diff --git a/Config.hs b/Config.hs deleted file mode 100644 --- a/Config.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE CPP #-} -module Config - ( module GHC.Version - , cBuildPlatformString - , cHostPlatformString - , cProjectName - , cBooterVersion - , cStage - ) where - -import GhcPrelude - -import GHC.Version - -cBuildPlatformString :: String -cBuildPlatformString = "x86_64-unknown-linux" - -cHostPlatformString :: String -cHostPlatformString = "x86_64-unknown-linux" - -cProjectName :: String -cProjectName = "The Glorious Glasgow Haskell Compilation System" - -cBooterVersion :: String -cBooterVersion = "8.10.7" - -cStage :: String -cStage = show (2 :: Int) diff --git a/GHC.hs b/GHC.hs new file mode 100644 --- /dev/null +++ b/GHC.hs @@ -0,0 +1,1756 @@ +{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-} +{-# LANGUAGE TupleSections, NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2012 +-- +-- The GHC API +-- +-- ----------------------------------------------------------------------------- + +module GHC ( + -- * Initialisation + defaultErrorHandler, + defaultCleanupHandler, + prettyPrintGhcErrors, + withSignalHandlers, + withCleanupSession, + + -- * GHC Monad + Ghc, GhcT, GhcMonad(..), HscEnv, + runGhc, runGhcT, initGhcMonad, + printException, + handleSourceError, + needsTemplateHaskellOrQQ, + + -- * Flags and settings + DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt, + GhcMode(..), GhcLink(..), defaultObjectTarget, + parseDynamicFlags, + getSessionDynFlags, setSessionDynFlags, + getProgramDynFlags, setProgramDynFlags, setLogAction, + getInteractiveDynFlags, setInteractiveDynFlags, + interpretPackageEnv, + + -- * Targets + Target(..), TargetId(..), Phase, + setTargets, + getTargets, + addTarget, + removeTarget, + guessTarget, + + -- * Loading\/compiling the program + depanal, depanalE, + load, LoadHowMuch(..), InteractiveImport(..), + SuccessFlag(..), succeeded, failed, + defaultWarnErrLogger, WarnErrLogger, + workingDirectoryChanged, + parseModule, typecheckModule, desugarModule, loadModule, + ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), + TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedMod, ParsedMod, + moduleInfo, renamedSource, typecheckedSource, + parsedSource, coreModule, + + -- ** Compiling to Core + CoreModule(..), + compileToCoreModule, compileToCoreSimplified, + + -- * Inspecting the module structure of the program + ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, + mgLookupModule, + ModSummary(..), ms_mod_name, ModLocation(..), + getModSummary, + getModuleGraph, + isLoaded, + topSortModuleGraph, + + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, + modInfoExports, + modInfoExportsWithSelectors, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, + modInfoIface, + modInfoRdrEnv, + modInfoSafe, + lookupGlobalName, + findGlobalAnns, + mkPrintUnqualifiedForModule, + ModIface, ModIface_(..), + SafeHaskellMode(..), + + -- * Querying the environment + -- packageDbModules, + + -- * Printing + PrintUnqualified, alwaysQualify, + + -- * Interactive evaluation + + -- ** Executing statements + execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), + resumeExec, + + -- ** Adding new declarations + runDecls, runDeclsWithLocation, runParsedDecls, + + -- ** Get/set the current context + parseImportDecl, + setContext, getContext, + setGHCiMonad, getGHCiMonad, + + -- ** Inspecting the current context + getBindings, getInsts, getPrintUnqual, + findModule, lookupModule, + isModuleTrusted, moduleTrustReqs, + getNamesInScope, + getRdrNamesInScope, + getGRE, + moduleIsInterpreted, + getInfo, + showModule, + moduleIsBootOrNotObjectLinkable, + getNameToInstancesIndex, + + -- ** Inspecting types and kinds + exprType, TcRnExprMode(..), + typeKind, + + -- ** Looking up a Name + parseName, + lookupName, + + -- ** Compiling expressions + HValue, parseExpr, compileParsedExpr, + GHC.Runtime.Eval.compileExpr, dynCompileExpr, + ForeignHValue, + compileExprRemote, compileParsedExprRemote, + + -- ** Docs + getDocs, GetDocsFailure(..), + + -- ** Other + runTcInteractive, -- Desired by some clients (#8878) + isStmt, hasImport, isImport, isDecl, + + -- ** The debugger + SingleStep(..), + Resume(..), + History(historyBreakInfo, historyEnclosingDecls), + GHC.getHistorySpan, getHistoryModule, + abandon, abandonAll, + getResumeContext, + GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, + modInfoModBreaks, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), + GHC.Runtime.Eval.back, + GHC.Runtime.Eval.forward, + + -- * Abstract syntax elements + + -- ** Units + Unit, + + -- ** Modules + Module, mkModule, pprModule, moduleName, moduleUnit, + ModuleName, mkModuleName, moduleNameString, + + -- ** Names + Name, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, + NamedThing(..), + RdrName(Qual,Unqual), + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isDeadEndId, isDictonaryId, + recordSelectorTyCon, + + -- ** Type constructors + TyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, + isPrimTyCon, isFunTyCon, + isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, + tyConClass_maybe, + synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, + + -- ** Type variables + TyVar, + alphaTyVars, + + -- ** Data constructors + DataCon, + dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, dataConWrapperType, + dataConSrcBangs, + StrictnessMark(..), isMarkedStrict, + + -- ** Classes + Class, + classMethods, classSCTheta, classTvsFds, classATs, + pprFundeps, + + -- ** Instances + ClsInst, + instanceDFunId, + pprInstance, pprInstanceHdr, + pprFamInst, + + FamInst, + + -- ** Types and Kinds + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, + Kind, + PredType, + ThetaType, pprForAll, pprThetaArrowTy, + parseInstanceHead, + getInstancesForType, + + -- ** Entities + TyThing(..), + + -- ** Syntax + module GHC.Hs, -- ToDo: remove extraneous bits + + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, + LexicalFixity(..), + + -- ** Source locations + SrcLoc(..), RealSrcLoc, + mkSrcLoc, noSrcLoc, + srcLocFile, srcLocLine, srcLocCol, + SrcSpan(..), RealSrcSpan, + mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, + srcSpanStart, srcSpanEnd, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Located + GenLocated(..), Located, RealLocated, + + -- *** Constructing Located + noLoc, mkGeneralLocated, + + -- *** Deconstructing Located + getLoc, unLoc, + getRealSrcSpan, unRealSrcSpan, + + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost_smallest, + spans, isSubspanOf, + + -- * Exceptions + GhcException(..), showGhcException, + + -- * Token stream manipulations + Token, + getTokenStream, getRichTokenStream, + showRichTokenStream, addSourceToTokens, + + -- * Pure interface to the parser + parser, + + -- * API Annotations + ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey, + getAnnotation, getAndRemoveAnnotation, + getAnnotationComments, getAndRemoveAnnotationComments, + unicodeAnn, + + -- * Miscellaneous + --sessionHscEnv, + cyclicModuleErr, + ) where + +{- + ToDo: + + * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt. +-} + +#include "HsVersions.h" + +import GHC.Prelude hiding (init) + +import GHC.ByteCode.Types +import GHC.Runtime.Eval +import GHC.Runtime.Eval.Types +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types +import GHCi.RemoteTypes + +import GHC.Core.Ppr.TyThing ( pprFamInst ) +import GHC.Driver.Main +import GHC.Driver.Make +import GHC.Driver.Hooks +import GHC.Driver.Pipeline ( compileOne' ) +import GHC.Driver.Monad +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) +import GHC.Iface.Load ( loadSysInterface ) +import GHC.Tc.Types +import GHC.Core.Predicate +import GHC.Unit.State +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Hs +import GHC.Core.Type hiding( typeKind ) +import GHC.Tc.Utils.TcType +import GHC.Types.Id +import GHC.Builtin.Types.Prim ( alphaTyVars ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr ( pprForAll ) +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts ) +import GHC.Core.InstEnv +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Avail +import GHC.Types.SrcLoc +import GHC.Core +import GHC.Iface.Tidy +import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename ) +import GHC.Driver.Finder +import GHC.Driver.Types +import GHC.Driver.CmdLine +import GHC.Driver.Session hiding (WarnReason(..)) +import GHC.Driver.Ways +import GHC.SysTools +import GHC.SysTools.BaseDir +import GHC.Types.Annotations +import GHC.Unit.Module +import GHC.Utils.Panic +import GHC.Platform +import GHC.Data.Bag ( listToBag ) +import GHC.Utils.Error +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Data.StringBuffer +import GHC.Utils.Outputable +import GHC.Types.Basic +import GHC.Data.FastString +import qualified GHC.Parser as Parser +import GHC.Parser.Lexer +import GHC.Parser.Annotation +import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.Name.Env +import GHC.Tc.Module +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Family +import GHC.SysTools.FileCleanup + +import Data.Foldable +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Sequence as Seq +import Data.Maybe +import Data.Time +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) +import Control.Monad +import System.Exit ( exitWith, ExitCode(..) ) +import GHC.Utils.Exception +import Data.IORef +import System.FilePath +import Control.Concurrent +import Control.Applicative ((<|>)) +import Control.Monad.Catch as MC + +import GHC.Data.Maybe +import System.IO.Error ( isDoesNotExistError ) +import System.Environment ( getEnv ) +import System.Directory + + +-- %************************************************************************ +-- %* * +-- Initialisation: exception handlers +-- %* * +-- %************************************************************************ + + +-- | Install some default exception handlers and run the inner computation. +-- Unless you want to handle exceptions yourself, you should wrap this around +-- the top level of your program. The default handlers output the error +-- message(s) to stderr and exit cleanly. +defaultErrorHandler :: (ExceptionMonad m) + => FatalMessager -> FlushOut -> m a -> m a +defaultErrorHandler fm (FlushOut flushOut) inner = + -- top-level exception handler: any unrecognised exception is a compiler bug. + MC.handle (\exception -> liftIO $ do + flushOut + case fromException exception of + -- an IO exception probably isn't our fault, so don't panic + Just (ioe :: IOException) -> + fatalErrorMsg'' fm (show ioe) + _ -> case fromException exception of + Just UserInterrupt -> + -- Important to let this one propagate out so our + -- calling process knows we were interrupted by ^C + liftIO $ throwIO UserInterrupt + Just StackOverflow -> + fatalErrorMsg'' fm "stack overflow: use +RTS -K to increase it" + _ -> case fromException exception of + Just (ex :: ExitCode) -> liftIO $ throwIO ex + _ -> + fatalErrorMsg'' fm + (show (Panic (show exception))) + exitWith (ExitFailure 1) + ) $ + + -- error messages propagated as exceptions + handleGhcException + (\ge -> liftIO $ do + flushOut + case ge of + Signal _ -> exitWith (ExitFailure 1) + _ -> do fatalErrorMsg'' fm (show ge) + exitWith (ExitFailure 1) + ) $ + inner + +-- | This function is no longer necessary, cleanup is now done by +-- runGhc/runGhcT. +{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} +defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a +defaultCleanupHandler _ m = m + where _warning_suppression = m `MC.onException` undefined + + +-- %************************************************************************ +-- %* * +-- The Ghc Monad +-- %* * +-- %************************************************************************ + +-- | Run function for the 'Ghc' monad. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. +-- +-- Any errors not handled inside the 'Ghc' action are propagated as IO +-- exceptions. + +runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> Ghc a -- ^ The action to perform. + -> IO a +runGhc mb_top_dir ghc = do + ref <- newIORef (panic "empty session") + let session = Session ref + flip unGhc session $ withSignalHandlers $ do -- catch ^C + initGhcMonad mb_top_dir + withCleanupSession ghc + +-- | Run function for 'GhcT' monad transformer. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. + +runGhcT :: ExceptionMonad m => + Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> GhcT m a -- ^ The action to perform. + -> m a +runGhcT mb_top_dir ghct = do + ref <- liftIO $ newIORef (panic "empty session") + let session = Session ref + flip unGhcT session $ withSignalHandlers $ do -- catch ^C + initGhcMonad mb_top_dir + withCleanupSession ghct + +withCleanupSession :: GhcMonad m => m a -> m a +withCleanupSession ghc = ghc `MC.finally` cleanup + where + cleanup = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + liftIO $ do + cleanTempFiles dflags + cleanTempDirs dflags + stopInterp hsc_env -- shut down the IServ + -- exceptions will be blocked while we clean the temporary files, + -- so there shouldn't be any difficulty if we receive further + -- signals. + +-- | Initialise a GHC session. +-- +-- If you implement a custom 'GhcMonad' you must call this function in the +-- monad run function. It will initialise the session variable and clear all +-- warnings. +-- +-- The first argument should point to the directory where GHC's library files +-- reside. More precisely, this should be the output of @ghc --print-libdir@ +-- of the version of GHC the module using this API is compiled with. For +-- portability, you should use the @ghc-paths@ package, available at +-- . + +initGhcMonad :: GhcMonad m => Maybe FilePath -> m () +initGhcMonad mb_top_dir + = do { env <- liftIO $ + do { top_dir <- findTopDir mb_top_dir + ; mySettings <- initSysTools top_dir + ; myLlvmConfig <- lazyInitLlvmConfig top_dir + ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) + ; checkBrokenTablesNextToCode dflags + ; setUnsafeGlobalDynFlags dflags + -- c.f. DynFlags.parseDynamicFlagsFull, which + -- creates DynFlags and sets the UnsafeGlobalDynFlags + ; newHscEnv dflags } + ; setSession env } + +-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which +-- breaks tables-next-to-code in dynamically linked modules. This +-- check should be more selective but there is currently no released +-- version where this bug is fixed. +-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and +-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 +checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () +checkBrokenTablesNextToCode dflags + = do { broken <- checkBrokenTablesNextToCode' dflags + ; when broken + $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr + ; liftIO $ fail "unsupported linker" + } + } + where + invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> + text "when using binutils ld (please see:" <+> + text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" + +checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool +checkBrokenTablesNextToCode' dflags + | not (isARM arch) = return False + | WayDyn `S.notMember` ways dflags = return False + | not tablesNextToCode = return False + | otherwise = do + linkerInfo <- liftIO $ getLinkerInfo dflags + case linkerInfo of + GnuLD _ -> return True + _ -> return False + where platform = targetPlatform dflags + arch = platformArch platform + tablesNextToCode = platformTablesNextToCode platform + + +-- %************************************************************************ +-- %* * +-- Flags & settings +-- %* * +-- %************************************************************************ + +-- $DynFlags +-- +-- The GHC session maintains two sets of 'DynFlags': +-- +-- * The "interactive" @DynFlags@, which are used for everything +-- related to interactive evaluation, including 'runStmt', +-- 'runDecls', 'exprType', 'lookupName' and so on (everything +-- under \"Interactive evaluation\" in this module). +-- +-- * The "program" @DynFlags@, which are used when loading +-- whole modules with 'load' +-- +-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the +-- interactive @DynFlags@. +-- +-- 'setProgramDynFlags', 'getProgramDynFlags' work with the +-- program @DynFlags@. +-- +-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' +-- retrieves the program @DynFlags@ (for backwards compatibility). + + +-- | Updates both the interactive and program DynFlags in a Session. +-- This also reads the package database (unless it has already been +-- read), and prepares the compilers knowledge about packages. It can +-- be called again to load new packages: just add new package flags to +-- (packageFlags dflags). +-- +-- Returns a list of new packages that may need to be linked in using +-- the dynamic linker (see 'linkPackages') as a result of new package +-- flags. If you are not doing linking or doing static linking, you +-- can ignore the list of packages returned. +-- +setSessionDynFlags :: GhcMonad m => DynFlags -> m () +setSessionDynFlags dflags = do + dflags' <- checkNewDynFlags dflags + dflags''' <- liftIO $ initUnits dflags' + + -- Interpreter + interp <- if gopt Opt_ExternalInterpreter dflags + then do + let + prog = pgm_i dflags ++ flavour + profiled = ways dflags `hasWay` WayProf + dynamic = ways dflags `hasWay` WayDyn + flavour + | profiled = "-prof" -- FIXME: can't we have both? + | dynamic = "-dyn" + | otherwise = "" + msg = text "Starting " <> text prog + tr <- if verbosity dflags >= 3 + then return (logInfo dflags $ withPprStyle defaultDumpStyle msg) + else return (pure ()) + let + conf = IServConfig + { iservConfProgram = prog + , iservConfOpts = getOpts dflags opt_i + , iservConfProfiled = profiled + , iservConfDynamic = dynamic + , iservConfHook = createIservProcessHook (hooks dflags) + , iservConfTrace = tr + } + s <- liftIO $ newMVar IServPending + return (Just (ExternalInterp conf (IServ s))) + else +#if defined(HAVE_INTERNAL_INTERPRETER) + return (Just InternalInterp) +#else + return Nothing +#endif + + modifySession $ \h -> h{ hsc_dflags = dflags''' + , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' } + , hsc_interp = hsc_interp h <|> interp + -- we only update the interpreter if there wasn't + -- already one set up + } + invalidateModSummaryCache + +-- | Sets the program 'DynFlags'. Note: this invalidates the internal +-- cached module graph, causing more work to be done the next time +-- 'load' is called. +-- +-- Returns a boolean indicating if preload units have changed and need to be +-- reloaded. +setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool +setProgramDynFlags dflags = setProgramDynFlags_ True dflags + +-- | Set the action taken when the compiler produces a message. This +-- can also be accomplished using 'setProgramDynFlags', but using +-- 'setLogAction' avoids invalidating the cached module graph. +setLogAction :: GhcMonad m => LogAction -> m () +setLogAction action = do + dflags' <- getProgramDynFlags + void $ setProgramDynFlags_ False $ + dflags' { log_action = action } + +setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool +setProgramDynFlags_ invalidate_needed dflags = do + dflags' <- checkNewDynFlags dflags + dflags_prev <- getProgramDynFlags + let changed = packageFlagsChanged dflags_prev dflags' + dflags'' <- if changed + then liftIO $ initUnits dflags' + else return dflags' + modifySession $ \h -> h{ hsc_dflags = dflags'' } + when invalidate_needed $ invalidateModSummaryCache + return changed + + +-- When changing the DynFlags, we want the changes to apply to future +-- loads, but without completely discarding the program. But the +-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so +-- after a change to DynFlags, the changes would apply to new modules +-- but not existing modules; this seems undesirable. +-- +-- Furthermore, the GHC API client might expect that changing +-- log_action would affect future compilation messages, but for those +-- modules we have cached ModSummaries for, we'll continue to use the +-- old log_action. This is definitely wrong (#7478). +-- +-- Hence, we invalidate the ModSummary cache after changing the +-- DynFlags. We do this by tweaking the date on each ModSummary, so +-- that the next downsweep will think that all the files have changed +-- and preprocess them again. This won't necessarily cause everything +-- to be recompiled, because by the time we check whether we need to +-- recompile a module, we'll have re-summarised the module and have a +-- correct ModSummary. +-- +invalidateModSummaryCache :: GhcMonad m => m () +invalidateModSummaryCache = + modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } + where + inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } + +-- | Returns the program 'DynFlags'. +getProgramDynFlags :: GhcMonad m => m DynFlags +getProgramDynFlags = getSessionDynFlags + +-- | Set the 'DynFlags' used to evaluate interactive expressions. +-- Note: this cannot be used for changes to packages. Use +-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the +-- 'unitState' into the interactive @DynFlags@. +setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () +setInteractiveDynFlags dflags = do + dflags' <- checkNewDynFlags dflags + dflags'' <- checkNewInteractiveDynFlags dflags' + modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }} + +-- | Get the 'DynFlags' used to evaluate interactive expressions. +getInteractiveDynFlags :: GhcMonad m => m DynFlags +getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) + + +parseDynamicFlags :: MonadIO m => + DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) +parseDynamicFlags dflags cmdline = do + (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline + dflags2 <- liftIO $ interpretPackageEnv dflags1 + return (dflags2, leftovers, warns) + + +-- | Checks the set of new DynFlags for possibly erroneous option +-- combinations when invoking 'setSessionDynFlags' and friends, and if +-- found, returns a fixed copy (if possible). +checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags +checkNewDynFlags dflags = do + -- See Note [DynFlags consistency] + let (dflags', warnings) = makeDynFlagsConsistent dflags + liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings) + return dflags' + +checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags +checkNewInteractiveDynFlags dflags0 = do + -- We currently don't support use of StaticPointers in expressions entered on + -- the REPL. See #12356. + if xopt LangExt.StaticPointers dflags0 + then do liftIO $ printOrThrowWarnings dflags0 $ listToBag + [mkPlainWarnMsg dflags0 interactiveSrcSpan + $ text "StaticPointers is not supported in GHCi interactive expressions."] + return $ xopt_unset dflags0 LangExt.StaticPointers + else return dflags0 + + +-- %************************************************************************ +-- %* * +-- Setting, getting, and modifying the targets +-- %* * +-- %************************************************************************ + +-- ToDo: think about relative vs. absolute file paths. And what +-- happens when the current directory changes. + +-- | Sets the targets for this session. Each target may be a module name +-- or a filename. The targets correspond to the set of root modules for +-- the program\/library. Unloading the current program is achieved by +-- setting the current set of targets to be empty, followed by 'load'. +setTargets :: GhcMonad m => [Target] -> m () +setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) + +-- | Returns the current set of targets +getTargets :: GhcMonad m => m [Target] +getTargets = withSession (return . hsc_targets) + +-- | Add another target. +addTarget :: GhcMonad m => Target -> m () +addTarget target + = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) + +-- | Remove a target +removeTarget :: GhcMonad m => TargetId -> m () +removeTarget target_id + = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) + where + filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] + +-- | Attempts to guess what Target a string refers to. This function +-- implements the @--make@/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- +-- - otherwise interpret the string as a module name +-- +guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target +guessTarget str (Just phase) + = return (Target (TargetFile str (Just phase)) True Nothing) +guessTarget str Nothing + | isHaskellSrcFilename file + = return (target (TargetFile file Nothing)) + | otherwise + = do exists <- liftIO $ doesFileExist hs_file + if exists + then return (target (TargetFile hs_file Nothing)) + else do + exists <- liftIO $ doesFileExist lhs_file + if exists + then return (target (TargetFile lhs_file Nothing)) + else do + if looksLikeModuleName file + then return (target (TargetModule (mkModuleName file))) + else do + dflags <- getDynFlags + liftIO $ throwGhcExceptionIO + (ProgramError (showSDoc dflags $ + text "target" <+> quotes (text file) <+> + text "is not a module name or a source file")) + where + (file,obj_allowed) + | '*':rest <- str = (rest, False) + | otherwise = (str, True) + + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" + + target tid = Target tid obj_allowed Nothing + + +-- | Inform GHC that the working directory has changed. GHC will flush +-- its cache of module locations, since it may no longer be valid. +-- +-- Note: Before changing the working directory make sure all threads running +-- in the same session have stopped. If you change the working directory, +-- you should also unload the current program (set targets to empty, +-- followed by load). +workingDirectoryChanged :: GhcMonad m => m () +workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) + + +-- %************************************************************************ +-- %* * +-- Running phases one at a time +-- %* * +-- %************************************************************************ + +class ParsedMod m where + modSummary :: m -> ModSummary + parsedSource :: m -> ParsedSource + +class ParsedMod m => TypecheckedMod m where + renamedSource :: m -> Maybe RenamedSource + typecheckedSource :: m -> TypecheckedSource + moduleInfo :: m -> ModuleInfo + tm_internals :: m -> (TcGblEnv, ModDetails) + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields. + +class TypecheckedMod m => DesugaredMod m where + coreModule :: m -> ModGuts + +-- | The result of successful parsing. +data ParsedModule = + ParsedModule { pm_mod_summary :: ModSummary + , pm_parsed_source :: ParsedSource + , pm_extra_src_files :: [FilePath] + , pm_annotations :: ApiAnns } + -- See Note [Api annotations] in GHC.Parser.Annotation + +instance ParsedMod ParsedModule where + modSummary m = pm_mod_summary m + parsedSource m = pm_parsed_source m + +-- | The result of successful typechecking. It also contains the parser +-- result. +data TypecheckedModule = + TypecheckedModule { tm_parsed_module :: ParsedModule + , tm_renamed_source :: Maybe RenamedSource + , tm_typechecked_source :: TypecheckedSource + , tm_checked_module_info :: ModuleInfo + , tm_internals_ :: (TcGblEnv, ModDetails) + } + +instance ParsedMod TypecheckedModule where + modSummary m = modSummary (tm_parsed_module m) + parsedSource m = parsedSource (tm_parsed_module m) + +instance TypecheckedMod TypecheckedModule where + renamedSource m = tm_renamed_source m + typecheckedSource m = tm_typechecked_source m + moduleInfo m = tm_checked_module_info m + tm_internals m = tm_internals_ m + +-- | The result of successful desugaring (i.e., translation to core). Also +-- contains all the information of a typechecked module. +data DesugaredModule = + DesugaredModule { dm_typechecked_module :: TypecheckedModule + , dm_core_module :: ModGuts + } + +instance ParsedMod DesugaredModule where + modSummary m = modSummary (dm_typechecked_module m) + parsedSource m = parsedSource (dm_typechecked_module m) + +instance TypecheckedMod DesugaredModule where + renamedSource m = renamedSource (dm_typechecked_module m) + typecheckedSource m = typecheckedSource (dm_typechecked_module m) + moduleInfo m = moduleInfo (dm_typechecked_module m) + tm_internals m = tm_internals_ (dm_typechecked_module m) + +instance DesugaredMod DesugaredModule where + coreModule m = dm_core_module m + +type ParsedSource = Located HsModule +type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], + Maybe LHsDocString) +type TypecheckedSource = LHsBinds GhcTc + +-- NOTE: +-- - things that aren't in the output of the typechecker right now: +-- - the export list +-- - the imports +-- - type signatures +-- - type/data/newtype declarations +-- - class declarations +-- - instances +-- - extra things in the typechecker's output: +-- - default methods are turned into top-level decls. +-- - dictionary bindings + +-- | Return the 'ModSummary' of a module with the given name. +-- +-- The module must be part of the module graph (see 'hsc_mod_graph' and +-- 'ModuleGraph'). If this is not the case, this function will throw a +-- 'GhcApiError'. +-- +-- This function ignores boot modules and requires that there is only one +-- non-boot module with the given name. +getModSummary :: GhcMonad m => ModuleName -> m ModSummary +getModSummary mod = do + mg <- liftM hsc_mod_graph getSession + let mods_by_name = [ ms | ms <- mgModSummaries mg + , ms_mod_name ms == mod + , isBootSummary ms == NotBoot ] + case mods_by_name of + [] -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph") + [ms] -> return ms + multiple -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) + +-- | Parse a module. +-- +-- Throws a 'SourceError' on parse error. +parseModule :: GhcMonad m => ModSummary -> m ParsedModule +parseModule ms = do + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + hpm <- liftIO $ hscParse hsc_env_tmp ms + return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) + (hpm_annotations hpm)) + -- See Note [Api annotations] in GHC.Parser.Annotation + +-- | Typecheck and rename a parsed module. +-- +-- Throws a 'SourceError' if either fails. +typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule +typecheckModule pmod = do + let ms = modSummary pmod + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + (tc_gbl_env, rn_info) + <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod, + hpm_annotations = pm_annotations pmod } + details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env + + return $ + TypecheckedModule { + tm_internals_ = (tc_gbl_env, details), + tm_parsed_module = pmod, + tm_renamed_source = rn_info, + tm_typechecked_source = tcg_binds tc_gbl_env, + tm_checked_module_info = + ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), + minf_instances = fixSafeInstances safe $ md_insts details, + minf_iface = Nothing, + minf_safe = safe, + minf_modBreaks = emptyModBreaks + }} + +-- | Desugar a typechecked module. +desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule +desugarModule tcm = do + let ms = modSummary tcm + let (tcg, _) = tm_internals tcm + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg + return $ + DesugaredModule { + dm_typechecked_module = tcm, + dm_core_module = guts + } + +-- | Load a module. Input doesn't need to be desugared. +-- +-- A module must be loaded before dependent modules can be typechecked. This +-- always includes generating a 'ModIface' and, depending on the +-- @DynFlags@\'s 'GHC.Driver.Session.hscTarget', may also include code generation. +-- +-- This function will always cause recompilation and will always overwrite +-- previous compilation results (potentially files on disk). +-- +loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod +loadModule tcm = do + let ms = modSummary tcm + let mod = ms_mod_name ms + let loc = ms_location ms + let (tcg, _details) = tm_internals tcm + + mb_linkable <- case ms_obj_date ms of + Just t | t > ms_hs_date ms -> do + l <- liftIO $ findObjectLinkable (ms_mod ms) + (ml_obj_file loc) t + return (Just l) + _otherwise -> return Nothing + + let source_modified | isNothing mb_linkable = SourceModified + | otherwise = SourceUnmodified + -- we can't determine stability here + + -- compile doesn't change the session + hsc_env <- getSession + mod_info <- liftIO $ compileOne' (Just tcg) Nothing + hsc_env ms 1 1 Nothing mb_linkable + source_modified + + modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info } + return tcm + + +-- %************************************************************************ +-- %* * +-- Dealing with Core +-- %* * +-- %************************************************************************ + +-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for +-- the 'GHC.compileToCoreModule' interface. +data CoreModule + = CoreModule { + -- | Module name + cm_module :: !Module, + -- | Type environment for types declared in this module + cm_types :: !TypeEnv, + -- | Declarations + cm_binds :: CoreProgram, + -- | Safe Haskell mode + cm_safe :: SafeHaskellMode + } + +instance Outputable CoreModule where + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, + cm_safe = sf}) + = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te + $$ vcat (map ppr cb) + +-- | This is the way to get access to the Core bindings corresponding +-- to a module. 'compileToCore' parses, typechecks, and +-- desugars the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule +compileToCoreSimplified = compileCore True + +compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule +compileCore simplify fn = do + -- First, set the target to the desired filename + target <- guessTarget fn Nothing + addTarget target + _ <- load LoadAllTargets + -- Then find dependencies + modGraph <- depanal [] True + case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of + Just modSummary -> do + -- Now we have the module name; + -- parse, typecheck and desugar the module + (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly? + do tm <- typecheckModule =<< parseModule modSummary + let tcg = fst (tm_internals tm) + (,) tcg . coreModule <$> desugarModule tm + liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ + if simplify + then do + -- If simplify is true: simplify (hscSimplify), then tidy + -- (tidyProgram). + hsc_env <- getSession + simpl_guts <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tcg) + hscSimplify hsc_env plugins mod_guts + tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts + return $ Left tidy_guts + else + return $ Right mod_guts + + Nothing -> panic "compileToCoreModule: target FilePath not found in\ + module dependency graph" + where -- two versions, based on whether we simplify (thus run tidyProgram, + -- which returns a (CgGuts, ModDetails) pair, or not (in which case + -- we just have a ModGuts. + gutsToCoreModule :: SafeHaskellMode + -> Either (CgGuts, ModDetails) ModGuts + -> CoreModule + gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { + cm_module = cg_module cg, + cm_types = md_types md, + cm_binds = cg_binds cg, + cm_safe = safe_mode + } + gutsToCoreModule safe_mode (Right mg) = CoreModule { + cm_module = mg_module mg, + cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) + (mg_tcs mg) + (mg_fam_insts mg), + cm_binds = mg_binds mg, + cm_safe = safe_mode + } + +-- %************************************************************************ +-- %* * +-- Inspecting the session +-- %* * +-- %************************************************************************ + +-- | Get the module dependency graph. +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession + +-- | Return @True@ \<==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> + return $! isJust (lookupHpt (hsc_HPT hsc_env) m) + +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +getBindings = withSession $ \hsc_env -> + return $ icInScopeTTs $ hsc_IC hsc_env + +-- | Return the instances for the current interactive session. +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) +getInsts = withSession $ \hsc_env -> + return $ ic_instances (hsc_IC hsc_env) + +getPrintUnqual :: GhcMonad m => m PrintUnqualified +getPrintUnqual = withSession $ \hsc_env -> + return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: [AvailInfo], + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_instances :: [ClsInst], + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode, + minf_modBreaks :: ModBreaks + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do + let mg = hsc_mod_graph hsc_env + if mgElemModule mg mdl + then liftIO $ getHomeModuleInfo hsc_env mdl + else do + {- if isHomeModule (hsc_dflags hsc_env) mdl + then return Nothing + else -} liftIO $ getPackageModuleInfo hsc_env mdl + -- ToDo: we don't understand what the following comment means. + -- (SDM, 19/7/2011) + -- getPackageModuleInfo will attempt to find the interface, so + -- we don't want to call it for a home module, just in case there + -- was a problem loading the module and the interface doesn't + -- exist... hence the isHomeModule test here. (ToDo: reinstate) + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getPackageModuleInfo hsc_env mdl + = do eps <- hscEPS hsc_env + iface <- hscGetModuleInterface hsc_env mdl + let + avails = mi_exports iface + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = avails, + minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = emptyModBreaks + })) + +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getHomeModuleInfo hsc_env mdl = + case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + iface = hm_iface hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details, + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface + ,minf_modBreaks = getModBreaks hmi + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] +modInfoTopLevelScope minf + = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = concatMap availNames $! minf_exports minf + +modInfoExportsWithSelectors :: ModuleInfo -> [Name] +modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [ClsInst] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) + +mkPrintUnqualifiedForModule :: GhcMonad m => + ModuleInfo + -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X +mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do + return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) + +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> do + eps <- liftIO $ readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name + +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + +modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv +modInfoRdrEnv = minf_rdr_env + +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + +modInfoModBreaks :: ModuleInfo -> ModBreaks +modInfoModBreaks = minf_modBreaks + +isDictonaryId :: Id -> Bool +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { + (_tvs, _theta, tau) -> isDictTy tau } + +-- | Looks up a global name: that is, any top-level name in any +-- visible module. Unlike 'lookupName', lookupGlobalName does not use +-- the interactive context, and therefore does not require a preceding +-- 'setContext'. +lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupGlobalName name = withSession $ \hsc_env -> do + liftIO $ lookupTypeHscEnv hsc_env name + +findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] +findGlobalAnns deserialize target = withSession $ \hsc_env -> do + ann_env <- liftIO $ prepareAnnotations hsc_env Nothing + return (findAnns deserialize ann_env target) + +-- | get the GlobalRdrEnv for a session +getGRE :: GhcMonad m => m GlobalRdrEnv +getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) + +-- | Retrieve all type and family instances in the environment, indexed +-- by 'Name'. Each name's lists will contain every instance in which that name +-- is mentioned in the instance head. +getNameToInstancesIndex :: GhcMonad m + => [Module] -- ^ visible modules. An orphan instance will be returned + -- if it is visible from at least one module in the list. + -> Maybe [Module] -- ^ modules to load. If this is not specified, we load + -- modules for everything that is in scope unqualified. + -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) +getNameToInstancesIndex visible_mods mods_to_load = do + hsc_env <- getSession + liftIO $ runTcInteractive hsc_env $ + do { case mods_to_load of + Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env) + Just mods -> + let doc = text "Need interface for reporting instances in scope" + in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods + + ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs + ; let visible_mods' = mkModuleSet visible_mods + ; (pkg_fie, home_fie) <- tcGetFamInstEnvs + -- We use Data.Sequence.Seq because we are creating left associated + -- mappends. + -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts + ; let cls_index = Map.fromListWith mappend + [ (n, Seq.singleton ispec) + | ispec <- instEnvElts ie_local ++ instEnvElts ie_global + , instIsVisible visible_mods' ispec + , n <- nameSetElemsStable $ orphNamesOfClsInst ispec + ] + ; let fam_index = Map.fromListWith mappend + [ (n, Seq.singleton fispec) + | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie + , n <- nameSetElemsStable $ orphNamesOfFamInst fispec + ] + ; return $ mkNameEnv $ + [ (nm, (toList clss, toList fams)) + | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend + (fmap (,Seq.empty) cls_index) + (fmap (Seq.empty,) fam_index) + ] } + +-- ----------------------------------------------------------------------------- + +{- ToDo: Move the primary logic here to "GHC.Unit.State" +-- | Return all /external/ modules available in the package database. +-- Modules from the current session (i.e., from the 'HomePackageTable') are +-- not included. This includes module names which are reexported by packages. +packageDbModules :: GhcMonad m => + Bool -- ^ Only consider exposed packages. + -> m [Module] +packageDbModules only_exposed = do + dflags <- getSessionDynFlags + let pkgs = eltsUFM (unitInfoMap (unitState dflags)) + return $ + [ mkModule pid modname + | p <- pkgs + , not only_exposed || exposed p + , let pid = mkUnit p + , modname <- exposedModules p + ++ map exportName (reexportedModules p) ] + -} + +-- ----------------------------------------------------------------------------- +-- Misc exported utils + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +-- | print a 'NamedThing', adding parentheses if the name is an operator. +pprParenSymName :: NamedThing a => a -> SDoc +pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) + +-- ---------------------------------------------------------------------------- + + +-- ToDo: +-- - Data and Typeable instances for HsSyn. + +-- ToDo: check for small transformations that happen to the syntax in +-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) + +-- ToDo: maybe use TH syntax instead of Iface syntax? There's already a way +-- to get from TyCons, Ids etc. to TH syntax (reify). + +-- :browse will use either lm_toplev or inspect lm_interface, depending +-- on whether the module is interpreted or not. + + +-- Extract the filename, stringbuffer content and dynflags associed to a module +-- +-- XXX: Explain pre-conditions +getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) +getModuleSourceAndFlags mod = do + m <- getModSummary (moduleName mod) + case ml_hs_file $ ms_location m of + Nothing -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod) + Just sourceFile -> do + source <- liftIO $ hGetStringBuffer sourceFile + return (sourceFile, source, ms_hspp_opts m) + + +-- | Return module source as token stream, including comments. +-- +-- The module must be in the module graph and its source must be available. +-- Throws a 'GHC.Driver.Types.SourceError' on parse error. +getTokenStream :: GhcMonad m => Module -> m [Located Token] +getTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + case lexTokenStream source startLoc flags of + POk _ ts -> return ts + PFailed pst -> + do dflags <- getDynFlags + throwErrors (getErrorMessages pst dflags) + +-- | Give even more information on the source than 'getTokenStream' +-- This function allows reconstructing the source completely with +-- 'showRichTokenStream'. +getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] +getRichTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + case lexTokenStream source startLoc flags of + POk _ ts -> return $ addSourceToTokens startLoc source ts + PFailed pst -> + do dflags <- getDynFlags + throwErrors (getErrorMessages pst dflags) + +-- | Given a source location and a StringBuffer corresponding to this +-- location, return a rich token stream with the source associated to the +-- tokens. +addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] + -> [(Located Token, String)] +addSourceToTokens _ _ [] = [] +addSourceToTokens loc buf (t@(L span _) : ts) + = case span of + UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts + RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts + where + (newLoc, newBuf, str) = go "" loc buf + start = realSrcSpanStart s + end = realSrcSpanEnd s + go acc loc buf | loc < start = go acc nLoc nBuf + | start <= loc && loc < end = go (ch:acc) nLoc nBuf + | otherwise = (loc, buf, reverse acc) + where (ch, nBuf) = nextChar buf + nLoc = advanceSrcLoc loc ch + + +-- | Take a rich token stream such as produced from 'getRichTokenStream' and +-- return source code almost identical to the original code (except for +-- insignificant whitespace.) +showRichTokenStream :: [(Located Token, String)] -> String +showRichTokenStream ts = go startLoc ts "" + where sourceFile = getFile $ map (getLoc . fst) ts + getFile [] = panic "showRichTokenStream: No source file found" + getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (RealSrcSpan s _ : _) = srcSpanFile s + startLoc = mkRealSrcLoc sourceFile 1 1 + go _ [] = id + go loc ((L span _, str):ts) + = case span of + UnhelpfulSpan _ -> go loc ts + RealSrcSpan s _ + | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) + . (str ++) + . go tokEnd ts + | otherwise -> ((replicate (tokLine - locLine) '\n') ++) + . ((replicate (tokCol - 1) ' ') ++) + . (str ++) + . go tokEnd ts + where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) + (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) + tokEnd = realSrcSpanEnd s + +-- ----------------------------------------------------------------------------- +-- Interactive evaluation + +-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the +-- filesystem and package database to find the corresponding 'Module', +-- using the algorithm that is used for an @import@ declaration. +findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +findModule mod_name maybe_pkg = withSession $ \hsc_env -> do + let + dflags = hsc_dflags hsc_env + this_pkg = homeUnit dflags + -- + case maybe_pkg of + Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found _ m -> return m + err -> throwOneError $ noModError dflags noSrcSpan mod_name err + _otherwise -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found loc m | moduleUnit m /= this_pkg -> return m + | otherwise -> modNotLoadedError dflags m loc + err -> throwOneError $ noModError dflags noSrcSpan mod_name err + +modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a +modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ + text "module is not loaded:" <+> + quotes (ppr (moduleName m)) <+> + parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) + +-- | Like 'findModule', but differs slightly when the module refers to +-- a source file, and the file has not been loaded via 'load'. In +-- this case, 'findModule' will throw an error (module not loaded), +-- but 'lookupModule' will check to see whether the module can also be +-- found in a package, and if so, that package 'Module' will be +-- returned. If not, the usual module-not-found error will be thrown. +-- +lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) +lookupModule mod_name Nothing = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findExposedPackageModule hsc_env mod_name Nothing + case res of + Found _ m -> return m + err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + +lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> + case lookupHpt (hsc_HPT hsc_env) mod_name of + Just mod_info -> return (Just (mi_module (hm_iface mod_info))) + _not_a_home_module -> return Nothing + +-- | Check that a module is safe to import (according to Safe Haskell). +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an error may be thrown first. +isModuleTrusted :: GhcMonad m => Module -> m Bool +isModuleTrusted m = withSession $ \hsc_env -> + liftIO $ hscCheckSafe hsc_env m noSrcSpan + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) +moduleTrustReqs m = withSession $ \hsc_env -> + liftIO $ hscGetSafe hsc_env m noSrcSpan + +-- | Set the monad GHCi lifts user statements into. +-- +-- Checks that a type (in string form) is an instance of the +-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, +-- throws an error otherwise. +setGHCiMonad :: GhcMonad m => String -> m () +setGHCiMonad name = withSession $ \hsc_env -> do + ty <- liftIO $ hscIsGHCiMonad hsc_env name + modifySession $ \s -> + let ic = (hsc_IC s) { ic_monad = ty } + in s { hsc_IC = ic } + +-- | Get the monad GHCi lifts user statements into. +getGHCiMonad :: GhcMonad m => m Name +getGHCiMonad = fmap (ic_monad . hsc_IC) getSession + +getHistorySpan :: GhcMonad m => History -> m SrcSpan +getHistorySpan h = withSession $ \hsc_env -> + return $ GHC.Runtime.Eval.getHistorySpan hsc_env h + +obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term +obtainTermFromVal bound force ty a = withSession $ \hsc_env -> + liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a + +obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term +obtainTermFromId bound force id = withSession $ \hsc_env -> + liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id + + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupName name = + withSession $ \hsc_env -> + liftIO $ hscTcRcLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Pure API + +-- | A pure interface to the module parser. +-- +parser :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags -- ^ the flags + -> FilePath -- ^ the filename (for source locations) + -> (WarningMessages, Either ErrorMessages (Located HsModule)) + +parser str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case unP Parser.parseModule (mkPState dflags buf loc) of + + PFailed pst -> + let (warns,errs) = getMessages pst dflags in + (warns, Left errs) + + POk pst rdr_module -> + let (warns,_) = getMessages pst dflags in + (warns, Right rdr_module) + +-- ----------------------------------------------------------------------------- +-- | Find the package environment (if one exists) +-- +-- We interpret the package environment as a set of package flags; to be +-- specific, if we find a package environment file like +-- +-- > clear-package-db +-- > global-package-db +-- > package-db blah/package.conf.d +-- > package-id id1 +-- > package-id id2 +-- +-- we interpret this as +-- +-- > [ -hide-all-packages +-- > , -clear-package-db +-- > , -global-package-db +-- > , -package-db blah/package.conf.d +-- > , -package-id id1 +-- > , -package-id id2 +-- > ] +-- +-- There's also an older syntax alias for package-id, which is just an +-- unadorned package id +-- +-- > id1 +-- > id2 +-- +interpretPackageEnv :: DynFlags -> IO DynFlags +interpretPackageEnv dflags = do + mPkgEnv <- runMaybeT $ msum $ [ + getCmdLineArg >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , cmdLineError env + ] + , getEnvVar >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , envError env + ] + , notIfHideAllPackages >> msum [ + findLocalEnvFile >>= probeEnvFile + , probeEnvName defaultEnvName + ] + ] + case mPkgEnv of + Nothing -> + -- No environment found. Leave DynFlags unchanged. + return dflags + Just "-" -> do + -- Explicitly disabled environment file. Leave DynFlags unchanged. + return dflags + Just envfile -> do + content <- readFile envfile + compilationProgressMsg dflags ("Loaded package environment from " ++ envfile) + let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags + + return dflags' + where + -- Loading environments (by name or by location) + + platformArchOs = platformMini (targetPlatform dflags) + + namedEnvPath :: String -> MaybeT IO FilePath + namedEnvPath name = do + appdir <- versionedAppDir (programName dflags) platformArchOs + return $ appdir "environments" name + + probeEnvName :: String -> MaybeT IO FilePath + probeEnvName name = probeEnvFile =<< namedEnvPath name + + probeEnvFile :: FilePath -> MaybeT IO FilePath + probeEnvFile path = do + guard =<< liftMaybeT (doesFileExist path) + return path + + probeNullEnv :: FilePath -> MaybeT IO FilePath + probeNullEnv "-" = return "-" + probeNullEnv _ = mzero + + -- Various ways to define which environment to use + + getCmdLineArg :: MaybeT IO String + getCmdLineArg = MaybeT $ return $ packageEnv dflags + + getEnvVar :: MaybeT IO String + getEnvVar = do + mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT" + case mvar of + Right var -> return var + Left err -> if isDoesNotExistError err then mzero + else liftMaybeT $ throwIO err + + notIfHideAllPackages :: MaybeT IO () + notIfHideAllPackages = + guard (not (gopt Opt_HideAllPackages dflags)) + + defaultEnvName :: String + defaultEnvName = "default" + + -- e.g. .ghc.environment.x86_64-linux-7.6.3 + localEnvFileName :: FilePath + localEnvFileName = ".ghc.environment" <.> versionedFilePath platformArchOs + + -- Search for an env file, starting in the current dir and looking upwards. + -- Fail if we get to the users home dir or the filesystem root. That is, + -- we don't look for an env file in the user's home dir. The user-wide + -- env lives in ghc's versionedAppDir/environments/default + findLocalEnvFile :: MaybeT IO FilePath + findLocalEnvFile = do + curdir <- liftMaybeT getCurrentDirectory + homedir <- tryMaybeT getHomeDirectory + let probe dir | isDrive dir || dir == homedir + = mzero + probe dir = do + let file = dir localEnvFileName + exists <- liftMaybeT (doesFileExist file) + if exists + then return file + else probe (takeDirectory dir) + probe curdir + + -- Error reporting + + cmdLineError :: String -> MaybeT IO a + cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " ++ show env ++ " not found" + + envError :: String -> MaybeT IO a + envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " + ++ show env + ++ " (specified in GHC_ENVIRONMENT) not found" diff --git a/GHC/Builtin/Names.hs b/GHC/Builtin/Names.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Names.hs @@ -0,0 +1,2768 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[GHC.Builtin.Names]{Definitions of prelude modules and names} + + +Nota Bene: all Names defined in here should come from the base package + + - ModuleNames for prelude modules, + e.g. pREL_BASE_Name :: ModuleName + + - Modules for prelude modules + e.g. pREL_Base :: Module + + - Uniques for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConKey :: Unique + minusClassOpKey :: Unique + + - Names for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConName :: Name + minusName :: Name + One of these Names contains + (a) the module and occurrence name of the thing + (b) its Unique + The way the compiler "knows about" one of these things is + where the type checker or desugarer needs to look it up. For + example, when desugaring list comprehensions the desugarer + needs to conjure up 'foldr'. It does this by looking up + foldrName in the environment. + + - RdrNames for Ids, DataCons etc that the compiler may emit into + generated code (e.g. for deriving). It's not necessary to know + the uniques for these guys, only their names + + +Note [Known-key names] +~~~~~~~~~~~~~~~~~~~~~~ +It is *very* important that the compiler gives wired-in things and +things with "known-key" names the correct Uniques wherever they +occur. We have to be careful about this in exactly two places: + + 1. When we parse some source code, renaming the AST better yield an + AST whose Names have the correct uniques + + 2. When we read an interface file, the read-in gubbins better have + the right uniques + +This is accomplished through a combination of mechanisms: + + 1. When parsing source code, the RdrName-decorated AST has some + RdrNames which are Exact. These are wired-in RdrNames where the + we could directly tell from the parsed syntax what Name to + use. For example, when we parse a [] in a type we can just insert + an Exact RdrName Name with the listTyConKey. + + Currently, I believe this is just an optimisation: it would be + equally valid to just output Orig RdrNames that correctly record + the module etc we expect the final Name to come from. However, + were we to eliminate isBuiltInOcc_maybe it would become essential + (see point 3). + + 2. The knownKeyNames (which consist of the basicKnownKeyNames from + the module, and those names reachable via the wired-in stuff from + GHC.Builtin.Types) are used to initialise the "OrigNameCache" in + GHC.Iface.Env. This initialization ensures that when the type checker + or renamer (both of which use GHC.Iface.Env) look up an original name + (i.e. a pair of a Module and an OccName) for a known-key name + they get the correct Unique. + + This is the most important mechanism for ensuring that known-key + stuff gets the right Unique, and is why it is so important to + place your known-key names in the appropriate lists. + + 3. For "infinite families" of known-key names (i.e. tuples and sums), we + have to be extra careful. Because there are an infinite number of + these things, we cannot add them to the list of known-key names + used to initialise the OrigNameCache. Instead, we have to + rely on never having to look them up in that cache. See + Note [Infinite families of known-key names] for details. + + +Note [Infinite families of known-key names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Infinite families of known-key things (e.g. tuples and sums) pose a tricky +problem: we can't add them to the knownKeyNames finite map which we use to +ensure that, e.g., a reference to (,) gets assigned the right unique (if this +doesn't sound familiar see Note [Known-key names] above). + +We instead handle tuples and sums separately from the "vanilla" known-key +things, + + a) The parser recognises them specially and generates an Exact Name (hence not + looked up in the orig-name cache) + + b) The known infinite families of names are specially serialised by + GHC.Iface.Binary.putName, with that special treatment detected when we read + back to ensure that we get back to the correct uniques. See Note [Symbol + table representation of names] in GHC.Iface.Binary and Note [How tuples + work] in GHC.Builtin.Types. + +Most of the infinite families cannot occur in source code, so mechanisms (a) and (b) +suffice to ensure that they always have the right Unique. In particular, +implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned +by the user. For those things that *can* appear in source programs, + + c) GHC.Iface.Env.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax + directly onto the corresponding name, rather than trying to find it in the + original-name cache. + + See also Note [Built-in syntax and the OrigNameCache] + +Note that one-tuples are an exception to the rule, as they do get assigned +known keys. See +Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) +in GHC.Builtin.Types. + +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Builtin.Names + ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience + + ----------------------------------------------------------- + module GHC.Builtin.Names, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey + -- (c) Groups of classes and types + -- (d) miscellaneous things + -- So many that we export them all + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Unit.Types +import GHC.Unit.Module.Name +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Data.FastString + +{- +************************************************************************ +* * + allNameStrings +* * +************************************************************************ +-} + +allNameStrings :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] + +{- +************************************************************************ +* * +\subsection{Local Names} +* * +************************************************************************ + +This *local* name is used by the interactive stuff +-} + +itName :: Unique -> SrcSpan -> Name +itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: OccName -> Name +mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey + +{- +************************************************************************ +* * +\subsection{Known key Names} +* * +************************************************************************ + +This section tells what the compiler knows about the association of +names with uniques. These ones are the *non* wired-in ones. The +wired in ones are defined in GHC.Builtin.Types etc. +-} + +basicKnownKeyNames :: [Name] -- See Note [Known-key names] +basicKnownKeyNames + = genericTyConNames + ++ [ -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + eqClassName, -- mentioned, derivable + ordClassName, -- derivable + boundedClassName, -- derivable + numClassName, -- mentioned, numeric + enumClassName, -- derivable + monadClassName, + functorClassName, + realClassName, -- numeric + integralClassName, -- numeric + fractionalClassName, -- numeric + floatingClassName, -- numeric + realFracClassName, -- numeric + realFloatClassName, -- numeric + dataClassName, + isStringClassName, + applicativeClassName, + alternativeClassName, + foldableClassName, + traversableClassName, + semigroupClassName, sappendName, + monoidClassName, memptyName, mappendName, mconcatName, + + -- The IO type + -- See Note [TyConRepNames for non-wired-in TyCons] + ioTyConName, ioDataConName, + runMainIOName, + runRWName, + + -- Type representation types + trModuleTyConName, trModuleDataConName, + trNameTyConName, trNameSDataConName, trNameDDataConName, + trTyConTyConName, trTyConDataConName, + + -- Typeable + typeableClassName, + typeRepTyConName, + someTypeRepTyConName, + someTypeRepDataConName, + kindRepTyConName, + kindRepTyConAppDataConName, + kindRepVarDataConName, + kindRepAppDataConName, + kindRepFunDataConName, + kindRepTYPEDataConName, + kindRepTypeLitSDataConName, + kindRepTypeLitDDataConName, + typeLitSortTyConName, + typeLitSymbolDataConName, + typeLitNatDataConName, + typeRepIdName, + mkTrTypeName, + mkTrConName, + mkTrAppName, + mkTrFunName, + typeSymbolTypeRepName, typeNatTypeRepName, + trGhcPrimModuleName, + + -- KindReps for common cases + starKindRepName, + starArrStarKindRepName, + starArrStarArrStarKindRepName, + + -- Dynamic + toDynName, + + -- Numeric stuff + negateName, minusName, geName, eqName, + + -- Conversion functions + rationalTyConName, + ratioTyConName, ratioDataConName, + fromRationalName, fromIntegerName, + toIntegerName, toRationalName, + fromIntegralName, realToFracName, + + -- Int# stuff + divIntName, modIntName, + + -- String stuff + fromStringName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + + -- Applicative stuff + pureAName, apAName, thenAName, + + -- Functor stuff + fmapName, + + -- Monad stuff + thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, + returnMName, joinMName, + + -- MonadFail + monadFailClassName, failMName, + + -- MonadFix + monadFixClassName, mfixName, + + -- Arrow stuff + arrAName, composeAName, firstAName, + appAName, choiceAName, loopAName, + + -- Ix stuff + ixClassName, + + -- Show stuff + showClassName, + + -- Read stuff + readClassName, + + -- Stable pointers + newStablePtrName, + + -- GHC Extensions + groupWithName, + + -- Strings and lists + unpackCStringName, unpackCStringUtf8Name, + unpackCStringFoldrName, unpackCStringFoldrUtf8Name, + cstringLengthName, + + -- Overloaded lists + isListClassName, + fromListName, + fromListNName, + toListName, + + -- List operations + concatName, filterName, mapName, + zipName, foldrName, buildName, augmentName, appendName, + + -- FFI primitive types that are not wired-in. + stablePtrTyConName, ptrTyConName, funPtrTyConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + word16TyConName, word32TyConName, word64TyConName, + + -- Others + otherwiseIdName, inlineIdName, + eqStringName, assertName, breakpointName, breakpointCondName, + opaqueTyConName, + assertErrorName, traceName, + printName, fstName, sndName, + dollarName, + + -- ghc-bignum + integerFromNaturalName, + integerToNaturalClampName, + integerToNaturalThrowName, + integerToNaturalName, + integerToWordName, + integerToIntName, + integerToWord64Name, + integerToInt64Name, + integerFromWordName, + integerFromWord64Name, + integerFromInt64Name, + integerAddName, + integerMulName, + integerSubName, + integerNegateName, + integerEqName, + integerNeName, + integerLeName, + integerGtName, + integerLtName, + integerGeName, + integerAbsName, + integerSignumName, + integerCompareName, + integerPopCountName, + integerQuotName, + integerRemName, + integerDivName, + integerModName, + integerDivModName, + integerQuotRemName, + integerToFloatName, + integerToDoubleName, + integerEncodeFloatName, + integerEncodeDoubleName, + integerGcdName, + integerLcmName, + integerAndName, + integerOrName, + integerXorName, + integerComplementName, + integerBitName, + integerTestBitName, + integerShiftLName, + integerShiftRName, + + naturalToWordName, + naturalToWordClampName, + naturalEqName, + naturalNeName, + naturalGeName, + naturalLeName, + naturalGtName, + naturalLtName, + naturalCompareName, + naturalPopCountName, + naturalShiftRName, + naturalShiftLName, + naturalAddName, + naturalSubName, + naturalSubThrowName, + naturalSubUnsafeName, + naturalMulName, + naturalSignumName, + naturalNegateName, + naturalQuotRemName, + naturalQuotName, + naturalRemName, + naturalAndName, + naturalAndNotName, + naturalOrName, + naturalXorName, + naturalTestBitName, + naturalBitName, + naturalGcdName, + naturalLcmName, + naturalLog2Name, + naturalLogBaseWordName, + naturalLogBaseName, + naturalPowModName, + naturalSizeInBaseName, + + bignatFromWordListName, + + -- Float/Double + rationalToFloatName, + rationalToDoubleName, + + -- Other classes + randomClassName, randomGenClassName, monadPlusClassName, + + -- Type-level naturals + knownNatClassName, knownSymbolClassName, + + -- Overloaded labels + isLabelClassName, + + -- Implicit Parameters + ipClassName, + + -- Overloaded record fields + hasFieldClassName, + + -- Call Stacks + callStackTyConName, + emptyCallStackName, pushCallStackName, + + -- Source Locations + srcLocDataConName, + + -- Annotation type checking + toAnnotationWrapperName + + -- The SPEC type for SpecConstr + , specTyConName + + -- The Either type + , eitherTyConName, leftDataConName, rightDataConName + + -- Plugins + , pluginTyConName + , frontendPluginTyConName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + + -- Monad comprehensions + , guardMName + , liftMName + , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName + + -- StaticPtr + , makeStaticName + , staticPtrTyConName + , staticPtrDataConName, staticPtrInfoDataConName + , fromStaticPtrName + + -- Fingerprint + , fingerprintDataConName + + -- Custom type errors + , errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + + -- Unsafe coercion proofs + , unsafeEqualityProofName + , unsafeEqualityTyConName + , unsafeReflDataConName + , unsafeCoercePrimName + ] + +genericTyConNames :: [Name] +genericTyConNames = [ + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName + ] + +{- +************************************************************************ +* * +\subsection{Module names} +* * +************************************************************************ + + +--MetaHaskell Extension Add a new module here +-} + +pRELUDE :: Module +pRELUDE = mkBaseModule_ pRELUDE_NAME + +gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION, + gHC_TYPES, gHC_GENERICS, gHC_MAGIC, + gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM, + gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, + gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT, + gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING, + dATA_FOLDABLE, dATA_TRAVERSABLE, + gHC_CONC, gHC_IO, gHC_IO_Exception, + gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, + gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, + tYPEABLE, tYPEABLE_INTERNAL, gENERICS, + rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, + aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, + cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY, + dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module + +gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values +gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic") +gHC_PRIM_EXCEPTION = mkPrimModule (fsLit "GHC.Prim.Exception") +gHC_TYPES = mkPrimModule (fsLit "GHC.Types") +gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") +gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") +gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") +gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers") + +gHC_BASE = mkBaseModule (fsLit "GHC.Base") +gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") +gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") +gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers") +gHC_SHOW = mkBaseModule (fsLit "GHC.Show") +gHC_READ = mkBaseModule (fsLit "GHC.Read") +gHC_NUM = mkBaseModule (fsLit "GHC.Num") +gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe") +gHC_NUM_INTEGER = mkBignumModule (fsLit "GHC.Num.Integer") +gHC_NUM_NATURAL = mkBignumModule (fsLit "GHC.Num.Natural") +gHC_NUM_BIGNAT = mkBignumModule (fsLit "GHC.Num.BigNat") +gHC_LIST = mkBaseModule (fsLit "GHC.List") +gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") +dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") +dATA_EITHER = mkBaseModule (fsLit "Data.Either") +dATA_LIST = mkBaseModule (fsLit "Data.List") +dATA_STRING = mkBaseModule (fsLit "Data.String") +dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") +dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") +gHC_CONC = mkBaseModule (fsLit "GHC.Conc") +gHC_IO = mkBaseModule (fsLit "GHC.IO") +gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") +gHC_ST = mkBaseModule (fsLit "GHC.ST") +gHC_IX = mkBaseModule (fsLit "GHC.Ix") +gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") +gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") +gHC_ERR = mkBaseModule (fsLit "GHC.Err") +gHC_REAL = mkBaseModule (fsLit "GHC.Real") +gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") +gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") +sYSTEM_IO = mkBaseModule (fsLit "System.IO") +dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") +tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") +gENERICS = mkBaseModule (fsLit "Data.Data") +rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") +lEX = mkBaseModule (fsLit "Text.Read.Lex") +gHC_INT = mkBaseModule (fsLit "GHC.Int") +gHC_WORD = mkBaseModule (fsLit "GHC.Word") +mONAD = mkBaseModule (fsLit "Control.Monad") +mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") +mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") +mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail") +aRROW = mkBaseModule (fsLit "Control.Arrow") +cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") +gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") +rANDOM = mkBaseModule (fsLit "System.Random") +gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") +cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") +gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") +gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats") +dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") +dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") +dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace") +uNSAFE_COERCE = mkBaseModule (fsLit "Unsafe.Coerce") + +gHC_SRCLOC :: Module +gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") + +gHC_STACK, gHC_STACK_TYPES :: Module +gHC_STACK = mkBaseModule (fsLit "GHC.Stack") +gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types") + +gHC_STATICPTR :: Module +gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") + +gHC_STATICPTR_INTERNAL :: Module +gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal") + +gHC_FINGERPRINT_TYPE :: Module +gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") + +gHC_OVER_LABELS :: Module +gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels") + +gHC_RECORDS :: Module +gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") + +mAIN, rOOT_MAIN :: Module +mAIN = mkMainModule_ mAIN_NAME +rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation + +mkInteractiveModule :: Int -> Module +-- (mkInteractiveMoudule 9) makes module 'interactive:M9' +mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n)) + +pRELUDE_NAME, mAIN_NAME :: ModuleName +pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") +mAIN_NAME = mkModuleNameFS (fsLit "Main") + +dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName +dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") +dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") + +mkPrimModule :: FastString -> Module +mkPrimModule m = mkModule primUnit (mkModuleNameFS m) + +mkBignumModule :: FastString -> Module +mkBignumModule m = mkModule bignumUnit (mkModuleNameFS m) + +mkBaseModule :: FastString -> Module +mkBaseModule m = mkBaseModule_ (mkModuleNameFS m) + +mkBaseModule_ :: ModuleName -> Module +mkBaseModule_ m = mkModule baseUnit m + +mkThisGhcModule :: FastString -> Module +mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m) + +mkThisGhcModule_ :: ModuleName -> Module +mkThisGhcModule_ m = mkModule thisGhcUnit m + +mkMainModule :: FastString -> Module +mkMainModule m = mkModule mainUnit (mkModuleNameFS m) + +mkMainModule_ :: ModuleName -> Module +mkMainModule_ m = mkModule mainUnit m + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +main_RDR_Unqual :: RdrName +main_RDR_Unqual = mkUnqual varName (fsLit "main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main + +eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, + ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") +lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") +gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") +compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") +ltTag_RDR = nameRdrName ordLTDataConName +eqTag_RDR = nameRdrName ordEQDataConName +gtTag_RDR = nameRdrName ordGTDataConName + +eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR + :: RdrName +eqClass_RDR = nameRdrName eqClassName +numClass_RDR = nameRdrName numClassName +ordClass_RDR = nameRdrName ordClassName +enumClass_RDR = nameRdrName enumClassName +monadClass_RDR = nameRdrName monadClassName + +map_RDR, append_RDR :: RdrName +map_RDR = nameRdrName mapName +append_RDR = nameRdrName appendName + +foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR + :: RdrName +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName + +left_RDR, right_RDR :: RdrName +left_RDR = nameRdrName leftDataConName +right_RDR = nameRdrName rightDataConName + +fromEnum_RDR, toEnum_RDR :: RdrName +fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") +toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") + +enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName + +ratioDataCon_RDR, integerAdd_RDR, integerMul_RDR :: RdrName +ratioDataCon_RDR = nameRdrName ratioDataConName +integerAdd_RDR = nameRdrName integerAddName +integerMul_RDR = nameRdrName integerMulName + +ioDataCon_RDR :: RdrName +ioDataCon_RDR = nameRdrName ioDataConName + +eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, + unpackCStringFoldrUtf8_RDR, unpackCStringUtf8_RDR :: RdrName +eqString_RDR = nameRdrName eqStringName +unpackCString_RDR = nameRdrName unpackCStringName +unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName +unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name +unpackCStringFoldrUtf8_RDR = nameRdrName unpackCStringFoldrUtf8Name + +newStablePtr_RDR :: RdrName +newStablePtr_RDR = nameRdrName newStablePtrName + +bindIO_RDR, returnIO_RDR :: RdrName +bindIO_RDR = nameRdrName bindIOName +returnIO_RDR = nameRdrName returnIOName + +fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName +fromInteger_RDR = nameRdrName fromIntegerName +fromRational_RDR = nameRdrName fromRationalName +minus_RDR = nameRdrName minusName +times_RDR = varQual_RDR gHC_NUM (fsLit "*") +plus_RDR = varQual_RDR gHC_NUM (fsLit "+") + +toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName +toInteger_RDR = nameRdrName toIntegerName +toRational_RDR = nameRdrName toRationalName +fromIntegral_RDR = nameRdrName fromIntegralName + +fromString_RDR :: RdrName +fromString_RDR = nameRdrName fromStringName + +fromList_RDR, fromListN_RDR, toList_RDR :: RdrName +fromList_RDR = nameRdrName fromListName +fromListN_RDR = nameRdrName fromListNName +toList_RDR = nameRdrName toListName + +compose_RDR :: RdrName +compose_RDR = varQual_RDR gHC_BASE (fsLit ".") + +not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, + and_RDR, range_RDR, inRange_RDR, index_RDR, + unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName +and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") +not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") +getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") +succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") +pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") +minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") +maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") +range_RDR = varQual_RDR gHC_IX (fsLit "range") +inRange_RDR = varQual_RDR gHC_IX (fsLit "inRange") +index_RDR = varQual_RDR gHC_IX (fsLit "index") +unsafeIndex_RDR = varQual_RDR gHC_IX (fsLit "unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR gHC_IX (fsLit "unsafeRangeSize") + +readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, + readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName +readList_RDR = varQual_RDR gHC_READ (fsLit "readList") +readListDefault_RDR = varQual_RDR gHC_READ (fsLit "readListDefault") +readListPrec_RDR = varQual_RDR gHC_READ (fsLit "readListPrec") +readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault") +readPrec_RDR = varQual_RDR gHC_READ (fsLit "readPrec") +parens_RDR = varQual_RDR gHC_READ (fsLit "parens") +choose_RDR = varQual_RDR gHC_READ (fsLit "choose") +lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP") +expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP") + +readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName +readField_RDR = varQual_RDR gHC_READ (fsLit "readField") +readFieldHash_RDR = varQual_RDR gHC_READ (fsLit "readFieldHash") +readSymField_RDR = varQual_RDR gHC_READ (fsLit "readSymField") + +punc_RDR, ident_RDR, symbol_RDR :: RdrName +punc_RDR = dataQual_RDR lEX (fsLit "Punc") +ident_RDR = dataQual_RDR lEX (fsLit "Ident") +symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") + +step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName +step_RDR = varQual_RDR rEAD_PREC (fsLit "step") +alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") +reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") +prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") +pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") + +showsPrec_RDR, shows_RDR, showString_RDR, + showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName +showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") +shows_RDR = varQual_RDR gHC_SHOW (fsLit "shows") +showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") +showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") +showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") +showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") + +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_ERR (fsLit "error") + +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, + unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, + from_RDR, from1_RDR, to_RDR, to1_RDR, + datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, + conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR, + uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, + uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, + uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, + uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName + +u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") +par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") +rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") +k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") +m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") + +l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") +r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") + +prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") +comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") + +unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") +unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") +unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") +unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") + +from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") +from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") +to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") +to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") + +datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") +moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") +packageName_RDR = varQual_RDR gHC_GENERICS (fsLit "packageName") +isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype") +selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") +conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") +conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") +conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") + +prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") +infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") +leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName +rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName +notAssocDataCon_RDR = nameRdrName notAssociativeDataConName + +uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr") +uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar") +uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble") +uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat") +uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt") +uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord") + +uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#") +uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#") +uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#") +uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") +uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") +uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#") + +fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, + foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, + mappend_RDR :: RdrName +fmap_RDR = nameRdrName fmapName +replace_RDR = varQual_RDR gHC_BASE (fsLit "<$") +pure_RDR = nameRdrName pureAName +ap_RDR = nameRdrName apAName +liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2") +foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") +foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") +null_RDR = varQual_RDR dATA_FOLDABLE (fsLit "null") +all_RDR = varQual_RDR dATA_FOLDABLE (fsLit "all") +traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") +mempty_RDR = nameRdrName memptyName +mappend_RDR = nameRdrName mappendName + +---------------------- +varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR + :: Module -> FastString -> RdrName +varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) +tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) + +{- +************************************************************************ +* * +\subsection{Known-key names} +* * +************************************************************************ + +Many of these Names are not really "built in", but some parts of the +compiler (notably the deriving mechanism) need to mention their names, +and it's convenient to write them all down in one place. +-} + +wildCardName :: Name +wildCardName = mkSystemVarName wildCardKey (fsLit "wild") + +runMainIOName, runRWName :: Name +runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey +runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey + +orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name +orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey +ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey +ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey +ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey + +specTyConName :: Name +specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey + +eitherTyConName, leftDataConName, rightDataConName :: Name +eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey +leftDataConName = dcQual dATA_EITHER (fsLit "Left") leftDataConKey +rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey + +-- Generics (types) +v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name + +v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey +u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey +par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey +rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey +k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey +m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey + +sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey +prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey +compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey + +rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey +dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey +cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey +sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey + +rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey +d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey +c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey +s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey +noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey + +repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey +rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey + +uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey +uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey +uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey +uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey +uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey +uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey +uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey + +prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey +infixIDataConName = dcQual gHC_GENERICS (fsLit "InfixI") infixIDataConKey +leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey +rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey +notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey + +sourceUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey +sourceNoUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey +noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey +sourceLazyDataConName = dcQual gHC_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey +sourceStrictDataConName = dcQual gHC_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey +noSourceStrictnessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey +decidedLazyDataConName = dcQual gHC_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey +decidedStrictDataConName = dcQual gHC_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey +decidedUnpackDataConName = dcQual gHC_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey + +metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey +metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey +metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey + +-- Primitive Int +divIntName, modIntName :: Name +divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey +modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey + +-- Base strings Strings +unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, + eqStringName, cstringLengthName :: Name +unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey +unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey +eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey +unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey + +-- The 'inline' function +inlineIdName :: Name +inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey + +-- Base classes (Eq, Ord, Functor) +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey +functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey +fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey + +-- Class Monad +monadClassName, thenMName, bindMName, returnMName :: Name +monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey +thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey +bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey +returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey + +-- Class MonadFail +monadFailClassName, failMName :: Name +monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey +failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey + +-- Class Applicative +applicativeClassName, pureAName, apAName, thenAName :: Name +applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey +apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey +pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey +thenAName = varQual gHC_BASE (fsLit "*>") thenAClassOpKey + +-- Classes (Foldable, Traversable) +foldableClassName, traversableClassName :: Name +foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey +traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey + +-- Classes (Semigroup, Monoid) +semigroupClassName, sappendName :: Name +semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey +sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey +monoidClassName, memptyName, mappendName, mconcatName :: Name +monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey +memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey +mappendName = varQual gHC_BASE (fsLit "mappend") mappendClassOpKey +mconcatName = varQual gHC_BASE (fsLit "mconcat") mconcatClassOpKey + + + +-- AMP additions + +joinMName, alternativeClassName :: Name +joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey +alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey + +-- +joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, + alternativeClassKey :: Unique +joinMIdKey = mkPreludeMiscIdUnique 750 +apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> +pureAClassOpKey = mkPreludeMiscIdUnique 752 +thenAClassOpKey = mkPreludeMiscIdUnique 753 +alternativeClassKey = mkPreludeMiscIdUnique 754 + + +-- Functions for GHC extensions +groupWithName :: Name +groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey + +-- Random PrelBase functions +fromStringName, otherwiseIdName, foldrName, buildName, augmentName, + mapName, appendName, assertName, + breakpointName, breakpointCondName, + opaqueTyConName, dollarName :: Name +dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey +otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey +foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey +buildName = varQual gHC_BASE (fsLit "build") buildIdKey +augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey +mapName = varQual gHC_BASE (fsLit "map") mapIdKey +appendName = varQual gHC_BASE (fsLit "++") appendIdKey +assertName = varQual gHC_BASE (fsLit "assert") assertIdKey +breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey +breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey +opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey +fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey + +-- PrelTup +fstName, sndName :: Name +fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey +sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey + +-- Module GHC.Num +numClassName, fromIntegerName, minusName, negateName :: Name +numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey +fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey +minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey +negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey + +--------------------------------- +-- ghc-bignum +--------------------------------- +integerFromNaturalName + , integerToNaturalClampName + , integerToNaturalThrowName + , integerToNaturalName + , integerToWordName + , integerToIntName + , integerToWord64Name + , integerToInt64Name + , integerFromWordName + , integerFromWord64Name + , integerFromInt64Name + , integerAddName + , integerMulName + , integerSubName + , integerNegateName + , integerEqName + , integerNeName + , integerLeName + , integerGtName + , integerLtName + , integerGeName + , integerAbsName + , integerSignumName + , integerCompareName + , integerPopCountName + , integerQuotName + , integerRemName + , integerDivName + , integerModName + , integerDivModName + , integerQuotRemName + , integerToFloatName + , integerToDoubleName + , integerEncodeFloatName + , integerEncodeDoubleName + , integerGcdName + , integerLcmName + , integerAndName + , integerOrName + , integerXorName + , integerComplementName + , integerBitName + , integerTestBitName + , integerShiftLName + , integerShiftRName + , naturalToWordName + , naturalToWordClampName + , naturalEqName + , naturalNeName + , naturalGeName + , naturalLeName + , naturalGtName + , naturalLtName + , naturalCompareName + , naturalPopCountName + , naturalShiftRName + , naturalShiftLName + , naturalAddName + , naturalSubName + , naturalSubThrowName + , naturalSubUnsafeName + , naturalMulName + , naturalSignumName + , naturalNegateName + , naturalQuotRemName + , naturalQuotName + , naturalRemName + , naturalAndName + , naturalAndNotName + , naturalOrName + , naturalXorName + , naturalTestBitName + , naturalBitName + , naturalGcdName + , naturalLcmName + , naturalLog2Name + , naturalLogBaseWordName + , naturalLogBaseName + , naturalPowModName + , naturalSizeInBaseName + , bignatFromWordListName + :: Name + +bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name +bnbVarQual str key = varQual gHC_NUM_BIGNAT (fsLit str) key +bnnVarQual str key = varQual gHC_NUM_NATURAL (fsLit str) key +bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key + +-- Types and DataCons +bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey + +naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey +naturalToWordClampName = bnnVarQual "naturalToWordClamp#" naturalToWordClampIdKey +naturalEqName = bnnVarQual "naturalEq#" naturalEqIdKey +naturalNeName = bnnVarQual "naturalNe#" naturalNeIdKey +naturalGeName = bnnVarQual "naturalGe#" naturalGeIdKey +naturalLeName = bnnVarQual "naturalLe#" naturalLeIdKey +naturalGtName = bnnVarQual "naturalGt#" naturalGtIdKey +naturalLtName = bnnVarQual "naturalLt#" naturalLtIdKey +naturalCompareName = bnnVarQual "naturalCompare" naturalCompareIdKey +naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey +naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey +naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey +naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey +naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey +naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey +naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey +naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey +naturalSignumName = bnnVarQual "naturalSignum" naturalSignumIdKey +naturalNegateName = bnnVarQual "naturalNegate" naturalNegateIdKey +naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey +naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey +naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey +naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey +naturalAndNotName = bnnVarQual "naturalAndNot" naturalAndNotIdKey +naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey +naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey +naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey +naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey +naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey +naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey +naturalLog2Name = bnnVarQual "naturalLog2#" naturalLog2IdKey +naturalLogBaseWordName = bnnVarQual "naturalLogBaseWord#" naturalLogBaseWordIdKey +naturalLogBaseName = bnnVarQual "naturalLogBase#" naturalLogBaseIdKey +naturalPowModName = bnnVarQual "naturalPowMod" naturalPowModIdKey +naturalSizeInBaseName = bnnVarQual "naturalSizeInBase#" naturalSizeInBaseIdKey + +integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey +integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey +integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey +integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey +integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey +integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey +integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey +integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey +integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey +integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey +integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey +integerAddName = bniVarQual "integerAdd" integerAddIdKey +integerMulName = bniVarQual "integerMul" integerMulIdKey +integerSubName = bniVarQual "integerSub" integerSubIdKey +integerNegateName = bniVarQual "integerNegate" integerNegateIdKey +integerEqName = bniVarQual "integerEq#" integerEqIdKey +integerNeName = bniVarQual "integerNe#" integerNeIdKey +integerLeName = bniVarQual "integerLe#" integerLeIdKey +integerGtName = bniVarQual "integerGt#" integerGtIdKey +integerLtName = bniVarQual "integerLt#" integerLtIdKey +integerGeName = bniVarQual "integerGe#" integerGeIdKey +integerAbsName = bniVarQual "integerAbs" integerAbsIdKey +integerSignumName = bniVarQual "integerSignum" integerSignumIdKey +integerCompareName = bniVarQual "integerCompare" integerCompareIdKey +integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey +integerQuotName = bniVarQual "integerQuot" integerQuotIdKey +integerRemName = bniVarQual "integerRem" integerRemIdKey +integerDivName = bniVarQual "integerDiv" integerDivIdKey +integerModName = bniVarQual "integerMod" integerModIdKey +integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey +integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey +integerToFloatName = bniVarQual "integerToFloat#" integerToFloatIdKey +integerToDoubleName = bniVarQual "integerToDouble#" integerToDoubleIdKey +integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey +integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey +integerGcdName = bniVarQual "integerGcd" integerGcdIdKey +integerLcmName = bniVarQual "integerLcm" integerLcmIdKey +integerAndName = bniVarQual "integerAnd" integerAndIdKey +integerOrName = bniVarQual "integerOr" integerOrIdKey +integerXorName = bniVarQual "integerXor" integerXorIdKey +integerComplementName = bniVarQual "integerComplement" integerComplementIdKey +integerBitName = bniVarQual "integerBit#" integerBitIdKey +integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey +integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey +integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey + + + +--------------------------------- +-- End of ghc-bignum +--------------------------------- + +-- GHC.Real types and classes +rationalTyConName, ratioTyConName, ratioDataConName, realClassName, + integralClassName, realFracClassName, fractionalClassName, + fromRationalName, toIntegerName, toRationalName, fromIntegralName, + realToFracName :: Name +rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey +ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey +ratioDataConName = dcQual gHC_REAL (fsLit ":%") ratioDataConKey +realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey +integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey +realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey +fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey +realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey + +-- PrelFloat classes +floatingClassName, realFloatClassName :: Name +floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey +realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey + +-- other GHC.Float functions +rationalToFloatName, rationalToDoubleName :: Name +rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey +rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey + +-- Class Ix +ixClassName :: Name +ixClassName = clsQual gHC_IX (fsLit "Ix") ixClassKey + +-- Typeable representation types +trModuleTyConName + , trModuleDataConName + , trNameTyConName + , trNameSDataConName + , trNameDDataConName + , trTyConTyConName + , trTyConDataConName + :: Name +trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey +trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey +trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey +trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey +trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey +trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey +trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey + +kindRepTyConName + , kindRepTyConAppDataConName + , kindRepVarDataConName + , kindRepAppDataConName + , kindRepFunDataConName + , kindRepTYPEDataConName + , kindRepTypeLitSDataConName + , kindRepTypeLitDDataConName + :: Name +kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey +kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey +kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey +kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey +kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey +kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey +kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey +kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey + +typeLitSortTyConName + , typeLitSymbolDataConName + , typeLitNatDataConName + :: Name +typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey +typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey +typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey + +-- Class Typeable, and functions for constructing `Typeable` dictionaries +typeableClassName + , typeRepTyConName + , someTypeRepTyConName + , someTypeRepDataConName + , mkTrTypeName + , mkTrConName + , mkTrAppName + , mkTrFunName + , typeRepIdName + , typeNatTypeRepName + , typeSymbolTypeRepName + , trGhcPrimModuleName + :: Name +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey +someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey +someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey +typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey +mkTrTypeName = varQual tYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey +mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey +mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey +mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey +typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey +typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey +-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) +-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. +trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey + +-- Typeable KindReps for some common cases +starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name +starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey +starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey +starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey + +-- Custom type errors +errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + :: Name + +errorMessageTypeErrorFamName = + tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey + +typeErrorTextDataConName = + dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey + +typeErrorAppendDataConName = + dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey + +typeErrorVAppendDataConName = + dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey + +typeErrorShowTypeDataConName = + dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey + +-- Unsafe coercion proofs +unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName, + unsafeReflDataConName :: Name +unsafeEqualityProofName = varQual uNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey +unsafeEqualityTyConName = tcQual uNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey +unsafeReflDataConName = dcQual uNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey +unsafeCoercePrimName = varQual uNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey + +-- Dynamic +toDynName :: Name +toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey + +-- Class Data +dataClassName :: Name +dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey + +-- Error module +assertErrorName :: Name +assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey + +-- Debug.Trace +traceName :: Name +traceName = varQual dEBUG_TRACE (fsLit "trace") traceKey + +-- Enum module (Enum, Bounded) +enumClassName, enumFromName, enumFromToName, enumFromThenName, + enumFromThenToName, boundedClassName :: Name +enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey +enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey +enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey + +-- List functions +concatName, filterName, zipName :: Name +concatName = varQual gHC_LIST (fsLit "concat") concatIdKey +filterName = varQual gHC_LIST (fsLit "filter") filterIdKey +zipName = varQual gHC_LIST (fsLit "zip") zipIdKey + +-- Overloaded lists +isListClassName, fromListName, fromListNName, toListName :: Name +isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey +fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey +fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey +toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey + +-- Class Show +showClassName :: Name +showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey + +-- Class Read +readClassName :: Name +readClassName = clsQual gHC_READ (fsLit "Read") readClassKey + +-- Classes Generic and Generic1, Datatype, Constructor and Selector +genClassName, gen1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name +genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey +gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey + +datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey +constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey +selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] + +-- GHCi things +ghciIoClassName, ghciStepIoMName :: Name +ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey +ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey + +-- IO things +ioTyConName, ioDataConName, + thenIOName, bindIOName, returnIOName, failIOName :: Name +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey +thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey + +-- IO things +printName :: Name +printName = varQual sYSTEM_IO (fsLit "print") printIdKey + +-- Int, Word, and Addr things +int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name +int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey +int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey +int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey +int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey + +-- Word module +word16TyConName, word32TyConName, word64TyConName :: Name +word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey +word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey +word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey + +-- PrelPtr module +ptrTyConName, funPtrTyConName :: Name +ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey +funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey + +-- Foreign objects and weak pointers +stablePtrTyConName, newStablePtrName :: Name +stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey +newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey + +-- Recursive-do notation +monadFixClassName, mfixName :: Name +monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey +mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey + +-- Arrow notation +arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name +arrAName = varQual aRROW (fsLit "arr") arrAIdKey +composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey +firstAName = varQual aRROW (fsLit "first") firstAIdKey +appAName = varQual aRROW (fsLit "app") appAIdKey +choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey +loopAName = varQual aRROW (fsLit "loop") loopAIdKey + +-- Monad comprehensions +guardMName, liftMName, mzipName :: Name +guardMName = varQual mONAD (fsLit "guard") guardMIdKey +liftMName = varQual mONAD (fsLit "liftM") liftMIdKey +mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey + + +-- Annotation type checking +toAnnotationWrapperName :: Name +toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey + +-- Other classes, needed for type defaulting +monadPlusClassName, randomClassName, randomGenClassName, + isStringClassName :: Name +monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey +randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey +randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey +isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey + +-- Type-level naturals +knownNatClassName :: Name +knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey +knownSymbolClassName :: Name +knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey + +-- Overloaded labels +isLabelClassName :: Name +isLabelClassName + = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey + +-- Implicit Parameters +ipClassName :: Name +ipClassName + = clsQual gHC_CLASSES (fsLit "IP") ipClassKey + +-- Overloaded record fields +hasFieldClassName :: Name +hasFieldClassName + = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey + +-- Source Locations +callStackTyConName, emptyCallStackName, pushCallStackName, + srcLocDataConName :: Name +callStackTyConName + = tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey +emptyCallStackName + = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey +pushCallStackName + = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey +srcLocDataConName + = dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey + +-- plugins +pLUGINS :: Module +pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins") +pluginTyConName :: Name +pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey +frontendPluginTyConName :: Name +frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey + +-- Static pointers +makeStaticName :: Name +makeStaticName = + varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey + +staticPtrInfoTyConName :: Name +staticPtrInfoTyConName = + tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey + +staticPtrInfoDataConName :: Name +staticPtrInfoDataConName = + dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey + +staticPtrTyConName :: Name +staticPtrTyConName = + tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey + +staticPtrDataConName :: Name +staticPtrDataConName = + dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey + +fromStaticPtrName :: Name +fromStaticPtrName = + varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey + +fingerprintDataConName :: Name +fingerprintDataConName = + dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey + +{- +************************************************************************ +* * +\subsection{Local helpers} +* * +************************************************************************ + +All these are original names; hence mkOrig +-} + +varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name +varQual = mk_known_key_name varName +tcQual = mk_known_key_name tcName +clsQual = mk_known_key_name clsName +dcQual = mk_known_key_name dataName + +mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name +mk_known_key_name space modu str unique + = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} +* * +************************************************************************ +--MetaHaskell extension hand allocate keys here +-} + +boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, + fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, + functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, + realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +dataClassKey = mkPreludeClassUnique 9 +functorClassKey = mkPreludeClassUnique 10 +numClassKey = mkPreludeClassUnique 11 +ordClassKey = mkPreludeClassUnique 12 +readClassKey = mkPreludeClassUnique 13 +realClassKey = mkPreludeClassUnique 14 +realFloatClassKey = mkPreludeClassUnique 15 +realFracClassKey = mkPreludeClassUnique 16 +showClassKey = mkPreludeClassUnique 17 +ixClassKey = mkPreludeClassUnique 18 + +typeableClassKey :: Unique +typeableClassKey = mkPreludeClassUnique 20 + +monadFixClassKey :: Unique +monadFixClassKey = mkPreludeClassUnique 28 + +monadFailClassKey :: Unique +monadFailClassKey = mkPreludeClassUnique 29 + +monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique +monadPlusClassKey = mkPreludeClassUnique 30 +randomClassKey = mkPreludeClassUnique 31 +randomGenClassKey = mkPreludeClassUnique 32 + +isStringClassKey :: Unique +isStringClassKey = mkPreludeClassUnique 33 + +applicativeClassKey, foldableClassKey, traversableClassKey :: Unique +applicativeClassKey = mkPreludeClassUnique 34 +foldableClassKey = mkPreludeClassUnique 35 +traversableClassKey = mkPreludeClassUnique 36 + +genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique +genClassKey = mkPreludeClassUnique 37 +gen1ClassKey = mkPreludeClassUnique 38 + +datatypeClassKey = mkPreludeClassUnique 39 +constructorClassKey = mkPreludeClassUnique 40 +selectorClassKey = mkPreludeClassUnique 41 + +-- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence +knownNatClassNameKey :: Unique +knownNatClassNameKey = mkPreludeClassUnique 42 + +-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence +knownSymbolClassNameKey :: Unique +knownSymbolClassNameKey = mkPreludeClassUnique 43 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 44 + +isLabelClassNameKey :: Unique +isLabelClassNameKey = mkPreludeClassUnique 45 + +semigroupClassKey, monoidClassKey :: Unique +semigroupClassKey = mkPreludeClassUnique 46 +monoidClassKey = mkPreludeClassUnique 47 + +-- Implicit Parameters +ipClassKey :: Unique +ipClassKey = mkPreludeClassUnique 48 + +-- Overloaded record fields +hasFieldClassNameKey :: Unique +hasFieldClassNameKey = mkPreludeClassUnique 49 + + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES ClassUniques 200-299 +----------------------------------------------------- + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} +* * +************************************************************************ +-} + +addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, + byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, + doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, + intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, + int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, + int64PrimTyConKey, int64TyConKey, + integerTyConKey, naturalTyConKey, + listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, + weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, + mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, + ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, + stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey, + smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, + stringTyConKey :: Unique +addrPrimTyConKey = mkPreludeTyConUnique 1 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +stringTyConKey = mkPreludeTyConUnique 6 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +doublePrimTyConKey = mkPreludeTyConUnique 9 +doubleTyConKey = mkPreludeTyConUnique 10 +floatPrimTyConKey = mkPreludeTyConUnique 11 +floatTyConKey = mkPreludeTyConUnique 12 +funTyConKey = mkPreludeTyConUnique 13 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +int8PrimTyConKey = mkPreludeTyConUnique 16 +int8TyConKey = mkPreludeTyConUnique 17 +int16PrimTyConKey = mkPreludeTyConUnique 18 +int16TyConKey = mkPreludeTyConUnique 19 +int32PrimTyConKey = mkPreludeTyConUnique 20 +int32TyConKey = mkPreludeTyConUnique 21 +int64PrimTyConKey = mkPreludeTyConUnique 22 +int64TyConKey = mkPreludeTyConUnique 23 +integerTyConKey = mkPreludeTyConUnique 24 +naturalTyConKey = mkPreludeTyConUnique 25 + +listTyConKey = mkPreludeTyConUnique 26 +foreignObjPrimTyConKey = mkPreludeTyConUnique 27 +maybeTyConKey = mkPreludeTyConUnique 28 +weakPrimTyConKey = mkPreludeTyConUnique 29 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 +orderingTyConKey = mkPreludeTyConUnique 32 +mVarPrimTyConKey = mkPreludeTyConUnique 33 +ioPortPrimTyConKey = mkPreludeTyConUnique 34 +ratioTyConKey = mkPreludeTyConUnique 35 +rationalTyConKey = mkPreludeTyConUnique 36 +realWorldTyConKey = mkPreludeTyConUnique 37 +stablePtrPrimTyConKey = mkPreludeTyConUnique 38 +stablePtrTyConKey = mkPreludeTyConUnique 39 +eqTyConKey = mkPreludeTyConUnique 40 +heqTyConKey = mkPreludeTyConUnique 41 +arrayArrayPrimTyConKey = mkPreludeTyConUnique 42 +mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 43 + +statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, + mutVarPrimTyConKey, ioTyConKey, + wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, + word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, + word64PrimTyConKey, word64TyConKey, + liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, + typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, + funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, + eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey, + compactPrimTyConKey :: Unique +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 +stableNameTyConKey = mkPreludeTyConUnique 52 +eqPrimTyConKey = mkPreludeTyConUnique 53 +eqReprPrimTyConKey = mkPreludeTyConUnique 54 +eqPhantPrimTyConKey = mkPreludeTyConUnique 55 +mutVarPrimTyConKey = mkPreludeTyConUnique 56 +ioTyConKey = mkPreludeTyConUnique 57 +voidPrimTyConKey = mkPreludeTyConUnique 58 +wordPrimTyConKey = mkPreludeTyConUnique 59 +wordTyConKey = mkPreludeTyConUnique 60 +word8PrimTyConKey = mkPreludeTyConUnique 61 +word8TyConKey = mkPreludeTyConUnique 62 +word16PrimTyConKey = mkPreludeTyConUnique 63 +word16TyConKey = mkPreludeTyConUnique 64 +word32PrimTyConKey = mkPreludeTyConUnique 65 +word32TyConKey = mkPreludeTyConUnique 66 +word64PrimTyConKey = mkPreludeTyConUnique 67 +word64TyConKey = mkPreludeTyConUnique 68 +liftedConKey = mkPreludeTyConUnique 69 +unliftedConKey = mkPreludeTyConUnique 70 +anyBoxConKey = mkPreludeTyConUnique 71 +kindConKey = mkPreludeTyConUnique 72 +boxityConKey = mkPreludeTyConUnique 73 +typeConKey = mkPreludeTyConUnique 74 +threadIdPrimTyConKey = mkPreludeTyConUnique 75 +bcoPrimTyConKey = mkPreludeTyConUnique 76 +ptrTyConKey = mkPreludeTyConUnique 77 +funPtrTyConKey = mkPreludeTyConUnique 78 +tVarPrimTyConKey = mkPreludeTyConUnique 79 +compactPrimTyConKey = mkPreludeTyConUnique 80 + +eitherTyConKey :: Unique +eitherTyConKey = mkPreludeTyConUnique 84 + +-- Kind constructors +liftedTypeKindTyConKey, tYPETyConKey, + constraintKindTyConKey, runtimeRepTyConKey, + vecCountTyConKey, vecElemTyConKey :: Unique +liftedTypeKindTyConKey = mkPreludeTyConUnique 87 +tYPETyConKey = mkPreludeTyConUnique 88 +constraintKindTyConKey = mkPreludeTyConUnique 92 +runtimeRepTyConKey = mkPreludeTyConUnique 95 +vecCountTyConKey = mkPreludeTyConUnique 96 +vecElemTyConKey = mkPreludeTyConUnique 97 + +pluginTyConKey, frontendPluginTyConKey :: Unique +pluginTyConKey = mkPreludeTyConUnique 102 +frontendPluginTyConKey = mkPreludeTyConUnique 103 + +unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, + opaqueTyConKey :: Unique +unknownTyConKey = mkPreludeTyConUnique 129 +unknown1TyConKey = mkPreludeTyConUnique 130 +unknown2TyConKey = mkPreludeTyConUnique 131 +unknown3TyConKey = mkPreludeTyConUnique 132 +opaqueTyConKey = mkPreludeTyConUnique 133 + +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, + repTyConKey, rep1TyConKey, uRecTyConKey, + uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, + uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique + +v1TyConKey = mkPreludeTyConUnique 135 +u1TyConKey = mkPreludeTyConUnique 136 +par1TyConKey = mkPreludeTyConUnique 137 +rec1TyConKey = mkPreludeTyConUnique 138 +k1TyConKey = mkPreludeTyConUnique 139 +m1TyConKey = mkPreludeTyConUnique 140 + +sumTyConKey = mkPreludeTyConUnique 141 +prodTyConKey = mkPreludeTyConUnique 142 +compTyConKey = mkPreludeTyConUnique 143 + +rTyConKey = mkPreludeTyConUnique 144 +dTyConKey = mkPreludeTyConUnique 146 +cTyConKey = mkPreludeTyConUnique 147 +sTyConKey = mkPreludeTyConUnique 148 + +rec0TyConKey = mkPreludeTyConUnique 149 +d1TyConKey = mkPreludeTyConUnique 151 +c1TyConKey = mkPreludeTyConUnique 152 +s1TyConKey = mkPreludeTyConUnique 153 +noSelTyConKey = mkPreludeTyConUnique 154 + +repTyConKey = mkPreludeTyConUnique 155 +rep1TyConKey = mkPreludeTyConUnique 156 + +uRecTyConKey = mkPreludeTyConUnique 157 +uAddrTyConKey = mkPreludeTyConUnique 158 +uCharTyConKey = mkPreludeTyConUnique 159 +uDoubleTyConKey = mkPreludeTyConUnique 160 +uFloatTyConKey = mkPreludeTyConUnique 161 +uIntTyConKey = mkPreludeTyConUnique 162 +uWordTyConKey = mkPreludeTyConUnique 163 + +-- Type-level naturals +typeNatKindConNameKey, typeSymbolKindConNameKey, + typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, + typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey + , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey + , typeNatDivTyFamNameKey + , typeNatModTyFamNameKey + , typeNatLogTyFamNameKey + :: Unique +typeNatKindConNameKey = mkPreludeTyConUnique 164 +typeSymbolKindConNameKey = mkPreludeTyConUnique 165 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 166 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 167 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 168 +typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169 +typeNatSubTyFamNameKey = mkPreludeTyConUnique 170 +typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171 +typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172 +typeNatDivTyFamNameKey = mkPreludeTyConUnique 173 +typeNatModTyFamNameKey = mkPreludeTyConUnique 174 +typeNatLogTyFamNameKey = mkPreludeTyConUnique 175 + +-- Custom user type-errors +errorMessageTypeErrorFamKey :: Unique +errorMessageTypeErrorFamKey = mkPreludeTyConUnique 176 + + + +ntTyConKey:: Unique +ntTyConKey = mkPreludeTyConUnique 177 +coercibleTyConKey :: Unique +coercibleTyConKey = mkPreludeTyConUnique 178 + +proxyPrimTyConKey :: Unique +proxyPrimTyConKey = mkPreludeTyConUnique 179 + +specTyConKey :: Unique +specTyConKey = mkPreludeTyConUnique 180 + +anyTyConKey :: Unique +anyTyConKey = mkPreludeTyConUnique 181 + +smallArrayPrimTyConKey = mkPreludeTyConUnique 182 +smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 183 + +staticPtrTyConKey :: Unique +staticPtrTyConKey = mkPreludeTyConUnique 184 + +staticPtrInfoTyConKey :: Unique +staticPtrInfoTyConKey = mkPreludeTyConUnique 185 + +callStackTyConKey :: Unique +callStackTyConKey = mkPreludeTyConUnique 186 + +-- Typeables +typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique +typeRepTyConKey = mkPreludeTyConUnique 187 +someTypeRepTyConKey = mkPreludeTyConUnique 188 +someTypeRepDataConKey = mkPreludeTyConUnique 189 + + +typeSymbolAppendFamNameKey :: Unique +typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190 + +-- Unsafe equality +unsafeEqualityTyConKey :: Unique +unsafeEqualityTyConKey = mkPreludeTyConUnique 191 + +-- Linear types +multiplicityTyConKey :: Unique +multiplicityTyConKey = mkPreludeTyConUnique 192 + +unrestrictedFunTyConKey :: Unique +unrestrictedFunTyConKey = mkPreludeTyConUnique 193 + +multMulTyConKey :: Unique +multMulTyConKey = mkPreludeTyConUnique 194 + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES TyConUniques 200-299 +----------------------------------------------------- + +----------------------- SIMD ------------------------ +-- USES TyConUniques 300-399 +----------------------------------------------------- + +#include "primop-vector-uniques.hs-incl" + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} +* * +************************************************************************ +-} + +charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, + floatDataConKey, intDataConKey, nilDataConKey, + ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, + word8DataConKey, ioDataConKey, heqDataConKey, + coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique + +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +nothingDataConKey = mkPreludeDataConUnique 7 +justDataConKey = mkPreludeDataConUnique 8 +eqDataConKey = mkPreludeDataConUnique 9 +nilDataConKey = mkPreludeDataConUnique 10 +ratioDataConKey = mkPreludeDataConUnique 11 +word8DataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 13 +trueDataConKey = mkPreludeDataConUnique 14 +wordDataConKey = mkPreludeDataConUnique 15 +ioDataConKey = mkPreludeDataConUnique 16 +heqDataConKey = mkPreludeDataConUnique 18 + +-- Generic data constructors +crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 + +leftDataConKey, rightDataConKey :: Unique +leftDataConKey = mkPreludeDataConUnique 25 +rightDataConKey = mkPreludeDataConUnique 26 + +ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique +ordLTDataConKey = mkPreludeDataConUnique 27 +ordEQDataConKey = mkPreludeDataConUnique 28 +ordGTDataConKey = mkPreludeDataConUnique 29 + + +coercibleDataConKey = mkPreludeDataConUnique 32 + +staticPtrDataConKey :: Unique +staticPtrDataConKey = mkPreludeDataConUnique 33 + +staticPtrInfoDataConKey :: Unique +staticPtrInfoDataConKey = mkPreludeDataConUnique 34 + +fingerprintDataConKey :: Unique +fingerprintDataConKey = mkPreludeDataConUnique 35 + +srcLocDataConKey :: Unique +srcLocDataConKey = mkPreludeDataConUnique 37 + +trTyConTyConKey, trTyConDataConKey, + trModuleTyConKey, trModuleDataConKey, + trNameTyConKey, trNameSDataConKey, trNameDDataConKey, + trGhcPrimModuleKey, kindRepTyConKey, + typeLitSortTyConKey :: Unique +trTyConTyConKey = mkPreludeDataConUnique 40 +trTyConDataConKey = mkPreludeDataConUnique 41 +trModuleTyConKey = mkPreludeDataConUnique 42 +trModuleDataConKey = mkPreludeDataConUnique 43 +trNameTyConKey = mkPreludeDataConUnique 44 +trNameSDataConKey = mkPreludeDataConUnique 45 +trNameDDataConKey = mkPreludeDataConUnique 46 +trGhcPrimModuleKey = mkPreludeDataConUnique 47 +kindRepTyConKey = mkPreludeDataConUnique 48 +typeLitSortTyConKey = mkPreludeDataConUnique 49 + +typeErrorTextDataConKey, + typeErrorAppendDataConKey, + typeErrorVAppendDataConKey, + typeErrorShowTypeDataConKey + :: Unique +typeErrorTextDataConKey = mkPreludeDataConUnique 50 +typeErrorAppendDataConKey = mkPreludeDataConUnique 51 +typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 +typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 + +prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, + rightAssociativeDataConKey, notAssociativeDataConKey, + sourceUnpackDataConKey, sourceNoUnpackDataConKey, + noSourceUnpackednessDataConKey, sourceLazyDataConKey, + sourceStrictDataConKey, noSourceStrictnessDataConKey, + decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, + metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique +prefixIDataConKey = mkPreludeDataConUnique 54 +infixIDataConKey = mkPreludeDataConUnique 55 +leftAssociativeDataConKey = mkPreludeDataConUnique 56 +rightAssociativeDataConKey = mkPreludeDataConUnique 57 +notAssociativeDataConKey = mkPreludeDataConUnique 58 +sourceUnpackDataConKey = mkPreludeDataConUnique 59 +sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 +noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 +sourceLazyDataConKey = mkPreludeDataConUnique 62 +sourceStrictDataConKey = mkPreludeDataConUnique 63 +noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 +decidedLazyDataConKey = mkPreludeDataConUnique 65 +decidedStrictDataConKey = mkPreludeDataConUnique 66 +decidedUnpackDataConKey = mkPreludeDataConUnique 67 +metaDataDataConKey = mkPreludeDataConUnique 68 +metaConsDataConKey = mkPreludeDataConUnique 69 +metaSelDataConKey = mkPreludeDataConUnique 70 + +vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique +vecRepDataConKey = mkPreludeDataConUnique 71 +tupleRepDataConKey = mkPreludeDataConUnique 72 +sumRepDataConKey = mkPreludeDataConUnique 73 + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] +liftedRepDataConKey :: Unique +runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) + = map mkPreludeDataConUnique [74..88] + +unliftedRepDataConKeys = vecRepDataConKey : + tupleRepDataConKey : + sumRepDataConKey : + unliftedSimpleRepDataConKeys + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- VecCount +vecCountDataConKeys :: [Unique] +vecCountDataConKeys = map mkPreludeDataConUnique [89..94] + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- VecElem +vecElemDataConKeys :: [Unique] +vecElemDataConKeys = map mkPreludeDataConUnique [95..104] + +-- Typeable things +kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, + kindRepFunDataConKey, kindRepTYPEDataConKey, + kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey + :: Unique +kindRepTyConAppDataConKey = mkPreludeDataConUnique 105 +kindRepVarDataConKey = mkPreludeDataConUnique 106 +kindRepAppDataConKey = mkPreludeDataConUnique 107 +kindRepFunDataConKey = mkPreludeDataConUnique 108 +kindRepTYPEDataConKey = mkPreludeDataConUnique 109 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111 + +typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique +typeLitSymbolDataConKey = mkPreludeDataConUnique 112 +typeLitNatDataConKey = mkPreludeDataConUnique 113 + +-- Unsafe equality +unsafeReflDataConKey :: Unique +unsafeReflDataConKey = mkPreludeDataConUnique 114 + +-- Multiplicity + +oneDataConKey, manyDataConKey :: Unique +oneDataConKey = mkPreludeDataConUnique 115 +manyDataConKey = mkPreludeDataConUnique 116 + +-- ghc-bignum +integerISDataConKey, integerINDataConKey, integerIPDataConKey, + naturalNSDataConKey, naturalNBDataConKey :: Unique +integerISDataConKey = mkPreludeDataConUnique 120 +integerINDataConKey = mkPreludeDataConUnique 121 +integerIPDataConKey = mkPreludeDataConUnique 122 +naturalNSDataConKey = mkPreludeDataConUnique 123 +naturalNBDataConKey = mkPreludeDataConUnique 124 + + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES DataUniques 200-250 +----------------------------------------------------- + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} +* * +************************************************************************ +-} + +wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, + buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey, + seqIdKey, eqStringIdKey, + noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, + runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, + realWorldPrimIdKey, recConErrorIdKey, + unpackCStringUtf8IdKey, unpackCStringAppendIdKey, + unpackCStringFoldrIdKey, unpackCStringFoldrUtf8IdKey, + unpackCStringIdKey, + typeErrorIdKey, divIntIdKey, modIntIdKey, + absentSumFieldErrorIdKey, cstringLengthIdKey, + raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey + :: Unique + +wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] +absentErrorIdKey = mkPreludeMiscIdUnique 1 +augmentIdKey = mkPreludeMiscIdUnique 2 +appendIdKey = mkPreludeMiscIdUnique 3 +buildIdKey = mkPreludeMiscIdUnique 4 +errorIdKey = mkPreludeMiscIdUnique 5 +foldrIdKey = mkPreludeMiscIdUnique 6 +recSelErrorIdKey = mkPreludeMiscIdUnique 7 +seqIdKey = mkPreludeMiscIdUnique 8 +absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 +eqStringIdKey = mkPreludeMiscIdUnique 10 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 +runtimeErrorIdKey = mkPreludeMiscIdUnique 13 +patErrorIdKey = mkPreludeMiscIdUnique 14 +realWorldPrimIdKey = mkPreludeMiscIdUnique 15 +recConErrorIdKey = mkPreludeMiscIdUnique 16 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 + +unpackCStringIdKey = mkPreludeMiscIdUnique 20 +unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 21 +voidPrimIdKey = mkPreludeMiscIdUnique 22 +typeErrorIdKey = mkPreludeMiscIdUnique 23 +divIntIdKey = mkPreludeMiscIdUnique 24 +modIntIdKey = mkPreludeMiscIdUnique 25 +cstringLengthIdKey = mkPreludeMiscIdUnique 26 +raiseOverflowIdKey = mkPreludeMiscIdUnique 27 +raiseUnderflowIdKey = mkPreludeMiscIdUnique 28 +raiseDivZeroIdKey = mkPreludeMiscIdUnique 29 + +concatIdKey, filterIdKey, zipIdKey, + bindIOIdKey, returnIOIdKey, newStablePtrIdKey, + printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, + fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique +concatIdKey = mkPreludeMiscIdUnique 31 +filterIdKey = mkPreludeMiscIdUnique 32 +zipIdKey = mkPreludeMiscIdUnique 33 +bindIOIdKey = mkPreludeMiscIdUnique 34 +returnIOIdKey = mkPreludeMiscIdUnique 35 +newStablePtrIdKey = mkPreludeMiscIdUnique 36 +printIdKey = mkPreludeMiscIdUnique 37 +failIOIdKey = mkPreludeMiscIdUnique 38 +nullAddrIdKey = mkPreludeMiscIdUnique 39 +voidArgIdKey = mkPreludeMiscIdUnique 40 +fstIdKey = mkPreludeMiscIdUnique 41 +sndIdKey = mkPreludeMiscIdUnique 42 +otherwiseIdKey = mkPreludeMiscIdUnique 43 +assertIdKey = mkPreludeMiscIdUnique 44 + + +rootMainKey, runMainKey :: Unique +rootMainKey = mkPreludeMiscIdUnique 101 +runMainKey = mkPreludeMiscIdUnique 102 + +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey = mkPreludeMiscIdUnique 103 +lazyIdKey = mkPreludeMiscIdUnique 104 +assertErrorIdKey = mkPreludeMiscIdUnique 105 +oneShotKey = mkPreludeMiscIdUnique 106 +runRWKey = mkPreludeMiscIdUnique 107 + +traceKey :: Unique +traceKey = mkPreludeMiscIdUnique 108 + +breakpointIdKey, breakpointCondIdKey :: Unique +breakpointIdKey = mkPreludeMiscIdUnique 110 +breakpointCondIdKey = mkPreludeMiscIdUnique 111 + +inlineIdKey, noinlineIdKey :: Unique +inlineIdKey = mkPreludeMiscIdUnique 120 +-- see below + +mapIdKey, groupWithIdKey, dollarIdKey :: Unique +mapIdKey = mkPreludeMiscIdUnique 121 +groupWithIdKey = mkPreludeMiscIdUnique 122 +dollarIdKey = mkPreludeMiscIdUnique 123 + +coercionTokenIdKey :: Unique +coercionTokenIdKey = mkPreludeMiscIdUnique 124 + +noinlineIdKey = mkPreludeMiscIdUnique 125 + +rationalToFloatIdKey, rationalToDoubleIdKey :: Unique +rationalToFloatIdKey = mkPreludeMiscIdUnique 130 +rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 + +magicDictKey :: Unique +magicDictKey = mkPreludeMiscIdUnique 156 + +coerceKey :: Unique +coerceKey = mkPreludeMiscIdUnique 157 + +{- +Certain class operations from Prelude classes. They get their own +uniques so we can look them up easily when we want to conjure them up +during type checking. +-} + +-- Just a placeholder for unbound variables produced by the renamer: +unboundKey :: Unique +unboundKey = mkPreludeMiscIdUnique 158 + +fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, + enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, + enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, + bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey + :: Unique +fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 +minusClassOpKey = mkPreludeMiscIdUnique 161 +fromRationalClassOpKey = mkPreludeMiscIdUnique 162 +enumFromClassOpKey = mkPreludeMiscIdUnique 163 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 +enumFromToClassOpKey = mkPreludeMiscIdUnique 165 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 +eqClassOpKey = mkPreludeMiscIdUnique 167 +geClassOpKey = mkPreludeMiscIdUnique 168 +negateClassOpKey = mkPreludeMiscIdUnique 169 +bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) +thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 173 +returnMClassOpKey = mkPreludeMiscIdUnique 174 + +-- Recursive do notation +mfixIdKey :: Unique +mfixIdKey = mkPreludeMiscIdUnique 175 + +-- MonadFail operations +failMClassOpKey :: Unique +failMClassOpKey = mkPreludeMiscIdUnique 176 + +-- Arrow notation +arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, + loopAIdKey :: Unique +arrAIdKey = mkPreludeMiscIdUnique 180 +composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> +firstAIdKey = mkPreludeMiscIdUnique 182 +appAIdKey = mkPreludeMiscIdUnique 183 +choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| +loopAIdKey = mkPreludeMiscIdUnique 185 + +fromStringClassOpKey :: Unique +fromStringClassOpKey = mkPreludeMiscIdUnique 186 + +-- Annotation type checking +toAnnotationWrapperIdKey :: Unique +toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 + +-- Conversion functions +fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique +fromIntegralIdKey = mkPreludeMiscIdUnique 190 +realToFracIdKey = mkPreludeMiscIdUnique 191 +toIntegerClassOpKey = mkPreludeMiscIdUnique 192 +toRationalClassOpKey = mkPreludeMiscIdUnique 193 + +-- Monad comprehensions +guardMIdKey, liftMIdKey, mzipIdKey :: Unique +guardMIdKey = mkPreludeMiscIdUnique 194 +liftMIdKey = mkPreludeMiscIdUnique 195 +mzipIdKey = mkPreludeMiscIdUnique 196 + +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + +-- Overloaded lists +isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 +fromListNClassOpKey = mkPreludeMiscIdUnique 500 +toListClassOpKey = mkPreludeMiscIdUnique 501 + +proxyHashKey :: Unique +proxyHashKey = mkPreludeMiscIdUnique 502 + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES IdUniques 200-499 +----------------------------------------------------- + +-- Used to make `Typeable` dictionaries +mkTyConKey + , mkTrTypeKey + , mkTrConKey + , mkTrAppKey + , mkTrFunKey + , typeNatTypeRepKey + , typeSymbolTypeRepKey + , typeRepIdKey + :: Unique +mkTyConKey = mkPreludeMiscIdUnique 503 +mkTrTypeKey = mkPreludeMiscIdUnique 504 +mkTrConKey = mkPreludeMiscIdUnique 505 +mkTrAppKey = mkPreludeMiscIdUnique 506 +typeNatTypeRepKey = mkPreludeMiscIdUnique 507 +typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 +typeRepIdKey = mkPreludeMiscIdUnique 509 +mkTrFunKey = mkPreludeMiscIdUnique 510 + +-- Representations for primitive types +trTYPEKey + ,trTYPE'PtrRepLiftedKey + , trRuntimeRepKey + , tr'PtrRepLiftedKey + :: Unique +trTYPEKey = mkPreludeMiscIdUnique 511 +trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512 +trRuntimeRepKey = mkPreludeMiscIdUnique 513 +tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514 + +-- KindReps for common cases +starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique +starKindRepKey = mkPreludeMiscIdUnique 520 +starArrStarKindRepKey = mkPreludeMiscIdUnique 521 +starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 + +-- Dynamic +toDynIdKey :: Unique +toDynIdKey = mkPreludeMiscIdUnique 523 + + +bitIntegerIdKey :: Unique +bitIntegerIdKey = mkPreludeMiscIdUnique 550 + +heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique +eqSCSelIdKey = mkPreludeMiscIdUnique 551 +heqSCSelIdKey = mkPreludeMiscIdUnique 552 +coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 + +sappendClassOpKey :: Unique +sappendClassOpKey = mkPreludeMiscIdUnique 554 + +memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique +memptyClassOpKey = mkPreludeMiscIdUnique 555 +mappendClassOpKey = mkPreludeMiscIdUnique 556 +mconcatClassOpKey = mkPreludeMiscIdUnique 557 + +emptyCallStackKey, pushCallStackKey :: Unique +emptyCallStackKey = mkPreludeMiscIdUnique 558 +pushCallStackKey = mkPreludeMiscIdUnique 559 + +fromStaticPtrClassOpKey :: Unique +fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 + +makeStaticKey :: Unique +makeStaticKey = mkPreludeMiscIdUnique 561 + +-- Unsafe coercion proofs +unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique +unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 +unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 + + +------------------------------------------------------ +-- ghc-bignum uses 600-699 uniques +------------------------------------------------------ + +integerFromNaturalIdKey + , integerToNaturalClampIdKey + , integerToNaturalThrowIdKey + , integerToNaturalIdKey + , integerToWordIdKey + , integerToIntIdKey + , integerToWord64IdKey + , integerToInt64IdKey + , integerAddIdKey + , integerMulIdKey + , integerSubIdKey + , integerNegateIdKey + , integerEqIdKey + , integerNeIdKey + , integerLeIdKey + , integerGtIdKey + , integerLtIdKey + , integerGeIdKey + , integerAbsIdKey + , integerSignumIdKey + , integerCompareIdKey + , integerPopCountIdKey + , integerQuotIdKey + , integerRemIdKey + , integerDivIdKey + , integerModIdKey + , integerDivModIdKey + , integerQuotRemIdKey + , integerToFloatIdKey + , integerToDoubleIdKey + , integerEncodeFloatIdKey + , integerEncodeDoubleIdKey + , integerGcdIdKey + , integerLcmIdKey + , integerAndIdKey + , integerOrIdKey + , integerXorIdKey + , integerComplementIdKey + , integerBitIdKey + , integerTestBitIdKey + , integerShiftLIdKey + , integerShiftRIdKey + , integerFromWordIdKey + , integerFromWord64IdKey + , integerFromInt64IdKey + , naturalToWordIdKey + , naturalToWordClampIdKey + , naturalEqIdKey + , naturalNeIdKey + , naturalGeIdKey + , naturalLeIdKey + , naturalGtIdKey + , naturalLtIdKey + , naturalCompareIdKey + , naturalPopCountIdKey + , naturalShiftRIdKey + , naturalShiftLIdKey + , naturalAddIdKey + , naturalSubIdKey + , naturalSubThrowIdKey + , naturalSubUnsafeIdKey + , naturalMulIdKey + , naturalSignumIdKey + , naturalNegateIdKey + , naturalQuotRemIdKey + , naturalQuotIdKey + , naturalRemIdKey + , naturalAndIdKey + , naturalAndNotIdKey + , naturalOrIdKey + , naturalXorIdKey + , naturalTestBitIdKey + , naturalBitIdKey + , naturalGcdIdKey + , naturalLcmIdKey + , naturalLog2IdKey + , naturalLogBaseWordIdKey + , naturalLogBaseIdKey + , naturalPowModIdKey + , naturalSizeInBaseIdKey + , bignatFromWordListIdKey + :: Unique + +integerFromNaturalIdKey = mkPreludeMiscIdUnique 600 +integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601 +integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602 +integerToNaturalIdKey = mkPreludeMiscIdUnique 603 +integerToWordIdKey = mkPreludeMiscIdUnique 604 +integerToIntIdKey = mkPreludeMiscIdUnique 605 +integerToWord64IdKey = mkPreludeMiscIdUnique 606 +integerToInt64IdKey = mkPreludeMiscIdUnique 607 +integerAddIdKey = mkPreludeMiscIdUnique 608 +integerMulIdKey = mkPreludeMiscIdUnique 609 +integerSubIdKey = mkPreludeMiscIdUnique 610 +integerNegateIdKey = mkPreludeMiscIdUnique 611 +integerEqIdKey = mkPreludeMiscIdUnique 612 +integerNeIdKey = mkPreludeMiscIdUnique 613 +integerLeIdKey = mkPreludeMiscIdUnique 614 +integerGtIdKey = mkPreludeMiscIdUnique 615 +integerLtIdKey = mkPreludeMiscIdUnique 616 +integerGeIdKey = mkPreludeMiscIdUnique 617 +integerAbsIdKey = mkPreludeMiscIdUnique 618 +integerSignumIdKey = mkPreludeMiscIdUnique 619 +integerCompareIdKey = mkPreludeMiscIdUnique 620 +integerPopCountIdKey = mkPreludeMiscIdUnique 621 +integerQuotIdKey = mkPreludeMiscIdUnique 622 +integerRemIdKey = mkPreludeMiscIdUnique 623 +integerDivIdKey = mkPreludeMiscIdUnique 624 +integerModIdKey = mkPreludeMiscIdUnique 625 +integerDivModIdKey = mkPreludeMiscIdUnique 626 +integerQuotRemIdKey = mkPreludeMiscIdUnique 627 +integerToFloatIdKey = mkPreludeMiscIdUnique 628 +integerToDoubleIdKey = mkPreludeMiscIdUnique 629 +integerEncodeFloatIdKey = mkPreludeMiscIdUnique 630 +integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 631 +integerGcdIdKey = mkPreludeMiscIdUnique 632 +integerLcmIdKey = mkPreludeMiscIdUnique 633 +integerAndIdKey = mkPreludeMiscIdUnique 634 +integerOrIdKey = mkPreludeMiscIdUnique 635 +integerXorIdKey = mkPreludeMiscIdUnique 636 +integerComplementIdKey = mkPreludeMiscIdUnique 637 +integerBitIdKey = mkPreludeMiscIdUnique 638 +integerTestBitIdKey = mkPreludeMiscIdUnique 639 +integerShiftLIdKey = mkPreludeMiscIdUnique 640 +integerShiftRIdKey = mkPreludeMiscIdUnique 641 +integerFromWordIdKey = mkPreludeMiscIdUnique 642 +integerFromWord64IdKey = mkPreludeMiscIdUnique 643 +integerFromInt64IdKey = mkPreludeMiscIdUnique 644 + +naturalToWordIdKey = mkPreludeMiscIdUnique 650 +naturalToWordClampIdKey = mkPreludeMiscIdUnique 651 +naturalEqIdKey = mkPreludeMiscIdUnique 652 +naturalNeIdKey = mkPreludeMiscIdUnique 653 +naturalGeIdKey = mkPreludeMiscIdUnique 654 +naturalLeIdKey = mkPreludeMiscIdUnique 655 +naturalGtIdKey = mkPreludeMiscIdUnique 656 +naturalLtIdKey = mkPreludeMiscIdUnique 657 +naturalCompareIdKey = mkPreludeMiscIdUnique 658 +naturalPopCountIdKey = mkPreludeMiscIdUnique 659 +naturalShiftRIdKey = mkPreludeMiscIdUnique 660 +naturalShiftLIdKey = mkPreludeMiscIdUnique 661 +naturalAddIdKey = mkPreludeMiscIdUnique 662 +naturalSubIdKey = mkPreludeMiscIdUnique 663 +naturalSubThrowIdKey = mkPreludeMiscIdUnique 664 +naturalSubUnsafeIdKey = mkPreludeMiscIdUnique 665 +naturalMulIdKey = mkPreludeMiscIdUnique 666 +naturalSignumIdKey = mkPreludeMiscIdUnique 667 +naturalNegateIdKey = mkPreludeMiscIdUnique 668 +naturalQuotRemIdKey = mkPreludeMiscIdUnique 669 +naturalQuotIdKey = mkPreludeMiscIdUnique 670 +naturalRemIdKey = mkPreludeMiscIdUnique 671 +naturalAndIdKey = mkPreludeMiscIdUnique 672 +naturalAndNotIdKey = mkPreludeMiscIdUnique 673 +naturalOrIdKey = mkPreludeMiscIdUnique 674 +naturalXorIdKey = mkPreludeMiscIdUnique 675 +naturalTestBitIdKey = mkPreludeMiscIdUnique 676 +naturalBitIdKey = mkPreludeMiscIdUnique 677 +naturalGcdIdKey = mkPreludeMiscIdUnique 678 +naturalLcmIdKey = mkPreludeMiscIdUnique 679 +naturalLog2IdKey = mkPreludeMiscIdUnique 680 +naturalLogBaseWordIdKey = mkPreludeMiscIdUnique 681 +naturalLogBaseIdKey = mkPreludeMiscIdUnique 682 +naturalPowModIdKey = mkPreludeMiscIdUnique 683 +naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 + +bignatFromWordListIdKey = mkPreludeMiscIdUnique 690 + +{- +************************************************************************ +* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +* * +************************************************************************ + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. +-} + +numericClassKeys :: [Unique] +numericClassKeys = + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys :: [Unique] +fractionalClassKeys = + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + +-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), +-- and are: "classes defined in the Prelude or a standard library" +standardClassKeys :: [Unique] +standardClassKeys = derivableClassKeys ++ numericClassKeys + ++ [randomClassKey, randomGenClassKey, + functorClassKey, + monadClassKey, monadPlusClassKey, monadFailClassKey, + semigroupClassKey, monoidClassKey, + isStringClassKey, + applicativeClassKey, foldableClassKey, + traversableClassKey, alternativeClassKey + ] + +{- +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@GHC.Tc.Deriv@). +-} + +derivableClassKeys :: [Unique] +derivableClassKeys + = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, + boundedClassKey, showClassKey, readClassKey ] + + +-- These are the "interactive classes" that are consulted when doing +-- defaulting. Does not include Num or IsString, which have special +-- handling. +interactiveClassNames :: [Name] +interactiveClassNames + = [ showClassName, eqClassName, ordClassName, foldableClassName + , traversableClassName ] + +interactiveClassKeys :: [Unique] +interactiveClassKeys = map getUnique interactiveClassNames + +{- +************************************************************************ +* * + Semi-builtin names +* * +************************************************************************ + +The following names should be considered by GHCi to be in scope always. + +-} + +pretendNameIsInScope :: Name -> Bool +pretendNameIsInScope n + = any (n `hasKey`) + [ liftedTypeKindTyConKey, tYPETyConKey + , runtimeRepTyConKey, liftedRepDataConKey ] diff --git a/GHC/Builtin/Names/TH.hs b/GHC/Builtin/Names/TH.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Names/TH.hs @@ -0,0 +1,1120 @@ +-- %************************************************************************ +-- %* * +-- The known-key names for Template Haskell +-- %* * +-- %************************************************************************ + +module GHC.Builtin.Names.TH where + +import GHC.Prelude () + +import GHC.Builtin.Names( mk_known_key_name ) +import GHC.Unit +import GHC.Types.Name( Name ) +import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) +import GHC.Types.Name.Reader( RdrName, nameRdrName ) +import GHC.Types.Unique +import GHC.Data.FastString + +-- To add a name, do three things +-- +-- 1) Allocate a key +-- 2) Make a "Name" +-- 3) Add the name to templateHaskellNames + +templateHaskellNames :: [Name] +-- The names that are implicitly mentioned by ``bracket'' +-- Should stay in sync with the import list of GHC.HsToCore.Quote + +templateHaskellNames = [ + returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + mkNameSName, + mkModNameName, + liftStringName, + unTypeName, unTypeCodeName, + unsafeCodeCoerceName, + + -- Lit + charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName, + -- Pat + litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, + conPName, tildePName, bangPName, infixPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName, + -- FieldPat + fieldPatName, + -- Match + matchName, + -- Clause + clauseName, + -- Exp + varEName, conEName, litEName, appEName, appTypeEName, infixEName, + infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, + tupEName, unboxedTupEName, unboxedSumEName, + condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName, + fromEName, fromThenEName, fromToEName, fromThenToEName, + listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, + labelEName, implicitParamVarEName, + -- FieldExp + fieldExpName, + -- Body + guardedBName, normalBName, + -- Guard + normalGEName, patGEName, + -- Stmt + bindSName, letSName, noBindSName, parSName, recSName, + -- Dec + funDName, valDName, dataDName, newtypeDName, tySynDName, + classDName, instanceWithOverlapDName, + standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, + pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, + pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, + dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, + dataInstDName, newtypeInstDName, tySynInstDName, + infixLDName, infixRDName, infixNDName, + roleAnnotDName, patSynDName, patSynSigDName, + implicitParamBindDName, + -- Cxt + cxtName, + + -- SourceUnpackedness + noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, + -- SourceStrictness + noSourceStrictnessName, sourceLazyName, sourceStrictName, + -- Con + normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName, + -- Bang + bangName, + -- BangType + bangTypeName, + -- VarBangType + varBangTypeName, + -- PatSynDir (for pattern synonyms) + unidirPatSynName, implBidirPatSynName, explBidirPatSynName, + -- PatSynArgs (for pattern synonyms) + prefixPatSynName, infixPatSynName, recordPatSynName, + -- Type + forallTName, forallVisTName, varTName, conTName, infixTName, appTName, + appKindTName, equalityTName, tupleTName, unboxedTupleTName, + unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName, + promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, + wildCardTName, implicitParamTName, + -- TyLit + numTyLitName, strTyLitName, + -- TyVarBndr + plainTVName, kindedTVName, + plainInvisTVName, kindedInvisTVName, + -- Specificity + specifiedSpecName, inferredSpecName, + -- Role + nominalRName, representationalRName, phantomRName, inferRName, + -- Kind + starKName, constraintKName, + -- FamilyResultSig + noSigName, kindSigName, tyVarSigName, + -- InjectivityAnn + injectivityAnnName, + -- Callconv + cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, + -- Safety + unsafeName, + safeName, + interruptibleName, + -- Inline + noInlineDataConName, inlineDataConName, inlinableDataConName, + -- RuleMatch + conLikeDataConName, funLikeDataConName, + -- Phases + allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, + -- Overlap + overlappableDataConName, overlappingDataConName, overlapsDataConName, + incoherentDataConName, + -- DerivStrategy + stockStrategyName, anyclassStrategyName, + newtypeStrategyName, viaStrategyName, + -- RuleBndr + ruleVarName, typedRuleVarName, + -- FunDep + funDepName, + -- TySynEqn + tySynEqnName, + -- AnnTarget + valueAnnotationName, typeAnnotationName, moduleAnnotationName, + -- DerivClause + derivClauseName, + + -- The type classes + liftClassName, quoteClassName, + + -- And the tycons + qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName, + expQTyConName, fieldExpTyConName, predTyConName, + stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, + varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, + typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName, + patQTyConName, funDepTyConName, decsQTyConName, + ruleBndrTyConName, tySynEqnTyConName, + roleTyConName, codeTyConName, injAnnTyConName, kindTyConName, + overlapTyConName, derivClauseTyConName, derivStrategyTyConName, + modNameTyConName, + + -- Quasiquoting + quoteDecName, quoteTypeName, quoteExpName, quotePatName] + +thSyn, thLib, qqLib :: Module +thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") +thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal") +qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") + +mkTHModule :: FastString -> Module +mkTHModule m = mkModule thUnit (mkModuleNameFS m) + +libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name +libFun = mk_known_key_name varName thLib +libTc = mk_known_key_name tcName thLib +thFun = mk_known_key_name varName thSyn +thTc = mk_known_key_name tcName thSyn +thCls = mk_known_key_name clsName thSyn +thCon = mk_known_key_name dataName thSyn +qqFun = mk_known_key_name varName qqLib + +-------------------- TH.Syntax ----------------------- +liftClassName :: Name +liftClassName = thCls (fsLit "Lift") liftClassKey + +quoteClassName :: Name +quoteClassName = thCls (fsLit "Quote") quoteClassKey + +qTyConName, nameTyConName, fieldExpTyConName, patTyConName, + fieldPatTyConName, expTyConName, decTyConName, typeTyConName, + matchTyConName, clauseTyConName, funDepTyConName, predTyConName, + codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName, + modNameTyConName :: Name +qTyConName = thTc (fsLit "Q") qTyConKey +nameTyConName = thTc (fsLit "Name") nameTyConKey +fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey +patTyConName = thTc (fsLit "Pat") patTyConKey +fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey +expTyConName = thTc (fsLit "Exp") expTyConKey +decTyConName = thTc (fsLit "Dec") decTyConKey +decsTyConName = libTc (fsLit "Decs") decsTyConKey +typeTyConName = thTc (fsLit "Type") typeTyConKey +matchTyConName = thTc (fsLit "Match") matchTyConKey +clauseTyConName = thTc (fsLit "Clause") clauseTyConKey +funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey +codeTyConName = thTc (fsLit "Code") codeTyConKey +injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey +overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey +modNameTyConName = thTc (fsLit "ModName") modNameTyConKey + +returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, + mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName, + unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey +newNameName = thFun (fsLit "newName") newNameIdKey +liftName = thFun (fsLit "lift") liftIdKey +liftStringName = thFun (fsLit "liftString") liftStringIdKey +mkNameName = thFun (fsLit "mkName") mkNameIdKey +mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey +mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey +mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey +mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey +mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey +unTypeName = thFun (fsLit "unType") unTypeIdKey +unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey +unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey +liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey + + +-------------------- TH.Lib ----------------------- +-- data Lit = ... +charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, + charPrimLName :: Name +charLName = libFun (fsLit "charL") charLIdKey +stringLName = libFun (fsLit "stringL") stringLIdKey +integerLName = libFun (fsLit "integerL") integerLIdKey +intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey +wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey +floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey +doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey +rationalLName = libFun (fsLit "rationalL") rationalLIdKey +stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey +charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey + +-- data Pat = ... +litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, + infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, + sigPName, viewPName :: Name +litPName = libFun (fsLit "litP") litPIdKey +varPName = libFun (fsLit "varP") varPIdKey +tupPName = libFun (fsLit "tupP") tupPIdKey +unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey +unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey +conPName = libFun (fsLit "conP") conPIdKey +infixPName = libFun (fsLit "infixP") infixPIdKey +tildePName = libFun (fsLit "tildeP") tildePIdKey +bangPName = libFun (fsLit "bangP") bangPIdKey +asPName = libFun (fsLit "asP") asPIdKey +wildPName = libFun (fsLit "wildP") wildPIdKey +recPName = libFun (fsLit "recP") recPIdKey +listPName = libFun (fsLit "listP") listPIdKey +sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey + +-- type FieldPat = ... +fieldPatName :: Name +fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey + +-- data Match = ... +matchName :: Name +matchName = libFun (fsLit "match") matchIdKey + +-- data Clause = ... +clauseName :: Name +clauseName = libFun (fsLit "clause") clauseIdKey + +-- data Exp = ... +varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName, + sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, + unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, + caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName, + labelEName, implicitParamVarEName :: Name +varEName = libFun (fsLit "varE") varEIdKey +conEName = libFun (fsLit "conE") conEIdKey +litEName = libFun (fsLit "litE") litEIdKey +appEName = libFun (fsLit "appE") appEIdKey +appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey +infixEName = libFun (fsLit "infixE") infixEIdKey +infixAppName = libFun (fsLit "infixApp") infixAppIdKey +sectionLName = libFun (fsLit "sectionL") sectionLIdKey +sectionRName = libFun (fsLit "sectionR") sectionRIdKey +lamEName = libFun (fsLit "lamE") lamEIdKey +lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey +tupEName = libFun (fsLit "tupE") tupEIdKey +unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey +unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey +condEName = libFun (fsLit "condE") condEIdKey +multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey +letEName = libFun (fsLit "letE") letEIdKey +caseEName = libFun (fsLit "caseE") caseEIdKey +doEName = libFun (fsLit "doE") doEIdKey +mdoEName = libFun (fsLit "mdoE") mdoEIdKey +compEName = libFun (fsLit "compE") compEIdKey +-- ArithSeq skips a level +fromEName, fromThenEName, fromToEName, fromThenToEName :: Name +fromEName = libFun (fsLit "fromE") fromEIdKey +fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey +fromToEName = libFun (fsLit "fromToE") fromToEIdKey +fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey +-- end ArithSeq +listEName, sigEName, recConEName, recUpdEName :: Name +listEName = libFun (fsLit "listE") listEIdKey +sigEName = libFun (fsLit "sigE") sigEIdKey +recConEName = libFun (fsLit "recConE") recConEIdKey +recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey +staticEName = libFun (fsLit "staticE") staticEIdKey +unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey +labelEName = libFun (fsLit "labelE") labelEIdKey +implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey + +-- type FieldExp = ... +fieldExpName :: Name +fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey + +-- data Body = ... +guardedBName, normalBName :: Name +guardedBName = libFun (fsLit "guardedB") guardedBIdKey +normalBName = libFun (fsLit "normalB") normalBIdKey + +-- data Guard = ... +normalGEName, patGEName :: Name +normalGEName = libFun (fsLit "normalGE") normalGEIdKey +patGEName = libFun (fsLit "patGE") patGEIdKey + +-- data Stmt = ... +bindSName, letSName, noBindSName, parSName, recSName :: Name +bindSName = libFun (fsLit "bindS") bindSIdKey +letSName = libFun (fsLit "letS") letSIdKey +noBindSName = libFun (fsLit "noBindS") noBindSIdKey +parSName = libFun (fsLit "parS") parSIdKey +recSName = libFun (fsLit "recS") recSIdKey + +-- data Dec = ... +funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, + instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, + pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, + pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, + dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, + openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, + infixNDName, roleAnnotDName, patSynDName, patSynSigDName, + pragCompleteDName, implicitParamBindDName :: Name +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey +standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey +pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey +pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey +pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey +closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey +dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey +roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey +patSynDName = libFun (fsLit "patSynD") patSynDIdKey +patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey +implicitParamBindDName = libFun (fsLit "implicitParamBindD") implicitParamBindDIdKey + +-- type Ctxt = ... +cxtName :: Name +cxtName = libFun (fsLit "cxt") cxtIdKey + +-- data SourceUnpackedness = ... +noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name +noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey +sourceNoUnpackName = libFun (fsLit "sourceNoUnpack") sourceNoUnpackKey +sourceUnpackName = libFun (fsLit "sourceUnpack") sourceUnpackKey + +-- data SourceStrictness = ... +noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name +noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey +sourceLazyName = libFun (fsLit "sourceLazy") sourceLazyKey +sourceStrictName = libFun (fsLit "sourceStrict") sourceStrictKey + +-- data Con = ... +normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name +normalCName = libFun (fsLit "normalC" ) normalCIdKey +recCName = libFun (fsLit "recC" ) recCIdKey +infixCName = libFun (fsLit "infixC" ) infixCIdKey +forallCName = libFun (fsLit "forallC" ) forallCIdKey +gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey +recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey + +-- data Bang = ... +bangName :: Name +bangName = libFun (fsLit "bang") bangIdKey + +-- type BangType = ... +bangTypeName :: Name +bangTypeName = libFun (fsLit "bangType") bangTKey + +-- type VarBangType = ... +varBangTypeName :: Name +varBangTypeName = libFun (fsLit "varBangType") varBangTKey + +-- data PatSynDir = ... +unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name +unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey +implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey +explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey + +-- data PatSynArgs = ... +prefixPatSynName, infixPatSynName, recordPatSynName :: Name +prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey +infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey +recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey + +-- data Type = ... +forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, + unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName, + appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName, + promotedTupleTName, promotedNilTName, promotedConsTName, + wildCardTName, implicitParamTName :: Name +forallTName = libFun (fsLit "forallT") forallTIdKey +forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey +varTName = libFun (fsLit "varT") varTIdKey +conTName = libFun (fsLit "conT") conTIdKey +tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey +unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey +arrowTName = libFun (fsLit "arrowT") arrowTIdKey +mulArrowTName = libFun (fsLit "mulArrowT") mulArrowTIdKey +listTName = libFun (fsLit "listT") listTIdKey +appTName = libFun (fsLit "appT") appTIdKey +appKindTName = libFun (fsLit "appKindT") appKindTIdKey +sigTName = libFun (fsLit "sigT") sigTIdKey +equalityTName = libFun (fsLit "equalityT") equalityTIdKey +litTName = libFun (fsLit "litT") litTIdKey +promotedTName = libFun (fsLit "promotedT") promotedTIdKey +promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey +promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey +promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey +wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey +infixTName = libFun (fsLit "infixT") infixTIdKey +implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey + +-- data TyLit = ... +numTyLitName, strTyLitName :: Name +numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey +strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey + +-- data TyVarBndr = ... +plainTVName, kindedTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey + +plainInvisTVName, kindedInvisTVName :: Name +plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey +kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey + +-- data Specificity = ... +specifiedSpecName, inferredSpecName :: Name +specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey +inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey + +-- data Role = ... +nominalRName, representationalRName, phantomRName, inferRName :: Name +nominalRName = libFun (fsLit "nominalR") nominalRIdKey +representationalRName = libFun (fsLit "representationalR") representationalRIdKey +phantomRName = libFun (fsLit "phantomR") phantomRIdKey +inferRName = libFun (fsLit "inferR") inferRIdKey + +-- data Kind = ... +starKName, constraintKName :: Name +starKName = libFun (fsLit "starK") starKIdKey +constraintKName = libFun (fsLit "constraintK") constraintKIdKey + +-- data FamilyResultSig = ... +noSigName, kindSigName, tyVarSigName :: Name +noSigName = libFun (fsLit "noSig") noSigIdKey +kindSigName = libFun (fsLit "kindSig") kindSigIdKey +tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey + +-- data InjectivityAnn = ... +injectivityAnnName :: Name +injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey + +-- data Callconv = ... +cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name +cCallName = libFun (fsLit "cCall") cCallIdKey +stdCallName = libFun (fsLit "stdCall") stdCallIdKey +cApiCallName = libFun (fsLit "cApi") cApiCallIdKey +primCallName = libFun (fsLit "prim") primCallIdKey +javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey + +-- data Safety = ... +unsafeName, safeName, interruptibleName :: Name +unsafeName = libFun (fsLit "unsafe") unsafeIdKey +safeName = libFun (fsLit "safe") safeIdKey +interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey + +-- data RuleBndr = ... +ruleVarName, typedRuleVarName :: Name +ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey +typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey + +-- data FunDep = ... +funDepName :: Name +funDepName = libFun (fsLit "funDep") funDepIdKey + +-- data TySynEqn = ... +tySynEqnName :: Name +tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey + +-- data AnnTarget = ... +valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name +valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey +typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey +moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey + +-- type DerivClause = ... +derivClauseName :: Name +derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey + +-- data DerivStrategy = ... +stockStrategyName, anyclassStrategyName, newtypeStrategyName, + viaStrategyName :: Name +stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey +anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey +newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey +viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey + +patQTyConName, expQTyConName, stmtTyConName, + conTyConName, bangTypeTyConName, + varBangTypeTyConName, typeQTyConName, + decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, + derivClauseTyConName, kindTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, + derivStrategyTyConName :: Name +-- These are only used for the types of top-level splices +expQTyConName = libTc (fsLit "ExpQ") expQTyConKey +decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] +typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey +patQTyConName = libTc (fsLit "PatQ") patQTyConKey + +-- These are used in GHC.HsToCore.Quote but always wrapped in a type variable +stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey +conTyConName = thTc (fsLit "Con") conTyConKey +bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey +varBangTypeTyConName = thTc (fsLit "VarBangType") varBangTypeTyConKey +ruleBndrTyConName = thTc (fsLit "RuleBndr") ruleBndrTyConKey +tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey +roleTyConName = libTc (fsLit "Role") roleTyConKey +derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey +kindTyConName = thTc (fsLit "Kind") kindTyConKey +tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey +tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey +derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey + +-- quasiquoting +quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name +quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey +quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey + +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + +-- data RuleMatch = ... +conLikeDataConName, funLikeDataConName :: Name +conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey +funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey + +-- data Phases = ... +allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name +allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey +fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey +beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey + +-- data Overlap = ... +overlappableDataConName, + overlappingDataConName, + overlapsDataConName, + incoherentDataConName :: Name +overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey +overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey +overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey +incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey + +{- ********************************************************************* +* * + Class keys +* * +********************************************************************* -} + +-- ClassUniques available: 200-299 +-- Check in GHC.Builtin.Names if you want to change this + +liftClassKey :: Unique +liftClassKey = mkPreludeClassUnique 200 + +quoteClassKey :: Unique +quoteClassKey = mkPreludeClassUnique 201 + +{- ********************************************************************* +* * + TyCon keys +* * +********************************************************************* -} + +-- TyConUniques available: 200-299 +-- Check in GHC.Builtin.Names if you want to change this + +expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, + patTyConKey, + stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, + tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, + decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, + fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, + funDepTyConKey, predTyConKey, + predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, + roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey, + overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey, + modNameTyConKey :: Unique +expTyConKey = mkPreludeTyConUnique 200 +matchTyConKey = mkPreludeTyConUnique 201 +clauseTyConKey = mkPreludeTyConUnique 202 +qTyConKey = mkPreludeTyConUnique 203 +expQTyConKey = mkPreludeTyConUnique 204 +patTyConKey = mkPreludeTyConUnique 206 +stmtTyConKey = mkPreludeTyConUnique 209 +conTyConKey = mkPreludeTyConUnique 210 +typeQTyConKey = mkPreludeTyConUnique 211 +typeTyConKey = mkPreludeTyConUnique 212 +decTyConKey = mkPreludeTyConUnique 213 +bangTypeTyConKey = mkPreludeTyConUnique 214 +varBangTypeTyConKey = mkPreludeTyConUnique 215 +fieldExpTyConKey = mkPreludeTyConUnique 216 +fieldPatTyConKey = mkPreludeTyConUnique 217 +nameTyConKey = mkPreludeTyConUnique 218 +patQTyConKey = mkPreludeTyConUnique 219 +funDepTyConKey = mkPreludeTyConUnique 222 +predTyConKey = mkPreludeTyConUnique 223 +predQTyConKey = mkPreludeTyConUnique 224 +tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225 +decsQTyConKey = mkPreludeTyConUnique 226 +ruleBndrTyConKey = mkPreludeTyConUnique 227 +tySynEqnTyConKey = mkPreludeTyConUnique 228 +roleTyConKey = mkPreludeTyConUnique 229 +injAnnTyConKey = mkPreludeTyConUnique 231 +kindTyConKey = mkPreludeTyConUnique 232 +overlapTyConKey = mkPreludeTyConUnique 233 +derivClauseTyConKey = mkPreludeTyConUnique 234 +derivStrategyTyConKey = mkPreludeTyConUnique 235 +decsTyConKey = mkPreludeTyConUnique 236 +tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 +codeTyConKey = mkPreludeTyConUnique 238 +modNameTyConKey = mkPreludeTyConUnique 239 + +{- ********************************************************************* +* * + DataCon keys +* * +********************************************************************* -} + +-- DataConUniques available: 100-150 +-- If you want to change this, make sure you check in GHC.Builtin.Names + +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 200 +inlineDataConKey = mkPreludeDataConUnique 201 +inlinableDataConKey = mkPreludeDataConUnique 202 + +-- data RuleMatch = ... +conLikeDataConKey, funLikeDataConKey :: Unique +conLikeDataConKey = mkPreludeDataConUnique 203 +funLikeDataConKey = mkPreludeDataConUnique 204 + +-- data Phases = ... +allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique +allPhasesDataConKey = mkPreludeDataConUnique 205 +fromPhaseDataConKey = mkPreludeDataConUnique 206 +beforePhaseDataConKey = mkPreludeDataConUnique 207 + +-- data Overlap = .. +overlappableDataConKey, + overlappingDataConKey, + overlapsDataConKey, + incoherentDataConKey :: Unique +overlappableDataConKey = mkPreludeDataConUnique 209 +overlappingDataConKey = mkPreludeDataConUnique 210 +overlapsDataConKey = mkPreludeDataConUnique 211 +incoherentDataConKey = mkPreludeDataConUnique 212 + +{- ********************************************************************* +* * + Id keys +* * +********************************************************************* -} + +-- IdUniques available: 200-499 +-- If you want to change this, make sure you check in GHC.Builtin.Names + +returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey, + unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique +returnQIdKey = mkPreludeMiscIdUnique 200 +bindQIdKey = mkPreludeMiscIdUnique 201 +sequenceQIdKey = mkPreludeMiscIdUnique 202 +liftIdKey = mkPreludeMiscIdUnique 203 +newNameIdKey = mkPreludeMiscIdUnique 204 +mkNameIdKey = mkPreludeMiscIdUnique 205 +mkNameG_vIdKey = mkPreludeMiscIdUnique 206 +mkNameG_dIdKey = mkPreludeMiscIdUnique 207 +mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 +mkNameLIdKey = mkPreludeMiscIdUnique 209 +mkNameSIdKey = mkPreludeMiscIdUnique 210 +unTypeIdKey = mkPreludeMiscIdUnique 211 +unTypeCodeIdKey = mkPreludeMiscIdUnique 212 +liftTypedIdKey = mkPreludeMiscIdUnique 214 +mkModNameIdKey = mkPreludeMiscIdUnique 215 +unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 + + +-- data Lit = ... +charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, + floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey, + charPrimLIdKey:: Unique +charLIdKey = mkPreludeMiscIdUnique 220 +stringLIdKey = mkPreludeMiscIdUnique 221 +integerLIdKey = mkPreludeMiscIdUnique 222 +intPrimLIdKey = mkPreludeMiscIdUnique 223 +wordPrimLIdKey = mkPreludeMiscIdUnique 224 +floatPrimLIdKey = mkPreludeMiscIdUnique 225 +doublePrimLIdKey = mkPreludeMiscIdUnique 226 +rationalLIdKey = mkPreludeMiscIdUnique 227 +stringPrimLIdKey = mkPreludeMiscIdUnique 228 +charPrimLIdKey = mkPreludeMiscIdUnique 229 + +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 230 + +-- data Pat = ... +litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey, + infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, + listPIdKey, sigPIdKey, viewPIdKey :: Unique +litPIdKey = mkPreludeMiscIdUnique 240 +varPIdKey = mkPreludeMiscIdUnique 241 +tupPIdKey = mkPreludeMiscIdUnique 242 +unboxedTupPIdKey = mkPreludeMiscIdUnique 243 +unboxedSumPIdKey = mkPreludeMiscIdUnique 244 +conPIdKey = mkPreludeMiscIdUnique 245 +infixPIdKey = mkPreludeMiscIdUnique 246 +tildePIdKey = mkPreludeMiscIdUnique 247 +bangPIdKey = mkPreludeMiscIdUnique 248 +asPIdKey = mkPreludeMiscIdUnique 249 +wildPIdKey = mkPreludeMiscIdUnique 250 +recPIdKey = mkPreludeMiscIdUnique 251 +listPIdKey = mkPreludeMiscIdUnique 252 +sigPIdKey = mkPreludeMiscIdUnique 253 +viewPIdKey = mkPreludeMiscIdUnique 254 + +-- type FieldPat = ... +fieldPatIdKey :: Unique +fieldPatIdKey = mkPreludeMiscIdUnique 260 + +-- data Match = ... +matchIdKey :: Unique +matchIdKey = mkPreludeMiscIdUnique 261 + +-- data Clause = ... +clauseIdKey :: Unique +clauseIdKey = mkPreludeMiscIdUnique 262 + + +-- data Exp = ... +varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, + infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, + tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey, + letEIdKey, caseEIdKey, doEIdKey, compEIdKey, + fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, + listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, + unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique +varEIdKey = mkPreludeMiscIdUnique 270 +conEIdKey = mkPreludeMiscIdUnique 271 +litEIdKey = mkPreludeMiscIdUnique 272 +appEIdKey = mkPreludeMiscIdUnique 273 +appTypeEIdKey = mkPreludeMiscIdUnique 274 +infixEIdKey = mkPreludeMiscIdUnique 275 +infixAppIdKey = mkPreludeMiscIdUnique 276 +sectionLIdKey = mkPreludeMiscIdUnique 277 +sectionRIdKey = mkPreludeMiscIdUnique 278 +lamEIdKey = mkPreludeMiscIdUnique 279 +lamCaseEIdKey = mkPreludeMiscIdUnique 280 +tupEIdKey = mkPreludeMiscIdUnique 281 +unboxedTupEIdKey = mkPreludeMiscIdUnique 282 +unboxedSumEIdKey = mkPreludeMiscIdUnique 283 +condEIdKey = mkPreludeMiscIdUnique 284 +multiIfEIdKey = mkPreludeMiscIdUnique 285 +letEIdKey = mkPreludeMiscIdUnique 286 +caseEIdKey = mkPreludeMiscIdUnique 287 +doEIdKey = mkPreludeMiscIdUnique 288 +compEIdKey = mkPreludeMiscIdUnique 289 +fromEIdKey = mkPreludeMiscIdUnique 290 +fromThenEIdKey = mkPreludeMiscIdUnique 291 +fromToEIdKey = mkPreludeMiscIdUnique 292 +fromThenToEIdKey = mkPreludeMiscIdUnique 293 +listEIdKey = mkPreludeMiscIdUnique 294 +sigEIdKey = mkPreludeMiscIdUnique 295 +recConEIdKey = mkPreludeMiscIdUnique 296 +recUpdEIdKey = mkPreludeMiscIdUnique 297 +staticEIdKey = mkPreludeMiscIdUnique 298 +unboundVarEIdKey = mkPreludeMiscIdUnique 299 +labelEIdKey = mkPreludeMiscIdUnique 300 +implicitParamVarEIdKey = mkPreludeMiscIdUnique 301 +mdoEIdKey = mkPreludeMiscIdUnique 302 + +-- type FieldExp = ... +fieldExpIdKey :: Unique +fieldExpIdKey = mkPreludeMiscIdUnique 305 + +-- data Body = ... +guardedBIdKey, normalBIdKey :: Unique +guardedBIdKey = mkPreludeMiscIdUnique 306 +normalBIdKey = mkPreludeMiscIdUnique 307 + +-- data Guard = ... +normalGEIdKey, patGEIdKey :: Unique +normalGEIdKey = mkPreludeMiscIdUnique 308 +patGEIdKey = mkPreludeMiscIdUnique 309 + +-- data Stmt = ... +bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique +bindSIdKey = mkPreludeMiscIdUnique 310 +letSIdKey = mkPreludeMiscIdUnique 311 +noBindSIdKey = mkPreludeMiscIdUnique 312 +parSIdKey = mkPreludeMiscIdUnique 313 +recSIdKey = mkPreludeMiscIdUnique 314 + +-- data Dec = ... +funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, + instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, + pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, + pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, + openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, + newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, + infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, + patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, + kiSigDIdKey :: Unique +funDIdKey = mkPreludeMiscIdUnique 320 +valDIdKey = mkPreludeMiscIdUnique 321 +dataDIdKey = mkPreludeMiscIdUnique 322 +newtypeDIdKey = mkPreludeMiscIdUnique 323 +tySynDIdKey = mkPreludeMiscIdUnique 324 +classDIdKey = mkPreludeMiscIdUnique 325 +instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326 +instanceDIdKey = mkPreludeMiscIdUnique 327 +sigDIdKey = mkPreludeMiscIdUnique 328 +forImpDIdKey = mkPreludeMiscIdUnique 329 +pragInlDIdKey = mkPreludeMiscIdUnique 330 +pragSpecDIdKey = mkPreludeMiscIdUnique 331 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 332 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 333 +pragRuleDIdKey = mkPreludeMiscIdUnique 334 +pragAnnDIdKey = mkPreludeMiscIdUnique 335 +dataFamilyDIdKey = mkPreludeMiscIdUnique 336 +openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337 +dataInstDIdKey = mkPreludeMiscIdUnique 338 +newtypeInstDIdKey = mkPreludeMiscIdUnique 339 +tySynInstDIdKey = mkPreludeMiscIdUnique 340 +closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341 +infixLDIdKey = mkPreludeMiscIdUnique 342 +infixRDIdKey = mkPreludeMiscIdUnique 343 +infixNDIdKey = mkPreludeMiscIdUnique 344 +roleAnnotDIdKey = mkPreludeMiscIdUnique 345 +standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 +defaultSigDIdKey = mkPreludeMiscIdUnique 347 +patSynDIdKey = mkPreludeMiscIdUnique 348 +patSynSigDIdKey = mkPreludeMiscIdUnique 349 +pragCompleteDIdKey = mkPreludeMiscIdUnique 350 +implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 +kiSigDIdKey = mkPreludeMiscIdUnique 352 + +-- type Cxt = ... +cxtIdKey :: Unique +cxtIdKey = mkPreludeMiscIdUnique 361 + +-- data SourceUnpackedness = ... +noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique +noSourceUnpackednessKey = mkPreludeMiscIdUnique 362 +sourceNoUnpackKey = mkPreludeMiscIdUnique 363 +sourceUnpackKey = mkPreludeMiscIdUnique 364 + +-- data SourceStrictness = ... +noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique +noSourceStrictnessKey = mkPreludeMiscIdUnique 365 +sourceLazyKey = mkPreludeMiscIdUnique 366 +sourceStrictKey = mkPreludeMiscIdUnique 367 + +-- data Con = ... +normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey, + recGadtCIdKey :: Unique +normalCIdKey = mkPreludeMiscIdUnique 368 +recCIdKey = mkPreludeMiscIdUnique 369 +infixCIdKey = mkPreludeMiscIdUnique 370 +forallCIdKey = mkPreludeMiscIdUnique 371 +gadtCIdKey = mkPreludeMiscIdUnique 372 +recGadtCIdKey = mkPreludeMiscIdUnique 373 + +-- data Bang = ... +bangIdKey :: Unique +bangIdKey = mkPreludeMiscIdUnique 374 + +-- type BangType = ... +bangTKey :: Unique +bangTKey = mkPreludeMiscIdUnique 375 + +-- type VarBangType = ... +varBangTKey :: Unique +varBangTKey = mkPreludeMiscIdUnique 376 + +-- data PatSynDir = ... +unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique +unidirPatSynIdKey = mkPreludeMiscIdUnique 377 +implBidirPatSynIdKey = mkPreludeMiscIdUnique 378 +explBidirPatSynIdKey = mkPreludeMiscIdUnique 379 + +-- data PatSynArgs = ... +prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique +prefixPatSynIdKey = mkPreludeMiscIdUnique 380 +infixPatSynIdKey = mkPreludeMiscIdUnique 381 +recordPatSynIdKey = mkPreludeMiscIdUnique 382 + +-- data Type = ... +forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey, + unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, + appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, + promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, + wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique +forallTIdKey = mkPreludeMiscIdUnique 390 +forallVisTIdKey = mkPreludeMiscIdUnique 391 +varTIdKey = mkPreludeMiscIdUnique 392 +conTIdKey = mkPreludeMiscIdUnique 393 +tupleTIdKey = mkPreludeMiscIdUnique 394 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 395 +unboxedSumTIdKey = mkPreludeMiscIdUnique 396 +arrowTIdKey = mkPreludeMiscIdUnique 397 +listTIdKey = mkPreludeMiscIdUnique 398 +appTIdKey = mkPreludeMiscIdUnique 399 +appKindTIdKey = mkPreludeMiscIdUnique 400 +sigTIdKey = mkPreludeMiscIdUnique 401 +equalityTIdKey = mkPreludeMiscIdUnique 402 +litTIdKey = mkPreludeMiscIdUnique 403 +promotedTIdKey = mkPreludeMiscIdUnique 404 +promotedTupleTIdKey = mkPreludeMiscIdUnique 405 +promotedNilTIdKey = mkPreludeMiscIdUnique 406 +promotedConsTIdKey = mkPreludeMiscIdUnique 407 +wildCardTIdKey = mkPreludeMiscIdUnique 408 +implicitParamTIdKey = mkPreludeMiscIdUnique 409 +infixTIdKey = mkPreludeMiscIdUnique 410 + +-- data TyLit = ... +numTyLitIdKey, strTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 411 +strTyLitIdKey = mkPreludeMiscIdUnique 412 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 413 +kindedTVIdKey = mkPreludeMiscIdUnique 414 + +plainInvisTVIdKey, kindedInvisTVIdKey :: Unique +plainInvisTVIdKey = mkPreludeMiscIdUnique 482 +kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 + +-- data Role = ... +nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique +nominalRIdKey = mkPreludeMiscIdUnique 415 +representationalRIdKey = mkPreludeMiscIdUnique 416 +phantomRIdKey = mkPreludeMiscIdUnique 417 +inferRIdKey = mkPreludeMiscIdUnique 418 + +-- data Kind = ... +starKIdKey, constraintKIdKey :: Unique +starKIdKey = mkPreludeMiscIdUnique 425 +constraintKIdKey = mkPreludeMiscIdUnique 426 + +-- data FamilyResultSig = ... +noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique +noSigIdKey = mkPreludeMiscIdUnique 427 +kindSigIdKey = mkPreludeMiscIdUnique 428 +tyVarSigIdKey = mkPreludeMiscIdUnique 429 + +-- data InjectivityAnn = ... +injectivityAnnIdKey :: Unique +injectivityAnnIdKey = mkPreludeMiscIdUnique 430 + +-- data Callconv = ... +cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, + javaScriptCallIdKey :: Unique +cCallIdKey = mkPreludeMiscIdUnique 431 +stdCallIdKey = mkPreludeMiscIdUnique 432 +cApiCallIdKey = mkPreludeMiscIdUnique 433 +primCallIdKey = mkPreludeMiscIdUnique 434 +javaScriptCallIdKey = mkPreludeMiscIdUnique 435 + +-- data Safety = ... +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique +unsafeIdKey = mkPreludeMiscIdUnique 440 +safeIdKey = mkPreludeMiscIdUnique 441 +interruptibleIdKey = mkPreludeMiscIdUnique 442 + +-- data FunDep = ... +funDepIdKey :: Unique +funDepIdKey = mkPreludeMiscIdUnique 445 + +-- mulArrow +mulArrowTIdKey :: Unique +mulArrowTIdKey = mkPreludeMiscIdUnique 446 + +-- data TySynEqn = ... +tySynEqnIdKey :: Unique +tySynEqnIdKey = mkPreludeMiscIdUnique 460 + +-- quasiquoting +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 470 +quotePatKey = mkPreludeMiscIdUnique 471 +quoteDecKey = mkPreludeMiscIdUnique 472 +quoteTypeKey = mkPreludeMiscIdUnique 473 + +-- data RuleBndr = ... +ruleVarIdKey, typedRuleVarIdKey :: Unique +ruleVarIdKey = mkPreludeMiscIdUnique 480 +typedRuleVarIdKey = mkPreludeMiscIdUnique 481 + +-- data AnnTarget = ... +valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique +valueAnnotationIdKey = mkPreludeMiscIdUnique 490 +typeAnnotationIdKey = mkPreludeMiscIdUnique 491 +moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 + +-- type DerivPred = ... +derivClauseIdKey :: Unique +derivClauseIdKey = mkPreludeMiscIdUnique 493 + +-- data DerivStrategy = ... +stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey, + viaStrategyIdKey :: Unique +stockStrategyIdKey = mkPreludeDataConUnique 494 +anyclassStrategyIdKey = mkPreludeDataConUnique 495 +newtypeStrategyIdKey = mkPreludeDataConUnique 496 +viaStrategyIdKey = mkPreludeDataConUnique 497 + +-- data Specificity = ... +specifiedSpecKey, inferredSpecKey :: Unique +specifiedSpecKey = mkPreludeMiscIdUnique 498 +inferredSpecKey = mkPreludeMiscIdUnique 499 + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName +lift_RDR = nameRdrName liftName +liftTyped_RDR = nameRdrName liftTypedName +unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName +mkNameG_dRDR = nameRdrName mkNameG_dName +mkNameG_vRDR = nameRdrName mkNameG_vName + +-- data Exp = ... +conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName +conE_RDR = nameRdrName conEName +litE_RDR = nameRdrName litEName +appE_RDR = nameRdrName appEName +infixApp_RDR = nameRdrName infixAppName + +-- data Lit = ... +stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR, + doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName +stringL_RDR = nameRdrName stringLName +intPrimL_RDR = nameRdrName intPrimLName +wordPrimL_RDR = nameRdrName wordPrimLName +floatPrimL_RDR = nameRdrName floatPrimLName +doublePrimL_RDR = nameRdrName doublePrimLName +stringPrimL_RDR = nameRdrName stringPrimLName +charPrimL_RDR = nameRdrName charPrimLName diff --git a/GHC/Builtin/PrimOps.hs b/GHC/Builtin/PrimOps.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/PrimOps.hs @@ -0,0 +1,771 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PrimOp]{Primitive operations (machine-level)} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Builtin.PrimOps ( + PrimOp(..), PrimOpVecCat(..), allThePrimOps, + primOpType, primOpSig, primOpResultType, + primOpTag, maxPrimOpTag, primOpOcc, + primOpWrapperId, + + tagToEnumKey, + + primOpOutOfLine, primOpCodeSize, + primOpOkForSpeculation, primOpOkForSideEffects, + primOpIsCheap, primOpFixity, primOpDocs, + + getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), + + PrimCall(..) + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types + +import GHC.Cmm.Type +import GHC.Types.Demand +import GHC.Types.Id ( Id, mkVanillaGlobalWithInfo ) +import GHC.Types.Id.Info ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) +import GHC.Types.Name +import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) +import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) +import GHC.Core.Type +import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 ) +import GHC.Types.Basic ( Arity, Fixity(..), FixityDirection(..), Boxity(..), + SourceText(..) ) +import GHC.Types.SrcLoc ( wiredInSrcSpan ) +import GHC.Types.ForeignCall ( CLabelString ) +import GHC.Types.Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) +import GHC.Unit ( Unit ) +import GHC.Utils.Outputable +import GHC.Data.FastString + +{- +************************************************************************ +* * +\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} +* * +************************************************************************ + +These are in \tr{state-interface.verb} order. +-} + +-- supplies: +-- data PrimOp = ... +#include "primop-data-decl.hs-incl" + +-- supplies +-- primOpTag :: PrimOp -> Int +#include "primop-tag.hs-incl" +primOpTag _ = error "primOpTag: unknown primop" + + +instance Eq PrimOp where + op1 == op2 = primOpTag op1 == primOpTag op2 + +instance Ord PrimOp where + op1 < op2 = primOpTag op1 < primOpTag op2 + op1 <= op2 = primOpTag op1 <= primOpTag op2 + op1 >= op2 = primOpTag op1 >= primOpTag op2 + op1 > op2 = primOpTag op1 > primOpTag op2 + op1 `compare` op2 | op1 < op2 = LT + | op1 == op2 = EQ + | otherwise = GT + +instance Outputable PrimOp where + ppr op = pprPrimOp op + +data PrimOpVecCat = IntVec + | WordVec + | FloatVec + +-- An @Enum@-derived list would be better; meanwhile... (ToDo) + +allThePrimOps :: [PrimOp] +allThePrimOps = +#include "primop-list.hs-incl" + +tagToEnumKey :: Unique +tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) + +{- +************************************************************************ +* * +\subsection[PrimOp-info]{The essential info about each @PrimOp@} +* * +************************************************************************ + +The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may +refer to the primitive operation. The conventional \tr{#}-for- +unboxed ops is added on later. + +The reason for the funny characters in the names is so we do not +interfere with the programmer's Haskell name spaces. + +We use @PrimKinds@ for the ``type'' information, because they're +(slightly) more convenient to use than @TyCons@. +-} + +data PrimOpInfo + = Dyadic OccName -- string :: T -> T -> T + Type + | Monadic OccName -- string :: T -> T + Type + | Compare OccName -- string :: T -> T -> Int# + Type + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T + [TyVar] + [Type] + Type + +mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo +mkDyadic str ty = Dyadic (mkVarOccFS str) ty +mkMonadic str ty = Monadic (mkVarOccFS str) ty +mkCompare str ty = Compare (mkVarOccFS str) ty + +mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo +mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty + +{- +************************************************************************ +* * +\subsubsection{Strictness} +* * +************************************************************************ + +Not all primops are strict! +-} + +primOpStrictness :: PrimOp -> Arity -> StrictSig + -- See Demand.StrictnessInfo for discussion of what the results + -- The arity should be the arity of the primop; that's why + -- this function isn't exported. +#include "primop-strictness.hs-incl" + +{- +************************************************************************ +* * +\subsubsection{Fixity} +* * +************************************************************************ +-} + +primOpFixity :: PrimOp -> Maybe Fixity +#include "primop-fixity.hs-incl" + +{- +************************************************************************ +* * +\subsubsection{Docs} +* * +************************************************************************ + +See Note [GHC.Prim Docs] +-} + +primOpDocs :: [(String, String)] +#include "primop-docs.hs-incl" + +{- +************************************************************************ +* * +\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} +* * +************************************************************************ + +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. +-} + +primOpInfo :: PrimOp -> PrimOpInfo +#include "primop-primop-info.hs-incl" +primOpInfo _ = error "primOpInfo: unknown primop" + +{- +Here are a load of comments from the old primOp info: + +A @Word#@ is an unsigned @Int#@. + +@decodeFloat#@ is given w/ Integer-stuff (it's similar). + +@decodeDouble#@ is given w/ Integer-stuff (it's similar). + +Decoding of floating-point numbers is sorta Integer-related. Encoding +is done with plain ccalls now (see PrelNumExtra.hs). + +A @Weak@ Pointer is created by the @mkWeak#@ primitive: + + mkWeak# :: k -> v -> f -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +In practice, you'll use the higher-level + + data Weak v = Weak# v + mkWeak :: k -> v -> IO () -> IO (Weak v) + +The following operation dereferences a weak pointer. The weak pointer +may have been finalized, so the operation returns a result code which +must be inspected before looking at the dereferenced value. + + deRefWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, v, Int# #) + +Only look at v if the Int# returned is /= 0 !! + +The higher-level op is + + deRefWeak :: Weak v -> IO (Maybe v) + +Weak pointers can be finalized early by using the finalize# operation: + + finalizeWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, Int#, IO () #) + +The Int# returned is either + + 0 if the weak pointer has already been finalized, or it has no + finalizer (the third component is then invalid). + + 1 if the weak pointer is still alive, with the finalizer returned + as the third component. + +A {\em stable name/pointer} is an index into a table of stable name +entries. Since the garbage collector is told about stable pointers, +it is safe to pass a stable pointer to external systems such as C +routines. + +\begin{verbatim} +makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) +freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld +deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) +eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# +\end{verbatim} + +It may seem a bit surprising that @makeStablePtr#@ is a @IO@ +operation since it doesn't (directly) involve IO operations. The +reason is that if some optimisation pass decided to duplicate calls to +@makeStablePtr#@ and we only pass one of the stable pointers over, a +massive space leak can result. Putting it into the IO monad +prevents this. (Another reason for putting them in a monad is to +ensure correct sequencing wrt the side-effecting @freeStablePtr@ +operation.) + +An important property of stable pointers is that if you call +makeStablePtr# twice on the same object you get the same stable +pointer back. + +Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, +besides, it's not likely to be used from Haskell) so it's not a +primop. + +Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] + +Stable Names +~~~~~~~~~~~~ + +A stable name is like a stable pointer, but with three important differences: + + (a) You can't deRef one to get back to the original object. + (b) You can convert one to an Int. + (c) You don't need to 'freeStableName' + +The existence of a stable name doesn't guarantee to keep the object it +points to alive (unlike a stable pointer), hence (a). + +Invariants: + + (a) makeStableName always returns the same value for a given + object (same as stable pointers). + + (b) if two stable names are equal, it implies that the objects + from which they were created were the same. + + (c) stableNameToInt always returns the same Int for a given + stable name. + + +These primops are pretty weird. + + tagToEnum# :: Int -> a (result type must be an enumerated type) + +The constraints aren't currently checked by the front end, but the +code generator will fall over if they aren't satisfied. + +************************************************************************ +* * + Which PrimOps are out-of-line +* * +************************************************************************ + +Some PrimOps need to be called out-of-line because they either need to +perform a heap check or they block. +-} + +primOpOutOfLine :: PrimOp -> Bool +#include "primop-out-of-line.hs-incl" + +{- +************************************************************************ +* * + Failure and side effects +* * +************************************************************************ + +Note [Checking versus non-checking primops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + In GHC primops break down into two classes: + + a. Checking primops behave, for instance, like division. In this + case the primop may throw an exception (e.g. division-by-zero) + and is consequently is marked with the can_fail flag described below. + The ability to fail comes at the expense of precluding some optimizations. + + b. Non-checking primops behavior, for instance, like addition. While + addition can overflow it does not produce an exception. So can_fail is + set to False, and we get more optimisation opportunities. But we must + never throw an exception, so we cannot rewrite to a call to error. + + It is important that a non-checking primop never be transformed in a way that + would cause it to bottom. Doing so would violate Core's let/app invariant + (see Note [Core let/app invariant] in GHC.Core) which is critical to + the simplifier's ability to float without fear of changing program meaning. + + +Note [PrimOp can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both can_fail and has_side_effects mean that the primop has +some effect that is not captured entirely by its result value. + +---------- has_side_effects --------------------- +A primop "has_side_effects" if it has some *write* effect, visible +elsewhere + - writing to the world (I/O) + - writing to a mutable data structure (writeIORef) + - throwing a synchronous Haskell exception + +Often such primops have a type like + State -> input -> (State, output) +so the state token guarantees ordering. In general we rely *only* on +data dependencies of the state token to enforce write-effect ordering + + * NB1: if you inline unsafePerformIO, you may end up with + side-effecting ops whose 'state' output is discarded. + And programmers may do that by hand; see #9390. + That is why we (conservatively) do not discard write-effecting + primops even if both their state and result is discarded. + + * NB2: We consider primops, such as raiseIO#, that can raise a + (Haskell) synchronous exception to "have_side_effects" but not + "can_fail". We must be careful about not discarding such things; + see the paper "A semantics for imprecise exceptions". + + * NB3: *Read* effects (like reading an IORef) don't count here, + because it doesn't matter if we don't do them, or do them more than + once. *Sequencing* is maintained by the data dependency of the state + token. + +---------- can_fail ---------------------------- +A primop "can_fail" if it can fail with an *unchecked* exception on +some elements of its input domain. Main examples: + division (fails on zero denominator) + array indexing (fails if the index is out of bounds) + +An "unchecked exception" is one that is an outright error, (not +turned into a Haskell exception,) such as seg-fault or +divide-by-zero error. Such can_fail primops are ALWAYS surrounded +with a test that checks for the bad cases, but we need to be +very careful about code motion that might move it out of +the scope of the test. + +Note [Transformations affected by can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The can_fail and has_side_effects properties have the following effect +on program transformations. Summary table is followed by details. + + can_fail has_side_effects +Discard YES NO +Float in YES YES +Float out NO NO +Duplicate YES NO + +* Discarding. case (a `op` b) of _ -> rhs ===> rhs + You should not discard a has_side_effects primop; e.g. + case (writeIntArray# a i v s of (# _, _ #) -> True + Arguably you should be able to discard this, since the + returned stat token is not used, but that relies on NEVER + inlining unsafePerformIO, and programmers sometimes write + this kind of stuff by hand (#9390). So we (conservatively) + never discard a has_side_effects primop. + + However, it's fine to discard a can_fail primop. For example + case (indexIntArray# a i) of _ -> True + We can discard indexIntArray#; it has can_fail, but not + has_side_effects; see #5658 which was all about this. + Notice that indexIntArray# is (in a more general handling of + effects) read effect, but we don't care about that here, and + treat read effects as *not* has_side_effects. + + Similarly (a `/#` b) can be discarded. It can seg-fault or + cause a hardware exception, but not a synchronous Haskell + exception. + + + + Synchronous Haskell exceptions, e.g. from raiseIO#, are treated + as has_side_effects and hence are not discarded. + +* Float in. You can float a can_fail or has_side_effects primop + *inwards*, but not inside a lambda (see Duplication below). + +* Float out. You must not float a can_fail primop *outwards* lest + you escape the dynamic scope of the test. Example: + case d ># 0# of + True -> case x /# d of r -> r +# 1 + False -> 0 + Here we must not float the case outwards to give + case x/# d of r -> + case d ># 0# of + True -> r +# 1 + False -> 0 + + Nor can you float out a has_side_effects primop. For example: + if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 + else s0 + Notice that s0 is mentioned in both branches of the 'if', but + only one of these two will actually be consumed. But if we + float out to + case writeMutVar# v True s0 of (# s1 #) -> + if blah then s1 else s0 + the writeMutVar will be performed in both branches, which is + utterly wrong. + +* Duplication. You cannot duplicate a has_side_effect primop. You + might wonder how this can occur given the state token threading, but + just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get + something like this + p = case readMutVar# s v of + (# s', r #) -> (State# s', r) + s' = case p of (s', r) -> s' + r = case p of (s', r) -> r + + (All these bindings are boxed.) If we inline p at its two call + sites, we get a catastrophe: because the read is performed once when + s' is demanded, and once when 'r' is demanded, which may be much + later. Utterly wrong. #3207 is real example of this happening. + + However, it's fine to duplicate a can_fail primop. That is really + the only difference between can_fail and has_side_effects. + +Note [Implementation: how can_fail/has_side_effects affect transformations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that floating/duplication/discarding are done right +in the simplifier? + +Two main predicates on primpops test these flags: + primOpOkForSideEffects <=> not has_side_effects + primOpOkForSpeculation <=> not (has_side_effects || can_fail) + + * The "no-float-out" thing is achieved by ensuring that we never + let-bind a can_fail or has_side_effects primop. The RHS of a + let-binding (which can float in and out freely) satisfies + exprOkForSpeculation; this is the let/app invariant. And + exprOkForSpeculation is false of can_fail and has_side_effects. + + * So can_fail and has_side_effects primops will appear only as the + scrutinees of cases, and that's why the FloatIn pass is capable + of floating case bindings inwards. + + * The no-duplicate thing is done via primOpIsCheap, by making + has_side_effects things (very very very) not-cheap! +-} + +primOpHasSideEffects :: PrimOp -> Bool +#include "primop-has-side-effects.hs-incl" + +primOpCanFail :: PrimOp -> Bool +#include "primop-can-fail.hs-incl" + +primOpOkForSpeculation :: PrimOp -> Bool + -- See Note [PrimOp can_fail and has_side_effects] + -- See comments with GHC.Core.Utils.exprOkForSpeculation + -- primOpOkForSpeculation => primOpOkForSideEffects +primOpOkForSpeculation op + = primOpOkForSideEffects op + && not (primOpOutOfLine op || primOpCanFail op) + -- I think the "out of line" test is because out of line things can + -- be expensive (eg sine, cosine), and so we may not want to speculate them + +primOpOkForSideEffects :: PrimOp -> Bool +primOpOkForSideEffects op + = not (primOpHasSideEffects op) + +{- +Note [primOpIsCheap] +~~~~~~~~~~~~~~~~~~~~ + +@primOpIsCheap@, as used in GHC.Core.Opt.Simplify.Utils. For now (HACK +WARNING), we just borrow some other predicates for a +what-should-be-good-enough test. "Cheap" means willing to call it more +than once, and/or push it inside a lambda. The latter could change the +behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. +-} + +primOpIsCheap :: PrimOp -> Bool +-- See Note [PrimOp can_fail and has_side_effects] +primOpIsCheap op = primOpOkForSpeculation op +-- In March 2001, we changed this to +-- primOpIsCheap op = False +-- thereby making *no* primops seem cheap. But this killed eta +-- expansion on case (x ==# y) of True -> \s -> ... +-- which is bad. In particular a loop like +-- doLoop n = loop 0 +-- where +-- loop i | i == n = return () +-- | otherwise = bar i >> loop (i+1) +-- allocated a closure every time round because it doesn't eta expand. +-- +-- The problem that originally gave rise to the change was +-- let x = a +# b *# c in x +# x +-- were we don't want to inline x. But primopIsCheap doesn't control +-- that (it's exprIsDupable that does) so the problem doesn't occur +-- even if primOpIsCheap sometimes says 'True'. + +{- +************************************************************************ +* * + PrimOp code size +* * +************************************************************************ + +primOpCodeSize +~~~~~~~~~~~~~~ +Gives an indication of the code size of a primop, for the purposes of +calculating unfolding sizes; see GHC.Core.Unfold.sizeExpr. +-} + +primOpCodeSize :: PrimOp -> Int +#include "primop-code-size.hs-incl" + +primOpCodeSizeDefault :: Int +primOpCodeSizeDefault = 1 + -- GHC.Core.Unfold.primOpSize already takes into account primOpOutOfLine + -- and adds some further costs for the args in that case. + +primOpCodeSizeForeignCall :: Int +primOpCodeSizeForeignCall = 4 + +{- +************************************************************************ +* * + PrimOp types +* * +************************************************************************ +-} + +primOpType :: PrimOp -> Type -- you may want to use primOpSig instead +primOpType op + = case primOpInfo op of + Dyadic _occ ty -> dyadic_fun_ty ty + Monadic _occ ty -> monadic_fun_ty ty + Compare _occ ty -> compare_fun_ty ty + + GenPrimOp _occ tyvars arg_tys res_ty -> + mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty) + +primOpResultType :: PrimOp -> Type +primOpResultType op + = case primOpInfo op of + Dyadic _occ ty -> ty + Monadic _occ ty -> ty + Compare _occ _ty -> intPrimTy + GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty + +primOpOcc :: PrimOp -> OccName +primOpOcc op = case primOpInfo op of + Dyadic occ _ -> occ + Monadic occ _ -> occ + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ + +{- Note [Primop wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +To support (limited) use of primops in GHCi genprimopcode generates the +GHC.PrimopWrappers module. This module contains a "primop wrapper" +binding for each primop. These are standard Haskell functions mirroring the +types of the primops they wrap. For instance, in the case of plusInt# we would +have: + + module GHC.PrimopWrappers where + import GHC.Prim as P + + plusInt# :: Int# -> Int# -> Int# + plusInt# a b = P.plusInt# a b + +The Id for the wrapper of a primop can be found using +'GHC.Builtin.PrimOp.primOpWrapperId'. However, GHCi does not use this mechanism +to link primops; it rather does a rather hacky symbol lookup (see +GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed? + +Note that these wrappers aren't *quite* +as expressive as their unwrapped breathern in that they may exhibit less levity +polymorphism. For instance, consider the case of mkWeakNoFinalizer# which has +type: + + mkWeakNoFinalizer# :: forall (r :: RuntimeRep) (k :: TYPE r) (v :: Type). + k -> v + -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +Naively we could generate a wrapper of the form, + + + mkWeakNoFinalizer# k v s = GHC.Prim.mkWeakNoFinalizer# k v s + +However, this would require that 'k' bind the levity-polymorphic key, +which is disallowed by our levity polymorphism validity checks (see Note +[Levity polymorphism invariants] in GHC.Core). Consequently, we give the +wrapper the simpler, less polymorphic type + + mkWeakNoFinalizer# :: forall (k :: Type) (v :: Type). + k -> v + -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +This simplification tends to be good enough for GHCi uses given that there are +few levity polymorphic primops and we do little simplification on interpreted +code anyways. + +TODO: This behavior is actually wrong; a program becomes ill-typed upon +replacing a real primop occurrence with one of its wrapper due to the fact that +the former has an additional type binder. Hmmm.... + +Note [Eta expanding primops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +STG requires that primop applications be saturated. This makes code generation +significantly simpler since otherwise we would need to define a calling +convention for curried applications that can accomodate levity polymorphism. + +To ensure saturation, CorePrep eta expands expand all primop applications as +described in Note [Eta expansion of hasNoBinding things in CorePrep] in +GHC.Core.Prep. + +Historical Note: + +For a short period around GHC 8.8 we rewrote unsaturated primop applications to +rather use the primop's wrapper (see Note [Primop wrappers] in +GHC.Builtin.PrimOps) instead of eta expansion. This was because at the time +CoreTidy would try to predict the CAFfyness of bindings that would be produced +by CorePrep for inclusion in interface files. Eta expanding during CorePrep +proved to be very difficult to predict, leading to nasty inconsistencies in +CAFfyness determinations (see #16846). + +Thankfully, we now no longer try to predict CAFfyness but rather compute it on +GHC STG (see Note [SRTs] in GHC.Cmm.Info.Build) and inject it into the interface +file after code generation (see TODO: Refer to whatever falls out of #18096). +This is much simpler and avoids the potential for inconsistency, allowing us to +return to the somewhat simpler eta expansion approach for unsaturated primops. + +See #18079. +-} + +-- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'. +-- See Note [Primop wrappers]. +primOpWrapperId :: PrimOp -> Id +primOpWrapperId op = mkVanillaGlobalWithInfo name ty info + where + info = setCafInfo vanillaIdInfo NoCafRefs + name = mkExternalName uniq gHC_PRIMOPWRAPPERS (primOpOcc op) wiredInSrcSpan + uniq = mkPrimOpWrapperUnique (primOpTag op) + ty = primOpType op + +isComparisonPrimOp :: PrimOp -> Bool +isComparisonPrimOp op = case primOpInfo op of + Compare {} -> True + _ -> False + +-- primOpSig is like primOpType but gives the result split apart: +-- (type variables, argument types, result type) +-- It also gives arity, strictness info + +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) +primOpSig op + = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) + where + arity = length arg_tys + (tyvars, arg_tys, res_ty) + = case (primOpInfo op) of + Monadic _occ ty -> ([], [ty], ty ) + Dyadic _occ ty -> ([], [ty,ty], ty ) + Compare _occ ty -> ([], [ty,ty], intPrimTy) + GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) + +data PrimOpResultInfo + = ReturnsPrim PrimRep + | ReturnsAlg TyCon + +-- Some PrimOps need not return a manifest primitive or algebraic value +-- (i.e. they might return a polymorphic value). These PrimOps *must* +-- be out of line, or the code generator won't work. + +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo +getPrimOpResultInfo op + = case (primOpInfo op) of + Dyadic _ ty -> ReturnsPrim (typePrimRep1 ty) + Monadic _ ty -> ReturnsPrim (typePrimRep1 ty) + Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) + GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) + | otherwise -> ReturnsAlg tc + where + tc = tyConAppTyCon ty + -- All primops return a tycon-app result + -- The tycon can be an unboxed tuple or sum, though, + -- which gives rise to a ReturnAlg + +{- +We do not currently make use of whether primops are commutable. + +We used to try to move constants to the right hand side for strength +reduction. +-} + +{- +commutableOp :: PrimOp -> Bool +#include "primop-commutable.hs-incl" +-} + +-- Utils: + +dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type +dyadic_fun_ty ty = mkVisFunTysMany [ty, ty] ty +monadic_fun_ty ty = mkVisFunTyMany ty ty +compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy + +-- Output stuff: + +pprPrimOp :: PrimOp -> SDoc +pprPrimOp other_op = pprOccName (primOpOcc other_op) + +{- +************************************************************************ +* * +\subsubsection[PrimCall]{User-imported primitive calls} +* * +************************************************************************ +-} + +data PrimCall = PrimCall CLabelString Unit + +instance Outputable PrimCall where + ppr (PrimCall lbl pkgId) + = text "__primcall" <+> ppr pkgId <+> ppr lbl diff --git a/GHC/Builtin/PrimOps.hs-boot b/GHC/Builtin/PrimOps.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Builtin/PrimOps.hs-boot @@ -0,0 +1,5 @@ +module GHC.Builtin.PrimOps where + +import GHC.Prelude () + +data PrimOp diff --git a/GHC/Builtin/RebindableNames.hs b/GHC/Builtin/RebindableNames.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/RebindableNames.hs @@ -0,0 +1,6 @@ +module GHC.Builtin.RebindableNames where + +import GHC.Data.FastString + +reboundIfSymbol :: FastString +reboundIfSymbol = fsLit "ifThenElse" diff --git a/GHC/Builtin/Types.hs b/GHC/Builtin/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types.hs @@ -0,0 +1,1935 @@ +{- +(c) The GRASP Project, Glasgow University, 1994-1998 + +Wired-in knowledge about {\em non-primitive} types +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | This module is about types that can be defined in Haskell, but which +-- must be wired into the compiler nonetheless. C.f module "GHC.Builtin.Types.Prim" +module GHC.Builtin.Types ( + -- * Helper functions defined here + mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the + -- built-in functions for evaluation. + + mkWiredInIdName, -- used in GHC.Types.Id.Make + + -- * All wired in things + wiredInTyCons, isBuiltInOcc_maybe, + + -- * Bool + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + promotedFalseDataCon, promotedTrueDataCon, + + -- * Ordering + orderingTyCon, + ordLTDataCon, ordLTDataConId, + ordEQDataCon, ordEQDataConId, + ordGTDataCon, ordGTDataConId, + promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, + + -- * Boxing primitive types + boxingDataCon_maybe, + + -- * Char + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, stringTyCon_RDR, + + -- * Double + doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, + + -- * Float + floatTyCon, floatDataCon, floatTy, floatTyConName, + + -- * Int + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + + -- * Word + wordTyCon, wordDataCon, wordTyConName, wordTy, + + -- * Word8 + word8TyCon, word8DataCon, word8TyConName, word8Ty, + + -- * List + listTyCon, listTyCon_RDR, listTyConName, listTyConKey, + nilDataCon, nilDataConName, nilDataConKey, + consDataCon_RDR, consDataCon, consDataConName, + promotedNilDataCon, promotedConsDataCon, + mkListTy, mkPromotedListTy, + + -- * Maybe + maybeTyCon, maybeTyConName, + nothingDataCon, nothingDataConName, promotedNothingDataCon, + justDataCon, justDataConName, promotedJustDataCon, + + -- * Tuples + mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr, + tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName, + promotedTupleDataCon, + unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, + pairTyCon, + unboxedUnitTyCon, unboxedUnitDataCon, + unboxedTupleKind, unboxedSumKind, + + -- ** Constraint tuples + cTupleTyConName, cTupleTyConNames, isCTupleTyConName, + cTupleTyConNameArity_maybe, + cTupleDataConName, cTupleDataConNames, + + -- * Any + anyTyCon, anyTy, anyTypeOfKind, + + -- * Recovery TyCon + makeRecoveryTyCon, + + -- * Sums + mkSumTy, sumTyCon, sumDataCon, + + -- * Kinds + typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, + isLiftedTypeKindTyConName, liftedTypeKind, + typeToTypeKind, constraintKind, + liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName, + liftedTypeKindTyConName, + + -- * Equality predicates + heqTyCon, heqTyConName, heqClass, heqDataCon, + eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR, + coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, + + -- * RuntimeRep and friends + runtimeRepTyCon, vecCountTyCon, vecElemTyCon, + + runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, + + vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, + + liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy, + + vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy, + + int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + + doubleElemRepDataConTy, + + -- * Multiplicity and friends + multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy, + multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy, + oneDataConTyCon, manyDataConTyCon, + multMulTyCon, + + unrestrictedFunTyCon, unrestrictedFunTyConName, + + -- * Bignum + integerTy, integerTyCon, integerTyConName, + integerISDataCon, integerISDataConName, + integerIPDataCon, integerIPDataConName, + integerINDataCon, integerINDataConName, + naturalTy, naturalTyCon, naturalTyConName, + naturalNSDataCon, naturalNSDataConName, + naturalNBDataCon, naturalNBDataConName + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId ) + +-- friends: +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import {-# SOURCE #-} GHC.Builtin.Uniques + +-- others: +import GHC.Core.Coercion.Axiom +import GHC.Types.Id +import GHC.Types.Var (VarBndr (Bndr)) +import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) +import GHC.Unit.Module ( Module ) +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Core.DataCon +import {-# SOURCE #-} GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Class ( Class, mkClass ) +import GHC.Types.Name.Reader +import GHC.Types.Name as Name +import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) +import GHC.Types.Name.Set ( NameSet, mkNameSet, elemNameSet ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Types.Unique +import Data.Array +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Data.BooleanFormula ( mkAnd ) + +import qualified Data.ByteString.Char8 as BS + +import Data.List ( elemIndex ) + +alpha_tyvar :: [TyVar] +alpha_tyvar = [alphaTyVar] + +alpha_ty :: [Type] +alpha_ty = [alphaTy] + +{- +Note [Wiring in RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, +making it a pain to wire in. To ease the pain somewhat, we use lists of +the different bits, like Uniques, Names, DataCons. These lists must be +kept in sync with each other. The rule is this: use the order as declared +in GHC.Types. All places where such lists exist should contain a reference +to this Note, so a search for this Note's name should find all the lists. + +See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. + +************************************************************************ +* * +\subsection{Wired in type constructors} +* * +************************************************************************ + +If you change which things are wired in, make sure you change their +names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc +-} + +-- This list is used only to define GHC.Builtin.Utils.wiredInThings. That in turn +-- is used to initialise the name environment carried around by the renamer. +-- This means that if we look up the name of a TyCon (or its implicit binders) +-- that occurs in this list that name will be assigned the wired-in key we +-- define here. +-- +-- Because of their infinite nature, this list excludes +-- * tuples, including boxed, unboxed and constraint tuples +--- (mkTupleTyCon, unitTyCon, pairTyCon) +-- * unboxed sums (sumTyCon) +-- See Note [Infinite families of known-key names] in GHC.Builtin.Names +-- +-- See also Note [Known-key names] +wiredInTyCons :: [TyCon] + +wiredInTyCons = [ -- Units are not treated like other tuples, because they + -- are defined in GHC.Base, and there's only a few of them. We + -- put them in wiredInTyCons so that they will pre-populate + -- the name cache, so the parser in isBuiltInOcc_maybe doesn't + -- need to look out for them. + unitTyCon + , unboxedUnitTyCon + , anyTyCon + , boolTyCon + , charTyCon + , stringTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , wordTyCon + , word8TyCon + , listTyCon + , orderingTyCon + , maybeTyCon + , heqTyCon + , eqTyCon + , coercibleTyCon + , typeNatKindCon + , typeSymbolKindCon + , runtimeRepTyCon + , vecCountTyCon + , vecElemTyCon + , constraintKindTyCon + , liftedTypeKindTyCon + , multiplicityTyCon + , naturalTyCon + , integerTyCon + ] + +mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName built_in modu fs unique tycon + = mkWiredInName modu (mkTcOccFS fs) unique + (ATyCon tycon) -- Relevant TyCon + built_in + +mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name +mkWiredInDataConName built_in modu fs unique datacon + = mkWiredInName modu (mkDataOccFS fs) unique + (AConLike (RealDataCon datacon)) -- Relevant DataCon + built_in + +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +eqTyConName, eqDataConName, eqSCSelIdName :: Name +eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon +eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon +eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId + +{- Note [eqTyCon (~) is built-in syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The (~) type operator used in equality constraints (a~b) is considered built-in +syntax. This has a few consequences: + +* The user is not allowed to define their own type constructors with this name: + + ghci> class a ~ b + :1:1: error: Illegal binding of built-in syntax: ~ + +* Writing (a ~ b) does not require enabling -XTypeOperators. It does, however, + require -XGADTs or -XTypeFamilies. + +* The (~) type operator is always in scope. It doesn't need to be imported, + and it cannot be hidden. + +* We have a bunch of special cases in the compiler to arrange all of the above. + +There's no particular reason for (~) to be special, but fixing this would be a +breaking change. +-} +eqTyCon_RDR :: RdrName +eqTyCon_RDR = nameRdrName eqTyConName + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +heqTyConName, heqDataConName, heqSCSelIdName :: Name +heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon +heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon +heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId + +-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs +coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name +coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon +coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon +coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId + +charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name +charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon +stringTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "String") stringTyConKey stringTyCon +intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon + +boolTyConName, falseDataConName, trueDataConName :: Name +boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon + +listTyConName, nilDataConName, consDataConName :: Name +listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon +consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + +maybeTyConName, nothingDataConName, justDataConName :: Name +maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe") + maybeTyConKey maybeTyCon +nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing") + nothingDataConKey nothingDataCon +justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just") + justDataConKey justDataCon + +wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name +wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon +wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon +word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon +word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon + +floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name +floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon +doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon + +-- Any + +{- +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructor Any, + + type family Any :: k where { } + +It has these properties: + + * Note that 'Any' is kind polymorphic since in some program we may + need to use Any to fill in a type variable of some kind other than * + (see #959 for examples). Its kind is thus `forall k. k``. + + * It is defined in module GHC.Types, and exported so that it is + available to users. For this reason it's treated like any other + wired-in type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + + * It is a *closed* type family, with no instances. This means that + if ty :: '(k1, k2) we add a given coercion + g :: ty ~ (Fst ty, Snd ty) + If Any was a *data* type, then we'd get inconsistency because 'ty' + could be (Any '(k1,k2)) and then we'd have an equality with Any on + one side and '(,) on the other. See also #9097 and #9636. + + * When instantiated at a lifted type it is inhabited by at least one value, + namely bottom + + * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is wired-in so we can easily refer to it where we don't have a name + environment (e.g. see Rules.matchRule for one example) + + * If (Any k) is the type of a value, it must be a /lifted/ value. So + if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See + Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. This is a convenient + invariant, and makes isUnliftedTyCon well-defined; otherwise what + would (isUnliftedTyCon Any) be? + +It's used to instantiate un-constrained type variables after type checking. For +example, 'length' has type + + length :: forall a. [a] -> Int + +and the list datacon for the empty list has type + + [] :: forall a. [a] + +In order to compose these two terms as @length []@ a type +application is required, but there is no constraint on the +choice. In this situation GHC uses 'Any', + +> length (Any *) ([] (Any *)) + +Above, we print kinds explicitly, as if with --fprint-explicit-kinds. + +The Any tycon used to be quite magic, but we have since been able to +implement it merely with an empty kind polymorphic type family. See #10886 for a +bit of history. +-} + + +anyTyConName :: Name +anyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] + res_kind = mkTyVarTy (binderVar kv) + +anyTy :: Type +anyTy = mkTyConTy anyTyCon + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind = mkTyConApp anyTyCon [kind] + +-- | Make a fake, recovery 'TyCon' from an existing one. +-- Used when recovering from errors in type declarations +makeRecoveryTyCon :: TyCon -> TyCon +makeRecoveryTyCon tc + = mkTcTyCon (tyConName tc) + bndrs res_kind + noTcTyConScopedTyVars + True -- Fully generalised + flavour -- Keep old flavour + where + flavour = tyConFlavour tc + [kv] = mkTemplateKindVars [liftedTypeKind] + (bndrs, res_kind) + = case flavour of + PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv) + _ -> (tyConBinders tc, tyConResKind tc) + -- For data types we have already validated their kind, so it + -- makes sense to keep it. For promoted data constructors we haven't, + -- so we recover with kind (forall k. k). Otherwise consider + -- data T a where { MkT :: Show a => T a } + -- If T is for some reason invalid, we don't want to fall over + -- at (promoted) use-sites of MkT. + +-- Kinds +typeNatKindConName, typeSymbolKindConName :: Name +typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon +typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon + +constraintKindTyConName :: Name +constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon + +liftedTypeKindTyConName :: Name +liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon + +multiplicityTyConName :: Name +multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") + multiplicityTyConKey multiplicityTyCon + +oneDataConName, manyDataConName :: Name +oneDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon +manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon + -- It feels wrong to have One and Many be BuiltInSyntax. But otherwise, + -- `Many`, in particular, is considered out of scope unless an appropriate + -- file is open. The problem with this is that `Many` appears implicitly in + -- types every time there is an `(->)`, hence out-of-scope errors get + -- reported. Making them built-in make it so that they are always considered in + -- scope. + +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name +runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon +vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon +tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon +sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon + +-- See Note [Wiring in RuntimeRep] +runtimeRepSimpleDataConNames :: [Name] +runtimeRepSimpleDataConNames + = zipWith3Lazy mk_special_dc_name + [ fsLit "LiftedRep", fsLit "UnliftedRep" + , fsLit "IntRep" + , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep" + , fsLit "WordRep" + , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep" + , fsLit "AddrRep" + , fsLit "FloatRep", fsLit "DoubleRep" + ] + runtimeRepSimpleDataConKeys + runtimeRepSimpleDataCons + +vecCountTyConName :: Name +vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon + +-- See Note [Wiring in RuntimeRep] +vecCountDataConNames :: [Name] +vecCountDataConNames = zipWith3Lazy mk_special_dc_name + [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" + , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] + vecCountDataConKeys + vecCountDataCons + +vecElemTyConName :: Name +vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon + +-- See Note [Wiring in RuntimeRep] +vecElemDataConNames :: [Name] +vecElemDataConNames = zipWith3Lazy mk_special_dc_name + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" + , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" + , fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + vecElemDataConKeys + vecElemDataCons + +mk_special_dc_name :: FastString -> Unique -> DataCon -> Name +mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc + +boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR, + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +stringTyCon_RDR = nameRdrName stringTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName + +{- +************************************************************************ +* * +\subsection{mkWiredInTyCon} +* * +************************************************************************ +-} + +-- This function assumes that the types it creates have all parameters at +-- Representational role, and that there is no kind polymorphism. +pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon name cType tyvars cons + = mkAlgTyCon name + (mkAnonTyConBinders VisArg tyvars) + liftedTypeKind + (map (const Representational) tyvars) + cType + [] -- No stupid theta + (mkDataTyConRhs cons) + (VanillaAlgTyCon (mkPrelTyConRepName name)) + False -- Not in GADT syntax + +pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon n univs tys = pcDataConW n univs (map linear tys) + +pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon +pcDataConW n univs tys = pcDataConWithFixity False n univs + [] -- no ex_tvs + univs -- the univs are precisely the user-written tyvars + tys + +pcDataConWithFixity :: Bool -- ^ declared infix? + -> Name -- ^ datacon name + -> [TyVar] -- ^ univ tyvars + -> [TyCoVar] -- ^ ex tycovars + -> [TyCoVar] -- ^ user-written tycovars + -> [Scaled Type] -- ^ args + -> TyCon + -> DataCon +pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n)) + NoRRI +-- The Name's unique is the first of two free uniques; +-- the first is used for the datacon itself, +-- the second is used for the "worker name" +-- +-- To support this the mkPreludeDataConUnique function "allocates" +-- one DataCon unique per pair of Ints. + +pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo + -> [TyVar] -> [TyCoVar] -> [TyCoVar] + -> [Scaled Type] -> TyCon -> DataCon +-- The Name should be in the DataName name space; it's the name +-- of the DataCon itself. +-- +-- IMPORTANT NOTE: +-- if you try to wire-in a /GADT/ data constructor you will +-- find it hard (we did). You will need wrapper and worker +-- Names, a DataConBoxer, DataConRep, EqSpec, etc. +-- Try hard not to wire-in GADT data types. You will live +-- to regret doing so (we do). + +pcDataConWithFixity' declared_infix dc_name wrk_key rri + tyvars ex_tyvars user_tyvars arg_tys tycon + = data_con + where + tag_map = mkTyConTagMap tycon + -- This constructs the constructor Name to ConTag map once per + -- constructor, which is quadratic. It's OK here, because it's + -- only called for wired in data types that don't have a lot of + -- constructors. It's also likely that GHC will lift tag_map, since + -- we call pcDataConWithFixity' with static TyCons in the same module. + -- See Note [Constructor tag allocation] and #14657 + data_con = mkDataCon dc_name declared_infix prom_info + (map (const no_bang) arg_tys) + [] -- No labelled fields + tyvars ex_tyvars + (mkTyVarBinders SpecifiedSpec user_tyvars) + [] -- No equality spec + [] -- No theta + arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) + rri + tycon + (lookupNameEnv_NF tag_map dc_name) + [] -- No stupid theta + (mkDataConWorkId wrk_name data_con) + NoDataConRep -- Wired-in types are too simple to need wrappers + + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + wrk_name = mkDataConWorkerName data_con wrk_key + + prom_info = mkPrelTyConRepName dc_name + +mkDataConWorkerName :: DataCon -> Unique -> Name +mkDataConWorkerName data_con wrk_key = + mkWiredInName modu wrk_occ wrk_key + (AnId (dataConWorkId data_con)) UserSyntax + where + modu = ASSERT( isExternalName dc_name ) + nameModule dc_name + dc_name = dataConName data_con + dc_occ = nameOccName dc_name + wrk_occ = mkDataConWorkerOcc dc_occ + +-- used for RuntimeRep and friends +pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon +pcSpecialDataCon dc_name arg_tys tycon rri + = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri + [] [] [] (map linear arg_tys) tycon + +{- +************************************************************************ +* * + Kinds +* * +************************************************************************ +-} + +typeNatKindCon, typeSymbolKindCon :: TyCon +-- data Nat +-- data Symbol +typeNatKindCon = pcTyCon typeNatKindConName Nothing [] [] +typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] + +typeNatKind, typeSymbolKind :: Kind +typeNatKind = mkTyConTy typeNatKindCon +typeSymbolKind = mkTyConTy typeSymbolKindCon + +constraintKindTyCon :: TyCon +-- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon! +constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] + +liftedTypeKind, typeToTypeKind, constraintKind :: Kind +liftedTypeKind = tYPE liftedRepTy +typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind +constraintKind = mkTyConApp constraintKindTyCon [] + +{- +************************************************************************ +* * + Stuff for dealing with tuples +* * +************************************************************************ + +Note [How tuples work] See also Note [Known-key names] in GHC.Builtin.Names +~~~~~~~~~~~~~~~~~~~~~~ +* There are three families of tuple TyCons and corresponding + DataCons, expressed by the type BasicTypes.TupleSort: + data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple + +* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon + +* BoxedTuples + - A wired-in type + - Data type declarations in GHC.Tuple + - The data constructors really have an info table + +* UnboxedTuples + - A wired-in type + - Have a pretend DataCon, defined in GHC.Prim, + but no actual declaration and no info table + +* ConstraintTuples + - Are known-key rather than wired-in. Reason: it's awkward to + have all the superclass selectors wired-in. + - Declared as classes in GHC.Classes, e.g. + class (c1,c2) => (c1,c2) + - Given constraints: the superclasses automatically become available + - Wanted constraints: there is a built-in instance + instance (c1,c2) => (c1,c2) + See GHC.Tc.Solver.Interact.matchCTuple + - Currently just go up to 62; beyond that + you have to use manual nesting + - Their OccNames look like (%,,,%), so they can easily be + distinguished from term tuples. But (following Haskell) we + pretty-print saturated constraint tuples with round parens; + see BasicTypes.tupleParens. + +* In quite a lot of places things are restricted just to + BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish + E.g. tupleTyCon has a Boxity argument + +* When looking up an OccName in the original-name cache + (GHC.Iface.Env.lookupOrigNameCache), we spot the tuple OccName to make sure + we get the right wired-in name. This guy can't tell the difference + between BoxedTuple and ConstraintTuple (same OccName!), so tuples + are not serialised into interface files using OccNames at all. + +* Serialization to interface files works via the usual mechanism for known-key + things: instead of serializing the OccName we just serialize the key. During + deserialization we lookup the Name associated with the unique with the logic + in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details. + +Note [One-tuples] +~~~~~~~~~~~~~~~~~ +GHC supports both boxed and unboxed one-tuples: + - Unboxed one-tuples are sometimes useful when returning a + single value after CPR analysis + - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when + there is just one binder +Basically it keeps everything uniform. + +However the /naming/ of the type/data constructors for one-tuples is a +bit odd: + 3-tuples: (,,) (,,)# + 2-tuples: (,) (,)# + 1-tuples: ?? + 0-tuples: () ()# + +Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#' +for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: + data () = () + data Solo a = Solo a + data (a,b) = (a,b) + +There is no way to write a boxed one-tuple in Haskell using tuple syntax. +They can, however, be written using other methods: + +1. They can be written directly by importing them from GHC.Tuple. +2. They can be generated by way of Template Haskell or in `deriving` code. + +There is nothing special about one-tuples in Core; in particular, they have no +custom pretty-printing, just using `Solo`. + +Note that there is *not* a unary constraint tuple, unlike for other forms of +tuples. See [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType for more +details. + +See also Note [Flattening one-tuples] in GHC.Core.Make and +Note [Don't flatten tuples from HsSyn] in GHC.Core.Make. + +----- +-- Wrinkle: Make boxed one-tuple names have known keys +----- + +We make boxed one-tuple names have known keys so that `data Solo a = Solo a`, +defined in GHC.Tuple, will be used when one-tuples are spliced in through +Template Haskell. This program (from #18097) crucially relies on this: + + case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x + +Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an +ExplicitTuple of length 1) will not match the type of Solo (an ordinary +data constructor used in a pattern). Making Solo known-key allows GHC to make +this connection. + +Unlike Solo, every other tuple is /not/ known-key +(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The +main reason for this exception is that other tuples are written with special +syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe` +function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache). +In contrast, Solo is just an ordinary data type with no special syntax, so it +doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Solo +known-key is the next-best way to teach the internals of the compiler about it. +-} + +-- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names +-- with BuiltInSyntax. However, this should only be necessary while resolving +-- names produced by Template Haskell splices since we take care to encode +-- built-in syntax names specially in interface files. See +-- Note [Symbol table representation of names]. +-- +-- Moreover, there is no need to include names of things that the user can't +-- write (e.g. type representation bindings like $tc(,,,)). +isBuiltInOcc_maybe :: OccName -> Maybe Name +isBuiltInOcc_maybe occ = + case name of + "[]" -> Just $ choose_ns listTyConName nilDataConName + ":" -> Just consDataConName + + -- equality tycon + "~" -> Just eqTyConName + + -- function tycon + "FUN" -> Just funTyConName + "->" -> Just unrestrictedFunTyConName + + -- boxed tuple data/tycon + -- We deliberately exclude Solo (the boxed 1-tuple). + -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) + "()" -> Just $ tup_name Boxed 0 + _ | Just rest <- "(" `BS.stripPrefix` name + , (commas, rest') <- BS.span (==',') rest + , ")" <- rest' + -> Just $ tup_name Boxed (1+BS.length commas) + + -- unboxed tuple data/tycon + "(##)" -> Just $ tup_name Unboxed 0 + "Solo#" -> Just $ tup_name Unboxed 1 + _ | Just rest <- "(#" `BS.stripPrefix` name + , (commas, rest') <- BS.span (==',') rest + , "#)" <- rest' + -> Just $ tup_name Unboxed (1+BS.length commas) + + -- unboxed sum tycon + _ | Just rest <- "(#" `BS.stripPrefix` name + , (pipes, rest') <- BS.span (=='|') rest + , "#)" <- rest' + -> Just $ tyConName $ sumTyCon (1+BS.length pipes) + + -- unboxed sum datacon + _ | Just rest <- "(#" `BS.stripPrefix` name + , (pipes1, rest') <- BS.span (=='|') rest + , Just rest'' <- "_" `BS.stripPrefix` rest' + , (pipes2, rest''') <- BS.span (=='|') rest'' + , "#)" <- rest''' + -> let arity = BS.length pipes1 + BS.length pipes2 + 1 + alt = BS.length pipes1 + 1 + in Just $ dataConName $ sumDataCon alt arity + _ -> Nothing + where + name = bytesFS $ occNameFS occ + + choose_ns :: Name -> Name -> Name + choose_ns tc dc + | isTcClsNameSpace ns = tc + | isDataConNameSpace ns = dc + | otherwise = pprPanic "tup_name" (ppr occ) + where ns = occNameSpace occ + + tup_name boxity arity + = choose_ns (getName (tupleTyCon boxity arity)) + (getName (tupleDataCon boxity arity)) + +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +-- No need to cache these, the caching is done in mk_tuple +mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar) +mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar) + +mkCTupleOcc :: NameSpace -> Arity -> OccName +mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) + +mkTupleStr :: Boxity -> Arity -> String +mkTupleStr Boxed = mkBoxedTupleStr +mkTupleStr Unboxed = mkUnboxedTupleStr + +mkBoxedTupleStr :: Arity -> String +mkBoxedTupleStr 0 = "()" +mkBoxedTupleStr 1 = "Solo" -- See Note [One-tuples] +mkBoxedTupleStr ar = '(' : commas ar ++ ")" + +mkUnboxedTupleStr :: Arity -> String +mkUnboxedTupleStr 0 = "(##)" +mkUnboxedTupleStr 1 = "Solo#" -- See Note [One-tuples] +mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)" + +mkConstraintTupleStr :: Arity -> String +mkConstraintTupleStr 0 = "(%%)" +mkConstraintTupleStr 1 = "Solo%" -- See Note [One-tuples] +mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)" + +commas :: Arity -> String +commas ar = take (ar-1) (repeat ',') + +cTupleTyConName :: Arity -> Name +cTupleTyConName arity + = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES + (mkCTupleOcc tcName arity) noSrcSpan + +cTupleTyConNames :: [Name] +cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) + +cTupleTyConNameSet :: NameSet +cTupleTyConNameSet = mkNameSet cTupleTyConNames + +isCTupleTyConName :: Name -> Bool +-- Use Type.isCTupleClass where possible +isCTupleTyConName n + = ASSERT2( isExternalName n, ppr n ) + nameModule n == gHC_CLASSES + && n `elemNameSet` cTupleTyConNameSet + +-- | If the given name is that of a constraint tuple, return its arity. +-- Note that this is inefficient. +cTupleTyConNameArity_maybe :: Name -> Maybe Arity +cTupleTyConNameArity_maybe n + | not (isCTupleTyConName n) = Nothing + | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames) + where + -- Since `cTupleTyConNames` jumps straight from the `0` to the `2` + -- case, we have to adjust accordingly our calculated arity. + adjustArity a = if a > 0 then a + 1 else a + +cTupleDataConName :: Arity -> Name +cTupleDataConName arity + = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES + (mkCTupleOcc dataName arity) noSrcSpan + +cTupleDataConNames :: [Name] +cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) + +tupleTyCon :: Boxity -> Arity -> TyCon +tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleTyConName :: TupleSort -> Arity -> Name +tupleTyConName ConstraintTuple a = cTupleTyConName a +tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) +tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) + +promotedTupleDataCon :: Boxity -> Arity -> TyCon +promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) + +tupleDataCon :: Boxity -> Arity -> DataCon +tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially +tupleDataCon Boxed i = snd (boxedTupleArr ! i) +tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) + +tupleDataConName :: Boxity -> Arity -> Name +tupleDataConName sort i = dataConName (tupleDataCon sort i) + +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] + +-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed +-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type +-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep +-- [IntRep, LiftedRep])@ +unboxedTupleSumKind :: TyCon -> [Type] -> Kind +unboxedTupleSumKind tc rr_tys + = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) + +-- | Specialization of 'unboxedTupleSumKind' for tuples +unboxedTupleKind :: [Type] -> Kind +unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon + +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple Boxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + BoxedTuple flavour + + tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) + tc_res_kind = liftedTypeKind + tc_arity = arity + flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + dc_arg_tys = mkTyVarTys dc_tvs + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Boxed + modu = gHC_TUPLE + tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +mk_tuple Unboxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + UnboxedTuple flavour + + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> # + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map tYPE ks) + + tc_res_kind = unboxedTupleKind rr_tys + + tc_arity = arity * 2 + flavour = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Unboxed + modu = gHC_PRIM + tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +unitTyCon :: TyCon +unitTyCon = tupleTyCon Boxed 0 + +unitTyConKey :: Unique +unitTyConKey = getUnique unitTyCon + +unitDataCon :: DataCon +unitDataCon = head (tyConDataCons unitTyCon) + +unitDataConId :: Id +unitDataConId = dataConWorkId unitDataCon + +pairTyCon :: TyCon +pairTyCon = tupleTyCon Boxed 2 + +unboxedUnitTyCon :: TyCon +unboxedUnitTyCon = tupleTyCon Unboxed 0 + +unboxedUnitDataCon :: DataCon +unboxedUnitDataCon = tupleDataCon Unboxed 0 + + +{- ********************************************************************* +* * + Unboxed sums +* * +********************************************************************* -} + +-- | OccName for n-ary unboxed sum type constructor. +mkSumTyConOcc :: Arity -> OccName +mkSumTyConOcc n = mkOccName tcName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : bars ++ "#)" + bars = replicate (n-1) '|' + +-- | OccName for i-th alternative of n-ary unboxed sum data constructor. +mkSumDataConOcc :: ConTag -> Arity -> OccName +mkSumDataConOcc alt n = mkOccName dataName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)" + bars i = replicate i '|' + +-- | Type constructor for n-ary unboxed sum. +sumTyCon :: Arity -> TyCon +sumTyCon arity + | arity > mAX_SUM_SIZE + = fst (mk_sum arity) -- Build one specially + + | arity < 2 + = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") + + | otherwise + = fst (unboxedSumArr ! arity) + +-- | Data constructor for i-th alternative of a n-ary unboxed sum. +sumDataCon :: ConTag -- Alternative + -> Arity -- Arity + -> DataCon +sumDataCon alt arity + | alt > arity + = panic ("sumDataCon: index out of bounds: alt: " + ++ show alt ++ " > arity " ++ show arity) + + | alt <= 0 + = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity < 2 + = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity > mAX_SUM_SIZE + = snd (mk_sum arity) ! (alt - 1) -- Build one specially + + | otherwise + = snd (unboxedSumArr ! arity) ! (alt - 1) + +-- | Cached type and data constructors for sums. The outer array is +-- indexed by the arity of the sum and the inner array is indexed by +-- the alternative. +unboxedSumArr :: Array Int (TyCon, Array Int DataCon) +unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] + +-- | Specialization of 'unboxedTupleSumKind' for sums +unboxedSumKind :: [Type] -> Kind +unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon + +-- | Create type constructor and data constructors for n-ary unboxed sum. +mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) +mk_sum arity = (tycon, sum_cons) + where + tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) + (UnboxedAlgTyCon rep_name) + + -- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276. + rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name + + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map tYPE ks) + + tyvars = binderVars tc_binders + + tc_res_kind = unboxedSumKind rr_tys + + (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars) + + tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + + sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] + sum_con i = let dc = pcDataCon dc_name + tyvars -- univ tyvars + [tyvar_tys !! i] -- arg types + tycon + + dc_name = mkWiredInName gHC_PRIM + (mkSumDataConOcc i arity) + (dc_uniq i) + (AConLike (RealDataCon dc)) + BuiltInSyntax + in dc + + tc_uniq = mkSumTyConUnique arity + dc_uniq i = mkSumDataConUnique i arity + +{- +************************************************************************ +* * + Equality types and classes +* * +********************************************************************* -} + +-- See Note [The equality types story] in GHC.Builtin.Types.Prim +-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) +-- +-- It's tempting to put functional dependencies on (~~), but it's not +-- necessary because the functional-dependency coverage check looks +-- through superclasses, and (~#) is handled in that check. + +eqTyCon, heqTyCon, coercibleTyCon :: TyCon +eqClass, heqClass, coercibleClass :: Class +eqDataCon, heqDataCon, coercibleDataCon :: DataCon +eqSCSelId, heqSCSelId, coercibleSCSelId :: Id + +(eqTyCon, eqClass, eqDataCon, eqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon eqTyConName binders roles + rhs klass + (mkPrelTyConRepName eqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b]) + sc_sel_id = mkDictSelId eqSCSelIdName klass + +(heqTyCon, heqClass, heqDataCon, heqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon heqTyConName binders roles + rhs klass + (mkPrelTyConRepName heqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConW heqDataConName tvs [unrestricted sc_pred] tycon + + -- Kind: forall k1 k2. k1 -> k2 -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + roles = [Nominal, Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + + tvs = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) + sc_sel_id = mkDictSelId heqSCSelIdName klass + +(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon coercibleTyConName binders roles + rhs klass + (mkPrelTyConRepName coercibleTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConW coercibleDataConName tvs [unrestricted sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Representational, Representational] + rhs = mkDataTyConRhs [datacon] + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) + sc_sel_id = mkDictSelId coercibleSCSelIdName klass + +mk_class :: TyCon -> PredType -> Id -> Class +mk_class tycon sc_pred sc_sel_id + = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] + [] [] (mkAnd []) tycon + + + +{- ********************************************************************* +* * + Multiplicity Polymorphism +* * +********************************************************************* -} + +{- Multiplicity polymorphism is implemented very similarly to levity + polymorphism. We write in the multiplicity kind and the One and Many + types which can appear in user programs. These are defined properly in GHC.Types. + +data Multiplicity = One | Many +-} + +multiplicityTy :: Type +multiplicityTy = mkTyConTy multiplicityTyCon + +multiplicityTyCon :: TyCon +multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] + [oneDataCon, manyDataCon] + +oneDataCon, manyDataCon :: DataCon +oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon +manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon + +oneDataConTy, manyDataConTy :: Type +oneDataConTy = mkTyConTy oneDataConTyCon +manyDataConTy = mkTyConTy manyDataConTyCon + +oneDataConTyCon, manyDataConTyCon :: TyCon +oneDataConTyCon = promoteDataCon oneDataCon +manyDataConTyCon = promoteDataCon manyDataCon + +multMulTyConName :: Name +multMulTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon + +multMulTyCon :: TyCon +multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing + (BuiltInSynFamTyCon trivialBuiltInFamily) + Nothing + NotInjective + where + binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] + +unrestrictedFunTy :: Type +unrestrictedFunTy = functionWithMultiplicity manyDataConTy + +unrestrictedFunTyCon :: TyCon +unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy + where arrowKind = mkTyConKind binders liftedTypeKind + -- See also funTyCon + binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) + , Bndr runtimeRep2TyVar (NamedTCB Inferred) + ] + ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty + , tYPE runtimeRep2Ty + ] + +unrestrictedFunTyConName :: Name +unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") unrestrictedFunTyConKey unrestrictedFunTyCon + +{- ********************************************************************* +* * + Kinds and RuntimeRep +* * +********************************************************************* -} + +-- For information about the usage of the following type, +-- see Note [TYPE and RuntimeRep] in module GHC.Builtin.Types.Prim +runtimeRepTy :: Type +runtimeRepTy = mkTyConTy runtimeRepTyCon + +-- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim +-- type Type = tYPE 'LiftedRep +liftedTypeKindTyCon :: TyCon +liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName + [] liftedTypeKind [] + (tYPE liftedRepTy) + +runtimeRepTyCon :: TyCon +runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] + (vecRepDataCon : tupleRepDataCon : + sumRepDataCon : runtimeRepSimpleDataCons) + +vecRepDataCon :: DataCon +vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon + , mkTyConTy vecElemTyCon ] + runtimeRepTyCon + (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [count, elem] + | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) + , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) + = [VecRep n e] + prim_rep_fun args + = pprPanic "vecRepDataCon" (ppr args) + +vecRepDataConTyCon :: TyCon +vecRepDataConTyCon = promoteDataCon vecRepDataCon + +tupleRepDataCon :: DataCon +tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [rr_ty_list] + = concatMap (runtimeRepPrimRep doc) rr_tys + where + rr_tys = extractPromotedList rr_ty_list + doc = text "tupleRepDataCon" <+> ppr rr_tys + prim_rep_fun args + = pprPanic "tupleRepDataCon" (ppr args) + +tupleRepDataConTyCon :: TyCon +tupleRepDataConTyCon = promoteDataCon tupleRepDataCon + +sumRepDataCon :: DataCon +sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [rr_ty_list] + = map slotPrimRep (ubxSumRepType prim_repss) + where + rr_tys = extractPromotedList rr_ty_list + doc = text "sumRepDataCon" <+> ppr rr_tys + prim_repss = map (runtimeRepPrimRep doc) rr_tys + prim_rep_fun args + = pprPanic "sumRepDataCon" (ppr args) + +sumRepDataConTyCon :: TyCon +sumRepDataConTyCon = promoteDataCon sumRepDataCon + +-- See Note [Wiring in RuntimeRep] +-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType +runtimeRepSimpleDataCons :: [DataCon] +liftedRepDataCon :: DataCon +runtimeRepSimpleDataCons@(liftedRepDataCon : _) + = zipWithLazy mk_runtime_rep_dc + [ LiftedRep, UnliftedRep + , IntRep + , Int8Rep, Int16Rep, Int32Rep, Int64Rep + , WordRep + , Word8Rep, Word16Rep, Word32Rep, Word64Rep + , AddrRep + , FloatRep, DoubleRep + ] + runtimeRepSimpleDataConNames + where + mk_runtime_rep_dc primrep name + = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + +-- See Note [Wiring in RuntimeRep] +liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy :: Type +[liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy + ] + = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons + +vecCountTyCon :: TyCon +vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons + +-- See Note [Wiring in RuntimeRep] +vecCountDataCons :: [DataCon] +vecCountDataCons = zipWithLazy mk_vec_count_dc + [ 2, 4, 8, 16, 32, 64 ] + vecCountDataConNames + where + mk_vec_count_dc n name + = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + +-- See Note [Wiring in RuntimeRep] +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type +[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons + +vecElemTyCon :: TyCon +vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons + +-- See Note [Wiring in RuntimeRep] +vecElemDataCons :: [DataCon] +vecElemDataCons = zipWithLazy mk_vec_elem_dc + [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep + , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep + , FloatElemRep, DoubleElemRep ] + vecElemDataConNames + where + mk_vec_elem_dc elem name + = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) + +-- See Note [Wiring in RuntimeRep] +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type +[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) + vecElemDataCons + +liftedRepDataConTyCon :: TyCon +liftedRepDataConTyCon = promoteDataCon liftedRepDataCon + +-- The type ('LiftedRep) +liftedRepTy :: Type +liftedRepTy = liftedRepDataConTy + +{- ********************************************************************* +* * + The boxed primitive types: Char, Int, etc +* * +********************************************************************* -} + +boxingDataCon_maybe :: TyCon -> Maybe DataCon +-- boxingDataCon_maybe Char# = C# +-- boxingDataCon_maybe Int# = I# +-- ... etc ... +-- See Note [Boxing primitive types] +boxingDataCon_maybe tc + = lookupNameEnv boxing_constr_env (tyConName tc) + +boxing_constr_env :: NameEnv DataCon +boxing_constr_env + = mkNameEnv [(charPrimTyConName , charDataCon ) + ,(intPrimTyConName , intDataCon ) + ,(wordPrimTyConName , wordDataCon ) + ,(floatPrimTyConName , floatDataCon ) + ,(doublePrimTyConName, doubleDataCon) ] + +{- Note [Boxing primitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a handful of primitive types (Int, Char, Word, Float, Double), +we can readily box and an unboxed version (Int#, Char# etc) using +the corresponding data constructor. This is useful in a couple +of places, notably let-floating -} + + +charTy :: Type +charTy = mkTyConTy charTyCon + +charTyCon :: TyCon +charTyCon = pcTyCon charTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsChar"))) + [] [charDataCon] +charDataCon :: DataCon +charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon + +stringTy :: Type +stringTy = mkTyConApp stringTyCon [] + +stringTyCon :: TyCon +-- We have this wired-in so that Haskell literal strings +-- get type String (in hsLitType), which in turn influences +-- inferred types and error messages +stringTyCon = buildSynTyCon stringTyConName + [] liftedTypeKind [] + (mkListTy charTy) + +intTy :: Type +intTy = mkTyConTy intTyCon + +intTyCon :: TyCon +intTyCon = pcTyCon intTyConName + (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) + [] [intDataCon] +intDataCon :: DataCon +intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon + +wordTy :: Type +wordTy = mkTyConTy wordTyCon + +wordTyCon :: TyCon +wordTyCon = pcTyCon wordTyConName + (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) + [] [wordDataCon] +wordDataCon :: DataCon +wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon + +word8Ty :: Type +word8Ty = mkTyConTy word8TyCon + +word8TyCon :: TyCon +word8TyCon = pcTyCon word8TyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsWord8"))) [] + [word8DataCon] +word8DataCon :: DataCon +word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon + +floatTy :: Type +floatTy = mkTyConTy floatTyCon + +floatTyCon :: TyCon +floatTyCon = pcTyCon floatTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsFloat"))) [] + [floatDataCon] +floatDataCon :: DataCon +floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon + +doubleTy :: Type +doubleTy = mkTyConTy doubleTyCon + +doubleTyCon :: TyCon +doubleTyCon = pcTyCon doubleTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsDouble"))) [] + [doubleDataCon] + +doubleDataCon :: DataCon +doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon + +{- +************************************************************************ +* * + The Bool type +* * +************************************************************************ + +An ordinary enumeration type, but deeply wired in. There are no +magical operations on @Bool@ (just the regular Prelude code). + +{\em BEGIN IDLE SPECULATION BY SIMON} + +This is not the only way to encode @Bool@. A more obvious coding makes +@Bool@ just a boxed up version of @Bool#@, like this: +\begin{verbatim} +type Bool# = Int# +data Bool = MkBool Bool# +\end{verbatim} + +Unfortunately, this doesn't correspond to what the Report says @Bool@ +looks like! Furthermore, we get slightly less efficient code (I +think) with this coding. @gtInt@ would look like this: + +\begin{verbatim} +gtInt :: Int -> Int -> Bool +gtInt x y = case x of I# x# -> + case y of I# y# -> + case (gtIntPrim x# y#) of + b# -> MkBool b# +\end{verbatim} + +Notice that the result of the @gtIntPrim@ comparison has to be turned +into an integer (here called @b#@), and returned in a @MkBool@ box. + +The @if@ expression would compile to this: +\begin{verbatim} +case (gtInt x y) of + MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } +\end{verbatim} + +I think this code is a little less efficient than the previous code, +but I'm not certain. At all events, corresponding with the Report is +important. The interesting thing is that the language is expressive +enough to describe more than one alternative; and that a type doesn't +necessarily need to be a straightforwardly boxed version of its +primitive counterpart. + +{\em END IDLE SPECULATION BY SIMON} +-} + +boolTy :: Type +boolTy = mkTyConTy boolTyCon + +boolTyCon :: TyCon +boolTyCon = pcTyCon boolTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsBool"))) + [] [falseDataCon, trueDataCon] + +falseDataCon, trueDataCon :: DataCon +falseDataCon = pcDataCon falseDataConName [] [] boolTyCon +trueDataCon = pcDataCon trueDataConName [] [] boolTyCon + +falseDataConId, trueDataConId :: Id +falseDataConId = dataConWorkId falseDataCon +trueDataConId = dataConWorkId trueDataCon + +orderingTyCon :: TyCon +orderingTyCon = pcTyCon orderingTyConName Nothing + [] [ordLTDataCon, ordEQDataCon, ordGTDataCon] + +ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon +ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon +ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon +ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon + +ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id +ordLTDataConId = dataConWorkId ordLTDataCon +ordEQDataConId = dataConWorkId ordEQDataCon +ordGTDataConId = dataConWorkId ordGTDataCon + +{- +************************************************************************ +* * + The List type + Special syntax, deeply wired in, + but otherwise an ordinary algebraic data type +* * +************************************************************************ + + data [] a = [] | a : (List a) +-} + +mkListTy :: Type -> Type +mkListTy ty = mkTyConApp listTyCon [ty] + +listTyCon :: TyCon +listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon] + +-- See also Note [Empty lists] in GHC.Hs.Expr. +nilDataCon :: DataCon +nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon + +consDataCon :: DataCon +consDataCon = pcDataConWithFixity True {- Declared infix -} + consDataConName + alpha_tyvar [] alpha_tyvar + (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) listTyCon +-- Interesting: polymorphic recursion would help here. +-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy +-- gets the over-specific type (Type -> Type) + +-- Wired-in type Maybe + +maybeTyCon :: TyCon +maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar + [nothingDataCon, justDataCon] + +nothingDataCon :: DataCon +nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon + +justDataCon :: DataCon +justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon + +{- +** ********************************************************************* +* * + The tuple types +* * +************************************************************************ + +The tuple types are definitely magic, because they form an infinite +family. + +\begin{itemize} +\item +They have a special family of type constructors, of type @TyCon@ +These contain the tycon arity, but don't require a Unique. + +\item +They have a special family of constructors, of type +@Id@. Again these contain their arity but don't need a Unique. + +\item +There should be a magic way of generating the info tables and +entry code for all tuples. + +But at the moment we just compile a Haskell source +file\srcloc{lib/prelude/...} containing declarations like: +\begin{verbatim} +data Tuple0 = Tup0 +data Tuple2 a b = Tup2 a b +data Tuple3 a b c = Tup3 a b c +data Tuple4 a b c d = Tup4 a b c d +... +\end{verbatim} +The print-names associated with the magic @Id@s for tuple constructors +``just happen'' to be the same as those generated by these +declarations. + +\item +The instance environment should have a magic way to know +that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and +so on. \ToDo{Not implemented yet.} + +\item +There should also be a way to generate the appropriate code for each +of these instances, but (like the info tables and entry code) it is +done by enumeration\srcloc{lib/prelude/InTup?.hs}. +\end{itemize} +-} + +-- | Make a tuple type. The list of types should /not/ include any +-- RuntimeRep specifications. Boxed 1-tuples are flattened. +-- See Note [One-tuples] +mkTupleTy :: Boxity -> [Type] -> Type +-- Special case for *boxed* 1-tuples, which are represented by the type itself +mkTupleTy Boxed [ty] = ty +mkTupleTy boxity tys = mkTupleTy1 boxity tys + +-- | Make a tuple type. The list of types should /not/ include any +-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened. +-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn] +-- in "GHC.Core.Make" +mkTupleTy1 :: Boxity -> [Type] -> Type +mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys +mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) + (map getRuntimeRep tys ++ tys) + +-- | Build the type of a small tuple that holds the specified type of thing +-- Flattens 1-tuples. See Note [One-tuples]. +mkBoxedTupleTy :: [Type] -> Type +mkBoxedTupleTy tys = mkTupleTy Boxed tys + +unitTy :: Type +unitTy = mkTupleTy Boxed [] + +{- ********************************************************************* +* * + The sum types +* * +************************************************************************ +-} + +mkSumTy :: [Type] -> Type +mkSumTy tys = mkTyConApp (sumTyCon (length tys)) + (map getRuntimeRep tys ++ tys) + +-- Promoted Booleans + +promotedFalseDataCon, promotedTrueDataCon :: TyCon +promotedTrueDataCon = promoteDataCon trueDataCon +promotedFalseDataCon = promoteDataCon falseDataCon + +-- Promoted Maybe +promotedNothingDataCon, promotedJustDataCon :: TyCon +promotedNothingDataCon = promoteDataCon nothingDataCon +promotedJustDataCon = promoteDataCon justDataCon + +-- Promoted Ordering + +promotedLTDataCon + , promotedEQDataCon + , promotedGTDataCon + :: TyCon +promotedLTDataCon = promoteDataCon ordLTDataCon +promotedEQDataCon = promoteDataCon ordEQDataCon +promotedGTDataCon = promoteDataCon ordGTDataCon + +-- Promoted List +promotedConsDataCon, promotedNilDataCon :: TyCon +promotedConsDataCon = promoteDataCon consDataCon +promotedNilDataCon = promoteDataCon nilDataCon + +-- | Make a *promoted* list. +mkPromotedListTy :: Kind -- ^ of the elements of the list + -> [Type] -- ^ elements + -> Type +mkPromotedListTy k tys + = foldr cons nil tys + where + cons :: Type -- element + -> Type -- list + -> Type + cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] + + nil :: Type + nil = mkTyConApp promotedNilDataCon [k] + +-- | Extract the elements of a promoted list. Panics if the type is not a +-- promoted list +extractPromotedList :: Type -- ^ The promoted list + -> [Type] +extractPromotedList tys = go tys + where + go list_ty + | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty + = ASSERT( tc `hasKey` consDataConKey ) + t : go ts + + | Just (tc, [_k]) <- splitTyConApp_maybe list_ty + = ASSERT( tc `hasKey` nilDataConKey ) + [] + + | otherwise + = pprPanic "extractPromotedList" (ppr tys) + + + +--------------------------------------- +-- ghc-bignum +--------------------------------------- + +integerTyConName + , integerISDataConName + , integerIPDataConName + , integerINDataConName + :: Name +integerTyConName + = mkWiredInTyConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "Integer") + integerTyConKey + integerTyCon +integerISDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "IS") + integerISDataConKey + integerISDataCon +integerIPDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "IP") + integerIPDataConKey + integerIPDataCon +integerINDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "IN") + integerINDataConKey + integerINDataCon + +integerTy :: Type +integerTy = mkTyConTy integerTyCon + +integerTyCon :: TyCon +integerTyCon = pcTyCon integerTyConName Nothing [] + [integerISDataCon, integerIPDataCon, integerINDataCon] + +integerISDataCon :: DataCon +integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon + +integerIPDataCon :: DataCon +integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon + +integerINDataCon :: DataCon +integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon + +naturalTyConName + , naturalNSDataConName + , naturalNBDataConName + :: Name +naturalTyConName + = mkWiredInTyConName + UserSyntax + gHC_NUM_NATURAL + (fsLit "Natural") + naturalTyConKey + naturalTyCon +naturalNSDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_NATURAL + (fsLit "NS") + naturalNSDataConKey + naturalNSDataCon +naturalNBDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_NATURAL + (fsLit "NB") + naturalNBDataConKey + naturalNBDataCon + +naturalTy :: Type +naturalTy = mkTyConTy naturalTyCon + +naturalTyCon :: TyCon +naturalTyCon = pcTyCon naturalTyConName Nothing [] + [naturalNSDataCon, naturalNBDataCon] + +naturalNSDataCon :: DataCon +naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon + +naturalNBDataCon :: DataCon +naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon diff --git a/GHC/Builtin/Types.hs-boot b/GHC/Builtin/Types.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types.hs-boot @@ -0,0 +1,58 @@ +module GHC.Builtin.Types where + +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind) + +import GHC.Types.Basic (Arity, TupleSort) +import GHC.Types.Name (Name) + +listTyCon :: TyCon +typeNatKind, typeSymbolKind :: Type +mkBoxedTupleTy :: [Type] -> Type + +coercibleTyCon, heqTyCon :: TyCon + +unitTy :: Type + +liftedTypeKind :: Kind +liftedTypeKindTyCon :: TyCon + +constraintKind :: Kind + +runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon +runtimeRepTy :: Type + +liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon + +liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy :: Type + +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type + +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type + +anyTypeOfKind :: Kind -> Type +unboxedTupleKind :: [Type] -> Type +mkPromotedListTy :: Type -> [Type] -> Type + +multiplicityTyCon :: TyCon +multiplicityTy :: Type +oneDataConTy :: Type +oneDataConTyCon :: TyCon +manyDataConTy :: Type +manyDataConTyCon :: TyCon +unrestrictedFunTyCon :: TyCon +multMulTyCon :: TyCon + +tupleTyConName :: TupleSort -> Arity -> Name + +integerTy, naturalTy :: Type diff --git a/GHC/Builtin/Types/Literals.hs b/GHC/Builtin/Types/Literals.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types/Literals.hs @@ -0,0 +1,991 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.Builtin.Types.Literals + ( typeNatTyCons + , typeNatCoAxiomRules + , BuiltInSynFamily(..) + + -- If you define a new built-in type family, make sure to export its TyCon + -- from here as well. + -- See Note [Adding built-in type families] + , typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatLeqTyCon + , typeNatSubTyCon + , typeNatDivTyCon + , typeNatModTyCon + , typeNatLogTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + , typeSymbolAppendTyCon + ) where + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Data.Pair +import GHC.Tc.Utils.TcType ( TcType, tcEqType ) +import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon + , Injectivity(..) ) +import GHC.Core.Coercion ( Role(..) ) +import GHC.Tc.Types.Constraint ( Xi ) +import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) +import GHC.Types.Name ( Name, BuiltInSyntax(..) ) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders ) +import GHC.Builtin.Names + ( gHC_TYPELITS + , gHC_TYPENATS + , typeNatAddTyFamNameKey + , typeNatMulTyFamNameKey + , typeNatExpTyFamNameKey + , typeNatLeqTyFamNameKey + , typeNatSubTyFamNameKey + , typeNatDivTyFamNameKey + , typeNatModTyFamNameKey + , typeNatLogTyFamNameKey + , typeNatCmpTyFamNameKey + , typeSymbolCmpTyFamNameKey + , typeSymbolAppendFamNameKey + ) +import GHC.Data.FastString +import qualified Data.Map as Map +import Data.Maybe ( isJust ) +import Control.Monad ( guard ) +import Data.List ( isPrefixOf, isSuffixOf ) + +{- +Note [Type-level literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are currently two forms of type-level literals: natural numbers, and +symbols (even though this module is named GHC.Builtin.Types.Literals, it covers both). + +Type-level literals are supported by CoAxiomRules (conditional axioms), which +power the built-in type families (see Note [Adding built-in type families]). +Currently, all built-in type families are for the express purpose of supporting +type-level literals. + +See also the Wiki page: + + https://gitlab.haskell.org/ghc/ghc/wikis/type-nats + +Note [Adding built-in type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a few steps to adding a built-in type family: + +* Adding a unique for the type family TyCon + + These go in GHC.Builtin.Names. It will likely be of the form + @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that + has not been chosen before in GHC.Builtin.Names. There are several examples already + in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey. + +* Adding the type family TyCon itself + + This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define + these—see, for instance, typeNatAddTyCon. + + Once your TyCon has been defined, be sure to: + + - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.) + - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals. + +* Exposing associated type family axioms + + When defining the type family TyCon, you will need to define an axiom for + the type family in general (see, for instance, axAddDef), and perhaps other + auxiliary axioms for special cases of the type family (see, for instance, + axAdd0L and axAdd0R). + + After you have defined all of these axioms, be sure to include them in the + typeNatCoAxiomRules list, defined in GHC.Builtin.Types.Literals. + (Not doing so caused #14934.) + +* Define the type family somewhere + + Finally, you will need to define the type family somewhere, likely in @base@. + Currently, all of the built-in type families are defined in GHC.TypeLits or + GHC.TypeNats, so those are likely candidates. + + Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals, + you should give an open type family definition with no instances, like so: + + type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat + + Changing the argument and result kinds as appropriate. + +* Update the relevant test cases + + The GHC test suite will likely need to be updated after you add your built-in + type family. For instance: + + - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added + a test there, the expected output of T9181 will need to change. + - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit + tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have + runtime unit tests. Consider adding further unit tests to those if your + built-in type family deals with Nats or Symbols, respectively. +-} + +{------------------------------------------------------------------------------- +Built-in type constructors for functions on type-level nats +-} + +-- The list of built-in type family TyCons that GHC uses. +-- If you define a built-in type family, make sure to add it to this list. +-- See Note [Adding built-in type families] +typeNatTyCons :: [TyCon] +typeNatTyCons = + [ typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatLeqTyCon + , typeNatSubTyCon + , typeNatDivTyCon + , typeNatModTyCon + , typeNatLogTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + , typeSymbolAppendTyCon + ] + +typeNatAddTyCon :: TyCon +typeNatAddTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamAdd + , sfInteractTop = interactTopAdd + , sfInteractInert = interactInertAdd + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+") + typeNatAddTyFamNameKey typeNatAddTyCon + +typeNatSubTyCon :: TyCon +typeNatSubTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamSub + , sfInteractTop = interactTopSub + , sfInteractInert = interactInertSub + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-") + typeNatSubTyFamNameKey typeNatSubTyCon + +typeNatMulTyCon :: TyCon +typeNatMulTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamMul + , sfInteractTop = interactTopMul + , sfInteractInert = interactInertMul + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*") + typeNatMulTyFamNameKey typeNatMulTyCon + +typeNatDivTyCon :: TyCon +typeNatDivTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamDiv + , sfInteractTop = interactTopDiv + , sfInteractInert = interactInertDiv + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div") + typeNatDivTyFamNameKey typeNatDivTyCon + +typeNatModTyCon :: TyCon +typeNatModTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamMod + , sfInteractTop = interactTopMod + , sfInteractInert = interactInertMod + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod") + typeNatModTyFamNameKey typeNatModTyCon + + + + + +typeNatExpTyCon :: TyCon +typeNatExpTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamExp + , sfInteractTop = interactTopExp + , sfInteractInert = interactInertExp + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^") + typeNatExpTyFamNameKey typeNatExpTyCon + +typeNatLogTyCon :: TyCon +typeNatLogTyCon = mkTypeNatFunTyCon1 name + BuiltInSynFamily + { sfMatchFam = matchFamLog + , sfInteractTop = interactTopLog + , sfInteractInert = interactInertLog + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2") + typeNatLogTyFamNameKey typeNatLogTyCon + + + +typeNatLeqTyCon :: TyCon +typeNatLeqTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) + boolTy + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?") + typeNatLeqTyFamNameKey typeNatLeqTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamLeq + , sfInteractTop = interactTopLeq + , sfInteractInert = interactInertLeq + } + +typeNatCmpTyCon :: TyCon +typeNatCmpTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat") + typeNatCmpTyFamNameKey typeNatCmpTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamCmpNat + , sfInteractTop = interactTopCmpNat + , sfInteractInert = \_ _ _ _ -> [] + } + +typeSymbolCmpTyCon :: TyCon +typeSymbolCmpTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol") + typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamCmpSymbol + , sfInteractTop = interactTopCmpSymbol + , sfInteractInert = \_ _ _ _ -> [] + } + +typeSymbolAppendTyCon :: TyCon +typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamAppendSymbol + , sfInteractTop = interactTopAppendSymbol + , sfInteractInert = interactInertAppendSymbol + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol") + typeSymbolAppendFamNameKey typeSymbolAppendTyCon + + + +-- Make a unary built-in constructor of kind: Nat -> Nat +mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon +mkTypeNatFunTyCon1 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ typeNatKind ]) + typeNatKind + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + + +-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat +mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon +mkTypeNatFunTyCon2 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) + typeNatKind + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + +-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol +mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon +mkTypeSymbolFunTyCon2 op tcb = + mkFamilyTyCon op + (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) + typeSymbolKind + Nothing + (BuiltInSynFamTyCon tcb) + Nothing + NotInjective + + +{------------------------------------------------------------------------------- +Built-in rules axioms +-------------------------------------------------------------------------------} + +-- If you add additional rules, please remember to add them to +-- `typeNatCoAxiomRules` also. +-- See Note [Adding built-in type families] +axAddDef + , axMulDef + , axExpDef + , axLeqDef + , axCmpNatDef + , axCmpSymbolDef + , axAppendSymbolDef + , axAdd0L + , axAdd0R + , axMul0L + , axMul0R + , axMul1L + , axMul1R + , axExp1L + , axExp0R + , axExp1R + , axLeqRefl + , axCmpNatRefl + , axCmpSymbolRefl + , axLeq0L + , axSubDef + , axSub0R + , axAppendSymbol0R + , axAppendSymbol0L + , axDivDef + , axDiv1 + , axModDef + , axMod1 + , axLogDef + :: CoAxiomRule + +axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $ + \x y -> Just $ num (x + y) + +axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $ + \x y -> Just $ num (x * y) + +axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $ + \x y -> Just $ num (x ^ y) + +axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $ + \x y -> Just $ bool (x <= y) + +axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon + $ \x y -> Just $ ordering (compare x y) + +axCmpSymbolDef = + CoAxiomRule + { coaxrName = fsLit "CmpSymbolDef" + , coaxrAsmpRoles = [Nominal, Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + s2' <- isStrLitTy s2 + t2' <- isStrLitTy t2 + return (mkTyConApp typeSymbolCmpTyCon [s1,t1] === + ordering (compare s2' t2')) } + +axAppendSymbolDef = CoAxiomRule + { coaxrName = fsLit "AppendSymbolDef" + , coaxrAsmpRoles = [Nominal, Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + s2' <- isStrLitTy s2 + t2' <- isStrLitTy t2 + let z = mkStrLitTy (appendFS s2' t2') + return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z) + } + +axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ + \x y -> fmap num (minus x y) + +axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $ + \x y -> do guard (y /= 0) + return (num (div x y)) + +axModDef = mkBinAxiom "ModDef" typeNatModTyCon $ + \x y -> do guard (y /= 0) + return (num (mod x y)) + +axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $ + \x -> do (a,_) <- genLog x 2 + return (num a) + +axAdd0L = mkAxiom1 "Add0L" $ \(Pair s t) -> (num 0 .+. s) === t +axAdd0R = mkAxiom1 "Add0R" $ \(Pair s t) -> (s .+. num 0) === t +axSub0R = mkAxiom1 "Sub0R" $ \(Pair s t) -> (s .-. num 0) === t +axMul0L = mkAxiom1 "Mul0L" $ \(Pair s _) -> (num 0 .*. s) === num 0 +axMul0R = mkAxiom1 "Mul0R" $ \(Pair s _) -> (s .*. num 0) === num 0 +axMul1L = mkAxiom1 "Mul1L" $ \(Pair s t) -> (num 1 .*. s) === t +axMul1R = mkAxiom1 "Mul1R" $ \(Pair s t) -> (s .*. num 1) === t +axDiv1 = mkAxiom1 "Div1" $ \(Pair s t) -> (tDiv s (num 1) === t) +axMod1 = mkAxiom1 "Mod1" $ \(Pair s _) -> (tMod s (num 1) === num 0) + -- XXX: Shouldn't we check that _ is 0? +axExp1L = mkAxiom1 "Exp1L" $ \(Pair s _) -> (num 1 .^. s) === num 1 +axExp0R = mkAxiom1 "Exp0R" $ \(Pair s _) -> (s .^. num 0) === num 1 +axExp1R = mkAxiom1 "Exp1R" $ \(Pair s t) -> (s .^. num 1) === t +axLeqRefl = mkAxiom1 "LeqRefl" $ \(Pair s _) -> (s <== s) === bool True +axCmpNatRefl = mkAxiom1 "CmpNatRefl" + $ \(Pair s _) -> (cmpNat s s) === ordering EQ +axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl" + $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ +axLeq0L = mkAxiom1 "Leq0L" $ \(Pair s _) -> (num 0 <== s) === bool True +axAppendSymbol0R = mkAxiom1 "Concat0R" + $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t +axAppendSymbol0L = mkAxiom1 "Concat0L" + $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t + +-- The list of built-in type family axioms that GHC uses. +-- If you define new axioms, make sure to include them in this list. +-- See Note [Adding built-in type families] +typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule +typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) + [ axAddDef + , axMulDef + , axExpDef + , axLeqDef + , axCmpNatDef + , axCmpSymbolDef + , axAppendSymbolDef + , axAdd0L + , axAdd0R + , axMul0L + , axMul0R + , axMul1L + , axMul1R + , axExp1L + , axExp0R + , axExp1R + , axLeqRefl + , axCmpNatRefl + , axCmpSymbolRefl + , axLeq0L + , axSubDef + , axSub0R + , axAppendSymbol0R + , axAppendSymbol0L + , axDivDef + , axDiv1 + , axModDef + , axMod1 + , axLogDef + ] + + + +{------------------------------------------------------------------------------- +Various utilities for making axioms and types +-------------------------------------------------------------------------------} + +(.+.) :: Type -> Type -> Type +s .+. t = mkTyConApp typeNatAddTyCon [s,t] + +(.-.) :: Type -> Type -> Type +s .-. t = mkTyConApp typeNatSubTyCon [s,t] + +(.*.) :: Type -> Type -> Type +s .*. t = mkTyConApp typeNatMulTyCon [s,t] + +tDiv :: Type -> Type -> Type +tDiv s t = mkTyConApp typeNatDivTyCon [s,t] + +tMod :: Type -> Type -> Type +tMod s t = mkTyConApp typeNatModTyCon [s,t] + +(.^.) :: Type -> Type -> Type +s .^. t = mkTyConApp typeNatExpTyCon [s,t] + +(<==) :: Type -> Type -> Type +s <== t = mkTyConApp typeNatLeqTyCon [s,t] + +cmpNat :: Type -> Type -> Type +cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] + +cmpSymbol :: Type -> Type -> Type +cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t] + +appendSymbol :: Type -> Type -> Type +appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t] + +(===) :: Type -> Type -> Pair Type +x === y = Pair x y + +num :: Integer -> Type +num = mkNumLitTy + +bool :: Bool -> Type +bool b = if b then mkTyConApp promotedTrueDataCon [] + else mkTyConApp promotedFalseDataCon [] + +isBoolLitTy :: Type -> Maybe Bool +isBoolLitTy tc = + do (tc,[]) <- splitTyConApp_maybe tc + case () of + _ | tc == promotedFalseDataCon -> return False + | tc == promotedTrueDataCon -> return True + | otherwise -> Nothing + +orderingKind :: Kind +orderingKind = mkTyConApp orderingTyCon [] + +ordering :: Ordering -> Type +ordering o = + case o of + LT -> mkTyConApp promotedLTDataCon [] + EQ -> mkTyConApp promotedEQDataCon [] + GT -> mkTyConApp promotedGTDataCon [] + +isOrderingLitTy :: Type -> Maybe Ordering +isOrderingLitTy tc = + do (tc1,[]) <- splitTyConApp_maybe tc + case () of + _ | tc1 == promotedLTDataCon -> return LT + | tc1 == promotedEQDataCon -> return EQ + | tc1 == promotedGTDataCon -> return GT + | otherwise -> Nothing + +known :: (Integer -> Bool) -> TcType -> Bool +known p x = case isNumLitTy x of + Just a -> p a + Nothing -> False + + +mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule +mkUnAxiom str tc f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrAsmpRoles = [Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2] <- return cs + s2' <- isNumLitTy s2 + z <- f s2' + return (mkTyConApp tc [s1] === z) + } + + + +-- For the definitional axioms +mkBinAxiom :: String -> TyCon -> + (Integer -> Integer -> Maybe Type) -> CoAxiomRule +mkBinAxiom str tc f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrAsmpRoles = [Nominal, Nominal] + , coaxrRole = Nominal + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + s2' <- isNumLitTy s2 + t2' <- isNumLitTy t2 + z <- f s2' t2' + return (mkTyConApp tc [s1,t1] === z) + } + + + +mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule +mkAxiom1 str f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrAsmpRoles = [Nominal] + , coaxrRole = Nominal + , coaxrProves = \case [eqn] -> Just (f eqn) + _ -> Nothing + } + + +{------------------------------------------------------------------------------- +Evaluation +-------------------------------------------------------------------------------} + +matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamAdd [s,t] + | Just 0 <- mbX = Just (axAdd0L, [t], t) + | Just 0 <- mbY = Just (axAdd0R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axAddDef, [s,t], num (x + y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamAdd _ = Nothing + +matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamSub [s,t] + | Just 0 <- mbY = Just (axSub0R, [s], s) + | Just x <- mbX, Just y <- mbY, Just z <- minus x y = + Just (axSubDef, [s,t], num z) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamSub _ = Nothing + +matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamMul [s,t] + | Just 0 <- mbX = Just (axMul0L, [t], num 0) + | Just 0 <- mbY = Just (axMul0R, [s], num 0) + | Just 1 <- mbX = Just (axMul1L, [t], t) + | Just 1 <- mbY = Just (axMul1R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axMulDef, [s,t], num (x * y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamMul _ = Nothing + +matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamDiv [s,t] + | Just 1 <- mbY = Just (axDiv1, [s], s) + | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamDiv _ = Nothing + +matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamMod [s,t] + | Just 1 <- mbY = Just (axMod1, [s], num 0) + | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamMod _ = Nothing + + + +matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamExp [s,t] + | Just 0 <- mbY = Just (axExp0R, [s], num 1) + | Just 1 <- mbX = Just (axExp1L, [t], num 1) + | Just 1 <- mbY = Just (axExp1R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axExpDef, [s,t], num (x ^ y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamExp _ = Nothing + +matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamLog [s] + | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n) + where mbX = isNumLitTy s +matchFamLog _ = Nothing + + +matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamLeq [s,t] + | Just 0 <- mbX = Just (axLeq0L, [t], bool True) + | Just x <- mbX, Just y <- mbY = + Just (axLeqDef, [s,t], bool (x <= y)) + | tcEqType s t = Just (axLeqRefl, [s], bool True) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamLeq _ = Nothing + +matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamCmpNat [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axCmpNatDef, [s,t], ordering (compare x y)) + | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamCmpNat _ = Nothing + +matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamCmpSymbol [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axCmpSymbolDef, [s,t], ordering (compare x y)) + | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ) + where mbX = isStrLitTy s + mbY = isStrLitTy t +matchFamCmpSymbol _ = Nothing + +matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamAppendSymbol [s,t] + | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t) + | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y)) + where + mbX = isStrLitTy s + mbY = isStrLitTy t +matchFamAppendSymbol _ = Nothing + +{------------------------------------------------------------------------------- +Interact with axioms +-------------------------------------------------------------------------------} + +interactTopAdd :: [Xi] -> Xi -> [Pair Type] +interactTopAdd [s,t] r + | Just 0 <- mbZ = [ s === num 0, t === num 0 ] -- (s + t ~ 0) => (s ~ 0, t ~ 0) + | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y] -- (5 + t ~ 8) => (t ~ 3) + | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x] -- (s + 5 ~ 8) => (s ~ 3) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopAdd _ _ = [] + +{- +Note [Weakened interaction rule for subtraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A simpler interaction here might be: + + `s - t ~ r` --> `t + r ~ s` + +This would enable us to reuse all the code for addition. +Unfortunately, this works a little too well at the moment. +Consider the following example: + + 0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0) + +This (correctly) spots that the constraint cannot be solved. + +However, this may be a problem if the constraint did not +need to be solved in the first place! Consider the following example: + +f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5 +f = id + +Currently, GHC is strict while evaluating functions, so this does not +work, because even though the `If` should evaluate to `5 - 0`, we +also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`, +which fails. + +So, for the time being, we only add an improvement when the RHS is a constant, +which happens to work OK for the moment, although clearly we need to do +something more general. +-} +interactTopSub :: [Xi] -> Xi -> [Pair Type] +interactTopSub [s,t] r + | Just z <- mbZ = [ s === (num z .+. t) ] -- (s - t ~ 5) => (5 + t ~ s) + where + mbZ = isNumLitTy r +interactTopSub _ _ = [] + + + + + +interactTopMul :: [Xi] -> Xi -> [Pair Type] +interactTopMul [s,t] r + | Just 1 <- mbZ = [ s === num 1, t === num 1 ] -- (s * t ~ 1) => (s ~ 1, t ~ 1) + | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y] -- (3 * t ~ 15) => (t ~ 5) + | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x] -- (s * 3 ~ 15) => (s ~ 5) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopMul _ _ = [] + +interactTopDiv :: [Xi] -> Xi -> [Pair Type] +interactTopDiv _ _ = [] -- I can't think of anything... + +interactTopMod :: [Xi] -> Xi -> [Pair Type] +interactTopMod _ _ = [] -- I can't think of anything... + +interactTopExp :: [Xi] -> Xi -> [Pair Type] +interactTopExp [s,t] r + | Just 0 <- mbZ = [ s === num 0 ] -- (s ^ t ~ 0) => (s ~ 0) + | Just x <- mbX, Just z <- mbZ, Just y <- logExact z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3) + | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopExp _ _ = [] + +interactTopLog :: [Xi] -> Xi -> [Pair Type] +interactTopLog _ _ = [] -- I can't think of anything... + + + +interactTopLeq :: [Xi] -> Xi -> [Pair Type] +interactTopLeq [s,t] r + | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0) + where + mbY = isNumLitTy t + mbZ = isBoolLitTy r +interactTopLeq _ _ = [] + +interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] +interactTopCmpNat [s,t] r + | Just EQ <- isOrderingLitTy r = [ s === t ] +interactTopCmpNat _ _ = [] + +interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type] +interactTopCmpSymbol [s,t] r + | Just EQ <- isOrderingLitTy r = [ s === t ] +interactTopCmpSymbol _ _ = [] + +interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type] +interactTopAppendSymbol [s,t] r + -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "") + | Just z <- mbZ, nullFS z = + [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ] + + -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar") + | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z = + [ t === mkStrLitTy (mkFastString $ drop (length x) z) ] + + -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo") + | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z = + [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ] + + where + mbX = isStrLitTy s + mbY = isStrLitTy t + mbZ = isStrLitTy r + +interactTopAppendSymbol _ _ = [] + +{------------------------------------------------------------------------------- +Interaction with inerts +-------------------------------------------------------------------------------} + +interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertAdd [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertAdd _ _ _ _ = [] + +interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertSub [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertSub _ _ _ _ = [] + +interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertMul [x1,y1] z1 [x2,y2] z2 + | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 + +interactInertMul _ _ _ _ = [] + +interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertDiv _ _ _ _ = [] + +interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertMod _ _ _ _ = [] + +interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertExp [x1,y1] z1 [x2,y2] z2 + | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 + +interactInertExp _ _ _ _ = [] + +interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertLog _ _ _ _ = [] + + +interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertLeq [x1,y1] z1 [x2,y2] z2 + | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ] + | bothTrue && tcEqType y1 x2 = [ (x1 <== y2) === bool True ] + | bothTrue && tcEqType y2 x1 = [ (x2 <== y1) === bool True ] + where bothTrue = isJust $ do True <- isBoolLitTy z1 + True <- isBoolLitTy z2 + return () + +interactInertLeq _ _ _ _ = [] + + +interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertAppendSymbol _ _ _ _ = [] + + + +{- ----------------------------------------------------------------------------- +These inverse functions are used for simplifying propositions using +concrete natural numbers. +----------------------------------------------------------------------------- -} + +-- | Subtract two natural numbers. +minus :: Integer -> Integer -> Maybe Integer +minus x y = if x >= y then Just (x - y) else Nothing + +-- | Compute the exact logarithm of a natural number. +-- The logarithm base is the second argument. +logExact :: Integer -> Integer -> Maybe Integer +logExact x y = do (z,True) <- genLog x y + return z + + +-- | Divide two natural numbers. +divide :: Integer -> Integer -> Maybe Integer +divide _ 0 = Nothing +divide x y = case divMod x y of + (a,0) -> Just a + _ -> Nothing + +-- | Compute the exact root of a natural number. +-- The second argument specifies which root we are computing. +rootExact :: Integer -> Integer -> Maybe Integer +rootExact x y = do (z,True) <- genRoot x y + return z + + + +{- | Compute the n-th root of a natural number, rounded down to +the closest natural number. The boolean indicates if the result +is exact (i.e., True means no rounding was done, False means rounded down). +The second argument specifies which root we are computing. -} +genRoot :: Integer -> Integer -> Maybe (Integer, Bool) +genRoot _ 0 = Nothing +genRoot x0 1 = Just (x0, True) +genRoot x0 root = Just (search 0 (x0+1)) + where + search from to = let x = from + div (to - from) 2 + a = x ^ root + in case compare a x0 of + EQ -> (x, True) + LT | x /= from -> search x to + | otherwise -> (from, False) + GT | x /= to -> search from x + | otherwise -> (from, False) + +{- | Compute the logarithm of a number in the given base, rounded down to the +closest integer. The boolean indicates if we the result is exact +(i.e., True means no rounding happened, False means we rounded down). +The logarithm base is the second argument. -} +genLog :: Integer -> Integer -> Maybe (Integer, Bool) +genLog x 0 = if x == 1 then Just (0, True) else Nothing +genLog _ 1 = Nothing +genLog 0 _ = Nothing +genLog x base = Just (exactLoop 0 x) + where + exactLoop s i + | i == 1 = (s,True) + | i < base = (s,False) + | otherwise = + let s1 = s + 1 + in s1 `seq` case divMod i base of + (j,r) + | r == 0 -> exactLoop s1 j + | otherwise -> (underLoop s1 j, False) + + underLoop s i + | i < base = s + | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) diff --git a/GHC/Builtin/Types/Prim.hs b/GHC/Builtin/Types/Prim.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Types/Prim.hs @@ -0,0 +1,1154 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Wired-in knowledge about primitive types +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | This module defines TyCons that can't be expressed in Haskell. +-- They are all, therefore, wired-in TyCons. C.f module "GHC.Builtin.Types" +module GHC.Builtin.Types.Prim( + mkPrimTyConName, -- For implicit parameters in GHC.Builtin.Types only + + mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom, + mkTemplateKiTyVars, mkTemplateKiTyVar, + + mkTemplateTyConBinders, mkTemplateKindTyConBinders, + mkTemplateAnonTyConBinders, + + alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + alphaTys, alphaTy, betaTy, gammaTy, deltaTy, + alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep, + alphaTysUnliftedRep, alphaTyUnliftedRep, + runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, + openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, + + multiplicityTyVar, + + -- Kind constructors... + tYPETyCon, tYPETyConName, + + -- Kinds + tYPE, primRepToRuntimeRep, + + functionWithMultiplicity, + funTyCon, funTyConName, + unexposedPrimTyCons, exposedPrimTyCons, primTyCons, + + charPrimTyCon, charPrimTy, charPrimTyConName, + intPrimTyCon, intPrimTy, intPrimTyConName, + wordPrimTyCon, wordPrimTy, wordPrimTyConName, + addrPrimTyCon, addrPrimTy, addrPrimTyConName, + floatPrimTyCon, floatPrimTy, floatPrimTyConName, + doublePrimTyCon, doublePrimTy, doublePrimTyConName, + + voidPrimTyCon, voidPrimTy, + statePrimTyCon, mkStatePrimTy, + realWorldTyCon, realWorldTy, realWorldStatePrimTy, + + proxyPrimTyCon, mkProxyPrimTy, + + arrayPrimTyCon, mkArrayPrimTy, + byteArrayPrimTyCon, byteArrayPrimTy, + arrayArrayPrimTyCon, mkArrayArrayPrimTy, + smallArrayPrimTyCon, mkSmallArrayPrimTy, + mutableArrayPrimTyCon, mkMutableArrayPrimTy, + mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, + mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy, + smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, + mutVarPrimTyCon, mkMutVarPrimTy, + + mVarPrimTyCon, mkMVarPrimTy, + ioPortPrimTyCon, mkIOPortPrimTy, + tVarPrimTyCon, mkTVarPrimTy, + stablePtrPrimTyCon, mkStablePtrPrimTy, + stableNamePrimTyCon, mkStableNamePrimTy, + compactPrimTyCon, compactPrimTy, + bcoPrimTyCon, bcoPrimTy, + weakPrimTyCon, mkWeakPrimTy, + threadIdPrimTyCon, threadIdPrimTy, + + int8PrimTyCon, int8PrimTy, int8PrimTyConName, + word8PrimTyCon, word8PrimTy, word8PrimTyConName, + + int16PrimTyCon, int16PrimTy, int16PrimTyConName, + word16PrimTyCon, word16PrimTy, word16PrimTyConName, + + int32PrimTyCon, int32PrimTy, int32PrimTyConName, + word32PrimTyCon, word32PrimTy, word32PrimTyConName, + + int64PrimTyCon, int64PrimTy, int64PrimTyConName, + word64PrimTyCon, word64PrimTy, word64PrimTyConName, + + eqPrimTyCon, -- ty1 ~# ty2 + eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) + eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) + equalityTyCon, + + -- * SIMD +#include "primop-vector-tys-exports.hs-incl" + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Builtin.Types + ( runtimeRepTy, unboxedTupleKind, liftedTypeKind + , vecRepDataConTyCon, tupleRepDataConTyCon + , liftedRepDataConTy, unliftedRepDataConTy + , intRepDataConTy + , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy + , wordRepDataConTy + , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy + , addrRepDataConTy + , floatRepDataConTy, doubleRepDataConTy + , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy + , vec64DataConTy + , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy + , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy + , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy + , doubleElemRepDataConTy + , mkPromotedListTy, multiplicityTy ) + +import GHC.Types.Var ( TyVar, mkTyVar ) +import GHC.Types.Name +import GHC.Core.TyCon +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Builtin.Names +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid + -- import loops which show up if you import Type instead + +import Data.Char + +{- +************************************************************************ +* * +\subsection{Primitive type constructors} +* * +************************************************************************ +-} + +primTyCons :: [TyCon] +primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons + +-- | Primitive 'TyCon's that are defined in GHC.Prim but not exposed. +-- It's important to keep these separate as we don't want users to be able to +-- write them (see #15209) or see them in GHCi's @:browse@ output +-- (see #12023). +unexposedPrimTyCons :: [TyCon] +unexposedPrimTyCons + = [ eqPrimTyCon + , eqReprPrimTyCon + , eqPhantPrimTyCon + ] + +-- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim. +exposedPrimTyCons :: [TyCon] +exposedPrimTyCons + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , arrayArrayPrimTyCon + , smallArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , int8PrimTyCon + , int16PrimTyCon + , int32PrimTyCon + , int64PrimTyCon + , bcoPrimTyCon + , weakPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , mutableArrayArrayPrimTyCon + , smallMutableArrayPrimTyCon + , mVarPrimTyCon + , ioPortPrimTyCon + , tVarPrimTyCon + , mutVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , stableNamePrimTyCon + , compactPrimTyCon + , statePrimTyCon + , voidPrimTyCon + , proxyPrimTyCon + , threadIdPrimTyCon + , wordPrimTyCon + , word8PrimTyCon + , word16PrimTyCon + , word32PrimTyCon + , word64PrimTyCon + + , tYPETyCon + +#include "primop-vector-tycons.hs-incl" + ] + +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc fs unique tycon + = mkWiredInName gHC_PRIM (mkTcOccFS fs) + unique + (ATyCon tycon) -- Relevant TyCon + UserSyntax + +mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name +mkBuiltInPrimTc fs unique tycon + = mkWiredInName gHC_PRIM (mkTcOccFS fs) + unique + (ATyCon tycon) -- Relevant TyCon + BuiltInSyntax + + +charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name +charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon +int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon +int16PrimTyConName = mkPrimTc (fsLit "Int16#") int16PrimTyConKey int16PrimTyCon +int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon +word8PrimTyConName = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon +word16PrimTyConName = mkPrimTc (fsLit "Word16#") word16PrimTyConKey word16PrimTyCon +word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon +voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon +proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon +eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon +eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon +eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon +realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon +smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon +smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +ioPortPrimTyConName = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon +mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon +tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon +compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon +bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon +weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon +threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon + +{- +************************************************************************ +* * +\subsection{Support code} +* * +************************************************************************ + +alphaTyVars is a list of type variables for use in templates: + ["a", "b", ..., "z", "t1", "t2", ... ] +-} + +mkTemplateKindVar :: Kind -> TyVar +mkTemplateKindVar = mkTyVar (mk_tv_name 0 "k") + +mkTemplateKindVars :: [Kind] -> [TyVar] +-- k0 with unique (mkAlphaTyVarUnique 0) +-- k1 with unique (mkAlphaTyVarUnique 1) +-- ... etc +mkTemplateKindVars [kind] = [mkTemplateKindVar kind] + -- Special case for one kind: just "k" +mkTemplateKindVars kinds + = [ mkTyVar (mk_tv_name u ('k' : show u)) kind + | (kind, u) <- kinds `zip` [0..] ] +mk_tv_name :: Int -> String -> Name +mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u) + (mkTyVarOccFS (mkFastString s)) + noSrcSpan + +mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] +-- a with unique (mkAlphaTyVarUnique n) +-- b with unique (mkAlphaTyVarUnique n+1) +-- ... etc +-- Typically called as +-- mkTemplateTyVarsFrom (length kv_bndrs) kinds +-- where kv_bndrs are the kind-level binders of a TyCon +mkTemplateTyVarsFrom n kinds + = [ mkTyVar name kind + | (kind, index) <- zip kinds [0..], + let ch_ord = index + ord 'a' + name_str | ch_ord <= ord 'z' = [chr ch_ord] + | otherwise = 't':show index + name = mk_tv_name (index + n) name_str + ] + +mkTemplateTyVars :: [Kind] -> [TyVar] +mkTemplateTyVars = mkTemplateTyVarsFrom 1 + +mkTemplateTyConBinders + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds + -> [TyConBinder] +mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindTyConBinders kind_var_kinds + anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs)) + tv_bndrs = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds + +mkTemplateKiTyVars + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds [ak1, .., akm] + -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] +-- Example: if you want the tyvars for +-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah +-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *]) +mkTemplateKiTyVars kind_var_kinds mk_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindVars kind_var_kinds + anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs) + tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds + +mkTemplateKiTyVar + :: Kind -- [k1, .., kn] Kind of kind-forall'd var + -> (Kind -> [Kind]) -- Arg is kv1:k1 + -- Result is anon arg kinds [ak1, .., akm] + -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] +-- Example: if you want the tyvars for +-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah +-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *]) +mkTemplateKiTyVar kind mk_arg_kinds + = kv_bndr : tv_bndrs + where + kv_bndr = mkTemplateKindVar kind + anon_kinds = mk_arg_kinds (mkTyVarTy kv_bndr) + tv_bndrs = mkTemplateTyVarsFrom 1 anon_kinds + +mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] +-- Makes named, Specified binders +mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] + +mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] +mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds) + +mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] +mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds) + +alphaTyVars :: [TyVar] +alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind + +alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar +(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars + +alphaTys :: [Type] +alphaTys = mkTyVarTys alphaTyVars +alphaTy, betaTy, gammaTy, deltaTy :: Type +(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys + +alphaTyVarsUnliftedRep :: [TyVar] +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepDataConTy) + +alphaTyVarUnliftedRep :: TyVar +(alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep + +alphaTysUnliftedRep :: [Type] +alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep +alphaTyUnliftedRep :: Type +(alphaTyUnliftedRep:_) = alphaTysUnliftedRep + +runtimeRep1TyVar, runtimeRep2TyVar :: TyVar +(runtimeRep1TyVar : runtimeRep2TyVar : _) + = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' + +runtimeRep1Ty, runtimeRep2Ty :: Type +runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar +runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar + +openAlphaTyVar, openBetaTyVar :: TyVar +-- alpha :: TYPE r1 +-- beta :: TYPE r2 +[openAlphaTyVar,openBetaTyVar] + = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] + +openAlphaTy, openBetaTy :: Type +openAlphaTy = mkTyVarTy openAlphaTyVar +openBetaTy = mkTyVarTy openBetaTyVar + +multiplicityTyVar :: TyVar +multiplicityTyVar = mkTemplateTyVars (repeat multiplicityTy) !! 13 -- selects 'n' + +{- +************************************************************************ +* * + FunTyCon +* * +************************************************************************ +-} + +funTyConName :: Name +funTyConName = mkPrimTyConName (fsLit "FUN") funTyConKey funTyCon + +-- | The @FUN@ type constructor. +-- +-- @ +-- FUN :: forall {m :: Multiplicity} {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- TYPE rep1 -> TYPE rep2 -> * +-- @ +-- +-- The runtime representations quantification is left inferred. This +-- means they cannot be specified with @-XTypeApplications@. +-- +-- This is a deliberate choice to allow future extensions to the +-- function arrow. To allow visible application a type synonym can be +-- defined: +-- +-- @ +-- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). +-- TYPE rep1 -> TYPE rep2 -> Type +-- type Arr = FUN +-- @ +-- +funTyCon :: TyCon +funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar + , mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty + , tYPE runtimeRep2Ty + ] + tc_rep_nm = mkPrelTyConRepName funTyConName + +{- +************************************************************************ +* * + Kinds +* * +************************************************************************ + +Note [TYPE and RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +All types that classify values have a kind of the form (TYPE rr), where + + data RuntimeRep -- Defined in ghc-prim:GHC.Types + = LiftedRep + | UnliftedRep + | IntRep + | FloatRep + .. etc .. + + rr :: RuntimeRep + + TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in + +So for example: + Int :: TYPE 'LiftedRep + Array# Int :: TYPE 'UnliftedRep + Int# :: TYPE 'IntRep + Float# :: TYPE 'FloatRep + Maybe :: TYPE 'LiftedRep -> TYPE 'LiftedRep + (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) + +We abbreviate '*' specially: + type * = TYPE 'LiftedRep + +The 'rr' parameter tells us how the value is represented at runtime. + +Generally speaking, you can't be polymorphic in 'rr'. E.g + f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a] + f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ... +This is no good: we could not generate code for 'f', because the +calling convention for 'f' varies depending on whether the argument is +a a Int, Int#, or Float#. (You could imagine generating specialised +code, one for each instantiation of 'rr', but we don't do that.) + +Certain functions CAN be runtime-rep-polymorphic, because the code +generator never has to manipulate a value of type 'a :: TYPE rr'. + +* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a + Code generator never has to manipulate the return value. + +* unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair: + Always inlined to be a no-op + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b + +* Unboxed tuples, and unboxed sums, defined in GHC.Builtin.Types + Always inlined, and hence specialised to the call site + (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> TYPE ('TupleRep '[r1, r2]) + +Note [PrimRep and kindPrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As part of its source code, in GHC.Core.TyCon, GHC has + data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc... + +Notice that + * RuntimeRep is part of the syntax tree of the program being compiled + (defined in a library: ghc-prim:GHC.Types) + * PrimRep is part of GHC's source code. + (defined in GHC.Core.TyCon) + +We need to get from one to the other; that is what kindPrimRep does. +Suppose we have a value + (v :: t) where (t :: k) +Given this kind + k = TyConApp "TYPE" [rep] +GHC needs to be able to figure out how 'v' is represented at runtime. +It expects 'rep' to be form + TyConApp rr_dc args +where 'rr_dc' is a promoteed data constructor from RuntimeRep. So +now we need to go from 'dc' to the corresponding PrimRep. We store this +PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo. + +-} + +tYPETyCon :: TyCon +tYPETyConName :: Name + +tYPETyCon = mkKindTyCon tYPETyConName + (mkTemplateAnonTyConBinders [runtimeRepTy]) + liftedTypeKind + [Nominal] + (mkPrelTyConRepName tYPETyConName) + +-------------------------- +-- ... and now their names + +-- If you edit these, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon + +mkPrimTyConName :: FastString -> Unique -> TyCon -> Name +mkPrimTyConName = mkPrimTcName BuiltInSyntax + -- All of the super kinds and kinds are defined in Prim, + -- and use BuiltInSyntax, because they are never in scope in the source + +mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name +mkPrimTcName built_in_syntax occ key tycon + = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax + +----------------------------- +-- | Given a RuntimeRep, applies TYPE to it. +-- see Note [TYPE and RuntimeRep] +tYPE :: Type -> Type +tYPE rr = TyConApp tYPETyCon [rr] + +-- Given a Multiplicity, applies FUN to it. +functionWithMultiplicity :: Type -> Type +functionWithMultiplicity mul = TyConApp funTyCon [mul] + +{- +************************************************************************ +* * + Basic primitive types (@Char#@, @Int#@, etc.) +* * +************************************************************************ +-} + +-- only used herein +pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon +pcPrimTyCon name roles rep + = mkPrimTyCon name binders result_kind roles + where + binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) + result_kind = tYPE (primRepToRuntimeRep rep) + +-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep +-- Defined here to avoid (more) module loops +primRepToRuntimeRep :: PrimRep -> Type +primRepToRuntimeRep rep = case rep of + VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] + LiftedRep -> liftedRepDataConTy + UnliftedRep -> unliftedRepDataConTy + IntRep -> intRepDataConTy + Int8Rep -> int8RepDataConTy + Int16Rep -> int16RepDataConTy + Int32Rep -> int32RepDataConTy + Int64Rep -> int64RepDataConTy + WordRep -> wordRepDataConTy + Word8Rep -> word8RepDataConTy + Word16Rep -> word16RepDataConTy + Word32Rep -> word32RepDataConTy + Word64Rep -> word64RepDataConTy + AddrRep -> addrRepDataConTy + FloatRep -> floatRepDataConTy + DoubleRep -> doubleRepDataConTy + VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] + where + n' = case n of + 2 -> vec2DataConTy + 4 -> vec4DataConTy + 8 -> vec8DataConTy + 16 -> vec16DataConTy + 32 -> vec32DataConTy + 64 -> vec64DataConTy + _ -> pprPanic "Disallowed VecCount" (ppr n) + + elem' = case elem of + Int8ElemRep -> int8ElemRepDataConTy + Int16ElemRep -> int16ElemRepDataConTy + Int32ElemRep -> int32ElemRepDataConTy + Int64ElemRep -> int64ElemRepDataConTy + Word8ElemRep -> word8ElemRepDataConTy + Word16ElemRep -> word16ElemRepDataConTy + Word32ElemRep -> word32ElemRepDataConTy + Word64ElemRep -> word64ElemRepDataConTy + FloatElemRep -> floatElemRepDataConTy + DoubleElemRep -> doubleElemRepDataConTy + +pcPrimTyCon0 :: Name -> PrimRep -> TyCon +pcPrimTyCon0 name rep + = pcPrimTyCon name [] rep + +charPrimTy :: Type +charPrimTy = mkTyConTy charPrimTyCon +charPrimTyCon :: TyCon +charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep + +intPrimTy :: Type +intPrimTy = mkTyConTy intPrimTyCon +intPrimTyCon :: TyCon +intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep + +int8PrimTy :: Type +int8PrimTy = mkTyConTy int8PrimTyCon +int8PrimTyCon :: TyCon +int8PrimTyCon = pcPrimTyCon0 int8PrimTyConName Int8Rep + +int16PrimTy :: Type +int16PrimTy = mkTyConTy int16PrimTyCon +int16PrimTyCon :: TyCon +int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName Int16Rep + +int32PrimTy :: Type +int32PrimTy = mkTyConTy int32PrimTyCon +int32PrimTyCon :: TyCon +int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName Int32Rep + +int64PrimTy :: Type +int64PrimTy = mkTyConTy int64PrimTyCon +int64PrimTyCon :: TyCon +int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep + +wordPrimTy :: Type +wordPrimTy = mkTyConTy wordPrimTyCon +wordPrimTyCon :: TyCon +wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep + +word8PrimTy :: Type +word8PrimTy = mkTyConTy word8PrimTyCon +word8PrimTyCon :: TyCon +word8PrimTyCon = pcPrimTyCon0 word8PrimTyConName Word8Rep + +word16PrimTy :: Type +word16PrimTy = mkTyConTy word16PrimTyCon +word16PrimTyCon :: TyCon +word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName Word16Rep + +word32PrimTy :: Type +word32PrimTy = mkTyConTy word32PrimTyCon +word32PrimTyCon :: TyCon +word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep + +word64PrimTy :: Type +word64PrimTy = mkTyConTy word64PrimTyCon +word64PrimTyCon :: TyCon +word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep + +addrPrimTy :: Type +addrPrimTy = mkTyConTy addrPrimTyCon +addrPrimTyCon :: TyCon +addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep + +floatPrimTy :: Type +floatPrimTy = mkTyConTy floatPrimTyCon +floatPrimTyCon :: TyCon +floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep + +doublePrimTy :: Type +doublePrimTy = mkTyConTy doublePrimTyCon +doublePrimTyCon :: TyCon +doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep + +{- +************************************************************************ +* * + The @State#@ type (and @_RealWorld@ types) +* * +************************************************************************ + +Note [The equality types story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC sports a veritable menagerie of equality types: + + Type or Lifted? Hetero? Role Built in Defining module + class? L/U TyCon +----------------------------------------------------------------------------------------- +~# T U hetero nominal eqPrimTyCon GHC.Prim +~~ C L hetero nominal heqTyCon GHC.Types +~ C L homo nominal eqTyCon GHC.Types +:~: T L homo nominal (not built-in) Data.Type.Equality +:~~: T L hetero nominal (not built-in) Data.Type.Equality + +~R# T U hetero repr eqReprPrimTy GHC.Prim +Coercible C L homo repr coercibleTyCon GHC.Types +Coercion T L homo repr (not built-in) Data.Type.Coercion +~P# T U hetero phantom eqPhantPrimTyCon GHC.Prim + +Recall that "hetero" means the equality can related types of different +kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2) +also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2). + +To produce less confusion for end users, when not dumping and without +-fprint-equality-relations, each of these groups is printed as the bottommost +listed equality. That is, (~#) and (~~) are both rendered as (~) in +error messages, and (~R#) is rendered as Coercible. + +Let's take these one at a time: + + -------------------------- + (~#) :: forall k1 k2. k1 -> k2 -> # + -------------------------- +This is The Type Of Equality in GHC. It classifies nominal coercions. +This type is used in the solver for recording equality constraints. +It responds "yes" to Type.isEqPrimPred and classifies as an EqPred in +Type.classifyPredType. + +All wanted constraints of this type are built with coercion holes. +(See Note [Coercion holes] in GHC.Core.TyCo.Rep.) But see also +Note [Deferred errors for coercion holes] in GHC.Tc.Errors to see how +equality constraints are deferred. + +Within GHC, ~# is called eqPrimTyCon, and it is defined in GHC.Builtin.Types.Prim. + + + -------------------------- + (~~) :: forall k1 k2. k1 -> k2 -> Constraint + -------------------------- +This is (almost) an ordinary class, defined as if by + class a ~# b => a ~~ b + instance a ~# b => a ~~ b +Here's what's unusual about it: + + * We can't actually declare it that way because we don't have syntax for ~#. + And ~# isn't a constraint, so even if we could write it, it wouldn't kind + check. + + * Users cannot write instances of it. + + * It is "naturally coherent". This means that the solver won't hesitate to + solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the + context. (Normally, it waits to learn more, just in case the given + influences what happens next.) See Note [Naturally coherent classes] + in GHC.Tc.Solver.Interact. + + * It always terminates. That is, in the UndecidableInstances checks, we + don't worry if a (~~) constraint is too big, as we know that solving + equality terminates. + +On the other hand, this behaves just like any class w.r.t. eager superclass +unpacking in the solver. So a lifted equality given quickly becomes an unlifted +equality given. This is good, because the solver knows all about unlifted +equalities. There is some special-casing in GHC.Tc.Solver.Interact.matchClassInst to +pretend that there is an instance of this class, as we can't write the instance +in Haskell. + +Within GHC, ~~ is called heqTyCon, and it is defined in GHC.Builtin.Types. + + + -------------------------- + (~) :: forall k. k -> k -> Constraint + -------------------------- +This is /exactly/ like (~~), except with a homogeneous kind. +It is an almost-ordinary class defined as if by + class a ~# b => (a :: k) ~ (b :: k) + instance a ~# b => a ~ b + + * All the bullets for (~~) apply + + * In addition (~) is magical syntax, as ~ is a reserved symbol. + It cannot be exported or imported. + +Within GHC, ~ is called eqTyCon, and it is defined in GHC.Builtin.Types. + +Historical note: prior to July 18 (~) was defined as a + more-ordinary class with (~~) as a superclass. But that made it + special in different ways; and the extra superclass selections to + get from (~) to (~#) via (~~) were tiresome. Now it's defined + uniformly with (~~) and Coercible; much nicer.) + + + -------------------------- + (:~:) :: forall k. k -> k -> * + (:~~:) :: forall k1 k2. k1 -> k2 -> * + -------------------------- +These are perfectly ordinary GADTs, wrapping (~) and (~~) resp. +They are not defined within GHC at all. + + + -------------------------- + (~R#) :: forall k1 k2. k1 -> k2 -> # + -------------------------- +The is the representational analogue of ~#. This is the type of representational +equalities that the solver works on. All wanted constraints of this type are +built with coercion holes. + +Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in GHC.Builtin.Types.Prim. + + + -------------------------- + Coercible :: forall k. k -> k -> Constraint + -------------------------- +This is quite like (~~) in the way it's defined and treated within GHC, but +it's homogeneous. Homogeneity helps with type inference (as GHC can solve one +kind from the other) and, in my (Richard's) estimation, will be more intuitive +for users. + +An alternative design included HCoercible (like (~~)) and Coercible (like (~)). +One annoyance was that we want `coerce :: Coercible a b => a -> b`, and +we need the type of coerce to be fully wired-in. So the HCoercible/Coercible +split required that both types be fully wired-in. Instead of doing this, +I just got rid of HCoercible, as I'm not sure who would use it, anyway. + +Within GHC, Coercible is called coercibleTyCon, and it is defined in +GHC.Builtin.Types. + + + -------------------------- + Coercion :: forall k. k -> k -> * + -------------------------- +This is a perfectly ordinary GADT, wrapping Coercible. It is not defined +within GHC at all. + + + -------------------------- + (~P#) :: forall k1 k2. k1 -> k2 -> # + -------------------------- +This is the phantom analogue of ~# and it is barely used at all. +(The solver has no idea about this one.) Here is the motivation: + + data Phant a = MkPhant + type role Phant phantom + + Phant _P :: Phant Int ~P# Phant Bool + +We just need to have something to put on that last line. You probably +don't need to worry about it. + + + +Note [The State# TyCon] +~~~~~~~~~~~~~~~~~~~~~~~ +State# is the primitive, unlifted type of states. It has one type parameter, +thus + State# RealWorld +or + State# s + +where s is a type variable. The only purpose of the type parameter is to +keep different state threads separate. It is represented by nothing at all. + +The type parameter to State# is intended to keep separate threads separate. +Even though this parameter is not used in the definition of State#, it is +given role Nominal to enforce its intended use. +-} + +mkStatePrimTy :: Type -> Type +mkStatePrimTy ty = TyConApp statePrimTyCon [ty] + +statePrimTyCon :: TyCon -- See Note [The State# TyCon] +statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep + +{- +RealWorld is deeply magical. It is *primitive*, but it is not +*unlifted* (hence ptrArg). We never manipulate values of type +RealWorld; it's only used in the type system, to parameterise State#. +-} + +realWorldTyCon :: TyCon +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind [] +realWorldTy :: Type +realWorldTy = mkTyConTy realWorldTyCon +realWorldStatePrimTy :: Type +realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld + +-- Note: the ``state-pairing'' types are not truly primitive, +-- so they are defined in \tr{GHC.Builtin.Types}, not here. + + +voidPrimTy :: Type +voidPrimTy = TyConApp voidPrimTyCon [] + +voidPrimTyCon :: TyCon +voidPrimTyCon = pcPrimTyCon voidPrimTyConName [] VoidRep + +mkProxyPrimTy :: Type -> Type -> Type +mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] + +proxyPrimTyCon :: TyCon +proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom] + where + -- Kind: forall k. k -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind] id + res_kind = unboxedTupleKind [] + + +{- ********************************************************************* +* * + Primitive equality constraints + See Note [The equality types story] +* * +********************************************************************* -} + +eqPrimTyCon :: TyCon -- The representation type for equality predicates + -- See Note [The equality types story] +eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = unboxedTupleKind [] + roles = [Nominal, Nominal, Nominal, Nominal] + +-- like eqPrimTyCon, but the type for *Representational* coercions +-- this should only ever appear as the type of a covar. Its role is +-- interpreted in coercionRole +eqReprPrimTyCon :: TyCon -- See Note [The equality types story] +eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = unboxedTupleKind [] + roles = [Nominal, Nominal, Representational, Representational] + +-- like eqPrimTyCon, but the type for *Phantom* coercions. +-- This is only used to make higher-order equalities. Nothing +-- should ever actually have this type! +eqPhantPrimTyCon :: TyCon +eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = unboxedTupleKind [] + roles = [Nominal, Nominal, Phantom, Phantom] + +-- | Given a Role, what TyCon is the type of equality predicates at that role? +equalityTyCon :: Role -> TyCon +equalityTyCon Nominal = eqPrimTyCon +equalityTyCon Representational = eqReprPrimTyCon +equalityTyCon Phantom = eqPhantPrimTyCon + +{- ********************************************************************* +* * + The primitive array types +* * +********************************************************************* -} + +arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, + byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, + smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] UnliftedRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] UnliftedRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName UnliftedRep +arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName UnliftedRep +mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep +smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] UnliftedRep +smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep + +mkArrayPrimTy :: Type -> Type +mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] +byteArrayPrimTy :: Type +byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon +mkArrayArrayPrimTy :: Type +mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon +mkSmallArrayPrimTy :: Type -> Type +mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt] +mkMutableArrayPrimTy :: Type -> Type -> Type +mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] +mkMutableByteArrayPrimTy :: Type -> Type +mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] +mkMutableArrayArrayPrimTy :: Type -> Type +mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] +mkSmallMutableArrayPrimTy :: Type -> Type -> Type +mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] + + +{- ********************************************************************* +* * + The mutable variable type +* * +********************************************************************* -} + +mutVarPrimTyCon :: TyCon +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep + +mkMutVarPrimTy :: Type -> Type -> Type +mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-io-port-var]{The synchronizing I/O Port type} +* * +************************************************************************ +-} + +ioPortPrimTyCon :: TyCon +ioPortPrimTyCon = pcPrimTyCon ioPortPrimTyConName [Nominal, Representational] UnliftedRep + +mkIOPortPrimTy :: Type -> Type -> Type +mkIOPortPrimTy s elt = TyConApp ioPortPrimTyCon [s, elt] + +{- +************************************************************************ +* * + The synchronizing variable type +\subsection[TysPrim-synch-var]{The synchronizing variable type} +* * +************************************************************************ +-} + +mVarPrimTyCon :: TyCon +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep + +mkMVarPrimTy :: Type -> Type -> Type +mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * + The transactional variable type +* * +************************************************************************ +-} + +tVarPrimTyCon :: TyCon +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep + +mkTVarPrimTy :: Type -> Type -> Type +mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * + The stable-pointer type +* * +************************************************************************ +-} + +stablePtrPrimTyCon :: TyCon +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep + +mkStablePtrPrimTy :: Type -> Type +mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] + +{- +************************************************************************ +* * + The stable-name type +* * +************************************************************************ +-} + +stableNamePrimTyCon :: TyCon +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Phantom] UnliftedRep + +mkStableNamePrimTy :: Type -> Type +mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] + +{- +************************************************************************ +* * + The Compact NFData (CNF) type +* * +************************************************************************ +-} + +compactPrimTyCon :: TyCon +compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep + +compactPrimTy :: Type +compactPrimTy = mkTyConTy compactPrimTyCon + +{- +************************************************************************ +* * + The ``bytecode object'' type +* * +************************************************************************ +-} + +-- Unlike most other primitive types, BCO is lifted. This is because in +-- general a BCO may be a thunk for the reasons given in Note [Updatable CAF +-- BCOs] in GHCi.CreateBCO. +bcoPrimTy :: Type +bcoPrimTy = mkTyConTy bcoPrimTyCon +bcoPrimTyCon :: TyCon +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep + +{- +************************************************************************ +* * + The ``weak pointer'' type +* * +************************************************************************ +-} + +weakPrimTyCon :: TyCon +weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep + +mkWeakPrimTy :: Type -> Type +mkWeakPrimTy v = TyConApp weakPrimTyCon [v] + +{- +************************************************************************ +* * + The ``thread id'' type +* * +************************************************************************ + +A thread id is represented by a pointer to the TSO itself, to ensure +that they are always unique and we can always find the TSO for a given +thread id. However, this has the unfortunate consequence that a +ThreadId# for a given thread is treated as a root by the garbage +collector and can keep TSOs around for too long. + +Hence the programmer API for thread manipulation uses a weak pointer +to the thread id internally. +-} + +threadIdPrimTy :: Type +threadIdPrimTy = mkTyConTy threadIdPrimTyCon +threadIdPrimTyCon :: TyCon +threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep + +{- +************************************************************************ +* * +\subsection{SIMD vector types} +* * +************************************************************************ +-} + +#include "primop-vector-tys.hs-incl" diff --git a/GHC/Builtin/Uniques.hs b/GHC/Builtin/Uniques.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Uniques.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP #-} + +-- | This is where we define a mapping from Uniques to their associated +-- known-key Names for things associated with tuples and sums. We use this +-- mapping while deserializing known-key Names in interface file symbol tables, +-- which are encoded as their Unique. See Note [Symbol table representation of +-- names] for details. +-- + +module GHC.Builtin.Uniques + ( -- * Looking up known-key names + knownUniqueName + + -- * Getting the 'Unique's of 'Name's + -- ** Anonymous sums + , mkSumTyConUnique + , mkSumDataConUnique + -- ** Tuples + -- *** Vanilla + , mkTupleTyConUnique + , mkTupleDataConUnique + -- *** Constraint + , mkCTupleTyConUnique + , mkCTupleDataConUnique + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Types +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Utils.Misc + +import Data.Bits +import Data.Maybe + +-- | Get the 'Name' associated with a known-key 'Unique'. +knownUniqueName :: Unique -> Maybe Name +knownUniqueName u = + case tag of + 'z' -> Just $ getUnboxedSumName n + '4' -> Just $ getTupleTyConName Boxed n + '5' -> Just $ getTupleTyConName Unboxed n + '7' -> Just $ getTupleDataConName Boxed n + '8' -> Just $ getTupleDataConName Unboxed n + 'k' -> Just $ getCTupleTyConName n + 'm' -> Just $ getCTupleDataConUnique n + _ -> Nothing + where + (tag, n) = unpkUnique u + +-------------------------------------------------- +-- Anonymous sums +-- +-- Sum arities start from 2. The encoding is a bit funny: we break up the +-- integral part into bitfields for the arity, an alternative index (which is +-- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a +-- tag (used to identify the sum's TypeRep binding). +-- +-- This layout is chosen to remain compatible with the usual unique allocation +-- for wired-in data constructors described in GHC.Types.Unique +-- +-- TyCon for sum of arity k: +-- 00000000 kkkkkkkk 11111100 + +-- TypeRep of TyCon for sum of arity k: +-- 00000000 kkkkkkkk 11111101 +-- +-- DataCon for sum of arity k and alternative n (zero-based): +-- 00000000 kkkkkkkk nnnnnn00 +-- +-- TypeRep for sum DataCon of arity k and alternative n (zero-based): +-- 00000000 kkkkkkkk nnnnnn10 + +mkSumTyConUnique :: Arity -> Unique +mkSumTyConUnique arity = + ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the + -- alternative + mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) + +mkSumDataConUnique :: ConTagZ -> Arity -> Unique +mkSumDataConUnique alt arity + | alt >= arity + = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) + | otherwise + = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} + +getUnboxedSumName :: Int -> Name +getUnboxedSumName n + | n .&. 0xfc == 0xfc + = case tag of + 0x0 -> tyConName $ sumTyCon arity + 0x1 -> getRep $ sumTyCon arity + _ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag) + | tag == 0x0 + = dataConName $ sumDataCon (alt + 1) arity + | tag == 0x1 + = getName $ dataConWrapId $ sumDataCon (alt + 1) arity + | tag == 0x2 + = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity + | otherwise + = pprPanic "getUnboxedSumName" (ppr n) + where + arity = n `shiftR` 8 + alt = (n .&. 0xfc) `shiftR` 2 + tag = 0x3 .&. n + getRep tycon = + fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon)) + $ tyConRepName_maybe tycon + +-- Note [Uniques for tuple type and data constructors] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +-- +-- Wired-in tuple data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon + +-------------------------------------------------- +-- Constraint tuples + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleTyConUnique a = mkUnique 'k' (2*a) + +mkCTupleDataConUnique :: Arity -> Unique +mkCTupleDataConUnique a = mkUnique 'm' (3*a) + +getCTupleTyConName :: Int -> Name +getCTupleTyConName n = + case n `divMod` 2 of + (arity, 0) -> cTupleTyConName arity + (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity + _ -> panic "getCTupleTyConName: impossible" + +getCTupleDataConUnique :: Int -> Name +getCTupleDataConUnique n = + case n `divMod` 3 of + (arity, 0) -> cTupleDataConName arity + (_arity, 1) -> panic "getCTupleDataConName: no worker" + (arity, 2) -> mkPrelTyConRepName $ cTupleDataConName arity + _ -> panic "getCTupleDataConName: impossible" + +-------------------------------------------------- +-- Normal tuples + +mkTupleDataConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- may be used in C labels +mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) +mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) + +getTupleTyConName :: Boxity -> Int -> Name +getTupleTyConName boxity n = + case n `divMod` 2 of + (arity, 0) -> tyConName $ tupleTyCon boxity arity + (arity, 1) -> fromMaybe (panic "getTupleTyConName") + $ tyConRepName_maybe $ tupleTyCon boxity arity + _ -> panic "getTupleTyConName: impossible" + +getTupleDataConName :: Boxity -> Int -> Name +getTupleDataConName boxity n = + case n `divMod` 3 of + (arity, 0) -> dataConName $ tupleDataCon boxity arity + (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity + (arity, 2) -> fromMaybe (panic "getTupleDataCon") + $ tyConRepName_maybe $ promotedTupleDataCon boxity arity + _ -> panic "getTupleDataConName: impossible" diff --git a/GHC/Builtin/Uniques.hs-boot b/GHC/Builtin/Uniques.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Uniques.hs-boot @@ -0,0 +1,18 @@ +module GHC.Builtin.Uniques where + +import GHC.Prelude +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Types.Basic + +-- Needed by GHC.Builtin.Types +knownUniqueName :: Unique -> Maybe Name + +mkSumTyConUnique :: Arity -> Unique +mkSumDataConUnique :: ConTagZ -> Arity -> Unique + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleDataConUnique :: Arity -> Unique + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique :: Boxity -> Arity -> Unique diff --git a/GHC/Builtin/Utils.hs b/GHC/Builtin/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Builtin/Utils.hs @@ -0,0 +1,310 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} + +-- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge. +-- +-- This module serves as the central gathering point for names which the +-- compiler knows something about. This includes functions for, +-- +-- * discerning whether a 'Name' is known-key +-- +-- * given a 'Unique', looking up its corresponding known-key 'Name' +-- +-- See Note [Known-key names] and Note [About wired-in things] for information +-- about the two types of prelude things in GHC. +-- +module GHC.Builtin.Utils ( + -- * Known-key names + isKnownKeyName, + lookupKnownKeyName, + lookupKnownNameInfo, + + -- ** Internal use + -- | 'knownKeyNames' is exported to seed the original name cache only; + -- if you find yourself wanting to look at it you might consider using + -- 'lookupKnownKeyName' or 'isKnownKeyName'. + knownKeyNames, + + -- * Miscellaneous + wiredInIds, ghcPrimIds, + primOpRules, builtinRules, + + ghcPrimExports, + ghcPrimDeclDocs, + primOpId, + + -- * Random other things + maybeCharLikeCon, maybeIntLikeCon, + + -- * Class categories + isNumericClass, isStandardClass + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Uniques +import GHC.Types.Unique ( isValidKnownKeyUnique ) + +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Builtin.Names.TH ( templateHaskellNames ) +import GHC.Builtin.Names +import GHC.Core.Opt.ConstantFold +import GHC.Types.Avail +import GHC.Builtin.PrimOps +import GHC.Core.DataCon +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make +import GHC.Utils.Outputable +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Driver.Types +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Types.Unique.FM +import GHC.Utils.Misc as Utils +import GHC.Builtin.Types.Literals ( typeNatTyCons ) +import GHC.Hs.Doc + +import Control.Applicative ((<|>)) +import Data.List ( intercalate , find ) +import Data.Array +import Data.Maybe +import qualified Data.Map as Map + +{- +************************************************************************ +* * +\subsection[builtinNameInfo]{Lookup built-in names} +* * +************************************************************************ + +Note [About wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Wired-in things are Ids\/TyCons that are completely known to the compiler. + They are global values in GHC, (e.g. listTyCon :: TyCon). + +* A wired-in Name contains the thing itself inside the Name: + see Name.wiredInNameTyThing_maybe + (E.g. listTyConName contains listTyCon. + +* The name cache is initialised with (the names of) all wired-in things + (except tuples and sums; see Note [Infinite families of known-key names]) + +* The type environment itself contains no wired in things. The type + checker sees if the Name is wired in before looking up the name in + the type environment. + +* GHC.Iface.Make prunes out wired-in things before putting them in an interface file. + So interface files never contain wired-in things. +-} + + +-- | This list is used to ensure that when you say "Prelude.map" in your source +-- code, or in an interface file, you get a Name with the correct known key (See +-- Note [Known-key names] in "GHC.Builtin.Names") +knownKeyNames :: [Name] +knownKeyNames + | debugIsOn + , Just badNamesStr <- knownKeyNamesOkay all_names + = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) + -- NB: We can't use ppr here, because this is sometimes evaluated in a + -- context where there are no DynFlags available, leading to a cryptic + -- "<
>" error. (This seems to happen only in the + -- stage 2 compiler, for reasons I [Richard] have no clue of.) + | otherwise + = all_names + where + all_names = + -- We exclude most tuples from this list—see + -- Note [Infinite families of known-key names] in GHC.Builtin.Names. + -- We make an exception for Solo (i.e., the boxed 1-tuple), since it does + -- not use special syntax like other tuples. + -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) + -- in GHC.Builtin.Types. + tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 : + concat [ wired_tycon_kk_names funTyCon + , concatMap wired_tycon_kk_names primTyCons + , concatMap wired_tycon_kk_names wiredInTyCons + , concatMap wired_tycon_kk_names typeNatTyCons + , map idName wiredInIds + , map (idName . primOpId) allThePrimOps + , map (idName . primOpWrapperId) allThePrimOps + , basicKnownKeyNames + , templateHaskellNames + ] + -- All of the names associated with a wired-in TyCon. + -- This includes the TyCon itself, its DataCons and promoted TyCons. + wired_tycon_kk_names :: TyCon -> [Name] + wired_tycon_kk_names tc = + tyConName tc : (rep_names tc ++ implicits) + where implicits = concatMap thing_kk_names (implicitTyConThings tc) + + wired_datacon_kk_names :: DataCon -> [Name] + wired_datacon_kk_names dc = + dataConName dc : rep_names (promoteDataCon dc) + + thing_kk_names :: TyThing -> [Name] + thing_kk_names (ATyCon tc) = wired_tycon_kk_names tc + thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc + thing_kk_names thing = [getName thing] + + -- The TyConRepName for a known-key TyCon has a known key, + -- but isn't itself an implicit thing. Yurgh. + -- NB: if any of the wired-in TyCons had record fields, the record + -- field names would be in a similar situation. Ditto class ops. + -- But it happens that there aren't any + rep_names tc = case tyConRepName_maybe tc of + Just n -> [n] + Nothing -> [] + +-- | Check the known-key names list of consistency. +knownKeyNamesOkay :: [Name] -> Maybe String +knownKeyNamesOkay all_names + | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names + = Just $ " Out-of-range known-key uniques: [" + ++ intercalate ", " (map (occNameString . nameOccName) ns) ++ + "]" + | null badNamesPairs + = Nothing + | otherwise + = Just badNamesStr + where + namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n) + emptyUFM all_names + badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv + badNamesPairs = nonDetUFMToList badNamesEnv + -- It's OK to use nonDetUFMToList here because the ordering only affects + -- the message when we get a panic + badNamesStrs = map pairToStr badNamesPairs + badNamesStr = unlines badNamesStrs + + pairToStr (uniq, ns) = " " ++ + show uniq ++ + ": [" ++ + intercalate ", " (map (occNameString . nameOccName) ns) ++ + "]" + +-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a +-- known-key thing. +lookupKnownKeyName :: Unique -> Maybe Name +lookupKnownKeyName u = + knownUniqueName u <|> lookupUFM_Directly knownKeysMap u + +-- | Is a 'Name' known-key? +isKnownKeyName :: Name -> Bool +isKnownKeyName n = + isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap + +-- | Maps 'Unique's to known-key names. +-- +-- The type is @UniqFM Name Name@ to denote that the 'Unique's used +-- in the domain are 'Unique's associated with 'Name's (as opposed +-- to some other namespace of 'Unique's). +knownKeysMap :: UniqFM Name Name +knownKeysMap = listToIdentityUFM knownKeyNames + +-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by +-- GHCi's ':info' command. +lookupKnownNameInfo :: Name -> SDoc +lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of + -- If we do find a doc, we add comment delimiters to make the output + -- of ':info' valid Haskell. + Nothing -> empty + Just doc -> vcat [text "{-", doc, text "-}"] + +-- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390) +knownNamesInfo :: NameEnv SDoc +knownNamesInfo = unitNameEnv coercibleTyConName $ + vcat [ text "Coercible is a special constraint with custom solving rules." + , text "It is not a class." + , text "Please see section `The Coercible constraint`" + , text "of the user's guide for details." ] + +{- +We let a lot of "non-standard" values be visible, so that we can make +sense of them in interface pragmas. It's cool, though they all have +"non-standard" names, so they won't get past the parser in user code. + +************************************************************************ +* * + PrimOpIds +* * +************************************************************************ +-} + +primOpIds :: Array Int Id +-- A cache of the PrimOp Ids, indexed by PrimOp tag +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps ] + +primOpId :: PrimOp -> Id +primOpId op = primOpIds ! primOpTag op + +{- +************************************************************************ +* * + Export lists for pseudo-modules (GHC.Prim) +* * +************************************************************************ + +GHC.Prim "exports" all the primops and primitive types, some +wired-in Ids. +-} + +ghcPrimExports :: [IfaceExport] +ghcPrimExports + = map (avail . idName) ghcPrimIds ++ + map (avail . idName . primOpId) allThePrimOps ++ + [ AvailTC n [n] [] + | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc ] + +ghcPrimDeclDocs :: DeclDocMap +ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs + where + names = map idName ghcPrimIds ++ + map (idName . primOpId) allThePrimOps ++ + map tyConName (funTyCon : exposedPrimTyCons) + findName (nameStr, doc) + | Just name <- find ((nameStr ==) . getOccString) names + = Just (name, mkHsDocString doc) + | otherwise = Nothing + +{- +************************************************************************ +* * + Built-in keys +* * +************************************************************************ + +ToDo: make it do the ``like'' part properly (as in 0.26 and before). +-} + +maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey + +{- +************************************************************************ +* * + Class predicates +* * +************************************************************************ +-} + +isNumericClass, isStandardClass :: Class -> Bool + +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys + +is_elem :: Eq a => a -> [a] -> Bool +is_elem = isIn "is_X_Class" diff --git a/GHC/ByteCode/Asm.hs b/GHC/ByteCode/Asm.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Asm.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler and linker +module GHC.ByteCode.Asm ( + assembleBCOs, assembleOneBCO, + + bcoFreeNames, + SizedSeq, sizeSS, ssElts, + iNTERP_STACK_CHECK_THRESH + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.ByteCode.Instr +import GHC.ByteCode.InfoTable +import GHC.ByteCode.Types +import GHCi.RemoteTypes +import GHC.Runtime.Interpreter + +import GHC.Driver.Types +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Literal +import GHC.Core.TyCon +import GHC.Data.FastString +import GHC.StgToCmm.Layout ( ArgRep(..) ) +import GHC.Runtime.Heap.Layout +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Utils.Misc +import GHC.Types.Unique +import GHC.Types.Unique.DSet + +-- From iserv +import SizedSeq + +import Control.Monad +import Control.Monad.ST ( runST ) +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict + +import Data.Array.MArray + +import qualified Data.Array.Unboxed as Array +import Data.Array.Base ( UArray(..) ) + +import Data.Array.Unsafe( castSTUArray ) + +import Foreign +import Data.Char ( ord ) +import Data.List ( genericLength ) +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map + +-- ----------------------------------------------------------------------------- +-- Unlinked BCOs + +-- CompiledByteCode represents the result of byte-code +-- compiling a bunch of functions and data types + +-- | Finds external references. Remember to remove the names +-- defined by this group of BCOs themselves +bcoFreeNames :: UnlinkedBCO -> UniqDSet Name +bcoFreeNames bco + = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] + where + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + = unionManyUniqDSets ( + mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] : + mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] : + map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] + ) + +-- ----------------------------------------------------------------------------- +-- The bytecode assembler + +-- The object format for bytecodes is: 16 bits for the opcode, and 16 +-- for each field -- so the code can be considered a sequence of +-- 16-bit ints. Each field denotes either a stack offset or number of +-- items on the stack (eg SLIDE), and index into the pointer table (eg +-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a +-- bytecode address in this BCO. + +-- Top level assembler fn. +assembleBCOs + :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()] + -> Maybe ModBreaks + -> IO CompiledByteCode +assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do + itblenv <- mkITbls hsc_env tycons + bcos <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos + (bcos',ptrs) <- mallocStrings hsc_env bcos + return CompiledByteCode + { bc_bcos = bcos' + , bc_itbls = itblenv + , bc_ffis = concatMap protoBCOFFIs proto_bcos + , bc_strs = top_strs ++ ptrs + , bc_breaks = modbreaks + } + +-- Find all the literal strings and malloc them together. We want to +-- do this because: +-- +-- a) It should be done when we compile the module, not each time we relink it +-- b) For -fexternal-interpreter It's more efficient to malloc the strings +-- as a single batch message, especially when compiling in parallel. +-- +mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()]) +mallocStrings hsc_env ulbcos = do + let bytestrings = reverse (execState (mapM_ collect ulbcos) []) + ptrs <- iservCmd hsc_env (MallocStrings bytestrings) + return (evalState (mapM splice ulbcos) ptrs, ptrs) + where + splice bco@UnlinkedBCO{..} = do + lits <- mapM spliceLit unlinkedBCOLits + ptrs <- mapM splicePtr unlinkedBCOPtrs + return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs } + + spliceLit (BCONPtrStr _) = do + rptrs <- get + case rptrs of + (RemotePtr p : rest) -> do + put rest + return (BCONPtrWord (fromIntegral p)) + _ -> panic "mallocStrings:spliceLit" + spliceLit other = return other + + splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco + splicePtr other = return other + + collect UnlinkedBCO{..} = do + mapM_ collectLit unlinkedBCOLits + mapM_ collectPtr unlinkedBCOPtrs + + collectLit (BCONPtrStr bs) = do + strs <- get + put (bs:strs) + collectLit _ = return () + + collectPtr (BCOPtrBCO bco) = collect bco + collectPtr _ = return () + + +assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO +assembleOneBCO hsc_env pbco = do + ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco + ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco] + return ubco' + +assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO platform (ProtoBCO { protoBCOName = nm + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity }) = do + -- pass 1: collect up the offsets of the local labels. + let asm = mapM_ (assembleI platform) instrs + + initial_offset = 0 + + -- Jump instructions are variable-sized, there are long and short variants + -- depending on the magnitude of the offset. However, we can't tell what + -- size instructions we will need until we have calculated the offsets of + -- the labels, which depends on the size of the instructions... So we + -- first create the label environment assuming that all jumps are short, + -- and if the final size is indeed small enough for short jumps, we are + -- done. Otherwise, we repeat the calculation, and we force all jumps in + -- this BCO to be long. + (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm + ((n_insns, lbl_map), long_jumps) + | isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True) + | otherwise = ((n_insns0, lbl_map0), False) + + env :: Word16 -> Word + env lbl = fromMaybe + (pprPanic "assembleBCO.findLabel" (ppr lbl)) + (Map.lookup lbl lbl_map) + + -- pass 2: run assembler and generate instructions, literals and pointers + let initial_state = (emptySS, emptySS, emptySS) + (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm + + -- precomputed size should be equal to final size + ASSERT(n_insns == sizeSS final_insns) return () + + let asm_insns = ssElts final_insns + insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns + bitmap_arr = mkBitmapArray bsize bitmap + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs + + -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive + -- objects, since they might get run too early. Disable this until + -- we figure out what to do. + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) + + return ul_bco + +mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64 +-- Here the return type must be an array of Words, not StgWords, +-- because the underlying ByteArray# will end up as a component +-- of a BCO object. +mkBitmapArray bsize bitmap + = Array.listArray (0, length bitmap) $ + fromIntegral bsize : map (fromInteger . fromStgWord) bitmap + +-- instrs nonptrs ptrs +type AsmState = (SizedSeq Word16, + SizedSeq BCONPtr, + SizedSeq BCOPtr) + +data Operand + = Op Word + | SmallOp Word16 + | LabelOp Word16 +-- (unused) | LargeOp Word + +data Assembler a + = AllocPtr (IO BCOPtr) (Word -> Assembler a) + | AllocLit [BCONPtr] (Word -> Assembler a) + | AllocLabel Word16 (Assembler a) + | Emit Word16 [Operand] (Assembler a) + | NullAsm a + deriving (Functor) + +instance Applicative Assembler where + pure = NullAsm + (<*>) = ap + +instance Monad Assembler where + NullAsm x >>= f = f x + AllocPtr p k >>= f = AllocPtr p (k >=> f) + AllocLit l k >>= f = AllocLit l (k >=> f) + AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) + Emit w ops k >>= f = Emit w ops (k >>= f) + +ioptr :: IO BCOPtr -> Assembler Word +ioptr p = AllocPtr p return + +ptr :: BCOPtr -> Assembler Word +ptr = ioptr . return + +lit :: [BCONPtr] -> Assembler Word +lit l = AllocLit l return + +label :: Word16 -> Assembler () +label w = AllocLabel w (return ()) + +emit :: Word16 -> [Operand] -> Assembler () +emit w ops = Emit w ops (return ()) + +type LabelEnv = Word16 -> Word + +largeOp :: Bool -> Operand -> Bool +largeOp long_jumps op = case op of + SmallOp _ -> False + Op w -> isLarge w + LabelOp _ -> long_jumps +-- LargeOp _ -> True + +runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a +runAsm platform long_jumps e = go + where + go (NullAsm x) = return x + go (AllocPtr p_io k) = do + p <- lift p_io + w <- state $ \(st_i0,st_l0,st_p0) -> + let st_p1 = addToSS st_p0 p + in (sizeSS st_p0, (st_i0,st_l0,st_p1)) + go $ k w + go (AllocLit lits k) = do + w <- state $ \(st_i0,st_l0,st_p0) -> + let st_l1 = addListToSS st_l0 lits + in (sizeSS st_l0, (st_i0,st_l1,st_p0)) + go $ k w + go (AllocLabel _ k) = go k + go (Emit w ops k) = do + let largeOps = any (largeOp long_jumps) ops + opcode + | largeOps = largeArgInstr w + | otherwise = w + words = concatMap expand ops + expand (SmallOp w) = [w] + expand (LabelOp w) = expand (Op (e w)) + expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w] +-- expand (LargeOp w) = largeArg platform w + state $ \(st_i0,st_l0,st_p0) -> + let st_i1 = addListToSS st_i0 (opcode : words) + in ((), (st_i1,st_l0,st_p0)) + go k + +type LabelEnvMap = Map Word16 Word + +data InspectState = InspectState + { instrCount :: !Word + , ptrCount :: !Word + , litCount :: !Word + , lblEnv :: LabelEnvMap + } + +inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) +inspectAsm platform long_jumps initial_offset + = go (InspectState initial_offset 0 0 Map.empty) + where + go s (NullAsm _) = (instrCount s, lblEnv s) + go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) + where n = ptrCount s + go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) + where n = litCount s + go s (AllocLabel lbl k) = go s' k + where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } + go s (Emit _ ops k) = go s' k + where + s' = s { instrCount = instrCount s + size } + size = sum (map count ops) + 1 + largeOps = any (largeOp long_jumps) ops + count (SmallOp _) = 1 + count (LabelOp _) = count (Op 0) + count (Op _) = if largeOps then largeArg16s platform else 1 +-- count (LargeOp _) = largeArg16s platform + +-- Bring in all the bci_ bytecode constants. +#include "rts/Bytecodes.h" + +largeArgInstr :: Word16 -> Word16 +largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci + +largeArg :: Platform -> Word -> [Word16] +largeArg platform w = case platformWordSize platform of + PW8 -> [fromIntegral (w `shiftR` 48), + fromIntegral (w `shiftR` 32), + fromIntegral (w `shiftR` 16), + fromIntegral w] + PW4 -> [fromIntegral (w `shiftR` 16), + fromIntegral w] + +largeArg16s :: Platform -> Word +largeArg16s platform = case platformWordSize platform of + PW8 -> 4 + PW4 -> 2 + +assembleI :: Platform + -> BCInstr + -> Assembler () +assembleI platform i = case i of + STKCHECK n -> emit bci_STKCHECK [Op n] + PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] + PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] + PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] + PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1] + PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1] + PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1] + PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1] + PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1] + PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp o1] + PUSH_G nm -> do p <- ptr (BCOPtrName nm) + emit bci_PUSH_G [Op p] + PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) + emit bci_PUSH_G [Op p] + PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_G [Op p] + PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_ALTS [Op p] + PUSH_ALTS_UNLIFTED proto pk + -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit (push_alts pk) [Op p] + PUSH_PAD8 -> emit bci_PUSH_PAD8 [] + PUSH_PAD16 -> emit bci_PUSH_PAD16 [] + PUSH_PAD32 -> emit bci_PUSH_PAD32 [] + PUSH_UBX8 lit -> do np <- literal lit + emit bci_PUSH_UBX8 [Op np] + PUSH_UBX16 lit -> do np <- literal lit + emit bci_PUSH_UBX16 [Op np] + PUSH_UBX32 lit -> do np <- literal lit + emit bci_PUSH_UBX32 [Op np] + PUSH_UBX lit nws -> do np <- literal lit + emit bci_PUSH_UBX [Op np, SmallOp nws] + + PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] + PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] + PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] + PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] + PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] + PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] + PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] + PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] + PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] + PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] + PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] + + SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] + ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] + ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] + ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] + MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] + MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] + UNPACK n -> emit bci_UNPACK [SmallOp n] + PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] + emit bci_PACK [Op itbl_no, SmallOp sz] + LABEL lbl -> label lbl + TESTLT_I i l -> do np <- int i + emit bci_TESTLT_I [Op np, LabelOp l] + TESTEQ_I i l -> do np <- int i + emit bci_TESTEQ_I [Op np, LabelOp l] + TESTLT_W w l -> do np <- word w + emit bci_TESTLT_W [Op np, LabelOp l] + TESTEQ_W w l -> do np <- word w + emit bci_TESTEQ_W [Op np, LabelOp l] + TESTLT_F f l -> do np <- float f + emit bci_TESTLT_F [Op np, LabelOp l] + TESTEQ_F f l -> do np <- float f + emit bci_TESTEQ_F [Op np, LabelOp l] + TESTLT_D d l -> do np <- double d + emit bci_TESTLT_D [Op np, LabelOp l] + TESTEQ_D d l -> do np <- double d + emit bci_TESTEQ_D [Op np, LabelOp l] + TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] + TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] + CASEFAIL -> emit bci_CASEFAIL [] + SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] + JMP l -> emit bci_JMP [LabelOp l] + ENTER -> emit bci_ENTER [] + RETURN -> emit bci_RETURN [] + RETURN_UBX rep -> emit (return_ubx rep) [] + CCALL off m_addr i -> do np <- addr m_addr + emit bci_CCALL [SmallOp off, Op np, SmallOp i] + BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray + q <- int (getKey uniq) + np <- addr cc + emit bci_BRK_FUN [Op p1, SmallOp index, + Op q, Op np] + + where + literal (LitLabel fs (Just sz) _) + | platformOS platform == OSMinGW32 + = litlabel (appendFS fs (mkFastString ('@':show sz))) + -- On Windows, stdcall labels have a suffix indicating the no. of + -- arg words, e.g. foo@8. testcase: ffi012(ghci) + literal (LitLabel fs _ _) = litlabel fs + literal LitNullAddr = int 0 + literal (LitFloat r) = float (fromRational r) + literal (LitDouble r) = double (fromRational r) + literal (LitChar c) = int (ord c) + literal (LitString bs) = lit [BCONPtrStr bs] + -- LitString requires a zero-terminator when emitted + literal (LitNumber nt i) = case nt of + LitNumInt -> int (fromIntegral i) + LitNumWord -> int (fromIntegral i) + LitNumInt64 -> int64 (fromIntegral i) + LitNumWord64 -> int64 (fromIntegral i) + LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger" + LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural" + -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most + -- likely to elicit a crash (rather than corrupt memory) in case absence + -- analysis messed up. + literal LitRubbish = int 0 + + litlabel fs = lit [BCONPtrLbl fs] + addr (RemotePtr a) = words [fromIntegral a] + float = words . mkLitF + double = words . mkLitD platform + int = words . mkLitI + int64 = words . mkLitI64 platform + words ws = lit (map BCONPtrWord ws) + word w = words [w] + +isLarge :: Word -> Bool +isLarge n = n > 65535 + +push_alts :: ArgRep -> Word16 +push_alts V = bci_PUSH_ALTS_V +push_alts P = bci_PUSH_ALTS_P +push_alts N = bci_PUSH_ALTS_N +push_alts L = bci_PUSH_ALTS_L +push_alts F = bci_PUSH_ALTS_F +push_alts D = bci_PUSH_ALTS_D +push_alts V16 = error "push_alts: vector" +push_alts V32 = error "push_alts: vector" +push_alts V64 = error "push_alts: vector" + +return_ubx :: ArgRep -> Word16 +return_ubx V = bci_RETURN_V +return_ubx P = bci_RETURN_P +return_ubx N = bci_RETURN_N +return_ubx L = bci_RETURN_L +return_ubx F = bci_RETURN_F +return_ubx D = bci_RETURN_D +return_ubx V16 = error "return_ubx: vector" +return_ubx V32 = error "return_ubx: vector" +return_ubx V64 = error "return_ubx: vector" + +-- Make lists of host-sized words for literals, so that when the +-- words are placed in memory at increasing addresses, the +-- bit pattern is correct for the host's word size and endianness. +mkLitI :: Int -> [Word] +mkLitF :: Float -> [Word] +mkLitD :: Platform -> Double -> [Word] +mkLitI64 :: Platform -> Int64 -> [Word] + +mkLitF f + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 f + f_arr <- castSTUArray arr + w0 <- readArray f_arr 0 + return [w0 :: Word] + ) + +mkLitD platform d = case platformWordSize platform of + PW4 -> runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 d + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word, w1] + ) + PW8 -> runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 d + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + +mkLitI64 platform ii = case platformWordSize platform of + PW4 -> runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 ii + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word,w1] + ) + PW8 -> runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 ii + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + +mkLitI i = [fromIntegral i :: Word] + +iNTERP_STACK_CHECK_THRESH :: Int +iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/GHC/ByteCode/InfoTable.hs b/GHC/ByteCode/InfoTable.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/InfoTable.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Generate infotables for interpreter-made bytecodes +module GHC.ByteCode.InfoTable ( mkITbls ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.ByteCode.Types +import GHC.Runtime.Interpreter +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Types.Name ( Name, getName ) +import GHC.Types.Name.Env +import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) +import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Types.RepType +import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) +import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import GHC.Utils.Misc +import GHC.Utils.Panic + +{- + Manufacturing of info tables for DataCons +-} + +-- Make info tables for the data decls in this module +mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv +mkITbls hsc_env tcs = + foldr plusNameEnv emptyNameEnv <$> + mapM (mkITbl hsc_env) (filter isDataTyCon tcs) + where + mkITbl :: HscEnv -> TyCon -> IO ItblEnv + mkITbl hsc_env tc + | dcs `lengthIs` n -- paranoia; this is an assertion. + = make_constr_itbls hsc_env dcs + where + dcs = tyConDataCons tc + n = tyConFamilySize tc + mkITbl _ _ = panic "mkITbl" + +mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv +mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] + +-- Assumes constructors are numbered from zero, not one +make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv +make_constr_itbls hsc_env cons = + mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) + where + dflags = hsc_dflags hsc_env + + mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) + mk_itbl dcon conNo = do + let rep_args = [ NonVoid prim_rep + | arg <- dataConRepArgTys dcon + , prim_rep <- typePrimRep (scaledThing arg) ] + + (tot_wds, ptr_wds) = + mkVirtConstrSizes dflags rep_args + + ptrs' = ptr_wds + nptrs' = tot_wds - ptr_wds + nptrs_really + | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' + | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' + + descr = dataConIdentity dcon + + platform = targetPlatform dflags + tables_next_to_code = platformTablesNextToCode platform + + r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really + conNo (tagForCon dflags dcon) descr) + return (getName dcon, ItblPtr r) diff --git a/GHC/ByteCode/Instr.hs b/GHC/ByteCode/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Instr.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE CPP, MagicHash #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode instruction definitions +module GHC.ByteCode.Instr ( + BCInstr(..), ProtoBCO(..), bciStackUse, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.ByteCode.Types +import GHCi.RemoteTypes +import GHCi.FFI (C_ffi_cif) +import GHC.StgToCmm.Layout ( ArgRep(..) ) +import GHC.Core.Ppr +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Id +import GHC.Core +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Types.Var.Set +import GHC.Builtin.PrimOps +import GHC.Runtime.Heap.Layout + +import Data.Word +import GHC.Stack.CCS (CostCentre) + +-- ---------------------------------------------------------------------------- +-- Bytecode instructions + +data ProtoBCO a + = ProtoBCO { + protoBCOName :: a, -- name, in some sense + protoBCOInstrs :: [BCInstr], -- instrs + -- arity and GC info + protoBCOBitmap :: [StgWord], + protoBCOBitmapSize :: Word16, + protoBCOArity :: Int, + -- what the BCO came from, for debugging only + protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), + -- malloc'd pointers + protoBCOFFIs :: [FFIInfo] + } + +type LocalLabel = Word16 + +data BCInstr + -- Messing with the stack + = STKCHECK Word + + -- Push locals (existing bits of the stack) + | PUSH_L !Word16{-offset-} + | PUSH_LL !Word16 !Word16{-2 offsets-} + | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} + + -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e., + -- the stack will grow by 8, 16 or 32 bits) + | PUSH8 !Word16 + | PUSH16 !Word16 + | PUSH32 !Word16 + + -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the + -- value will take the whole word on the stack (i.e., the stack will grow by + -- a word) + -- This is useful when extracting a packed constructor field for further use. + -- Currently we expect all values on the stack to take full words, except for + -- the ones used for PACK (i.e., actually constracting new data types, in + -- which case we use PUSH{8,16,32}) + | PUSH8_W !Word16 + | PUSH16_W !Word16 + | PUSH32_W !Word16 + + -- Push a ptr (these all map to PUSH_G really) + | PUSH_G Name + | PUSH_PRIMOP PrimOp + | PUSH_BCO (ProtoBCO Name) + + -- Push an alt continuation + | PUSH_ALTS (ProtoBCO Name) + | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep + + -- Pushing 8, 16 and 32 bits of padding (for constructors). + | PUSH_PAD8 + | PUSH_PAD16 + | PUSH_PAD32 + + -- Pushing literals + | PUSH_UBX8 Literal + | PUSH_UBX16 Literal + | PUSH_UBX32 Literal + | PUSH_UBX Literal Word16 + -- push this int/float/double/addr, on the stack. Word16 + -- is # of words to copy from literal pool. Eitherness reflects + -- the difficulty of dealing with MachAddr here, mostly due to + -- the excessive (and unnecessary) restrictions imposed by the + -- designers of the new Foreign library. In particular it is + -- quite impossible to convert an Addr to any other integral + -- type, and it appears impossible to get hold of the bits of + -- an addr, even though we need to assemble BCOs. + + -- various kinds of application + | PUSH_APPLY_N + | PUSH_APPLY_V + | PUSH_APPLY_F + | PUSH_APPLY_D + | PUSH_APPLY_L + | PUSH_APPLY_P + | PUSH_APPLY_PP + | PUSH_APPLY_PPP + | PUSH_APPLY_PPPP + | PUSH_APPLY_PPPPP + | PUSH_APPLY_PPPPPP + + | SLIDE Word16{-this many-} Word16{-down by this much-} + + -- To do with the heap + | ALLOC_AP !Word16 -- make an AP with this many payload words + | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words + | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words + | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-} + | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} + | UNPACK !Word16 -- unpack N words from t.o.s Constr + | PACK DataCon !Word16 + -- after assembly, the DataCon is an index into the + -- itbl array + -- For doing case trees + | LABEL LocalLabel + | TESTLT_I Int LocalLabel + | TESTEQ_I Int LocalLabel + | TESTLT_W Word LocalLabel + | TESTEQ_W Word LocalLabel + | TESTLT_F Float LocalLabel + | TESTEQ_F Float LocalLabel + | TESTLT_D Double LocalLabel + | TESTEQ_D Double LocalLabel + + -- The Word16 value is a constructor number and therefore + -- stored in the insn stream rather than as an offset into + -- the literal pool. + | TESTLT_P Word16 LocalLabel + | TESTEQ_P Word16 LocalLabel + + | CASEFAIL + | JMP LocalLabel + + -- For doing calls to C (via glue code generated by libffi) + | CCALL Word16 -- stack frame size + (RemotePtr C_ffi_cif) -- addr of the glue code + Word16 -- flags. + -- + -- 0x1: call is interruptible + -- 0x2: call is unsafe + -- + -- (XXX: inefficient, but I don't know + -- what the alignment constraints are.) + + -- For doing magic ByteArray passing to foreign calls + | SWIZZLE Word16 -- to the ptr N words down the stack, + Word16 -- add M (interpreted as a signed 16-bit entity) + + -- To Infinity And Beyond + | ENTER + | RETURN -- return a lifted value + | RETURN_UBX ArgRep -- return an unlifted value, here's its rep + + -- Breakpoints + | BRK_FUN Word16 Unique (RemotePtr CostCentre) + +-- ----------------------------------------------------------------------------- +-- Printing bytecode instructions + +instance Outputable a => Outputable (ProtoBCO a) where + ppr (ProtoBCO { protoBCOName = name + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity + , protoBCOExpr = origin + , protoBCOFFIs = ffis }) + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <+> text (show ffis) <> colon) + $$ nest 3 (case origin of + Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) + (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' + Right rhs -> pprCoreExprShort (deAnnotate rhs)) + $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) + $$ nest 3 (vcat (map ppr instrs)) + +-- Print enough of the Core expression to enable the reader to find +-- the expression in the -ddump-prep output. That is, we need to +-- include at least a binder. + +pprCoreExprShort :: CoreExpr -> SDoc +pprCoreExprShort expr@(Lam _ _) + = let + (bndrs, _) = collectBinders expr + in + char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..." + +pprCoreExprShort (Case _expr var _ty _alts) + = text "case of" <+> ppr var + +pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ...")) +pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) + +pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e +pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T" + +pprCoreExprShort e = pprCoreExpr e + +pprCoreAltShort :: CoreAlt -> SDoc +pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr + +instance Outputable BCInstr where + ppr (STKCHECK n) = text "STKCHECK" <+> ppr n + ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset + ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 + ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 + ppr (PUSH8 offset) = text "PUSH8 " <+> ppr offset + ppr (PUSH16 offset) = text "PUSH16 " <+> ppr offset + ppr (PUSH32 offset) = text "PUSH32 " <+> ppr offset + ppr (PUSH8_W offset) = text "PUSH8_W " <+> ppr offset + ppr (PUSH16_W offset) = text "PUSH16_W " <+> ppr offset + ppr (PUSH32_W offset) = text "PUSH32_W " <+> ppr offset + ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm + ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." + <> ppr op + ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) + ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) + ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) + + ppr PUSH_PAD8 = text "PUSH_PAD8" + ppr PUSH_PAD16 = text "PUSH_PAD16" + ppr PUSH_PAD32 = text "PUSH_PAD32" + + ppr (PUSH_UBX8 lit) = text "PUSH_UBX8" <+> ppr lit + ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit + ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit + ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit + ppr PUSH_APPLY_N = text "PUSH_APPLY_N" + ppr PUSH_APPLY_V = text "PUSH_APPLY_V" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" + + ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d + ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz + ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz + ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz + ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (UNPACK sz) = text "UNPACK " <+> ppr sz + ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz + ppr (LABEL lab) = text "__" <> ppr lab <> colon + ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab + ppr CASEFAIL = text "CASEFAIL" + ppr (JMP lab) = text "JMP" <+> ppr lab + ppr (CCALL off marshall_addr flags) = text "CCALL " <+> ppr off + <+> text "marshall code at" + <+> text (show marshall_addr) + <+> (case flags of + 0x1 -> text "(interruptible)" + 0x2 -> text "(unsafe)" + _ -> empty) + ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff + <+> text "by" <+> ppr n + ppr ENTER = text "ENTER" + ppr RETURN = text "RETURN" + ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk + ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "" + +-- ----------------------------------------------------------------------------- +-- The stack use, in words, of each bytecode insn. These _must_ be +-- correct, or overestimates of reality, to be safe. + +-- NOTE: we aggregate the stack use from case alternatives too, so that +-- we can do a single stack check at the beginning of a function only. + +-- This could all be made more accurate by keeping track of a proper +-- stack high water mark, but it doesn't seem worth the hassle. + +protoBCOStackUse :: ProtoBCO a -> Word +protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) + +bciStackUse :: BCInstr -> Word +bciStackUse STKCHECK{} = 0 +bciStackUse PUSH_L{} = 1 +bciStackUse PUSH_LL{} = 2 +bciStackUse PUSH_LLL{} = 3 +bciStackUse PUSH8{} = 1 -- overapproximation +bciStackUse PUSH16{} = 1 -- overapproximation +bciStackUse PUSH32{} = 1 -- overapproximation on 64bit arch +bciStackUse PUSH8_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH16_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH_G{} = 1 +bciStackUse PUSH_PRIMOP{} = 1 +bciStackUse PUSH_BCO{} = 1 +bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco +bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco +bciStackUse (PUSH_PAD8) = 1 -- overapproximation +bciStackUse (PUSH_PAD16) = 1 -- overapproximation +bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch +bciStackUse (PUSH_UBX8 _) = 1 -- overapproximation +bciStackUse (PUSH_UBX16 _) = 1 -- overapproximation +bciStackUse (PUSH_UBX32 _) = 1 -- overapproximation on 64bit arch +bciStackUse (PUSH_UBX _ nw) = fromIntegral nw +bciStackUse PUSH_APPLY_N{} = 1 +bciStackUse PUSH_APPLY_V{} = 1 +bciStackUse PUSH_APPLY_F{} = 1 +bciStackUse PUSH_APPLY_D{} = 1 +bciStackUse PUSH_APPLY_L{} = 1 +bciStackUse PUSH_APPLY_P{} = 1 +bciStackUse PUSH_APPLY_PP{} = 1 +bciStackUse PUSH_APPLY_PPP{} = 1 +bciStackUse PUSH_APPLY_PPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPPP{} = 1 +bciStackUse ALLOC_AP{} = 1 +bciStackUse ALLOC_AP_NOUPD{} = 1 +bciStackUse ALLOC_PAP{} = 1 +bciStackUse (UNPACK sz) = fromIntegral sz +bciStackUse LABEL{} = 0 +bciStackUse TESTLT_I{} = 0 +bciStackUse TESTEQ_I{} = 0 +bciStackUse TESTLT_W{} = 0 +bciStackUse TESTEQ_W{} = 0 +bciStackUse TESTLT_F{} = 0 +bciStackUse TESTEQ_F{} = 0 +bciStackUse TESTLT_D{} = 0 +bciStackUse TESTEQ_D{} = 0 +bciStackUse TESTLT_P{} = 0 +bciStackUse TESTEQ_P{} = 0 +bciStackUse CASEFAIL{} = 0 +bciStackUse JMP{} = 0 +bciStackUse ENTER{} = 0 +bciStackUse RETURN{} = 0 +bciStackUse RETURN_UBX{} = 1 +bciStackUse CCALL{} = 0 +bciStackUse SWIZZLE{} = 0 +bciStackUse BRK_FUN{} = 0 + +-- These insns actually reduce stack use, but we need the high-tide level, +-- so can't use this info. Not that it matters much. +bciStackUse SLIDE{} = 0 +bciStackUse MKAP{} = 0 +bciStackUse MKPAP{} = 0 +bciStackUse PACK{} = 1 -- worst case is PACK 0 words diff --git a/GHC/ByteCode/Linker.hs b/GHC/ByteCode/Linker.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Linker.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler and linker +module GHC.ByteCode.Linker ( + ClosureEnv, emptyClosureEnv, extendClosureEnv, + linkBCO, lookupStaticPtr, + lookupIE, + nameToCLabel, linkFail + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.BreakArray +import SizedSeq + +import GHC.Runtime.Interpreter +import GHC.ByteCode.Types +import GHC.Driver.Types +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Builtin.PrimOps +import GHC.Unit +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Misc + +-- Standard libraries +import Data.Array.Unboxed +import Foreign.Ptr +import GHC.Exts + +{- + Linking interpretables into something we can run +-} + +type ClosureEnv = NameEnv (Name, ForeignHValue) + +emptyClosureEnv :: ClosureEnv +emptyClosureEnv = emptyNameEnv + +extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv +extendClosureEnv cl_env pairs + = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] + +{- + Linking interpretables into something we can run +-} + +linkBCO + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray + -> UnlinkedBCO + -> IO ResolvedBCO +linkBCO hsc_env ie ce bco_ix breakarray + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + -- fromIntegral Word -> Word64 should be a no op if Word is Word64 + -- otherwise it will result in a cast to longlong on 32bit systems. + lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0) + ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0) + return (ResolvedBCO isLittleEndian arity insns bitmap + (listArray (0, fromIntegral (sizeSS lits0)-1) lits) + (addListToSS emptySS ptrs)) + +lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word +lookupLiteral _ _ (BCONPtrWord lit) = return lit +lookupLiteral hsc_env _ (BCONPtrLbl sym) = do + Ptr a# <- lookupStaticPtr hsc_env sym + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral hsc_env ie (BCONPtrItbl nm) = do + Ptr a# <- lookupIE hsc_env ie nm + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral _ _ (BCONPtrStr _) = + -- should be eliminated during assembleBCOs + panic "lookupLiteral: BCONPtrStr" + +lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ()) +lookupStaticPtr hsc_env addr_of_label_string = do + m <- lookupSymbol hsc_env addr_of_label_string + case m of + Just ptr -> return ptr + Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" + (unpackFS addr_of_label_string) + +lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ()) +lookupIE hsc_env ie con_nm = + case lookupNameEnv ie con_nm of + Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) + Nothing -> do -- try looking up in the object files. + let sym_to_find1 = nameToCLabel con_nm "con_info" + m <- lookupSymbol hsc_env sym_to_find1 + case m of + Just addr -> return addr + Nothing + -> do -- perhaps a nullary constructor? + let sym_to_find2 = nameToCLabel con_nm "static_info" + n <- lookupSymbol hsc_env sym_to_find2 + case n of + Just addr -> return addr + Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE" + (unpackFS sym_to_find1 ++ " or " ++ + unpackFS sym_to_find2) + +lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ()) +lookupPrimOp hsc_env primop = do + let sym_to_find = primopToCLabel primop "closure" + m <- lookupSymbol hsc_env (mkFastString sym_to_find) + case m of + Just p -> return (toRemotePtr p) + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find + +resolvePtr + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray + -> BCOPtr + -> IO ResolvedBCOPtr +resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm) + | Just ix <- lookupNameEnv bco_ix nm = + return (ResolvedBCORef ix) -- ref to another BCO in this group + | Just (_, rhv) <- lookupNameEnv ce nm = + return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) + | otherwise = + ASSERT2(isExternalName nm, ppr nm) + do let sym_to_find = nameToCLabel nm "closure" + m <- lookupSymbol hsc_env sym_to_find + case m of + Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find) +resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) = + ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op +resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) = + ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco +resolvePtr _ _ _ _ breakarray BCOPtrBreakArray = + return (ResolvedBCOPtrBreakArray breakarray) + +linkFail :: String -> String -> IO a +linkFail who what + = throwGhcExceptionIO (ProgramError $ + unlines [ "",who + , "During interactive linking, GHCi couldn't find the following symbol:" + , ' ' : ' ' : what + , "This may be due to you not asking GHCi to load extra object files," + , "archives or DLLs needed by your current session. Restart GHCi, specifying" + , "the missing library using the -L/path/to/object/dir and -lmissinglibname" + , "flags, or simply by naming the relevant files on the GHCi command line." + , "Alternatively, this link failure might indicate a bug in GHCi." + , "If you suspect the latter, please report this as a GHC bug:" + , " https://www.haskell.org/ghc/reportabug" + ]) + + +nameToCLabel :: Name -> String -> FastString +nameToCLabel n suffix = mkFastString label + where + encodeZ = zString . zEncodeFS + (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n + packagePart = encodeZ (unitFS pkgKey) + modulePart = encodeZ (moduleNameFS modName) + occPart = encodeZ (occNameFS (nameOccName n)) + + label = concat + [ if pkgKey == mainUnit then "" else packagePart ++ "_" + , modulePart + , '_':occPart + , '_':suffix + ] + + +-- See Note [Primop wrappers] in GHC.Builtin.PrimOps +primopToCLabel :: PrimOp -> String -> String +primopToCLabel primop suffix = concat + [ "ghczmprim_GHCziPrimopWrappers_" + , zString (zEncodeFS (occNameFS (primOpOcc primop))) + , '_':suffix + ] diff --git a/GHC/ByteCode/Types.hs b/GHC/ByteCode/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Types.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler types +module GHC.ByteCode.Types + ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) + , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) + , ItblEnv, ItblPtr(..) + , CgBreakInfo(..) + , ModBreaks (..), BreakIndex, emptyModBreaks + , CCostCentre + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Builtin.PrimOps +import SizedSeq +import GHC.Core.Type +import GHC.Types.SrcLoc +import GHCi.BreakArray +import GHCi.RemoteTypes +import GHCi.FFI +import Control.DeepSeq + +import Foreign +import Data.Array +import Data.Array.Base ( UArray(..) ) +import Data.ByteString (ByteString) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Maybe (catMaybes) +import GHC.Exts.Heap +import GHC.Stack.CCS + +-- ----------------------------------------------------------------------------- +-- Compiled Byte Code + +data CompiledByteCode = CompiledByteCode + { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings + , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls + , bc_ffis :: [FFIInfo] -- ffi blocks we allocated + , bc_strs :: [RemotePtr ()] -- malloc'd strings + , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not + -- creating breakpoints, for some reason) + } + -- ToDo: we're not tracking strings that we malloc'd +newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) + deriving (Show, NFData) + +instance Outputable CompiledByteCode where + ppr CompiledByteCode{..} = ppr bc_bcos + +-- Not a real NFData instance, because ModBreaks contains some things +-- we can't rnf +seqCompiledByteCode :: CompiledByteCode -> () +seqCompiledByteCode CompiledByteCode{..} = + rnf bc_bcos `seq` + rnf (nameEnvElts bc_itbls) `seq` + rnf bc_ffis `seq` + rnf bc_strs `seq` + rnf (fmap seqModBreaks bc_breaks) + +type ItblEnv = NameEnv (Name, ItblPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) + deriving (Show, NFData) + +data UnlinkedBCO + = UnlinkedBCO { + unlinkedBCOName :: !Name, + unlinkedBCOArity :: {-# UNPACK #-} !Int, + unlinkedBCOInstrs :: !(UArray Int Word16), -- insns + unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap + unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs + } + +instance NFData UnlinkedBCO where + rnf UnlinkedBCO{..} = + rnf unlinkedBCOLits `seq` + rnf unlinkedBCOPtrs + +data BCOPtr + = BCOPtrName !Name + | BCOPtrPrimOp !PrimOp + | BCOPtrBCO !UnlinkedBCO + | BCOPtrBreakArray -- a pointer to this module's BreakArray + +instance NFData BCOPtr where + rnf (BCOPtrBCO bco) = rnf bco + rnf x = x `seq` () + +data BCONPtr + = BCONPtrWord {-# UNPACK #-} !Word + | BCONPtrLbl !FastString + | BCONPtrItbl !Name + | BCONPtrStr !ByteString + +instance NFData BCONPtr where + rnf x = x `seq` () + +-- | Information about a breakpoint that we know at code-generation time +data CgBreakInfo + = CgBreakInfo + { cgb_vars :: [Maybe (Id,Word16)] + , cgb_resty :: Type + } +-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval + +-- Not a real NFData instance because we can't rnf Id or Type +seqCgBreakInfo :: CgBreakInfo -> () +seqCgBreakInfo CgBreakInfo{..} = + rnf (map snd (catMaybes (cgb_vars))) `seq` + seqType cgb_resty + +instance Outputable UnlinkedBCO where + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + = sep [text "BCO", ppr nm, text "with", + ppr (sizeSS lits), text "lits", + ppr (sizeSS ptrs), text "ptrs" ] + +instance Outputable CgBreakInfo where + ppr info = text "CgBreakInfo" <+> + parens (ppr (cgb_vars info) <+> + ppr (cgb_resty info)) + +-- ----------------------------------------------------------------------------- +-- Breakpoints + +-- | Breakpoint index +type BreakIndex = Int + +-- | C CostCentre type +data CCostCentre + +-- | All the information about the breakpoints for a module +data ModBreaks + = ModBreaks + { modBreaks_flags :: ForeignRef BreakArray + -- ^ The array of flags, one per breakpoint, + -- indicating which breakpoints are enabled. + , modBreaks_locs :: !(Array BreakIndex SrcSpan) + -- ^ An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakIndex [OccName]) + -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. + -- See Note [Field modBreaks_decls] + , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) + -- ^ Array pointing to cost centre for each breakpoint + , modBreaks_breakInfo :: IntMap CgBreakInfo + -- ^ info about each breakpoint from the bytecode generator + } + +seqModBreaks :: ModBreaks -> () +seqModBreaks ModBreaks{..} = + rnf modBreaks_flags `seq` + rnf modBreaks_locs `seq` + rnf modBreaks_vars `seq` + rnf modBreaks_decls `seq` + rnf modBreaks_ccs `seq` + rnf (fmap seqCgBreakInfo modBreaks_breakInfo) + +-- | Construct an empty ModBreaks +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaks + { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" + -- ToDo: can we avoid this? + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + , modBreaks_decls = array (0,-1) [] + , modBreaks_ccs = array (0,-1) [] + , modBreaks_breakInfo = IntMap.empty + } + +{- +Note [Field modBreaks_decls] +~~~~~~~~~~~~~~~~~~~~~~ +A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means: +The breakpoint is in the function called "baz" that is declared in a `let` +or `where` clause of a declaration called "bar", which itself is declared +in a `let` or `where` clause of the top-level function called "foo". +-} diff --git a/GHC/Cmm.hs b/GHC/Cmm.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm.hs @@ -0,0 +1,267 @@ +-- Cmm representations using Hoopl's Graph CmmNode e x. +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} + +module GHC.Cmm ( + -- * Cmm top-level datatypes + CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, + CmmDecl, CmmDeclSRTs, GenCmmDecl(..), + CmmGraph, GenCmmGraph(..), + CmmBlock, RawCmmDecl, + Section(..), SectionType(..), + GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..), + SectionProtection(..), sectionProtection, + + -- ** Blocks containing lists + GenBasicBlock(..), blockId, + ListGraph(..), pprBBlock, + + -- * Info Tables + CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable, + ClosureTypeInfo(..), + ProfilingInfo(..), ConstrDescription, + + -- * Statements, expressions and types + module GHC.Cmm.Node, + module GHC.Cmm.Expr, + ) where + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.CostCentre +import GHC.Cmm.CLabel +import GHC.Cmm.BlockId +import GHC.Cmm.Node +import GHC.Runtime.Heap.Layout +import GHC.Cmm.Expr +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Utils.Outputable +import Data.ByteString (ByteString) + +----------------------------------------------------------------------------- +-- Cmm, GenCmm +----------------------------------------------------------------------------- + +-- A CmmProgram is a list of CmmGroups +-- A CmmGroup is a list of top-level declarations + +-- When object-splitting is on, each group is compiled into a separate +-- .o file. So typically we put closely related stuff in a CmmGroup. +-- Section-splitting follows suit and makes one .text subsection for each +-- CmmGroup. + +type CmmProgram = [CmmGroup] + +type GenCmmGroup d h g = [GenCmmDecl d h g] +-- | Cmm group before SRT generation +type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph +-- | Cmm group with SRTs +type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo CmmGraph +-- | "Raw" cmm group (TODO (osa): not sure what that means) +type RawCmmGroup = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) CmmGraph + +----------------------------------------------------------------------------- +-- CmmDecl, GenCmmDecl +----------------------------------------------------------------------------- + +-- GenCmmDecl is abstracted over +-- d, the type of static data elements in CmmData +-- h, the static info preceding the code of a CmmProc +-- g, the control-flow graph of a CmmProc +-- +-- We expect there to be two main instances of this type: +-- (a) C--, i.e. populated with various C-- constructs +-- (b) Native code, populated with data/instructions + +-- | A top-level chunk, abstracted over the type of the contents of +-- the basic blocks (Cmm or instructions are the likely instantiations). +data GenCmmDecl d h g + = CmmProc -- A procedure + h -- Extra header such as the info table + CLabel -- Entry label + [GlobalReg] -- Registers live on entry. Note that the set of live + -- registers will be correct in generated C-- code, but + -- not in hand-written C-- code. However, + -- splitAtProcPoints calculates correct liveness + -- information for CmmProcs. + g -- Control-flow graph for the procedure's code + + | CmmData -- Static data + Section + d + +type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph +type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph + +type RawCmmDecl + = GenCmmDecl + RawCmmStatics + (LabelMap RawCmmStatics) + CmmGraph + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +type CmmGraph = GenCmmGraph CmmNode +data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +type CmmBlock = Block CmmNode C C + +----------------------------------------------------------------------------- +-- Info Tables +----------------------------------------------------------------------------- + +-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains +-- the extra info (beyond the executable code) that belongs to that CmmDecl. +data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable + , stack_info :: CmmStackInfo } + +topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable +topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) +topInfoTable _ = Nothing + +data CmmStackInfo + = StackInfo { + arg_space :: ByteOff, + -- number of bytes of arguments on the stack on entry to the + -- the proc. This is filled in by GHC.StgToCmm.codeGen, and + -- used by the stack allocator later. + do_layout :: Bool + -- Do automatic stack layout for this proc. This is + -- True for all code generated by the code generator, + -- but is occasionally False for hand-written Cmm where + -- we want to do the stack manipulation manually. + } + +-- | Info table as a haskell data type +data CmmInfoTable + = CmmInfoTable { + cit_lbl :: CLabel, -- Info table label + cit_rep :: SMRep, + cit_prof :: ProfilingInfo, + cit_srt :: Maybe CLabel, -- empty, or a closure address + cit_clo :: Maybe (Id, CostCentreStack) + -- Just (id,ccs) <=> build a static closure later + -- Nothing <=> don't build a static closure + -- + -- Static closures for FUNs and THUNKs are *not* generated by + -- the code generator, because we might want to add SRT + -- entries to them later (for FUNs at least; THUNKs are + -- treated the same for consistency). See Note [SRTs] in + -- GHC.Cmm.Info.Build, in particular the [FUN] optimisation. + -- + -- This is strictly speaking not a part of the info table that + -- will be finally generated, but it's the only convenient + -- place to convey this information from the code generator to + -- where we build the static closures in + -- GHC.Cmm.Info.Build.doSRTs. + } + +data ProfilingInfo + = NoProfilingInfo + | ProfilingInfo ByteString ByteString -- closure_type, closure_desc + +----------------------------------------------------------------------------- +-- Static Data +----------------------------------------------------------------------------- + +data SectionType + = Text + | Data + | ReadOnlyData + | RelocatableReadOnlyData + | UninitialisedData + | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned + | CString + | OtherSection String + deriving (Show) + +data SectionProtection + = ReadWriteSection + | ReadOnlySection + | WriteProtectedSection -- See Note [Relocatable Read-Only Data] + deriving (Eq) + +-- | Should a data in this section be considered constant at runtime +sectionProtection :: Section -> SectionProtection +sectionProtection (Section t _) = case t of + Text -> ReadOnlySection + ReadOnlyData -> ReadOnlySection + RelocatableReadOnlyData -> WriteProtectedSection + ReadOnlyData16 -> ReadOnlySection + CString -> ReadOnlySection + Data -> ReadWriteSection + UninitialisedData -> ReadWriteSection + (OtherSection _) -> ReadWriteSection + +{- +Note [Relocatable Read-Only Data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Relocatable data are only read-only after relocation at the start of the +program. They should be writable from the source code until then. Failure to +do so would end up in segfaults at execution when using linkers that do not +enforce writability of those sections, such as the gold linker. +-} + +data Section = Section SectionType CLabel + +data CmmStatic + = CmmStaticLit CmmLit + -- ^ a literal value, size given by cmmLitRep of the literal. + | CmmUninitialised Int + -- ^ uninitialised data, N bytes long + | CmmString ByteString + -- ^ string of 8-bit values only, not zero terminated. + | CmmFileEmbed FilePath + -- ^ an embedded binary file + +-- Static data before SRT generation +data GenCmmStatics (rawOnly :: Bool) where + CmmStatics + :: CLabel -- Label of statics + -> CmmInfoTable + -> CostCentreStack + -> [CmmLit] -- Payload + -> GenCmmStatics 'False + + -- | Static data, after SRTs are generated + CmmStaticsRaw + :: CLabel -- Label of statics + -> [CmmStatic] -- The static data itself + -> GenCmmStatics a + +type CmmStatics = GenCmmStatics 'False +type RawCmmStatics = GenCmmStatics 'True + +-- ----------------------------------------------------------------------------- +-- Basic blocks consisting of lists + +-- These are used by the LLVM and NCG backends, when populating Cmm +-- with lists of instructions. + +data GenBasicBlock i = BasicBlock BlockId [i] + +-- | The branch block id is that of the first block in +-- the branch, which is that branch's entry point +blockId :: GenBasicBlock i -> BlockId +blockId (BasicBlock blk_id _ ) = blk_id + +newtype ListGraph i = ListGraph [GenBasicBlock i] + +instance Outputable instr => Outputable (ListGraph instr) where + ppr (ListGraph blocks) = vcat (map ppr blocks) + +instance Outputable instr => Outputable (GenBasicBlock instr) where + ppr = pprBBlock + +pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc +pprBBlock (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) + diff --git a/GHC/Cmm/BlockId.hs b/GHC/Cmm/BlockId.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/BlockId.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- BlockId module should probably go away completely, being superseded by Label -} +module GHC.Cmm.BlockId + ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet + , newBlockId + , blockLbl, infoTblLbl + ) where + +import GHC.Prelude + +import GHC.Cmm.CLabel +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Unique.Supply + +import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel) + +---------------------------------------------------------------- +--- Block Ids, their environments, and their sets + +{- Note [Unique BlockId] +~~~~~~~~~~~~~~~~~~~~~~~~ +Although a 'BlockId' is a local label, for reasons of implementation, +'BlockId's must be unique within an entire compilation unit. The reason +is that each local label is mapped to an assembly-language label, and in +most assembly languages allow, a label is visible throughout the entire +compilation unit in which it appears. +-} + +type BlockId = Label + +mkBlockId :: Unique -> BlockId +mkBlockId unique = mkHooplLabel $ getKey unique + +newBlockId :: MonadUnique m => m BlockId +newBlockId = mkBlockId <$> getUniqueM + +blockLbl :: BlockId -> CLabel +blockLbl label = mkLocalBlockLabel (getUnique label) + +infoTblLbl :: BlockId -> CLabel +infoTblLbl label + = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs diff --git a/GHC/Cmm/BlockId.hs-boot b/GHC/Cmm/BlockId.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Cmm/BlockId.hs-boot @@ -0,0 +1,8 @@ +module GHC.Cmm.BlockId (BlockId, mkBlockId) where + +import GHC.Cmm.Dataflow.Label (Label) +import GHC.Types.Unique (Unique) + +type BlockId = Label + +mkBlockId :: Unique -> BlockId diff --git a/GHC/Cmm/CLabel.hs b/GHC/Cmm/CLabel.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/CLabel.hs @@ -0,0 +1,1593 @@ +----------------------------------------------------------------------------- +-- +-- Object-file symbols (called CLabel for histerical raisins). +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Cmm.CLabel ( + CLabel, -- abstract type + NeedExternDecl (..), + ForeignLabelSource(..), + pprDebugCLabel, + + mkClosureLabel, + mkSRTLabel, + mkInfoTableLabel, + mkEntryLabel, + mkRednCountsLabel, + mkConInfoTableLabel, + mkApEntryLabel, + mkApInfoTableLabel, + mkClosureTableLabel, + mkBytesLabel, + + mkLocalBlockLabel, + mkLocalClosureLabel, + mkLocalInfoTableLabel, + mkLocalClosureTableLabel, + + mkBlockInfoTableLabel, + + mkBitmapLabel, + mkStringLitLabel, + + mkAsmTempLabel, + mkAsmTempDerivedLabel, + mkAsmTempEndLabel, + mkAsmTempDieLabel, + + mkDirty_MUT_VAR_Label, + mkNonmovingWriteBarrierEnabledLabel, + mkUpdInfoLabel, + mkBHUpdInfoLabel, + mkIndStaticInfoLabel, + mkMainCapabilityLabel, + mkMAP_FROZEN_CLEAN_infoLabel, + mkMAP_FROZEN_DIRTY_infoLabel, + mkMAP_DIRTY_infoLabel, + mkSMAP_FROZEN_CLEAN_infoLabel, + mkSMAP_FROZEN_DIRTY_infoLabel, + mkSMAP_DIRTY_infoLabel, + mkBadAlignmentLabel, + mkArrWords_infoLabel, + mkSRTInfoLabel, + + mkTopTickyCtrLabel, + mkCAFBlackHoleInfoTableLabel, + mkRtsPrimOpLabel, + mkRtsSlowFastTickyCtrLabel, + + mkSelectorInfoLabel, + mkSelectorEntryLabel, + + mkCmmInfoLabel, + mkCmmEntryLabel, + mkCmmRetInfoLabel, + mkCmmRetLabel, + mkCmmCodeLabel, + mkCmmDataLabel, + mkRtsCmmDataLabel, + mkCmmClosureLabel, + + mkRtsApFastLabel, + + mkPrimCallLabel, + + mkForeignLabel, + addLabelSize, + + foreignLabelStdcallInfo, + isBytesLabel, + isForeignLabel, + isSomeRODataLabel, + isStaticClosureLabel, + mkCCLabel, mkCCSLabel, + + DynamicLinkerLabelInfo(..), + mkDynamicLinkerLabel, + dynamicLinkerLabelInfo, + + mkPicBaseLabel, + mkDeadStripPreventer, + + mkHpcTicksLabel, + + -- * Predicates + hasCAF, + needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel, + isMathFun, + isCFunctionLabel, isGcPtrLabel, labelDynamic, + isLocalCLabel, mayRedirectTo, + + -- * Conversions + toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName, + + pprCLabel, + isInfoTableLabel, + isConInfoTableLabel, + isIdLabel, isTickyLabel + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Id.Info +import GHC.Types.Basic +import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId) +import GHC.Unit +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Builtin.PrimOps +import GHC.Types.CostCentre +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Driver.Session +import GHC.Platform +import GHC.Types.Unique.Set +import GHC.Utils.Misc +import GHC.Core.Ppr ( {- instances -} ) +import GHC.CmmToAsm.Config + +-- ----------------------------------------------------------------------------- +-- The CLabel type + +{- | + 'CLabel' is an abstract type that supports the following operations: + + - Pretty printing + + - In a C file, does it need to be declared before use? (i.e. is it + guaranteed to be already in scope in the places we need to refer to it?) + + - If it needs to be declared, what type (code or data) should it be + declared to have? + + - Is it visible outside this object file or not? + + - Is it "dynamic" (see details below) + + - Eq and Ord, so that we can make sets of CLabels (currently only + used in outputting C as far as I can tell, to avoid generating + more than one declaration for any given label). + + - Converting an info table label into an entry label. + + CLabel usage is a bit messy in GHC as they are used in a number of different + contexts: + + - By the C-- AST to identify labels + + - By the unregisterised C code generator (\"PprC\") for naming functions (hence + the name 'CLabel') + + - By the native and LLVM code generators to identify labels + + For extra fun, each of these uses a slightly different subset of constructors + (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and + LLVM backends). + + In general, we use 'IdLabel' to represent Haskell things early in the + pipeline. However, later optimization passes will often represent blocks they + create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the + label. +-} + +data CLabel + = -- | A label related to the definition of a particular Id or Con in a .hs file. + IdLabel + Name + CafInfo + IdLabelInfo -- ^ encodes the suffix of the label + + -- | A label from a .cmm file that is not associated with a .hs level Id. + | CmmLabel + UnitId -- ^ what package the label belongs to. + NeedExternDecl -- ^ does the label need an "extern .." declaration + FastString -- ^ identifier giving the prefix of the label + CmmLabelInfo -- ^ encodes the suffix of the label + + -- | A label with a baked-in \/ algorithmically generated name that definitely + -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so + -- If it doesn't have an algorithmically generated name then use a CmmLabel + -- instead and give it an appropriate UnitId argument. + | RtsLabel + RtsLabelInfo + + -- | A label associated with a block. These aren't visible outside of the + -- compilation unit in which they are defined. These are generally used to + -- name blocks produced by Cmm-to-Cmm passes and the native code generator, + -- where we don't have a 'Name' to associate the label to and therefore can't + -- use 'IdLabel'. + | LocalBlockLabel + {-# UNPACK #-} !Unique + + -- | A 'C' (or otherwise foreign) label. + -- + | ForeignLabel + FastString -- ^ name of the imported label. + + (Maybe Int) -- ^ possible '@n' suffix for stdcall functions + -- When generating C, the '@n' suffix is omitted, but when + -- generating assembler we must add it to the label. + + ForeignLabelSource -- ^ what package the foreign label is in. + + FunctionOrData + + -- | Local temporary label used for native (or LLVM) code generation; must not + -- appear outside of these contexts. Use primarily for debug information + | AsmTempLabel + {-# UNPACK #-} !Unique + + -- | A label \"derived\" from another 'CLabel' by the addition of a suffix. + -- Must not occur outside of the NCG or LLVM code generators. + | AsmTempDerivedLabel + CLabel + FastString -- ^ suffix + + | StringLitLabel + {-# UNPACK #-} !Unique + + | CC_Label CostCentre + | CCS_Label CostCentreStack + + + -- | These labels are generated and used inside the NCG only. + -- They are special variants of a label used for dynamic linking + -- see module PositionIndependentCode for details. + | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel + + -- | This label is generated and used inside the NCG only. + -- It is used as a base for PIC calculations on some platforms. + -- It takes the form of a local numeric assembler label '1'; and + -- is pretty-printed as 1b, referring to the previous definition + -- of 1: in the assembler source file. + | PicBaseLabel + + -- | A label before an info table to prevent excessive dead-stripping on darwin + | DeadStripPreventer CLabel + + + -- | Per-module table of tick locations + | HpcTicksLabel Module + + -- | Static reference table + | SRTLabel + {-# UNPACK #-} !Unique + + -- | A bitmap (function or case return) + | LargeBitmapLabel + {-# UNPACK #-} !Unique + + deriving Eq + +isIdLabel :: CLabel -> Bool +isIdLabel IdLabel{} = True +isIdLabel _ = False + +-- Used in SRT analysis. See Note [Ticky labels in SRT analysis] in +-- GHC.Cmm.Info.Build. +isTickyLabel :: CLabel -> Bool +isTickyLabel (IdLabel _ _ RednCounts) = True +isTickyLabel _ = False + +-- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the +-- label (e.g. "extern StgWordArray(foo)"). The type is fixed to StgWordArray. +-- +-- Symbols from the RTS don't need "extern" declarations because they are +-- exposed via "includes/Stg.h" with the appropriate type. See 'needsCDecl'. +-- +-- The fixed StgWordArray type led to "conflicting types" issues with user +-- provided Cmm files (not in the RTS) that declare data of another type (#15467 +-- and test for #17920). Hence the Cmm parser considers that labels in data +-- sections don't need the "extern" declaration (just add one explicitly if you +-- need it). +-- +-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes +-- for why extern declaration are needed at all. +newtype NeedExternDecl + = NeedExternDecl Bool + deriving (Ord,Eq) + +-- This is laborious, but necessary. We can't derive Ord because +-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the +-- implementation. See Note [No Ord for Unique] +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +instance Ord CLabel where + compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = + compare a1 a2 `thenCmp` + compare b1 b2 `thenCmp` + compare c1 c2 + compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = + compare a1 a2 `thenCmp` + compare b1 b2 `thenCmp` + compare c1 c2 `thenCmp` + compare d1 d2 + compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 + compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2 + compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) = + compare a1 a2 `thenCmp` + compare b1 b2 `thenCmp` + compare c1 c2 `thenCmp` + compare d1 d2 + compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 + compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = + compare a1 a2 `thenCmp` + compare b1 b2 + compare (StringLitLabel u1) (StringLitLabel u2) = + nonDetCmpUnique u1 u2 + compare (CC_Label a1) (CC_Label a2) = + compare a1 a2 + compare (CCS_Label a1) (CCS_Label a2) = + compare a1 a2 + compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) = + compare a1 a2 `thenCmp` + compare b1 b2 + compare PicBaseLabel PicBaseLabel = EQ + compare (DeadStripPreventer a1) (DeadStripPreventer a2) = + compare a1 a2 + compare (HpcTicksLabel a1) (HpcTicksLabel a2) = + compare a1 a2 + compare (SRTLabel u1) (SRTLabel u2) = + nonDetCmpUnique u1 u2 + compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) = + nonDetCmpUnique u1 u2 + compare IdLabel{} _ = LT + compare _ IdLabel{} = GT + compare CmmLabel{} _ = LT + compare _ CmmLabel{} = GT + compare RtsLabel{} _ = LT + compare _ RtsLabel{} = GT + compare LocalBlockLabel{} _ = LT + compare _ LocalBlockLabel{} = GT + compare ForeignLabel{} _ = LT + compare _ ForeignLabel{} = GT + compare AsmTempLabel{} _ = LT + compare _ AsmTempLabel{} = GT + compare AsmTempDerivedLabel{} _ = LT + compare _ AsmTempDerivedLabel{} = GT + compare StringLitLabel{} _ = LT + compare _ StringLitLabel{} = GT + compare CC_Label{} _ = LT + compare _ CC_Label{} = GT + compare CCS_Label{} _ = LT + compare _ CCS_Label{} = GT + compare DynamicLinkerLabel{} _ = LT + compare _ DynamicLinkerLabel{} = GT + compare PicBaseLabel{} _ = LT + compare _ PicBaseLabel{} = GT + compare DeadStripPreventer{} _ = LT + compare _ DeadStripPreventer{} = GT + compare HpcTicksLabel{} _ = LT + compare _ HpcTicksLabel{} = GT + compare SRTLabel{} _ = LT + compare _ SRTLabel{} = GT + +-- | Record where a foreign label is stored. +data ForeignLabelSource + + -- | Label is in a named package + = ForeignLabelInPackage Unit + + -- | Label is in some external, system package that doesn't also + -- contain compiled Haskell code, and is not associated with any .hi files. + -- We don't have to worry about Haskell code being inlined from + -- external packages. It is safe to treat the RTS package as "external". + | ForeignLabelInExternalPackage + + -- | Label is in the package currently being compiled. + -- This is only used for creating hacky tmp labels during code generation. + -- Don't use it in any code that might be inlined across a package boundary + -- (ie, core code) else the information will be wrong relative to the + -- destination module. + | ForeignLabelInThisPackage + + deriving (Eq, Ord) + + +-- | For debugging problems with the CLabel representation. +-- We can't make a Show instance for CLabel because lots of its components don't have instances. +-- The regular Outputable instance only shows the label name, and not its other info. +-- +pprDebugCLabel :: CLabel -> SDoc +pprDebugCLabel lbl + = case lbl of + IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel" + <> whenPprDebug (text ":" <> text (show info))) + CmmLabel pkg _ext _name _info + -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) + + RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") + + ForeignLabel _name mSuffix src funOrData + -> ppr lbl <> (parens $ text "ForeignLabel" + <+> ppr mSuffix + <+> ppr src + <+> ppr funOrData) + + _ -> ppr lbl <> (parens $ text "other CLabel") + + +data IdLabelInfo + = Closure -- ^ Label for closure + | InfoTable -- ^ Info tables for closures; always read-only + | Entry -- ^ Entry point + | Slow -- ^ Slow entry point + + | LocalInfoTable -- ^ Like InfoTable but not externally visible + | LocalEntry -- ^ Like Entry but not externally visible + + | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id + + | ConEntry -- ^ Constructor entry point + | ConInfoTable -- ^ Corresponding info table + + | ClosureTable -- ^ Table of closures for Enum tycons + + | Bytes -- ^ Content of a string literal. See + -- Note [Bytes label]. + | BlockInfoTable -- ^ Like LocalInfoTable but for a proc-point block + -- instead of a closure entry-point. + -- See Note [Proc-point local block entry-point]. + + deriving (Eq, Ord, Show) + + +data RtsLabelInfo + = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks + | RtsSelectorEntry Bool{-updatable-} Int{-offset-} + + | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks + | RtsApEntry Bool{-updatable-} Int{-arity-} + + | RtsPrimOp PrimOp + | RtsApFast FastString -- ^ _fast versions of generic apply + | RtsSlowFastTickyCtr String + + deriving (Eq, Ord) + -- NOTE: Eq on PtrString compares the pointer only, so this isn't + -- a real equality. + + +-- | What type of Cmm label we're dealing with. +-- Determines the suffix appended to the name when a CLabel.CmmLabel +-- is pretty printed. +data CmmLabelInfo + = CmmInfo -- ^ misc rts info tables, suffix _info + | CmmEntry -- ^ misc rts entry points, suffix _entry + | CmmRetInfo -- ^ misc rts ret info tables, suffix _info + | CmmRet -- ^ misc rts return points, suffix _ret + | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure + | CmmCode -- ^ misc rts code + | CmmClosure -- ^ closures eg CHARLIKE_closure + | CmmPrimCall -- ^ a prim call to some hand written Cmm code + deriving (Eq, Ord) + +data DynamicLinkerLabelInfo + = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt + | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo + | GotSymbolPtr -- ELF: foo@got + | GotSymbolOffset -- ELF: foo@gotoff + + deriving (Eq, Ord) + + +-- ----------------------------------------------------------------------------- +-- Constructing CLabels +-- ----------------------------------------------------------------------------- + +-- Constructing IdLabels +-- These are always local: + +mkSRTLabel :: Unique -> CLabel +mkSRTLabel u = SRTLabel u + +mkRednCountsLabel :: Name -> CLabel +mkRednCountsLabel name = IdLabel name NoCafRefs RednCounts -- Note [ticky for LNE] + +-- These have local & (possibly) external variants: +mkLocalClosureLabel :: Name -> CafInfo -> CLabel +mkLocalInfoTableLabel :: Name -> CafInfo -> CLabel +mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel +mkLocalClosureLabel !name !c = IdLabel name c Closure +mkLocalInfoTableLabel name c = IdLabel name c LocalInfoTable +mkLocalClosureTableLabel name c = IdLabel name c ClosureTable + +mkClosureLabel :: Name -> CafInfo -> CLabel +mkInfoTableLabel :: Name -> CafInfo -> CLabel +mkEntryLabel :: Name -> CafInfo -> CLabel +mkClosureTableLabel :: Name -> CafInfo -> CLabel +mkConInfoTableLabel :: Name -> CafInfo -> CLabel +mkBytesLabel :: Name -> CLabel +mkClosureLabel name c = IdLabel name c Closure +mkInfoTableLabel name c = IdLabel name c InfoTable +mkEntryLabel name c = IdLabel name c Entry +mkClosureTableLabel name c = IdLabel name c ClosureTable +mkConInfoTableLabel name c = IdLabel name c ConInfoTable +mkBytesLabel name = IdLabel name NoCafRefs Bytes + +mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel +mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable + -- See Note [Proc-point local block entry-point]. + +-- Constructing Cmm Labels +mkDirty_MUT_VAR_Label, + mkNonmovingWriteBarrierEnabledLabel, + mkUpdInfoLabel, + mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, + mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, + mkMAP_DIRTY_infoLabel, + mkArrWords_infoLabel, + mkTopTickyCtrLabel, + mkCAFBlackHoleInfoTableLabel, + mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, + mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel +mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction +mkNonmovingWriteBarrierEnabledLabel + = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData +mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo +mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo +mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo +mkMainCapabilityLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability") CmmData +mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo +mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo +mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo +mkTopTickyCtrLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct") CmmData +mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkArrWords_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS") CmmInfo +mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo +mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo +mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo +mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry + +mkSRTInfoLabel :: Int -> CLabel +mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo + where + lbl = + case n of + 1 -> fsLit "stg_SRT_1" + 2 -> fsLit "stg_SRT_2" + 3 -> fsLit "stg_SRT_3" + 4 -> fsLit "stg_SRT_4" + 5 -> fsLit "stg_SRT_5" + 6 -> fsLit "stg_SRT_6" + 7 -> fsLit "stg_SRT_7" + 8 -> fsLit "stg_SRT_8" + 9 -> fsLit "stg_SRT_9" + 10 -> fsLit "stg_SRT_10" + 11 -> fsLit "stg_SRT_11" + 12 -> fsLit "stg_SRT_12" + 13 -> fsLit "stg_SRT_13" + 14 -> fsLit "stg_SRT_14" + 15 -> fsLit "stg_SRT_15" + 16 -> fsLit "stg_SRT_16" + _ -> panic "mkSRTInfoLabel" + +----- +mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, + mkCmmCodeLabel, mkCmmClosureLabel + :: UnitId -> FastString -> CLabel + +mkCmmDataLabel :: UnitId -> NeedExternDecl -> FastString -> CLabel +mkRtsCmmDataLabel :: FastString -> CLabel + +mkCmmInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmInfo +mkCmmEntryLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmEntry +mkCmmRetInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo +mkCmmRetLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRet +mkCmmCodeLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmCode +mkCmmClosureLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmClosure +mkCmmDataLabel pkg ext str = CmmLabel pkg ext str CmmData +mkRtsCmmDataLabel str = CmmLabel rtsUnitId (NeedExternDecl False) str CmmData + -- RTS symbols don't need "GHC.CmmToC" to + -- generate \"extern\" declaration (they are + -- exposed via includes/Stg.h) + +mkLocalBlockLabel :: Unique -> CLabel +mkLocalBlockLabel u = LocalBlockLabel u + +-- Constructing RtsLabels +mkRtsPrimOpLabel :: PrimOp -> CLabel +mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) + +mkSelectorInfoLabel :: DynFlags -> Bool -> Int -> CLabel +mkSelectorInfoLabel dflags upd offset = + ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) + RtsLabel (RtsSelectorInfoTable upd offset) + +mkSelectorEntryLabel :: DynFlags -> Bool -> Int -> CLabel +mkSelectorEntryLabel dflags upd offset = + ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) + RtsLabel (RtsSelectorEntry upd offset) + +mkApInfoTableLabel :: DynFlags -> Bool -> Int -> CLabel +mkApInfoTableLabel dflags upd arity = + ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) + RtsLabel (RtsApInfoTable upd arity) + +mkApEntryLabel :: DynFlags -> Bool -> Int -> CLabel +mkApEntryLabel dflags upd arity = + ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) + RtsLabel (RtsApEntry upd arity) + + +-- A call to some primitive hand written Cmm code +mkPrimCallLabel :: PrimCall -> CLabel +mkPrimCallLabel (PrimCall str pkg) + = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall + + +-- Constructing ForeignLabels + +-- | Make a foreign label +mkForeignLabel + :: FastString -- name + -> Maybe Int -- size prefix + -> ForeignLabelSource -- what package it's in + -> FunctionOrData + -> CLabel + +mkForeignLabel = ForeignLabel + + +-- | Update the label size field in a ForeignLabel +addLabelSize :: CLabel -> Int -> CLabel +addLabelSize (ForeignLabel str _ src fod) sz + = ForeignLabel str (Just sz) src fod +addLabelSize label _ + = label + +-- | Whether label is a top-level string literal +isBytesLabel :: CLabel -> Bool +isBytesLabel (IdLabel _ _ Bytes) = True +isBytesLabel _lbl = False + +-- | Whether label is a non-haskell label (defined in C code) +isForeignLabel :: CLabel -> Bool +isForeignLabel (ForeignLabel _ _ _ _) = True +isForeignLabel _lbl = False + +-- | Whether label is a static closure label (can come from haskell or cmm) +isStaticClosureLabel :: CLabel -> Bool +-- Closure defined in haskell (.hs) +isStaticClosureLabel (IdLabel _ _ Closure) = True +-- Closure defined in cmm +isStaticClosureLabel (CmmLabel _ _ _ CmmClosure) = True +isStaticClosureLabel _lbl = False + +-- | Whether label is a .rodata label +isSomeRODataLabel :: CLabel -> Bool +-- info table defined in haskell (.hs) +isSomeRODataLabel (IdLabel _ _ ClosureTable) = True +isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True +isSomeRODataLabel (IdLabel _ _ InfoTable) = True +isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True +isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True +-- info table defined in cmm (.cmm) +isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True +isSomeRODataLabel _lbl = False + +-- | Whether label is points to some kind of info table +isInfoTableLabel :: CLabel -> Bool +isInfoTableLabel (IdLabel _ _ InfoTable) = True +isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True +isInfoTableLabel (IdLabel _ _ ConInfoTable) = True +isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True +isInfoTableLabel _ = False + +-- | Whether label is points to constructor info table +isConInfoTableLabel :: CLabel -> Bool +isConInfoTableLabel (IdLabel _ _ ConInfoTable) = True +isConInfoTableLabel _ = False + +-- | Get the label size field from a ForeignLabel +foreignLabelStdcallInfo :: CLabel -> Maybe Int +foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info +foreignLabelStdcallInfo _lbl = Nothing + + +-- Constructing Large*Labels +mkBitmapLabel :: Unique -> CLabel +mkBitmapLabel uniq = LargeBitmapLabel uniq + +-- Constructing Cost Center Labels +mkCCLabel :: CostCentre -> CLabel +mkCCSLabel :: CostCentreStack -> CLabel +mkCCLabel cc = CC_Label cc +mkCCSLabel ccs = CCS_Label ccs + +mkRtsApFastLabel :: FastString -> CLabel +mkRtsApFastLabel str = RtsLabel (RtsApFast str) + +mkRtsSlowFastTickyCtrLabel :: String -> CLabel +mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat) + + +-- Constructing Code Coverage Labels +mkHpcTicksLabel :: Module -> CLabel +mkHpcTicksLabel = HpcTicksLabel + + +-- Constructing labels used for dynamic linking +mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel +mkDynamicLinkerLabel = DynamicLinkerLabel + +dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) +dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) +dynamicLinkerLabelInfo _ = Nothing + +mkPicBaseLabel :: CLabel +mkPicBaseLabel = PicBaseLabel + + +-- Constructing miscellaneous other labels +mkDeadStripPreventer :: CLabel -> CLabel +mkDeadStripPreventer lbl = DeadStripPreventer lbl + +mkStringLitLabel :: Unique -> CLabel +mkStringLitLabel = StringLitLabel + +mkAsmTempLabel :: Uniquable a => a -> CLabel +mkAsmTempLabel a = AsmTempLabel (getUnique a) + +mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel +mkAsmTempDerivedLabel = AsmTempDerivedLabel + +mkAsmTempEndLabel :: CLabel -> CLabel +mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end") + +-- | Construct a label for a DWARF Debug Information Entity (DIE) +-- describing another symbol. +mkAsmTempDieLabel :: CLabel -> CLabel +mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die") + +-- ----------------------------------------------------------------------------- +-- Convert between different kinds of label + +toClosureLbl :: CLabel -> CLabel +toClosureLbl (IdLabel n c _) = IdLabel n c Closure +toClosureLbl (CmmLabel m ext str _) = CmmLabel m ext str CmmClosure +toClosureLbl l = pprPanic "toClosureLbl" (ppr l) + +toSlowEntryLbl :: CLabel -> CLabel +toSlowEntryLbl (IdLabel n _ BlockInfoTable) + = pprPanic "toSlowEntryLbl" (ppr n) +toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow +toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l) + +toEntryLbl :: CLabel -> CLabel +toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry +toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry +toEntryLbl (IdLabel n _ BlockInfoTable) = mkLocalBlockLabel (nameUnique n) + -- See Note [Proc-point local block entry-point]. +toEntryLbl (IdLabel n c _) = IdLabel n c Entry +toEntryLbl (CmmLabel m ext str CmmInfo) = CmmLabel m ext str CmmEntry +toEntryLbl (CmmLabel m ext str CmmRetInfo) = CmmLabel m ext str CmmRet +toEntryLbl l = pprPanic "toEntryLbl" (ppr l) + +toInfoLbl :: CLabel -> CLabel +toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable +toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable +toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable +toInfoLbl (CmmLabel m ext str CmmEntry)= CmmLabel m ext str CmmInfo +toInfoLbl (CmmLabel m ext str CmmRet) = CmmLabel m ext str CmmRetInfo +toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l) + +hasHaskellName :: CLabel -> Maybe Name +hasHaskellName (IdLabel n _ _) = Just n +hasHaskellName _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Does a CLabel's referent itself refer to a CAF? +hasCAF :: CLabel -> Bool +hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE] +hasCAF (IdLabel _ MayHaveCafRefs _) = True +hasCAF _ = False + +-- Note [ticky for LNE] +-- ~~~~~~~~~~~~~~~~~~~~~ + +-- Until 14 Feb 2013, every ticky counter was associated with a +-- closure. Thus, ticky labels used IdLabel. It is odd that +-- GHC.Cmm.Info.Build.cafTransfers would consider such a ticky label +-- reason to add the name to the CAFEnv (and thus eventually the SRT), +-- but it was harmless because the ticky was only used if the closure +-- was also. +-- +-- Since we now have ticky counters for LNEs, it is no longer the case +-- that every ticky counter has an actual closure. So I changed the +-- generation of ticky counters' CLabels to not result in their +-- associated id ending up in the SRT. +-- +-- NB IdLabel is still appropriate for ticky ids (as opposed to +-- CmmLabel) because the LNE's counter is still related to an .hs Id, +-- that Id just isn't for a proper closure. + +-- ----------------------------------------------------------------------------- +-- Does a CLabel need declaring before use or not? +-- +-- See wiki:commentary/compiler/backends/ppr-c#prototypes + +needsCDecl :: CLabel -> Bool + -- False <=> it's pre-declared; don't bother + -- don't bother declaring Bitmap labels, we always make sure + -- they are defined before use. +needsCDecl (SRTLabel _) = True +needsCDecl (LargeBitmapLabel _) = False +needsCDecl (IdLabel _ _ _) = True +needsCDecl (LocalBlockLabel _) = True + +needsCDecl (StringLitLabel _) = False +needsCDecl (AsmTempLabel _) = False +needsCDecl (AsmTempDerivedLabel _ _) = False +needsCDecl (RtsLabel _) = False + +needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _) + -- local labels mustn't have it + | not external = False + + -- Prototypes for labels defined in the runtime system are imported + -- into HC files via includes/Stg.h. + | pkgId == rtsUnitId = False + + -- For other labels we inline one into the HC file directly. + | otherwise = True + +needsCDecl l@(ForeignLabel{}) = not (isMathFun l) +needsCDecl (CC_Label _) = True +needsCDecl (CCS_Label _) = True +needsCDecl (HpcTicksLabel _) = True +needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel" +needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel" +needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer" + +-- | If a label is a local block label then return just its 'BlockId', otherwise +-- 'Nothing'. +maybeLocalBlockLabel :: CLabel -> Maybe BlockId +maybeLocalBlockLabel (LocalBlockLabel uq) = Just $ mkBlockId uq +maybeLocalBlockLabel _ = Nothing + + +-- | Check whether a label corresponds to a C function that has +-- a prototype in a system header somewhere, or is built-in +-- to the C compiler. For these labels we avoid generating our +-- own C prototypes. +isMathFun :: CLabel -> Bool +isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs +isMathFun _ = False + +math_funs :: UniqSet FastString +math_funs = mkUniqSet [ + -- _ISOC99_SOURCE + (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"), + (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"), + (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"), + (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"), + (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"), + (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"), + (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"), + (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"), + (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"), + (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"), + (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"), + (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"), + (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"), + (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"), + (fsLit "exp"), (fsLit "expf"), (fsLit "expl"), + (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"), + (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"), + (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"), + (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"), + (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"), + (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"), + (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"), + (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"), + (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"), + (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"), + (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"), + (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"), + (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"), + (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"), + (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"), + (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"), + (fsLit "log"), (fsLit "logf"), (fsLit "logl"), + (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"), + (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"), + (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"), + (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"), + (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"), + (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"), + (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"), + (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"), + (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"), + (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"), + (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"), + (fsLit "pow"), (fsLit "powf"), (fsLit "powl"), + (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"), + (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"), + (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"), + (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"), + (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"), + (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"), + (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"), + (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"), + (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"), + (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"), + (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"), + (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"), + (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"), + -- ISO C 99 also defines these function-like macros in math.h: + -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater, + -- isgreaterequal, isless, islessequal, islessgreater, isunordered + + -- additional symbols from _BSD_SOURCE + (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"), + (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"), + (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"), + (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"), + (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"), + (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"), + (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"), + (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"), + (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"), + (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"), + (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"), + (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"), + (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"), + (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl"), + + -- These functions are described in IEEE Std 754-2008 - + -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661 + (fsLit "nextup"), (fsLit "nextupf"), (fsLit "nextupl"), + (fsLit "nextdown"), (fsLit "nextdownf"), (fsLit "nextdownl") + ] + +-- ----------------------------------------------------------------------------- +-- | Is a CLabel visible outside this object file or not? +-- From the point of view of the code generator, a name is +-- externally visible if it has to be declared as exported +-- in the .o file's symbol table; that is, made non-static. +externallyVisibleCLabel :: CLabel -> Bool -- not C "static" +externallyVisibleCLabel (StringLitLabel _) = False +externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False +externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (LocalBlockLabel _) = False +externallyVisibleCLabel (CmmLabel _ _ _ _) = True +externallyVisibleCLabel (ForeignLabel{}) = True +externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info +externallyVisibleCLabel (CC_Label _) = True +externallyVisibleCLabel (CCS_Label _) = True +externallyVisibleCLabel (DynamicLinkerLabel _ _) = False +externallyVisibleCLabel (HpcTicksLabel _) = True +externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (SRTLabel _) = False +externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" +externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" + +externallyVisibleIdLabel :: IdLabelInfo -> Bool +externallyVisibleIdLabel LocalInfoTable = False +externallyVisibleIdLabel LocalEntry = False +externallyVisibleIdLabel BlockInfoTable = False +externallyVisibleIdLabel _ = True + +-- ----------------------------------------------------------------------------- +-- Finding the "type" of a CLabel + +-- For generating correct types in label declarations: + +data CLabelType + = CodeLabel -- Address of some executable instructions + | DataLabel -- Address of data, not a GC ptr + | GcPtrLabel -- Address of a (presumably static) GC object + +isCFunctionLabel :: CLabel -> Bool +isCFunctionLabel lbl = case labelType lbl of + CodeLabel -> True + _other -> False + +isGcPtrLabel :: CLabel -> Bool +isGcPtrLabel lbl = case labelType lbl of + GcPtrLabel -> True + _other -> False + + +-- | Work out the general type of data at the address of this label +-- whether it be code, data, or static GC object. +labelType :: CLabel -> CLabelType +labelType (IdLabel _ _ info) = idInfoLabelType info +labelType (CmmLabel _ _ _ CmmData) = DataLabel +labelType (CmmLabel _ _ _ CmmClosure) = GcPtrLabel +labelType (CmmLabel _ _ _ CmmCode) = CodeLabel +labelType (CmmLabel _ _ _ CmmInfo) = DataLabel +labelType (CmmLabel _ _ _ CmmEntry) = CodeLabel +labelType (CmmLabel _ _ _ CmmPrimCall) = CodeLabel +labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel +labelType (CmmLabel _ _ _ CmmRet) = CodeLabel +labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApFast _)) = CodeLabel +labelType (RtsLabel _) = DataLabel +labelType (LocalBlockLabel _) = CodeLabel +labelType (SRTLabel _) = DataLabel +labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel +labelType (ForeignLabel _ _ _ IsData) = DataLabel +labelType (AsmTempLabel _) = panic "labelType(AsmTempLabel)" +labelType (AsmTempDerivedLabel _ _) = panic "labelType(AsmTempDerivedLabel)" +labelType (StringLitLabel _) = DataLabel +labelType (CC_Label _) = DataLabel +labelType (CCS_Label _) = DataLabel +labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right? +labelType PicBaseLabel = DataLabel +labelType (DeadStripPreventer _) = DataLabel +labelType (HpcTicksLabel _) = DataLabel +labelType (LargeBitmapLabel _) = DataLabel + +idInfoLabelType :: IdLabelInfo -> CLabelType +idInfoLabelType info = + case info of + InfoTable -> DataLabel + LocalInfoTable -> DataLabel + BlockInfoTable -> DataLabel + Closure -> GcPtrLabel + ConInfoTable -> DataLabel + ClosureTable -> DataLabel + RednCounts -> DataLabel + Bytes -> DataLabel + _ -> CodeLabel + + +-- ----------------------------------------------------------------------------- + +-- | Is a 'CLabel' defined in the current module being compiled? +-- +-- Sometimes we can optimise references within a compilation unit in ways that +-- we couldn't for inter-module references. This provides a conservative +-- estimate of whether a 'CLabel' lives in the current module. +isLocalCLabel :: Module -> CLabel -> Bool +isLocalCLabel this_mod lbl = + case lbl of + IdLabel name _ _ + | isInternalName name -> True + | otherwise -> nameModule name == this_mod + LocalBlockLabel _ -> True + _ -> False + +-- ----------------------------------------------------------------------------- + +-- | Does a 'CLabel' need dynamic linkage? +-- +-- When referring to data in code, we need to know whether +-- that data resides in a DLL or not. [Win32 only.] +-- @labelDynamic@ returns @True@ if the label is located +-- in a DLL, be it a data reference or not. +labelDynamic :: NCGConfig -> Module -> CLabel -> Bool +labelDynamic config this_mod lbl = + case lbl of + -- is the RTS in a DLL or not? + RtsLabel _ -> + externalDynamicRefs && (this_pkg /= rtsUnit) + + IdLabel n _ _ -> + externalDynamicRefs && isDynLinkName platform this_mod n + + -- When compiling in the "dyn" way, each package is to be linked into + -- its own shared library. + CmmLabel pkg _ _ _ + | os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg) + | otherwise -> externalDynamicRefs + + LocalBlockLabel _ -> False + + ForeignLabel _ _ source _ -> + if os == OSMinGW32 + then case source of + -- Foreign label is in some un-named foreign package (or DLL). + ForeignLabelInExternalPackage -> True + + -- Foreign label is linked into the same package as the + -- source file currently being compiled. + ForeignLabelInThisPackage -> False + + -- Foreign label is in some named package. + -- When compiling in the "dyn" way, each package is to be + -- linked into its own DLL. + ForeignLabelInPackage pkgId -> + externalDynamicRefs && (this_pkg /= pkgId) + + else -- On Mac OS X and on ELF platforms, false positives are OK, + -- so we claim that all foreign imports come from dynamic + -- libraries + True + + CC_Label cc -> + externalDynamicRefs && not (ccFromThisModule cc this_mod) + + -- CCS_Label always contains a CostCentre defined in the current module + CCS_Label _ -> False + + HpcTicksLabel m -> + externalDynamicRefs && this_mod /= m + + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. + _ -> False + where + externalDynamicRefs = ncgExternalDynamicRefs config + platform = ncgPlatform config + os = platformOS platform + this_pkg = moduleUnit this_mod + + +----------------------------------------------------------------------------- +-- Printing out CLabels. + +{- +Convention: + + _ + +where is _ for external names and for +internal names. is one of the following: + + info Info table + srt Static reference table + entry Entry code (function, closure) + slow Slow entry code (if any) + ret Direct return address + vtbl Vector table + _alt Case alternative (tag n) + dflt Default case alternative + btm Large bitmap vector + closure Static closure + con_entry Dynamic Constructor entry code + con_info Dynamic Constructor info table + static_entry Static Constructor entry code + static_info Static Constructor info table + sel_info Selector info table + sel_entry Selector entry code + cc Cost centre + ccs Cost centre stack + +Many of these distinctions are only for documentation reasons. For +example, _ret is only distinguished from _entry to make it easy to +tell whether a code fragment is a return point or a closure/function +entry. + +Note [Closure and info labels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a function 'foo, we have: + foo_info : Points to the info table describing foo's closure + (and entry code for foo with tables next to code) + foo_closure : Static (no-free-var) closure only: + points to the statically-allocated closure + +For a data constructor (such as Just or Nothing), we have: + Just_con_info: Info table for the data constructor itself + the first word of a heap-allocated Just + Just_info: Info table for the *worker function*, an + ordinary Haskell function of arity 1 that + allocates a (Just x) box: + Just = \x -> Just x + Just_closure: The closure for this worker + + Nothing_closure: a statically allocated closure for Nothing + Nothing_static_info: info table for Nothing_closure + +All these must be exported symbol, EXCEPT Just_info. We don't need to +export this because in other modules we either have + * A reference to 'Just'; use Just_closure + * A saturated call 'Just x'; allocate using Just_con_info +Not exporting these Just_info labels reduces the number of symbols +somewhat. + +Note [Bytes label] +~~~~~~~~~~~~~~~~~~ +For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which +points to a static data block containing the content of the literal. + +Note [Proc-point local block entry-points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A label for a proc-point local block entry-point has no "_entry" suffix. With +`infoTblLbl` we derive an info table label from a proc-point block ID. If +we convert such an info table label into an entry label we must produce +the label without an "_entry" suffix. So an info table label records +the fact that it was derived from a block ID in `IdLabelInfo` as +`BlockInfoTable`. + +The info table label and the local block label are both local labels +and are not externally visible. +-} + +instance Outputable CLabel where + ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c + +pprCLabel :: DynFlags -> CLabel -> SDoc +pprCLabel dflags = \case + (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u + + (AsmTempLabel u) + | not (platformUnregisterised platform) + -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u + + (AsmTempDerivedLabel l suf) + | useNCG + -> ptext (asmTempLabelPrefix platform) + <> case l of AsmTempLabel u -> pprUniqueAlways u + LocalBlockLabel u -> pprUniqueAlways u + _other -> pprCLabel dflags l + <> ftext suf + + (DynamicLinkerLabel info lbl) + | useNCG + -> pprDynamicLinkerAsmLabel platform info lbl + + PicBaseLabel + | useNCG + -> text "1b" + + (DeadStripPreventer lbl) + | useNCG + -> + {- + `lbl` can be temp one but we need to ensure that dsp label will stay + in the final binary so we prepend non-temp prefix ("dsp_") and + optional `_` (underscore) because this is how you mark non-temp symbols + on some platforms (Darwin) + -} + maybe_underscore $ text "dsp_" <> pprCLabel dflags lbl <> text "_dsp" + + (StringLitLabel u) + | useNCG + -> pprUniqueAlways u <> ptext (sLit "_str") + + lbl -> getPprStyle $ \sty -> + if useNCG && asmStyle sty + then maybe_underscore $ pprAsmCLbl lbl + else pprCLbl platform lbl + + where + platform = targetPlatform dflags + useNCG = hscTarget dflags == HscAsm + + maybe_underscore :: SDoc -> SDoc + maybe_underscore doc = + if platformLeadingUnderscore platform + then pp_cSEP <> doc + else doc + + pprAsmCLbl (ForeignLabel fs (Just sz) _ _) + | platformOS platform == OSMinGW32 + -- In asm mode, we need to put the suffix on a stdcall ForeignLabel. + -- (The C compiler does this itself). + = ftext fs <> char '@' <> int sz + pprAsmCLbl lbl = pprCLbl platform lbl + +pprCLbl :: Platform -> CLabel -> SDoc +pprCLbl platform = \case + (StringLitLabel u) -> pprUniqueAlways u <> text "_str" + (SRTLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt" + (LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform + <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm" + -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7') + -- until that gets resolved we'll just force them to start + -- with a letter so the label will be legal assembly code. + + (CmmLabel _ _ str CmmCode) -> ftext str + (CmmLabel _ _ str CmmData) -> ftext str + (CmmLabel _ _ str CmmPrimCall) -> ftext str + + (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u + + (RtsLabel (RtsApFast str)) -> ftext str <> text "_fast" + + (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) -> + hcat [text "stg_sel_", text (show offset), + ptext (if upd_reqd + then (sLit "_upd_info") + else (sLit "_noupd_info")) + ] + + (RtsLabel (RtsSelectorEntry upd_reqd offset)) -> + hcat [text "stg_sel_", text (show offset), + ptext (if upd_reqd + then (sLit "_upd_entry") + else (sLit "_noupd_entry")) + ] + + (RtsLabel (RtsApInfoTable upd_reqd arity)) -> + hcat [text "stg_ap_", text (show arity), + ptext (if upd_reqd + then (sLit "_upd_info") + else (sLit "_noupd_info")) + ] + + (RtsLabel (RtsApEntry upd_reqd arity)) -> + hcat [text "stg_ap_", text (show arity), + ptext (if upd_reqd + then (sLit "_upd_entry") + else (sLit "_noupd_entry")) + ] + + (CmmLabel _ _ fs CmmInfo) -> ftext fs <> text "_info" + (CmmLabel _ _ fs CmmEntry) -> ftext fs <> text "_entry" + (CmmLabel _ _ fs CmmRetInfo) -> ftext fs <> text "_info" + (CmmLabel _ _ fs CmmRet) -> ftext fs <> text "_ret" + (CmmLabel _ _ fs CmmClosure) -> ftext fs <> text "_closure" + + (RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop + (RtsLabel (RtsSlowFastTickyCtr pat)) -> + text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr") + + (ForeignLabel str _ _ _) -> ftext str + + (IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor + + (CC_Label cc) -> ppr cc + (CCS_Label ccs) -> ppr ccs + (HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc") + + (AsmTempLabel {}) -> panic "pprCLbl AsmTempLabel" + (AsmTempDerivedLabel {}) -> panic "pprCLbl AsmTempDerivedLabel" + (DynamicLinkerLabel {}) -> panic "pprCLbl DynamicLinkerLabel" + (PicBaseLabel {}) -> panic "pprCLbl PicBaseLabel" + (DeadStripPreventer {}) -> panic "pprCLbl DeadStripPreventer" + +ppIdFlavor :: IdLabelInfo -> SDoc +ppIdFlavor x = pp_cSEP <> text + (case x of + Closure -> "closure" + InfoTable -> "info" + LocalInfoTable -> "info" + Entry -> "entry" + LocalEntry -> "entry" + Slow -> "slow" + RednCounts -> "ct" + ConEntry -> "con_entry" + ConInfoTable -> "con_info" + ClosureTable -> "closure_tbl" + Bytes -> "bytes" + BlockInfoTable -> "info" + ) + + +pp_cSEP :: SDoc +pp_cSEP = char '_' + + +instance Outputable ForeignLabelSource where + ppr fs + = case fs of + ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId + ForeignLabelInThisPackage -> parens $ text "this package" + ForeignLabelInExternalPackage -> parens $ text "external package" + +internalNamePrefix :: Platform -> Name -> SDoc +internalNamePrefix platform name = getPprStyle $ \ sty -> + if asmStyle sty && isRandomGenerated then + ptext (asmTempLabelPrefix platform) + else + empty + where + isRandomGenerated = not $ isExternalName name + +tempLabelPrefixOrUnderscore :: Platform -> SDoc +tempLabelPrefixOrUnderscore platform = + getPprStyle $ \ sty -> + if asmStyle sty then + ptext (asmTempLabelPrefix platform) + else + char '_' + +-- ----------------------------------------------------------------------------- +-- Machine-dependent knowledge about labels. + +asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels +asmTempLabelPrefix platform = case platformOS platform of + OSDarwin -> sLit "L" + OSAIX -> sLit "__L" -- follow IBM XL C's convention + _ -> sLit ".L" + +pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc +pprDynamicLinkerAsmLabel platform dllInfo lbl = + case platformOS platform of + OSDarwin + | platformArch platform == ArchX86_64 -> + case dllInfo of + CodeStub -> char 'L' <> ppr lbl <> text "$stub" + SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" + GotSymbolPtr -> ppr lbl <> text "@GOTPCREL" + GotSymbolOffset -> ppr lbl + | otherwise -> + case dllInfo of + CodeStub -> char 'L' <> ppr lbl <> text "$stub" + SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" + _ -> panic "pprDynamicLinkerAsmLabel" + + OSAIX -> + case dllInfo of + SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention + _ -> panic "pprDynamicLinkerAsmLabel" + + _ | osElfTarget (platformOS platform) -> elfLabel + + OSMinGW32 -> + case dllInfo of + SymbolPtr -> text "__imp_" <> ppr lbl + _ -> panic "pprDynamicLinkerAsmLabel" + + _ -> panic "pprDynamicLinkerAsmLabel" + where + elfLabel + | platformArch platform == ArchPPC + = case dllInfo of + CodeStub -> -- See Note [.LCTOC1 in PPC PIC code] + ppr lbl <> text "+32768@plt" + SymbolPtr -> text ".LC_" <> ppr lbl + _ -> panic "pprDynamicLinkerAsmLabel" + + | platformArch platform == ArchX86_64 + = case dllInfo of + CodeStub -> ppr lbl <> text "@plt" + GotSymbolPtr -> ppr lbl <> text "@gotpcrel" + GotSymbolOffset -> ppr lbl + SymbolPtr -> text ".LC_" <> ppr lbl + + | platformArch platform == ArchPPC_64 ELF_V1 + || platformArch platform == ArchPPC_64 ELF_V2 + = case dllInfo of + GotSymbolPtr -> text ".LC_" <> ppr lbl + <> text "@toc" + GotSymbolOffset -> ppr lbl + SymbolPtr -> text ".LC_" <> ppr lbl + _ -> panic "pprDynamicLinkerAsmLabel" + + | otherwise + = case dllInfo of + CodeStub -> ppr lbl <> text "@plt" + SymbolPtr -> text ".LC_" <> ppr lbl + GotSymbolPtr -> ppr lbl <> text "@got" + GotSymbolOffset -> ppr lbl <> text "@gotoff" + +-- Figure out whether `symbol` may serve as an alias +-- to `target` within one compilation unit. +-- +-- This is true if any of these holds: +-- * `target` is a module-internal haskell name. +-- * `target` is an exported name, but comes from the same +-- module as `symbol` +-- +-- These are sufficient conditions for establishing e.g. a +-- GNU assembly alias ('.equiv' directive). Sadly, there is +-- no such thing as an alias to an imported symbol (conf. +-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/) +-- See note [emit-time elimination of static indirections]. +-- +-- Precondition is that both labels represent the +-- same semantic value. + +mayRedirectTo :: CLabel -> CLabel -> Bool +mayRedirectTo symbol target + | Just nam <- haskellName + , staticClosureLabel + , isExternalName nam + , Just mod <- nameModule_maybe nam + , Just anam <- hasHaskellName symbol + , Just amod <- nameModule_maybe anam + = amod == mod + + | Just nam <- haskellName + , staticClosureLabel + , isInternalName nam + = True + + | otherwise = False + where staticClosureLabel = isStaticClosureLabel target + haskellName = hasHaskellName target + + +{- +Note [emit-time elimination of static indirections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in #15155, certain static values are representationally +equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers). + + newtype A = A Int + {-# NOINLINE a #-} + a = A 42 + +a1_rYB :: Int +[GblId, Caf=NoCafRefs, Unf=OtherCon []] +a1_rYB = GHC.Types.I# 42# + +a [InlPrag=NOINLINE] :: A +[GblId, Unf=OtherCon []] +a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A) + +Formerly we created static indirections for these (IND_STATIC), which +consist of a statically allocated forwarding closure that contains +the (possibly tagged) indirectee. (See CMM/assembly below.) +This approach is suboptimal for two reasons: + (a) they occupy extra space, + (b) they need to be entered in order to obtain the indirectee, + thus they cannot be tagged. + +Fortunately there is a common case where static indirections can be +eliminated while emitting assembly (native or LLVM), viz. when the +indirectee is in the same module (object file) as the symbol that +points to it. In this case an assembly-level identification can +be created ('.equiv' directive), and as such the same object will +be assigned two names in the symbol table. Any of the identified +symbols can be referenced by a tagged pointer. + +Currently the 'mayRedirectTo' predicate will +give a clue whether a label can be equated with another, already +emitted, label (which can in turn be an alias). The general mechanics +is that we identify data (IND_STATIC closures) that are amenable +to aliasing while pretty-printing of assembly output, and emit the +'.equiv' directive instead of static data in such a case. + +Here is a sketch how the output is massaged: + + Consider +newtype A = A Int +{-# NOINLINE a #-} +a = A 42 -- I# 42# is the indirectee + -- 'a' is exported + + results in STG + +a1_rXq :: GHC.Types.Int +[GblId, Caf=NoCafRefs, Unf=OtherCon []] = + CCS_DONT_CARE GHC.Types.I#! [42#]; + +T15155.a [InlPrag=NOINLINE] :: T15155.A +[GblId, Unf=OtherCon []] = + CAF_ccs \ u [] a1_rXq; + + and CMM + +[section ""data" . a1_rXq_closure" { + a1_rXq_closure: + const GHC.Types.I#_con_info; + const 42; + }] + +[section ""data" . T15155.a_closure" { + T15155.a_closure: + const stg_IND_STATIC_info; + const a1_rXq_closure+1; + const 0; + const 0; + }] + +The emitted assembly is + +#### INDIRECTEE +a1_rXq_closure: -- module local haskell value + .quad GHC.Types.I#_con_info -- an Int + .quad 42 + +#### BEFORE +.globl T15155.a_closure -- exported newtype wrapped value +T15155.a_closure: + .quad stg_IND_STATIC_info -- the closure info + .quad a1_rXq_closure+1 -- indirectee ('+1' being the tag) + .quad 0 + .quad 0 + +#### AFTER +.globl T15155.a_closure -- exported newtype wrapped value +.equiv a1_rXq_closure,T15155.a_closure -- both are shared + +The transformation is performed because + T15155.a_closure `mayRedirectTo` a1_rXq_closure+1 +returns True. +-} diff --git a/GHC/Cmm/CallConv.hs b/GHC/Cmm/CallConv.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/CallConv.hs @@ -0,0 +1,218 @@ +module GHC.Cmm.CallConv ( + ParamLocation(..), + assignArgumentsPos, + assignStack, + realArgRegsCover +) where + +import GHC.Prelude + +import GHC.Cmm.Expr +import GHC.Runtime.Heap.Layout +import GHC.Cmm (Convention(..)) +import GHC.Cmm.Ppr () -- For Outputable instances + +import GHC.Driver.Session +import GHC.Platform +import GHC.Utils.Outputable + +-- Calculate the 'GlobalReg' or stack locations for function call +-- parameters as used by the Cmm calling convention. + +data ParamLocation + = RegisterParam GlobalReg + | StackParam ByteOff + +instance Outputable ParamLocation where + ppr (RegisterParam g) = ppr g + ppr (StackParam p) = ppr p + +-- | +-- Given a list of arguments, and a function that tells their types, +-- return a list showing where each argument is passed +-- +assignArgumentsPos :: DynFlags + -> ByteOff -- stack offset to start with + -> Convention + -> (a -> CmmType) -- how to get a type from an arg + -> [a] -- args + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) + +assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) + where + platform = targetPlatform dflags + regs = case (reps, conv) of + (_, NativeNodeCall) -> getRegsWithNode dflags + (_, NativeDirectCall) -> getRegsWithoutNode dflags + ([_], NativeReturn) -> allRegs dflags + (_, NativeReturn) -> getRegsWithNode dflags + -- GC calling convention *must* put values in registers + (_, GC) -> allRegs dflags + (_, Slow) -> nodeOnly + -- The calling conventions first assign arguments to registers, + -- then switch to the stack when we first run out of registers + -- (even if there are still available registers for args of a + -- different type). When returning an unboxed tuple, we also + -- separate the stack arguments by pointerhood. + (reg_assts, stk_args) = assign_regs [] reps regs + (stk_off, stk_assts) = assignStack platform off arg_ty stk_args + assignments = reg_assts ++ stk_assts + + assign_regs assts [] _ = (assts, []) + assign_regs assts (r:rs) regs | isVecType ty = vec + | isFloatType ty = float + | otherwise = int + where vec = case (w, regs) of + (W128, (vs, fs, ds, ls, s:ss)) + | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) + (W256, (vs, fs, ds, ls, s:ss)) + | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) + (W512, (vs, fs, ds, ls, s:ss)) + | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) + _ -> (assts, (r:rs)) + float = case (w, regs) of + (W32, (vs, fs, ds, ls, s:ss)) + | passFloatInXmm -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) + (W32, (vs, f:fs, ds, ls, ss)) + | not passFloatInXmm -> k (RegisterParam f, (vs, fs, ds, ls, ss)) + (W64, (vs, fs, ds, ls, s:ss)) + | passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) + (W64, (vs, fs, d:ds, ls, ss)) + | not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss)) + _ -> (assts, (r:rs)) + int = case (w, regs) of + (W128, _) -> panic "W128 unsupported register type" + (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform) + -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) + (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform) + -> k (RegisterParam l, (vs, fs, ds, ls, ss)) + _ -> (assts, (r:rs)) + k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' + ty = arg_ty r + w = typeWidth ty + gcp | isGcPtrType ty = VGcPtr + | otherwise = VNonGcPtr + passFloatInXmm = passFloatArgsInXmm platform + +passFloatArgsInXmm :: Platform -> Bool +passFloatArgsInXmm platform = case platformArch platform of + ArchX86_64 -> True + ArchX86 -> False + _ -> False + +-- We used to spill vector registers to the stack since the LLVM backend didn't +-- support vector registers in its calling convention. However, this has now +-- been fixed. This function remains only as a convenient way to re-enable +-- spilling when debugging code generation. +passVectorInReg :: Width -> DynFlags -> Bool +passVectorInReg _ _ = True + +assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a] + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) +assignStack platform offset arg_ty args = assign_stk offset [] (reverse args) + where + assign_stk offset assts [] = (offset, assts) + assign_stk offset assts (r:rs) + = assign_stk off' ((r, StackParam off') : assts) rs + where w = typeWidth (arg_ty r) + off' = offset + size + -- Stack arguments always take a whole number of words, we never + -- pack them unlike constructor fields. + size = roundUpToWords platform (widthInBytes w) + +----------------------------------------------------------------------------- +-- Local information about the registers available + +type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. + , [GlobalReg] -- floats + , [GlobalReg] -- doubles + , [GlobalReg] -- longs (int64 and word64) + , [Int] -- XMM (floats and doubles) + ) + +-- Vanilla registers can contain pointers, Ints, Chars. +-- Floats and doubles have separate register supplies. +-- +-- We take these register supplies from the *real* registers, i.e. those +-- that are guaranteed to map to machine registers. + +getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs +getRegsWithoutNode dflags = + ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) + , realFloatRegs dflags + , realDoubleRegs dflags + , realLongRegs dflags + , realXmmRegNos dflags) + +-- getRegsWithNode uses R1/node even if it isn't a register +getRegsWithNode dflags = + ( if null (realVanillaRegs dflags) + then [VanillaReg 1] + else realVanillaRegs dflags + , realFloatRegs dflags + , realDoubleRegs dflags + , realLongRegs dflags + , realXmmRegNos dflags) + +allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] +allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] +allXmmRegs :: DynFlags -> [Int] + +allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) +allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) +allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) +allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) +allXmmRegs dflags = regList (mAX_XMM_REG dflags) + +realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] +realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] +realXmmRegNos :: DynFlags -> [Int] + +realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags) +realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) +realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) +realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) + +realXmmRegNos dflags + | isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags) + | otherwise = [] + +regList :: Int -> [Int] +regList n = [1 .. n] + +allRegs :: DynFlags -> AvailRegs +allRegs dflags = (allVanillaRegs dflags, + allFloatRegs dflags, + allDoubleRegs dflags, + allLongRegs dflags, + allXmmRegs dflags) + +nodeOnly :: AvailRegs +nodeOnly = ([VanillaReg 1], [], [], [], []) + +-- This returns the set of global registers that *cover* the machine registers +-- used for argument passing. On platforms where registers can overlap---right +-- now just x86-64, where Float and Double registers overlap---passing this set +-- of registers is guaranteed to preserve the contents of all live registers. We +-- only use this functionality in hand-written C-- code in the RTS. +realArgRegsCover :: DynFlags -> [GlobalReg] +realArgRegsCover dflags + | passFloatArgsInXmm (targetPlatform dflags) + = map ($VGcPtr) (realVanillaRegs dflags) ++ + realLongRegs dflags ++ + realDoubleRegs dflags -- we only need to save the low Double part of XMM registers. + -- Moreover, the NCG can't load/store full XMM + -- registers for now... + + | otherwise + = map ($VGcPtr) (realVanillaRegs dflags) ++ + realFloatRegs dflags ++ + realDoubleRegs dflags ++ + realLongRegs dflags + -- we don't save XMM registers if they are not used for parameter passing diff --git a/GHC/Cmm/CommonBlockElim.hs b/GHC/Cmm/CommonBlockElim.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/CommonBlockElim.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-} + +module GHC.Cmm.CommonBlockElim + ( elimCommonBlocks + ) +where + + +import GHC.Prelude hiding (iterate, succ, unzip, zip) + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch (eqSwitchTargetWith) +import GHC.Cmm.ContFlowOpt + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Collections +import Data.Bits +import Data.Maybe (mapMaybe) +import qualified Data.List as List +import Data.Word +import qualified Data.Map as M +import GHC.Utils.Outputable +import qualified GHC.Data.TrieMap as TM +import GHC.Types.Unique.FM +import GHC.Types.Unique +import Control.Arrow (first, second) + +-- ----------------------------------------------------------------------------- +-- Eliminate common blocks + +-- If two blocks are identical except for the label on the first node, +-- then we can eliminate one of the blocks. To ensure that the semantics +-- of the program are preserved, we have to rewrite each predecessor of the +-- eliminated block to proceed with the block we keep. + +-- The algorithm iterates over the blocks in the graph, +-- checking whether it has seen another block that is equal modulo labels. +-- If so, then it adds an entry in a map indicating that the new block +-- is made redundant by the old block. +-- Otherwise, it is added to the useful blocks. + +-- To avoid comparing every block with every other block repeatedly, we group +-- them by +-- * a hash of the block, ignoring labels (explained below) +-- * the list of outgoing labels +-- The hash is invariant under relabeling, so we only ever compare within +-- the same group of blocks. +-- +-- The list of outgoing labels is updated as we merge blocks (that is why they +-- are not included in the hash, which we want to calculate only once). +-- +-- All in all, two blocks should never be compared if they have different +-- hashes, and at most once otherwise. Previously, we were slower, and people +-- rightfully complained: #10397 + +-- TODO: Use optimization fuel +elimCommonBlocks :: CmmGraph -> CmmGraph +elimCommonBlocks g = replaceLabels env $ copyTicks env g + where + env = iterate mapEmpty blocks_with_key + -- The order of blocks doesn't matter here. While we could use + -- revPostorder which drops unreachable blocks this is done in + -- ContFlowOpt already which runs before this pass. So we use + -- toBlockList since it is faster. + groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]] + blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] + +-- Invariant: The blocks in the list are pairwise distinct +-- (so avoid comparing them again) +type DistinctBlocks = [CmmBlock] +type Key = [Label] +type Subst = LabelMap BlockId + +-- The outer list groups by hash. We retain this grouping throughout. +iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst +iterate subst blocks + | mapNull new_substs = subst + | otherwise = iterate subst' updated_blocks + where + grouped_blocks :: [[(Key, [DistinctBlocks])]] + grouped_blocks = map groupByLabel blocks + + merged_blocks :: [[(Key, DistinctBlocks)]] + (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks + where + go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db)) + where + (new_subst2, db) = mergeBlockList subst dbs + + subst' = subst `mapUnion` new_substs + updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks + +-- Combine two lists of blocks. +-- While they are internally distinct they can still share common blocks. +mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks) +mergeBlocks subst existing new = go new + where + go [] = (mapEmpty, existing) + go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of + -- This block is a duplicate. Drop it, and add it to the substitution + Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs + -- This block is not a duplicate, keep it. + Nothing -> second (b:) $ go bs + +mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks) +mergeBlockList _ [] = pprPanic "mergeBlockList" empty +mergeBlockList subst (b:bs) = go mapEmpty b bs + where + go !new_subst1 b [] = (new_subst1, b) + go !new_subst1 b1 (b2:bs) = go new_subst b bs + where + (new_subst2, b) = mergeBlocks subst b1 b2 + new_subst = new_subst1 `mapUnion` new_subst2 + + +-- ----------------------------------------------------------------------------- +-- Hashing and equality on blocks + +-- Below here is mostly boilerplate: hashing blocks ignoring labels, +-- and comparing blocks modulo a label mapping. + +-- To speed up comparisons, we hash each basic block modulo jump labels. +-- The hashing is a bit arbitrary (the numbers are completely arbitrary), +-- but it should be fast and good enough. + +-- We want to get as many small buckets as possible, as comparing blocks is +-- expensive. So include as much as possible in the hash. Ideally everything +-- that is compared with (==) in eqBlockBodyWith. + +type HashCode = Int + +hash_block :: CmmBlock -> HashCode +hash_block block = + fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) + -- UniqFM doesn't like negative Ints + where hash_fst _ h = h + hash_mid m h = hash_node m + h `shiftL` 1 + hash_lst m h = hash_node m + h `shiftL` 1 + + hash_node :: CmmNode O x -> Word32 + hash_node n | dont_care n = 0 -- don't care + hash_node (CmmAssign r e) = hash_reg r + hash_e e + hash_node (CmmStore e e') = hash_e e + hash_e e' + hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as + hash_node (CmmBranch _) = 23 -- NB. ignore the label + hash_node (CmmCondBranch p _ _ _) = hash_e p + hash_node (CmmCall e _ _ _ _ _) = hash_e e + hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t + hash_node (CmmSwitch e _) = hash_e e + hash_node _ = error "hash_node: unknown Cmm node!" + + hash_reg :: CmmReg -> Word32 + hash_reg (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397 + hash_reg (CmmGlobal _) = 19 + + hash_e :: CmmExpr -> Word32 + hash_e (CmmLit l) = hash_lit l + hash_e (CmmLoad e _) = 67 + hash_e e + hash_e (CmmReg r) = hash_reg r + hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check + hash_e (CmmRegOff r i) = hash_reg r + cvt i + hash_e (CmmStackSlot _ _) = 13 + + hash_lit :: CmmLit -> Word32 + hash_lit (CmmInt i _) = fromInteger i + hash_lit (CmmFloat r _) = truncate r + hash_lit (CmmVec ls) = hash_list hash_lit ls + hash_lit (CmmLabel _) = 119 -- ugh + hash_lit (CmmLabelOff _ i) = cvt $ 199 + i + hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i + hash_lit (CmmBlock _) = 191 -- ugh + hash_lit (CmmHighStackMark) = cvt 313 + + hash_tgt (ForeignTarget e _) = hash_e e + hash_tgt (PrimTarget _) = 31 -- lots of these + + hash_list f = foldl' (\z x -> f x + z) (0::Word32) + + cvt = fromInteger . toInteger + + hash_unique :: Uniquable a => a -> Word32 + hash_unique = cvt . getKey . getUnique + +-- | Ignore these node types for equality +dont_care :: CmmNode O x -> Bool +dont_care CmmComment {} = True +dont_care CmmTick {} = True +dont_care CmmUnwind {} = True +dont_care _other = False + +-- Utilities: equality and substitution on the graph. + +-- Given a map ``subst'' from BlockID -> BlockID, we define equality. +eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool +eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' +lookupBid :: LabelMap BlockId -> BlockId -> BlockId +lookupBid subst bid = case mapLookup bid subst of + Just bid -> lookupBid subst bid + Nothing -> bid + +-- Middle nodes and expressions can contain BlockIds, in particular in +-- CmmStackSlot and CmmBlock, so we have to use a special equality for +-- these. +-- +eqMiddleWith :: (BlockId -> BlockId -> Bool) + -> CmmNode O O -> CmmNode O O -> Bool +eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2) + = r1 == r2 && eqExprWith eqBid e1 e2 +eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2) + = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 +eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) + (CmmUnsafeForeignCall t2 r2 a2) + = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2 +eqMiddleWith _ _ _ = False + +eqExprWith :: (BlockId -> BlockId -> Bool) + -> CmmExpr -> CmmExpr -> Bool +eqExprWith eqBid = eq + where + CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2 + CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2 + CmmReg r1 `eq` CmmReg r2 = r1==r2 + CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2 + CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 + _e1 `eq` _e2 = False + + xs `eqs` ys = eqListWith eq xs ys + + eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 + eqLit l1 l2 = l1 == l2 + + eqArea Old Old = True + eqArea (Young id1) (Young id2) = eqBid id1 id2 + eqArea _ _ = False + +-- Equality on the body of a block, modulo a function mapping block +-- IDs to block IDs. +eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool +eqBlockBodyWith eqBid block block' + {- + | equal = pprTrace "equal" (vcat [ppr block, ppr block']) True + | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False + -} + = equal + where (_,m,l) = blockSplit block + nodes = filter (not . dont_care) (blockToList m) + (_,m',l') = blockSplit block' + nodes' = filter (not . dont_care) (blockToList m') + + equal = eqListWith (eqMiddleWith eqBid) nodes nodes' && + eqLastWith eqBid l l' + + +eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool +eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 +eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) = + c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2 +eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) = + t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 +eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) = + e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2 +eqLastWith _ _ _ = False + +eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool +eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' +eqMaybeWith _ Nothing Nothing = True +eqMaybeWith _ _ _ = False + +eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool +eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs +eqListWith _ [] [] = True +eqListWith _ _ _ = False + +-- | Given a block map, ensure that all "target" blocks are covered by +-- the same ticks as the respective "source" blocks. This not only +-- means copying ticks, but also adjusting tick scopes where +-- necessary. +copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph +copyTicks env g + | mapNull env = g + | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap + where -- Reverse block merge map + blockMap = toBlockMap g + revEnv = mapFoldlWithKey insertRev M.empty env + insertRev m k x = M.insertWith (const (k:)) x [k] m + -- Copy ticks and scopes into the given block + copyTo block = case M.lookup (entryLabel block) revEnv of + Nothing -> block + Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls + copy from to = + let ticks = blockTicks from + CmmEntry _ scp0 = firstNode from + (CmmEntry lbl scp1, code) = blockSplitHead to + in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead` + foldr blockCons code (map CmmTick ticks) + +-- Group by [Label] +-- See Note [Compressed TrieMap] in GHC.Core.Map about the usage of GenMap. +groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])] +groupByLabel = + go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks])) + where + go !m [] = TM.foldTM (:) m [] + go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries + where --k' = map (getKey . getUnique) k + adjust Nothing = Just (k,[v]) + adjust (Just (_,vs)) = Just (k,v:vs) + +groupByInt :: (a -> Int) -> [a] -> [[a]] +groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs + -- See Note [Unique Determinism and code generation] + where + go m x = alterUFM addEntry m (f x) + where + addEntry xs = Just $! maybe [x] (x:) xs diff --git a/GHC/Cmm/ContFlowOpt.hs b/GHC/Cmm/ContFlowOpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/ContFlowOpt.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Cmm.ContFlowOpt + ( cmmCfgOpts + , cmmCfgOptsProc + , removeUnreachableBlocksProc + , replaceLabels + ) +where + +import GHC.Prelude hiding (succ, unzip, zip) + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) +import GHC.Data.Maybe +import GHC.Utils.Panic +import GHC.Utils.Misc + +import Control.Monad + + +-- Note [What is shortcutting] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider this Cmm code: +-- +-- L1: ... +-- goto L2; +-- L2: goto L3; +-- L3: ... +-- +-- Here L2 is an empty block and contains only an unconditional branch +-- to L3. In this situation any block that jumps to L2 can jump +-- directly to L3: +-- +-- L1: ... +-- goto L3; +-- L2: goto L3; +-- L3: ... +-- +-- In this situation we say that we shortcut L2 to L3. One of +-- consequences of shortcutting is that some blocks of code may become +-- unreachable (in the example above this is true for L2). + + +-- Note [Control-flow optimisations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This optimisation does three things: +-- +-- - If a block finishes in an unconditional branch to another block +-- and that is the only jump to that block we concatenate the +-- destination block at the end of the current one. +-- +-- - If a block finishes in a call whose continuation block is a +-- goto, then we can shortcut the destination, making the +-- continuation block the destination of the goto - but see Note +-- [Shortcut call returns]. +-- +-- - For any block that is not a call we try to shortcut the +-- destination(s). Additionally, if a block ends with a +-- conditional branch we try to invert the condition. +-- +-- Blocks are processed using postorder DFS traversal. A side effect +-- of determining traversal order with a graph search is elimination +-- of any blocks that are unreachable. +-- +-- Transformations are improved by working from the end of the graph +-- towards the beginning, because we may be able to perform many +-- shortcuts in one go. + + +-- Note [Shortcut call returns] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We are going to maintain the "current" graph (LabelMap CmmBlock) as +-- we go, and also a mapping from BlockId to BlockId, representing +-- continuation labels that we have renamed. This latter mapping is +-- important because we might shortcut a CmmCall continuation. For +-- example: +-- +-- Sp[0] = L +-- call g returns to L +-- L: goto M +-- M: ... +-- +-- So when we shortcut the L block, we need to replace not only +-- the continuation of the call, but also references to L in the +-- code (e.g. the assignment Sp[0] = L): +-- +-- Sp[0] = M +-- call g returns to M +-- M: ... +-- +-- So we keep track of which labels we have renamed and apply the mapping +-- at the end with replaceLabels. + + +-- Note [Shortcut call returns and proc-points] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider this code that you might get from a recursive +-- let-no-escape: +-- +-- goto L1 +-- L1: +-- if (Hp > HpLim) then L2 else L3 +-- L2: +-- call stg_gc_noregs returns to L4 +-- L4: +-- goto L1 +-- L3: +-- ... +-- goto L1 +-- +-- Then the control-flow optimiser shortcuts L4. But that turns L1 +-- into the call-return proc point, and every iteration of the loop +-- has to shuffle variables to and from the stack. So we must *not* +-- shortcut L4. +-- +-- Moreover not shortcutting call returns is probably fine. If L4 can +-- concat with its branch target then it will still do so. And we +-- save some compile time because we don't have to traverse all the +-- code in replaceLabels. +-- +-- However, we probably do want to do this if we are splitting proc +-- points, because L1 will be a proc-point anyway, so merging it with +-- L4 reduces the number of proc points. Unfortunately recursive +-- let-no-escapes won't generate very good code with proc-point +-- splitting on - we should probably compile them to explicitly use +-- the native calling convention instead. + +cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph +cmmCfgOpts split g = fst (blockConcat split g) + +cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl +cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' + where (g', env) = blockConcat split g + info' = info{ info_tbls = new_info_tbls } + new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) + + -- If we changed any labels, then we have to update the info tables + -- too, except for the top-level info table because that might be + -- referred to by other procs. + upd_info (k,info) + | Just k' <- mapLookup k env + = (k', if k' == g_entry g' + then info + else info{ cit_lbl = infoTblLbl k' }) + | otherwise + = (k,info) +cmmCfgOptsProc _ top = top + + +blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId) +blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } + = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map') + where + -- We might be able to shortcut the entry BlockId itself. + -- Remember to update the shortcut_map, since we also have to + -- update the info_tbls mapping now. + (new_entry, shortcut_map') + | Just entry_blk <- mapLookup entry_id new_blocks + , Just dest <- canShortcut entry_blk + = (dest, mapInsert entry_id dest shortcut_map) + | otherwise + = (entry_id, shortcut_map) + + -- blocks are sorted in reverse postorder, but we want to go from the exit + -- towards beginning, so we use foldr below. + blocks = revPostorder g + blockmap = foldl' (flip addBlock) emptyBody blocks + + -- Accumulator contains three components: + -- * map of blocks in a graph + -- * map of shortcut labels. See Note [Shortcut call returns] + -- * map containing number of predecessors for each block. We discard + -- it after we process all blocks. + (new_blocks, shortcut_map, _) = + foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks + + -- Map of predecessors for initial graph. We increase number of + -- predecessors for entry block by one to denote that it is + -- target of a jump, even if no block in the current graph jumps + -- to it. + initialBackEdges = incPreds entry_id (predMap blocks) + + maybe_concat :: CmmBlock + -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) + -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) + maybe_concat block (!blocks, !shortcut_map, !backEdges) + -- If: + -- (1) current block ends with unconditional branch to b' and + -- (2) it has exactly one predecessor (namely, current block) + -- + -- Then: + -- (1) append b' block at the end of current block + -- (2) remove b' from the map of blocks + -- (3) remove information about b' from predecessors map + -- + -- Since we know that the block has only one predecessor we call + -- mapDelete directly instead of calling decPreds. + -- + -- Note that we always maintain an up-to-date list of predecessors, so + -- we can ignore the contents of shortcut_map + | CmmBranch b' <- last + , hasOnePredecessor b' + , Just blk' <- mapLookup b' blocks + = let bid' = entryLabel blk' + in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks + , shortcut_map + , mapDelete b' backEdges ) + + -- If: + -- (1) we are splitting proc points (see Note + -- [Shortcut call returns and proc-points]) and + -- (2) current block is a CmmCall or CmmForeignCall with + -- continuation b' and + -- (3) we can shortcut that continuation to dest + -- Then: + -- (1) we change continuation to point to b' + -- (2) create mapping from b' to dest + -- (3) increase number of predecessors of dest by 1 + -- (4) decrease number of predecessors of b' by 1 + -- + -- Later we will use replaceLabels to substitute all occurrences of b' + -- with dest. + | splitting_procs + , Just b' <- callContinuation_maybe last + , Just blk' <- mapLookup b' blocks + , Just dest <- canShortcut blk' + = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks + , mapInsert b' dest shortcut_map + , decPreds b' $ incPreds dest backEdges ) + + -- If: + -- (1) a block does not end with a call + -- Then: + -- (1) if it ends with a conditional attempt to invert the + -- conditional + -- (2) attempt to shortcut all destination blocks + -- (3) if new successors of a block are different from the old ones + -- update the of predecessors accordingly + -- + -- A special case of this is a situation when a block ends with an + -- unconditional jump to a block that can be shortcut. + | Nothing <- callContinuation_maybe last + = let oldSuccs = successors last + newSuccs = successors rewrite_last + in ( mapInsert bid (blockJoinTail head rewrite_last) blocks + , shortcut_map + , if oldSuccs == newSuccs + then backEdges + else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs ) + + -- Otherwise don't do anything + | otherwise + = ( blocks, shortcut_map, backEdges ) + where + (head, last) = blockSplitTail block + bid = entryLabel block + + -- Changes continuation of a call to a specified label + update_cont dest = + case last of + CmmCall{} -> last { cml_cont = Just dest } + CmmForeignCall{} -> last { succ = dest } + _ -> panic "Can't shortcut continuation." + + -- Attempts to shortcut successors of last node + shortcut_last = mapSuccessors shortcut last + where + shortcut l = + case mapLookup l blocks of + Just b | Just dest <- canShortcut b -> dest + _otherwise -> l + + rewrite_last + -- Sometimes we can get rid of the conditional completely. + | CmmCondBranch _cond t f _l <- shortcut_last + , t == f + = CmmBranch t + + -- See Note [Invert Cmm conditionals] + | CmmCondBranch cond t f l <- shortcut_last + , hasOnePredecessor t -- inverting will make t a fallthrough + , likelyTrue l || (numPreds f > 1) + , Just cond' <- maybeInvertCmmExpr cond + = CmmCondBranch cond' f t (invertLikeliness l) + + -- If all jump destinations of a switch go to the + -- same target eliminate the switch. + | CmmSwitch _expr targets <- shortcut_last + , (t:ts) <- switchTargetsToList targets + , all (== t) ts + = CmmBranch t + + | otherwise + = shortcut_last + + likelyTrue (Just True) = True + likelyTrue _ = False + + invertLikeliness :: Maybe Bool -> Maybe Bool + invertLikeliness = fmap not + + -- Number of predecessors for a block + numPreds bid = mapLookup bid backEdges `orElse` 0 + + hasOnePredecessor b = numPreds b == 1 + +{- + Note [Invert Cmm conditionals] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The native code generator always produces jumps to the true branch. + Falling through to the false branch is however faster. So we try to + arrange for that to happen. + This means we invert the condition if: + * The likely path will become a fallthrough. + * We can't guarantee a fallthrough for the false branch but for the + true branch. + + In some cases it's faster to avoid inverting when the false branch is likely. + However determining when that is the case is neither easy nor cheap so for + now we always invert as this produces smaller binaries and code that is + equally fast on average. (On an i7-6700K) + + TODO: + There is also the edge case when both branches have multiple predecessors. + In this case we could assume that we will end up with a jump for BOTH + branches. In this case it might be best to put the likely path in the true + branch especially if there are large numbers of predecessors as this saves + us the jump thats not taken. However I haven't tested this and as of early + 2018 we almost never generate cmm where this would apply. +-} + +-- Functions for incrementing and decrementing number of predecessors. If +-- decrementing would set the predecessor count to 0, we remove entry from the +-- map. +-- Invariant: if a block has no predecessors it should be dropped from the +-- graph because it is unreachable. maybe_concat is constructed to maintain +-- that invariant, but calling replaceLabels may introduce unreachable blocks. +-- We rely on subsequent passes in the Cmm pipeline to remove unreachable +-- blocks. +incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int +incPreds bid edges = mapInsertWith (+) bid 1 edges +decPreds bid edges = case mapLookup bid edges of + Just preds | preds > 1 -> mapInsert bid (preds - 1) edges + Just _ -> mapDelete bid edges + _ -> edges + + +-- Checks if a block consists only of "goto dest". If it does than we return +-- "Just dest" label. See Note [What is shortcutting] +canShortcut :: CmmBlock -> Maybe BlockId +canShortcut block + | (_, middle, CmmBranch dest) <- blockSplit block + , all dont_care $ blockToList middle + = Just dest + | otherwise + = Nothing + where dont_care CmmComment{} = True + dont_care CmmTick{} = True + dont_care _other = False + +-- Concatenates two blocks. First one is assumed to be open on exit, the second +-- is assumed to be closed on entry (i.e. it has a label attached to it, which +-- the splice function removes by calling snd on result of blockSplitHead). +splice :: Block CmmNode C O -> CmmBlock -> CmmBlock +splice head rest = entry `blockJoinHead` code0 `blockAppend` code1 + where (CmmEntry lbl sc0, code0) = blockSplitHead head + (CmmEntry _ sc1, code1) = blockSplitHead rest + entry = CmmEntry lbl (combineTickScopes sc0 sc1) + +-- If node is a call with continuation call return Just label of that +-- continuation. Otherwise return Nothing. +callContinuation_maybe :: CmmNode O C -> Maybe BlockId +callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b +callContinuation_maybe (CmmForeignCall { succ = b }) = Just b +callContinuation_maybe _ = Nothing + + +-- Map over the CmmGraph, replacing each label with its mapping in the +-- supplied LabelMap. +replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph +replaceLabels env g + | mapNull env = g + | otherwise = replace_eid $ mapGraphNodes1 txnode g + where + replace_eid g = g {g_entry = lookup (g_entry g)} + lookup id = mapLookup id env `orElse` id + + txnode :: CmmNode e x -> CmmNode e x + txnode (CmmBranch bid) = CmmBranch (lookup bid) + txnode (CmmCondBranch p t f l) = + mkCmmCondBranch (exp p) (lookup t) (lookup f) l + txnode (CmmSwitch e ids) = + CmmSwitch (exp e) (mapSwitchTargets lookup ids) + txnode (CmmCall t k rg a res r) = + CmmCall (exp t) (liftM lookup k) rg a res r + txnode fc@CmmForeignCall{} = + fc{ args = map exp (args fc), succ = lookup (succ fc) } + txnode other = mapExpDeep exp other + + exp :: CmmExpr -> CmmExpr + exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) + exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i + exp e = e + +mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C +mkCmmCondBranch p t f l = + if t == f then CmmBranch t else CmmCondBranch p t f l + +-- Build a map from a block to its set of predecessors. +predMap :: [CmmBlock] -> LabelMap Int +predMap blocks = foldr add_preds mapEmpty blocks + where + add_preds block env = foldr add env (successors block) + where add lbl env = mapInsertWith (+) lbl 1 env + +-- Removing unreachable blocks +removeUnreachableBlocksProc :: CmmDecl -> CmmDecl +removeUnreachableBlocksProc proc@(CmmProc info lbl live g) + | used_blocks `lengthLessThan` mapSize (toBlockMap g) + = CmmProc info' lbl live g' + | otherwise + = proc + where + g' = ofBlockList (g_entry g) used_blocks + info' = info { info_tbls = keep_used (info_tbls info) } + -- Remove any info_tbls for unreachable + + keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable + keep_used bs = mapFoldlWithKey keep mapEmpty bs + + keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable + keep env l i | l `setMember` used_lbls = mapInsert l i env + | otherwise = env + + used_blocks :: [CmmBlock] + used_blocks = revPostorder g + + used_lbls :: LabelSet + used_lbls = setFromList $ map entryLabel used_blocks diff --git a/GHC/Cmm/Dataflow.hs b/GHC/Cmm/Dataflow.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- +-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, +-- and Norman Ramsey +-- +-- Modifications copyright (c) The University of Glasgow 2012 +-- +-- This module is a specialised and optimised version of +-- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is +-- specialised to the UniqSM monad. +-- + +module GHC.Cmm.Dataflow + ( C, O, Block + , lastNode, entryLabel + , foldNodesBwdOO + , foldRewriteNodesBwdOO + , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..) + , TransferFun, RewriteFun + , Fact, FactBase + , getFact, mkFactBase + , analyzeCmmFwd, analyzeCmmBwd + , rewriteCmmBwd + , changedIf + , joinOutFacts + , joinFacts + ) +where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Types.Unique.Supply + +import Data.Array +import Data.Maybe +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Kind (Type) + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label + +type family Fact (x :: Extensibility) f :: Type +type instance Fact C f = FactBase f +type instance Fact O f = f + +newtype OldFact a = OldFact a + +newtype NewFact a = NewFact a + +-- | The result of joining OldFact and NewFact. +data JoinedFact a + = Changed !a -- ^ Result is different than OldFact. + | NotChanged !a -- ^ Result is the same as OldFact. + +getJoined :: JoinedFact a -> a +getJoined (Changed a) = a +getJoined (NotChanged a) = a + +changedIf :: Bool -> a -> JoinedFact a +changedIf True = Changed +changedIf False = NotChanged + +type JoinFun a = OldFact a -> NewFact a -> JoinedFact a + +data DataflowLattice a = DataflowLattice + { fact_bot :: a + , fact_join :: JoinFun a + } + +data Direction = Fwd | Bwd + +type TransferFun f = CmmBlock -> FactBase f -> FactBase f + +-- | Function for rewrtiting and analysis combined. To be used with +-- @rewriteCmm@. +-- +-- Currently set to work with @UniqSM@ monad, but we could probably abstract +-- that away (if we do that, we might want to specialize the fixpoint algorithms +-- to the particular monads through SPECIALIZE). +type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f) + +analyzeCmmBwd, analyzeCmmFwd + :: DataflowLattice f + -> TransferFun f + -> CmmGraph + -> FactBase f + -> FactBase f +analyzeCmmBwd = analyzeCmm Bwd +analyzeCmmFwd = analyzeCmm Fwd + +analyzeCmm + :: Direction + -> DataflowLattice f + -> TransferFun f + -> CmmGraph + -> FactBase f + -> FactBase f +analyzeCmm dir lattice transfer cmmGraph initFact = + {-# SCC analyzeCmm #-} + let entry = g_entry cmmGraph + hooplGraph = g_graph cmmGraph + blockMap = + case hooplGraph of + GMany NothingO bm NothingO -> bm + in fixpointAnalysis dir lattice transfer entry blockMap initFact + +-- Fixpoint algorithm. +fixpointAnalysis + :: forall f. + Direction + -> DataflowLattice f + -> TransferFun f + -> Label + -> LabelMap CmmBlock + -> FactBase f + -> FactBase f +fixpointAnalysis direction lattice do_block entry blockmap = loop start + where + -- Sorting the blocks helps to minimize the number of times we need to + -- process blocks. For instance, for forward analysis we want to look at + -- blocks in reverse postorder. Also, see comments for sortBlocks. + blocks = sortBlocks direction entry blockmap + num_blocks = length blocks + block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks + start = {-# SCC "start" #-} IntSet.fromDistinctAscList + [0 .. num_blocks - 1] + dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks + join = fact_join lattice + + loop + :: IntHeap -- ^ Worklist, i.e., blocks to process + -> FactBase f -- ^ Current result (increases monotonically) + -> FactBase f + loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo = + let block = block_arr ! index + out_facts = {-# SCC "do_block" #-} do_block block fbase1 + -- For each of the outgoing edges, we join it with the current + -- information in fbase1 and (if something changed) we update it + -- and add the affected blocks to the worklist. + (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-} + mapFoldlWithKey + (updateFact join dep_blocks) (todo1, fbase1) out_facts + in loop todo2 fbase2 + loop _ !fbase1 = fbase1 + +rewriteCmmBwd + :: DataflowLattice f + -> RewriteFun f + -> CmmGraph + -> FactBase f + -> UniqSM (CmmGraph, FactBase f) +rewriteCmmBwd = rewriteCmm Bwd + +rewriteCmm + :: Direction + -> DataflowLattice f + -> RewriteFun f + -> CmmGraph + -> FactBase f + -> UniqSM (CmmGraph, FactBase f) +rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do + let entry = g_entry cmmGraph + hooplGraph = g_graph cmmGraph + blockMap1 = + case hooplGraph of + GMany NothingO bm NothingO -> bm + (blockMap2, facts) <- + fixpointRewrite dir lattice rwFun entry blockMap1 initFact + return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts) + +fixpointRewrite + :: forall f. + Direction + -> DataflowLattice f + -> RewriteFun f + -> Label + -> LabelMap CmmBlock + -> FactBase f + -> UniqSM (LabelMap CmmBlock, FactBase f) +fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap + where + -- Sorting the blocks helps to minimize the number of times we need to + -- process blocks. For instance, for forward analysis we want to look at + -- blocks in reverse postorder. Also, see comments for sortBlocks. + blocks = sortBlocks dir entry blockmap + num_blocks = length blocks + block_arr = {-# SCC "block_arr_rewrite" #-} + listArray (0, num_blocks - 1) blocks + start = {-# SCC "start_rewrite" #-} + IntSet.fromDistinctAscList [0 .. num_blocks - 1] + dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks + join = fact_join lattice + + loop + :: IntHeap -- ^ Worklist, i.e., blocks to process + -> LabelMap CmmBlock -- ^ Rewritten blocks. + -> FactBase f -- ^ Current facts. + -> UniqSM (LabelMap CmmBlock, FactBase f) + loop todo !blocks1 !fbase1 + | Just (index, todo1) <- IntSet.minView todo = do + -- Note that we use the *original* block here. This is important. + -- We're optimistically rewriting blocks even before reaching the fixed + -- point, which means that the rewrite might be incorrect. So if the + -- facts change, we need to rewrite the original block again (taking + -- into account the new facts). + let block = block_arr ! index + (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-} + do_block block fbase1 + let blocks2 = mapInsert (entryLabel new_block) new_block blocks1 + (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-} + mapFoldlWithKey + (updateFact join dep_blocks) (todo1, fbase1) out_facts + loop todo2 blocks2 fbase2 + loop _ !blocks1 !fbase1 = return (blocks1, fbase1) + + +{- +Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analyzed. Reason: consider +constant prop and this graph, with entry point L1: + L1: x:=3; goto L4 + L2: x:=4; goto L4 + L4: if x>3 goto L2 else goto L5 +Here L2 is actually unreachable, but if we process it with bottom input fact, +we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. + +* If a currently-unreachable block is not analyzed, then its rewritten + graph will not be accumulated in tfb_rg. And that is good: + unreachable blocks simply do not appear in the output. + +* Note that clients must be careful to provide a fact (even if bottom) + for each entry point. Otherwise useful blocks may be garbage collected. + +* Note that updateFact must set the change-flag if a label goes from + not-in-fbase to in-fbase, even if its fact is bottom. In effect the + real fact lattice is + UNR + bottom + the points above bottom + +* Even if the fact is going from UNR to bottom, we still call the + client's fact_join function because it might give the client + some useful debugging information. + +* All of this only applies for *forward* ixpoints. For the backward + case we must treat every block as reachable; it might finish with a + 'return', and therefore have no successors, for example. +-} + + +----------------------------------------------------------------------------- +-- Pieces that are shared by fixpoint and fixpoint_anal +----------------------------------------------------------------------------- + +-- | Sort the blocks into the right order for analysis. This means reverse +-- postorder for a forward analysis. For the backward one, we simply reverse +-- that (see Note [Backward vs forward analysis]). +sortBlocks + :: NonLocal n + => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C] +sortBlocks direction entry blockmap = + case direction of + Fwd -> fwd + Bwd -> reverse fwd + where + fwd = revPostorderFrom blockmap entry + +-- Note [Backward vs forward analysis] +-- +-- The forward and backward cases are not dual. In the forward case, the entry +-- points are known, and one simply traverses the body blocks from those points. +-- In the backward case, something is known about the exit points, but a +-- backward analysis must also include reachable blocks that don't reach the +-- exit, as in a procedure that loops forever and has side effects.) +-- For instance, let E be the entry and X the exit blocks (arrows indicate +-- control flow) +-- E -> X +-- E -> B +-- B -> C +-- C -> B +-- We do need to include B and C even though they're unreachable in the +-- *reverse* graph (that we could use for backward analysis): +-- E <- X +-- E <- B +-- B <- C +-- C <- B +-- So when sorting the blocks for the backward analysis, we simply take the +-- reverse of what is used for the forward one. + + +-- | Construct a mapping from a @Label@ to the block indexes that should be +-- re-analyzed if the facts at that @Label@ change. +-- +-- Note that we're considering here the entry point of the block, so if the +-- facts change at the entry: +-- * for a backward analysis we need to re-analyze all the predecessors, but +-- * for a forward analysis, we only need to re-analyze the current block +-- (and that will in turn propagate facts into its successors). +mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet +mkDepBlocks Fwd blocks = go blocks 0 mapEmpty + where + go [] !_ !dep_map = dep_map + go (b:bs) !n !dep_map = + go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map +mkDepBlocks Bwd blocks = go blocks 0 mapEmpty + where + go [] !_ !dep_map = dep_map + go (b:bs) !n !dep_map = + let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m + in go bs (n + 1) $ foldl' insert dep_map (successors b) + +-- | After some new facts have been generated by analysing a block, we +-- fold this function over them to generate (a) a list of block +-- indices to (re-)analyse, and (b) the new FactBase. +updateFact + :: JoinFun f + -> LabelMap IntSet + -> (IntHeap, FactBase f) + -> Label + -> f -- out fact + -> (IntHeap, FactBase f) +updateFact fact_join dep_blocks (todo, fbase) lbl new_fact + = case lookupFact lbl fbase of + Nothing -> + -- Note [No old fact] + let !z = mapInsert lbl new_fact fbase in (changed, z) + Just old_fact -> + case fact_join (OldFact old_fact) (NewFact new_fact) of + (NotChanged _) -> (todo, fbase) + (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z) + where + changed = todo `IntSet.union` + mapFindWithDefault IntSet.empty lbl dep_blocks + +{- +Note [No old fact] + +We know that the new_fact is >= _|_, so we don't need to join. However, +if the new fact is also _|_, and we have already analysed its block, +we don't need to record a change. So there's a tradeoff here. It turns +out that always recording a change is faster. +-} + +---------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------- + +-- Fact lookup: the fact `orelse` bottom +getFact :: DataflowLattice f -> Label -> FactBase f -> f +getFact lat l fb = case lookupFact l fb of Just f -> f + Nothing -> fact_bot lat + +-- | Returns the result of joining the facts from all the successors of the +-- provided node or block. +joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f +joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts + where + join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) + facts = + [ fromJust fact + | s <- successors nonLocal + , let fact = lookupFact s fact_base + , isJust fact + ] + +joinFacts :: DataflowLattice f -> [f] -> f +joinFacts lattice facts = foldl' join (fact_bot lattice) facts + where + join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) + +-- | Returns the joined facts for each label. +mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f +mkFactBase lattice = foldl' add mapEmpty + where + join = fact_join lattice + + add result (l, f1) = + let !newFact = + case mapLookup l result of + Nothing -> f1 + Just f2 -> getJoined $ join (OldFact f1) (NewFact f2) + in mapInsert l newFact result + +-- | Folds backward over all nodes of an open-open block. +-- Strict in the accumulator. +foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f +foldNodesBwdOO funOO = go + where + go (BCat b1 b2) f = go b1 $! go b2 f + go (BSnoc h n) f = go h $! funOO n f + go (BCons n t) f = funOO n $! go t f + go (BMiddle n) f = funOO n f + go BNil f = f +{-# INLINABLE foldNodesBwdOO #-} + +-- | Folds backward over all the nodes of an open-open block and allows +-- rewriting them. The accumulator is both the block of nodes and @f@ (usually +-- dataflow facts). +-- Strict in both accumulated parts. +foldRewriteNodesBwdOO + :: forall f. + (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)) + -> Block CmmNode O O + -> f + -> UniqSM (Block CmmNode O O, f) +foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts + where + go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1 + go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1 + go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1 + go (BMiddle node) !fact1 = rewriteOO node fact1 + go BNil !fact = return (BNil, fact) + + comp rew1 rew2 = \f1 -> do + (b, f2) <- rew2 f1 + (a, !f3) <- rew1 f2 + let !c = joinBlocksOO a b + return (c, f3) + {-# INLINE comp #-} +{-# INLINABLE foldRewriteNodesBwdOO #-} + +joinBlocksOO :: Block n O O -> Block n O O -> Block n O O +joinBlocksOO BNil b = b +joinBlocksOO b BNil = b +joinBlocksOO (BMiddle n) b = blockCons n b +joinBlocksOO b (BMiddle n) = blockSnoc b n +joinBlocksOO b1 b2 = BCat b1 b2 + +type IntHeap = IntSet diff --git a/GHC/Cmm/Dataflow/Block.hs b/GHC/Cmm/Dataflow/Block.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow/Block.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module GHC.Cmm.Dataflow.Block + ( Extensibility (..) + , O + , C + , MaybeO(..) + , IndexedCO + , Block(..) + , blockAppend + , blockCons + , blockFromList + , blockJoin + , blockJoinHead + , blockJoinTail + , blockSnoc + , blockSplit + , blockSplitHead + , blockSplitTail + , blockToList + , emptyBlock + , firstNode + , foldBlockNodesB + , foldBlockNodesB3 + , foldBlockNodesF + , isEmptyBlock + , lastNode + , mapBlock + , mapBlock' + , mapBlock3' + , replaceFirstNode + , replaceLastNode + ) where + +import GHC.Prelude + +-- ----------------------------------------------------------------------------- +-- Shapes: Open and Closed + +-- | Used at the type level to indicate "open" vs "closed" structure. +data Extensibility + -- | An "open" structure with a unique, unnamed control-flow edge flowing in + -- or out. \"Fallthrough\" and concatenation are permitted at an open point. + = Open + -- | A "closed" structure which supports control transfer only through the use + -- of named labels---no "fallthrough" is permitted. The number of control-flow + -- edges is unconstrained. + | Closed + +type O = 'Open +type C = 'Closed + +-- | Either type indexed by closed/open using type families +type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k +type instance IndexedCO C a _b = a +type instance IndexedCO O _a b = b + +-- | Maybe type indexed by open/closed +data MaybeO ex t where + JustO :: t -> MaybeO O t + NothingO :: MaybeO C t + +deriving instance Functor (MaybeO ex) + +-- ----------------------------------------------------------------------------- +-- The Block type + +-- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). +-- Open at the entry means single entry, mutatis mutandis for exit. +-- A closed/closed block is a /basic/ block and can't be extended further. +-- Clients should avoid manipulating blocks and should stick to either nodes +-- or graphs. +data Block n e x where + BlockCO :: n C O -> Block n O O -> Block n C O + BlockCC :: n C O -> Block n O O -> n O C -> Block n C C + BlockOC :: Block n O O -> n O C -> Block n O C + + BNil :: Block n O O + BMiddle :: n O O -> Block n O O + BCat :: Block n O O -> Block n O O -> Block n O O + BSnoc :: Block n O O -> n O O -> Block n O O + BCons :: n O O -> Block n O O -> Block n O O + + +-- ----------------------------------------------------------------------------- +-- Simple operations on Blocks + +-- Predicates + +isEmptyBlock :: Block n e x -> Bool +isEmptyBlock BNil = True +isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r +isEmptyBlock _ = False + + +-- Building + +emptyBlock :: Block n O O +emptyBlock = BNil + +blockCons :: n O O -> Block n O x -> Block n O x +blockCons n b = case b of + BlockOC b l -> (BlockOC $! (n `blockCons` b)) l + BNil{} -> BMiddle n + BMiddle{} -> n `BCons` b + BCat{} -> n `BCons` b + BSnoc{} -> n `BCons` b + BCons{} -> n `BCons` b + +blockSnoc :: Block n e O -> n O O -> Block n e O +blockSnoc b n = case b of + BlockCO f b -> BlockCO f $! (b `blockSnoc` n) + BNil{} -> BMiddle n + BMiddle{} -> b `BSnoc` n + BCat{} -> b `BSnoc` n + BSnoc{} -> b `BSnoc` n + BCons{} -> b `BSnoc` n + +blockJoinHead :: n C O -> Block n O x -> Block n C x +blockJoinHead f (BlockOC b l) = BlockCC f b l +blockJoinHead f b = BlockCO f BNil `cat` b + +blockJoinTail :: Block n e O -> n O C -> Block n e C +blockJoinTail (BlockCO f b) t = BlockCC f b t +blockJoinTail b t = b `cat` BlockOC BNil t + +blockJoin :: n C O -> Block n O O -> n O C -> Block n C C +blockJoin f b t = BlockCC f b t + +blockAppend :: Block n e O -> Block n O x -> Block n e x +blockAppend = cat + + +-- Taking apart + +firstNode :: Block n C x -> n C O +firstNode (BlockCO n _) = n +firstNode (BlockCC n _ _) = n + +lastNode :: Block n x C -> n O C +lastNode (BlockOC _ n) = n +lastNode (BlockCC _ _ n) = n + +blockSplitHead :: Block n C x -> (n C O, Block n O x) +blockSplitHead (BlockCO n b) = (n, b) +blockSplitHead (BlockCC n b t) = (n, BlockOC b t) + +blockSplitTail :: Block n e C -> (Block n e O, n O C) +blockSplitTail (BlockOC b n) = (b, n) +blockSplitTail (BlockCC f b t) = (BlockCO f b, t) + +-- | Split a closed block into its entry node, open middle block, and +-- exit node. +blockSplit :: Block n C C -> (n C O, Block n O O, n O C) +blockSplit (BlockCC f b t) = (f, b, t) + +blockToList :: Block n O O -> [n O O] +blockToList b = go b [] + where go :: Block n O O -> [n O O] -> [n O O] + go BNil r = r + go (BMiddle n) r = n : r + go (BCat b1 b2) r = go b1 $! go b2 r + go (BSnoc b1 n) r = go b1 (n:r) + go (BCons n b1) r = n : go b1 r + +blockFromList :: [n O O] -> Block n O O +blockFromList = foldr BCons BNil + +-- Modifying + +replaceFirstNode :: Block n C x -> n C O -> Block n C x +replaceFirstNode (BlockCO _ b) f = BlockCO f b +replaceFirstNode (BlockCC _ b n) f = BlockCC f b n + +replaceLastNode :: Block n x C -> n O C -> Block n x C +replaceLastNode (BlockOC b _) n = BlockOC b n +replaceLastNode (BlockCC l b _) n = BlockCC l b n + +-- ----------------------------------------------------------------------------- +-- General concatenation + +cat :: Block n e O -> Block n O x -> Block n e x +cat x y = case x of + BNil -> y + + BlockCO l b1 -> case y of + BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n + BNil -> x + BMiddle _ -> BlockCO l $! (b1 `cat` y) + BCat{} -> BlockCO l $! (b1 `cat` y) + BSnoc{} -> BlockCO l $! (b1 `cat` y) + BCons{} -> BlockCO l $! (b1 `cat` y) + + BMiddle n -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle{} -> BCons n y + BCat{} -> BCons n y + BSnoc{} -> BCons n y + BCons{} -> BCons n y + + BCat{} -> case y of + BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + BSnoc{} -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + + BCons{} -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + +-- ----------------------------------------------------------------------------- +-- Mapping + +-- | map a function over the nodes of a 'Block' +mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x +mapBlock f (BlockCO n b ) = BlockCO (f n) (mapBlock f b) +mapBlock f (BlockOC b n) = BlockOC (mapBlock f b) (f n) +mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m) +mapBlock _ BNil = BNil +mapBlock f (BMiddle n) = BMiddle (f n) +mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2) +mapBlock f (BSnoc b n) = BSnoc (mapBlock f b) (f n) +mapBlock f (BCons n b) = BCons (f n) (mapBlock f b) + +-- | A strict 'mapBlock' +mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x) +mapBlock' f = mapBlock3' (f, f, f) + +-- | map over a block, with different functions to apply to first nodes, +-- middle nodes and last nodes respectively. The map is strict. +-- +mapBlock3' :: forall n n' e x . + ( n C O -> n' C O + , n O O -> n' O O, + n O C -> n' O C) + -> Block n e x -> Block n' e x +mapBlock3' (f, m, l) b = go b + where go :: forall e x . Block n e x -> Block n' e x + go (BlockOC b y) = (BlockOC $! go b) $! l y + go (BlockCO x b) = (BlockCO $! f x) $! (go b) + go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y) + go BNil = BNil + go (BMiddle n) = BMiddle $! m n + go (BCat x y) = (BCat $! go x) $! (go y) + go (BSnoc x n) = (BSnoc $! go x) $! (m n) + go (BCons n x) = (BCons $! m n) $! (go x) + +-- ----------------------------------------------------------------------------- +-- Folding + + +-- | Fold a function over every node in a block, forward or backward. +-- The fold function must be polymorphic in the shape of the nodes. +foldBlockNodesF3 :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) +foldBlockNodesF :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) +foldBlockNodesB3 :: forall n a b c . + ( n C O -> b -> c + , n O O -> b -> b + , n O C -> a -> b) + -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) +foldBlockNodesB :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) + +foldBlockNodesF3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b + block (BlockCO f b ) = ff f `cat` block b + block (BlockCC f b l) = ff f `cat` block b `cat` fl l + block (BlockOC b l) = block b `cat` fl l + block BNil = id + block (BMiddle node) = fm node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BSnoc` n) = block b1 `cat` fm n + block (n `BCons` b2) = fm n `cat` block b2 + cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c + cat f f' = f' . f + +foldBlockNodesF f = foldBlockNodesF3 (f, f, f) + +foldBlockNodesB3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b + block (BlockCO f b ) = ff f `cat` block b + block (BlockCC f b l) = ff f `cat` block b `cat` fl l + block (BlockOC b l) = block b `cat` fl l + block BNil = id + block (BMiddle node) = fm node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BSnoc` n) = block b1 `cat` fm n + block (n `BCons` b2) = fm n `cat` block b2 + cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c + cat f f' = f . f' + +foldBlockNodesB f = foldBlockNodesB3 (f, f, f) + diff --git a/GHC/Cmm/Dataflow/Collections.hs b/GHC/Cmm/Dataflow/Collections.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow/Collections.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Cmm.Dataflow.Collections + ( IsSet(..) + , setInsertList, setDeleteList, setUnions + , IsMap(..) + , mapInsertList, mapDeleteList, mapUnions + , UniqueMap, UniqueSet + ) where + +import GHC.Prelude + +import qualified Data.IntMap.Strict as M +import qualified Data.IntSet as S + +import Data.List (foldl1') + +class IsSet set where + type ElemOf set + + setNull :: set -> Bool + setSize :: set -> Int + setMember :: ElemOf set -> set -> Bool + + setEmpty :: set + setSingleton :: ElemOf set -> set + setInsert :: ElemOf set -> set -> set + setDelete :: ElemOf set -> set -> set + + setUnion :: set -> set -> set + setDifference :: set -> set -> set + setIntersection :: set -> set -> set + setIsSubsetOf :: set -> set -> Bool + setFilter :: (ElemOf set -> Bool) -> set -> set + + setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b + setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b + + setElems :: set -> [ElemOf set] + setFromList :: [ElemOf set] -> set + +-- Helper functions for IsSet class +setInsertList :: IsSet set => [ElemOf set] -> set -> set +setInsertList keys set = foldl' (flip setInsert) set keys + +setDeleteList :: IsSet set => [ElemOf set] -> set -> set +setDeleteList keys set = foldl' (flip setDelete) set keys + +setUnions :: IsSet set => [set] -> set +setUnions [] = setEmpty +setUnions sets = foldl1' setUnion sets + + +class IsMap map where + type KeyOf map + + mapNull :: map a -> Bool + mapSize :: map a -> Int + mapMember :: KeyOf map -> map a -> Bool + mapLookup :: KeyOf map -> map a -> Maybe a + mapFindWithDefault :: a -> KeyOf map -> map a -> a + + mapEmpty :: map a + mapSingleton :: KeyOf map -> a -> map a + mapInsert :: KeyOf map -> a -> map a -> map a + mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a + mapDelete :: KeyOf map -> map a -> map a + mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a + mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a + + mapUnion :: map a -> map a -> map a + mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a + mapDifference :: map a -> map a -> map a + mapIntersection :: map a -> map a -> map a + mapIsSubmapOf :: Eq a => map a -> map a -> Bool + + mapMap :: (a -> b) -> map a -> map b + mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b + mapFoldl :: (b -> a -> b) -> b -> map a -> b + mapFoldr :: (a -> b -> b) -> b -> map a -> b + mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b + mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m + mapFilter :: (a -> Bool) -> map a -> map a + mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a + + + mapElems :: map a -> [a] + mapKeys :: map a -> [KeyOf map] + mapToList :: map a -> [(KeyOf map, a)] + mapFromList :: [(KeyOf map, a)] -> map a + mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a + +-- Helper functions for IsMap class +mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a +mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs + +mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a +mapDeleteList keys map = foldl' (flip mapDelete) map keys + +mapUnions :: IsMap map => [map a] -> map a +mapUnions [] = mapEmpty +mapUnions maps = foldl1' mapUnion maps + +----------------------------------------------------------------------------- +-- Basic instances +----------------------------------------------------------------------------- + +newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid) + +instance IsSet UniqueSet where + type ElemOf UniqueSet = Int + + setNull (US s) = S.null s + setSize (US s) = S.size s + setMember k (US s) = S.member k s + + setEmpty = US S.empty + setSingleton k = US (S.singleton k) + setInsert k (US s) = US (S.insert k s) + setDelete k (US s) = US (S.delete k s) + + setUnion (US x) (US y) = US (S.union x y) + setDifference (US x) (US y) = US (S.difference x y) + setIntersection (US x) (US y) = US (S.intersection x y) + setIsSubsetOf (US x) (US y) = S.isSubsetOf x y + setFilter f (US s) = US (S.filter f s) + + setFoldl k z (US s) = S.foldl' k z s + setFoldr k z (US s) = S.foldr k z s + + setElems (US s) = S.elems s + setFromList ks = US (S.fromList ks) + +newtype UniqueMap v = UM (M.IntMap v) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance IsMap UniqueMap where + type KeyOf UniqueMap = Int + + mapNull (UM m) = M.null m + mapSize (UM m) = M.size m + mapMember k (UM m) = M.member k m + mapLookup k (UM m) = M.lookup k m + mapFindWithDefault def k (UM m) = M.findWithDefault def k m + + mapEmpty = UM M.empty + mapSingleton k v = UM (M.singleton k v) + mapInsert k v (UM m) = UM (M.insert k v m) + mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) + mapDelete k (UM m) = UM (M.delete k m) + mapAlter f k (UM m) = UM (M.alter f k m) + mapAdjust f k (UM m) = UM (M.adjust f k m) + + mapUnion (UM x) (UM y) = UM (M.union x y) + mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y) + mapDifference (UM x) (UM y) = UM (M.difference x y) + mapIntersection (UM x) (UM y) = UM (M.intersection x y) + mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y + + mapMap f (UM m) = UM (M.map f m) + mapMapWithKey f (UM m) = UM (M.mapWithKey f m) + mapFoldl k z (UM m) = M.foldl' k z m + mapFoldr k z (UM m) = M.foldr k z m + mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m + mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m + {-# INLINEABLE mapFilter #-} + mapFilter f (UM m) = UM (M.filter f m) + {-# INLINEABLE mapFilterWithKey #-} + mapFilterWithKey f (UM m) = UM (M.filterWithKey f m) + + mapElems (UM m) = M.elems m + mapKeys (UM m) = M.keys m + {-# INLINEABLE mapToList #-} + mapToList (UM m) = M.toList m + mapFromList assocs = UM (M.fromList assocs) + mapFromListWith f assocs = UM (M.fromListWith f assocs) diff --git a/GHC/Cmm/Dataflow/Graph.hs b/GHC/Cmm/Dataflow/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow/Graph.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module GHC.Cmm.Dataflow.Graph + ( Body + , Graph + , Graph'(..) + , NonLocal(..) + , addBlock + , bodyList + , emptyBody + , labelsDefined + , mapGraph + , mapGraphBlocks + , revPostorderFrom + ) where + + +import GHC.Prelude +import GHC.Utils.Misc + +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections + +import Data.Kind + +-- | A (possibly empty) collection of closed/closed blocks +type Body n = LabelMap (Block n C C) + +-- | @Body@ abstracted over @block@ +type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C) + +------------------------------- +-- | Gives access to the anchor points for +-- nonlocal edges as well as the edges themselves +class NonLocal thing where + entryLabel :: thing C x -> Label -- ^ The label of a first node or block + successors :: thing e C -> [Label] -- ^ Gives control-flow successors + +instance NonLocal n => NonLocal (Block n) where + entryLabel (BlockCO f _) = entryLabel f + entryLabel (BlockCC f _ _) = entryLabel f + + successors (BlockOC _ n) = successors n + successors (BlockCC _ _ n) = successors n + + +emptyBody :: Body' block n +emptyBody = mapEmpty + +bodyList :: Body' block n -> [(Label,block n C C)] +bodyList body = mapToList body + +addBlock + :: (NonLocal block, HasDebugCallStack) + => block C C -> LabelMap (block C C) -> LabelMap (block C C) +addBlock block body = mapAlter add lbl body + where + lbl = entryLabel block + add Nothing = Just block + add _ = error $ "duplicate label " ++ show lbl ++ " in graph" + + +-- --------------------------------------------------------------------------- +-- Graph + +-- | A control-flow graph, which may take any of four shapes (O/O, +-- O/C, C/O, C/C). A graph open at the entry has a single, +-- distinguished, anonymous entry point; if a graph is closed at the +-- entry, its entry point(s) are supplied by a context. +type Graph = Graph' Block + +-- | @Graph'@ is abstracted over the block type, so that we can build +-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow +-- needs this). +data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where + GNil :: Graph' block n O O + GUnit :: block n O O -> Graph' block n O O + GMany :: MaybeO e (block n O C) + -> Body' block n + -> MaybeO x (block n C O) + -> Graph' block n e x + + +-- ----------------------------------------------------------------------------- +-- Mapping over graphs + +-- | Maps over all nodes in a graph. +mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x +mapGraph f = mapGraphBlocks (mapBlock f) + +-- | Function 'mapGraphBlocks' enables a change of representation of blocks, +-- nodes, or both. It lifts a polymorphic block transform into a polymorphic +-- graph transform. When the block representation stabilizes, a similar +-- function should be provided for blocks. +mapGraphBlocks :: forall block n block' n' e x . + (forall e x . block n e x -> block' n' e x) + -> (Graph' block n e x -> Graph' block' n' e x) + +mapGraphBlocks f = map + where map :: Graph' block n e x -> Graph' block' n' e x + map GNil = GNil + map (GUnit b) = GUnit (f b) + map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) + +-- ----------------------------------------------------------------------------- +-- Extracting Labels from graphs + +labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x + -> LabelSet +labelsDefined GNil = setEmpty +labelsDefined (GUnit{}) = setEmpty +labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body + where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet + addEntry labels label _ = setInsert label labels + exitLabel :: MaybeO x (block n C O) -> LabelSet + exitLabel NothingO = setEmpty + exitLabel (JustO b) = setSingleton (entryLabel b) + + +---------------------------------------------------------------- + +-- | Returns a list of blocks reachable from the provided Labels in the reverse +-- postorder. +-- +-- This is the most important traversal over this data structure. It drops +-- unreachable code and puts blocks in an order that is good for solving forward +-- dataflow problems quickly. The reverse order is good for solving backward +-- dataflow problems quickly. The forward order is also reasonably good for +-- emitting instructions, except that it will not usually exploit Forrest +-- Baskett's trick of eliminating the unconditional branch from a loop. For +-- that you would need a more serious analysis, probably based on dominators, to +-- identify loop headers. +-- +-- For forward analyses we want reverse postorder visitation, consider: +-- @ +-- A -> [B,C] +-- B -> D +-- C -> D +-- @ +-- Postorder: [D, C, B, A] (or [D, B, C, A]) +-- Reverse postorder: [A, B, C, D] (or [A, C, B, D]) +-- This matters for, e.g., forward analysis, because we want to analyze *both* +-- B and C before we analyze D. +revPostorderFrom + :: forall block. (NonLocal block) + => LabelMap (block C C) -> Label -> [block C C] +revPostorderFrom graph start = go start_worklist setEmpty [] + where + start_worklist = lookup_for_descend start Nil + + -- To compute the postorder we need to "visit" a block (mark as done) + -- *after* visiting all its successors. So we need to know whether we + -- already processed all successors of each block (and @NonLocal@ allows + -- arbitrary many successors). So we use an explicit stack with an extra bit + -- of information: + -- * @ConsTodo@ means to explore the block if it wasn't visited before + -- * @ConsMark@ means that all successors were already done and we can add + -- the block to the result. + -- + -- NOTE: We add blocks to the result list in postorder, but we *prepend* + -- them (i.e., we use @(:)@), which means that the final list is in reverse + -- postorder. + go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C] + go Nil !_ !result = result + go (ConsMark block rest) !wip_or_done !result = + go rest wip_or_done (block : result) + go (ConsTodo block rest) !wip_or_done !result + | entryLabel block `setMember` wip_or_done = go rest wip_or_done result + | otherwise = + let new_worklist = + foldr lookup_for_descend + (ConsMark block rest) + (successors block) + in go new_worklist (setInsert (entryLabel block) wip_or_done) result + + lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C) + lookup_for_descend label wl + | Just b <- mapLookup label graph = ConsTodo b wl + | otherwise = + error $ "Label that doesn't have a block?! " ++ show label + +data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil diff --git a/GHC/Cmm/Dataflow/Label.hs b/GHC/Cmm/Dataflow/Label.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dataflow/Label.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Cmm.Dataflow.Label + ( Label + , LabelMap + , LabelSet + , FactBase + , lookupFact + , mkHooplLabel + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable + +-- TODO: This should really just use GHC's Unique and Uniq{Set,FM} +import GHC.Cmm.Dataflow.Collections + +import GHC.Types.Unique (Uniquable(..)) +import GHC.Data.TrieMap + + +----------------------------------------------------------------------------- +-- Label +----------------------------------------------------------------------------- + +newtype Label = Label { lblToUnique :: Int } + deriving (Eq, Ord) + +mkHooplLabel :: Int -> Label +mkHooplLabel = Label + +instance Show Label where + show (Label n) = "L" ++ show n + +instance Uniquable Label where + getUnique label = getUnique (lblToUnique label) + +instance Outputable Label where + ppr label = ppr (getUnique label) + +----------------------------------------------------------------------------- +-- LabelSet + +newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup) + +instance IsSet LabelSet where + type ElemOf LabelSet = Label + + setNull (LS s) = setNull s + setSize (LS s) = setSize s + setMember (Label k) (LS s) = setMember k s + + setEmpty = LS setEmpty + setSingleton (Label k) = LS (setSingleton k) + setInsert (Label k) (LS s) = LS (setInsert k s) + setDelete (Label k) (LS s) = LS (setDelete k s) + + setUnion (LS x) (LS y) = LS (setUnion x y) + setDifference (LS x) (LS y) = LS (setDifference x y) + setIntersection (LS x) (LS y) = LS (setIntersection x y) + setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y + setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s) + setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s + setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s + + setElems (LS s) = map mkHooplLabel (setElems s) + setFromList ks = LS (setFromList (map lblToUnique ks)) + +----------------------------------------------------------------------------- +-- LabelMap + +newtype LabelMap v = LM (UniqueMap v) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance IsMap LabelMap where + type KeyOf LabelMap = Label + + mapNull (LM m) = mapNull m + mapSize (LM m) = mapSize m + mapMember (Label k) (LM m) = mapMember k m + mapLookup (Label k) (LM m) = mapLookup k m + mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m + + mapEmpty = LM mapEmpty + mapSingleton (Label k) v = LM (mapSingleton k v) + mapInsert (Label k) v (LM m) = LM (mapInsert k v m) + mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m) + mapDelete (Label k) (LM m) = LM (mapDelete k m) + mapAlter f (Label k) (LM m) = LM (mapAlter f k m) + mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m) + + mapUnion (LM x) (LM y) = LM (mapUnion x y) + mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y) + mapDifference (LM x) (LM y) = LM (mapDifference x y) + mapIntersection (LM x) (LM y) = LM (mapIntersection x y) + mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y + + mapMap f (LM m) = LM (mapMap f m) + mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m) + mapFoldl k z (LM m) = mapFoldl k z m + mapFoldr k z (LM m) = mapFoldr k z m + mapFoldlWithKey k z (LM m) = + mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m + mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m + {-# INLINEABLE mapFilter #-} + mapFilter f (LM m) = LM (mapFilter f m) + {-# INLINEABLE mapFilterWithKey #-} + mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m) + + mapElems (LM m) = mapElems m + mapKeys (LM m) = map mkHooplLabel (mapKeys m) + {-# INLINEABLE mapToList #-} + mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m] + mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs]) + mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) + +----------------------------------------------------------------------------- +-- Instances + +instance Outputable LabelSet where + ppr = ppr . setElems + +instance Outputable a => Outputable (LabelMap a) where + ppr = ppr . mapToList + +instance TrieMap LabelMap where + type Key LabelMap = Label + emptyTM = mapEmpty + lookupTM k m = mapLookup k m + alterTM k f m = mapAlter f k m + foldTM k m z = mapFoldr k z m + mapTM f m = mapMap f m + +----------------------------------------------------------------------------- +-- FactBase + +type FactBase f = LabelMap f + +lookupFact :: Label -> FactBase f -> Maybe f +lookupFact = mapLookup diff --git a/GHC/Cmm/DebugBlock.hs b/GHC/Cmm/DebugBlock.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/DebugBlock.hs @@ -0,0 +1,549 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- Debugging data +-- +-- Association of debug data on the Cmm level, with methods to encode it in +-- event log format for later inclusion in profiling event logs. +-- +----------------------------------------------------------------------------- + +module GHC.Cmm.DebugBlock ( + + DebugBlock(..), + cmmDebugGen, + cmmDebugLabels, + cmmDebugLink, + debugToMap, + + -- * Unwinding information + UnwindTable, UnwindPoint(..), + UnwindExpr(..), toUnwindExpr + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Core +import GHC.Data.FastString ( nilFS, mkFastString ) +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Cmm.Ppr.Expr ( pprExpr ) +import GHC.Types.SrcLoc +import GHC.Utils.Misc ( seqList ) + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label + +import Data.Maybe +import Data.List ( minimumBy, nubBy ) +import Data.Ord ( comparing ) +import qualified Data.Map as Map +import Data.Either ( partitionEithers ) + +-- | Debug information about a block of code. Ticks scope over nested +-- blocks. +data DebugBlock = + DebugBlock + { dblProcedure :: !Label -- ^ Entry label of containing proc + , dblLabel :: !Label -- ^ Hoopl label + , dblCLabel :: !CLabel -- ^ Output label + , dblHasInfoTbl :: !Bool -- ^ Has an info table? + , dblParent :: !(Maybe DebugBlock) + -- ^ The parent of this proc. See Note [Splitting DebugBlocks] + , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block + , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block + , dblPosition :: !(Maybe Int) -- ^ Output position relative to + -- other blocks. @Nothing@ means + -- the block was optimized out + , dblUnwind :: [UnwindPoint] + , dblBlocks :: ![DebugBlock] -- ^ Nested blocks + } + +instance Outputable DebugBlock where + ppr blk = (if | dblProcedure blk == dblLabel blk + -> text "proc" + | dblHasInfoTbl blk + -> text "pp-blk" + | otherwise + -> text "blk") <+> + ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+> + (maybe empty ppr (dblSourceTick blk)) <+> + (maybe (text "removed") ((text "pos " <>) . ppr) + (dblPosition blk)) <+> + (ppr (dblUnwind blk)) $+$ + (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk))) + +-- | Intermediate data structure holding debug-relevant context information +-- about a block. +type BlockContext = (CmmBlock, RawCmmDecl) + +-- | Extract debug data from a group of procedures. We will prefer +-- source notes that come from the given module (presumably the module +-- that we are currently compiling). +cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock] +cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes + where + blockCtxs :: Map.Map CmmTickScope [BlockContext] + blockCtxs = blockContexts decls + + -- Analyse tick scope structure: Each one is either a top-level + -- tick scope, or the child of another. + (topScopes, childScopes) + = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs + findP tsc GlobalScope = Left tsc -- top scope + findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc) + | otherwise = findP tsc scp' + where -- Note that we only following the left parent of + -- combined scopes. This loses us ticks, which we will + -- recover by copying ticks below. + scp' | SubScope _ scp' <- scp = scp' + | CombinedScope scp' _ <- scp = scp' + | otherwise = panic "findP impossible" + + scopeMap = foldr (uncurry insertMulti) Map.empty childScopes + + -- This allows us to recover ticks that we lost by flattening + -- the graph. Basically, if the parent is A but the child is + -- CBA, we know that there is no BA, because it would have taken + -- priority - but there might be a B scope, with ticks that + -- would not be associated with our child anymore. Note however + -- that there might be other childs (DB), which we have to + -- filter out. + -- + -- We expect this to be called rarely, which is why we are not + -- trying too hard to be efficient here. In many cases we won't + -- have to construct blockCtxsU in the first place. + ticksToCopy :: CmmTickScope -> [CmmTickish] + ticksToCopy (CombinedScope scp s) = go s + where go s | scp `isTickSubScope` s = [] -- done + | SubScope _ s' <- s = ticks ++ go s' + | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2 + | otherwise = panic "ticksToCopy impossible" + where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs + ticksToCopy _ = [] + bCtxsTicks = concatMap (blockTicks . fst) + + -- Finding the "best" source tick is somewhat arbitrary -- we + -- select the first source span, while preferring source ticks + -- from the same source file. Furthermore, dumps take priority + -- (if we generated one, we probably want debug information to + -- refer to it). + bestSrcTick = minimumBy (comparing rangeRating) + rangeRating (SourceNote span _) + | srcSpanFile span == thisFile = 1 + | otherwise = 2 :: Int + rangeRating note = pprPanic "rangeRating" (ppr note) + thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + + -- Returns block tree for this scope as well as all nested + -- scopes. Note that if there are multiple blocks in the (exact) + -- same scope we elect one as the "branch" node and add the rest + -- as children. + blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock + blocksForScope cstick scope = mkBlock True (head bctxs) + where bctxs = fromJust $ Map.lookup scope blockCtxs + nested = fromMaybe [] $ Map.lookup scope scopeMap + childs = map (mkBlock False) (tail bctxs) ++ + map (blocksForScope stick) nested + + mkBlock :: Bool -> BlockContext -> DebugBlock + mkBlock top (block, prc) + = DebugBlock { dblProcedure = g_entry graph + , dblLabel = label + , dblCLabel = case info of + Just (CmmStaticsRaw infoLbl _) -> infoLbl + Nothing + | g_entry graph == label -> entryLbl + | otherwise -> blockLbl label + , dblHasInfoTbl = isJust info + , dblParent = Nothing + , dblTicks = ticks + , dblPosition = Nothing -- see cmmDebugLink + , dblSourceTick = stick + , dblBlocks = blocks + , dblUnwind = [] + } + where (CmmProc infos entryLbl _ graph) = prc + label = entryLabel block + info = mapLookup label infos + blocks | top = seqList childs childs + | otherwise = [] + + -- A source tick scopes over all nested blocks. However + -- their source ticks might take priority. + isSourceTick SourceNote {} = True + isSourceTick _ = False + -- Collect ticks from all blocks inside the tick scope. + -- We attempt to filter out duplicates while we're at it. + ticks = nubBy (flip tickishContains) $ + bCtxsTicks bctxs ++ ticksToCopy scope + stick = case filter isSourceTick ticks of + [] -> cstick + sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick) + +-- | Build a map of blocks sorted by their tick scopes +-- +-- This involves a pre-order traversal, as we want blocks in rough +-- control flow order (so ticks have a chance to be sorted in the +-- right order). +blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext] +blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls + where walkProc :: RawCmmDecl + -> Map.Map CmmTickScope [BlockContext] + -> Map.Map CmmTickScope [BlockContext] + walkProc CmmData{} m = m + walkProc prc@(CmmProc _ _ _ graph) m + | mapNull blocks = m + | otherwise = snd $ walkBlock prc entry (emptyLbls, m) + where blocks = toBlockMap graph + entry = [mapFind (g_entry graph) blocks] + emptyLbls = setEmpty :: LabelSet + + walkBlock :: RawCmmDecl -> [Block CmmNode C C] + -> (LabelSet, Map.Map CmmTickScope [BlockContext]) + -> (LabelSet, Map.Map CmmTickScope [BlockContext]) + walkBlock _ [] c = c + walkBlock prc (block:blocks) (visited, m) + | lbl `setMember` visited + = walkBlock prc blocks (visited, m) + | otherwise + = walkBlock prc blocks $ + walkBlock prc succs + (lbl `setInsert` visited, + insertMulti scope (block, prc) m) + where CmmEntry lbl scope = firstNode block + (CmmProc _ _ _ graph) = prc + succs = map (flip mapFind (toBlockMap graph)) + (successors (lastNode block)) + mapFind = mapFindWithDefault (error "contextTree: block not found!") + +insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] +insertMulti k v = Map.insertWith (const (v:)) k [v] + +cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] +cmmDebugLabels isMeta nats = seqList lbls lbls + where -- Find order in which procedures will be generated by the + -- back-end (that actually matters for DWARF generation). + -- + -- Note that we might encounter blocks that are missing or only + -- consist of meta instructions -- we will declare them missing, + -- which will skip debug data generation without messing up the + -- block hierarchy. + lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats + getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs + getBlocks _other = [] + allMeta (BasicBlock _ instrs) = all isMeta instrs + +-- | Sets position and unwind table fields in the debug block tree according to +-- native generated code. +cmmDebugLink :: [Label] -> LabelMap [UnwindPoint] + -> [DebugBlock] -> [DebugBlock] +cmmDebugLink labels unwindPts blocks = map link blocks + where blockPos :: LabelMap Int + blockPos = mapFromList $ flip zip [0..] labels + link block = block { dblPosition = mapLookup (dblLabel block) blockPos + , dblBlocks = map link (dblBlocks block) + , dblUnwind = fromMaybe mempty + $ mapLookup (dblLabel block) unwindPts + } + +-- | Converts debug blocks into a label map for easier lookups +debugToMap :: [DebugBlock] -> LabelMap DebugBlock +debugToMap = mapUnions . map go + where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b) + +{- +Note [What is this unwinding business?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Unwinding tables are a variety of debugging information used by debugging tools +to reconstruct the execution history of a program at runtime. These tables +consist of sets of "instructions", one set for every instruction in the program, +which describe how to reconstruct the state of the machine at the point where +the current procedure was called. For instance, consider the following annotated +pseudo-code, + + a_fun: + add rsp, 8 -- unwind: rsp = rsp - 8 + mov rax, 1 -- unwind: rax = unknown + call another_block + sub rsp, 8 -- unwind: rsp = rsp + +We see that attached to each instruction there is an "unwind" annotation, which +provides a relationship between each updated register and its value at the +time of entry to a_fun. This is the sort of information that allows gdb to give +you a stack backtrace given the execution state of your program. This +unwinding information is captured in various ways by various debug information +formats; in the case of DWARF (the only format supported by GHC) it is known as +Call Frame Information (CFI) and can be found in the .debug.frames section of +your object files. + +Currently we only bother to produce unwinding information for registers which +are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp +(which is the STG stack pointer) and $rsp (the C stack pointer). + +Let's consider how GHC would annotate a C-- program with unwinding information +with a typical C-- procedure as would come from the STG-to-Cmm code generator, + + entry() + { c2fe: + v :: P64 = R2; + if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; + c2ff: + R2 = v :: P64; + R1 = test_closure; + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; + c2fg: + I64[Sp - 8] = c2dD; + R1 = v :: P64; + Sp = Sp - 8; // Sp updated here + if (R1 & 7 != 0) goto c2dD; else goto c2dE; + c2dE: + call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; + c2dD: + w :: P64 = R1; + Hp = Hp + 48; + if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; + ... + }, + +Let's consider how this procedure will be decorated with unwind information +(largely by GHC.Cmm.LayoutStack). Naturally, when we enter the procedure `entry` the +value of Sp is no different from what it was at its call site. Therefore we will +add an `unwind` statement saying this at the beginning of its unwind-annotated +code, + + entry() + { c2fe: + unwind Sp = Just Sp + 0; + v :: P64 = R2; + if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; + +After c2fe we may pass to either c2ff or c2fg; let's first consider the +former. In this case there is nothing in particular that we need to do other +than reiterate what we already know about Sp, + + c2ff: + unwind Sp = Just Sp + 0; + R2 = v :: P64; + R1 = test_closure; + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; + +In contrast, c2fg updates Sp midway through its body. To ensure that unwinding +can happen correctly after this point we must include an unwind statement there, +in addition to the usual beginning-of-block statement, + + c2fg: + unwind Sp = Just Sp + 0; + I64[Sp - 8] = c2dD; + R1 = v :: P64; + Sp = Sp - 8; + unwind Sp = Just Sp + 8; + if (R1 & 7 != 0) goto c2dD; else goto c2dE; + +The remaining blocks are simple, + + c2dE: + unwind Sp = Just Sp + 8; + call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; + c2dD: + unwind Sp = Just Sp + 8; + w :: P64 = R1; + Hp = Hp + 48; + if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; + ... + }, + + +The flow of unwinding information through the compiler is a bit convoluted: + + * C-- begins life in StgToCmm without any unwind information. This is because we + haven't actually done any register assignment or stack layout yet, so there + is no need for unwind information. + + * GHC.Cmm.LayoutStack figures out how to layout each procedure's stack, and produces + appropriate unwinding nodes for each adjustment of the STG Sp register. + + * The unwind nodes are carried through the sinking pass. Currently this is + guaranteed not to invalidate unwind information since it won't touch stores + to Sp, but this will need revisiting if CmmSink gets smarter in the future. + + * Eventually we make it to the native code generator backend which can then + preserve the unwind nodes in its machine-specific instructions. In so doing + the backend can also modify or add unwinding information; this is necessary, + for instance, in the case of x86-64, where adjustment of $rsp may be + necessary during calls to native foreign code due to the native calling + convention. + + * The NCG then retrieves the final unwinding table for each block from the + backend with extractUnwindPoints. + + * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen + + * These DebugBlocks are then converted to, e.g., DWARF unwinding tables + (by the Dwarf module) and emitted in the final object. + +See also: + Note [Unwinding information in the NCG] in "GHC.CmmToAsm", + Note [Unwind pseudo-instruction in Cmm], + Note [Debugging DWARF unwinding info]. + + +Note [Debugging DWARF unwinding info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For debugging generated unwinding info I've found it most useful to dump the +disassembled binary with objdump -D and dump the debug info with +readelf --debug-dump=frames-interp. + +You should get something like this: + + 0000000000000010 : + 10: 48 83 c5 18 add $0x18,%rbp + 14: ff 65 00 jmpq *0x0(%rbp) + +and: + + Contents of the .debug_frame section: + + 00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16 + LOC CFA rbp rsp ra + 0000000000000000 rbp+0 v+0 s c+0 + + 00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017 + LOC CFA rbp rsp ra + 000000000000000f rbp+0 v+0 s c+0 + 000000000000000f rbp+24 v+0 s c+0 + +To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in +Appendix 5 (page 101 of the pdf) and more details in the relevant section. + +The key thing to keep in mind is that the value at LOC is the value from +*before* the instruction at LOC executes. In other words it answers the +question: if my $rip is at LOC, how do I get the relevant values given the +values obtained through unwinding so far. + +If the readelf --debug-dump=frames-interp output looks wrong, it may also be +useful to look at readelf --debug-dump=frames, which is closer to the +information that GHC generated. + +It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm +-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm] +explains how to interpret it. + +Inside gdb there are a couple useful commands for inspecting frames. +For example: + + gdb> info frame + +It shows the values of registers obtained through unwinding. + +Another useful thing to try when debugging the DWARF unwinding is to enable +extra debugging output in GDB: + + gdb> set debug frame 1 + +This makes GDB produce a trace of its internal workings. Having gone this far, +it's just a tiny step to run GDB in GDB. Make sure you install debugging +symbols for gdb if you obtain it through a package manager. + +Keep in mind that the current release of GDB has an instruction pointer handling +heuristic that works well for C-like languages, but doesn't always work for +Haskell. See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types" for more details. + +Note [Unwind pseudo-instruction in Cmm] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't +generate any assembly, but controls what DWARF unwinding information gets +generated. + +It's important to understand what ranges of code the unwind pseudo-instruction +refers to. +For a sequence of CmmNodes like: + + A // starts at addr X and ends at addr Y-1 + unwind Sp = Just Sp + 16; + B // starts at addr Y and ends at addr Z + +the unwind statement reflects the state after A has executed, but before B +has executed. If you consult the Note [Debugging DWARF unwinding info], the +LOC this information will end up in is Y. +-} + +-- | A label associated with an 'UnwindTable' +data UnwindPoint = UnwindPoint !CLabel !UnwindTable + +instance Outputable UnwindPoint where + ppr (UnwindPoint lbl uws) = + braces $ ppr lbl<>colon + <+> hsep (punctuate comma $ map pprUw $ Map.toList uws) + where + pprUw (g, expr) = ppr g <> char '=' <> ppr expr + +-- | Maps registers to expressions that yield their "old" values +-- further up the stack. Most interesting for the stack pointer @Sp@, +-- but might be useful to document saved registers, too. Note that a +-- register's value will be 'Nothing' when the register's previous +-- value cannot be reconstructed. +type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr) + +-- | Expressions, used for unwind information +data UnwindExpr = UwConst !Int -- ^ literal value + | UwReg !GlobalReg !Int -- ^ register plus offset + | UwDeref UnwindExpr -- ^ pointer dereferencing + | UwLabel CLabel + | UwPlus UnwindExpr UnwindExpr + | UwMinus UnwindExpr UnwindExpr + | UwTimes UnwindExpr UnwindExpr + deriving (Eq) + +instance Outputable UnwindExpr where + pprPrec _ (UwConst i) = ppr i + pprPrec _ (UwReg g 0) = ppr g + pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x)) + pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e + pprPrec _ (UwLabel l) = pprPrec 3 l + pprPrec p (UwPlus e0 e1) | p <= 0 + = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1 + pprPrec p (UwMinus e0 e1) | p <= 0 + = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1 + pprPrec p (UwTimes e0 e1) | p <= 1 + = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1 + pprPrec _ other = parens (pprPrec 0 other) + +-- | Conversion of Cmm expressions to unwind expressions. We check for +-- unsupported operator usages and simplify the expression as far as +-- possible. +toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr +toUnwindExpr _ (CmmLit (CmmInt i _)) = UwConst (fromIntegral i) +toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l +toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i +toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0 +toUnwindExpr platform (CmmLoad e _) = UwDeref (toUnwindExpr platform e) +toUnwindExpr platform e@(CmmMachOp op [e1, e2]) = + case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of + (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y) + (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y) + (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y) + (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y) + (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y) + (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y) + (MO_Add{}, u1, u2 ) -> UwPlus u1 u2 + (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 + (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 + _otherwise -> pprPanic "Unsupported operator in unwind expression!" + (pprExpr platform e) +toUnwindExpr _ e + = pprPanic "Unsupported unwind expression!" (ppr e) diff --git a/GHC/Cmm/Expr.hs b/GHC/Cmm/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Expr.hs @@ -0,0 +1,623 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.Cmm.Expr + ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr + , CmmReg(..), cmmRegType, cmmRegWidth + , CmmLit(..), cmmLitType + , LocalReg(..), localRegType + , GlobalReg(..), isArgReg, globalRegType + , spReg, hpReg, spLimReg, hpLimReg, nodeReg + , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg + , node, baseReg + , VGcPtr(..) + + , DefinerOfRegs, UserOfRegs + , foldRegsDefd, foldRegsUsed + , foldLocalRegsDefd, foldLocalRegsUsed + + , RegSet, LocalRegSet, GlobalRegSet + , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet + , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet + , regSetToList + + , Area(..) + , module GHC.Cmm.MachOp + , module GHC.Cmm.Type + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.MachOp +import GHC.Cmm.Type +import GHC.Driver.Session +import GHC.Utils.Outputable (panic) +import GHC.Types.Unique + +import Data.Set (Set) +import qualified Data.Set as Set + +import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) + +----------------------------------------------------------------------------- +-- CmmExpr +-- An expression. Expressions have no side effects. +----------------------------------------------------------------------------- + +data CmmExpr + = CmmLit CmmLit -- Literal + | CmmLoad !CmmExpr !CmmType -- Read memory location + | CmmReg !CmmReg -- Contents of register + | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) + | CmmStackSlot Area {-# UNPACK #-} !Int + -- addressing expression of a stack slot + -- See Note [CmmStackSlot aliasing] + | CmmRegOff !CmmReg Int + -- CmmRegOff reg i + -- ** is shorthand only, meaning ** + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) + +instance Eq CmmExpr where -- Equality ignores the types + CmmLit l1 == CmmLit l2 = l1==l2 + CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 + CmmReg r1 == CmmReg r2 = r1==r2 + CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 + CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 + _e1 == _e2 = False + +data CmmReg + = CmmLocal {-# UNPACK #-} !LocalReg + | CmmGlobal GlobalReg + deriving( Eq, Ord ) + +-- | A stack area is either the stack slot where a variable is spilled +-- or the stack space where function arguments and results are passed. +data Area + = Old -- See Note [Old Area] + | Young {-# UNPACK #-} !BlockId -- Invariant: must be a continuation BlockId + -- See Note [Continuation BlockId] in GHC.Cmm.Node. + deriving (Eq, Ord) + +{- Note [Old Area] +~~~~~~~~~~~~~~~~~~ +There is a single call area 'Old', allocated at the extreme old +end of the stack frame (ie just younger than the return address) +which holds: + * incoming (overflow) parameters, + * outgoing (overflow) parameter to tail calls, + * outgoing (overflow) result values + * the update frame (if any) + +Its size is the max of all these requirements. On entry, the stack +pointer will point to the youngest incoming parameter, which is not +necessarily at the young end of the Old area. + +End of note -} + + +{- Note [CmmStackSlot aliasing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When do two CmmStackSlots alias? + + - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M + - T[old+N] aliases with U[old+M] only if the areas actually overlap + +Or more informally, different Areas may overlap with each other. + +An alternative semantics, that we previously had, was that different +Areas do not overlap. The problem that lead to redefining the +semantics of stack areas is described below. + +e.g. if we had + + x = Sp[old + 8] + y = Sp[old + 16] + + Sp[young(L) + 8] = L + Sp[young(L) + 16] = y + Sp[young(L) + 24] = x + call f() returns to L + +if areas semantically do not overlap, then we might optimise this to + + Sp[young(L) + 8] = L + Sp[young(L) + 16] = Sp[old + 8] + Sp[young(L) + 24] = Sp[old + 16] + call f() returns to L + +and now young(L) cannot be allocated at the same place as old, and we +are doomed to use more stack. + + - old+8 conflicts with young(L)+8 + - old+16 conflicts with young(L)+16 and young(L)+8 + +so young(L)+8 == old+24 and we get + + Sp[-8] = L + Sp[-16] = Sp[8] + Sp[-24] = Sp[0] + Sp -= 24 + call f() returns to L + +However, if areas are defined to be "possibly overlapping" in the +semantics, then we cannot commute any loads/stores of old with +young(L), and we will be able to re-use both old+8 and old+16 for +young(L). + + x = Sp[8] + y = Sp[0] + + Sp[8] = L + Sp[0] = y + Sp[-8] = x + Sp = Sp - 8 + call f() returns to L + +Now, the assignments of y go away, + + x = Sp[8] + Sp[8] = L + Sp[-8] = x + Sp = Sp - 8 + call f() returns to L +-} + +data CmmLit + = CmmInt !Integer Width + -- Interpretation: the 2's complement representation of the value + -- is truncated to the specified size. This is easier than trying + -- to keep the value within range, because we don't know whether + -- it will be used as a signed or unsigned value (the CmmType doesn't + -- distinguish between signed & unsigned). + | CmmFloat Rational Width + | CmmVec [CmmLit] -- Vector literal + | CmmLabel CLabel -- Address of label + | CmmLabelOff CLabel Int -- Address of label + byte offset + + -- Due to limitations in the C backend, the following + -- MUST ONLY be used inside the info table indicated by label2 + -- (label2 must be the info label), and label1 must be an + -- SRT, a slow entrypoint or a large bitmap (see the Mangler) + -- Don't use it at all unless tablesNextToCode. + -- It is also used inside the NCG during when generating + -- position-independent code. + | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset + -- In an expression, the width just has the effect of MO_SS_Conv + -- from wordWidth to the desired width. + -- + -- In a static literal, the supported Widths depend on the + -- architecture: wordWidth is supported on all + -- architectures. Additionally W32 is supported on x86_64 when + -- using the small memory model. + + | CmmBlock {-# UNPACK #-} !BlockId -- Code label + -- Invariant: must be a continuation BlockId + -- See Note [Continuation BlockId] in GHC.Cmm.Node. + + | CmmHighStackMark -- A late-bound constant that stands for the max + -- #bytes of stack space used during a procedure. + -- During the stack-layout pass, CmmHighStackMark + -- is replaced by a CmmInt for the actual number + -- of bytes used + deriving Eq + +cmmExprType :: Platform -> CmmExpr -> CmmType +cmmExprType platform = \case + (CmmLit lit) -> cmmLitType platform lit + (CmmLoad _ rep) -> rep + (CmmReg reg) -> cmmRegType platform reg + (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args) + (CmmRegOff reg _) -> cmmRegType platform reg + (CmmStackSlot _ _) -> bWord platform -- an address + -- Careful though: what is stored at the stack slot may be bigger than + -- an address + +cmmLitType :: Platform -> CmmLit -> CmmType +cmmLitType platform = \case + (CmmInt _ width) -> cmmBits width + (CmmFloat _ width) -> cmmFloat width + (CmmVec []) -> panic "cmmLitType: CmmVec []" + (CmmVec (l:ls)) -> let ty = cmmLitType platform l + in if all (`cmmEqType` ty) (map (cmmLitType platform) ls) + then cmmVec (1+length ls) ty + else panic "cmmLitType: CmmVec" + (CmmLabel lbl) -> cmmLabelType platform lbl + (CmmLabelOff lbl _) -> cmmLabelType platform lbl + (CmmLabelDiffOff _ _ _ width) -> cmmBits width + (CmmBlock _) -> bWord platform + (CmmHighStackMark) -> bWord platform + +cmmLabelType :: Platform -> CLabel -> CmmType +cmmLabelType platform lbl + | isGcPtrLabel lbl = gcWord platform + | otherwise = bWord platform + +cmmExprWidth :: Platform -> CmmExpr -> Width +cmmExprWidth platform e = typeWidth (cmmExprType platform e) + +-- | Returns an alignment in bytes of a CmmExpr when it's a statically +-- known integer constant, otherwise returns an alignment of 1 byte. +-- The caller is responsible for using with a sensible CmmExpr +-- argument. +cmmExprAlignment :: CmmExpr -> Alignment +cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff) +cmmExprAlignment _ = mkAlignment 1 +-------- +--- Negation for conditional branches + +maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr +maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op + return (CmmMachOp op' args) +maybeInvertCmmExpr _ = Nothing + +----------------------------------------------------------------------------- +-- Local registers +----------------------------------------------------------------------------- + +data LocalReg + = LocalReg {-# UNPACK #-} !Unique CmmType + -- ^ Parameters: + -- 1. Identifier + -- 2. Type + +instance Eq LocalReg where + (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 + +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +-- See Note [No Ord for Unique] +instance Ord LocalReg where + compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _) = uniq + +cmmRegType :: Platform -> CmmReg -> CmmType +cmmRegType _ (CmmLocal reg) = localRegType reg +cmmRegType platform (CmmGlobal reg) = globalRegType platform reg + +cmmRegWidth :: Platform -> CmmReg -> Width +cmmRegWidth platform = typeWidth . cmmRegType platform + +localRegType :: LocalReg -> CmmType +localRegType (LocalReg _ rep) = rep + +----------------------------------------------------------------------------- +-- Register-use information for expressions and other types +----------------------------------------------------------------------------- + +-- | Sets of registers + +-- These are used for dataflow facts, and a common operation is taking +-- the union of two RegSets and then asking whether the union is the +-- same as one of the inputs. UniqSet isn't good here, because +-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary +-- Sets. + +type RegSet r = Set r +type LocalRegSet = RegSet LocalReg +type GlobalRegSet = RegSet GlobalReg + +emptyRegSet :: RegSet r +nullRegSet :: RegSet r -> Bool +elemRegSet :: Ord r => r -> RegSet r -> Bool +extendRegSet :: Ord r => RegSet r -> r -> RegSet r +deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r +mkRegSet :: Ord r => [r] -> RegSet r +minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r +sizeRegSet :: RegSet r -> Int +regSetToList :: RegSet r -> [r] + +emptyRegSet = Set.empty +nullRegSet = Set.null +elemRegSet = Set.member +extendRegSet = flip Set.insert +deleteFromRegSet = flip Set.delete +mkRegSet = Set.fromList +minusRegSet = Set.difference +plusRegSet = Set.union +timesRegSet = Set.intersection +sizeRegSet = Set.size +regSetToList = Set.toList + +class Ord r => UserOfRegs r a where + foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsUsed :: UserOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsUsed = foldRegsUsed + +class Ord r => DefinerOfRegs r a where + foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsDefd :: DefinerOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsDefd = foldRegsDefd + +instance UserOfRegs LocalReg CmmReg where + foldRegsUsed _ f z (CmmLocal reg) = f z reg + foldRegsUsed _ _ z (CmmGlobal _) = z + +instance DefinerOfRegs LocalReg CmmReg where + foldRegsDefd _ f z (CmmLocal reg) = f z reg + foldRegsDefd _ _ z (CmmGlobal _) = z + +instance UserOfRegs GlobalReg CmmReg where + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal reg) = f z reg + +instance DefinerOfRegs GlobalReg CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal reg) = f z reg + +instance Ord r => UserOfRegs r r where + foldRegsUsed _ f z r = f z r + +instance Ord r => DefinerOfRegs r r where + foldRegsDefd _ f z r = f z r + +instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + -- The (Ord r) in the context is necessary here + -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance + foldRegsUsed dflags f !z e = expr z e + where expr z (CmmLit _) = z + expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr + expr z (CmmReg r) = foldRegsUsed dflags f z r + expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs + expr z (CmmRegOff r _) = foldRegsUsed dflags f z r + expr z (CmmStackSlot _ _) = z + +instance UserOfRegs r a => UserOfRegs r [a] where + foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as + {-# INLINABLE foldRegsUsed #-} + +instance DefinerOfRegs r a => DefinerOfRegs r [a] where + foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as + {-# INLINABLE foldRegsDefd #-} + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- + +data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- +{- +Note [Overlapping global registers] + +The backend might not faithfully implement the abstraction of the STG +machine with independent registers for different values of type +GlobalReg. Specifically, certain pairs of registers (r1, r2) may +overlap in the sense that a store to r1 invalidates the value in r2, +and vice versa. + +Currently this occurs only on the x86_64 architecture where FloatReg n +and DoubleReg n are assigned the same microarchitectural register, in +order to allow functions to receive more Float# or Double# arguments +in registers (as opposed to on the stack). + +There are no specific rules about which registers might overlap with +which other registers, but presumably it's safe to assume that nothing +will overlap with special registers like Sp or BaseReg. + +Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap +on a particular platform. The instance Eq GlobalReg is syntactic +equality of STG registers and does not take overlap into +account. However it is still used in UserOfRegs/DefinerOfRegs and +there are likely still bugs there, beware! +-} + +data GlobalReg + -- Argument and return registers + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + VGcPtr + + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number + + | XmmReg -- 128-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | YmmReg -- 256-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | ZmmReg -- 512-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + -- STG registers + | Sp -- Stack ptr; points to last occupied stack location. + | SpLim -- Stack limit + | Hp -- Heap ptr; points to last occupied heap location. + | HpLim -- Heap limit register + | CCCS -- Current cost-centre stack + | CurrentTSO -- pointer to current thread's TSO + | CurrentNursery -- pointer to allocation area + | HpAlloc -- allocation count for heap check failure + + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: + | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info + | GCEnter1 -- stg_gc_enter_1 + | GCFun -- stg_gc_fun + + -- Base offset for the register table, used for accessing registers + -- which do not have real registers assigned to them. This register + -- will only appear after we have expanded GlobalReg into memory accesses + -- (where necessary) in the native code generator. + | BaseReg + + -- The register used by the platform for the C stack pointer. This is + -- a break in the STG abstraction used exclusively to setup stack unwinding + -- information. + | MachSp + + -- The is a dummy register used to indicate to the stack unwinder where + -- a routine would return to. + | UnwindReturnReg + + -- Base Register for PIC (position-independent code) calculations + -- Only used inside the native code generator. It's exact meaning differs + -- from platform to platform (see module PositionIndependentCode). + | PicBaseReg + + deriving( Show ) + +instance Eq GlobalReg where + VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes + FloatReg i == FloatReg j = i==j + DoubleReg i == DoubleReg j = i==j + LongReg i == LongReg j = i==j + -- NOTE: XMM, YMM, ZMM registers actually are the same registers + -- at least with respect to store at YMM i and then read from XMM i + -- and similarly for ZMM etc. + XmmReg i == XmmReg j = i==j + YmmReg i == YmmReg j = i==j + ZmmReg i == ZmmReg j = i==j + Sp == Sp = True + SpLim == SpLim = True + Hp == Hp = True + HpLim == HpLim = True + CCCS == CCCS = True + CurrentTSO == CurrentTSO = True + CurrentNursery == CurrentNursery = True + HpAlloc == HpAlloc = True + EagerBlackholeInfo == EagerBlackholeInfo = True + GCEnter1 == GCEnter1 = True + GCFun == GCFun = True + BaseReg == BaseReg = True + MachSp == MachSp = True + UnwindReturnReg == UnwindReturnReg = True + PicBaseReg == PicBaseReg = True + _r1 == _r2 = False + +instance Ord GlobalReg where + compare (VanillaReg i _) (VanillaReg j _) = compare i j + -- Ignore type when seeking clashes + compare (FloatReg i) (FloatReg j) = compare i j + compare (DoubleReg i) (DoubleReg j) = compare i j + compare (LongReg i) (LongReg j) = compare i j + compare (XmmReg i) (XmmReg j) = compare i j + compare (YmmReg i) (YmmReg j) = compare i j + compare (ZmmReg i) (ZmmReg j) = compare i j + compare Sp Sp = EQ + compare SpLim SpLim = EQ + compare Hp Hp = EQ + compare HpLim HpLim = EQ + compare CCCS CCCS = EQ + compare CurrentTSO CurrentTSO = EQ + compare CurrentNursery CurrentNursery = EQ + compare HpAlloc HpAlloc = EQ + compare EagerBlackholeInfo EagerBlackholeInfo = EQ + compare GCEnter1 GCEnter1 = EQ + compare GCFun GCFun = EQ + compare BaseReg BaseReg = EQ + compare MachSp MachSp = EQ + compare UnwindReturnReg UnwindReturnReg = EQ + compare PicBaseReg PicBaseReg = EQ + compare (VanillaReg _ _) _ = LT + compare _ (VanillaReg _ _) = GT + compare (FloatReg _) _ = LT + compare _ (FloatReg _) = GT + compare (DoubleReg _) _ = LT + compare _ (DoubleReg _) = GT + compare (LongReg _) _ = LT + compare _ (LongReg _) = GT + compare (XmmReg _) _ = LT + compare _ (XmmReg _) = GT + compare (YmmReg _) _ = LT + compare _ (YmmReg _) = GT + compare (ZmmReg _) _ = LT + compare _ (ZmmReg _) = GT + compare Sp _ = LT + compare _ Sp = GT + compare SpLim _ = LT + compare _ SpLim = GT + compare Hp _ = LT + compare _ Hp = GT + compare HpLim _ = LT + compare _ HpLim = GT + compare CCCS _ = LT + compare _ CCCS = GT + compare CurrentTSO _ = LT + compare _ CurrentTSO = GT + compare CurrentNursery _ = LT + compare _ CurrentNursery = GT + compare HpAlloc _ = LT + compare _ HpAlloc = GT + compare GCEnter1 _ = LT + compare _ GCEnter1 = GT + compare GCFun _ = LT + compare _ GCFun = GT + compare BaseReg _ = LT + compare _ BaseReg = GT + compare MachSp _ = LT + compare _ MachSp = GT + compare UnwindReturnReg _ = LT + compare _ UnwindReturnReg = GT + compare EagerBlackholeInfo _ = LT + compare _ EagerBlackholeInfo = GT + +-- convenient aliases +baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, + currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg +baseReg = CmmGlobal BaseReg +spReg = CmmGlobal Sp +hpReg = CmmGlobal Hp +hpLimReg = CmmGlobal HpLim +spLimReg = CmmGlobal SpLim +nodeReg = CmmGlobal node +currentTSOReg = CmmGlobal CurrentTSO +currentNurseryReg = CmmGlobal CurrentNursery +hpAllocReg = CmmGlobal HpAlloc +cccsReg = CmmGlobal CCCS + +node :: GlobalReg +node = VanillaReg 1 VGcPtr + +globalRegType :: Platform -> GlobalReg -> CmmType +globalRegType platform = \case + (VanillaReg _ VGcPtr) -> gcWord platform + (VanillaReg _ VNonGcPtr) -> bWord platform + (FloatReg _) -> cmmFloat W32 + (DoubleReg _) -> cmmFloat W64 + (LongReg _) -> cmmBits W64 + -- TODO: improve the internal model of SIMD/vectorized registers + -- the right design SHOULd improve handling of float and double code too. + -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim + (XmmReg _) -> cmmVec 4 (cmmBits W32) + (YmmReg _) -> cmmVec 8 (cmmBits W32) + (ZmmReg _) -> cmmVec 16 (cmmBits W32) + + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg (XmmReg {}) = True +isArgReg (YmmReg {}) = True +isArgReg (ZmmReg {}) = True +isArgReg _ = False diff --git a/GHC/Cmm/Graph.hs b/GHC/Cmm/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Graph.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE BangPatterns, GADTs #-} + +module GHC.Cmm.Graph + ( CmmAGraph, CmmAGraphScoped, CgStmt(..) + , (<*>), catAGraphs + , mkLabel, mkMiddle, mkLast, outOfLine + , lgraphOfAGraph, labelAGraph + + , stackStubExpr + , mkNop, mkAssign, mkStore + , mkUnsafeCall, mkFinalCall, mkCallReturnsTo + , mkJumpReturnsTo + , mkJump, mkJumpExtra + , mkRawJump + , mkCbranch, mkSwitch + , mkReturn, mkComment, mkCallEntry, mkBranch + , mkUnwind + , copyInOflow, copyOutOflow + , noExtraStack + , toCall, Transfer(..) + ) +where + +import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>) + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.CallConv +import GHC.Cmm.Switch (SwitchTargets) + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Types.ForeignCall +import GHC.Data.OrdList +import GHC.Runtime.Heap.Layout (ByteOff) +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Utils.Panic + + +----------------------------------------------------------------------------- +-- Building Graphs + + +-- | CmmAGraph is a chunk of code consisting of: +-- +-- * ordinary statements (assignments, stores etc.) +-- * jumps +-- * labels +-- * out-of-line labelled blocks +-- +-- The semantics is that control falls through labels and out-of-line +-- blocks. Everything after a jump up to the next label is by +-- definition unreachable code, and will be discarded. +-- +-- Two CmmAGraphs can be stuck together with <*>, with the meaning that +-- control flows from the first to the second. +-- +-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends) +-- by providing a label for the entry point and a tick scope; see +-- 'labelAGraph'. +type CmmAGraph = OrdList CgStmt +-- | Unlabeled graph with tick scope +type CmmAGraphScoped = (CmmAGraph, CmmTickScope) + +data CgStmt + = CgLabel BlockId CmmTickScope + | CgStmt (CmmNode O O) + | CgLast (CmmNode O C) + | CgFork BlockId CmmAGraph CmmTickScope + +flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph +flattenCmmAGraph id (stmts_t, tscope) = + CmmGraph { g_entry = id, + g_graph = GMany NothingO body NothingO } + where + body = foldr addBlock emptyBody $ flatten id stmts_t tscope [] + + -- + -- flatten: given an entry label and a CmmAGraph, make a list of blocks. + -- + -- NB. avoid the quadratic-append trap by passing in the tail of the + -- list. This is important for Very Long Functions (e.g. in T783). + -- + flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C] + -> [Block CmmNode C C] + flatten id g tscope blocks + = flatten1 (fromOL g) block' blocks + where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock + -- + -- flatten0: we are outside a block at this point: any code before + -- the first label is unreachable, so just drop it. + -- + flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] + flatten0 [] blocks = blocks + + flatten0 (CgLabel id tscope : stmts) blocks + = flatten1 stmts block blocks + where !block = blockJoinHead (CmmEntry id tscope) emptyBlock + + flatten0 (CgFork fork_id stmts_t tscope : rest) blocks + = flatten fork_id stmts_t tscope $ flatten0 rest blocks + + flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks + flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks + + -- + -- flatten1: we have a partial block, collect statements until the + -- next last node to make a block, then call flatten0 to get the rest + -- of the blocks + -- + flatten1 :: [CgStmt] -> Block CmmNode C O + -> [Block CmmNode C C] -> [Block CmmNode C C] + + -- The current block falls through to the end of a function or fork: + -- this code should not be reachable, but it may be referenced by + -- other code that is not reachable. We'll remove it later with + -- dead-code analysis, but for now we have to keep the graph + -- well-formed, so we terminate the block with a branch to the + -- beginning of the current block. + flatten1 [] block blocks + = blockJoinTail block (CmmBranch (entryLabel block)) : blocks + + flatten1 (CgLast stmt : stmts) block blocks + = block' : flatten0 stmts blocks + where !block' = blockJoinTail block stmt + + flatten1 (CgStmt stmt : stmts) block blocks + = flatten1 stmts block' blocks + where !block' = blockSnoc block stmt + + flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks + = flatten fork_id stmts_t tscope $ flatten1 rest block blocks + + -- a label here means that we should start a new block, and the + -- current block should fall through to the new block. + flatten1 (CgLabel id tscp : stmts) block blocks + = blockJoinTail block (CmmBranch id) : + flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks + + + +---------- AGraph manipulation + +(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph +(<*>) = appOL + +catAGraphs :: [CmmAGraph] -> CmmAGraph +catAGraphs = concatOL + +-- | creates a sequence "goto id; id:" as an AGraph +mkLabel :: BlockId -> CmmTickScope -> CmmAGraph +mkLabel bid scp = unitOL (CgLabel bid scp) + +-- | creates an open AGraph from a given node +mkMiddle :: CmmNode O O -> CmmAGraph +mkMiddle middle = unitOL (CgStmt middle) + +-- | creates a closed AGraph from a given node +mkLast :: CmmNode O C -> CmmAGraph +mkLast last = unitOL (CgLast last) + +-- | A labelled code block; should end in a last node +outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph +outOfLine l (c,s) = unitOL (CgFork l c s) + +-- | allocate a fresh label for the entry point +lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph +lgraphOfAGraph g = do + u <- getUniqueM + return (labelAGraph (mkBlockId u) g) + +-- | use the given BlockId as the label of the entry point +labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph +labelAGraph lbl ag = flattenCmmAGraph lbl ag + +---------- No-ops +mkNop :: CmmAGraph +mkNop = nilOL + +mkComment :: FastString -> CmmAGraph +mkComment fs + -- SDM: generating all those comments takes time, this saved about 4% for me + | debugIsOn = mkMiddle $ CmmComment fs + | otherwise = nilOL + +---------- Assignment and store +mkAssign :: CmmReg -> CmmExpr -> CmmAGraph +mkAssign l (CmmReg r) | l == r = mkNop +mkAssign l r = mkMiddle $ CmmAssign l r + +mkStore :: CmmExpr -> CmmExpr -> CmmAGraph +mkStore l r = mkMiddle $ CmmStore l r + +---------- Control transfer +mkJump :: DynFlags -> Convention -> CmmExpr + -> [CmmExpr] + -> UpdFrameOffset + -> CmmAGraph +mkJump dflags conv e actuals updfr_off = + lastWithArgs dflags Jump Old conv actuals updfr_off $ + toCall e Nothing updfr_off 0 + +-- | A jump where the caller says what the live GlobalRegs are. Used +-- for low-level hand-written Cmm. +mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg] + -> CmmAGraph +mkRawJump dflags e updfr_off vols = + lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $ + \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols + + +mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr] + -> UpdFrameOffset -> [CmmExpr] + -> CmmAGraph +mkJumpExtra dflags conv e actuals updfr_off extra_stack = + lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $ + toCall e Nothing updfr_off 0 + +mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph +mkCbranch pred ifso ifnot likely = + mkLast (CmmCondBranch pred ifso ifnot likely) + +mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph +mkSwitch e tbl = mkLast $ CmmSwitch e tbl + +mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset + -> CmmAGraph +mkReturn dflags e actuals updfr_off = + lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ + toCall e Nothing updfr_off 0 + +mkBranch :: BlockId -> CmmAGraph +mkBranch bid = mkLast (CmmBranch bid) + +mkFinalCall :: DynFlags + -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset + -> CmmAGraph +mkFinalCall dflags f _ actuals updfr_off = + lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $ + toCall f Nothing updfr_off 0 + +mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] + -> BlockId + -> ByteOff + -> UpdFrameOffset + -> [CmmExpr] + -> CmmAGraph +mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do + lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals + updfr_off extra_stack $ + toCall f (Just ret_lbl) updfr_off ret_off + +-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be +-- already on the stack). +mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] + -> BlockId + -> ByteOff + -> UpdFrameOffset + -> CmmAGraph +mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do + lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $ + toCall f (Just ret_lbl) updfr_off ret_off + +mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph +mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as + +-- | Construct a 'CmmUnwind' node for the given register and unwinding +-- expression. +mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph +mkUnwind r e = mkMiddle $ CmmUnwind [(r, Just e)] + +-------------------------------------------------------------------------- + + + + +-- Why are we inserting extra blocks that simply branch to the successors? +-- Because in addition to the branch instruction, @mkBranch@ will insert +-- a necessary adjustment to the stack pointer. + + +-- For debugging purposes, we can stub out dead stack slots: +stackStubExpr :: Width -> CmmExpr +stackStubExpr w = CmmLit (CmmInt 0 w) + +-- When we copy in parameters, we usually want to put overflow +-- parameters on the stack, but sometimes we want to pass the +-- variables in their spill slots. Therefore, for copying arguments +-- and results, we provide different functions to pass the arguments +-- in an overflow area and to pass them in spill slots. +copyInOflow :: DynFlags -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] + -> (Int, [GlobalReg], CmmAGraph) + +copyInOflow dflags conv area formals extra_stk + = (offset, gregs, catAGraphs $ map mkMiddle nodes) + where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk + +-- Return the number of bytes used for copying arguments, as well as the +-- instructions to copy the arguments. +copyIn :: DynFlags -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] + -> (ByteOff, [GlobalReg], [CmmNode O O]) +copyIn dflags conv area formals extra_stk + = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) + where + platform = targetPlatform dflags + -- See Note [Width of parameters] + ci (reg, RegisterParam r@(VanillaReg {})) = + let local = CmmLocal reg + global = CmmReg (CmmGlobal r) + width = cmmRegWidth platform local + expr + | width == wordWidth platform = global + | width < wordWidth platform = + CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] + | otherwise = panic "Parameter width greater than word width" + + in CmmAssign local expr + + -- Non VanillaRegs + ci (reg, RegisterParam r) = + CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) + + ci (reg, StackParam off) + | isBitsType $ localRegType reg + , typeWidth (localRegType reg) < wordWidth platform = + let + stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform)) + local = CmmLocal reg + width = cmmRegWidth platform local + expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot] + in CmmAssign local expr + + | otherwise = + CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) + where ty = localRegType reg + + init_offset = widthInBytes (wordWidth platform) -- infotable + + (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk + + (stk_size, args) = assignArgumentsPos dflags stk_off conv + localRegType formals + +-- Factoring out the common parts of the copyout functions yielded something +-- more complicated: + +data Transfer = Call | JumpRet | Jump | Ret deriving Eq + +copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr] + -> UpdFrameOffset + -> [CmmExpr] -- extra stack args + -> (Int, [GlobalReg], CmmAGraph) + +-- Generate code to move the actual parameters into the locations +-- required by the calling convention. This includes a store for the +-- return address. +-- +-- The argument layout function ignores the pointer to the info table, +-- so we slot that in here. When copying-out to a young area, we set +-- the info table for return and adjust the offsets of the other +-- parameters. If this is a call instruction, we adjust the offsets +-- of the other parameters. +copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff + = (stk_size, regs, graph) + where + platform = targetPlatform dflags + (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) + + -- See Note [Width of parameters] + co (v, RegisterParam r@(VanillaReg {})) (rs, ms) = + let width = cmmExprWidth platform v + value + | width == wordWidth platform = v + | width < wordWidth platform = + CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v] + | otherwise = panic "Parameter width greater than word width" + + in (r:rs, mkAssign (CmmGlobal r) value <*> ms) + + -- Non VanillaRegs + co (v, RegisterParam r) (rs, ms) = + (r:rs, mkAssign (CmmGlobal r) v <*> ms) + + -- See Note [Width of parameters] + co (v, StackParam off) (rs, ms) + = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) + + width v = cmmExprWidth platform v + value v + | isBitsType $ cmmExprType platform v + , width v < wordWidth platform = + CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v] + | otherwise = v + + (setRA, init_offset) = + case area of + Young id -> -- Generate a store instruction for + -- the return address if making a call + case transfer of + Call -> + ([(CmmLit (CmmBlock id), StackParam init_offset)], + widthInBytes (wordWidth platform)) + JumpRet -> + ([], + widthInBytes (wordWidth platform)) + _other -> + ([], 0) + Old -> ([], updfr_off) + + (extra_stack_off, stack_params) = + assignStack platform init_offset (cmmExprType platform) extra_stack_stuff + + args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it + (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv + (cmmExprType platform) actuals + + +-- Note [Width of parameters] +-- +-- Consider passing a small (< word width) primitive like Int8# to a function. +-- It's actually non-trivial to do this without extending/narrowing: +-- * Global registers are considered to have native word width (i.e., 64-bits on +-- x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a +-- global register. +-- * Same problem exists with LLVM IR. +-- * Lowering gets harder since on x86-32 not every register exposes its lower +-- 8 bits (e.g., for %eax we can use %al, but there isn't a corresponding +-- 8-bit register for %edi). So we would either need to extend/narrow anyway, +-- or complicate the calling convention. +-- * Passing a small integer in a stack slot, which has native word width, +-- requires extending to word width when writing to the stack and narrowing +-- when reading off the stack (see #16258). +-- So instead, we always extend every parameter smaller than native word width +-- in copyOutOflow and then truncate it back to the expected width in copyIn. +-- Note that we do this in cmm using MO_XX_Conv to avoid requiring +-- zero-/sign-extending - it's up to a backend to handle this in a most +-- efficient way (e.g., a simple register move or a smaller size store). +-- This convention (of ignoring the upper bits) is different from some C ABIs, +-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters. +-- +-- There was some discussion about this on this PR: +-- https://github.com/ghc-proposals/ghc-proposals/pull/74 + + +mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] + -> (Int, [GlobalReg], CmmAGraph) +mkCallEntry dflags conv formals extra_stk + = copyInOflow dflags conv Old formals extra_stk + +lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr] + -> UpdFrameOffset + -> (ByteOff -> [GlobalReg] -> CmmAGraph) + -> CmmAGraph +lastWithArgs dflags transfer area conv actuals updfr_off last = + lastWithArgsAndExtraStack dflags transfer area conv actuals + updfr_off noExtraStack last + +lastWithArgsAndExtraStack :: DynFlags + -> Transfer -> Area -> Convention -> [CmmExpr] + -> UpdFrameOffset -> [CmmExpr] + -> (ByteOff -> [GlobalReg] -> CmmAGraph) + -> CmmAGraph +lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off + extra_stack last = + copies <*> last outArgs regs + where + (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals + updfr_off extra_stack + + +noExtraStack :: [CmmExpr] +noExtraStack = [] + +toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff + -> ByteOff -> [GlobalReg] + -> CmmAGraph +toCall e cont updfr_off res_space arg_space regs = + mkLast $ CmmCall e cont regs arg_space res_space updfr_off diff --git a/GHC/Cmm/Info.hs b/GHC/Cmm/Info.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Info.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE CPP #-} +module GHC.Cmm.Info ( + mkEmptyContInfoTable, + cmmToRawCmm, + srtEscape, + + -- info table accessors + closureInfoPtr, + entryCode, + getConstrTag, + cmmGetClosureType, + infoTable, + infoTableConstrTag, + infoTableSrtBitmap, + infoTableClosureType, + infoTablePtrs, + infoTableNonPtrs, + funInfoTable, + funInfoArity, + + -- info table sizes and offsets + stdInfoTableSizeW, + fixedInfoTableSizeW, + profInfoTableSizeW, + maxStdInfoTableSizeW, + maxRetInfoTableSizeW, + stdInfoTableSizeB, + conInfoTableSizeB, + stdSrtBitmapOffset, + stdClosureTypeOffset, + stdPtrsOffset, stdNonPtrsOffset, +) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Runtime.Heap.Layout +import GHC.Data.Bitmap +import GHC.Data.Stream (Stream) +import qualified GHC.Data.Stream as Stream +import GHC.Cmm.Dataflow.Collections + +import GHC.Platform +import GHC.Data.Maybe +import GHC.Driver.Session +import GHC.Utils.Error (withTimingSilent) +import GHC.Utils.Panic +import GHC.Types.Unique.Supply +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Outputable + +import Data.ByteString (ByteString) +import Data.Bits + +-- When we split at proc points, we need an empty info table. +mkEmptyContInfoTable :: CLabel -> CmmInfoTable +mkEmptyContInfoTable info_lbl + = CmmInfoTable { cit_lbl = info_lbl + , cit_rep = mkStackRep [] + , cit_prof = NoProfilingInfo + , cit_srt = Nothing + , cit_clo = Nothing } + +cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a + -> IO (Stream IO RawCmmGroup a) +cmmToRawCmm dflags cmms + = do { uniqs <- mkSplitUniqSupply 'i' + ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl]) + do_one uniqs cmm = + -- NB. strictness fixes a space leak. DO NOT REMOVE. + withTimingSilent dflags (text "Cmm -> Raw Cmm") + forceRes $ + case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of + (b,uniqs') -> return (uniqs',b) + ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms) + } + + where forceRes (uniqs, rawcmms) = + uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms + +-- Make a concrete info table, represented as a list of CmmStatic +-- (it can't be simply a list of Word, because the SRT field is +-- represented by a label+offset expression). +-- +-- With tablesNextToCode, the layout is +-- +-- +-- +-- +-- Without tablesNextToCode, the layout of an info table is +-- +-- +-- +-- +-- See includes/rts/storage/InfoTables.h +-- +-- For return-points these are as follows +-- +-- Tables next to code: +-- +-- +-- +-- ret-addr --> +-- +-- Not tables-next-to-code: +-- +-- ret-addr --> +-- +-- +-- +-- * The SRT slot is only there if there is SRT info to record + +mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl] +mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] + +mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) + -- + -- in the non-tables-next-to-code case, procs can have at most a + -- single info table associated with the entry label of the proc. + -- + | not (platformTablesNextToCode (targetPlatform dflags)) + = case topInfoTable proc of -- must be at most one + -- no info table + Nothing -> + return [CmmProc mapEmpty entry_lbl live blocks] + + Just info@CmmInfoTable { cit_lbl = info_lbl } -> do + (top_decls, (std_info, extra_bits)) <- + mkInfoTableContents dflags info Nothing + let + rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits + -- + -- Separately emit info table (with the function entry + -- point as first entry) and the entry code + -- + return (top_decls ++ + [CmmProc mapEmpty entry_lbl live blocks, + mkRODataLits info_lbl + (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) + + -- + -- With tables-next-to-code, we can have many info tables, + -- associated with some of the BlockIds of the proc. For each info + -- table we need to turn it into CmmStatics, and collect any new + -- CmmDecls that arise from doing so. + -- + | otherwise + = do + (top_declss, raw_infos) <- + unzip `fmap` mapM do_one_info (mapToList (info_tbls infos)) + return (concat top_declss ++ + [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) + + where + platform = targetPlatform dflags + do_one_info (lbl,itbl) = do + (top_decls, (std_info, extra_bits)) <- + mkInfoTableContents dflags itbl Nothing + let + info_lbl = cit_lbl itbl + rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits + -- + return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $ + reverse rel_extra_bits ++ rel_std_info)) + +----------------------------------------------------- +type InfoTableContents = ( [CmmLit] -- The standard part + , [CmmLit] ) -- The "extra bits" +-- These Lits have *not* had mkRelativeTo applied to them + +mkInfoTableContents :: DynFlags + -> CmmInfoTable + -> Maybe Int -- Override default RTS type tag? + -> UniqSM ([RawCmmDecl], -- Auxiliary top decls + InfoTableContents) -- Info tbl + extra bits + +mkInfoTableContents dflags + info@(CmmInfoTable { cit_lbl = info_lbl + , cit_rep = smrep + , cit_prof = prof + , cit_srt = srt }) + mb_rts_tag + | RTSRep rts_tag rep <- smrep + = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) + -- Completely override the rts_tag that mkInfoTableContents would + -- otherwise compute, with the rts_tag stored in the RTSRep + -- (which in turn came from a handwritten .cmm file) + + | StackRep frame <- smrep + = do { (prof_lits, prof_data) <- mkProfLits platform prof + ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt + ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame + ; let + std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit + rts_tag | Just tag <- mb_rts_tag = tag + | null liveness_data = rET_SMALL -- Fits in extra_bits + | otherwise = rET_BIG -- Does not; extra_bits is + -- a label + ; return (prof_data ++ liveness_data, (std_info, srt_label)) } + + | HeapRep _ ptrs nonptrs closure_type <- smrep + = do { let layout = packIntsCLit platform ptrs nonptrs + ; (prof_lits, prof_data) <- mkProfLits platform prof + ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt + ; (mb_srt_field, mb_layout, extra_bits, ct_data) + <- mk_pieces closure_type srt_label + ; let std_info = mkStdInfoTable dflags prof_lits + (mb_rts_tag `orElse` rtsClosureType smrep) + (mb_srt_field `orElse` srt_bitmap) + (mb_layout `orElse` layout) + ; return (prof_data ++ ct_data, (std_info, extra_bits)) } + where + platform = targetPlatform dflags + mk_pieces :: ClosureTypeInfo -> [CmmLit] + -> UniqSM ( Maybe CmmLit -- Override the SRT field with this + , Maybe CmmLit -- Override the layout field with this + , [CmmLit] -- "Extra bits" for info table + , [RawCmmDecl]) -- Auxiliary data decls + mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor + = do { (descr_lit, decl) <- newStringLit con_descr + ; return ( Just (CmmInt (fromIntegral con_tag) + (halfWordWidth platform)) + , Nothing, [descr_lit], [decl]) } + + mk_pieces Thunk srt_label + = return (Nothing, Nothing, srt_label, []) + + mk_pieces (ThunkSelector offset) _no_srt + = return (Just (CmmInt 0 (halfWordWidth platform)), + Just (mkWordCLit platform (fromIntegral offset)), [], []) + -- Layout known (one free var); we use the layout field for offset + + mk_pieces (Fun arity (ArgSpec fun_type)) srt_label + = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label + ; return (Nothing, Nothing, extra_bits, []) } + + mk_pieces (Fun arity (ArgGen arg_bits)) srt_label + = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits + ; let fun_type | null liveness_data = aRG_GEN + | otherwise = aRG_GEN_BIG + extra_bits = [ packIntsCLit platform fun_type arity ] + ++ (if inlineSRT platform then [] else [ srt_lit ]) + ++ [ liveness_lit, slow_entry ] + ; return (Nothing, Nothing, extra_bits, liveness_data) } + where + slow_entry = CmmLabel (toSlowEntryLbl info_lbl) + srt_lit = case srt_label of + [] -> mkIntCLit platform 0 + (lit:_rest) -> ASSERT( null _rest ) lit + + mk_pieces other _ = pprPanic "mk_pieces" (ppr other) + +mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier + +packIntsCLit :: Platform -> Int -> Int -> CmmLit +packIntsCLit platform a b = packHalfWordsCLit platform + (toStgHalfWord platform (fromIntegral a)) + (toStgHalfWord platform (fromIntegral b)) + + +mkSRTLit :: Platform + -> CLabel + -> Maybe CLabel + -> ([CmmLit], -- srt_label, if any + CmmLit) -- srt_bitmap +mkSRTLit platform info_lbl (Just lbl) + | inlineSRT platform + = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth platform)) +mkSRTLit platform _ Nothing = ([], CmmInt 0 (halfWordWidth platform)) +mkSRTLit platform _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth platform)) + + +-- | Is the SRT offset field inline in the info table on this platform? +-- +-- See the section "Referring to an SRT from the info table" in +-- Note [SRTs] in "GHC.Cmm.Info.Build" +inlineSRT :: Platform -> Bool +inlineSRT platform = platformArch platform == ArchX86_64 + && platformTablesNextToCode platform + +------------------------------------------------------------------------- +-- +-- Lay out the info table and handle relative offsets +-- +------------------------------------------------------------------------- + +-- This function takes +-- * the standard info table portion (StgInfoTable) +-- * the "extra bits" (StgFunInfoExtraRev etc.) +-- * the entry label +-- * the code +-- and lays them out in memory, producing a list of RawCmmDecl + +------------------------------------------------------------------------- +-- +-- Position independent code +-- +------------------------------------------------------------------------- +-- In order to support position independent code, we mustn't put absolute +-- references into read-only space. Info tables in the tablesNextToCode +-- case must be in .text, which is read-only, so we doctor the CmmLits +-- to use relative offsets instead. + +-- Note that this is done even when the -fPIC flag is not specified, +-- as we want to keep binary compatibility between PIC and non-PIC. + +makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit +makeRelativeRefTo platform info_lbl lit + = if platformTablesNextToCode platform + then case lit of + CmmLabel lbl -> CmmLabelDiffOff lbl info_lbl 0 (wordWidth platform) + CmmLabelOff lbl off -> CmmLabelDiffOff lbl info_lbl off (wordWidth platform) + _ -> lit + else lit + +------------------------------------------------------------------------- +-- +-- Build a liveness mask for the stack layout +-- +------------------------------------------------------------------------- + +-- There are four kinds of things on the stack: +-- +-- - pointer variables (bound in the environment) +-- - non-pointer variables (bound in the environment) +-- - free slots (recorded in the stack free list) +-- - non-pointer data slots (recorded in the stack free list) +-- +-- The first two are represented with a 'Just' of a 'LocalReg'. +-- The last two with one or more 'Nothing' constructors. +-- Each 'Nothing' represents one used word. +-- +-- The head of the stack layout is the top of the stack and +-- the least-significant bit. + +mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) + -- ^ Returns: + -- 1. The bitmap (literal value or label) + -- 2. Large bitmap CmmData if needed + +mkLivenessBits dflags liveness + | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word + = do { uniq <- getUniqueM + ; let bitmap_lbl = mkBitmapLabel uniq + ; return (CmmLabel bitmap_lbl, + [mkRODataLits bitmap_lbl lits]) } + + | otherwise -- Fits in one word + = return (mkStgWordCLit platform bitmap_word, []) + where + platform = targetPlatform dflags + n_bits = length liveness + + bitmap :: Bitmap + bitmap = mkBitmap platform liveness + + small_bitmap = case bitmap of + [] -> toStgWord platform 0 + [b] -> b + _ -> panic "mkLiveness" + bitmap_word = toStgWord platform (fromIntegral n_bits) + .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) + + lits = mkWordCLit platform (fromIntegral n_bits) + : map (mkStgWordCLit platform) bitmap + -- The first word is the size. The structure must match + -- StgLargeBitmap in includes/rts/storage/InfoTable.h + +------------------------------------------------------------------------- +-- +-- Generating a standard info table +-- +------------------------------------------------------------------------- + +-- The standard bits of an info table. This part of the info table +-- corresponds to the StgInfoTable type defined in +-- includes/rts/storage/InfoTables.h. +-- +-- Its shape varies with ticky/profiling/tables next to code etc +-- so we can't use constant offsets from Constants + +mkStdInfoTable + :: DynFlags + -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) + -> Int -- Closure RTS tag + -> CmmLit -- SRT length + -> CmmLit -- layout field + -> [CmmLit] + +mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit + = -- Parallel revertible-black hole field + prof_info + -- Ticky info (none at present) + -- Debug info (none at present) + ++ [layout_lit, tag, srt] + + where + platform = targetPlatform dflags + prof_info + | sccProfilingEnabled dflags = [type_descr, closure_descr] + | otherwise = [] + + tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform) + +------------------------------------------------------------------------- +-- +-- Making string literals +-- +------------------------------------------------------------------------- + +mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) +mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), []) +mkProfLits _ (ProfilingInfo td cd) + = do { (td_lit, td_decl) <- newStringLit td + ; (cd_lit, cd_decl) <- newStringLit cd + ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } + +newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt) +newStringLit bytes + = do { uniq <- getUniqueM + ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) } + + +-- Misc utils + +-- | Value of the srt field of an info table when using an StgLargeSRT +srtEscape :: Platform -> StgHalfWord +srtEscape platform = toStgHalfWord platform (-1) + +------------------------------------------------------------------------- +-- +-- Accessing fields of an info table +-- +------------------------------------------------------------------------- + +-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is +-- enabled. +wordAligned :: DynFlags -> CmmExpr -> CmmExpr +wordAligned dflags e + | gopt Opt_AlignmentSanitisation dflags + = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e] + | otherwise + = e + where platform = targetPlatform dflags + +closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr +-- Takes a closure pointer and returns the info table pointer +closureInfoPtr dflags e = + CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags)) + +-- | Takes an info pointer (the first word of a closure) and returns its entry +-- code +entryCode :: Platform -> CmmExpr -> CmmExpr +entryCode platform e = + if platformTablesNextToCode platform + then e + else CmmLoad e (bWord platform) + +getConstrTag :: DynFlags -> CmmExpr -> CmmExpr +-- Takes a closure pointer, and return the *zero-indexed* +-- constructor tag obtained from the info table +-- This lives in the SRT field of the info table +-- (constructors don't need SRTs). +getConstrTag dflags closure_ptr + = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table] + where + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) + platform = targetPlatform dflags + +cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr +-- Takes a closure pointer, and return the closure type +-- obtained from the info table +cmmGetClosureType dflags closure_ptr + = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table] + where + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) + platform = targetPlatform dflags + +infoTable :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info pointer (the first word of a closure) +-- and returns a pointer to the first word of the standard-form +-- info table, excluding the entry-code word (if present) +infoTable dflags info_ptr + | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer + where platform = targetPlatform dflags + +infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the constr tag +-- field of the info table (same as the srt_bitmap field) +infoTableConstrTag = infoTableSrtBitmap + +infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the srt_bitmap +-- field of the info table +infoTableSrtBitmap dflags info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform) + where platform = targetPlatform dflags + +infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the closure type +-- field of the info table. +infoTableClosureType dflags info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform) + where platform = targetPlatform dflags + +infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTablePtrs dflags info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform) + where platform = targetPlatform dflags + +infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTableNonPtrs dflags info_tbl + = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform) + where platform = targetPlatform dflags + +funInfoTable :: DynFlags -> CmmExpr -> CmmExpr +-- Takes the info pointer of a function, +-- and returns a pointer to the first word of the StgFunInfoExtra struct +-- in the info table. +funInfoTable dflags info_ptr + | platformTablesNextToCode platform + = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) + | otherwise + = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags) + -- Past the entry code pointer + where + platform = targetPlatform dflags + +-- Takes the info pointer of a function, returns the function's arity +funInfoArity :: DynFlags -> CmmExpr -> CmmExpr +funInfoArity dflags iptr + = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes)) + where + platform = targetPlatform dflags + fun_info = funInfoTable dflags iptr + rep = cmmBits (widthFromBytes rep_bytes) + tablesNextToCode = platformTablesNextToCode platform + + (rep_bytes, offset) + | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc + , oFFSET_StgFunInfoExtraRev_arity dflags ) + | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc + , oFFSET_StgFunInfoExtraFwd_arity dflags ) + + pc = platformConstants dflags + +----------------------------------------------------------------------------- +-- +-- Info table sizes & offsets +-- +----------------------------------------------------------------------------- + +stdInfoTableSizeW :: DynFlags -> WordOff +-- The size of a standard info table varies with profiling/ticky etc, +-- so we can't get it from Constants +-- It must vary in sync with mkStdInfoTable +stdInfoTableSizeW dflags + = fixedInfoTableSizeW + + if sccProfilingEnabled dflags + then profInfoTableSizeW + else 0 + +fixedInfoTableSizeW :: WordOff +fixedInfoTableSizeW = 2 -- layout, type + +profInfoTableSizeW :: WordOff +profInfoTableSizeW = 2 + +maxStdInfoTableSizeW :: WordOff +maxStdInfoTableSizeW = + 1 {- entry, when !tablesNextToCode -} + + fixedInfoTableSizeW + + profInfoTableSizeW + +maxRetInfoTableSizeW :: WordOff +maxRetInfoTableSizeW = + maxStdInfoTableSizeW + + 1 {- srt label -} + +stdInfoTableSizeB :: DynFlags -> ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform + where platform = targetPlatform dflags + +stdSrtBitmapOffset :: DynFlags -> ByteOff +-- Byte offset of the SRT bitmap half-word which is +-- in the *higher-addressed* part of the type_lit +stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize platform + where platform = targetPlatform dflags + +stdClosureTypeOffset :: DynFlags -> ByteOff +-- Byte offset of the closure type half-word +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - platformWordSizeInBytes platform + where platform = targetPlatform dflags + +stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + where platform = targetPlatform dflags + +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + halfWordSize platform + where platform = targetPlatform dflags + +conInfoTableSizeB :: DynFlags -> Int +conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform + where platform = targetPlatform dflags diff --git a/GHC/Cmm/Info/Build.hs b/GHC/Cmm/Info/Build.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Info/Build.hs @@ -0,0 +1,1194 @@ +{-# LANGUAGE GADTs, BangPatterns, RecordWildCards, + GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections, + ScopedTypeVariables, OverloadedStrings #-} + +module GHC.Cmm.Info.Build + ( CAFSet, CAFEnv, cafAnal, cafAnalData + , doSRTs, ModuleSRTInfo (..), emptySRT + , SRTMap, srtMapNonCAFs + ) where + +import GHC.Prelude hiding (succ) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow +import GHC.Unit.Module +import GHC.Platform +import GHC.Data.Graph.Directed +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Driver.Session +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Runtime.Heap.Layout +import GHC.Types.Unique.Supply +import GHC.Types.CostCentre +import GHC.StgToCmm.Heap +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config + +import Control.Monad +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import Data.List (unzip4) + +import GHC.Types.Name.Set + +{- Note [SRTs] + +SRTs are the mechanism by which the garbage collector can determine +the live CAFs in the program. + +Representation +^^^^^^^^^^^^^^ + ++------+ +| info | +| | +-----+---+---+---+ +| -------->|SRT_2| | | | | 0 | +|------| +-----+-|-+-|-+---+ +| | | | +| code | | | +| | v v + +An SRT is simply an object in the program's data segment. It has the +same representation as a static constructor. There are 16 +pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info, +representing SRT objects with 1-16 pointers, respectively. + +The entries of an SRT object point to static closures, which are either +- FUN_STATIC, THUNK_STATIC or CONSTR +- Another SRT (actually just a CONSTR) + +The final field of the SRT is the static link field, used by the +garbage collector to chain together static closures that it visits and +to determine whether a static closure has been visited or not. (see +Note [STATIC_LINK fields]) + +By traversing the transitive closure of an SRT, the GC will reach all +of the CAFs that are reachable from the code associated with this SRT. + +If we need to create an SRT with more than 16 entries, we build a +chain of SRT objects with all but the last having 16 entries. + ++-----+---+- -+---+---+ +|SRT16| | | | | | 0 | ++-----+-|-+- -+-|-+---+ + | | + v v + +----+---+---+---+ + |SRT2| | | | | 0 | + +----+-|-+-|-+---+ + | | + | | + v v + +Referring to an SRT from the info table +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The following things have SRTs: + +- Static functions (FUN) +- Static thunks (THUNK), ie. CAFs +- Continuations (RET_SMALL, etc.) + +In each case, the info table points to the SRT. + +- info->srt is zero if there's no SRT, otherwise: +- info->srt == 1 and info->f.srt_offset points to the SRT + +e.g. for a FUN with an SRT: + +StgFunInfoTable +------+ + info->f.srt_offset | ------------> offset to SRT object +StgStdInfoTable +------+ + info->layout.ptrs | ... | + info->layout.nptrs | ... | + info->srt | 1 | + info->type | ... | + |------| + +On x86_64, we optimise the info table representation further. The +offset to the SRT can be stored in 32 bits (all code lives within a +2GB region in x86_64's small memory model), so we can save a word in +the info table by storing the srt_offset in the srt field, which is +half a word. + +On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169): + +- info->srt is zero if there's no SRT, otherwise: +- info->srt is an offset from the info pointer to the SRT object + +StgStdInfoTable +------+ + info->layout.ptrs | | + info->layout.nptrs | | + info->srt | ------------> offset to SRT object + |------| + + +EXAMPLE +^^^^^^^ + +f = \x. ... g ... + where + g = \y. ... h ... c1 ... + h = \z. ... c2 ... + +c1 & c2 are CAFs + +g and h are local functions, but they have no static closures. When +we generate code for f, we start with a CmmGroup of four CmmDecls: + + [ f_closure, f_entry, g_entry, h_entry ] + +we process each CmmDecl separately in cpsTop, giving us a list of +CmmDecls. e.g. for f_entry, we might end up with + + [ f_entry, f1_ret, f2_proc ] + +where f1_ret is a return point, and f2_proc is a proc-point. We have +a CAFSet for each of these CmmDecls, let's suppose they are + + [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ] + [ g_entry{h_info, c1_closure} ] + [ h_entry{c2_closure} ] + +Next, we make an SRT for each of these functions: + + f_srt : [g_info] + g_srt : [h_info, c1_closure] + h_srt : [c2_closure] + +Now, for g_info and h_info, we want to refer to the SRTs for g and h +respectively, which we'll label g_srt and h_srt: + + f_srt : [g_srt] + g_srt : [h_srt, c1_closure] + h_srt : [c2_closure] + +Now, when an SRT has a single entry, we don't actually generate an SRT +closure for it, instead we just replace references to it with its +single element. So, since h_srt == c2_closure, we have + + f_srt : [g_srt] + g_srt : [c2_closure, c1_closure] + h_srt : [c2_closure] + +and the only SRT closure we generate is + + g_srt = SRT_2 [c2_closure, c1_closure] + +Algorithm +^^^^^^^^^ + +0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {} + Maps closures to their SRT entries (i.e. how they appear in a SRT payload) + +1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG + after code-generation. + +2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might + be multiple CmmDecls in the result, due to proc-point splitting. + +3. In cpsTop, *before* proc-point splitting, when we still have a single + CmmDecl, we do cafAnal for procs: + + * cafAnal performs a backwards analysis on the code blocks + + * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel), + representing all the CAFLabels reachable from this label. + + * A label is added to the set if it refers to a FUN, THUNK, or RET, + and its CafInfo /= NoCafRefs. + (NB. all CafInfo for Ids in the current module should be initialised to + MayHaveCafRefs) + + * The result is CAFEnv = LabelMap CAFSet + + (Why *before* proc-point splitting? Because the analysis needs to propagate + information across branches, and proc-point splitting turns branches into + CmmCalls to top-level CmmDecls. The analysis would fail to find all the + references to CAFFY labels if we did it after proc-point splitting.) + + For static data, cafAnalData simply returns set of all labels that refer to a + FUN, THUNK, and RET whose CafInfos /= NoCafRefs. + +4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl) + for static data. So after `mapM cpsTop decls` we have + [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)] + +5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl]) + +6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets) + +7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel + +8. For each SCC in dependency order + - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC + - Apply CAFEnv to each label and concat the result :: [CAFLabel] + - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get + srt :: [SRTEntry] + - Make a label for this SRT, call it l + - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the + group to the SRT (see Note [Invalid optimisation: shortcutting]) + - Add to srtMap: lbls -> if null srt then Nothing else Just l + +9. At the end, for every top-level binding x, if srtMap x == Nothing, then the + binding is non-CAFFY, otherwise it is CAFFY. + +Optimisations +^^^^^^^^^^^^^ + +To reduce the code size overhead and the cost of traversing SRTs in +the GC, we want to simplify SRTs where possible. We therefore apply +the following optimisations. Each has a [keyword]; search for the +keyword in the code below to see where the optimisation is +implemented. + +1. [Inline] we never create an SRT with a single entry, instead we + point to the single entry directly from the info table. + + i.e. instead of + + +------+ + | info | + | | +-----+---+---+ + | -------->|SRT_1| | | 0 | + |------| +-----+-|-+---+ + | | | + | code | | + | | v + C + + we can point directly to the closure: + + +------+ + | info | + | | + | -------->C + |------| + | | + | code | + | | + + + Furthermore, the SRT for any code that refers to this info table + can point directly to C. + + The exception to this is when we're doing dynamic linking. In that + case, if the closure is not locally defined then we can't point to + it directly from the info table, because this is the text section + which cannot contain runtime relocations. In this case we skip this + optimisation and generate the singleton SRT, because SRTs are in the + data section and *can* have relocatable references. + +2. [FUN] A static function closure can also be an SRT, we simply put + the SRT entries as fields in the static closure. This makes a lot + of sense: the static references are just like the free variables of + the FUN closure. + + i.e. instead of + + f_closure: + +-----+---+ + | | | 0 | + +- |--+---+ + | +------+ + | | info | f_srt: + | | | +-----+---+---+---+ + | | -------->|SRT_2| | | | + 0 | + `----------->|------| +-----+-|-+-|-+---+ + | | | | + | code | | | + | | v v + + + We can generate: + + f_closure: + +-----+---+---+---+ + | | | | | | | 0 | + +- |--+-|-+-|-+---+ + | | | +------+ + | v v | info | + | | | + | | 0 | + `----------->|------| + | | + | code | + | | + + + (note: we can't do this for THUNKs, because the thunk gets + overwritten when it is entered, so we wouldn't be able to share + this SRT with other info tables that want to refer to it (see + [Common] below). FUNs are immutable so don't have this problem.) + +3. [Common] Identical SRTs can be commoned up. + +4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also + refers to C (perhaps transitively), then we can omit the reference + to C from A. + + +Note that there are many other optimisations that we could do, but +aren't implemented. In general, we could omit any reference from an +SRT if everything reachable from it is also reachable from the other +fields in the SRT. Our [Filter] optimisation is a special case of +this. + +Another opportunity we don't exploit is this: + +A = {X,Y,Z} +B = {Y,Z} +C = {X,B} + +Here we could use C = {A} and therefore [Inline] C = A. +-} + +-- --------------------------------------------------------------------- +{- Note [Invalid optimisation: shortcutting] + +You might think that if we have something like + +A's SRT = {B} +B's SRT = {X} + +that we could replace the reference to B in A's SRT with X. + +A's SRT = {X} +B's SRT = {X} + +and thereby perhaps save a little work at runtime, because we don't +have to visit B. + +But this is NOT valid. + +Consider these cases: + +0. B can't be a constructor, because constructors don't have SRTs + +1. B is a CAF. This is the easy one. Obviously we want A's SRT to + point to B, so that it keeps B alive. + +2. B is a function. This is the tricky one. The reason we can't +shortcut in this case is that we aren't allowed to resurrect static +objects. + +== How does this cause a problem? == + +The particular case that cropped up when we tried this was #15544. +- A is a thunk +- B is a static function +- X is a CAF +- suppose we GC when A is alive, and B is not otherwise reachable. +- B is "collected", meaning that it doesn't make it onto the static + objects list during this GC, but nothing bad happens yet. +- Next, suppose we enter A, and then call B. (remember that A refers to B) + At the entry point to B, we GC. This puts B on the stack, as part of the + RET_FUN stack frame that gets pushed when we GC at a function entry point. +- This GC will now reach B +- But because B was previous "collected", it breaks the assumption + that static objects are never resurrected. See Note [STATIC_LINK + fields] in rts/sm/Storage.h for why this is bad. +- In practice, the GC thinks that B has already been visited, and so + doesn't visit X, and catastrophe ensues. + +== Isn't this caused by the RET_FUN business? == + +Maybe, but could you prove that RET_FUN is the only way that +resurrection can occur? + +So, no shortcutting. + +Note [Ticky labels in SRT analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered +non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing` +(meaning they're not CAFFY). + +However when building with -ticky we generate ticky CLabels using the function's +`Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky +build we get two IdLabels using the name `sat_s1rQ`: + +- For the function itself: IdLabel sat_s1rQ ... Entry +- For the ticky counter: IdLabel sat_s1rQ ... RednCounts + +In these cases we really want to use the function definition for the SRT +analysis of this Name, because that's what we export for this Name -- ticky +counters are not exported. So we ignore ticky counters in SRT analysis (which +are never CAFFY and never exported). + +Not doing this caused #17947 where we analysed the function first mapped the +name to CAFFY. We then saw the ticky constructor, and becuase it has the same +Name as the function and is not CAFFY we overrode the CafInfo of the name as +non-CAFFY. +-} + +-- --------------------------------------------------------------------- +-- Label types + +-- Labels that come from cafAnal can be: +-- - _closure labels for static functions or CAFs +-- - _info labels for dynamic functions, thunks, or continuations +-- - _entry labels for functions or thunks +-- +-- Meanwhile the labels on top-level blocks are _entry labels. +-- +-- To put everything in the same namespace we convert all labels to +-- closure labels using toClosureLbl. Note that some of these +-- labels will not actually exist; that's ok because we're going to +-- map them to SRTEntry later, which ranges over labels that do exist. +-- +newtype CAFLabel = CAFLabel CLabel + deriving (Eq,Ord,Outputable) + +type CAFSet = Set CAFLabel +type CAFEnv = LabelMap CAFSet + +mkCAFLabel :: CLabel -> CAFLabel +mkCAFLabel lbl = CAFLabel (toClosureLbl lbl) + +-- This is a label that we can put in an SRT. It *must* be a closure label, +-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR. +newtype SRTEntry = SRTEntry CLabel + deriving (Eq, Ord, Outputable) + +-- --------------------------------------------------------------------- +-- CAF analysis + +addCafLabel :: CLabel -> CAFSet -> CAFSet +addCafLabel l s + | Just _ <- hasHaskellName l + , let caf_label = mkCAFLabel l + -- For imported Ids hasCAF will have accurate CafInfo + -- Locals are initialized as CAFFY. We turn labels with empty SRTs into + -- non-CAFFYs in doSRTs + , hasCAF l + = Set.insert caf_label s + | otherwise + = s + +cafAnalData + :: CmmStatics + -> CAFSet + +cafAnalData (CmmStaticsRaw _lbl _data) = + Set.empty + +cafAnalData (CmmStatics _lbl _itbl _ccs payload) = + foldl' analyzeStatic Set.empty payload + where + analyzeStatic s lit = + case lit of + CmmLabel c -> addCafLabel c s + CmmLabelOff c _ -> addCafLabel c s + CmmLabelDiffOff c1 c2 _ _ -> addCafLabel c1 $! addCafLabel c2 s + _ -> s + +-- | +-- For each code block: +-- - collect the references reachable from this code block to FUN, +-- THUNK or RET labels for which hasCAF == True +-- +-- This gives us a `CAFEnv`: a mapping from code block to sets of labels +-- +cafAnal + :: LabelSet -- The blocks representing continuations, ie. those + -- that will get RET info tables. These labels will + -- get their own SRTs, so we don't aggregate CAFs from + -- references to these labels, we just use the label. + -> CLabel -- The top label of the proc + -> CmmGraph + -> CAFEnv +cafAnal contLbls topLbl cmmGraph = + analyzeCmmBwd cafLattice + (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty + + +cafLattice :: DataflowLattice CAFSet +cafLattice = DataflowLattice Set.empty add + where + add (OldFact old) (NewFact new) = + let !new' = old `Set.union` new + in changedIf (Set.size new' > Set.size old) new' + + +cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet +cafTransfers contLbls entry topLbl + block@(BlockCC eNode middle xNode) fBase = + let joined :: CAFSet + joined = cafsInNode xNode $! live' + + result :: CAFSet + !result = foldNodesBwdOO cafsInNode middle joined + + facts :: [Set CAFLabel] + facts = mapMaybe successorFact (successors xNode) + + live' :: CAFSet + live' = joinFacts cafLattice facts + + successorFact :: Label -> Maybe (Set CAFLabel) + successorFact s + -- If this is a loop back to the entry, we can refer to the + -- entry label. + | s == entry = Just (addCafLabel topLbl Set.empty) + -- If this is a continuation, we want to refer to the + -- SRT for the continuation's info table + | s `setMember` contLbls + = Just (Set.singleton (mkCAFLabel (infoTblLbl s))) + -- Otherwise, takes the CAF references from the destination + | otherwise + = lookupFact s fBase + + cafsInNode :: CmmNode e x -> CAFSet -> CAFSet + cafsInNode node set = foldExpDeep addCafExpr node set + + addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel + addCafExpr expr !set = + case expr of + CmmLit (CmmLabel c) -> + addCafLabel c set + CmmLit (CmmLabelOff c _) -> + addCafLabel c set + CmmLit (CmmLabelDiffOff c1 c2 _ _) -> + addCafLabel c1 $! addCafLabel c2 set + _ -> + set + in + srtTrace "cafTransfers" (text "block:" <+> ppr block $$ + text "contLbls:" <+> ppr contLbls $$ + text "entry:" <+> ppr entry $$ + text "topLbl:" <+> ppr topLbl $$ + text "cafs in exit:" <+> ppr joined $$ + text "result:" <+> ppr result) $ + mapSingleton (entryLabel eNode) result + + +-- ----------------------------------------------------------------------------- +-- ModuleSRTInfo + +data ModuleSRTInfo = ModuleSRTInfo + { thisModule :: Module + -- ^ Current module being compiled. Required for calling labelDynamic. + , dedupSRTs :: Map (Set SRTEntry) SRTEntry + -- ^ previous SRTs we've emitted, so we can de-duplicate. + -- Used to implement the [Common] optimisation. + , flatSRTs :: Map SRTEntry (Set SRTEntry) + -- ^ The reverse mapping, so that we can remove redundant + -- entries. e.g. if we have an SRT [a,b,c], and we know that b + -- points to [c,d], we can omit c and emit [a,b]. + -- Used to implement the [Filter] optimisation. + , moduleSRTMap :: SRTMap + } + +instance Outputable ModuleSRTInfo where + ppr ModuleSRTInfo{..} = + text "ModuleSRTInfo {" $$ + (nest 4 $ text "dedupSRTs =" <+> ppr dedupSRTs $$ + text "flatSRTs =" <+> ppr flatSRTs $$ + text "moduleSRTMap =" <+> ppr moduleSRTMap) $$ char '}' + +emptySRT :: Module -> ModuleSRTInfo +emptySRT mod = + ModuleSRTInfo + { thisModule = mod + , dedupSRTs = Map.empty + , flatSRTs = Map.empty + , moduleSRTMap = Map.empty + } + +-- ----------------------------------------------------------------------------- +-- Constructing SRTs + +{- Implementation notes + +- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable + +- The entry in info_tbls corresponding to g_entry is the closure info + table, the rest are continuations. + +- Each entry in info_tbls possibly needs an SRT. We need to make a + label for each of these. + +- We get the CAFSet for each entry from the CAFEnv + +-} + +data SomeLabel + = BlockLabel !Label + | DeclLabel CLabel + deriving (Eq, Ord) + +instance Outputable SomeLabel where + ppr (BlockLabel l) = text "b:" <+> ppr l + ppr (DeclLabel l) = text "s:" <+> ppr l + +getBlockLabel :: SomeLabel -> Maybe Label +getBlockLabel (BlockLabel l) = Just l +getBlockLabel (DeclLabel _) = Nothing + +getBlockLabels :: [SomeLabel] -> [Label] +getBlockLabels = mapMaybe getBlockLabel + +-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl, +-- where the label is +-- - the info label for a continuation or dynamic closure +-- - the closure label for a top-level function (not a CAF) +getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)] +getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) = + [] +getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) = + [ (DeclLabel lbl, mkCAFLabel lbl) ] +getLabelledBlocks (CmmProc top_info _ _ _) = + [ (BlockLabel blockId, caf_lbl) + | (blockId, info) <- mapToList (info_tbls top_info) + , let rep = cit_rep info + , not (isStaticRep rep) || not (isThunkRep rep) + , let !caf_lbl = mkCAFLabel (cit_lbl info) + ] + +-- | Put the labelled blocks that we will be annotating with SRTs into +-- dependency order. This is so that we can process them one at a +-- time, resolving references to earlier blocks to point to their +-- SRTs. CAFs themselves are not included here; see getCAFs below. +depAnalSRTs + :: CAFEnv + -> Map CLabel CAFSet -- CAFEnv for statics + -> [CmmDecl] + -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)] +depAnalSRTs cafEnv cafEnv_static decls = + srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$ + text "nodes:" <+> ppr (map node_payload nodes) $$ + text "graph:" <+> ppr graph) graph + where + labelledBlocks :: [(SomeLabel, CAFLabel)] + labelledBlocks = concatMap getLabelledBlocks decls + labelToBlock :: Map CAFLabel SomeLabel + labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks + + nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)] + nodes = [ DigraphNode (l,lbl,cafs') l + (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs')) + | (l, lbl) <- labelledBlocks + , Just (cafs :: Set CAFLabel) <- + [case l of + BlockLabel l -> mapLookup l cafEnv + DeclLabel cl -> Map.lookup cl cafEnv_static] + , let cafs' = Set.delete lbl cafs + ] + + graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)] + graph = stronglyConnCompFromEdgedVerticesOrd nodes + +-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF. +-- These are treated differently from other labelled blocks: +-- - we never shortcut a reference to a CAF to the contents of its +-- SRT, since the point of SRTs is to keep CAFs alive. +-- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. +-- instead we generate their SRTs after everything else. +getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)] +getCAFs cafEnv decls = + [ (g_entry g, mkCAFLabel topLbl, cafs) + | CmmProc top_info topLbl _ g <- decls + , Just info <- [mapLookup (g_entry g) (info_tbls top_info)] + , let rep = cit_rep info + , isStaticRep rep && isThunkRep rep + , Just cafs <- [mapLookup (g_entry g) cafEnv] + ] + + +-- | Get the list of blocks that correspond to the entry points for +-- FUN_STATIC closures. These are the blocks for which if we have an +-- SRT we can merge it with the static closure. [FUN] +getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)] +getStaticFuns decls = + [ (g_entry g, lbl) + | CmmProc top_info _ _ g <- decls + , Just info <- [mapLookup (g_entry g) (info_tbls top_info)] + , Just (id, _) <- [cit_clo info] + , let rep = cit_rep info + , isStaticRep rep && isFunRep rep + , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id) + ] + + +-- | Maps labels from 'cafAnal' to the final CLabel that will appear +-- in the SRT. +-- - closures with singleton SRTs resolve to their single entry +-- - closures with larger SRTs map to the label for that SRT +-- - CAFs must not map to anything! +-- - if a labels maps to Nothing, we found that this label's SRT +-- is empty, so we don't need to refer to it from other SRTs. +type SRTMap = Map CAFLabel (Maybe SRTEntry) + + +-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the +-- module. Any 'Name's not in the set are CAFFY. +srtMapNonCAFs :: SRTMap -> NonCaffySet +srtMapNonCAFs srtMap = + NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap)) + where + get_name (CAFLabel l, Nothing) = hasHaskellName l + get_name (_l, Just _srt_entry) = Nothing + +-- | resolve a CAFLabel to its SRTEntry using the SRTMap +resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry +resolveCAF srtMap lbl@(CAFLabel l) = + srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret + where + ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap + +-- | Attach SRTs to all info tables in the CmmDecls, and add SRT +-- declarations to the ModuleSRTInfo. +-- +doSRTs + :: DynFlags + -> ModuleSRTInfo + -> [(CAFEnv, [CmmDecl])] + -> [(CAFSet, CmmDecl)] + -> IO (ModuleSRTInfo, [CmmDeclSRTs]) + +doSRTs dflags moduleSRTInfo procs data_ = do + us <- mkSplitUniqSupply 'u' + + -- Ignore the original grouping of decls, and combine all the + -- CAFEnvs into a single CAFEnv. + let static_data_env :: Map CLabel CAFSet + static_data_env = + Map.fromList $ + flip map data_ $ + \(set, decl) -> + case decl of + CmmProc{} -> + pprPanic "doSRTs" (text "Proc in static data list:" <+> ppr decl) + CmmData _ static -> + case static of + CmmStatics lbl _ _ _ -> (lbl, set) + CmmStaticsRaw lbl _ -> (lbl, set) + + static_data :: Set CLabel + static_data = Map.keysSet static_data_env + + (proc_envs, procss) = unzip procs + cafEnv = mapUnions proc_envs + decls = map snd data_ ++ concat procss + staticFuns = mapFromList (getStaticFuns decls) + + -- Put the decls in dependency order. Why? So that we can implement + -- [Inline] and [Filter]. If we need to refer to an SRT that has + -- a single entry, we use the entry itself, which means that we + -- don't need to generate the singleton SRT in the first place. But + -- to do this we need to process blocks before things that depend on + -- them. + let + sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)] + sccs = {-# SCC depAnalSRTs #-} depAnalSRTs cafEnv static_data_env decls + + cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)] + cafsWithSRTs = getCAFs cafEnv decls + + srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$ + text "procs:" <+> ppr procs $$ + text "static_data_env:" <+> ppr static_data_env $$ + text "sccs:" <+> ppr sccs $$ + text "cafsWithSRTs:" <+> ppr cafsWithSRTs) + + -- On each strongly-connected group of decls, construct the SRT + -- closures and the SRT fields for info tables. + let result :: + [ ( [CmmDeclSRTs] -- generated SRTs + , [(Label, CLabel)] -- SRT fields for info tables + , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references + ) ] + + (result, moduleSRTInfo') = + initUs_ us $ + flip runStateT moduleSRTInfo $ do + nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs + cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> + oneSRT dflags staticFuns [BlockLabel l] [cafLbl] + True{-is a CAF-} cafs static_data + return (nonCAFs ++ cAFs) + + (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result + srt_decls = concat srt_declss + + -- Next, update the info tables with the SRTs + let + srtFieldMap = mapFromList (concat pairs) + funSRTMap = mapFromList (concat funSRTs) + has_caf_refs' = or has_caf_refs + decls' = + concatMap (updInfoSRTs dflags srtFieldMap funSRTMap has_caf_refs') decls + + -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are + -- not analysed in oneSRT so we never add entries for them to the SRTMap. + let srtMap_w_raws = + foldl' (\(srtMap :: SRTMap) (_, decl) -> + case decl of + CmmData _ CmmStatics{} -> + -- already updated by oneSRT + srtMap + CmmData _ (CmmStaticsRaw lbl _) + | isIdLabel lbl && not (isTickyLabel lbl) -> + -- Raw data are not analysed by oneSRT and they can't + -- be CAFFY. + -- See Note [Ticky labels in SRT analysis] above for + -- why we exclude ticky labels here. + Map.insert (mkCAFLabel lbl) Nothing srtMap + | otherwise -> + -- Not an IdLabel, ignore + srtMap + CmmProc{} -> + pprPanic "doSRTs" (text "Found Proc in static data list:" <+> ppr decl)) + (moduleSRTMap moduleSRTInfo') data_ + + return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls') + + +-- | Build the SRT for a strongly-connected component of blocks +doSCC + :: DynFlags + -> LabelMap CLabel -- which blocks are static function entry points + -> Set CLabel -- static data + -> SCC (SomeLabel, CAFLabel, Set CAFLabel) + -> StateT ModuleSRTInfo UniqSM + ( [CmmDeclSRTs] -- generated SRTs + , [(Label, CLabel)] -- SRT fields for info tables + , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references + ) + +doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) = + oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data + +doSCC dflags staticFuns static_data (CyclicSCC nodes) = do + -- build a single SRT for the whole cycle, see Note [recursive SRTs] + let (lbls, caf_lbls, cafsets) = unzip3 nodes + cafs = Set.unions cafsets + oneSRT dflags staticFuns lbls caf_lbls False cafs static_data + + +{- Note [recursive SRTs] + +If the dependency analyser has found us a recursive group of +declarations, then we build a single SRT for the whole group, on the +grounds that everything in the group is reachable from everything +else, so we lose nothing by having a single SRT. + +However, there are a couple of wrinkles to be aware of. + +* The Set CAFLabel for this SRT will contain labels in the group +itself. The SRTMap will therefore not contain entries for these labels +yet, so we can't turn them into SRTEntries using resolveCAF. BUT we +can just remove recursive references from the Set CAFLabel before +generating the SRT - the SRT will still contain all the CAFLabels that +we need to refer to from this group's SRT. + +* That is, EXCEPT for static function closures. For the same reason +described in Note [Invalid optimisation: shortcutting], we cannot omit +references to static function closures. + - But, since we will merge the SRT with one of the static function + closures (see [FUN]), we can omit references to *that* static + function closure from the SRT. +-} + +-- | Build an SRT for a set of blocks +oneSRT + :: DynFlags + -> LabelMap CLabel -- which blocks are static function entry points + -> [SomeLabel] -- blocks in this set + -> [CAFLabel] -- labels for those blocks + -> Bool -- True <=> this SRT is for a CAF + -> Set CAFLabel -- SRT for this set + -> Set CLabel -- Static data labels in this group + -> StateT ModuleSRTInfo UniqSM + ( [CmmDeclSRTs] -- SRT objects we built + , [(Label, CLabel)] -- SRT fields for these blocks' itbls + , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references + ) + +oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do + topSRT <- get + + let + config = initConfig dflags + srtMap = moduleSRTMap topSRT + + blockids = getBlockLabels lbls + + -- Can we merge this SRT with a FUN_STATIC closure? + maybeFunClosure :: Maybe (CLabel, Label) + otherFunLabels :: [CLabel] + (maybeFunClosure, otherFunLabels) = + case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of + [] -> (Nothing, []) + ((l,b):xs) -> (Just (l,b), map fst xs) + + -- Remove recursive references from the SRT + nonRec :: Set CAFLabel + nonRec = cafs `Set.difference` Set.fromList caf_lbls + + -- Resolve references to their SRT entries + resolved :: [SRTEntry] + resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec) + + -- The set of all SRTEntries in SRTs that we refer to from here. + allBelow = + Set.unions [ lbls | caf <- resolved + , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ] + + -- Remove SRTEntries that are also in an SRT that we refer to. + -- Implements the [Filter] optimisation. + filtered0 = Set.fromList resolved `Set.difference` allBelow + + srtTraceM "oneSRT:" + (text "srtMap:" <+> ppr srtMap $$ + text "nonRec:" <+> ppr nonRec $$ + text "lbls:" <+> ppr lbls $$ + text "caf_lbls:" <+> ppr caf_lbls $$ + text "static_data:" <+> ppr static_data $$ + text "cafs:" <+> ppr cafs $$ + text "blockids:" <+> ppr blockids $$ + text "maybeFunClosure:" <+> ppr maybeFunClosure $$ + text "otherFunLabels:" <+> ppr otherFunLabels $$ + text "resolved:" <+> ppr resolved $$ + text "allBelow:" <+> ppr allBelow $$ + text "filtered0:" <+> ppr filtered0) + + let + isStaticFun = isJust maybeFunClosure + + -- For a label without a closure (e.g. a continuation), we must + -- update the SRTMap for the label to point to a closure. It's + -- important that we don't do this for static functions or CAFs, + -- see Note [Invalid optimisation: shortcutting]. + updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM () + updateSRTMap srtEntry = + srtTrace "updateSRTMap" + (ppr srtEntry <+> "isCAF:" <+> ppr isCAF <+> + "isStaticFun:" <+> ppr isStaticFun) $ + when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ + modify' $ \state -> + let !srt_map = + foldl' (\srt_map cafLbl@(CAFLabel clbl) -> + -- Only map static data to Nothing (== not CAFFY). For CAFFY + -- statics we refer to the static itself instead of a SRT. + if not (Set.member clbl static_data) || isNothing srtEntry then + Map.insert cafLbl srtEntry srt_map + else + srt_map) + (moduleSRTMap state) + caf_lbls + in + state{ moduleSRTMap = srt_map } + + this_mod = thisModule topSRT + + allStaticData = + all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls + + if Set.null filtered0 then do + srtTraceM "oneSRT: empty" (ppr caf_lbls) + updateSRTMap Nothing + return ([], [], [], False) + else do + -- We're going to build an SRT for this group, which should include function + -- references in the group. See Note [recursive SRTs]. + let allBelow_funs = + Set.fromList (map (SRTEntry . toClosureLbl) otherFunLabels) + let filtered = filtered0 `Set.union` allBelow_funs + srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$ + text "allBelow_funs:" <+> ppr allBelow_funs) + case Set.toList filtered of + [] -> pprPanic "oneSRT" empty -- unreachable + + -- [Inline] - when we have only one entry there is no need to + -- build an SRT object at all, instead we put the singleton SRT + -- entry in the info table. + [one@(SRTEntry lbl)] + | -- Info tables refer to SRTs by offset (as noted in the section + -- "Referring to an SRT from the info table" of Note [SRTs]). However, + -- when dynamic linking is used we cannot guarantee that the offset + -- between the SRT and the info table will fit in the offset field. + -- Consequently we build a singleton SRT in this case. + not (labelDynamic config this_mod lbl) + + -- MachO relocations can't express offsets between compilation units at + -- all, so we are always forced to build a singleton SRT in this case. + && (not (osMachOTarget $ platformOS $ ncgPlatform config) + || isLocalCLabel this_mod lbl) -> do + + -- If we have a static function closure, then it becomes the + -- SRT object, and everything else points to it. (the only way + -- we could have multiple labels here is if this is a + -- recursive group, see Note [recursive SRTs]) + case maybeFunClosure of + Just (staticFunLbl,staticFunBlock) -> + return ([], withLabels, [], True) + where + withLabels = + [ (b, if b == staticFunBlock then lbl else staticFunLbl) + | b <- blockids ] + Nothing -> do + srtTraceM "oneSRT: one" (text "caf_lbls:" <+> ppr caf_lbls $$ + text "one:" <+> ppr one) + updateSRTMap (Just one) + return ([], map (,lbl) blockids, [], True) + + cafList | allStaticData -> + return ([], [], [], not (null cafList)) + + cafList -> + -- Check whether an SRT with the same entries has been emitted already. + -- Implements the [Common] optimisation. + case Map.lookup filtered (dedupSRTs topSRT) of + Just srtEntry@(SRTEntry srtLbl) -> do + srtTraceM "oneSRT [Common]" (ppr caf_lbls <+> ppr srtLbl) + updateSRTMap (Just srtEntry) + return ([], map (,srtLbl) blockids, [], True) + Nothing -> do + -- No duplicates: we have to build a new SRT object + (decls, funSRTs, srtEntry) <- + case maybeFunClosure of + Just (fun,block) -> + return ( [], [(block, cafList)], SRTEntry fun ) + Nothing -> do + (decls, entry) <- lift $ buildSRTChain dflags cafList + return (decls, [], entry) + updateSRTMap (Just srtEntry) + let allBelowThis = Set.union allBelow filtered + newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT) + -- When all definition in this group are static data we don't + -- generate any SRTs. + newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) + modify' (\state -> state{ dedupSRTs = newDedupSRTs, + flatSRTs = newFlatSRTs }) + srtTraceM "oneSRT: new" (text "caf_lbls:" <+> ppr caf_lbls $$ + text "filtered:" <+> ppr filtered $$ + text "srtEntry:" <+> ppr srtEntry $$ + text "newDedupSRTs:" <+> ppr newDedupSRTs $$ + text "newFlatSRTs:" <+> ppr newFlatSRTs) + let SRTEntry lbl = srtEntry + return (decls, map (,lbl) blockids, funSRTs, True) + + +-- | build a static SRT object (or a chain of objects) from a list of +-- SRTEntries. +buildSRTChain + :: DynFlags + -> [SRTEntry] + -> UniqSM + ( [CmmDeclSRTs] -- The SRT object(s) + , SRTEntry -- label to use in the info table + ) +buildSRTChain _ [] = panic "buildSRT: empty" +buildSRTChain dflags cafSet = + case splitAt mAX_SRT_SIZE cafSet of + (these, []) -> do + (decl,lbl) <- buildSRT dflags these + return ([decl], lbl) + (these,those) -> do + (rest, rest_lbl) <- buildSRTChain dflags (head these : those) + (decl,lbl) <- buildSRT dflags (rest_lbl : tail these) + return (decl:rest, lbl) + where + mAX_SRT_SIZE = 16 + + +buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry) +buildSRT dflags refs = do + id <- getUniqueM + let + lbl = mkSRTLabel id + platform = targetPlatform dflags + srt_n_info = mkSRTInfoLabel (length refs) + fields = + mkStaticClosure dflags srt_n_info dontCareCCS + [ CmmLabel lbl | SRTEntry lbl <- refs ] + [] -- no padding + [mkIntCLit platform 0] -- link field + [] -- no saved info + return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) + +-- | Update info tables with references to their SRTs. Also generate +-- static closures, splicing in SRT fields as necessary. +updInfoSRTs + :: DynFlags + -> LabelMap CLabel -- SRT labels for each block + -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures + -> Bool -- Whether the CmmDecl's group has CAF references + -> CmmDecl + -> [CmmDeclSRTs] + +updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics)) + = [CmmData s (CmmStaticsRaw lbl statics)] + +updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload)) + = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))] + where + caf_info = if caffy then MayHaveCafRefs else NoCafRefs + field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload + +updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g) + | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] + | otherwise = [ proc ] + where + caf_info = if caffy then MayHaveCafRefs else NoCafRefs + proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g + newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info) + updInfoTbl l info_tbl + | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf + | otherwise = info_tbl { cit_srt = mapLookup l srt_env } + + -- Generate static closures [FUN]. Note that this also generates + -- static closures for thunks (CAFs), because it's easier to treat + -- them uniformly in the code generator. + maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs) + maybeStaticClosure + | Just info_tbl@CmmInfoTable{..} <- + mapLookup (g_entry g) (info_tbls top_info) + , Just (id, ccs) <- cit_clo + , isStaticRep cit_rep = + let + (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of + Nothing -> + -- if we don't add SRT entries to this closure, then we + -- want to set the srt field in its info table as usual + (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, []) + Just srtEntries -> srtTrace "maybeStaticFun" (ppr res) + (info_tbl { cit_rep = new_rep }, res) + where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] + fields = mkStaticClosureFields dflags info_tbl ccs caf_info srtEntries + new_rep = case cit_rep of + HeapRep sta ptrs nptrs ty -> + HeapRep sta (ptrs + length srtEntries) nptrs ty + _other -> panic "maybeStaticFun" + lbl = mkLocalClosureLabel (idName id) caf_info + in + Just (newInfo, mkDataLits (Section Data lbl) lbl fields) + | otherwise = Nothing + + +srtTrace :: String -> SDoc -> b -> b +-- srtTrace = pprTrace +srtTrace _ _ b = b + +srtTraceM :: Applicative f => String -> SDoc -> f () +srtTraceM str doc = srtTrace str doc (pure ()) diff --git a/GHC/Cmm/LayoutStack.hs b/GHC/Cmm/LayoutStack.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/LayoutStack.hs @@ -0,0 +1,1241 @@ +{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-} +module GHC.Cmm.LayoutStack ( + cmmLayoutStack, setInfoTableStackMap + ) where + +import GHC.Prelude hiding ((<*>)) + +import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation +import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation + +import GHC.Types.Basic +import GHC.Cmm +import GHC.Cmm.Info +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Utils +import GHC.Cmm.Graph +import GHC.Types.ForeignCall +import GHC.Cmm.Liveness +import GHC.Cmm.ProcPoint +import GHC.Runtime.Heap.Layout +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Types.Unique.Supply +import GHC.Data.Maybe +import GHC.Types.Unique.FM +import GHC.Utils.Misc + +import GHC.Platform +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Outputable hiding ( isEmpty ) +import qualified Data.Set as Set +import Control.Monad.Fix +import Data.Array as Array +import Data.Bits +import Data.List (nub) + +{- Note [Stack Layout] + +The job of this pass is to + + - replace references to abstract stack Areas with fixed offsets from Sp. + + - replace the CmmHighStackMark constant used in the stack check with + the maximum stack usage of the proc. + + - save any variables that are live across a call, and reload them as + necessary. + +Before stack allocation, local variables remain live across native +calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local +variables are clobbered by native calls. + +We want to do stack allocation so that as far as possible + - stack use is minimized, and + - unnecessary stack saves and loads are avoided. + +The algorithm we use is a variant of linear-scan register allocation, +where the stack is our register file. + +We proceed in two passes, see Note [Two pass approach] for why they are not easy +to merge into one. + +Pass 1: + + - First, we do a liveness analysis, which annotates every block with + the variables live on entry to the block. + + - We traverse blocks in reverse postorder DFS; that is, we visit at + least one predecessor of a block before the block itself. The + stack layout flowing from the predecessor of the block will + determine the stack layout on entry to the block. + + - We maintain a data structure + + Map Label StackMap + + which describes the contents of the stack and the stack pointer on + entry to each block that is a successor of a block that we have + visited. + + - For each block we visit: + + - Look up the StackMap for this block. + + - If this block is a proc point (or a call continuation, if we aren't + splitting proc points), we need to reload all the live variables from the + stack - but this is done in Pass 2, which calculates more precise liveness + information (see description of Pass 2). + + - Walk forwards through the instructions: + - At an assignment x = Sp[loc] + - Record the fact that Sp[loc] contains x, so that we won't + need to save x if it ever needs to be spilled. + - At an assignment x = E + - If x was previously on the stack, it isn't any more + - At the last node, if it is a call or a jump to a proc point + - Lay out the stack frame for the call (see setupStackFrame) + - emit instructions to save all the live variables + - Remember the StackMaps for all the successors + - emit an instruction to adjust Sp + - If the last node is a branch, then the current StackMap is the + StackMap for the successors. + + - Manifest Sp: replace references to stack areas in this block + with real Sp offsets. We cannot do this until we have laid out + the stack area for the successors above. + + In this phase we also eliminate redundant stores to the stack; + see elimStackStores. + + - There is one important gotcha: sometimes we'll encounter a control + transfer to a block that we've already processed (a join point), + and in that case we might need to rearrange the stack to match + what the block is expecting. (exactly the same as in linear-scan + register allocation, except here we have the luxury of an infinite + supply of temporary variables). + + - Finally, we update the magic CmmHighStackMark constant with the + stack usage of the function, and eliminate the whole stack check + if there was no stack use. (in fact this is done as part of the + main traversal, by feeding the high-water-mark output back in as + an input. I hate cyclic programming, but it's just too convenient + sometimes.) + + There are plenty of tricky details: update frames, proc points, return + addresses, foreign calls, and some ad-hoc optimisations that are + convenient to do here and effective in common cases. Comments in the + code below explain these. + +Pass 2: + +- Calculate live registers, but taking into account that nothing is live at the + entry to a proc point. + +- At each proc point and call continuation insert reloads of live registers from + the stack (they were saved by Pass 1). + + +Note [Two pass approach] + +The main reason for Pass 2 is being able to insert only the reloads that are +needed and the fact that the two passes need different liveness information. +Let's consider an example: + + ..... + \ / + D <- proc point + / \ + E F + \ / + G <- proc point + | + X + +Pass 1 needs liveness assuming that local variables are preserved across calls. +This is important because it needs to save any local registers to the stack +(e.g., if register a is used in block X, it must be saved before any native +call). +However, for Pass 2, where we want to reload registers from stack (in a proc +point), this is overly conservative and would lead us to generate reloads in D +for things used in X, even though we're going to generate reloads in G anyway +(since it's also a proc point). +So Pass 2 calculates liveness knowing that nothing is live at the entry to a +proc point. This means that in D we only need to reload things used in E or F. +This can be quite important, for an extreme example see testcase for #3294. + +Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1 +is a forward one. Furthermore, Pass 1 is creating code that uses local registers +(saving them before a call), which the liveness analysis for Pass 2 must see to +be correct. + +-} + + +-- All stack locations are expressed as positive byte offsets from the +-- "base", which is defined to be the address above the return address +-- on the stack on entry to this CmmProc. +-- +-- Lower addresses have higher StackLocs. +-- +type StackLoc = ByteOff + +{- + A StackMap describes the stack at any given point. At a continuation + it has a particular layout, like this: + + | | <- base + |-------------| + | ret0 | <- base + 8 + |-------------| + . upd frame . <- base + sm_ret_off + |-------------| + | | + . vars . + . (live/dead) . + | | <- base + sm_sp - sm_args + |-------------| + | ret1 | + . ret vals . <- base + sm_sp (<--- Sp points here) + |-------------| + +Why do we include the final return address (ret0) in our stack map? I +have absolutely no idea, but it seems to be done that way consistently +in the rest of the code generator, so I played along here. --SDM + +Note that we will be constructing an info table for the continuation +(ret1), which needs to describe the stack down to, but not including, +the update frame (or ret0, if there is no update frame). +-} + +data StackMap = StackMap + { sm_sp :: StackLoc + -- ^ the offset of Sp relative to the base on entry + -- to this block. + , sm_args :: ByteOff + -- ^ the number of bytes of arguments in the area for this block + -- Defn: the offset of young(L) relative to the base is given by + -- (sm_sp - sm_args) of the StackMap for block L. + , sm_ret_off :: ByteOff + -- ^ Number of words of stack that we do not describe with an info + -- table, because it contains an update frame. + , sm_regs :: UniqFM LocalReg (LocalReg,StackLoc) + -- ^ regs on the stack + } + +instance Outputable StackMap where + ppr StackMap{..} = + text "Sp = " <> int sm_sp $$ + text "sm_args = " <> int sm_args $$ + text "sm_ret_off = " <> int sm_ret_off $$ + text "sm_regs = " <> pprUFM sm_regs ppr + + +cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph + -> UniqSM (CmmGraph, LabelMap StackMap) +cmmLayoutStack dflags procpoints entry_args + graph@(CmmGraph { g_entry = entry }) + = do + -- We need liveness info. Dead assignments are removed later + -- by the sinking pass. + let liveness = cmmLocalLiveness dflags graph + blocks = revPostorder graph + + (final_stackmaps, _final_high_sp, new_blocks) <- + mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> + layout dflags procpoints liveness entry entry_args + rec_stackmaps rec_high_sp blocks + + blocks_with_reloads <- + insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks + new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads + return (ofBlockList entry new_blocks', final_stackmaps) + +-- ----------------------------------------------------------------------------- +-- Pass 1 +-- ----------------------------------------------------------------------------- + +layout :: DynFlags + -> LabelSet -- proc points + -> LabelMap CmmLocalLive -- liveness + -> BlockId -- entry + -> ByteOff -- stack args on entry + + -> LabelMap StackMap -- [final] stack maps + -> ByteOff -- [final] Sp high water mark + + -> [CmmBlock] -- [in] blocks + + -> UniqSM + ( LabelMap StackMap -- [out] stack maps + , ByteOff -- [out] Sp high water mark + , [CmmBlock] -- [out] new blocks + ) + +layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks + = go blocks init_stackmap entry_args [] + where + (updfr, cont_info) = collectContInfo blocks + + init_stackmap = mapSingleton entry StackMap{ sm_sp = entry_args + , sm_args = entry_args + , sm_ret_off = updfr + , sm_regs = emptyUFM + } + + go [] acc_stackmaps acc_hwm acc_blocks + = return (acc_stackmaps, acc_hwm, acc_blocks) + + go (b0 : bs) acc_stackmaps acc_hwm acc_blocks + = do + let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0 + + let stack0@StackMap { sm_sp = sp0 } + = mapFindWithDefault + (pprPanic "no stack map for" (ppr entry_lbl)) + entry_lbl acc_stackmaps + + -- (a) Update the stack map to include the effects of + -- assignments in this block + let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0 + + -- (b) Look at the last node and if we are making a call or + -- jumping to a proc point, we must save the live + -- variables, adjust Sp, and construct the StackMaps for + -- each of the successor blocks. See handleLastNode for + -- details. + (middle1, sp_off, last1, fixup_blocks, out) + <- handleLastNode dflags procpoints liveness cont_info + acc_stackmaps stack1 tscope middle0 last0 + + -- (c) Manifest Sp: run over the nodes in the block and replace + -- CmmStackSlot with CmmLoad from Sp with a concrete offset. + -- + -- our block: + -- middle0 -- the original middle nodes + -- middle1 -- live variable saves from handleLastNode + -- Sp = Sp + sp_off -- Sp adjustment goes here + -- last1 -- the last node + -- + let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1 + + let final_blocks = + manifestSp dflags final_stackmaps stack0 sp0 final_sp_high + entry0 middle_pre sp_off last1 fixup_blocks + + let acc_stackmaps' = mapUnion acc_stackmaps out + + -- If this block jumps to the GC, then we do not take its + -- stack usage into account for the high-water mark. + -- Otherwise, if the only stack usage is in the stack-check + -- failure block itself, we will do a redundant stack + -- check. The stack has a buffer designed to accommodate + -- the largest amount of stack needed for calling the GC. + -- + this_sp_hwm | isGcJump last0 = 0 + | otherwise = sp0 - sp_off + + hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out)) + + go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) + + +-- ----------------------------------------------------------------------------- + +-- Not foolproof, but GCFun is the culprit we most want to catch +isGcJump :: CmmNode O C -> Bool +isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) }) + = l == GCFun || l == GCEnter1 +isGcJump _something_else = False + +-- ----------------------------------------------------------------------------- + +-- This doesn't seem right somehow. We need to find out whether this +-- proc will push some update frame material at some point, so that we +-- can avoid using that area of the stack for spilling. Ideally we would +-- capture this information in the CmmProc (e.g. in CmmStackInfo; see #18232 +-- for details on one ill-fated attempt at this). +-- +-- So we'll just take the max of all the cml_ret_offs. This could be +-- unnecessarily pessimistic, but probably not in the code we +-- generate. + +collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff) +collectContInfo blocks + = (maximum ret_offs, mapFromList (catMaybes mb_argss)) + where + (mb_argss, ret_offs) = mapAndUnzip get_cont blocks + + get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff) + get_cont b = + case lastNode b of + CmmCall { cml_cont = Just l, .. } + -> (Just (l, cml_ret_args), cml_ret_off) + CmmForeignCall { .. } + -> (Just (succ, ret_args), ret_off) + _other -> (Nothing, 0) + + +-- ----------------------------------------------------------------------------- +-- Updating the StackMap from middle nodes + +-- Look for loads from stack slots, and update the StackMap. This is +-- purely for optimisation reasons, so that we can avoid saving a +-- variable back to a different stack slot if it is already on the +-- stack. +-- +-- This happens a lot: for example when function arguments are passed +-- on the stack and need to be immediately saved across a call, we +-- want to just leave them where they are on the stack. +-- +procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap +procMiddle stackmaps node sm + = case node of + CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _) + -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) } + where loc = getStackLoc area off stackmaps + CmmAssign (CmmLocal r) _other + -> sm { sm_regs = delFromUFM (sm_regs sm) r } + _other + -> sm + +getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc +getStackLoc Old n _ = n +getStackLoc (Young l) n stackmaps = + case mapLookup l stackmaps of + Nothing -> pprPanic "getStackLoc" (ppr l) + Just sm -> sm_sp sm - sm_args sm + n + + +-- ----------------------------------------------------------------------------- +-- Handling stack allocation for a last node + +-- We take a single last node and turn it into: +-- +-- C1 (some statements) +-- Sp = Sp + N +-- C2 (some more statements) +-- call f() -- the actual last node +-- +-- plus possibly some more blocks (we may have to add some fixup code +-- between the last node and the continuation). +-- +-- C1: is the code for saving the variables across this last node onto +-- the stack, if the continuation is a call or jumps to a proc point. +-- +-- C2: if the last node is a safe foreign call, we have to inject some +-- extra code that goes *after* the Sp adjustment. + +handleLastNode + :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff + -> LabelMap StackMap -> StackMap -> CmmTickScope + -> Block CmmNode O O + -> CmmNode O C + -> UniqSM + ( [CmmNode O O] -- nodes to go *before* the Sp adjustment + , ByteOff -- amount to adjust Sp + , CmmNode O C -- new last node + , [CmmBlock] -- new blocks + , LabelMap StackMap -- stackmaps for the continuations + ) + +handleLastNode dflags procpoints liveness cont_info stackmaps + stack0@StackMap { sm_sp = sp0 } tscp middle last + = case last of + -- At each return / tail call, + -- adjust Sp to point to the last argument pushed, which + -- is cml_args, after popping any other junk from the stack. + CmmCall{ cml_cont = Nothing, .. } -> do + let sp_off = sp0 - cml_args + return ([], sp_off, last, [], mapEmpty) + + -- At each CmmCall with a continuation: + CmmCall{ cml_cont = Just cont_lbl, .. } -> + return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off + + CmmForeignCall{ succ = cont_lbl, .. } -> do + return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off + -- one word of args: the return address + + CmmBranch {} -> handleBranches + CmmCondBranch {} -> handleBranches + CmmSwitch {} -> handleBranches + + where + platform = targetPlatform dflags + -- Calls and ForeignCalls are handled the same way: + lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff + -> ( [CmmNode O O] + , ByteOff + , CmmNode O C + , [CmmBlock] + , LabelMap StackMap + ) + lastCall lbl cml_args cml_ret_args cml_ret_off + = ( assignments + , spOffsetForCall sp0 cont_stack cml_args + , last + , [] -- no new blocks + , mapSingleton lbl cont_stack ) + where + (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off + + + prepareStack lbl cml_ret_args cml_ret_off + | Just cont_stack <- mapLookup lbl stackmaps + -- If we have already seen this continuation before, then + -- we just have to make the stack look the same: + = (fixupStack stack0 cont_stack, cont_stack) + -- Otherwise, we have to allocate the stack frame + | otherwise + = (save_assignments, new_cont_stack) + where + (new_cont_stack, save_assignments) + = setupStackFrame platform lbl liveness cml_ret_off cml_ret_args stack0 + + + -- For other last nodes (branches), if any of the targets is a + -- proc point, we have to set up the stack to match what the proc + -- point is expecting. + -- + handleBranches :: UniqSM ( [CmmNode O O] + , ByteOff + , CmmNode O C + , [CmmBlock] + , LabelMap StackMap ) + + handleBranches + -- Note [diamond proc point] + | Just l <- futureContinuation middle + , (nub $ filter (`setMember` procpoints) $ successors last) == [l] + = do + let cont_args = mapFindWithDefault 0 l cont_info + (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0) + out = mapFromList [ (l', cont_stack) + | l' <- successors last ] + return ( assigs + , spOffsetForCall sp0 cont_stack (platformWordSizeInBytes platform) + , last + , [] + , out) + + | otherwise = do + pps <- mapM handleBranch (successors last) + let lbl_map :: LabelMap Label + lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ] + fix_lbl l = mapFindWithDefault l l lbl_map + return ( [] + , 0 + , mapSuccessors fix_lbl last + , concat [ blk | (_,_,_,blk) <- pps ] + , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] ) + + -- For each successor of this block + handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock]) + handleBranch l + -- (a) if the successor already has a stackmap, we need to + -- shuffle the current stack to make it look the same. + -- We have to insert a new block to make this happen. + | Just stack2 <- mapLookup l stackmaps + = do + let assigs = fixupStack stack0 stack2 + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs + return (l, tmp_lbl, stack2, block) + + -- (b) if the successor is a proc point, save everything + -- on the stack. + | l `setMember` procpoints + = do + let cont_args = mapFindWithDefault 0 l cont_info + (stack2, assigs) = + setupStackFrame platform l liveness (sm_ret_off stack0) + cont_args stack0 + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs + return (l, tmp_lbl, stack2, block) + + -- (c) otherwise, the current StackMap is the StackMap for + -- the continuation. But we must remember to remove any + -- variables from the StackMap that are *not* live at + -- the destination, because this StackMap might be used + -- by fixupStack if this is a join point. + | otherwise = return (l, l, stack1, []) + where live = mapFindWithDefault (panic "handleBranch") l liveness + stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) } + is_live (r,_) = r `elemRegSet` live + + +makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap + -> CmmTickScope -> [CmmNode O O] + -> UniqSM (Label, [CmmBlock]) +makeFixupBlock dflags sp0 l stack tscope assigs + | null assigs && sp0 == sm_sp stack = return (l, []) + | otherwise = do + tmp_lbl <- newBlockId + let sp_off = sp0 - sm_sp stack + block = blockJoin (CmmEntry tmp_lbl tscope) + ( maybeAddSpAdj dflags sp0 sp_off + $ blockFromList assigs ) + (CmmBranch l) + return (tmp_lbl, [block]) + + +-- Sp is currently pointing to current_sp, +-- we want it to point to +-- (sm_sp cont_stack - sm_args cont_stack + args) +-- so the difference is +-- sp0 - (sm_sp cont_stack - sm_args cont_stack + args) +spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff +spOffsetForCall current_sp cont_stack args + = current_sp - (sm_sp cont_stack - sm_args cont_stack + args) + + +-- | create a sequence of assignments to establish the new StackMap, +-- given the old StackMap. +fixupStack :: StackMap -> StackMap -> [CmmNode O O] +fixupStack old_stack new_stack = concatMap move new_locs + where + old_map = sm_regs old_stack + new_locs = stackSlotRegs new_stack + + move (r,n) + | Just (_,m) <- lookupUFM old_map r, n == m = [] + | otherwise = [CmmStore (CmmStackSlot Old n) + (CmmReg (CmmLocal r))] + + + +setupStackFrame + :: Platform + -> BlockId -- label of continuation + -> LabelMap CmmLocalLive -- liveness + -> ByteOff -- updfr + -> ByteOff -- bytes of return values on stack + -> StackMap -- current StackMap + -> (StackMap, [CmmNode O O]) + +setupStackFrame platform lbl liveness updfr_off ret_args stack0 + = (cont_stack, assignments) + where + -- get the set of LocalRegs live in the continuation + live = mapFindWithDefault Set.empty lbl liveness + + -- the stack from the base to updfr_off is off-limits. + -- our new stack frame contains: + -- * saved live variables + -- * the return address [young(C) + 8] + -- * the args for the call, + -- which are replaced by the return values at the return + -- point. + + -- everything up to updfr_off is off-limits + -- stack1 contains updfr_off, plus everything we need to save + (stack1, assignments) = allocate platform updfr_off live stack0 + + -- And the Sp at the continuation is: + -- sm_sp stack1 + ret_args + cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args + , sm_args = ret_args + , sm_ret_off = updfr_off + } + + +-- ----------------------------------------------------------------------------- +-- Note [diamond proc point] +-- +-- This special case looks for the pattern we get from a typical +-- tagged case expression: +-- +-- Sp[young(L1)] = L1 +-- if (R1 & 7) != 0 goto L1 else goto L2 +-- L2: +-- call [R1] returns to L1 +-- L1: live: {y} +-- x = R1 +-- +-- If we let the generic case handle this, we get +-- +-- Sp[-16] = L1 +-- if (R1 & 7) != 0 goto L1a else goto L2 +-- L2: +-- Sp[-8] = y +-- Sp = Sp - 16 +-- call [R1] returns to L1 +-- L1a: +-- Sp[-8] = y +-- Sp = Sp - 16 +-- goto L1 +-- L1: +-- x = R1 +-- +-- The code for saving the live vars is duplicated in each branch, and +-- furthermore there is an extra jump in the fast path (assuming L1 is +-- a proc point, which it probably is if there is a heap check). +-- +-- So to fix this we want to set up the stack frame before the +-- conditional jump. How do we know when to do this, and when it is +-- safe? The basic idea is, when we see the assignment +-- +-- Sp[young(L)] = L +-- +-- we know that +-- * we are definitely heading for L +-- * there can be no more reads from another stack area, because young(L) +-- overlaps with it. +-- +-- We don't necessarily know that everything live at L is live now +-- (some might be assigned between here and the jump to L). So we +-- simplify and only do the optimisation when we see +-- +-- (1) a block containing an assignment of a return address L +-- (2) ending in a branch where one (and only) continuation goes to L, +-- and no other continuations go to proc points. +-- +-- then we allocate the stack frame for L at the end of the block, +-- before the branch. +-- +-- We could generalise (2), but that would make it a bit more +-- complicated to handle, and this currently catches the common case. + +futureContinuation :: Block CmmNode O O -> Maybe BlockId +futureContinuation middle = foldBlockNodesB f middle Nothing + where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId + f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _ + = Just l + f _ r = r + +-- ----------------------------------------------------------------------------- +-- Saving live registers + +-- | Given a set of live registers and a StackMap, save all the registers +-- on the stack and return the new StackMap and the assignments to do +-- the saving. +-- +allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap + -> (StackMap, [CmmNode O O]) +allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0 + , sm_regs = regs0 } + = + -- we only have to save regs that are not already in a slot + let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live) + regs1 = filterUFM (\(r,_) -> elemRegSet r live) regs0 + in + + -- make a map of the stack + let stack = reverse $ Array.elems $ + accumArray (\_ x -> x) Empty (1, toWords platform (max sp0 ret_off)) $ + ret_words ++ live_words + where ret_words = + [ (x, Occupied) + | x <- [ 1 .. toWords platform ret_off] ] + live_words = + [ (toWords platform x, Occupied) + | (r,off) <- nonDetEltsUFM regs1, + -- See Note [Unique Determinism and code generation] + let w = localRegBytes platform r, + x <- [ off, off - platformWordSizeInBytes platform .. off - w + 1] ] + in + + -- Pass over the stack: find slots to save all the new live variables, + -- choosing the oldest slots first (hence a foldr). + let + save slot ([], stack, n, assigs, regs) -- no more regs to save + = ([], slot:stack, plusW platform n 1, assigs, regs) + save slot (to_save, stack, n, assigs, regs) + = case slot of + Occupied -> (to_save, Occupied:stack, plusW platform n 1, assigs, regs) + Empty + | Just (stack', r, to_save') <- + select_save to_save (slot:stack) + -> let assig = CmmStore (CmmStackSlot Old n') + (CmmReg (CmmLocal r)) + n' = plusW platform n 1 + in + (to_save', stack', n', assig : assigs, (r,(r,n')):regs) + + | otherwise + -> (to_save, slot:stack, plusW platform n 1, assigs, regs) + + -- we should do better here: right now we'll fit the smallest first, + -- but it would make more sense to fit the biggest first. + select_save :: [LocalReg] -> [StackSlot] + -> Maybe ([StackSlot], LocalReg, [LocalReg]) + select_save regs stack = go regs [] + where go [] _no_fit = Nothing + go (r:rs) no_fit + | Just rest <- dropEmpty words stack + = Just (replicate words Occupied ++ rest, r, rs++no_fit) + | otherwise + = go rs (r:no_fit) + where words = localRegWords platform r + + -- fill in empty slots as much as possible + (still_to_save, save_stack, n, save_assigs, save_regs) + = foldr save (to_save, [], 0, [], []) stack + + -- push any remaining live vars on the stack + (push_sp, push_assigs, push_regs) + = foldr push (n, [], []) still_to_save + where + push r (n, assigs, regs) + = (n', assig : assigs, (r,(r,n')) : regs) + where + n' = n + localRegBytes platform r + assig = CmmStore (CmmStackSlot Old n') + (CmmReg (CmmLocal r)) + + trim_sp + | not (null push_regs) = push_sp + | otherwise + = plusW platform n (- length (takeWhile isEmpty save_stack)) + + final_regs = regs1 `addListToUFM` push_regs + `addListToUFM` save_regs + + in + -- XXX should be an assert + if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else + + if (trim_sp .&. (platformWordSizeInBytes platform - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else + + ( stackmap { sm_regs = final_regs , sm_sp = trim_sp } + , push_assigs ++ save_assigs ) + + +-- ----------------------------------------------------------------------------- +-- Manifesting Sp + +-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp. The +-- block looks like this: +-- +-- middle_pre -- the middle nodes +-- Sp = Sp + sp_off -- Sp adjustment goes here +-- last -- the last node +-- +-- And we have some extra blocks too (that don't contain Sp adjustments) +-- +-- The adjustment for middle_pre will be different from that for +-- middle_post, because the Sp adjustment intervenes. +-- +manifestSp + :: DynFlags + -> LabelMap StackMap -- StackMaps for other blocks + -> StackMap -- StackMap for this block + -> ByteOff -- Sp on entry to the block + -> ByteOff -- SpHigh + -> CmmNode C O -- first node + -> [CmmNode O O] -- middle + -> ByteOff -- sp_off + -> CmmNode O C -- last node + -> [CmmBlock] -- new blocks + -> [CmmBlock] -- final blocks with Sp manifest + +manifestSp dflags stackmaps stack0 sp0 sp_high + first middle_pre sp_off last fixup_blocks + = final_block : fixup_blocks' + where + area_off = getAreaOff stackmaps + platform = targetPlatform dflags + + adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x + adj_pre_sp = mapExpDeep (areaToSp platform sp0 sp_high area_off) + adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off) + + final_middle = maybeAddSpAdj dflags sp0 sp_off + . blockFromList + . map adj_pre_sp + . elimStackStores stack0 stackmaps area_off + $ middle_pre + final_last = optStackCheck (adj_post_sp last) + + final_block = blockJoin first final_middle final_last + + fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks + +getAreaOff :: LabelMap StackMap -> (Area -> StackLoc) +getAreaOff _ Old = 0 +getAreaOff stackmaps (Young l) = + case mapLookup l stackmaps of + Just sm -> sm_sp sm - sm_args sm + Nothing -> pprPanic "getAreaOff" (ppr l) + + +maybeAddSpAdj + :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O +maybeAddSpAdj dflags sp0 sp_off block = + add_initial_unwind $ add_adj_unwind $ adj block + where + platform = targetPlatform dflags + adj block + | sp_off /= 0 + = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off) + | otherwise = block + -- Add unwind pseudo-instruction at the beginning of each block to + -- document Sp level for debugging + add_initial_unwind block + | debugLevel dflags > 0 + = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block + | otherwise + = block + where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform) + + -- Add unwind pseudo-instruction right after the Sp adjustment + -- if there is one. + add_adj_unwind block + | debugLevel dflags > 0 + , sp_off /= 0 + = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] + | otherwise + = block + where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off) + +{- Note [SP old/young offsets] + +Sp(L) is the Sp offset on entry to block L relative to the base of the +OLD area. + +SpArgs(L) is the size of the young area for L, i.e. the number of +arguments. + + - in block L, each reference to [old + N] turns into + [Sp + Sp(L) - N] + + - in block L, each reference to [young(L') + N] turns into + [Sp + Sp(L) - Sp(L') + SpArgs(L') - N] + + - be careful with the last node of each block: Sp has already been adjusted + to be Sp + Sp(L) - Sp(L') +-} + +areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr + +areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n) + = cmmOffset platform spExpr (sp_old - area_off area - n) + -- Replace (CmmStackSlot area n) with an offset from Sp + +areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark) + = mkIntExpr platform sp_hwm + -- Replace CmmHighStackMark with the number of bytes of stack used, + -- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap + +areaToSp platform _ _ _ (CmmMachOp (MO_U_Lt _) args) + | falseStackCheck args + = zeroExpr platform +areaToSp platform _ _ _ (CmmMachOp (MO_U_Ge _) args) + | falseStackCheck args + = mkIntExpr platform 1 + -- Replace a stack-overflow test that cannot fail with a no-op + -- See Note [Always false stack check] + +areaToSp _ _ _ _ other = other + +-- | Determine whether a stack check cannot fail. +falseStackCheck :: [CmmExpr] -> Bool +falseStackCheck [ CmmMachOp (MO_Sub _) + [ CmmRegOff (CmmGlobal Sp) x_off + , CmmLit (CmmInt y_lit _)] + , CmmReg (CmmGlobal SpLim)] + = fromIntegral x_off >= y_lit +falseStackCheck _ = False + +-- Note [Always false stack check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We can optimise stack checks of the form +-- +-- if ((Sp + x) - y < SpLim) then .. else .. +-- +-- where are non-negative integer byte offsets. Since we know that +-- SpLim <= Sp (remember the stack grows downwards), this test must +-- yield False if (x >= y), so we can rewrite the comparison to False. +-- A subsequent sinking pass will later drop the dead code. +-- Optimising this away depends on knowing that SpLim <= Sp, so it is +-- really the job of the stack layout algorithm, hence we do it now. +-- +-- The control flow optimiser may negate a conditional to increase +-- the likelihood of a fallthrough if the branch is not taken. But +-- not every conditional is inverted as the control flow optimiser +-- places some requirements on the predecessors of both branch targets. +-- So we better look for the inverted comparison too. + +optStackCheck :: CmmNode O C -> CmmNode O C +optStackCheck n = -- Note [Always false stack check] + case n of + CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false + CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true + other -> other + + +-- ----------------------------------------------------------------------------- + +-- | Eliminate stores of the form +-- +-- Sp[area+n] = r +-- +-- when we know that r is already in the same slot as Sp[area+n]. We +-- could do this in a later optimisation pass, but that would involve +-- a separate analysis and we already have the information to hand +-- here. It helps clean up some extra stack stores in common cases. +-- +-- Note that we may have to modify the StackMap as we walk through the +-- code using procMiddle, since an assignment to a variable in the +-- StackMap will invalidate its mapping there. +-- +elimStackStores :: StackMap + -> LabelMap StackMap + -> (Area -> ByteOff) + -> [CmmNode O O] + -> [CmmNode O O] +elimStackStores stackmap stackmaps area_off nodes + = go stackmap nodes + where + go _stackmap [] = [] + go stackmap (n:ns) + = case n of + CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) + | Just (_,off) <- lookupUFM (sm_regs stackmap) r + , area_off area + m == off + -> go stackmap ns + _otherwise + -> n : go (procMiddle stackmaps n stackmap) ns + + +-- ----------------------------------------------------------------------------- +-- Update info tables to include stack liveness + + +setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl +setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g) + = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g + where + fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = + info_tbl { cit_rep = StackRep (get_liveness lbl) } + fix_info _ other = other + + get_liveness :: BlockId -> Liveness + get_liveness lbl + = case mapLookup lbl stackmaps of + Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls) + Just sm -> stackMapToLiveness platform sm + +setInfoTableStackMap _ _ d = d + + +stackMapToLiveness :: Platform -> StackMap -> Liveness +stackMapToLiveness platform StackMap{..} = + reverse $ Array.elems $ + accumArray (\_ x -> x) True (toWords platform sm_ret_off + 1, + toWords platform (sm_sp - sm_args)) live_words + where + live_words = [ (toWords platform off, False) + | (r,off) <- nonDetEltsUFM sm_regs + , isGcPtrType (localRegType r) ] + -- See Note [Unique Determinism and code generation] + +-- ----------------------------------------------------------------------------- +-- Pass 2 +-- ----------------------------------------------------------------------------- + +insertReloadsAsNeeded + :: DynFlags + -> ProcPointSet + -> LabelMap StackMap + -> BlockId + -> [CmmBlock] + -> UniqSM [CmmBlock] +insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do + toBlockList . fst <$> + rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty + where + rewriteCC :: RewriteFun CmmLocalLive + rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do + let entry_label = entryLabel e_node + platform = targetPlatform dflags + stackmap = case mapLookup entry_label final_stackmaps of + Just sm -> sm + Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap" + + -- Merge the liveness from successor blocks and analyse the last + -- node. + joined = gen_kill dflags x_node $! + joinOutFacts liveLattice x_node fact_base0 + -- What is live at the start of middle0. + live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined + + -- If this is a procpoint we need to add the reloads, but only if + -- they're actually live. Furthermore, nothing is live at the entry + -- to a proc point. + (middle1, live_with_reloads) + | entry_label `setMember` procpoints + = let reloads = insertReloads platform stackmap live_at_middle0 + in (foldr blockCons middle0 reloads, emptyRegSet) + | otherwise + = (middle0, live_at_middle0) + + -- Final liveness for this block. + !fact_base2 = mapSingleton entry_label live_with_reloads + + return (BlockCC e_node middle1 x_node, fact_base2) + +insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O] +insertReloads platform stackmap live = + [ CmmAssign (CmmLocal reg) + -- This cmmOffset basically corresponds to manifesting + -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] + (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off)) + (localRegType reg)) + | (reg, reg_off) <- stackSlotRegs stackmap + , reg `elemRegSet` live + ] + where + sp_off = sm_sp stackmap + +-- ----------------------------------------------------------------------------- +-- Lowering safe foreign calls + +{- +Note [Lower safe foreign calls] + +We start with + + Sp[young(L1)] = L1 + ,----------------------- + | r1 = foo(x,y,z) returns to L1 + '----------------------- + L1: + R1 = r1 -- copyIn, inserted by mkSafeCall + ... + +the stack layout algorithm will arrange to save and reload everything +live across the call. Our job now is to expand the call so we get + + Sp[young(L1)] = L1 + ,----------------------- + | SAVE_THREAD_STATE() + | token = suspendThread(BaseReg, interruptible) + | r = foo(x,y,z) + | BaseReg = resumeThread(token) + | LOAD_THREAD_STATE() + | R1 = r -- copyOut + | jump Sp[0] + '----------------------- + L1: + r = R1 -- copyIn, inserted by mkSafeCall + ... + +Note the copyOut, which saves the results in the places that L1 is +expecting them (see Note [safe foreign call convention]). Note also +that safe foreign call is replace by an unsafe one in the Cmm graph. +-} + +lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock +lowerSafeForeignCall dflags block + | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block + = do + let platform = targetPlatform dflags + -- Both 'id' and 'new_base' are KindNonPtr because they're + -- RTS-only objects and are not subject to garbage collection + id <- newTemp (bWord platform) + new_base <- newTemp (cmmRegType platform baseReg) + let (caller_save, caller_load) = callerSaveVolatileRegs dflags + save_state_code <- saveThreadState dflags + load_state_code <- loadThreadState dflags + let suspend = save_state_code <*> + caller_save <*> + mkMiddle (callSuspendThread platform id intrbl) + midCall = mkUnsafeCall tgt res args + resume = mkMiddle (callResumeThread new_base id) <*> + -- Assign the result to BaseReg: we + -- might now have a different Capability! + mkAssign baseReg (CmmReg (CmmLocal new_base)) <*> + caller_load <*> + load_state_code + + (_, regs, copyout) = + copyOutOflow dflags NativeReturn Jump (Young succ) + (map (CmmReg . CmmLocal) res) + ret_off [] + + -- NB. after resumeThread returns, the top-of-stack probably contains + -- the stack frame for succ, but it might not: if the current thread + -- received an exception during the call, then the stack might be + -- different. Hence we continue by jumping to the top stack frame, + -- not by jumping to succ. + jump = CmmCall { cml_target = entryCode platform $ + CmmLoad spExpr (bWord platform) + , cml_cont = Just succ + , cml_args_regs = regs + , cml_args = widthInBytes (wordWidth platform) + , cml_ret_args = ret_args + , cml_ret_off = ret_off } + + graph' <- lgraphOfAGraph ( suspend <*> + midCall <*> + resume <*> + copyout <*> + mkLast jump, tscp) + + case toBlockList graph' of + [one] -> let (_, middle', last) = blockSplit one + in return (blockJoin entry (middle `blockAppend` middle') last) + _ -> panic "lowerSafeForeignCall0" + + -- Block doesn't end in a safe foreign call: + | otherwise = return block + + +foreignLbl :: FastString -> CmmExpr +foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction)) + +callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O +callSuspendThread platform id intrbl = + CmmUnsafeForeignCall + (ForeignTarget (foreignLbl (fsLit "suspendThread")) + (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn)) + [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)] + +callResumeThread :: LocalReg -> LocalReg -> CmmNode O O +callResumeThread new_base id = + CmmUnsafeForeignCall + (ForeignTarget (foreignLbl (fsLit "resumeThread")) + (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn)) + [new_base] [CmmReg (CmmLocal id)] + +-- ----------------------------------------------------------------------------- + +plusW :: Platform -> ByteOff -> WordOff -> ByteOff +plusW platform b w = b + w * platformWordSizeInBytes platform + +data StackSlot = Occupied | Empty + -- Occupied: a return address or part of an update frame + +instance Outputable StackSlot where + ppr Occupied = text "XXX" + ppr Empty = text "---" + +dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] +dropEmpty 0 ss = Just ss +dropEmpty n (Empty : ss) = dropEmpty (n-1) ss +dropEmpty _ _ = Nothing + +isEmpty :: StackSlot -> Bool +isEmpty Empty = True +isEmpty _ = False + +localRegBytes :: Platform -> LocalReg -> ByteOff +localRegBytes platform r + = roundUpToWords platform (widthInBytes (typeWidth (localRegType r))) + +localRegWords :: Platform -> LocalReg -> WordOff +localRegWords platform = toWords platform . localRegBytes platform + +toWords :: Platform -> ByteOff -> WordOff +toWords platform x = x `quot` platformWordSizeInBytes platform + + +stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)] +stackSlotRegs sm = nonDetEltsUFM (sm_regs sm) + -- See Note [Unique Determinism and code generation] diff --git a/GHC/Cmm/Lexer.x b/GHC/Cmm/Lexer.x new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Lexer.x @@ -0,0 +1,368 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2004-2006 +-- +-- Lexer for concrete Cmm. We try to stay close to the C-- spec, but there +-- are a few minor differences: +-- +-- * extra keywords for our macros, and float32/float64 types +-- * global registers (Sp,Hp, etc.) +-- +----------------------------------------------------------------------------- + +{ +module GHC.Cmm.Lexer ( + CmmToken(..), cmmlex, + ) where + +import GHC.Prelude + +import GHC.Cmm.Expr + +import GHC.Parser.Lexer +import GHC.Cmm.Monad +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Parser.CharClass +import GHC.Utils.Misc +--import TRACE + +import Data.Word +import Data.Char +} + +$whitechar = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space +$white_no_nl = $whitechar # \n + +$ascdigit = 0-9 +$unidigit = \x01 -- Trick Alex into handling Unicode. See alexGetChar. +$digit = [$ascdigit $unidigit] +$octit = 0-7 +$hexit = [$digit A-F a-f] + +$unilarge = \x03 -- Trick Alex into handling Unicode. See alexGetChar. +$asclarge = [A-Z \xc0-\xd6 \xd8-\xde] +$large = [$asclarge $unilarge] + +$unismall = \x04 -- Trick Alex into handling Unicode. See alexGetChar. +$ascsmall = [a-z \xdf-\xf6 \xf8-\xff] +$small = [$ascsmall $unismall \_] + +$namebegin = [$large $small \. \$ \@] +$namechar = [$namebegin $digit] + +@decimal = $digit+ +@octal = $octit+ +@hexadecimal = $hexit+ +@exponent = [eE] [\-\+]? @decimal + +@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent + +@escape = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3}) +@strchar = ($printable # [\"\\]) | @escape + +cmm :- + +$white_no_nl+ ; +^\# pragma .* \n ; -- Apple GCC 3.3 CPP generates pragmas in its output + +^\# (line)? { begin line_prag } + +-- single-line line pragmas, of the form +-- # "" \n + $digit+ { setLine line_prag1 } + \" [^\"]* \" { setFile line_prag2 } + .* { pop } + +<0> { + \n ; + + [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } + + ".." { kw CmmT_DotDot } + "::" { kw CmmT_DoubleColon } + ">>" { kw CmmT_Shr } + "<<" { kw CmmT_Shl } + ">=" { kw CmmT_Ge } + "<=" { kw CmmT_Le } + "==" { kw CmmT_Eq } + "!=" { kw CmmT_Ne } + "&&" { kw CmmT_BoolAnd } + "||" { kw CmmT_BoolOr } + + "True" { kw CmmT_True } + "False" { kw CmmT_False } + "likely" { kw CmmT_likely} + + P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } + R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } + F@decimal { global_regN FloatReg } + D@decimal { global_regN DoubleReg } + L@decimal { global_regN LongReg } + Sp { global_reg Sp } + SpLim { global_reg SpLim } + Hp { global_reg Hp } + HpLim { global_reg HpLim } + CCCS { global_reg CCCS } + CurrentTSO { global_reg CurrentTSO } + CurrentNursery { global_reg CurrentNursery } + HpAlloc { global_reg HpAlloc } + BaseReg { global_reg BaseReg } + MachSp { global_reg MachSp } + UnwindReturnReg { global_reg UnwindReturnReg } + + $namebegin $namechar* { name } + + 0 @octal { tok_octal } + @decimal { tok_decimal } + 0[xX] @hexadecimal { tok_hexadecimal } + @floating_point { strtoken tok_float } + + \" @strchar* \" { strtoken tok_string } +} + +{ +data CmmToken + = CmmT_SpecChar Char + | CmmT_DotDot + | CmmT_DoubleColon + | CmmT_Shr + | CmmT_Shl + | CmmT_Ge + | CmmT_Le + | CmmT_Eq + | CmmT_Ne + | CmmT_BoolAnd + | CmmT_BoolOr + | CmmT_CLOSURE + | CmmT_INFO_TABLE + | CmmT_INFO_TABLE_RET + | CmmT_INFO_TABLE_FUN + | CmmT_INFO_TABLE_CONSTR + | CmmT_INFO_TABLE_SELECTOR + | CmmT_else + | CmmT_export + | CmmT_section + | CmmT_goto + | CmmT_if + | CmmT_call + | CmmT_jump + | CmmT_foreign + | CmmT_never + | CmmT_prim + | CmmT_reserve + | CmmT_return + | CmmT_returns + | CmmT_import + | CmmT_switch + | CmmT_case + | CmmT_default + | CmmT_push + | CmmT_unwind + | CmmT_bits8 + | CmmT_bits16 + | CmmT_bits32 + | CmmT_bits64 + | CmmT_bits128 + | CmmT_bits256 + | CmmT_bits512 + | CmmT_float32 + | CmmT_float64 + | CmmT_gcptr + | CmmT_GlobalReg GlobalReg + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer + | CmmT_Float Rational + | CmmT_EOF + | CmmT_False + | CmmT_True + | CmmT_likely + deriving (Show) + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken) + +begin :: Int -> Action +begin code _span _str _len = do liftP (pushLexState code); lexToken + +pop :: Action +pop _span _buf _len = liftP popLexState >> lexToken + +special_char :: Action +special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) + +kw :: CmmToken -> Action +kw tok span _buf _len = return (L span tok) + +global_regN :: (Int -> GlobalReg) -> Action +global_regN con span buf len + = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) + where buf' = stepOn buf + n = parseUnsignedInteger buf' (len-1) 10 octDecDigit + +global_reg :: GlobalReg -> Action +global_reg r span _buf _len = return (L span (CmmT_GlobalReg r)) + +strtoken :: (String -> CmmToken) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +name :: Action +name span buf len = + case lookupUFM reservedWordsFM fs of + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) + where + fs = lexemeToFastString buf len + +reservedWordsFM = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), + ( "call", CmmT_call ), + ( "jump", CmmT_jump ), + ( "foreign", CmmT_foreign ), + ( "never", CmmT_never ), + ( "prim", CmmT_prim ), + ( "reserve", CmmT_reserve ), + ( "return", CmmT_return ), + ( "returns", CmmT_returns ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), + ( "default", CmmT_default ), + ( "push", CmmT_push ), + ( "unwind", CmmT_unwind ), + ( "bits8", CmmT_bits8 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "bits128", CmmT_bits128 ), + ( "bits256", CmmT_bits256 ), + ( "bits512", CmmT_bits512 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ), +-- New forms + ( "b8", CmmT_bits8 ), + ( "b16", CmmT_bits16 ), + ( "b32", CmmT_bits32 ), + ( "b64", CmmT_bits64 ), + ( "b128", CmmT_bits128 ), + ( "b256", CmmT_bits256 ), + ( "b512", CmmT_bits512 ), + ( "f32", CmmT_float32 ), + ( "f64", CmmT_float64 ), + ( "gcptr", CmmT_gcptr ), + ( "likely", CmmT_likely), + ( "True", CmmT_True ), + ( "False", CmmT_False ) + ] + +tok_decimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) + +tok_octal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) + +tok_hexadecimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) + +tok_float str = CmmT_Float $! readRational str + +tok_string str = CmmT_String (read str) + -- urk, not quite right, but it'll do for now + +-- ----------------------------------------------------------------------------- +-- Line pragmas + +setLine :: Int -> Action +setLine code (PsSpan span _) buf len = do + let line = parseUnsignedInteger buf len 10 octDecDigit + liftP $ do + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line + -- trace ("setLine " ++ show line) $ do + popLexState >> pushLexState code + lexToken + +setFile :: Int -> Action +setFile code (PsSpan span _) buf len = do + let file = lexemeToFastString (stepOn buf) (len-2) + liftP $ do + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + popLexState >> pushLexState code + lexToken + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +cmmlex :: (Located CmmToken -> PD a) -> PD a +cmmlex cont = do + (L span tok) <- lexToken + --trace ("token: " ++ show tok) $ do + cont (L (mkSrcSpanPs span) tok) + +lexToken :: PD (PsLocated CmmToken) +lexToken = do + inp@(loc1,buf) <- getInput + sc <- liftP getLexState + case alexScan inp sc of + AlexEOF -> do let span = mkPsSpan loc1 loc1 + liftP (setLastToken span 0) + return (L span CmmT_EOF) + AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(end,_buf2) len t -> do + setInput inp2 + let span = mkPsSpan loc1 end + span `seq` liftP (setLastToken span len) + t span buf len + +-- ----------------------------------------------------------------------------- +-- Monad stuff + +-- Stuff that Alex needs to know about our input type: +type AlexInput = (PsLoc,StringBuffer) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,s) = prevChar s '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (loc,s) + | atEnd s = Nothing + | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) + where c = currentChar s + b = fromIntegral $ ord $ c + loc' = advancePsLoc loc c + s' = stepOn s + +getInput :: PD AlexInput +getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b) + +setInput :: AlexInput -> PD () +setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } () +} diff --git a/GHC/Cmm/Lint.hs b/GHC/Cmm/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Lint.hs @@ -0,0 +1,295 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2011 +-- +-- CmmLint: checking the correctness of Cmm statements and expressions +-- +----------------------------------------------------------------------------- +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +module GHC.Cmm.Lint ( + cmmLint, cmmLintGraph + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Regs (callerSaves) +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Liveness +import GHC.Cmm.Switch (switchTargetsToList) +import GHC.Cmm.Ppr () -- For Outputable instances +import GHC.Utils.Outputable +import GHC.Driver.Session + +import Control.Monad (ap, unless) + +-- Things to check: +-- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there) +-- - check for branches to blocks that don't exist +-- - check types + +-- ----------------------------------------------------------------------------- +-- Exported entry points: + +cmmLint :: (Outputable d, Outputable h) + => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc +cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops + +cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc +cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g + +runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint dflags l p = + case unCL (l p) dflags of + Left err -> Just (vcat [text "Cmm lint error:", + nest 2 err, + text "Program was:", + nest 2 (ppr p)]) + Right _ -> Nothing + +lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint () +lintCmmDecl dflags (CmmProc _ lbl _ g) + = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g +lintCmmDecl _ (CmmData {}) + = return () + + +lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint () +lintCmmGraph dflags g = + cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks + -- cmmLiveness throws an error if there are registers + -- live on entry to the graph (i.e. undefined + -- variables) + where + blocks = toBlockList g + labels = setFromList (map entryLabel blocks) + + +lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint () +lintCmmBlock labels block + = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do + let (_, middle, last) = blockSplit block + mapM_ lintCmmMiddle (blockToList middle) + lintCmmLast labels last + +-- ----------------------------------------------------------------------------- +-- lintCmmExpr + +-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking +-- byte/word mismatches. + +lintCmmExpr :: CmmExpr -> CmmLint CmmType +lintCmmExpr (CmmLoad expr rep) = do + _ <- lintCmmExpr expr + -- Disabled, if we have the inlining phase before the lint phase, + -- we can have funny offsets due to pointer tagging. -- EZY + -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $ + -- cmmCheckWordAddress expr + return rep +lintCmmExpr expr@(CmmMachOp op args) = do + platform <- getPlatform + tys <- mapM lintCmmExpr args + if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op + then cmmCheckMachOp op args tys + else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op) +lintCmmExpr (CmmRegOff reg offset) + = do platform <- getPlatform + let rep = typeWidth (cmmRegType platform reg) + lintCmmExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) +lintCmmExpr expr = + do platform <- getPlatform + return (cmmExprType platform expr) + +-- Check for some common byte/word mismatches (eg. Sp + 1) +cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType +cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys + = cmmCheckMachOp op [reg, lit] tys +cmmCheckMachOp op _ tys + = do platform <- getPlatform + return (machOpResultType platform op tys) + +{- +isOffsetOp :: MachOp -> Bool +isOffsetOp (MO_Add _) = True +isOffsetOp (MO_Sub _) = True +isOffsetOp _ = False + +-- This expression should be an address from which a word can be loaded: +-- check for funny-looking sub-word offsets. +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0 + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0 + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress _ + = return () + +-- No warnings for unaligned arithmetic with the node register, +-- which is used to extract fields from tagged constructor closures. +notNodeReg :: CmmExpr -> Bool +notNodeReg (CmmReg reg) | reg == nodeReg = False +notNodeReg _ = True +-} + +lintCmmMiddle :: CmmNode O O -> CmmLint () +lintCmmMiddle node = case node of + CmmComment _ -> return () + CmmTick _ -> return () + CmmUnwind{} -> return () + + CmmAssign reg expr -> do + platform <- getPlatform + erep <- lintCmmExpr expr + let reg_ty = cmmRegType platform reg + if (erep `cmmEqType_ignoring_ptrhood` reg_ty) + then return () + else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty + + CmmStore l r -> do + _ <- lintCmmExpr l + _ <- lintCmmExpr r + return () + + CmmUnsafeForeignCall target _formals actuals -> do + lintTarget target + let lintArg expr = do + -- Arguments can't mention caller-saved + -- registers. See Note [Register parameter passing]. + mayNotMentionCallerSavedRegs (text "foreign call argument") expr + lintCmmExpr expr + + mapM_ lintArg actuals + + +lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint () +lintCmmLast labels node = case node of + CmmBranch id -> checkTarget id + + CmmCondBranch e t f _ -> do + platform <- getPlatform + mapM_ checkTarget [t,f] + _ <- lintCmmExpr e + checkCond platform e + + CmmSwitch e ids -> do + platform <- getPlatform + mapM_ checkTarget $ switchTargetsToList ids + erep <- lintCmmExpr e + if (erep `cmmEqType_ignoring_ptrhood` bWord platform) + then return () + else cmmLintErr (text "switch scrutinee is not a word: " <> + ppr e <> text " :: " <> ppr erep) + + CmmCall { cml_target = target, cml_cont = cont } -> do + _ <- lintCmmExpr target + maybe (return ()) checkTarget cont + + CmmForeignCall tgt _ args succ _ _ _ -> do + lintTarget tgt + let lintArg expr = do + -- Arguments can't mention caller-saved + -- registers. See Note [Register + -- parameter passing]. + -- N.B. This won't catch local registers + -- which the NCG's register allocator later + -- places in caller-saved registers. + mayNotMentionCallerSavedRegs (text "foreign call argument") expr + lintCmmExpr expr + mapM_ lintArg args + checkTarget succ + where + checkTarget id + | setMember id labels = return () + | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) + +lintTarget :: ForeignTarget -> CmmLint () +lintTarget (ForeignTarget e _) = do + mayNotMentionCallerSavedRegs (text "foreign target") e + _ <- lintCmmExpr e + return () +lintTarget (PrimTarget {}) = return () + +-- | As noted in Note [Register parameter passing], the arguments and +-- 'ForeignTarget' of a foreign call mustn't mention +-- caller-saved registers. +mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a) + => SDoc -> a -> CmmLint () +mayNotMentionCallerSavedRegs what thing = do + dflags <- getDynFlags + let badRegs = filter (callerSaves (targetPlatform dflags)) + $ foldRegsUsed dflags (flip (:)) [] thing + unless (null badRegs) + $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing) + +checkCond :: Platform -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values +checkCond _ expr + = cmmLintErr (hang (text "expression is not a conditional:") 2 + (ppr expr)) + +-- ----------------------------------------------------------------------------- +-- CmmLint monad + +-- just a basic error monad: + +newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } + deriving (Functor) + +instance Applicative CmmLint where + pure a = CmmLint (\_ -> Right a) + (<*>) = ap + +instance Monad CmmLint where + CmmLint m >>= k = CmmLint $ \dflags -> + case m dflags of + Left e -> Left e + Right a -> unCL (k a) dflags + +instance HasDynFlags CmmLint where + getDynFlags = CmmLint (\dflags -> Right dflags) + +getPlatform :: CmmLint Platform +getPlatform = targetPlatform <$> getDynFlags + +cmmLintErr :: SDoc -> CmmLint a +cmmLintErr msg = CmmLint (\_ -> Left msg) + +addLintInfo :: SDoc -> CmmLint a -> CmmLint a +addLintInfo info thing = CmmLint $ \dflags -> + case unCL thing dflags of + Left err -> Left (hang info 2 err) + Right a -> Right a + +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep opExpectsRep + = cmmLintErr (text "in MachOp application: " $$ + nest 2 (ppr expr) $$ + (text "op is expecting: " <+> ppr opExpectsRep) $$ + (text "arguments provide: " <+> ppr argsRep)) + +cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a +cmmLintAssignErr stmt e_ty r_ty + = cmmLintErr (text "in assignment: " $$ + nest 2 (vcat [ppr stmt, + text "Reg ty:" <+> ppr r_ty, + text "Rhs ty:" <+> ppr e_ty])) + + +{- +cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a +cmmLintDubiousWordOffset expr + = cmmLintErr (text "offset is not a multiple of words: " $$ + nest 2 (ppr expr)) +-} + diff --git a/GHC/Cmm/Liveness.hs b/GHC/Cmm/Liveness.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Liveness.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Cmm.Liveness + ( CmmLocalLive + , cmmLocalLiveness + , cmmGlobalLiveness + , liveLattice + , gen_kill + ) +where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Ppr.Expr () -- For Outputable instances +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Label + +import GHC.Data.Maybe +import GHC.Utils.Outputable + +----------------------------------------------------------------------------- +-- Calculating what variables are live on entry to a basic block +----------------------------------------------------------------------------- + +-- | The variables live on entry to a block +type CmmLive r = RegSet r +type CmmLocalLive = CmmLive LocalReg + +-- | The dataflow lattice +liveLattice :: Ord r => DataflowLattice (CmmLive r) +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-} +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-} +liveLattice = DataflowLattice emptyRegSet add + where + add (OldFact old) (NewFact new) = + let !join = plusRegSet old new + in changedIf (sizeRegSet join > sizeRegSet old) join + +-- | A mapping from block labels to the variables live on entry +type BlockEntryLiveness r = LabelMap (CmmLive r) + +----------------------------------------------------------------------------- +-- | Calculated liveness info for a CmmGraph +----------------------------------------------------------------------------- + +cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg +cmmLocalLiveness dflags graph = + check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty + where + entry = g_entry graph + check facts = + noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts + +cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg +cmmGlobalLiveness dflags graph = + analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty + +-- | On entry to the procedure, there had better not be any LocalReg's live-in. +noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a +noLiveOnEntry bid in_fact x = + if nullRegSet in_fact then x + else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) + +gen_kill + :: (DefinerOfRegs r n, UserOfRegs r n) + => DynFlags -> n -> CmmLive r -> CmmLive r +gen_kill dflags node set = + let !afterKill = foldRegsDefd dflags deleteFromRegSet set node + in foldRegsUsed dflags extendRegSet afterKill node +{-# INLINE gen_kill #-} + +xferLive + :: forall r. + ( UserOfRegs r (CmmNode O O) + , DefinerOfRegs r (CmmNode O O) + , UserOfRegs r (CmmNode O C) + , DefinerOfRegs r (CmmNode O C) + ) + => DynFlags -> TransferFun (CmmLive r) +xferLive dflags (BlockCC eNode middle xNode) fBase = + let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase + !result = foldNodesBwdOO (gen_kill dflags) middle joined + in mapSingleton (entryLabel eNode) result +{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-} +{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-} diff --git a/GHC/Cmm/MachOp.hs b/GHC/Cmm/MachOp.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/MachOp.hs @@ -0,0 +1,672 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Cmm.MachOp + ( MachOp(..) + , pprMachOp, isCommutableMachOp, isAssociativeMachOp + , isComparisonMachOp, maybeIntComparison, machOpResultType + , machOpArgReps, maybeInvertComparison, isFloatComparison + + -- MachOp builders + , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot + , mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord + , mo_u_32ToWord, mo_s_32ToWord + , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + + -- CallishMachOp + , CallishMachOp(..), callishMachOpHints + , pprCallishMachOp + , machOpMemcpyishAlign + + -- Atomic read-modify-write + , AtomicMachOp(..) + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.Type +import GHC.Utils.Outputable + +----------------------------------------------------------------------------- +-- MachOp +----------------------------------------------------------------------------- + +{- | +Machine-level primops; ones which we can reasonably delegate to the +native code generators to handle. + +Most operations are parameterised by the 'Width' that they operate on. +Some operations have separate signed and unsigned versions, and float +and integer versions. + +Note that there are variety of places in the native code generator where we +assume that the code produced for a MachOp does not introduce new blocks. +-} + +data MachOp + -- Integer operations (insensitive to signed/unsigned) + = MO_Add Width + | MO_Sub Width + | MO_Eq Width + | MO_Ne Width + | MO_Mul Width -- low word of multiply + + -- Signed multiply/divide + | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows + | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) + | MO_S_Rem Width -- signed % (same semantics as IntRemOp) + | MO_S_Neg Width -- unary - + + -- Unsigned multiply/divide + | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows + | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) + | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) + + -- Signed comparisons + | MO_S_Ge Width + | MO_S_Le Width + | MO_S_Gt Width + | MO_S_Lt Width + + -- Unsigned comparisons + | MO_U_Ge Width + | MO_U_Le Width + | MO_U_Gt Width + | MO_U_Lt Width + + -- Floating point arithmetic + | MO_F_Add Width + | MO_F_Sub Width + | MO_F_Neg Width -- unary - + | MO_F_Mul Width + | MO_F_Quot Width + + -- Floating point comparison + | MO_F_Eq Width + | MO_F_Ne Width + | MO_F_Ge Width + | MO_F_Le Width + | MO_F_Gt Width + | MO_F_Lt Width + + -- Bitwise operations. Not all of these may be supported + -- at all sizes, and only integral Widths are valid. + | MO_And Width + | MO_Or Width + | MO_Xor Width + | MO_Not Width + | MO_Shl Width + | MO_U_Shr Width -- unsigned shift right + | MO_S_Shr Width -- signed shift right + + -- Conversions. Some of these will be NOPs. + -- Floating-point conversions use the signed variant. + | MO_SF_Conv Width Width -- Signed int -> Float + | MO_FS_Conv Width Width -- Float -> Signed int + | MO_SS_Conv Width Width -- Signed int -> Signed int + | MO_UU_Conv Width Width -- unsigned int -> unsigned int + | MO_XX_Conv Width Width -- int -> int; puts no requirements on the + -- contents of upper bits when extending; + -- narrowing is simply truncation; the only + -- expectation is that we can recover the + -- original value by applying the opposite + -- MO_XX_Conv, e.g., + -- MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x) + -- is equivalent to just x. + | MO_FF_Conv Width Width -- Float -> Float + + -- Vector element insertion and extraction operations + | MO_V_Insert Length Width -- Insert scalar into vector + | MO_V_Extract Length Width -- Extract scalar from vector + + -- Integer vector operations + | MO_V_Add Length Width + | MO_V_Sub Length Width + | MO_V_Mul Length Width + + -- Signed vector multiply/divide + | MO_VS_Quot Length Width + | MO_VS_Rem Length Width + | MO_VS_Neg Length Width + + -- Unsigned vector multiply/divide + | MO_VU_Quot Length Width + | MO_VU_Rem Length Width + + -- Floating point vector element insertion and extraction operations + | MO_VF_Insert Length Width -- Insert scalar into vector + | MO_VF_Extract Length Width -- Extract scalar from vector + + -- Floating point vector operations + | MO_VF_Add Length Width + | MO_VF_Sub Length Width + | MO_VF_Neg Length Width -- unary negation + | MO_VF_Mul Length Width + | MO_VF_Quot Length Width + + -- Alignment check (for -falignment-sanitisation) + | MO_AlignmentCheck Int Width + deriving (Eq, Show) + +pprMachOp :: MachOp -> SDoc +pprMachOp mo = text (show mo) + + + +-- ----------------------------------------------------------------------------- +-- Some common MachReps + +-- A 'wordRep' is a machine word on the target architecture +-- Specifically, it is the size of an Int#, Word#, Addr# +-- and the unit of allocation on the stack and the heap +-- Any pointer is also guaranteed to be a wordRep. + +mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord + , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + :: Platform -> MachOp + +mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_32To8, mo_32To16 + :: MachOp + +mo_wordAdd platform = MO_Add (wordWidth platform) +mo_wordSub platform = MO_Sub (wordWidth platform) +mo_wordEq platform = MO_Eq (wordWidth platform) +mo_wordNe platform = MO_Ne (wordWidth platform) +mo_wordMul platform = MO_Mul (wordWidth platform) +mo_wordSQuot platform = MO_S_Quot (wordWidth platform) +mo_wordSRem platform = MO_S_Rem (wordWidth platform) +mo_wordSNeg platform = MO_S_Neg (wordWidth platform) +mo_wordUQuot platform = MO_U_Quot (wordWidth platform) +mo_wordURem platform = MO_U_Rem (wordWidth platform) + +mo_wordSGe platform = MO_S_Ge (wordWidth platform) +mo_wordSLe platform = MO_S_Le (wordWidth platform) +mo_wordSGt platform = MO_S_Gt (wordWidth platform) +mo_wordSLt platform = MO_S_Lt (wordWidth platform) + +mo_wordUGe platform = MO_U_Ge (wordWidth platform) +mo_wordULe platform = MO_U_Le (wordWidth platform) +mo_wordUGt platform = MO_U_Gt (wordWidth platform) +mo_wordULt platform = MO_U_Lt (wordWidth platform) + +mo_wordAnd platform = MO_And (wordWidth platform) +mo_wordOr platform = MO_Or (wordWidth platform) +mo_wordXor platform = MO_Xor (wordWidth platform) +mo_wordNot platform = MO_Not (wordWidth platform) +mo_wordShl platform = MO_Shl (wordWidth platform) +mo_wordSShr platform = MO_S_Shr (wordWidth platform) +mo_wordUShr platform = MO_U_Shr (wordWidth platform) + +mo_u_8To32 = MO_UU_Conv W8 W32 +mo_s_8To32 = MO_SS_Conv W8 W32 +mo_u_16To32 = MO_UU_Conv W16 W32 +mo_s_16To32 = MO_SS_Conv W16 W32 + +mo_u_8ToWord platform = MO_UU_Conv W8 (wordWidth platform) +mo_s_8ToWord platform = MO_SS_Conv W8 (wordWidth platform) +mo_u_16ToWord platform = MO_UU_Conv W16 (wordWidth platform) +mo_s_16ToWord platform = MO_SS_Conv W16 (wordWidth platform) +mo_s_32ToWord platform = MO_SS_Conv W32 (wordWidth platform) +mo_u_32ToWord platform = MO_UU_Conv W32 (wordWidth platform) + +mo_WordTo8 platform = MO_UU_Conv (wordWidth platform) W8 +mo_WordTo16 platform = MO_UU_Conv (wordWidth platform) W16 +mo_WordTo32 platform = MO_UU_Conv (wordWidth platform) W32 +mo_WordTo64 platform = MO_UU_Conv (wordWidth platform) W64 + +mo_32To8 = MO_UU_Conv W32 W8 +mo_32To16 = MO_UU_Conv W32 W16 + + +-- ---------------------------------------------------------------------------- +-- isCommutableMachOp + +{- | +Returns 'True' if the MachOp has commutable arguments. This is used +in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isCommutableMachOp :: MachOp -> Bool +isCommutableMachOp mop = + case mop of + MO_Add _ -> True + MO_Eq _ -> True + MO_Ne _ -> True + MO_Mul _ -> True + MO_S_MulMayOflo _ -> True + MO_U_MulMayOflo _ -> True + MO_And _ -> True + MO_Or _ -> True + MO_Xor _ -> True + MO_F_Add _ -> True + MO_F_Mul _ -> True + _other -> False + +-- ---------------------------------------------------------------------------- +-- isAssociativeMachOp + +{- | +Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@) +This is used in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isAssociativeMachOp :: MachOp -> Bool +isAssociativeMachOp mop = + case mop of + MO_Add {} -> True -- NB: does not include + MO_Mul {} -> True -- floatint point! + MO_And {} -> True + MO_Or {} -> True + MO_Xor {} -> True + _other -> False + + +-- ---------------------------------------------------------------------------- +-- isComparisonMachOp + +{- | +Returns 'True' if the MachOp is a comparison. + +If in doubt, return False. This generates worse code on the +native routes, but is otherwise harmless. +-} +isComparisonMachOp :: MachOp -> Bool +isComparisonMachOp mop = + case mop of + MO_Eq _ -> True + MO_Ne _ -> True + MO_S_Ge _ -> True + MO_S_Le _ -> True + MO_S_Gt _ -> True + MO_S_Lt _ -> True + MO_U_Ge _ -> True + MO_U_Le _ -> True + MO_U_Gt _ -> True + MO_U_Lt _ -> True + MO_F_Eq {} -> True + MO_F_Ne {} -> True + MO_F_Ge {} -> True + MO_F_Le {} -> True + MO_F_Gt {} -> True + MO_F_Lt {} -> True + _other -> False + +{- | +Returns @Just w@ if the operation is an integer comparison with width +@w@, or @Nothing@ otherwise. +-} +maybeIntComparison :: MachOp -> Maybe Width +maybeIntComparison mop = + case mop of + MO_Eq w -> Just w + MO_Ne w -> Just w + MO_S_Ge w -> Just w + MO_S_Le w -> Just w + MO_S_Gt w -> Just w + MO_S_Lt w -> Just w + MO_U_Ge w -> Just w + MO_U_Le w -> Just w + MO_U_Gt w -> Just w + MO_U_Lt w -> Just w + _ -> Nothing + +isFloatComparison :: MachOp -> Bool +isFloatComparison mop = + case mop of + MO_F_Eq {} -> True + MO_F_Ne {} -> True + MO_F_Ge {} -> True + MO_F_Le {} -> True + MO_F_Gt {} -> True + MO_F_Lt {} -> True + _other -> False + +-- ----------------------------------------------------------------------------- +-- Inverting conditions + +-- Sometimes it's useful to be able to invert the sense of a +-- condition. Not all conditional tests are invertible: in +-- particular, floating point conditionals cannot be inverted, because +-- there exist floating-point values which return False for both senses +-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). + +maybeInvertComparison :: MachOp -> Maybe MachOp +maybeInvertComparison op + = case op of -- None of these Just cases include floating point + MO_Eq r -> Just (MO_Ne r) + MO_Ne r -> Just (MO_Eq r) + MO_U_Lt r -> Just (MO_U_Ge r) + MO_U_Gt r -> Just (MO_U_Le r) + MO_U_Le r -> Just (MO_U_Gt r) + MO_U_Ge r -> Just (MO_U_Lt r) + MO_S_Lt r -> Just (MO_S_Ge r) + MO_S_Gt r -> Just (MO_S_Le r) + MO_S_Le r -> Just (MO_S_Gt r) + MO_S_Ge r -> Just (MO_S_Lt r) + _other -> Nothing + +-- ---------------------------------------------------------------------------- +-- machOpResultType + +{- | +Returns the MachRep of the result of a MachOp. +-} +machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType +machOpResultType platform mop tys = + case mop of + MO_Add {} -> ty1 -- Preserve GC-ptr-hood + MO_Sub {} -> ty1 -- of first arg + MO_Mul r -> cmmBits r + MO_S_MulMayOflo r -> cmmBits r + MO_S_Quot r -> cmmBits r + MO_S_Rem r -> cmmBits r + MO_S_Neg r -> cmmBits r + MO_U_MulMayOflo r -> cmmBits r + MO_U_Quot r -> cmmBits r + MO_U_Rem r -> cmmBits r + + MO_Eq {} -> comparisonResultRep platform + MO_Ne {} -> comparisonResultRep platform + MO_S_Ge {} -> comparisonResultRep platform + MO_S_Le {} -> comparisonResultRep platform + MO_S_Gt {} -> comparisonResultRep platform + MO_S_Lt {} -> comparisonResultRep platform + + MO_U_Ge {} -> comparisonResultRep platform + MO_U_Le {} -> comparisonResultRep platform + MO_U_Gt {} -> comparisonResultRep platform + MO_U_Lt {} -> comparisonResultRep platform + + MO_F_Add r -> cmmFloat r + MO_F_Sub r -> cmmFloat r + MO_F_Mul r -> cmmFloat r + MO_F_Quot r -> cmmFloat r + MO_F_Neg r -> cmmFloat r + MO_F_Eq {} -> comparisonResultRep platform + MO_F_Ne {} -> comparisonResultRep platform + MO_F_Ge {} -> comparisonResultRep platform + MO_F_Le {} -> comparisonResultRep platform + MO_F_Gt {} -> comparisonResultRep platform + MO_F_Lt {} -> comparisonResultRep platform + + MO_And {} -> ty1 -- Used for pointer masking + MO_Or {} -> ty1 + MO_Xor {} -> ty1 + MO_Not r -> cmmBits r + MO_Shl r -> cmmBits r + MO_U_Shr r -> cmmBits r + MO_S_Shr r -> cmmBits r + + MO_SS_Conv _ to -> cmmBits to + MO_UU_Conv _ to -> cmmBits to + MO_XX_Conv _ to -> cmmBits to + MO_FS_Conv _ to -> cmmBits to + MO_SF_Conv _ to -> cmmFloat to + MO_FF_Conv _ to -> cmmFloat to + + MO_V_Insert l w -> cmmVec l (cmmBits w) + MO_V_Extract _ w -> cmmBits w + + MO_V_Add l w -> cmmVec l (cmmBits w) + MO_V_Sub l w -> cmmVec l (cmmBits w) + MO_V_Mul l w -> cmmVec l (cmmBits w) + + MO_VS_Quot l w -> cmmVec l (cmmBits w) + MO_VS_Rem l w -> cmmVec l (cmmBits w) + MO_VS_Neg l w -> cmmVec l (cmmBits w) + + MO_VU_Quot l w -> cmmVec l (cmmBits w) + MO_VU_Rem l w -> cmmVec l (cmmBits w) + + MO_VF_Insert l w -> cmmVec l (cmmFloat w) + MO_VF_Extract _ w -> cmmFloat w + + MO_VF_Add l w -> cmmVec l (cmmFloat w) + MO_VF_Sub l w -> cmmVec l (cmmFloat w) + MO_VF_Mul l w -> cmmVec l (cmmFloat w) + MO_VF_Quot l w -> cmmVec l (cmmFloat w) + MO_VF_Neg l w -> cmmVec l (cmmFloat w) + + MO_AlignmentCheck _ _ -> ty1 + where + (ty1:_) = tys + +comparisonResultRep :: Platform -> CmmType +comparisonResultRep = bWord -- is it? + + +-- ----------------------------------------------------------------------------- +-- machOpArgReps + +-- | This function is used for debugging only: we can check whether an +-- application of a MachOp is "type-correct" by checking that the MachReps of +-- its arguments are the same as the MachOp expects. This is used when +-- linting a CmmExpr. + +machOpArgReps :: Platform -> MachOp -> [Width] +machOpArgReps platform op = + case op of + MO_Add r -> [r,r] + MO_Sub r -> [r,r] + MO_Eq r -> [r,r] + MO_Ne r -> [r,r] + MO_Mul r -> [r,r] + MO_S_MulMayOflo r -> [r,r] + MO_S_Quot r -> [r,r] + MO_S_Rem r -> [r,r] + MO_S_Neg r -> [r] + MO_U_MulMayOflo r -> [r,r] + MO_U_Quot r -> [r,r] + MO_U_Rem r -> [r,r] + + MO_S_Ge r -> [r,r] + MO_S_Le r -> [r,r] + MO_S_Gt r -> [r,r] + MO_S_Lt r -> [r,r] + + MO_U_Ge r -> [r,r] + MO_U_Le r -> [r,r] + MO_U_Gt r -> [r,r] + MO_U_Lt r -> [r,r] + + MO_F_Add r -> [r,r] + MO_F_Sub r -> [r,r] + MO_F_Mul r -> [r,r] + MO_F_Quot r -> [r,r] + MO_F_Neg r -> [r] + MO_F_Eq r -> [r,r] + MO_F_Ne r -> [r,r] + MO_F_Ge r -> [r,r] + MO_F_Le r -> [r,r] + MO_F_Gt r -> [r,r] + MO_F_Lt r -> [r,r] + + MO_And r -> [r,r] + MO_Or r -> [r,r] + MO_Xor r -> [r,r] + MO_Not r -> [r] + MO_Shl r -> [r, wordWidth platform] + MO_U_Shr r -> [r, wordWidth platform] + MO_S_Shr r -> [r, wordWidth platform] + + MO_SS_Conv from _ -> [from] + MO_UU_Conv from _ -> [from] + MO_XX_Conv from _ -> [from] + MO_SF_Conv from _ -> [from] + MO_FS_Conv from _ -> [from] + MO_FF_Conv from _ -> [from] + + MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform] + MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth platform] + + MO_V_Add _ r -> [r,r] + MO_V_Sub _ r -> [r,r] + MO_V_Mul _ r -> [r,r] + + MO_VS_Quot _ r -> [r,r] + MO_VS_Rem _ r -> [r,r] + MO_VS_Neg _ r -> [r] + + MO_VU_Quot _ r -> [r,r] + MO_VU_Rem _ r -> [r,r] + + MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform] + MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth platform] + + MO_VF_Add _ r -> [r,r] + MO_VF_Sub _ r -> [r,r] + MO_VF_Mul _ r -> [r,r] + MO_VF_Quot _ r -> [r,r] + MO_VF_Neg _ r -> [r] + + MO_AlignmentCheck _ r -> [r] + +----------------------------------------------------------------------------- +-- CallishMachOp +----------------------------------------------------------------------------- + +-- CallishMachOps tend to be implemented by foreign calls in some backends, +-- so we separate them out. In Cmm, these can only occur in a +-- statement position, in contrast to an ordinary MachOp which can occur +-- anywhere in an expression. +data CallishMachOp + = MO_F64_Pwr + | MO_F64_Sin + | MO_F64_Cos + | MO_F64_Tan + | MO_F64_Sinh + | MO_F64_Cosh + | MO_F64_Tanh + | MO_F64_Asin + | MO_F64_Acos + | MO_F64_Atan + | MO_F64_Asinh + | MO_F64_Acosh + | MO_F64_Atanh + | MO_F64_Log + | MO_F64_Log1P + | MO_F64_Exp + | MO_F64_ExpM1 + | MO_F64_Fabs + | MO_F64_Sqrt + | MO_F32_Pwr + | MO_F32_Sin + | MO_F32_Cos + | MO_F32_Tan + | MO_F32_Sinh + | MO_F32_Cosh + | MO_F32_Tanh + | MO_F32_Asin + | MO_F32_Acos + | MO_F32_Atan + | MO_F32_Asinh + | MO_F32_Acosh + | MO_F32_Atanh + | MO_F32_Log + | MO_F32_Log1P + | MO_F32_Exp + | MO_F32_ExpM1 + | MO_F32_Fabs + | MO_F32_Sqrt + + | MO_UF_Conv Width + + | MO_S_Mul2 Width + | MO_S_QuotRem Width + | MO_U_QuotRem Width + | MO_U_QuotRem2 Width + | MO_Add2 Width + | MO_AddWordC Width + | MO_SubWordC Width + | MO_AddIntC Width + | MO_SubIntC Width + | MO_U_Mul2 Width + + | MO_ReadBarrier + | MO_WriteBarrier + | MO_Touch -- Keep variables live (when using interior pointers) + + -- Prefetch + | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not + -- program behavior. + -- the Int can be 0-3. Needs to be known at compile time + -- to interact with code generation correctly. + -- TODO: add support for prefetch WRITES, + -- currently only exposes prefetch reads, which + -- would the majority of use cases in ghc anyways + + + -- These three MachOps are parameterised by the known alignment + -- of the destination and source (for memcpy/memmove) pointers. + -- This information may be used for optimisation in backends. + | MO_Memcpy Int + | MO_Memset Int + | MO_Memmove Int + | MO_Memcmp Int + + | MO_PopCnt Width + | MO_Pdep Width + | MO_Pext Width + | MO_Clz Width + | MO_Ctz Width + + | MO_BSwap Width + | MO_BRev Width + + -- Atomic read-modify-write. + | MO_AtomicRMW Width AtomicMachOp + | MO_AtomicRead Width + | MO_AtomicWrite Width + | MO_Cmpxchg Width + -- Should be an AtomicRMW variant eventually. + -- Sequential consistent. + | MO_Xchg Width + deriving (Eq, Show) + +-- | The operation to perform atomically. +data AtomicMachOp = + AMO_Add + | AMO_Sub + | AMO_And + | AMO_Nand + | AMO_Or + | AMO_Xor + deriving (Eq, Show) + +pprCallishMachOp :: CallishMachOp -> SDoc +pprCallishMachOp mo = text (show mo) + +callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint]) +callishMachOpHints op = case op of + MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint]) + MO_Memset _ -> ([], [AddrHint,NoHint,NoHint]) + MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint]) + MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint]) + _ -> ([],[]) + -- empty lists indicate NoHint + +-- | The alignment of a 'memcpy'-ish operation. +machOpMemcpyishAlign :: CallishMachOp -> Maybe Int +machOpMemcpyishAlign op = case op of + MO_Memcpy align -> Just align + MO_Memset align -> Just align + MO_Memmove align -> Just align + MO_Memcmp align -> Just align + _ -> Nothing diff --git a/GHC/Cmm/Monad.hs b/GHC/Cmm/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Monad.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- A Parser monad with access to the 'DynFlags'. +-- +-- The 'P' monad only has access to the subset of 'DynFlags' +-- required for parsing Haskell. + +-- The parser for C-- requires access to a lot more of the 'DynFlags', +-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance. +----------------------------------------------------------------------------- +module GHC.Cmm.Monad ( + PD(..) + , liftP + , failMsgPD + ) where + +import GHC.Prelude + +import Control.Monad + +import GHC.Driver.Session +import GHC.Parser.Lexer + +newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a } + +instance Functor PD where + fmap = liftM + +instance Applicative PD where + pure = returnPD + (<*>) = ap + +instance Monad PD where + (>>=) = thenPD + +liftP :: P a -> PD a +liftP (P f) = PD $ \_ s -> f s + +failMsgPD :: String -> PD a +failMsgPD = liftP . failMsgP + +returnPD :: a -> PD a +returnPD = liftP . return + +thenPD :: PD a -> (a -> PD b) -> PD b +(PD m) `thenPD` k = PD $ \d s -> + case m d s of + POk s1 a -> unPD (k a) d s1 + PFailed s1 -> PFailed s1 + +instance HasDynFlags PD where + getDynFlags = PD $ \d s -> POk s d diff --git a/GHC/Cmm/Node.hs b/GHC/Cmm/Node.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Node.hs @@ -0,0 +1,727 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- CmmNode type for representation using Hoopl graphs. + +module GHC.Cmm.Node ( + CmmNode(..), CmmFormal, CmmActual, CmmTickish, + UpdFrameOffset, Convention(..), + ForeignConvention(..), ForeignTarget(..), foreignTargetHints, + CmmReturnInfo(..), + mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, + mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors, + + -- * Tick scopes + CmmTickScope(..), isTickSubScope, combineTickScopes, + ) where + +import GHC.Prelude hiding (succ) + +import GHC.Platform.Regs +import GHC.Cmm.Expr +import GHC.Cmm.Switch +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Types.ForeignCall +import GHC.Utils.Outputable +import GHC.Runtime.Heap.Layout +import GHC.Core (Tickish) +import qualified GHC.Types.Unique as U + +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import Data.Maybe +import Data.List (tails,sortBy) +import GHC.Types.Unique (nonDetCmpUnique) +import GHC.Utils.Misc + + +------------------------ +-- CmmNode + +#define ULabel {-# UNPACK #-} !Label + +data CmmNode e x where + CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O + + CmmComment :: FastString -> CmmNode O O + + -- Tick annotation, covering Cmm code in our tick scope. We only + -- expect non-code @Tickish@ at this point (e.g. @SourceNote@). + -- See Note [CmmTick scoping details] + CmmTick :: !CmmTickish -> CmmNode O O + + -- Unwind pseudo-instruction, encoding stack unwinding + -- instructions for a debugger. This describes how to reconstruct + -- the "old" value of a register if we want to navigate the stack + -- up one frame. Having unwind information for @Sp@ will allow the + -- debugger to "walk" the stack. + -- + -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" + CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O + + CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O + -- Assign to register + + CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O + -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. + + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] + -- Like a "fat machine instruction"; can occur + -- in the middle of a block + ForeignTarget -> -- call target + [CmmFormal] -> -- zero or more results + [CmmActual] -> -- zero or more arguments + CmmNode O O + -- Semantics: clobbers any GlobalRegs for which callerSaves r == True + -- See Note [Unsafe foreign calls clobber caller-save registers] + -- + -- Invariant: the arguments and the ForeignTarget must not + -- mention any registers for which GHC.Platform.callerSaves + -- is True. See Note [Register parameter passing]. + + CmmBranch :: ULabel -> CmmNode O C + -- Goto another block in the same procedure + + CmmCondBranch :: { -- conditional branch + cml_pred :: CmmExpr, + cml_true, cml_false :: ULabel, + cml_likely :: Maybe Bool -- likely result of the conditional, + -- if known + } -> CmmNode O C + + CmmSwitch + :: CmmExpr -- Scrutinee, of some integral type + -> SwitchTargets -- Cases. See [Note SwitchTargets] + -> CmmNode O C + + CmmCall :: { -- A native call or tail call + cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! + + cml_cont :: Maybe Label, + -- Label of continuation (Nothing for return or tail call) + -- + -- Note [Continuation BlockIds]: these BlockIds are called + -- Continuation BlockIds, and are the only BlockIds that can + -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or + -- (CmmStackSlot (Young b) _). + + cml_args_regs :: [GlobalReg], + -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed + -- to the call. This is essential information for the + -- native code generator's register allocator; without + -- knowing which GlobalRegs are live it has to assume that + -- they are all live. This list should only include + -- GlobalRegs that are mapped to real machine registers on + -- the target platform. + + cml_args :: ByteOff, + -- Byte offset, from the *old* end of the Area associated with + -- the Label (if cml_cont = Nothing, then Old area), of + -- youngest outgoing arg. Set the stack pointer to this before + -- transferring control. + -- (NB: an update frame might also have been stored in the Old + -- area, but it'll be in an older part than the args.) + + cml_ret_args :: ByteOff, + -- For calls *only*, the byte offset for youngest returned value + -- This is really needed at the *return* point rather than here + -- at the call, but in practice it's convenient to record it here. + + cml_ret_off :: ByteOff + -- For calls *only*, the byte offset of the base of the frame that + -- must be described by the info table for the return point. + -- The older words are an update frames, which have their own + -- info-table and layout information + + -- From a liveness point of view, the stack words older than + -- cml_ret_off are treated as live, even if the sequel of + -- the call goes into a loop. + } -> CmmNode O C + + CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] + -- Always the last node of a block + tgt :: ForeignTarget, -- call target and convention + res :: [CmmFormal], -- zero or more results + args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] + succ :: ULabel, -- Label of continuation + ret_args :: ByteOff, -- same as cml_ret_args + ret_off :: ByteOff, -- same as cml_ret_off + intrbl:: Bool -- whether or not the call is interruptible + } -> CmmNode O C + +{- Note [Foreign calls] +~~~~~~~~~~~~~~~~~~~~~~~ +A CmmUnsafeForeignCall is used for *unsafe* foreign calls; +a CmmForeignCall call is used for *safe* foreign calls. + +Unsafe ones are mostly easy: think of them as a "fat machine +instruction". In particular, they do *not* kill all live registers, +just the registers they return to (there was a bit of code in GHC that +conservatively assumed otherwise.) However, see [Register parameter passing]. + +Safe ones are trickier. A safe foreign call + r = f(x) +ultimately expands to + push "return address" -- Never used to return to; + -- just points an info table + save registers into TSO + call suspendThread + r = f(x) -- Make the call + call resumeThread + restore registers + pop "return address" +We cannot "lower" a safe foreign call to this sequence of Cmms, because +after we've saved Sp all the Cmm optimiser's assumptions are broken. + +Note that a safe foreign call needs an info table. + +So Safe Foreign Calls must remain as last nodes until the stack is +made manifest in GHC.Cmm.LayoutStack, where they are lowered into the above +sequence. +-} + +{- Note [Unsafe foreign calls clobber caller-save registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A foreign call is defined to clobber any GlobalRegs that are mapped to +caller-saves machine registers (according to the prevailing C ABI). +GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves. + +This is a design choice that makes it easier to generate code later. +We could instead choose to say that foreign calls do *not* clobber +caller-saves regs, but then we would have to figure out which regs +were live across the call later and insert some saves/restores. + +Furthermore when we generate code we never have any GlobalRegs live +across a call, because they are always copied-in to LocalRegs and +copied-out again before making a call/jump. So all we have to do is +avoid any code motion that would make a caller-saves GlobalReg live +across a foreign call during subsequent optimisations. +-} + +{- Note [Register parameter passing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On certain architectures, some registers are utilized for parameter +passing in the C calling convention. For example, in x86-64 Linux +convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for +argument passing. These are registers R3-R6, which our generated +code may also be using; as a result, it's necessary to save these +values before doing a foreign call. This is done during initial +code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils. + +However, one result of doing this is that the contents of these registers may +mysteriously change if referenced inside the arguments. This is dangerous, so +you'll need to disable inlining much in the same way is done in GHC.Cmm.Sink +currently. We should fix this! +-} + +--------------------------------------------- +-- Eq instance of CmmNode + +deriving instance Eq (CmmNode e x) + +---------------------------------------------- +-- Hoopl instances of CmmNode + +instance NonLocal CmmNode where + entryLabel (CmmEntry l _) = l + + successors (CmmBranch l) = [l] + successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint + successors (CmmSwitch _ ids) = switchTargetsToList ids + successors (CmmCall {cml_cont=l}) = maybeToList l + successors (CmmForeignCall {succ=l}) = [l] + + +-------------------------------------------------- +-- Various helper types + +type CmmActual = CmmExpr +type CmmFormal = LocalReg + +type UpdFrameOffset = ByteOff + +-- | A convention maps a list of values (function arguments or return +-- values) to registers or stack locations. +data Convention + = NativeDirectCall + -- ^ top-level Haskell functions use @NativeDirectCall@, which + -- maps arguments to registers starting with R2, according to + -- how many registers are available on the platform. This + -- convention ignores R1, because for a top-level function call + -- the function closure is implicit, and doesn't need to be passed. + | NativeNodeCall + -- ^ non-top-level Haskell functions, which pass the address of + -- the function closure in R1 (regardless of whether R1 is a + -- real register or not), and the rest of the arguments in + -- registers or on the stack. + | NativeReturn + -- ^ a native return. The convention for returns depends on + -- how many values are returned: for just one value returned, + -- the appropriate register is used (R1, F1, etc.). regardless + -- of whether it is a real register or not. For multiple + -- values returned, they are mapped to registers or the stack. + | Slow + -- ^ Slow entry points: all args pushed on the stack + | GC + -- ^ Entry to the garbage collector: uses the node reg! + -- (TODO: I don't think we need this --SDM) + deriving( Eq ) + +data ForeignConvention + = ForeignConvention + CCallConv -- Which foreign-call convention + [ForeignHint] -- Extra info about the args + [ForeignHint] -- Extra info about the result + CmmReturnInfo + deriving Eq + +data CmmReturnInfo + = CmmMayReturn + | CmmNeverReturns + deriving ( Eq ) + +data ForeignTarget -- The target of a foreign call + = ForeignTarget -- A foreign procedure + CmmExpr -- Its address + ForeignConvention -- Its calling convention + | PrimTarget -- A possibly-side-effecting machine operation + CallishMachOp -- Which one + deriving Eq + +foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) +foreignTargetHints target + = ( res_hints ++ repeat NoHint + , arg_hints ++ repeat NoHint ) + where + (res_hints, arg_hints) = + case target of + PrimTarget op -> callishMachOpHints op + ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) -> + (res_hints, arg_hints) + +-------------------------------------------------- +-- Instances of register and slot users / definers + +instance UserOfRegs LocalReg (CmmNode e x) where + foldRegsUsed dflags f !z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt} -> fold f z tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. UserOfRegs LocalReg a + => (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed dflags f z n + +instance UserOfRegs GlobalReg (CmmNode e x) where + foldRegsUsed dflags f !z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. UserOfRegs GlobalReg a + => (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed dflags f z n + +instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where + -- The (Ord r) in the context is necessary here + -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance + foldRegsUsed _ _ !z (PrimTarget _) = z + foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e + +instance DefinerOfRegs LocalReg (CmmNode e x) where + foldRegsDefd dflags f !z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall _ fs _ -> fold f z fs + CmmForeignCall {res=res} -> fold f z res + _ -> z + where fold :: forall a b. DefinerOfRegs LocalReg a + => (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd dflags f z n + +instance DefinerOfRegs GlobalReg (CmmNode e x) where + foldRegsDefd dflags f !z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) + CmmCall {} -> fold f z activeRegs + CmmForeignCall {} -> fold f z activeRegs + -- See Note [Safe foreign calls clobber STG registers] + _ -> z + where fold :: forall a b. DefinerOfRegs GlobalReg a + => (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd dflags f z n + + platform = targetPlatform dflags + activeRegs = activeStgRegs platform + activeCallerSavesRegs = filter (callerSaves platform) activeRegs + + foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = [] + foreignTargetRegs _ = activeCallerSavesRegs + +-- Note [Safe foreign calls clobber STG registers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During stack layout phase every safe foreign call is expanded into a block +-- that contains unsafe foreign call (instead of safe foreign call) and ends +-- with a normal call (See Note [Foreign calls]). This means that we must +-- treat safe foreign call as if it was a normal call (because eventually it +-- will be). This is important if we try to run sinking pass before stack +-- layout phase. Consider this example of what might go wrong (this is cmm +-- code from stablename001 test). Here is code after common block elimination +-- (before stack layout): +-- +-- c1q6: +-- _s1pf::P64 = R1; +-- _c1q8::I64 = performMajorGC; +-- I64[(young + 8)] = c1q9; +-- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...) +-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- If we run sinking pass now (still before stack layout) we will get this: +-- +-- c1q6: +-- I64[(young + 8)] = c1q9; +-- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...) +-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- Notice that _s1pf was sunk past a foreign call. When we run stack layout +-- safe call to performMajorGC will be turned into: +-- +-- c1q6: +-- _s1pc::P64 = P64[Sp + 8]; +-- I64[Sp - 8] = c1q9; +-- Sp = Sp - 8; +-- I64[I64[CurrentTSO + 24] + 16] = Sp; +-- P64[CurrentNursery + 8] = Hp + 8; +-- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,] +-- result hints: [PtrHint] suspendThread(BaseReg, 0); +-- call "ccall" arg hints: [] result hints: [] performMajorGC(); +-- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint] +-- result hints: [PtrHint] resumeThread(_u1qI::I64); +-- BaseReg = _u1qJ::I64; +-- _u1qK::P64 = CurrentTSO; +-- _u1qL::P64 = I64[_u1qK::P64 + 24]; +-- Sp = I64[_u1qL::P64 + 16]; +-- SpLim = _u1qL::P64 + 192; +-- HpAlloc = 0; +-- Hp = I64[CurrentNursery + 8] - 8; +-- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1); +-- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- _s1pf::P64 = R1; <------ INCORRECT! +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that +-- call is clearly incorrect. This is what would happen if we assumed that +-- safe foreign call has the same semantics as unsafe foreign call. To prevent +-- this we need to treat safe foreign call as if was normal call. + +----------------------------------- +-- mapping Expr in GHC.Cmm.Node + +mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget +mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c +mapForeignTarget _ m@(PrimTarget _) = m + +wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr +-- Take a transformer on expressions and apply it recursively. +-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e +-- then uses f to rewrite the resulting expression +wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) +wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) +wrapRecExp f e = f e + +mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExp _ f@(CmmEntry{}) = f +mapExp _ m@(CmmComment _) = m +mapExp _ m@(CmmTick _) = m +mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap (fmap f)) regs) +mapExp f (CmmAssign r e) = CmmAssign r (f e) +mapExp f (CmmStore addr e) = CmmStore (f addr) (f e) +mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) +mapExp _ l@(CmmBranch _) = l +mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l +mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids +mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt} +mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl + +mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExpDeep f = mapExp $ wrapRecExp f + +------------------------------------------------------------------------ +-- mapping Expr in GHC.Cmm.Node, but not performing allocation if no changes + +mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget +mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e +mapForeignTargetM _ (PrimTarget _) = Nothing + +wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) +-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e +-- then gives f a chance to rewrite the resulting expression +wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) +wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr) +wrapRecExpM f e = f e + +mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpM _ (CmmEntry{}) = Nothing +mapExpM _ (CmmComment _) = Nothing +mapExpM _ (CmmTick _) = Nothing +mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs +mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e +mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e] +mapExpM _ (CmmBranch _) = Nothing +mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e +mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e +mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt +mapExpM f (CmmUnsafeForeignCall tgt fs as) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) + Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as +mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl) + Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as + +-- share as much as possible +mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] +mapListM f xs = let (b, r) = mapListT f xs + in if b then Just r else Nothing + +mapListJ :: (a -> Maybe a) -> [a] -> [a] +mapListJ f xs = snd (mapListT f xs) + +mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a]) +mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs)) + where g (_, y, Nothing) (True, ys) = (True, y:ys) + g (_, _, Just y) (True, ys) = (True, y:ys) + g (ys', _, Nothing) (False, _) = (False, ys') + g (_, _, Just y) (False, ys) = (True, y:ys) + +mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpDeepM f = mapExpM $ wrapRecExpM f + +----------------------------------- +-- folding Expr in GHC.Cmm.Node + +foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z +foldExpForeignTarget exp (ForeignTarget e _) z = exp e z +foldExpForeignTarget _ (PrimTarget _) z = z + +-- Take a folder on expressions and apply it recursively. +-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad +-- itself, delegating all the other CmmExpr forms to 'f'. +wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z +wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es +wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z) +wrapRecExpf f e z = f e z + +foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExp _ (CmmEntry {}) z = z +foldExp _ (CmmComment {}) z = z +foldExp _ (CmmTick {}) z = z +foldExp f (CmmUnwind xs) z = foldr (maybe id f) z (map snd xs) +foldExp f (CmmAssign _ e) z = f e z +foldExp f (CmmStore addr e) z = f addr $ f e z +foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as +foldExp _ (CmmBranch _) z = z +foldExp f (CmmCondBranch e _ _ _) z = f e z +foldExp f (CmmSwitch e _) z = f e z +foldExp f (CmmCall {cml_target=tgt}) z = f tgt z +foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args + +foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExpDeep f = foldExp (wrapRecExpf f) + +-- ----------------------------------------------------------------------------- + +mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C +mapSuccessors f (CmmBranch bid) = CmmBranch (f bid) +mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l +mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids) +mapSuccessors _ n = n + +mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C + -> (CmmNode O C, [a]) +mapCollectSuccessors f (CmmBranch bid) + = let (bid', acc) = f bid in (CmmBranch bid', [acc]) +mapCollectSuccessors f (CmmCondBranch p y n l) + = let (bidt, acct) = f y + (bidf, accf) = f n + in (CmmCondBranch p bidt bidf l, [accf, acct]) +mapCollectSuccessors f (CmmSwitch e ids) + = let lbls = switchTargetsToList ids :: [Label] + lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a) + in ( CmmSwitch e + (mapSwitchTargets + (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids) + , map snd (mapElems lblMap) + ) +mapCollectSuccessors _ n = (n, []) + +-- ----------------------------------------------------------------------------- + +-- | Tickish in Cmm context (annotations only) +type CmmTickish = Tickish () + +-- | Tick scope identifier, allowing us to reason about what +-- annotations in a Cmm block should scope over. We especially take +-- care to allow optimisations to reorganise blocks without losing +-- tick association in the process. +data CmmTickScope + = GlobalScope + -- ^ The global scope is the "root" of the scope graph. Every + -- scope is a sub-scope of the global scope. It doesn't make sense + -- to add ticks to this scope. On the other hand, this means that + -- setting this scope on a block means no ticks apply to it. + + | SubScope !U.Unique CmmTickScope + -- ^ Constructs a new sub-scope to an existing scope. This allows + -- us to translate Core-style scoping rules (see @tickishScoped@) + -- into the Cmm world. Suppose the following code: + -- + -- tick<1> case ... of + -- A -> tick<2> ... + -- B -> tick<3> ... + -- + -- We want the top-level tick annotation to apply to blocks + -- generated for the A and B alternatives. We can achieve that by + -- generating tick<1> into a block with scope a, while the code + -- for alternatives A and B gets generated into sub-scopes a/b and + -- a/c respectively. + + | CombinedScope CmmTickScope CmmTickScope + -- ^ A combined scope scopes over everything that the two given + -- scopes cover. It is therefore a sub-scope of either scope. This + -- is required for optimisations. Consider common block elimination: + -- + -- A -> tick<2> case ... of + -- C -> [common] + -- B -> tick<3> case ... of + -- D -> [common] + -- + -- We will generate code for the C and D alternatives, and figure + -- out afterwards that it's actually common code. Scoping rules + -- dictate that the resulting common block needs to be covered by + -- both tick<2> and tick<3>, therefore we need to construct a + -- scope that is a child to *both* scope. Now we can do that - if + -- we assign the scopes a/c and b/d to the common-ed up blocks, + -- the new block could have a combined tick scope a/c+b/d, which + -- both tick<2> and tick<3> apply to. + +-- Note [CmmTick scoping details]: +-- +-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the +-- same block. Note that as a result of this, optimisations making +-- tick scopes more specific can *reduce* the amount of code a tick +-- scopes over. Fixing this would require a separate @CmmTickScope@ +-- field for @CmmTick@. Right now we do not do this simply because I +-- couldn't find an example where it actually mattered -- multiple +-- blocks within the same scope generally jump to each other, which +-- prevents common block elimination from happening in the first +-- place. But this is no strong reason, so if Cmm optimisations become +-- more involved in future this might have to be revisited. + +-- | Output all scope paths. +scopeToPaths :: CmmTickScope -> [[U.Unique]] +scopeToPaths GlobalScope = [[]] +scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s) +scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2 + +-- | Returns the head uniques of the scopes. This is based on the +-- assumption that the @Unique@ of @SubScope@ identifies the +-- underlying super-scope. Used for efficient equality and comparison, +-- see below. +scopeUniques :: CmmTickScope -> [U.Unique] +scopeUniques GlobalScope = [] +scopeUniques (SubScope u _) = [u] +scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2 + +-- Equality and order is based on the head uniques defined above. We +-- take care to short-cut the (extremely) common cases. +instance Eq CmmTickScope where + GlobalScope == GlobalScope = True + GlobalScope == _ = False + _ == GlobalScope = False + (SubScope u _) == (SubScope u' _) = u == u' + (SubScope _ _) == _ = False + _ == (SubScope _ _) = False + scope == scope' = + sortBy nonDetCmpUnique (scopeUniques scope) == + sortBy nonDetCmpUnique (scopeUniques scope') + -- This is still deterministic because + -- the order is the same for equal lists + +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +-- See Note [No Ord for Unique] +instance Ord CmmTickScope where + compare GlobalScope GlobalScope = EQ + compare GlobalScope _ = LT + compare _ GlobalScope = GT + compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u' + compare scope scope' = cmpList nonDetCmpUnique + (sortBy nonDetCmpUnique $ scopeUniques scope) + (sortBy nonDetCmpUnique $ scopeUniques scope') + +instance Outputable CmmTickScope where + ppr GlobalScope = text "global" + ppr (SubScope us GlobalScope) + = ppr us + ppr (SubScope us s) = ppr s <> char '/' <> ppr us + ppr combined = parens $ hcat $ punctuate (char '+') $ + map (hcat . punctuate (char '/') . map ppr . reverse) $ + scopeToPaths combined + +-- | Checks whether two tick scopes are sub-scopes of each other. True +-- if the two scopes are equal. +isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool +isTickSubScope = cmp + where cmp _ GlobalScope = True + cmp GlobalScope _ = False + cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s' + cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2' + cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s' + +-- | Combine two tick scopes. The new scope should be sub-scope of +-- both parameters. We simplify automatically if one tick scope is a +-- sub-scope of the other already. +combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope +combineTickScopes s1 s2 + | s1 `isTickSubScope` s2 = s1 + | s2 `isTickSubScope` s1 = s2 + | otherwise = CombinedScope s1 s2 diff --git a/GHC/Cmm/Opt.hs b/GHC/Cmm/Opt.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Opt.hs @@ -0,0 +1,424 @@ +----------------------------------------------------------------------------- +-- +-- Cmm optimisation +-- +-- (c) The University of Glasgow 2006 +-- +----------------------------------------------------------------------------- + +module GHC.Cmm.Opt ( + constantFoldNode, + constantFoldExpr, + cmmMachOpFold, + cmmMachOpFoldM + ) where + +import GHC.Prelude + +import GHC.Cmm.Utils +import GHC.Cmm +import GHC.Utils.Misc + +import GHC.Utils.Outputable +import GHC.Platform + +import Data.Bits +import Data.Maybe + + +constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x +constantFoldNode platform = mapExp (constantFoldExpr platform) + +constantFoldExpr :: Platform -> CmmExpr -> CmmExpr +constantFoldExpr platform = wrapRecExp f + where f (CmmMachOp op args) = cmmMachOpFold platform op args + f (CmmRegOff r 0) = CmmReg r + f e = e + +-- ----------------------------------------------------------------------------- +-- MachOp constant folder + +-- Now, try to constant-fold the MachOps. The arguments have already +-- been optimized and folded. + +cmmMachOpFold + :: Platform + -> MachOp -- The operation from an CmmMachOp + -> [CmmExpr] -- The optimized arguments + -> CmmExpr + +cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args) + +-- Returns Nothing if no changes, useful for Hoopl, also reduces +-- allocation! +cmmMachOpFoldM + :: Platform + -> MachOp + -> [CmmExpr] + -> Maybe CmmExpr + +cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)] + = Just $ case op of + MO_S_Neg _ -> CmmLit (CmmInt (-x) rep) + MO_Not _ -> CmmLit (CmmInt (complement x) rep) + + -- these are interesting: we must first narrow to the + -- "from" type, in order to truncate to the correct size. + -- The final narrow/widen to the destination type + -- is implicit in the CmmLit. + MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to) + MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) + MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) + MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to) + + _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op + + +-- Eliminate conversion NOPs +cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM _ (MO_XX_Conv rep1 rep2) [x] | rep1 == rep2 = Just x + +-- Eliminate nested conversions where possible +cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] + | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, + Just (_, rep3,signed2) <- isIntConversion conv_outer + = case () of + -- widen then narrow to the same size is a nop + _ | rep1 < rep2 && rep1 == rep3 -> Just x + -- Widen then narrow to different size: collapse to single conversion + -- but remember to use the signedness from the widening, just in case + -- the final conversion is a widen. + | rep1 < rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + -- Nested widenings: collapse if the signedness is the same + | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> + Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + -- Nested narrowings: collapse + | rep1 > rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x] + | otherwise -> + Nothing + where + isIntConversion (MO_UU_Conv rep1 rep2) + = Just (rep1,rep2,False) + isIntConversion (MO_SS_Conv rep1 rep2) + = Just (rep1,rep2,True) + isIntConversion _ = Nothing + + intconv True = MO_SS_Conv + intconv False = MO_UU_Conv + +-- ToDo: a narrow of a load can be collapsed into a narrow load, right? +-- but what if the architecture only supports word-sized loads, should +-- we do the transformation anyway? + +cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] + = case mop of + -- for comparisons: don't forget to narrow the arguments before + -- comparing, since they might be out of range. + MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform)) + MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform)) + + MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth platform)) + MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform)) + MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth platform)) + MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform)) + + MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth platform)) + MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform)) + MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth platform)) + MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform)) + + MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) + MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) + MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r) + MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r) + MO_U_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem` y_u) r) + MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r) + MO_S_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r) + + MO_And r -> Just $ CmmLit (CmmInt (x .&. y) r) + MO_Or r -> Just $ CmmLit (CmmInt (x .|. y) r) + MO_Xor r -> Just $ CmmLit (CmmInt (x `xor` y) r) + + MO_Shl r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r) + MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) + MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r) + + _ -> Nothing + + where + x_u = narrowU xrep x + y_u = narrowU xrep y + x_s = narrowS xrep x + y_s = narrowS xrep y + + +-- When possible, shift the constants to the right-hand side, so that we +-- can match for strength reductions. Note that the code generator will +-- also assume that constants have been shifted to the right when +-- possible. + +cmmMachOpFoldM platform op [x@(CmmLit _), y] + | not (isLit y) && isCommutableMachOp op + = Just (cmmMachOpFold platform op [y, x]) + +-- Turn (a+b)+c into a+(b+c) where possible. Because literals are +-- moved to the right, it is more likely that we will find +-- opportunities for constant folding when the expression is +-- right-associated. +-- +-- ToDo: this appears to introduce a quadratic behaviour due to the +-- nested cmmMachOpFold. Can we fix this? +-- +-- Why do we check isLit arg1? If arg1 is a lit, it means that arg2 +-- is also a lit (otherwise arg1 would be on the right). If we +-- put arg1 on the left of the rearranged expression, we'll get into a +-- loop: (x1+x2)+x3 => x1+(x2+x3) => (x2+x3)+x1 => x2+(x3+x1) ... +-- +-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the +-- PicBaseReg from the corresponding label (or label difference). +-- +cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3] + | mop2 `associates_with` mop1 + && not (isLit arg1) && not (isPicReg arg1) + = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]]) + where + MO_Add{} `associates_with` MO_Sub{} = True + mop1 `associates_with` mop2 = + mop1 == mop2 && isAssociativeMachOp mop1 + +-- special case: (a - b) + c ==> a + (c - b) +cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] + | not (isLit arg1) && not (isPicReg arg1) + = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]]) + +-- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N) +-- +-- this is better because lit+N is a single link-time constant (e.g. a +-- CmmLabelOff), so the right-hand expression needs only one +-- instruction, whereas the left needs two. This happens when pointer +-- tagging gives us label+offset, and PIC turns the label into +-- PicBaseReg + label. +-- +cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit] + , CmmLit (CmmInt n rep) ] + | isPicReg pic + = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] + where off = fromIntegral (narrowS rep n) + +-- Make a RegOff if we can +cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n)) + +-- Fold label(+/-)offset into a CmmLit where possible + +cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) + + +-- Comparison of literal with widened operand: perform the comparison +-- at the smaller width, as long as the literal is within range. + +-- We can't do the reverse trick, when the operand is narrowed: +-- narrowing throws away bits from the operand, there's no way to do +-- the same comparison at the larger size. + +cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] + | -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try + platformArch platform `elem` [ArchX86, ArchX86_64], + -- if the operand is widened: + Just (rep, signed, narrow_fn) <- maybe_conversion conv, + -- and this is a comparison operation: + Just narrow_cmp <- maybe_comparison cmp rep signed, + -- and the literal fits in the smaller size: + i == narrow_fn rep i + -- then we can do the comparison at the smaller size + = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)]) + where + maybe_conversion (MO_UU_Conv from to) + | to > from + = Just (from, False, narrowU) + maybe_conversion (MO_SS_Conv from to) + | to > from + = Just (from, True, narrowS) + + -- don't attempt to apply this optimisation when the source + -- is a float; see #1916 + maybe_conversion _ = Nothing + + -- careful (#2080): if the original comparison was signed, but + -- we were doing an unsigned widen, then we must do an + -- unsigned comparison at the smaller size. + maybe_comparison (MO_U_Gt _) rep _ = Just (MO_U_Gt rep) + maybe_comparison (MO_U_Ge _) rep _ = Just (MO_U_Ge rep) + maybe_comparison (MO_U_Lt _) rep _ = Just (MO_U_Lt rep) + maybe_comparison (MO_U_Le _) rep _ = Just (MO_U_Le rep) + maybe_comparison (MO_Eq _) rep _ = Just (MO_Eq rep) + maybe_comparison (MO_S_Gt _) rep True = Just (MO_S_Gt rep) + maybe_comparison (MO_S_Ge _) rep True = Just (MO_S_Ge rep) + maybe_comparison (MO_S_Lt _) rep True = Just (MO_S_Lt rep) + maybe_comparison (MO_S_Le _) rep True = Just (MO_S_Le rep) + maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep) + maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep) + maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep) + maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep) + maybe_comparison _ _ _ = Nothing + +-- We can often do something with constants of 0 and 1 ... +-- See Note [Comparison operators] + +cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))] + = case mop of + -- Arithmetic + MO_Add _ -> Just x -- x + 0 = x + MO_Sub _ -> Just x -- x - 0 = x + MO_Mul _ -> Just y -- x * 0 = 0 + + -- Logical operations + MO_And _ -> Just y -- x & 0 = 0 + MO_Or _ -> Just x -- x | 0 = x + MO_Xor _ -> Just x -- x `xor` 0 = x + + -- Shifts + MO_Shl _ -> Just x -- x << 0 = x + MO_S_Shr _ -> Just x -- ditto shift-right + MO_U_Shr _ -> Just x + + -- Comparisons; these ones are trickier + -- See Note [Comparison operators] + MO_Ne _ | isComparisonExpr x -> Just x -- (x > y) != 0 = x > y + MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x > y) == 0 = x <= y + MO_U_Gt _ | isComparisonExpr x -> Just x -- (x > y) > 0 = x > y + MO_S_Gt _ | isComparisonExpr x -> Just x -- ditto + MO_U_Lt _ | isComparisonExpr x -> Just zero -- (x > y) < 0 = 0 + MO_S_Lt _ | isComparisonExpr x -> Just zero + MO_U_Ge _ | isComparisonExpr x -> Just one -- (x > y) >= 0 = 1 + MO_S_Ge _ | isComparisonExpr x -> Just one + + MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x > y) <= 0 = x <= y + MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' + _ -> Nothing + where + zero = CmmLit (CmmInt 0 (wordWidth platform)) + one = CmmLit (CmmInt 1 (wordWidth platform)) + +cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))] + = case mop of + -- Arithmetic: x*1 = x, etc + MO_Mul _ -> Just x + MO_S_Quot _ -> Just x + MO_U_Quot _ -> Just x + MO_S_Rem _ -> Just $ CmmLit (CmmInt 0 rep) + MO_U_Rem _ -> Just $ CmmLit (CmmInt 0 rep) + + -- Comparisons; trickier + -- See Note [Comparison operators] + MO_Ne _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x>y) != 1 = x<=y + MO_Eq _ | isComparisonExpr x -> Just x -- (x>y) == 1 = x>y + MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x>y) < 1 = x<=y + MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- ditto + MO_U_Gt _ | isComparisonExpr x -> Just zero -- (x>y) > 1 = 0 + MO_S_Gt _ | isComparisonExpr x -> Just zero + MO_U_Le _ | isComparisonExpr x -> Just one -- (x>y) <= 1 = 1 + MO_S_Le _ | isComparisonExpr x -> Just one + MO_U_Ge _ | isComparisonExpr x -> Just x -- (x>y) >= 1 = x>y + MO_S_Ge _ | isComparisonExpr x -> Just x + _ -> Nothing + where + zero = CmmLit (CmmInt 0 (wordWidth platform)) + one = CmmLit (CmmInt 1 (wordWidth platform)) + +-- Now look for multiplication/division by powers of 2 (integers). + +cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))] + = case mop of + MO_Mul rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) + MO_U_Quot rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) + MO_U_Rem rep + | Just _ <- exactLog2 n -> + Just (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)]) + MO_S_Quot rep + | Just p <- exactLog2 n, + CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require + -- it is a reg. FIXME: remove this restriction. + Just (cmmMachOpFold platform (MO_S_Shr rep) + [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)]) + MO_S_Rem rep + | Just p <- exactLog2 n, + CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require + -- it is a reg. FIXME: remove this restriction. + -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p). + -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot) + -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation. + Just (cmmMachOpFold platform (MO_Sub rep) + [x, cmmMachOpFold platform (MO_And rep) + [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]]) + _ -> Nothing + where + -- In contrast with unsigned integers, for signed ones + -- shift right is not the same as quot, because it rounds + -- to minus infinity, whereas quot rounds toward zero. + -- To fix this up, we add one less than the divisor to the + -- dividend if it is a negative number. + -- + -- to avoid a test/jump, we use the following sequence: + -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) + -- x2 = y & (divisor-1) + -- result = x + x2 + -- this could be done a bit more simply using conditional moves, + -- but we're processor independent here. + -- + -- we optimise the divide by 2 case slightly, generating + -- x1 = x >> word_size-1 (unsigned) + -- return = x + x1 + signedQuotRemHelper :: Width -> Integer -> CmmExpr + signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2] + where + bits = fromIntegral (widthInBits rep) - 1 + shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep + x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] + x2 = if p == 1 then x1 else + CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] + +-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x +-- Unfortunately this needs a unique supply because x might not be a +-- register. See #2253 (program 6) for an example. + + +-- Anything else is just too hard. + +cmmMachOpFoldM _ _ _ = Nothing + +{- Note [Comparison operators] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + CmmCondBranch ((x>#y) == 1) t f +we really want to convert to + CmmCondBranch (x>#y) t f + +That's what the constant-folding operations on comparison operators do above. +-} + + +-- ----------------------------------------------------------------------------- +-- Utils + +isPicReg :: CmmExpr -> Bool +isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True +isPicReg _ = False diff --git a/GHC/Cmm/Parser.y b/GHC/Cmm/Parser.y new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Parser.y @@ -0,0 +1,1448 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2004-2012 +-- +-- Parser for concrete Cmm. +-- +----------------------------------------------------------------------------- + +{- ----------------------------------------------------------------------------- +Note [Syntax of .cmm files] + +NOTE: You are very much on your own in .cmm. There is very little +error checking at all: + + * Type errors are detected by the (optional) -dcmm-lint pass, if you + don't turn this on then a type error will likely result in a panic + from the native code generator. + + * Passing the wrong number of arguments or arguments of the wrong + type is not detected. + +There are two ways to write .cmm code: + + (1) High-level Cmm code delegates the stack handling to GHC, and + never explicitly mentions Sp or registers. + + (2) Low-level Cmm manages the stack itself, and must know about + calling conventions. + +Whether you want high-level or low-level Cmm is indicated by the +presence of an argument list on a procedure. For example: + +foo ( gcptr a, bits32 b ) +{ + // this is high-level cmm code + + if (b > 0) { + // we can make tail calls passing arguments: + jump stg_ap_0_fast(a); + } + + push (stg_upd_frame_info, a) { + // stack frames can be explicitly pushed + + (x,y) = call wibble(a,b,3,4); + // calls pass arguments and return results using the native + // Haskell calling convention. The code generator will automatically + // construct a stack frame and an info table for the continuation. + + return (x,y); + // we can return multiple values from the current proc + } +} + +bar +{ + // this is low-level cmm code, indicated by the fact that we did not + // put an argument list on bar. + + x = R1; // the calling convention is explicit: better be careful + // that this works on all platforms! + + jump %ENTRY_CODE(Sp(0)) +} + +Here is a list of rules for high-level and low-level code. If you +break the rules, you get a panic (for using a high-level construct in +a low-level proc), or wrong code (when using low-level code in a +high-level proc). This stuff isn't checked! (TODO!) + +High-level only: + + - tail-calls with arguments, e.g. + jump stg_fun (arg1, arg2); + + - function calls: + (ret1,ret2) = call stg_fun (arg1, arg2); + + This makes a call with the NativeNodeCall convention, and the + values are returned to the following code using the NativeReturn + convention. + + - returning: + return (ret1, ret2) + + These use the NativeReturn convention to return zero or more + results to the caller. + + - pushing stack frames: + push (info_ptr, field1, ..., fieldN) { ... statements ... } + + - reserving temporary stack space: + + reserve N = x { ... } + + this reserves an area of size N (words) on the top of the stack, + and binds its address to x (a local register). Typically this is + used for allocating temporary storage for passing to foreign + functions. + + Note that if you make any native calls or invoke the GC in the + scope of the reserve block, you are responsible for ensuring that + the stack you reserved is laid out correctly with an info table. + +Low-level only: + + - References to Sp, R1-R8, F1-F4 etc. + + NB. foreign calls may clobber the argument registers R1-R8, F1-F4 + etc., so ensure they are saved into variables around foreign + calls. + + - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp + directly. + +Both high-level and low-level code can use a raw tail-call: + + jump stg_fun [R1,R2] + +NB. you *must* specify the list of GlobalRegs that are passed via a +jump, otherwise the register allocator will assume that all the +GlobalRegs are dead at the jump. + + +Calling Conventions +------------------- + +High-level procedures use the NativeNode calling convention, or the +NativeReturn convention if the 'return' keyword is used (see Stack +Frames below). + +Low-level procedures implement their own calling convention, so it can +be anything at all. + +If a low-level procedure implements the NativeNode calling convention, +then it can be called by high-level code using an ordinary function +call. In general this is hard to arrange because the calling +convention depends on the number of physical registers available for +parameter passing, but there are two cases where the calling +convention is platform-independent: + + - Zero arguments. + + - One argument of pointer or non-pointer word type; this is always + passed in R1 according to the NativeNode convention. + + - Returning a single value; these conventions are fixed and platform + independent. + + +Stack Frames +------------ + +A stack frame is written like this: + +INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN ) + return ( arg1, ..., argM ) +{ + ... code ... +} + +where field1 ... fieldN are the fields of the stack frame (with types) +arg1...argN are the values returned to the stack frame (with types). +The return values are assumed to be passed according to the +NativeReturn convention. + +On entry to the code, the stack frame looks like: + + |----------| + | fieldN | + | ... | + | field1 | + |----------| + | info_ptr | + |----------| + | argN | + | ... | <- Sp + +and some of the args may be in registers. + +We prepend the code by a copyIn of the args, and assign all the stack +frame fields to their formals. The initial "arg offset" for stack +layout purposes consists of the whole stack frame plus any args that +might be on the stack. + +A tail-call may pass a stack frame to the callee using the following +syntax: + +jump f (info_ptr, field1,..,fieldN) (arg1,..,argN) + +where info_ptr and field1..fieldN describe the stack frame, and +arg1..argN are the arguments passed to f using the NativeNodeCall +convention. Note if a field is longer than a word (e.g. a D_ on +a 32-bit machine) then the call will push as many words as +necessary to the stack to accommodate it (e.g. 2). + + +----------------------------------------------------------------------------- -} + +{ +{-# LANGUAGE TupleSections #-} + +module GHC.Cmm.Parser ( parseCmmFile ) where + +import GHC.Prelude +import qualified Prelude -- for happy-generated code + +import GHC.StgToCmm.ExtCode +import GHC.Cmm.CallConv +import GHC.StgToCmm.Prof +import GHC.StgToCmm.Heap +import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit + , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff + , getUpdFrameOff ) +import qualified GHC.StgToCmm.Monad as F +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Foreign +import GHC.StgToCmm.Expr +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Layout hiding (ArgRep(..)) +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame ) +import GHC.Core ( Tickish(SourceNote) ) + +import GHC.Cmm.Opt +import GHC.Cmm.Graph +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch ( mkSwitchTargets ) +import GHC.Cmm.Info +import GHC.Cmm.BlockId +import GHC.Cmm.Lexer +import GHC.Cmm.CLabel +import GHC.Cmm.Monad +import GHC.Runtime.Heap.Layout +import GHC.Parser.Lexer + +import GHC.Types.CostCentre +import GHC.Types.ForeignCall +import GHC.Unit.Module +import GHC.Platform +import GHC.Types.Literal +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.SrcLoc +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Settings.Constants +import GHC.Utils.Outputable +import GHC.Types.Basic +import GHC.Data.Bag ( emptyBag, unitBag ) +import GHC.Types.Var + +import Control.Monad +import Data.Array +import Data.Char ( ord ) +import System.Exit +import Data.Maybe +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as BS8 + +#include "HsVersions.h" +} + +%expect 0 + +%token + ':' { L _ (CmmT_SpecChar ':') } + ';' { L _ (CmmT_SpecChar ';') } + '{' { L _ (CmmT_SpecChar '{') } + '}' { L _ (CmmT_SpecChar '}') } + '[' { L _ (CmmT_SpecChar '[') } + ']' { L _ (CmmT_SpecChar ']') } + '(' { L _ (CmmT_SpecChar '(') } + ')' { L _ (CmmT_SpecChar ')') } + '=' { L _ (CmmT_SpecChar '=') } + '`' { L _ (CmmT_SpecChar '`') } + '~' { L _ (CmmT_SpecChar '~') } + '/' { L _ (CmmT_SpecChar '/') } + '*' { L _ (CmmT_SpecChar '*') } + '%' { L _ (CmmT_SpecChar '%') } + '-' { L _ (CmmT_SpecChar '-') } + '+' { L _ (CmmT_SpecChar '+') } + '&' { L _ (CmmT_SpecChar '&') } + '^' { L _ (CmmT_SpecChar '^') } + '|' { L _ (CmmT_SpecChar '|') } + '>' { L _ (CmmT_SpecChar '>') } + '<' { L _ (CmmT_SpecChar '<') } + ',' { L _ (CmmT_SpecChar ',') } + '!' { L _ (CmmT_SpecChar '!') } + + '..' { L _ (CmmT_DotDot) } + '::' { L _ (CmmT_DoubleColon) } + '>>' { L _ (CmmT_Shr) } + '<<' { L _ (CmmT_Shl) } + '>=' { L _ (CmmT_Ge) } + '<=' { L _ (CmmT_Le) } + '==' { L _ (CmmT_Eq) } + '!=' { L _ (CmmT_Ne) } + '&&' { L _ (CmmT_BoolAnd) } + '||' { L _ (CmmT_BoolOr) } + + 'True' { L _ (CmmT_True ) } + 'False' { L _ (CmmT_False) } + 'likely'{ L _ (CmmT_likely)} + + 'CLOSURE' { L _ (CmmT_CLOSURE) } + 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } + 'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) } + 'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) } + 'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) } + 'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) } + 'else' { L _ (CmmT_else) } + 'export' { L _ (CmmT_export) } + 'section' { L _ (CmmT_section) } + 'goto' { L _ (CmmT_goto) } + 'if' { L _ (CmmT_if) } + 'call' { L _ (CmmT_call) } + 'jump' { L _ (CmmT_jump) } + 'foreign' { L _ (CmmT_foreign) } + 'never' { L _ (CmmT_never) } + 'prim' { L _ (CmmT_prim) } + 'reserve' { L _ (CmmT_reserve) } + 'return' { L _ (CmmT_return) } + 'returns' { L _ (CmmT_returns) } + 'import' { L _ (CmmT_import) } + 'switch' { L _ (CmmT_switch) } + 'case' { L _ (CmmT_case) } + 'default' { L _ (CmmT_default) } + 'push' { L _ (CmmT_push) } + 'unwind' { L _ (CmmT_unwind) } + 'bits8' { L _ (CmmT_bits8) } + 'bits16' { L _ (CmmT_bits16) } + 'bits32' { L _ (CmmT_bits32) } + 'bits64' { L _ (CmmT_bits64) } + 'bits128' { L _ (CmmT_bits128) } + 'bits256' { L _ (CmmT_bits256) } + 'bits512' { L _ (CmmT_bits512) } + 'float32' { L _ (CmmT_float32) } + 'float64' { L _ (CmmT_float64) } + 'gcptr' { L _ (CmmT_gcptr) } + + GLOBALREG { L _ (CmmT_GlobalReg $$) } + NAME { L _ (CmmT_Name $$) } + STRING { L _ (CmmT_String $$) } + INT { L _ (CmmT_Int $$) } + FLOAT { L _ (CmmT_Float $$) } + +%monad { PD } { >>= } { return } +%lexer { cmmlex } { L _ CmmT_EOF } +%name cmmParse cmm +%tokentype { Located CmmToken } + +-- C-- operator precedences, taken from the C-- spec +%right '||' -- non-std extension, called %disjoin in C-- +%right '&&' -- non-std extension, called %conjoin in C-- +%right '!' +%nonassoc '>=' '>' '<=' '<' '!=' '==' +%left '|' +%left '^' +%left '&' +%left '>>' '<<' +%left '-' '+' +%left '/' '*' '%' +%right '~' + +%% + +cmm :: { CmmParse () } + : {- empty -} { return () } + | cmmtop cmm { do $1; $2 } + +cmmtop :: { CmmParse () } + : cmmproc { $1 } + | cmmdata { $1 } + | decl { $1 } + | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' + {% liftP . withHomeUnitId $ \pkg -> + do lits <- sequence $6; + staticClosure pkg $3 $5 (map getLit lits) } + +-- The only static closures in the RTS are dummy closures like +-- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need +-- to provide the full generality of static closures here. +-- In particular: +-- * CCS can always be CCS_DONT_CARE +-- * closure is always extern +-- * payload is always empty +-- * we can derive closure and info table labels from a single NAME + +cmmdata :: { CmmParse () } + : 'section' STRING '{' data_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) } + +data_label :: { CmmParse CLabel } + : NAME ':' + {% liftP . withHomeUnitId $ \pkg -> + return (mkCmmDataLabel pkg (NeedExternDecl False) $1) } + +statics :: { [CmmParse [CmmStatic]] } + : {- empty -} { [] } + | static statics { $1 : $2 } + +static :: { CmmParse [CmmStatic] } + : type expr ';' { do e <- $2; + return [CmmStaticLit (getLit e)] } + | type ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1))] } + | 'bits8' '[' ']' STRING ';' { return [mkString $4] } + | 'bits8' '[' INT ']' ';' { return [CmmUninitialised + (fromIntegral $3)] } + | typenot8 '[' INT ']' ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1) * + fromIntegral $3)] } + | 'CLOSURE' '(' NAME lits ')' + { do { lits <- sequence $4 + ; dflags <- getDynFlags + ; return $ map CmmStaticLit $ + mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) + -- mkForeignLabel because these are only used + -- for CHARLIKE and INTLIKE closures in the RTS. + dontCareCCS (map getLit lits) [] [] [] } } + -- arrays of closures required for the CHARLIKE & INTLIKE arrays + +lits :: { [CmmParse CmmExpr] } + : {- empty -} { [] } + | ',' expr lits { $2 : $3 } + +cmmproc :: { CmmParse () } + : info maybe_conv maybe_formals maybe_body + { do ((entry_ret_label, info, stk_formals, formals), agraph) <- + getCodeScoped $ loopDecls $ do { + (entry_ret_label, info, stk_formals) <- $1; + dflags <- getDynFlags; + formals <- sequence (fromMaybe [] $3); + withName (showSDoc dflags (ppr entry_ret_label)) + $4; + return (entry_ret_label, info, stk_formals, formals) } + let do_layout = isJust $3 + code (emitProcWithStackFrame $2 info + entry_ret_label stk_formals formals agraph + do_layout ) } + +maybe_conv :: { Convention } + : {- empty -} { NativeNodeCall } + | 'return' { NativeReturn } + +maybe_body :: { CmmParse () } + : ';' { return () } + | '{' body '}' { withSourceNote $1 $3 $2 } + +info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } + : NAME + {% liftP . withHomeUnitId $ \pkg -> + do newFunctionName $1 pkg + return (mkCmmCodeLabel pkg $1, Nothing, []) } + + + | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, closure type, description, type + {% liftP . withHomeUnitId $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $11 $13 + rep = mkRTSRep (fromIntegral $9) $ + mkHeapRep dflags False (fromIntegral $5) + (fromIntegral $7) Thunk + -- not really Thunk, but that makes the info table + -- we want. + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []) } + + | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' + -- ptrs, nptrs, closure type, description, type, fun type + {% liftP . withHomeUnitId $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $11 $13 + ty = Fun 0 (ArgSpec (fromIntegral $15)) + -- Arity zero, arg_type $15 + rep = mkRTSRep (fromIntegral $9) $ + mkHeapRep dflags False (fromIntegral $5) + (fromIntegral $7) ty + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []) } + -- we leave most of the fields zero here. This is only used + -- to generate the BCO info table in the RTS at the moment. + + | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, tag, closure type, description, type + {% liftP . withHomeUnitId $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $13 $15 + ty = Constr (fromIntegral $9) -- Tag + (BS8.pack $13) + rep = mkRTSRep (fromIntegral $11) $ + mkHeapRep dflags False (fromIntegral $5) + (fromIntegral $7) ty + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing }, + []) } + + -- If profiling is on, this string gets duplicated, + -- but that's the way the old code did it we can fix it some other time. + + | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' + -- selector, closure type, description, type + {% liftP . withHomeUnitId $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $9 $11 + ty = ThunkSelector (fromIntegral $5) + rep = mkRTSRep (fromIntegral $7) $ + mkHeapRep dflags False 0 0 ty + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ')' + -- closure type (no live regs) + {% liftP . withHomeUnitId $ \pkg -> + do let prof = NoProfilingInfo + rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] + return (mkCmmRetLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' + -- closure type, live regs + {% liftP . withHomeUnitId $ \pkg -> + do dflags <- getDynFlags + let platform = targetPlatform dflags + live <- sequence $7 + let prof = NoProfilingInfo + -- drop one for the info pointer + bitmap = mkLiveness platform (drop 1 live) + rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap + return (mkCmmRetLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + live) } + +body :: { CmmParse () } + : {- empty -} { return () } + | decl body { do $1; $2 } + | stmt body { do $1; $2 } + +decl :: { CmmParse () } + : type names ';' { mapM_ (newLocal $1) $2 } + | 'import' importNames ';' { mapM_ newImport $2 } + | 'export' names ';' { return () } -- ignore exports + + +-- an imported function name, with optional packageId +importNames + :: { [(FastString, CLabel)] } + : importName { [$1] } + | importName ',' importNames { $1 : $3 } + +importName + :: { (FastString, CLabel) } + + -- A label imported without an explicit packageId. + -- These are taken to come from some foreign, unnamed package. + : NAME + { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } + + -- as previous 'NAME', but 'IsData' + | 'CLOSURE' NAME + { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) } + + -- A label imported with an explicit UnitId. + | STRING NAME + { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) } + + +names :: { [FastString] } + : NAME { [$1] } + | NAME ',' names { $1 : $3 } + +stmt :: { CmmParse () } + : ';' { return () } + + | NAME ':' + { do l <- newLabel $1; emitLabel l } + + + + | lreg '=' expr ';' + { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) } + | type '[' expr ']' '=' expr ';' + { withSourceNote $2 $7 (doStore $1 $3 $6) } + + -- Gah! We really want to say "foreign_results" but that causes + -- a shift/reduce conflict with assignment. We either + -- we expand out the no-result and single result cases or + -- we tweak the syntax to avoid the conflict. The later + -- option is taken here because the other way would require + -- multiple levels of expanding and get unwieldy. + | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';' + {% foreignCall $3 $1 $4 $6 $8 $9 } + | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';' + {% primCall $1 $4 $6 } + -- stmt-level macros, stealing syntax from ordinary C-- function calls. + -- Perhaps we ought to use the %%-form? + | NAME '(' exprs0 ')' ';' + {% stmtMacro $1 $3 } + | 'switch' maybe_range expr '{' arms default '}' + { do as <- sequence $5; doSwitch $2 $3 as $6 } + | 'goto' NAME ';' + { do l <- lookupLabel $2; emit (mkBranch l) } + | 'return' '(' exprs0 ')' ';' + { doReturn $3 } + | 'jump' expr vols ';' + { doRawJump $2 $3 } + | 'jump' expr '(' exprs0 ')' ';' + { doJumpWithStack $2 [] $4 } + | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';' + { doJumpWithStack $2 $4 $7 } + | 'call' expr '(' exprs0 ')' ';' + { doCall $2 [] $4 } + | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';' + { doCall $6 $2 $8 } + | 'if' bool_expr cond_likely 'goto' NAME + { do l <- lookupLabel $5; cmmRawIf $2 l $3 } + | 'if' bool_expr cond_likely '{' body '}' else + { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 } + | 'push' '(' exprs0 ')' maybe_body + { pushStackFrame $3 $5 } + | 'reserve' expr '=' lreg maybe_body + { reserveStackFrame $2 $4 $5 } + | 'unwind' unwind_regs ';' + { $2 >>= code . emitUnwind } + +unwind_regs + :: { CmmParse [(GlobalReg, Maybe CmmExpr)] } + : GLOBALREG '=' expr_or_unknown ',' unwind_regs + { do e <- $3; rest <- $5; return (($1, e) : rest) } + | GLOBALREG '=' expr_or_unknown + { do e <- $3; return [($1, e)] } + +-- | Used by unwind to indicate unknown unwinding values. +expr_or_unknown + :: { CmmParse (Maybe CmmExpr) } + : 'return' + { do return Nothing } + | expr + { do e <- $1; return (Just e) } + +foreignLabel :: { CmmParse CmmExpr } + : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) } + +opt_never_returns :: { CmmReturnInfo } + : { CmmMayReturn } + | 'never' 'returns' { CmmNeverReturns } + +bool_expr :: { CmmParse BoolExpr } + : bool_op { $1 } + | expr { do e <- $1; return (BoolTest e) } + +bool_op :: { CmmParse BoolExpr } + : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolAnd e1 e2) } + | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolOr e1 e2) } + | '!' bool_expr { do e <- $2; return (BoolNot e) } + | '(' bool_op ')' { $2 } + +safety :: { Safety } + : {- empty -} { PlayRisky } + | STRING {% parseSafety $1 } + +vols :: { [GlobalReg] } + : '[' ']' { [] } + | '[' '*' ']' {% do df <- getDynFlags + ; return (realArgRegsCover df) } + -- All of them. See comment attached + -- to realArgRegsCover + | '[' globals ']' { $2 } + +globals :: { [GlobalReg] } + : GLOBALREG { [$1] } + | GLOBALREG ',' globals { $1 : $3 } + +maybe_range :: { Maybe (Integer,Integer) } + : '[' INT '..' INT ']' { Just ($2, $4) } + | {- empty -} { Nothing } + +arms :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] } + : {- empty -} { [] } + | arm arms { $1 : $2 } + +arm :: { CmmParse ([Integer],Either BlockId (CmmParse ())) } + : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } + +arm_body :: { CmmParse (Either BlockId (CmmParse ())) } + : '{' body '}' { return (Right (withSourceNote $1 $3 $2)) } + | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } + +ints :: { [Integer] } + : INT { [ $1 ] } + | INT ',' ints { $1 : $3 } + +default :: { Maybe (CmmParse ()) } + : 'default' ':' '{' body '}' { Just (withSourceNote $3 $5 $4) } + -- taking a few liberties with the C-- syntax here; C-- doesn't have + -- 'default' branches + | {- empty -} { Nothing } + +-- Note: OldCmm doesn't support a first class 'else' statement, though +-- CmmNode does. +else :: { CmmParse () } + : {- empty -} { return () } + | 'else' '{' body '}' { withSourceNote $2 $4 $3 } + +cond_likely :: { Maybe Bool } + : '(' 'likely' ':' 'True' ')' { Just True } + | '(' 'likely' ':' 'False' ')' { Just False } + | {- empty -} { Nothing } + + +-- we have to write this out longhand so that Happy's precedence rules +-- can kick in. +expr :: { CmmParse CmmExpr } + : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] } + | expr '*' expr { mkMachOp MO_Mul [$1,$3] } + | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] } + | expr '-' expr { mkMachOp MO_Sub [$1,$3] } + | expr '+' expr { mkMachOp MO_Add [$1,$3] } + | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] } + | expr '<<' expr { mkMachOp MO_Shl [$1,$3] } + | expr '&' expr { mkMachOp MO_And [$1,$3] } + | expr '^' expr { mkMachOp MO_Xor [$1,$3] } + | expr '|' expr { mkMachOp MO_Or [$1,$3] } + | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] } + | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] } + | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] } + | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] } + | expr '!=' expr { mkMachOp MO_Ne [$1,$3] } + | expr '==' expr { mkMachOp MO_Eq [$1,$3] } + | '~' expr { mkMachOp MO_Not [$2] } + | '-' expr { mkMachOp MO_S_Neg [$2] } + | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ; + return (mkMachOp mo [$1,$5]) } } + | expr0 { $1 } + +expr0 :: { CmmParse CmmExpr } + : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } + | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } + | STRING { do s <- code (newStringCLit $1); + return (CmmLit s) } + | reg { $1 } + | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } + | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } + | '(' expr ')' { $2 } + + +-- leaving out the type of a literal gives you the native word size in C-- +maybe_ty :: { CmmType } + : {- empty -} {% do dflags <- getDynFlags; return $ bWord (targetPlatform dflags) } + | '::' type { $2 } + +cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] } + : {- empty -} { [] } + | cmm_hint_exprs { $1 } + +cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] } + : cmm_hint_expr { [$1] } + | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } + +cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) } + : expr { do e <- $1; + return (e, inferCmmHint e) } + | expr STRING {% do h <- parseCmmHint $2; + return $ do + e <- $1; return (e, h) } + +exprs0 :: { [CmmParse CmmExpr] } + : {- empty -} { [] } + | exprs { $1 } + +exprs :: { [CmmParse CmmExpr] } + : expr { [ $1 ] } + | expr ',' exprs { $1 : $3 } + +reg :: { CmmParse CmmExpr } + : NAME { lookupName $1 } + | GLOBALREG { return (CmmReg (CmmGlobal $1)) } + +foreign_results :: { [CmmParse (LocalReg, ForeignHint)] } + : {- empty -} { [] } + | '(' foreign_formals ')' '=' { $2 } + +foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] } + : foreign_formal { [$1] } + | foreign_formal ',' { [$1] } + | foreign_formal ',' foreign_formals { $1 : $3 } + +foreign_formal :: { CmmParse (LocalReg, ForeignHint) } + : local_lreg { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) } + | STRING local_lreg {% do h <- parseCmmHint $1; + return $ do + e <- $2; return (e,h) } + +local_lreg :: { CmmParse LocalReg } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg (CmmLocal r) -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } + +lreg :: { CmmParse CmmReg } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg r -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } + | GLOBALREG { return (CmmGlobal $1) } + +maybe_formals :: { Maybe [CmmParse LocalReg] } + : {- empty -} { Nothing } + | '(' formals0 ')' { Just $2 } + +formals0 :: { [CmmParse LocalReg] } + : {- empty -} { [] } + | formals { $1 } + +formals :: { [CmmParse LocalReg] } + : formal ',' { [$1] } + | formal { [$1] } + | formal ',' formals { $1 : $3 } + +formal :: { CmmParse LocalReg } + : type NAME { newLocal $1 $2 } + +type :: { CmmType } + : 'bits8' { b8 } + | typenot8 { $1 } + +typenot8 :: { CmmType } + : 'bits16' { b16 } + | 'bits32' { b32 } + | 'bits64' { b64 } + | 'bits128' { b128 } + | 'bits256' { b256 } + | 'bits512' { b512 } + | 'float32' { f32 } + | 'float64' { f64 } + | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord (targetPlatform dflags) } + +{ +section :: String -> SectionType +section "text" = Text +section "data" = Data +section "rodata" = ReadOnlyData +section "relrodata" = RelocatableReadOnlyData +section "bss" = UninitialisedData +section s = OtherSection s + +mkString :: String -> CmmStatic +mkString s = CmmString (BS8.pack s) + +-- mkMachOp infers the type of the MachOp from the type of its first +-- argument. We assume that this is correct: for MachOps that don't have +-- symmetrical args (e.g. shift ops), the first arg determines the type of +-- the op. +mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr +mkMachOp fn args = do + dflags <- getDynFlags + let platform = targetPlatform dflags + arg_exprs <- sequence args + return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs) + +getLit :: CmmExpr -> CmmLit +getLit (CmmLit l) = l +getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r +getLit _ = panic "invalid literal" -- TODO messy failure + +nameToMachOp :: FastString -> PD (Width -> MachOp) +nameToMachOp name = + case lookupUFM machOps name of + Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name) + Just m -> return m + +exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) +exprOp name args_code = do + dflags <- getDynFlags + case lookupUFM (exprMacros dflags) name of + Just f -> return $ do + args <- sequence args_code + return (f args) + Nothing -> do + mo <- nameToMachOp name + return $ mkMachOp mo args_code + +exprMacros :: DynFlags -> UniqFM FastString ([CmmExpr] -> CmmExpr) +exprMacros dflags = listToUFM [ + ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), + ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), + ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr dflags x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), + ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), + ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) + ] + where platform = targetPlatform dflags + +-- we understand a subset of C-- primitives: +machOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "add", MO_Add ), + ( "sub", MO_Sub ), + ( "eq", MO_Eq ), + ( "ne", MO_Ne ), + ( "mul", MO_Mul ), + ( "neg", MO_S_Neg ), + ( "quot", MO_S_Quot ), + ( "rem", MO_S_Rem ), + ( "divu", MO_U_Quot ), + ( "modu", MO_U_Rem ), + + ( "ge", MO_S_Ge ), + ( "le", MO_S_Le ), + ( "gt", MO_S_Gt ), + ( "lt", MO_S_Lt ), + + ( "geu", MO_U_Ge ), + ( "leu", MO_U_Le ), + ( "gtu", MO_U_Gt ), + ( "ltu", MO_U_Lt ), + + ( "and", MO_And ), + ( "or", MO_Or ), + ( "xor", MO_Xor ), + ( "com", MO_Not ), + ( "shl", MO_Shl ), + ( "shrl", MO_U_Shr ), + ( "shra", MO_S_Shr ), + + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), + ( "lobits16", flip MO_UU_Conv W16 ), + ( "lobits32", flip MO_UU_Conv W32 ), + ( "lobits64", flip MO_UU_Conv W64 ), + + ( "zx16", flip MO_UU_Conv W16 ), + ( "zx32", flip MO_UU_Conv W32 ), + ( "zx64", flip MO_UU_Conv W64 ), + + ( "sx16", flip MO_SS_Conv W16 ), + ( "sx32", flip MO_SS_Conv W32 ), + ( "sx64", flip MO_SS_Conv W64 ), + + ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode + ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode + ( "f2i8", flip MO_FS_Conv W8 ), + ( "f2i16", flip MO_FS_Conv W16 ), + ( "f2i32", flip MO_FS_Conv W32 ), + ( "f2i64", flip MO_FS_Conv W64 ), + ( "i2f32", flip MO_SF_Conv W32 ), + ( "i2f64", flip MO_SF_Conv W64 ) + ] + +callishMachOps :: UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr])) +callishMachOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "read_barrier", (MO_ReadBarrier,)), + ( "write_barrier", (MO_WriteBarrier,)), + ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), + ( "memset", memcpyLikeTweakArgs MO_Memset ), + ( "memmove", memcpyLikeTweakArgs MO_Memmove ), + ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), + + ("prefetch0", (MO_Prefetch_Data 0,)), + ("prefetch1", (MO_Prefetch_Data 1,)), + ("prefetch2", (MO_Prefetch_Data 2,)), + ("prefetch3", (MO_Prefetch_Data 3,)), + + ( "popcnt8", (MO_PopCnt W8,)), + ( "popcnt16", (MO_PopCnt W16,)), + ( "popcnt32", (MO_PopCnt W32,)), + ( "popcnt64", (MO_PopCnt W64,)), + + ( "pdep8", (MO_Pdep W8,)), + ( "pdep16", (MO_Pdep W16,)), + ( "pdep32", (MO_Pdep W32,)), + ( "pdep64", (MO_Pdep W64,)), + + ( "pext8", (MO_Pext W8,)), + ( "pext16", (MO_Pext W16,)), + ( "pext32", (MO_Pext W32,)), + ( "pext64", (MO_Pext W64,)), + + ( "cmpxchg8", (MO_Cmpxchg W8,)), + ( "cmpxchg16", (MO_Cmpxchg W16,)), + ( "cmpxchg32", (MO_Cmpxchg W32,)), + ( "cmpxchg64", (MO_Cmpxchg W64,)), + + ( "xchg8", (MO_Xchg W8,)), + ( "xchg16", (MO_Xchg W16,)), + ( "xchg32", (MO_Xchg W32,)), + ( "xchg64", (MO_Xchg W64,)) + + -- ToDo: the rest, maybe + -- edit: which rest? + -- also: how do we tell CMM Lint how to type check callish macops? + ] + where + memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) + memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" + memcpyLikeTweakArgs op args@(_:_) = + (op align, args') + where + args' = init args + align = case last args of + CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger + e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e) + -- The alignment of memcpy-ish operations must be a + -- compile-time constant. We verify this here, passing it around + -- in the MO_* constructor. In order to do this, however, we + -- must intercept the arguments in primCall. + +parseSafety :: String -> PD Safety +parseSafety "safe" = return PlaySafe +parseSafety "unsafe" = return PlayRisky +parseSafety "interruptible" = return PlayInterruptible +parseSafety str = failMsgPD ("unrecognised safety: " ++ str) + +parseCmmHint :: String -> PD ForeignHint +parseCmmHint "ptr" = return AddrHint +parseCmmHint "signed" = return SignedHint +parseCmmHint str = failMsgPD ("unrecognised hint: " ++ str) + +-- labels are always pointers, so we might as well infer the hint +inferCmmHint :: CmmExpr -> ForeignHint +inferCmmHint (CmmLit (CmmLabel _)) = AddrHint +inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint +inferCmmHint _ = NoHint + +isPtrGlobalReg Sp = True +isPtrGlobalReg SpLim = True +isPtrGlobalReg Hp = True +isPtrGlobalReg HpLim = True +isPtrGlobalReg CCCS = True +isPtrGlobalReg CurrentTSO = True +isPtrGlobalReg CurrentNursery = True +isPtrGlobalReg (VanillaReg _ VGcPtr) = True +isPtrGlobalReg _ = False + +happyError :: PD a +happyError = PD $ \_ s -> unP srcParseFail s + +-- ----------------------------------------------------------------------------- +-- Statement-level macros + +stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) +stmtMacro fun args_code = do + case lookupUFM stmtMacros fun of + Nothing -> failMsgPD ("unknown macro: " ++ unpackFS fun) + Just fcode -> return $ do + args <- sequence args_code + code (fcode args) + +stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ()) +stmtMacros = listToUFM [ + ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), + + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), + ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), + + -- completely generic heap and stack checks, for use in high-level cmm. + ( fsLit "HP_CHK_GEN", \[bytes] -> + heapStackCheckGen Nothing (Just bytes) ), + ( fsLit "STK_CHK_GEN", \[] -> + heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), + + -- A stack check for a fixed amount of stack. Sounds a bit strange, but + -- we use the stack for a bit of temporary storage in a couple of primops + ( fsLit "STK_CHK_GEN_N", \[bytes] -> + heapStackCheckGen (Just bytes) Nothing ), + + -- A stack check on entry to a thunk, where the argument is the thunk pointer. + ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), + + ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), + ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + + ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ), + ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ), + + ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), + ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), + + ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "SET_HDR", \[ptr,info,ccs] -> + emitSetDynHdr ptr info ccs ), + ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> + tickyAllocPrim hdr goods slop ), + ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> + tickyAllocPAP goods slop ), + ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> + tickyAllocThunk goods slop ), + ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) + ] + +emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushUpdateFrame sp e = do + dflags <- getDynFlags + emitUpdateFrame dflags sp mkUpdInfoLabel e + +pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () +pushStackFrame fields body = do + dflags <- getDynFlags + exprs <- sequence fields + updfr_off <- getUpdFrameOff + let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old + [] updfr_off exprs + emit g + withUpdFrameOff new_updfr_off body + +reserveStackFrame + :: CmmParse CmmExpr + -> CmmParse CmmReg + -> CmmParse () + -> CmmParse () +reserveStackFrame psize preg body = do + dflags <- getDynFlags + let platform = targetPlatform dflags + old_updfr_off <- getUpdFrameOff + reg <- preg + esize <- psize + let size = case constantFoldExpr platform esize of + CmmLit (CmmInt n _) -> n + _other -> pprPanic "CmmParse: not a compile-time integer: " + (ppr esize) + let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size + emitAssign reg (CmmStackSlot Old frame) + withUpdFrameOff frame body + +profilingInfo dflags desc_str ty_str + = if not (sccProfilingEnabled dflags) + then NoProfilingInfo + else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) + +staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure pkg cl_label info payload + = do dflags <- getDynFlags + let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] + code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits + +foreignCall + :: String + -> [CmmParse (LocalReg, ForeignHint)] + -> CmmParse CmmExpr + -> [CmmParse (CmmExpr, ForeignHint)] + -> Safety + -> CmmReturnInfo + -> PD (CmmParse ()) +foreignCall conv_string results_code expr_code args_code safety ret + = do conv <- case conv_string of + "C" -> return CCallConv + "stdcall" -> return StdCallConv + _ -> failMsgPD ("unknown calling convention: " ++ conv_string) + return $ do + dflags <- getDynFlags + results <- sequence results_code + expr <- expr_code + args <- sequence args_code + let + platform = targetPlatform dflags + expr' = adjCallTarget platform conv expr args + (arg_exprs, arg_hints) = unzip args + (res_regs, res_hints) = unzip results + fc = ForeignConvention conv arg_hints res_hints ret + target = ForeignTarget expr' fc + _ <- code $ emitForeignCall safety res_regs target arg_exprs + return () + + +doReturn :: [CmmParse CmmExpr] -> CmmParse () +doReturn exprs_code = do + dflags <- getDynFlags + exprs <- sequence exprs_code + updfr_off <- getUpdFrameOff + emit (mkReturnSimple dflags exprs updfr_off) + +mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple dflags actuals updfr_off = + mkReturn dflags e actuals updfr_off + where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off) + (gcWord platform)) + platform = targetPlatform dflags + +doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () +doRawJump expr_code vols = do + dflags <- getDynFlags + expr <- expr_code + updfr_off <- getUpdFrameOff + emit (mkRawJump dflags expr updfr_off vols) + +doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] + -> [CmmParse CmmExpr] -> CmmParse () +doJumpWithStack expr_code stk_code args_code = do + dflags <- getDynFlags + expr <- expr_code + stk_args <- sequence stk_code + args <- sequence args_code + updfr_off <- getUpdFrameOff + emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args) + +doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] + -> CmmParse () +doCall expr_code res_code args_code = do + expr <- expr_code + args <- sequence args_code + ress <- sequence res_code + updfr_off <- getUpdFrameOff + c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] + emit c + +adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] + -> CmmExpr +-- On Windows, we have to add the '@N' suffix to the label when making +-- a call with the stdcall calling convention. +adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args + | platformOS platform == OSMinGW32 + = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) + where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e))) + -- c.f. CgForeignCall.emitForeignCall +adjCallTarget _ _ expr _ + = expr + +primCall + :: [CmmParse (CmmFormal, ForeignHint)] + -> FastString + -> [CmmParse CmmExpr] + -> PD (CmmParse ()) +primCall results_code name args_code + = case lookupUFM callishMachOps name of + Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name) + Just f -> return $ do + results <- sequence results_code + args <- sequence args_code + let (p, args') = f args + code (emitPrimCall (map fst results) p args') + +doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () +doStore rep addr_code val_code + = do dflags <- getDynFlags + addr <- addr_code + val <- val_code + -- if the specified store type does not match the type of the expr + -- on the rhs, then we insert a coercion that will cause the type + -- mismatch to be flagged by cmm-lint. If we don't do this, then + -- the store will happen at the wrong type, and the error will not + -- be noticed. + let val_width = typeWidth (cmmExprType platform val) + rep_width = typeWidth rep + platform = targetPlatform dflags + let coerce_val + | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] + | otherwise = val + emitStore addr coerce_val + +-- ----------------------------------------------------------------------------- +-- If-then-else and boolean expressions + +data BoolExpr + = BoolExpr `BoolAnd` BoolExpr + | BoolExpr `BoolOr` BoolExpr + | BoolNot BoolExpr + | BoolTest CmmExpr + +-- ToDo: smart constructors which simplify the boolean expression. + +cmmIfThenElse cond then_part else_part likely = do + then_id <- newBlockId + join_id <- newBlockId + c <- cond + emitCond c then_id likely + else_part + emit (mkBranch join_id) + emitLabel then_id + then_part + -- fall through to join + emitLabel join_id + +cmmRawIf cond then_id likely = do + c <- cond + emitCond c then_id likely + +-- 'emitCond cond true_id' emits code to test whether the cond is true, +-- branching to true_id if so, and falling through otherwise. +emitCond (BoolTest e) then_id likely = do + else_id <- newBlockId + emit (mkCbranch e then_id else_id likely) + emitLabel else_id +emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely + | Just op' <- maybeInvertComparison op + = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely) +emitCond (BoolNot e) then_id likely = do + else_id <- newBlockId + emitCond e else_id likely + emit (mkBranch then_id) + emitLabel else_id +emitCond (e1 `BoolOr` e2) then_id likely = do + emitCond e1 then_id likely + emitCond e2 then_id likely +emitCond (e1 `BoolAnd` e2) then_id likely = do + -- we'd like to invert one of the conditionals here to avoid an + -- extra branch instruction, but we can't use maybeInvertComparison + -- here because we can't look too closely at the expression since + -- we're in a loop. + and_id <- newBlockId + else_id <- newBlockId + emitCond e1 and_id likely + emit (mkBranch else_id) + emitLabel and_id + emitCond e2 then_id likely + emitLabel else_id + +-- ----------------------------------------------------------------------------- +-- Source code notes + +-- | Generate a source note spanning from "a" to "b" (inclusive), then +-- proceed with parsing. This allows debugging tools to reason about +-- locations in Cmm code. +withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c +withSourceNote a b parse = do + name <- getName + case combineSrcSpans (getLoc a) (getLoc b) of + RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse + _other -> parse + +-- ----------------------------------------------------------------------------- +-- Table jumps + +-- We use a simplified form of C-- switch statements for now. A +-- switch statement always compiles to a table jump. Each arm can +-- specify a list of values (not ranges), and there can be a single +-- default branch. The range of the table is given either by the +-- optional range on the switch (eg. switch [0..7] {...}), or by +-- the minimum/maximum values from the branches. + +doSwitch :: Maybe (Integer,Integer) + -> CmmParse CmmExpr + -> [([Integer],Either BlockId (CmmParse ()))] + -> Maybe (CmmParse ()) -> CmmParse () +doSwitch mb_range scrut arms deflt + = do + -- Compile code for the default branch + dflt_entry <- + case deflt of + Nothing -> return Nothing + Just e -> do b <- forkLabelledCode e; return (Just b) + + -- Compile each case branch + table_entries <- mapM emitArm arms + let table = M.fromList (concat table_entries) + + dflags <- getDynFlags + let platform = targetPlatform dflags + let range = fromMaybe (0, platformMaxWord platform) mb_range + + expr <- scrut + -- ToDo: check for out of range and jump to default if necessary + emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table) + where + emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do + blockid <- forkLabelledCode code + return [ (i,blockid) | i <- ints ] + +forkLabelledCode :: CmmParse () -> CmmParse BlockId +forkLabelledCode p = do + (_,ag) <- getCodeScoped p + l <- newBlockId + emitOutOfLine l ag + return l + +-- ----------------------------------------------------------------------------- +-- Putting it all together + +-- The initial environment: we define some constants that the compiler +-- knows about here. +initEnv :: DynFlags -> Env +initEnv dflags = listToUFM [ + ( fsLit "SIZEOF_StgHeader", + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth platform)) )), + ( fsLit "SIZEOF_StgInfoTable", + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth platform)) )) + ] + where platform = targetPlatform dflags + +parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) +parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do + buf <- hGetStringBuffer filename + let + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 + init_state = (mkPState dflags buf init_loc) { lex_state = [0] } + -- reset the lex_state: the Lexer monad leaves some stuff + -- in there we don't want. + case unPD cmmParse dflags init_state of + PFailed pst -> + return (getMessages pst dflags, Nothing) + POk pst code -> do + st <- initC + let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return () + (cmm,_) = runC dflags no_module st fcode + let ms = getMessages pst dflags + if (errorsFound dflags ms) + then return (ms, Nothing) + else return (ms, Just cmm) + where + no_module = panic "parseCmmFile: no module" +} diff --git a/GHC/Cmm/Pipeline.hs b/GHC/Cmm/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Pipeline.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Cmm.Pipeline ( + -- | Converts C-- with an implicit stack and native C-- calls into + -- optimized, CPS converted and native-call-less C--. The latter + -- C-- can be used to generate assembly. + cmmPipeline +) where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Cmm.Lint +import GHC.Cmm.Info.Build +import GHC.Cmm.CommonBlockElim +import GHC.Cmm.Switch.Implement +import GHC.Cmm.ProcPoint +import GHC.Cmm.ContFlowOpt +import GHC.Cmm.LayoutStack +import GHC.Cmm.Sink +import GHC.Cmm.Dataflow.Collections + +import GHC.Types.Unique.Supply +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Driver.Types +import Control.Monad +import GHC.Utils.Outputable +import GHC.Platform +import Data.Either (partitionEithers) + +----------------------------------------------------------------------------- +-- | Top level driver for C-- pipeline +----------------------------------------------------------------------------- + +cmmPipeline + :: HscEnv -- Compilation env including + -- dynamic flags: -dcmm-lint -ddump-cmm-cps + -> ModuleSRTInfo -- Info about SRTs generated so far + -> CmmGroup -- Input C-- with Procedures + -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- + +cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ + do let dflags = hsc_dflags hsc_env + + tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog + + let (procs, data_) = partitionEithers tops + (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ + dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms) + + return (srtInfo, cmms) + + where forceRes (info, group) = + info `seq` foldr (\decl r -> decl `seq` r) () group + + dflags = hsc_dflags hsc_env + +cpsTop :: HscEnv -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) +cpsTop _ p@(CmmData _ statics) = return (Right (cafAnalData statics, p)) +cpsTop hsc_env proc = + do + ----------- Control-flow optimisations ---------------------------------- + + -- The first round of control-flow optimisation speeds up the + -- later passes by removing lots of empty blocks, so we do it + -- even when optimisation isn't turned on. + -- + CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} + return $ cmmCfgOptsProc splitting_proc_points proc + dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g + + let !TopInfo {stack_info=StackInfo { arg_space = entry_off + , do_layout = do_layout }} = h + + ----------- Eliminate common blocks ------------------------------------- + g <- {-# SCC "elimCommonBlocks" #-} + condPass Opt_CmmElimCommonBlocks elimCommonBlocks g + Opt_D_dump_cmm_cbe "Post common block elimination" + + -- Any work storing block Labels must be performed _after_ + -- elimCommonBlocks + + ----------- Implement switches ------------------------------------------ + g <- {-# SCC "createSwitchPlans" #-} + runUniqSM $ cmmImplementSwitchPlans dflags g + dump Opt_D_dump_cmm_switch "Post switch plan" g + + ----------- Proc points ------------------------------------------------- + let + call_pps :: ProcPointSet -- LabelMap + call_pps = {-# SCC "callProcPoints" #-} callProcPoints g + proc_points <- + if splitting_proc_points + then do + pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ + minimalProcPointSet (targetPlatform dflags) call_pps g + dumpWith dflags Opt_D_dump_cmm_proc "Proc points" + FormatCMM (ppr l $$ ppr pp $$ ppr g) + return pp + else + return call_pps + + ----------- Layout the stack and manifest Sp ---------------------------- + (g, stackmaps) <- + {-# SCC "layoutStack" #-} + if do_layout + then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g + else return (g, mapEmpty) + dump Opt_D_dump_cmm_sp "Layout Stack" g + + ----------- Sink and inline assignments -------------------------------- + g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] + condPass Opt_CmmSink (cmmSink dflags) g + Opt_D_dump_cmm_sink "Sink assignments" + + ------------- CAF analysis ---------------------------------------------- + let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g + dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv) + + g <- if splitting_proc_points + then do + ------------- Split into separate procedures ----------------------- + let pp_map = {-# SCC "procPointAnalysis" #-} + procPointAnalysis proc_points g + dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" + FormatCMM (ppr pp_map) + g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ + splitAtProcPoints dflags l call_pps proc_points pp_map + (CmmProc h l v g) + dumps Opt_D_dump_cmm_split "Post splitting" g + return g + else do + -- attach info tables to return points + return $ [attachContInfoTables call_pps (CmmProc h l v g)] + + ------------- Populate info tables with stack info ----------------- + g <- {-# SCC "setInfoTableStackMap" #-} + return $ map (setInfoTableStackMap platform stackmaps) g + dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g + + ----------- Control-flow optimisations ----------------------------- + g <- {-# SCC "cmmCfgOpts(2)" #-} + return $ if optLevel dflags >= 1 + then map (cmmCfgOptsProc splitting_proc_points) g + else g + g <- return (map removeUnreachableBlocksProc g) + -- See Note [unreachable blocks] + dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g + + return (Left (cafEnv, g)) + + where dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + dump = dumpGraph dflags + + dumps flag name + = mapM_ (dumpWith dflags flag name FormatCMM . ppr) + + condPass flag pass g dumpflag dumpname = + if gopt flag dflags + then do + g <- return $ pass g + dump dumpflag dumpname g + return g + else return g + + -- we don't need to split proc points for the NCG, unless + -- tablesNextToCode is off. The latter is because we have no + -- label to put on info tables for basic blocks that are not + -- the entry point. + splitting_proc_points = hscTarget dflags /= HscAsm + || not (platformTablesNextToCode platform) + || -- Note [inconsistent-pic-reg] + usingInconsistentPicReg + usingInconsistentPicReg + = case (platformArch platform, platformOS platform, positionIndependent dflags) + of (ArchX86, OSDarwin, pic) -> pic + _ -> False + +-- Note [Sinking after stack layout] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- In the past we considered running sinking pass also before stack +-- layout, but after making some measurements we realized that: +-- +-- a) running sinking only before stack layout produces slower +-- code than running sinking only before stack layout +-- +-- b) running sinking both before and after stack layout produces +-- code that has the same performance as when running sinking +-- only after stack layout. +-- +-- In other words sinking before stack layout doesn't buy as anything. +-- +-- An interesting question is "why is it better to run sinking after +-- stack layout"? It seems that the major reason are stores and loads +-- generated by stack layout. Consider this code before stack layout: +-- +-- c1E: +-- _c1C::P64 = R3; +-- _c1B::P64 = R2; +-- _c1A::P64 = R1; +-- I64[(young + 8)] = c1D; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- R3 = _c1C::P64; +-- R2 = _c1B::P64; +-- R1 = _c1A::P64; +-- call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- Stack layout pass will save all local variables live across a call +-- (_c1C, _c1B and _c1A in this example) on the stack just before +-- making a call and reload them from the stack after returning from a +-- call: +-- +-- c1E: +-- _c1C::P64 = R3; +-- _c1B::P64 = R2; +-- _c1A::P64 = R1; +-- I64[Sp - 32] = c1D; +-- P64[Sp - 24] = _c1A::P64; +-- P64[Sp - 16] = _c1B::P64; +-- P64[Sp - 8] = _c1C::P64; +-- Sp = Sp - 32; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- _c1A::P64 = P64[Sp + 8]; +-- _c1B::P64 = P64[Sp + 16]; +-- _c1C::P64 = P64[Sp + 24]; +-- R3 = _c1C::P64; +-- R2 = _c1B::P64; +-- R1 = _c1A::P64; +-- Sp = Sp + 32; +-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- If we don't run sinking pass after stack layout we are basically +-- left with such code. However, running sinking on this code can lead +-- to significant improvements: +-- +-- c1E: +-- I64[Sp - 32] = c1D; +-- P64[Sp - 24] = R1; +-- P64[Sp - 16] = R2; +-- P64[Sp - 8] = R3; +-- Sp = Sp - 32; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- R3 = P64[Sp + 24]; +-- R2 = P64[Sp + 16]; +-- R1 = P64[Sp + 8]; +-- Sp = Sp + 32; +-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- Now we only have 9 assignments instead of 15. +-- +-- There is one case when running sinking before stack layout could +-- be beneficial. Consider this: +-- +-- L1: +-- x = y +-- call f() returns L2 +-- L2: ...x...y... +-- +-- Since both x and y are live across a call to f, they will be stored +-- on the stack during stack layout and restored after the call: +-- +-- L1: +-- x = y +-- P64[Sp - 24] = L2 +-- P64[Sp - 16] = x +-- P64[Sp - 8] = y +-- Sp = Sp - 24 +-- call f() returns L2 +-- L2: +-- y = P64[Sp + 16] +-- x = P64[Sp + 8] +-- Sp = Sp + 24 +-- ...x...y... +-- +-- However, if we run sinking before stack layout we would propagate x +-- to its usage place (both x and y must be local register for this to +-- be possible - global registers cannot be floated past a call): +-- +-- L1: +-- x = y +-- call f() returns L2 +-- L2: ...y...y... +-- +-- Thus making x dead at the call to f(). If we ran stack layout now +-- we would generate less stores and loads: +-- +-- L1: +-- x = y +-- P64[Sp - 16] = L2 +-- P64[Sp - 8] = y +-- Sp = Sp - 16 +-- call f() returns L2 +-- L2: +-- y = P64[Sp + 8] +-- Sp = Sp + 16 +-- ...y...y... +-- +-- But since we don't see any benefits from running sinking before stack +-- layout, this situation probably doesn't arise too often in practice. +-- + +{- Note [inconsistent-pic-reg] + +On x86/Darwin, PIC is implemented by inserting a sequence like + + call 1f + 1: popl %reg + +at the proc entry point, and then referring to labels as offsets from +%reg. If we don't split proc points, then we could have many entry +points in a proc that would need this sequence, and each entry point +would then get a different value for %reg. If there are any join +points, then at the join point we don't have a consistent value for +%reg, so we don't know how to refer to labels. + +Hence, on x86/Darwin, we have to split proc points, and then each proc +point will get its own PIC initialisation sequence. + +This isn't an issue on x86/ELF, where the sequence is + + call 1f + 1: popl %reg + addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg + +so %reg always has a consistent value: the address of +_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. + +-} + +{- Note [unreachable blocks] + +The control-flow optimiser sometimes leaves unreachable blocks behind +containing junk code. These aren't necessarily a problem, but +removing them is good because it might save time in the native code +generator later. + +-} + +runUniqSM :: UniqSM a -> IO a +runUniqSM m = do + us <- mkSplitUniqSupply 'u' + return (initUs_ us m) + + +dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph dflags flag name g = do + when (gopt Opt_DoCmmLinting dflags) $ do_lint g + dumpWith dflags flag name FormatCMM (ppr g) + where + do_lint g = case cmmLintGraph dflags g of + Just err -> do { fatalErrorMsg dflags err + ; ghcExit dflags 1 + } + Nothing -> return () + +dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpWith dflags flag txt fmt sdoc = do + dumpIfSet_dyn dflags flag txt fmt sdoc + when (not (dopt flag dflags)) $ + -- If `-ddump-cmm-verbose -ddump-to-file` is specified, + -- dump each Cmm pipeline stage output to a separate file. #16930 + when (dopt Opt_D_dump_cmm_verbose dflags) + $ dumpAction dflags (mkDumpStyle alwaysQualify) + (dumpOptionsFromFlag flag) txt fmt sdoc + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/GHC/Cmm/Ppr.hs b/GHC/Cmm/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Ppr.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +---------------------------------------------------------------------------- +-- +-- Pretty-printing of Cmm as (a superset of) C-- +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- +-- +-- This is where we walk over CmmNode emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We +-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs + +module GHC.Cmm.Ppr + ( module GHC.Cmm.Ppr.Decl + , module GHC.Cmm.Ppr.Expr + ) +where + +import GHC.Prelude hiding (succ) + +import GHC.Platform +import GHC.Driver.Session (targetPlatform) +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Cmm.Ppr.Decl +import GHC.Cmm.Ppr.Expr +import GHC.Utils.Misc + +import GHC.Types.Basic +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph + +------------------------------------------------- +-- Outputable instances + +instance Outputable CmmStackInfo where + ppr = pprStackInfo + +instance Outputable CmmTopInfo where + ppr = pprTopInfo + + +instance Outputable (CmmNode e x) where + ppr e = sdocWithDynFlags $ \dflags -> + pprNode (targetPlatform dflags) e + +instance Outputable Convention where + ppr = pprConvention + +instance Outputable ForeignConvention where + ppr = pprForeignConvention + +instance Outputable ForeignTarget where + ppr = pprForeignTarget + +instance Outputable CmmReturnInfo where + ppr = pprReturnInfo + +instance Outputable (Block CmmNode C C) where + ppr = pprBlock +instance Outputable (Block CmmNode C O) where + ppr = pprBlock +instance Outputable (Block CmmNode O C) where + ppr = pprBlock +instance Outputable (Block CmmNode O O) where + ppr = pprBlock + +instance Outputable (Graph CmmNode e x) where + ppr = pprGraph + +instance Outputable CmmGraph where + ppr = pprCmmGraph + +---------------------------------------------------------- +-- Outputting types Cmm contains + +pprStackInfo :: CmmStackInfo -> SDoc +pprStackInfo (StackInfo {arg_space=arg_space}) = + text "arg_space: " <> ppr arg_space + +pprTopInfo :: CmmTopInfo -> SDoc +pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = + vcat [text "info_tbls: " <> ppr info_tbl, + text "stack_info: " <> ppr stack_info] + +---------------------------------------------------------- +-- Outputting blocks and graphs + +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock block + = foldBlockNodesB3 ( ($$) . ppr + , ($$) . (nest 4) . ppr + , ($$) . (nest 4) . ppr + ) + block + empty + +pprGraph :: Graph CmmNode e x -> SDoc +pprGraph GNil = empty +pprGraph (GUnit block) = ppr block +pprGraph (GMany entry body exit) + = text "{" + $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) + $$ text "}" + where pprMaybeO :: Outputable (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc + pprMaybeO NothingO = empty + pprMaybeO (JustO block) = ppr block + +pprCmmGraph :: CmmGraph -> SDoc +pprCmmGraph g + = text "{" <> text "offset" + $$ nest 2 (vcat $ map ppr blocks) + $$ text "}" + where blocks = revPostorder g + -- revPostorder has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. + +--------------------------------------------- +-- Outputting CmmNode and types which it contains + +pprConvention :: Convention -> SDoc +pprConvention (NativeNodeCall {}) = text "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" + +pprForeignConvention :: ForeignConvention -> SDoc +pprForeignConvention (ForeignConvention c args res ret) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret + +pprReturnInfo :: CmmReturnInfo -> SDoc +pprReturnInfo CmmMayReturn = empty +pprReturnInfo CmmNeverReturns = text "never returns" + +pprForeignTarget :: ForeignTarget -> SDoc +pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn + where + ppr_target :: CmmExpr -> SDoc + ppr_target t@(CmmLit _) = ppr t + ppr_target fn' = parens (ppr fn') + +pprForeignTarget (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = ppr + (CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction)) + +pprNode :: Platform -> CmmNode e x -> SDoc +pprNode platform node = pp_node <+> pp_debug + where + pp_node :: SDoc + pp_node = case node of + -- label: + CmmEntry id tscope -> + (sdocOption sdocSuppressUniques $ \case + True -> text "_lbl_" + False -> ppr id + ) + <> colon + <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope) + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- //tick bla<...> + CmmTick t -> ppUnlessOption sdocSuppressTicks + (text "//tick" <+> ppr t) + + -- unwind reg = expr; + CmmUnwind regs -> + text "unwind " + <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + where + rep = ppr ( cmmExprType platform expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmUnsafeForeignCall target results args -> + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + text "call", + ppr target <> parens (commafy $ map ppr args) <> semi] + + -- goto label; + CmmBranch ident -> text "goto" <+> ppr ident <> semi + + -- if (expr) goto t; else goto f; + CmmCondBranch expr t f l -> + hsep [ text "if" + , parens(ppr expr) + , case l of + Nothing -> empty + Just b -> parens (text "likely:" <+> ppr b) + , text "goto" + , ppr t <> semi + , text "else goto" + , ppr f <> semi + ] + + CmmSwitch expr ids -> + hang (hsep [ text "switch" + , range + , if isTrivialCmmExpr expr + then ppr expr + else parens (ppr expr) + , text "{" + ]) + 4 (vcat (map ppCase cases) $$ def) $$ rbrace + where + (cases, mbdef) = switchTargetsFallThrough ids + ppCase (is,l) = hsep + [ text "case" + , commafy $ map integer is + , text ": goto" + , ppr l <> semi + ] + def | Just l <- mbdef = hsep + [ text "default:" + , braces (text "goto" <+> ppr l <> semi) + ] + | otherwise = empty + + range = brackets $ hsep [integer lo, text "..", integer hi] + where (lo,hi) = switchTargetsRange ids + + CmmCall tgt k regs out res updfr_off -> + hcat [ text "call", space + , pprFun tgt, parens (interpp'SP regs), space + , returns <+> + text "args: " <> ppr out <> comma <+> + text "res: " <> ppr res <> comma <+> + text "upd: " <> ppr updfr_off + , semi ] + where pprFun f@(CmmLit _) = ppr f + pprFun f = parens (ppr f) + + returns + | Just r <- k = text "returns to" <+> ppr r <> comma + | otherwise = empty + + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> + hcat $ if i then [text "interruptible", space] else [] ++ + [ text "foreign call", space + , ppr t, text "(...)", space + , text "returns to" <+> ppr s + <+> text "args:" <+> parens (ppr as) + <+> text "ress:" <+> parens (ppr rs) + , text "ret_args:" <+> ppr a + , text "ret_off:" <+> ppr u + , semi ] + + pp_debug :: SDoc + pp_debug = + if not debugIsOn then empty + else case node of + CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" + CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" + CmmTick {} -> empty + CmmUnwind {} -> text " // CmmUnwind" + CmmAssign {} -> text " // CmmAssign" + CmmStore {} -> text " // CmmStore" + CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" + CmmBranch {} -> text " // CmmBranch" + CmmCondBranch {} -> text " // CmmCondBranch" + CmmSwitch {} -> text " // CmmSwitch" + CmmCall {} -> text " // CmmCall" + CmmForeignCall {} -> text " // CmmForeignCall" + + commafy :: [SDoc] -> SDoc + commafy xs = hsep $ punctuate comma xs diff --git a/GHC/Cmm/Ppr/Decl.hs b/GHC/Cmm/Ppr/Decl.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Ppr/Decl.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE GADTs #-} + +---------------------------------------------------------------------------- +-- +-- Pretty-printing of common Cmm types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We +-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.Cmm.Ppr.Decl + ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.Ppr.Expr +import GHC.Cmm + +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Data.FastString + +import Data.List +import System.IO + +import qualified Data.ByteString as BS + + +pprCmms :: (Outputable info, Outputable g) + => [GenCmmGroup RawCmmStatics info g] -> SDoc +pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) + where + separator = space $$ text "-------------------" $$ space + +writeCmms :: (Outputable info, Outputable g) + => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO () +writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms) + +----------------------------------------------------------------------------- + +instance (Outputable d, Outputable info, Outputable i) + => Outputable (GenCmmDecl d info i) where + ppr t = pprTop t + +instance Outputable (GenCmmStatics a) where + ppr = pprStatics + +instance Outputable CmmStatic where + ppr e = sdocWithDynFlags $ \dflags -> + pprStatic (targetPlatform dflags) e + +instance Outputable CmmInfoTable where + ppr = pprInfoTable + + +----------------------------------------------------------------------------- + +pprCmmGroup :: (Outputable d, Outputable info, Outputable g) + => GenCmmGroup d info g -> SDoc +pprCmmGroup tops + = vcat $ intersperse blankLine $ map pprTop tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. +-- +pprTop :: (Outputable d, Outputable info, Outputable i) + => GenCmmDecl d info i -> SDoc + +pprTop (CmmProc info lbl live graph) + + = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live + , nest 8 $ lbrace <+> ppr info $$ rbrace + , nest 4 $ ppr graph + , rbrace ] + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- +pprTop (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (ppr ds)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- Info tables. + +pprInfoTable :: CmmInfoTable -> SDoc +pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep + , cit_prof = prof_info + , cit_srt = srt }) + = vcat [ text "label: " <> ppr lbl + , text "rep: " <> ppr rep + , case prof_info of + NoProfilingInfo -> empty + ProfilingInfo ct cd -> + vcat [ text "type: " <> text (show (BS.unpack ct)) + , text "desc: " <> text (show (BS.unpack cd)) ] + , text "srt: " <> ppr srt ] + +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- + +pprStatics :: GenCmmStatics a -> SDoc +pprStatics (CmmStatics lbl itbl ccs payload) = + ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload +pprStatics (CmmStaticsRaw lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) + +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of + CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path) + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Section -> SDoc +pprSection (Section t suffix) = + section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix) + where + section = text "section" + +pprSectionType :: SectionType -> SDoc +pprSectionType s = doubleQuotes (ptext t) + where + t = case s of + Text -> sLit "text" + Data -> sLit "data" + ReadOnlyData -> sLit "readonly" + ReadOnlyData16 -> sLit "readonly16" + RelocatableReadOnlyData + -> sLit "relreadonly" + UninitialisedData -> sLit "uninitialised" + CString -> sLit "cstring" + OtherSection s' -> sLit s' -- Not actually a literal though. diff --git a/GHC/Cmm/Ppr/Expr.hs b/GHC/Cmm/Ppr/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Ppr/Expr.hs @@ -0,0 +1,290 @@ +---------------------------------------------------------------------------- +-- +-- Pretty-printing of common Cmm types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We +-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Cmm.Ppr.Expr + ( pprExpr, pprLit + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Driver.Session (targetPlatform) +import GHC.Cmm.Expr + +import GHC.Utils.Outputable + +import Data.Maybe +import Numeric ( fromRat ) + +----------------------------------------------------------------------------- + +instance Outputable CmmExpr where + ppr e = sdocWithDynFlags $ \dflags -> + pprExpr (targetPlatform dflags) e + +instance Outputable CmmReg where + ppr e = pprReg e + +instance Outputable CmmLit where + ppr l = sdocWithDynFlags $ \dflags -> + pprLit (targetPlatform dflags) l + +instance Outputable LocalReg where + ppr e = pprLocalReg e + +instance Outputable Area where + ppr e = pprArea e + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +-- -------------------------------------------------------------------------- +-- Expressions +-- + +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e + = case e of + CmmRegOff reg i -> + pprExpr platform (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType platform reg) + CmmLit lit -> pprLit platform lit + _other -> pprExpr1 platform e + +-- Here's the precedence table from GHC.Cmm.Parser: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' + +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. + +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp1 op + = pprExpr7 platform x <+> doc <+> pprExpr7 platform y +pprExpr1 platform e = pprExpr7 platform e + +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc + +infixMachOp1 (MO_Eq _) = Just (text "==") +infixMachOp1 (MO_Ne _) = Just (text "!=") +infixMachOp1 (MO_Shl _) = Just (text "<<") +infixMachOp1 (MO_U_Shr _) = Just (text ">>") +infixMachOp1 (MO_U_Ge _) = Just (text ">=") +infixMachOp1 (MO_U_Le _) = Just (text "<=") +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing + +-- %left '-' '+' +pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp7 op + = pprExpr7 platform x <+> doc <+> pprExpr8 platform y +pprExpr7 platform e = pprExpr8 platform e + +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing + +-- %left '/' '*' '%' +pprExpr8 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp8 op + = pprExpr8 platform x <+> doc <+> pprExpr9 platform y +pprExpr8 platform e = pprExpr9 platform e + +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing + +pprExpr9 :: Platform -> CmmExpr -> SDoc +pprExpr9 platform e = + case e of + CmmLit lit -> pprLit1 platform lit + CmmLoad expr rep -> ppr rep <> brackets (ppr expr) + CmmReg reg -> ppr reg + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) + CmmMachOp mop args -> genMachOp platform mop args + +genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc +genMachOp platform mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y + + -- unary + [x] -> doc <> pprExpr9 platform x + + _ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map (pprExpr platform) args))) + empty + + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) + + | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) + where ppr_op = text (map (\c -> if c == ' ' then '_' else c) + (show mop)) + -- replace spaces in (show mop) with underscores, + +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + _ -> Nothing + +-- -------------------------------------------------------------------------- +-- Literals. +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , ppUnless (rep == wordWidth platform) $ + space <> dcolon <+> ppr rep ] + + CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] + CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>' + CmmLabel clbl -> ppr clbl + CmmLabelOff clbl i -> ppr clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-' + <> ppr clbl2 <> ppr_offset i + CmmBlock id -> ppr id + CmmHighStackMark -> text "" + +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) +pprLit1 platform lit = pprLit platform lit + +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) + +-- -------------------------------------------------------------------------- +-- Registers, whether local (temps) or global +-- +pprReg :: CmmReg -> SDoc +pprReg r + = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) = +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + char '_' <> pprUnique uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + pprUnique unique = sdocOption sdocSuppressUniques $ \case + True -> text "_locVar_" + False -> ppr unique + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty + +-- Stack areas +pprArea :: Area -> SDoc +pprArea Old = text "old" +pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] + +-- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg' +-- +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr + = case gr of + VanillaReg n _ -> char 'R' <> int n +-- Temp Jan08 +-- VanillaReg n VNonGcPtr -> char 'R' <> int n +-- VanillaReg n VGcPtr -> char 'P' <> int n + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + XmmReg n -> text "XMM" <> int n + YmmReg n -> text "YMM" <> int n + ZmmReg n -> text "ZMM" <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + MachSp -> text "MachSp" + UnwindReturnReg-> text "UnwindReturnReg" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + BaseReg -> text "BaseReg" + PicBaseReg -> text "PicBaseReg" + +----------------------------------------------------------------------------- + +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs diff --git a/GHC/Cmm/ProcPoint.hs b/GHC/Cmm/ProcPoint.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/ProcPoint.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Cmm.ProcPoint + ( ProcPointSet, Status(..) + , callProcPoints, minimalProcPointSet + , splitAtProcPoints, procPointAnalysis + , attachContInfoTables + ) +where + +import GHC.Prelude hiding (last, unzip, succ, zip) + +import GHC.Driver.Session +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Ppr () -- For Outputable instances +import GHC.Cmm.Utils +import GHC.Cmm.Info +import GHC.Cmm.Liveness +import GHC.Cmm.Switch +import Data.List (sortBy) +import GHC.Data.Maybe +import Control.Monad +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.Supply +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label + +-- Compute a minimal set of proc points for a control-flow graph. + +-- Determine a protocol for each proc point (which live variables will +-- be passed as arguments and which will be on the stack). + +{- +A proc point is a basic block that, after CPS transformation, will +start a new function. The entry block of the original function is a +proc point, as is the continuation of each function call. +A third kind of proc point arises if we want to avoid copying code. +Suppose we have code like the following: + + f() { + if (...) { ..1..; call foo(); ..2..} + else { ..3..; call bar(); ..4..} + x = y + z; + return x; + } + +The statement 'x = y + z' can be reached from two different proc +points: the continuations of foo() and bar(). We would prefer not to +put a copy in each continuation; instead we would like 'x = y + z' to +be the start of a new procedure to which the continuations can jump: + + f_cps () { + if (...) { ..1..; push k_foo; jump foo_cps(); } + else { ..3..; push k_bar; jump bar_cps(); } + } + k_foo() { ..2..; jump k_join(y, z); } + k_bar() { ..4..; jump k_join(y, z); } + k_join(y, z) { x = y + z; return x; } + +You might think then that a criterion to make a node a proc point is +that it is directly reached by two distinct proc points. (Note +[Direct reachability].) But this criterion is a bit too simple; for +example, 'return x' is also reached by two proc points, yet there is +no point in pulling it out of k_join. A good criterion would be to +say that a node should be made a proc point if it is reached by a set +of proc points that is different than its immediate dominator. NR +believes this criterion can be shown to produce a minimum set of proc +points, and given a dominator tree, the proc points can be chosen in +time linear in the number of blocks. Lacking a dominator analysis, +however, we turn instead to an iterative solution, starting with no +proc points and adding them according to these rules: + + 1. The entry block is a proc point. + 2. The continuation of a call is a proc point. + 3. A node is a proc point if it is directly reached by more proc + points than one of its predecessors. + +Because we don't understand the problem very well, we apply rule 3 at +most once per iteration, then recompute the reachability information. +(See Note [No simple dataflow].) The choice of the new proc point is +arbitrary, and I don't know if the choice affects the final solution, +so I don't know if the number of proc points chosen is the +minimum---but the set will be minimal. + + + +Note [Proc-point analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given a specified set of proc-points (a set of block-ids), "proc-point +analysis" figures out, for every block, which proc-point it belongs to. +All the blocks belonging to proc-point P will constitute a single +top-level C procedure. + +A non-proc-point block B "belongs to" a proc-point P iff B is +reachable from P without going through another proc-point. + +Invariant: a block B should belong to at most one proc-point; if it +belongs to two, that's a bug. + +Note [Non-existing proc-points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +On some architectures it might happen that the list of proc-points +computed before stack layout pass will be invalidated by the stack +layout. This will happen if stack layout removes from the graph +blocks that were determined to be proc-points. Later on in the pipeline +we use list of proc-points to perform [Proc-point analysis], but +if a proc-point does not exist anymore then we will get compiler panic. +See #8205. +-} + +type ProcPointSet = LabelSet + +data Status + = ReachedBy ProcPointSet -- set of proc points that directly reach the block + | ProcPoint -- this block is itself a proc point + +instance Outputable Status where + ppr (ReachedBy ps) + | setNull ps = text "" + | otherwise = text "reached by" <+> + (hsep $ punctuate comma $ map ppr $ setElems ps) + ppr ProcPoint = text "" + +-------------------------------------------------- +-- Proc point analysis + +-- Once you know what the proc-points are, figure out +-- what proc-points each block is reachable from +-- See Note [Proc-point analysis] +procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status +procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) = + analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints + where + initProcPoints = + mkFactBase + procPointLattice + [ (id, ProcPoint) + | id <- setElems procPoints + -- See Note [Non-existing proc-points] + , id `setMember` labelsInGraph + ] + labelsInGraph = labelsDefined graph + +procPointTransfer :: TransferFun Status +procPointTransfer block facts = + let label = entryLabel block + !fact = case getFact procPointLattice label facts of + ProcPoint -> ReachedBy $! setSingleton label + f -> f + result = map (\id -> (id, fact)) (successors block) + in mkFactBase procPointLattice result + +procPointLattice :: DataflowLattice Status +procPointLattice = DataflowLattice unreached add_to + where + unreached = ReachedBy setEmpty + add_to (OldFact ProcPoint) _ = NotChanged ProcPoint + add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case + add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) + | setSize union > setSize p = Changed (ReachedBy union) + | otherwise = NotChanged (ReachedBy p) + where + union = setUnion p' p + +---------------------------------------------------------------------- + +-- It is worth distinguishing two sets of proc points: those that are +-- induced by calls in the original graph and those that are +-- introduced because they're reachable from multiple proc points. +-- +-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. +callProcPoints :: CmmGraph -> ProcPointSet +callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g + where add :: LabelSet -> CmmBlock -> LabelSet + add set b = case lastNode b of + CmmCall {cml_cont = Just k} -> setInsert k set + CmmForeignCall {succ=k} -> setInsert k set + _ -> set + +minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph + -> UniqSM ProcPointSet +-- Given the set of successors of calls (which must be proc-points) +-- figure out the minimal set of necessary proc-points +minimalProcPointSet platform callProcPoints g + = extendPPSet platform g (revPostorder g) callProcPoints + +extendPPSet + :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet +extendPPSet platform g blocks procPoints = + let env = procPointAnalysis procPoints g + add pps block = let id = entryLabel block + in case mapLookup id env of + Just ProcPoint -> setInsert id pps + _ -> pps + procPoints' = foldlGraphBlocks add setEmpty g + newPoints = mapMaybe ppSuccessor blocks + newPoint = listToMaybe newPoints + ppSuccessor b = + let nreached id = case mapLookup id env `orElse` + pprPanic "no ppt" (ppr id <+> ppr b) of + ProcPoint -> 1 + ReachedBy ps -> setSize ps + block_procpoints = nreached (entryLabel b) + -- | Looking for a successor of b that is reached by + -- more proc points than b and is not already a proc + -- point. If found, it can become a proc point. + newId succ_id = not (setMember succ_id procPoints') && + nreached succ_id > block_procpoints + in listToMaybe $ filter newId $ successors b + + in case newPoint of + Just id -> + if setMember id procPoints' + then panic "added old proc pt" + else extendPPSet platform g blocks (setInsert id procPoints') + Nothing -> return procPoints' + + +-- At this point, we have found a set of procpoints, each of which should be +-- the entry point of a procedure. +-- Now, we create the procedure for each proc point, +-- which requires that we: +-- 1. build a map from proc points to the blocks reachable from the proc point +-- 2. turn each branch to a proc point into a jump +-- 3. turn calls and returns into jumps +-- 4. build info tables for the procedures -- and update the info table for +-- the SRTs in the entry procedure as well. +-- Input invariant: A block should only be reachable from a single ProcPoint. +-- ToDo: use the _ret naming convention that the old code generator +-- used. -- EZY +splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> + CmmDecl -> UniqSM [CmmDecl] +splitAtProcPoints dflags entry_label callPPs procPoints procMap + (CmmProc (TopInfo {info_tbls = info_tbls}) + top_l _ g@(CmmGraph {g_entry=entry})) = + do -- Build a map from procpoints to the blocks they reach + let add_block + :: LabelMap (LabelMap CmmBlock) + -> CmmBlock + -> LabelMap (LabelMap CmmBlock) + add_block graphEnv b = + case mapLookup bid procMap of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case setElems set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> graphEnv + where bid = entryLabel b + add graphEnv procId bid b = mapInsert procId graph' graphEnv + where graph = mapLookup procId graphEnv `orElse` mapEmpty + graph' = mapInsert bid b graph + + let liveness = cmmGlobalLiveness dflags g + let ppLiveness pp = filter isArgReg $ + regSetToList $ + expectJust "ppLiveness" $ mapLookup pp liveness + + graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g + + -- Build a map from proc point BlockId to pairs of: + -- * Labels for their new procedures + -- * Labels for the info tables of their new procedures (only if + -- the proc point is a callPP) + -- Due to common blockification, we may overestimate the set of procpoints. + let add_label map pp = mapInsert pp lbls map + where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) + | otherwise = (block_lbl, guard (setMember pp callPPs) >> + Just info_table_lbl) + where block_lbl = blockLbl pp + info_table_lbl = infoTblLbl pp + + procLabels :: LabelMap (CLabel, Maybe CLabel) + procLabels = foldl' add_label mapEmpty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + + -- In each new graph, add blocks jumping off to the new procedures, + -- and replace branches to procpoints with branches to the jump-off blocks + let add_jump_block + :: (LabelMap Label, [CmmBlock]) + -> (Label, CLabel) + -> UniqSM (LabelMap Label, [CmmBlock]) + add_jump_block (env, bs) (pp, l) = + do bid <- liftM mkBlockId getUniqueM + let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump + live = ppLiveness pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 + return (mapInsert pp bid env, b : bs) + + add_jumps + :: LabelMap CmmGraph + -> (Label, LabelMap CmmBlock) + -> UniqSM (LabelMap CmmGraph) + add_jumps newGraphEnv (ppId, blockEnv) = + do let needed_jumps = -- find which procpoints we currently branch to + mapFoldr add_if_branch_to_pp [] blockEnv + add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] + add_if_branch_to_pp block rst = + case lastNode block of + CmmBranch id -> add_if_pp id rst + CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst) + CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids + _ -> rst + + -- when jumping to a PP that has an info table, if + -- tablesNextToCode is off we must jump to the entry + -- label instead. + platform = targetPlatform dflags + tablesNextToCode = platformTablesNextToCode platform + jump_label (Just info_lbl) _ + | tablesNextToCode = info_lbl + | otherwise = toEntryLbl info_lbl + jump_label Nothing block_lbl = block_lbl + + add_if_pp id rst = case mapLookup id procLabels of + Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst + Nothing -> rst + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (mapEmpty, []) needed_jumps + -- update the entry block + let b = expectJust "block in env" $ mapLookup ppId blockEnv + blockEnv' = mapInsert ppId b blockEnv + -- replace branches to procpoints with branches to jumps + blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' + -- add the jump blocks to the graph + blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks + let g' = ofBlockMap ppId blockEnv''' + -- pprTrace "g' pre jumps" (ppr g') $ do + return (mapInsert ppId g' newGraphEnv) + + graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv + + let to_proc (bid, g) + | bid == entry + = CmmProc (TopInfo {info_tbls = info_tbls, + stack_info = stack_info}) + top_l live g' + | otherwise + = case expectJust "pp label" $ mapLookup bid procLabels of + (lbl, Just info_lbl) + -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) + , stack_info=stack_info}) + lbl live g' + (lbl, Nothing) + -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) + lbl live g' + where + g' = replacePPIds g + live = ppLiveness (g_entry g') + stack_info = StackInfo { arg_space = 0 + , do_layout = True } + -- cannot use panic, this is printed by -ddump-cmm + + -- References to procpoint IDs can now be replaced with the + -- infotable's label + replacePPIds g = {-# SCC "replacePPIds" #-} + mapGraphNodes (id, mapExp repl, mapExp repl) g + where repl e@(CmmLit (CmmBlock bid)) = + case mapLookup bid procLabels of + Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) + _ -> e + repl e = e + + -- The C back end expects to see return continuations before the + -- call sites. Here, we sort them in reverse order -- it gets + -- reversed later. + let (_, block_order) = + foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) + (revPostorder g) + add_block_num (i, map) block = + (i + 1, mapInsert (entryLabel block) i map) + sort_fn (bid, _) (bid', _) = + compare (expectJust "block_order" $ mapLookup bid block_order) + (expectJust "block_order" $ mapLookup bid' block_order) + procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv + return -- pprTrace "procLabels" (ppr procLabels) + -- pprTrace "splitting graphs" (ppr procs) + procs +splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] + +-- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a +-- recursive lookup, see comment below. +replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph +replaceBranches env cmmg + = {-# SCC "replaceBranches" #-} + ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg + where + f block = replaceLastNode block $ last (lastNode block) + + last :: CmmNode O C -> CmmNode O C + last (CmmBranch id) = CmmBranch (lookup id) + last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l + last (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets lookup ids) + last l@(CmmCall {}) = l { cml_cont = Nothing } + -- NB. remove the continuation of a CmmCall, since this + -- label will now be in a different CmmProc. Not only + -- is this tidier, it stops CmmLint from complaining. + last l@(CmmForeignCall {}) = l + lookup id = fmap lookup (mapLookup id env) `orElse` id + -- XXX: this is a recursive lookup, it follows chains + -- until the lookup returns Nothing, at which point we + -- return the last BlockId + +-- -------------------------------------------------------------- +-- Not splitting proc points: add info tables for continuations + +attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl +attachContInfoTables call_proc_points (CmmProc top_info top_l live g) + = CmmProc top_info{info_tbls = info_tbls'} top_l live g + where + info_tbls' = mapUnion (info_tbls top_info) $ + mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) + | l <- setElems call_proc_points + , l /= g_entry g ] +attachContInfoTables _ other_decl + = other_decl + +---------------------------------------------------------------- + +{- +Note [Direct reachability] + +Block B is directly reachable from proc point P iff control can flow +from P to B without passing through an intervening proc point. +-} + +---------------------------------------------------------------- + +{- +Note [No simple dataflow] + +Sadly, it seems impossible to compute the proc points using a single +dataflow pass. One might attempt to use this simple lattice: + + data Location = Unknown + | InProc BlockId -- node is in procedure headed by the named proc point + | ProcPoint -- node is itself a proc point + +At a join, a node in two different blocks becomes a proc point. +The difficulty is that the change of information during iterative +computation may promote a node prematurely. Here's a program that +illustrates the difficulty: + + f () { + entry: + .... + L1: + if (...) { ... } + else { ... } + + L2: if (...) { g(); goto L1; } + return x + y; + } + +The only proc-point needed (besides the entry) is L1. But in an +iterative analysis, consider what happens to L2. On the first pass +through, it rises from Unknown to 'InProc entry', but when L1 is +promoted to a proc point (because it's the successor of g()), L1's +successors will be promoted to 'InProc L1'. The problem hits when the +new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. +The join operation makes it a proc point when in fact it needn't be, +because its immediate dominator L1 is already a proc point and there +are no other proc points that directly reach L2. +-} + + + +{- Note [Separate Adams optimization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It may be worthwhile to attempt the Adams optimization by rewriting +the graph before the assignment of proc-point protocols. Here are a +couple of rules: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: // no CopyIn node here L: CopyIn c ress; + + +And when c == c' and ress == ress', this also: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: CopyIn c' ress' L: CopyIn c' ress' ; + +In both cases the goal is to eliminate k. +-} diff --git a/GHC/Cmm/Sink.hs b/GHC/Cmm/Sink.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Sink.hs @@ -0,0 +1,860 @@ +{-# LANGUAGE GADTs #-} +module GHC.Cmm.Sink ( + cmmSink + ) where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Cmm.Opt +import GHC.Cmm.Liveness +import GHC.Cmm.Utils +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Platform.Regs + +import GHC.Platform +import GHC.Driver.Session +import GHC.Types.Unique +import GHC.Types.Unique.FM + +import qualified Data.IntSet as IntSet +import Data.List (partition) +import qualified Data.Set as Set +import Data.Maybe + +-- Compact sets for membership tests of local variables. + +type LRegSet = IntSet.IntSet + +emptyLRegSet :: LRegSet +emptyLRegSet = IntSet.empty + +nullLRegSet :: LRegSet -> Bool +nullLRegSet = IntSet.null + +insertLRegSet :: LocalReg -> LRegSet -> LRegSet +insertLRegSet l = IntSet.insert (getKey (getUnique l)) + +elemLRegSet :: LocalReg -> LRegSet -> Bool +elemLRegSet l = IntSet.member (getKey (getUnique l)) + +-- ----------------------------------------------------------------------------- +-- Sinking and inlining + +-- This is an optimisation pass that +-- (a) moves assignments closer to their uses, to reduce register pressure +-- (b) pushes assignments into a single branch of a conditional if possible +-- (c) inlines assignments to registers that are mentioned only once +-- (d) discards dead assignments +-- +-- This tightens up lots of register-heavy code. It is particularly +-- helpful in the Cmm generated by the Stg->Cmm code generator, in +-- which every function starts with a copyIn sequence like: +-- +-- x1 = R1 +-- x2 = Sp[8] +-- x3 = Sp[16] +-- if (Sp - 32 < SpLim) then L1 else L2 +-- +-- we really want to push the x1..x3 assignments into the L2 branch. +-- +-- Algorithm: +-- +-- * Start by doing liveness analysis. +-- +-- * Keep a list of assignments A; earlier ones may refer to later ones. +-- Currently we only sink assignments to local registers, because we don't +-- have liveness information about global registers. +-- +-- * Walk forwards through the graph, look at each node N: +-- +-- * If it is a dead assignment, i.e. assignment to a register that is +-- not used after N, discard it. +-- +-- * Try to inline based on current list of assignments +-- * If any assignments in A (1) occur only once in N, and (2) are +-- not live after N, inline the assignment and remove it +-- from A. +-- +-- * If an assignment in A is cheap (RHS is local register), then +-- inline the assignment and keep it in A in case it is used afterwards. +-- +-- * Otherwise don't inline. +-- +-- * If N is assignment to a local register pick up the assignment +-- and add it to A. +-- +-- * If N is not an assignment to a local register: +-- * remove any assignments from A that conflict with N, and +-- place them before N in the current block. We call this +-- "dropping" the assignments. +-- +-- * An assignment conflicts with N if it: +-- - assigns to a register mentioned in N +-- - mentions a register assigned by N +-- - reads from memory written by N +-- * do this recursively, dropping dependent assignments +-- +-- * At an exit node: +-- * drop any assignments that are live on more than one successor +-- and are not trivial +-- * if any successor has more than one predecessor (a join-point), +-- drop everything live in that successor. Since we only propagate +-- assignments that are not dead at the successor, we will therefore +-- eliminate all assignments dead at this point. Thus analysis of a +-- join-point will always begin with an empty list of assignments. +-- +-- +-- As a result of above algorithm, sinking deletes some dead assignments +-- (transitively, even). This isn't as good as removeDeadAssignments, +-- but it's much cheaper. + +-- ----------------------------------------------------------------------------- +-- things that we aren't optimising very well yet. +-- +-- ----------- +-- (1) From GHC's FastString.hashStr: +-- +-- s2ay: +-- if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp; +-- c2gn: +-- R1 = _s2au::I64; +-- call (I64[Sp])(R1) args: 8, res: 0, upd: 8; +-- c2gp: +-- _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128, +-- 4091); +-- _s2an::I64 = _s2an::I64 + 1; +-- _s2au::I64 = _s2cO::I64; +-- goto s2ay; +-- +-- a nice loop, but we didn't eliminate the silly assignment at the end. +-- See Note [dependent assignments], which would probably fix this. +-- This is #8336. +-- +-- ----------- +-- (2) From stg_atomically_frame in PrimOps.cmm +-- +-- We have a diamond control flow: +-- +-- x = ... +-- | +-- / \ +-- A B +-- \ / +-- | +-- use of x +-- +-- Now x won't be sunk down to its use, because we won't push it into +-- both branches of the conditional. We certainly do have to check +-- that we can sink it past all the code in both A and B, but having +-- discovered that, we could sink it to its use. +-- + +-- ----------------------------------------------------------------------------- + +type Assignment = (LocalReg, CmmExpr, AbsMem) + -- Assignment caches AbsMem, an abstraction of the memory read by + -- the RHS of the assignment. + +type Assignments = [Assignment] + -- A sequence of assignments; kept in *reverse* order + -- So the list [ x=e1, y=e2 ] means the sequence of assignments + -- y = e2 + -- x = e1 + +cmmSink :: DynFlags -> CmmGraph -> CmmGraph +cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks + where + liveness = cmmLocalLiveness dflags graph + getLive l = mapFindWithDefault Set.empty l liveness + + blocks = revPostorder graph + + join_pts = findJoinPoints blocks + + sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock] + sink _ [] = [] + sink sunk (b:bs) = + -- pprTrace "sink" (ppr lbl) $ + blockJoin first final_middle final_last : sink sunk' bs + where + platform = targetPlatform dflags + lbl = entryLabel b + (first, middle, last) = blockSplit b + + succs = successors last + + -- Annotate the middle nodes with the registers live *after* + -- the node. This will help us decide whether we can inline + -- an assignment in the current node or not. + live = Set.unions (map getLive succs) + live_middle = gen_kill dflags last live + ann_middles = annotate dflags live_middle (blockToList middle) + + -- Now sink and inline in this block + (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) + fold_last = constantFoldNode platform last + (final_last, assigs') = tryToInline dflags live fold_last assigs + + -- We cannot sink into join points (successors with more than + -- one predecessor), so identify the join points and the set + -- of registers live in them. + (joins, nonjoins) = partition (`mapMember` join_pts) succs + live_in_joins = Set.unions (map getLive joins) + + -- We do not want to sink an assignment into multiple branches, + -- so identify the set of registers live in multiple successors. + -- This is made more complicated because when we sink an assignment + -- into one branch, this might change the set of registers that are + -- now live in multiple branches. + init_live_sets = map getLive nonjoins + live_in_multi live_sets r = + case filter (Set.member r) live_sets of + (_one:_two:_) -> True + _ -> False + + -- Now, drop any assignments that we will not sink any further. + (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs' + + drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') + where + should_drop = conflicts dflags a final_last + || not (isTrivial dflags rhs) && live_in_multi live_sets r + || r `Set.member` live_in_joins + + live_sets' | should_drop = live_sets + | otherwise = map upd live_sets + + upd set | r `Set.member` set = set `Set.union` live_rhs + | otherwise = set + + live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs + + final_middle = foldl' blockSnoc middle' dropped_last + + sunk' = mapUnion sunk $ + mapFromList [ (l, filterAssignments dflags (getLive l) assigs'') + | l <- succs ] + +{- TODO: enable this later, when we have some good tests in place to + measure the effect and tune it. + +-- small: an expression we don't mind duplicating +isSmall :: CmmExpr -> Bool +isSmall (CmmReg (CmmLocal _)) = True -- +isSmall (CmmLit _) = True +isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y +isSmall (CmmRegOff (CmmLocal _) _) = True +isSmall _ = False +-} + +-- +-- We allow duplication of trivial expressions: registers (both local and +-- global) and literals. +-- +isTrivial :: DynFlags -> CmmExpr -> Bool +isTrivial _ (CmmReg (CmmLocal _)) = True +isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] + if isARM (platformArch (targetPlatform dflags)) + then True -- CodeGen.Platform.ARM does not have globalRegMaybe + else isJust (globalRegMaybe (targetPlatform dflags) r) + -- GlobalRegs that are loads from BaseReg are not trivial +isTrivial _ (CmmLit _) = True +isTrivial _ _ = False + +-- +-- annotate each node with the set of registers live *after* the node +-- +annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] +annotate dflags live nodes = snd $ foldr ann (live,[]) nodes + where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes) + +-- +-- Find the blocks that have multiple successors (join points) +-- +findJoinPoints :: [CmmBlock] -> LabelMap Int +findJoinPoints blocks = mapFilter (>1) succ_counts + where + all_succs = concatMap successors blocks + + succ_counts :: LabelMap Int + succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs + +-- +-- filter the list of assignments to remove any assignments that +-- are not live in a continuation. +-- +filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments +filterAssignments dflags live assigs = reverse (go assigs []) + where go [] kept = kept + go (a@(r,_,_):as) kept | needed = go as (a:kept) + | otherwise = go as kept + where + needed = r `Set.member` live + || any (conflicts dflags a) (map toNode kept) + -- Note that we must keep assignments that are + -- referred to by other assignments we have + -- already kept. + +-- ----------------------------------------------------------------------------- +-- Walk through the nodes of a block, sinking and inlining assignments +-- as we go. +-- +-- On input we pass in a: +-- * list of nodes in the block +-- * a list of assignments that appeared *before* this block and +-- that are being sunk. +-- +-- On output we get: +-- * a new block +-- * a list of assignments that will be placed *after* that block. +-- + +walk :: DynFlags + -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with + -- the set of registers live *after* + -- this node. + + -> Assignments -- The current list of + -- assignments we are sinking. + -- Earlier assignments may refer + -- to later ones. + + -> ( Block CmmNode O O -- The new block + , Assignments -- Assignments to sink further + ) + +walk dflags nodes assigs = go nodes emptyBlock assigs + where + go [] block as = (block, as) + go ((live,node):ns) block as + | shouldDiscard node live = go ns block as + -- discard dead assignment + | Just a <- shouldSink platform node2 = go ns block (a : as1) + | otherwise = go ns block' as' + where + platform = targetPlatform dflags + node1 = constantFoldNode platform node + + (node2, as1) = tryToInline dflags live node1 as + + (dropped, as') = dropAssignmentsSimple dflags + (\a -> conflicts dflags a node2) as1 + + block' = foldl' blockSnoc block dropped `blockSnoc` node2 + + +-- +-- Heuristic to decide whether to pick up and sink an assignment +-- Currently we pick up all assignments to local registers. It might +-- be profitable to sink assignments to global regs too, but the +-- liveness analysis doesn't track those (yet) so we can't. +-- +shouldSink :: Platform -> CmmNode e x -> Maybe Assignment +shouldSink platform (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem platform e) + where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e +shouldSink _ _other = Nothing + +-- +-- discard dead assignments. This doesn't do as good a job as +-- removeDeadAssignments, because it would need multiple passes +-- to get all the dead code, but it catches the common case of +-- superfluous reloads from the stack that the stack allocator +-- leaves behind. +-- +-- Also we catch "r = r" here. You might think it would fall +-- out of inlining, but the inliner will see that r is live +-- after the instruction and choose not to inline r in the rhs. +-- +shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool +shouldDiscard node live + = case node of + CmmAssign r (CmmReg r') | r == r' -> True + CmmAssign (CmmLocal r) _ -> not (r `Set.member` live) + _otherwise -> False + + +toNode :: Assignment -> CmmNode O O +toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs + +dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments + -> ([CmmNode O O], Assignments) +dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) () + +dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments + -> ([CmmNode O O], Assignments) +dropAssignments dflags should_drop state assigs + = (dropped, reverse kept) + where + (dropped,kept) = go state assigs [] [] + + go _ [] dropped kept = (dropped, kept) + go state (assig : rest) dropped kept + | conflict = go state' rest (toNode assig : dropped) kept + | otherwise = go state' rest dropped (assig:kept) + where + (dropit, state') = should_drop assig state + conflict = dropit || any (conflicts dflags assig) dropped + + +-- ----------------------------------------------------------------------------- +-- Try to inline assignments into a node. +-- This also does constant folding for primpops, since +-- inlining opens up opportunities for doing so. + +tryToInline + :: DynFlags + -> LocalRegSet -- set of registers live after this + -- node. We cannot inline anything + -- that is live after the node, unless + -- it is small enough to duplicate. + -> CmmNode O x -- The node to inline into + -> Assignments -- Assignments to inline + -> ( + CmmNode O x -- New node + , Assignments -- Remaining assignments + ) + +tryToInline dflags live node assigs = go usages node emptyLRegSet assigs + where + usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used + usages = foldLocalRegsUsed dflags addUsage emptyUFM node + + go _usages node _skipped [] = (node, []) + + go usages node skipped (a@(l,rhs,_) : rest) + | cannot_inline = dont_inline + | occurs_none = discard -- Note [discard during inlining] + | occurs_once = inline_and_discard + | isTrivial dflags rhs = inline_and_keep + | otherwise = dont_inline + where + platform = targetPlatform dflags + inline_and_discard = go usages' inl_node skipped rest + where usages' = foldLocalRegsUsed dflags addUsage usages rhs + + discard = go usages node skipped rest + + dont_inline = keep node -- don't inline the assignment, keep it + inline_and_keep = keep inl_node -- inline the assignment, keep it + + keep node' = (final_node, a : rest') + where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest + usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) + usages rhs + -- we must not inline anything that is mentioned in the RHS + -- of a binding that we have already skipped, so we set the + -- usages of the regs on the RHS to 2. + + cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments] + || l `elemLRegSet` skipped + || not (okToInline dflags rhs node) + + l_usages = lookupUFM usages l + l_live = l `elemRegSet` live + + occurs_once = not l_live && l_usages == Just 1 + occurs_none = not l_live && l_usages == Nothing + + inl_node = improveConditional (mapExpDeep inl_exp node) + + inl_exp :: CmmExpr -> CmmExpr + -- inl_exp is where the inlining actually takes place! + inl_exp (CmmReg (CmmLocal l')) | l == l' = rhs + inl_exp (CmmRegOff (CmmLocal l') off) | l == l' + = cmmOffset platform rhs off + -- re-constant fold after inlining + inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args + inl_exp other = other + + +{- Note [improveConditional] + +cmmMachOpFold tries to simplify conditionals to turn things like + (a == b) != 1 +into + (a != b) +but there's one case it can't handle: when the comparison is over +floating-point values, we can't invert it, because floating-point +comparisons aren't invertible (because of NaNs). + +But we *can* optimise this conditional by swapping the true and false +branches. Given + CmmCondBranch ((a >## b) != 1) t f +we can turn it into + CmmCondBranch (a >## b) f t + +So here we catch conditionals that weren't optimised by cmmMachOpFold, +and apply above transformation to eliminate the comparison against 1. + +It's tempting to just turn every != into == and then let cmmMachOpFold +do its thing, but that risks changing a nice fall-through conditional +into one that requires two jumps. (see swapcond_last in +GHC.Cmm.ContFlowOpt), so instead we carefully look for just the cases where +we can eliminate a comparison. +-} +improveConditional :: CmmNode O x -> CmmNode O x +improveConditional + (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l) + | neLike mop, isComparisonExpr x + = CmmCondBranch x f t (fmap not l) + where + neLike (MO_Ne _) = True + neLike (MO_U_Lt _) = True -- (x LocalReg -> UniqFM LocalReg Int +addUsage m r = addToUFM_C (+) m r 1 + +regsUsedIn :: LRegSet -> CmmExpr -> Bool +regsUsedIn ls _ | nullLRegSet ls = False +regsUsedIn ls e = wrapRecExpf f e False + where f (CmmReg (CmmLocal l)) _ | l `elemLRegSet` ls = True + f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True + f _ z = z + +-- we don't inline into CmmUnsafeForeignCall if the expression refers +-- to global registers. This is a HACK to avoid global registers +-- clashing with C argument-passing registers, really the back-end +-- ought to be able to handle it properly, but currently neither PprC +-- nor the NCG can do it. See Note [Register parameter passing] +-- See also GHC.StgToCmm.Foreign.load_args_into_temps. +okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +okToInline dflags expr node@(CmmUnsafeForeignCall{}) = + not (globalRegistersConflict dflags expr node) +okToInline _ _ _ = True + +-- ----------------------------------------------------------------------------- + +-- | @conflicts (r,e) node@ is @False@ if and only if the assignment +-- @r = e@ can be safely commuted past statement @node@. +conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool +conflicts dflags (r, rhs, addr) node + + -- (1) node defines registers used by rhs of assignment. This catches + -- assignments and all three kinds of calls. See Note [Sinking and calls] + | globalRegistersConflict dflags rhs node = True + | localRegistersConflict dflags rhs node = True + + -- (2) node uses register defined by assignment + | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True + + -- (3) a store to an address conflicts with a read of the same memory + | CmmStore addr' e <- node + , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True + + -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively + | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True + | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True + | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True + + -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] + | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True + + -- (6) native calls clobber any memory + | CmmCall{} <- node, memConflicts addr AnyMem = True + + -- (7) otherwise, no conflict + | otherwise = False + where + platform = targetPlatform dflags + +-- Returns True if node defines any global registers that are used in the +-- Cmm expression +globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +globalRegistersConflict dflags expr node = + foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr) + False node + +-- Returns True if node defines any local registers that are used in the +-- Cmm expression +localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +localRegistersConflict dflags expr node = + foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal r) expr) + False node + +-- Note [Sinking and calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) +-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after +-- stack layout (see Note [Sinking after stack layout]) which leads to two +-- invariants related to calls: +-- +-- a) during stack layout phase all safe foreign calls are turned into +-- unsafe foreign calls (see Note [Lower safe foreign calls]). This +-- means that we will never encounter CmmForeignCall node when running +-- sinking after stack layout +-- +-- b) stack layout saves all variables live across a call on the stack +-- just before making a call (remember we are not sinking assignments to +-- stack): +-- +-- L1: +-- x = R1 +-- P64[Sp - 16] = L2 +-- P64[Sp - 8] = x +-- Sp = Sp - 16 +-- call f() returns L2 +-- L2: +-- +-- We will attempt to sink { x = R1 } but we will detect conflict with +-- { P64[Sp - 8] = x } and hence we will drop { x = R1 } without even +-- checking whether it conflicts with { call f() }. In this way we will +-- never need to check any assignment conflicts with CmmCall. Remember +-- that we still need to check for potential memory conflicts. +-- +-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes +-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]). +-- This assumption holds only when we do sinking after stack layout. If we run +-- it before stack layout we need to check for possible conflicts with all three +-- kinds of calls. Our `conflicts` function does that by using a generic +-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and +-- UserOfRegs typeclasses. +-- + +-- An abstraction of memory read or written. +data AbsMem + = NoMem -- no memory accessed + | AnyMem -- arbitrary memory + | HeapMem -- definitely heap memory + | StackMem -- definitely stack memory + | SpMem -- [Sp+n] + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +-- Having SpMem is important because it lets us float loads from Sp +-- past stores to Sp as long as they don't overlap, and this helps to +-- unravel some long sequences of +-- x1 = [Sp + 8] +-- x2 = [Sp + 16] +-- ... +-- [Sp + 8] = xi +-- [Sp + 16] = xj +-- +-- Note that SpMem is invalidated if Sp is changed, but the definition +-- of 'conflicts' above handles that. + +-- ToDo: this won't currently fix the following commonly occurring code: +-- x1 = [R1 + 8] +-- x2 = [R1 + 16] +-- .. +-- [Hp - 8] = x1 +-- [Hp - 16] = x2 +-- .. + +-- because [R1 + 8] and [Hp - 8] are both HeapMem. We know that +-- assignments to [Hp + n] do not conflict with any other heap memory, +-- but this is tricky to nail down. What if we had +-- +-- x = Hp + n +-- [x] = ... +-- +-- the store to [x] should be "new heap", not "old heap". +-- Furthermore, you could imagine that if we started inlining +-- functions in Cmm then there might well be reads of heap memory +-- that was written in the same basic block. To take advantage of +-- non-aliasing of heap memory we will have to be more clever. + +-- Note [Foreign calls clobber heap] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- It is tempting to say that foreign calls clobber only +-- non-heap/stack memory, but unfortunately we break this invariant in +-- the RTS. For example, in stg_catch_retry_frame we call +-- stmCommitNestedTransaction() which modifies the contents of the +-- TRec it is passed (this actually caused incorrect code to be +-- generated). +-- +-- Since the invariant is true for the majority of foreign calls, +-- perhaps we ought to have a special annotation for calls that can +-- modify heap/stack memory. For now we just use the conservative +-- definition here. +-- +-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and +-- therefore we should never float any memory operations across one of +-- these calls. + + +bothMems :: AbsMem -> AbsMem -> AbsMem +bothMems NoMem x = x +bothMems x NoMem = x +bothMems HeapMem HeapMem = HeapMem +bothMems StackMem StackMem = StackMem +bothMems (SpMem o1 w1) (SpMem o2 w2) + | o1 == o2 = SpMem o1 (max w1 w2) + | otherwise = StackMem +bothMems SpMem{} StackMem = StackMem +bothMems StackMem SpMem{} = StackMem +bothMems _ _ = AnyMem + +memConflicts :: AbsMem -> AbsMem -> Bool +memConflicts NoMem _ = False +memConflicts _ NoMem = False +memConflicts HeapMem StackMem = False +memConflicts StackMem HeapMem = False +memConflicts SpMem{} HeapMem = False +memConflicts HeapMem SpMem{} = False +memConflicts (SpMem o1 w1) (SpMem o2 w2) + | o1 < o2 = o1 + w1 > o2 + | otherwise = o2 + w2 > o1 +memConflicts _ _ = True + +exprMem :: Platform -> CmmExpr -> AbsMem +exprMem platform (CmmLoad addr w) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr) +exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es) +exprMem _ _ = NoMem + +loadAddr :: Platform -> CmmExpr -> Width -> AbsMem +loadAddr platform e w = + case e of + CmmReg r -> regAddr platform r 0 w + CmmRegOff r i -> regAddr platform r i w + _other | regUsedIn platform spReg e -> StackMem + | otherwise -> AnyMem + +regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem +regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) +regAddr _ (CmmGlobal Hp) _ _ = HeapMem +regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps +regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ _ = AnyMem + +{- +Note [Inline GlobalRegs?] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Should we freely inline GlobalRegs? + +Actually it doesn't make a huge amount of difference either way, so we +*do* currently treat GlobalRegs as "trivial" and inline them +everywhere, but for what it's worth, here is what I discovered when I +(SimonM) looked into this: + +Common sense says we should not inline GlobalRegs, because when we +have + + x = R1 + +the register allocator will coalesce this assignment, generating no +code, and simply record the fact that x is bound to $rbx (or +whatever). Furthermore, if we were to sink this assignment, then the +range of code over which R1 is live increases, and the range of code +over which x is live decreases. All things being equal, it is better +for x to be live than R1, because R1 is a fixed register whereas x can +live in any register. So we should neither sink nor inline 'x = R1'. + +However, not inlining GlobalRegs can have surprising +consequences. e.g. (cgrun020) + + c3EN: + _s3DB::P64 = R1; + _c3ES::P64 = _s3DB::P64 & 7; + if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV; + c3EU: + _s3DD::P64 = P64[_s3DB::P64 + 6]; + _s3DE::P64 = P64[_s3DB::P64 + 14]; + I64[Sp - 8] = c3F0; + R1 = _s3DE::P64; + P64[Sp] = _s3DD::P64; + +inlining the GlobalReg gives: + + c3EN: + if (R1 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + _s3DD::P64 = P64[R1 + 6]; + R1 = P64[R1 + 14]; + P64[Sp] = _s3DD::P64; + +but if we don't inline the GlobalReg, instead we get: + + _s3DB::P64 = R1; + if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + R1 = P64[_s3DB::P64 + 14]; + P64[Sp] = P64[_s3DB::P64 + 6]; + +This looks better - we managed to inline _s3DD - but in fact it +generates an extra reg-reg move: + +.Lc3EU: + movq $c3F0_info,-8(%rbp) + movq %rbx,%rax + movq 14(%rbx),%rbx + movq 6(%rax),%rax + movq %rax,(%rbp) + +because _s3DB is now live across the R1 assignment, we lost the +benefit of coalescing. + +Who is at fault here? Perhaps if we knew that _s3DB was an alias for +R1, then we would not sink a reference to _s3DB past the R1 +assignment. Or perhaps we *should* do that - we might gain by sinking +it, despite losing the coalescing opportunity. + +Sometimes not inlining global registers wins by virtue of the rule +about not inlining into arguments of a foreign call, e.g. (T7163) this +is what happens when we inlined F1: + + _s3L2::F32 = F1; + _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32); + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(_c3O3::F32); + +but if we don't inline F1: + + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(%MO_F_Mul_W32(_s3L2::F32, + 10.0 :: W32)); +-} diff --git a/GHC/Cmm/Switch.hs b/GHC/Cmm/Switch.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Switch.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module GHC.Cmm.Switch ( + SwitchTargets, + mkSwitchTargets, + switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned, + mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough, + switchTargetsToList, eqSwitchTargetWith, + + SwitchPlan(..), + targetSupportsSwitch, + createSwitchPlan, + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Cmm.Dataflow.Label (Label) + +import Data.Maybe +import Data.List (groupBy) +import Data.Function (on) +import qualified Data.Map as M + +-- Note [Cmm Switches, the general plan] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Compiling a high-level switch statement, as it comes out of a STG case +-- expression, for example, allows for a surprising amount of design decisions. +-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as +-- well as from the actual code generation. +-- +-- The overall plan is: +-- * The Stg → Cmm transformation creates a single `SwitchTargets` in +-- emitSwitch and emitCmmLitSwitch in GHC.StgToCmm.Utils. +-- At this stage, they are unsuitable for code generation. +-- * A dedicated Cmm transformation (GHC.Cmm.Switch.Implement) replaces these +-- switch statements with code that is suitable for code generation, i.e. +-- a nice balanced tree of decisions with dense jump tables in the leafs. +-- The actual planning of this tree is performed in pure code in createSwitchPlan +-- in this module. See Note [createSwitchPlan]. +-- * The actual code generation will not do any further processing and +-- implement each CmmSwitch with a jump tables. +-- +-- When compiling to LLVM or C, GHC.Cmm.Switch.Implement leaves the switch +-- statements alone, as we can turn a SwitchTargets value into a nice +-- switch-statement in LLVM resp. C, and leave the rest to the compiler. +-- +-- See Note [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement] why the two module are +-- separated. + +----------------------------------------------------------------------------- +-- Note [Magic Constants in GHC.Cmm.Switch] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are a lot of heuristics here that depend on magic values where it is +-- hard to determine the "best" value (for whatever that means). These are the +-- magic values: + +-- | Number of consecutive default values allowed in a jump table. If there are +-- more of them, the jump tables are split. +-- +-- Currently 7, as it costs 7 words of additional code when a jump table is +-- split (at least on x64, determined experimentally). +maxJumpTableHole :: Integer +maxJumpTableHole = 7 + +-- | Minimum size of a jump table. If the number is smaller, the switch is +-- implemented using conditionals. +-- Currently 5, because an if-then-else tree of 4 values is nice and compact. +minJumpTableSize :: Int +minJumpTableSize = 5 + +-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset]. +minJumpTableOffset :: Integer +minJumpTableOffset = 2 + + +----------------------------------------------------------------------------- +-- Switch Targets + +-- Note [SwitchTargets] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- The branches of a switch are stored in a SwitchTargets, which consists of an +-- (optional) default jump target, and a map from values to jump targets. +-- +-- If the default jump target is absent, the behaviour of the switch outside the +-- values of the map is undefined. +-- +-- We use an Integer for the keys the map so that it can be used in switches on +-- unsigned as well as signed integers. +-- +-- The map may be empty (we prune out-of-range branches here, so it could be us +-- emptying it). +-- +-- Before code generation, the table needs to be brought into a form where all +-- entries are non-negative, so that it can be compiled into a jump table. +-- See switchTargetsToTable. + + +-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch' +-- value, and knows whether the value is signed, the possible range, an +-- optional default value and a map from values to jump labels. +data SwitchTargets = + SwitchTargets + Bool -- Signed values + (Integer, Integer) -- Range + (Maybe Label) -- Default value + (M.Map Integer Label) -- The branches + deriving (Show, Eq) + +-- | The smart constructor mkSwitchTargets normalises the map a bit: +-- * No entries outside the range +-- * No entries equal to the default +-- * No default if all elements have explicit values +mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets +mkSwitchTargets signed range@(lo,hi) mbdef ids + = SwitchTargets signed range mbdef' ids' + where + ids' = dropDefault $ restrict ids + mbdef' | defaultNeeded = mbdef + | otherwise = Nothing + + -- Drop entries outside the range, if there is a range + restrict = restrictMap (lo,hi) + + -- Drop entries that equal the default, if there is a default + dropDefault | Just l <- mbdef = M.filter (/= l) + | otherwise = id + + -- Check if the default is still needed + defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1 + + +-- | Changes all labels mentioned in the SwitchTargets value +mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets +mapSwitchTargets f (SwitchTargets signed range mbdef branches) + = SwitchTargets signed range (fmap f mbdef) (fmap f branches) + +-- | Returns the list of non-default branches of the SwitchTargets value +switchTargetsCases :: SwitchTargets -> [(Integer, Label)] +switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches + +-- | Return the default label of the SwitchTargets value +switchTargetsDefault :: SwitchTargets -> Maybe Label +switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef + +-- | Return the range of the SwitchTargets value +switchTargetsRange :: SwitchTargets -> (Integer, Integer) +switchTargetsRange (SwitchTargets _ range _ _) = range + +-- | Return whether this is used for a signed value +switchTargetsSigned :: SwitchTargets -> Bool +switchTargetsSigned (SwitchTargets signed _ _ _) = signed + +-- | switchTargetsToTable creates a dense jump table, usable for code generation. +-- +-- Also returns an offset to add to the value; the list is 0-based on the +-- result of that addition. +-- +-- The conversion from Integer to Int is a bit of a wart, as the actual +-- scrutinee might be an unsigned word, but it just works, due to wrap-around +-- arithmetic (as verified by the CmmSwitchTest test case). +switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label]) +switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches) + = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ]) + where + labelFor i = case M.lookup i branches of Just l -> Just l + Nothing -> mbdef + start | lo >= 0 && lo < minJumpTableOffset = 0 -- See Note [Jump Table Offset] + | otherwise = lo + +-- Note [Jump Table Offset] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Usually, the code for a jump table starting at x will first subtract x from +-- the value, to avoid a large amount of empty entries. But if x is very small, +-- the extra entries are no worse than the subtraction in terms of code size, and +-- not having to do the subtraction is quicker. +-- +-- I.e. instead of +-- _u20N: +-- leaq -1(%r14),%rax +-- jmp *_n20R(,%rax,8) +-- _n20R: +-- .quad _c20p +-- .quad _c20q +-- do +-- _u20N: +-- jmp *_n20Q(,%r14,8) +-- +-- _n20Q: +-- .quad 0 +-- .quad _c20p +-- .quad _c20q +-- .quad _c20r + +-- | The list of all labels occurring in the SwitchTargets value. +switchTargetsToList :: SwitchTargets -> [Label] +switchTargetsToList (SwitchTargets _ _ mbdef branches) + = maybeToList mbdef ++ M.elems branches + +-- | Groups cases with equal targets, suitable for pretty-printing to a +-- c-like switch statement with fall-through semantics. +switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label) +switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef) + where + groups = map (\xs -> (map fst xs, snd (head xs))) $ + groupBy ((==) `on` snd) $ + M.toList branches + +-- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim" +eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool +eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) = + signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2) + where + goMB Nothing Nothing = True + goMB (Just l1) (Just l2) = l1 `eq` l2 + goMB _ _ = False + goList [] [] = True + goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2 + goList _ _ = False + +----------------------------------------------------------------------------- +-- Code generation for Switches + + +-- | A SwitchPlan abstractly describes how a Switch statement ought to be +-- implemented. See Note [createSwitchPlan] +data SwitchPlan + = Unconditionally Label + | IfEqual Integer Label SwitchPlan + | IfLT Bool Integer SwitchPlan SwitchPlan + | JumpTable SwitchTargets + deriving Show +-- +-- Note [createSwitchPlan] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A SwitchPlan describes how a Switch statement is to be broken down into +-- smaller pieces suitable for code generation. +-- +-- createSwitchPlan creates such a switch plan, in these steps: +-- 1. It splits the switch statement at segments of non-default values that +-- are too large. See splitAtHoles and Note [Magic Constants in GHC.Cmm.Switch] +-- 2. Too small jump tables should be avoided, so we break up smaller pieces +-- in breakTooSmall. +-- 3. We fill in the segments between those pieces with a jump to the default +-- label (if there is one), returning a SeparatedList in mkFlatSwitchPlan +-- 4. We find and replace two less-than branches by a single equal-to-test in +-- findSingleValues +-- 5. The thus collected pieces are assembled to a balanced binary tree. + +{- + Note [Two alts + default] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + +Discussion and a bit more info at #14644 + +When dealing with a switch of the form: +switch(e) { + case 1: goto l1; + case 3000: goto l2; + default: goto ldef; +} + +If we treat it as a sparse jump table we would generate: + +if (e > 3000) //Check if value is outside of the jump table. + goto ldef; +else { + if (e < 3000) { //Compare to upper value + if(e != 1) //Compare to remaining value + goto ldef; + else + goto l2; + } + else + goto l1; +} + +Instead we special case this to : + +if (e==1) goto l1; +else if (e==3000) goto l2; +else goto l3; + +This means we have: +* Less comparisons for: 1,<3000 +* Unchanged for 3000 +* One more for >3000 + +This improves code in a few ways: +* One comparison less means smaller code which helps with cache. +* It exchanges a taken jump for two jumps no taken in the >range case. + Jumps not taken are cheaper (See Agner guides) making this about as fast. +* For all other cases the first range check is removed making it faster. + +The end result is that the change is not measurably slower for the case +>3000 and faster for the other cases. + +This makes running this kind of match in an inner loop cheaper by 10-20% +depending on the data. +In nofib this improves wheel-sieve1 by 4-9% depending on problem +size. + +We could also add a second conditional jump after the comparison to +keep the range check like this: + cmp 3000, rArgument + jg + je +While this is fairly cheap it made no big difference for the >3000 case +and slowed down all other cases making it not worthwhile. +-} + + +-- | Does the target support switch out of the box? Then leave this to the +-- target! +targetSupportsSwitch :: HscTarget -> Bool +targetSupportsSwitch HscC = True +targetSupportsSwitch HscLlvm = True +targetSupportsSwitch _ = False + +-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it +-- down into smaller pieces suitable for code generation. +createSwitchPlan :: SwitchTargets -> SwitchPlan +-- Lets do the common case of a singleton map quickly and efficiently (#10677) +createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m) + | [(x, l)] <- M.toList m + = IfEqual x l (Unconditionally defLabel) +-- And another common case, matching "booleans" +createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m) + | [(x1, l1), (_x2,l2)] <- M.toAscList m + --Checking If |range| = 2 is enough if we have two unique literals + , hi - lo == 1 + = IfEqual x1 l1 (Unconditionally l2) +-- See Note [Two alts + default] +createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m) + | [(x1, l1), (x2,l2)] <- M.toAscList m + = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel)) +createSwitchPlan (SwitchTargets signed range mbdef m) = + -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $ + plan + where + pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m + flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces + plan = buildTree signed $ flatPlan + + +--- +--- Step 1: Splitting at large holes +--- +splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a] +splitAtHoles _ m | M.null m = [] +splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles + where + holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m)) + nonHoles = reassocTuples lo holes hi + + (lo,_) = M.findMin m + (hi,_) = M.findMax m + +--- +--- Step 2: Avoid small jump tables +--- +-- We do not want jump tables below a certain size. This breaks them up +-- (into singleton maps, for now). +breakTooSmall :: M.Map Integer a -> [M.Map Integer a] +breakTooSmall m + | M.size m > minJumpTableSize = [m] + | otherwise = [M.singleton k v | (k,v) <- M.toList m] + +--- +--- Step 3: Fill in the blanks +--- + +-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every +-- two entries, dividing the range. +-- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if +-- the expression is < n, and plan2 otherwise. + +type FlatSwitchPlan = SeparatedList Integer SwitchPlan + +mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan + +-- If we have no default (i.e. undefined where there is no entry), we can +-- branch at the minimum of each map +mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty +mkFlatSwitchPlan signed Nothing _ (m:ms) + = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ]) + +-- If we have a default, we have to interleave segments that jump +-- to the default between the maps +mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps) + where + go (lo,hi) [] + | lo > hi = [] + | otherwise = [(lo, Unconditionally l)] + go (lo,hi) (m:ms) + | lo < min + = (lo, Unconditionally l) : go (min,hi) (m:ms) + | lo == min + = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms + | otherwise + = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min) + where + min = fst (M.findMin m) + max = fst (M.findMax m) + + +mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan +mkLeafPlan signed mbdef m + | [(_,l)] <- M.toList m -- singleton map + = Unconditionally l + | otherwise + = JumpTable $ mkSwitchTargets signed (min,max) mbdef m + where + min = fst (M.findMin m) + max = fst (M.findMax m) + +--- +--- Step 4: Reduce the number of branches using == +--- + +-- A sequence of three unconditional jumps, with the outer two pointing to the +-- same value and the bounds off by exactly one can be improved +findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan +findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs) + | l == l3 && i + 1 == i' + = findSingleValues (IfEqual i l2 (Unconditionally l), xs) +findSingleValues (p, (i,p'):xs) + = (p,i) `consSL` findSingleValues (p', xs) +findSingleValues (p, []) + = (p, []) + +--- +--- Step 5: Actually build the tree +--- + +-- Build a balanced tree from a separated list +buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan +buildTree _ (p,[]) = p +buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2) + where + (sl1, m, sl2) = divideSL sl + + + +-- +-- Utility data type: Non-empty lists with extra markers in between each +-- element: +-- + +type SeparatedList b a = (a, [(b,a)]) + +consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a +consSL (a, b) (a', xs) = (a, (b,a'):xs) + +divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a) +divideSL (_,[]) = error "divideSL: Singleton SeparatedList" +divideSL (p,xs) = ((p, xs1), m, (p', xs2)) + where + (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs + +-- +-- Other Utilities +-- + +restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b +restrictMap (lo,hi) m = mid + where (_, mid_hi) = M.split (lo-1) m + (mid, _) = M.split (hi+1) mid_hi + +-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)] +reassocTuples :: a -> [(a,a)] -> a -> [(a,a)] +reassocTuples initial [] last + = [(initial,last)] +reassocTuples initial ((a,b):tuples) last + = (initial,a) : reassocTuples b tuples last + +-- Note [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- I (Joachim) separated the two somewhat closely related modules +-- +-- - GHC.Cmm.Switch, which provides the CmmSwitchTargets type and contains the strategy +-- for implementing a Cmm switch (createSwitchPlan), and +-- - GHC.Cmm.Switch.Implement, which contains the actual Cmm graph modification, +-- +-- for these reasons: +-- +-- * GHC.Cmm.Switch is very low in the dependency tree, i.e. does not depend on any +-- GHC specific modules at all (with the exception of Output and +-- GHC.Cmm.Dataflow (Literal)). +-- * GHC.Cmm.Switch.Implement is the Cmm transformation and hence very high in +-- the dependency tree. +-- * GHC.Cmm.Switch provides the CmmSwitchTargets data type, which is abstract, but +-- used in GHC.Cmm.Node. +-- * Because GHC.Cmm.Switch is low in the dependency tree, the separation allows +-- for more parallelism when building GHC. +-- * The interaction between the modules is very explicit and easy to +-- understand, due to the small and simple interface. diff --git a/GHC/Cmm/Switch/Implement.hs b/GHC/Cmm/Switch/Implement.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Switch/Implement.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE GADTs #-} +module GHC.Cmm.Switch.Implement + ( cmmImplementSwitchPlans + ) +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Types.Unique.Supply +import GHC.Driver.Session +import GHC.Utils.Monad (concatMapM) + +-- +-- This module replaces Switch statements as generated by the Stg -> Cmm +-- transformation, which might be huge and sparse and hence unsuitable for +-- assembly code, by proper constructs (if-then-else trees, dense jump tables). +-- +-- The actual, abstract strategy is determined by createSwitchPlan in +-- GHC.Cmm.Switch and returned as a SwitchPlan; here is just the implementation in +-- terms of Cmm code. See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch. +-- +-- This division into different modules is both to clearly separate concerns, +-- but also because createSwitchPlan needs access to the constructors of +-- SwitchTargets, a data type exported abstractly by GHC.Cmm.Switch. +-- + +-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for +-- code generation. +cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph +cmmImplementSwitchPlans dflags g + -- Switch generation done by backend (LLVM/C) + | targetSupportsSwitch (hscTarget dflags) = return g + | otherwise = do + blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g) + return $ ofBlockList (g_entry g) blocks' + +visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock] +visitSwitches platform block + | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block + = do + let plan = createSwitchPlan ids + -- See Note [Floating switch expressions] + (assignSimple, simpleExpr) <- floatSwitchExpr platform vanillaExpr + + (newTail, newBlocks) <- implementSwitchPlan platform scope simpleExpr plan + + let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail + + return $ block' : newBlocks + + | otherwise + = return [block] + +-- Note [Floating switch expressions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- When we translate a sparse switch into a search tree we would like +-- to compute the value we compare against only once. + +-- For this purpose we assign the switch expression to a local register +-- and then use this register when constructing the actual binary tree. + +-- This is important as the expression could contain expensive code like +-- memory loads or divisions which we REALLY don't want to duplicate. + +-- This happened in parts of the handwritten RTS Cmm code. See also #16933 + +-- See Note [Floating switch expressions] +floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr) +floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg) +floatSwitchExpr platform expr = do + (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM + return (BMiddle assign, expr') + + +-- Implementing a switch plan (returning a tail block) +implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock]) +implementSwitchPlan platform scope expr = go + where + go (Unconditionally l) + = return (emptyBlock `blockJoinTail` CmmBranch l, []) + go (JumpTable ids) + = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, []) + go (IfLT signed i ids1 ids2) + = do + (bid1, newBlocks1) <- go' ids1 + (bid2, newBlocks2) <- go' ids2 + + let lt | signed = cmmSLtWord + | otherwise = cmmULtWord + scrut = lt platform expr $ CmmLit $ mkWordCLit platform i + lastNode = CmmCondBranch scrut bid1 bid2 Nothing + lastBlock = emptyBlock `blockJoinTail` lastNode + return (lastBlock, newBlocks1++newBlocks2) + go (IfEqual i l ids2) + = do + (bid2, newBlocks2) <- go' ids2 + + let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i + lastNode = CmmCondBranch scrut bid2 l Nothing + lastBlock = emptyBlock `blockJoinTail` lastNode + return (lastBlock, newBlocks2) + + -- Same but returning a label to branch to + go' (Unconditionally l) + = return (l, []) + go' p + = do + bid <- mkBlockId `fmap` getUniqueM + (last, newBlocks) <- go p + let block = CmmEntry bid scope `blockJoinHead` last + return (bid, block: newBlocks) diff --git a/GHC/Cmm/Type.hs b/GHC/Cmm/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Type.hs @@ -0,0 +1,430 @@ +module GHC.Cmm.Type + ( CmmType -- Abstract + , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord + , cInt + , cmmBits, cmmFloat + , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood + , isFloatType, isGcPtrType, isBitsType + , isWord32, isWord64, isFloat64, isFloat32 + + , Width(..) + , widthInBits, widthInBytes, widthInLog, widthFromBytes + , wordWidth, halfWordWidth, cIntWidth + , halfWordMask + , narrowU, narrowS + , rEP_CostCentreStack_mem_alloc + , rEP_CostCentreStack_scc_count + , rEP_StgEntCounter_allocs + , rEP_StgEntCounter_allocd + + , ForeignHint(..) + + , Length + , vec, vec2, vec4, vec8, vec16 + , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 + , cmmVec + , vecLength, vecElemType + , isVecType + ) +where + + +import GHC.Prelude + +import GHC.Platform +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Outputable + +import Data.Word +import Data.Int + +----------------------------------------------------------------------------- +-- CmmType +----------------------------------------------------------------------------- + + -- NOTE: CmmType is an abstract type, not exported from this + -- module so you can easily change its representation + -- + -- However Width is exported in a concrete way, + -- and is used extensively in pattern-matching + +data CmmType -- The important one! + = CmmType CmmCat Width + +data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + | VecCat Length CmmCat -- Vector + deriving( Eq ) + -- See Note [Signed vs unsigned] at the end + +instance Outputable CmmType where + ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) + +instance Outputable CmmCat where + ppr FloatCat = text "F" + ppr GcPtrCat = text "P" + ppr BitsCat = text "I" + ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" + +-- Why is CmmType stratified? For native code generation, +-- most of the time you just want to know what sort of register +-- to put the thing in, and for this you need to know how +-- many bits thing has, and whether it goes in a floating-point +-- register. By contrast, the distinction between GcPtr and +-- GcNonPtr is of interest to only a few parts of the code generator. + +-------- Equality on CmmType -------------- +-- CmmType is *not* an instance of Eq; sometimes we care about the +-- Gc/NonGc distinction, and sometimes we don't +-- So we use an explicit function to force you to think about it +cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality +cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 + +cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool + -- This equality is temporary; used in CmmLint + -- but the RTS files are not yet well-typed wrt pointers +cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) + = c1 `weak_eq` c2 && w1==w2 + where + weak_eq :: CmmCat -> CmmCat -> Bool + FloatCat `weak_eq` FloatCat = True + FloatCat `weak_eq` _other = False + _other `weak_eq` FloatCat = False + (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2 + && cat1 `weak_eq` cat2 + (VecCat {}) `weak_eq` _other = False + _other `weak_eq` (VecCat {}) = False + _word1 `weak_eq` _word2 = True -- Ignores GcPtr + +--- Simple operations on CmmType ----- +typeWidth :: CmmType -> Width +typeWidth (CmmType _ w) = w + +cmmBits, cmmFloat :: Width -> CmmType +cmmBits = CmmType BitsCat +cmmFloat = CmmType FloatCat + +-------- Common CmmTypes ------------ +-- Floats and words of specific widths +b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType +b8 = cmmBits W8 +b16 = cmmBits W16 +b32 = cmmBits W32 +b64 = cmmBits W64 +b128 = cmmBits W128 +b256 = cmmBits W256 +b512 = cmmBits W512 +f32 = cmmFloat W32 +f64 = cmmFloat W64 + +-- CmmTypes of native word widths +bWord :: Platform -> CmmType +bWord platform = cmmBits (wordWidth platform) + +bHalfWord :: Platform -> CmmType +bHalfWord platform = cmmBits (halfWordWidth platform) + +gcWord :: Platform -> CmmType +gcWord platform = CmmType GcPtrCat (wordWidth platform) + +cInt :: DynFlags -> CmmType +cInt dflags = cmmBits (cIntWidth dflags) + +------------ Predicates ---------------- +isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool +isFloatType (CmmType FloatCat _) = True +isFloatType _other = False + +isGcPtrType (CmmType GcPtrCat _) = True +isGcPtrType _other = False + +isBitsType (CmmType BitsCat _) = True +isBitsType _ = False + +isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool +-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) +-- isFloat32 and 64 are obvious + +isWord64 (CmmType BitsCat W64) = True +isWord64 (CmmType GcPtrCat W64) = True +isWord64 _other = False + +isWord32 (CmmType BitsCat W32) = True +isWord32 (CmmType GcPtrCat W32) = True +isWord32 _other = False + +isFloat32 (CmmType FloatCat W32) = True +isFloat32 _other = False + +isFloat64 (CmmType FloatCat W64) = True +isFloat64 _other = False + +----------------------------------------------------------------------------- +-- Width +----------------------------------------------------------------------------- + +data Width = W8 | W16 | W32 | W64 + | W128 + | W256 + | W512 + deriving (Eq, Ord, Show) + +instance Outputable Width where + ppr rep = ptext (mrStr rep) + +mrStr :: Width -> PtrString +mrStr = sLit . show + + +-------- Common Widths ------------ +wordWidth :: Platform -> Width +wordWidth platform = case platformWordSize platform of + PW4 -> W32 + PW8 -> W64 + +halfWordWidth :: Platform -> Width +halfWordWidth platform = case platformWordSize platform of + PW4 -> W16 + PW8 -> W32 + +halfWordMask :: Platform -> Integer +halfWordMask platform = case platformWordSize platform of + PW4 -> 0xFFFF + PW8 -> 0xFFFFFFFF + +-- cIntRep is the Width for a C-language 'int' +cIntWidth :: DynFlags -> Width +cIntWidth dflags = case cINT_SIZE dflags of + 4 -> W32 + 8 -> W64 + s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) + +widthInBits :: Width -> Int +widthInBits W8 = 8 +widthInBits W16 = 16 +widthInBits W32 = 32 +widthInBits W64 = 64 +widthInBits W128 = 128 +widthInBits W256 = 256 +widthInBits W512 = 512 + + +widthInBytes :: Width -> Int +widthInBytes W8 = 1 +widthInBytes W16 = 2 +widthInBytes W32 = 4 +widthInBytes W64 = 8 +widthInBytes W128 = 16 +widthInBytes W256 = 32 +widthInBytes W512 = 64 + + +widthFromBytes :: Int -> Width +widthFromBytes 1 = W8 +widthFromBytes 2 = W16 +widthFromBytes 4 = W32 +widthFromBytes 8 = W64 +widthFromBytes 16 = W128 +widthFromBytes 32 = W256 +widthFromBytes 64 = W512 + +widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) + +-- log_2 of the width in bytes, useful for generating shifts. +widthInLog :: Width -> Int +widthInLog W8 = 0 +widthInLog W16 = 1 +widthInLog W32 = 2 +widthInLog W64 = 3 +widthInLog W128 = 4 +widthInLog W256 = 5 +widthInLog W512 = 6 + + +-- widening / narrowing + +narrowU :: Width -> Integer -> Integer +narrowU W8 x = fromIntegral (fromIntegral x :: Word8) +narrowU W16 x = fromIntegral (fromIntegral x :: Word16) +narrowU W32 x = fromIntegral (fromIntegral x :: Word32) +narrowU W64 x = fromIntegral (fromIntegral x :: Word64) +narrowU _ _ = panic "narrowTo" + +narrowS :: Width -> Integer -> Integer +narrowS W8 x = fromIntegral (fromIntegral x :: Int8) +narrowS W16 x = fromIntegral (fromIntegral x :: Int16) +narrowS W32 x = fromIntegral (fromIntegral x :: Int32) +narrowS W64 x = fromIntegral (fromIntegral x :: Int64) +narrowS _ _ = panic "narrowTo" + +----------------------------------------------------------------------------- +-- SIMD +----------------------------------------------------------------------------- + +type Length = Int + +vec :: Length -> CmmType -> CmmType +vec l (CmmType cat w) = CmmType (VecCat l cat) vecw + where + vecw :: Width + vecw = widthFromBytes (l*widthInBytes w) + +vec2, vec4, vec8, vec16 :: CmmType -> CmmType +vec2 = vec 2 +vec4 = vec 4 +vec8 = vec 8 +vec16 = vec 16 + +vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType +vec2f64 = vec 2 f64 +vec2b64 = vec 2 b64 +vec4f32 = vec 4 f32 +vec4b32 = vec 4 b32 +vec8b16 = vec 8 b16 +vec16b8 = vec 16 b8 + +cmmVec :: Int -> CmmType -> CmmType +cmmVec n (CmmType cat w) = + CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w)) + +vecLength :: CmmType -> Length +vecLength (CmmType (VecCat l _) _) = l +vecLength _ = panic "vecLength: not a vector" + +vecElemType :: CmmType -> CmmType +vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw + where + scalw :: Width + scalw = widthFromBytes (widthInBytes w `div` l) +vecElemType _ = panic "vecElemType: not a vector" + +isVecType :: CmmType -> Bool +isVecType (CmmType (VecCat {}) _) = True +isVecType _ = False + +------------------------------------------------------------------------- +-- Hints + +-- Hints are extra type information we attach to the arguments and +-- results of a foreign call, where more type information is sometimes +-- needed by the ABI to make the correct kind of call. + +data ForeignHint + = NoHint | AddrHint | SignedHint + deriving( Eq ) + -- Used to give extra per-argument or per-result + -- information needed by foreign calling conventions + +------------------------------------------------------------------------- + +-- These don't really belong here, but I don't know where is best to +-- put them. + +rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType +rEP_CostCentreStack_mem_alloc dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) + where pc = platformConstants dflags + +rEP_CostCentreStack_scc_count :: DynFlags -> CmmType +rEP_CostCentreStack_scc_count dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) + where pc = platformConstants dflags + +rEP_StgEntCounter_allocs :: DynFlags -> CmmType +rEP_StgEntCounter_allocs dflags + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) + where pc = platformConstants dflags + +rEP_StgEntCounter_allocd :: DynFlags -> CmmType +rEP_StgEntCounter_allocd dflags + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc)) + where pc = platformConstants dflags + +------------------------------------------------------------------------- +{- Note [Signed vs unsigned] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +Should a CmmType include a signed vs. unsigned distinction? + +This is very much like a "hint" in C-- terminology: it isn't necessary +in order to generate correct code, but it might be useful in that the +compiler can generate better code if it has access to higher-level +hints about data. This is important at call boundaries, because the +definition of a function is not visible at all of its call sites, so +the compiler cannot infer the hints. + +Here in Cmm, we're taking a slightly different approach. We include +the int vs. float hint in the CmmType, because (a) the majority of +platforms have a strong distinction between float and int registers, +and (b) we don't want to do any heavyweight hint-inference in the +native code backend in order to get good code. We're treating the +hint more like a type: our Cmm is always completely consistent with +respect to hints. All coercions between float and int are explicit. + +What about the signed vs. unsigned hint? This information might be +useful if we want to keep sub-word-sized values in word-size +registers, which we must do if we only have word-sized registers. + +On such a system, there are two straightforward conventions for +representing sub-word-sized values: + +(a) Leave the upper bits undefined. Comparison operations must + sign- or zero-extend both operands before comparing them, + depending on whether the comparison is signed or unsigned. + +(b) Always keep the values sign- or zero-extended as appropriate. + Arithmetic operations must narrow the result to the appropriate + size. + +A clever compiler might not use either (a) or (b) exclusively, instead +it would attempt to minimize the coercions by analysis: the same kind +of analysis that propagates hints around. In Cmm we don't want to +have to do this, so we plump for having richer types and keeping the +type information consistent. + +If signed/unsigned hints are missing from CmmType, then the only +choice we have is (a), because we don't know whether the result of an +operation should be sign- or zero-extended. + +Many architectures have extending load operations, which work well +with (b). To make use of them with (a), you need to know whether the +value is going to be sign- or zero-extended by an enclosing comparison +(for example), which involves knowing above the context. This is +doable but more complex. + +Further complicating the issue is foreign calls: a foreign calling +convention can specify that signed 8-bit quantities are passed as +sign-extended 32 bit quantities, for example (this is the case on the +PowerPC). So we *do* need sign information on foreign call arguments. + +Pros for adding signed vs. unsigned to CmmType: + + - It would let us use convention (b) above, and get easier + code generation for extending loads. + + - Less information required on foreign calls. + + - MachOp type would be simpler + +Cons: + + - More complexity + + - What is the CmmType for a VanillaReg? Currently it is + always wordRep, but now we have to decide whether it is + signed or unsigned. The same VanillaReg can thus have + different CmmType in different parts of the program. + + - Extra coercions cluttering up expressions. + +Currently for GHC, the foreign call point is moot, because we do our +own promotion of sub-word-sized values to word-sized values. The Int8 +type is represented by an Int# which is kept sign-extended at all times +(this is slightly naughty, because we're making assumptions about the +C calling convention rather early on in the compiler). However, given +this, the cons outweigh the pros. + +-} + diff --git a/GHC/Cmm/Utils.hs b/GHC/Cmm/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Utils.hs @@ -0,0 +1,618 @@ +{-# LANGUAGE GADTs, RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- Cmm utilities. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.Cmm.Utils( + -- CmmType + primRepCmmType, slotCmmType, slotForeignHint, + typeCmmType, typeForeignHint, primRepForeignHint, + + -- CmmLit + zeroCLit, mkIntCLit, + mkWordCLit, packHalfWordsCLit, + mkByteStringCLit, mkFileEmbedLit, + mkDataLits, mkRODataLits, + mkStgWordCLit, + + -- CmmExpr + mkIntExpr, zeroExpr, + mkLblExpr, + cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, + cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, + cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, + cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, + cmmNegate, + cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, + cmmSLtWord, + cmmNeWord, cmmEqWord, + cmmOrWord, cmmAndWord, + cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord, + cmmToWord, + + cmmMkAssign, + + isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr, + + baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, + currentTSOExpr, currentNurseryExpr, cccsExpr, + + -- Tagging + cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, + cmmConstrTag1, + + -- Overlap and usage + regsOverlap, regUsedIn, + + -- Liveness and bitmaps + mkLiveness, + + -- * Operations that probably don't belong here + modifyGraph, + + ofBlockMap, toBlockMap, + ofBlockList, toBlockList, bodyToBlockList, + toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, + foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1, + + -- * Ticks + blockTicks + ) where + +import GHC.Prelude + +import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) +import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) + +import GHC.Platform +import GHC.Runtime.Heap.Layout +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Types.Unique +import GHC.Platform.Regs + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Bits +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections + +--------------------------------------------------- +-- +-- CmmTypes +-- +--------------------------------------------------- + +primRepCmmType :: Platform -> PrimRep -> CmmType +primRepCmmType platform = \case + VoidRep -> panic "primRepCmmType:VoidRep" + LiftedRep -> gcWord platform + UnliftedRep -> gcWord platform + IntRep -> bWord platform + WordRep -> bWord platform + Int8Rep -> b8 + Word8Rep -> b8 + Int16Rep -> b16 + Word16Rep -> b16 + Int32Rep -> b32 + Word32Rep -> b32 + Int64Rep -> b64 + Word64Rep -> b64 + AddrRep -> bWord platform + FloatRep -> f32 + DoubleRep -> f64 + (VecRep len rep) -> vec len (primElemRepCmmType rep) + +slotCmmType :: Platform -> SlotTy -> CmmType +slotCmmType platform = \case + PtrUnliftedSlot -> gcWord platform + PtrLiftedSlot -> gcWord platform + WordSlot -> bWord platform + Word64Slot -> b64 + FloatSlot -> f32 + DoubleSlot -> f64 + +primElemRepCmmType :: PrimElemRep -> CmmType +primElemRepCmmType Int8ElemRep = b8 +primElemRepCmmType Int16ElemRep = b16 +primElemRepCmmType Int32ElemRep = b32 +primElemRepCmmType Int64ElemRep = b64 +primElemRepCmmType Word8ElemRep = b8 +primElemRepCmmType Word16ElemRep = b16 +primElemRepCmmType Word32ElemRep = b32 +primElemRepCmmType Word64ElemRep = b64 +primElemRepCmmType FloatElemRep = f32 +primElemRepCmmType DoubleElemRep = f64 + +typeCmmType :: Platform -> UnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) + +primRepForeignHint :: PrimRep -> ForeignHint +primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" +primRepForeignHint LiftedRep = AddrHint +primRepForeignHint UnliftedRep = AddrHint +primRepForeignHint IntRep = SignedHint +primRepForeignHint Int8Rep = SignedHint +primRepForeignHint Int16Rep = SignedHint +primRepForeignHint Int32Rep = SignedHint +primRepForeignHint Int64Rep = SignedHint +primRepForeignHint WordRep = NoHint +primRepForeignHint Word8Rep = NoHint +primRepForeignHint Word16Rep = NoHint +primRepForeignHint Word32Rep = NoHint +primRepForeignHint Word64Rep = NoHint +primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg +primRepForeignHint FloatRep = NoHint +primRepForeignHint DoubleRep = NoHint +primRepForeignHint (VecRep {}) = NoHint + +slotForeignHint :: SlotTy -> ForeignHint +slotForeignHint PtrLiftedSlot = AddrHint +slotForeignHint PtrUnliftedSlot = AddrHint +slotForeignHint WordSlot = NoHint +slotForeignHint Word64Slot = NoHint +slotForeignHint FloatSlot = NoHint +slotForeignHint DoubleSlot = NoHint + +typeForeignHint :: UnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRep1 + +--------------------------------------------------- +-- +-- CmmLit +-- +--------------------------------------------------- + +-- XXX: should really be Integer, since Int doesn't necessarily cover +-- the full range of target Ints. +mkIntCLit :: Platform -> Int -> CmmLit +mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform) + +mkIntExpr :: Platform -> Int -> CmmExpr +mkIntExpr platform i = CmmLit $! mkIntCLit platform i + +zeroCLit :: Platform -> CmmLit +zeroCLit platform = CmmInt 0 (wordWidth platform) + +zeroExpr :: Platform -> CmmExpr +zeroExpr platform = CmmLit (zeroCLit platform) + +mkWordCLit :: Platform -> Integer -> CmmLit +mkWordCLit platform wd = CmmInt wd (wordWidth platform) + +-- | We make a top-level decl for the string, and return a label pointing to it +mkByteStringCLit + :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) +mkByteStringCLit lbl bytes + = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes]) + where + -- This can not happen for String literals (as there \NUL is replaced by + -- C0 80). However, it can happen with Addr# literals. + sec = if 0 `BS.elem` bytes then ReadOnlyData else CString + +-- | We make a top-level decl for the embedded binary file, and return a label pointing to it +mkFileEmbedLit + :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) +mkFileEmbedLit lbl path + = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path])) + + +-- | Build a data-segment data block +mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt +mkDataLits section lbl lits + = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits) + +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt +-- Build a read-only data block +mkRODataLits lbl lits + = mkDataLits section lbl lits + where + section | any needsRelocation lits = Section RelocatableReadOnlyData lbl + | otherwise = Section ReadOnlyData lbl + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False + +mkStgWordCLit :: Platform -> StgWord -> CmmLit +mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform) + +packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit +-- Make a single word literal in which the lower_half_word is +-- at the lower address, and the upper_half_word is at the +-- higher address +-- ToDo: consider using half-word lits instead +-- but be careful: that's vulnerable when reversed +packHalfWordsCLit platform lower_half_word upper_half_word + = case platformByteOrder platform of + BigEndian -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u) + LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform)) + where l = fromStgHalfWord lower_half_word + u = fromStgHalfWord upper_half_word + +--------------------------------------------------- +-- +-- CmmExpr +-- +--------------------------------------------------- + +mkLblExpr :: CLabel -> CmmExpr +mkLblExpr lbl = CmmLit (CmmLabel lbl) + +cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +-- assumes base and offset have the same CmmType +cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n) +cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off] + +cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr +cmmOffset _platform e 0 = e +cmmOffset platform e byte_off = case e of + CmmReg reg -> cmmRegOff reg byte_off + CmmRegOff reg m -> cmmRegOff reg (m+byte_off) + CmmLit lit -> CmmLit (cmmOffsetLit lit byte_off) + CmmStackSlot area off -> CmmStackSlot area (off - byte_off) + -- note stack area offsets increase towards lower addresses + CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)] + -> CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off) rep)] + _ -> CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)] + where width = cmmExprWidth platform e + +-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. +cmmRegOff :: CmmReg -> Int -> CmmExpr +cmmRegOff reg 0 = CmmReg reg +cmmRegOff reg byte_off = CmmRegOff reg byte_off + +cmmOffsetLit :: CmmLit -> Int -> CmmLit +cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off +cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) +cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off + = CmmLabelDiffOff l1 l2 (m+byte_off) w +cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep +cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) + +cmmLabelOff :: CLabel -> Int -> CmmLit +-- Smart constructor for CmmLabelOff +cmmLabelOff lbl 0 = CmmLabel lbl +cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off + +-- | Useful for creating an index into an array, with a statically known offset. +-- The type is the element type; used for making the multiplier +cmmIndex :: Platform + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> Int -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width) + +-- | Useful for creating an index into an array, with an unknown offset. +cmmIndexExpr :: Platform + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> CmmExpr -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n) +cmmIndexExpr platform width base idx = + cmmOffsetExpr platform base byte_off + where + idx_w = cmmExprWidth platform idx + byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)] + +cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr +cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty + +-- The "B" variants take byte offsets +cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr +cmmRegOffB = cmmRegOff + +cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr +cmmOffsetB = cmmOffset + +cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprB = cmmOffsetExpr + +cmmLabelOffB :: CLabel -> ByteOff -> CmmLit +cmmLabelOffB = cmmLabelOff + +cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit +cmmOffsetLitB = cmmOffsetLit + +----------------------- +-- The "W" variants take word offsets + +cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +-- The second arg is a *word* offset; need to change it to bytes +cmmOffsetExprW platform e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n) +cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off + +cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr +cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n) + +cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr +cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off) + +cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit +cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off) + +cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit +cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off) + +cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr +cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty + +----------------------- +cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, + cmmSLtWord, + cmmNeWord, cmmEqWord, + cmmOrWord, cmmAndWord, + cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord + :: Platform -> CmmExpr -> CmmExpr -> CmmExpr +cmmOrWord platform e1 e2 = CmmMachOp (mo_wordOr platform) [e1, e2] +cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2] +cmmNeWord platform e1 e2 = CmmMachOp (mo_wordNe platform) [e1, e2] +cmmEqWord platform e1 e2 = CmmMachOp (mo_wordEq platform) [e1, e2] +cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2] +cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2] +cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2] +cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2] +cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2] +cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2] +cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2] +cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2] +cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2] + +cmmNegate :: Platform -> CmmExpr -> CmmExpr +cmmNegate platform = \case + (CmmLit (CmmInt n rep)) + -> CmmLit (CmmInt (-n) rep) + e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e] + +cmmToWord :: Platform -> CmmExpr -> CmmExpr +cmmToWord platform e + | w == word = e + | otherwise = CmmMachOp (MO_UU_Conv w word) [e] + where + w = cmmExprWidth platform e + word = wordWidth platform + +cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr) +cmmMkAssign platform expr uq = + let !ty = cmmExprType platform expr + reg = (CmmLocal (LocalReg uq ty)) + in (CmmAssign reg expr, CmmReg reg) + + +--------------------------------------------------- +-- +-- CmmExpr predicates +-- +--------------------------------------------------- + +isTrivialCmmExpr :: CmmExpr -> Bool +isTrivialCmmExpr (CmmLoad _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True +isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" + +hasNoGlobalRegs :: CmmExpr -> Bool +hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e +hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es +hasNoGlobalRegs (CmmLit _) = True +hasNoGlobalRegs (CmmReg (CmmLocal _)) = True +hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True +hasNoGlobalRegs _ = False + +isLit :: CmmExpr -> Bool +isLit (CmmLit _) = True +isLit _ = False + +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _ = False + +--------------------------------------------------- +-- +-- Tagging +-- +--------------------------------------------------- + +-- Tag bits mask +cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr +cmmTagMask dflags = mkIntExpr (targetPlatform dflags) (tAG_MASK dflags) +cmmPointerMask dflags = mkIntExpr (targetPlatform dflags) (complement (tAG_MASK dflags)) + +-- Used to untag a possibly tagged pointer +-- A static label need not be untagged +cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr +cmmUntag _ e@(CmmLit (CmmLabel _)) = e +-- Default case +cmmUntag dflags e = cmmAndWord platform e (cmmPointerMask dflags) + where platform = targetPlatform dflags + +-- Test if a closure pointer is untagged +cmmIsTagged dflags e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask dflags)) (zeroExpr platform) + where platform = targetPlatform dflags + +-- Get constructor tag, but one based. +cmmConstrTag1 dflags e = cmmAndWord platform e (cmmTagMask dflags) + where platform = targetPlatform dflags + + +----------------------------------------------------------------------------- +-- Overlap and usage + +-- | Returns True if the two STG registers overlap on the specified +-- platform, in the sense that writing to one will clobber the +-- other. This includes the case that the two registers are the same +-- STG register. See Note [Overlapping global registers] for details. +regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool +regsOverlap platform (CmmGlobal g) (CmmGlobal g') + | Just real <- globalRegMaybe platform g, + Just real' <- globalRegMaybe platform g', + real == real' + = True +regsOverlap _ reg reg' = reg == reg' + +-- | Returns True if the STG register is used by the expression, in +-- the sense that a store to the register might affect the value of +-- the expression. +-- +-- We must check for overlapping registers and not just equal +-- registers here, otherwise CmmSink may incorrectly reorder +-- assignments that conflict due to overlap. See #10521 and Note +-- [Overlapping global registers]. +regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool +regUsedIn platform = regUsedIn_ where + _ `regUsedIn_` CmmLit _ = False + reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e + reg `regUsedIn_` CmmReg reg' = regsOverlap platform reg reg' + reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg' + reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es + _ `regUsedIn_` CmmStackSlot _ _ = False + +-------------------------------------------- +-- +-- mkLiveness +-- +--------------------------------------------- + +mkLiveness :: Platform -> [LocalReg] -> Liveness +mkLiveness _ [] = [] +mkLiveness platform (reg:regs) + = bits ++ mkLiveness platform regs + where + word_size = platformWordSizeInBytes platform + sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1) + `quot` word_size + -- number of words, rounded up + bits = replicate sizeW is_non_ptr -- True <=> Non Ptr + + is_non_ptr = not $ isGcPtrType (localRegType reg) + + +-- ============================================== - +-- ============================================== - +-- ============================================== - + +--------------------------------------------------- +-- +-- Manipulating CmmGraphs +-- +--------------------------------------------------- + +modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' +modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} + +toBlockMap :: CmmGraph -> LabelMap CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph +ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} + +toBlockList :: CmmGraph -> [CmmBlock] +toBlockList g = mapElems $ toBlockMap g + +-- | like 'toBlockList', but the entry block always comes first +toBlockListEntryFirst :: CmmGraph -> [CmmBlock] +toBlockListEntryFirst g + | mapNull m = [] + | otherwise = entry_block : others + where + m = toBlockMap g + entry_id = g_entry g + Just entry_block = mapLookup entry_id m + others = filter ((/= entry_id) . entryLabel) (mapElems m) + +-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks +-- so that the false case of a conditional jumps to the next block in the output +-- list of blocks. This matches the way OldCmm blocks were output since in +-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches +-- have both true and false successors. Block ordering can make a big difference +-- in performance in the LLVM backend. Note that we rely crucially on the order +-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode +-- defined in "GHC.Cmm.Node". -GBM +toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] +toBlockListEntryFirstFalseFallthrough g + | mapNull m = [] + | otherwise = dfs setEmpty [entry_block] + where + m = toBlockMap g + entry_id = g_entry g + Just entry_block = mapLookup entry_id m + + dfs :: LabelSet -> [CmmBlock] -> [CmmBlock] + dfs _ [] = [] + dfs visited (block:bs) + | id `setMember` visited = dfs visited bs + | otherwise = block : dfs (setInsert id visited) bs' + where id = entryLabel block + bs' = foldr add_id bs (successors block) + add_id id bs = case mapLookup id m of + Just b -> b : bs + Nothing -> bs + +ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph +ofBlockList entry blocks = CmmGraph { g_entry = entry + , g_graph = GMany NothingO body NothingO } + where body = foldr addBlock emptyBody blocks + +bodyToBlockList :: Body CmmNode -> [CmmBlock] +bodyToBlockList body = mapElems body + +mapGraphNodes :: ( CmmNode C O -> CmmNode C O + , CmmNode O O -> CmmNode O O + , CmmNode O C -> CmmNode O C) + -> CmmGraph -> CmmGraph +mapGraphNodes funs@(mf,_,_) g = + ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $ + mapMap (mapBlock3' funs) $ toBlockMap g + +mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph +mapGraphNodes1 f = modifyGraph (mapGraph f) + + +foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a +foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g + +revPostorder :: CmmGraph -> [CmmBlock] +revPostorder g = {-# SCC "revPostorder" #-} + revPostorderFrom (toBlockMap g) (g_entry g) + +------------------------------------------------- +-- Tick utilities + +-- | Extract all tick annotations from the given block +blockTicks :: Block CmmNode C C -> [CmmTickish] +blockTicks b = reverse $ foldBlockNodesF goStmt b [] + where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish] + goStmt (CmmTick t) ts = t:ts + goStmt _other ts = ts + + +-- ----------------------------------------------------------------------------- +-- Access to common global registers + +baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, + spLimExpr, hpLimExpr, cccsExpr :: CmmExpr +baseExpr = CmmReg baseReg +spExpr = CmmReg spReg +spLimExpr = CmmReg spLimReg +hpExpr = CmmReg hpReg +hpLimExpr = CmmReg hpLimReg +currentTSOExpr = CmmReg currentTSOReg +currentNurseryExpr = CmmReg currentNurseryReg +cccsExpr = CmmReg cccsReg diff --git a/GHC/CmmToAsm.hs b/GHC/CmmToAsm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm.hs @@ -0,0 +1,1246 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- This is the top-level module in the native code generator. +-- +-- ----------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms, + DeriveFunctor #-} + +#if !defined(GHC_LOADED_INTO_GHCI) +{-# LANGUAGE UnboxedTuples #-} +#endif + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.CmmToAsm ( + -- * Module entry point + nativeCodeGen + + -- * Test-only exports: see trac #12744 + -- used by testGraphNoSpills, which needs to access + -- the register allocator intermediate data structures + -- cmmNativeGen emits + , cmmNativeGen + , NcgImpl(..) + , x86NcgImpl + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import qualified GHC.CmmToAsm.X86.CodeGen as X86.CodeGen +import qualified GHC.CmmToAsm.X86.Regs as X86.Regs +import qualified GHC.CmmToAsm.X86.Instr as X86.Instr +import qualified GHC.CmmToAsm.X86.Ppr as X86.Ppr + +import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC.CodeGen +import qualified GHC.CmmToAsm.SPARC.Regs as SPARC.Regs +import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr +import qualified GHC.CmmToAsm.SPARC.Ppr as SPARC.Ppr +import qualified GHC.CmmToAsm.SPARC.ShortcutJump as SPARC.ShortcutJump +import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC.CodeGen.Expand + +import qualified GHC.CmmToAsm.PPC.CodeGen as PPC.CodeGen +import qualified GHC.CmmToAsm.PPC.Regs as PPC.Regs +import qualified GHC.CmmToAsm.PPC.RegInfo as PPC.RegInfo +import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr +import qualified GHC.CmmToAsm.PPC.Ppr as PPC.Ppr + +import GHC.CmmToAsm.Reg.Liveness +import qualified GHC.CmmToAsm.Reg.Linear as Linear + +import qualified GHC.Data.Graph.Color as Color +import qualified GHC.CmmToAsm.Reg.Graph as Color +import qualified GHC.CmmToAsm.Reg.Graph.Stats as Color +import qualified GHC.CmmToAsm.Reg.Graph.TrivColorable as Color + +import GHC.Utils.Asm +import GHC.CmmToAsm.Reg.Target +import GHC.Platform +import GHC.CmmToAsm.BlockLayout as BlockLayout +import GHC.Settings.Config +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.PIC +import GHC.Platform.Reg +import GHC.Platform.Reg.Class (RegClass) +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Dwarf +import GHC.CmmToAsm.Config +import GHC.Cmm.DebugBlock + +import GHC.Cmm.BlockId +import GHC.StgToCmm.CgUtils ( fixStgRegisters ) +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Opt ( cmmMachOpFold ) +import GHC.Cmm.Ppr +import GHC.Cmm.CLabel + +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Driver.Session +import GHC.Utils.Misc + +import GHC.Types.Basic ( Alignment ) +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.BufHandle +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Types.Unique.Set +import GHC.Utils.Error +import GHC.Unit +import GHC.Data.Stream (Stream) +import qualified GHC.Data.Stream as Stream + +-- DEBUGGING ONLY +--import GHC.Data.OrdList + +import Data.List +import Data.Maybe +import Data.Ord ( comparing ) +import Control.Exception +import Control.Monad +import System.IO + +{- +The native-code generator has machine-independent and +machine-dependent modules. + +This module ("AsmCodeGen") is the top-level machine-independent +module. Before entering machine-dependent land, we do some +machine-independent optimisations (defined below) on the +'CmmStmts's. + +We convert to the machine-specific 'Instr' datatype with +'cmmCodeGen', assuming an infinite supply of registers. We then use +a machine-independent register allocator ('regAlloc') to rejoin +reality. Obviously, 'regAlloc' has machine-specific helper +functions (see about "RegAllocInfo" below). + +Finally, we order the basic blocks of the function so as to minimise +the number of jumps between blocks, by utilising fallthrough wherever +possible. + +The machine-dependent bits break down as follows: + + * ["MachRegs"] Everything about the target platform's machine + registers (and immediate operands, and addresses, which tend to + intermingle/interact with registers). + + * ["MachInstrs"] Includes the 'Instr' datatype (possibly should + have a module of its own), plus a miscellany of other things + (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) + + * ["MachCodeGen"] is where 'Cmm' stuff turns into + machine instructions. + + * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really + a 'SDoc'). + + * ["RegAllocInfo"] In the register allocator, we manipulate + 'MRegsState's, which are 'BitSet's, one bit per machine register. + When we want to say something about a specific machine register + (e.g., ``it gets clobbered by this instruction''), we set/unset + its bit. Obviously, we do this 'BitSet' thing for efficiency + reasons. + + The 'RegAllocInfo' module collects together the machine-specific + info needed to do register allocation. + + * ["RegisterAlloc"] The (machine-independent) register allocator. +-} + +-------------------- +nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply + -> Stream IO RawCmmGroup a + -> IO a +nativeCodeGen dflags this_mod modLoc h us cmms + = let config = initConfig dflags + platform = ncgPlatform config + nCG' :: ( Outputable statics, Outputable instr + , Outputable jumpDest, Instruction instr) + => NcgImpl statics instr jumpDest -> IO a + nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms + in case platformArch platform of + ArchX86 -> nCG' (x86NcgImpl config) + ArchX86_64 -> nCG' (x86_64NcgImpl config) + ArchPPC -> nCG' (ppcNcgImpl config) + ArchS390X -> panic "nativeCodeGen: No NCG for S390X" + ArchSPARC -> nCG' (sparcNcgImpl config) + ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64" + ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" + ArchAArch64 -> panic "nativeCodeGen: No NCG for AArch64" + ArchPPC_64 _ -> nCG' (ppcNcgImpl config) + ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" + ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" + ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" + ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" + ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" + +x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) + X86.Instr.Instr X86.Instr.JumpDest +x86NcgImpl config + = (x86_64NcgImpl config) + +x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) + X86.Instr.Instr X86.Instr.JumpDest +x86_64NcgImpl config + = NcgImpl { + ncgConfig = config + ,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config + ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId + ,canShortcut = X86.Instr.canShortcut + ,shortcutStatics = X86.Instr.shortcutStatics + ,shortcutJump = X86.Instr.shortcutJump + ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl config + ,maxSpillSlots = X86.Instr.maxSpillSlots config + ,allocatableRegs = X86.Regs.allocatableRegs platform + ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform + ,ncgExpandTop = id + ,ncgMakeFarBranches = const id + ,extractUnwindPoints = X86.CodeGen.extractUnwindPoints + ,invertCondBranches = X86.CodeGen.invertCondBranches + } + where + platform = ncgPlatform config + +ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest +ppcNcgImpl config + = NcgImpl { + ncgConfig = config + ,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config + ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId + ,canShortcut = PPC.RegInfo.canShortcut + ,shortcutStatics = PPC.RegInfo.shortcutStatics + ,shortcutJump = PPC.RegInfo.shortcutJump + ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl config + ,maxSpillSlots = PPC.Instr.maxSpillSlots config + ,allocatableRegs = PPC.Regs.allocatableRegs platform + ,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform + ,ncgExpandTop = id + ,ncgMakeFarBranches = PPC.Instr.makeFarBranches + ,extractUnwindPoints = const [] + ,invertCondBranches = \_ _ -> id + } + where + platform = ncgPlatform config + +sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest +sparcNcgImpl config + = NcgImpl { + ncgConfig = config + ,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr platform + ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId + ,canShortcut = SPARC.ShortcutJump.canShortcut + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics + ,shortcutJump = SPARC.ShortcutJump.shortcutJump + ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl config + ,maxSpillSlots = SPARC.Instr.maxSpillSlots config + ,allocatableRegs = SPARC.Regs.allocatableRegs + ,ncgAllocMoreStack = noAllocMoreStack + ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop + ,ncgMakeFarBranches = const id + ,extractUnwindPoints = const [] + ,invertCondBranches = \_ _ -> id + } + where + platform = ncgPlatform config + +-- +-- Allocating more stack space for spilling is currently only +-- supported for the linear register allocator on x86/x86_64, the rest +-- default to the panic below. To support allocating extra stack on +-- more platforms provide a definition of ncgAllocMoreStack. +-- +noAllocMoreStack :: Int -> NatCmmDecl statics instr + -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]) +noAllocMoreStack amount _ + = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n" + ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" + ++ " is a known limitation in the linear allocator.\n" + ++ "\n" + ++ " Try enabling the graph colouring allocator with -fregs-graph instead." + ++ " You can still file a bug report if you like.\n" + + +-- | Data accumulated during code generation. Mostly about statistics, +-- but also collects debug data for DWARF generation. +data NativeGenAcc statics instr + = NGS { ngs_imports :: ![[CLabel]] + , ngs_natives :: ![[NatCmmDecl statics instr]] + -- ^ Native code generated, for statistics. This might + -- hold a lot of data, so it is important to clear this + -- field as early as possible if it isn't actually + -- required. + , ngs_colorStats :: ![[Color.RegAllocStats statics instr]] + , ngs_linearStats :: ![[Linear.RegAllocStats]] + , ngs_labels :: ![Label] + , ngs_debug :: ![DebugBlock] + , ngs_dwarfFiles :: !DwarfFiles + , ngs_unwinds :: !(LabelMap [UnwindPoint]) + -- ^ see Note [Unwinding information in the NCG] + -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". + } + +{- +Note [Unwinding information in the NCG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Unwind information is a type of metadata which allows a debugging tool +to reconstruct the values of machine registers at the time a procedure was +entered. For the most part, the production of unwind information is handled by +the Cmm stage, where it is represented by CmmUnwind nodes. + +Unfortunately, the Cmm stage doesn't know everything necessary to produce +accurate unwinding information. For instance, the x86-64 calling convention +requires that the stack pointer be aligned to 16 bytes, which in turn means that +GHC must sometimes add padding to $sp prior to performing a foreign call. When +this happens unwind information must be updated accordingly. +For this reason, we make the NCG backends responsible for producing +unwinding tables (with the extractUnwindPoints function in NcgImpl). + +We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds +field of NativeGenAcc. This is a label map which contains an entry for each +procedure, containing a list of unwinding points (e.g. a label and an associated +unwinding table). + +See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". +-} + +nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest, + Instruction instr) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> Handle + -> UniqSupply + -> Stream IO RawCmmGroup a + -> IO a +nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms + = do + -- BufHandle is a performance hack. We could hide it inside + -- Pretty if it weren't for the fact that we do lots of little + -- printDocs here (in order to do codegen in constant space). + bufh <- newBufHandle h + let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty + (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us + cmms ngs0 + _ <- finishNativeGen dflags modLoc bufh us' ngs + return a + +finishNativeGen :: Instruction instr + => DynFlags + -> ModLocation + -> BufHandle + -> UniqSupply + -> NativeGenAcc statics instr + -> IO UniqSupply +finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs + = withTimingSilent dflags (text "NCG") (`seq` ()) $ do + -- Write debug data and finish + let emitDw = debugLevel dflags > 0 + us' <- if not emitDw then return us else do + (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs) + emitNativeCode dflags bufh dwarf + return us' + bFlush bufh + + -- dump global NCG stats for graph coloring allocator + let stats = concat (ngs_colorStats ngs) + unless (null stats) $ do + + -- build the global register conflict graph + let graphGlobal + = foldl' Color.union Color.initGraph + $ [ Color.raGraph stat + | stat@Color.RegAllocStatsStart{} <- stats] + + dump_stats (Color.pprStats stats graphGlobal) + + let platform = targetPlatform dflags + dumpIfSet_dyn dflags + Opt_D_dump_asm_conflicts "Register conflict graph" + FormatText + $ Color.dotGraph + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + $ graphGlobal + + + -- dump global NCG stats for linear allocator + let linearStats = concat (ngs_linearStats ngs) + unless (null linearStats) $ + dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) + + -- write out the imports + let ctx = initSDocContext dflags (mkCodeStyle AsmStyle) + printSDocLn ctx Pretty.LeftMode h + $ makeImportsDoc dflags (concat (ngs_imports ngs)) + return us' + where + dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify) + (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" + FormatText + +cmmNativeGenStream :: (Outputable statics, Outputable instr + ,Outputable jumpDest, Instruction instr) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> BufHandle + -> UniqSupply + -> Stream IO RawCmmGroup a + -> NativeGenAcc statics instr + -> IO (NativeGenAcc statics instr, UniqSupply, a) + +cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs + = do r <- Stream.runStream cmm_stream + case r of + Left a -> + return (ngs { ngs_imports = reverse $ ngs_imports ngs + , ngs_natives = reverse $ ngs_natives ngs + , ngs_colorStats = reverse $ ngs_colorStats ngs + , ngs_linearStats = reverse $ ngs_linearStats ngs + }, + us, + a) + Right (cmms, cmm_stream') -> do + (us', ngs'') <- + withTimingSilent + dflags + ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do + -- Generate debug information + let debugFlag = debugLevel dflags > 0 + !ndbgs | debugFlag = cmmDebugGen modLoc cmms + | otherwise = [] + dbgMap = debugToMap ndbgs + + -- Generate native code + (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h + dbgMap us cmms ngs 0 + + -- Link native code information into debug blocks + -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". + let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs + unless (null ldbgs) $ + dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText + (vcat $ map ppr ldbgs) + + -- Accumulate debug information for emission in finishNativeGen. + let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] } + return (us', ngs'') + + cmmNativeGenStream dflags this_mod modLoc ncgImpl h us' + cmm_stream' ngs'' + + where ncglabel = text "NCG" + +-- | Do native code generation on all these cmms. +-- +cmmNativeGens :: forall statics instr jumpDest. + (Outputable statics, Outputable instr + ,Outputable jumpDest, Instruction instr) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> BufHandle + -> LabelMap DebugBlock + -> UniqSupply + -> [RawCmmDecl] + -> NativeGenAcc statics instr + -> Int + -> IO (NativeGenAcc statics instr, UniqSupply) + +cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go + where + go :: UniqSupply -> [RawCmmDecl] + -> NativeGenAcc statics instr -> Int + -> IO (NativeGenAcc statics instr, UniqSupply) + + go us [] ngs !_ = + return (ngs, us) + + go us (cmm : cmms) ngs count = do + let fileIds = ngs_dwarfFiles ngs + (us', fileIds', native, imports, colorStats, linearStats, unwinds) + <- {-# SCC "cmmNativeGen" #-} + cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap + cmm count + + -- Generate .file directives for every new file that has been + -- used. Note that it is important that we generate these in + -- ascending order, as Clang's 3.6 assembler complains. + let newFileIds = sortBy (comparing snd) $ + nonDetEltsUFM $ fileIds' `minusUFM` fileIds + -- See Note [Unique Determinism and code generation] + pprDecl (f,n) = text "\t.file " <> ppr n <+> + pprFilePathString (unpackFS f) + + emitNativeCode dflags h $ vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDecl ncgImpl) native + + -- force evaluation all this stuff to avoid space leaks + {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) () + + let !labels' = if debugLevel dflags > 0 + then cmmDebugLabels isMetaInstr native else [] + !natives' = if dopt Opt_D_dump_asm_stats dflags + then native : ngs_natives ngs else [] + + mCon = maybe id (:) + ngs' = ngs{ ngs_imports = imports : ngs_imports ngs + , ngs_natives = natives' + , ngs_colorStats = colorStats `mCon` ngs_colorStats ngs + , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs + , ngs_labels = ngs_labels ngs ++ labels' + , ngs_dwarfFiles = fileIds' + , ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds + } + go us' cmms ngs' (count + 1) + + +emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO () +emitNativeCode dflags h sdoc = do + + let ctx = initSDocContext dflags (mkCodeStyle AsmStyle) + {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc + + -- dump native code + dumpIfSet_dyn dflags + Opt_D_dump_asm "Asm code" FormatASM + sdoc + +-- | Complete native code generation phase for a single top-level chunk of Cmm. +-- Dumping the output of each stage along the way. +-- Global conflict graph and NGC stats +cmmNativeGen + :: forall statics instr jumpDest. (Instruction instr, + Outputable statics, Outputable instr, Outputable jumpDest) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> UniqSupply + -> DwarfFiles + -> LabelMap DebugBlock + -> RawCmmDecl -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing + -> IO ( UniqSupply + , DwarfFiles + , [NatCmmDecl statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats] -- stats for the linear register allocators + , LabelMap [UnwindPoint] -- unwinding information for blocks + ) + +cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count + = do + let config = ncgConfig ncgImpl + let platform = ncgPlatform config + + let proc_name = case cmm of + (CmmProc _ entry_label _ _) -> ppr entry_label + _ -> text "DataChunk" + + -- rewrite assignments to global regs + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters dflags cmm + + -- cmm to cmm optimisations + let (opt_cmm, imports) = + {-# SCC "cmmToCmm" #-} + cmmToCmm config this_mod fixed_cmm + + dumpIfSet_dyn dflags + Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM + (pprCmmGroup [opt_cmm]) + + let cmmCfg = {-# SCC "getCFG" #-} + getCfgProc (cfgWeightInfo dflags) opt_cmm + + -- generate native code from cmm + let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) = + {-# SCC "genMachCode" #-} + initUs us $ genMachCode dflags this_mod modLoc + (cmmTopCodeGen ncgImpl) + fileIds dbgMap opt_cmm cmmCfg + + dumpIfSet_dyn dflags + Opt_D_dump_asm_native "Native code" FormatASM + (vcat $ map (pprNatCmmDecl ncgImpl) native) + + maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name + + -- tag instructions with register liveness information + -- also drops dead code. We don't keep the cfg in sync on + -- some backends, so don't use it there. + let livenessCfg = if backendMaintainsCfg platform + then Just nativeCfgWeights + else Nothing + let (withLiveness, usLive) = + {-# SCC "regLiveness" #-} + initUs usGen + $ mapM (cmmTopLiveness livenessCfg platform) native + + dumpIfSet_dyn dflags + Opt_D_dump_asm_liveness "Liveness annotations added" + FormatCMM + (vcat $ map ppr withLiveness) + + -- allocate registers + (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <- + if ( gopt Opt_RegsGraph dflags + || gopt Opt_RegsIterative dflags ) + then do + -- the regs usable for allocation + let (alloc_regs :: UniqFM RegClass (UniqSet RealReg)) + = foldr (\r -> plusUFM_C unionUniqSets + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) + emptyUFM + $ allocatableRegs ncgImpl + + -- do the graph coloring register allocation + let ((alloced, maybe_more_stack, regAllocStats), usAlloc) + = {-# SCC "RegAlloc-color" #-} + initUs usLive + $ Color.regAlloc + config + alloc_regs + (mkUniqSet [0 .. maxSpillSlots ncgImpl]) + (maxSpillSlots ncgImpl) + withLiveness + livenessCfg + + let ((alloced', stack_updt_blks), usAlloc') + = initUs usAlloc $ + case maybe_more_stack of + Nothing -> return (alloced, []) + Just amount -> do + (alloced',stack_updt_blks) <- unzip <$> + (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced) + return (alloced', concat stack_updt_blks ) + + + -- dump out what happened during register allocation + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + FormatCMM + (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc_stages "Build/spill stages" + FormatText + (vcat $ map (\(stage, stats) + -> text "# --------------------------" + $$ text "# cmm " <> int count <> text " Stage " <> int stage + $$ ppr stats) + $ zip [0..] regAllocStats) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just regAllocStats else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced', usAlloc' + , mPprStats + , Nothing + , [], stack_updt_blks) + + else do + -- do linear register allocation + let reg_alloc proc = do + (alloced, maybe_more_stack, ra_stats) <- + Linear.regAlloc config proc + case maybe_more_stack of + Nothing -> return ( alloced, ra_stats, [] ) + Just amount -> do + (alloced',stack_updt_blks) <- + ncgAllocMoreStack ncgImpl amount alloced + return (alloced', ra_stats, stack_updt_blks ) + + let ((alloced, regAllocStats, stack_updt_blks), usAlloc) + = {-# SCC "RegAlloc-linear" #-} + initUs usLive + $ liftM unzip3 + $ mapM reg_alloc withLiveness + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + FormatCMM + (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just (catMaybes regAllocStats) else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , Nothing + , mPprStats, (catMaybes regAllocStats) + , concat stack_updt_blks ) + + -- Fixupblocks the register allocator inserted (from, regMoves, to) + let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)] + cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats) + + let cfgWithFixupBlks = + (\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg + + -- Insert stack update blocks + let postRegCFG = + pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m )) + <*> cfgWithFixupBlks + <*> pure stack_updt_blks + + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + generateJumpTables ncgImpl alloced + + when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags + Opt_D_dump_cfg_weights "CFG Update information" + FormatText + ( text "stack:" <+> ppr stack_updt_blks $$ + text "linearAlloc:" <+> ppr cfgRegAllocUpdates ) + + ---- shortcut branches + let (shorted, postShortCFG) = + {-# SCC "shortcutBranches" #-} + shortcutBranches dflags ncgImpl tabled postRegCFG + + let optimizedCFG :: Maybe CFG + optimizedCFG = + optimizeCFG (gopt Opt_CmmStaticPred dflags) (cfgWeightInfo dflags) cmm <$!> postShortCFG + + maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name + + --TODO: Partially check validity of the cfg. + let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks + getBlks _ = [] + + when ( backendMaintainsCfg platform && + (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do + let blocks = concatMap getBlks shorted + let labels = setFromList $ fmap blockId blocks :: LabelSet + let cfg = fromJust optimizedCFG + return $! seq (sanityCheckCfg cfg labels $ + text "cfg not in lockstep") () + + ---- sequence blocks + let sequenced :: [NatCmmDecl statics instr] + sequenced = + checkLayout shorted $ + {-# SCC "sequenceBlocks" #-} + map (BlockLayout.sequenceTop + dflags + ncgImpl optimizedCFG) + shorted + + let branchOpt :: [NatCmmDecl statics instr] + branchOpt = + {-# SCC "invertCondBranches" #-} + map invert sequenced + where + invertConds :: LabelMap RawCmmStatics -> [NatBasicBlock instr] + -> [NatBasicBlock instr] + invertConds = invertCondBranches ncgImpl optimizedCFG + invert top@CmmData {} = top + invert (CmmProc info lbl live (ListGraph blocks)) = + CmmProc info lbl live (ListGraph $ invertConds info blocks) + + ---- expansion of SPARC synthetic instrs + let expanded = + {-# SCC "sparc_expand" #-} + ncgExpandTop ncgImpl branchOpt + --ncgExpandTop ncgImpl sequenced + + dumpIfSet_dyn dflags + Opt_D_dump_asm_expanded "Synthetic instructions expanded" + FormatCMM + (vcat $ map (pprNatCmmDecl ncgImpl) expanded) + + -- generate unwinding information from cmm + let unwinds :: BlockMap [UnwindPoint] + unwinds = + {-# SCC "unwindingInfo" #-} + foldl' addUnwind mapEmpty expanded + where + addUnwind acc proc = + acc `mapUnion` computeUnwinding dflags ncgImpl proc + + return ( usAlloc + , fileIds' + , expanded + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear + , unwinds ) + +maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO () +maybeDumpCfg _dflags Nothing _ _ = return () +maybeDumpCfg dflags (Just cfg) msg proc_name + | null cfg = return () + | otherwise + = dumpIfSet_dyn + dflags Opt_D_dump_cfg_weights msg + FormatText + (proc_name <> char ':' $$ pprEdgeWeights cfg) + +-- | Make sure all blocks we want the layout algorithm to place have been placed. +checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] + -> [NatCmmDecl statics instr] +checkLayout procsUnsequenced procsSequenced = + ASSERT2(setNull diff, + ppr "Block sequencing dropped blocks:" <> ppr diff) + procsSequenced + where + blocks1 = foldl' (setUnion) setEmpty $ + map getBlockIds procsUnsequenced :: LabelSet + blocks2 = foldl' (setUnion) setEmpty $ + map getBlockIds procsSequenced + diff = setDifference blocks1 blocks2 + + getBlockIds (CmmData _ _) = setEmpty + getBlockIds (CmmProc _ _ _ (ListGraph blocks)) = + setFromList $ map blockId blocks + +-- | Compute unwinding tables for the blocks of a procedure +computeUnwinding :: Instruction instr + => DynFlags -> NcgImpl statics instr jumpDest + -> NatCmmDecl statics instr + -- ^ the native code generated for the procedure + -> LabelMap [UnwindPoint] + -- ^ unwinding tables for all points of all blocks of the + -- procedure +computeUnwinding dflags _ _ + | debugLevel dflags == 0 = mapEmpty +computeUnwinding _ _ (CmmData _ _) = mapEmpty +computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) = + -- In general we would need to push unwinding information down the + -- block-level call-graph to ensure that we fully account for all + -- relevant register writes within a procedure. + -- + -- However, the only unwinding information that we care about in GHC is for + -- Sp. The fact that GHC.Cmm.LayoutStack already ensures that we have unwind + -- information at the beginning of every block means that there is no need + -- to perform this sort of push-down. + mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs) + | BasicBlock blk_lbl instrs <- blks ] + +-- | Build a doc for all the imports. +-- +makeImportsDoc :: DynFlags -> [CLabel] -> SDoc +makeImportsDoc dflags imports + = dyld_stubs imports + $$ + -- On recent versions of Darwin, the linker supports + -- dead-stripping of code and data on a per-symbol basis. + -- There's a hack to make this work in PprMach.pprNatCmmDecl. + (if platformHasSubsectionsViaSymbols platform + then text ".subsections_via_symbols" + else Outputable.empty) + $$ + -- On recent GNU ELF systems one can mark an object file + -- as not requiring an executable stack. If all objects + -- linked into a program have this note then the program + -- will not use an executable stack, which is good for + -- security. GHC generated code does not need an executable + -- stack so add the note in: + (if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits" + else Outputable.empty) + $$ + -- And just because every other compiler does, let's stick in + -- an identifier directive: .ident "GHC x.y.z" + (if platformHasIdentDirective platform + then let compilerIdent = text "GHC" <+> text cProjectVersion + in text ".ident" <+> doubleQuotes compilerIdent + else Outputable.empty) + + where + config = initConfig dflags + platform = ncgPlatform config + + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + dyld_stubs :: [CLabel] -> SDoc +{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $ + map head $ group $ sort imps-} + -- (Hack) sometimes two Labels pretty-print the same, but have + -- different uniques; so we compare their text versions... + dyld_stubs imps + | needImportedSymbols config + = vcat $ + (pprGotDeclaration config :) $ + map ( pprImportedSymbol dflags config . fst . head) $ + groupBy (\(_,a) (_,b) -> a == b) $ + sortBy (\(_,a) (_,b) -> compare a b) $ + map doPpr $ + imps + | otherwise + = Outputable.empty + + doPpr lbl = (lbl, renderWithStyle + (initSDocContext dflags astyle) + (pprCLabel dflags lbl)) + astyle = mkCodeStyle AsmStyle + +-- ----------------------------------------------------------------------------- +-- Generate jump tables + +-- Analyzes all native code and generates data sections for all jump +-- table instructions. +generateJumpTables + :: NcgImpl statics instr jumpDest + -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] +generateJumpTables ncgImpl xs = concatMap f xs + where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs + f p = [p] + g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) + +-- ----------------------------------------------------------------------------- +-- Shortcut branches + +shortcutBranches + :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags + -> NcgImpl statics instr jumpDest + -> [NatCmmDecl statics instr] + -> Maybe CFG + -> ([NatCmmDecl statics instr],Maybe CFG) + +shortcutBranches dflags ncgImpl tops weights + | gopt Opt_AsmShortcutting dflags + = ( map (apply_mapping ncgImpl mapping) tops' + , shortcutWeightMap mappingBid <$!> weights ) + | otherwise + = (tops, weights) + where + (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops + mapping = mapUnions mappings :: LabelMap jumpDest + mappingBid = fmap (getJumpDestBlockId ncgImpl) mapping + +build_mapping :: forall instr t d statics jumpDest. + NcgImpl statics instr jumpDest + -> GenCmmDecl d (LabelMap t) (ListGraph instr) + -> (GenCmmDecl d (LabelMap t) (ListGraph instr) + ,LabelMap jumpDest) +build_mapping _ top@(CmmData _ _) = (top, mapEmpty) +build_mapping _ (CmmProc info lbl live (ListGraph [])) + = (CmmProc info lbl live (ListGraph []), mapEmpty) +build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) + = (CmmProc info lbl live (ListGraph (head:others)), mapping) + -- drop the shorted blocks, but don't ever drop the first one, + -- because it is pointed to by a global label. + where + -- find all the blocks that just consist of a jump that can be + -- shorted. + -- Don't completely eliminate loops here -- that can leave a dangling jump! + shortcut_blocks :: [(BlockId, jumpDest)] + (_, shortcut_blocks, others) = + foldl' split (setEmpty :: LabelSet, [], []) blocks + split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) + | Just jd <- canShortcut ncgImpl insn + , Just dest <- getJumpDestBlockId ncgImpl jd + , not (has_info id) + , (setMember dest s) || dest == id -- loop checks + = (s, shortcut_blocks, b : others) + split (s, shortcut_blocks, others) (BasicBlock id [insn]) + | Just dest <- canShortcut ncgImpl insn + , not (has_info id) + = (setInsert id s, (id,dest) : shortcut_blocks, others) + split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) + + -- do not eliminate blocks that have an info table + has_info l = mapMember l info + + -- build a mapping from BlockId to JumpDest for shorting branches + mapping = mapFromList shortcut_blocks + +apply_mapping :: NcgImpl statics instr jumpDest + -> LabelMap jumpDest + -> GenCmmDecl statics h (ListGraph instr) + -> GenCmmDecl statics h (ListGraph instr) +apply_mapping ncgImpl ufm (CmmData sec statics) + = CmmData sec (shortcutStatics ncgImpl (\bid -> mapLookup bid ufm) statics) +apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map short_bb blocks) + where + short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns + short_insn i = shortcutJump ncgImpl (\bid -> mapLookup bid ufm) i + -- shortcutJump should apply the mapping repeatedly, + -- just in case we can short multiple branches. + +-- ----------------------------------------------------------------------------- +-- Instruction selection + +-- Native code instruction selection for a chunk of stix code. For +-- this part of the computation, we switch from the UniqSM monad to +-- the NatM monad. The latter carries not only a Unique, but also an +-- Int denoting the current C stack pointer offset in the generated +-- code; this is needed for creating correct spill offsets on +-- architectures which don't offer, or for which it would be +-- prohibitively expensive to employ, a frame pointer register. Viz, +-- x86. + +-- The offset is measured in bytes, and indicates the difference +-- between the current (simulated) C stack-ptr and the value it was at +-- the beginning of the block. For stacks which grow down, this value +-- should be either zero or negative. + +-- Along with the stack pointer offset, we also carry along a LabelMap of +-- DebugBlocks, which we read to generate .location directives. +-- +-- Switching between the two monads whilst carrying along the same +-- Unique supply breaks abstraction. Is that bad? + +genMachCode + :: DynFlags + -> Module -> ModLocation + -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) + -> DwarfFiles + -> LabelMap DebugBlock + -> RawCmmDecl + -> CFG + -> UniqSM + ( [NatCmmDecl statics instr] + , [CLabel] + , DwarfFiles + , CFG + ) + +genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg + = do { initial_us <- getUniqueSupplyM + ; let initial_st = mkNatM_State initial_us 0 dflags this_mod + modLoc fileIds dbgMap cmm_cfg + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) + final_delta = natm_delta final_st + final_imports = natm_imports final_st + final_cfg = natm_cfg final_st + ; if final_delta == 0 + then return (new_tops, final_imports + , natm_fileid final_st, final_cfg) + else pprPanic "genMachCode: nonzero final delta" (int final_delta) + } + +-- ----------------------------------------------------------------------------- +-- Generic Cmm optimiser + +{- +Here we do: + + (a) Constant folding + (c) Position independent code and dynamic linking + (i) introduce the appropriate indirections + and position independent refs + (ii) compile a list of imported symbols + (d) Some arch-specific optimizations + +(a) will be moving to the new Hoopl pipeline, however, (c) and +(d) are only needed by the native backend and will continue to live +here. + +Ideas for other things we could do (put these in Hoopl please!): + + - shortcut jumps-to-jumps + - simple CSE: if an expr is assigned to a temp, then replace later occs of + that expr with the temp, until the expr is no longer valid (can push through + temp assignments, and certain assigns to mem...) +-} + +cmmToCmm :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) +cmmToCmm _ _ top@(CmmData _ _) = (top, []) +cmmToCmm config this_mod (CmmProc info lbl live graph) + = runCmmOpt config this_mod $ + do blocks' <- mapM cmmBlockConFold (toBlockList graph) + return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') + +-- Avoids using unboxed tuples when loading into GHCi +#if !defined(GHC_LOADED_INTO_GHCI) + +type OptMResult a = (# a, [CLabel] #) + +pattern OptMResult :: a -> b -> (# a, b #) +pattern OptMResult x y = (# x, y #) +{-# COMPLETE OptMResult #-} +#else + +data OptMResult a = OptMResult !a ![CLabel] deriving (Functor) +#endif + +newtype CmmOptM a = CmmOptM (NCGConfig -> Module -> [CLabel] -> OptMResult a) + deriving (Functor) + +instance Applicative CmmOptM where + pure x = CmmOptM $ \_ _ imports -> OptMResult x imports + (<*>) = ap + +instance Monad CmmOptM where + (CmmOptM f) >>= g = + CmmOptM $ \config this_mod imports0 -> + case f config this_mod imports0 of + OptMResult x imports1 -> + case g x of + CmmOptM g' -> g' config this_mod imports1 + +instance CmmMakeDynamicReferenceM CmmOptM where + addImport = addImportCmmOpt + getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports + +addImportCmmOpt :: CLabel -> CmmOptM () +addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports) + +getCmmOptConfig :: CmmOptM NCGConfig +getCmmOptConfig = CmmOptM $ \config _ imports -> OptMResult config imports + +runCmmOpt :: NCGConfig -> Module -> CmmOptM a -> (a, [CLabel]) +runCmmOpt config this_mod (CmmOptM f) = + case f config this_mod [] of + OptMResult result imports -> (result, imports) + +cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock +cmmBlockConFold block = do + let (entry, middle, last) = blockSplit block + stmts = blockToList middle + stmts' <- mapM cmmStmtConFold stmts + last' <- cmmStmtConFold last + return $ blockJoin entry (blockFromList stmts') last' + +-- This does three optimizations, but they're very quick to check, so we don't +-- bother turning them off even when the Hoopl code is active. Since +-- this is on the old Cmm representation, we can't reuse the code either: +-- * reg = reg --> nop +-- * if 0 then jump --> nop +-- * if 1 then jump --> jump +-- We might be tempted to skip this step entirely of not Opt_PIC, but +-- there is some PowerPC code for the non-PIC case, which would also +-- have to be separated. +cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) +cmmStmtConFold stmt + = case stmt of + CmmAssign reg src + -> do src' <- cmmExprConFold DataReference src + return $ case src' of + CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") + new_src -> CmmAssign reg new_src + + CmmStore addr src + -> do addr' <- cmmExprConFold DataReference addr + src' <- cmmExprConFold DataReference src + return $ CmmStore addr' src' + + CmmCall { cml_target = addr } + -> do addr' <- cmmExprConFold JumpReference addr + return $ stmt { cml_target = addr' } + + CmmUnsafeForeignCall target regs args + -> do target' <- case target of + ForeignTarget e conv -> do + e' <- cmmExprConFold CallReference e + return $ ForeignTarget e' conv + PrimTarget _ -> + return target + args' <- mapM (cmmExprConFold DataReference) args + return $ CmmUnsafeForeignCall target' regs args' + + CmmCondBranch test true false likely + -> do test' <- cmmExprConFold DataReference test + return $ case test' of + CmmLit (CmmInt 0 _) -> CmmBranch false + CmmLit (CmmInt _ _) -> CmmBranch true + _other -> CmmCondBranch test' true false likely + + CmmSwitch expr ids + -> do expr' <- cmmExprConFold DataReference expr + return $ CmmSwitch expr' ids + + other + -> return other + +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprConFold referenceKind expr = do + config <- getCmmOptConfig + + let expr' = if not (ncgDoConstantFolding config) + then expr + else cmmExprCon config expr + + cmmExprNative referenceKind expr' + +cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr +cmmExprCon config (CmmLoad addr rep) = CmmLoad (cmmExprCon config addr) rep +cmmExprCon config (CmmMachOp mop args) + = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args) +cmmExprCon _ other = other + +-- handles both PIC and non-PIC cases... a very strange mixture +-- of things to do. +cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprNative referenceKind expr = do + config <- getCmmOptConfig + let platform = ncgPlatform config + arch = platformArch platform + case expr of + CmmLoad addr rep + -> do addr' <- cmmExprNative DataReference addr + return $ CmmLoad addr' rep + + CmmMachOp mop args + -> do args' <- mapM (cmmExprNative DataReference) args + return $ CmmMachOp mop args' + + CmmLit (CmmBlock id) + -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) + -- we must convert block Ids to CLabels here, because we + -- might have to do the PIC transformation. Hence we must + -- not modify BlockIds beyond this point. + + CmmLit (CmmLabel lbl) + -> do + cmmMakeDynamicReference config referenceKind lbl + CmmLit (CmmLabelOff lbl off) + -> do + dynRef <- cmmMakeDynamicReference config referenceKind lbl + -- need to optimize here, since it's late + return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [ + dynRef, + (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform)) + ] + + -- On powerpc (non-PIC), it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: + CmmReg (CmmGlobal EagerBlackholeInfo) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) + CmmReg (CmmGlobal GCEnter1) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) + CmmReg (CmmGlobal GCFun) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) + + other + -> return other + diff --git a/GHC/CmmToAsm/BlockLayout.hs b/GHC/CmmToAsm/BlockLayout.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/BlockLayout.hs @@ -0,0 +1,929 @@ +-- +-- Copyright (c) 2018 Andreas Klebinger +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHC.CmmToAsm.BlockLayout + ( sequenceTop, backendMaintainsCfg) +where + +#include "HsVersions.h" +import GHC.Prelude + +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.CFG + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label + +import GHC.Platform +import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) +import GHC.Types.Unique.FM +import GHC.Utils.Misc + +import GHC.Data.Graph.Directed +import GHC.Utils.Outputable +import GHC.Data.Maybe + +-- DEBUGGING ONLY +--import GHC.Cmm.DebugBlock +--import Debug.Trace +import GHC.Data.List.SetOps (removeDups) + +import GHC.Data.OrdList +import Data.List (sortOn, sortBy, nub) +import Data.Foldable (toList) + +import qualified Data.Set as Set +import Data.STRef +import Control.Monad.ST.Strict +import Control.Monad (foldM, unless) +import GHC.Data.UnionFind + +{- + Note [CFG based code layout] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The major steps in placing blocks are as follow: + * Compute a CFG based on the Cmm AST, see getCfgProc. + This CFG will have edge weights representing a guess + on how important they are. + * After we convert Cmm to Asm we run `optimizeCFG` which + adds a few more "educated guesses" to the equation. + * Then we run loop analysis on the CFG (`loopInfo`) which tells us + about loop headers, loop nesting levels and the sort. + * Based on the CFG and loop information refine the edge weights + in the CFG and normalize them relative to the most often visited + node. (See `mkGlobalWeights`) + * Feed this CFG into the block layout code (`sequenceTop`) in this + module. Which will then produce a code layout based on the input weights. + + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~~~ Note [Chain based CFG serialization] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + For additional information also look at + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout + + We have a CFG with edge weights based on which we try to place blocks next to + each other. + + Edge weights not only represent likelihood of control transfer between blocks + but also how much a block would benefit from being placed sequentially after + it's predecessor. + For example blocks which are preceded by an info table are more likely to end + up in a different cache line than their predecessor and we can't eliminate the jump + so there is less benefit to placing them sequentially. + + For example consider this example: + + A: ... + jmp cond D (weak successor) + jmp B + B: ... + jmp C + C: ... + jmp X + D: ... + jmp B (weak successor) + + We determine a block layout by building up chunks (calling them chains) of + possible control flows for which blocks will be placed sequentially. + + Eg for our example we might end up with two chains like: + [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially. + However there is no particular order in which chains are placed since + (hopefully) the blocks for which sequentiality is important have already + been placed in the same chain. + + ----------------------------------------------------------------------------- + 1) First try to create a list of good chains. + ----------------------------------------------------------------------------- + + Good chains are these which allow us to eliminate jump instructions. + Which further eliminate often executed jumps first. + + We do so by: + + *) Ignore edges which represent instructions which can not be replaced + by fall through control flow. Primarily calls and edges to blocks which + are prefixed by a info table we have to jump across. + + *) Then process remaining edges in order of frequency taken and: + + +) If source and target have not been placed build a new chain from them. + + +) If source and target have been placed, and are ends of differing chains + try to merge the two chains. + + +) If one side of the edge is a end/front of a chain, add the other block of + to edge to the same chain + + Eg if we look at edge (B -> C) and already have the chain (A -> B) + then we extend the chain to (A -> B -> C). + + +) If the edge was used to modify or build a new chain remove the edge from + our working list. + + *) If there any blocks not being placed into a chain after these steps we place + them into a chain consisting of only this block. + + Ranking edges by their taken frequency, if + two edges compete for fall through on the same target block, the one taken + more often will automatically win out. Resulting in fewer instructions being + executed. + + Creating singleton chains is required for situations where we have code of the + form: + + A: goto B: + + B: goto C: + + C: ... + + As the code in block B is only connected to the rest of the program via edges + which will be ignored in this step we make sure that B still ends up in a chain + this way. + + ----------------------------------------------------------------------------- + 2) We also try to fuse chains. + ----------------------------------------------------------------------------- + + As a result from the above step we still end up with multiple chains which + represent sequential control flow chunks. But they are not yet suitable for + code layout as we need to place *all* blocks into a single sequence. + + In this step we combine chains result from the above step via these steps: + + *) Look at the ranked list of *all* edges, including calls/jumps across info tables + and the like. + + *) Look at each edge and + + +) Given an edge (A -> B) try to find two chains for which + * Block A is at the end of one chain + * Block B is at the front of the other chain. + +) If we find such a chain we "fuse" them into a single chain, remove the + edge from working set and continue. + +) If we can't find such chains we skip the edge and continue. + + ----------------------------------------------------------------------------- + 3) Place indirect successors (neighbours) after each other + ----------------------------------------------------------------------------- + + We might have chains [A,B,C,X],[E] in a CFG of the sort: + + A ---> B ---> C --------> X(exit) + \- ->E- -/ + + While E does not follow X it's still beneficial to place them near each other. + This can be advantageous if eg C,X,E will end up in the same cache line. + + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~~~ Note [Triangle Control Flow] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Checking if an argument is already evaluated leads to a somewhat + special case which looks like this: + + A: + if (R1 & 7 != 0) goto Leval; else goto Lwork; + Leval: // global + call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8; + Lwork: // global + ... + + A + |\ + | Leval + |/ - (This edge can be missing because of optimizations) + Lwork + + Once we hit the metal the call instruction is just 2-3 bytes large + depending on the register used. So we lay out the assembly like this: + + movq %rbx,%rax + andl $7,%eax + cmpq $1,%rax + jne Lwork + Leval: + jmp *(%rbx) # encoded in 2-3 bytes. + + Lwork: + ... + + We could explicitly check for this control flow pattern. + + This is advantageous because: + * It's optimal if the argument isn't evaluated. + * If it's evaluated we only have the extra cost of jumping over + the 2-3 bytes for the call. + * Guarantees the smaller encoding for the conditional jump. + + However given that Lwork usually has an info table we + penalize this edge. So Leval should get placed first + either way and things work out for the best. + + Optimizing for the evaluated case instead would penalize + the other code path. It adds an jump as we can't fall through + to Lwork because of the info table. + Assuming that Lwork is large the chance that the "call" ends up + in the same cache line is also fairly small. + + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~~~ Note [Layout relevant edge weights] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The input to the chain based code layout algorithm is a CFG + with edges annotated with their frequency. The frequency + of traversal corresponds quite well to the cost of not placing + the connected blocks next to each other. + + However even if having the same frequency certain edges are + inherently more or less relevant to code layout. + + In particular: + + * Edges which cross an info table are less relevant than others. + + If we place the blocks across this edge next to each other + they are still separated by the info table which negates + much of the benefit. It makes it less likely both blocks + will share a cache line reducing the benefits from locality. + But it also prevents us from eliminating jump instructions. + + * Conditional branches and switches are slightly less relevant. + + We can completely remove unconditional jumps by placing them + next to each other. This is not true for conditional branch edges. + We apply a small modifier to them to ensure edges for which we can + eliminate the overhead completely are considered first. See also #18053. + + * Edges constituted by a call are ignored. + + Considering these hardly helped with performance and ignoring + them helps quite a bit to improve compiler performance. + + So we perform a preprocessing step where we apply a multiplicator + to these kinds of edges. + + -} + + +-- | Look at X number of blocks in two chains to determine +-- if they are "neighbours". +neighbourOverlapp :: Int +neighbourOverlapp = 2 + +-- | Maps blocks near the end of a chain to it's chain AND +-- the other blocks near the end. +-- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E])) +-- where [A,B] are blocks in the end region of a chain. +-- This is cheaper then recomputing the ends multiple times. +type FrontierMap = LabelMap ([BlockId],BlockChain) + +-- | A non empty ordered sequence of basic blocks. +-- It is suitable for serialization in this order. +-- +-- We use OrdList instead of [] to allow fast append on both sides +-- when combining chains. +newtype BlockChain + = BlockChain { chainBlocks :: (OrdList BlockId) } + +-- All chains are constructed the same way so comparison +-- including structure is faster. +instance Eq BlockChain where + BlockChain b1 == BlockChain b2 = strictlyEqOL b1 b2 + +-- Useful for things like sets and debugging purposes, sorts by blocks +-- in the chain. +instance Ord (BlockChain) where + (BlockChain lbls1) `compare` (BlockChain lbls2) + = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) + strictlyOrdOL lbls1 lbls2 + +instance Outputable (BlockChain) where + ppr (BlockChain blks) = + parens (text "Chain:" <+> ppr (fromOL $ blks) ) + +chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b +chainFoldl f z (BlockChain blocks) = foldl' f z blocks + +noDups :: [BlockChain] -> Bool +noDups chains = + let chainBlocks = concatMap chainToBlocks chains :: [BlockId] + (_blocks, dups) = removeDups compare chainBlocks + in if null dups then True + else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False + +inFront :: BlockId -> BlockChain -> Bool +inFront bid (BlockChain seq) + = headOL seq == bid + +chainSingleton :: BlockId -> BlockChain +chainSingleton lbl + = BlockChain (unitOL lbl) + +chainFromList :: [BlockId] -> BlockChain +chainFromList = BlockChain . toOL + +chainSnoc :: BlockChain -> BlockId -> BlockChain +chainSnoc (BlockChain blks) lbl + = BlockChain (blks `snocOL` lbl) + +chainCons :: BlockId -> BlockChain -> BlockChain +chainCons lbl (BlockChain blks) + = BlockChain (lbl `consOL` blks) + +chainConcat :: BlockChain -> BlockChain -> BlockChain +chainConcat (BlockChain blks1) (BlockChain blks2) + = BlockChain (blks1 `appOL` blks2) + +chainToBlocks :: BlockChain -> [BlockId] +chainToBlocks (BlockChain blks) = fromOL blks + +-- | Given the Chain A -> B -> C -> D and we break at C +-- we get the two Chains (A -> B, C -> D) as result. +breakChainAt :: BlockId -> BlockChain + -> (BlockChain,BlockChain) +breakChainAt bid (BlockChain blks) + | not (bid == head rblks) + = panic "Block not in chain" + | otherwise + = (BlockChain (toOL lblks), + BlockChain (toOL rblks)) + where + (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks) + +takeR :: Int -> BlockChain -> [BlockId] +takeR n (BlockChain blks) = + take n . fromOLReverse $ blks + +takeL :: Int -> BlockChain -> [BlockId] +takeL n (BlockChain blks) = + take n . fromOL $ blks + +-- Note [Combining neighborhood chains] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- See also Note [Chain based CFG serialization] +-- We have the chains (A-B-C-D) and (E-F) and an Edge C->E. +-- +-- While placing the latter after the former doesn't result in sequential +-- control flow it is still beneficial. As block C and E might end +-- up in the same cache line. +-- +-- So we place these chains next to each other even if we can't fuse them. +-- +-- A -> B -> C -> D +-- v +-- - -> E -> F ... +-- +-- A simple heuristic to chose which chains we want to combine: +-- * Process edges in descending priority. +-- * Check if there is a edge near the end of one chain which goes +-- to a block near the start of another edge. +-- +-- While we could take into account the space between the two blocks which +-- share an edge this blows up compile times quite a bit. It requires +-- us to find all edges between two chains, check the distance for all edges, +-- rank them based on the distance and only then we can select two chains +-- to combine. Which would add a lot of complexity for little gain. +-- +-- So instead we just rank by the strength of the edge and use the first pair we +-- find. + +-- | For a given list of chains and edges try to combine chains with strong +-- edges between them. +combineNeighbourhood :: [CfgEdge] -- ^ Edges to consider + -> [BlockChain] -- ^ Current chains of blocks + -> ([BlockChain], Set.Set (BlockId,BlockId)) + -- ^ Resulting list of block chains, and a set of edges which + -- were used to fuse chains and as such no longer need to be + -- considered. +combineNeighbourhood edges chains + = -- pprTraceIt "Neighbours" $ + -- pprTrace "combineNeighbours" (ppr edges) $ + applyEdges edges endFrontier startFrontier (Set.empty) + where + --Build maps from chain ends to chains + endFrontier, startFrontier :: FrontierMap + endFrontier = + mapFromList $ concatMap (\chain -> + let ends = getEnds chain :: [BlockId] + entry = (ends,chain) + in map (\x -> (x,entry)) ends ) chains + startFrontier = + mapFromList $ concatMap (\chain -> + let front = getFronts chain + entry = (front,chain) + in map (\x -> (x,entry)) front) chains + applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId) + -> ([BlockChain], Set.Set (BlockId,BlockId)) + applyEdges [] chainEnds _chainFronts combined = + (ordNub $ map snd $ mapElems chainEnds, combined) + applyEdges ((CfgEdge from to _w):edges) chainEnds chainFronts combined + | Just (c1_e,c1) <- mapLookup from chainEnds + , Just (c2_f,c2) <- mapLookup to chainFronts + , c1 /= c2 -- Avoid trying to concat a chain with itself. + = let newChain = chainConcat c1 c2 + newChainFrontier = getFronts newChain + newChainEnds = getEnds newChain + newFronts :: FrontierMap + newFronts = + let withoutOld = + foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1) + entry = + (newChainFrontier,newChain) --let bound to ensure sharing + in foldl' (\m x -> mapInsert x entry m) + withoutOld newChainFrontier + + newEnds = + let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2) + entry = (newChainEnds,newChain) --let bound to ensure sharing + in foldl' (\m x -> mapInsert x entry m) + withoutOld newChainEnds + in + -- pprTrace "ApplyEdges" + -- (text "before" $$ + -- text "fronts" <+> ppr chainFronts $$ + -- text "ends" <+> ppr chainEnds $$ + + -- text "various" $$ + -- text "newChain" <+> ppr newChain $$ + -- text "newChainFrontier" <+> ppr newChainFrontier $$ + -- text "newChainEnds" <+> ppr newChainEnds $$ + -- text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$ + + -- text "after" $$ + -- text "fronts" <+> ppr newFronts $$ + -- text "ends" <+> ppr newEnds + -- ) + applyEdges edges newEnds newFronts (Set.insert (from,to) combined) + | otherwise + = applyEdges edges chainEnds chainFronts combined + where + + getFronts chain = takeL neighbourOverlapp chain + getEnds chain = takeR neighbourOverlapp chain + +-- In the last stop we combine all chains into a single one. +-- Trying to place chains with strong edges next to each other. +mergeChains :: [CfgEdge] -> [BlockChain] + -> (BlockChain) +mergeChains edges chains + = runST $ do + let addChain m0 chain = do + ref <- fresh chain + return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain + chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains + merge edges chainMap' + where + -- We keep a map from ALL blocks to their respective chain (sigh) + -- This is required since when looking at an edge we need to find + -- the associated chains quickly. + -- We use a union-find data structure to do this efficiently. + + merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain + merge [] chains = do + chains' <- mapM find =<< (nub <$> (mapM repr $ mapElems chains)) :: ST s [BlockChain] + return $ foldl' chainConcat (head chains') (tail chains') + merge ((CfgEdge from to _):edges) chains + -- | pprTrace "merge" (ppr (from,to) <> ppr chains) False + -- = undefined + = do + same <- equivalent cFrom cTo + unless same $ do + cRight <- find cTo + cLeft <- find cFrom + new_point <- fresh (chainConcat cLeft cRight) + union cTo new_point + union cFrom new_point + merge edges chains + where + cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains + cTo = expectJust "mergeChains:chainMap:to" $ mapLookup to chains + + +-- See Note [Chain based CFG serialization] for the general idea. +-- This creates and fuses chains at the same time for performance reasons. + +-- Try to build chains from a list of edges. +-- Edges must be sorted **descending** by their priority. +-- Returns the constructed chains, along with all edges which +-- are irrelevant past this point, this information doesn't need +-- to be complete - it's only used to speed up the process. +-- An Edge is irrelevant if the ends are part of the same chain. +-- We say these edges are already linked +buildChains :: [CfgEdge] -> [BlockId] + -> ( LabelMap BlockChain -- Resulting chains, indexd by end if chain. + , Set.Set (BlockId, BlockId)) --List of fused edges. +buildChains edges blocks + = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty + where + -- buildNext builds up chains from edges one at a time. + + -- We keep a map from the ends of chains to the chains. + -- This way we can easily check if an block should be appended to an + -- existing chain! + -- We store them using STRefs so we don't have to rebuild the spine of both + -- maps every time we update a chain. + buildNext :: forall s. LabelSet + -> LabelMap (STRef s BlockChain) -- Map from end of chain to chain. + -> LabelMap (STRef s BlockChain) -- Map from start of chain to chain. + -> [CfgEdge] -- Edges to check - ordered by decreasing weight + -> Set.Set (BlockId, BlockId) -- Used edges + -> ST s ( LabelMap BlockChain -- Chains by end + , Set.Set (BlockId, BlockId) --List of fused edges + ) + buildNext placed _chainStarts chainEnds [] linked = do + ends' <- sequence $ mapMap readSTRef chainEnds :: ST s (LabelMap BlockChain) + -- Any remaining blocks have to be made to singleton chains. + -- They might be combined with other chains later on outside this function. + let unplaced = filter (\x -> not (setMember x placed)) blocks + singletons = map (\x -> (x,chainSingleton x)) unplaced :: [(BlockId,BlockChain)] + return (foldl' (\m (k,v) -> mapInsert k v m) ends' singletons , linked) + buildNext placed chainStarts chainEnds (edge:todo) linked + | from == to + -- We skip self edges + = buildNext placed chainStarts chainEnds todo (Set.insert (from,to) linked) + | not (alreadyPlaced from) && + not (alreadyPlaced to) + = do + --pprTraceM "Edge-Chain:" (ppr edge) + chain' <- newSTRef $ chainFromList [from,to] + buildNext + (setInsert to (setInsert from placed)) + (mapInsert from chain' chainStarts) + (mapInsert to chain' chainEnds) + todo + (Set.insert (from,to) linked) + + | (alreadyPlaced from) && + (alreadyPlaced to) + , Just predChain <- mapLookup from chainEnds + , Just succChain <- mapLookup to chainStarts + , predChain /= succChain -- Otherwise we try to create a cycle. + = do + -- pprTraceM "Fusing edge" (ppr edge) + fuseChain predChain succChain + + | (alreadyPlaced from) && + (alreadyPlaced to) + = --pprTraceM "Skipping:" (ppr edge) >> + buildNext placed chainStarts chainEnds todo linked + + | otherwise + = do -- pprTraceM "Finding chain for:" (ppr edge $$ + -- text "placed" <+> ppr placed) + findChain + where + from = edgeFrom edge + to = edgeTo edge + alreadyPlaced blkId = (setMember blkId placed) + + -- Combine two chains into a single one. + fuseChain :: STRef s BlockChain -> STRef s BlockChain + -> ST s ( LabelMap BlockChain -- Chains by end + , Set.Set (BlockId, BlockId) --List of fused edges + ) + fuseChain fromRef toRef = do + fromChain <- readSTRef fromRef + toChain <- readSTRef toRef + let newChain = chainConcat fromChain toChain + ref <- newSTRef newChain + let start = head $ takeL 1 newChain + let end = head $ takeR 1 newChain + -- chains <- sequence $ mapMap readSTRef chainStarts + -- pprTraceM "pre-fuse chains:" $ ppr chains + buildNext + placed + (mapInsert start ref $ mapDelete to $ chainStarts) + (mapInsert end ref $ mapDelete from $ chainEnds) + todo + (Set.insert (from,to) linked) + + + --Add the block to a existing chain or creates a new chain + findChain :: ST s ( LabelMap BlockChain -- Chains by end + , Set.Set (BlockId, BlockId) --List of fused edges + ) + findChain + -- We can attach the block to the end of a chain + | alreadyPlaced from + , Just predChain <- mapLookup from chainEnds + = do + chain <- readSTRef predChain + let newChain = chainSnoc chain to + writeSTRef predChain newChain + let chainEnds' = mapInsert to predChain $ mapDelete from chainEnds + -- chains <- sequence $ mapMap readSTRef chainStarts + -- pprTraceM "from chains:" $ ppr chains + buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked) + -- We can attack it to the front of a chain + | alreadyPlaced to + , Just succChain <- mapLookup to chainStarts + = do + chain <- readSTRef succChain + let newChain = from `chainCons` chain + writeSTRef succChain newChain + let chainStarts' = mapInsert from succChain $ mapDelete to chainStarts + -- chains <- sequence $ mapMap readSTRef chainStarts' + -- pprTraceM "to chains:" $ ppr chains + buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked) + -- The placed end of the edge is part of a chain already and not an end. + | otherwise + = do + let block = if alreadyPlaced to then from else to + --pprTraceM "Singleton" $ ppr block + let newChain = chainSingleton block + ref <- newSTRef newChain + buildNext (setInsert block placed) (mapInsert block ref chainStarts) + (mapInsert block ref chainEnds) todo (linked) + where + alreadyPlaced blkId = (setMember blkId placed) + +-- | Place basic blocks based on the given CFG. +-- See Note [Chain based CFG serialization] +sequenceChain :: forall a i. (Instruction i, Outputable i) + => LabelMap a -- ^ Keys indicate an info table on the block. + -> CFG -- ^ Control flow graph and some meta data. + -> [GenBasicBlock i] -- ^ List of basic blocks to be placed. + -> [GenBasicBlock i] -- ^ Blocks placed in sequence. +sequenceChain _info _weights [] = [] +sequenceChain _info _weights [x] = [x] +sequenceChain info weights blocks@((BasicBlock entry _):_) = + let directEdges :: [CfgEdge] + directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights) + where + -- Apply modifiers to turn edge frequencies into useable weights + -- for computing code layout. + -- See also Note [Layout relevant edge weights] + relevantWeight :: CfgEdge -> Maybe CfgEdge + relevantWeight edge@(CfgEdge from to edgeInfo) + | (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo + -- Ignore edges across calls. + = Nothing + | mapMember to info + , w <- edgeWeight edgeInfo + -- The payoff is quite small if we jump over an info table + = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 }) + | (EdgeInfo CmmSource { trans_cmmNode = exitNode } _) <- edgeInfo + , cantEliminate exitNode + , w <- edgeWeight edgeInfo + -- A small penalty to edge types which + -- we can't optimize away by layout. + -- w * 0.96875 == w - w/32 + = Just (CfgEdge from to edgeInfo { edgeWeight = w * 0.96875 }) + | otherwise + = Just edge + where + cantEliminate CmmCondBranch {} = True + cantEliminate CmmSwitch {} = True + cantEliminate _ = False + + blockMap :: LabelMap (GenBasicBlock i) + blockMap + = foldl' (\m blk@(BasicBlock lbl _ins) -> + mapInsert lbl blk m) + mapEmpty blocks + + (builtChains, builtEdges) + = {-# SCC "buildChains" #-} + --pprTraceIt "generatedChains" $ + --pprTrace "blocks" (ppr (mapKeys blockMap)) $ + buildChains directEdges (mapKeys blockMap) + + rankedEdges :: [CfgEdge] + -- Sort descending by weight, remove fused edges + rankedEdges = + filter (\edge -> not (Set.member (edgeFrom edge,edgeTo edge) builtEdges)) $ + directEdges + + (neighbourChains, combined) + = ASSERT(noDups $ mapElems builtChains) + {-# SCC "groupNeighbourChains" #-} + -- pprTraceIt "NeighbourChains" $ + combineNeighbourhood rankedEdges (mapElems builtChains) + + + allEdges :: [CfgEdge] + allEdges = {-# SCC allEdges #-} + sortOn (relevantWeight) $ filter (not . deadEdge) $ (infoEdgeList weights) + where + deadEdge :: CfgEdge -> Bool + deadEdge (CfgEdge from to _) = let e = (from,to) in Set.member e combined || Set.member e builtEdges + relevantWeight :: CfgEdge -> EdgeWeight + relevantWeight (CfgEdge _ _ edgeInfo) + | EdgeInfo (CmmSource { trans_cmmNode = CmmCall {}}) _ <- edgeInfo + -- Penalize edges across calls + = weight/(64.0) + | otherwise + = weight + where + -- negate to sort descending + weight = negate (edgeWeight edgeInfo) + + masterChain = + {-# SCC "mergeChains" #-} + -- pprTraceIt "MergedChains" $ + mergeChains allEdges neighbourChains + + --Make sure the first block stays first + prepedChains + | inFront entry masterChain + = [masterChain] + | (rest,entry) <- breakChainAt entry masterChain + = [entry,rest] +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = pprPanic "Entry point eliminated" $ + ppr masterChain +#endif + + blockList + = ASSERT(noDups [masterChain]) + (concatMap fromOL $ map chainBlocks prepedChains) + + --chainPlaced = setFromList $ map blockId blockList :: LabelSet + chainPlaced = setFromList $ blockList :: LabelSet + unplaced = + let blocks = mapKeys blockMap + isPlaced b = setMember (b) chainPlaced + in filter (\block -> not (isPlaced block)) blocks + + placedBlocks = + -- We want debug builds to catch this as it's a good indicator for + -- issues with CFG invariants. But we don't want to blow up production + -- builds if something slips through. + ASSERT(null unplaced) + --pprTraceIt "placedBlocks" $ + -- ++ [] is stil kinda expensive + if null unplaced then blockList else blockList ++ unplaced + getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap + in + --Assert we placed all blocks given as input + ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks) + dropJumps info $ map getBlock placedBlocks + +{-# SCC dropJumps #-} +-- | Remove redundant jumps between blocks when we can rely on +-- fall through. +dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i] + -> [GenBasicBlock i] +dropJumps _ [] = [] +dropJumps info ((BasicBlock lbl ins):todo) + | not . null $ ins --This can happen because of shortcutting + , [dest] <- jumpDestsOfInstr (last ins) + , ((BasicBlock nextLbl _) : _) <- todo + , not (mapMember dest info) + , nextLbl == dest + = BasicBlock lbl (init ins) : dropJumps info todo + | otherwise + = BasicBlock lbl ins : dropJumps info todo + + +-- ----------------------------------------------------------------------------- +-- Sequencing the basic blocks + +-- Cmm BasicBlocks are self-contained entities: they always end in a +-- jump, either non-local or to another basic block in the same proc. +-- In this phase, we attempt to place the basic blocks in a sequence +-- such that as many of the local jumps as possible turn into +-- fallthroughs. + +sequenceTop + :: (Instruction instr, Outputable instr) + => DynFlags -- Determine which layout algo to use + -> NcgImpl statics instr jumpDest + -> Maybe CFG -- ^ CFG if we have one. + -> NatCmmDecl statics instr -- ^ Function to serialize + -> NatCmmDecl statics instr + +sequenceTop _ _ _ top@(CmmData _ _) = top +sequenceTop dflags ncgImpl edgeWeights + (CmmProc info lbl live (ListGraph blocks)) + | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags) + --Use chain based algorithm + , Just cfg <- edgeWeights + = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $ + {-# SCC layoutBlocks #-} + sequenceChain info cfg blocks ) + | otherwise + --Use old algorithm + = let cfg = if dontUseCfg then Nothing else edgeWeights + in CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $ + {-# SCC layoutBlocks #-} + sequenceBlocks cfg info blocks) + where + dontUseCfg = gopt Opt_WeightlessBlocklayout dflags || + (not $ backendMaintainsCfg (targetPlatform dflags)) + +-- The old algorithm: +-- It is very simple (and stupid): We make a graph out of +-- the blocks where there is an edge from one block to another iff the +-- first block ends by jumping to the second. Then we topologically +-- sort this graph. Then traverse the list: for each block, we first +-- output the block, then if it has an out edge, we move the +-- destination of the out edge to the front of the list, and continue. + +-- FYI, the classic layout for basic blocks uses postorder DFS; this +-- algorithm is implemented in Hoopl. + +sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a + -> [GenBasicBlock inst] -> [GenBasicBlock inst] +sequenceBlocks _edgeWeight _ [] = [] +sequenceBlocks edgeWeights infos (entry:blocks) = + let entryNode = mkNode edgeWeights entry + bodyNodes = reverse + (flattenSCCs (sccBlocks edgeWeights blocks)) + in dropJumps infos . seqBlocks infos $ ( entryNode : bodyNodes) + -- the first block is the entry point ==> it must remain at the start. + +sccBlocks + :: Instruction instr + => Maybe CFG -> [NatBasicBlock instr] + -> [SCC (Node BlockId (NatBasicBlock instr))] +sccBlocks edgeWeights blocks = + stronglyConnCompFromEdgedVerticesUniqR + (map (mkNode edgeWeights) blocks) + +mkNode :: (Instruction t) + => Maybe CFG -> GenBasicBlock t + -> Node BlockId (GenBasicBlock t) +mkNode edgeWeights block@(BasicBlock id instrs) = + DigraphNode block id outEdges + where + outEdges :: [BlockId] + outEdges + --Select the heaviest successor, ignore weights <= zero + = successor + where + successor + | Just successors <- fmap (`getSuccEdgesSorted` id) + edgeWeights -- :: Maybe [(Label, EdgeInfo)] + = case successors of + [] -> [] + ((target,info):_) + | length successors > 2 || edgeWeight info <= 0 -> [] + | otherwise -> [target] + | otherwise + = case jumpDestsOfInstr (last instrs) of + [one] -> [one] + _many -> [] + + +seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)] + -> [GenBasicBlock t1] +seqBlocks infos blocks = placeNext pullable0 todo0 + where + -- pullable: Blocks that are not yet placed + -- todo: Original order of blocks, to be followed if we have no good + -- reason not to; + -- may include blocks that have already been placed, but then + -- these are not in pullable + pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ] + todo0 = map node_key blocks + + placeNext _ [] = [] + placeNext pullable (i:rest) + | Just (block, pullable') <- lookupDeleteUFM pullable i + = place pullable' rest block + | otherwise + -- We already placed this block, so ignore + = placeNext pullable rest + + place pullable todo (block,[]) + = block : placeNext pullable todo + place pullable todo (block@(BasicBlock id instrs),[next]) + | mapMember next infos + = block : placeNext pullable todo + | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next + = BasicBlock id instrs : place pullable' todo nextBlock + | otherwise + = block : placeNext pullable todo + place _ _ (_,tooManyNextNodes) + = pprPanic "seqBlocks" (ppr tooManyNextNodes) + + +lookupDeleteUFM :: UniqFM BlockId elt -> BlockId + -> Maybe (elt, UniqFM BlockId elt) +lookupDeleteUFM m k = do -- Maybe monad + v <- lookupUFM m k + return (v, delFromUFM m k) + +backendMaintainsCfg :: Platform -> Bool +backendMaintainsCfg platform = case platformArch platform of + -- ArchX86 -- Should work but not tested so disabled currently. + ArchX86_64 -> True + _otherwise -> False + diff --git a/GHC/CmmToAsm/CFG.hs b/GHC/CmmToAsm/CFG.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/CFG.hs @@ -0,0 +1,1369 @@ +-- +-- Copyright (c) 2018 Andreas Klebinger +-- + +{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHC.CmmToAsm.CFG + ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..) + , TransitionSource(..) + + --Modify the CFG + , addWeightEdge, addEdge + , delEdge + , addNodesBetween, shortcutWeightMap + , reverseEdges, filterEdges + , addImmediateSuccessor + , mkWeightInfo, adjustEdgeWeight, setEdgeWeight + + --Query the CFG + , infoEdgeList, edgeList + , getSuccessorEdges, getSuccessors + , getSuccEdgesSorted + , getEdgeInfo + , getCfgNodes, hasNode + + -- Loop Information + , loopMembers, loopLevels, loopInfo + + --Construction/Misc + , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg + + --Find backedges and update their weight + , optimizeCFG + , mkGlobalWeights + + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Cmm.BlockId +import GHC.Cmm as Cmm + +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block +import qualified GHC.Cmm.Dataflow.Graph as G + +import GHC.Utils.Misc +import GHC.Data.Graph.Directed +import GHC.Data.Maybe + +import GHC.Types.Unique +import qualified GHC.CmmToAsm.CFG.Dominators as Dom +import Data.IntMap.Strict (IntMap) +import Data.IntSet (IntSet) + +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M +import qualified Data.IntSet as IS +import qualified Data.Set as S +import Data.Tree +import Data.Bifunctor + +import GHC.Utils.Outputable +-- DEBUGGING ONLY +--import GHC.Cmm.DebugBlock +--import GHC.Data.OrdList +--import GHC.Cmm.DebugBlock.Trace +import GHC.Cmm.Ppr () -- For Outputable instances +import qualified GHC.Driver.Session as D + +import Data.List (sort, nub, partition) +import Data.STRef.Strict +import Control.Monad.ST + +import Data.Array.MArray +import Data.Array.ST +import Data.Array.IArray +import Data.Array.Unsafe (unsafeFreeze) +import Data.Array.Base (unsafeRead, unsafeWrite) + +import Control.Monad +import GHC.Data.UnionFind + +type Prob = Double + +type Edge = (BlockId, BlockId) +type Edges = [Edge] + +newtype EdgeWeight + = EdgeWeight { weightToDouble :: Double } + deriving (Eq,Ord,Enum,Num,Real,Fractional) + +instance Outputable EdgeWeight where + ppr (EdgeWeight w) = doublePrec 5 w + +type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo) + +-- | A control flow graph where edges have been annotated with a weight. +-- Implemented as IntMap (IntMap \) +-- We must uphold the invariant that for each edge A -> B we must have: +-- A entry B in the outer map. +-- A entry B in the map we get when looking up A. +-- Maintaining this invariant is useful as any failed lookup now indicates +-- an actual error in code which might go unnoticed for a while +-- otherwise. +type CFG = EdgeInfoMap EdgeInfo + +data CfgEdge + = CfgEdge + { edgeFrom :: !BlockId + , edgeTo :: !BlockId + , edgeInfo :: !EdgeInfo + } + +-- | Careful! Since we assume there is at most one edge from A to B +-- the Eq instance does not consider weight. +instance Eq CfgEdge where + (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _) + = from1 == from2 && to1 == to2 + +-- | Edges are sorted ascending pointwise by weight, source and destination +instance Ord CfgEdge where + compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1})) + (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2})) + | weight1 < weight2 || weight1 == weight2 && from1 < from2 || + weight1 == weight2 && from1 == from2 && to1 < to2 + = LT + | from1 == from2 && to1 == to2 && weight1 == weight2 + = EQ + | otherwise + = GT + +instance Outputable CfgEdge where + ppr (CfgEdge from1 to1 edgeInfo) + = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1) + +-- | Can we trace back a edge to a specific Cmm Node +-- or has it been introduced during assembly codegen. We use this to maintain +-- some information which would otherwise be lost during the +-- Cmm \<-> asm transition. +-- See also Note [Inverting Conditional Branches] +data TransitionSource + = CmmSource { trans_cmmNode :: (CmmNode O C) + , trans_info :: BranchInfo } + | AsmCodeGen + deriving (Eq) + +data BranchInfo = NoInfo -- ^ Unknown, but not heap or stack check. + | HeapStackCheck -- ^ Heap or stack check + deriving Eq + +instance Outputable BranchInfo where + ppr NoInfo = text "regular" + ppr HeapStackCheck = text "heap/stack" + +isHeapOrStackCheck :: TransitionSource -> Bool +isHeapOrStackCheck (CmmSource { trans_info = HeapStackCheck}) = True +isHeapOrStackCheck _ = False + +-- | Information about edges +data EdgeInfo + = EdgeInfo + { transitionSource :: !TransitionSource + , edgeWeight :: !EdgeWeight + } deriving (Eq) + +instance Outputable EdgeInfo where + ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo) + +-- | Convenience function, generate edge info based +-- on weight not originating from cmm. +mkWeightInfo :: EdgeWeight -> EdgeInfo +mkWeightInfo = EdgeInfo AsmCodeGen + +-- | Adjust the weight between the blocks using the given function. +-- If there is no such edge returns the original map. +adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight) + -> BlockId -> BlockId -> CFG +adjustEdgeWeight cfg f from to + | Just info <- getEdgeInfo from to cfg + , !weight <- edgeWeight info + , !newWeight <- f weight + = addEdge from to (info { edgeWeight = newWeight}) cfg + | otherwise = cfg + +-- | Set the weight between the blocks to the given weight. +-- If there is no such edge returns the original map. +setEdgeWeight :: CFG -> EdgeWeight + -> BlockId -> BlockId -> CFG +setEdgeWeight cfg !weight from to + | Just info <- getEdgeInfo from to cfg + = addEdge from to (info { edgeWeight = weight}) cfg + | otherwise = cfg + + +getCfgNodes :: CFG -> [BlockId] +getCfgNodes m = + mapKeys m + +-- | Is this block part of this graph? +hasNode :: CFG -> BlockId -> Bool +hasNode m node = + -- Check the invariant that each node must exist in the first map or not at all. + ASSERT( found || not (any (mapMember node) m)) + found + where + found = mapMember node m + + + +-- | Check if the nodes in the cfg and the set of blocks are the same. +-- In a case of a missmatch we panic and show the difference. +sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool +sanityCheckCfg m blockSet msg + | blockSet == cfgNodes + = True + | otherwise = + pprPanic "Block list and cfg nodes don't match" ( + text "difference:" <+> ppr diff $$ + text "blocks:" <+> ppr blockSet $$ + text "cfg:" <+> pprEdgeWeights m $$ + msg ) + False + where + cfgNodes = setFromList $ getCfgNodes m :: LabelSet + diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet + +-- | Filter the CFG with a custom function f. +-- Paramaeters are `f from to edgeInfo` +filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG +filterEdges f cfg = + mapMapWithKey filterSources cfg + where + filterSources from m = + mapFilterWithKey (\to w -> f from to w) m + + +{- Note [Updating the CFG during shortcutting] + +See Note [What is shortcutting] in the control flow optimization +code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting. + +In the native backend we shortcut jumps at the assembly level. ("GHC.CmmToAsm") +This means we remove blocks containing only one jump from the code +and instead redirecting all jumps targeting this block to the deleted +blocks jump target. + +However we want to have an accurate representation of control +flow in the CFG. So we add/remove edges accordingly to account +for the eliminated blocks and new edges. + +If we shortcut A -> B -> C to A -> C: +* We delete edges A -> B and B -> C +* Replacing them with the edge A -> C + +We also try to preserve jump weights while doing so. + +Note that: +* The edge B -> C can't have interesting weights since + the block B consists of a single unconditional jump without branching. +* We delete the edge A -> B and add the edge A -> C. +* The edge A -> B can be one of many edges originating from A so likely + has edge weights we want to preserve. + +For this reason we simply store the edge info from the original A -> B +edge and apply this information to the new edge A -> C. + +Sometimes we have a scenario where jump target C is not represented by an +BlockId but an immediate value. I'm only aware of this happening without +tables next to code currently. + +Then we go from A ---> B - -> IMM to A - -> IMM where the dashed arrows +are not stored in the CFG. + +In that case we simply delete the edge A -> B. + +In terms of implementation the native backend first builds a mapping +from blocks suitable for shortcutting to their jump targets. +Then it redirects all jump instructions to these blocks using the +built up mapping. +This function (shortcutWeightMap) takes the same mapping and +applies the mapping to the CFG in the way laid out above. + +-} +shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG +shortcutWeightMap cuts cfg + | mapNull cuts = cfg + | otherwise = normalised_cfg + where + -- First take the cuts map and collapse any shortcuts, for example + -- if the cuts map has A -> B and B -> C then we want to rewrite + -- A -> C and B -> C directly. + normalised_cuts_st :: forall s . ST s (LabelMap (Maybe BlockId)) + normalised_cuts_st = do + (null :: Point s (Maybe BlockId)) <- fresh Nothing + let cuts_list = mapToList cuts + -- Create a unification variable for each of the nodes in a rewrite + cuts_vars <- traverse (\p -> (p,) <$> fresh (Just p)) (concatMap (\(a, b) -> [a] ++ maybe [] (:[]) b) cuts_list) + let cuts_map = mapFromList cuts_vars :: LabelMap (Point s (Maybe BlockId)) + -- Then unify according the the rewrites in the cuts map + mapM_ (\(from, to) -> expectJust "shortcutWeightMap" (mapLookup from cuts_map) + `union` expectJust "shortcutWeightMap" (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list + -- Then recover the unique representative, which is the result of following + -- the chain to the end. + mapM find cuts_map + + normalised_cuts = runST normalised_cuts_st + + cuts_domain :: LabelSet + cuts_domain = setFromList $ mapKeys cuts + + -- The CFG is shortcutted using the normalised cuts map + normalised_cfg :: CFG + normalised_cfg = mapFoldlWithKey update_edge mapEmpty cfg + + update_edge :: CFG -> Label -> LabelMap EdgeInfo -> CFG + update_edge new_map from edge_map + -- If the from edge is in the cuts map then delete the edge + | setMember from cuts_domain = new_map + -- Otherwise we are keeping the edge, but might have shortcutted some of + -- the target nodes. + | otherwise = mapInsert from (mapFoldlWithKey update_from_edge mapEmpty edge_map) new_map + + update_from_edge :: LabelMap a -> Label -> a -> LabelMap a + update_from_edge new_map to_edge edge_info + -- Edge is in the normalised cuts + | Just new_edge <- mapLookup to_edge normalised_cuts = + case new_edge of + -- The result was Nothing, so edge is deleted + Nothing -> new_map + -- The new target for the edge, write it with the old edge_info. + Just new_to -> mapInsert new_to edge_info new_map + -- Node wasn't in the cuts map, so just add it back + | otherwise = mapInsert to_edge edge_info new_map + + +-- | Sometimes we insert a block which should unconditionally be executed +-- after a given block. This function updates the CFG for these cases. +-- So we get A -> B => A -> A' -> B +-- \ \ +-- -> C => -> C +-- +addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG +addImmediateSuccessor dflags node follower cfg + = updateEdges . addWeightEdge node follower uncondWeight $ cfg + where + uncondWeight = fromIntegral . D.uncondWeight . + D.cfgWeightInfo $ dflags + targets = getSuccessorEdges cfg node + successors = map fst targets :: [BlockId] + updateEdges = addNewSuccs . remOldSuccs + remOldSuccs m = foldl' (flip (delEdge node)) m successors + addNewSuccs m = + foldl' (\m' (t,info) -> addEdge follower t info m') m targets + +-- | Adds a new edge, overwrites existing edges if present +addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG +addEdge from to info cfg = + mapAlter addFromToEdge from $ + mapAlter addDestNode to cfg + where + -- Simply insert the edge into the edge list. + addFromToEdge Nothing = Just $ mapSingleton to info + addFromToEdge (Just wm) = Just $ mapInsert to info wm + -- We must add the destination node explicitly + addDestNode Nothing = Just $ mapEmpty + addDestNode n@(Just _) = n + + +-- | Adds a edge with the given weight to the cfg +-- If there already existed an edge it is overwritten. +-- `addWeightEdge from to weight cfg` +addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG +addWeightEdge from to weight cfg = + addEdge from to (mkWeightInfo weight) cfg + +delEdge :: BlockId -> BlockId -> CFG -> CFG +delEdge from to m = + mapAlter remDest from m + where + remDest Nothing = Nothing + remDest (Just wm) = Just $ mapDelete to wm + + +-- | Destinations from bid ordered by weight (descending) +getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)] +getSuccEdgesSorted m bid = + let destMap = mapFindWithDefault mapEmpty bid m + cfgEdges = mapToList destMap + sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges + in --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m) + sortedEdges + +-- | Get successors of a given node with edge weights. +getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)] +getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m) + where + lookupError = pprPanic "getSuccessorEdges: Block does not exist" $ + ppr bid <+> pprEdgeWeights m + +getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo +getEdgeInfo from to m + | Just wm <- mapLookup from m + , Just info <- mapLookup to wm + = Just $! info + | otherwise + = Nothing + +getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight +getEdgeWeight cfg from to = + edgeWeight $ expectJust "Edgeweight for noexisting block" $ + getEdgeInfo from to cfg + +getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource +getTransitionSource from to cfg = transitionSource $ expectJust "Source info for noexisting block" $ + getEdgeInfo from to cfg + +reverseEdges :: CFG -> CFG +reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg + where + -- We must preserve nodes without outgoing edges! + addNode :: CFG -> BlockId -> CFG + addNode cfg b = mapInsertWith mapUnion b mapEmpty cfg + go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG + go cfg from toMap = mapFoldlWithKey (\cfg to info -> addEdge to from info cfg) cfg toMap :: CFG + + +-- | Returns a unordered list of all edges with info +infoEdgeList :: CFG -> [CfgEdge] +infoEdgeList m = + go (mapToList m) [] + where + -- We avoid foldMap to avoid thunk buildup + go :: [(BlockId,LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge] + go [] acc = acc + go ((from,toMap):xs) acc + = go' xs from (mapToList toMap) acc + go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [(BlockId,EdgeInfo)] -> [CfgEdge] -> [CfgEdge] + go' froms _ [] acc = go froms acc + go' froms from ((to,info):tos) acc + = go' froms from tos (CfgEdge from to info : acc) + +-- | Returns a unordered list of all edges without weights +edgeList :: CFG -> [Edge] +edgeList m = + go (mapToList m) [] + where + -- We avoid foldMap to avoid thunk buildup + go :: [(BlockId,LabelMap EdgeInfo)] -> [Edge] -> [Edge] + go [] acc = acc + go ((from,toMap):xs) acc + = go' xs from (mapKeys toMap) acc + go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [BlockId] -> [Edge] -> [Edge] + go' froms _ [] acc = go froms acc + go' froms from (to:tos) acc + = go' froms from tos ((from,to) : acc) + +-- | Get successors of a given node without edge weights. +getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId] +getSuccessors m bid + | Just wm <- mapLookup bid m + = mapKeys wm + | otherwise = lookupError + where + lookupError = pprPanic "getSuccessors: Block does not exist" $ + ppr bid <+> pprEdgeWeights m + +pprEdgeWeights :: CFG -> SDoc +pprEdgeWeights m = + let edges = sort $ infoEdgeList m :: [CfgEdge] + printEdge (CfgEdge from to (EdgeInfo { edgeWeight = weight })) + = text "\t" <> ppr from <+> text "->" <+> ppr to <> + text "[label=\"" <> ppr weight <> text "\",weight=\"" <> + ppr weight <> text "\"];\n" + --for the case that there are no edges from/to this node. + --This should rarely happen but it can save a lot of time + --to immediately see it when it does. + printNode node + = text "\t" <> ppr node <> text ";\n" + getEdgeNodes (CfgEdge from to _) = [from,to] + edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet + nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m + in + text "digraph {\n" <> + (foldl' (<>) empty (map printEdge edges)) <> + (foldl' (<>) empty (map printNode nodes)) <> + text "}\n" + +{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible +-- | Invariant: The edge **must** exist already in the graph. +updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG +updateEdgeWeight f (from, to) cfg + | Just oldInfo <- getEdgeInfo from to cfg + = let !oldWeight = edgeWeight oldInfo + !newWeight = f oldWeight + in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg + | otherwise + = panic "Trying to update invalid edge" + +-- from to oldWeight => newWeight +mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG +mapWeights f cfg = + foldl' (\cfg (CfgEdge from to info) -> + let oldWeight = edgeWeight info + newWeight = f from to oldWeight + in addEdge from to (info {edgeWeight = newWeight}) cfg) + cfg (infoEdgeList cfg) + + +-- | Insert a block in the control flow between two other blocks. +-- We pass a list of tuples (A,B,C) where +-- * A -> C: Old edge +-- * A -> B -> C : New Arc, where B is the new block. +-- It's possible that a block has two jumps to the same block +-- in the assembly code. However we still only store a single edge for +-- these cases. +-- We assign the old edge info to the edge A -> B and assign B -> C the +-- weight of an unconditional jump. +addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG +addNodesBetween dflags m updates = + foldl' updateWeight m . + weightUpdates $ updates + where + weight = fromIntegral . D.uncondWeight . + D.cfgWeightInfo $ dflags + -- We might add two blocks for different jumps along a single + -- edge. So we end up with edges: A -> B -> C , A -> D -> C + -- in this case after applying the first update the weight for A -> C + -- is no longer available. So we calculate future weights before updates. + weightUpdates = map getWeight + getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo) + getWeight (from,between,old) + | Just edgeInfo <- getEdgeInfo from old m + = (from,between,old,edgeInfo) + | otherwise + = pprPanic "Can't find weight for edge that should have one" ( + text "triple" <+> ppr (from,between,old) $$ + text "updates" <+> ppr updates $$ + text "cfg:" <+> pprEdgeWeights m ) + updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG + updateWeight m (from,between,old,edgeInfo) + = addEdge from between edgeInfo . + addWeightEdge between old weight . + delEdge from old $ m + +{- + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~~~ Note [CFG Edge Weights] ~~~ + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Edge weights assigned do not currently represent a specific + cost model and rather just a ranking of which blocks should + be placed next to each other given their connection type in + the CFG. + This is especially relevant if we whenever two blocks will + jump to the same target. + + A B + \ / + C + + Should A or B be placed in front of C? The block layout algorithm + decides this based on which edge (A,C)/(B,C) is heavier. So we + make a educated guess on which branch should be preferred. + + We rank edges in this order: + * Unconditional Control Transfer - They will always + transfer control to their target. Unless there is a info table + we can turn the jump into a fallthrough as well. + We use 20k as default, so it's easy to spot if values have been + modified but unlikely that we run into issues with overflow. + * If branches (likely) - We assume branches marked as likely + are taken more than 80% of the time. + By ranking them below unconditional jumps we make sure we + prefer the unconditional if there is a conditional and + unconditional edge towards a block. + * If branches (regular) - The false branch can potentially be turned + into a fallthrough so we prefer it slightly over the true branch. + * Unlikely branches - These can be assumed to be taken less than 20% + of the time. So we given them one of the lowest priorities. + * Switches - Switches at this level are implemented as jump tables + so have a larger number of successors. So without more information + we can only say that each individual successor is unlikely to be + jumped to and we rank them accordingly. + * Calls - We currently ignore calls completely: + * By the time we return from a call there is a good chance + that the address we return to has already been evicted from + cache eliminating a main advantage sequential placement brings. + * Calls always require a info table in front of their return + address. This reduces the chance that we return to the same + cache line further. + +-} +-- | Generate weights for a Cmm proc based on some simple heuristics. +getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG +getCfgProc _ (CmmData {}) = mapEmpty +getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph + +getCfg :: D.CfgWeights -> CmmGraph -> CFG +getCfg weights graph = + foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks + where + D.CFGWeights + { D.uncondWeight = uncondWeight + , D.condBranchWeight = condBranchWeight + , D.switchWeight = switchWeight + , D.callWeight = callWeight + , D.likelyCondWeight = likelyCondWeight + , D.unlikelyCondWeight = unlikelyCondWeight + -- Last two are used in other places + --, D.infoTablePenalty = infoTablePenalty + --, D.backEdgeBonus = backEdgeBonus + } = weights + -- Explicitly add all nodes to the cfg to ensure they are part of the + -- CFG. + edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty) + insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG + insertEdge m ((from,to),weight) = + mapAlter f from m + where + f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo) + f Nothing = Just $ mapSingleton to weight + f (Just destMap) = Just $ mapInsert to weight destMap + getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)] + getBlockEdges block = + case branch of + CmmBranch dest -> [mkEdge dest uncondWeight] + CmmCondBranch cond t f l + | l == Nothing -> + [mkEdge f condBranchWeight, mkEdge t condBranchWeight] + | l == Just True -> + [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight] + | l == Just False -> + [mkEdge f likelyCondWeight, mkEdge t unlikelyCondWeight] + where + mkEdgeInfo = -- pprTrace "Info" (ppr branchInfo <+> ppr cond) + EdgeInfo (CmmSource branch branchInfo) . fromIntegral + mkEdge target weight = ((bid,target), mkEdgeInfo weight) + branchInfo = + foldRegsUsed + (panic "foldRegsDynFlags") + (\info r -> if r == SpLim || r == HpLim || r == BaseReg + then HeapStackCheck else info) + NoInfo cond + + (CmmSwitch _e ids) -> + let switchTargets = switchTargetsToList ids + --Compiler performance hack - for very wide switches don't + --consider targets for layout. + adjustedWeight = + if (length switchTargets > 10) then -1 else switchWeight + in map (\x -> mkEdge x adjustedWeight) switchTargets + (CmmCall { cml_cont = Just cont}) -> [mkEdge cont callWeight] + (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight] + (CmmCall { cml_cont = Nothing }) -> [] + other -> + panic "Foo" $ + ASSERT2(False, ppr "Unknown successor cause:" <> + (ppr branch <+> text "=>" <> ppr (G.successors other))) + map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other + where + bid = G.entryLabel block + mkEdgeInfo = EdgeInfo (CmmSource branch NoInfo) . fromIntegral + mkEdge target weight = ((bid,target), mkEdgeInfo weight) + branch = lastNode block :: CmmNode O C + + blocks = revPostorder graph :: [CmmBlock] + +--Find back edges by BFS +findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges +findBackEdges root cfg = + --pprTraceIt "Backedges:" $ + map fst . + filter (\x -> snd x == Backward) $ typedEdges + where + edges = edgeList cfg :: [(BlockId,BlockId)] + getSuccs = getSuccessors cfg :: BlockId -> [BlockId] + typedEdges = + classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)] + +optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG +optimizeCFG _ _ (CmmData {}) cfg = cfg +optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg = + (if doStaticPred then staticPredCfg (g_entry graph) else id) $ + optHsPatterns weights proc $ cfg + +-- | Modify branch weights based on educated guess on +-- patterns GHC tends to produce and how they affect +-- performance. +-- +-- Most importantly we penalize jumps across info tables. +optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG +optHsPatterns _ (CmmData {}) cfg = cfg +optHsPatterns weights (CmmProc info _lab _live graph) cfg = + {-# SCC optHsPatterns #-} + -- pprTrace "Initial:" (pprEdgeWeights cfg) $ + -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $ + + -- pprTrace "LoopInfo:" (ppr $ loopInfo cfg (g_entry graph)) $ + favourFewerPreds . + penalizeInfoTables info . + increaseBackEdgeWeight (g_entry graph) $ cfg + where + + -- | Increase the weight of all backedges in the CFG + -- this helps to make loop jumpbacks the heaviest edges + increaseBackEdgeWeight :: BlockId -> CFG -> CFG + increaseBackEdgeWeight root cfg = + let backedges = findBackEdges root cfg + update weight + --Keep irrelevant edges irrelevant + | weight <= 0 = 0 + | otherwise + = weight + fromIntegral (D.backEdgeBonus weights) + in foldl' (\cfg edge -> updateEdgeWeight update edge cfg) + cfg backedges + + -- | Since we cant fall through info tables we penalize these. + penalizeInfoTables :: LabelMap a -> CFG -> CFG + penalizeInfoTables info cfg = + mapWeights fupdate cfg + where + fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight + fupdate _ to weight + | mapMember to info + = weight - (fromIntegral $ D.infoTablePenalty weights) + | otherwise = weight + + -- | If a block has two successors, favour the one with fewer + -- predecessors and/or the one allowing fall through. + favourFewerPreds :: CFG -> CFG + favourFewerPreds cfg = + let + revCfg = + reverseEdges $ filterEdges + (\_from -> fallthroughTarget) cfg + + predCount n = length $ getSuccessorEdges revCfg n + nodes = getCfgNodes cfg + + modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight) + modifiers preds1 preds2 + | preds1 < preds2 = ( 1,-1) + | preds1 == preds2 = ( 0, 0) + | otherwise = (-1, 1) + + update :: CFG -> BlockId -> CFG + update cfg node + | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node + , !w1 <- edgeWeight e1 + , !w2 <- edgeWeight e2 + --Only change the weights if there isn't already a ordering. + , w1 == w2 + , (mod1,mod2) <- modifiers (predCount s1) (predCount s2) + = (\cfg' -> + (adjustEdgeWeight cfg' (+mod2) node s2)) + (adjustEdgeWeight cfg (+mod1) node s1) + | otherwise + = cfg + in foldl' update cfg nodes + where + fallthroughTarget :: BlockId -> EdgeInfo -> Bool + fallthroughTarget to (EdgeInfo source _weight) + | mapMember to info = False + | AsmCodeGen <- source = True + | CmmSource { trans_cmmNode = CmmBranch {} } <- source = True + | CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True + | otherwise = False + +-- | Convert block-local branch weights to global weights. +staticPredCfg :: BlockId -> CFG -> CFG +staticPredCfg entry cfg = cfg' + where + (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-} + mkGlobalWeights entry cfg + cfg' = {-# SCC rewriteEdges #-} + mapFoldlWithKey + (\cfg from m -> + mapFoldlWithKey + (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to ) + cfg m ) + cfg + globalEdgeWeights + +-- | Determine loop membership of blocks based on SCC analysis +-- This is faster but only gives yes/no answers. +loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool +loopMembers cfg = + foldl' (flip setLevel) mapEmpty sccs + where + mkNode :: BlockId -> Node BlockId BlockId + mkNode bid = DigraphNode bid bid (getSuccessors cfg bid) + nodes = map mkNode (getCfgNodes cfg) + + sccs = stronglyConnCompFromEdgedVerticesOrd nodes + + setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool + setLevel (AcyclicSCC bid) m = mapInsert bid False m + setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids + +loopLevels :: CFG -> BlockId -> LabelMap Int +loopLevels cfg root = liLevels loopInfos + where + loopInfos = loopInfo cfg root + +data LoopInfo = LoopInfo + { liBackEdges :: [(Edge)] -- ^ List of back edges + , liLevels :: LabelMap Int -- ^ BlockId -> LoopLevel mapping + , liLoops :: [(Edge, LabelSet)] -- ^ (backEdge, loopBody), body includes header + } + +instance Outputable LoopInfo where + ppr (LoopInfo _ _lvls loops) = + text "Loops:(backEdge, bodyNodes)" $$ + (vcat $ map ppr loops) + +{- Note [Determining the loop body] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Starting with the knowledge that: + * head dominates the loop + * `tail` -> `head` is a backedge + + We can determine all nodes by: + * Deleting the loop head from the graph. + * Collect all blocks which are reachable from the `tail`. + + We do so by performing bfs from the tail node towards the head. + -} + +-- | Determine loop membership of blocks based on Dominator analysis. +-- This is slower but gives loop levels instead of just loop membership. +-- However it only detects natural loops. Irreducible control flow is not +-- recognized even if it loops. But that is rare enough that we don't have +-- to care about that special case. +loopInfo :: HasDebugCallStack => CFG -> BlockId -> LoopInfo +loopInfo cfg root = LoopInfo { liBackEdges = backEdges + , liLevels = mapFromList loopCounts + , liLoops = loopBodies } + where + revCfg = reverseEdges cfg + + graph = -- pprTrace "CFG - loopInfo" (pprEdgeWeights cfg) $ + fmap (setFromList . mapKeys ) cfg :: LabelMap LabelSet + + + --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ... + rooted = ( fromBlockId root + , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet) + tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId + + -- Map from Nodes to their dominators + domMap :: LabelMap LabelSet + domMap = mkDomMap tree + + edges = edgeList cfg :: [(BlockId, BlockId)] + -- We can't recompute nodes from edges, there might be blocks not connected via edges. + nodes = getCfgNodes cfg :: [BlockId] + + -- identify back edges + isBackEdge (from,to) + | Just doms <- mapLookup from domMap + , setMember to doms + = True + | otherwise = False + + -- See Note [Determining the loop body] + -- Get the loop body associated with a back edge. + findBody edge@(tail, head) + = ( edge, setInsert head $ go (setSingleton tail) (setSingleton tail) ) + where + -- See Note [Determining the loop body] + + + go :: LabelSet -> LabelSet -> LabelSet + go found current + | setNull current = found + | otherwise = go (setUnion newSuccessors found) + newSuccessors + where + -- Really predecessors, since we use the reversed cfg. + newSuccessors = setFilter (\n -> not $ setMember n found) successors :: LabelSet + successors = setDelete head $ setUnions $ map + (\x -> if x == head then setEmpty else setFromList (getSuccessors revCfg x)) + (setElems current) :: LabelSet + + backEdges = filter isBackEdge edges + loopBodies = map findBody backEdges :: [(Edge, LabelSet)] + + -- Block b is part of n loop bodies => loop nest level of n + loopCounts = + let bodies = map (first snd) loopBodies -- [(Header, Body)] + loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies + in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] + + toIntSet :: LabelSet -> IntSet + toIntSet s = IS.fromList . map fromBlockId . setElems $ s + toIntMap :: LabelMap a -> IntMap a + toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m + + mkDomMap :: Tree BlockId -> LabelMap LabelSet + mkDomMap root = mapFromList $ go setEmpty root + where + go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)] + go parents (Node lbl []) + = [(lbl, parents)] + go parents (Node _ leaves) + = let nodes = map rootLabel leaves + entries = map (\x -> (x,parents)) nodes + in entries ++ concatMap + (\n -> go (setInsert (rootLabel n) parents) n) + leaves + + fromBlockId :: BlockId -> Int + fromBlockId = getKey . getUnique + + toBlockId :: Int -> BlockId + toBlockId = mkBlockId . mkUniqueGrimily + +-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. +newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId]) + +instance G.NonLocal (BlockNode) where + entryLabel (BN (lbl,_)) = lbl + successors (BN (_,succs)) = succs + +revPostorderFrom :: HasDebugCallStack => CFG -> BlockId -> [BlockId] +revPostorderFrom cfg root = + map fromNode $ G.revPostorderFrom hooplGraph root + where + nodes = getCfgNodes cfg + hooplGraph = foldl' (\m n -> mapInsert n (toNode n) m) mapEmpty nodes + + fromNode :: BlockNode C C -> BlockId + fromNode (BN x) = fst x + + toNode :: BlockId -> BlockNode C C + toNode bid = + BN (bid,getSuccessors cfg $ bid) + + +-- | We take in a CFG which has on its edges weights which are +-- relative only to other edges originating from the same node. +-- +-- We return a CFG for which each edge represents a GLOBAL weight. +-- This means edge weights are comparable across the whole graph. +-- +-- For irreducible control flow results might be imprecise, otherwise they +-- are reliable. +-- +-- The algorithm is based on the Paper +-- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus +-- The only big change is that we go over the nodes in the body of loops in +-- reverse post order. Which is required for diamond control flow to work probably. +-- +-- We also apply a few prediction heuristics (based on the same paper) +-- +-- The returned result represents frequences. +-- For blocks it's the expected number of executions and +-- for edges is the number of traversals. + +{-# NOINLINE mkGlobalWeights #-} +{-# SCC mkGlobalWeights #-} +mkGlobalWeights :: HasDebugCallStack => BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double)) +mkGlobalWeights root localCfg + | null localCfg = panic "Error - Empty CFG" + | otherwise + = (blockFreqs', edgeFreqs') + where + -- Calculate fixpoints + (blockFreqs, edgeFreqs) = calcFreqs nodeProbs backEdges' bodies' revOrder' + blockFreqs' = mapFromList $ map (first fromVertex) (assocs blockFreqs) :: LabelMap Double + edgeFreqs' = fmap fromVertexMap $ fromVertexMap edgeFreqs + + fromVertexMap :: IM.IntMap x -> LabelMap x + fromVertexMap m = mapFromList . map (first fromVertex) $ IM.toList m + + revOrder = revPostorderFrom localCfg root :: [BlockId] + loopResults@(LoopInfo backedges _levels bodies) = loopInfo localCfg root + + revOrder' = map toVertex revOrder + backEdges' = map (bimap toVertex toVertex) backedges + bodies' = map calcBody bodies + + estimatedCfg = staticBranchPrediction root loopResults localCfg + -- Normalize the weights to probabilities and apply heuristics + nodeProbs = cfgEdgeProbabilities estimatedCfg toVertex + + -- By mapping vertices to numbers in reverse post order we can bring any subset into reverse post + -- order simply by sorting. + -- TODO: The sort is redundant if we can guarantee that setElems returns elements ascending + calcBody (backedge, blocks) = + (toVertex $ snd backedge, sort . map toVertex $ (setElems blocks)) + + vertexMapping = mapFromList $ zip revOrder [0..] :: LabelMap Int + blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId + -- Map from blockId to indices starting at zero + toVertex :: BlockId -> Int + toVertex blockId = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping + -- Map from indices starting at zero to blockIds + fromVertex :: Int -> BlockId + fromVertex vertex = blockMapping ! vertex + +{- Note [Static Branch Prediction] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The work here has been based on the paper +"Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus. + +The primary differences are that if we branch on the result of a heap +check we do not apply any of the heuristics. +The reason is simple: They look like loops in the control flow graph +but are usually never entered, and if at most once. + +Currently implemented is a heuristic to predict that we do not exit +loops (lehPredicts) and one to predict that backedges are more likely +than any other edge. + +The back edge case is special as it superceeds any other heuristic if it +applies. + +Do NOT rely solely on nofib results for benchmarking this. I recommend at least +comparing megaparsec and container benchmarks. Nofib does not seeem to have +many instances of "loopy" Cmm where these make a difference. + +TODO: +* The paper containers more benchmarks which should be implemented. +* If we turn the likelihood on if/else branches into a probability + instead of true/false we could implement this as a Cmm pass. + + The complete Cmm code still exists and can be accessed by the heuristics + + There is no chance of register allocation/codegen inserting branches/blocks + + making the TransitionSource info wrong. + + potential to use this information in CmmPasses. + - Requires refactoring of all the code relying on the binary nature of likelihood. + - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG. +-} + +-- | Combination of target node id and information about the branch +-- we are looking at. +type TargetNodeInfo = (BlockId, EdgeInfo) + + +-- | Update branch weights based on certain heuristics. +-- See Note [Static Branch Prediction] +-- TODO: This should be combined with optimizeCFG +{-# SCC staticBranchPrediction #-} +staticBranchPrediction :: BlockId -> LoopInfo -> CFG -> CFG +staticBranchPrediction _root (LoopInfo l_backEdges loopLevels l_loops) cfg = + -- pprTrace "staticEstimatesOn" (ppr (cfg)) $ + foldl' update cfg nodes + where + nodes = getCfgNodes cfg + backedges = S.fromList $ l_backEdges + -- Loops keyed by their back edge + loops = M.fromList $ l_loops :: M.Map Edge LabelSet + loopHeads = S.fromList $ map snd $ M.keys loops + + update :: CFG -> BlockId -> CFG + update cfg node + -- No successors, nothing to do. + | null successors = cfg + + -- Mix of backedges and others: + -- Always predict the backedges. + | not (null m) && length m < length successors + -- Heap/Stack checks "loop", but only once. + -- So we simply exclude any case involving them. + , not $ any (isHeapOrStackCheck . transitionSource . snd) successors + = let loopChance = repeat $! pred_LBH / (fromIntegral $ length m) + exitChance = repeat $! (1 - pred_LBH) / fromIntegral (length not_m) + updates = zip (map fst m) loopChance ++ zip (map fst not_m) exitChance + in -- pprTrace "mix" (ppr (node,successors)) $ + foldl' (\cfg (to,weight) -> setEdgeWeight cfg weight node to) cfg updates + + -- For (regular) non-binary branches we keep the weights from the STG -> Cmm translation. + | length successors /= 2 + = cfg + + -- Only backedges - no need to adjust + | length m > 0 + = cfg + + -- A regular binary branch, we can plug addition predictors in here. + | [(s1,s1_info),(s2,s2_info)] <- successors + , not $ any (isHeapOrStackCheck . transitionSource . snd) successors + = -- Normalize weights to total of 1 + let !w1 = max (edgeWeight s1_info) (0) + !w2 = max (edgeWeight s2_info) (0) + -- Of both weights are <= 0 we set both to 0.5 + normalizeWeight w = if w1 + w2 == 0 then 0.5 else w/(w1+w2) + !cfg' = setEdgeWeight cfg (normalizeWeight w1) node s1 + !cfg'' = setEdgeWeight cfg' (normalizeWeight w2) node s2 + + -- Figure out which heuristics apply to these successors + heuristics = map ($ ((s1,s1_info),(s2,s2_info))) + [lehPredicts, phPredicts, ohPredicts, ghPredicts, lhhPredicts, chPredicts + , shPredicts, rhPredicts] + -- Apply result of a heuristic. Argument is the likelihood + -- predicted for s1. + applyHeuristic :: CFG -> Maybe Prob -> CFG + applyHeuristic cfg Nothing = cfg + applyHeuristic cfg (Just (s1_pred :: Double)) + | s1_old == 0 || s2_old == 0 || + isHeapOrStackCheck (transitionSource s1_info) || + isHeapOrStackCheck (transitionSource s2_info) + = cfg + | otherwise = + let -- Predictions from heuristic + s1_prob = EdgeWeight s1_pred :: EdgeWeight + s2_prob = 1.0 - s1_prob + -- Update + d = (s1_old * s1_prob) + (s2_old * s2_prob) :: EdgeWeight + s1_prob' = s1_old * s1_prob / d + !s2_prob' = s2_old * s2_prob / d + !cfg_s1 = setEdgeWeight cfg s1_prob' node s1 + in -- pprTrace "Applying heuristic!" (ppr (node,s1,s2) $$ ppr (s1_prob', s2_prob')) $ + setEdgeWeight cfg_s1 s2_prob' node s2 + where + -- Old weights + s1_old = getEdgeWeight cfg node s1 + s2_old = getEdgeWeight cfg node s2 + + in + -- pprTraceIt "RegularCfgResult" $ + foldl' applyHeuristic cfg'' heuristics + + -- Branch on heap/stack check + | otherwise = cfg + + where + -- Chance that loops are taken. + pred_LBH = 0.875 + -- successors + successors = getSuccessorEdges cfg node + -- backedges + (m,not_m) = partition (\succ -> S.member (node, fst succ) backedges) successors + + -- Heuristics return nothing if they don't say anything about this branch + -- or Just (prob_s1) where prob_s1 is the likelihood for s1 to be the + -- taken branch. s1 is the branch in the true case. + + -- Loop exit heuristic. + -- We are unlikely to leave a loop unless it's to enter another one. + pred_LEH = 0.75 + -- If and only if no successor is a loopheader, + -- then we will likely not exit the current loop body. + lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob + lehPredicts ((s1,_s1_info),(s2,_s2_info)) + | S.member s1 loopHeads || S.member s2 loopHeads + = Nothing + + | otherwise + = --pprTrace "lehPredict:" (ppr $ compare s1Level s2Level) $ + case compare s1Level s2Level of + EQ -> Nothing + LT -> Just (1-pred_LEH) --s1 exits to a shallower loop level (exits loop) + GT -> Just (pred_LEH) --s1 exits to a deeper loop level + where + s1Level = mapLookup s1 loopLevels + s2Level = mapLookup s2 loopLevels + + -- Comparing to a constant is unlikely to be equal. + ohPredicts (s1,_s2) + | CmmSource { trans_cmmNode = src1 } <- getTransitionSource node (fst s1) cfg + , CmmCondBranch cond ltrue _lfalse likely <- src1 + , likely == Nothing + , CmmMachOp mop args <- cond + , MO_Eq {} <- mop + , not (null [x | x@CmmLit{} <- args]) + = if fst s1 == ltrue then Just 0.3 else Just 0.7 + + | otherwise + = Nothing + + -- TODO: These are all the other heuristics from the paper. + -- Not all will apply, for now we just stub them out as Nothing. + phPredicts = const Nothing + ghPredicts = const Nothing + lhhPredicts = const Nothing + chPredicts = const Nothing + shPredicts = const Nothing + rhPredicts = const Nothing + +-- We normalize all edge weights as probabilities between 0 and 1. +-- Ignoring rounding errors all outgoing edges sum up to 1. +cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob) +cfgEdgeProbabilities cfg toVertex + = mapFoldlWithKey foldEdges IM.empty cfg + where + foldEdges = (\m from toMap -> IM.insert (toVertex from) (normalize toMap) m) + + normalize :: (LabelMap EdgeInfo) -> (IM.IntMap Prob) + normalize weightMap + | edgeCount <= 1 = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) 1.0 m) IM.empty weightMap + | otherwise = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) (normalWeight k) m) IM.empty weightMap + where + edgeCount = mapSize weightMap + -- Negative weights are generally allowed but are mapped to zero. + -- We then check if there is at least one non-zero edge and if not + -- assign uniform weights to all branches. + minWeight = 0 :: Prob + weightMap' = fmap (\w -> max (weightToDouble . edgeWeight $ w) minWeight) weightMap + totalWeight = sum weightMap' + + normalWeight :: BlockId -> Prob + normalWeight bid + | totalWeight == 0 + = 1.0 / fromIntegral edgeCount + | Just w <- mapLookup bid weightMap' + = w/totalWeight + | otherwise = panic "impossible" + +-- This is the fixpoint algorithm from +-- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus +-- The adaption to Haskell is my own. +calcFreqs :: IM.IntMap (IM.IntMap Prob) -> [(Int,Int)] -> [(Int, [Int])] -> [Int] + -> (Array Int Double, IM.IntMap (IM.IntMap Prob)) +calcFreqs graph backEdges loops revPostOrder = runST $ do + visitedNodes <- newArray (0,nodeCount-1) False :: ST s (STUArray s Int Bool) + blockFreqs <- newArray (0,nodeCount-1) 0.0 :: ST s (STUArray s Int Double) + edgeProbs <- newSTRef graph + edgeBackProbs <- newSTRef graph + + -- let traceArray a = do + -- vs <- forM [0..nodeCount-1] $ \i -> readArray a i >>= (\v -> return (i,v)) + -- trace ("array: " ++ show vs) $ return () + + let -- See #1600, we need to inline or unboxing makes perf worse. + -- {-# INLINE getFreq #-} + {-# INLINE visited #-} + visited b = unsafeRead visitedNodes b + getFreq b = unsafeRead blockFreqs b + -- setFreq :: forall s. Int -> Double -> ST s () + setFreq b f = unsafeWrite blockFreqs b f + -- setVisited :: forall s. Node -> ST s () + setVisited b = unsafeWrite visitedNodes b True + -- Frequency/probability that edge is taken. + getProb' arr b1 b2 = readSTRef arr >>= + (\graph -> + return . + fromMaybe (error "getFreq 1") . + IM.lookup b2 . + fromMaybe (error "getFreq 2") $ + (IM.lookup b1 graph) + ) + setProb' arr b1 b2 prob = do + g <- readSTRef arr + let !m = fromMaybe (error "Foo") $ IM.lookup b1 g + !m' = IM.insert b2 prob m + writeSTRef arr $! (IM.insert b1 m' g) + + getEdgeFreq b1 b2 = getProb' edgeProbs b1 b2 + setEdgeFreq b1 b2 = setProb' edgeProbs b1 b2 + getProb b1 b2 = fromMaybe (error "getProb") $ do + m' <- IM.lookup b1 graph + IM.lookup b2 m' + + getBackProb b1 b2 = getProb' edgeBackProbs b1 b2 + setBackProb b1 b2 = setProb' edgeBackProbs b1 b2 + + + let -- calcOutFreqs :: Node -> ST s () + calcOutFreqs bhead block = do + !f <- getFreq block + forM (successors block) $ \bi -> do + let !prob = getProb block bi + let !succFreq = f * prob + setEdgeFreq block bi succFreq + -- traceM $ "SetOut: " ++ show (block, bi, f, prob, succFreq) + when (bi == bhead) $ setBackProb block bi succFreq + + + let propFreq block head = do + -- traceM ("prop:" ++ show (block,head)) + -- traceShowM block + + !v <- visited block + if v then + return () --Dont look at nodes twice + else if block == head then + setFreq block 1.0 -- Loop header frequency is always 1 + else do + let preds = IS.elems $ predecessors block + irreducible <- (fmap or) $ forM preds $ \bp -> do + !bp_visited <- visited bp + let bp_backedge = isBackEdge bp block + return (not bp_visited && not bp_backedge) + + if irreducible + then return () -- Rare we don't care + else do + setFreq block 0 + !cycleProb <- sum <$> (forM preds $ \pred -> do + if isBackEdge pred block + then + getBackProb pred block + else do + !f <- getFreq block + !prob <- getEdgeFreq pred block + setFreq block $! f + prob + return 0) + -- traceM $ "cycleProb:" ++ show cycleProb + let limit = 1 - 1/512 -- Paper uses 1 - epsilon, but this works. + -- determines how large likelyhoods in loops can grow. + !cycleProb <- return $ min cycleProb limit -- <- return $ if cycleProb > limit then limit else cycleProb + -- traceM $ "cycleProb:" ++ show cycleProb + + !f <- getFreq block + setFreq block (f / (1.0 - cycleProb)) + + setVisited block + calcOutFreqs head block + + -- Loops, by nesting, inner to outer + forM_ loops $ \(head, body) -> do + forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i True) -- Mark all nodes as visited. + forM_ body (\i -> unsafeWrite visitedNodes i False) -- Mark all blocks reachable from head as not visited + forM_ body $ \block -> propFreq block head + + -- After dealing with all loops, deal with non-looping parts of the CFG + forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i False) -- Everything in revPostOrder is reachable + forM_ revPostOrder $ \block -> propFreq block (head revPostOrder) + + -- trace ("Final freqs:") $ return () + -- let freqString = pprFreqs freqs + -- trace (unlines freqString) $ return () + -- trace (pprFre) $ return () + graph' <- readSTRef edgeProbs + freqs' <- unsafeFreeze blockFreqs + + return (freqs', graph') + where + -- How can these lookups fail? Consider the CFG [A -> B] + predecessors :: Int -> IS.IntSet + predecessors b = fromMaybe IS.empty $ IM.lookup b revGraph + successors :: Int -> [Int] + successors b = fromMaybe (lookupError "succ" b graph)$ IM.keys <$> IM.lookup b graph + lookupError s b g = pprPanic ("Lookup error " ++ s) $ + ( text "node" <+> ppr b $$ + text "graph" <+> + vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g) + ) + + nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets count toMap) (IM.size graph) graph + where + countTargets = (\count k _ -> countNode k + count ) + countNode n = if IM.member n graph then 0 else 1 + + isBackEdge from to = S.member (from,to) backEdgeSet + backEdgeSet = S.fromList backEdges + + revGraph :: IntMap IntSet + revGraph = IM.foldlWithKey' (\m from toMap -> addEdges m from toMap) IM.empty graph + where + addEdges m0 from toMap = IM.foldlWithKey' (\m k _ -> addEdge m from k) m0 toMap + addEdge m0 from to = IM.insertWith IS.union to (IS.singleton from) m0 diff --git a/GHC/CmmToAsm/CFG/Dominators.hs b/GHC/CmmToAsm/CFG/Dominators.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/CFG/Dominators.hs @@ -0,0 +1,597 @@ +{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-} + +{- | + Module : Dominators + Copyright : (c) Matt Morrow 2009 + License : BSD3 + Maintainer : + Stability : experimental + Portability : portable + + Taken from the dom-lt package. + + The Lengauer-Tarjan graph dominators algorithm. + + \[1\] Lengauer, Tarjan, + /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979. + + \[2\] Muchnick, + /Advanced Compiler Design and Implementation/, 1997. + + \[3\] Brisk, Sarrafzadeh, + /Interference Graphs for Procedures in Static Single/ + /Information Form are Interval Graphs/, 2007. + + Originally taken from the dom-lt package. +-} + +module GHC.CmmToAsm.CFG.Dominators ( + Node,Path,Edge + ,Graph,Rooted + ,idom,ipdom + ,domTree,pdomTree + ,dom,pdom + ,pddfs,rpddfs + ,fromAdj,fromEdges + ,toAdj,toEdges + ,asTree,asGraph + ,parents,ancestors +) where + +import GHC.Prelude + +import Data.Bifunctor +import Data.Tuple (swap) + +import Data.Tree +import Data.IntMap(IntMap) +import Data.IntSet(IntSet) +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS + +import Control.Monad +import Control.Monad.ST.Strict + +import Data.Array.ST +import Data.Array.Base hiding ((!)) + -- (unsafeNewArray_ + -- ,unsafeWrite,unsafeRead + -- ,readArray,writeArray) + +import GHC.Utils.Misc (debugIsOn) + +----------------------------------------------------------------------------- + +type Node = Int +type Path = [Node] +type Edge = (Node,Node) +type Graph = IntMap IntSet +type Rooted = (Node, Graph) + +----------------------------------------------------------------------------- + +-- | /Dominators/. +-- Complexity as for @idom@ +dom :: Rooted -> [(Node, Path)] +dom = ancestors . domTree + +-- | /Post-dominators/. +-- Complexity as for @idom@. +pdom :: Rooted -> [(Node, Path)] +pdom = ancestors . pdomTree + +-- | /Dominator tree/. +-- Complexity as for @idom@. +domTree :: Rooted -> Tree Node +domTree a@(r,_) = + let is = filter ((/=r).fst) (idom a) + tg = fromEdges (fmap swap is) + in asTree (r,tg) + +-- | /Post-dominator tree/. +-- Complexity as for @idom@. +pdomTree :: Rooted -> Tree Node +pdomTree a@(r,_) = + let is = filter ((/=r).fst) (ipdom a) + tg = fromEdges (fmap swap is) + in asTree (r,tg) + +-- | /Immediate dominators/. +-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is +-- \"a functional inverse of Ackermann's function\". +-- +-- This Complexity bound assumes /O(1)/ indexing. Since we're +-- using @IntMap@, it has an additional /lg |V|/ factor +-- somewhere in there. I'm not sure where. +idom :: Rooted -> [(Node,Node)] +idom rg = runST (evalS idomM =<< initEnv (pruneReach rg)) + +-- | /Immediate post-dominators/. +-- Complexity as for @idom@. +ipdom :: Rooted -> [(Node,Node)] +ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg))) + +----------------------------------------------------------------------------- + +-- | /Post-dominated depth-first search/. +pddfs :: Rooted -> [Node] +pddfs = reverse . rpddfs + +-- | /Reverse post-dominated depth-first search/. +rpddfs :: Rooted -> [Node] +rpddfs = concat . levels . pdomTree + +----------------------------------------------------------------------------- + +type Dom s a = S s (Env s) a +type NodeSet = IntSet +type NodeMap a = IntMap a +data Env s = Env + {succE :: !Graph + ,predE :: !Graph + ,bucketE :: !Graph + ,dfsE :: {-# UNPACK #-}!Int + ,zeroE :: {-# UNPACK #-}!Node + ,rootE :: {-# UNPACK #-}!Node + ,labelE :: {-# UNPACK #-}!(Arr s Node) + ,parentE :: {-# UNPACK #-}!(Arr s Node) + ,ancestorE :: {-# UNPACK #-}!(Arr s Node) + ,childE :: {-# UNPACK #-}!(Arr s Node) + ,ndfsE :: {-# UNPACK #-}!(Arr s Node) + ,dfnE :: {-# UNPACK #-}!(Arr s Int) + ,sdnoE :: {-# UNPACK #-}!(Arr s Int) + ,sizeE :: {-# UNPACK #-}!(Arr s Int) + ,domE :: {-# UNPACK #-}!(Arr s Node) + ,rnE :: {-# UNPACK #-}!(Arr s Node)} + +----------------------------------------------------------------------------- + +idomM :: Dom s [(Node,Node)] +idomM = do + dfsDom =<< rootM + n <- gets dfsE + forM_ [n,n-1..1] (\i-> do + w <- ndfsM i + sw <- sdnoM w + ps <- predsM w + forM_ ps (\v-> do + u <- eval v + su <- sdnoM u + when (su < sw) + (store sdnoE w su)) + z <- ndfsM =<< sdnoM w + modify(\e->e{bucketE=IM.adjust + (w`IS.insert`) + z (bucketE e)}) + pw <- parentM w + link pw w + bps <- bucketM pw + forM_ bps (\v-> do + u <- eval v + su <- sdnoM u + sv <- sdnoM v + let dv = case su < sv of + True-> u + False-> pw + store domE v dv)) + forM_ [1..n] (\i-> do + w <- ndfsM i + j <- sdnoM w + z <- ndfsM j + dw <- domM w + when (dw /= z) + (do ddw <- domM dw + store domE w ddw)) + fromEnv + +----------------------------------------------------------------------------- + +eval :: Node -> Dom s Node +eval v = do + n0 <- zeroM + a <- ancestorM v + case a==n0 of + True-> labelM v + False-> do + compress v + a <- ancestorM v + l <- labelM v + la <- labelM a + sl <- sdnoM l + sla <- sdnoM la + case sl <= sla of + True-> return l + False-> return la + +compress :: Node -> Dom s () +compress v = do + n0 <- zeroM + a <- ancestorM v + aa <- ancestorM a + when (aa /= n0) (do + compress a + a <- ancestorM v + aa <- ancestorM a + l <- labelM v + la <- labelM a + sl <- sdnoM l + sla <- sdnoM la + when (sla < sl) + (store labelE v la) + store ancestorE v aa) + +----------------------------------------------------------------------------- + +link :: Node -> Node -> Dom s () +link v w = do + n0 <- zeroM + lw <- labelM w + slw <- sdnoM lw + let balance s = do + c <- childM s + lc <- labelM c + slc <- sdnoM lc + case slw < slc of + False-> return s + True-> do + zs <- sizeM s + zc <- sizeM c + cc <- childM c + zcc <- sizeM cc + case 2*zc <= zs+zcc of + True-> do + store ancestorE c s + store childE s cc + balance s + False-> do + store sizeE c zs + store ancestorE s c + balance c + s <- balance w + lw <- labelM w + zw <- sizeM w + store labelE s lw + store sizeE v . (+zw) =<< sizeM v + let follow s = do + when (s /= n0) (do + store ancestorE s v + follow =<< childM s) + zv <- sizeM v + follow =<< case zv < 2*zw of + False-> return s + True-> do + cv <- childM v + store childE v s + return cv + +----------------------------------------------------------------------------- + +dfsDom :: Node -> Dom s () +dfsDom i = do + _ <- go i + n0 <- zeroM + r <- rootM + store parentE r n0 + where go i = do + n <- nextM + store dfnE i n + store sdnoE i n + store ndfsE n i + store labelE i i + ss <- succsM i + forM_ ss (\j-> do + s <- sdnoM j + case s==0 of + False-> return() + True-> do + store parentE j i + go j) + +----------------------------------------------------------------------------- + +initEnv :: Rooted -> ST s (Env s) +initEnv (r0,g0) = do + let (g,rnmap) = renum 1 g0 + pred = predG g + r = rnmap IM.! r0 + n = IM.size g + ns = [0..n] + m = n+1 + + let bucket = IM.fromList + (zip ns (repeat mempty)) + + rna <- newI m + writes rna (fmap swap + (IM.toList rnmap)) + + doms <- newI m + sdno <- newI m + size <- newI m + parent <- newI m + ancestor <- newI m + child <- newI m + label <- newI m + ndfs <- newI m + dfn <- newI m + + forM_ [0..n] (doms.=0) + forM_ [0..n] (sdno.=0) + forM_ [1..n] (size.=1) + forM_ [0..n] (ancestor.=0) + forM_ [0..n] (child.=0) + + (doms.=r) r + (size.=0) 0 + (label.=0) 0 + + return (Env + {rnE = rna + ,dfsE = 0 + ,zeroE = 0 + ,rootE = r + ,labelE = label + ,parentE = parent + ,ancestorE = ancestor + ,childE = child + ,ndfsE = ndfs + ,dfnE = dfn + ,sdnoE = sdno + ,sizeE = size + ,succE = g + ,predE = pred + ,bucketE = bucket + ,domE = doms}) + +fromEnv :: Dom s [(Node,Node)] +fromEnv = do + dom <- gets domE + rn <- gets rnE + -- r <- gets rootE + (_,n) <- st (getBounds dom) + forM [1..n] (\i-> do + j <- st(rn!:i) + d <- st(dom!:i) + k <- st(rn!:d) + return (j,k)) + +----------------------------------------------------------------------------- + +zeroM :: Dom s Node +zeroM = gets zeroE +domM :: Node -> Dom s Node +domM = fetch domE +rootM :: Dom s Node +rootM = gets rootE +succsM :: Node -> Dom s [Node] +succsM i = gets (IS.toList . (! i) . succE) +predsM :: Node -> Dom s [Node] +predsM i = gets (IS.toList . (! i) . predE) +bucketM :: Node -> Dom s [Node] +bucketM i = gets (IS.toList . (! i) . bucketE) +sizeM :: Node -> Dom s Int +sizeM = fetch sizeE +sdnoM :: Node -> Dom s Int +sdnoM = fetch sdnoE +-- dfnM :: Node -> Dom s Int +-- dfnM = fetch dfnE +ndfsM :: Int -> Dom s Node +ndfsM = fetch ndfsE +childM :: Node -> Dom s Node +childM = fetch childE +ancestorM :: Node -> Dom s Node +ancestorM = fetch ancestorE +parentM :: Node -> Dom s Node +parentM = fetch parentE +labelM :: Node -> Dom s Node +labelM = fetch labelE +nextM :: Dom s Int +nextM = do + n <- gets dfsE + let n' = n+1 + modify(\e->e{dfsE=n'}) + return n' + +----------------------------------------------------------------------------- + +type A = STUArray +type Arr s a = A s Int a + +infixl 9 !: +infixr 2 .= + +(.=) :: (MArray (A s) a (ST s)) + => Arr s a -> a -> Int -> ST s () +(v .= x) i + | debugIsOn = writeArray v i x + | otherwise = unsafeWrite v i x + +(!:) :: (MArray (A s) a (ST s)) + => A s Int a -> Int -> ST s a +a !: i + | debugIsOn = do + o <- readArray a i + return $! o + | otherwise = do + o <- unsafeRead a i + return $! o + +new :: (MArray (A s) a (ST s)) + => Int -> ST s (Arr s a) +new n = unsafeNewArray_ (0,n-1) + +newI :: Int -> ST s (Arr s Int) +newI = new + +-- newD :: Int -> ST s (Arr s Double) +-- newD = new + +-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a] +-- dump a = do +-- (m,n) <- getBounds a +-- forM [m..n] (\i -> a!:i) + +writes :: (MArray (A s) a (ST s)) + => Arr s a -> [(Int,a)] -> ST s () +writes a xs = forM_ xs (\(i,x) -> (a.=x) i) + +-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a) +-- arr xs = do +-- let n = length xs +-- a <- new n +-- go a n 0 xs +-- return a +-- where go _ _ _ [] = return () +-- go a n i (x:xs) +-- | i <= n = (a.=x) i >> go a n (i+1) xs +-- | otherwise = return () + +----------------------------------------------------------------------------- + +(!) :: Monoid a => IntMap a -> Int -> a +(!) g n = maybe mempty id (IM.lookup n g) + +fromAdj :: [(Node, [Node])] -> Graph +fromAdj = IM.fromList . fmap (second IS.fromList) + +fromEdges :: [Edge] -> Graph +fromEdges = collectI IS.union fst (IS.singleton . snd) + +toAdj :: Graph -> [(Node, [Node])] +toAdj = fmap (second IS.toList) . IM.toList + +toEdges :: Graph -> [Edge] +toEdges = concatMap (uncurry (fmap . (,))) . toAdj + +predG :: Graph -> Graph +predG g = IM.unionWith IS.union (go g) g0 + where g0 = fmap (const mempty) g + f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet + f m i a = foldl' (\m p -> IM.insertWith mappend p + (IS.singleton i) m) + m + (IS.toList a) + go :: IntMap IntSet -> IntMap IntSet + go = flip IM.foldlWithKey' mempty f + +pruneReach :: Rooted -> Rooted +pruneReach (r,g) = (r,g2) + where is = reachable + (maybe mempty id + . flip IM.lookup g) $ r + g2 = IM.fromList + . fmap (second (IS.filter (`IS.member`is))) + . filter ((`IS.member`is) . fst) + . IM.toList $ g + +tip :: Tree a -> (a, [Tree a]) +tip (Node a ts) = (a, ts) + +parents :: Tree a -> [(a, a)] +parents (Node i xs) = p i xs + ++ concatMap parents xs + where p i = fmap (flip (,) i . rootLabel) + +ancestors :: Tree a -> [(a, [a])] +ancestors = go [] + where go acc (Node i xs) + = let acc' = i:acc + in p acc' xs ++ concatMap (go acc') xs + p is = fmap (flip (,) is . rootLabel) + +asGraph :: Tree Node -> Rooted +asGraph t@(Node a _) = let g = go t in (a, fromAdj g) + where go (Node a ts) = let as = (fst . unzip . fmap tip) ts + in (a, as) : concatMap go ts + +asTree :: Rooted -> Tree Node +asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a)) + f = (g !) + in go r + +reachable :: (Node -> NodeSet) -> (Node -> NodeSet) +reachable f a = go (IS.singleton a) a + where go seen a = let s = f a + as = IS.toList (s `IS.difference` seen) + in foldl' go (s `IS.union` seen) as + +collectI :: (c -> c -> c) + -> (a -> Int) -> (a -> c) -> [a] -> IntMap c +collectI (<>) f g + = foldl' (\m a -> IM.insertWith (<>) + (f a) + (g a) m) mempty + +-- collect :: (Ord b) => (c -> c -> c) +-- -> (a -> b) -> (a -> c) -> [a] -> Map b c +-- collect (<>) f g +-- = foldl' (\m a -> SM.insertWith (<>) +-- (f a) +-- (g a) m) mempty + +-- (renamed, old -> new) +renum :: Int -> Graph -> (Graph, NodeMap Node) +renum from = (\(_,m,g)->(g,m)) + . IM.foldlWithKey' + f (from,mempty,mempty) + where + f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet + -> (Int, NodeMap Node, IntMap IntSet) + f (!n,!env,!new) i ss = + let (j,n2,env2) = go n env i + (n3,env3,ss2) = IS.fold + (\k (!n,!env,!new)-> + case go n env k of + (l,n2,env2)-> (n2,env2,l `IS.insert` new)) + (n2,env2,mempty) ss + new2 = IM.insertWith IS.union j ss2 new + in (n3,env3,new2) + go :: Int + -> NodeMap Node + -> Node + -> (Node,Int,NodeMap Node) + go !n !env i = + case IM.lookup i env of + Just j -> (j,n,env) + Nothing -> (n,n+1,IM.insert i n env) + +----------------------------------------------------------------------------- + +newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o} +instance Functor (S z s) where + fmap f (S g) = S (\k -> g (k . f)) +instance Monad (S z s) where + return = pure + S g >>= f = S (\k -> g (\a -> unS (f a) k)) +instance Applicative (S z s) where + pure a = S (\k -> k a) + (<*>) = ap +-- get :: S z s s +-- get = S (\k s -> k s s) +gets :: (s -> a) -> S z s a +gets f = S (\k s -> k (f s) s) +-- set :: s -> S z s () +-- set s = S (\k _ -> k () s) +modify :: (s -> s) -> S z s () +modify f = S (\k -> k () . f) +-- runS :: S z s a -> s -> ST z (a, s) +-- runS (S g) = g (\a s -> return (a,s)) +evalS :: S z s a -> s -> ST z a +evalS (S g) = g ((return .) . const) +-- execS :: S z s a -> s -> ST z s +-- execS (S g) = g ((return .) . flip const) +st :: ST z a -> S z s a +st m = S (\k s-> do + a <- m + k a s) +store :: (MArray (A z) a (ST z)) + => (s -> Arr z a) -> Int -> a -> S z s () +store f i x = do + a <- gets f + st ((a.=x) i) +fetch :: (MArray (A z) a (ST z)) + => (s -> Arr z a) -> Int -> S z s a +fetch f i = do + a <- gets f + st (a!:i) + diff --git a/GHC/CmmToAsm/CPrim.hs b/GHC/CmmToAsm/CPrim.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/CPrim.hs @@ -0,0 +1,143 @@ +-- | Generating C symbol names emitted by the compiler. +module GHC.CmmToAsm.CPrim + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , xchgLabel + , popCntLabel + , pdepLabel + , pextLabel + , bSwapLabel + , bRevLabel + , clzLabel + , ctzLabel + , word2FloatLabel + ) where + +import GHC.Prelude + +import GHC.Cmm.Type +import GHC.Cmm.MachOp +import GHC.Utils.Outputable + +popCntLabel :: Width -> String +popCntLabel w = "hs_popcnt" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w) + +pdepLabel :: Width -> String +pdepLabel w = "hs_pdep" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "pdepLabel: Unsupported word width " (ppr w) + +pextLabel :: Width -> String +pextLabel w = "hs_pext" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "pextLabel: Unsupported word width " (ppr w) + +bSwapLabel :: Width -> String +bSwapLabel w = "hs_bswap" ++ pprWidth w + where + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w) + +bRevLabel :: Width -> String +bRevLabel w = "hs_bitrev" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "bRevLabel: Unsupported word width " (ppr w) + +clzLabel :: Width -> String +clzLabel w = "hs_clz" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "clzLabel: Unsupported word width " (ppr w) + +ctzLabel :: Width -> String +ctzLabel w = "hs_ctz" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w) + +word2FloatLabel :: Width -> String +word2FloatLabel w = "hs_word2float" ++ pprWidth w + where + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> String +atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + pprFunName AMO_Add = "add" + pprFunName AMO_Sub = "sub" + pprFunName AMO_And = "and" + pprFunName AMO_Nand = "nand" + pprFunName AMO_Or = "or" + pprFunName AMO_Xor = "xor" + +xchgLabel :: Width -> String +xchgLabel w = "hs_xchg" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "xchgLabel: Unsupported word width " (ppr w) + +cmpxchgLabel :: Width -> String +cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> String +atomicReadLabel w = "hs_atomicread" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> String +atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/GHC/CmmToAsm/Config.hs b/GHC/CmmToAsm/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Config.hs @@ -0,0 +1,42 @@ +-- | Native code generator configuration +module GHC.CmmToAsm.Config + ( NCGConfig(..) + , ncgWordWidth + , platformWordWidth + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Cmm.Type (Width(..)) + +-- | Native code generator configuration +data NCGConfig = NCGConfig + { ncgPlatform :: !Platform -- ^ Target platform + , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment + , ncgDebugLevel :: !Int -- ^ Debug level + , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries + , ncgPIC :: !Bool -- ^ Enable Position-Independent Code + , ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it + , ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset` + , ncgSplitSections :: !Bool -- ^ Split sections + , ncgSpillPreallocSize :: !Int -- ^ Size in bytes of the pre-allocated spill space on the C stack + , ncgRegsIterative :: !Bool + , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass + , ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding + , ncgSseVersion :: Maybe SseVersion -- ^ (x86) SSE instructions + , ncgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions + , ncgDumpRegAllocStages :: !Bool + , ncgDumpAsmStats :: !Bool + , ncgDumpAsmConflicts :: !Bool + } + +-- | Return Word size +ncgWordWidth :: NCGConfig -> Width +ncgWordWidth config = platformWordWidth (ncgPlatform config) + +-- | Return Word size +platformWordWidth :: Platform -> Width +platformWordWidth platform = case platformWordSize platform of + PW4 -> W32 + PW8 -> W64 diff --git a/GHC/CmmToAsm/Dwarf.hs b/GHC/CmmToAsm/Dwarf.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Dwarf.hs @@ -0,0 +1,270 @@ +module GHC.CmmToAsm.Dwarf ( + dwarfGen + ) where + +import GHC.Prelude + +import GHC.Cmm.CLabel +import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Settings.Config ( cProjectName, cProjectVersion ) +import GHC.Core ( Tickish(..) ) +import GHC.Cmm.DebugBlock +import GHC.Driver.Session +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique +import GHC.Types.Unique.Supply + +import GHC.CmmToAsm.Dwarf.Constants +import GHC.CmmToAsm.Dwarf.Types + +import Control.Arrow ( first ) +import Control.Monad ( mfilter ) +import Data.Maybe +import Data.List ( sortBy ) +import Data.Ord ( comparing ) +import qualified Data.Map as Map +import System.FilePath +import System.Directory ( getCurrentDirectory ) + +import qualified GHC.Cmm.Dataflow.Label as H +import qualified GHC.Cmm.Dataflow.Collections as H + +-- | Generate DWARF/debug information +dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] + -> IO (SDoc, UniqSupply) +dwarfGen _ _ us [] = return (empty, us) +dwarfGen df modLoc us blocks = do + let platform = targetPlatform df + + -- Convert debug data structures to DWARF info records + -- We strip out block information when running with -g0 or -g1. + let procs = debugSplitProcs blocks + stripBlocks dbg + | debugLevel df < 2 = dbg { dblBlocks = [] } + | otherwise = dbg + compPath <- getCurrentDirectory + let lowLabel = dblCLabel $ head procs + highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs + dwarfUnit = DwarfCompileUnit + { dwChildren = map (procToDwarf df) (map stripBlocks procs) + , dwName = fromMaybe "" (ml_hs_file modLoc) + , dwCompDir = addTrailingPathSeparator compPath + , dwProducer = cProjectName ++ " " ++ cProjectVersion + , dwLowLabel = lowLabel + , dwHighLabel = highLabel + , dwLineLabel = dwarfLineLabel + } + + -- Check whether we have any source code information, so we do not + -- end up writing a pointer to an empty .debug_line section + -- (dsymutil on Mac Os gets confused by this). + let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) + || any haveSrcIn (dblBlocks blk) + haveSrc = any haveSrcIn procs + + -- .debug_abbrev section: Declare the format we're using + let abbrevSct = pprAbbrevDecls platform haveSrc + + -- .debug_info section: Information records on procedures and blocks + let -- unique to identify start and end compilation unit .debug_inf + (unitU, us') = takeUniqFromSupply us + infoSct = vcat [ ptext dwarfInfoLabel <> colon + , dwarfInfoSection platform + , compileUnitHeader platform unitU + , pprDwarfInfo platform haveSrc dwarfUnit + , compileUnitFooter unitU + ] + + -- .debug_line section: Generated mainly by the assembler, but we + -- need to label it + let lineSct = dwarfLineSection platform $$ + ptext dwarfLineLabel <> colon + + -- .debug_frame section: Information about the layout of the GHC stack + let (framesU, us'') = takeUniqFromSupply us' + frameSct = dwarfFrameSection platform $$ + ptext dwarfFrameLabel <> colon $$ + pprDwarfFrame platform (debugFrame framesU procs) + + -- .aranges section: Information about the bounds of compilation units + let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs + | otherwise = [DwarfARange lowLabel highLabel] + let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU + + return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') + +-- | Build an address range entry for one proc. +-- With split sections, each proc needs its own entry, since they may get +-- scattered in the final binary. Without split sections, we could make a +-- single arange based on the first/last proc. +mkDwarfARange :: DebugBlock -> DwarfARange +mkDwarfARange proc = DwarfARange start end + where + start = dblCLabel proc + end = mkAsmTempEndLabel start + +-- | Header for a compilation unit, establishing global format +-- parameters +compileUnitHeader :: Platform -> Unique -> SDoc +compileUnitHeader platform unitU = + let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field + length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel + <> text "-4" -- length of initialLength field + in vcat [ ppr cuLabel <> colon + , text "\t.long " <> length -- compilation unit size + , pprHalf 3 -- DWARF version + , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) + -- abbrevs offset + , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size + ] + +-- | Compilation unit footer, mainly establishing size of debug sections +compileUnitFooter :: Unique -> SDoc +compileUnitFooter unitU = + let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU + in ppr cuEndLabel <> colon + +-- | Splits the blocks by procedures. In the result all nested blocks +-- will come from the same procedure as the top-level block. See +-- Note [Splitting DebugBlocks] for details. +debugSplitProcs :: [DebugBlock] -> [DebugBlock] +debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b + where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty + split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock] + split parent blk = H.mapInsert prc [blk'] nested + where prc = dblProcedure blk + blk' = blk { dblBlocks = own_blks + , dblParent = parent + } + own_blks = fromMaybe [] $ H.mapLookup prc nested + nested = mergeMaps $ map (split parent') $ dblBlocks blk + -- Figure out who should be the parent of nested blocks. + -- If @blk@ is optimized out then it isn't a good choice + -- and we just use its parent. + parent' + | Nothing <- dblPosition blk = parent + | otherwise = Just blk + +{- +Note [Splitting DebugBlocks] + +DWARF requires that we break up the nested DebugBlocks produced from +the C-- AST. For instance, we begin with tick trees containing nested procs. +For example, + + proc A [tick1, tick2] + block B [tick3] + proc C [tick4] + +when producing DWARF we need to procs (which are represented in DWARF as +TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for +this transform, pulling out the nested procs into top-level procs. + +However, in doing this we need to be careful to preserve the parentage of the +nested procs. This is the reason DebugBlocks carry the dblParent field, allowing +us to reorganize the above tree as, + + proc A [tick1, tick2] + block B [tick3] + proc C [tick4] parent=B + +Here we have annotated the new proc C with an attribute giving its original +parent, B. +-} + +-- | Generate DWARF info for a procedure debug block +procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo +procToDwarf df prc + = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc) + , dwName = case dblSourceTick prc of + Just s@SourceNote{} -> sourceName s + _otherwise -> showSDocDump df $ ppr $ dblLabel prc + , dwLabel = dblCLabel prc + , dwParent = fmap mkAsmTempDieLabel + $ mfilter goodParent + $ fmap dblCLabel (dblParent prc) + } + where + goodParent a | a == dblCLabel prc = False + -- Omit parent if it would be self-referential + goodParent a | not (externallyVisibleCLabel a) + , debugLevel df < 2 = False + -- We strip block information when running -g0 or -g1, don't + -- refer to blocks in that case. Fixes #14894. + goodParent _ = True + +-- | Generate DWARF info for a block +blockToDwarf :: DebugBlock -> DwarfInfo +blockToDwarf blk + = DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk) + ++ map blockToDwarf (dblBlocks blk) + , dwLabel = dblCLabel blk + , dwMarker = marker + } + where + marker + | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk + | otherwise = Nothing -- block was optimized out + +tickToDwarf :: Tickish () -> [DwarfInfo] +tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss] +tickToDwarf _ = [] + +-- | Generates the data for the debug frame section, which encodes the +-- desired stack unwind behaviour for the debugger +debugFrame :: Unique -> [DebugBlock] -> DwarfFrame +debugFrame u procs + = DwarfFrame { dwCieLabel = mkAsmTempLabel u + , dwCieInit = initUws + , dwCieProcs = map (procToFrame initUws) procs + } + where + initUws :: UnwindTable + initUws = Map.fromList [(Sp, Just (UwReg Sp 0))] + +-- | Generates unwind information for a procedure debug block +procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc +procToFrame initUws blk + = DwarfFrameProc { dwFdeProc = dblCLabel blk + , dwFdeHasInfo = dblHasInfoTbl blk + , dwFdeBlocks = map (uncurry blockToFrame) + (setHasInfo blockUws) + } + where blockUws :: [(DebugBlock, [UnwindPoint])] + blockUws = map snd $ sortBy (comparing fst) $ flatten blk + + flatten :: DebugBlock + -> [(Int, (DebugBlock, [UnwindPoint]))] + flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks } + | Just p <- pos = (p, (b, uws')):nested + | otherwise = nested -- block was optimized out + where uws' = addDefaultUnwindings initUws uws + nested = concatMap flatten blocks + + -- | If the current procedure has an info table, then we also say that + -- its first block has one to ensure that it gets the necessary -1 + -- offset applied to its start address. + -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types". + setHasInfo :: [(DebugBlock, [UnwindPoint])] + -> [(DebugBlock, [UnwindPoint])] + setHasInfo [] = [] + setHasInfo (c0:cs) = first setIt c0 : cs + where + setIt child = + child { dblHasInfoTbl = dblHasInfoTbl child + || dblHasInfoTbl blk } + +blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock +blockToFrame blk uws + = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk + , dwFdeUnwind = uws + } + +addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint] +addDefaultUnwindings tbl pts = + [ UnwindPoint lbl (tbl' `mappend` tbl) + -- mappend is left-biased + | UnwindPoint lbl tbl' <- pts + ] diff --git a/GHC/CmmToAsm/Dwarf/Constants.hs b/GHC/CmmToAsm/Dwarf/Constants.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Dwarf/Constants.hs @@ -0,0 +1,232 @@ +-- | Constants describing the DWARF format. Most of this simply +-- mirrors \/usr\/include\/dwarf.h. + +module GHC.CmmToAsm.Dwarf.Constants where + +import GHC.Prelude + +import GHC.Utils.Asm +import GHC.Data.FastString +import GHC.Platform +import GHC.Utils.Outputable + +import GHC.Platform.Reg +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.PPC.Regs (toRegNo) + +import Data.Word + +-- | Language ID used for Haskell. +dW_LANG_Haskell :: Word +dW_LANG_Haskell = 0x18 + -- Thanks to Nathan Howell for getting us our very own language ID! + +-- * Dwarf tags +dW_TAG_compile_unit, dW_TAG_subroutine_type, + dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block, + dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type, + dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef, + dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable, + dW_TAG_ghc_src_note :: Word +dW_TAG_array_type = 1 +dW_TAG_lexical_block = 11 +dW_TAG_pointer_type = 15 +dW_TAG_compile_unit = 17 +dW_TAG_structure_type = 19 +dW_TAG_typedef = 22 +dW_TAG_subroutine_type = 32 +dW_TAG_subrange_type = 33 +dW_TAG_base_type = 36 +dW_TAG_file_type = 41 +dW_TAG_subprogram = 46 +dW_TAG_variable = 52 +dW_TAG_auto_variable = 256 +dW_TAG_arg_variable = 257 + +dW_TAG_ghc_src_note = 0x5b00 + +-- * Dwarf attributes +dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language, + dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base, + dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word +dW_AT_name = 0x03 +dW_AT_stmt_list = 0x10 +dW_AT_low_pc = 0x11 +dW_AT_high_pc = 0x12 +dW_AT_language = 0x13 +dW_AT_comp_dir = 0x1b +dW_AT_producer = 0x25 +dW_AT_external = 0x3f +dW_AT_frame_base = 0x40 +dW_AT_use_UTF8 = 0x53 +dW_AT_MIPS_linkage_name = 0x2007 + +-- * Custom DWARF attributes +-- Chosen a more or less random section of the vendor-extensible region + +-- ** Describing C-- blocks +-- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks +dW_AT_ghc_tick_parent :: Word +dW_AT_ghc_tick_parent = 0x2b20 + +-- ** Describing source notes +-- These appear in DW_TAG_ghc_src_note DIEs +dW_AT_ghc_span_file, dW_AT_ghc_span_start_line, + dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line, + dW_AT_ghc_span_end_col :: Word +dW_AT_ghc_span_file = 0x2b00 +dW_AT_ghc_span_start_line = 0x2b01 +dW_AT_ghc_span_start_col = 0x2b02 +dW_AT_ghc_span_end_line = 0x2b03 +dW_AT_ghc_span_end_col = 0x2b04 + + +-- * Abbrev declarations +dW_CHILDREN_no, dW_CHILDREN_yes :: Word8 +dW_CHILDREN_no = 0 +dW_CHILDREN_yes = 1 + +dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag, + dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word +dW_FORM_addr = 0x01 +dW_FORM_data2 = 0x05 +dW_FORM_data4 = 0x06 +dW_FORM_string = 0x08 +dW_FORM_flag = 0x0c +dW_FORM_block1 = 0x0a +dW_FORM_ref_addr = 0x10 +dW_FORM_ref4 = 0x13 +dW_FORM_flag_present = 0x19 + +-- * Dwarf native types +dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed, + dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word +dW_ATE_address = 1 +dW_ATE_boolean = 2 +dW_ATE_float = 4 +dW_ATE_signed = 5 +dW_ATE_signed_char = 6 +dW_ATE_unsigned = 7 +dW_ATE_unsigned_char = 8 + +-- * Call frame information +dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value, + dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression, + dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf, + dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression, + dW_CFA_offset :: Word8 +dW_CFA_set_loc = 0x01 +dW_CFA_undefined = 0x07 +dW_CFA_same_value = 0x08 +dW_CFA_def_cfa = 0x0c +dW_CFA_def_cfa_offset = 0x0e +dW_CFA_def_cfa_expression = 0x0f +dW_CFA_expression = 0x10 +dW_CFA_offset_extended_sf = 0x11 +dW_CFA_def_cfa_sf = 0x12 +dW_CFA_def_cfa_offset_sf = 0x13 +dW_CFA_val_offset = 0x14 +dW_CFA_val_expression = 0x16 +dW_CFA_offset = 0x80 + +-- * Operations +dW_OP_addr, dW_OP_deref, dW_OP_consts, + dW_OP_minus, dW_OP_mul, dW_OP_plus, + dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8 +dW_OP_addr = 0x03 +dW_OP_deref = 0x06 +dW_OP_consts = 0x11 +dW_OP_minus = 0x1c +dW_OP_mul = 0x1e +dW_OP_plus = 0x22 +dW_OP_lit0 = 0x30 +dW_OP_breg0 = 0x70 +dW_OP_call_frame_cfa = 0x9c + +-- * Dwarf section declarations +dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, + dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc +dwarfInfoSection platform = dwarfSection platform "info" +dwarfAbbrevSection platform = dwarfSection platform "abbrev" +dwarfLineSection platform = dwarfSection platform "line" +dwarfFrameSection platform = dwarfSection platform "frame" +dwarfGhcSection platform = dwarfSection platform "ghc" +dwarfARangesSection platform = dwarfSection platform "aranges" + +dwarfSection :: Platform -> String -> SDoc +dwarfSection platform name = + case platformOS platform of + os | osElfTarget os + -> text "\t.section .debug_" <> text name <> text ",\"\"," + <> sectionType platform "progbits" + | osMachOTarget os + -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug" + | otherwise + -> text "\t.section .debug_" <> text name <> text ",\"dr\"" + +-- * Dwarf section labels +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString +dwarfInfoLabel = sLit ".Lsection_info" +dwarfAbbrevLabel = sLit ".Lsection_abbrev" +dwarfLineLabel = sLit ".Lsection_line" +dwarfFrameLabel = sLit ".Lsection_frame" + +-- | Mapping of registers to DWARF register numbers +dwarfRegNo :: Platform -> Reg -> Word8 +dwarfRegNo p r = case platformArch p of + ArchX86 + | r == eax -> 0 + | r == ecx -> 1 -- yes, no typo + | r == edx -> 2 + | r == ebx -> 3 + | r == esp -> 4 + | r == ebp -> 5 + | r == esi -> 6 + | r == edi -> 7 + ArchX86_64 + | r == rax -> 0 + | r == rdx -> 1 -- this neither. The order GCC allocates registers in? + | r == rcx -> 2 + | r == rbx -> 3 + | r == rsi -> 4 + | r == rdi -> 5 + | r == rbp -> 6 + | r == rsp -> 7 + | r == r8 -> 8 + | r == r9 -> 9 + | r == r10 -> 10 + | r == r11 -> 11 + | r == r12 -> 12 + | r == r13 -> 13 + | r == r14 -> 14 + | r == r15 -> 15 + | r == xmm0 -> 17 + | r == xmm1 -> 18 + | r == xmm2 -> 19 + | r == xmm3 -> 20 + | r == xmm4 -> 21 + | r == xmm5 -> 22 + | r == xmm6 -> 23 + | r == xmm7 -> 24 + | r == xmm8 -> 25 + | r == xmm9 -> 26 + | r == xmm10 -> 27 + | r == xmm11 -> 28 + | r == xmm12 -> 29 + | r == xmm13 -> 30 + | r == xmm14 -> 31 + | r == xmm15 -> 32 + ArchPPC_64 _ -> fromIntegral $ toRegNo r + _other -> error "dwarfRegNo: Unsupported platform or unknown register!" + +-- | Virtual register number to use for return address. +dwarfReturnRegNo :: Platform -> Word8 +dwarfReturnRegNo p + -- We "overwrite" IP with our pseudo register - that makes sense, as + -- when using this mechanism gdb already knows the IP anyway. Clang + -- does this too, so it must be safe. + = case platformArch p of + ArchX86 -> 8 -- eip + ArchX86_64 -> 16 -- rip + ArchPPC_64 ELF_V2 -> 65 -- lr (link register) + _other -> error "dwarfReturnRegNo: Unsupported platform!" diff --git a/GHC/CmmToAsm/Dwarf/Types.hs b/GHC/CmmToAsm/Dwarf/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Dwarf/Types.hs @@ -0,0 +1,609 @@ +module GHC.CmmToAsm.Dwarf.Types + ( -- * Dwarf information + DwarfInfo(..) + , pprDwarfInfo + , pprAbbrevDecls + -- * Dwarf address range table + , DwarfARange(..) + , pprDwarfARanges + -- * Dwarf frame + , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..) + , pprDwarfFrame + -- * Utilities + , pprByte + , pprHalf + , pprData4' + , pprDwWord + , pprWord + , pprLEBWord + , pprLEBInt + , wordAlign + , sectionOffset + ) + where + +import GHC.Prelude + +import GHC.Cmm.DebugBlock +import GHC.Cmm.CLabel +import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique +import GHC.Platform.Reg +import GHC.Types.SrcLoc +import GHC.Utils.Misc + +import GHC.CmmToAsm.Dwarf.Constants + +import qualified Data.ByteString as BS +import qualified Control.Monad.Trans.State.Strict as S +import Control.Monad (zipWithM, join) +import Data.Bits +import qualified Data.Map as Map +import Data.Word +import Data.Char + +import GHC.Platform.Regs + +-- | Individual dwarf records. Each one will be encoded as an entry in +-- the @.debug_info@ section. +data DwarfInfo + = DwarfCompileUnit { dwChildren :: [DwarfInfo] + , dwName :: String + , dwProducer :: String + , dwCompDir :: String + , dwLowLabel :: CLabel + , dwHighLabel :: CLabel + , dwLineLabel :: PtrString } + | DwarfSubprogram { dwChildren :: [DwarfInfo] + , dwName :: String + , dwLabel :: CLabel + , dwParent :: Maybe CLabel + -- ^ label of DIE belonging to the parent tick + } + | DwarfBlock { dwChildren :: [DwarfInfo] + , dwLabel :: CLabel + , dwMarker :: Maybe CLabel + } + | DwarfSrcNote { dwSrcSpan :: RealSrcSpan + } + +-- | Abbreviation codes used for encoding above records in the +-- @.debug_info@ section. +data DwarfAbbrev + = DwAbbrNull -- ^ Pseudo, used for marking the end of lists + | DwAbbrCompileUnit + | DwAbbrSubprogram + | DwAbbrSubprogramWithParent + | DwAbbrBlockWithoutCode + | DwAbbrBlock + | DwAbbrGhcSrcNote + deriving (Eq, Enum) + +-- | Generate assembly for the given abbreviation code +pprAbbrev :: DwarfAbbrev -> SDoc +pprAbbrev = pprLEBWord . fromIntegral . fromEnum + +-- | Abbreviation declaration. This explains the binary encoding we +-- use for representing 'DwarfInfo'. Be aware that this must be updated +-- along with 'pprDwarfInfo'. +pprAbbrevDecls :: Platform -> Bool -> SDoc +pprAbbrevDecls platform haveDebugLine = + let mkAbbrev abbr tag chld flds = + let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form + in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$ + vcat (map fld flds) $$ pprByte 0 $$ pprByte 0 + -- These are shared between DwAbbrSubprogram and + -- DwAbbrSubprogramWithParent + subprogramAttrs = + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_MIPS_linkage_name, dW_FORM_string) + , (dW_AT_external, dW_FORM_flag) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + , (dW_AT_frame_base, dW_FORM_block1) + ] + in dwarfAbbrevSection platform $$ + ptext dwarfAbbrevLabel <> colon $$ + mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes + ([(dW_AT_name, dW_FORM_string) + , (dW_AT_producer, dW_FORM_string) + , (dW_AT_language, dW_FORM_data4) + , (dW_AT_comp_dir, dW_FORM_string) + , (dW_AT_use_UTF8, dW_FORM_flag_present) -- not represented in body + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + ] ++ + (if haveDebugLine + then [ (dW_AT_stmt_list, dW_FORM_data4) ] + else [])) $$ + mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes + subprogramAttrs $$ + mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes + (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$ + mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + ] $$ + mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + ] $$ + mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no + [ (dW_AT_ghc_span_file, dW_FORM_string) + , (dW_AT_ghc_span_start_line, dW_FORM_data4) + , (dW_AT_ghc_span_start_col, dW_FORM_data2) + , (dW_AT_ghc_span_end_line, dW_FORM_data4) + , (dW_AT_ghc_span_end_col, dW_FORM_data2) + ] $$ + pprByte 0 + +-- | Generate assembly for DWARF data +pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfo platform haveSrc d + = case d of + DwarfCompileUnit {} -> hasChildren + DwarfSubprogram {} -> hasChildren + DwarfBlock {} -> hasChildren + DwarfSrcNote {} -> noChildren + where + hasChildren = + pprDwarfInfoOpen platform haveSrc d $$ + vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$ + pprDwarfInfoClose + noChildren = pprDwarfInfoOpen platform haveSrc d + +-- | Prints assembler data corresponding to DWARF info records. Note +-- that the binary format of this is parameterized in @abbrevDecls@ and +-- has to be kept in synch. +pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel + highLabel lineLbl) = + pprAbbrev DwAbbrCompileUnit + $$ pprString name + $$ pprString producer + $$ pprData4 dW_LANG_Haskell + $$ pprString compDir + $$ pprWord platform (ppr lowLabel) + $$ pprWord platform (ppr highLabel) + $$ if haveSrc + then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel) + else empty +pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label + parent) = sdocWithDynFlags $ \df -> + ppr (mkAsmTempDieLabel label) <> colon + $$ pprAbbrev abbrev + $$ pprString name + $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label)) + $$ pprFlag (externallyVisibleCLabel label) + $$ pprWord platform (ppr label) + $$ pprWord platform (ppr $ mkAsmTempEndLabel label) + $$ pprByte 1 + $$ pprByte dW_OP_call_frame_cfa + $$ parentValue + where + abbrev = case parent of Nothing -> DwAbbrSubprogram + Just _ -> DwAbbrSubprogramWithParent + parentValue = maybe empty pprParentDie parent + pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel) +pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df -> + ppr (mkAsmTempDieLabel label) <> colon + $$ pprAbbrev DwAbbrBlockWithoutCode + $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label)) +pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df -> + ppr (mkAsmTempDieLabel label) <> colon + $$ pprAbbrev DwAbbrBlock + $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label)) + $$ pprWord platform (ppr marker) + $$ pprWord platform (ppr $ mkAsmTempEndLabel marker) +pprDwarfInfoOpen _ _ (DwarfSrcNote ss) = + pprAbbrev DwAbbrGhcSrcNote + $$ pprString' (ftext $ srcSpanFile ss) + $$ pprData4 (fromIntegral $ srcSpanStartLine ss) + $$ pprHalf (fromIntegral $ srcSpanStartCol ss) + $$ pprData4 (fromIntegral $ srcSpanEndLine ss) + $$ pprHalf (fromIntegral $ srcSpanEndCol ss) + +-- | Close a DWARF info record with children +pprDwarfInfoClose :: SDoc +pprDwarfInfoClose = pprAbbrev DwAbbrNull + +-- | A DWARF address range. This is used by the debugger to quickly locate +-- which compilation unit a given address belongs to. This type assumes +-- a non-segmented address-space. +data DwarfARange + = DwarfARange + { dwArngStartLabel :: CLabel + , dwArngEndLabel :: CLabel + } + +-- | Print assembler directives corresponding to a DWARF @.debug_aranges@ +-- address table entry. +pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc +pprDwarfARanges platform arngs unitU = + let wordSize = platformWordSizeInBytes platform + paddingSize = 4 :: Int + -- header is 12 bytes long. + -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform). + -- pad such that first entry begins at multiple of entry size. + pad n = vcat $ replicate n $ pprByte 0 + -- Fix for #17428 + initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize + in pprDwWord (ppr initialLength) + $$ pprHalf 2 + $$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU) + (ptext dwarfInfoLabel) + $$ pprByte (fromIntegral wordSize) + $$ pprByte 0 + $$ pad paddingSize + -- body + $$ vcat (map (pprDwarfARange platform) arngs) + -- terminus + $$ pprWord platform (char '0') + $$ pprWord platform (char '0') + +pprDwarfARange :: Platform -> DwarfARange -> SDoc +pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length + where + length = ppr (dwArngEndLabel arng) + <> char '-' <> ppr (dwArngStartLabel arng) + +-- | Information about unwind instructions for a procedure. This +-- corresponds to a "Common Information Entry" (CIE) in DWARF. +data DwarfFrame + = DwarfFrame + { dwCieLabel :: CLabel + , dwCieInit :: UnwindTable + , dwCieProcs :: [DwarfFrameProc] + } + +-- | Unwind instructions for an individual procedure. Corresponds to a +-- "Frame Description Entry" (FDE) in DWARF. +data DwarfFrameProc + = DwarfFrameProc + { dwFdeProc :: CLabel + , dwFdeHasInfo :: Bool + , dwFdeBlocks :: [DwarfFrameBlock] + -- ^ List of blocks. Order must match asm! + } + +-- | Unwind instructions for a block. Will become part of the +-- containing FDE. +data DwarfFrameBlock + = DwarfFrameBlock + { dwFdeBlkHasInfo :: Bool + , dwFdeUnwind :: [UnwindPoint] + -- ^ these unwind points must occur in the same order as they occur + -- in the block + } + +instance Outputable DwarfFrameBlock where + ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds + +-- | Header for the @.debug_frame@ section. Here we emit the "Common +-- Information Entry" record that establishes general call frame +-- parameters and the default stack layout. +pprDwarfFrame :: Platform -> DwarfFrame -> SDoc +pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} + = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") + cieEndLabel = mkAsmTempEndLabel cieLabel + length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel + spReg = dwarfGlobalRegNo platform Sp + retReg = dwarfReturnRegNo platform + wordSize = platformWordSizeInBytes platform + pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc + pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw) + + -- Preserve C stack pointer: This necessary to override that default + -- unwinding behavior of setting $sp = CFA. + preserveSp = case platformArch platform of + ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 + ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 + _ -> empty + in vcat [ ppr cieLabel <> colon + , pprData4' length -- Length of CIE + , ppr cieStartLabel <> colon + , pprData4' (text "-1") + -- Common Information Entry marker (-1 = 0xf..f) + , pprByte 3 -- CIE version (we require DWARF 3) + , pprByte 0 -- Augmentation (none) + , pprByte 1 -- Code offset multiplicator + , pprByte (128-fromIntegral wordSize) + -- Data offset multiplicator + -- (stacks grow down => "-w" in signed LEB128) + , pprByte retReg -- virtual register holding return address + ] $$ + -- Initial unwind table + vcat (map pprInit $ Map.toList cieInit) $$ + vcat [ -- RET = *CFA + pprByte (dW_CFA_offset+retReg) + , pprByte 0 + + -- Preserve C stack pointer + , preserveSp + + -- Sp' = CFA + -- (we need to set this manually as our (STG) Sp register is + -- often not the architecture's default stack register) + , pprByte dW_CFA_val_offset + , pprLEBWord (fromIntegral spReg) + , pprLEBWord 0 + ] $$ + wordAlign platform $$ + ppr cieEndLabel <> colon $$ + -- Procedure unwind tables + vcat (map (pprFrameProc platform cieLabel cieInit) procs) + +-- | Writes a "Frame Description Entry" for a procedure. This consists +-- mainly of referencing the CIE and writing state machine +-- instructions to describe how the frame base (CFA) changes. +pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc +pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) + = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") + fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") + procEnd = mkAsmTempEndLabel procLbl + ifInfo str = if hasInfo then text str else empty + -- see [Note: Info Offset] + in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon + , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel) + , ppr fdeLabel <> colon + , pprData4' (ppr frameLbl <> char '-' <> + ptext dwarfFrameLabel) -- Reference to CIE + , pprWord platform (ppr procLbl <> ifInfo "-1") -- Code pointer + , pprWord platform (ppr procEnd <> char '-' <> + ppr procLbl <> ifInfo "+1") -- Block byte length + ] $$ + vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$ + wordAlign platform $$ + ppr fdeEndLabel <> colon + +-- | Generates unwind information for a block. We only generate +-- instructions where unwind information actually changes. This small +-- optimisations saves a lot of space, as subsequent blocks often have +-- the same unwind information. +pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc +pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) = + vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0 + where + pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc + pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws -> + let -- Did a register's unwind expression change? + isChanged :: GlobalReg -> Maybe UnwindExpr + -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr) + isChanged g new + -- the value didn't change + | Just new == old = Nothing + -- the value was and still is undefined + | Nothing <- old + , Nothing <- new = Nothing + -- the value changed + | otherwise = Just (join old, new) + where + old = Map.lookup g oldUws + + changed = Map.toList $ Map.mapMaybeWithKey isChanged uws + + in if oldUws == uws + then (empty, oldUws) + else let -- see [Note: Info Offset] + needsOffset = firstDecl && hasInfo + lblDoc = ppr lbl <> + if needsOffset then text "-1" else empty + doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$ + vcat (map (uncurry $ pprSetUnwind platform) changed) + in (doc, uws) + +-- Note [Info Offset] +-- +-- GDB was pretty much written with C-like programs in mind, and as a +-- result they assume that once you have a return address, it is a +-- good idea to look at (PC-1) to unwind further - as that's where the +-- "call" instruction is supposed to be. +-- +-- Now on one hand, code generated by GHC looks nothing like what GDB +-- expects, and in fact going up from a return pointer is guaranteed +-- to land us inside an info table! On the other hand, that actually +-- gives us some wiggle room, as we expect IP to never *actually* end +-- up inside the info table, so we can "cheat" by putting whatever GDB +-- expects to see there. This is probably pretty safe, as GDB cannot +-- assume (PC-1) to be a valid code pointer in the first place - and I +-- have seen no code trying to correct this. +-- +-- Note that this will not prevent GDB from failing to look-up the +-- correct function name for the frame, as that uses the symbol table, +-- which we can not manipulate as easily. +-- +-- There's a GDB patch to address this at [1]. At the moment of writing +-- it's not merged, so I recommend building GDB with the patch if you +-- care about unwinding. The hack above doesn't cover every case. +-- +-- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html + +-- | Get DWARF register ID for a given GlobalReg +dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8 +dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p +dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg + +-- | Generate code for setting the unwind information for a register, +-- optimized using its known old value in the table. Note that "Sp" is +-- special: We see it as synonym for the CFA. +pprSetUnwind :: Platform + -> GlobalReg + -- ^ the register to produce an unwinding table entry for + -> (Maybe UnwindExpr, Maybe UnwindExpr) + -- ^ the old and new values of the register + -> SDoc +pprSetUnwind plat g (_, Nothing) + = pprUndefUnwind plat g +pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s' + = if o' >= 0 + then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') + else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' +pprSetUnwind plat Sp (_, Just (UwReg s' o')) + = if o' >= 0 + then pprByte dW_CFA_def_cfa $$ + pprLEBRegNo plat s' $$ + pprLEBWord (fromIntegral o') + else pprByte dW_CFA_def_cfa_sf $$ + pprLEBRegNo plat s' $$ + pprLEBInt o' +pprSetUnwind plat Sp (_, Just uw) + = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw +pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) + | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case + = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ + pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat)) + | otherwise + = pprByte dW_CFA_offset_extended_sf $$ + pprLEBRegNo plat g $$ + pprLEBInt o +pprSetUnwind plat g (_, Just (UwDeref uw)) + = pprByte dW_CFA_expression $$ + pprLEBRegNo plat g $$ + pprUnwindExpr plat True uw +pprSetUnwind plat g (_, Just (UwReg g' 0)) + | g == g' + = pprByte dW_CFA_same_value $$ + pprLEBRegNo plat g +pprSetUnwind plat g (_, Just uw) + = pprByte dW_CFA_val_expression $$ + pprLEBRegNo plat g $$ + pprUnwindExpr plat True uw + +-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 +-- encoded number. +pprLEBRegNo :: Platform -> GlobalReg -> SDoc +pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat + +-- | Generates a DWARF expression for the given unwind expression. If +-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets +-- mentioned. +pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc +pprUnwindExpr platform spIsCFA expr + = let pprE (UwConst i) + | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) + | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... + pprE (UwReg Sp i) | spIsCFA + = if i == 0 + then pprByte dW_OP_call_frame_cfa + else pprE (UwPlus (UwReg Sp 0) (UwConst i)) + pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ + pprLEBInt i + pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref + pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (ppr l) + pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus + pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus + pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul + in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length + -- computed as the difference of the following local labels 2: and 1: + text "1:" $$ + pprE expr $$ + text "2:" + +-- | Generate code for re-setting the unwind information for a +-- register to @undefined@ +pprUndefUnwind :: Platform -> GlobalReg -> SDoc +pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ + pprLEBRegNo plat g + + +-- | Align assembly at (machine) word boundary +wordAlign :: Platform -> SDoc +wordAlign plat = + text "\t.align " <> case platformOS plat of + OSDarwin -> case platformWordSize plat of + PW8 -> char '3' + PW4 -> char '2' + _other -> ppr (platformWordSizeInBytes plat) + +-- | Assembly for a single byte of constant DWARF data +pprByte :: Word8 -> SDoc +pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word) + +-- | Assembly for a two-byte constant integer +pprHalf :: Word16 -> SDoc +pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word) + +-- | Assembly for a constant DWARF flag +pprFlag :: Bool -> SDoc +pprFlag f = pprByte (if f then 0xff else 0x00) + +-- | Assembly for 4 bytes of dynamic DWARF data +pprData4' :: SDoc -> SDoc +pprData4' x = text "\t.long " <> x + +-- | Assembly for 4 bytes of constant DWARF data +pprData4 :: Word -> SDoc +pprData4 = pprData4' . ppr + +-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as +-- we are generating 32 bit DWARF. +pprDwWord :: SDoc -> SDoc +pprDwWord = pprData4' + +-- | Assembly for a machine word of dynamic data. Depends on the +-- architecture we are currently generating code for. +pprWord :: Platform -> SDoc -> SDoc +pprWord plat s = + case platformWordSize plat of + PW4 -> text "\t.long " <> s + PW8 -> text "\t.quad " <> s + +-- | Prints a number in "little endian base 128" format. The idea is +-- to optimize for small numbers by stopping once all further bytes +-- would be 0. The highest bit in every byte signals whether there +-- are further bytes to read. +pprLEBWord :: Word -> SDoc +pprLEBWord x | x < 128 = pprByte (fromIntegral x) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBWord (x `shiftR` 7) + +-- | Same as @pprLEBWord@, but for a signed number +pprLEBInt :: Int -> SDoc +pprLEBInt x | x >= -64 && x < 64 + = pprByte (fromIntegral (x .&. 127)) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBInt (x `shiftR` 7) + +-- | Generates a dynamic null-terminated string. If required the +-- caller needs to make sure that the string is escaped properly. +pprString' :: SDoc -> SDoc +pprString' str = text "\t.asciz \"" <> str <> char '"' + +-- | Generate a string constant. We take care to escape the string. +pprString :: String -> SDoc +pprString str + = pprString' $ hcat $ map escapeChar $ + if str `lengthIs` utf8EncodedLength str + then str + else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str + +-- | Escape a single non-unicode character +escapeChar :: Char -> SDoc +escapeChar '\\' = text "\\\\" +escapeChar '\"' = text "\\\"" +escapeChar '\n' = text "\\n" +escapeChar c + | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings + = char c + | otherwise + = char '\\' <> char (intToDigit (ch `div` 64)) <> + char (intToDigit ((ch `div` 8) `mod` 8)) <> + char (intToDigit (ch `mod` 8)) + where ch = ord c + +-- | Generate an offset into another section. This is tricky because +-- this is handled differently depending on platform: Mac Os expects +-- us to calculate the offset using assembler arithmetic. Linux expects +-- us to just reference the target directly, and will figure out on +-- their own that we actually need an offset. Finally, Windows has +-- a special directive to refer to relative offsets. Fun. +sectionOffset :: Platform -> SDoc -> SDoc -> SDoc +sectionOffset plat target section = + case platformOS plat of + OSDarwin -> pprDwWord (target <> char '-' <> section) + OSMinGW32 -> text "\t.secrel32 " <> target + _other -> pprDwWord target diff --git a/GHC/CmmToAsm/Format.hs b/GHC/CmmToAsm/Format.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Format.hs @@ -0,0 +1,105 @@ +-- | Formats on this architecture +-- A Format is a combination of width and class +-- +-- TODO: Signed vs unsigned? +-- +-- TODO: This module is currently shared by all architectures because +-- NCGMonad need to know about it to make a VReg. It would be better +-- to have architecture specific formats, and do the overloading +-- properly. eg SPARC doesn't care about FF80. +-- +module GHC.CmmToAsm.Format ( + Format(..), + intFormat, + floatFormat, + isFloatFormat, + cmmTypeFormat, + formatToWidth, + formatInBytes +) + +where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Utils.Outputable + +-- It looks very like the old MachRep, but it's now of purely local +-- significance, here in the native code generator. You can change it +-- without global consequences. +-- +-- A major use is as an opcode qualifier; thus the opcode +-- mov.l a b +-- might be encoded +-- MOV II32 a b +-- where the Format field encodes the ".l" part. + +-- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats +-- here. I've removed them from the x86 version, we'll see what happens --SDM + +-- ToDo: quite a few occurrences of Format could usefully be replaced by Width + +data Format + = II8 + | II16 + | II32 + | II64 + | FF32 + | FF64 + deriving (Show, Eq) + + +-- | Get the integer format of this width. +intFormat :: Width -> Format +intFormat width + = case width of + W8 -> II8 + W16 -> II16 + W32 -> II32 + W64 -> II64 + other -> sorry $ "The native code generator cannot " ++ + "produce code for Format.intFormat " ++ show other + ++ "\n\tConsider using the llvm backend with -fllvm" + + +-- | Get the float format of this width. +floatFormat :: Width -> Format +floatFormat width + = case width of + W32 -> FF32 + W64 -> FF64 + + other -> pprPanic "Format.floatFormat" (ppr other) + + +-- | Check if a format represents a floating point value. +isFloatFormat :: Format -> Bool +isFloatFormat format + = case format of + FF32 -> True + FF64 -> True + _ -> False + + +-- | Convert a Cmm type to a Format. +cmmTypeFormat :: CmmType -> Format +cmmTypeFormat ty + | isFloatType ty = floatFormat (typeWidth ty) + | otherwise = intFormat (typeWidth ty) + + +-- | Get the Width of a Format. +formatToWidth :: Format -> Width +formatToWidth format + = case format of + II8 -> W8 + II16 -> W16 + II32 -> W32 + II64 -> W64 + FF32 -> W32 + FF64 -> W64 + + +formatInBytes :: Format -> Int +formatInBytes = widthInBytes . formatToWidth diff --git a/GHC/CmmToAsm/Instr.hs b/GHC/CmmToAsm/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Instr.hs @@ -0,0 +1,206 @@ + +module GHC.CmmToAsm.Instr ( + RegUsage(..), + noUsage, + GenBasicBlock(..), blockId, + ListGraph(..), + NatCmm, + NatCmmDecl, + NatBasicBlock, + topInfoTable, + entryBlocks, + Instruction(..) +) + +where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Reg + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Cmm hiding (topInfoTable) + +import GHC.CmmToAsm.Config + +-- | Holds a list of source and destination registers used by a +-- particular instruction. +-- +-- Machine registers that are pre-allocated to stgRegs are filtered +-- out, because they are uninteresting from a register allocation +-- standpoint. (We wouldn't want them to end up on the free list!) +-- +-- As far as we are concerned, the fixed registers simply don't exist +-- (for allocation purposes, anyway). +-- +data RegUsage + = RU { + reads :: [Reg], + writes :: [Reg] + } + +-- | No regs read or written to. +noUsage :: RegUsage +noUsage = RU [] [] + +-- Our flavours of the Cmm types +-- Type synonyms for Cmm populated with native code +type NatCmm instr + = GenCmmGroup + RawCmmStatics + (LabelMap RawCmmStatics) + (ListGraph instr) + +type NatCmmDecl statics instr + = GenCmmDecl + statics + (LabelMap RawCmmStatics) + (ListGraph instr) + + +type NatBasicBlock instr + = GenBasicBlock instr + + +-- | Returns the info table associated with the CmmDecl's entry point, +-- if any. +topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i +topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) + = mapLookup (blockId b) infos +topInfoTable _ + = Nothing + +-- | Return the list of BlockIds in a CmmDecl that are entry points +-- for this proc (i.e. they may be jumped to from outside this proc). +entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId] +entryBlocks (CmmProc info _ _ (ListGraph code)) = entries + where + infos = mapKeys info + entries = case code of + [] -> infos + BasicBlock entry _ : _ -- first block is the entry point + | entry `elem` infos -> infos + | otherwise -> entry : infos +entryBlocks _ = [] + +-- | Common things that we can do with instructions, on all architectures. +-- These are used by the shared parts of the native code generator, +-- specifically the register allocators. +-- +class Instruction instr where + + -- | Get the registers that are being used by this instruction. + -- regUsage doesn't need to do any trickery for jumps and such. + -- Just state precisely the regs read and written by that insn. + -- The consequences of control flow transfers, as far as register + -- allocation goes, are taken care of by the register allocator. + -- + regUsageOfInstr + :: Platform + -> instr + -> RegUsage + + + -- | Apply a given mapping to all the register references in this + -- instruction. + patchRegsOfInstr + :: instr + -> (Reg -> Reg) + -> instr + + + -- | Checks whether this instruction is a jump/branch instruction. + -- One that can change the flow of control in a way that the + -- register allocator needs to worry about. + isJumpishInstr + :: instr -> Bool + + + -- | Give the possible destinations of this jump instruction. + -- Must be defined for all jumpish instructions. + jumpDestsOfInstr + :: instr -> [BlockId] + + + -- | Change the destination of this jump instruction. + -- Used in the linear allocator when adding fixup blocks for join + -- points. + patchJumpInstr + :: instr + -> (BlockId -> BlockId) + -> instr + + + -- | An instruction to spill a register into a spill slot. + mkSpillInstr + :: NCGConfig + -> Reg -- ^ the reg to spill + -> Int -- ^ the current stack delta + -> Int -- ^ spill slot to use + -> instr + + + -- | An instruction to reload a register from a spill slot. + mkLoadInstr + :: NCGConfig + -> Reg -- ^ the reg to reload. + -> Int -- ^ the current stack delta + -> Int -- ^ the spill slot to use + -> instr + + -- | See if this instruction is telling us the current C stack delta + takeDeltaInstr + :: instr + -> Maybe Int + + -- | Check whether this instruction is some meta thing inserted into + -- the instruction stream for other purposes. + -- + -- Not something that has to be treated as a real machine instruction + -- and have its registers allocated. + -- + -- eg, comments, delta, ldata, etc. + isMetaInstr + :: instr + -> Bool + + + + -- | Copy the value in a register to another one. + -- Must work for all register classes. + mkRegRegMoveInstr + :: Platform + -> Reg -- ^ source register + -> Reg -- ^ destination register + -> instr + + -- | Take the source and destination from this reg -> reg move instruction + -- or Nothing if it's not one + takeRegRegMoveInstr + :: instr + -> Maybe (Reg, Reg) + + -- | Make an unconditional jump instruction. + -- For architectures with branch delay slots, its ok to put + -- a NOP after the jump. Don't fill the delay slot with an + -- instruction that references regs or you'll confuse the + -- linear allocator. + mkJumpInstr + :: BlockId + -> [instr] + + + -- Subtract an amount from the C stack pointer + mkStackAllocInstr + :: Platform + -> Int + -> [instr] + + -- Add an amount to the C stack pointer + mkStackDeallocInstr + :: Platform + -> Int + -> [instr] diff --git a/GHC/CmmToAsm/Monad.hs b/GHC/CmmToAsm/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Monad.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE BangPatterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- The native code generator's monad. +-- +-- ----------------------------------------------------------------------------- + +module GHC.CmmToAsm.Monad ( + NcgImpl(..), + NatM_State(..), mkNatM_State, + + NatM, -- instance Monad + initNat, + initConfig, + addImportNat, + addNodeBetweenNat, + addImmediateSuccessorNat, + updateCfgNat, + getUniqueNat, + mapAccumLNat, + setDeltaNat, + getConfig, + getPlatform, + getDeltaNat, + getThisModuleNat, + getBlockIdNat, + getNewLabelNat, + getNewRegNat, + getNewRegPairNat, + getPicBaseMaybeNat, + getPicBaseNat, + getDynFlags, + getModLoc, + getFileId, + getDebugBlock, + + DwarfFiles +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Reg +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Cmm.DebugBlock +import GHC.Data.FastString ( FastString ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Types.Unique ( Unique ) +import GHC.Driver.Session +import GHC.Unit.Module + +import Control.Monad ( ap ) + +import GHC.CmmToAsm.Instr +import GHC.Utils.Outputable (SDoc, pprPanic, ppr) +import GHC.Cmm (RawCmmDecl, RawCmmStatics) +import GHC.CmmToAsm.CFG + +data NcgImpl statics instr jumpDest = NcgImpl { + ncgConfig :: !NCGConfig, + cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), + getJumpDestBlockId :: jumpDest -> Maybe BlockId, + canShortcut :: instr -> Maybe jumpDest, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, + shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, + pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, + maxSpillSlots :: Int, + allocatableRegs :: [RealReg], + ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], + ncgAllocMoreStack :: Int -> NatCmmDecl statics instr + -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]), + -- ^ The list of block ids records the redirected jumps to allow us to update + -- the CFG. + ncgMakeFarBranches :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr], + extractUnwindPoints :: [instr] -> [UnwindPoint], + -- ^ given the instruction sequence of a block, produce a list of + -- the block's 'UnwindPoint's + -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" + -- and Note [Unwinding information in the NCG] in this module. + invertCondBranches :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr] + -> [NatBasicBlock instr] + -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \@ + -- when possible. + } + +data NatM_State + = NatM_State { + natm_us :: UniqSupply, + natm_delta :: Int, + natm_imports :: [(CLabel)], + natm_pic :: Maybe Reg, + natm_dflags :: DynFlags, + natm_config :: NCGConfig, + natm_this_module :: Module, + natm_modloc :: ModLocation, + natm_fileid :: DwarfFiles, + natm_debug_map :: LabelMap DebugBlock, + natm_cfg :: CFG + -- ^ Having a CFG with additional information is essential for some + -- operations. However we can't reconstruct all information once we + -- generated instructions. So instead we update the CFG as we go. + } + +type DwarfFiles = UniqFM FastString (FastString, Int) + +newtype NatM result = NatM (NatM_State -> (result, NatM_State)) + deriving (Functor) + +unNat :: NatM a -> NatM_State -> (a, NatM_State) +unNat (NatM a) = a + +mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation -> + DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State +mkNatM_State us delta dflags this_mod + = \loc dwf dbg cfg -> + NatM_State + { natm_us = us + , natm_delta = delta + , natm_imports = [] + , natm_pic = Nothing + , natm_dflags = dflags + , natm_config = initConfig dflags + , natm_this_module = this_mod + , natm_modloc = loc + , natm_fileid = dwf + , natm_debug_map = dbg + , natm_cfg = cfg + } + +-- | Initialize the native code generator configuration from the DynFlags +initConfig :: DynFlags -> NCGConfig +initConfig dflags = NCGConfig + { ncgPlatform = targetPlatform dflags + , ncgProcAlignment = cmmProcAlignment dflags + , ncgDebugLevel = debugLevel dflags + , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , ncgPIC = positionIndependent dflags + , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags + , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags + , ncgSplitSections = gopt Opt_SplitSections dflags + , ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags + , ncgRegsIterative = gopt Opt_RegsIterative dflags + , ncgAsmLinting = gopt Opt_DoAsmLinting dflags + + -- With -O1 and greater, the cmmSink pass does constant-folding, so + -- we don't need to do it again in the native code generator. + , ncgDoConstantFolding = optLevel dflags < 1 + + , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags + , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags + , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags + , ncgBmiVersion = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags + ArchX86 -> bmiVersion dflags + _ -> Nothing + + -- We Assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + , ncgSseVersion = + let v | sseVersion dflags < Just SSE2 = Just SSE2 + | otherwise = sseVersion dflags + in case platformArch (targetPlatform dflags) of + ArchX86_64 -> v + ArchX86 -> v + _ -> Nothing + } + + +initNat :: NatM_State -> NatM a -> (a, NatM_State) +initNat init_st m + = case unNat m init_st of { (r,st) -> (r,st) } + +instance Applicative NatM where + pure = returnNat + (<*>) = ap + +instance Monad NatM where + (>>=) = thenNat + +instance MonadUnique NatM where + getUniqueSupplyM = NatM $ \st -> + case splitUniqSupply (natm_us st) of + (us1, us2) -> (us1, st {natm_us = us2}) + + getUniqueM = NatM $ \st -> + case takeUniqFromSupply (natm_us st) of + (uniq, us') -> (uniq, st {natm_us = us'}) + +thenNat :: NatM a -> (a -> NatM b) -> NatM b +thenNat expr cont + = NatM $ \st -> case unNat expr st of + (result, st') -> unNat (cont result) st' + +returnNat :: a -> NatM a +returnNat result + = NatM $ \st -> (result, st) + +mapAccumLNat :: (acc -> x -> NatM (acc, y)) + -> acc + -> [x] + -> NatM (acc, [y]) + +mapAccumLNat _ b [] + = return (b, []) +mapAccumLNat f b (x:xs) + = do (b__2, x__2) <- f b x + (b__3, xs__2) <- mapAccumLNat f b__2 xs + return (b__3, x__2:xs__2) + +getUniqueNat :: NatM Unique +getUniqueNat = NatM $ \ st -> + case takeUniqFromSupply $ natm_us st of + (uniq, us') -> (uniq, st {natm_us = us'}) + +instance HasDynFlags NatM where + getDynFlags = NatM $ \ st -> (natm_dflags st, st) + + +getDeltaNat :: NatM Int +getDeltaNat = NatM $ \ st -> (natm_delta st, st) + + +setDeltaNat :: Int -> NatM () +setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) + + +getThisModuleNat :: NatM Module +getThisModuleNat = NatM $ \ st -> (natm_this_module st, st) + + +addImportNat :: CLabel -> NatM () +addImportNat imp + = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st}) + +updateCfgNat :: (CFG -> CFG) -> NatM () +updateCfgNat f + = NatM $ \ st -> let !cfg' = f (natm_cfg st) + in ((), st { natm_cfg = cfg'}) + +-- | Record that we added a block between `from` and `old`. +addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM () +addNodeBetweenNat from between to + = do df <- getDynFlags + let jmpWeight = fromIntegral . uncondWeight . + cfgWeightInfo $ df + updateCfgNat (updateCfg jmpWeight from between to) + where + -- When transforming A -> B to A -> A' -> B + -- A -> A' keeps the old edge info while + -- A' -> B gets the info for an unconditional + -- jump. + updateCfg weight from between old m + | Just info <- getEdgeInfo from old m + = addEdge from between info . + addWeightEdge between old weight . + delEdge from old $ m + | otherwise + = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to)) + + +-- | Place `succ` after `block` and change any edges +-- block -> X to `succ` -> X +addImmediateSuccessorNat :: BlockId -> BlockId -> NatM () +addImmediateSuccessorNat block succ = do + dflags <- getDynFlags + updateCfgNat (addImmediateSuccessor dflags block succ) + +getBlockIdNat :: NatM BlockId +getBlockIdNat + = do u <- getUniqueNat + return (mkBlockId u) + + +getNewLabelNat :: NatM CLabel +getNewLabelNat + = blockLbl <$> getBlockIdNat + + +getNewRegNat :: Format -> NatM Reg +getNewRegNat rep + = do u <- getUniqueNat + platform <- getPlatform + return (RegVirtual $ targetMkVirtualReg platform u rep) + + +getNewRegPairNat :: Format -> NatM (Reg,Reg) +getNewRegPairNat rep + = do u <- getUniqueNat + platform <- getPlatform + let vLo = targetMkVirtualReg platform u rep + let lo = RegVirtual $ targetMkVirtualReg platform u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return (lo, hi) + + +getPicBaseMaybeNat :: NatM (Maybe Reg) +getPicBaseMaybeNat + = NatM (\state -> (natm_pic state, state)) + + +getPicBaseNat :: Format -> NatM Reg +getPicBaseNat rep + = do mbPicBase <- getPicBaseMaybeNat + case mbPicBase of + Just picBase -> return picBase + Nothing + -> do + reg <- getNewRegNat rep + NatM (\state -> (reg, state { natm_pic = Just reg })) + +getModLoc :: NatM ModLocation +getModLoc + = NatM $ \ st -> (natm_modloc st, st) + +-- | Get native code generator configuration +getConfig :: NatM NCGConfig +getConfig = NatM $ \st -> (natm_config st, st) + +-- | Get target platform from native code generator configuration +getPlatform :: NatM Platform +getPlatform = ncgPlatform <$> getConfig + +getFileId :: FastString -> NatM Int +getFileId f = NatM $ \st -> + case lookupUFM (natm_fileid st) f of + Just (_,n) -> (n, st) + Nothing -> let n = 1 + sizeUFM (natm_fileid st) + fids = addToUFM (natm_fileid st) f (f,n) + in n `seq` fids `seq` (n, st { natm_fileid = fids }) + +getDebugBlock :: Label -> NatM (Maybe DebugBlock) +getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st) diff --git a/GHC/CmmToAsm/PIC.hs b/GHC/CmmToAsm/PIC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PIC.hs @@ -0,0 +1,846 @@ +{- + This module handles generation of position independent code and + dynamic-linking related issues for the native code generator. + + This depends both the architecture and OS, so we define it here + instead of in one of the architecture specific modules. + + Things outside this module which are related to this: + + + module CLabel + - PIC base label (pretty printed as local label 1) + - DynamicLinkerLabels - several kinds: + CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset + - labelDynamic predicate + + module Cmm + - The GlobalReg datatype has a PicBaseReg constructor + - The CmmLit datatype has a CmmLabelDiffOff constructor + + codeGen & RTS + - When tablesNextToCode, no absolute addresses are stored in info tables + any more. Instead, offsets from the info label are used. + - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers + because Win32 doesn't support external references in data sections. + TODO: make sure this still works, it might be bitrotted + + NCG + - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all + labels. + - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output + all the necessary stuff for imported symbols. + - The NCG monad keeps track of a list of imported symbols. + - MachCodeGen invokes initializePicBase to generate code to initialize + the PIC base register when needed. + - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel + that wasn't in the original Cmm code (e.g. floating point literals). +-} + +module GHC.CmmToAsm.PIC ( + cmmMakeDynamicReference, + CmmMakeDynamicReferenceM(..), + ReferenceKind(..), + needImportedSymbols, + pprImportedSymbol, + pprGotDeclaration, + + initializePicBase_ppc, + initializePicBase_x86 +) + +where + +import GHC.Prelude + +import qualified GHC.CmmToAsm.PPC.Instr as PPC +import qualified GHC.CmmToAsm.PPC.Regs as PPC +import qualified GHC.CmmToAsm.X86.Instr as X86 + +import GHC.Platform +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config + + +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, + mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), + dynamicLinkerLabelInfo, mkPicBaseLabel, + labelDynamic, externallyVisibleCLabel ) + +import GHC.Cmm.CLabel ( mkForeignLabel ) + + +import GHC.Types.Basic +import GHC.Unit.Module + +import GHC.Utils.Outputable + +import GHC.Driver.Session +import GHC.Data.FastString + + + +-------------------------------------------------------------------------------- +-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm +-- code. It does The Right Thing(tm) to convert the CmmLabel into a +-- position-independent, dynamic-linking-aware reference to the thing +-- in question. +-- Note that this also has to be called from MachCodeGen in order to +-- access static data like floating point literals (labels that were +-- created after the cmmToCmm pass). +-- The function must run in a monad that can keep track of imported symbols +-- A function for recording an imported symbol must be passed in: +-- - addImportCmmOpt for the CmmOptM monad +-- - addImportNat for the NatM monad. + +data ReferenceKind + = DataReference + | CallReference + | JumpReference + deriving(Eq) + +class Monad m => CmmMakeDynamicReferenceM m where + addImport :: CLabel -> m () + getThisModule :: m Module + +instance CmmMakeDynamicReferenceM NatM where + addImport = addImportNat + getThisModule = getThisModuleNat + +cmmMakeDynamicReference + :: CmmMakeDynamicReferenceM m + => NCGConfig + -> ReferenceKind -- whether this is the target of a jump + -> CLabel -- the label + -> m CmmExpr + +cmmMakeDynamicReference config referenceKind lbl + | Just _ <- dynamicLinkerLabelInfo lbl + = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through + + | otherwise + = do this_mod <- getThisModule + let platform = ncgPlatform config + case howToAccessLabel + config + (platformArch platform) + (platformOS platform) + this_mod + referenceKind lbl of + + AccessViaStub -> do + let stub = mkDynamicLinkerLabel CodeStub lbl + addImport stub + return $ CmmLit $ CmmLabel stub + + AccessViaSymbolPtr -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ CmmLoad (cmmMakePicReference config symbolPtr) (bWord platform) + + AccessDirectly -> case referenceKind of + -- for data, we might have to make some calculations: + DataReference -> return $ cmmMakePicReference config lbl + -- all currently supported processors support + -- PC-relative branch and call instructions, + -- so just jump there if it's a call or a jump + _ -> return $ CmmLit $ CmmLabel lbl + + +-- ----------------------------------------------------------------------------- +-- Create a position independent reference to a label. +-- (but do not bother with dynamic linking). +-- We calculate the label's address by adding some (platform-dependent) +-- offset to our base register; this offset is calculated by +-- the function picRelative in the platform-dependent part below. + +cmmMakePicReference :: NCGConfig -> CLabel -> CmmExpr +cmmMakePicReference config lbl + -- Windows doesn't need PIC, + -- everything gets relocated at runtime + | OSMinGW32 <- platformOS platform + = CmmLit $ CmmLabel lbl + + | OSAIX <- platformOS platform + = CmmMachOp (MO_Add W32) + [ CmmReg (CmmGlobal PicBaseReg) + , CmmLit $ picRelative (wordWidth platform) + (platformArch platform) + (platformOS platform) + lbl ] + + -- both ABI versions default to medium code model + | ArchPPC_64 _ <- platformArch platform + = CmmMachOp (MO_Add W32) -- code model medium + [ CmmReg (CmmGlobal PicBaseReg) + , CmmLit $ picRelative (wordWidth platform) + (platformArch platform) + (platformOS platform) + lbl ] + + | (ncgPIC config || ncgExternalDynamicRefs config) + && absoluteLabel lbl + = CmmMachOp (MO_Add (wordWidth platform)) + [ CmmReg (CmmGlobal PicBaseReg) + , CmmLit $ picRelative (wordWidth platform) + (platformArch platform) + (platformOS platform) + lbl ] + + | otherwise + = CmmLit $ CmmLabel lbl + where + platform = ncgPlatform config + + + +absoluteLabel :: CLabel -> Bool +absoluteLabel lbl + = case dynamicLinkerLabelInfo lbl of + Just (GotSymbolPtr, _) -> False + Just (GotSymbolOffset, _) -> False + _ -> True + + +-------------------------------------------------------------------------------- +-- Knowledge about how special dynamic linker labels like symbol +-- pointers, code stubs and GOT offsets look like is located in the +-- module CLabel. + +-- We have to decide which labels need to be accessed +-- indirectly or via a piece of stub code. +data LabelAccessStyle + = AccessViaStub + | AccessViaSymbolPtr + | AccessDirectly + +howToAccessLabel :: NCGConfig -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle + +-- Windows +-- In Windows speak, a "module" is a set of objects linked into the +-- same Portable Executable (PE) file. (both .exe and .dll files are PEs). +-- +-- If we're compiling a multi-module program then symbols from other modules +-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the +-- following. +-- +-- (in the local module) +-- __imp_SYMBOL: addr of SYMBOL +-- +-- (in the other module) +-- SYMBOL: the real function / data. +-- +-- To access the function at SYMBOL from our local module, we just need to +-- dereference the local __imp_SYMBOL. +-- +-- If not compiling with -dynamic we assume that all our code will be linked +-- into the same .exe file. In this case we always access symbols directly, +-- and never use __imp_SYMBOL. +-- +howToAccessLabel config _ OSMinGW32 this_mod _ lbl + + -- Assume all symbols will be in the same PE, so just access them directly. + | not (ncgExternalDynamicRefs config) + = AccessDirectly + + -- If the target symbol is in another PE we need to access it via the + -- appropriate __imp_SYMBOL pointer. + | labelDynamic config this_mod lbl + = AccessViaSymbolPtr + + -- Target symbol is in the same PE as the caller, so just access it directly. + | otherwise + = AccessDirectly + + +-- Mach-O (Darwin, Mac OS X) +-- +-- Indirect access is required in the following cases: +-- * things imported from a dynamic library +-- * (not on x86_64) data from a different module, if we're generating PIC code +-- It is always possible to access something indirectly, +-- even when it's not necessary. +-- +howToAccessLabel config arch OSDarwin this_mod DataReference lbl + -- data access to a dynamic library goes via a symbol pointer + | labelDynamic config this_mod lbl + = AccessViaSymbolPtr + + -- when generating PIC code, all cross-module data references must + -- must go via a symbol pointer, too, because the assembler + -- cannot generate code for a label difference where one + -- label is undefined. Doesn't apply t x86_64. + -- Unfortunately, we don't know whether it's cross-module, + -- so we do it for all externally visible labels. + -- This is a slight waste of time and space, but otherwise + -- we'd need to pass the current Module all the way in to + -- this function. + | arch /= ArchX86_64 + , ncgPIC config && externallyVisibleCLabel lbl + = AccessViaSymbolPtr + + | otherwise + = AccessDirectly + +howToAccessLabel config arch OSDarwin this_mod JumpReference lbl + -- dyld code stubs don't work for tailcalls because the + -- stack alignment is only right for regular calls. + -- Therefore, we have to go via a symbol pointer: + | arch == ArchX86 || arch == ArchX86_64 + , labelDynamic config this_mod lbl + = AccessViaSymbolPtr + + +howToAccessLabel config arch OSDarwin this_mod _ lbl + -- Code stubs are the usual method of choice for imported code; + -- not needed on x86_64 because Apple's new linker, ld64, generates + -- them automatically. + | arch /= ArchX86_64 + , labelDynamic config this_mod lbl + = AccessViaStub + + | otherwise + = AccessDirectly + + +---------------------------------------------------------------------------- +-- AIX + +-- quite simple (for now) +howToAccessLabel _config _arch OSAIX _this_mod kind _lbl + = case kind of + DataReference -> AccessViaSymbolPtr + CallReference -> AccessDirectly + JumpReference -> AccessDirectly + +-- ELF (Linux) +-- +-- ELF tries to pretend to the main application code that dynamic linking does +-- not exist. While this may sound convenient, it tends to mess things up in +-- very bad ways, so we have to be careful when we generate code for a non-PIE +-- main program (-dynamic but no -fPIC). +-- +-- Indirect access is required for references to imported symbols +-- from position independent code. It is also required from the main program +-- when dynamic libraries containing Haskell code are used. + +howToAccessLabel _ (ArchPPC_64 _) os _ kind _ + | osElfTarget os + = case kind of + -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC + DataReference -> AccessViaSymbolPtr + -- RTLD does not generate stubs for function descriptors + -- in tail calls. Create a symbol pointer and generate + -- the code to load the function descriptor at the call site. + JumpReference -> AccessViaSymbolPtr + -- regular calls are handled by the runtime linker + _ -> AccessDirectly + +howToAccessLabel config _ os _ _ _ + -- no PIC -> the dynamic linker does everything for us; + -- if we don't dynamically link to Haskell code, + -- it actually manages to do so without messing things up. + | osElfTarget os + , not (ncgPIC config) && + not (ncgExternalDynamicRefs config) + = AccessDirectly + +howToAccessLabel config arch os this_mod DataReference lbl + | osElfTarget os + = case () of + -- A dynamic label needs to be accessed via a symbol pointer. + _ | labelDynamic config this_mod lbl + -> AccessViaSymbolPtr + + -- For PowerPC32 -fPIC, we have to access even static data + -- via a symbol pointer (see below for an explanation why + -- PowerPC32 Linux is especially broken). + | arch == ArchPPC + , ncgPIC config + -> AccessViaSymbolPtr + + | otherwise + -> AccessDirectly + + + -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons: + -- on i386, the position-independent symbol stubs in the Procedure Linkage Table + -- require the address of the GOT to be loaded into register %ebx on entry. + -- The linker will take any reference to the symbol stub as a hint that + -- the label in question is a code label. When linking executables, this + -- will cause the linker to replace even data references to the label with + -- references to the symbol stub. + + -- This leaves calling a (foreign) function from non-PIC code + -- (AccessDirectly, because we get an implicit symbol stub) + -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) + +howToAccessLabel config arch os this_mod CallReference lbl + | osElfTarget os + , labelDynamic config this_mod lbl && not (ncgPIC config) + = AccessDirectly + + | osElfTarget os + , arch /= ArchX86 + , labelDynamic config this_mod lbl + , ncgPIC config + = AccessViaStub + +howToAccessLabel config _ os this_mod _ lbl + | osElfTarget os + = if labelDynamic config this_mod lbl + then AccessViaSymbolPtr + else AccessDirectly + +-- all other platforms +howToAccessLabel config _ _ _ _ _ + | not (ncgPIC config) + = AccessDirectly + + | otherwise + = panic "howToAccessLabel: PIC not defined for this platform" + + + +-- ------------------------------------------------------------------- +-- | Says what we have to add to our 'PIC base register' in order to +-- get the address of a label. + +picRelative :: Width -> Arch -> OS -> CLabel -> CmmLit + +-- Darwin, but not x86_64: +-- The PIC base register points to the PIC base label at the beginning +-- of the current CmmDecl. We just have to use a label difference to +-- get the offset. +-- We have already made sure that all labels that are not from the current +-- module are accessed indirectly ('as' can't calculate differences between +-- undefined labels). +picRelative width arch OSDarwin lbl + | arch /= ArchX86_64 + = CmmLabelDiffOff lbl mkPicBaseLabel 0 width + +-- On AIX we use an indirect local TOC anchored by 'gotLabel'. +-- This way we use up only one global TOC entry per compilation-unit +-- (this is quite similar to GCC's @-mminimal-toc@ compilation mode) +picRelative width _ OSAIX lbl + = CmmLabelDiffOff lbl gotLabel 0 width + +-- PowerPC Linux: +-- The PIC base register points to our fake GOT. Use a label difference +-- to get the offset. +-- We have made sure that *everything* is accessed indirectly, so this +-- is only used for offsets from the GOT to symbol pointers inside the +-- GOT. +picRelative width ArchPPC os lbl + | osElfTarget os + = CmmLabelDiffOff lbl gotLabel 0 width + + +-- Most Linux versions: +-- The PIC base register points to the GOT. Use foo@got for symbol +-- pointers, and foo@gotoff for everything else. +-- Linux and Darwin on x86_64: +-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers, +-- and a GotSymbolOffset label for other things. +-- For reasons of tradition, the symbol offset label is written as a plain label. +picRelative _ arch os lbl + | osElfTarget os || (os == OSDarwin && arch == ArchX86_64) + = let result + | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl + = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl' + + | otherwise + = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl + + in result + +picRelative _ _ _ _ + = panic "GHC.CmmToAsm.PIC.picRelative undefined for this platform" + + + +-------------------------------------------------------------------------------- + +needImportedSymbols :: NCGConfig -> Bool +needImportedSymbols config + | os == OSDarwin + , arch /= ArchX86_64 + = True + + | os == OSAIX + = True + + -- PowerPC Linux: -fPIC or -dynamic + | osElfTarget os + , arch == ArchPPC + = ncgPIC config || ncgExternalDynamicRefs config + + -- PowerPC 64 Linux: always + | osElfTarget os + , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2 + = True + + -- i386 (and others?): -dynamic but not -fPIC + | osElfTarget os + , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 + = ncgExternalDynamicRefs config && + not (ncgPIC config) + + | otherwise + = False + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform + +-- gotLabel +-- The label used to refer to our "fake GOT" from +-- position-independent code. +gotLabel :: CLabel +gotLabel + -- HACK: this label isn't really foreign + = mkForeignLabel + (fsLit ".LCTOC1") + Nothing ForeignLabelInThisPackage IsData + + + +-- Emit GOT declaration +-- Output whatever needs to be output once per .s file. +-- +-- We don't need to declare any offset tables. +-- However, for PIC on x86, we need a small helper function. +pprGotDeclaration :: NCGConfig -> SDoc +pprGotDeclaration config = case (arch,os) of + (ArchX86, OSDarwin) + | ncgPIC config + -> vcat [ + text ".section __TEXT,__textcoal_nt,coalesced,no_toc", + text ".weak_definition ___i686.get_pc_thunk.ax", + text ".private_extern ___i686.get_pc_thunk.ax", + text "___i686.get_pc_thunk.ax:", + text "\tmovl (%esp), %eax", + text "\tret" ] + + (_, OSDarwin) -> empty + + -- Emit XCOFF TOC section + (_, OSAIX) + -> vcat $ [ text ".toc" + , text ".tc ghc_toc_table[TC],.LCTOC1" + , text ".csect ghc_toc_table[RW]" + -- See Note [.LCTOC1 in PPC PIC code] + , text ".set .LCTOC1,$+0x8000" + ] + + + -- PPC 64 ELF v1 needs a Table Of Contents (TOC) + (ArchPPC_64 ELF_V1, _) + -> text ".section \".toc\",\"aw\"" + + -- In ELF v2 we also need to tell the assembler that we want ABI + -- version 2. This would normally be done at the top of the file + -- right after a file directive, but I could not figure out how + -- to do that. + (ArchPPC_64 ELF_V2, _) + -> vcat [ text ".abiversion 2", + text ".section \".toc\",\"aw\"" + ] + + (arch, os) + | osElfTarget os + , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 + , not (ncgPIC config) + -> empty + + | osElfTarget os + , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 + -> vcat [ + -- See Note [.LCTOC1 in PPC PIC code] + text ".section \".got2\",\"aw\"", + text ".LCTOC1 = .+32768" ] + + _ -> panic "pprGotDeclaration: no match" + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform + + +-------------------------------------------------------------------------------- +-- On Darwin, we have to generate our own stub code for lazy binding.. +-- For each processor architecture, there are two versions, one for PIC +-- and one for non-PIC. +-- + +pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc +pprImportedSymbol dflags config importedLbl = case (arch,os) of + (ArchX86, OSDarwin) + | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl + -> if not pic + then + vcat [ + text ".symbol_stub", + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\tjmp *L" <> pprCLabel dflags lbl + <> text "$lazy_ptr", + text "L" <> pprCLabel dflags lbl + <> text "$stub_binder:", + text "\tpushl $L" <> pprCLabel dflags lbl + <> text "$lazy_ptr", + text "\tjmp dyld_stub_binding_helper" + ] + else + vcat [ + text ".section __TEXT,__picsymbolstub2," + <> text "symbol_stubs,pure_instructions,25", + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\tcall ___i686.get_pc_thunk.ax", + text "1:", + text "\tmovl L" <> pprCLabel dflags lbl + <> text "$lazy_ptr-1b(%eax),%edx", + text "\tjmp *%edx", + text "L" <> pprCLabel dflags lbl + <> text "$stub_binder:", + text "\tlea L" <> pprCLabel dflags lbl + <> text "$lazy_ptr-1b(%eax),%eax", + text "\tpushl %eax", + text "\tjmp dyld_stub_binding_helper" + ] + $+$ vcat [ text ".section __DATA, __la_sym_ptr" + <> (if pic then int 2 else int 3) + <> text ",lazy_symbol_pointers", + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\t.long L" <> pprCLabel dflags lbl + <> text "$stub_binder"] + + | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl + -> vcat [ + text ".non_lazy_symbol_pointer", + char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:", + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\t.long\t0"] + + | otherwise + -> empty + + (_, OSDarwin) -> empty + + + -- XCOFF / AIX + -- + -- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To + -- workaround the limitation of a global TOC we use an indirect TOC + -- with the label `ghc_toc_table`. + -- + -- See also GCC's `-mminimal-toc` compilation mode or + -- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/ + -- + -- NB: No DSO-support yet + + (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of + Just (SymbolPtr, lbl) + -> vcat [ + text "LC.." <> pprCLabel dflags lbl <> char ':', + text "\t.long" <+> pprCLabel dflags lbl ] + _ -> empty + + -- ELF / Linux + -- + -- In theory, we don't need to generate any stubs or symbol pointers + -- by hand for Linux. + -- + -- Reality differs from this in two areas. + -- + -- 1) If we just use a dynamically imported symbol directly in a read-only + -- section of the main executable (as GCC does), ld generates R_*_COPY + -- relocations, which are fundamentally incompatible with reversed info + -- tables. Therefore, we need a table of imported addresses in a writable + -- section. + -- The "official" GOT mechanism (label@got) isn't intended to be used + -- in position dependent code, so we have to create our own "fake GOT" + -- when not Opt_PIC && WayDyn `elem` ways dflags. + -- + -- 2) PowerPC Linux is just plain broken. + -- While it's theoretically possible to use GOT offsets larger + -- than 16 bit, the standard crt*.o files don't, which leads to + -- linker errors as soon as the GOT size exceeds 16 bit. + -- Also, the assembler doesn't support @gotoff labels. + -- In order to be able to use a larger GOT, we have to circumvent the + -- entire GOT mechanism and do it ourselves (this is also what GCC does). + + + -- When needImportedSymbols is defined, + -- the NCG will keep track of all DynamicLinkerLabels it uses + -- and output each of them using pprImportedSymbol. + + (ArchPPC_64 _, _) + | osElfTarget os + -> case dynamicLinkerLabelInfo importedLbl of + Just (SymbolPtr, lbl) + -> vcat [ + text ".LC_" <> pprCLabel dflags lbl <> char ':', + text "\t.quad" <+> pprCLabel dflags lbl ] + _ -> empty + + _ | osElfTarget os + -> case dynamicLinkerLabelInfo importedLbl of + Just (SymbolPtr, lbl) + -> let symbolSize = case ncgWordWidth config of + W32 -> sLit "\t.long" + W64 -> sLit "\t.quad" + _ -> panic "Unknown wordRep in pprImportedSymbol" + + in vcat [ + text ".section \".got2\", \"aw\"", + text ".LC_" <> pprCLabel dflags lbl <> char ':', + ptext symbolSize <+> pprCLabel dflags lbl ] + + -- PLT code stubs are generated automatically by the dynamic linker. + _ -> empty + + _ -> panic "PIC.pprImportedSymbol: no match" + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform + pic = ncgPIC config + +-------------------------------------------------------------------------------- +-- Generate code to calculate the address that should be put in the +-- PIC base register. +-- This is called by MachCodeGen for every CmmProc that accessed the +-- PIC base register. It adds the appropriate instructions to the +-- top of the CmmProc. + +-- It is assumed that the first NatCmmDecl in the input list is a Proc +-- and the rest are CmmDatas. + +-- Darwin is simple: just fetch the address of a local label. +-- The FETCHPC pseudo-instruction is expanded to multiple instructions +-- during pretty-printing so that we don't have to deal with the +-- local label: + +-- PowerPC version: +-- bcl 20,31,1f. +-- 1: mflr picReg + +-- i386 version: +-- call 1f +-- 1: popl %picReg + + + +-- Get a pointer to our own fake GOT, which is defined on a per-module basis. +-- This is exactly how GCC does it in linux. + +initializePicBase_ppc + :: Arch -> OS -> Reg + -> [NatCmmDecl RawCmmStatics PPC.Instr] + -> NatM [NatCmmDecl RawCmmStatics PPC.Instr] + +initializePicBase_ppc ArchPPC os picReg + (CmmProc info lab live (ListGraph blocks) : statics) + | osElfTarget os + = do + let + gotOffset = PPC.ImmConstantDiff + (PPC.ImmCLbl gotLabel) + (PPC.ImmCLbl mkPicBaseLabel) + + blocks' = case blocks of + [] -> [] + (b:bs) -> fetchPC b : map maybeFetchPC bs + + maybeFetchPC b@(BasicBlock bID _) + | bID `mapMember` info = fetchPC b + | otherwise = b + + -- GCC does PIC prologs thusly: + -- bcl 20,31,.L1 + -- .L1: + -- mflr 30 + -- addis 30,30,.LCTOC1-.L1@ha + -- addi 30,30,.LCTOC1-.L1@l + -- TODO: below we use it over temporary register, + -- it can and should be optimised by picking + -- correct PIC reg. + fetchPC (BasicBlock bID insns) = + BasicBlock bID (PPC.FETCHPC picReg + : PPC.ADDIS picReg picReg (PPC.HA gotOffset) + : PPC.ADD picReg picReg + (PPC.RIImm (PPC.LO gotOffset)) + : PPC.MR PPC.r30 picReg + : insns) + + return (CmmProc info lab live (ListGraph blocks') : statics) + +------------------------------------------------------------------------- +-- Load TOC into register 2 +-- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee +-- in register 12. +-- We pass the label to FETCHTOC and create a .localentry too. +-- TODO: Explain this better and refer to ABI spec! +{- +We would like to do approximately this, but spill slot allocation +might be added before the first BasicBlock. That violates the ABI. + +For now we will emit the prologue code in the pretty printer, +which is also what we do for ELF v1. +initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = do + bID <-getUniqueM + return (CmmProc info lab live (ListGraph (b':entry:blocks)) + : statics) + where BasicBlock entryID _ = entry + b' = BasicBlock bID [PPC.FETCHTOC picReg lab, + PPC.BCC PPC.ALWAYS entryID] +-} + +initializePicBase_ppc _ _ _ _ + = panic "initializePicBase_ppc: not needed" + + +-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT +-- which pretty-prints as: +-- call 1f +-- 1: popl %picReg +-- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg +-- (See PprMach.hs) + +initializePicBase_x86 + :: Arch -> OS -> Reg + -> [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] + -> NatM [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] + +initializePicBase_x86 ArchX86 os picReg + (CmmProc info lab live (ListGraph blocks) : statics) + | osElfTarget os + = return (CmmProc info lab live (ListGraph blocks') : statics) + where blocks' = case blocks of + [] -> [] + (b:bs) -> fetchGOT b : map maybeFetchGOT bs + + -- we want to add a FETCHGOT instruction to the beginning of + -- every block that is an entry point, which corresponds to + -- the blocks that have entries in the info-table mapping. + maybeFetchGOT b@(BasicBlock bID _) + | bID `mapMember` info = fetchGOT b + | otherwise = b + + fetchGOT (BasicBlock bID insns) = + BasicBlock bID (X86.FETCHGOT picReg : insns) + +initializePicBase_x86 ArchX86 OSDarwin picReg + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) + + where BasicBlock bID insns = entry + block' = BasicBlock bID (X86.FETCHPC picReg : insns) + +initializePicBase_x86 _ _ _ _ + = panic "initializePicBase_x86: not needed" diff --git a/GHC/CmmToAsm/PPC/CodeGen.hs b/GHC/CmmToAsm/PPC/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/CodeGen.hs @@ -0,0 +1,2463 @@ +{-# LANGUAGE CPP, GADTs #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- + +-- This is a big module, but, if you pay attention to +-- (a) the sectioning, and (b) the type signatures, +-- the structure should not be too overwhelming. + +module GHC.CmmToAsm.PPC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) + +where + +#include "HsVersions.h" + +-- NCG stuff: +import GHC.Prelude + +import GHC.Platform.Regs +import GHC.CmmToAsm.PPC.Instr +import GHC.CmmToAsm.PPC.Cond +import GHC.CmmToAsm.PPC.Regs +import GHC.CmmToAsm.CPrim +import GHC.Cmm.DebugBlock + ( DebugBlock(..) ) +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat, getNewLabelNat + , getBlockIdNat, getPicBaseNat, getNewRegPairNat + , getPicBaseMaybeNat, getPlatform, getConfig + , getDebugBlock, getFileId + ) +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.Platform.Reg.Class +import GHC.Platform.Reg +import GHC.CmmToAsm.Reg.Target +import GHC.Platform + +-- Our intermediate code: +import GHC.Cmm.BlockId +import GHC.Cmm.Ppr ( pprExpr ) +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Core ( Tickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + +-- The rest: +import GHC.Data.OrdList +import GHC.Utils.Outputable + +import Control.Monad ( mapAndUnzipM, when ) +import Data.Bits +import Data.Word + +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Utils.Misc + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector + +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal (pre-order?) yields the insns in the correct +-- order. + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl RawCmmStatics Instr] + +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + platform <- getPlatform + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + os = platformOS platform + arch = platformArch platform + case arch of + ArchPPC | os == OSAIX -> return tops + | otherwise -> do + picBaseMb <- getPicBaseMaybeNat + case picBaseMb of + Just picBase -> initializePicBase_ppc arch os picBase tops + Nothing -> return tops + ArchPPC_64 ELF_V1 -> fixup_entry tops + -- generating function descriptor is handled in + -- pretty printer + ArchPPC_64 ELF_V2 -> fixup_entry tops + -- generating function prologue is handled in + -- pretty printer + _ -> panic "PPC.cmmTopCodeGen: unknown arch" + where + fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = do + let BasicBlock bID insns = entry + bID' <- if lab == (blockLbl bID) + then newBlockId + else return bID + let b' = BasicBlock bID' insns + return (CmmProc info lab live (ListGraph (b':blocks)) : statics) + fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc" + +cmmTopCodeGen (CmmData sec dat) = do + return [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen + :: Block CmmNode C C + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl RawCmmStatics Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span name) + -> do fileid <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col =srcSpanStartCol span + return $ unitOL $ LOCATION fileid line col name + _ -> return nilOL + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock +stmtsToInstrs stmts + = do instrss <- mapM stmtToInstrs stmts + return (concatOL instrss) + +stmtToInstrs :: CmmNode e x -> NatM InstrBlock +stmtToInstrs stmt = do + config <- getConfig + platform <- getPlatform + case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + CmmUnwind {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | target32Bit platform && + isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType platform reg + format = cmmTypeFormat ty + + CmmStore addr src + | isFloatType ty -> assignMem_FltCode format addr src + | target32Bit platform && + isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + CmmBranch id -> genBranch id + CmmCondBranch arg true false prediction -> do + b1 <- genCondJump true arg prediction + b2 <- genBranch false + return (b1 `appOL` b2) + CmmSwitch arg ids -> genSwitch config arg ids + CmmCall { cml_target = arg + , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) + _ -> + panic "stmtToInstrs: statement should have been cps'd away" + +jumpRegs :: Platform -> [GlobalReg] -> [Reg] +jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + + +swizzleRegisterRep :: Register -> Format -> Register +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code +swizzleRegisterRep (Any _ codefn) format = Any format codefn + + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = blockLbl blockid + + + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: Platform -> CmmExpr -> CmmExpr +mangleIndexTree platform (CmmRegOff reg off) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType platform reg) + +mangleIndexTree _ _ + = panic "PPC.CodeGen.mangleIndexTree: no match" + +-- ----------------------------------------------------------------------------- +-- Code gen for 64-bit arithmetic on 32-bit platforms + +{- +Simple support for generating 64-bit code (ie, 64 bit values and 64 +bit assignments) on 32-bit platforms. Unlike the main code generator +we merely shoot for generating working code as simply as possible, and +pay little attention to code quality. Specifically, there is no +attempt to deal cleverly with the fixed-vs-floating register +distinction; all values are generated into (pairs of) floating +registers, even if this would mean some redundant reg-reg moves as a +result. Only one of the VRegUniques is returned, since it will be +of the VRegUniqueLo form, and the upper-half VReg can be determined +by applying getHiVRegFromLo to it. +-} + +data ChildCode64 -- a.k.a "Register64" + = ChildCode64 + InstrBlock -- code + Reg -- the lower 32-bit temporary which contains the + -- result; use getHiVRegFromLo to find the other + -- VRegUnique. Rules of this simplified insn + -- selection game are therefore that the returned + -- Reg may be modified + + +-- | Compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + +getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) +getI64Amodes addrTree = do + Amode hi_addr addr_code <- getAmode D addrTree + case addrOffset hi_addr 4 of + Just lo_addr -> return (hi_addr, lo_addr, addr_code) + Nothing -> do (hi_ptr, code) <- getSomeReg addrTree + return (AddrRegImm hi_ptr (ImmInt 0), + AddrRegImm hi_ptr (ImmInt 4), + code) + + +assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_I64Code addrTree valueTree = do + (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree + ChildCode64 vcode rlo <- iselExpr64 valueTree + let + rhi = getHiVRegFromLo rlo + + -- Big-endian store + mov_hi = ST II32 rhi hi_addr + mov_lo = ST II32 rlo lo_addr + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + + +assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree + let + r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MR r_dst_lo r_src_lo + mov_hi = MR r_dst_hi r_src_hi + return ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(powerpc): invalid lvalue" + + +iselExpr64 :: CmmExpr -> NatM ChildCode64 +iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do + (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree + (rlo, rhi) <- getNewRegPairNat II32 + let mov_hi = LD II32 rhi hi_addr + mov_lo = LD II32 rlo lo_addr + return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo + +iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty + = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) + +iselExpr64 (CmmLit (CmmInt i _)) = do + (rlo,rhi) <- getNewRegPairNat II32 + let + half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) + + code = toOL [ + LIS rlo (ImmInt half1), + OR rlo rlo (RIImm $ ImmInt half0), + LIS rhi (ImmInt half3), + OR rhi rhi (RIImm $ ImmInt half2) + ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ ADDC rlo r1lo r2lo, + ADDE rhi r1hi r2hi ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ SUBFC rlo r2lo (RIReg r1lo), + SUBFE rhi r2hi r1hi ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do + (expr_reg,expr_code) <- getSomeReg expr + (rlo, rhi) <- getNewRegPairNat II32 + let mov_hi = LI rhi (ImmInt 0) + mov_lo = MR rlo expr_reg + return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo + +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do + (expr_reg,expr_code) <- getSomeReg expr + (rlo, rhi) <- getNewRegPairNat II32 + let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31)) + mov_lo = MR rlo expr_reg + return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo +iselExpr64 expr + = do + platform <- getPlatform + pprPanic "iselExpr64(powerpc)" (pprExpr platform expr) + + + +getRegister :: CmmExpr -> NatM Register +getRegister e = do config <- getConfig + getRegister' config (ncgPlatform config) e + +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register + +getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) + | OSAIX <- platformOS platform = do + let code dst = toOL [ LD II32 dst tocAddr ] + tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]")) + return (Any II32 code) + | target32Bit platform = do + reg <- getPicBaseNat $ archWordFormat (target32Bit platform) + return (Fixed (archWordFormat (target32Bit platform)) + reg nilOL) + | otherwise = return (Fixed II64 toc nilOL) + +getRegister' _ platform (CmmReg reg) + = return (Fixed (cmmTypeFormat (cmmRegType platform reg)) + (getRegisterReg platform reg) nilOL) + +getRegister' config platform tree@(CmmRegOff _ _) + = getRegister' config platform (mangleIndexTree platform tree) + + -- for 32-bit architectures, support some 64 -> 32 bit conversions: + -- TO_W_(x), TO_W_(x >> 32) + +getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit platform = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit platform = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | target32Bit platform = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | target32Bit platform = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ platform (CmmLoad mem pk) + | not (isWord64 pk) = do + Amode addr addr_code <- getAmode D mem + let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) + addr_code `snocOL` LD format dst addr + return (Any format code) + | not (target32Bit platform) = do + Amode addr addr_code <- getAmode DS mem + let code dst = addr_code `snocOL` LD II64 dst addr + return (Any II64 code) + + where format = cmmTypeFormat pk + +-- catch simple cases of zero- or sign-extended load +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +-- Note: there is no Load Byte Arithmetic instruction, so no signed case here + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode D mem + return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do + -- lwa is DS-form. See Note [Power instruction format] + Amode addr addr_code <- getAmode DS mem + return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) + +getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps + = case mop of + MO_Not rep -> triv_ucode_int rep NOT + + MO_F_Neg w -> triv_ucode_float w FNEG + MO_S_Neg w -> triv_ucode_int w NEG + + MO_FF_Conv W64 W32 -> trivialUCode FF32 FRSP x + MO_FF_Conv W32 W64 -> conversionNop FF64 x + + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x + + MO_SS_Conv from to + | from >= to -> conversionNop (intFormat to) x + | otherwise -> triv_ucode_int to (EXTS (intFormat from)) + + MO_UU_Conv from to + | from >= to -> conversionNop (intFormat to) x + | otherwise -> clearLeft from to + + MO_XX_Conv _ to -> conversionNop (intFormat to) x + + _ -> panic "PPC.CodeGen.getRegister: no match" + + where + triv_ucode_int width instr = trivialUCode (intFormat width) instr x + triv_ucode_float width instr = trivialUCode (floatFormat width) instr x + + conversionNop new_format expr + = do e_code <- getRegister' config platform expr + return (swizzleRegisterRep e_code new_format) + + clearLeft from to + = do (src1, code1) <- getSomeReg x + let arch_fmt = intFormat (wordWidth platform) + arch_bits = widthInBits (wordWidth platform) + size = widthInBits from + code dst = code1 `snocOL` + CLRLI arch_fmt dst src1 (arch_bits - size) + return (Any (intFormat to) code) + +getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps + = case mop of + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y + + MO_Eq rep -> condIntReg EQQ rep x y + MO_Ne rep -> condIntReg NE rep x y + + MO_S_Gt rep -> condIntReg GTT rep x y + MO_S_Ge rep -> condIntReg GE rep x y + MO_S_Lt rep -> condIntReg LTT rep x y + MO_S_Le rep -> condIntReg LE rep x y + + MO_U_Gt rep -> condIntReg GU rep x y + MO_U_Ge rep -> condIntReg GEU rep x y + MO_U_Lt rep -> condIntReg LU rep x y + MO_U_Le rep -> condIntReg LEU rep x y + + MO_F_Add w -> triv_float w FADD + MO_F_Sub w -> triv_float w FSUB + MO_F_Mul w -> triv_float w FMUL + MO_F_Quot w -> triv_float w FDIV + + -- optimize addition with 32-bit immediate + -- (needed for PIC) + MO_Add W32 -> + case y of + CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm + -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep) + CmmLit lit + -> do + (src, srcCode) <- getSomeReg x + let imm = litToImm lit + code dst = srcCode `appOL` toOL [ + ADDIS dst src (HA imm), + ADD dst dst (RIImm (LO imm)) + ] + return (Any II32 code) + _ -> trivialCode W32 True ADD x y + + MO_Add rep -> trivialCode rep True ADD x y + MO_Sub rep -> + case y of + CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm) + -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep) + _ -> case x of + CmmLit (CmmInt imm _) + | Just _ <- makeImmediate rep True imm + -- subfi ('subtract from' with immediate) doesn't exist + -> trivialCode rep True SUBFC y x + _ -> trivialCodeNoImm' (intFormat rep) SUBF y x + + MO_Mul rep -> shiftMulCode rep True MULL x y + MO_S_MulMayOflo rep -> do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + format = intFormat rep + code dst = code1 `appOL` code2 + `appOL` toOL [ MULLO format dst src1 src2 + , MFOV format dst + ] + return (Any format code) + + MO_S_Quot rep -> divCode rep True x y + MO_U_Quot rep -> divCode rep False x y + + MO_S_Rem rep -> remainder rep True x y + MO_U_Rem rep -> remainder rep False x y + + MO_And rep -> case y of + (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4 + -> do + (src, srcCode) <- getSomeReg x + let clear_mask = if imm == -4 then 2 else 3 + fmt = intFormat rep + code dst = srcCode + `appOL` unitOL (CLRRI fmt dst src clear_mask) + return (Any fmt code) + _ -> trivialCode rep False AND x y + MO_Or rep -> trivialCode rep False OR x y + MO_Xor rep -> trivialCode rep False XOR x y + + MO_Shl rep -> shiftMulCode rep False SL x y + MO_S_Shr rep -> srCode rep True SRA x y + MO_U_Shr rep -> srCode rep False SR x y + _ -> panic "PPC.CodeGen.getRegister: no match" + + where + triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register + triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y + + remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register + remainder rep sgn x y = do + let fmt = intFormat rep + tmp <- getNewRegNat fmt + code <- remainderCode rep sgn tmp x y + return (Any fmt code) + + +getRegister' _ _ (CmmLit (CmmInt i rep)) + | Just imm <- makeImmediate rep True i + = let + code dst = unitOL (LI dst imm) + in + return (Any (intFormat rep) code) + +getRegister' config _ (CmmLit (CmmFloat f frep)) = do + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + Amode addr addr_code <- getAmode D dynRef + let format = floatFormat frep + code dst = + LDATA (Section ReadOnlyData lbl) + (CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f frep)]) + `consOL` (addr_code `snocOL` LD format dst addr) + return (Any format code) + +getRegister' config platform (CmmLit lit) + | target32Bit platform + = let rep = cmmLitType platform lit + imm = litToImm lit + code dst = toOL [ + LIS dst (HA imm), + ADD dst dst (RIImm (LO imm)) + ] + in return (Any (cmmTypeFormat rep) code) + | otherwise + = do lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + Amode addr addr_code <- getAmode D dynRef + let rep = cmmLitType platform lit + format = cmmTypeFormat rep + code dst = + LDATA (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmStaticLit lit]) + `consOL` (addr_code `snocOL` LD format dst addr) + return (Any format code) + +getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other) + + -- extend?Rep: wrap integer expression of type `from` + -- in a conversion to `to` +extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr +extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x] + +extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr +extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x] + +-- ----------------------------------------------------------------------------- +-- The 'Amode' type: Memory addressing modes passed up the tree. + +data Amode + = Amode AddrMode InstrBlock + +{- +Now, given a tree (the argument to a CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + +{- Note [Power instruction format] +In some instructions the 16 bit offset must be a multiple of 4, i.e. +the two least significant bits must be zero. The "Power ISA" specification +calls these instruction formats "DS-FORM" and the instructions with +arbitrary 16 bit offsets are "D-FORM". + +The Power ISA specification document can be obtained from www.power.org. +-} +data InstrForm = D | DS + +getAmode :: InstrForm -> CmmExpr -> NatM Amode +getAmode inf tree@(CmmRegOff _ _) + = do platform <- getPlatform + getAmode inf (mangleIndexTree platform tree) + +getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W32 True (-i) + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + + +getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W32 True i + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + +getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True (-i) + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + + +getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True i + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + +getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True (-i) + = do + (reg, code) <- getSomeReg x + (reg', off', code') <- + if i `mod` 4 == 0 + then do return (reg, off, code) + else do + tmp <- getNewRegNat II64 + return (tmp, ImmInt 0, + code `snocOL` ADD tmp reg (RIImm off)) + return (Amode (AddrRegImm reg' off') code') + +getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W64 True i + = do + (reg, code) <- getSomeReg x + (reg', off', code') <- + if i `mod` 4 == 0 + then do return (reg, off, code) + else do + tmp <- getNewRegNat II64 + return (tmp, ImmInt 0, + code `snocOL` ADD tmp reg (RIImm off)) + return (Amode (AddrRegImm reg' off') code') + + -- optimize addition with 32-bit immediate + -- (needed for PIC) +getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit]) + = do + platform <- getPlatform + (src, srcCode) <- getSomeReg x + let imm = litToImm lit + case () of + _ | OSAIX <- platformOS platform + , isCmmLabelType lit -> + -- HA16/LO16 relocations on labels not supported on AIX + return (Amode (AddrRegImm src imm) srcCode) + | otherwise -> do + tmp <- getNewRegNat II32 + let code = srcCode `snocOL` ADDIS tmp src (HA imm) + return (Amode (AddrRegImm tmp (LO imm)) code) + where + isCmmLabelType (CmmLabel {}) = True + isCmmLabelType (CmmLabelOff {}) = True + isCmmLabelType (CmmLabelDiffOff {}) = True + isCmmLabelType _ = False + +getAmode _ (CmmLit lit) + = do + platform <- getPlatform + case platformArch platform of + ArchPPC -> do + tmp <- getNewRegNat II32 + let imm = litToImm lit + code = unitOL (LIS tmp (HA imm)) + return (Amode (AddrRegImm tmp (LO imm)) code) + _ -> do -- TODO: Load from TOC, + -- see getRegister' _ (CmmLit lit) + tmp <- getNewRegNat II64 + let imm = litToImm lit + code = toOL [ + LIS tmp (HIGHESTA imm), + OR tmp tmp (RIImm (HIGHERA imm)), + SL II64 tmp tmp (RIImm (ImmInt 32)), + ORIS tmp tmp (HA imm) + ] + return (Amode (AddrRegImm tmp (LO imm)) code) + +getAmode _ (CmmMachOp (MO_Add W32) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) + +getAmode _ (CmmMachOp (MO_Add W64) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) + +getAmode _ other + = do + (reg, code) <- getSomeReg other + let + off = ImmInt 0 + return (Amode (AddrRegImm reg off) code) + + +-- The 'CondCode' type: Condition codes passed up the tree. +data CondCode + = CondCode Bool Cond InstrBlock + +-- Set up a condition code for a conditional branch. + +getCondCode :: CmmExpr -> NatM CondCode + +-- almost the same as everywhere else - but we need to +-- extend small integers to 32 bit or 64 bit first + +getCondCode (CmmMachOp mop [x, y]) + = do + case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + MO_F_Lt W32 -> condFltCode LTT x y + MO_F_Le W32 -> condFltCode LE x y + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode LTT x y + MO_F_Le W64 -> condFltCode LE x y + + MO_Eq rep -> condIntCode EQQ rep x y + MO_Ne rep -> condIntCode NE rep x y + + MO_S_Gt rep -> condIntCode GTT rep x y + MO_S_Ge rep -> condIntCode GE rep x y + MO_S_Lt rep -> condIntCode LTT rep x y + MO_S_Le rep -> condIntCode LE rep x y + + MO_U_Gt rep -> condIntCode GU rep x y + MO_U_Ge rep -> condIntCode GEU rep x y + MO_U_Lt rep -> condIntCode LU rep x y + MO_U_Le rep -> condIntCode LEU rep x y + + _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) + +getCondCode _ = panic "getCondCode(2)(powerpc)" + + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond width x y = do + platform <- getPlatform + condIntCode' (target32Bit platform) cond width x y + +condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode + +-- simple code for 64-bit on 32-bit platforms +condIntCode' True cond W64 x y + | condUnsigned cond + = do + ChildCode64 code_x x_lo <- iselExpr64 x + ChildCode64 code_y y_lo <- iselExpr64 y + let x_hi = getHiVRegFromLo x_lo + y_hi = getHiVRegFromLo y_lo + end_lbl <- getBlockIdNat + let code = code_x `appOL` code_y `appOL` toOL + [ CMPL II32 x_hi (RIReg y_hi) + , BCC NE end_lbl Nothing + , CMPL II32 x_lo (RIReg y_lo) + , BCC ALWAYS end_lbl Nothing + + , NEWBLOCK end_lbl + ] + return (CondCode False cond code) + | otherwise + = do + ChildCode64 code_x x_lo <- iselExpr64 x + ChildCode64 code_y y_lo <- iselExpr64 y + let x_hi = getHiVRegFromLo x_lo + y_hi = getHiVRegFromLo y_lo + end_lbl <- getBlockIdNat + cmp_lo <- getBlockIdNat + let code = code_x `appOL` code_y `appOL` toOL + [ CMP II32 x_hi (RIReg y_hi) + , BCC NE end_lbl Nothing + , CMP II32 x_hi (RIImm (ImmInt 0)) + , BCC LE cmp_lo Nothing + , CMPL II32 x_lo (RIReg y_lo) + , BCC ALWAYS end_lbl Nothing + , NEWBLOCK cmp_lo + , CMPL II32 y_lo (RIReg x_lo) + , BCC ALWAYS end_lbl Nothing + + , NEWBLOCK end_lbl + ] + return (CondCode False cond code) + +-- optimize pointer tag checks. Operation andi. sets condition register +-- so cmpi ..., 0 is redundant. +condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)]) + (CmmLit (CmmInt 0 _)) + | not $ condUnsigned cond, + Just src2 <- makeImmediate rep False imm + = do + (src1, code) <- getSomeReg x + let code' = code `snocOL` AND r0 src1 (RIImm src2) + return (CondCode False cond code') + +condIntCode' _ cond width x (CmmLit (CmmInt y rep)) + | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y + = do + let op_len = max W32 width + let extend = if condUnsigned cond then extendUExpr width op_len + else extendSExpr width op_len + (src1, code) <- getSomeReg (extend x) + let format = intFormat op_len + code' = code `snocOL` + (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2) + return (CondCode False cond code') + +condIntCode' _ cond width x y = do + let op_len = max W32 width + let extend = if condUnsigned cond then extendUExpr width op_len + else extendSExpr width op_len + (src1, code1) <- getSomeReg (extend x) + (src2, code2) <- getSomeReg (extend y) + let format = intFormat op_len + code' = code1 `appOL` code2 `snocOL` + (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2) + return (CondCode False cond code') + +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condFltCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 + code'' = case cond of -- twiddle CR to handle unordered case + GE -> code' `snocOL` CRNOR ltbit eqbit gtbit + LE -> code' `snocOL` CRNOR gtbit eqbit ltbit + _ -> code' + where + ltbit = 0 ; eqbit = 2 ; gtbit = 1 + return (CondCode True cond code'') + + + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_IntCode pk addr src = do + (srcReg, code) <- getSomeReg src + Amode dstAddr addr_code <- case pk of + II64 -> getAmode DS addr + _ -> getAmode D addr + return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr + +-- dst is a reg, but src could be anything +assignReg_IntCode _ reg src + = do + platform <- getPlatform + let dst = getRegisterReg platform reg + r <- getRegister src + return $ case r of + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` MR dst freg + + + +-- Easy, isn't it? +assignMem_FltCode = assignMem_IntCode +assignReg_FltCode = assignReg_IntCode + + + +genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock + +genJump (CmmLit (CmmLabel lbl)) regs + = return (unitOL $ JMP lbl regs) + +genJump tree gregs + = do + platform <- getPlatform + genJump' tree (platformToGCP platform) gregs + +genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock + +genJump' tree (GCP64ELF 1) regs + = do + (target,code) <- getSomeReg tree + return (code + `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0)) + `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8)) + `snocOL` MTCTR r11 + `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16)) + `snocOL` BCTR [] Nothing regs) + +genJump' tree (GCP64ELF 2) regs + = do + (target,code) <- getSomeReg tree + return (code + `snocOL` MR r12 target + `snocOL` MTCTR r12 + `snocOL` BCTR [] Nothing regs) + +genJump' tree _ regs + = do + (target,code) <- getSomeReg tree + return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. +-} + + +genCondJump + :: BlockId -- the branch target + -> CmmExpr -- the condition on which to branch + -> Maybe Bool + -> NatM InstrBlock + +genCondJump id bool prediction = do + CondCode _ cond code <- getCondCode bool + return (code `snocOL` BCC cond id prediction) + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. + +genCCall :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall (PrimTarget MO_ReadBarrier) _ _ + = return $ unitOL LWSYNC +genCCall (PrimTarget MO_WriteBarrier) _ _ + = return $ unitOL LWSYNC + +genCCall (PrimTarget MO_Touch) _ _ + = return $ nilOL + +genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ + = return $ nilOL + +genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] + = do platform <- getPlatform + let fmt = intFormat width + reg_dst = getRegisterReg platform (CmmLocal dst) + (instr, n_code) <- case amop of + AMO_Add -> getSomeRegOrImm ADD True reg_dst + AMO_Sub -> case n of + CmmLit (CmmInt i _) + | Just imm <- makeImmediate width True (-i) + -> return (ADD reg_dst reg_dst (RIImm imm), nilOL) + _ + -> do + (n_reg, n_code) <- getSomeReg n + return (SUBF reg_dst n_reg reg_dst, n_code) + AMO_And -> getSomeRegOrImm AND False reg_dst + AMO_Nand -> do (n_reg, n_code) <- getSomeReg n + return (NAND reg_dst reg_dst n_reg, n_code) + AMO_Or -> getSomeRegOrImm OR False reg_dst + AMO_Xor -> getSomeRegOrImm XOR False reg_dst + Amode addr_reg addr_code <- getAmodeIndex addr + lbl_retry <- getBlockIdNat + return $ n_code `appOL` addr_code + `appOL` toOL [ HWSYNC + , BCC ALWAYS lbl_retry Nothing + + , NEWBLOCK lbl_retry + , LDR fmt reg_dst addr_reg + , instr + , STC fmt reg_dst addr_reg + , BCC NE lbl_retry (Just False) + , ISYNC + ] + where + getAmodeIndex (CmmMachOp (MO_Add _) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) + getAmodeIndex other + = do + (reg, code) <- getSomeReg other + return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here! + getSomeRegOrImm op sign dst + = case n of + CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i + -> return (op dst dst (RIImm imm), nilOL) + _ + -> do + (n_reg, n_code) <- getSomeReg n + return (op dst dst (RIReg n_reg), n_code) + +genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr] + = do platform <- getPlatform + let fmt = intFormat width + reg_dst = getRegisterReg platform (CmmLocal dst) + form = if widthInBits width == 64 then DS else D + Amode addr_reg addr_code <- getAmode form addr + lbl_end <- getBlockIdNat + return $ addr_code `appOL` toOL [ HWSYNC + , LD fmt reg_dst addr_reg + , CMP fmt reg_dst (RIReg reg_dst) + , BCC NE lbl_end (Just False) + , BCC ALWAYS lbl_end Nothing + -- See Note [Seemingly useless cmp and bne] + , NEWBLOCK lbl_end + , ISYNC + ] + +-- Note [Seemingly useless cmp and bne] +-- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction +-- the second paragraph says that isync may complete before storage accesses +-- "associated" with a preceding instruction have been performed. The cmp +-- operation and the following bne introduce a data and control dependency +-- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe +-- Fetch). +-- This is also what gcc does. + + +genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do + code <- assignMem_IntCode (intFormat width) addr val + return $ unitOL(HWSYNC) `appOL` code + +genCCall (PrimTarget (MO_Clz width)) [dst] [src] + = do platform <- getPlatform + let reg_dst = getRegisterReg platform (CmmLocal dst) + if target32Bit platform && width == W64 + then do + ChildCode64 code vr_lo <- iselExpr64 src + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + lbl3 <- getBlockIdNat + let vr_hi = getHiVRegFromLo vr_lo + cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0)) + , BCC NE lbl2 Nothing + , BCC ALWAYS lbl1 Nothing + + , NEWBLOCK lbl1 + , CNTLZ II32 reg_dst vr_lo + , ADD reg_dst reg_dst (RIImm (ImmInt 32)) + , BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl2 + , CNTLZ II32 reg_dst vr_hi + , BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl3 + ] + return $ code `appOL` cntlz + else do + let format = if width == W64 then II64 else II32 + (s_reg, s_code) <- getSomeReg src + (pre, reg , post) <- + case width of + W64 -> return (nilOL, s_reg, nilOL) + W32 -> return (nilOL, s_reg, nilOL) + W16 -> do + reg_tmp <- getNewRegNat format + return + ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535)) + , reg_tmp + , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16))) + ) + W8 -> do + reg_tmp <- getNewRegNat format + return + ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255)) + , reg_tmp + , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24))) + ) + _ -> panic "genCall: Clz wrong format" + let cntlz = unitOL (CNTLZ format reg_dst reg) + return $ s_code `appOL` pre `appOL` cntlz `appOL` post + +genCCall (PrimTarget (MO_Ctz width)) [dst] [src] + = do platform <- getPlatform + let reg_dst = getRegisterReg platform (CmmLocal dst) + if target32Bit platform && width == W64 + then do + let format = II32 + ChildCode64 code vr_lo <- iselExpr64 src + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + lbl3 <- getBlockIdNat + x' <- getNewRegNat format + x'' <- getNewRegNat format + r' <- getNewRegNat format + cnttzlo <- cnttz format reg_dst vr_lo + let vr_hi = getHiVRegFromLo vr_lo + cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0)) + , BCC NE lbl2 Nothing + , BCC ALWAYS lbl1 Nothing + + , NEWBLOCK lbl1 + , ADD x' vr_hi (RIImm (ImmInt (-1))) + , ANDC x'' x' vr_hi + , CNTLZ format r' x'' + -- 32 + (32 - clz(x'')) + , SUBFC reg_dst r' (RIImm (ImmInt 64)) + , BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl2 + ] + `appOL` cnttzlo `appOL` + toOL [ BCC ALWAYS lbl3 Nothing + + , NEWBLOCK lbl3 + ] + return $ code `appOL` cnttz64 + else do + let format = if width == W64 then II64 else II32 + (s_reg, s_code) <- getSomeReg src + (reg_ctz, pre_code) <- + case width of + W64 -> return (s_reg, nilOL) + W32 -> return (s_reg, nilOL) + W16 -> do + reg_tmp <- getNewRegNat format + return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1)) + W8 -> do + reg_tmp <- getNewRegNat format + return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256))) + _ -> panic "genCall: Ctz wrong format" + ctz_code <- cnttz format reg_dst reg_ctz + return $ s_code `appOL` pre_code `appOL` ctz_code + where + -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1)) + -- see Henry S. Warren, Hacker's Delight, p 107 + cnttz format dst src = do + let format_bits = 8 * formatInBytes format + x' <- getNewRegNat format + x'' <- getNewRegNat format + r' <- getNewRegNat format + return $ toOL [ ADD x' src (RIImm (ImmInt (-1))) + , ANDC x'' x' src + , CNTLZ format r' x'' + , SUBFC dst r' (RIImm (ImmInt (format_bits))) + ] + +genCCall target dest_regs argsAndHints + = do platform <- getPlatform + case target of + PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width + dest_regs argsAndHints + PrimTarget (MO_U_QuotRem width) -> divOp1 platform False width + dest_regs argsAndHints + PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs + argsAndHints + PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs + argsAndHints + PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints + PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints + PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints + PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width + dest_regs argsAndHints + PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width + dest_regs argsAndHints + PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints + PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints + _ -> do config <- getConfig + genCCall' config (platformToGCP platform) + target dest_regs argsAndHints + where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y] + = do let reg_q = getRegisterReg platform (CmmLocal res_q) + reg_r = getRegisterReg platform (CmmLocal res_r) + remainderCode width signed reg_q arg_x arg_y + <*> pure reg_r + + divOp1 _ _ _ _ _ + = panic "genCCall: Wrong number of arguments for divOp1" + divOp2 platform width [res_q, res_r] + [arg_x_high, arg_x_low, arg_y] + = do let reg_q = getRegisterReg platform (CmmLocal res_q) + reg_r = getRegisterReg platform (CmmLocal res_r) + fmt = intFormat width + half = 4 * (formatInBytes fmt) + (xh_reg, xh_code) <- getSomeReg arg_x_high + (xl_reg, xl_code) <- getSomeReg arg_x_low + (y_reg, y_code) <- getSomeReg arg_y + s <- getNewRegNat fmt + b <- getNewRegNat fmt + v <- getNewRegNat fmt + vn1 <- getNewRegNat fmt + vn0 <- getNewRegNat fmt + un32 <- getNewRegNat fmt + tmp <- getNewRegNat fmt + un10 <- getNewRegNat fmt + un1 <- getNewRegNat fmt + un0 <- getNewRegNat fmt + q1 <- getNewRegNat fmt + rhat <- getNewRegNat fmt + tmp1 <- getNewRegNat fmt + q0 <- getNewRegNat fmt + un21 <- getNewRegNat fmt + again1 <- getBlockIdNat + no1 <- getBlockIdNat + then1 <- getBlockIdNat + endif1 <- getBlockIdNat + again2 <- getBlockIdNat + no2 <- getBlockIdNat + then2 <- getBlockIdNat + endif2 <- getBlockIdNat + return $ y_code `appOL` xl_code `appOL` xh_code `appOL` + -- see Hacker's Delight p 196 Figure 9-3 + toOL [ -- b = 2 ^ (bits_in_word / 2) + LI b (ImmInt 1) + , SL fmt b b (RIImm (ImmInt half)) + -- s = clz(y) + , CNTLZ fmt s y_reg + -- v = y << s + , SL fmt v y_reg (RIReg s) + -- vn1 = upper half of v + , SR fmt vn1 v (RIImm (ImmInt half)) + -- vn0 = lower half of v + , CLRLI fmt vn0 v half + -- un32 = (u1 << s) + -- | (u0 >> (bits_in_word - s)) + , SL fmt un32 xh_reg (RIReg s) + , SUBFC tmp s + (RIImm (ImmInt (8 * formatInBytes fmt))) + , SR fmt tmp xl_reg (RIReg tmp) + , OR un32 un32 (RIReg tmp) + -- un10 = u0 << s + , SL fmt un10 xl_reg (RIReg s) + -- un1 = upper half of un10 + , SR fmt un1 un10 (RIImm (ImmInt half)) + -- un0 = lower half of un10 + , CLRLI fmt un0 un10 half + -- q1 = un32/vn1 + , DIV fmt False q1 un32 vn1 + -- rhat = un32 - q1*vn1 + , MULL fmt tmp q1 (RIReg vn1) + , SUBF rhat tmp un32 + , BCC ALWAYS again1 Nothing + + , NEWBLOCK again1 + -- if (q1 >= b || q1*vn0 > b*rhat + un1) + , CMPL fmt q1 (RIReg b) + , BCC GEU then1 Nothing + , BCC ALWAYS no1 Nothing + + , NEWBLOCK no1 + , MULL fmt tmp q1 (RIReg vn0) + , SL fmt tmp1 rhat (RIImm (ImmInt half)) + , ADD tmp1 tmp1 (RIReg un1) + , CMPL fmt tmp (RIReg tmp1) + , BCC LEU endif1 Nothing + , BCC ALWAYS then1 Nothing + + , NEWBLOCK then1 + -- q1 = q1 - 1 + , ADD q1 q1 (RIImm (ImmInt (-1))) + -- rhat = rhat + vn1 + , ADD rhat rhat (RIReg vn1) + -- if (rhat < b) goto again1 + , CMPL fmt rhat (RIReg b) + , BCC LTT again1 Nothing + , BCC ALWAYS endif1 Nothing + + , NEWBLOCK endif1 + -- un21 = un32*b + un1 - q1*v + , SL fmt un21 un32 (RIImm (ImmInt half)) + , ADD un21 un21 (RIReg un1) + , MULL fmt tmp q1 (RIReg v) + , SUBF un21 tmp un21 + -- compute second quotient digit + -- q0 = un21/vn1 + , DIV fmt False q0 un21 vn1 + -- rhat = un21- q0*vn1 + , MULL fmt tmp q0 (RIReg vn1) + , SUBF rhat tmp un21 + , BCC ALWAYS again2 Nothing + + , NEWBLOCK again2 + -- if (q0>b || q0*vn0 > b*rhat + un0) + , CMPL fmt q0 (RIReg b) + , BCC GEU then2 Nothing + , BCC ALWAYS no2 Nothing + + , NEWBLOCK no2 + , MULL fmt tmp q0 (RIReg vn0) + , SL fmt tmp1 rhat (RIImm (ImmInt half)) + , ADD tmp1 tmp1 (RIReg un0) + , CMPL fmt tmp (RIReg tmp1) + , BCC LEU endif2 Nothing + , BCC ALWAYS then2 Nothing + + , NEWBLOCK then2 + -- q0 = q0 - 1 + , ADD q0 q0 (RIImm (ImmInt (-1))) + -- rhat = rhat + vn1 + , ADD rhat rhat (RIReg vn1) + -- if (rhat> s + , SL fmt reg_r un21 (RIImm (ImmInt half)) + , ADD reg_r reg_r (RIReg un0) + , MULL fmt tmp q0 (RIReg v) + , SUBF reg_r tmp reg_r + , SR fmt reg_r reg_r (RIReg s) + -- compute quotient + -- q = q1*b + q0 + , SL fmt reg_q q1 (RIImm (ImmInt half)) + , ADD reg_q reg_q (RIReg q0) + ] + divOp2 _ _ _ _ + = panic "genCCall: Wrong number of arguments for divOp2" + multOp2 platform width [res_h, res_l] [arg_x, arg_y] + = do let reg_h = getRegisterReg platform (CmmLocal res_h) + reg_l = getRegisterReg platform (CmmLocal res_l) + fmt = intFormat width + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg) + , MULHU fmt reg_h x_reg y_reg + ] + multOp2 _ _ _ _ + = panic "genCall: Wrong number of arguments for multOp2" + add2Op platform [res_h, res_l] [arg_x, arg_y] + = do let reg_h = getRegisterReg platform (CmmLocal res_h) + reg_l = getRegisterReg platform (CmmLocal res_l) + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ LI reg_h (ImmInt 0) + , ADDC reg_l x_reg y_reg + , ADDZE reg_h reg_h + ] + add2Op _ _ _ + = panic "genCCall: Wrong number of arguments/results for add2" + + addcOp platform [res_r, res_c] [arg_x, arg_y] + = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y] + addcOp _ _ _ + = panic "genCCall: Wrong number of arguments/results for addc" + + -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1, + -- which is 0 for borrow and 1 otherwise. We need 1 and 0 + -- so xor with 1. + subcOp platform [res_r, res_c] [arg_x, arg_y] + = do let reg_r = getRegisterReg platform (CmmLocal res_r) + reg_c = getRegisterReg platform (CmmLocal res_c) + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ LI reg_c (ImmInt 0) + , SUBFC reg_r y_reg (RIReg x_reg) + , ADDZE reg_c reg_c + , XOR reg_c reg_c (RIImm (ImmInt 1)) + ] + subcOp _ _ _ + = panic "genCCall: Wrong number of arguments/results for subc" + addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y] + = do let reg_r = getRegisterReg platform (CmmLocal res_r) + reg_c = getRegisterReg platform (CmmLocal res_c) + (x_reg, x_code) <- getSomeReg arg_x + (y_reg, y_code) <- getSomeReg arg_y + return $ y_code `appOL` x_code + `appOL` toOL [ instr reg_r y_reg x_reg, + -- SUBFO argument order reversed! + MFOV (intFormat width) reg_c + ] + addSubCOp _ _ _ _ _ + = panic "genCall: Wrong number of arguments/results for addC" + fabs platform [res] [arg] + = do let res_r = getRegisterReg platform (CmmLocal res) + (arg_reg, arg_code) <- getSomeReg arg + return $ arg_code `snocOL` FABS res_r arg_reg + fabs _ _ _ + = panic "genCall: Wrong number of arguments/results for fabs" + +-- TODO: replace 'Int' by an enum such as 'PPC_64ABI' +data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX + +platformToGCP :: Platform -> GenCCallPlatform +platformToGCP platform + = case platformOS platform of + OSAIX -> GCPAIX + _ -> case platformArch platform of + ArchPPC -> GCP32ELF + ArchPPC_64 ELF_V1 -> GCP64ELF 1 + ArchPPC_64 ELF_V2 -> GCP64ELF 2 + _ -> panic "platformToGCP: Not PowerPC" + + +genCCall' + :: NCGConfig + -> GenCCallPlatform + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + +{- + PowerPC Linux uses the System V Release 4 Calling Convention + for PowerPC. It is described in the + "System V Application Binary Interface PowerPC Processor Supplement". + + PowerPC 64 Linux uses the System V Release 4 Calling Convention for + 64-bit PowerPC. It is specified in + "64-bit PowerPC ELF Application Binary Interface Supplement 1.9" + (PPC64 ELF v1.9). + + PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit + ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement" + (PPC64 ELF v2). + + AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian + 32-Bit Hardware Implementation" + + All four conventions are similar: + Parameters may be passed in general-purpose registers starting at r3, in + floating point registers starting at f1, or on the stack. + + But there are substantial differences: + * The number of registers used for parameter passing and the exact set of + nonvolatile registers differs (see MachRegs.hs). + * On AIX and 64-bit ELF, stack space is always reserved for parameters, + even if they are passed in registers. The called routine may choose to + save parameters from registers to the corresponding space on the stack. + * On AIX and 64-bit ELF, a corresponding amount of GPRs is skipped when + a floating point parameter is passed in an FPR. + * SysV insists on either passing I64 arguments on the stack, or in two GPRs, + starting with an odd-numbered GPR. It may skip a GPR to achieve this. + AIX just treats an I64 likt two separate I32s (high word first). + * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only + 4-byte aligned like everything else on AIX. + * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on + PowerPC Linux does not agree, so neither do we. + + According to all conventions, the parameter area should be part of the + caller's stack frame, allocated in the caller's prologue code (large enough + to hold the parameter lists for all called routines). The NCG already + uses the stack for register spilling, leaving 64 bytes free at the top. + If we need a larger parameter area than that, we increase the size + of the stack frame just before ccalling. +-} + + +genCCall' config gcp target dest_regs args + = do + (finalStack,passArgumentsCode,usedRegs) <- passArguments + (zip3 args argReps argHints) + allArgRegs + (allFPArgRegs platform) + initialStackOffset + nilOL [] + + (labelOrExpr, reduceToFF32) <- case target of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + uses_pic_base_implicitly + return (Left lbl, False) + ForeignTarget expr _ -> do + uses_pic_base_implicitly + return (Right expr, False) + PrimTarget mop -> outOfLineMachOp mop + + let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode + codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 + + case labelOrExpr of + Left lbl -> do -- the linker does all the work for us + return ( codeBefore + `snocOL` BL lbl usedRegs + `appOL` maybeNOP -- some ABI require a NOP after BL + `appOL` codeAfter) + Right dyn -> do -- implement call through function pointer + (dynReg, dynCode) <- getSomeReg dyn + case gcp of + GCP64ELF 1 -> return ( dynCode + `appOL` codeBefore + `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40)) + `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0)) + `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8)) + `snocOL` MTCTR r11 + `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16)) + `snocOL` BCTRL usedRegs + `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40)) + `appOL` codeAfter) + GCP64ELF 2 -> return ( dynCode + `appOL` codeBefore + `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24)) + `snocOL` MR r12 dynReg + `snocOL` MTCTR r12 + `snocOL` BCTRL usedRegs + `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24)) + `appOL` codeAfter) + GCPAIX -> return ( dynCode + -- AIX/XCOFF follows the PowerOPEN ABI + -- which is quite similar to LinuxPPC64/ELFv1 + `appOL` codeBefore + `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20)) + `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0)) + `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4)) + `snocOL` MTCTR r11 + `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8)) + `snocOL` BCTRL usedRegs + `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20)) + `appOL` codeAfter) + _ -> return ( dynCode + `snocOL` MTCTR dynReg + `appOL` codeBefore + `snocOL` BCTRL usedRegs + `appOL` codeAfter) + where + platform = ncgPlatform config + + uses_pic_base_implicitly = do + -- See Note [implicit register in PPC PIC code] + -- on why we claim to use PIC register here + when (ncgPIC config && target32Bit platform) $ do + _ <- getPicBaseNat $ archWordFormat True + return () + + initialStackOffset = case gcp of + GCPAIX -> 24 + GCP32ELF -> 8 + GCP64ELF 1 -> 48 + GCP64ELF 2 -> 32 + _ -> panic "genCall': unknown calling convention" + -- size of linkage area + size of arguments, in bytes + stackDelta finalStack = case gcp of + GCPAIX -> + roundTo 16 $ (24 +) $ max 32 $ sum $ + map (widthInBytes . typeWidth) argReps + GCP32ELF -> roundTo 16 finalStack + GCP64ELF 1 -> + roundTo 16 $ (48 +) $ max 64 $ sum $ + map (roundTo 8 . widthInBytes . typeWidth) + argReps + GCP64ELF 2 -> + roundTo 16 $ (32 +) $ max 64 $ sum $ + map (roundTo 8 . widthInBytes . typeWidth) + argReps + _ -> panic "genCall': unknown calling conv." + + argReps = map (cmmExprType platform) args + (argHints, _) = foreignTargetHints target + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + spFormat = if target32Bit platform then II32 else II64 + + -- TODO: Do not create a new stack frame if delta is too large. + move_sp_down finalStack + | delta > stackFrameHeaderSize platform = + toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))), + DELTA (-delta)] + | otherwise = nilOL + where delta = stackDelta finalStack + move_sp_up finalStack + | delta > stackFrameHeaderSize platform = + toOL [ADD sp sp (RIImm (ImmInt delta)), + DELTA 0] + | otherwise = nilOL + where delta = stackDelta finalStack + + -- A NOP instruction is required after a call (bl instruction) + -- on AIX and 64-Bit Linux. + -- If the call is to a function with a different TOC (r2) the + -- link editor replaces the NOP instruction with a load of the TOC + -- from the stack to restore the TOC. + maybeNOP = case gcp of + GCP32ELF -> nilOL + -- See Section 3.9.4 of OpenPower ABI + GCPAIX -> unitOL NOP + -- See Section 3.5.11 of PPC64 ELF v1.9 + GCP64ELF 1 -> unitOL NOP + -- See Section 2.3.6 of PPC64 ELF v2 + GCP64ELF 2 -> unitOL NOP + _ -> panic "maybeNOP: Unknown PowerPC 64-bit ABI" + + passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) + passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset + accumCode accumUsed | isWord64 arg_ty + && target32Bit (ncgPlatform config) = + do + ChildCode64 code vr_lo <- iselExpr64 arg + let vr_hi = getHiVRegFromLo vr_lo + + case gcp of + GCPAIX -> + do let storeWord vr (gpr:_) _ = MR gpr vr + storeWord vr [] offset + = ST II32 vr (AddrRegImm sp (ImmInt offset)) + passArguments args + (drop 2 gprs) + fprs + (stackOffset+8) + (accumCode `appOL` code + `snocOL` storeWord vr_hi gprs stackOffset + `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) + ((take 2 gprs) ++ accumUsed) + GCP32ELF -> + do let stackOffset' = roundTo 8 stackOffset + stackCode = accumCode `appOL` code + `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) + `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) + regCode hireg loreg = + accumCode `appOL` code + `snocOL` MR hireg vr_hi + `snocOL` MR loreg vr_lo + + case gprs of + hireg : loreg : regs | even (length gprs) -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _skipped : hireg : loreg : regs -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _ -> -- only one or no regs left + passArguments args [] fprs (stackOffset'+8) + stackCode accumUsed + GCP64ELF _ -> panic "passArguments: 32 bit code" + + passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed + | reg : _ <- regs = do + register <- getRegister arg_pro + let code = case register of + Fixed _ freg fcode -> fcode `snocOL` MR reg freg + Any _ acode -> acode reg + stackOffsetRes = case gcp of + -- The PowerOpen ABI requires that we + -- reserve stack slots for register + -- parameters + GCPAIX -> stackOffset + stackBytes + -- ... the SysV ABI 32-bit doesn't. + GCP32ELF -> stackOffset + -- ... but SysV ABI 64-bit does. + GCP64ELF _ -> stackOffset + stackBytes + passArguments args + (drop nGprs gprs) + (drop nFprs fprs) + stackOffsetRes + (accumCode `appOL` code) + (reg : accumUsed) + | otherwise = do + (vr, code) <- getSomeReg arg_pro + passArguments args + (drop nGprs gprs) + (drop nFprs fprs) + (stackOffset' + stackBytes) + (accumCode `appOL` code + `snocOL` ST format_pro vr stackSlot) + accumUsed + where + arg_pro + | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth platform)) [arg] + | otherwise = arg + format_pro + | isBitsType rep = intFormat (wordWidth platform) + | otherwise = cmmTypeFormat rep + conv_op = case hint of + SignedHint -> MO_SS_Conv + _ -> MO_UU_Conv + + stackOffset' = case gcp of + GCPAIX -> + -- The 32bit PowerOPEN ABI is happy with + -- 32bit-alignment ... + stackOffset + GCP32ELF + -- ... the SysV ABI requires 8-byte + -- alignment for doubles. + | isFloatType rep && typeWidth rep == W64 -> + roundTo 8 stackOffset + | otherwise -> + stackOffset + GCP64ELF _ -> + -- Everything on the stack is mapped to + -- 8-byte aligned doublewords + stackOffset + stackOffset'' + | isFloatType rep && typeWidth rep == W32 = + case gcp of + -- The ELF v1 ABI Section 3.2.3 requires: + -- "Single precision floating point values + -- are mapped to the second word in a single + -- doubleword" + GCP64ELF 1 -> stackOffset' + 4 + _ -> stackOffset' + | otherwise = stackOffset' + + stackSlot = AddrRegImm sp (ImmInt stackOffset'') + (nGprs, nFprs, stackBytes, regs) + = case gcp of + GCPAIX -> + case cmmTypeFormat rep of + II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- The PowerOpen ABI requires that we skip a + -- corresponding number of GPRs when we use + -- the FPRs. + -- + -- E.g. for a `double` two GPRs are skipped, + -- whereas for a `float` one GPR is skipped + -- when parameters are assigned to + -- registers. + -- + -- The PowerOpen ABI specification can be found at + -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/ + FF32 -> (1, 1, 4, fprs) + FF64 -> (2, 1, 8, fprs) + II64 -> panic "genCCall' passArguments II64" + + GCP32ELF -> + case cmmTypeFormat rep of + II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- ... the SysV ABI doesn't. + FF32 -> (0, 1, 4, fprs) + FF64 -> (0, 1, 8, fprs) + II64 -> panic "genCCall' passArguments II64" + GCP64ELF _ -> + case cmmTypeFormat rep of + II8 -> (1, 0, 8, gprs) + II16 -> (1, 0, 8, gprs) + II32 -> (1, 0, 8, gprs) + II64 -> (1, 0, 8, gprs) + -- The ELFv1 ABI requires that we skip a + -- corresponding number of GPRs when we use + -- the FPRs. + FF32 -> (1, 1, 8, fprs) + FF64 -> (1, 1, 8, fprs) + + moveResult reduceToFF32 = + case dest_regs of + [] -> nilOL + [dest] + | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) + | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) + | isWord64 rep && target32Bit platform + -> toOL [MR (getHiVRegFromLo r_dest) r3, + MR r_dest r4] + | otherwise -> unitOL (MR r_dest r3) + where rep = cmmRegType platform (CmmLocal dest) + r_dest = getRegisterReg platform (CmmLocal dest) + _ -> panic "genCCall' moveResult: Bad dest_regs" + + outOfLineMachOp mop = + do + mopExpr <- cmmMakeDynamicReference config CallReference $ + mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction + let mopLabelOrExpr = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + return (mopLabelOrExpr, reduce) + where + (functionName, reduce) = case mop of + MO_F32_Exp -> (fsLit "exp", True) + MO_F32_ExpM1 -> (fsLit "expm1", True) + MO_F32_Log -> (fsLit "log", True) + MO_F32_Log1P -> (fsLit "log1p", True) + MO_F32_Sqrt -> (fsLit "sqrt", True) + MO_F32_Fabs -> unsupported + + MO_F32_Sin -> (fsLit "sin", True) + MO_F32_Cos -> (fsLit "cos", True) + MO_F32_Tan -> (fsLit "tan", True) + + MO_F32_Asin -> (fsLit "asin", True) + MO_F32_Acos -> (fsLit "acos", True) + MO_F32_Atan -> (fsLit "atan", True) + + MO_F32_Sinh -> (fsLit "sinh", True) + MO_F32_Cosh -> (fsLit "cosh", True) + MO_F32_Tanh -> (fsLit "tanh", True) + MO_F32_Pwr -> (fsLit "pow", True) + + MO_F32_Asinh -> (fsLit "asinh", True) + MO_F32_Acosh -> (fsLit "acosh", True) + MO_F32_Atanh -> (fsLit "atanh", True) + + MO_F64_Exp -> (fsLit "exp", False) + MO_F64_ExpM1 -> (fsLit "expm1", False) + MO_F64_Log -> (fsLit "log", False) + MO_F64_Log1P -> (fsLit "log1p", False) + MO_F64_Sqrt -> (fsLit "sqrt", False) + MO_F64_Fabs -> unsupported + + MO_F64_Sin -> (fsLit "sin", False) + MO_F64_Cos -> (fsLit "cos", False) + MO_F64_Tan -> (fsLit "tan", False) + + MO_F64_Asin -> (fsLit "asin", False) + MO_F64_Acos -> (fsLit "acos", False) + MO_F64_Atan -> (fsLit "atan", False) + + MO_F64_Sinh -> (fsLit "sinh", False) + MO_F64_Cosh -> (fsLit "cosh", False) + MO_F64_Tanh -> (fsLit "tanh", False) + MO_F64_Pwr -> (fsLit "pow", False) + + MO_F64_Asinh -> (fsLit "asinh", False) + MO_F64_Acosh -> (fsLit "acosh", False) + MO_F64_Atanh -> (fsLit "atanh", False) + + MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False) + + MO_Memcpy _ -> (fsLit "memcpy", False) + MO_Memset _ -> (fsLit "memset", False) + MO_Memmove _ -> (fsLit "memmove", False) + MO_Memcmp _ -> (fsLit "memcmp", False) + + MO_BSwap w -> (fsLit $ bSwapLabel w, False) + MO_BRev w -> (fsLit $ bRevLabel w, False) + MO_PopCnt w -> (fsLit $ popCntLabel w, False) + MO_Pdep w -> (fsLit $ pdepLabel w, False) + MO_Pext w -> (fsLit $ pextLabel w, False) + MO_Clz _ -> unsupported + MO_Ctz _ -> unsupported + MO_AtomicRMW {} -> unsupported + MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) + MO_Xchg w -> (fsLit $ xchgLabel w, False) + MO_AtomicRead _ -> unsupported + MO_AtomicWrite _ -> unsupported + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddWordC {} -> unsupported + MO_SubWordC {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + MO_Prefetch_Data _ -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported") + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets + | OSAIX <- platformOS platform + = do + (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + let fmt = archWordFormat $ target32Bit platform + sha = if target32Bit platform then 2 else 3 + tmp <- getNewRegNat fmt + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let code = e_code `appOL` t_code `appOL` toOL [ + SL fmt tmp reg (RIImm (ImmInt sha)), + LD fmt tmp (AddrRegReg tableReg tmp), + MTCTR tmp, + BCTR ids (Just lbl) [] + ] + return code + + | (ncgPIC config) || (not $ target32Bit platform) + = do + (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + let fmt = archWordFormat $ target32Bit platform + sha = if target32Bit platform then 2 else 3 + tmp <- getNewRegNat fmt + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let code = e_code `appOL` t_code `appOL` toOL [ + SL fmt tmp reg (RIImm (ImmInt sha)), + LD fmt tmp (AddrRegReg tableReg tmp), + ADD tmp tmp (RIReg tableReg), + MTCTR tmp, + BCTR ids (Just lbl) [] + ] + return code + | otherwise + = do + (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + let fmt = archWordFormat $ target32Bit platform + sha = if target32Bit platform then 2 else 3 + tmp <- getNewRegNat fmt + lbl <- getNewLabelNat + let code = e_code `appOL` toOL [ + SL fmt tmp reg (RIImm (ImmInt sha)), + ADDIS tmp tmp (HA (ImmCLbl lbl)), + LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), + MTCTR tmp, + BCTR ids (Just lbl) [] + ] + return code + where + (offset, ids) = switchTargetsToTable targets + platform = ncgPlatform config + +generateJumpTableForInstr :: NCGConfig -> Instr + -> Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr config (BCTR ids (Just lbl) _) = + let jumpTable + | (ncgPIC config) || (not $ target32Bit $ ncgPlatform config) + = map jumpTableEntryRel ids + | otherwise = map (jumpTableEntry config) ids + where jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 + (ncgWordWidth config)) + where blockLabel = blockLbl blockid + in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- 'condIntReg' and 'condFltReg': condition codes into registers + +-- Turn those condition codes into integers now (when they appear on +-- the right hand side of an assignment). + + + +condReg :: NatM CondCode -> NatM Register +condReg getCond = do + CondCode _ cond cond_code <- getCond + platform <- getPlatform + let + code dst = cond_code + `appOL` negate_code + `appOL` toOL [ + MFCR dst, + RLWINM dst dst (bit + 1) 31 31 + ] + + negate_code | do_negate = unitOL (CRNOR bit bit bit) + | otherwise = nilOL + + (bit, do_negate) = case cond of + LTT -> (0, False) + LE -> (1, True) + EQQ -> (2, False) + GE -> (0, True) + GTT -> (1, False) + + NE -> (2, True) + + LU -> (0, False) + LEU -> (1, True) + GEU -> (0, True) + GU -> (1, False) + _ -> panic "PPC.CodeGen.codeReg: no match" + + format = archWordFormat $ target32Bit platform + return (Any format code) + +condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register +condIntReg cond width x y = condReg (condIntCode cond width x y) +condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg cond x y = condReg (condFltCode cond x y) + + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + + + +{- +Wolfgang's PowerPC version of The Rules: + +A slightly modified version of The Rules to take advantage of the fact +that PowerPC instructions work on all registers and don't implicitly +clobber any fixed registers. + +* The only expression for which getRegister returns Fixed is (CmmReg reg). + +* If getRegister returns Any, then the code it generates may modify only: + (a) fresh temporaries + (b) the destination register + It may *not* modify global registers, unless the global + register happens to be the destination register. + It may not clobber any other registers. In fact, only ccalls clobber any + fixed registers. + Also, it may not modify the counter register (used by genCCall). + + Corollary: If a getRegister for a subexpression returns Fixed, you need + not move it to a fresh temporary before evaluating the next subexpression. + The Fixed register won't be modified. + Therefore, we don't need a counterpart for the x86's getStableReg on PPC. + +* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on + the value of the destination register. +-} + +trivialCode + :: Width + -> Bool + -> (Reg -> Reg -> RI -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + +trivialCode rep signed instr x (CmmLit (CmmInt y _)) + | Just imm <- makeImmediate rep signed y + = do + (src1, code1) <- getSomeReg x + let code dst = code1 `snocOL` instr dst src1 (RIImm imm) + return (Any (intFormat rep) code) + +trivialCode rep _ instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2) + return (Any (intFormat rep) code) + +shiftMulCode + :: Width + -> Bool + -> (Format-> Reg -> Reg -> RI -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register +shiftMulCode width sign instr x (CmmLit (CmmInt y _)) + | Just imm <- makeImmediate width sign y + = do + (src1, code1) <- getSomeReg x + let format = intFormat width + let ins_fmt = intFormat (max W32 width) + let code dst = code1 `snocOL` instr ins_fmt dst src1 (RIImm imm) + return (Any format code) + +shiftMulCode width _ instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let format = intFormat width + let ins_fmt = intFormat (max W32 width) + let code dst = code1 `appOL` code2 + `snocOL` instr ins_fmt dst src1 (RIReg src2) + return (Any format code) + +trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCodeNoImm' format instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2 + return (Any format code) + +trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCodeNoImm format instr x y + = trivialCodeNoImm' format (instr format) x y + +srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +srCode width sgn instr x (CmmLit (CmmInt y _)) + | Just imm <- makeImmediate width sgn y + = do + let op_len = max W32 width + extend = if sgn then extendSExpr else extendUExpr + (src1, code1) <- getSomeReg (extend width op_len x) + let code dst = code1 `snocOL` + instr (intFormat op_len) dst src1 (RIImm imm) + return (Any (intFormat width) code) + +srCode width sgn instr x y = do + let op_len = max W32 width + extend = if sgn then extendSExpr else extendUExpr + (src1, code1) <- getSomeReg (extend width op_len x) + (src2, code2) <- getSomeReg (extendUExpr width op_len y) + -- Note: Shift amount `y` is unsigned + let code dst = code1 `appOL` code2 `snocOL` + instr (intFormat op_len) dst src1 (RIReg src2) + return (Any (intFormat width) code) + +divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register +divCode width sgn x y = do + let op_len = max W32 width + extend = if sgn then extendSExpr else extendUExpr + (src1, code1) <- getSomeReg (extend width op_len x) + (src2, code2) <- getSomeReg (extend width op_len y) + let code dst = code1 `appOL` code2 `snocOL` + DIV (intFormat op_len) sgn dst src1 src2 + return (Any (intFormat width) code) + + +trivialUCode :: Format + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register +trivialUCode rep instr x = do + (src, code) <- getSomeReg x + let code' dst = code `snocOL` instr dst src + return (Any rep code') + +-- There is no "remainder" instruction on the PPC, so we have to do +-- it the hard way. +-- The "sgn" parameter is the signedness for the division instruction + +remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr + -> NatM (Reg -> InstrBlock) +remainderCode rep sgn reg_q arg_x arg_y = do + let op_len = max W32 rep + fmt = intFormat op_len + extend = if sgn then extendSExpr else extendUExpr + (x_reg, x_code) <- getSomeReg (extend rep op_len arg_x) + (y_reg, y_code) <- getSomeReg (extend rep op_len arg_y) + return $ \reg_r -> y_code `appOL` x_code + `appOL` toOL [ DIV fmt sgn reg_q x_reg y_reg + , MULL fmt reg_r reg_q (RIReg y_reg) + , SUBF reg_r reg_r x_reg + ] + + +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP fromRep toRep x = do + platform <- getPlatform + let arch = platformArch platform + coerceInt2FP' arch fromRep toRep x + +coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP' ArchPPC fromRep toRep x = do + (src, code) <- getSomeReg x + lbl <- getNewLabelNat + itmp <- getNewRegNat II32 + ftmp <- getNewRegNat FF64 + config <- getConfig + platform <- getPlatform + dynRef <- cmmMakeDynamicReference config DataReference lbl + Amode addr addr_code <- getAmode D dynRef + let + code' dst = code `appOL` maybe_exts `appOL` toOL [ + LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], + XORIS itmp src (ImmInt 0x8000), + ST II32 itmp (spRel platform 3), + LIS itmp (ImmInt 0x4330), + ST II32 itmp (spRel platform 2), + LD FF64 ftmp (spRel platform 2) + ] `appOL` addr_code `appOL` toOL [ + LD FF64 dst addr, + FSUB FF64 dst ftmp dst + ] `appOL` maybe_frsp dst + + maybe_exts = case fromRep of + W8 -> unitOL $ EXTS II8 src src + W16 -> unitOL $ EXTS II16 src src + W32 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + maybe_frsp dst + = case toRep of + W32 -> unitOL $ FRSP dst dst + W64 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + return (Any (floatFormat toRep) code') + +-- On an ELF v1 Linux we use the compiler doubleword in the stack frame +-- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only +-- set right before a call and restored right after return from the call. +-- So it is fine. +coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do + (src, code) <- getSomeReg x + platform <- getPlatform + let + code' dst = code `appOL` maybe_exts `appOL` toOL [ + ST II64 src (spRel platform 3), + LD FF64 dst (spRel platform 3), + FCFID dst dst + ] `appOL` maybe_frsp dst + + maybe_exts = case fromRep of + W8 -> unitOL $ EXTS II8 src src + W16 -> unitOL $ EXTS II16 src src + W32 -> unitOL $ EXTS II32 src src + W64 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + maybe_frsp dst + = case toRep of + W32 -> unitOL $ FRSP dst dst + W64 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + return (Any (floatFormat toRep) code') + +coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch" + + +coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register +coerceFP2Int fromRep toRep x = do + platform <- getPlatform + let arch = platformArch platform + coerceFP2Int' arch fromRep toRep x + +coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register +coerceFP2Int' ArchPPC _ toRep x = do + platform <- getPlatform + -- the reps don't really matter: F*->FF64 and II32->I* are no-ops + (src, code) <- getSomeReg x + tmp <- getNewRegNat FF64 + let + code' dst = code `appOL` toOL [ + -- convert to int in FP reg + FCTIWZ tmp src, + -- store value (64bit) from FP to stack + ST FF64 tmp (spRel platform 2), + -- read low word of value (high word is undefined) + LD II32 dst (spRel platform 3)] + return (Any (intFormat toRep) code') + +coerceFP2Int' (ArchPPC_64 _) _ toRep x = do + platform <- getPlatform + -- the reps don't really matter: F*->FF64 and II64->I* are no-ops + (src, code) <- getSomeReg x + tmp <- getNewRegNat FF64 + let + code' dst = code `appOL` toOL [ + -- convert to int in FP reg + FCTIDZ tmp src, + -- store value (64bit) from FP to compiler word on stack + ST FF64 tmp (spRel platform 3), + LD II64 dst (spRel platform 3)] + return (Any (intFormat toRep) code') + +coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch" + +-- Note [.LCTOC1 in PPC PIC code] +-- The .LCTOC1 label is defined to point 32768 bytes into the GOT table +-- to make the most of the PPC's 16-bit displacements. +-- As 16-bit signed offset is used (usually via addi/lwz instructions) +-- first element will have '-32768' offset against .LCTOC1. + +-- Note [implicit register in PPC PIC code] +-- PPC generates calls by labels in assembly +-- in form of: +-- bl puts+32768@plt +-- in this form it's not seen directly (by GHC NCG) +-- that r30 (PicBaseReg) is used, +-- but r30 is a required part of PLT code setup: +-- puts+32768@plt: +-- lwz r11,-30484(r30) ; offset in .LCTOC1 +-- mtctr r11 +-- bctr diff --git a/GHC/CmmToAsm/PPC/Cond.hs b/GHC/CmmToAsm/PPC/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Cond.hs @@ -0,0 +1,47 @@ +module GHC.CmmToAsm.PPC.Cond ( + Cond(..), + condNegate, + condUnsigned, +) + +where + +import GHC.Prelude + +import GHC.Utils.Panic + +data Cond + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + deriving Eq + + +condNegate :: Cond -> Cond +condNegate ALWAYS = panic "condNegate: ALWAYS" +condNegate EQQ = NE +condNegate GE = LTT +condNegate GEU = LU +condNegate GTT = LE +condNegate GU = LEU +condNegate LE = GTT +condNegate LEU = GU +condNegate LTT = GE +condNegate LU = GEU +condNegate NE = EQQ + +-- Condition utils +condUnsigned :: Cond -> Bool +condUnsigned GU = True +condUnsigned LU = True +condUnsigned GEU = True +condUnsigned LEU = True +condUnsigned _ = False diff --git a/GHC/CmmToAsm/PPC/Instr.hs b/GHC/CmmToAsm/PPC/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Instr.hs @@ -0,0 +1,717 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- + +#include "HsVersions.h" + +module GHC.CmmToAsm.PPC.Instr ( + archWordFormat, + RI(..), + Instr(..), + stackFrameHeaderSize, + maxSpillSlots, + allocMoreStack, + makeFarBranches +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.PPC.Regs +import GHC.CmmToAsm.PPC.Cond +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Platform.Regs +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.Info +import GHC.Data.FastString +import GHC.Cmm.CLabel +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.FM (listToUFM, lookupUFM) +import GHC.Types.Unique.Supply + +import Control.Monad (replicateM) +import Data.Maybe (fromMaybe) + +-------------------------------------------------------------------------------- +-- Format of a PPC memory address. +-- +archWordFormat :: Bool -> Format +archWordFormat is32Bit + | is32Bit = II32 + | otherwise = II64 + + +-- | Instruction instance for powerpc +instance Instruction Instr where + regUsageOfInstr = ppc_regUsageOfInstr + patchRegsOfInstr = ppc_patchRegsOfInstr + isJumpishInstr = ppc_isJumpishInstr + jumpDestsOfInstr = ppc_jumpDestsOfInstr + patchJumpInstr = ppc_patchJumpInstr + mkSpillInstr = ppc_mkSpillInstr + mkLoadInstr = ppc_mkLoadInstr + takeDeltaInstr = ppc_takeDeltaInstr + isMetaInstr = ppc_isMetaInstr + mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr + takeRegRegMoveInstr = ppc_takeRegRegMoveInstr + mkJumpInstr = ppc_mkJumpInstr + mkStackAllocInstr = ppc_mkStackAllocInstr + mkStackDeallocInstr = ppc_mkStackDeallocInstr + + +ppc_mkStackAllocInstr :: Platform -> Int -> [Instr] +ppc_mkStackAllocInstr platform amount + = ppc_mkStackAllocInstr' platform (-amount) + +ppc_mkStackDeallocInstr :: Platform -> Int -> [Instr] +ppc_mkStackDeallocInstr platform amount + = ppc_mkStackAllocInstr' platform amount + +ppc_mkStackAllocInstr' :: Platform -> Int -> [Instr] +ppc_mkStackAllocInstr' platform amount + | fits16Bits amount + = [ LD fmt r0 (AddrRegImm sp zero) + , STU fmt r0 (AddrRegImm sp immAmount) + ] + | otherwise + = [ LD fmt r0 (AddrRegImm sp zero) + , ADDIS tmp sp (HA immAmount) + , ADD tmp tmp (RIImm (LO immAmount)) + , STU fmt r0 (AddrRegReg sp tmp) + ] + where + fmt = intFormat $ widthFromBytes (platformWordSizeInBytes platform) + zero = ImmInt 0 + tmp = tmpReg platform + immAmount = ImmInt amount + +-- +-- See note [extra spill slots] in X86/Instr.hs +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr + -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) +allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do + let + infos = mapKeys info + entries = case code of + [] -> infos + BasicBlock entry _ : _ -- first block is the entry point + | entry `elem` infos -> infos + | otherwise -> entry : infos + + uniqs <- replicateM (length entries) getUniqueM + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + retargetList = (zip entries (map mkBlockId uniqs)) + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insns (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id $ alloc ++ [BCC ALWAYS new_blockid Nothing] + , BasicBlock new_blockid block' + ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r + -- BCTR might or might not be a non-local jump. For + -- "labeled-goto" we use JMP, and for "computed-goto" we + -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'. + = case insn of + JMP _ _ -> dealloc ++ (insn : r) + BCTR [] Nothing _ -> dealloc ++ (insn : r) + BCTR ids label rs -> BCTR (map (fmap retarget) ids) label rs : r + BCCFAR cond b p -> BCCFAR cond (retarget b) p : r + BCC cond b p -> BCC cond (retarget b) p : r + _ -> insn : r + -- BL and BCTRL are call-like instructions rather than + -- jumps, and are used only for C calls. + + retarget :: BlockId -> BlockId + retarget b + = fromMaybe b (mapLookup b new_blockmap) + + new_code + = concatMap insert_stack_insns code + + -- in + return (CmmProc info lbl live (ListGraph new_code),retargetList) + + +-- ----------------------------------------------------------------------------- +-- Machine's assembly language + +-- We have a few common "instructions" (nearly all the pseudo-ops) but +-- mostly all of 'Instr' is machine-specific. + +-- Register or immediate +data RI + = RIReg Reg + | RIImm Imm + +data Instr + -- comment pseudo-op + = COMMENT FastString + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + + -- some static data spat out during code + -- generation. Will be extracted before + -- pretty-printing. + | LDATA Section RawCmmStatics + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for + -- benefit of subsequent passes + | DELTA Int + + -- Loads and stores. + | LD Format Reg AddrMode -- Load format, dst, src + | LDFAR Format Reg AddrMode -- Load format, dst, src 32 bit offset + | LDR Format Reg AddrMode -- Load and reserve format, dst, src + | LA Format Reg AddrMode -- Load arithmetic format, dst, src + | ST Format Reg AddrMode -- Store format, src, dst + | STFAR Format Reg AddrMode -- Store format, src, dst 32 bit offset + | STU Format Reg AddrMode -- Store with Update format, src, dst + | STC Format Reg AddrMode -- Store conditional format, src, dst + | LIS Reg Imm -- Load Immediate Shifted dst, src + | LI Reg Imm -- Load Immediate dst, src + | MR Reg Reg -- Move Register dst, src -- also for fmr + + | CMP Format Reg RI -- format, src1, src2 + | CMPL Format Reg RI -- format, src1, src2 + + | BCC Cond BlockId (Maybe Bool) -- cond, block, hint + | BCCFAR Cond BlockId (Maybe Bool) -- cond, block, hint + -- hint: + -- Just True: branch likely taken + -- Just False: branch likely not taken + -- Nothing: no hint + | JMP CLabel [Reg] -- same as branch, + -- but with CLabel instead of block ID + -- and live global registers + | MTCTR Reg + | BCTR [Maybe BlockId] (Maybe CLabel) [Reg] + -- with list of local destinations, and + -- jump table location if necessary + | BL CLabel [Reg] -- with list of argument regs + | BCTRL [Reg] + + | ADD Reg Reg RI -- dst, src1, src2 + | ADDO Reg Reg Reg -- add and set overflow + | ADDC Reg Reg Reg -- (carrying) dst, src1, src2 + | ADDE Reg Reg Reg -- (extended) dst, src1, src2 + | ADDZE Reg Reg -- (to zero extended) dst, src + | ADDIS Reg Reg Imm -- Add Immediate Shifted dst, src1, src2 + | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1 + | SUBFO Reg Reg Reg -- subtract from and set overflow + | SUBFC Reg Reg RI -- (carrying) dst, src1, src2 ; + -- dst = src2 - src1 + | SUBFE Reg Reg Reg -- (extended) dst, src1, src2 ; + -- dst = src2 - src1 + | MULL Format Reg Reg RI + | MULLO Format Reg Reg Reg -- multiply and set overflow + | MFOV Format Reg -- move overflow bit (1|33) to register + -- pseudo-instruction; pretty printed as + -- mfxer dst + -- extr[w|d]i dst, dst, 1, [1|33] + | MULHU Format Reg Reg Reg + | DIV Format Bool Reg Reg Reg + | AND Reg Reg RI -- dst, src1, src2 + | ANDC Reg Reg Reg -- AND with complement, dst = src1 & ~ src2 + | NAND Reg Reg Reg -- dst, src1, src2 + | OR Reg Reg RI -- dst, src1, src2 + | ORIS Reg Reg Imm -- OR Immediate Shifted dst, src1, src2 + | XOR Reg Reg RI -- dst, src1, src2 + | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2 + + | EXTS Format Reg Reg + | CNTLZ Format Reg Reg + + | NEG Reg Reg + | NOT Reg Reg + + | SL Format Reg Reg RI -- shift left + | SR Format Reg Reg RI -- shift right + | SRA Format Reg Reg RI -- shift right arithmetic + + | RLWINM Reg Reg Int Int Int -- Rotate Left Word Immediate then AND with Mask + | CLRLI Format Reg Reg Int -- clear left immediate (extended mnemonic) + | CLRRI Format Reg Reg Int -- clear right immediate (extended mnemonic) + + | FADD Format Reg Reg Reg + | FSUB Format Reg Reg Reg + | FMUL Format Reg Reg Reg + | FDIV Format Reg Reg Reg + | FABS Reg Reg -- abs is the same for single and double + | FNEG Reg Reg -- negate is the same for single and double prec. + + | FCMP Reg Reg + + | FCTIWZ Reg Reg -- convert to integer word + | FCTIDZ Reg Reg -- convert to integer double word + | FCFID Reg Reg -- convert from integer double word + | FRSP Reg Reg -- reduce to single precision + -- (but destination is a FP register) + + | CRNOR Int Int Int -- condition register nor + | MFCR Reg -- move from condition register + + | MFLR Reg -- move from link register + | FETCHPC Reg -- pseudo-instruction: + -- bcl to next insn, mflr reg + | HWSYNC -- heavy weight sync + | ISYNC -- instruction synchronize + | LWSYNC -- memory barrier + | NOP -- no operation, PowerPC 64 bit + -- needs this as place holder to + -- reload TOC pointer + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage +ppc_regUsageOfInstr platform instr + = case instr of + LD _ reg addr -> usage (regAddr addr, [reg]) + LDFAR _ reg addr -> usage (regAddr addr, [reg]) + LDR _ reg addr -> usage (regAddr addr, [reg]) + LA _ reg addr -> usage (regAddr addr, [reg]) + ST _ reg addr -> usage (reg : regAddr addr, []) + STFAR _ reg addr -> usage (reg : regAddr addr, []) + STU _ reg addr -> usage (reg : regAddr addr, []) + STC _ reg addr -> usage (reg : regAddr addr, []) + LIS reg _ -> usage ([], [reg]) + LI reg _ -> usage ([], [reg]) + MR reg1 reg2 -> usage ([reg2], [reg1]) + CMP _ reg ri -> usage (reg : regRI ri,[]) + CMPL _ reg ri -> usage (reg : regRI ri,[]) + BCC _ _ _ -> noUsage + BCCFAR _ _ _ -> noUsage + JMP _ regs -> usage (regs, []) + MTCTR reg -> usage ([reg],[]) + BCTR _ _ regs -> usage (regs, []) + BL _ params -> usage (params, callClobberedRegs platform) + BCTRL params -> usage (params, callClobberedRegs platform) + + ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + ADDO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDZE reg1 reg2 -> usage ([reg2], [reg1]) + ADDIS reg1 reg2 _ -> usage ([reg2], [reg1]) + SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + SUBFO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + SUBFC reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SUBFE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + MULL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + MULLO _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + MFOV _ reg -> usage ([], [reg]) + MULHU _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + DIV _ _ reg1 reg2 reg3 + -> usage ([reg2,reg3], [reg1]) + + AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + ANDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + NAND reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + ORIS reg1 reg2 _ -> usage ([reg2], [reg1]) + XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + XORIS reg1 reg2 _ -> usage ([reg2], [reg1]) + EXTS _ reg1 reg2 -> usage ([reg2], [reg1]) + CNTLZ _ reg1 reg2 -> usage ([reg2], [reg1]) + NEG reg1 reg2 -> usage ([reg2], [reg1]) + NOT reg1 reg2 -> usage ([reg2], [reg1]) + SL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SR _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SRA _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1]) + CLRLI _ reg1 reg2 _ -> usage ([reg2], [reg1]) + CLRRI _ reg1 reg2 _ -> usage ([reg2], [reg1]) + + FADD _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FSUB _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FMUL _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FDIV _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FABS r1 r2 -> usage ([r2], [r1]) + FNEG r1 r2 -> usage ([r2], [r1]) + FCMP r1 r2 -> usage ([r1,r2], []) + FCTIWZ r1 r2 -> usage ([r2], [r1]) + FCTIDZ r1 r2 -> usage ([r2], [r1]) + FCFID r1 r2 -> usage ([r2], [r1]) + FRSP r1 r2 -> usage ([r2], [r1]) + MFCR reg -> usage ([], [reg]) + MFLR reg -> usage ([], [reg]) + FETCHPC reg -> usage ([], [reg]) + _ -> noUsage + where + usage (src, dst) = RU (filter (interesting platform) src) + (filter (interesting platform) dst) + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + + regRI (RIReg r) = [r] + regRI _ = [] + +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) = freeReg platform i +interesting _ (RegReal (RealRegPair{})) + = panic "PPC.Instr.interesting: no reg pairs on this arch" + + + +-- | Apply a given mapping to all the register references in this +-- instruction. +ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +ppc_patchRegsOfInstr instr env + = case instr of + LD fmt reg addr -> LD fmt (env reg) (fixAddr addr) + LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr) + LDR fmt reg addr -> LDR fmt (env reg) (fixAddr addr) + LA fmt reg addr -> LA fmt (env reg) (fixAddr addr) + ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) + STFAR fmt reg addr -> STFAR fmt (env reg) (fixAddr addr) + STU fmt reg addr -> STU fmt (env reg) (fixAddr addr) + STC fmt reg addr -> STC fmt (env reg) (fixAddr addr) + LIS reg imm -> LIS (env reg) imm + LI reg imm -> LI (env reg) imm + MR reg1 reg2 -> MR (env reg1) (env reg2) + CMP fmt reg ri -> CMP fmt (env reg) (fixRI ri) + CMPL fmt reg ri -> CMPL fmt (env reg) (fixRI ri) + BCC cond lbl p -> BCC cond lbl p + BCCFAR cond lbl p -> BCCFAR cond lbl p + JMP l regs -> JMP l regs -- global regs will not be remapped + MTCTR reg -> MTCTR (env reg) + BCTR targets lbl rs -> BCTR targets lbl rs + BL imm argRegs -> BL imm argRegs -- argument regs + BCTRL argRegs -> BCTRL argRegs -- cannot be remapped + ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri) + ADDO reg1 reg2 reg3 -> ADDO (env reg1) (env reg2) (env reg3) + ADDC reg1 reg2 reg3 -> ADDC (env reg1) (env reg2) (env reg3) + ADDE reg1 reg2 reg3 -> ADDE (env reg1) (env reg2) (env reg3) + ADDZE reg1 reg2 -> ADDZE (env reg1) (env reg2) + ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm + SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3) + SUBFO reg1 reg2 reg3 -> SUBFO (env reg1) (env reg2) (env reg3) + SUBFC reg1 reg2 ri -> SUBFC (env reg1) (env reg2) (fixRI ri) + SUBFE reg1 reg2 reg3 -> SUBFE (env reg1) (env reg2) (env reg3) + MULL fmt reg1 reg2 ri + -> MULL fmt (env reg1) (env reg2) (fixRI ri) + MULLO fmt reg1 reg2 reg3 + -> MULLO fmt (env reg1) (env reg2) (env reg3) + MFOV fmt reg -> MFOV fmt (env reg) + MULHU fmt reg1 reg2 reg3 + -> MULHU fmt (env reg1) (env reg2) (env reg3) + DIV fmt sgn reg1 reg2 reg3 + -> DIV fmt sgn (env reg1) (env reg2) (env reg3) + + AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri) + ANDC reg1 reg2 reg3 -> ANDC (env reg1) (env reg2) (env reg3) + NAND reg1 reg2 reg3 -> NAND (env reg1) (env reg2) (env reg3) + OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri) + ORIS reg1 reg2 imm -> ORIS (env reg1) (env reg2) imm + XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri) + XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm + EXTS fmt reg1 reg2 -> EXTS fmt (env reg1) (env reg2) + CNTLZ fmt reg1 reg2 -> CNTLZ fmt (env reg1) (env reg2) + NEG reg1 reg2 -> NEG (env reg1) (env reg2) + NOT reg1 reg2 -> NOT (env reg1) (env reg2) + SL fmt reg1 reg2 ri + -> SL fmt (env reg1) (env reg2) (fixRI ri) + SR fmt reg1 reg2 ri + -> SR fmt (env reg1) (env reg2) (fixRI ri) + SRA fmt reg1 reg2 ri + -> SRA fmt (env reg1) (env reg2) (fixRI ri) + RLWINM reg1 reg2 sh mb me + -> RLWINM (env reg1) (env reg2) sh mb me + CLRLI fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n + CLRRI fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n + FADD fmt r1 r2 r3 -> FADD fmt (env r1) (env r2) (env r3) + FSUB fmt r1 r2 r3 -> FSUB fmt (env r1) (env r2) (env r3) + FMUL fmt r1 r2 r3 -> FMUL fmt (env r1) (env r2) (env r3) + FDIV fmt r1 r2 r3 -> FDIV fmt (env r1) (env r2) (env r3) + FABS r1 r2 -> FABS (env r1) (env r2) + FNEG r1 r2 -> FNEG (env r1) (env r2) + FCMP r1 r2 -> FCMP (env r1) (env r2) + FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) + FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2) + FCFID r1 r2 -> FCFID (env r1) (env r2) + FRSP r1 r2 -> FRSP (env r1) (env r2) + MFCR reg -> MFCR (env reg) + MFLR reg -> MFLR (env reg) + FETCHPC reg -> FETCHPC (env reg) + _ -> instr + where + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + + fixRI (RIReg r) = RIReg (env r) + fixRI other = other + + +-------------------------------------------------------------------------------- +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +ppc_isJumpishInstr :: Instr -> Bool +ppc_isJumpishInstr instr + = case instr of + BCC{} -> True + BCCFAR{} -> True + BCTR{} -> True + BCTRL{} -> True + BL{} -> True + JMP{} -> True + _ -> False + + +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +ppc_jumpDestsOfInstr :: Instr -> [BlockId] +ppc_jumpDestsOfInstr insn + = case insn of + BCC _ id _ -> [id] + BCCFAR _ id _ -> [id] + BCTR targets _ _ -> [id | Just id <- targets] + _ -> [] + + +-- | Change the destination of this jump instruction. +-- Used in the linear allocator when adding fixup blocks for join +-- points. +ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +ppc_patchJumpInstr insn patchF + = case insn of + BCC cc id p -> BCC cc (patchF id) p + BCCFAR cc id p -> BCCFAR cc (patchF id) p + BCTR ids lbl rs -> BCTR (map (fmap patchF) ids) lbl rs + _ -> insn + + +-- ----------------------------------------------------------------------------- + +-- | An instruction to spill a register into a spill slot. +ppc_mkSpillInstr + :: NCGConfig + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +ppc_mkSpillInstr config reg delta slot + = let platform = ncgPlatform config + off = spillSlotToOffset platform slot + arch = platformArch platform + in + let fmt = case targetClassOfReg platform reg of + RcInteger -> case arch of + ArchPPC -> II32 + _ -> II64 + RcDouble -> FF64 + _ -> panic "PPC.Instr.mkSpillInstr: no match" + instr = case makeImmediate W32 True (off-delta) of + Just _ -> ST + Nothing -> STFAR -- pseudo instruction: 32 bit offsets + + in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) + + +ppc_mkLoadInstr + :: NCGConfig + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +ppc_mkLoadInstr config reg delta slot + = let platform = ncgPlatform config + off = spillSlotToOffset platform slot + arch = platformArch platform + in + let fmt = case targetClassOfReg platform reg of + RcInteger -> case arch of + ArchPPC -> II32 + _ -> II64 + RcDouble -> FF64 + _ -> panic "PPC.Instr.mkLoadInstr: no match" + instr = case makeImmediate W32 True (off-delta) of + Just _ -> LD + Nothing -> LDFAR -- pseudo instruction: 32 bit offsets + + in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) + + +-- | The size of a minimal stackframe header including minimal +-- parameter save area. +stackFrameHeaderSize :: Platform -> Int +stackFrameHeaderSize platform + = case platformOS platform of + OSAIX -> 24 + 8 * 4 + _ -> case platformArch platform of + -- header + parameter save area + ArchPPC -> 64 -- TODO: check ABI spec + ArchPPC_64 ELF_V1 -> 48 + 8 * 8 + ArchPPC_64 ELF_V2 -> 32 + 8 * 8 + _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS" + +-- | The maximum number of bytes required to spill a register. PPC32 +-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and +-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike +-- x86. Note that AltiVec's vector registers are 128-bit wide so we +-- must not use this to spill them. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config +-- = 0 -- useful for testing allocMoreStack + = let platform = ncgPlatform config + in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + `div` spillSlotSize) - 1 + +-- | The number of bytes that the stack pointer should be aligned +-- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor +-- specific supplements). +stackAlign :: Int +stackAlign = 16 + +-- | Convert a spill slot number to a *byte* offset, with no sign. +spillSlotToOffset :: Platform -> Int -> Int +spillSlotToOffset platform slot + = stackFrameHeaderSize platform + spillSlotSize * slot + + +-------------------------------------------------------------------------------- +-- | See if this instruction is telling us the current C stack delta +ppc_takeDeltaInstr + :: Instr + -> Maybe Int + +ppc_takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +ppc_isMetaInstr + :: Instr + -> Bool + +ppc_isMetaInstr instr + = case instr of + COMMENT{} -> True + LOCATION{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + + +-- | Copy the value in a register to another one. +-- Must work for all register classes. +ppc_mkRegRegMoveInstr + :: Reg + -> Reg + -> Instr + +ppc_mkRegRegMoveInstr src dst + = MR dst src + + +-- | Make an unconditional jump instruction. +ppc_mkJumpInstr + :: BlockId + -> [Instr] + +ppc_mkJumpInstr id + = [BCC ALWAYS id Nothing] + + +-- | Take the source and destination from this reg -> reg move instruction +-- or Nothing if it's not one +ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) +ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst) +ppc_takeRegRegMoveInstr _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Making far branches + +-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too +-- big, we have to work around this limitation. + +makeFarBranches + :: LabelMap RawCmmStatics + -> [NatBasicBlock Instr] + -> [NatBasicBlock Instr] +makeFarBranches info_env blocks + | last blockAddresses < nearLimit = blocks + | otherwise = zipWith handleBlock blockAddresses blocks + where + blockAddresses = scanl (+) 0 $ map blockLen blocks + blockLen (BasicBlock _ instrs) = length instrs + + handleBlock addr (BasicBlock id instrs) + = BasicBlock id (zipWith makeFar [addr..] instrs) + + makeFar _ (BCC ALWAYS tgt _) = BCC ALWAYS tgt Nothing + makeFar addr (BCC cond tgt p) + | abs (addr - targetAddr) >= nearLimit + = BCCFAR cond tgt p + | otherwise + = BCC cond tgt p + where Just targetAddr = lookupUFM blockAddressMap tgt + makeFar _ other = other + + -- 8192 instructions are allowed; let's keep some distance, as + -- we have a few pseudo-insns that are pretty-printed as + -- multiple instructions, and it's just not worth the effort + -- to calculate things exactly + nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW + + blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses diff --git a/GHC/CmmToAsm/PPC/Ppr.hs b/GHC/CmmToAsm/PPC/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Ppr.hs @@ -0,0 +1,1123 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.CmmToAsm.PPC.Ppr (pprNatCmmDecl) where + +import GHC.Prelude + +import GHC.CmmToAsm.PPC.Regs +import GHC.CmmToAsm.PPC.Instr +import GHC.CmmToAsm.PPC.Cond +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Format +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config + +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Ppr.Expr () -- For Outputable instances + +import GHC.Types.Unique ( pprUniqueAlways, getUnique ) +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Driver.Session (targetPlatform) + +import Data.Word +import Data.Int +import Data.Bits + +-- ----------------------------------------------------------------------------- +-- Printing this stuff out + +pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section + $$ pprDatas (ncgPlatform config) dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in + case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) $$ + (case platformArch platform of + ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl + ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl + _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, + -- so label needed + vcat (map (pprBasicBlock config top_info) blocks) $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + pprSizeDecl platform lbl + + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) $$ + (if platformHasSubsectionsViaSymbols platform + then ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock config top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then + -- See Note [Subsections Via Symbols] in X86/Ppr.hs + text "\t.long " + <+> ppr info_lbl + <+> char '-' + <+> ppr (mkDeadStripPreventer info_lbl) + else empty) $$ + pprSizeDecl platform info_lbl + +-- | Output the ELF .size directive. +pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) + then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl + else empty + where + prettyLbl = ppr lbl + codeLbl + | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl + | otherwise = prettyLbl + +pprFunctionDescriptor :: CLabel -> SDoc +pprFunctionDescriptor lab = pprGloblDecl lab + $$ text "\t.section \".opd\", \"aw\"" + $$ text "\t.align 3" + $$ ppr lab <> char ':' + $$ text "\t.quad ." + <> ppr lab + <> text ",.TOC.@tocbase,0" + $$ text "\t.previous" + $$ text "\t.type" + <+> ppr lab + <> text ", @function" + $$ char '.' <> ppr lab <> char ':' + +pprFunctionPrologue :: CLabel ->SDoc +pprFunctionPrologue lab = pprGloblDecl lab + $$ text ".type " + <> ppr lab + <> text ", @function" + $$ ppr lab <> char ':' + $$ text "0:\taddis\t" <> pprReg toc + <> text ",12,.TOC.-0b@ha" + $$ text "\taddi\t" <> pprReg toc + <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" + $$ text "\t.localentry\t" <> ppr lab + <> text ",.-" <> ppr lab + +pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr + -> SDoc +pprBasicBlock config info_env (BasicBlock blockid instrs) + = maybe_infotable $$ + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) instrs) $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + else empty + ) + where + asmLbl = blockLbl blockid + platform = ncgPlatform config + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (CmmStaticsRaw info_lbl info) -> + pprAlignForSection platform Text $$ + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl + + + +pprDatas :: Platform -> RawCmmStatics -> SDoc +-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl alias + $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') +pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) + +pprData :: Platform -> CmmStatic -> SDoc +pprData platform d = case d of + CmmString str -> pprString str + CmmFileEmbed path -> pprFileEmbed path + CmmUninitialised bytes -> text ".space " <> int bytes + CmmStaticLit lit -> pprDataItem platform lit + +pprGloblDecl :: CLabel -> SDoc +pprGloblDecl lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = text ".globl " <> ppr lbl + +pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc +pprTypeAndSizeDecl platform lbl + = if platformOS platform == OSLinux && externallyVisibleCLabel lbl + then text ".type " <> + ppr lbl <> text ", @object" + else empty + +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = + pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (ppr lbl <> char ':') + +-- ----------------------------------------------------------------------------- +-- pprInstr: print an 'Instr' + +instance Outputable Instr where + ppr instr = sdocWithDynFlags $ \dflags -> + pprInstr (targetPlatform dflags) instr + + +pprReg :: Reg -> SDoc + +pprReg r + = case r of + RegReal (RealRegSingle i) -> ppr_reg_no i + RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u + RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + + where + ppr_reg_no :: Int -> SDoc + ppr_reg_no i + | i <= 31 = int i -- GPRs + | i <= 63 = int (i-32) -- FPRs + | otherwise = text "very naughty powerpc register" + + + +pprFormat :: Format -> SDoc +pprFormat x + = ptext (case x of + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "w" + II64 -> sLit "d" + FF32 -> sLit "fs" + FF64 -> sLit "fd") + + +pprCond :: Cond -> SDoc +pprCond c + = ptext (case c of { + ALWAYS -> sLit ""; + EQQ -> sLit "eq"; NE -> sLit "ne"; + LTT -> sLit "lt"; GE -> sLit "ge"; + GTT -> sLit "gt"; LE -> sLit "le"; + LU -> sLit "lt"; GEU -> sLit "ge"; + GU -> sLit "gt"; LEU -> sLit "le"; }) + + +pprImm :: Imm -> SDoc + +pprImm (ImmInt i) = int i +pprImm (ImmInteger i) = integer i +pprImm (ImmCLbl l) = ppr l +pprImm (ImmIndex l i) = ppr l <> char '+' <> int i +pprImm (ImmLit s) = s + +pprImm (ImmFloat _) = text "naughty float immediate" +pprImm (ImmDouble _) = text "naughty double immediate" + +pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b +pprImm (ImmConstantDiff a b) = pprImm a <> char '-' + <> lparen <> pprImm b <> rparen + +pprImm (LO (ImmInt i)) = pprImm (LO (ImmInteger (toInteger i))) +pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16)) + where + lo16 = fromInteger (i .&. 0xffff) :: Int16 + +pprImm (LO i) + = pprImm i <> text "@l" + +pprImm (HI i) + = pprImm i <> text "@h" + +pprImm (HA (ImmInt i)) = pprImm (HA (ImmInteger (toInteger i))) +pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16) + where + ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 + hi16 = (i `shiftR` 16) + lo16 = i .&. 0xffff + +pprImm (HA i) + = pprImm i <> text "@ha" + +pprImm (HIGHERA i) + = pprImm i <> text "@highera" + +pprImm (HIGHESTA i) + = pprImm i <> text "@highesta" + + +pprAddr :: AddrMode -> SDoc +pprAddr (AddrRegReg r1 r2) + = pprReg r1 <> char ',' <+> pprReg r2 +pprAddr (AddrRegImm r1 (ImmInt i)) + = hcat [ int i, char '(', pprReg r1, char ')' ] +pprAddr (AddrRegImm r1 (ImmInteger i)) + = hcat [ integer i, char '(', pprReg r1, char ')' ] +pprAddr (AddrRegImm r1 imm) + = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] + + +pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign config sec@(Section seg _) = + pprSectionHeader config sec $$ + pprAlignForSection (ncgPlatform config) seg + +-- | Print appropriate alignment for the given section type. +pprAlignForSection :: Platform -> SectionType -> SDoc +pprAlignForSection platform seg = + let ppc64 = not $ target32Bit platform + in ptext $ case seg of + Text -> sLit ".align 2" + Data + | ppc64 -> sLit ".align 3" + | otherwise -> sLit ".align 2" + ReadOnlyData + | ppc64 -> sLit ".align 3" + | otherwise -> sLit ".align 2" + RelocatableReadOnlyData + | ppc64 -> sLit ".align 3" + | otherwise -> sLit ".align 2" + UninitialisedData + | ppc64 -> sLit ".align 3" + | otherwise -> sLit ".align 2" + ReadOnlyData16 -> sLit ".align 4" + -- TODO: This is copied from the ReadOnlyData case, but it can likely be + -- made more efficient. + CString + | ppc64 -> sLit ".align 3" + | otherwise -> sLit ".align 2" + OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" + +pprDataItem :: Platform -> CmmLit -> SDoc +pprDataItem platform lit + = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + imm = litToImm lit + archPPC_64 = not $ target32Bit platform + + ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + ppr_item II64 _ + | archPPC_64 = [text "\t.quad\t" <> pprImm imm] + + ppr_item II64 (CmmInt x _) + | not archPPC_64 = + [text "\t.long\t" + <> int (fromIntegral + (fromIntegral (x `shiftR` 32) :: Word32)), + text "\t.long\t" + <> int (fromIntegral (fromIntegral x :: Word32))] + + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + + ppr_item _ _ + = panic "PPC.Ppr.pprDataItem: no match" + + +pprInstr :: Platform -> Instr -> SDoc +pprInstr platform instr = case instr of + + COMMENT _ + -> empty -- nuke 'em + + -- COMMENT s + -- -> if platformOS platform == OSLinux + -- then text "# " <> ftext s + -- else text "; " <> ftext s + + LOCATION file line col _name + -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col + + DELTA d + -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) + + NEWBLOCK _ + -> panic "PprMach.pprInstr: NEWBLOCK" + + LDATA _ _ + -> panic "PprMach.pprInstr: LDATA" + +{- + SPILL reg slot + -> hcat [ + text "\tSPILL", + char '\t', + pprReg reg, + comma, + text "SLOT" <> parens (int slot)] + + RELOAD slot reg + -> hcat [ + text "\tRELOAD", + char '\t', + text "SLOT" <> parens (int slot), + comma, + pprReg reg] +-} + + LD fmt reg addr + -> hcat [ + char '\t', + text "l", + ptext (case fmt of + II8 -> sLit "bz" + II16 -> sLit "hz" + II32 -> sLit "wz" + II64 -> sLit "d" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + LDFAR fmt reg (AddrRegImm source off) + -> vcat + [ pprInstr platform (ADDIS (tmpReg platform) source (HA off)) + , pprInstr platform (LD fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] + + LDFAR _ _ _ + -> panic "PPC.Ppr.pprInstr LDFAR: no match" + + LDR fmt reg1 addr + -> hcat [ + text "\tl", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC.Ppr.Instr LDR: no match", + text "arx\t", + pprReg reg1, + text ", ", + pprAddr addr + ] + + LA fmt reg addr + -> hcat [ + char '\t', + text "l", + ptext (case fmt of + II8 -> sLit "ba" + II16 -> sLit "ha" + II32 -> sLit "wa" + II64 -> sLit "d" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + ST fmt reg addr + -> hcat [ + char '\t', + text "st", + pprFormat fmt, + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + STFAR fmt reg (AddrRegImm source off) + -> vcat [ pprInstr platform (ADDIS (tmpReg platform) source (HA off)) + , pprInstr platform (ST fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] + + STFAR _ _ _ + -> panic "PPC.Ppr.pprInstr STFAR: no match" + + STU fmt reg addr + -> hcat [ + char '\t', + text "st", + pprFormat fmt, + char 'u', + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + STC fmt reg1 addr + -> hcat [ + text "\tst", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC.Ppr.Instr STC: no match", + text "cx.\t", + pprReg reg1, + text ", ", + pprAddr addr + ] + + LIS reg imm + -> hcat [ + char '\t', + text "lis", + char '\t', + pprReg reg, + text ", ", + pprImm imm + ] + + LI reg imm + -> hcat [ + char '\t', + text "li", + char '\t', + pprReg reg, + text ", ", + pprImm imm + ] + + MR reg1 reg2 + | reg1 == reg2 -> empty + | otherwise -> hcat [ + char '\t', + case targetClassOfReg platform reg1 of + RcInteger -> text "mr" + _ -> text "fmr", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + CMP fmt reg ri + -> hcat [ + char '\t', + op, + char '\t', + pprReg reg, + text ", ", + pprRI ri + ] + where + op = hcat [ + text "cmp", + pprFormat fmt, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] + + CMPL fmt reg ri + -> hcat [ + char '\t', + op, + char '\t', + pprReg reg, + text ", ", + pprRI ri + ] + where + op = hcat [ + text "cmpl", + pprFormat fmt, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] + + BCC cond blockid prediction + -> hcat [ + char '\t', + text "b", + pprCond cond, + pprPrediction prediction, + char '\t', + ppr lbl + ] + where lbl = mkLocalBlockLabel (getUnique blockid) + pprPrediction p = case p of + Nothing -> empty + Just True -> char '+' + Just False -> char '-' + + BCCFAR cond blockid prediction + -> vcat [ + hcat [ + text "\tb", + pprCond (condNegate cond), + neg_prediction, + text "\t$+8" + ], + hcat [ + text "\tb\t", + ppr lbl + ] + ] + where lbl = mkLocalBlockLabel (getUnique blockid) + neg_prediction = case prediction of + Nothing -> empty + Just True -> char '-' + Just False -> char '+' + + JMP lbl _ + -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL" + | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel" + | otherwise -> + hcat [ -- an alias for b that takes a CLabel + char '\t', + text "b", + char '\t', + ppr lbl + ] + + MTCTR reg + -> hcat [ + char '\t', + text "mtctr", + char '\t', + pprReg reg + ] + + BCTR _ _ _ + -> hcat [ + char '\t', + text "bctr" + ] + + BL lbl _ + -> case platformOS platform of + OSAIX -> + -- On AIX, "printf" denotes a function-descriptor (for use + -- by function pointers), whereas the actual entry-code + -- address is denoted by the dot-prefixed ".printf" label. + -- Moreover, the PPC NCG only ever emits a BL instruction + -- for calling C ABI functions. Most of the time these calls + -- originate from FFI imports and have a 'ForeignLabel', + -- but when profiling the codegen inserts calls via + -- 'emitRtsCallGen' which are 'CmmLabel's even though + -- they'd technically be more like 'ForeignLabel's. + hcat [ + text "\tbl\t.", + ppr lbl + ] + _ -> + hcat [ + text "\tbl\t", + ppr lbl + ] + + BCTRL _ + -> hcat [ + char '\t', + text "bctrl" + ] + + ADD reg1 reg2 ri + -> pprLogic (sLit "add") reg1 reg2 ri + + ADDIS reg1 reg2 imm + -> hcat [ + char '\t', + text "addis", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] + + ADDO reg1 reg2 reg3 + -> pprLogic (sLit "addo") reg1 reg2 (RIReg reg3) + + ADDC reg1 reg2 reg3 + -> pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) + + ADDE reg1 reg2 reg3 + -> pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) + + ADDZE reg1 reg2 + -> pprUnary (sLit "addze") reg1 reg2 + + SUBF reg1 reg2 reg3 + -> pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) + + SUBFO reg1 reg2 reg3 + -> pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3) + + SUBFC reg1 reg2 ri + -> hcat [ + char '\t', + text "subf", + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + text "c\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprRI ri + ] + + SUBFE reg1 reg2 reg3 + -> pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) + + MULL fmt reg1 reg2 ri + -> pprMul fmt reg1 reg2 ri + + MULLO fmt reg1 reg2 reg3 + -> hcat [ + char '\t', + text "mull", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "o\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + + MFOV fmt reg + -> vcat [ + hcat [ + char '\t', + text "mfxer", + char '\t', + pprReg reg + ], + hcat [ + char '\t', + text "extr", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "i\t", + pprReg reg, + text ", ", + pprReg reg, + text ", 1, ", + case fmt of + II32 -> text "1" + II64 -> text "33" + _ -> panic "PPC: illegal format" + ] + ] + + MULHU fmt reg1 reg2 reg3 + -> hcat [ + char '\t', + text "mulh", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "u\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + + DIV fmt sgn reg1 reg2 reg3 + -> pprDiv fmt sgn reg1 reg2 reg3 + + -- for some reason, "andi" doesn't exist. + -- we'll use "andi." instead. + AND reg1 reg2 (RIImm imm) + -> hcat [ + char '\t', + text "andi.", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] + + AND reg1 reg2 ri + -> pprLogic (sLit "and") reg1 reg2 ri + + ANDC reg1 reg2 reg3 + -> pprLogic (sLit "andc") reg1 reg2 (RIReg reg3) + + NAND reg1 reg2 reg3 + -> pprLogic (sLit "nand") reg1 reg2 (RIReg reg3) + + OR reg1 reg2 ri + -> pprLogic (sLit "or") reg1 reg2 ri + + XOR reg1 reg2 ri + -> pprLogic (sLit "xor") reg1 reg2 ri + + ORIS reg1 reg2 imm + -> hcat [ + char '\t', + text "oris", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] + + XORIS reg1 reg2 imm + -> hcat [ + char '\t', + text "xoris", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] + + EXTS fmt reg1 reg2 + -> hcat [ + char '\t', + text "exts", + pprFormat fmt, + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + CNTLZ fmt reg1 reg2 + -> hcat [ + char '\t', + text "cntlz", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + NEG reg1 reg2 + -> pprUnary (sLit "neg") reg1 reg2 + + NOT reg1 reg2 + -> pprUnary (sLit "not") reg1 reg2 + + SR II32 reg1 reg2 (RIImm (ImmInt i)) + -- Handle the case where we are asked to shift a 32 bit register by + -- less than zero or more than 31 bits. We convert this into a clear + -- of the destination register. + -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900 + | i < 0 || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2)) + + SL II32 reg1 reg2 (RIImm (ImmInt i)) + -- As above for SR, but for left shifts. + -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870 + | i < 0 || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2)) + + SRA II32 reg1 reg2 (RIImm (ImmInt i)) + -- PT: I don't know what to do for negative shift amounts: + -- For now just panic. + -- + -- For shift amounts greater than 31 set all bit to the + -- value of the sign bit, this also what sraw does. + | i > 31 -> pprInstr platform (SRA II32 reg1 reg2 (RIImm (ImmInt 31))) + + SL fmt reg1 reg2 ri + -> let op = case fmt of + II32 -> "slw" + II64 -> "sld" + _ -> panic "PPC.Ppr.pprInstr: shift illegal size" + in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + + SR fmt reg1 reg2 ri + -> let op = case fmt of + II32 -> "srw" + II64 -> "srd" + _ -> panic "PPC.Ppr.pprInstr: shift illegal size" + in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + + SRA fmt reg1 reg2 ri + -> let op = case fmt of + II32 -> "sraw" + II64 -> "srad" + _ -> panic "PPC.Ppr.pprInstr: shift illegal size" + in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + + RLWINM reg1 reg2 sh mb me + -> hcat [ + text "\trlwinm\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int sh, + text ", ", + int mb, + text ", ", + int me + ] + + CLRLI fmt reg1 reg2 n + -> hcat [ + text "\tclrl", + pprFormat fmt, + text "i ", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int n + ] + + CLRRI fmt reg1 reg2 n + -> hcat [ + text "\tclrr", + pprFormat fmt, + text "i ", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int n + ] + + FADD fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3 + + FSUB fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3 + + FMUL fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3 + + FDIV fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3 + + FABS reg1 reg2 + -> pprUnary (sLit "fabs") reg1 reg2 + + FNEG reg1 reg2 + -> pprUnary (sLit "fneg") reg1 reg2 + + FCMP reg1 reg2 + -> hcat [ + char '\t', + text "fcmpu\t0, ", + -- Note: we're using fcmpu, not fcmpo + -- The difference is with fcmpo, compare with NaN is an invalid operation. + -- We don't handle invalid fp ops, so we don't care. + -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for + -- better portability since some non-GNU assembler (such as + -- IBM's `as`) tend not to support the symbolic register name cr0. + -- This matches the syntax that GCC seems to emit for PPC targets. + pprReg reg1, + text ", ", + pprReg reg2 + ] + + FCTIWZ reg1 reg2 + -> pprUnary (sLit "fctiwz") reg1 reg2 + + FCTIDZ reg1 reg2 + -> pprUnary (sLit "fctidz") reg1 reg2 + + FCFID reg1 reg2 + -> pprUnary (sLit "fcfid") reg1 reg2 + + FRSP reg1 reg2 + -> pprUnary (sLit "frsp") reg1 reg2 + + CRNOR dst src1 src2 + -> hcat [ + text "\tcrnor\t", + int dst, + text ", ", + int src1, + text ", ", + int src2 + ] + + MFCR reg + -> hcat [ + char '\t', + text "mfcr", + char '\t', + pprReg reg + ] + + MFLR reg + -> hcat [ + char '\t', + text "mflr", + char '\t', + pprReg reg + ] + + FETCHPC reg + -> vcat [ + text "\tbcl\t20,31,1f", + hcat [ text "1:\tmflr\t", pprReg reg ] + ] + + HWSYNC + -> text "\tsync" + + ISYNC + -> text "\tisync" + + LWSYNC + -> text "\tlwsync" + + NOP + -> text "\tnop" + +pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc +pprLogic op reg1 reg2 ri = hcat [ + char '\t', + ptext op, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprRI ri + ] + + +pprMul :: Format -> Reg -> Reg -> RI -> SDoc +pprMul fmt reg1 reg2 ri = hcat [ + char '\t', + text "mull", + case ri of + RIReg _ -> case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format" + RIImm _ -> char 'i', + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprRI ri + ] + + +pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc +pprDiv fmt sgn reg1 reg2 reg3 = hcat [ + char '\t', + text "div", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + if sgn then empty else char 'u', + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + + +pprUnary :: PtrString -> Reg -> Reg -> SDoc +pprUnary op reg1 reg2 = hcat [ + char '\t', + ptext op, + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + +pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc +pprBinaryF op fmt reg1 reg2 reg3 = hcat [ + char '\t', + ptext op, + pprFFormat fmt, + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + +pprRI :: RI -> SDoc +pprRI (RIReg r) = pprReg r +pprRI (RIImm r) = pprImm r + + +pprFFormat :: Format -> SDoc +pprFFormat FF64 = empty +pprFFormat FF32 = char 's' +pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match" + + -- limit immediate argument for shift instruction to range 0..63 + -- for 64 bit size and 0..32 otherwise +limitShiftRI :: Format -> RI -> RI +limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 = + panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." +limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 = + panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed." +limitShiftRI _ x = x diff --git a/GHC/CmmToAsm/PPC/RegInfo.hs b/GHC/CmmToAsm/PPC/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/RegInfo.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Machine-specific parts of the register allocator +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- +module GHC.CmmToAsm.PPC.RegInfo ( + JumpDest( DestBlockId ), getJumpDestBlockId, + canShortcut, + shortcutJump, + + shortcutStatics +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.CmmToAsm.PPC.Instr + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.CLabel + +import GHC.Types.Unique +import GHC.Utils.Outputable (ppr, text, Outputable, (<>)) + +data JumpDest = DestBlockId BlockId + +-- Debug Instance +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other + + +-- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics fn (CmmStaticsRaw lbl statics) + = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) + -- slightly dodgy, we're ignoring the second label, but this + -- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> BlockId + -> CLabel + +shortBlockId fn blockid = + case fn blockid of + Nothing -> mkLocalBlockLabel uq + Just (DestBlockId blockid') -> shortBlockId fn blockid' + where uq = getUnique blockid diff --git a/GHC/CmmToAsm/PPC/Regs.hs b/GHC/CmmToAsm/PPC/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/PPC/Regs.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE CPP #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1994-2004 +-- +-- ----------------------------------------------------------------------------- + +module GHC.CmmToAsm.PPC.Regs ( + -- squeeze functions + virtualRegSqueeze, + realRegSqueeze, + + mkVirtualReg, + regDotColor, + + -- immediates + Imm(..), + strImmLit, + litToImm, + + -- addressing modes + AddrMode(..), + addrOffset, + + -- registers + spRel, + argRegs, + allArgRegs, + callClobberedRegs, + allMachRegNos, + classOfRealReg, + showReg, + toRegNo, + + -- machine specific + allFPArgRegs, + fits16Bits, + makeImmediate, + fReg, + r0, sp, toc, r3, r4, r11, r12, r30, + tmpReg, + f1, + + allocatableRegs + +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.CmmToAsm.Format + +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Types.Unique + +import GHC.Platform.Regs +import GHC.Utils.Outputable +import GHC.Platform + +import Data.Word ( Word8, Word16, Word32, Word64 ) +import Data.Int ( Int8, Int16, Int32, Int64 ) + + +-- squeese functions for the graph allocator ----------------------------------- + +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 + + RcDouble + -> case vr of + VirtualRegD{} -> 1 + VirtualRegF{} -> 0 + _other -> 0 + + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 1 -- first fp reg is 32 + | otherwise -> 0 + + RealRegPair{} -> 0 + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 0 + | otherwise -> 1 + + RealRegPair{} -> 0 + + _other -> 0 + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) = VirtualRegI u + | otherwise + = case format of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "mkVirtualReg" + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + RcDouble -> text "green" + + + +-- immediates ------------------------------------------------------------------ +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit SDoc -- Simple string + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + | LO Imm + | HI Imm + | HA Imm {- high halfword adjusted -} + | HIGHERA Imm + | HIGHESTA Imm + + +strImmLit :: String -> Imm +strImmLit s = ImmLit (text s) + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "PPC.Regs.litToImm: no match" + + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm + + +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + AddrRegImm r (ImmInt n) + | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2)) + | otherwise -> Nothing + where n2 = n + off + + AddrRegImm r (ImmInteger n) + | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) + | otherwise -> Nothing + where n2 = n + toInteger off + + _ -> Nothing + + +-- registers ------------------------------------------------------------------- +-- @spRel@ gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. @fpRel@, where +-- applicable, is the same but for the frame pointer. + +spRel :: Platform + -> Int -- desired stack offset in words, positive or negative + -> AddrMode + +spRel platform n = AddrRegImm sp (ImmInt (n * platformWordSizeInBytes platform)) + + +-- argRegs is the set of regs which are read for an n-argument call to C. +-- For archs which pass all args on the stack (x86), is empty. +-- Sparc passes up to the first 6 args in regs. +argRegs :: RegNo -> [Reg] +argRegs 0 = [] +argRegs 1 = map regSingle [3] +argRegs 2 = map regSingle [3,4] +argRegs 3 = map regSingle [3..5] +argRegs 4 = map regSingle [3..6] +argRegs 5 = map regSingle [3..7] +argRegs 6 = map regSingle [3..8] +argRegs 7 = map regSingle [3..9] +argRegs 8 = map regSingle [3..10] +argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!" + + +allArgRegs :: [Reg] +allArgRegs = map regSingle [3..10] + + +-- these are the regs which we cannot assume stay alive over a C call. +callClobberedRegs :: Platform -> [Reg] +callClobberedRegs _platform + = map regSingle (0:[2..12] ++ map fReg [0..13]) + + +allMachRegNos :: [RegNo] +allMachRegNos = [0..63] + + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < 32 = RcInteger + | otherwise = RcDouble + +classOfRealReg (RealRegPair{}) + = panic "regClass(ppr): no reg pairs on this architecture" + +showReg :: RegNo -> String +showReg n + | n >= 0 && n <= 31 = "%r" ++ show n + | n >= 32 && n <= 63 = "%f" ++ show (n - 32) + | otherwise = "%unknown_powerpc_real_reg_" ++ show n + +toRegNo :: Reg -> RegNo +toRegNo (RegReal (RealRegSingle n)) = n +toRegNo _ = panic "PPC.toRegNo: unsupported register" + +-- machine specific ------------------------------------------------------------ + +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + = case platformOS platform of + OSAIX -> map (regSingle . fReg) [1..13] + _ -> case platformArch platform of + ArchPPC -> map (regSingle . fReg) [1..8] + ArchPPC_64 _ -> map (regSingle . fReg) [1..13] + _ -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux" + +fits16Bits :: Integral a => a -> Bool +fits16Bits x = x >= -32768 && x < 32768 + +makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm +makeImmediate rep signed x = fmap ImmInt (toI16 rep signed) + where + narrow W64 False = fromIntegral (fromIntegral x :: Word64) + narrow W32 False = fromIntegral (fromIntegral x :: Word32) + narrow W16 False = fromIntegral (fromIntegral x :: Word16) + narrow W8 False = fromIntegral (fromIntegral x :: Word8) + narrow W64 True = fromIntegral (fromIntegral x :: Int64) + narrow W32 True = fromIntegral (fromIntegral x :: Int32) + narrow W16 True = fromIntegral (fromIntegral x :: Int16) + narrow W8 True = fromIntegral (fromIntegral x :: Int8) + narrow _ _ = panic "PPC.Regs.narrow: no match" + + narrowed = narrow rep signed + + toI16 W32 True + | narrowed >= -32768 && narrowed < 32768 = Just narrowed + | otherwise = Nothing + toI16 W32 False + | narrowed >= 0 && narrowed < 65536 = Just narrowed + | otherwise = Nothing + toI16 W64 True + | narrowed >= -32768 && narrowed < 32768 = Just narrowed + | otherwise = Nothing + toI16 W64 False + | narrowed >= 0 && narrowed < 65536 = Just narrowed + | otherwise = Nothing + toI16 _ _ = Just narrowed + + +{- +The PowerPC has 64 registers of interest; 32 integer registers and 32 floating +point registers. +-} + +fReg :: Int -> RegNo +fReg x = (32 + x) + +r0, sp, toc, r3, r4, r11, r12, r30, f1 :: Reg +r0 = regSingle 0 +sp = regSingle 1 +toc = regSingle 2 +r3 = regSingle 3 +r4 = regSingle 4 +r11 = regSingle 11 +r12 = regSingle 12 +r30 = regSingle 30 +f1 = regSingle $ fReg 1 + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = freeReg platform i + in map RealRegSingle $ filter isFree allMachRegNos + +-- temporary register for compiler use +tmpReg :: Platform -> Reg +tmpReg platform = + case platformArch platform of + ArchPPC -> regSingle 13 + ArchPPC_64 _ -> regSingle 30 + _ -> panic "PPC.Regs.tmpReg: unknown arch" diff --git a/GHC/CmmToAsm/Ppr.hs b/GHC/CmmToAsm/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Ppr.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.Ppr ( + castFloatToWord8Array, + castDoubleToWord8Array, + floatToBytes, + doubleToBytes, + pprASCII, + pprString, + pprFileEmbed, + pprSectionHeader +) + +where + +import GHC.Prelude + +import GHC.Utils.Asm +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.CmmToAsm.Config +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Platform + +import qualified Data.Array.Unsafe as U ( castSTUArray ) +import Data.Array.ST + +import Control.Monad.ST + +import Data.Word +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import GHC.Exts +import GHC.Word + + + +-- ----------------------------------------------------------------------------- +-- Converting floating-point literals to integrals for printing + +castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) +castFloatToWord8Array = U.castSTUArray + +castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) +castDoubleToWord8Array = U.castSTUArray + +-- floatToBytes and doubleToBytes convert to the host's byte +-- order. Providing that we're not cross-compiling for a +-- target with the opposite endianness, this should work ok +-- on all targets. + +-- ToDo: this stuff is very similar to the shenanigans in PprAbs, +-- could they be merged? + +floatToBytes :: Float -> [Int] +floatToBytes f + = runST (do + arr <- newArray_ ((0::Int),3) + writeArray arr 0 f + arr <- castFloatToWord8Array arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + return (map fromIntegral [i0,i1,i2,i3]) + ) + +doubleToBytes :: Double -> [Int] +doubleToBytes d + = runST (do + arr <- newArray_ ((0::Int),7) + writeArray arr 0 d + arr <- castDoubleToWord8Array arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + i4 <- readArray arr 4 + i5 <- readArray arr 5 + i6 <- readArray arr 6 + i7 <- readArray arr 7 + return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7]) + ) + +-- --------------------------------------------------------------------------- +-- Printing ASCII strings. +-- +-- Print as a string and escape non-printable characters. +-- This is similar to charToC in GHC.Utils.Misc + +pprASCII :: ByteString -> SDoc +pprASCII str + -- Transform this given literal bytestring to escaped string and construct + -- the literal SDoc directly. + -- See #14741 + -- and Note [Pretty print ASCII when AsmCodeGen] + = text $ BS.foldr (\w s -> do1 w ++ s) "" str + where + do1 :: Word8 -> String + do1 w | 0x09 == w = "\\t" + | 0x0A == w = "\\n" + | 0x22 == w = "\\\"" + | 0x5C == w = "\\\\" + -- ASCII printable characters range + | w >= 0x20 && w <= 0x7E = [chr' w] + | otherwise = '\\' : octal w + + -- we know that the Chars we create are in the ASCII range + -- so we bypass the check in "chr" + chr' :: Word8 -> Char + chr' (W8# w#) = C# (chr# (word2Int# w#)) + + octal :: Word8 -> String + octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07) + , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07) + , chr' (ord0 + w .&. 0x07) + ] + ord0 = 0x30 -- = ord '0' + +-- | Emit a ".string" directive +pprString :: ByteString -> SDoc +pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs) + +-- | Emit a ".incbin" directive +-- +-- A NULL byte is added after the binary data. +pprFileEmbed :: FilePath -> SDoc +pprFileEmbed path + = text "\t.incbin " + <> pprFilePathString path -- proper escape (see #16389) + <> text "\n\t.byte 0" + +{- +Note [Embedding large binary blobs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To embed a blob of binary data (e.g. an UTF-8 encoded string) into the generated +code object, we have several options: + + 1. Generate a ".byte" directive for each byte. This is what was done in the past + (see Note [Pretty print ASCII when AsmCodeGen]). + + 2. Generate a single ".string"/".asciz" directive for the whole sequence of + bytes. Bytes in the ASCII printable range are rendered as characters and + other values are escaped (e.g., "\t", "\077", etc.). + + 3. Create a temporary file into which we dump the binary data and generate a + single ".incbin" directive. The assembler will include the binary file for + us in the generated output object. + +Now the code generator uses either (2) or (3), depending on the binary blob +size. Using (3) for small blobs adds too much overhead (see benchmark results +in #16190), so we only do it when the size is above a threshold (500K at the +time of writing). + +The threshold is configurable via the `-fbinary-blob-threshold` flag. + +-} + + +{- +Note [Pretty print ASCII when AsmCodeGen] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, when generating assembly code, we created SDoc with +`(ptext . sLit)` for every bytes in literal bytestring, then +combine them using `hcat`. + +When handling literal bytestrings with millions of bytes, +millions of SDoc would be created and to combine, leading to +high memory usage. + +Now we escape the given bytestring to string directly and construct +SDoc only once. This improvement could dramatically decrease the +memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal +string in source code. See #14741 for profiling results. +-} + +-- ---------------------------------------------------------------------------- +-- Printing section headers. +-- +-- If -split-section was specified, include the suffix label, otherwise just +-- print the section type. For Darwin, where subsections-for-symbols are +-- used instead, only print section type. +-- +-- For string literals, additional flags are specified to enable merging of +-- identical strings in the linker. With -split-sections each string also gets +-- a unique section to allow strings from unused code to be GC'd. + +pprSectionHeader :: NCGConfig -> Section -> SDoc +pprSectionHeader config (Section t suffix) = + case platformOS (ncgPlatform config) of + OSAIX -> pprXcoffSectionHeader t + OSDarwin -> pprDarwinSectionHeader t + OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix + _ -> pprGNUSectionHeader config (char '.') t suffix + +pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc +pprGNUSectionHeader config sep t suffix = + text ".section " <> ptext header <> subsection <> flags + where + platform = ncgPlatform config + splitSections = ncgSplitSections config + subsection + | splitSections = sep <> ppr suffix + | otherwise = empty + header = case t of + Text -> sLit ".text" + Data -> sLit ".data" + ReadOnlyData | OSMinGW32 <- platformOS platform + -> sLit ".rdata" + | otherwise -> sLit ".rodata" + RelocatableReadOnlyData | OSMinGW32 <- platformOS platform + -- Concept does not exist on Windows, + -- So map these to R/O data. + -> sLit ".rdata$rel.ro" + | otherwise -> sLit ".data.rel.ro" + UninitialisedData -> sLit ".bss" + ReadOnlyData16 | OSMinGW32 <- platformOS platform + -> sLit ".rdata$cst16" + | otherwise -> sLit ".rodata.cst16" + CString + | OSMinGW32 <- platformOS platform + -> sLit ".rdata" + | otherwise -> sLit ".rodata.str" + OtherSection _ -> + panic "PprBase.pprGNUSectionHeader: unknown section type" + flags = case t of + CString + | OSMinGW32 <- platformOS platform + -> empty + | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" + _ -> empty + +-- XCOFF doesn't support relocating label-differences, so we place all +-- RO sections into .text[PR] sections +pprXcoffSectionHeader :: SectionType -> SDoc +pprXcoffSectionHeader t = text $ case t of + Text -> ".csect .text[PR]" + Data -> ".csect .data[RW]" + ReadOnlyData -> ".csect .text[PR] # ReadOnlyData" + RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData" + ReadOnlyData16 -> ".csect .text[PR] # ReadOnlyData16" + CString -> ".csect .text[PR] # CString" + UninitialisedData -> ".csect .data[BS]" + OtherSection _ -> + panic "PprBase.pprXcoffSectionHeader: unknown section type" + +pprDarwinSectionHeader :: SectionType -> SDoc +pprDarwinSectionHeader t = + ptext $ case t of + Text -> sLit ".text" + Data -> sLit ".data" + ReadOnlyData -> sLit ".const" + RelocatableReadOnlyData -> sLit ".const_data" + UninitialisedData -> sLit ".data" + ReadOnlyData16 -> sLit ".const" + CString -> sLit ".section\t__TEXT,__cstring,cstring_literals" + OtherSection _ -> + panic "PprBase.pprDarwinSectionHeader: unknown section type" diff --git a/GHC/CmmToAsm/Reg/Graph.hs b/GHC/CmmToAsm/Reg/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Graph coloring register allocator. +module GHC.CmmToAsm.Reg.Graph ( + regAlloc +) where +import GHC.Prelude + +import qualified GHC.Data.Graph.Color as Color +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Graph.Spill +import GHC.CmmToAsm.Reg.Graph.SpillClean +import GHC.CmmToAsm.Reg.Graph.SpillCost +import GHC.CmmToAsm.Reg.Graph.Stats +import GHC.CmmToAsm.Reg.Graph.TrivColorable +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply +import GHC.Utils.Misc (seqList) +import GHC.CmmToAsm.CFG + +import Data.Maybe +import Control.Monad + + +-- | The maximum number of build\/spill cycles we'll allow. +-- +-- It should only take 3 or 4 cycles for the allocator to converge. +-- If it takes any longer than this it's probably in an infinite loop, +-- so it's better just to bail out and report a bug. +maxSpinCount :: Int +maxSpinCount = 10 + + +-- | The top level of the graph coloring register allocator. +regAlloc + :: (Outputable statics, Outputable instr, Instruction instr) + => NCGConfig + -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation + -> UniqSet Int -- ^ set of available spill slots. + -> Int -- ^ current number of spill slots + -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. + -> Maybe CFG -- ^ CFG of basic blocks if available + -> UniqSM ( [NatCmmDecl statics instr] + , Maybe Int, [RegAllocStats statics instr] ) + -- ^ code with registers allocated, additional stacks required + -- and stats for each stage of allocation + +regAlloc config regsFree slotsFree slotsCount code cfg + = do + let platform = ncgPlatform config + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) + + (code_final, debug_codeGraphs, slotsCount', _) + <- regAlloc_spin config 0 + triv + regsFree slotsFree slotsCount [] code cfg + + let needStack + | slotsCount == slotsCount' + = Nothing + | otherwise + = Just slotsCount' + + return ( code_final + , needStack + , reverse debug_codeGraphs ) + + +-- | Perform solver iterations for the graph coloring allocator. +-- +-- We extract a register conflict graph from the provided cmm code, +-- and try to colour it. If that works then we use the solution rewrite +-- the code with real hregs. If coloring doesn't work we add spill code +-- and try to colour it again. After `maxSpinCount` iterations we give up. +-- +regAlloc_spin + :: forall instr statics. + (Instruction instr, + Outputable instr, + Outputable statics) + => NCGConfig + -> Int -- ^ Number of solver iterations we've already performed. + -> Color.Triv VirtualReg RegClass RealReg + -- ^ Function for calculating whether a register is trivially + -- colourable. + -> UniqFM RegClass (UniqSet RealReg) -- ^ Free registers that we can allocate. + -> UniqSet Int -- ^ Free stack slots that we can use. + -> Int -- ^ Number of spill slots in use + -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to. + -> [LiveCmmDecl statics instr] -- ^ Liveness annotated code to allocate. + -> Maybe CFG + -> UniqSM ( [NatCmmDecl statics instr] + , [RegAllocStats statics instr] + , Int -- Slots in use + , Color.Graph VirtualReg RegClass RealReg) + +regAlloc_spin config spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg + = do + let platform = ncgPlatform config + + -- If any of these dump flags are turned on we want to hang on to + -- intermediate structures in the allocator - otherwise tell the + -- allocator to ditch them early so we don't end up creating space leaks. + let dump = or + [ ncgDumpRegAllocStages config + , ncgDumpAsmStats config + , ncgDumpAsmConflicts config + ] + + -- Check that we're not running off down the garden path. + when (spinCount > maxSpinCount) + $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." + ( text "It looks like the register allocator is stuck in an infinite loop." + $$ text "max cycles = " <> int maxSpinCount + $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr + $ nonDetEltsUniqSet $ unionManyUniqSets + $ nonDetEltsUFM regsFree) + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) + + -- Build the register conflict graph from the cmm code. + (graph :: Color.Graph VirtualReg RegClass RealReg) + <- {-# SCC "BuildGraph" #-} buildGraph code + + -- VERY IMPORTANT: + -- We really do want the graph to be fully evaluated _before_ we + -- start coloring. If we don't do this now then when the call to + -- Color.colorGraph forces bits of it, the heap will be filled with + -- half evaluated pieces of graph and zillions of apply thunks. + seqGraph graph `seq` return () + + -- Build a map of the cost of spilling each instruction. + -- This is a lazy binding, so the map will only be computed if we + -- actually have to spill to the stack. + let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo + $ map (slurpSpillCostInfo platform cfg) code + + -- The function to choose regs to leave uncolored. + let spill = chooseSpill spillCosts + + -- Record startup state in our log. + let stat1 + = if spinCount == 0 + then Just $ RegAllocStatsStart + { raLiveCmm = code + , raGraph = graph + , raSpillCosts = spillCosts + , raPlatform = platform + } + else Nothing + + -- Try and color the graph. + let (graph_colored, rsSpill, rmCoalesce) + = {-# SCC "ColorGraph" #-} + Color.colorGraph + (ncgRegsIterative config) + spinCount + regsFree triv spill graph + + -- Rewrite registers in the code that have been coalesced. + let patchF reg + | RegVirtual vr <- reg + = case lookupUFM rmCoalesce vr of + Just vr' -> patchF (RegVirtual vr') + Nothing -> reg + + | otherwise + = reg + + let (code_coalesced :: [LiveCmmDecl statics instr]) + = map (patchEraseLive patchF) code + + -- Check whether we've found a coloring. + if isEmptyUniqSet rsSpill + + -- Coloring was successful because no registers needed to be spilled. + then do + -- if -fasm-lint is turned on then validate the graph. + -- This checks for bugs in the graph allocator itself. + let graph_colored_lint = + if ncgAsmLinting config + then Color.validateGraph (text "") + True -- Require all nodes to be colored. + graph_colored + else graph_colored + + -- Rewrite the code to use real hregs, using the colored graph. + let code_patched + = map (patchRegsFromGraph platform graph_colored_lint) + code_coalesced + + -- Clean out unneeded SPILL/RELOAD meta instructions. + -- The spill code generator just spills the entire live range + -- of a vreg, but it might not need to be on the stack for + -- its entire lifetime. + let code_spillclean + = map (cleanSpills platform) code_patched + + -- Strip off liveness information from the allocated code. + -- Also rewrite SPILL/RELOAD meta instructions into real machine + -- instructions along the way + let code_final + = map (stripLive config) code_spillclean + + -- Record what happened in this stage for debugging + let stat + = RegAllocStatsColored + { raCode = code + , raGraph = graph + , raGraphColored = graph_colored_lint + , raCoalesced = rmCoalesce + , raCodeCoalesced = code_coalesced + , raPatched = code_patched + , raSpillClean = code_spillclean + , raFinal = code_final + , raSRMs = foldl' addSRM (0, 0, 0) + $ map countSRMs code_spillclean + , raPlatform = platform + } + + -- Bundle up all the register allocator statistics. + -- .. but make sure to drop them on the floor if they're not + -- needed, otherwise we'll get a space leak. + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- Ensure all the statistics are evaluated, to avoid space leaks. + seqList statList (return ()) + + return ( code_final + , statList + , slotsCount + , graph_colored_lint) + + -- Coloring was unsuccessful. We need to spill some register to the + -- stack, make a new graph, and try to color it again. + else do + -- if -fasm-lint is turned on then validate the graph + let graph_colored_lint = + if ncgAsmLinting config + then Color.validateGraph (text "") + False -- don't require nodes to be colored + graph_colored + else graph_colored + + -- Spill uncolored regs to the stack. + (code_spilled, slotsFree', slotsCount', spillStats) + <- regSpill platform code_coalesced slotsFree slotsCount rsSpill + + -- Recalculate liveness information. + -- NOTE: we have to reverse the SCCs here to get them back into + -- the reverse-dependency order required by computeLiveness. + -- If they're not in the correct order that function will panic. + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) + code_spilled + + -- Record what happened in this stage for debugging. + let stat = + RegAllocStatsSpill + { raCode = code + , raGraph = graph_colored_lint + , raCoalesced = rmCoalesce + , raSpillStats = spillStats + , raSpillCosts = spillCosts + , raSpilled = code_spilled + , raPlatform = platform } + + -- Bundle up all the register allocator statistics. + -- .. but make sure to drop them on the floor if they're not + -- needed, otherwise we'll get a space leak. + let statList = + if dump + then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- Ensure all the statistics are evaluated, to avoid space leaks. + seqList statList (return ()) + + regAlloc_spin config (spinCount + 1) triv regsFree slotsFree' + slotsCount' statList code_relive cfg + + +-- | Build a graph from the liveness and coalesce information in this code. +buildGraph + :: Instruction instr + => [LiveCmmDecl statics instr] + -> UniqSM (Color.Graph VirtualReg RegClass RealReg) + +buildGraph code + = do + -- Slurp out the conflicts and reg->reg moves from this code. + let (conflictList, moveList) = + unzip $ map slurpConflicts code + + -- Slurp out the spill/reload coalesces. + let moveList2 = map slurpReloadCoalesce code + + -- Add the reg-reg conflicts to the graph. + let conflictBag = unionManyBags conflictList + let graph_conflict + = foldr graphAddConflictSet Color.initGraph conflictBag + + -- Add the coalescences edges to the graph. + let moveBag + = unionBags (unionManyBags moveList2) + (unionManyBags moveList) + + let graph_coalesce + = foldr graphAddCoalesce graph_conflict moveBag + + return graph_coalesce + + +-- | Add some conflict edges to the graph. +-- Conflicts between virtual and real regs are recorded as exclusions. +graphAddConflictSet + :: UniqSet Reg + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + +graphAddConflictSet set graph + = let virtuals = mkUniqSet + [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] + + graph1 = Color.addConflicts virtuals classOfVirtualReg graph + + graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) + graph1 + [ (vr, rr) + | RegVirtual vr <- nonDetEltsUniqSet set + , RegReal rr <- nonDetEltsUniqSet set] + -- See Note [Unique Determinism and code generation] + + in graph2 + + +-- | Add some coalesence edges to the graph +-- Coalesences between virtual and real regs are recorded as preferences. +graphAddCoalesce + :: (Reg, Reg) + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + +graphAddCoalesce (r1, r2) graph + | RegReal rr <- r1 + , RegVirtual vr <- r2 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph + + | RegReal rr <- r2 + , RegVirtual vr <- r1 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph + + | RegVirtual vr1 <- r1 + , RegVirtual vr2 <- r2 + = Color.addCoalesce + (vr1, classOfVirtualReg vr1) + (vr2, classOfVirtualReg vr2) + graph + + -- We can't coalesce two real regs, but there could well be existing + -- hreg,hreg moves in the input code. We'll just ignore these + -- for coalescing purposes. + | RegReal _ <- r1 + , RegReal _ <- r2 + = graph + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise + = panic "graphAddCoalesce" +#endif + + +-- | Patch registers in code using the reg -> reg mapping in this graph. +patchRegsFromGraph + :: (Outputable statics, Outputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +patchRegsFromGraph platform graph code + = patchEraseLive patchF code + where + -- Function to lookup the hardreg for a virtual reg from the graph. + patchF reg + -- leave real regs alone. + | RegReal{} <- reg + = reg + + -- this virtual has a regular node in the graph. + | RegVirtual vr <- reg + , Just node <- Color.lookupNode graph vr + = case Color.nodeColor node of + Just color -> RegReal color + Nothing -> RegVirtual vr + + -- no node in the graph for this virtual, bad news. + | otherwise + = pprPanic "patchRegsFromGraph: register mapping failed." + ( text "There is no node in the graph for register " + <> ppr reg + $$ ppr code + $$ Color.dotGraph + (\_ -> text "white") + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + graph) + + +----- +-- for when laziness just isn't what you wanted... +-- We need to deepSeq the whole graph before trying to colour it to avoid +-- space leaks. +seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () +seqGraph graph = seqNodes (nonDetEltsUFM (Color.graphMap graph)) + -- See Note [Unique Determinism and code generation] + +seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () +seqNodes ns + = case ns of + [] -> () + (n : ns) -> seqNode n `seq` seqNodes ns + +seqNode :: Color.Node VirtualReg RegClass RealReg -> () +seqNode node + = seqVirtualReg (Color.nodeId node) + `seq` seqRegClass (Color.nodeClass node) + `seq` seqMaybeRealReg (Color.nodeColor node) + `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node))) + `seq` (seqRealRegList (nonDetEltsUniqSet (Color.nodeExclusions node))) + `seq` (seqRealRegList (Color.nodePreference node)) + `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node))) + -- It's OK to use nonDetEltsUniqSet for seq + +seqVirtualReg :: VirtualReg -> () +seqVirtualReg reg = reg `seq` () + +seqRealReg :: RealReg -> () +seqRealReg reg = reg `seq` () + +seqRegClass :: RegClass -> () +seqRegClass c = c `seq` () + +seqMaybeRealReg :: Maybe RealReg -> () +seqMaybeRealReg mr + = case mr of + Nothing -> () + Just r -> seqRealReg r + +seqVirtualRegList :: [VirtualReg] -> () +seqVirtualRegList rs + = case rs of + [] -> () + (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs + +seqRealRegList :: [RealReg] -> () +seqRealRegList rs + = case rs of + [] -> () + (r : rs) -> seqRealReg r `seq` seqRealRegList rs diff --git a/GHC/CmmToAsm/Reg/Graph/Base.hs b/GHC/CmmToAsm/Reg/Graph/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -0,0 +1,163 @@ + +-- | Utils for calculating general worst, bound, squeese and free, functions. +-- +-- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" +-- Michael Smith, Normal Ramsey, Glenn Holloway. +-- PLDI 2004 +-- +-- These general versions are not used in GHC proper because they are too slow. +-- Instead, hand written optimised versions are provided for each architecture +-- in MachRegs*.hs +-- +-- This code is here because we can test the architecture specific code against +-- it. +-- +module GHC.CmmToAsm.Reg.Graph.Base ( + RegClass(..), + Reg(..), + RegSub(..), + + worst, + bound, + squeese +) where + +import GHC.Prelude + +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Utils.Monad (concatMapM) + + +-- Some basic register classes. +-- These aren't necessarily in 1-to-1 correspondence with the allocatable +-- RegClasses in MachRegs.hs +data RegClass + -- general purpose regs + = ClassG32 -- 32 bit GPRs + | ClassG16 -- 16 bit GPRs + | ClassG8 -- 8 bit GPRs + + -- floating point regs + | ClassF64 -- 64 bit FPRs + deriving (Show, Eq, Enum) + + +-- | A register of some class +data Reg + -- a register of some class + = Reg RegClass Int + + -- a sub-component of one of the other regs + | RegSub RegSub Reg + deriving (Show, Eq) + + +-- | so we can put regs in UniqSets +instance Uniquable Reg where + getUnique (Reg c i) + = mkRegSingleUnique + $ fromEnum c * 1000 + i + + getUnique (RegSub s (Reg c i)) + = mkRegSubUnique + $ fromEnum s * 10000 + fromEnum c * 1000 + i + + getUnique (RegSub _ (RegSub _ _)) + = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg." + + +-- | A subcomponent of another register +data RegSub + = SubL16 -- lowest 16 bits + | SubL8 -- lowest 8 bits + | SubL8H -- second lowest 8 bits + deriving (Show, Enum, Ord, Eq) + + +-- | Worst case displacement +-- +-- a node N of classN has some number of neighbors, +-- all of which are from classC. +-- +-- (worst neighbors classN classC) is the maximum number of potential +-- colors for N that can be lost by coloring its neighbors. +-- +-- This should be hand coded/cached for each particular architecture, +-- because the compute time is very long.. +worst :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> Int -> RegClass -> RegClass -> Int + +worst regsOfClass regAlias neighbors classN classC + = let regAliasS regs = unionManyUniqSets + $ map regAlias + $ nonDetEltsUniqSet regs + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + -- all the regs in classes N, C + regsN = regsOfClass classN + regsC = regsOfClass classC + + -- all the possible subsets of c which have size < m + regsS = filter (\s -> sizeUniqSet s >= 1 + && sizeUniqSet s <= neighbors) + $ powersetLS regsC + + -- for each of the subsets of C, the regs which conflict + -- with posiblities for N + regsS_conflict + = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS + + in maximum $ map sizeUniqSet $ regsS_conflict + + +-- | For a node N of classN and neighbors of classesC +-- (bound classN classesC) is the maximum number of potential +-- colors for N that can be lost by coloring its neighbors. +bound :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> RegClass -> [RegClass] -> Int + +bound regsOfClass regAlias classN classesC + = let regAliasS regs = unionManyUniqSets + $ map regAlias + $ nonDetEltsUFM regs + -- See Note [Unique Determinism and code generation] + + regsC_aliases + = unionManyUniqSets + $ map (regAliasS . getUniqSet . regsOfClass) classesC + + overlap = intersectUniqSets (regsOfClass classN) regsC_aliases + + in sizeUniqSet overlap + + +-- | The total squeese on a particular node with a list of neighbors. +-- +-- A version of this should be constructed for each particular architecture, +-- possibly including uses of bound, so that alised registers don't get +-- counted twice, as per the paper. +squeese :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> RegClass -> [(Int, RegClass)] -> Int + +squeese regsOfClass regAlias classN countCs + = sum + $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) + $ countCs + + +-- | powerset (for lists) +powersetL :: [a] -> [[a]] +powersetL = concatMapM (\x -> [[],[x]]) + + +-- | powersetLS (list of sets) +powersetLS :: Uniquable a => UniqSet a -> [UniqSet a] +powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s + -- See Note [Unique Determinism and code generation] diff --git a/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs @@ -0,0 +1,99 @@ +-- | Register coalescing. +module GHC.CmmToAsm.Reg.Graph.Coalesce ( + regCoalesce, + slurpJoinMovs +) where +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg + +import GHC.Cmm +import GHC.Data.Bag +import GHC.Data.Graph.Directed +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply + + +-- | Do register coalescing on this top level thing +-- +-- For Reg -> Reg moves, if the first reg dies at the same time the +-- second reg is born then the mov only serves to join live ranges. +-- The two regs can be renamed to be the same and the move instruction +-- safely erased. +regCoalesce + :: Instruction instr + => [LiveCmmDecl statics instr] + -> UniqSM [LiveCmmDecl statics instr] + +regCoalesce code + = do + let joins = foldl' unionBags emptyBag + $ map slurpJoinMovs code + + let alloc = foldl' buildAlloc emptyUFM + $ bagToList joins + + let patched = map (patchEraseLive (sinkReg alloc)) code + + return patched + + +-- | Add a v1 = v2 register renaming to the map. +-- The register with the lowest lexical name is set as the +-- canonical version. +buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg +buildAlloc fm (r1, r2) + = let rmin = min r1 r2 + rmax = max r1 r2 + in addToUFM fm rmax rmin + + +-- | Determine the canonical name for a register by following +-- v1 = v2 renamings in this map. +sinkReg :: UniqFM Reg Reg -> Reg -> Reg +sinkReg fm r + = case lookupUFM fm r of + Nothing -> r + Just r' -> sinkReg fm r' + + +-- | Slurp out mov instructions that only serve to join live ranges. +-- +-- During a mov, if the source reg dies and the destination reg is +-- born then we can rename the two regs to the same thing and +-- eliminate the move. +slurpJoinMovs + :: Instruction instr + => LiveCmmDecl statics instr + -> Bag (Reg, Reg) + +slurpJoinMovs live + = slurpCmm emptyBag live + where + slurpCmm rs CmmData{} + = rs + + slurpCmm rs (CmmProc _ _ _ sccs) + = foldl' slurpBlock rs (flattenSCCs sccs) + + slurpBlock rs (BasicBlock _ instrs) + = foldl' slurpLI rs instrs + + slurpLI rs (LiveInstr _ Nothing) = rs + slurpLI rs (LiveInstr instr (Just live)) + | Just (r1, r2) <- takeRegRegMoveInstr instr + , elementOfUniqSet r1 $ liveDieRead live + , elementOfUniqSet r2 $ liveBorn live + + -- only coalesce movs between two virtuals for now, + -- else we end up with allocatable regs in the live + -- regs list.. + , isVirtualReg r1 && isVirtualReg r2 + = consBag (r1, r2) rs + + | otherwise + = rs + diff --git a/GHC/CmmToAsm/Reg/Graph/Spill.hs b/GHC/CmmToAsm/Reg/Graph/Spill.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -0,0 +1,386 @@ + +-- | When there aren't enough registers to hold all the vregs we have to spill +-- some of those vregs to slots on the stack. This module is used modify the +-- code to use those slots. +module GHC.CmmToAsm.Reg.Graph.Spill ( + regSpill, + SpillStats(..), + accSpillSL +) where +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Utils +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg +import GHC.Cmm hiding (RegSet) +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections + +import GHC.Utils.Monad +import GHC.Utils.Monad.State +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Platform + +import Data.List +import Data.Maybe +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + + +-- | Spill all these virtual regs to stack slots. +-- +-- Bumps the number of required stack slots if required. +-- +-- +-- TODO: See if we can split some of the live ranges instead of just globally +-- spilling the virtual reg. This might make the spill cleaner's job easier. +-- +-- TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction +-- when making spills. If an instr is using a spilled virtual we may be able to +-- address the spill slot directly. +-- +regSpill + :: Instruction instr + => Platform + -> [LiveCmmDecl statics instr] -- ^ the code + -> UniqSet Int -- ^ available stack slots + -> Int -- ^ current number of spill slots. + -> UniqSet VirtualReg -- ^ the regs to spill + -> UniqSM + ([LiveCmmDecl statics instr] + -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , Int -- slot count in use now. + , SpillStats ) -- stats about what happened during spilling + +regSpill platform code slotsFree slotCount regs + + -- Not enough slots to spill these regs. + | sizeUniqSet slotsFree < sizeUniqSet regs + = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $ + let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512]) + in regSpill platform code slotsFree' (slotCount+512) regs + + | otherwise + = do + -- Allocate a slot for each of the spilled regs. + let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree + let + regSlotMap = toRegMap -- Cast keys from VirtualReg to Reg + -- See Note [UniqFM and the register allocator] + $ listToUFM + $ zip (nonDetEltsUniqSet regs) slots :: UniqFM Reg Int + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + -- Grab the unique supply from the monad. + us <- getUniqueSupplyM + + -- Run the spiller on all the blocks. + let (code', state') = + runState (mapM (regSpill_top platform regSlotMap) code) + (initSpillS us) + + return ( code' + , minusUniqSet slotsFree (mkUniqSet slots) + , slotCount + , makeSpillStats state') + + +-- | Spill some registers to stack slots in a top-level thing. +regSpill_top + :: Instruction instr + => Platform + -> RegMap Int + -- ^ map of vregs to slots they're being spilled to. + -> LiveCmmDecl statics instr + -- ^ the top level thing. + -> SpillM (LiveCmmDecl statics instr) + +regSpill_top platform regSlotMap cmm + = case cmm of + CmmData{} + -> return cmm + + CmmProc info label live sccs + | LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info + -> do + -- The liveVRegsOnEntry contains the set of vregs that are live + -- on entry to each basic block. If we spill one of those vregs + -- we remove it from that set and add the corresponding slot + -- number to the liveSlotsOnEntry set. The spill cleaner needs + -- this information to erase unneeded spill and reload instructions + -- after we've done a successful allocation. + let liveSlotsOnEntry' :: BlockMap IntSet + liveSlotsOnEntry' + = mapFoldlWithKey patchLiveSlot + liveSlotsOnEntry liveVRegsOnEntry + + let info' + = LiveInfo static firstId + liveVRegsOnEntry + liveSlotsOnEntry' + + -- Apply the spiller to all the basic blocks in the CmmProc. + sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs + + return $ CmmProc info' label live sccs' + + where -- Given a BlockId and the set of registers live in it, + -- if registers in this block are being spilled to stack slots, + -- then record the fact that these slots are now live in those blocks + -- in the given slotmap. + patchLiveSlot + :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet + + patchLiveSlot slotMap blockId regsLive + = let + -- Slots that are already recorded as being live. + curSlotsLive = fromMaybe IntSet.empty + $ mapLookup blockId slotMap + + moreSlotsLive = IntSet.fromList + $ catMaybes + $ map (lookupUFM regSlotMap) + $ nonDetEltsUniqSet regsLive + -- See Note [Unique Determinism and code generation] + + slotMap' + = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive) + slotMap + + in slotMap' + + +-- | Spill some registers to stack slots in a basic block. +regSpill_block + :: Instruction instr + => Platform + -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. + -> LiveBasicBlock instr + -> SpillM (LiveBasicBlock instr) + +regSpill_block platform regSlotMap (BasicBlock i instrs) + = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs + return $ BasicBlock i (concat instrss') + + +-- | Spill some registers to stack slots in a single instruction. +-- If the instruction uses registers that need to be spilled, then it is +-- prefixed (or postfixed) with the appropriate RELOAD or SPILL meta +-- instructions. +regSpill_instr + :: Instruction instr + => Platform + -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. + -> LiveInstr instr + -> SpillM [LiveInstr instr] + +regSpill_instr _ _ li@(LiveInstr _ Nothing) + = do return [li] + +regSpill_instr platform regSlotMap + (LiveInstr instr (Just _)) + = do + -- work out which regs are read and written in this instr + let RU rlRead rlWritten = regUsageOfInstr platform instr + + -- sometimes a register is listed as being read more than once, + -- nub this so we don't end up inserting two lots of spill code. + let rsRead_ = nub rlRead + let rsWritten_ = nub rlWritten + + -- if a reg is modified, it appears in both lists, want to undo this.. + let rsRead = rsRead_ \\ rsWritten_ + let rsWritten = rsWritten_ \\ rsRead_ + let rsModify = intersect rsRead_ rsWritten_ + + -- work out if any of the regs being used are currently being spilled. + let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead + let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten + let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify + + -- rewrite the instr and work out spill code. + (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead + (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten + (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify + + let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) + let prefixes = concat mPrefixes + let postfixes = concat mPostfixes + + -- final code + let instrs' = prefixes + ++ [LiveInstr instr3 Nothing] + ++ postfixes + + return $ instrs' + + +-- | Add a RELOAD met a instruction to load a value for an instruction that +-- writes to a vreg that is being spilled. +spillRead + :: Instruction instr + => UniqFM Reg Int + -> instr + -> Reg + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillRead regSlotMap instr reg + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } + + return ( instr' + , ( [LiveInstr (RELOAD slot nReg) Nothing] + , []) ) + + | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" + + +-- | Add a SPILL meta instruction to store a value for an instruction that +-- writes to a vreg that is being spilled. +spillWrite + :: Instruction instr + => UniqFM Reg Int + -> instr + -> Reg + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillWrite regSlotMap instr reg + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) } + + return ( instr' + , ( [] + , [LiveInstr (SPILL nReg slot) Nothing])) + + | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" + + +-- | Add both RELOAD and SPILL meta instructions for an instruction that +-- both reads and writes to a vreg that is being spilled. +spillModify + :: Instruction instr + => UniqFM Reg Int + -> instr + -> Reg + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillModify regSlotMap instr reg + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } + + return ( instr' + , ( [LiveInstr (RELOAD slot nReg) Nothing] + , [LiveInstr (SPILL nReg slot) Nothing])) + + | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" + + +-- | Rewrite uses of this virtual reg in an instr to use a different +-- virtual reg. +patchInstr + :: Instruction instr + => Reg -> instr -> SpillM (instr, Reg) + +patchInstr reg instr + = do nUnique <- newUnique + + -- The register we're rewriting is supposed to be virtual. + -- If it's not then something has gone horribly wrong. + let nReg + = case reg of + RegVirtual vr + -> RegVirtual (renameVirtualReg nUnique vr) + + RegReal{} + -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" + + let instr' = patchReg1 reg nReg instr + return (instr', nReg) + + +patchReg1 + :: Instruction instr + => Reg -> Reg -> instr -> instr + +patchReg1 old new instr + = let patchF r + | r == old = new + | otherwise = r + in patchRegsOfInstr instr patchF + + +-- Spiller monad -------------------------------------------------------------- +-- | State monad for the spill code generator. +type SpillM a + = State SpillS a + +-- | Spill code generator state. +data SpillS + = SpillS + { -- | Unique supply for generating fresh vregs. + stateUS :: UniqSupply + + -- | Spilled vreg vs the number of times it was loaded, stored. + , stateSpillSL :: UniqFM Reg (Reg, Int, Int) } + + +-- | Create a new spiller state. +initSpillS :: UniqSupply -> SpillS +initSpillS uniqueSupply + = SpillS + { stateUS = uniqueSupply + , stateSpillSL = emptyUFM } + + +-- | Allocate a new unique in the spiller monad. +newUnique :: SpillM Unique +newUnique + = do us <- gets stateUS + case takeUniqFromSupply us of + (uniq, us') + -> do modify $ \s -> s { stateUS = us' } + return uniq + + +-- | Add a spill/reload count to a stats record for a register. +accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int) +accSpillSL (r1, s1, l1) (_, s2, l2) + = (r1, s1 + s2, l1 + l2) + + +-- Spiller stats -------------------------------------------------------------- +-- | Spiller statistics. +-- Tells us what registers were spilled. +data SpillStats + = SpillStats + { spillStoreLoad :: UniqFM Reg (Reg, Int, Int) } + + +-- | Extract spiller statistics from the spiller state. +makeSpillStats :: SpillS -> SpillStats +makeSpillStats s + = SpillStats + { spillStoreLoad = stateSpillSL s } + + +instance Outputable SpillStats where + ppr stats + = pprUFM (spillStoreLoad stats) + (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l)) diff --git a/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/GHC/CmmToAsm/Reg/Graph/SpillClean.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Clean out unneeded spill\/reload instructions. +-- +-- Handling of join points +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- @ +-- B1: B2: +-- ... ... +-- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1 +-- ... A ... ... B ... +-- jump B3 jump B3 +-- +-- B3: ... C ... +-- RELOAD SLOT(0), %r1 +-- ... +-- @ +-- +-- The Plan +-- ~~~~~~~~ +-- +-- As long as %r1 hasn't been written to in A, B or C then we don't need +-- the reload in B3. +-- +-- What we really care about here is that on the entry to B3, %r1 will +-- always have the same value that is in SLOT(0) (ie, %r1 is _valid_) +-- +-- This also works if the reloads in B1\/B2 were spills instead, because +-- spilling %r1 to a slot makes that slot have the same value as %r1. +-- +module GHC.CmmToAsm.Reg.Graph.SpillClean ( + cleanSpills +) where +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Utils.Monad.State +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Cmm.Dataflow.Collections + +import Data.List +import Data.Maybe +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + + +-- | The identification number of a spill slot. +-- A value is stored in a spill slot when we don't have a free +-- register to hold it. +type Slot = Int + + +-- | Clean out unneeded spill\/reloads from this top level thing. +cleanSpills + :: Instruction instr + => Platform + -> LiveCmmDecl statics instr + -> LiveCmmDecl statics instr + +cleanSpills platform cmm + = evalState (cleanSpin platform 0 cmm) initCleanS + + +-- | Do one pass of cleaning. +cleanSpin + :: Instruction instr + => Platform + -> Int -- ^ Iteration number for the cleaner. + -> LiveCmmDecl statics instr -- ^ Liveness annotated code to clean. + -> CleanM (LiveCmmDecl statics instr) + +cleanSpin platform spinCount code + = do + -- Initialise count of cleaned spill and reload instructions. + modify $ \s -> s + { sCleanedSpillsAcc = 0 + , sCleanedReloadsAcc = 0 + , sReloadedBy = emptyUFM } + + code_forward <- mapBlockTopM (cleanBlockForward platform) code + code_backward <- cleanTopBackward code_forward + + -- During the cleaning of each block we collected information about + -- what regs were valid across each jump. Based on this, work out + -- whether it will be safe to erase reloads after join points for + -- the next pass. + collateJoinPoints + + -- Remember how many spill and reload instructions we cleaned in this pass. + spills <- gets sCleanedSpillsAcc + reloads <- gets sCleanedReloadsAcc + modify $ \s -> s + { sCleanedCount = (spills, reloads) : sCleanedCount s } + + -- If nothing was cleaned in this pass or the last one + -- then we're done and it's time to bail out. + cleanedCount <- gets sCleanedCount + if take 2 cleanedCount == [(0, 0), (0, 0)] + then return code + + -- otherwise go around again + else cleanSpin platform (spinCount + 1) code_backward + + +------------------------------------------------------------------------------- +-- | Clean out unneeded reload instructions, +-- while walking forward over the code. +cleanBlockForward + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) + +cleanBlockForward platform (BasicBlock blockId instrs) + = do + -- See if we have a valid association for the entry to this block. + jumpValid <- gets sJumpValid + let assoc = case lookupUFM jumpValid blockId of + Just assoc -> assoc + Nothing -> emptyAssoc + + instrs_reload <- cleanForward platform blockId assoc [] instrs + return $ BasicBlock blockId instrs_reload + + + +-- | Clean out unneeded reload instructions. +-- +-- Walking forwards across the code +-- On a reload, if we know a reg already has the same value as a slot +-- then we don't need to do the reload. +-- +cleanForward + :: Instruction instr + => Platform + -> BlockId -- ^ the block that we're currently in + -> Assoc Store -- ^ two store locations are associated if + -- they have the same value + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) + -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) + +cleanForward _ _ _ acc [] + = return acc + +-- Rewrite live range joins via spill slots to just a spill and a reg-reg move +-- hopefully the spill will be also be cleaned in the next pass +cleanForward platform blockId assoc acc (li1 : li2 : instrs) + + | LiveInstr (SPILL reg1 slot1) _ <- li1 + , LiveInstr (RELOAD slot2 reg2) _ <- li2 + , slot1 == slot2 + = do + modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + cleanForward platform blockId assoc acc + $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing + : instrs + +cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) + | Just (r1, r2) <- takeRegRegMoveInstr i1 + = if r1 == r2 + -- Erase any left over nop reg reg moves while we're here + -- this will also catch any nop moves that the previous case + -- happens to add. + then cleanForward platform blockId assoc acc instrs + + -- If r1 has the same value as some slots and we copy r1 to r2, + -- then r2 is now associated with those slots instead + else do let assoc' = addAssoc (SReg r1) (SReg r2) + $ delAssoc (SReg r2) + $ assoc + + cleanForward platform blockId assoc' (li : acc) instrs + + +cleanForward platform blockId assoc acc (li : instrs) + + -- Update association due to the spill. + | LiveInstr (SPILL reg slot) _ <- li + = let assoc' = addAssoc (SReg reg) (SSlot slot) + $ delAssoc (SSlot slot) + $ assoc + in cleanForward platform blockId assoc' (li : acc) instrs + + -- Clean a reload instr. + | LiveInstr (RELOAD{}) _ <- li + = do (assoc', mli) <- cleanReload platform blockId assoc li + case mli of + Nothing -> cleanForward platform blockId assoc' acc + instrs + + Just li' -> cleanForward platform blockId assoc' (li' : acc) + instrs + + -- Remember the association over a jump. + | LiveInstr instr _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accJumpValid assoc) targets + cleanForward platform blockId assoc (li : acc) instrs + + -- Writing to a reg changes its value. + | LiveInstr instr _ <- li + , RU _ written <- regUsageOfInstr platform instr + = let assoc' = foldr delAssoc assoc (map SReg $ nub written) + in cleanForward platform blockId assoc' (li : acc) instrs + + + +-- | Try and rewrite a reload instruction to something more pleasing +cleanReload + :: Instruction instr + => Platform + -> BlockId + -> Assoc Store + -> LiveInstr instr + -> CleanM (Assoc Store, Maybe (LiveInstr instr)) + +cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) + + -- If the reg we're reloading already has the same value as the slot + -- then we can erase the instruction outright. + | elemAssoc (SSlot slot) (SReg reg) assoc + = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + return (assoc, Nothing) + + -- If we can find another reg with the same value as this slot then + -- do a move instead of a reload. + | Just reg2 <- findRegOfSlot assoc slot + = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + + let assoc' = addAssoc (SReg reg) (SReg reg2) + $ delAssoc (SReg reg) + $ assoc + + return ( assoc' + , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) + + -- Gotta keep this instr. + | otherwise + = do -- Update the association. + let assoc' + = addAssoc (SReg reg) (SSlot slot) + -- doing the reload makes reg and slot the same value + $ delAssoc (SReg reg) + -- reg value changes on reload + $ assoc + + -- Remember that this block reloads from this slot. + accBlockReloadsSlot blockId slot + + return (assoc', Just li) + +cleanReload _ _ _ _ + = panic "RegSpillClean.cleanReload: unhandled instr" + + +------------------------------------------------------------------------------- +-- | Clean out unneeded spill instructions, +-- while walking backwards over the code. +-- +-- If there were no reloads from a slot between a spill and the last one +-- then the slot was never read and we don't need the spill. +-- +-- SPILL r0 -> s1 +-- RELOAD s1 -> r2 +-- SPILL r3 -> s1 <--- don't need this spill +-- SPILL r4 -> s1 +-- RELOAD s1 -> r5 +-- +-- Maintain a set of +-- "slots which were spilled to but not reloaded from yet" +-- +-- Walking backwards across the code: +-- a) On a reload from a slot, remove it from the set. +-- +-- a) On a spill from a slot +-- If the slot is in set then we can erase the spill, +-- because it won't be reloaded from until after the next spill. +-- +-- otherwise +-- keep the spill and add the slot to the set +-- +-- TODO: This is mostly inter-block +-- we should really be updating the noReloads set as we cross jumps also. +-- +-- TODO: generate noReloads from liveSlotsOnEntry +-- +cleanTopBackward + :: Instruction instr + => LiveCmmDecl statics instr + -> CleanM (LiveCmmDecl statics instr) + +cleanTopBackward cmm + = case cmm of + CmmData{} + -> return cmm + + CmmProc info label live sccs + | LiveInfo _ _ _ liveSlotsOnEntry <- info + -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs + return $ CmmProc info label live sccs' + + +cleanBlockBackward + :: Instruction instr + => BlockMap IntSet + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) + +cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs) + = do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs + return $ BasicBlock blockId instrs_spill + + + +cleanBackward + :: Instruction instr + => BlockMap IntSet -- ^ Slots live on entry to each block + -> UniqSet Int -- ^ Slots that have been spilled, but not reloaded from + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ Instrs to clean (in forwards order) + -> CleanM [LiveInstr instr] -- ^ Cleaned instrs (in backwards order) + +cleanBackward liveSlotsOnEntry noReloads acc lis + = do reloadedBy <- gets sReloadedBy + cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis + + +cleanBackward' + :: Instruction instr + => BlockMap IntSet + -> UniqFM Store [BlockId] + -> UniqSet Int + -> [LiveInstr instr] + -> [LiveInstr instr] + -> State CleanS [LiveInstr instr] + +cleanBackward' _ _ _ acc [] + = return acc + +cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) + + -- If nothing ever reloads from this slot then we don't need the spill. + | LiveInstr (SPILL _ slot) _ <- li + , Nothing <- lookupUFM reloadedBy (SSlot slot) + = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } + cleanBackward liveSlotsOnEntry noReloads acc instrs + + | LiveInstr (SPILL _ slot) _ <- li + = if elementOfUniqSet slot noReloads + + -- We can erase this spill because the slot won't be read until + -- after the next one + then do + modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } + cleanBackward liveSlotsOnEntry noReloads acc instrs + + else do + -- This slot is being spilled to, but we haven't seen any reloads yet. + let noReloads' = addOneToUniqSet noReloads slot + cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + -- if we reload from a slot then it's no longer unused + | LiveInstr (RELOAD slot _) _ <- li + , noReloads' <- delOneFromUniqSet noReloads slot + = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + -- If a slot is live in a jump target then assume it's reloaded there. + -- + -- TODO: A real dataflow analysis would do a better job here. + -- If the target block _ever_ used the slot then we assume + -- it always does, but if those reloads are cleaned the slot + -- liveness map doesn't get updated. + | LiveInstr instr _ <- li + , targets <- jumpDestsOfInstr instr + = do + let slotsReloadedByTargets + = IntSet.unions + $ catMaybes + $ map (flip mapLookup liveSlotsOnEntry) + $ targets + + let noReloads' + = foldl' delOneFromUniqSet noReloads + $ IntSet.toList slotsReloadedByTargets + + cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + +#if __GLASGOW_HASKELL__ <= 810 + -- some other instruction + | otherwise + = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs +#endif + + +-- | Combine the associations from all the inward control flow edges. +-- +collateJoinPoints :: CleanM () +collateJoinPoints + = modify $ \s -> s + { sJumpValid = mapUFM intersects (sJumpValidAcc s) + , sJumpValidAcc = emptyUFM } + +intersects :: [Assoc Store] -> Assoc Store +intersects [] = emptyAssoc +intersects assocs = foldl1' intersectAssoc assocs + + +-- | See if we have a reg with the same value as this slot in the association table. +findRegOfSlot :: Assoc Store -> Int -> Maybe Reg +findRegOfSlot assoc slot + | close <- closeAssoc (SSlot slot) assoc + , Just (SReg reg) <- find isStoreReg $ nonDetEltsUniqSet close + -- See Note [Unique Determinism and code generation] + = Just reg + + | otherwise + = Nothing + + +------------------------------------------------------------------------------- +-- | Cleaner monad. +type CleanM + = State CleanS + +-- | Cleaner state. +data CleanS + = CleanS + { -- | Regs which are valid at the start of each block. + sJumpValid :: UniqFM BlockId (Assoc Store) + + -- | Collecting up what regs were valid across each jump. + -- in the next pass we can collate these and write the results + -- to sJumpValid. + , sJumpValidAcc :: UniqFM BlockId [Assoc Store] + + -- | Map of (slot -> blocks which reload from this slot) + -- used to decide if whether slot spilled to will ever be + -- reloaded from on this path. + , sReloadedBy :: UniqFM Store [BlockId] + + -- | Spills and reloads cleaned each pass (latest at front) + , sCleanedCount :: [(Int, Int)] + + -- | Spills and reloads that have been cleaned in this pass so far. + , sCleanedSpillsAcc :: Int + , sCleanedReloadsAcc :: Int } + + +-- | Construct the initial cleaner state. +initCleanS :: CleanS +initCleanS + = CleanS + { sJumpValid = emptyUFM + , sJumpValidAcc = emptyUFM + + , sReloadedBy = emptyUFM + + , sCleanedCount = [] + + , sCleanedSpillsAcc = 0 + , sCleanedReloadsAcc = 0 } + + +-- | Remember the associations before a jump. +accJumpValid :: Assoc Store -> BlockId -> CleanM () +accJumpValid assocs target + = modify $ \s -> s { + sJumpValidAcc = addToUFM_C (++) + (sJumpValidAcc s) + target + [assocs] } + + +accBlockReloadsSlot :: BlockId -> Slot -> CleanM () +accBlockReloadsSlot blockId slot + = modify $ \s -> s { + sReloadedBy = addToUFM_C (++) + (sReloadedBy s) + (SSlot slot) + [blockId] } + + +------------------------------------------------------------------------------- +-- A store location can be a stack slot or a register +data Store + = SSlot Int + | SReg Reg + + +-- | Check if this is a reg store. +isStoreReg :: Store -> Bool +isStoreReg ss + = case ss of + SSlot _ -> False + SReg _ -> True + + +-- Spill cleaning is only done once all virtuals have been allocated to realRegs +instance Uniquable Store where + getUnique (SReg r) + | RegReal (RealRegSingle i) <- r + = mkRegSingleUnique i + + | RegReal (RealRegPair r1 r2) <- r + = mkRegPairUnique (r1 * 65535 + r2) + + | otherwise + = error $ "RegSpillClean.getUnique: found virtual reg during spill clean," + ++ "only real regs expected." + + getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok + + +instance Outputable Store where + ppr (SSlot i) = text "slot" <> int i + ppr (SReg r) = ppr r + + +------------------------------------------------------------------------------- +-- Association graphs. +-- In the spill cleaner, two store locations are associated if they are known +-- to hold the same value. +-- +-- TODO: Monomorphize: I think we only ever use this with a ~ Store +type Assoc a = UniqFM a (UniqSet a) + +-- | An empty association +emptyAssoc :: Assoc a +emptyAssoc = emptyUFM + + +-- | Add an association between these two things. +-- addAssoc :: Uniquable a +-- => a -> a -> Assoc a -> Assoc a +addAssoc :: Store -> Store -> Assoc Store -> Assoc Store + +addAssoc a b m + = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b) + m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a) + in m2 + + +-- | Delete all associations to a node. +delAssoc :: Store -> Assoc Store -> Assoc Store +delAssoc a m + | Just aSet <- lookupUFM m a + , m1 <- delFromUFM m a + = nonDetStrictFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet + -- It's OK to use a non-deterministic fold here because deletion is + -- commutative + + | otherwise = m + + +-- | Delete a single association edge (a -> b). +delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store +delAssoc1 a b m + | Just aSet <- lookupUFM m a + = addToUFM m a (delOneFromUniqSet aSet b) + + | otherwise = m + + +-- | Check if these two things are associated. +elemAssoc :: Store -> Store -> Assoc Store -> Bool + +elemAssoc a b m + = elementOfUniqSet b (closeAssoc a m) + + +-- | Find the refl. trans. closure of the association from this point. +closeAssoc :: Store -> Assoc Store -> UniqSet Store +closeAssoc a assoc + = closeAssoc' assoc emptyUniqSet (unitUniqSet a) + where + closeAssoc' assoc visited toVisit + = case nonDetEltsUniqSet toVisit of + -- See Note [Unique Determinism and code generation] + + -- nothing else to visit, we're done + [] -> visited + + (x:_) + -- we've already seen this node + | elementOfUniqSet x visited + -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x) + + -- haven't seen this node before, + -- remember to visit all its neighbors + | otherwise + -> let neighbors + = case lookupUFM assoc x of + Nothing -> emptyUniqSet + Just set -> set + + in closeAssoc' assoc + (addOneToUniqSet visited x) + (unionUniqSets toVisit neighbors) + +-- | Intersect two associations. +intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store +intersectAssoc a b + = intersectUFM_C (intersectUniqSets) a b diff --git a/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-} +module GHC.CmmToAsm.Reg.Graph.SpillCost ( + SpillCostRecord, + plusSpillCostRecord, + pprSpillCostRecord, + + SpillCostInfo, + zeroSpillCostInfo, + plusSpillCostInfo, + + slurpSpillCostInfo, + chooseSpill, + + lifeMapFromSpillCostInfo +) where +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Data.Graph.Base + +import GHC.Cmm.Dataflow.Collections (mapLookup) +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Data.Graph.Directed (flattenSCCs) +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Utils.Monad.State +import GHC.CmmToAsm.CFG + +import Data.List (nub, minimumBy) +import Data.Maybe +import Control.Monad (join) + + +-- | Records the expected cost to spill some register. +type SpillCostRecord + = ( VirtualReg -- register name + , Int -- number of writes to this reg + , Int -- number of reads from this reg + , Int) -- number of instrs this reg was live on entry to + + +-- | Map of `SpillCostRecord` +type SpillCostInfo + = UniqFM VirtualReg SpillCostRecord + +type SpillCostState = State SpillCostInfo () + +-- | An empty map of spill costs. +zeroSpillCostInfo :: SpillCostInfo +zeroSpillCostInfo = emptyUFM + + +-- | Add two spill cost infos. +plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo +plusSpillCostInfo sc1 sc2 + = plusUFM_C plusSpillCostRecord sc1 sc2 + + +-- | Add two spill cost records. +plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord +plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) + | r1 == r2 = (r1, a1 + a2, b1 + b2, c1 + c2) + | otherwise = error "RegSpillCost.plusRegInt: regs don't match" + + +-- | Slurp out information used for determining spill costs. +-- +-- For each vreg, the number of times it was written to, read from, +-- and the number of instructions it was live on entry to (lifetime) +-- +slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr) + => Platform + -> Maybe CFG + -> LiveCmmDecl statics instr + -> SpillCostInfo + +slurpSpillCostInfo platform cfg cmm + = execState (countCmm cmm) zeroSpillCostInfo + where + countCmm CmmData{} = return () + countCmm (CmmProc info _ _ sccs) + = mapM_ (countBlock info freqMap) + $ flattenSCCs sccs + where + LiveInfo _ entries _ _ = info + freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg + + -- Lookup the regs that are live on entry to this block in + -- the info table from the CmmProc. + countBlock info freqMap (BasicBlock blockId instrs) + | LiveInfo _ _ blockLive _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , rsLiveEntry_virt <- takeVirtuals rsLiveEntry + = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs + + | otherwise + = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" + + + countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState + countLIs _ _ [] + = return () + + -- Skip over comment and delta pseudo instrs. + countLIs scale rsLive (LiveInstr instr Nothing : lis) + | isMetaInstr instr + = countLIs scale rsLive lis + + | otherwise + = pprPanic "RegSpillCost.slurpSpillCostInfo" + $ text "no liveness information on instruction " <> ppr instr + + countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis) + = do + -- Increment the lifetime counts for regs live on entry to this instr. + mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + -- Increment counts for what regs were read/written from. + let (RU read written) = regUsageOfInstr platform instr + mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read + mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written + + -- Compute liveness for entry to next instruction. + let liveDieRead_virt = takeVirtuals (liveDieRead live) + let liveDieWrite_virt = takeVirtuals (liveDieWrite live) + let liveBorn_virt = takeVirtuals (liveBorn live) + + let rsLiveAcross + = rsLiveEntry `minusUniqSet` liveDieRead_virt + + let rsLiveNext + = (rsLiveAcross `unionUniqSets` liveBorn_virt) + `minusUniqSet` liveDieWrite_virt + + countLIs scale rsLiveNext lis + + incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0) + incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0) + incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) + + blockFreq :: Maybe (LabelMap Double) -> Label -> Double + blockFreq freqs bid + | Just freq <- join (mapLookup bid <$> freqs) + = max 1.0 (10000 * freq) + | otherwise + = 1.0 -- Only if no cfg given + +-- | Take all the virtual registers from this set. +takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg +takeVirtuals set = mkUniqSet + [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] + -- See Note [Unique Determinism and code generation] + + +-- | Choose a node to spill from this graph +chooseSpill + :: SpillCostInfo + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + +chooseSpill info graph + = let cost = spillCost_length info graph + node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + in nodeId node + + +------------------------------------------------------------------------------- +-- | Chaitins spill cost function is: +-- +-- cost = sum loadCost * freq (u) + sum storeCost * freq (d) +-- u <- uses (v) d <- defs (v) +-- +-- There are no loops in our code at the moment, so we can set the freq's to 1. +-- +-- If we don't have live range splitting then Chaitins function performs badly +-- if we have lots of nested live ranges and very few registers. +-- +-- v1 v2 v3 +-- def v1 . +-- use v1 . +-- def v2 . . +-- def v3 . . . +-- use v1 . . . +-- use v3 . . . +-- use v2 . . +-- use v1 . +-- +-- defs uses degree cost +-- v1: 1 3 3 1.5 +-- v2: 1 2 3 1.0 +-- v3: 1 1 3 0.666 +-- +-- v3 has the lowest cost, but if we only have 2 hardregs and we insert +-- spill code for v3 then this isn't going to improve the colorability of +-- the graph. +-- +-- When compiling SHA1, which as very long basic blocks and some vregs +-- with very long live ranges the allocator seems to try and spill from +-- the inside out and eventually run out of stack slots. +-- +-- Without live range splitting, its's better to spill from the outside +-- in so set the cost of very long live ranges to zero +-- + +-- spillCost_chaitin +-- :: SpillCostInfo +-- -> Graph VirtualReg RegClass RealReg +-- -> VirtualReg +-- -> Float + +-- spillCost_chaitin info graph reg +-- -- Spilling a live range that only lives for 1 instruction +-- -- isn't going to help us at all - and we definitely want to avoid +-- -- trying to re-spill previously inserted spill code. +-- | lifetime <= 1 = 1/0 + +-- -- It's unlikely that we'll find a reg for a live range this long +-- -- better to spill it straight up and not risk trying to keep it around +-- -- and have to go through the build/color cycle again. + +-- -- To facility this we scale down the spill cost of long ranges. +-- -- This makes sure long ranges are still spilled first. +-- -- But this way spill cost remains relevant for long live +-- -- ranges. +-- | lifetime >= 128 +-- = (spillCost / conflicts) / 10.0 + + +-- -- Otherwise revert to chaitin's regular cost function. +-- | otherwise = (spillCost / conflicts) +-- where +-- !spillCost = fromIntegral (uses + defs) :: Float +-- conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg) +-- (_, defs, uses, lifetime) +-- = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg + + +-- Just spill the longest live range. +spillCost_length + :: SpillCostInfo + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Float + +spillCost_length info _ reg + | lifetime <= 1 = 1/0 + | otherwise = 1 / fromIntegral lifetime + where (_, _, _, lifetime) + = fromMaybe (reg, 0, 0, 0) + $ lookupUFM info reg + + +-- | Extract a map of register lifetimes from a `SpillCostInfo`. +lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int) +lifeMapFromSpillCostInfo info + = listToUFM + $ map (\(r, _, _, life) -> (r, (r, life))) + $ nonDetEltsUFM info + -- See Note [Unique Determinism and code generation] + + +-- | Determine the degree (number of neighbors) of this node which +-- have the same class. +nodeDegree + :: (VirtualReg -> RegClass) + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Int + +nodeDegree classOfVirtualReg graph reg + | Just node <- lookupUFM (graphMap graph) reg + + , virtConflicts + <- length + $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ nodeConflicts node + + = virtConflicts + sizeUniqSet (nodeExclusions node) + + | otherwise + = 0 + + +-- | Show a spill cost record, including the degree from the graph +-- and final calculated spill cost. +pprSpillCostRecord + :: (VirtualReg -> RegClass) + -> (Reg -> SDoc) + -> Graph VirtualReg RegClass RealReg + -> SpillCostRecord + -> SDoc + +pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) + = hsep + [ pprReg (RegVirtual reg) + , ppr uses + , ppr defs + , ppr life + , ppr $ nodeDegree regClass graph reg + , text $ show $ (fromIntegral (uses + defs) + / fromIntegral (nodeDegree regClass graph reg) :: Float) ] + diff --git a/GHC/CmmToAsm/Reg/Graph/Stats.hs b/GHC/CmmToAsm/Reg/Graph/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE BangPatterns, CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Carries interesting info for debugging / profiling of the +-- graph coloring register allocator. +module GHC.CmmToAsm.Reg.Graph.Stats ( + RegAllocStats (..), + + pprStats, + pprStatsSpills, + pprStatsLifetimes, + pprStatsConflict, + pprStatsLifeConflict, + + countSRMs, addSRM +) where + +import GHC.Prelude + +import qualified GHC.Data.Graph.Color as Color +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Graph.Spill +import GHC.CmmToAsm.Reg.Graph.SpillCost +import GHC.CmmToAsm.Reg.Graph.TrivColorable +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg.Class +import GHC.Platform.Reg +import GHC.CmmToAsm.Reg.Target +import GHC.Platform + +import GHC.Utils.Outputable +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Monad.State + +-- | Holds interesting statistics from the register allocator. +data RegAllocStats statics instr + + -- Information about the initial conflict graph. + = RegAllocStatsStart + { -- | Initial code, with liveness. + raLiveCmm :: [LiveCmmDecl statics instr] + + -- | The initial, uncolored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | Information to help choose which regs to spill. + , raSpillCosts :: SpillCostInfo + + -- | Target platform + , raPlatform :: !Platform + } + + + -- Information about an intermediate graph. + -- This is one that we couldn't color, so had to insert spill code + -- instruction stream. + | RegAllocStatsSpill + { -- | Code we tried to allocate registers for. + raCode :: [LiveCmmDecl statics instr] + + -- | Partially colored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | The regs that were coalesced. + , raCoalesced :: UniqFM VirtualReg VirtualReg + + -- | Spiller stats. + , raSpillStats :: SpillStats + + -- | Number of instructions each reg lives for. + , raSpillCosts :: SpillCostInfo + + -- | Code with spill instructions added. + , raSpilled :: [LiveCmmDecl statics instr] + + -- | Target platform + , raPlatform :: !Platform + } + + + -- a successful coloring + | RegAllocStatsColored + { -- | Code we tried to allocate registers for. + raCode :: [LiveCmmDecl statics instr] + + -- | Uncolored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | Coalesced and colored graph. + , raGraphColored :: Color.Graph VirtualReg RegClass RealReg + + -- | Regs that were coalesced. + , raCoalesced :: UniqFM VirtualReg VirtualReg + + -- | Code with coalescings applied. + , raCodeCoalesced :: [LiveCmmDecl statics instr] + + -- | Code with vregs replaced by hregs. + , raPatched :: [LiveCmmDecl statics instr] + + -- | Code with unneeded spill\/reloads cleaned out. + , raSpillClean :: [LiveCmmDecl statics instr] + + -- | Final code. + , raFinal :: [NatCmmDecl statics instr] + + -- | Spill\/reload\/reg-reg moves present in this code. + , raSRMs :: (Int, Int, Int) + + -- | Target platform + , raPlatform :: !Platform + } + + +instance (Outputable statics, Outputable instr) + => Outputable (RegAllocStats statics instr) where + + ppr (s@RegAllocStatsStart{}) + = text "# Start" + $$ text "# Native code with liveness information." + $$ ppr (raLiveCmm s) + $$ text "" + $$ text "# Initial register conflict graph." + $$ Color.dotGraph + (targetRegDotColor (raPlatform s)) + (trivColorable (raPlatform s) + (targetVirtualRegSqueeze (raPlatform s)) + (targetRealRegSqueeze (raPlatform s))) + (raGraph s) + + + ppr (s@RegAllocStatsSpill{}) = + text "# Spill" + + $$ text "# Code with liveness information." + $$ ppr (raCode s) + $$ text "" + + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) + $$ text "" + else empty) + + $$ text "# Spills inserted." + $$ ppr (raSpillStats s) + $$ text "" + + $$ text "# Code with spills inserted." + $$ ppr (raSpilled s) + + + ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + = text "# Colored" + + $$ text "# Code with liveness information." + $$ ppr (raCode s) + $$ text "" + + $$ text "# Register conflict graph (colored)." + $$ Color.dotGraph + (targetRegDotColor (raPlatform s)) + (trivColorable (raPlatform s) + (targetVirtualRegSqueeze (raPlatform s)) + (targetRealRegSqueeze (raPlatform s))) + (raGraphColored s) + $$ text "" + + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) + $$ text "" + else empty) + + $$ text "# Native code after coalescings applied." + $$ ppr (raCodeCoalesced s) + $$ text "" + + $$ text "# Native code after register allocation." + $$ ppr (raPatched s) + $$ text "" + + $$ text "# Clean out unneeded spill/reloads." + $$ ppr (raSpillClean s) + $$ text "" + + $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." + $$ ppr (raFinal s) + $$ text "" + $$ text "# Score:" + $$ (text "# spills inserted: " <> int spills) + $$ (text "# reloads inserted: " <> int reloads) + $$ (text "# reg-reg moves remaining: " <> int moves) + $$ text "" + + +-- | Do all the different analysis on this list of RegAllocStats +pprStats + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg + -> SDoc + +pprStats stats graph + = let outSpills = pprStatsSpills stats + outLife = pprStatsLifetimes stats + outConflict = pprStatsConflict stats + outScatter = pprStatsLifeConflict stats graph + + in vcat [outSpills, outLife, outConflict, outScatter] + + +-- | Dump a table of how many spill loads \/ stores were inserted for each vreg. +pprStatsSpills + :: [RegAllocStats statics instr] -> SDoc + +pprStatsSpills stats + = let + finals = [ s | s@RegAllocStatsColored{} <- stats] + + -- sum up how many stores\/loads\/reg-reg-moves were left in the code + total = foldl' addSRM (0, 0, 0) + $ map raSRMs finals + + in ( text "-- spills-added-total" + $$ text "-- (stores, loads, reg_reg_moves_remaining)" + $$ ppr total + $$ text "") + + +-- | Dump a table of how long vregs tend to live for in the initial code. +pprStatsLifetimes + :: [RegAllocStats statics instr] -> SDoc + +pprStatsLifetimes stats + = let info = foldl' plusSpillCostInfo zeroSpillCostInfo + [ raSpillCosts s + | s@RegAllocStatsStart{} <- stats ] + + lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info + + in ( text "-- vreg-population-lifetimes" + $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" + $$ pprUFM lifeBins (vcat . map ppr) + $$ text "\n") + + +binLifetimeCount :: UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int) +binLifetimeCount fm + = let lifes = map (\l -> (l, (l, 1))) + $ map snd + $ nonDetEltsUFM fm + -- See Note [Unique Determinism and code generation] + + in addListToUFM_C + (\(l1, c1) (_, c2) -> (l1, c1 + c2)) + emptyUFM + lifes + + +-- | Dump a table of how many conflicts vregs tend to have in the initial code. +pprStatsConflict + :: [RegAllocStats statics instr] -> SDoc + +pprStatsConflict stats + = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) + emptyUFM + $ map Color.slurpNodeConflictCount + [ raGraph s | s@RegAllocStatsStart{} <- stats ] + + in ( text "-- vreg-conflicts" + $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" + $$ pprUFM confMap (vcat . map ppr) + $$ text "\n") + + +-- | For every vreg, dump how many conflicts it has, and its lifetime. +-- Good for making a scatter plot. +pprStatsLifeConflict + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph + -> SDoc + +pprStatsLifeConflict stats graph + = let lifeMap = lifeMapFromSpillCostInfo + $ foldl' plusSpillCostInfo zeroSpillCostInfo + $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] + + scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of + Just (_, l) -> l + Nothing -> 0 + Just node = Color.lookupNode graph r + in parens $ hcat $ punctuate (text ", ") + [ doubleQuotes $ ppr $ Color.nodeId node + , ppr $ sizeUniqSet (Color.nodeConflicts node) + , ppr $ lifetime ]) + $ map Color.nodeId + $ nonDetEltsUFM + -- See Note [Unique Determinism and code generation] + $ Color.graphMap graph + + in ( text "-- vreg-conflict-lifetime" + $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" + $$ (vcat scatter) + $$ text "\n") + + +-- | Count spill/reload/reg-reg moves. +-- Lets us see how well the register allocator has done. +countSRMs + :: Instruction instr + => LiveCmmDecl statics instr -> (Int, Int, Int) + +countSRMs cmm + = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) + + +countSRM_block + :: Instruction instr + => GenBasicBlock (LiveInstr instr) + -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) + +countSRM_block (BasicBlock i instrs) + = do instrs' <- mapM countSRM_instr instrs + return $ BasicBlock i instrs' + + +countSRM_instr + :: Instruction instr + => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) + +countSRM_instr li + | LiveInstr SPILL{} _ <- li + = do modify $ \(s, r, m) -> (s + 1, r, m) + return li + + | LiveInstr RELOAD{} _ <- li + = do modify $ \(s, r, m) -> (s, r + 1, m) + return li + + | LiveInstr instr _ <- li + , Just _ <- takeRegRegMoveInstr instr + = do modify $ \(s, r, m) -> (s, r, m + 1) + return li + + | otherwise + = return li + + +-- sigh.. +addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) +addSRM (s1, r1, m1) (s2, r2, m2) + = let !s = s1 + s2 + !r = r1 + r2 + !m = m1 + m2 + in (s, r, m) + diff --git a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE CPP #-} + +module GHC.CmmToAsm.Reg.Graph.TrivColorable ( + trivColorable, +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Data.Graph.Base + +import GHC.Types.Unique.Set +import GHC.Platform +import GHC.Utils.Panic + +-- trivColorable --------------------------------------------------------------- + +-- trivColorable function for the graph coloring allocator +-- +-- This gets hammered by scanGraph during register allocation, +-- so needs to be fairly efficient. +-- +-- NOTE: This only works for architectures with just RcInteger and RcDouble +-- (which are disjoint) ie. x86, x86_64 and ppc +-- +-- The number of allocatable regs is hard coded in here so we can do +-- a fast comparison in trivColorable. +-- +-- It's ok if these numbers are _less_ than the actual number of free +-- regs, but they can't be more or the register conflict +-- graph won't color. +-- +-- If the graph doesn't color then the allocator will panic, but it won't +-- generate bad object code or anything nasty like that. +-- +-- There is an allocatableRegsInClass :: RegClass -> Int, but doing +-- the unboxing is too slow for us here. +-- TODO: Is that still true? Could we use allocatableRegsInClass +-- without losing performance now? +-- +-- Look at includes/stg/MachRegs.h to get the numbers. +-- + + +-- Disjoint registers ---------------------------------------------------------- +-- +-- The definition has been unfolded into individual cases for speed. +-- Each architecture has a different register setup, so we use a +-- different regSqueeze function for each. +-- +accSqueeze + :: Int + -> Int + -> (reg -> Int) + -> UniqSet reg + -> Int + +accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us) + -- See Note [Unique Determinism and code generation] + where acc count [] = count + acc count _ | count >= maxCount = count + acc count (r:rs) = acc (count + squeeze r) rs + +{- Note [accSqueeze] +~~~~~~~~~~~~~~~~~~~~ +BL 2007/09 +Doing a nice fold over the UniqSet makes trivColorable use +32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs. +Therefore the UniqFM is made non-abstract and we use custom fold. + +MS 2010/04 +When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal +representation any more. But it is imperative that the accSqueeze stops +the folding if the count gets greater or equal to maxCount. We thus convert +UniqFM to a (lazy) list, do the fold and stops if necessary, which was +the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows. +(original = previous implementation, folding = fold of the whole UFM, + lazyFold = the current implementation, + hackFold = using internal representation of Data.IntMap) + + original folding hackFold lazyFold + -O -fasm (used everywhere) 31.509s 30.387s 30.791s 30.603s + 100.00% 96.44% 97.72% 97.12% + -fregs-graph 67.938s 74.875s 62.673s 64.679s + 100.00% 110.21% 92.25% 95.20% + -fregs-iterative 89.761s 143.913s 81.075s 86.912s + 100.00% 160.33% 90.32% 96.83% + -fnew-codegen 38.225s 37.142s 37.551s 37.119s + 100.00% 97.17% 98.24% 97.11% + -fnew-codegen -fregs-graph 91.786s 91.51s 87.368s 86.88s + 100.00% 99.70% 95.19% 94.65% + -fnew-codegen -fregs-iterative 206.72s 343.632s 194.694s 208.677s + 100.00% 166.23% 94.18% 100.95% +-} + +trivColorable + :: Platform + -> (RegClass -> VirtualReg -> Int) + -> (RegClass -> RealReg -> Int) + -> Triv VirtualReg RegClass RealReg + +trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions + | let cALLOCATABLE_REGS_INTEGER + = (case platformArch platform of + ArchX86 -> 3 + ArchX86_64 -> 5 + ArchPPC -> 16 + ArchSPARC -> 14 + ArchSPARC64 -> panic "trivColorable ArchSPARC64" + ArchPPC_64 _ -> 15 + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchAArch64 -> panic "trivColorable ArchAArch64" + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchS390X -> panic "trivColorable ArchS390X" + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER + (virtualRegSqueeze RcInteger) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_INTEGER + (realRegSqueeze RcInteger) + exclusions + + = count3 < cALLOCATABLE_REGS_INTEGER + +trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions + | let cALLOCATABLE_REGS_FLOAT + = (case platformArch platform of + -- On x86_64 and x86, Float and RcDouble + -- use the same registers, + -- so we only use RcDouble to represent the + -- register allocation problem on those types. + ArchX86 -> 0 + ArchX86_64 -> 0 + ArchPPC -> 0 + ArchSPARC -> 22 + ArchSPARC64 -> panic "trivColorable ArchSPARC64" + ArchPPC_64 _ -> 0 + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchAArch64 -> panic "trivColorable ArchAArch64" + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchS390X -> panic "trivColorable ArchS390X" + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT + (virtualRegSqueeze RcFloat) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_FLOAT + (realRegSqueeze RcFloat) + exclusions + + = count3 < cALLOCATABLE_REGS_FLOAT + +trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions + | let cALLOCATABLE_REGS_DOUBLE + = (case platformArch platform of + ArchX86 -> 8 + -- in x86 32bit mode sse2 there are only + -- 8 XMM registers xmm0 ... xmm7 + ArchX86_64 -> 10 + -- in x86_64 there are 16 XMM registers + -- xmm0 .. xmm15, here 10 is a + -- "dont need to solve conflicts" count that + -- was chosen at some point in the past. + ArchPPC -> 26 + ArchSPARC -> 11 + ArchSPARC64 -> panic "trivColorable ArchSPARC64" + ArchPPC_64 _ -> 20 + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchAArch64 -> panic "trivColorable ArchAArch64" + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchS390X -> panic "trivColorable ArchS390X" + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE + (virtualRegSqueeze RcDouble) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_DOUBLE + (realRegSqueeze RcDouble) + exclusions + + = count3 < cALLOCATABLE_REGS_DOUBLE + + + + +-- Specification Code ---------------------------------------------------------- +-- +-- The trivColorable function for each particular architecture should +-- implement the following function, but faster. +-- + +{- +trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool +trivColorable classN conflicts exclusions + = let + + acc :: Reg -> (Int, Int) -> (Int, Int) + acc r (cd, cf) + = case regClass r of + RcInteger -> (cd+1, cf) + RcFloat -> (cd, cf+1) + _ -> panic "Regs.trivColorable: reg class not handled" + + tmp = nonDetFoldUFM acc (0, 0) conflicts + (countInt, countFloat) = nonDetFoldUFM acc tmp exclusions + + squeese = worst countInt classN RcInteger + + worst countFloat classN RcFloat + + in squeese < allocatableRegsInClass classN + +-- | Worst case displacement +-- node N of classN has n neighbors of class C. +-- +-- We currently only have RcInteger and RcDouble, which don't conflict at all. +-- This is a bit boring compared to what's in RegArchX86. +-- +worst :: Int -> RegClass -> RegClass -> Int +worst n classN classC + = case classN of + RcInteger + -> case classC of + RcInteger -> min n (allocatableRegsInClass RcInteger) + RcFloat -> 0 + + RcDouble + -> case classC of + RcFloat -> min n (allocatableRegsInClass RcFloat) + RcInteger -> 0 + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: [RegNo] +allocatableRegs + = let isFree i = freeReg i + in filter isFree allMachRegNos + + +-- | The number of regs in each class. +-- We go via top level CAFs to ensure that we're not recomputing +-- the length of these lists each time the fn is called. +allocatableRegsInClass :: RegClass -> Int +allocatableRegsInClass cls + = case cls of + RcInteger -> allocatableRegsInteger + RcFloat -> allocatableRegsDouble + +allocatableRegsInteger :: Int +allocatableRegsInteger + = length $ filter (\r -> regClass r == RcInteger) + $ map RealReg allocatableRegs + +allocatableRegsFloat :: Int +allocatableRegsFloat + = length $ filter (\r -> regClass r == RcFloat + $ map RealReg allocatableRegs +-} diff --git a/GHC/CmmToAsm/Reg/Graph/X86.hs b/GHC/CmmToAsm/Reg/Graph/X86.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Graph/X86.hs @@ -0,0 +1,161 @@ + +-- | A description of the register set of the X86. +-- +-- This isn't used directly in GHC proper. +-- +-- See RegArchBase.hs for the reference. +-- See MachRegs.hs for the actual trivColorable function used in GHC. +-- +module GHC.CmmToAsm.Reg.Graph.X86 ( + classOfReg, + regsOfClass, + regName, + regAlias, + worst, + squeese, +) where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Graph.Base (Reg(..), RegSub(..), RegClass(..)) +import GHC.Types.Unique.Set + +import qualified Data.Array as A + + +-- | Determine the class of a register +classOfReg :: Reg -> RegClass +classOfReg reg + = case reg of + Reg c _ -> c + + RegSub SubL16 _ -> ClassG16 + RegSub SubL8 _ -> ClassG8 + RegSub SubL8H _ -> ClassG8 + + +-- | Determine all the regs that make up a certain class. +regsOfClass :: RegClass -> UniqSet Reg +regsOfClass c + = case c of + ClassG32 + -> mkUniqSet [ Reg ClassG32 i + | i <- [0..7] ] + + ClassG16 + -> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) + | i <- [0..7] ] + + ClassG8 + -> unionUniqSets + (mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ]) + (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ]) + + ClassF64 + -> mkUniqSet [ Reg ClassF64 i + | i <- [0..5] ] + + +-- | Determine the common name of a reg +-- returns Nothing if this reg is not part of the machine. +regName :: Reg -> Maybe String +regName reg + = case reg of + Reg ClassG32 i + | i <= 7 -> + let names = A.listArray (0,8) + [ "eax", "ebx", "ecx", "edx" + , "ebp", "esi", "edi", "esp" ] + in Just $ names A.! i + + RegSub SubL16 (Reg ClassG32 i) + | i <= 7 -> + let names = A.listArray (0,8) + [ "ax", "bx", "cx", "dx" + , "bp", "si", "di", "sp"] + in Just $ names A.! i + + RegSub SubL8 (Reg ClassG32 i) + | i <= 3 -> + let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"] + in Just $ names A.! i + + RegSub SubL8H (Reg ClassG32 i) + | i <= 3 -> + let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"] + in Just $ names A.! i + + _ -> Nothing + + +-- | Which regs alias what other regs. +regAlias :: Reg -> UniqSet Reg +regAlias reg + = case reg of + + -- 32 bit regs alias all of the subregs + Reg ClassG32 i + + -- for eax, ebx, ecx, eds + | i <= 3 + -> mkUniqSet + $ [ Reg ClassG32 i, RegSub SubL16 reg + , RegSub SubL8 reg, RegSub SubL8H reg ] + + -- for esi, edi, esp, ebp + | 4 <= i && i <= 7 + -> mkUniqSet + $ [ Reg ClassG32 i, RegSub SubL16 reg ] + + -- 16 bit subregs alias the whole reg + RegSub SubL16 r@(Reg ClassG32 _) + -> regAlias r + + -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg + RegSub SubL8 r@(Reg ClassG32 _) + -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] + + RegSub SubL8H r@(Reg ClassG32 _) + -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] + + -- fp + Reg ClassF64 _ + -> unitUniqSet reg + + _ -> error "regAlias: invalid register" + + +-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86 +worst :: Int -> RegClass -> RegClass -> Int +worst n classN classC + = case classN of + ClassG32 + -> case classC of + ClassG32 -> min n 8 + ClassG16 -> min n 8 + ClassG8 -> min n 4 + ClassF64 -> 0 + + ClassG16 + -> case classC of + ClassG32 -> min n 8 + ClassG16 -> min n 8 + ClassG8 -> min n 4 + ClassF64 -> 0 + + ClassG8 + -> case classC of + ClassG32 -> min (n*2) 8 + ClassG16 -> min (n*2) 8 + ClassG8 -> min n 8 + ClassF64 -> 0 + + ClassF64 + -> case classC of + ClassF64 -> min n 6 + _ -> 0 + +squeese :: RegClass -> [(Int, RegClass)] -> Int +squeese classN countCs + = sum (map (\(i, classC) -> worst i classN classC) countCs) + diff --git a/GHC/CmmToAsm/Reg/Linear.hs b/GHC/CmmToAsm/Reg/Linear.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear.hs @@ -0,0 +1,962 @@ +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- The register allocator +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +{- +The algorithm is roughly: + + 1) Compute strongly connected components of the basic block list. + + 2) Compute liveness (mapping from pseudo register to + point(s) of death?). + + 3) Walk instructions in each basic block. We keep track of + (a) Free real registers (a bitmap?) + (b) Current assignment of temporaries to machine registers and/or + spill slots (call this the "assignment"). + (c) Partial mapping from basic block ids to a virt-to-loc mapping. + When we first encounter a branch to a basic block, + we fill in its entry in this table with the current mapping. + + For each instruction: + (a) For each temporary *read* by the instruction: + If the temporary does not have a real register allocation: + - Allocate a real register from the free list. If + the list is empty: + - Find a temporary to spill. Pick one that is + not used in this instruction (ToDo: not + used for a while...) + - generate a spill instruction + - If the temporary was previously spilled, + generate an instruction to read the temp from its spill loc. + (optimisation: if we can see that a real register is going to + be used soon, then don't use it for allocation). + + (b) For each real register clobbered by this instruction: + If a temporary resides in it, + If the temporary is live after this instruction, + Move the temporary to another (non-clobbered & free) reg, + or spill it to memory. Mark the temporary as residing + in both memory and a register if it was spilled (it might + need to be read by this instruction). + + (ToDo: this is wrong for jump instructions?) + + We do this after step (a), because if we start with + movq v1, %rsi + which is an instruction that clobbers %rsi, if v1 currently resides + in %rsi we want to get + movq %rsi, %freereg + movq %rsi, %rsi -- will disappear + instead of + movq %rsi, %freereg + movq %freereg, %rsi + + (c) Update the current assignment + + (d) If the instruction is a branch: + if the destination block already has a register assignment, + Generate a new block with fixup code and redirect the + jump to the new block. + else, + Update the block id->assignment mapping with the current + assignment. + + (e) Delete all register assignments for temps which are read + (only) and die here. Update the free register list. + + (f) Mark all registers clobbered by this instruction as not free, + and mark temporaries which have been spilled due to clobbering + as in memory (step (a) marks then as in both mem & reg). + + (g) For each temporary *written* by this instruction: + Allocate a real register as for (b), spilling something + else if necessary. + - except when updating the assignment, drop any memory + locations that the temporary was previously in, since + they will be no longer valid after this instruction. + + (h) Delete all register assignments for temps which are + written and die here (there should rarely be any). Update + the free register list. + + (i) Rewrite the instruction with the new mapping. + + (j) For each spilled reg known to be now dead, re-add its stack slot + to the free list. + +-} + +module GHC.CmmToAsm.Reg.Linear ( + regAlloc, + module GHC.CmmToAsm.Reg.Linear.Base, + module GHC.CmmToAsm.Reg.Linear.Stats + ) where + +#include "HsVersions.h" + + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.State +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Linear.StackMap +import GHC.CmmToAsm.Reg.Linear.FreeRegs +import GHC.CmmToAsm.Reg.Linear.Stats +import GHC.CmmToAsm.Reg.Linear.JoinToTargets +import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC +import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC +import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 +import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Reg.Utils +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config +import GHC.Platform.Reg + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm hiding (RegSet) + +import GHC.Data.Graph.Directed +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Platform + +import Data.Maybe +import Data.List +import Control.Monad + +-- ----------------------------------------------------------------------------- +-- Top level of the register allocator + +-- Allocate registers +regAlloc + :: (Outputable instr, Instruction instr) + => NCGConfig + -> LiveCmmDecl statics instr + -> UniqSM ( NatCmmDecl statics instr + , Maybe Int -- number of extra stack slots required, + -- beyond maxSpillSlots + , Maybe RegAllocStats + ) + +regAlloc _ (CmmData sec d) + = return + ( CmmData sec d + , Nothing + , Nothing ) + +regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) + = return ( CmmProc info lbl live (ListGraph []) + , Nothing + , Nothing ) + +regAlloc config (CmmProc static lbl live sccs) + | LiveInfo info entry_ids@(first_id:_) block_live _ <- static + = do + -- do register allocation on each component. + (final_blocks, stats, stack_use) + <- linearRegAlloc config entry_ids block_live sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output + let ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks + + let max_spill_slots = maxSpillSlots config + extra_stack + | stack_use > max_spill_slots + = Just (stack_use - max_spill_slots) + | otherwise + = Nothing + + return ( CmmProc info lbl live (ListGraph (first' : rest')) + , extra_stack + , Just stats) + +-- bogus. to make non-exhaustive match warning go away. +regAlloc _ (CmmProc _ _ _ _) + = panic "RegAllocLinear.regAlloc: no match" + + +-- ----------------------------------------------------------------------------- +-- Linear sweep to allocate registers + + +-- | Do register allocation on some basic blocks. +-- But be careful to allocate a block in an SCC only if it has +-- an entry in the block map or it is the first block. +-- +linearRegAlloc + :: (Outputable instr, Instruction instr) + => NCGConfig + -> [BlockId] -- ^ entry points + -> BlockMap RegSet + -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] + -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) + +linearRegAlloc config entry_ids block_live sccs + = case platformArch platform of + ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) + ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) + ArchS390X -> panic "linearRegAlloc ArchS390X" + ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) + ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64" + ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" + ArchAArch64 -> panic "linearRegAlloc ArchAArch64" + ArchPPC_64 _ -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchAlpha -> panic "linearRegAlloc ArchAlpha" + ArchMipseb -> panic "linearRegAlloc ArchMipseb" + ArchMipsel -> panic "linearRegAlloc ArchMipsel" + ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" + where + go f = linearRegAlloc' config f entry_ids block_live sccs + platform = ncgPlatform config + +-- | Constraints on the instruction instances used by the +-- linear allocator. +type OutputableRegConstraint freeRegs instr = + (FR freeRegs, Outputable freeRegs, Outputable instr, Instruction instr) + +linearRegAlloc' + :: OutputableRegConstraint freeRegs instr + => NCGConfig + -> freeRegs + -> [BlockId] -- ^ entry points + -> BlockMap RegSet -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) + +linearRegAlloc' config initFreeRegs entry_ids block_live sccs + = do us <- getUniqueSupplyM + let !(_, !stack, !stats, !blocks) = + runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us + $ linearRA_SCCs entry_ids block_live [] sccs + return (blocks, stats, getStackUse stack) + + +linearRA_SCCs :: OutputableRegConstraint freeRegs instr + => [BlockId] + -> BlockMap RegSet + -> [NatBasicBlock instr] + -> [SCC (LiveBasicBlock instr)] + -> RegM freeRegs [NatBasicBlock instr] + +linearRA_SCCs _ _ blocksAcc [] + = return $ reverse blocksAcc + +linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock block_live block + linearRA_SCCs entry_ids block_live + ((reverse blocks') ++ blocksAcc) + sccs + +linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) + = do + blockss' <- process entry_ids block_live blocks [] (return []) False + linearRA_SCCs entry_ids block_live + (reverse (concat blockss') ++ blocksAcc) + sccs + +{- from John Dias's patch 2008/10/16: + The linear-scan allocator sometimes allocates a block + before allocating one of its predecessors, which could lead to + inconsistent allocations. Make it so a block is only allocated + if a predecessor has set the "incoming" assignments for the block, or + if it's the procedure's entry block. + + BL 2009/02: Careful. If the assignment for a block doesn't get set for + some reason then this function will loop. We should probably do some + more sanity checking to guard against this eventuality. +-} + +process :: OutputableRegConstraint freeRegs instr + => [BlockId] + -> BlockMap RegSet + -> [GenBasicBlock (LiveInstr instr)] + -> [GenBasicBlock (LiveInstr instr)] + -> [[NatBasicBlock instr]] + -> Bool + -> RegM freeRegs [[NatBasicBlock instr]] + +process _ _ [] [] accum _ + = return $ reverse accum + +process entry_ids block_live [] next_round accum madeProgress + | not madeProgress + + {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. + pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." + ( text "Unreachable blocks:" + $$ vcat (map ppr next_round)) -} + = return $ reverse accum + + | otherwise + = process entry_ids block_live + next_round [] accum False + +process entry_ids block_live (b@(BasicBlock id _) : blocks) + next_round accum madeProgress + = do + block_assig <- getBlockAssigR + + if isJust (lookupBlockAssignment id block_assig) + || id `elem` entry_ids + then do + b' <- processBlock block_live b + process entry_ids block_live blocks + next_round (b' : accum) True + + else process entry_ids block_live blocks + (b : next_round) accum madeProgress + + +-- | Do register allocation on this basic block +-- +processBlock + :: OutputableRegConstraint freeRegs instr + => BlockMap RegSet -- ^ live regs on entry to each basic block + -> LiveBasicBlock instr -- ^ block to do register allocation on + -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated + +processBlock block_live (BasicBlock id instrs) + = do -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs) + initBlock id block_live + + (instrs', fixups) + <- linearRA block_live [] [] id instrs + -- pprTraceM "blockResult" $ ppr (instrs', fixups) + return $ BasicBlock id instrs' : fixups + + +-- | Load the freeregs and current reg assignment into the RegM state +-- for the basic block with this BlockId. +initBlock :: FR freeRegs + => BlockId -> BlockMap RegSet -> RegM freeRegs () +initBlock id block_live + = do platform <- getPlatform + block_assig <- getBlockAssigR + case lookupBlockAssignment id block_assig of + -- no prior info about this block: we must consider + -- any fixed regs to be allocated, but we can ignore + -- virtual regs (presumably this is part of a loop, + -- and we'll iterate again). The assignment begins + -- empty. + Nothing + -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) + case mapLookup id block_live of + Nothing -> + setFreeRegsR (frInitFreeRegs platform) + Just live -> + setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) + [ r | RegReal r <- nonDetEltsUniqSet live ] + -- See Note [Unique Determinism and code generation] + setAssigR emptyRegMap + + -- load info about register assignments leading into this block. + Just (freeregs, assig) + -> do setFreeRegsR freeregs + setAssigR assig + + +-- | Do allocation for a sequence of instructions. +linearRA + :: OutputableRegConstraint freeRegs instr + => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. + -> BlockId -- ^ id of the current block, for debugging. + -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. + + -> RegM freeRegs + ( [instr] -- instructions after register allocation + , [NatBasicBlock instr]) -- fresh blocks of fixup code. + + +linearRA _ accInstr accFixup _ [] + = return + ( reverse accInstr -- instrs need to be returned in the correct order. + , accFixup) -- it doesn't matter what order the fixup blocks are returned in. + + +linearRA block_live accInstr accFixups id (instr:instrs) + = do + (accInstr', new_fixups) <- raInsn block_live accInstr id instr + + linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + + +-- | Do allocation for a single instruction. +raInsn + :: OutputableRegConstraint freeRegs instr + => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> BlockId -- ^ the id of the current block, for debugging + -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. + -> RegM freeRegs + ( [instr] -- new instructions + , [NatBasicBlock instr]) -- extra fixup blocks + +raInsn _ new_instrs _ (LiveInstr ii Nothing) + | Just n <- takeDeltaInstr ii + = do setDeltaR n + return (new_instrs, []) + +raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing) + | isMetaInstr ii + = return (i : new_instrs, []) + + +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) + = do + assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + + -- If we have a reg->reg move between virtual registers, where the + -- src register is not live after this instruction, and the dst + -- register does not already have an assignment, + -- and the source register is assigned to a register, not to a spill slot, + -- then we can eliminate the instruction. + -- (we can't eliminate it if the source register is on the stack, because + -- we do not want to use one spill slot for different virtual registers) + case takeRegRegMoveInstr instr of + Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), + isVirtualReg dst, + not (dst `elemUFM` assig), + isRealReg src || isInReg src assig -> do + case src of + (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) + -- if src is a fixed reg, then we just map dest to this + -- reg in the assignment. src must be an allocatable reg, + -- otherwise it wouldn't be in r_dying. + _virt -> case lookupUFM assig src of + Nothing -> panic "raInsn" + Just loc -> + setAssigR (addToUFM (delFromUFM assig src) dst loc) + + -- we have eliminated this instruction + {- + freeregs <- getFreeRegsR + assig <- getAssigR + pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) + $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do + -} + return (new_instrs, []) + + _ -> genRaInsn block_live new_instrs id instr + (nonDetEltsUniqSet $ liveDieRead live) + (nonDetEltsUniqSet $ liveDieWrite live) + -- See Note [Unique Determinism and code generation] + +raInsn _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> ppr instr) + +-- ToDo: what can we do about +-- +-- R1 = x +-- jump I64[x] // [R1] +-- +-- where x is mapped to the same reg as R1. We want to coalesce x and +-- R1, but the register allocator doesn't know whether x will be +-- assigned to again later, in which case x and R1 should be in +-- different registers. Right now we assume the worst, and the +-- assignment to R1 will clobber x, so we'll spill x into another reg, +-- generating another reg->reg move. + + +isInReg :: Reg -> RegMap Loc -> Bool +isInReg src assig | Just (InReg _) <- lookupUFM assig src = True + | otherwise = False + + +genRaInsn :: forall freeRegs instr. + OutputableRegConstraint freeRegs instr + => BlockMap RegSet + -> [instr] + -> BlockId + -> instr + -> [Reg] + -> [Reg] + -> RegM freeRegs ([instr], [NatBasicBlock instr]) + +genRaInsn block_live new_instrs block_id instr r_dying w_dying = do +-- pprTraceM "genRaInsn" $ ppr (block_id, instr) + platform <- getPlatform + case regUsageOfInstr platform instr of { RU read written -> + do + let real_written = [ rr | (RegReal rr) <- written ] :: [RealReg] + let virt_written = [ vr | (RegVirtual vr) <- written ] + + -- we don't need to do anything with real registers that are + -- only read by this instr. (the list is typically ~2 elements, + -- so using nub isn't a problem). + let virt_read = nub [ vr | (RegVirtual vr) <- read ] :: [VirtualReg] + + -- debugging +{- freeregs <- getFreeRegsR + assig <- getAssigR + pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn" + (ppr instr + $$ text "r_dying = " <+> ppr r_dying + $$ text "w_dying = " <+> ppr w_dying + $$ text "virt_read = " <+> ppr virt_read + $$ text "virt_written = " <+> ppr virt_written + $$ text "freeregs = " <+> text (show freeregs) + $$ text "assig = " <+> ppr assig) + $ do +-} + + -- (a), (b) allocate real regs for all regs read by this instruction. + (r_spills, r_allocd) <- + allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read + + -- (c) save any temporaries which will be clobbered by this instruction + clobber_saves <- saveClobberedTemps real_written r_dying + + -- (d) Update block map for new destinations + -- NB. do this before removing dead regs from the assignment, because + -- these dead regs might in fact be live in the jump targets (they're + -- only dead in the code that follows in the current basic block). + (fixup_blocks, adjusted_instr) + <- joinToTargets block_live block_id instr + +-- when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks + + -- Debugging - show places where the reg alloc inserted + -- assignment fixup blocks. + -- when (not $ null fixup_blocks) $ + -- pprTrace "fixup_blocks" (ppr fixup_blocks) (return ()) + + -- (e) Delete all register assignments for temps which are read + -- (only) and die here. Update the free register list. + releaseRegs r_dying + + -- (f) Mark regs which are clobbered as unallocatable + clobberRegs real_written + + -- (g) Allocate registers for temporaries *written* (only) + (w_spills, w_allocd) <- + allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written + + -- (h) Release registers for temps which are written here and not + -- used again. + releaseRegs w_dying + + let + -- (i) Patch the instruction + patch_map :: UniqFM Reg Reg + patch_map + = toRegMap $ -- Cast key from VirtualReg to Reg + -- See Note [UniqFM and the register allocator] + listToUFM + [ (t, RegReal r) + | (t, r) <- zip virt_read r_allocd + ++ zip virt_written w_allocd ] + + patched_instr :: instr + patched_instr + = patchRegsOfInstr adjusted_instr patchLookup + + patchLookup :: Reg -> Reg + patchLookup x + = case lookupUFM patch_map x of + Nothing -> x + Just y -> y + + + -- (j) free up stack slots for dead spilled regs + -- TODO (can't be bothered right now) + + -- erase reg->reg moves where the source and destination are the same. + -- If the src temp didn't die in this instr but happened to be allocated + -- to the same real reg as the destination, then we can erase the move anyway. + let squashed_instr = case takeRegRegMoveInstr patched_instr of + Just (src, dst) + | src == dst -> [] + _ -> [patched_instr] + + let code = squashed_instr ++ w_spills ++ reverse r_spills + ++ clobber_saves ++ new_instrs + +-- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do +-- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do + + return (code, fixup_blocks) + + } + +-- ----------------------------------------------------------------------------- +-- releaseRegs + +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () +releaseRegs regs = do + platform <- getPlatform + assig <- getAssigR + free <- getFreeRegsR + let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () + loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs + loop assig !free (r:rs) = + case lookupUFM assig r of + Just (InBoth real _) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + Just (InReg real) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + _ -> loop (delFromUFM assig r) free rs + loop assig free regs + + +-- ----------------------------------------------------------------------------- +-- Clobber real registers + +-- For each temp in a register that is going to be clobbered: +-- - if the temp dies after this instruction, do nothing +-- - otherwise, put it somewhere safe (another reg if possible, +-- otherwise spill and record InBoth in the assignment). +-- - for allocateRegs on the temps *read*, +-- - clobbered regs are allocatable. +-- +-- for allocateRegs on the temps *written*, +-- - clobbered regs are not allocatable. +-- + +saveClobberedTemps + :: forall instr freeRegs. + (Instruction instr, FR freeRegs) + => [RealReg] -- real registers clobbered by this instruction + -> [Reg] -- registers which are no longer live after this insn + -> RegM freeRegs [instr] -- return: instructions to spill any temps that will + -- be clobbered. + +saveClobberedTemps [] _ + = return [] + +saveClobberedTemps clobbered dying + = do + assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + -- Unique represents the VirtualReg + let to_spill :: [(Unique, RealReg)] + to_spill + = [ (temp,reg) + | (temp, InReg reg) <- nonDetUFMToList assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + , any (realRegsAlias reg) clobbered + , temp `notElem` map getUnique dying ] + + (instrs,assig') <- clobber assig [] to_spill + setAssigR assig' + return instrs + + where + -- See Note [UniqFM and the register allocator] + clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc) + clobber assig instrs [] + = return (instrs, assig) + + clobber assig instrs ((temp, reg) : rest) + = do platform <- getPlatform + + freeRegs <- getFreeRegsR + let regclass = targetClassOfRealReg platform reg + freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs + + case filter (`notElem` clobbered) freeRegs_thisClass of + + -- (1) we have a free reg of the right class that isn't + -- clobbered by this instruction; use it to save the + -- clobbered value. + (my_reg : _) -> do + setFreeRegsR (frAllocateReg platform my_reg freeRegs) + + let new_assign = addToUFM_Directly assig temp (InReg my_reg) + let instr = mkRegRegMoveInstr platform + (RegReal reg) (RegReal my_reg) + + clobber new_assign (instr : instrs) rest + + -- (2) no free registers: spill the value + [] -> do + (spill, slot) <- spillR (RegReal reg) temp + + -- record why this reg was spilled for profiling + recordSpill (SpillClobber temp) + + let new_assign = addToUFM_Directly assig temp (InBoth reg slot) + + clobber new_assign (spill : instrs) rest + + + +-- | Mark all these real regs as allocated, +-- and kick out their vreg assignments. +-- +clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () +clobberRegs [] + = return () + +clobberRegs clobbered + = do platform <- getPlatform + freeregs <- getFreeRegsR + setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered + + assig <- getAssigR + setAssigR $! clobber assig (nonDetUFMToList assig) + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + + where + -- if the temp was InReg and clobbered, then we will have + -- saved it in saveClobberedTemps above. So the only case + -- we have to worry about here is InBoth. Note that this + -- also catches temps which were loaded up during allocation + -- of read registers, not just those saved in saveClobberedTemps. + + clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc + clobber assig [] + = assig + + clobber assig ((temp, InBoth reg slot) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM_Directly assig temp (InMem slot)) rest + + clobber assig (_:rest) + = clobber assig rest + +-- ----------------------------------------------------------------------------- +-- allocateRegsAndSpill + +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + +-- This function does several things: +-- For each temporary referred to by this instruction, +-- we allocate a real register (spilling another temporary if necessary). +-- We load the temporary up from memory if necessary. +-- We also update the register assignment in the process, and +-- the list of free registers and free stack slots. + +allocateRegsAndSpill + :: forall freeRegs instr. (FR freeRegs, Outputable instr, Instruction instr) + => Bool -- True <=> reading (load up spilled regs) + -> [VirtualReg] -- don't push these out + -> [instr] -- spill insns + -> [RealReg] -- real registers allocated (accum.) + -> [VirtualReg] -- temps to allocate + -> RegM freeRegs ( [instr] , [RealReg]) + +allocateRegsAndSpill _ _ spills alloc [] + = return (spills, reverse alloc) + +allocateRegsAndSpill reading keep spills alloc (r:rs) + = do assig <- toVRegMap <$> getAssigR + -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig) + -- See Note [UniqFM and the register allocator] + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig + case lookupUFM assig r of + -- case (1a): already in a register + Just (InReg my_reg) -> + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- case (1b): already in a register (and memory) + -- NB1. if we're writing this register, update its assignment to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + Just (InBoth my_reg _) + -> do when (not reading) (setAssigR $ toRegMap (addToUFM assig r (InReg my_reg))) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- Not already in a register, so we need to find a free one... + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- NOTE: if the input to the NCG contains some + -- unreachable blocks with junk code, this panic + -- might be triggered. Make sure you only feed + -- sensible code into the NCG. In GHC.Cmm.Pipeline we + -- call removeUnreachableBlocks at the end for this + -- reason. + + | otherwise -> doSpill WriteNew + +-- | Given a virtual reg find a preferred real register. +-- The preferred register is simply the first one the variable +-- was assigned to (if any). This way when we allocate for a loop +-- variables are likely to end up in the same registers at the +-- end and start of the loop, avoiding redundant reg-reg moves. +-- Note: I tried returning a list of past assignments, but that +-- turned out to barely matter. +findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg) +findPrefRealReg vreg = do + bassig <- getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) + return $ lookupFirstUsed vreg bassig + +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) + => Bool + -> [VirtualReg] + -> [instr] + -> [RealReg] + -> VirtualReg + -> [VirtualReg] + -> UniqFM VirtualReg Loc + -> SpillLoc + -> RegM freeRegs ([instr], [RealReg]) +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc + = do platform <- getPlatform + freeRegs <- getFreeRegsR + let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg] + + -- Can we put the variable into a register it already was? + pref_reg <- findPrefRealReg r + + case freeRegs_thisClass of + -- case (2): we have a free register + (first_free : _) -> + do let final_reg + | Just reg <- pref_reg + , reg `elem` freeRegs_thisClass + = reg + | otherwise + = first_free + spills' <- loadTemp r spill_loc final_reg spills + + setAssigR $ toRegMap + $ (addToUFM assig r $! newLocation spill_loc final_reg) + setFreeRegsR $ frAllocateReg platform final_reg freeRegs + + allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs + + + -- case (3): we need to push something out to free up a register + [] -> + do let inRegOrBoth (InReg _) = True + inRegOrBoth (InBoth _ _) = True + inRegOrBoth _ = False + let candidates' :: UniqFM VirtualReg Loc + candidates' = + flip delListFromUFM keep $ + filterUFM inRegOrBoth $ + assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + let candidates = nonDetUFMToList candidates' + + -- the vregs we could kick out that are already in a slot + let candidates_inBoth :: [(Unique, RealReg, StackSlot)] + candidates_inBoth + = [ (temp, reg, mem) + | (temp, InBoth reg mem) <- candidates + , targetClassOfRealReg platform reg == classOfVirtualReg r ] + + -- the vregs we could kick out that are only in a reg + -- this would require writing the reg to a new slot before using it. + let candidates_inReg + = [ (temp, reg) + | (temp, InReg reg) <- candidates + , targetClassOfRealReg platform reg == classOfVirtualReg r ] + + let result + + -- we have a temporary that is in both register and mem, + -- just free up its register for use. + | (temp, my_reg, slot) : _ <- candidates_inBoth + = do spills' <- loadTemp r spill_loc my_reg spills + let assig1 = addToUFM_Directly assig temp (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + + setAssigR $ toRegMap assig2 + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + + -- otherwise, we need to spill a temporary that currently + -- resides in a register. + | (temp_to_push_out, (my_reg :: RealReg)) : _ + <- candidates_inReg + = do + (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + let spill_store = (if reading then id else reverse) + [ -- COMMENT (fsLit "spill alloc") + spill_insn ] + + -- record that this temp was spilled + recordSpill (SpillAlloc temp_to_push_out) + + -- update the register assignment + let assig1 = addToUFM_Directly assig temp_to_push_out (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + setAssigR $ toRegMap assig2 + + -- if need be, load up a spilled temp into the reg we've just freed up. + spills' <- loadTemp r spill_loc my_reg spills + + allocateRegsAndSpill reading keep + (spill_store ++ spills') + (my_reg:alloc) rs + + + -- there wasn't anything to spill, so we're screwed. + | otherwise + = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") + $ vcat + [ text "allocating vreg: " <> text (show r) + , text "assignment: " <> ppr assig + , text "freeRegs: " <> text (show freeRegs) + , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] + + result + + +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg + +-- | Load up a spilled temporary if we need to (read from memory). +loadTemp + :: (Instruction instr) + => VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp + -> RealReg -- the hreg to load the temp into + -> [instr] + -> RegM freeRegs [instr] + +loadTemp vreg (ReadMem slot) hreg spills + = do + insn <- loadR (RegReal hreg) slot + recordSpill (SpillLoad $ getUnique vreg) + return $ {- COMMENT (fsLit "spill load") : -} insn : spills + +loadTemp _ _ _ spills = + return spills + diff --git a/GHC/CmmToAsm/Reg/Linear/Base.hs b/GHC/CmmToAsm/Reg/Linear/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Put common type definitions here to break recursive module dependencies. + +module GHC.CmmToAsm.Reg.Linear.Base ( + BlockAssignment, + lookupBlockAssignment, + lookupFirstUsed, + emptyBlockAssignment, + updateBlockAssignment, + + Loc(..), + regsOfLoc, + + -- for stats + SpillReason(..), + RegAllocStats(..), + + -- the allocator monad + RA_State(..), +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.StackMap +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Config +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.CmmToAsm.Reg.Utils + +data ReadingOrWriting = Reading | Writing deriving (Eq,Ord) + +-- | Used to store the register assignment on entry to a basic block. +-- We use this to handle join points, where multiple branch instructions +-- target a particular label. We have to insert fixup code to make +-- the register assignments from the different sources match up. +-- +data BlockAssignment freeRegs + = BlockAssignment { blockMap :: !(BlockMap (freeRegs, RegMap Loc)) + , firstUsed :: !(UniqFM VirtualReg RealReg) } + +-- | Find the register mapping for a specific BlockId. +lookupBlockAssignment :: BlockId -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc) +lookupBlockAssignment bid ba = mapLookup bid (blockMap ba) + +-- | Lookup which register a virtual register was first assigned to. +lookupFirstUsed :: VirtualReg -> BlockAssignment freeRegs -> Maybe RealReg +lookupFirstUsed vr ba = lookupUFM (firstUsed ba) vr + +-- | An initial empty 'BlockAssignment' +emptyBlockAssignment :: BlockAssignment freeRegs +emptyBlockAssignment = BlockAssignment mapEmpty mempty + +-- | Add new register mappings for a specific block. +updateBlockAssignment :: BlockId + -> (freeRegs, RegMap Loc) + -> BlockAssignment freeRegs + -> BlockAssignment freeRegs +updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) = + BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap) + (mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap)) + where + -- The blocks are processed in dependency order, so if there's already an + -- entry in the map then keep that assignment rather than writing the new + -- assignment. + combWithExisting :: RealReg -> Loc -> Maybe RealReg + combWithExisting old_reg _ = Just $ old_reg + + fromLoc :: Loc -> Maybe RealReg + fromLoc (InReg rr) = Just rr + fromLoc (InBoth rr _) = Just rr + fromLoc _ = Nothing + + +-- | Where a vreg is currently stored +-- A temporary can be marked as living in both a register and memory +-- (InBoth), for example if it was recently loaded from a spill location. +-- This makes it cheap to spill (no save instruction required), but we +-- have to be careful to turn this into InReg if the value in the +-- register is changed. + +-- This is also useful when a temporary is about to be clobbered. We +-- save it in a spill location, but mark it as InBoth because the current +-- instruction might still want to read it. +-- +data Loc + -- | vreg is in a register + = InReg !RealReg + + -- | vreg is held in a stack slot + | InMem {-# UNPACK #-} !StackSlot + + + -- | vreg is held in both a register and a stack slot + | InBoth !RealReg + {-# UNPACK #-} !StackSlot + deriving (Eq, Show, Ord) + +instance Outputable Loc where + ppr l = text (show l) + + +-- | Get the reg numbers stored in this Loc. +regsOfLoc :: Loc -> [RealReg] +regsOfLoc (InReg r) = [r] +regsOfLoc (InBoth r _) = [r] +regsOfLoc (InMem _) = [] + + +-- | Reasons why instructions might be inserted by the spiller. +-- Used when generating stats for -ddrop-asm-stats. +-- +data SpillReason + -- | vreg was spilled to a slot so we could use its + -- current hreg for another vreg + = SpillAlloc !Unique + + -- | vreg was moved because its hreg was clobbered + | SpillClobber !Unique + + -- | vreg was loaded from a spill slot + | SpillLoad !Unique + + -- | reg-reg move inserted during join to targets + | SpillJoinRR !Unique + + -- | reg-mem move inserted during join to targets + | SpillJoinRM !Unique + + +-- | Used to carry interesting stats out of the register allocator. +data RegAllocStats + = RegAllocStats + { ra_spillInstrs :: UniqFM Unique [Int] -- Keys are the uniques of regs + -- and taken from SpillReason + -- See Note [UniqFM and the register allocator] + , ra_fixupList :: [(BlockId,BlockId,BlockId)] + -- ^ (from,fixup,to) : We inserted fixup code between from and to + } + + +-- | The register allocator state +data RA_State freeRegs + = RA_State + + { + -- | the current mapping from basic blocks to + -- the register assignments at the beginning of that block. + ra_blockassig :: BlockAssignment freeRegs + + -- | free machine registers + , ra_freeregs :: !freeRegs + + -- | assignment of temps to locations + , ra_assig :: RegMap Loc + + -- | current stack delta + , ra_delta :: Int + + -- | free stack slots for spilling + , ra_stack :: StackMap + + -- | unique supply for generating names for join point fixup blocks. + , ra_us :: UniqSupply + + -- | Record why things were spilled, for -ddrop-asm-stats. + -- Just keep a list here instead of a map of regs -> reasons. + -- We don't want to slow down the allocator if we're not going to emit the stats. + , ra_spills :: [SpillReason] + + -- | Native code generator configuration + , ra_config :: !NCGConfig + + -- | (from,fixup,to) : We inserted fixup code between from and to + , ra_fixups :: [(BlockId,BlockId,BlockId)] + + } + + diff --git a/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE CPP #-} + +module GHC.CmmToAsm.Reg.Linear.FreeRegs ( + FR(..), + maxSpillSlots +) + +#include "HsVersions.h" + +where + +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class + +import GHC.CmmToAsm.Config +import GHC.Utils.Panic +import GHC.Platform + +-- ----------------------------------------------------------------------------- +-- The free register set +-- This needs to be *efficient* +-- Here's an inefficient 'executable specification' of the FreeRegs data type: +-- +-- type FreeRegs = [RegNo] +-- noFreeRegs = 0 +-- releaseReg n f = if n `elem` f then f else (n : f) +-- initFreeRegs = allocatableRegs +-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f +-- allocateReg f r = filter (/= r) f + +import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC +import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC +import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 +import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 + +import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr +import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr +import qualified GHC.CmmToAsm.X86.Instr as X86.Instr + +class Show freeRegs => FR freeRegs where + frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs + frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] + frInitFreeRegs :: Platform -> freeRegs + frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs + +instance FR X86.FreeRegs where + frAllocateReg = \_ -> X86.allocateReg + frGetFreeRegs = X86.getFreeRegs + frInitFreeRegs = X86.initFreeRegs + frReleaseReg = \_ -> X86.releaseReg + +instance FR X86_64.FreeRegs where + frAllocateReg = \_ -> X86_64.allocateReg + frGetFreeRegs = X86_64.getFreeRegs + frInitFreeRegs = X86_64.initFreeRegs + frReleaseReg = \_ -> X86_64.releaseReg + +instance FR PPC.FreeRegs where + frAllocateReg = \_ -> PPC.allocateReg + frGetFreeRegs = \_ -> PPC.getFreeRegs + frInitFreeRegs = PPC.initFreeRegs + frReleaseReg = \_ -> PPC.releaseReg + +instance FR SPARC.FreeRegs where + frAllocateReg = SPARC.allocateReg + frGetFreeRegs = \_ -> SPARC.getFreeRegs + frInitFreeRegs = SPARC.initFreeRegs + frReleaseReg = SPARC.releaseReg + +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config = case platformArch (ncgPlatform config) of + ArchX86 -> X86.Instr.maxSpillSlots config + ArchX86_64 -> X86.Instr.maxSpillSlots config + ArchPPC -> PPC.Instr.maxSpillSlots config + ArchS390X -> panic "maxSpillSlots ArchS390X" + ArchSPARC -> SPARC.Instr.maxSpillSlots config + ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" + ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" + ArchAArch64 -> panic "maxSpillSlots ArchAArch64" + ArchPPC_64 _ -> PPC.Instr.maxSpillSlots config + ArchAlpha -> panic "maxSpillSlots ArchAlpha" + ArchMipseb -> panic "maxSpillSlots ArchMipseb" + ArchMipsel -> panic "maxSpillSlots ArchMipsel" + ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" + ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -0,0 +1,378 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handles joining of a jump instruction to its targets. + +-- The first time we encounter a jump to a particular basic block, we +-- record the assignment of temporaries. The next time we encounter a +-- jump to the same block, we compare our current assignment to the +-- stored one. They might be different if spilling has occurred in one +-- branch; so some fixup code will be required to match up the assignments. +-- +module GHC.CmmToAsm.Reg.Linear.JoinToTargets (joinToTargets) where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.State +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Linear.FreeRegs +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config +import GHC.Platform.Reg + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Data.Graph.Directed +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set + +-- | For a jump instruction at the end of a block, generate fixup code so its +-- vregs are in the correct regs for its destination. +-- +joinToTargets + :: (FR freeRegs, Instruction instr, Outputable instr) + => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. + + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. + + -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. + , instr) -- the original branch + -- instruction, but maybe + -- patched to jump + -- to a fixup block first. + +joinToTargets block_live id instr + + -- we only need to worry about jump instructions. + | not $ isJumpishInstr instr + = return ([], instr) + + | otherwise + = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + +----- +joinToTargets' + :: (FR freeRegs, Instruction instr, Outputable instr) + => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. + + -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. + + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. + + -> [BlockId] -- ^ branch destinations still to consider. + + -> RegM freeRegs ([NatBasicBlock instr], instr) + +-- no more targets to consider. all done. +joinToTargets' _ new_blocks _ instr [] + = return (new_blocks, instr) + +-- handle a branch target. +joinToTargets' block_live new_blocks block_id instr (dest:dests) + = do + -- get the map of where the vregs are stored on entry to each basic block. + block_assig <- getBlockAssigR + + -- get the assignment on entry to the branch instruction. + assig <- getAssigR + + -- adjust the current assignment to remove any vregs that are not live + -- on entry to the destination block. + let Just live_set = mapLookup dest block_live + let still_live uniq _ = uniq `elemUniqSet_Directly` live_set + let adjusted_assig = filterUFM_Directly still_live assig + + -- and free up those registers which are now free. + let to_free = + [ r | (reg, loc) <- nonDetUFMToList assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + , not (elemUniqSet_Directly reg live_set) + , r <- regsOfLoc loc ] + + case lookupBlockAssignment dest block_assig of + Nothing + -> joinToTargets_first + block_live new_blocks block_id instr dest dests + block_assig adjusted_assig to_free + + Just (_, dest_assig) + -> joinToTargets_again + block_live new_blocks block_id instr dest dests + adjusted_assig dest_assig + + +-- this is the first time we jumped to this block. +joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr) + => BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> BlockAssignment freeRegs + -> RegMap Loc + -> [RealReg] + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_first block_live new_blocks block_id instr dest dests + block_assig src_assig + to_free + + = do config <- getConfig + let platform = ncgPlatform config + + -- free up the regs that are not live on entry to this block. + freeregs <- getFreeRegsR + let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free + + -- remember the current assignment on entry to this block. + setBlockAssigR (updateBlockAssignment dest (freeregs', src_assig) block_assig) + + joinToTargets' block_live new_blocks block_id instr dests + + +-- we've jumped to this block before +joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr) + => BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> UniqFM Reg Loc + -> UniqFM Reg Loc + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_again + block_live new_blocks block_id instr dest dests + src_assig dest_assig + + -- the assignments already match, no problem. + | nonDetUFMToList dest_assig == nonDetUFMToList src_assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + = joinToTargets' block_live new_blocks block_id instr dests + + -- assignments don't match, need fixup code + | otherwise + = do + + -- make a graph of what things need to be moved where. + let graph = makeRegMovementGraph src_assig dest_assig + + -- look for cycles in the graph. This can happen if regs need to be swapped. + -- Note that we depend on the fact that this function does a + -- bottom up traversal of the tree-like portions of the graph. + -- + -- eg, if we have + -- R1 -> R2 -> R3 + -- + -- ie move value in R1 to R2 and value in R2 to R3. + -- + -- We need to do the R2 -> R3 move before R1 -> R2. + -- + let sccs = stronglyConnCompFromEdgedVerticesOrdR graph + + -- debugging + {- + pprTrace + ("joinToTargets: making fixup code") + (vcat [ text " in block: " <> ppr block_id + , text " jmp instruction: " <> ppr instr + , text " src assignment: " <> ppr src_assig + , text " dest assignment: " <> ppr dest_assig + , text " movement graph: " <> ppr graph + , text " sccs of graph: " <> ppr sccs + , text ""]) + (return ()) + -} + delta <- getDeltaR + fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + let fixUpInstrs = concat fixUpInstrs_ + + -- make a new basic block containing the fixup code. + -- A the end of the current block we will jump to the fixup one, + -- then that will jump to our original destination. + fixup_block_id <- mkBlockId <$> getUniqueR + let block = BasicBlock fixup_block_id + $ fixUpInstrs ++ mkJumpInstr dest + + -- if we didn't need any fixups, then don't include the block + case fixUpInstrs of + [] -> joinToTargets' block_live new_blocks block_id instr dests + + -- patch the original branch instruction so it goes to our + -- fixup block instead. + _ -> let instr' = patchJumpInstr instr + (\bid -> if bid == dest + then fixup_block_id + else bid) -- no change! + + in do + {- --debugging + pprTrace "FixUpEdge info:" + ( + text "inBlock:" <> ppr block_id $$ + text "instr:" <> ppr instr $$ + text "instr':" <> ppr instr' $$ + text "fixup_block_id':" <> + ppr fixup_block_id $$ + text "dest:" <> ppr dest + ) (return ()) + -} + recordFixupBlock block_id fixup_block_id dest + joinToTargets' block_live (block : new_blocks) + block_id instr' dests + + +-- | Construct a graph of register\/spill movements. +-- +-- Cyclic components seem to occur only very rarely. +-- +-- We cut some corners by not handling memory-to-memory moves. +-- This shouldn't happen because every temporary gets its own stack slot. +-- +makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique] +makeRegMovementGraph adjusted_assig dest_assig + = [ node | (vreg, src) <- nonDetUFMToList adjusted_assig + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + -- source reg might not be needed at the dest: + , Just loc <- [lookupUFM_Directly dest_assig vreg] + , node <- expandNode vreg src loc ] + + +-- | Expand out the destination, so InBoth destinations turn into +-- a combination of InReg and InMem. + +-- The InBoth handling is a little tricky here. If the destination is +-- InBoth, then we must ensure that the value ends up in both locations. +-- An InBoth destination must conflict with an InReg or InMem source, so +-- we expand an InBoth destination as necessary. +-- +-- An InBoth source is slightly different: we only care about the register +-- that the source value is in, so that we can move it to the destinations. +-- +expandNode + :: a + -> Loc -- ^ source of move + -> Loc -- ^ destination of move + -> [Node Loc a ] + +expandNode vreg loc@(InReg src) (InBoth dst mem) + | src == dst = [DigraphNode vreg loc [InMem mem]] + | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] + +expandNode vreg loc@(InMem src) (InBoth dst mem) + | src == mem = [DigraphNode vreg loc [InReg dst]] + | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] + +expandNode _ (InBoth _ src) (InMem dst) + | src == dst = [] -- guaranteed to be true + +expandNode _ (InBoth src _) (InReg dst) + | src == dst = [] + +expandNode vreg (InBoth src _) dst + = expandNode vreg (InReg src) dst + +expandNode vreg src dst + | src == dst = [] + | otherwise = [DigraphNode vreg src [dst]] + + +-- | Generate fixup code for a particular component in the move graph +-- This component tells us what values need to be moved to what +-- destinations. We have eliminated any possibility of single-node +-- cycles in expandNode above. +-- +handleComponent + :: Instruction instr + => Int -> instr -> SCC (Node Loc Unique) + -> RegM freeRegs [instr] + +-- If the graph is acyclic then we won't get the swapping problem below. +-- In this case we can just do the moves directly, and avoid having to +-- go via a spill slot. +-- +handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts)) + = mapM (makeMove delta vreg src) dsts + + +-- Handle some cyclic moves. +-- This can happen if we have two regs that need to be swapped. +-- eg: +-- vreg source loc dest loc +-- (vreg1, InReg r1, [InReg r2]) +-- (vreg2, InReg r2, [InReg r1]) +-- +-- To avoid needing temp register, we just spill all the source regs, then +-- reaload them into their destination regs. +-- +-- Note that we can not have cycles that involve memory locations as +-- sources as single destination because memory locations (stack slots) +-- are allocated exclusively for a virtual register and therefore can not +-- require a fixup. +-- +handleComponent delta instr + (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest)) + -- dest list may have more than one element, if the reg is also InMem. + = do + -- spill the source into its slot + (instrSpill, slot) + <- spillR (RegReal sreg) vreg + + -- reload into destination reg + instrLoad <- loadR (RegReal dreg) slot + + remainingFixUps <- mapM (handleComponent delta instr) + (stronglyConnCompFromEdgedVerticesOrdR rest) + + -- make sure to do all the reloads after all the spills, + -- so we don't end up clobbering the source values. + return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) + +handleComponent _ _ (CyclicSCC _) + = panic "Register Allocator: handleComponent cyclic" + + +-- | Move a vreg between these two locations. +-- +makeMove + :: Instruction instr + => Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs instr -- ^ move instruction. + +makeMove delta vreg src dst + = do config <- getConfig + let platform = ncgPlatform config + + case (src, dst) of + (InReg s, InReg d) -> + do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) + (InMem s, InReg d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr config (RegReal d) delta s + (InReg s, InMem d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr config (RegReal s) delta d + _ -> + -- we don't handle memory to memory moves. + -- they shouldn't happen because we don't share + -- stack slots between vregs. + panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" + ++ show dst ++ ")" + ++ " we don't handle mem->mem moves.") + diff --git a/GHC/CmmToAsm/Reg/Linear/PPC.hs b/GHC/CmmToAsm/Reg/Linear/PPC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Free regs map for PowerPC +module GHC.CmmToAsm.Reg.Linear.PPC where + +import GHC.Prelude + +import GHC.CmmToAsm.PPC.Regs +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Platform + +import Data.Word +import Data.Bits + +-- The PowerPC has 32 integer and 32 floating point registers. +-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much +-- better. +-- Note that when getFreeRegs scans for free registers, it starts at register +-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered +-- registers are callee-saves, while the lower regs are caller-saves, so it +-- makes sense to start at the high end. +-- Apart from that, the code does nothing PowerPC-specific, so feel free to +-- add your favourite platform to the #if (if you have 64 registers but only +-- 32-bit words). + +data FreeRegs = FreeRegs !Word32 !Word32 + deriving( Show ) -- The Show is used in an ASSERT + +instance Outputable FreeRegs where + ppr = text . show + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 = FreeRegs g (f .|. (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f + +releaseReg _ _ + = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs g f) + | RcDouble <- cls = go f (0x80000000) 63 + | RcInteger <- cls = go g (0x80000000) 31 + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) + where + go _ 0 _ = [] + go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1) + | otherwise = go x (m `shiftR` 1) $! i-1 + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f + +allocateReg _ _ + = panic "RegAlloc.Linear.PPC.allocateReg: bad reg" diff --git a/GHC/CmmToAsm/Reg/Linear/SPARC.hs b/GHC/CmmToAsm/Reg/Linear/SPARC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/SPARC.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Free regs map for SPARC +module GHC.CmmToAsm.Reg.Linear.SPARC where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Regs +import GHC.Platform.Reg.Class +import GHC.Platform.Reg + +import GHC.Platform.Regs +import GHC.Utils.Outputable +import GHC.Platform + +import Data.Word +import Data.Bits + + +-------------------------------------------------------------------------------- +-- SPARC is like PPC, except for twinning of floating point regs. +-- When we allocate a double reg we must take an even numbered +-- float reg, as well as the one after it. + + +-- Holds bitmaps showing what registers are currently allocated. +-- The float and double reg bitmaps overlap, but we only alloc +-- float regs into the float map, and double regs into the double map. +-- +-- Free regs have a bit set in the corresponding bitmap. +-- +data FreeRegs + = FreeRegs + !Word32 -- int reg bitmap regs 0..31 + !Word32 -- float reg bitmap regs 32..63 + !Word32 -- double reg bitmap regs 32..63 + +instance Show FreeRegs where + show = showFreeRegs + +instance Outputable FreeRegs where + ppr = text . showFreeRegs + +-- | A reg map where no regs are free to be allocated. +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 0 + + +-- | The initial set of free regs. +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs + + +-- | Get all the free registers of this class. +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs g f d) + | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 + | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 + | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) +#endif + where + go _ _ 0 _ + = [] + + go step bitmap mask ix + | bitmap .&. mask /= 0 + = ix : (go step bitmap (mask `shiftL` step) $! ix + step) + + | otherwise + = go step bitmap (mask `shiftL` step) $! ix + step + + +-- | Grab a register. +allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs +allocateReg platform + reg@(RealRegSingle r) + (FreeRegs g f d) + + -- can't allocate free regs + | not $ freeReg platform r + = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) + + -- a general purpose reg + | r <= 31 + = let mask = complement (bitMask r) + in FreeRegs + (g .&. mask) + f + d + + -- a float reg + | r >= 32, r <= 63 + = let mask = complement (bitMask (r - 32)) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then complement (bitMask (r - 32)) + else complement (bitMask (r - 32 - 1)) + in FreeRegs + g + (f .&. mask) + (d .&. maskLow) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + +allocateReg _ + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = complement (bitMask (r1 - 32)) + mask2 = complement (bitMask (r2 - 32)) + in + FreeRegs + g + ((f .&. mask1) .&. mask2) + (d .&. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + + + +-- | Release a register from allocation. +-- The register liveness information says that most regs die after a C call, +-- but we still don't want to allocate to some of them. +-- +releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs +releaseReg platform + reg@(RealRegSingle r) + regs@(FreeRegs g f d) + + -- don't release pinned reg + | not $ freeReg platform r + = regs + + -- a general purpose reg + | r <= 31 + = let mask = bitMask r + in FreeRegs (g .|. mask) f d + + -- a float reg + | r >= 32, r <= 63 + = let mask = bitMask (r - 32) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then bitMask (r - 32) + else bitMask (r - 32 - 1) + in FreeRegs + g + (f .|. mask) + (d .|. maskLow) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + +releaseReg _ + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = bitMask (r1 - 32) + mask2 = bitMask (r2 - 32) + in + FreeRegs + g + ((f .|. mask1) .|. mask2) + (d .|. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + + + +bitMask :: Int -> Word32 +bitMask n = 1 `shiftL` n + + +showFreeRegs :: FreeRegs -> String +showFreeRegs regs + = "FreeRegs\n" + ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" + ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" + ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" diff --git a/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/GHC/CmmToAsm/Reg/Linear/StackMap.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -0,0 +1,61 @@ + +-- | The assignment of virtual registers to stack slots + +-- We have lots of stack slots. Memory-to-memory moves are a pain on most +-- architectures. Therefore, we avoid having to generate memory-to-memory moves +-- by simply giving every virtual register its own stack slot. + +-- The StackMap stack map keeps track of virtual register - stack slot +-- associations and of which stack slots are still free. Once it has been +-- associated, a stack slot is never "freed" or removed from the StackMap again, +-- it remains associated until we are done with the current CmmProc. +-- +module GHC.CmmToAsm.Reg.Linear.StackMap ( + StackSlot, + StackMap(..), + emptyStackMap, + getStackSlotFor, + getStackUse +) + +where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique + + +-- | Identifier for a stack slot. +type StackSlot = Int + +data StackMap + = StackMap + { -- | The slots that are still available to be allocated. + stackMapNextFreeSlot :: !Int + + -- See Note [UniqFM and the register allocator] + -- | Assignment of vregs to stack slots. + , stackMapAssignment :: UniqFM Unique StackSlot } + + +-- | An empty stack map, with all slots available. +emptyStackMap :: StackMap +emptyStackMap = StackMap 0 emptyUFM + + +-- | If this vreg unique already has a stack assignment then return the slot number, +-- otherwise allocate a new slot, and update the map. +-- +getStackSlotFor :: StackMap -> Unique -> (StackMap, Int) + +getStackSlotFor fs@(StackMap _ reserved) reg + | Just slot <- lookupUFM reserved reg = (fs, slot) + +getStackSlotFor (StackMap freeSlot reserved) reg = + (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot) + +-- | Return the number of stack slots that were allocated +getStackUse :: StackMap -> Int +getStackUse (StackMap freeSlot _) = freeSlot + diff --git a/GHC/CmmToAsm/Reg/Linear/State.hs b/GHC/CmmToAsm/Reg/Linear/State.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/State.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if !defined(GHC_LOADED_INTO_GHCI) +{-# LANGUAGE UnboxedTuples #-} +#endif + +-- | State monad for the linear register allocator. + +-- Here we keep all the state that the register allocator keeps track +-- of as it walks the instructions in a basic block. + +module GHC.CmmToAsm.Reg.Linear.State ( + RA_State(..), + RegM, + runR, + + spillR, + loadR, + + getFreeRegsR, + setFreeRegsR, + + getAssigR, + setAssigR, + + getBlockAssigR, + setBlockAssigR, + + setDeltaR, + getDeltaR, + + getUniqueR, + getConfig, + getPlatform, + + recordSpill, + recordFixupBlock +) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.Stats +import GHC.CmmToAsm.Reg.Linear.StackMap +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config +import GHC.Platform.Reg +import GHC.Cmm.BlockId + +import GHC.Platform +import GHC.Types.Unique +import GHC.Types.Unique.Supply + +import Control.Monad (ap) + +-- Avoids using unboxed tuples when loading into GHCi +#if !defined(GHC_LOADED_INTO_GHCI) + +type RA_Result freeRegs a = (# RA_State freeRegs, a #) + +pattern RA_Result :: a -> b -> (# a, b #) +pattern RA_Result a b = (# a, b #) +{-# COMPLETE RA_Result #-} +#else + +data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a + deriving (Functor) + +#endif + +-- | The register allocator monad type. +newtype RegM freeRegs a + = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a } + deriving (Functor) + +instance Applicative (RegM freeRegs) where + pure a = RegM $ \s -> RA_Result s a + (<*>) = ap + +instance Monad (RegM freeRegs) where + m >>= k = RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s } + +-- | Get native code generator configuration +getConfig :: RegM a NCGConfig +getConfig = RegM $ \s -> RA_Result s (ra_config s) + +-- | Get target platform from native code generator configuration +getPlatform :: RegM a Platform +getPlatform = ncgPlatform <$> getConfig + +-- | Run a computation in the RegM register allocator monad. +runR :: NCGConfig + -> BlockAssignment freeRegs + -> freeRegs + -> RegMap Loc + -> StackMap + -> UniqSupply + -> RegM freeRegs a + -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) + +runR config block_assig freeregs assig stack us thing = + case unReg thing + (RA_State + { ra_blockassig = block_assig + , ra_freeregs = freeregs + , ra_assig = assig + , ra_delta = 0{-???-} + , ra_stack = stack + , ra_us = us + , ra_spills = [] + , ra_config = config + , ra_fixups = [] }) + of + RA_Result state returned_thing + -> (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing) + + +-- | Make register allocator stats from its final state. +makeRAStats :: RA_State freeRegs -> RegAllocStats +makeRAStats state + = RegAllocStats + { ra_spillInstrs = binSpillReasons (ra_spills state) + , ra_fixupList = ra_fixups state } + + +spillR :: Instruction instr + => Reg -> Unique -> RegM freeRegs (instr, Int) + +spillR reg temp = RegM $ \s -> + let (stack1,slot) = getStackSlotFor (ra_stack s) temp + instr = mkSpillInstr (ra_config s) reg (ra_delta s) slot + in + RA_Result s{ra_stack=stack1} (instr,slot) + + +loadR :: Instruction instr + => Reg -> Int -> RegM freeRegs instr + +loadR reg slot = RegM $ \s -> + RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot) + +getFreeRegsR :: RegM freeRegs freeRegs +getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> + RA_Result s freeregs + +setFreeRegsR :: freeRegs -> RegM freeRegs () +setFreeRegsR regs = RegM $ \ s -> + RA_Result s{ra_freeregs = regs} () + +getAssigR :: RegM freeRegs (RegMap Loc) +getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> + RA_Result s assig + +setAssigR :: RegMap Loc -> RegM freeRegs () +setAssigR assig = RegM $ \ s -> + RA_Result s{ra_assig=assig} () + +getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) +getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> + RA_Result s assig + +setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () +setBlockAssigR assig = RegM $ \ s -> + RA_Result s{ra_blockassig = assig} () + +setDeltaR :: Int -> RegM freeRegs () +setDeltaR n = RegM $ \ s -> + RA_Result s{ra_delta = n} () + +getDeltaR :: RegM freeRegs Int +getDeltaR = RegM $ \s -> RA_Result s (ra_delta s) + +getUniqueR :: RegM freeRegs Unique +getUniqueR = RegM $ \s -> + case takeUniqFromSupply (ra_us s) of + (uniq, us) -> RA_Result s{ra_us = us} uniq + + +-- | Record that a spill instruction was inserted, for profiling. +recordSpill :: SpillReason -> RegM freeRegs () +recordSpill spill + = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) () + +-- | Record a created fixup block +recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs () +recordFixupBlock from between to + = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) () diff --git a/GHC/CmmToAsm/Reg/Linear/Stats.hs b/GHC/CmmToAsm/Reg/Linear/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/Stats.hs @@ -0,0 +1,90 @@ +module GHC.CmmToAsm.Reg.Linear.Stats ( + binSpillReasons, + countRegRegMovesNat, + pprStats +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.Reg.Linear.Base +import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Instr +import GHC.Types.Unique (Unique) + +import GHC.Types.Unique.FM +import GHC.Utils.Outputable + +import GHC.Utils.Monad.State + +-- | Build a map of how many times each reg was alloced, clobbered, loaded etc. +binSpillReasons + :: [SpillReason] -> UniqFM Unique [Int] + -- See Note [UniqFM and the register allocator] +binSpillReasons reasons + = addListToUFM_C + (zipWith (+)) + emptyUFM + (map (\reason -> case reason of + SpillAlloc r -> (r, [1, 0, 0, 0, 0]) + SpillClobber r -> (r, [0, 1, 0, 0, 0]) + SpillLoad r -> (r, [0, 0, 1, 0, 0]) + SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) + SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) + + +-- | Count reg-reg moves remaining in this code. +countRegRegMovesNat + :: Instruction instr + => NatCmmDecl statics instr -> Int + +countRegRegMovesNat cmm + = execState (mapGenBlockTopM countBlock cmm) 0 + where + countBlock b@(BasicBlock _ instrs) + = do mapM_ countInstr instrs + return b + + countInstr instr + | Just _ <- takeRegRegMoveInstr instr + = do modify (+ 1) + return instr + + | otherwise + = return instr + + +-- | Pretty print some RegAllocStats +pprStats + :: Instruction instr + => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc + +pprStats code statss + = let -- sum up all the instrs inserted by the spiller + -- See Note [UniqFM and the register allocator] + spills :: UniqFM Unique [Int] + spills = foldl' (plusUFM_C (zipWith (+))) + emptyUFM + $ map ra_spillInstrs statss + + spillTotals = foldl' (zipWith (+)) + [0, 0, 0, 0, 0] + $ nonDetEltsUFM spills + -- See Note [Unique Determinism and code generation] + + -- count how many reg-reg-moves remain in the code + moves = sum $ map countRegRegMovesNat code + + pprSpill (reg, spills) + = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) + + in ( text "-- spills-added-total" + $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" + $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) + $$ text "" + $$ text "-- spills-added" + $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" + $$ (pprUFMWithKeys spills (vcat . map pprSpill)) + $$ text "") + diff --git a/GHC/CmmToAsm/Reg/Linear/X86.hs b/GHC/CmmToAsm/Reg/Linear/X86.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/X86.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Free regs map for i386 +module GHC.CmmToAsm.Reg.Linear.X86 where + +import GHC.Prelude + +import GHC.CmmToAsm.X86.Regs +import GHC.Platform.Reg.Class +import GHC.Platform.Reg +import GHC.Utils.Panic +import GHC.Platform +import GHC.Utils.Outputable + +import Data.Word +import Data.Bits + +newtype FreeRegs = FreeRegs Word32 + deriving (Show,Outputable) + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) + +releaseReg _ _ + = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 + + where go 0 _ = [] + go n m + | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls + = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) + + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) + +allocateReg _ _ + = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" + diff --git a/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/GHC/CmmToAsm/Reg/Linear/X86_64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/X86_64.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Free regs map for x86_64 +module GHC.CmmToAsm.Reg.Linear.X86_64 where + +import GHC.Prelude + +import GHC.CmmToAsm.X86.Regs +import GHC.Platform.Reg.Class +import GHC.Platform.Reg +import GHC.Utils.Panic +import GHC.Platform +import GHC.Utils.Outputable + +import Data.Word +import Data.Bits + +newtype FreeRegs = FreeRegs Word64 + deriving (Show,Outputable) + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) + +releaseReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 + + where go 0 _ = [] + go n m + | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls + = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) + + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) + +allocateReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg" + + diff --git a/GHC/CmmToAsm/Reg/Liveness.hs b/GHC/CmmToAsm/Reg/Liveness.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Liveness.hs @@ -0,0 +1,1036 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- The register liveness determinator +-- +-- (c) The University of Glasgow 2004-2013 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.Reg.Liveness ( + RegSet, + RegMap, emptyRegMap, + BlockMap, mapEmpty, + LiveCmmDecl, + InstrSR (..), + LiveInstr (..), + Liveness (..), + LiveInfo (..), + LiveBasicBlock, + + mapBlockTop, mapBlockTopM, mapSCCM, + mapGenBlockTop, mapGenBlockTopM, + stripLive, + stripLiveBlock, + slurpConflicts, + slurpReloadCoalesce, + eraseDeltasLive, + patchEraseLive, + patchRegsLiveInstr, + reverseBlocksInTops, + regLiveness, + cmmTopLiveness + ) where +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Config + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Cmm hiding (RegSet, emptyRegSet) + +import GHC.Data.Graph.Directed +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Data.Bag +import GHC.Utils.Monad.State + +import Data.List +import Data.Maybe +import Data.IntSet (IntSet) + +----------------------------------------------------------------------------- +type RegSet = UniqSet Reg + +-- | Map from some kind of register to a. +-- +-- While we give the type for keys as Reg which is the common case +-- sometimes we end up using VirtualReq or naked Uniques. +-- See Note [UniqFM and the register allocator] +type RegMap a = UniqFM Reg a + +emptyRegMap :: RegMap a +emptyRegMap = emptyUFM + +emptyRegSet :: RegSet +emptyRegSet = emptyUniqSet + +type BlockMap a = LabelMap a + +type SlotMap a = UniqFM Slot a + +type Slot = Int + +-- | A top level thing which carries liveness information. +type LiveCmmDecl statics instr + = GenCmmDecl + statics + LiveInfo + [SCC (LiveBasicBlock instr)] + + +-- | The register allocator also wants to use SPILL/RELOAD meta instructions, +-- so we'll keep those here. +data InstrSR instr + -- | A real machine instruction + = Instr instr + + -- | spill this reg to a stack slot + | SPILL Reg Int + + -- | reload this reg from a stack slot + | RELOAD Int Reg + +instance Instruction instr => Instruction (InstrSR instr) where + regUsageOfInstr platform i + = case i of + Instr instr -> regUsageOfInstr platform instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] + + patchRegsOfInstr i f + = case i of + Instr instr -> Instr (patchRegsOfInstr instr f) + SPILL reg slot -> SPILL (f reg) slot + RELOAD slot reg -> RELOAD slot (f reg) + + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False + + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] + + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i + + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing + + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False + + mkRegRegMoveInstr platform r1 r2 + = Instr (mkRegRegMoveInstr platform r1 r2) + + takeRegRegMoveInstr i + = case i of + Instr instr -> takeRegRegMoveInstr instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) + + mkStackAllocInstr platform amount = + Instr <$> mkStackAllocInstr platform amount + + mkStackDeallocInstr platform amount = + Instr <$> mkStackDeallocInstr platform amount + + +-- | An instruction with liveness information. +data LiveInstr instr + = LiveInstr (InstrSR instr) (Maybe Liveness) + +-- | Liveness information. +-- The regs which die are ones which are no longer live in the *next* instruction +-- in this sequence. +-- (NB. if the instruction is a jump, these registers might still be live +-- at the jump target(s) - you have to check the liveness at the destination +-- block to find out). + +data Liveness + = Liveness + { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. + , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. + + +-- | Stash regs live on entry to each basic block in the info part of the cmm code. +data LiveInfo + = LiveInfo + (LabelMap RawCmmStatics) -- cmm info table static stuff + [BlockId] -- entry points (first one is the + -- entry point for the proc). + (BlockMap RegSet) -- argument locals live on entry to this block + (BlockMap IntSet) -- stack slots live on entry to this block + + +-- | A basic block with liveness information. +type LiveBasicBlock instr + = GenBasicBlock (LiveInstr instr) + + +instance Outputable instr + => Outputable (InstrSR instr) where + + ppr (Instr realInstr) + = ppr realInstr + + ppr (SPILL reg slot) + = hcat [ + text "\tSPILL", + char ' ', + ppr reg, + comma, + text "SLOT" <> parens (int slot)] + + ppr (RELOAD slot reg) + = hcat [ + text "\tRELOAD", + char ' ', + text "SLOT" <> parens (int slot), + comma, + ppr reg] + +instance Outputable instr + => Outputable (LiveInstr instr) where + + ppr (LiveInstr instr Nothing) + = ppr instr + + ppr (LiveInstr instr (Just live)) + = ppr instr + $$ (nest 8 + $ vcat + [ pprRegs (text "# born: ") (liveBorn live) + , pprRegs (text "# r_dying: ") (liveDieRead live) + , pprRegs (text "# w_dying: ") (liveDieWrite live) ] + $+$ space) + + where pprRegs :: SDoc -> RegSet -> SDoc + pprRegs name regs + | isEmptyUniqSet regs = empty + | otherwise = name <> + (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) + +instance Outputable LiveInfo where + ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) + = (ppr mb_static) + $$ text "# entryIds = " <> ppr entryIds + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + + + +-- | map a function across all the basic blocks in this code +-- +mapBlockTop + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +mapBlockTop f cmm + = evalState (mapBlockTopM (\x -> return $ f x) cmm) () + + +-- | map a function across all the basic blocks in this code (monadic version) +-- +mapBlockTopM + :: Monad m + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr) + +mapBlockTopM _ cmm@(CmmData{}) + = return cmm + +mapBlockTopM f (CmmProc header label live sccs) + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label live sccs' + +mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' + +mapSCCM f (CyclicSCC xs) + = do xs' <- mapM f xs + return $ CyclicSCC xs' + + +-- map a function across all the basic blocks in this code +mapGenBlockTop + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i)) + +mapGenBlockTop f cmm + = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () + + +-- | map a function across all the basic blocks in this code (monadic version) +mapGenBlockTopM + :: Monad m + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))) + +mapGenBlockTopM _ cmm@(CmmData{}) + = return cmm + +mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) + = do blocks' <- mapM f blocks + return $ CmmProc header label live (ListGraph blocks') + + +-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. +-- +slurpConflicts + :: Instruction instr + => LiveCmmDecl statics instr + -> (Bag (UniqSet Reg), Bag (Reg, Reg)) + +slurpConflicts live + = slurpCmm (emptyBag, emptyBag) live + + where slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc info _ _ sccs) + = foldl' (slurpSCC info) rs sccs + + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b + + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs + + slurpBlock info rs (BasicBlock blockId instrs) + | LiveInfo _ _ blockLive _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) + + | otherwise + = panic "Liveness.slurpConflicts: bad block" + + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) + + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis + + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) + = let + -- regs that die because they are read for the last time at the start of an instruction + -- are not live across it. + rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + + -- regs live on entry to the next instruction. + -- be careful of orphans, make sure to delete dying regs _after_ unioning + -- in the ones that are born here. + rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) + `minusUniqSet` (liveDieWrite live) + + -- orphan vregs are the ones that die in the same instruction they are born in. + -- these are likely to be results that are never used, but we still + -- need to assign a hreg to them.. + rsOrphans = intersectUniqSets + (liveBorn live) + (unionUniqSets (liveDieWrite live) (liveDieRead live)) + + -- + rsConflicts = unionUniqSets rsLiveNext rsOrphans + + in case takeRegRegMoveInstr instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis + + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis + + +-- | For spill\/reloads +-- +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 +-- +-- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely +-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. +-- +-- +slurpReloadCoalesce + :: forall statics instr. Instruction instr + => LiveCmmDecl statics instr + -> Bag (Reg, Reg) + +slurpReloadCoalesce live + = slurpCmm emptyBag live + + where + slurpCmm :: Bag (Reg, Reg) + -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] + -> Bag (Reg, Reg) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ _ sccs) + = slurpComp cs (flattenSCCs sccs) + + slurpComp :: Bag (Reg, Reg) + -> [LiveBasicBlock instr] + -> Bag (Reg, Reg) + slurpComp cs blocks + = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM + in unionManyBags (cs : moveBags) + + slurpCompM :: [LiveBasicBlock instr] + -> State (UniqFM BlockId [UniqFM Slot Reg]) [Bag (Reg, Reg)] + slurpCompM blocks + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks + + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks + + slurpBlock :: Bool -> LiveBasicBlock instr + -> State (UniqFM BlockId [UniqFM Slot Reg]) (Bag (Reg, Reg)) + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: SlotMap Reg -- current slotMap + -> LiveInstr instr + -> State (UniqFM BlockId [SlotMap Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( SlotMap Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge + + slurpLI slotMap li + + -- remember what reg was stored into the slot + | LiveInstr (SPILL reg slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg + = return (slotMap', Nothing) + + -- add an edge between the this reg and the last one stored into the slot + | LiveInstr (RELOAD slot reg) _ <- li + = case lookupUFM slotMap slot of + Just reg2 + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) + + -- if we hit a jump, remember the current slotMap + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) + + | otherwise + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: SlotMap Reg -> SlotMap Reg -> SlotMap Reg + mergeSlotMaps map1 map2 + -- toList sadly means we have to use the _Directly style + -- functions. + -- TODO: We shouldn't need to go through a list here. + = listToUFM_Directly + $ [ (k, r1) + | (k, r1) <- nonDetUFMToList map1 + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + , case lookupUFM_Directly map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] + + +-- | Strip away liveness information, yielding NatCmmDecl +stripLive + :: (Outputable statics, Outputable instr, Instruction instr) + => NCGConfig + -> LiveCmmDecl statics instr + -> NatCmmDecl statics instr + +stripLive config live + = stripCmm live + + where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) + => LiveCmmDecl statics instr -> NatCmmDecl statics instr + stripCmm (CmmData sec ds) = CmmData sec ds + stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) + = let final_blocks = flattenSCCs sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks + + in CmmProc info label live + (ListGraph $ map (stripLiveBlock config) $ first' : rest') + + -- If the proc has blocks but we don't know what the first one was, then we're dead. + stripCmm proc + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) + +-- | Strip away liveness information from a basic block, +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. + +stripLiveBlock + :: Instruction instr + => NCGConfig + -> LiveBasicBlock instr + -> NatBasicBlock instr + +stripLiveBlock config (BasicBlock i lis) + = BasicBlock i instrs' + + where (instrs', _) + = runState (spillNat [] lis) 0 + + spillNat acc [] + = return (reverse acc) + + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) + = do delta <- get + spillNat (mkSpillInstr config reg delta slot : acc) instrs + + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) + = do delta <- get + spillNat (mkLoadInstr config reg delta slot : acc) instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) + = spillNat (instr : acc) instrs + + +-- | Erase Delta instructions. + +eraseDeltasLive + :: Instruction instr + => LiveCmmDecl statics instr + -> LiveCmmDecl statics instr + +eraseDeltasLive cmm + = mapBlockTop eraseBlock cmm + where + eraseBlock (BasicBlock id lis) + = BasicBlock id + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) + $ lis + + +-- | Patch the registers in this code according to this register mapping. +-- also erase reg -> reg moves when the reg is the same. +-- also erase reg -> reg moves when the destination dies in this instr. +patchEraseLive + :: Instruction instr + => (Reg -> Reg) + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +patchEraseLive patchF cmm + = patchCmm cmm + where + patchCmm cmm@CmmData{} = cmm + + patchCmm (CmmProc info label live sccs) + | LiveInfo static id blockMap mLiveSlots <- info + = let + patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set + -- See Note [Unique Determinism and code generation] + blockMap' = mapMap (patchRegSet . getUniqSet) blockMap + + info' = LiveInfo static id blockMap' mLiveSlots + in CmmProc info' label live $ map patchSCC sccs + + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) + + patchBlock (BasicBlock id lis) + = BasicBlock id $ patchInstrs lis + + patchInstrs [] = [] + patchInstrs (li : lis) + + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr i + , eatMe r1 r2 live + = patchInstrs lis + + | otherwise + = li' : patchInstrs lis + + where li' = patchRegsLiveInstr patchF li + + eatMe r1 r2 live + -- source and destination regs are the same + | r1 == r2 = True + + -- destination reg is never used + | elementOfUniqSet r2 (liveBorn live) + , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) + = True + + | otherwise = False + + +-- | Patch registers in this LiveInstr, including the liveness information. +-- +patchRegsLiveInstr + :: Instruction instr + => (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr + +patchRegsLiveInstr patchF li + = case li of + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing + + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr instr patchF) + (Just live + { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg + liveBorn = mapUniqSet patchF $ liveBorn live + , liveDieRead = mapUniqSet patchF $ liveDieRead live + , liveDieWrite = mapUniqSet patchF $ liveDieWrite live }) + -- See Note [Unique Determinism and code generation] + + +-------------------------------------------------------------------------------- +-- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information + +cmmTopLiveness + :: (Outputable instr, Instruction instr) + => Maybe CFG -> Platform + -> NatCmmDecl statics instr + -> UniqSM (LiveCmmDecl statics instr) +cmmTopLiveness cfg platform cmm + = regLiveness platform $ natCmmTopToLive cfg cmm + +natCmmTopToLive + :: (Instruction instr, Outputable instr) + => Maybe CFG -> NatCmmDecl statics instr + -> LiveCmmDecl statics instr + +natCmmTopToLive _ (CmmData i d) + = CmmData i d + +natCmmTopToLive _ (CmmProc info lbl live (ListGraph [])) + = CmmProc (LiveInfo info [] mapEmpty mapEmpty) lbl live [] + +natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) + = CmmProc (LiveInfo info' (first_id : entry_ids) mapEmpty mapEmpty) + lbl live sccsLive + where + first_id = blockId first + all_entry_ids = entryBlocks proc + sccs = sccBlocks blocks all_entry_ids mCfg + sccsLive = map (fmap (\(BasicBlock l instrs) -> + BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) + $ sccs + + entry_ids = filter (reachable_node) . + filter (/= first_id) $ all_entry_ids + info' = mapFilterWithKey (\node _ -> reachable_node node) info + reachable_node + | Just cfg <- mCfg + = hasNode cfg + | otherwise + = const True + +-- +-- Compute the liveness graph of the set of basic blocks. Important: +-- we also discard any unreachable code here, starting from the entry +-- points (the first block in the list, and any blocks with info +-- tables). Unreachable code arises when code blocks are orphaned in +-- earlier optimisation passes, and may confuse the register allocator +-- by referring to registers that are not initialised. It's easy to +-- discard the unreachable code as part of the SCC pass, so that's +-- exactly what we do. (#7574) +-- +sccBlocks + :: forall instr . Instruction instr + => [NatBasicBlock instr] + -> [BlockId] + -> Maybe CFG + -> [SCC (NatBasicBlock instr)] + +sccBlocks blocks entries mcfg = map (fmap node_payload) sccs + where + nodes :: [ Node BlockId (NatBasicBlock instr) ] + nodes = [ DigraphNode block id (getOutEdges instrs) + | block@(BasicBlock id instrs) <- blocks ] + + g1 = graphFromEdgedVerticesUniq nodes + + reachable :: LabelSet + reachable + | Just cfg <- mcfg + -- Our CFG only contains reachable nodes by construction at this point. + = setFromList $ getCfgNodes cfg + | otherwise + = setFromList $ [ node_key node | node <- reachablesG g1 roots ] + + g2 = graphFromEdgedVerticesUniq [ node | node <- nodes + , node_key node + `setMember` reachable ] + + sccs = stronglyConnCompG g2 + + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concatMap jumpDestsOfInstr instrs + + -- This is truly ugly, but I don't see a good alternative. + -- Digraph just has the wrong API. We want to identify nodes + -- by their keys (BlockId), but Digraph requires the whole + -- node: (NatBasicBlock, BlockId, [BlockId]). This takes + -- advantage of the fact that Digraph only looks at the key, + -- even though it asks for the whole triple. + roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks") + | b <- entries ] + +-------------------------------------------------------------------------------- +-- Annotate code with register liveness information +-- + +regLiveness + :: (Outputable instr, Instruction instr) + => Platform + -> LiveCmmDecl statics instr + -> UniqSM (LiveCmmDecl statics instr) + +regLiveness _ (CmmData i d) + = return $ CmmData i d + +regLiveness _ (CmmProc info lbl live []) + | LiveInfo static mFirst _ _ <- info + = return $ CmmProc + (LiveInfo static mFirst mapEmpty mapEmpty) + lbl live [] + +regLiveness platform (CmmProc info lbl live sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info + = let (ann_sccs, block_live) = computeLiveness platform sccs + + in return $ CmmProc (LiveInfo static mFirst block_live liveSlotsOnEntry) + lbl live ann_sccs + + +-- ----------------------------------------------------------------------------- +-- | Check ordering of Blocks +-- The computeLiveness function requires SCCs to be in reverse +-- dependent order. If they're not the liveness information will be +-- wrong, and we'll get a bad allocation. Better to check for this +-- precondition explicitly or some other poor sucker will waste a +-- day staring at bad assembly code.. +-- +checkIsReverseDependent + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + +checkIsReverseDependent sccs' + = go emptyUniqSet sccs' + + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case nonDetEltsUniqSet badDests of + -- See Note [Unique Determinism and code generation] + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case nonDetEltsUniqSet badDests of + -- See Note [Unique Determinism and code generation] + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] + + +-- | If we've compute liveness info for this code already we have to reverse +-- the SCCs in each top to get them back to the right order so we can do it again. +reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr +reverseBlocksInTops top + = case top of + CmmData{} -> top + CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) + + +-- | Computing liveness +-- +-- On entry, the SCCs must be in "reverse" order: later blocks may transfer +-- control to earlier ones only, else `panic`. +-- +-- The SCCs returned are in the *opposite* order, which is exactly what we +-- want for the next pass. +-- +computeLiveness + :: (Outputable instr, Instruction instr) + => Platform + -> [SCC (LiveBasicBlock instr)] + -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers + -- which are "dead after this instruction". + BlockMap RegSet) -- blocks annotated with set of live registers + -- on entry to the block. + +computeLiveness platform sccs + = case checkIsReverseDependent sccs of + Nothing -> livenessSCCs platform mapEmpty [] sccs + Just bad -> pprPanic "RegAlloc.Liveness.computeLiveness" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , ppr sccs]) + +livenessSCCs + :: Instruction instr + => Platform + -> BlockMap RegSet + -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] + -> ( [SCC (LiveBasicBlock instr)] + , BlockMap RegSet) + +livenessSCCs _ blockmap done [] + = (done, blockmap) + +livenessSCCs platform blockmap done (AcyclicSCC block : sccs) + = let (blockmap', block') = livenessBlock platform blockmap block + in livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs + +livenessSCCs platform blockmap done + (CyclicSCC blocks : sccs) = + livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs + where (blockmap', blocks') + = iterateUntilUnchanged linearLiveness equalBlockMaps + blockmap blocks + + iterateUntilUnchanged + :: (a -> b -> (a,c)) -> (a -> a -> Bool) + -> a -> b + -> (a,c) + + iterateUntilUnchanged f eq a b + = head $ + concatMap tail $ + groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ + iterate (\(a, _) -> f a b) $ + (a, panic "RegLiveness.livenessSCCs") + + + linearLiveness + :: Instruction instr + => BlockMap RegSet -> [LiveBasicBlock instr] + -> (BlockMap RegSet, [LiveBasicBlock instr]) + + linearLiveness = mapAccumL (livenessBlock platform) + + -- probably the least efficient way to compare two + -- BlockMaps for equality. + equalBlockMaps a b + = a' == b' + where a' = map f $ mapToList a + b' = map f $ mapToList b + f (key,elt) = (key, nonDetEltsUniqSet elt) + -- See Note [Unique Determinism and code generation] + + + +-- | Annotate a basic block with register liveness information. +-- +livenessBlock + :: Instruction instr + => Platform + -> BlockMap RegSet + -> LiveBasicBlock instr + -> (BlockMap RegSet, LiveBasicBlock instr) + +livenessBlock platform blockmap (BasicBlock block_id instrs) + = let + (regsLiveOnEntry, instrs1) + = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) + blockmap' = mapInsert block_id regsLiveOnEntry blockmap + + instrs2 = livenessForward platform regsLiveOnEntry instrs1 + + output = BasicBlock block_id instrs2 + + in ( blockmap', output) + +-- | Calculate liveness going forwards, +-- filling in when regs are born + +livenessForward + :: Instruction instr + => Platform + -> RegSet -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] + +livenessForward _ _ [] = [] +livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) + | Just live <- mLive + = let + RU _ written = regUsageOfInstr platform instr + -- Regs that are written to but weren't live on entry to this instruction + -- are recorded as being born here. + rsBorn = mkUniqSet + $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written + + rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) + `minusUniqSet` (liveDieRead live) + `minusUniqSet` (liveDieWrite live) + + in LiveInstr instr (Just live { liveBorn = rsBorn }) + : livenessForward platform rsLiveNext lis + + | otherwise + = li : livenessForward platform rsLiveEntry lis + + +-- | Calculate liveness going backwards, +-- filling in when regs die, and what regs are live across each instruction + +livenessBack + :: Instruction instr + => Platform + -> RegSet -- regs live on this instr + -> BlockMap RegSet -- regs live on entry to other BBs + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (RegSet, [LiveInstr instr]) + +livenessBack _ liveregs _ done [] = (liveregs, done) + +livenessBack platform liveregs blockmap acc (instr : instrs) + = let (liveregs', instr') = liveness1 platform liveregs blockmap instr + in livenessBack platform liveregs' blockmap (instr' : acc) instrs + + +-- don't bother tagging comments or deltas with liveness +liveness1 + :: Instruction instr + => Platform + -> RegSet + -> BlockMap RegSet + -> LiveInstr instr + -> (RegSet, LiveInstr instr) + +liveness1 _ liveregs _ (LiveInstr instr _) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) + +liveness1 platform liveregs blockmap (LiveInstr instr _) + + | not_a_branch + = (liveregs1, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying + , liveDieWrite = mkUniqSet w_dying })) + + | otherwise + = (liveregs_br, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying_br + , liveDieWrite = mkUniqSet w_dying })) + + where + !(RU read written) = regUsageOfInstr platform instr + + -- registers that were written here are dead going backwards. + -- registers that were read here are live going backwards. + liveregs1 = (liveregs `delListFromUniqSet` written) + `addListToUniqSet` read + + -- registers that are not live beyond this point, are recorded + -- as dying here. + r_dying = [ reg | reg <- read, reg `notElem` written, + not (elementOfUniqSet reg liveregs) ] + + w_dying = [ reg | reg <- written, + not (elementOfUniqSet reg liveregs) ] + + -- union in the live regs from all the jump destinations of this + -- instruction. + targets = jumpDestsOfInstr instr -- where we go from here + not_a_branch = null targets + + targetLiveRegs target + = case mapLookup target blockmap of + Just ra -> ra + Nothing -> emptyRegSet + + live_from_branch = unionManyUniqSets (map targetLiveRegs targets) + + liveregs_br = liveregs1 `unionUniqSets` live_from_branch + + -- registers that are live only in the branch targets should + -- be listed as dying here. + live_branch_only = live_from_branch `minusUniqSet` liveregs + r_dying_br = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets` + live_branch_only) + -- See Note [Unique Determinism and code generation] diff --git a/GHC/CmmToAsm/Reg/Target.hs b/GHC/CmmToAsm/Reg/Target.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Target.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +-- | Hard wired things related to registers. +-- This is module is preventing the native code generator being able to +-- emit code for non-host architectures. +-- +-- TODO: Do a better job of the overloading, and eliminate this module. +-- We'd probably do better with a Register type class, and hook this to +-- Instruction somehow. +-- +-- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable +module GHC.CmmToAsm.Reg.Target ( + targetVirtualRegSqueeze, + targetRealRegSqueeze, + targetClassOfRealReg, + targetMkVirtualReg, + targetRegDotColor, + targetClassOfReg +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.CmmToAsm.Format + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Platform + +import qualified GHC.CmmToAsm.X86.Regs as X86 +import qualified GHC.CmmToAsm.X86.RegInfo as X86 +import qualified GHC.CmmToAsm.PPC.Regs as PPC +import qualified GHC.CmmToAsm.SPARC.Regs as SPARC + +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int +targetVirtualRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.virtualRegSqueeze + ArchX86_64 -> X86.virtualRegSqueeze + ArchPPC -> PPC.virtualRegSqueeze + ArchS390X -> panic "targetVirtualRegSqueeze ArchS390X" + ArchSPARC -> SPARC.virtualRegSqueeze + ArchSPARC64 -> panic "targetVirtualRegSqueeze ArchSPARC64" + ArchPPC_64 _ -> PPC.virtualRegSqueeze + ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" + ArchAArch64 -> panic "targetVirtualRegSqueeze ArchAArch64" + ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" + ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" + ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" + ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" + ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" + + +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int +targetRealRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.realRegSqueeze + ArchX86_64 -> X86.realRegSqueeze + ArchPPC -> PPC.realRegSqueeze + ArchS390X -> panic "targetRealRegSqueeze ArchS390X" + ArchSPARC -> SPARC.realRegSqueeze + ArchSPARC64 -> panic "targetRealRegSqueeze ArchSPARC64" + ArchPPC_64 _ -> PPC.realRegSqueeze + ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" + ArchAArch64 -> panic "targetRealRegSqueeze ArchAArch64" + ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" + ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" + ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" + ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" + ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" + +targetClassOfRealReg :: Platform -> RealReg -> RegClass +targetClassOfRealReg platform + = case platformArch platform of + ArchX86 -> X86.classOfRealReg platform + ArchX86_64 -> X86.classOfRealReg platform + ArchPPC -> PPC.classOfRealReg + ArchS390X -> panic "targetClassOfRealReg ArchS390X" + ArchSPARC -> SPARC.classOfRealReg + ArchSPARC64 -> panic "targetClassOfRealReg ArchSPARC64" + ArchPPC_64 _ -> PPC.classOfRealReg + ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" + ArchAArch64 -> panic "targetClassOfRealReg ArchAArch64" + ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" + ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" + ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" + ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" + ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" + +targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg +targetMkVirtualReg platform + = case platformArch platform of + ArchX86 -> X86.mkVirtualReg + ArchX86_64 -> X86.mkVirtualReg + ArchPPC -> PPC.mkVirtualReg + ArchS390X -> panic "targetMkVirtualReg ArchS390X" + ArchSPARC -> SPARC.mkVirtualReg + ArchSPARC64 -> panic "targetMkVirtualReg ArchSPARC64" + ArchPPC_64 _ -> PPC.mkVirtualReg + ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" + ArchAArch64 -> panic "targetMkVirtualReg ArchAArch64" + ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" + ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" + ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" + ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" + ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" + +targetRegDotColor :: Platform -> RealReg -> SDoc +targetRegDotColor platform + = case platformArch platform of + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform + ArchPPC -> PPC.regDotColor + ArchS390X -> panic "targetRegDotColor ArchS390X" + ArchSPARC -> SPARC.regDotColor + ArchSPARC64 -> panic "targetRegDotColor ArchSPARC64" + ArchPPC_64 _ -> PPC.regDotColor + ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" + ArchAArch64 -> panic "targetRegDotColor ArchAArch64" + ArchAlpha -> panic "targetRegDotColor ArchAlpha" + ArchMipseb -> panic "targetRegDotColor ArchMipseb" + ArchMipsel -> panic "targetRegDotColor ArchMipsel" + ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" + ArchUnknown -> panic "targetRegDotColor ArchUnknown" + + +targetClassOfReg :: Platform -> Reg -> RegClass +targetClassOfReg platform reg + = case reg of + RegVirtual vr -> classOfVirtualReg vr + RegReal rr -> targetClassOfRealReg platform rr diff --git a/GHC/CmmToAsm/Reg/Utils.hs b/GHC/CmmToAsm/Reg/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Utils.hs @@ -0,0 +1,59 @@ +module GHC.CmmToAsm.Reg.Utils + ( toRegMap, toVRegMap ) +where + +{- Note [UniqFM and the register allocator] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Before UniqFM had a key type the register allocator + wasn't picky about key types, using VirtualReg, Reg + and Unique at various use sites for the same map. + + This is safe. + * The Unique values come from registers at various + points where we lose a reference to the original + register value, but the unique is still valid. + + * VirtualReg is a subset of the registers in Reg's type. + Making a value of VirtualReg into a Reg in fact doesn't + change its unique. This is because Reg consists of virtual + regs and real regs, whose unique values do not overlap. + + * Since the code was written in the assumption that keys are + not typed it's hard to reverse this assumption now. So we get + some gnarly but correct code where we often pass around Uniques + and switch between using Uniques, VirtualReg and RealReg as keys + of the same map. These issues were always there. But with the + now-typed keys they become visible. It's a classic case of not all + correct programs type checking. + + We reduce some of the burden by providing a way to cast + + UniqFM VirtualReg a + + to + + UniqFM Reg a + + in this module. This is safe as Reg is the sum of VirtualReg and + RealReg. With each kind of register keeping the same unique when + treated as Reg. + + TODO: If you take offense to this I encourage you to refactor this + code. I'm sure we can do with less casting of keys and direct use + of uniques. It might also be reasonable to just use a IntMap directly + instead of dealing with UniqFM at all. + + +-} +import GHC.Types.Unique.FM +import GHC.Platform.Reg + +-- These should hopefully be zero cost. + +toRegMap :: UniqFM VirtualReg elt -> UniqFM Reg elt +toRegMap = unsafeCastUFMKey + +toVRegMap :: UniqFM Reg elt -> UniqFM VirtualReg elt +toVRegMap = unsafeCastUFMKey + diff --git a/GHC/CmmToAsm/SPARC/AddrMode.hs b/GHC/CmmToAsm/SPARC/AddrMode.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/AddrMode.hs @@ -0,0 +1,44 @@ + +module GHC.CmmToAsm.SPARC.AddrMode ( + AddrMode(..), + addrOffset +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.Base +import GHC.Platform.Reg + +-- addressing modes ------------------------------------------------------------ + +-- | Represents a memory address in an instruction. +-- Being a RISC machine, the SPARC addressing modes are very regular. +-- +data AddrMode + = AddrRegReg Reg Reg -- addr = r1 + r2 + | AddrRegImm Reg Imm -- addr = r1 + imm + + +-- | Add an integer offset to the address in an AddrMode. +-- +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + AddrRegImm r (ImmInt n) + | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2)) + | otherwise -> Nothing + where n2 = n + off + + AddrRegImm r (ImmInteger n) + | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) + | otherwise -> Nothing + where n2 = n + toInteger off + + AddrRegReg r (RegReal (RealRegSingle 0)) + | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) + | otherwise -> Nothing + + _ -> Nothing diff --git a/GHC/CmmToAsm/SPARC/Base.hs b/GHC/CmmToAsm/SPARC/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/Base.hs @@ -0,0 +1,70 @@ + +-- | Bits and pieces on the bottom of the module dependency tree. +-- Also import the required constants, so we know what we're using. +-- +-- In the interests of cross-compilation, we want to free ourselves +-- from the autoconf generated modules like "GHC.Settings.Constants" + +module GHC.CmmToAsm.SPARC.Base ( + wordLength, + wordLengthInBits, + spillSlotSize, + extraStackArgsHere, + fits13Bits, + is32BitInteger, + largeOffsetError +) + +where + +import GHC.Prelude + +import GHC.Utils.Panic + +import Data.Int + + +-- On 32 bit SPARC, pointers are 32 bits. +wordLength :: Int +wordLength = 4 + +wordLengthInBits :: Int +wordLengthInBits + = wordLength * 8 + +-- | We need 8 bytes because our largest registers are 64 bit. +spillSlotSize :: Int +spillSlotSize = 8 + + +-- | We (allegedly) put the first six C-call arguments in registers; +-- where do we start putting the rest of them? +extraStackArgsHere :: Int +extraStackArgsHere = 23 + + +{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-} +-- | Check whether an offset is representable with 13 bits. +fits13Bits :: Integral a => a -> Bool +fits13Bits x = x >= -4096 && x < 4096 + +-- | Check whether an integer will fit in 32 bits. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. +-- +is32BitInteger :: Integer -> Bool +is32BitInteger i + = i64 <= 0x7fffffff && i64 >= -0x80000000 + where i64 = fromIntegral i :: Int64 + + +-- | Sadness. +largeOffsetError :: (Show a) => a -> b +largeOffsetError i + = panic ("ERROR: SPARC native-code generator cannot handle large offset (" + ++ show i ++ ");\nprobably because of large constant data structures;" ++ + "\nworkaround: use -fllvm on this module.\n") + + diff --git a/GHC/CmmToAsm/SPARC/CodeGen.hs b/GHC/CmmToAsm/SPARC/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -0,0 +1,700 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2013 +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE GADTs #-} +module GHC.CmmToAsm.SPARC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) + +where + +#include "HsVersions.h" + +-- NCG stuff: +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Base +import GHC.CmmToAsm.SPARC.CodeGen.Sanity +import GHC.CmmToAsm.SPARC.CodeGen.Amode +import GHC.CmmToAsm.SPARC.CodeGen.CondCode +import GHC.CmmToAsm.SPARC.CodeGen.Gen64 +import GHC.CmmToAsm.SPARC.CodeGen.Gen32 +import GHC.CmmToAsm.SPARC.CodeGen.Base +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.Stack +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig ) +import GHC.CmmToAsm.Config + +-- Our intermediate code: +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.CmmToAsm.PIC +import GHC.Platform.Reg +import GHC.Cmm.CLabel +import GHC.CmmToAsm.CPrim + +-- The rest: +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Utils.Outputable +import GHC.Platform + +import Control.Monad ( mapAndUnzipM ) + +-- | Top level code generation +cmmTopCodeGen :: RawCmmDecl + -> NatM [NatCmmDecl RawCmmStatics Instr] + +cmmTopCodeGen (CmmProc info lab live graph) + = do let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + let tops = proc : concat statics + + return tops + +cmmTopCodeGen (CmmData sec dat) = do + return [CmmData sec dat] -- no translation, we just use CmmStatic + + +-- | Do code generation on a single block of CMM code. +-- code generation may introduce new basic block boundaries, which +-- are indicated by the NEWBLOCK instruction. We must split up the +-- instruction stream into basic blocks again. Also, we extract +-- LDATAs here too. +basicBlockCodeGen :: CmmBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl RawCmmStatics Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = mid_instrs `appOL` tail_instrs + let + (top,other_blocks,statics) + = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + + -- do intra-block sanity checking + blocksChecked + = map (checkBlock block) + $ BasicBlock id top : other_blocks + + return (blocksChecked, statics) + + +-- | Convert some Cmm statements to SPARC instructions. +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock +stmtsToInstrs stmts + = do instrss <- mapM stmtToInstrs stmts + return (concatOL instrss) + + +stmtToInstrs :: CmmNode e x -> NatM InstrBlock +stmtToInstrs stmt = do + platform <- getPlatform + config <- getConfig + case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + CmmUnwind {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType platform reg + format = cmmTypeFormat ty + + CmmStore addr src + | isFloatType ty -> assignMem_FltCode format addr src + | isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + CmmBranch id -> genBranch id + CmmCondBranch arg true false _ -> do + b1 <- genCondJump true arg + b2 <- genBranch false + return (b1 `appOL` b2) + CmmSwitch arg ids -> genSwitch config arg ids + CmmCall { cml_target = arg } -> genJump arg + + _ + -> panic "stmtToInstrs: statement should have been cps'd away" + + +{- +Now, given a tree (the argument to a CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + + + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: Platform -> Maybe BlockId -> CmmStatic +jumpTableEntry platform Nothing = CmmStaticLit (CmmInt 0 (wordWidth platform)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = blockLbl blockid + + + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_IntCode pk addr src = do + (srcReg, code) <- getSomeReg src + Amode dstAddr addr_code <- getAmode addr + return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr + + +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_IntCode _ reg src = do + platform <- getPlatform + r <- getRegister src + let dst = getRegisterReg platform reg + return $ case r of + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst + + + +-- Floating point assignment to memory +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_FltCode pk addr src = do + platform <- getPlatform + Amode dst__2 code1 <- getAmode addr + (src__2, code2) <- getSomeReg src + tmp1 <- getNewRegNat pk + let + pk__2 = cmmExprType platform src + code__2 = code1 `appOL` code2 `appOL` + if formatToWidth pk == typeWidth pk__2 + then unitOL (ST pk src__2 dst__2) + else toOL [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1 + , ST pk tmp1 dst__2] + return code__2 + +-- Floating point assignment to a register/temporary +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_FltCode pk dstCmmReg srcCmmExpr = do + platform <- getPlatform + srcRegister <- getRegister srcCmmExpr + let dstReg = getRegisterReg platform dstCmmReg + + return $ case srcRegister of + Any _ code -> code dstReg + Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg + + + + +genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock + +genJump (CmmLit (CmmLabel lbl)) + = return (toOL [CALL (Left target) 0 True, NOP]) + where + target = ImmCLbl lbl + +genJump tree + = do + (target, code) <- getSomeReg tree + return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches + +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. + +SPARC: First, we have to ensure that the condition codes are set +according to the supplied comparison operation. We generate slightly +different code for floating point comparisons, because a floating +point operation cannot directly precede a @BF@. We assume the worst +and fill that slot with a @NOP@. + +SPARC: Do not fill the delay slots here; you will confuse the register +allocator. +-} + + +genCondJump + :: BlockId -- the branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock + + + +genCondJump bid bool = do + CondCode is_float cond code <- getCondCode bool + return ( + code `appOL` + toOL ( + if is_float + then [NOP, BF cond False bid, NOP] + else [BI cond False bid, NOP] + ) + ) + + + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets + | ncgPIC config + = error "MachCodeGen: sparc genSwitch PIC not finished\n" + + | otherwise + = do (e_reg, e_code) <- getSomeReg (cmmOffset (ncgPlatform config) expr offset) + + base_reg <- getNewRegNat II32 + offset_reg <- getNewRegNat II32 + dst <- getNewRegNat II32 + + label <- getNewLabelNat + + return $ e_code `appOL` + toOL + [ -- load base of jump table + SETHI (HI (ImmCLbl label)) base_reg + , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg + + -- the addrs in the table are 32 bits wide.. + , SLL e_reg (RIImm $ ImmInt 2) offset_reg + + -- load and jump to the destination + , LD II32 (AddrRegReg base_reg offset_reg) dst + , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label + , NOP ] + where (offset, ids) = switchTargetsToTable targets + +generateJumpTableForInstr :: Platform -> Instr + -> Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr platform (JMP_TBL _ ids label) = + let jumpTable = map (jumpTableEntry platform) ids + in Just (CmmData (Section ReadOnlyData label) (CmmStaticsRaw label jumpTable)) +generateJumpTableForInstr _ _ = Nothing + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +{- + Now the biggest nightmare---calls. Most of the nastiness is buried in + @get_arg@, which moves the arguments to the correct registers/stack + locations. Apart from that, the code is easy. + + The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) + + If we have to put args on the stack, move %o6==%sp down by + the number of words to go on the stack, to ensure there's enough space. + + According to Fraser and Hanson's lcc book, page 478, fig 17.2, + 16 words above the stack pointer is a word for the address of + a structure return value. I use this as a temporary location + for moving values from float to int regs. Certainly it isn't + safe to put anything in the 16 words starting at %sp, since + this area can get trashed at any time due to window overflows + caused by signal handlers. + + A final complication (if the above isn't enough) is that + we can't blithely calculate the arguments one by one into + %o0 .. %o5. Consider the following nested calls: + + fff a (fff b c) + + Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately + the inner call will itself use %o0, which trashes the value put there + in preparation for the outer call. Upshot: we need to calculate the + args into temporary regs, and move those to arg regs or onto the + stack only immediately prior to the call proper. Sigh. +-} + +genCCall + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + + + +-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream +-- are guaranteed to take place before writes afterwards (unlike on PowerPC). +-- Ref: Section 8.4 of the SPARC V9 Architecture manual. +-- +-- In the SPARC case we don't need a barrier. +-- +genCCall (PrimTarget MO_ReadBarrier) _ _ + = return $ nilOL +genCCall (PrimTarget MO_WriteBarrier) _ _ + = return $ nilOL + +genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ + = return $ nilOL + +genCCall target dest_regs args + = do -- work out the arguments, and assign them to integer regs + argcode_and_vregs <- mapM arg_to_int_vregs args + let (argcodes, vregss) = unzip argcode_and_vregs + let vregs = concat vregss + + let n_argRegs = length allArgRegs + let n_argRegs_used = min (length vregs) n_argRegs + + + -- deal with static vs dynamic call targets + callinsns <- case target of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + ForeignTarget expr _ + -> do (dyn_c, dyn_rs) <- arg_to_int_vregs expr + let dyn_r = case dyn_rs of + [dyn_r'] -> dyn_r' + _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + PrimTarget mop + -> do res <- outOfLineMachOp mop + lblOrMopExpr <- case res of + Left lbl -> do + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + Right mopExpr -> do + (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr + let dyn_r = case dyn_rs of + [dyn_r'] -> dyn_r' + _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + return lblOrMopExpr + + let argcode = concatOL argcodes + + let (move_sp_down, move_sp_up) + = let diff = length vregs - n_argRegs + nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment + in if nn <= 0 + then (nilOL, nilOL) + else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) + + let transfer_code + = toOL (move_final vregs allArgRegs extraStackArgsHere) + + platform <- getPlatform + return + $ argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` + move_sp_up `appOL` + assign_code platform dest_regs + + +-- | Generate code to calculate an argument, and move it into one +-- or two integer vregs. +arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs arg = do platform <- getPlatform + arg_to_int_vregs' platform arg + +arg_to_int_vregs' :: Platform -> CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs' platform arg + + -- If the expr produces a 64 bit int, then we can just use iselExpr64 + | isWord64 (cmmExprType platform arg) + = do (ChildCode64 code r_lo) <- iselExpr64 arg + let r_hi = getHiVRegFromLo r_lo + return (code, [r_hi, r_lo]) + + | otherwise + = do (src, code) <- getSomeReg arg + let pk = cmmExprType platform arg + + case cmmTypeFormat pk of + + -- Load a 64 bit float return value into two integer regs. + FF64 -> do + v1 <- getNewRegNat II32 + v2 <- getNewRegNat II32 + + let code2 = + code `snocOL` + FMOV FF64 src f0 `snocOL` + ST FF32 f0 (spRel 16) `snocOL` + LD II32 (spRel 16) v1 `snocOL` + ST FF32 f1 (spRel 16) `snocOL` + LD II32 (spRel 16) v2 + + return (code2, [v1,v2]) + + -- Load a 32 bit float return value into an integer reg + FF32 -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + ST FF32 src (spRel 16) `snocOL` + LD II32 (spRel 16) v1 + + return (code2, [v1]) + + -- Move an integer return value into its destination reg. + _ -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + OR False g0 (RIReg src) v1 + + return (code2, [v1]) + + +-- | Move args from the integer vregs into which they have been +-- marshalled, into %o0 .. %o5, and the rest onto the stack. +-- +move_final :: [Reg] -> [Reg] -> Int -> [Instr] + +-- all args done +move_final [] _ _ + = [] + +-- out of aregs; move to stack +move_final (v:vs) [] offset + = ST II32 v (spRel offset) + : move_final vs [] (offset+1) + +-- move into an arg (%o[0..5]) reg +move_final (v:vs) (a:az) offset + = OR False g0 (RIReg v) a + : move_final vs az offset + + +-- | Assign results returned from the call into their +-- destination regs. +-- +assign_code :: Platform -> [LocalReg] -> OrdList Instr + +assign_code _ [] = nilOL + +assign_code platform [dest] + = let rep = localRegType dest + width = typeWidth rep + r_dest = getRegisterReg platform (CmmLocal dest) + + result + | isFloatType rep + , W32 <- width + = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest + + | isFloatType rep + , W64 <- width + = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest + + | not $ isFloatType rep + , W32 <- width + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest + + | not $ isFloatType rep + , W64 <- width + , r_dest_hi <- getHiVRegFromLo r_dest + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] + + | otherwise + = panic "SPARC.CodeGen.GenCCall: no match" + + in result + +assign_code _ _ + = panic "SPARC.CodeGen.GenCCall: no match" + + + +-- | Generate a call to implement an out-of-line floating point operation +outOfLineMachOp + :: CallishMachOp + -> NatM (Either CLabel CmmExpr) + +outOfLineMachOp mop + = do let functionName + = outOfLineMachOp_table mop + + config <- getConfig + mopExpr <- cmmMakeDynamicReference config CallReference + $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction + + let mopLabelOrExpr + = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + + return mopLabelOrExpr + + +-- | Decide what C function to use to implement a CallishMachOp +-- +outOfLineMachOp_table + :: CallishMachOp + -> FastString + +outOfLineMachOp_table mop + = case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" + MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Fabs -> unsupported + MO_F32_Pwr -> fsLit "powf" + + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F32_Asinh -> fsLit "asinhf" + MO_F32_Acosh -> fsLit "acoshf" + MO_F32_Atanh -> fsLit "atanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" + MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Fabs -> unsupported + MO_F64_Pwr -> fsLit "pow" + + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_F64_Asinh -> fsLit "asinh" + MO_F64_Acosh -> fsLit "acosh" + MO_F64_Atanh -> fsLit "atanh" + + MO_UF_Conv w -> fsLit $ word2FloatLabel w + + MO_Memcpy _ -> fsLit "memcpy" + MO_Memset _ -> fsLit "memset" + MO_Memmove _ -> fsLit "memmove" + MO_Memcmp _ -> fsLit "memcmp" + + MO_BSwap w -> fsLit $ bSwapLabel w + MO_BRev w -> fsLit $ bRevLabel w + MO_PopCnt w -> fsLit $ popCntLabel w + MO_Pdep w -> fsLit $ pdepLabel w + MO_Pext w -> fsLit $ pextLabel w + MO_Clz w -> fsLit $ clzLabel w + MO_Ctz w -> fsLit $ ctzLabel w + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_Xchg w -> fsLit $ xchgLabel w + MO_AtomicRead w -> fsLit $ atomicReadLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddWordC {} -> unsupported + MO_SubWordC {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + (MO_Prefetch_Data _) -> unsupported + where unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs b/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs @@ -0,0 +1,74 @@ +module GHC.CmmToAsm.SPARC.CodeGen.Amode ( + getAmode +) + +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 +import GHC.CmmToAsm.SPARC.CodeGen.Base +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.Base +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Format + +import GHC.Cmm + +import GHC.Data.OrdList + + +-- | Generate code to reference a memory address. +getAmode + :: CmmExpr -- ^ expr producing an address + -> NatM Amode + +getAmode tree@(CmmRegOff _ _) + = do platform <- getPlatform + getAmode (mangleIndexTree platform tree) + +getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) + | fits13Bits (-i) + = do + (reg, code) <- getSomeReg x + let + off = ImmInt (-(fromInteger i)) + return (Amode (AddrRegImm reg off) code) + + +getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) + | fits13Bits i + = do + (reg, code) <- getSomeReg x + let + off = ImmInt (fromInteger i) + return (Amode (AddrRegImm reg off) code) + +getAmode (CmmMachOp (MO_Add _) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + let + code = codeX `appOL` codeY + return (Amode (AddrRegReg regX regY) code) + +getAmode (CmmLit lit) + = do + let imm__2 = litToImm lit + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + + let code = toOL [ SETHI (HI imm__2) tmp1 + , OR False tmp1 (RIImm (LO imm__2)) tmp2] + + return (Amode (AddrRegReg tmp2 g0) code) + +getAmode other + = do + (reg, code) <- getSomeReg other + let + off = ImmInt 0 + return (Amode (AddrRegImm reg off) code) diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Base.hs b/GHC/CmmToAsm/SPARC/CodeGen/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/Base.hs @@ -0,0 +1,118 @@ +module GHC.CmmToAsm.SPARC.CodeGen.Base ( + InstrBlock, + CondCode(..), + ChildCode64(..), + Amode(..), + + Register(..), + setFormatOfRegister, + + getRegisterReg, + mangleIndexTree +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Cond +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.Format +import GHC.Platform.Reg + +import GHC.Platform.Regs +import GHC.Cmm +import GHC.Cmm.Ppr.Expr () -- For Outputable instances +import GHC.Platform + +import GHC.Utils.Outputable +import GHC.Data.OrdList + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Condition codes passed up the tree. +-- +data CondCode + = CondCode Bool Cond InstrBlock + + +-- | a.k.a \"Register64\" +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. +-- +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified +-- +data ChildCode64 + = ChildCode64 + InstrBlock + Reg + + +-- | Holds code that references a memory address. +data Amode + = Amode + -- the AddrMode we can use in the instruction + -- that does the real load\/store. + AddrMode + + -- other setup code we have to run first before we can use the + -- above AddrMode. + InstrBlock + + + +-------------------------------------------------------------------------------- +-- | Code to produce a result into a register. +-- If the result must go in a specific register, it comes out as Fixed. +-- Otherwise, the parent can decide which register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + + +-- | Change the format field in a Register. +setFormatOfRegister + :: Register -> Format -> Register + +setFormatOfRegister reg format + = case reg of + Fixed _ reg code -> Fixed format reg code + Any _ codefn -> Any format codefn + + +-------------------------------------------------------------------------------- +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of + Just reg -> RegReal reg + Nothing -> pprPanic + "SPARC.CodeGen.Base.getRegisterReg: global is in memory" + (ppr $ CmmGlobal mid) + + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: Platform -> CmmExpr -> CmmExpr + +mangleIndexTree platform (CmmRegOff reg off) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType platform reg) + +mangleIndexTree _ _ + = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs b/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs @@ -0,0 +1,110 @@ +module GHC.CmmToAsm.SPARC.CodeGen.CondCode ( + getCondCode, + condIntCode, + condFltCode +) + +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 +import GHC.CmmToAsm.SPARC.CodeGen.Base +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.Cond +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.Base +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Format + +import GHC.Cmm + +import GHC.Data.OrdList +import GHC.Utils.Outputable + + +getCondCode :: CmmExpr -> NatM CondCode +getCondCode (CmmMachOp mop [x, y]) + = + case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + MO_F_Lt W32 -> condFltCode LTT x y + MO_F_Le W32 -> condFltCode LE x y + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode LTT x y + MO_F_Le W64 -> condFltCode LE x y + + MO_Eq _ -> condIntCode EQQ x y + MO_Ne _ -> condIntCode NE x y + + MO_S_Gt _ -> condIntCode GTT x y + MO_S_Ge _ -> condIntCode GE x y + MO_S_Lt _ -> condIntCode LTT x y + MO_S_Le _ -> condIntCode LE x y + + MO_U_Gt _ -> condIntCode GU x y + MO_U_Ge _ -> condIntCode GEU x y + MO_U_Lt _ -> condIntCode LU x y + MO_U_Le _ -> condIntCode LEU x y + + _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) + +getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) + + + + + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond x (CmmLit (CmmInt y _)) + | fits13Bits y + = do + (src1, code) <- getSomeReg x + let + src2 = ImmInt (fromInteger y) + code' = code `snocOL` SUB False True src1 (RIImm src2) g0 + return (CondCode False cond code') + +condIntCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 = code1 `appOL` code2 `snocOL` + SUB False True src1 (RIReg src2) g0 + return (CondCode False cond code__2) + + +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condFltCode cond x y = do + platform <- getPlatform + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp <- getNewRegNat FF64 + let + promote x = FxTOy FF32 FF64 x tmp + + pk1 = cmmExprType platform x + pk2 = cmmExprType platform y + + code__2 = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + FCMP True (cmmTypeFormat pk1) src1 src2 + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + FCMP True FF64 tmp src2 + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + FCMP True FF64 src1 tmp + return (CondCode True cond code__2) diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs b/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs @@ -0,0 +1,156 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Expand out synthetic instructions into single machine instrs. +module GHC.CmmToAsm.SPARC.CodeGen.Expand ( + expandTop +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg +import GHC.CmmToAsm.Format +import GHC.Cmm + + +import GHC.Utils.Outputable +import GHC.Data.OrdList + +-- | Expand out synthetic instructions in this top level thing +expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr +expandTop top@(CmmData{}) + = top + +expandTop (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map expandBlock blocks) + + +-- | Expand out synthetic instructions in this block +expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr + +expandBlock (BasicBlock label instrs) + = let instrs_ol = expandBlockInstrs instrs + instrs' = fromOL instrs_ol + in BasicBlock label instrs' + + +-- | Expand out some instructions +expandBlockInstrs :: [Instr] -> OrdList Instr +expandBlockInstrs [] = nilOL + +expandBlockInstrs (ii:is) + = let ii_doubleRegs = remapRegPair ii + is_misaligned = expandMisalignedDoubles ii_doubleRegs + + in is_misaligned `appOL` expandBlockInstrs is + + + +-- | In the SPARC instruction set the FP register pairs that are used +-- to hold 64 bit floats are referred to by just the first reg +-- of the pair. Remap our internal reg pairs to the appropriate reg. +-- +-- For example: +-- ldd [%l1], (%f0 | %f1) +-- +-- gets mapped to +-- ldd [$l1], %f0 +-- +remapRegPair :: Instr -> Instr +remapRegPair instr + = let patchF reg + = case reg of + RegReal (RealRegSingle _) + -> reg + + RegReal (RealRegPair r1 r2) + + -- sanity checking + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + , r2 == r1 + 1 + -> RegReal (RealRegSingle r1) + + | otherwise + -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) + + RegVirtual _ + -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) + + in patchRegsOfInstr instr patchF + + + + +-- Expand out 64 bit load/stores into individual instructions to handle +-- possible double alignment problems. +-- +-- TODO: It'd be better to use a scratch reg instead of the add/sub thing. +-- We might be able to do this faster if we use the UA2007 instr set +-- instead of restricting ourselves to SPARC V9. +-- +expandMisalignedDoubles :: Instr -> OrdList Instr +expandMisalignedDoubles instr + + -- Translate to: + -- add g1,g2,g1 + -- ld [g1],%fn + -- ld [g1+4],%f(n+1) + -- sub g1,g2,g1 -- to restore g1 + | LD FF64 (AddrRegReg r1 r2) fReg <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , LD FF32 (AddrRegReg r1 g0) fReg + , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | LD FF64 addr fReg <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ LD FF32 addr fReg + , LD FF32 addr' (fRegHi fReg) ] + + -- Translate to: + -- add g1,g2,g1 + -- st %fn,[g1] + -- st %f(n+1),[g1+4] + -- sub g1,g2,g1 -- to restore g1 + | ST FF64 fReg (AddrRegReg r1 r2) <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , ST FF32 fReg (AddrRegReg r1 g0) + , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | ST FF64 fReg addr <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ ST FF32 fReg addr + , ST FF32 (fRegHi fReg) addr' ] + + -- some other instr + | otherwise + = unitOL instr + + + +-- | The high partner for this float reg. +fRegHi :: Reg -> Reg +fRegHi (RegReal (RealRegSingle r1)) + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + = (RegReal $ RealRegSingle (r1 + 1)) + +-- Can't take high partner for non-low reg. +fRegHi reg + = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs b/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs @@ -0,0 +1,690 @@ +-- | Evaluation of 32 bit values. +module GHC.CmmToAsm.SPARC.CodeGen.Gen32 ( + getSomeReg, + getRegister +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.CodeGen.CondCode +import GHC.CmmToAsm.SPARC.CodeGen.Amode +import GHC.CmmToAsm.SPARC.CodeGen.Gen64 +import GHC.CmmToAsm.SPARC.CodeGen.Base +import GHC.CmmToAsm.SPARC.Stack +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Cond +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.Base +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Format +import GHC.Platform.Reg + +import GHC.Cmm + +import Control.Monad (liftM) +import GHC.Data.OrdList +import GHC.Utils.Outputable + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + + + +-- | Make code to evaluate a 32 bit expression. +-- +getRegister :: CmmExpr -> NatM Register + +getRegister (CmmReg reg) + = do platform <- getPlatform + return (Fixed (cmmTypeFormat (cmmRegType platform reg)) + (getRegisterReg platform reg) nilOL) + +getRegister tree@(CmmRegOff _ _) + = do platform <- getPlatform + getRegister (mangleIndexTree platform tree) + +getRegister (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + + +-- Load a literal float into a float register. +-- The actual literal is stored in a new data area, and we load it +-- at runtime. +getRegister (CmmLit (CmmFloat f W32)) = do + + -- a label for the new data area + lbl <- getNewLabelNat + tmp <- getNewRegNat II32 + + let code dst = toOL [ + -- the data area + LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl + [CmmStaticLit (CmmFloat f W32)], + + -- load the literal + SETHI (HI (ImmCLbl lbl)) tmp, + LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + + return (Any FF32 code) + +getRegister (CmmLit (CmmFloat d W64)) = do + lbl <- getNewLabelNat + tmp <- getNewRegNat II32 + let code dst = toOL [ + LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl + [CmmStaticLit (CmmFloat d W64)], + SETHI (HI (ImmCLbl lbl)) tmp, + LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + return (Any FF64 code) + + +-- Unary machine ops +getRegister (CmmMachOp mop [x]) + = case mop of + -- Floating point negation ------------------------- + MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x + MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x + + + -- Integer negation -------------------------------- + MO_S_Neg rep -> trivialUCode (intFormat rep) (SUB False False g0) x + MO_Not rep -> trivialUCode (intFormat rep) (XNOR False g0) x + + + -- Float word size conversion ---------------------- + MO_FF_Conv W64 W32 -> coerceDbl2Flt x + MO_FF_Conv W32 W64 -> coerceFlt2Dbl x + + + -- Float <-> Signed Int conversion ----------------- + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x + + + -- Unsigned integer word size conversions ---------- + + -- If it's the same size, then nothing needs to be done. + MO_UU_Conv from to + | from == to -> conversionNop (intFormat to) x + + -- To narrow an unsigned word, mask out the high bits to simulate what would + -- happen if we copied the value into a smaller register. + MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + + -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 + -- case because the only way we can load it is via SETHI, which needs 2 ops. + -- Do some shifts to chop out the high bits instead. + MO_UU_Conv W32 W16 + -> do tmpReg <- getNewRegNat II32 + (xReg, xCode) <- getSomeReg x + let code dst + = xCode + `appOL` toOL + [ SLL xReg (RIImm $ ImmInt 16) tmpReg + , SRL tmpReg (RIImm $ ImmInt 16) dst] + + return $ Any II32 code + + -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + + -- To widen an unsigned word we don't have to do anything. + -- Just leave it in the same register and mark the result as the new size. + MO_UU_Conv W8 W16 -> conversionNop (intFormat W16) x + MO_UU_Conv W8 W32 -> conversionNop (intFormat W32) x + MO_UU_Conv W16 W32 -> conversionNop (intFormat W32) x + + + -- Signed integer word size conversions ------------ + + -- Mask out high bits when narrowing them + MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + + -- Sign extend signed words when widening them. + MO_SS_Conv W8 W16 -> integerExtend W8 W16 x + MO_SS_Conv W8 W32 -> integerExtend W8 W32 x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 x + + _ -> panic ("Unknown unary mach op: " ++ show mop) + + +-- Binary machine ops +getRegister (CmmMachOp mop [x, y]) + = case mop of + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt W32 -> condIntReg GU x y + MO_U_Ge W32 -> condIntReg GEU x y + MO_U_Lt W32 -> condIntReg LU x y + MO_U_Le W32 -> condIntReg LEU x y + + MO_U_Gt W16 -> condIntReg GU x y + MO_U_Ge W16 -> condIntReg GEU x y + MO_U_Lt W16 -> condIntReg LU x y + MO_U_Le W16 -> condIntReg LEU x y + + MO_Add W32 -> trivialCode W32 (ADD False False) x y + MO_Sub W32 -> trivialCode W32 (SUB False False) x y + + MO_S_MulMayOflo rep -> imulMayOflo rep x y + + MO_S_Quot W32 -> idiv True False x y + MO_U_Quot W32 -> idiv False False x y + + MO_S_Rem W32 -> irem True x y + MO_U_Rem W32 -> irem False x y + + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y + + MO_F_Add w -> trivialFCode w FADD x y + MO_F_Sub w -> trivialFCode w FSUB x y + MO_F_Mul w -> trivialFCode w FMUL x y + MO_F_Quot w -> trivialFCode w FDIV x y + + MO_And rep -> trivialCode rep (AND False) x y + MO_Or rep -> trivialCode rep (OR False) x y + MO_Xor rep -> trivialCode rep (XOR False) x y + + MO_Mul rep -> trivialCode rep (SMUL False) x y + + MO_Shl rep -> trivialCode rep SLL x y + MO_U_Shr rep -> trivialCode rep SRL x y + MO_S_Shr rep -> trivialCode rep SRA x y + + _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) + +getRegister (CmmLoad mem pk) = do + Amode src code <- getAmode mem + let + code__2 dst = code `snocOL` LD (cmmTypeFormat pk) src dst + return (Any (cmmTypeFormat pk) code__2) + +getRegister (CmmLit (CmmInt i _)) + | fits13Bits i + = let + src = ImmInt (fromInteger i) + code dst = unitOL (OR False g0 (RIImm src) dst) + in + return (Any II32 code) + +getRegister (CmmLit lit) + = let imm = litToImm lit + code dst = toOL [ + SETHI (HI imm) dst, + OR False dst (RIImm (LO imm)) dst] + in return (Any II32 code) + + +getRegister _ + = panic "SPARC.CodeGen.Gen32.getRegister: no match" + + +-- | sign extend and widen +integerExtend + :: Width -- ^ width of source expression + -> Width -- ^ width of result + -> CmmExpr -- ^ source expression + -> NatM Register + +integerExtend from to expr + = do -- load the expr into some register + (reg, e_code) <- getSomeReg expr + tmp <- getNewRegNat II32 + let bitCount + = case (from, to) of + (W8, W32) -> 24 + (W16, W32) -> 16 + (W8, W16) -> 24 + _ -> panic "SPARC.CodeGen.Gen32: no match" + let code dst + = e_code + + -- local shift word left to load the sign bit + `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp + + -- arithmetic shift right to sign extend + `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst + + return (Any (intFormat to) code) + + +-- | For nop word format conversions we set the resulting value to have the +-- required size, but don't need to generate any actual code. +-- +conversionNop + :: Format -> CmmExpr -> NatM Register + +conversionNop new_rep expr + = do e_code <- getRegister expr + return (setFormatOfRegister e_code new_rep) + + + +-- | Generate an integer division instruction. +idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register + +-- For unsigned division with a 32 bit numerator, +-- we can just clear the Y register. +idiv False cc x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + + +-- For _signed_ division with a 32 bit numerator, +-- we have to sign extend the numerator into the Y register. +idiv True cc x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend + , SRA tmp (RIImm (ImmInt 16)) tmp + + , WRY tmp g0 + , SDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + + +-- | Do an integer remainder. +-- +-- NOTE: The SPARC v8 architecture manual says that integer division +-- instructions _may_ generate a remainder, depending on the implementation. +-- If so it is _recommended_ that the remainder is placed in the Y register. +-- +-- The UltraSparc 2007 manual says Y is _undefined_ after division. +-- +-- The SPARC T2 doesn't store the remainder, not sure about the others. +-- It's probably best not to worry about it, and just generate our own +-- remainders. +-- +irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register + +-- For unsigned operands: +-- Division is between a 64 bit numerator and a 32 bit denominator, +-- so we still have to clear the Y register. +irem False x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV False a_reg (RIReg b_reg) tmp_reg + , UMUL False tmp_reg (RIReg b_reg) tmp_reg + , SUB False False a_reg (RIReg tmp_reg) dst] + + return (Any II32 code) + + + +-- For signed operands: +-- Make sure to sign extend into the Y register, or the remainder +-- will have the wrong sign when the numerator is negative. +-- +-- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, +-- not the full 32. Not sure why this is, something to do with overflow? +-- If anyone cares enough about the speed of signed remainder they +-- can work it out themselves (then tell me). -- BL 2009/01/20 +irem True x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp1_reg <- getNewRegNat II32 + tmp2_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , WRY tmp1_reg g0 + + , SDIV False a_reg (RIReg b_reg) tmp2_reg + , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg + , SUB False False a_reg (RIReg tmp2_reg) dst] + + return (Any II32 code) + + +imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register +imulMayOflo rep a b + = do + (a_reg, a_code) <- getSomeReg a + (b_reg, b_code) <- getSomeReg b + res_lo <- getNewRegNat II32 + res_hi <- getNewRegNat II32 + + let shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" + + let code dst = a_code `appOL` b_code `appOL` + toOL [ + SMUL False a_reg (RIReg b_reg) res_lo, + RDY res_hi, + SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, + SUB False False res_lo (RIReg res_hi) dst + ] + return (Any II32 code) + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + +trivialCode + :: Width + -> (Reg -> RI -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + +trivialCode _ instr x (CmmLit (CmmInt y _)) + | fits13Bits y + = do + (src1, code) <- getSomeReg x + let + src2 = ImmInt (fromInteger y) + code__2 dst = code `snocOL` instr src1 (RIImm src2) dst + return (Any II32 code__2) + + +trivialCode _ instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 dst = code1 `appOL` code2 `snocOL` + instr src1 (RIReg src2) dst + return (Any II32 code__2) + + +trivialFCode + :: Width + -> (Format -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + +trivialFCode pk instr x y = do + platform <- getPlatform + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp <- getNewRegNat FF64 + let + promote x = FxTOy FF32 FF64 x tmp + + pk1 = cmmExprType platform x + pk2 = cmmExprType platform y + + code__2 dst = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + instr (floatFormat pk) src1 src2 dst + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + instr FF64 tmp src2 dst + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + instr FF64 src1 tmp dst + return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) + code__2) + + + +trivialUCode + :: Format + -> (RI -> Reg -> Instr) + -> CmmExpr + -> NatM Register + +trivialUCode format instr x = do + (src, code) <- getSomeReg x + let + code__2 dst = code `snocOL` instr (RIReg src) dst + return (Any format code__2) + + +trivialUFCode + :: Format + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register + +trivialUFCode pk instr x = do + (src, code) <- getSomeReg x + let + code__2 dst = code `snocOL` instr src dst + return (Any pk code__2) + + + + +-- Coercions ------------------------------------------------------------------- + +-- | Coerce a integer value to floating point +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP width1 width2 x = do + (src, code) <- getSomeReg x + let + code__2 dst = code `appOL` toOL [ + ST (intFormat width1) src (spRel (-2)), + LD (intFormat width1) (spRel (-2)) dst, + FxTOy (intFormat width1) (floatFormat width2) dst dst] + return (Any (floatFormat $ width2) code__2) + + + +-- | Coerce a floating point value to integer +-- +-- NOTE: On sparc v9 there are no instructions to move a value from an +-- FP register directly to an int register, so we have to use a load/store. +-- +coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register +coerceFP2Int width1 width2 x + = do let fformat1 = floatFormat width1 + fformat2 = floatFormat width2 + + iformat2 = intFormat width2 + + (fsrc, code) <- getSomeReg x + fdst <- getNewRegNat fformat2 + + let code2 dst + = code + `appOL` toOL + -- convert float to int format, leaving it in a float reg. + [ FxTOy fformat1 iformat2 fsrc fdst + + -- store the int into mem, then load it back to move + -- it into an actual int reg. + , ST fformat2 fdst (spRel (-2)) + , LD iformat2 (spRel (-2)) dst] + + return (Any iformat2 code2) + + +-- | Coerce a double precision floating point value to single precision. +coerceDbl2Flt :: CmmExpr -> NatM Register +coerceDbl2Flt x = do + (src, code) <- getSomeReg x + return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) + + +-- | Coerce a single precision floating point value to double precision +coerceFlt2Dbl :: CmmExpr -> NatM Register +coerceFlt2Dbl x = do + (src, code) <- getSomeReg x + return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst)) + + + + +-- Condition Codes ------------------------------------------------------------- +-- +-- Evaluate a comparison, and get the result into a register. +-- +-- Do not fill the delay slots here. you will confuse the register allocator. +-- +condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register +condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do + (src, code) <- getSomeReg x + let + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + return (Any II32 code__2) + +condIntReg EQQ x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + return (Any II32 code__2) + +condIntReg NE x (CmmLit (CmmInt 0 _)) = do + (src, code) <- getSomeReg x + let + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + return (Any II32 code__2) + +condIntReg NE x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + return (Any II32 code__2) + +condIntReg cond x y = do + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat + CondCode _ cond cond_code <- condIntCode cond x y + let + code__2 dst + = cond_code + `appOL` toOL + [ BI cond False bid1 + , NOP + + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid2] + + return (Any II32 code__2) + + +condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg cond x y = do + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat + + CondCode _ cond cond_code <- condFltCode cond x y + let + code__2 dst + = cond_code + `appOL` toOL + [ NOP + , BF cond False bid1 + , NOP + + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid2 ] + + return (Any II32 code__2) diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot b/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot @@ -0,0 +1,16 @@ + +module GHC.CmmToAsm.SPARC.CodeGen.Gen32 ( + getSomeReg, + getRegister +) + +where + +import GHC.CmmToAsm.SPARC.CodeGen.Base +import GHC.CmmToAsm.Monad +import GHC.Platform.Reg + +import GHC.Cmm + +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getRegister :: CmmExpr -> NatM Register diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs @@ -0,0 +1,213 @@ +-- | Evaluation of 64 bit values on 32 bit platforms. +module GHC.CmmToAsm.SPARC.CodeGen.Gen64 ( + assignMem_I64Code, + assignReg_I64Code, + iselExpr64 +) + +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 +import GHC.CmmToAsm.SPARC.CodeGen.Base +import GHC.CmmToAsm.SPARC.CodeGen.Amode +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.Instr +-- GHC.CmmToAsm.SPARC.Ppr() +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Format +import GHC.Platform.Reg + +import GHC.Cmm + +import GHC.Data.OrdList +import GHC.Utils.Outputable + +-- | Code to assign a 64 bit value to memory. +assignMem_I64Code + :: CmmExpr -- ^ expr producing the destination address + -> CmmExpr -- ^ expr producing the source value. + -> NatM InstrBlock + +assignMem_I64Code addrTree valueTree + = do + ChildCode64 vcode rlo <- iselExpr64 valueTree + + (src, acode) <- getSomeReg addrTree + let + rhi = getHiVRegFromLo rlo + + -- Big-endian store + mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0)) + mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4)) + + code = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo + +{- pprTrace "assignMem_I64Code" + (vcat [ text "addrTree: " <+> ppr addrTree + , text "valueTree: " <+> ppr valueTree + , text "vcode:" + , vcat $ map ppr $ fromOL vcode + , text "" + , text "acode:" + , vcat $ map ppr $ fromOL acode ]) + $ -} + return code + + +-- | Code to assign a 64 bit value to a register. +assignReg_I64Code + :: CmmReg -- ^ the destination register + -> CmmExpr -- ^ expr producing the source value + -> NatM InstrBlock + +assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree + = do + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree + let + r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk) + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = mkMOV r_src_lo r_dst_lo + mov_hi = mkMOV r_src_hi r_dst_hi + mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg + + return (vcode `snocOL` mov_hi `snocOL` mov_lo) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(sparc): invalid lvalue" + + + + +-- | Get the value of an expression into a 64 bit register. + +iselExpr64 :: CmmExpr -> NatM ChildCode64 + +-- Load a 64 bit word +iselExpr64 (CmmLoad addrTree ty) + | isWord64 ty + = do Amode amode addr_code <- getAmode addrTree + let result + + | AddrRegReg r1 r2 <- amode + = do rlo <- getNewRegNat II32 + tmp <- getNewRegNat II32 + let rhi = getHiVRegFromLo rlo + + return $ ChildCode64 + ( addr_code + `appOL` toOL + [ ADD False False r1 (RIReg r2) tmp + , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi + , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ]) + rlo + + | AddrRegImm r1 (ImmInt i) <- amode + = do rlo <- getNewRegNat II32 + let rhi = getHiVRegFromLo rlo + + return $ ChildCode64 + ( addr_code + `appOL` toOL + [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi + , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ]) + rlo + + | otherwise + = panic "SPARC.CodeGen.Gen64: no match" + + result + + +-- Add a literal to a 64 bit integer +iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) + = do ChildCode64 code1 r1_lo <- iselExpr64 e1 + let r1_hi = getHiVRegFromLo r1_lo + + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + let code = code1 + `appOL` toOL + [ ADD False True r1_lo (RIImm (ImmInteger i)) r_dst_lo + , ADD True False r1_hi (RIReg g0) r_dst_hi ] + + return $ ChildCode64 code r_dst_lo + + +-- Addition of II64 +iselExpr64 (CmmMachOp (MO_Add _) [e1, e2]) + = do ChildCode64 code1 r1_lo <- iselExpr64 e1 + let r1_hi = getHiVRegFromLo r1_lo + + ChildCode64 code2 r2_lo <- iselExpr64 e2 + let r2_hi = getHiVRegFromLo r2_lo + + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + let code = code1 + `appOL` code2 + `appOL` toOL + [ ADD False True r1_lo (RIReg r2_lo) r_dst_lo + , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] + + return $ ChildCode64 code r_dst_lo + + +iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) + | isWord64 ty + = do + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_lo = RegVirtual $ mkVirtualReg uq II32 + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = mkMOV r_src_lo r_dst_lo + mov_hi = mkMOV r_src_hi r_dst_hi + mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg + return ( + ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo + ) + +-- Convert something into II64 +iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) + = do + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + -- compute expr and load it into r_dst_lo + (a_reg, a_code) <- getSomeReg expr + + platform <- getPlatform + let code = a_code + `appOL` toOL + [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits + , mkRegRegMoveInstr platform a_reg r_dst_lo ] + + return $ ChildCode64 code r_dst_lo + +-- only W32 supported for now +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) + = do + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + -- compute expr and load it into r_dst_lo + (a_reg, a_code) <- getSomeReg expr + + platform <- getPlatform + let code = a_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi + , mkRegRegMoveInstr platform a_reg r_dst_lo ] + + return $ ChildCode64 code r_dst_lo + + +iselExpr64 expr + = pprPanic "iselExpr64(sparc)" (ppr expr) diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs b/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs @@ -0,0 +1,69 @@ +-- | One ounce of sanity checking is worth 10000000000000000 ounces +-- of staring blindly at assembly code trying to find the problem.. +module GHC.CmmToAsm.SPARC.CodeGen.Sanity ( + checkBlock +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances +import GHC.CmmToAsm.Instr + +import GHC.Cmm + +import GHC.Utils.Outputable + + +-- | Enforce intra-block invariants. +-- +checkBlock :: CmmBlock + -> NatBasicBlock Instr + -> NatBasicBlock Instr + +checkBlock cmm block@(BasicBlock _ instrs) + | checkBlockInstrs instrs + = block + + | otherwise + = pprPanic + ("SPARC.CodeGen: bad block\n") + ( vcat [ text " -- cmm -----------------\n" + , ppr cmm + , text " -- native code ---------\n" + , ppr block ]) + + +checkBlockInstrs :: [Instr] -> Bool +checkBlockInstrs ii + + -- An unconditional jumps end the block. + -- There must be an unconditional jump in the block, otherwise + -- the register liveness determinator will get the liveness + -- information wrong. + -- + -- If the block ends with a cmm call that never returns + -- then there can be unreachable instructions after the jump, + -- but we don't mind here. + -- + | instr : NOP : _ <- ii + , isUnconditionalJump instr + = True + + -- All jumps must have a NOP in their branch delay slot. + -- The liveness determinator and register allocators aren't smart + -- enough to handle branch delay slots. + -- + | instr : NOP : is <- ii + , isJumpishInstr instr + = checkBlockInstrs is + + -- keep checking + | _:i2:is <- ii + = checkBlockInstrs (i2:is) + + -- this block is no good + | otherwise + = False diff --git a/GHC/CmmToAsm/SPARC/Cond.hs b/GHC/CmmToAsm/SPARC/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/Cond.hs @@ -0,0 +1,27 @@ +module GHC.CmmToAsm.SPARC.Cond ( + Cond(..), +) + +where + +import GHC.Prelude + +-- | Branch condition codes. +data Cond + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + | NEG + | NEVER + | POS + | VC + | VS + deriving Eq diff --git a/GHC/CmmToAsm/SPARC/Imm.hs b/GHC/CmmToAsm/SPARC/Imm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/Imm.hs @@ -0,0 +1,67 @@ +module GHC.CmmToAsm.SPARC.Imm ( + -- immediate values + Imm(..), + strImmLit, + litToImm +) + +where + +import GHC.Prelude + +import GHC.Cmm +import GHC.Cmm.CLabel + +import GHC.Utils.Outputable + +-- | An immediate value. +-- Not all of these are directly representable by the machine. +-- Things like ImmLit are slurped out and put in a data segment instead. +-- +data Imm + = ImmInt Int + + -- Sigh. + | ImmInteger Integer + + -- AbstractC Label (with baggage) + | ImmCLbl CLabel + + -- Simple string + | ImmLit SDoc + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + + | LO Imm + | HI Imm + + +-- | Create a ImmLit containing this string. +strImmLit :: String -> Imm +strImmLit s = ImmLit (text s) + + +-- | Convert a CmmLit to an Imm. +-- Narrow to the width: a CmmInt might be out of +-- range, but we assume that ImmInteger only contains +-- in-range values. A signed value should be fine here. +-- +litToImm :: CmmLit -> Imm +litToImm lit + = case lit of + CmmInt i w -> ImmInteger (narrowS w i) + CmmFloat f W32 -> ImmFloat f + CmmFloat f W64 -> ImmDouble f + CmmLabel l -> ImmCLbl l + CmmLabelOff l off -> ImmIndex l off + + CmmLabelDiffOff l1 l2 off _ + -> ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) + + _ -> panic "SPARC.Regs.litToImm: no match" diff --git a/GHC/CmmToAsm/SPARC/Instr.hs b/GHC/CmmToAsm/SPARC/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/Instr.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- +#include "HsVersions.h" + +module GHC.CmmToAsm.SPARC.Instr ( + RI(..), + riZero, + + fpRelEA, + moveSp, + + isUnconditionalJump, + + Instr(..), + maxSpillSlots +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Stack +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Cond +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.Base +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg.Class +import GHC.Platform.Reg +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config + +import GHC.Cmm.CLabel +import GHC.Platform.Regs +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Platform + + +-- | Register or immediate +data RI + = RIReg Reg + | RIImm Imm + +-- | Check if a RI represents a zero value. +-- - a literal zero +-- - register %g0, which is always zero. +-- +riZero :: RI -> Bool +riZero (RIImm (ImmInt 0)) = True +riZero (RIImm (ImmInteger 0)) = True +riZero (RIReg (RegReal (RealRegSingle 0))) = True +riZero _ = False + + +-- | Calculate the effective address which would be used by the +-- corresponding fpRel sequence. +fpRelEA :: Int -> Reg -> Instr +fpRelEA n dst + = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst + + +-- | Code to shift the stack pointer by n words. +moveSp :: Int -> Instr +moveSp n + = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp + +-- | An instruction that will cause the one after it never to be exectuted +isUnconditionalJump :: Instr -> Bool +isUnconditionalJump ii + = case ii of + CALL{} -> True + JMP{} -> True + JMP_TBL{} -> True + BI ALWAYS _ _ -> True + BF ALWAYS _ _ -> True + _ -> False + + +-- | instance for sparc instruction set +instance Instruction Instr where + regUsageOfInstr = sparc_regUsageOfInstr + patchRegsOfInstr = sparc_patchRegsOfInstr + isJumpishInstr = sparc_isJumpishInstr + jumpDestsOfInstr = sparc_jumpDestsOfInstr + patchJumpInstr = sparc_patchJumpInstr + mkSpillInstr = sparc_mkSpillInstr + mkLoadInstr = sparc_mkLoadInstr + takeDeltaInstr = sparc_takeDeltaInstr + isMetaInstr = sparc_isMetaInstr + mkRegRegMoveInstr = sparc_mkRegRegMoveInstr + takeRegRegMoveInstr = sparc_takeRegRegMoveInstr + mkJumpInstr = sparc_mkJumpInstr + mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" + mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" + + +-- | SPARC instruction set. +-- Not complete. This is only the ones we need. +-- +data Instr + + -- meta ops -------------------------------------------------- + -- comment pseudo-op + = COMMENT FastString + + -- some static data spat out during code generation. + -- Will be extracted before pretty-printing. + | LDATA Section RawCmmStatics + + -- Start a new basic block. Useful during codegen, removed later. + -- Preceding instruction should be a jump, as per the invariants + -- for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for benefit of subsequent passes. + | DELTA Int + + -- real instrs ----------------------------------------------- + -- Loads and stores. + | LD Format AddrMode Reg -- format, src, dst + | ST Format Reg AddrMode -- format, src, dst + + -- Int Arithmetic. + -- x: add/sub with carry bit. + -- In SPARC V9 addx and friends were renamed addc. + -- + -- cc: modify condition codes + -- + | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + + | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst + | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst + + + -- The SPARC divide instructions perform 64bit by 32bit division + -- The Y register is xored into the first operand. + + -- On _some implementations_ the Y register is overwritten by + -- the remainder, so we have to make sure it is 0 each time. + + -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 + | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst + | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst + + | RDY Reg -- move contents of Y register to reg + | WRY Reg Reg -- Y <- src1 `xor` src2 + + -- Logic operations. + | AND Bool Reg RI Reg -- cc?, src1, src2, dst + | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst + | OR Bool Reg RI Reg -- cc?, src1, src2, dst + | ORN Bool Reg RI Reg -- cc?, src1, src2, dst + | XOR Bool Reg RI Reg -- cc?, src1, src2, dst + | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst + | SLL Reg RI Reg -- src1, src2, dst + | SRL Reg RI Reg -- src1, src2, dst + | SRA Reg RI Reg -- src1, src2, dst + + -- Load immediates. + | SETHI Imm Reg -- src, dst + + -- Do nothing. + -- Implemented by the assembler as SETHI 0, %g0, but worth an alias + | NOP + + -- Float Arithmetic. + -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single + -- instructions right up until we spit them out. + -- + | FABS Format Reg Reg -- src dst + | FADD Format Reg Reg Reg -- src1, src2, dst + | FCMP Bool Format Reg Reg -- exception?, src1, src2, dst + | FDIV Format Reg Reg Reg -- src1, src2, dst + | FMOV Format Reg Reg -- src, dst + | FMUL Format Reg Reg Reg -- src1, src2, dst + | FNEG Format Reg Reg -- src, dst + | FSQRT Format Reg Reg -- src, dst + | FSUB Format Reg Reg Reg -- src1, src2, dst + | FxTOy Format Format Reg Reg -- src, dst + + -- Jumping around. + | BI Cond Bool BlockId -- cond, annul?, target + | BF Cond Bool BlockId -- cond, annul?, target + + | JMP AddrMode -- target + + -- With a tabled jump we know all the possible destinations. + -- We also need this info so we can work out what regs are live across the jump. + -- + | JMP_TBL AddrMode [Maybe BlockId] CLabel + + | CALL (Either Imm Reg) Int Bool -- target, args, terminal + + +-- | regUsage returns the sets of src and destination registers used +-- by a particular instruction. Machine registers that are +-- pre-allocated to stgRegs are filtered out, because they are +-- uninteresting from a register allocation standpoint. (We wouldn't +-- want them to end up on the free list!) As far as we are concerned, +-- the fixed registers simply don't exist (for allocation purposes, +-- anyway). + +-- regUsage doesn't need to do any trickery for jumps and such. Just +-- state precisely the regs read and written by that insn. The +-- consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage +sparc_regUsageOfInstr platform instr + = case instr of + LD _ addr reg -> usage (regAddr addr, [reg]) + ST _ reg addr -> usage (reg : regAddr addr, []) + ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + RDY rd -> usage ([], [rd]) + WRY r1 r2 -> usage ([r1, r2], []) + AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SETHI _ reg -> usage ([], [reg]) + FABS _ r1 r2 -> usage ([r1], [r2]) + FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FCMP _ _ r1 r2 -> usage ([r1, r2], []) + FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FMOV _ r1 r2 -> usage ([r1], [r2]) + FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FNEG _ r1 r2 -> usage ([r1], [r2]) + FSQRT _ r1 r2 -> usage ([r1], [r2]) + FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FxTOy _ _ r1 r2 -> usage ([r1], [r2]) + + JMP addr -> usage (regAddr addr, []) + JMP_TBL addr _ _ -> usage (regAddr addr, []) + + CALL (Left _ ) _ True -> noUsage + CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) + CALL (Right reg) _ True -> usage ([reg], []) + CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) + _ -> noUsage + + where + usage (src, dst) + = RU (filter (interesting platform) src) + (filter (interesting platform) dst) + + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + + regRI (RIReg r) = [r] + regRI _ = [] + + +-- | Interesting regs are virtuals, or ones that are allocatable +-- by the register allocator. +interesting :: Platform -> Reg -> Bool +interesting platform reg + = case reg of + RegVirtual _ -> True + RegReal (RealRegSingle r1) -> freeReg platform r1 + RegReal (RealRegPair r1 _) -> freeReg platform r1 + + + +-- | Apply a given mapping to tall the register references in this instruction. +sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +sparc_patchRegsOfInstr instr env = case instr of + LD fmt addr reg -> LD fmt (fixAddr addr) (env reg) + ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) + + ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) + SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) + UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) + SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) + UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) + SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) + RDY rd -> RDY (env rd) + WRY r1 r2 -> WRY (env r1) (env r2) + AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) + ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) + OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) + ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) + XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) + XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) + SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) + SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) + SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) + + SETHI imm reg -> SETHI imm (env reg) + + FABS s r1 r2 -> FABS s (env r1) (env r2) + FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) + FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) + FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) + FMOV s r1 r2 -> FMOV s (env r1) (env r2) + FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) + FNEG s r1 r2 -> FNEG s (env r1) (env r2) + FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) + FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) + FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) + + JMP addr -> JMP (fixAddr addr) + JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l + + CALL (Left i) n t -> CALL (Left i) n t + CALL (Right r) n t -> CALL (Right (env r)) n t + _ -> instr + + where + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + + fixRI (RIReg r) = RIReg (env r) + fixRI other = other + + +-------------------------------------------------------------------------------- +sparc_isJumpishInstr :: Instr -> Bool +sparc_isJumpishInstr instr + = case instr of + BI{} -> True + BF{} -> True + JMP{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False + +sparc_jumpDestsOfInstr :: Instr -> [BlockId] +sparc_jumpDestsOfInstr insn + = case insn of + BI _ _ id -> [id] + BF _ _ id -> [id] + JMP_TBL _ ids _ -> [id | Just id <- ids] + _ -> [] + + +sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +sparc_patchJumpInstr insn patchF + = case insn of + BI cc annul id -> BI cc annul (patchF id) + BF cc annul id -> BF cc annul (patchF id) + JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l + _ -> insn + + +-------------------------------------------------------------------------------- +-- | Make a spill instruction. +-- On SPARC we spill below frame pointer leaving 2 words/spill +sparc_mkSpillInstr + :: NCGConfig + -> Reg -- ^ register to spill + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr + +sparc_mkSpillInstr config reg _ slot + = let platform = ncgPlatform config + off = spillSlotToOffset config slot + off_w = 1 + (off `div` 4) + fmt = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + + in ST fmt reg (fpRel (negate off_w)) + + +-- | Make a spill reload instruction. +sparc_mkLoadInstr + :: NCGConfig + -> Reg -- ^ register to load into + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr + +sparc_mkLoadInstr config reg _ slot + = let platform = ncgPlatform config + off = spillSlotToOffset config slot + off_w = 1 + (off `div` 4) + fmt = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + + in LD fmt (fpRel (- off_w)) reg + + +-------------------------------------------------------------------------------- +-- | See if this instruction is telling us the current C stack delta +sparc_takeDeltaInstr + :: Instr + -> Maybe Int + +sparc_takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +sparc_isMetaInstr + :: Instr + -> Bool + +sparc_isMetaInstr instr + = case instr of + COMMENT{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + + +-- | Make a reg-reg move instruction. +-- On SPARC v8 there are no instructions to move directly between +-- floating point and integer regs. If we need to do that then we +-- have to go via memory. +-- +sparc_mkRegRegMoveInstr + :: Platform + -> Reg + -> Reg + -> Instr + +sparc_mkRegRegMoveInstr platform src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst + , srcClass == dstClass + = case srcClass of + RcInteger -> ADD False False src (RIReg g0) dst + RcDouble -> FMOV FF64 src dst + RcFloat -> FMOV FF32 src dst + + | otherwise + = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" + + +-- | Check whether an instruction represents a reg-reg move. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. +-- +sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) +sparc_takeRegRegMoveInstr instr + = case instr of + ADD False False src (RIReg src2) dst + | g0 == src2 -> Just (src, dst) + + FMOV FF64 src dst -> Just (src, dst) + FMOV FF32 src dst -> Just (src, dst) + _ -> Nothing + + +-- | Make an unconditional branch instruction. +sparc_mkJumpInstr + :: BlockId + -> [Instr] + +sparc_mkJumpInstr id + = [BI ALWAYS False id + , NOP] -- fill the branch delay slot. diff --git a/GHC/CmmToAsm/SPARC/Ppr.hs b/GHC/CmmToAsm/SPARC/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/Ppr.hs @@ -0,0 +1,647 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.CmmToAsm.SPARC.Ppr ( + pprNatCmmDecl, + pprBasicBlock, + pprData, + pprInstr, + pprFormat, + pprImm, + pprDataItem +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Cond +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Base +import GHC.CmmToAsm.Instr +import GHC.Platform.Reg +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Config + +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.Ppr() -- For Outputable instances +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Collections + +import GHC.Types.Unique ( pprUniqueAlways ) +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Data.FastString + +-- ----------------------------------------------------------------------------- +-- Printing this stuff out + +pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section + $$ pprDatas (ncgPlatform config) dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in + case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) $$ + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform top_info) blocks) + + Just (CmmStaticsRaw info_lbl _) -> + (if platformHasSubsectionsViaSymbols platform + then pprSectionAlign config dspSection $$ + ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock platform top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then + -- See Note [Subsections Via Symbols] in X86/Ppr.hs + text "\t.long " + <+> ppr info_lbl + <+> char '-' + <+> ppr (mkDeadStripPreventer info_lbl) + else empty) + +dspSection :: Section +dspSection = Section Text $ + panic "subsections-via-symbols doesn't combine with split-sections" + +pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock platform info_env (BasicBlock blockid instrs) + = maybe_infotable $$ + pprLabel platform (blockLbl blockid) $$ + vcat (map pprInstr instrs) + where + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (CmmStaticsRaw info_lbl info) -> + pprAlignForSection Text $$ + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl + + +pprDatas :: Platform -> RawCmmStatics -> SDoc +-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl alias + $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') +pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) + +pprData :: Platform -> CmmStatic -> SDoc +pprData platform d = case d of + CmmString str -> pprString str + CmmFileEmbed path -> pprFileEmbed path + CmmUninitialised bytes -> text ".skip " <> int bytes + CmmStaticLit lit -> pprDataItem platform lit + +pprGloblDecl :: CLabel -> SDoc +pprGloblDecl lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = text ".global " <> ppr lbl + +pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc +pprTypeAndSizeDecl platform lbl + = if platformOS platform == OSLinux && externallyVisibleCLabel lbl + then text ".type " <> ppr lbl <> ptext (sLit ", @object") + else empty + +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = + pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (ppr lbl <> char ':') + +-- ----------------------------------------------------------------------------- +-- pprInstr: print an 'Instr' + +instance Outputable Instr where + ppr instr = pprInstr instr + + +-- | Pretty print a register. +pprReg :: Reg -> SDoc +pprReg reg + = case reg of + RegVirtual vr + -> case vr of + VirtualRegI u -> text "%vI_" <> pprUniqueAlways u + VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u + VirtualRegF u -> text "%vF_" <> pprUniqueAlways u + VirtualRegD u -> text "%vD_" <> pprUniqueAlways u + + + RegReal rr + -> case rr of + RealRegSingle r1 + -> pprReg_ofRegNo r1 + + RealRegPair r1 r2 + -> text "(" <> pprReg_ofRegNo r1 + <> vbar <> pprReg_ofRegNo r2 + <> text ")" + + + +-- | Pretty print a register name, based on this register number. +-- The definition has been unfolded so we get a jump-table in the +-- object code. This function is called quite a lot when emitting +-- the asm file.. +-- +pprReg_ofRegNo :: Int -> SDoc +pprReg_ofRegNo i + = ptext + (case i of { + 0 -> sLit "%g0"; 1 -> sLit "%g1"; + 2 -> sLit "%g2"; 3 -> sLit "%g3"; + 4 -> sLit "%g4"; 5 -> sLit "%g5"; + 6 -> sLit "%g6"; 7 -> sLit "%g7"; + 8 -> sLit "%o0"; 9 -> sLit "%o1"; + 10 -> sLit "%o2"; 11 -> sLit "%o3"; + 12 -> sLit "%o4"; 13 -> sLit "%o5"; + 14 -> sLit "%o6"; 15 -> sLit "%o7"; + 16 -> sLit "%l0"; 17 -> sLit "%l1"; + 18 -> sLit "%l2"; 19 -> sLit "%l3"; + 20 -> sLit "%l4"; 21 -> sLit "%l5"; + 22 -> sLit "%l6"; 23 -> sLit "%l7"; + 24 -> sLit "%i0"; 25 -> sLit "%i1"; + 26 -> sLit "%i2"; 27 -> sLit "%i3"; + 28 -> sLit "%i4"; 29 -> sLit "%i5"; + 30 -> sLit "%i6"; 31 -> sLit "%i7"; + 32 -> sLit "%f0"; 33 -> sLit "%f1"; + 34 -> sLit "%f2"; 35 -> sLit "%f3"; + 36 -> sLit "%f4"; 37 -> sLit "%f5"; + 38 -> sLit "%f6"; 39 -> sLit "%f7"; + 40 -> sLit "%f8"; 41 -> sLit "%f9"; + 42 -> sLit "%f10"; 43 -> sLit "%f11"; + 44 -> sLit "%f12"; 45 -> sLit "%f13"; + 46 -> sLit "%f14"; 47 -> sLit "%f15"; + 48 -> sLit "%f16"; 49 -> sLit "%f17"; + 50 -> sLit "%f18"; 51 -> sLit "%f19"; + 52 -> sLit "%f20"; 53 -> sLit "%f21"; + 54 -> sLit "%f22"; 55 -> sLit "%f23"; + 56 -> sLit "%f24"; 57 -> sLit "%f25"; + 58 -> sLit "%f26"; 59 -> sLit "%f27"; + 60 -> sLit "%f28"; 61 -> sLit "%f29"; + 62 -> sLit "%f30"; 63 -> sLit "%f31"; + _ -> sLit "very naughty sparc register" }) + + +-- | Pretty print a format for an instruction suffix. +pprFormat :: Format -> SDoc +pprFormat x + = ptext + (case x of + II8 -> sLit "ub" + II16 -> sLit "uh" + II32 -> sLit "" + II64 -> sLit "d" + FF32 -> sLit "" + FF64 -> sLit "d") + + +-- | Pretty print a format for an instruction suffix. +-- eg LD is 32bit on sparc, but LDD is 64 bit. +pprStFormat :: Format -> SDoc +pprStFormat x + = ptext + (case x of + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "" + II64 -> sLit "x" + FF32 -> sLit "" + FF64 -> sLit "d") + + + +-- | Pretty print a condition code. +pprCond :: Cond -> SDoc +pprCond c + = ptext + (case c of + ALWAYS -> sLit "" + NEVER -> sLit "n" + GEU -> sLit "geu" + LU -> sLit "lu" + EQQ -> sLit "e" + GTT -> sLit "g" + GE -> sLit "ge" + GU -> sLit "gu" + LTT -> sLit "l" + LE -> sLit "le" + LEU -> sLit "leu" + NE -> sLit "ne" + NEG -> sLit "neg" + POS -> sLit "pos" + VC -> sLit "vc" + VS -> sLit "vs") + + +-- | Pretty print an address mode. +pprAddr :: AddrMode -> SDoc +pprAddr am + = case am of + AddrRegReg r1 (RegReal (RealRegSingle 0)) + -> pprReg r1 + + AddrRegReg r1 r2 + -> hcat [ pprReg r1, char '+', pprReg r2 ] + + AddrRegImm r1 (ImmInt i) + | i == 0 -> pprReg r1 + | not (fits13Bits i) -> largeOffsetError i + | otherwise -> hcat [ pprReg r1, pp_sign, int i ] + where + pp_sign = if i > 0 then char '+' else empty + + AddrRegImm r1 (ImmInteger i) + | i == 0 -> pprReg r1 + | not (fits13Bits i) -> largeOffsetError i + | otherwise -> hcat [ pprReg r1, pp_sign, integer i ] + where + pp_sign = if i > 0 then char '+' else empty + + AddrRegImm r1 imm + -> hcat [ pprReg r1, char '+', pprImm imm ] + + +-- | Pretty print an immediate value. +pprImm :: Imm -> SDoc +pprImm imm + = case imm of + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> ppr l + ImmIndex l i -> ppr l <> char '+' <> int i + ImmLit s -> s + + ImmConstantSum a b + -> pprImm a <> char '+' <> pprImm b + + ImmConstantDiff a b + -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen + + LO i + -> hcat [ text "%lo(", pprImm i, rparen ] + + HI i + -> hcat [ text "%hi(", pprImm i, rparen ] + + -- these should have been converted to bytes and placed + -- in the data section. + ImmFloat _ -> text "naughty float immediate" + ImmDouble _ -> text "naughty double immediate" + + +-- | Pretty print a section \/ segment header. +-- On SPARC all the data sections must be at least 8 byte aligned +-- incase we store doubles in them. +-- +pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign config sec@(Section seg _) = + pprSectionHeader config sec $$ + pprAlignForSection seg + +-- | Print appropriate alignment for the given section type. +pprAlignForSection :: SectionType -> SDoc +pprAlignForSection seg = + ptext (case seg of + Text -> sLit ".align 4" + Data -> sLit ".align 8" + ReadOnlyData -> sLit ".align 8" + RelocatableReadOnlyData + -> sLit ".align 8" + UninitialisedData -> sLit ".align 8" + ReadOnlyData16 -> sLit ".align 16" + -- TODO: This is copied from the ReadOnlyData case, but it can likely be + -- made more efficient. + CString -> sLit ".align 8" + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section") + +-- | Pretty print a data item. +pprDataItem :: Platform -> CmmLit -> SDoc +pprDataItem platform lit + = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + imm = litToImm lit + + ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + + ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm] + ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" + + +-- | Pretty print an instruction. +pprInstr :: Instr -> SDoc + +-- nuke comments. +pprInstr (COMMENT _) + = empty + +pprInstr (DELTA d) + = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) + +-- Newblocks and LData should have been slurped out before producing the .s file. +pprInstr (NEWBLOCK _) + = panic "X86.Ppr.pprInstr: NEWBLOCK" + +pprInstr (LDATA _ _) + = panic "PprMach.pprInstr: LDATA" + +-- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand +pprInstr (LD FF64 _ reg) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" + +pprInstr (LD format addr reg) + = hcat [ + text "\tld", + pprFormat format, + char '\t', + lbrack, + pprAddr addr, + pp_rbracket_comma, + pprReg reg + ] + +-- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand +pprInstr (ST FF64 reg _) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" + +-- no distinction is made between signed and unsigned bytes on stores for the +-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), +-- so we call a special-purpose pprFormat for ST.. +pprInstr (ST format reg addr) + = hcat [ + text "\tst", + pprStFormat format, + char '\t', + pprReg reg, + pp_comma_lbracket, + pprAddr addr, + rbrack + ] + + +pprInstr (ADD x cc reg1 ri reg2) + | not x && not cc && riZero ri + = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] + + | otherwise + = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 + + +pprInstr (SUB x cc reg1 ri reg2) + | not x && cc && reg2 == g0 + = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ] + + | not x && not cc && riZero ri + = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] + + | otherwise + = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 + +pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2 + +pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 + +pprInstr (OR b reg1 ri reg2) + | not b && reg1 == g0 + = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ] + in case ri of + RIReg rrr | rrr == reg2 -> empty + _ -> doit + + | otherwise + = pprRegRIReg (sLit "or") b reg1 ri reg2 + +pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2 + +pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2 +pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2 + +pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 +pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 +pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 + +pprInstr (RDY rd) = text "\trd\t%y," <> pprReg rd +pprInstr (WRY reg1 reg2) + = text "\twr\t" + <> pprReg reg1 + <> char ',' + <> pprReg reg2 + <> char ',' + <> text "%y" + +pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 +pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 +pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2 +pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2 + +pprInstr (SETHI imm reg) + = hcat [ + text "\tsethi\t", + pprImm imm, + comma, + pprReg reg + ] + +pprInstr NOP + = text "\tnop" + +pprInstr (FABS format reg1 reg2) + = pprFormatRegReg (sLit "fabs") format reg1 reg2 + +pprInstr (FADD format reg1 reg2 reg3) + = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3 + +pprInstr (FCMP e format reg1 reg2) + = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp") + format reg1 reg2 + +pprInstr (FDIV format reg1 reg2 reg3) + = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3 + +pprInstr (FMOV format reg1 reg2) + = pprFormatRegReg (sLit "fmov") format reg1 reg2 + +pprInstr (FMUL format reg1 reg2 reg3) + = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3 + +pprInstr (FNEG format reg1 reg2) + = pprFormatRegReg (sLit "fneg") format reg1 reg2 + +pprInstr (FSQRT format reg1 reg2) + = pprFormatRegReg (sLit "fsqrt") format reg1 reg2 + +pprInstr (FSUB format reg1 reg2 reg3) + = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3 + +pprInstr (FxTOy format1 format2 reg1 reg2) + = hcat [ + text "\tf", + ptext + (case format1 of + II32 -> sLit "ito" + FF32 -> sLit "sto" + FF64 -> sLit "dto" + _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), + ptext + (case format2 of + II32 -> sLit "i\t" + II64 -> sLit "x\t" + FF32 -> sLit "s\t" + FF64 -> sLit "d\t" + _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), + pprReg reg1, comma, pprReg reg2 + ] + + +pprInstr (BI cond b blockid) + = hcat [ + text "\tb", pprCond cond, + if b then pp_comma_a else empty, + char '\t', + ppr (blockLbl blockid) + ] + +pprInstr (BF cond b blockid) + = hcat [ + text "\tfb", pprCond cond, + if b then pp_comma_a else empty, + char '\t', + ppr (blockLbl blockid) + ] + +pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr +pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) + +pprInstr (CALL (Left imm) n _) + = hcat [ text "\tcall\t", pprImm imm, comma, int n ] + +pprInstr (CALL (Right reg) n _) + = hcat [ text "\tcall\t", pprReg reg, comma, int n ] + + +-- | Pretty print a RI +pprRI :: RI -> SDoc +pprRI (RIReg r) = pprReg r +pprRI (RIImm r) = pprImm r + + +-- | Pretty print a two reg instruction. +pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc +pprFormatRegReg name format reg1 reg2 + = hcat [ + char '\t', + ptext name, + (case format of + FF32 -> text "s\t" + FF64 -> text "d\t" + _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), + + pprReg reg1, + comma, + pprReg reg2 + ] + + +-- | Pretty print a three reg instruction. +pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc +pprFormatRegRegReg name format reg1 reg2 reg3 + = hcat [ + char '\t', + ptext name, + (case format of + FF32 -> text "s\t" + FF64 -> text "d\t" + _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), + pprReg reg1, + comma, + pprReg reg2, + comma, + pprReg reg3 + ] + + +-- | Pretty print an instruction of two regs and a ri. +pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc +pprRegRIReg name b reg1 ri reg2 + = hcat [ + char '\t', + ptext name, + if b then text "cc\t" else char '\t', + pprReg reg1, + comma, + pprRI ri, + comma, + pprReg reg2 + ] + +{- +pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc +pprRIReg name b ri reg1 + = hcat [ + char '\t', + ptext name, + if b then text "cc\t" else char '\t', + pprRI ri, + comma, + pprReg reg1 + ] +-} + +{- +pp_ld_lbracket :: SDoc +pp_ld_lbracket = text "\tld\t[" +-} + +pp_rbracket_comma :: SDoc +pp_rbracket_comma = text "]," + + +pp_comma_lbracket :: SDoc +pp_comma_lbracket = text ",[" + + +pp_comma_a :: SDoc +pp_comma_a = text ",a" diff --git a/GHC/CmmToAsm/SPARC/Regs.hs b/GHC/CmmToAsm/SPARC/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/Regs.hs @@ -0,0 +1,259 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1994-2004 +-- +-- ----------------------------------------------------------------------------- + +module GHC.CmmToAsm.SPARC.Regs ( + -- registers + showReg, + virtualRegSqueeze, + realRegSqueeze, + classOfRealReg, + allRealRegs, + + -- machine specific info + gReg, iReg, lReg, oReg, fReg, + fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, + + -- allocatable + allocatableRegs, + + -- args + argRegs, + allArgRegs, + callClobberedRegs, + + -- + mkVirtualReg, + regDotColor +) + +where + + +import GHC.Prelude + +import GHC.Platform.SPARC +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.CmmToAsm.Format + +import GHC.Types.Unique +import GHC.Utils.Outputable + +{- + The SPARC has 64 registers of interest; 32 integer registers and 32 + floating point registers. The mapping of STG registers to SPARC + machine registers is defined in StgRegs.h. We are, of course, + prepared for any eventuality. + + The whole fp-register pairing thing on sparcs is a huge nuisance. See + includes/stg/MachRegs.h for a description of what's going on + here. +-} + + +-- | Get the standard name for the register with this number. +showReg :: RegNo -> String +showReg n + | n >= 0 && n < 8 = "%g" ++ show n + | n >= 8 && n < 16 = "%o" ++ show (n-8) + | n >= 16 && n < 24 = "%l" ++ show (n-16) + | n >= 24 && n < 32 = "%i" ++ show (n-24) + | n >= 32 && n < 64 = "%f" ++ show (n-32) + | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" + + +-- Get the register class of a certain real reg +classOfRealReg :: RealReg -> RegClass +classOfRealReg reg + = case reg of + RealRegSingle i + | i < 32 -> RcInteger + | otherwise -> RcFloat + + RealRegPair{} -> RcDouble + + +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int + +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 + + RcFloat + -> case vr of + VirtualRegF{} -> 1 + VirtualRegD{} -> 2 + _other -> 0 + + RcDouble + -> case vr of + VirtualRegF{} -> 1 + VirtualRegD{} -> 1 + _other -> 0 + + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int + +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 1 + | otherwise -> 0 + + RealRegPair{} -> 0 + + RcFloat + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 0 + | otherwise -> 1 + + RealRegPair{} -> 2 + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> 0 + | otherwise -> 1 + + RealRegPair{} -> 1 + + +-- | All the allocatable registers in the machine, +-- including register pairs. +allRealRegs :: [RealReg] +allRealRegs + = [ (RealRegSingle i) | i <- [0..63] ] + ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] + + +-- | Get the regno for this sort of reg +gReg, lReg, iReg, oReg, fReg :: Int -> RegNo + +gReg x = x -- global regs +oReg x = (8 + x) -- output regs +lReg x = (16 + x) -- local regs +iReg x = (24 + x) -- input regs +fReg x = (32 + x) -- float regs + + +-- | Some specific regs used by the code generator. +g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg + +f6 = RegReal (RealRegSingle (fReg 6)) +f8 = RegReal (RealRegSingle (fReg 8)) +f22 = RegReal (RealRegSingle (fReg 22)) +f26 = RegReal (RealRegSingle (fReg 26)) +f27 = RegReal (RealRegSingle (fReg 27)) + +-- g0 is always zero, and writes to it vanish. +g0 = RegReal (RealRegSingle (gReg 0)) +g1 = RegReal (RealRegSingle (gReg 1)) +g2 = RegReal (RealRegSingle (gReg 2)) + +-- FP, SP, int and float return (from C) regs. +fp = RegReal (RealRegSingle (iReg 6)) +sp = RegReal (RealRegSingle (oReg 6)) +o0 = RegReal (RealRegSingle (oReg 0)) +o1 = RegReal (RealRegSingle (oReg 1)) +f0 = RegReal (RealRegSingle (fReg 0)) +f1 = RegReal (RealRegSingle (fReg 1)) + +-- | Produce the second-half-of-a-double register given the first half. +{- +fPair :: Reg -> Maybe Reg +fPair (RealReg n) + | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) + +fPair (VirtualRegD u) + = Just (VirtualRegHi u) + +fPair reg + = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) + Nothing +-} + + +-- | All the regs that the register allocator can allocate to, +-- with the fixed use regs removed. +-- +allocatableRegs :: [RealReg] +allocatableRegs + = let isFree rr + = case rr of + RealRegSingle r -> freeReg r + RealRegPair r1 r2 -> freeReg r1 && freeReg r2 + in filter isFree allRealRegs + + +-- | The registers to place arguments for function calls, +-- for some number of arguments. +-- +argRegs :: RegNo -> [Reg] +argRegs r + = case r of + 0 -> [] + 1 -> map (RegReal . RealRegSingle . oReg) [0] + 2 -> map (RegReal . RealRegSingle . oReg) [0,1] + 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] + 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] + 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] + 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] + _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" + + +-- | All the regs that could possibly be returned by argRegs +-- +allArgRegs :: [Reg] +allArgRegs + = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] + + +-- These are the regs that we cannot assume stay alive over a C call. +-- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 +-- +callClobberedRegs :: [Reg] +callClobberedRegs + = map (RegReal . RealRegSingle) + ( oReg 7 : + [oReg i | i <- [0..5]] ++ + [gReg i | i <- [1..7]] ++ + [fReg i | i <- [0..31]] ) + + + +-- | Make a virtual reg with this format. +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) + = VirtualRegI u + + | otherwise + = case format of + FF32 -> VirtualRegF u + FF64 -> VirtualRegD u + _ -> panic "mkVReg" + + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + _other -> text "green" diff --git a/GHC/CmmToAsm/SPARC/ShortcutJump.hs b/GHC/CmmToAsm/SPARC/ShortcutJump.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/ShortcutJump.hs @@ -0,0 +1,74 @@ +module GHC.CmmToAsm.SPARC.ShortcutJump ( + JumpDest(..), getJumpDestBlockId, + canShortcut, + shortcutJump, + shortcutStatics, + shortBlockId +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.Instr +import GHC.CmmToAsm.SPARC.Imm + +import GHC.Cmm.CLabel +import GHC.Cmm.BlockId +import GHC.Cmm + +import GHC.Utils.Panic +import GHC.Utils.Outputable + +data JumpDest + = DestBlockId BlockId + | DestImm Imm + +-- Debug Instance +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "blk:" <> ppr bid + ppr (DestImm _bid) = text "imm:?" + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing + + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other + + + +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics fn (CmmStaticsRaw lbl statics) + = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) +-- slightly dodgy, we're ignoring the second label, but this +-- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + + +shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel +shortBlockId fn blockid = + case fn blockid of + Nothing -> blockLbl blockid + Just (DestBlockId blockid') -> shortBlockId fn blockid' + Just (DestImm (ImmCLbl lbl)) -> lbl + _other -> panic "shortBlockId" diff --git a/GHC/CmmToAsm/SPARC/Stack.hs b/GHC/CmmToAsm/SPARC/Stack.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/SPARC/Stack.hs @@ -0,0 +1,59 @@ +module GHC.CmmToAsm.SPARC.Stack ( + spRel, + fpRel, + spillSlotToOffset, + maxSpillSlots +) + +where + +import GHC.Prelude + +import GHC.CmmToAsm.SPARC.AddrMode +import GHC.CmmToAsm.SPARC.Regs +import GHC.CmmToAsm.SPARC.Base +import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.Config + +import GHC.Utils.Outputable + +-- | Get an AddrMode relative to the address in sp. +-- This gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. +-- +spRel :: Int -- ^ stack offset in words, positive or negative + -> AddrMode + +spRel n = AddrRegImm sp (ImmInt (n * wordLength)) + + +-- | Get an address relative to the frame pointer. +-- This doesn't work work for offsets greater than 13 bits; we just hope for the best +-- +fpRel :: Int -> AddrMode +fpRel n + = AddrRegImm fp (ImmInt (n * wordLength)) + + +-- | Convert a spill slot number to a *byte* offset, with no sign. +-- +spillSlotToOffset :: NCGConfig -> Int -> Int +spillSlotToOffset config slot + | slot >= 0 && slot < maxSpillSlots config + = 64 + spillSlotSize * slot + + | otherwise + = pprPanic "spillSlotToOffset:" + ( text "invalid spill location: " <> int slot + $$ text "maxSpillSlots: " <> int (maxSpillSlots config)) + + +-- | The maximum number of spill slots available on the C stack. +-- If we use up all of the slots, then we're screwed. +-- +-- Why do we reserve 64 bytes, instead of using the whole thing?? +-- -- BL 2009/02/15 +-- +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config + = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize) - 1 diff --git a/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/CodeGen.hs @@ -0,0 +1,3935 @@ +{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} + +#if __GLASGOW_HASKELL__ <= 808 +-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it +-- The default iteration limit is a bit too low for the definitions +-- in this module. +{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} +#endif + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- + +-- This is a big module, but, if you pay attention to +-- (a) the sectioning, and (b) the type signatures, the +-- structure should not be too overwhelming. + +module GHC.CmmToAsm.X86.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + extractUnwindPoints, + invertCondBranches, + InstrBlock +) + +where + +#include "HsVersions.h" + +-- NCG stuff: +import GHC.Prelude + +import GHC.CmmToAsm.X86.Instr +import GHC.CmmToAsm.X86.Cond +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.X86.Ppr +import GHC.CmmToAsm.X86.RegInfo + +import GHC.Platform.Regs +import GHC.CmmToAsm.CPrim +import GHC.Cmm.DebugBlock + ( DebugBlock(..), UnwindPoint(..), UnwindTable + , UnwindExpr(UwReg), toUnwindExpr + ) +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat + , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat + , getPicBaseMaybeNat, getDebugBlock, getFileId + , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform + ) +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.Platform.Reg +import GHC.Platform + +-- Our intermediate code: +import GHC.Types.Basic +import GHC.Cmm.BlockId +import GHC.Unit ( primUnitId ) +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.CLabel +import GHC.Core ( Tickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + +-- The rest: +import GHC.Types.ForeignCall ( CCallConv(..) ) +import GHC.Data.OrdList +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Types.Unique.Supply ( getUniqueM ) + +import Control.Monad +import Data.Bits +import Data.Foldable (fold) +import Data.Int +import Data.Maybe +import Data.Word + +import qualified Data.Map as M + +is32BitPlatform :: NatM Bool +is32BitPlatform = do + platform <- getPlatform + return $ target32Bit platform + +sse2Enabled :: NatM Bool +sse2Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSE2) + +sse4_2Enabled :: NatM Bool +sse4_2Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSE42) + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr] + +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + platform <- getPlatform + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + os = platformOS platform + + case picBaseMb of + Just picBase -> initializePicBase_x86 ArchX86 os picBase tops + Nothing -> return tops + +cmmTopCodeGen (CmmData sec dat) = do + return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic + +{- Note [Verifying basic blocks] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + We want to guarantee a few things about the results + of instruction selection. + + Namely that each basic blocks consists of: + * A (potentially empty) sequence of straight line instructions + followed by + * A (potentially empty) sequence of jump like instructions. + + We can verify this by going through the instructions and + making sure that any non-jumpish instruction can't appear + after a jumpish instruction. + + There are gotchas however: + * CALLs are strictly speaking control flow but here we care + not about them. Hence we treat them as regular instructions. + + It's safe for them to appear inside a basic block + as (ignoring side effects inside the call) they will result in + straight line code. + + * NEWBLOCK marks the start of a new basic block so can + be followed by any instructions. +-} + +-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally. +verifyBasicBlock :: Platform -> [Instr] -> () +verifyBasicBlock platform instrs + | debugIsOn = go False instrs + | otherwise = () + where + go _ [] = () + go atEnd (i:instr) + = case i of + -- Start a new basic block + NEWBLOCK {} -> go False instr + -- Calls are not viable block terminators + CALL {} | atEnd -> faultyBlockWith i + | not atEnd -> go atEnd instr + -- All instructions ok, check if we reached the end and continue. + _ | not atEnd -> go (isJumpishInstr i) instr + -- Only jumps allowed at the end of basic blocks. + | otherwise -> if isJumpishInstr i + then go True instr + else faultyBlockWith i + faultyBlockWith i + = pprPanic "Non control flow instructions after end of basic block." + (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs)) + +basicBlockCodeGen + :: CmmBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl (Alignment, RawCmmStatics) Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span name) + -> do fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + return $ unitOL $ LOCATION fileId line col name + _ -> return nilOL + (mid_instrs,mid_bid) <- stmtsToInstrs id stmts + (!tail_instrs,_) <- stmtToInstrs mid_bid tail + let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs + platform <- getPlatform + return $! verifyBasicBlock platform (fromOL instrs) + instrs' <- fold <$> traverse addSpUnwindings instrs + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs' + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + +-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes +-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" +-- for details. +addSpUnwindings :: Instr -> NatM (OrdList Instr) +addSpUnwindings instr@(DELTA d) = do + config <- getConfig + if ncgDebugLevel config >= 1 + then do lbl <- mkAsmTempLabel <$> getUniqueM + let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d) + return $ toOL [ instr, UNWIND lbl unwind ] + else return (unitOL instr) +addSpUnwindings instr = return $ unitOL instr + +{- Note [Keeping track of the current block] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When generating instructions for Cmm we sometimes require +the current block for things like retry loops. + +We also sometimes change the current block, if a MachOP +results in branching control flow. + +Issues arise if we have two statements in the same block, +which both depend on the current block id *and* change the +basic block after them. This happens for atomic primops +in the X86 backend where we want to update the CFG data structure +when introducing new basic blocks. + +For example in #17334 we got this Cmm code: + + c3Bf: // global + (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18); + (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0); + _s3sT::I64 = _s3sV::I64; + goto c3B1; + +This resulted in two new basic blocks being inserted: + + c3Bf: + movl $18,%vI_n3Bo + movq 88(%vI_s3sQ),%rax + jmp _n3Bp + n3Bp: + ... + cmpxchgq %vI_n3Bq,88(%vI_s3sQ) + jne _n3Bp + ... + jmp _n3Bs + n3Bs: + ... + cmpxchgq %vI_n3Bt,88(%vI_s3sQ) + jne _n3Bs + ... + jmp _c3B1 + ... + +Based on the Cmm we called stmtToInstrs we translated both atomic operations under +the assumption they would be placed into their Cmm basic block `c3Bf`. +However for the retry loop we introduce new labels, so this is not the case +for the second statement. +This resulted in a desync between the explicit control flow graph +we construct as a separate data type and the actual control flow graph in the code. + +Instead we now return the new basic block if a statement causes a change +in the current block and use the block for all following statements. + +For this reason genCCall is also split into two parts. One for calls which +*won't* change the basic blocks in which successive instructions will be +placed (since they only evaluate CmmExpr, which can only contain MachOps, which +cannot introduce basic blocks in their lowerings). A different one for calls +which *are* known to change the basic block. + +-} + +-- See Note [Keeping track of the current block] for why +-- we pass the BlockId. +stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in. + -> [CmmNode O O] -- ^ Cmm Statement + -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction +stmtsToInstrs bid stmts = + go bid stmts nilOL + where + go bid [] instrs = return (instrs,bid) + go bid (s:stmts) instrs = do + (instrs',bid') <- stmtToInstrs bid s + -- If the statement introduced a new block, we use that one + let !newBid = fromMaybe bid bid' + go newBid stmts (instrs `appOL` instrs') + +-- | `bid` refers to the current block and is used to update the CFG +-- if new blocks are inserted in the control flow. +-- See Note [Keeping track of the current block] for more details. +stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in. + -> CmmNode e x + -> NatM (InstrBlock, Maybe BlockId) + -- ^ Instructions, and bid of new block if successive + -- statements are placed in a different basic block. +stmtToInstrs bid stmt = do + is32Bit <- is32BitPlatform + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genCCall is32Bit target result_regs args bid + + _ -> (,Nothing) <$> case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + + CmmUnwind regs -> do + let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable + to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr) + case foldMap to_unwind_entry regs of + tbl | M.null tbl -> return nilOL + | otherwise -> do + lbl <- mkAsmTempLabel <$> getUniqueM + return $ unitOL $ UNWIND lbl tbl + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | is32Bit && isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType platform reg + format = cmmTypeFormat ty + + CmmStore addr src + | isFloatType ty -> assignMem_FltCode format addr src + | is32Bit && isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> return $ genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _ -> genCondBranch bid true false arg + CmmSwitch arg ids -> genSwitch arg ids + CmmCall { cml_target = arg + , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) + _ -> + panic "stmtToInstrs: statement should have been cps'd away" + + +jumpRegs :: Platform -> [GlobalReg] -> [Reg] +jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Condition codes passed up the tree. +-- +data CondCode + = CondCode Bool Cond InstrBlock + + +-- | a.k.a "Register64" +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. +-- +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified +-- +data ChildCode64 + = ChildCode64 + InstrBlock + Reg + + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + + +swizzleRegisterRep :: Register -> Format -> Register +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code +swizzleRegisterRep (Any _ codefn) format = Any format codefn + + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated + let fmt = cmmTypeFormat pk in + RegVirtual (mkVirtualReg u fmt) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of + Just reg -> RegReal $ reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... + + +-- | Memory addressing modes passed up the tree. +data Amode + = Amode AddrMode InstrBlock + +{- +Now, given a tree (the argument to a CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + + +-- | Check whether an integer will fit in 32 bits. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. +-- +is32BitInteger :: Integer -> Bool +is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 + where i64 = fromIntegral i :: Int64 + + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = blockLbl blockid + + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr +mangleIndexTree platform reg off + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType platform reg) + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + + +assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_I64Code addrTree valueTree = do + Amode addr addr_code <- getAmode addrTree + ChildCode64 vcode rlo <- iselExpr64 valueTree + let + rhi = getHiVRegFromLo rlo + + -- Little-endian store + mov_lo = MOV II32 (OpReg rlo) (OpAddr addr) + mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + + +assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree + let + r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi) + return ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(i386): invalid lvalue" + + +iselExpr64 :: CmmExpr -> NatM ChildCode64 +iselExpr64 (CmmLit (CmmInt i _)) = do + (rlo,rhi) <- getNewRegPairNat II32 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + code = toOL [ + MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) + ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do + Amode addr addr_code <- getAmode addrTree + (rlo,rhi) <- getNewRegPairNat II32 + let + mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) + mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) + return ( + ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo + ) + +iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty + = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) + +-- we handle addition, but rather badly +iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + (rlo,rhi) <- getNewRegPairNat II32 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + r1hi = getHiVRegFromLo r1lo + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpReg r2hi) (OpReg rhi) ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + SUB II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SBB II32 (OpReg r2hi) (OpReg rhi) ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do + fn <- getAnyReg expr + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + code = fn r_dst_lo + return ( + ChildCode64 (code `snocOL` + MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi)) + r_dst_lo + ) + +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do + fn <- getAnyReg expr + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + code = fn r_dst_lo + return ( + ChildCode64 (code `snocOL` + MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL` + CLTD II32 `snocOL` + MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL` + MOV II32 (OpReg edx) (OpReg r_dst_hi)) + r_dst_lo + ) + +iselExpr64 expr + = pprPanic "iselExpr64(i386)" (ppr expr) + + +-------------------------------------------------------------------------------- +getRegister :: CmmExpr -> NatM Register +getRegister e = do platform <- getPlatform + is32Bit <- is32BitPlatform + getRegister' platform is32Bit e + +getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register + +getRegister' platform is32Bit (CmmReg reg) + = case reg of + CmmGlobal PicBaseReg + | is32Bit -> + -- on x86_64, we have %rip for PicBaseReg, but it's not + -- a full-featured register, it can only be used for + -- rip-relative addressing. + do reg' <- getPicBaseNat (archWordFormat is32Bit) + return (Fixed (archWordFormat is32Bit) reg' nilOL) + _ -> + do + let + fmt = cmmTypeFormat (cmmRegType platform reg) + format = fmt + -- + platform <- ncgPlatform <$> getConfig + return (Fixed format + (getRegisterReg platform reg) + nilOL) + + +getRegister' platform is32Bit (CmmRegOff r n) + = getRegister' platform is32Bit $ mangleIndexTree platform r n + +getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e]) + = addAlignmentCheck align <$> getRegister' platform is32Bit e + +-- for 32-bit architectures, support some 64 -> 32 bit conversions: +-- TO_W_(x), TO_W_(x >> 32) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ _ (CmmLit lit@(CmmFloat f w)) = + float_const_sse2 where + float_const_sse2 + | f == 0.0 = do + let + format = floatFormat w + code dst = unitOL (XOR format (OpReg dst) (OpReg dst)) + -- I don't know why there are xorpd, xorps, and pxor instructions. + -- They all appear to do the same thing --SDM + return (Any format code) + + | otherwise = do + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + loadFloatAmode w addr code + +-- catch simple cases of zero- or sign-extended load +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II32 code) + +-- catch simple cases of zero- or sign-extended load +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II32) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), + CmmLit displacement]) + | not is32Bit = do + return $ Any II64 (\dst -> unitOL $ + LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) + +getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps + case mop of + MO_F_Neg w -> sse2NegCode w x + + + MO_S_Neg w -> triv_ucode NEGI (intFormat w) + MO_Not w -> triv_ucode NOT (intFormat w) + + -- Nop conversions + MO_UU_Conv W32 W8 -> toI8Reg W32 x + MO_SS_Conv W32 W8 -> toI8Reg W32 x + MO_XX_Conv W32 W8 -> toI8Reg W32 x + MO_UU_Conv W16 W8 -> toI8Reg W16 x + MO_SS_Conv W16 W8 -> toI8Reg W16 x + MO_XX_Conv W16 W8 -> toI8Reg W16 x + MO_UU_Conv W32 W16 -> toI16Reg W32 x + MO_SS_Conv W32 W16 -> toI16Reg W32 x + MO_XX_Conv W32 W16 -> toI16Reg W32 x + + MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_XX_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + + MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + + -- widenings + MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x + MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x + MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x + + MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x + MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x + + -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we + -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register + -- has 8-bit version). So for 32-bit code, we'll just zero-extend. + MO_XX_Conv W8 W32 + | is32Bit -> integerExtend W8 W32 MOVZxL x + | otherwise -> integerExtend W8 W32 MOV x + MO_XX_Conv W8 W16 + | is32Bit -> integerExtend W8 W16 MOVZxL x + | otherwise -> integerExtend W8 W16 MOV x + MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x + + MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x + MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x + MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x + MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x + MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x + MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x + -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl. + -- However, we don't want the register allocator to throw it + -- away as an unnecessary reg-to-reg move, so we keep it in + -- the form of a movzl and print it as a movl later. + -- This doesn't apply to MO_XX_Conv since in this case we don't care about + -- the upper bits. So we can just use MOV. + MO_XX_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOV x + MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x + MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x + + MO_FF_Conv W32 W64 -> coerceFP2FP W64 x + + + MO_FF_Conv W64 W32 -> coerceFP2FP W32 x + + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x + + MO_V_Insert {} -> needLlvm + MO_V_Extract {} -> needLlvm + MO_V_Add {} -> needLlvm + MO_V_Sub {} -> needLlvm + MO_V_Mul {} -> needLlvm + MO_VS_Quot {} -> needLlvm + MO_VS_Rem {} -> needLlvm + MO_VS_Neg {} -> needLlvm + MO_VU_Quot {} -> needLlvm + MO_VU_Rem {} -> needLlvm + MO_VF_Insert {} -> needLlvm + MO_VF_Extract {} -> needLlvm + MO_VF_Add {} -> needLlvm + MO_VF_Sub {} -> needLlvm + MO_VF_Mul {} -> needLlvm + MO_VF_Quot {} -> needLlvm + MO_VF_Neg {} -> needLlvm + + _other -> pprPanic "getRegister" (pprMachOp mop) + where + triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register + triv_ucode instr format = trivialUCode format (instr format) x + + -- signed or unsigned extension. + integerExtend :: Width -> Width + -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> NatM Register + integerExtend from to instr expr = do + (reg,e_code) <- if from == W8 then getByteReg expr + else getSomeReg expr + let + code dst = + e_code `snocOL` + instr (intFormat from) (OpReg reg) (OpReg dst) + return (Any (intFormat to) code) + + toI8Reg :: Width -> CmmExpr -> NatM Register + toI8Reg new_rep expr + = do codefn <- getAnyReg expr + return (Any (intFormat new_rep) codefn) + -- HACK: use getAnyReg to get a byte-addressable register. + -- If the source was a Fixed register, this will add the + -- mov instruction to put it into the desired destination. + -- We're assuming that the destination won't be a fixed + -- non-byte-addressable register; it won't be, because all + -- fixed registers are word-sized. + + toI16Reg = toI8Reg -- for now + + conversionNop :: Format -> CmmExpr -> NatM Register + conversionNop new_format expr + = do e_code <- getRegister' platform is32Bit expr + return (swizzleRegisterRep e_code new_format) + + +getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps + case mop of + MO_F_Eq _ -> condFltReg is32Bit EQQ x y + MO_F_Ne _ -> condFltReg is32Bit NE x y + MO_F_Gt _ -> condFltReg is32Bit GTT x y + MO_F_Ge _ -> condFltReg is32Bit GE x y + -- Invert comparison condition and swap operands + -- See Note [SSE Parity Checks] + MO_F_Lt _ -> condFltReg is32Bit GTT y x + MO_F_Le _ -> condFltReg is32Bit GE y x + + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt _ -> condIntReg GU x y + MO_U_Ge _ -> condIntReg GEU x y + MO_U_Lt _ -> condIntReg LU x y + MO_U_Le _ -> condIntReg LEU x y + + MO_F_Add w -> trivialFCode_sse2 w ADD x y + + MO_F_Sub w -> trivialFCode_sse2 w SUB x y + + MO_F_Quot w -> trivialFCode_sse2 w FDIV x y + + MO_F_Mul w -> trivialFCode_sse2 w MUL x y + + + MO_Add rep -> add_code rep x y + MO_Sub rep -> sub_code rep x y + + MO_S_Quot rep -> div_code rep True True x y + MO_S_Rem rep -> div_code rep True False x y + MO_U_Quot rep -> div_code rep False True x y + MO_U_Rem rep -> div_code rep False False x y + + MO_S_MulMayOflo rep -> imulMayOflo rep x y + + MO_Mul W8 -> imulW8 x y + MO_Mul rep -> triv_op rep IMUL + MO_And rep -> triv_op rep AND + MO_Or rep -> triv_op rep OR + MO_Xor rep -> triv_op rep XOR + + {- Shift ops on x86s have constraints on their source, it + either has to be Imm, CL or 1 + => trivialCode is not restrictive enough (sigh.) + -} + MO_Shl rep -> shift_code rep SHL x y {-False-} + MO_U_Shr rep -> shift_code rep SHR x y {-False-} + MO_S_Shr rep -> shift_code rep SAR x y {-False-} + + MO_V_Insert {} -> needLlvm + MO_V_Extract {} -> needLlvm + MO_V_Add {} -> needLlvm + MO_V_Sub {} -> needLlvm + MO_V_Mul {} -> needLlvm + MO_VS_Quot {} -> needLlvm + MO_VS_Rem {} -> needLlvm + MO_VS_Neg {} -> needLlvm + MO_VF_Insert {} -> needLlvm + MO_VF_Extract {} -> needLlvm + MO_VF_Add {} -> needLlvm + MO_VF_Sub {} -> needLlvm + MO_VF_Mul {} -> needLlvm + MO_VF_Quot {} -> needLlvm + MO_VF_Neg {} -> needLlvm + + _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) + where + -------------------- + triv_op width instr = trivialCode width op (Just op) x y + where op = instr (intFormat width) + + -- Special case for IMUL for bytes, since the result of IMULB will be in + -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider + -- values. + imulW8 :: CmmExpr -> CmmExpr -> NatM Register + imulW8 arg_a arg_b = do + (a_reg, a_code) <- getNonClobberedReg arg_a + b_code <- getAnyReg arg_b + + let code = a_code `appOL` b_code eax `appOL` + toOL [ IMUL2 format (OpReg a_reg) ] + format = intFormat W8 + + return (Fixed format eax code) + + + imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + imulMayOflo rep a b = do + (a_reg, a_code) <- getNonClobberedReg a + b_code <- getAnyReg b + let + shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" + + format = intFormat rep + code = a_code `appOL` b_code eax `appOL` + toOL [ + IMUL2 format (OpReg a_reg), -- result in %edx:%eax + SAR format (OpImm (ImmInt shift_amt)) (OpReg eax), + -- sign extend lower part + SUB format (OpReg edx) (OpReg eax) + -- compare against upper + -- eax==0 if high part == sign extended low part + ] + return (Fixed format eax code) + + -------------------- + shift_code :: Width + -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + + {- Case1: shift length as immediate -} + shift_code width instr x (CmmLit lit) = do + x_code <- getAnyReg x + let + format = intFormat width + code dst + = x_code dst `snocOL` + instr format (OpImm (litToImm lit)) (OpReg dst) + return (Any format code) + + {- Case2: shift length is complex (non-immediate) + * y must go in %ecx. + * we cannot do y first *and* put its result in %ecx, because + %ecx might be clobbered by x. + * if we do y second, then x cannot be + in a clobbered reg. Also, we cannot clobber x's reg + with the instruction itself. + * so we can either: + - do y first, put its result in a fresh tmp, then copy it to %ecx later + - do y second and put its result into %ecx. x gets placed in a fresh + tmp. This is likely to be better, because the reg alloc can + eliminate this reg->reg move here (it won't eliminate the other one, + because the move is into the fixed %ecx). + * in the case of C calls the use of ecx here can interfere with arguments. + We avoid this with the hack described in Note [Evaluate C-call + arguments before placing in destination registers] + -} + shift_code width instr x y{-amount-} = do + x_code <- getAnyReg x + let format = intFormat width + tmp <- getNewRegNat format + y_code <- getAnyReg y + let + code = x_code tmp `appOL` + y_code ecx `snocOL` + instr format (OpReg ecx) (OpReg tmp) + return (Fixed format tmp code) + + -------------------- + add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + add_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger y = add_int rep x y + add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y + where format = intFormat rep + -- TODO: There are other interesting patterns we want to replace + -- with a LEA, e.g. `(x + offset) + (y << shift)`. + + -------------------- + sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + sub_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger (-y) = add_int rep x (-y) + sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y + + -- our three-operand add instruction: + add_int width x y = do + (x_reg, x_code) <- getSomeReg x + let + format = intFormat width + imm = ImmInt (fromInteger y) + code dst + = x_code `snocOL` + LEA format + (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) + (OpReg dst) + -- + return (Any format code) + + ---------------------- + + -- See Note [DIV/IDIV for bytes] + div_code W8 signed quotient x y = do + let widen | signed = MO_SS_Conv W8 W16 + | otherwise = MO_UU_Conv W8 W16 + div_code + W16 + signed + quotient + (CmmMachOp widen [x]) + (CmmMachOp widen [y]) + + div_code width signed quotient x y = do + (y_op, y_code) <- getRegOrMem y -- cannot be clobbered + x_code <- getAnyReg x + let + format = intFormat width + widen | signed = CLTD format + | otherwise = XOR format (OpReg edx) (OpReg edx) + + instr | signed = IDIV + | otherwise = DIV + + code = y_code `appOL` + x_code eax `appOL` + toOL [widen, instr format y_op] + + result | quotient = eax + | otherwise = edx + + return (Fixed format result code) + + +getRegister' _ _ (CmmLoad mem pk) + | isFloatType pk + = do + Amode addr mem_code <- getAmode mem + loadFloatAmode (typeWidth pk) addr mem_code + +getRegister' _ is32Bit (CmmLoad mem pk) + | is32Bit && not (isWord64 pk) + = do + code <- intLoadCode instr mem + return (Any format code) + where + width = typeWidth pk + format = intFormat width + instr = case width of + W8 -> MOVZxL II8 + _other -> MOV format + -- We always zero-extend 8-bit loads, if we + -- can't think of anything better. This is because + -- we can't guarantee access to an 8-bit variant of every register + -- (esi and edi don't have 8-bit variants), so to make things + -- simpler we do our 8-bit arithmetic with full 32-bit registers. + +-- Simpler memory load code on x86_64 +getRegister' _ is32Bit (CmmLoad mem pk) + | not is32Bit + = do + code <- intLoadCode (MOV format) mem + return (Any format code) + where format = intFormat $ typeWidth pk + +getRegister' _ is32Bit (CmmLit (CmmInt 0 width)) + = let + format = intFormat width + + -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits + format1 = if is32Bit then format + else case format of + II64 -> II32 + _ -> format + code dst + = unitOL (XOR format1 (OpReg dst) (OpReg dst)) + in + return (Any format code) + + -- optimisation for loading small literals on x86_64: take advantage + -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit + -- instruction forms are shorter. +getRegister' platform is32Bit (CmmLit lit) + | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit) + = let + imm = litToImm lit + code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) + in + return (Any II64 code) + where + isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff + isBigLit _ = False + -- note1: not the same as (not.is32BitLit), because that checks for + -- signed literals that fit in 32 bits, but we want unsigned + -- literals here. + -- note2: all labels are small, because we're assuming the + -- small memory model (see gcc docs, -mcmodel=small). + +getRegister' platform _ (CmmLit lit) + = do let format = cmmTypeFormat (cmmLitType platform lit) + imm = litToImm lit + code dst = unitOL (MOV format (OpImm imm) (OpReg dst)) + return (Any format code) + +getRegister' _ _ other + | isVecExpr other = needLlvm + | otherwise = pprPanic "getRegister(x86)" (ppr other) + + +intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr + -> NatM (Reg -> InstrBlock) +intLoadCode instr mem = do + Amode src mem_code <- getAmode mem + return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst)) + +-- Compute an expression into *any* register, adding the appropriate +-- move instruction if necessary. +getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock) +getAnyReg expr = do + r <- getRegister expr + anyReg r + +anyReg :: Register -> NatM (Reg -> InstrBlock) +anyReg (Any _ code) = return code +anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst) + +-- A bit like getSomeReg, but we want a reg that can be byte-addressed. +-- Fixed registers might not be byte-addressable, so we make sure we've +-- got a temporary, inserting an extra reg copy if necessary. +getByteReg :: CmmExpr -> NatM (Reg, InstrBlock) +getByteReg expr = do + is32Bit <- is32BitPlatform + if is32Bit + then do r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + | isVirtualReg reg -> return (reg,code) + | otherwise -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + -- ToDo: could optimise slightly by checking for + -- byte-addressable real registers, but that will + -- happen very rarely if at all. + else getSomeReg expr -- all regs are byte-addressable on x86_64 + +-- Another variant: this time we want the result in a register that cannot +-- be modified by code to evaluate an arbitrary expression. +getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) +getNonClobberedReg expr = do + r <- getRegister expr + platform <- ncgPlatform <$> getConfig + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + -- only certain regs can be clobbered + | reg `elem` instrClobberedRegs platform + -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + | otherwise -> + return (reg, code) + +reg2reg :: Format -> Reg -> Reg -> Instr +reg2reg format src dst = MOV format (OpReg src) (OpReg dst) + + +-------------------------------------------------------------------------------- + +-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'. +-- +-- An 'Amode' is a datatype representing a valid address form for the target +-- (e.g. "Base + Index + disp" or immediate) and the code to compute it. +getAmode :: CmmExpr -> NatM Amode +getAmode e = do + platform <- getPlatform + let is32Bit = target32Bit platform + + case e of + CmmRegOff r n + -> getAmode $ mangleIndexTree platform r n + + CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement] + | not is32Bit + -> return $ Amode (ripRel (litToImm displacement)) nilOL + + -- This is all just ridiculous, since it carefully undoes + -- what mangleIndexTree has just done. + CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)] + | is32BitLit is32Bit lit + -- ASSERT(rep == II32)??? + -> do + (x_reg, x_code) <- getSomeReg x + let off = ImmInt (-(fromInteger i)) + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + + CmmMachOp (MO_Add _rep) [x, CmmLit lit] + | is32BitLit is32Bit lit + -- ASSERT(rep == II32)??? + -> do + (x_reg, x_code) <- getSomeReg x + let off = litToImm lit + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + + -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be + -- recognised by the next rule. + CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)] + -> getAmode (CmmMachOp (MO_Add rep) [b,a]) + + -- Matches: (x + offset) + (y << shift) + CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset) + + CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + -> x86_complex_amode x y shift 0 + + CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + && is32BitInteger offset + -> x86_complex_amode x y shift offset + + CmmMachOp (MO_Add _) [x,y] + | not (isLit y) -- we already handle valid literals above. + -> x86_complex_amode x y 0 0 + + CmmLit lit + | is32BitLit is32Bit lit + -> return (Amode (ImmAddr (litToImm lit) 0) nilOL) + + -- Literal with offsets too big (> 32 bits) fails during the linking phase + -- (#15570). We already handled valid literals above so we don't have to + -- test anything here. + CmmLit (CmmLabelOff l off) + -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l) + , CmmLit (CmmInt (fromIntegral off) W64) + ]) + CmmLit (CmmLabelDiffOff l1 l2 off w) + -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w) + , CmmLit (CmmInt (fromIntegral off) W64) + ]) + + -- in case we can't do something better, we just compute the expression + -- and put the result in a register + _ -> do + (reg,code) <- getSomeReg e + return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) + + + +-- | Like 'getAmode', but on 32-bit use simple register addressing +-- (i.e. no index register). This stops us from running out of +-- registers on x86 when using instructions such as cmpxchg, which can +-- use up to three virtual registers and one fixed register. +getSimpleAmode :: Bool -> CmmExpr -> NatM Amode +getSimpleAmode is32Bit addr + | is32Bit = do + addr_code <- getAnyReg addr + config <- getConfig + addr_r <- getNewRegNat (intFormat (ncgWordWidth config)) + let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) + return $! Amode amode (addr_code addr_r) + | otherwise = getAmode addr + +x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode +x86_complex_amode base index shift offset + = do (x_reg, x_code) <- getNonClobberedReg base + -- x must be in a temp, because it has to stay live over y_code + -- we could compare x_reg and y_reg and do something better here... + (y_reg, y_code) <- getSomeReg index + let + code = x_code `appOL` y_code + base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; + n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" + return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) + code) + + + + +-- ----------------------------------------------------------------------------- +-- getOperand: sometimes any operand will do. + +-- getNonClobberedOperand: the value of the operand will remain valid across +-- the computation of an arbitrary expression, unless the expression +-- is computed directly into a register which the operand refers to +-- (see trivialCode where this function is used for an example). + +getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand (CmmLit lit) = do + if isSuitableFloatingPointLit lit + then do + let CmmFloat _ w = lit + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + return (OpAddr addr, code) + else do + + is32Bit <- is32BitPlatform + platform <- getPlatform + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit)) + then return (OpImm (litToImm lit), nilOL) + else getNonClobberedOperand_generic (CmmLit lit) + +getNonClobberedOperand (CmmLoad mem pk) = do + is32Bit <- is32BitPlatform + -- this logic could be simplified + -- TODO FIXME + if (if is32Bit then not (isWord64 pk) else True) + -- if 32bit and pk is at float/double/simd value + -- or if 64bit + -- this could use some eyeballs or i'll need to stare at it more later + then do + platform <- ncgPlatform <$> getConfig + Amode src mem_code <- getAmode mem + (src',save_code) <- + if (amodeCouldBeClobbered platform src) + then do + tmp <- getNewRegNat (archWordFormat is32Bit) + return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), + unitOL (LEA (archWordFormat is32Bit) + (OpAddr src) + (OpReg tmp))) + else + return (src, nilOL) + return (OpAddr src', mem_code `appOL` save_code) + else do + -- if its a word or gcptr on 32bit? + getNonClobberedOperand_generic (CmmLoad mem pk) + +getNonClobberedOperand e = getNonClobberedOperand_generic e + +getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand_generic e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +amodeCouldBeClobbered :: Platform -> AddrMode -> Bool +amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) + +regClobbered :: Platform -> Reg -> Bool +regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr +regClobbered _ _ = False + +-- getOperand: the operand is not required to remain valid across the +-- computation of an arbitrary expression. +getOperand :: CmmExpr -> NatM (Operand, InstrBlock) + +getOperand (CmmLit lit) = do + use_sse2 <- sse2Enabled + if (use_sse2 && isSuitableFloatingPointLit lit) + then do + let CmmFloat _ w = lit + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + return (OpAddr addr, code) + else do + + is32Bit <- is32BitPlatform + platform <- getPlatform + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit)) + then return (OpImm (litToImm lit), nilOL) + else getOperand_generic (CmmLit lit) + +getOperand (CmmLoad mem pk) = do + is32Bit <- is32BitPlatform + use_sse2 <- sse2Enabled + if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else + getOperand_generic (CmmLoad mem pk) + +getOperand e = getOperand_generic e + +getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getOperand_generic e = do + (reg, code) <- getSomeReg e + return (OpReg reg, code) + +isOperand :: Bool -> CmmExpr -> Bool +isOperand _ (CmmLoad _ _) = True +isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit + || isSuitableFloatingPointLit lit +isOperand _ _ = False + +-- | Given a 'Register', produce a new 'Register' with an instruction block +-- which will check the value for alignment. Used for @-falignment-sanitisation@. +addAlignmentCheck :: Int -> Register -> Register +addAlignmentCheck align reg = + case reg of + Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg) + Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt reg) + where + check :: Format -> Reg -> InstrBlock + check fmt reg = + ASSERT(not $ isFloatFormat fmt) + toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg) + , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel + ] + +memConstant :: Alignment -> CmmLit -> NatM Amode +memConstant align lit = do + lbl <- getNewLabelNat + let rosection = Section ReadOnlyData lbl + config <- getConfig + platform <- getPlatform + (addr, addr_code) <- if target32Bit platform + then do dynRef <- cmmMakeDynamicReference + config + DataReference + lbl + Amode addr addr_code <- getAmode dynRef + return (addr, addr_code) + else return (ripRel (ImmCLbl lbl), nilOL) + let code = + LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit]) + `consOL` addr_code + return (Amode addr code) + + +loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register +loadFloatAmode w addr addr_code = do + let format = floatFormat w + code dst = addr_code `snocOL` + MOV format (OpAddr addr) (OpReg dst) + + return (Any format code) + + +-- if we want a floating-point literal as an operand, we can +-- use it directly from memory. However, if the literal is +-- zero, we're better off generating it into a register using +-- xor. +isSuitableFloatingPointLit :: CmmLit -> Bool +isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0 +isSuitableFloatingPointLit _ = False + +getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) +getRegOrMem e@(CmmLoad mem pk) = do + is32Bit <- is32BitPlatform + use_sse2 <- sse2Enabled + if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) +getRegOrMem e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +is32BitLit :: Bool -> CmmLit -> Bool +is32BitLit is32Bit lit + | not is32Bit = case lit of + CmmInt i W64 -> is32BitInteger i + -- assume that labels are in the range 0-2^31-1: this assumes the + -- small memory model (see gcc docs, -mcmodel=small). + CmmLabel _ -> True + -- however we can't assume that label offsets are in this range + -- (see #15570) + CmmLabelOff _ off -> is32BitInteger (fromIntegral off) + CmmLabelDiffOff _ _ off _ -> is32BitInteger (fromIntegral off) + _ -> True +is32BitLit _ _ = True + + + + +-- Set up a condition code for a conditional branch. + +getCondCode :: CmmExpr -> NatM CondCode + +-- yes, they really do seem to want exactly the same! + +getCondCode (CmmMachOp mop [x, y]) + = + case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + -- Invert comparison condition and swap operands + -- See Note [SSE Parity Checks] + MO_F_Lt W32 -> condFltCode GTT y x + MO_F_Le W32 -> condFltCode GE y x + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode GTT y x + MO_F_Le W64 -> condFltCode GE y x + + _ -> condIntCode (machOpToCond mop) x y + +getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) + +machOpToCond :: MachOp -> Cond +machOpToCond mo = case mo of + MO_Eq _ -> EQQ + MO_Ne _ -> NE + MO_S_Gt _ -> GTT + MO_S_Ge _ -> GE + MO_S_Lt _ -> LTT + MO_S_Le _ -> LE + MO_U_Gt _ -> GU + MO_U_Ge _ -> GEU + MO_U_Lt _ -> LU + MO_U_Le _ -> LEU + _other -> pprPanic "machOpToCond" (pprMachOp mo) + + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond x y = do is32Bit <- is32BitPlatform + condIntCode' is32Bit cond x y + +condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +-- memory vs immediate +condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit) + | is32BitLit is32Bit lit = do + Amode x_addr x_code <- getAmode x + let + imm = litToImm lit + code = x_code `snocOL` + CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr) + -- + return (CondCode False cond code) + +-- anything vs zero, using a mask +-- TODO: Add some sanity checking!!!! +condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk)) + | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit + = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs zero +condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs operand +condIntCode' is32Bit cond x y + | isOperand is32Bit y = do + platform <- getPlatform + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` y_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg) + return (CondCode False cond code) +-- operand vs. anything: invert the comparison so that we can use a +-- single comparison instruction. + | isOperand is32Bit x + , Just revcond <- maybeFlipCond cond = do + platform <- getPlatform + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getOperand x + let + code = y_code `appOL` x_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg) + return (CondCode False revcond code) + +-- anything vs anything +condIntCode' _ cond x y = do + platform <- getPlatform + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getRegOrMem x + let + code = y_code `appOL` + x_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op + return (CondCode False cond code) + + + +-------------------------------------------------------------------------------- +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +condFltCode cond x y + = condFltCode_sse2 + where + + + -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be + -- an operand, but the right must be a reg. We can probably do better + -- than this general case... + condFltCode_sse2 = do + platform <- getPlatform + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` + y_code `snocOL` + CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg) + -- NB(1): we need to use the unsigned comparison operators on the + -- result of this comparison. + return (CondCode True (condToUnsigned cond) code) + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + + +-- integer assignment to memory + +-- specific case of adding/subtracting an integer to a particular address. +-- ToDo: catch other cases where we can use an operation directly on a memory +-- address. +assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _, + CmmLit (CmmInt i _)]) + | addr == addr2, pk /= II64 || is32BitInteger i, + Just instr <- check op + = do Amode amode code_addr <- getAmode addr + let code = code_addr `snocOL` + instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode) + return code + where + check (MO_Add _) = Just ADD + check (MO_Sub _) = Just SUB + check _ = Nothing + -- ToDo: more? + +-- general case +assignMem_IntCode pk addr src = do + is32Bit <- is32BitPlatform + Amode addr code_addr <- getAmode addr + (code_src, op_src) <- get_op_RI is32Bit src + let + code = code_src `appOL` + code_addr `snocOL` + MOV pk op_src (OpAddr addr) + -- NOTE: op_src is stable, so it will still be valid + -- after code_addr. This may involve the introduction + -- of an extra MOV to a temporary register, but we hope + -- the register allocator will get rid of it. + -- + return code + where + get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator + get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit + = return (nilOL, OpImm (litToImm lit)) + get_op_RI _ op + = do (reg,code) <- getNonClobberedReg op + return (code, OpReg reg) + + +-- Assign; dst is a reg, rhs is mem +assignReg_IntCode pk reg (CmmLoad src _) = do + load_code <- intLoadCode (MOV pk) src + platform <- ncgPlatform <$> getConfig + return (load_code (getRegisterReg platform reg)) + +-- dst is a reg, but src could be anything +assignReg_IntCode _ reg src = do + platform <- ncgPlatform <$> getConfig + code <- getAnyReg src + return (code (getRegisterReg platform reg)) + + +-- Floating point assignment to memory +assignMem_FltCode pk addr src = do + (src_reg, src_code) <- getNonClobberedReg src + Amode addr addr_code <- getAmode addr + let + code = src_code `appOL` + addr_code `snocOL` + MOV pk (OpReg src_reg) (OpAddr addr) + + return code + +-- Floating point assignment to a register/temporary +assignReg_FltCode _ reg src = do + src_code <- getAnyReg src + platform <- ncgPlatform <$> getConfig + return (src_code (getRegisterReg platform reg)) + + +genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock + +genJump (CmmLoad mem _) regs = do + Amode target code <- getAmode mem + return (code `snocOL` JMP (OpAddr target) regs) + +genJump (CmmLit lit) regs = do + return (unitOL (JMP (OpImm (litToImm lit)) regs)) + +genJump expr regs = do + (reg,code) <- getSomeReg expr + return (code `snocOL` JMP (OpReg reg) regs) + + +-- ----------------------------------------------------------------------------- +-- Unconditional branches + +genBranch :: BlockId -> InstrBlock +genBranch = toOL . mkJumpInstr + + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps/branches + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. + +I386: First, we have to ensure that the condition +codes are set according to the supplied comparison operation. +-} + +{- Note [64-bit integer comparisons on 32-bit] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + When doing these comparisons there are 2 kinds of + comparisons. + + * Comparison for equality (or lack thereof) + + We use xor to check if high/low bits are + equal. Then combine the results using or and + perform a single conditional jump based on the + result. + + * Other comparisons: + + We map all other comparisons to the >= operation. + Why? Because it's easy to encode it with a single + conditional jump. + + We do this by first computing [r1_lo - r2_lo] + and use the carry flag to compute + [r1_high - r2_high - CF]. + + At which point if r1 >= r2 then the result will be + positive. Otherwise negative so we can branch on this + condition. + +-} + + +genCondBranch + :: BlockId -- the source of the jump + -> BlockId -- the true branch target + -> BlockId -- the false branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock -- Instructions + +genCondBranch bid id false expr = do + is32Bit <- is32BitPlatform + genCondBranch' is32Bit bid id false expr + +-- | We return the instructions generated. +genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr + -> NatM InstrBlock + +-- 64-bit integer comparisons on 32-bit +-- See Note [64-bit integer comparisons on 32-bit] +genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2]) + | is32Bit, Just W64 <- maybeIntComparison mop = do + + -- The resulting registers here are both the lower part of + -- the register as well as a way to get at the higher part. + ChildCode64 code1 r1 <- iselExpr64 e1 + ChildCode64 code2 r2 <- iselExpr64 e2 + let cond = machOpToCond mop :: Cond + + let cmpCode = intComparison cond true false r1 r2 + return $ code1 `appOL` code2 `appOL` cmpCode + + where + intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock + intComparison cond true false r1_lo r2_lo = + case cond of + -- Impossible results of machOpToCond + ALWAYS -> panic "impossible" + NEG -> panic "impossible" + POS -> panic "impossible" + CARRY -> panic "impossible" + OFLO -> panic "impossible" + PARITY -> panic "impossible" + NOTPARITY -> panic "impossible" + -- Special case #1 x == y and x != y + EQQ -> cmpExact + NE -> cmpExact + -- [x >= y] + GE -> cmpGE + GEU -> cmpGE + -- [x > y] <==> ![y >= x] + GTT -> intComparison GE false true r2_lo r1_lo + GU -> intComparison GEU false true r2_lo r1_lo + -- [x <= y] <==> [y >= x] + LE -> intComparison GE true false r2_lo r1_lo + LEU -> intComparison GEU true false r2_lo r1_lo + -- [x < y] <==> ![x >= x] + LTT -> intComparison GE false true r1_lo r2_lo + LU -> intComparison GEU false true r1_lo r2_lo + where + r1_hi = getHiVRegFromLo r1_lo + r2_hi = getHiVRegFromLo r2_lo + cmpExact :: OrdList Instr + cmpExact = + toOL + [ XOR II32 (OpReg r2_hi) (OpReg r1_hi) + , XOR II32 (OpReg r2_lo) (OpReg r1_lo) + , OR II32 (OpReg r1_hi) (OpReg r1_lo) + , JXX cond true + , JXX ALWAYS false + ] + cmpGE = toOL + [ CMP II32 (OpReg r2_lo) (OpReg r1_lo) + , SBB II32 (OpReg r2_hi) (OpReg r1_hi) + , JXX cond true + , JXX ALWAYS false ] + +genCondBranch' _ bid id false bool = do + CondCode is_float cond cond_code <- getCondCode bool + use_sse2 <- sse2Enabled + if not is_float || not use_sse2 + then + return (cond_code `snocOL` JXX cond id `appOL` genBranch false) + else do + -- See Note [SSE Parity Checks] + let jmpFalse = genBranch false + code + = case cond of + NE -> or_unordered + GU -> plain_test + GEU -> plain_test + -- Use ASSERT so we don't break releases if + -- LTT/LE creep in somehow. + LTT -> + ASSERT2(False, ppr "Should have been turned into >") + and_ordered + LE -> + ASSERT2(False, ppr "Should have been turned into >=") + and_ordered + _ -> and_ordered + + plain_test = unitOL ( + JXX cond id + ) `appOL` jmpFalse + or_unordered = toOL [ + JXX cond id, + JXX PARITY id + ] `appOL` jmpFalse + and_ordered = toOL [ + JXX PARITY false, + JXX cond id, + JXX ALWAYS false + ] + updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false) + return (cond_code `appOL` code) + +{- Note [Introducing cfg edges inside basic blocks] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + During instruction selection a statement `s` + in a block B with control of the sort: B -> C + will sometimes result in control + flow of the sort: + + ┌ < ┐ + v ^ + B -> B1 ┴ -> C + + as is the case for some atomic operations. + + Now to keep the CFG in sync when introducing B1 we clearly + want to insert it between B and C. However there is + a catch when we have to deal with self loops. + + We might start with code and a CFG of these forms: + + loop: + stmt1 ┌ < ┐ + .... v ^ + stmtX loop ┘ + stmtY + .... + goto loop: + + Now we introduce B1: + ┌ ─ ─ ─ ─ ─┐ + loop: │ ┌ < ┐ │ + instrs v │ │ ^ + .... loop ┴ B1 ┴ ┘ + instrsFromX + stmtY + goto loop: + + This is simple, all outgoing edges from loop now simply + start from B1 instead and the code generator knows which + new edges it introduced for the self loop of B1. + + Disaster strikes if the statement Y follows the same pattern. + If we apply the same rule that all outgoing edges change then + we end up with: + + loop ─> B1 ─> B2 ┬─┐ + │ │ └─<┤ │ + │ └───<───┘ │ + └───────<────────┘ + + This is problematic. The edge B1->B1 is modified as expected. + However the modification is wrong! + + The assembly in this case looked like this: + + _loop: + + _B1: + ... + cmpxchgq ... + jne _B1 + + + _B2: + ... + cmpxchgq ... + jne _B2 + + jmp loop + + There is no edge _B2 -> _B1 here. It's still a self loop onto _B1. + + The problem here is that really B1 should be two basic blocks. + Otherwise we have control flow in the *middle* of a basic block. + A contradiction! + + So to account for this we add yet another basic block marker: + + _B: + + _B1: + ... + cmpxchgq ... + jne _B1 + jmp _B1' + _B1': + + + _B2: + ... + + Now when inserting B2 we will only look at the outgoing edges of B1' and + everything will work out nicely. + + You might also wonder why we don't insert jumps at the end of _B1'. There is + no way another block ends up jumping to the labels _B1 or _B2 since they are + essentially invisible to other blocks. View them as control flow labels local + to the basic block if you'd like. + + Not doing this ultimately caused (part 2 of) #17334. +-} + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. +-- +-- See Note [Keeping track of the current block] for information why we need +-- to take/return a block id. + +genCCall + :: Bool -- 32 bit platform? + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> BlockId -- The block we are in + -> NatM (InstrBlock, Maybe BlockId) + +-- First we deal with cases which might introduce new blocks in the stream. + +genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop)) + [dst] [addr, n] bid = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode is32Bit addr -- See genCCall for MO_Cmpxchg + arg <- getNewRegNat format + arg_code <- getAnyReg n + platform <- ncgPlatform <$> getConfig + + let dst_r = getRegisterReg platform (CmmLocal dst) + (code, lbl) <- op_code dst_r arg amode + return (addr_code `appOL` arg_code arg `appOL` code, Just lbl) + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId + op_code dst_r arg amode = case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ], bid) + AMO_Sub -> return $ (toOL [ NEGI format (OpReg arg) + , LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ], bid) + -- In these cases we need a new block id, and have to return it so + -- that later instruction selection can reference it. + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst + , NOT format dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr, BlockId) + cmpxchg_code instrs = do + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + tmp <- getNewRegNat format + + --Record inserted blocks + -- We turn A -> B into A -> A' -> A'' -> B + -- with a self loop on A'. + addImmediateSuccessorNat bid lbl1 + addImmediateSuccessorNat lbl1 lbl2 + updateCfgNat (addWeightEdge lbl1 lbl1 0) + + return $ (toOL + [ MOV format (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl1 + , NEWBLOCK lbl1 + -- Keep old value so we can return it: + , MOV format (OpReg eax) (OpReg dst_r) + , MOV format (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode)) + , JXX NE lbl1 + -- See Note [Introducing cfg edges inside basic blocks] + -- why this basic block is required. + , JXX ALWAYS lbl2 + , NEWBLOCK lbl2 + ], + lbl2) + format = intFormat width + +genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid + | is32Bit, width == W64 = do + ChildCode64 vcode rlo <- iselExpr64 src + platform <- ncgPlatform <$> getConfig + let rhi = getHiVRegFromLo rlo + dst_r = getRegisterReg platform (CmmLocal dst) + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + let format = if width == W8 then II16 else intFormat width + tmp_r <- getNewRegNat format + + -- New CFG Edges: + -- bid -> lbl2 + -- bid -> lbl1 -> lbl2 + -- We also changes edges originating at bid to start at lbl2 instead. + dflags <- getDynFlags + updateCfgNat (addWeightEdge bid lbl1 110 . + addWeightEdge lbl1 lbl2 110 . + addImmediateSuccessor dflags bid lbl2) + + -- The following instruction sequence corresponds to the pseudo-code + -- + -- if (src) { + -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32); + -- } else { + -- dst = 64; + -- } + let !instrs = vcode `appOL` toOL + ([ MOV II32 (OpReg rhi) (OpReg tmp_r) + , OR II32 (OpReg rlo) (OpReg tmp_r) + , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r) + , JXX EQQ lbl2 + , JXX ALWAYS lbl1 + + , NEWBLOCK lbl1 + , BSF II32 (OpReg rhi) dst_r + , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r) + , BSF II32 (OpReg rlo) tmp_r + , CMOV NE II32 (OpReg tmp_r) dst_r + , JXX ALWAYS lbl2 + + , NEWBLOCK lbl2 + ]) + return (instrs, Just lbl2) + + | otherwise = do + code_src <- getAnyReg src + config <- getConfig + let platform = ncgPlatform config + let dst_r = getRegisterReg platform (CmmLocal dst) + if ncgBmiVersion config >= Just BMI2 + then do + src_r <- getNewRegNat (intFormat width) + let instrs = appOL (code_src src_r) $ case width of + W8 -> toOL + [ OR II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r) + , TZCNT II32 (OpReg src_r) dst_r + ] + W16 -> toOL + [ TZCNT II16 (OpReg src_r) dst_r + , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) + ] + _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r + return (instrs, Nothing) + else do + -- The following insn sequence makes sure 'ctz 0' has a defined value. + -- starting with Haswell, one could use the TZCNT insn instead. + let format = if width == W8 then II16 else intFormat width + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + let !instrs = code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSF format (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) + , CMOV NE format (OpReg tmp_r) dst_r + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + return (instrs, Nothing) + where + bw = widthInBits width + +genCCall bits mop dst args bid = do + config <- getConfig + instr <- genCCall' config bits mop dst args bid + return (instr, Nothing) + +-- genCCall' handles cases not introducing new code blocks. +genCCall' + :: NCGConfig + -> Bool -- 32 bit platform? + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> BlockId -- The block we are in + -> NatM InstrBlock + +-- Unroll memcpy calls if the number of bytes to copy isn't too +-- large. Otherwise, call C's memcpy. +genCCall' config _ (PrimTarget (MO_Memcpy align)) _ + [dst, src, CmmLit (CmmInt n _)] _ + | fromInteger insns <= ncgInlineThresholdMemcpy config = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat format + code_src <- getAnyReg src + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + return $ code_dst dst_r `appOL` code_src src_r `appOL` + go dst_r src_r tmp_r (fromInteger n) + where + platform = ncgPlatform config + -- The number of instructions we will generate (approx). We need 2 + -- instructions per move. + insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) + + maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported + effectiveAlignment = min (alignmentOf align) maxAlignment + format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment + + -- The size of each move, in bytes. + sizeBytes :: Integer + sizeBytes = fromIntegral (formatInBytes format) + + go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr + go dst src tmp i + | i >= sizeBytes = + unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - sizeBytes) + -- Deal with remaining bytes. + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 4) + | i >= 2 = + unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 2) + | i >= 1 = + unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 1) + | otherwise = nilOL + where + src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone + (ImmInteger (n - i)) + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + +genCCall' config _ (PrimTarget (MO_Memset align)) _ + [dst, + CmmLit (CmmInt c _), + CmmLit (CmmInt n _)] + _ + | fromInteger insns <= ncgInlineThresholdMemset config = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat format + if format == II64 && n >= 8 then do + code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64)) + imm8byte_r <- getNewRegNat II64 + return $ code_dst dst_r `appOL` + code_imm8byte imm8byte_r `appOL` + go8 dst_r imm8byte_r (fromInteger n) + else + return $ code_dst dst_r `appOL` + go4 dst_r (fromInteger n) + where + platform = ncgPlatform config + maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported + effectiveAlignment = min (alignmentOf align) maxAlignment + format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment + c2 = c `shiftL` 8 .|. c + c4 = c2 `shiftL` 16 .|. c2 + c8 = c4 `shiftL` 32 .|. c4 + + -- The number of instructions we will generate (approx). We need 1 + -- instructions per move. + insns = (n + sizeBytes - 1) `div` sizeBytes + + -- The size of each move, in bytes. + sizeBytes :: Integer + sizeBytes = fromIntegral (formatInBytes format) + + -- Depending on size returns the widest MOV instruction and its + -- width. + gen4 :: AddrMode -> Integer -> (InstrBlock, Integer) + gen4 addr size + | size >= 4 = + (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4) + | size >= 2 = + (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2) + | size >= 1 = + (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1) + | otherwise = (nilOL, 0) + + -- Generates a 64-bit wide MOV instruction from REG to MEM. + gen8 :: AddrMode -> Reg -> InstrBlock + gen8 addr reg8byte = + unitOL (MOV format (OpReg reg8byte) (OpAddr addr)) + + -- Unrolls memset when the widest MOV is <= 4 bytes. + go4 :: Reg -> Integer -> InstrBlock + go4 dst left = + if left <= 0 then nilOL + else curMov `appOL` go4 dst (left - curWidth) + where + possibleWidth = minimum [left, sizeBytes] + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) + (curMov, curWidth) = gen4 dst_addr possibleWidth + + -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg + -- argument). Falls back to go4 when all 8 byte moves are + -- exhausted. + go8 :: Reg -> Reg -> Integer -> InstrBlock + go8 dst reg8byte left = + if possibleWidth >= 8 then + let curMov = gen8 dst_addr reg8byte + in curMov `appOL` go8 dst reg8byte (left - 8) + else go4 dst left + where + possibleWidth = minimum [left, sizeBytes] + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) + +genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _ = return nilOL +genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL + -- barriers compile to no code on x86/x86-64; + -- we keep it this long in order to prevent earlier optimisations. + +genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL + +genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _ [src] _ = + case n of + 0 -> genPrefetch src $ PREFETCH NTA format + 1 -> genPrefetch src $ PREFETCH Lvl2 format + 2 -> genPrefetch src $ PREFETCH Lvl1 format + 3 -> genPrefetch src $ PREFETCH Lvl0 format + l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l) + -- the c / llvm prefetch convention is 0, 1, 2, and 3 + -- the x86 corresponding names are : NTA, 2 , 1, and 0 + where + format = archWordFormat is32bit + -- need to know what register width for pointers! + genPrefetch inRegSrc prefetchCTor = + do + code_src <- getAnyReg inRegSrc + src_r <- getNewRegNat format + return $ code_src src_r `appOL` + (unitOL (prefetchCTor (OpAddr + ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) )) + -- prefetch always takes an address + +genCCall' _ is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do + platform <- ncgPlatform <$> getConfig + let dst_r = getRegisterReg platform (CmmLocal dst) + case width of + W64 | is32Bit -> do + ChildCode64 vcode rlo <- iselExpr64 src + let dst_rhi = getHiVRegFromLo dst_r + rhi = getHiVRegFromLo rlo + return $ vcode `appOL` + toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi), + MOV II32 (OpReg rhi) (OpReg dst_r), + BSWAP II32 dst_rhi, + BSWAP II32 dst_r ] + W16 -> do code_src <- getAnyReg src + return $ code_src dst_r `appOL` + unitOL (BSWAP II32 dst_r) `appOL` + unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r)) + _ -> do code_src <- getAnyReg src + return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r) + where + format = intFormat width + +genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] + args@[src] bid = do + sse4_2 <- sse4_2Enabled + let platform = ncgPlatform config + if sse4_2 + then do code_src <- getAnyReg src + src_r <- getNewRegNat format + let dst_r = getRegisterReg platform (CmmLocal dst) + return $ code_src src_r `appOL` + (if width == W8 then + -- The POPCNT instruction doesn't take a r/m8 + unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` + unitOL (POPCNT II16 (OpReg src_r) dst_r) + else + unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL` + (if width == W8 || width == W16 then + -- We used a 16-bit destination register above, + -- so zero-extend + unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) + else nilOL) + else do + targetExpr <- cmmMakeDynamicReference config + CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall' config is32Bit target dest_regs args bid + where + format = intFormat width + lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width)) + +genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] + args@[src, mask] bid = do + let platform = ncgPlatform config + if ncgBmiVersion config >= Just BMI2 + then do code_src <- getAnyReg src + code_mask <- getAnyReg mask + src_r <- getNewRegNat format + mask_r <- getNewRegNat format + let dst_r = getRegisterReg platform (CmmLocal dst) + return $ code_src src_r `appOL` code_mask mask_r `appOL` + (if width == W8 then + -- The PDEP instruction doesn't take a r/m8 + unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL` + unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL` + unitOL (PDEP II16 (OpReg mask_r) (OpReg src_r ) dst_r) + else + unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL` + (if width == W8 || width == W16 then + -- We used a 16-bit destination register above, + -- so zero-extend + unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) + else nilOL) + else do + targetExpr <- cmmMakeDynamicReference config + CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall' config is32Bit target dest_regs args bid + where + format = intFormat width + lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width)) + +genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] + args@[src, mask] bid = do + let platform = ncgPlatform config + if ncgBmiVersion config >= Just BMI2 + then do code_src <- getAnyReg src + code_mask <- getAnyReg mask + src_r <- getNewRegNat format + mask_r <- getNewRegNat format + let dst_r = getRegisterReg platform (CmmLocal dst) + return $ code_src src_r `appOL` code_mask mask_r `appOL` + (if width == W8 then + -- The PEXT instruction doesn't take a r/m8 + unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL` + unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL` + unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r) + else + unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL` + (if width == W8 || width == W16 then + -- We used a 16-bit destination register above, + -- so zero-extend + unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) + else nilOL) + else do + targetExpr <- cmmMakeDynamicReference config + CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall' config is32Bit target dest_regs args bid + where + format = intFormat width + lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width)) + +genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid + | is32Bit && width == W64 = do + -- Fallback to `hs_clz64` on i386 + targetExpr <- cmmMakeDynamicReference config CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall' config is32Bit target dest_regs args bid + + | otherwise = do + code_src <- getAnyReg src + config <- getConfig + let platform = ncgPlatform config + let dst_r = getRegisterReg platform (CmmLocal dst) + if ncgBmiVersion config >= Just BMI2 + then do + src_r <- getNewRegNat (intFormat width) + return $ appOL (code_src src_r) $ case width of + W8 -> toOL + [ MOVZxL II8 (OpReg src_r) (OpReg src_r) -- zero-extend to 32 bit + , LZCNT II32 (OpReg src_r) dst_r -- lzcnt with extra 24 zeros + , SUB II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros + ] + W16 -> toOL + [ LZCNT II16 (OpReg src_r) dst_r + , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit + ] + _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r) + else do + let format = if width == W8 then II16 else intFormat width + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSR format (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) + , CMOV NE format (OpReg tmp_r) dst_r + , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r) + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + where + bw = widthInBits width + lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) + +genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do + targetExpr <- cmmMakeDynamicReference config + CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall' config is32Bit target dest_regs args bid + where + lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) + +genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do + load_code <- intLoadCode (MOV (intFormat width)) addr + platform <- ncgPlatform <$> getConfig + + return (load_code (getRegisterReg platform (CmmLocal dst))) + +genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do + code <- assignMem_IntCode (intFormat width) addr val + return $ code `snocOL` MFENCE + +genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do + -- On x86 we don't have enough registers to use cmpxchg with a + -- complicated addressing mode, so on that architecture we + -- pre-compute the address first. + Amode amode addr_code <- getSimpleAmode is32Bit addr + newval <- getNewRegNat format + newval_code <- getAnyReg new + oldval <- getNewRegNat format + oldval_code <- getAnyReg old + platform <- getPlatform + let dst_r = getRegisterReg platform (CmmLocal dst) + code = toOL + [ MOV format (OpReg oldval) (OpReg eax) + , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode)) + , MOV format (OpReg eax) (OpReg dst_r) + ] + return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval + `appOL` code + where + format = intFormat width + +genCCall' config is32Bit (PrimTarget (MO_Xchg width)) [dst] [addr, value] _ + | (is32Bit && width == W64) = panic "gencCall: 64bit atomic exchange not supported on 32bit platforms" + | otherwise = do + let dst_r = getRegisterReg platform (CmmLocal dst) + Amode amode addr_code <- getSimpleAmode is32Bit addr + (newval, newval_code) <- getSomeReg value + -- Copy the value into the target register, perform the exchange. + let code = toOL + [ MOV format (OpReg newval) (OpReg dst_r) + -- On X86 xchg implies a lock prefix if we use a memory argument. + -- so this is atomic. + , XCHG format (OpAddr amode) dst_r + ] + return $ addr_code `appOL` newval_code `appOL` code + where + format = intFormat width + platform = ncgPlatform config + +genCCall' _ is32Bit target dest_regs args bid = do + platform <- ncgPlatform <$> getConfig + case (target, dest_regs) of + -- void return type prim op + (PrimTarget op, []) -> + outOfLineCmmOp bid op Nothing args + -- we only cope with a single result for foreign calls + (PrimTarget op, [r]) -> case op of + MO_F32_Fabs -> case args of + [x] -> sse2FabsCode W32 x + _ -> panic "genCCall: Wrong number of arguments for fabs" + MO_F64_Fabs -> case args of + [x] -> sse2FabsCode W64 x + _ -> panic "genCCall: Wrong number of arguments for fabs" + + MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args + MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args + _other_op -> outOfLineCmmOp bid op (Just r) args + + where + actuallyInlineSSE2Op = actuallyInlineFloatOp' + + actuallyInlineFloatOp' instr format [x] + = do res <- trivialUFCode format (instr format) x + any <- anyReg res + return (any (getRegisterReg platform (CmmLocal r))) + + actuallyInlineFloatOp' _ _ args + = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! (" + ++ show (length args) ++ ")" + + sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock + sse2FabsCode w x = do + let fmt = floatFormat w + x_code <- getAnyReg x + let + const | FF32 <- fmt = CmmInt 0x7fffffff W32 + | otherwise = CmmInt 0x7fffffffffffffff W64 + Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const + tmp <- getNewRegNat fmt + let + code dst = x_code dst `appOL` amode_code `appOL` toOL [ + MOV fmt (OpAddr amode) (OpReg tmp), + AND fmt (OpReg tmp) (OpReg dst) + ] + + return $ code (getRegisterReg platform (CmmLocal r)) + + (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args + (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args + (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args + (PrimTarget (MO_Add2 width), [res_h, res_l]) -> + case args of + [arg_x, arg_y] -> + do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) + let format = intFormat width + lCode <- anyReg =<< trivialCode width (ADD_CC format) + (Just (ADD_CC format)) arg_x arg_y + let reg_l = getRegisterReg platform (CmmLocal res_l) + reg_h = getRegisterReg platform (CmmLocal res_h) + code = hCode reg_h `appOL` + lCode reg_l `snocOL` + ADC format (OpImm (ImmInteger 0)) (OpReg reg_h) + return code + _ -> panic "genCCall: Wrong number of arguments/results for add2" + (PrimTarget (MO_AddWordC width), [res_r, res_c]) -> + addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args + (PrimTarget (MO_SubWordC width), [res_r, res_c]) -> + addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args + (PrimTarget (MO_AddIntC width), [res_r, res_c]) -> + addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args + (PrimTarget (MO_SubIntC width), [res_r, res_c]) -> + addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args + (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> + case args of + [arg_x, arg_y] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + let format = intFormat width + reg_h = getRegisterReg platform (CmmLocal res_h) + reg_l = getRegisterReg platform (CmmLocal res_l) + code = y_code `appOL` + x_code rax `appOL` + toOL [MUL2 format y_reg, + MOV format (OpReg rdx) (OpReg reg_h), + MOV format (OpReg rax) (OpReg reg_l)] + return code + _ -> panic "genCCall: Wrong number of arguments/results for mul2" + (PrimTarget (MO_S_Mul2 width), [res_c, res_h, res_l]) -> + case args of + [arg_x, arg_y] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + reg_tmp <- getNewRegNat II8 + let format = intFormat width + reg_h = getRegisterReg platform (CmmLocal res_h) + reg_l = getRegisterReg platform (CmmLocal res_l) + reg_c = getRegisterReg platform (CmmLocal res_c) + code = y_code `appOL` + x_code rax `appOL` + toOL [ IMUL2 format y_reg + , MOV format (OpReg rdx) (OpReg reg_h) + , MOV format (OpReg rax) (OpReg reg_l) + , SETCC CARRY (OpReg reg_tmp) + , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) + ] + return code + _ -> panic "genCCall: Wrong number of arguments/results for imul2" + + _ -> do + (instrs0, args') <- evalArgs bid args + instrs1 <- if is32Bit + then genCCall32' target dest_regs args' + else genCCall64' target dest_regs args' + return (instrs0 `appOL` instrs1) + + where divOp1 platform signed width results [arg_x, arg_y] + = divOp platform signed width results Nothing arg_x arg_y + divOp1 _ _ _ _ _ + = panic "genCCall: Wrong number of arguments for divOp1" + divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] + = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y + divOp2 _ _ _ _ _ + = panic "genCCall: Wrong number of arguments for divOp2" + + -- See Note [DIV/IDIV for bytes] + divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y = + let widen | signed = MO_SS_Conv W8 W16 + | otherwise = MO_UU_Conv W8 W16 + arg_x_low_16 = CmmMachOp widen [arg_x_low] + arg_y_16 = CmmMachOp widen [arg_y] + m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high + in divOp + platform signed W16 [res_q, res_r] + m_arg_x_high_16 arg_x_low_16 arg_y_16 + + divOp platform signed width [res_q, res_r] + m_arg_x_high arg_x_low arg_y + = do let format = intFormat width + reg_q = getRegisterReg platform (CmmLocal res_q) + reg_r = getRegisterReg platform (CmmLocal res_r) + widen | signed = CLTD format + | otherwise = XOR format (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_low_code <- getAnyReg arg_x_low + x_high_code <- case m_arg_x_high of + Just arg_x_high -> + getAnyReg arg_x_high + Nothing -> + return $ const $ unitOL widen + return $ y_code `appOL` + x_low_code rax `appOL` + x_high_code rdx `appOL` + toOL [instr format y_reg, + MOV format (OpReg rax) (OpReg reg_q), + MOV format (OpReg rdx) (OpReg reg_r)] + divOp _ _ _ _ _ _ _ + = panic "genCCall: Wrong number of results for divOp" + + addSubIntC platform instr mrevinstr cond width + res_r res_c [arg_x, arg_y] + = do let format = intFormat width + rCode <- anyReg =<< trivialCode width (instr format) + (mrevinstr format) arg_x arg_y + reg_tmp <- getNewRegNat II8 + let reg_c = getRegisterReg platform (CmmLocal res_c) + reg_r = getRegisterReg platform (CmmLocal res_r) + code = rCode reg_r `snocOL` + SETCC cond (OpReg reg_tmp) `snocOL` + MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) + + return code + addSubIntC _ _ _ _ _ _ _ _ + = panic "genCCall: Wrong number of arguments/results for addSubIntC" + +{- +Note [Evaluate C-call arguments before placing in destination registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When producing code for C calls we must take care when placing arguments +in their final registers. Specifically, we must ensure that temporary register +usage due to evaluation of one argument does not clobber a register in which we +already placed a previous argument (e.g. as the code generation logic for +MO_Shl can clobber %rcx due to x86 instruction limitations). + +This is precisely what happened in #18527. Consider this C--: + + (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64)); + +Here we are calling the C function `doSomething` with three arguments, the last +involving a non-trivial expression involving MO_Shl. In this case the NCG could +naively generate the following assembly (where $tmp denotes some temporary +register and $argN denotes the register for argument N, as dictated by the +platform's calling convention): + + mov _s2hp, $arg1 # place first argument + mov _s2hq, $arg2 # place second argument + + # Compute 1 << _s2hz + mov _s2hz, %rcx + shl %cl, $tmp + + # Compute (_s2hw | (1 << _s2hz)) + mov _s2hw, $arg3 + or $tmp, $arg3 + + # Perform the call + call func + +This code is outright broken on Windows which assigns $arg1 to %rcx. This means +that the evaluation of the last argument clobbers the first argument. + +To avoid this we use a rather awful hack: when producing code for a C call with +at least one non-trivial argument, we first evaluate all of the arguments into +local registers before moving them into their final calling-convention-defined +homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an +expression which might contain a MachOp since these are the only cases which +might clobber registers. Furthermore, we use a conservative approximation of +this condition (only looking at the top-level of CmmExprs) to avoid spending +too much effort trying to decide whether we want to take the fast path. + +Note that this hack *also* applies to calls to out-of-line PrimTargets (which +are lowered via a C call) since outOfLineCmmOp produces the call via +(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up +back in genCCall{32,64}. +-} + +-- | See Note [Evaluate C-call arguments before placing in destination registers] +evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual]) +evalArgs bid actuals + | any mightContainMachOp actuals = do + regs_blks <- mapM evalArg actuals + return (concatOL $ map fst regs_blks, map snd regs_blks) + | otherwise = return (nilOL, actuals) + where + mightContainMachOp (CmmReg _) = False + mightContainMachOp (CmmRegOff _ _) = False + mightContainMachOp (CmmLit _) = False + mightContainMachOp _ = True + + evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr) + evalArg actual = do + platform <- getPlatform + lreg <- newLocalReg $ cmmExprType platform actual + (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual + -- The above assignment shouldn't change the current block + MASSERT(isNothing bid1) + return (instrs, CmmReg $ CmmLocal lreg) + + newLocalReg :: CmmType -> NatM LocalReg + newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty + +-- Note [DIV/IDIV for bytes] +-- +-- IDIV reminder: +-- Size Dividend Divisor Quotient Remainder +-- byte %ax r/m8 %al %ah +-- word %dx:%ax r/m16 %ax %dx +-- dword %edx:%eax r/m32 %eax %edx +-- qword %rdx:%rax r/m64 %rax %rdx +-- +-- We do a special case for the byte division because the current +-- codegen doesn't deal well with accessing %ah register (also, +-- accessing %ah in 64-bit mode is complicated because it cannot be an +-- operand of many instructions). So we just widen operands to 16 bits +-- and get the results from %al, %dl. This is not optimal, but a few +-- register moves are probably not a huge deal when doing division. + +genCCall32' :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall32' target dest_regs args = do + config <- getConfig + let platform = ncgPlatform config + prom_args = map (maybePromoteCArg platform W32) args + + -- If the size is smaller than the word, we widen things (see maybePromoteCArg) + arg_size_bytes :: CmmType -> Int + arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform)) + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + push_arg :: CmmActual {-current argument-} + -> NatM InstrBlock -- code + + push_arg arg -- we don't need the hints on x86 + | isWord64 arg_ty = do + ChildCode64 code r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + let r_hi = getHiVRegFromLo r_lo + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + format = floatFormat (typeWidth arg_ty) + in + + -- assume SSE2 + MOV format (OpReg reg) (OpAddr addr) + + ] + ) + + | otherwise = do + -- Arguments can be smaller than 32-bit, but we still use @PUSH + -- II32@ - the usual calling conventions expect integers to be + -- 4-byte aligned. + ASSERT((typeWidth arg_ty) <= W32) return () + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType platform arg + size = arg_size_bytes arg_ty -- Byte size + + let + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] + sizes = map (arg_size_bytes . cmmExprType platform) (reverse args) + raw_arg_size = sum sizes + platformWordSizeInBytes platform + arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size + tot_arg_size = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform + + + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) + + push_codes <- mapM push_arg (reverse prom_args) + delta <- getDeltaNat + MASSERT(delta == delta0 - tot_arg_size) + + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + ForeignTarget (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) []), conv) + where fn_imm = ImmCLbl lbl + ForeignTarget expr conv + -> do { (dyn_r, dyn_c) <- getSomeReg expr + ; ASSERT( isWord32 (cmmExprType platform expr) ) + return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } + PrimTarget _ + -> panic $ "genCCall: Can't handle PrimTarget call type here, error " + ++ "probably because too many return values." + + let push_code + | arg_pad_size /= 0 + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- even if we are doing stdcall, though (#5052) + pop_size + | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size + | otherwise = tot_arg_size + + call = callinsns `appOL` + toOL ( + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) + ++ + [DELTA delta0] + ) + setDeltaNat delta0 + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] + | isFloatType ty = + -- we assume SSE2 + let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + fmt = floatFormat w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA (delta0 - b), + X87Store fmt tmp_amode, + -- X87Store only supported for the CDECL ABI + -- NB: This code will need to be + -- revisted once GHC does more work around + -- SIGFPE f + MOV fmt (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA delta0] + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intFormat w) + (OpReg eax) + (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getRegisterReg platform (CmmLocal dest) + assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) + +genCCall64' :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall64' target dest_regs args = do + platform <- getPlatform + -- load up the register arguments + let prom_args = map (maybePromoteCArg platform W32) args + + let load_args :: [CmmExpr] + -> [Reg] -- int regs avail for args + -> [Reg] -- FP regs avail for args + -> InstrBlock -- code computing args + -> InstrBlock -- code assigning args to ABI regs + -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock) + -- no more regs to use + load_args args [] [] code acode = + return (args, [], [], code, acode) + + -- no more args to push + load_args [] aregs fregs code acode = + return ([], aregs, fregs, code, acode) + + load_args (arg : rest) aregs fregs code acode + | isFloatType arg_rep = case fregs of + [] -> push_this_arg + (r:rs) -> do + (code',acode') <- reg_this_arg r + load_args rest aregs rs code' acode' + | otherwise = case aregs of + [] -> push_this_arg + (r:rs) -> do + (code',acode') <- reg_this_arg r + load_args rest rs fregs code' acode' + where + + -- put arg into the list of stack pushed args + push_this_arg = do + (args',ars,frs,code',acode') + <- load_args rest aregs fregs code acode + return (arg:args', ars, frs, code', acode') + + -- pass the arg into the given register + reg_this_arg r + -- "operand" args can be directly assigned into r + | isOperand False arg = do + arg_code <- getAnyReg arg + return (code, (acode `appOL` arg_code r)) + -- The last non-operand arg can be directly assigned after its + -- computation without going into a temporary register + | all (isOperand False) rest = do + arg_code <- getAnyReg arg + return (code `appOL` arg_code r,acode) + + -- other args need to be computed beforehand to avoid clobbering + -- previously assigned registers used to pass parameters (see + -- #11792, #12614). They are assigned into temporary registers + -- and get assigned to proper call ABI registers after they all + -- have been computed. + | otherwise = do + arg_code <- getAnyReg arg + tmp <- getNewRegNat arg_fmt + let + code' = code `appOL` arg_code tmp + acode' = acode `snocOL` reg2reg arg_fmt tmp r + return (code',acode') + + arg_rep = cmmExprType platform arg + arg_fmt = cmmTypeFormat arg_rep + + load_args_win :: [CmmExpr] + -> [Reg] -- used int regs + -> [Reg] -- used FP regs + -> [(Reg, Reg)] -- (int, FP) regs avail for args + -> InstrBlock + -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock) + load_args_win args usedInt usedFP [] code + = return (args, usedInt, usedFP, code, nilOL) + -- no more regs to use + load_args_win [] usedInt usedFP _ code + = return ([], usedInt, usedFP, code, nilOL) + -- no more args to push + load_args_win (arg : rest) usedInt usedFP + ((ireg, freg) : regs) code + | isFloatType arg_rep = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) (freg : usedFP) regs + (code `appOL` + arg_code freg `snocOL` + -- If we are calling a varargs function + -- then we need to define ireg as well + -- as freg + MOV II64 (OpReg freg) (OpReg ireg)) + | otherwise = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) usedFP regs + (code `appOL` arg_code ireg) + where + arg_rep = cmmExprType platform arg + + arg_size = 8 -- always, at the mo + + push_args [] code = return code + push_args (arg:rest) code + | isFloatType arg_rep = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp), + DELTA (delta-arg_size), + MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))] + push_args rest code' + + | otherwise = do + -- Arguments can be smaller than 64-bit, but we still use @PUSH + -- II64@ - the usual calling conventions expect integers to be + -- 8-byte aligned. + ASSERT(width <= W64) return () + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + PUSH II64 arg_op, + DELTA (delta-arg_size)] + push_args rest code' + where + arg_rep = cmmExprType platform arg + width = typeWidth arg_rep + + leaveStackSpace n = do + delta <- getDeltaNat + setDeltaNat (delta - n * arg_size) + return $ toOL [ + SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp), + DELTA (delta - n * arg_size)] + + (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code) + <- + if platformOS platform == OSMinGW32 + then load_args_win prom_args [] [] (allArgRegs platform) nilOL + else do + (stack_args, aregs, fregs, load_args_code, assign_args_code) + <- load_args prom_args (allIntArgRegs platform) + (allFPArgRegs platform) + nilOL nilOL + let used_regs rs as = reverse (drop (length rs) (reverse as)) + fregs_used = used_regs fregs (allFPArgRegs platform) + aregs_used = used_regs aregs (allIntArgRegs platform) + return (stack_args, aregs_used, fregs_used, load_args_code + , assign_args_code) + + let + arg_regs_used = int_regs_used ++ fp_regs_used + arg_regs = [eax] ++ arg_regs_used + -- for annotating the call instruction with + sse_regs = length fp_regs_used + arg_stack_slots = if platformOS platform == OSMinGW32 + then length stack_args + length (allArgRegs platform) + else length stack_args + tot_arg_size = arg_size * arg_stack_slots + + + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] + let word_size = platformWordSizeInBytes platform + (real_size, adjust_rsp) <- + if (tot_arg_size + word_size) `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... + delta <- getDeltaNat + setDeltaNat (delta - word_size) + return (tot_arg_size + word_size, toOL [ + SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp), + DELTA (delta - word_size) ]) + + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + -- On Win64, we also have to leave stack space for the arguments + -- that we are passing in registers + lss_code <- if platformOS platform == OSMinGW32 + then leaveStackSpace (length (allArgRegs platform)) + else return nilOL + delta <- getDeltaNat + + -- deal with static vs dynamic call targets + (callinsns,_cconv) <- + case target of + ForeignTarget (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + ForeignTarget expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + PrimTarget _ + -> panic $ "genCCall: Can't handle PrimTarget call type here, error " + ++ "probably because too many return values." + + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- stdcall has callee do it, but is not supported on + -- x86_64 target (see #3336) + (if real_size==0 then [] else + [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + setDeltaNat (delta + real_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatFormat W32) + (OpReg xmm0) + (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatFormat W64) + (OpReg xmm0) + (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg platform (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" + + return (adjust_rsp `appOL` + push_code `appOL` + load_args_code `appOL` + assign_args_code `appOL` + lss_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) + + +maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr +maybePromoteCArg platform wto arg + | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] + | otherwise = arg + where + wfrom = cmmExprWidth platform arg + +outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual] + -> NatM InstrBlock +outOfLineCmmOp bid mop res args + = do + config <- getConfig + targetExpr <- cmmMakeDynamicReference config CallReference lbl + let target = ForeignTarget targetExpr + (ForeignConvention CCallConv [] [] CmmMayReturn) + + -- We know foreign calls results in no new basic blocks, so we can ignore + -- the returned block id. + (instrs, _) <- stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args) + return instrs + where + -- Assume we can call these functions directly, and that they're not in a dynamic library. + -- TODO: Why is this ok? Under linux this code will be in libm.so + -- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 + lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction + + fn = case mop of + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Fabs -> fsLit "fabsf" + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" + MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + MO_F32_Pwr -> fsLit "powf" + + MO_F32_Asinh -> fsLit "asinhf" + MO_F32_Acosh -> fsLit "acoshf" + MO_F32_Atanh -> fsLit "atanhf" + + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Fabs -> fsLit "fabs" + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" + MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + MO_F64_Pwr -> fsLit "pow" + + MO_F64_Asinh -> fsLit "asinh" + MO_F64_Acosh -> fsLit "acosh" + MO_F64_Atanh -> fsLit "atanh" + + MO_Memcpy _ -> fsLit "memcpy" + MO_Memset _ -> fsLit "memset" + MO_Memmove _ -> fsLit "memmove" + MO_Memcmp _ -> fsLit "memcmp" + + MO_PopCnt _ -> fsLit "popcnt" + MO_BSwap _ -> fsLit "bswap" + {- Here the C implementation is used as there is no x86 + instruction to reverse a word's bit order. + -} + MO_BRev w -> fsLit $ bRevLabel w + MO_Clz w -> fsLit $ clzLabel w + MO_Ctz _ -> unsupported + + MO_Pdep w -> fsLit $ pdepLabel w + MO_Pext w -> fsLit $ pextLabel w + + MO_AtomicRMW _ _ -> fsLit "atomicrmw" + MO_AtomicRead _ -> fsLit "atomicread" + MO_AtomicWrite _ -> fsLit "atomicwrite" + MO_Cmpxchg _ -> fsLit "cmpxchg" + MO_Xchg _ -> should_be_inline + + MO_UF_Conv _ -> unsupported + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_AddWordC {} -> unsupported + MO_SubWordC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + (MO_Prefetch_Data _ ) -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + -- If we generate a call for the given primop + -- something went wrong. + should_be_inline = panic ("outOfLineCmmOp: " ++ show mop + ++ " should be handled inline") + + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock + +genSwitch expr targets = do + config <- getConfig + let platform = ncgPlatform config + if ncgPIC config + then do + (reg,e_code) <- getNonClobberedReg (cmmOffset platform expr offset) + -- getNonClobberedReg because it needs to survive across t_code + lbl <- getNewLabelNat + let is32bit = target32Bit platform + os = platformOS platform + -- Might want to use .rodata. instead, but as + -- long as it's something unique it'll work out since the + -- references to the jump table are in the appropriate section. + rosection = case os of + -- on Mac OS X/x86_64, put the jump table in the text section to + -- work around a limitation of the linker. + -- ld64 is unable to handle the relocations for + -- .quad L1 - L0 + -- if L0 is not preceded by a non-anonymous label in its section. + OSDarwin | not is32bit -> Section Text lbl + _ -> Section ReadOnlyData lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) + + offsetReg <- getNewRegNat (intFormat (platformWordWidth platform)) + return $ if is32bit || os == OSDarwin + then e_code `appOL` t_code `appOL` toOL [ + ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids rosection lbl + ] + else -- HACK: On x86_64 binutils<2.17 is only able to generate + -- PC32 relocations, hence we only get 32-bit offsets in + -- the jump table. As these offsets are always negative + -- we need to properly sign extend them to 64-bit. This + -- hack should be removed in conjunction with the hack in + -- PprMach.hs/pprDataItem once binutils 2.17 is standard. + e_code `appOL` t_code `appOL` toOL [ + MOVSxL II32 op (OpReg offsetReg), + ADD (intFormat (platformWordWidth platform)) + (OpReg offsetReg) + (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids rosection lbl + ] + else do + (reg,e_code) <- getSomeReg (cmmOffset platform expr offset) + lbl <- getNewLabelNat + let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl)) + code = e_code `appOL` toOL [ + JMP_TBL op ids (Section ReadOnlyData lbl) lbl + ] + return code + where + (offset, blockIds) = switchTargetsToTable targets + ids = map (fmap DestBlockId) blockIds + +generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr) +generateJumpTableForInstr config (JMP_TBL _ ids section lbl) + = let getBlockId (DestBlockId id) = id + getBlockId _ = panic "Non-Label target in Jump Table" + blockIds = map (fmap getBlockId) ids + in Just (createJumpTable config blockIds section lbl) +generateJumpTableForInstr _ _ = Nothing + +createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel + -> GenCmmDecl (Alignment, RawCmmStatics) h g +createJumpTable config ids section lbl + = let jumpTable + | ncgPIC config = + let ww = ncgWordWidth config + jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 ww) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww) + where blockLabel = blockLbl blockid + in map jumpTableEntryRel ids + | otherwise = map (jumpTableEntry config) ids + in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable) + +extractUnwindPoints :: [Instr] -> [UnwindPoint] +extractUnwindPoints instrs = + [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs] + +-- ----------------------------------------------------------------------------- +-- 'condIntReg' and 'condFltReg': condition codes into registers + +-- Turn those condition codes into integers now (when they appear on +-- the right hand side of an assignment). +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. + +condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register + +condIntReg cond x y = do + CondCode _ cond cond_code <- condIntCode cond x y + tmp <- getNewRegNat II8 + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] + return (Any II32 code) + + +----------------------------------------------------------- +--- Note [SSE Parity Checks] --- +----------------------------------------------------------- + +-- We have to worry about unordered operands (eg. comparisons +-- against NaN). If the operands are unordered, the comparison +-- sets the parity flag, carry flag and zero flag. +-- All comparisons are supposed to return false for unordered +-- operands except for !=, which returns true. +-- +-- Optimisation: we don't have to test the parity flag if we +-- know the test has already excluded the unordered case: eg > +-- and >= test for a zero carry flag, which can only occur for +-- ordered operands. +-- +-- By reversing comparisons we can avoid testing the parity +-- for < and <= as well. If any of the arguments is an NaN we +-- return false either way. If both arguments are valid then +-- x <= y <-> y >= x holds. So it's safe to swap these. +-- +-- We invert the condition inside getRegister'and getCondCode +-- which should cover all invertable cases. +-- All other functions translating FP comparisons to assembly +-- use these to two generate the comparison code. +-- +-- As an example consider a simple check: +-- +-- func :: Float -> Float -> Int +-- func x y = if x < y then 1 else 0 +-- +-- Which in Cmm gives the floating point comparison. +-- +-- if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf; +-- +-- We used to compile this to an assembly code block like this: +-- _c2gh: +-- ucomiss %xmm2,%xmm1 +-- jp _c2gf +-- jb _c2gg +-- jmp _c2gf +-- +-- Where we have to introduce an explicit +-- check for unordered results (using jmp parity): +-- +-- We can avoid this by exchanging the arguments and inverting the direction +-- of the comparison. This results in the sequence of: +-- +-- ucomiss %xmm1,%xmm2 +-- ja _c2g2 +-- jmp _c2g1 +-- +-- Removing the jump reduces the pressure on the branch predidiction system +-- and plays better with the uOP cache. + +condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg is32Bit cond x y = condFltReg_sse2 + where + + + condFltReg_sse2 = do + CondCode _ cond cond_code <- condFltCode cond x y + tmp1 <- getNewRegNat (archWordFormat is32Bit) + tmp2 <- getNewRegNat (archWordFormat is32Bit) + let -- See Note [SSE Parity Checks] + code dst = + cond_code `appOL` + (case cond of + NE -> or_unordered dst + GU -> plain_test dst + GEU -> plain_test dst + -- Use ASSERT so we don't break releases if these creep in. + LTT -> ASSERT2(False, ppr "Should have been turned into >") + and_ordered dst + LE -> ASSERT2(False, ppr "Should have been turned into >=") + and_ordered dst + _ -> and_ordered dst) + + plain_test dst = toOL [ + SETCC cond (OpReg tmp1), + MOVZxL II8 (OpReg tmp1) (OpReg dst) + ] + or_unordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC PARITY (OpReg tmp2), + OR II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + and_ordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC NOTPARITY (OpReg tmp2), + AND II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + return (Any II32 code) + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + + +{- +The Rules of the Game are: + +* You cannot assume anything about the destination register dst; + it may be anything, including a fixed reg. + +* You may compute an operand into a fixed reg, but you may not + subsequently change the contents of that fixed reg. If you + want to do so, first copy the value either to a temporary + or into dst. You are free to modify dst even if it happens + to be a fixed reg -- that's not your problem. + +* You cannot assume that a fixed reg will stay live over an + arbitrary computation. The same applies to the dst reg. + +* Temporary regs obtained from getNewRegNat are distinct from + each other and from all other regs, and stay live over + arbitrary computations. + +-------------------- + +SDM's version of The Rules: + +* If getRegister returns Any, that means it can generate correct + code which places the result in any register, period. Even if that + register happens to be read during the computation. + + Corollary #1: this means that if you are generating code for an + operation with two arbitrary operands, you cannot assign the result + of the first operand into the destination register before computing + the second operand. The second operand might require the old value + of the destination register. + + Corollary #2: A function might be able to generate more efficient + code if it knows the destination register is a new temporary (and + therefore not read by any of the sub-computations). + +* If getRegister returns Any, then the code it generates may modify only: + (a) fresh temporaries + (b) the destination register + (c) known registers (eg. %ecx is used by shifts) + In particular, it may *not* modify global registers, unless the global + register happens to be the destination register. +-} + +trivialCode :: Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode width instr m a b + = do is32Bit <- is32BitPlatform + trivialCode' is32Bit width instr m a b + +trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b + | is32BitLit is32Bit lit_a = do + b_code <- getAnyReg b + let + code dst + = b_code dst `snocOL` + revinstr (OpImm (litToImm lit_a)) (OpReg dst) + return (Any (intFormat width) code) + +trivialCode' _ width instr _ a b + = genTrivialCode (intFormat width) instr a b + +-- This is re-used for floating pt instructions too. +genTrivialCode :: Format -> (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +genTrivialCode rep instr a b = do + (b_op, b_code) <- getNonClobberedOperand b + a_code <- getAnyReg a + tmp <- getNewRegNat rep + let + -- We want the value of b to stay alive across the computation of a. + -- But, we want to calculate a straight into the destination register, + -- because the instruction only has two operands (dst := dst `op` src). + -- The troublesome case is when the result of b is in the same register + -- as the destination reg. In this case, we have to save b in a + -- new temporary across the computation of a. + code dst + | dst `regClashesWithOp` b_op = + b_code `appOL` + unitOL (MOV rep b_op (OpReg tmp)) `appOL` + a_code dst `snocOL` + instr (OpReg tmp) (OpReg dst) + | otherwise = + b_code `appOL` + a_code dst `snocOL` + instr b_op (OpReg dst) + return (Any rep code) + +regClashesWithOp :: Reg -> Operand -> Bool +reg `regClashesWithOp` OpReg reg2 = reg == reg2 +reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) +_ `regClashesWithOp` _ = False + +----------- + +trivialUCode :: Format -> (Operand -> Instr) + -> CmmExpr -> NatM Register +trivialUCode rep instr x = do + x_code <- getAnyReg x + let + code dst = + x_code dst `snocOL` + instr (OpReg dst) + return (Any rep code) + +----------- + + +trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialFCode_sse2 pk instr x y + = genTrivialCode format (instr format) x y + where format = floatFormat pk + + +trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register +trivialUFCode format instr x = do + (x_reg, x_code) <- getSomeReg x + let + code dst = + x_code `snocOL` + instr x_reg dst + return (Any format code) + + +-------------------------------------------------------------------------------- +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP from to x = coerce_sse2 + where + + coerce_sse2 = do + (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand + let + opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD + n -> panic $ "coerceInt2FP.sse: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc (intFormat from) x_op dst + return (Any (floatFormat to) code) + -- works even if the destination rep is Width -> CmmExpr -> NatM Register +coerceFP2Int from to x = coerceFP2Int_sse2 + where + coerceFP2Int_sse2 = do + (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand + let + opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ; + n -> panic $ "coerceFP2Init.sse: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc (intFormat to) x_op dst + return (Any (intFormat to) code) + -- works even if the destination rep is CmmExpr -> NatM Register +coerceFP2FP to x = do + (x_reg, x_code) <- getSomeReg x + let + opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD; + n -> panic $ "coerceFP2FP: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc x_reg dst + return (Any ( floatFormat to) code) + +-------------------------------------------------------------------------------- + +sse2NegCode :: Width -> CmmExpr -> NatM Register +sse2NegCode w x = do + let fmt = floatFormat w + x_code <- getAnyReg x + -- This is how gcc does it, so it can't be that bad: + let + const = case fmt of + FF32 -> CmmInt 0x80000000 W32 + FF64 -> CmmInt 0x8000000000000000 W64 + x@II8 -> wrongFmt x + x@II16 -> wrongFmt x + x@II32 -> wrongFmt x + x@II64 -> wrongFmt x + + where + wrongFmt x = panic $ "sse2NegCode: " ++ show x + Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const + tmp <- getNewRegNat fmt + let + code dst = x_code dst `appOL` amode_code `appOL` toOL [ + MOV fmt (OpAddr amode) (OpReg tmp), + XOR fmt (OpReg tmp) (OpReg dst) + ] + -- + return (Any fmt code) + +isVecExpr :: CmmExpr -> Bool +isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True +isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True +isVecExpr (CmmMachOp (MO_V_Add {}) _) = True +isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True +isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True +isVecExpr (CmmMachOp _ [e]) = isVecExpr e +isVecExpr _ = False + +needLlvm :: NatM a +needLlvm = + sorry $ unlines ["The native code generator does not support vector" + ,"instructions. Please use -fllvm."] + +-- | This works on the invariant that all jumps in the given blocks are required. +-- Starting from there we try to make a few more jumps redundant by reordering +-- them. +-- We depend on the information in the CFG to do so so without a given CFG +-- we do nothing. +invertCondBranches :: Maybe CFG -- ^ CFG if present + -> LabelMap a -- ^ Blocks with info tables + -> [NatBasicBlock Instr] -- ^ List of basic blocks + -> [NatBasicBlock Instr] +invertCondBranches Nothing _ bs = bs +invertCondBranches (Just cfg) keep bs = + invert bs + where + invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr] + invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs) + | --pprTrace "Block" (ppr lbl1) True, + (jmp1,jmp2) <- last2 ins + , JXX cond1 target1 <- jmp1 + , target1 == lbl2 + --, pprTrace "CutChance" (ppr b1) True + , JXX ALWAYS target2 <- jmp2 + -- We have enough information to check if we can perform the inversion + -- TODO: We could also check for the last asm instruction which sets + -- status flags instead. Which I suspect is worse in terms of compiler + -- performance, but might be applicable to more cases + , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg + , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg + -- Both jumps come from the same cmm statement + , transitionSource edgeInfo1 == transitionSource edgeInfo2 + , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1 + + --Int comparisons are invertable + , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch + , Just _ <- maybeIntComparison op + , Just invCond <- maybeInvertCond cond1 + + --Swap the last two jumps, invert the conditional jumps condition. + = let jumps = + case () of + -- We are free the eliminate the jmp. So we do so. + _ | not (mapMember target1 keep) + -> [JXX invCond target2] + -- If the conditional target is unlikely we put the other + -- target at the front. + | edgeWeight edgeInfo2 > edgeWeight edgeInfo1 + -> [JXX invCond target2, JXX ALWAYS target1] + -- Keep things as-is otherwise + | otherwise + -> [jmp1, jmp2] + in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $ + (BasicBlock lbl1 + (dropTail 2 ins ++ jumps)) + : invert (b2:bs) + invert (b:bs) = b : invert bs + invert [] = [] diff --git a/GHC/CmmToAsm/X86/Cond.hs b/GHC/CmmToAsm/X86/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Cond.hs @@ -0,0 +1,91 @@ +module GHC.CmmToAsm.X86.Cond ( + Cond(..), + condToUnsigned, + maybeFlipCond, + maybeInvertCond +) + +where + +import GHC.Prelude + +data Cond + = ALWAYS -- What's really used? ToDo + | EQQ -- je/jz -> zf = 1 + | GE -- jge + | GEU -- ae + | GTT -- jg + | GU -- ja + | LE -- jle + | LEU -- jbe + | LTT -- jl + | LU -- jb + | NE -- jne + | NEG -- js + | POS -- jns + | CARRY -- jc + | OFLO -- jo + | PARITY -- jp + | NOTPARITY -- jnp + deriving Eq + +condToUnsigned :: Cond -> Cond +condToUnsigned GTT = GU +condToUnsigned LTT = LU +condToUnsigned GE = GEU +condToUnsigned LE = LEU +condToUnsigned x = x + +-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the +-- arguments to the conditional @c@, and the new condition should be @c'@. +maybeFlipCond :: Cond -> Maybe Cond +maybeFlipCond cond = case cond of + EQQ -> Just EQQ + NE -> Just NE + LU -> Just GU + GU -> Just LU + LEU -> Just GEU + GEU -> Just LEU + LTT -> Just GTT + GTT -> Just LTT + LE -> Just GE + GE -> Just LE + _other -> Nothing + +-- | If we apply @maybeInvertCond@ to the condition of a jump we turn +-- jumps taken into jumps not taken and vice versa. +-- +-- Careful! If the used comparison and the conditional jump +-- don't match the above behaviour will NOT hold. +-- When used for FP comparisons this does not consider unordered +-- numbers. +-- Also inverting twice might return a synonym for the original condition. +maybeInvertCond :: Cond -> Maybe Cond +maybeInvertCond cond = case cond of + ALWAYS -> Nothing + EQQ -> Just NE + NE -> Just EQQ + + NEG -> Just POS + POS -> Just NEG + + GEU -> Just LU + LU -> Just GEU + + GE -> Just LTT + LTT -> Just GE + + GTT -> Just LE + LE -> Just GTT + + GU -> Just LEU + LEU -> Just GU + + --GEU "==" NOTCARRY, they are synonyms + --at the assembly level + CARRY -> Just GEU + + OFLO -> Nothing + + PARITY -> Just NOTPARITY + NOTPARITY -> Just PARITY diff --git a/GHC/CmmToAsm/X86/Instr.hs b/GHC/CmmToAsm/X86/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Instr.hs @@ -0,0 +1,1061 @@ +{-# LANGUAGE CPP, TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- + +module GHC.CmmToAsm.X86.Instr + ( Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..) + , getJumpDestBlockId, canShortcut, shortcutStatics + , shortcutJump, allocMoreStack + , maxSpillSlots, archWordFormat + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.CmmToAsm.X86.Cond +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Format +import GHC.Platform.Reg.Class +import GHC.Platform.Reg +import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config + +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Platform.Regs +import GHC.Cmm +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Platform + +import GHC.Types.Basic (Alignment) +import GHC.Cmm.CLabel +import GHC.Types.Unique.Set +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import GHC.Cmm.DebugBlock (UnwindTable) + +import Control.Monad +import Data.Maybe (fromMaybe) + +-- Format of an x86/x86_64 memory address, in bytes. +-- +archWordFormat :: Bool -> Format +archWordFormat is32Bit + | is32Bit = II32 + | otherwise = II64 + +-- | Instruction instance for x86 instruction set. +instance Instruction Instr where + regUsageOfInstr = x86_regUsageOfInstr + patchRegsOfInstr = x86_patchRegsOfInstr + isJumpishInstr = x86_isJumpishInstr + jumpDestsOfInstr = x86_jumpDestsOfInstr + patchJumpInstr = x86_patchJumpInstr + mkSpillInstr = x86_mkSpillInstr + mkLoadInstr = x86_mkLoadInstr + takeDeltaInstr = x86_takeDeltaInstr + isMetaInstr = x86_isMetaInstr + mkRegRegMoveInstr = x86_mkRegRegMoveInstr + takeRegRegMoveInstr = x86_takeRegRegMoveInstr + mkJumpInstr = x86_mkJumpInstr + mkStackAllocInstr = x86_mkStackAllocInstr + mkStackDeallocInstr = x86_mkStackDeallocInstr + + +-- ----------------------------------------------------------------------------- +-- Intel x86 instructions + +{- +Intel, in their infinite wisdom, selected a stack model for floating +point registers on x86. That might have made sense back in 1979 -- +nowadays we can see it for the nonsense it really is. A stack model +fits poorly with the existing nativeGen infrastructure, which assumes +flat integer and FP register sets. Prior to this commit, nativeGen +could not generate correct x86 FP code -- to do so would have meant +somehow working the register-stack paradigm into the register +allocator and spiller, which sounds very difficult. + +We have decided to cheat, and go for a simple fix which requires no +infrastructure modifications, at the expense of generating ropey but +correct FP code. All notions of the x86 FP stack and its insns have +been removed. Instead, we pretend (to the instruction selector and +register allocator) that x86 has six floating point registers, %fake0 +.. %fake5, which can be used in the usual flat manner. We further +claim that x86 has floating point instructions very similar to SPARC +and Alpha, that is, a simple 3-operand register-register arrangement. +Code generation and register allocation proceed on this basis. + +When we come to print out the final assembly, our convenient fiction +is converted to dismal reality. Each fake instruction is +independently converted to a series of real x86 instructions. +%fake0 .. %fake5 are mapped to %st(0) .. %st(5). To do reg-reg +arithmetic operations, the two operands are pushed onto the top of the +FP stack, the operation done, and the result copied back into the +relevant register. There are only six %fake registers because 2 are +needed for the translation, and x86 has 8 in total. + +The translation is inefficient but is simple and it works. A cleverer +translation would handle a sequence of insns, simulating the FP stack +contents, would not impose a fixed mapping from %fake to %st regs, and +hopefully could avoid most of the redundant reg-reg moves of the +current translation. + +We might as well make use of whatever unique FP facilities Intel have +chosen to bless us with (let's not be churlish, after all). +Hence GLDZ and GLD1. Bwahahahahahahaha! +-} + +{- +Note [x86 Floating point precision] + +Intel's internal floating point registers are by default 80 bit +extended precision. This means that all operations done on values in +registers are done at 80 bits, and unless the intermediate values are +truncated to the appropriate size (32 or 64 bits) by storing in +memory, calculations in registers will give different results from +calculations which pass intermediate values in memory (eg. via +function calls). + +One solution is to set the FPU into 64 bit precision mode. Some OSs +do this (eg. FreeBSD) and some don't (eg. Linux). The problem here is +that this will only affect 64-bit precision arithmetic; 32-bit +calculations will still be done at 64-bit precision in registers. So +it doesn't solve the whole problem. + +There's also the issue of what the C library is expecting in terms of +precision. It seems to be the case that glibc on Linux expects the +FPU to be set to 80 bit precision, so setting it to 64 bit could have +unexpected effects. Changing the default could have undesirable +effects on other 3rd-party library code too, so the right thing would +be to save/restore the FPU control word across Haskell code if we were +to do this. + +gcc's -ffloat-store gives consistent results by always storing the +results of floating-point calculations in memory, which works for both +32 and 64-bit precision. However, it only affects the values of +user-declared floating point variables in C, not intermediate results. +GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision +flag). + +Another problem is how to spill floating point registers in the +register allocator. Should we spill the whole 80 bits, or just 64? +On an OS which is set to 64 bit precision, spilling 64 is fine. On +Linux, spilling 64 bits will round the results of some operations. +This is what gcc does. Spilling at 80 bits requires taking up a full +128 bit slot (so we get alignment). We spill at 80-bits and ignore +the alignment problems. + +In the future [edit: now available in GHC 7.0.1, with the -msse2 +flag], we'll use the SSE registers for floating point. This requires +a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision +float ops), which means P4 or Xeon and above. Using SSE will solve +all these problems, because the SSE registers use fixed 32 bit or 64 +bit precision. + +--SDM 1/2003 +-} + +data Instr + -- comment pseudo-op + = COMMENT FastString + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + + -- some static data spat out during code + -- generation. Will be extracted before + -- pretty-printing. + | LDATA Section (Alignment, RawCmmStatics) + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- unwinding information + -- See Note [Unwinding information in the NCG]. + | UNWIND CLabel UnwindTable + + -- specify current stack offset for benefit of subsequent passes. + -- This carries a BlockId so it can be used in unwinding information. + | DELTA Int + + -- Moves. + | MOV Format Operand Operand + | CMOV Cond Format Operand Reg + | MOVZxL Format Operand Operand -- format is the size of operand 1 + | MOVSxL Format Operand Operand -- format is the size of operand 1 + -- x86_64 note: plain mov into a 32-bit register always zero-extends + -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which + -- don't affect the high bits of the register. + + -- Load effective address (also a very useful three-operand add instruction :-) + | LEA Format Operand Operand + + -- Int Arithmetic. + | ADD Format Operand Operand + | ADC Format Operand Operand + | SUB Format Operand Operand + | SBB Format Operand Operand + + | MUL Format Operand Operand + | MUL2 Format Operand -- %edx:%eax = operand * %rax + | IMUL Format Operand Operand -- signed int mul + | IMUL2 Format Operand -- %edx:%eax = operand * %eax + + | DIV Format Operand -- eax := eax:edx/op, edx := eax:edx%op + | IDIV Format Operand -- ditto, but signed + + -- Int Arithmetic, where the effects on the condition register + -- are important. Used in specialized sequences such as MO_Add2. + -- Do not rewrite these instructions to "equivalent" ones that + -- have different effect on the condition register! (See #9013.) + | ADD_CC Format Operand Operand + | SUB_CC Format Operand Operand + + -- Simple bit-twiddling. + | AND Format Operand Operand + | OR Format Operand Operand + | XOR Format Operand Operand + | NOT Format Operand + | NEGI Format Operand -- NEG instruction (name clash with Cond) + | BSWAP Format Reg + + -- Shifts (amount may be immediate or %cl only) + | SHL Format Operand{-amount-} Operand + | SAR Format Operand{-amount-} Operand + | SHR Format Operand{-amount-} Operand + + | BT Format Imm Operand + | NOP + + + -- We need to support the FSTP (x87 store and pop) instruction + -- so that we can correctly read off the return value of an + -- x86 CDECL C function call when its floating point. + -- so we dont include a register argument, and just use st(0) + -- this instruction is used ONLY for return values of C ffi calls + -- in x86_32 abi + | X87Store Format AddrMode -- st(0), dst + + + -- SSE2 floating point: we use a restricted set of the available SSE2 + -- instructions for floating-point. + -- use MOV for moving (either movss or movsd (movlpd better?)) + | CVTSS2SD Reg Reg -- F32 to F64 + | CVTSD2SS Reg Reg -- F64 to F32 + | CVTTSS2SIQ Format Operand Reg -- F32 to I32/I64 (with truncation) + | CVTTSD2SIQ Format Operand Reg -- F64 to I32/I64 (with truncation) + | CVTSI2SS Format Operand Reg -- I32/I64 to F32 + | CVTSI2SD Format Operand Reg -- I32/I64 to F64 + + -- use ADD, SUB, and SQRT for arithmetic. In both cases, operands + -- are Operand Reg. + + -- SSE2 floating-point division: + | FDIV Format Operand Operand -- divisor, dividend(dst) + + -- use CMP for comparisons. ucomiss and ucomisd instructions + -- compare single/double prec floating point respectively. + + | SQRT Format Operand Reg -- src, dst + + + -- Comparison + | TEST Format Operand Operand + | CMP Format Operand Operand + | SETCC Cond Operand + + -- Stack Operations. + | PUSH Format Operand + | POP Format Operand + -- both unused (SDM): + -- | PUSHA + -- | POPA + + -- Jumping around. + | JMP Operand [Reg] -- including live Regs at the call + | JXX Cond BlockId -- includes unconditional branches + | JXX_GBL Cond Imm -- non-local version of JXX + -- Table jump + | JMP_TBL Operand -- Address to jump to + [Maybe JumpDest] -- Targets of the jump table + Section -- Data section jump table should be put in + CLabel -- Label of jump table + -- | X86 call instruction + | CALL (Either Imm Reg) -- ^ Jump target + [Reg] -- ^ Arguments (required for register allocation) + + -- Other things. + | CLTD Format -- sign extend %eax into %edx:%eax + + | FETCHGOT Reg -- pseudo-insn for ELF position-independent code + -- pretty-prints as + -- call 1f + -- 1: popl %reg + -- addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg + | FETCHPC Reg -- pseudo-insn for Darwin position-independent code + -- pretty-prints as + -- call 1f + -- 1: popl %reg + + -- bit counting instructions + | POPCNT Format Operand Reg -- [SSE4.2] count number of bits set to 1 + | LZCNT Format Operand Reg -- [BMI2] count number of leading zeros + | TZCNT Format Operand Reg -- [BMI2] count number of trailing zeros + | BSF Format Operand Reg -- bit scan forward + | BSR Format Operand Reg -- bit scan reverse + + -- bit manipulation instructions + | PDEP Format Operand Operand Reg -- [BMI2] deposit bits to the specified mask + | PEXT Format Operand Operand Reg -- [BMI2] extract bits from the specified mask + + -- prefetch + | PREFETCH PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch + -- variant can be NTA, Lvl0, Lvl1, or Lvl2 + + | LOCK Instr -- lock prefix + | XADD Format Operand Operand -- src (r), dst (r/m) + | CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit + | XCHG Format Operand Reg -- src (r/m), dst (r/m) + | MFENCE + +data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 + + +data Operand + = OpReg Reg -- register + | OpImm Imm -- immediate value + | OpAddr AddrMode -- memory reference + + + +-- | Returns which registers are read and written as a (read, written) +-- pair. +x86_regUsageOfInstr :: Platform -> Instr -> RegUsage +x86_regUsageOfInstr platform instr + = case instr of + MOV _ src dst -> usageRW src dst + CMOV _ _ src dst -> mkRU (use_R src [dst]) [dst] + MOVZxL _ src dst -> usageRW src dst + MOVSxL _ src dst -> usageRW src dst + LEA _ src dst -> usageRW src dst + ADD _ src dst -> usageRM src dst + ADC _ src dst -> usageRM src dst + SUB _ src dst -> usageRM src dst + SBB _ src dst -> usageRM src dst + IMUL _ src dst -> usageRM src dst + + -- Result of IMULB will be in just in %ax + IMUL2 II8 src -> mkRU (eax:use_R src []) [eax] + -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and + -- %ax/%eax/%rax. + IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] + + MUL _ src dst -> usageRM src dst + MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] + DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] + IDIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] + ADD_CC _ src dst -> usageRM src dst + SUB_CC _ src dst -> usageRM src dst + AND _ src dst -> usageRM src dst + OR _ src dst -> usageRM src dst + + XOR _ (OpReg src) (OpReg dst) + | src == dst -> mkRU [] [dst] + + XOR _ src dst -> usageRM src dst + NOT _ op -> usageM op + BSWAP _ reg -> mkRU [reg] [reg] + NEGI _ op -> usageM op + SHL _ imm dst -> usageRM imm dst + SAR _ imm dst -> usageRM imm dst + SHR _ imm dst -> usageRM imm dst + BT _ _ src -> mkRUR (use_R src []) + + PUSH _ op -> mkRUR (use_R op []) + POP _ op -> mkRU [] (def_W op) + TEST _ src dst -> mkRUR (use_R src $! use_R dst []) + CMP _ src dst -> mkRUR (use_R src $! use_R dst []) + SETCC _ op -> mkRU [] (def_W op) + JXX _ _ -> mkRU [] [] + JXX_GBL _ _ -> mkRU [] [] + JMP op regs -> mkRUR (use_R op regs) + JMP_TBL op _ _ _ -> mkRUR (use_R op []) + CALL (Left _) params -> mkRU params (callClobberedRegs platform) + CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform) + CLTD _ -> mkRU [eax] [edx] + NOP -> mkRU [] [] + + X87Store _ dst -> mkRUR ( use_EA dst []) + + CVTSS2SD src dst -> mkRU [src] [dst] + CVTSD2SS src dst -> mkRU [src] [dst] + CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst] + CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst] + CVTSI2SS _ src dst -> mkRU (use_R src []) [dst] + CVTSI2SD _ src dst -> mkRU (use_R src []) [dst] + FDIV _ src dst -> usageRM src dst + SQRT _ src dst -> mkRU (use_R src []) [dst] + + FETCHGOT reg -> mkRU [] [reg] + FETCHPC reg -> mkRU [] [reg] + + COMMENT _ -> noUsage + LOCATION{} -> noUsage + UNWIND{} -> noUsage + DELTA _ -> noUsage + + POPCNT _ src dst -> mkRU (use_R src []) [dst] + LZCNT _ src dst -> mkRU (use_R src []) [dst] + TZCNT _ src dst -> mkRU (use_R src []) [dst] + BSF _ src dst -> mkRU (use_R src []) [dst] + BSR _ src dst -> mkRU (use_R src []) [dst] + + PDEP _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] + PEXT _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] + + -- note: might be a better way to do this + PREFETCH _ _ src -> mkRU (use_R src []) [] + LOCK i -> x86_regUsageOfInstr platform i + XADD _ src dst -> usageMM src dst + CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) + XCHG _ src dst -> usageMM src (OpReg dst) + MFENCE -> noUsage + + _other -> panic "regUsage: unrecognised instr" + where + -- # Definitions + -- + -- Written: If the operand is a register, it's written. If it's an + -- address, registers mentioned in the address are read. + -- + -- Modified: If the operand is a register, it's both read and + -- written. If it's an address, registers mentioned in the address + -- are read. + + -- 2 operand form; first operand Read; second Written + usageRW :: Operand -> Operand -> RegUsage + usageRW op (OpReg reg) = mkRU (use_R op []) [reg] + usageRW op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) + usageRW _ _ = panic "X86.RegInfo.usageRW: no match" + + -- 2 operand form; first operand Read; second Modified + usageRM :: Operand -> Operand -> RegUsage + usageRM op (OpReg reg) = mkRU (use_R op [reg]) [reg] + usageRM op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) + usageRM _ _ = panic "X86.RegInfo.usageRM: no match" + + -- 2 operand form; first operand Modified; second Modified + usageMM :: Operand -> Operand -> RegUsage + usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] + usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src] + usageMM (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [dst]) [dst] + usageMM _ _ = panic "X86.RegInfo.usageMM: no match" + + -- 3 operand form; first operand Read; second Modified; third Modified + usageRMM :: Operand -> Operand -> Operand -> RegUsage + usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg] + usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] + usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" + + -- 1 operand form; operand Modified + usageM :: Operand -> RegUsage + usageM (OpReg reg) = mkRU [reg] [reg] + usageM (OpAddr ea) = mkRUR (use_EA ea []) + usageM _ = panic "X86.RegInfo.usageM: no match" + + -- Registers defd when an operand is written. + def_W (OpReg reg) = [reg] + def_W (OpAddr _ ) = [] + def_W _ = panic "X86.RegInfo.def_W: no match" + + -- Registers used when an operand is read. + use_R (OpReg reg) tl = reg : tl + use_R (OpImm _) tl = tl + use_R (OpAddr ea) tl = use_EA ea tl + + -- Registers used to compute an effective address. + use_EA (ImmAddr _ _) tl = tl + use_EA (AddrBaseIndex base index _) tl = + use_base base $! use_index index tl + where use_base (EABaseReg r) tl = r : tl + use_base _ tl = tl + use_index EAIndexNone tl = tl + use_index (EAIndex i _) tl = i : tl + + mkRUR src = src' `seq` RU src' [] + where src' = filter (interesting platform) src + + mkRU src dst = src' `seq` dst' `seq` RU src' dst' + where src' = filter (interesting platform) src + dst' = filter (interesting platform) dst + +-- | Is this register interesting for the register allocator? +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) = freeReg platform i +interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" + + + +-- | Applies the supplied function to all registers in instructions. +-- Typically used to change virtual registers to real registers. +x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +x86_patchRegsOfInstr instr env + = case instr of + MOV fmt src dst -> patch2 (MOV fmt) src dst + CMOV cc fmt src dst -> CMOV cc fmt (patchOp src) (env dst) + MOVZxL fmt src dst -> patch2 (MOVZxL fmt) src dst + MOVSxL fmt src dst -> patch2 (MOVSxL fmt) src dst + LEA fmt src dst -> patch2 (LEA fmt) src dst + ADD fmt src dst -> patch2 (ADD fmt) src dst + ADC fmt src dst -> patch2 (ADC fmt) src dst + SUB fmt src dst -> patch2 (SUB fmt) src dst + SBB fmt src dst -> patch2 (SBB fmt) src dst + IMUL fmt src dst -> patch2 (IMUL fmt) src dst + IMUL2 fmt src -> patch1 (IMUL2 fmt) src + MUL fmt src dst -> patch2 (MUL fmt) src dst + MUL2 fmt src -> patch1 (MUL2 fmt) src + IDIV fmt op -> patch1 (IDIV fmt) op + DIV fmt op -> patch1 (DIV fmt) op + ADD_CC fmt src dst -> patch2 (ADD_CC fmt) src dst + SUB_CC fmt src dst -> patch2 (SUB_CC fmt) src dst + AND fmt src dst -> patch2 (AND fmt) src dst + OR fmt src dst -> patch2 (OR fmt) src dst + XOR fmt src dst -> patch2 (XOR fmt) src dst + NOT fmt op -> patch1 (NOT fmt) op + BSWAP fmt reg -> BSWAP fmt (env reg) + NEGI fmt op -> patch1 (NEGI fmt) op + SHL fmt imm dst -> patch1 (SHL fmt imm) dst + SAR fmt imm dst -> patch1 (SAR fmt imm) dst + SHR fmt imm dst -> patch1 (SHR fmt imm) dst + BT fmt imm src -> patch1 (BT fmt imm) src + TEST fmt src dst -> patch2 (TEST fmt) src dst + CMP fmt src dst -> patch2 (CMP fmt) src dst + PUSH fmt op -> patch1 (PUSH fmt) op + POP fmt op -> patch1 (POP fmt) op + SETCC cond op -> patch1 (SETCC cond) op + JMP op regs -> JMP (patchOp op) regs + JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl + + -- literally only support storing the top x87 stack value st(0) + X87Store fmt dst -> X87Store fmt (lookupAddr dst) + + CVTSS2SD src dst -> CVTSS2SD (env src) (env dst) + CVTSD2SS src dst -> CVTSD2SS (env src) (env dst) + CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst) + CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst) + CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst) + CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst) + FDIV fmt src dst -> FDIV fmt (patchOp src) (patchOp dst) + SQRT fmt src dst -> SQRT fmt (patchOp src) (env dst) + + CALL (Left _) _ -> instr + CALL (Right reg) p -> CALL (Right (env reg)) p + + FETCHGOT reg -> FETCHGOT (env reg) + FETCHPC reg -> FETCHPC (env reg) + + NOP -> instr + COMMENT _ -> instr + LOCATION {} -> instr + UNWIND {} -> instr + DELTA _ -> instr + + JXX _ _ -> instr + JXX_GBL _ _ -> instr + CLTD _ -> instr + + POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst) + LZCNT fmt src dst -> LZCNT fmt (patchOp src) (env dst) + TZCNT fmt src dst -> TZCNT fmt (patchOp src) (env dst) + PDEP fmt src mask dst -> PDEP fmt (patchOp src) (patchOp mask) (env dst) + PEXT fmt src mask dst -> PEXT fmt (patchOp src) (patchOp mask) (env dst) + BSF fmt src dst -> BSF fmt (patchOp src) (env dst) + BSR fmt src dst -> BSR fmt (patchOp src) (env dst) + + PREFETCH lvl format src -> PREFETCH lvl format (patchOp src) + + LOCK i -> LOCK (x86_patchRegsOfInstr i env) + XADD fmt src dst -> patch2 (XADD fmt) src dst + CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst + XCHG fmt src dst -> XCHG fmt (patchOp src) (env dst) + MFENCE -> instr + + _other -> panic "patchRegs: unrecognised instr" + + where + patch1 :: (Operand -> a) -> Operand -> a + patch1 insn op = insn $! patchOp op + patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a + patch2 insn src dst = (insn $! patchOp src) $! patchOp dst + + patchOp (OpReg reg) = OpReg $! env reg + patchOp (OpImm imm) = OpImm imm + patchOp (OpAddr ea) = OpAddr $! lookupAddr ea + + lookupAddr (ImmAddr imm off) = ImmAddr imm off + lookupAddr (AddrBaseIndex base index disp) + = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp + where + lookupBase EABaseNone = EABaseNone + lookupBase EABaseRip = EABaseRip + lookupBase (EABaseReg r) = EABaseReg $! env r + + lookupIndex EAIndexNone = EAIndexNone + lookupIndex (EAIndex r i) = (EAIndex $! env r) i + + +-------------------------------------------------------------------------------- +x86_isJumpishInstr + :: Instr -> Bool + +x86_isJumpishInstr instr + = case instr of + JMP{} -> True + JXX{} -> True + JXX_GBL{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False + + +x86_jumpDestsOfInstr + :: Instr + -> [BlockId] + +x86_jumpDestsOfInstr insn + = case insn of + JXX _ id -> [id] + JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids] + _ -> [] + + +x86_patchJumpInstr + :: Instr -> (BlockId -> BlockId) -> Instr + +x86_patchJumpInstr insn patchF + = case insn of + JXX cc id -> JXX cc (patchF id) + JMP_TBL op ids section lbl + -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl + _ -> insn + where + patchJumpDest f (DestBlockId id) = DestBlockId (f id) + patchJumpDest _ dest = dest + + + + + +-- ----------------------------------------------------------------------------- +-- | Make a spill instruction. +x86_mkSpillInstr + :: NCGConfig + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +x86_mkSpillInstr config reg delta slot + = let off = spillSlotToOffset platform slot - delta + in + case targetClassOfReg platform reg of + RcInteger -> MOV (archWordFormat is32Bit) + (OpReg reg) (OpAddr (spRel platform off)) + RcDouble -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off)) + _ -> panic "X86.mkSpillInstr: no match" + where platform = ncgPlatform config + is32Bit = target32Bit platform + +-- | Make a spill reload instruction. +x86_mkLoadInstr + :: NCGConfig + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +x86_mkLoadInstr config reg delta slot + = let off = spillSlotToOffset platform slot - delta + in + case targetClassOfReg platform reg of + RcInteger -> MOV (archWordFormat is32Bit) + (OpAddr (spRel platform off)) (OpReg reg) + RcDouble -> MOV FF64 (OpAddr (spRel platform off)) (OpReg reg) + _ -> panic "X86.x86_mkLoadInstr" + where platform = ncgPlatform config + is32Bit = target32Bit platform + +spillSlotSize :: Platform -> Int +spillSlotSize platform + | target32Bit platform = 12 + | otherwise = 8 + +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config + = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize (ncgPlatform config)) - 1 +-- = 0 -- useful for testing allocMoreStack + +-- number of bytes that the stack pointer should be aligned to +stackAlign :: Int +stackAlign = 16 + +-- convert a spill slot number to a *byte* offset, with no sign: +-- decide on a per arch basis whether you are spilling above or below +-- the C stack pointer. +spillSlotToOffset :: Platform -> Int -> Int +spillSlotToOffset platform slot + = 64 + spillSlotSize platform * slot + +-------------------------------------------------------------------------------- + +-- | See if this instruction is telling us the current C stack delta +x86_takeDeltaInstr + :: Instr + -> Maybe Int + +x86_takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +x86_isMetaInstr + :: Instr + -> Bool + +x86_isMetaInstr instr + = case instr of + COMMENT{} -> True + LOCATION{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + UNWIND{} -> True + DELTA{} -> True + _ -> False + + + +--- TODO: why is there +-- | Make a reg-reg move instruction. +-- On SPARC v8 there are no instructions to move directly between +-- floating point and integer regs. If we need to do that then we +-- have to go via memory. +-- +x86_mkRegRegMoveInstr + :: Platform + -> Reg + -> Reg + -> Instr + +x86_mkRegRegMoveInstr platform src dst + = case targetClassOfReg platform src of + RcInteger -> case platformArch platform of + ArchX86 -> MOV II32 (OpReg src) (OpReg dst) + ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst) + _ -> panic "x86_mkRegRegMoveInstr: Bad arch" + RcDouble -> MOV FF64 (OpReg src) (OpReg dst) + -- this code is the lie we tell ourselves because both float and double + -- use the same register class.on x86_64 and x86 32bit with SSE2, + -- more plainly, both use the XMM registers + _ -> panic "X86.RegInfo.mkRegRegMoveInstr: no match" + +-- | Check whether an instruction represents a reg-reg move. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. +-- +x86_takeRegRegMoveInstr + :: Instr + -> Maybe (Reg,Reg) + +x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2)) + = Just (r1,r2) + +x86_takeRegRegMoveInstr _ = Nothing + + +-- | Make an unconditional branch instruction. +x86_mkJumpInstr + :: BlockId + -> [Instr] + +x86_mkJumpInstr id + = [JXX ALWAYS id] + +-- Note [Windows stack layout] +-- | On most OSes the kernel will place a guard page after the current stack +-- page. If you allocate larger than a page worth you may jump over this +-- guard page. Not only is this a security issue, but on certain OSes such +-- as Windows a new page won't be allocated if you don't hit the guard. This +-- will cause a segfault or access fault. +-- +-- This function defines if the current allocation amount requires a probe. +-- On Windows (for now) we emit a call to _chkstk for this. For other OSes +-- this is not yet implemented. +-- See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk +-- The Windows stack looks like this: +-- +-- +-------------------+ +-- | SP | +-- +-------------------+ +-- | | +-- | GUARD PAGE | +-- | | +-- +-------------------+ +-- | | +-- | | +-- | UNMAPPED | +-- | | +-- | | +-- +-------------------+ +-- +-- In essence each allocation larger than a page size needs to be chunked and +-- a probe emitted after each page allocation. You have to hit the guard +-- page so the kernel can map in the next page, otherwise you'll segfault. +-- +needs_probe_call :: Platform -> Int -> Bool +needs_probe_call platform amount + = case platformOS platform of + OSMinGW32 -> case platformArch platform of + ArchX86 -> amount > (4 * 1024) + ArchX86_64 -> amount > (8 * 1024) + _ -> False + _ -> False + +x86_mkStackAllocInstr + :: Platform + -> Int + -> [Instr] +x86_mkStackAllocInstr platform amount + = case platformOS platform of + OSMinGW32 -> + -- These will clobber AX but this should be ok because + -- + -- 1. It is the first thing we do when entering the closure and AX is + -- a caller saved registers on Windows both on x86_64 and x86. + -- + -- 2. The closures are only entered via a call or longjmp in which case + -- there are no expectations for volatile registers. + -- + -- 3. When the target is a local branch point it is re-targeted + -- after the dealloc, preserving #2. See note [extra spill slots]. + -- + -- We emit a call because the stack probes are quite involved and + -- would bloat code size a lot. GHC doesn't really have an -Os. + -- __chkstk is guaranteed to leave all nonvolatile registers and AX + -- untouched. It's part of the standard prologue code for any Windows + -- function dropping the stack more than a page. + -- See Note [Windows stack layout] + case platformArch platform of + ArchX86 | needs_probe_call platform amount -> + [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax) + , CALL (Left $ strImmLit "___chkstk_ms") [eax] + , SUB II32 (OpReg eax) (OpReg esp) + ] + | otherwise -> + [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) + , TEST II32 (OpReg esp) (OpReg esp) + ] + ArchX86_64 | needs_probe_call platform amount -> + [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax) + , CALL (Left $ strImmLit "___chkstk_ms") [rax] + , SUB II64 (OpReg rax) (OpReg rsp) + ] + | otherwise -> + [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) + , TEST II64 (OpReg rsp) (OpReg rsp) + ] + _ -> panic "x86_mkStackAllocInstr" + _ -> + case platformArch platform of + ArchX86 -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ] + ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ] + _ -> panic "x86_mkStackAllocInstr" + +x86_mkStackDeallocInstr + :: Platform + -> Int + -> [Instr] +x86_mkStackDeallocInstr platform amount + = case platformArch platform of + ArchX86 -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)] + ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)] + _ -> panic "x86_mkStackDeallocInstr" + + +-- +-- Note [extra spill slots] +-- +-- If the register allocator used more spill slots than we have +-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more +-- C stack space on entry and exit from this proc. Therefore we +-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp" +-- before every non-local jump. +-- +-- This became necessary when the new codegen started bundling entire +-- functions together into one proc, because the register allocator +-- assigns a different stack slot to each virtual reg within a proc. +-- To avoid using so many slots we could also: +-- +-- - split up the proc into connected components before code generator +-- +-- - rename the virtual regs, so that we re-use vreg names and hence +-- stack slots for non-overlapping vregs. +-- +-- Note that when a block is both a non-local entry point (with an +-- info table) and a local branch target, we have to split it into +-- two, like so: +-- +-- +-- L: +-- +-- +-- becomes +-- +-- +-- L: +-- subl $rsp, N +-- jmp Lnew +-- Lnew: +-- +-- +-- and all branches pointing to L are retargetted to point to Lnew. +-- Otherwise, we would repeat the $rsp adjustment for each branch to +-- L. +-- +-- Returns a list of (L,Lnew) pairs. +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr + -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + uniqs <- replicateM (length entries) getUniqueM + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize platform -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + retargetList = (zip entries (map mkBlockId uniqs)) + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insns (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid] + , BasicBlock new_blockid block' ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + JMP _ _ -> dealloc ++ (insn : r) + JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL" + _other -> x86_patchJumpInstr insn retarget : r + where retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insns code + -- in + return (CmmProc info lbl live (ListGraph new_code), retargetList) + +data JumpDest = DestBlockId BlockId | DestImm Imm + +-- Debug Instance +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + ppr (DestImm _imm) = text "jd:noShow" + + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing + +canShortcut :: Instr -> Maybe JumpDest +canShortcut (JXX ALWAYS id) = Just (DestBlockId id) +canShortcut (JMP (OpImm imm) _) = Just (DestImm imm) +canShortcut _ = Nothing + + +-- This helper shortcuts a sequence of branches. +-- The blockset helps avoid following cycles. +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn + where + shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr + shortcutJump' fn seen insn@(JXX cc id) = + if setMember id seen then insn + else case fn id of + Nothing -> insn + Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') + Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) + where seen' = setInsert id seen + shortcutJump' fn _ (JMP_TBL addr blocks section tblId) = + let updateBlock (Just (DestBlockId bid)) = + case fn bid of + Nothing -> Just (DestBlockId bid ) + Just dest -> Just dest + updateBlock dest = dest + blocks' = map updateBlock blocks + in JMP_TBL addr blocks' section tblId + shortcutJump' _ _ other = other + +-- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics) +shortcutStatics fn (align, CmmStaticsRaw lbl statics) + = (align, CmmStaticsRaw lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) + -- slightly dodgy, we're ignoring the second label, but this + -- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> UniqSet Unique + -> BlockId + -> CLabel + +shortBlockId fn seen blockid = + case (elementOfUniqSet uq seen, fn blockid) of + (True, _) -> blockLbl blockid + (_, Nothing) -> blockLbl blockid + (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' + (_, Just (DestImm (ImmCLbl lbl))) -> lbl + (_, _other) -> panic "shortBlockId" + where uq = getUnique blockid diff --git a/GHC/CmmToAsm/X86/Ppr.hs b/GHC/CmmToAsm/X86/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Ppr.hs @@ -0,0 +1,1091 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.CmmToAsm.X86.Ppr ( + pprNatCmmDecl, + pprData, + pprInstr, + pprFormat, + pprImm, + pprDataItem, +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.X86.Instr +import GHC.CmmToAsm.X86.Cond +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.Platform.Reg +import GHC.CmmToAsm.Ppr + + +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) +import GHC.Driver.Session +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Types.Unique ( pprUniqueAlways ) +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Outputable + +import Data.Word +import Data.Bits + +-- ----------------------------------------------------------------------------- +-- Printing this stuff out +-- +-- +-- Note [Subsections Via Symbols] +-- +-- If we are using the .subsections_via_symbols directive +-- (available on recent versions of Darwin), +-- we have to make sure that there is some kind of reference +-- from the entry code to a label on the _top_ of the info table, +-- so that the linker will not think it is unreferenced and dead-strip +-- it. That's why the label is called a DeadStripPreventer (_dsp). +-- +-- The LLVM code gen already creates `iTableSuf` symbols, where +-- the X86 would generate the DeadStripPreventer (_dsp) symbol. +-- Therefore all that is left for llvm code gen, is to ensure +-- that all the `iTableSuf` symbols are marked as used. +-- As of this writing the documentation regarding the +-- .subsections_via_symbols and -dead_strip can be found at +-- + +pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) + where + platform = ncgPlatform config + +pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section $$ pprDatas config dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in + pprProcAlignment config $$ + case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) $$ + pprProcAlignment config $$ + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock config top_info) blocks) $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + pprSizeDecl platform lbl + + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) $$ + pprProcAlignment config $$ + (if platformHasSubsectionsViaSymbols platform + then ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock config top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then -- See Note [Subsections Via Symbols] + text "\t.long " + <+> ppr info_lbl + <+> char '-' + <+> ppr (mkDeadStripPreventer info_lbl) + else empty) $$ + pprSizeDecl platform info_lbl + +-- | Output the ELF .size directive. +pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) + then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl + else empty + +pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock config info_env (BasicBlock blockid instrs) + = maybe_infotable $ + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) instrs) $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + else empty + ) + where + asmLbl = blockLbl blockid + platform = ncgPlatform config + maybe_infotable c = case mapLookup blockid info_env of + Nothing -> c + Just (CmmStaticsRaw infoLbl info) -> + pprAlignForSection platform Text $$ + infoTableLoc $$ + vcat (map (pprData config) info) $$ + pprLabel platform infoLbl $$ + c $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel infoLbl) <> char ':' + else empty + ) + -- Make sure the info table has the right .loc for the block + -- coming right after it. See [Note: Info Offset] + infoTableLoc = case instrs of + (l@LOCATION{} : _) -> pprInstr platform l + _other -> empty + + +pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc +-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas _config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl alias + $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') + +pprDatas config (align, (CmmStaticsRaw lbl dats)) + = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) + where + platform = ncgPlatform config + +pprData :: NCGConfig -> CmmStatic -> SDoc +pprData _config (CmmString str) = pprString str +pprData _config (CmmFileEmbed path) = pprFileEmbed path + +pprData config (CmmUninitialised bytes) + = let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes + +pprData config (CmmStaticLit lit) = pprDataItem config lit + +pprGloblDecl :: CLabel -> SDoc +pprGloblDecl lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = text ".globl " <> ppr lbl + +pprLabelType' :: Platform -> CLabel -> SDoc +pprLabelType' platform lbl = + if isCFunctionLabel lbl || functionOkInfoTable then + text "@function" + else + text "@object" + where + {- + NOTE: This is a bit hacky. + + With the `tablesNextToCode` info tables look like this: + ``` + + label_info: + + ``` + So actually info table label points exactly to the code and we can mark + the label as @function. (This is required to make perf and potentially other + tools to work on Haskell binaries). + This usually works well but it can cause issues with a linker. + A linker uses different algorithms for the relocation depending on + the symbol type.For some reason, a linker will generate JUMP_SLOT relocation + when constructor info table is referenced from a data section. + This only happens with static constructor call so + we mark _con_info symbols as `@object` to avoid the issue with relocations. + + @SimonMarlow hack explanation: + "The reasoning goes like this: + + * The danger when we mark a symbol as `@function` is that the linker will + redirect it to point to the PLT and use a `JUMP_SLOT` relocation when + the symbol refers to something outside the current shared object. + A PLT / JUMP_SLOT reference only works for symbols that we jump to, not + for symbols representing data,, nor for info table symbol references which + we expect to point directly to the info table. + * GHC generates code that might refer to any info table symbol from the text + segment, but that's OK, because those will be explicit GOT references + generated by the code generator. + * When we refer to info tables from the data segment, it's either + * a FUN_STATIC/THUNK_STATIC local to this module + * a `con_info` that could be from anywhere + + So, the only info table symbols that we might refer to from the data segment + of another shared object are `con_info` symbols, so those are the ones we + need to exclude from getting the @function treatment. + " + + A good place to check for more + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code + + Another possible hack is to create an extra local function symbol for + every code-like thing to give the needed information for to the tools + but mess up with the relocation. https://phabricator.haskell.org/D4730 + -} + functionOkInfoTable = platformTablesNextToCode platform && + isInfoTableLabel lbl && not (isConInfoTableLabel lbl) + + +pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl platform lbl + = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl + else empty + +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = + pprGloblDecl lbl + $$ pprTypeDecl platform lbl + $$ (ppr lbl <> char ':') + +pprAlign :: Platform -> Alignment -> SDoc +pprAlign platform alignment + = text ".align " <> int (alignmentOn platform) + where + bytes = alignmentBytes alignment + alignmentOn platform = if platformOS platform == OSDarwin + then log2 bytes + else bytes + + log2 :: Int -> Int -- cache the common ones + log2 1 = 0 + log2 2 = 1 + log2 4 = 2 + log2 8 = 3 + log2 n = 1 + log2 (n `quot` 2) + +instance Outputable Instr where + ppr instr = sdocWithDynFlags $ \dflags -> + pprInstr (targetPlatform dflags) instr + + +pprReg :: Platform -> Format -> Reg -> SDoc +pprReg platform f r + = case r of + RegReal (RealRegSingle i) -> + if target32Bit platform then ppr32_reg_no f i + else ppr64_reg_no f i + RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u + RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + + where + ppr32_reg_no :: Format -> Int -> SDoc + ppr32_reg_no II8 = ppr32_reg_byte + ppr32_reg_no II16 = ppr32_reg_word + ppr32_reg_no _ = ppr32_reg_long + + ppr32_reg_byte i = ptext + (case i of { + 0 -> sLit "%al"; 1 -> sLit "%bl"; + 2 -> sLit "%cl"; 3 -> sLit "%dl"; + _ -> sLit $ "very naughty I386 byte register: " ++ show i + }) + + ppr32_reg_word i = ptext + (case i of { + 0 -> sLit "%ax"; 1 -> sLit "%bx"; + 2 -> sLit "%cx"; 3 -> sLit "%dx"; + 4 -> sLit "%si"; 5 -> sLit "%di"; + 6 -> sLit "%bp"; 7 -> sLit "%sp"; + _ -> sLit "very naughty I386 word register" + }) + + ppr32_reg_long i = ptext + (case i of { + 0 -> sLit "%eax"; 1 -> sLit "%ebx"; + 2 -> sLit "%ecx"; 3 -> sLit "%edx"; + 4 -> sLit "%esi"; 5 -> sLit "%edi"; + 6 -> sLit "%ebp"; 7 -> sLit "%esp"; + _ -> ppr_reg_float i + }) + + ppr64_reg_no :: Format -> Int -> SDoc + ppr64_reg_no II8 = ppr64_reg_byte + ppr64_reg_no II16 = ppr64_reg_word + ppr64_reg_no II32 = ppr64_reg_long + ppr64_reg_no _ = ppr64_reg_quad + + ppr64_reg_byte i = ptext + (case i of { + 0 -> sLit "%al"; 1 -> sLit "%bl"; + 2 -> sLit "%cl"; 3 -> sLit "%dl"; + 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs! + 6 -> sLit "%bpl"; 7 -> sLit "%spl"; + 8 -> sLit "%r8b"; 9 -> sLit "%r9b"; + 10 -> sLit "%r10b"; 11 -> sLit "%r11b"; + 12 -> sLit "%r12b"; 13 -> sLit "%r13b"; + 14 -> sLit "%r14b"; 15 -> sLit "%r15b"; + _ -> sLit $ "very naughty x86_64 byte register: " ++ show i + }) + + ppr64_reg_word i = ptext + (case i of { + 0 -> sLit "%ax"; 1 -> sLit "%bx"; + 2 -> sLit "%cx"; 3 -> sLit "%dx"; + 4 -> sLit "%si"; 5 -> sLit "%di"; + 6 -> sLit "%bp"; 7 -> sLit "%sp"; + 8 -> sLit "%r8w"; 9 -> sLit "%r9w"; + 10 -> sLit "%r10w"; 11 -> sLit "%r11w"; + 12 -> sLit "%r12w"; 13 -> sLit "%r13w"; + 14 -> sLit "%r14w"; 15 -> sLit "%r15w"; + _ -> sLit "very naughty x86_64 word register" + }) + + ppr64_reg_long i = ptext + (case i of { + 0 -> sLit "%eax"; 1 -> sLit "%ebx"; + 2 -> sLit "%ecx"; 3 -> sLit "%edx"; + 4 -> sLit "%esi"; 5 -> sLit "%edi"; + 6 -> sLit "%ebp"; 7 -> sLit "%esp"; + 8 -> sLit "%r8d"; 9 -> sLit "%r9d"; + 10 -> sLit "%r10d"; 11 -> sLit "%r11d"; + 12 -> sLit "%r12d"; 13 -> sLit "%r13d"; + 14 -> sLit "%r14d"; 15 -> sLit "%r15d"; + _ -> sLit "very naughty x86_64 register" + }) + + ppr64_reg_quad i = ptext + (case i of { + 0 -> sLit "%rax"; 1 -> sLit "%rbx"; + 2 -> sLit "%rcx"; 3 -> sLit "%rdx"; + 4 -> sLit "%rsi"; 5 -> sLit "%rdi"; + 6 -> sLit "%rbp"; 7 -> sLit "%rsp"; + 8 -> sLit "%r8"; 9 -> sLit "%r9"; + 10 -> sLit "%r10"; 11 -> sLit "%r11"; + 12 -> sLit "%r12"; 13 -> sLit "%r13"; + 14 -> sLit "%r14"; 15 -> sLit "%r15"; + _ -> ppr_reg_float i + }) + +ppr_reg_float :: Int -> PtrString +ppr_reg_float i = case i of + 16 -> sLit "%xmm0" ; 17 -> sLit "%xmm1" + 18 -> sLit "%xmm2" ; 19 -> sLit "%xmm3" + 20 -> sLit "%xmm4" ; 21 -> sLit "%xmm5" + 22 -> sLit "%xmm6" ; 23 -> sLit "%xmm7" + 24 -> sLit "%xmm8" ; 25 -> sLit "%xmm9" + 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11" + 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13" + 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15" + _ -> sLit "very naughty x86 register" + +pprFormat :: Format -> SDoc +pprFormat x + = ptext (case x of + II8 -> sLit "b" + II16 -> sLit "w" + II32 -> sLit "l" + II64 -> sLit "q" + FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) + FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) + ) + +pprFormat_x87 :: Format -> SDoc +pprFormat_x87 x + = ptext $ case x of + FF32 -> sLit "s" + FF64 -> sLit "l" + _ -> panic "X86.Ppr.pprFormat_x87" + + +pprCond :: Cond -> SDoc +pprCond c + = ptext (case c of { + GEU -> sLit "ae"; LU -> sLit "b"; + EQQ -> sLit "e"; GTT -> sLit "g"; + GE -> sLit "ge"; GU -> sLit "a"; + LTT -> sLit "l"; LE -> sLit "le"; + LEU -> sLit "be"; NE -> sLit "ne"; + NEG -> sLit "s"; POS -> sLit "ns"; + CARRY -> sLit "c"; OFLO -> sLit "o"; + PARITY -> sLit "p"; NOTPARITY -> sLit "np"; + ALWAYS -> sLit "mp"}) + + +pprImm :: Imm -> SDoc +pprImm (ImmInt i) = int i +pprImm (ImmInteger i) = integer i +pprImm (ImmCLbl l) = ppr l +pprImm (ImmIndex l i) = ppr l <> char '+' <> int i +pprImm (ImmLit s) = s + +pprImm (ImmFloat _) = text "naughty float immediate" +pprImm (ImmDouble _) = text "naughty double immediate" + +pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b +pprImm (ImmConstantDiff a b) = pprImm a <> char '-' + <> lparen <> pprImm b <> rparen + + + +pprAddr :: Platform -> AddrMode -> SDoc +pprAddr _platform (ImmAddr imm off) + = let pp_imm = pprImm imm + in + if (off == 0) then + pp_imm + else if (off < 0) then + pp_imm <> int off + else + pp_imm <> char '+' <> int off + +pprAddr platform (AddrBaseIndex base index displacement) + = let + pp_disp = ppr_disp displacement + pp_off p = pp_disp <> char '(' <> p <> char ')' + pp_reg r = pprReg platform (archWordFormat (target32Bit platform)) r + in + case (base, index) of + (EABaseNone, EAIndexNone) -> pp_disp + (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b) + (EABaseRip, EAIndexNone) -> pp_off (text "%rip") + (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i) + (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r + <> comma <> int i) + _ -> panic "X86.Ppr.pprAddr: no match" + + where + ppr_disp (ImmInt 0) = empty + ppr_disp imm = pprImm imm + +-- | Print section header and appropriate alignment for that section. +pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign _config (Section (OtherSection _) _) = + panic "X86.Ppr.pprSectionAlign: unknown section" +pprSectionAlign config sec@(Section seg _) = + pprSectionHeader config sec $$ + pprAlignForSection (ncgPlatform config) seg + +-- | Print appropriate alignment for the given section type. +pprAlignForSection :: Platform -> SectionType -> SDoc +pprAlignForSection platform seg = + text ".align " <> + case platformOS platform of + -- Darwin: alignments are given as shifts. + OSDarwin + | target32Bit platform -> + case seg of + ReadOnlyData16 -> int 4 + CString -> int 1 + _ -> int 2 + | otherwise -> + case seg of + ReadOnlyData16 -> int 4 + CString -> int 1 + _ -> int 3 + -- Other: alignments are given as bytes. + _ + | target32Bit platform -> + case seg of + Text -> text "4,0x90" + ReadOnlyData16 -> int 16 + CString -> int 1 + _ -> int 4 + | otherwise -> + case seg of + ReadOnlyData16 -> int 16 + CString -> int 1 + _ -> int 8 + +pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem config lit + = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + platform = ncgPlatform config + imm = litToImm lit + + -- These seem to be common: + ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] + ppr_item II16 _ = [text "\t.word\t" <> pprImm imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + + ppr_item II64 _ + = case platformOS platform of + OSDarwin + | target32Bit platform -> + case lit of + CmmInt x _ -> + [text "\t.long\t" + <> int (fromIntegral (fromIntegral x :: Word32)), + text "\t.long\t" + <> int (fromIntegral + (fromIntegral (x `shiftR` 32) :: Word32))] + _ -> panic "X86.Ppr.ppr_item: no match for II64" + | otherwise -> + [text "\t.quad\t" <> pprImm imm] + _ + | target32Bit platform -> + [text "\t.quad\t" <> pprImm imm] + | otherwise -> + -- x86_64: binutils can't handle the R_X86_64_PC64 + -- relocation type, which means we can't do + -- pc-relative 64-bit addresses. Fortunately we're + -- assuming the small memory model, in which all such + -- offsets will fit into 32 bits, so we have to stick + -- to 32-bit offset fields and modify the RTS + -- appropriately + -- + -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h + -- + case lit of + -- A relative relocation: + CmmLabelDiffOff _ _ _ _ -> + [text "\t.long\t" <> pprImm imm, + text "\t.long\t0"] + _ -> + [text "\t.quad\t" <> pprImm imm] + + ppr_item _ _ + = panic "X86.Ppr.ppr_item: no match" + + +asmComment :: SDoc -> SDoc +asmComment c = whenPprDebug $ text "# " <> c + +pprInstr :: Platform -> Instr -> SDoc +pprInstr platform i = case i of + COMMENT s + -> asmComment (ftext s) + + LOCATION file line col _name + -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col + + DELTA d + -> asmComment $ text ("\tdelta = " ++ show d) + + NEWBLOCK _ + -> panic "pprInstr: NEWBLOCK" + + UNWIND lbl d + -> asmComment (text "\tunwind = " <> ppr d) + $$ ppr lbl <> colon + + LDATA _ _ + -> panic "pprInstr: LDATA" + +{- + SPILL reg slot + -> hcat [ + text "\tSPILL", + char ' ', + pprUserReg reg, + comma, + text "SLOT" <> parens (int slot)] + + RELOAD slot reg + -> hcat [ + text "\tRELOAD", + char ' ', + text "SLOT" <> parens (int slot), + comma, + pprUserReg reg] +-} + + -- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper. + -- The code generator catches most of these already, but not all. + MOV format (OpImm (ImmInt 0)) dst@(OpReg _) + -> pprInstr platform (XOR format' dst dst) + where format' = case format of + II64 -> II32 -- 32-bit version is equivalent, and smaller + _ -> format + + MOV format src dst + -> pprFormatOpOp (sLit "mov") format src dst + + CMOV cc format src dst + -> pprCondOpReg (sLit "cmov") format cc src dst + + MOVZxL II32 src dst + -> pprFormatOpOp (sLit "mov") II32 src dst + -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple + -- movl. But we represent it as a MOVZxL instruction, because + -- the reg alloc would tend to throw away a plain reg-to-reg + -- move, and we still want it to do that. + + MOVZxL formats src dst + -> pprFormatOpOpCoerce (sLit "movz") formats II32 src dst + -- zero-extension only needs to extend to 32 bits: on x86_64, + -- the remaining zero-extension to 64 bits is automatic, and the 32-bit + -- instruction is shorter. + + MOVSxL formats src dst + -> pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst + + -- here we do some patching, since the physical registers are only set late + -- in the code generation. + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) + | reg1 == reg3 + -> pprFormatOpOp (sLit "add") format (OpReg reg2) dst + + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) + | reg2 == reg3 + -> pprFormatOpOp (sLit "add") format (OpReg reg1) dst + + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3) + | reg1 == reg3 + -> pprInstr platform (ADD format (OpImm displ) dst) + + LEA format src dst + -> pprFormatOpOp (sLit "lea") format src dst + + ADD format (OpImm (ImmInt (-1))) dst + -> pprFormatOp (sLit "dec") format dst + + ADD format (OpImm (ImmInt 1)) dst + -> pprFormatOp (sLit "inc") format dst + + ADD format src dst + -> pprFormatOpOp (sLit "add") format src dst + + ADC format src dst + -> pprFormatOpOp (sLit "adc") format src dst + + SUB format src dst + -> pprFormatOpOp (sLit "sub") format src dst + + SBB format src dst + -> pprFormatOpOp (sLit "sbb") format src dst + + IMUL format op1 op2 + -> pprFormatOpOp (sLit "imul") format op1 op2 + + ADD_CC format src dst + -> pprFormatOpOp (sLit "add") format src dst + + SUB_CC format src dst + -> pprFormatOpOp (sLit "sub") format src dst + + -- Use a 32-bit instruction when possible as it saves a byte. + -- Notably, extracting the tag bits of a pointer has this form. + -- TODO: we could save a byte in a subsequent CMP instruction too, + -- but need something like a peephole pass for this + AND II64 src@(OpImm (ImmInteger mask)) dst + | 0 <= mask && mask < 0xffffffff + -> pprInstr platform (AND II32 src dst) + + AND FF32 src dst + -> pprOpOp (sLit "andps") FF32 src dst + + AND FF64 src dst + -> pprOpOp (sLit "andpd") FF64 src dst + + AND format src dst + -> pprFormatOpOp (sLit "and") format src dst + + OR format src dst + -> pprFormatOpOp (sLit "or") format src dst + + XOR FF32 src dst + -> pprOpOp (sLit "xorps") FF32 src dst + + XOR FF64 src dst + -> pprOpOp (sLit "xorpd") FF64 src dst + + XOR format src dst + -> pprFormatOpOp (sLit "xor") format src dst + + POPCNT format src dst + -> pprOpOp (sLit "popcnt") format src (OpReg dst) + + LZCNT format src dst + -> pprOpOp (sLit "lzcnt") format src (OpReg dst) + + TZCNT format src dst + -> pprOpOp (sLit "tzcnt") format src (OpReg dst) + + BSF format src dst + -> pprOpOp (sLit "bsf") format src (OpReg dst) + + BSR format src dst + -> pprOpOp (sLit "bsr") format src (OpReg dst) + + PDEP format src mask dst + -> pprFormatOpOpReg (sLit "pdep") format src mask dst + + PEXT format src mask dst + -> pprFormatOpOpReg (sLit "pext") format src mask dst + + PREFETCH NTA format src + -> pprFormatOp_ (sLit "prefetchnta") format src + + PREFETCH Lvl0 format src + -> pprFormatOp_ (sLit "prefetcht0") format src + + PREFETCH Lvl1 format src + -> pprFormatOp_ (sLit "prefetcht1") format src + + PREFETCH Lvl2 format src + -> pprFormatOp_ (sLit "prefetcht2") format src + + NOT format op + -> pprFormatOp (sLit "not") format op + + BSWAP format op + -> pprFormatOp (sLit "bswap") format (OpReg op) + + NEGI format op + -> pprFormatOp (sLit "neg") format op + + SHL format src dst + -> pprShift (sLit "shl") format src dst + + SAR format src dst + -> pprShift (sLit "sar") format src dst + + SHR format src dst + -> pprShift (sLit "shr") format src dst + + BT format imm src + -> pprFormatImmOp (sLit "bt") format imm src + + CMP format src dst + | isFloatFormat format -> pprFormatOpOp (sLit "ucomi") format src dst -- SSE2 + | otherwise -> pprFormatOpOp (sLit "cmp") format src dst + + TEST format src dst + -> pprFormatOpOp (sLit "test") format' src dst + where + -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. + -- We can replace them by equivalent, but smaller instructions + -- by reducing the size of the immediate operand as far as possible. + -- (We could handle masks larger than a single byte too, + -- but it would complicate the code considerably + -- and tag checks are by far the most common case.) + -- The mask must have the high bit clear for this smaller encoding + -- to be completely equivalent to the original; in particular so + -- that the signed comparison condition bits are the same as they + -- would be if doing a full word comparison. See #13425. + format' = case (src,dst) of + (OpImm (ImmInteger mask), OpReg dstReg) + | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg + _ -> format + minSizeOfReg platform (RegReal (RealRegSingle i)) + | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl + | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp + | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b + minSizeOfReg _ _ = format -- other + + PUSH format op + -> pprFormatOp (sLit "push") format op + + POP format op + -> pprFormatOp (sLit "pop") format op + +-- both unused (SDM): +-- PUSHA -> text "\tpushal" +-- POPA -> text "\tpopal" + + NOP + -> text "\tnop" + + CLTD II8 + -> text "\tcbtw" + + CLTD II16 + -> text "\tcwtd" + + CLTD II32 + -> text "\tcltd" + + CLTD II64 + -> text "\tcqto" + + CLTD x + -> panic $ "pprInstr: CLTD " ++ show x + + SETCC cond op + -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op) + + XCHG format src val + -> pprFormatOpReg (sLit "xchg") format src val + + JXX cond blockid + -> pprCondInstr (sLit "j") cond (ppr lab) + where lab = blockLbl blockid + + JXX_GBL cond imm + -> pprCondInstr (sLit "j") cond (pprImm imm) + + JMP (OpImm imm) _ + -> text "\tjmp " <> pprImm imm + + JMP op _ + -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op + + JMP_TBL op _ _ _ + -> pprInstr platform (JMP op []) + + CALL (Left imm) _ + -> text "\tcall " <> pprImm imm + + CALL (Right reg) _ + -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg + + IDIV fmt op + -> pprFormatOp (sLit "idiv") fmt op + + DIV fmt op + -> pprFormatOp (sLit "div") fmt op + + IMUL2 fmt op + -> pprFormatOp (sLit "imul") fmt op + + -- x86_64 only + MUL format op1 op2 + -> pprFormatOpOp (sLit "mul") format op1 op2 + + MUL2 format op + -> pprFormatOp (sLit "mul") format op + + FDIV format op1 op2 + -> pprFormatOpOp (sLit "div") format op1 op2 + + SQRT format op1 op2 + -> pprFormatOpReg (sLit "sqrt") format op1 op2 + + CVTSS2SD from to + -> pprRegReg (sLit "cvtss2sd") from to + + CVTSD2SS from to + -> pprRegReg (sLit "cvtsd2ss") from to + + CVTTSS2SIQ fmt from to + -> pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to + + CVTTSD2SIQ fmt from to + -> pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to + + CVTSI2SS fmt from to + -> pprFormatOpReg (sLit "cvtsi2ss") fmt from to + + CVTSI2SD fmt from to + -> pprFormatOpReg (sLit "cvtsi2sd") fmt from to + + -- FETCHGOT for PIC on ELF platforms + FETCHGOT reg + -> vcat [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ], + hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", + pprReg platform II32 reg ] + ] + + -- FETCHPC for PIC on Darwin/x86 + -- get the instruction pointer into a register + -- (Terminology note: the IP is called Program Counter on PPC, + -- and it's a good thing to use the same name on both platforms) + FETCHPC reg + -> vcat [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ] + ] + + -- the + -- GST fmt src addr ==> FLD dst ; FSTPsz addr + g@(X87Store fmt addr) + -> pprX87 g (hcat [gtab, text "fstp", pprFormat_x87 fmt, gsp, pprAddr platform addr]) + + -- Atomics + LOCK i + -> text "\tlock" $$ pprInstr platform i + + MFENCE + -> text "\tmfence" + + XADD format src dst + -> pprFormatOpOp (sLit "xadd") format src dst + + CMPXCHG format src dst + -> pprFormatOpOp (sLit "cmpxchg") format src dst + + + where + gtab :: SDoc + gtab = char '\t' + + gsp :: SDoc + gsp = char ' ' + + + + pprX87 :: Instr -> SDoc -> SDoc + pprX87 fake actual + = (char '#' <> pprX87Instr fake) $$ actual + + pprX87Instr :: Instr -> SDoc + pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst + pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" + + pprDollImm :: Imm -> SDoc + pprDollImm i = text "$" <> pprImm i + + + pprOperand :: Platform -> Format -> Operand -> SDoc + pprOperand platform f op = case op of + OpReg r -> pprReg platform f r + OpImm i -> pprDollImm i + OpAddr ea -> pprAddr platform ea + + + pprMnemonic_ :: PtrString -> SDoc + pprMnemonic_ name = + char '\t' <> ptext name <> space + + + pprMnemonic :: PtrString -> Format -> SDoc + pprMnemonic name format = + char '\t' <> ptext name <> pprFormat format <> space + + + pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc + pprFormatImmOp name format imm op1 + = hcat [ + pprMnemonic name format, + char '$', + pprImm imm, + comma, + pprOperand platform format op1 + ] + + + pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc + pprFormatOp_ name format op1 + = hcat [ + pprMnemonic_ name , + pprOperand platform format op1 + ] + + pprFormatOp :: PtrString -> Format -> Operand -> SDoc + pprFormatOp name format op1 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1 + ] + + + pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc + pprFormatOpOp name format op1 op2 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprOperand platform format op2 + ] + + + pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc + pprOpOp name format op1 op2 + = hcat [ + pprMnemonic_ name, + pprOperand platform format op1, + comma, + pprOperand platform format op2 + ] + + pprRegReg :: PtrString -> Reg -> Reg -> SDoc + pprRegReg name reg1 reg2 + = hcat [ + pprMnemonic_ name, + pprReg platform (archWordFormat (target32Bit platform)) reg1, + comma, + pprReg platform (archWordFormat (target32Bit platform)) reg2 + ] + + + pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc + pprFormatOpReg name format op1 reg2 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprReg platform (archWordFormat (target32Bit platform)) reg2 + ] + + pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc + pprCondOpReg name format cond op1 reg2 + = hcat [ + char '\t', + ptext name, + pprCond cond, + space, + pprOperand platform format op1, + comma, + pprReg platform format reg2 + ] + + pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc + pprFormatFormatOpReg name format1 format2 op1 reg2 + = hcat [ + pprMnemonic name format2, + pprOperand platform format1 op1, + comma, + pprReg platform format2 reg2 + ] + + pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc + pprFormatOpOpReg name format op1 op2 reg3 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + + + pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc + pprFormatAddr name format op + = hcat [ + pprMnemonic name format, + comma, + pprAddr platform op + ] + + pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc + pprShift name format src dest + = hcat [ + pprMnemonic name format, + pprOperand platform II8 src, -- src is 8-bit sized + comma, + pprOperand platform format dest + ] + + + pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc + pprFormatOpOpCoerce name format1 format2 op1 op2 + = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space, + pprOperand platform format1 op1, + comma, + pprOperand platform format2 op2 + ] + + + pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc + pprCondInstr name cond arg + = hcat [ char '\t', ptext name, pprCond cond, space, arg] diff --git a/GHC/CmmToAsm/X86/RegInfo.hs b/GHC/CmmToAsm/X86/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/RegInfo.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} +module GHC.CmmToAsm.X86.RegInfo ( + mkVirtualReg, + regDotColor +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.CmmToAsm.Format +import GHC.Platform.Reg + +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique + +import GHC.Types.Unique.FM +import GHC.CmmToAsm.X86.Regs + + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + = case format of + FF32 -> VirtualRegD u + -- for scalar F32, we use the same xmm as F64! + -- this is a hack that needs some improvement. + -- For now we map both to being allocated as "Double" Registers + -- on X86/X86_64 + FF64 -> VirtualRegD u + _other -> VirtualRegI u + +regDotColor :: Platform -> RealReg -> SDoc +regDotColor platform reg + = case (lookupUFM (regColors platform) reg) of + Just str -> text str + _ -> panic "Register not assigned a color" + +regColors :: Platform -> UniqFM RealReg [Char] +regColors platform = listToUFM (normalRegColors platform) + +normalRegColors :: Platform -> [(RealReg,String)] +normalRegColors platform = + zip (map realRegSingle [0..lastint platform]) colors + ++ zip (map realRegSingle [firstxmm..lastxmm platform]) greys + where + -- 16 colors - enough for amd64 gp regs + colors = ["#800000","#ff0000","#808000","#ffff00","#008000" + ,"#00ff00","#008080","#00ffff","#000080","#0000ff" + ,"#800080","#ff00ff","#87005f","#875f00","#87af00" + ,"#ff00af"] + + -- 16 shades of grey, enough for the currently supported + -- SSE extensions. + greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646" + ,"#545454","#626262","#707070","#7e7e7e","#8c8c8c" + ,"#9a9a9a","#a8a8a8","#b6b6b6","#c4c4c4","#d2d2d2" + ,"#e0e0e0"] + + + +-- 32 shades of grey - use for avx 512 if we ever need it +-- greys = ["#070707","#0e0e0e","#151515","#1c1c1c" +-- ,"#232323","#2a2a2a","#313131","#383838","#3f3f3f" +-- ,"#464646","#4d4d4d","#545454","#5b5b5b","#626262" +-- ,"#696969","#707070","#777777","#7e7e7e","#858585" +-- ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8" +-- ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb" +-- ,"#d2d2d2","#d9d9d9","#e0e0e0"] + + diff --git a/GHC/CmmToAsm/X86/Regs.hs b/GHC/CmmToAsm/X86/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/X86/Regs.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE CPP #-} + +module GHC.CmmToAsm.X86.Regs ( + -- squeese functions for the graph allocator + virtualRegSqueeze, + realRegSqueeze, + + -- immediates + Imm(..), + strImmLit, + litToImm, + + -- addressing modes + AddrMode(..), + addrOffset, + + -- registers + spRel, + argRegs, + allArgRegs, + allIntArgRegs, + callClobberedRegs, + instrClobberedRegs, + allMachRegNos, + classOfRealReg, + showReg, + + -- machine specific + EABase(..), EAIndex(..), addrModeRegs, + + eax, ebx, ecx, edx, esi, edi, ebp, esp, + + + rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp, + r8, r9, r10, r11, r12, r13, r14, r15, + lastint, + xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, + xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15, + xmm, + firstxmm, lastxmm, + + ripRel, + allFPArgRegs, + + allocatableRegs +) + +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform.Regs +import GHC.Platform.Reg +import GHC.Platform.Reg.Class + +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.Utils.Outputable +import GHC.Platform + +import qualified Data.Array as A + +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int + +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 + + RcDouble + -> case vr of + VirtualRegD{} -> 1 + VirtualRegF{} -> 0 + _other -> 0 + + + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < firstxmm -> 1 + | otherwise -> 0 + + RealRegPair{} -> 0 + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo >= firstxmm -> 1 + | otherwise -> 0 + + RealRegPair{} -> 0 + + + _other -> 0 + +-- ----------------------------------------------------------------------------- +-- Immediates + +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit SDoc -- Simple string + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + +strImmLit :: String -> Imm +strImmLit s = ImmLit (text s) + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "X86.Regs.litToImm: no match" + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrBaseIndex EABase EAIndex Displacement + | ImmAddr Imm Int + +data EABase = EABaseNone | EABaseReg Reg | EABaseRip +data EAIndex = EAIndexNone | EAIndex Reg Int +type Displacement = Imm + + +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) + + AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off))) + AddrBaseIndex r i (ImmInteger n) + -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off)))) + + AddrBaseIndex r i (ImmCLbl lbl) + -> Just (AddrBaseIndex r i (ImmIndex lbl off)) + + AddrBaseIndex r i (ImmIndex lbl ix) + -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off))) + + _ -> Nothing -- in theory, shouldn't happen + + +addrModeRegs :: AddrMode -> [Reg] +addrModeRegs (AddrBaseIndex b i _) = b_regs ++ i_regs + where + b_regs = case b of { EABaseReg r -> [r]; _ -> [] } + i_regs = case i of { EAIndex r _ -> [r]; _ -> [] } +addrModeRegs _ = [] + + +-- registers ------------------------------------------------------------------- + +-- @spRel@ gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. @fpRel@, where +-- applicable, is the same but for the frame pointer. + + +spRel :: Platform + -> Int -- ^ desired stack offset in bytes, positive or negative + -> AddrMode +spRel platform n + | target32Bit platform + = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n) + | otherwise + = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n) + +-- The register numbers must fit into 32 bits on x86, so that we can +-- use a Word32 to represent the set of free registers in the register +-- allocator. + + + +firstxmm :: RegNo +firstxmm = 16 + +-- on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available +lastxmm :: Platform -> RegNo +lastxmm platform + | target32Bit platform = firstxmm + 7 -- xmm0 - xmmm7 + | otherwise = firstxmm + 15 -- xmm0 -xmm15 + +lastint :: Platform -> RegNo +lastint platform + | target32Bit platform = 7 -- not %r8..%r15 + | otherwise = 15 + +intregnos :: Platform -> [RegNo] +intregnos platform = [0 .. lastint platform] + + + +xmmregnos :: Platform -> [RegNo] +xmmregnos platform = [firstxmm .. lastxmm platform] + +floatregnos :: Platform -> [RegNo] +floatregnos platform = xmmregnos platform + +-- argRegs is the set of regs which are read for an n-argument call to C. +-- For archs which pass all args on the stack (x86), is empty. +-- Sparc passes up to the first 6 args in regs. +argRegs :: RegNo -> [Reg] +argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" + +-- | The complete set of machine registers. +allMachRegNos :: Platform -> [RegNo] +allMachRegNos platform = intregnos platform ++ floatregnos platform + +-- | Take the class of a register. +{-# INLINE classOfRealReg #-} +classOfRealReg :: Platform -> RealReg -> RegClass +-- On x86, we might want to have an 8-bit RegClass, which would +-- contain just regs 1-4 (the others don't have 8-bit versions). +-- However, we can get away without this at the moment because the +-- only allocatable integer regs are also 8-bit compatible (1, 3, 4). +classOfRealReg platform reg + = case reg of + RealRegSingle i + | i <= lastint platform -> RcInteger + | i <= lastxmm platform -> RcDouble + | otherwise -> panic "X86.Reg.classOfRealReg registerSingle too high" + _ -> panic "X86.Regs.classOfRealReg: RegPairs on this arch" + +-- | Get the name of the register with this number. +-- NOTE: fixme, we dont track which "way" the XMM registers are used +showReg :: Platform -> RegNo -> String +showReg platform n + | n >= firstxmm && n <= lastxmm platform = "%xmm" ++ show (n-firstxmm) + | n >= 8 && n < firstxmm = "%r" ++ show n + | otherwise = regNames platform A.! n + +regNames :: Platform -> A.Array Int String +regNames platform + = if target32Bit platform + then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"] + else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"] + + + +-- machine specific ------------------------------------------------------------ + + +{- +Intel x86 architecture: +- All registers except 7 (esp) are available for use. +- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). +- Registers 0-7 have 16-bit counterparts (ax, bx etc.) +- Registers 0-3 have 8 bit counterparts (ah, bh etc.) + +The fp registers are all Double registers; we don't have any RcFloat class +regs. @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should +never generate them. + +TODO: cleanup modelling float vs double registers and how they are the same class. +-} + + +eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg + +eax = regSingle 0 +ebx = regSingle 1 +ecx = regSingle 2 +edx = regSingle 3 +esi = regSingle 4 +edi = regSingle 5 +ebp = regSingle 6 +esp = regSingle 7 + + + + +{- +AMD x86_64 architecture: +- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values: + + 8 16 32 64 + --------------------- + al ax eax rax + bl bx ebx rbx + cl cx ecx rcx + dl dx edx rdx + sil si esi rsi + dil si edi rdi + bpl bp ebp rbp + spl sp esp rsp + r10b r10w r10d r10 + r11b r11w r11d r11 + r12b r12w r12d r12 + r13b r13w r13d r13 + r14b r14w r14d r14 + r15b r15w r15d r15 +-} + +rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, + r8, r9, r10, r11, r12, r13, r14, r15, + xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, + xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg + +rax = regSingle 0 +rbx = regSingle 1 +rcx = regSingle 2 +rdx = regSingle 3 +rsi = regSingle 4 +rdi = regSingle 5 +rbp = regSingle 6 +rsp = regSingle 7 +r8 = regSingle 8 +r9 = regSingle 9 +r10 = regSingle 10 +r11 = regSingle 11 +r12 = regSingle 12 +r13 = regSingle 13 +r14 = regSingle 14 +r15 = regSingle 15 +xmm0 = regSingle 16 +xmm1 = regSingle 17 +xmm2 = regSingle 18 +xmm3 = regSingle 19 +xmm4 = regSingle 20 +xmm5 = regSingle 21 +xmm6 = regSingle 22 +xmm7 = regSingle 23 +xmm8 = regSingle 24 +xmm9 = regSingle 25 +xmm10 = regSingle 26 +xmm11 = regSingle 27 +xmm12 = regSingle 28 +xmm13 = regSingle 29 +xmm14 = regSingle 30 +xmm15 = regSingle 31 + +ripRel :: Displacement -> AddrMode +ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm + + + -- so we can re-use some x86 code: +{- +eax = rax +ebx = rbx +ecx = rcx +edx = rdx +esi = rsi +edi = rdi +ebp = rbp +esp = rsp +-} + +xmm :: RegNo -> Reg +xmm n = regSingle (firstxmm+n) + + + + +-- | these are the regs which we cannot assume stay alive over a C call. +callClobberedRegs :: Platform -> [Reg] +-- caller-saves registers +callClobberedRegs platform + | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform) + | platformOS platform == OSMinGW32 + = [rax,rcx,rdx,r8,r9,r10,r11] + -- Only xmm0-5 are caller-saves registers on 64bit windows. + -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage ) + -- For details check the Win64 ABI. + ++ map xmm [0 .. 5] + | otherwise + -- all xmm regs are caller-saves + -- caller-saves registers + = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] + ++ map regSingle (floatregnos platform) + +allArgRegs :: Platform -> [(Reg, Reg)] +allArgRegs platform + | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9] + (map regSingle [firstxmm ..]) + | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch" + +allIntArgRegs :: Platform -> [Reg] +allIntArgRegs platform + | (platformOS platform == OSMinGW32) || target32Bit platform + = panic "X86.Regs.allIntArgRegs: not defined for this platform" + | otherwise = [rdi,rsi,rdx,rcx,r8,r9] + + +-- | on 64bit platforms we pass the first 8 float/double arguments +-- in the xmm registers. +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + | platformOS platform == OSMinGW32 + = panic "X86.Regs.allFPArgRegs: not defined for this platform" + | otherwise = map regSingle [firstxmm .. firstxmm + 7 ] + + +-- Machine registers which might be clobbered by instructions that +-- generate results into fixed registers, or need arguments in a fixed +-- register. +instrClobberedRegs :: Platform -> [Reg] +instrClobberedRegs platform + | target32Bit platform = [ eax, ecx, edx ] + | otherwise = [ rax, rcx, rdx ] + +-- + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = freeReg platform i + in map RealRegSingle $ filter isFree (allMachRegNos platform) + diff --git a/GHC/CmmToC.hs b/GHC/CmmToC.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToC.hs @@ -0,0 +1,1398 @@ +{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing of Cmm as C, suitable for feeding gcc +-- +-- (c) The University of Glasgow 2004-2006 +-- +-- Print Cmm as real C, for -fvia-C +-- +-- See wiki:commentary/compiler/backends/ppr-c +-- +-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded" +-- relative to the old AbstractC, and many oddities/decorations have +-- disappeared from the data type. +-- +-- This code generator is only supported in unregisterised mode. +-- +----------------------------------------------------------------------------- + +module GHC.CmmToC ( + writeC + ) where + +#include "HsVersions.h" + +-- Cmm stuff +import GHC.Prelude + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Types.ForeignCall +import GHC.Cmm hiding (pprBBlock) +import GHC.Cmm.Ppr () -- For Outputable instances +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Utils +import GHC.Cmm.Switch + +-- Utils +import GHC.CmmToAsm.CPrim +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Utils.Misc + +-- The rest +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Control.Monad.ST +import Data.Bits +import Data.Char +import Data.List (intersperse) +import Data.Map (Map) +import Data.Word +import System.IO +import qualified Data.Map as Map +import Control.Monad (ap) +import qualified Data.Array.Unsafe as U ( castSTUArray ) +import Data.Array.ST + +-- -------------------------------------------------------------------------- +-- Top level + +writeC :: DynFlags -> Handle -> RawCmmGroup -> IO () +writeC dflags handle cmm = printForC dflags handle (pprC dflags cmm $$ blankLine) + +-- -------------------------------------------------------------------------- +-- Now do some real work +-- +-- for fun, we could call cmmToCmm over the tops... +-- + +pprC :: DynFlags -> RawCmmGroup -> SDoc +pprC dflags tops = vcat $ intersperse blankLine $ map (pprTop dflags) tops + +-- +-- top level procs +-- +pprTop :: DynFlags -> RawCmmDecl -> SDoc +pprTop dflags = \case + (CmmProc infos clbl _in_live_regs graph) -> + (case mapLookup (g_entry graph) infos of + Nothing -> empty + Just (CmmStaticsRaw info_clbl info_dat) -> + pprDataExterns platform info_dat $$ + pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$ + (vcat [ + blankLine, + extern_decls, + (if (externallyVisibleCLabel clbl) + then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, + nest 8 temp_decls, + vcat (map (pprBBlock dflags) blocks), + rbrace ] + ) + where + -- info tables are always in .rodata + info_is_in_rodata = True + blocks = toBlockListEntryFirst graph + (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks + + + -- Chunks of static data. + + -- We only handle (a) arrays of word-sized things and (b) strings. + + (CmmData section (CmmStaticsRaw lbl [CmmString str])) -> + pprExternDecl platform lbl $$ + hcat [ + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, + text "[] = ", pprStringInCStyle str, semi + ] + + (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) -> + pprExternDecl platform lbl $$ + hcat [ + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, + brackets (int size), semi + ] + + (CmmData section (CmmStaticsRaw lbl lits)) -> + pprDataExterns platform lits $$ + pprWordArray dflags (isSecConstant section) lbl lits + where + isSecConstant section = case sectionProtection section of + ReadOnlySection -> True + WriteProtectedSection -> True + _ -> False + platform = targetPlatform dflags + +-- -------------------------------------------------------------------------- +-- BasicBlocks are self-contained entities: they always end in a jump. +-- +-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn +-- as many jumps as possible into fall throughs. +-- + +pprBBlock :: DynFlags -> CmmBlock -> SDoc +pprBBlock dflags block = + nest 4 (pprBlockId (entryLabel block) <> colon) $$ + nest 8 (vcat (map (pprStmt dflags) (blockToList nodes)) $$ pprStmt dflags last) + where + (_, nodes, last) = blockSplit block + +-- -------------------------------------------------------------------------- +-- Info tables. Just arrays of words. +-- See codeGen/ClosureInfo, and nativeGen/PprMach + +pprWordArray :: DynFlags -> Bool -> CLabel -> [CmmStatic] -> SDoc +pprWordArray dflags is_ro lbl ds + = -- TODO: align closures only + pprExternDecl platform lbl $$ + hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord" + , space, ppr lbl, text "[]" + -- See Note [StgWord alignment] + , pprAlignment (wordWidth platform) + , text "= {" ] + $$ nest 8 (commafy (pprStatics dflags ds)) + $$ text "};" + where + platform = targetPlatform dflags + +pprAlignment :: Width -> SDoc +pprAlignment words = + text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))" + +-- Note [StgWord alignment] +-- C codegen builds static closures as StgWord C arrays (pprWordArray). +-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume +-- pointers to 'StgClosure' are aligned at pointer size boundary: +-- 4 byte boundary on 32 systems +-- and 8 bytes on 64-bit systems +-- see TAG_MASK and TAG_BITS definition and usage. +-- +-- It's a reasonable assumption also known as natural alignment. +-- Although some architectures have different alignment rules. +-- One of known exceptions is m68k (#11395, comment:16) where: +-- __alignof__(StgWord) == 2, sizeof(StgWord) == 4 +-- +-- Thus we explicitly increase alignment by using +-- __attribute__((aligned(4))) +-- declaration. + +-- +-- has to be static, if it isn't globally visible +-- +pprLocalness :: CLabel -> SDoc +pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static " + | otherwise = empty + +pprConstness :: Bool -> SDoc +pprConstness is_ro | is_ro = text "const " + | otherwise = empty + +-- -------------------------------------------------------------------------- +-- Statements. +-- + +pprStmt :: DynFlags -> CmmNode e x -> SDoc + +pprStmt dflags stmt = + case stmt of + CmmEntry{} -> empty + CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/") + -- XXX if the string contains "*/", we need to fix it + -- XXX we probably want to emit these comments when + -- some debugging option is on. They can get quite + -- large. + + CmmTick _ -> empty + CmmUnwind{} -> empty + + CmmAssign dest src -> pprAssign dflags dest src + + CmmStore dest src + | typeWidth rep == W64 && wordWidth platform /= W64 + -> (if isFloatType rep then text "ASSIGN_DBL" + else ptext (sLit ("ASSIGN_Word64"))) <> + parens (mkP_ <> pprExpr1 dflags dest <> comma <> pprExpr dflags src) <> semi + + | otherwise + -> hsep [ pprExpr dflags (CmmLoad dest rep), equals, pprExpr dflags src <> semi ] + where + rep = cmmExprType platform src + platform = targetPlatform dflags + + CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> + fnCall + where + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + platform = targetPlatform dflags + + ForeignConvention cconv _ _ ret = conv + + cast_fn = parens (cCast dflags (pprCFunType platform (char '*') cconv hresults hargs) fn) + + -- See wiki:commentary/compiler/backends/ppr-c#prototypes + fnCall = + case fn of + CmmLit (CmmLabel lbl) + | StdCallConv <- cconv -> + pprCall dflags (ppr lbl) cconv hresults hargs + -- stdcall functions must be declared with + -- a function type, otherwise the C compiler + -- doesn't add the @n suffix to the label. We + -- can't add the @n suffix ourselves, because + -- it isn't valid C. + | CmmNeverReturns <- ret -> + pprCall dflags cast_fn cconv hresults hargs <> semi + | not (isMathFun lbl) -> + pprForeignCall dflags (ppr lbl) cconv hresults hargs + _ -> + pprCall dflags cast_fn cconv hresults hargs <> semi + -- for a dynamic call, no declaration is necessary. + + CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty + CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty + + CmmUnsafeForeignCall target@(PrimTarget op) results args -> + fn_call + where + cconv = CCallConv + fn = pprCallishMachOp_for_C op + + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + + fn_call + -- The mem primops carry an extra alignment arg. + -- We could maybe emit an alignment directive using this info. + -- We also need to cast mem primops to prevent conflicts with GCC + -- builtins (see bug #5967). + | Just _align <- machOpMemcpyishAlign op + = (text ";EFF_(" <> fn <> char ')' <> semi) $$ + pprForeignCall dflags fn cconv hresults hargs + | otherwise + = pprCall dflags fn cconv hresults hargs + + CmmBranch ident -> pprBranch ident + CmmCondBranch expr yes no _ -> pprCondBranch dflags expr yes no + CmmCall { cml_target = expr } -> mkJMP_ (pprExpr dflags expr) <> semi + CmmSwitch arg ids -> pprSwitch dflags arg ids + + _other -> pprPanic "PprC.pprStmt" (ppr stmt) + +type Hinted a = (a, ForeignHint) + +pprForeignCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] + -> SDoc +pprForeignCall dflags fn cconv results args = fn_call + where + platform = targetPlatform dflags + fn_call = braces ( + pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi + $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi + $$ pprCall dflags (text "ghcFunPtr") cconv results args <> semi + ) + cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn) + +pprCFunType :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCFunType platform ppr_fn cconv ress args + = let res_type [] = text "void" + res_type [(one, hint)] = machRepHintCType platform (localRegType one) hint + res_type _ = panic "pprCFunType: only void or 1 return value supported" + + arg_type (expr, hint) = machRepHintCType platform (cmmExprType platform expr) hint + in res_type ress <+> + parens (ccallConvAttribute cconv <> ppr_fn) <> + parens (commafy (map arg_type args)) + +-- --------------------------------------------------------------------- +-- unconditional branches +pprBranch :: BlockId -> SDoc +pprBranch ident = text "goto" <+> pprBlockId ident <> semi + + +-- --------------------------------------------------------------------- +-- conditional branches to local labels +pprCondBranch :: DynFlags -> CmmExpr -> BlockId -> BlockId -> SDoc +pprCondBranch dflags expr yes no + = hsep [ text "if" , parens(pprExpr dflags expr) , + text "goto", pprBlockId yes <> semi, + text "else goto", pprBlockId no <> semi ] + +-- --------------------------------------------------------------------- +-- a local table branch +-- +-- we find the fall-through cases +-- +pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc +pprSwitch dflags e ids + = (hang (text "switch" <+> parens ( pprExpr dflags e ) <+> lbrace) + 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace + where + (pairs, mbdef) = switchTargetsFallThrough ids + platform = targetPlatform dflags + + -- fall through case + caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix + where + do_fallthrough ix = + hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon , + text "/* fall through */" ] + + final_branch ix = + hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon , + text "goto" , (pprBlockId ident) <> semi ] + + caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" + + def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi + | otherwise = empty + +-- --------------------------------------------------------------------- +-- Expressions. +-- + +-- C Types: the invariant is that the C expression generated by +-- +-- pprExpr e +-- +-- has a type in C which is also given by +-- +-- machRepCType (cmmExprType e) +-- +-- (similar invariants apply to the rest of the pretty printer). + +pprExpr :: DynFlags -> CmmExpr -> SDoc +pprExpr dflags e = case e of + CmmLit lit -> pprLit dflags lit + CmmLoad e ty -> pprLoad dflags e ty + CmmReg reg -> pprCastReg reg + CmmRegOff reg 0 -> pprCastReg reg + + -- CmmRegOff is an alias of MO_Add + CmmRegOff reg i -> pprCastReg reg <> char '+' <> + pprHexVal dflags (fromIntegral i) (wordWidth platform) + + CmmMachOp mop args -> pprMachOpApp dflags mop args + + CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" + where + platform = targetPlatform dflags + + +pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc +pprLoad dflags e ty + | width == W64, wordWidth platform /= W64 + = (if isFloatType ty then text "PK_DBL" + else text "PK_Word64") + <> parens (mkP_ <> pprExpr1 dflags e) + + | otherwise + = case e of + CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty) + -> char '*' <> pprAsPtrReg r + + CmmRegOff r 0 | isPtrReg r && width == wordWidth platform && not (isFloatType ty) + -> char '*' <> pprAsPtrReg r + + CmmRegOff r off | isPtrReg r && width == wordWidth platform + , off `rem` platformWordSizeInBytes platform == 0 && not (isFloatType ty) + -- ToDo: check that the offset is a word multiple? + -- (For tagging to work, I had to avoid unaligned loads. --ARY) + -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform)) + + _other -> cLoad dflags e ty + where + width = typeWidth ty + platform = targetPlatform dflags + +pprExpr1 :: DynFlags -> CmmExpr -> SDoc +pprExpr1 dflags e = case e of + CmmLit lit -> pprLit1 dflags lit + CmmReg _reg -> pprExpr dflags e + _ -> parens (pprExpr dflags e) + +-- -------------------------------------------------------------------------- +-- MachOp applications + +pprMachOpApp :: DynFlags -> MachOp -> [CmmExpr] -> SDoc + +pprMachOpApp dflags op args + | isMulMayOfloOp op + = text "mulIntMayOflo" <> parens (commafy (map (pprExpr dflags) args)) + where isMulMayOfloOp (MO_U_MulMayOflo _) = True + isMulMayOfloOp (MO_S_MulMayOflo _) = True + isMulMayOfloOp _ = False + +pprMachOpApp dflags mop args + | Just ty <- machOpNeedsCast mop + = ty <> parens (pprMachOpApp' dflags mop args) + | otherwise + = pprMachOpApp' dflags mop args + +-- Comparisons in C have type 'int', but we want type W_ (this is what +-- resultRepOfMachOp says). The other C operations inherit their type +-- from their operands, so no casting is required. +machOpNeedsCast :: MachOp -> Maybe SDoc +machOpNeedsCast mop + | isComparisonMachOp mop = Just mkW_ + | otherwise = Nothing + +pprMachOpApp' :: DynFlags -> MachOp -> [CmmExpr] -> SDoc +pprMachOpApp' dflags mop args + = case args of + -- dyadic + [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y + + -- unary + [x] -> pprMachOp_for_C platform mop <> parens (pprArg x) + + _ -> panic "PprC.pprMachOp : machop with wrong number of args" + + where + platform = targetPlatform dflags + -- Cast needed for signed integer ops + pprArg e | signedOp mop = cCast dflags (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e + | needsFCasts mop = cCast dflags (machRep_F_CType (typeWidth (cmmExprType platform e))) e + | otherwise = pprExpr1 dflags e + needsFCasts (MO_F_Eq _) = False + needsFCasts (MO_F_Ne _) = False + needsFCasts (MO_F_Neg _) = True + needsFCasts (MO_F_Quot _) = True + needsFCasts mop = floatComparison mop + +-- -------------------------------------------------------------------------- +-- Literals + +pprLit :: DynFlags -> CmmLit -> SDoc +pprLit dflags lit = case lit of + CmmInt i rep -> pprHexVal dflags i rep + + CmmFloat f w -> parens (machRep_F_CType w) <> str + where d = fromRational f :: Double + str | isInfinite d && d < 0 = text "-INFINITY" + | isInfinite d = text "INFINITY" + | isNaN d = text "NAN" + | otherwise = text (show d) + -- these constants come from + -- see #1861 + + CmmVec {} -> panic "PprC printing vector literal" + + CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid) + CmmHighStackMark -> panic "PprC printing high stack mark" + CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl + CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i + CmmLabelDiffOff clbl1 _ i _ -- non-word widths not supported via C + -- WARNING: + -- * the lit must occur in the info table clbl2 + -- * clbl1 must be an SRT, a slow entry point or a large bitmap + -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i + + where + pprCLabelAddr lbl = char '&' <> ppr lbl + +pprLit1 :: DynFlags -> CmmLit -> SDoc +pprLit1 dflags lit = case lit of + (CmmLabelOff _ _) -> parens (pprLit dflags lit) + (CmmLabelDiffOff _ _ _ _) -> parens (pprLit dflags lit) + (CmmFloat _ _) -> parens (pprLit dflags lit) + _ -> pprLit dflags lit + +-- --------------------------------------------------------------------------- +-- Static data + +pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] +pprStatics dflags = pprStatics' + where + platform = targetPlatform dflags + pprStatics' = \case + [] -> [] + (CmmStaticLit (CmmFloat f W32) : rest) + -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding + | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest + -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest' + -- adjacent floats aren't padded but combined into a single word + | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest + -> pprLit1 dflags (floatPairToWord platform f g) : pprStatics' rest' + | wordWidth platform == W32 + -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest + | otherwise + -> pprPanic "pprStatics: float" (vcat (map ppr' rest)) + where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l) + ppr' _other = text "bad static!" + + (CmmStaticLit (CmmFloat f W64) : rest) + -> map (pprLit1 dflags) (doubleToWords platform f) ++ pprStatics' rest + + (CmmStaticLit (CmmInt i W64) : rest) + | wordWidth platform == W32 + -> case platformByteOrder platform of + BigEndian -> pprStatics' (CmmStaticLit (CmmInt q W32) : + CmmStaticLit (CmmInt r W32) : rest) + LittleEndian -> pprStatics' (CmmStaticLit (CmmInt r W32) : + CmmStaticLit (CmmInt q W32) : rest) + where r = i .&. 0xffffffff + q = i `shiftR` 32 + + (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest) + | wordWidth platform == W64 + -> case platformByteOrder platform of + BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest) + LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest) + + (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest) + | wordWidth platform == W32 + -> case platformByteOrder platform of + BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest) + LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest) + + (CmmStaticLit (CmmInt _ w) : _) + | w /= wordWidth platform + -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w) + + (CmmStaticLit lit : rest) + -> pprLit1 dflags lit : pprStatics' rest + + (other : _) + -> pprPanic "pprStatics: other" (pprStatic dflags other) + +pprStatic :: DynFlags -> CmmStatic -> SDoc +pprStatic dflags s = case s of + + CmmStaticLit lit -> nest 4 (pprLit dflags lit) + CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) + + -- these should be inlined, like the old .hc + CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s')) + CmmFileEmbed {} -> panic "Unexpected CmmFileEmbed literal" + + +-- --------------------------------------------------------------------------- +-- Block Ids + +pprBlockId :: BlockId -> SDoc +pprBlockId b = char '_' <> ppr (getUnique b) + +-- -------------------------------------------------------------------------- +-- Print a MachOp in a way suitable for emitting via C. +-- + +pprMachOp_for_C :: Platform -> MachOp -> SDoc + +pprMachOp_for_C platform mop = case mop of + + -- Integer operations + MO_Add _ -> char '+' + MO_Sub _ -> char '-' + MO_Eq _ -> text "==" + MO_Ne _ -> text "!=" + MO_Mul _ -> char '*' + + MO_S_Quot _ -> char '/' + MO_S_Rem _ -> char '%' + MO_S_Neg _ -> char '-' + + MO_U_Quot _ -> char '/' + MO_U_Rem _ -> char '%' + + -- & Floating-point operations + MO_F_Add _ -> char '+' + MO_F_Sub _ -> char '-' + MO_F_Neg _ -> char '-' + MO_F_Mul _ -> char '*' + MO_F_Quot _ -> char '/' + + -- Signed comparisons + MO_S_Ge _ -> text ">=" + MO_S_Le _ -> text "<=" + MO_S_Gt _ -> char '>' + MO_S_Lt _ -> char '<' + + -- & Unsigned comparisons + MO_U_Ge _ -> text ">=" + MO_U_Le _ -> text "<=" + MO_U_Gt _ -> char '>' + MO_U_Lt _ -> char '<' + + -- & Floating-point comparisons + MO_F_Eq _ -> text "==" + MO_F_Ne _ -> text "!=" + MO_F_Ge _ -> text ">=" + MO_F_Le _ -> text "<=" + MO_F_Gt _ -> char '>' + MO_F_Lt _ -> char '<' + + -- Bitwise operations. Not all of these may be supported at all + -- sizes, and only integral MachReps are valid. + MO_And _ -> char '&' + MO_Or _ -> char '|' + MO_Xor _ -> char '^' + MO_Not _ -> char '~' + MO_Shl _ -> text "<<" + MO_U_Shr _ -> text ">>" -- unsigned shift right + MO_S_Shr _ -> text ">>" -- signed shift right + +-- Conversions. Some of these will be NOPs, but never those that convert +-- between ints and floats. +-- Floating-point conversions use the signed variant. +-- We won't know to generate (void*) casts here, but maybe from +-- context elsewhere + +-- noop casts + MO_UU_Conv from to | from == to -> empty + MO_UU_Conv _from to -> parens (machRep_U_CType platform to) + + MO_SS_Conv from to | from == to -> empty + MO_SS_Conv _from to -> parens (machRep_S_CType platform to) + + MO_XX_Conv from to | from == to -> empty + MO_XX_Conv _from to -> parens (machRep_U_CType platform to) + + MO_FF_Conv from to | from == to -> empty + MO_FF_Conv _from to -> parens (machRep_F_CType to) + + MO_SF_Conv _from to -> parens (machRep_F_CType to) + MO_FS_Conv _from to -> parens (machRep_S_CType platform to) + + MO_S_MulMayOflo _ -> pprTrace "offending mop:" + (text "MO_S_MulMayOflo") + (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" + ++ " should have been handled earlier!") + MO_U_MulMayOflo _ -> pprTrace "offending mop:" + (text "MO_U_MulMayOflo") + (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo" + ++ " should have been handled earlier!") + + MO_V_Insert {} -> pprTrace "offending mop:" + (text "MO_V_Insert") + (panic $ "PprC.pprMachOp_for_C: MO_V_Insert" + ++ " should have been handled earlier!") + MO_V_Extract {} -> pprTrace "offending mop:" + (text "MO_V_Extract") + (panic $ "PprC.pprMachOp_for_C: MO_V_Extract" + ++ " should have been handled earlier!") + + MO_V_Add {} -> pprTrace "offending mop:" + (text "MO_V_Add") + (panic $ "PprC.pprMachOp_for_C: MO_V_Add" + ++ " should have been handled earlier!") + MO_V_Sub {} -> pprTrace "offending mop:" + (text "MO_V_Sub") + (panic $ "PprC.pprMachOp_for_C: MO_V_Sub" + ++ " should have been handled earlier!") + MO_V_Mul {} -> pprTrace "offending mop:" + (text "MO_V_Mul") + (panic $ "PprC.pprMachOp_for_C: MO_V_Mul" + ++ " should have been handled earlier!") + + MO_VS_Quot {} -> pprTrace "offending mop:" + (text "MO_VS_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot" + ++ " should have been handled earlier!") + MO_VS_Rem {} -> pprTrace "offending mop:" + (text "MO_VS_Rem") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem" + ++ " should have been handled earlier!") + MO_VS_Neg {} -> pprTrace "offending mop:" + (text "MO_VS_Neg") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg" + ++ " should have been handled earlier!") + + MO_VU_Quot {} -> pprTrace "offending mop:" + (text "MO_VU_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot" + ++ " should have been handled earlier!") + MO_VU_Rem {} -> pprTrace "offending mop:" + (text "MO_VU_Rem") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" + ++ " should have been handled earlier!") + + MO_VF_Insert {} -> pprTrace "offending mop:" + (text "MO_VF_Insert") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" + ++ " should have been handled earlier!") + MO_VF_Extract {} -> pprTrace "offending mop:" + (text "MO_VF_Extract") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract" + ++ " should have been handled earlier!") + + MO_VF_Add {} -> pprTrace "offending mop:" + (text "MO_VF_Add") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Add" + ++ " should have been handled earlier!") + MO_VF_Sub {} -> pprTrace "offending mop:" + (text "MO_VF_Sub") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub" + ++ " should have been handled earlier!") + MO_VF_Neg {} -> pprTrace "offending mop:" + (text "MO_VF_Neg") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg" + ++ " should have been handled earlier!") + MO_VF_Mul {} -> pprTrace "offending mop:" + (text "MO_VF_Mul") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul" + ++ " should have been handled earlier!") + MO_VF_Quot {} -> pprTrace "offending mop:" + (text "MO_VF_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot" + ++ " should have been handled earlier!") + + MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend" + +signedOp :: MachOp -> Bool -- Argument type(s) are signed ints +signedOp (MO_S_Quot _) = True +signedOp (MO_S_Rem _) = True +signedOp (MO_S_Neg _) = True +signedOp (MO_S_Ge _) = True +signedOp (MO_S_Le _) = True +signedOp (MO_S_Gt _) = True +signedOp (MO_S_Lt _) = True +signedOp (MO_S_Shr _) = True +signedOp (MO_SS_Conv _ _) = True +signedOp (MO_SF_Conv _ _) = True +signedOp _ = False + +floatComparison :: MachOp -> Bool -- comparison between float args +floatComparison (MO_F_Eq _) = True +floatComparison (MO_F_Ne _) = True +floatComparison (MO_F_Ge _) = True +floatComparison (MO_F_Le _) = True +floatComparison (MO_F_Gt _) = True +floatComparison (MO_F_Lt _) = True +floatComparison _ = False + +-- --------------------------------------------------------------------- +-- tend to be implemented by foreign calls + +pprCallishMachOp_for_C :: CallishMachOp -> SDoc + +pprCallishMachOp_for_C mop + = case mop of + MO_F64_Pwr -> text "pow" + MO_F64_Sin -> text "sin" + MO_F64_Cos -> text "cos" + MO_F64_Tan -> text "tan" + MO_F64_Sinh -> text "sinh" + MO_F64_Cosh -> text "cosh" + MO_F64_Tanh -> text "tanh" + MO_F64_Asin -> text "asin" + MO_F64_Acos -> text "acos" + MO_F64_Atanh -> text "atanh" + MO_F64_Asinh -> text "asinh" + MO_F64_Acosh -> text "acosh" + MO_F64_Atan -> text "atan" + MO_F64_Log -> text "log" + MO_F64_Log1P -> text "log1p" + MO_F64_Exp -> text "exp" + MO_F64_ExpM1 -> text "expm1" + MO_F64_Sqrt -> text "sqrt" + MO_F64_Fabs -> text "fabs" + MO_F32_Pwr -> text "powf" + MO_F32_Sin -> text "sinf" + MO_F32_Cos -> text "cosf" + MO_F32_Tan -> text "tanf" + MO_F32_Sinh -> text "sinhf" + MO_F32_Cosh -> text "coshf" + MO_F32_Tanh -> text "tanhf" + MO_F32_Asin -> text "asinf" + MO_F32_Acos -> text "acosf" + MO_F32_Atan -> text "atanf" + MO_F32_Asinh -> text "asinhf" + MO_F32_Acosh -> text "acoshf" + MO_F32_Atanh -> text "atanhf" + MO_F32_Log -> text "logf" + MO_F32_Log1P -> text "log1pf" + MO_F32_Exp -> text "expf" + MO_F32_ExpM1 -> text "expm1f" + MO_F32_Sqrt -> text "sqrtf" + MO_F32_Fabs -> text "fabsf" + MO_ReadBarrier -> text "load_load_barrier" + MO_WriteBarrier -> text "write_barrier" + MO_Memcpy _ -> text "memcpy" + MO_Memset _ -> text "memset" + MO_Memmove _ -> text "memmove" + MO_Memcmp _ -> text "memcmp" + (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) + (MO_BRev w) -> ptext (sLit $ bRevLabel w) + (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) + (MO_Pext w) -> ptext (sLit $ pextLabel w) + (MO_Pdep w) -> ptext (sLit $ pdepLabel w) + (MO_Clz w) -> ptext (sLit $ clzLabel w) + (MO_Ctz w) -> ptext (sLit $ ctzLabel w) + (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) + (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) + (MO_Xchg w) -> ptext (sLit $ xchgLabel w) + (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) + (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) + (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddWordC {} -> unsupported + MO_SubWordC {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_Touch -> unsupported + (MO_Prefetch_Data _ ) -> unsupported + --- we could support prefetch via "__builtin_prefetch" + --- Not adding it for now + where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop + ++ " not supported!") + +-- --------------------------------------------------------------------- +-- Useful #defines +-- + +mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc + +mkJMP_ i = text "JMP_" <> parens i +mkFN_ i = text "FN_" <> parens i -- externally visible function +mkIF_ i = text "IF_" <> parens i -- locally visible + +-- from includes/Stg.h +-- +mkC_,mkW_,mkP_ :: SDoc + +mkC_ = text "(C_)" -- StgChar +mkW_ = text "(W_)" -- StgWord +mkP_ = text "(P_)" -- StgWord* + +-- --------------------------------------------------------------------- +-- +-- Assignments +-- +-- Generating assignments is what we're all about, here +-- +pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc + +-- dest is a reg, rhs is a reg +pprAssign _ r1 (CmmReg r2) + | isPtrReg r1 && isPtrReg r2 + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] + +-- dest is a reg, rhs is a CmmRegOff +pprAssign dflags r1 (CmmRegOff r2 off) + | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0) + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] + where + platform = targetPlatform dflags + off1 = off `shiftR` wordShift platform + + (op,off') | off >= 0 = (char '+', off1) + | otherwise = (char '-', -off1) + +-- dest is a reg, rhs is anything. +-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting +-- the lvalue elicits a warning from new GCC versions (3.4+). +pprAssign dflags r1 r2 + | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 dflags r2) + | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 dflags r2) + | otherwise = mkAssign (pprExpr dflags r2) + where mkAssign x = if r1 == CmmGlobal BaseReg + then text "ASSIGN_BaseReg" <> parens x <> semi + else pprReg r1 <> text " = " <> x <> semi + +-- --------------------------------------------------------------------- +-- Registers + +pprCastReg :: CmmReg -> SDoc +pprCastReg reg + | isStrangeTypeReg reg = mkW_ <> pprReg reg + | otherwise = pprReg reg + +-- True if (pprReg reg) will give an expression with type StgPtr. We +-- need to take care with pointer arithmetic on registers with type +-- StgPtr. +isFixedPtrReg :: CmmReg -> Bool +isFixedPtrReg (CmmLocal _) = False +isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r + +-- True if (pprAsPtrReg reg) will give an expression with type StgPtr +-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. +-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; +-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. +isPtrReg :: CmmReg -> Bool +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg + +-- True if this global reg has type StgPtr +isFixedPtrGlobalReg :: GlobalReg -> Bool +isFixedPtrGlobalReg Sp = True +isFixedPtrGlobalReg Hp = True +isFixedPtrGlobalReg HpLim = True +isFixedPtrGlobalReg SpLim = True +isFixedPtrGlobalReg _ = False + +-- True if in C this register doesn't have the type given by +-- (machRepCType (cmmRegType reg)), so it has to be cast. +isStrangeTypeReg :: CmmReg -> Bool +isStrangeTypeReg (CmmLocal _) = False +isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g + +isStrangeTypeGlobal :: GlobalReg -> Bool +isStrangeTypeGlobal CCCS = True +isStrangeTypeGlobal CurrentTSO = True +isStrangeTypeGlobal CurrentNursery = True +isStrangeTypeGlobal BaseReg = True +isStrangeTypeGlobal r = isFixedPtrGlobalReg r + +strangeRegType :: CmmReg -> Maybe SDoc +strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *") +strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *") +strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *") +strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *") +strangeRegType _ = Nothing + +-- pprReg just prints the register name. +-- +pprReg :: CmmReg -> SDoc +pprReg r = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +pprAsPtrReg :: CmmReg -> SDoc +pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) + = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p" +pprAsPtrReg other_reg = pprReg other_reg + +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr = case gr of + VanillaReg n _ -> char 'R' <> int n <> text ".w" + -- pprGlobalReg prints a VanillaReg as a .w regardless + -- Example: R1.w = R1.w & (-0x8UL); + -- JMP_(*R1.p); + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + BaseReg -> text "BaseReg" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other + +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq + +-- ----------------------------------------------------------------------------- +-- Foreign Calls + +pprCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCall dflags ppr_fn cconv results args + | not (is_cishCC cconv) + = panic $ "pprCall: unknown calling convention" + + | otherwise + = + ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi + where + platform = targetPlatform dflags + + ppr_assign [] rhs = rhs + ppr_assign [(one,hint)] rhs + = pprLocalReg one <> text " = " + <> pprUnHint hint (localRegType one) <> rhs + ppr_assign _other _rhs = panic "pprCall: multiple results" + + pprArg (expr, AddrHint) + = cCast dflags (text "void *") expr + -- see comment by machRepHintCType below + pprArg (expr, SignedHint) + = cCast dflags (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr + pprArg (expr, _other) + = pprExpr dflags expr + + pprUnHint AddrHint rep = parens (machRepCType platform rep) + pprUnHint SignedHint rep = parens (machRepCType platform rep) + pprUnHint _ _ = empty + +-- Currently we only have these two calling conventions, but this might +-- change in the future... +is_cishCC :: CCallConv -> Bool +is_cishCC CCallConv = True +is_cishCC CApiConv = True +is_cishCC StdCallConv = True +is_cishCC PrimCallConv = False +is_cishCC JavaScriptCallConv = False + +-- --------------------------------------------------------------------- +-- Find and print local and external declarations for a list of +-- Cmm statements. +-- +pprTempAndExternDecls :: Platform -> [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls platform stmts + = (pprUFM (getUniqSet temps) (vcat . map (pprTempDecl platform)), + vcat (map (pprExternDecl platform) (Map.keys lbls))) + where (temps, lbls) = runTE (mapM_ te_BB stmts) + +pprDataExterns :: Platform -> [CmmStatic] -> SDoc +pprDataExterns platform statics + = vcat (map (pprExternDecl platform) (Map.keys lbls)) + where (_, lbls) = runTE (mapM_ te_Static statics) + +pprTempDecl :: Platform -> LocalReg -> SDoc +pprTempDecl platform l@(LocalReg _ rep) + = hcat [ machRepCType platform rep, space, pprLocalReg l, semi ] + +pprExternDecl :: Platform -> CLabel -> SDoc +pprExternDecl platform lbl + -- do not print anything for "known external" things + | not (needsCDecl lbl) = empty + | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz + | otherwise = + hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");" + -- occasionally useful to see label type + -- , text "/* ", pprDebugCLabel lbl, text " */" + ] + where + label_type lbl | isBytesLabel lbl = text "B_" + | isForeignLabel lbl && isCFunctionLabel lbl + = text "FF_" + | isCFunctionLabel lbl = text "F_" + | isStaticClosureLabel lbl = text "C_" + -- generic .rodata labels + | isSomeRODataLabel lbl = text "RO_" + -- generic .data labels (common case) + | otherwise = text "RW_" + + visibility + | externallyVisibleCLabel lbl = char 'E' + | otherwise = char 'I' + + -- If the label we want to refer to is a stdcall function (on Windows) then + -- we must generate an appropriate prototype for it, so that the C compiler will + -- add the @n suffix to the label (#2276) + stdcall_decl sz = + text "extern __attribute__((stdcall)) void " <> ppr lbl + <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform)))) + <> semi + +type TEState = (UniqSet LocalReg, Map CLabel ()) +newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor) + +instance Applicative TE where + pure a = TE $ \s -> (a, s) + (<*>) = ap + +instance Monad TE where + TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s' + +te_lbl :: CLabel -> TE () +te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) + +te_temp :: LocalReg -> TE () +te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) + +runTE :: TE () -> TEState +runTE (TE m) = snd (m (emptyUniqSet, Map.empty)) + +te_Static :: CmmStatic -> TE () +te_Static (CmmStaticLit lit) = te_Lit lit +te_Static _ = return () + +te_BB :: CmmBlock -> TE () +te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last + where (_, mid, last) = blockSplit block + +te_Lit :: CmmLit -> TE () +te_Lit (CmmLabel l) = te_lbl l +te_Lit (CmmLabelOff l _) = te_lbl l +te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1 +te_Lit _ = return () + +te_Stmt :: CmmNode e x -> TE () +te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e +te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r +te_Stmt (CmmUnsafeForeignCall target rs es) + = do te_Target target + mapM_ te_temp rs + mapM_ te_Expr es +te_Stmt (CmmCondBranch e _ _ _) = te_Expr e +te_Stmt (CmmSwitch e _) = te_Expr e +te_Stmt (CmmCall { cml_target = e }) = te_Expr e +te_Stmt _ = return () + +te_Target :: ForeignTarget -> TE () +te_Target (ForeignTarget e _) = te_Expr e +te_Target (PrimTarget{}) = return () + +te_Expr :: CmmExpr -> TE () +te_Expr (CmmLit lit) = te_Lit lit +te_Expr (CmmLoad e _) = te_Expr e +te_Expr (CmmReg r) = te_Reg r +te_Expr (CmmMachOp _ es) = mapM_ te_Expr es +te_Expr (CmmRegOff r _) = te_Reg r +te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!" + +te_Reg :: CmmReg -> TE () +te_Reg (CmmLocal l) = te_temp l +te_Reg _ = return () + + +-- --------------------------------------------------------------------- +-- C types for MachReps + +cCast :: DynFlags -> SDoc -> CmmExpr -> SDoc +cCast dflags ty expr = parens ty <> pprExpr1 dflags expr + +cLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc +cLoad dflags expr rep + = if bewareLoadStoreAlignment (platformArch platform) + then let decl = machRepCType platform rep <+> text "x" <> semi + struct = text "struct" <+> braces (decl) + packed_attr = text "__attribute__((packed))" + cast = parens (struct <+> packed_attr <> char '*') + in parens (cast <+> pprExpr1 dflags expr) <> text "->x" + else char '*' <> parens (cCast dflags (machRepPtrCType platform rep) expr) + where -- On these platforms, unaligned loads are known to cause problems + bewareLoadStoreAlignment ArchAlpha = True + bewareLoadStoreAlignment ArchMipseb = True + bewareLoadStoreAlignment ArchMipsel = True + bewareLoadStoreAlignment (ArchARM {}) = True + bewareLoadStoreAlignment ArchAArch64 = True + bewareLoadStoreAlignment ArchSPARC = True + bewareLoadStoreAlignment ArchSPARC64 = True + -- Pessimistically assume that they will also cause problems + -- on unknown arches + bewareLoadStoreAlignment ArchUnknown = True + bewareLoadStoreAlignment _ = False + platform = targetPlatform dflags + +isCmmWordType :: Platform -> CmmType -> Bool +-- True of GcPtrReg/NonGcReg of native word size +isCmmWordType platform ty = not (isFloatType ty) + && typeWidth ty == wordWidth platform + +-- This is for finding the types of foreign call arguments. For a pointer +-- argument, we always cast the argument to (void *), to avoid warnings from +-- the C compiler. +machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc +machRepHintCType platform rep = \case + AddrHint -> text "void *" + SignedHint -> machRep_S_CType platform (typeWidth rep) + _other -> machRepCType platform rep + +machRepPtrCType :: Platform -> CmmType -> SDoc +machRepPtrCType platform r + = if isCmmWordType platform r + then text "P_" + else machRepCType platform r <> char '*' + +machRepCType :: Platform -> CmmType -> SDoc +machRepCType platform ty + | isFloatType ty = machRep_F_CType w + | otherwise = machRep_U_CType platform w + where + w = typeWidth ty + +machRep_F_CType :: Width -> SDoc +machRep_F_CType W32 = text "StgFloat" -- ToDo: correct? +machRep_F_CType W64 = text "StgDouble" +machRep_F_CType _ = panic "machRep_F_CType" + +machRep_U_CType :: Platform -> Width -> SDoc +machRep_U_CType platform w + = case w of + _ | w == wordWidth platform -> text "W_" + W8 -> text "StgWord8" + W16 -> text "StgWord16" + W32 -> text "StgWord32" + W64 -> text "StgWord64" + _ -> panic "machRep_U_CType" + +machRep_S_CType :: Platform -> Width -> SDoc +machRep_S_CType platform w + = case w of + _ | w == wordWidth platform -> text "I_" + W8 -> text "StgInt8" + W16 -> text "StgInt16" + W32 -> text "StgInt32" + W64 -> text "StgInt64" + _ -> panic "machRep_S_CType" + + +-- --------------------------------------------------------------------- +-- print strings as valid C strings + +pprStringInCStyle :: ByteString -> SDoc +pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s))) + +-- --------------------------------------------------------------------------- +-- Initialising static objects with floating-point numbers. We can't +-- just emit the floating point number, because C will cast it to an int +-- by rounding it. We want the actual bit-representation of the float. +-- +-- Consider a concrete C example: +-- double d = 2.5e-10; +-- float f = 2.5e-10f; +-- +-- int * i2 = &d; printf ("i2: %08X %08X\n", i2[0], i2[1]); +-- long long * l = &d; printf (" l: %016llX\n", l[0]); +-- int * i = &f; printf (" i: %08X\n", i[0]); +-- Result on 64-bit LE (x86_64): +-- i2: E826D695 3DF12E0B +-- l: 3DF12E0BE826D695 +-- i: 2F89705F +-- Result on 32-bit BE (m68k): +-- i2: 3DF12E0B E826D695 +-- l: 3DF12E0BE826D695 +-- i: 2F89705F +-- +-- The trick here is to notice that binary representation does not +-- change much: only Word32 values get swapped on LE hosts / targets. + +-- This is a hack to turn the floating point numbers into ints that we +-- can safely initialise to static locations. + +castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32) +castFloatToWord32Array = U.castSTUArray + +castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64) +castDoubleToWord64Array = U.castSTUArray + +floatToWord :: Platform -> Rational -> CmmLit +floatToWord platform r + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 (fromRational r) + arr' <- castFloatToWord32Array arr + w32 <- readArray arr' 0 + return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform)) + ) + where wo | wordWidth platform == W64 + , BigEndian <- platformByteOrder platform + = 32 + | otherwise + = 0 + +floatPairToWord :: Platform -> Rational -> Rational -> CmmLit +floatPairToWord platform r1 r2 + = runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 (fromRational r1) + writeArray arr 1 (fromRational r2) + arr' <- castFloatToWord32Array arr + w32_1 <- readArray arr' 0 + w32_2 <- readArray arr' 1 + return (pprWord32Pair w32_1 w32_2) + ) + where pprWord32Pair w32_1 w32_2 + | BigEndian <- platformByteOrder platform = + CmmInt ((shiftL i1 32) .|. i2) W64 + | otherwise = + CmmInt ((shiftL i2 32) .|. i1) W64 + where i1 = toInteger w32_1 + i2 = toInteger w32_2 + +doubleToWords :: Platform -> Rational -> [CmmLit] +doubleToWords platform r + = runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 (fromRational r) + arr' <- castDoubleToWord64Array arr + w64 <- readArray arr' 0 + return (pprWord64 w64) + ) + where targetWidth = wordWidth platform + pprWord64 w64 + | targetWidth == W64 = + [ CmmInt (toInteger w64) targetWidth ] + | targetWidth == W32 = + [ CmmInt (toInteger targetW1) targetWidth + , CmmInt (toInteger targetW2) targetWidth + ] + | otherwise = panic "doubleToWords.pprWord64" + where (targetW1, targetW2) = case platformByteOrder platform of + BigEndian -> (wHi, wLo) + LittleEndian -> (wLo, wHi) + wHi = w64 `shiftR` 32 + wLo = w64 .&. 0xFFFFffff + +-- --------------------------------------------------------------------------- +-- Utils + +wordShift :: Platform -> Int +wordShift platform = widthInLog (wordWidth platform) + +commafy :: [SDoc] -> SDoc +commafy xs = hsep $ punctuate comma xs + +-- Print in C hex format: 0x13fa +pprHexVal :: DynFlags -> Integer -> Width -> SDoc +pprHexVal dflags w rep + | w < 0 = parens (char '-' <> + text "0x" <> intToDoc (-w) <> repsuffix rep) + | otherwise = text "0x" <> intToDoc w <> repsuffix rep + where + -- type suffix for literals: + -- Integer literals are unsigned in Cmm/C. We explicitly cast to + -- signed values for doing signed operations, but at all other + -- times values are unsigned. This also helps eliminate occasional + -- warnings about integer overflow from gcc. + + repsuffix W64 = + if cINT_SIZE dflags == 8 then char 'U' + else if cLONG_SIZE dflags == 8 then text "UL" + else if cLONG_LONG_SIZE dflags == 8 then text "ULL" + else panic "pprHexVal: Can't find a 64-bit type" + repsuffix _ = char 'U' + + intToDoc :: Integer -> SDoc + intToDoc i = case truncInt i of + 0 -> char '0' + v -> go v + + -- We need to truncate value as Cmm backend does not drop + -- redundant bits to ease handling of negative values. + -- Thus the following Cmm code on 64-bit arch, like amd64: + -- CInt v; + -- v = {something}; + -- if (v == %lobits32(-1)) { ... + -- leads to the following C code: + -- StgWord64 v = (StgWord32)({something}); + -- if (v == 0xFFFFffffFFFFffffU) { ... + -- Such code is incorrect as it promotes both operands to StgWord64 + -- and the whole condition is always false. + truncInt :: Integer -> Integer + truncInt i = + case rep of + W8 -> i `rem` (2^(8 :: Int)) + W16 -> i `rem` (2^(16 :: Int)) + W32 -> i `rem` (2^(32 :: Int)) + W64 -> i `rem` (2^(64 :: Int)) + _ -> panic ("pprHexVal/truncInt: C backend can't encode " + ++ show rep ++ " literals") + + go 0 = empty + go w' = go q <> dig + where + (q,r) = w' `quotRem` 16 + dig | r < 10 = char (chr (fromInteger r + ord '0')) + | otherwise = char (chr (fromInteger r - 10 + ord 'a')) diff --git a/GHC/CmmToLlvm.hs b/GHC/CmmToLlvm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-} + +-- ----------------------------------------------------------------------------- +-- | This is the top-level module in the LLVM code generator. +-- +module GHC.CmmToLlvm + ( LlvmVersion + , llvmVersionList + , llvmCodeGen + , llvmFixupAsm + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.CodeGen +import GHC.CmmToLlvm.Data +import GHC.CmmToLlvm.Ppr +import GHC.CmmToLlvm.Regs +import GHC.CmmToLlvm.Mangler + +import GHC.StgToCmm.CgUtils ( fixStgRegisters ) +import GHC.Cmm +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Ppr + +import GHC.Utils.BufHandle +import GHC.Driver.Session +import GHC.Platform ( platformArch, Arch(..) ) +import GHC.Utils.Error +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.SysTools ( figureLlvmVersion ) +import qualified GHC.Data.Stream as Stream + +import Control.Monad ( when, forM_ ) +import Data.Maybe ( fromMaybe, catMaybes ) +import System.IO + +-- ----------------------------------------------------------------------------- +-- | Top-level of the LLVM Code generator +-- +llvmCodeGen :: DynFlags -> Handle + -> Stream.Stream IO RawCmmGroup a + -> IO a +llvmCodeGen dflags h cmm_stream + = withTiming dflags (text "LLVM CodeGen") (const ()) $ do + bufh <- newBufHandle h + + -- Pass header + showPass dflags "LLVM CodeGen" + + -- get llvm version, cache for later use + mb_ver <- figureLlvmVersion dflags + + -- warn if unsupported + forM_ mb_ver $ \ver -> do + debugTraceMsg dflags 2 + (text "Using LLVM version:" <+> text (llvmVersionStr ver)) + let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags + when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $ + "You are using an unsupported version of LLVM!" $$ + "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+> + "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+> + "System LLVM version: " <> text (llvmVersionStr ver) $$ + "We will try though..." + let isS390X = platformArch (targetPlatform dflags) == ArchS390X + let major_ver = head . llvmVersionList $ ver + when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $ + "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> + "You are using LLVM version: " <> text (llvmVersionStr ver) + + -- HACK: the Nothing case here is potentially wrong here but we + -- currently don't use the LLVM version to guide code generation + -- so this is okay. + let llvm_ver :: LlvmVersion + llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver + + -- run code generation + a <- runLlvm dflags llvm_ver bufh $ + llvmCodeGen' dflags (liftStream cmm_stream) + + bFlush bufh + + return a + +llvmCodeGen' :: DynFlags -> Stream.Stream LlvmM RawCmmGroup a -> LlvmM a +llvmCodeGen' dflags cmm_stream + = do -- Preamble + renderLlvm header + ghcInternalFunctions + cmmMetaLlvmPrelude + + -- Procedures + a <- Stream.consume cmm_stream llvmGroupLlvmGens + + -- Declare aliases for forward references + opts <- getLlvmOpts + renderLlvm . pprLlvmData opts =<< generateExternDecls + + -- Postamble + cmmUsedLlvmGens + + return a + where + header :: SDoc + header = + let target = platformMisc_llvmTarget $ platformMisc dflags + in text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"") + $+$ text ("target triple = \"" ++ target ++ "\"") + + getDataLayout :: LlvmConfig -> String -> String + getDataLayout config target = + case lookup target (llvmTargets config) of + Just (LlvmTarget {lDataLayout=dl}) -> dl + Nothing -> pprPanic "Failed to lookup LLVM data layout" $ + text "Target:" <+> text target $$ + hang (text "Available targets:") 4 + (vcat $ map (text . fst) $ llvmTargets config) + +llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () +llvmGroupLlvmGens cmm = do + + -- Insert functions into map, collect data + let split (CmmData s d' ) = return $ Just (s, d') + split (CmmProc h l live g) = do + -- Set function type + let l' = case mapLookup (g_entry g) h :: Maybe RawCmmStatics of + Nothing -> l + Just (CmmStaticsRaw info_lbl _) -> info_lbl + lml <- strCLabel_llvm l' + funInsert lml =<< llvmFunTy live + return Nothing + cdata <- fmap catMaybes $ mapM split cmm + + {-# SCC "llvm_datas_gen" #-} + cmmDataLlvmGens cdata + {-# SCC "llvm_procs_gen" #-} + mapM_ cmmLlvmGen cmm + +-- ----------------------------------------------------------------------------- +-- | Do LLVM code generation on all these Cmms data sections. +-- +cmmDataLlvmGens :: [(Section,RawCmmStatics)] -> LlvmM () + +cmmDataLlvmGens statics + = do lmdatas <- mapM genLlvmData statics + + let (concat -> gs, tss) = unzip lmdatas + + let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _) + = funInsert l ty + regGlobal _ = pure () + mapM_ regGlobal gs + gss' <- mapM aliasify $ gs + + opts <- getLlvmOpts + renderLlvm $ pprLlvmData opts (concat gss', concat tss) + +-- | Complete LLVM code generation phase for a single top-level chunk of Cmm. +cmmLlvmGen ::RawCmmDecl -> LlvmM () +cmmLlvmGen cmm@CmmProc{} = do + + -- rewrite assignments to global regs + dflags <- getDynFlags + let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm + + dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" + FormatCMM (pprCmmGroup [fixed_cmm]) + + -- generate llvm code from cmm + llvmBC <- withClearVars $ genLlvmProc fixed_cmm + + -- pretty print + (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC + + -- Output, note down used variables + renderLlvm (vcat docs) + mapM_ markUsedVar $ concat ivars + +cmmLlvmGen _ = return () + +-- ----------------------------------------------------------------------------- +-- | Generate meta data nodes +-- + +cmmMetaLlvmPrelude :: LlvmM () +cmmMetaLlvmPrelude = do + metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do + -- Generate / lookup meta data IDs + tbaaId <- getMetaUniqueId + setUniqMeta uniq tbaaId + parentId <- maybe (return Nothing) getUniqMeta parent + -- Build definition + return $ MetaUnnamed tbaaId $ MetaStruct $ + case parentId of + Just p -> [ MetaStr name, MetaNode p ] + -- As of LLVM 4.0, a node without parents should be rendered as + -- just a name on its own. Previously `null` was accepted as the + -- name. + Nothing -> [ MetaStr name ] + opts <- getLlvmOpts + renderLlvm $ ppLlvmMetas opts metas + +-- ----------------------------------------------------------------------------- +-- | Marks variables as used where necessary +-- + +cmmUsedLlvmGens :: LlvmM () +cmmUsedLlvmGens = do + + -- LLVM would discard variables that are internal and not obviously + -- used if we didn't provide these hints. This will generate a + -- definition of the form + -- + -- @llvm.used = appending global [42 x i8*] [i8* bitcast to i8*, ...] + -- + -- Which is the LLVM way of protecting them against getting removed. + ivars <- getUsedVars + let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = (LMArray (length ivars) i8Ptr) + usedArray = LMStaticArray (map cast ivars) ty + sectName = Just $ fsLit "llvm.metadata" + lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant + lmUsed = LMGlobal lmUsedVar (Just usedArray) + opts <- getLlvmOpts + if null ivars + then return () + else renderLlvm $ pprLlvmData opts ([lmUsed], []) diff --git a/GHC/CmmToLlvm/Base.hs b/GHC/CmmToLlvm/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Base.hs @@ -0,0 +1,664 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ---------------------------------------------------------------------------- +-- | Base LLVM Code Generation module +-- +-- Contains functions useful through out the code generator. +-- + +module GHC.CmmToLlvm.Base ( + + LlvmCmmDecl, LlvmBasicBlock, + LiveGlobalRegs, + LlvmUnresData, LlvmData, UnresLabel, UnresStatic, + + LlvmVersion, llvmVersionSupported, parseLlvmVersion, + supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, + llvmVersionStr, llvmVersionList, + + LlvmM, + runLlvm, liftStream, withClearVars, varLookup, varInsert, + markStackReg, checkStackReg, + funLookup, funInsert, getLlvmVer, getDynFlags, + dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars, + ghcInternalFunctions, getPlatform, getLlvmOpts, + + getMetaUniqueId, + setUniqMeta, getUniqMeta, + + cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, + llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, + llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR, + + strCLabel_llvm, + getGlobalPtr, generateExternDecls, + + aliasify, llvmDefLabel + ) where + +#include "HsVersions.h" +#include "ghcautoconf.h" + +import GHC.Prelude +import GHC.Utils.Panic + +import GHC.Llvm +import GHC.CmmToLlvm.Regs + +import GHC.Cmm.CLabel +import GHC.Cmm.Ppr.Expr () +import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Cmm hiding ( succ ) +import GHC.Cmm.Utils (regsOverlap) +import GHC.Utils.Outputable as Outp +import GHC.Platform +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Utils.BufHandle ( BufHandle ) +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply +import GHC.Utils.Error +import qualified GHC.Data.Stream as Stream + +import Data.Maybe (fromJust) +import Control.Monad (ap) +import Data.Char (isDigit) +import Data.List (sortBy, groupBy, intercalate) +import Data.Ord (comparing) +import qualified Data.List.NonEmpty as NE + +-- ---------------------------------------------------------------------------- +-- * Some Data Types +-- + +type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement) +type LlvmBasicBlock = GenBasicBlock LlvmStatement + +-- | Global registers live on proc entry +type LiveGlobalRegs = [GlobalReg] + +-- | Unresolved code. +-- Of the form: (data label, data type, unresolved data) +type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) + +-- | Top level LLVM Data (globals and type aliases) +type LlvmData = ([LMGlobal], [LlvmType]) + +-- | An unresolved Label. +-- +-- Labels are unresolved when we haven't yet determined if they are defined in +-- the module we are currently compiling, or an external one. +type UnresLabel = CmmLit +type UnresStatic = Either UnresLabel LlvmStatic + +-- ---------------------------------------------------------------------------- +-- * Type translations +-- + +-- | Translate a basic CmmType to an LlvmType. +cmmToLlvmType :: CmmType -> LlvmType +cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty)) + | isFloatType ty = widthToLlvmFloat $ typeWidth ty + | otherwise = widthToLlvmInt $ typeWidth ty + +-- | Translate a Cmm Float Width to a LlvmType. +widthToLlvmFloat :: Width -> LlvmType +widthToLlvmFloat W32 = LMFloat +widthToLlvmFloat W64 = LMDouble +widthToLlvmFloat W128 = LMFloat128 +widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w + +-- | Translate a Cmm Bit Width to a LlvmType. +widthToLlvmInt :: Width -> LlvmType +widthToLlvmInt w = LMInt $ widthInBits w + +-- | GHC Call Convention for LLVM +llvmGhcCC :: Platform -> LlvmCallConvention +llvmGhcCC platform + | platformUnregisterised platform = CC_Ccc + | otherwise = CC_Ghc + +-- | Llvm Function type for Cmm function +llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType +llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible + +-- | Llvm Function signature +llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig live lbl link = do + lbl' <- strCLabel_llvm lbl + llvmFunSig' live lbl' link + +llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig' live lbl link + = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) + | otherwise = (x, []) + platform <- getPlatform + return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs + (map (toParams . getVarType) (llvmFunArgs platform live)) + (llvmFunAlign platform) + +-- | Alignment to use for functions +llvmFunAlign :: Platform -> LMAlign +llvmFunAlign platform = Just (platformWordSizeInBytes platform) + +-- | Alignment to use for into tables +llvmInfAlign :: Platform -> LMAlign +llvmInfAlign platform = Just (platformWordSizeInBytes platform) + +-- | Section to use for a function +llvmFunSection :: LlvmOpts -> LMString -> LMSection +llvmFunSection opts lbl + | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl]) + | otherwise = Nothing + +-- | A Function's arguments +llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar] +llvmFunArgs platform live = + map (lmGlobalRegArg platform) (filter isPassed allRegs) + where allRegs = activeStgRegs platform + paddingRegs = padLiveArgs platform live + isLive r = r `elem` alwaysLive + || r `elem` live + || r `elem` paddingRegs + isPassed r = not (isFPR r) || isLive r + + +isFPR :: GlobalReg -> Bool +isFPR (FloatReg _) = True +isFPR (DoubleReg _) = True +isFPR (XmmReg _) = True +isFPR (YmmReg _) = True +isFPR (ZmmReg _) = True +isFPR _ = False + +-- | Return a list of "padding" registers for LLVM function calls. +-- +-- When we generate LLVM function signatures, we can't just make any register +-- alive on function entry. Instead, we need to insert fake arguments of the +-- same register class until we are sure that one of them is mapped to the +-- register we want alive. E.g. to ensure that F5 is alive, we may need to +-- insert fake arguments mapped to F1, F2, F3 and F4. +-- +-- Invariant: Cmm FPR regs with number "n" maps to real registers with number +-- "n" If the calling convention uses registers in a different order or if the +-- invariant doesn't hold, this code probably won't be correct. +padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs +padLiveArgs platform live = + if platformUnregisterised platform + then [] -- not using GHC's register convention for platform. + else padded + where + ---------------------------------- + -- handle floating-point registers (FPR) + + fprLive = filter isFPR live -- real live FPR registers + + -- we group live registers sharing the same classes, i.e. that use the same + -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg + -- all use the same real regs on X86-64 (XMM registers). + -- + classes = groupBy sharesClass fprLive + sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers + norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family + + -- For each class, we just have to fill missing registers numbers. We use + -- the constructor of the greatest register to build padding registers. + -- + -- E.g. sortedRs = [ F2, XMM4, D5] + -- output = [D1, D3] + padded = concatMap padClass classes + padClass rs = go sortedRs [1..] + where + sortedRs = sortBy (comparing fpr_num) rs + maxr = last sortedRs + ctor = fpr_ctor maxr + + go [] _ = [] + go (c1:c2:_) _ -- detect bogus case (see #17920) + | fpr_num c1 == fpr_num c2 + , Just real <- globalRegMaybe platform c1 + = sorryDoc "LLVM code generator" $ + text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <> + text ") both alive AND mapped to the same real register: " <> ppr real <> + text ". This isn't currently supported by the LLVM backend." + go (c:cs) (f:fs) + | fpr_num c == f = go cs fs -- already covered by a real register + | otherwise = ctor f : go (c:cs) fs -- add padding register + go _ _ = undefined -- unreachable + + fpr_ctor :: GlobalReg -> Int -> GlobalReg + fpr_ctor (FloatReg _) = FloatReg + fpr_ctor (DoubleReg _) = DoubleReg + fpr_ctor (XmmReg _) = XmmReg + fpr_ctor (YmmReg _) = YmmReg + fpr_ctor (ZmmReg _) = ZmmReg + fpr_ctor _ = error "fpr_ctor expected only FPR regs" + + fpr_num :: GlobalReg -> Int + fpr_num (FloatReg i) = i + fpr_num (DoubleReg i) = i + fpr_num (XmmReg i) = i + fpr_num (YmmReg i) = i + fpr_num (ZmmReg i) = i + fpr_num _ = error "fpr_num expected only FPR regs" + + +-- | Llvm standard fun attributes +llvmStdFunAttrs :: [LlvmFuncAttr] +llvmStdFunAttrs = [NoUnwind] + +-- | Convert a list of types to a list of function parameters +-- (each with no parameter attributes) +tysToParams :: [LlvmType] -> [LlvmParameter] +tysToParams = map (\ty -> (ty, [])) + +-- | Pointer width +llvmPtrBits :: Platform -> Int +llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform + +-- ---------------------------------------------------------------------------- +-- * Llvm Version +-- + +newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } + deriving (Eq, Ord) + +parseLlvmVersion :: String -> Maybe LlvmVersion +parseLlvmVersion = + fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit) + where + go vs s + | null ver_str + = reverse vs + | '.' : rest' <- rest + = go (read ver_str : vs) rest' + | otherwise + = reverse (read ver_str : vs) + where + (ver_str, rest) = span isDigit s + +-- | The (inclusive) lower bound on the LLVM Version that is currently supported. +supportedLlvmVersionLowerBound :: LlvmVersion +supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) + +-- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. +supportedLlvmVersionUpperBound :: LlvmVersion +supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) + +llvmVersionSupported :: LlvmVersion -> Bool +llvmVersionSupported v = + v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound + +llvmVersionStr :: LlvmVersion -> String +llvmVersionStr = intercalate "." . map show . llvmVersionList + +llvmVersionList :: LlvmVersion -> [Int] +llvmVersionList = NE.toList . llvmVersionNE + +-- ---------------------------------------------------------------------------- +-- * Environment Handling +-- + +data LlvmEnv = LlvmEnv + { envVersion :: LlvmVersion -- ^ LLVM version + , envOpts :: LlvmOpts -- ^ LLVM backend options + , envDynFlags :: DynFlags -- ^ Dynamic flags + , envOutput :: BufHandle -- ^ Output buffer + , envMask :: !Char -- ^ Mask for creating unique values + , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs + , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes + , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type + , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] + , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) + + -- the following get cleared for every function (see @withClearVars@) + , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type + , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) + } + +type LlvmEnvMap = UniqFM Unique LlvmType + +-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad +newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } + deriving (Functor) + +instance Applicative LlvmM where + pure x = LlvmM $ \env -> return (x, env) + (<*>) = ap + +instance Monad LlvmM where + m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env + runLlvmM (f x) env' + +instance HasDynFlags LlvmM where + getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) + +-- | Get target platform +getPlatform :: LlvmM Platform +getPlatform = llvmOptsPlatform <$> getLlvmOpts + +-- | Get LLVM options +getLlvmOpts :: LlvmM LlvmOpts +getLlvmOpts = LlvmM $ \env -> return (envOpts env, env) + +instance MonadUnique LlvmM where + getUniqueSupplyM = do + mask <- getEnv envMask + liftIO $! mkSplitUniqSupply mask + + getUniqueM = do + mask <- getEnv envMask + liftIO $! uniqFromMask mask + +-- | Lifting of IO actions. Not exported, as we want to encapsulate IO. +liftIO :: IO a -> LlvmM a +liftIO m = LlvmM $ \env -> do x <- m + return (x, env) + +-- | Get initial Llvm environment. +runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a +runLlvm dflags ver out m = do + (a, _) <- runLlvmM m env + return a + where env = LlvmEnv { envFunMap = emptyUFM + , envVarMap = emptyUFM + , envStackRegs = [] + , envUsedVars = [] + , envAliases = emptyUniqSet + , envVersion = ver + , envOpts = initLlvmOpts dflags + , envDynFlags = dflags + , envOutput = out + , envMask = 'n' + , envFreshMeta = MetaId 0 + , envUniqMeta = emptyUFM + } + +-- | Get environment (internal) +getEnv :: (LlvmEnv -> a) -> LlvmM a +getEnv f = LlvmM (\env -> return (f env, env)) + +-- | Modify environment (internal) +modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () +modifyEnv f = LlvmM (\env -> return ((), f env)) + +-- | Lift a stream into the LlvmM monad +liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x +liftStream s = Stream.Stream $ do + r <- liftIO $ Stream.runStream s + case r of + Left b -> return (Left b) + Right (a, r2) -> return (Right (a, liftStream r2)) + +-- | Clear variables from the environment for a subcomputation +withClearVars :: LlvmM a -> LlvmM a +withClearVars m = LlvmM $ \env -> do + (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } + return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) + +-- | Insert variables or functions into the environment. +varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () +varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) (getUnique s) t } +funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) (getUnique s) t } + +-- | Lookup variables or functions in the environment. +varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) +varLookup s = getEnv (flip lookupUFM (getUnique s) . envVarMap) +funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap) + +-- | Set a register as allocated on the stack +markStackReg :: GlobalReg -> LlvmM () +markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } + +-- | Check whether a register is allocated on the stack +checkStackReg :: GlobalReg -> LlvmM Bool +checkStackReg r = getEnv ((elem r) . envStackRegs) + +-- | Allocate a new global unnamed metadata identifier +getMetaUniqueId :: LlvmM MetaId +getMetaUniqueId = LlvmM $ \env -> + return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env }) + +-- | Get the LLVM version we are generating code for +getLlvmVer :: LlvmM LlvmVersion +getLlvmVer = getEnv envVersion + +-- | Dumps the document if the corresponding flag has been set by the user +dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () +dumpIfSetLlvm flag hdr fmt doc = do + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc + +-- | Prints the given contents to the output handle +renderLlvm :: Outp.SDoc -> LlvmM () +renderLlvm sdoc = do + + -- Write to output + dflags <- getDynFlags + out <- getEnv envOutput + let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle) + liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc + + -- Dump, if requested + dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc + return () + +-- | Marks a variable as "used" +markUsedVar :: LlvmVar -> LlvmM () +markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } + +-- | Return all variables marked as "used" so far +getUsedVars :: LlvmM [LlvmVar] +getUsedVars = getEnv envUsedVars + +-- | Saves that at some point we didn't know the type of the label and +-- generated a reference to a type variable instead +saveAlias :: LMString -> LlvmM () +saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } + +-- | Sets metadata node for a given unique +setUniqMeta :: Unique -> MetaId -> LlvmM () +setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } + +-- | Gets metadata node for given unique +getUniqMeta :: Unique -> LlvmM (Maybe MetaId) +getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) + +-- ---------------------------------------------------------------------------- +-- * Internal functions +-- + +-- | Here we pre-initialise some functions that are used internally by GHC +-- so as to make sure they have the most general type in the case that +-- user code also uses these functions but with a different type than GHC +-- internally. (Main offender is treating return type as 'void' instead of +-- 'void *'). Fixes trac #5486. +ghcInternalFunctions :: LlvmM () +ghcInternalFunctions = do + platform <- getPlatform + dflags <- getDynFlags + let w = llvmWord platform + cint = LMInt $ widthInBits $ cIntWidth dflags + mk "memcmp" cint [i8Ptr, i8Ptr, w] + mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w] + mk "memmove" i8Ptr [i8Ptr, i8Ptr, w] + mk "memset" i8Ptr [i8Ptr, w, w] + mk "newSpark" w [i8Ptr, i8Ptr] + where + mk n ret args = do + let n' = fsLit n + decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret + FixedArgs (tysToParams args) Nothing + renderLlvm $ ppLlvmFunctionDecl decl + funInsert n' (LMFunction decl) + +-- ---------------------------------------------------------------------------- +-- * Label handling +-- + +-- | Pretty print a 'CLabel'. +strCLabel_llvm :: CLabel -> LlvmM LMString +strCLabel_llvm lbl = do + dflags <- getDynFlags + let sdoc = pprCLabel dflags lbl + str = Outp.renderWithStyle + (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)) + sdoc + return (fsLit str) + +-- ---------------------------------------------------------------------------- +-- * Global variables / forward references +-- + +-- | Create/get a pointer to a global value. Might return an alias if +-- the value in question hasn't been defined yet. We especially make +-- no guarantees on the type of the returned pointer. +getGlobalPtr :: LMString -> LlvmM LlvmVar +getGlobalPtr llvmLbl = do + m_ty <- funLookup llvmLbl + let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing + case m_ty of + -- Directly reference if we have seen it already + Just ty -> do + if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"]) + then return $ mkGlbVar (llvmLbl) ty Global + else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global + -- Otherwise use a forward alias of it + Nothing -> do + saveAlias llvmLbl + return $ mkGlbVar llvmLbl i8 Alias + +-- | Derive the definition label. It has an identified +-- structure type. +llvmDefLabel :: LMString -> LMString +llvmDefLabel = (`appendFS` fsLit "$def") + +-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. +-- +-- Must be called at a point where we are sure that no new global definitions +-- will be generated anymore! +generateExternDecls :: LlvmM ([LMGlobal], [LlvmType]) +generateExternDecls = do + delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + defss <- flip mapM delayed $ \lbl -> do + m_ty <- funLookup lbl + case m_ty of + -- If we have a definition we've already emitted the proper aliases + -- when the symbol itself was emitted by @aliasify@ + Just _ -> return [] + + -- If we don't have a definition this is an external symbol and we + -- need to emit a declaration + Nothing -> + let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global + in return [LMGlobal var Nothing] + + -- Reset forward list + modifyEnv $ \env -> env { envAliases = emptyUniqSet } + return (concat defss, []) + +-- | Here we take a global variable definition, rename it with a +-- @$def@ suffix, and generate the appropriate alias. +aliasify :: LMGlobal -> LlvmM [LMGlobal] +-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +-- Here we obtain the indirectee's precise type and introduce +-- fresh aliases to both the precise typed label (lbl$def) and the i8* +-- typed (regular) label of it with the matching new names. +aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias) + (Just orig)) = do + let defLbl = llvmDefLabel lbl + LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig + defOrigLbl = llvmDefLabel origLbl + orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias) + origType <- funLookup origLbl + let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl + (pLift $ fromJust origType) oLnk + Nothing Nothing Alias)) + (pLift ty) + pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig) + , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig') + ] +aliasify (LMGlobal var val) = do + let LMGlobalVar lbl ty link sect align const = var + + defLbl = llvmDefLabel lbl + defVar = LMGlobalVar defLbl ty Internal sect align const + + defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const + aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias + aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr + + -- we need to mark the $def symbols as used so LLVM doesn't forget which + -- section they need to go in. This will vanish once we switch away from + -- mangling sections for TNTC. + markUsedVar defVar + + return [ LMGlobal defVar val + , LMGlobal aliasVar (Just aliasVal) + ] + +-- Note [Llvm Forward References] +-- +-- The issue here is that LLVM insists on being strongly typed at +-- every corner, so the first time we mention something, we have to +-- settle what type we assign to it. That makes things awkward, as Cmm +-- will often reference things before their definition, and we have no +-- idea what (LLVM) type it is going to be before that point. +-- +-- Our work-around is to define "aliases" of a standard type (i8 *) in +-- these kind of situations, which we later tell LLVM to be either +-- references to their actual local definitions (involving a cast) or +-- an external reference. This obviously only works for pointers. +-- +-- In particular when we encounter a reference to a symbol in a chunk of +-- C-- there are three possible scenarios, +-- +-- 1. We have already seen a definition for the referenced symbol. This +-- means we already know its type. +-- +-- 2. We have not yet seen a definition but we will find one later in this +-- compilation unit. Since we want to be a good consumer of the +-- C-- streamed to us from upstream, we don't know the type of the +-- symbol at the time when we must emit the reference. +-- +-- 3. We have not yet seen a definition nor will we find one in this +-- compilation unit. In this case the reference refers to an +-- external symbol for which we do not know the type. +-- +-- Let's consider case (2) for a moment: say we see a reference to +-- the symbol @fooBar@ for which we have not seen a definition. As we +-- do not know the symbol's type, we assume it is of type @i8*@ and emit +-- the appropriate casts in @getSymbolPtr@. Later on, when we +-- encounter the definition of @fooBar@ we emit it but with a modified +-- name, @fooBar$def@ (which we'll call the definition symbol), to +-- since we have already had to assume that the symbol @fooBar@ +-- is of type @i8*@. We then emit @fooBar@ itself as an alias +-- of @fooBar$def@ with appropriate casts. This all happens in +-- @aliasify@. +-- +-- Case (3) is quite similar to (2): References are emitted assuming +-- the referenced symbol is of type @i8*@. When we arrive at the end of +-- the compilation unit and realize that the symbol is external, we emit +-- an LLVM @external global@ declaration for the symbol @fooBar@ +-- (handled in @generateExternDecls@). This takes advantage of the +-- fact that the aliases produced by @aliasify@ for exported symbols +-- have external linkage and can therefore be used as normal symbols. +-- +-- Historical note: As of release 3.5 LLVM does not allow aliases to +-- refer to declarations. This the reason why aliases are produced at the +-- point of definition instead of the point of usage, as was previously +-- done. See #9142 for details. +-- +-- Finally, case (1) is trivial. As we already have a definition for +-- and therefore know the type of the referenced symbol, we can do +-- away with casting the alias to the desired type in @getSymbolPtr@ +-- and instead just emit a reference to the definition symbol directly. +-- This is the @Just@ case in @getSymbolPtr@. diff --git a/GHC/CmmToLlvm/CodeGen.hs b/GHC/CmmToLlvm/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/CodeGen.hs @@ -0,0 +1,2072 @@ +{-# LANGUAGE CPP, GADTs, MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmProc to LLVM code. +-- +module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.Regs + +import GHC.Cmm.BlockId +import GHC.Platform.Regs ( activeStgRegs ) +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Ppr as PprCmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Collections + +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Types.ForeignCall +import GHC.Utils.Outputable hiding (panic, pprPanic) +import qualified GHC.Utils.Outputable as Outputable +import GHC.Platform +import GHC.Data.OrdList +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Utils.Misc + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad + +import qualified Data.Semigroup as Semigroup +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) + +type Atomic = Bool +type LlvmStatements = OrdList LlvmStatement + +data Signage = Signed | Unsigned deriving (Eq, Show) + +-- ----------------------------------------------------------------------------- +-- | Top-level of the LLVM proc Code generator +-- +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) = do + let blocks = toBlockListEntryFirstFalseFallthrough graph + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks + let info = mapLookup (g_entry graph) infos + proc = CmmProc info lbl live (ListGraph lmblocks) + return (proc:lmdata) + +genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" + +-- ----------------------------------------------------------------------------- +-- * Block code generation +-- + +-- | Generate code for a list of blocks that make up a complete +-- procedure. The first block in the list is expected to be the entry +-- point. +basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen _ [] = panic "no entry block!" +basicBlocksCodeGen live cmmBlocks + = do -- Emit the prologue + -- N.B. this must be its own block to ensure that the entry block of the + -- procedure has no predecessors, as required by the LLVM IR. See #17589 + -- and #11649. + bid <- newBlockId + (prologue, prologueTops) <- funPrologue live cmmBlocks + let entryBlock = BasicBlock bid (fromOL prologue) + + -- Generate code + (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks + + -- Compose + return (entryBlock : blocks, prologueTops ++ concat topss) + + +-- | Generate code for one block +basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen block + = do let (_, nodes, tail) = blockSplit block + id = entryLabel block + (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs tail + let instrs = fromOL (mid_instrs `appOL` tail_instrs) + return (BasicBlock id instrs, top' ++ top) + +-- ----------------------------------------------------------------------------- +-- * CmmNode code generation +-- + +-- A statement conversion return data. +-- * LlvmStatements: The compiled LLVM statements. +-- * LlvmCmmDecl: Any global data needed. +type StmtData = (LlvmStatements, [LlvmCmmDecl]) + + +-- | Convert a list of CmmNode's to LlvmStatement's +stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs stmts + = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts + return (concatOL instrss, concat topss) + + +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: CmmNode e x -> LlvmM StmtData +stmtToInstrs stmt = case stmt of + + CmmComment _ -> return (nilOL, []) -- nuke comments + CmmTick _ -> return (nilOL, []) + CmmUnwind {} -> return (nilOL, []) + + CmmAssign reg src -> genAssign reg src + CmmStore addr src -> genStore addr src + + CmmBranch id -> genBranch id + CmmCondBranch arg true false likely + -> genCondBranch arg true false likely + CmmSwitch arg ids -> genSwitch arg ids + + -- Foreign Call + CmmUnsafeForeignCall target res args + -> genCall target res args + + -- Tail call + CmmCall { cml_target = arg, + cml_args_regs = live } -> genJump arg live + + _ -> panic "Llvm.CodeGen.stmtToInstrs" + +-- | Wrapper function to declare an instrinct function by function type +getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData +getInstrinct2 fname fty@(LMFunction funSig) = do + + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant + + fn <- funLookup fname + tops <- case fn of + Just _ -> + return [] + Nothing -> do + funInsert fname fty + un <- getUniqueM + let lbl = mkAsmTempLabel un + return [CmmData (Section Data lbl) [([],[fty])]] + + return (fv, nilOL, tops) + +getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" + +-- | Declares an instrinct function by return and parameter types +getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData +getInstrinct fname retTy parTys = + let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy + FixedArgs (tysToParams parTys) Nothing + fty = LMFunction funSig + in getInstrinct2 fname fty + +-- | Memory barrier instruction for LLVM >= 3.0 +barrier :: LlvmM StmtData +barrier = do + let s = Fence False SyncSeqCst + return (unitOL s, []) + +-- | Insert a 'barrier', unless the target platform is in the provided list of +-- exceptions (where no code will be emitted instead). +barrierUnless :: [Arch] -> LlvmM StmtData +barrierUnless exs = do + platform <- getPlatform + if platformArch platform `elem` exs + then return (nilOL, []) + else barrier + +-- | Foreign Calls +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData + +-- Barriers need to be handled specially as they are implemented as LLVM +-- intrinsic functions. +genCall (PrimTarget MO_ReadBarrier) _ _ = + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] +genCall (PrimTarget MO_WriteBarrier) _ _ = do + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] + +genCall (PrimTarget MO_Touch) _ _ + = return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do + dstV <- getCmmRegW (CmmLocal dst) + let ty = cmmToLlvmType $ localRegType dst + width = widthToLlvmFloat w + castV <- lift $ mkLocalVar ty + ve <- exprToVarW e + statement $ Assignment castV $ Cast LM_Uitofp ve width + statement $ Store castV dstV + +genCall (PrimTarget (MO_UF_Conv _)) [_] args = + panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ + "Can only handle 1, given" ++ show (length args) ++ "." + +-- Handle prefetching data +genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args + | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do + let argTy = [i8Ptr, i32, i32, i32] + funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing + + let (_, arg_hints) = foreignTargetHints t + let args_hints' = zip args arg_hints + argVars <- arg_varsW args_hints' ([], nilOL, []) + fptr <- liftExprData $ getFunPtr funTy t + argVars' <- castVarsW Signed $ zip argVars argTy + + let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1] + statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] + | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) + +-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg +-- and return types +genCall t@(PrimTarget (MO_PopCnt w)) dsts args = + genCallSimpleCast w t dsts args + +genCall t@(PrimTarget (MO_Pdep w)) dsts args = + genCallSimpleCast2 w t dsts args +genCall t@(PrimTarget (MO_Pext w)) dsts args = + genCallSimpleCast2 w t dsts args +genCall t@(PrimTarget (MO_Clz w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_Ctz w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BSwap w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BRev w)) dsts args = + genCallSimpleCast w t dsts args + +genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do + addrVar <- exprToVarW addr + nVar <- exprToVarW n + let targetTy = widthToLlvmInt width + ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) + ptrVar <- doExprW (pLift targetTy) ptrExpr + dstVar <- getCmmRegW (CmmLocal dst) + let op = case amop of + AMO_Add -> LAO_Add + AMO_Sub -> LAO_Sub + AMO_And -> LAO_And + AMO_Nand -> LAO_Nand + AMO_Or -> LAO_Or + AMO_Xor -> LAO_Xor + retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst + statement $ Store retVar dstVar + +genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do + dstV <- getCmmRegW (CmmLocal dst) + v1 <- genLoadW True addr (localRegType dst) + statement $ Store v1 dstV + +genCall (PrimTarget (MO_Cmpxchg _width)) + [dst] [addr, old, new] = runStmtsDecls $ do + addrVar <- exprToVarW addr + oldVar <- exprToVarW old + newVar <- exprToVarW new + let targetTy = getVarType oldVar + ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) + ptrVar <- doExprW (pLift targetTy) ptrExpr + dstVar <- getCmmRegW (CmmLocal dst) + retVar <- doExprW (LMStructU [targetTy,i1]) + $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst + retVar' <- doExprW targetTy $ ExtractV retVar 0 + statement $ Store retVar' dstVar + +genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do + dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar + addrVar <- exprToVarW addr + valVar <- exprToVarW val + let ptrTy = pLift $ getVarType valVar + ptrExpr = Cast LM_Inttoptr addrVar ptrTy + ptrVar <- doExprW ptrTy ptrExpr + resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst) + statement $ Store resVar dstV + +genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do + addrVar <- exprToVarW addr + valVar <- exprToVarW val + let ptrTy = pLift $ getVarType valVar + ptrExpr = Cast LM_Inttoptr addrVar ptrTy + ptrVar <- doExprW ptrTy ptrExpr + statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst + +-- Handle memcpy function specifically since llvm's intrinsic version takes +-- some extra parameters. +genCall t@(PrimTarget op) [] args + | Just align <- machOpMemcpyishAlign op + = do + platform <- getPlatform + runStmtsDecls $ do + let isVolTy = [i1] + isVolVal = [mkIntLit i1 0] + argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord platform, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord platform, i32] ++ isVolTy + funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + argVars <- arg_varsW args_hints ([], nilOL, []) + fptr <- getFunPtrW funTy t + argVars' <- castVarsW Signed $ zip argVars argTy + + let alignVal = mkIntLit i32 align + arguments = argVars' ++ (alignVal:isVolVal) + statement $ Expr $ Call StdCall fptr arguments [] + +-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands +-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will +-- generate 'mul' on 128-bit operands. Then we only need some plumbing to +-- extract the two 64-bit values out of 128-bit result. +genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First zero-extend the operands ('mul' instruction requires the operands + -- and the result to be of the same type). Note that we don't use 'castVars' + -- because it tries to do LM_Sext. + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x + rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x + -- Do the actual multiplication (note that the result is also 2x width). + retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt + -- Extract the lower bits of the result into retL. + retL <- doExprW width $ Cast LM_Trunc retV width + -- Now we unsigned right-shift the higher bits by width. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit + -- And extract them into retH. + retH <- doExprW width $ Cast LM_Trunc retShifted width + dstRegL <- getCmmRegW (CmmLocal dstL) + dstRegH <- getCmmRegW (CmmLocal dstH) + statement $ Store retL dstRegL + statement $ Store retH dstRegH + +genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First sign-extend the operands ('mul' instruction requires the operands + -- and the result to be of the same type). Note that we don't use 'castVars' + -- because it tries to do LM_Sext. + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + lhsExt <- doExprW width2x $ Cast LM_Sext lhsVar width2x + rhsExt <- doExprW width2x $ Cast LM_Sext rhsVar width2x + -- Do the actual multiplication (note that the result is also 2x width). + retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt + -- Extract the lower bits of the result into retL. + retL <- doExprW width $ Cast LM_Trunc retV width + -- Now we signed right-shift the higher bits by width. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + retShifted <- doExprW width2x $ LlvmOp LM_MO_AShr retV widthLlvmLit + -- And extract them into retH. + retH <- doExprW width $ Cast LM_Trunc retShifted width + -- Check if the carry is useful by doing a full arithmetic right shift on + -- retL and comparing the result with retH + let widthLlvmLitm1 = LMLitVar $ LMIntLit (fromIntegral bitWidth - 1) width + retH' <- doExprW width $ LlvmOp LM_MO_AShr retL widthLlvmLitm1 + retC1 <- doExprW i1 $ Compare LM_CMP_Ne retH retH' -- Compare op returns a 1-bit value (i1) + retC <- doExprW width $ Cast LM_Zext retC1 width -- so we zero-extend it + dstRegL <- getCmmRegW (CmmLocal dstL) + dstRegH <- getCmmRegW (CmmLocal dstH) + dstRegC <- getCmmRegW (CmmLocal dstC) + statement $ Store retL dstRegL + statement $ Store retH dstRegH + statement $ Store retC dstRegC + +-- MO_U_QuotRem2 is another case we handle by widening the registers to double +-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The +-- main difference here is that we need to combine two words into one register +-- and then use both 'udiv' and 'urem' instructions to compute the result. +genCall (PrimTarget (MO_U_QuotRem2 w)) + [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First zero-extend all parameters to double width. + let zeroExtend expr = do + var <- exprToVarW expr + doExprW width2x $ Cast LM_Zext var width2x + lhsExtH <- zeroExtend lhsH + lhsExtL <- zeroExtend lhsL + rhsExt <- zeroExtend rhs + -- Now we combine the first two parameters (that represent the high and low + -- bits of the value). So first left-shift the high bits to their position + -- and then bit-or them with the low bits. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit + lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL + -- Finally, we can call 'udiv' and 'urem' to compute the results. + retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt + retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt + -- And since everything is in 2x width, we need to truncate the results and + -- then return them. + let narrow var = doExprW width $ Cast LM_Trunc var width + retDiv <- narrow retExtDiv + retRem <- narrow retExtRem + dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) + dstRegR <- lift $ getCmmReg (CmmLocal dstR) + statement $ Store retDiv dstRegQ + statement $ Store retRem dstRegR + +-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from +-- which we need to extract the actual values. +genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] +genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the +-- return tuple to be the overflow bit and the second element to contain the +-- actual result of the addition. So we still use genCallWithOverflow but swap +-- the return registers. +genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +-- Handle all other foreign calls and prim ops. +genCall target res args = do + platform <- getPlatform + runStmtsDecls $ do + + -- extract Cmm call convention, and translate to LLVM call convention + let lmconv = case target of + ForeignTarget _ (ForeignConvention conv _ _ _) -> + case conv of + StdCallConv -> case platformArch platform of + ArchX86 -> CC_X86_Stdcc + ArchX86_64 -> CC_X86_Stdcc + _ -> CC_Ccc + CCallConv -> CC_Ccc + CApiConv -> CC_Ccc + PrimCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv" + JavaScriptCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: JavaScriptCallConv" + + PrimTarget _ -> CC_Ccc + + {- + CC_Ccc of the possibilities here are a worry with the use of a custom + calling convention for passing STG args. In practice the more + dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. + + The native code generator only handles StdCall and CCallConv. + -} + + -- parameter types + let arg_type (_, AddrHint) = (i8Ptr, []) + -- cast pointers to i8*. Llvm equivalent of void* + arg_type (expr, hint) = + case cmmToLlvmType $ cmmExprType platform expr of + ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform + -> (ty, if hint == SignedHint then [SignExt] else [ZeroExt]) + ty -> (ty, []) + + -- ret type + let ret_type [] = LMVoid + ret_type [(_, AddrHint)] = i8Ptr + ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg + ret_type t = panic $ "genCall: Too many return values! Can only handle" + ++ " 0 or 1, given " ++ show (length t) ++ "." + + -- call attributes + let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs + | otherwise = llvmStdFunAttrs + + never_returns = case target of + ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True + _ -> False + + -- fun type + let (res_hints, arg_hints) = foreignTargetHints target + let args_hints = zip args arg_hints + let ress_hints = zip res res_hints + let ccTy = StdCall -- tail calls should be done through CmmJump + let retTy = ret_type ress_hints + let argTy = map arg_type args_hints + let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + lmconv retTy FixedArgs argTy (llvmFunAlign platform) + + + argVars <- arg_varsW args_hints ([], nilOL, []) + fptr <- getFunPtrW funTy target + + let doReturn | ccTy == TailCall = statement $ Return Nothing + | never_returns = statement $ Unreachable + | otherwise = return () + + + -- make the actual call + case retTy of + LMVoid -> do + statement $ Expr $ Call ccTy fptr argVars fnAttrs + + _ -> do + v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs + -- get the return register + let ret_reg [reg] = reg + ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" + ++ " 1, given " ++ show (length t) ++ "." + let creg = ret_reg res + vreg <- getCmmRegW (CmmLocal creg) + if retTy == pLower (getVarType vreg) + then do + statement $ Store v1 vreg + doReturn + else do + let ty = pLower $ getVarType vreg + let op = case ty of + vt | isPointer vt -> LM_Bitcast + | isInt vt -> LM_Ptrtoint + | otherwise -> + panic $ "genCall: CmmReg bad match for" + ++ " returned type!" + + v2 <- doExprW ty $ Cast op v1 ty + statement $ Store v2 vreg + doReturn + +-- | Generate a call to an LLVM intrinsic that performs arithmetic operation +-- with overflow bit (i.e., returns a struct containing the actual result of the +-- operation and an overflow bit). This function will also extract the overflow +-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the +-- overflow "bit" as a usual Int# or Word#). +genCallWithOverflow + :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData +genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do + -- So far this was only tested for the following four CallishMachOps. + let valid = op `elem` [ MO_Add2 w + , MO_AddIntC w + , MO_SubIntC w + , MO_AddWordC w + , MO_SubWordC w + ] + MASSERT(valid) + let width = widthToLlvmInt w + -- This will do most of the work of generating the call to the intrinsic and + -- extracting the values from the struct. + (value, overflowBit, (stmts, top)) <- + genCallExtract t w (lhs, rhs) (width, i1) + -- value is i, but overflowBit is i1, so we need to cast (Cmm expects + -- both to be i) + (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width + dstRegV <- getCmmReg (CmmLocal dstV) + dstRegO <- getCmmReg (CmmLocal dstO) + let storeV = Store value dstRegV + storeO = Store overflow dstRegO + return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) +genCallWithOverflow _ _ _ _ = + panic "genCallExtract: wrong ForeignTarget or number of arguments" + +-- | A helper function for genCallWithOverflow that handles generating the call +-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars. +genCallExtract + :: ForeignTarget -- ^ PrimOp + -> Width -- ^ Width of the operands. + -> (CmmActual, CmmActual) -- ^ Actual arguments. + -> (LlvmType, LlvmType) -- ^ LLVM types of the returned struct. + -> LlvmM (LlvmVar, LlvmVar, StmtData) +genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do + let width = widthToLlvmInt w + argTy = [width, width] + retTy = LMStructU [llvmTypeA, llvmTypeB] + + -- Process the arguments. + let args_hints = zip [argA, argB] (snd $ foreignTargetHints target) + (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, []) + (argsV2, args2) <- castVars Signed $ zip argsV1 argTy + + -- Get the function and make the call. + fname <- cmmPrimOpFunctions op + (fptr, _, top2) <- getInstrinct fname retTy argTy + -- We use StdCall for primops. See also the last case of genCall. + (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 [] + + -- This will result in a two element struct, we need to use "extractvalue" + -- to get them out of it. + (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0) + (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1) + + let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2 + tops = top1 ++ top2 + return (res1, res2, (stmts, tops)) + +genCallExtract _ _ _ _ = + panic "genCallExtract: unsupported ForeignTarget" + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- since GHC only really has i32 and i64 types and things like Word8 are backed +-- by an i32 and just present a logical i8 range. So we must handle conversions +-- from i32 to i8 explicitly as LLVM is strict about types. +genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType dst + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width [width] + + dstV <- getCmmReg (CmmLocal dst) + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars Signed $ zip argsV [width] + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] + let retV' = singletonPanic "genCallSimpleCast" retVs' + let s2 = Store retV' dstV + + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast _ _ dsts _ = + panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- since GHC only really has i32 and i64 types and things like Word8 are backed +-- by an i32 and just present a logical i8 range. So we must handle conversions +-- from i32 to i8 explicitly as LLVM is strict about types. +genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType dst + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width (const width <$> args) + + dstV <- getCmmReg (CmmLocal dst) + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV) + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] + let retV' = singletonPanic "genCallSimpleCast2" retVs' + let s2 = Store retV' dstV + + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast2 _ _ dsts _ = + panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts") + +-- | Create a function pointer from a target. +getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget + -> WriterT LlvmAccum LlvmM LlvmVar +getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ + +-- | Create a function pointer from a target. +getFunPtr :: (LMString -> LlvmType) -> ForeignTarget + -> LlvmM ExprData +getFunPtr funTy targ = case targ of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + name <- strCLabel_llvm lbl + getHsFunc' name (funTy name) + + ForeignTarget expr _ -> do + (v1, stmts, top) <- exprToVar expr + dflags <- getDynFlags + let fty = funTy $ fsLit "dynamic" + cast = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> panic $ "genCall: Expr is of bad type for function" + ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" + + (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) + return (v2, stmts `snocOL` s1, top) + + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty + +-- | Conversion of call arguments. +arg_varsW :: [(CmmActual, ForeignHint)] + -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> WriterT LlvmAccum LlvmM [LlvmVar] +arg_varsW xs ys = do + (vars, stmts, decls) <- lift $ arg_vars xs ys + tell $ LlvmAccum stmts decls + return vars + +-- | Conversion of call arguments. +arg_vars :: [(CmmActual, ForeignHint)] + -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) + +arg_vars ((e, AddrHint):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + dflags <- getDynFlags + let op = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + a -> panic $ "genCall: Can't cast llvmType to i8*! (" + ++ showSDoc dflags (ppr a) ++ ")" + + (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + tops ++ top') + +arg_vars ((e, _):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') + + +-- | Cast a collection of LLVM variables to specific types. +castVarsW :: Signage + -> [(LlvmVar, LlvmType)] + -> WriterT LlvmAccum LlvmM [LlvmVar] +castVarsW signage vars = do + (vars, stmts) <- lift $ castVars signage vars + tell $ LlvmAccum stmts mempty + return vars + +-- | Cast a collection of LLVM variables to specific types. +castVars :: Signage -> [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars signage vars = do + done <- mapM (uncurry (castVar signage)) vars + let (vars', stmts) = unzip done + return (vars', toOL stmts) + +-- | Cast an LLVM variable to a specific type, panicing if it can't be done. +castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar signage v t | getVarType v == t + = return (v, Nop) + + | otherwise + = do dflags <- getDynFlags + platform <- getPlatform + let op = case (getVarType v, t) of + (LMInt n, LMInt m) + -> if n < m then extend else LM_Trunc + (vt, _) | isFloat vt && isFloat t + -> if llvmWidthInBits platform vt < llvmWidthInBits platform t + then LM_Fpext else LM_Fptrunc + (vt, _) | isInt vt && isFloat t -> LM_Sitofp + (vt, _) | isFloat vt && isInt t -> LM_Fptosi + (vt, _) | isInt vt && isPointer t -> LM_Inttoptr + (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint + (vt, _) | isPointer vt && isPointer t -> LM_Bitcast + (vt, _) | isVector vt && isVector t -> LM_Bitcast + + (vt, _) -> panic $ "castVars: Can't cast this type (" + ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" + doExpr t $ Cast op v t + where extend = case signage of + Signed -> LM_Sext + Unsigned -> LM_Zext + + +cmmPrimOpRetValSignage :: CallishMachOp -> Signage +cmmPrimOpRetValSignage mop = case mop of + MO_Pdep _ -> Unsigned + MO_Pext _ -> Unsigned + _ -> Signed + +-- | Decide what C function to use to implement a CallishMachOp +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + + dflags <- getDynFlags + platform <- getPlatform + let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord platform) + intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform) + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + + return $ case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" + MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" + MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" + MO_F32_Fabs -> fsLit "llvm.fabs.f32" + MO_F32_Pwr -> fsLit "llvm.pow.f32" + + MO_F32_Sin -> fsLit "llvm.sin.f32" + MO_F32_Cos -> fsLit "llvm.cos.f32" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F32_Asinh -> fsLit "asinhf" + MO_F32_Acosh -> fsLit "acoshf" + MO_F32_Atanh -> fsLit "atanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" + MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" + MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" + MO_F64_Fabs -> fsLit "llvm.fabs.f64" + MO_F64_Pwr -> fsLit "llvm.pow.f64" + + MO_F64_Sin -> fsLit "llvm.sin.f64" + MO_F64_Cos -> fsLit "llvm.cos.f64" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_F64_Asinh -> fsLit "asinh" + MO_F64_Acosh -> fsLit "acosh" + MO_F64_Atanh -> fsLit "atanh" + + MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1 + MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1 + MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2 + MO_Memcmp _ -> fsLit $ "memcmp" + + (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BRev w) -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + + (MO_Pdep w) -> let w' = showSDoc dflags (ppr $ widthInBits w) + in if isBmi2Enabled dflags + then fsLit $ "llvm.x86.bmi.pdep." ++ w' + else fsLit $ "hs_pdep" ++ w' + (MO_Pext w) -> let w' = showSDoc dflags (ppr $ widthInBits w) + in if isBmi2Enabled dflags + then fsLit $ "llvm.x86.bmi.pext." ++ w' + else fsLit $ "hs_pext" ++ w' + + (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" + + MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_AddWordC w -> fsLit $ "llvm.uadd.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the + -- appropriate case of genCall. + MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + MO_UF_Conv _ -> unsupported + + MO_AtomicRead _ -> unsupported + MO_AtomicRMW _ _ -> unsupported + MO_AtomicWrite _ -> unsupported + MO_Cmpxchg _ -> unsupported + MO_Xchg _ -> unsupported + +-- | Tail function calls +genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData + +-- Call to known function +genJump (CmmLit (CmmLabel lbl)) live = do + (vf, stmts, top) <- getHsFunc live lbl + (stgRegs, stgStmts) <- funEpilogue live + let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs + let s2 = Return Nothing + return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + + +-- Call to unknown function / address +genJump expr live = do + fty <- llvmFunTy live + (vf, stmts, top) <- exprToVar expr + dflags <- getDynFlags + + let cast = case getVarType vf of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> panic $ "genJump: Expr is of bad type for function call! (" + ++ showSDoc dflags (ppr ty) ++ ")" + + (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) + (stgRegs, stgStmts) <- funEpilogue live + let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs + let s3 = Return Nothing + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + top) + + +-- | CmmAssign operation +-- +-- We use stack allocated variables for CmmReg. The optimiser will replace +-- these with registers when possible. +genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData +genAssign reg val = do + vreg <- getCmmReg reg + (vval, stmts2, top2) <- exprToVar val + let stmts = stmts2 + + let ty = (pLower . getVarType) vreg + platform <- getPlatform + case ty of + -- Some registers are pointer types, so need to cast value to pointer + LMPointer _ | getVarType vval == llvmWord platform -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = Store v vreg + return (stmts `snocOL` s1 `snocOL` s2, top2) + + LMVector _ _ -> do + (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty + let s2 = Store v vreg + return (stmts `snocOL` s1 `snocOL` s2, top2) + + _ -> do + let s1 = Store vval vreg + return (stmts `snocOL` s1, top2) + + +-- | CmmStore operation +genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genStore addr@(CmmReg (CmmGlobal r)) val + = genStore_fast addr r 0 val + +genStore addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast addr r n val + +genStore addr@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast addr r (fromInteger n) val + +genStore addr@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast addr r (negate $ fromInteger n) val + +-- generic case +genStore addr val + = getTBAAMeta topN >>= genStore_slow addr val + +-- | CmmStore operation +-- This is a special case for storing to a global register pointer +-- offset such as I32[Sp+8]. +genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr + -> LlvmM StmtData +genStore_fast addr r n val + = do platform <- getPlatform + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (vval, stmts, top) <- exprToVar val + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + -- We might need a different pointer type, so check + case pLower grt == getVarType vval of + -- were fine + True -> do + let s3 = MetaStmt meta $ Store vval ptr + return (stmts `appOL` s1 `snocOL` s2 + `snocOL` s3, top) + + -- cast to pointer type needed + False -> do + let ty = (pLift . getVarType) vval + (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty + let s4 = MetaStmt meta $ Store vval ptr' + return (stmts `appOL` s1 `snocOL` s2 + `snocOL` s3 `snocOL` s4, top) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genStore_slow addr val meta + + +-- | CmmStore operation +-- Generic case. Uses casts and pointer arithmetic if needed. +genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData +genStore_slow addr val meta = do + (vaddr, stmts1, top1) <- exprToVar addr + (vval, stmts2, top2) <- exprToVar val + + let stmts = stmts1 `appOL` stmts2 + dflags <- getDynFlags + platform <- getPlatform + opts <- getLlvmOpts + case getVarType vaddr of + -- sometimes we need to cast an int to a pointer before storing + LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = MetaStmt meta $ Store v vaddr + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + LMPointer _ -> do + let s1 = MetaStmt meta $ Store vval vaddr + return (stmts `snocOL` s1, top1 ++ top2) + + i@(LMInt _) | i == llvmWord platform -> do + let vty = pLift $ getVarType vval + (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty + let s2 = MetaStmt meta $ Store vval vptr + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + other -> + pprPanic "genStore: ptr not right type!" + (PprCmm.pprExpr platform addr <+> text ( + "Size of Ptr: " ++ show (llvmPtrBits platform) ++ + ", Size of var: " ++ show (llvmWidthInBits platform other) ++ + ", Var: " ++ showSDoc dflags (ppVar opts vaddr))) + + +-- | Unconditional branch +genBranch :: BlockId -> LlvmM StmtData +genBranch id = + let label = blockIdToLlvm id + in return (unitOL $ Branch label, []) + + +-- | Conditional branch +genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData +genCondBranch cond idT idF likely = do + let labelT = blockIdToLlvm idT + let labelF = blockIdToLlvm idF + -- See Note [Literals and branch conditions]. + (vc, stmts1, top1) <- exprToVarOpt i1Option cond + if getVarType vc == i1 + then do + (vc', (stmts2, top2)) <- case likely of + Just b -> genExpectLit (if b then 1 else 0) i1 vc + _ -> pure (vc, (nilOL, [])) + let s1 = BranchIf vc' labelT labelF + return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) + else do + dflags <- getDynFlags + opts <- getLlvmOpts + panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")" + + +-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var. +genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData) +genExpectLit expLit expTy var = do + dflags <- getDynFlags + + let + lit = LMLitVar $ LMIntLit expLit expTy + + llvmExpectName + | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy) + | otherwise = panic $ "genExpectedLit: Type not an int!" + + (llvmExpect, stmts, top) <- + getInstrinct llvmExpectName expTy [expTy, expTy] + (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] [] + return (var', (stmts `snocOL` call, top)) + +{- Note [Literals and branch conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is important that whenever we generate branch conditions for +literals like '1', they are properly narrowed to an LLVM expression of +type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert +a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt +must be certain to return a properly narrowed type. genLit is +responsible for this, in the case of literal integers. + +Often, we won't see direct statements like: + + if(1) { + ... + } else { + ... + } + +at this point in the pipeline, because the Glorious Code Generator +will do trivial branch elimination in the sinking pass (among others,) +which will eliminate the expression entirely. + +However, it's certainly possible and reasonable for this to occur in +hand-written C-- code. Consider something like: + + #if !defined(SOME_CONDITIONAL) + #define CHECK_THING(x) 1 + #else + #define CHECK_THING(x) some_operation((x)) + #endif + + f() { + + if (CHECK_THING(xyz)) { + ... + } else { + ... + } + + } + +In such an instance, CHECK_THING might result in an *expression* in +one case, and a *literal* in the other, depending on what in +particular was #define'd. So we must be sure to properly narrow the +literal in this case to i1 as it won't be eliminated beforehand. + +For a real example of this, see ./rts/StgStdThunks.cmm + +-} + + + +-- | Switch branch +genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData +genSwitch cond ids = do + (vc, stmts, top) <- exprToVar cond + let ty = getVarType vc + + let labels = [ (mkIntLit ty ix, blockIdToLlvm b) + | (ix, b) <- switchTargetsCases ids ] + -- out of range is undefined, so let's just branch to first label + let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l + | otherwise = snd (head labels) + + let s1 = Switch vc defLbl labels + return $ (stmts `snocOL` s1, top) + + +-- ----------------------------------------------------------------------------- +-- * CmmExpr code generation +-- + +-- | An expression conversion return data: +-- * LlvmVar: The var holding the result of the expression +-- * LlvmStatements: Any statements needed to evaluate the expression +-- * LlvmCmmDecl: Any global data needed for this expression +type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) + +-- | Values which can be passed to 'exprToVar' to configure its +-- behaviour in certain circumstances. +-- +-- Currently just used for determining if a comparison should return +-- a boolean (i1) or a word. See Note [Literals and branch conditions]. +newtype EOption = EOption { i1Expected :: Bool } +-- XXX: EOption is an ugly and inefficient solution to this problem. + +-- | i1 type expected (condition scrutinee). +i1Option :: EOption +i1Option = EOption True + +-- | Word type expected (usual). +wordOption :: EOption +wordOption = EOption False + +-- | Convert a CmmExpr to a list of LlvmStatements with the result of the +-- expression being stored in the returned LlvmVar. +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption + +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of + + CmmLit lit + -> genLit opt lit + + CmmLoad e' ty + -> genLoad False e' ty + + -- Cmmreg in expression is the value, so must load. If you want actual + -- reg pointer, call getCmmReg directly. + CmmReg r -> do + (v1, ty, s1) <- getCmmRegVal r + case isPointer ty of + True -> do + -- Cmm wants the value, so pointer types must be cast to ints + platform <- getPlatform + (v2, s2) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint v1 (llvmWord platform) + return (v2, s1 `snocOL` s2, []) + + False -> return (v1, s1, []) + + CmmMachOp op exprs + -> genMachOp opt op exprs + + CmmRegOff r i + -> do platform <- getPlatform + exprToVar $ expandCmmReg platform (r, i) + + CmmStackSlot _ _ + -> panic "exprToVar: CmmStackSlot not supported!" + + +-- | Handle CmmMachOp expressions +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Unary Machop +genMachOp _ op [x] = case op of + + MO_Not w -> + let all1 = mkIntLit (widthToLlvmInt w) (-1) + in negate (widthToLlvmInt w) all1 LM_MO_Xor + + MO_S_Neg w -> + let all0 = mkIntLit (widthToLlvmInt w) 0 + in negate (widthToLlvmInt w) all0 LM_MO_Sub + + MO_F_Neg w -> + let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w) + in negate (widthToLlvmFloat w) all0 LM_MO_FSub + + MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp + MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi + + MO_SS_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext + + MO_UU_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_XX_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_FF_Conv from to + -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext + + MO_VS_Neg len w -> + let ty = widthToLlvmInt w + vecty = LMVector len ty + all0 = LMIntLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_Sub + + MO_VF_Neg len w -> + let ty = widthToLlvmFloat w + vecty = LMVector len ty + all0 = LMFloatLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_FSub + + MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm" + + -- Handle unsupported cases explicitly so we get a warning + -- of missing case when new MachOps added + MO_Add _ -> panicOp + MO_Mul _ -> panicOp + MO_Sub _ -> panicOp + MO_S_MulMayOflo _ -> panicOp + MO_S_Quot _ -> panicOp + MO_S_Rem _ -> panicOp + MO_U_MulMayOflo _ -> panicOp + MO_U_Quot _ -> panicOp + MO_U_Rem _ -> panicOp + + MO_Eq _ -> panicOp + MO_Ne _ -> panicOp + MO_S_Ge _ -> panicOp + MO_S_Gt _ -> panicOp + MO_S_Le _ -> panicOp + MO_S_Lt _ -> panicOp + MO_U_Ge _ -> panicOp + MO_U_Gt _ -> panicOp + MO_U_Le _ -> panicOp + MO_U_Lt _ -> panicOp + + MO_F_Add _ -> panicOp + MO_F_Sub _ -> panicOp + MO_F_Mul _ -> panicOp + MO_F_Quot _ -> panicOp + MO_F_Eq _ -> panicOp + MO_F_Ne _ -> panicOp + MO_F_Ge _ -> panicOp + MO_F_Gt _ -> panicOp + MO_F_Le _ -> panicOp + MO_F_Lt _ -> panicOp + + MO_And _ -> panicOp + MO_Or _ -> panicOp + MO_Xor _ -> panicOp + MO_Shl _ -> panicOp + MO_U_Shr _ -> panicOp + MO_S_Shr _ -> panicOp + + MO_V_Insert _ _ -> panicOp + MO_V_Extract _ _ -> panicOp + + MO_V_Add _ _ -> panicOp + MO_V_Sub _ _ -> panicOp + MO_V_Mul _ _ -> panicOp + + MO_VS_Quot _ _ -> panicOp + MO_VS_Rem _ _ -> panicOp + + MO_VU_Quot _ _ -> panicOp + MO_VU_Rem _ _ -> panicOp + + MO_VF_Insert _ _ -> panicOp + MO_VF_Extract _ _ -> panicOp + + MO_VF_Add _ _ -> panicOp + MO_VF_Sub _ _ -> panicOp + MO_VF_Mul _ _ -> panicOp + MO_VF_Quot _ _ -> panicOp + + where + negate ty v2 negOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx + return (v1, stmts `snocOL` s1, top) + + negateVec ty v2 negOp = do + (vx, stmts1, top) <- exprToVar x + (vxs', stmts2) <- castVars Signed [(vx, ty)] + let vx' = singletonPanic "genMachOp: negateVec" vxs' + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + + fiConv ty convOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ Cast convOp vx ty + return (v1, stmts `snocOL` s1, top) + + sameConv from ty reduce expand = do + x'@(vx, stmts, top) <- exprToVar x + let sameConv' op = do + (v1, s1) <- doExpr ty $ Cast op vx ty + return (v1, stmts `snocOL` s1, top) + platform <- getPlatform + let toWidth = llvmWidthInBits platform ty + -- LLVM doesn't like trying to convert to same width, so + -- need to check for that as we do get Cmm code doing it. + case widthInBits from of + w | w < toWidth -> sameConv' expand + w | w > toWidth -> sameConv' reduce + _w -> return x' + + panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered" + ++ "with one argument! (" ++ show op ++ ")" + +-- Handle GlobalRegs pointers +genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (fromInteger n) e + +genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (negate . fromInteger $ n) e + +-- Generic case +genMachOp opt op e = genMachOp_slow opt op e + + +-- | Handle CmmMachOp expressions +-- This is a specialised method that handles Global register manipulations like +-- 'Sp - 16', using the getelementptr instruction. +genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] + -> LlvmM ExprData +genMachOp_fast opt op r n e + = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + platform <- getPlatform + let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + (var, s3) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint ptr (llvmWord platform) + return (var, s1 `snocOL` s2 `snocOL` s3, []) + + False -> genMachOp_slow opt op e + + +-- | Handle CmmMachOp expressions +-- This handles all the cases not handle by the specialised genMachOp_fast. +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Element extraction +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do + vval <- exprToVarW val + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, LMVector l ty)] + doExprW ty $ Extract vval' vidx + where + ty = widthToLlvmInt w + +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do + vval <- exprToVarW val + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, LMVector l ty)] + doExprW ty $ Extract vval' vidx + where + ty = widthToLlvmFloat w + +-- Element insertion +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do + vval <- exprToVarW val + velt <- exprToVarW elt + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, ty)] + doExprW ty $ Insert vval' velt vidx + where + ty = LMVector l (widthToLlvmInt w) + +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do + vval <- exprToVarW val + velt <- exprToVarW elt + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, ty)] + doExprW ty $ Insert vval' velt vidx + where + ty = LMVector l (widthToLlvmFloat w) + +-- Binary MachOp +genMachOp_slow opt op [x, y] = case op of + + MO_Eq _ -> genBinComp opt LM_CMP_Eq + MO_Ne _ -> genBinComp opt LM_CMP_Ne + + MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt + MO_S_Ge _ -> genBinComp opt LM_CMP_Sge + MO_S_Lt _ -> genBinComp opt LM_CMP_Slt + MO_S_Le _ -> genBinComp opt LM_CMP_Sle + + MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt + MO_U_Ge _ -> genBinComp opt LM_CMP_Uge + MO_U_Lt _ -> genBinComp opt LM_CMP_Ult + MO_U_Le _ -> genBinComp opt LM_CMP_Ule + + MO_Add _ -> genBinMach LM_MO_Add + MO_Sub _ -> genBinMach LM_MO_Sub + MO_Mul _ -> genBinMach LM_MO_Mul + + MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!" + + MO_S_MulMayOflo w -> isSMulOK w x y + + MO_S_Quot _ -> genBinMach LM_MO_SDiv + MO_S_Rem _ -> genBinMach LM_MO_SRem + + MO_U_Quot _ -> genBinMach LM_MO_UDiv + MO_U_Rem _ -> genBinMach LM_MO_URem + + MO_F_Eq _ -> genBinComp opt LM_CMP_Feq + MO_F_Ne _ -> genBinComp opt LM_CMP_Fne + MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt + MO_F_Ge _ -> genBinComp opt LM_CMP_Fge + MO_F_Lt _ -> genBinComp opt LM_CMP_Flt + MO_F_Le _ -> genBinComp opt LM_CMP_Fle + + MO_F_Add _ -> genBinMach LM_MO_FAdd + MO_F_Sub _ -> genBinMach LM_MO_FSub + MO_F_Mul _ -> genBinMach LM_MO_FMul + MO_F_Quot _ -> genBinMach LM_MO_FDiv + + MO_And _ -> genBinMach LM_MO_And + MO_Or _ -> genBinMach LM_MO_Or + MO_Xor _ -> genBinMach LM_MO_Xor + MO_Shl _ -> genBinMach LM_MO_Shl + MO_U_Shr _ -> genBinMach LM_MO_LShr + MO_S_Shr _ -> genBinMach LM_MO_AShr + + MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add + MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub + MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul + + MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv + MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem + + MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv + MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem + + MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd + MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub + MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul + MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv + + MO_Not _ -> panicOp + MO_S_Neg _ -> panicOp + MO_F_Neg _ -> panicOp + + MO_SF_Conv _ _ -> panicOp + MO_FS_Conv _ _ -> panicOp + MO_SS_Conv _ _ -> panicOp + MO_UU_Conv _ _ -> panicOp + MO_XX_Conv _ _ -> panicOp + MO_FF_Conv _ _ -> panicOp + + MO_V_Insert {} -> panicOp + + MO_VS_Neg {} -> panicOp + + MO_VF_Insert {} -> panicOp + + MO_VF_Neg {} -> panicOp + + MO_AlignmentCheck {} -> panicOp + +#if __GLASGOW_HASKELL__ < 811 + MO_VF_Extract {} -> panicOp + MO_V_Extract {} -> panicOp +#endif + + where + binLlvmOp ty binOp = do + platform <- getPlatform + runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + if getVarType vx == getVarType vy + then do + doExprW (ty vx) $ binOp vx vy + + else do + -- Error. Continue anyway so we can debug the generated ll file. + dflags <- getDynFlags + let style = mkCodeStyle CStyle + toString doc = renderWithStyle (initSDocContext dflags style) doc + cmmToStr = (lines . toString . PprCmm.pprExpr platform) + statement $ Comment $ map fsLit $ cmmToStr x + statement $ Comment $ map fsLit $ cmmToStr y + doExprW (ty vx) $ binOp vx vy + + binCastLlvmOp ty binOp = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + vxy' <- castVarsW Signed [(vx, ty), (vy, ty)] + case vxy' of + [vx',vy'] -> doExprW ty $ binOp vx' vy' + _ -> panic "genMachOp_slow: binCastLlvmOp" + + -- | Need to use EOption here as Cmm expects word size results from + -- comparisons while LLVM return i1. Need to extend to llvmWord type + -- if expected. See Note [Literals and branch conditions]. + genBinComp opt cmp = do + ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + dflags <- getDynFlags + platform <- getPlatform + if getVarType v1 == i1 + then case i1Expected opt of + True -> return ed + False -> do + let w_ = llvmWord platform + (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ + return (v2, stmts `snocOL` s1, top) + else + panic $ "genBinComp: Compare returned type other then i1! " + ++ (showSDoc dflags $ ppr $ getVarType v1) + + genBinMach op = binLlvmOp getVarType (LlvmOp op) + + genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) + + -- | Detect if overflow will occur in signed multiply of the two + -- CmmExpr's. This is the LLVM assembly equivalent of the NCG + -- implementation. Its much longer due to type information/safety. + -- This should actually compile to only about 3 asm instructions. + isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData + isSMulOK _ x y = do + platform <- getPlatform + dflags <- getDynFlags + runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + + let word = getVarType vx + let word2 = LMInt $ 2 * (llvmWidthInBits platform $ getVarType vx) + let shift = llvmWidthInBits platform word + let shift1 = toIWord platform (shift - 1) + let shift2 = toIWord platform shift + + if isInt word + then do + x1 <- doExprW word2 $ Cast LM_Sext vx word2 + y1 <- doExprW word2 $ Cast LM_Sext vy word2 + r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1 + rlow1 <- doExprW word $ Cast LM_Trunc r1 word + rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1 + rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2 + rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word + doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2 + + else + panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" + + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" + ++ "with two arguments! (" ++ show op ++ ")" + +-- More than two expression, invalid! +genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!" + + +-- | Handle CmmLoad expression. +genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genLoad atomic e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast atomic e r 0 ty + +genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast atomic e r n ty + +genLoad atomic e@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast atomic e r (fromInteger n) ty + +genLoad atomic e@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast atomic e r (negate $ fromInteger n) ty + +-- generic case +genLoad atomic e ty + = getTBAAMeta topN >>= genLoad_slow atomic e ty + +-- | Handle CmmLoad expression. +-- This is a special case for loading from a global register pointer +-- offset such as I32[Sp+8]. +genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast atomic e r n ty = do + platform <- getPlatform + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let ty' = cmmToLlvmType ty + (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + -- We might need a different pointer type, so check + case grt == ty' of + -- were fine + True -> do + (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr) + return (var, s1 `snocOL` s2 `snocOL` s3, + []) + + -- cast to pointer type needed + False -> do + let pty = pLift ty' + (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty + (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr') + return (var, s1 `snocOL` s2 `snocOL` s3 + `snocOL` s4, []) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genLoad_slow atomic e ty meta + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr + +-- | Handle Cmm load expression. +-- Generic case. Uses casts and pointer arithmetic if needed. +genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow atomic e ty meta = do + platform <- getPlatform + dflags <- getDynFlags + opts <- getLlvmOpts + runExprData $ do + iptr <- exprToVarW e + case getVarType iptr of + LMPointer _ -> do + doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) + + i@(LMInt _) | i == llvmWord platform -> do + let pty = LMPointer $ cmmToLlvmType ty + ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty + doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr) + + other -> do pprPanic "exprToVar: CmmLoad expression is not right type!" + (PprCmm.pprExpr platform e <+> text ( + "Size of Ptr: " ++ show (llvmPtrBits platform) ++ + ", Size of var: " ++ show (llvmWidthInBits platform other) ++ + ", Var: " ++ showSDoc dflags (ppVar opts iptr))) + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr + + +-- | Handle CmmReg expression. This will return a pointer to the stack +-- location of the register. Throws an error if it isn't allocated on +-- the stack. +getCmmReg :: CmmReg -> LlvmM LlvmVar +getCmmReg (CmmLocal (LocalReg un _)) + = do exists <- varLookup un + dflags <- getDynFlags + case exists of + Just ety -> return (LMLocalVar un $ pLift ety) + Nothing -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" + -- This should never happen, as every local variable should + -- have been assigned a value at some point, triggering + -- "funPrologue" to allocate it on the stack. + +getCmmReg (CmmGlobal g) + = do onStack <- checkStackReg g + dflags <- getDynFlags + platform <- getPlatform + if onStack + then return (lmGlobalRegVar platform g) + else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" + +-- | Return the value of a given register, as well as its type. Might +-- need to be load from stack. +getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) +getCmmRegVal reg = + case reg of + CmmGlobal g -> do + onStack <- checkStackReg g + platform <- getPlatform + if onStack then loadFromStack else do + let r = lmGlobalRegArg platform g + return (r, getVarType r, nilOL) + _ -> loadFromStack + where loadFromStack = do + ptr <- getCmmReg reg + let ty = pLower $ getVarType ptr + (v, s) <- doExpr ty (Load ptr) + return (v, ty, unitOL s) + +-- | Allocate a local CmmReg on the stack +allocReg :: CmmReg -> (LlvmVar, LlvmStatements) +allocReg (CmmLocal (LocalReg un ty)) + = let ty' = cmmToLlvmType ty + var = LMLocalVar un (LMPointer ty') + alc = Alloca ty' 1 + in (var, unitOL $ Assignment var alc) + +allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" + ++ " have been handled elsewhere!" + + +-- | Generate code for a literal +genLit :: EOption -> CmmLit -> LlvmM ExprData +genLit opt (CmmInt i w) + -- See Note [Literals and branch conditions]. + = let width | i1Expected opt = i1 + | otherwise = LMInt (widthInBits w) + -- comm = Comment [ fsLit $ "EOption: " ++ show opt + -- , fsLit $ "Width : " ++ show w + -- , fsLit $ "Width' : " ++ show (widthInBits w) + -- ] + in return (mkIntLit width i, nilOL, []) + +genLit _ (CmmFloat r w) + = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), + nilOL, []) + +genLit opt (CmmVec ls) + = do llvmLits <- mapM toLlvmLit ls + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) + where + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + (llvmLitVar, _, _) <- genLit opt lit + case llvmLitVar of + LMLitVar llvmLit -> return llvmLit + _ -> panic "genLit" + +genLit _ cmm@(CmmLabel l) + = do var <- getGlobalPtr =<< strCLabel_llvm l + platform <- getPlatform + let lmty = cmmToLlvmType $ cmmLitType platform cmm + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord platform) + return (v1, unitOL s1, []) + +genLit opt (CmmLabelOff label off) = do + platform <- getPlatform + (vlbl, stmts, stat) <- genLit opt (CmmLabel label) + let voff = toIWord platform off + (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff + return (v1, stmts `snocOL` s1, stat) + +genLit opt (CmmLabelDiffOff l1 l2 off w) = do + platform <- getPlatform + (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) + (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) + let voff = toIWord platform off + let ty1 = getVarType vl1 + let ty2 = getVarType vl2 + if (isInt ty1) && (isInt ty2) + && (llvmWidthInBits platform ty1 == llvmWidthInBits platform ty2) + then do + (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 + (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff + let ty = widthToLlvmInt w + let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2 + if w /= wordWidth platform + then do + (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty + return (v3, stmts `snocOL` s3, stat1 ++ stat2) + else + return (v2, stmts, stat1 ++ stat2) + else + panic "genLit: CmmLabelDiffOff encountered with different label ty!" + +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) + +genLit _ CmmHighStackMark + = panic "genStaticLit - CmmHighStackMark unsupported!" + + +-- ----------------------------------------------------------------------------- +-- * Misc +-- + +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allocated on the +-- stack. This avoids having to map a CmmReg to an equivalent SSA form +-- and avoids having to deal with Phi node insertion. This is also +-- the approach recommended by LLVM developers. +-- +-- On the other hand, this is unnecessarily verbose if the register in +-- question is never written. Therefore we skip it where we can to +-- save a few lines in the output and hopefully speed compilation up a +-- bit. +funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData +funPrologue live cmmBlocks = do + + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmLocal rs + getAssignedRegs _ = [] + getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body + assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks + isLive r = r `elem` alwaysLive || r `elem` live + + platform <- getPlatform + stmtss <- forM assignedRegs $ \reg -> + case reg of + CmmLocal (LocalReg un _) -> do + let (newv, stmts) = allocReg reg + varInsert un (pLower $ getVarType newv) + return stmts + CmmGlobal r -> do + let reg = lmGlobalRegVar platform r + arg = lmGlobalRegArg platform r + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty + rval = if isLive r then arg else trash + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + markStackReg r + return $ toOL [alloc, Store rval reg] + + return (concatOL stmtss `snocOL` jumpToEntry, []) + where + entryBlk : _ = cmmBlocks + jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk) + +-- | Function epilogue. Load STG variables to use as argument for call. +-- STG Liveness optimisation done here. +funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + platform <- getPlatform + + let paddingRegs = padLiveArgs platform live + + -- Set to value or "undef" depending on whether the register is + -- actually live + let loadExpr r = do + (v, _, s) <- getCmmRegVal (CmmGlobal r) + return (Just $ v, s) + loadUndef r = do + let ty = (pLower . getVarType $ lmGlobalRegVar platform r) + return (Just $ LMLitVar $ LMUndefLit ty, nilOL) + + -- Note that floating-point registers in `activeStgRegs` must be sorted + -- according to the calling convention. + -- E.g. for X86: + -- GOOD: F1,D1,XMM1,F2,D2,XMM2,... + -- BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,... + -- As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't + -- want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1 + -- and D1 -> XMM2. + let allRegs = activeStgRegs platform + loads <- forM allRegs $ \r -> if + -- load live registers + | r `elem` alwaysLive -> loadExpr r + | r `elem` live -> loadExpr r + -- load all non Floating-Point Registers + | not (isFPR r) -> loadUndef r + -- load padding Floating-Point Registers + | r `elem` paddingRegs -> loadUndef r + | otherwise -> return (Nothing, nilOL) + + let (vars, stmts) = unzip loads + return (catMaybes vars, concatOL stmts) + +-- | Get a function pointer to the CLabel specified. +-- +-- This is for Haskell functions, function type is assumed, so doesn't work +-- with foreign functions. +getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData +getHsFunc live lbl + = do fty <- llvmFunTy live + name <- strCLabel_llvm lbl + getHsFunc' name fty + +getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData +getHsFunc' name fty + = do fun <- getGlobalPtr name + if getVarType fun == fty + then return (fun, nilOL, []) + else do (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (v1, unitOL s1, []) + +-- | Create a new local var +mkLocalVar :: LlvmType -> LlvmM LlvmVar +mkLocalVar ty = do + un <- getUniqueM + return $ LMLocalVar un ty + + +-- | Execute an expression, assigning result to a var +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) +doExpr ty expr = do + v <- mkLocalVar ty + return (v, Assignment v expr) + + +-- | Expand CmmRegOff +expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr +expandCmmReg platform (reg, off) + = let width = typeWidth (cmmRegType platform reg) + voff = CmmLit $ CmmInt (fromIntegral off) width + in CmmMachOp (MO_Add width) [CmmReg reg, voff] + + +-- | Convert a block id into a appropriate Llvm label +blockIdToLlvm :: BlockId -> LlvmVar +blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel + +-- | Create Llvm int Literal +mkIntLit :: Integral a => LlvmType -> a -> LlvmVar +mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty + +-- | Convert int type to a LLvmVar of word or i32 size +toI32 :: Integral a => a -> LlvmVar +toI32 = mkIntLit i32 + +toIWord :: Integral a => Platform -> a -> LlvmVar +toIWord platform = mkIntLit (llvmWord platform) + + +-- | Error functions +panic :: HasCallStack => String -> a +panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s + +pprPanic :: HasCallStack => String -> SDoc -> a +pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d + + +-- | Returns TBAA meta data by unique +getTBAAMeta :: Unique -> LlvmM [MetaAnnot] +getTBAAMeta u = do + mi <- getUniqMeta u + return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] + +-- | Returns TBAA meta data for given register +getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] +getTBAARegMeta = getTBAAMeta . getTBAA + + +-- | A more convenient way of accumulating LLVM statements and declarations. +data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl] + +instance Semigroup LlvmAccum where + LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB = + LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB) + +instance Monoid LlvmAccum where + mempty = LlvmAccum nilOL [] + mappend = (Semigroup.<>) + +liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar +liftExprData action = do + (var, stmts, decls) <- lift action + tell $ LlvmAccum stmts decls + return var + +statement :: LlvmStatement -> WriterT LlvmAccum LlvmM () +statement stmt = tell $ LlvmAccum (unitOL stmt) [] + +doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar +doExprW a b = do + (var, stmt) <- lift $ doExpr a b + statement stmt + return var + +exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar +exprToVarW = liftExprData . exprToVar + +runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData +runExprData action = do + (var, LlvmAccum stmts decls) <- runWriterT action + return (var, stmts, decls) + +runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl]) +runStmtsDecls action = do + LlvmAccum stmts decls <- execWriterT action + return (stmts, decls) + +getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar +getCmmRegW = lift . getCmmReg + +genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar +genLoadW atomic e ty = liftExprData $ genLoad atomic e ty + +-- | Return element of single-element list; 'panic' if list is not a single-element list +singletonPanic :: String -> [a] -> a +singletonPanic _ [x] = x +singletonPanic s _ = panic s diff --git a/GHC/CmmToLlvm/Data.hs b/GHC/CmmToLlvm/Data.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Data.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE CPP #-} +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmData to LLVM code. +-- + +module GHC.CmmToLlvm.Data ( + genLlvmData, genData + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Platform + +import GHC.Data.FastString +import GHC.Utils.Outputable +import qualified Data.ByteString as BS + +-- ---------------------------------------------------------------------------- +-- * Constants +-- + +-- | The string appended to a variable name to create its structure type alias +structStr :: LMString +structStr = fsLit "_struct" + +-- | The LLVM visibility of the label +linkage :: CLabel -> LlvmLinkageType +linkage lbl = if externallyVisibleCLabel lbl + then ExternallyVisible else Internal + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pass a CmmStatic section to an equivalent Llvm code. +genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData +-- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' = do + label <- strCLabel_llvm alias + label' <- strCLabel_llvm ind' + let link = linkage alias + link' = linkage ind' + -- the LLVM type we give the alias is an empty struct type + -- but it doesn't really matter, as the pointer is only + -- used for (bit/int)casting. + tyAlias = LMAlias (label `appendFS` structStr, LMStructU []) + + aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias + -- we don't know the type of the indirectee here + indType = panic "will be filled by 'aliasify', later" + orig = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias + + pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) + +genLlvmData (sec, CmmStaticsRaw lbl xs) = do + label <- strCLabel_llvm lbl + static <- mapM genData xs + lmsec <- llvmSection sec + platform <- getPlatform + let types = map getStatType static + + strucTy = LMStruct types + tyAlias = LMAlias (label `appendFS` structStr, strucTy) + + struct = Just $ LMStaticStruc static tyAlias + link = linkage lbl + align = case sec of + Section CString _ -> if (platformArch platform == ArchS390X) + then Just 2 else Just 1 + _ -> Nothing + const = if sectionProtection sec == ReadOnlySection + then Constant else Global + varDef = LMGlobalVar label tyAlias link lmsec align const + globDef = LMGlobal varDef struct + + return ([globDef], [tyAlias]) + +-- | Format the section type part of a Cmm Section +llvmSectionType :: Platform -> SectionType -> FastString +llvmSectionType p t = case t of + Text -> fsLit ".text" + ReadOnlyData -> case platformOS p of + OSMinGW32 -> fsLit ".rdata" + _ -> fsLit ".rodata" + RelocatableReadOnlyData -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$rel.ro" + _ -> fsLit ".data.rel.ro" + ReadOnlyData16 -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$cst16" + _ -> fsLit ".rodata.cst16" + Data -> fsLit ".data" + UninitialisedData -> fsLit ".bss" + CString -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$str" + _ -> fsLit ".rodata.str" + (OtherSection _) -> panic "llvmSectionType: unknown section type" + +-- | Format a Cmm Section into a LLVM section name +llvmSection :: Section -> LlvmM LMSection +llvmSection (Section t suffix) = do + opts <- getLlvmOpts + let splitSect = llvmOptsSplitSections opts + platform = llvmOptsPlatform opts + if not splitSect + then return Nothing + else do + lmsuffix <- strCLabel_llvm suffix + let result sep = Just (concatFS [llvmSectionType platform t + , fsLit sep, lmsuffix]) + case platformOS platform of + OSMinGW32 -> return (result "$") + _ -> return (result ".") + +-- ---------------------------------------------------------------------------- +-- * Generate static data +-- + +-- | Handle static data +genData :: CmmStatic -> LlvmM LlvmStatic + +genData (CmmFileEmbed {}) = panic "Unexpected CmmFileEmbed literal" +genData (CmmString str) = do + let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) + (BS.unpack str) + ve = v ++ [LMStaticLit $ LMIntLit 0 i8] + return $ LMStaticArray ve (LMArray (length ve) i8) + +genData (CmmUninitialised bytes) + = return $ LMUninitType (LMArray bytes i8) + +genData (CmmStaticLit lit) + = genStaticLit lit + +-- | Generate Llvm code for a static literal. +-- +-- Will either generate the code or leave it unresolved if it is a 'CLabel' +-- which isn't yet known. +genStaticLit :: CmmLit -> LlvmM LlvmStatic +genStaticLit (CmmInt i w) + = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + +genStaticLit (CmmFloat r w) + = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) + +genStaticLit (CmmVec ls) + = do sls <- mapM toLlvmLit ls + return $ LMStaticLit (LMVectorLit sls) + where + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + slit <- genStaticLit lit + case slit of + LMStaticLit llvmLit -> return llvmLit + _ -> panic "genStaticLit" + +-- Leave unresolved, will fix later +genStaticLit cmm@(CmmLabel l) = do + var <- getGlobalPtr =<< strCLabel_llvm l + platform <- getPlatform + let ptr = LMStaticPointer var + lmty = cmmToLlvmType $ cmmLitType platform cmm + return $ LMPtoI ptr lmty + +genStaticLit (CmmLabelOff label off) = do + platform <- getPlatform + var <- genStaticLit (CmmLabel label) + let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord platform) + return $ LMAdd var offset + +genStaticLit (CmmLabelDiffOff l1 l2 off w) = do + platform <- getPlatform + var1 <- genStaticLit (CmmLabel l1) + var2 <- genStaticLit (CmmLabel l2) + let var + | w == wordWidth platform = LMSub var1 var2 + | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w) + offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w) + return $ LMAdd var offset + +genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b + +genStaticLit (CmmHighStackMark) + = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/GHC/CmmToLlvm/Mangler.hs b/GHC/CmmToLlvm/Mangler.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Mangler.hs @@ -0,0 +1,129 @@ +-- ----------------------------------------------------------------------------- +-- | GHC LLVM Mangler +-- +-- This script processes the assembly produced by LLVM, rewriting all symbols +-- of type @function to @object. This keeps them from going through the PLT, +-- which would be bad due to tables-next-to-code. On x86_64, +-- it also rewrites AVX instructions that require alignment to their +-- unaligned counterparts, since the stack is only 16-byte aligned but these +-- instructions require 32-byte alignment. +-- + +module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where + +import GHC.Prelude + +import GHC.Driver.Session ( DynFlags, targetPlatform ) +import GHC.Platform ( platformArch, Arch(..) ) +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Outputable ( text ) + +import Control.Exception +import qualified Data.ByteString.Char8 as B +import System.IO + +-- | Read in assembly file and process +llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () +llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} + withTiming dflags (text "LLVM Mangler") id $ + withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do + go r w + hClose r + hClose w + return () + where + go :: Handle -> Handle -> IO () + go r w = do + e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString) + let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w + case e_l of + Right l -> writeline l + Left _ -> return () + +-- | These are the rewrites that the mangler will perform +rewrites :: [Rewrite] +rewrites = [rewriteSymType, rewriteAVX] + +type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString + +-- | Rewrite a line of assembly source with the given rewrites, +-- taking the first rewrite that applies. +rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString +rewriteLine dflags rewrites l + -- We disable .subsections_via_symbols on darwin and ios, as the llvm code + -- gen uses prefix data for the info table. This however does not prevent + -- llvm from generating .subsections_via_symbols, which in turn with + -- -dead_strip, strips the info tables, and therefore breaks ghc. + | isSubsectionsViaSymbols l = + (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!") + | otherwise = + case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of + Nothing -> l + Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten] + where + isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols") + + (symbol, rest) = splitLine l + + firstJust :: [Maybe a] -> Maybe a + firstJust (Just x:_) = Just x + firstJust [] = Nothing + firstJust (_:rest) = firstJust rest + +-- | This rewrites @.type@ annotations of function symbols to @%object@. +-- This is done as the linker can relocate @%functions@ through the +-- Procedure Linking Table (PLT). This is bad since we expect that the +-- info table will appear directly before the symbol's location. In the +-- case that the PLT is used, this will be not an info table but instead +-- some random PLT garbage. +rewriteSymType :: Rewrite +rewriteSymType _ l + | isType l = Just $ rewrite '@' $ rewrite '%' l + | otherwise = Nothing + where + isType = B.isPrefixOf (B.pack ".type") + + rewrite :: Char -> B.ByteString -> B.ByteString + rewrite prefix = replaceOnce funcType objType + where + funcType = prefix `B.cons` B.pack "function" + objType = prefix `B.cons` B.pack "object" + +-- | This rewrites aligned AVX instructions to their unaligned counterparts on +-- x86-64. This is necessary because the stack is not adequately aligned for +-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer +-- and disable tail call optimization. Both would be catastrophic here so GHC +-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then +-- rewrites the instructions in the mangler. +rewriteAVX :: Rewrite +rewriteAVX dflags s + | not isX86_64 = Nothing + | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s + | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s + | otherwise = Nothing + where + isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64 + isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") + isVmovap = B.isPrefixOf (B.pack "vmovap") + +-- | @replaceOnce match replace bs@ replaces the first occurrence of the +-- substring @match@ in @bs@ with @replace@. +replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +replaceOnce matchBS replaceOnceBS = loop + where + loop :: B.ByteString -> B.ByteString + loop cts = + case B.breakSubstring matchBS cts of + (hd,tl) | B.null tl -> hd + | otherwise -> hd `B.append` replaceOnceBS `B.append` + B.drop (B.length matchBS) tl + +-- | This function splits a line of assembly code into the label and the +-- rest of the code. +splitLine :: B.ByteString -> (B.ByteString, B.ByteString) +splitLine l = (symbol, B.dropWhile isSpace rest) + where + isSpace ' ' = True + isSpace '\t' = True + isSpace _ = False + (symbol, rest) = B.span (not . isSpace) l diff --git a/GHC/CmmToLlvm/Ppr.hs b/GHC/CmmToLlvm/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Ppr.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE CPP #-} + +-- ---------------------------------------------------------------------------- +-- | Pretty print helpers for the LLVM Code generator. +-- +module GHC.CmmToLlvm.Ppr ( + pprLlvmCmmDecl, pprLlvmData, infoSection + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.Data + +import GHC.Cmm.CLabel +import GHC.Cmm + +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.Unique + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pretty print LLVM data code +pprLlvmData :: LlvmOpts -> LlvmData -> SDoc +pprLlvmData opts (globals, types) = + let ppLlvmTys (LMAlias a) = ppLlvmAlias a + ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f + ppLlvmTys _other = empty + + types' = vcat $ map ppLlvmTys types + globals' = ppLlvmGlobals opts globals + in types' $+$ globals' + + +-- | Pretty print LLVM code +pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +pprLlvmCmmDecl (CmmData _ lmdata) = do + opts <- getLlvmOpts + return (vcat $ map (pprLlvmData opts) lmdata, []) + +pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) + = do let lbl = case mb_info of + Nothing -> entry_lbl + Just (CmmStaticsRaw info_lbl _) -> info_lbl + link = if externallyVisibleCLabel lbl + then ExternallyVisible + else Internal + lmblocks = map (\(BasicBlock id stmts) -> + LlvmBlock (getUnique id) stmts) blks + + funDec <- llvmFunSig live lbl link + dflags <- getDynFlags + opts <- getLlvmOpts + platform <- getPlatform + let buildArg = fsLit . showSDoc dflags . ppPlainName opts + funArgs = map buildArg (llvmFunArgs platform live) + funSect = llvmFunSection opts (decName funDec) + + -- generate the info table + prefix <- case mb_info of + Nothing -> return Nothing + Just (CmmStaticsRaw _ statics) -> do + infoStatics <- mapM genData statics + let infoTy = LMStruct $ map getStatType infoStatics + return $ Just $ LMStaticStruc infoStatics infoTy + + + let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect + prefix lmblocks + name = decName $ funcDecl fun + defName = llvmDefLabel name + funcDecl' = (funcDecl fun) { decName = defName } + fun' = fun { funcDecl = funcDecl' } + funTy = LMFunction funcDecl' + funVar = LMGlobalVar name + (LMPointer funTy) + link + Nothing + Nothing + Alias + defVar = LMGlobalVar defName + (LMPointer funTy) + (funcLinkage funcDecl') + (funcSect fun) + (funcAlign funcDecl') + Alias + alias = LMGlobal funVar + (Just $ LMBitc (LMStaticPointer defVar) + i8Ptr) + + return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', []) + + +-- | The section we are putting info tables and their entry code into, should +-- be unique since we process the assembly pattern matching this. +infoSection :: String +infoSection = "X98A__STRIP,__me" diff --git a/GHC/CmmToLlvm/Regs.hs b/GHC/CmmToLlvm/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Regs.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------------------- +-- | Deal with Cmm registers +-- + +module GHC.CmmToLlvm.Regs ( + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Llvm + +import GHC.Cmm.Expr +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Outputable ( panic ) +import GHC.Types.Unique + +-- | Get the LlvmVar function variable storing the real register +lmGlobalRegVar :: Platform -> GlobalReg -> LlvmVar +lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var" + +-- | Get the LlvmVar function argument storing the real register +lmGlobalRegArg :: Platform -> GlobalReg -> LlvmVar +lmGlobalRegArg platform = lmGlobalReg platform "_Arg" + +{- Need to make sure the names here can't conflict with the unique generated + names. Uniques generated names containing only base62 chars. So using say + the '_' char guarantees this. +-} +lmGlobalReg :: Platform -> String -> GlobalReg -> LlvmVar +lmGlobalReg platform suf reg + = case reg of + BaseReg -> ptrGlobal $ "Base" ++ suf + Sp -> ptrGlobal $ "Sp" ++ suf + Hp -> ptrGlobal $ "Hp" ++ suf + VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf + VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf + VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf + VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf + VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf + VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf + VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf + VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf + VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf + SpLim -> wordGlobal $ "SpLim" ++ suf + FloatReg 1 -> floatGlobal $"F1" ++ suf + FloatReg 2 -> floatGlobal $"F2" ++ suf + FloatReg 3 -> floatGlobal $"F3" ++ suf + FloatReg 4 -> floatGlobal $"F4" ++ suf + FloatReg 5 -> floatGlobal $"F5" ++ suf + FloatReg 6 -> floatGlobal $"F6" ++ suf + DoubleReg 1 -> doubleGlobal $ "D1" ++ suf + DoubleReg 2 -> doubleGlobal $ "D2" ++ suf + DoubleReg 3 -> doubleGlobal $ "D3" ++ suf + DoubleReg 4 -> doubleGlobal $ "D4" ++ suf + DoubleReg 5 -> doubleGlobal $ "D5" ++ suf + DoubleReg 6 -> doubleGlobal $ "D6" ++ suf + XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf + XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf + XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf + XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf + XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf + XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf + YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf + YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf + YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf + YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf + YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf + YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf + ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf + ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf + ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf + ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf + ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf + ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf + MachSp -> wordGlobal $ "MachSp" ++ suf + _other -> panic $ "GHC.CmmToLlvm.Reg: GlobalReg (" ++ (show reg) + ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg + where + wordGlobal name = LMNLocalVar (fsLit name) (llvmWord platform) + ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr platform) + floatGlobal name = LMNLocalVar (fsLit name) LMFloat + doubleGlobal name = LMNLocalVar (fsLit name) LMDouble + xmmGlobal name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32)) + ymmGlobal name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32)) + zmmGlobal name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32)) + +-- | A list of STG Registers that should always be considered alive +alwaysLive :: [GlobalReg] +alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] + +-- | STG Type Based Alias Analysis hierarchy +stgTBAA :: [(Unique, LMString, Maybe Unique)] +stgTBAA + = [ (rootN, fsLit "root", Nothing) + , (topN, fsLit "top", Just rootN) + , (stackN, fsLit "stack", Just topN) + , (heapN, fsLit "heap", Just topN) + , (rxN, fsLit "rx", Just heapN) + , (baseN, fsLit "base", Just topN) + -- FIX: Not 100% sure if this hierarchy is complete. I think the big thing + -- is Sp is never aliased, so might want to change the hierarchy to have Sp + -- on its own branch that is never aliased (e.g never use top as a TBAA + -- node). + ] + +-- | Id values +-- The `rootN` node is the root (there can be more than one) of the TBAA +-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It +-- should never occur in any LLVM instruction statement. +rootN, topN, stackN, heapN, rxN, baseN :: Unique +rootN = getUnique (fsLit "GHC.CmmToLlvm.Regs.rootN") +topN = getUnique (fsLit "GHC.CmmToLlvm.Regs.topN") +stackN = getUnique (fsLit "GHC.CmmToLlvm.Regs.stackN") +heapN = getUnique (fsLit "GHC.CmmToLlvm.Regs.heapN") +rxN = getUnique (fsLit "GHC.CmmToLlvm.Regs.rxN") +baseN = getUnique (fsLit "GHC.CmmToLlvm.Regs.baseN") + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> Unique +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _ _) = rxN +getTBAA _ = topN diff --git a/GHC/Core.hs b/GHC/Core.hs new file mode 100644 --- /dev/null +++ b/GHC/Core.hs @@ -0,0 +1,2360 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection +module GHC.Core ( + -- * Main data types + Expr(..), Alt, Bind(..), AltCon(..), Arg, + Tickish(..), TickishScoping(..), TickishPlacement(..), + CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, + + -- * In/Out type synonyms + InId, InBind, InExpr, InAlt, InArg, InType, InKind, + InBndr, InVar, InCoercion, InTyVar, InCoVar, + OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind, + OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion, + + -- ** 'Expr' construction + mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams, + mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg, + + mkIntLit, mkIntLitWrap, + mkWordLit, mkWordLitWrap, + mkWord64LitWord64, mkInt64LitInt64, + mkCharLit, mkStringLit, + mkFloatLit, mkFloatLitFloat, + mkDoubleLit, mkDoubleLitDouble, + + mkConApp, mkConApp2, mkTyBind, mkCoBind, + varToCoreExpr, varsToCoreExprs, + + isId, cmpAltCon, cmpAlt, ltAlt, + + -- ** Simple 'Expr' access functions and predicates + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + collectBinders, collectTyBinders, collectTyAndValBinders, + collectNBinders, + collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + + exprToType, exprToCoercion_maybe, + applyTypeToArg, + + isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount, + isRuntimeArg, isRuntimeVar, + + -- * Tick-related functions + tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable, + tickishCanSplit, mkNoCount, mkNoScope, + tickishIsCode, tickishPlace, + tickishContains, + + -- * Unfolding data types + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + + -- ** Constructing 'Unfolding's + noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, + + -- ** Predicates and deconstruction on 'Unfolding' + unfoldingTemplate, expandUnfolding_maybe, + maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, + isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding, + isBootUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, + + -- * Annotated expression data types + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, + + -- ** Operations on annotated expressions + collectAnnArgs, collectAnnArgsTicks, + + -- ** Operations on annotations + deAnnotate, deAnnotate', deAnnAlt, deAnnBind, + collectAnnBndrs, collectNAnnBndrs, + + -- * Orphanhood + IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, + + -- * Core rule data types + CoreRule(..), RuleBase, + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, + RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv, + + -- ** Operations on 'CoreRule's + ruleArity, ruleName, ruleIdName, ruleActivation, + setRuleIdName, ruleModule, + isBuiltinRule, isLocalRule, isAutoRule, + ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Types.CostCentre +import GHC.Types.Var.Env( InScopeSet ) +import GHC.Types.Var +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env( NameEnv, emptyNameEnv ) +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Unit.Module +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Unique.Set +import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) +import GHC.Utils.Binary + +import Data.Data hiding (TyCon) +import Data.Int +import Data.Word + +infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` +-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) + +{- +************************************************************************ +* * +\subsection{The main data types} +* * +************************************************************************ + +These data types are the heart of the compiler +-} + +-- | This is the data type that represents GHCs core intermediate language. Currently +-- GHC uses System FC for this purpose, +-- which is closely related to the simpler and better known System F . +-- +-- We get from Haskell source to this Core language in a number of stages: +-- +-- 1. The source code is parsed into an abstract syntax tree, which is represented +-- by the data type 'GHC.Hs.Expr.HsExpr' with the names being 'GHC.Types.Name.Reader.RdrNames' +-- +-- 2. This syntax tree is /renamed/, which attaches a 'GHC.Types.Unique.Unique' to every 'GHC.Types.Name.Reader.RdrName' +-- (yielding a 'GHC.Types.Name.Name') to disambiguate identifiers which are lexically identical. +-- For example, this program: +-- +-- @ +-- f x = let f x = x + 1 +-- in f (x - 2) +-- @ +-- +-- Would be renamed by having 'Unique's attached so it looked something like this: +-- +-- @ +-- f_1 x_2 = let f_3 x_4 = x_4 + 1 +-- in f_3 (x_2 - 2) +-- @ +-- But see Note [Shadowing] below. +-- +-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating +-- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names. +-- +-- 4. Finally the syntax tree is /desugared/ from the expressive 'GHC.Hs.Expr.HsExpr' type into +-- this 'Expr' type, which has far fewer constructors and hence is easier to perform +-- optimization, analysis and code generation on. +-- +-- The type parameter @b@ is for the type of binders in the expression tree. +-- +-- The language consists of the following elements: +-- +-- * Variables +-- See Note [Variable occurrences in Core] +-- +-- * Primitive literals +-- +-- * Applications: note that the argument may be a 'Type'. +-- See Note [Core let/app invariant] +-- See Note [Levity polymorphism invariants] +-- +-- * Lambda abstraction +-- See Note [Levity polymorphism invariants] +-- +-- * Recursive and non recursive @let@s. Operationally +-- this corresponds to allocating a thunk for the things +-- bound and then executing the sub-expression. +-- +-- See Note [Core letrec invariant] +-- See Note [Core let/app invariant] +-- See Note [Levity polymorphism invariants] +-- See Note [Core type and coercion invariant] +-- +-- * Case expression. Operationally this corresponds to evaluating +-- the scrutinee (expression examined) to weak head normal form +-- and then examining at most one level of resulting constructor (i.e. you +-- cannot do nested pattern matching directly with this). +-- +-- The binder gets bound to the value of the scrutinee, +-- and the 'Type' must be that of all the case alternatives +-- +-- IMPORTANT: see Note [Case expression invariants] +-- +-- * Cast an expression to a particular type. +-- This is used to implement @newtype@s (a @newtype@ constructor or +-- destructor just becomes a 'Cast' in Core) and GADTs. +-- +-- * Ticks. These are used to represent all the source annotation we +-- support: profiling SCCs, HPC ticks, and GHCi breakpoints. +-- +-- * A type: this should only show up at the top level of an Arg +-- +-- * A coercion + +{- Note [Why does Case have a 'Type' field?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The obvious alternative is + exprType (Case scrut bndr alts) + | (_,_,rhs1):_ <- alts + = exprType rhs1 + +But caching the type in the Case constructor + exprType (Case scrut bndr ty alts) = ty +is better for at least three reasons: + +* It works when there are no alternatives (see case invariant 1 above) + +* It might be faster in deeply-nested situations. + +* It might not be quite the same as (exprType rhs) for one + of the RHSs in alts. Consider a phantom type synonym + type S a = Int + and we want to form the case expression + case x of { K (a::*) -> (e :: S a) } + Then exprType of the RHS is (S a), but we cannot make that be + the 'ty' in the Case constructor because 'a' is simply not in + scope there. Instead we must expand the synonym to Int before + putting it in the Case constructor. See GHC.Core.Utils.mkSingleAltCase. + + So we'd have to do synonym expansion in exprType which would + be inefficient. + +* The type stored in the case is checked with lintInTy. This checks + (among other things) that it does not mention any variables that are + not in scope. If we did not have the type there, it would be a bit + harder for Core Lint to reject case blah of Ex x -> x where + data Ex = forall a. Ex a. +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Expr b + = Var Id + | Lit Literal + | App (Expr b) (Arg b) + | Lam b (Expr b) + | Let (Bind b) (Expr b) + | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants] + -- and Note [Why does Case have a 'Type' field?] + | Cast (Expr b) CoercionR -- The Coercion has Representational role + | Tick (Tickish Id) (Expr b) + | Type Type + | Coercion Coercion + deriving Data + +-- | Type synonym for expressions that occur in function argument positions. +-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not +type Arg b = Expr b + +-- | A case split alternative. Consists of the constructor leading to the alternative, +-- the variables bound from the constructor, and the expression to be executed given that binding. +-- The default alternative is @(DEFAULT, [], rhs)@ + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +type Alt b = (AltCon, [b], Expr b) + +-- | A case alternative constructor (i.e. pattern match) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data AltCon + = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. + -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ + + | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ + -- Invariant: always an *unlifted* literal + -- See Note [Literal alternatives] + + | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ + deriving (Eq, Data) + +-- This instance is a bit shady. It can only be used to compare AltCons for +-- a single type constructor. Fortunately, it seems quite unlikely that we'll +-- ever need to compare AltCons for different type constructors. +-- The instance adheres to the order described in [Core case invariants] +instance Ord AltCon where + compare (DataAlt con1) (DataAlt con2) = + ASSERT( dataConTyCon con1 == dataConTyCon con2 ) + compare (dataConTag con1) (dataConTag con2) + compare (DataAlt _) _ = GT + compare _ (DataAlt _) = LT + compare (LitAlt l1) (LitAlt l2) = compare l1 l2 + compare (LitAlt _) DEFAULT = GT + compare DEFAULT DEFAULT = EQ + compare DEFAULT _ = LT + +-- | Binding, used for top level bindings in a module and local bindings in a @let@. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + deriving Data + +{- +Note [Shadowing] +~~~~~~~~~~~~~~~~ +While various passes attempt to rename on-the-fly in a manner that +avoids "shadowing" (thereby simplifying downstream optimizations), +neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +In particular, scrutinee variables `x` in expressions of the form +`Case e x t` are often renamed to variables with a prefix +"wild_". These "wild" variables may appear in the body of the +case-expression, and further, may be shadowed within the body. + +So the Unique in a Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +Note [Literal alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal alternatives (LitAlt lit) are always for *un-lifted* literals. +We have one literal, a literal Integer, that is lifted, and we don't +allow in a LitAlt, because LitAlt cases don't do any evaluation. Also +(see #5603) if you say + case 3 of + IS x -> ... + IP _ -> ... + IN _ -> ... +(where IS, IP, IN are the constructors for Integer) we don't want the +simplifier calling findAlt with argument (LitAlt 3). No no. Integer +literals are an opaque encoding of an algebraic data type, not of +an unlifted literal, like all the others. + +Also, we do not permit case analysis with literal patterns on floating-point +types. See #9238 and Note [Rules for floating-point comparisons] in +GHC.Core.Opt.ConstantFold for the rationale for this restriction. + +-------------------------- GHC.Core INVARIANTS --------------------------- + +Note [Variable occurrences in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Variable /occurrences/ are never CoVars, though /bindings/ can be. +All CoVars appear in Coercions. + +For example + \(c :: Age~#Int) (d::Int). d |> (sym c) +Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in +a Coercion, (sym c). + +Note [Core letrec invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The right hand sides of all top-level and recursive @let@s +/must/ be of lifted type (see "Type#type_classification" for +the meaning of /lifted/ vs. /unlifted/). + +There is one exception to this rule, top-level @let@s are +allowed to bind primitive string literals: see +Note [Core top-level string literals]. + +Note [Core top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As an exception to the usual rule that top-level binders must be lifted, +we allow binding primitive string literals (of type Addr#) of type Addr# at the +top level. This allows us to share string literals earlier in the pipeline and +crucially allows other optimizations in the Core2Core pipeline to fire. +Consider, + + f n = let a::Addr# = "foo"# + in \x -> blah + +In order to be able to inline `f`, we would like to float `a` to the top. +Another option would be to inline `a`, but that would lead to duplicating string +literals, which we want to avoid. See #8472. + +The solution is simply to allow top-level unlifted binders. We can't allow +arbitrary unlifted expression at the top-level though, unlifted binders cannot +be thunks, so we just allow string literals. + +We allow the top-level primitive string literals to be wrapped in Ticks +in the same way they can be wrapped when nested in an expression. +CoreToSTG currently discards Ticks around top-level primitive string literals. +See #14779. + +Also see Note [Compilation plan for top-level string literals]. + +Note [Compilation plan for top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a summary on how top-level string literals are handled by various +parts of the compilation pipeline. + +* In the source language, there is no way to bind a primitive string literal + at the top level. + +* In Core, we have a special rule that permits top-level Addr# bindings. See + Note [Core top-level string literals]. Core-to-core passes may introduce + new top-level string literals. + +* In STG, top-level string literals are explicitly represented in the syntax + tree. + +* A top-level string literal may end up exported from a module. In this case, + in the object file, the content of the exported literal is given a label with + the _bytes suffix. + +Note [Core let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The let/app invariant + the right hand side of a non-recursive 'Let', and + the argument of an 'App', + /may/ be of unlifted type, but only if + the expression is ok-for-speculation + or the 'Let' is for a join point. + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary + +The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in +GHC.Core.Make. + +For discussion of some implications of the let/app invariant primops see +Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps. + +Note [Case expression invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions are one of the more complicated elements of the Core +language, and come with a number of invariants. All of them should be +checked by Core Lint. + +1. The list of alternatives may be empty; + See Note [Empty case alternatives] + +2. The 'DEFAULT' case alternative must be first in the list, + if it occurs at all. Checked in GHC.Core.Lint.checkCaseAlts. + +3. The remaining cases are in order of (strictly) increasing + tag (for 'DataAlts') or + lit (for 'LitAlts'). + This makes finding the relevant constructor easy, and makes + comparison easier too. Checked in GHC.Core.Lint.checkCaseAlts. + +4. The list of alternatives must be exhaustive. An /exhaustive/ case + does not necessarily mention all constructors: + + @ + data Foo = Red | Green | Blue + ... case x of + Red -> True + other -> f (case x of + Green -> ... + Blue -> ... ) ... + @ + + The inner case does not need a @Red@ alternative, because @x@ + can't be @Red@ at that program point. + + This is not checked by Core Lint -- it's very hard to do so. + E.g. suppose that inner case was floated out, thus: + let a = case x of + Green -> ... + Blue -> ... ) + case x of + Red -> True + other -> f a + Now it's really hard to see that the Green/Blue case is + exhaustive. But it is. + + If you have a case-expression that really /isn't/ exhaustive, + we may generate seg-faults. Consider the Green/Blue case + above. Since there are only two branches we may generate + code that tests for Green, and if not Green simply /assumes/ + Blue (since, if the case is exhaustive, that's all that + remains). Of course, if it's not Blue and we start fetching + fields that should be in a Blue constructor, we may die + horribly. See also Note [Core Lint guarantee] in GHC.Core.Lint. + +5. Floating-point values must not be scrutinised against literals. + See #9238 and Note [Rules for floating-point comparisons] + in GHC.Core.Opt.ConstantFold for rationale. Checked in lintCaseExpr; + see the call to isFloatingTy. + +6. The 'ty' field of (Case scrut bndr ty alts) is the type of the + /entire/ case expression. Checked in lintAltExpr. + See also Note [Why does Case have a 'Type' field?]. + +7. The type of the scrutinee must be the same as the type + of the case binder, obviously. Checked in lintCaseExpr. + +8. The multiplicity of the binders in constructor patterns must be the + multiplicity of the corresponding field /scaled by the multiplicity of the + case binder/. Checked in lintCoreAlt. + +Note [Core type and coercion invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a /non-recursive/, /non-top-level/ let to bind type and +coercion variables. These can be very convenient for postponing type +substitutions until the next run of the simplifier. + +* A type variable binding must have a RHS of (Type ty) + +* A coercion variable binding must have a RHS of (Coercion co) + + It is possible to have terms that return a coercion, but we use + case-binding for those; e.g. + case (eq_sel d) of (co :: a ~# b) -> blah + where eq_sel :: (a~b) -> (a~#b) + + Or even + case (df @Int) of (co :: a ~# b) -> blah + Which is very exotic, and I think never encountered; but see + Note [Equality superclasses in quantified constraints] + in GHC.Tc.Solver.Canonical + +Note [Core case invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Case expression invariants] + +Note [Levity polymorphism invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The levity-polymorphism invariants are these (as per "Levity Polymorphism", +PLDI '17): + +* The type of a term-binder must not be levity-polymorphic, + unless it is a let(rec)-bound join point + (see Note [Invariants on join points]) + +* The type of the argument of an App must not be levity-polymorphic. + +A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables. + +For example + \(r::RuntimeRep). \(a::TYPE r). \(x::a). e +is illegal because x's type has kind (TYPE r), which has 'r' free. + +See Note [Levity polymorphism checking] in GHC.HsToCore.Monad to see where these +invariants are established for user-written code. + +Note [Core let goal] +~~~~~~~~~~~~~~~~~~~~ +* The simplifier tries to ensure that if the RHS of a let is a constructor + application, its arguments are trivial, so that the constructor can be + inlined vigorously. + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The alternatives of a case expression should be exhaustive. But +this exhaustive list can be empty! + +* A case expression can have empty alternatives if (and only if) the + scrutinee is bound to raise an exception or diverge. When do we know + this? See Note [Bottoming expressions] in GHC.Core.Utils. + +* The possibility of empty alternatives is one reason we need a type on + the case expression: if the alternatives are empty we can't get the + type from the alternatives! + +* In the case of empty types (see Note [Bottoming expressions]), say + data T + we do NOT want to replace + case (x::T) of Bool {} --> error Bool "Inaccessible case" + because x might raise an exception, and *that*'s what we want to see! + (#6067 is an example.) To preserve semantics we'd have to say + x `seq` error Bool "Inaccessible case" + but the 'seq' is just such a case, so we are back to square 1. + +* We can use the empty-alternative construct to coerce error values from + one type to another. For example + + f :: Int -> Int + f n = error "urk" + + g :: Int -> (# Char, Bool #) + g x = case f x of { 0 -> ..., n -> ... } + + Then if we inline f in g's RHS we get + case (error Int "urk") of (# Char, Bool #) { ... } + and we can discard the alternatives since the scrutinee is bottom to give + case (error Int "urk") of (# Char, Bool #) {} + + This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), + if for no other reason that we don't need to instantiate the (~) at an + unboxed type. + +* We treat a case expression with empty alternatives as trivial iff + its scrutinee is (see GHC.Core.Utils.exprIsTrivial). This is actually + important; see Note [Empty case is trivial] in GHC.Core.Utils + +* An empty case is replaced by its scrutinee during the CoreToStg + conversion; remember STG is un-typed, so there is no need for + the empty case to do the type conversion. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +In Core, a *join point* is a specially tagged function whose only occurrences +are saturated tail calls. A tail call can appear in these places: + + 1. In the branches (not the scrutinee) of a case + 2. Underneath a let (value or join point) + 3. Inside another join point + +We write a join-point declaration as + join j @a @b x y = e1 in e2, +like a let binding but with "join" instead (or "join rec" for "let rec"). Note +that we put the parameters before the = rather than using lambdas; this is +because it's relevant how many parameters the join point takes *as a join +point.* This number is called the *join arity,* distinct from arity because it +counts types as well as values. Note that a join point may return a lambda! So + join j x = x + 1 +is different from + join j = \x -> x + 1 +The former has join arity 1, while the latter has join arity 0. + +The identifier for a join point is called a join id or a *label.* An invocation +is called a *jump.* We write a jump using the jump keyword: + + jump j 3 + +The words *label* and *jump* are evocative of assembly code (or Cmm) for a +reason: join points are indeed compiled as labeled blocks, and jumps become +actual jumps (plus argument passing and stack adjustment). There is no closure +allocated and only a fraction of the function-call overhead. Hence we would +like as many functions as possible to become join points (see OccurAnal) and +the type rules for join points ensure we preserve the properties that make them +efficient. + +In the actual AST, a join point is indicated by the IdDetails of the binder: a +local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its +join arity. + +For more details, see the paper: + + Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling + without continuations." Submitted to PLDI'17. + + https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/ + +Note [Invariants on join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Join points must follow these invariants: + + 1. All occurrences must be tail calls. Each of these tail calls must pass the + same number of arguments, counting both types and values; we call this the + "join arity" (to distinguish from regular arity, which only counts values). + + See Note [Join points are less general than the paper] + + 2. For join arity n, the right-hand side must begin with at least n lambdas. + No ticks, no casts, just lambdas! C.f. GHC.Core.Utils.joinRhsArity. + + 2a. Moreover, this same constraint applies to any unfolding of + the binder. Reason: if we want to push a continuation into + the RHS we must push it into the unfolding as well. + + 2b. The Arity (in the IdInfo) of a join point is the number of value + binders in the top n lambdas, where n is the join arity. + + So arity <= join arity; the former counts only value binders + while the latter counts all binders. + e.g. Suppose $j has join arity 1 + let j = \x y. e in case x of { A -> j 1; B -> j 2 } + Then its ordinary arity is also 1, not 2. + + The arity of a join point isn't very important; but short of setting + it to zero, it is helpful to have an invariant. E.g. #17294. + + 3. If the binding is recursive, then all other bindings in the recursive group + must also be join points. + + 4. The binding's type must not be polymorphic in its return type (as defined + in Note [The polymorphism rule of join points]). + +However, join points have simpler invariants in other ways + + 5. A join point can have an unboxed type without the RHS being + ok-for-speculation (i.e. drop the let/app invariant) + e.g. let j :: Int# = factorial x in ... + + 6. A join point can have a levity-polymorphic RHS + e.g. let j :: r :: TYPE l = fail void# in ... + This happened in an intermediate program #13394 + +Examples: + + join j1 x = 1 + x in jump j (jump j x) -- Fails 1: non-tail call + join j1' x = 1 + x in if even a + then jump j1 a + else jump j1 a b -- Fails 1: inconsistent calls + join j2 x = flip (+) x in j2 1 2 -- Fails 2: not enough lambdas + join j2' x = \y -> x + y in j3 1 -- Passes: extra lams ok + join j @a (x :: a) = x -- Fails 4: polymorphic in ret type + +Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join +point must have an exact call as its LHS. + +Strictly speaking, invariant 3 is redundant, since a call from inside a lazy +binding isn't a tail call. Since a let-bound value can't invoke a free join +point, then, they can't be mutually recursive. (A Core binding group *can* +include spurious extra bindings if the occurrence analyser hasn't run, so +invariant 3 does still need to be checked.) For the rigorous definition of +"tail call", see Section 3 of the paper (Note [Join points]). + +Invariant 4 is subtle; see Note [The polymorphism rule of join points]. + +Invariant 6 is to enable code like this: + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + join j :: a + j = error @r @a "bloop" + in case x of + A -> j + B -> j + C -> error @r @a "blurp" + +Core Lint will check these invariants, anticipating that any binder whose +OccInfo is marked AlwaysTailCalled will become a join point as soon as the +simplifier (or simpleOptPgm) runs. + +Note [Join points are less general than the paper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the paper "Compiling without continuations", this expression is +perfectly valid: + + join { j = \_ -> e } + in (case blah of ) + ( True -> j void# ) arg + ( False -> blah ) + +assuming 'j' has arity 1. Here the call to 'j' does not look like a +tail call, but actually everything is fine. See Section 3, "Managing \Delta" +in the paper. + +In GHC, however, we adopt a slightly more restrictive subset, in which +join point calls must be tail calls. I think we /could/ loosen it up, but +in fact the simplifier ensures that we always get tail calls, and it makes +the back end a bit easier I think. Generally, just less to think about; +nothing deeper than that. + +Note [The type of a join point] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point has the same type it would have as a function. That is, if it takes +an Int and a Bool and its body produces a String, its type is `Int -> Bool -> +String`. Natural as this may seem, it can be awkward. A join point shouldn't be +thought to "return" in the same sense a function does---a jump is one-way. This +is crucial for understanding how case-of-case interacts with join points: + + case (join + j :: Int -> Bool -> String + j x y = ... + in + jump j z w) of + "" -> True + _ -> False + +The simplifier will pull the case into the join point (see Note [Join points +and case-of-case] in GHC.Core.Opt.Simplify): + + join + j :: Int -> Bool -> Bool -- changed! + j x y = case ... of "" -> True + _ -> False + in + jump j z w + +The body of the join point now returns a Bool, so the label `j` has to +have its type updated accordingly, which is done by +GHC.Core.Opt.Simplify.Env.adjustJoinPointType. Inconvenient though +this may be, it has the advantage that 'GHC.Core.Utils.exprType' can +still return a type for any expression, including a jump. + +Relationship to the paper + +This plan differs from the paper (see Note [Invariants on join +points]). In the paper, we instead give j the type `Int -> Bool -> +forall a. a`. Then each jump carries the "return type" as a parameter, +exactly the way other non-returning functions like `error` work: + + case (join + j :: Int -> Bool -> forall a. a + j x y = ... + in + jump j z w @String) of + "" -> True + _ -> False + +Now we can move the case inward and we only have to change the jump: + + join + j :: Int -> Bool -> forall a. a + j x y = case ... of "" -> True + _ -> False + in + jump j z w @Bool + +(Core Lint would still check that the body of the join point has the right type; +that type would simply not be reflected in the join id.) + +Note [The polymorphism rule of join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant 4 of Note [Invariants on join points] forbids a join point to be +polymorphic in its return type. That is, if its type is + + forall a1 ... ak. t1 -> ... -> tn -> r + +where its join arity is k+n, none of the type parameters ai may occur free in r. + +In some way, this falls out of the fact that given + + join + j @a1 ... @ak x1 ... xn = e1 + in e2 + +then all calls to `j` are in tail-call positions of `e`, and expressions in +tail-call positions in `e` have the same type as `e`. +Therefore the type of `e1` -- the return type of the join point -- must be the +same as the type of e2. +Since the type variables aren't bound in `e2`, its type can't include them, and +thus neither can the type of `e1`. + +This unfortunately prevents the `go` in the following code from being a +join-point: + + iter :: forall a. Int -> (a -> a) -> a -> a + iter @a n f x = go @a n f x + where + go :: forall a. Int -> (a -> a) -> a -> a + go @a 0 _ x = x + go @a n f x = go @a (n-1) f (f x) + +In this case, a static argument transformation would fix that (see +ticket #14620): + + iter :: forall a. Int -> (a -> a) -> a -> a + iter @a n f x = go' @a n f x + where + go' :: Int -> (a -> a) -> a -> a + go' 0 _ x = x + go' n f x = go' (n-1) f (f x) + +In general, loopification could be employed to do that (see #14068.) + +Can we simply drop the requirement, and allow `go` to be a join-point? We +could, and it would work. But we could not longer apply the case-of-join-point +transformation universally. This transformation would do: + + case (join go @a n f x = case n of 0 -> x + n -> go @a (n-1) f (f x) + in go @Bool n neg True) of + True -> e1; False -> e2 + + ===> + + join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2 + n -> go @a (n-1) f (f x) + in go @Bool n neg True + +but that is ill-typed, as `x` is type `a`, not `Bool`. + + +This also justifies why we do not consider the `e` in `e |> co` to be in +tail position: A cast changes the type, but the type must be the same. But +operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for +ideas how to fix this. + +************************************************************************ +* * + In/Out type synonyms +* * +********************************************************************* -} + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +-- Pre-cloning or substitution +type InBndr = CoreBndr +type InType = Type +type InKind = Kind +type InBind = CoreBind +type InExpr = CoreExpr +type InAlt = CoreAlt +type InArg = CoreArg +type InCoercion = Coercion + +-- Post-cloning or substitution +type OutBndr = CoreBndr +type OutType = Type +type OutKind = Kind +type OutCoercion = Coercion +type OutBind = CoreBind +type OutExpr = CoreExpr +type OutAlt = CoreAlt +type OutArg = CoreArg +type MOutCoercion = MCoercion + + +{- ********************************************************************* +* * + Ticks +* * +************************************************************************ +-} + +-- | Allows attaching extra information to points in expressions + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Tickish id = + -- | An @{-# SCC #-}@ profiling annotation, either automatically + -- added by the desugarer as a result of -auto-all, or added by + -- the user. + ProfNote { + profNoteCC :: CostCentre, -- ^ the cost centre + profNoteCount :: !Bool, -- ^ bump the entry count? + profNoteScope :: !Bool -- ^ scopes over the enclosed expression + -- (i.e. not just a tick) + } + + -- | A "tick" used by HPC to track the execution of each + -- subexpression in the original source code. + | HpcTick { + tickModule :: Module, + tickId :: !Int + } + + -- | A breakpoint for the GHCi debugger. This behaves like an HPC + -- tick, but has a list of free variables which will be available + -- for inspection in GHCi when the program stops at the breakpoint. + -- + -- NB. we must take account of these Ids when (a) counting free variables, + -- and (b) substituting (don't substitute for them) + | Breakpoint + { breakpointId :: !Int + , breakpointFVs :: [id] -- ^ the order of this list is important: + -- it matches the order of the lists in the + -- appropriate entry in 'GHC.Driver.Types.ModBreaks'. + -- + -- Careful about substitution! See + -- Note [substTickish] in "GHC.Core.Subst". + } + + -- | A source note. + -- + -- Source notes are pure annotations: Their presence should neither + -- influence compilation nor execution. The semantics are given by + -- causality: The presence of a source note means that a local + -- change in the referenced source code span will possibly provoke + -- the generated code to change. On the flip-side, the functionality + -- of annotated code *must* be invariant against changes to all + -- source code *except* the spans referenced in the source notes + -- (see "Causality of optimized Haskell" paper for details). + -- + -- Therefore extending the scope of any given source note is always + -- valid. Note that it is still undesirable though, as this reduces + -- their usefulness for debugging and profiling. Therefore we will + -- generally try only to make use of this property where it is + -- necessary to enable optimizations. + | SourceNote + { sourceSpan :: RealSrcSpan -- ^ Source covered + , sourceName :: String -- ^ Name for source location + -- (uses same names as CCs) + } + + deriving (Eq, Ord, Data) + +-- | A "counting tick" (where tickishCounts is True) is one that +-- counts evaluations in some way. We cannot discard a counting tick, +-- and the compiler should preserve the number of counting ticks as +-- far as possible. +-- +-- However, we still allow the simplifier to increase or decrease +-- sharing, so in practice the actual number of ticks may vary, except +-- that we never change the value from zero to non-zero or vice versa. +tickishCounts :: Tickish id -> Bool +tickishCounts n@ProfNote{} = profNoteCount n +tickishCounts HpcTick{} = True +tickishCounts Breakpoint{} = True +tickishCounts _ = False + + +-- | Specifies the scoping behaviour of ticks. This governs the +-- behaviour of ticks that care about the covered code and the cost +-- associated with it. Important for ticks relating to profiling. +data TickishScoping = + -- | No scoping: The tick does not care about what code it + -- covers. Transformations can freely move code inside as well as + -- outside without any additional annotation obligations + NoScope + + -- | Soft scoping: We want all code that is covered to stay + -- covered. Note that this scope type does not forbid + -- transformations from happening, as long as all results of + -- the transformations are still covered by this tick or a copy of + -- it. For example + -- + -- let x = tick<...> (let y = foo in bar) in baz + -- ===> + -- let x = tick<...> bar; y = tick<...> foo in baz + -- + -- Is a valid transformation as far as "bar" and "foo" is + -- concerned, because both still are scoped over by the tick. + -- + -- Note though that one might object to the "let" not being + -- covered by the tick any more. However, we are generally lax + -- with this - constant costs don't matter too much, and given + -- that the "let" was effectively merged we can view it as having + -- lost its identity anyway. + -- + -- Also note that this scoping behaviour allows floating a tick + -- "upwards" in pretty much any situation. For example: + -- + -- case foo of x -> tick<...> bar + -- ==> + -- tick<...> case foo of x -> bar + -- + -- While this is always legal, we want to make a best effort to + -- only make us of this where it exposes transformation + -- opportunities. + | SoftScope + + -- | Cost centre scoping: We don't want any costs to move to other + -- cost-centre stacks. This means we not only want no code or cost + -- to get moved out of their cost centres, but we also object to + -- code getting associated with new cost-centre ticks - or + -- changing the order in which they get applied. + -- + -- A rule of thumb is that we don't want any code to gain new + -- annotations. However, there are notable exceptions, for + -- example: + -- + -- let f = \y -> foo in tick<...> ... (f x) ... + -- ==> + -- tick<...> ... foo[x/y] ... + -- + -- In-lining lambdas like this is always legal, because inlining a + -- function does not change the cost-centre stack when the + -- function is called. + | CostCentreScope + + deriving (Eq) + +-- | Returns the intended scoping rule for a Tickish +tickishScoped :: Tickish id -> TickishScoping +tickishScoped n@ProfNote{} + | profNoteScope n = CostCentreScope + | otherwise = NoScope +tickishScoped HpcTick{} = NoScope +tickishScoped Breakpoint{} = CostCentreScope + -- Breakpoints are scoped: eventually we're going to do call + -- stacks, but also this helps prevent the simplifier from moving + -- breakpoints around and changing their result type (see #1531). +tickishScoped SourceNote{} = SoftScope + +-- | Returns whether the tick scoping rule is at least as permissive +-- as the given scoping rule. +tickishScopesLike :: Tickish id -> TickishScoping -> Bool +tickishScopesLike t scope = tickishScoped t `like` scope + where NoScope `like` _ = True + _ `like` NoScope = False + SoftScope `like` _ = True + _ `like` SoftScope = False + CostCentreScope `like` _ = True + +-- | Returns @True@ for ticks that can be floated upwards easily even +-- where it might change execution counts, such as: +-- +-- Just (tick<...> foo) +-- ==> +-- tick<...> (Just foo) +-- +-- This is a combination of @tickishSoftScope@ and +-- @tickishCounts@. Note that in principle splittable ticks can become +-- floatable using @mkNoTick@ -- even though there's currently no +-- tickish for which that is the case. +tickishFloatable :: Tickish id -> Bool +tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) + +-- | Returns @True@ for a tick that is both counting /and/ scoping and +-- can be split into its (tick, scope) parts using 'mkNoScope' and +-- 'mkNoTick' respectively. +tickishCanSplit :: Tickish id -> Bool +tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} + = True +tickishCanSplit _ = False + +mkNoCount :: Tickish id -> Tickish id +mkNoCount n | not (tickishCounts n) = n + | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" +mkNoCount n@ProfNote{} = n {profNoteCount = False} +mkNoCount _ = panic "mkNoCount: Undefined split!" + +mkNoScope :: Tickish id -> Tickish id +mkNoScope n | tickishScoped n == NoScope = n + | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" +mkNoScope n@ProfNote{} = n {profNoteScope = False} +mkNoScope _ = panic "mkNoScope: Undefined split!" + +-- | Return @True@ if this source annotation compiles to some backend +-- code. Without this flag, the tickish is seen as a simple annotation +-- that does not have any associated evaluation code. +-- +-- What this means that we are allowed to disregard the tick if doing +-- so means that we can skip generating any code in the first place. A +-- typical example is top-level bindings: +-- +-- foo = tick<...> \y -> ... +-- ==> +-- foo = \y -> tick<...> ... +-- +-- Here there is just no operational difference between the first and +-- the second version. Therefore code generation should simply +-- translate the code as if it found the latter. +tickishIsCode :: Tickish id -> Bool +tickishIsCode SourceNote{} = False +tickishIsCode _tickish = True -- all the rest for now + + +-- | Governs the kind of expression that the tick gets placed on when +-- annotating for example using @mkTick@. If we find that we want to +-- put a tickish on an expression ruled out here, we try to float it +-- inwards until we find a suitable expression. +data TickishPlacement = + + -- | Place ticks exactly on run-time expressions. We can still + -- move the tick through pure compile-time constructs such as + -- other ticks, casts or type lambdas. This is the most + -- restrictive placement rule for ticks, as all tickishs have in + -- common that they want to track runtime processes. The only + -- legal placement rule for counting ticks. + PlaceRuntime + + -- | As @PlaceRuntime@, but we float the tick through all + -- lambdas. This makes sense where there is little difference + -- between annotating the lambda and annotating the lambda's code. + | PlaceNonLam + + -- | In addition to floating through lambdas, cost-centre style + -- tickishs can also be moved from constructors, non-function + -- variables and literals. For example: + -- + -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... + -- + -- Neither the constructor application, the variable or the + -- literal are likely to have any cost worth mentioning. And even + -- if y names a thunk, the call would not care about the + -- evaluation context. Therefore removing all annotations in the + -- above example is safe. + | PlaceCostCentre + + deriving (Eq) + +-- | Placement behaviour we want for the ticks +tickishPlace :: Tickish id -> TickishPlacement +tickishPlace n@ProfNote{} + | profNoteCount n = PlaceRuntime + | otherwise = PlaceCostCentre +tickishPlace HpcTick{} = PlaceRuntime +tickishPlace Breakpoint{} = PlaceRuntime +tickishPlace SourceNote{} = PlaceNonLam + +-- | Returns whether one tick "contains" the other one, therefore +-- making the second tick redundant. +tickishContains :: Eq b => Tickish b -> Tickish b -> Bool +tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) + = containsSpan sp1 sp2 && n1 == n2 + -- compare the String last +tickishContains t1 t2 + = t1 == t2 + +{- +************************************************************************ +* * + Orphans +* * +************************************************************************ +-} + +-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' +-- witnessing the instance's non-orphanhood. +-- See Note [Orphans] +data IsOrphan + = IsOrphan + | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood + -- In that case, the instance is fingerprinted as part + -- of the definition of 'n's definition + deriving Data + +-- | Returns true if 'IsOrphan' is orphan. +isOrphan :: IsOrphan -> Bool +isOrphan IsOrphan = True +isOrphan _ = False + +-- | Returns true if 'IsOrphan' is not an orphan. +notOrphan :: IsOrphan -> Bool +notOrphan NotOrphan{} = True +notOrphan _ = False + +chooseOrphanAnchor :: NameSet -> IsOrphan +-- Something (rule, instance) is relate to all the Names in this +-- list. Choose one of them to be an "anchor" for the orphan. We make +-- the choice deterministic to avoid gratuitous changes in the ABI +-- hash (#4012). Specifically, use lexicographic comparison of +-- OccName rather than comparing Uniques +-- +-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically +-- +chooseOrphanAnchor local_names + | isEmptyNameSet local_names = IsOrphan + | otherwise = NotOrphan (minimum occs) + where + occs = map nameOccName $ nonDetEltsUniqSet local_names + -- It's OK to use nonDetEltsUFM here, see comments above + +instance Binary IsOrphan where + put_ bh IsOrphan = putByte bh 0 + put_ bh (NotOrphan n) = do + putByte bh 1 + put_ bh n + get bh = do + h <- getByte bh + case h of + 0 -> return IsOrphan + _ -> do + n <- get bh + return $ NotOrphan n + +{- +Note [Orphans] +~~~~~~~~~~~~~~ +Class instances, rules, and family instances are divided into orphans +and non-orphans. Roughly speaking, an instance/rule is an orphan if +its left hand side mentions nothing defined in this module. Orphan-hood +has two major consequences + + * A module that contains orphans is called an "orphan module". If + the module being compiled depends (transitively) on an orphan + module M, then M.hi is read in regardless of whether M is otherwise + needed. This is to ensure that we don't miss any instance decls in + M. But it's painful, because it means we need to keep track of all + the orphan modules below us. + + * A non-orphan is not finger-printed separately. Instead, for + fingerprinting purposes it is treated as part of the entity it + mentions on the LHS. For example + data T = T1 | T2 + instance Eq T where .... + The instance (Eq T) is incorporated as part of T's fingerprint. + + In contrast, orphans are all fingerprinted together in the + mi_orph_hash field of the ModIface. + + See GHC.Iface.Recomp.addFingerprints. + +Orphan-hood is computed + * For class instances: + when we make a ClsInst + (because it is needed during instance lookup) + + * For rules and family instances: + when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule) + or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) +-} + +{- +************************************************************************ +* * +\subsection{Rewrite rules} +* * +************************************************************************ + +The CoreRule type and its friends are dealt with mainly in GHC.Core.Rules, but +GHC.Core.FVs, GHC.Core.Subst, GHC.Core.Ppr, GHC.Core.Tidy also inspect the +representation. +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are unordered; + -- we sort out any overlaps on lookup + +-- | A full rule environment which we can apply rules from. Like a 'RuleBase', +-- but it also includes the set of visible orphans we use to filter out orphan +-- rules which are not visible (even though we can see them...) +data RuleEnv + = RuleEnv { re_base :: RuleBase + , re_visible_orphs :: ModuleSet + } + +mkRuleEnv :: RuleBase -> [Module] -> RuleEnv +mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs) + +emptyRuleEnv :: RuleEnv +emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet + +-- | A 'CoreRule' is: +-- +-- * \"Local\" if the function it is a rule for is defined in the +-- same module as the rule itself. +-- +-- * \"Orphan\" if nothing on the LHS is defined in the same module +-- as the rule itself +data CoreRule + = Rule { + ru_name :: RuleName, -- ^ Name of the rule, for communication with the user + ru_act :: Activation, -- ^ When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.ClsInst( is_cls, is_rough ) + ru_fn :: Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule + ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side + + -- Proper-matching stuff + -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- ^ Variables quantified over + ru_args :: [CoreExpr], -- ^ Left hand side arguments + + -- And the right-hand side + ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] + + -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- (notably by Specialise or SpecConstr) + -- @False@ <=> generated at the user's behest + -- See Note [Trimming auto-rules] in "GHC.Iface.Tidy" + -- for the sole purpose of this field. + + ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used + -- to test if we should see an orphan rule. + + ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. + + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is + -- defined in the same module as the rule + -- and is not an implicit 'Id' (like a record selector, + -- class operation, or data constructor). This + -- is different from 'ru_orphan', where a rule + -- can avoid being an orphan if *any* Name in + -- LHS of the rule was defined in the same + -- module as the rule. + } + + -- | Built-in rules are used for constant folding + -- and suchlike. They have no free variables. + -- A built-in rule is always visible (there is no such thing as + -- an orphan built-in rule.) + | BuiltinRule { + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments + ru_try :: RuleFun + -- ^ This function does the rewrite. It given too many + -- arguments, it simply discards them; the returned 'CoreExpr' + -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + } + -- See Note [Extra args in rule matching] in GHC.Core.Rules + +-- | Rule options +data RuleOpts = RuleOpts + { roPlatform :: !Platform -- ^ Target platform + , roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding + , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled + } + +type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type InScopeEnv = (InScopeSet, IdUnfoldingFun) + +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + +isBuiltinRule :: CoreRule -> Bool +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False + +isAutoRule :: CoreRule -> Bool +isAutoRule (BuiltinRule {}) = False +isAutoRule (Rule { ru_auto = is_auto }) = is_auto + +-- | The number of arguments the 'ru_fn' must be applied +-- to before the rule can match on it +ruleArity :: CoreRule -> Int +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + +ruleName :: CoreRule -> RuleName +ruleName = ru_name + +ruleModule :: CoreRule -> Maybe Module +ruleModule Rule { ru_origin } = Just ru_origin +ruleModule BuiltinRule {} = Nothing + +ruleActivation :: CoreRule -> Activation +ruleActivation (BuiltinRule { }) = AlwaysActive +ruleActivation (Rule { ru_act = act }) = act + +-- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn + +isLocalRule :: CoreRule -> Bool +isLocalRule = ru_local + +-- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side +setRuleIdName :: Name -> CoreRule -> CoreRule +setRuleIdName nm ru = ru { ru_fn = nm } + +{- +************************************************************************ +* * + Unfoldings +* * +************************************************************************ + +The @Unfolding@ type is declared here to avoid numerous loops +-} + +-- | Records the /unfolding/ of an identifier, which is approximately the form the +-- identifier would have if we substituted its definition in for the identifier. +-- This type should be treated as abstract everywhere except in "GHC.Core.Unfold" +data Unfolding + = NoUnfolding -- ^ We have no information about the unfolding. + + | BootUnfolding -- ^ We have no information about the unfolding, because + -- this 'Id' came from an @hi-boot@ file. + -- See Note [Inlining and hs-boot files] in "GHC.CoreToIface" + -- for what this is used for. + + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding { -- The Unfolding of a DFunId + -- See Note [DFun unfoldings] + -- df = /\a1..am. \d1..dn. MkD t1 .. tk + -- (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] + df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) + df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, + } -- in positional order + + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_src :: UnfoldingSource, -- Where the unfolding came from + uf_is_top :: Bool, -- True <=> top level binding + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function + -- Cached version of exprIsConLike + uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand + -- inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: Bool, -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } + -- ^ An unfolding with redundant cached information. Parameters: + -- + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] + -- + -- uf_is_top: Is this a top level binding? + -- + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- this variable + -- + -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? + -- Basically this is a cached version of 'exprIsWorkFree' + -- + -- uf_guidance: Tells us about the /size/ of the unfolding template + + +------------------------------------------------ +data UnfoldingSource + = -- See also Note [Historical note: unfoldings for wrappers] + + InlineRhs -- The current rhs of the function + -- Replace uf_tmpl each time around + + | InlineStable -- From an INLINE or INLINABLE pragma + -- INLINE if guidance is UnfWhen + -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever + -- (well, technically an INLINABLE might be made + -- UnfWhen if it was small enough, and then + -- it will behave like INLINE outside the current + -- module, but that is the way automatic unfoldings + -- work so it is consistent with the intended + -- meaning of INLINABLE). + -- + -- uf_tmpl may change, but only as a result of + -- gentle simplification, it doesn't get updated + -- to the current RHS during compilation as with + -- InlineRhs. + -- + -- See Note [InlineStable] + + | InlineCompulsory -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + + + +-- | 'UnfoldingGuidance' says when unfolding should take place +data UnfoldingGuidance + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in GHC.Core.Unfold + ug_arity :: Arity, -- Number of value arguments expected + + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to subtract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfNever -- The RHS is big, so don't inline it + deriving (Eq) + +{- +Note [Historical note: unfoldings for wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a nice clever scheme in interface files for +wrappers. A wrapper's unfolding can be reconstructed from its worker's +id and its strictness. This decreased .hi file size (sometimes +significantly, for modules like GHC.Classes with many high-arity w/w +splits) and had a slight corresponding effect on compile times. + +However, when we added the second demand analysis, this scheme lead to +some Core lint errors. The second analysis could change the strictness +signatures, which sometimes resulted in a wrapper's regenerated +unfolding applying the wrapper to too many arguments. + +Instead of repairing the clever .hi scheme, we abandoned it in favor +of simplicity. The .hi sizes are usually insignificant (excluding the ++1M for base libraries), and compile time barely increases (~+1% for +nofib). The nicer upshot is that the UnfoldingSource no longer mentions +an Id, so, eg, substitutions need not traverse them. + + +Note [DFun unfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The Arity in a DFunUnfolding is total number of args (type and value) +that the DFun needs to produce a dictionary. That's not necessarily +related to the ordinary arity of the dfun Id, esp if the class has +one method, so the dictionary is represented by a newtype. Example + + class C a where { op :: a -> Int } + instance C a -> C [a] where op xs = op (head xs) + +The instance translates to + + $dfCList :: forall a. C a => C [a] -- Arity 2! + $dfCList = /\a.\d. $copList {a} d |> co + + $copList :: forall a. C a => [a] -> Int -- Arity 2! + $copList = /\a.\d.\xs. op {a} d (head xs) + +Now we might encounter (op (dfCList {ty} d) a1 a2) +and we want the (op (dfList {ty} d)) rule to fire, because $dfCList +has all its arguments, even though its (value) arity is 2. That's +why we record the number of expected arguments in the DFunUnfolding. + +Note that although it's an Arity, it's most convenient for it to give +the *total* number of arguments, both type and value. See the use +site in exprIsConApp_maybe. +-} + +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True + +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False + +------------------------------------------------ +noUnfolding :: Unfolding +-- ^ There is no known 'Unfolding' +evaldUnfolding :: Unfolding +-- ^ This unfolding marks the associated thing as being evaluated + +noUnfolding = NoUnfolding +evaldUnfolding = OtherCon [] + +-- | There is no known 'Unfolding', because this came from an +-- hi-boot file. +bootUnfolding :: Unfolding +bootUnfolding = BootUnfolding + +mkOtherCon :: [AltCon] -> Unfolding +mkOtherCon = OtherCon + +isStableSource :: UnfoldingSource -> Bool +-- Keep the unfolding template +isStableSource InlineCompulsory = True +isStableSource InlineStable = True +isStableSource InlineRhs = False + +-- | Retrieves the template of an unfolding: panics if none is known +unfoldingTemplate :: Unfolding -> CoreExpr +unfoldingTemplate = uf_tmpl + +-- | Retrieves the template of an unfolding if possible +-- maybeUnfoldingTemplate is used mainly wnen specialising, and we do +-- want to specialise DFuns, so it's important to return a template +-- for DFunUnfoldings +maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) + = Just expr +maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) +maybeUnfoldingTemplate _ + = Nothing + +-- | The constructors that the unfolding could never be: +-- returns @[]@ if no information is available +otherCons :: Unfolding -> [AltCon] +otherCons (OtherCon cons) = cons +otherCons _ = [] + +-- | Determines if it is certainly the case that the unfolding will +-- yield a value (something in HNF): returns @False@ if unsure +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isValueUnfolding _ = False + +-- | Determines if it possibly the case that the unfolding will +-- yield a value. Unlike 'isValueUnfolding' it returns @True@ +-- for 'OtherCon' +isEvaldUnfolding :: Unfolding -> Bool + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isEvaldUnfolding _ = False + +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (OtherCon _) = True +isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con +isConLikeUnfolding _ = False + +-- | Is the thing we will unfold into certainly cheap? +isCheapUnfolding :: Unfolding -> Bool +isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf +isCheapUnfolding _ = False + +isExpandableUnfolding :: Unfolding -> Bool +isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable +isExpandableUnfolding _ = False + +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in GHC.Core.Rules +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs +expandUnfolding_maybe _ = Nothing + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True +isCompulsoryUnfolding _ = False + +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False + +-- | Only returns False if there is no unfolding information available at all +hasSomeUnfolding :: Unfolding -> Bool +hasSomeUnfolding NoUnfolding = False +hasSomeUnfolding BootUnfolding = False +hasSomeUnfolding _ = True + +isBootUnfolding :: Unfolding -> Bool +isBootUnfolding BootUnfolding = True +isBootUnfolding _ = False + +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False + +hasCoreUnfolding :: Unfolding -> Bool +-- An unfolding "has Core" if it contains a Core expression, which +-- may mention free variables. See Note [Fragile unfoldings] +hasCoreUnfolding (CoreUnfolding {}) = True +hasCoreUnfolding (DFunUnfolding {}) = True +hasCoreUnfolding _ = False + -- NoUnfolding, BootUnfolding, OtherCon have no Core + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False + +{- Note [Fragile unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An unfolding is "fragile" if it mentions free variables (and hence would +need substitution) or might be affected by optimisation. The non-fragile +ones are + + NoUnfolding, BootUnfolding + + OtherCon {} If we know this binder (say a lambda binder) will be + bound to an evaluated thing, we want to retain that + info in simpleOptExpr; see #13077. + +We consider even a StableUnfolding as fragile, because it needs substitution. + +Note [InlineStable] +~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = +you intend that calls (f e) are replaced by [e/x] So we +should capture (\x.) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the InlineRule saying "all . map p", +which deforests well at the call site. + +So INLINE pragma gives rise to an InlineRule, which captures the original RHS. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +See also Note [Inlining an InlineRule] in GHC.Core.Unfold. + + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, +so that the occurrence info on the binders is correct. This is important, +because the Simplifier does not re-analyse the template when using it. If +the occurrence info is wrong + - We may get more simplifier iterations than necessary, because + once-occ info isn't there + - More seriously, we may get an infinite loop if there's a Rec + without a loop breaker marked + + +************************************************************************ +* * + AltCon +* * +************************************************************************ +-} + +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in GHC.Core.Opt.Simplify.Env. If you declared that lookForConstructor +-- *ignores* constructor-applications with LitArg args, then you could get rid +-- of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = text "__DEFAULT" + +cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering +cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 + +ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool +ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT + +cmpAltCon :: AltCon -> AltCon -> Ordering +-- ^ Compares 'AltCon's within a single list of alternatives +-- DEFAULT comes out smallest, so that sorting by AltCon puts +-- alternatives in the order required: see Note [Case expression invariants] +cmpAltCon DEFAULT DEFAULT = EQ +cmpAltCon DEFAULT _ = LT + +cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 +cmpAltCon (DataAlt _) DEFAULT = GT +cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 +cmpAltCon (LitAlt _) DEFAULT = GT + +cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> + ppr con1 <+> ppr con2 ) + LT + +{- +************************************************************************ +* * +\subsection{Useful synonyms} +* * +************************************************************************ + +Note [CoreProgram] +~~~~~~~~~~~~~~~~~~ +The top level bindings of a program, a CoreProgram, are represented as +a list of CoreBind + + * Later bindings in the list can refer to earlier ones, but not vice + versa. So this is OK + NonRec { x = 4 } + Rec { p = ...q...x... + ; q = ...p...x } + Rec { f = ...p..x..f.. } + NonRec { g = ..f..q...x.. } + But it would NOT be ok for 'f' to refer to 'g'. + + * The occurrence analyser does strongly-connected component analysis + on each Rec binding, and splits it into a sequence of smaller + bindings where possible. So the program typically starts life as a + single giant Rec, which is then dependency-analysed into smaller + chunks. +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +type CoreProgram = [CoreBind] -- See Note [CoreProgram] + +-- | The common case for the type of binders and variables when +-- we are manipulating the Core language within GHC +type CoreBndr = Var +-- | Expressions where binders are 'CoreBndr's +type CoreExpr = Expr CoreBndr +-- | Argument expressions where binders are 'CoreBndr's +type CoreArg = Arg CoreBndr +-- | Binding groups where binders are 'CoreBndr's +type CoreBind = Bind CoreBndr +-- | Case alternatives where binders are 'CoreBndr's +type CoreAlt = Alt CoreBndr + +{- +************************************************************************ +* * +\subsection{Tagging} +* * +************************************************************************ +-} + +-- | Binders are /tagged/ with a t +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" + +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) + +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' + +deTagExpr :: TaggedExpr t -> CoreExpr +deTagExpr (Var v) = Var v +deTagExpr (Lit l) = Lit l +deTagExpr (Type ty) = Type ty +deTagExpr (Coercion co) = Coercion co +deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) +deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) +deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) +deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) +deTagExpr (Tick t e) = Tick t (deTagExpr e) +deTagExpr (Cast e co) = Cast (deTagExpr e) co + +deTagBind :: TaggedBind t -> CoreBind +deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) +deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] + +deTagAlt :: TaggedAlt t -> CoreAlt +deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) + +{- +************************************************************************ +* * +\subsection{Core-constructing functions with checking} +* * +************************************************************************ +-} + +-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to +-- use 'GHC.Core.Make.mkCoreApps' if possible +mkApps :: Expr b -> [Arg b] -> Expr b +-- | Apply a list of type argument expressions to a function expression in a nested fashion +mkTyApps :: Expr b -> [Type] -> Expr b +-- | Apply a list of coercion argument expressions to a function expression in a nested fashion +mkCoApps :: Expr b -> [Coercion] -> Expr b +-- | Apply a list of type or value variables to a function expression in a nested fashion +mkVarApps :: Expr b -> [Var] -> Expr b +-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to +-- use 'GHC.Core.Make.mkCoreConApps' if possible +mkConApp :: DataCon -> [Arg b] -> Expr b + +mkApps f args = foldl' App f args +mkCoApps f args = foldl' (\ e a -> App e (Coercion a)) f args +mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars +mkConApp con args = mkApps (Var (dataConWorkId con)) args + +mkTyApps f args = foldl' (\ e a -> App e (mkTyArg a)) f args + +mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b +mkConApp2 con tys arg_ids = Var (dataConWorkId con) + `mkApps` map Type tys + `mkApps` map varToCoreExpr arg_ids + +mkTyArg :: Type -> Expr b +mkTyArg ty + | Just co <- isCoercionTy_maybe ty = Coercion co + | otherwise = Type ty + +-- | Create a machine integer literal expression of type @Int#@ from an @Integer@. +-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr' +mkIntLit :: Platform -> Integer -> Expr b +mkIntLit platform n = Lit (mkLitInt platform n) + +-- | Create a machine integer literal expression of type @Int#@ from an +-- @Integer@, wrapping if necessary. +-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr' +mkIntLitWrap :: Platform -> Integer -> Expr b +mkIntLitWrap platform n = Lit (mkLitIntWrap platform n) + +-- | Create a machine word literal expression of type @Word#@ from an @Integer@. +-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr' +mkWordLit :: Platform -> Integer -> Expr b +mkWordLit platform w = Lit (mkLitWord platform w) + +-- | Create a machine word literal expression of type @Word#@ from an +-- @Integer@, wrapping if necessary. +-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr' +mkWordLitWrap :: Platform -> Integer -> Expr b +mkWordLitWrap platform w = Lit (mkLitWordWrap platform w) + +mkWord64LitWord64 :: Word64 -> Expr b +mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) + +mkInt64LitInt64 :: Int64 -> Expr b +mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w)) + +-- | Create a machine character literal expression of type @Char#@. +-- If you want an expression of type @Char@ use 'GHC.Core.Make.mkCharExpr' +mkCharLit :: Char -> Expr b +-- | Create a machine string literal expression of type @Addr#@. +-- If you want an expression of type @String@ use 'GHC.Core.Make.mkStringExpr' +mkStringLit :: String -> Expr b + +mkCharLit c = Lit (mkLitChar c) +mkStringLit s = Lit (mkLitString s) + +-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. +-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr' +mkFloatLit :: Rational -> Expr b +-- | Create a machine single precision literal expression of type @Float#@ from a @Float@. +-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr' +mkFloatLitFloat :: Float -> Expr b + +mkFloatLit f = Lit (mkLitFloat f) +mkFloatLitFloat f = Lit (mkLitFloat (toRational f)) + +-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. +-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr' +mkDoubleLit :: Rational -> Expr b +-- | Create a machine double precision literal expression of type @Double#@ from a @Double@. +-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr' +mkDoubleLitDouble :: Double -> Expr b + +mkDoubleLit d = Lit (mkLitDouble d) +mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) + +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let/app invariant. Prefer to use 'GHC.Core.Make.mkCoreLets' if +-- possible, which does guarantee the invariant +mkLets :: [Bind b] -> Expr b -> Expr b +-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to +-- use 'GHC.Core.Make.mkCoreLams' if possible +mkLams :: [b] -> Expr b -> Expr b + +mkLams binders body = foldr Lam body binders +mkLets binds body = foldr mkLet body binds + +mkLet :: Bind b -> Expr b -> Expr b +-- The desugarer sometimes generates an empty Rec group +-- which Lint rejects, so we kill it off right away +mkLet (Rec []) body = body +mkLet bind body = Let bind body + +-- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr@. +mkLetNonRec :: b -> Expr b -> Expr b -> Expr b +mkLetNonRec b rhs body = Let (NonRec b rhs) body + +-- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of +-- @binds@ if binds is non-empty. +mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b +mkLetRec [] body = body +mkLetRec bs body = Let (Rec bs) body + +-- | Create a binding group where a type variable is bound to a type. +-- Per Note [Core type and coercion invariant], +-- this can only be used to bind something in a non-recursive @let@ expression +mkTyBind :: TyVar -> Type -> CoreBind +mkTyBind tv ty = NonRec tv (Type ty) + +-- | Create a binding group where a type variable is bound to a type. +-- Per Note [Core type and coercion invariant], +-- this can only be used to bind something in a non-recursive @let@ expression +mkCoBind :: CoVar -> Coercion -> CoreBind +mkCoBind cv co = NonRec cv (Coercion co) + +-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) + | isCoVar v = Coercion (mkCoVarCo v) + | otherwise = ASSERT( isId v ) Var v + +varsToCoreExprs :: [CoreBndr] -> [Expr b] +varsToCoreExprs vs = map varToCoreExpr vs + +{- +************************************************************************ +* * + Getting a result type +* * +************************************************************************ + +These are defined here to avoid a module loop between GHC.Core.Utils and GHC.Core.FVs + +-} + +applyTypeToArg :: Type -> CoreExpr -> Type +-- ^ Determines the type resulting from applying an expression with given type +-- to a given argument expression +applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg) + +-- | If the expression is a 'Type', converts. Otherwise, +-- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'. +exprToType :: CoreExpr -> Type +exprToType (Type ty) = ty +exprToType _bad = pprPanic "exprToType" empty + +-- | If the expression is a 'Coercion', converts. +exprToCoercion_maybe :: CoreExpr -> Maybe Coercion +exprToCoercion_maybe (Coercion co) = Just co +exprToCoercion_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Simple access functions} +* * +************************************************************************ +-} + +-- | Extract every variable by this group +bindersOf :: Bind b -> [b] +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] + +-- | 'bindersOf' applied to a list of binding groups +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds + +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] + +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | (_,_,e) <- alts] + +-- | Collapse all the bindings in the supplied groups into a single +-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group +flattenBinds :: [Bind b] -> [(b, Expr b)] +flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds +flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds +flattenBinds [] = [] + +-- | We often want to strip off leading lambdas before getting down to +-- business. Variants are 'collectTyBinders', 'collectValBinders', +-- and 'collectTyAndValBinders' +collectBinders :: Expr b -> ([b], Expr b) +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) +-- | Strip off exactly N leading lambdas (type or value). Good for use with +-- join points. +collectNBinders :: Int -> Expr b -> ([b], Expr b) + +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) + +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) + +collectValBinders expr + = go [] expr + where + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) + +collectTyAndValBinders expr + = (tvs, ids, body) + where + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 + +collectNBinders orig_n orig_expr + = go orig_n [] orig_expr + where + go 0 bs expr = (reverse bs, expr) + go n bs (Lam b e) = go (n-1) (b:bs) e + go _ _ _ = pprPanic "collectNBinders" $ int orig_n + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectArgs :: Expr b -> (Expr b, [Arg b]) +collectArgs expr + = go expr [] + where + go (App f a) as = go f (a:as) + go e as = (e, as) + +-- | Attempt to remove the last N arguments of a function call. +-- Strip off any ticks or coercions encountered along the way and any +-- at the end. +stripNArgs :: Word -> Expr a -> Maybe (Expr a) +stripNArgs !n (Tick _ e) = stripNArgs n e +stripNArgs n (Cast f _) = stripNArgs n f +stripNArgs 0 e = Just e +stripNArgs n (App f _) = stripNArgs (n - 1) f +stripNArgs _ _ = Nothing + +-- | Like @collectArgs@, but also collects looks through floatable +-- ticks if it means that we can find more arguments. +collectArgsTicks :: (Tickish Id -> Bool) -> Expr b + -> (Expr b, [Arg b], [Tickish Id]) +collectArgsTicks skipTick expr + = go expr [] [] + where + go (App f a) as ts = go f (a:as) ts + go (Tick t e) as ts + | skipTick t = go e as (t:ts) + go e as ts = (e, as, reverse ts) + + +{- +************************************************************************ +* * +\subsection{Predicates} +* * +************************************************************************ + +At one time we optionally carried type arguments through to runtime. +@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, +i.e. if type applications are actual lambdas because types are kept around +at runtime. Similarly isRuntimeArg. +-} + +-- | Will this variable exist at runtime? +isRuntimeVar :: Var -> Bool +isRuntimeVar = isId + +-- | Will this argument expression exist at runtime? +isRuntimeArg :: CoreExpr -> Bool +isRuntimeArg = isValArg + +-- | Returns @True@ for value arguments, false for type args +-- NB: coercions are value arguments (zero width, to be sure, +-- like State#, but still value args). +isValArg :: Expr b -> Bool +isValArg e = not (isTypeArg e) + +-- | Returns @True@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level +isTyCoArg :: Expr b -> Bool +isTyCoArg (Type {}) = True +isTyCoArg (Coercion {}) = True +isTyCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Coercion' +-- expression at its top level +isCoArg :: Expr b -> Bool +isCoArg (Coercion {}) = True +isCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Type' expression at its +-- top level. Note this does NOT include 'Coercion's. +isTypeArg :: Expr b -> Bool +isTypeArg (Type {}) = True +isTypeArg _ = False + +-- | The number of binders that bind values rather than types +valBndrCount :: [CoreBndr] -> Int +valBndrCount = count isId + +-- | The number of argument expressions that are values rather than types at their top level +valArgCount :: [Arg b] -> Int +valArgCount = count isValArg + +{- +************************************************************************ +* * +\subsection{Annotated core} +* * +************************************************************************ +-} + +-- | Annotated core: allows annotation at every node in the tree +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +-- | A clone of the 'Expr' type but allowing annotation at every tree node +data AnnExpr' bndr annot + = AnnVar Id + | AnnLit Literal + | AnnLam bndr (AnnExpr bndr annot) + | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) + | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion + | AnnTick (Tickish Id) (AnnExpr bndr annot) + | AnnType Type + | AnnCoercion Coercion + +-- | A clone of the 'Alt' type but allowing annotation at every tree node +type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) + +-- | A clone of the 'Bind' type but allowing annotation at every tree node +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) +collectAnnArgs expr + = go expr [] + where + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) + +collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a + -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) +collectAnnArgsTicks tickishOk expr + = go expr [] [] + where + go (_, AnnApp f a) as ts = go f (a:as) ts + go (_, AnnTick t e) as ts | tickishOk t + = go e as (t:ts) + go e as ts = (e, as, reverse ts) + +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +deAnnotate' :: AnnExpr' bndr annot -> Expr bndr +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co +deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) + +deAnnotate' (AnnLet bind body) + = Let (deAnnBind bind) (deAnnotate body) +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) + +deAnnAlt :: AnnAlt bndr annot -> Alt bndr +deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) + +deAnnBind :: AnnBind b annot -> Bind b +deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) +deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' +collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectAnnBndrs e + = collect [] e + where + collect bs (_, AnnLam b body) = collect (b:bs) body + collect bs body = (reverse bs, body) + +-- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' +collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectNAnnBndrs orig_n e + = collect orig_n [] e + where + collect 0 bs body = (reverse bs, body) + collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body + collect _ _ _ = pprPanic "collectNBinders" $ int orig_n diff --git a/GHC/Core/Class.hs b/GHC/Core/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Class.hs @@ -0,0 +1,371 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- The @Class@ datatype + +{-# LANGUAGE CPP #-} + +module GHC.Core.Class ( + Class, + ClassOpItem, + ClassATItem(..), ATValidityInfo(..), + ClassMinimalDef, + DefMethInfo, pprDefMethInfo, + + FunDep, pprFundeps, pprFunDep, + + mkClass, mkAbstractClass, classTyVars, classArity, + classKey, className, classATs, classATItems, classTyCon, classMethods, + classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, + classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, + isAbstractClass, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.BooleanFormula (BooleanFormula, mkTrue) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection[Class-basic]{@Class@: basic definition} +* * +************************************************************************ + +A @Class@ corresponds to a Greek kappa in the static semantics: +-} + +data Class + = Class { + classTyCon :: TyCon, -- The data type constructor for + -- dictionaries of this class + -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep + + className :: Name, -- Just the cached name of the TyCon + classKey :: Unique, -- Cached unique of TyCon + + classTyVars :: [TyVar], -- The class kind and type variables; + -- identical to those of the TyCon + -- If you want visibility info, look at the classTyCon + -- This field is redundant because it's duplicated in the + -- classTyCon, but classTyVars is used quite often, so maybe + -- it's a bit faster to cache it here + + classFunDeps :: [FunDep TyVar], -- The functional dependencies + + classBody :: ClassBody -- Superclasses, ATs, methods + + } + +-- | e.g. +-- +-- > class C a b c | a b -> c, a c -> b where... +-- +-- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +-- +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'', + +-- For details on above see note [Api annotations] in GHC.Parser.Annotation +type FunDep a = ([a],[a]) + +type ClassOpItem = (Id, DefMethInfo) + -- Selector function; contains unfolding + -- Default-method info + +type DefMethInfo = Maybe (Name, DefMethSpec Type) + -- Nothing No default method + -- Just ($dm, VanillaDM) A polymorphic default method, name $dm + -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty + -- The generic dm type is *not* quantified + -- over the class variables; ie has the + -- class variables free + +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe (Type, ATValidityInfo)) + -- Default associated type (if any) from this template + -- Note [Associated type defaults] + +-- | Information about an associated type family default implementation. This +-- is used solely for validity checking. +-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl". +data ATValidityInfo + = NoATVI -- Used for associated type families that are imported + -- from another module, for which we don't need to + -- perform any validity checking. + + | ATVI SrcSpan [Type] -- Used for locally defined associated type families. + -- The [Type] are the LHS patterns. + +type ClassMinimalDef = BooleanFormula Name -- Required methods + +data ClassBody + = AbstractClass + | ConcreteClass { + -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) + -- We need value-level selectors for both the dictionary + -- superclasses and the equality superclasses + cls_sc_theta :: [PredType], -- Immediate superclasses, + cls_sc_sel_ids :: [Id], -- Selector functions to extract the + -- superclasses from a + -- dictionary of this class + -- Associated types + cls_ats :: [ClassATItem], -- Associated type families + + -- Class operations (methods, not superclasses) + cls_ops :: [ClassOpItem], -- Ordered by tag + + -- Minimal complete definition + cls_min_def :: ClassMinimalDef + } + -- TODO: maybe super classes should be allowed in abstract class definitions + +classMinimalDef :: Class -> ClassMinimalDef +classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d +classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction + +{- +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + ATI F ((x,a) -> b) + So the tyConTyVars of the family TyCon bind the free vars of + the default Type rhs + +The @mkClass@ function fills in the indirect superclasses. + +The SrcSpan is for the entire original declaration. +-} + +mkClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> [PredType] -> [Id] + -> [ClassATItem] + -> [ClassOpItem] + -> ClassMinimalDef + -> TyCon + -> Class + +mkClass cls_name tyvars fds super_classes superdict_sels at_stuff + op_stuff mindef tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = ConcreteClass { + cls_sc_theta = super_classes, + cls_sc_sel_ids = superdict_sels, + cls_ats = at_stuff, + cls_ops = op_stuff, + cls_min_def = mindef + }, + classTyCon = tycon } + +mkAbstractClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> TyCon + -> Class + +mkAbstractClass cls_name tyvars fds tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = AbstractClass, + classTyCon = tycon } + +{- +Note [Associated type tyvar names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TyCon of an associated type should use the same variable names as its +parent class. Thus + class C a b where + type F b x a :: * +We make F use the same Name for 'a' as C does, and similarly 'b'. + +The reason for this is when checking instances it's easier to match +them up, to ensure they match. Eg + instance C Int [d] where + type F [d] x Int = .... +we should make sure that the first and third args match the instance +header. + +Having the same variables for class and tycon is also used in checkValidRoles +(in GHC.Tc.TyCl) when checking a class's roles. + + +************************************************************************ +* * +\subsection[Class-selectors]{@Class@: simple selectors} +* * +************************************************************************ + +The rest of these functions are just simple selectors. +-} + +classArity :: Class -> Arity +classArity clas = length (classTyVars clas) + -- Could memoise this + +classAllSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels ++ classMethods c +classAllSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels +classSCSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelId :: Class -> Int -> Id +-- Get the n'th superclass selector Id +-- where n is 0-indexed, and counts +-- *all* superclasses including equalities +classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n + = ASSERT( n >= 0 && lengthExceeds sc_sels n ) + sc_sels !! n +classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) + +classMethods :: Class -> [Id] +classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) + = [op_sel | (op_sel, _) <- op_stuff] +classMethods _ = [] + +classOpItems :: Class -> [ClassOpItem] +classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) + = op_stuff +classOpItems _ = [] + +classATs :: Class -> [TyCon] +classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) + = [tc | ATI tc _ <- at_stuff] +classATs _ = [] + +classATItems :: Class -> [ClassATItem] +classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) + = at_stuff +classATItems _ = [] + +classSCTheta :: Class -> [PredType] +classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) + = theta_stuff +classSCTheta _ = [] + +classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) +classTvsFds c = (classTyVars c, classFunDeps c) + +classHasFds :: Class -> Bool +classHasFds (Class { classFunDeps = fds }) = not (null fds) + +classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) +classBigSig (Class {classTyVars = tyvars, + classBody = AbstractClass}) + = (tyvars, [], [], []) +classBigSig (Class {classTyVars = tyvars, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, + cls_sc_sel_ids = sc_sels, + cls_ops = op_stuff + }}) + = (tyvars, sc_theta, sc_sels, op_stuff) + +classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = AbstractClass}) + = (tyvars, fundeps, [], [], [], []) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, + cls_ats = ats, cls_ops = op_stuff + }}) + = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) + +isAbstractClass :: Class -> Bool +isAbstractClass Class{ classBody = AbstractClass } = True +isAbstractClass _ = False + +{- +************************************************************************ +* * +\subsection[Class-instances]{Instance declarations for @Class@} +* * +************************************************************************ + +We compare @Classes@ by their keys (which include @Uniques@). +-} + +instance Eq Class where + c1 == c2 = classKey c1 == classKey c2 + c1 /= c2 = classKey c1 /= classKey c2 + +instance Uniquable Class where + getUnique c = classKey c + +instance NamedThing Class where + getName clas = className clas + +instance Outputable Class where + ppr c = ppr (getName c) + +pprDefMethInfo :: DefMethInfo -> SDoc +pprDefMethInfo Nothing = empty -- No default method +pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n +pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" + <+> ppr n <+> dcolon <+> pprType ty + +pprFundeps :: Outputable a => [FunDep a] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) + +pprFunDep :: Outputable a => FunDep a -> SDoc +pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] + +instance Data.Data Class where + -- don't traverse? + toConstr _ = abstractConstr "Class" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Class" diff --git a/GHC/Core/Coercion.hs b/GHC/Core/Coercion.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion.hs @@ -0,0 +1,3031 @@ +{- +(c) The University of Glasgow 2006 +-} + +{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns, + ScopedTypeVariables #-} + +-- | Module for (a) type kinds and (b) type coercions, +-- as used in System FC. See 'GHC.Core.Expr' for +-- more on System FC and how coercions fit into it. +-- +module GHC.Core.Coercion ( + -- * Main data type + Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, + UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..), + coHoleCoVar, setCoHoleCoVar, + LeftOrRight(..), + Var, CoVar, TyCoVar, + Role(..), ltRole, + + -- ** Functions over coercions + coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, + coercionType, mkCoercionType, + coercionKind, coercionLKind, coercionRKind,coercionKinds, + coercionRole, coercionKindRole, + + -- ** Constructing coercions + mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, + mkPiCo, mkPiCos, mkCoCast, + mkSymCo, mkTransCo, mkTransMCo, + mkNthCo, nthCoRole, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, + mkForAllCo, mkForAllCos, mkHomoForAllCos, + mkPhantomCo, + mkHoleCo, mkUnivCo, mkSubCo, + mkAxiomInstCo, mkProofIrrelCo, + downgradeRole, mkAxiomRuleCo, + mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, + mkKindCo, + castCoercionKind, castCoercionKind1, castCoercionKind2, + mkFamilyTyConAppCo, + + mkHeteroCoercionType, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + + -- ** Decomposition + instNewTyCon_maybe, + + NormaliseStepper, NormaliseStepResult(..), composeSteppers, + mapStepResult, unwrapNewTypeStepper, + topNormaliseNewType_maybe, topNormaliseTypeX, + + decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, + splitTyConAppCo_maybe, + splitAppCo_maybe, + splitFunCo_maybe, + splitForAllCo_maybe, + splitForAllCo_ty_maybe, splitForAllCo_co_maybe, + + nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + + pickLR, + + isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, + isReflCoVar_maybe, isGReflMCo, coToMCo, + + -- ** Coercion variables + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + isCoVar_maybe, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, + coercionSize, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTvSubstAndInScope, getCvSubstEnv, + + -- ** Lifting + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, + liftCoSubstVarBndrUsing, isMappedByLC, + + mkSubstLiftingContext, zapLiftingContext, + substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, + + -- ** Comparison + eqCoercion, eqCoercionX, + + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, + pprCoAxBranchUser, tidyCoAxBndrsForUser, + etaExpandCoAxBranch, + + -- * Tidying + tidyCo, tidyCos, + + -- * Other + promoteCoercion, buildCoercion, + + multToCo, + + simplifyArgsWorker, + + badCoercionHole, badCoercionHoleCo + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) + +import GHC.Prelude + +import GHC.Iface.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) +import GHC.Utils.Misc +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Data.Pair +import GHC.Types.SrcLoc +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Types.Unique.FM + +import Control.Monad (foldM, zipWithM) +import Data.Function ( on ) +import Data.Char( isDigit ) +import qualified Data.Monoid as Monoid + +{- +%************************************************************************ +%* * + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. See + -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep + +\subsection{Coercion variables} +%* * +%************************************************************************ +-} + +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +{- +%************************************************************************ +%* * + Pretty-printing CoAxioms +%* * +%************************************************************************ + +Defined here to avoid module loops. CoAxiom is loaded very early on. + +-} + +etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) +-- Return the (tvs,lhs,rhs) after eta-expanding, +-- to the way in which the axiom was originally written +-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom +etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- ToDo: what about eta_cvs? + = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) + where + eta_tys = mkTyVarTys eta_tvs + +pprCoAxiom :: CoAxiom br -> SDoc +-- Used in debug-printing only +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = hang (text "axiom" <+> ppr ax <+> dcolon) + 2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) + +pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc +-- Used when printing injectivity errors (FamInst.reportInjectivityErrors) +-- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch) +-- This happens in error messages: don't print the RHS of a data +-- family axiom, which is meaningless to a user +pprCoAxBranchUser tc br + | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br + | otherwise = pprCoAxBranch tc br + +pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc +-- Print the family-instance equation when reporting +-- a conflict between equations (FamInst.conflictInstErr) +-- For type families the RHS is important; for data families not so. +-- Indeed for data families the RHS is a mysterious internal +-- type constructor, so we suppress it (#14179) +-- See FamInstEnv Note [Family instance overlap conflicts] +pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs + where + pp_rhs _ _ = empty + +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch = ppr_co_ax_branch ppr_rhs + where + ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs + +ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) + -> TyCon -> CoAxBranch -> SDoc +ppr_co_ax_branch ppr_rhs fam_tc branch + = foldr1 (flip hangNotEmpty 2) + [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + , pp_lhs <+> ppr_rhs tidy_env ee_rhs + , text "-- Defined" <+> pp_loc ] + where + loc = coAxBranchSpan branch + pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) + | otherwise = text "in" <+> ppr loc + + -- Eta-expand LHS and RHS types, because sometimes data family + -- instances are eta-reduced. + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. + (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch + + pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) + (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) + + (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs + +tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +-- Tidy wildcards "_1", "_2" to "_", and do not return them +-- in the list of binders to be printed +-- This is so that in error messages we see +-- forall a. F _ [a] _ = ... +-- rather than +-- forall a _1 _2. F _1 [a] _2 = ... +-- +-- This is a rather disgusting function +-- See Note [Wildcard names] in GHC.Tc.Gen.HsType +tidyCoAxBndrsForUser init_env tcvs + = (tidy_env, reverse tidy_bndrs) + where + (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs + + tidy_one (env@(occ_env, subst), rev_bndrs') bndr + | is_wildcard bndr = (env_wild, rev_bndrs') + | otherwise = (env', bndr' : rev_bndrs') + where + (env', bndr') = tidyVarBndr env bndr + env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) + wild_bndr = setVarName bndr $ + tidyNameOcc (varName bndr) (mkTyVarOcc "_") + -- Tidy the binder to "_" + + is_wildcard :: Var -> Bool + is_wildcard tv = case occNameString (getOccName tv) of + ('_' : rest) -> all isDigit rest + _ -> False + +{- +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ + +Note [Function coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Remember that + (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> TYPE LiftedRep +whose `RuntimeRep' arguments are intentionally marked inferred to +avoid type application. + +Hence + FunCo r mult co1 co2 :: (s1->t1) ~r (s2->t2) +is short for + TyConAppCo (->) mult co_rep1 co_rep2 co1 co2 +where co_rep1, co_rep2 are the coercions on the representations. +-} + + +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into +-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: +-- +-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] +decomposeCo :: Arity -> Coercion + -> [Role] -- the roles of the output coercions + -- this must have at least as many + -- entries as the Arity provided + -> [Coercion] +decomposeCo arity co rs + = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] + -- Remember, Nth is zero-indexed + +decomposeFunCo :: HasDebugCallStack + => Role -- Role of the input coercion + -> Coercion -- Input coercion + -> (CoercionN, Coercion, Coercion) +-- Expects co :: (s1 -> t1) ~ (s2 -> t2) +-- Returns (co1 :: s1~s2, co2 :: t1~t2) +-- See Note [Function coercions] for the "3" and "4" +decomposeFunCo r co = ASSERT2( all_ok, ppr co ) + (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co) + where + Pair s1t1 s2t2 = coercionKind co + all_ok = isFunTy s1t1 && isFunTy s2t2 + +{- Note [Pushing a coercion into a pi-type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this: + (f |> co) t1 .. tn +Then we want to push the coercion into the arguments, so as to make +progress. For example of why you might want to do so, see Note +[Respecting definitional equality] in GHC.Core.TyCo.Rep. + +This is done by decomposePiCos. Specifically, if + decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) +then + (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn + +Notes: + +* k can be smaller than n! That is decomposePiCos can return *fewer* + coercions than there are arguments (ie k < n), if the kind provided + doesn't have enough binders. + +* If there is a type error, we might see + (f |> co) t1 + where co :: (forall a. ty) ~ (ty1 -> ty2) + Here 'co' is insoluble, but we don't want to crash in decoposePiCos. + So decomposePiCos carefully tests both sides of the coercion to check + they are both foralls or both arrows. Not doing this caused #15343. +-} + +decomposePiCos :: HasDebugCallStack + => CoercionN -> Pair Type -- Coercion and its kind + -> [Type] + -> ([CoercionN], CoercionN) +-- See Note [Pushing a coercion into a pi-type] +decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args + = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args + where + orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co + + go :: [CoercionN] -- accumulator for argument coercions, reversed + -> (TCvSubst,Kind) -- Lhs kind of coercion + -> CoercionN -- coercion originally applied to the function + -> (TCvSubst,Kind) -- Rhs kind of coercion + -> [Type] -- Arguments to that function + -> ([CoercionN], Coercion) + -- Invariant: co :: subst1(k2) ~ subst2(k2) + + go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) + | Just (a, t1) <- splitForAllTy_maybe k1 + , Just (b, t2) <- splitForAllTy_maybe k2 + -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) + -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) + -- a :: s1 + -- b :: s2 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] + = let arg_co = mkNthCo Nominal 0 (mkSymCo co) + res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) + subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) + subst2' = extendTCvSubst subst2 b ty + in + go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys + + | Just (_w1, _s1, t1) <- splitFunTy_maybe k1 + , Just (_w1, _s2, t2) <- splitFunTy_maybe k2 + -- know co :: (s1 -> t1) ~ (s2 -> t2) + -- function :: s1 -> t1 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1 ~ t2 + = let (_, sym_arg_co, res_co) = decomposeFunCo Nominal co + -- It should be fine to ignore the multiplicity bit of the coercion + -- for a Nominal coercion. + arg_co = mkSymCo sym_arg_co + in + go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys + + | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) + = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) + co + (zapTCvSubst subst2, substTy subst1 k2) + (ty:tys) + + -- tys might not be empty, if the left-hand type of the original coercion + -- didn't have enough binders + go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) + +-- | Attempts to obtain the type variable underlying a 'Coercion' +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +-- | Attempts to tease a coercion apart into a type constructor and the application +-- of a number of coercion arguments to that constructor +splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) +splitTyConAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + = do { (tc, tys) <- splitTyConApp_maybe ty + ; let args = zipWith mkReflCo (tyConRolesX r tc) tys + ; return (tc, args) } +splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) +splitTyConAppCo_maybe (FunCo _ w arg res) = Just (funTyCon, cos) + where cos = [w, mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] +splitTyConAppCo_maybe _ = Nothing + +multToCo :: Mult -> Coercion +multToCo r = mkNomReflCo r + +-- first result has role equal to input; third result is Nominal +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | args `lengthExceeds` tyConArity tc + , Just (args', arg') <- snocView args + = Just ( mkTyConAppCo r tc args', arg' ) + + | not (mustBeSaturated tc) + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' + = Just ( mkTyConAppCo r tc args', arg'' ) + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl + +splitAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (mkReflCo r ty1, mkNomReflCo ty2) +splitAppCo_maybe _ = Nothing + +-- Only used in specialise/Rules +splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +splitFunCo_maybe (FunCo _ _ arg res) = Just (arg, res) +splitFunCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) +splitForAllCo_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder +splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_ty_maybe (ForAllCo tv k_co co) + | isTyVar tv = Just (tv, k_co, co) +splitForAllCo_ty_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder +splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +splitForAllCo_co_maybe (ForAllCo cv k_co co) + | isCoVar cv = Just (cv, k_co, co) +splitForAllCo_co_maybe _ = Nothing + +------------------------------------------------------- +-- and some coercion kind stuff + +coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type +coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1 +coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2 + +coVarTypes :: HasDebugCallStack => CoVar -> Pair Type +coVarTypes cv + | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv + = Pair ty1 ty2 + +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) +coVarKindsTypesRole cv + | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = (k1, k2, ty1, ty2, eqTyConRole tc) + | otherwise + = pprPanic "coVarKindsTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type +coVarKind cv + = ASSERT( isCoVar cv ) + varType cv + +coVarRole :: CoVar -> Role +coVarRole cv + = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)) + +eqTyConRole :: TyCon -> Role +-- Given (~#) or (~R#) return the Nominal or Representational respectively +eqTyConRole tc + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "eqTyConRole: unknown tycon" (ppr tc) + +-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, +-- produce a coercion @rep_co :: r1 ~ r2@. +mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion +mkRuntimeRepCo co + = mkNthCo Nominal 0 kind_co + where + kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 + -- (up to silliness with Constraint) + +isReflCoVar_maybe :: Var -> Maybe Coercion +-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) +-- Works on all kinds of Vars, not just CoVars +isReflCoVar_maybe cv + | isCoVar cv + , Pair ty1 ty2 <- coVarTypes cv + , ty1 `eqType` ty2 + = Just (mkReflCo (coVarRole cv) ty1) + | otherwise + = Nothing + +-- | Tests if this coercion is obviously a generalized reflexive coercion. +-- Guaranteed to work very quickly. +isGReflCo :: Coercion -> Bool +isGReflCo (GRefl{}) = True +isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl +isGReflCo _ = False + +-- | Tests if this MCoercion is obviously generalized reflexive +-- Guaranteed to work very quickly. +isGReflMCo :: MCoercion -> Bool +isGReflMCo MRefl = True +isGReflMCo (MCo co) | isGReflCo co = True +isGReflMCo _ = False + +-- | Tests if this coercion is obviously reflexive. Guaranteed to work +-- very quickly. Sometimes a coercion can be reflexive, but not obviously +-- so. c.f. 'isReflexiveCo' +isReflCo :: Coercion -> Bool +isReflCo (Refl{}) = True +isReflCo (GRefl _ _ mco) | isGReflMCo mco = True +isReflCo _ = False + +-- | Returns the type coerced if this coercion is a generalized reflexive +-- coercion. Guaranteed to work very quickly. +isGReflCo_maybe :: Coercion -> Maybe (Type, Role) +isGReflCo_maybe (GRefl r ty _) = Just (ty, r) +isGReflCo_maybe (Refl ty) = Just (ty, Nominal) +isGReflCo_maybe _ = Nothing + +-- | Returns the type coerced if this coercion is reflexive. Guaranteed +-- to work very quickly. Sometimes a coercion can be reflexive, but not +-- obviously so. c.f. 'isReflexiveCo_maybe' +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl ty) = Just (ty, Nominal) +isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflCo_maybe _ = Nothing + +-- | Slowly checks if the coercion is reflexive. Don't call this in a loop, +-- as it walks over the entire coercion. +isReflexiveCo :: Coercion -> Bool +isReflexiveCo = isJust . isReflexiveCo_maybe + +-- | Extracts the coerced type from a reflexive coercion. This potentially +-- walks over the entire coercion, so avoid doing this in a loop. +isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) +isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) +isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflexiveCo_maybe co + | ty1 `eqType` ty2 + = Just (ty1, r) + | otherwise + = Nothing + where (Pair ty1 ty2, r) = coercionKindRole co + +coToMCo :: Coercion -> MCoercion +coToMCo c = if isReflCo c + then MRefl + else MCo c + +{- +%************************************************************************ +%* * + Building coercions +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. + +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +downgradeRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of downgradeRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like downgradeRole_maybe, but it panics if the +conversion isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. +The result (if it exists) is always Nominal. The input can be at any role. It +works on a "best effort" basis, as it should never be strictly necessary to +upgrade a coercion during compilation. It is currently only used within GHC in +splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second +coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable +that splitAppCo_maybe is operating over a TyConAppCo that uses a +representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, +it is not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. (Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the +GHC API, as he was decomposing Core casts. The Core casts use representational +coercions, as they must, but his use case required nominal coercions (he was +building a GADT). So, that's why this function is exported from this module. + +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as +appropriate? I (Richard E.) have decided not to do this, because upgrading a +role is bizarre and a caller should have to ask for this behavior explicitly. + +-} + +-- | Make a generalized reflexive coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflCo r ty mco + | isGReflMCo mco = if r == Nominal then Refl ty + else GRefl r ty MRefl + | otherwise = GRefl r ty mco + +-- | Make a reflexive coercion +mkReflCo :: Role -> Type -> Coercion +mkReflCo Nominal ty = Refl ty +mkReflCo r ty = GRefl r ty MRefl + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo ty = GRefl Representational ty MRefl + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = Refl + +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos + | [w, _rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] + , isFunTyCon tc + = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) + -- rep1 :: ra ~ rc rep2 :: rb ~ rd + -- co1 :: a ~ c co2 :: b ~ d + mkFunCo r w co1 co2 + + -- Expand type synonyms + | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos + + | Just tys_roles <- traverse isReflCo_maybe cos + = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + -- See Note [Refl invariant] + + | otherwise = TyConAppCo r tc cos + +-- | Build a function 'Coercion' from two other 'Coercion's. That is, +-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. +mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo r w co1 co2 + -- See Note [Refl invariant] + | Just (ty1, _) <- isReflCo_maybe co1 + , Just (ty2, _) <- isReflCo_maybe co2 + , Just (w, _) <- isReflCo_maybe w + = mkReflCo r (mkVisFunTy w ty1 ty2) + | otherwise = FunCo r w co1 co2 + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -- ^ :: t1 ~r t2 + -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> Coercion -- ^ :: t1 s1 ~r t2 s2 +mkAppCo co arg + | Just (ty1, r) <- isReflCo_maybe co + , Just (ty2, _) <- isReflCo_maybe arg + = mkReflCo r (mkAppTy ty1 ty2) + + | Just (ty1, r) <- isReflCo_maybe co + , Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) + = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] + zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... + +mkAppCo (TyConAppCo r tc args) arg + = case r of + Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) + Representational -> mkTyConAppCo Representational tc (args ++ [arg']) + where new_role = (tyConRolesRepresentational tc) !! (length args) + arg' = downgradeRole new_role Nominal arg + Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) +mkAppCo co arg = AppCo co arg +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep. + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion + -> [Coercion] + -> Coercion +mkAppCos co1 cos = foldl' mkAppCo co1 cos + +{- Note [Unused coercion variable in ForAllCo] + +See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the +motivation for checking coercion variable in types. +To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: + +(1) In mkForAllCo, we check whether cv is a coercion variable + and whether it is not used in body_co. If so we construct a FunCo. +(2) We don't do this check in mkForAllCo. + In coercionKind, we use mkTyCoForAllTy to perform the check and construct + a FunTy when necessary. + +We chose (2) for two reasons: + +* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not + make a difference. +* even if cv occurs in body_co, it is possible that cv does not occur in the kind + of body_co. Therefore the check in coercionKind is inevitable. + +The last wrinkle is that there are restrictions around the use of the cv in the +coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that +we cannot prove that the type system is consistent with unrestricted use of this +cv; the consistency proof uses an untyped rewrite relation that works over types +with all coercions and casts removed. So, we can allow the cv to appear only in +positions that are erased. As an approximation of this (and keeping close to the +published theory), we currently allow the cv only within the type in a Refl node +and under a GRefl node (including in the Coercion stored in a GRefl). It's +possible other places are OK, too, but this is a safe approximation. + +Sadly, with heterogeneous equality, this restriction might be able to be violated; +Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst +function might create an invalid coercion. Because a violation of the +restriction might lead to a program that "goes wrong", it is checked all the time, +even in a production compiler and without -dcore-list. We *have* proved that the +problem does not occur with homogeneous equality, so this check can be dropped +once ~# is made to be homogeneous. +-} + + +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +-- See Note [Unused coercion variable in ForAllCo] +mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , Just (ty, r) <- isReflCo_maybe co + , isGReflCo kind_co + = mkReflCo r (mkTyCoInvForAllTy v ty) + | otherwise + = ForAllCo v kind_co co + +-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo_NoRefl v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , ASSERT( not (isReflCo co)) True + , isCoVar v + , not (v `elemVarSet` tyCoVarsOfCo co) + = FunCo (coercionRole co) (multToCo Many) kind_co co + -- Functions from coercions are always unrestricted + | otherwise + = ForAllCo v kind_co co + +-- | Make nested ForAllCos +mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion +mkForAllCos bndrs co + | Just (ty, r ) <- isReflCo_maybe co + = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in + foldl' (flip $ uncurry mkForAllCo_NoRefl) + (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) + non_refls_rev'd + | otherwise + = foldr (uncurry mkForAllCo_NoRefl) co bndrs + +-- | Make a Coercion quantified over a type/coercion variable; +-- the variable has the same type in both sides of the coercion +mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos vs co + | Just (ty, r) <- isReflCo_maybe co + = mkReflCo r (mkTyCoInvForAllTys vs ty) + | otherwise + = mkHomoForAllCos_NoRefl vs co + +-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. +mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos_NoRefl vs orig_co + = ASSERT( not (isReflCo orig_co)) + foldr go orig_co vs + where + go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +-- See Note [mkCoVarCo] +mkCoVarCo cv = CoVarCo cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +{- Note [mkCoVarCo] +~~~~~~~~~~~~~~~~~~~ +In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is +valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but +it's a relatively expensive test and perhaps better done in +optCoercion. Not a big deal either way. +-} + +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) +isCoVar_maybe :: Coercion -> Maybe CoVar +isCoVar_maybe (CoVarCo cv) = Just cv +isCoVar_maybe _ = Nothing + +mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] + -> Coercion +-- mkAxInstCo can legitimately be called over-staturated; +-- i.e. with more type arguments than the coercion requires +mkAxInstCo role ax index tys cos + | arity == n_tys = downgradeRole role ax_role $ + mkAxiomInstCo ax_br index (rtys `chkAppend` cos) + | otherwise = ASSERT( arity < n_tys ) + downgradeRole role ax_role $ + mkAppCos (mkAxiomInstCo ax_br index + (ax_args `chkAppend` cos)) + leftover_args + where + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + tvs = coAxBranchTyVars branch + arity = length tvs + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + (ax_args, leftover_args) + = splitAt arity rtys + ax_role = coAxiomRole ax + +-- worker function +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkAxiomInstCo ax index args + = ASSERT( args `lengthIs` coAxiomArity ax index ) + AxiomInstCo ax index args + +-- to be used only with unbranched axioms +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched + -> [Type] -> [Coercion] -> Coercion +mkUnbranchedAxInstCo role ax tys cos + = mkAxInstCo role ax 0 tys cos + +mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstRHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkAppTys rhs' tys2 + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 $ + substTyWithCoVars cvs cos $ + coAxBranchRHS branch + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Return the left-hand type of the axiom, when the axiom is instantiated +-- at the types given. +mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +mkAxInstLHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + lhs_tys = substTysWith tvs tys1 $ + substTysWithCoVars cvs cos $ + coAxBranchLHS branch + fam_tc = coAxiomTyCon ax + +-- | Instantiate the left-hand side of an unbranched axiom +mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Coercion +mkHoleCo h = HoleCo h + +-- | Make a universal coercion between two arbitrary types. +mkUnivCo :: UnivCoProvenance + -> Role -- ^ role of the built coercion, "r" + -> Type -- ^ t1 :: k1 + -> Type -- ^ t2 :: k2 + -> Coercion -- ^ :: t1 ~r t2 +mkUnivCo prov role ty1 ty2 + | ty1 `eqType` ty2 = mkReflCo role ty1 + | otherwise = UnivCo prov role ty1 ty2 + +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, but don't bother pushing occurrences +-- of symmetry to the leaves; the optimizer will take care of that. +mkSymCo co | isReflCo co = co +mkSymCo (SymCo co) = co +mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo co = SymCo co + +-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. +-- (co1 ; co2) +mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo co1 co2 | isReflCo co1 = co2 + | isReflCo co2 = co1 +mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) + = GRefl r t1 (MCo $ mkTransCo co1 co2) +mkTransCo co1 co2 = TransCo co1 co2 + +-- | Compose two MCoercions via transitivity +mkTransMCo :: MCoercion -> MCoercion -> MCoercion +mkTransMCo MRefl co2 = co2 +mkTransMCo co1 MRefl = co1 +mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) + +mkNthCo :: HasDebugCallStack + => Role -- The role of the coercion you're creating + -> Int -- Zero-indexed + -> Coercion + -> Coercion +mkNthCo r n co + = ASSERT2( good_call, bad_call_msg ) + go r n co + where + Pair ty1 ty2 = coercionKind co + + go r 0 co + | Just (ty, _) <- isReflCo_maybe co + , Just (tv, _) <- splitForAllTy_maybe ty + = -- works for both tyvar and covar + ASSERT( r == Nominal ) + mkNomReflCo (varType tv) + + go r n co + | Just (ty, r0) <- isReflCo_maybe co + , let tc = tyConAppTyCon ty + = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) + ASSERT( nthRole r0 tc n == r ) + mkReflCo r (tyConAppArgN n ty) + where ok_tc_app :: Type -> Int -> Bool + ok_tc_app ty n + | Just (_, tys) <- splitTyConApp_maybe ty + = tys `lengthExceeds` n + | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall + = n == 0 + | otherwise + = False + + go r 0 (ForAllCo _ kind_co _) + = ASSERT( r == Nominal ) + kind_co + -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) + -- then (nth 0 co :: k1 ~N k2) + -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) + -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) + + go r n co@(FunCo r0 w arg res) + -- See Note [Function coercions] + -- If FunCo _ mult arg_co res_co :: (s1:TYPE sk1 :mult-> s2:TYPE sk2) + -- ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2) + -- Then we want to behave as if co was + -- TyConAppCo mult argk_co resk_co arg_co res_co + -- where + -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) + -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) + -- i.e. mkRuntimeRepCo + = case n of + 0 -> ASSERT( r == Nominal ) w + 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg + 2 -> ASSERT( r == Nominal ) mkRuntimeRepCo res + 3 -> ASSERT( r == r0 ) arg + 4 -> ASSERT( r == r0 ) res + _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) + + go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n + , (vcat [ ppr tc + , ppr arg_cos + , ppr r0 + , ppr n + , ppr r ]) ) + arg_cos `getNth` n + + go r n co = + NthCo r n co + + -- Assertion checking + bad_call_msg = vcat [ text "Coercion =" <+> ppr co + , text "LHS ty =" <+> ppr ty1 + , text "RHS ty =" <+> ppr ty2 + , text "n =" <+> ppr n, text "r =" <+> ppr r + , text "coercion role =" <+> ppr (coercionRole co) ] + good_call + -- If the Coercion passed in is between forall-types, then the Int must + -- be 0 and the role must be Nominal. + | Just (_tv1, _) <- splitForAllTy_maybe ty1 + , Just (_tv2, _) <- splitForAllTy_maybe ty2 + = n == 0 && r == Nominal + + -- If the Coercion passed in is between T tys and T tys', then the Int + -- must be less than the length of tys/tys' (which must be the same + -- lengths). + -- + -- If the role of the Coercion is nominal, then the role passed in must + -- be nominal. If the role of the Coercion is representational, then the + -- role passed in must be tyConRolesRepresentational T !! n. If the role + -- of the Coercion is Phantom, then the role passed in must be Phantom. + -- + -- See also Note [NthCo Cached Roles] if you're wondering why it's + -- blaringly obvious that we should be *computing* this role instead of + -- passing it in. + | Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + = let len1 = length tys1 + len2 = length tys2 + good_role = case coercionRole co of + Nominal -> r == Nominal + Representational -> r == (tyConRolesRepresentational tc1 !! n) + Phantom -> r == Phantom + in len1 == len2 && n < len1 && good_role + + | otherwise + = True + + + +-- | If you're about to call @mkNthCo r n co@, then @r@ should be +-- whatever @nthCoRole n co@ returns. +nthCoRole :: Int -> Coercion -> Role +nthCoRole n co + | Just (tc, _) <- splitTyConApp_maybe lty + = nthRole r tc n + + | Just _ <- splitForAllTy_maybe lty + = Nominal + + | otherwise + = pprPanic "nthCoRole" (ppr co) + + where + lty = coercionLKind co + r = coercionRole co + +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr co + | Just (ty, eq) <- isReflCo_maybe co + = mkReflCo eq (pickLR lr (splitAppTy ty)) + | otherwise + = LRCo lr co + +-- | Instantiates a 'Coercion'. +mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo (ForAllCo tcv _kind_co body_co) co + | Just (arg, _) <- isReflCo_maybe co + -- works for both tyvar and covar + = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co +mkInstCo co arg = InstCo co arg + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: ty ~r (ty |> co)@ +mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion +mkGReflRightCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: (ty |> co) ~r ty@ +mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion +mkGReflLeftCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkSymCo $ GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, +-- produces @co' :: (ty |> co) ~r ty' +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceLeftCo r ty co co2 + | isGReflCo co = co2 + | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, +-- produces @co' :: ty' ~r (ty |> co) +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceRightCo r ty co co2 + | isGReflCo co = co2 + | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) + +-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. +mkKindCo :: Coercion -> Coercion +mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) +mkKindCo (GRefl _ _ (MCo co)) = co +mkKindCo (UnivCo (PhantomProv h) _ _ _) = h +mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h +mkKindCo co + | Pair ty1 ty2 <- coercionKind co + -- generally, calling coercionKind during coercion creation is a bad idea, + -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, + -- so it's OK here. + , let tk1 = typeKind ty1 + tk2 = typeKind ty2 + , tk1 `eqType` tk2 + = Refl tk1 + | otherwise + = KindCo co + +mkSubCo :: Coercion -> Coercion +-- Input coercion is Nominal, result is Representational +-- see also Note [Role twiddling functions] +mkSubCo (Refl ty) = GRefl Representational ty MRefl +mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo (FunCo Nominal w arg res) + = FunCo Representational w + (downgradeRole Representational Nominal arg) + (downgradeRole Representational Nominal res) +mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) + SubCo co + +-- | Changes a role, but only a downgrade. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- ^ desired role + -> Role -- ^ current role + -> Coercion -> Maybe Coercion +-- In (downgradeRole_maybe dr cr co) it's a precondition that +-- cr = coercionRole co + +downgradeRole_maybe Nominal Nominal co = Just co +downgradeRole_maybe Nominal _ _ = Nothing + +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Representational Representational co = Just co +downgradeRole_maybe Representational Phantom _ = Nothing + +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) + +-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. +-- See Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case downgradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "downgradeRole" (ppr co) + +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomRuleCo = AxiomRuleCo + +-- | Make a "coercion between coercions". +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" + -> Coercion -- ^ :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Coercion -- ^ :: g1 ~r g2 + +-- if the two coercion prove the same fact, I just don't care what +-- the individual coercions are. +mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) + -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ +mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r + (mkCoercionTy g1) (mkCoercionTy g2) + +{- +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ +-} + +-- | Converts a coercion to be nominal, if possible. +-- See Note [Role twiddling functions] +setNominalRole_maybe :: Role -- of input coercion + -> Coercion -> Maybe Coercion +setNominalRole_maybe r co + | r == Nominal = Just co + | otherwise = setNominalRole_maybe_helper co + where + setNominalRole_maybe_helper (SubCo co) = Just co + setNominalRole_maybe_helper co@(Refl _) = Just co + setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co + setNominalRole_maybe_helper (TyConAppCo Representational tc cos) + = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos + ; return $ TyConAppCo Nominal tc cos' } + setNominalRole_maybe_helper (FunCo Representational w co1 co2) + = do { co1' <- setNominalRole_maybe Representational co1 + ; co2' <- setNominalRole_maybe Representational co2 + ; return $ FunCo Nominal w co1' co2' + } + setNominalRole_maybe_helper (SymCo co) + = SymCo <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (TransCo co1 co2) + = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 + setNominalRole_maybe_helper (AppCo co1 co2) + = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 + setNominalRole_maybe_helper (ForAllCo tv kind_co co) + = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (NthCo _r n co) + -- NB, this case recurses via setNominalRole_maybe, not + -- setNominalRole_maybe_helper! + = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co + setNominalRole_maybe_helper (InstCo co arg) + = InstCo <$> setNominalRole_maybe_helper co <*> pure arg + setNominalRole_maybe_helper (UnivCo prov _ co1 co2) + | case prov of PhantomProv _ -> False -- should always be phantom + ProofIrrelProv _ -> True -- it's always safe + PluginProv _ -> False -- who knows? This choice is conservative. + CorePrepProv -> True + = Just $ UnivCo prov Nominal co1 co2 + setNominalRole_maybe_helper _ = Nothing + +-- | Make a phantom coercion between two types. The coercion passed +-- in must be a nominal coercion between the kinds of the +-- types. +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkPhantomCo h t1 t2 + = mkUnivCo (PhantomProv h) Phantom t1 t2 + +-- takes any coercion and turns it into a Phantom coercion +toPhantomCo :: Coercion -> Coercion +toPhantomCo co + = mkPhantomCo (mkKindCo co) ty1 ty2 + where Pair ty1 ty2 = coercionKind co + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles tc cos + = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos + +-- the Role parameter is the Role of the TyConAppCo +-- defined here because this is intimately concerned with the implementation +-- of TyConAppCo +-- Always returns an infinite list (with a infinite tail of Nominal) +tyConRolesX :: Role -> TyCon -> [Role] +tyConRolesX Representational tc = tyConRolesRepresentational tc +tyConRolesX role _ = repeat role + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRolesRepresentational :: TyCon -> [Role] +tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal + +nthRole :: Role -> TyCon -> Int -> Role +nthRole Nominal _ _ = Nominal +nthRole Phantom _ _ = Phantom +nthRole Representational tc n + = (tyConRolesRepresentational tc) `getNth` n + +ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True + +------------------------------- + +-- | like mkKindCo, but aggressively & recursively optimizes to avoid using +-- a KindCo constructor. The output role is nominal. +promoteCoercion :: Coercion -> CoercionN + +-- First cases handles anything that should yield refl. +promoteCoercion co = case co of + + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- no later branch should return refl + -- The ASSERT( False )s throughout + -- are these cases explicitly, but they should never fire. + + Refl _ -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ MRefl -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ (MCo co) -> co + + TyConAppCo _ tc args + | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args + -> co' + | otherwise + -> mkKindCo co + + AppCo co1 arg + | Just co' <- instCoercion (coercionKind (mkKindCo co1)) + (promoteCoercion co1) arg + -> co' + | otherwise + -> mkKindCo co + + ForAllCo tv _ g + | isTyVar tv + -> promoteCoercion g + + ForAllCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep + + FunCo _ _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + CoVarCo {} -> mkKindCo co + HoleCo {} -> mkKindCo co + AxiomInstCo {} -> mkKindCo co + AxiomRuleCo {} -> mkKindCo co + + UnivCo (PhantomProv kco) _ _ _ -> kco + UnivCo (ProofIrrelProv kco) _ _ _ -> kco + UnivCo (PluginProv _) _ _ _ -> mkKindCo co + UnivCo CorePrepProv _ _ _ -> mkKindCo co + + SymCo g + -> mkSymCo (promoteCoercion g) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + NthCo _ n co1 + | Just (_, args) <- splitTyConAppCo_maybe co1 + , args `lengthExceeds` n + -> promoteCoercion (args !! n) + + | Just _ <- splitForAllCo_maybe co + , n == 0 + -> ASSERT( False ) mkNomReflCo liftedTypeKind + + | otherwise + -> mkKindCo co + + LRCo lr co1 + | Just (lco, rco) <- splitAppCo_maybe co1 + -> case lr of + CLeft -> promoteCoercion lco + CRight -> promoteCoercion rco + + | otherwise + -> mkKindCo co + + InstCo g _ + | isForAllTy_ty ty1 + -> ASSERT( isForAllTy_ty ty2 ) + promoteCoercion g + | otherwise + -> ASSERT( False) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep + + KindCo _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + where + Pair ty1 ty2 = coercionKind co + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, +-- where @g' = promoteCoercion (h w)@. +-- fails if this is not possible, if @g@ coerces between a forall and an -> +-- or if second parameter has a representational role and can't be used +-- with an InstCo. +instCoercion :: Pair Type -- g :: lty ~ rty + -> CoercionN -- ^ must be nominal + -> Coercion + -> Maybe CoercionN +instCoercion (Pair lty rty) g w + | (isForAllTy_ty lty && isForAllTy_ty rty) + || (isForAllTy_co lty && isForAllTy_co rty) + , Just w' <- setNominalRole_maybe (coercionRole w) w + -- g :: (forall t1. t2) ~ (forall t1. t3) + -- w :: s1 ~ s2 + -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] + = Just $ mkInstCo g w' + | isFunTy lty && isFunTy rty + -- g :: (t1 -> t2) ~ (t3 -> t4) + -- returns t2 ~ t4 + = Just $ mkNthCo Nominal 4 g -- extract result type, which is the 5th argument to (->) + | otherwise -- one forall, one funty... + = Nothing + +-- | Repeated use of 'instCoercion' +instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN +instCoercions g ws + = let arg_ty_pairs = map coercionKind ws in + snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) + where + go :: (Pair Type, Coercion) -> (Pair Type, Coercion) + -> Maybe (Pair Type, Coercion) + go (g_tys, g) (w_tys, w) + = do { g' <- instCoercion g_tys g w + ; return (piResultTy <$> g_tys <*> w_tys, g') } + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +castCoercionKind2 :: Coercion -> Role -> Type -> Type + -> CoercionN -> CoercionN -> Coercion +castCoercionKind2 g r t1 t2 h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + +-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@ +-- That is, it's a specialised form of castCoercionKind, where the two +-- kind coercions are identical +-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h) ~r (t2 |> h)@. +-- @h@ must be nominal. +-- See Note [castCoercionKind1] +castCoercionKind1 :: Coercion -> Role -> Type -> Type + -> CoercionN -> Coercion +castCoercionKind1 g r t1 t2 h + = case g of + Refl {} -> ASSERT( r == Nominal ) -- Refl is always Nominal + mkNomReflCo (mkCastTy t2 h) + GRefl _ _ mco -> case mco of + MRefl -> mkReflCo r (mkCastTy t2 h) + MCo kind_co -> GRefl r (mkCastTy t1 h) $ + MCo (mkSymCo h `mkTransCo` kind_co `mkTransCo` h) + _ -> castCoercionKind2 g r t1 t2 h h + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) +-- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand. +castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion +castCoercionKind g h1 h2 + = castCoercionKind2 g r t1 t2 h1 h2 + where + (Pair t1 t2, r) = coercionKindRole g + +mkFamilyTyConAppCo :: TyCon -> [CoercionN] -> CoercionN +-- ^ Given a family instance 'TyCon' and its arg 'Coercion's, return the +-- corresponding family 'Coercion'. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance 'TyCon' is :RTL, so: +-- +-- > mkFamilyTyConAppCo :RTL (co :: a ~# Int) = T (Maybe a) ~# T (Maybe Int) +-- +-- cf. 'mkFamilyTyConApp' +mkFamilyTyConAppCo tc cos + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_cos = ASSERT2( tvs `equalLength` cos, ppr tc <+> ppr cos ) + map (liftCoSubstWith Nominal tvs cos) fam_tys + = mkTyConAppCo Nominal fam_tc fam_cos + | otherwise + = mkTyConAppCo Nominal tc cos + +-- See note [Newtype coercions] in GHC.Core.TyCon + +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs + +-- | Make a forall 'Coercion', where both types related by the coercion +-- are quantified over the same variable. +mkPiCo :: Role -> Var -> Coercion -> Coercion +mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co + | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) + -- We didn't call mkForAllCo here because if v does not appear + -- in co, the argement coercion will be nominal. But here we + -- want it to be r. It is only called in 'mkPiCos', which is + -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for + -- now (Aug 2018) v won't occur in co. + mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co + | otherwise = mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co + +-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 +-- The first coercion might be lifted or unlifted; thus the ~? above +-- Lifted and unlifted equalities take different numbers of arguments, +-- so we have to make sure to supply the right parameter to decomposeCo. +-- Also, note that the role of the first coercion is the same as the role of +-- the equalities related by the second coercion. The second coercion is +-- itself always representational. +mkCoCast :: Coercion -> CoercionR -> Coercion +mkCoCast c g + | (g2:g1:_) <- reverse co_list + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + + | otherwise + = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) + where + -- g :: (s1 ~# t1) ~# (s2 ~# t2) + -- g1 :: s1 ~# s2 + -- g2 :: t1 ~# t2 + (tc, _) = splitTyConApp (coercionLKind g) + co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) + +{- Note [castCoercionKind1] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +castCoercionKind1 deals with the very important special case of castCoercionKind2 +where the two kind coercions are identical. In that case we can exploit the +situation where the main coercion is reflexive, via the special cases for Refl +and GRefl. + +This is important when flattening (ty |> co). We flatten ty, yielding + fco :: ty ~ ty' +and now we want a coercion xco between + xco :: (ty |> co) ~ (ty' |> co) +That's exactly what castCoercionKind1 does. And it's very very common for +fco to be Refl. In that case we do NOT want to get some terrible composition +of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2 +has to do in its full generality. See #18413. +-} + +{- +%************************************************************************ +%* * + Newtypes +%* * +%************************************************************************ +-} + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) +instNewTyCon_maybe tc tys + | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype + , tvs `leLength` tys -- Check saturated enough + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Type normalisation +* * +************************************************************************ +-} + +-- | A function to check if we can reduce a type by one step. Used +-- with 'topNormaliseTypeX'. +type NormaliseStepper ev = RecTcChecker + -> TyCon -- tc + -> [Type] -- tys + -> NormaliseStepResult ev + +-- | The result of stepping in a normalisation function. +-- See 'topNormaliseTypeX'. +data NormaliseStepResult ev + = NS_Done -- ^ Nothing more to do + | NS_Abort -- ^ Utter failure. The outer function should fail too. + | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; + -- ^ ev is evidence; + -- Usually a co :: old type ~ new type + +mapStepResult :: (ev1 -> ev2) + -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 +mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) +mapStepResult _ NS_Done = NS_Done +mapStepResult _ NS_Abort = NS_Abort + +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. +-- So if it returns NS_Done, it means that both steppers are satisfied +composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev + -> NormaliseStepper ev +composeSteppers step1 step2 rec_nts tc tys + = case step1 rec_nts tc tys of + success@(NS_Step {}) -> success + NS_Done -> step2 rec_nts tc tys + NS_Abort -> NS_Abort + +-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into +-- a loop. If it would fall into a loop, it produces 'NS_Abort'. +unwrapNewTypeStepper :: NormaliseStepper Coercion +unwrapNewTypeStepper rec_nts tc tys + | Just (ty', co) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' ty' co + Nothing -> NS_Abort + + | otherwise + = NS_Done + +-- | A general function for normalising the top-level of a type. It continues +-- to use the provided 'NormaliseStepper' until that function fails, and then +-- this function returns. The roles of the coercions produced by the +-- 'NormaliseStepper' must all be the same, which is the role returned from +-- the call to 'topNormaliseTypeX'. +-- +-- Typically ev is Coercion. +-- +-- If topNormaliseTypeX step plus ty = Just (ev, ty') +-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' +-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn +-- If it returns Nothing then no newtype unwrapping could happen +topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) + -> Type -> Maybe (ev, Type) +topNormaliseTypeX stepper plus ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys + = go rec_nts ev ty' + | otherwise + = Nothing + where + go rec_nts ev ty + | Just (tc, tys) <- splitTyConApp_maybe ty + = case stepper rec_nts tc tys of + NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' + NS_Done -> Just (ev, ty) + NS_Abort -> Nothing + + | otherwise + = Just (ev, ty) + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) +-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. +-- This function strips off @newtype@ layers enough to reveal something that isn't +-- a @newtype@. Specifically, here's the invariant: +-- +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') +-- +-- then (a) @co : ty0 ~ ty'@. +-- (b) ty' is not a newtype. +-- +-- The function returns @Nothing@ for non-@newtypes@, +-- or unsaturated applications +-- +-- This function does *not* look through type families, because it has no access to +-- the type family environment. If you do have that at hand, consider to use +-- topNormaliseType_maybe, which should be a drop-in replacement for +-- topNormaliseNewType_maybe +-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' +topNormaliseNewType_maybe ty + = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty + +{- +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ +-} + +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType + +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType + +{- +%************************************************************************ +%* * + "Lifting" substitution + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ + +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = K (a -> Maybe a) + g :: T t1 ~ T t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = Nth 0 g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +In the presence of kind coercions, this is a bit +of a hairy operation. So, we refer you to the paper introducing kind coercions, +available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf + +Note [extendLiftingContextEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we have datatype + K :: \/k. \/a::k. P -> T k -- P be some type + g :: T k1 ~ T k2 + + case (K @k1 @t1 x) |> g of + K y -> rhs + +We want to push the coercion inside the constructor application. +We first get the coercion mapped by the universal type variable k: + lc = k |-> Nth 0 g :: k1~k2 + +Here, the important point is that the kind of a is coerced, and P might be +dependent on the existential type variable a. +Thus we first get the coercion of a's kind + g2 = liftCoSubst lc k :: k1 ~ k2 + +Then we store a new mapping into the lifting context + lc2 = a |-> (t1 ~ t1 |> g2), lc + +So later when we can correctly deal with the argument type P + liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] + +This is exactly what extendLiftingContextEx does. +* For each (tyvar:k, ty) pair, we product the mapping + tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) +* For each (covar:s1~s2, ty) pair, we produce the mapping + covar |-> (co ~ co') + co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' + +This follows the lifting context extension definition in the +"FC with Explicit Kind Equality" paper. +-} + +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + +data LiftingContext = LC TCvSubst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt + -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions*. + -- That's the whole point of this function! + -- Also maps coercion variables to ProofIrrelCos. + +-- like liftCoSubstWith, but allows for existentially-bound types as well +liftCoSubstWithEx :: Role -- desired role for output coercion + -> [TyVar] -- universally quantified tyvars + -> [Coercion] -- coercions to substitute for those + -> [TyCoVar] -- existentially quantified tycovars + -> [Type] -- types and coercions to be bound to ex vars + -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) +liftCoSubstWithEx role univs omegas exs rhos + = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) + psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) + in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) + +liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith r tvs cos ty + = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty + +-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) +-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where +-- @lc_left@ is a substitution mapping type variables to the left-hand +-- types of the mapped coercions in @lc@, and similar for @lc_right@. +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +{-# INLINE liftCoSubst #-} +-- Inlining this function is worth 2% of allocation in T9872d, +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = mkReflCo r (substTy subst ty) + | otherwise = ty_co_subst lc r ty + +emptyLiftingContext :: InScopeSet -> LiftingContext +emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv + +mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext +mkLiftingContext pairs + = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + (mkVarEnv pairs) + +mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext subst = LC subst emptyVarEnv + +-- | Extend a lifting context with a new mapping. +extendLiftingContext :: LiftingContext -- ^ original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext + -- mappings to reflexive coercions are just substitutions +extendLiftingContext (LC subst env) tv arg + | Just (ty, _) <- isReflCo_maybe arg + = LC (extendTCvSubst subst tv ty) env + | otherwise + = LC subst (extendVarEnv env tv arg) + +-- | Extend a lifting context with a new mapping, and extend the in-scope set +extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ to this coercion + -> LiftingContext +extendLiftingContextAndInScope (LC subst env) tv co + = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co + +-- | Extend a lifting context with existential-variable bindings. +-- See Note [extendLiftingContextEx] +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyCoVar,Type)] -- ^ ex. var / value pairs + -> LiftingContext +-- Note that this is more involved than extendLiftingContext. That function +-- takes a coercion to extend with, so it's assumed that the caller has taken +-- into account any of the kind-changing stuff worried about here. +extendLiftingContextEx lc [] = lc +extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) +-- This function adds bindings for *Nominal* coercions. Why? Because it +-- works with existentially bound variables, which are considered to have +-- nominal roles. + | isTyVar v + = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v $ + mkGReflRightCo Nominal + ty + (ty_co_subst lc Nominal (tyVarKind v))) + in extendLiftingContextEx lc' rest + | CoercionTy co <- ty + = -- co :: s1 ~r s2 + -- lift_s1 :: s1 ~r s1' + -- lift_s2 :: s2 ~r s2' + -- kco :: (s1 ~r s2) ~N (s1' ~r s2') + ASSERT( isCoVar v ) + let (_, _, s1, s2, r) = coVarKindsTypesRole v + lift_s1 = ty_co_subst lc r s1 + lift_s2 = ty_co_subst lc r s2 + kco = mkTyConAppCo Nominal (equalityTyCon r) + [ mkKindCo lift_s1, mkKindCo lift_s2 + , lift_s1 , lift_s2 ] + lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + (extendVarEnv env v + (mkProofIrrelCo Nominal kco co $ + (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) + in extendLiftingContextEx lc' rest + | otherwise + = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) + + +-- | Erase the environments in a lifting context +zapLiftingContext :: LiftingContext -> LiftingContext +zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv + +-- | Like 'substForAllCoBndr', but works on a lifting context +substForAllCoBndrUsingLC :: Bool + -> (Coercion -> Coercion) + -> LiftingContext -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) +substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co + = (LC subst' lc_env, tv', co') + where + (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. +-- +-- For the inverse operation, see 'liftCoMatch' +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst !lc role ty + -- !lc: making this function strict in lc allows callers to + -- pass its two components separately, rather than boxing them + = go role ty + where + go :: Role -> Type -> Coercion + go r ty | Just ty' <- coreView ty + = go r ty' + go Phantom ty = lift_phantom ty + go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ + liftCoSubstTyVar lc r tv + go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) + go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) + go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2) + go r t@(ForAllTy (Bndr v _) ty) + = let (lc', v', h) = liftCoSubstVarBndr lc v + body_co = ty_co_subst lc' r ty in + if isTyVar v' || almostDevoidCoVarOfCo v' body_co + -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo + -- imposes an extra restriction on where a covar can appear. See last + -- wrinkle in Note [Unused coercion variable in ForAllCo]. + -- We specifically check for this and panic because we know that + -- there's a hole in the type system here, and we'd rather panic than + -- fall into it. + then mkForAllCo v' h body_co + else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) + go r ty@(LitTy {}) = ASSERT( r == Nominal ) + mkNomReflCo ty + go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co) + (substRightCo lc co) + go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) + (substRightCo lc co) + where kco = go Nominal (coercionType co) + + lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) + (substTy (lcSubstLeft lc) ty) + (substTy (lcSubstRight lc) ty) + +{- +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail if a coercion in the environment is of too low a role. + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. +-} + +-- See Note [liftCoSubstTyVar] +liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LC subst env) r v + | Just co_arg <- lookupVarEnv env v + = downgradeRole_maybe r (coercionRole co_arg) co_arg + + | otherwise + = Just $ mkReflCo r (substTyVar subst v) + +{- Note [liftCoSubstVarBndr] + +callback: + We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in + FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type + in snd. + However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and + ignore the fourth component of the return value. + +liftCoSubstTyVarBndrUsing: + Given + forall tv:k. t + We want to get + forall (tv:k1) (kind_co :: k1 ~ k2) body_co + + We lift the kind k to get the kind_co + kind_co = ty_co_subst k :: k1 ~ k2 + + Now in the LiftingContext, we add the new mapping + tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) + +liftCoSubstCoVarBndrUsing: + Given + forall cv:(s1 ~ s2). t + We want to get + forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co + + We lift s1 and s2 respectively to get + eta1 :: s1' ~ t1 + eta2 :: s2' ~ t2 + And + kind_co = TyConAppCo Nominal (~#) eta1 eta2 + + Now in the liftingContext, we add the new mapping + cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) +-} + +-- See Note [liftCoSubstVarBndr] +liftCoSubstVarBndr :: LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, Coercion) +liftCoSubstVarBndr lc tv + = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in + (lc', tv', h) + where + callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, CoercionN, a) +liftCoSubstVarBndrUsing fun lc old_var + | isTyVar old_var + = liftCoSubstTyVarBndrUsing fun lc old_var + | otherwise + = liftCoSubstCoVarBndrUsing fun lc old_var + +-- Works for tyvar binder +liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, CoercionN, a) +liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isTyVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, eta, stuff ) + where + old_kind = tyVarKind old_var + (eta, stuff) = fun lc old_kind + k1 = coercionLKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta + -- :: new_var ~ new_var |> eta + new_cenv = extendVarEnv cenv old_var lifted + +-- Works for covar binder +liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> CoVar + -> (LiftingContext, CoVar, CoercionN, a) +liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isCoVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, kind_co, stuff ) + where + old_kind = coVarKind old_var + (eta, stuff) = fun lc old_kind + k1 = coercionLKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + -- old_var :: s1 ~r s2 + -- eta :: (s1' ~r s2') ~N (t1 ~r t2) + -- eta1 :: s1' ~r t1 + -- eta2 :: s2' ~r t2 + -- co1 :: s1' ~r s2' + -- co2 :: t1 ~r t2 + -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) + -- lifted :: co1 ~N co2 + + role = coVarRole old_var + eta' = downgradeRole role Nominal eta + eta1 = mkNthCo role 2 eta' + eta2 = mkNthCo role 3 eta' + + co1 = mkCoVarCo new_var + co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 + kind_co = mkTyConAppCo Nominal (equalityTyCon role) + [ mkKindCo co1, mkKindCo co2 + , co1 , co2 ] + lifted = mkProofIrrelCo Nominal kind_co co1 co2 + + new_cenv = extendVarEnv cenv old_var lifted + +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env + +-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 +-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 +substLeftCo :: LiftingContext -> Coercion -> Coercion +substLeftCo lc co + = substCo (lcSubstLeft lc) co + +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co + +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo + +lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env + +lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env + +liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft = liftEnvSubst pFst + +liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight = liftEnvSubst pSnd + +liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst selector subst lc_env + = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst + where + pairs = nonDetUFMToList lc_env + -- It's OK to use nonDetUFMToList here because we + -- immediately forget the ordering by creating + -- a VarEnv + (tpairs, cpairs) = partitionWith ty_or_co pairs + tenv = mkVarEnv_Directly tpairs + cenv = mkVarEnv_Directly cpairs + + ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) + ty_or_co (u, co) + | Just equality_co <- isCoercionTy_maybe equality_ty + = Right (u, equality_co) + | otherwise + = Left (u, equality_ty) + where + equality_ty = selector (coercionKind co) + +-- | Extract the underlying substitution from the LiftingContext +lcTCvSubst :: LiftingContext -> TCvSubst +lcTCvSubst (LC subst _) = subst + +-- | Get the 'InScopeSet' from a 'LiftingContext' +lcInScopeSet :: LiftingContext -> InScopeSet +lcInScopeSet (LC subst _) = getTCvInScope subst + +{- +%************************************************************************ +%* * + Sequencing on coercions +%* * +%************************************************************************ +-} + +seqMCo :: MCoercion -> () +seqMCo MRefl = () +seqMCo (MCo co) = seqCo co + +seqCo :: Coercion -> () +seqCo (Refl ty) = seqType ty +seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k + `seq` seqCo co +seqCo (FunCo r w co1 co2) = r `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2 +seqCo (CoVarCo cv) = cv `seq` () +seqCo (HoleCo h) = coHoleCoVar h `seq` () +seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos +seqCo (UnivCo p r t1 t2) + = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo r n co) = r `seq` n `seq` seqCo co +seqCo (LRCo lr co) = lr `seq` seqCo co +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (KindCo co) = seqCo co +seqCo (SubCo co) = seqCo co +seqCo (AxiomRuleCo _ cs) = seqCos cs + +seqProv :: UnivCoProvenance -> () +seqProv (PhantomProv co) = seqCo co +seqProv (ProofIrrelProv co) = seqCo co +seqProv (PluginProv _) = () +seqProv CorePrepProv = () + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos + +{- +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ +-} + +-- | Apply 'coercionKind' to multiple 'Coercion's +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys + +-- | Get a coercion's kind and role. +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole co = (coercionKind co, coercionRole co) + +coercionType :: Coercion -> Type +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + +------------------ +-- | If it is the case that +-- +-- > c :: (t1 ~ t2) +-- +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. + +coercionKind :: Coercion -> Pair Type +coercionKind co = Pair (coercionLKind co) (coercionRKind co) + +coercionLKind :: Coercion -> Type +coercionLKind co + = go co + where + go (Refl ty) = ty + go (GRefl _ ty _) = ty + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) + go (FunCo _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2) + go (CoVarCo cv) = coVarLType cv + go (HoleCo h) = coVarLType (coHoleCoVar h) + go (UnivCo _ _ ty1 _) = ty1 + go (SymCo co) = coercionRKind co + go (TransCo co1 _) = go co1 + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (NthCo _ d co) = go_nth d (go co) + go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) + go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ + coaxrProves ax $ map coercionKind cos + + go_ax_inst ax ind tys + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs } <- coAxiomNthBranch ax ind + , let (tys1, cotys1) = splitAtList tvs tys + cos1 = map stripCoercionTy cotys1 + = ASSERT( tys `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + mkTyConApp (coAxiomTyCon ax) lhs + + go_app :: Coercion -> [Type] -> Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (go arg:args) + go_app co args = piResultTys (go co) args + +go_nth :: Int -> Type -> Type +go_nth d ty + | Just args <- tyConAppArgs_maybe ty + = ASSERT( args `lengthExceeds` d ) + args `getNth` d + + | d == 0 + , Just (tv,_) <- splitForAllTy_maybe ty + = tyVarKind tv + + | otherwise + = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty) + +coercionRKind :: Coercion -> Type +coercionRKind co + = go co + where + go (Refl ty) = ty + go (GRefl _ ty MRefl) = ty + go (GRefl _ ty (MCo co1)) = mkCastTy ty co1 + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (CoVarCo cv) = coVarRType cv + go (HoleCo h) = coVarRType (coHoleCoVar h) + go (FunCo _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2) + go (UnivCo _ _ _ ty2) = ty2 + go (SymCo co) = coercionLKind co + go (TransCo _ co2) = go co2 + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (NthCo _ d co) = go_nth d (go co) + go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) + go (AxiomRuleCo ax cos) = pSnd $ expectJust "coercionKind" $ + coaxrProves ax $ map coercionKind cos + + go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar + | isGReflCo k_co = mkTyCoInvForAllTy tv1 (go co1) + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = go_forall empty_subst co + where + empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) + + go_ax_inst ax ind tys + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , let (tys2, cotys2) = splitAtList tvs tys + cos2 = map stripCoercionTy cotys2 + = ASSERT( tys `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + substTyWith tvs tys2 $ + substTyWithCoVars cvs cos2 rhs + + go_app :: Coercion -> [Type] -> Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (go arg:args) + go_app co args = piResultTys (go co) args + + go_forall subst (ForAllCo tv1 k_co co) + -- See Note [Nested ForAllCos] + | isTyVar tv1 + = mkInfForAllTy tv2 (go_forall subst' co) + where + k2 = coercionRKind k_co + tv2 = setTyVarKind tv1 (substTy subst k2) + subst' | isGReflCo k_co = extendTCvInScope subst tv1 + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ + TyVarTy tv2 `mkCastTy` mkSymCo k_co + + go_forall subst (ForAllCo cv1 k_co co) + | isCoVar cv1 + = mkTyCoInvForAllTy cv2 (go_forall subst' co) + where + k2 = coercionRKind k_co + r = coVarRole cv1 + eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) + eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) + + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) + -- k1 = t1 ~r t2 + -- k2 = s1 ~r s2 + -- cv1 :: t1 ~r t2 + -- cv2 :: s1 ~r s2 + -- eta1 :: t1 ~r s1 + -- eta2 :: t2 ~r s2 + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 + + cv2 = setVarType cv1 (substTy subst k2) + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) + subst' | isReflCo k_co = extendTCvInScope subst cv1 + | otherwise = extendCvSubst (extendTCvInScope subst cv2) + cv1 n_subst + + go_forall subst other_co + -- when other_co is not a ForAllCo + = substTy subst (go other_co) + +{- + +Note [Nested ForAllCos] +~~~~~~~~~~~~~~~~~~~~~~~ + +Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an +co)...) )`. We do not want to perform `n` single-type-variable +substitutions over the kind of `co`; rather we want to do one substitution +which substitutes for all of `a1`, `a2` ... simultaneously. If we do one +at a time we get the performance hole reported in #11735. + +Solution: gather up the type variables for nested `ForAllCos`, and +substitute for them all at once. Remarkably, for #11735 this single +change reduces /total/ compile time by a factor of more than ten. + +-} + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = go + where + go (Refl _) = Nominal + go (GRefl r _ _) = r + go (TyConAppCo r _ _) = r + go (AppCo co1 _) = go co1 + go (ForAllCo _ _ co) = go co + go (FunCo r _ _ _) = r + go (CoVarCo cv) = coVarRole cv + go (HoleCo h) = coVarRole (coHoleCoVar h) + go (AxiomInstCo ax _ _) = coAxiomRole ax + go (UnivCo _ r _ _) = r + go (SymCo co) = go co + go (TransCo co1 _co2) = go co1 + go (NthCo r _d _co) = r + go (LRCo {}) = Nominal + go (InstCo co _) = go co + go (KindCo {}) = Nominal + go (SubCo _) = Representational + go (AxiomRuleCo ax _) = coaxrRole ax + +{- +Note [Nested InstCos] +~~~~~~~~~~~~~~~~~~~~~ +In #5631 we found that 70% of the entire compilation time was +being spent in coercionKind! The reason was that we had + (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos +where + g :: forall a1 a2 .. a100. phi +If we deal with the InstCos one at a time, we'll do this: + 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' + 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst +But this is a *quadratic* algorithm, and the blew up #5631. +So it's very important to do the substitution simultaneously; +cf Type.piResultTys (which in fact we call here). + +-} + +-- | Makes a coercion type from two types: the types whose equality +-- is proven by the relevant 'Coercion' +mkCoercionType :: Role -> Type -> Type -> Type +mkCoercionType Nominal = mkPrimEqPred +mkCoercionType Representational = mkReprPrimEqPred +mkCoercionType Phantom = \ty1 ty2 -> + let ki1 = typeKind ty1 + ki2 = typeKind ty2 + in + TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] + +mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type +mkHeteroCoercionType Nominal = mkHeteroPrimEqPred +mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred +mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" + +-- | Creates a primitive type equality predicate. +-- Invariant: the types are not Coercions +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Makes a lifted equality predicate at the given role +mkPrimEqPredRole :: Role -> Type -> Type -> PredType +mkPrimEqPredRole Nominal = mkPrimEqPred +mkPrimEqPredRole Representational = mkReprPrimEqPred +mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" + +-- | Creates a primitive type equality predicate with explicit kinds +mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + +-- | Creates a primitive representational type equality predicate +-- with explicit kinds +mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroReprPrimEqPred k1 k2 ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + +mkReprPrimEqPred :: Type -> Type -> Type +mkReprPrimEqPred ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Assuming that two types are the same, ignoring coercions, find +-- a nominal coercion between the types. This is useful when optimizing +-- transitivity over coercion applications, where splitting two +-- AppCos might yield different kinds. See Note [EtaAppCo] in +-- "GHC.Core.Coercion.Opt". +buildCoercion :: Type -> Type -> CoercionN +buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + go (CastTy ty1 co) ty2 + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceLeftCo r ty1 co co' + + go ty1 (CastTy ty2 co) + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceRightCo r ty2 co co' + + go ty1@(TyVarTy tv1) _tyvarty + = ASSERT( case _tyvarty of + { TyVarTy tv2 -> tv1 == tv2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2) + + go (TyConApp tc1 args1) (TyConApp tc2 args2) + = ASSERT( tc1 == tc2 ) + mkTyConAppCo Nominal tc1 (zipWith go args1 args2) + + go (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) + | isTyVar tv1 + = ASSERT( isTyVar tv2 ) + mkForAllCo tv1 kind_co (go ty1 ty2') + where kind_co = go (tyVarKind tv1) (tyVarKind tv2) + in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTyWithInScope in_scope [tv2] + [mkTyVarTy tv1 `mkCastTy` kind_co] + ty2 + + go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) + = ASSERT( isCoVar cv1 && isCoVar cv2 ) + mkForAllCo cv1 kind_co (go ty1 ty2') + where s1 = varType cv1 + s2 = varType cv2 + kind_co = go s1 s2 + + -- s1 = t1 ~r t2 + -- s2 = t3 ~r t4 + -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) + -- eta1 :: t1 ~r t3 + -- eta2 :: t2 ~r t4 + + r = coVarRole cv1 + kind_co' = downgradeRole r Nominal kind_co + eta1 = mkNthCo r 2 kind_co' + eta2 = mkNthCo r 3 kind_co' + + subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` + mkCoVarCo cv1 `mkTransCo` + eta2) + ty2 + + go ty1@(LitTy lit1) _lit2 + = ASSERT( case _lit2 of + { LitTy lit2 -> lit1 == lit2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (CoercionTy co1) (CoercionTy co2) + = mkProofIrrelCo Nominal kind_co co1 co2 + where + kind_co = go (coercionType co1) (coercionType co2) + + go ty1 ty2 + = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 + , ppr ty1, ppr ty2 ]) + +{- +%************************************************************************ +%* * + Simplifying types +%* * +%************************************************************************ + +The function below morally belongs in GHC.Tc.Solver.Flatten, but it is used also in +FamInstEnv, and so lives here. + +Note [simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant (F2) of Note [Flattening] says that flattening is homogeneous. +This causes some trouble when flattening a function applied to a telescope +of arguments, perhaps with dependency. For example, suppose + + type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] + +and we wish to flatten the args of (with kind applications explicit) + + F a b (Just a c) (Right a b d) False + +where all variables are skolems and + + a :: Type + b :: Type + c :: a + d :: k + + [G] aco :: a ~ fa + [G] bco :: b ~ fb + [G] cco :: c ~ fc + [G] dco :: d ~ fd + +The first step is to flatten all the arguments. This is done before calling +simplifyArgsWorker. We start from + + a + b + Just a c + Right a b d + False + +and get + + (fa, co1 :: fa ~ a) + (fb, co2 :: fb ~ b) + (Just fa (fc |> aco) |> co6, co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c)) + (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d)) + (False, co5 :: False ~ False) + +where + co6 :: Maybe fa ~ Maybe a + co7 :: Either fa fb ~ Either a b + +We now process the flattened args in left-to-right order. The first two args +need no further processing. But now consider the third argument. Let f3 = the flattened +result, Just fa (fc |> aco) |> co6. +This f3 flattened argument has kind (Maybe a), due to +(F2). And yet, when we build the application (F fa fb ...), we need this +argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. +The coercion to use is +determined by the kind of F: we see in F's kind that the third argument has +kind Maybe j. Critically, we also know that the argument corresponding to j +(in our example, a) flattened with a coercion co1. We can thus know the +coercion needed for the 3rd argument is (Maybe (sym co1)), thus building +(f3 |> Maybe (sym co1)) + +More generally, we must use the Lifting Lemma, as implemented in +Coercion.liftCoSubst. As we work left-to-right, any variable that is a +dependent parameter (j and k, in our example) gets mapped in a lifting context +to the coercion that is output from flattening the corresponding argument (co1 +and co2, in our example). Then, after flattening later arguments, we lift the +kind of these arguments in the lifting context that we've be building up. +This coercion is then used to keep the result of flattening well-kinded. + +Working through our example, this is what happens: + + 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, + because the binder associated with the first argument has a closed type (no + variables). + + 2. Extend the LC with [k |-> co2]. No casting to do. + + 3. Lifting the kind (Maybe j) with our LC + yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to + F. + + 4. Lifting the kind (Either j k) with our LC + yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th + argument to F, where f4 is the flattened form of argument 4, written above. + + 5. We lift Bool with our LC, getting ; + casting has no effect. + +We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False) +has the wrong kind. Its kind is [fb], instead of the original [b]. +So we must use our LC one last time to lift the result kind [k], +getting res_co :: [fb] ~ [b], and we cast our result. + +Accordingly, the final result is + + F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) + (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) + False + |> [sym bco] + +The res_co (in this case, [sym bco]) +is returned as the third return value from simplifyArgsWorker. + +Note [Last case in simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, +because that case is first. We've run out of +binders. But perhaps inner_ki is a tyvar that has been instantiated with a +Π-type. + +Here is an example. + + a :: forall (k :: Type). k -> k + type family Star + Proxy :: forall j. j -> Type + axStar :: Star ~ Type + type family NoWay :: Bool + axNoWay :: NoWay ~ False + bo :: Type + [G] bc :: bo ~ Bool (in inert set) + + co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) + co = forall (j :: sym axStar). ( -> sym axStar) + + We are flattening: + a (forall (j :: Star). (j |> axStar) -> Star) -- 1 + (Proxy |> co) -- 2 + (bo |> sym axStar) -- 3 + (NoWay |> sym bc) -- 4 + :: Star + +First, we flatten all the arguments (before simplifyArgsWorker), like so: + + (forall j. j -> Type, co1 :: (forall j. j -> Type) ~ + (forall (j :: Star). (j |> axStar) -> Star)) -- 1 + (Proxy |> co, co2 :: (Proxy |> co) ~ (Proxy |> co)) -- 2 + (Bool |> sym axStar, co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar)) -- 3 + (False |> sym bc, co4 :: (False |> sym bc) ~ (NoWay |> sym bc)) -- 4 + +Then we do the process described in Note [simplifyArgsWorker]. + +1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we + don't use it. But we do build a lifting context [k -> co1] (where co1 is a + result of flattening an argument, written above). + +2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1). + This is not a dependent argument, so we don't extend the lifting context. + +Now we need to deal with argument (3). +The way we normally proceed is to lift the kind of the binder, to see whether +it's dependent. +But here, the remainder of the kind of `a` that we're left with +after processing two arguments is just `k`. + +The way forward is look up k in the lifting context, getting co1. If we're at +all well-typed, co1 will be a coercion between Π-types, with at least one binder. +So, let's +decompose co1 with decomposePiCos. This decomposition needs arguments to use +to instantiate any kind parameters. Look at the type of co1. If we just +decomposed it, we would end up with coercions whose types include j, which is +out of scope here. Accordingly, decomposePiCos takes a list of types whose +kinds are the *right-hand* types in the decomposed coercion. (See comments on +decomposePiCos.) Because the flattened types have unflattened kinds (because +flattening is homogeneous), passing the list of flattened types to decomposePiCos +just won't do: later arguments' kinds won't be as expected. So we need to get +the *unflattened* types to pass to decomposePiCos. We can do this easily enough +by taking the kind of the argument coercions, passed in originally. + +(Alternative 1: We could re-engineer decomposePiCos to deal with this situation. +But that function is already gnarly, and taking the right-hand types is correct +at its other call sites, which are much more common than this one.) + +(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its +behavior into simplifyArgsWorker. This would work, I think, but then all of the +complication of decomposePiCos would end up layered on top of all the complication +here. Please, no.) + +(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker +so that we don't have to recreate them. But that would complicate the interface +of this function to handle a very dark, dark corner case. Better to keep our +demons to ourselves here instead of exposing them to callers. This decision is +easily reversed if there is ever any performance trouble due to the call of +coercionKind.) + +So we now call + + decomposePiCos co1 + (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star)) + [bo |> sym axStar, NoWay |> sym bc] + +to get + + co5 :: Star ~ Type + co6 :: (j |> axStar) ~ (j |> co5), substituted to + (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) + == bo ~ bo + res_co :: Type ~ Star + +We then use these casts on (the flattened) (3) and (4) to get + + (Bool |> sym axStar |> co5 :: Type) -- (C3) + (False |> sym bc |> co6 :: bo) -- (C4) + +We can simplify to + + Bool -- (C3) + (False |> sym bc :: bo) -- (C4) + +Of course, we still must do the processing in Note [simplifyArgsWorker] to finish +the job. We thus want to recur. Our new function kind is the left-hand type of +co1 (gotten, recall, by lifting the variable k that was the return kind of the +original function). Why the left-hand type (as opposed to the right-hand type)? +Because we have casted all the arguments according to decomposePiCos, which gets +us from the right-hand type to the left-hand one. We thus recur with that new +function kind, zapping our lifting context, because we have essentially applied +it. + +This recursive call returns ([Bool, False], [...], Refl). The Bool and False +are the correct arguments we wish to return. But we must be careful about the +result coercion: our new, flattened application will have kind Type, but we +want to make sure that the result coercion casts this back to Star. (Why? +Because we started with an application of kind Star, and flattening is homogeneous.) + +So, we have to twiddle the result coercion appropriately. + +Let's check whether this is well-typed. We know + + a :: forall (k :: Type). k -> k + + a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type + + a (forall j. j -> Type) + Proxy + :: forall j. j -> Type + + a (forall j. j -> Type) + Proxy + Bool + :: Bool -> Type + + a (forall j. j -> Type) + Proxy + Bool + False + :: Type + + a (forall j. j -> Type) + Proxy + Bool + False + |> res_co + :: Star + +as desired. + +Whew. + +Historical note: I (Richard E) once thought that the final part of the kind +had to be a variable k (as in the example above). But it might not be: it could +be an application of a variable. Here is the example: + + let f :: forall (a :: Type) (b :: a -> Type). b (Any @a) + k :: Type + x :: k + + flatten (f @Type @((->) k) x) + +After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` +is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded. + +-} + + +-- This is shared between the flattener and the normaliser in GHC.Core.FamInstEnv. +-- See Note [simplifyArgsWorker] +{-# INLINE simplifyArgsWorker #-} +simplifyArgsWorker :: [TyCoBinder] -> Kind + -- the binders & result kind (not a Π-type) of the function applied to the args + -- list of binders can be shorter or longer than the list of args + -> TyCoVarSet -- free vars of the args + -> [Role] -- list of roles, r + -> [(Type, Coercion)] -- flattened type arguments, arg + -- each comes with the coercion used to flatten it, + -- with co :: flattened_type ~ original_type + -> ([Type], [Coercion], CoercionN) +-- Returns (xis, cos, res_co), where each co :: xi ~ arg, +-- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args +-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), +-- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded. +-- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this +-- function is all about. That is, (f xis), where xis are the returned arguments, *is* +-- well kinded. +simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs + orig_roles orig_simplified_args + = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args + where + orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs + + go :: [Type] -- Xis accumulator, in reverse order + -> [Coercion] -- Coercions accumulator, in reverse order + -- These are in 1-to-1 correspondence + -> LiftingContext -- mapping from tyvars to flattening coercions + -> [TyCoBinder] -- Unsubsted binders of function's kind + -> Kind -- Unsubsted result kind of function (not a Pi-type) + -> [Role] -- Roles at which to flatten these ... + -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions + -> ([Type], [Coercion], CoercionN) + go acc_xis acc_cos !lc binders inner_ki _ [] + -- The !lc makes the function strict in the lifting context + -- which means GHC can unbox that pair. A modest win. + = (reverse acc_xis, reverse acc_cos, kind_co) + where + final_kind = mkPiTys binders inner_ki + kind_co = liftCoSubst Nominal lc final_kind + + go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) + = -- By Note [Flattening] in GHC.Tc.Solver.Flatten invariant (F2), + -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be + -- used as an argument to a function whose kind is different, if + -- earlier arguments have been flattened to new types. We thus + -- need a coercion (kind_co :: old_kind ~ new_kind). + -- + -- The bangs here have been observed to improve performance + -- significantly in optimized builds; see #18502 + let !kind_co = mkSymCo $ + liftCoSubst Nominal lc (tyCoBinderType binder) + !casted_xi = xi `mkCastTy` kind_co + casted_co = mkCoherenceLeftCo role xi kind_co co + + -- now, extend the lifting context with the new binding + !new_lc | Just tv <- tyCoBinderVar_maybe binder + = extendLiftingContextAndInScope lc tv casted_co + | otherwise + = lc + in + go (casted_xi : acc_xis) + (casted_co : acc_cos) + new_lc + binders + inner_ki + roles + args + + + -- See Note [Last case in simplifyArgsWorker] + go acc_xis acc_cos lc [] inner_ki roles args + = let co1 = liftCoSubst Nominal lc inner_ki + co1_kind = coercionKind co1 + unflattened_tys = map (coercionRKind . snd) args + (arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys + casted_args = ASSERT2( equalLength args arg_cos + , ppr args $$ ppr arg_cos ) + [ (casted_xi, casted_co) + | ((xi, co), arg_co, role) <- zip3 args arg_cos roles + , let casted_xi = xi `mkCastTy` arg_co + casted_co = mkCoherenceLeftCo role xi arg_co co ] + -- In general decomposePiCos can return fewer cos than tys, + -- but not here; because we're well typed, there will be enough + -- binders. Note that decomposePiCos does substitutions, so even + -- if the original substitution results in something ending with + -- ... -> k, that k will be substituted to perhaps reveal more + -- binders. + zapped_lc = zapLiftingContext lc + Pair flattened_kind _ = co1_kind + (bndrs, new_inner) = splitPiTys flattened_kind + + (xis_out, cos_out, res_co_out) + = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args + in + (xis_out, cos_out, res_co_out `mkTransCo` res_co) + + go _ _ _ _ _ _ _ = panic + "simplifyArgsWorker wandered into deeper water than usual" + -- This debug information is commented out because leaving it in + -- causes a ~2% increase in allocations in T9872d. + -- That's independent of the analogous case in flatten_args_fast + -- in GHC.Tc.Solver.Flatten: + -- each of these causes a 2% increase on its own, so commenting them + -- both out gives a 4% decrease in T9872d. + {- + + (vcat [ppr orig_binders, + ppr orig_inner_ki, + ppr (take 10 orig_roles), -- often infinite! + ppr orig_tys]) + -} + +{- +%************************************************************************ +%* * + Coercion holes +%* * +%************************************************************************ +-} + +bad_co_hole_ty :: Type -> Monoid.Any +bad_co_hole_co :: Coercion -> Monoid.Any +(bad_co_hole_ty, _, bad_co_hole_co, _) + = foldTyCo folder () + where + folder = TyCoFolder { tcf_view = const Nothing + , tcf_tyvar = const2 (Monoid.Any False) + , tcf_covar = const2 (Monoid.Any False) + , tcf_hole = const hole + , tcf_tycobinder = const2 + } + + const2 :: a -> b -> c -> a + const2 x _ _ = x + + hole :: CoercionHole -> Monoid.Any + hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True + hole _ = Monoid.Any False + +-- | Is there a blocking coercion hole in this type? See +-- "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds] +badCoercionHole :: Type -> Bool +badCoercionHole = Monoid.getAny . bad_co_hole_ty + +-- | Is there a blocking coercion hole in this coercion? See +-- GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds] +badCoercionHoleCo :: Coercion -> Bool +badCoercionHoleCo = Monoid.getAny . bad_co_hole_co diff --git a/GHC/Core/Coercion.hs-boot b/GHC/Core/Coercion.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion.hs-boot @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Coercion where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep +import {-# SOURCE #-} GHC.Core.TyCon + +import GHC.Types.Basic ( LeftOrRight ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Var +import GHC.Data.Pair +import GHC.Utils.Misc + +mkReflCo :: Role -> Type -> Coercion +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkAppCo :: Coercion -> Coercion -> Coercion +mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion +mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion +mkCoVarCo :: CoVar -> Coercion +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkSymCo :: Coercion -> Coercion +mkTransCo :: Coercion -> Coercion -> Coercion +mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkInstCo :: Coercion -> Coercion -> Coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkNomReflCo :: Type -> Coercion +mkKindCo :: Coercion -> Coercion +mkSubCo :: Coercion -> Coercion +mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion + +isGReflCo :: Coercion -> Bool +isReflCo :: Coercion -> Bool +isReflexiveCo :: Coercion -> Bool +decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) +coVarRole :: CoVar -> Role + +mkCoercionType :: Role -> Type -> Type -> Type + +data LiftingContext +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +seqCo :: Coercion -> () + +coercionKind :: Coercion -> Pair Type +coercionLKind :: Coercion -> Type +coercionRKind :: Coercion -> Type +coercionType :: Coercion -> Type diff --git a/GHC/Core/Coercion/Axiom.hs b/GHC/Core/Coercion/Axiom.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion/Axiom.hs @@ -0,0 +1,590 @@ +-- (c) The University of Glasgow 2012 + +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, + ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} + +-- | Module for coercion axioms, used to represent type family instances +-- and newtypes + +module GHC.Core.Coercion.Axiom ( + BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), + manyBranches, unbranched, + fromBranches, numBranches, + mapAccumBranches, + + CoAxiom(..), CoAxBranch(..), + + toBranchedAxiom, toUnbranchedAxiom, + coAxiomName, coAxiomArity, coAxiomBranches, + coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, + coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, + coAxBranchRoles, + coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, + placeHolderIncomps, + + Role(..), fsFromRole, + + CoAxiomRule(..), TypeEqn, + BuiltInSynFamily(..), trivialBuiltInFamily + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Var +import GHC.Utils.Misc +import GHC.Utils.Binary +import GHC.Data.Pair +import GHC.Types.Basic +import Data.Typeable ( Typeable ) +import GHC.Types.SrcLoc +import qualified Data.Data as Data +import Data.Array +import Data.List ( mapAccumL ) + +#include "HsVersions.h" + +{- +Note [Coercion axiom branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to allow closed type families, an axiom needs to contain an +ordered list of alternatives, called branches. The kind of the coercion built +from an axiom is determined by which index is used when building the coercion +from the axiom. + +For example, consider the axiom derived from the following declaration: + +type family F a where + F [Int] = Bool + F [a] = Double + F (a b) = Char + +This will give rise to this axiom: + +axF :: { F [Int] ~ Bool + ; forall (a :: *). F [a] ~ Double + ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char + } + +The axiom is used with the AxiomInstCo constructor of Coercion. If we wish +to have a coercion showing that F (Maybe Int) ~ Char, it will look like + +axF[2] <*> :: F (Maybe Int) ~ Char +-- or, written using concrete-ish syntax -- +AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] + +Note that the index is 0-based. + +For type-checking, it is also necessary to check that no previous pattern +can unify with the supplied arguments. After all, it is possible that some +of the type arguments are lambda-bound type variables whose instantiation may +cause an earlier match among the branches. We wish to prohibit this behavior, +so the type checker rules out the choice of a branch where a previous branch +can unify. See also [Apartness] in GHC.Core.FamInstEnv. + +For example, the following is malformed, where 'a' is a lambda-bound type +variable: + +axF[2] <*> :: F (a Bool) ~ Char + +Why? Because a might be instantiated with [], meaning that branch 1 should +apply, not branch 2. This is a vital consistency check; without it, we could +derive Int ~ Bool, and that is a Bad Thing. + +Note [Branched axioms] +~~~~~~~~~~~~~~~~~~~~~~ +Although a CoAxiom has the capacity to store many branches, in certain cases, +we want only one. These cases are in data/newtype family instances, newtype +coercions, and type family instances. +Furthermore, these unbranched axioms are used in a +variety of places throughout GHC, and it would difficult to generalize all of +that code to deal with branched axioms, especially when the code can be sure +of the fact that an axiom is indeed a singleton. At the same time, it seems +dangerous to assume singlehood in various places through GHC. + +The solution to this is to label a CoAxiom with a phantom type variable +declaring whether it is known to be a singleton or not. The branches +are stored using a special datatype, declared below, that ensures that the +type variable is accurate. + +************************************************************************ +* * + Branches +* * +************************************************************************ +-} + +type BranchIndex = Int -- The index of the branch in the list of branches + -- Counting from zero + +-- promoted data type +data BranchFlag = Branched | Unbranched +type Branched = 'Branched +type Unbranched = 'Unbranched +-- By using type synonyms for the promoted constructors, we avoid needing +-- DataKinds and the promotion quote in client modules. This also means that +-- we don't need to export the term-level constructors, which should never be used. + +newtype Branches (br :: BranchFlag) + = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } +type role Branches nominal + +manyBranches :: [CoAxBranch] -> Branches Branched +manyBranches brs = ASSERT( snd bnds >= fst bnds ) + MkBranches (listArray bnds brs) + where + bnds = (0, length brs - 1) + +unbranched :: CoAxBranch -> Branches Unbranched +unbranched br = MkBranches (listArray (0, 0) [br]) + +toBranched :: Branches br -> Branches Branched +toBranched = MkBranches . unMkBranches + +toUnbranched :: Branches br -> Branches Unbranched +toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) + MkBranches arr + +fromBranches :: Branches br -> [CoAxBranch] +fromBranches = elems . unMkBranches + +branchesNth :: Branches br -> BranchIndex -> CoAxBranch +branchesNth (MkBranches arr) n = arr ! n + +numBranches :: Branches br -> Int +numBranches (MkBranches arr) = snd (bounds arr) + 1 + +-- | The @[CoAxBranch]@ passed into the mapping function is a list of +-- all previous branches, reversed +mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) + -> Branches br -> Branches br +mapAccumBranches f (MkBranches arr) + = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_branches cur_branch = ( cur_branch : prev_branches + , f prev_branches cur_branch ) + + +{- +************************************************************************ +* * + Coercion axioms +* * +************************************************************************ + +Note [Storing compatibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During axiom application, we need to be aware of which branches are compatible +with which others. The full explanation is in Note [Compatibility] in +GHc.Core.FamInstEnv. (The code is placed there to avoid a dependency from +GHC.Core.Coercion.Axiom on the unification algorithm.) Although we could +theoretically compute compatibility on the fly, this is silly, so we store it +in a CoAxiom. + +Specifically, each branch refers to all other branches with which it is +incompatible. This list might well be empty, and it will always be for the +first branch of any axiom. + +CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk +stored in cab_incomps. The incompatibilities are properly a property of the +axiom as a whole, and they are computed only when the final axiom is built. + +During serialization, the list is converted into a list of the indices +of the branches. + +Note [CoAxioms are homogeneous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All axioms must be *homogeneous*, meaning that the kind of the LHS must +match the kind of the RHS. In practice, this means: + + Given a CoAxiom { co_ax_tc = ax_tc }, + for every branch CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }: + typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs + +This is checked in FamInstEnv.mkCoAxBranch. +-} + +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data CoAxiom br + = CoAxiom -- Type equality axiom. + { co_ax_unique :: Unique -- Unique identifier + , co_ax_name :: Name -- Name for pretty-printing + , co_ax_role :: Role -- Role of the axiom's equality + , co_ax_tc :: TyCon -- The head of the LHS patterns + -- e.g. the newtype or family tycon + , co_ax_branches :: Branches br -- The branches that form this axiom + , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" + -- See Note [Implicit axioms] + -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. + } + +data CoAxBranch + = CoAxBranch + { cab_loc :: SrcSpan -- Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh + -- See Note [CoAxBranch type variables] + , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars + -- cab_tvs and cab_lhs may be eta-reduced; see + -- Note [Eta reduction for data families] + , cab_cvs :: [CoVar] -- Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in GHC.Tc.TyCl + , cab_roles :: [Role] -- See Note [CoAxBranch roles] + , cab_lhs :: [Type] -- Type patterns to match against + , cab_rhs :: Type -- Right-hand side of the equality + -- See Note [CoAxioms are homogeneous] + , cab_incomps :: [CoAxBranch] -- The previous incompatible branches + -- See Note [Storing compatibility] + } + deriving Data.Data + +toBranchedAxiom :: CoAxiom br -> CoAxiom Branched +toBranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toBranched branches) implicit + +toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched +toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toUnbranched branches) implicit + +coAxiomNumPats :: CoAxiom br -> Int +coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) + +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch +coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index + = branchesNth bs index + +coAxiomArity :: CoAxiom br -> BranchIndex -> Arity +coAxiomArity ax index + = length tvs + length cvs + where + CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index + +coAxiomName :: CoAxiom br -> Name +coAxiomName = co_ax_name + +coAxiomRole :: CoAxiom br -> Role +coAxiomRole = co_ax_role + +coAxiomBranches :: CoAxiom br -> Branches br +coAxiomBranches = co_ax_branches + +coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch +coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) + | snd (bounds arr) == 0 + = Just $ arr ! 0 + | otherwise + = Nothing + +coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch +coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) + = arr ! 0 + +coAxiomTyCon :: CoAxiom br -> TyCon +coAxiomTyCon = co_ax_tc + +coAxBranchTyVars :: CoAxBranch -> [TyVar] +coAxBranchTyVars = cab_tvs + +coAxBranchCoVars :: CoAxBranch -> [CoVar] +coAxBranchCoVars = cab_cvs + +coAxBranchLHS :: CoAxBranch -> [Type] +coAxBranchLHS = cab_lhs + +coAxBranchRHS :: CoAxBranch -> Type +coAxBranchRHS = cab_rhs + +coAxBranchRoles :: CoAxBranch -> [Role] +coAxBranchRoles = cab_roles + +coAxBranchSpan :: CoAxBranch -> SrcSpan +coAxBranchSpan = cab_loc + +isImplicitCoAxiom :: CoAxiom br -> Bool +isImplicitCoAxiom = co_ax_implicit + +coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] +coAxBranchIncomps = cab_incomps + +-- See Note [Compatibility checking] in GHC.Core.FamInstEnv +placeHolderIncomps :: [CoAxBranch] +placeHolderIncomps = panic "placeHolderIncomps" + +{- +Note [CoAxBranch type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of a CoAxBranch of an associated type-family instance, +we use the *same* type variables (where possible) as the +enclosing class or instance. Consider + + instance C Int [z] where + type F Int [z] = ... -- Second param must be [z] + +In the CoAxBranch in the instance decl (F Int [z]) we use the +same 'z', so that it's easy to check that that type is the same +as that in the instance header. + +So, unlike FamInsts, there is no expectation that the cab_tvs +are fresh wrt each other, or any other CoAxBranch. + +Note [CoAxBranch roles] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + newtype Age = MkAge Int + newtype Wrap a = MkWrap a + + convert :: Wrap Age -> Int + convert (MkWrap (MkAge i)) = i + +We want this to compile to: + + NTCo:Wrap :: forall a. Wrap a ~R a + NTCo:Age :: Age ~R Int + convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) + +But, note that NTCo:Age is at role R. Thus, we need to be able to pass +coercions at role R into axioms. However, we don't *always* want to be able to +do this, as it would be disastrous with type families. The solution is to +annotate the arguments to the axiom with roles, much like we annotate tycon +tyvars. Where do these roles get set? Newtype axioms inherit their roles from +the newtype tycon; family axioms are all at role N. + +Note [CoAxiom locations] +~~~~~~~~~~~~~~~~~~~~~~~~ +The source location of a CoAxiom is stored in two places in the +datatype tree. + * The first is in the location info buried in the Name of the + CoAxiom. This span includes all of the branches of a branched + CoAxiom. + * The second is in the cab_loc fields of the CoAxBranches. + +In the case of a single branch, we can extract the source location of +the branch from the name of the CoAxiom. In other cases, we need an +explicit SrcSpan to correctly store the location of the equation +giving rise to the FamInstBranch. + +Note [Implicit axioms] +~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Implicit TyThings] in GHC.Driver.Types +* A CoAxiom arising from data/type family instances is not "implicit". + That is, it has its own IfaceAxiom declaration in an interface file + +* The CoAxiom arising from a newtype declaration *is* "implicit". + That is, it does not have its own IfaceAxiom declaration in an + interface file; instead the CoAxiom is generated by type-checking + the newtype declaration + +Note [Eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. + +From the 'newtype instance' you might think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +----- Bottom line ------ + +For a CoAxBranch for a data family instance with representation +TyCon rep_tc: + + - cab_tvs (of its CoAxiom) may be shorter + than tyConTyVars of rep_tc. + + - cab_lhs may be shorter than tyConArity of the family tycon + i.e. LHS is unsaturated + + - cab_rhs will be (rep_tc cab_tvs) + i.e. RHS is un-saturated + + - This eta reduction happens for data instances as well + as newtype instances. Here we want to eta-reduce the data family axiom. + + - This eta-reduction is done in GHC.Tc.TyCl.Instance.tcDataFamInstDecl. + +But for a /type/ family + - cab_lhs has the exact arity of the family tycon + +There are certain situations (e.g., pretty-printing) where it is necessary to +deal with eta-expanded data family instances. For these situations, the +cab_eta_tvs field records the stuff that has been eta-reduced away. +So if we have + axiom forall a b. F [a->b] = D b a +and cab_eta_tvs is [p,q], then the original user-written definition +looked like + axiom forall a b p q. F [a->b] p q = D b a p q +(See #9692, #14179, and #15845 for examples of what can go wrong if +we don't eta-expand when showing things to the user.) + +See also: + +* Note [Newtype eta] in GHC.Core.TyCon. This is notionally separate + and deals with the axiom connecting a newtype with its representation + type; but it too is eta-reduced. +* Note [Implementing eta reduction for data families] in "GHC.Tc.TyCl.Instance". This + describes the implementation details of this eta reduction happen. +-} + +instance Eq (CoAxiom br) where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable (CoAxiom br) where + getUnique = co_ax_unique + +instance Outputable (CoAxiom br) where + ppr = ppr . getName + +instance NamedThing (CoAxiom br) where + getName = co_ax_name + +instance Typeable br => Data.Data (CoAxiom br) where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" + +instance Outputable CoAxBranch where + ppr (CoAxBranch { cab_loc = loc + , cab_lhs = lhs + , cab_rhs = rhs }) = + text "CoAxBranch" <+> parens (ppr loc) <> colon + <+> brackets (fsep (punctuate comma (map pprType lhs))) + <+> text "=>" <+> pprType rhs + +{- +************************************************************************ +* * + Roles +* * +************************************************************************ + +Roles are defined here to avoid circular dependencies. +-} + +-- See Note [Roles] in GHC.Core.Coercion +-- defined here to avoid cyclic dependency with GHC.Core.Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data.Data) + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in GHC.Parser.PostProcess +fsFromRole :: Role -> FastString +fsFromRole Nominal = fsLit "nominal" +fsFromRole Representational = fsLit "representational" +fsFromRole Phantom = fsLit "phantom" + +instance Outputable Role where + ppr = ftext . fsFromRole + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +{- +************************************************************************ +* * + CoAxiomRule + Rules for building Evidence +* * +************************************************************************ + +Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: + + forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 + +My intention is to reuse these for both (~) and (~#). +The short-term plan is to use this datatype to represent the type-nat axioms. +In the longer run, it may be good to unify this and `CoAxiom`, +as `CoAxiom` is the special case when there are no assumptions. +-} + +-- | A more explicit representation for `t1 ~ t2`. +type TypeEqn = Pair Type + +-- | For now, we work only with nominal equality. +data CoAxiomRule = CoAxiomRule + { coaxrName :: FastString + , coaxrAsmpRoles :: [Role] -- roles of parameter equations + , coaxrRole :: Role -- role of resulting equation + , coaxrProves :: [TypeEqn] -> Maybe TypeEqn + -- ^ coaxrProves returns @Nothing@ when it doesn't like + -- the supplied arguments. When this happens in a coercion + -- that means that the coercion is ill-formed, and Core Lint + -- checks for that. + } + +instance Data.Data CoAxiomRule where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiomRule" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiomRule" + +instance Uniquable CoAxiomRule where + getUnique = getUnique . coaxrName + +instance Eq CoAxiomRule where + x == y = coaxrName x == coaxrName y + +instance Ord CoAxiomRule where + compare x y = compare (coaxrName x) (coaxrName y) + +instance Outputable CoAxiomRule where + ppr = ppr . coaxrName + + +-- Type checking of built-in families +data BuiltInSynFamily = BuiltInSynFamily + { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) + , sfInteractTop :: [Type] -> Type -> [TypeEqn] + , sfInteractInert :: [Type] -> Type -> + [Type] -> Type -> [TypeEqn] + } + +-- Provides default implementations that do nothing. +trivialBuiltInFamily :: BuiltInSynFamily +trivialBuiltInFamily = BuiltInSynFamily + { sfMatchFam = \_ -> Nothing + , sfInteractTop = \_ _ -> [] + , sfInteractInert = \_ _ _ _ -> [] + } diff --git a/GHC/Core/Coercion/Opt.hs b/GHC/Core/Coercion/Opt.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Coercion/Opt.hs @@ -0,0 +1,1207 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.Coercion +import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) +import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Outputable +import GHC.Core.FamInstEnv ( flattenTys ) +import GHC.Data.Pair +import GHC.Data.List.SetOps ( getNth ) +import GHC.Utils.Misc +import GHC.Core.Unify +import GHC.Core.InstEnv +import Control.Monad ( zipWithM ) + +{- +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + +Note [Optimising InstCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +(1) tv is a type variable +When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. + +Let's look at the typing rules. + +h : k1 ~ k2 +tv:k1 |- g : t1 ~ t2 +----------------------------- +ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) + +g1 : (all tv:k1.t1') ~ (all tv:k2.t2') +g2 : s1 ~ s2 +-------------------- +InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] + +We thus want some coercion proving this: + + (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) + +If we substitute the *type* tv for the *coercion* +(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. +This is bizarre, +though, because we're substituting a type variable with a coercion. However, +this operation already exists: it's called *lifting*, and defined in GHC.Core.Coercion. +We just need to enhance the lifting operation to be able to deal with +an ambient substitution, which is why a LiftingContext stores a TCvSubst. + +(2) cv is a coercion variable +Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. + +h : (t1 ~r t2) ~N (t3 ~r t4) +cv : t1 ~r t2 |- g : t1' ~r2 t2' +n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 +n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 +------------------------------------------------ +ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 + (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) + +g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') +g2 : h1 ~N h2 +h1 : t1 ~r t2 +h2 : t3 ~r t4 +------------------------------------------------ +InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] + +We thus want some coercion proving this: + + t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] + +So we substitute the coercion variable c for the coercion +(h1 ~N (n1; h2; sym n2)) in g. +-} + +optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion dflags env co + | hasNoOptCoercion dflags = substCo env co + | otherwise = optCoercion' env co + +optCoercion' :: TCvSubst -> Coercion -> NormalCo +optCoercion' env co + | debugIsOn + = let out_co = opt_co1 lc False co + (Pair in_ty1 in_ty2, in_role) = coercionKindRole co + (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co + in + ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 && + substTyUnchecked env in_ty2 `eqType` out_ty2 && + in_role == out_role + , text "optCoercion changed types!" + $$ hang (text "in_co:") 2 (ppr co) + $$ hang (text "in_ty1:") 2 (ppr in_ty1) + $$ hang (text "in_ty2:") 2 (ppr in_ty2) + $$ hang (text "out_co:") 2 (ppr out_co) + $$ hang (text "out_ty1:") 2 (ppr out_ty1) + $$ hang (text "out_ty2:") 2 (ppr out_ty2) + $$ hang (text "subst:") 2 (ppr env) ) + out_co + + | otherwise = opt_co1 lc False co + where + lc = mkSubstLiftingContext env + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +-- | Do we apply a @sym@ to the result? +type SymFlag = Bool + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. All coercions in +-- the lifting context are already optimized (and sym'd if nec'y) +opt_co1 :: LiftingContext + -> SymFlag + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: LiftingContext + -> SymFlag + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co3 env sym Nothing r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role. +opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4_wrap env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4_wrap = opt_co4 +{- +opt_co4_wrap env sym rep r co + = pprTrace "opt_co4_wrap {" + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co ]) $ + ASSERT( r == coercionRole co ) + let result = opt_co4 env sym rep r co in + pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ + result +-} + +opt_co4 env _ rep r (Refl ty) + = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr Nominal $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env _ rep r (GRefl _r ty MRefl) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env sym rep r (GRefl _r ty (MCo co)) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + if isGReflCo co || isGReflCo co' + then liftCoSubst r' env ty + else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) + where + r' = chooseRole rep r + ty' = substTy (lcSubstLeft env) ty + co' = opt_co4 env False False Nominal co + +opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co + -- surprisingly, we don't have to do anything to the env here. This is + -- because any "lifting" substitutions in the env are tied to ForAllCos, + -- which treat their left and right sides differently. We don't want to + -- exchange them. + +opt_co4 env sym rep r g@(TyConAppCo _r tc cos) + = ASSERT( r == _r ) + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRolesRepresentational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRolesRepresentational tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4 env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4_wrap env sym rep r co1) + (opt_co4_wrap env sym False Nominal co2) + +opt_co4 env sym rep r (ForAllCo tv k_co co) + = case optForAllCoBndr env sym tv k_co of + (env', tv', k_co') -> mkForAllCo tv' k_co' $ + opt_co4_wrap env' sym rep r co + -- Use the "mk" functions to check for nested Refls + +opt_co4 env sym rep r (FunCo _r cow co1 co2) + = ASSERT( r == _r ) + if rep + then mkFunCo Representational cow' co1' co2' + else mkFunCo r cow' co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + cow' = opt_co1 env sym cow + +opt_co4 env sym rep r (CoVarCo cv) + | Just co <- lookupCoVar (lcTCvSubst env) cv + = opt_co4_wrap (zapLiftingContext env) sym rep r co + + | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] + = mkReflCo (chooseRole rep r) ty1 + + | otherwise + = ASSERT( isCoVar cv1 ) + wrapRole rep r $ wrapSym sym $ + CoVarCo cv1 + + where + Pair ty1 ty2 = coVarTypes cv1 + + cv1 = case lookupInScope (lcInScopeSet env) cv of + Just cv1 -> cv1 + Nothing -> WARN( True, text "opt_co: not in scope:" + <+> ppr cv $$ ppr env) + cv + -- cv1 might have a substituted kind! + +opt_co4 _ _ _ _ (HoleCo h) + = pprPanic "opt_univ fell into a hole" (ppr h) + +opt_co4 env sym rep r (AxiomInstCo con ind cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = ASSERT( r == coAxiomRole con ) + wrapRole rep (coAxiomRole con) $ + wrapSym sym $ + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomInstCo con ind (zipWith (opt_co2 env False) + (coAxBranchRoles (coAxiomNthBranch con ind)) + cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co4 env sym rep r (UnivCo prov _r t1 t2) + = ASSERT( r == _r ) + opt_univ env sym prov (chooseRole rep r) t1 t2 + +opt_co4 env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + in_scope = lcInScopeSet env + +opt_co4 env _sym rep r (NthCo _r n co) + | Just (ty, _) <- isReflCo_maybe co + , Just (_tc, args) <- ASSERT( r == _r ) + splitTyConApp_maybe ty + = liftCoSubst (chooseRole rep r) env (args `getNth` n) + | Just (ty, _) <- isReflCo_maybe co + , n == 0 + , Just (tv, _) <- splitForAllTy_maybe ty + -- works for both tyvar and covar + = liftCoSubst (chooseRole rep r) env (varType tv) + +opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) + = ASSERT( r == r1 ) + opt_co4_wrap env sym rep r (cos `getNth` n) + +opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) + -- works for both tyvar and covar + = ASSERT( r == _r ) + ASSERT( n == 0 ) + opt_co4_wrap env sym rep Nominal eta + +opt_co4 env sym rep r (NthCo _r n co) + | TyConAppCo _ _ cos <- co' + , let nth_co = cos `getNth` n + = if rep && (r == Nominal) + -- keep propagating the SubCo + then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co + else nth_co + + | ForAllCo _ eta _ <- co' + = if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal eta + else eta + + | otherwise + = wrapRole rep r $ NthCo r n co' + where + co' = opt_co1 env sym co + +opt_co4 env sym rep r (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co + = ASSERT( r == Nominal ) + opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) + | Just pr_co <- splitAppCo_maybe co' + = ASSERT( r == Nominal ) + if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) + else pick_lr lr pr_co + | otherwise + = wrapRole rep Nominal $ LRCo lr co' + where + co' = opt_co4_wrap env sym False Nominal co + + pick_lr CLeft (l, _) = l + pick_lr CRight (_, r) = r + +-- See Note [Optimising InstCo] +opt_co4 env sym rep r (InstCo co1 arg) + -- forall over type... + | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 + = opt_co4_wrap (extendLiftingContext env tv + (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) + -- mkSymCo kind_co :: k1 ~ k2 + -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) + -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) + sym rep r co_body + + -- forall over coercion... + | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 + , CoercionTy h1 <- t1 + , CoercionTy h2 <- t2 + = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 + in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body + + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution, then re-optimize + + -- forall over type... + | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' + = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' + (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) + False False r' co_body' + + -- forall over coercion... + | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' + , CoercionTy h1' <- t1' + , CoercionTy h2' <- t2' + = let new_co = mk_new_co cv' kind_co' h1' h2' + in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) + False False r' co_body' + + | otherwise = InstCo co1' arg' + where + co1' = opt_co4_wrap env sym rep r co1 + r' = chooseRole rep r + arg' = opt_co4_wrap env sym False Nominal arg + sym_arg = wrapSym sym arg' + + -- Performance note: don't be alarmed by the two calls to coercionKind + -- here, as only one call to coercionKind is actually demanded per guard. + -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used + -- when checking if co1' (i.e., co1 post-optimization) is a forall. + -- + -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' + -- might have an extra Sym at the front (after being optimized) that co1 + -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) + Pair t1 t2 = coercionKind sym_arg + Pair t1' t2' = coercionKind arg' + + mk_new_co cv kind_co h1 h2 + = let -- h1 :: (t1 ~ t2) + -- h2 :: (t3 ~ t4) + -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) + -- n1 :: t1 ~ t3 + -- n2 :: t2 ~ t4 + -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) + r2 = coVarRole cv + kind_co' = downgradeRole r2 Nominal kind_co + n1 = mkNthCo r2 2 kind_co' + n2 = mkNthCo r2 3 kind_co' + in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 + (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) + +opt_co4 env sym _rep r (KindCo co) + = ASSERT( r == Nominal ) + let kco' = promoteCoercion co in + case kco' of + KindCo co' -> promoteCoercion (opt_co1 env sym co') + _ -> opt_co4_wrap env sym False Nominal kco' + -- This might be able to be optimized more to do the promotion + -- and substitution/optimization at the same time + +opt_co4 env sym _ r (SubCo co) + = ASSERT( r == Representational ) + opt_co4_wrap env sym True Nominal co + +-- This could perhaps be optimized more. +opt_co4 env sym rep r (AxiomRuleCo co cs) + = ASSERT( r == coaxrRole co ) + wrapRole rep r $ + wrapSym sym $ + AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) + +{- Note [Optimise CoVarCo to Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (c :: t~t) we can optimise it to Refl. That increases the +chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) + +We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] +in GHC.Core.Coercion. +-} + +------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo +opt_phantom env sym co + = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + +{- Note [Differing kinds] + ~~~~~~~~~~~~~~~~~~~~~~ +The two types may not have the same kind (although that would be very unusual). +But even if they have the same kind, and the same type constructor, the number +of arguments in a `CoTyConApp` can differ. Consider + + Any :: forall k. k + + Any * Int :: * + Any (*->*) Maybe Int :: * + +Hence the need to compare argument lengths; see #13658 + -} + +opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role + -> Type -> Type -> Coercion +opt_univ env sym (PhantomProv h) _r ty1 ty2 + | sym = mkPhantomCo h' ty2' ty1' + | otherwise = mkPhantomCo h' ty1' ty2' + where + h' = opt_co4 env sym False Nominal h + ty1' = substTy (lcSubstLeft env) ty1 + ty2' = substTy (lcSubstRight env) ty2 + +opt_univ env sym prov role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + , equalLength tys1 tys2 -- see Note [Differing kinds] + -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); + -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps + = let roles = tyConRolesX role tc1 + arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 + arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos + in + mkTyConAppCo role tc1 arg_cos' + + -- can't optimize the AppTy case because we can't build the kind coercions. + + | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 + , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + eta = mkUnivCo prov' Nominal k1 k2 + -- eta gets opt'ed soon, but not yet. + ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 + + (env', tv1', eta') = optForAllCoBndr env sym tv1 eta + in + mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 + , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = varType cv1 + k2 = varType cv2 + r' = coVarRole cv1 + eta = mkUnivCo prov' Nominal k1 k2 + eta_d = downgradeRole r' Nominal eta + -- eta gets opt'ed soon, but not yet. + n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` + (mkNthCo r' 3 eta_d) + ty2' = substTyWithCoVars [cv2] [n_co] ty2 + + (env', cv1', eta') = optForAllCoBndr env sym cv1 eta + in + mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | otherwise + = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 + ty2 = substTyUnchecked (lcSubstRight env) oty2 + (a, b) | sym = (ty2, ty1) + | otherwise = (ty1, ty2) + in + mkUnivCo prov' role a b + + where + prov' = case prov of + PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco + ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco + PluginProv _ -> prov + CorePrepProv -> prov + +------------- +opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWithEqual "opt_transList" (opt_trans is) + -- The input lists must have identical length. + +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 + | isReflCo co1 = co2 + -- optimize when co1 is a Refl Co + | otherwise = opt_trans1 is co1 co2 + +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 is co1 co2 + | isReflCo co2 = co1 + -- optimize when co2 is a Refl Co + | otherwise = opt_trans2 is co1 co2 + +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 is (TransCo co1a co1b) co2 + -- Don't know whether the sub-coercions are the identity + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mkTransCo co1 co2 + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) + = ASSERT( r1 == r2 ) + fireTransRule "GRefl" in_co1 in_co2 $ + mkGReflRightCo r1 t1 (opt_trans is co1 co2) + +-- Push transitivity through matching destructors +opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) + | d1 == d2 + , coercionRole co1 == coercionRole co2 + , co1 `compatible_co` co2 + = ASSERT( r1 == r2 ) + fireTransRule "PushNth" in_co1 in_co2 $ + mkNthCo r1 d1 (opt_trans is co1 co2) + +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqCoercion` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) + in_co2@(UnivCo p2 r2 _tyl2 tyr2) + | Just prov' <- opt_trans_prov p1 p2 + = ASSERT( r1 == r2 ) + fireTransRule "UnivCo" in_co1 in_co2 $ + mkUnivCo prov' r1 tyl1 tyr2 + where + -- if the provenances are different, opt'ing will be very confusing + opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) + = Just $ PhantomProv $ opt_trans is kco1 kco2 + opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) + = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 + opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 + opt_trans_prov _ _ = Nothing + +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) + | tc1 == tc2 + = ASSERT( r1 == r2 ) + fireTransRule "PushTyConApp" in_co1 in_co2 $ + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) + +opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b) + = ASSERT( r1 == r2) -- Just like the TyConAppCo/TyConAppCo case + fireTransRule "PushFun" in_co1 in_co2 $ + mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + -- Must call opt_trans_rule_app; see Note [EtaAppCo] + = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] + +-- Eta rules +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = fireTransRule "EtaCompL" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = fireTransRule "EtaCompR" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +-- Push transitivity inside forall +-- forall over types. +opt_trans_rule is co1 co2 + | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 + , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 + , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + where + push_trans tv1 eta1 r1 tv2 eta2 r2 + -- Given: + -- co1 = /\ tv1 : eta1. r1 + -- co2 = /\ tv2 : eta2. r2 + -- Wanted: + -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) + = fireTransRule "EtaAllTy_ty" co1 co2 $ + mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` tv1 + r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 + +-- Push transitivity inside forall +-- forall over coercions. +opt_trans_rule is co1 co2 + | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 + , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 + , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + where + push_trans cv1 eta1 r1 cv2 eta2 r2 + -- Given: + -- co1 = /\ cv1 : eta1. r1 + -- co2 = /\ cv2 : eta2. r2 + -- Wanted: + -- n1 = nth 2 eta1 + -- n2 = nth 3 eta1 + -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) + = fireTransRule "EtaAllTy_co" co1 co2 $ + mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` cv1 + role = coVarRole cv1 + eta1' = downgradeRole role Nominal eta1 + n1 = mkNthCo role 2 eta1' + n2 = mkNthCo role 3 eta1' + r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` n2]) + r2 + +-- Push transitivity inside axioms +opt_trans_rule is co1 co2 + + -- See Note [Why call checkAxInstCo during optimisation] + -- TrPushSymAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , True <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst + + -- TrPushAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , False <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxR" co1 co2 newAxInst + + -- TrPushSymAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , True <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst + + -- TrPushAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , False <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxL" co1 co2 newAxInst + + -- TrPushAxSym/TrPushSymAx + | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe + , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe + , con1 == con2 + , ind1 == ind2 + , sym1 == not sym2 + , let branch = coAxiomNthBranch con1 ind1 + qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch + lhs = coAxNthLHS con1 ind1 + rhs = coAxBranchRHS branch + pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if sym2 + -- TrPushAxSym + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs + where + co1_is_axiom_maybe = isAxiom_maybe co1 + co2_is_axiom_maybe = isAxiom_maybe co2 + role = coercionRole co1 -- should be the same as coercionRole co2! + +opt_trans_rule _ co1 co2 -- Identity rule + | let ty1 = coercionLKind co1 + r = coercionRole co1 + ty2 = coercionRKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + mkReflCo r ty2 + +opt_trans_rule _ _ _ = Nothing + +-- See Note [EtaAppCo] +opt_trans_rule_app :: InScopeSet + -> Coercion -- original left-hand coercion (printing only) + -> Coercion -- original right-hand coercion (printing only) + -> Coercion -- left-hand coercion "function" + -> [Coercion] -- left-hand coercion "args" + -> Coercion -- right-hand coercion "function" + -> [Coercion] -- right-hand coercion "args" + -> Maybe Coercion +opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs + | AppCo co1aa co1ab <- co1a + , Just (co2aa, co2ab) <- etaAppCo_maybe co2a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | AppCo co2aa co2ab <- co2a + , Just (co1aa, co1ab) <- etaAppCo_maybe co1a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | otherwise + = ASSERT( co1bs `equalLength` co2bs ) + fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ + let rt1a = coercionRKind co1a + + lt2a = coercionLKind co2a + rt2a = coercionRole co2a + + rt1bs = map coercionRKind co1bs + lt2bs = map coercionLKind co2bs + rt2bs = map coercionRole co2bs + + kcoa = mkKindCo $ buildCoercion lt2a rt1a + kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs + + co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a + co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs + co2bs'' = zipWith mkTransCo co2bs' co2bs + in + mkAppCos (opt_trans is co1a co2a') + (zipWith (opt_trans is) co1bs co2bs'') + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = Just res + +{- +Note [Conflict checking with AxiomInstCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following type family and axiom: + +type family Equal (a :: k) (b :: k) :: Bool +type instance where + Equal a a = True + Equal a b = False +-- +Equal :: forall k::*. k -> k -> Bool +axEqual :: { forall k::*. forall a::k. Equal k a a ~ True + ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } + +We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ +False) and that all is OK. But, all is not OK: we want to use the first branch +of the axiom in this case, not the second. The problem is that the parameters +of the first branch can unify with the supplied coercions, thus meaning that +the first branch should be taken. See also Note [Apartness] in +"GHC.Core.FamInstEnv". + +Note [Why call checkAxInstCo during optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible that otherwise-good-looking optimisations meet with disaster +in the presence of axioms with multiple equations. Consider + +type family Equal (a :: *) (b :: *) :: Bool where + Equal a a = True + Equal a b = False +type family Id (a :: *) :: * where + Id a = a + +axEq :: { [a::*]. Equal a a ~ True + ; [a::*, b::*]. Equal a b ~ False } +axId :: [a::*]. Id a ~ a + +co1 = Equal (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ Equal Int Bool +co2 = axEq[1] + :: Equal Int Bool ~ False + +We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that +co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what +happens when we push the coercions inside? We get + +co3 = axEq[1] (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ False + +which is bogus! This is because the type system isn't smart enough to know +that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type +families. At the time of writing, I (Richard Eisenberg) couldn't think of +a way of detecting this any more efficient than just building the optimised +coercion and checking. + +Note [EtaAppCo] +~~~~~~~~~~~~~~~ +Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd +like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that +the resultant coercions might not be well kinded. Here is an example (things +labeled with x don't matter in this example): + + k1 :: Type + k2 :: Type + + a :: k1 -> Type + b :: k1 + + h :: k1 ~ k2 + + co1a :: x1 ~ (a |> (h -> ) + co1b :: x2 ~ (b |> h) + + co2a :: a ~ x3 + co2b :: b ~ x4 + +First, convince yourself of the following: + + co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) + co2a co2b :: a b ~ x3 x4 + + (a |> (h -> )) (b |> h) `eqType` a b + +That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep, +where we ignore coercions in types as long as two types' kinds are the same. +In our case, we meet this last condition, because + + (a |> (h -> )) (b |> h) :: Type + and + a b :: Type + +So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the +suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the +kinds don't match up. + +The solution here is to twiddle the kinds in the output coercions. First, we +need to find coercions + + ak :: kind(a |> (h -> )) ~ kind(a) + bk :: kind(b |> h) ~ kind(b) + +This can be done with mkKindCo and buildCoercion. The latter assumes two +types are identical modulo casts and builds a coercion between them. + +Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the +output coercions. These are well-kinded. + +Also, note that all of this is done after accumulated any nested AppCo +parameters. This step is to avoid quadratic behavior in calling coercionKind. + +The problem described here was first found in dependent/should_compile/dynamic-paper. + +-} + +-- | Check to make sure that an AxInstCo is internally consistent. +-- Returns the conflicting branch, if it exists +-- See Note [Conflict checking with AxiomInstCo] +checkAxInstCo :: Coercion -> Maybe CoAxBranch +-- defined here to avoid dependencies in GHC.Core.Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +checkAxInstCo (AxiomInstCo ax ind cos) + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map coercionLKind cos) + co_args = map stripCoercionTy cotys + subst = zipTvSubst tvs tys `composeTCvSubst` + zipCvSubst cvs co_args + target = Type.substTys subst (coAxBranchLHS branch) + in_scope = mkInScopeSet $ + unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + flattened_target = flattenTys in_scope target in + check_no_conflict flattened_target incomps + where + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in GHC.Core.FamInstEnv + | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp + = check_no_conflict flat rest + | otherwise + = Just b +checkAxInstCo _ = Nothing + + +----------- +wrapSym :: SymFlag -> Coercion -> Coercion +wrapSym sym co | sym = mkSymCo co + | otherwise = co + +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role + -> Coercion -> Coercion +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r + +----------- +isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) +isAxiom_maybe (SymCo co) + | Just (sym, con, ind, cos) <- isAxiom_maybe co + = Just (not sym, con, ind, cos) +isAxiom_maybe (AxiomInstCo con ind cos) + = Just (False, con, ind, cos) +isAxiom_maybe _ = Nothing + +matchAxiom :: Bool -- True = match LHS, False = match RHS + -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] +matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co + | CoAxBranch { cab_tvs = qtvs + , cab_cvs = [] -- can't infer these, so fail if there are any + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , Just subst <- liftCoMatch (mkVarSet qtvs) + (if sym then (mkTyConApp tc lhs) else rhs) + co + , all (`isMappedByLC` subst) qtvs + = zipWithM (liftCoSubstTyVar subst) roles qtvs + + | otherwise + = Nothing + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + x1 = coercionRKind co1 + x2 = coercionLKind co2 + +------------- +{- +etaForAllCo +~~~~~~~~~~~~~~~~~ +(1) etaForAllCo_ty_maybe +Suppose we have + + g : all a1:k1.t1 ~ all a2:k2.t2 + +but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: + + g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h1)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. + +(2) etaForAllCo_co_maybe +Suppose we have + + g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 + +Similarly, we do this + + g' = all c1:h1. h2 + : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] + [c1 |-> eta1;c1;sym eta2] + +Here, + + h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) + eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) + h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) +-} +etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall tv:kind_co. co) +etaForAllCo_ty_maybe co + | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co + = Just (tv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 + , isForAllTy_ty ty2 + , let kind_co = mkNthCo Nominal 0 co + = Just ( tv1, kind_co + , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) + + | otherwise + = Nothing + +etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall cv:kind_co. co) +etaForAllCo_co_maybe co + | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (cv1, _) <- splitForAllTy_co_maybe ty1 + , isForAllTy_co ty2 + = let kind_co = mkNthCo Nominal 0 co + r = coVarRole cv1 + l_co = mkCoVarCo cv1 + kind_co' = downgradeRole r Nominal kind_co + r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` + l_co `mkTransCo` + (mkNthCo r 3 kind_co') + in Just ( cv1, kind_co + , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) + + | otherwise + = Nothing + +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | (Pair ty1 ty2, Nominal) <- coercionKindRole co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) + = ASSERT( tc == tc2 ) Just cos2 + +etaTyConAppCo_maybe tc co + | not (mustBeSaturated tc) + , (Pair ty1 ty2, r) <- coercionKindRole co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep + , let n = length tys1 + , tys2 `lengthIs` n -- This can fail in an erroneous program + -- E.g. T a ~# T a b + -- #14607 + = ASSERT( tc == tc1 ) + Just (decomposeCo n co (tyConRolesX r tc1)) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing + +{- +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +because it's possible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + +-} + +optForAllCoBndr :: LiftingContext -> Bool + -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) +optForAllCoBndr env sym + = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/GHC/Core/ConLike.hs b/GHC/Core/ConLike.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/ConLike.hs @@ -0,0 +1,210 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[ConLike]{@ConLike@: Constructor-like things} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.ConLike ( + ConLike(..) + , conLikeArity + , conLikeFieldLabels + , conLikeInstOrigArgTys + , conLikeUserTyVarBinders + , conLikeExTyCoVars + , conLikeName + , conLikeStupidTheta + , conLikeWrapId_maybe + , conLikeImplBangs + , conLikeFullSig + , conLikeResTy + , conLikeFieldType + , conLikesWithFields + , conLikeIsInfix + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Core.TyCo.Rep (Type, ThetaType) +import GHC.Types.Var +import GHC.Core.Type(mkTyConApp) +import GHC.Core.Multiplicity + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection{Constructor-like things} +* * +************************************************************************ +-} + +-- | A constructor-like thing +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq ConLike where + (==) = eqConLike + +eqConLike :: ConLike -> ConLike -> Bool +eqConLike x y = getUnique x == getUnique y + +-- There used to be an Ord ConLike instance here that used Unique for ordering. +-- It was intentionally removed to prevent determinism problems. +-- See Note [Unique Determinism] in GHC.Types.Unique. + +instance Uniquable ConLike where + getUnique (RealDataCon dc) = getUnique dc + getUnique (PatSynCon ps) = getUnique ps + +instance NamedThing ConLike where + getName (RealDataCon dc) = getName dc + getName (PatSynCon ps) = getName ps + +instance Outputable ConLike where + ppr (RealDataCon dc) = ppr dc + ppr (PatSynCon ps) = ppr ps + +instance OutputableBndr ConLike where + pprInfixOcc (RealDataCon dc) = pprInfixOcc dc + pprInfixOcc (PatSynCon ps) = pprInfixOcc ps + pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc + pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps + +instance Data.Data ConLike where + -- don't traverse? + toConstr _ = abstractConstr "ConLike" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ConLike" + +-- | Number of arguments +conLikeArity :: ConLike -> Arity +conLikeArity (RealDataCon data_con) = dataConSourceArity data_con +conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn + +-- | Names of fields used for selectors +conLikeFieldLabels :: ConLike -> [FieldLabel] +conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con +conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn + +-- | Returns just the instantiated /value/ argument types of a 'ConLike', +-- (excluding dictionary args) +conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type] +conLikeInstOrigArgTys (RealDataCon data_con) tys = + dataConInstOrigArgTys data_con tys +conLikeInstOrigArgTys (PatSynCon pat_syn) tys = + map unrestricted $ patSynInstArgTys pat_syn tys + +-- | 'TyVarBinder's for the type variables of the 'ConLike'. For pattern +-- synonyms, this will always consist of the universally quantified variables +-- followed by the existentially quantified type variables. For data +-- constructors, the situation is slightly more complicated—see +-- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon". +conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder] +conLikeUserTyVarBinders (RealDataCon data_con) = + dataConUserTyVarBinders data_con +conLikeUserTyVarBinders (PatSynCon pat_syn) = + patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn + -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`. + +-- | Existentially quantified type/coercion variables +conLikeExTyCoVars :: ConLike -> [TyCoVar] +conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 +conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 + +conLikeName :: ConLike -> Name +conLikeName (RealDataCon data_con) = dataConName data_con +conLikeName (PatSynCon pat_syn) = patSynName pat_syn + +-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +-- It is empty for `PatSynCon` as they do not allow such contexts. +conLikeStupidTheta :: ConLike -> ThetaType +conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con +conLikeStupidTheta (PatSynCon {}) = [] + +-- | Returns the `Id` of the wrapper. This is also known as the builder in +-- some contexts. The value is Nothing only in the case of unidirectional +-- pattern synonyms. +conLikeWrapId_maybe :: ConLike -> Maybe Id +conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con +conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn + +-- | Returns the strictness information for each constructor +conLikeImplBangs :: ConLike -> [HsImplBang] +conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con +conLikeImplBangs (PatSynCon pat_syn) = + replicate (patSynArity pat_syn) HsLazy + +-- | Returns the type of the whole pattern +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + +-- | The \"full signature\" of the 'ConLike' returns, in order: +-- +-- 1) The universally quantified type variables +-- +-- 2) The existentially quantified type/coercion variables +-- +-- 3) The equality specification +-- +-- 4) The provided theta (the constraints provided by a match) +-- +-- 5) The required theta (the constraints required for a match) +-- +-- 6) The original argument types (i.e. before +-- any change of the representation of the type) +-- +-- 7) The original result type +conLikeFullSig :: ConLike + -> ([TyVar], [TyCoVar], [EqSpec] + -- Why tyvars for universal but tycovars for existential? + -- See Note [Existential coercion variables] in GHC.Core.DataCon + , ThetaType, ThetaType, [Scaled Type], Type) +conLikeFullSig (RealDataCon con) = + let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con + -- Required theta is empty as normal data cons require no additional + -- constraints for a match + in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) +conLikeFullSig (PatSynCon pat_syn) = + let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn + -- eqSpec is empty + in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) + +-- | Extract the type for any given labelled field of the 'ConLike' +conLikeFieldType :: ConLike -> FieldLabelString -> Type +conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label +conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label + + +-- | The ConLikes that have *all* the given fields +conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] +conLikesWithFields con_likes lbls = filter has_flds con_likes + where has_flds dc = all (has_fld dc) lbls + has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) + +conLikeIsInfix :: ConLike -> Bool +conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc +conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/GHC/Core/ConLike.hs-boot b/GHC/Core/ConLike.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/ConLike.hs-boot @@ -0,0 +1,9 @@ +module GHC.Core.ConLike where +import {-# SOURCE #-} GHC.Core.DataCon (DataCon) +import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn) +import GHC.Types.Name ( Name ) + +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +conLikeName :: ConLike -> Name diff --git a/GHC/Core/DataCon.hs b/GHC/Core/DataCon.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/DataCon.hs @@ -0,0 +1,1582 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[DataCon]{@DataCon@: Data Constructors} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module GHC.Core.DataCon ( + -- * Main data types + DataCon, DataConRep(..), + SrcStrictness(..), SrcUnpackedness(..), + HsSrcBang(..), HsImplBang(..), + StrictnessMark(..), + ConTag, + + -- ** Equality specs + EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, + eqSpecPair, eqSpecPreds, + substEqSpec, filterEqSpec, + + -- ** Field labels + FieldLbl(..), FieldLabel, FieldLabelString, + + -- ** Type construction + mkDataCon, fIRST_TAG, + + -- ** Type deconstruction + dataConRepType, dataConInstSig, dataConFullSig, + dataConName, dataConIdentity, dataConTag, dataConTagZ, + dataConTyCon, dataConOrigTyCon, + dataConWrapperType, + dataConNonlinearType, + dataConDisplayType, + dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, + dataConUserTyVars, dataConUserTyVarBinders, + dataConEqSpec, dataConTheta, + dataConStupidTheta, + dataConOtherTheta, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, + dataConInstOrigArgTys, dataConRepArgTys, + dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, + dataConSrcBangs, + dataConSourceArity, dataConRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConImplicitTyThings, + dataConRepStrictness, dataConImplBangs, dataConBoxer, + + splitDataProductType_maybe, + + -- ** Predicates on DataCons + isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, + isUnboxedSumCon, + isVanillaDataCon, classDataCon, dataConCannotMatch, + dataConUserTyVarsArePermuted, + isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, + specialPromotedDc, + + -- ** Promotion related functions + promoteDataCon + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) +import GHC.Core.Type as Type +import GHC.Core.Coercion +import GHC.Core.Unify +import GHC.Core.TyCon +import GHC.Core.Multiplicity +import GHC.Types.FieldLabel +import GHC.Core.Class +import GHC.Types.Name +import GHC.Builtin.Names +import GHC.Core.Predicate +import GHC.Types.Var +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Unit +import GHC.Utils.Binary +import GHC.Types.Unique.Set +import GHC.Types.Unique( mkAlphaTyVarUnique ) + +import GHC.Driver.Session +import GHC.LanguageExtensions as LangExt + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Data as Data +import Data.Char +import Data.List( find ) + +{- +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly up to four, Names associated with it: + + OccName Name space Name of Notes + --------------------------------------------------------------------------- + The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) + The "worker data con" C VarName Id The worker + The "wrapper data con" $WC VarName Id The wrapper + The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + +The "worker Id", is the actual data constructor. +* Every data constructor (newtype or data type) has a worker + +* The worker is very like a primop, in that it has no binding. + +* For a *data* type, the worker *is* the data constructor; + it has no unfolding + +* For a *newtype*, the worker has a compulsory unfolding which + does a cast, e.g. + newtype T = MkT Int + The worker for MkT has unfolding + \\(x:Int). x `cast` sym CoT + Here CoT is the type constructor, witnessing the FC axiom + axiom CoT : T = Int + +The "wrapper Id", \$WC, goes as follows + +* Its type is exactly what it looks like in the source program. + +* It is an ordinary function, and it gets a top-level binding + like any other function. + +* The wrapper Id isn't generated for a data type if there is + nothing for the wrapper to do. That is, if its defn would be + \$wC = C + +Note [Data constructor workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Algebraic data types + - Always have a worker, with no unfolding + - May or may not have a wrapper; see Note [The need for a wrapper] + +* Newtypes + - Always have a worker, which has a compulsory unfolding (just a cast) + - May or may not have a wrapper; see Note [The need for a wrapper] + +* INVARIANT: the dictionary constructor for a class + never has a wrapper. + +* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments + +* The wrapper (if it exists) takes dcOrigArgTys as its arguments. + The worker takes dataConRepArgTys as its arguments + If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys + +* The 'NoDataConRep' case of DataConRep is important. Not only is it + efficient, but it also ensures that the wrapper is replaced by the + worker (because it *is* the worker) even when there are no + args. E.g. in + f (:) x + the (:) *is* the worker. This is really important in rule matching, + (We could match on the wrappers, but that makes it less likely that + rules will match when we bring bits of unfoldings together.) + +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why might the wrapper have anything to do? The full story is +in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep. + +* Unboxing strict fields (with -funbox-strict-fields) + data T = MkT !(Int,Int) + \$wMkT :: (Int,Int) -> T + \$wMkT (x,y) = MkT x y + Notice that the worker has two fields where the wapper has + just one. That is, the worker has type + MkT :: Int -> Int -> T + +* Equality constraints for GADTs + data T a where { MkT :: a -> T [a] } + + The worker gets a type with explicit equality + constraints, thus: + MkT :: forall a b. (a=[b]) => b -> T a + + The wrapper has the programmer-specified type: + \$wMkT :: a -> T [a] + \$wMkT a x = MkT [a] a [a] x + The third argument is a coercion + [a] :: [a]~[a] + +* Data family instances may do a cast on the result + +* Type variables may be permuted; see MkId + Note [Data con wrappers and GADT syntax] + + +Note [The stupid context] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Data types can have a context: + + data (Eq a, Ord b) => T a b = T1 a b | T2 a + +and that makes the constructors have a context too +(notice that T2's context is "thinned"): + + T1 :: (Eq a, Ord b) => a -> b -> T a b + T2 :: (Eq a) => a -> T a b + +Furthermore, this context pops up when pattern matching +(though GHC hasn't implemented this, but it is in H98, and +I've fixed GHC so that it now does): + + f (T2 x) = x +gets inferred type + f :: Eq a => T a b -> a + +I say the context is "stupid" because the dictionaries passed +are immediately discarded -- they do nothing and have no benefit. +It's a flaw in the language. + + Up to now [March 2002] I have put this stupid context into the + type of the "wrapper" constructors functions, T1 and T2, but + that turned out to be jolly inconvenient for generics, and + record update, and other functions that build values of type T + (because they don't have suitable dictionaries available). + + So now I've taken the stupid context out. I simply deal with + it separately in the type checker on occurrences of a + constructor, either in an expression or in a pattern. + + [May 2003: actually I think this decision could easily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] + +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q + +Note that (Foo a) might not be an instance of Ord. + +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ +-} + +-- | A data constructor +-- +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', +-- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma' + +-- For details on above see note [Api annotations] in GHC.Parser.Annotation +data DataCon + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name + dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's + + -- Running example: + -- + -- *** As declared by the user + -- data T a b c where + -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c + + -- *** As represented internally + -- data T a b c where + -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) + -- => x -> y -> T a b c + -- + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcUnivTyVars = [a,b,c] + -- dcExTyCoVars = [x,y] + -- dcUserTyVarBinders = [c,y,x,b] + -- dcEqSpec = [a~(x,y)] + -- dcOtherTheta = [x~y, Ord x] + -- dcOrigArgTys = [x,y] + -- dcRepTyCon = T + + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE + -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, + -- vanilla datacons guaranteed to have the same type variables as their + -- parent TyCon, but that seems ugly.) They can be different in the case + -- where a GADT constructor uses different names for the universal + -- tyvars than does the tycon. For example: + -- + -- data H a where + -- MkH :: b -> H b + -- + -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH + -- will be [b]. + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no coercions, nothing. + -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] + -- NB 1: newtypes always have a vanilla data con + -- NB 2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + -- The declaration format is held in the TyCon (algTcGadtSyntax) + + -- Universally-quantified type vars [a,b,c] + -- INVARIANT: length matches arity of the dcRepTyCon + -- INVARIANT: result type of data con worker is exactly (T a b c) + -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with + -- the tyConTyVars of the parent TyCon + dcUnivTyVars :: [TyVar], + + -- Existentially-quantified type and coercion vars [x,y] + -- For an example involving coercion variables, + -- Why tycovars? See Note [Existential coercion variables] + dcExTyCoVars :: [TyCoVar], + + -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames + -- Reason: less confusing, and easier to generate Iface syntax + + -- The type/coercion vars in the order the user wrote them [c,y,x,b] + -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set + -- of tyvars (*not* covars) of dcExTyCoVars unioned with the + -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec + -- See Note [DataCon user type variable binders] + dcUserTyVarBinders :: [InvisTVBinder], + + dcEqSpec :: [EqSpec], -- Equalities derived from the result type, + -- _as written by the programmer_. + -- Only non-dependent GADT equalities (dependent + -- GADT equalities are in the covars of + -- dcExTyCoVars). + + -- This field allows us to move conveniently between the two ways + -- of representing a GADT constructor's type: + -- MkT :: forall a b. (a ~ [b]) => b -> T a + -- MkT :: forall b. b -> T [b] + -- Each equality is of the form (a ~ ty), where 'a' is one of + -- the universally quantified type variables. Moreover, the + -- only place in the DataCon where this 'a' will occur is in + -- dcUnivTyVars. See [The dcEqSpec domain invariant]. + + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) + -- In GADT form, this is *exactly* what the programmer writes, even if + -- the context constrains only universally quantified variables + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- other than those in the dcEqSpec + + dcStupidTheta :: ThetaType, -- The context of the data type declaration + -- data Eq a => T a = ... + -- or, rather, a "thinned" version thereof + -- "Thinned", because the Report says + -- to eliminate any constraints that don't mention + -- tyvars free in the arg types for this constructor + -- + -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars + -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon + -- + -- "Stupid", because the dictionaries aren't used for anything. + -- Indeed, [as of March 02] they are no longer in the type of + -- the wrapper Id, because that makes it harder to use the wrap-id + -- to rebuild values after record selection or in generics. + + dcOrigArgTys :: [Scaled Type], -- Original argument types + -- (before unboxing and flattening of strict fields) + dcOrigResTy :: Type, -- Original result type, as seen by the user + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The dcOrigResTy is T [a], but the dcRepTyCon might be R:TList + + -- Now the strictness annotations and field labels of the constructor + dcSrcBangs :: [HsSrcBang], + -- See Note [Bangs on data constructor arguments] + -- + -- The [HsSrcBang] as written by the programmer. + -- + -- Matches 1-1 with dcOrigArgTys + -- Hence length = dataConSourceArity dataCon + + dcFields :: [FieldLabel], + -- Field labels for this constructor, in the + -- same order as the dcOrigArgTys; + -- length = 0 (if not a record) or dataConSourceArity. + + -- The curried worker function that corresponds to the constructor: + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + dcWorkId :: Id, + + -- Constructor representation + dcRep :: DataConRep, + + -- Cached; see Note [DataCon arities] + -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) + -- INVARIANT: dcSourceArity == length dcOrigArgTys + dcRepArity :: Arity, + dcSourceArity :: Arity, + + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + + dcRepType :: Type, -- Type of the constructor + -- forall a x y. (a~(x,y), x~y, Ord x) => + -- x -> y -> T a + -- (this is *not* of the constructor wrapper Id: + -- see Note [Data con representation] below) + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t + -- and use that to check the pattern. Mind you, this is really only + -- used in GHC.Core.Lint. + + + dcInfix :: Bool, -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere + + dcPromoted :: TyCon -- The promoted TyCon + -- See Note [Promoted data constructors] in GHC.Core.TyCon + } + + +{- Note [TyVarBinders in DataCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the TyVarBinders in a DataCon and PatSyn: + + * Each argument flag is Inferred or Specified. + None are Required. (A DataCon is a term-level function; see + Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.) + +Why do we need the TyVarBinders, rather than just the TyVars? So that +we can construct the right type for the DataCon with its foralls +attributed the correct visibility. That in turn governs whether you +can use visible type application at a call of the data constructor. + +See also [DataCon user type variable binders] for an extended discussion on the +order in which TyVarBinders appear in a DataCon. + +Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For now (Aug 2018) we can't write coercion quantifications in source Haskell, but +we can in Core. Consider having: + + data T :: forall k. k -> k -> Constraint where + MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) + => T k a b + + dcUnivTyVars = [k,a,b] + dcExTyCoVars = [k',c,co] + dcUserTyVarBinders = [k,a,k',c] + dcEqSpec = [b~(c|>co)] + dcOtherTheta = [] + dcOrigArgTys = [] + dcRepTyCon = T + + Function call 'dataConKindEqSpec' returns [k'~k] + +Note [DataCon arities] +~~~~~~~~~~~~~~~~~~~~~~ +dcSourceArity does not take constraints into account, +but dcRepArity does. For example: + MkT :: Ord a => a -> T a + dcSourceArity = 1 + dcRepArity = 2 + +Note [DataCon user type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In System FC, data constructor type signatures always quantify over all of +their universal type variables, followed by their existential type variables. +Normally, this isn't a problem, as most datatypes naturally quantify their type +variables in this order anyway. For example: + + data T a b = forall c. MkT b c + +Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, +where k, a, and b are universal and c is existential. (The inferred variable k +isn't available for TypeApplications, hence why it's in braces.) This is a +perfectly reasonable order to use, as the syntax of H98-style datatypes +(+ ExistentialQuantification) suggests it. + +Things become more complicated when GADT syntax enters the picture. Consider +this example: + + data X a where + MkX :: forall b a. b -> Proxy a -> X a + +If we adopt the earlier approach of quantifying all the universal variables +followed by all the existential ones, GHC would come up with this type +signature for MkX: + + MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a + +But this is not what we want at all! After all, if a user were to use +TypeApplications on MkX, they would expect to instantiate `b` before `a`, +as that's the order in which they were written in the `forall`. (See #11721.) +Instead, we'd like GHC to come up with this type signature: + + MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a + +In fact, even if we left off the explicit forall: + + data X a where + MkX :: b -> Proxy a -> X a + +Then a user should still expect `b` to be quantified before `a`, since +according to the rules of TypeApplications, in the absence of `forall` GHC +performs a stable topological sort on the type variables in the user-written +type signature, which would place `b` before `a`. + +But as noted above, enacting this behavior is not entirely trivial, as System +FC demands the variables go in universal-then-existential order under the hood. +Our solution is thus to equip DataCon with two different sets of type +variables: + +* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential + type/coercion variables, respectively. Their order is irrelevant for the + purposes of TypeApplications, and as a consequence, they do not come equipped + with visibilities (that is, they are TyVars/TyCoVars instead of + TyCoVarBinders). + +* dcUserTyVarBinders, for the type variables binders in the order in which they + originally arose in the user-written type signature. Their order *does* matter + for TypeApplications, so they are full TyVarBinders, complete with + visibilities. + +This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders +consists precisely of: + +* The set of tyvars in dcUnivTyVars whose type variables do not appear in + dcEqSpec, unioned with: +* The set of tyvars (*not* covars) in dcExTyCoVars + No covars here because because they're not user-written + +The word "set" is used above because the order in which the tyvars appear in +dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or +dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of +(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the +ordering, they in fact share the same type variables (with the same Uniques). We +sometimes refer to this as "the dcUserTyVarBinders invariant". + +dcUserTyVarBinders, as the name suggests, is the one that users will +see most of the time. It's used when computing the type signature of a +data constructor wrapper (see dataConWrapperType), and as a result, +it's what matters from a TypeApplications perspective. + +Note [The dcEqSpec domain invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example of a GADT constructor: + + data Y a where + MkY :: Bool -> Y Bool + +The user-written type of MkY is `Bool -> Y Bool`, but what is the underlying +Core type for MkY? There are two conceivable possibilities: + +1. MkY :: forall a. (a ~# Bool) => Bool -> Y a +2. MkY :: forall a. (a ~# Bool) => a -> Y a + +In practice, GHC picks (1) as the Core type for MkY. This is because we +maintain an invariant that the type variables in the domain of dcEqSpec will +only ever appear in the dcUnivTyVars. As a consequence, the type variables in +the domain of dcEqSpec will /never/ appear in the dcExTyCoVars, dcOtherTheta, +dcOrigArgTys, or dcOrigResTy; these can only ever mention variables from +dcUserTyVarBinders, which excludes things in the domain of dcEqSpec. +(See Note [DataCon user type variable binders].) This explains why GHC would +not pick (2) as the Core type, since the argument type `a` mentions a type +variable in the dcEqSpec. + +There are certain parts of the codebase where it is convenient to apply the +substitution arising from the dcEqSpec to the dcUnivTyVars in order to obtain +the user-written return type of a GADT constructor. A consequence of the +dcEqSpec domain invariant is that you /never/ need to apply the substitution +to any other part of the constructor type, as they don't require it. +-} + +-- | Data Constructor Representation +-- See Note [Data constructor workers and wrappers] +data DataConRep + = -- NoDataConRep means that the data con has no wrapper + NoDataConRep + + -- DCR means that the data con has a wrapper + | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, + -- and constructs the representation + + , dcr_boxer :: DataConBoxer + + , dcr_arg_tys :: [Scaled Type] -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all evidence args + + , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys + -- See also Note [Data-con worker strictness] + + , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + } + +------------------------- + +-- | Haskell Source Bang +-- +-- Bangs on data constructor arguments as the user wrote them in the +-- source code. +-- +-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and +-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we +-- emit a warning (in checkValidDataCon) and treat it like +-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ +data HsSrcBang = + HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.Basic + SrcUnpackedness + SrcStrictness + deriving Data.Data + +-- | Haskell Implementation Bang +-- +-- Bangs of data constructor arguments as generated by the compiler +-- after consulting HsSrcBang, flags, etc. +data HsImplBang + = HsLazy -- ^ Lazy field, or one with an unlifted type + | HsStrict -- ^ Strict but not unpacked field + | HsUnpack (Maybe Coercion) + -- ^ Strict and unpacked field + -- co :: arg-ty ~ product-ty HsBang + deriving Data.Data + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data.Data) + +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data.Data) + + + +------------------------- +-- StrictnessMark is internal only, used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict + +-- | An 'EqSpec' is a tyvar/type pair representing an equality made in +-- rejigging a GADT constructor +data EqSpec = EqSpec TyVar + Type + +-- | Make a non-dependent 'EqSpec' +mkEqSpec :: TyVar -> Type -> EqSpec +mkEqSpec tv ty = EqSpec tv ty + +eqSpecTyVar :: EqSpec -> TyVar +eqSpecTyVar (EqSpec tv _) = tv + +eqSpecType :: EqSpec -> Type +eqSpecType (EqSpec _ ty) = ty + +eqSpecPair :: EqSpec -> (TyVar, Type) +eqSpecPair (EqSpec tv ty) = (tv, ty) + +eqSpecPreds :: [EqSpec] -> ThetaType +eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty + | EqSpec tv ty <- spec ] + +-- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec +-- is mapped in the substitution, it is mapped to a type variable, not +-- a full type. +substEqSpec :: TCvSubst -> EqSpec -> EqSpec +substEqSpec subst (EqSpec tv ty) + = EqSpec tv' (substTy subst ty) + where + tv' = getTyVar "substEqSpec" (substTyVar subst tv) + +-- | Filter out any 'TyVar's mentioned in an 'EqSpec'. +filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] +filterEqSpec eq_spec + = filter not_in_eq_spec + where + not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec + +instance Outputable EqSpec where + ppr (EqSpec tv ty) = ppr (tv, ty) + +{- Note [Data-con worker strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we do *not* say the worker Id is strict even if the data +constructor is declared strict + e.g. data T = MkT !(Int,Int) +Why? Because the *wrapper* $WMkT is strict (and its unfolding has case +expressions that do the evals) but the *worker* MkT itself is not. If we +pretend it is strict then when we see + case x of y -> MkT y +the simplifier thinks that y is "sure to be evaluated" (because the worker MkT +is strict) and drops the case. No, the workerId MkT is not strict. + +However, the worker does have StrictnessMarks. When the simplifier sees a +pattern + case e of MkT x -> ... +it uses the dataConRepStrictness of MkT to mark x as evaluated; but that's +fine... dataConRepStrictness comes from the data con not from the worker Id. + +Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int {-# UNPACK #-} !Int Bool + +When compiling the module, GHC will decide how to represent +MkT, depending on the optimisation level, and settings of +flags like -funbox-small-strict-fields. + +Terminology: + * HsSrcBang: What the user wrote + Constructors: HsSrcBang + + * HsImplBang: What GHC decided + Constructors: HsLazy, HsStrict, HsUnpack + +* If T was defined in this module, MkT's dcSrcBangs field + records the [HsSrcBang] of what the user wrote; in the example + [ HsSrcBang _ NoSrcUnpack SrcStrict + , HsSrcBang _ SrcUnpack SrcStrict + , HsSrcBang _ NoSrcUnpack NoSrcStrictness] + +* However, if T was defined in an imported module, the importing module + must follow the decisions made in the original module, regardless of + the flag settings in the importing module. + Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make + +* The dcr_bangs field of the dcRep field records the [HsImplBang] + If T was defined in this module, Without -O the dcr_bangs might be + [HsStrict, HsStrict, HsLazy] + With -O it might be + [HsStrict, HsUnpack _, HsLazy] + With -funbox-small-strict-fields it might be + [HsUnpack, HsUnpack _, HsLazy] + With -XStrictData it might be + [HsStrict, HsUnpack _, HsStrict] + +Note [Data con representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The dcRepType field contains the type of the representation of a constructor +This may differ from the type of the constructor *Id* (built +by MkId.mkDataConId) for two reasons: + a) the constructor Id may be overloaded, but the dictionary isn't stored + e.g. data Eq a => T a = MkT a a + + b) the constructor may store an unboxed version of a strict field. + +Here's an example illustrating both: + data Ord a => T a = MkT Int! a +Here + T :: Ord a => Int -> a -> T a +but the rep type is + Trep :: Int# -> a -> T a +Actually, the unboxed part isn't implemented yet! + + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq DataCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable DataCon where + getUnique = dcUnique + +instance NamedThing DataCon where + getName = dcName + +instance Outputable DataCon where + ppr con = ppr (dataConName con) + +instance OutputableBndr DataCon where + pprInfixOcc con = pprInfixName (dataConName con) + pprPrefixOcc con = pprPrefixName (dataConName con) + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" + +instance Outputable HsSrcBang where + ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark + +instance Outputable HsImplBang where + ppr HsLazy = text "Lazy" + ppr (HsUnpack Nothing) = text "Unpacked" + ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) + ppr HsStrict = text "StrictNotUnpacked" + +instance Outputable SrcStrictness where + ppr SrcLazy = char '~' + ppr SrcStrict = char '!' + ppr NoSrcStrict = empty + +instance Outputable SrcUnpackedness where + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" + ppr NoSrcUnpack = empty + +instance Outputable StrictnessMark where + ppr MarkedStrict = text "!" + ppr NotMarkedStrict = empty + +instance Binary SrcStrictness where + put_ bh SrcLazy = putByte bh 0 + put_ bh SrcStrict = putByte bh 1 + put_ bh NoSrcStrict = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcLazy + 1 -> return SrcStrict + _ -> return NoSrcStrict + +instance Binary SrcUnpackedness where + put_ bh SrcNoUnpack = putByte bh 0 + put_ bh SrcUnpack = putByte bh 1 + put_ bh NoSrcUnpack = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcNoUnpack + 1 -> return SrcUnpack + _ -> return NoSrcUnpack + +-- | Compare strictness annotations +eqHsBang :: HsImplBang -> HsImplBang -> Bool +eqHsBang HsLazy HsLazy = True +eqHsBang HsStrict HsStrict = True +eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True +eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) + = eqType (coercionType c1) (coercionType c2) +eqHsBang _ _ = False + +isBanged :: HsImplBang -> Bool +isBanged (HsUnpack {}) = True +isBanged (HsStrict {}) = True +isBanged HsLazy = False + +isSrcStrict :: SrcStrictness -> Bool +isSrcStrict SrcStrict = True +isSrcStrict _ = False + +isSrcUnpacked :: SrcUnpackedness -> Bool +isSrcUnpacked SrcUnpack = True +isSrcUnpacked _ = False + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict + +{- ********************************************************************* +* * +\subsection{Construction} +* * +********************************************************************* -} + +-- | Build a new data constructor +mkDataCon :: Name + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> [InvisTVBinder] -- ^ User-written 'TyVarBinder's. + -- These must be Inferred/Specified. + -- See @Note [TyVarBinders in DataCons]@ + -> [EqSpec] -- ^ GADT equalities + -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper + -> [KnotTied (Scaled Type)] -- ^ Original argument types + -> KnotTied Type -- ^ Original result type + -> RuntimeRepInfo -- ^ See comments on 'GHC.Core.TyCon.RuntimeRepInfo' + -> KnotTied TyCon -- ^ Representation type constructor + -> ConTag -- ^ Constructor tag + -> ThetaType -- ^ The "stupid theta", context of the data + -- declaration e.g. @data Eq a => T a ...@ + -> Id -- ^ Worker Id + -> DataConRep -- ^ Representation + -> DataCon + -- Can get the tag from the TyCon + +mkDataCon name declared_infix prom_info + arg_stricts -- Must match orig_arg_tys 1-1 + fields + univ_tvs ex_tvs user_tvbs + eq_spec theta + orig_arg_tys orig_res_ty rep_info rep_tycon tag + stupid_theta work_id rep +-- Warning: mkDataCon is not a good place to check certain invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that assertions here +-- are a little dodgy. + + = con + where + is_vanilla = null ex_tvs && null eq_spec && null theta + + con = MkData {dcName = name, dcUnique = nameUnique name, + dcVanilla = is_vanilla, dcInfix = declared_infix, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs, + dcUserTyVarBinders = user_tvbs, + dcEqSpec = eq_spec, + dcOtherTheta = theta, + dcStupidTheta = stupid_theta, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = rep_tycon, + dcSrcBangs = arg_stricts, + dcFields = fields, dcTag = tag, dcRepType = rep_ty, + dcWorkId = work_id, + dcRep = rep, + dcSourceArity = length orig_arg_tys, + dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, + dcPromoted = promoted } + + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + + rep_arg_tys = dataConRepArgTys con + + rep_ty = + case rep of + -- If the DataCon has no wrapper, then the worker's type *is* the + -- user-facing type, so we can simply use dataConWrapperType. + NoDataConRep -> dataConWrapperType con + -- If the DataCon has a wrapper, then the worker's type is never seen + -- by the user. The visibilities we pick do not matter here. + DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ + mkVisFunTys rep_arg_tys $ + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + + -- See Note [Promoted data constructors] in GHC.Core.TyCon + prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv + | Bndr tv spec <- user_tvbs ] + + fresh_names = freshNames (map getName user_tvbs) + -- fresh_names: make sure that the "anonymous" tyvars don't + -- clash in name or unique with the universal/existential ones. + -- Tiresome! And unnecessary because these tyvars are never looked at + prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) + {- Invisible -} | (n,t) <- fresh_names `zip` theta ] + prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) + {- Visible -} | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ] + prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs + prom_res_kind = orig_res_ty + promoted = mkPromotedDataCon con name prom_info prom_bndrs + prom_res_kind roles rep_info + + roles = map (\tv -> if isTyVar tv then Nominal else Phantom) + (univ_tvs ++ ex_tvs) + ++ map (const Representational) (theta ++ map scaledThing orig_arg_tys) + +freshNames :: [Name] -> [Name] +-- Make an infinite list of Names whose Uniques and OccNames +-- differ from those in the 'avoid' list +freshNames avoids + = [ mkSystemName uniq occ + | n <- [0..] + , let uniq = mkAlphaTyVarUnique n + occ = mkTyVarOccFS (mkFastString ('x' : show n)) + + , not (uniq `elementOfUniqSet` avoid_uniqs) + , not (occ `elemOccSet` avoid_occs) ] + + where + avoid_uniqs :: UniqSet Unique + avoid_uniqs = mkUniqSet (map getUnique avoids) + + avoid_occs :: OccSet + avoid_occs = mkOccSet (map getOccName avoids) + +-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification +dataConName :: DataCon -> Name +dataConName = dcName + +-- | The tag used for ordering 'DataCon's +dataConTag :: DataCon -> ConTag +dataConTag = dcTag + +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + +-- | The type constructor that we are building via this data constructor +dataConTyCon :: DataCon -> TyCon +dataConTyCon = dcRepTyCon + +-- | The original type constructor used in the definition of this data +-- constructor. In case of a data family instance, that will be the family +-- type constructor. +dataConOrigTyCon :: DataCon -> TyCon +dataConOrigTyCon dc + | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc + | otherwise = dcRepTyCon dc + +-- | The representation type of the data constructor, i.e. the sort +-- type that will represent values of this type at runtime +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +-- | Should the 'DataCon' be presented infix? +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +-- | The universally-quantified type variables of the constructor +dataConUnivTyVars :: DataCon -> [TyVar] +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs + +-- | The existentially-quantified type/coercion variables of the constructor +-- including dependent (kind-) GADT equalities +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs + +-- | Both the universal and existential type/coercion variables of the constructor +dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] +dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) + = univ_tvs ++ ex_tvs + +-- See Note [DataCon user type variable binders] +-- | The type variables of the constructor, in the order the user wrote them +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs + +-- See Note [DataCon user type variable binders] +-- | 'InvisTVBinder's for the type variables of the constructor, in the order the +-- user wrote them +dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] +dataConUserTyVarBinders = dcUserTyVarBinders + +-- | Equalities derived from the result type of the data constructor, as written +-- by the programmer in any GADT declaration. This includes *all* GADT-like +-- equalities, including those written in by hand by the programmer. +dataConEqSpec :: DataCon -> [EqSpec] +dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = dataConKindEqSpec con + ++ eq_spec ++ + [ spec -- heterogeneous equality + | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` heqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] ++ + [ spec -- homogeneous equality + | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` eqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] + +-- | Dependent (kind-level) equalities in a constructor. +-- There are extracted from the existential variables. +-- See Note [Existential coercion variables] +dataConKindEqSpec :: DataCon -> [EqSpec] +dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) + -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), + -- which are frequently used functions. + -- For now (Aug 2018) this function always return empty set as we don't really + -- have coercion variables. + -- In the future when we do, we might want to cache this information in DataCon + -- so it won't be computed every time when aforementioned functions are called. + = [ EqSpec tv ty + | cv <- ex_tcvs + , isCoVar cv + , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + tv = getTyVar "dataConKindEqSpec" ty1 + ] + +-- | The *full* constraints on the constructor type, including dependent GADT +-- equalities. +dataConTheta :: DataCon -> ThetaType +dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta + +-- | Get the Id of the 'DataCon' worker: a function that is the "actual" +-- constructor and has no top level binding in the program. The type may +-- be different from the obvious one written in the source program. Panics +-- if there is no such 'Id' for this 'DataCon' +dataConWorkId :: DataCon -> Id +dataConWorkId dc = dcWorkId dc + +-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" +-- constructor so it has the type visible in the source program: c.f. +-- 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data +-- constructor and also for a newtype (whose constructor is inlined +-- compulsorily) +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcRep dc of + NoDataConRep -> Nothing + DCR { dcr_wrap_id = wrap_id } -> Just wrap_id + +-- | Returns an Id which looks like the Haskell-source constructor by using +-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to +-- the worker (see 'dataConWorkId') +dataConWrapId :: DataCon -> Id +dataConWrapId dc = case dcRep dc of + NoDataConRep-> dcWorkId dc -- worker=wrapper + DCR { dcr_wrap_id = wrap_id } -> wrap_id + +-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, +-- the union of the 'dataConWorkId' and the 'dataConWrapId' +dataConImplicitTyThings :: DataCon -> [TyThing] +dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) + = [AnId work] ++ wrap_ids + where + wrap_ids = case rep of + NoDataConRep -> [] + DCR { dcr_wrap_id = wrap } -> [AnId wrap] + +-- | The labels for the fields of this particular 'DataCon' +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels = dcFields + +-- | Extract the type for any given labelled field of the 'DataCon' +dataConFieldType :: DataCon -> FieldLabelString -> Type +dataConFieldType con label = case dataConFieldType_maybe con label of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) + +-- | Extract the label and type for any given labelled field of the +-- 'DataCon', or return 'Nothing' if the field does not belong to it +dataConFieldType_maybe :: DataCon -> FieldLabelString + -> Maybe (FieldLabel, Type) +dataConFieldType_maybe con label + = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con)) + +-- | Strictness/unpack annotations, from user; or, for imported +-- DataCons, from the interface file +-- The list is in one-to-one correspondence with the arity of the 'DataCon' + +dataConSrcBangs :: DataCon -> [HsSrcBang] +dataConSrcBangs = dcSrcBangs + +-- | Source-level arity of the data constructor +dataConSourceArity :: DataCon -> Arity +dataConSourceArity (MkData { dcSourceArity = arity }) = arity + +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries +dataConRepArity :: DataCon -> Arity +dataConRepArity (MkData { dcRepArity = arity }) = arity + +-- | Return whether there are any argument types for this 'DataCon's original source type +-- See Note [DataCon arities] +isNullarySrcDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = dataConSourceArity dc == 0 + +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +-- See Note [DataCon arities] +isNullaryRepDataCon :: DataCon -> Bool +isNullaryRepDataCon dc = dataConRepArity dc == 0 + +dataConRepStrictness :: DataCon -> [StrictnessMark] +-- ^ Give the demands on the arguments of a +-- Core constructor application (Con dc args) +dataConRepStrictness dc = case dcRep dc of + NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] + DCR { dcr_stricts = strs } -> strs + +dataConImplBangs :: DataCon -> [HsImplBang] +-- The implementation decisions about the strictness/unpack of each +-- source program argument to the data constructor +dataConImplBangs dc + = case dcRep dc of + NoDataConRep -> replicate (dcSourceArity dc) HsLazy + DCR { dcr_bangs = bangs } -> bangs + +dataConBoxer :: DataCon -> Maybe DataConBoxer +dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer +dataConBoxer _ = Nothing + +dataConInstSig + :: DataCon + -> [Type] -- Instantiate the *universal* tyvars with these types + -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys +-- ^ Instantiate the universal tyvars of a data con, +-- returning +-- ( instantiated existentials +-- , instantiated constraints including dependent GADT equalities +-- which are *also* listed in the instantiated existentials +-- , instantiated args) +dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs + , dcOrigArgTys = arg_tys }) + univ_tys + = ( ex_tvs' + , substTheta subst (dataConTheta con) + , substTys subst (map scaledThing arg_tys)) + where + univ_subst = zipTvSubst univ_tvs univ_tys + (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs + + +-- | The \"full signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivTyVars' +-- +-- 2) The result of 'dataConExTyCoVars' +-- +-- 3) The non-dependent GADT equalities. +-- Dependent GADT equalities are implied by coercion variables in +-- return value (2). +-- +-- 4) The other constraints of the data constructor type, excluding GADT +-- equalities +-- +-- 5) The original argument types to the 'DataCon' (i.e. before +-- any change of the representation of the type) with linearity +-- annotations +-- +-- 6) The original result type of the 'DataCon' +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc + +-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +{- +Note [Displaying linear fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constructor with a linear field can be written either as +MkT :: a %1 -> T a (with -XLinearTypes) +or +MkT :: a -> T a (with -XNoLinearTypes) + +There are two different methods to retrieve a type of a datacon. +They differ in how linear fields are handled. + +1. dataConWrapperType: +The type of the wrapper in Core. +For example, dataConWrapperType for Maybe is a %1 -> Just a. + +2. dataConNonlinearType: +The type of the constructor, with linear arrows replaced by unrestricted ones. +Used when we don't want to introduce linear types to user (in holes +and in types in hie used by haddock). + +3. dataConDisplayType (depends on DynFlags): +The type we'd like to show in error messages, :info and -ddump-types. +Ideally, it should reflect the type written by the user; +the function returns a type with arrows that would be required +to write this constructor under the current setting of -XLinearTypes. +In principle, this type can be different from the user's source code +when the value of -XLinearTypes has changed, but we don't +expect this to cause much trouble. + +Due to internal plumbing in checkValidDataCon, we can't just return a Doc. +The multiplicity of arrows returned by dataConDisplayType and +dataConDisplayType is used only for pretty-printing. +-} + +dataConWrapperType :: DataCon -> Type +-- ^ The user-declared type of the data constructor +-- in the nice-to-read form: +-- +-- > T :: forall a b. a -> b -> T [a] +-- +-- rather than: +-- +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c +-- +-- The type variables are quantified in the order that the user wrote them. +-- See @Note [DataCon user type variable binders]@. +-- +-- NB: If the constructor is part of a data instance, the result type +-- mentions the family tycon, not the internal one. +dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) + = mkInvisForAllTys user_tvbs $ + mkInvisFunTysMany theta $ + mkVisFunTys arg_tys $ + res_ty + +dataConNonlinearType :: DataCon -> Type +dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) + = let arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys + in mkInvisForAllTys user_tvbs $ + mkInvisFunTysMany theta $ + mkVisFunTys arg_tys' $ + res_ty + +dataConDisplayType :: DynFlags -> DataCon -> Type +dataConDisplayType dflags dc + = if xopt LangExt.LinearTypes dflags + then dataConWrapperType dc + else dataConNonlinearType dc + +-- | Finds the instantiated types of the arguments required to construct a +-- 'DataCon' representation +-- NB: these INCLUDE any dictionary args +-- but EXCLUDE the data-declaration context, which is discarded +-- It's all post-flattening etc; this is a representation type +dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) + -> [Type] -- ^ Instantiated at these types + -> [Scaled Type] +dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2( null ex_tvs, ppr dc ) + map (mapScaledType (substTyWith univ_tvs inst_tys)) (dataConRepArgTys dc) + +-- | Returns just the instantiated /value/ argument types of a 'DataCon', +-- (excluding dictionary args) +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Scaled Type] +-- For vanilla datacons, it's all quite straightforward +-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just +-- the value args +dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + substScaledTys subst arg_tys + where + tyvars = univ_tvs ++ ex_tvs + subst = zipTCvSubst tyvars inst_tys + +-- | Returns the argument types of the wrapper, excluding all dictionary arguments +-- and without substituting for any type variables +dataConOrigArgTys :: DataCon -> [Scaled Type] +dataConOrigArgTys dc = dcOrigArgTys dc + +-- | Returns constraints in the wrapper type, other than those in the dataConEqSpec +dataConOtherTheta :: DataCon -> ThetaType +dataConOtherTheta dc = dcOtherTheta dc + +-- | Returns the arg types of the worker, including *all* non-dependent +-- evidence, after any flattening has been done and without substituting for +-- any type variables +dataConRepArgTys :: DataCon -> [Scaled Type] +dataConRepArgTys (MkData { dcRep = rep + , dcEqSpec = eq_spec + , dcOtherTheta = theta + , dcOrigArgTys = orig_arg_tys }) + = case rep of + NoDataConRep -> ASSERT( null eq_spec ) (map unrestricted theta) ++ orig_arg_tys + DCR { dcr_arg_tys = arg_tys } -> arg_tys + +-- | The string @package:module.name@ identifying a constructor, which is attached +-- to its info table and used by the GHCi debugger and the heap profiler +dataConIdentity :: DataCon -> ByteString +-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. +dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat + [ BSB.shortByteString $ fastStringToShortByteString $ + unitFS $ moduleUnit mod + , BSB.int8 $ fromIntegral (ord ':') + , BSB.shortByteString $ fastStringToShortByteString $ + moduleNameFS $ moduleName mod + , BSB.int8 $ fromIntegral (ord '.') + , BSB.shortByteString $ fastStringToShortByteString $ + occNameFS $ nameOccName name + ] + where name = dataConName dc + mod = ASSERT( isExternalName name ) nameModule name + +isTupleDataCon :: DataCon -> Bool +isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc + +isUnboxedTupleCon :: DataCon -> Bool +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc + +isUnboxedSumCon :: DataCon -> Bool +isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc + +-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc + +-- | Should this DataCon be allowed in a type even without -XDataKinds? +-- Currently, only Lifted & Unlifted +specialPromotedDc :: DataCon -> Bool +specialPromotedDc = isKindTyCon . dataConTyCon + +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" + +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the dcRepTyCon for the data con +dataConCannotMatch tys con + -- See (U6) in Note [Implementing unsafeCoerce] + -- in base:Unsafe.Coerce + | dataConName con == unsafeReflDataConName + = False + | null inst_theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise = typesCantMatch (concatMap predEqs inst_theta) + where + (_, inst_theta, _) = dataConInstSig con tys + + -- TODO: could gather equalities from superclasses too + predEqs pred = case classifyPredType pred of + EqPred NomEq ty1 ty2 -> [(ty1, ty2)] + ClassPred eq args + | eq `hasKey` eqTyConKey + , [_, ty1, ty2] <- args -> [(ty1, ty2)] + | eq `hasKey` heqTyConKey + , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] + _ -> [] + +-- | Were the type variables of the data con written in a different order +-- than the regular order (universal tyvars followed by existential tyvars)? +-- +-- This is not a cheap test, so we minimize its use in GHC as much as possible. +-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in +-- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once +-- during a data constructor's lifetime. + +-- See Note [DataCon user type variable binders], as well as +-- Note [Data con wrappers and GADT syntax] for an explanation of what +-- mkDataConRep is doing with this function. +dataConUserTyVarsArePermuted :: DataCon -> Bool +dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec + , dcUserTyVarBinders = user_tvbs }) = + (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs + +{- +%************************************************************************ +%* * + Promoting of data types to the kind level +* * +************************************************************************ + +-} + +promoteDataCon :: DataCon -> TyCon +promoteDataCon (MkData { dcPromoted = tc }) = tc + +{- +************************************************************************ +* * +\subsection{Splitting products} +* * +************************************************************************ +-} + +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- +-- * Single-constructor +-- +-- * Not existentially quantified +-- +-- Whether the type is a @data@ type or a @newtype@ +splitDataProductType_maybe + :: Type -- ^ A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Scaled Type]) -- Its /representation/ arg types + + -- Rejecting existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitDataProductType_maybe ty + | Just (tycon, ty_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tycon + = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) + | otherwise + = Nothing diff --git a/GHC/Core/DataCon.hs-boot b/GHC/Core/DataCon.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/DataCon.hs-boot @@ -0,0 +1,34 @@ +module GHC.Core.DataCon where + +import GHC.Prelude +import GHC.Types.Var( TyVar, TyCoVar, InvisTVBinder ) +import GHC.Types.Name( Name, NamedThing ) +import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) +import GHC.Types.FieldLabel ( FieldLabel ) +import GHC.Types.Unique ( Uniquable ) +import GHC.Utils.Outputable ( Outputable, OutputableBndr ) +import GHC.Types.Basic (Arity) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType, Scaled ) + +data DataCon +data DataConRep +data EqSpec + +dataConName :: DataCon -> Name +dataConTyCon :: DataCon -> TyCon +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] +dataConSourceArity :: DataCon -> Arity +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type] +dataConStupidTheta :: DataCon -> ThetaType +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) +isUnboxedSumCon :: DataCon -> Bool + +instance Eq DataCon +instance Uniquable DataCon +instance NamedThing DataCon +instance Outputable DataCon +instance OutputableBndr DataCon diff --git a/GHC/Core/FVs.hs b/GHC/Core/FVs.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/FVs.hs @@ -0,0 +1,806 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Taken quite directly from the Peyton Jones/Lester paper. +-} + +{-# LANGUAGE CPP #-} + +-- | A module concerned with finding the free variables of an expression. +module GHC.Core.FVs ( + -- * Free variables of expressions and binding groups + exprFreeVars, + exprFreeVarsDSet, + exprFreeVarsList, + exprFreeIds, + exprFreeIdsDSet, + exprFreeIdsList, + exprsFreeIdsDSet, + exprsFreeIdsList, + exprsFreeVars, + exprsFreeVarsList, + bindFreeVars, + + -- * Selective free variables of expressions + InterestingVarFun, + exprSomeFreeVars, exprsSomeFreeVars, + exprSomeFreeVarsList, exprsSomeFreeVarsList, + + -- * Free variables of Rules, Vars and Ids + varTypeTyCoVars, + varTypeTyCoFVs, + idUnfoldingVars, idFreeVars, dIdFreeVars, + bndrRuleAndUnfoldingVarsDSet, + idFVs, + idRuleVars, idRuleRhsVars, stableUnfoldingVars, + ruleFreeVars, rulesFreeVars, + rulesFreeVarsDSet, mkRuleInfo, + ruleLhsFreeIds, ruleLhsFreeIdsList, + ruleRhsFreeVars, ruleRhsFreeIds, + + expr_fvs, + + -- * Orphan names + orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, + orphNamesOfTypes, orphNamesOfCoCon, + exprsOrphNames, orphNamesOfFamInst, + + -- * Core syntax tree annotation with free variables + FVAnn, -- annotation, abstract + CoreExprWithFVs, -- = AnnExpr Id FVAnn + CoreExprWithFVs', -- = AnnExpr' Id FVAnn + CoreBindWithFVs, -- = AnnBind Id FVAnn + CoreAltWithFVs, -- = AnnAlt Id FVAnn + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs) + freeVarsOf, -- CoreExprWithFVs -> DIdSet + freeVarsOfAnn + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name.Set +import GHC.Types.Unique.Set +import GHC.Types.Unique (Uniquable (..)) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.FamInstEnv +import GHC.Builtin.Types( unrestrictedFunTyConName ) +import GHC.Builtin.Types.Prim( funTyConName ) +import GHC.Data.Maybe( orElse ) +import GHC.Utils.Misc +import GHC.Types.Basic( Activation ) +import GHC.Utils.Outputable +import GHC.Utils.FV as FV + +{- +************************************************************************ +* * +\section{Finding the free variables of an expression} +* * +************************************************************************ + +This function simply finds the free variables of an expression. +So far as type variables are concerned, it only finds tyvars that are + + * free in type arguments, + * free in the type of a binder, + +but not those that are free in the type of variable occurrence. +-} + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a non-deterministic set. +exprFreeVars :: CoreExpr -> VarSet +exprFreeVars = fvVarSet . exprFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" +-- for why export it. +exprFVs :: CoreExpr -> FV +exprFVs = filterFV isLocalVar . expr_fvs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministic set. +exprFreeVarsDSet :: CoreExpr -> DVarSet +exprFreeVarsDSet = fvDVarSet . exprFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministically ordered list. +exprFreeVarsList :: CoreExpr -> [Var] +exprFreeVarsList = fvVarList . exprFVs + +-- | Find all locally-defined free Ids in an expression +exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +exprFreeIds = exprSomeFreeVars isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministic set. +exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids +exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministically ordered list. +exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids +exprFreeIdsList = exprSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministic set. +exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids +exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministically ordered list. +exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids +exprsFreeIdsList = exprsSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a non-deterministic set. +exprsFreeVars :: [CoreExpr] -> VarSet +exprsFreeVars = fvVarSet . exprsFVs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" +-- for why export it. +exprsFVs :: [CoreExpr] -> FV +exprsFVs exprs = mapUnionFV exprFVs exprs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a deterministically ordered list. +exprsFreeVarsList :: [CoreExpr] -> [Var] +exprsFreeVarsList = fvVarList . exprsFVs + +-- | Find all locally defined free Ids in a binding group +bindFreeVars :: CoreBind -> VarSet +bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) +bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ + addBndrs (map fst prs) + (mapUnionFV rhs_fvs prs) + +-- | Finds free variables in an expression selected by a predicate +exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> VarSet +exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministically ordered list. +exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> [Var] +exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministic set. +exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> DVarSet +exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in several expressions selected by a predicate +exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> VarSet +exprsSomeFreeVars fv_cand es = + fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministically ordered list. +exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> [Var] +exprsSomeFreeVarsList fv_cand es = + fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministic set. +exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> [CoreExpr] + -> DVarSet +exprsSomeFreeVarsDSet fv_cand e = + fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e + +-- Comment about obsolete code +-- We used to gather the free variables the RULES at a variable occurrence +-- with the following cryptic comment: +-- "At a variable occurrence, add in any free variables of its rule rhss +-- Curiously, we gather the Id's free *type* variables from its binding +-- site, but its free *rule-rhs* variables from its usage sites. This +-- is a little weird. The reason is that the former is more efficient, +-- but the latter is more fine grained, and a makes a difference when +-- a variable mentions itself one of its own rule RHSs" +-- Not only is this "weird", but it's also pretty bad because it can make +-- a function seem more recursive than it is. Suppose +-- f = ...g... +-- g = ... +-- RULE g x = ...f... +-- Then f is not mentioned in its own RHS, and needn't be a loop breaker +-- (though g may be). But if we collect the rule fvs from g's occurrence, +-- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB +-- code in GHC.Enum.) +-- +-- Anyway, it seems plain wrong. The RULE is like an extra RHS for the +-- function, so its free variables belong at the definition site. +-- +-- Deleted code looked like +-- foldVarSet add_rule_var var_itself_set (idRuleVars var) +-- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var +-- | otherwise = set +-- SLPJ Feb06 + +addBndr :: CoreBndr -> FV -> FV +addBndr bndr fv fv_cand in_scope acc + = (varTypeTyCoFVs bndr `unionFV` + -- Include type variables in the binder's type + -- (not just Ids; coercion variables too!) + FV.delFV bndr fv) fv_cand in_scope acc + +addBndrs :: [CoreBndr] -> FV -> FV +addBndrs bndrs fv = foldr addBndr fv bndrs + +expr_fvs :: CoreExpr -> FV +expr_fvs (Type ty) fv_cand in_scope acc = + tyCoFVsOfType ty fv_cand in_scope acc +expr_fvs (Coercion co) fv_cand in_scope acc = + tyCoFVsOfCo co fv_cand in_scope acc +expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc +expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +expr_fvs (Tick t expr) fv_cand in_scope acc = + (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc +expr_fvs (App fun arg) fv_cand in_scope acc = + (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc +expr_fvs (Lam bndr body) fv_cand in_scope acc = + addBndr bndr (expr_fvs body) fv_cand in_scope acc +expr_fvs (Cast expr co) fv_cand in_scope acc = + (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc + +expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc + = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr + (mapUnionFV alt_fvs alts)) fv_cand in_scope acc + where + alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) + +expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc + = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) + fv_cand in_scope acc + +expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc + = addBndrs (map fst pairs) + (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) + fv_cand in_scope acc + +--------- +rhs_fvs :: (Id, CoreExpr) -> FV +rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` + bndrRuleAndUnfoldingFVs bndr + -- Treat any RULES as extra RHSs of the binding + +--------- +exprs_fvs :: [CoreExpr] -> FV +exprs_fvs exprs = mapUnionFV expr_fvs exprs + +tickish_fvs :: Tickish Id -> FV +tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids +tickish_fvs _ = emptyFV + +{- +************************************************************************ +* * +\section{Free names} +* * +************************************************************************ +-} + +-- | Finds the free /external/ names of an expression, notably +-- including the names of type constructors (which of course do not show +-- up in 'exprFreeVars'). +exprOrphNames :: CoreExpr -> NameSet +-- There's no need to delete local binders, because they will all +-- be /internal/ names. +exprOrphNames e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = idName v + go (Lit _) = emptyNameSet + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion co) = orphNamesOfCo co + go (App e1 e2) = go e1 `unionNameSet` go e2 + go (Lam v e) = go e `delFromNameSet` idName v + go (Tick _ e) = go e + go (Cast e co) = go e `unionNameSet` orphNamesOfCo co + go (Let (NonRec _ r) e) = go e `unionNameSet` go r + go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e + go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty + `unionNameSet` unionNameSets (map go_alt as) + + go_alt (_,_,r) = go r + +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +exprsOrphNames :: [CoreExpr] -> NameSet +exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es + + +{- ********************************************************************** +%* * + orphNamesXXX + +%* * +%********************************************************************* -} + +orphNamesOfTyCon :: TyCon -> NameSet +orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of + Nothing -> emptyNameSet + Just cls -> unitNameSet (getName cls) + +orphNamesOfType :: Type -> NameSet +orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' + -- Look through type synonyms (#4912) +orphNamesOfType (TyVarTy _) = emptyNameSet +orphNamesOfType (LitTy {}) = emptyNameSet +orphNamesOfType (TyConApp tycon tys) = func + `unionNameSet` orphNamesOfTyCon tycon + `unionNameSet` orphNamesOfTypes tys + where func = case tys of + arg:_ | tycon == funTyCon -> orph_names_of_fun_ty_con arg + _ -> emptyNameSet +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) + `unionNameSet` orphNamesOfType res +orphNamesOfType (FunTy _ w arg res) = orph_names_of_fun_ty_con w + `unionNameSet` unitNameSet funTyConName + `unionNameSet` orphNamesOfType w + `unionNameSet` orphNamesOfType arg + `unionNameSet` orphNamesOfType res +orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg +orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co +orphNamesOfType (CoercionTy co) = orphNamesOfCo co + +orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet +orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet + +orphNamesOfTypes :: [Type] -> NameSet +orphNamesOfTypes = orphNamesOfThings orphNamesOfType + +orphNamesOfMCo :: MCoercion -> NameSet +orphNamesOfMCo MRefl = emptyNameSet +orphNamesOfMCo (MCo co) = orphNamesOfCo co + +orphNamesOfCo :: Coercion -> NameSet +orphNamesOfCo (Refl ty) = orphNamesOfType ty +orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco +orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (ForAllCo _ kind_co co) + = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co +orphNamesOfCo (FunCo _ co_mult co1 co2) = orphNamesOfCo co_mult `unionNameSet` orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (CoVarCo _) = emptyNameSet +orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 +orphNamesOfCo (SymCo co) = orphNamesOfCo co +orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co +orphNamesOfCo (LRCo _ co) = orphNamesOfCo co +orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg +orphNamesOfCo (KindCo co) = orphNamesOfCo co +orphNamesOfCo (SubCo co) = orphNamesOfCo co +orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs +orphNamesOfCo (HoleCo _) = emptyNameSet + +orphNamesOfProv :: UnivCoProvenance -> NameSet +orphNamesOfProv (PhantomProv co) = orphNamesOfCo co +orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co +orphNamesOfProv (PluginProv _) = emptyNameSet +orphNamesOfProv CorePrepProv = emptyNameSet + +orphNamesOfCos :: [Coercion] -> NameSet +orphNamesOfCos = orphNamesOfThings orphNamesOfCo + +orphNamesOfCoCon :: CoAxiom br -> NameSet +orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches + +orphNamesOfAxiom :: CoAxiom br -> NameSet +orphNamesOfAxiom axiom + = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) + `extendNameSet` getName (coAxiomTyCon axiom) + +orphNamesOfCoAxBranches :: Branches br -> NameSet +orphNamesOfCoAxBranches + = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches + +orphNamesOfCoAxBranch :: CoAxBranch -> NameSet +orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) + = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs + +-- | orphNamesOfAxiom collects the names of the concrete types and +-- type constructors that make up the LHS of a type family instance, +-- including the family name itself. +-- +-- For instance, given `type family Foo a b`: +-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] +-- +-- Used in the implementation of ":info" in GHCi. +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) + +-- Detect FUN 'Many as an application of (->), so that :i (->) works as expected +-- (see #8535) Issue #16475 describes a more robust solution +orph_names_of_fun_ty_con :: Mult -> NameSet +orph_names_of_fun_ty_con Many = unitNameSet unrestrictedFunTyConName +orph_names_of_fun_ty_con _ = emptyNameSet + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ +-} + +-- | Those variables free in the right hand side of a rule returned as a +-- non-deterministic set +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule {}) = noFVs +ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) + = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) + -- See Note [Rule free var hack] + +-- | Those variables free in the both the left right hand sides of a rule +-- returned as a non-deterministic set +ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars = fvVarSet . ruleFVs + +-- | Those variables free in the both the left right hand sides of a rule +-- returned as FV computation +ruleFVs :: CoreRule -> FV +ruleFVs (BuiltinRule {}) = emptyFV +ruleFVs (Rule { ru_fn = _do_not_include + -- See Note [Rule free var hack] + , ru_bndrs = bndrs + , ru_rhs = rhs, ru_args = args }) + = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) + +-- | Those variables free in the both the left right hand sides of rules +-- returned as FV computation +rulesFVs :: [CoreRule] -> FV +rulesFVs = mapUnionFV ruleFVs + +-- | Those variables free in the both the left right hand sides of rules +-- returned as a deterministic set +rulesFreeVarsDSet :: [CoreRule] -> DVarSet +rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules + +-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' +mkRuleInfo :: [CoreRule] -> RuleInfo +mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) + +idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet +-- Just the variables free on the *rhs* of a rule +idRuleRhsVars is_active id + = mapUnionVarSet get_fvs (idCoreRules id) + where + get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs + , ru_rhs = rhs, ru_act = act }) + | is_active act + -- See Note [Finding rule RHS free vars] in "GHC.Core.Opt.OccurAnal" + = delOneFromUniqSet_Directly fvs (getUnique fn) + -- Note [Rule free var hack] + where + fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) + get_fvs _ = noFVs + +-- | Those variables free in the right hand side of several rules +rulesFreeVars :: [CoreRule] -> VarSet +rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules + +ruleLhsFreeIds :: CoreRule -> VarSet +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a non-deterministic set +ruleLhsFreeIds = fvVarSet . ruleLhsFVIds + +ruleLhsFreeIdsList :: CoreRule -> [Var] +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a deterministically ordered list +ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds + +ruleLhsFVIds :: CoreRule -> FV +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns an FV computation +ruleLhsFVIds (BuiltinRule {}) = emptyFV +ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args) + +ruleRhsFreeIds :: CoreRule -> VarSet +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a non-deterministic set +ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet +ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = fvVarSet $ filterFV isLocalId $ + addBndrs bndrs $ exprs_fvs args + +{- +Note [Rule free var hack] (Not a hack any more) +~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to include the Id in its own rhs free-var set. +Otherwise the occurrence analyser makes bindings recursive: + f x y = x+y + RULE: f (f x y) z ==> f x (f y z) +However, the occurrence analyser distinguishes "non-rule loop breakers" +from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will +put this 'f' in a Rec block, but will mark the binding as a non-rule loop +breaker, which is perfectly inlinable. +-} + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ + +The free variable pass annotates every node in the expression with its +NON-GLOBAL free variables and type variables. +-} + +type FVAnn = DVarSet -- See Note [The FVAnn invariant] + +{- Note [The FVAnn invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant: a FVAnn, say S, is closed: + That is: if v is in S, + then freevars( v's type/kind ) is also in S +-} + +-- | Every node in a binding group annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreBindWithFVs = AnnBind Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +-- NB: see Note [The FVAnn invariant] +type CoreExprWithFVs = AnnExpr Id FVAnn +type CoreExprWithFVs' = AnnExpr' Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreAltWithFVs = AnnAlt Id FVAnn + +freeVarsOf :: CoreExprWithFVs -> DIdSet +-- ^ Inverse function to 'freeVars' +freeVarsOf (fvs, _) = fvs + +-- | Extract the vars reported in a FVAnn +freeVarsOfAnn :: FVAnn -> DIdSet +freeVarsOfAnn fvs = fvs + +noFVs :: VarSet +noFVs = emptyVarSet + +aFreeVar :: Var -> DVarSet +aFreeVar = unitDVarSet + +unionFVs :: DVarSet -> DVarSet -> DVarSet +unionFVs = unionDVarSet + +unionFVss :: [DVarSet] -> DVarSet +unionFVss = unionDVarSets + +delBindersFV :: [Var] -> DVarSet -> DVarSet +delBindersFV bs fvs = foldr delBinderFV fvs bs + +delBinderFV :: Var -> DVarSet -> DVarSet +-- This way round, so we can do it multiple times using foldr + +-- (b `delBinderFV` s) +-- * removes the binder b from the free variable set s, +-- * AND *adds* to s the free variables of b's type +-- +-- This is really important for some lambdas: +-- In (\x::a -> x) the only mention of "a" is in the binder. +-- +-- Also in +-- let x::a = b in ... +-- we should really note that "a" is free in this expression. +-- It'll be pinned inside the /\a by the binding for b, but +-- it seems cleaner to make sure that a is in the free-var set +-- when it is mentioned. +-- +-- This also shows up in recursive bindings. Consider: +-- /\a -> letrec x::a = x in E +-- Now, there are no explicit free type variables in the RHS of x, +-- but nevertheless "a" is free in its definition. So we add in +-- the free tyvars of the types of the binders, and include these in the +-- free vars of the group, attached to the top level of each RHS. +-- +-- This actually happened in the defn of errorIO in IOBase.hs: +-- errorIO (ST io) = case (errorIO# io) of +-- _ -> bottom +-- where +-- bottom = bottom -- Never evaluated + +delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b + -- Include coercion variables too! + +varTypeTyCoVars :: Var -> TyCoVarSet +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var + +dVarTypeTyCoVars :: Var -> DTyCoVarSet +-- Find the type/kind/coercion variables free in the type of the id/tyvar +dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var + +varTypeTyCoFVs :: Var -> FV +varTypeTyCoFVs var = tyCoFVsOfType (varType var) + +idFreeVars :: Id -> VarSet +idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id + +dIdFreeVars :: Id -> DVarSet +dIdFreeVars id = fvDVarSet $ idFVs id + +idFVs :: Id -> FV +-- Type variables, rule variables, and inline variables +idFVs id = ASSERT( isId id) + varTypeTyCoFVs id `unionFV` + bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet +bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingFVs :: Id -> FV +bndrRuleAndUnfoldingFVs id + | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id + | otherwise = emptyFV + +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars +idRuleVars id = fvVarSet $ idRuleFVs id + +idRuleFVs :: Id -> FV +idRuleFVs id = ASSERT( isId id) + FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) + +idUnfoldingVars :: Id -> VarSet +-- Produce free vars for an unfolding, but NOT for an ordinary +-- (non-inline) unfolding, since it is a dup of the rhs +-- and we'll get exponential behaviour if we look at both unf and rhs! +-- But do look at the *real* unfolding, even for loop breakers, else +-- we might get out-of-scope variables +idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id + +idUnfoldingFVs :: Id -> FV +idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV + +stableUnfoldingVars :: Unfolding -> Maybe VarSet +stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf + +stableUnfoldingFVs :: Unfolding -> Maybe FV +stableUnfoldingFVs unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src + -> Just (filterFV isLocalVar $ expr_fvs rhs) + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args) + -- DFuns are top level, so no fvs from types of bndrs + _other -> Nothing + + +{- +************************************************************************ +* * +\subsection{Free variables (and types)} +* * +************************************************************************ +-} + +freeVarsBind :: CoreBind + -> DVarSet -- Free vars of scope of binding + -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope +freeVarsBind (NonRec binder rhs) body_fvs + = ( AnnNonRec binder rhs2 + , freeVarsOf rhs2 `unionFVs` body_fvs2 + `unionFVs` bndrRuleAndUnfoldingVarsDSet binder ) + where + rhs2 = freeVars rhs + body_fvs2 = binder `delBinderFV` body_fvs + +freeVarsBind (Rec binds) body_fvs + = ( AnnRec (binders `zip` rhss2) + , delBindersFV binders all_fvs ) + where + (binders, rhss) = unzip binds + rhss2 = map freeVars rhss + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders + -- See Note [The FVAnn invariant] + all_fvs = rhs_body_fvs `unionFVs` binders_fvs + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs + +freeVars :: CoreExpr -> CoreExprWithFVs +-- ^ Annotate a 'CoreExpr' with its (non-global) free type +-- and value variables at every tree node. +freeVars = go + where + go :: CoreExpr -> CoreExprWithFVs + go (Var v) + | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v) + | otherwise = (emptyDVarSet, AnnVar v) + where + mult_vars = tyCoVarsOfTypeDSet (varMult v) + ty_fvs = dVarTypeTyCoVars v + -- See Note [The FVAnn invariant] + + go (Lit lit) = (emptyDVarSet, AnnLit lit) + go (Lam b body) + = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs) + , AnnLam b body' ) + where + body'@(body_fvs, _) = go body + b_ty = idType b + b_fvs = tyCoVarsOfTypeDSet b_ty + -- See Note [The FVAnn invariant] + + go (App fun arg) + = ( freeVarsOf fun' `unionFVs` freeVarsOf arg' + , AnnApp fun' arg' ) + where + fun' = go fun + arg' = go arg + + go (Case scrut bndr ty alts) + = ( (bndr `delBinderFV` alts_fvs) + `unionFVs` freeVarsOf scrut2 + `unionFVs` tyCoVarsOfTypeDSet ty + -- Don't need to look at (idType bndr) + -- because that's redundant with scrut + , AnnCase scrut2 bndr ty alts2 ) + where + scrut2 = go scrut + + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = unionFVss alts_fvs_s + + fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), + (con, args, rhs2)) + where + rhs2 = go rhs + + go (Let bind body) + = (bind_fvs, AnnLet bind2 body2) + where + (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2) + body2 = go body + + go (Cast expr co) + = ( freeVarsOf expr2 `unionFVs` cfvs + , AnnCast expr2 (cfvs, co) ) + where + expr2 = go expr + cfvs = tyCoVarsOfCoDSet co + + go (Tick tickish expr) + = ( tickishFVs tickish `unionFVs` freeVarsOf expr2 + , AnnTick tickish expr2 ) + where + expr2 = go expr + tickishFVs (Breakpoint _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet + + go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) + go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) diff --git a/GHC/Core/FamInstEnv.hs b/GHC/Core/FamInstEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/FamInstEnv.hs @@ -0,0 +1,1852 @@ +-- (c) The University of Glasgow 2006 +-- +-- FamInstEnv: Type checked family instance declarations + +{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections, + DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.FamInstEnv ( + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + pprFamInst, pprFamInsts, + mkImportedFamInst, + + FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, + extendFamInstEnv, extendFamInstEnvList, + famInstEnvElts, famInstEnvSize, familyInstances, + + -- * CoAxioms + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, + mkNewTypeCoAxiom, + + FamInstMatch(..), + lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, + + isDominatedBy, apartnessCheck, + + -- Injectivity + InjectivityCheckResult(..), + lookupFamInstEnvInjectivityConflicts, injectiveBranches, + + -- Normalisation + topNormaliseType, topNormaliseType_maybe, + normaliseType, normaliseTcApp, + topReduceTyFamApp_maybe, reduceTyFamApp_maybe, + + -- Flattening + flattenTys + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Unify +import GHC.Core.Type as Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name +import GHC.Types.Unique.DFM +import GHC.Utils.Outputable +import GHC.Data.Maybe +import GHC.Core.Map +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Data.FastString +import Control.Monad +import Data.List( mapAccumL ) +import Data.Array( Array, assocs ) + +{- +************************************************************************ +* * + Type checked family instance heads +* * +************************************************************************ + +Note [FamInsts and CoAxioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* CoAxioms and FamInsts are just like + DFunIds and ClsInsts + +* A CoAxiom is a System-FC thing: it can relate any two types + +* A FamInst is a Haskell source-language thing, corresponding + to a type/data family instance declaration. + - The FamInst contains a CoAxiom, which is the evidence + for the instance + + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family +-} + +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom + -- introduced by this family + -- instance + -- INVARIANT: apart from freshening (see below) + -- fi_tvs = cab_tvs of the (single) axiom branch + -- fi_cvs = cab_cvs ...ditto... + -- fi_tys = cab_lhs ...ditto... + -- fi_rhs = cab_rhs ...ditto... + + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + -- except that the TyVars are freshened + , fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough-match field] in GHC.Core.InstEnv + , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys + + -- Used for "proper matching"; ditto + , fi_tvs :: [TyVar] -- Template tyvars for full match + , fi_cvs :: [CoVar] -- Template covars for full match + -- Like ClsInsts, these variables are always fresh + -- See Note [Template tyvars are fresh] in GHC.Core.InstEnv + + , fi_tys :: [Type] -- The LHS type patterns + -- May be eta-reduced; see Note [Eta reduction for data families] + -- in GHC.Core.Coercion.Axiom + + , fi_rhs :: Type -- the RHS, with its freshened vars + } + +data FamFlavor + = SynFamilyInst -- A synonym family + | DataFamilyInst TyCon -- A data family, with its representation TyCon + +{- +Note [Arity of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data family instances might legitimately be over- or under-saturated. + +Under-saturation has two potential causes: + U1) Eta reduction. See Note [Eta reduction for data families] in + GHC.Core.Coercion.Axiom. + U2) When the user has specified a return kind instead of written out patterns. + Example: + + data family Sing (a :: k) + data instance Sing :: Bool -> Type + + The data family tycon Sing has an arity of 2, the k and the a. But + the data instance has only one pattern, Bool (standing in for k). + This instance is equivalent to `data instance Sing (a :: Bool)`, but + without the last pattern, we have an under-saturated data family instance. + On its own, this example is not compelling enough to add support for + under-saturation, but U1 makes this feature more compelling. + +Over-saturation is also possible: + O1) If the data family's return kind is a type variable (see also #12369), + an instance might legitimately have more arguments than the family. + Example: + + data family Fix :: (Type -> k) -> k + data instance Fix f = MkFix1 (f (Fix f)) + data instance Fix f x = MkFix2 (f (Fix f x) x) + + In the first instance here, the k in the data family kind is chosen to + be Type. In the second, it's (Type -> Type). + + However, we require that any over-saturation is eta-reducible. That is, + we require that any extra patterns be bare unrepeated type variables; + see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. + Accordingly, the FamInst is never over-saturated. + +Why can we allow such flexibility for data families but not for type families? +Because data families can be decomposed -- that is, they are generative and +injective. A Type family is neither and so always must be applied to all its +arguments. +-} + +-- Obtain the axiom of a family instance +famInstAxiom :: FamInst -> CoAxiom Unbranched +famInstAxiom = fi_axiom + +-- Split the left-hand side of the FamInst +famInstSplitLHS :: FamInst -> (TyCon, [Type]) +famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) + = (coAxiomTyCon axiom, lhs) + +-- Get the RHS of the FamInst +famInstRHS :: FamInst -> Type +famInstRHS = fi_rhs + +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom + +-- Return the representation TyCons introduced by data family instances, if any +famInstsRepTyCons :: [FamInst] -> [TyCon] +famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] + +-- Extracts the TyCon for this *data* (or newtype) instance +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi + = case fi_flavor fi of + DataFamilyInst tycon -> Just tycon + SynFamilyInst -> Nothing + +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi + = case fi_flavor fi of + DataFamilyInst tycon -> tycon + SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) + +{- +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance NamedThing FamInst where + getName = coAxiomName . fi_axiom + +instance Outputable FamInst where + ppr = pprFamInst + +pprFamInst :: FamInst -> SDoc +-- Prints the FamInst as a family instance declaration +-- NB: This function, FamInstEnv.pprFamInst, is used only for internal, +-- debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user +pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax + , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) + = hang (ppr_tc_sort <+> text "instance" + <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) + 2 (whenPprDebug debug_stuff) + where + ppr_tc_sort = case flavor of + SynFamilyInst -> text "type" + DataFamilyInst tycon + | isDataTyCon tycon -> text "data" + | isNewTyCon tycon -> text "newtype" + | isAbstractTyCon tycon -> text "data" + | otherwise -> text "WEIRD" <+> ppr tycon + + debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax + , text "Tvs:" <+> ppr tvs + , text "LHS:" <+> ppr tys + , text "RHS:" <+> ppr rhs ] + +pprFamInsts :: [FamInst] -> SDoc +pprFamInsts finsts = vcat (map pprFamInst finsts) + +{- +Note [Lazy axiom match] +~~~~~~~~~~~~~~~~~~~~~~~ +It is Vitally Important that mkImportedFamInst is *lazy* in its axiom +parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime +later, mkImportedFamInst is called using that axiom. However, the axiom +may itself depend on entities which are not yet loaded as of the time +of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the +axiom, a dependency loop spontaneously appears and GHC hangs. The solution +is simply for mkImportedFamInst never, ever to look inside of the axiom +until everything else is good and ready to do so. We can assume that this +readiness has been achieved when some other code pulls on the axiom in the +FamInst. Thus, we pattern match on the axiom lazily (in the where clause, +not in the parameter list) and we assert the consistency of names there +also. +-} + +-- Make a family instance representation from the information found in an +-- interface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +mkImportedFamInst :: Name -- Name of the family + -> [Maybe Name] -- Rough match info + -> CoAxiom Unbranched -- Axiom introduced + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = tvs, + fi_cvs = cvs, + fi_tys = tys, + fi_rhs = rhs, + fi_axiom = axiom, + fi_flavor = flavor } + where + -- See Note [Lazy axiom match] + ~(CoAxBranch { cab_lhs = tys + , cab_tvs = tvs + , cab_cvs = cvs + , cab_rhs = rhs }) = coAxiomSingleBranch axiom + + -- Derive the flavor for an imported FamInst rather disgustingly + -- Maybe we should store it in the IfaceFamInst? + flavor = case splitTyConApp_maybe rhs of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst + +{- +************************************************************************ +* * + FamInstEnv +* * +************************************************************************ + +Note [FamInstEnv] +~~~~~~~~~~~~~~~~~ +A FamInstEnv maps a family name to the list of known instances for that family. + +The same FamInstEnv includes both 'data family' and 'type family' instances. +Type families are reduced during type inference, but not data families; +the user explains when to use a data family instance by using constructors +and pattern matching. + +Nevertheless it is still useful to have data families in the FamInstEnv: + + - For finding overlaps and conflicts + + - For finding the representation type...see FamInstEnv.topNormaliseType + and its call site in GHC.Core.Opt.Simplify + + - In standalone deriving instance Eq (T [Int]) we need to find the + representation type for T [Int] + +Note [Varying number of patterns for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For data families, the number of patterns may vary between instances. +For example + data family T a b + data instance T Int a = T1 a | T2 + data instance T Bool [a] = T3 a + +Then we get a data type for each instance, and an axiom: + data TInt a = T1 a | T2 + data TBoolList a = T3 a + + axiom ax7 :: T Int ~ TInt -- Eta-reduced + axiom ax8 a :: T Bool [a] ~ TBoolList a + +These two axioms for T, one with one pattern, one with two; +see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +Note [FamInstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn FamInstEnvs into a list in some places that don't directly affect +the ABI. That happens in family consistency checks and when producing output +for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard +to tell what it affects without following a chain of functions. It's also +easy to accidentally make that nondeterminism affect the ABI. Furthermore +the envs should be relatively small, so it should be free to use deterministic +maps here. Testing with nofib and validate detected no difference between +UniqFM and UniqDFM. +See Note [Deterministic UniqFM]. +-} + +-- Internally we sometimes index by Name instead of TyCon despite +-- of what the type says. This is safe since +-- getUnique (tyCon) == getUniqe (tcName tyCon) +type FamInstEnv = UniqDFM TyCon FamilyInstEnv -- Maps a family to its instances + -- See Note [FamInstEnv] + -- See Note [FamInstEnv determinism] + +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + +newtype FamilyInstEnv + = FamIE [FamInst] -- The instances for a particular family, in any order + +instance Outputable FamilyInstEnv where + ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) + +-- | Index a FamInstEnv by the tyCons name. +toNameInstEnv :: FamInstEnv -> UniqDFM Name FamilyInstEnv +toNameInstEnv = unsafeCastUDFMKey + +-- | Create a FamInstEnv from Name indices. +fromNameInstEnv :: UniqDFM Name FamilyInstEnv -> FamInstEnv +fromNameInstEnv = unsafeCastUDFMKey + +-- INVARIANTS: +-- * The fs_tvs are distinct in each FamInst +-- of a range value of the map (so we can safely unify them) + +emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) +emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) + +emptyFamInstEnv :: FamInstEnv +emptyFamInstEnv = emptyUDFM + +famInstEnvElts :: FamInstEnv -> [FamInst] +famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] + -- See Note [FamInstEnv determinism] + +famInstEnvSize :: FamInstEnv -> Int +famInstEnvSize = nonDetStrictFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 + -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the + -- size. + +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] +familyInstances (pkg_fie, home_fie) fam + = get home_fie ++ get pkg_fie + where + get env = case lookupUDFM env fam of + Just (FamIE insts) -> insts + Nothing -> [] + +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv +extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis + +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +extendFamInstEnv inst_env + ins_item@(FamInst {fi_fam = cls_nm}) + = fromNameInstEnv $ addToUDFM_C add (toNameInstEnv inst_env) cls_nm (FamIE [ins_item]) + where + add (FamIE items) _ = FamIE (ins_item:items) + +{- +************************************************************************ +* * + Compatibility +* * +************************************************************************ + +Note [Apartness] +~~~~~~~~~~~~~~~~ +In dealing with closed type families, we must be able to check that one type +will never reduce to another. This check is called /apartness/. The check +is always between a target (which may be an arbitrary type) and a pattern. +Here is how we do it: + +apart(target, pattern) = not (unify(flatten(target), pattern)) + +where flatten (implemented in flattenTys, below) converts all type-family +applications into fresh variables. (See Note [Flattening].) + +Note [Compatibility] +~~~~~~~~~~~~~~~~~~~~ +Two patterns are /compatible/ if either of the following conditions hold: +1) The patterns are apart. +2) The patterns unify with a substitution S, and their right hand sides +equal under that substitution. + +For open type families, only compatible instances are allowed. For closed +type families, the story is slightly more complicated. Consider the following: + +type family F a where + F Int = Bool + F a = Int + +g :: Show a => a -> F a +g x = length (show x) + +Should that type-check? No. We need to allow for the possibility that 'a' +might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int +only when we can be sure that 'a' is not Int. + +To achieve this, after finding a possible match within the equations, we have to +go back to all previous equations and check that, under the +substitution induced by the match, other branches are surely apart. (See +Note [Apartness].) This is similar to what happens with class +instance selection, when we need to guarantee that there is only a match and +no unifiers. The exact algorithm is different here because the +potentially-overlapping group is closed. + +As another example, consider this: + +type family G x where + G Int = Bool + G a = Double + +type family H y +-- no instances + +Now, we want to simplify (G (H Char)). We can't, because (H Char) might later +simplify to be Int. So, (G (H Char)) is stuck, for now. + +While everything above is quite sound, it isn't as expressive as we'd like. +Consider this: + +type family J a where + J Int = Int + J a = a + +Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if +b is instantiated with Int, but the RHSs coincide there, so it's all OK. + +So, the rule is this: when looking up a branch in a closed type family, we +find a branch that matches the target, but then we make sure that the target +is apart from every previous *incompatible* branch. We don't check the +branches that are compatible with the matching branch, because they are either +irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). + +Note [Compatibility of eta-reduced axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In newtype instances of data families we eta-reduce the axioms, +See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. This means that +we sometimes need to test compatibility of two axioms that were eta-reduced to +different degrees, e.g.: + + +data family D a b c +newtype instance D a Int c = DInt (Maybe a) + -- D a Int ~ Maybe + -- lhs = [a, Int] +newtype instance D Bool Int Char = DIntChar Float + -- D Bool Int Char ~ Float + -- lhs = [Bool, Int, Char] + +These are obviously incompatible. We could detect this by saturating +(eta-expanding) the shorter LHS with fresh tyvars until the lists are of +equal length, but instead we can just remove the tail of the longer list, as +those types will simply unify with the freshly introduced tyvars. + +By doing this, in case the LHS are unifiable, the yielded substitution won't +mention the tyvars that appear in the tail we dropped off, and we might try +to test equality RHSes of different kinds, but that's fine since this case +occurs only for data families, where the RHS is a unique tycon and the equality +fails anyway. +-} + +-- See Note [Compatibility] +compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool +compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 + -- See Note [Compatibility of eta-reduced axioms] + in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of + SurelyApart -> True + Unifiable subst + | Type.substTyAddInScope subst rhs1 `eqType` + Type.substTyAddInScope subst rhs2 + -> True + _ -> False + +-- | Result of testing two type family equations for injectiviy. +data InjectivityCheckResult + = InjectivityAccepted + -- ^ Either RHSs are distinct or unification of RHSs leads to unification of + -- LHSs + | InjectivityUnified CoAxBranch CoAxBranch + -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for + -- closed type families where equation after unification might be + -- overlpapped (in which case it is OK if they don't unify). Constructor + -- stores axioms after unification. + +-- | Check whether two type family axioms don't violate injectivity annotation. +injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch + -> InjectivityCheckResult +injectiveBranches injectivity + ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + -- See Note [Verifying injectivity annotation], case 1. + = let getInjArgs = filterByList injectivity + in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification + Nothing -> InjectivityAccepted + -- RHS are different, so equations are injective. + -- This is case 1A from Note [Verifying injectivity annotation] + Just subst -> -- RHS unify under a substitution + let lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. + then InjectivityAccepted + else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + -- payload of InjectivityUnified used only for check 1B2, only + -- for closed type families + +-- takes a CoAxiom with unknown branch incompatibilities and computes +-- the compatibilities +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom +computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] +computeAxiomIncomps branches + = snd (mapAccumL go [] branches) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_brs cur_br + = (cur_br : prev_brs, new_br) + where + new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } + + mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] + mk_incomps prev_brs cur_br + = filter (not . compatibleBranches cur_br) prev_brs + +{- +************************************************************************ +* * + Constructing axioms + These functions are here because tidyType / tcUnifyTysFG + are not available in GHC.Core.Coercion.Axiom + + Also computeAxiomIncomps is too sophisticated for CoAxiom +* * +************************************************************************ + +Note [Tidy axioms when we build them] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Like types and classes, we build axioms fully quantified over all +their variables, and tidy them when we build them. For example, +we print out axioms and don't want to print stuff like + F k k a b = ... +Instead we must tidy those kind variables. See #7524. + +We could instead tidy when we print, but that makes it harder to get +things like injectivity errors to come out right. Danger of + Type family equation violates injectivity annotation. + Kind variable ‘k’ cannot be inferred from the right-hand side. + In the type family equation: + PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 + +Note [Always number wildcard types in CoAxBranch] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from the DataFamilyInstanceLHS test case): + + data family Sing (a :: k) + data instance Sing (_ :: MyKind) where + SingA :: Sing A + SingB :: Sing B + +If we're not careful during tidying, then when this program is compiled with +-ddump-types, we'll get the following information: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ + +It's misleading to have a wildcard type appearing on the RHS like +that. To avoid this issue, when building a CoAxiom (which is what eventually +gets printed above), we tidy all the variables in an env that already contains +'_'. Thus, any variable named '_' will be renamed, giving us the nicer output +here: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 + +Which is at least legal syntax. + +See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom; note that we +are tidying (changing OccNames only), not freshening, in accordance with +that Note. +-} + +-- all axiom roles are Nominal, as this is only used with type families +mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [TyVar] -- Extra eta tyvars + -> [CoVar] -- possibly stale covars + -> [Type] -- LHS patterns + -> Type -- RHS + -> [Role] + -> SrcSpan + -> CoAxBranch +mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc + = CoAxBranch { cab_tvs = tvs' + , cab_eta_tvs = eta_tvs' + , cab_cvs = cvs' + , cab_lhs = tidyTypes env lhs + , cab_roles = roles + , cab_rhs = tidyType env rhs + , cab_loc = loc + , cab_incomps = placeHolderIncomps } + where + (env1, tvs') = tidyVarBndrs init_tidy_env tvs + (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs + (env, cvs') = tidyVarBndrs env2 cvs + -- See Note [Tidy axioms when we build them] + -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom + + init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_tidy_env = mkEmptyTidyEnv init_occ_env + -- See Note [Always number wildcard types in CoAxBranch] + +-- all of the following code is here to avoid mutual dependencies with +-- Coercion +mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched +mkBranchedCoAxiom ax_name fam_tc branches + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = manyBranches (computeAxiomIncomps branches) } + +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + +mkSingleCoAxiom :: Role -> Name + -> [TyVar] -> [TyVar] -> [CoVar] + -> TyCon -> [Type] -> Type + -> CoAxiom Unbranched +-- Make a single-branch CoAxiom, including making the branch itself +-- Used for both type family (Nominal) and data family (Representational) +-- axioms, hence passing in the Role +mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = role + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty + (map (const Nominal) tvs) + (getSrcSpan ax_name) + +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched +mkNewTypeCoAxiom name tycon tvs roles rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon + , co_ax_role = Representational + , co_ax_tc = tycon + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty + roles (getSrcSpan name) + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +families), and then, it doesn't matter which match we choose (as the +instances are guaranteed confluent). + +We return the matching family instances and the type instance at which it +matches. For example, if we lookup 'T [Int]' and have a family instance + + data instance T [a] = .. + +desugared to + + data :R42T a = .. + coe :Co:R42T a :: T [a] ~ :R42T a + +we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. +-} + +-- when matching a type family application, we get a FamInst, +-- and the list of types the axiom should be applied to +data FamInstMatch = FamInstMatch { fim_instance :: FamInst + , fim_tys :: [Type] + , fim_cos :: [Coercion] + } + -- See Note [Over-saturated matches] + +instance Outputable FamInstMatch where + ppr (FamInstMatch { fim_instance = inst + , fim_tys = tys + , fim_cos = cos }) + = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos + +lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] +lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc + = get pkg_ie ++ get home_ie + where + get ie = case lookupUDFM ie fam_tc of + Nothing -> [] + Just (FamIE fis) -> fis + +lookupFamInstEnv + :: FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnv + = lookup_fam_inst_env match + where + match _ _ tpl_tys tys = tcMatchTys tpl_tys tys + +lookupFamInstEnvConflicts + :: FamInstEnvs + -> FamInst -- Putative new instance + -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) +-- E.g. when we are about to add +-- f : type instance F [a] = a->a +-- we do (lookupFamInstConflicts f [b]) +-- to find conflicting matches +-- +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) + = lookup_fam_inst_env my_unify envs fam tys + where + (fam, tys) = famInstSplitLHS fam_inst + -- In example above, fam tys' = F [b] + + my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys) ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch + then Nothing + else Just noSubst + -- Note [Family instance overlap conflicts] + + noSubst = panic "lookupFamInstEnvConflicts noSubst" + new_branch = coAxiomSingleBranch new_axiom + +-------------------------------------------------------------------------------- +-- Type family injectivity checking bits -- +-------------------------------------------------------------------------------- + +{- Note [Verifying injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Injectivity means that the RHS of a type family uniquely determines the LHS (see +Note [Type inference for type families with injectivity]). The user informs us about +injectivity using an injectivity annotation and it is GHC's task to verify that +this annotation is correct w.r.t. type family equations. Whenever we see a new +equation of a type family we need to make sure that adding this equation to the +already known equations of a type family does not violate the injectivity annotation +supplied by the user (see Note [Injectivity annotation]). Of course if the type +family has no injectivity annotation then no check is required. But if a type +family has injectivity annotation we need to make sure that the following +conditions hold: + +1. For each pair of *different* equations of a type family, one of the following + conditions holds: + + A: RHSs are different. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution + then it must be possible to unify the LHSs under the same substitution. + Example: + + type family FunnyId a = r | r -> a + type instance FunnyId Int = Int + type instance FunnyId a = a + + RHSs of these two equations unify under [ a |-> Int ] substitution. + Under this substitution LHSs are equal therefore these equations don't + violate injectivity annotation. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some + substitution then either the LHSs unify under the same substitution or + the LHS of the latter equation is overlapped by earlier equations. + Example 1: + + type family SwapIntChar a = r | r -> a where + SwapIntChar Int = Char + SwapIntChar Char = Int + SwapIntChar a = a + + Say we are checking the last two equations. RHSs unify under [ a |-> + Int ] substitution but LHSs don't. So we apply the substitution to LHS + of last equation and check whether it is overlapped by any of previous + equations. Since it is overlapped by the first equation we conclude + that pair of last two equations does not violate injectivity + annotation. (Check done in GHC.Tc.Validity.checkValidCoAxiom#gather_conflicts) + + A special case of B is when RHSs unify with an empty substitution ie. they + are identical. + + If any of the above two conditions holds we conclude that the pair of + equations does not violate injectivity annotation. But if we find a pair + of equations where neither of the above holds we report that this pair + violates injectivity annotation because for a given RHS we don't have a + unique LHS. (Note that (B) actually implies (A).) + + Note that we only take into account these LHS patterns that were declared + as injective. + +2. If an RHS of a type family equation is a bare type variable then + all LHS variables (including implicit kind variables) also have to be bare. + In other words, this has to be a sole equation of that type family and it has + to cover all possible patterns. So for example this definition will be + rejected: + + type family W1 a = r | r -> a + type instance W1 [a] = a + + If it were accepted we could call `W1 [W1 Int]`, which would reduce to + `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, + which is bogus. Checked FamInst.bareTvInRHSViolated. + +3. If the RHS of a type family equation is a type family application then the type + family is rejected as not injective. This is checked by FamInst.isTFHeaded. + +4. If a LHS type variable that is declared as injective is not mentioned in an + injective position in the RHS then the type family is rejected as not + injective. "Injective position" means either an argument to a type + constructor or argument to a type family on injective position. + There are subtleties here. See Note [Coverage condition for injective type families] + in GHC.Tc.Instance.Family. + +Check (1) must be done for all family instances (transitively) imported. Other +checks (2-4) should be done just for locally written equations, as they are checks +involving just a single equation, not about interactions. Doing the other checks for +imported equations led to #17405, as the behavior of check (4) depends on +-XUndecidableInstances (see Note [Coverage condition for injective type families] in +FamInst), which may vary between modules. + +See also Note [Injective type families] in GHC.Core.TyCon +-} + + +-- | Check whether an open type family equation can be added to already existing +-- instance environment without causing conflicts with supplied injectivity +-- annotations. Returns list of conflicting axioms (type instance +-- declarations). +lookupFamInstEnvInjectivityConflicts + :: [Bool] -- injectivity annotation for this type family instance + -- INVARIANT: list contains at least one True value + -> FamInstEnvs -- all type instances seens so far + -> FamInst -- new type instance that we're checking + -> [CoAxBranch] -- conflicting instance declarations +lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) + fam_inst@(FamInst { fi_axiom = new_axiom }) + -- See Note [Verifying injectivity annotation]. This function implements + -- check (1.B1) for open type families described there. + = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie + where + fam = famInstTyCon fam_inst + new_branch = coAxiomSingleBranch new_axiom + + -- filtering function used by `lookup_inj_fam_conflicts` to check whether + -- a pair of equations conflicts with the injectivity annotation. + isInjConflict (FamInst { fi_axiom = old_axiom }) + | InjectivityAccepted <- + injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch + = False -- no conflict + | otherwise = True + + lookup_inj_fam_conflicts ie + | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam + = map (coAxiomSingleBranch . fi_axiom) $ + filter isInjConflict insts + | otherwise = [] + + +-------------------------------------------------------------------------------- +-- Type family overlap checking bits -- +-------------------------------------------------------------------------------- + +{- +Note [Family instance overlap conflicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- In the case of data family instances, any overlap is fundamentally a + conflict (as these instances imply injective type mappings). + +- In the case of type family instances, overlap is admitted as long as + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg + type instance F a Int = a + type instance F Int b = b + These two overlap on (F Int Int) but then both RHSs are Int, + so all is well. We require that they are syntactically equal; + anything else would be difficult to test for at this stage. +-} + +------------------------------------------------------------ +-- Might be a one-way match or a unifier +type MatchFun = FamInst -- The FamInst template + -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst + -> [Type] -- Target to match against + -> Maybe TCvSubst + +lookup_fam_inst_env' -- The worker, local to this module + :: MatchFun + -> FamInstEnv + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] +lookup_fam_inst_env' match_fun ie fam match_tys + | isOpenFamilyTyCon fam + , Just (FamIE insts) <- lookupUDFM ie fam + = find insts -- The common case + | otherwise = [] + where + + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 + = (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 + , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + substCoVars subst tpl_cvs + }) + : find rest + + -- No match => try next + | otherwise + = find rest + where + (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) + + -- Deal with over-saturation + -- See Note [Over-saturated matches] + split_tys tpl_tys + | isTypeFamilyTyCon fam + = pre_rough_split_tys + + | otherwise + = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys + rough_tcs = roughMatchTcs match_tys1 + in (rough_tcs, match_tys1, match_tys2) + + (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys + pre_rough_split_tys + = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) + +lookup_fam_inst_env -- The worker, local to this module + :: MatchFun + -> FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches + +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys + = lookup_fam_inst_env' match_fun home_ie fam tys + ++ lookup_fam_inst_env' match_fun pkg_ie fam tys + +{- +Note [Over-saturated matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's ok to look up an over-saturated type constructor. E.g. + type family F a :: * -> * + type instance F (a,b) = Either (a->b) + +The type instance gives rise to a newtype TyCon (at a higher kind +which you can't do in Haskell!): + newtype FPair a b = FP (Either (a->b)) + +Then looking up (F (Int,Bool) Char) will return a FamInstMatch + (FPair, [Int,Bool,Char]) +The "extra" type argument [Char] just stays on the end. + +We handle data families and type families separately here: + + * For type families, all instances of a type family must have the + same arity, so we can precompute the split between the match_tys + and the overflow tys. This is done in pre_rough_split_tys. + + * For data family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see + Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. +-} + +-- checks if one LHS is dominated by a list of other branches +-- in other words, if an application would match the first LHS, it is guaranteed +-- to match at least one of the others. The RHSs are ignored. +-- This algorithm is conservative: +-- True -> the LHS is definitely covered by the others +-- False -> no information +-- It is currently (Oct 2012) used only for generating errors for +-- inaccessible branches. If these errors go unreported, no harm done. +-- This is defined here to avoid a dependency from CoAxiom to Unify +isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool +isDominatedBy branch branches + = or $ map match branches + where + lhs = coAxBranchLHS branch + match (CoAxBranch { cab_lhs = tys }) + = isJust $ tcMatchTys tys lhs + +{- +************************************************************************ +* * + Choosing an axiom application +* * +************************************************************************ + +The lookupFamInstEnv function does a nice job for *open* type families, +but we also need to handle closed ones when normalising a type: +-} + +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe (Coercion, Type) +-- Attempt to do a *one-step* reduction of a type-family application +-- but *not* newtypes +-- Works on type-synonym families always; data-families only if +-- the role we seek is representational +-- It does *not* normalise the type arguments first, so this may not +-- go as far as you want. If you want normalised type arguments, +-- use topReduceTyFamApp_maybe +-- +-- The TyCon can be oversaturated. +-- Works on both open and closed families +-- +-- Always returns a *homogeneous* coercion -- type family reductions are always +-- homogeneous +reduceTyFamApp_maybe envs role tc tys + | Phantom <- role + = Nothing + + | case role of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc + -- If we seek a representational coercion + -- (e.g. the call in topNormaliseType_maybe) then we can + -- unwrap data families as well as type-synonym families; + -- otherwise only type-synonym families + , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } + , fim_tys = inst_tys + , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys + -- NB: Allow multiple matches because of compatible overlap + + = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos + ty = coercionRKind co + in Just (co, ty) + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc + , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys inst_cos + ty = coercionRKind co + in Just (co, ty) + + | Just ax <- isBuiltInSynFamTyCon_maybe tc + , Just (coax,ts,ty) <- sfMatchFam ax tys + = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) + in Just (co, ty) + + | otherwise + = Nothing + +-- The axiom can be oversaturated. (Closed families only.) +chooseBranch :: CoAxiom Branched -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args +chooseBranch axiom tys + = do { let num_pats = coAxiomNumPats axiom + (target_tys, extra_tys) = splitAt num_pats tys + branches = coAxiomBranches axiom + ; (ind, inst_tys, inst_cos) + <- findBranch (unMkBranches branches) target_tys + ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } + +-- The axiom must *not* be oversaturated +findBranch :: Array BranchIndex CoAxBranch + -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) + -- coercions relate requested types to returned axiom LHS at role N +findBranch branches target_tys + = foldr go Nothing (assocs branches) + where + go :: (BranchIndex, CoAxBranch) + -> Maybe (BranchIndex, [Type], [Coercion]) + -> Maybe (BranchIndex, [Type], [Coercion]) + go (index, branch) other + = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs + , cab_lhs = tpl_lhs + , cab_incomps = incomps }) = branch + in_scope = mkInScopeSet (unionVarSets $ + map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + -- See Note [Flattening] below + flattened_target = flattenTys in_scope target_tys + in case tcMatchTys tpl_lhs target_tys of + Just subst -- matching worked. now, check for apartness. + | apartnessCheck flattened_target branch + -> -- matching worked & we're apart from all incompatible branches. + -- success + ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) + + -- failure. keep looking + _ -> other + +-- | Do an apartness check, as described in the "Closed Type Families" paper +-- (POPL '14). This should be used when determining if an equation +-- ('CoAxBranch') of a closed type family can be used to reduce a certain target +-- type family application. +apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure + -- they're flattened! See Note [Flattening]. + -- (NB: This "flat" is a different + -- "flat" than is used in GHC.Tc.Solver.Flatten.) + -> CoAxBranch -- ^ the candidate equation we wish to use + -- Precondition: this matches the target + -> Bool -- ^ True <=> equation can fire +apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) + = all (isSurelyApart + . tcUnifyTysFG (const BindMe) flattened_target + . coAxBranchLHS) incomps + where + isSurelyApart SurelyApart = True + isSurelyApart _ = False + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +Note [Normalising types] +~~~~~~~~~~~~~~~~~~~~~~~~ +The topNormaliseType function removes all occurrences of type families +and newtypes from the top-level structure of a type. normaliseTcApp does +the type family lookup and is fairly straightforward. normaliseType is +a little more involved. + +The complication comes from the fact that a type family might be used in the +kind of a variable bound in a forall. We wish to remove this type family +application, but that means coming up with a fresh variable (with the new +kind). Thus, we need a substitution to be built up as we recur through the +type. However, an ordinary TCvSubst just won't do: when we hit a type variable +whose kind has changed during normalisation, we need both the new type +variable *and* the coercion. We could conjure up a new VarEnv with just this +property, but a usable substitution environment already exists: +LiftingContexts from the liftCoSubst family of functions, defined in GHC.Core.Coercion. +A LiftingContext maps a type variable to a coercion and a coercion variable to +a pair of coercions. Let's ignore coercion variables for now. Because the +coercion a type variable maps to contains the destination type (via +coercionKind), we don't need to store that destination type separately. Thus, +a LiftingContext has what we need: a map from type variables to (Coercion, +Type) pairs. + +We also benefit because we can piggyback on the liftCoSubstVarBndr function to +deal with binders. However, I had to modify that function to work with this +application. Thus, we now have liftCoSubstVarBndrUsing, which takes +a function used to process the kind of the binder. We don't wish +to lift the kind, but instead normalise it. So, we pass in a callback function +that processes the kind of the binder. + +After that brilliant explanation of all this, I'm sure you've forgotten the +dangling reference to coercion variables. What do we do with those? Nothing at +all. The point of normalising types is to remove type family applications, but +there's no sense in removing these from coercions. We would just get back a +new coercion witnessing the equality between the same types as the original +coercion. Because coercions are irrelevant anyway, there is no point in doing +this. So, whenever we encounter a coercion, we just say that it won't change. +That's what the CoercionTy case is doing within normalise_type. + +Note [Normalisation and type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be a bit careful about normalising in the presence of type +synonyms (#13035). Suppose S is a type synonym, and we have + S t1 t2 +If S is family-free (on its RHS) we can just normalise t1 and t2 and +reconstruct (S t1' t2'). Expanding S could not reveal any new redexes +because type families are saturated. + +But if S has a type family on its RHS we expand /before/ normalising +the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them +after expansion, and that can lead to /exponential/ behaviour; see #13035. + +Notice, though, that expanding first can in principle duplicate t1,t2, +which might contain redexes. I'm sure you could conjure up an exponential +case by that route too, but it hasn't happened in practice yet! +-} + +topNormaliseType :: FamInstEnvs -> Type -> Type +topNormaliseType env ty = case topNormaliseType_maybe env ty of + Just (_co, ty') -> ty' + Nothing -> ty + +topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) + +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- returning an appropriate Representational coercion. Specifically, if +-- topNormaliseType_maybe env ty = Just (co, ty') +-- then +-- (a) co :: ty ~R ty' +-- (b) ty' is not a newtype, and is not a type-family or data-family redex +-- +-- However, ty' can be something like (Maybe (F ty)), where +-- (F ty) is a redex. +-- +-- Always operates homogeneously: the returned type has the same kind as the +-- original type, and the returned coercion is always homogeneous. +topNormaliseType_maybe env ty + = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty + ; return $ case mkind_co of + MRefl -> (co, nty) + MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo Representational nty + (mkSymCo kind_co) co + in (final_co, nty_casted) } + where + stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper + + combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) + + unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) + unwrapNewTypeStepper' rec_nts tc tys + = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys + + -- second coercion below is the kind coercion relating the original type's kind + -- to the normalised type's kind + tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) + tyFamStepper rec_nts tc tys -- Try to step a type/data family + = case topReduceTyFamApp_maybe env tc tys of + Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, MCo res_co) + _ -> NS_Done + +--------------- +normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) +-- See comments on normaliseType for the arguments of this function +normaliseTcApp env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_app tc tys + +-- See Note [Normalising types] about the LiftingContext +normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) +normalise_tc_app tc tys + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , not (isFamFreeTyCon tc) -- Expand and try again + = -- A synonym with type families in the RHS + -- Expand and try again + -- See Note [Normalisation and type synonyms] + normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + + | isFamilyTyCon tc + = -- A type-family application + do { env <- getEnv + ; role <- getRole + ; (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; case reduceTyFamApp_maybe env role tc ntys of + Just (first_co, ty') + -> do { (rest_co,nty) <- normalise_type ty' + ; return (assemble_result role nty + (args_co `mkTransCo` first_co `mkTransCo` rest_co) + res_co) } + _ -> -- No unique matching family instance exists; + -- we do not do anything + return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + | otherwise + = -- A synonym with no type families in the RHS; or data type etc + -- Just normalise the arguments and rebuild + do { (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; role <- getRole + ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + where + assemble_result :: Role -- r, ambient role in NormM monad + -> Type -- nty, result type, possibly of changed kind + -> Coercion -- orig_ty ~r nty, possibly heterogeneous + -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) + -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) + -- where nty_casted has same kind as orig_ty + assemble_result r nty orig_to_nty kind_co + = ( final_co, nty_old_kind ) + where + nty_old_kind = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty + +--------------- +-- | Try to simplify a type-family application, by *one* step +-- If topReduceTyFamApp_maybe env r F tys = Just (co, rhs, res_co) +-- then co :: F tys ~R# rhs +-- res_co :: typeKind(F tys) ~ typeKind(rhs) +-- Type families and data families; always Representational role +topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] + -> Maybe (Coercion, Type, Coercion) +topReduceTyFamApp_maybe envs fam_tc arg_tys + | isFamilyTyCon fam_tc -- type families and data families + , Just (co, rhs) <- reduceTyFamApp_maybe envs role fam_tc ntys + = Just (args_co `mkTransCo` co, rhs, res_co) + | otherwise + = Nothing + where + role = Representational + (args_co, ntys, res_co) = initNormM envs role (tyCoVarsOfTypes arg_tys) $ + normalise_tc_args fam_tc arg_tys + +normalise_tc_args :: TyCon -> [Type] -- tc tys + -> NormM (Coercion, [Type], CoercionN) + -- (co, new_tys), where + -- co :: tc tys ~ tc new_tys; might not be homogeneous + -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) +normalise_tc_args tc tys + = do { role <- getRole + ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys + ; return (mkTyConAppCo role tc args_cos, nargs, res_co) } + +--------------- +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> (Coercion, Type) +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +normalise_type :: Type -- old type + -> NormM (Coercion, Type) -- (coercion, new type), where + -- co :: old-type ~ new_type +-- Normalise the input type, by eliminating *all* type-function redexes +-- but *not* newtypes (which are visible to the programmer) +-- Returns with Refl if nothing happens +-- Does nothing to newtypes +-- The returned coercion *must* be *homogeneous* +-- See Note [Normalising types] +-- Try not to disturb type synonyms if possible + +normalise_type ty + = go ty + where + go (TyConApp tc tys) = normalise_tc_app tc tys + go ty@(LitTy {}) = do { r <- getRole + ; return (mkReflCo r ty, ty) } + go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] + + go ty@(FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) + = do { (co1, nty1) <- go ty1 + ; (co2, nty2) <- go ty2 + ; (wco, wty) <- withRole Nominal $ go w + ; r <- getRole + ; return (mkFunCo r wco co1 co2, ty { ft_mult = wty, ft_arg = nty1, ft_res = nty2 }) } + go (ForAllTy (Bndr tcvar vis) ty) + = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar + ; (co, nty) <- withLC lc' $ normalise_type ty + ; let tv2 = setTyVarKind tv' ki' + ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } + go (TyVarTy tv) = normalise_tyvar tv + go (CastTy ty co) + = do { (nco, nty) <- go ty + ; lc <- getLC + ; let co' = substRightCo lc co + ; return (castCoercionKind2 nco Nominal ty nty co co' + , mkCastTy nty co') } + go (CoercionTy co) + = do { lc <- getLC + ; r <- getRole + ; let right_co = substRightCo lc co + ; return ( mkProofIrrelCo r + (liftCoSubst Nominal lc (coercionType co)) + co right_co + , mkCoercionTy right_co ) } + + go_app_tys :: Type -- function + -> [Type] -- args + -> NormM (Coercion, Type) + -- cf. GHC.Tc.Solver.Flatten.flatten_app_ty_args + go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) + go_app_tys fun_ty arg_tys + = do { (fun_co, nfun) <- go fun_ty + ; case tcSplitTyConApp_maybe nfun of + Just (tc, xis) -> + do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys)) + -- flatten_app_ty_args avoids redundantly processing the xis, + -- but that's a much more performance-sensitive function. + -- This type normalisation is not called in a loop. + ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) } + Nothing -> + do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun) + (repeat Nominal) + arg_tys + ; role <- getRole + ; let nty = mkAppTys nfun nargs + nco = mkAppCos fun_co args_cos + nty_casted = nty `mkCastTy` mkSymCo res_co + final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco + ; return (final_co, nty_casted) } } + +normalise_args :: Kind -- of the function + -> [Role] -- roles at which to normalise args + -> [Type] -- args + -> NormM ([Coercion], [Type], Coercion) +-- returns (cos, xis, res_co), where each xi is the normalised +-- version of the corresponding type, each co is orig_arg ~ xi, +-- and the res_co :: kind(f orig_args) ~ kind(f xis) +-- NB: The xis might *not* have the same kinds as the input types, +-- but the resulting application *will* be well-kinded +-- cf. GHC.Tc.Solver.Flatten.flatten_args_slow +normalise_args fun_ki roles args + = do { normed_args <- zipWithM normalise1 roles args + ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args + ; return (map mkSymCo cos, xis, mkSymCo res_co) } + where + (ki_binders, inner_ki) = splitPiTys fun_ki + fvs = tyCoVarsOfTypes args + + -- flattener conventions are different from ours + impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion) + impedance_match action = do { (co, ty) <- action + ; return (ty, mkSymCo co) } + + normalise1 role ty + = impedance_match $ withRole role $ normalise_type ty + +normalise_tyvar :: TyVar -> NormM (Coercion, Type) +normalise_tyvar tv + = ASSERT( isTyVar tv ) + do { lc <- getLC + ; r <- getRole + ; return $ case liftCoSubstTyVar lc r tv of + Just co -> (co, coercionRKind co) + Nothing -> (mkReflCo r ty, ty) } + where ty = mkTyVarTy tv + +normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) +normalise_var_bndr tcvar + -- works for both tvar and covar + = do { lc1 <- getLC + ; env <- getEnv + ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal + ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } + +-- | a monad for the normalisation functions, reading 'FamInstEnvs', +-- a 'LiftingContext', and a 'Role'. +newtype NormM a = NormM { runNormM :: + FamInstEnvs -> LiftingContext -> Role -> a } + deriving (Functor) + +initNormM :: FamInstEnvs -> Role + -> TyCoVarSet -- the in-scope variables + -> NormM a -> a +initNormM env role vars (NormM thing_inside) + = thing_inside env lc role + where + in_scope = mkInScopeSet vars + lc = emptyLiftingContext in_scope + +getRole :: NormM Role +getRole = NormM (\ _ _ r -> r) + +getLC :: NormM LiftingContext +getLC = NormM (\ _ lc _ -> lc) + +getEnv :: NormM FamInstEnvs +getEnv = NormM (\ env _ _ -> env) + +withRole :: Role -> NormM a -> NormM a +withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r + +withLC :: LiftingContext -> NormM a -> NormM a +withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r + +instance Monad NormM where + ma >>= fmb = NormM $ \env lc r -> + let a = runNormM ma env lc r in + runNormM (fmb a) env lc r + +instance Applicative NormM where + pure x = NormM $ \ _ _ _ -> x + (<*>) = ap + +{- +************************************************************************ +* * + Flattening +* * +************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~ +As described in "Closed type families with overlapping equations" +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +we need to flatten core types before unifying them, when checking for "surely-apart" +against earlier equations of a closed type family. +Flattening means replacing all top-level uses of type functions with +fresh variables, *taking care to preserve sharing*. That is, the type +(Either (F a b) (F a b)) should flatten to (Either c c), never (Either +c d). + +Here is a nice example of why it's all necessary: + + type family F a b where + F Int Bool = Char + F a b = Double + type family G a -- open, no instances + +How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, +while the second equation does. But, before reducing, we must make sure that the +target can never become (F Int Bool). Well, no matter what G Float becomes, it +certainly won't become *both* Int and Bool, so indeed we're safe reducing +(F (G Float) (G Float)) to Double. + +This is necessary not only to get more reductions (which we might be +willing to give up on), but for substitutivity. If we have (F x x), we +can see that (F x x) can reduce to Double. So, it had better be the +case that (F blah blah) can reduce to Double, no matter what (blah) +is! Flattening as done below ensures this. + +The algorithm works by building up a TypeMap TyVar, mapping +type family applications to fresh variables. This mapping must +be threaded through all the function calls, as any entry in +the mapping must be propagated to all future nodes in the tree. + +The algorithm also must track the set of in-scope variables, in +order to make fresh variables as it flattens. (We are far from a +source of fresh Uniques.) See Wrinkle 2, below. + +There are wrinkles, of course: + +1. The flattening algorithm must account for the possibility + of inner `forall`s. (A `forall` seen here can happen only + because of impredicativity. However, the flattening operation + is an algorithm in Core, which is impredicative.) + Suppose we have (forall b. F b) -> (forall b. F b). Of course, + those two bs are entirely unrelated, and so we should certainly + not flatten the two calls F b to the same variable. Instead, they + must be treated separately. We thus carry a substitution that + freshens variables; we must apply this substitution (in + `coreFlattenTyFamApp`) before looking up an application in the environment. + Note that the range of the substitution contains only TyVars, never anything + else. + + For the sake of efficiency, we only apply this substitution when absolutely + necessary. Namely: + + * We do not perform the substitution at all if it is empty. + * We only need to worry about the arguments of a type family that are within + the arity of said type family, so we can get away with not applying the + substitution to any oversaturated type family arguments. + * Importantly, we do /not/ achieve this substitution by recursively + flattening the arguments, as this would be wrong. Consider `F (G a)`, + where F and G are type families. We might decide that `F (G a)` flattens + to `beta`. Later, the substitution is non-empty (but does not map `a`) and + so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course, + `F gamma` is unknown, and so we flatten it to `delta`, but it really + should have been `beta`! Argh! + + Moral of the story: instead of flattening the arguments, just substitute + them directly. + +2. There are two different reasons we might add a variable + to the in-scope set as we work: + + A. We have just invented a new flattening variable. + B. We have entered a `forall`. + + Annoying here is that in-scope variable source (A) must be + threaded through the calls. For example, consider (F b -> forall c. F c). + Suppose that, when flattening F b, we invent a fresh variable c. + Now, when we encounter (forall c. F c), we need to know c is already in + scope so that we locally rename c to c'. However, if we don't thread through + the in-scope set from one argument of (->) to the other, we won't know this + and might get very confused. + + In contrast, source (B) increases only as we go deeper, as in-scope sets + normally do. However, even here we must be careful. The TypeMap TyVar that + contains mappings from type family applications to freshened variables will + be threaded through both sides of (forall b. F b) -> (forall b. F b). We + thus must make sure that the two `b`s don't get renamed to the same b1. (If + they did, then looking up `F b1` would yield the same flatten var for + each.) So, even though `forall`-bound variables should really be in the + in-scope set only when they are in scope, we retain these variables even + outside of their scope. This ensures that, if we encounter a fresh + `forall`-bound b, we will rename it to b2, not b1. Note that keeping a + larger in-scope set than strictly necessary is always OK, as in-scope sets + are only ever used to avoid collisions. + + Sadly, the freshening substitution described in (1) really mustn't bind + variables outside of their scope: note that its domain is the *unrenamed* + variables. This means that the substitution gets "pushed down" (like a + reader monad) while the in-scope set gets threaded (like a state monad). + Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; + instead, we just carry a TvSubstEnv down, tying it to the InScopeSet + traveling separately as necessary. + +3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k: + + type family F ty_1 ... ty_k :: res_k + + It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a + flattening skolem. But we must instead flatten it to + `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the + type family. + + Why is this better? Consider the following concrete example from #16995: + + type family Param :: Type -> Type + + type family LookupParam (a :: Type) :: Type where + LookupParam (f Char) = Bool + LookupParam x = Int + + foo :: LookupParam (Param ()) + foo = 42 + + In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to + `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if + `alpha` is apart from `f Char`, so it won't fall through to the second + equation. But since the `Param` type family has arity 0, we can instead + flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is + apart from `f Char`, permitting the second equation to be reached. + + Not only does this allow more programs to be accepted, it's also important + for correctness. Not doing this was the root cause of the Core Lint error + in #16995. + +flattenTys is defined here because of module dependencies. +-} + +data FlattenEnv + = FlattenEnv { fe_type_map :: TypeMap TyVar + -- domain: exactly-saturated type family applications + -- range: fresh variables + , fe_in_scope :: InScopeSet } + -- See Note [Flattening] + +emptyFlattenEnv :: InScopeSet -> FlattenEnv +emptyFlattenEnv in_scope + = FlattenEnv { fe_type_map = emptyTypeMap + , fe_in_scope = in_scope } + +updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv +updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } + +flattenTys :: InScopeSet -> [Type] -> [Type] +-- See Note [Flattening] +-- NB: the returned types may mention fresh type variables, +-- arising from the flattening. We don't return the +-- mapping from those fresh vars to the ty-fam +-- applications they stand for (we could, but no need) +flattenTys in_scope tys + = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys + +coreFlattenTys :: TvSubstEnv -> FlattenEnv + -> [Type] -> (FlattenEnv, [Type]) +coreFlattenTys subst = mapAccumL (coreFlattenTy subst) + +coreFlattenTy :: TvSubstEnv -> FlattenEnv + -> Type -> (FlattenEnv, Type) +coreFlattenTy subst = go + where + go env ty | Just ty' <- coreView ty = go env ty' + + go env (TyVarTy tv) + | Just ty <- lookupVarEnv subst tv = (env, ty) + | otherwise = let (env', ki) = go env (tyVarKind tv) in + (env', mkTyVarTy $ setTyVarKind tv ki) + go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, AppTy ty1' ty2') + go env (TyConApp tc tys) + -- NB: Don't just check if isFamilyTyCon: this catches *data* families, + -- which are generative and thus can be preserved during flattening + | not (isGenerativeTyCon tc Nominal) + = coreFlattenTyFamApp subst env tc tys + + | otherwise + = let (env', tys') = coreFlattenTys subst env tys in + (env', mkTyConApp tc tys') + + go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) + = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 + (env3, mult') = go env2 mult in + (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' }) + + go env (ForAllTy (Bndr tv vis) ty) + = let (env1, subst', tv') = coreFlattenVarBndr subst env tv + (env2, ty') = coreFlattenTy subst' env1 ty in + (env2, ForAllTy (Bndr tv' vis) ty') + + go env ty@(LitTy {}) = (env, ty) + + go env (CastTy ty co) + = let (env1, ty') = go env ty + (env2, co') = coreFlattenCo subst env1 co in + (env2, CastTy ty' co') + + go env (CoercionTy co) + = let (env', co') = coreFlattenCo subst env co in + (env', CoercionTy co') + + +-- when flattening, we don't care about the contents of coercions. +-- so, just return a fresh variable of the right (flattened) type +coreFlattenCo :: TvSubstEnv -> FlattenEnv + -> Coercion -> (FlattenEnv, Coercion) +coreFlattenCo subst env co + = (env2, mkCoVarCo covar) + where + (env1, kind') = coreFlattenTy subst env (coercionType co) + covar = mkFlattenFreshCoVar (fe_in_scope env1) kind' + -- Add the covar to the FlattenEnv's in-scope set. + -- See Note [Flattening], wrinkle 2A. + env2 = updateInScopeSet env1 (flip extendInScopeSet covar) + +coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv + -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar) +coreFlattenVarBndr subst env tv + = (env2, subst', tv') + where + -- See Note [Flattening], wrinkle 2B. + kind = varType tv + (env1, kind') = coreFlattenTy subst env kind + tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') + subst' = extendVarEnv subst tv (mkTyVarTy tv') + env2 = updateInScopeSet env1 (flip extendInScopeSet tv') + +coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv + -> TyCon -- type family tycon + -> [Type] -- args, already flattened + -> (FlattenEnv, Type) +coreFlattenTyFamApp tv_subst env fam_tc fam_args + = case lookupTypeMap type_map fam_ty of + Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args') + Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc + tv = uniqAway in_scope $ + mkTyVar tyvar_name (typeKind fam_ty) + + ty' = mkAppTys (mkTyVarTy tv) leftover_args' + env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv + , fe_in_scope = extendInScopeSet in_scope tv } + in (env'', ty') + where + arity = tyConArity fam_tc + tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv + (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args ) + splitAt arity fam_args + -- Apply the substitution before looking up an application in the + -- environment. See Note [Flattening], wrinkle 1. + -- NB: substTys short-cuts the common case when the substitution is empty. + sat_fam_args' = substTys tcv_subst sat_fam_args + (env', leftover_args') = coreFlattenTys tv_subst env leftover_args + -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening], + -- wrinkle 3), so we split it into the arguments needed to saturate it + -- (sat_fam_args') and the rest (leftover_args') + fam_ty = mkTyConApp fam_tc sat_fam_args' + FlattenEnv { fe_type_map = type_map + , fe_in_scope = in_scope } = env' + +mkFlattenFreshTyName :: Uniquable a => a -> Name +mkFlattenFreshTyName unq + = mkSysTvName (getUnique unq) (fsLit "flt") + +mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar +mkFlattenFreshCoVar in_scope kind + = let uniq = unsafeGetFreshLocalUnique in_scope + name = mkSystemVarName uniq (fsLit "flc") + in mkCoVar name kind diff --git a/GHC/Core/InstEnv.hs b/GHC/Core/InstEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/InstEnv.hs @@ -0,0 +1,1040 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[InstEnv]{Utilities for typechecking instance declarations} + +The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module GHC.Core.InstEnv ( + DFunId, InstMatch, ClsInstLookupResult, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, + instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, + instanceDFunId, updateClsInstDFun, instanceRoughTcs, + fuzzyClsInstCmp, orphNamesOfClsInst, + + InstEnvs(..), VisibleOrphanModules, InstEnv, + emptyInstEnv, extendInstEnv, + deleteFromInstEnv, deleteDFunFromInstEnv, + identicalClsInstHead, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, + memberInstEnv, + instIsVisible, + classInstances, instanceBindFun, + instanceCantMatch, roughMatchTcs, + isOverlappable, isOverlapping, isIncoherent + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, + -- and depends on TcType in many ways +import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) +import GHC.Unit +import GHC.Core.Class +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Unique (getUnique) +import GHC.Core.Unify +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Types.Basic +import GHC.Types.Unique.DFM +import GHC.Utils.Misc +import GHC.Types.Id +import Data.Data ( Data ) +import Data.Maybe ( isJust, isNothing ) + +{- +************************************************************************ +* * + ClsInst: the data type for type-class instances +* * +************************************************************************ +-} + +-- | A type-class instance. Note that there is some tricky laziness at work +-- here. See Note [ClsInst laziness and the rough-match fields] for more +-- details. +data ClsInst + = ClsInst { -- Used for "rough matching"; see + -- Note [ClsInst laziness and the rough-match fields] + -- INVARIANT: is_tcs = roughMatchTcs is_tys + is_cls_nm :: Name -- ^ Class name + , is_tcs :: [Maybe Name] -- ^ Top of type args + + -- | @is_dfun_name = idName . is_dfun@. + -- + -- We use 'is_dfun_name' for the visibility check, + -- 'instIsVisible', which needs to know the 'Module' which the + -- dictionary is defined in. However, we cannot use the 'Module' + -- attached to 'is_dfun' since doing so would mean we would + -- potentially pull in an entire interface file unnecessarily. + -- This was the cause of #12367. + , is_dfun_name :: Name + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: [TyVar] -- Fresh template tyvars for full match + -- See Note [Template tyvars are fresh] + , is_cls :: Class -- The real class + , is_tys :: [Type] -- Full arg types (mentioning is_tvs) + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + -- (modulo alpha conversion) + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag + , is_orphan :: IsOrphan + } + deriving Data + +-- | A fuzzy comparison function for class instances, intended for sorting +-- instances before displaying them to the user. +fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering +fuzzyClsInstCmp x y = + stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` + mconcat (map cmp (zip (is_tcs x) (is_tcs y))) + where + cmp (Nothing, Nothing) = EQ + cmp (Nothing, Just _) = LT + cmp (Just _, Nothing) = GT + cmp (Just x, Just y) = stableNameCmp x y + +isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool +isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) +isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) +isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) + +{- +Note [ClsInst laziness and the rough-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is +otherwise unused in the program. Then it's stupid to load B.hi, the data type +declaration for B.T -- and perhaps further instance declarations! + +We avoid this as follows: + +* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's + content. + +* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys + contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we + poke any of these fields we'll typecheck the DFunId declaration, and hence + pull in interfaces that it refers to. See Note [Proper-match fields]. + +* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and + is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking + inside the DFunId. The rough-match fields allow us to say "definitely does not + match", based only on Names. + + This laziness is very important; see #12367. Try hard to avoid pulling on + the structured fields unless you really need the instance. + +* Another place to watch is InstEnv.instIsVisible, which needs the module to + which the ClsInst belongs. We can get this from is_dfun_name. + +* In is_tcs, + Nothing means that this type arg is a type variable + + (Just n) means that this type arg is a + TyConApp with a type constructor of n. + This is always a real tycon, never a synonym! + (Two different synonyms might match, but two + different real tycons can't.) + NB: newtypes are not transparent, though! +-} + +{- +Note [Template tyvars are fresh] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs field of a ClsInst has *completely fresh* tyvars. +That is, they are + * distinct from any other ClsInst + * distinct from any tyvars free in predicates that may + be looked up in the class instance environment +Reason for freshness: we use unification when checking for overlap +etc, and that requires the tyvars to be distinct. + +The invariant is checked by the ASSERT in lookupInstEnv'. + +Note [Proper-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs, is_cls, is_tys fields are simply cached values, pulled +out (lazily) from the dfun id. They are cached here simply so +that we don't need to decompose the DFunId each time we want +to match it. The hope is that the rough-match fields mean +that we often never poke the proper-match fields. + +However, note that: + * is_tvs must be a superset of the free vars of is_tys + + * is_tvs, is_tys may be alpha-renamed compared to the ones in + the dfun Id + +Note [Haddock assumptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For normal user-written instances, Haddock relies on + + * the SrcSpan of + * the Name of + * the is_dfun of + * an Instance + +being equal to + + * the SrcSpan of + * the instance head type of + * the InstDecl used to construct the Instance. +-} + +instanceDFunId :: ClsInst -> DFunId +instanceDFunId = is_dfun + +updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst +updateClsInstDFun tidy_dfun ispec + = ispec { is_dfun = tidy_dfun (is_dfun ispec) } + +instanceRoughTcs :: ClsInst -> [Maybe Name] +instanceRoughTcs = is_tcs + + +instance NamedThing ClsInst where + getName ispec = getName (is_dfun ispec) + +instance Outputable ClsInst where + ppr = pprInstance + +pprInstance :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstance ispec + = hang (pprInstanceHdr ispec) + 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) + , whenPprDebug (ppr (is_dfun ispec)) ]) + +-- * pprInstanceHdr is used in VStudio to populate the ClassView tree +pprInstanceHdr :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) + = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) + +pprInstances :: [ClsInst] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceHead :: ClsInst -> ([TyVar], Class, [Type]) +-- Returns the head, using the fresh tyavs from the ClsInst +instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) + = (tvs, cls, tys) + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + +-- | Collects the names of concrete types and type constructors that make +-- up the head of a class instance. For instance, given `class Foo a b`: +-- +-- `instance Foo (Either (Maybe Int) a) Bool` would yield +-- [Either, Maybe, Int, Bool] +-- +-- Used in the implementation of ":info" in GHCi. +-- +-- The 'tcSplitSigmaTy' is because of +-- instance Foo a => Baz T where ... +-- The decl is an orphan if Baz and T are both not locally defined, +-- even if Foo *is* locally defined +orphNamesOfClsInst :: ClsInst -> NameSet +orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) + = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm + +instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) +-- Decomposes the DFunId +instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalInstance :: DFunId -> OverlapFlag + -> [TyVar] -> Class -> [Type] + -> ClsInst +-- Used for local instances, where we can safely pull on the DFunId. +-- Consider using newClsInst instead; this will also warn if +-- the instance is an orphan. +mkLocalInstance dfun oflag tvs cls tys + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs + , is_dfun_name = dfun_name + , is_cls = cls, is_cls_nm = cls_name + , is_tys = tys, is_tcs = roughMatchTcs tys + , is_orphan = orph + } + where + cls_name = className cls + dfun_name = idName dfun + this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name + is_local name = nameIsLocalOrFrom this_mod name + + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + (cls_tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] + + -- See Note [When exactly is an instance decl an orphan?] + orph | is_local cls_name = NotOrphan (nameOccName cls_name) + | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns + | otherwise = IsOrphan + + notOrphan NotOrphan{} = True + notOrphan _ = False + + mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns | null fds = [choose_one arg_names] + | otherwise = map do_one fds + do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names + , not (tv `elem` rtvs)] + + choose_one nss = chooseOrphanAnchor (unionNameSets nss) + +mkImportedInstance :: Name -- ^ the name of the class + -> [Maybe Name] -- ^ the types which the class was applied to + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? + -> ClsInst +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +-- The bound tyvars of the dfun are guaranteed fresh, because +-- the dfun has been typechecked out of the same interface file +mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs, is_tys = tys + , is_dfun_name = dfun_name + , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs + , is_orphan = orphan } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + +{- +Note [When exactly is an instance decl an orphan?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + (see GHC.Iface.Make.instanceToIfaceInst, which implements this) +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. + +Functional dependencies complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) + + +************************************************************************ +* * + InstEnv, ClsInstEnv +* * +************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun +-} + +--------------------------------------------------- +{- +Note [InstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn InstEnvs into a list in some places that don't directly affect +the ABI. That happens when we create output for `:info`. +Unfortunately that nondeterminism is nonlocal and it's hard to tell what it +affects without following a chain of functions. It's also easy to accidentally +make that nondeterminism affect the ABI. Furthermore the envs should be +relatively small, so it should be free to use deterministic maps here. +Testing with nofib and validate detected no difference between UniqFM and +UniqDFM. See also Note [Deterministic UniqFM] +-} + +-- Internally it's safe to indexable this map by +-- by @Class@, the classes @Name@, the classes @TyCon@ +-- or it's @Unique@. +-- This is since: +-- getUnique cls == getUnique (className cls) == getUnique (classTyCon cls) +-- +-- We still use Class as key type as it's both the common case +-- and conveys the meaning better. But the implementation of +--InstEnv is a bit more lax internally. +type InstEnv = UniqDFM Class ClsInstEnv -- Maps Class to instances for that class + -- See Note [InstEnv determinism] + +-- | 'InstEnvs' represents the combination of the global type class instance +-- environment, the local type class instance environment, and the set of +-- transitively reachable orphan modules (according to what modules have been +-- directly imported) used to test orphan instance visibility. +data InstEnvs = InstEnvs { + ie_global :: InstEnv, -- External-package instances + ie_local :: InstEnv, -- Home-package instances + ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively + -- reachable from the module being compiled + -- See Note [Instance lookup and orphan instances] + } + +-- | Set of visible orphan modules, according to what modules have been directly +-- imported. This is based off of the dep_orphs field, which records +-- transitively reachable orphan modules (modules that define orphan instances). +type VisibleOrphanModules = ModuleSet + +newtype ClsInstEnv + = ClsIE [ClsInst] -- The instances for a particular class, in any order + +instance Outputable ClsInstEnv where + ppr (ClsIE is) = pprInstances is + +-- INVARIANTS: +-- * The is_tvs are distinct in each ClsInst +-- of a ClsInstEnv (so we can safely unify them) + +-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: +-- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +-- The "a" in the pattern must be one of the forall'd variables in +-- the dfun type. + +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUDFM + +instEnvElts :: InstEnv -> [ClsInst] +instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] + -- See Note [InstEnv determinism] + +instEnvClasses :: InstEnv -> [Class] +instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie] + +-- | Test if an instance is visible, by checking that its origin module +-- is in 'VisibleOrphanModules'. +-- See Note [Instance lookup and orphan instances] +instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool +instIsVisible vis_mods ispec + -- NB: Instances from the interactive package always are visible. We can't + -- add interactive modules to the set since we keep creating new ones + -- as a GHCi session progresses. + = case nameModule_maybe (is_dfun_name ispec) of + Nothing -> True + Just mod | isInteractiveModule mod -> True + | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods + | otherwise -> True + +classInstances :: InstEnvs -> Class -> [ClsInst] +classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUDFM env cls of + Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts + Nothing -> [] + +-- | Checks for an exact match of ClsInst in the instance environment. +-- We use this when we do signature checking in "GHC.Tc.Module" +memberInstEnv :: InstEnv -> ClsInst -> Bool +memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = + maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) + (lookupUDFM_Directly inst_env (getUnique cls_nm)) + where + identicalDFunType cls1 cls2 = + eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) + +extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv +extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs + +extendInstEnv :: InstEnv -> ClsInst -> InstEnv +extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = addToUDFM_C_Directly add inst_env (getUnique cls_nm) (ClsIE [ins_item]) + where + add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) + +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = adjustUDFM_Directly adjust inst_env (getUnique cls_nm) + where + adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) + +deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv +-- Delete a specific instance fron an InstEnv +deleteDFunFromInstEnv inst_env dfun + = adjustUDFM adjust inst_env cls + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + adjust (ClsIE items) = ClsIE (filterOut same_dfun items) + same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' + +identicalClsInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Used for overriding in GHCi +-- Obviously should be insensitive to alpha-renaming +identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) + (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) + = cls_nm1 == cls_nm2 + && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields + && isJust (tcMatchTys tys1 tys2) + && isJust (tcMatchTys tys2 tys1) + +{- +************************************************************************ +* * + Looking up an instance +* * +************************************************************************ + +@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since +the env is kept ordered, the first match must be the only one. The +thing we are looking up can have an arbitrary "flexi" part. + +Note [Instance lookup and orphan instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are compiling a module M, and we have a zillion packages +loaded, and we are looking up an instance for C (T W). If we find a +match in module 'X' from package 'p', should be "in scope"; that is, + + is p:X in the transitive closure of modules imported from M? + +The difficulty is that the "zillion packages" might include ones loaded +through earlier invocations of the GHC API, or earlier module loads in GHCi. +They might not be in the dependencies of M itself; and if not, the instances +in them should not be visible. #2182, #8427. + +There are two cases: + * If the instance is *not an orphan*, then module X defines C, T, or W. + And in order for those types to be involved in typechecking M, it + must be that X is in the transitive closure of M's imports. So we + can use the instance. + + * If the instance *is an orphan*, the above reasoning does not apply. + So we keep track of the set of orphan modules transitively below M; + this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. + + If module p:X is in this set, then we can use the instance, otherwise + we can't. + +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled as follows: + + * An instance is "incoherent" + if it has an INCOHERENT pragma, or + if it appears in a module compiled with -XIncoherentInstances. + + * An instance is "overlappable" + if it has an OVERLAPPABLE or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + + * An instance is "overlapping" + if it has an OVERLAPPING or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + compiled with -XOverlappingInstances. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + +* Find all instances `I` that *match* the target constraint; that is, the + target constraint is a substitution instance of `I`. These instance + declarations are the *candidates*. + +* Eliminate any candidate `IX` for which both of the following hold: + + - There is another candidate `IY` that is strictly more specific; that + is, `IY` is a substitution instance of `IX` but not vice versa. + + - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This + "either/or" design, rather than a "both/and" design, allow a + client to deliberately override an instance from a library, + without requiring a change to the library.) + +- If exactly one non-incoherent candidate remains, select it. If all + remaining candidates are incoherent, select an arbitrary one. + Otherwise the search fails (i.e. when more than one surviving + candidate is not incoherent). + +- If the selected candidate (from the previous step) is incoherent, the + search succeeds, returning that candidate. + +- If not, find all instances that *unify* with the target constraint, + but do not *match* it. Such non-candidate instances might match when + the target constraint is further instantiated. If all of them are + incoherent, the search succeeds, returning the selected candidate; if + not, the search fails. + +Notice that these rules are not influenced by flag settings in the +client module, where the instances are *used*. These rules make it +possible for a library author to design a library that relies on +overlapping instances without the client having to know. + +Note [Overlapping instances] (NB: these notes are quite old) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + +For now we just use association lists. + +\subsection{Avoiding a problem with overlapping} + +Consider this little program: + +\begin{pseudocode} + class C a where c :: a + class C a => D a where d :: a + + instance C Int where c = 17 + instance D Int where d = 13 + + instance C a => C [a] where c = [c] + instance ({- C [a], -} D a) => D [a] where d = c + + instance C [Int] where c = [37] + + main = print (d :: [Int]) +\end{pseudocode} + +What do you think `main' prints (assuming we have overlapping instances, and +all that turned on)? Well, the instance for `D' at type `[a]' is defined to +be `c' at the same type, and we've got an instance of `C' at `[Int]', so the +answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because +the `C [Int]' instance is more specific). + +Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That +was easy ;-) Let's just consult hugs for good measure. Wait - if I use old +hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it +doesn't even compile! What's going on!? + +What hugs complains about is the `D [a]' instance decl. + +\begin{pseudocode} + ERROR "mj.hs" (line 10): Cannot build superclass instance + *** Instance : D [a] + *** Context supplied : D a + *** Required superclass : C [a] +\end{pseudocode} + +You might wonder what hugs is complaining about. It's saying that you +need to add `C [a]' to the context of the `D [a]' instance (as appears +in comments). But there's that `C [a]' instance decl one line above +that says that I can reduce the need for a `C [a]' instance to the +need for a `C a' instance, and in this case, I already have the +necessary `C a' instance (since we have `D a' explicitly in the +context, and `C' is a superclass of `D'). + +Unfortunately, the above reasoning indicates a premature commitment to the +generic `C [a]' instance. I.e., it prematurely rules out the more specific +instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to +add the context that hugs suggests (uncomment the `C [a]'), effectively +deferring the decision about which instance to use. + +Now, interestingly enough, 4.04 has this same bug, but it's covered up +in this case by a little known `optimization' that was disabled in +4.06. Ghc-4.04 silently inserts any missing superclass context into +an instance declaration. In this case, it silently inserts the `C +[a]', and everything happens to work out. + +(See `GHC.Types.Id.Make.mkDictFunId' for the code in question. Search for +`Mark Jones', although Mark claims no credit for the `optimization' in +question, and would rather it stopped being called the `Mark Jones +optimization' ;-) + +So, what's the fix? I think hugs has it right. Here's why. Let's try +something else out with ghc-4.04. Let's add the following line: + + d' :: D a => [a] + d' = c + +Everyone raise their hand who thinks that `d :: [Int]' should give a +different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The +`optimization' only applies to instance decls, not to regular +bindings, giving inconsistent behavior. + +Old hugs had this same bug. Here's how we fixed it: like GHC, the +list of instances for a given class is ordered, so that more specific +instances come before more generic ones. For example, the instance +list for C might contain: + ..., C Int, ..., C a, ... +When we go to look for a `C Int' instance we'll get that one first. +But what if we go looking for a `C b' (`b' is unconstrained)? We'll +pass the `C Int' instance, and keep going. But if `b' is +unconstrained, then we don't know yet if the more specific instance +will eventually apply. GHC keeps going, and matches on the generic `C +a'. The fix is to, at each step, check to see if there's a reverse +match, and if so, abort the search. This prevents hugs from +prematurely choosing a generic instance when a more specific one +exists. + +--Jeff + +BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in +this test. Suppose the instance envt had + ..., forall a b. C a a b, ..., forall a b c. C a b c, ... +(still most specific first) +Now suppose we are looking for (C x y Int), where x and y are unconstrained. + C x y Int doesn't match the template {a,b} C a a b +but neither does + C a a b match the template {x,y} C x y Int +But still x and y might subsequently be unified so they *do* match. + +Simple story: unify, don't match. +-} + +type DFunInstType = Maybe Type + -- Just ty => Instantiate with this type + -- Nothing => Instantiate with any type of this tyvar's kind + -- See Note [DFunInstType: instantiating types] + +type InstMatch = (ClsInst, [DFunInstType]) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , [ClsInst] -- These don't match but do unify + , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell + -- (see Note [Safe Haskell Overlapping Instances] in + -- GHC.Tc.Solver). + +{- +Note [DFunInstType: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A successful match is a ClsInst, together with the types at which + the dfun_id in the ClsInst should be instantiated +The instantiating types are (Either TyVar Type)s because the dfun +might have some tyvars that *only* appear in arguments + dfun :: forall a b. C a b, Ord b => D [a] +When we match this against D [ty], we return the instantiating types + [Just ty, Nothing] +where the 'Nothing' indicates that 'b' can be freely instantiated. +(The caller instantiates it to a flexi type variable, which will + presumably later become fixed via functional dependencies.) +-} + +-- |Look up an instance in the given instance environment. The given class application must match exactly +-- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, +-- yield 'Left errorMessage'. +lookupUniqueInstEnv :: InstEnvs + -> Class -> [Type] + -> Either MsgDoc (ClsInst, [Type]) +lookupUniqueInstEnv instEnv cls tys + = case lookupInstEnv False instEnv cls tys of + ([(inst, inst_tys)], _, _) + | noFlexiVar -> Right (inst, inst_tys') + | otherwise -> Left $ text "flexible type variable:" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + where + inst_tys' = [ty | Just ty <- inst_tys] + noFlexiVar = all isJust inst_tys + _other -> Left $ text "instance not found" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + +lookupInstEnv' :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [ClsInst]) -- These don't match but do unify + -- (no incoherent ones in here) +-- The second component of the result pair happens when we look up +-- Foo [a] +-- in an InstEnv that has entries for +-- Foo [Int] +-- Foo [b] +-- Then which we choose would depend on the way in which 'a' +-- is instantiated. So we report that Foo [b] is a match (mapping b->a) +-- but Foo [Int] is a unifier. This gives the caller a better chance of +-- giving a suitable error message + +lookupInstEnv' ie vis_mods cls tys + = lookup ie + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + + -------------- + lookup env = case lookupUDFM env cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts) -> find [] [] insts + + -------------- + find ms us [] = (ms, us) + find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs + , is_tys = tpl_tys }) : rest) + | not (instIsVisible vis_mods item) + = find ms us rest -- See Note [Instance lookup and orphan instances] + + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find ms us rest + + | Just subst <- tcMatchTys tpl_tys tys + = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest + + -- Does not match, so next check whether the things unify + -- See Note [Overlapping instances] + -- Ignore ones that are incoherent: Note [Incoherent instances] + | isIncoherent item + = find ms us rest + + | otherwise + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, + (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr tpl_tvs <+> ppr tpl_tys) + ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + -- See Note [Template tyvars are fresh] + case tcUnifyTys instanceBindFun tpl_tys tys of + Just _ -> find ms (item:us) rest + Nothing -> find ms us rest + where + tpl_tv_set = mkVarSet tpl_tvs + +--------------- +-- This is the common way to call this function. +lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions + -> InstEnvs -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult +-- ^ See Note [Rules for instance lookup] +-- ^ See Note [Safe Haskell Overlapping Instances] in "GHC.Tc.Solver" +-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in "GHC.Tc.Solver" +lookupInstEnv check_overlap_safe + (InstEnvs { ie_global = pkg_ie + , ie_local = home_ie + , ie_visible = vis_mods }) + cls + tys + = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ + (final_matches, final_unifs, unsafe_overlapped) + where + (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + final_matches = foldr insert_overlapping [] all_matches + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + unsafe_overlapped + = case final_matches of + [match] -> check_safe match + _ -> [] + + -- If the selected match is incoherent, discard all unifiers + final_unifs = case final_matches of + (m:_) | isIncoherent (fst m) -> [] + _ -> all_unifs + + -- NOTE [Safe Haskell isSafeOverlap] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We restrict code compiled in 'Safe' mode from overriding code + -- compiled in any other mode. The rationale is that code compiled + -- in 'Safe' mode is code that is untrusted by the ghc user. So + -- we shouldn't let that code change the behaviour of code the + -- user didn't compile in 'Safe' mode since that's the code they + -- trust. So 'Safe' instances can only overlap instances from the + -- same module. A same instance origin policy for safe compiled + -- instances. + check_safe (inst,_) + = case check_overlap_safe && unsafeTopInstance inst of + -- make sure it only overlaps instances from the same module + True -> go [] all_matches + -- most specific is from a trusted location. + False -> [] + where + go bad [] = bad + go bad (i@(x,_):unchecked) = + if inSameMod x || isOverlappable x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + + -- We consider the most specific instance unsafe when it both: + -- (1) Comes from a module compiled as `Safe` + -- (2) Is an orphan instance, OR, an instance for a MPTC + unsafeTopInstance inst = isSafeOverlap (is_flag inst) && + (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) + +--------------- +insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) + | new_beats_old -- New strictly overrides old + , not old_beats_new + , new_inst `can_override` old_inst + = insert_overlapping new_item old_items + + | old_beats_new -- Old strictly overrides new + , not new_beats_old + , old_inst `can_override` new_inst + = old_item : old_items + + -- Discard incoherent instances; see Note [Incoherent instances] + | isIncoherent old_inst -- Old is incoherent; discard it + = insert_overlapping new_item old_items + | isIncoherent new_inst -- New is incoherent; discard it + = old_item : old_items + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + = old_item : insert_overlapping new_item old_items + where + + new_beats_old = new_inst `more_specific_than` old_inst + old_beats_new = old_inst `more_specific_than` new_inst + + -- `instB` can be instantiated to match `instA` + -- or the two are equal + instA `more_specific_than` instB + = isJust (tcMatchTys (is_tys instB) (is_tys instA)) + + instA `can_override` instB + = isOverlapping instA || isOverlappable instB + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: #9242. + -- Previous change: #3877, Dec 10. + +{- +Note [Incoherent instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some classes, the choice of a particular instance does not matter, any one +is good. E.g. consider + + class D a b where { opD :: a -> b -> String } + instance D Int b where ... + instance D a Int where ... + + g (x::Int) = opD x x -- Wanted: D Int Int + +For such classes this should work (without having to add an "instance D Int +Int", and using -XOverlappingInstances, which would then work). This is what +-XIncoherentInstances is for: Telling GHC "I don't care which instance you use; +if you can use one, use it." + +Should this logic only work when *all* candidates have the incoherent flag, or +even when all but one have it? The right choice is the latter, which can be +justified by comparing the behaviour with how -XIncoherentInstances worked when +it was only about the unify-check (note [Overlapping instances]): + +Example: + class C a b c where foo :: (a,b,c) + instance C [a] b Int + instance [incoherent] [Int] b c + instance [incoherent] C a Int c +Thanks to the incoherent flags, + [Wanted] C [a] b Int +works: Only instance one matches, the others just unify, but are marked +incoherent. + +So I can write + (foo :: ([a],b,Int)) :: ([Int], Int, Int). +but if that works then I really want to be able to write + foo :: ([Int], Int, Int) +as well. Now all three instances from above match. None is more specific than +another, so none is ruled out by the normal overlapping rules. One of them is +not incoherent, but we still want this to compile. Hence the +"all-but-one-logic". + +The implementation is in insert_overlapping, where we remove matching +incoherent instances as long as there are others. + + + +************************************************************************ +* * + Binding decisions +* * +************************************************************************ +-} + +instanceBindFun :: TyCoVar -> BindFlag +instanceBindFun tv | isOverlappableTyVar tv = Skolem + | otherwise = BindMe + -- Note [Binding when looking up instances] + +{- +Note [Binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When looking up in the instance environment, or family-instance environment, +we are careful about multiple matches, as described above in +Note [Overlapping instances] + +The key_tys can contain skolem constants, and we can guarantee that those +are never going to be instantiated to anything, so we should not involve +them in the unification test. Example: + class Foo a where { op :: a -> Int } + instance Foo a => Foo [a] -- NB overlap + instance Foo [Int] -- NB overlap + data T = forall a. Foo a => MkT a + f :: T -> Int + f (MkT x) = op [x,x] +The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd +complain, saying that the choice of instance depended on the instantiation +of 'a'; but of course it isn't *going* to be instantiated. + +We do this only for isOverlappableTyVar skolems. For example we reject + g :: forall a => [a] -> Int + g x = op x +on the grounds that the correct instance depends on the instantiation of 'a' +-} diff --git a/GHC/Core/Lint.hs b/GHC/Core/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Lint.hs @@ -0,0 +1,3333 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns, ScopedTypeVariables, DeriveFunctor, MultiWayIf #-} + +module GHC.Core.Lint ( + lintCoreBindings, lintUnfolding, + lintPassResult, lintInteractiveExpr, lintExpr, + lintAnnots, lintAxioms, + + -- ** Debug output + endPass, endPassIO, + dumpPassResult, + GHC.Core.Lint.dumpIfSet, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Stats ( coreBindsStats ) +import GHC.Core.Opt.Monad +import GHC.Data.Bag +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types ( multiplicityTy ) +import GHC.Tc.Utils.TcType ( isFloatingTy, isTyFamFree ) +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Ppr +import GHC.Utils.Error +import GHC.Core.Coercion +import GHC.Types.SrcLoc +import GHC.Core.Type as Type +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Types.RepType +import GHC.Core.TyCo.Rep -- checks validity of types/coercions +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) +import GHC.Core.TyCon as TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.Unify +import GHC.Types.Basic +import GHC.Utils.Error as Err +import GHC.Data.List.SetOps +import GHC.Builtin.Names +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Core.InstEnv ( instanceDFunId ) +import GHC.Core.Coercion.Opt ( checkAxInstCo ) +import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv ) + +import GHC.Driver.Types hiding (Usage) +import GHC.Driver.Session +import Control.Monad +import GHC.Utils.Monad +import Data.Foldable ( toList ) +import Data.List.NonEmpty ( NonEmpty(..), groupWith ) +import Data.List ( partition ) +import Data.Maybe +import GHC.Data.Pair +import qualified GHC.LanguageExtensions as LangExt + +{- +Note [Core Lint guarantee] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Core Lint is the type-checker for Core. Using it, we get the following guarantee: + +If all of: +1. Core Lint passes, +2. there are no unsafe coercions (i.e. unsafeEqualityProof), +3. all plugin-supplied coercions (i.e. PluginProv) are valid, and +4. all case-matches are complete +then running the compiled program will not seg-fault, assuming no bugs downstream +(e.g. in the code generator). This guarantee is quite powerful, in that it allows us +to decouple the safety of the resulting program from the type inference algorithm. + +However, do note point (4) above. Core Lint does not check for incomplete case-matches; +see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, +an incomplete case-match might slip by Core Lint and cause trouble at runtime. + +Note [GHC Formalism] +~~~~~~~~~~~~~~~~~~~~ +This file implements the type-checking algorithm for System FC, the "official" +name of the Core language. Type safety of FC is heart of the claim that +executables produced by GHC do not have segmentation faults. Thus, it is +useful to be able to reason about System FC independently of reading the code. +To this purpose, there is a document core-spec.pdf built in docs/core-spec that +contains a formalism of the types and functions dealt with here. If you change +just about anything in this file or you change other types/functions throughout +the Core language (all signposted to this note), you should update that +formalism. See docs/core-spec/README for more info about how to do so. + +Note [check vs lint] +~~~~~~~~~~~~~~~~~~~~ +This file implements both a type checking algorithm and also general sanity +checking. For example, the "sanity checking" checks for TyConApp on the left +of an AppTy, which should never happen. These sanity checks don't really +affect any notion of type soundness. Yet, it is convenient to do the sanity +checks at the same time as the type checks. So, we use the following naming +convention: + +- Functions that begin with 'lint'... are involved in type checking. These + functions might also do some sanity checking. + +- Functions that begin with 'check'... are *not* involved in type checking. + They exist only for sanity checking. + +Issues surrounding variable naming, shadowing, and such are considered *not* +to be part of type checking, as the formalism omits these details. + +Summary of checks +~~~~~~~~~~~~~~~~~ +Checks that a set of core bindings is well-formed. The PprStyle and String +just control what we print in the event of an error. The Bool value +indicates whether we have done any specialisation yet (in which case we do +some extra checks). + +We check for + (a) type errors + (b) Out-of-scope type variables + (c) Out-of-scope local variables + (d) Ill-kinded types + (e) Incorrect unsafe coercions + +If we have done specialisation the we check that there are + (a) No top-level bindings of primitive (unboxed type) + +Outstanding issues: + + -- Things are *not* OK if: + -- + -- * Unsaturated type app before specialisation has been done; + -- + -- * Oversaturated type app after specialisation (eta reduction + -- may well be happening...); + + +Note [Linting function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Representation of function types], all saturated +applications of funTyCon are represented with the FunTy constructor. We check +this invariant in lintType. + +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Bool in + let x::a = True in +That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". +One place it is used is in mkWwArgs; see Note [Join points and beta-redexes] +in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). + +* Hence when linting we need to remember that a=Int, else we + might reject a correct program. So we carry a type substitution (in + this example [a -> Bool]) and apply this substitution before + comparing types. In effect, in Lint, type equality is always + equality-moduolo-le-subst. This is in the le_subst field of + LintEnv. But nota bene: + + (SI1) The le_subst substitution is applied to types and coercions only + + (SI2) The result of that substitution is used only to check for type + equality, to check well-typed-ness, /but is then discarded/. + The result of substittion does not outlive the CoreLint pass. + + (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. + +* The function + lintInTy :: Type -> LintM (Type, Kind) + returns a substituted type. + +* When we encounter a binder (like x::a) we must apply the substitution + to the type of the binding variable. lintBinders does this. + +* Clearly we need to clone tyvar binders as we go. + +* But take care (#17590)! We must also clone CoVar binders: + let a = TYPE (ty |> cv) + in \cv -> blah + blindly substituting for `a` might capture `cv`. + +* Alas, when cloning a coercion variable we might choose a unique + that happens to clash with an inner Id, thus + \cv_66 -> let wild_X7 = blah in blah + We decide to clone `cv_66` becuase it's already in scope. Fine, + choose a new unique. Aha, X7 looks good. So we check the lambda + body with le_subst of [cv_66 :-> cv_X7] + + This is all fine, even though we use the same unique as wild_X7. + As (SI2) says, we do /not/ return a new lambda + (\cv_X7 -> let wild_X7 = blah in ...) + We simply use the le_subst subsitution in types/coercions only, when + checking for equality. + +* We still need to check that Id occurrences are bound by some + enclosing binding. We do /not/ use the InScopeSet for the le_subst + for this purpose -- it contains only TyCoVars. Instead we have a separate + le_ids for the in-scope Id binders. + +Sigh. We might want to explore getting rid of type-let! + +Note [Bad unsafe coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions +Linter introduces additional rules that checks improper coercion between +different types, called bad coercions. Following coercions are forbidden: + + (a) coercions between boxed and unboxed values; + (b) coercions between unlifted values of the different sizes, here + active size is checked, i.e. size of the actual value but not + the space allocated for value; + (c) coercions between floating and integral boxed values, this check + is not yet supported for unboxed tuples, as no semantics were + specified for that; + (d) coercions from / to vector type + (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be + coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules + (a-e) holds. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +We check the rules listed in Note [Invariants on join points] in GHC.Core. The +only one that causes any difficulty is the first: All occurrences must be tail +calls. To this end, along with the in-scope set, we remember in le_joins the +subset of in-scope Ids that are valid join ids. For example: + + join j x = ... in + case e of + A -> jump j y -- good + B -> case (jump j z) of -- BAD + C -> join h = jump j w in ... -- good + D -> let x = jump j v in ... -- BAD + +A join point remains valid in case branches, so when checking the A +branch, j is still valid. When we check the scrutinee of the inner +case, however, we set le_joins to empty, and catch the +error. Similarly, join points can occur free in RHSes of other join +points but not the RHSes of value bindings (thunks and functions). + +************************************************************************ +* * + Beginning and ending passes +* * +************************************************************************ + +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a convenient place for them. They print out stuff +before and after core passes, and do Core Lint when necessary. +-} + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; print_unqual <- getPrintUnqualified + ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } + +endPassIO :: HscEnv -> PrintUnqualified + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +-- Used by the IO-is CorePrep too +endPassIO hsc_env print_unqual pass binds rules + = do { dumpPassResult dflags print_unqual mb_flag + (ppr pass) (pprPassDetails pass) binds rules + ; lintPassResult hsc_env pass binds } + where + dflags = hsc_dflags hsc_env + mb_flag = case coreDumpFlag pass of + Just flag | dopt flag dflags -> Just flag + | dopt Opt_D_verbose_core2core dflags -> Just flag + _ -> Nothing + +dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dflags dump_me pass extra_info doc + = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc + +dumpPassResult :: DynFlags + -> PrintUnqualified + -> Maybe DumpFlag -- Just df => show details in a file whose + -- name is specified by df + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult dflags unqual mb_flag hdr extra_info binds rules + = do { forM_ mb_flag $ \flag -> do + let sty = mkDumpStyle unqual + dumpAction dflags sty (dumpOptionsFromFlag flag) + (showSDoc dflags hdr) FormatCore dump_doc + + -- Report result size + -- This has the side effect of forcing the intermediate to be evaluated + -- if it's not already forced by a -ddump flag. + ; Err.debugTraceMsg dflags 2 size_doc + } + + where + size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +coreDumpFlag :: CoreToDo -> Maybe DumpFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity +coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal +coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt +coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep +coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal + +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +{- +************************************************************************ +* * + Top-level interfaces +* * +************************************************************************ +-} + +lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () +lintPassResult hsc_env pass binds + | not (gopt Opt_DoCoreLinting dflags) + = return () + | otherwise + = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds + ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) + ; displayLintResults dflags pass warns errs binds } + where + dflags = hsc_dflags hsc_env + +displayLintResults :: DynFlags -> CoreToDo + -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram + -> IO () +displayLintResults dflags pass warns errs binds + | not (isEmptyBag errs) + = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan + $ withPprStyle defaultDumpStyle + (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs + , text "*** Offending Program ***" + , pprCoreBindings binds + , text "*** End of Offense ***" ]) + ; Err.ghcExit dflags 1 } + + | not (isEmptyBag warns) + , not (hasNoDebugOutput dflags) + , showLintWarnings pass + -- If the Core linter encounters an error, output to stderr instead of + -- stdout (#13342) + = putLogMsg dflags NoReason Err.SevInfo noSrcSpan + $ withPprStyle defaultDumpStyle + (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) + + | otherwise = return () + where + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = text "*** Core Lint" <+> text string + <+> text ": in result of" <+> pass + <+> text "***" + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False +showLintWarnings _ = True + +lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () +lintInteractiveExpr what hsc_env expr + | not (gopt Opt_DoCoreLinting dflags) + = return () + | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr + = do { display_lint_err err + ; Err.ghcExit dflags 1 } + | otherwise + = return () + where + dflags = hsc_dflags hsc_env + + display_lint_err err + = do { putLogMsg dflags NoReason Err.SevDump + noSrcSpan + $ withPprStyle defaultDumpStyle + (vcat [ lint_banner "errors" (text what) + , err + , text "*** Offending Program ***" + , pprCoreExpr expr + , text "*** End of Offense ***" ]) + ; Err.ghcExit dflags 1 } + +interactiveInScope :: HscEnv -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See #8215 for an example +interactiveInScope hsc_env + = tyvars ++ ids + where + -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr + ictxt = hsc_IC hsc_env + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) + ids = typeEnvIds te + tyvars = tyCoVarsOfTypesList $ map idType ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) +-- Returns (warnings, errors) +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreBindings dflags pass local_in_scope binds + = initL dflags flags local_in_scope $ + addLoc TopLevelBindings $ + do { checkL (null dups) (dupVars dups) + ; checkL (null ext_dups) (dupExtVars ext_dups) + ; lintRecBindings TopLevel all_pairs $ \_ -> + return () } + where + all_pairs = flattenBinds binds + -- Put all the top-level binders in scope at the start + -- This is because rewrite rules can bring something + -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal" + binders = map fst all_pairs + + flags = (defaultLintFlags dflags) + { lf_check_global_ids = check_globals + , lf_check_inline_loop_breakers = check_lbs + , lf_check_static_ptrs = check_static_ptrs } + + -- See Note [Checking for global Ids] + check_globals = case pass of + CoreTidy -> False + CorePrep -> False + _ -> True + + -- See Note [Checking for INLINE loop breakers] + check_lbs = case pass of + CoreDesugar -> False + CoreDesugarOpt -> False + _ -> True + + -- See Note [Checking StaticPtrs] + check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere + | otherwise = case pass of + CoreDoFloatOutwards _ -> AllowAtTopLevel + CoreTidy -> RejectEverywhere + CorePrep -> AllowAtTopLevel + _ -> AllowAnywhere + + (_, dups) = removeDups compare binders + + -- dups_ext checks for names with different uniques + -- but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- because they both get the same linker symbol + ext_dups = snd (removeDups ord_ext (map Var.varName binders)) + ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 + , Just m2 <- nameModule_maybe n2 + = compare (m1, nameOccName n1) (m2, nameOccName n2) + | otherwise = LT + +{- +************************************************************************ +* * +\subsection[lintUnfolding]{lintUnfolding} +* * +************************************************************************ + +Note [Linting Unfoldings from Interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We use this to check all top-level unfoldings that come in from interfaces +(it is very painful to catch errors otherwise). + +We do not need to call lintUnfolding on unfoldings that are nested within +top-level unfoldings; they are linted when we lint the top-level unfolding; +hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. + +-} + +lintUnfolding :: Bool -- True <=> is a compulsory unfolding + -> DynFlags + -> SrcLoc + -> VarSet -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintUnfolding is_compulsory dflags locn var_set expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + vars = nonDetEltsUniqSet var_set + (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $ + if is_compulsory + -- See Note [Checking for levity polymorphism] + then noLPChecks linter + else linter + linter = addLoc (ImportedUnfolding locn) $ + lintCoreExpr expr + +lintExpr :: DynFlags + -> [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintExpr dflags vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter + linter = addLoc TopLevelBindings $ + lintCoreExpr expr + +{- +************************************************************************ +* * +\subsection[lintCoreBinding]{lintCoreBinding} +* * +************************************************************************ + +Check a core binding, returning the list of variables bound. +-} + +-- Returns a UsageEnv because this function is called in lintCoreExpr for +-- Let + +lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] + -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv]) +lintRecBindings top_lvl pairs thing_inside + = lintIdBndrs top_lvl bndrs $ \ bndrs' -> + do { ues <- zipWithM lint_pair bndrs' rhss + ; a <- thing_inside bndrs' + ; return (a, ues) } + where + (bndrs, rhss) = unzip pairs + lint_pair bndr' rhs + = addLoc (RhsOf bndr') $ + do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + ; return ue } + +lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv) +lintLetBody bndrs body + = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) + ; mapM_ (lintJoinBndrType body_ty) bndrs + ; return (body_ty, body_ue) } + +lintLetBind :: TopLevelFlag -> RecFlag -> LintedId + -> CoreExpr -> LintedType -> LintM () +-- Binder's type, and the RHS, have already been linted +-- This function checks other invariants +lintLetBind top_lvl rec_flag binder rhs rhs_ty + = do { let binder_ty = idType binder + ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty) + + -- If the binding is for a CoVar, the RHS should be (Coercion co) + -- See Note [Core type and coercion invariant] in GHC.Core + ; checkL (not (isCoVar binder) || isCoArg rhs) + (mkLetErr binder rhs) + + -- Check the let/app invariant + -- See Note [Core let/app invariant] in GHC.Core + ; checkL ( isJoinId binder + || not (isUnliftedType binder_ty) + || (isNonRec rec_flag && exprOkForSpeculation rhs) + || exprIsTickedString rhs) + (badBndrTyMsg binder (text "unlifted")) + + -- Check that if the binder is top-level or recursive, it's not + -- demanded. Primitive string literals are exempt as there is no + -- computation to perform, see Note [Core top-level string literals]. + ; checkL (not (isStrictId binder) + || (isNonRec rec_flag && not (isTopLevel top_lvl)) + || exprIsTickedString rhs) + (mkStrictMsg binder) + + -- Check that if the binder is at the top level and has type Addr#, + -- that it is a string literal, see + -- Note [Core top-level string literals]. + ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) + || exprIsTickedString rhs) + (mkTopNonLitStrMsg binder) + + ; flags <- getLintFlags + + -- Check that a join-point binder has a valid type + -- NB: lintIdBinder has checked that it is not top-level bound + ; case isJoinId_maybe binder of + Nothing -> return () + Just arity -> checkL (isValidJoinPointType arity binder_ty) + (mkInvalidJoinPointMsg binder binder_ty) + + ; when (lf_check_inline_loop_breakers flags + && isStableUnfolding (realIdUnfolding binder) + && isStrongLoopBreaker (idOccInfo binder) + && isInlinePragma (idInlinePragma binder)) + (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- We used to check that the dmdTypeDepth of a demand signature never + -- exceeds idArity, but that is an unnecessary complication, see + -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal + + -- Check that the binder's arity is within the bounds imposed by + -- the type and the strictness signature. See Note [exprArity invariant] + -- and Note [Trimming arity] + ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds typeArity" <+> + ppr (length (typeArity (idType binder))) <> colon <+> + ppr binder) + + ; case splitStrictSig (idStrictness binder) of + (demands, result_info) | isDeadEndDiv result_info -> + checkL (demands `lengthAtLeast` idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds arity imposed by the strictness signature" <+> + ppr (idStrictness binder) <> colon <+> + ppr binder) + _ -> return () + + ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + + ; addLoc (UnfoldingOf binder) $ + lintIdUnfolding binder binder_ty (idUnfolding binder) + ; return () } + + -- We should check the unfolding, if any, but this is tricky because + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + +-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' +-- in that it doesn't reject occurrences of the function 'makeStatic' when they +-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and +-- for join points, it skips the outer lambdas that take arguments to the +-- join point. +-- +-- See Note [Checking StaticPtrs]. +lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv) +-- NB: the Id can be Linted or not -- it's only used for +-- its OccInfo and join-pointer-hood +lintRhs bndr rhs + | Just arity <- isJoinId_maybe bndr + = lintJoinLams arity (Just bndr) rhs + | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) + = lintJoinLams arity Nothing rhs + +-- Allow applications of the data constructor @StaticPtr@ at the top +-- but produce errors otherwise. +lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go + where + -- Allow occurrences of 'makeStatic' at the top-level but produce errors + -- otherwise. + go :: StaticPtrCheck -> LintM (OutType, UsageEnv) + go AllowAtTopLevel + | (binders0, rhs') <- collectTyBinders rhs + , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' + = markAllJoinsBad $ + foldr + -- imitate @lintCoreExpr (Lam ...)@ + lintLambda + -- imitate @lintCoreExpr (App ...)@ + (do fun_ty_ue <- lintCoreExpr fun + lintCoreArgs fun_ty_ue [Type t, info, e] + ) + binders0 + go _ = markAllJoinsBad $ lintCoreExpr rhs + +-- | Lint the RHS of a join point with expected join arity of @n@ (see Note +-- [Join points] in "GHC.Core"). +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv) +lintJoinLams join_arity enforce rhs + = go join_arity rhs + where + go 0 expr = lintCoreExpr expr + go n (Lam var body) = lintLambda var $ go (n-1) body + go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas + = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs + | otherwise -- Future join point, not yet eta-expanded + = markAllJoinsBad $ lintCoreExpr expr + -- Body of lambda is not a tail position + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty uf + | isStableUnfolding uf + , Just rhs <- maybeUnfoldingTemplate uf + = do { ty <- fst <$> (if isCompulsoryUnfolding uf + then noLPChecks $ lintRhs bndr rhs + -- See Note [Checking for levity polymorphism] + else lintRhs bndr rhs) + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } +lintIdUnfolding _ _ _ + = return () -- Do not Lint unstable unfoldings, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + +{- +Note [Checking for INLINE loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very suspicious if a strong loop breaker is marked INLINE. + +However, the desugarer generates instance methods with INLINE pragmas +that form a mutually recursive group. Only after a round of +simplification are they unravelled. So we suppress the test for +the desugarer. + +Note [Checking for levity polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We ordinarily want to check for bad levity polymorphism. See +Note [Levity polymorphism invariants] in GHC.Core. However, we do *not* +want to do this in a compulsory unfolding. Compulsory unfoldings arise +only internally, for things like newtype wrappers, dictionaries, and +(notably) unsafeCoerce#. These might legitimately be levity-polymorphic; +indeed levity-polyorphic unfoldings are a primary reason for the +very existence of compulsory unfoldings (we can't compile code for +the original, levity-poly, binding). + +It is vitally important that we do levity-polymorphism checks *after* +performing the unfolding, but not beforehand. This is all safe because +we will check any unfolding after it has been unfolded; checking the +unfolding beforehand is merely an optimization, and one that actively +hurts us here. + +Note [Linting of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~ +runRW# has some very special behavior (see Note [runRW magic] in +GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing +join points in its argument. For example, this is fine: + + join j x = ... + in runRW# (\s. case v of + A -> j 3 + B -> j 4) + +Usually those calls to the join point 'j' would not be valid tail calls, +because they occur in a function argument. But in the case of runRW# +they are fine, because runRW# (\s.e) behaves operationally just like e. +(runRW# is ultimately inlined in GHC.CoreToStg.Prep.) + +In the case that the continuation is /not/ a lambda we simply disable this +special behaviour. For example, this is /not/ fine: + + join j = ... + in runRW# @r @ty (jump j) + + + +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +-- Linted things: substitution applied, and type is linted +type LintedType = Type +type LintedKind = Kind +type LintedCoercion = Coercion +type LintedTyCoVar = TyCoVar +type LintedId = Id + +-- | Lint an expression cast through the given coercion, returning the type +-- resulting from the cast. +lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType +lintCastExpr expr expr_ty co + = do { co' <- lintCoercion co + ; let (Pair from_ty to_ty, role) = coercionKindRole co' + ; checkValueType to_ty $ + text "target of cast" <+> quotes (ppr co') + ; lintRole co' Representational role + ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; return to_ty } + +lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv) +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoreExpr (Var var) + = lintIdOcc var 0 + +lintCoreExpr (Lit lit) + = return (literalType lit, zeroUE) + +lintCoreExpr (Cast expr co) + = do (expr_ty, ue) <- markAllJoinsBad $ lintCoreExpr expr + to_ty <- lintCastExpr expr expr_ty co + return (to_ty, ue) + +lintCoreExpr (Tick tickish expr) + = do case tickish of + Breakpoint _ ids -> forM_ ids $ \id -> do + checkDeadIdOcc id + lookupIdInScope id + _ -> return () + markAllJoinsBadIf block_joins $ lintCoreExpr expr + where + block_joins = not (tickish `tickishScopesLike` SoftScope) + -- TODO Consider whether this is the correct rule. It is consistent with + -- the simplifier's behaviour - cost-centre-scoped ticks become part of + -- the continuation, and thus they behave like part of an evaluation + -- context, but soft-scoped and non-scoped ticks simply wrap the result + -- (see Simplify.simplTick). + +lintCoreExpr (Let (NonRec tv (Type ty)) body) + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- lintType ty + ; lintTyBndr tv $ \ tv' -> + do { addLoc (RhsOf tv) $ lintTyKind tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; extendTvSubstL tv ty' $ + addLoc (BodyOfLetRec [tv]) $ + lintCoreExpr body } } + +lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr + = do { -- First Lint the RHS, before bringing the binder into scope + (rhs_ty, let_ue) <- lintRhs bndr rhs + + -- See Note [Multiplicity of let binders] in Var + -- Now lint the binder + ; lintBinder LetBind bndr $ \bndr' -> + do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty + ; addAliasUE bndr let_ue (lintLetBody [bndr'] body) } } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr e@(Let (Rec pairs) body) + = do { -- Check that the list of pairs is non-empty + checkL (not (null pairs)) (emptyRec e) + + -- Check that there are no duplicated binders + ; let (_, dups) = removeDups compare bndrs + ; checkL (null dups) (dupVars dups) + + -- Check that either all the binders are joins, or none + ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ + mkInconsistentRecMsg bndrs + + -- See Note [Multiplicity of let binders] in Var + ; ((body_type, body_ue), ues) <- + lintRecBindings NotTopLevel pairs $ \ bndrs' -> + lintLetBody bndrs' body + ; return (body_type, body_ue `addUE` scaleUE Many (foldr1 addUE ues)) } + where + bndrs = map fst pairs + +lintCoreExpr e@(App _ _) + | Var fun <- fun + , fun `hasKey` runRWKey + -- N.B. we may have an over-saturated application of the form: + -- runRW (\s -> \x -> ...) y + , arg_ty1 : arg_ty2 : arg3 : rest <- args + = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) arg_ty1 + ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2 + -- See Note [Linting of runRW#] + ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) + lintRunRWCont expr@(Lam _ _) = do + lintJoinLams 1 (Just fun) expr + lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other + -- TODO: Look through ticks? + ; (arg3_ty, ue3) <- lintRunRWCont arg3 + ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3 + ; lintCoreArgs app_ty rest } + + | otherwise + = do { pair <- lintCoreFun fun (length args) + ; lintCoreArgs pair args } + where + (fun, args) = collectArgs e + +lintCoreExpr (Lam var expr) + = markAllJoinsBad $ + lintLambda var $ lintCoreExpr expr + +lintCoreExpr (Case scrut var alt_ty alts) + = lintCaseExpr scrut var alt_ty alts + +-- This case can't happen; linting types in expressions gets routed through +-- lintCoreArgs +lintCoreExpr (Type ty) + = failWithL (text "Type found as expression" <+> ppr ty) + +lintCoreExpr (Coercion co) + = do { co' <- addLoc (InCo co) $ + lintCoercion co + ; return (coercionType co', zeroUE) } + +---------------------- +lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed + -> LintM (LintedType, UsageEnv) -- returns type of the *variable* +lintIdOcc var nargs + = addLoc (OccOf var) $ + do { checkL (isNonCoVarId var) + (text "Non term variable" <+> ppr var) + -- See GHC.Core Note [Variable occurrences in Core] + + -- Check that the type of the occurrence is the same + -- as the type of the binding site. The inScopeIds are + -- /un-substituted/, so this checks that the occurrence type + -- is identical to the binder type. + -- This makes things much easier for things like: + -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... + -- The "::Maybe a" on the occurrence is referring to the /outer/ a. + -- If we compared /substituted/ types we'd risk comparing + -- (Maybe a) from the binding site with bogus (Maybe a1) from + -- the occurrence site. Comparing un-substituted types finesses + -- this altogether + ; (bndr, linted_bndr_ty) <- lookupIdInScope var + ; let occ_ty = idType var + bndr_ty = idType bndr + ; ensureEqTys occ_ty bndr_ty $ + mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty + + -- Check for a nested occurrence of the StaticPtr constructor. + -- See Note [Checking StaticPtrs]. + ; lf <- getLintFlags + ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ + checkL (idName var /= makeStaticName) $ + text "Found makeStatic nested in an expression" + + ; checkDeadIdOcc var + ; checkJoinOcc var nargs + + ; usage <- varCallSiteUsage var + + ; return (linted_bndr_ty, usage) } + +lintCoreFun :: CoreExpr + -> Int -- Number of arguments (type or val) being passed + -> LintM (LintedType, UsageEnv) -- Returns type of the *function* +lintCoreFun (Var var) nargs + = lintIdOcc var nargs + +lintCoreFun (Lam var body) nargs + -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see + -- Note [Beta redexes] + | nargs /= 0 + = lintLambda var $ lintCoreFun body (nargs - 1) + +lintCoreFun expr nargs + = markAllJoinsBadIf (nargs /= 0) $ + -- See Note [Join points are less general than the paper] + lintCoreExpr expr +------------------ +lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) +lintLambda var lintBody = + addLoc (LambdaBodyOf var) $ + lintBinder LambdaBind var $ \ var' -> + do { (body_ty, ue) <- lintBody + ; ue' <- checkLinearity ue var' + ; return (mkLamType var' body_ty, ue') } +------------------ +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (text "Occurrence of a dead Id" <+> ppr id) } + | otherwise + = return () + +------------------ +lintJoinBndrType :: LintedType -- Type of the body + -> LintedId -- Possibly a join Id + -> LintM () +-- Checks that the return type of a join Id matches the body +-- E.g. join j x = rhs in body +-- The type of 'rhs' must be the same as the type of 'body' +lintJoinBndrType body_ty bndr + | Just arity <- isJoinId_maybe bndr + , let bndr_ty = idType bndr + , (bndrs, res) <- splitPiTys bndr_ty + = checkL (length bndrs >= arity + && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ + hang (text "Join point returns different type than body") + 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) + , text "Join arity:" <+> ppr arity + , text "Body type:" <+> ppr body_ty ]) + | otherwise + = return () + +checkJoinOcc :: Id -> JoinArity -> LintM () +-- Check that if the occurrence is a JoinId, then so is the +-- binding site, and it's a valid join Id +checkJoinOcc var n_args + | Just join_arity_occ <- isJoinId_maybe var + = do { mb_join_arity_bndr <- lookupJoinId var + ; case mb_join_arity_bndr of { + Nothing -> -- Binder is not a join point + do { join_set <- getValidJoins + ; addErrL (text "join set " <+> ppr join_set $$ + invalidJoinOcc var) } ; + + Just join_arity_bndr -> + + do { checkL (join_arity_bndr == join_arity_occ) $ + -- Arity differs at binding site and occurrence + mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ + + ; checkL (n_args == join_arity_occ) $ + -- Arity doesn't match #args + mkBadJumpMsg var join_arity_occ n_args } } } + + | otherwise + = return () + +-- Check that the usage of var is consistent with var itself, and pop the var +-- from the usage environment (this is important because of shadowing). +checkLinearity :: UsageEnv -> Var -> LintM UsageEnv +checkLinearity body_ue lam_var = + case varMultMaybe lam_var of + Just mult -> do ensureSubUsage lhs mult (err_msg mult) + return $ deleteUE body_ue lam_var + Nothing -> return body_ue -- A type variable + where + lhs = lookupUE body_ue lam_var + err_msg mult = text "Linearity failure in lambda:" <+> ppr lam_var + $$ ppr lhs <+> text "⊈" <+> ppr mult + +{- +Note [No alternatives lint check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions with no alternatives are odd beasts, and it would seem +like they would worth be looking at in the linter (cf #10180). We +used to check two things: + +* exprIsHNF is false: it would *seem* to be terribly wrong if + the scrutinee was already in head normal form. + +* exprIsDeadEnd is true: we should be able to see why GHC believes the + scrutinee is diverging for sure. + +It was already known that the second test was not entirely reliable. +Unfortunately (#13990), the first test turned out not to be reliable +either. Getting the checks right turns out to be somewhat complicated. + +For example, suppose we have (comment 8) + + data T a where + TInt :: T Int + + absurdTBool :: T Bool -> a + absurdTBool v = case v of + + data Foo = Foo !(T Bool) + + absurdFoo :: Foo -> a + absurdFoo (Foo x) = absurdTBool x + +GHC initially accepts the empty case because of the GADT conditions. But then +we inline absurdTBool, getting + + absurdFoo (Foo x) = case x of + +x is in normal form (because the Foo constructor is strict) but the +case is empty. To avoid this problem, GHC would have to recognize +that matching on Foo x is already absurd, which is not so easy. + +More generally, we don't really know all the ways that GHC can +lose track of why an expression is bottom, so we shouldn't make too +much fuss when that happens. + + +Note [Beta redexes] +~~~~~~~~~~~~~~~~~~~ +Consider: + + join j @x y z = ... in + (\@x y z -> jump j @x y z) @t e1 e2 + +This is clearly ill-typed, since the jump is inside both an application and a +lambda, either of which is enough to disqualify it as a tail call (see Note +[Invariants on join points] in GHC.Core). However, strictly from a +lambda-calculus perspective, the term doesn't go wrong---after the two beta +reductions, the jump *is* a tail call and everything is fine. + +Why would we want to allow this when we have let? One reason is that a compound +beta redex (that is, one with more than one argument) has different scoping +rules: naively reducing the above example using lets will capture any free +occurrence of y in e2. More fundamentally, type lets are tricky; many passes, +such as Float Out, tacitly assume that the incoming program's type lets have +all been dealt with by the simplifier. Thus we don't want to let-bind any types +in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately +before Float Out. + +All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this +loophole, doing so to avoid re-traversing large functions (beta-reducing a type +lambda without introducing a type let requires a substitution). TODO: Improve +simpleOptPgm so that we can forget all this ever happened. + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + + +lintCoreArgs :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv) +lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args + +lintCoreArg :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv) +lintCoreArg (fun_ty, ue) (Type arg_ty) + = do { checkL (not (isCoercionTy arg_ty)) + (text "Unnecessary coercion-to-type injection:" + <+> ppr arg_ty) + ; arg_ty' <- lintType arg_ty + ; res <- lintTyApp fun_ty arg_ty' + ; return (res, ue) } + +lintCoreArg (fun_ty, fun_ue) arg + = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg + -- See Note [Levity polymorphism invariants] in GHC.Core + ; flags <- getLintFlags + ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty)) + (text "Levity-polymorphic argument:" <+> + (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) + -- check for levity polymorphism first, because otherwise isUnliftedType panics + + ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) + (mkLetAppMsg arg) + + ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } + +----------------- +lintAltBinders :: UsageEnv + -> Var -- Case binder + -> LintedType -- Scrutinee type + -> LintedType -- Constructor type + -> [(Mult, OutVar)] -- Binders + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] + = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) + ; return rhs_ue } +lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) + | isTyVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty' bndrs } + | otherwise + = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE + -- We can pass zeroUE to lintValApp because we ignore its usage + -- calculation and compute it in the call for checkCaseLinearity below. + ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr + ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } + +-- | Implements the case rules for linearity +checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv +checkCaseLinearity ue case_bndr var_w bndr = do + ensureSubUsage lhs rhs err_msg + lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (varMult bndr) + return $ deleteUE ue bndr + where + lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage) + rhs = case_bndr_w `mkMultMul` var_w + err_msg = (text "Linearity failure in variable:" <+> ppr bndr + $$ ppr lhs <+> text "⊈" <+> ppr rhs + $$ text "Computed by:" + <+> text "LHS:" <+> lhs_formula + <+> text "RHS:" <+> rhs_formula) + lhs_formula = ppr bndr_usage <+> text "+" + <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w) + rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w + case_bndr_w = varMult case_bndr + case_bndr_usage = lookupUE ue case_bndr + bndr_usage = lookupUE ue bndr + + + +----------------- +lintTyApp :: LintedType -> LintedType -> LintM LintedType +lintTyApp fun_ty arg_ty + | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty + = do { lintTyKind tv arg_ty + ; in_scope <- getInScope + -- substTy needs the set of tyvars in scope to avoid generating + -- uniques that are already in scope. + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst + ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } + + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) + +----------------- + +-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ +-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the +-- application. +lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) +lintValApp arg fun_ty arg_ty fun_ue arg_ue + | Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty + = do { ensureEqTys arg_ty' arg_ty err1 + ; let app_ue = addUE fun_ue (scaleUE w arg_ue) + ; return (res_ty', app_ue) } + | otherwise + = failWithL err2 + where + err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +lintTyKind :: OutTyVar -> LintedType -> LintM () +-- Both args have had substitution applied + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintTyKind tyvar arg_ty + = unless (arg_kind `eqType` tyvar_kind) $ + addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind)) + where + tyvar_kind = tyVarKind tyvar + arg_kind = typeKind arg_ty + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv) +lintCaseExpr scrut var alt_ty alts = + do { let e = Case scrut var alt_ty alts -- Just for error messages + + -- Check the scrutinee + ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut + -- See Note [Join points are less general than the paper] + -- in GHC.Core + ; let scrut_mult = varMult var + + ; alt_ty <- addLoc (CaseTy scrut) $ + lintValueType alt_ty + ; var_ty <- addLoc (IdTy var) $ + lintValueType (idType var) + + -- We used to try to check whether a case expression with no + -- alternatives was legitimate, but this didn't work. + -- See Note [No alternatives lint check] for details. + + -- Check that the scrutinee is not a floating-point type + -- if there are any literal alternatives + -- See GHC.Core Note [Case expression invariants] item (5) + -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold + ; let isLitPat (LitAlt _, _ , _) = True + isLitPat _ = False + ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) + (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ + "expression with literal pattern in case " ++ + "analysis (see #9238).") + $$ text "scrut" <+> ppr scrut) + + ; case tyConAppTyCon_maybe (idType var) of + Just tycon + | debugIsOn + , isAlgTyCon tycon + , not (isAbstractTyCon tycon) + , null (tyConDataCons tycon) + , not (exprIsDeadEnd scrut) + -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate + + ; subst <- getTCvSubst + ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) + -- See GHC.Core Note [Case expression invariants] item (7) + + ; lintBinder CaseBind var $ \_ -> + do { -- Check the alternatives + ; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts + ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues + ; checkCaseAlts e scrut_ty alts + ; return (alt_ty, case_ue) } } + +checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order +-- c) Check that there's a default for infinite types +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifier correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty alts = + do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + -- See GHC.Core Note [Case expression invariants] item (2) + + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + -- See GHC.Core Note [Case expression invariants] item (3) + + -- For types Int#, Word# with an infinite (well, large!) number of + -- possible values, there should usually be a DEFAULT case + -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to + -- have *no* case alternatives. + -- In effect, this is a kind of partial test. I suppose it's possible + -- that we might *know* that 'x' was 1 or 2, in which case + -- case x of { 1 -> e1; 2 -> e2 } + -- would be fine. + ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) + (nonExhaustiveAltsMsg e) } + where + (con_alts, maybe_deflt) = findDefault alts + + -- Check that successive alternatives have strictly increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag _ = True + + non_deflt (DEFAULT, _, _) = False + non_deflt _ = True + + is_infinite_ty = case tyConAppTyCon_maybe ty of + Nothing -> False + Just tycon -> isPrimTyCon tycon + +lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv +lintAltExpr expr ann_ty + = do { (actual_ty, ue) <- lintCoreExpr expr + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) + ; return ue } + -- See GHC.Core Note [Case expression invariants] item (6) + +lintCoreAlt :: Var -- Case binder + -> LintedType -- Type of scrutinee + -> Mult -- Multiplicity of scrutinee + -> LintedType -- Type of the alternative + -> CoreAlt + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreAlt _ _ _ alt_ty (DEFAULT, args, rhs) = + do { lintL (null args) (mkDefaultArgsMsg args) + ; lintAltExpr rhs alt_ty } + +lintCoreAlt _case_bndr scrut_ty _ alt_ty (LitAlt lit, args, rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { lintL (null args) (mkDefaultArgsMsg args) + ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; lintAltExpr rhs alt_ty } + where + lit_ty = literalType lit + +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(DataAlt con, args, rhs) + | isNewTyCon (dataConTyCon con) + = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty + = addLoc (CaseAlt alt) $ do + { -- First instantiate the universally quantified + -- type variables of the data constructor + -- We've already check + lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + ; ex_tvs_n = length (dataConExTyCoVars con) + -- See Note [Alt arg multiplicities] + ; multiplicities = replicate ex_tvs_n Many ++ + map scaledMult (dataConRepArgTys con) } + + -- And now bring the new binders into scope + ; lintBinders CasePatBind args $ \ args' -> do + { + rhs_ue <- lintAltExpr rhs alt_ty + ; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities args')) + ; return $ deleteUE rhs_ue' case_bndr + } + } + + | otherwise -- Scrut-ty is wrong shape + = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) + +lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () +lintLinearBinder doc actual_usage described_usage + = ensureSubMult actual_usage described_usage err_msg + where + err_msg = (text "Multiplicity of variable does not agree with its context" + $$ doc + $$ ppr actual_usage + $$ text "Annotation:" <+> ppr described_usage) + +{- +Note [Alt arg multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is necessary to use `dataConRepArgTys` so you get the arg tys from +the wrapper if there is one. + +You also need to add the existential ty vars as they are passed are arguments +but not returned by `dataConRepArgTys`. Without this the test `GADT1` fails. +-} + +{- +************************************************************************ +* * +\subsection[lint-types]{Types} +* * +************************************************************************ +-} + +-- When we lint binders, we (one at a time and in order): +-- 1. Lint var types or kinds (possibly substituting) +-- 2. Add the binder to the in scope set, and if its a coercion var, +-- we may extend the substitution to reflect its (possibly) new kind +lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a +lintBinders _ [] linterF = linterF [] +lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> + lintBinders site vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a +lintBinder site var linterF + | isTyCoVar var = lintTyCoBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF + +lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a +lintTyBndr = lintTyCoBndr -- We could specialise it, I guess + +-- lintCoBndr :: CoVar -> (LintedTyCoVar -> LintM a) -> LintM a +-- lintCoBndr = lintTyCoBndr -- We could specialise it, I guess + +lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a +lintTyCoBndr tcv thing_inside + = do { subst <- getTCvSubst + ; kind' <- lintType (varType tcv) + ; let tcv' = uniqAway (getTCvInScope subst) $ + setVarType tcv kind' + subst' = extendTCvSubstWithClone subst tcv tcv' + ; when (isCoVar tcv) $ + lintL (isCoVarType kind') + (text "CoVar with non-coercion type:" <+> pprTyVar tcv) + ; updateTCvSubst subst' (thing_inside tcv') } + +lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a +lintIdBndrs top_lvl ids thing_inside + = go ids thing_inside + where + go :: [Id] -> ([Id] -> LintM a) -> LintM a + go [] thing_inside = thing_inside [] + go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> + go ids $ \ids' -> + thing_inside (id' : ids') + +lintIdBndr :: TopLevelFlag -> BindingSite + -> InVar -> (OutVar -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules +lintIdBndr top_lvl bind_site id thing_inside + = ASSERT2( isId id, ppr id ) + do { flags <- getLintFlags + ; checkL (not (lf_check_global_ids flags) || isLocalId id) + (text "Non-local Id binder" <+> ppr id) + -- See Note [Checking for global Ids] + + -- Check that if the binder is nested, it is not marked as exported + ; checkL (not (isExportedId id) || is_top_lvl) + (mkNonTopExportedMsg id) + + -- Check that if the binder is nested, it does not have an external name + ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) + (mkNonTopExternalNameMsg id) + + -- See Note [Levity polymorphism invariants] in GHC.Core + ; lintL (isJoinId id || not (lf_check_levity_poly flags) + || not (isTypeLevPoly id_ty)) $ + text "Levity-polymorphic binder:" <+> ppr id <+> dcolon <+> + parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) + + -- Check that a join-id is a not-top-level let-binding + ; when (isJoinId id) $ + checkL (not is_top_lvl && is_let_bind) $ + mkBadJoinBindMsg id + + -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); + -- if so, it should be a CoVar, and checked by lintCoVarBndr + ; lintL (not (isCoVarType id_ty)) + (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) + + ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty) + + ; addInScopeId id linted_ty $ + thing_inside (setIdType id linted_ty) } + where + id_ty = idType id + + is_top_lvl = isTopLevel top_lvl + is_let_bind = case bind_site of + LetBind -> True + _ -> False + +{- +%************************************************************************ +%* * + Types +%* * +%************************************************************************ +-} + +lintValueType :: Type -> LintM LintedType +-- Types only, not kinds +-- Check the type, and apply the substitution to it +-- See Note [Linting type lets] +lintValueType ty + = addLoc (InType ty) $ + do { ty' <- lintType ty + ; let sk = typeKind ty' + ; lintL (classifiesTypeWithValues sk) $ + hang (text "Ill-kinded type:" <+> ppr ty) + 2 (text "has kind:" <+> ppr sk) + ; return ty' } + +checkTyCon :: TyCon -> LintM () +checkTyCon tc + = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) + +------------------- +lintType :: Type -> LintM LintedType + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintType (TyVarTy tv) + | not (isTyVar tv) + = failWithL (mkBadTyVarMsg tv) + + | otherwise + = do { subst <- getTCvSubst + ; case lookupTyVar subst tv of + Just linted_ty -> return linted_ty + + -- In GHCi we may lint an expression with a free + -- type variable. Then it won't be in the + -- substitution, but it should be in scope + Nothing | tv `isInScope` subst + -> return (TyVarTy tv) + | otherwise + -> failWithL $ + hang (text "The type variable" <+> pprBndr LetBind tv) + 2 (text "is out of scope") + } + +lintType ty@(AppTy t1 t2) + | TyConApp {} <- t1 + = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty + | otherwise + = do { t1' <- lintType t1 + ; t2' <- lintType t2 + ; lint_ty_app ty (typeKind t1') [t2'] + ; return (AppTy t1' t2') } + +lintType ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags + ; lintTySynFamApp report_unsat ty tc tys } + + | isFunTyCon tc + , tys `lengthIs` 5 + -- We should never see a saturated application of funTyCon; such + -- applications should be represented with the FunTy constructor. + -- See Note [Linting function types] and + -- Note [Representation of function types]. + = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty)) + + | otherwise -- Data types, data families, primitive types + = do { checkTyCon tc + ; tys' <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + +-- arrows can related *unlifted* kinds, so this has to be separate from +-- a dependent forall. +lintType ty@(FunTy af tw t1 t2) + = do { t1' <- lintType t1 + ; t2' <- lintType t2 + ; tw' <- lintType tw + ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw' + ; return (FunTy af tw' t1' t2') } + +lintType ty@(ForAllTy (Bndr tcv vis) body_ty) + | not (isTyCoVar tcv) + = failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty) + | otherwise + = lintTyCoBndr tcv $ \tcv' -> + do { body_ty' <- lintType body_ty + ; lintForAllBody tcv' body_ty' + + ; when (isCoVar tcv) $ + lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $ + text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) + -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo] + + ; return (ForAllTy (Bndr tcv' vis) body_ty') } + +lintType ty@(LitTy l) + = do { lintTyLit l; return ty } + +lintType (CastTy ty co) + = do { ty' <- lintType ty + ; co' <- lintStarCoercion co + ; let tyk = typeKind ty' + cok = coercionLKind co' + ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok) + ; return (CastTy ty' co') } + +lintType (CoercionTy co) + = do { co' <- lintCoercion co + ; return (CoercionTy co') } + +----------------- +lintForAllBody :: LintedTyCoVar -> LintedType -> LintM () +-- Do the checks for the body of a forall-type +lintForAllBody tcv body_ty + = do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty) + + -- For type variables, check for skolem escape + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + -- The kind of (forall cv. th) is liftedTypeKind, so no + -- need to check for skolem-escape in the CoVar case + ; let body_kind = typeKind body_ty + ; when (isTyVar tcv) $ + case occCheckExpand [tcv] body_kind of + Just {} -> return () + Nothing -> failWithL $ + hang (text "Variable escape in forall:") + 2 (vcat [ text "tyvar:" <+> ppr tcv + , text "type:" <+> ppr body_ty + , text "kind:" <+> ppr body_kind ]) + } + +----------------- +lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType +-- The TyCon is a type synonym or a type family (not a data family) +-- See Note [Linting type synonym applications] +-- c.f. GHC.Tc.Validity.check_syn_tc_app +lintTySynFamApp report_unsat ty tc tys + | report_unsat -- Report unsaturated only if report_unsat is on + , tys `lengthLessThan` tyConArity tc + = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) + + -- Deal with type synonyms + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { -- Kind-check the argument types, but without reporting + -- un-saturated type families/synonyms + tys' <- setReportUnsat False (mapM lintType tys) + + ; when report_unsat $ + do { _ <- lintType expanded_ty + ; return () } + + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + + -- Otherwise this must be a type family + | otherwise + = do { tys' <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) tys' + ; return (TyConApp tc tys') } + +----------------- +-- Confirms that a type is really *, #, Constraint etc +checkValueType :: LintedType -> SDoc -> LintM () +checkValueType ty doc + = lintL (classifiesTypeWithValues kind) + (text "Non-*-like kind when *-like expected:" <+> ppr kind $$ + text "when checking" <+> doc) + where + kind = typeKind ty + +----------------- +lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintArrow what t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw + -- or lintArrow "coercion `blah'" k1 k2 kw + = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) + ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) + ; unless (isMultiplicityTy kw) (addErrL (msg (text "multiplicity") kw)) } + where + k1 = typeKind t1 + k2 = typeKind t2 + kw = typeKind tw + msg ar k + = vcat [ hang (text "Ill-kinded" <+> ar) + 2 (text "in" <+> what) + , what <+> text "kind:" <+> ppr k ] + +----------------- +lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM () +lint_ty_app ty k tys + = lint_app (text "type" <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM () +lint_co_app ty k tys + = lint_app (text "coercion" <+> quotes (ppr ty)) k tys + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = text "Negative type literal:" <+> integer n +lintTyLit (StrTyLit _) = return () + +lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM () +-- (lint_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lint_app doc kfn arg_tys + = do { in_scope <- getInScope + -- We need the in_scope set to satisfy the invariant in + -- Note [The substitution invariant] in GHC.Core.TyCo.Subst + ; _ <- foldlM (go_app in_scope) kfn arg_tys + ; return () } + where + fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc + , nest 2 (text "Function kind =" <+> ppr kfn) + , nest 2 (text "Arg types =" <+> ppr arg_tys) + , extra ] + + go_app in_scope kfn ta + | Just kfn' <- coreView kfn + = go_app in_scope kfn' ta + + go_app _ fun_kind@(FunTy _ _ kfa kfb) ta + = do { let ka = typeKind ta + ; unless (ka `eqType` kfa) $ + addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) + ; return kfb } + + go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta + = do { let kv_kind = varType kv + ka = typeKind ta + ; unless (ka `eqType` kv_kind) $ + addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ + ppr ta <+> dcolon <+> ppr ka))) + ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } + + go_app _ kfn ta + = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) + +{- ********************************************************************* +* * + Linting rules +* * +********************************************************************* -} + +lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM () +lintCoreRule _ _ (BuiltinRule {}) + = return () -- Don't bother + +lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs }) + = lintBinders LambdaBind bndrs $ \ _ -> + do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args + ; (rhs_ty, _) <- case isJoinId_maybe fun of + Just join_arity + -> do { checkL (args `lengthIs` join_arity) $ + mkBadJoinPointRuleMsg fun join_arity rule + -- See Note [Rules for join points] + ; lintCoreExpr rhs } + _ -> markAllJoinsBad $ lintCoreExpr rhs + ; ensureEqTys lhs_ty rhs_ty $ + (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty + , text "rhs type:" <+> ppr rhs_ty + , text "fun_ty:" <+> ppr fun_ty ]) + ; let bad_bndrs = filter is_bad_bndr bndrs + + ; checkL (null bad_bndrs) + (rule_doc <+> text "unbound" <+> ppr bad_bndrs) + -- See Note [Linting rules] + } + where + rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon + + lhs_fvs = exprsFreeVars args + rhs_fvs = exprFreeVars rhs + + is_bad_bndr :: Var -> Bool + -- See Note [Unbound RULE binders] in GHC.Core.Rules + is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) + && bndr `elemVarSet` rhs_fvs + && isNothing (isReflCoVar_maybe bndr) + + +{- Note [Linting rules] +~~~~~~~~~~~~~~~~~~~~~~~ +It's very bad if simplifying a rule means that one of the template +variables (ru_bndrs) that /is/ mentioned on the RHS becomes +not-mentioned in the LHS (ru_args). How can that happen? Well, in +#10602, SpecConstr stupidly constructed a rule like + + forall x,c1,c2. + f (x |> c1 |> c2) = .... + +But simplExpr collapses those coercions into one. (Indeed in +#10602, it collapsed to the identity and was removed altogether.) + +We don't have a great story for what to do here, but at least +this check will nail it. + +NB (#11643): it's possible that a variable listed in the +binders becomes not-mentioned on both LHS and RHS. Here's a silly +example: + RULE forall x y. f (g x y) = g (x+1) (y-1) +And suppose worker/wrapper decides that 'x' is Absent. Then +we'll end up with + RULE forall x y. f ($gw y) = $gw (x+1) +This seems sufficiently obscure that there isn't enough payoff to +try to trim the forall'd binder list. + +Note [Rules for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A join point cannot be partially applied. However, the left-hand side of a rule +for a join point is effectively a *pattern*, not a piece of code, so there's an +argument to be made for allowing a situation like this: + + join $sj :: Int -> Int -> String + $sj n m = ... + j :: forall a. Eq a => a -> a -> String + {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} + j @a $dEq x y = ... + +Applying this rule can't turn a well-typed program into an ill-typed one, so +conceivably we could allow it. But we can always eta-expand such an +"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact +the simplifier would have to in order to deal with the RHS. So we take a +conservative view and don't allow undersaturated rules for join points. See +Note [Rules and join points] in "GHC.Core.Opt.OccurAnal" for further discussion. +-} + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +{- Note [Asymptotic efficiency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting coercions (and types actually) we return a linted +(substituted) coercion. Then we often have to take the coercionKind of +that returned coercion. If we get long chains, that can be asymptotically +inefficient, notably in +* TransCo +* InstCo +* NthCo (cf #9233) +* LRCo + +But the code is simple. And this is only Lint. Let's wait to see if +the bad perf bites us in practice. + +A solution would be to return the kind and role of the coercion, +as well as the linted coercion. Or perhaps even *only* the kind and role, +which is what used to happen. But that proved tricky and error prone +(#17923), so now we return the coercion. +-} + + +-- lints a coercion, confirming that its lh kind and its rh kind are both * +-- also ensures that the role is Nominal +lintStarCoercion :: InCoercion -> LintM LintedCoercion +lintStarCoercion g + = do { g' <- lintCoercion g + ; let Pair t1 t2 = coercionKind g' + ; checkValueType t1 (text "the kind of the left type in" <+> ppr g) + ; checkValueType t2 (text "the kind of the right type in" <+> ppr g) + ; lintRole g Nominal (coercionRole g) + ; return g' } + +lintCoercion :: InCoercion -> LintM LintedCoercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) + + | otherwise + = do { subst <- getTCvSubst + ; case lookupCoVar subst cv of + Just linted_co -> return linted_co ; + Nothing + | cv `isInScope` subst + -> return (CoVarCo cv) + | otherwise + -> + -- lintCoBndr always extends the substitition + failWithL $ + hang (text "The coercion variable" <+> pprBndr LetBind cv) + 2 (text "is out of scope") + } + + +lintCoercion (Refl ty) + = do { ty' <- lintType ty + ; return (Refl ty') } + +lintCoercion (GRefl r ty MRefl) + = do { ty' <- lintType ty + ; return (GRefl r ty' MRefl) } + +lintCoercion (GRefl r ty (MCo co)) + = do { ty' <- lintType ty + ; co' <- lintCoercion co + ; let tk = typeKind ty' + tl = coercionLKind co' + ; ensureEqTys tk tl $ + hang (text "GRefl coercion kind mis-match:" <+> ppr co) + 2 (vcat [ppr ty', ppr tk, ppr tl]) + ; lintRole co' Nominal (coercionRole co') + ; return (GRefl r ty' (MCo co')) } + +lintCoercion co@(TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [_w, _rep1,_rep2,_co1,_co2] <- cos + = failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) + -- All saturated TyConAppCos should be FunCos + + | Just {} <- synTyConDefn_maybe tc + = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) + + | otherwise + = do { checkTyCon tc + ; cos' <- mapM lintCoercion cos + ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos') + ; lint_co_app co (tyConKind tc) (map pFst co_kinds) + ; lint_co_app co (tyConKind tc) (map pSnd co_kinds) + ; zipWithM_ (lintRole co) (tyConRolesX r tc) co_roles + ; return (TyConAppCo r tc cos') } + +lintCoercion co@(AppCo co1 co2) + | TyConAppCo {} <- co1 + = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) + | Just (TyConApp {}, _) <- isReflCo_maybe co1 + = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) + | otherwise + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; let (Pair lk1 rk1, r1) = coercionKindRole co1' + (Pair lk2 rk2, r2) = coercionKindRole co2' + ; lint_co_app co (typeKind lk1) [lk2] + ; lint_co_app co (typeKind rk1) [rk2] + + ; if r1 == Phantom + then lintL (r2 == Phantom || r2 == Nominal) + (text "Second argument in AppCo cannot be R:" $$ + ppr co) + else lintRole co Nominal r2 + + ; return (AppCo co1' co2') } + +---------- +lintCoercion co@(ForAllCo tcv kind_co body_co) + | not (isTyCoVar tcv) + = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co) + | otherwise + = do { kind_co' <- lintStarCoercion kind_co + ; lintTyCoBndr tcv $ \tcv' -> + do { body_co' <- lintCoercion body_co + ; ensureEqTys (varType tcv') (coercionLKind kind_co') $ + text "Kind mis-match in ForallCo" <+> ppr co + + -- Assuming kind_co :: k1 ~ k2 + -- Need to check that + -- (forall (tcv:k1). lty) and + -- (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv]) + -- are both well formed. Easiest way is to call lintForAllBody + -- for each; there is actually no need to do the funky substitution + ; let Pair lty rty = coercionKind body_co' + ; lintForAllBody tcv' lty + ; lintForAllBody tcv' rty + + ; when (isCoVar tcv) $ + lintL (almostDevoidCoVarOfCo tcv body_co) $ + text "Covar can only appear in Refl and GRefl: " <+> ppr co + -- See "last wrinkle" in GHC.Core.Coercion + -- Note [Unused coercion variable in ForAllCo] + -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + + ; return (ForAllCo tcv' kind_co' body_co') } } + +lintCoercion co@(FunCo r cow co1 co2) + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; cow' <- lintCoercion cow + ; let Pair lt1 rt1 = coercionKind co1 + Pair lt2 rt2 = coercionKind co2 + Pair ltw rtw = coercionKind cow + ; lintArrow (text "coercion" <+> quotes (ppr co)) lt1 lt2 ltw + ; lintArrow (text "coercion" <+> quotes (ppr co)) rt1 rt2 rtw + ; lintRole co1 r (coercionRole co1) + ; lintRole co2 r (coercionRole co2) + ; ensureEqTys (typeKind ltw) multiplicityTy (text "coercion" <> quotes (ppr co)) + ; ensureEqTys (typeKind rtw) multiplicityTy (text "coercion" <> quotes (ppr co)) + ; let expected_mult_role = case r of + Phantom -> Phantom + _ -> Nominal + ; lintRole cow expected_mult_role (coercionRole cow) + ; return (FunCo r cow' co1' co2') } + +-- See Note [Bad unsafe coercion] +lintCoercion co@(UnivCo prov r ty1 ty2) + = do { ty1' <- lintType ty1 + ; ty2' <- lintType ty2 + ; let k1 = typeKind ty1' + k2 = typeKind ty2' + ; prov' <- lint_prov k1 k2 prov + + ; when (r /= Phantom && classifiesTypeWithValues k1 + && classifiesTypeWithValues k2) + (checkTypes ty1 ty2) + + ; return (UnivCo prov' r ty1' ty2') } + where + report s = hang (text $ "Unsafe coercion: " ++ s) + 2 (vcat [ text "From:" <+> ppr ty1 + , text " To:" <+> ppr ty2]) + isUnBoxed :: PrimRep -> Bool + isUnBoxed = not . isGcPtrRep + + -- see #9122 for discussion of these checks + checkTypes t1 t2 + = do { checkWarnL (not lev_poly1) + (report "left-hand type is levity-polymorphic") + ; checkWarnL (not lev_poly2) + (report "right-hand type is levity-polymorphic") + ; when (not (lev_poly1 || lev_poly2)) $ + do { checkWarnL (reps1 `equalLength` reps2 || + is_core_prep_prov prov) + (report "between values with different # of reps") + ; zipWithM_ validateCoercion reps1 reps2 }} + where + lev_poly1 = isTypeLevPoly t1 + lev_poly2 = isTypeLevPoly t2 + + -- don't look at these unless lev_poly1/2 are False + -- Otherwise, we get #13458 + reps1 = typePrimRep t1 + reps2 = typePrimRep t2 + + -- CorePrep deliberately makes ill-kinded casts + -- e.g (case error @Int "blah" of {}) :: Int# + -- ==> (error @Int "blah") |> Unsafe Int Int# + -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep + is_core_prep_prov CorePrepProv = True + is_core_prep_prov _ = False + + validateCoercion :: PrimRep -> PrimRep -> LintM () + validateCoercion rep1 rep2 + = do { platform <- targetPlatform <$> getDynFlags + ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) + (report "between unboxed and boxed value") + ; checkWarnL (TyCon.primRepSizeB platform rep1 + == TyCon.primRepSizeB platform rep2) + (report "between unboxed values of different size") + ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) + (TyCon.primRepIsFloat rep2) + ; case fl of + Nothing -> addWarnL (report "between vector types") + Just False -> addWarnL (report "between float and integral values") + _ -> return () + } + + lint_prov k1 k2 (PhantomProv kco) + = do { kco' <- lintStarCoercion kco + ; lintRole co Phantom r + ; check_kinds kco' k1 k2 + ; return (PhantomProv kco') } + + lint_prov k1 k2 (ProofIrrelProv kco) + = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co) + ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co) + ; kco' <- lintStarCoercion kco + ; check_kinds kco k1 k2 + ; return (ProofIrrelProv kco') } + + lint_prov _ _ prov@(PluginProv _) = return prov + lint_prov _ _ prov@CorePrepProv = return prov + + check_kinds kco k1 k2 + = do { let Pair k1' k2' = coercionKind kco + ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) + ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } + + +lintCoercion (SymCo co) + = do { co' <- lintCoercion co + ; return (SymCo co') } + +lintCoercion co@(TransCo co1 co2) + = do { co1' <- lintCoercion co1 + ; co2' <- lintCoercion co2 + ; let ty1b = coercionRKind co1' + ty2a = coercionLKind co2' + ; ensureEqTys ty1b ty2a + (hang (text "Trans coercion mis-match:" <+> ppr co) + 2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')])) + ; lintRole co (coercionRole co1) (coercionRole co2) + ; return (TransCo co1' co2') } + +lintCoercion the_co@(NthCo r0 n co) + = do { co' <- lintCoercion co + ; let (Pair s t, r) = coercionKindRole co' + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + { (Just _, Just _) + -- works for both tyvar and covar + | n == 0 + , (isForAllTy_ty s && isForAllTy_ty t) + || (isForAllTy_co s && isForAllTy_co t) + -> do { lintRole the_co Nominal r0 + ; return (NthCo r0 n co') } + + ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + { (Just (tc_s, tys_s), Just (tc_t, tys_t)) + | tc_s == tc_t + , isInjectiveTyCon tc_s r + -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep + , tys_s `equalLength` tys_t + , tys_s `lengthExceeds` n + -> do { lintRole the_co tr r0 + ; return (NthCo r0 n co') } + where + tr = nthRole r tc_s n + + ; _ -> failWithL (hang (text "Bad getNth:") + 2 (ppr the_co $$ ppr s $$ ppr t)) }}} + +lintCoercion the_co@(LRCo lr co) + = do { co' <- lintCoercion co + ; let Pair s t = coercionKind co' + r = coercionRole co' + ; lintRole co Nominal r + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just _, Just _) -> return (LRCo lr co') + _ -> failWithL (hang (text "Bad LRCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion (InstCo co arg) + = do { co' <- lintCoercion co + ; arg' <- lintCoercion arg + ; let Pair t1 t2 = coercionKind co' + Pair s1 s2 = coercionKind arg' + + ; lintRole arg Nominal (coercionRole arg') + + ; case (splitForAllTy_ty_maybe t1, splitForAllTy_ty_maybe t2) of + -- forall over tvar + { (Just (tv1,_), Just (tv2,_)) + | typeKind s1 `eqType` tyVarKind tv1 + , typeKind s2 `eqType` tyVarKind tv2 + -> return (InstCo co' arg') + | otherwise + -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co) + + ; _ -> case (splitForAllTy_co_maybe t1, splitForAllTy_co_maybe t2) of + -- forall over covar + { (Just (cv1, _), Just (cv2, _)) + | typeKind s1 `eqType` varType cv1 + , typeKind s2 `eqType` varType cv2 + , CoercionTy _ <- s1 + , CoercionTy _ <- s2 + -> return (InstCo co' arg') + | otherwise + -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co) + + ; _ -> failWithL (text "Bad argument of inst") }}} + +lintCoercion co@(AxiomInstCo con ind cos) + = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) + (bad_ax (text "index out of range")) + ; let CoAxBranch { cab_tvs = ktvs + , cab_cvs = cvs + , cab_roles = roles } = coAxiomNthBranch con ind + ; unless (cos `equalLength` (ktvs ++ cvs)) $ + bad_ax (text "lengths") + ; cos' <- mapM lintCoercion cos + ; subst <- getTCvSubst + ; let empty_subst = zapTCvSubst subst + ; _ <- foldlM check_ki (empty_subst, empty_subst) + (zip3 (ktvs ++ cvs) roles cos') + ; let fam_tc = coAxiomTyCon con + ; case checkAxInstCo co of + Just bad_branch -> bad_ax $ text "inconsistent with" <+> + pprCoAxBranch fam_tc bad_branch + Nothing -> return () + ; return (AxiomInstCo con ind cos') } + where + bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, role, arg') + = do { let Pair s' t' = coercionKind arg' + sk' = typeKind s' + tk' = typeKind t' + ; lintRole arg' role (coercionRole arg') + ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) + ktv_kind_r = substTy subst_r (tyVarKind ktv) + ; unless (sk' `eqType` ktv_kind_l) + (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr sk', ppr ktv, ppr ktv_kind_l ] )) + ; unless (tk' `eqType` ktv_kind_r) + (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr tk', ppr ktv, ppr ktv_kind_r ] )) + ; return (extendTCvSubst subst_l ktv s', + extendTCvSubst subst_r ktv t') } + +lintCoercion (KindCo co) + = do { co' <- lintCoercion co + ; return (KindCo co') } + +lintCoercion (SubCo co') + = do { co' <- lintCoercion co' + ; lintRole co' Nominal (coercionRole co') + ; return (SubCo co') } + +lintCoercion this@(AxiomRuleCo ax cos) + = do { cos' <- mapM lintCoercion cos + ; lint_roles 0 (coaxrAsmpRoles ax) cos' + ; case coaxrProves ax (map coercionKind cos') of + Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] + Just _ -> return (AxiomRuleCo ax cos') } + where + err m xs = failWithL $ + hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName ax) : xs) + + lint_roles n (e : es) (co : cos) + | e == coercionRole co = lint_roles (n+1) es cos + | otherwise = err "Argument roles mismatch" + [ text "In argument:" <+> int (n+1) + , text "Expected:" <+> ppr e + , text "Found:" <+> ppr (coercionRole co) ] + lint_roles _ [] [] = return () + lint_roles n [] rs = err "Too many coercion arguments" + [ text "Expected:" <+> int n + , text "Provided:" <+> int (n + length rs) ] + + lint_roles n es [] = err "Not enough coercion arguments" + [ text "Expected:" <+> int (n + length es) + , text "Provided:" <+> int n ] + +lintCoercion (HoleCo h) + = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h + ; lintCoercion (CoVarCo (coHoleCoVar h)) } + +{- +************************************************************************ +* * + Axioms +* * +************************************************************************ +-} + +lintAxioms :: DynFlags + -> [CoAxiom Branched] + -> WarnsAndErrs +lintAxioms dflags axioms + = initL dflags (defaultLintFlags dflags) [] $ + do { mapM_ lint_axiom axioms + ; let axiom_groups = groupWith coAxiomTyCon axioms + ; mapM_ lint_axiom_group axiom_groups } + +lint_axiom :: CoAxiom Branched -> LintM () +lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches + , co_ax_role = ax_role }) + = addLoc (InAxiom ax) $ + do { mapM_ (lint_branch tc) branch_list + ; extra_checks } + where + branch_list = fromBranches branches + + extra_checks + | isNewTyCon tc + = do { CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs_tys } + <- case branch_list of + [branch] -> return branch + _ -> failWithL (text "multi-branch axiom with newtype") + ; let ax_lhs = mkInfForAllTys tvs $ + mkTyConApp tc lhs_tys + nt_tvs = takeList tvs (tyConTyVars tc) + -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon + nt_lhs = mkInfForAllTys nt_tvs $ + mkTyConApp tc (mkTyVarTys nt_tvs) + -- See Note [Newtype eta] in GHC.Core.TyCon + ; lintL (ax_lhs `eqType` nt_lhs) + (text "Newtype axiom LHS does not match newtype definition") + ; lintL (null cvs) + (text "Newtype axiom binds coercion variables") + ; lintL (null eta_tvs) -- See Note [Eta reduction for data families] + -- which is not about newtype axioms + (text "Newtype axiom has eta-tvs") + ; lintL (ax_role == Representational) + (text "Newtype axiom role not representational") + ; lintL (roles `equalLength` tvs) + (text "Newtype axiom roles list is the wrong length." $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (roles == takeList roles (tyConRoles tc)) + (vcat [ text "Newtype axiom roles do not match newtype tycon's." + , text "axiom roles:" <+> sep (map ppr roles) + , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ]) + } + + | isFamilyTyCon tc + = do { if | isTypeFamilyTyCon tc + -> lintL (ax_role == Nominal) + (text "type family axiom is not nominal") + + | isDataFamilyTyCon tc + -> lintL (ax_role == Representational) + (text "data family axiom is not representational") + + | otherwise + -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc) + + ; mapM_ (lint_family_branch tc) branch_list } + + | otherwise + = addErrL (text "Axiom tycon is neither a newtype nor a family.") + +lint_branch :: TyCon -> CoAxBranch -> LintM () +lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs_args, cab_rhs = rhs }) + = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> + do { let lhs = mkTyConApp ax_tc lhs_args + ; lhs' <- lintType lhs + ; rhs' <- lintType rhs + ; let lhs_kind = typeKind lhs' + rhs_kind = typeKind rhs' + ; lintL (lhs_kind `eqType` rhs_kind) $ + hang (text "Inhomogeneous axiom") + 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ + text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) } + +-- these checks do not apply to newtype axioms +lint_family_branch :: TyCon -> CoAxBranch -> LintM () +lint_family_branch fam_tc br@(CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs + , cab_incomps = incomps }) + = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs) + (text "Type family axiom has eta-tvs") + ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs) + (text "Quantified variable in family axiom unused in LHS") + ; lintL (all isTyFamFree lhs) + (text "Type family application on LHS of family axiom") + ; lintL (all (== Nominal) roles) + (text "Non-nominal role in family axiom" $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (null cvs) + (text "Coercion variables bound in family axiom") + ; forM_ incomps $ \ br' -> + lintL (not (compatible_branches br br')) $ + text "Incorrect incompatible branch:" <+> ppr br' } + +lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () +lint_axiom_group (_ :| []) = return () +lint_axiom_group (ax :| axs) + = do { lintL (isOpenFamilyTyCon tc) + (text "Non-open-family with multiple axioms") + ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs + , ax2 <- all_axs ] + ; mapM_ (lint_axiom_pair tc) all_pairs } + where + all_axs = ax : axs + tc = coAxiomTyCon ax + +lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM () +lint_axiom_pair tc (ax1, ax2) + | Just br1@(CoAxBranch { cab_tvs = tvs1 + , cab_lhs = lhs1 + , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1 + , Just br2@(CoAxBranch { cab_tvs = tvs2 + , cab_lhs = lhs2 + , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2 + = lintL (compatible_branches br1 br2) $ + vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2 + , text "are incompatible" ] + , text "tvs1 =" <+> pprTyVars tvs1 + , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1) + , text "rhs1 =" <+> ppr rhs1 + , text "tvs2 =" <+> pprTyVars tvs2 + , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2) + , text "rhs2 =" <+> ppr rhs2 ] + + | otherwise + = addErrL (text "Open type family axiom has more than one branch: either" <+> + ppr ax1 <+> text "or" <+> ppr ax2) + +compatible_branches :: CoAxBranch -> CoAxBranch -> Bool +-- True <=> branches are compatible. See Note [Compatibility] in GHC.Core.FamInstEnv. +compatible_branches (CoAxBranch { cab_tvs = tvs1 + , cab_lhs = lhs1 + , cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2 + , cab_lhs = lhs2 + , cab_rhs = rhs2 }) + = -- we need to freshen ax2 w.r.t. ax1 + -- do this by pretending tvs1 are in scope when processing tvs2 + let in_scope = mkInScopeSet (mkVarSet tvs1) + subst0 = mkEmptyTCvSubst in_scope + (subst, _) = substTyVarBndrs subst0 tvs2 + lhs2' = substTys subst lhs2 + rhs2' = substTy subst rhs2 + in + case tcUnifyTys (const BindMe) lhs1 lhs2' of + Just unifying_subst -> substTy unifying_subst rhs1 `eqType` + substTy unifying_subst rhs2' + Nothing -> True + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +data LintEnv + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + + , le_subst :: TCvSubst -- Current TyCo substitution + -- See Note [Linting type lets] + -- /Only/ substitutes for type variables; + -- but might clone CoVars + -- We also use le_subst to keep track of + -- in-scope TyVars and CoVars (but not Ids) + -- Range of the TCvSubst is LintedType/LintedCo + + , le_ids :: VarEnv (Id, LintedType) -- In-scope Ids + -- Used to check that occurrences have an enclosing binder. + -- The Id is /pre-substitution/, used to check that + -- the occurrence has an identical type to the binder + -- The LintedType is used to return the type of the occurrence, + -- without having to lint it again. + + , le_joins :: IdSet -- Join points in scope that are valid + -- A subset of the InScopeSet in le_subst + -- See Note [Join points] + + , le_dynflags :: DynFlags -- DynamicFlags + , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the + -- alias-like binders, as found in + -- non-recursive lets. + } + +data LintFlags + = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] + , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] + , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] + , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] + , lf_check_levity_poly :: Bool -- See Note [Checking for levity polymorphism] + } + +-- See Note [Checking StaticPtrs] +data StaticPtrCheck + = AllowAnywhere + -- ^ Allow 'makeStatic' to occur anywhere. + | AllowAtTopLevel + -- ^ Allow 'makeStatic' calls at the top-level only. + | RejectEverywhere + -- ^ Reject any 'makeStatic' occurrence. + deriving Eq + +defaultLintFlags :: DynFlags -> LintFlags +defaultLintFlags dflags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = AllowAnywhere + , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags + , lf_report_unsat_syns = True + , lf_check_levity_poly = True + } + +newtype LintM a = + LintM { unLintM :: + LintEnv -> + WarnsAndErrs -> -- Warning and error messages so far + (Maybe a, WarnsAndErrs) } -- Result and messages (if any) + deriving (Functor) + +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) + +{- Note [Checking for global Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before CoreTidy, all locally-bound Ids must be LocalIds, even +top-level ones. See Note [Exported LocalIds] and #9857. + +Note [Checking StaticPtrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. + +Every occurrence of the function 'makeStatic' should be moved to the +top level by the FloatOut pass. It's vital that we don't have nested +'makeStatic' occurrences after CorePrep, because we populate the Static +Pointer Table from the top-level bindings. See SimplCore Note [Grand +plan for static forms]. + +The linter checks that no occurrence is left behind, nested within an +expression. The check is enabled only after the FloatOut, CorePrep, +and CoreTidy passes and only if the module uses the StaticPointers +language extension. Checking more often doesn't help since the condition +doesn't hold until after the first FloatOut pass. + +Note [Type substitution] +~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. + +Note [Linting type synonym applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting a type-synonym, or type-family, application + S ty1 .. tyn +we behave as follows (#15057, #T15664): + +* If lf_report_unsat_syns = True, and S has arity < n, + complain about an unsaturated type synonym or type family + +* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. + + Reason: catch out of scope variables or other ill-kinded gubbins, + even if S discards that argument entirely. E.g. (#15012): + type FakeOut a = Int + type family TF a + type instance TF Int = FakeOut a + Here 'a' is out of scope; but if we expand FakeOut, we conceal + that out-of-scope error. + + Reason for switching off lf_report_unsat_syns: with + LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they + are saturated when the type is expanded. Example + type T f = f Int + type S a = a -> a + type Z = T S + In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. + +* If lf_report_unsat_syns is on, expand the synonym application and + lint the result. Reason: want to check that synonyms are saturated + when the type is expanded. + +Note [Linting linearity] +~~~~~~~~~~~~~~~~~~~~~~~~ +There are two known optimisations that have not yet been updated +to work with Linear Lint: + +* Lambda-bound variables with unfoldings + (see Note [Case binders and join points] and ticket #17530) +* Optimisations can create a letrec which uses a variable linearly, e.g. + letrec f True = f False + f False = x + in f True + uses 'x' linearly, but this is not seen by the linter. + Plan: make let-bound variables remember the usage environment. + See test LinearLetRec and https://github.com/tweag/ghc/issues/405. + +We plan to fix both of the issues in the very near future. +For now, linear Lint is disabled by default and +has to be enabled manually with -dlinear-core-lint. +-} + +instance Applicative LintM where + pure x = LintM $ \ _ errs -> (Just x, errs) + (<*>) = ap + +instance Monad LintM where + m >>= k = LintM (\ env errs -> + let (res, errs') = unLintM m env errs in + case res of + Just r -> unLintM (k r) env errs' + Nothing -> (Nothing, errs')) + +instance MonadFail LintM where + fail err = failWithL (text err) + +instance HasDynFlags LintM where + getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) + +data LintLocInfo + = RhsOf Id -- The variable bound + | OccOf Id -- Occurrence of id + | LambdaBodyOf Id -- The lambda-binder + | RuleOf Id -- Rules attached to a binder + | UnfoldingOf Id -- Unfolding of a binder + | BodyOfLetRec [Id] -- One of the binders + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | CaseTy CoreExpr -- The type field of a case expression + -- with this scrutinee + | IdTy Id -- The type field of an Id binder + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + | InAxiom (CoAxiom Branched) -- Inside a CoAxiom + +initL :: DynFlags -> LintFlags -> [Var] + -> LintM a -> WarnsAndErrs -- Warnings and errors +initL dflags flags vars m + = case unLintM m env (emptyBag, emptyBag) of + (Just _, errs) -> errs + (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + "without reporting an error message") empty + where + (tcvs, ids) = partition isTyCoVar vars + env = LE { le_flags = flags + , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs)) + , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] + , le_joins = emptyVarSet + , le_loc = [] + , le_dynflags = dflags + , le_ue_aliases = emptyNameEnv } + +setReportUnsat :: Bool -> LintM a -> LintM a +-- Switch off lf_report_unsat_syns +setReportUnsat ru thing_inside + = LintM $ \ env errs -> + let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } + in unLintM thing_inside env' errs + +-- See Note [Checking for levity polymorphism] +noLPChecks :: LintM a -> LintM a +noLPChecks thing_inside + = LintM $ \env errs -> + let env' = env { le_flags = (le_flags env) { lf_check_levity_poly = False } } + in unLintM thing_inside env' errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) + +checkL :: Bool -> MsgDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +-- like checkL, but relevant to type checking +lintL :: Bool -> MsgDoc -> LintM () +lintL = checkL + +checkWarnL :: Bool -> MsgDoc -> LintM () +checkWarnL True _ = return () +checkWarnL False msg = addWarnL msg + +failWithL :: MsgDoc -> LintM a +failWithL msg = LintM $ \ env (warns,errs) -> + (Nothing, (warns, addMsg True env errs msg)) + +addErrL :: MsgDoc -> LintM () +addErrL msg = LintM $ \ env (warns,errs) -> + (Just (), (warns, addMsg True env errs msg)) + +addWarnL :: MsgDoc -> LintM () +addWarnL msg = LintM $ \ env (warns,errs) -> + (Just (), (addMsg False env warns msg, errs)) + +addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc +addMsg is_error env msgs msg + = ASSERT2( notNull loc_msgs, msg ) + msgs `snocBag` mk_msg msg + where + loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first + loc_msgs = map dumpLoc (le_loc env) + + cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs + , text "Substitution:" <+> ppr (le_subst env) ] + context | is_error = cxt_doc + | otherwise = whenPprDebug cxt_doc + -- Print voluminous info for Lint errors + -- but not for warnings + + msg_span = case [ span | (loc,_) <- loc_msgs + , let span = srcLocSpan loc + , isGoodSrcSpan span ] of + [] -> noSrcSpan + (s:_) -> s + mk_msg msg = mkLocMessage SevWarning msg_span + (msg $$ context) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m + = LintM $ \ env errs -> + unLintM m (env { le_loc = extra_loc : le_loc env }) errs + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) + where + is_case_pat (LE { le_loc = CasePat {} : _ }) = True + is_case_pat _other = False + +addInScopeId :: Id -> LintedType -> LintM a -> LintM a +addInScopeId id linted_ty m + = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set }) errs -> + unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) + , le_joins = add_joins join_set }) errs + where + add_joins join_set + | isJoinId id = extendVarSet join_set id -- Overwrite with new arity + | otherwise = delVarSet join_set id -- Remove any existing binding + +getInScopeIds :: LintM (VarEnv (Id,LintedType)) +getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs)) + +extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a +extendTvSubstL tv ty m + = LintM $ \ env errs -> + unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + +updateTCvSubst :: TCvSubst -> LintM a -> LintM a +updateTCvSubst subst' m + = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs + +markAllJoinsBad :: LintM a -> LintM a +markAllJoinsBad m + = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs + +markAllJoinsBadIf :: Bool -> LintM a -> LintM a +markAllJoinsBadIf True m = markAllJoinsBad m +markAllJoinsBadIf False m = m + +getValidJoins :: LintM IdSet +getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) + +getTCvSubst :: LintM TCvSubst +getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) + +getUEAliases :: LintM (NameEnv UsageEnv) +getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) + +lookupIdInScope :: Id -> LintM (Id, LintedType) +lookupIdInScope id_occ + = do { in_scope_ids <- getInScopeIds + ; case lookupVarEnv in_scope_ids id_occ of + Just (id_bndr, linted_ty) + -> do { checkL (not (bad_global id_bndr)) global_in_scope + ; return (id_bndr, linted_ty) } + Nothing -> do { checkL (not is_local) local_out_of_scope + ; return (id_occ, idType id_occ) } } + -- We don't bother to lint the type + -- of global (i.e. imported) Ids + where + is_local = mustHaveLocalBinding id_occ + local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ + global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId") + 2 (pprBndr LetBind id_occ) + bad_global id_bnd = isGlobalId id_occ + && isLocalId id_bnd + && not (isWiredIn id_occ) + -- 'bad_global' checks for the case where an /occurrence/ is + -- a GlobalId, but there is an enclosing binding fora a LocalId. + -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, + -- but GHCi adds GlobalIds from the interactive context. These + -- are fine; hence the test (isLocalId id == isLocalId v) + -- NB: when compiling Control.Exception.Base, things like absentError + -- are defined locally, but appear in expressions as (global) + -- wired-in Ids after worker/wrapper + -- So we simply disable the test in this case + +lookupJoinId :: Id -> LintM (Maybe JoinArity) +-- Look up an Id which should be a join point, valid here +-- If so, return its arity, if not return Nothing +lookupJoinId id + = do { join_set <- getValidJoins + ; case lookupVarSet join_set id of + Just id' -> return (isJoinId_maybe id') + Nothing -> return Nothing } + +addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a +addAliasUE id ue thing_inside = LintM $ \ env errs -> + let new_ue_aliases = + extendNameEnv (le_ue_aliases env) (getName id) ue + in + unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs + +varCallSiteUsage :: Id -> LintM UsageEnv +varCallSiteUsage id = + do m <- getUEAliases + return $ case lookupNameEnv m (getName id) of + Nothing -> unitUE id One + Just id_ue -> id_ue + +ensureEqTys :: LintedType -> LintedType -> MsgDoc -> LintM () +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +-- Assumes ty1,ty2 are have already had the substitution applied +ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg + +ensureSubUsage :: Usage -> Mult -> SDoc -> LintM () +ensureSubUsage Bottom _ _ = return () +ensureSubUsage Zero described_mult err_msg = ensureSubMult Many described_mult err_msg +ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg + +ensureSubMult :: Mult -> Mult -> SDoc -> LintM () +ensureSubMult actual_usage described_usage err_msg = do + flags <- getLintFlags + when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of + Submult -> return () + Unknown -> case isMultMul actual_usage' of + Just (m1, m2) -> ensureSubMult m1 described_usage' err_msg >> + ensureSubMult m2 described_usage' err_msg + Nothing -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) + + where actual_usage' = normalize actual_usage + described_usage' = normalize described_usage + + normalize :: Mult -> Mult + normalize m = case isMultMul m of + Just (m1, m2) -> mkMultMul (normalize m1) (normalize m2) + Nothing -> m + +lintRole :: Outputable thing + => thing -- where the role appeared + -> Role -- expected + -> Role -- actual + -> LintM () +lintRole co r1 r2 + = lintL (r1 == r2) + (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text "got" <+> ppr r2 $$ + text "in" <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) + +dumpLoc (OccOf v) + = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) + +dumpLoc (RuleOf b) + = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b) + +dumpLoc (UnfoldingOf b) + = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, text "In body of a letrec with no binders") + +dumpLoc (BodyOfLetRec bs@(_:_)) + = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs) + +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) + +dumpLoc (CaseAlt (con, args, _)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (con, args, _)) + = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CaseTy scrut) + = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") + 2 (ppr scrut)) + +dumpLoc (IdTy b) + = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) + +dumpLoc (ImportedUnfolding locn) + = (locn, text "In an imported unfolding") +dumpLoc TopLevelBindings + = (noSrcLoc, Outputable.empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) +dumpLoc (InAxiom ax) + = (getSrcLoc ax_name, text "In the coercion axiom" <+> ppr ax_name <+> dcolon <+> pp_ax) + where + CoAxiom { co_ax_name = ax_name + , co_ax_tc = tc + , co_ax_role = ax_role + , co_ax_branches = branches } = ax + branch_list = fromBranches branches + + pp_ax + | [branch] <- branch_list + = pp_branch branch + + | otherwise + = braces $ vcat (map pp_branch branch_list) + + pp_branch (CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs + , cab_lhs = lhs_tys + , cab_rhs = rhs_ty }) + = sep [ brackets (pprWithCommas pprTyVar (tvs ++ cvs)) <> dot + , ppr (mkTyConApp tc lhs_tys) + , text "~_" <> pp_role ax_role + , ppr rhs_ty ] + + pp_role Nominal = text "N" + pp_role Representational = text "R" + pp_role Phantom = text "P" + +pp_binders :: [Var] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) + +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] + +------------------------------------------------------ +-- Messages for case expressions + +mkDefaultArgsMsg :: [Var] -> MsgDoc +mkDefaultArgsMsg args + = hang (text "DEFAULT case with binders") + 4 (ppr args) + +mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ text "Actual type:" <+> ppr ty1, + text "Annotation on case:" <+> ppr ty2, + text "Alt Rhs:" <+> ppr e ]) + +mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc +mkScrutMsg var var_ty scrut_ty subst + = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, + text "Result binder type:" <+> ppr var_ty,--(idType var), + text "Scrutinee type:" <+> ppr scrut_ty, + hsep [text "Current TCv subst", ppr subst]] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) + +nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc +nonExhaustiveAltsMsg e + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) + +mkBadConMsg :: TyCon -> DataCon -> MsgDoc +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + +mkBadPatMsg :: Type -> Type -> MsgDoc +mkBadPatMsg con_result_ty scrut_ty + = vcat [ + text "In a case alternative, pattern result type doesn't match scrutinee type:", + text "Pattern result type:" <+> ppr con_result_ty, + text "Scrutinee type:" <+> ppr scrut_ty + ] + +integerScrutinisedMsg :: MsgDoc +integerScrutinisedMsg + = text "In a LitAlt, the literal is lifted (probably Integer)" + +mkBadAltMsg :: Type -> CoreAlt -> MsgDoc +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc +mkNewTyDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for newtype datacon", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + + +------------------------------------------------------ +-- Other error messages + +mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkAppMsg fun_ty arg_ty arg + = vcat [text "Argument value doesn't match argument type:", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [text "Non-function type in function position", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> MsgDoc +mkLetErr bndr rhs + = vcat [text "Bad `let' binding:", + hang (text "Variable:") + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (text "Rhs:") + 4 (ppr rhs)] + +mkTyAppMsg :: Type -> Type -> MsgDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (text "Exp type:") + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +emptyRec :: CoreExpr -> MsgDoc +emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) + +mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg binder what ty + = vcat + [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, + ppr binder], + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty]] + +mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg e + = hang (text "This argument does not satisfy the let/app invariant:") + 2 (ppr e) + +badBndrTyMsg :: Id -> SDoc -> MsgDoc +badBndrTyMsg binder what + = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder + , text "Binder's type:" <+> ppr (idType binder) ] + +mkStrictMsg :: Id -> MsgDoc +mkStrictMsg binder + = vcat [hsep [text "Recursive or top-level binder has strict demand info:", + ppr binder], + hsep [text "Binder's demand info:", ppr (idDemandInfo binder)] + ] + +mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg binder + = hsep [text "Non-top-level binder is marked as exported:", ppr binder] + +mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg binder + = hsep [text "Non-top-level binder has an external name:", ppr binder] + +mkTopNonLitStrMsg :: Id -> MsgDoc +mkTopNonLitStrMsg binder + = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] + +mkKindErrMsg :: TyVar -> Type -> MsgDoc +mkKindErrMsg tyvar arg_ty + = vcat [text "Kinds don't match in type application:", + hang (text "Type variable:") + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) + +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc +mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) + +mk_cast_err :: String -- ^ What sort of casted thing this is + -- (\"expression\" or \"type\"). + -> String -- ^ What sort of coercion is being used + -- (\"type\" or \"kind\"). + -> SDoc -- ^ The thing being casted. + -> Coercion -> Type -> Type -> MsgDoc +mk_cast_err thing_str co_str pp_thing co from_ty thing_ty + = vcat [from_msg <+> text "of Cast differs from" <+> co_msg + <+> text "of" <+> enclosed_msg, + from_msg <> colon <+> ppr from_ty, + text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon + <+> ppr thing_ty, + text "Actual" <+> enclosed_msg <> colon <+> pp_thing, + text "Coercion used in cast:" <+> ppr co + ] + where + co_msg, from_msg, enclosed_msg :: SDoc + co_msg = text co_str + from_msg = text "From-" <> co_msg + enclosed_msg = text "enclosed" <+> text thing_str + +mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc +mkBadUnivCoMsg lr co + = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> + text "side of a UnivCo:" <+> ppr co + +mkBadProofIrrelMsg :: Type -> Coercion -> SDoc +mkBadProofIrrelMsg ty co + = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") + 2 (vcat [ text "type:" <+> ppr ty + , text "co:" <+> ppr co ]) + +mkBadTyVarMsg :: Var -> SDoc +mkBadTyVarMsg tv + = text "Non-tyvar used in TyVarTy:" + <+> ppr tv <+> dcolon <+> ppr (varType tv) + +mkBadJoinBindMsg :: Var -> SDoc +mkBadJoinBindMsg var + = vcat [ text "Bad join point binding:" <+> ppr var + , text "Join points can be bound only by a non-top-level let" ] + +mkInvalidJoinPointMsg :: Var -> Type -> SDoc +mkInvalidJoinPointMsg var ty + = hang (text "Join point has invalid type:") + 2 (ppr var <+> dcolon <+> ppr ty) + +mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc +mkBadJoinArityMsg var ar n rhs + = vcat [ text "Join point has too few lambdas", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of lambdas:" <+> ppr (ar - n), + text "Rhs = " <+> ppr rhs + ] + +invalidJoinOcc :: Var -> SDoc +invalidJoinOcc var + = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var + , text "The binder is either not a join point, or not valid here" ] + +mkBadJumpMsg :: Var -> Int -> Int -> SDoc +mkBadJumpMsg var ar nargs + = vcat [ text "Join point invoked with wrong number of arguments", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of arguments:" <+> int nargs ] + +mkInconsistentRecMsg :: [Var] -> SDoc +mkInconsistentRecMsg bndrs + = vcat [ text "Recursive let binders mix values and join points", + text "Binders:" <+> hsep (map ppr_with_details bndrs) ] + where + ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) + +mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc +mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ + = vcat [ text "Mismatch in join point arity between binder and occurrence" + , text "Var:" <+> ppr bndr + , text "Arity at binding site:" <+> ppr join_arity_bndr + , text "Arity at occurrence: " <+> ppr join_arity_occ ] + +mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc +mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty + = vcat [ text "Mismatch in type between binder and occurrence" + , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty + , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty + , text " Before subst:" <+> ppr (idType var) ] + +mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc +mkBadJoinPointRuleMsg bndr join_arity rule + = vcat [ text "Join point has rule with wrong number of arguments" + , text "Var:" <+> ppr bndr + , text "Join arity:" <+> ppr join_arity + , text "Rule:" <+> ppr rule ] + +pprLeftOrRight :: LeftOrRight -> MsgDoc +pprLeftOrRight CLeft = text "left" +pprLeftOrRight CRight = text "right" + +dupVars :: [NonEmpty Var] -> MsgDoc +dupVars vars + = hang (text "Duplicate variables brought into scope") + 2 (ppr (map toList vars)) + +dupExtVars :: [NonEmpty Name] -> MsgDoc +dupExtVars vars + = hang (text "Duplicate top-level variables with the same qualified name") + 2 (ppr (map toList vars)) + +{- +************************************************************************ +* * +\subsection{Annotation Linting} +* * +************************************************************************ +-} + +-- | This checks whether a pass correctly looks through debug +-- annotations (@SourceNote@). This works a bit different from other +-- consistency checks: We check this by running the given task twice, +-- noting all differences between the results. +lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +lintAnnots pname pass guts = do + -- Run the pass as we normally would + dflags <- getDynFlags + when (gopt Opt_DoAnnotationLinting dflags) $ + liftIO $ Err.showPass dflags "Annotation linting - first run" + nguts <- pass guts + -- If appropriate re-run it without debug annotations to make sure + -- that they made no difference. + when (gopt Opt_DoAnnotationLinting dflags) $ do + liftIO $ Err.showPass dflags "Annotation linting - second run" + nguts' <- withoutAnnots pass guts + -- Finally compare the resulting bindings + liftIO $ Err.showPass dflags "Annotation linting - comparison" + let binds = flattenBinds $ mg_binds nguts + binds' = flattenBinds $ mg_binds nguts' + (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' + when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat + [ lint_banner "warning" pname + , text "Core changes with annotations:" + , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs + ] + -- Return actual new guts + return nguts + +-- | Run the given pass without annotations. This means that we both +-- set the debugLevel setting to 0 in the environment as well as all +-- annotations from incoming modules. +withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +withoutAnnots pass guts = do + -- Remove debug flag from environment. + dflags <- getDynFlags + let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} } + withoutFlag corem = + -- TODO: supply tag here as well ? + liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> + getUniqMask <*> getModule <*> + getVisibleOrphanMods <*> + getPrintUnqualified <*> getSrcSpanM <*> + pure corem + -- Nuke existing ticks in module. + -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes + -- them in absence of debugLevel > 0. + let nukeTicks = stripTicksE (not . tickishIsCode) + nukeAnnotsBind :: CoreBind -> CoreBind + nukeAnnotsBind bind = case bind of + Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs + NonRec b e -> NonRec b $ nukeTicks e + nukeAnnotsMod mg@ModGuts{mg_binds=binds} + = mg{mg_binds = map nukeAnnotsBind binds} + -- Perform pass with all changes applied + fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/GHC/Core/Make.hs b/GHC/Core/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Make.hs @@ -0,0 +1,1030 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handy functions for creating much Core syntax +module GHC.Core.Make ( + -- * Constructing normal syntax + mkCoreLet, mkCoreLets, + mkCoreApp, mkCoreApps, mkCoreConApps, + mkCoreLams, mkWildCase, mkIfThenElse, + mkWildValBinder, mkWildEvBinder, + mkSingleAltCase, + sortQuantVars, castBottomExpr, + + -- * Constructing boxed literals + mkWordExpr, + mkIntExpr, mkIntExprInt, mkUncheckedIntExpr, + mkIntegerExpr, mkNaturalExpr, + mkFloatExpr, mkDoubleExpr, + mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, + + -- * Floats + FloatBind(..), wrapFloat, wrapFloats, floatBindings, + + -- * Constructing small tuples + mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreUbxSum, + mkCoreTupBoxity, unitExpr, + + -- * Constructing big tuples + mkBigCoreVarTup, mkBigCoreVarTup1, + mkBigCoreVarTupTy, mkBigCoreTupTy, + mkBigCoreTup, + + -- * Deconstructing small tuples + mkSmallTupleSelector, mkSmallTupleCase, + + -- * Deconstructing big tuples + mkTupleSelector, mkTupleSelector1, mkTupleCase, + + -- * Constructing list expressions + mkNilExpr, mkConsExpr, mkListExpr, + mkFoldrExpr, mkBuildExpr, + + -- * Constructing Maybe expressions + mkNothingExpr, mkJustExpr, + + -- * Error Ids + mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, + rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Var ( EvVar, setTyVarUnique ) + +import GHC.Core +import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) +import GHC.Types.Literal +import GHC.Driver.Types +import GHC.Platform + +import GHC.Builtin.Types +import GHC.Builtin.Names + +import GHC.Hs.Utils ( mkChunkified, chunkify ) +import GHC.Core.Type +import GHC.Core.Coercion ( isCoVar ) +import GHC.Core.DataCon ( DataCon, dataConWorkId ) +import GHC.Core.Multiplicity +import GHC.Builtin.Types.Prim +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Name hiding ( varName ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.Supply +import GHC.Types.Basic +import GHC.Utils.Misc +import Data.List + +import Data.Char ( ord ) + +infixl 4 `mkCoreApp`, `mkCoreApps` + +{- +************************************************************************ +* * +\subsection{Basic GHC.Core construction} +* * +************************************************************************ +-} +sortQuantVars :: [Var] -> [Var] +-- Sort the variables, putting type and covars first, in scoped order, +-- and then other Ids +-- It is a deterministic sort, meaining it doesn't look at the values of +-- Uniques. For explanation why it's important See Note [Unique Determinism] +-- in GHC.Types.Unique. +sortQuantVars vs = sorted_tcvs ++ ids + where + (tcvs, ids) = partition (isTyVar <||> isCoVar) vs + sorted_tcvs = scopedSort tcvs + +-- | Bind a binding group over an expression, using a @let@ or @case@ as +-- appropriate (see "GHC.Core#let_app_invariant") +mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet (NonRec bndr rhs) body -- See Note [Core let/app invariant] + = bindNonRec bndr rhs body +mkCoreLet bind body + = Let bind body + +-- | Create a lambda where the given expression has a number of variables +-- bound over it. The leftmost binder is that bound by the outermost +-- lambda in the result +mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr +mkCoreLams = mkLams + +-- | Bind a list of binding groups over an expression. The leftmost binding +-- group becomes the outermost group in the resulting expression +mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkCoreLets binds body = foldr mkCoreLet body binds + +-- | Construct an expression which represents the application of a number of +-- expressions to that of a data constructor expression. The leftmost expression +-- in the list is applied first +mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr +mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args + +-- | Construct an expression which represents the application of a number of +-- expressions to another. The leftmost expression in the list is applied first +-- Respects the let/app invariant by building a case expression where necessary +-- See Note [Core let/app invariant] in "GHC.Core" +mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreApps fun args + = fst $ + foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args + where + doc_string = ppr fun_ty $$ ppr fun $$ ppr args + fun_ty = exprType fun + +-- | Construct an expression which represents the application of one expression +-- to the other +-- Respects the let/app invariant by building a case expression where necessary +-- See Note [Core let/app invariant] in "GHC.Core" +mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreApp s fun arg + = fst $ mkCoreAppTyped s (fun, exprType fun) arg + +-- | Construct an expression which represents the application of one expression +-- paired with its type to an argument. The result is paired with its type. This +-- function is not exported and used in the definition of 'mkCoreApp' and +-- 'mkCoreApps'. +-- Respects the let/app invariant by building a case expression where necessary +-- See Note [Core let/app invariant] in "GHC.Core" +mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) +mkCoreAppTyped _ (fun, fun_ty) (Type ty) + = (App fun (Type ty), piResultTy fun_ty ty) +mkCoreAppTyped _ (fun, fun_ty) (Coercion co) + = (App fun (Coercion co), funResultTy fun_ty) +mkCoreAppTyped d (fun, fun_ty) arg + = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) + (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty) + where + (mult, arg_ty, res_ty) = splitFunTy fun_ty + +mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr +-- Build an application (e1 e2), +-- or a strict binding (case e2 of x -> e1 x) +-- using the latter when necessary to respect the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core +mkValApp fun arg (Scaled w arg_ty) res_ty + | not (needsCaseBinding arg_ty arg) + = App fun arg -- The vastly common case + | otherwise + = mkStrictApp fun arg (Scaled w arg_ty) res_ty + +{- ********************************************************************* +* * + Building case expressions +* * +********************************************************************* -} + +mkWildEvBinder :: PredType -> EvVar +mkWildEvBinder pred = mkWildValBinder Many pred + +-- | Make a /wildcard binder/. This is typically used when you need a binder +-- that you expect to use only at a *binding* site. Do not use it at +-- occurrence sites because it has a single, fixed unique, and it's very +-- easy to get into difficulties with shadowing. That's why it is used so little. +-- See Note [WildCard binders] in "GHC.Core.Opt.Simplify.Env" +mkWildValBinder :: Mult -> Type -> Id +mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName w ty + -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors + -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. + +mkWildCase :: CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr +-- Make a case expression whose case binder is unused +-- The alts and res_ty should not have any occurrences of WildId +mkWildCase scrut (Scaled w scrut_ty) res_ty alts + = Case scrut (mkWildValBinder w scrut_ty) res_ty alts + +mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr +-- Build a strict application (case e2 of x -> e1 x) +mkStrictApp fun arg (Scaled w arg_ty) res_ty + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] + -- mkDefaultCase looks attractive here, and would be sound. + -- But it uses (exprType alt_rhs) to compute the result type, + -- whereas here we already know that the result type is res_ty + where + arg_id = mkWildValBinder w arg_ty + -- Lots of shadowing, but it doesn't matter, + -- because 'fun' and 'res_ty' should not have a free wild-id + -- + -- This is Dangerous. But this is the only place we play this + -- game, mkStrictApp returns an expression that does not have + -- a free wild-id. So the only way 'fun' could get a free wild-id + -- would be if you take apart this case expression (or some other + -- expression that uses mkWildValBinder, of which there are not + -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. + +mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr +mkIfThenElse guard then_expr else_expr +-- Not going to be refining, so okay to take the type of the "then" clause + = mkWildCase guard (linear boolTy) (exprType then_expr) + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] + +castBottomExpr :: CoreExpr -> Type -> CoreExpr +-- (castBottomExpr e ty), assuming that 'e' diverges, +-- return an expression of type 'ty' +-- See Note [Empty case alternatives] in GHC.Core +castBottomExpr e res_ty + | e_ty `eqType` res_ty = e + | otherwise = Case e (mkWildValBinder One e_ty) res_ty [] + where + e_ty = exprType e + +{- +************************************************************************ +* * +\subsection{Making literals} +* * +************************************************************************ +-} + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExpr :: Platform -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr platform i = mkCoreConApps intDataCon [mkIntLit platform i] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@. Don't check +-- that the number is in the range of the target platform @Int@ +mkUncheckedIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int +mkUncheckedIntExpr i = mkCoreConApps intDataCon [Lit (mkLitIntUnchecked i)] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLit platform (fromIntegral i)] + +-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value +mkWordExpr :: Platform -> Integer -> CoreExpr +mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Integer@ +mkIntegerExpr :: Integer -> CoreExpr -- Result :: Integer +mkIntegerExpr i = Lit (mkLitInteger i) + +-- | Create a 'CoreExpr' which will evaluate to the given @Natural@ +mkNaturalExpr :: Integer -> CoreExpr +mkNaturalExpr i = Lit (mkLitNatural i) + +-- | Create a 'CoreExpr' which will evaluate to the given @Float@ +mkFloatExpr :: Float -> CoreExpr +mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] + +-- | Create a 'CoreExpr' which will evaluate to the given @Double@ +mkDoubleExpr :: Double -> CoreExpr +mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] + + +-- | Create a 'CoreExpr' which will evaluate to the given @Char@ +mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int +mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] + +-- | Create a 'CoreExpr' which will evaluate to the given @String@ +mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String + +-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ +mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String + +mkStringExpr str = mkStringExprFS (mkFastString str) + +mkStringExprFS = mkStringExprFSWith lookupId + +mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr +mkStringExprFSWith lookupM str + | nullFS str + = return (mkNilExpr charTy) + + | all safeChar chars + = do unpack_id <- lookupM unpackCStringName + return (App (Var unpack_id) lit) + + | otherwise + = do unpack_utf8_id <- lookupM unpackCStringUtf8Name + return (App (Var unpack_utf8_id) lit) + + where + chars = unpackFS str + safeChar c = ord c >= 1 && ord c <= 0x7F + lit = Lit (LitString (bytesFS str)) + +{- +************************************************************************ +* * +\subsection{Tuple constructors} +* * +************************************************************************ +-} + +{- +Creating tuples and their types for Core expressions + +@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. + +* If it has only one element, it is the identity function. + +* If there are more elements than a big tuple can have, it nests + the tuples. + +Note [Flattening one-tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This family of functions creates a tuple of variables/expressions/types. + mkCoreTup [e1,e2,e3] = (e1,e2,e3) +What if there is just one variable/expression/type in the argument? +We could do one of two things: + +* Flatten it out, so that + mkCoreTup [e1] = e1 + +* Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types) + mkCoreTup1 [e1] = Solo e1 + We use a suffix "1" to indicate this. + +Usually we want the former, but occasionally the latter. + +NB: The logic in tupleDataCon knows about () and Solo and (,), etc. + +Note [Don't flatten tuples from HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell), +we should treat it really as a 1-tuple, without flattening. Note that a +1-tuple and a flattened value have different performance and laziness +characteristics, so should just do what we're asked. + +This arose from discussions in #16881. + +One-tuples that arise internally depend on the circumstance; often flattening +is a good idea. Decisions are made on a case-by-case basis. + +-} + +-- | Build the type of a small tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [c] = c +mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform + +-- | Build a small tuple holding the specified expressions +-- One-tuples are *not* flattened; see Note [Flattening one-tuples] +-- See also Note [Don't flatten tuples from HsSyn] +mkCoreTup1 :: [CoreExpr] -> CoreExpr +mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) + +-- | Build a small unboxed tuple holding the specified expressions, +-- with the given types. The types must be the types of the expressions. +-- Do not include the RuntimeRep specifiers; this function calculates them +-- for you. +-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] +mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr +mkCoreUbxTup tys exps + = ASSERT( tys `equalLength` exps) + mkCoreConApps (tupleDataCon Unboxed (length tys)) + (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) + +-- | Make a core tuple of the given boxity; don't flatten 1-tuples +mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr +mkCoreTupBoxity Boxed exps = mkCoreTup1 exps +mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps + +-- | Build an unboxed sum. +-- +-- Alternative number ("alt") starts from 1. +mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr +mkCoreUbxSum arity alt tys exp + = ASSERT( length tys == arity ) + ASSERT( alt <= arity ) + mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep) tys + ++ map Type tys + ++ [exp]) + +-- | Build a big tuple holding the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreVarTup :: [Id] -> CoreExpr +mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) + +mkBigCoreVarTup1 :: [Id] -> CoreExpr +-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened +-- see Note [Flattening one-tuples] +mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) + [Type (idType id), Var id] +mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) + +-- | Build the type of a big tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreVarTupTy :: [Id] -> Type +mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) + +-- | Build a big tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup = mkChunkified mkCoreTup + +-- | Build the type of a big tuple that holds the specified type of thing +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreTupTy :: [Type] -> Type +mkBigCoreTupTy = mkChunkified mkBoxedTupleTy + +-- | The unit expression +unitExpr :: CoreExpr +unitExpr = Var unitDataConId + +{- +************************************************************************ +* * +\subsection{Tuple destructors} +* * +************************************************************************ +-} + +-- | Builds a selector which scrutises the given +-- expression and extracts the one name from the list given. +-- If you want the no-shadowing rule to apply, the caller +-- is responsible for making sure that none of these names +-- are in scope. +-- +-- If there is just one 'Id' in the tuple, then the selector is +-- just the identity. +-- +-- If necessary, we pattern match on a \"big\" tuple. +-- +-- A tuple selector is not linear in its argument. Consequently, the case +-- expression built by `mkTupleSelector` must consume its scrutinee 'Many' +-- times. And all the argument variables must have multiplicity 'Many'. +mkTupleSelector, mkTupleSelector1 + :: [Id] -- ^ The 'Id's to pattern match the tuple against + -> Id -- ^ The 'Id' to select + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr -- ^ Selector expression + +-- mkTupleSelector [a,b,c,d] b v e +-- = case e of v { +-- (p,q) -> case p of p { +-- (a,b) -> b }} +-- We use 'tpl' vars for the p,q, since shadowing does not matter. +-- +-- In fact, it's more convenient to generate it innermost first, getting +-- +-- case (case e of v +-- (p,q) -> p) of p +-- (a,b) -> b +mkTupleSelector vars the_var scrut_var scrut + = mk_tup_sel (chunkify vars) the_var + where + mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut + mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ + mk_tup_sel (chunkify tpl_vs) tpl_v + where + tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] + tpl_vs = mkTemplateLocals tpl_tys + [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, + the_var `elem` gp ] +-- ^ 'mkTupleSelector1' is like 'mkTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkTupleSelector1 vars the_var scrut_var scrut + | [_] <- vars + = mkSmallTupleSelector1 vars the_var scrut_var scrut + | otherwise + = mkTupleSelector vars the_var scrut_var scrut + +-- | Like 'mkTupleSelector' but for tuples that are guaranteed +-- never to be \"big\". +-- +-- > mkSmallTupleSelector [x] x v e = [| e |] +-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] +mkSmallTupleSelector, mkSmallTupleSelector1 + :: [Id] -- The tuple args + -> Id -- The selected one + -> Id -- A variable of the same type as the scrutinee + -> CoreExpr -- Scrutinee + -> CoreExpr +mkSmallTupleSelector [var] should_be_the_same_var _ scrut + = ASSERT(var == should_be_the_same_var) + scrut -- Special case for 1-tuples +mkSmallTupleSelector vars the_var scrut_var scrut + = mkSmallTupleSelector1 vars the_var scrut_var scrut + +-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkSmallTupleSelector1 vars the_var scrut_var scrut + = ASSERT( notNull vars ) + Case scrut scrut_var (idType the_var) + [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] + +-- | A generalization of 'mkTupleSelector', allowing the body +-- of the case to be an arbitrary expression. +-- +-- To avoid shadowing, we use uniques to invent new variables. +-- +-- If necessary we pattern match on a \"big\" tuple. +mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables + -> [Id] -- ^ The tuple identifiers to pattern match on + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr +-- ToDo: eliminate cases where none of the variables are needed. +-- +-- mkTupleCase uniqs [a,b,c,d] body v e +-- = case e of v { (p,q) -> +-- case p of p { (a,b) -> +-- case q of q { (c,d) -> +-- body }}} +mkTupleCase uniqs vars body scrut_var scrut + = mk_tuple_case uniqs (chunkify vars) body + where + -- This is the case where don't need any nesting + mk_tuple_case _ [vars] body + = mkSmallTupleCase vars body scrut_var scrut + + -- This is the case where we must make nest tuples at least once + mk_tuple_case us vars_s body + = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s + in mk_tuple_case us' (chunkify vars') body' + + one_tuple_case chunk_vars (us, vs, body) + = let (uniq, us') = takeUniqFromSupply us + scrut_var = mkSysLocal (fsLit "ds") uniq Many + (mkBoxedTupleTy (map idType chunk_vars)) + body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) + in (us', scrut_var:vs, body') + +-- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed +-- not to need nesting. +mkSmallTupleCase + :: [Id] -- ^ The tuple args + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr + +mkSmallTupleCase [var] body _scrut_var scrut + = bindNonRec var scrut body +mkSmallTupleCase vars body scrut_var scrut +-- One branch no refinement? + = Case scrut scrut_var (exprType body) + [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels + +instance Outputable FloatBind where + ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body + +-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] +-- u = let b1 in let b2 in … in let bn in u@ +wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr +wrapFloats floats expr = foldr wrapFloat expr floats + +bindBindings :: CoreBind -> [Var] +bindBindings (NonRec b _) = [b] +bindBindings (Rec bnds) = map fst bnds + +floatBindings :: FloatBind -> [Var] +floatBindings (FloatLet bnd) = bindBindings bnd +floatBindings (FloatCase _ b _ bs) = b:bs + +{- +************************************************************************ +* * +\subsection{Common list manipulation expressions} +* * +************************************************************************ + +Call the constructor Ids when building explicit lists, so that they +interact well with rules. +-} + +-- | Makes a list @[]@ for lists of the specified type +mkNilExpr :: Type -> CoreExpr +mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] + +-- | Makes a list @(:)@ for lists of the specified type +mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr +mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] + +-- | Make a list containing the given expressions, where the list has the given type +mkListExpr :: Type -> [CoreExpr] -> CoreExpr +mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs + +-- | Make a fully applied 'foldr' expression +mkFoldrExpr :: MonadThings m + => Type -- ^ Element type of the list + -> Type -- ^ Fold result type + -> CoreExpr -- ^ "Cons" function expression for the fold + -> CoreExpr -- ^ "Nil" expression for the fold + -> CoreExpr -- ^ List expression being folded acress + -> m CoreExpr +mkFoldrExpr elt_ty result_ty c n list = do + foldr_id <- lookupId foldrName + return (Var foldr_id `App` Type elt_ty + `App` Type result_ty + `App` c + `App` n + `App` list) + +-- | Make a 'build' expression applied to a locally-bound worker function +mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m) + => Type -- ^ Type of list elements to be built + -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's + -- of the binders for the build worker function, returns + -- the body of that worker + -> m CoreExpr +mkBuildExpr elt_ty mk_build_inside = do + n_tyvar <- newTyVar alphaTyVar + let n_ty = mkTyVarTy n_tyvar + c_ty = mkVisFunTysMany [elt_ty, n_ty] n_ty + [c, n] <- sequence [mkSysLocalM (fsLit "c") Many c_ty, mkSysLocalM (fsLit "n") Many n_ty] + + build_inside <- mk_build_inside (c, c_ty) (n, n_ty) + + build_id <- lookupId buildName + return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside + where + newTyVar tyvar_tmpl = do + uniq <- getUniqueM + return (setTyVarUnique tyvar_tmpl uniq) + +{- +************************************************************************ +* * + Manipulating Maybe data type +* * +************************************************************************ +-} + + +-- | Makes a Nothing for the specified type +mkNothingExpr :: Type -> CoreExpr +mkNothingExpr ty = mkConApp nothingDataCon [Type ty] + +-- | Makes a Just from a value of the specified type +mkJustExpr :: Type -> CoreExpr -> CoreExpr +mkJustExpr ty val = mkConApp justDataCon [Type ty, val] + + +{- +************************************************************************ +* * + Error expressions +* * +************************************************************************ +-} + +mkRuntimeErrorApp + :: Id -- Should be of type (forall a. Addr# -> a) + -- where Addr# points to a UTF8 encoded string + -> Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkRuntimeErrorApp err_id res_ty err_msg + = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) + , Type res_ty, err_string ] + where + err_string = Lit (mkLitString err_msg) + +mkImpossibleExpr :: Type -> CoreExpr +mkImpossibleExpr res_ty + = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" + +{- +************************************************************************ +* * + Error Ids +* * +************************************************************************ + +GHC randomly injects these into the code. + +@patError@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absentErr@ (rather than a totally random +crash). + +@parError@ is a special version of @error@ which the compiler does +not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ +templates, but we don't ever expect to generate code for it. +-} + +errorIds :: [Id] +errorIds + = [ rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + rEC_SEL_ERROR_ID, + aBSENT_ERROR_ID, + aBSENT_SUM_FIELD_ERROR_ID, + tYPE_ERROR_ID, -- Used with Opt_DeferTypeErrors, see #10284 + rAISE_OVERFLOW_ID, + rAISE_UNDERFLOW_ID, + rAISE_DIVZERO_ID + ] + +recSelErrorName, runtimeErrorName, absentErrorName :: Name +recConErrorName, patErrorName :: Name +nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name +typeErrorName :: Name +absentSumFieldErrorName :: Name +raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name + +recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID +absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID +runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID +recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID +typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID + +noMethodBindingErrorName = err_nm "noMethodBindingError" + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID + +err_nm :: String -> Unique -> Id -> Name +err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id + +rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id +pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id +tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id +rAISE_OVERFLOW_ID, rAISE_UNDERFLOW_ID, rAISE_DIVZERO_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName +tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName + +-- Note [aBSENT_SUM_FIELD_ERROR_ID] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Unboxed sums are transformed into unboxed tuples in GHC.Stg.Unarise.mkUbxSum +-- and fields that can't be reached are filled with rubbish values. It's easy to +-- come up with rubbish literal values: we use 0 (ints/words) and 0.0 +-- (floats/doubles). Coming up with a rubbish pointer value is more delicate: +-- +-- 1. it needs to be a valid closure pointer for the GC (not a NULL pointer) +-- +-- 2. it is never used in Core, only in STG; and even then only for filling a +-- GC-ptr slot in an unboxed sum (see GHC.Stg.Unarise.ubxSumRubbishArg). +-- So all we need is a pointer, and its levity doesn't matter. Hence we +-- can safely give it the (lifted) type: +-- +-- absentSumFieldError :: forall a. a +-- +-- despite the fact that Unarise might instantiate it at non-lifted +-- types. +-- +-- 3. it can't take arguments because it's used in unarise and applying an +-- argument would require allocating a thunk. +-- +-- 4. it can't be CAFFY because that would mean making some non-CAFFY +-- definitions that use unboxed sums CAFFY in unarise. +-- +-- Getting this wrong causes hard-to-debug runtime issues, see #15038. +-- +-- 5. it can't be defined in `base` package. +-- +-- Defining `absentSumFieldError` in `base` package introduces a +-- dependency on `base` for any code using unboxed sums. It became an +-- issue when we wanted to use unboxed sums in boot libraries used by +-- `base`, see #17791. +-- +-- +-- * Most runtime-error functions throw a proper Haskell exception, which can be +-- caught in the usual way. But these functions are defined in +-- `base:Control.Exception.Base`, hence, they cannot be directly invoked in +-- any library compiled before `base`. Only exceptions that have been wired +-- in the RTS can be thrown (indirectly, via a call into the RTS) by libraries +-- compiled before `base`. +-- +-- However wiring exceptions in the RTS is a bit annoying because we need to +-- explicitly import exception closures via their mangled symbol name (e.g. +-- `import CLOSURE base_GHCziIOziException_heapOverflow_closure`) in Cmm files +-- and every imported symbol must be indicated to the linker in a few files +-- (`package.conf`, `rts.cabal`, `win32/libHSbase.def`, `Prelude.h`...). It +-- explains why exceptions are only wired in the RTS when necessary. +-- +-- * `absentSumFieldError` is defined in ghc-prim:GHC.Prim.Panic, hence, it can +-- be invoked in libraries compiled before `base`. It does not throw a Haskell +-- exception; instead, it calls `stg_panic#`, which immediately halts +-- execution. A runtime invocation of `absentSumFieldError` indicates a GHC +-- bug. Unlike (say) pattern-match errors, it cannot be caused by a user +-- error. That's why it is OK for it to be un-catchable. +-- + +absentSumFieldErrorName + = mkWiredInIdName + gHC_PRIM_PANIC + (fsLit "absentSumFieldError") + absentSumFieldErrorIdKey + aBSENT_SUM_FIELD_ERROR_ID + +raiseOverflowName + = mkWiredInIdName + gHC_PRIM_EXCEPTION + (fsLit "raiseOverflow") + raiseOverflowIdKey + rAISE_OVERFLOW_ID + +raiseUnderflowName + = mkWiredInIdName + gHC_PRIM_EXCEPTION + (fsLit "raiseUnderflow") + raiseUnderflowIdKey + rAISE_UNDERFLOW_ID + +raiseDivZeroName + = mkWiredInIdName + gHC_PRIM_EXCEPTION + (fsLit "raiseDivZero") + raiseDivZeroIdKey + rAISE_DIVZERO_ID + +aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName +rAISE_OVERFLOW_ID = mkExceptionId raiseOverflowName +rAISE_UNDERFLOW_ID = mkExceptionId raiseUnderflowName +rAISE_DIVZERO_ID = mkExceptionId raiseDivZeroName + +-- | Exception with type \"forall a. a\" +mkExceptionId :: Name -> Id +mkExceptionId name + = mkVanillaGlobalWithInfo name + (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a + (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv + `setCprInfo` mkCprSig 0 botCpr + `setArityInfo` 0 + `setCafInfo` NoCafRefs) -- #15038 + +mkRuntimeErrorId :: Name -> Id +-- Error function +-- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a +-- with arity: 1 +-- which diverges after being given one argument +-- The Addr# is expected to be the address of +-- a UTF8-encoded error string +mkRuntimeErrorId name + = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + `setCprInfo` mkCprSig 1 botCpr + `setArityInfo` 1 + -- Make arity and strictness agree + + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + + strict_sig = mkClosedStrictSig [evalDmd] botDiv + +runtimeErrorTy :: Type +-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a +-- See Note [Error and friends have an "open-tyvar" forall] +runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] + (mkVisFunTyMany addrPrimTy openAlphaTy) + +{- Note [Error and friends have an "open-tyvar" forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'error' and 'undefined' have types + error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a + undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a +Notice the runtime-representation polymorphism. This ensures that +"error" can be instantiated at unboxed as well as boxed types. +This is OK because it never returns, so the return type is irrelevant. + + +************************************************************************ +* * + aBSENT_ERROR_ID +* * +************************************************************************ + +Note [aBSENT_ERROR_ID] +~~~~~~~~~~~~~~~~~~~~~~ +We use aBSENT_ERROR_ID to build dummy values in workers. E.g. + + f x = (case x of (a,b) -> b) + 1::Int + +The demand analyser figures ot that only the second component of x is +used, and does a w/w split thus + + f x = case x of (a,b) -> $wf b + + $wf b = let a = absentError "blah" + x = (a,b) + in + +After some simplification, the (absentError "blah") thunk goes away. + +------ Tricky wrinkle ------- +#14285 had, roughly + + data T a = MkT a !a + {-# INLINABLE f #-} + f x = case x of MkT a b -> g (MkT b a) + +It turned out that g didn't use the second component, and hence f doesn't use +the first. But the stable-unfolding for f looks like + \x. case x of MkT a b -> g ($WMkT b a) +where $WMkT is the wrapper for MkT that evaluates its arguments. We +apply the same w/w split to this unfolding (see Note [Worker-wrapper +for INLINEABLE functions] in GHC.Core.Opt.WorkWrap) so the template ends up like + \b. let a = absentError "blah" + x = MkT a b + in case x of MkT a b -> g ($WMkT b a) + +After doing case-of-known-constructor, and expanding $WMkT we get + \b -> g (case absentError "blah" of a -> MkT b a) + +Yikes! That bogusly appears to evaluate the absentError! + +This is extremely tiresome. Another way to think of this is that, in +Core, it is an invariant that a strict data constructor, like MkT, must +be applied only to an argument in HNF. So (absentError "blah") had +better be non-bottom. + +So the "solution" is to add a special case for absentError to exprIsHNFlike. +This allows Simplify.rebuildCase, in the Note [Case to let transformation] +branch, to convert the case on absentError into a let. We also make +absentError *not* be diverging, unlike the other error-ids, so that we +can be sure not to remove the case branches before converting the case to +a let. + +If, by some bug or bizarre happenstance, we ever call absentError, we should +throw an exception. This should never happen, of course, but we definitely +can't return anything. e.g. if somehow we had + case absentError "foo" of + Nothing -> ... + Just x -> ... +then if we return, the case expression will select a field and continue. +Seg fault city. Better to throw an exception. (Even though we've said +it is in HNF :-) + +It might seem a bit surprising that seq on absentError is simply erased + + absentError "foo" `seq` x ==> x + +but that should be okay; since there's no pattern match we can't really +be relying on anything from it. +-} + +aBSENT_ERROR_ID + = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info + where + absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy) + -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for + -- lifted-type things; see Note [Absent errors] in GHC.Core.Opt.WorkWrap.Utils + arity_info = vanillaIdInfo `setArityInfo` 1 + -- NB: no bottoming strictness info, unlike other error-ids. + -- See Note [aBSENT_ERROR_ID] + +mkAbsentErrorApp :: Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkAbsentErrorApp res_ty err_msg + = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] + where + err_string = Lit (mkLitString err_msg) diff --git a/GHC/Core/Map.hs b/GHC/Core/Map.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Map.hs @@ -0,0 +1,835 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Core.Map ( + -- * Maps over Core expressions + CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + -- * Maps over 'Type's + TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, + LooseTypeMap, + -- ** With explicit scoping + CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope, + mkDeBruijnContext, + -- * Maps over 'Maybe' values + MaybeMap, + -- * Maps over 'List' values + ListMap, + -- * Maps over 'Literal's + LiteralMap, + -- * Map for compressing leaves. See Note [Compressed TrieMap] + GenMap, + -- * 'TrieMap' class + TrieMap(..), XT, insertTM, deleteTM, + lkDFreeVar, xtDFreeVar, + lkDNamed, xtDNamed, + (>.>), (|>), (|>>), + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.TrieMap +import GHC.Core +import GHC.Core.Coercion +import GHC.Types.Name +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Types.Var +import GHC.Data.FastString(FastString) +import GHC.Utils.Misc + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import GHC.Types.Var.Env +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import Control.Monad( (>=>) ) + +{- +This module implements TrieMaps over Core related data structures +like CoreExpr or Type. It is built on the Tries from the TrieMap +module. + +The code is very regular and boilerplate-like, but there is +some neat handling of *binders*. In effect they are deBruijn +numbered on the fly. + + +-} + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +-- NB: Be careful about RULES and type families (#5821). So we should make sure +-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) + +-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not +-- known when defining GenMap so we can only specialize them here. + +{-# SPECIALIZE lkG :: Key TypeMapX -> TypeMapG a -> Maybe a #-} +{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-} +{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} + + +{-# SPECIALIZE xtG :: Key TypeMapX -> XT a -> TypeMapG a -> TypeMapG a #-} +{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-} +{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} + +{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a -> TypeMapG b #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} + +{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a -> b -> b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} + + +{- +************************************************************************ +* * + CoreMap +* * +************************************************************************ +-} + +lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a +lkDNamed n env = lookupDNameEnv env (getName n) + +xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a +xtDNamed tc f m = alterDNameEnv f m (getName tc) + + +{- +Note [Binders] +~~~~~~~~~~~~~~ + * In general we check binders as late as possible because types are + less likely to differ than expression structure. That's why + cm_lam :: CoreMapG (TypeMapG a) + rather than + cm_lam :: TypeMapG (CoreMapG a) + + * We don't need to look at the type of some binders, notably + - the case binder in (Case _ b _ _) + - the binders in an alternative + because they are totally fixed by the context + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* For a key (Case e b ty (alt:alts)) we don't need to look the return type + 'ty', because every alternative has that type. + +* For a key (Case e b ty []) we MUST look at the return type 'ty', because + otherwise (Case (error () "urk") _ Int []) would compare equal to + (Case (error () "urk") _ Bool []) + which is utterly wrong (#6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecessary, so we have two fields (cm_case and cm_ecase) +for the two possibilities. Only cm_ecase looks at the type. + +See also Note [Empty case alternatives] in GHC.Core. +-} + +-- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this +-- is the type you want. +newtype CoreMap a = CoreMap (CoreMapG a) + +instance TrieMap CoreMap where + type Key CoreMap = CoreExpr + emptyTM = CoreMap emptyTM + lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) + foldTM k (CoreMap m) = foldTM k m + mapTM f (CoreMap m) = CoreMap (mapTM f m) + +-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'CoreMap' +-- inside another 'TrieMap', this is the type you want. +type CoreMapG = GenMap CoreMapX + +-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without +-- the 'GenMap' optimization. +data CoreMapX a + = CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMapG a + , cm_type :: TypeMapG a + , cm_cast :: CoreMapG (CoercionMapG a) + , cm_tick :: CoreMapG (TickishMap a) + , cm_app :: CoreMapG (CoreMapG a) + , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] + , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) + , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) + , cm_case :: CoreMapG (ListMap AltMap a) + , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] + } + +instance Eq (DeBruijn CoreExpr) where + D env1 e1 == D env2 e2 = go e1 e2 where + go (Var v1) (Var v2) + = case (lookupCME env1 v1, lookupCME env2 v2) of + (Just b1, Just b2) -> b1 == b2 + (Nothing, Nothing) -> v1 == v2 + _ -> False + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = D env1 t1 == D env2 t2 + go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 + go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 + go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 + -- This seems a bit dodgy, see 'eqTickish' + go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 + + go (Lam b1 e1) (Lam b2 e2) + = D env1 (varType b1) == D env2 (varType b2) + && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) + && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 + + go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go r1 r2 + && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 + + go (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = equalLength ps1 ps2 + && D env1' rs1 == D env2' rs2 + && D env1' e1 == D env2' e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env1' = extendCMEs env1 bs1 + env2' = extendCMEs env2 bs2 + + go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] + = null a2 && go e1 e2 && D env1 t1 == D env2 t2 + | otherwise + = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 + + go _ _ = False + +emptyE :: CoreMapX a +emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM + , cm_co = emptyTM, cm_type = emptyTM + , cm_cast = emptyTM, cm_app = emptyTM + , cm_lam = emptyTM, cm_letn = emptyTM + , cm_letr = emptyTM, cm_case = emptyTM + , cm_ecase = emptyTM, cm_tick = emptyTM } + +instance TrieMap CoreMapX where + type Key CoreMapX = DeBruijn CoreExpr + emptyTM = emptyE + lookupTM = lkE + alterTM = xtE + foldTM = fdE + mapTM = mapE + +-------------------------- +mapE :: (a->b) -> CoreMapX a -> CoreMapX b +mapE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit + , cm_co = mapTM f cco, cm_type = mapTM f ctype + , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp + , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn + , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase + , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } + +-------------------------- +lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a +lookupCoreMap cm e = lookupTM e cm + +extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a +extendCoreMap m e v = alterTM e (\_ -> Just v) m + +foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b +foldCoreMap k z m = foldTM k m z + +emptyCoreMap :: CoreMap a +emptyCoreMap = emptyTM + +instance Outputable a => Outputable (CoreMap a) where + ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) + +------------------------- +fdE :: (a -> b -> b) -> CoreMapX a -> b -> b +fdE k m + = foldTM k (cm_var m) + . foldTM k (cm_lit m) + . foldTM k (cm_co m) + . foldTM k (cm_type m) + . foldTM (foldTM k) (cm_cast m) + . foldTM (foldTM k) (cm_tick m) + . foldTM (foldTM k) (cm_app m) + . foldTM (foldTM k) (cm_lam m) + . foldTM (foldTM (foldTM k)) (cm_letn m) + . foldTM (foldTM (foldTM k)) (cm_letr m) + . foldTM (foldTM k) (cm_case m) + . foldTM (foldTM k) (cm_ecase m) + +-- lkE: lookup in trie for expressions +lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a +lkE (D env expr) cm = go expr cm + where + go (Var v) = cm_var >.> lkVar env v + go (Lit l) = cm_lit >.> lookupTM l + go (Type t) = cm_type >.> lkG (D env t) + go (Coercion c) = cm_co >.> lkG (D env c) + go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) + go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) + go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) + >=> lkBndr env v + go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) + >=> lkG (D (extendCME env b) e) >=> lkBndr env b + go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr + >.> lkList (lkG . D env1) rhss + >=> lkG (D env1 e) + >=> lkList (lkBndr env1) bndrs + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) + | otherwise = cm_case >.> lkG (D env e) + >=> lkList (lkA (extendCME env b)) as + +xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a +xtE (D env (Var v)) f m = m { cm_var = cm_var m + |> xtVar env v f } +xtE (D env (Type t)) f m = m { cm_type = cm_type m + |> xtG (D env t) f } +xtE (D env (Coercion c)) f m = m { cm_co = cm_co m + |> xtG (D env c) f } +xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } +xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) + |>> xtG (D env c) f } +xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) + |>> xtTickish t f } +xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) + |>> xtG (D env e1) f } +xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m + |> xtG (D (extendCME env v) e) + |>> xtBndr env v f } +xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m + |> xtG (D (extendCME env b) e) + |>> xtG (D env r) + |>> xtBndr env b f } +xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = + let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr m + |> xtList (xtG . D env1) rhss + |>> xtG (D env1 e) + |>> xtList (xtBndr env1) + bndrs f } +xtE (D env (Case e b ty as)) f m + | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) + |>> xtG (D env ty) f } + | otherwise = m { cm_case = cm_case m |> xtG (D env e) + |>> let env1 = extendCME env b + in xtList (xtA env1) as f } + +-- TODO: this seems a bit dodgy, see 'eqTickish' +type TickishMap a = Map.Map (Tickish Id) a +lkTickish :: Tickish Id -> TickishMap a -> Maybe a +lkTickish = lookupTM + +xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a +xtTickish = alterTM + +------------------------ +data AltMap a -- A single alternative + = AM { am_deflt :: CoreMapG a + , am_data :: DNameEnv (CoreMapG a) + , am_lit :: LiteralMap (CoreMapG a) } + +instance TrieMap AltMap where + type Key AltMap = CoreAlt + emptyTM = AM { am_deflt = emptyTM + , am_data = emptyDNameEnv + , am_lit = emptyTM } + lookupTM = lkA emptyCME + alterTM = xtA emptyCME + foldTM = fdA + mapTM = mapA + +instance Eq (DeBruijn CoreAlt) where + D env1 a1 == D env2 a2 = go a1 a2 where + go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) + = D env1 rhs1 == D env2 rhs2 + go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) + = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 + go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2) + = dc1 == dc2 && + D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 + go _ _ = False + +mapA :: (a->b) -> AltMap a -> AltMap b +mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = mapTM f adeflt + , am_data = mapTM (mapTM f) adata + , am_lit = mapTM (mapTM f) alit } + +lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a +lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) +lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc + >=> lkG (D (extendCMEs env bs) rhs) + +xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a +xtA env (DEFAULT, _, rhs) f m = + m { am_deflt = am_deflt m |> xtG (D env rhs) f } +xtA env (LitAlt l, _, rhs) f m = + m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } +xtA env (DataAlt d, bs, rhs) f m = + m { am_data = am_data m |> xtDNamed d + |>> xtG (D (extendCMEs env bs) rhs) f } + +fdA :: (a -> b -> b) -> AltMap a -> b -> b +fdA k m = foldTM k (am_deflt m) + . foldTM (foldTM k) (am_data m) + . foldTM (foldTM k) (am_lit m) + +{- +************************************************************************ +* * + Coercions +* * +************************************************************************ +-} + +-- We should really never care about the contents of a coercion. Instead, +-- just look up the coercion's type. +newtype CoercionMap a = CoercionMap (CoercionMapG a) + +instance TrieMap CoercionMap where + type Key CoercionMap = Coercion + emptyTM = CoercionMap emptyTM + lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) + foldTM k (CoercionMap m) = foldTM k m + mapTM f (CoercionMap m) = CoercionMap (mapTM f m) + +type CoercionMapG = GenMap CoercionMapX +newtype CoercionMapX a = CoercionMapX (TypeMapX a) + +instance TrieMap CoercionMapX where + type Key CoercionMapX = DeBruijn Coercion + emptyTM = CoercionMapX emptyTM + lookupTM = lkC + alterTM = xtC + foldTM f (CoercionMapX core_tm) = foldTM f core_tm + mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) + +instance Eq (DeBruijn Coercion) where + D env1 co1 == D env2 co2 + = D env1 (coercionType co1) == + D env2 (coercionType co2) + +lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a +lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) + core_tm + +xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a +xtC (D env co) f (CoercionMapX m) + = CoercionMapX (xtT (D env $ coercionType co) f m) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'TypeMap' +-- inside another 'TrieMap', this is the type you want. Note that this +-- lookup does not do a kind-check. Thus, all keys in this map must have +-- the same kind. Also note that this map respects the distinction between +-- @Type@ and @Constraint@, despite the fact that they are equivalent type +-- synonyms in Core. +type TypeMapG = GenMap TypeMapX + +-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the +-- 'GenMap' optimization. +data TypeMapX a + = TM { tm_var :: VarMap a + , tm_app :: TypeMapG (TypeMapG a) + , tm_tycon :: DNameEnv a + , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] + , tm_tylit :: TyLitMap a + , tm_coerce :: Maybe a + } + -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type + +-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the +-- last one? See Note [Equality on AppTys] in "GHC.Core.Type" +-- +-- Note, however, that we keep Constraint and Type apart here, despite the fact +-- that they are both synonyms of TYPE 'LiftedRep (see #11715). +trieMapView :: Type -> Maybe Type +trieMapView ty + -- First check for TyConApps that need to be expanded to + -- AppTy chains. + | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty + = Just $ foldl' AppTy (TyConApp tc []) tys + + -- Then resolve any remaining nullary synonyms. + | Just ty' <- tcView ty = Just ty' +trieMapView _ = Nothing + +instance TrieMap TypeMapX where + type Key TypeMapX = DeBruijn Type + emptyTM = emptyT + lookupTM = lkT + alterTM = xtT + foldTM = fdT + mapTM = mapT + +instance Eq (DeBruijn Type) where + env_t@(D env t) == env_t'@(D env' t') + | Just new_t <- tcView t = D env new_t == env_t' + | Just new_t' <- tcView t' = env_t == D env' new_t' + | otherwise + = case (t, t') of + (CastTy t1 _, _) -> D env t1 == D env t' + (_, CastTy t1' _) -> D env t == D env t1' + + (TyVarTy v, TyVarTy v') + -> case (lookupCME env v, lookupCME env' v') of + (Just bv, Just bv') -> bv == bv' + (Nothing, Nothing) -> v == v' + _ -> False + -- See Note [Equality on AppTys] in GHC.Core.Type + (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (FunTy _ w1 t1 t2, FunTy _ w1' t1' t2') + -> D env w1 == D env w1' && D env t1 == D env' t1' && D env t2 == D env' t2' + (TyConApp tc tys, TyConApp tc' tys') + -> tc == tc' && D env tys == D env' tys' + (LitTy l, LitTy l') + -> l == l' + (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty') + -> D env (varType tv) == D env' (varType tv') && + D (extendCME env tv) ty == D (extendCME env' tv') ty' + (CoercionTy {}, CoercionTy {}) + -> True + _ -> False + +instance {-# OVERLAPPING #-} + Outputable a => Outputable (TypeMapG a) where + ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) + +emptyT :: TypeMapX a +emptyT = TM { tm_var = emptyTM + , tm_app = emptyTM + , tm_tycon = emptyDNameEnv + , tm_forall = emptyTM + , tm_tylit = emptyTyLitMap + , tm_coerce = Nothing } + +mapT :: (a->b) -> TypeMapX a -> TypeMapX b +mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) + = TM { tm_var = mapTM f tvar + , tm_app = mapTM (mapTM f) tapp + , tm_tycon = mapTM f ttycon + , tm_forall = mapTM (mapTM f) tforall + , tm_tylit = mapTM f tlit + , tm_coerce = fmap f tcoerce } + +----------------- +lkT :: DeBruijn Type -> TypeMapX a -> Maybe a +lkT (D env ty) m = go ty m + where + go ty | Just ty' <- trieMapView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkG (D env t1) + >=> lkG (D env t2) + go (TyConApp tc []) = tm_tycon >.> lkDNamed tc + go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) + go (LitTy l) = tm_tylit >.> lkTyLit l + go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) + >=> lkBndr env tv + go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) + go (CastTy t _) = go t + go (CoercionTy {}) = tm_coerce + +----------------- +xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a +xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m + +xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } +xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) + |>> xtG (D env t2) f } +xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } +xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } +xtT (D env (CastTy t _)) f m = xtT (D env t) f m +xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } +xtT (D env (ForAllTy (Bndr tv _) ty)) f m + = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) + |>> xtBndr env tv f } +xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) +xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) + +fdT :: (a -> b -> b) -> TypeMapX a -> b -> b +fdT k m = foldTM k (tm_var m) + . foldTM (foldTM k) (tm_app m) + . foldTM k (tm_tycon m) + . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + . foldMaybe k (tm_coerce m) + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a + , tlm_string :: Map.Map FastString a + } + +instance TrieMap TyLitMap where + type Key TyLitMap = TyLit + emptyTM = emptyTyLitMap + lookupTM = lkTyLit + alterTM = xtTyLit + foldTM = foldTyLit + mapTM = mapTyLit + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } + +mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b +mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) + = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumTyLit n -> tlm_number >.> Map.lookup n + StrTyLit n -> tlm_string >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } + StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m = flip (Map.foldr l) (tlm_string m) + . flip (Map.foldr l) (tlm_number m) + +------------------------------------------------- +-- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this +-- is the type you want. The keys in this map may have different kinds. +newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) + +lkTT :: DeBruijn Type -> TypeMap a -> Maybe a +lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m + >>= lkG (D env ty) + +xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a +xtTT (D env ty) f (TypeMap m) + = TypeMap (m |> xtG (D env $ typeKind ty) + |>> xtG (D env ty) f) + +-- Below are some client-oriented functions which operate on 'TypeMap'. + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = TypeMap emptyTM + lookupTM k m = lkTT (deBruijnize k) m + alterTM k f m = xtTT (deBruijnize k) f m + foldTM k (TypeMap m) = foldTM (foldTM k) m + mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) + +foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b +foldTypeMap k z m = foldTM k m z + +emptyTypeMap :: TypeMap a +emptyTypeMap = emptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lookupTM t cm + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = alterTM t (const (Just v)) m + +lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a +lookupTypeMapWithScope m cm t = lkTT (D cm t) m + +-- | Extend a 'TypeMap' with a type in the given context. +-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to +-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over +-- multiple insertions. +extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a +extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m + +-- | Construct a deBruijn environment with the given variables in scope. +-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@ +mkDeBruijnContext :: [Var] -> CmEnv +mkDeBruijnContext = extendCMEs emptyCME + +-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), +-- you'll find entries inserted under (t), even if (g) is non-reflexive. +newtype LooseTypeMap a + = LooseTypeMap (TypeMapG a) + +instance TrieMap LooseTypeMap where + type Key LooseTypeMap = Type + emptyTM = LooseTypeMap emptyTM + lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m + alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) + foldTM f (LooseTypeMap m) = foldTM f m + mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) + +{- +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +type BoundVar = Int -- Bound variables are deBruijn numbered +type BoundVarMap a = IntMap.IntMap a + +data CmEnv = CME { cme_next :: !BoundVar + , cme_env :: VarEnv BoundVar } + +emptyCME :: CmEnv +emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } + +extendCME :: CmEnv -> Var -> CmEnv +extendCME (CME { cme_next = bv, cme_env = env }) v + = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } + +extendCMEs :: CmEnv -> [Var] -> CmEnv +extendCMEs env vs = foldl' extendCME env vs + +lookupCME :: CmEnv -> Var -> Maybe BoundVar +lookupCME (CME { cme_env = env }) v = lookupVarEnv env v + +-- | @DeBruijn a@ represents @a@ modulo alpha-renaming. This is achieved +-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn +-- numbering. This allows us to define an 'Eq' instance for @DeBruijn a@, even +-- if this was not (easily) possible for @a@. Note: we purposely don't +-- export the constructor. Make a helper function if you find yourself +-- needing it. +data DeBruijn a = D CmEnv a + +-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no +-- bound binders (an empty 'CmEnv'). This is usually what you want if there +-- isn't already a 'CmEnv' in scope. +deBruijnize :: a -> DeBruijn a +deBruijnize = D emptyCME + +instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where + D _ [] == D _ [] = True + D env (x:xs) == D env' (x':xs') = D env x == D env' x' && + D env xs == D env' xs' + _ == _ = False + +instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where + D _ Nothing == D _ Nothing = True + D env (Just x) == D env' (Just x') = D env x == D env' x' + _ == _ = False + +--------- Variable binders ------------- + +-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between +-- binding forms whose binders have different types. For example, +-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should +-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: +-- we can disambiguate this by matching on the type (or kind, if this +-- a binder in a type) of the binder. +-- +-- We also need to do the same for multiplicity! Which, since multiplicities are +-- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries +-- of pairs are composition. +data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a)) + +instance TrieMap BndrMap where + type Key BndrMap = Var + emptyTM = BndrMap emptyTM + lookupTM = lkBndr emptyCME + alterTM = xtBndr emptyCME + foldTM = fdBndrMap + mapTM = mapBndrMap + +mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b +mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm) + +fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b +fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm + + +-- Note [Binders] +-- ~~~~~~~~~~~~~~ +-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all +-- of these data types have binding forms. + +lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a +lkBndr env v (BndrMap tymap) = do + multmap <- lkG (D env (varType v)) tymap + lookupTM (D env <$> varMultMaybe v) multmap + + +xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v xt (BndrMap tymap) = + BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt)) + + +--------- Variable occurrence ------------- +data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable + , vm_fvar :: DVarEnv a } -- Free variable + +instance TrieMap VarMap where + type Key VarMap = Var + emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } + lookupTM = lkVar emptyCME + alterTM = xtVar emptyCME + foldTM = fdVar + mapTM = mapVar + +mapVar :: (a->b) -> VarMap a -> VarMap b +mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } + +lkVar :: CmEnv -> Var -> VarMap a -> Maybe a +lkVar env v + | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv + | otherwise = vm_fvar >.> lkDFreeVar v + +xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a +xtVar env v f m + | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f } + | otherwise = m { vm_fvar = vm_fvar m |> xtDFreeVar v f } + +fdVar :: (a -> b -> b) -> VarMap a -> b -> b +fdVar k m = foldTM k (vm_bvar m) + . foldTM k (vm_fvar m) + +lkDFreeVar :: Var -> DVarEnv a -> Maybe a +lkDFreeVar var env = lookupDVarEnv env var + +xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a +xtDFreeVar v f m = alterDVarEnv f m v diff --git a/GHC/Core/Multiplicity.hs b/GHC/Core/Multiplicity.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Multiplicity.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +{-| +This module defines the semi-ring of multiplicities, and associated functions. +Multiplicities annotate arrow types to indicate the linearity of the +arrow (in the sense of linear types). + +Mult is a type synonym for Type, used only when its kind is Multiplicity. +To simplify dealing with multiplicities, functions such as +mkMultMul perform simplifications such as Many * x = Many on the fly. +-} +module GHC.Core.Multiplicity + ( Mult + , pattern One + , pattern Many + , isMultMul + , mkMultAdd + , mkMultMul + , mkMultSup + , Scaled(..) + , scaledMult + , scaledThing + , unrestricted + , linear + , tymult + , irrelevantMult + , mkScaled + , scaledSet + , scaleScaled + , IsSubmult(..) + , submult + , mapScaledType) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Core.TyCo.Rep +import {-# SOURCE #-} GHC.Builtin.Types ( multMulTyCon ) +import GHC.Core.Type +import GHC.Builtin.Names (multMulTyConKey) +import GHC.Types.Unique (hasKey) + +{- +Note [Linear types] +~~~~~~~~~~~~~~~~~~~ +This module is the entry point for linear types. + +The detailed design is in the _Linear Haskell_ article +[https://arxiv.org/abs/1710.09756]. Other important resources in the linear +types implementation wiki page +[https://gitlab.haskell.org/ghc/ghc/wikis/linear-types/implementation], and the +proposal [https://github.com/ghc-proposals/ghc-proposals/pull/111] which +describes the concrete design at length. + +For the busy developer, though, here is a high-level view of linear types is the following: + +- Function arrows are annotated with a multiplicity (as defined by type `Mult` + and its smart constructors in this module) + - Because, as a type constructor, the type of function now has an extra + argument, the notation (->) is no longer suitable. We named the function + type constructor `FUN`. + - (->) retains its backward compatible meaning: `(->) a b = a -> b`. To + achieve this, `(->)` is defined as a type synonym to `FUN Many` (see + below). +- Multiplicities can be reified in Haskell as types of kind + `GHC.Types.Multiplicity` +- Ground multiplicity (that is, without a variable) can be `One` or `Many` + (`Many` is generally rendered as ω in the scientific literature). + Functions whose type is annotated with `One` are linear functions, functions whose + type is annotated with `Many` are regular functions, often called “unrestricted” + to contrast them with linear functions. +- A linear function is defined as a function such that *if* its result is + consumed exactly once, *then* its argument is consumed exactly once. You can + think of “consuming exactly once” as evaluating a value in normal form exactly + once (though not necessarily in one go). The _Linear Haskell_ article (see + infra) has a more precise definition of “consuming exactly once”. +- Data types can have unrestricted fields (the canonical example being the + `Unrestricted` data type), then these don't need to be consumed for a value to + be consumed exactly once. So consuming a value of type `Unrestricted` exactly + once means forcing it at least once. +- Why “at least once”? Because if `case u of { C x y -> f (C x y) }` is linear + (provided `f` is a linear function). So we might as well have done `case u of + { !z -> f z }`. So, we can observe constructors as many times as we want, and + we are actually allowed to force the same thing several times because laziness + means that we are really forcing a the value once, and observing its + constructor several times. The type checker and the linter recognise some (but + not all) of these multiple forces as indeed linear. Mostly just enough to + support variable patterns. +- Multiplicities form a semiring. +- Multiplicities can also be variables and we can universally quantify over + these variables. This is referred to as “multiplicity + polymorphism”. Furthermore, multiplicity can be formal semiring expressions + combining variables. +- Contrary to the paper, the sum of two multiplicities is always `Many`. This + will have to change, however, if we want to add a multiplicity for 0. Whether + we want to is still debated. +- Case expressions have a multiplicity annotation too. A case expression with + multiplicity `One`, consumes its scrutinee exactly once (provided the entire + case expression is consumed exactly once); whereas a case expression with + multiplicity `Many` can consume its scrutinee as many time as it wishes (no + matter how much the case expression is consumed). + +Note [Usages] +~~~~~~~~~~~~~ +In the _Linear Haskell_ paper, you'll find typing rules such as these: + + Γ ⊢ f : A #π-> B Δ ⊢ u : A + --------------------------- + Γ + kΔ ⊢ f u : B + +If you read this as a type-checking algorithm going from the bottom up, this +reads as: the algorithm has to find a split of some input context Ξ into an +appropriate Γ and a Δ such as Ξ = Γ + kΔ, *and the multiplicities are chosen to +make f and u typecheck*. + +This could be achieved by letting the typechecking of `f` use exactly the +variable it needs, then passing the remainder, as `Delta` to the typechecking of +u. But what does that mean if `x` is bound with multiplicity `p` (a variable) +and `f` consumes `x` once? `Delta` would have to contain `x` with multiplicity +`p-1`. It's not really clear how to make that works. In summary: bottom-up +multiplicity checking forgoes addition and multiplication in favour of +subtraction and division. And variables make the latter hard. + +The alternative is to read multiplicities from the top down: as an *output* from +the typechecking algorithm, rather than an input. We call these output +multiplicities Usages, to distinguish them from the multiplicities which come, +as input, from the types of functions. Usages are checked for compatibility with +multiplicity annotations using an ordering relation. In other words, the usage +of x in the expression u is the smallest multiplicity which can be ascribed to x +for u to typecheck. + +Usages are usually group in a UsageEnv, as defined in the UsageEnv module. + +So, in our function application example, the typechecking algorithm would +receive usage environements f_ue from the typechecking of f, and u_ue from the +typechecking of u. Then the output would be f_ue + (k * u_ue). Addition and +scaling of usage environment is the pointwise extension of the semiring +operations on multiplicities. + +Note [Zero as a usage] +~~~~~~~~~~~~~~~~~~~~~~ +In the current presentation usages are not exactly multiplicities, because they +can contain 0, and multiplicities can't. + +Why do we need a 0 usage? A function which doesn't use its argument will be +required to annotate it with `Many`: + + \(x # Many) -> 0 + +However, we cannot replace absence with Many when computing usages +compositionally: in + + (x, True) + +We expect x to have usage 1. But when computing the usage of x in True we would +find that x is absent, hence has multiplicity Many. The final multiplicity would +be One+Many = Many. Oops! + +Hence there is a usage Zero for absent variables. Zero is characterised by being +the neutral element to usage addition. + +We may decide to add Zero as a multiplicity in the future. In which case, this +distinction will go away. + +Note [Joining usages] +~~~~~~~~~~~~~~~~~~~~~ +The usage of a variable is defined, in Note [Usages], as the minimum usage which +can be ascribed to a variable. + +So what is the usage of x in + + case … of + { p1 -> u -- usage env: u_ue + ; p2 -> v } -- usage env: v_ue + +It must be the least upper bound, or _join_, of u_ue(x) and v_ue(x). + +So, contrary to a declarative presentation where the correct usage of x can be +conjured out of thin air, we need to be able to compute the join of two +multiplicities. Join is extended pointwise on usage environments. + +Note [Bottom as a usage] +~~~~~~~~~~~~~~~~~~~~~~ +What is the usage of x in + + case … of {} + +Per usual linear logic, as well as the _Linear Haskell_ article, x can have +every multiplicity. + +So we need a minimum usage _bottom_, which is also the neutral element for join. + +In fact, this is not such as nice solution, because it is not clear how to +define sum and multiplication with bottom. We give reasonable definitions, but +they are not complete (they don't respect the semiring laws, and it's possible +to come up with examples of Core transformation which are not well-typed) + +A better solution would probably be to annotate case expressions with a usage +environment, just like they are annotated with a type. Which, probably not +coincidentally, is also primarily for empty cases. + +A side benefit of this approach is that the linter would not need to join +multiplicities, anymore; hence would be closer to the presentation in the +article. That's because it could use the annotation as the multiplicity for each +branch. + +Note [Data constructors are linear by default] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data constructors defined without -XLinearTypes (as well as data constructors +defined with the Haskell 98 in all circumstances) have all their fields linear. + +That is, in + + data Maybe a = Nothing | Just a + +We have + + Just :: a %1 -> Just a + +The goal is to maximise reuse of types between linear code and traditional +code. This is argued at length in the proposal and the article (links in Note +[Linear Types]). + +Note [Polymorphisation of linear fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The choice in Note [Data constructors are linear by default] has an impact on +backwards compatibility. Consider + + map Just + +We have + + map :: (a -> b) -> f a -> f b + Just :: a %1 -> Just a + +Types don't match, we should get a type error. But this is legal Haskell 98 +code! Bad! Bad! Bad! + +It could be solved with subtyping, but subtyping doesn't combine well with +polymorphism. + +Instead, we generalise the type of Just, when used as term: + + Just :: forall {p}. a %p-> Just a + +This is solely a concern for higher-order code like this: when called fully +applied linear constructors are more general than constructors with unrestricted +fields. In particular, linear constructors can always be eta-expanded to their +Haskell 98 type. This is explained in the paper (but there, we had a different +strategy to resolve this type mismatch in higher-order code. It turned out to be +insufficient, which is explained in the wiki page as well as the proposal). + +We only generalise linear fields this way: fields with multiplicity Many, or +other multiplicity expressions are exclusive to -XLinearTypes, hence don't have +backward compatibility implications. + +The implementation is described in Note [Linear fields generalization]. + +More details in the proposal. +-} + +{- +Note [Adding new multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To add a new multiplicity, you need to: +* Add the new type with Multiplicity kind +* Update cases in mkMultAdd, mkMultMul, mkMultSup, submult, tcSubMult +* Check supUE function that computes sup of a multiplicity + and Zero +-} + +isMultMul :: Mult -> Maybe (Mult, Mult) +isMultMul ty | Just (tc, [x, y]) <- splitTyConApp_maybe ty + , tc `hasKey` multMulTyConKey = Just (x, y) + | otherwise = Nothing + +{- +Note [Overapproximating multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions mkMultAdd, mkMultMul, mkMultSup perform operations +on multiplicities. They can return overapproximations: their result +is merely guaranteed to be a submultiplicity of the actual value. + +They should be used only when an upper bound is acceptable. +In most cases, they are used in usage environments (UsageEnv); +in usage environments, replacing a usage with a larger one can only +cause more programs to fail to typecheck. + +In future work, instead of approximating we might add type families +and allow users to write types involving operations on multiplicities. +In this case, we could enforce more invariants in Mult, for example, +enforce that it is in the form of a sum of products, and even +that the sumands and factors are ordered somehow, to have more equalities. +-} + +-- With only two multiplicities One and Many, we can always replace +-- p + q by Many. See Note [Overapproximating multiplicities]. +mkMultAdd :: Mult -> Mult -> Mult +mkMultAdd _ _ = Many + +mkMultMul :: Mult -> Mult -> Mult +mkMultMul One p = p +mkMultMul p One = p +mkMultMul Many _ = Many +mkMultMul _ Many = Many +mkMultMul p q = mkTyConApp multMulTyCon [p, q] + +scaleScaled :: Mult -> Scaled a -> Scaled a +scaleScaled m' (Scaled m t) = Scaled (m' `mkMultMul` m) t + +-- See Note [Joining usages] +-- | @mkMultSup w1 w2@ returns a multiplicity such that @mkMultSup w1 +-- w2 >= w1@ and @mkMultSup w1 w2 >= w2@. See Note [Overapproximating multiplicities]. +mkMultSup :: Mult -> Mult -> Mult +mkMultSup = mkMultMul +-- Note: If you are changing this logic, check 'supUE' in UsageEnv as well. + +-- +-- * Multiplicity ordering +-- + +data IsSubmult = Submult -- Definitely a submult + | Unknown -- Could be a submult, need to ask the typechecker + deriving (Show, Eq) + +instance Outputable IsSubmult where + ppr = text . show + +-- | @submult w1 w2@ check whether a value of multiplicity @w1@ is allowed where a +-- value of multiplicity @w2@ is expected. This is a partial order. + +submult :: Mult -> Mult -> IsSubmult +submult _ Many = Submult +submult One One = Submult +-- The 1 <= p rule +submult One _ = Submult +submult _ _ = Unknown diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Arity.hs @@ -0,0 +1,1335 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + + Arity and eta expansion +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Arity and eta expansion +module GHC.Core.Opt.Arity + ( manifestArity, joinRhsArity, exprArity, typeArity + , exprEtaExpandArity, findRhsArity + , etaExpand, etaExpandAT + , etaExpandToJoinPoint, etaExpandToJoinPointRule + , exprBotStrictness_maybe + , ArityType(..), expandableArityType, arityTypeArity + , maxWithArity, isBotArityType, idArityType + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Subst +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Core.Type as Type +import GHC.Core.TyCon ( initRecTc, checkRecTc ) +import GHC.Core.Predicate ( isDictTy ) +import GHC.Core.Coercion as Coercion +import GHC.Core.Multiplicity +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc ( lengthAtLeast ) + +{- +************************************************************************ +* * + manifestArity and exprArity +* * +************************************************************************ + +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. +-} + +manifestArity :: CoreExpr -> Arity +-- ^ manifestArity sees how many leading value lambdas there are, +-- after looking through casts +manifestArity (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e +manifestArity (Cast e _) = manifestArity e +manifestArity _ = 0 + +joinRhsArity :: CoreExpr -> JoinArity +-- Join points are supposed to have manifestly-visible +-- lambdas at the top: no ticks, no casts, nothing +-- Moreover, type lambdas count in JoinArity +joinRhsArity (Lam _ e) = 1 + joinRhsArity e +joinRhsArity _ = 0 + + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, fast, version of 'exprEtaExpandArity' +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e co) = trim_arity (go e) (coercionRKind co) + -- Note [exprArity invariant] + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + + trim_arity :: Arity -> Type -> Arity + trim_arity arity ty = arity `min` length (typeArity ty) + +--------------- +typeArity :: Type -> [OneShotInfo] +-- How many value arrows are visible in the type? +-- We look through foralls, and newtypes +-- See Note [exprArity invariant] +typeArity ty + = go initRecTc ty + where + go rec_nts ty + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_nts ty' + + | Just (_,arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res + + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] + -- in GHC.Core.TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' ty' + -- Important to look through non-recursive newtypes, so that, eg + -- (f x) where f has arity 2, f :: Int -> IO () + -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) + + | otherwise + = [] + +--------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness signatures. It's used during +-- float-out +exprBotStrictness_maybe e + = case getBotArity (arityType env e) of + Nothing -> Nothing + Just ar -> Just (ar, sig ar) + where + env = AE { ae_ped_bot = True + , ae_cheap_fn = \ _ _ -> False + , ae_joins = emptyVarSet } + sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv + +{- +Note [exprArity invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprArity has the following invariants: + + (1) If typeArity (exprType e) = n, + then manifestArity (etaExpand e n) = n + + That is, etaExpand can always expand as much as typeArity says + So the case analysis in etaExpand and in typeArity must match + + (2) exprArity e <= typeArity (exprType e) + + (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n + + That is, if exprArity says "the arity is n" then etaExpand really + can get "n" manifest lambdas to the top. + +Why is this important? Because + - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of + each top-level Id, and in + - In CorePrep we use etaExpand on each rhs, so that the visible lambdas + actually match that arity, which in turn means + that the StgRhs has the right number of lambdas + +An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least +for top-level bindings, in which case we would not need the trim_arity +in exprArity. That is a less local change, so I'm going to leave it for today! + +Note [Newtype classes and eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: this nasty special case is no longer required, because + for newtype classes we don't use the class-op rule mechanism + at all. See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013 + +-------- Old out of date comments, just for interest ----------- +We have to be careful when eta-expanding through newtypes. In general +it's a good idea, but annoyingly it interacts badly with the class-op +rule mechanism. Consider + + class C a where { op :: a -> a } + instance C b => C [b] where + op x = ... + +These translate to + + co :: forall a. (a->a) ~ C a + + $copList :: C b -> [b] -> [b] + $copList d x = ... + + $dfList :: C b -> C [b] + {-# DFunUnfolding = [$copList] #-} + $dfList d = $copList d |> co@[b] + +Now suppose we have: + + dCInt :: C Int + + blah :: [Int] -> [Int] + blah = op ($dfList dCInt) + +Now we want the built-in op/$dfList rule will fire to give + blah = $copList dCInt + +But with eta-expansion 'blah' might (and in #3772, which is +slightly more complicated, does) turn into + + blah = op (\eta. ($dfList dCInt |> sym co) eta) + +and now it is *much* harder for the op/$dfList rule to fire, because +exprIsConApp_maybe won't hold of the argument to op. I considered +trying to *make* it hold, but it's tricky and I gave up. + +The test simplCore/should_compile/T3722 is an excellent example. +-------- End of old out of date comments, just for interest ----------- + + +Note [exprArity for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to an application we check that the arg is trivial. + eg f (fac x) does not have arity 2, + even if f has arity 3! + +* We require that is trivial rather merely cheap. Suppose f has arity 2. + Then f (Just y) + has arity 0, because if we gave it arity 1 and then inlined f we'd get + let v = Just y in \w. + which has arity 0. And we try to maintain the invariant that we don't + have arity decreases. + +* The `max 0` is important! (\x y -> f x) has arity 2, even if f is + unknown, hence arity 0 + + +************************************************************************ +* * + Computing the "arity" of an expression +* * +************************************************************************ + +Note [Definition of arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "arity" of an expression 'e' is n if + applying 'e' to *fewer* than n *value* arguments + converges rapidly + +Or, to put it another way + + there is no work lost in duplicating the partial + application (e x1 .. x(n-1)) + +In the divergent case, no work is lost by duplicating because if the thing +is evaluated once, that's the end of the program. + +Or, to put it another way, in any context C + + C[ (\x1 .. xn. e x1 .. xn) ] + is as efficient as + C[ e ] + +It's all a bit more subtle than it looks: + +Note [One-shot lambdas] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider one-shot lambdas + let x = expensive in \y z -> E +We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. + +Note [Dealing with bottom] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A Big Deal with computing arities is expressions like + + f = \x -> case x of + True -> \s -> e1 + False -> \s -> e2 + +This happens all the time when f :: Bool -> IO () +In this case we do eta-expand, in order to get that \s to the +top, and give f arity 2. + +This isn't really right in the presence of seq. Consider + (f bot) `seq` 1 + +This should diverge! But if we eta-expand, it won't. We ignore this +"problem" (unless -fpedantic-bottoms is on), because being scrupulous +would lose an important transformation for many programs. (See +#5587 for an example.) + +Consider also + f = \x -> error "foo" +Here, arity 1 is fine. But if it is + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Technically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +So these two transformations aren't always the Right Thing, and we +have several tickets reporting unexpected behaviour resulting from +this transformation. So we try to limit it as much as possible: + + (1) Do NOT move a lambda outside a known-bottom case expression + case undefined of { (a,b) -> \y -> e } + This showed up in #5557 + + (2) Do NOT move a lambda outside a case if all the branches of + the case are known to return bottom. + case x of { (a,b) -> \y -> error "urk" } + This case is less important, but the idea is that if the fn is + going to diverge eventually anyway then getting the best arity + isn't an issue, so we might as well play safe + + (3) Do NOT move a lambda outside a case unless + (a) The scrutinee is ok-for-speculation, or + (b) more liberally: the scrutinee is cheap (e.g. a variable), and + -fpedantic-bottoms is not enforced (see #2915 for an example) + +Of course both (1) and (2) are readily defeated by disguising the bottoms. + +4. Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Non-recursive newtypes are transparent, and should not get in the way. +We do (currently) eta-expand recursive newtypes too. So if we have, say + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + + HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate + And since negate has arity 2, you might try to eta expand. But you can't + decompose Int to a function type. Hence the final case in eta_expand. + +Note [The state-transformer hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + f = e +where e has arity n. Then, if we know from the context that f has +a usage type like + t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... +then we can expand the arity to m. This usage type says that +any application (x e1 .. en) will be applied to uniquely to (m-n) more args +Consider f = \x. let y = + in case x of + True -> foo + False -> \(s:RealWorld) -> e +where foo has arity 1. Then we want the state hack to +apply to foo too, so we can eta expand the case. + +Then we expect that if f is applied to one arg, it'll be applied to two +(that's the hack -- we don't really know, and sometimes it's false) +See also Id.isOneShotBndr. + +Note [State hack and bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a terrible idea to use the state hack on a bottoming function. +Here's what happens (#2861): + + f :: String -> IO T + f = \p. error "..." + +Eta-expand, using the state hack: + + f = \p. (\s. ((error "...") |> g1) s) |> g2 + g1 :: IO T ~ (S -> (S,T)) + g2 :: (S -> (S,T)) ~ IO T + +Extrude the g2 + + f' = \p. \s. ((error "...") |> g1) s + f = f' |> (String -> g2) + +Discard args for bottomming function + + f' = \p. \s. ((error "...") |> g1 |> g3 + g3 :: (S -> (S,T)) ~ (S,T) + +Extrude g1.g3 + + f'' = \p. \s. (error "...") + f' = f'' |> (String -> S -> g1.g3) + +And now we can repeat the whole loop. Aargh! The bug is in applying the +state hack to a function which then swallows the argument. + +This arose in another guise in #3959. Here we had + + catch# (throw exn >> return ()) + +Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. +After inlining (>>) we get + + catch# (\_. throw {IO ()} exn) + +We must *not* eta-expand to + + catch# (\_ _. throw {...} exn) + +because 'catch#' expects to get a (# _,_ #) after applying its argument to +a State#, not another function! + +In short, we use the state hack to allow us to push let inside a lambda, +but not to introduce a new lambda. + + +Note [ArityType] +~~~~~~~~~~~~~~~~ +ArityType is the result of a compositional analysis on expressions, +from which we can decide the real arity of the expression (extracted +with function exprEtaExpandArity). + +Here is what the fields mean. If an arbitrary expression 'f' has +ArityType 'at', then + + * If at = ABot n, then (f x1..xn) definitely diverges. Partial + applications to fewer than n args may *or may not* diverge. + + We allow ourselves to eta-expand bottoming functions, even + if doing so may lose some `seq` sharing, + let x = in \y. error (g x y) + ==> \y. let x = in error (g x y) + + * If at = ATop as, and n=length as, + then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, + assuming the calls of f respect the one-shot-ness of + its definition. + + NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f' + can have ArityType as ATop, with length as > 0, only if e1 e2 are + themselves. + + * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely + really functions, or bottom, but *not* casts from a data type, in + at least one case branch. (If it's a function in one case branch but + an unsafe cast from a data type in another, the program is bogus.) + So eta expansion is dynamically ok; see Note [State hack and + bottoming functions], the part about catch# + +Example: + f = \x\y. let v = in + \s(one-shot) \t(one-shot). blah + 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot] + The one-shot-ness means we can, in effect, push that + 'let' inside the \st. + + +Suppose f = \xy. x+y +Then f :: AT [False,False] ATop + f v :: AT [False] ATop + f :: AT [] ATop + +-------------------- Main arity code ---------------------------- +-} + + +data ArityType -- See Note [ArityType] + = ATop [OneShotInfo] + | ABot Arity + deriving( Eq ) + -- There is always an explicit lambda + -- to justify the [OneShot], or the Arity + +instance Outputable ArityType where + ppr (ATop os) = text "ATop" <> parens (ppr (length os)) + ppr (ABot n) = text "ABot" <> parens (ppr n) + +arityTypeArity :: ArityType -> Arity +-- The number of value args for the arity type +arityTypeArity (ATop oss) = length oss +arityTypeArity (ABot ar) = ar + +expandableArityType :: ArityType -> Bool +-- True <=> eta-expansion will add at least one lambda +expandableArityType (ATop oss) = not (null oss) +expandableArityType (ABot ar) = ar /= 0 + +isBotArityType :: ArityType -> Bool +isBotArityType (ABot {}) = True +isBotArityType (ATop {}) = False + +arityTypeOneShots :: ArityType -> [OneShotInfo] +arityTypeOneShots (ATop oss) = oss +arityTypeOneShots (ABot ar) = replicate ar OneShotLam + -- If we are diveging or throwing an exception anyway + -- it's fine to push redexes inside the lambdas + +botArityType :: ArityType +botArityType = ABot 0 -- Unit for andArityType + +maxWithArity :: ArityType -> Arity -> ArityType +maxWithArity at@(ABot {}) _ = at +maxWithArity at@(ATop oss) ar + | oss `lengthAtLeast` ar = at + | otherwise = ATop (take ar (oss ++ repeat NoOneShotInfo)) + +vanillaArityType :: ArityType +vanillaArityType = ATop [] -- Totally uninformative + +-- ^ The Arity returned is the number of value args the +-- expression can be applied to without doing much work +exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +exprEtaExpandArity dflags e + = arityType env e + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp + , ae_ped_bot = gopt Opt_PedanticBottoms dflags + , ae_joins = emptyVarSet } + +getBotArity :: ArityType -> Maybe Arity +-- Arity of a divergent function +getBotArity (ABot n) = Just n +getBotArity _ = Nothing + +mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun +mk_cheap_fn dflags cheap_app + | not (gopt Opt_DictsCheap dflags) + = \e _ -> exprIsCheapX cheap_app e + | otherwise + = \e mb_ty -> exprIsCheapX cheap_app e + || case mb_ty of + Nothing -> False + Just ty -> isDictTy ty + + +---------------------- +findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +-- If findRhsArity e = (n, is_bot) then +-- (a) any application of e to (\x1..xn. e x1 .. xn) +-- (b) if is_bot=True, then e applied to n args is guaranteed bottom +findRhsArity dflags bndr rhs old_arity + = go (get_arity init_cheap_app) + -- We always call exprEtaExpandArity once, but usually + -- that produces a result equal to old_arity, and then + -- we stop right away (since arities should not decrease) + -- Result: the common case is that there is just one iteration + where + init_cheap_app :: CheapAppFun + init_cheap_app fn n_val_args + | fn == bndr = True -- On the first pass, this binder gets infinite arity + | otherwise = isCheapApp fn n_val_args + + go :: ArityType -> ArityType + go cur_atype + | cur_arity <= old_arity = cur_atype + | new_atype == cur_atype = cur_atype + | otherwise = +#if defined(DEBUG) + pprTrace "Exciting arity" + (vcat [ ppr bndr <+> ppr cur_atype <+> ppr new_atype + , ppr rhs]) +#endif + go new_atype + where + new_atype = get_arity cheap_app + + cur_arity = arityTypeArity cur_atype + cheap_app :: CheapAppFun + cheap_app fn n_val_args + | fn == bndr = n_val_args < cur_arity + | otherwise = isCheapApp fn n_val_args + + get_arity :: CheapAppFun -> ArityType + get_arity cheap_app = arityType env rhs + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app + , ae_ped_bot = gopt Opt_PedanticBottoms dflags + , ae_joins = emptyVarSet } + +{- +Note [Arity analysis] +~~~~~~~~~~~~~~~~~~~~~ +The motivating example for arity analysis is this: + + f = \x. let g = f (x+1) + in \y. ...g... + +What arity does f have? Really it should have arity 2, but a naive +look at the RHS won't see that. You need a fixpoint analysis which +says it has arity "infinity" the first time round. + +This example happens a lot; it first showed up in Andy Gill's thesis, +fifteen years ago! It also shows up in the code for 'rnf' on lists +in #4138. + +The analysis is easy to achieve because exprEtaExpandArity takes an +argument + type CheapFun = CoreExpr -> Maybe Type -> Bool +used to decide if an expression is cheap enough to push inside a +lambda. And exprIsCheapX in turn takes an argument + type CheapAppFun = Id -> Int -> Bool +which tells when an application is cheap. This makes it easy to +write the analysis loop. + +The analysis is cheap-and-cheerful because it doesn't deal with +mutual recursion. But the self-recursive case is the important one. + +Note [Eta expanding through dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the experimental -fdicts-cheap flag is on, we eta-expand through +dictionary bindings. This improves arities. Thereby, it also +means that full laziness is less prone to floating out the +application of a function to its dictionary arguments, which +can thereby lose opportunities for fusion. Example: + foo :: Ord a => a -> ... + foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- So foo has arity 1 + + f = \x. foo dInt $ bar x + +The (foo DInt) is floated out, and makes ineffective a RULE + foo (bar x) = ... + +One could go further and make exprIsCheap reply True to any +dictionary-typed expression, but that's more work. +-} + +arityLam :: Id -> ArityType -> ArityType +arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as) +arityLam _ (ABot n) = ABot (n+1) + +floatIn :: Bool -> ArityType -> ArityType +-- We have something like (let x = E in b), +-- where b has the given arity type. +floatIn _ (ABot n) = ABot n +floatIn True (ATop as) = ATop as +floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as) + -- If E is not cheap, keep arity only for one-shots + +arityApp :: ArityType -> Bool -> ArityType +-- Processing (fun arg) where at is the ArityType of fun, +-- Knock off an argument and behave like 'let' +arityApp (ABot 0) _ = ABot 0 +arityApp (ABot n) _ = ABot (n-1) +arityApp (ATop []) _ = ATop [] +arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as) + +andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case' +-- This is least upper bound in the ArityType lattice +andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max] +andArityType (ATop as) (ABot _) = ATop as +andArityType (ABot _) (ATop bs) = ATop bs +andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) + where -- See Note [Combining case branches] + combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs + combine [] bs = takeWhile isOneShotInfo bs + combine as [] = takeWhile isOneShotInfo as + +{- Note [ABot branches: use max] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider case x of + True -> \x. error "urk" + False -> \xy. error "urk2" + +Remember: ABot n means "if you apply to n args, it'll definitely diverge". +So we need (ABot 2) for the whole thing, the /max/ of the ABot arities. + +Note [Combining case branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + go = \x. let z = go e0 + go2 = \x. case x of + True -> z + False -> \s(one-shot). e1 + in go2 x +We *really* want to eta-expand go and go2. +When combining the branches of the case we have + ATop [] `andAT` ATop [OneShotLam] +and we want to get ATop [OneShotLam]. But if the inner +lambda wasn't one-shot we don't want to do this. +(We need a proper arity analysis to justify that.) + +So we combine the best of the two branches, on the (slightly dodgy) +basis that if we know one branch is one-shot, then they all must be. + +Note [Arity trimming] +~~~~~~~~~~~~~~~~~~~~~ +Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and +F is some type family. + +Because of Note [exprArity invariant], item (2), we must return with arity at +most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of +calling arityType on (\x y. blah). Failing to do so, and hence breaking the +exprArity invariant, led to #5441. + +How to trim? For ATop, it's easy. But we must take great care with ABot. +Suppose the expression was (\x y. error "urk"), we'll get (ABot 2). We +absolutely must not trim that to (ABot 1), because that claims that +((\x y. error "urk") |> co) diverges when given one argument, which it +absolutely does not. And Bad Things happen if we think something returns bottom +when it doesn't (#16066). + +So, do not reduce the 'n' in (ABot n); rather, switch (conservatively) to ATop. + +Historical note: long ago, we unconditionally switched to ATop when we +encountered a cast, but that is far too conservative: see #5475 +-} + +--------------------------- +type CheapFun = CoreExpr -> Maybe Type -> Bool + -- How to decide if an expression is cheap + -- If the Maybe is Just, the type is the type + -- of the expression; Nothing means "don't know" + +data ArityEnv + = AE { ae_cheap_fn :: CheapFun + , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms + , ae_joins :: IdSet -- In-scope join points + -- See Note [Eta-expansion and join points] + } + +extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv +extendJoinEnv env@(AE { ae_joins = joins }) join_ids + = env { ae_joins = joins `extendVarSetList` join_ids } + +---------------- +arityType :: ArityEnv -> CoreExpr -> ArityType + +arityType env (Cast e co) + = case arityType env e of + ATop os -> ATop (take co_arity os) -- See Note [Arity trimming] + ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo) + | otherwise -> ABot n + where + co_arity = length (typeArity (coercionRKind co)) + -- See Note [exprArity invariant] (2); must be true of + -- arityType too, since that is how we compute the arity + -- of variables, and they in turn affect result of exprArity + -- #5441 is a nice demo + -- However, do make sure that ATop -> ATop and ABot -> ABot! + -- Casts don't affect that part. Getting this wrong provoked #5475 + +arityType env (Var v) + | v `elemVarSet` ae_joins env + = botArityType -- See Note [Eta-expansion and join points] + | otherwise + = idArityType v + + -- Lambdas; increase arity +arityType env (Lam x e) + | isId x = arityLam x (arityType env e) + | otherwise = arityType env e + + -- Applications; decrease arity, except for types +arityType env (App fun (Type _)) + = arityType env fun +arityType env (App fun arg ) + = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing) + + -- Case/Let; keep arity if either the expression is cheap + -- or it's a 1-shot lambda + -- The former is not really right for Haskell + -- f x = case x of { (a,b) -> \y. e } + -- ===> + -- f x y = case x of { (a,b) -> e } + -- The difference is observable using 'seq' + -- +arityType env (Case scrut _ _ alts) + | exprIsDeadEnd scrut || null alts + = botArityType -- Do not eta expand + -- See Note [Dealing with bottom (1)] + | otherwise + = case alts_type of + ABot n | n>0 -> ATop [] -- Don't eta expand + | otherwise -> botArityType -- if RHS is bottomming + -- See Note [Dealing with bottom (2)] + + ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)] + , ae_cheap_fn env scrut Nothing -> ATop as + | exprOkForSpeculation scrut -> ATop as + | otherwise -> ATop (takeWhile isOneShotInfo as) + where + alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] + +arityType env (Let (NonRec j rhs) body) + | Just join_arity <- isJoinId_maybe j + , (_, rhs_body) <- collectNBinders join_arity rhs + = -- See Note [Eta-expansion and join points] + andArityType (arityType env rhs_body) + (arityType env' body) + where + env' = extendJoinEnv env [j] + +arityType env (Let (Rec pairs) body) + | ((j,_):_) <- pairs + , isJoinId j + = -- See Note [Eta-expansion and join points] + foldr (andArityType . do_one) (arityType env' body) pairs + where + env' = extendJoinEnv env (map fst pairs) + do_one (j,rhs) + | Just arity <- isJoinId_maybe j + = arityType env' $ snd $ collectNBinders arity rhs + | otherwise + = pprPanic "arityType:joinrec" (ppr pairs) + +arityType env (Let b e) + = floatIn (cheap_bind b) (arityType env e) + where + cheap_bind (NonRec b e) = is_cheap (b,e) + cheap_bind (Rec prs) = all is_cheap prs + is_cheap (b,e) = ae_cheap_fn env e (Just (idType b)) + +arityType env (Tick t e) + | not (tickishIsCode t) = arityType env e + +arityType _ _ = vanillaArityType + +{- Note [Eta-expansion and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#18328) + + f x = join j y = case y of + True -> \a. blah + False -> \b. blah + in case x of + A -> j True + B -> \c. blah + C -> j False + +and suppose the join point is too big to inline. Now, what is the +arity of f? If we inlined the join point, we'd definitely say "arity +2" because we are prepared to push case-scrutinisation inside a +lambda. But currently the join point totally messes all that up, +because (thought of as a vanilla let-binding) the arity pinned on 'j' +is just 1. + +Why don't we eta-expand j? Because of +Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils + +Even if we don't eta-expand j, why is its arity only 1? +See invariant 2b in Note [Invariants on join points] in GHC.Core. + +So we do this: + +* Treat the RHS of a join-point binding, /after/ stripping off + join-arity lambda-binders, as very like the body of the let. + More precisely, do andArityType with the arityType from the + body of the let. + +* Dually, when we come to a /call/ of a join point, just no-op + by returning botArityType, the bottom element of ArityType, + which so that: bot `andArityType` x = x + +* This works if the join point is bound in the expression we are + taking the arityType of. But if it's bound further out, it makes + no sense to say that (say) the arityType of (j False) is ABot 0. + Bad things happen. So we keep track of the in-scope join-point Ids + in ae_join. + +This will make f, above, have arity 2. Then, we'll eta-expand it thus: + + f x eta = (join j y = ... in case x of ...) eta + +and the Simplify will automatically push that application of eta into +the join points. + +An alternative (roughly equivalent) idea would be to carry an +environment mapping let-bound Ids to their ArityType. +-} + +idArityType :: Id -> ArityType +idArityType v + | strict_sig <- idStrictness v + , not $ isTopSig strict_sig + , (ds, res) <- splitStrictSig strict_sig + , let arity = length ds + = if isDeadEndDiv res then ABot arity + else ATop (take arity one_shots) + | otherwise + = ATop (take (idArity v) one_shots) + where + one_shots :: [OneShotInfo] -- One-shot-ness derived from the type + one_shots = typeArity (idType v) + +{- +%************************************************************************ +%* * + The main eta-expander +%* * +%************************************************************************ + +We go for: + f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym + (n >= 0) + +where (in both cases) + + * The xi can include type variables + + * The yi are all value variables + + * N is a NORMAL FORM (i.e. no redexes anywhere) + wanting a suitable number of extra args. + +The biggest reason for doing this is for cases like + + f = \x -> case x of + True -> \y -> e1 + False -> \y -> e2 + +Here we want to get the lambdas together. A good example is the nofib +program fibheaps, which gets 25% more allocation if you don't do this +eta-expansion. + +We may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. + +Note [No crap in eta-expanded code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The eta expander is careful not to introduce "crap". In particular, +given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it +returns a CoreExpr satisfying the same invariant. See Note [Eta +expansion and the CorePrep invariants] in CorePrep. + +This means the eta-expander has to do a bit of on-the-fly +simplification but it's not too hard. The alternative, of relying on +a subsequent clean-up phase of the Simplifier to de-crapify the result, +means you can't really use it in CorePrep, which is painful. + +Note [Eta expansion for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The no-crap rule is very tiresome to guarantee when +we have join points. Consider eta-expanding + let j :: Int -> Int -> Bool + j x = e + in b + +The simple way is + \(y::Int). (let j x = e in b) y + +The no-crap way is + \(y::Int). let j' :: Int -> Bool + j' x = e y + in b[j'/j] y +where I have written to stress that j's type has +changed. Note that (of course!) we have to push the application +inside the RHS of the join as well as into the body. AND if j +has an unfolding we have to push it into there too. AND j might +be recursive... + +So for now I'm abandoning the no-crap rule in this case. I think +that for the use in CorePrep it really doesn't matter; and if +it does, then CoreToStg.myCollectArgs will fall over. + +(Moreover, I think that casts can make the no-crap rule fail too.) + +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + +Note [Eta expansion and source notes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CorePrep puts floatable ticks outside of value applications, but not +type applications. As a result we might be trying to eta-expand an +expression like + + (src<...> v) @a + +which we want to lead to code like + + \x -> src<...> v @a x + +This means that we need to look through type applications and be ready +to re-add floats on the top. + +Note [Eta expansion with ArityType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The etaExpandAT function takes an ArityType (not just an Arity) to +guide eta-expansion. Why? Because we want to preserve one-shot info. +Consider + foo = \x. case x of + True -> (\s{os}. blah) |> co + False -> wubble +We'll get an ArityType for foo of (ATop [NoOneShot,OneShot]). + +Then we want to eta-expand to + foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co + +That 'eta' binder is fresh, and we really want it to have the +one-shot flag from the inner \s{osf}. By expanding with the +ArityType gotten from analysing the RHS, we achieve this neatly. + +This makes a big difference to the one-shot monad trick; +see Note [The one-shot state monad trick] in GHC.Core.Unify. +-} + +-- | @etaExpand n e@ returns an expression with +-- the same meaning as @e@, but with arity @n@. +-- +-- Given: +-- +-- > e' = etaExpand n e +-- +-- We should have that: +-- +-- > ty = exprType e = exprType e' +etaExpand :: Arity -> CoreExpr -> CoreExpr +etaExpandAT :: ArityType -> CoreExpr -> CoreExpr + +etaExpand n orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr +etaExpandAT at orig_expr = eta_expand (arityTypeOneShots at) orig_expr + -- See Note [Eta expansion with ArityType] + +-- etaExpand arity e = res +-- Then 'res' has at least 'arity' lambdas at the top +-- See Note [Eta expansion with ArityType] +-- +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) +-- +-- It deals with coerces too, though they are now rare +-- so perhaps the extra code isn't worth it + +eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr +eta_expand one_shots orig_expr + = go one_shots orig_expr + where + -- Strip off existing lambdas and casts before handing off to mkEtaWW + -- Note [Eta expansion and SCCs] + go [] expr = expr + go oss@(_:oss1) (Lam v body) | isTyVar v = Lam v (go oss body) + | otherwise = Lam v (go oss1 body) + go oss (Cast expr co) = Cast (go oss expr) co + + go oss expr + = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ + retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas) + where + in_scope = mkInScopeSet (exprFreeVars expr) + (in_scope', etas) = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) + subst' = mkEmptySubst in_scope' + + -- Find ticks behind type apps. + -- See Note [Eta expansion and source notes] + (expr', args) = collectArgs expr + (ticks, expr'') = stripTicksTop tickishFloatable expr' + sexpr = foldl' App expr'' args + retick expr = foldr mkTick expr ticks + + -- Abstraction Application +-------------- +data EtaInfo = EtaVar Var -- /\a. [] [] a + -- \x. [] [] x + | EtaCo Coercion -- [] |> sym co [] |> co + +instance Outputable EtaInfo where + ppr (EtaVar v) = text "EtaVar" <+> ppr v + ppr (EtaCo co) = text "EtaCo" <+> ppr co + +pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] +pushCoercion co1 (EtaCo co2 : eis) + | isReflCo co = eis + | otherwise = EtaCo co : eis + where + co = co1 `mkTransCo` co2 + +pushCoercion co eis = EtaCo co : eis + +-------------- +etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr +etaInfoAbs [] expr = expr +etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) +etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) + +-------------- +etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr +-- (etaInfoApp s e eis) returns something equivalent to +-- ((substExpr s e) `appliedto` eis) + +etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) + = etaInfoApp (GHC.Core.Subst.extendSubstWithVar subst v1 v2) e eis + +etaInfoApp subst (Cast e co1) eis + = etaInfoApp subst e (pushCoercion co' eis) + where + co' = GHC.Core.Subst.substCo subst co1 + +etaInfoApp subst (Case e b ty alts) eis + = Case (subst_expr subst e) b1 ty' alts' + where + (subst1, b1) = substBndr subst b + alts' = map subst_alt alts + ty' = etaInfoAppTy (GHC.Core.Subst.substTy subst ty) eis + subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) + where + (subst2,bs') = substBndrs subst1 bs + +etaInfoApp subst (Let b e) eis + | not (isJoinBind b) + -- See Note [Eta expansion for join points] + = Let b' (etaInfoApp subst' e eis) + where + (subst', b') = substBindSC subst b + +etaInfoApp subst (Tick t e) eis + = Tick (substTickish subst t) (etaInfoApp subst e eis) + +etaInfoApp subst expr _ + | (Var fun, _) <- collectArgs expr + , Var fun' <- lookupIdSubst subst fun + , isJoinId fun' + = subst_expr subst expr + +etaInfoApp subst e eis + = go (subst_expr subst e) eis + where + go e [] = e + go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis + go e (EtaCo co : eis) = go (Cast e co) eis + + +-------------- +etaInfoAppTy :: Type -> [EtaInfo] -> Type +-- If e :: ty +-- then etaInfoApp e eis :: etaInfoApp ty eis +etaInfoAppTy ty [] = ty +etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis +etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis + +-------------- +-- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding +-- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the +-- free variables of @e@. +-- +-- Note that this function is entirely unconcerned about cost centres and other +-- semantically-irrelevant source annotations, so call sites must take care to +-- preserve that info. See Note [Eta expansion and SCCs]. +mkEtaWW + :: [OneShotInfo] + -- ^ How many value arguments to eta-expand + -> SDoc + -- ^ The pretty-printed original expression, for warnings. + -> InScopeSet + -- ^ A super-set of the free vars of the expression to eta-expand. + -> Type + -> (InScopeSet, [EtaInfo]) + -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. + -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the + -- fresh variables in 'EtaInfo'. + +mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty + = go 0 orig_oss empty_subst orig_ty [] + where + empty_subst = mkEmptyTCvSubst in_scope + + go :: Int -- For fresh names + -> [OneShotInfo] -- Number of value args to expand to + -> TCvSubst -> Type -- We are really looking at subst(ty) + -> [EtaInfo] -- Accumulating parameter + -> (InScopeSet, [EtaInfo]) + go _ [] subst _ eis -- See Note [exprArity invariant] + ----------- Done! No more expansion needed + = (getTCvInScope subst, reverse eis) + + go n oss@(one_shot:oss1) subst ty eis -- See Note [exprArity invariant] + ----------- Forall types (forall a. ty) + | Just (tcv,ty') <- splitForAllTy_maybe ty + , (subst', tcv') <- Type.substVarBndr subst tcv + , let oss' | isTyVar tcv = oss + | otherwise = oss1 + -- A forall can bind a CoVar, in which case + -- we consume one of the [OneShotInfo] + = go n oss' subst' ty' (EtaVar tcv' : eis) + + ----------- Function types (t1 -> t2) + | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , not (isTypeLevPoly arg_ty) + -- See Note [Levity polymorphism invariants] in GHC.Core + -- See also test case typecheck/should_run/EtaExpandLevPoly + + , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty) + -- Avoid free vars of the original expression + + , let eta_id' = eta_id `setIdOneShotInfo` one_shot + = go (n+1) oss1 subst' res_ty (EtaVar eta_id' : eis) + + ----------- Newtypes + -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + | Just (co, ty') <- topNormaliseNewType_maybe ty + , let co' = Coercion.substCo subst co + -- Remember to apply the substitution to co (#16979) + -- (or we could have applied to ty, but then + -- we'd have had to zap it for the recursive call) + = go n oss subst ty' (pushCoercion co' eis) + + | otherwise -- We have an expression of arity > 0, + -- but its type isn't a function, or a binder + -- is levity-polymorphic + = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr ) + (getTCvInScope subst, reverse eis) + -- This *can* legitimately happen: + -- e.g. coerce Int (\x. x) Essentially the programmer is + -- playing fast and loose with types (Happy does this a lot). + -- So we simply decline to eta-expand. Otherwise we'd end up + -- with an explicit lambda having a non-function type + + + +------------ +subst_expr :: Subst -> CoreExpr -> CoreExpr +-- Apply a substitution to an expression. We use substExpr +-- not substExprSC (short-cutting substitution) because +-- we may be changing the types of join points, so applying +-- the in-scope set is necessary. +-- +-- ToDo: we could instead check if we actually *are* +-- changing any join points' types, and if not use substExprSC. +subst_expr = substExpr + + +-------------- + +-- | Split an expression into the given number of binders and a body, +-- eta-expanding if necessary. Counts value *and* type binders. +etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) +etaExpandToJoinPoint join_arity expr + = go join_arity [] expr + where + go 0 rev_bs e = (reverse rev_bs, e) + go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e + go n rev_bs e = case etaBodyForJoinPoint n e of + (bs, e') -> (reverse rev_bs ++ bs, e') + +etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule +etaExpandToJoinPointRule _ rule@(BuiltinRule {}) + = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule])) + -- How did a local binding get a built-in rule anyway? Probably a plugin. + rule +etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs + , ru_args = args }) + | need_args == 0 + = rule + | need_args < 0 + = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) + | otherwise + = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args + , ru_rhs = new_rhs } + where + need_args = join_arity - length args + (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs + new_args = varsToCoreExprs new_bndrs + +-- Adds as many binders as asked for; assumes expr is not a lambda +etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) +etaBodyForJoinPoint need_args body + = go need_args (exprType body) (init_subst body) [] body + where + go 0 _ _ rev_bs e + = (reverse rev_bs, e) + go n ty subst rev_bs e + | Just (tv, res_ty) <- splitForAllTy_maybe ty + , let (subst', tv') = Type.substVarBndr subst tv + = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') + | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty) + = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) + | otherwise + = pprPanic "etaBodyForJoinPoint" $ int need_args $$ + ppr body $$ ppr (exprType body) + + init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) + +-------------- +freshEtaId :: Int -> TCvSubst -> Scaled Type -> (TCvSubst, Id) +-- Make a fresh Id, with specified type (after applying substitution) +-- It should be "fresh" in the sense that it's not in the in-scope set +-- of the TvSubstEnv; and it should itself then be added to the in-scope +-- set of the TvSubstEnv +-- +-- The Int is just a reasonable starting point for generating a unique; +-- it does not necessarily have to be unique itself. +freshEtaId n subst ty + = (subst', eta_id') + where + Scaled mult' ty' = Type.substScaledTyUnchecked subst ty + eta_id' = uniqAway (getTCvInScope subst) $ + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' + -- "OrCoVar" since this can be used to eta-expand + -- coercion abstractions + subst' = extendTCvInScope subst eta_id' diff --git a/GHC/Core/Opt/CSE.hs b/GHC/Core/Opt/CSE.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CSE.hs @@ -0,0 +1,799 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section{Common subexpression} +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Subst +import GHC.Types.Var ( Var ) +import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Id ( Id, idType, idHasRules + , idInlineActivation, setInlineActivation + , zapIdOccInfo, zapIdUsageInfo, idInlinePragma + , isJoinId, isJoinId_maybe ) +import GHC.Core.Utils ( mkAltExpr, eqExpr + , exprIsTickedString + , stripTicksE, stripTicksT, mkTicks ) +import GHC.Core.FVs ( exprFreeVars ) +import GHC.Core.Type ( tyConAppArgs ) +import GHC.Core +import GHC.Utils.Outputable +import GHC.Types.Basic +import GHC.Core.Map +import GHC.Utils.Misc ( filterOut, equalLength, debugIsOn ) +import Data.List ( mapAccumL ) + +{- + Simple common sub-expression + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + x1 = C a b + x2 = C x1 b +we build up a reverse mapping: C a b -> x1 + C x1 b -> x2 +and apply that to the rest of the program. + +When we then see + y1 = C a b + y2 = C y1 b +we replace the C a b with x1. But then we *dont* want to +add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 +so that a subsequent binding + y2 = C y1 b +will get transformed to C x1 b, and then to x2. + +So we carry an extra var->var substitution which we apply *before* looking up in the +reverse mapping. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +We have to be careful about shadowing. +For example, consider + f = \x -> let y = x+x in + h = \x -> x+x + in ... + +Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no +shadowing, but it doesn't any more (it proved too hard), so we clone as we go. +We can simply add clones to the substitution already described. + + +Note [CSE for bindings] +~~~~~~~~~~~~~~~~~~~~~~~ +Let-bindings have two cases, implemented by addBinding. + +* SUBSTITUTE: applies when the RHS is a variable + + let x = y in ...(h x).... + + Here we want to extend the /substitution/ with x -> y, so that the + (h x) in the body might CSE with an enclosing (let v = h y in ...). + NB: the substitution maps InIds, so we extend the substitution with + a binding for the original InId 'x' + + How can we have a variable on the RHS? Doesn't the simplifier inline them? + + - First, the original RHS might have been (g z) which has CSE'd + with an enclosing (let y = g z in ...). This is super-important. + See #5996: + x1 = C a b + x2 = C x1 b + y1 = C a b + y2 = C y1 b + Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to + the substitution so that we can CSE the binding for y2. + + - Second, we use addBinding for case expression scrutinees too; + see Note [CSE for case expressions] + +* EXTEND THE REVERSE MAPPING: applies in all other cases + + let x = h y in ...(h y)... + + Here we want to extend the /reverse mapping (cs_map)/ so that + we CSE the (h y) call to x. + + Note that we use EXTEND even for a trivial expression, provided it + is not a variable or literal. In particular this /includes/ type + applications. This can be important (#13156); e.g. + case f @ Int of { r1 -> + case f @ Int of { r2 -> ... + Here we want to common-up the two uses of (f @ Int) so we can + remove one of the case expressions. + + See also Note [Corner case for case expressions] for another + reason not to use SUBSTITUTE for all trivial expressions. + +Notice that + - The SUBSTITUTE situation extends the substitution (cs_subst) + - The EXTEND situation extends the reverse mapping (cs_map) + +Notice also that in the SUBSTITUTE case we leave behind a binding + x = y +even though we /also/ carry a substitution x -> y. Can we just drop +the binding instead? Well, not at top level! See Note [Top level and +postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils; and in any +case CSE applies only to the /bindings/ of the program, and we leave +it to the simplifier to propate effects to the RULES. Finally, it +doesn't seem worth the effort to discard the nested bindings because +the simplifier will do it next. + +Note [CSE for case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case scrut_expr of x { ...alts... } +This is very like a strict let-binding + let !x = scrut_expr in ... +So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a +result all the stuff under Note [CSE for bindings] applies directly. + +For example: + +* Trivial scrutinee + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... + + Here, (wild1:as) is morally the same as (a:as) and hence equal to + wild. But that's not quite obvious. In the rest of the compiler we + want to keep it as (wild1:as), but for CSE purpose that's a bad + idea. + + By using addBinding we add the binding (wild1 -> a) to the substitution, + which does exactly the right thing. + + (Notice this is exactly backwards to what the simplifier does, which + is to try to replaces uses of 'a' with uses of 'wild1'.) + + This is the main reason that addBinding is called with a trivial rhs. + +* Non-trivial scrutinee + case (f x) of y { pat -> ...let z = f x in ... } + + By using addBinding we'll add (f x :-> y) to the cs_map, and + thereby CSE the inner (f x) to y. + +Note [CSE for INLINE and NOINLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are some subtle interactions of CSE with functions that the user +has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.) +Consider + + yes :: Int {-# NOINLINE yes #-} + yes = undefined + + no :: Int {-# NOINLINE no #-} + no = undefined + + foo :: Int -> Int -> Int {-# NOINLINE foo #-} + foo m n = n + + {-# RULES "foo/no" foo no = id #-} + + bar :: Int -> Int + bar = foo yes + +We do not expect the rule to fire. But if we do CSE, then we risk +getting yes=no, and the rule does fire. Actually, it won't because +NOINLINE means that 'yes' will never be inlined, not even if we have +yes=no. So that's fine (now; perhaps in the olden days, yes=no would +have substituted even if 'yes' was NOINLINE). + +But we do need to take care. Consider + + {-# NOINLINE bar #-} + bar = -- Same rhs as foo + + foo = + +If CSE produces + foo = bar +then foo will never be inlined to (when it should be, if +is small). The conclusion here is this: + + We should not add + :-> bar + to the CSEnv if 'bar' has any constraints on when it can inline; + that is, if its 'activation' not always active. Otherwise we + might replace by 'bar', and then later be unable to see that it + really was . + +An except to the rule is when the INLINE pragma is not from the user, e.g. from +WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec +is then true. + +Note that we do not (currently) do CSE on the unfolding stored inside +an Id, even if it is a 'stable' unfolding. That means that when an +unfolding happens, it is always faithful to what the stable unfolding +originally was. + +Note [CSE for stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + {-# Unf = Stable (\pq. build blah) #-} + foo = x + +Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial. +(Turns out that this actually happens for the enumFromTo method of +the Integer instance of Enum in GHC.Enum.) Suppose moreover that foo's +stable unfolding originates from an INLINE or INLINEABLE pragma on foo. +Then we obviously do NOT want to extend the substitution with (foo->x), +because we promised to inline foo as what the user wrote. See similar Note +[Stable unfoldings and postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils. + +Nor do we want to change the reverse mapping. Suppose we have + + {-# Unf = Stable (\pq. build blah) #-} + foo = + bar = + +There could conceivably be merit in rewriting the RHS of bar: + bar = foo +but now bar's inlining behaviour will change, and importing +modules might see that. So it seems dodgy and we don't do it. + +Stable unfoldings are also created during worker/wrapper when we decide +that a function's definition is so small that it should always inline. +In this case we still want to do CSE (#13340). Hence the use of +isAnyInlinePragma rather than isStableUnfolding. + +Note [Corner case for case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another reason that we do not use SUBSTITUTE for +all trivial expressions. Consider + case x |> co of (y::Array# Int) { ... } + +We do not want to extend the substitution with (y -> x |> co); since y +is of unlifted type, this would destroy the let/app invariant if (x |> +co) was not ok-for-speculation. + +But surely (x |> co) is ok-for-speculation, because it's a trivial +expression, and x's type is also unlifted, presumably. Well, maybe +not if you are using unsafe casts. I actually found a case where we +had + (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int) + +Note [CSE for join points?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not be naive about join points in CSE: + join j = e in + if b then jump j else 1 + e +The expression (1 + jump j) is not good (see Note [Invariants on join points] in +GHC.Core). This seems to come up quite seldom, but it happens (first seen +compiling ppHtml in Haddock.Backends.Xhtml). + +We could try and be careful by tracking which join points are still valid at +each subexpression, but since join points aren't allocated or shared, there's +less to gain by trying to CSE them. (#13219) + +Note [Look inside join-point binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Another way how CSE for join points is tricky is + + let join foo x = (x, 42) + join bar x = (x, 42) + in … jump foo 1 … jump bar 2 … + +naively, CSE would turn this into + + let join foo x = (x, 42) + join bar = foo + in … jump foo 1 … jump bar 2 … + +but now bar is a join point that claims arity one, but its right-hand side +is not a lambda, breaking the join-point invariant (this was #15002). + +So `cse_bind` must zoom past the lambdas of a join point (using +`collectNBinders`) and resume searching for CSE opportunities only in +the body of the join point. + +Note [CSE for recursive bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x ... f.... + g = \y ... g ... +where the "..." are identical. Could we CSE them? In full generality +with mutual recursion it's quite hard; but for self-recursive bindings +(which are very common) it's rather easy: + +* Maintain a separate cs_rec_map, that maps + (\f. (\x. ...f...) ) -> f + Note the \f in the domain of the mapping! + +* When we come across the binding for 'g', look up (\g. (\y. ...g...)) + Bingo we get a hit. So we can replace the 'g' binding with + g = f + +We can't use cs_map for this, because the key isn't an expression of +the program; it's a kind of synthetic key for recursive bindings. + + +************************************************************************ +* * +\section{Common subexpression} +* * +************************************************************************ +-} + +cseProgram :: CoreProgram -> CoreProgram +cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds) + +cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) +cseBind toplevel env (NonRec b e) + = (env2, NonRec b2 e2) + where + (env1, b1) = addBinder env b + (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1 + +cseBind toplevel env (Rec [(in_id, rhs)]) + | noCSE in_id + = (env1, Rec [(out_id, rhs')]) + + -- See Note [CSE for recursive bindings] + | Just previous <- lookupCSRecEnv env out_id rhs'' + , let previous' = mkTicks ticks previous + out_id' = delayInlining toplevel out_id + = -- We have a hit in the recursive-binding cache + (extendCSSubst env1 in_id previous', NonRec out_id' previous') + + | otherwise + = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) + + where + (env1, [out_id]) = addRecBinders env [in_id] + rhs' = cseExpr env1 rhs + rhs'' = stripTicksE tickishFloatable rhs' + ticks = stripTicksT tickishFloatable rhs' + id_expr' = varToCoreExpr out_id + zapped_id = zapIdUsageInfo out_id + +cseBind toplevel env (Rec pairs) + = (env2, Rec pairs') + where + (env1, bndrs1) = addRecBinders env (map fst pairs) + (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) + + do_one env (pr, b1) = cse_bind toplevel env pr b1 + +-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer +-- to @in_id@ (@out_id@, created from addBinder or addRecBinders), +-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd) +-- binding to the 'CSEnv', so that we attempt to CSE any expressions +-- which are equal to @out_rhs@. +cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr)) +cse_bind toplevel env (in_id, in_rhs) out_id + | isTopLevel toplevel, exprIsTickedString in_rhs + -- See Note [Take care with literal strings] + = (env', (out_id', in_rhs)) + + | Just arity <- isJoinId_maybe in_id + -- See Note [Look inside join-point binders] + = let (params, in_body) = collectNBinders arity in_rhs + (env', params') = addBinders env params + out_body = tryForCSE env' in_body + in (env, (out_id, mkLams params' out_body)) + + | otherwise + = (env', (out_id'', out_rhs)) + where + (env', out_id') = addBinding env in_id out_id out_rhs + (cse_done, out_rhs) = try_for_cse env in_rhs + out_id'' | cse_done = delayInlining toplevel out_id' + | otherwise = out_id' + +delayInlining :: TopLevelFlag -> Id -> Id +-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already +-- See Note [Delay inlining after CSE] +delayInlining top_lvl bndr + | isTopLevel top_lvl + , isAlwaysActive (idInlineActivation bndr) + , idHasRules bndr -- Only if the Id has some RULES, + -- which might otherwise get lost + -- These rules are probably auto-generated specialisations, + -- since Ids with manual rules usually have manually-inserted + -- delayed inlining anyway + = bndr `setInlineActivation` activateAfterInitial + | otherwise + = bndr + +addBinding :: CSEnv -- Includes InId->OutId cloning + -> InVar -- Could be a let-bound type + -> OutId -> OutExpr -- Processed binding + -> (CSEnv, OutId) -- Final env, final bndr +-- Extend the CSE env with a mapping [rhs -> out-id] +-- unless we can instead just substitute [in-id -> rhs] +-- +-- It's possible for the binder to be a type variable (see +-- Note [Type-let] in GHC.Core), in which case we can just substitute. +addBinding env in_id out_id rhs' + | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) + | noCSE in_id = (env, out_id) + | use_subst = (extendCSSubst env in_id rhs', out_id) + | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) + where + id_expr' = varToCoreExpr out_id + zapped_id = zapIdUsageInfo out_id + -- Putting the Id into the cs_map makes it possible that + -- it'll become shared more than it is now, which would + -- invalidate (the usage part of) its demand info. + -- This caused #100218. + -- Easiest thing is to zap the usage info; subsequently + -- performing late demand-analysis will restore it. Don't zap + -- the strictness info; it's not necessary to do so, and losing + -- it is bad for performance if you don't do late demand + -- analysis + + -- Should we use SUBSTITUTE or EXTEND? + -- See Note [CSE for bindings] + use_subst = case rhs' of + Var {} -> True + _ -> False + +-- | Given a binder `let x = e`, this function +-- determines whether we should add `e -> x` to the cs_map +noCSE :: InId -> Bool +noCSE id = not (isAlwaysActive (idInlineActivation id)) && + not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) + -- See Note [CSE for INLINE and NOINLINE] + || isAnyInlinePragma (idInlinePragma id) + -- See Note [CSE for stable unfoldings] + || isJoinId id + -- See Note [CSE for join points?] + + +{- Note [Take care with literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example: + + x = "foo"# + y = "foo"# + ...x...y...x...y.... + +We would normally turn this into: + + x = "foo"# + y = x + ...x...x...x...x.... + +But this breaks an invariant of Core, namely that the RHS of a top-level binding +of type Addr# must be a string literal, not another variable. See Note +[Core top-level string literals] in GHC.Core. + +For this reason, we special case top-level bindings to literal strings and leave +the original RHS unmodified. This produces: + + x = "foo"# + y = "foo"# + ...x...x...x...x.... + +Now 'y' will be discarded as dead code, and we are done. + +The net effect is that for the y-binding we want to + - Use SUBSTITUTE, by extending the substitution with y :-> x + - but leave the original binding for y undisturbed + +This is done by cse_bind. I got it wrong the first time (#13367). + +Note [Delay inlining after CSE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#15445) we have + f,g :: Num a => a -> a + f x = ...f (x-1)..... + g y = ...g (y-1) .... + +and we make some specialisations of 'g', either automatically, or via +a SPECIALISE pragma. Then CSE kicks in and notices that the RHSs of +'f' and 'g' are identical, so we get + f x = ...f (x-1)... + g = f + {-# RULES g @Int _ = $sg #-} + +Now there is terrible danger that, in an importing module, we'll inline +'g' before we have a chance to run its specialisation! + +Solution: during CSE, after a "hit" in the CSE cache + * when adding a binding + g = f + * for a top-level function g + * and g has specialisation RULES +add a NOINLINE[2] activation to it, to ensure it's not inlined +right away. + +Notes: +* Why top level only? Because for nested bindings we are already past + phase 2 and will never return there. + +* Why "only if g has RULES"? Because there is no point in + doing this if there are no RULES; and other things being + equal it delays optimisation to delay inlining (#17409) + + +---- Historical note --- + +This patch is simpler and more direct than an earlier +version: + + commit 2110738b280543698407924a16ac92b6d804dc36 + Author: Simon Peyton Jones + Date: Mon Jul 30 13:43:56 2018 +0100 + + Don't inline functions with RULES too early + +We had to revert this patch because it made GHC itself slower. + +Why? It delayed inlining of /all/ functions with RULES, and that was +very bad in GHC.Tc.Solver.Flatten.flatten_ty_con_app + +* It delayed inlining of liftM +* That delayed the unravelling of the recursion in some dictionary + bindings. +* That delayed some eta expansion, leaving + flatten_ty_con_app = \x y. let in \z. blah +* That allowed the float-out pass to put sguff between + the \y and \z. +* And that permanently stopped eta expansion of the function, + even once was simplified. + +-} + +tryForCSE :: CSEnv -> InExpr -> OutExpr +tryForCSE env expr = snd (try_for_cse env expr) + +try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr) +-- (False, e') => We did not CSE the entire expression, +-- but we might have CSE'd some sub-expressions, +-- yielding e' +-- +-- (True, te') => We CSE'd the entire expression, +-- yielding the trivial expression te' +try_for_cse env expr + | Just e <- lookupCSEnv env expr'' = (True, mkTicks ticks e) + | otherwise = (False, expr') + -- The varToCoreExpr is needed if we have + -- case e of xco { ...case e of yco { ... } ... } + -- Then CSE will substitute yco -> xco; + -- but these are /coercion/ variables + where + expr' = cseExpr env expr + expr'' = stripTicksE tickishFloatable expr' + ticks = stripTicksT tickishFloatable expr' + -- We don't want to lose the source notes when a common sub + -- expression gets eliminated. Hence we push all (!) of them on + -- top of the replaced sub-expression. This is probably not too + -- useful in practice, but upholds our semantics. + +-- | Runs CSE on a single expression. +-- +-- This entry point is not used in the compiler itself, but is provided +-- as a convenient entry point for users of the GHC API. +cseOneExpr :: InExpr -> OutExpr +cseOneExpr e = cseExpr env e + where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } + +cseExpr :: CSEnv -> InExpr -> OutExpr +cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) +cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) +cseExpr _ (Lit lit) = Lit lit +cseExpr env (Var v) = lookupSubst env v +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (Tick t e) = Tick t (cseExpr env e) +cseExpr env (Cast e co) = Cast (tryForCSE env e) (substCo (csEnvSubst env) co) +cseExpr env (Lam b e) = let (env', b') = addBinder env b + in Lam b' (cseExpr env' e) +cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env bind + in Let bind' (cseExpr env' e) +cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts + +cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr +cseCase env scrut bndr ty alts + = Case scrut1 bndr3 ty' $ + combineAlts alt_env (map cse_alt alts) + where + ty' = substTy (csEnvSubst env) ty + scrut1 = tryForCSE env scrut + + bndr1 = zapIdOccInfo bndr + -- Zapping the OccInfo is needed because the extendCSEnv + -- in cse_alt may mean that a dead case binder + -- becomes alive, and Lint rejects that + (env1, bndr2) = addBinder env bndr1 + (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 + -- addBinding: see Note [CSE for case expressions] + + con_target :: OutExpr + con_target = lookupSubst alt_env bndr + + arg_tys :: [OutType] + arg_tys = tyConAppArgs (idType bndr3) + + -- See Note [CSE for case alternatives] + cse_alt (DataAlt con, args, rhs) + = (DataAlt con, args', tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' con_expr con_target + con_expr = mkAltExpr (DataAlt con) args' arg_tys + + cse_alt (con, args, rhs) + = (con, args', tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args + +combineAlts :: CSEnv -> [OutAlt] -> [OutAlt] +-- See Note [Combine case alternatives] +combineAlts env alts + | (Just alt1, rest_alts) <- find_bndr_free_alt alts + , (_,bndrs1,rhs1) <- alt1 + , let filtered_alts = filterOut (identical_alt rhs1) rest_alts + , not (equalLength rest_alts filtered_alts) + = ASSERT2( null bndrs1, ppr alts ) + (DEFAULT, [], rhs1) : filtered_alts + + | otherwise + = alts + where + in_scope = substInScope (csEnvSubst env) + + find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt]) + -- The (Just alt) is a binder-free alt + -- See Note [Combine case alts: awkward corner] + find_bndr_free_alt [] + = (Nothing, []) + find_bndr_free_alt (alt@(_,bndrs,_) : alts) + | null bndrs = (Just alt, alts) + | otherwise = case find_bndr_free_alt alts of + (mb_bf, alts) -> (mb_bf, alt:alts) + + identical_alt rhs1 (_,_,rhs) = eqExpr in_scope rhs1 rhs + -- Even if this alt has binders, they will have been cloned + -- If any of these binders are mentioned in 'rhs', then + -- 'rhs' won't compare equal to 'rhs1' (which is from an + -- alt with no binders). + +{- Note [CSE for case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider case e of x + K1 y -> ....(K1 y)... + K2 -> ....K2.... + +We definitely want to CSE that (K1 y) into just x. + +But what about the lone K2? At first you would think "no" because +turning K2 into 'x' increases the number of live variables. But + +* Turning K2 into x increases the chance of combining identical alts. + Example case xs of + (_:_) -> f xs + [] -> f [] + See #17901 and simplCore/should_compile/T17901 for more examples + of this kind. + +* The next run of the simplifier will turn 'x' back into K2, so we won't + permanently bloat the free-var count. + + +Note [Combine case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +combineAlts is just a more heavyweight version of the use of +combineIdenticalAlts in GHC.Core.Opt.Simplify.Utils.prepareAlts. The basic idea is +to transform + + DEFAULT -> e1 + K x -> e1 + W y z -> e2 +===> + DEFAULT -> e1 + W y z -> e2 + +In the simplifier we use cheapEqExpr, because it is called a lot. +But here in CSE we use the full eqExpr. After all, two alternatives usually +differ near the root, so it probably isn't expensive to compare the full +alternative. It seems like the same kind of thing that CSE is supposed +to be doing, which is why I put it here. + +I actually saw some examples in the wild, where some inlining made e1 too +big for cheapEqExpr to catch it. + +Note [Combine case alts: awkward corner] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We would really like to check isDeadBinder on the binders in the +alternative. But alas, the simplifer zaps occ-info on binders in case +alternatives; see Note [Case alternative occ info] in GHC.Core.Opt.Simplify. + +* One alternative (perhaps a good one) would be to do OccAnal + just before CSE. Then perhaps we could get rid of combineIdenticalAlts + in the Simplifier, which might save work. + +* Another would be for CSE to return free vars as it goes. + +* But the current solution is to find a nullary alternative (including + the DEFAULT alt, if any). This will not catch + case x of + A y -> blah + B z p -> blah + where no alternative is nullary or DEFAULT. But the current + solution is at least cheap. + + +************************************************************************ +* * +\section{The CSE envt} +* * +************************************************************************ +-} + +data CSEnv + = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs + -- The substitution variables to + -- /trivial/ OutExprs, not arbitrary expressions + + , cs_map :: CoreMap OutExpr -- The reverse mapping + -- Maps a OutExpr to a /trivial/ OutExpr + -- The key of cs_map is stripped of all Ticks + + , cs_rec_map :: CoreMap OutExpr + -- See Note [CSE for recursive bindings] + } + +emptyCSEnv :: CSEnv +emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap + , cs_subst = emptySubst } + +lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr +lookupCSEnv (CS { cs_map = csmap }) expr + = lookupCoreMap csmap expr + +extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv +extendCSEnv cse expr triv_expr + = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr } + where + sexpr = stripTicksE tickishFloatable expr + +extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv +-- See Note [CSE for recursive bindings] +extendCSRecEnv cse bndr expr triv_expr + = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr } + +lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr +-- See Note [CSE for recursive bindings] +lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr + = lookupCoreMap csmap (Lam bndr expr) + +csEnvSubst :: CSEnv -> Subst +csEnvSubst = cs_subst + +lookupSubst :: CSEnv -> Id -> OutExpr +lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst sub x + +extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv +extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } + +-- | Add clones to the substitution to deal with shadowing. See +-- Note [Shadowing] for more details. You should call this whenever +-- you go under a binder. +addBinder :: CSEnv -> Var -> (CSEnv, Var) +addBinder cse v = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v + +addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) +addBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substBndrs (cs_subst cse) vs + +addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) +addRecBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substRecBndrs (cs_subst cse) vs diff --git a/GHC/Core/Opt/CallArity.hs b/GHC/Core/Opt/CallArity.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CallArity.hs @@ -0,0 +1,763 @@ +-- +-- Copyright (c) 2014 Joachim Breitner +-- + +module GHC.Core.Opt.CallArity + ( callArityAnalProgram + , callArityRHS -- for testing + ) where + +import GHC.Prelude + +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Driver.Session ( DynFlags ) + +import GHC.Types.Basic +import GHC.Core +import GHC.Types.Id +import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) +import GHC.Data.Graph.UnVar +import GHC.Types.Demand +import GHC.Utils.Misc + +import Control.Arrow ( first, second ) + + +{- +%************************************************************************ +%* * + Call Arity Analysis +%* * +%************************************************************************ + +Note [Call Arity: The goal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The goal of this analysis is to find out if we can eta-expand a local function, +based on how it is being called. The motivating example is this code, +which comes up when we implement foldl using foldr, and do list fusion: + + let go = \x -> let d = case ... of + False -> go (x+1) + True -> id + in \z -> d (x + z) + in go 1 0 + +If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of +partial function applications, which would be bad. + +The function `go` has a type of arity two, but only one lambda is manifest. +Furthermore, an analysis that only looks at the RHS of go cannot be sufficient +to eta-expand go: If `go` is ever called with one argument (and the result used +multiple times), we would be doing the work in `...` multiple times. + +So `callArityAnalProgram` looks at the whole let expression to figure out if +all calls are nice, i.e. have a high enough arity. It then stores the result in +the `calledArity` field of the `IdInfo` of `go`, which the next simplifier +phase will eta-expand. + +The specification of the `calledArity` field is: + + No work will be lost if you eta-expand me to the arity in `calledArity`. + +What we want to know for a variable +----------------------------------- + +For every let-bound variable we'd like to know: + 1. A lower bound on the arity of all calls to the variable, and + 2. whether the variable is being called at most once or possible multiple + times. + +It is always ok to lower the arity, or pretend that there are multiple calls. +In particular, "Minimum arity 0 and possible called multiple times" is always +correct. + + +What we want to know from an expression +--------------------------------------- + +In order to obtain that information for variables, we analyze expression and +obtain bits of information: + + I. The arity analysis: + For every variable, whether it is absent, or called, + and if called, which what arity. + + II. The Co-Called analysis: + For every two variables, whether there is a possibility that both are being + called. + We obtain as a special case: For every variables, whether there is a + possibility that it is being called twice. + +For efficiency reasons, we gather this information only for a set of +*interesting variables*, to avoid spending time on, e.g., variables from pattern matches. + +The two analysis are not completely independent, as a higher arity can improve +the information about what variables are being called once or multiple times. + +Note [Analysis I: The arity analysis] +------------------------------------ + +The arity analysis is quite straight forward: The information about an +expression is an + VarEnv Arity +where absent variables are bound to Nothing and otherwise to a lower bound to +their arity. + +When we analyze an expression, we analyze it with a given context arity. +Lambdas decrease and applications increase the incoming arity. Analysizing a +variable will put that arity in the environment. In lets or cases all the +results from the various subexpressions are lubed, which takes the point-wise +minimum (considering Nothing an infinity). + + +Note [Analysis II: The Co-Called analysis] +------------------------------------------ + +The second part is more sophisticated. For reasons explained below, it is not +sufficient to simply know how often an expression evaluates a variable. Instead +we need to know which variables are possibly called together. + +The data structure here is an undirected graph of variables, which is provided +by the abstract + UnVarGraph + +It is safe to return a larger graph, i.e. one with more edges. The worst case +(i.e. the least useful and always correct result) is the complete graph on all +free variables, which means that anything can be called together with anything +(including itself). + +Notation for the following: +C(e) is the co-called result for e. +G₁∪G₂ is the union of two graphs +fv is the set of free variables (conveniently the domain of the arity analysis result) +S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ } +S² is the complete graph on the set of variables S, S² = S×S +C'(e) is a variant for bound expression: + If e is called at most once, or it is and stays a thunk (after the analysis), + it is simply C(e). Otherwise, the expression can be called multiple times + and we return (fv e)² + +The interesting cases of the analysis: + * Var v: + No other variables are being called. + Return {} (the empty graph) + * Lambda v e, under arity 0: + This means that e can be evaluated many times and we cannot get + any useful co-call information. + Return (fv e)² + * Case alternatives alt₁,alt₂,...: + Only one can be execuded, so + Return (alt₁ ∪ alt₂ ∪...) + * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: + We get the results from both sides, with the argument evaluated at most once. + Additionally, anything called by e₁ can possibly be called with anything + from e₂. + Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂) + * App e₁ x: + As this is already in A-normal form, CorePrep will not separately lambda + bind (and hence share) x. So we conservatively assume multiple calls to x here + Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} + * Let v = rhs in body: + In addition to the results from the subexpressions, add all co-calls from + everything that the body calls together with v to everything that is called + by v. + Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} + * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body + Tricky. + We assume that it is really mutually recursive, i.e. that every variable + calls one of the others, and that this is strongly connected (otherwise we + return an over-approximation, so that's ok), see note [Recursion and fixpointing]. + + Let V = {v₁,...vₙ}. + Assume that the vs have been analysed with an incoming demand and + cardinality consistent with the final result (this is the fixed-pointing). + Again we can use the results from all subexpressions. + In addition, for every variable vᵢ, we need to find out what it is called + with (call this set Sᵢ). There are two cases: + * If vᵢ is a function, we need to go through all right-hand-sides and bodies, + and collect every variable that is called together with any variable from V: + Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to + exclude it from this set: + Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + Finally, combine all this: + Return: C(body) ∪ + C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ + (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ) + +Using the result: Eta-Expansion +------------------------------- + +We use the result of these two analyses to decide whether we can eta-expand the +rhs of a let-bound variable. + +If the variable is already a function (exprIsCheap), and all calls to the +variables have a higher arity than the current manifest arity (i.e. the number +of lambdas), expand. + +If the variable is a thunk we must be careful: Eta-Expansion will prevent +sharing of work, so this is only safe if there is at most one call to the +function. Therefore, we check whether {v,v} ∈ G. + + Example: + + let n = case .. of .. -- A thunk! + in n 0 + n 1 + + vs. + + let n = case .. of .. + in case .. of T -> n 0 + F -> n 1 + + We are only allowed to eta-expand `n` if it is going to be called at most + once in the body of the outer let. So we need to know, for each variable + individually, that it is going to be called at most once. + + +Why the co-call graph? +---------------------- + +Why is it not sufficient to simply remember which variables are called once and +which are called multiple times? It would be in the previous example, but consider + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y + n 1) + False > n + in go 1 + False -> n + +vs. + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y+1) + False > n + in go 1 + False -> n + +In both cases, the body and the rhs of the inner let call n at most once. +But only in the second case that holds for the whole expression! The +crucial difference is that in the first case, the rhs of `go` can call +*both* `go` and `n`, and hence can call `n` multiple times as it recurses, +while in the second case find out that `go` and `n` are not called together. + + +Why co-call information for functions? +-------------------------------------- + +Although for eta-expansion we need the information only for thunks, we still +need to know whether functions are being called once or multiple times, and +together with what other functions. + + Example: + + let n = case .. of .. + f x = n (x+1) + in f 1 + f 2 + + vs. + + let n = case .. of .. + f x = n (x+1) + in case .. of T -> f 0 + F -> f 1 + + Here, the body of f calls n exactly once, but f itself is being called + multiple times, so eta-expansion is not allowed. + + +Note [Analysis type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The work-hourse of the analysis is the function `callArityAnal`, with the +following type: + + type CallArityRes = (UnVarGraph, VarEnv Arity) + callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + +and the following specification: + + ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr + + <=> + + Assume the expression `expr` is being passed `arity` arguments. Then it holds that + * The domain of `callArityEnv` is a subset of `interestingIds`. + * Any variable from `interestingIds` that is not mentioned in the `callArityEnv` + is absent, i.e. not called at all. + * Every call from `expr` to a variable bound to n in `callArityEnv` has at + least n value arguments. + * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`, + then in no execution of `expr` both are being called. + Furthermore, expr' is expr with the callArity field of the `IdInfo` updated. + + +Note [Which variables are interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The analysis would quickly become prohibitive expensive if we would analyse all +variables; for most variables we simply do not care about how often they are +called, i.e. variables bound in a pattern match. So interesting are variables that are + * top-level or let bound + * and possibly functions (typeArity > 0) + +Note [Taking boring variables into account] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If we decide that the variable bound in `let x = e1 in e2` is not interesting, +the analysis of `e2` will not report anything about `x`. To ensure that +`callArityBind` does still do the right thing we have to take that into account +every time we would be lookup up `x` in the analysis result of `e2`. + * Instead of calling lookupCallArityRes, we return (0, True), indicating + that this variable might be called many times with no arguments. + * Instead of checking `calledWith x`, we assume that everything can be called + with it. + * In the recursive case, when calclulating the `cross_calls`, if there is + any boring variable in the recursive group, we ignore all co-call-results + and directly go to a very conservative assumption. + +The last point has the nice side effect that the relatively expensive +integration of co-call results in a recursive groups is often skipped. This +helped to avoid the compile time blowup in some real-world code with large +recursive groups (#10293). + +Note [Recursion and fixpointing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For a mutually recursive let, we begin by + 1. analysing the body, using the same incoming arity as for the whole expression. + 2. Then we iterate, memoizing for each of the bound variables the last + analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes. + 3. We combine the analysis result from the body and the memoized results for + the arguments (if already present). + 4. For each variable, we find out the incoming arity and whether it is called + once, based on the current analysis result. If this differs from the + memoized results, we re-analyse the rhs and update the memoized table. + 5. If nothing had to be reanalyzed, we are done. + Otherwise, repeat from step 3. + + +Note [Thunks in recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We never eta-expand a thunk in a recursive group, on the grounds that if it is +part of a recursive group, then it will be called multiple times. + +This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not +t1) in the following code: + + let go x = t1 + t1 = if ... then t2 else ... + t2 = if ... then go 1 else ... + in go 0 + +Detecting this would require finding out what variables are only ever called +from thunks. While this is certainly possible, we yet have to see this to be +relevant in the wild. + + +Note [Analysing top-level binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We can eta-expand top-level-binds if they are not exported, as we see all calls +to them. The plan is as follows: Treat the top-level binds as nested lets around +a body representing “all external calls”, which returns a pessimistic +CallArityRes (the co-call graph is the complete graph, all arityies 0). + +Note [Trimming arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the Call Arity papers, we are working on an untyped lambda calculus with no +other id annotations, where eta-expansion is always possible. But this is not +the case for Core! + 1. We need to ensure the invariant + callArity e <= typeArity (exprType e) + for the same reasons that exprArity needs this invariant (see Note + [exprArity invariant] in GHC.Core.Opt.Arity). + + If we are not doing that, a too-high arity annotation will be stored with + the id, confusing the simplifier later on. + + 2. Eta-expanding a right hand side might invalidate existing annotations. In + particular, if an id has a strictness annotation of <...><...>b, then + passing two arguments to it will definitely bottom out, so the simplifier + will throw away additional parameters. This conflicts with Call Arity! So + we ensure that we never eta-expand such a value beyond the number of + arguments mentioned in the strictness signature. + See #10176 for a real-world-example. + +Note [What is a thunk] +~~~~~~~~~~~~~~~~~~~~~~ + +Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a +thunk, not eta-expanded, to avoid losing any sharing. This is also how the +published papers on Call Arity describe it. + +In practice, there are thunks that do a just little work, such as +pattern-matching on a variable, and the benefits of eta-expansion likely +outweigh the cost of doing that repeatedly. Therefore, this implementation of +Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk. + +Note [Call Arity and Join Points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The Call Arity analysis does not care about join points, and treats them just +like normal functions. This is ok. + +The analysis *could* make use of the fact that join points are always evaluated +in the same context as the join-binding they are defined in and are always +one-shot, and handle join points separately, as suggested in +https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870. +This *might* be more efficient (for example, join points would not have to be +considered interesting variables), but it would also add redundant code. So for +now we do not do that. + +The simplifier never eta-expands join points (it instead pushes extra arguments from +an eta-expanded context into the join point’s RHS), so the call arity +annotation on join points is not actually used. As it would be equally valid +(though less efficient) to eta-expand join points, this is the simplifier's +choice, and hence Call Arity sets the call arity for join points as well. +-} + +-- Main entry point + +callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram +callArityAnalProgram _dflags binds = binds' + where + (_, binds') = callArityTopLvl [] emptyVarSet binds + +-- See Note [Analysing top-level-binds] +callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) +callArityTopLvl exported _ [] + = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported]) + , [] ) +callArityTopLvl exported int1 (b:bs) + = (ae2, b':bs') + where + int2 = bindersOf b + exported' = filter isExportedId int2 ++ exported + int' = int1 `addInterestingBinds` b + (ae1, bs') = callArityTopLvl exported' int' bs + (ae2, b') = callArityBind (boringBinds b) ae1 int1 b + + +callArityRHS :: CoreExpr -> CoreExpr +callArityRHS = snd . callArityAnal 0 emptyVarSet + +-- The main analysis function. See Note [Analysis type signature] +callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + -- How this expression uses its interesting variables + -- and the expression with IdInfo updated + +-- The trivial base cases +callArityAnal _ _ e@(Lit _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Type _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Coercion _) + = (emptyArityRes, e) +-- The transparent cases +callArityAnal arity int (Tick t e) + = second (Tick t) $ callArityAnal arity int e +callArityAnal arity int (Cast e co) + = second (\e -> Cast e co) $ callArityAnal arity int e + +-- The interesting case: Variables, Lambdas, Lets, Applications, Cases +callArityAnal arity int e@(Var v) + | v `elemVarSet` int + = (unitArityRes v arity, e) + | otherwise + = (emptyArityRes, e) + +-- Non-value lambdas are ignored +callArityAnal arity int (Lam v e) | not (isId v) + = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e + +-- We have a lambda that may be called multiple times, so its free variables +-- can all be co-called. +callArityAnal 0 int (Lam v e) + = (ae', Lam v e') + where + (ae, e') = callArityAnal 0 (int `delVarSet` v) e + ae' = calledMultipleTimes ae +-- We have a lambda that we are calling. decrease arity. +callArityAnal arity int (Lam v e) + = (ae, Lam v e') + where + (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e + +-- Application. Increase arity for the called expression, nothing to know about +-- the second +callArityAnal arity int (App e (Type t)) + = second (\e -> App e (Type t)) $ callArityAnal arity int e +callArityAnal arity int (App e1 e2) + = (final_ae, App e1' e2') + where + (ae1, e1') = callArityAnal (arity + 1) int e1 + (ae2, e2') = callArityAnal 0 int e2 + -- If the argument is trivial (e.g. a variable), then it will _not_ be + -- let-bound in the Core to STG transformation (CorePrep actually), + -- so no sharing will happen here, and we have to assume many calls. + ae2' | exprIsTrivial e2 = calledMultipleTimes ae2 + | otherwise = ae2 + final_ae = ae1 `both` ae2' + +-- Case expression. +callArityAnal arity int (Case scrut bndr ty alts) + = -- pprTrace "callArityAnal:Case" + -- (vcat [ppr scrut, ppr final_ae]) + (final_ae, Case scrut' bndr ty alts') + where + (alt_aes, alts') = unzip $ map go alts + go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e + in (ae, (dc, bndrs, e')) + alt_ae = lubRess alt_aes + (scrut_ae, scrut') = callArityAnal 0 int scrut + final_ae = scrut_ae `both` alt_ae + +-- For lets, use callArityBind +callArityAnal arity int (Let bind e) + = -- pprTrace "callArityAnal:Let" + -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ]) + (final_ae, Let bind' e') + where + int_body = int `addInterestingBinds` bind + (ae_body, e') = callArityAnal arity int_body e + (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind + +-- Which bindings should we look at? +-- See Note [Which variables are interesting] +isInteresting :: Var -> Bool +isInteresting v = not $ null (typeArity (idType v)) + +interestingBinds :: CoreBind -> [Var] +interestingBinds = filter isInteresting . bindersOf + +boringBinds :: CoreBind -> VarSet +boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf + +addInterestingBinds :: VarSet -> CoreBind -> VarSet +addInterestingBinds int bind + = int `delVarSetList` bindersOf bind -- Possible shadowing + `extendVarSetList` interestingBinds bind + +-- Used for both local and top-level binds +-- Second argument is the demand from the body +callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind) +-- Non-recursive let +callArityBind boring_vars ae_body int (NonRec v rhs) + | otherwise + = -- pprTrace "callArityBind:NonRec" + -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) + (final_ae, NonRec v' rhs') + where + is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] + -- If v is boring, we will not find it in ae_body, but always assume (0, False) + boring = v `elemVarSet` boring_vars + + (arity, called_once) + | boring = (0, False) -- See Note [Taking boring variables into account] + | otherwise = lookupCallArityRes ae_body v + safe_arity | called_once = arity + | is_thunk = 0 -- A thunk! Do not eta-expand + | otherwise = arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity v safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs + + + ae_rhs'| called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + called_by_v = domRes ae_rhs' + called_with_v + | boring = domRes ae_body + | otherwise = calledWith ae_body v `delUnVarSet` v + final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body + + v' = v `setIdCallArity` trimmed_arity + + +-- Recursive let. See Note [Recursion and fixpointing] +callArityBind boring_vars ae_body int b@(Rec binds) + = -- (if length binds > 300 then + -- pprTrace "callArityBind:Rec" + -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ + (final_ae, Rec binds') + where + -- See Note [Taking boring variables into account] + any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds] + + int_body = int `addInterestingBinds` b + (ae_rhs, binds') = fix initial_binds + final_ae = bindersOf b `resDelList` ae_rhs + + initial_binds = [(i,Nothing,e) | (i,e) <- binds] + + fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) + fix ann_binds + | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ + any_change + = fix ann_binds' + | otherwise + = (ae, map (\(i, _, e) -> (i, e)) ann_binds') + where + aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ] + ae = callArityRecEnv any_boring aes_old ae_body + + rerun (i, mbLastRun, rhs) + | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae) + -- No call to this yet, so do nothing + = (False, (i, Nothing, rhs)) + + | Just (old_called_once, old_arity, _) <- mbLastRun + , called_once == old_called_once + , new_arity == old_arity + -- No change, no need to re-analyze + = (False, (i, mbLastRun, rhs)) + + | otherwise + -- We previously analyzed this with a different arity (or not at all) + = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] + + safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] + | otherwise = new_arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity i safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs + + ae_rhs' | called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + i' = i `setIdCallArity` trimmed_arity + + in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs')) + where + -- See Note [Taking boring variables into account] + (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False) + | otherwise = lookupCallArityRes ae i + + (changes, ann_binds') = unzip $ map rerun ann_binds + any_change = or changes + +-- Combining the results from body and rhs, (mutually) recursive case +-- See Note [Analysis II: The Co-Called analysis] +callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes +callArityRecEnv any_boring ae_rhss ae_body + = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $ + ae_new + where + vars = map fst ae_rhss + + ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body + + cross_calls + -- See Note [Taking boring variables into account] + | any_boring = completeGraph (domRes ae_combined) + -- Also, calculating cross_calls is expensive. Simply be conservative + -- if the mutually recursive group becomes too large. + | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined) + | otherwise = unionUnVarGraphs $ map cross_call ae_rhss + cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v + where + is_thunk = idCallArity v == 0 + -- What rhs are relevant as happening before (or after) calling v? + -- If v is a thunk, everything from all the _other_ variables + -- If v is not a thunk, everything can happen. + ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body + | otherwise = ae_combined + -- What do we want to know from these? + -- Which calls can happen next to any recursive call. + called_with_v + = unionUnVarSets $ map (calledWith ae_before_v) vars + called_by_v = domRes ae_rhs + + ae_new = first (cross_calls `unionUnVarGraph`) ae_combined + +-- See Note [Trimming arity] +trimArity :: Id -> Arity -> Arity +trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] + where + max_arity_by_type = length (typeArity (idType v)) + max_arity_by_strsig + | isDeadEndDiv result_info = length demands + | otherwise = a + + (demands, result_info) = splitStrictSig (idStrictness v) + +--------------------------------------- +-- Functions related to CallArityRes -- +--------------------------------------- + +-- Result type for the two analyses. +-- See Note [Analysis I: The arity analysis] +-- and Note [Analysis II: The Co-Called analysis] +type CallArityRes = (UnVarGraph, VarEnv Arity) + +emptyArityRes :: CallArityRes +emptyArityRes = (emptyUnVarGraph, emptyVarEnv) + +unitArityRes :: Var -> Arity -> CallArityRes +unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) + +resDelList :: [Var] -> CallArityRes -> CallArityRes +resDelList vs ae = foldr resDel ae vs + +resDel :: Var -> CallArityRes -> CallArityRes +resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v) + +domRes :: CallArityRes -> UnVarSet +domRes (_, ae) = varEnvDom ae + +-- In the result, find out the minimum arity and whether the variable is called +-- at most once. +lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool) +lookupCallArityRes (g, ae) v + = case lookupVarEnv ae v of + Just a -> (a, not (g `hasLoopAt` v)) + Nothing -> (0, False) + +calledWith :: CallArityRes -> Var -> UnVarSet +calledWith (g, _) v = neighbors g v + +addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes +addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`) + +-- Replaces the co-call graph by a complete graph (i.e. no information) +calledMultipleTimes :: CallArityRes -> CallArityRes +calledMultipleTimes res = first (const (completeGraph (domRes res))) res + +-- Used for application and cases +both :: CallArityRes -> CallArityRes -> CallArityRes +both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2 + +-- Used when combining results from alternative cases; take the minimum +lubRes :: CallArityRes -> CallArityRes -> CallArityRes +lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2) + +lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity +lubArityEnv = plusVarEnv_C min + +lubRess :: [CallArityRes] -> CallArityRes +lubRess = foldl' lubRes emptyArityRes diff --git a/GHC/Core/Opt/ConstantFold.hs b/GHC/Core/Opt/ConstantFold.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/ConstantFold.hs @@ -0,0 +1,2339 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[ConFold]{Constant Folder} + +Conceptually, constant folding should be parameterized with the kind +of target machine to get identical behaviour during compilation time +and runtime. We cheat a little bit here... + +ToDo: + check boundaries before folding, e.g. we can fold the Float addition + (i1 + i2) only if it results in a valid Float. +-} + +{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards, + DeriveFunctor, LambdaCase, TypeApplications, MultiWayIf #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.ConstantFold + ( primOpRules + , builtinRules + , caseRules + , EnableBignumRules (..) + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId, voidPrimId ) + +import GHC.Core +import GHC.Core.Make +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Core.SimpleOpt ( exprIsLiteral_maybe ) +import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Core.TyCon + ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon + , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons + , tyConFamilySize ) +import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) +import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType + , stripTicksTop, stripTicksTopT, mkTicks, stripTicksE ) +import GHC.Core.Unfold ( exprIsConApp_maybe ) +import GHC.Core.Multiplicity +import GHC.Core.FVs +import GHC.Core.Type +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Occurrence ( occNameFS ) +import GHC.Builtin.Names +import GHC.Data.Maybe ( orElse ) +import GHC.Types.Name ( Name, nameOccName ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Basic +import GHC.Platform +import GHC.Utils.Misc +import GHC.Core.Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) + +import Control.Applicative ( Alternative(..) ) + +import Control.Monad +import Data.Bits as Bits +import qualified Data.ByteString as BS +import Data.Int +import Data.Ratio +import Data.Word +import Data.Maybe (fromMaybe) + +{- +Note [Constant folding] +~~~~~~~~~~~~~~~~~~~~~~~ +primOpRules generates a rewrite rule for each primop +These rules do what is often called "constant folding" +E.g. the rules for +# might say + 4 +# 5 = 9 +Well, of course you'd need a lot of rules if you did it +like that, so we use a BuiltinRule instead, so that we +can match in any two literal values. So the rule is really +more like + (Lit x) +# (Lit y) = Lit (x+#y) +where the (+#) on the rhs is done at compile time + +That is why these rules are built in here. +-} + +primOpRules :: Name -> PrimOp -> Maybe CoreRule +primOpRules nm = \case + TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] + DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ] + + -- Int operations + IntAddOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) + , identityPlatform zeroi + , numFoldingRules IntAddOp intPrimOps + ] + IntSubOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) + , rightIdentityPlatform zeroi + , equalArgs >> retLit zeroi + , numFoldingRules IntSubOp intPrimOps + ] + IntAddCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) + , identityCPlatform zeroi ] + IntSubCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) + , rightIdentityCPlatform zeroi + , equalArgs >> retLitNoC zeroi ] + IntMulOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) + , zeroElem zeroi + , identityPlatform onei + , numFoldingRules IntMulOp intPrimOps + ] + IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) + , leftZero zeroi + , rightIdentityPlatform onei + , equalArgs >> retLit onei ] + IntRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) + , leftZero zeroi + , do l <- getLiteral 1 + platform <- getPlatform + guard (l == onei platform) + retLit zeroi + , equalArgs >> retLit zeroi + , equalArgs >> retLit zeroi ] + AndIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem zeroi ] + OrIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityPlatform zeroi ] + XorIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityPlatform zeroi + , equalArgs >> retLit zeroi ] + NotIOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotIOp ] + IntNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp IntNegOp ] + ISllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftL) + , rightIdentityPlatform zeroi ] + ISraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftR) + , rightIdentityPlatform zeroi ] + ISrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogical + , rightIdentityPlatform zeroi ] + + -- Word operations + WordAddOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) + , identityPlatform zerow + , numFoldingRules WordAddOp wordPrimOps + ] + WordSubOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) + , rightIdentityPlatform zerow + , equalArgs >> retLit zerow + , numFoldingRules WordSubOp wordPrimOps + ] + WordAddCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) + , identityCPlatform zerow ] + WordSubCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) + , rightIdentityCPlatform zerow + , equalArgs >> retLitNoC zerow ] + WordMulOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) + , identityPlatform onew + , numFoldingRules WordMulOp wordPrimOps + ] + WordQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) + , rightIdentityPlatform onew ] + WordRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) + , leftZero zerow + , do l <- getLiteral 1 + platform <- getPlatform + guard (l == onew platform) + retLit zerow + , equalArgs >> retLit zerow ] + AndOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) + , idempotent + , zeroElem zerow ] + OrOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) + , idempotent + , identityPlatform zerow ] + XorOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) + , identityPlatform zerow + , equalArgs >> retLit zerow ] + NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotOp ] + SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const Bits.shiftL) ] + SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogical ] + + -- coercions + Word2IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform word2IntLit + , inversePrimOp Int2WordOp ] + Int2WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform int2WordLit + , inversePrimOp Word2IntOp ] + Narrow8IntOp -> mkPrimOpRule nm 1 [ liftLit narrow8IntLit + , subsumedByPrimOp Narrow8IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ] + Narrow16IntOp -> mkPrimOpRule nm 1 [ liftLit narrow16IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ] + Narrow32IntOp -> mkPrimOpRule nm 1 [ liftLit narrow32IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp + , removeOp32 + , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ] + Narrow8WordOp -> mkPrimOpRule nm 1 [ liftLit narrow8WordLit + , subsumedByPrimOp Narrow8WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow8WordOp 8 ] + Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLit narrow16WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow16WordOp 16 ] + Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLit narrow32WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp + , removeOp32 + , narrowSubsumesAnd AndOp Narrow32WordOp 32 ] + OrdOp -> mkPrimOpRule nm 1 [ liftLit char2IntLit + , inversePrimOp ChrOp ] + ChrOp -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs + guard (litFitsInChar lit) + liftLit int2CharLit + , inversePrimOp OrdOp ] + Float2IntOp -> mkPrimOpRule nm 1 [ liftLit float2IntLit ] + Int2FloatOp -> mkPrimOpRule nm 1 [ liftLit int2FloatLit ] + Double2IntOp -> mkPrimOpRule nm 1 [ liftLit double2IntLit ] + Int2DoubleOp -> mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] + -- SUP: Not sure what the standard says about precision in the following 2 cases + Float2DoubleOp -> mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] + Double2FloatOp -> mkPrimOpRule nm 1 [ liftLit double2FloatLit ] + + -- Float + FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) + , identity zerof ] + FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) + , rightIdentity zerof ] + FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) + , identity onef + , strengthReduction twof FloatAddOp ] + -- zeroElem zerof doesn't hold because of NaN + FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) + , rightIdentity onef ] + FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp FloatNegOp ] + FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ] + + -- Double + DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) + , identity zerod ] + DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) + , rightIdentity zerod ] + DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) + , identity oned + , strengthReduction twod DoubleAddOp ] + -- zeroElem zerod doesn't hold because of NaN + DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) + , rightIdentity oned ] + DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp DoubleNegOp ] + DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ] + + -- Relational operators + + IntEqOp -> mkRelOpRule nm (==) [ litEq True ] + IntNeOp -> mkRelOpRule nm (/=) [ litEq False ] + CharEqOp -> mkRelOpRule nm (==) [ litEq True ] + CharNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + IntGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + IntLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + CharGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + CharLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + FloatGtOp -> mkFloatingRelOpRule nm (>) + FloatGeOp -> mkFloatingRelOpRule nm (>=) + FloatLeOp -> mkFloatingRelOpRule nm (<=) + FloatLtOp -> mkFloatingRelOpRule nm (<) + FloatEqOp -> mkFloatingRelOpRule nm (==) + FloatNeOp -> mkFloatingRelOpRule nm (/=) + + DoubleGtOp -> mkFloatingRelOpRule nm (>) + DoubleGeOp -> mkFloatingRelOpRule nm (>=) + DoubleLeOp -> mkFloatingRelOpRule nm (<=) + DoubleLtOp -> mkFloatingRelOpRule nm (<) + DoubleEqOp -> mkFloatingRelOpRule nm (==) + DoubleNeOp -> mkFloatingRelOpRule nm (/=) + + WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + WordEqOp -> mkRelOpRule nm (==) [ litEq True ] + WordNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] + + SeqOp -> mkPrimOpRule nm 4 [ seqRule ] + SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] + + _ -> Nothing + +{- +************************************************************************ +* * +\subsection{Doing the business} +* * +************************************************************************ +-} + +-- useful shorthands +mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule +mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) + +mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> [RuleM CoreExpr] -> Maybe CoreRule +mkRelOpRule nm cmp extra + = mkPrimOpRule nm 2 $ + binaryCmpLit cmp : equal_rule : extra + where + -- x `cmp` x does not depend on x, so + -- compute it for the arbitrary value 'True' + -- and use that result + equal_rule = do { equalArgs + ; platform <- getPlatform + ; return (if cmp True True + then trueValInt platform + else falseValInt platform) } + +{- Note [Rules for floating-point comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need different rules for floating-point values because for floats +it is not true that x = x (for NaNs); so we do not want the equal_rule +rule that mkRelOpRule uses. + +Note also that, in the case of equality/inequality, we do /not/ +want to switch to a case-expression. For example, we do not want +to convert + case (eqFloat# x 3.8#) of + True -> this + False -> that +to + case x of + 3.8#::Float# -> this + _ -> that +See #9238. Reason: comparing floating-point values for equality +delicate, and we don't want to implement that delicacy in the code for +case expressions. So we make it an invariant of Core that a case +expression never scrutinises a Float# or Double#. + +This transformation is what the litEq rule does; +see Note [The litEq rule: converting equality to case]. +So we /refrain/ from using litEq for mkFloatingRelOpRule. +-} + +mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> Maybe CoreRule +-- See Note [Rules for floating-point comparisons] +mkFloatingRelOpRule nm cmp + = mkPrimOpRule nm 2 [binaryCmpLit cmp] + +-- common constants +zeroi, onei, zerow, onew :: Platform -> Literal +zeroi platform = mkLitInt platform 0 +onei platform = mkLitInt platform 1 +zerow platform = mkLitWord platform 0 +onew platform = mkLitWord platform 1 + +zerof, onef, twof, zerod, oned, twod :: Literal +zerof = mkLitFloat 0.0 +onef = mkLitFloat 1.0 +twof = mkLitFloat 2.0 +zerod = mkLitDouble 0.0 +oned = mkLitDouble 1.0 +twod = mkLitDouble 2.0 + +cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool) + -> Literal -> Literal -> Maybe CoreExpr +cmpOp platform cmp = go + where + done True = Just $ trueValInt platform + done False = Just $ falseValInt platform + + -- These compares are at different types + go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) + go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) + go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) + go (LitNumber nt1 i1) (LitNumber nt2 i2) + | nt1 /= nt2 = Nothing + | otherwise = done (i1 `cmp` i2) + go _ _ = Nothing + +-------------------------- + +negOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Negate +negOp env = \case + (LitFloat 0.0) -> Nothing -- can't represent -0.0 as a Rational + (LitFloat f) -> Just (mkFloatVal env (-f)) + (LitDouble 0.0) -> Nothing + (LitDouble d) -> Just (mkDoubleVal env (-d)) + (LitNumber nt i) + | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i))) + _ -> Nothing + +complementOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Binary complement +complementOp env (LitNumber nt i) = + Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i))) +complementOp _ _ = Nothing + +intOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOp2 = intOp2' . const + +intOp2' :: (Integral a, Integral b) + => (RuleOpts -> a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = + let o = op env + in intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2) +intOp2' _ _ _ _ = Nothing + +intOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = do + intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2) +intOpC2 _ _ _ _ = Nothing + +shiftRightLogical :: Platform -> Integer -> Int -> Integer +-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do +-- Do this by converting to Word and back. Obviously this won't work for big +-- values, but its ok as we use it here +shiftRightLogical platform x n = + case platformWordSize platform of + PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32) + PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64) + +-------------------------- +retLit :: (Platform -> Literal) -> RuleM CoreExpr +retLit l = do platform <- getPlatform + return $ Lit $ l platform + +retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr +retLitNoC l = do platform <- getPlatform + let lit = l platform + let ty = literalType lit + return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)] + +wordOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) + = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) +wordOp2 _ _ _ _ = Nothing + +wordOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) = + wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) +wordOpC2 _ _ _ _ = Nothing + +shiftRule :: LitNumType -- Type of the result, either LitNumInt or LitNumWord + -> (Platform -> Integer -> Int -> Integer) + -> RuleM CoreExpr +-- Shifts take an Int; hence third arg of op is Int +-- Used for shift primops +-- ISllOp, ISraOp, ISrlOp :: Int# -> Int# -> Int# +-- SllOp, SrlOp :: Word# -> Int# -> Word# +shiftRule lit_num_ty shift_op + = do { platform <- getPlatform + ; [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs + ; case e1 of + _ | shift_len == 0 + -> return e1 + -- See Note [Guarding against silly shifts] + | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform) + -> return $ Lit $ mkLitNumberWrap platform lit_num_ty 0 + -- Be sure to use lit_num_ty here, so we get a correctly typed zero + -- of type Int# or Word# resp. See #18589 + + -- Do the shift at type Integer, but shift length is Int + Lit (LitNumber nt x) + | 0 < shift_len + , shift_len <= toInteger (platformWordSizeInBits platform) + -> let op = shift_op platform + y = x `op` fromInteger shift_len + in liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y)) + + _ -> mzero } + +-------------------------- +floatOp2 :: (Rational -> Rational -> Rational) + -> RuleOpts -> Literal -> Literal + -> Maybe (Expr CoreBndr) +floatOp2 op env (LitFloat f1) (LitFloat f2) + = Just (mkFloatVal env (f1 `op` f2)) +floatOp2 _ _ _ _ = Nothing + +-------------------------- +floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr +floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e))) + = Just $ mkCoreUbxTup [intPrimTy, intPrimTy] + [ mkIntVal (roPlatform env) (toInteger m) + , mkIntVal (roPlatform env) (toInteger e) ] +floatDecodeOp _ _ + = Nothing + +-------------------------- +doubleOp2 :: (Rational -> Rational -> Rational) + -> RuleOpts -> Literal -> Literal + -> Maybe (Expr CoreBndr) +doubleOp2 op env (LitDouble f1) (LitDouble f2) + = Just (mkDoubleVal env (f1 `op` f2)) +doubleOp2 _ _ _ _ = Nothing + +-------------------------- +doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr +doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e))) + = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy] + [ Lit (mkLitINT64 (roPlatform env) (toInteger m)) + , mkIntVal platform (toInteger e) ] + where + platform = roPlatform env + (iNT64Ty, mkLitINT64) + | platformWordSizeInBits platform < 64 + = (int64PrimTy, mkLitInt64Wrap) + | otherwise + = (intPrimTy , mkLitIntWrap) +doubleDecodeOp _ _ + = Nothing + +-------------------------- +{- Note [The litEq rule: converting equality to case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This stuff turns + n ==# 3# +into + case n of + 3# -> True + m -> False + +This is a Good Thing, because it allows case-of case things +to happen, and case-default absorption to happen. For +example: + + if (n ==# 3#) || (n ==# 4#) then e1 else e2 +will transform to + case n of + 3# -> e1 + 4# -> e1 + m -> e2 +(modulo the usual precautions to avoid duplicating e1) +-} + +litEq :: Bool -- True <=> equality, False <=> inequality + -> RuleM CoreExpr +litEq is_eq = msum + [ do [Lit lit, expr] <- getArgs + platform <- getPlatform + do_lit_eq platform lit expr + , do [expr, Lit lit] <- getArgs + platform <- getPlatform + do_lit_eq platform lit expr ] + where + do_lit_eq platform lit expr = do + guard (not (litIsLifted lit)) + return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) + where + val_if_eq | is_eq = trueValInt platform + | otherwise = falseValInt platform + val_if_neq | is_eq = falseValInt platform + | otherwise = trueValInt platform + + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Comparison -> RuleM CoreExpr +boundsCmp op = do + platform <- getPlatform + [a, b] <- getArgs + liftMaybe $ mkRuleFn platform op a b + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn _ _ _ _ = Nothing + +isMinBound :: Platform -> Literal -> Bool +isMinBound _ (LitChar c) = c == minBound +isMinBound platform (LitNumber nt i) = case nt of + LitNumInt -> i == platformMinInt platform + LitNumInt64 -> i == toInteger (minBound :: Int64) + LitNumWord -> i == 0 + LitNumWord64 -> i == 0 + LitNumNatural -> i == 0 + LitNumInteger -> False +isMinBound _ _ = False + +isMaxBound :: Platform -> Literal -> Bool +isMaxBound _ (LitChar c) = c == maxBound +isMaxBound platform (LitNumber nt i) = case nt of + LitNumInt -> i == platformMaxInt platform + LitNumInt64 -> i == toInteger (maxBound :: Int64) + LitNumWord -> i == platformMaxWord platform + LitNumWord64 -> i == toInteger (maxBound :: Word64) + LitNumNatural -> False + LitNumInteger -> False +isMaxBound _ _ = False + +-- | Create an Int literal expression while ensuring the given Integer is in the +-- target Int range +intResult :: Platform -> Integer -> Maybe CoreExpr +intResult platform result = Just (intResult' platform result) + +intResult' :: Platform -> Integer -> CoreExpr +intResult' platform result = Lit (mkLitIntWrap platform result) + +-- | Create an unboxed pair of an Int literal expression, ensuring the given +-- Integer is in the target Int range and the corresponding overflow flag +-- (@0#@/@1#@) if it wasn't. +intCResult :: Platform -> Integer -> Maybe CoreExpr +intCResult platform result = Just (mkPair [Lit lit, Lit c]) + where + mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] + (lit, b) = mkLitIntWrapC platform result + c = if b then onei platform else zeroi platform + +-- | Create a Word literal expression while ensuring the given Integer is in the +-- target Word range +wordResult :: Platform -> Integer -> Maybe CoreExpr +wordResult platform result = Just (wordResult' platform result) + +wordResult' :: Platform -> Integer -> CoreExpr +wordResult' platform result = Lit (mkLitWordWrap platform result) + +-- | Create an unboxed pair of a Word literal expression, ensuring the given +-- Integer is in the target Word range and the corresponding carry flag +-- (@0#@/@1#@) if it wasn't. +wordCResult :: Platform -> Integer -> Maybe CoreExpr +wordCResult platform result = Just (mkPair [Lit lit, Lit c]) + where + mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] + (lit, b) = mkLitWordWrapC platform result + c = if b then onei platform else zeroi platform + +inversePrimOp :: PrimOp -> RuleM CoreExpr +inversePrimOp primop = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId primop primop_id + return e + +subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr +this `subsumesPrimOp` that = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId that primop_id + return (Var (mkPrimOpId this) `App` e) + +subsumedByPrimOp :: PrimOp -> RuleM CoreExpr +subsumedByPrimOp primop = do + [e@(Var primop_id `App` _)] <- getArgs + matchPrimOpId primop primop_id + return e + +-- | narrow subsumes bitwise `and` with full mask (cf #16402): +-- +-- narrowN (x .&. m) +-- m .&. (2^N-1) = 2^N-1 +-- ==> narrowN x +-- +-- e.g. narrow16 (x .&. 0xFFFF) +-- ==> narrow16 x +-- +narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr +narrowSubsumesAnd and_primop narrw n = do + [Var primop_id `App` x `App` y] <- getArgs + matchPrimOpId and_primop primop_id + let mask = bit n -1 + g v (Lit (LitNumber _ m)) = do + guard (m .&. mask == mask) + return (Var (mkPrimOpId narrw) `App` v) + g _ _ = mzero + g x y <|> g y x + +idempotent :: RuleM CoreExpr +idempotent = do [e1, e2] <- getArgs + guard $ cheapEqExpr e1 e2 + return e1 + +{- +Note [Guarding against silly shifts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + import Data.Bits( (.|.), shiftL ) + chunkToBitmap :: [Bool] -> Word32 + chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] + +This optimises to: +Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> + case w1_sCT of _ { + [] -> 0##; + : x_aAW xs_aAX -> + case x_aAW of _ { + GHC.Types.False -> + case w_sCS of wild2_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; + 9223372036854775807 -> 0## }; + GHC.Types.True -> + case GHC.Prim.>=# w_sCS 64 of _ { + GHC.Types.False -> + case w_sCS of wild3_Xh { + __DEFAULT -> + case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> + GHC.Prim.or# (GHC.Prim.narrow32Word# + (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) + ww_sCW + }; + 9223372036854775807 -> + GHC.Prim.narrow32Word# +!!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) + }; + GHC.Types.True -> + case w_sCS of wild3_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; + 9223372036854775807 -> 0## + } } } } + +Note the massive shift on line "!!!!". It can't happen, because we've checked +that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this! +Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we +can't constant fold it, but if it gets to the assembler we get + Error: operand type mismatch for `shl' + +So the best thing to do is to rewrite the shift with a call to error, +when the second arg is large. However, in general we cannot do this; consider +this case + + let x = I# (uncheckedIShiftL# n 80) + in ... + +Here x contains an invalid shift and consequently we would like to rewrite it +as follows: + + let x = I# (error "invalid shift) + in ... + +This was originally done in the fix to #16449 but this breaks the let/app +invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742. +For the reasons discussed in Note [Checking versus non-checking primops] (in +the PrimOp module) there is no safe way rewrite the argument of I# such that +it bottoms. + +Consequently we instead take advantage of the fact that large shifts are +undefined behavior (see associated documentation in primops.txt.pp) and +transform the invalid shift into an "obviously incorrect" value. + +There are two cases: + +- Shifting fixed-width things: the primops ISll, Sll, etc + These are handled by shiftRule. + + We are happy to shift by any amount up to wordSize but no more. + +- Shifting Bignums (Integer, Natural): these are handled by bignum_shift. + + Here we could in principle shift by any amount, but we arbitrary + limit the shift to 4 bits; in particular we do not want shift by a + huge amount, which can happen in code like that above. + +The two cases are more different in their code paths that is comfortable, +but that is only a historical accident. + + +************************************************************************ +* * +\subsection{Vaguely generic functions} +* * +************************************************************************ +-} + +mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +-- Gives the Rule the same name as the primop itself +mkBasicRule op_name n_args rm + = BuiltinRule { ru_name = occNameFS (nameOccName op_name), + ru_fn = op_name, + ru_nargs = n_args, + ru_try = runRuleM rm } + +newtype RuleM r = RuleM + { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } + deriving (Functor) + +instance Applicative RuleM where + pure x = RuleM $ \_ _ _ _ -> Just x + (<*>) = ap + +instance Monad RuleM where + RuleM f >>= g + = RuleM $ \env iu fn args -> + case f env iu fn args of + Nothing -> Nothing + Just r -> runRuleM (g r) env iu fn args + +instance MonadFail RuleM where + fail _ = mzero + +instance Alternative RuleM where + empty = RuleM $ \_ _ _ _ -> Nothing + RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args -> + f1 env iu fn args <|> f2 env iu fn args + +instance MonadPlus RuleM + +getPlatform :: RuleM Platform +getPlatform = roPlatform <$> getEnv + +getEnv :: RuleM RuleOpts +getEnv = RuleM $ \env _ _ _ -> Just env + +liftMaybe :: Maybe a -> RuleM a +liftMaybe Nothing = mzero +liftMaybe (Just x) = return x + +liftLit :: (Literal -> Literal) -> RuleM CoreExpr +liftLit f = liftLitPlatform (const f) + +liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr +liftLitPlatform f = do + platform <- getPlatform + [Lit lit] <- getArgs + return $ Lit (f platform lit) + +removeOp32 :: RuleM CoreExpr +removeOp32 = do + platform <- getPlatform + case platformWordSize platform of + PW4 -> do + [e] <- getArgs + return e + PW8 -> + mzero + +getArgs :: RuleM [CoreExpr] +getArgs = RuleM $ \_ _ _ args -> Just args + +getInScopeEnv :: RuleM InScopeEnv +getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu + +getFunction :: RuleM Id +getFunction = RuleM $ \_ _ fn _ -> Just fn + +isLiteral :: CoreExpr -> RuleM Literal +isLiteral e = do + env <- getInScopeEnv + case exprIsLiteral_maybe env e of + Nothing -> mzero + Just l -> pure l + +isNumberLiteral :: CoreExpr -> RuleM Integer +isNumberLiteral e = isLiteral e >>= \case + LitNumber _ x -> pure x + _ -> mzero + +isIntegerLiteral :: CoreExpr -> RuleM Integer +isIntegerLiteral e = isLiteral e >>= \case + LitNumber LitNumInteger x -> pure x + _ -> mzero + +isNaturalLiteral :: CoreExpr -> RuleM Integer +isNaturalLiteral e = isLiteral e >>= \case + LitNumber LitNumNatural x -> pure x + _ -> mzero + +isWordLiteral :: CoreExpr -> RuleM Integer +isWordLiteral e = isLiteral e >>= \case + LitNumber LitNumWord x -> pure x + _ -> mzero + +isIntLiteral :: CoreExpr -> RuleM Integer +isIntLiteral e = isLiteral e >>= \case + LitNumber LitNumInt x -> pure x + _ -> mzero + +-- return the n-th argument of this rule, if it is a literal +-- argument indices start from 0 +getLiteral :: Int -> RuleM Literal +getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of + (Lit l:_) -> Just l + _ -> Nothing + +unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit op = do + env <- getEnv + [Lit l] <- getArgs + liftMaybe $ op env (convFloating env l) + +binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit op = do + env <- getEnv + [Lit l1, Lit l2] <- getArgs + liftMaybe $ op env (convFloating env l1) (convFloating env l2) + +binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr +binaryCmpLit op = do + platform <- getPlatform + binaryLit (\_ -> cmpOp platform op) + +leftIdentity :: Literal -> RuleM CoreExpr +leftIdentity id_lit = leftIdentityPlatform (const id_lit) + +rightIdentity :: Literal -> RuleM CoreExpr +rightIdentity id_lit = rightIdentityPlatform (const id_lit) + +identity :: Literal -> RuleM CoreExpr +identity lit = leftIdentity lit `mplus` rightIdentity lit + +leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityPlatform id_lit = do + platform <- getPlatform + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit platform + return e2 + +-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in +-- addition to the result, we have to indicate that no carry/overflow occurred. +leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityCPlatform id_lit = do + platform <- getPlatform + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit platform + let no_c = Lit (zeroi platform) + return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) + +rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityPlatform id_lit = do + platform <- getPlatform + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit platform + return e1 + +-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in +-- addition to the result, we have to indicate that no carry/overflow occurred. +rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityCPlatform id_lit = do + platform <- getPlatform + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit platform + let no_c = Lit (zeroi platform) + return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) + +identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityPlatform lit = + leftIdentityPlatform lit `mplus` rightIdentityPlatform lit + +-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition +-- to the result, we have to indicate that no carry/overflow occurred. +identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityCPlatform lit = + leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit + +leftZero :: (Platform -> Literal) -> RuleM CoreExpr +leftZero zero = do + platform <- getPlatform + [Lit l1, _] <- getArgs + guard $ l1 == zero platform + return $ Lit l1 + +rightZero :: (Platform -> Literal) -> RuleM CoreExpr +rightZero zero = do + platform <- getPlatform + [_, Lit l2] <- getArgs + guard $ l2 == zero platform + return $ Lit l2 + +zeroElem :: (Platform -> Literal) -> RuleM CoreExpr +zeroElem lit = leftZero lit `mplus` rightZero lit + +equalArgs :: RuleM () +equalArgs = do + [e1, e2] <- getArgs + guard $ e1 `cheapEqExpr` e2 + +nonZeroLit :: Int -> RuleM () +nonZeroLit n = getLiteral n >>= guard . not . isZeroLit + +-- When excess precision is not requested, cut down the precision of the +-- Rational value to that of Float/Double. We confuse host architecture +-- and target architecture here, but it's convenient (and wrong :-). +convFloating :: RuleOpts -> Literal -> Literal +convFloating env (LitFloat f) | not (roExcessRationalPrecision env) = + LitFloat (toRational (fromRational f :: Float )) +convFloating env (LitDouble d) | not (roExcessRationalPrecision env) = + LitDouble (toRational (fromRational d :: Double)) +convFloating _ l = l + +guardFloatDiv :: RuleM () +guardFloatDiv = do + [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs + guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + +guardDoubleDiv :: RuleM () +guardDoubleDiv = do + [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs + guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] + && d2 /= 0 -- avoid NaN and Infinity/-Infinity +-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to +-- zero, but we might want to preserve the negative zero here which +-- is representable in Float/Double but not in (normalised) +-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? + +strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr +strengthReduction two_lit add_op = do -- Note [Strength reduction] + arg <- msum [ do [arg, Lit mult_lit] <- getArgs + guard (mult_lit == two_lit) + return arg + , do [Lit mult_lit, arg] <- getArgs + guard (mult_lit == two_lit) + return arg ] + return $ Var (mkPrimOpId add_op) `App` arg `App` arg + +-- Note [Strength reduction] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This rule turns floating point multiplications of the form 2.0 * x and +-- x * 2.0 into x + x addition, because addition costs less than multiplication. +-- See #7116 + +-- Note [What's true and false] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- trueValInt and falseValInt represent true and false values returned by +-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. +-- True is represented as an unboxed 1# literal, while false is represented +-- as 0# literal. +-- We still need Bool data constructors (True and False) to use in a rule +-- for constant folding of equal Strings + +trueValInt, falseValInt :: Platform -> Expr CoreBndr +trueValInt platform = Lit $ onei platform -- see Note [What's true and false] +falseValInt platform = Lit $ zeroi platform + +trueValBool, falseValBool :: Expr CoreBndr +trueValBool = Var trueDataConId -- see Note [What's true and false] +falseValBool = Var falseDataConId + +ltVal, eqVal, gtVal :: Expr CoreBndr +ltVal = Var ordLTDataConId +eqVal = Var ordEQDataConId +gtVal = Var ordGTDataConId + +mkIntVal :: Platform -> Integer -> Expr CoreBndr +mkIntVal platform i = Lit (mkLitInt platform i) +mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr +mkFloatVal env f = Lit (convFloating env (LitFloat f)) +mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr +mkDoubleVal env d = Lit (convFloating env (LitDouble d)) + +matchPrimOpId :: PrimOp -> Id -> RuleM () +matchPrimOpId op id = do + op' <- liftMaybe $ isPrimOpId_maybe id + guard $ op == op' + +{- +************************************************************************ +* * +\subsection{Special rules for seq, tagToEnum, dataToTag} +* * +************************************************************************ + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude but it works. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +We used to make this check in the type inference engine, but it's quite +ugly to do so, because the delayed constraint solving means that we don't +really know what's going on until the end. It's very much a corner case +because we don't expect the user to call tagToEnum# at all; we merely +generate calls in derived instances of Enum. So we compromise: a +rewrite rule rewrites a bad instance of tagToEnum# to an error call, +and emits a warning. +-} + +tagToEnumRule :: RuleM CoreExpr +-- If data T a = A | B | C +-- then tagToEnum# (T ty) 2# --> B ty +tagToEnumRule = do + [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs + case splitTyConApp_maybe ty of + Just (tycon, tc_args) | isEnumerationTyCon tycon -> do + let tag = fromInteger i + correct_tag dc = (dataConTagZ dc) == tag + (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) + ASSERT(null rest) return () + return $ mkTyApps (Var (dataConWorkId dc)) tc_args + + -- See Note [tagToEnum#] + _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) + return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" + +------------------------------ +dataToTagRule :: RuleM CoreExpr +-- See Note [dataToTag#] in primops.txt.pp +dataToTagRule = a `mplus` b + where + -- dataToTag (tagToEnum x) ==> x + a = do + [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs + guard $ tag_to_enum `hasKey` tagToEnumKey + guard $ ty1 `eqType` ty2 + return tag + + -- dataToTag (K e1 e2) ==> tag-of K + -- This also works (via exprIsConApp_maybe) for + -- dataToTag x + -- where x's unfolding is a constructor application + b = do + dflags <- getPlatform + [_, val_arg] <- getArgs + in_scope <- getInScopeEnv + (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg + ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () + return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) + +{- Note [dataToTag# magic] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The primop dataToTag# is unusual because it evaluates its argument. +Only `SeqOp` shares that property. (Other primops do not do anything +as fancy as argument evaluation.) The special handling for dataToTag# +is: + +* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp, + (actually in app_ok). Most primops with lifted arguments do not + evaluate those arguments, but DataToTagOp and SeqOp are two + exceptions. We say that they are /never/ ok-for-speculation, + regardless of the evaluated-ness of their argument. + See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp] + +* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr, + that evaluates its argument and then extracts the tag from + the returned value. + +* An application like (dataToTag# (Just x)) is optimised by + dataToTagRule in GHC.Core.Opt.ConstantFold. + +* A case expression like + case (dataToTag# e) of + gets transformed t + case e of + by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag] + +See #15696 for a long saga. +-} + +{- ********************************************************************* +* * + unsafeEqualityProof +* * +********************************************************************* -} + +-- unsafeEqualityProof k t t ==> UnsafeRefl (Refl t) +-- That is, if the two types are equal, it's not unsafe! + +unsafeEqualityProofRule :: RuleM CoreExpr +unsafeEqualityProofRule + = do { [Type rep, Type t1, Type t2] <- getArgs + ; guard (t1 `eqType` t2) + ; fn <- getFunction + ; let (_, ue) = splitForAllTys (idType fn) + tc = tyConAppTyCon ue -- tycon: UnsafeEquality + (dc:_) = tyConDataCons tc -- data con: UnsafeRefl + -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r). + -- UnsafeEquality r a a + ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) } + + +{- ********************************************************************* +* * + Rules for seq# and spark# +* * +********************************************************************* -} + +{- Note [seq# magic] +~~~~~~~~~~~~~~~~~~~~ +The primop + seq# :: forall a s . a -> State# s -> (# State# s, a #) + +is /not/ the same as the Prelude function seq :: a -> b -> b +as you can see from its type. In fact, seq# is the implementation +mechanism for 'evaluate' + + evaluate :: a -> IO a + evaluate a = IO $ \s -> seq# a s + +The semantics of seq# is + * evaluate its first argument + * and return it + +Things to note + +* Why do we need a primop at all? That is, instead of + case seq# x s of (# x, s #) -> blah + why not instead say this? + case x of { DEFAULT -> blah) + + Reason (see #5129): if we saw + catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler + + then we'd drop the 'case x' because the body of the case is bottom + anyway. But we don't want to do that; the whole /point/ of + seq#/evaluate is to evaluate 'x' first in the IO monad. + + In short, we /always/ evaluate the first argument and never + just discard it. + +* Why return the value? So that we can control sharing of seq'd + values: in + let x = e in x `seq` ... x ... + We don't want to inline x, so better to represent it as + let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + also it matches the type of rseq in the Eval monad. + +Implementing seq#. The compiler has magic for SeqOp in + +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) + +- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# + +- GHC.Core.Utils.exprOkForSpeculation; + see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils + +- Simplify.addEvals records evaluated-ness for the result; see + Note [Adding evaluatedness info to pattern-bound variables] + in GHC.Core.Opt.Simplify +-} + +seqRule :: RuleM CoreExpr +seqRule = do + [Type ty_a, Type _ty_s, a, s] <- getArgs + guard $ exprIsHNF a + return $ mkCoreUbxTup [exprType s, ty_a] [s, a] + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: RuleM CoreExpr +sparkRule = seqRule -- reduce on HNF, just the same + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? + +{- +************************************************************************ +* * +\subsection{Built in rules} +* * +************************************************************************ + +Note [Scoping for Builtin rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling a (base-package) module that defines one of the +functions mentioned in the RHS of a built-in rule, there's a danger +that we'll see + + f = ...(eq String x).... + + ....and lower down... + + eqString = ... + +Then a rewrite would give + + f = ...(eqString x)... + ....and lower down... + eqString = ... + +and lo, eqString is not in scope. This only really matters when we +get to code generation. But the occurrence analyser does a GlomBinds +step when necessary, that does a new SCC analysis on the whole set of +bindings (see occurAnalysePgm), which sorts out the dependency, so all +is fine. +-} + +newtype EnableBignumRules = EnableBignumRules Bool + +builtinRules :: EnableBignumRules -> [CoreRule] +-- Rules for non-primops that can't be expressed using a RULE pragma +builtinRules enableBignumRules + = [BuiltinRule { ru_name = fsLit "AppendLitString", + ru_fn = unpackCStringFoldrName, + ru_nargs = 4, ru_try = match_append_lit_C }, + BuiltinRule { ru_name = fsLit "AppendLitStringUtf8", + ru_fn = unpackCStringFoldrUtf8Name, + ru_nargs = 4, ru_try = match_append_lit_utf8 }, + BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, + ru_nargs = 2, ru_try = match_eq_string }, + BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, + ru_nargs = 1, ru_try = match_cstring_length }, + BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, + ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, + BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, + ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }, + + mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, + + mkBasicRule divIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 div) + , leftZero zeroi + , do + [arg, Lit (LitNumber LitNumInt d)] <- getArgs + Just n <- return $ exactLog2 d + platform <- getPlatform + return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal platform n + ], + + mkBasicRule modIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 mod) + , leftZero zeroi + , do + [arg, Lit (LitNumber LitNumInt d)] <- getArgs + Just _ <- return $ exactLog2 d + platform <- getPlatform + return $ Var (mkPrimOpId AndIOp) + `App` arg `App` mkIntVal platform (d - 1) + ] + ] + ++ builtinBignumRules enableBignumRules +{-# NOINLINE builtinRules #-} +-- there is no benefit to inlining these yet, despite this, GHC produces +-- unfoldings for this regardless since the floated list entries look small. + +builtinBignumRules :: EnableBignumRules -> [CoreRule] +builtinBignumRules (EnableBignumRules False) = [] +builtinBignumRules _ = + [ -- conversions + lit_to_integer "Word# -> Integer" integerFromWordName + , lit_to_integer "Int64# -> Integer" integerFromInt64Name + , lit_to_integer "Word64# -> Integer" integerFromWord64Name + , lit_to_integer "Natural -> Integer" integerFromNaturalName + + , integer_to_lit "Integer -> Word# (wrap)" integerToWordName mkWordLitWrap + , integer_to_lit "Integer -> Int# (wrap)" integerToIntName mkIntLitWrap + , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger) + , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger) + , integer_to_lit "Integer -> Float#" integerToFloatName (\_ -> mkFloatLitFloat . fromInteger) + , integer_to_lit "Integer -> Double#" integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger) + + , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True + , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False + , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False + + , lit_to_natural "Word# -> Natural" naturalNSName + , natural_to_word "Natural -> Word# (wrap)" naturalToWordName False + , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True + + -- comparisons (return an unlifted Int#) + , integer_cmp "integerEq#" integerEqName (==) + , integer_cmp "integerNe#" integerNeName (/=) + , integer_cmp "integerLe#" integerLeName (<=) + , integer_cmp "integerGt#" integerGtName (>) + , integer_cmp "integerLt#" integerLtName (<) + , integer_cmp "integerGe#" integerGeName (>=) + + , natural_cmp "naturalEq#" naturalEqName (==) + , natural_cmp "naturalNe#" naturalNeName (/=) + , natural_cmp "naturalLe#" naturalLeName (<=) + , natural_cmp "naturalGt#" naturalGtName (>) + , natural_cmp "naturalLt#" naturalLtName (<) + , natural_cmp "naturalGe#" naturalGeName (>=) + + -- comparisons (return an Ordering) + , bignum_compare "integerCompare" integerCompareName + , bignum_compare "naturalCompare" naturalCompareName + + -- binary operations + , integer_binop "integerAdd" integerAddName (+) + , integer_binop "integerSub" integerSubName (-) + , integer_binop "integerMul" integerMulName (*) + , integer_binop "integerGcd" integerGcdName gcd + , integer_binop "integerLcm" integerLcmName lcm + , integer_binop "integerAnd" integerAndName (.&.) + , integer_binop "integerOr" integerOrName (.|.) + , integer_binop "integerXor" integerXorName xor + + , natural_binop "naturalAdd" naturalAddName (+) + , natural_binop "naturalMul" naturalMulName (*) + , natural_binop "naturalGcd" naturalGcdName gcd + , natural_binop "naturalLcm" naturalLcmName lcm + , natural_binop "naturalAnd" naturalAndName (.&.) + , natural_binop "naturalOr" naturalOrName (.|.) + , natural_binop "naturalXor" naturalXorName xor + + -- Natural subtraction: it's a binop but it can fail because of underflow so + -- we have several primitives to handle here. + , natural_sub "naturalSubUnsafe" naturalSubUnsafeName + , natural_sub "naturalSubThrow" naturalSubThrowName + , mkRule "naturalSub" naturalSubName 2 $ do + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + -- return an unboxed sum: (# (# #) | Natural #) + let ret n v = pure $ mkCoreUbxSum 2 n [voidPrimTy,naturalTy] v + if x < y + then ret 1 $ Var voidPrimId + else ret 2 $ Lit (mkLitNatural (x - y)) + + -- unary operations + , bignum_unop "integerNegate" integerNegateName mkLitInteger negate + , bignum_unop "integerAbs" integerAbsName mkLitInteger abs + , bignum_unop "integerSignum" integerSignumName mkLitInteger signum + , bignum_unop "integerComplement" integerComplementName mkLitInteger complement + + , bignum_unop "naturalSignum" naturalSignumName mkLitNatural signum + + , mkRule "naturalNegate" naturalNegateName 1 $ do + [a0] <- getArgs + x <- isNaturalLiteral a0 + guard (x == 0) -- negate is only valid for (0 :: Natural) + pure a0 + + , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap + , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap + + -- identity passthrough + , id_passthrough "Int# -> Integer -> Int#" integerToIntName integerISName + , id_passthrough "Word# -> Integer -> Word#" integerToWordName integerFromWordName + , id_passthrough "Int64# -> Integer -> Int64#" integerToInt64Name integerFromInt64Name + , id_passthrough "Word64# -> Integer -> Word64#" integerToWord64Name integerFromWord64Name + , id_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSName + + -- identity passthrough with a conversion that can be done directly instead + , small_passthrough "Int# -> Integer -> Word#" + integerISName integerToWordName (mkPrimOpId Int2WordOp) + , small_passthrough "Int# -> Integer -> Float#" + integerISName integerToFloatName (mkPrimOpId Int2FloatOp) + , small_passthrough "Int# -> Integer -> Double#" + integerISName integerToDoubleName (mkPrimOpId Int2DoubleOp) + , small_passthrough "Word# -> Natural -> Int#" + naturalNSName naturalToWordName (mkPrimOpId Word2IntOp) + + -- Bits.bit + , bignum_bit "integerBit" integerBitName mkLitInteger + , bignum_bit "naturalBit" naturalBitName mkLitNatural + + -- Bits.testBit + , bignum_testbit "integerTestBit" integerTestBitName + , bignum_testbit "naturalTestBit" naturalTestBitName + + -- Bits.shift + , bignum_shift "integerShiftL" integerShiftLName shiftL mkLitInteger + , bignum_shift "integerShiftR" integerShiftRName shiftR mkLitInteger + , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkLitNatural + , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkLitNatural + + -- division + , divop_one "integerQuot" integerQuotName quot mkLitInteger + , divop_one "integerRem" integerRemName rem mkLitInteger + , divop_one "integerDiv" integerDivName div mkLitInteger + , divop_one "integerMod" integerModName mod mkLitInteger + , divop_both "integerDivMod" integerDivModName divMod mkLitInteger integerTy + , divop_both "integerQuotRem" integerQuotRemName quotRem mkLitInteger integerTy + + , divop_one "naturalQuot" naturalQuotName quot mkLitNatural + , divop_one "naturalRem" naturalRemName rem mkLitNatural + , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkLitNatural naturalTy + + -- conversions from Rational for Float/Double literals + , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr + , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr + + -- conversions from Integer for Float/Double literals + , integer_encode_float "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat + , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble + ] + where + -- The rule is matching against an occurrence of a data constructor in a + -- Core expression. It must match either its worker name or its wrapper + -- name, /not/ the DataCon name itself, which is different. + -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892 + -- + -- But data constructor wrappers deliberately inline late; See Note + -- [Activation for data constructor wrappers] in GHC.Types.Id.Make. + -- Suppose there is a wrapper and the rule matches on the worker: the + -- wrapper won't be inlined until rules have finished firing and the rule + -- will never fire. + -- + -- Hence the rule must match on the wrapper, if there is one, otherwise on + -- the worker. That is exactly the dataConWrapId for the data constructor. + -- The data constructor may or may not have a wrapper, but if not + -- dataConWrapId will return the worker + -- + integerISName = idName (dataConWrapId integerISDataCon) + naturalNSName = idName (dataConWrapId naturalNSDataCon) + + mkRule str name nargs f = BuiltinRule + { ru_name = fsLit str + , ru_fn = name + , ru_nargs = nargs + , ru_try = runRuleM f + } + + integer_to_lit str name convert = mkRule str name 1 $ do + [a0] <- getArgs + platform <- getPlatform + x <- isIntegerLiteral a0 + pure (convert platform x) + + natural_to_word str name clamp = mkRule str name 1 $ do + [a0] <- getArgs + n <- isNaturalLiteral a0 + platform <- getPlatform + if clamp && not (platformInWordRange platform n) + then pure (Lit (mkLitWord platform (platformMaxWord platform))) + else pure (Lit (mkLitWordWrap platform n)) + + integer_to_natural str name thrw clamp = mkRule str name 1 $ do + [a0] <- getArgs + x <- isIntegerLiteral a0 + if | x >= 0 -> pure $ Lit $ mkLitNatural x + | thrw -> mzero + | clamp -> pure $ Lit $ mkLitNatural 0 -- clamp to 0 + | otherwise -> pure $ Lit $ mkLitNatural (abs x) -- negate/wrap + + lit_to_integer str name = mkRule str name 1 $ do + [a0] <- getArgs + isLiteral a0 >>= \case + -- convert any numeric literal into an Integer literal + LitNumber _ i -> pure (Lit (mkLitInteger i)) + _ -> mzero + + lit_to_natural str name = mkRule str name 1 $ do + [a0] <- getArgs + isLiteral a0 >>= \case + -- convert any *positive* numeric literal into a Natural literal + LitNumber _ i | i >= 0 -> pure (Lit (mkLitNatural i)) + _ -> mzero + + integer_binop str name op = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isIntegerLiteral a0 + y <- isIntegerLiteral a1 + pure (Lit (mkLitInteger (x `op` y))) + + natural_binop str name op = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + pure (Lit (mkLitNatural (x `op` y))) + + natural_sub str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + guard (x >= y) + pure (Lit (mkLitNatural (x - y))) + + integer_cmp str name op = mkRule str name 2 $ do + platform <- getPlatform + [a0,a1] <- getArgs + x <- isIntegerLiteral a0 + y <- isIntegerLiteral a1 + pure $ if x `op` y + then trueValInt platform + else falseValInt platform + + natural_cmp str name op = mkRule str name 2 $ do + platform <- getPlatform + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + pure $ if x `op` y + then trueValInt platform + else falseValInt platform + + bignum_compare str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNumberLiteral a0 + y <- isNumberLiteral a1 + pure $ case x `compare` y of + LT -> ltVal + EQ -> eqVal + GT -> gtVal + + bignum_unop str name mk_lit op = mkRule str name 1 $ do + [a0] <- getArgs + x <- isNumberLiteral a0 + pure $ Lit (mk_lit (op x)) + + bignum_popcount str name mk_lit = mkRule str name 1 $ do + platform <- getPlatform + -- We use a host Int to compute the popCount. If we compile on a 32-bit + -- host for a 64-bit target, the result may be different than if computed + -- by the target. So we disable this rule if sizes don't match. + guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word)) + [a0] <- getArgs + x <- isNumberLiteral a0 + pure $ Lit (mk_lit platform (fromIntegral (popCount x))) + + id_passthrough str to_x from_x = mkRule str to_x 1 $ do + [App (Var f) x] <- getArgs + guard (idName f == from_x) + pure x + + small_passthrough str from_x to_y x_to_y = mkRule str to_y 1 $ do + [App (Var f) x] <- getArgs + guard (idName f == from_x) + pure $ App (Var x_to_y) x + + bignum_bit str name mk_lit = mkRule str name 1 $ do + [a0] <- getArgs + platform <- getPlatform + n <- isNumberLiteral a0 + -- Make sure n is positive and small enough to yield a decently + -- small number. Attempting to construct the Integer for + -- (integerBit 9223372036854775807#) + -- would be a bad idea (#14959) + guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform)) + -- it's safe to convert a target Int value into a host Int value + -- to perform the "bit" operation because n is very small (<= 64). + pure $ Lit (mk_lit (bit (fromIntegral n))) + + bignum_testbit str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + platform <- getPlatform + x <- isNumberLiteral a0 + n <- isNumberLiteral a1 + -- ensure that we can store 'n' in a host Int + guard (n >= 0 && n <= fromIntegral (maxBound :: Int)) + pure $ if testBit x (fromIntegral n) + then trueValInt platform + else falseValInt platform + + bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNumberLiteral a0 + n <- isWordLiteral a1 + -- See Note [Guarding against silly shifts] + -- Restrict constant-folding of shifts on Integers, somewhat arbitrary. + -- We can get huge shifts in inaccessible code (#15673) + guard (n <= 4) + pure $ Lit (mk_lit (x `shift_op` fromIntegral n)) + + divop_one str name divop mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + n <- isNumberLiteral a0 + d <- isNumberLiteral a1 + guard (d /= 0) + pure $ Lit (mk_lit (n `divop` d)) + + divop_both str name divop mk_lit ty = mkRule str name 2 $ do + [a0,a1] <- getArgs + n <- isNumberLiteral a0 + d <- isNumberLiteral a1 + guard (d /= 0) + let (r,s) = n `divop` d + pure $ mkCoreUbxTup [ty,ty] [Lit (mk_lit r), Lit (mk_lit s)] + + integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule + integer_encode_float str name mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isIntegerLiteral a0 + y <- isIntLiteral a1 + -- check that y (a target Int) is in the host Int range + guard (y <= fromIntegral (maxBound :: Int)) + pure (mk_lit $ encodeFloat x (fromInteger y)) + + rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule + rational_to str name mk_lit = mkRule str name 2 $ do + -- This turns `rationalToFloat n d` where `n` and `d` are literals into + -- a literal Float (and similarly for Double). + [a0,a1] <- getArgs + n <- isIntegerLiteral a0 + d <- isIntegerLiteral a1 + -- it's important to not match d == 0, because that may represent a + -- literal "0/0" or similar, and we can't produce a literal value for + -- NaN or +-Inf + guard (d /= 0) + pure $ mk_lit (fromRational (n % d)) + + +--------------------------------------------------- +-- The rule is this: +-- unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n) +-- = unpackFoldrCString*# "foobaz"# c n +-- +-- See also Note [String literals in GHC] in CString.hs + +-- CString version +match_append_lit_C :: RuleFun +match_append_lit_C = match_append_lit unpackCStringFoldrIdKey + +-- CStringUTF8 version +match_append_lit_utf8 :: RuleFun +match_append_lit_utf8 = match_append_lit unpackCStringFoldrUtf8IdKey + +{-# INLINE match_append_lit #-} +match_append_lit :: Unique -> RuleFun +match_append_lit foldVariant _ id_unf _ + [ Type ty1 + , lit1 + , c1 + , e2 + ] + -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the + -- `lit` and `c` arguments, lest this may fail to fire when building with + -- -g3. See #16740. + | (strTicks, Var unpk `App` Type ty2 + `App` lit2 + `App` c2 + `App` n) <- stripTicksTop tickishFloatable e2 + , unpk `hasKey` foldVariant + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 + , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2)) + in eqExpr freeVars c1 c2 + , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 + , c2Ticks <- stripTicksTopT tickishFloatable c2 + = ASSERT( ty1 `eqType` ty2 ) + Just $ mkTicks strTicks + $ Var unpk `App` Type ty1 + `App` Lit (LitString (s1 `BS.append` s2)) + `App` mkTicks (c1Ticks ++ c2Ticks) c1' + `App` n + +match_append_lit _ _ _ _ _ = Nothing + +--------------------------------------------------- +-- The rule is this: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 +-- Also matches unpackCStringUtf8# + +match_eq_string :: RuleFun +match_eq_string _ id_unf _ + [Var unpk1 `App` lit1, Var unpk2 `App` lit2] + | unpk_key1 <- getUnique unpk1 + , unpk_key2 <- getUnique unpk2 + , unpk_key1 == unpk_key2 + -- For now we insist the literals have to agree in their encoding + -- to keep the rule simple. But we could check if the decoded strings + -- compare equal in here as well. + , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey] + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 + = Just (if s1 == s2 then trueValBool else falseValBool) + +match_eq_string _ _ _ _ = Nothing + +----------------------------------------------------------------------- +-- Illustration of this rule: +-- +-- cstringLength# "foobar"# --> 6 +-- cstringLength# "fizz\NULzz"# --> 4 +-- +-- Nota bene: Addr# literals are suffixed by a NUL byte when they are +-- compiled to read-only data sections. That's why cstringLength# is +-- well defined on Addr# literals that do not explicitly have an embedded +-- NUL byte. +-- +-- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly +-- helpful when using OverloadedStrings to create a ByteString since the +-- function computing the length of such ByteStrings can often be constant +-- folded. +match_cstring_length :: RuleFun +match_cstring_length env id_unf _ [lit1] + | Just (LitString str) <- exprIsLiteral_maybe id_unf lit1 + -- If elemIndex returns Just, it has the index of the first embedded NUL + -- in the string. If no NUL bytes are present (the common case) then use + -- full length of the byte string. + = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str) + in Just (Lit (mkLitInt (roPlatform env) (fromIntegral len))) +match_cstring_length _ _ _ _ = Nothing + +--------------------------------------------------- +{- Note [inlineId magic] +~~~~~~~~~~~~~~~~~~~~~~~~ +The call 'inline f' arranges that 'f' is inlined, regardless of +its size. More precisely, the call 'inline f' rewrites to the +right-hand side of 'f's definition. This allows the programmer to +control inlining from a particular call site rather than the +definition site of the function. + +The moving parts are simple: + +* A very simple definition in the library base:GHC.Magic + {-# NOINLINE[0] inline #-} + inline :: a -> a + inline x = x + So in phase 0, 'inline' will be inlined, so its use imposes + no overhead. + +* A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes + (inline f) inline, implemented by match_inline. + The rule for the 'inline' function is this: + inline f_ty (f a b c) = a b c + (if f has an unfolding, EVEN if it's a loop breaker) + + It's important to allow the argument to 'inline' to have args itself + (a) because its more forgiving to allow the programmer to write + either inline f a b c + or inline (f a b c) + (b) because a polymorphic f wll get a type argument that the + programmer can't avoid, so the call may look like + inline (map @Int @Bool) g xs + + Also, don't forget about 'inline's type argument! +-} + +match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline (Type _ : e : _) + | (Var f, args1) <- collectArgs e, + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! + = Just (mkApps unf args1) + +match_inline _ = Nothing + +--------------------------------------------------- +-- See Note [magicDictId magic] in "GHC.Types.Id.Make" +-- for a description of what is going on here. +match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_magicDict [Type _, (stripTicksE (const True) -> (Var wrap `App` Type a `App` Type _ `App` f)), x, y ] + | Just (_, fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap + , Just (_, dictTy, _) <- splitFunTy_maybe fieldTy + , Just dictTc <- tyConAppTyCon_maybe dictTy + , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc + = Just + $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) + `App` y + +match_magicDict _ = Nothing + +-------------------------------------------------------- +-- Note [Constant folding through nested expressions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We use rewrites rules to perform constant folding. It means that we don't +-- have a global view of the expression we are trying to optimise. As a +-- consequence we only perform local (small-step) transformations that either: +-- 1) reduce the number of operations +-- 2) rearrange the expression to increase the odds that other rules will +-- match +-- +-- We don't try to handle more complex expression optimisation cases that would +-- require a global view. For example, rewriting expressions to increase +-- sharing (e.g., Horner's method); optimisations that require local +-- transformations increasing the number of operations; rearrangements to +-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). +-- +-- We already have rules to perform constant folding on expressions with the +-- following shape (where a and/or b are literals): +-- +-- D) op +-- /\ +-- / \ +-- / \ +-- a b +-- +-- To support nested expressions, we match three other shapes of expression +-- trees: +-- +-- A) op1 B) op1 C) op1 +-- /\ /\ /\ +-- / \ / \ / \ +-- / \ / \ / \ +-- a op2 op2 c op2 op3 +-- /\ /\ /\ /\ +-- / \ / \ / \ / \ +-- b c a b a b c d +-- +-- +-- R1) +/- simplification: +-- ops = + or -, two literals (not siblings) +-- +-- Examples: +-- A: 5 + (10-x) ==> 15-x +-- B: (10+x) + 5 ==> 15+x +-- C: (5+a)-(5-b) ==> 0+(a+b) +-- +-- R2) * simplification +-- ops = *, two literals (not siblings) +-- +-- Examples: +-- A: 5 * (10*x) ==> 50*x +-- B: (10*x) * 5 ==> 50*x +-- C: (5*a)*(5*b) ==> 25*(a*b) +-- +-- R3) * distribution over +/- +-- op1 = *, op2 = + or -, two literals (not siblings) +-- +-- This transformation doesn't reduce the number of operations but switches +-- the outer and the inner operations so that the outer is (+) or (-) instead +-- of (*). It increases the odds that other rules will match after this one. +-- +-- Examples: +-- A: 5 * (10-x) ==> 50 - (5*x) +-- B: (10+x) * 5 ==> 50 + (5*x) +-- C: Not supported as it would increase the number of operations: +-- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b +-- +-- R4) Simple factorization +-- +-- op1 = + or -, op2/op3 = *, +-- one literal for each innermost * operation (except in the D case), +-- the two other terms are equals +-- +-- Examples: +-- A: x - (10*x) ==> (-9)*x +-- B: (10*x) + x ==> 11*x +-- C: (5*x)-(x*3) ==> 2*x +-- D: x+x ==> 2*x +-- +-- R5) +/- propagation +-- +-- ops = + or -, one literal +-- +-- This transformation doesn't reduce the number of operations but propagates +-- the constant to the outer level. It increases the odds that other rules +-- will match after this one. +-- +-- Examples: +-- A: x - (10-y) ==> (x+y) - 10 +-- B: (10+x) - y ==> 10 + (x-y) +-- C: N/A (caught by the A and B cases) +-- +-------------------------------------------------------- + +-- | Rules to perform constant folding into nested expressions +-- +--See Note [Constant folding through nested expressions] +numFoldingRules :: PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr +numFoldingRules op dict = do + env <- getEnv + if not (roNumConstantFolding env) + then mzero + else do + [e1,e2] <- getArgs + platform <- getPlatform + let PrimOps{..} = dict platform + case BinOpApp e1 op e2 of + -- R1) +/- simplification + x :++: (y :++: v) -> return $ mkL (x+y) `add` v + x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v + x :++: (v :-: L y) -> return $ mkL (x-y) `add` v + L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v + L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v + L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v + + (y :++: v) :-: L x -> return $ mkL (y-x) `add` v + (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v + (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v + + (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v) + (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v) + (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v) + (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v) + (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w) + (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v) + (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w) + (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v) + (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w) + + (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w) + (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w) + (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w) + (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v) + (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v) + (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v) + (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w) + (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w) + (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w) + + -- R2) * simplification + x :**: (y :**: v) -> return $ mkL (x*y) `mul` v + (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) + + -- R3) * distribution over +/- + x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v) + x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v) + x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y) + + -- R4) Simple factorization + v :+: w + | w `cheapEqExpr` v -> return $ mkL 2 `mul` v + w :+: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v + w :-: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v + (y :**: v) :+: w + | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v + (y :**: v) :-: w + | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v + (x :**: w) :+: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v + (x :**: w) :-: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v + + -- R5) +/- propagation + w :+: (y :++: v) -> return $ mkL y `add` (w `add` v) + (y :++: v) :+: w -> return $ mkL y `add` (w `add` v) + w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y + (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w) + w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y + (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v) + w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v) + w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y + (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v) + (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y + + _ -> mzero + + + +-- | Match the application of a binary primop +pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr +pattern BinOpApp x op y = OpVal op `App` x `App` y + +-- | Match a primop +pattern OpVal :: PrimOp -> Arg CoreBndr +pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where + OpVal op = Var (mkPrimOpId op) + + + +-- | Match a literal +pattern L :: Integer -> Arg CoreBndr +pattern L l <- Lit (isLitValue_maybe -> Just l) + +-- | Match an addition +pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :+: y <- BinOpApp x (isAddOp -> True) y + +-- | Match an addition with a literal (handle commutativity) +pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr +pattern l :++: x <- (isAdd -> Just (l,x)) + +isAdd :: CoreExpr -> Maybe (Integer,CoreExpr) +isAdd e = case e of + L l :+: x -> Just (l,x) + x :+: L l -> Just (l,x) + _ -> Nothing + +-- | Match a multiplication +pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :*: y <- BinOpApp x (isMulOp -> True) y + +-- | Match a multiplication with a literal (handle commutativity) +pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr +pattern l :**: x <- (isMul -> Just (l,x)) + +isMul :: CoreExpr -> Maybe (Integer,CoreExpr) +isMul e = case e of + L l :*: x -> Just (l,x) + x :*: L l -> Just (l,x) + _ -> Nothing + + +-- | Match a subtraction +pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :-: y <- BinOpApp x (isSubOp -> True) y + +isSubOp :: PrimOp -> Bool +isSubOp IntSubOp = True +isSubOp WordSubOp = True +isSubOp _ = False + +isAddOp :: PrimOp -> Bool +isAddOp IntAddOp = True +isAddOp WordAddOp = True +isAddOp _ = False + +isMulOp :: PrimOp -> Bool +isMulOp IntMulOp = True +isMulOp WordMulOp = True +isMulOp _ = False + +-- | Explicit "type-class"-like dictionary for numeric primops +-- +-- Depends on Platform because creating a literal value depends on Platform +data PrimOps = PrimOps + { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers + , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers + , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers + , mkL :: Integer -> CoreExpr -- ^ Create a literal value + } + +intPrimOps :: Platform -> PrimOps +intPrimOps platform = PrimOps + { add = \x y -> BinOpApp x IntAddOp y + , sub = \x y -> BinOpApp x IntSubOp y + , mul = \x y -> BinOpApp x IntMulOp y + , mkL = intResult' platform + } + +wordPrimOps :: Platform -> PrimOps +wordPrimOps platform = PrimOps + { add = \x y -> BinOpApp x WordAddOp y + , sub = \x y -> BinOpApp x WordSubOp y + , mul = \x y -> BinOpApp x WordMulOp y + , mkL = wordResult' platform + } + + +-------------------------------------------------------- +-- Constant folding through case-expressions +-- +-- cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils +-------------------------------------------------------- + +-- | Match the scrutinee of a case and potentially return a new scrutinee and a +-- function to apply to each literal alternative. +caseRules :: Platform + -> CoreExpr -- Scrutinee + -> Maybe ( CoreExpr -- New scrutinee + , AltCon -> Maybe AltCon -- How to fix up the alt pattern + -- Nothing <=> Unreachable + -- See Note [Unreachable caseRules alternatives] + , Id -> CoreExpr) -- How to reconstruct the original scrutinee + -- from the new case-binder +-- e.g case e of b { +-- ...; +-- con bs -> rhs; +-- ... } +-- ==> +-- case e' of b' { +-- ...; +-- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; +-- ... } + +caseRules platform (App (App (Var f) v) (Lit l)) -- v `op` x# + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicRight op x + = Just (v, tx_lit_con platform adjust_lit + , \v -> (App (App (Var f) (Var v)) (Lit l))) + +caseRules platform (App (App (Var f) (Lit l)) v) -- x# `op` v + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicLeft x op + = Just (v, tx_lit_con platform adjust_lit + , \v -> (App (App (Var f) (Lit l)) (Var v))) + + +caseRules platform (App (Var f) v ) -- op v + | Just op <- isPrimOpId_maybe f + , Just adjust_lit <- adjustUnary op + = Just (v, tx_lit_con platform adjust_lit + , \v -> App (Var f) (Var v)) + +-- See Note [caseRules for tagToEnum] +caseRules platform (App (App (Var f) type_arg) v) + | Just TagToEnumOp <- isPrimOpId_maybe f + = Just (v, tx_con_tte platform + , \v -> (App (App (Var f) type_arg) (Var v))) + +-- See Note [caseRules for dataToTag] +caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x + | Just DataToTagOp <- isPrimOpId_maybe f + , Just (tc, _) <- tcSplitTyConApp_maybe ty + , isAlgTyCon tc + = Just (v, tx_con_dtt ty + , \v -> App (App (Var f) (Type ty)) (Var v)) + +caseRules _ _ = Nothing + + +tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon +tx_lit_con _ _ DEFAULT = Just DEFAULT +tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l) +tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) + -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the + -- literal alternatives remain in Word/Int target ranges + -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172). + +adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) +-- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x +adjustDyadicRight op lit + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> y+lit ) + IntSubOp -> Just (\y -> y+lit ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) + _ -> Nothing + +adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) +-- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x +adjustDyadicLeft lit op + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> lit-y ) + IntSubOp -> Just (\y -> lit-y ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) + _ -> Nothing + + +adjustUnary :: PrimOp -> Maybe (Integer -> Integer) +-- Given (op x) return a function 'f' s.t. f (op x) = x +adjustUnary op + = case op of + NotOp -> Just (\y -> complement y) + NotIOp -> Just (\y -> complement y) + IntNegOp -> Just (\y -> negate y ) + _ -> Nothing + +tx_con_tte :: Platform -> AltCon -> Maybe AltCon +tx_con_tte _ DEFAULT = Just DEFAULT +tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) +tx_con_tte platform (DataAlt dc) -- See Note [caseRules for tagToEnum] + = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc + +tx_con_dtt :: Type -> AltCon -> Maybe AltCon +tx_con_dtt _ DEFAULT = Just DEFAULT +tx_con_dtt ty (LitAlt (LitNumber LitNumInt i)) + | tag >= 0 + , tag < n_data_cons + = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) + | otherwise + = Nothing + where + tag = fromInteger i :: ConTagZ + tc = tyConAppTyCon ty + n_data_cons = tyConFamilySize tc + data_cons = tyConDataCons tc + +tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) + + +{- Note [caseRules for tagToEnum] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to transform + case tagToEnum x of + False -> e1 + True -> e2 +into + case x of + 0# -> e1 + 1# -> e2 + +This rule eliminates a lot of boilerplate. For + if (x>y) then e2 else e1 +we generate + case tagToEnum (x ># y) of + False -> e1 + True -> e2 +and it is nice to then get rid of the tagToEnum. + +Beware (#14768): avoid the temptation to map constructor 0 to +DEFAULT, in the hope of getting this + case (x ># y) of + DEFAULT -> e1 + 1# -> e2 +That fails utterly in the case of + data Colour = Red | Green | Blue + case tagToEnum x of + DEFAULT -> e1 + Red -> e2 + +We don't want to get this! + case x of + DEFAULT -> e1 + DEFAULT -> e2 + +Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils +(add_default in mkCase3). + +Note [caseRules for dataToTag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [dataToTag#] in primpops.txt.pp + +We want to transform + case dataToTag x of + DEFAULT -> e1 + 1# -> e2 +into + case x of + DEFAULT -> e1 + (:) _ _ -> e2 + +Note the need for some wildcard binders in +the 'cons' case. + +For the time, we only apply this transformation when the type of `x` is a type +headed by a normal tycon. In particular, we do not apply this in the case of a +data family tycon, since that would require carefully applying coercion(s) +between the data family and the data family instance's representation type, +which caseRules isn't currently engineered to handle (#14680). + +Note [Unreachable caseRules alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Take care if we see something like + case dataToTag x of + DEFAULT -> e1 + -1# -> e2 + 100 -> e3 +because there isn't a data constructor with tag -1 or 100. In this case the +out-of-range alternative is dead code -- we know the range of tags for x. + +Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating +an alternative that is unreachable. + +You may wonder how this can happen: check out #15436. +-} diff --git a/GHC/Core/Opt/CprAnal.hs b/GHC/Core/Opt/CprAnal.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CprAnal.hs @@ -0,0 +1,765 @@ +{-# LANGUAGE CPP #-} + +-- | Constructed Product Result analysis. Identifies functions that surely +-- return heap-allocated records on every code path, so that we can eliminate +-- said heap allocation by performing a worker/wrapper split. +-- +-- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/. +-- CPR analysis should happen after strictness analysis. +-- See Note [Phase ordering]. +module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core +import GHC.Core.Seq +import GHC.Utils.Outputable +import GHC.Builtin.Names ( runRWKey ) +import GHC.Types.Var.Env +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram ) +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.FamInstEnv +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Utils.Misc +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Data.Maybe ( isJust, isNothing ) + +import Control.Monad ( guard ) +import Data.List + +{- Note [Constructed Product Result] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The goal of Constructed Product Result analysis is to identify functions that +surely return heap-allocated records on every code path, so that we can +eliminate said heap allocation by performing a worker/wrapper split. + +@swap@ below is such a function: + + swap (a, b) = (b, a) + +A @case@ on an application of @swap@, like +@case swap (10, 42) of (a, b) -> a + b@ could cancel away +(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then +say that @swap@ has the CPR property. + +We can't inline recursive functions, but similar reasoning applies there: + + f x n = case n of + 0 -> (x, 0) + _ -> f (x+1) (n-1) + +Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed +product with the case. So @f@, too, has the CPR property. But we can't really +"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@ +might be too big to inline (or even marked NOINLINE). We still want to exploit +the CPR property, and that is exactly what the worker/wrapper transformation +can do for us: + + $wf x n = case n of + 0 -> case (x, 0) of -> (a, b) -> (# a, b #) + _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #) + f x n = case $wf x n of (# a, b #) -> (a, b) + +where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to: + + $wf x n = case n of + 0 -> (# x, 0 #) + _ -> $wf (x+1) (n-1) + +Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and +eliminate the heap-allocated pair constructor. + +Note [Phase ordering] +~~~~~~~~~~~~~~~~~~~~~ +We need to perform strictness analysis before CPR analysis, because that might +unbox some arguments, in turn leading to more constructed products. +Ideally, we would want the following pipeline: + +1. Strictness +2. worker/wrapper (for strictness) +3. CPR +4. worker/wrapper (for CPR) + +Currently, we omit 2. and anticipate the results of worker/wrapper. +See Note [CPR in a DataAlt case alternative] +and Note [CPR for binders that will be unboxed]. +An additional w/w pass would simplify things, but probably add slight overhead. +So currently we have + +1. Strictness +2. CPR +3. worker/wrapper (for strictness and CPR) +-} + +-- +-- * Analysing programs +-- + +cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram dflags fam_envs binds = do + let env = emptyAnalEnv fam_envs + let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds + dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr + -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal + seqBinds binds_plus_cpr `seq` return binds_plus_cpr + +-- Analyse a (group of) top-level binding(s) +cprAnalTopBind :: AnalEnv + -> CoreBind + -> (AnalEnv, CoreBind) +cprAnalTopBind env (NonRec id rhs) + = (env', NonRec id' rhs') + where + (id', rhs', env') = cprAnalBind TopLevel env id rhs + +cprAnalTopBind env (Rec pairs) + = (env', Rec pairs') + where + (env', pairs') = cprFix TopLevel env pairs + +-- +-- * Analysing expressions +-- + +-- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from +-- "Constructed Product Result Analysis for Haskell" +cprAnal, cprAnal' + :: AnalEnv + -> CoreExpr -- ^ expression to be denoted by a 'CprType' + -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' + +cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ + cprAnal' env e + +cprAnal' _ (Lit lit) = (topCprType, Lit lit) +cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact +cprAnal' _ (Coercion co) = (topCprType, Coercion co) + +cprAnal' env (Cast e co) + = (cpr_ty, Cast e' co) + where + (cpr_ty, e') = cprAnal env e + +cprAnal' env (Tick t e) + = (cpr_ty, Tick t e') + where + (cpr_ty, e') = cprAnal env e + +cprAnal' env e@(Var{}) + = cprAnalApp env e [] [] +cprAnal' env e@(App{}) + = cprAnalApp env e [] [] + +cprAnal' env (Lam var body) + | isTyVar var + , (body_ty, body') <- cprAnal env body + = (body_ty, Lam var body') + | otherwise + = (lam_ty, Lam var body') + where + env' = extendSigEnvForDemand env var (idDemandInfo var) + (body_ty, body') = cprAnal env' body + lam_ty = abstractCprTy body_ty + +cprAnal' env (Case scrut case_bndr ty alts) + = (res_ty, Case scrut' case_bndr ty alts') + where + (_, scrut') = cprAnal env scrut + -- Regardless whether scrut had the CPR property or not, the case binder + -- certainly has it. See 'extendEnvForDataAlt'. + (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts + res_ty = foldl' lubCprType botCprType alt_tys + +cprAnal' env (Let (NonRec id rhs) body) + = (body_ty, Let (NonRec id' rhs') body') + where + (id', rhs', env') = cprAnalBind NotTopLevel env id rhs + (body_ty, body') = cprAnal env' body + +cprAnal' env (Let (Rec pairs) body) + = body_ty `seq` (body_ty, Let (Rec pairs') body') + where + (env', pairs') = cprFix NotTopLevel env pairs + (body_ty, body') = cprAnal env' body + +cprAnalAlt + :: AnalEnv + -> CoreExpr -- ^ scrutinee + -> Id -- ^ case binder + -> Alt Var -- ^ current alternative + -> (CprType, Alt Var) +cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs) + -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] + = (rhs_ty, (con, bndrs, rhs')) + where + env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs + (rhs_ty, rhs') = cprAnal env_alt rhs +cprAnalAlt env _ _ (con,bndrs,rhs) + = (rhs_ty, (con, bndrs, rhs')) + where + (rhs_ty, rhs') = cprAnal env rhs + +-- +-- * CPR transformer +-- + +cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr) +cprAnalApp env e args' arg_tys + -- Collect CprTypes for (value) args (inlined collectArgs): + | App fn arg <- e, isTypeArg arg -- Don't analyse Type args + = cprAnalApp env fn (arg:args') arg_tys + | App fn arg <- e + , (arg_ty, arg') <- cprAnal env arg + = cprAnalApp env fn (arg':args') (arg_ty:arg_tys) + + | Var fn <- e + = (cprTransform env fn arg_tys, mkApps e args') + + | otherwise -- e is not an App and not a Var + , (e_ty, e') <- cprAnal env e + = (applyCprTy e_ty (length arg_tys), mkApps e' args') + +cprTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The function + -> [CprType] -- ^ info about incoming /value/ arguments + -> CprType -- ^ The demand type of the application +cprTransform env id args + = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig]) + sig + where + sig + -- Top-level binding, local let-binding, lambda arg or case binder + | Just sig <- lookupSigEnv env id + = applyCprTy (getCprSig sig) (length args) + -- CPR transformers for special Ids + | Just cpr_ty <- cprTransformSpecial id args + = cpr_ty + -- See Note [CPR for data structures] + | Just rhs <- cprDataStructureUnfolding_maybe id + = fst $ cprAnal env rhs + -- Imported function or data con worker + | isGlobalId id + = applyCprTy (getCprSig (idCprInfo id)) (length args) + | otherwise + = topCprType + +-- | CPR transformers for special Ids +cprTransformSpecial :: Id -> [CprType] -> Maybe CprType +cprTransformSpecial id args + -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep + | idUnique id == runRWKey -- `runRW (\s -> e)` + , [arg] <- args -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`) + = Just $ applyCprTy arg 1 -- `e` has CPR type `2` + | otherwise + = Nothing + +-- +-- * Bindings +-- + +-- Recursive bindings +cprFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> [(Id,CoreExpr)] + -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info +cprFix top_lvl orig_env orig_pairs + = loop 1 init_env init_pairs + where + init_sig id rhs + -- See Note [CPR for data structures] + | isDataStructure id rhs = topCprSig + | otherwise = mkCprSig 0 botCpr + -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal + orig_virgin = ae_virgin orig_env + init_pairs | orig_virgin = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + init_env = extendSigEnvList orig_env (map fst init_pairs) + + -- The fixed-point varies the idCprInfo field of the binders and and their + -- entries in the AnalEnv, and terminates if that annotation does not change + -- any more. + loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) + loop n env pairs + | found_fixpoint = (reset_env', pairs') + | otherwise = loop (n+1) env' pairs' + where + -- In all but the first iteration, delete the virgin flag + -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal + (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs + -- Make sure we reset the virgin flag to what it was when we are stable + reset_env' = env'{ ae_virgin = orig_virgin } + found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs + + step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)]) + step env pairs = mapAccumL go env pairs + where + go env (id, rhs) = (env', (id', rhs')) + where + (id', rhs', env') = cprAnalBind top_lvl env id rhs + +-- | Process the RHS of the binding for a sensible arity, add the CPR signature +-- to the Id, and augment the environment with the signature as well. +cprAnalBind + :: TopLevelFlag + -> AnalEnv + -> Id + -> CoreExpr + -> (Id, CoreExpr, AnalEnv) +cprAnalBind top_lvl env id rhs + -- See Note [CPR for data structures] + | isDataStructure id rhs + = (id, rhs, env) -- Data structure => no code => need to analyse rhs + | otherwise + = (id', rhs', env') + where + (rhs_ty, rhs') = cprAnal env rhs + -- possibly trim thunk CPR info + rhs_ty' + -- See Note [CPR for thunks] + | stays_thunk = trimCprTy rhs_ty + -- See Note [CPR for sum types] + | returns_sum = trimCprTy rhs_ty + | otherwise = rhs_ty + -- See Note [Arity trimming for CPR signatures] + sig = mkCprSigForArity (idArity id) rhs_ty' + id' = setIdCprInfo id sig + env' = extendSigEnv env id sig + + -- See Note [CPR for thunks] + stays_thunk = is_thunk && not_strict + is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + not_strict = not (isStrictDmd (idDemandInfo id)) + -- See Note [CPR for sum types] + (_, ret_ty) = splitPiTys (idType id) + not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) + returns_sum = not (isTopLevel top_lvl) && not_a_prod + +isDataStructure :: Id -> CoreExpr -> Bool +-- See Note [CPR for data structures] +isDataStructure id rhs = + idArity id == 0 && exprIsHNF rhs + +-- | Returns an expandable unfolding +-- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has +-- So effectively is a constructor application. +cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr +cprDataStructureUnfolding_maybe id = do + -- There are only FinalPhase Simplifier runs after CPR analysis + guard (activeInFinalPhase (idInlineActivation id)) + unf <- expandUnfolding_maybe (idUnfolding id) + guard (isDataStructure id unf) + return unf + +{- Note [Arity trimming for CPR signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although it doesn't affect correctness of the analysis per se, we have to trim +CPR signatures to idArity. Here's what might happen if we don't: + + f x = if expensive + then \y. Box y + else \z. Box z + g a b = f a b + +The two lambdas will have a CPR type of @1m@ (so construct a product after +applied to one argument). Thus, @f@ will have a CPR signature of @2m@ +(constructs a product after applied to two arguments). +But WW will never eta-expand @f@! In this case that would amount to possibly +duplicating @expensive@ work. + +(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see +Note [Don't eta expand in w/w].) + +So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature +from @f@'s, so it *will* be WW'd: + + f x = if expensive + then \y. Box y + else \z. Box z + $wg a b = case f a b of Box x -> x + g a b = Box ($wg a b) + +And the case in @g@ can never cancel away, thus we introduced extra reboxing. +Hence we always trim the CPR signature of a binding to idArity. +-} + +data AnalEnv + = AE + { ae_sigs :: SigEnv + -- ^ Current approximation of signatures for local ids + , ae_virgin :: Bool + -- ^ True only on every first iteration in a fixed-point + -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal" + , ae_fam_envs :: FamInstEnvs + -- ^ Needed when expanding type families and synonyms of product types. + } + +type SigEnv = VarEnv CprSig + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr virgin + , text "ae_sigs =" <+> ppr env ]) + +emptyAnalEnv :: FamInstEnvs -> AnalEnv +emptyAnalEnv fam_envs + = AE + { ae_sigs = emptyVarEnv + , ae_virgin = True + , ae_fam_envs = fam_envs + } + +-- | Extend an environment with the CPR sigs attached to the id +extendSigEnvList :: AnalEnv -> [Id] -> AnalEnv +extendSigEnvList env ids + = env { ae_sigs = sigs' } + where + sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ] + +extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv +extendSigEnv env id sig + = env { ae_sigs = extendVarEnv (ae_sigs env) id sig } + +lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +-- | A version of 'extendSigEnv' for a binder of which we don't see the RHS +-- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders). +-- In this case, we can still look at their demand to attach CPR signatures +-- anticipating the unboxing done by worker/wrapper. +-- See Note [CPR for binders that will be unboxed]. +extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv +extendSigEnvForDemand env id dmd + | isId id + , Just (_, DataConAppContext { dcac_dc = dc }) + <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd + = extendSigEnv env id (CprSig (conCprType (dataConTag dc))) + | otherwise + = env + where + -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE + -- function, we just assume that we aren't. That flag is only relevant + -- to Note [Do not unpack class dictionaries], the few unboxing + -- opportunities on dicts it prohibits are probably irrelevant to CPR. + has_inlineable_prag = False + +extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv +-- See Note [CPR in a DataAlt case alternative] +extendEnvForDataAlt env scrut case_bndr dc bndrs + = foldl' do_con_arg env' ids_w_strs + where + env' = extendSigEnv env case_bndr (CprSig case_bndr_ty) + + ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc + + tycon = dataConTyCon dc + is_product = isJust (isDataProductTyCon_maybe tycon) + is_sum = isJust (isDataSumTyCon_maybe tycon) + case_bndr_ty + | is_product || is_sum = conCprType (dataConTag dc) + -- Any of the constructors had existentials. This is a little too + -- conservative (after all, we only care about the particular data con), + -- but there is no easy way to write is_sum and this won't happen much. + | otherwise = topCprType + + -- We could have much deeper CPR info here with Nested CPR, which could + -- propagate available unboxed things from the scrutinee, getting rid of + -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative]. + -- Giving strict binders the CPR property only makes sense for products, as + -- the arguments in Note [CPR for binders that will be unboxed] don't apply + -- to sums (yet); we lack WW for strict binders of sum type. + do_con_arg env (id, str) + | is_var scrut + -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils + , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id) + = extendSigEnvForDemand env id dmd + | otherwise + = env + + is_var (Cast e _) = is_var e + is_var (Var v) = isLocalId v + is_var _ = False + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, to ensure that all expressions have been traversed at least once, and any +unsound CPR annotations have been updated. + +Note [CPR in a DataAlt case alternative] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case alternative, we want to give some of the binders the CPR property. +Specifically + + * The case binder; inside the alternative, the case binder always has + the CPR property, meaning that a case on it will successfully cancel. + Example: + f True x = case x of y { I# x' -> if x' ==# 3 + then y + else I# 8 } + f False x = I# 3 + + By giving 'y' the CPR property, we ensure that 'f' does too, so we get + f b x = case fw b x of { r -> I# r } + fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + fw False x = 3 + + Of course there is the usual risk of re-boxing: we have 'x' available + boxed and unboxed, but we return the unboxed version for the wrapper to + box. If the wrapper doesn't cancel with its caller, we'll end up + re-boxing something that we did have available in boxed form. + + * Any strict binders with product type, can use + Note [CPR for binders that will be unboxed] + to anticipate worker/wrappering for strictness info. + But we can go a little further. Consider + + data T = MkT !Int Int + + f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) + | otherwise = x + + For $wf2 we are going to unbox the MkT *and*, since it is strict, the + first argument of the MkT; see Note [Add demands for strict constructors]. + But then we don't want box it up again when returning it! We want + 'f2' to have the CPR property, so we give 'x' the CPR property. + + * It's a bit delicate because we're brittly anticipating worker/wrapper here. + If the case above is scrutinising something other than an argument the + original function, we really don't have the unboxed version available. E.g + g v = case foo v of + MkT x y | y>0 -> ... + | otherwise -> x + Here we don't have the unboxed 'x' available. Hence the + is_var_scrut test when making use of the strictness annotation. + Slightly ad-hoc, because even if the scrutinee *is* a variable it + might not be a onre of the arguments to the original function, or a + sub-component thereof. But it's simple, and nothing terrible + happens if we get it wrong. e.g. Trac #10694. + +Note [CPR for binders that will be unboxed] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a lambda-bound variable will be unboxed by worker/wrapper (so it must be +demanded strictly), then give it a CPR signature. Here's a concrete example +('f1' in test T10482a), assuming h is strict: + + f1 :: Int -> Int + f1 x = case h x of + A -> x + B -> f1 (x-1) + C -> x+1 + +If we notice that 'x' is used strictly, we can give it the CPR +property; and hence f1 gets the CPR property too. It's sound (doesn't +change strictness) to give it the CPR property because by the time 'x' +is returned (case A above), it'll have been evaluated (by the wrapper +of 'h' in the example). + +Moreover, if f itself is strict in x, then we'll pass x unboxed to +f1, and so the boxed version *won't* be available; in that case it's +very helpful to give 'x' the CPR property. + +Note that + + * We only want to do this for something that definitely + has product type, else we may get over-optimistic CPR results + (e.g. from \x -> x!). + + * This also (approximately) applies to DataAlt field binders; + See Note [CPR in a DataAlt case alternative]. + + * See Note [CPR examples] + +Note [CPR for sum types] +~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we do not do CPR for let-bindings that + * non-top level + * bind a sum type +Reason: I found that in some benchmarks we were losing let-no-escapes, +which messed it all up. Example + let j = \x. .... + in case y of + True -> j False + False -> j True +If we w/w this we get + let j' = \x. .... + in case y of + True -> case j' False of { (# a #) -> Just a } + False -> case j' True of { (# a #) -> Just a } +Notice that j' is not a let-no-escape any more. + +However this means in turn that the *enclosing* function +may be CPR'd (via the returned Justs). But in the case of +sums, there may be Nothing alternatives; and that messes +up the sum-type CPR. + +Conclusion: only do this for products. It's still not +guaranteed OK for products, but sums definitely lose sometimes. + +Note [CPR for thunks] +~~~~~~~~~~~~~~~~~~~~~ +If the rhs is a thunk, we usually forget the CPR info, because +it is presumably shared (else it would have been inlined, and +so we'd lose sharing if w/w'd it into a function). E.g. + + let r = case expensive of + (a,b) -> (b,a) + in ... + +If we marked r as having the CPR property, then we'd w/w into + + let $wr = \() -> case expensive of + (a,b) -> (# b, a #) + r = case $wr () of + (# b,a #) -> (b,a) + in ... + +But now r is a thunk, which won't be inlined, so we are no further ahead. +But consider + + f x = let r = case expensive of (a,b) -> (b,a) + in if foo r then r else (x,x) + +Does f have the CPR property? Well, no. + +However, if the strictness analyser has figured out (in a previous +iteration) that it's strict, then we DON'T need to forget the CPR info. +Instead we can retain the CPR info and do the thunk-splitting transform +(see WorkWrap.splitThunk). + +This made a big difference to PrelBase.modInt, which had something like + modInt = \ x -> let r = ... -> I# v in + ...body strict in r... +r's RHS isn't a value yet; but modInt returns r in various branches, so +if r doesn't have the CPR property then neither does modInt +Another case I found in practice (in Complex.magnitude), looks like this: + let k = if ... then I# a else I# b + in ... body strict in k .... +(For this example, it doesn't matter whether k is returned as part of +the overall result; but it does matter that k's RHS has the CPR property.) +Left to itself, the simplifier will make a join point thus: + let $j k = ...body strict in k... + if ... then $j (I# a) else $j (I# b) +With thunk-splitting, we get instead + let $j x = let k = I#x in ...body strict in k... + in if ... then $j a else $j b +This is much better; there's a good chance the I# won't get allocated. + +But what about botCpr? Consider + lvl = error "boom" + fac -1 = lvl + fac 0 = 1 + fac n = n * fac (n-1) +fac won't have the CPR property here when we trim every thunk! But the +assumption is that error cases are rarely entered and we are diverging anyway, +so WW doesn't hurt. + +Should we also trim CPR on DataCon application bindings? +See Note [CPR for data structures]! + +Note [CPR for data structures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Long static data structures (whether top-level or not) like + + xs = x1 : xs1 + xs1 = x2 : xs2 + xs2 = x3 : xs3 + +should not get CPR signatures (#18154), because they + + * Never get WW'd, so their CPR signature should be irrelevant after analysis + (in fact the signature might even be harmful for that reason) + * Would need to be inlined/expanded to see their constructed product + * Recording CPR on them blows up interface file sizes and is redundant with + their unfolding. In case of Nested CPR, this blow-up can be quadratic! + Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info + for xs2 contains that for xs1. And so on. + +Hence we don't analyse or annotate data structures in 'cprAnalBind'. To +implement this, the isDataStructure guard is triggered for bindings that satisfy + + (1) idArity id == 0 (otherwise it's a function) + (2) exprIsHNF rhs (otherwise it's a thunk, Note [CPR for thunks] applies) + +But we can't just stop giving DataCon application bindings the CPR *property*, +for example + + fac 0 = I# 1# + fac n = n * fac (n-1) + +fac certainly has the CPR property and should be WW'd! But FloatOut will +transform the first clause to + + lvl = I# 1# + fac 0 = lvl + +If lvl doesn't have the CPR property, fac won't either. But lvl is a data +structure, and hence (see above) will not have a CPR signature. So instead, when +'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR +transformer, 'cprTransform' instead tries to get its unfolding (via +'cprDataStructureUnfolding_maybe'), and analyses that instead. + +In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one +for each data declaration. They should not have CPR signatures (blow up!). + +There is a perhaps surprising special case: KindRep bindings satisfy +'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same +time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is +no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll +return topCprType. And that is fine! We should refrain to look through NOINLINE +data structures in general, as a constructed product could never be exposed +after WW. + +It's also worth pointing out how ad-hoc this is: If we instead had + + f1 x = x:[] + f2 x = x : f1 x + f3 x = x : f2 x + ... + +we still give every function an every deepening CPR signature. But it's very +uncommon to find code like this, whereas the long static data structures from +the beginning of this Note are very common because of GHC's strategy of ANF'ing +data structure RHSs. + +Note [CPR examples] +~~~~~~~~~~~~~~~~~~~~ +Here are some examples (stranal/should_compile/T10482a) of the +usefulness of Note [CPR in a DataAlt case alternative]. The main +point: all of these functions can have the CPR property. + + ------- f1 ----------- + -- x is used strictly by h, so it'll be available + -- unboxed before it is returned in the True branch + + f1 :: Int -> Int + f1 x = case h x x of + True -> x + False -> f1 (x-1) + + ------- f3 ----------- + -- h is strict in x, so x will be unboxed before it + -- is rerturned in the otherwise case. + + data T3 = MkT3 Int Int + + f1 :: T3 -> Int + f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) + | otherwise = x +-} diff --git a/GHC/Core/Opt/DmdAnal.hs b/GHC/Core/Opt/DmdAnal.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/DmdAnal.hs @@ -0,0 +1,1390 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + + ----------------- + A demand analysis + ----------------- +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Types.Demand -- All of it +import GHC.Core +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Core.Seq ( seqBinds ) +import GHC.Utils.Outputable +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic +import Data.List ( mapAccumL ) +import GHC.Core.DataCon +import GHC.Types.ForeignCall ( isSafeForeignCall ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Utils +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.FVs ( exprFreeIds, ruleRhsFreeIds ) +import GHC.Core.Coercion ( Coercion, coVarsOfCo ) +import GHC.Core.FamInstEnv +import GHC.Utils.Misc +import GHC.Data.Maybe ( isJust ) +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Types.Unique.Set + +{- +************************************************************************ +* * +\subsection{Top level stuff} +* * +************************************************************************ +-} + +dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +dmdAnalProgram dflags fam_envs binds = do + let env = emptyAnalEnv dflags fam_envs + let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds + dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds + -- See Note [Stamp out space leaks in demand analysis] + seqBinds binds_plus_dmds `seq` return binds_plus_dmds + +-- Analyse a (group of) top-level binding(s) +dmdAnalTopBind :: AnalEnv + -> CoreBind + -> (AnalEnv, CoreBind) +dmdAnalTopBind env (NonRec id rhs) + = ( extendAnalEnv TopLevel env id sig + , NonRec (setIdStrictness id sig) rhs') + where + ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs + +dmdAnalTopBind env (Rec pairs) + = (env', Rec pairs') + where + (env', _, pairs') = dmdFix TopLevel env cleanEvalDmd pairs + -- We get two iterations automatically + -- c.f. the NonRec case above + +{- Note [Stamp out space leaks in demand analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand analysis pass outputs a new copy of the Core program in +which binders have been annotated with demand and strictness +information. It's tiresome to ensure that this information is fully +evaluated everywhere that we produce it, so we just run a single +seqBinds over the output before returning it, to ensure that there are +no references holding on to the input Core program. + +This makes a ~30% reduction in peak memory usage when compiling +DynFlags (cf #9675 and #13426). + +This is particularly important when we are doing late demand analysis, +since we don't do a seqBinds at any point thereafter. Hence code +generation would hold on to an extra copy of the Core program, via +unforced thunks in demand or strictness information; and it is the +most memory-intensive part of the compilation process, so this added +seqBinds makes a big difference in peak memory usage. +-} + + +{- +************************************************************************ +* * +\subsection{The analyser itself} +* * +************************************************************************ + +Note [Ensure demand is strict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important not to analyse e with a lazy demand because +a) When we encounter case s of (a,b) -> + we demand s with U(d1d2)... but if the overall demand is lazy + that is wrong, and we'd need to reduce the demand on s, + which is inconvenient +b) More important, consider + f (let x = R in x+x), where f is lazy + We still want to mark x as demanded, because it will be when we + enter the let. If we analyse f's arg with a Lazy demand, we'll + just mark x as Lazy +c) The application rule wouldn't be right either + Evaluating (f x) in a L demand does *not* cause + evaluation of f in a C(L) demand! +-} + +-- If e is complicated enough to become a thunk, its contents will be evaluated +-- at most once, so oneify it. +dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand +dmdTransformThunkDmd e + | exprIsTrivial e = id + | otherwise = oneifyDmd + +-- Do not process absent demands +-- Otherwise act like in a normal demand analysis +-- See ↦* relation in the Cardinality Analysis paper +dmdAnalStar :: AnalEnv + -> Demand -- This one takes a *Demand* + -> CoreExpr -- Should obey the let/app invariant + -> (BothDmdArg, CoreExpr) +dmdAnalStar env dmd e + | (dmd_shell, cd) <- toCleanDmd dmd + , (dmd_ty, e') <- dmdAnal env cd e + = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) + -- The argument 'e' should satisfy the let/app invariant + -- See Note [Analysing with absent demand] in GHC.Types.Demand + (postProcessDmdType dmd_shell dmd_ty, e') + +-- Main Demand Analsysis machinery +dmdAnal, dmdAnal' :: AnalEnv + -> CleanDemand -- The main one takes a *CleanDemand* + -> CoreExpr -> (DmdType, CoreExpr) + +-- The CleanDemand is always strict and not absent +-- See Note [Ensure demand is strict] + +dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ + dmdAnal' env d e + +dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) +dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) + = (unitDmdType (coercionDmdEnv co), Coercion co) + +dmdAnal' env dmd (Var var) + = (dmdTransform env var dmd, Var var) + +dmdAnal' env dmd (Cast e co) + = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co) + where + (dmd_ty, e') = dmdAnal env dmd e + +dmdAnal' env dmd (Tick t e) + = (dmd_ty, Tick t e') + where + (dmd_ty, e') = dmdAnal env dmd e + +dmdAnal' env dmd (App fun (Type ty)) + = (fun_ty, App fun' (Type ty)) + where + (fun_ty, fun') = dmdAnal env dmd fun + +-- Lots of the other code is there to make this +-- beautiful, compositional, application rule :-) +dmdAnal' env dmd (App fun arg) + = -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let + call_dmd = mkCallDmd dmd + (fun_ty, fun') = dmdAnal env call_dmd fun + (arg_dmd, res_ty) = splitDmdTy fun_ty + (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg + in +-- pprTrace "dmdAnal:app" (vcat +-- [ text "dmd =" <+> ppr dmd +-- , text "expr =" <+> ppr (App fun arg) +-- , text "fun dmd_ty =" <+> ppr fun_ty +-- , text "arg dmd =" <+> ppr arg_dmd +-- , text "arg dmd_ty =" <+> ppr arg_ty +-- , text "res dmd_ty =" <+> ppr res_ty +-- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) + (res_ty `bothDmdType` arg_ty, App fun' arg') + +dmdAnal' env dmd (Lam var body) + | isTyVar var + = let + (body_ty, body') = dmdAnal env dmd body + in + (body_ty, Lam var body') + + | otherwise + = let (body_dmd, defer_and_use) = peelCallDmd dmd + -- body_dmd: a demand to analyze the body + + (body_ty, body') = dmdAnal env body_dmd body + (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var + in + (postProcessUnsat defer_and_use lam_ty, Lam var' body') + +dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) + -- Only one alternative with a product constructor + | let tycon = dataConTyCon dc + , isJust (isDataProductTyCon_maybe tycon) + = let + (rhs_ty, rhs') = dmdAnal env dmd rhs + (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs + (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr + id_dmds = addCaseBndrDmd case_bndr_dmd dmds + fam_envs = ae_fam_envs env + alt_ty3 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty2 + | otherwise + = alt_ty2 + + -- Compute demand on the scrutinee + -- See Note [Demand on scrutinee of a product case] + scrut_dmd = mkProdDmd id_dmds + (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut + res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty + case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + bndrs' = setBndrsDemandInfo bndrs id_dmds + in +-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut +-- , text "dmd" <+> ppr dmd +-- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') +-- , text "id_dmds" <+> ppr id_dmds +-- , text "scrut_dmd" <+> ppr scrut_dmd +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')]) + +dmdAnal' env dmd (Case scrut case_bndr ty alts) + = let -- Case expression with multiple alternatives + (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts + (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut + (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr + -- NB: Base case is botDmdType, for empty case alternatives + -- This is a unit for lubDmdType, and the right result + -- when there really are no alternatives + fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty + | otherwise + = alt_ty + res_ty = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty + + in +-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_tys" <+> ppr alt_tys +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty alts') + +-- Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- The following case handle the up variant. +-- +-- It is very simple. For let x = rhs in body +-- * Demand-analyse 'body' in the current environment +-- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' +-- * Demand-analyse 'rhs' in 'rhs_dmd' +-- +-- This is used for a non-recursive local let without manifest lambdas. +-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnal' env dmd (Let (NonRec id rhs) body) + | useLetUp id + = (final_ty, Let (NonRec id' rhs') body') + where + (body_ty, body') = dmdAnal env dmd body + (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id + id' = setIdDemandInfo id id_dmd + + (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs + final_ty = body_ty' `bothDmdType` rhs_ty + +dmdAnal' env dmd (Let (NonRec id rhs) body) + = (body_ty2, Let (NonRec id2 rhs') body') + where + (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs + id1 = setIdStrictness id sig + env1 = extendAnalEnv NotTopLevel env id sig + (body_ty, body') = dmdAnal env1 dmd body + (body_ty1, id2) = annotateBndr env body_ty id1 + body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] + + -- If the actual demand is better than the vanilla call + -- demand, you might think that we might do better to re-analyse + -- the RHS with the stronger demand. + -- But (a) That seldom happens, because it means that *every* path in + -- the body of the let has to use that stronger demand + -- (b) It often happens temporarily in when fixpointing, because + -- the recursive function at first seems to place a massive demand. + -- But we don't want to go to extra work when the function will + -- probably iterate to something less demanding. + -- In practice, all the times the actual demand on id2 is more than + -- the vanilla call demand seem to be due to (b). So we don't + -- bother to re-analyse the RHS. + +dmdAnal' env dmd (Let (Rec pairs) body) + = let + (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs + (body_ty, body') = dmdAnal env' dmd body + body_ty1 = deleteFVs body_ty (map fst pairs) + body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] + in + body_ty2 `seq` + (body_ty2, Let (Rec pairs') body') + +deleteFVs :: DmdType -> [Var] -> DmdType +deleteFVs (DmdType fvs dmds res) bndrs + = DmdType (delVarEnvList fvs bndrs) dmds res + +-- | A simple, syntactic analysis of whether an expression MAY throw a precise +-- exception when evaluated. It's always sound to return 'True'. +-- See Note [Which scrutinees may throw precise exceptions]. +exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool +exprMayThrowPreciseException envs e + | not (forcesRealWorld envs (exprType e)) + = False -- 1. in the Note + | (Var f, _) <- collectArgs e + , Just op <- isPrimOpId_maybe f + , op /= RaiseIOOp + = False -- 2. in the Note + | (Var f, _) <- collectArgs e + , Just fcall <- isFCallId_maybe f + , not (isSafeForeignCall fcall) + = False -- 3. in the Note + | otherwise + = True -- _. in the Note + +-- | Recognises types that are +-- * @State# RealWorld@ +-- * Unboxed tuples with a @State# RealWorld@ field +-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See +-- T13380e) and user-written variants thereof by their type. +forcesRealWorld :: FamInstEnvs -> Type -> Bool +forcesRealWorld fam_envs ty + | ty `eqType` realWorldStatePrimTy + = True + | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys } + <- deepSplitProductType_maybe fam_envs ty + , isUnboxedTupleCon dc + = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys + | otherwise + = False + +dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) +dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) + | null bndrs -- Literals, DEFAULT, and nullary constructors + , (rhs_ty, rhs') <- dmdAnal env dmd rhs + = (rhs_ty, (con, [], rhs')) + + | otherwise -- Non-nullary data constructors + , (rhs_ty, rhs') <- dmdAnal env dmd rhs + , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs + , let case_bndr_dmd = findIdDemand alt_ty case_bndr + id_dmds = addCaseBndrDmd case_bndr_dmd dmds + = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) + +{- Note [Which scrutinees may throw precise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the specification of 'exprMayThrowPreciseExceptions', +which is important for Scenario 2 of +Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. + +For an expression @f a1 ... an :: ty@ we determine that + 1. False If ty is *not* @State# RealWorld@ or an unboxed tuple thereof. + This check is done by 'forcesRealWorld'. + (Why not simply unboxed pairs as above? This is motivated by + T13380{d,e}.) + 2. False If f is a PrimOp, and it is *not* raiseIO# + 3. False If f is an unsafe FFI call ('PlayRisky') + _. True Otherwise "give up". + +It is sound to return False in those cases, because + 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions + from pure code. + 2. raiseIO# is the only primop that may throw a precise exception. + 3. Unsafe FFI calls may not interact with the RTS (to throw, for example). + See haddock on GHC.Types.ForeignCall.PlayRisky. + +We *need* to return False in those cases, because + 1. We would lose too much strictness in pure code, all over the place. + 2. We would lose strictness for primops like getMaskingState#, which + introduces a substantial regression in + GHC.IO.Handle.Internals.wantReadableHandle. + 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData, + where an intermittent FFI call to c_MD5Init would otherwise lose + strictness on the arguments len and buf, leading to regressions in T9203 + (2%) and i386's haddock.base (5%). Tested by T13380f. + +In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic) +to the Divergence lattice, but in practice it turned out to be hard to untaint +from 'topDiv' to 'conDiv', leading to bugs, performance regressions and +complexity that didn't justify the single fixed testcase T13380c. + +Note [Demand on the scrutinee of a product case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When figuring out the demand on the scrutinee of a product case, +we use the demands of the case alternative, i.e. id_dmds. +But note that these include the demand on the case binder; +see Note [Demand on case-alternative binders] in GHC.Types.Demand. +This is crucial. Example: + f x = case x of y { (a,b) -> k y a } +If we just take scrut_demand = U(L,A), then we won't pass x to the +worker, so the worker will rebuild + x = (a, absent-error) +and that'll crash. + +Note [Aggregated demand for cardinality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use different strategies for strictness and usage/cardinality to +"unleash" demands captured on free variables by bindings. Let us +consider the example: + +f1 y = let {-# NOINLINE h #-} + h = y + in (h, h) + +We are interested in obtaining cardinality demand U1 on |y|, as it is +used only in a thunk, and, therefore, is not going to be updated any +more. Therefore, the demand on |y|, captured and unleashed by usage of +|h| is U1. However, if we unleash this demand every time |h| is used, +and then sum up the effects, the ultimate demand on |y| will be U1 + +U1 = U. In order to avoid it, we *first* collect the aggregate demand +on |h| in the body of let-expression, and only then apply the demand +transformer: + +transf[x](U) = {y |-> U1} + +so the resulting demand on |y| is U1. + +The situation is, however, different for strictness, where this +aggregating approach exhibits worse results because of the nature of +|both| operation for strictness. Consider the example: + +f y c = + let h x = y |seq| x + in case of + True -> h True + False -> y + +It is clear that |f| is strict in |y|, however, the suggested analysis +will infer from the body of |let| that |h| is used lazily (as it is +used in one branch only), therefore lazy demand will be put on its +free variable |y|. Conversely, if the demand on |h| is unleashed right +on the spot, we will get the desired result, namely, that |f| is +strict in |y|. + + +************************************************************************ +* * + Demand transformer +* * +************************************************************************ +-} + +dmdTransform :: AnalEnv -- The strictness environment + -> Id -- The function + -> CleanDemand -- The demand on the function + -> DmdType -- The demand type of the function in this context + -- Returned DmdEnv includes the demand on + -- this function plus demand on its free variables + +dmdTransform env var dmd + -- Data constructors + | isDataConWorkId var + = dmdTransformDataConSig (idArity var) dmd + -- Dictionary component selectors + | gopt Opt_DmdTxDictSel (ae_dflags env), + Just _ <- isClassOpId_maybe var + = dmdTransformDictSelSig (idStrictness var) dmd + -- Imported functions + | isGlobalId var + , let res = dmdTransformSig (idStrictness var) dmd + = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + res + -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). + -- In that case, we have a strictness signature to unleash in our AnalEnv. + | Just (sig, top_lvl) <- lookupSigEnv env var + , let fn_ty = dmdTransformSig sig dmd + = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ + if isTopLevel top_lvl + then fn_ty -- Don't record demand on top-level things + else addVarDmd fn_ty var (mkOnceUsedDmd dmd) + -- Everything else: + -- * Local let binders for which we use LetUp (cf. 'useLetUp') + -- * Lambda binders + -- * Case and constructor field binders + | otherwise + = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $ + unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) + +{- ********************************************************************* +* * + Binding right-hand sides +* * +********************************************************************* -} + +-- Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- dmdAnalRhsLetDown implements the Down variant: +-- * assuming a demand of +-- * looking at the definition +-- * determining a strictness signature +-- +-- It is used for toplevel definition, recursive definitions and local +-- non-recursive definitions that have manifest lambdas. +-- Local non-recursive definitions without a lambda are handled with LetUp. +-- +-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnalRhsLetDown + :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive + -> AnalEnv -> CleanDemand + -> Id -> CoreExpr + -> (DmdEnv, StrictSig, CoreExpr) +-- Process the RHS of the binding, add the strictness signature +-- to the Id, and augment the environment with the signature as well. +-- See Note [NOINLINE and strictness] +dmdAnalRhsLetDown rec_flag env let_dmd id rhs + = (lazy_fv, sig, rhs') + where + rhs_arity = idArity id + rhs_dmd -- See Note [Demand analysis for join points] + -- See Note [Invariants on join points] invariant 2b, in GHC.Core + -- rhs_arity matches the join arity of the join point + | isJoinId id + = mkCallDmds rhs_arity let_dmd + | otherwise + -- NB: rhs_arity + -- See Note [Demand signatures are computed for a threshold demand based on idArity] + = mkRhsDmd env rhs_arity rhs + + (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs + DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty + + sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) + + -- See Note [Aggregated demand for cardinality] + rhs_fv1 = case rec_flag of + Just bs -> reuseEnv (delVarEnvList rhs_fv bs) + Nothing -> rhs_fv + + rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs + + -- See Note [Lazy and unleashable free variables] + (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv2 + is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + + -- Find the RHS free vars of the unfoldings and RULES + -- See Note [Absence analysis for stable unfoldings and RULES] + extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $ + idCoreRules id + + unf = realIdUnfolding id + unf_fvs | isStableUnfolding unf + , Just unf_body <- maybeUnfoldingTemplate unf + = exprFreeIds unf_body + | otherwise = emptyVarSet + +-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for +-- unleashing on the given function's @rhs@, by creating +-- a call demand of @rhs_arity@ +-- See Historical Note [Product demands for function body] +mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand +mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd + +-- | If given the let-bound 'Id', 'useLetUp' determines whether we should +-- process the binding up (body before rhs) or down (rhs before body). +-- +-- We use LetDown if there is a chance to get a useful strictness signature to +-- unleash at call sites. LetDown is generally more precise than LetUp if we can +-- correctly guess how it will be used in the body, that is, for which incoming +-- demand the strictness signature should be computed, which allows us to +-- unleash higher-order demands on arguments at call sites. This is mostly the +-- case when +-- +-- * The binding takes any arguments before performing meaningful work (cf. +-- 'idArity'), in which case we are interested to see how it uses them. +-- * The binding is a join point, hence acting like a function, not a value. +-- As a big plus, we know *precisely* how it will be used in the body; since +-- it's always tail-called, we can directly unleash the incoming demand of +-- the let binding on its RHS when computing a strictness signature. See +-- [Demand analysis for join points]. +-- +-- Thus, if the binding is not a join point and its arity is 0, we have a thunk +-- and use LetUp, implying that we have no usable demand signature available +-- when we analyse the let body. +-- +-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free +-- vars at most once, regardless of how many times it was forced in the body. +-- This makes a real difference wrt. usage demands. The other reason is being +-- able to unleash a more precise product demand on its RHS once we know how the +-- thunk was used in the let body. +-- +-- Characteristic examples, always assuming a single evaluation: +-- +-- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that +-- the expression uses @y@ at most once. +-- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that +-- @b@ is absent. +-- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that +-- the expression uses @y@ strictly, because we have @f@'s demand signature +-- available at the call site. +-- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => +-- LetDown. Compared to LetUp, we find out that the expression uses @y@ +-- strictly, because we can unleash @exit@'s signature at each call site. +-- * For a more convincing example with join points, see Note [Demand analysis +-- for join points]. +-- +useLetUp :: Var -> Bool +useLetUp f = idArity f == 0 && not (isJoinId f) + +{- Note [Demand analysis for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g :: (Int,Int) -> Int + g (p,q) = p+q + + f :: T -> Int -> Int + f x p = g (join j y = (p,y) + in case x of + A -> j 3 + B -> j 4 + C -> (p,7)) + +If j was a vanilla function definition, we'd analyse its body with +evalDmd, and think that it was lazy in p. But for join points we can +do better! We know that j's body will (if called at all) be evaluated +with the demand that consumes the entire join-binding, in this case +the argument demand from g. Whizzo! g evaluates both components of +its argument pair, so p will certainly be evaluated if j is called. + +For f to be strict in p, we need /all/ paths to evaluate p; in this +case the C branch does so too, so we are fine. So, as usual, we need +to transport demands on free variables to the call site(s). Compare +Note [Lazy and unleashable free variables]. + +The implementation is easy. When analysing a join point, we can +analyse its body with the demand from the entire join-binding (written +let_dmd here). + +Another win for join points! #13543. + +However, note that the strictness signature for a join point can +look a little puzzling. E.g. + + (join j x = \y. error "urk") + (in case v of ) + ( A -> j 3 ) x + ( B -> j 4 ) + ( C -> \y. blah ) + +The entire thing is in a C(S) context, so j's strictness signature +will be [A]b +meaning one absent argument, returns bottom. That seems odd because +there's a \y inside. But it's right because when consumed in a C(1) +context the RHS of the join point is indeed bottom. + +Note [Demand signatures are computed for a threshold demand based on idArity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We compute demand signatures assuming idArity incoming arguments to approximate +behavior for when we have a call site with at least that many arguments. idArity +is /at least/ the number of manifest lambdas, but might be higher for PAPs and +trivial RHS (see Note [Demand analysis for trivial right-hand sides]). + +Because idArity of a function varies independently of its cardinality properties +(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode +the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' +(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to +unleash a demand signature when the incoming number of arguments is less than +that. See Note [What are demand signatures?] for more details on soundness. + +Why idArity arguments? Because that's a conservative estimate of how many +arguments we must feed a function before it does anything interesting with them. +Also it elegantly subsumes the trivial RHS and PAP case. + +There might be functions for which we might want to analyse for more incoming +arguments than idArity. Example: + + f x = + if expensive + then \y -> ... y ... + else \y -> ... y ... + +We'd analyse `f` under a unary call demand C(S), corresponding to idArity +being 1. That's enough to look under the manifest lambda and find out how a +unary call would use `x`, but not enough to look into the lambdas in the if +branches. + +On the other hand, if we analysed for call demand C(C(S)), we'd get useful +strictness info for `y` (and more precise info on `x`) and possibly CPR +information, but + + * We would no longer be able to unleash the signature at unary call sites + * Performing the worker/wrapper split based on this information would be + implicitly eta-expanding `f`, playing fast and loose with divergence and + even being unsound in the presence of newtypes, so we refrain from doing so. + Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap. + +Since we only compute one signature, we do so for arity 1. Computing multiple +signatures for different arities (i.e., polyvariance) would be entirely +possible, if it weren't for the additional runtime and implementation +complexity. + +Note [idArity varies independently of dmdTypeDepth] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound +identifier. But that means we would have to zap demand signatures every time we +reset or decrease arity. That's an unnecessary dependency, because + + * The demand signature captures a semantic property that is independent of + what the binding's current arity is + * idArity is analysis information itself, thus volatile + * We already *have* dmdTypeDepth, wo why not just use it to encode the + threshold for when to unleash the signature + (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand) + +Consider the following expression, for example: + + (let go x y = `x` seq ... in go) |> co + +`go` might have a strictness signature of ``. The simplifier will identify +`go` as a nullary join point through `joinPointBinding_maybe` and float the +coercion into the binding, leading to an arity decrease: + + join go = (\x y -> `x` seq ...) |> co in go + +With the CoreLint check, we would have to zap `go`'s perfectly viable strictness +signature. + +Note [What are demand signatures?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand analysis interprets expressions in the abstract domain of demand +transformers. Given an incoming demand we put an expression under, its abstract +transformer gives us back a demand type denoting how other things (like +arguments and free vars) were used when the expression was evaluated. +Here's an example: + + f x y = + if x + expensive + then \z -> z + y * ... + else \z -> z * ... + +The abstract transformer (let's call it F_e) of the if expression (let's call it +e) would transform an incoming head demand into a demand type like +{x->,y->}. In pictures: + + Demand ---F_e---> DmdType + {x->,y->} + +Let's assume that the demand transformers we compute for an expression are +correct wrt. to some concrete semantics for Core. How do demand signatures fit +in? They are strange beasts, given that they come with strict rules when to +it's sound to unleash them. + +Fortunately, we can formalise the rules with Galois connections. Consider +f's strictness signature, {}. It's a single-point approximation of +the actual abstract transformer of f's RHS for arity 2. So, what happens is that +we abstract *once more* from the abstract domain we already are in, replacing +the incoming Demand by a simple lattice with two elements denoting incoming +arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom +element). Here's the diagram: + + A_2 -----f_f----> DmdType + ^ | + | α γ | + | v + Demand ---F_f---> DmdType + +With + α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness + α(_) = <2 + γ(ty) = ty +and F_f being the abstract transformer of f's RHS and f_f being the abstracted +abstract transformer computable from our demand signature simply by + + f_f(>=2) = {} + f_f(<2) = postProcessUnsat {} + +where postProcessUnsat makes a proper top element out of the given demand type. + +Note [Demand analysis for trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo = plusInt |> co +where plusInt is an arity-2 function with known strictness. Clearly +we want plusInt's strictness to propagate to foo! But because it has +no manifest lambdas, it won't do so automatically, and indeed 'co' might +have type (Int->Int->Int) ~ T. + +Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to +forward plusInt's demand signature, and all is well (see Note [Newtype arity] in +GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. + +Note [Absence analysis for stable unfoldings and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #18638 shows that it's really important to do absence analysis +for stable unfoldings. Consider + + g = blah + + f = \x. ...no use of g.... + {- f's stable unfolding is f = \x. ...g... -} + +If f is ever inlined we use 'g'. But f's current RHS makes no use +of 'g', so if we don't look at the unfolding we'll mark g as Absent, +and transform to + + g = error "Entered absent value" + f = \x. ... + {- f's stable unfolding is f = \x. ...g... -} + +Now if f is subsequently inlined, we'll use 'g' and ... disaster. + +SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands +on its free variables) so that no variable mentioned in its unfolding +is Absent. This is done by the function Demand.keepAliveDmdEnv. + +ALSO: do the same for Ids free in the RHS of any RULES for f. + +PS: You may wonder how it can be that f's optimised RHS has somehow +discarded 'g', but when f is inlined we /don't/ discard g in the same +way. I think a simple example is + g = (a,b) + f = \x. fst g + {-# INLINE f #-} + +Now f's optimised RHS will be \x.a, but if we change g to (error "..") +(since it is apparently Absent) and then inline (\x. fst g) we get +disaster. But regardless, #18638 was a more complicated version of +this, that actually happened in practice. + +Historical Note [Product demands for function body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 2013 I spotted this example, in shootout/binary_trees: + + Main.check' = \ b z ds. case z of z' { I# ip -> + case ds_d13s of + Main.Nil -> z' + Main.Node s14k s14l s14m -> + Main.check' (not b) + (Main.check' b + (case b { + False -> I# (-# s14h s14k); + True -> I# (+# s14h s14k) + }) + s14l) + s14m } } } + +Here we *really* want to unbox z, even though it appears to be used boxed in +the Nil case. Partly the Nil case is not a hot path. But more specifically, +the whole function gets the CPR property if we do. + +That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where +(solely because the result was a product) we used a product demand +(albeit with lazy components) for the body. But that gives very silly +behaviour -- see #17932. Happily it turns out now to be entirely +unnecessary: we get good results with C(C(C(S))). So I simply +deleted the special case. +-} + +{- ********************************************************************* +* * + Fixpoints +* * +********************************************************************* -} + +-- Recursive bindings +dmdFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> CleanDemand + -> [(Id,CoreExpr)] + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info + +dmdFix top_lvl env let_dmd orig_pairs + = loop 1 initial_pairs + where + bndrs = map fst orig_pairs + + -- See Note [Initialising strictness] + initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + abort = (env, lazy_fv', zapped_pairs) + where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) + -- Note [Lazy and unleashable free variables] + non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' + lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs + zapped_pairs = zapIdStrictness pairs' + + -- The fixed-point varies the idStrictness field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id) + -- | (id,_)<- pairs]) $ + loop' n pairs + + loop' n pairs + | found_fixpoint = (final_anal_env, lazy_fv, pairs') + | n == 10 = abort + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs + first_round = n == 1 + (lazy_fv, pairs') = step first_round pairs + final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') + + step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) + step first_round pairs = (lazy_fv, pairs') + where + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) + + ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs + -- mapAccumL: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + + my_downRhs (env, lazy_fv) (id,rhs) + = ((env', lazy_fv'), (id', rhs')) + where + (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs + lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + env' = extendAnalEnv top_lvl env id sig + id' = setIdStrictness id sig + + zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] + zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, for two reasons: + + * To get information on used free variables (both lazy and strict!) + (see Note [Lazy and unleashable free variables]) + * To ensure that all expressions have been traversed at least once, and any left-over + strictness annotations have been updated. + +This final iteration does not add the variables to the strictness signature +environment, which effectively assigns them 'nopSig' (see "getStrictness") + +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two reasons we sometimes trim a demand to match a type. + 1. GADTs + 2. Recursive products and widening + +More on both below. But the botttom line is: we really don't want to +have a binder whose demand is more deeply-nested than its type +"allows". So in findBndrDmd we call trimToType and findTypeShape to +trim the demand on the binder to a form that matches the type + +Now to the reasons. For (1) consider + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a U(U,U) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, #8569). + +For (2) consider + data T = MkT Int T -- A recursive product + f :: Int -> T -> Int + f 0 _ = 0 + f _ (MkT n t) = f n t + +Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))). +Notice that this happens becuase T is a product type, and is recrusive. +If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, +and bale out entirely, which is inefficient and over-conservative. + +Worse, as we discovered in #18304, the size of the usages we compute +can grow /exponentially/, so even 10 iterations costs far too much. +Especially since we then discard the result. + +To avoid this we use the same findTypeShape function as for (1), but +arrange that it trims the demand if it encounters the same type constructor +twice (or three times, etc). We use our standard RecTcChecker mechanism +for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape. + +This is usually call "widening". We could do it just in dmdFix, but +since are doing this findTypeShape business /anyway/ because of (1), +and it has all the right information to hand, it's extremely +convenient to do it there. + +-} + +{- ********************************************************************* +* * + Strictness signatures and types +* * +********************************************************************* -} + +unitDmdType :: DmdEnv -> DmdType +unitDmdType dmd_env = DmdType dmd_env [] topDiv + +coercionDmdEnv :: Coercion -> DmdEnv +coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) + -- The VarSet from coVarsOfCo is really a VarEnv Var + +addVarDmd :: DmdType -> Var -> Demand -> DmdType +addVarDmd (DmdType fv ds res) var dmd + = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res + +addLazyFVs :: DmdType -> DmdEnv -> DmdType +addLazyFVs dmd_ty lazy_fvs + = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs + -- Using bothDmdType (rather than just both'ing the envs) + -- is vital. Consider + -- let f = \x -> (x,y) + -- in error (f 3) + -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L + -- demand with the bottom coming up from 'error' + -- + -- I got a loop in the fixpointer without this, due to an interaction + -- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was + -- letrec f n x + -- = letrec g y = x `fatbar` + -- letrec h z = z + ...g... + -- in h (f (n-1) x) + -- in ... + -- In the initial iteration for f, f=Bot + -- Suppose h is found to be strict in z, but the occurrence of g in its RHS + -- is lazy. Now consider the fixpoint iteration for g, esp the demands it + -- places on its free variables. Suppose it places none. Then the + -- x `fatbar` ...call to h... + -- will give a x->V demand for x. That turns into a L demand for x, + -- which floats out of the defn for h. Without the modifyEnv, that + -- L demand doesn't get both'd with the Bot coming up from the inner + -- call to f. So we just get an L demand for x for g. + +{- +Note [Do not strictify the argument dictionaries of a dfun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker can tie recursive knots involving dfuns, so we do the +conservative thing and refrain from strictifying a dfun's argument +dictionaries. +-} + +setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] +setBndrsDemandInfo (b:bs) ds + | isTyVar b = b : setBndrsDemandInfo bs ds +setBndrsDemandInfo (b:bs) (d:ds) = + let !new_info = setIdDemandInfo b d + !vars = setBndrsDemandInfo bs ds + in new_info : vars +setBndrsDemandInfo [] ds = ASSERT( null ds ) [] +setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) + +annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) +-- The returned env has the var deleted +-- The returned var is annotated with demand info +-- according to the result demand of the provided demand type +-- No effect on the argument demands +annotateBndr env dmd_ty var + | isId var = (dmd_ty', setIdDemandInfo var dmd) + | otherwise = (dmd_ty, var) + where + (dmd_ty', dmd) = findBndrDmd env False dmd_ty var + +annotateLamIdBndr :: AnalEnv + -> DFunFlag -- is this lambda at the top of the RHS of a dfun? + -> DmdType -- Demand type of body + -> Id -- Lambda binder + -> (DmdType, -- Demand type of lambda + Id) -- and binder annotated with demand + +annotateLamIdBndr env arg_of_dfun dmd_ty id +-- For lambdas we add the demand to the argument demands +-- Only called for Ids + = ASSERT( isId id ) + -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ + (final_ty, setIdDemandInfo id dmd) + where + -- Watch out! See note [Lambda-bound unfoldings] + final_ty = case maybeUnfoldingTemplate (idUnfolding id) of + Nothing -> main_ty + Just unf -> main_ty `bothDmdType` unf_ty + where + (unf_ty, _) = dmdAnalStar env dmd unf + + main_ty = addDemand dmd dmd_ty' + (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id + +{- Note [NOINLINE and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point we disabled strictness for NOINLINE functions, on the +grounds that they should be entirely opaque. But that lost lots of +useful semantic strictness information, so now we analyse them like +any other function, and pin strictness information on them. + +That in turn forces us to worker/wrapper them; see +Note [Worker-wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + + +Note [Lazy and unleashable free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We put the strict and once-used FVs in the DmdType of the Id, so +that at its call sites we unleash demands on its strict fvs. +An example is 'roll' in imaginary/wheel-sieve2 +Something like this: + roll x = letrec + go y = if ... then roll (x-1) else x+1 + in + go ms +We want to see that roll is strict in x, which is because +go is called. So we put the DmdEnv for x in go's DmdType. + +Another example: + + f :: Int -> Int -> Int + f x y = let t = x+1 + h z = if z==0 then t else + if z==1 then x+1 else + x + h (z-1) + in h y + +Calling h does indeed evaluate x, but we can only see +that if we unleash a demand on x at the call site for t. + +Incidentally, here's a place where lambda-lifting h would +lose the cigar --- we couldn't see the joint strictness in t/x + + ON THE OTHER HAND + +We don't want to put *all* the fv's from the RHS into the +DmdType. Because + + * it makes the strictness signatures larger, and hence slows down fixpointing + +and + + * it is useless information at the call site anyways: + For lazy, used-many times fv's we will never get any better result than + that, no matter how good the actual demand on the function at the call site + is (unless it is always absent, but then the whole binder is useless). + +Therefore we exclude lazy multiple-used fv's from the environment in the +DmdType. + +But now the signature lies! (Missing variables are assumed to be absent.) To +make up for this, the code that analyses the binding keeps the demand on those +variable separate (usually called "lazy_fv") and adds it to the demand of the +whole binding later. + +What if we decide _not_ to store a strictness signature for a binding at all, as +we do when aborting a fixed-point iteration? The we risk losing the information +that the strict variables are being used. In that case, we take all free variables +mentioned in the (unsound) strictness signature, conservatively approximate the +demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". + + +Note [Lambda-bound unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a lambda-bound variable to carry an unfolding, a facility that is used +exclusively for join points; see Note [Case binders and join points]. If so, +we must be careful to demand-analyse the RHS of the unfolding! Example + \x. \y{=Just x}. +Then if uses 'y', then transitively it uses 'x', and we must not +forget that fact, otherwise we might make 'x' absent when it isn't. + + +************************************************************************ +* * +\subsection{Strictness signatures} +* * +************************************************************************ +-} + +type DFunFlag = Bool -- indicates if the lambda being considered is in the + -- sequence of lambdas at the top of the RHS of a dfun +notArgOfDfun :: DFunFlag +notArgOfDfun = False + +{- Note [dmdAnalEnv performance] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It's tempting to think that removing the dynflags from AnalEnv would improve +performance. After all when analysing recursive groups we end up allocating +a lot of environments. However this is not the case. + +We do get some performance by making AnalEnv smaller. However very often we +defer computation which means we have to capture the dynflags in the thunks +we allocate. Doing this naively in practice causes more allocation than the +removal of DynFlags saves us. + +In theory it should be possible to make this better if we are stricter in +the analysis and therefore allocate fewer thunks. But I couldn't get there +in a few hours and overall the impact on GHC here is small, and there are +bigger fish to fry. So for new the env will keep a reference to the flags. +-} + +data AnalEnv + = AE { ae_dflags :: DynFlags -- See Note [dmdAnalEnv performance] + , ae_sigs :: SigEnv + , ae_virgin :: Bool -- True on first iteration only + -- See Note [Initialising strictness] + , ae_fam_envs :: FamInstEnvs + } + + -- We use the se_env to tell us whether to + -- record info about a variable in the DmdEnv + -- We do so if it's a LocalId, but not top-level + -- + -- The DmdEnv gives the demand on the free vars of the function + -- when it is given enough args to satisfy the strictness signature + +type SigEnv = VarEnv (StrictSig, TopLevelFlag) + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr virgin + , text "ae_sigs =" <+> ppr env ]) + +emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv +emptyAnalEnv dflags fam_envs + = AE { ae_dflags = dflags + , ae_sigs = emptySigEnv + , ae_virgin = True + , ae_fam_envs = fam_envs + } + +emptySigEnv :: SigEnv +emptySigEnv = emptyVarEnv + +-- | Extend an environment with the strictness IDs attached to the id +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv +extendAnalEnvs top_lvl env vars + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } + +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv +extendSigEnvs top_lvl sigs vars + = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars] + +extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv +extendAnalEnv top_lvl env var sig + = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } + +extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv +extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) + +lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) +-- Return the demands on the Ids in the [Var] +findBndrsDmds env dmd_ty bndrs + = go dmd_ty bndrs + where + go dmd_ty [] = (dmd_ty, []) + go dmd_ty (b:bs) + | isId b = let (dmd_ty1, dmds) = go dmd_ty bs + (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b + in (dmd_ty2, dmd : dmds) + | otherwise = go dmd_ty bs + +findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) +-- See Note [Trimming a demand to a type] +findBndrDmd env arg_of_dfun dmd_ty id + = (dmd_ty', dmd') + where + dmd' = strictify $ + trimToType starting_dmd (findTypeShape fam_envs id_ty) + + (dmd_ty', starting_dmd) = peelFV dmd_ty id + + id_ty = idType id + + strictify dmd + | gopt Opt_DictsStrict (ae_dflags env) + -- We never want to strictify a recursive let. At the moment + -- annotateBndr is only call for non-recursive lets; if that + -- changes, we need a RecFlag parameter and another guard here. + , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] + = strictifyDictDmd id_ty dmd + | otherwise + = dmd + + fam_envs = ae_fam_envs env + +{- Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See section 9.2 (Finding fixpoints) of the paper. + +Our basic plan is to initialise the strictness of each Id in a +recursive group to "bottom", and find a fixpoint from there. However, +this group B might be inside an *enclosing* recursive group A, in +which case we'll do the entire fixpoint shebang on for each iteration +of A. This can be illustrated by the following example: + +Example: + + f [] = [] + f (x:xs) = let g [] = f xs + g (y:ys) = y+1 : g ys + in g (h x) + +At each iteration of the fixpoint for f, the analyser has to find a +fixpoint for the enclosed function g. In the meantime, the demand +values for g at each iteration for f are *greater* than those we +encountered in the previous iteration for f. Therefore, we can begin +the fixpoint for g not with the bottom value but rather with the +result of the previous analysis. I.e., when beginning the fixpoint +process for g, we can start from the demand signature computed for g +previously and attached to the binding occurrence of g. + +To speed things up, we initialise each iteration of A (the enclosing +one) from the result of the last one, which is neatly recorded in each +binder. That way we make use of earlier iterations of the fixpoint +algorithm. (Cunning plan.) + +But on the *first* iteration we want to *ignore* the current strictness +of the Id, and start from "bottom". Nowadays the Id can have a current +strictness, because interface files record strictness for nested bindings. +To know when we are in the first iteration, we look at the ae_virgin +field of the AnalEnv. + + +Note [Final Demand Analyser run] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the information that the demand analyser determines is not always +preserved by the simplifier. For example, the simplifier will happily rewrite + \y [Demand=1*U] let x = y in x + x +to + \y [Demand=1*U] y + y +which is quite a lie. + +The once-used information is (currently) only used by the code +generator, though. So: + + * We zap the used-once info in the worker-wrapper; + see Note [Zapping Used Once info in WorkWrap] in + GHC.Core.Opt.WorkWrap. + If it's not reliable, it's better not to have it at all. + + * Just before TidyCore, we add a pass of the demand analyser, + but WITHOUT subsequent worker/wrapper and simplifier, + right before TidyCore. See SimplCore.getCoreToDo. + + This way, correct information finds its way into the module interface + (strictness signatures!) and the code generator (single-entry thunks!) + +Note that, in contrast, the single-call information (C1(..)) /can/ be +relied upon, as the simplifier tends to be very careful about not +duplicating actual function calls. + +Also see #11731. +-} diff --git a/GHC/Core/Opt/Exitify.hs b/GHC/Core/Opt/Exitify.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Exitify.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE PatternSynonyms #-} + +module GHC.Core.Opt.Exitify ( exitifyProgram ) where + +{- +Note [Exitification] +~~~~~~~~~~~~~~~~~~~~ + +This module implements Exitification. The goal is to pull as much code out of +recursive functions as possible, as the simplifier is better at inlining into +call-sites that are not in recursive functions. + +Example: + + let t = foo bar + joinrec go 0 x y = t (x*x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +We’d like to inline `t`, but that does not happen: Because t is a thunk and is +used in a recursive function, doing so might lose sharing in general. In +this case, however, `t` is on the _exit path_ of `go`, so called at most once. +How do we make this clearly visible to the simplifier? + +A code path (i.e., an expression in a tail-recursive position) in a recursive +function is an exit path if it does not contain a recursive call. We can bind +this expression outside the recursive function, as a join-point. + +Example result: + + let t = foo bar + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +Now `t` is no longer in a recursive function, and good things happen! +-} + +import GHC.Prelude +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core +import GHC.Core.Utils +import GHC.Utils.Monad.State +import GHC.Types.Unique +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.FVs +import GHC.Data.FastString +import GHC.Core.Type +import GHC.Utils.Misc( mapSnd ) + +import Data.Bifunctor +import Control.Monad + +-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them. +-- The really interesting function is exitifyRec +exitifyProgram :: CoreProgram -> CoreProgram +exitifyProgram binds = map goTopLvl binds + where + goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e) + goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs) + -- Top-level bindings are never join points + + in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds + + go :: InScopeSet -> CoreExpr -> CoreExpr + go _ e@(Var{}) = e + go _ e@(Lit {}) = e + go _ e@(Type {}) = e + go _ e@(Coercion {}) = e + go in_scope (Cast e' c) = Cast (go in_scope e') c + go in_scope (Tick t e') = Tick t (go in_scope e') + go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2) + + go in_scope (Lam v e') + = Lam v (go in_scope' e') + where in_scope' = in_scope `extendInScopeSet` v + + go in_scope (Case scrut bndr ty alts) + = Case (go in_scope scrut) bndr ty (map go_alt alts) + where + in_scope1 = in_scope `extendInScopeSet` bndr + go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs) + where in_scope' = in_scope1 `extendInScopeSetList` pats + + go in_scope (Let (NonRec bndr rhs) body) + = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body) + where + in_scope' = in_scope `extendInScopeSet` bndr + + go in_scope (Let (Rec pairs) body) + | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' + | otherwise = Let (Rec pairs') body' + where + is_join_rec = any (isJoinId . fst) pairs + in_scope' = in_scope `extendInScopeSetList` bindersOf (Rec pairs) + pairs' = mapSnd (go in_scope') pairs + body' = go in_scope' body + + +-- | State Monad used inside `exitify` +type ExitifyM = State [(JoinId, CoreExpr)] + +-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as +-- join-points outside the joinrec. +exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] +exitifyRec in_scope pairs + = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] + where + -- We need the set of free variables of many subexpressions here, so + -- annotate the AST with them + -- see Note [Calculating free variables] + ann_pairs = map (second freeVars) pairs + + -- Which are the recursive calls? + recursive_calls = mkVarSet $ map fst pairs + + (pairs',exits) = (`runState` []) $ do + forM ann_pairs $ \(x,rhs) -> do + -- go past the lambdas of the join point + let (args, body) = collectNAnnBndrs (idJoinArity x) rhs + body' <- go args body + let rhs' = mkLams args body' + return (x, rhs') + + --------------------- + -- 'go' is the main working function. + -- It goes through the RHS (tail-call positions only), + -- checks if there are no more recursive calls, if so, abstracts over + -- variables bound on the way and lifts it out as a join point. + -- + -- ExitifyM is a state monad to keep track of floated binds + go :: [Var] -- ^ Variables that are in-scope here, but + -- not in scope at the joinrec; that is, + -- we must potentially abstract over them. + -- Invariant: they are kept in dependency order + -> CoreExprWithFVs -- ^ Current expression in tail position + -> ExitifyM CoreExpr + + -- We first look at the expression (no matter what it shape is) + -- and determine if we can turn it into a exit join point + go captured ann_e + | -- An exit expression has no recursive calls + let fvs = dVarSetToVarSet (freeVarsOf ann_e) + , disjointVarSet fvs recursive_calls + = go_exit captured (deAnnotate ann_e) fvs + + -- We could not turn it into a exit join point. So now recurse + -- into all expression where eligible exit join points might sit, + -- i.e. into all tail-call positions: + + -- Case right hand sides are in tail-call position + go captured (_, AnnCase scrut bndr ty alts) = do + alts' <- forM alts $ \(dc, pats, rhs) -> do + rhs' <- go (captured ++ [bndr] ++ pats) rhs + return (dc, pats, rhs') + return $ Case (deAnnotate scrut) bndr ty alts' + + go captured (_, AnnLet ann_bind body) + -- join point, RHS and body are in tail-call position + | AnnNonRec j rhs <- ann_bind + , Just join_arity <- isJoinId_maybe j + = do let (params, join_body) = collectNAnnBndrs join_arity rhs + join_body' <- go (captured ++ params) join_body + let rhs' = mkLams params join_body' + body' <- go (captured ++ [j]) body + return $ Let (NonRec j rhs') body' + + -- rec join point, RHSs and body are in tail-call position + | AnnRec pairs <- ann_bind + , isJoinId (fst (head pairs)) + = do let js = map fst pairs + pairs' <- forM pairs $ \(j,rhs) -> do + let join_arity = idJoinArity j + (params, join_body) = collectNAnnBndrs join_arity rhs + join_body' <- go (captured ++ js ++ params) join_body + let rhs' = mkLams params join_body' + return (j, rhs') + body' <- go (captured ++ js) body + return $ Let (Rec pairs') body' + + -- normal Let, only the body is in tail-call position + | otherwise + = do body' <- go (captured ++ bindersOf bind ) body + return $ Let bind body' + where bind = deAnnBind ann_bind + + -- Cannot be turned into an exit join point, but also has no + -- tail-call subexpression. Nothing to do here. + go _ ann_e = return (deAnnotate ann_e) + + --------------------- + go_exit :: [Var] -- Variables captured locally + -> CoreExpr -- An exit expression + -> VarSet -- Free vars of the expression + -> ExitifyM CoreExpr + -- go_exit deals with a tail expression that is floatable + -- out as an exit point; that is, it mentions no recursive calls + go_exit captured e fvs + -- Do not touch an expression that is already a join jump where all arguments + -- are captured variables. See Note [Idempotency] + -- But _do_ float join jumps with interesting arguments. + -- See Note [Jumps can be interesting] + | (Var f, args) <- collectArgs e + , isJoinId f + , all isCapturedVarArg args + = return e + + -- Do not touch a boring expression (see Note [Interesting expression]) + | not is_interesting + = return e + + -- Cannot float out if local join points are used, as + -- we cannot abstract over them + | captures_join_points + = return e + + -- We have something to float out! + | otherwise + = do { -- Assemble the RHS of the exit join point + let rhs = mkLams abs_vars e + avoid = in_scope `extendInScopeSetList` captured + -- Remember this binding under a suitable name + ; v <- addExit avoid (length abs_vars) rhs + -- And jump to it from here + ; return $ mkVarApps (Var v) abs_vars } + + where + -- Used to detect exit expressions that are already proper exit jumps + isCapturedVarArg (Var v) = v `elem` captured + isCapturedVarArg _ = False + + -- An interesting exit expression has free, non-imported + -- variables from outside the recursive group + -- See Note [Interesting expression] + is_interesting = anyVarSet isLocalId $ + fvs `minusVarSet` mkVarSet captured + + -- The arguments of this exit join point + -- See Note [Picking arguments to abstract over] + abs_vars = snd $ foldr pick (fvs, []) captured + where + pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc) + | otherwise = (fvs', acc) + + -- We are going to abstract over these variables, so we must + -- zap any IdInfo they have; see #15005 + -- cf. GHC.Core.Opt.SetLevels.abstractVars + zap v | isId v = setIdInfo v vanillaIdInfo + | otherwise = v + + -- We cannot abstract over join points + captures_join_points = any isJoinId abs_vars + + +-- Picks a new unique, which is disjoint from +-- * the free variables of the whole joinrec +-- * any bound variables (captured) +-- * any exit join points created so far. +mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId +mkExitJoinId in_scope ty join_arity = do + fs <- get + let avoid = in_scope `extendInScopeSetList` (map fst fs) + `extendInScopeSet` exit_id_tmpl -- just cosmetics + return (uniqAway avoid exit_id_tmpl) + where + exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty + `asJoinId` join_arity + +addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope join_arity rhs = do + -- Pick a suitable name + let ty = exprType rhs + v <- mkExitJoinId in_scope ty join_arity + fs <- get + put ((v,rhs):fs) + return v + +{- +Note [Interesting expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want this to happen: + + joinrec go 0 x y = x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = x + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +because the floated exit path (`x`) is simply a parameter of `go`; there are +not useful interactions exposed this way. + +Neither do we want this to happen + + joinrec go 0 x y = x+x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = x+x + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +where the floated expression `x+x` is a bit more complicated, but still not +intersting. + +Expressions are interesting when they move an occurrence of a variable outside +the recursive `go` that can benefit from being obviously called once, for example: + * a local thunk that can then be inlined (see example in note [Exitification]) + * the parameter of a function, where the demand analyzer then can then + see that it is called at most once, and hence improve the function’s + strictness signature + +So we only hoist an exit expression out if it mentiones at least one free, +non-imported variable. + +Note [Jumps can be interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A jump to a join point can be interesting, if its arguments contain free +non-exported variables (z in the following example): + + joinrec go 0 x y = jump j (x+z) + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x y = jump j (x+z) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + + +The join point itself can be interesting, even if none if its +arguments have free variables free in the joinrec. For example + + join j p = case p of (x,y) -> x+y + joinrec go 0 x y = jump j (x,y) + go (n-1) x y = jump go (n-1) (x+y) y + in … + +Here, `j` would not be inlined because we do not inline something that looks +like an exit join point (see Note [Do not inline exit join points]). But +if we exitify the 'jump j (x,y)' we get + + join j p = case p of (x,y) -> x+y + join exit x y = jump j (x,y) + joinrec go 0 x y = jump exit x y + go (n-1) x y = jump go (n-1) (x+y) y + in … + +and now 'j' can inline, and we get rid of the pair. Here's another +example (assume `g` to be an imported function that, on its own, +does not make this interesting): + + join j y = map f y + joinrec go 0 x y = jump j (map g x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +Again, `j` would not be inlined because we do not inline something that looks +like an exit join point (see Note [Do not inline exit join points]). + +But after exitification we have + + join j y = map f y + join exit x = jump j (map g x) + joinrec go 0 x y = jump j (map g x) + go (n-1) x y = jump go (n-1) (x+y) + in … + +and now we can inline `j` and this will allow `map/map` to fire. + + +Note [Idempotency] +~~~~~~~~~~~~~~~~~~ + +We do not want this to happen, where we replace the floated expression with +essentially the same expression: + + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … +==> + join exit x = t (x*x) + join exit' x = jump exit x + joinrec go 0 x y = jump exit' x + go (n-1) x y = jump go (n-1) (x+y) + in … + +So when the RHS is a join jump, and all of its arguments are captured variables, +then we leave it in place. + +Note that `jump exit x` in this example looks interesting, as `exit` is a free +variable. Therefore, idempotency does not simply follow from floating only +interesting expressions. + +Note [Calculating free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have two options where to annotate the tree with free variables: + + A) The whole tree. + B) Each individual joinrec as we come across it. + +Downside of A: We pay the price on the whole module, even outside any joinrecs. +Downside of B: We pay the price per joinrec, possibly multiple times when +joinrecs are nested. + +Further downside of A: If the exitify function returns annotated expressions, +it would have to ensure that the annotations are correct. + +We therefore choose B, and calculate the free variables in `exitify`. + + +Note [Do not inline exit join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + + let t = foo bar + join exit x = t (x*x) + joinrec go 0 x y = jump exit x + go (n-1) x y = jump go (n-1) (x+y) + in … + +we do not want the simplifier to simply inline `exit` back in (which it happily +would). + +To prevent this, we need to recognize exit join points, and then disable +inlining. + +Exit join points, recognizeable using `isExitJoinId` are join points with an +occurrence in a recursive group, and can be recognized (after the occurrence +analyzer ran!) using `isExitJoinId`. +This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, +because the lambdas of a non-recursive join point are not considered for +`occ_in_lam`. For example, in the following code, `j1` is /not/ marked +occ_in_lam, because `j2` is called only once. + + join j1 x = x+1 + join j2 y = join j1 (y+2) + +To prevent inlining, we check for isExitJoinId +* In `preInlineUnconditionally` directly. +* In `simplLetUnfolding` we simply give exit join points no unfolding, which + prevents inlining in `postInlineUnconditionally` and call sites. + +Note [Placement of the exitification pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I (Joachim) experimented with multiple positions for the Exitification pass in +the Core2Core pipeline: + + A) Before the `simpl_phases` + B) Between the `simpl_phases` and the "main" simplifier pass + C) After demand_analyser + D) Before the final simplification phase + +Here is the table (this is without inlining join exit points in the final +simplifier run): + + Program | Allocs | Instrs + | ABCD.log A.log B.log C.log D.log | ABCD.log A.log B.log C.log D.log +----------------|---------------------------------------------------|------------------------------------------------- + fannkuch-redux | -99.9% +0.0% -99.9% -99.9% -99.9% | -3.9% +0.5% -3.0% -3.9% -3.9% + fasta | -0.0% +0.0% +0.0% -0.0% -0.0% | -8.5% +0.0% +0.0% -0.0% -8.5% + fem | 0.0% 0.0% 0.0% 0.0% +0.0% | -2.2% -0.1% -0.1% -2.1% -2.1% + fish | 0.0% 0.0% 0.0% 0.0% +0.0% | -3.1% +0.0% -1.1% -1.1% -0.0% + k-nucleotide | -91.3% -91.0% -91.0% -91.3% -91.3% | -6.3% +11.4% +11.4% -6.3% -6.2% + scs | -0.0% -0.0% -0.0% -0.0% -0.0% | -3.4% -3.0% -3.1% -3.3% -3.3% + simple | -6.0% 0.0% -6.0% -6.0% +0.0% | -3.4% +0.0% -5.2% -3.4% -0.1% + spectral-norm | -0.0% 0.0% 0.0% -0.0% +0.0% | -2.7% +0.0% -2.7% -5.4% -5.4% +----------------|---------------------------------------------------|------------------------------------------------- + Min | -95.0% -91.0% -95.0% -95.0% -95.0% | -8.5% -3.0% -5.2% -6.3% -8.5% + Max | +0.2% +0.2% +0.2% +0.2% +1.5% | +0.4% +11.4% +11.4% +0.4% +1.5% + Geometric Mean | -4.7% -2.1% -4.7% -4.7% -4.6% | -0.4% +0.1% -0.1% -0.3% -0.2% + +Position A is disqualified, as it does not get rid of the allocations in +fannkuch-redux. +Position A and B are disqualified because it increases instructions in k-nucleotide. +Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta. + +Assuming we have a budget of _one_ run of Exitification, then C wins (but we +could get more from running it multiple times, as seen in fish). + +Note [Picking arguments to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When we create an exit join point, so we need to abstract over those of its +free variables that are be out-of-scope at the destination of the exit join +point. So we go through the list `captured` and pick those that are actually +free variables of the join point. + +We do not just `filter (`elemVarSet` fvs) captured`, as there might be +shadowing, and `captured` may contain multiple variables with the same Unique. I +these cases we want to abstract only over the last occurrence, hence the `foldr` +(with emphasis on the `r`). This is #15110. + +-} diff --git a/GHC/Core/Opt/FloatIn.hs b/GHC/Core/Opt/FloatIn.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/FloatIn.hs @@ -0,0 +1,781 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[FloatIn]{Floating Inwards pass} +* * +************************************************************************ + +The main purpose of @floatInwards@ is floating into branches of a +case, so that we don't allocate things, save them on the stack, and +then discover that they aren't needed in the chosen branch. +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fprof-auto #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.FloatIn ( floatInwards ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Core +import GHC.Core.Make hiding ( wrapFloats ) +import GHC.Driver.Types ( ModGuts(..) ) +import GHC.Core.Utils +import GHC.Core.FVs +import GHC.Core.Opt.Monad ( CoreM ) +import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) +import GHC.Types.Var +import GHC.Core.Type +import GHC.Types.Var.Set +import GHC.Utils.Misc +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Types.Basic ( RecFlag(..), isRec ) + +{- +Top-level interface function, @floatInwards@. Note that we do not +actually float any bindings downwards from the top-level. +-} + +floatInwards :: ModGuts -> CoreM ModGuts +floatInwards pgm@(ModGuts { mg_binds = binds }) + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) } + where + fi_top_bind platform (NonRec binder rhs) + = NonRec binder (fiExpr platform [] (freeVars rhs)) + fi_top_bind platform (Rec pairs) + = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ] + + +{- +************************************************************************ +* * +\subsection{Mail from Andr\'e [edited]} +* * +************************************************************************ + +{\em Will wrote: What??? I thought the idea was to float as far +inwards as possible, no matter what. This is dropping all bindings +every time it sees a lambda of any kind. Help! } + +You are assuming we DO DO full laziness AFTER floating inwards! We +have to [not float inside lambdas] if we don't. + +If we indeed do full laziness after the floating inwards (we could +check the compilation flags for that) then I agree we could be more +aggressive and do float inwards past lambdas. + +Actually we are not doing a proper full laziness (see below), which +was another reason for not floating inwards past a lambda. + +This can easily be fixed. The problem is that we float lets outwards, +but there are a few expressions which are not let bound, like case +scrutinees and case alternatives. After floating inwards the +simplifier could decide to inline the let and the laziness would be +lost, e.g. + +\begin{verbatim} +let a = expensive ==> \b -> case expensive of ... +in \ b -> case a of ... +\end{verbatim} +The fix is +\begin{enumerate} +\item +to let bind the algebraic case scrutinees (done, I think) and +the case alternatives (except the ones with an +unboxed type)(not done, I think). This is best done in the +GHC.Core.Opt.SetLevels module, which tags things with their level numbers. +\item +do the full laziness pass (floating lets outwards). +\item +simplify. The simplifier inlines the (trivial) lets that were + created but were not floated outwards. +\end{enumerate} + +With the fix I think Will's suggestion that we can gain even more from +strictness by floating inwards past lambdas makes sense. + +We still gain even without going past lambdas, as things may be +strict in the (new) context of a branch (where it was floated to) or +of a let rhs, e.g. +\begin{verbatim} +let a = something case x of +in case x of alt1 -> case something of a -> a + a + alt1 -> a + a ==> alt2 -> b + alt2 -> b + +let a = something let b = case something of a -> a + a +in let b = a + a ==> in (b,b) +in (b,b) +\end{verbatim} +Also, even if a is not found to be strict in the new context and is +still left as a let, if the branch is not taken (or b is not entered) +the closure for a is not built. + +************************************************************************ +* * +\subsection{Main floating-inwards code} +* * +************************************************************************ +-} + +type FreeVarSet = DIdSet +type BoundVarSet = DIdSet + +data FloatInBind = FB BoundVarSet FreeVarSet FloatBind + -- The FreeVarSet is the free variables of the binding. In the case + -- of recursive bindings, the set doesn't include the bound + -- variables. + +type FloatInBinds = [FloatInBind] + -- In reverse dependency order (innermost binder first) + +fiExpr :: Platform + -> FloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result + +fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) + -- See Note [Dead bindings] +fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) +fiExpr platform to_drop (_, AnnCast expr (co_ann, co)) + = wrapFloats (drop_here ++ co_drop) $ + Cast (fiExpr platform e_drop expr) co + where + [drop_here, e_drop, co_drop] + = sepBindsByDropPoint platform False + [freeVarsOf expr, freeVarsOfAnn co_ann] + to_drop + +{- +Applications: we do float inside applications, mainly because we +need to get at all the arguments. The next simplifier run will +pull out any silly ones. +-} + +fiExpr platform to_drop ann_expr@(_,AnnApp {}) + = wrapFloats drop_here $ wrapFloats extra_drop $ + mkTicks ticks $ + mkApps (fiExpr platform fun_drop ann_fun) + (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args) + -- use zipWithEqual, we should have + -- length ann_args = length arg_fvs = length arg_drops + where + (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr + fun_ty = exprType (deAnnotate ann_fun) + fun_fvs = freeVarsOf ann_fun + arg_fvs = map freeVarsOf ann_args + + (drop_here : extra_drop : fun_drop : arg_drops) + = sepBindsByDropPoint platform False + (extra_fvs : fun_fvs : arg_fvs) + to_drop + -- Shortcut behaviour: if to_drop is empty, + -- sepBindsByDropPoint returns a suitable bunch of empty + -- lists without evaluating extra_fvs, and hence without + -- peering into each argument + + (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args + extra_fvs0 = case ann_fun of + (_, AnnVar _) -> fun_fvs + _ -> emptyDVarSet + -- Don't float the binding for f into f x y z; see Note [Join points] + -- for why we *can't* do it when f is a join point. (If f isn't a + -- join point, floating it in isn't especially harmful but it's + -- useless since the simplifier will immediately float it back out.) + + add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet) + add_arg (fun_ty, extra_fvs) (_, AnnType ty) + = (piResultTy fun_ty ty, extra_fvs) + + add_arg (fun_ty, extra_fvs) (arg_fvs, arg) + | noFloatIntoArg arg arg_ty + = (res_ty, extra_fvs `unionDVarSet` arg_fvs) + | otherwise + = (res_ty, extra_fvs) + where + (_, arg_ty, res_ty) = splitFunTy fun_ty + +{- Note [Dead bindings] +~~~~~~~~~~~~~~~~~~~~~~~ +At a literal we won't usually have any floated bindings; the +only way that can happen is if the binding wrapped the literal +/in the original input program/. e.g. + case x of { DEFAULT -> 1# } +But, while this may be unusual it is not actually wrong, and it did +once happen (#15696). + +Note [Do not destroy the let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Watch out for + f (x +# y) +We don't want to float bindings into here + f (case ... of { x -> x +# y }) +because that might destroy the let/app invariant, which requires +unlifted function arguments to be ok-for-speculation. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +Generally, we don't need to worry about join points - there are places we're +not allowed to float them, but since they can't have occurrences in those +places, we're not tempted. + +We do need to be careful about jumps, however: + + joinrec j x y z = ... in + jump j a b c + +Previous versions often floated the definition of a recursive function into its +only non-recursive occurrence. But for a join point, this is a disaster: + + (joinrec j x y z = ... in + jump j) a b c -- wrong! + +Every jump must be exact, so the jump to j must have three arguments. Hence +we're careful not to float into the target of a jump (though we can float into +the arguments just fine). + +Note [Floating in past a lambda group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We must be careful about floating inside a value lambda. + That risks losing laziness. + The float-out pass might rescue us, but then again it might not. + +* We must be careful about type lambdas too. At one time we did, and + there is no risk of duplicating work thereby, but we do need to be + careful. In particular, here is a bad case (it happened in the + cichelli benchmark: + let v = ... + in let f = /\t -> \a -> ... + ==> + let f = /\t -> let v = ... in \a -> ... + This is bad as now f is an updatable closure (update PAP) + and has arity 0. + +* Hack alert! We only float in through one-shot lambdas, + not (as you might guess) through lone big lambdas. + Reason: we float *out* past big lambdas (see the test in the Lam + case of FloatOut.floatExpr) and we don't want to float straight + back in again. + + It *is* important to float into one-shot lambdas, however; + see the remarks with noFloatIntoRhs. + +So we treat lambda in groups, using the following rule: + + Float in if (a) there is at least one Id, + and (b) there are no non-one-shot Ids + + Otherwise drop all the bindings outside the group. + +This is what the 'go' function in the AnnLam case is doing. + +(Join points are handled similarly: a join point is considered one-shot iff +it's non-recursive, so we float only into non-recursive join points.) + +Urk! if all are tyvars, and we don't float in, we may miss an + opportunity to float inside a nested case branch + + +Note [Floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We could, in principle, have a coercion binding like + case f x of co { DEFAULT -> e1 e2 } +It's not common to have a function that returns a coercion, but nothing +in Core prohibits it. If so, 'co' might be mentioned in e1 or e2 +/only in a type/. E.g. suppose e1 was + let (x :: Int |> co) = blah in blah2 + + +But, with coercions appearing in types, there is a complication: we +might be floating in a "strict let" -- that is, a case. Case expressions +mention their return type. We absolutely can't float a coercion binding +inward to the point that the type of the expression it's about to wrap +mentions the coercion. So we include the union of the sets of free variables +of the types of all the drop points involved. If any of the floaters +bind a coercion variable mentioned in any of the types, that binder must +be dropped right away. + +-} + +fiExpr platform to_drop lam@(_, AnnLam _ _) + | noFloatIntoLam bndrs -- Dump it all here + -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088 + = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) + + | otherwise -- Float inside + = mkLams bndrs (fiExpr platform to_drop body) + + where + (bndrs, body) = collectAnnBndrs lam + +{- +We don't float lets inwards past an SCC. + ToDo: keep info on current cc, and when passing + one, if it is not the same, annotate all lets in binds with current + cc, change current cc to the new one and float binds into expr. +-} + +fiExpr platform to_drop (_, AnnTick tickish expr) + | tickish `tickishScopesLike` SoftScope + = Tick tickish (fiExpr platform to_drop expr) + + | otherwise -- Wimp out for now - we could push values in + = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr)) + +{- +For @Lets@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, +or~(b2), in each of the RHSs of the pairs of a @Rec@. + +Note that we do {\em weird things} with this let's binding. Consider: +\begin{verbatim} +let + w = ... +in { + let v = ... w ... + in ... v .. w ... +} +\end{verbatim} +Look at the inner \tr{let}. As \tr{w} is used in both the bind and +body of the inner let, we could panic and leave \tr{w}'s binding where +it is. But \tr{v} is floatable further into the body of the inner let, and +{\em then} \tr{w} will also be only in the body of that inner let. + +So: rather than drop \tr{w}'s binding here, we add it onto the list of +things to drop in the outer let's body, and let nature take its +course. + +Note [extra_fvs (1): avoid floating into RHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider let x=\y....t... in body. We do not necessarily want to float +a binding for t into the RHS, because it'll immediately be floated out +again. (It won't go inside the lambda else we risk losing work.) +In letrec, we need to be more careful still. We don't want to transform + let x# = y# +# 1# + in + letrec f = \z. ...x#...f... + in ... +into + letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... +because now we can't float the let out again, because a letrec +can't have unboxed bindings. + +So we make "extra_fvs" which is the rhs_fvs of such bindings, and +arrange to dump bindings that bind extra_fvs before the entire let. + +Note [extra_fvs (2): free variables of rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x{rule mentioning y} = rhs in body +Here y is not free in rhs or body; but we still want to dump bindings +that bind y outside the let. So we augment extra_fvs with the +idRuleAndUnfoldingVars of x. No need for type variables, hence not using +idFreeVars. +-} + +fiExpr platform to_drop (_,AnnLet bind body) + = fiExpr platform (after ++ new_float : before) body + -- to_drop is in reverse dependency order + where + (before, new_float, after) = fiBind platform to_drop bind body_fvs + body_fvs = freeVarsOf body + +{- Note [Floating primops] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try to float-in a case expression over an unlifted type. The +motivating example was #5658: in particular, this change allows +array indexing operations, which have a single DEFAULT alternative +without any binders, to be floated inward. + +SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed +scalars also need to be floated inward, but unpacks have a single non-DEFAULT +alternative that binds the elements of the tuple. We now therefore also support +floating in cases with a single alternative that may bind values. + +But there are wrinkles + +* Which unlifted cases do we float? + See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which + explains: + - We can float in can_fail primops (which concerns imprecise exceptions), + but we can't float them out. + - But we can float a has_side_effects primop, but NOT inside a lambda, + so for now we don't float them at all. Hence exprOkForSideEffects. + - Throwing precise exceptions is a special case of the previous point: We + may /never/ float in a call to (something that ultimately calls) + 'raiseIO#'. + See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. + +* Because we can float can-fail primops (array indexing, division) inwards + but not outwards, we must be careful not to transform + case a /# b of r -> f (F# r) + ===> + f (case a /# b of r -> F# r) + because that creates a new thunk that wasn't there before. And + because it can't be floated out (can_fail), the thunk will stay + there. Disaster! (This happened in nofib 'simple' and 'scs'.) + + Solution: only float cases into the branches of other cases, and + not into the arguments of an application, or the RHS of a let. This + is somewhat conservative, but it's simple. And it still hits the + cases like #5658. This is implemented in sepBindsByJoinPoint; + if is_case is False we dump all floating cases right here. + +* #14511 is another example of why we want to restrict float-in + of case-expressions. Consider + case indexArray# a n of (# r #) -> writeArray# ma i (f r) + Now, floating that indexing operation into the (f r) thunk will + not create any new thunks, but it will keep the array 'a' alive + for much longer than the programmer expected. + + So again, not floating a case into a let or argument seems like + the Right Thing + +For @Case@, the possible drop points for the 'to_drop' +bindings are: + (a) inside the scrutinee + (b) inside one of the alternatives/default (default FVs always /first/!). + +-} + +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) + | isUnliftedType (idType case_bndr) + , exprOkForSideEffects (deAnnotate scrut) + -- See Note [Floating primops] + = wrapFloats shared_binds $ + fiExpr platform (case_float : rhs_binds) rhs + where + case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs + (FloatCase scrut' case_bndr con alt_bndrs) + scrut' = fiExpr platform scrut_binds scrut + rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) + scrut_fvs = freeVarsOf scrut + + [shared_binds, scrut_binds, rhs_binds] + = sepBindsByDropPoint platform False + [scrut_fvs, rhs_fvs] + to_drop + +fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) + = wrapFloats drop_here1 $ + wrapFloats drop_here2 $ + Case (fiExpr platform scrut_drops scrut) case_bndr ty + (zipWithEqual "fiExpr" fi_alt alts_drops_s alts) + -- use zipWithEqual, we should have length alts_drops_s = length alts + where + -- Float into the scrut and alts-considered-together just like App + [drop_here1, scrut_drops, alts_drops] + = sepBindsByDropPoint platform False + [scrut_fvs, all_alts_fvs] + to_drop + + -- Float into the alts with the is_case flag set + (drop_here2 : alts_drops_s) + | [ _ ] <- alts = [] : [alts_drops] + | otherwise = sepBindsByDropPoint platform True alts_fvs alts_drops + + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + all_alts_fvs = unionDVarSets alts_fvs + alt_fvs (_con, args, rhs) + = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) + -- Delete case_bndr and args from free vars of rhs + -- to get free vars of alt + + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs) + +------------------ +fiBind :: Platform + -> FloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreBindWithFVs -- Input binding + -> DVarSet -- Free in scope of binding + -> ( FloatInBinds -- Land these before + , FloatInBind -- The binding itself + , FloatInBinds) -- Land these after + +fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs + = ( extra_binds ++ shared_binds -- Land these before + -- See Note [extra_fvs (1,2)] + , FB (unitDVarSet id) rhs_fvs' -- The new binding itself + (FloatLet (NonRec id rhs')) + , body_binds ) -- Land these after + + where + body_fvs2 = body_fvs `delDVarSet` id + + rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] + extra_fvs | noFloatIntoRhs NonRecursive id rhs + = rule_fvs `unionDVarSet` rhs_fvs + | otherwise + = rule_fvs + -- See Note [extra_fvs (1): avoid floating into RHS] + -- No point in floating in only to float straight out again + -- We *can't* float into ok-for-speculation unlifted RHSs + -- But do float into join points + + [shared_binds, extra_binds, rhs_binds, body_binds] + = sepBindsByDropPoint platform False + [extra_fvs, rhs_fvs, body_fvs2] + to_drop + + -- Push rhs_binds into the right hand side of the binding + rhs' = fiRhs platform rhs_binds id ann_rhs + rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs + -- Don't forget the rule_fvs; the binding mentions them! + +fiBind platform to_drop (AnnRec bindings) body_fvs + = ( extra_binds ++ shared_binds + , FB (mkDVarSet ids) rhs_fvs' + (FloatLet (Rec (fi_bind rhss_binds bindings))) + , body_binds ) + where + (ids, rhss) = unzip bindings + rhss_fvs = map freeVarsOf rhss + + -- See Note [extra_fvs (1,2)] + rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids + extra_fvs = rule_fvs `unionDVarSet` + unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings + , noFloatIntoRhs Recursive bndr rhs ] + + (shared_binds:extra_binds:body_binds:rhss_binds) + = sepBindsByDropPoint platform False + (extra_fvs:body_fvs:rhss_fvs) + to_drop + + rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` + unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` + rule_fvs -- Don't forget the rule variables! + + -- Push rhs_binds into the right hand side of the binding + fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + -> [(Id, CoreExprWithFVs)] + -> [(Id, CoreExpr)] + + fi_bind to_drops pairs + = [ (binder, fiRhs platform to_drop binder rhs) + | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] + +------------------ +fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr +fiRhs platform to_drop bndr rhs + | Just join_arity <- isJoinId_maybe bndr + , let (bndrs, body) = collectNAnnBndrs join_arity rhs + = mkLams bndrs (fiExpr platform to_drop body) + | otherwise + = fiExpr platform to_drop rhs + +------------------ +noFloatIntoLam :: [Var] -> Bool +noFloatIntoLam bndrs = any bad bndrs + where + bad b = isId b && not (isOneShotBndr b) + -- Don't float inside a non-one-shot lambda + +noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool +-- ^ True if it's a bad idea to float bindings into this RHS +noFloatIntoRhs is_rec bndr rhs + | isJoinId bndr + = isRec is_rec -- Joins are one-shot iff non-recursive + + | otherwise + = noFloatIntoArg rhs (idType bndr) + +noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool +noFloatIntoArg expr expr_ty + | isUnliftedType expr_ty + = True -- See Note [Do not destroy the let/app invariant] + + | AnnLam bndr e <- expr + , (bndrs, _) <- collectAnnBndrs e + = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a) + || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b) + -- See Note [noFloatInto considerations] wrinkle 2 + + | otherwise -- Note [noFloatInto considerations] wrinkle 2 + = exprIsTrivial deann_expr || exprIsHNF deann_expr + where + deann_expr = deAnnotate' expr + +{- Note [noFloatInto considerations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When do we want to float bindings into + - noFloatIntoRHs: the RHS of a let-binding + - noFloatIntoArg: the argument of a function application + +Definitely don't float in if it has unlifted type; that +would destroy the let/app invariant. + +* Wrinkle 1: do not float in if + (a) any non-one-shot value lambdas + or (b) all type lambdas + In both cases we'll float straight back out again + NB: Must line up with fiExpr (AnnLam...); see #7088 + + (a) is important: we /must/ float into a one-shot lambda group + (which includes join points). This makes a big difference + for things like + f x# = let x = I# x# + in let j = \() -> ...x... + in if then normal-path else j () + If x is used only in the error case join point, j, we must float the + boxing constructor into it, else we box it every time which is very + bad news indeed. + +* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right + back out again... not tragic, but a waste of time. + + For function arguments we will still end up with this + in-then-out stuff; consider + letrec x = e in f x + Here x is not a HNF, so we'll produce + f (letrec x = e in x) + which is OK... it's not that common, and we'll end up + floating out again, in CorePrep if not earlier. + Still, we use exprIsTrivial to catch this case (sigh) + + +************************************************************************ +* * +\subsection{@sepBindsByDropPoint@} +* * +************************************************************************ + +This is the crucial function. The idea is: We have a wad of bindings +that we'd like to distribute inside a collection of {\em drop points}; +insides the alternatives of a \tr{case} would be one example of some +drop points; the RHS and body of a non-recursive \tr{let} binding +would be another (2-element) collection. + +So: We're given a list of sets-of-free-variables, one per drop point, +and a list of floating-inwards bindings. If a binding can go into +only one drop point (without suddenly making something out-of-scope), +in it goes. If a binding is used inside {\em multiple} drop points, +then it has to go in a you-must-drop-it-above-all-these-drop-points +point. + +We have to maintain the order on these drop-point-related lists. +-} + +-- pprFIB :: FloatInBinds -> SDoc +-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] + +sepBindsByDropPoint + :: Platform + -> Bool -- True <=> is case expression + -> [FreeVarSet] -- One set of FVs per drop point + -- Always at least two long! + -> FloatInBinds -- Candidate floaters + -> [FloatInBinds] -- FIRST one is bindings which must not be floated + -- inside any drop point; the rest correspond + -- one-to-one with the input list of FV sets + +-- Every input floater is returned somewhere in the result; +-- none are dropped, not even ones which don't seem to be +-- free in *any* of the drop-point fvs. Why? Because, for example, +-- a binding (let x = E in B) might have a specialised version of +-- x (say x') stored inside x, but x' isn't free in E or B. + +type DropBox = (FreeVarSet, FloatInBinds) + +sepBindsByDropPoint platform is_case drop_pts floaters + | null floaters -- Shortcut common case + = [] : [[] | _ <- drop_pts] + + | otherwise + = ASSERT( drop_pts `lengthAtLeast` 2 ) + go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts)) + where + n_alts = length drop_pts + + go :: FloatInBinds -> [DropBox] -> [FloatInBinds] + -- The *first* one in the argument list is the drop_here set + -- The FloatInBinds in the lists are in the reverse of + -- the normal FloatInBinds order; that is, they are the right way round! + + go [] drop_boxes = map (reverse . snd) drop_boxes + + go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) + = go binds new_boxes + where + -- "here" means the group of bindings dropped at the top of the fork + + (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs + | (fvs, _) <- drop_boxes] + + drop_here = used_here || cant_push + + n_used_alts = count id used_in_flags -- returns number of Trues in list. + + cant_push + | is_case = n_used_alts == n_alts -- Used in all, don't push + -- Remember n_alts > 1 + || (n_used_alts > 1 && not (floatIsDupable platform bind)) + -- floatIsDupable: see Note [Duplicating floats] + + | otherwise = floatIsCase bind || n_used_alts > 1 + -- floatIsCase: see Note [Floating primops] + + new_boxes | drop_here = (insert here_box : fork_boxes) + | otherwise = (here_box : new_fork_boxes) + + new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe + fork_boxes used_in_flags + + insert :: DropBox -> DropBox + insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops) + + insert_maybe box True = insert box + insert_maybe box False = box + + go _ _ = panic "sepBindsByDropPoint/go" + + +{- Note [Duplicating floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For case expressions we duplicate the binding if it is reasonably +small, and if it is not used in all the RHSs This is good for +situations like + let x = I# y in + case e of + C -> error x + D -> error x + E -> ...not mentioning x... + +If the thing is used in all RHSs there is nothing gained, +so we don't duplicate then. +-} + +floatedBindsFVs :: FloatInBinds -> FreeVarSet +floatedBindsFVs binds = mapUnionDVarSet fbFVs binds + +fbFVs :: FloatInBind -> DVarSet +fbFVs (FB _ fvs _) = fvs + +wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr +-- Remember FloatInBinds is in *reverse* dependency order +wrapFloats [] e = e +wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) + +floatIsDupable :: Platform -> FloatBind -> Bool +floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut +floatIsDupable platform (FloatLet (Rec prs)) = all (exprIsDupable platform . snd) prs +floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r + +floatIsCase :: FloatBind -> Bool +floatIsCase (FloatCase {}) = True +floatIsCase (FloatLet {}) = False diff --git a/GHC/Core/Opt/FloatOut.hs b/GHC/Core/Opt/FloatOut.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/FloatOut.hs @@ -0,0 +1,758 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[FloatOut]{Float bindings outwards (towards the top level)} + +``Long-distance'' floating of bindings towards the top level. +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.FloatOut ( floatOutwards ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.Opt.Arity ( exprArity, etaExpand ) +import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) + +import GHC.Driver.Session +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, + isJoinId, isJoinId_maybe ) +import GHC.Core.Opt.SetLevels +import GHC.Types.Unique.Supply ( UniqSupply ) +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Core.Type +import qualified Data.IntMap as M + +import Data.List ( partition ) + +#include "HsVersions.h" + +{- + ----------------- + Overall game plan + ----------------- + +The Big Main Idea is: + + To float out sub-expressions that can thereby get outside + a non-one-shot value lambda, and hence may be shared. + + +To achieve this we may need to do two things: + + a) Let-bind the sub-expression: + + f (g x) ==> let lvl = f (g x) in lvl + + Now we can float the binding for 'lvl'. + + b) More than that, we may need to abstract wrt a type variable + + \x -> ... /\a -> let v = ...a... in .... + + Here the binding for v mentions 'a' but not 'x'. So we + abstract wrt 'a', to give this binding for 'v': + + vp = /\a -> ...a... + v = vp a + + Now the binding for vp can float out unimpeded. + I can't remember why this case seemed important enough to + deal with, but I certainly found cases where important floats + didn't happen if we did not abstract wrt tyvars. + +With this in mind we can also achieve another goal: lambda lifting. +We can make an arbitrary (function) binding float to top level by +abstracting wrt *all* local variables, not just type variables, leaving +a binding that can be floated right to top level. Whether or not this +happens is controlled by a flag. + + +Random comments +~~~~~~~~~~~~~~~ + +At the moment we never float a binding out to between two adjacent +lambdas. For example: + +@ + \x y -> let t = x+x in ... +===> + \x -> let t = x+x in \y -> ... +@ +Reason: this is less efficient in the case where the original lambda +is never partially applied. + +But there's a case I've seen where this might not be true. Consider: +@ +elEm2 x ys + = elem' x ys + where + elem' _ [] = False + elem' x (y:ys) = x==y || elem' x ys +@ +It turns out that this generates a subexpression of the form +@ + \deq x ys -> let eq = eqFromEqDict deq in ... +@ +which might usefully be separated to +@ + \deq -> let eq = eqFromEqDict deq in \xy -> ... +@ +Well, maybe. We don't do this at the moment. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +Every occurrence of a join point must be a tail call (see Note [Invariants on +join points] in GHC.Core), so we must be careful with how far we float them. The +mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling] +in GHC.Core.Opt.SetLevels. For us, the significance is that a binder might be marked to be +dropped at the nearest boundary between tail calls and non-tail calls. For +example: + + (< join j = ... in + let x = < ... > in + case < ... > of + A -> ... + B -> ... + >) < ... > < ... > + +Here the join ceilings are marked with angle brackets. Either side of an +application is a join ceiling, as is the scrutinee position of a case +expression or the RHS of a let binding (but not a join point). + +Why do we *want* do float join points at all? After all, they're never +allocated, so there's no sharing to be gained by floating them. However, the +other benefit of floating is making RHSes small, and this can have a significant +impact. In particular, stream fusion has been known to produce nested loops like +this: + + joinrec j1 x1 = + joinrec j2 x2 = + joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... + in jump j3 x2 + in jump j2 x1 + in jump j1 x + +(Assume x1 and x2 do *not* occur free in j3.) + +Here j1 and j2 are wholly superfluous---each of them merely forwards its +argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make +everything one big mutual recursion: + + joinrec j1 x1 = jump j2 x1 + j2 x2 = jump j3 x2 + j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... + in jump j1 x + +Now the simplifier will happily inline the trivial j1 and j2, leaving only j3. +Without floating, we're stuck with three loops instead of one. + +************************************************************************ +* * +\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} +* * +************************************************************************ +-} + +floatOutwards :: FloatOutSwitches + -> DynFlags + -> UniqSupply + -> CoreProgram -> IO CoreProgram + +floatOutwards float_sws dflags us pgm + = do { + let { annotated_w_levels = setLevels float_sws pgm us ; + (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) + } ; + + dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" + FormatCore + (vcat (map ppr annotated_w_levels)); + + let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; + + dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" + FormatText + (hcat [ int tlets, text " Lets floated to top level; ", + int ntlets, text " Lets floated elsewhere; from ", + int lams, text " Lambda groups"]); + + return (bagToList (unionManyBags binds_s')) + } + +floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) +floatTopBind bind + = case (floatBind bind) of { (fs, floats, bind') -> + let float_bag = flattenTopFloats floats + in case bind' of + -- bind' can't have unlifted values or join points, so can only be one + -- value bind, rec or non-rec (see comment on floatBind) + [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) + [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e) + _ -> pprPanic "floatTopBind" (ppr bind') } + +{- +************************************************************************ +* * +\subsection[FloatOut-Bind]{Floating in a binding (the business end)} +* * +************************************************************************ +-} + +floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) + -- Returns a list with either + -- * A single non-recursive binding (value or join point), or + -- * The following, in order: + -- * Zero or more non-rec unlifted bindings + -- * One or both of: + -- * A recursive group of join binds + -- * A recursive group of value binds + -- See Note [Floating out of Rec rhss] for why things get arranged this way. +floatBind (NonRec (TB var _) rhs) + = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> + + -- A tiresome hack: + -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels + let rhs'' | isDeadEndId var + , exprArity rhs' < idArity var = etaExpand (idArity var) rhs' + | otherwise = rhs' + + in (fs, rhs_floats, [NonRec var rhs'']) } + +floatBind (Rec pairs) + = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> + let (new_ul_pairss, new_other_pairss) = unzip new_pairs + (new_join_pairs, new_l_pairs) = partition (isJoinId . fst) + (concat new_other_pairss) + -- Can't put the join points and the values in the same rec group + new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ] + | null new_l_pairs = [ Rec new_join_pairs ] + | otherwise = [ Rec new_l_pairs + , Rec new_join_pairs ] + new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ] + in + (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) } + where + do_pair :: (LevelledBndr, LevelledExpr) + -> (FloatStats, FloatBinds, + ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings + [(Id,CoreExpr)])) -- Join points and lifted value bindings + do_pair (TB name spec, rhs) + | isTopLvl dest_lvl -- See Note [floatBind for top level] + = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> + (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats) + [(name, rhs')]))} + | otherwise -- Note [Floating out of Rec rhss] + = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> + case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> + case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) -> + let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in + (fs, rhs_floats', (ul_pairs, pairs')) }}} + where + dest_lvl = floatSpecLevel spec + +splitRecFloats :: Bag FloatBind + -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings + [(Id,CoreExpr)], -- Join points and lifted value bindings + Bag FloatBind) -- A tail of further bindings +-- The "tail" begins with a case +-- See Note [Floating out of Rec rhss] +splitRecFloats fs + = go [] [] (bagToList fs) + where + go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b) + , not (isJoinId b) + = go ((b,r):ul_prs) prs fs + | otherwise + = go ul_prs ((b,r):prs) fs + go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs + go ul_prs prs fs = (reverse ul_prs, prs, + listToBag fs) + -- Order only matters for + -- non-rec + +installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr +-- Note [Floating out of Rec rhss] +installUnderLambdas floats e + | isEmptyBag floats = e + | otherwise = go e + where + go (Lam b e) = Lam b (go e) + go e = install floats e + +--------------- +floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) +floatList _ [] = (zeroStats, emptyFloats, []) +floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> + case floatList f as of { (fs_as, binds_as, bs) -> + (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} + +{- +Note [Floating out of Rec rhss] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider Rec { f<1,0> = \xy. body } +From the body we may get some floats. The ones with level <1,0> must +stay here, since they may mention f. Ideally we'd like to make them +part of the Rec block pairs -- but we can't if there are any +FloatCases involved. + +Nor is it a good idea to dump them in the rhs, but outside the lambda + f = case x of I# y -> \xy. body +because now f's arity might get worse, which is Not Good. (And if +there's an SCC around the RHS it might not get better again. +See #5342.) + +So, gruesomely, we split the floats into + * the outer FloatLets, which can join the Rec, and + * an inner batch starting in a FloatCase, which are then + pushed *inside* the lambdas. +This loses full-laziness the rare situation where there is a +FloatCase and a Rec interacting. + +If there are unlifted FloatLets (that *aren't* join points) among the floats, +we can't add them to the recursive group without angering Core Lint, but since +they must be ok-for-speculation, they can't actually be making any recursive +calls, so we can safely pull them out and keep them non-recursive. + +(Why is something getting floated to <1,0> that doesn't make a recursive call? +The case that came up in testing was that f *and* the unlifted binding were +getting floated *to the same place*: + + \x<2,0> -> + ... <3,0> + letrec { f> = + ... let x'> = x +# 1# in ... + } in ... + +Everything gets labeled "float to <2,0>" because it all depends on x, but this +makes f and x' look mutually recursive when they're not. + +The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the +wip/join-points branch. + +TODO: This can probably be solved somehow in GHC.Core.Opt.SetLevels. The difference between +"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very +important.) + +Note [floatBind for top level] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus + letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } +The binding for bar will be in the "tops" part of the floating binds, +and thus not partioned by floatBody. + +We could perhaps get rid of the 'tops' component of the floating binds, +but this case works just as well. + + +************************************************************************ + +\subsection[FloatOut-Expr]{Floating in expressions} +* * +************************************************************************ +-} + +floatBody :: Level + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) + +floatBody lvl arg -- Used rec rhss, and case-alternative rhss + = case (floatExpr arg) of { (fsa, floats, arg') -> + case (partitionByLevel lvl floats) of { (floats', heres) -> + -- Dump bindings are bound here + (fsa, floats', install heres arg') }} + +----------------- + +{- Note [Floating past breakpoints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to disallow floating out of breakpoint ticks (see #10052). However, I +think this is too restrictive. + +Consider the case of an expression scoped over by a breakpoint tick, + + tick<...> (let x = ... in f x) + +In this case it is completely legal to float out x, despite the fact that +breakpoint ticks are scoped, + + let x = ... in (tick<...> f x) + +The reason here is that we know that the breakpoint will still be hit when the +expression is entered since the tick still scopes over the RHS. + +-} + +floatExpr :: LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatExpr (Var v) = (zeroStats, emptyFloats, Var v) +floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) +floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) + +floatExpr (App e a) + = case (atJoinCeiling $ floatExpr e) of { (fse, floats_e, e') -> + case (atJoinCeiling $ floatExpr a) of { (fsa, floats_a, a') -> + (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} + +floatExpr lam@(Lam (TB _ lam_spec) _) + = let (bndrs_w_lvls, body) = collectBinders lam + bndrs = [b | TB b _ <- bndrs_w_lvls] + bndr_lvl = asJoinCeilLvl (floatSpecLevel lam_spec) + -- All the binders have the same level + -- See GHC.Core.Opt.SetLevels.lvlLamBndrs + -- Use asJoinCeilLvl to make this the join ceiling + in + case (floatBody bndr_lvl body) of { (fs, floats, body') -> + (add_to_stats fs floats, floats, mkLams bndrs body') } + +floatExpr (Tick tickish expr) + | tickish `tickishScopesLike` SoftScope -- not scoped, can just float + = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Tick tickish expr') } + + | not (tickishCounts tickish) || tickishCanSplit tickish + = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> + let -- Annotate bindings floated outwards past an scc expression + -- with the cc. We mark that cc as "duplicated", though. + annotated_defns = wrapTick (mkNoCount tickish) floating_defns + in + (fs, annotated_defns, Tick tickish expr') } + + -- Note [Floating past breakpoints] + | Breakpoint{} <- tickish + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Tick tickish expr') } + + | otherwise + = pprPanic "floatExpr tick" (ppr tickish) + +floatExpr (Cast expr co) + = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Cast expr' co) } + +floatExpr (Let bind body) + = case bind_spec of + FloatMe dest_lvl + -> case (floatBind bind) of { (fsb, bind_floats, binds') -> + case (floatExpr body) of { (fse, body_floats, body') -> + let new_bind_floats = foldr plusFloats emptyFloats + (map (unitLetFloat dest_lvl) binds') in + ( add_stats fsb fse + , bind_floats `plusFloats` new_bind_floats + `plusFloats` body_floats + , body') }} + + StayPut bind_lvl -- See Note [Avoiding unnecessary floating] + -> case (floatBind bind) of { (fsb, bind_floats, binds') -> + case (floatBody bind_lvl body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` body_floats + , foldr Let body' binds' ) }} + where + bind_spec = case bind of + NonRec (TB _ s) _ -> s + Rec ((TB _ s, _) : _) -> s + Rec [] -> panic "floatExpr:rec" + +floatExpr (Case scrut (TB case_bndr case_spec) ty alts) + = case case_spec of + FloatMe dest_lvl -- Case expression moves + | [(con@(DataAlt {}), bndrs, rhs)] <- alts + -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> + case floatExpr rhs of { (fsb, fdb, rhs') -> + let + float = unitCaseFloat dest_lvl scrut' + case_bndr con [b | TB b _ <- bndrs] + in + (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} + | otherwise + -> pprPanic "Floating multi-case" (ppr alts) + + StayPut bind_lvl -- Case expression stays put + -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> + case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> + (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') + }} + where + float_alt bind_lvl (con, bs, rhs) + = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> + (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } + +floatRhs :: CoreBndr + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatRhs bndr rhs + | Just join_arity <- isJoinId_maybe bndr + , Just (bndrs, body) <- try_collect join_arity rhs [] + = case bndrs of + [] -> floatExpr rhs + (TB _ lam_spec):_ -> + let lvl = floatSpecLevel lam_spec in + case floatBody lvl body of { (fs, floats, body') -> + (fs, floats, mkLams [b | TB b _ <- bndrs] body') } + | otherwise + = atJoinCeiling $ floatExpr rhs + where + try_collect 0 expr acc = Just (reverse acc, expr) + try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc) + try_collect _ _ _ = Nothing + +{- +Note [Avoiding unnecessary floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we want to avoid floating a let unnecessarily, because +it might worsen strictness: + let + x = ...(let y = e in y+y).... +Here y is demanded. If we float it outside the lazy 'x=..' then +we'd have to zap its demand info, and it may never be restored. + +So at a 'let' we leave the binding right where the are unless +the binding will escape a value lambda, e.g. + +(\x -> let y = fac 100 in y) + +That's what the partitionByMajorLevel does in the floatExpr (Let ...) +case. + +Notice, though, that we must take care to drop any bindings +from the body of the let that depend on the staying-put bindings. + +We used instead to do the partitionByMajorLevel on the RHS of an '=', +in floatRhs. But that was quite tiresome. We needed to test for +values or trivial rhss, because (in particular) we don't want to insert +new bindings between the "=" and the "\". E.g. + f = \x -> let in +We do not want + f = let in \x -> +(a) The simplifier will immediately float it further out, so we may + as well do so right now; in general, keeping rhss as manifest + values is good +(b) If a float-in pass follows immediately, it might add yet more + bindings just after the '='. And some of them might (correctly) + be strict even though the 'let f' is lazy, because f, being a value, + gets its demand-info zapped by the simplifier. +And even all that turned out to be very fragile, and broke +altogether when profiling got in the way. + +So now we do the partition right at the (Let..) itself. + +************************************************************************ +* * +\subsection{Utility bits for floating stats} +* * +************************************************************************ + +I didn't implement this with unboxed numbers. I don't want to be too +strict in this stuff, as it is rarely turned on. (WDP 95/09) +-} + +data FloatStats + = FlS Int -- Number of top-floats * lambda groups they've been past + Int -- Number of non-top-floats * lambda groups they've been past + Int -- Number of lambda (groups) seen + +get_stats :: FloatStats -> (Int, Int, Int) +get_stats (FlS a b c) = (a, b, c) + +zeroStats :: FloatStats +zeroStats = FlS 0 0 0 + +sum_stats :: [FloatStats] -> FloatStats +sum_stats xs = foldr add_stats zeroStats xs + +add_stats :: FloatStats -> FloatStats -> FloatStats +add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) + = FlS (a1 + a2) (b1 + b2) (c1 + c2) + +add_to_stats :: FloatStats -> FloatBinds -> FloatStats +add_to_stats (FlS a b c) (FB tops ceils others) + = FlS (a + lengthBag tops) + (b + lengthBag ceils + lengthBag (flattenMajor others)) + (c + 1) + +{- +************************************************************************ +* * +\subsection{Utility bits for floating} +* * +************************************************************************ + +Note [Representation of FloatBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatBinds types is somewhat important. We can get very large numbers +of floating bindings, often all destined for the top level. A typical example +is x = [4,2,5,2,5, .... ] +Then we get lots of small expressions like (fromInteger 4), which all get +lifted to top level. + +The trouble is that + (a) we partition these floating bindings *at every binding site* + (b) GHC.Core.Opt.SetLevels introduces a new bindings site for every float +So we had better not look at each binding at each binding site! + +That is why MajorEnv is represented as a finite map. + +We keep the bindings destined for the *top* level separate, because +we float them out even if they don't escape a *value* lambda; see +partitionByMajorLevel. +-} + +type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted +type MajorEnv = M.IntMap MinorEnv -- Keyed by major level +type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level + +data FloatBinds = FB !(Bag FloatLet) -- Destined for top level + !(Bag FloatBind) -- Destined for join ceiling + !MajorEnv -- Other levels + -- See Note [Representation of FloatBinds] + +instance Outputable FloatBinds where + ppr (FB fbs ceils defs) + = text "FB" <+> (braces $ vcat + [ text "tops =" <+> ppr fbs + , text "ceils =" <+> ppr ceils + , text "non-tops =" <+> ppr defs ]) + +flattenTopFloats :: FloatBinds -> Bag CoreBind +flattenTopFloats (FB tops ceils defs) + = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) + ASSERT2( isEmptyBag ceils, ppr ceils ) + tops + +addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +addTopFloatPairs float_bag prs + = foldr add prs float_bag + where + add (NonRec b r) prs = (b,r):prs + add (Rec prs1) prs2 = prs1 ++ prs2 + +flattenMajor :: MajorEnv -> Bag FloatBind +flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag + +flattenMinor :: MinorEnv -> Bag FloatBind +flattenMinor = M.foldr unionBags emptyBag + +emptyFloats :: FloatBinds +emptyFloats = FB emptyBag emptyBag M.empty + +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds +unitCaseFloat (Level major minor t) e b con bs + | t == JoinCeilLvl + = FB emptyBag floats M.empty + | otherwise + = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats)) + where + floats = unitBag (FloatCase e b con bs) + +unitLetFloat :: Level -> FloatLet -> FloatBinds +unitLetFloat lvl@(Level major minor t) b + | isTopLvl lvl = FB (unitBag b) emptyBag M.empty + | t == JoinCeilLvl = FB emptyBag floats M.empty + | otherwise = FB emptyBag emptyBag (M.singleton major + (M.singleton minor floats)) + where + floats = unitBag (FloatLet b) + +plusFloats :: FloatBinds -> FloatBinds -> FloatBinds +plusFloats (FB t1 c1 l1) (FB t2 c2 l2) + = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2) + +plusMajor :: MajorEnv -> MajorEnv -> MajorEnv +plusMajor = M.unionWith plusMinor + +plusMinor :: MinorEnv -> MinorEnv -> MinorEnv +plusMinor = M.unionWith unionBags + +install :: Bag FloatBind -> CoreExpr -> CoreExpr +install defn_groups expr + = foldr wrapFloat expr defn_groups + +partitionByLevel + :: Level -- Partitioning level + -> FloatBinds -- Defns to be divided into 2 piles... + -> (FloatBinds, -- Defns with level strictly < partition level, + Bag FloatBind) -- The rest + +{- +-- ---- partitionByMajorLevel ---- +-- Float it if we escape a value lambda, +-- *or* if we get to the top level +-- *or* if it's a case-float and its minor level is < current +-- +-- If we can get to the top level, say "yes" anyway. This means that +-- x = f e +-- transforms to +-- lvl = e +-- x = f lvl +-- which is as it should be + +partitionByMajorLevel (Level major _) (FB tops defns) + = (FB tops outer, heres `unionBags` flattenMajor inner) + where + (outer, mb_heres, inner) = M.splitLookup major defns + heres = case mb_heres of + Nothing -> emptyBag + Just h -> flattenMinor h +-} + +partitionByLevel (Level major minor typ) (FB tops ceils defns) + = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min), + here_min `unionBags` here_ceil + `unionBags` flattenMinor inner_min + `unionBags` flattenMajor inner_maj) + + where + (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns + (outer_min, mb_here_min, inner_min) = case mb_here_maj of + Nothing -> (M.empty, Nothing, M.empty) + Just min_defns -> M.splitLookup minor min_defns + here_min = mb_here_min `orElse` emptyBag + (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag) + | otherwise = (emptyBag, ceils) + +-- Like partitionByLevel, but instead split out the bindings that are marked +-- to float to the nearest join ceiling (see Note [Join points]) +partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind) +partitionAtJoinCeiling (FB tops ceils defs) + = (FB tops emptyBag defs, ceils) + +-- Perform some action at a join ceiling, i.e., don't let join points float out +-- (see Note [Join points]) +atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr) + -> (FloatStats, FloatBinds, CoreExpr) +atJoinCeiling (fs, floats, expr') + = (fs, floats', install ceils expr') + where + (floats', ceils) = partitionAtJoinCeiling floats + +wrapTick :: Tickish Id -> FloatBinds -> FloatBinds +wrapTick t (FB tops ceils defns) + = FB (mapBag wrap_bind tops) (wrap_defns ceils) + (M.map (M.map wrap_defns) defns) + where + wrap_defns = mapBag wrap_one + + wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) + wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) + + wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) + wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs + + maybe_tick e | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + -- we don't need to wrap a tick around an HNF when we float it + -- outside a tick: that is an invariant of the tick semantics + -- Conversely, inlining of HNFs inside an SCC is allowed, and + -- indeed the HNF we're floating here might well be inlined back + -- again, and we don't want to end up with duplicate ticks. diff --git a/GHC/Core/Opt/LiberateCase.hs b/GHC/Core/Opt/LiberateCase.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/LiberateCase.hs @@ -0,0 +1,442 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} +-} + +{-# LANGUAGE CPP #-} +module GHC.Core.Opt.LiberateCase ( liberateCase ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core +import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) +import GHC.Builtin.Types ( unitDataConId ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Utils.Misc ( notNull ) + +{- +The liberate-case transformation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module walks over @Core@, and looks for @case@ on free variables. +The criterion is: + if there is case on a free on the route to the recursive call, + then the recursive call is replaced with an unfolding. + +Example + + f = \ t -> case v of + V a b -> a : f t + +=> the inner f is replaced. + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> case v of + V a b -> a : f t + in f) t +(note the NEED for shadowing) + +=> Simplify + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> a : f t + in f t) + +Better code, because 'a' is free inside the inner letrec, rather +than needing projection from v. + +Note that this deals with *free variables*. SpecConstr deals with +*arguments* that are of known form. E.g. + + last [] = error + last (x:[]) = x + last (x:xs) = last xs + + +Note [Scrutinee with cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + f = \ t -> case (v `cast` co) of + V a b -> a : f t + +Exactly the same optimisation (unrolling one call to f) will work here, +despite the cast. See mk_alt_env in the Case branch of libCase. + + +To think about (Apr 94) +~~~~~~~~~~~~~~ +Main worry: duplicating code excessively. At the moment we duplicate +the entire binding group once at each recursive call. But there may +be a group of recursive calls which share a common set of evaluated +free variables, in which case the duplication is a plain waste. + +Another thing we could consider adding is some unfold-threshold thing, +so that we'll only duplicate if the size of the group rhss isn't too +big. + +Data types +~~~~~~~~~~ +The ``level'' of a binder tells how many +recursive defns lexically enclose the binding +A recursive defn "encloses" its RHS, not its +scope. For example: +\begin{verbatim} + letrec f = let g = ... in ... + in + let h = ... + in ... +\end{verbatim} +Here, the level of @f@ is zero, the level of @g@ is one, +and the level of @h@ is zero (NB not one). + + +************************************************************************ +* * + Top-level code +* * +************************************************************************ +-} + +liberateCase :: DynFlags -> CoreProgram -> CoreProgram +liberateCase dflags binds = do_prog (initEnv dflags) binds + where + do_prog _ [] = [] + do_prog env (bind:binds) = bind' : do_prog env' binds + where + (env', bind') = libCaseBind env bind + +{- +************************************************************************ +* * + Main payload +* * +************************************************************************ + +Bindings +~~~~~~~~ +-} + +libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) + +libCaseBind env (NonRec binder rhs) + = (addBinders env [binder], NonRec binder (libCase env rhs)) + +libCaseBind env (Rec pairs) + = (env_body, Rec pairs') + where + binders = map fst pairs + + env_body = addBinders env binders + + pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] + + -- We extend the rec-env by binding each Id to its rhs, first + -- processing the rhs with an *un-extended* environment, so + -- that the same process doesn't occur for ever! + env_rhs | is_dupable_bind = addRecBinds env dup_pairs + | otherwise = env + + dup_pairs = [ (localiseId binder, libCase env_body rhs) + | (binder, rhs) <- pairs ] + -- localiseID : see Note [Need to localiseId in libCaseBind] + + is_dupable_bind = small_enough && all ok_pair pairs + + -- Size: we are going to duplicate dup_pairs; to find their + -- size, build a fake binding (let { dup_pairs } in (), + -- and find the size of that + -- See Note [Small enough] + small_enough = case bombOutSize env of + Nothing -> True -- Infinity + Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $ + Let (Rec dup_pairs) (Var unitDataConId) + + ok_pair (id,_) + = idArity id > 0 -- Note [Only functions!] + && not (isDeadEndId id) -- Note [Not bottoming ids] + +{- Note [Not bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not specialise error-functions (this is unusual, but I once saw it, +(actually in Data.Typable.Internal) + +Note [Only functions!] +~~~~~~~~~~~~~~~~~~~~~~ +Consider the following code + + f = g (case v of V a b -> a : t f) + +where g is expensive. If we aren't careful, liberate case will turn this into + + f = g (case v of + V a b -> a : t (letrec f = g (case v of V a b -> a : f t) + in f) + ) + +Yikes! We evaluate g twice. This leads to a O(2^n) explosion +if g calls back to the same code recursively. + +Solution: make sure that we only do the liberate-case thing on *functions* + +Note [Small enough] +~~~~~~~~~~~~~~~~~~~ +Consider + \fv. letrec + f = \x. BIG...(case fv of { (a,b) -> ...g.. })... + g = \y. SMALL...f... + +Then we *can* in principle do liberate-case on 'g' (small RHS) but not +for 'f' (too big). But doing so is not profitable, because duplicating +'g' at its call site in 'f' doesn't get rid of any cases. So we just +ask for the whole group to be small enough. + +Note [Need to localiseId in libCaseBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The call to localiseId is needed for two subtle reasons +(a) Reset the export flags on the binders so + that we don't get name clashes on exported things if the + local binding floats out to top level. This is most unlikely + to happen, since the whole point concerns free variables. + But resetting the export flag is right regardless. + +(b) Make the name an Internal one. External Names should never be + nested; if it were floated to the top level, we'd get a name + clash at code generation time. + +Expressions +~~~~~~~~~~~ +-} + +libCase :: LibCaseEnv + -> CoreExpr + -> CoreExpr + +libCase env (Var v) = libCaseApp env v [] +libCase _ (Lit lit) = Lit lit +libCase _ (Type ty) = Type ty +libCase _ (Coercion co) = Coercion co +libCase env e@(App {}) | let (fun, args) = collectArgs e + , Var v <- fun + = libCaseApp env v args +libCase env (App fun arg) = App (libCase env fun) (libCase env arg) +libCase env (Tick tickish body) = Tick tickish (libCase env body) +libCase env (Cast e co) = Cast (libCase env e) co + +libCase env (Lam binder body) + = Lam binder (libCase (addBinders env [binder]) body) + +libCase env (Let bind body) + = Let bind' (libCase env_body body) + where + (env_body, bind') = libCaseBind env bind + +libCase env (Case scrut bndr ty alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) + where + env_alts = addBinders (mk_alt_env scrut) [bndr] + mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var + mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] + mk_alt_env _ = env + +libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) + -> (AltCon, [CoreBndr], CoreExpr) +libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) + +{- +Ids +~~~ + +To unfold, we can't just wrap the id itself in its binding if it's a join point: + + jump j a b c => (joinrec j x y z = ... in jump j) a b c -- wrong!!! + +Every jump must provide all arguments, so we have to be careful to wrap the +whole jump instead: + + jump j a b c => joinrec j x y z = ... in jump j a b c -- right + +-} + +libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr +libCaseApp env v args + | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing + , notNull free_scruts -- with free vars scrutinised in RHS + = Let the_bind expr' + + | otherwise + = expr' + + where + rec_id_level = lookupLevel env v + free_scruts = freeScruts env rec_id_level + expr' = mkApps (Var v) (map (libCase env) args) + +freeScruts :: LibCaseEnv + -> LibCaseLevel -- Level of the recursive Id + -> [Id] -- Ids that are scrutinised between the binding + -- of the recursive Id and here +freeScruts env rec_bind_lvl + = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env + , scrut_bind_lvl <= rec_bind_lvl + , scrut_at_lvl > rec_bind_lvl] + -- Note [When to specialise] + -- Note [Avoiding fruitless liberate-case] + +{- +Note [When to specialise] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x. letrec g = \y. case x of + True -> ... (f a) ... + False -> ... (g b) ... + +We get the following levels + f 0 + x 1 + g 1 + y 2 + +Then 'x' is being scrutinised at a deeper level than its binding, so +it's added to lc_sruts: [(x,1)] + +We do *not* want to specialise the call to 'f', because 'x' is not free +in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). + +We *do* want to specialise the call to 'g', because 'x' is free in g. +Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). + +Note [Avoiding fruitless liberate-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider also: + f = \x. case top_lvl_thing of + I# _ -> let g = \y. ... g ... + in ... + +Here, top_lvl_thing is scrutinised at a level (1) deeper than its +binding site (0). Nevertheless, we do NOT want to specialise the call +to 'g' because all the structure in its free variables is already +visible at the definition site for g. Hence, when considering specialising +an occurrence of 'g', we want to check that there's a scruted-var v st + + a) v's binding site is *outside* g + b) v's scrutinisation site is *inside* g + + +************************************************************************ +* * + Utility functions +* * +************************************************************************ +-} + +addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv +addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders + = env { lc_lvl_env = lvl_env' } + where + lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl) + +addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv +addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_rec_env = rec_env}) pairs + = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' } + where + lvl' = lvl + 1 + lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] + rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] + +addScrutedVar :: LibCaseEnv + -> Id -- This Id is being scrutinised by a case expression + -> LibCaseEnv + +addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_scruts = scruts }) scrut_var + | bind_lvl < lvl + = env { lc_scruts = scruts' } + -- Add to scruts iff the scrut_var is being scrutinised at + -- a deeper level than its defn + + | otherwise = env + where + scruts' = (scrut_var, bind_lvl, lvl) : scruts + bind_lvl = case lookupVarEnv lvl_env scrut_var of + Just lvl -> lvl + Nothing -> topLevel + +lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind +lookupRecId env id = lookupVarEnv (lc_rec_env env) id + +lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel +lookupLevel env id + = case lookupVarEnv (lc_lvl_env env) id of + Just lvl -> lvl + Nothing -> topLevel + +{- +************************************************************************ +* * + The environment +* * +************************************************************************ +-} + +type LibCaseLevel = Int + +topLevel :: LibCaseLevel +topLevel = 0 + +data LibCaseEnv + = LibCaseEnv { + lc_dflags :: DynFlags, + + lc_lvl :: LibCaseLevel, -- Current level + -- The level is incremented when (and only when) going + -- inside the RHS of a (sufficiently small) recursive + -- function. + + lc_lvl_env :: IdEnv LibCaseLevel, + -- Binds all non-top-level in-scope Ids (top-level and + -- imported things have a level of zero) + + lc_rec_env :: IdEnv CoreBind, + -- Binds *only* recursively defined ids, to their own + -- binding group, and *only* in their own RHSs + + lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] + -- Each of these Ids was scrutinised by an enclosing + -- case expression, at a level deeper than its binding + -- level. + -- + -- The first LibCaseLevel is the *binding level* of + -- the scrutinised Id, + -- The second is the level *at which it was scrutinised*. + -- (see Note [Avoiding fruitless liberate-case]) + -- The former is a bit redundant, since you could always + -- look it up in lc_lvl_env, but it's just cached here + -- + -- The order is insignificant; it's a bag really + -- + -- There's one element per scrutinisation; + -- in principle the same Id may appear multiple times, + -- although that'd be unusual: + -- case x of { (a,b) -> ....(case x of ...) .. } + } + +initEnv :: DynFlags -> LibCaseEnv +initEnv dflags + = LibCaseEnv { lc_dflags = dflags, + lc_lvl = 0, + lc_lvl_env = emptyVarEnv, + lc_rec_env = emptyVarEnv, + lc_scruts = [] } + +-- Bomb-out size for deciding if +-- potential liberatees are too big. +-- (passed in from cmd-line args) +bombOutSize :: LibCaseEnv -> Maybe Int +bombOutSize = liberateCaseThreshold . lc_dflags diff --git a/GHC/Core/Opt/Monad.hs b/GHC/Core/Opt/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Monad.hs @@ -0,0 +1,828 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Opt.Monad ( + -- * Configuration of the core-to-core passes + CoreToDo(..), runWhen, runMaybe, + SimplMode(..), + FloatOutSwitches(..), + pprPassDetails, + + -- * Plugins + CorePluginPass, bindsOnlyPass, + + -- * Counting + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..), + + -- * The monad + CoreM, runCoreM, + + -- ** Reading from the monad + getHscEnv, getRuleBase, getModule, + getDynFlags, getPackageFamInstEnv, + getVisibleOrphanMods, getUniqMask, + getPrintUnqualified, getSrcSpanM, + + -- ** Writing to the monad + addSimplCount, + + -- ** Lifting into the monad + liftIO, liftIOWithCount, + + -- ** Dealing with annotations + getAnnotations, getFirstAnnotations, + + -- ** Screen output + putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, + fatalErrorMsg, fatalErrorMsgS, + debugTraceMsg, debugTraceMsgS, + dumpIfSet_dyn + ) where + +import GHC.Prelude hiding ( read ) + +import GHC.Core +import GHC.Driver.Types +import GHC.Unit.Module +import GHC.Driver.Session +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Types.Annotations + +import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) +import qualified GHC.Data.IOEnv as IOEnv +import GHC.Types.Var +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Utils.Error( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) +import GHC.Types.Unique.Supply +import GHC.Utils.Monad +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import Data.Bifunctor ( bimap ) +import GHC.Utils.Error (dumpAction) +import Data.List (intersperse, groupBy, sortBy) +import Data.Ord +import Data.Dynamic +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import Data.Word +import Control.Monad +import Control.Applicative ( Alternative(..) ) +import GHC.Utils.Panic (throwGhcException, GhcException(..)) + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + Int -- Max iterations + SimplMode + | CoreDoPluginPass String CorePluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoExitify + | CoreDoDemand + | CoreDoCpr + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + | CoreOccurAnal + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _ _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" + ppr CoreDoDemand = text "Demand analysis" + ppr CoreDoCpr = text "Constructed Product Result analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CorePrep = text "CorePrep" + ppr CoreOccurAnal = text "Occurrence analysis" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n + , ppr md ] +pprPassDetails _ = Outputable.empty + +data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad + = SimplMode + { sm_names :: [String] -- Name(s) of the phase + , sm_phase :: CompilerPhase + , sm_dflags :: DynFlags -- Just for convenient non-monadic + -- access; we don't override these + , sm_rules :: Bool -- Whether RULES are enabled + , sm_inline :: Bool -- Whether inlining is enabled + , sm_case_case :: Bool -- Whether case-of-case is enabled + , sm_eta_expand :: Bool -- Whether eta-expansion is enabled + } + +instance Outputable SimplMode where + ppr (SimplMode { sm_phase = p, sm_names = ss + , sm_rules = r, sm_inline = i + , sm_eta_expand = eta, sm_case_case = cc }) + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (sLit "inline") <> comma + , pp_flag r (sLit "rules") <> comma + , pp_flag eta (sLit "eta-expand") <> comma + , pp_flag cc (sLit "case-of-case") ]) + where + pp_flag f s = ppUnless f (text "no") <+> ptext s + +data FloatOutSwitches = FloatOutSwitches { + floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if + -- doing so will abstract over n or fewer + -- value variables + -- Nothing <=> float all lambdas to top level, + -- regardless of how many free variables + -- Just 0 is the vanilla case: float a lambda + -- iff it has no free vars + + floatOutConstants :: Bool, -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + floatOutOverSatApps :: Bool, + -- ^ True <=> float out over-saturated applications + -- based on arity information. + -- See Note [Floating over-saturated applications] + -- in GHC.Core.Opt.SetLevels + floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. + } +instance Outputable FloatOutSwitches where + ppr = pprFloatOutSwitches + +pprFloatOutSwitches :: FloatOutSwitches -> SDoc +pprFloatOutSwitches sw + = text "FOS" <+> (braces $ + sep $ punctuate comma $ + [ text "Lam =" <+> ppr (floatOutLambdas sw) + , text "Consts =" <+> ppr (floatOutConstants sw) + , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) + +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + +{- + +************************************************************************ +* * + Types for Plugins +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type CorePluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +{- +************************************************************************ +* * + Counting and logging +* * +************************************************************************ +-} + +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = getPprDebug -- For now, anyway + +zeroSimplCount :: DynFlags -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dflags + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dopt Opt_D_dump_simpl_stats dflags + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick dflags tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = MapStrict.insertWith (+) tick 1 fm + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2 + , details = MapStrict.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount lhs rhs = + throwGhcException . PprProgramError "plusSimplCount" $ vcat + [ text "lhs" + , pprSimplCount lhs + , text "rhs" + , pprSimplCount rhs + ] + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [text "Total ticks: " <+> int tks, + blankLine, + pprTickCounts dts, + getVerboseSimplStats $ \dbg -> if dbg + then + vcat [blankLine, + text "Log (most recent first)", + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +But alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void# -> sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [[(Tick,Int)]] -- Each group shares a common tag + -- toList returns common tags adjacent + groups = groupBy same_tag (Map.toList counts) + same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 + +pprTickGroup :: [(Tick, Int)] -> SDoc +pprTickGroup group@((tick1,_):_) + = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortBy (flip (comparing snd)) group]) +pprTickGroup [] = panic "pprTickGroup" + +data Tick -- See Note [Which transformations are innocuous] + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString LetFloatFromLet = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (AltMerge _) = "AltMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString SimplifierDone = "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ + +{- +************************************************************************ +* * + Monad and carried data structure definitions +* * +************************************************************************ +-} + +data CoreReader = CoreReader { + cr_hsc_env :: HscEnv, + cr_rule_base :: RuleBase, + cr_module :: Module, + cr_print_unqual :: PrintUnqualified, + cr_loc :: SrcSpan, -- Use this for log/error messages so they + -- are at least tagged with the right source file + cr_visible_orphan_mods :: !ModuleSet, + cr_uniq_mask :: !Char -- Mask for creating unique values +} + +-- Note: CoreWriter used to be defined with data, rather than newtype. If it +-- is defined that way again, the cw_simpl_count field, at least, must be +-- strict to avoid a space leak (#7702). +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +emptyWriter :: DynFlags -> CoreWriter +emptyWriter dflags = CoreWriter { + cw_simpl_count = zeroSimplCount dflags + } + +plusWriter :: CoreWriter -> CoreWriter -> CoreWriter +plusWriter w1 w2 = CoreWriter { + cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) + } + +type CoreIOEnv = IOEnv CoreReader + +-- | The monad used by Core-to-Core passes to register simplification statistics. +-- Also used to have common state (in the form of UniqueSupply) for generating Uniques. +newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } + deriving (Functor) + +instance Monad CoreM where + mx >>= f = CoreM $ do + (x, w1) <- unCoreM mx + (y, w2) <- unCoreM (f x) + let w = w1 `plusWriter` w2 + return $ seq w (y, w) + -- forcing w before building the tuple avoids a space leak + -- (#7702) + +instance Applicative CoreM where + pure x = CoreM $ nop x + (<*>) = ap + m *> k = m >>= \_ -> k + +instance Alternative CoreM where + empty = CoreM Control.Applicative.empty + m <|> n = CoreM (unCoreM m <|> unCoreM n) + +instance MonadPlus CoreM + +instance MonadUnique CoreM where + getUniqueSupplyM = do + mask <- read cr_uniq_mask + liftIO $! mkSplitUniqSupply mask + + getUniqueM = do + mask <- read cr_uniq_mask + liftIO $! uniqFromMask mask + +runCoreM :: HscEnv + -> RuleBase + -> Char -- ^ Mask + -> Module + -> ModuleSet + -> PrintUnqualified + -> SrcSpan + -> CoreM a + -> IO (a, SimplCount) +runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m + = liftM extract $ runIOEnv reader $ unCoreM m + where + reader = CoreReader { + cr_hsc_env = hsc_env, + cr_rule_base = rule_base, + cr_module = mod, + cr_visible_orphan_mods = orph_imps, + cr_print_unqual = print_unqual, + cr_loc = loc, + cr_uniq_mask = mask + } + + extract :: (a, CoreWriter) -> (a, SimplCount) + extract (value, writer) = (value, cw_simpl_count writer) + +{- +************************************************************************ +* * + Core combinators, not exported +* * +************************************************************************ +-} + +nop :: a -> CoreIOEnv (a, CoreWriter) +nop x = do + r <- getEnv + return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) + +read :: (CoreReader -> a) -> CoreM a +read f = CoreM $ getEnv >>= (\r -> nop (f r)) + +write :: CoreWriter -> CoreM () +write w = CoreM $ return ((), w) + +-- \subsection{Lifting IO into the monad} + +-- | Lift an 'IOEnv' operation into 'CoreM' +liftIOEnv :: CoreIOEnv a -> CoreM a +liftIOEnv mx = CoreM (mx >>= (\x -> nop x)) + +instance MonadIO CoreM where + liftIO = liftIOEnv . IOEnv.liftIO + +-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' +liftIOWithCount :: IO (SimplCount, a) -> CoreM a +liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) + +{- +************************************************************************ +* * + Reader, writer and state accessors +* * +************************************************************************ +-} + +getHscEnv :: CoreM HscEnv +getHscEnv = read cr_hsc_env + +getRuleBase :: CoreM RuleBase +getRuleBase = read cr_rule_base + +getVisibleOrphanMods :: CoreM ModuleSet +getVisibleOrphanMods = read cr_visible_orphan_mods + +getPrintUnqualified :: CoreM PrintUnqualified +getPrintUnqualified = read cr_print_unqual + +getSrcSpanM :: CoreM SrcSpan +getSrcSpanM = read cr_loc + +addSimplCount :: SimplCount -> CoreM () +addSimplCount count = write (CoreWriter { cw_simpl_count = count }) + +getUniqMask :: CoreM Char +getUniqMask = read cr_uniq_mask + +-- Convenience accessors for useful fields of HscEnv + +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv + +instance HasModule CoreM where + getModule = read cr_module + +getPackageFamInstEnv :: CoreM PackageFamInstEnv +getPackageFamInstEnv = do + hsc_env <- getHscEnv + eps <- liftIO $ hscEPS hsc_env + return $ eps_fam_inst_env eps + +{- +************************************************************************ +* * + Dealing with annotations +* * +************************************************************************ +-} + +-- | Get all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +-- +-- This should be done once at the start of a Core-to-Core pass that uses +-- annotations. +-- +-- See Note [Annotations] +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) +getAnnotations deserialize guts = do + hsc_env <- getHscEnv + ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) + return (deserializeAnns deserialize ann_env) + +-- | Get at most one annotation of a given type per annotatable item. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) +getFirstAnnotations deserialize guts + = bimap mod name <$> getAnnotations deserialize guts + where + mod = mapModuleEnv head . filterModuleEnv (const $ not . null) + name = mapNameEnv head . filterNameEnv (not . null) + +{- +Note [Annotations] +~~~~~~~~~~~~~~~~~~ +A Core-to-Core pass that wants to make use of annotations calls +getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with +annotations of a specific type. This produces all annotations from interface +files read so far. However, annotations from interface files read during the +pass will not be visible until getAnnotations is called again. This is similar +to how rules work and probably isn't too bad. + +The current implementation could be optimised a bit: when looking up +annotations for a thing from the HomePackageTable, we could search directly in +the module where the thing is defined rather than building one UniqFM which +contains all annotations we know of. This would work because annotations can +only be given to things defined in the same module. However, since we would +only want to deserialise every annotation once, we would have to build a cache +for every module in the HTP. In the end, it's probably not worth it as long as +we aren't using annotations heavily. + +************************************************************************ +* * + Direct screen output +* * +************************************************************************ +-} + +msg :: Severity -> WarnReason -> SDoc -> CoreM () +msg sev reason doc + = do { dflags <- getDynFlags + ; loc <- getSrcSpanM + ; unqual <- getPrintUnqualified + ; let sty = case sev of + SevError -> err_sty + SevWarning -> err_sty + SevDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle unqual + user_sty = mkUserStyle unqual AllTheWay + dump_sty = mkDumpStyle unqual + ; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) } + +-- | Output a String message to the screen +putMsgS :: String -> CoreM () +putMsgS = putMsg . text + +-- | Output a message to the screen +putMsg :: SDoc -> CoreM () +putMsg = msg SevInfo NoReason + +-- | Output an error to the screen. Does not cause the compiler to die. +errorMsgS :: String -> CoreM () +errorMsgS = errorMsg . text + +-- | Output an error to the screen. Does not cause the compiler to die. +errorMsg :: SDoc -> CoreM () +errorMsg = msg SevError NoReason + +warnMsg :: WarnReason -> SDoc -> CoreM () +warnMsg = msg SevWarning + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsgS :: String -> CoreM () +fatalErrorMsgS = fatalErrorMsg . text + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsg :: SDoc -> CoreM () +fatalErrorMsg = msg SevFatal NoReason + +-- | Output a string debugging message at verbosity level of @-v@ or higher +debugTraceMsgS :: String -> CoreM () +debugTraceMsgS = debugTraceMsg . text + +-- | Outputs a debugging message at verbosity level of @-v@ or higher +debugTraceMsg :: SDoc -> CoreM () +debugTraceMsg = msg SevDump NoReason + +-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher +dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM () +dumpIfSet_dyn flag str fmt doc + = do { dflags <- getDynFlags + ; unqual <- getPrintUnqualified + ; when (dopt flag dflags) $ liftIO $ do + let sty = mkDumpStyle unqual + dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc } diff --git a/GHC/Core/Opt/Monad.hs-boot b/GHC/Core/Opt/Monad.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Monad.hs-boot @@ -0,0 +1,30 @@ +-- Created this hs-boot file to remove circular dependencies from the use of +-- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core +-- transformations. +-- However GHC.Core.Opt.Monad does much more than defining these, and because Plugins are +-- activated in various modules, the imports become circular. To solve this I +-- extracted CoreToDo and CoreM into this file. +-- I needed to write the whole definition of these types, otherwise it created +-- a data-newtype conflict. + +module GHC.Core.Opt.Monad ( CoreToDo, CoreM ) where + +import GHC.Prelude + +import GHC.Data.IOEnv ( IOEnv ) + +type CoreIOEnv = IOEnv CoreReader + +data CoreReader + +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +data SimplCount + +newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } + +instance Monad CoreM + +data CoreToDo diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/OccurAnal.hs @@ -0,0 +1,3049 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[OccurAnal]{Occurrence analysis pass} +* * +************************************************************************ + +The occurrence analyser re-typechecks a core expression, returning a new +core expression with (hopefully) improved usage information. +-} + +{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, + stripTicksTopE, mkTicks ) +import GHC.Core.Opt.Arity ( joinRhsArity ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Unit.Module( Module ) +import GHC.Core.Coercion +import GHC.Core.Type +import GHC.Core.TyCo.FVs( tyCoVarsOfMCo ) + +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Demand ( argOneShots, argsOneShots ) +import GHC.Data.Graph.Directed ( SCC(..), Node(..) + , stronglyConnCompFromEdgedVerticesUniq + , stronglyConnCompFromEdgedVerticesUniqR ) +import GHC.Builtin.Names( runRWKey ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Misc +import GHC.Data.Maybe( isJust ) +import GHC.Utils.Outputable +import Data.List + +{- +************************************************************************ +* * + occurAnalysePgm, occurAnalyseExpr +* * +************************************************************************ + +Here's the externally-callable interface: +-} + +occurAnalysePgm :: Module -- Used only in debug output + -> (Id -> Bool) -- Active unfoldings + -> (Activation -> Bool) -- Active rules + -> [CoreRule] + -> CoreProgram -> CoreProgram +occurAnalysePgm this_mod active_unf active_rule imp_rules binds + | isEmptyDetails final_usage + = occ_anald_binds + + | otherwise -- See Note [Glomming] + = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) + 2 (ppr final_usage ) ) + occ_anald_glommed_binds + where + init_env = initOccEnv { occ_rule_act = active_rule + , occ_unf_act = active_unf } + + (final_usage, occ_anald_binds) = go init_env binds + (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel + imp_rule_edges + (flattenBinds binds) + initial_uds + -- It's crucial to re-analyse the glommed-together bindings + -- so that we establish the right loop breakers. Otherwise + -- we can easily create an infinite loop (#9583 is an example) + -- + -- Also crucial to re-analyse the /original/ bindings + -- in case the first pass accidentally discarded as dead code + -- a binding that was actually needed (albeit before its + -- definition site). #17724 threw this up. + + initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules) + -- The RULES declarations keep things alive! + + -- Note [Preventing loops due to imported functions rules] + imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv + [ mapVarEnv (const maps_to) $ + getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) + | imp_rule <- imp_rules + , not (isBuiltinRule imp_rule) -- See Note [Plugin rules] + , let maps_to = exprFreeIds (ru_rhs imp_rule) + `delVarSetList` ru_bndrs imp_rule + , arg <- ru_args imp_rule ] + + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) + go _ [] + = (initial_uds, []) + go env (bind:binds) + = (final_usage, bind' ++ binds') + where + (bs_usage, binds') = go env binds + (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind + bs_usage + +occurAnalyseExpr :: CoreExpr -> CoreExpr +-- Do occurrence analysis, and discard occurrence info returned +occurAnalyseExpr expr + = snd (occAnal initOccEnv expr) + +{- Note [Plugin rules] +~~~~~~~~~~~~~~~~~~~~~~ +Conal Elliott (#11651) built a GHC plugin that added some +BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to +do some domain-specific transformations that could not be expressed +with an ordinary pattern-matching CoreRule. But then we can't extract +the dependencies (in imp_rule_edges) from ru_rhs etc, because a +BuiltinRule doesn't have any of that stuff. + +So we simply assume that BuiltinRules have no dependencies, and filter +them out from the imp_rule_edges comprehension. +-} + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ + +Note [Recursive bindings: the grand plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across a binding group + Rec { x1 = r1; ...; xn = rn } +we treat it like this (occAnalRecBind): + +1. Occurrence-analyse each right hand side, and build a + "Details" for each binding to capture the results. + + Wrap the details in a Node (details, node-id, dep-node-ids), + where node-id is just the unique of the binder, and + dep-node-ids lists all binders on which this binding depends. + We'll call these the "scope edges". + See Note [Forming the Rec groups]. + + All this is done by makeNode. + +2. Do SCC-analysis on these Nodes. Each SCC will become a new Rec or + NonRec. The key property is that every free variable of a binding + is accounted for by the scope edges, so that when we are done + everything is still in scope. + +3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we + identify suitable loop-breakers to ensure that inlining terminates. + This is done by occAnalRec. + +4. To do so we form a new set of Nodes, with the same details, but + different edges, the "loop-breaker nodes". The loop-breaker nodes + have both more and fewer dependencies than the scope edges + (see Note [Choosing loop breakers]) + + More edges: if f calls g, and g has an active rule that mentions h + then we add an edge from f -> h + + Fewer edges: we only include dependencies on active rules, on rule + RHSs (not LHSs) and if there is an INLINE pragma only + on the stable unfolding (and vice versa). The scope + edges must be much more inclusive. + +5. The "weak fvs" of a node are, by definition: + the scope fvs - the loop-breaker fvs + See Note [Weak loop breakers], and the nd_weak field of Details + +6. Having formed the loop-breaker nodes + +Note [Dead code] +~~~~~~~~~~~~~~~~ +Dropping dead code for a cyclic Strongly Connected Component is done +in a very simple way: + + the entire SCC is dropped if none of its binders are mentioned + in the body; otherwise the whole thing is kept. + +The key observation is that dead code elimination happens after +dependency analysis: so 'occAnalBind' processes SCCs instead of the +original term's binding groups. + +Thus 'occAnalBind' does indeed drop 'f' in an example like + + letrec f = ...g... + g = ...(...g...)... + in + ...g... + +when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in +'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes +'AcyclicSCC f', where 'body_usage' won't contain 'f'. + +------------------------------------------------------------ +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" +and "g uses f", no matter how indirectly. We do a SCC analysis +with an edge f -> g if "f uses g". + +More precisely, "f uses g" iff g should be in scope wherever f is. +That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f (Note [Rules are extra RHSs]) + c) or the LHS or a rule for f (Note [Rule dependency info]) + +These conditions apply regardless of the activation of the RULE (eg it might be +inactive in this phase but become active later). Once a Rec is broken up +it can never be put back together, so we must be conservative. + +The principle is that, regardless of rule firings, every variable is +always in scope. + + * Note [Rules are extra RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" + keeps the specialised "children" alive. If the parent dies + (because it isn't referenced any more), then the children will die + too (unless they are already referenced directly). + + To that end, we build a Rec group for each cyclic strongly + connected component, + *treating f's rules as extra RHSs for 'f'*. + More concretely, the SCC analysis runs on a graph with an edge + from f -> g iff g is mentioned in + (a) f's rhs + (b) f's RULES + These are rec_edges. + + Under (b) we include variables free in *either* LHS *or* RHS of + the rule. The former might seems silly, but see Note [Rule + dependency info]. So in Example [eftInt], eftInt and eftIntFB + will be put in the same Rec, even though their 'main' RHSs are + both non-recursive. + + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a RuleInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + + * Note [Rules are visible in their own rec group] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want the rules for 'f' to be visible in f's right-hand side. + And we'd like them to be visible in other functions in f's Rec + group. E.g. in Note [Specialisation rules] we want f' rule + to be visible in both f's RHS, and fs's RHS. + + This means that we must simplify the RULEs first, before looking + at any of the definitions. This is done by Simplify.simplRecBind, + when it calls addLetIdInfo. + +------------------------------------------------------------ +Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. +We avoid infinite inlinings by choosing loop breakers, and +ensuring that a loop breaker cuts each loop. + +See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which +deals with a closely related source of infinite loops. + +Fundamentally, we do SCC analysis on a graph. For each recursive +group we choose a loop breaker, delete all edges to that node, +re-analyse the SCC, and iterate. + +But what is the graph? NOT the same graph as was used for Note +[Forming Rec groups]! In particular, a RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in GHC.Core.Opt.Simplify + +Hence, if + f's RHS (or its INLINE template if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. + +In general, take the free variables of f's RHS, and augment it with +all the variables reachable by RULES from those starting points. That +is the whole reason for computing rule_fv_env in occAnalBind. (Of +course we only consider free vars that are also binders in this Rec +group.) See also Note [Finding rule RHS free vars] + +Note that when we compute this rule_fv_env, we only consider variables +free in the *RHS* of the rule, in contrast to the way we build the +Rec group in the first place (Note [Rule dependency info]) + +Note that if 'g' has RHS that mentions 'w', we should add w to +g's loop-breaker edges. More concretely there is an edge from f -> g +iff + (a) g is mentioned in f's RHS `xor` f's INLINE rhs + (see Note [Inline rules]) + (b) or h is mentioned in f's RHS, and + g appears in the RHS of an active RULE of h + or a transitive sequence of active rules starting with h + +Why "active rules"? See Note [Finding rule RHS free vars] + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note again that the edges of the graph we use for computing loop breakers +are not the same as the edges we use for computing the Rec blocks. +That's why we compute + +- rec_edges for the Rec block analysis +- loop_breaker_nodes for the loop breaker analysis + + * Note [Finding rule RHS free vars] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Consider this real example from Data Parallel Haskell + tagZero :: Array Int -> Array Tag + {-# INLINE [1] tagZeroes #-} + tagZero xs = pmap (\x -> fromBool (x==0)) xs + + {-# RULES "tagZero" [~1] forall xs n. + pmap fromBool = tagZero xs #-} + So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. + However, tagZero can only be inlined in phase 1 and later, while + the RULE is only active *before* phase 1. So there's no problem. + + To make this work, we look for the RHS free vars only for + *active* rules. That's the reason for the occ_rule_act field + of the OccEnv. + + * Note [Weak loop breakers] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + There is a last nasty wrinkle. Suppose we have + + Rec { f = f_rhs + RULE f [] = g + + h = h_rhs + g = h + ...more... + } + + Remember that we simplify the RULES before any RHS (see Note + [Rules are visible in their own rec group] above). + + So we must *not* postInlineUnconditionally 'g', even though + its RHS turns out to be trivial. (I'm assuming that 'g' is + not chosen as a loop breaker.) Why not? Because then we + drop the binding for 'g', which leaves it out of scope in the + RULE! + + Here's a somewhat different example of the same thing + Rec { g = h + ; h = ...f... + ; f = f_rhs + RULE f [] = g } + Here the RULE is "below" g, but we *still* can't postInlineUnconditionally + g, because the RULE for f is active throughout. So the RHS of h + might rewrite to h = ...g... + So g must remain in scope in the output program! + + We "solve" this by: + + Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff g is a "missing free variable" of the Rec group + + A "missing free variable" x is one that is mentioned in an RHS or + INLINE or RULE of a binding in the Rec group, but where the + dependency on x may not show up in the loop_breaker_nodes (see + note [Choosing loop breakers} above). + + A normal "strong" loop breaker has IAmLoopBreaker False. So + + Inline postInlineUnconditionally + strong IAmLoopBreaker False no no + weak IAmLoopBreaker True yes no + other yes yes + + The **sole** reason for this kind of loop breaker is so that + postInlineUnconditionally does not fire. Ugh. (Typically it'll + inline via the usual callSiteInline stuff, so it'll be dead in the + next pass, so the main Ugh is the tiresome complication.) + +Note [Rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +Note that RULES for imported functions are important in practice; they +occur a lot in the libraries. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE RankNTypes #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +Because of this problem, we make a small change in the occurrence analyser +designed to mark functions like "filter" as strong loop breakers on the basis that: + 1. The RHS of filter mentions the local function "filterFB" + 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS + +So for each RULE for an *imported* function we are going to add +dependency edges between the *local* FVS of the rule LHS and the +*local* FVS of the rule RHS. We don't do anything special for RULES on +local functions because the standard occurrence analysis stuff is +pretty good at getting loop-breakerness correct there. + +It is important to note that even with this extra hack we aren't always going to get +things right. For example, it might be that the rule LHS mentions an imported Id, +and another module has a RULE that can rewrite that imported Id to one of our local +Ids. + +Note [Specialising imported functions] (referred to from Specialise) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT for *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [Rules for imported +functions]. In particular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might +not be as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function + +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to something at the bottom: + f = \x -> B.g (q x) + h = \y -> 3 + + RULE: B.g (q x) = h x + +Applying this rule makes f refer to h, although f doesn't appear to +depend on h. (And, as in Note [Rules for imported functions], the +dependency might be more indirect. For example, f might mention C.t +rather than B.g, where C.t eventually inlines to B.g.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.g in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. + +------------------------------------------------------------ +Note [Inline rules] +~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to Inline Rules, +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. + +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs + + +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg + + foo :: Int -> Int + {-# INLINE [1] foo #-} + foo x = x+1 + + bar :: Int -> Int + {-# INLINE [1] bar #-} + bar x = foo x + 1 + + {-# RULES "foo" [~1] forall x. foo x = bar x #-} + +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) + + +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): + + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this group, which is typical of what SpecConstr builds: + + fs a = ....f (C a).... + f x = ....f (C a).... + {-# RULE f (C a) = fs a #-} + +So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). + +But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: + - the RULE is applied in f's RHS (see Note [Self-recursive rules] in GHC.Core.Opt.Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE + +This showed up when compiling Control.Concurrent.Chan.getChanContents. + +------------------------------------------------------------ +Note [Finding join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's the occurrence analyser's job to find bindings that we can turn into join +points, but it doesn't perform that transformation right away. Rather, it marks +the eligible bindings as part of their occurrence data, leaving it to the +simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. +The simplifier then eta-expands the RHS if needed and then updates the +occurrence sites. Dividing the work this way means that the occurrence analyser +still only takes one pass, yet one can always tell the difference between a +function call and a jump by looking at the occurrence (because the same pass +changes the 'IdDetails' and propagates the binders to their occurrence sites). + +To track potential join points, we use the 'occ_tail' field of OccInfo. A value +of `AlwaysTailCalled n` indicates that every occurrence of the variable is a +tail call with `n` arguments (counting both value and type arguments). Otherwise +'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the +rest of 'OccInfo' until it goes on the binder. + +Note [Join points and unfoldings/rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let j2 y = blah + let j x = j2 (x+x) + {-# INLINE [2] j #-} + in case e of { A -> j 1; B -> ...; C -> j 2 } + +Before j is inlined, we'll have occurrences of j2 in +both j's RHS and in its stable unfolding. We want to discover +j2 as a join point. So we must do the adjustRhsUsage thing +on j's RHS. That's why we pass mb_join_arity to calcUnfolding. + +Aame with rules. Suppose we have: + + let j :: Int -> Int + j y = 2 * y + let k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 y = j y #-} + k x y = x + 2 * y + in case e of { A -> k 1 2; B -> k 3 5; C -> blah } + +We identify k as a join point, and we want j to be a join point too. +Without the RULE it would be, and we don't want the RULE to mess it +up. So provided the join-point arity of k matches the args of the +rule we can allow the tail-cal info from the RHS of the rule to +propagate. + +* Wrinkle for Rec case. In the recursive case we don't know the + join-point arity in advance, when calling occAnalUnfolding and + occAnalRules. (See makeNode.) We don't want to pass Nothing, + because then a recursive joinrec might lose its join-poin-hood + when SpecConstr adds a RULE. So we just make do with the + *current* join-poin-hood, stored in the Id. + + In the non-recursive case things are simple: see occAnalNonRecBind + +* Wrinkle for RULES. Suppose the example was a bit different: + let j :: Int -> Int + j y = 2 * y + k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 = j #-} + k x y = x + 2 * y + in ... + If we eta-expanded the rule all woudl be well, but as it stands the + one arg of the rule don't match the join-point arity of 2. + + Conceivably we could notice that a potential join point would have + an "undersaturated" rule and account for it. This would mean we + could make something that's been specialised a join point, for + instance. But local bindings are rarely specialised, and being + overly cautious about rules only costs us anything when, for some `j`: + + * Before specialisation, `j` has non-tail calls, so it can't be a join point. + * During specialisation, `j` gets specialised and thus acquires rules. + * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), + and so now `j` *could* become a join point. + + This appears to be very rare in practice. TODO Perhaps we should gather + statistics to be sure. + +------------------------------------------------------------ +Note [Adjusting right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a dance we need to do after analysing a lambda expression or +a right-hand side. In particular, we need to + + a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot + lambda, or a non-recursive join point; and + b) call 'markAllNonTail' *unless* the binding is for a join point. + +Some examples, with how the free occurrences in e (assumed not to be a value +lambda) get marked: + + inside lam non-tail-called + ------------------------------------------------------------ + let x = e No Yes + let f = \x -> e Yes Yes + let f = \x{OneShot} -> e No Yes + \x -> e Yes Yes + join j x = e No No + joinrec j x = e Yes No + +There are a few other caveats; most importantly, if we're marking a binding as +'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so +that the effect cascades properly. Consequently, at the time the RHS is +analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must +return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once +join-point-hood has been decided. + +Thus the overall sequence taking place in 'occAnalNonRecBind' and +'occAnalRecBind' is as follows: + + 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. + 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make + the binding a join point. + 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when + recursive.) + +(In the recursive case, this logic is spread between 'makeNode' and +'occAnalRec'.) +-} + +------------------------------------------------------------------ +-- occAnalBind +------------------------------------------------------------------ + +occAnalBind :: OccEnv -- The incoming OccEnv + -> TopLevelFlag + -> ImpRuleEdges + -> CoreBind + -> UsageDetails -- Usage details of scope + -> (UsageDetails, -- Of the whole let(rec) + [CoreBind]) + +occAnalBind env lvl top_env (NonRec binder rhs) body_usage + = occAnalNonRecBind env lvl top_env binder rhs body_usage +occAnalBind env lvl top_env (Rec pairs) body_usage + = occAnalRecBind env lvl top_env pairs body_usage + +----------------- +occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage + | isTyVar bndr -- A type let; we don't gather usage info + = (body_usage, [NonRec bndr rhs]) + + | not (bndr `usedIn` body_usage) -- It's not mentioned + = (body_usage, []) + + | otherwise -- It's mentioned in the body + = (body_usage' `andUDs` rhs_usage4, [NonRec final_bndr rhs']) + where + (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr + occ = idOccInfo tagged_bndr + + -- Get the join info from the *new* decision + -- See Note [Join points and unfoldings/rules] + mb_join_arity = willBeJoinId_maybe tagged_bndr + is_join_point = isJust mb_join_arity + + final_bndr = tagged_bndr `setIdUnfolding` unf' + `setIdSpecialisation` mkRuleInfo rules' + + env1 | is_join_point = env -- See Note [Join point RHSs] + | certainly_inline = env -- See Note [Cascading inlines] + | otherwise = rhsCtxt env + + -- See Note [Sources of one-shot information] + rhs_env = env1 { occ_one_shots = argOneShots dmd } + + (rhs_usage1, rhs') = occAnalRhs rhs_env mb_join_arity rhs + + -- Unfoldings + -- See Note [Unfoldings and join points] + unf = idUnfolding bndr + (unf_usage, unf') = occAnalUnfolding rhs_env mb_join_arity unf + rhs_usage2 = rhs_usage1 `andUDs` unf_usage + + -- Rules + -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + rules_w_uds = occAnalRules rhs_env mb_join_arity bndr + rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds + rules' = map fstOf3 rules_w_uds + rhs_usage3 = foldr andUDs rhs_usage2 rule_uds + rhs_usage4 = case lookupVarEnv imp_rule_edges bndr of + Nothing -> rhs_usage3 + Just vs -> addManyOccs rhs_usage3 vs + -- See Note [Preventing loops due to imported functions rules] + + certainly_inline -- See Note [Cascading inlines] + = case occ of + OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 } + -> active && not_stable + _ -> False + + dmd = idDemandInfo bndr + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) + +----------------- +occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalRecBind env lvl imp_rule_edges pairs body_usage + = foldr (occAnalRec rhs_env lvl) (body_usage, []) sccs + -- For a recursive group, we + -- * occ-analyse all the RHSs + -- * compute strongly-connected components + -- * feed those components to occAnalRec + -- See Note [Recursive bindings: the grand plan] + where + sccs :: [SCC Details] + sccs = {-# SCC "occAnalBind.scc" #-} + stronglyConnCompFromEdgedVerticesUniq nodes + + nodes :: [LetrecNode] + nodes = {-# SCC "occAnalBind.assoc" #-} + map (makeNode rhs_env imp_rule_edges bndr_set) pairs + + bndrs = map fst pairs + bndr_set = mkVarSet bndrs + rhs_env = env `addInScope` bndrs + +{- +Note [Unfoldings and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We assume that anything in an unfolding occurs multiple times, since unfoldings +are often copied (that's the whole point!). But we still need to track tail +calls for the purpose of finding join points. +-} + +----------------------------- +occAnalRec :: OccEnv -> TopLevelFlag + -> SCC Details + -> (UsageDetails, [CoreBind]) + -> (UsageDetails, [CoreBind]) + + -- The NonRec case is just like a Let (NonRec ...) above +occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs + , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs })) + (body_uds, binds) + | not (bndr `usedIn` body_uds) + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- It's mentioned in the body + = (body_uds' `andUDs` rhs_uds', + NonRec tagged_bndr rhs : binds) + where + (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr + rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive + rhs_bndrs rhs_uds + + -- The Rec case is the interesting one + -- See Note [Recursive bindings: the grand plan] + -- See Note [Loop breaking] +occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds) + | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- At this point we always build a single Rec + = -- pprTrace "occAnalRec" (vcat + -- [ text "weak_fvs" <+> ppr weak_fvs + -- , text "lb nodes" <+> ppr loop_breaker_nodes]) + (final_uds, Rec pairs : binds) + + where + bndrs = map nd_bndr details_s + bndr_set = mkVarSet bndrs + + ------------------------------ + -- See Note [Choosing loop breakers] for loop_breaker_nodes + final_uds :: UsageDetails + loop_breaker_nodes :: [LetrecNode] + (final_uds, loop_breaker_nodes) + = mkLoopBreakerNodes env lvl bndr_set body_uds details_s + + ------------------------------ + weak_fvs :: VarSet + weak_fvs = mapUnionVarSet nd_weak details_s + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs loop_breaker_nodes [] + | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes [] + -- If weak_fvs is empty, the loop_breaker_nodes will include + -- all the edges in the original scope edges [remember, + -- weak_fvs is the difference between scope edges and + -- lb-edges], so a fresh SCC computation would yield a + -- single CyclicSCC result; and reOrderNodes deals with + -- exactly that case + + +------------------------------------------------------------------ +-- Loop breaking +------------------------------------------------------------------ + +type Binding = (Id,CoreExpr) + +loopBreakNodes :: Int + -> VarSet -- All binders + -> VarSet -- Binders whose dependencies may be "missing" + -- See Note [Weak loop breakers] + -> [LetrecNode] + -> [Binding] -- Append these to the end + -> [Binding] +{- +loopBreakNodes is applied to the list of nodes for a cyclic strongly +connected component (there's guaranteed to be a cycle). It returns +the same nodes, but + a) in a better order, + b) with some of the Ids having a IAmALoopBreaker pragma + +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means +that the simplifier can guarantee not to loop provided it never records an inlining +for these no-inline guys. + +Furthermore, the order of the binds is such that if we neglect dependencies +on the no-inline Ids then the binds are topologically sorted. This means +that the simplifier will generally do a good job if it works from top bottom, +recording inlinings for any Ids which aren't marked as "no-inline" as it goes. +-} + +-- Return the bindings sorted into a plausible order, and marked with loop breakers. +loopBreakNodes depth bndr_set weak_fvs nodes binds + = -- pprTrace "loopBreakNodes" (ppr nodes) $ + go (stronglyConnCompFromEdgedVerticesUniqR nodes) + where + go [] = binds + go (scc:sccs) = loop_break_scc scc (go sccs) + + loop_break_scc scc binds + = case scc of + AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds + CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds + +---------------------------------- +reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding] + -- Choose a loop breaker, mark it no-inline, + -- and call loopBreakNodes on the rest +reOrderNodes _ _ _ [] _ = panic "reOrderNodes" +reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds +reOrderNodes depth bndr_set weak_fvs (node : nodes) binds + = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen + -- , text "chosen" <+> ppr chosen_nodes ]) $ + loopBreakNodes new_depth bndr_set weak_fvs unchosen $ + (map mk_loop_breaker chosen_nodes ++ binds) + where + (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb + (nd_score (node_payload node)) + [node] [] nodes + + approximate_lb = depth >= 2 + new_depth | approximate_lb = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 + +mk_loop_breaker :: LetrecNode -> Binding +mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs}) + = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs) + where + tail_info = tailCallInfo (idOccInfo bndr) + +mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding +-- See Note [Weak loop breakers] +mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr + , nd_rhs = rhs}) + | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs) + | otherwise = (bndr, rhs) + where + occ' = weakLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) + +---------------------------------- +chooseLoopBreaker :: Bool -- True <=> Too many iterations, + -- so approximate + -> NodeScore -- Best score so far + -> [LetrecNode] -- Nodes with this score + -> [LetrecNode] -- Nodes with higher scores + -> [LetrecNode] -- Unprocessed nodes + -> ([LetrecNode], [LetrecNode]) + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in +chooseLoopBreaker _ _ loop_nodes acc [] + = (loop_nodes, acc) -- Done + + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] +chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) + | approx_lb + , rank sc == rank loop_sc + = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes + + | sc `betterLB` loop_sc -- Better score so pick this new one + = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes + + | otherwise -- Worse score so don't pick it + = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes + where + sc = nd_score (node_payload node) + +{- +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakders is +linear in the number of instance declarations. + +Note [Loop breakers and INLINE/INLINABLE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Avoid choosing a function with an INLINE pramga as the loop breaker! +If such a function is mutually-recursive with a non-INLINE thing, +then the latter should be the loop-breaker. + +It's vital to distinguish between INLINE and INLINABLE (the +Bool returned by hasStableCoreUnfolding_maybe). If we start with + Rec { {-# INLINABLE f #-} + f x = ...f... } +and then worker/wrapper it through strictness analysis, we'll get + Rec { {-# INLINABLE $wf #-} + $wf p q = let x = (p,q) in ...f... + + {-# INLINE f #-} + f x = case x of (p,q) -> $wf p q } + +Now it is vital that we choose $wf as the loop breaker, so we can +inline 'f' in '$wf'. + +Note [DFuns should not be loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's particularly bad to make a DFun into a loop breaker. See +Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance + +We give DFuns a higher score than ordinary CONLIKE things because +if there's a choice we want the DFun to be the non-loop breaker. Eg + +rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) + + $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) + {-# DFUN #-} + $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) + } + +Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it +if we can't unravel the DFun first. + +Note [Constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really really important to inline dictionaries. Real +example (the Enum Ordering instance from GHC.Base): + + rec f = \ x -> case d of (p,q,r) -> p x + g = \ x -> case d of (p,q,r) -> q x + d = (v, f, g) + +Here, f and g occur just once; but we can't inline them into d. +On the other hand we *could* simplify those case expressions if +we didn't stupidly choose d as the loop breaker. +But we won't because constructor args are marked "Many". +Inlining dictionaries is really essential to unravelling +the loops in static numeric dictionaries, see GHC.Float. + +Note [Closure conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. +The immediate motivation came from the result of a closure-conversion transformation +which generated code like this: + + data Clo a b = forall c. Clo (c -> a -> b) c + + ($:) :: Clo a b -> a -> b + Clo f env $: x = f env x + + rec { plus = Clo plus1 () + + ; plus1 _ n = Clo plus2 n + + ; plus2 Zero n = n + ; plus2 (Succ m) n = Succ (plus $: m $: n) } + +If we inline 'plus' and 'plus1', everything unravels nicely. But if +we choose 'plus1' as the loop breaker (which is entirely possible +otherwise), the loop does not unravel nicely. + + +@occAnalUnfolding@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that this +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. + + +************************************************************************ +* * + Making nodes +* * +************************************************************************ +-} + +type ImpRuleEdges = IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs + +noImpRuleEdges :: ImpRuleEdges +noImpRuleEdges = emptyVarEnv + +type LetrecNode = Node Unique Details -- Node comes from Digraph + -- The Unique key is gotten from the Id +data Details + = ND { nd_bndr :: Id -- Binder + + , nd_rhs :: CoreExpr -- RHS, already occ-analysed + + , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS + -- INVARIANT: (nd_rhs_bndrs nd, _) == + -- collectBinders (nd_rhs nd) + + , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings + -- ignoring phase (ie assuming all are active) + -- See Note [Forming Rec groups] + + , nd_inl :: IdSet -- Free variables of + -- the stable unfolding (if present and active) + -- or the RHS (if not) + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined + + , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds + -- but are *not* in nd_inl. These are the ones whose + -- dependencies might not be respected by loop_breaker_nodes + -- See Note [Weak loop breakers] + + , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES + + , nd_score :: NodeScore + } + +instance Outputable Details where + ppr nd = text "ND" <> braces + (sep [ text "bndr =" <+> ppr (nd_bndr nd) + , text "uds =" <+> ppr (nd_uds nd) + , text "inl =" <+> ppr (nd_inl nd) + , text "weak =" <+> ppr (nd_weak nd) + , text "rule =" <+> ppr (nd_active_rule_fvs nd) + , text "score =" <+> ppr (nd_score nd) + ]) + +-- The NodeScore is compared lexicographically; +-- e.g. lower rank wins regardless of size +type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker + , Int -- Size of rhs: higher => more likely to be picked as LB + -- Maxes out at maxExprSize; we just use it to prioritise + -- small functions + , Bool ) -- Was it a loop breaker before? + -- True => more likely to be picked + -- Note [Loop breakers, node scoring, and stability] + +rank :: NodeScore -> Int +rank (r, _, _) = r + +makeNode :: OccEnv -> ImpRuleEdges -> VarSet + -> (Var, CoreExpr) -> LetrecNode +-- See Note [Recursive bindings: the grand plan] +makeNode env imp_rule_edges bndr_set (bndr, rhs) + = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs) + -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR + -- is still deterministic with edges in nondeterministic order as + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + details = ND { nd_bndr = bndr' + , nd_rhs = rhs' + , nd_rhs_bndrs = bndrs' + , nd_uds = rhs_usage3 + , nd_inl = inl_fvs + , nd_weak = node_fvs `minusVarSet` inl_fvs + , nd_active_rule_fvs = active_rule_fvs + , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } + + bndr' = bndr `setIdUnfolding` unf' + `setIdSpecialisation` mkRuleInfo rules' + + -- Get join point info from the *current* decision + -- We don't know what the new decision will be! + -- Using the old decision at least allows us to + -- preserve existing join point, even RULEs are added + -- See Note [Join points and unfoldings/rules] + mb_join_arity = isJoinId_maybe bndr + + -- Constructing the edges for the main Rec computation + -- See Note [Forming Rec groups] + (bndrs, body) = collectBinders rhs + rhs_env = rhsCtxt env + (rhs_usage1, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body + rhs' = mkLams bndrs' body' + rhs_usage3 = foldr andUDs rhs_usage1 rule_uds + `andUDs` unf_uds + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + node_fvs = udFreeVars bndr_set rhs_usage3 + + -- Finding the free variables of the rules + is_active = occ_rule_act env :: Activation -> Bool + + rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] + rules_w_uds = occAnalRules rhs_env mb_join_arity bndr + + rules' = map fstOf3 rules_w_uds + + rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs + rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) + (lookupVarEnv imp_rule_edges bndr) + -- See Note [Preventing loops due to imported functions rules] + [ (ru_act rule, udFreeVars bndr_set rhs_uds) + | (rule, _, rhs_uds) <- rules_w_uds ] + rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds + active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs + , is_active a] + + -- Finding the usage details of the INLINE pragma (if any) + unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness + -- here because that is what we are setting! + (unf_uds, unf') = occAnalUnfolding rhs_env mb_join_arity unf + + -- Find the "nd_inl" free vars; for the loop-breaker phase + -- These are the vars that would become free if the function + -- was inlinined; usually that means the RHS, unless the + -- unfolding is a stable one. + -- Note: We could do this only for functions with an *active* unfolding + -- (returning emptyVarSet for an inactive one), but is_active + -- isn't the right thing (it tells about RULE activation), + -- so we'd need more plumbing + inl_fvs | isStableUnfolding unf = udFreeVars bndr_set unf_uds + | otherwise = udFreeVars bndr_set rhs_usage1 + +mkLoopBreakerNodes :: OccEnv -> TopLevelFlag + -> VarSet + -> UsageDetails -- for BODY of let + -> [Details] + -> (UsageDetails, -- adjusted + [LetrecNode]) +-- Does four things +-- a) tag each binder with its occurrence info +-- b) add a NodeScore to each node +-- c) make a Node with the right dependency edges for +-- the loop-breaker SCC analysis +-- d) adjust each RHS's usage details according to +-- the binder's (new) shotness and join-point-hood +mkLoopBreakerNodes env lvl bndr_set body_uds details_s + = (final_uds, zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs') + where + (final_uds, bndrs') + = tagRecBinders lvl body_uds + [ (bndr, uds, rhs_bndrs) + | ND { nd_bndr = bndr, nd_uds = uds, nd_rhs_bndrs = rhs_bndrs } + <- details_s ] + + mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr + = DigraphNode nd' (varUnique old_bndr) (nonDetKeysUniqSet lb_deps) + -- It's OK to use nonDetKeysUniqSet here as + -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges + -- in nondeterministic order as explained in + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + nd' = nd { nd_bndr = new_bndr, nd_score = score } + score = nodeScore env new_bndr lb_deps nd + lb_deps = extendFvs_ rule_fv_env inl_fvs + + + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- mentioned in RHS of active rules for f + -- Domain is *subset* of bound vars (others have no rule fvs) + rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) + init_rule_fvs -- See Note [Finding rule RHS free vars] + = [ (b, trimmed_rule_fvs) + | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s + , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set + , not (isEmptyVarSet trimmed_rule_fvs) ] + + +------------------------------------------ +nodeScore :: OccEnv + -> Id -- Binder with new occ-info + -> VarSet -- Loop-breaker dependencies + -> Details + -> NodeScore +nodeScore env new_bndr lb_deps + (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs }) + + | not (isId old_bndr) -- A type or coercion variable is never a loop breaker + = (100, 0, False) + + | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers + = (0, 0, True) -- See Note [Self-recursion and loop breakers] + + | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has + = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker + + | exprIsTrivial rhs + = mk_score 10 -- Practically certain to be inlined + -- Used to have also: && not (isExportedId bndr) + -- But I found this sometimes cost an extra iteration when we have + -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } + -- where df is the exported dictionary. Then df makes a really + -- bad choice for loop breaker + + | DFunUnfolding { df_args = args } <- old_unf + -- Never choose a DFun as a loop breaker + -- Note [DFuns should not be loop breakers] + = (9, length args, is_lb) + + -- Data structures are more important than INLINE pragmas + -- so that dictionary/method recursion unravels + + | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf + = mk_score 6 + + | is_con_app rhs -- Data types help with cases: + = mk_score 5 -- Note [Constructor applications] + + | isStableUnfolding old_unf + , can_unfold + = mk_score 3 + + | isOneOcc (idOccInfo new_bndr) + = mk_score 2 -- Likely to be inlined + + | can_unfold -- The Id has some kind of unfolding + = mk_score 1 + + | otherwise + = (0, 0, is_lb) + + where + mk_score :: Int -> NodeScore + mk_score rank = (rank, rhs_size, is_lb) + + -- is_lb: see Note [Loop breakers, node scoring, and stability] + is_lb = isStrongLoopBreaker (idOccInfo old_bndr) + + old_unf = realIdUnfolding old_bndr + can_unfold = canUnfold old_unf + rhs = case old_unf of + CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } + | isStableSource src + -> unf_rhs + _ -> bind_rhs + -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding + rhs_size = case old_unf of + CoreUnfolding { uf_guidance = guidance } + | UnfIfGoodArgs { ug_size = size } <- guidance + -> size + _ -> cheapExprSize rhs + + + -- Checking for a constructor application + -- Cheap and cheerful; the simplifier moves casts out of the way + -- The lambda case is important to spot x = /\a. C (f a) + -- which comes up when C is a dictionary constructor and + -- f is a default method. + -- Example: the instance for Show (ST s a) in GHC.ST + -- + -- However we *also* treat (\x. C p q) as a con-app-like thing, + -- Note [Closure conversion] + is_con_app (Var v) = isConLikeId v + is_con_app (App f _) = is_con_app f + is_con_app (Lam _ e) = is_con_app e + is_con_app (Tick _ e) = is_con_app e + is_con_app _ = False + +maxExprSize :: Int +maxExprSize = 20 -- Rather arbitrary + +cheapExprSize :: CoreExpr -> Int +-- Maxes out at maxExprSize +cheapExprSize e + = go 0 e + where + go n e | n >= maxExprSize = n + | otherwise = go1 n e + + go1 n (Var {}) = n+1 + go1 n (Lit {}) = n+1 + go1 n (Type {}) = n + go1 n (Coercion {}) = n + go1 n (Tick _ e) = go1 n e + go1 n (Cast e _) = go1 n e + go1 n (App f a) = go (go1 n f) a + go1 n (Lam b e) + | isTyVar b = go1 n e + | otherwise = go (n+1) e + go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) + go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) + + gos n [] = n + gos n (e:es) | n >= maxExprSize = n + | otherwise = gos (go1 n e) es + +betterLB :: NodeScore -> NodeScore -> Bool +-- If n1 `betterLB` n2 then choose n1 as the loop breaker +betterLB (rank1, size1, lb1) (rank2, size2, _) + | rank1 < rank2 = True + | rank1 > rank2 = False + | size1 < size2 = False -- Make the bigger n2 into the loop breaker + | size1 > size2 = True + | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it + | otherwise = False -- See Note [Loop breakers, node scoring, and stability] + +{- Note [Self-recursion and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + rec { f = ...f...g... + ; g = .....f... } +then 'f' has to be a loop breaker anyway, so we may as well choose it +right away, so that g can inline freely. + +This is really just a cheap hack. Consider + rec { f = ...g... + ; g = ..f..h... + ; h = ...f....} +Here f or g are better loop breakers than h; but we might accidentally +choose h. Finding the minimal set of loop breakers is hard. + +Note [Loop breakers, node scoring, and stability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To choose a loop breaker, we give a NodeScore to each node in the SCC, +and pick the one with the best score (according to 'betterLB'). + +We need to be jolly careful (#12425, #12234) about the stability +of this choice. Suppose we have + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...f.. + False -> ..f... + +In each iteration of the simplifier the occurrence analyser OccAnal +chooses a loop breaker. Suppose in iteration 1 it choose g as the loop +breaker. That means it is free to inline f. + +Suppose that GHC decides to inline f in the branches of the case, but +(for some reason; eg it is not saturated) in the rhs of g. So we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...g...g..... + False -> ..g..g.... + +Now suppose that, for some reason, in the next iteration the occurrence +analyser chooses f as the loop breaker, so it can freely inline g. And +again for some reason the simplifier inlines g at its calls in the case +branches, but not in the RHS of f. Then we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...(...f...f...)...(...f..f..)..... + False -> ..(...f...f...)...(..f..f...).... + +You can see where this is going! Each iteration of the simplifier +doubles the number of calls to f or g. No wonder GHC is slow! + +(In the particular example in comment:3 of #12425, f and g are the two +mutually recursive fmap instances for CondT and Result. They are both +marked INLINE which, oddly, is why they don't inline in each other's +RHS, because the call there is not saturated.) + +The root cause is that we flip-flop on our choice of loop breaker. I +always thought it didn't matter, and indeed for any single iteration +to terminate, it doesn't matter. But when we iterate, it matters a +lot!! + +So The Plan is this: + If there is a tie, choose the node that + was a loop breaker last time round + +Hence the is_lb field of NodeScore + +************************************************************************ +* * + Right hand sides +* * +************************************************************************ +-} + +occAnalRhs :: OccEnv -> Maybe JoinArity + -> CoreExpr -- RHS + -> (UsageDetails, CoreExpr) +occAnalRhs env mb_join_arity rhs + = case occAnalLamOrRhs env bndrs body of { (body_usage, bndrs', body') -> + let rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so + + -- Final adjustment + rhs_usage = adjustRhsUsage mb_join_arity NonRecursive bndrs' body_usage + + in (rhs_usage, rhs') } + where + (bndrs, body) = collectBinders rhs + +occAnalUnfolding :: OccEnv + -> Maybe JoinArity -- See Note [Join points and unfoldings/rules] + -> Unfolding + -> (UsageDetails, Unfolding) +-- Occurrence-analyse a stable unfolding; +-- discard a non-stable one altogether. +occAnalUnfolding env mb_join_arity unf + = case unf of + unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src -> (usage, unf') + | otherwise -> (emptyDetails, unf) + where -- For non-Stable unfoldings we leave them undisturbed, but + -- don't count their usage because the simplifier will discard them. + -- We leave them undisturbed because nodeScore uses their size info + -- to guide its decisions. It's ok to leave un-substituted + -- expressions in the tree because all the variables that were in + -- scope remain in scope; there is no cloning etc. + (usage, rhs') = occAnalRhs env mb_join_arity rhs + + unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules] + | otherwise = unf { uf_tmpl = rhs' } + + unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + -> ( final_usage, unf { df_args = args' } ) + where + env' = env `addInScope` bndrs + (usage, args') = occAnalList env' args + final_usage = markAllManyNonTail (delDetailsList usage bndrs) + + unf -> (emptyDetails, unf) + +occAnalRules :: OccEnv + -> Maybe JoinArity -- See Note [Join points and unfoldings/rules] + -> Id -- Get rules from here + -> [(CoreRule, -- Each (non-built-in) rule + UsageDetails, -- Usage details for LHS + UsageDetails)] -- Usage details for RHS +occAnalRules env mb_join_arity bndr + = map occ_anal_rule (idCoreRules bndr) + where + occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = (rule', lhs_uds', rhs_uds') + where + env' = env `addInScope` bndrs + rule' | noBinderSwaps env = rule -- Note [Unfoldings and rules] + | otherwise = rule { ru_args = args', ru_rhs = rhs' } + + (lhs_uds, args') = occAnalList env' args + lhs_uds' = markAllManyNonTail $ + lhs_uds `delDetailsList` bndrs + + (rhs_uds, rhs') = occAnal env' rhs + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_uds' = markAllNonTailIf (not exact_join) $ + markAllMany $ + rhs_uds `delDetailsList` bndrs + + exact_join = exactJoin mb_join_arity args + -- See Note [Join points and unfoldings/rules] + + occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails) + +{- Note [Join point RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = e + join j = Just x + +We want to inline x into j right away, so we don't want to give +the join point a RhsCtxt (#14137). It's not a huge deal, because +the FloatIn pass knows to float into join point RHSs; and the simplifier +does not float things out of join point RHSs. But it's a simple, cheap +thing to do. See #14137. + +Note [Unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally unfoldings and rules are already occurrence-analysed, so we +don't want to reconstruct their trees; we just want to analyse them to +find how they use their free variables. + +EXCEPT if there is a binder-swap going on, in which case we do want to +produce a new tree. + +So we have a fast-path that keeps the old tree if the occ_bs_env is +empty. This just saves a bit of allocation and reconstruction; not +a big deal. + +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an rhsCtxt for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally. +If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and + (b) certainly_inline says "yes" when preInlineUnconditionally says "no" +then the simplifier iterates indefinitely: + x = f y + k = Just x -- We decide that k is 'certainly_inline' + v = ...k... -- but preInlineUnconditionally doesn't inline it +inline ==> + k = Just (f y) + v = ...k... +float ==> + x1 = f y + k = Just x1 + v = ...k... + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. + + +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +occAnalList :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) +occAnalList _ [] = (emptyDetails, []) +occAnalList env (e:es) = case occAnal env e of { (uds1, e') -> + case occAnalList env es of { (uds2, es') -> + (uds1 `andUDs` uds2, e' : es') } } + +occAnal :: OccEnv + -> CoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + CoreExpr) + +occAnal _ expr@(Type _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal env expr@(Var _) = occAnalApp env (expr, [], []) + -- At one stage, I gathered the idRuleVars for the variable here too, + -- which in a way is the right thing to do. + -- But that went wrong right after specialisation, when + -- the *occurrences* of the overloaded function didn't have any + -- rules in them, so the *specialised* versions looked as if they + -- weren't used at all. + +occAnal _ (Coercion co) + = (addManyOccs emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion variables] + +{- +Note [Gather occurrences of coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, so that +we can sort them into the right place when doing dependency analysis. +-} + +occAnal env (Tick tickish body) + | SourceNote{} <- tickish + = (usage, Tick tickish body') + -- SourceNotes are best-effort; so we just proceed as usual. + -- If we drop a tick due to the issues described below it's + -- not the end of the world. + + | tickish `tickishScopesLike` SoftScope + = (markAllNonTail usage, Tick tickish body') + + | Breakpoint _ ids <- tickish + = (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body') + -- never substitute for any of the Ids in a Breakpoint + + | otherwise + = (usage_lam, Tick tickish body') + where + !(usage,body') = occAnal env body + -- for a non-soft tick scope, we can inline lambdas only + usage_lam = markAllNonTail (markAllInsideLam usage) + -- TODO There may be ways to make ticks and join points play + -- nicer together, but right now there are problems: + -- let j x = ... in tick (j 1) + -- Making j a join point may cause the simplifier to drop t + -- (if the tick is put into the continuation). So we don't + -- count j 1 as a tail call. + -- See #14242. + +occAnal env (Cast expr co) + = case occAnal env expr of { (usage, expr') -> + let usage1 = markAllManyNonTailIf (isRhsEnv env) usage + -- usage1: if we see let x = y `cast` co + -- then mark y as 'Many' so that we don't + -- immediately inline y again. + usage2 = addManyOccs usage1 (coVarsOfCo co) + -- usage2: see Note [Gather occurrences of coercion variables] + in (markAllNonTail usage2, Cast expr' co) + } + +occAnal env app@(App _ _) + = occAnalApp env (collectArgsTicks tickishFloatable app) + +-- Ignore type variables altogether +-- (a) occurrences inside type lambdas only not marked as InsideLam +-- (b) type variables not in environment + +occAnal env (Lam x body) + | isTyVar x + = case occAnal env body of { (body_usage, body') -> + (markAllNonTail body_usage, Lam x body') + } + +-- For value lambdas we do a special hack. Consider +-- (\x. \y. ...x...) +-- If we did nothing, x is used inside the \y, so would be marked +-- as dangerous to dup. But in the common case where the abstraction +-- is applied to two arguments this is over-pessimistic. +-- So instead, we just mark each binder with its occurrence +-- info in the *body* of the multiple lambda. +-- Then, the simplifier is careful when partially applying lambdas. + +occAnal env expr@(Lam _ _) + = case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') -> + let + expr' = mkLams tagged_bndrs body' + usage1 = markAllNonTail usage + one_shot_gp = all isOneShotBndr tagged_bndrs + final_usage = markAllInsideLamIf (not one_shot_gp) usage1 + in + (final_usage, expr') } + where + (bndrs, body) = collectBinders expr + +occAnal env (Case scrut bndr ty alts) + = case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') -> + let alt_env = addBndrSwap scrut' bndr $ + env { occ_encl = OccVanilla } `addInScope` [bndr] + in + case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') -> + let + alts_usage = foldr orUDs emptyDetails alts_usage_s + (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr + total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1 + -- Alts can have tail calls, but the scrutinee can't + in + total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} + +occAnal env (Let bind body) + = case occAnal (env `addInScope` bindersOf bind) + body of { (body_usage, body') -> + case occAnalBind env NotTopLevel + noImpRuleEdges bind + body_usage of { (final_usage, new_binds) -> + (final_usage, mkLets new_binds body') }} + +occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) +occAnalArgs _ [] _ + = (emptyDetails, []) + +occAnalArgs env (arg:args) one_shots + | isTypeArg arg + = case occAnalArgs env args one_shots of { (uds, args') -> + (uds, arg:args') } + + | otherwise + = case argCtxt env one_shots of { (arg_env, one_shots') -> + case occAnal arg_env arg of { (uds1, arg') -> + case occAnalArgs env args one_shots' of { (uds2, args') -> + (uds1 `andUDs` uds2, arg':args') }}} + +{- +Applications are dealt with specially because we want +the "build hack" to work. + +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. +-} + +occAnalApp :: OccEnv + -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) + -> (UsageDetails, Expr CoreBndr) +-- Naked variables (not applied) end up here too +occAnalApp env (Var fun, args, ticks) + -- Account for join arity of runRW# continuation + -- See Note [Simplification of runRW#] + -- + -- NB: Do not be tempted to make the next (Var fun, args, tick) + -- equation into an 'otherwise' clause for this equation + -- The former has a bang-pattern to occ-anal the args, and + -- we don't want to occ-anal them twice in the runRW# case! + -- This caused #18296 + | fun `hasKey` runRWKey + , [t1, t2, arg] <- args + , let (usage, arg') = occAnalRhs env (Just 1) arg + = (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + +occAnalApp env (Var fun_id, args, ticks) + = (all_uds, mkTicks ticks $ mkApps fun' args') + where + (fun', fun_id') = lookupBndrSwap env fun_id + + fun_uds = mkOneOcc fun_id' int_cxt n_args + -- NB: fun_uds is computed for fun_id', not fun_id + -- See (BS1) in Note [The binder-swap substitution] + + all_uds = fun_uds `andUDs` final_args_uds + + !(args_uds, args') = occAnalArgs env args one_shots + !final_args_uds = markAllNonTail $ + markAllInsideLamIf (isRhsEnv env && is_exp) $ + args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "inside-lambda", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor or PAP + -- argument position, which is what we want. Typically those + -- constructor arguments are just variables, or trivial expressions. + -- We use inside-lam because it's like eta-expanding the PAP. + -- + -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] + + n_val_args = valArgCount args + n_args = length args + int_cxt = case occ_encl env of + OccScrut -> IsInteresting + _other | n_val_args > 0 -> IsInteresting + | otherwise -> NotInteresting + + is_exp = isExpandableApp fun_id n_val_args + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs + + one_shots = argsOneShots (idStrictness fun_id) guaranteed_val_args + guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo + (occ_one_shots env)) + -- See Note [Sources of one-shot information], bullet point A'] + +occAnalApp env (fun, args, ticks) + = (markAllNonTail (fun_uds `andUDs` args_uds), + mkTicks ticks $ mkApps fun' args') + where + !(fun_uds, fun') = occAnal (addAppCtxt env args) fun + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexs like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some True items + -- onto the context stack. + !(args_uds, args') = occAnalArgs env args [] + + +{- +Note [Sources of one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrence analyser obtains one-shot-lambda information from two sources: + +A: Saturated applications: eg f e1 .. en + + In general, given a call (f e1 .. en) we can propagate one-shot info from + f's strictness signature into e1 .. en, but /only/ if n is enough to + saturate the strictness signature. A strictness signature like + + f :: C1(C1(L))LS + + means that *if f is applied to three arguments* then it will guarantee to + call its first argument at most once, and to call the result of that at + most once. But if f has fewer than three arguments, all bets are off; e.g. + + map (f (\x y. expensive) e2) xs + + Here the \x y abstraction may be called many times (once for each element of + xs) so we should not mark x and y as one-shot. But if it was + + map (f (\x y. expensive) 3 2) xs + + then the first argument of f will be called at most once. + + The one-shot info, derived from f's strictness signature, is + computed by 'argsOneShots', called in occAnalApp. + +A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) + where f is as above. + + In this case, f is only manifestly applied to one argument, so it does not + look saturated. So by the previous point, we should not use its strictness + signature to learn about the one-shotness of \x y. But in this case we can: + build is fully applied, so we may use its strictness signature; and from + that we learn that build calls its argument with two arguments *at most once*. + + So there is really only one call to f, and it will have three arguments. In + that sense, f is saturated, and we may proceed as described above. + + Hence the computation of 'guaranteed_val_args' in occAnalApp, using + '(occ_one_shots env)'. See also #13227, comment:9 + +B: Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + + Propagate one-shot info from the demanand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) + + This information must have come from a previous run of the demanand + analyser. + +Previously, the demand analyser would *also* set the one-shot information, but +that code was buggy (see #11770), so doing it only in on place, namely here, is +saner. + +Note [OneShots] +~~~~~~~~~~~~~~~ +When analysing an expression, the occ_one_shots argument contains information +about how the function is being used. The length of the list indicates +how many arguments will eventually be passed to the analysed expression, +and the OneShotInfo indicates whether this application is once or multiple times. + +Example: + + Context of f occ_one_shots when analysing f + + f 1 2 [OneShot, OneShot] + map (f 1) [OneShot, NoOneShotInfo] + build f [OneShot, OneShot] + f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] + +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, because it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). +-} + +occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr + -> (UsageDetails, [CoreBndr], CoreExpr) +-- Tags the returned binders with their OccInfo, but does +-- not do any markInsideLam to the returned usage details +occAnalLamOrRhs env [] body + = case occAnal env body of (body_usage, body') -> (body_usage, [], body') + -- RHS of thunk or nullary join point + +occAnalLamOrRhs env (bndr:bndrs) body + | isTyVar bndr + = -- Important: Keep the environment so that we don't inline into an RHS like + -- \(@ x) -> C @x (f @x) + -- (see the beginning of Note [Cascading inlines]). + case occAnalLamOrRhs env bndrs body of + (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') + +occAnalLamOrRhs env binders body + = case occAnal env_body body of { (body_usage, body') -> + let + (final_usage, tagged_binders) = tagLamBinders body_usage binders' + -- Use binders' to put one-shot info on the lambdas + in + (final_usage, tagged_binders, body') } + where + env1 = env `addInScope` binders + (env_body, binders') = oneShotGroup env1 binders + +occAnalAlt :: OccEnv + -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt env (con, bndrs, rhs) + = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) -> + let + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs + in -- See Note [Binders in case alternatives] + (alt_usg, (con, tagged_bndrs, rhs1)) } + +{- +************************************************************************ +* * + OccEnv +* * +************************************************************************ +-} + +data OccEnv + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- See Note [OneShots] + , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active + , occ_rule_act :: Activation -> Bool -- Which rules are active + -- See Note [Finding rule RHS free vars] + + -- See Note [The binder-swap substitution] + -- If x :-> (y, co) is in the env, + -- then please replace x by (y |> sym mco) + -- Invariant of course: idType x = exprType (y |> sym mco) + , occ_bs_env :: VarEnv (OutId, MCoercion) + , occ_bs_rng :: VarSet -- Vars free in the range of occ_bs_env + -- Domain is Global and Local Ids + -- Range is just Local Ids + } + + +----------------------------- +-- OccEncl is used to control whether to inline into constructor arguments +-- For example: +-- x = (p,q) -- Don't inline p or q +-- y = /\a -> (p a, q a) -- Still don't inline p or q +-- z = f (p,q) -- Do inline p,q; it may make a rule fire +-- So OccEncl tells enough about the context to know what to do when +-- we encounter a constructor application or PAP. +-- +-- OccScrut is used to set the "interesting context" field of OncOcc + +data OccEncl + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + + | OccScrut -- Scrutintee of a case + -- Can inline into constructor args + + | OccVanilla -- Argument of function, body of lambda, etc + -- Do inline into constructor args here + +instance Outputable OccEncl where + ppr OccRhs = text "occRhs" + ppr OccScrut = text "occScrut" + ppr OccVanilla = text "occVanilla" + +-- See note [OneShots] +type OneShots = [OneShotInfo] + +initOccEnv :: OccEnv +initOccEnv + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] + + -- To be conservative, we say that all + -- inlines and rules are active + , occ_unf_act = \_ -> True + , occ_rule_act = \_ -> True + + , occ_bs_env = emptyVarEnv + , occ_bs_rng = emptyVarSet } + +noBinderSwaps :: OccEnv -> Bool +noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env + +scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv +scrutCtxt env alts + | interesting_alts = env { occ_encl = OccScrut, occ_one_shots = [] } + | otherwise = env { occ_encl = OccVanilla, occ_one_shots = [] } + where + interesting_alts = case alts of + [] -> False + [alt] -> not (isDefaultAlt alt) + _ -> True + -- 'interesting_alts' is True if the case has at least one + -- non-default alternative. That in turn influences + -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! + +rhsCtxt :: OccEnv -> OccEnv +rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } + +argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) +argCtxt env [] + = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) +argCtxt env (one_shots:one_shots_s) + = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) + +isRhsEnv :: OccEnv -> Bool +isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of + OccRhs -> True + _ -> False + +addInScope :: OccEnv -> [Var] -> OccEnv +-- See Note [The binder-swap substitution] +addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs + | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } + | otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs } + +oneShotGroup :: OccEnv -> [CoreBndr] + -> ( OccEnv + , [CoreBndr] ) + -- The result binders have one-shot-ness set that they might not have had originally. + -- This happens in (build (\c n -> e)). Here the occurrence analyser + -- linearity context knows that c,n are one-shot, and it records that fact in + -- the binder. This is useful to guide subsequent float-in/float-out transformations + +oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs + = go ctxt bndrs [] + where + go ctxt [] rev_bndrs + = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } + , reverse rev_bndrs ) + + go [] bndrs rev_bndrs + = ( env { occ_one_shots = [], occ_encl = OccVanilla } + , reverse rev_bndrs ++ bndrs ) + + go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs + | isId bndr = go ctxt' bndrs (bndr': rev_bndrs) + | otherwise = go ctxt bndrs (bndr : rev_bndrs) + where + bndr' = updOneShotInfo bndr one_shot + -- Use updOneShotInfo, not setOneShotInfo, as pre-existing + -- one-shot info might be better than what we can infer, e.g. + -- due to explicit use of the magic 'oneShot' function. + -- See Note [The oneShot function] + + +markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var] +-- Mark the lambdas of a non-recursive join point as one-shot. +-- This is good to prevent gratuitous float-out etc +markJoinOneShots mb_join_arity bndrs + = case mb_join_arity of + Nothing -> bndrs + Just n -> go n bndrs + where + go 0 bndrs = bndrs + go _ [] = [] -- This can legitimately happen. + -- e.g. let j = case ... in j True + -- This will become an arity-1 join point after the + -- simplifier has eta-expanded it; but it may not have + -- enough lambdas /yet/. (Lint checks that JoinIds do + -- have enough lambdas.) + go n (b:bs) = b' : go (n-1) bs + where + b' | isId b = setOneShotLambda b + | otherwise = b + +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } + +transClosureFV :: VarEnv VarSet -> VarEnv VarSet +-- If (f,g), (g,h) are in the input, then (f,h) is in the output +-- as well as (f,g), (g,h) +transClosureFV env + | no_change = env + | otherwise = transClosureFV (listToUFM_Directly new_fv_list) + where + (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) + -- It's OK to use nonDetUFMToList here because we'll forget the + -- ordering by creating a new set with listToUFM + bump no_change (b,fvs) + | no_change_here = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs)) + where + (new_fvs, no_change_here) = extendFvs env fvs + +------------- +extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + +extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool) +-- (extendFVs env s) returns +-- (s `union` env(s), env(s) `subset` s) +extendFvs env s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) + where + extras :: VarSet -- env(s) + extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $ + -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes + intersectUFM_C (\x _ -> x) env (getUniqSet s) + +{- +************************************************************************ +* * + Binder swap +* * +************************************************************************ + +Note [Binder swap] +~~~~~~~~~~~~~~~~~~ +The "binder swap" transformation swaps occurrence of the +scrutinee of a case for occurrences of the case-binder: + + (1) case x of b { pi -> ri } + ==> + case x of b { pi -> ri[b/x] } + + (2) case (x |> co) of b { pi -> ri } + ==> + case (x |> co) of b { pi -> ri[b |> sym co/x] } + +The substitution ri[b/x] etc is done by the occurrence analyser. +See Note [The binder-swap substitution]. + +There are two reasons for making this swap: + +(A) It reduces the number of occurrences of the scrutinee, x. + That in turn might reduce its occurrences to one, so we + can inline it and save an allocation. E.g. + let x = factorial y in case x of b { I# v -> ...x... } + If we replace 'x' by 'b' in the alternative we get + let x = factorial y in case x of b { I# v -> ...b... } + and now we can inline 'x', thus + case (factorial y) of b { I# v -> ...b... } + +(B) The case-binder b has unfolding information; in the + example above we know that b = I# v. That in turn allows + nested cases to simplify. Consider + case x of b { I# v -> + ...(case x of b2 { I# v2 -> rhs })... + If we replace 'x' by 'b' in the alternative we get + case x of b { I# v -> + ...(case b of b2 { I# v2 -> rhs })... + and now it is trivial to simplify the inner case: + case x of b { I# v -> + ...(let b2 = b in rhs)... + + The same can happen even if the scrutinee is a variable + with a cast: see Note [Case of cast] + +The reason for doing these transformations /here in the occurrence +analyser/ is because it allows us to adjust the OccInfo for 'x' and +'b' as we go. + + * Suppose the only occurrences of 'x' are the scrutinee and in the + ri; then this transformation makes it occur just once, and hence + get inlined right away. + + * If instead the Simplifier replaces occurrences of x with + occurrences of b, that will mess up b's occurrence info. That in + turn might have consequences. + +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + +Note [The binder-swap substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binder-swap is implemented by the occ_bs_env field of OccEnv. +There are two main pieces: + +* Given case x |> co of b { alts } + we add [x :-> (b, co)] to the occ_bs_env environment; this is + done by addBndrSwap. + +* Then, at an occurrence of a variable, we look up in the occ_bs_env + to perform the swap. This is done by lookupBndrSwap. + +Some tricky corners: + +(BS1) We do the substitution before gathering occurrence info. So in + the above example, an occurrence of x turns into an occurrence + of b, and that's what we gather in the UsageDetails. It's as + if the binder-swap occurred before occurrence analysis. See + the computation of fun_uds in occAnalApp. + +(BS2) When doing a lookup in occ_bs_env, we may need to iterate, + as you can see implemented in lookupBndrSwap. Why? + Consider case x of a { 1# -> e1; DEFAULT -> + case x of b { 2# -> e2; DEFAULT -> + case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}} + At the first case addBndrSwap will extend occ_bs_env with + [x :-> a] + At the second case we occ-anal the scrutinee 'x', which looks up + 'x in occ_bs_env, returning 'a', as it should. + Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding + occ_bs_env = [x :-> a, a :-> b] + At the third case we'll again look up 'x' which returns 'a'. + But we don't want to stop the lookup there, else we'll end up with + case x of a { 1# -> e1; DEFAULT -> + case a of b { 2# -> e2; DEFAULT -> + case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}} + Instead, we want iterate the lookup in addBndrSwap, to give + case x of a { 1# -> e1; DEFAULT -> + case a of b { 2# -> e2; DEFAULT -> + case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}} + This makes a particular difference for case-merge, which works + only if the scrutinee is the case-binder of the immediately enclosing + case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils + See #19581 for the bug report that showed this up. + +(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env, + and we encounter: + - \x. blah + Here we want to delete the x-binding from occ_bs_env + + - \b. blah + This is harder: we really want to delete all bindings that + have 'b' free in the range. That is a bit tiresome to implement, + so we compromise. We keep occ_bs_rng, which is the set of + free vars of rng(occc_bs_env). If a binder shadows any of these + variables, we discard all of occ_bs_env. Safe, if a bit + brutal. NB, however: the simplifer de-shadows the code, so the + next time around this won't happen. + + These checks are implemented in addInScope. + + The occurrence analyser itself does /not/ do cloning. It could, in + principle, but it'd make it a bit more complicated and there is no + great benefit. The simplifer uses cloning to get a no-shadowing + situation, the care-when-shadowing behaviour above isn't needed for + long. + +(BS4) The domain of occ_bs_env can include GlobaIds. Eg + case M.foo of b { alts } + We extend occ_bs_env with [M.foo :-> b]. That's fine. + +(BS5) We have to apply the occ_bs_env substitution uniformly, + including to (local) rules and unfoldings. + +Historical note +--------------- +We used to do the binder-swap transformation by introducing +a proxy let-binding, thus; + + case x of b { pi -> ri } + ==> + case x of b { pi -> let x = b in ri } + +But that had two problems: + +1. If 'x' is an imported GlobalId, we'd end up with a GlobalId + on the LHS of a let-binding which isn't allowed. We worked + around this for a while by "localising" x, but it turned + out to be very painful #16296, + +2. In CorePrep we use the occurrence analyser to do dead-code + elimination (see Note [Dead code in CorePrep]). But that + occasionally led to an unlifted let-binding + case x of b { DEFAULT -> let x::Int# = b in ... } + which disobeys one of CorePrep's output invariants (no unlifted + let-bindings) -- see #5433. + +Doing a substitution (via occ_bs_env) is much better. + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> ...cb... } + +Core Lint never expects to find an *occurrence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See #5028. + +NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier +doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. + +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressions when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. The straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. +-} + +addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv +-- See Note [The binder-swap substitution] +addBndrSwap scrut case_bndr + env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) + | Just (scrut_var, mco) <- get_scrut_var (stripTicksTopE (const True) scrut) + , scrut_var /= case_bndr + -- Consider: case x of x { ... } + -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop + = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) + , occ_bs_rng = rng_vars `extendVarSet` case_bndr' + `unionVarSet` tyCoVarsOfMCo mco } + + | otherwise + = env + where + get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion) + get_scrut_var (Var v) = Just (v, MRefl) + get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast] + get_scrut_var _ = Nothing + + case_bndr' = zapIdOccInfo case_bndr + -- See Note [Zap case binders in proxy bindings] + +lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) +-- See Note [The binder-swap substitution] +-- Returns an expression of the same type as Id +lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr + = case lookupVarEnv bs_env bndr of { + Nothing -> (Var bndr, bndr) ; + Just (bndr1, mco) -> + + -- Why do we iterate here? + -- See (BS2) in Note [The binder-swap substitution] + case lookupBndrSwap env bndr1 of + (fun, fun_id) -> (add_cast fun mco, fun_id) } + + where + add_cast fun MRefl = fun + add_cast fun (MCo co) = Cast fun (mkSymCo co) + -- We must switch that 'co' to 'sym co'; + -- see the comment with occ_bs_env + -- No need to test for isReflCo, because 'co' came from + -- a (Cast e co) and hence is unlikely to be Refl + +{- +************************************************************************ +* * +\subsection[OccurAnal-types]{OccEnv} +* * +************************************************************************ + +Note [UsageDetails and zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On many occasions, we must modify all gathered occurrence data at once. For +instance, all occurrences underneath a (non-one-shot) lambda set the +'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but +that takes O(n) time and we will do this often---in particular, there are many +places where tail calls are not allowed, and each of these causes all variables +to get marked with 'NoTailCallInfo'. + +Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along +with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" +recording which variables have been zapped in some way. Zapping all occurrence +info then simply means setting the corresponding zapped set to the whole +'OccInfoEnv', a fast O(1) operation. +-} + +type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage + -- INVARIANT: never IAmDead + -- (Deadness is signalled by not being in the map at all) + +type ZappedSet = OccInfoEnv -- Values are ignored + +data UsageDetails + = UD { ud_env :: !OccInfoEnv + , ud_z_many :: ZappedSet -- apply 'markMany' to these + , ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these + , ud_z_no_tail :: ZappedSet } -- apply 'markNonTail' to these + -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv + +instance Outputable UsageDetails where + ppr ud = ppr (ud_env (flattenUsageDetails ud)) + +------------------- +-- UsageDetails API + +andUDs, orUDs + :: UsageDetails -> UsageDetails -> UsageDetails +andUDs = combineUsageDetailsWith addOccInfo +orUDs = combineUsageDetailsWith orOccInfo + +mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc id int_cxt arity + | isLocalId id + = emptyDetails { ud_env = unitVarEnv id occ_info } + | otherwise + = emptyDetails + where + occ_info = OneOcc { occ_in_lam = NotInsideLam + , occ_n_br = oneBranch + , occ_int_cxt = int_cxt + , occ_tail = AlwaysTailCalled arity } + +addManyOccId :: UsageDetails -> Id -> UsageDetails +-- Add the non-committal (id :-> noOccInfo) to the usage details +addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo } + +-- Add several occurrences, assumed not to be tail calls +addManyOcc :: Var -> UsageDetails -> UsageDetails +addManyOcc v u | isId v = addManyOccId u v + | otherwise = u + -- Give a non-committal binder info (i.e noOccInfo) because + -- a) Many copies of the specialised thing can appear + -- b) We don't want to substitute a BIG expression inside a RULE + -- even if that's the only occurrence of the thing + -- (Same goes for INLINE.) + +addManyOccs :: UsageDetails -> VarSet -> UsageDetails +addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set + -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes + +delDetails :: UsageDetails -> Id -> UsageDetails +delDetails ud bndr + = ud `alterUsageDetails` (`delVarEnv` bndr) + +delDetailsList :: UsageDetails -> [Id] -> UsageDetails +delDetailsList ud bndrs + = ud `alterUsageDetails` (`delVarEnvList` bndrs) + +emptyDetails :: UsageDetails +emptyDetails = UD { ud_env = emptyVarEnv + , ud_z_many = emptyVarEnv + , ud_z_in_lam = emptyVarEnv + , ud_z_no_tail = emptyVarEnv } + +isEmptyDetails :: UsageDetails -> Bool +isEmptyDetails = isEmptyVarEnv . ud_env + +markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail + :: UsageDetails -> UsageDetails +markAllMany ud = ud { ud_z_many = ud_env ud } +markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } +markAllNonTail ud = ud { ud_z_no_tail = ud_env ud } + +markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails + +markAllInsideLamIf True ud = markAllInsideLam ud +markAllInsideLamIf False ud = ud + +markAllNonTailIf True ud = markAllNonTail ud +markAllNonTailIf False ud = ud + + +markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo + +markAllManyNonTailIf :: Bool -- If this is true + -> UsageDetails -- Then do markAllManyNonTail on this + -> UsageDetails +markAllManyNonTailIf True uds = markAllManyNonTail uds +markAllManyNonTailIf False uds = uds + +lookupDetails :: UsageDetails -> Id -> OccInfo +lookupDetails ud id + | isCoVar id -- We do not currently gather occurrence info (from types) + = noOccInfo -- for CoVars, so we must conservatively mark them as used + -- See Note [DoO not mark CoVars as dead] + | otherwise + = case lookupVarEnv (ud_env ud) id of + Just occ -> doZapping ud id occ + Nothing -> IAmDead + +usedIn :: Id -> UsageDetails -> Bool +v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud + +udFreeVars :: VarSet -> UsageDetails -> VarSet +-- Find the subset of bndrs that are mentioned in uds +udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud) + +{- Note [Do not mark CoVars as dead] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's obviously wrong to mark CoVars as dead if they are used. +Currently we don't traverse types to gather usase info for CoVars, +so we had better treat them as having noOccInfo. + +This showed up in #15696 we had something like + case eq_sel d of co -> ...(typeError @(...co...) "urk")... + +Then 'd' was substituted by a dictionary, so the expression +simpified to + case (Coercion ) of co -> ...(typeError @(...co...) "urk")... + +But then the "drop the case altogether" equation of rebuildCase +thought that 'co' was dead, and discarded the entire case. Urk! + +I have no idea how we managed to avoid this pitfall for so long! +-} + +------------------- +-- Auxiliary functions for UsageDetails implementation + +combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) + -> UsageDetails -> UsageDetails -> UsageDetails +combineUsageDetailsWith plus_occ_info ud1 ud2 + | isEmptyDetails ud1 = ud2 + | isEmptyDetails ud2 = ud1 + | otherwise + = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) + , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) + , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) + , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } + +doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo +doZapping ud var occ + = doZappingByUnique ud (varUnique var) occ + +doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo +doZappingByUnique (UD { ud_z_many = many + , ud_z_in_lam = in_lam + , ud_z_no_tail = no_tail }) + uniq occ + = occ2 + where + occ1 | uniq `elemVarEnvByKey` many = markMany occ + | uniq `elemVarEnvByKey` in_lam = markInsideLam occ + | otherwise = occ + occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1 + | otherwise = occ1 + +alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails +alterZappedSets ud f + = ud { ud_z_many = f (ud_z_many ud) + , ud_z_in_lam = f (ud_z_in_lam ud) + , ud_z_no_tail = f (ud_z_no_tail ud) } + +alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails +alterUsageDetails ud f + = ud { ud_env = f (ud_env ud) } `alterZappedSets` f + +flattenUsageDetails :: UsageDetails -> UsageDetails +flattenUsageDetails ud + = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) } + `alterZappedSets` const emptyVarEnv + +------------------- +-- See Note [Adjusting right-hand sides] +adjustRhsUsage :: Maybe JoinArity -> RecFlag + -> [CoreBndr] -- Outer lambdas, AFTER occ anal + -> UsageDetails -- From body of lambda + -> UsageDetails +adjustRhsUsage mb_join_arity rec_flag bndrs usage + = markAllInsideLamIf (not one_shot) $ + markAllNonTailIf (not exact_join) $ + usage + where + one_shot = case mb_join_arity of + Just join_arity + | isRec rec_flag -> False + | otherwise -> all isOneShotBndr (drop join_arity bndrs) + Nothing -> all isOneShotBndr bndrs + + exact_join = exactJoin mb_join_arity bndrs + +exactJoin :: Maybe JoinArity -> [a] -> Bool +exactJoin Nothing _ = False +exactJoin (Just join_arity) args = args `lengthIs` join_arity + -- Remember join_arity includes type binders + +type IdWithOccInfo = Id + +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [IdWithOccInfo]) -- Tagged binders +tagLamBinders usage binders + = usage' `seq` (usage', bndrs') + where + (usage', bndrs') = mapAccumR tagLamBinder usage binders + +tagLamBinder :: UsageDetails -- Of scope + -> Id -- Binder + -> (UsageDetails, -- Details with binder removed + IdWithOccInfo) -- Tagged binders +-- Used for lambda and case binders +-- It copes with the fact that lambda bindings can have a +-- stable unfolding, used for join points +tagLamBinder usage bndr + = (usage2, bndr') + where + occ = lookupDetails usage bndr + bndr' = setBinderOcc (markNonTail occ) bndr + -- Don't try to make an argument into a join point + usage1 = usage `delDetails` bndr + usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr) + -- This is effectively the RHS of a + -- non-join-point binding, so it's okay to use + -- addManyOccsSet, which assumes no tail calls + | otherwise = usage1 + +tagNonRecBinder :: TopLevelFlag -- At top level? + -> UsageDetails -- Of scope + -> CoreBndr -- Binder + -> (UsageDetails, -- Details with binder removed + IdWithOccInfo) -- Tagged binder + +tagNonRecBinder lvl usage binder + = let + occ = lookupDetails usage binder + will_be_join = decideJoinPointHood lvl usage [binder] + occ' | will_be_join = -- must already be marked AlwaysTailCalled + ASSERT(isAlwaysTailCalled occ) occ + | otherwise = markNonTail occ + binder' = setBinderOcc occ' binder + usage' = usage `delDetails` binder + in + usage' `seq` (usage', binder') + +tagRecBinders :: TopLevelFlag -- At top level? + -> UsageDetails -- Of body of let ONLY + -> [(CoreBndr, -- Binder + UsageDetails, -- RHS usage details + [CoreBndr])] -- Lambdas in new RHS + -> (UsageDetails, -- Adjusted details for whole scope, + -- with binders removed + [IdWithOccInfo]) -- Tagged binders +-- Substantially more complicated than non-recursive case. Need to adjust RHS +-- details *before* tagging binders (because the tags depend on the RHSes). +tagRecBinders lvl body_uds triples + = let + (bndrs, rhs_udss, _) = unzip3 triples + + -- 1. Determine join-point-hood of whole group, as determined by + -- the *unadjusted* usage details + unadj_uds = foldr andUDs body_uds rhs_udss + will_be_joins = decideJoinPointHood lvl unadj_uds bndrs + + -- 2. Adjust usage details of each RHS, taking into account the + -- join-point-hood decision + rhs_udss' = map adjust triples + adjust (bndr, rhs_uds, rhs_bndrs) + = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds + where + -- Can't use willBeJoinId_maybe here because we haven't tagged the + -- binder yet (the tag depends on these adjustments!) + mb_join_arity + | will_be_joins + , let occ = lookupDetails unadj_uds bndr + , AlwaysTailCalled arity <- tailCallInfo occ + = Just arity + | otherwise + = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if + Nothing -- we are making join points! + + -- 3. Compute final usage details from adjusted RHS details + adj_uds = foldr andUDs body_uds rhs_udss' + + -- 4. Tag each binder with its adjusted details + bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr + | bndr <- bndrs ] + + -- 5. Drop the binders from the adjusted details and return + usage' = adj_uds `delDetailsList` bndrs + in + (usage', bndrs') + +setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr +setBinderOcc occ_info bndr + | isTyVar bndr = bndr + | isExportedId bndr = if isManyOccs (idOccInfo bndr) + then bndr + else setIdOccInfo bndr noOccInfo + -- Don't use local usage info for visible-elsewhere things + -- BUT *do* erase any IAmALoopBreaker annotation, because we're + -- about to re-generate it and it shouldn't be "sticky" + + | otherwise = setIdOccInfo bndr occ_info + +-- | Decide whether some bindings should be made into join points or not. +-- Returns `False` if they can't be join points. Note that it's an +-- all-or-nothing decision, as if multiple binders are given, they're +-- assumed to be mutually recursive. +-- +-- It must, however, be a final decision. If we say "True" for 'f', +-- and then subsequently decide /not/ make 'f' into a join point, then +-- the decision about another binding 'g' might be invalidated if (say) +-- 'f' tail-calls 'g'. +-- +-- See Note [Invariants on join points] in "GHC.Core". +decideJoinPointHood :: TopLevelFlag -> UsageDetails + -> [CoreBndr] + -> Bool +decideJoinPointHood TopLevel _ _ + = False +decideJoinPointHood NotTopLevel usage bndrs + | isJoinId (head bndrs) + = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> + ppr bndrs) + all_ok + | otherwise + = all_ok + where + -- See Note [Invariants on join points]; invariants cited by number below. + -- Invariant 2 is always satisfiable by the simplifier by eta expansion. + all_ok = -- Invariant 3: Either all are join points or none are + all ok bndrs + + ok bndr + | -- Invariant 1: Only tail calls, all same join arity + AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) + + , -- Invariant 1 as applied to LHSes of rules + all (ok_rule arity) (idCoreRules bndr) + + -- Invariant 2a: stable unfoldings + -- See Note [Join points and INLINE pragmas] + , ok_unfolding arity (realIdUnfolding bndr) + + -- Invariant 4: Satisfies polymorphism rule + , isValidJoinPointType arity (idType bndr) + = True + + | otherwise + = False + + ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans + ok_rule join_arity (Rule { ru_args = args }) + = args `lengthIs` join_arity + -- Invariant 1 as applied to LHSes of rules + + -- ok_unfolding returns False if we should /not/ convert a non-join-id + -- into a join-id, even though it is AlwaysTailCalled + ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) + = not (isStableSource src && join_arity > joinRhsArity rhs) + ok_unfolding _ (DFunUnfolding {}) + = False + ok_unfolding _ _ + = True + +willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity +willBeJoinId_maybe bndr + = case tailCallInfo (idOccInfo bndr) of + AlwaysTailCalled arity -> Just arity + _ -> isJoinId_maybe bndr + + +{- Note [Join points and INLINE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let g = \x. not -- Arity 1 + {-# INLINE g #-} + in case x of + A -> g True True + B -> g True False + C -> blah2 + +Here 'g' is always tail-called applied to 2 args, but the stable +unfolding captured by the INLINE pragma has arity 1. If we try to +convert g to be a join point, its unfolding will still have arity 1 +(since it is stable, and we don't meddle with stable unfoldings), and +Lint will complain (see Note [Invariants on join points], (2a), in +GHC.Core. #13413. + +Moreover, since g is going to be inlined anyway, there is no benefit +from making it a join point. + +If it is recursive, and uselessly marked INLINE, this will stop us +making it a join point, which is annoying. But occasionally +(notably in class methods; see Note [Instances and loop breakers] in +GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion +unravels; so ignoring INLINE pragmas on recursive things isn't good +either. + +See Invariant 2a of Note [Invariants on join points] in GHC.Core + + +************************************************************************ +* * +\subsection{Operations over OccInfo} +* * +************************************************************************ +-} + +markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo + +markMany IAmDead = IAmDead +markMany occ = ManyOccs { occ_tail = occ_tail occ } + +markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam } +markInsideLam occ = occ + +markNonTail IAmDead = IAmDead +markNonTail occ = occ { occ_tail = NoTailCallInfo } + +addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo + +addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` + tailCallInfo a2 } + -- Both branches are at least One + -- (Argument is never IAmDead) + +-- (orOccInfo orig new) is used +-- when combining occurrence info from branches of a case + +orOccInfo (OneOcc { occ_in_lam = in_lam1 + , occ_n_br = nbr1 + , occ_int_cxt = int_cxt1 + , occ_tail = tail1 }) + (OneOcc { occ_in_lam = in_lam2 + , occ_n_br = nbr2 + , occ_int_cxt = int_cxt2 + , occ_tail = tail2 }) + = OneOcc { occ_n_br = nbr1 + nbr2 + , occ_in_lam = in_lam1 `mappend` in_lam2 + , occ_int_cxt = int_cxt1 `mappend` int_cxt2 + , occ_tail = tail1 `andTailCallInfo` tail2 } + +orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` + tailCallInfo a2 } + +andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo +andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) + | arity1 == arity2 = info +andTailCallInfo _ _ = NoTailCallInfo diff --git a/GHC/Core/Opt/Pipeline.hs b/GHC/Core/Opt/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Pipeline.hs @@ -0,0 +1,1041 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SimplCore]{Driver for simplifying @Core@ programs} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core +import GHC.Driver.Types +import GHC.Core.Opt.CSE ( cseProgram ) +import GHC.Core.Rules ( mkRuleBase, unionRuleBase, + extendRuleBaseList, ruleCheckProgram, addRuleInfo, + getRules, initRuleOpts ) +import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import GHC.Types.Id.Info +import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +import GHC.Core.Utils ( mkTicks, stripTicksTop ) +import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, + lintAnnots ) +import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) +import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Monad +import qualified GHC.Utils.Error as Err +import GHC.Core.Opt.FloatIn ( floatInwards ) +import GHC.Core.Opt.FloatOut ( floatOutwards ) +import GHC.Core.FamInstEnv +import GHC.Types.Id +import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) +import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.Opt.LiberateCase ( liberateCase ) +import GHC.Core.Opt.StaticArgs ( doStaticArgs ) +import GHC.Core.Opt.Specialise ( specProgram) +import GHC.Core.Opt.SpecConstr ( specConstrProgram) +import GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) +import GHC.Core.Opt.CprAnal ( cprAnalProgram ) +import GHC.Core.Opt.CallArity ( callArityAnalProgram ) +import GHC.Core.Opt.Exitify ( exitifyProgram ) +import GHC.Core.Opt.WorkWrap ( wwTopBinds ) +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Unit.Module.Env +import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) +import GHC.Runtime.Loader -- ( initializePlugins ) + +import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) +import GHC.Types.Unique.FM +import GHC.Utils.Outputable +import Control.Monad +import qualified GHC.LanguageExtensions as LangExt +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +core2core :: HscEnv -> ModGuts -> IO ModGuts +core2core hsc_env guts@(ModGuts { mg_module = mod + , mg_loc = loc + , mg_deps = deps + , mg_rdr_env = rdr_env }) + = do { -- make sure all plugins are loaded + + ; let builtin_passes = getCoreToDo dflags + orph_mods = mkModuleSet (mod : dep_orphs deps) + uniq_mask = 's' + ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod + orph_mods print_unqual loc $ + do { hsc_env' <- getHscEnv + ; dflags' <- liftIO $ initializePlugins hsc_env' + (hsc_dflags hsc_env') + ; all_passes <- withPlugins dflags' + installCoreToDos + builtin_passes + ; runCorePasses all_passes guts } + + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + "Grand total simplifier statistics" + FormatText + (pprSimplCount stats) + + ; return guts2 } + where + dflags = hsc_dflags hsc_env + home_pkg_rules = hptRules hsc_env (dep_mods deps) + hpt_rule_base = mkRuleBase home_pkg_rules + print_unqual = mkPrintUnqualified dflags rdr_env + -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. + -- This is very convienent for the users of the monad (e.g. plugins do not have to + -- consume the ModGuts to find the module) but somewhat ugly because mg_module may + -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which + -- would mean our cached value would go out of date. + +{- +************************************************************************ +* * + Generating the main optimisation pipeline +* * +************************************************************************ +-} + +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + = flatten_todos core_todo + where + opt_level = optLevel dflags + phases = simplPhases dflags + max_iter = maxSimplIterations dflags + rule_check = ruleCheck dflags + call_arity = gopt Opt_CallArity dflags + exitification = gopt Opt_Exitification dflags + strictness = gopt Opt_Strictness dflags + full_laziness = gopt Opt_FullLaziness dflags + do_specialise = gopt Opt_Specialise dflags + do_float_in = gopt Opt_FloatIn dflags + cse = gopt Opt_CSE dflags + spec_constr = gopt Opt_SpecConstr dflags + liberate_case = gopt Opt_LiberateCase dflags + late_dmd_anal = gopt Opt_LateDmdAnal dflags + late_specialise = gopt Opt_LateSpecialise dflags + static_args = gopt Opt_StaticArgumentTransformation dflags + rules_on = gopt Opt_EnableRewriteRules dflags + eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags + ww_on = gopt Opt_WorkerWrapper dflags + static_ptrs = xopt LangExt.StaticPointers dflags + + maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) + + maybe_strictness_before (Phase phase) + | phase `elem` strictnessBefore dflags = CoreDoDemand + maybe_strictness_before _ + = CoreDoNothing + + base_mode = SimplMode { sm_phase = panic "base_mode" + , sm_names = [] + , sm_dflags = dflags + , sm_rules = rules_on + , sm_eta_expand = eta_expand_on + , sm_inline = True + , sm_case_case = True } + + simpl_phase phase name iter + = CoreDoPasses + $ [ maybe_strictness_before phase + , CoreDoSimplify iter + (base_mode { sm_phase = phase + , sm_names = [name] }) + + , maybe_rule_check phase ] + + -- Run GHC's internal simplification phase, after all rules have run. + -- See Note [Compiler phases] in GHC.Types.Basic + simplify name = simpl_phase FinalPhase name max_iter + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently = CoreDoSimplify max_iter + (base_mode { sm_phase = InitialPhase + , sm_names = ["Gentle"] + , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase] + , sm_inline = True + -- See Note [Inline in InitialPhase] + , sm_case_case = False }) + -- Don't do case-of-case transformations. + -- This makes full laziness work better + + dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreDoDemand,CoreDoCpr] + + + demand_analyser = (CoreDoPasses ( + dmd_cpr_ww ++ + [simplify "post-worker-wrapper"] + )) + + -- Static forms are moved to the top level with the FloatOut pass. + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + static_ptrs_float_outwards = + runWhen static_ptrs $ CoreDoPasses + [ simpl_gently -- Float Out can't handle type lets (sometimes created + -- by simpleOptPgm via mkParallelBindings) + , CoreDoFloatOutwards FloatOutSwitches + { floatOutLambdas = Just 0 + , floatOutConstants = True + , floatOutOverSatApps = False + , floatToTopLevelOnly = True + } + ] + + core_todo = + if opt_level == 0 then + [ static_ptrs_float_outwards, + CoreDoSimplify max_iter + (base_mode { sm_phase = FinalPhase + , sm_names = ["Non-opt simplification"] }) + ] + + else {- opt_level >= 1 -} [ + + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently, + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + runWhen do_specialise CoreDoSpecialising, + + if full_laziness then + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = Just 0, + floatOutConstants = True, + floatOutOverSatApps = False, + floatToTopLevelOnly = False } + -- Was: gentleFloatOutSwitches + -- + -- I have no idea why, but not floating constants to + -- top level is very bad in some cases. + -- + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" + -- improved rewrite's allocation by 19%, and + -- made 0.0% difference to any other nofib + -- benchmark + -- + -- Not doing floatOutOverSatApps yet, we'll do + -- that later on when we've had a chance to get more + -- accurate arity information. In fact it makes no + -- difference at all to performance if we do it here, + -- but maybe we save some unnecessary to-and-fro in + -- the simplifier. + else + -- Even with full laziness turned off, we still need to float static + -- forms to the top level. See Note [Grand plan for static forms] in + -- GHC.Iface.Tidy.StaticPtrTable. + static_ptrs_float_outwards, + + -- Run the simplier phases 2,1,0 to allow rewrite rules to fire + CoreDoPasses [ simpl_phase (Phase phase) "main" max_iter + | phase <- [phases, phases-1 .. 1] ], + simpl_phase (Phase 0) "main" (max max_iter 3), + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simplifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + + runWhen do_float_in CoreDoFloatInwards, + -- Run float-inwards immediately before the strictness analyser + -- Doing so pushes bindings nearer their use site and hence makes + -- them more likely to be strict. These bindings might only show + -- up after the inlining from simplification. Example in fulsom, + -- Csg.calc, where an arg of timesDouble thereby becomes strict. + + runWhen call_arity $ CoreDoPasses + [ CoreDoCallArity + , simplify "post-call-arity" + ], + + -- Strictness analysis + runWhen strictness demand_analyser, + + runWhen exitification CoreDoExitify, + -- See note [Placement of the exitification pass] + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = floatLamArgs dflags, + floatOutConstants = True, + floatOutOverSatApps = True, + floatToTopLevelOnly = False }, + -- 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) + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + maybe_rule_check FinalPhase, + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case (CoreDoPasses [ + CoreLiberateCase, + simplify "post-liberate-case" + ]), -- Run the simplifier after LiberateCase to vastly + -- reduce the possibility of shadowing + -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr + + runWhen spec_constr CoreDoSpecConstr, + + maybe_rule_check FinalPhase, + + runWhen late_specialise + (CoreDoPasses [ CoreDoSpecialising + , simplify "post-late-spec"]), + + -- LiberateCase can yield new CSE opportunities because it peels + -- off one layer of a recursive function (concretely, I saw this + -- in wheel-sieve1), and I'm guessing that SpecConstr can too + -- And CSE is a very cheap pass. So it seems worth doing here. + runWhen ((liberate_case || spec_constr) && cse) CoreCSE, + + -- Final clean-up simplification: + simplify "final", + + runWhen late_dmd_anal $ CoreDoPasses ( + dmd_cpr_ww ++ [simplify "post-late-ww"] + ), + + -- Final run of the demand_analyser, ensures that one-shot thunks are + -- really really one-shot thunks. Only needed if the demand analyser + -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal + -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution + -- can become /exponentially/ more expensive. See #11731, #12996. + runWhen (strictness || late_dmd_anal) CoreDoDemand, + + maybe_rule_check FinalPhase + ] + + -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity. + flatten_todos [] = [] + flatten_todos (CoreDoNothing : rest) = flatten_todos rest + flatten_todos (CoreDoPasses passes : rest) = + flatten_todos passes ++ flatten_todos rest + flatten_todos (todo : rest) = todo : flatten_todos rest + +{- Note [Inline in InitialPhase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is +confusing for users because when they say INLINE they expect the function to inline +right away. + +So now we do inlining immediately, even in the InitialPhase, assuming that the +Id's Activation allows it. + +This is a surprisingly big deal. Compiler performance improved a lot +when I made this change: + + perf/compiler/T5837.run T5837 [stat too good] (normal) + perf/compiler/parsing001.run parsing001 [stat too good] (normal) + perf/compiler/T12234.run T12234 [stat too good] (optasm) + perf/compiler/T9020.run T9020 [stat too good] (optasm) + perf/compiler/T3064.run T3064 [stat too good] (normal) + perf/compiler/T9961.run T9961 [stat too good] (normal) + perf/compiler/T13056.run T13056 [stat too good] (optasm) + perf/compiler/T9872d.run T9872d [stat too good] (normal) + perf/compiler/T783.run T783 [stat too good] (normal) + perf/compiler/T12227.run T12227 [stat too good] (normal) + perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal) + perf/compiler/T1969.run T1969 [stat too good] (normal) + perf/compiler/T9872a.run T9872a [stat too good] (normal) + perf/compiler/T9872c.run T9872c [stat too good] (normal) + perf/compiler/T9872b.run T9872b [stat too good] (normal) + perf/compiler/T9872d.run T9872d [stat too good] (normal) + +Note [RULEs enabled in InitialPhase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RULES are enabled when doing "gentle" simplification in InitialPhase, +or with -O0. Two reasons: + + * We really want the class-op cancellation to happen: + op (df d1 d2) --> $cop3 d1 d2 + because this breaks the mutual recursion between 'op' and 'df' + + * I wanted the RULE + lift String ===> ... + to work in Template Haskell when simplifying + splices, so we get simpler code for literal strings + +But watch out: list fusion can prevent floating. So use phase control +to switch off those rules until after floating. + +************************************************************************ +* * + The CoreToDo interpreter +* * +************************************************************************ +-} + +runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts +runCorePasses passes guts + = foldM do_pass guts passes + where + do_pass guts CoreDoNothing = return guts + do_pass guts (CoreDoPasses ps) = runCorePasses ps guts + do_pass guts pass = do + withTimingD (ppr pass <+> brackets (ppr mod)) + (const ()) $ do + { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts + ; endPass pass (mg_binds guts') (mg_rules guts') + ; return guts' } + + mod = mg_module guts + +doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts +doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} + simplifyPgm pass + +doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} + doPass cseProgram + +doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} + doPassD liberateCase + +doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} + floatInwards + +doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} + doPassDUM (floatOutwards f) + +doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} + doPassU doStaticArgs + +doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} + doPassD callArityAnalProgram + +doCorePass CoreDoExitify = {-# SCC "Exitify" #-} + doPass exitifyProgram + +doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-} + doPassDFM dmdAnalProgram + +doCorePass CoreDoCpr = {-# SCC "CprAnal" #-} + doPassDFM cprAnalProgram + +doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} + doPassDFU wwTopBinds + +doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} + specProgram + +doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} + specConstrProgram + +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat +doCorePass CoreDoNothing = return +doCorePass (CoreDoPasses passes) = runCorePasses passes + +doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass + +doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass) +doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) + +{- +************************************************************************ +* * +\subsection{Core pass combinators} +* * +************************************************************************ +-} + +printCore :: DynFlags -> CoreProgram -> IO () +printCore dflags binds + = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) + +ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheckPass current_phase pat guts = + withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) + (const ()) $ do + { rb <- getRuleBase + ; dflags <- getDynFlags + ; vis_orphs <- getVisibleOrphanMods + ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn + ++ (mg_rules guts) + ; let ropts = initRuleOpts dflags + ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan + $ withPprStyle defaultDumpStyle + (ruleCheckProgram ropts current_phase pat + rule_fn (mg_binds guts)) + ; return guts } + +doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDUM do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + us <- getUniqueSupplyM + liftIO $ do_pass dflags us binds + +doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) + +doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) + +doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) + +doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassU do_pass = doPassDU (const do_pass) + +doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDFM do_pass guts = do + dflags <- getDynFlags + p_fam_env <- getPackageFamInstEnv + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + doPassM (liftIO . do_pass dflags fam_envs) guts + +doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDFU do_pass guts = do + dflags <- getDynFlags + us <- getUniqueSupplyM + p_fam_env <- getPackageFamInstEnv + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + doPass (do_pass dflags fam_envs us) guts + +-- Most passes return no stats and don't change rules: these combinators +-- let us lift them to the full blown ModGuts+CoreM world +doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts +doPassM bind_f guts = do + binds' <- bind_f (mg_binds guts) + return (guts { mg_binds = binds' }) + +doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } + +-- Observer passes just peek; don't modify the bindings at all +observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts +observe do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + _ <- liftIO $ do_pass dflags binds + return binds + +{- +************************************************************************ +* * + Gentle simplification +* * +************************************************************************ +-} + +simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +simplifyExpr hsc_env expr + = withTiming dflags (text "Simplify [expr]") (const ()) $ + do { eps <- hscEPS hsc_env ; + ; let rule_env = mkRuleEnv (eps_rule_base eps) [] + fi_env = ( eps_fam_inst_env eps + , extendFamInstEnvList emptyFamInstEnv $ + snd $ ic_instances $ hsc_IC hsc_env ) + simpl_env = simplEnvForGHCi dflags + + ; us <- mkSplitUniqSupply 's' + ; let sz = exprSize expr + + ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $ + simplExprGently simpl_env expr + + ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics" (pprSimplCount counts) + + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + FormatCore + (pprCoreExpr expr') + + ; return expr' + } + where + dflags = hsc_dflags hsc_env + +simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. +-- Used (a) for user expressions typed in at the interactive prompt +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices +-- +-- The name 'Gently' suggests that the SimplMode is InitialPhase, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice + +-- It's important that simplExprGently does eta reduction; see +-- Note [Simplifying the left-hand side of a RULE] above. The +-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) +-- but only if -O is on. + +simplExprGently env expr = do + expr1 <- simplExpr env (occurAnalyseExpr expr) + simplExpr env (occurAnalyseExpr expr1) + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts +simplifyPgm pass guts + = do { hsc_env <- getHscEnv + ; us <- getUniqueSupplyM + ; rb <- getRuleBase + ; liftIOWithCount $ + simplifyPgmIO pass hsc_env us rb guts } + +simplifyPgmIO :: CoreToDo + -> HscEnv + -> UniqSupply + -> RuleBase + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) + hsc_env us hpt_rule_base + guts@(ModGuts { mg_module = this_mod + , mg_rdr_env = rdr_env + , mg_deps = deps + , mg_binds = binds, mg_rules = rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 [] binds rules + + ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && + dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count + <+> text "iterations", + blankLine, + pprSimplCount counts_out]) + + ; return (counts_out, guts') + } + where + dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env + simpl_env = mkSimplEnv mode + active_rule = activeRule mode + active_unf = activeUnfolding mode + + do_iteration :: UniqSupply + -> Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration us iteration_no counts_so_far binds rules + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations + = WARN( debugIsOn && (max_iterations > 2) + , hang (text "Simplifier bailing out after" <+> int max_iterations + <+> text "iterations" + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) + + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts { mg_binds = binds, mg_rules = rules } ) + + -- Try and force thunks off the binds; significantly reduces + -- space usage, especially with -O. JRS, 000620. + | let sz = coreBindsSize binds + , () <- sz `seq` () -- Force it + = do { + -- Occurrence analysis + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_unf active_rule rules + binds + } ; + Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore + (pprCoreBindings tagged_binds); + + -- Get any new rules, and extend the rule base + -- See Note [Overall plumbing for rules] in GHC.Core.Rules + -- We need to do this regularly, because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + eps <- hscEPS hsc_env ; + let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) + ; rule_base2 = extendRuleBaseList rule_base1 rules + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) + ; vis_orphs = this_mod : dep_orphs deps } ; + + -- Simplify the program + ((binds1, rules1), counts1) <- + initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $ + do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + + -- Apply the substitution to rules defined in this module + -- for imported Ids. Eg RULE map my_f = blah + -- If we have a substitution my_f :-> other_f, we'd better + -- apply it to the rule to, or it'll never match + ; rules1 <- simplRules env1 Nothing rules Nothing + + ; return (getTopFloatBinds floats, rules1) } ; + + -- Stop if nothing happened; don't dump output + -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; + lintPassResult hsc_env pass binds2 ; + + -- Loop + do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "do_iteration" +#endif + where + (us1, us2) = splitUniqSupply us + + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount dflags) + +simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" + +------------------- +dump_end_iteration :: DynFlags -> PrintUnqualified -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration dflags print_unqual iteration_no counts binds rules + = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules + where + mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = text "Simplifier iteration=" <> int iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr + , pprSimplCount counts + , text "---- End of simplifier counts for" <+> hdr ] + +{- +************************************************************************ +* * + Shorting out indirections +* * +************************************************************************ + +If we have this: + + x_local = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + x_local = x_exported + ...bindings... + +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. + +Note [Messing up the exported Id's RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: + + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x + +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place + +But in principle the user *might* want rules that only apply to the Id +he says. And inline pragmas are similar + {-# NOINLINE f #-} + f = local + local = +Then we do not want to get rid of the NOINLINE. + +Hence hasShortableIdinfo. + + +Note [Rules and indirection-zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might eliminate a binding that's mentioned in the +unfolding for something. + +Note [Indirection zapping and ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unfortunately this is another place where we need a special case for +ticks. The following happens quite regularly: + + x_local = + x_exported = tick x_local + +Which we want to become: + + x_exported = tick + +As it makes no sense to keep the tick and the expression on separate +bindings. Note however that this might increase the ticks scoping +over the execution of x_local, so we can only do this for floatable +ticks. More often than not, other references will be unfoldings of +x_exported, and therefore carry the tick anyway. +-} + +type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks + +shortOutIndirections :: CoreProgram -> CoreProgram +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + where + ind_env = makeIndEnv binds + -- These exported Ids are the subjects of the indirection-elimination + exp_ids = map fst $ nonDetEltsUFM ind_env + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- by immediately converting to a set or check if all the elements + -- satisfy a predicate. + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set + = [] -- Kill the exported-id binding + + | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr + , (exp_id', lcl_id') <- transferIdInfo exp_id bndr + = -- Turn a local-id binding into two bindings + -- exp_id = rhs; lcl_id = exp_id + [ (exp_id', mkTicks ticks rhs), + (lcl_id', Var exp_id') ] + + | otherwise + = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldl' add_bind emptyVarEnv binds + where + add_bind :: IndEnv -> CoreBind -> IndEnv + add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) + add_bind env (Rec pairs) = foldl' add_pair env pairs + + add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv + add_pair env (exported_id, exported) + | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported + , shortMeOut env exported_id local_id + = extendVarEnv env local_id (exported_id, ticks) + add_pair env _ = env + +----------------- +shortMeOut :: IndEnv -> Id -> Id -> Bool +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out because of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's IdInfo] + else WARN( True, text "Not shorting out:" <+> ppr exported_id ) + False + else + False + +----------------- +hasShortableIdInfo :: Id -> Bool +-- True if there is no user-attached IdInfo on exported_id, +-- so we can safely discard it +-- See Note [Messing up the exported Id's IdInfo] +hasShortableIdInfo id + = isEmptyRuleInfo (ruleInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + && not (isStableUnfolding (unfoldingInfo info)) + where + info = idInfo id + +----------------- +{- Note [Transferring IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + lcl_id = e; exp_id = lcl_id + +and lcl_id has useful IdInfo, we don't want to discard it by going + gbl_id = e; lcl_id = gbl_id + +Instead, transfer IdInfo from lcl_id to exp_id, specifically +* (Stable) unfolding +* Strictness +* Rules +* Inline pragma + +Overwriting, rather than merging, seems to work ok. + +We also zap the InlinePragma on the lcl_id. It might originally +have had a NOINLINE, which we have now transferred; and we really +want the lcl_id to inline now that its RHS is trivial! +-} + +transferIdInfo :: Id -> Id -> (Id, Id) +-- See Note [Transferring IdInfo] +transferIdInfo exported_id local_id + = ( modifyIdInfo transfer exported_id + , local_id `setInlinePragma` defaultInlinePragma ) + where + local_info = idInfo local_id + transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + `setCprInfo` cprInfo local_info + `setUnfoldingInfo` unfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + new_info = setRuleInfoHead (idName exported_id) + (ruleInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another diff --git a/GHC/Core/Opt/SetLevels.hs b/GHC/Core/Opt/SetLevels.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/SetLevels.hs @@ -0,0 +1,1819 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{GHC.Core.Opt.SetLevels} + + *************************** + Overview + *************************** + +1. We attach binding levels to Core bindings, in preparation for floating + outwards (@FloatOut@). + +2. We also let-ify many expressions (notably case scrutinees), so they + will have a fighting chance of being floated sensible. + +3. Note [Need for cloning during float-out] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We clone the binders of any floatable let-binding, so that when it is + floated out it will be unique. Example + (let x=2 in x) + (let x=3 in x) + we must clone before floating so we get + let x1=2 in + let x2=3 in + x1+x2 + + NOTE: this can't be done using the uniqAway idea, because the variable + must be unique in the whole program, not just its current scope, + because two variables in different scopes may float out to the + same top level place + + NOTE: Very tiresomely, we must apply this substitution to + the rules stored inside a variable too. + + We do *not* clone top-level bindings, because some of them must not change, + but we *do* clone bindings that are heading for the top level + +4. Note [Binder-swap during float-out] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + In the expression + case x of wild { p -> ...wild... } + we substitute x for wild in the RHS of the case alternatives: + case x of wild { p -> ...x... } + This means that a sub-expression involving x is not "trapped" inside the RHS. + And it's not inconvenient because we already have a substitution. + + Note that this is EXACTLY BACKWARDS from the what the simplifier does. + The simplifier tries to get rid of occurrences of x, in favour of wild, + in the hope that there will only be one remaining occurrence of x, namely + the scrutinee of the case, and we can inline it. + + This can only work if @wild@ is an unrestricted binder. Indeed, even with the + extended typing rule (in the linter) for case expressions, if + case x of wild # 1 { p -> e} + is well-typed, then + case x of wild # 1 { p -> e[wild\x] } + is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@ + at all). In which case, it is, of course, pointless to do the substitution + anyway. So for a linear binder (and really anything which isn't unrestricted), + doing this substitution would either produce ill-typed terms or be the + identity. +-} + +{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module GHC.Core.Opt.SetLevels ( + setLevels, + + Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl, + LevelledBind, LevelledExpr, LevelledBndr, + FloatSpec(..), floatSpecLevel, + + incMinorLvl, ltMajLvl, ltLvl, isTopLvl + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) +import GHC.Core.Utils ( exprType, exprIsHNF + , exprOkForSpeculation + , exprIsTopLevelBindable + , isExprLevPoly + , collectMakeStaticArgs + , mkLamTypes + ) +import GHC.Core.Opt.Arity ( exprBotStrictness_maybe ) +import GHC.Core.FVs -- all of it +import GHC.Core.Subst +import GHC.Core.Make ( sortQuantVars ) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) +import GHC.Types.Unique.DSet ( getUniqDSet ) +import GHC.Types.Var.Env +import GHC.Types.Literal ( litIsTrivial ) +import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, prependArgsStrictSig ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Name ( getOccName, mkSystemVarName ) +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Unique ( hasKey ) +import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType + , mightBeUnliftedType, closeOverKindsDSet ) +import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) +import GHC.Core.DataCon ( dataConOrigResTy ) +import GHC.Builtin.Types +import GHC.Builtin.Names ( runRWKey ) +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.DFM +import GHC.Utils.FV +import Data.Maybe +import GHC.Utils.Monad ( mapAccumLM ) + +{- +************************************************************************ +* * +\subsection{Level numbers} +* * +************************************************************************ +-} + +type LevelledExpr = TaggedExpr FloatSpec +type LevelledBind = TaggedBind FloatSpec +type LevelledBndr = TaggedBndr FloatSpec + +data Level = Level Int -- Level number of enclosing lambdas + Int -- Number of big-lambda and/or case expressions and/or + -- context boundaries between + -- here and the nearest enclosing lambda + LevelType -- Binder or join ceiling? +data LevelType = BndrLvl | JoinCeilLvl deriving (Eq) + +data FloatSpec + = FloatMe Level -- Float to just inside the binding + -- tagged with this level + | StayPut Level -- Stay where it is; binding is + -- tagged with this level + +floatSpecLevel :: FloatSpec -> Level +floatSpecLevel (FloatMe l) = l +floatSpecLevel (StayPut l) = l + +{- +The {\em level number} on a (type-)lambda-bound variable is the +nesting depth of the (type-)lambda which binds it. The outermost lambda +has level 1, so (Level 0 0) means that the variable is bound outside any lambda. + +On an expression, it's the maximum level number of its free +(type-)variables. On a let(rec)-bound variable, it's the level of its +RHS. On a case-bound variable, it's the number of enclosing lambdas. + +Top-level variables: level~0. Those bound on the RHS of a top-level +definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown +as ``subscripts'')... +\begin{verbatim} +a_0 = let b_? = ... in + x_1 = ... b ... in ... +\end{verbatim} + +The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@). +That's meant to be the level number of the enclosing binder in the +final (floated) program. If the level number of a sub-expression is +less than that of the context, then it might be worth let-binding the +sub-expression so that it will indeed float. + +If you can float to level @Level 0 0@ worth doing so because then your +allocation becomes static instead of dynamic. We always start with +context @Level 0 0@. + + +Note [FloatOut inside INLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose: +to say "don't float anything out of here". That's exactly what we +want for the body of an INLINE, where we don't want to float anything +out at all. See notes with lvlMFE below. + +But, check this out: + +-- At one time I tried the effect of not floating anything out of an InlineMe, +-- but it sometimes works badly. For example, consider PrelArr.done. It +-- has the form __inline (\d. e) +-- where e doesn't mention d. If we float this to +-- __inline (let x = e in \d. x) +-- things are bad. The inliner doesn't even inline it because it doesn't look +-- like a head-normal form. So it seems a lesser evil to let things float. +-- In GHC.Core.Opt.SetLevels we do set the context to (Level 0 0) when we get to an InlineMe +-- which discourages floating out. + +So the conclusion is: don't do any floating at all inside an InlineMe. +(In the above example, don't float the {x=e} out of the \d.) + +One particular case is that of workers: we don't want to float the +call to the worker outside the wrapper, otherwise the worker might get +inlined into the floated expression, and an importing module won't see +the worker at all. + +Note [Join ceiling] +~~~~~~~~~~~~~~~~~~~ +Join points can't float very far; too far, and they can't remain join points +So, suppose we have: + + f x = (joinrec j y = ... x ... in jump j x) + 1 + +One may be tempted to float j out to the top of f's RHS, but then the jump +would not be a tail call. Thus we keep track of a level called the *join +ceiling* past which join points are not allowed to float. + +The troublesome thing is that, unlike most levels to which something might +float, there is not necessarily an identifier to which the join ceiling is +attached. Fortunately, if something is to be floated to a join ceiling, it must +be dropped at the *nearest* join ceiling. Thus each level is marked as to +whether it is a join ceiling, so that FloatOut can tell which binders are being +floated to the nearest join ceiling and which to a particular binder (or set of +binders). +-} + +instance Outputable FloatSpec where + ppr (FloatMe l) = char 'F' <> ppr l + ppr (StayPut l) = ppr l + +tOP_LEVEL :: Level +tOP_LEVEL = Level 0 0 BndrLvl + +incMajorLvl :: Level -> Level +incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl + +incMinorLvl :: Level -> Level +incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl + +asJoinCeilLvl :: Level -> Level +asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl + +maxLvl :: Level -> Level -> Level +maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _) + | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 + | otherwise = l2 + +ltLvl :: Level -> Level -> Bool +ltLvl (Level maj1 min1 _) (Level maj2 min2 _) + = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) + +ltMajLvl :: Level -> Level -> Bool + -- Tells if one level belongs to a difft *lambda* level to another +ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2 + +isTopLvl :: Level -> Bool +isTopLvl (Level 0 0 _) = True +isTopLvl _ = False + +isJoinCeilLvl :: Level -> Bool +isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl + +instance Outputable Level where + ppr (Level maj min typ) + = hcat [ char '<', int maj, char ',', int min, char '>' + , ppWhen (typ == JoinCeilLvl) (char 'C') ] + +instance Eq Level where + (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2 + +{- +************************************************************************ +* * +\subsection{Main level-setting code} +* * +************************************************************************ +-} + +setLevels :: FloatOutSwitches + -> CoreProgram + -> UniqSupply + -> [LevelledBind] + +setLevels float_lams binds us + = initLvl us (do_them init_env binds) + where + init_env = initialEnv float_lams + + do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] + do_them _ [] = return [] + do_them env (b:bs) + = do { (lvld_bind, env') <- lvlTopBind env b + ; lvld_binds <- do_them env' bs + ; return (lvld_bind : lvld_binds) } + +lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) +lvlTopBind env (NonRec bndr rhs) + = do { rhs' <- lvl_top env NonRecursive bndr rhs + ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr] + ; return (NonRec bndr' rhs', env') } + +lvlTopBind env (Rec pairs) + = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL + (map fst pairs) + ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs + ; return (Rec (bndrs' `zip` rhss'), env') } + +lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr +lvl_top env is_rec bndr rhs + = lvlRhs env is_rec + (isDeadEndId bndr) + Nothing -- Not a join point + (freeVars rhs) + +{- +************************************************************************ +* * +\subsection{Setting expression levels} +* * +************************************************************************ + +Note [Floating over-saturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (f x y), and (f x) is a redex (ie f's arity is 1), +we call (f x) an "over-saturated application" + +Should we float out an over-sat app, if can escape a value lambda? +It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2). +But we don't want to do it for class selectors, because the work saved +is minimal, and the extra local thunks allocated cost money. + +Arguably we could float even class-op applications if they were going to +top level -- but then they must be applied to a constant dictionary and +will almost certainly be optimised away anyway. +-} + +lvlExpr :: LevelEnv -- Context + -> CoreExprWithFVs -- Input expression + -> LvlM LevelledExpr -- Result expression + +{- +The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing +binder. Here's an example + + v = \x -> ...\y -> let r = case (..x..) of + ..x.. + in .. + +When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's +the level of @r@, even though it's inside a level-2 @\y@. It's +important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we +don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE +--- because it isn't a *maximal* free expression. + +If there were another lambda in @r@'s rhs, it would get level-2 as well. +-} + +lvlExpr env (_, AnnType ty) = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) +lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) +lvlExpr env (_, AnnVar v) = return (lookupVar env v) +lvlExpr _ (_, AnnLit lit) = return (Lit lit) + +lvlExpr env (_, AnnCast expr (_, co)) = do + expr' <- lvlNonTailExpr env expr + return (Cast expr' (substCo (le_subst env) co)) + +lvlExpr env (_, AnnTick tickish expr) = do + expr' <- lvlNonTailExpr env expr + let tickish' = substTickish (le_subst env) tickish + return (Tick tickish' expr') + +lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr) + +-- We don't split adjacent lambdas. That is, given +-- \x y -> (x+1,y) +-- we don't float to give +-- \x -> let v = x+1 in \y -> (v,y) +-- Why not? Because partial applications are fairly rare, and splitting +-- lambdas makes them more expensive. + +lvlExpr env expr@(_, AnnLam {}) + = do { new_body <- lvlNonTailMFE new_env True body + ; return (mkLams new_bndrs new_body) } + where + (bndrs, body) = collectAnnBndrs expr + (env1, bndrs1) = substBndrsSL NonRecursive env bndrs + (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1 + -- At one time we called a special version of collectBinders, + -- which ignored coercions, because we don't want to split + -- a lambda like this (\x -> coerce t (\s -> ...)) + -- This used to happen quite a bit in state-transformer programs, + -- but not nearly so much now non-recursive newtypes are transparent. + -- [See GHC.Core.Opt.SetLevels rev 1.50 for a version with this approach.] + +lvlExpr env (_, AnnLet bind body) + = do { (bind', new_env) <- lvlBind env bind + ; body' <- lvlExpr new_env body + -- No point in going via lvlMFE here. If the binding is alive + -- (mentioned in body), and the whole let-expression doesn't + -- float, then neither will the body + ; return (Let bind' body') } + +lvlExpr env (_, AnnCase scrut case_bndr ty alts) + = do { scrut' <- lvlNonTailMFE env True scrut + ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts } + +lvlNonTailExpr :: LevelEnv -- Context + -> CoreExprWithFVs -- Input expression + -> LvlM LevelledExpr -- Result expression +lvlNonTailExpr env expr + = lvlExpr (placeJoinCeiling env) expr + +------------------------------------------- +lvlApp :: LevelEnv + -> CoreExprWithFVs + -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application + -> LvlM LevelledExpr -- Result expression +lvlApp env orig_expr ((_,AnnVar fn), args) + -- Try to ensure that runRW#'s continuation isn't floated out. + -- See Note [Simplification of runRW#]. + | fn `hasKey` runRWKey + = do { args' <- mapM (lvlExpr env) args + ; return (foldl' App (lookupVar env fn) args') } + + | floatOverSat env -- See Note [Floating over-saturated applications] + , arity > 0 + , arity < n_val_args + , Nothing <- isClassOpId_maybe fn + = do { rargs' <- mapM (lvlNonTailMFE env False) rargs + ; lapp' <- lvlNonTailMFE env False lapp + ; return (foldl' App lapp' rargs') } + + | otherwise + = do { (_, args') <- mapAccumLM lvl_arg stricts args + -- Take account of argument strictness; see + -- Note [Floating to the top] + ; return (foldl' App (lookupVar env fn) args') } + where + n_val_args = count (isValArg . deAnnotate) args + arity = idArity fn + + stricts :: [Demand] -- True for strict /value/ arguments + stricts = case splitStrictSig (idStrictness fn) of + (arg_ds, _) | arg_ds `lengthExceeds` n_val_args + -> [] + | otherwise + -> arg_ds + + -- Separate out the PAP that we are floating from the extra + -- arguments, by traversing the spine until we have collected + -- (n_val_args - arity) value arguments. + (lapp, rargs) = left (n_val_args - arity) orig_expr [] + + left 0 e rargs = (e, rargs) + left n (_, AnnApp f a) rargs + | isValArg (deAnnotate a) = left (n-1) f (a:rargs) + | otherwise = left n f (a:rargs) + left _ _ _ = panic "GHC.Core.Opt.SetLevels.lvlExpr.left" + + is_val_arg :: CoreExprWithFVs -> Bool + is_val_arg (_, AnnType {}) = False + is_val_arg _ = True + + lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr) + lvl_arg strs arg | (str1 : strs') <- strs + , is_val_arg arg + = do { arg' <- lvlMFE env (isStrictDmd str1) arg + ; return (strs', arg') } + | otherwise + = do { arg' <- lvlMFE env False arg + ; return (strs, arg') } + +lvlApp env _ (fun, args) + = -- No PAPs that we can float: just carry on with the + -- arguments and the function. + do { args' <- mapM (lvlNonTailMFE env False) args + ; fun' <- lvlNonTailExpr env fun + ; return (foldl' App fun' args') } + +------------------------------------------- +lvlCase :: LevelEnv -- Level of in-scope names/tyvars + -> DVarSet -- Free vars of input scrutinee + -> LevelledExpr -- Processed scrutinee + -> Id -> Type -- Case binder and result type + -> [CoreAltWithFVs] -- Input alternatives + -> LvlM LevelledExpr -- Result expression +lvlCase env scrut_fvs scrut' case_bndr ty alts + -- See Note [Floating single-alternative cases] + | [(con@(DataAlt {}), bs, body)] <- alts + , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] + , not (isTopLvl dest_lvl) -- Can't have top-level cases + , not (floatTopLvlOnly env) -- Can float anywhere + , Many <- idMult case_bndr -- See Note [Floating linear case] + = -- Always float the case if possible + -- Unlike lets we don't insist that it escapes a value lambda + do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) + ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' + ; body' <- lvlMFE rhs_env True body + ; let alt' = (con, map (stayPut dest_lvl) bs', body') + ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } + + | otherwise -- Stays put + = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr] + alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut' + ; alts' <- mapM (lvl_alt alts_env) alts + ; return (Case scrut' case_bndr' ty' alts') } + where + ty' = substTy (le_subst env) ty + + incd_lvl = incMinorLvl (le_ctxt_lvl env) + dest_lvl = maxFvLevel (const True) env scrut_fvs + -- Don't abstract over type variables, hence const True + + lvl_alt alts_env (con, bs, rhs) + = do { rhs' <- lvlMFE new_env True rhs + ; return (con, bs', rhs') } + where + (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs + +{- Note [Floating single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + data T a = MkT !a + f :: T Int -> blah + f x vs = case x of { MkT y -> + let f vs = ...(case y of I# w -> e)...f.. + in f vs + +Here we can float the (case y ...) out, because y is sure +to be evaluated, to give + f x vs = case x of { MkT y -> + case y of I# w -> + let f vs = ...(e)...f.. + in f vs + +That saves unboxing it every time round the loop. It's important in +some DPH stuff where we really want to avoid that repeated unboxing in +the inner loop. + +Things to note: + + * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation. + + - exrpIsHNF catches the key case of an evaluated variable + + - exprOkForSpeculation is /false/ of an evaluated variable; + See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils + So we'd actually miss the key case! + + - Nothing is gained from the extra generality of exprOkForSpeculation + since we only consider floating a case whose single alternative + is a DataAlt K a b -> rhs + + * We can't float a case to top level + + * It's worth doing this float even if we don't float + the case outside a value lambda. Example + case x of { + MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) + If we floated the cases out we could eliminate one of them. + + * We only do this with a single-alternative case + + +Note [Floating linear case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Linear case can't be floated past case branches: + case u of { p1 -> case[1] v of { C x -> ...x...}; p2 -> ... } +Is well typed, but + case[1] v of { C x -> case u of { p1 -> ...x...; p2 -> ... }} +Will not be, because of how `x` is used in one alternative but not the other. + +It is not easy to float this linear cases precisely, so, instead, we elect, for +the moment, to simply not float linear case. + + +Note [Setting levels when floating single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Handling level-setting when floating a single-alternative case binding +is a bit subtle, as evidenced by #16978. In particular, we must keep +in mind that we are merely moving the case and its binders, not the +body. For example, suppose 'a' is known to be evaluated and we have + + \z -> case a of + (x,_) -> + +After floating we may have: + + case a of + (x,_) -> \z -> + {- some expression involving x and z -} + +When analysing we want to use the /ambient/ level, +and /not/ the destination level of the 'case a of (x,-) ->' binding. + +#16978 was caused by us setting the context level to the destination +level of `x` when analysing . This led us to conclude that we +needed to quantify over some of its free variables (e.g. z), resulting +in shadowing and very confusing Core Lint failures. + + +Note [Check the output scrutinee for exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y { + A -> ....(case y of alts).... + } + +Because of the binder-swap, the inner case will get substituted to +(case x of ..). So when testing whether the scrutinee is in HNF we +must be careful to test the *result* scrutinee ('x' in this case), not +the *input* one 'y'. The latter *is* in HNF here (because y is +evaluated), but the former is not -- and indeed we can't float the +inner case out, at least not unless x is also evaluated at its binding +site. See #5453. + +That's why we apply exprIsHNF to scrut' and not to scrut. + +See Note [Floating single-alternative cases] for why +we use exprIsHNF in the first place. +-} + +lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars + -> Bool -- True <=> strict context [body of case + -- or let] + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +lvlNonTailMFE env strict_ctxt ann_expr + = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr + +lvlMFE :: LevelEnv -- Level of in-scope names/tyvars + -> Bool -- True <=> strict context [body of case or let] + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +-- lvlMFE is just like lvlExpr, except that it might let-bind +-- the expression, so that it can itself be floated. + +lvlMFE env _ (_, AnnType ty) + = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) + +-- No point in floating out an expression wrapped in a coercion or note +-- If we do we'll transform lvl = e |> co +-- to lvl' = e; lvl = lvl' |> co +-- and then inline lvl. Better just to float out the payload. +lvlMFE env strict_ctxt (_, AnnTick t e) + = do { e' <- lvlMFE env strict_ctxt e + ; let t' = substTickish (le_subst env) t + ; return (Tick t' e') } + +lvlMFE env strict_ctxt (_, AnnCast e (_, co)) + = do { e' <- lvlMFE env strict_ctxt e + ; return (Cast e' (substCo (le_subst env) co)) } + +lvlMFE env strict_ctxt e@(_, AnnCase {}) + | strict_ctxt -- Don't share cases in a strict context + = lvlExpr env e -- See Note [Case MFEs] + +lvlMFE env strict_ctxt ann_expr + | floatTopLvlOnly env && not (isTopLvl dest_lvl) + -- Only floating to the top level is allowed. + || hasFreeJoin env fvs -- If there is a free join, don't float + -- See Note [Free join points] + || isExprLevPoly expr + -- We can't let-bind levity polymorphic expressions + -- See Note [Levity polymorphism invariants] in GHC.Core + || notWorthFloating expr abs_vars + || not float_me + = -- Don't float it out + lvlExpr env ann_expr + + | float_is_new_lam || exprIsTopLevelBindable expr expr_ty + -- No wrapping needed if the type is lifted, or is a literal string + -- or if we are wrapping it in one or more value lambdas + = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive + (isJust mb_bot_str) + join_arity_maybe + ann_expr + -- Treat the expr just like a right-hand side + ; var <- newLvlVar expr1 join_arity_maybe is_mk_static + ; let var2 = annotateBotStr var float_n_lams mb_bot_str + ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1) + (mkVarApps (Var var2) abs_vars)) } + + -- OK, so the float has an unlifted type (not top-level bindable) + -- and no new value lambdas (float_is_new_lam is False) + -- Try for the boxing strategy + -- See Note [Floating MFEs of unlifted type] + | escapes_value_lam + , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions + -- See Note [Test cheapness with exprOkForSpeculation] + , Just (tc, _) <- splitTyConApp_maybe expr_ty + , Just dc <- boxingDataCon_maybe tc + , let dc_res_ty = dataConOrigResTy dc -- No free type variables + [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty] + = do { expr1 <- lvlExpr rhs_env ann_expr + ; let l1r = incMinorLvlFrom rhs_env + float_rhs = mkLams abs_vars_w_lvls $ + Case expr1 (stayPut l1r ubx_bndr) dc_res_ty + [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] + + ; var <- newLvlVar float_rhs Nothing is_mk_static + ; let l1u = incMinorLvlFrom env + use_expr = Case (mkVarApps (Var var) abs_vars) + (stayPut l1u bx_bndr) expr_ty + [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] + ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) + use_expr) } + + | otherwise -- e.g. do not float unboxed tuples + = lvlExpr env ann_expr + + where + expr = deAnnotate ann_expr + expr_ty = exprType expr + fvs = freeVarsOf ann_expr + fvs_ty = tyCoVarsOfType expr_ty + is_bot = isBottomThunk mb_bot_str + is_function = isFunction ann_expr + mb_bot_str = exprBotStrictness_maybe expr + -- See Note [Bottoming floats] + -- esp Bottoming floats (2) + expr_ok_for_spec = exprOkForSpeculation expr + dest_lvl = destLevel env fvs fvs_ty is_function is_bot False + abs_vars = abstractVars dest_lvl env fvs + + -- float_is_new_lam: the floated thing will be a new value lambda + -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is + -- allocation saved. The benefit is to get it to the top level + -- and hence out of the body of this function altogether, making + -- it smaller and more inlinable + float_is_new_lam = float_n_lams > 0 + float_n_lams = count isId abs_vars + + (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + + join_arity_maybe = Nothing + + is_mk_static = isJust (collectMakeStaticArgs expr) + -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable + + -- A decision to float entails let-binding this thing, and we only do + -- that if we'll escape a value lambda, or will go to the top level. + float_me = saves_work || saves_alloc || is_mk_static + + -- We can save work if we can move a redex outside a value lambda + -- But if float_is_new_lam is True, then the redex is wrapped in a + -- a new lambda, so no work is saved + saves_work = escapes_value_lam && not float_is_new_lam + + escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) + -- See Note [Escaping a value lambda] + + -- See Note [Floating to the top] + saves_alloc = isTopLvl dest_lvl + && floatConsts env + && (not strict_ctxt || is_bot || exprIsHNF expr) + +hasFreeJoin :: LevelEnv -> DVarSet -> Bool +-- Has a free join point which is not being floated to top level. +-- (In the latter case it won't be a join point any more.) +-- Not treating top-level ones specially had a massive effect +-- on nofib/minimax/Prog.prog +hasFreeJoin env fvs + = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) + +isBottomThunk :: Maybe (Arity, s) -> Bool +-- See Note [Bottoming floats] (2) +isBottomThunk (Just (0, _)) = True -- Zero arity +isBottomThunk _ = False + +{- Note [Floating to the top] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are keen to float something to the top level, even if it does not +escape a value lambda (and hence save work), for two reasons: + + * Doing so makes the function smaller, by floating out + bottoming expressions, or integer or string literals. That in + turn makes it easier to inline, with less duplication. + + * (Minor) Doing so may turn a dynamic allocation (done by machine + instructions) into a static one. Minor because we are assuming + we are not escaping a value lambda. + +But do not so if: + - the context is a strict, and + - the expression is not a HNF, and + - the expression is not bottoming + +Exammples: + +* Bottoming + f x = case x of + 0 -> error + _ -> x+1 + Here we want to float (error ) to top level, abstracting + over 'x', so as to make f's RHS smaller. + +* HNF + f = case y of + True -> p:q + False -> blah + We may as well float the (p:q) so it becomes a static data structure. + +* Case scrutinee + f = case g True of .... + Don't float (g True) to top level; then we have the admin of a + top-level thunk to worry about, with zero gain. + +* Case alternative + h = case y of + True -> g True + False -> False + Don't float (g True) to the top level + +* Arguments + t = f (g True) + If f is lazy, we /do/ float (g True) because then we can allocate + the thunk statically rather than dynamically. But if f is strict + we don't (see the use of idStrictness in lvlApp). It's not clear + if this test is worth the bother: it's only about CAFs! + +It's controlled by a flag (floatConsts), because doing this too +early loses opportunities for RULES which (needless to say) are +important in some nofib programs (gcd is an example). [SPJ note: +I think this is obsolete; the flag seems always on.] + +Note [Floating join point bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we only float a join point if it can /stay/ a join point. But +there is one exception: if it can go to the top level (#13286). +Consider + f x = joinrec j y n = <...j y' n'...> + in jump j x 0 + +Here we may just as well produce + j y n = <....j y' n'...> + f x = j x 0 + +and now there is a chance that 'f' will be inlined at its call sites. +It shouldn't make a lot of difference, but these tests + perf/should_run/MethSharing + simplCore/should_compile/spec-inline +and one nofib program, all improve if you do float to top, because +of the resulting inlining of f. So ok, let's do it. + +Note [Free join points] +~~~~~~~~~~~~~~~~~~~~~~~ +We never float a MFE that has a free join-point variable. You might think +this can never occur. After all, consider + join j x = ... + in ....(jump j x).... +How might we ever want to float that (jump j x)? + * If it would escape a value lambda, thus + join j x = ... in (\y. ...(jump j x)... ) + then 'j' isn't a valid join point in the first place. + +But consider + join j x = .... in + joinrec j2 y = ...(jump j x)...(a+b).... + +Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec. +But it is emphatically /not/ good to float the (jump j x) out: + (a) 'j' will stop being a join point + (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no + work would be saved by floating it out of the \y. + +Even if we floated 'j' to top level, (b) would still hold. + +Bottom line: never float a MFE that has a free JoinId. + +Note [Floating MFEs of unlifted type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + case f x of (r::Int#) -> blah +we'd like to float (f x). But it's not trivial because it has type +Int#, and we don't want to evaluate it too early. But we can instead +float a boxed version + y = case f x of r -> I# r +and replace the original (f x) with + case (case y of I# r -> r) of r -> blah + +Being able to float unboxed expressions is sometimes important; see +#12603. I'm not sure how /often/ it is important, but it's +not hard to achieve. + +We only do it for a fixed collection of types for which we have a +convenient boxing constructor (see boxingDataCon_maybe). In +particular we /don't/ do it for unboxed tuples; it's better to float +the components of the tuple individually. + +I did experiment with a form of boxing that works for any type, namely +wrapping in a function. In our example + + let y = case f x of r -> \v. f x + in case y void of r -> blah + +It works fine, but it's 50% slower (based on some crude benchmarking). +I suppose we could do it for types not covered by boxingDataCon_maybe, +but it's more code and I'll wait to see if anyone wants it. + +Note [Test cheapness with exprOkForSpeculation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to float very cheap expressions by boxing and unboxing. +But we use exprOkForSpeculation for the test, not exprIsCheap. +Why? Because it's important /not/ to transform + f (a /# 3) +to + f (case bx of I# a -> a /# 3) +and float bx = I# (a /# 3), because the application of f no +longer obeys the let/app invariant. But (a /# 3) is ok-for-spec +due to a special hack that says division operators can't fail +when the denominator is definitely non-zero. And yet that +same expression says False to exprIsCheap. Simplest way to +guarantee the let/app invariant is to use the same function! + +If an expression is okay for speculation, we could also float it out +*without* boxing and unboxing, since evaluating it early is okay. +However, it turned out to usually be better not to float such expressions, +since they tend to be extremely cheap things like (x +# 1#). Even the +cost of spilling the let-bound variable to the stack across a call may +exceed the cost of recomputing such an expression. (And we can't float +unlifted bindings to top-level.) + +We could try to do something smarter here, and float out expensive yet +okay-for-speculation things, such as division by non-zero constants. +But I suspect it's a narrow target. + +Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f = \x. g (error "urk") +we'd like to float the call to error, to get + lvl = error "urk" + f = \x. g lvl + +But, as ever, we need to be careful: + +(1) We want to float a bottoming + expression even if it has free variables: + f = \x. g (let v = h x in error ("urk" ++ v)) + Then we'd like to abstract over 'x' can float the whole arg of g: + lvl = \x. let v = h x in error ("urk" ++ v) + f = \x. g (lvl x) + To achieve this we pass is_bot to destLevel + +(2) We do not do this for lambdas that return + bottom. Instead we treat the /body/ of such a function specially, + via point (1). For example: + f = \x. ....(\y z. if x then error y else error z).... + ===> + lvl = \x z y. if b then error y else error z + f = \x. ...(\y z. lvl x z y)... + (There is no guarantee that we'll choose the perfect argument order.) + +(3) If we have a /binding/ that returns bottom, we want to float it to top + level, even if it has free vars (point (1)), and even it has lambdas. + Example: + ... let { v = \y. error (show x ++ show y) } in ... + We want to abstract over x and float the whole thing to top: + lvl = \xy. errror (show x ++ show y) + ...let {v = lvl x} in ... + + Then of course we don't want to separately float the body (error ...) + as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot + argument. + +See Maessen's paper 1999 "Bottom extraction: factoring error handling out +of functional programs" (unpublished I think). + +When we do this, we set the strictness and arity of the new bottoming +Id, *immediately*, for three reasons: + + * To prevent the abstracted thing being immediately inlined back in again + via preInlineUnconditionally. The latter has a test for bottoming Ids + to stop inlining them, so we'd better make sure it *is* a bottoming Id! + + * So that it's properly exposed as such in the interface file, even if + this is all happening after strictness analysis. + + * In case we do CSE with the same expression that *is* marked bottom + lvl = error "urk" + x{str=bot) = error "urk" + Here we don't want to replace 'x' with 'lvl', else we may get Lint + errors, e.g. via a case with empty alternatives: (case x of {}) + Lint complains unless the scrutinee of such a case is clearly bottom. + + This was reported in #11290. But since the whole bottoming-float + thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure + that it'll nail all such cases. + +Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tiresomely, though, the simplifier has an invariant that the manifest +arity of the RHS should be the same as the arity; but we can't call +etaExpand during GHC.Core.Opt.SetLevels because it works over a decorated form of +CoreExpr. So we do the eta expansion later, in GHC.Core.Opt.FloatOut. +But we should only eta-expand if the RHS doesn't already have the right +exprArity, otherwise we get unnecessary top-level bindings if the RHS was +trivial after the next run of the Simplifier. + +Note [Case MFEs] +~~~~~~~~~~~~~~~~ +We don't float a case expression as an MFE from a strict context. Why not? +Because in doing so we share a tiny bit of computation (the switch) but +in exchange we build a thunk, which is bad. This case reduces allocation +by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. +Doesn't change any other allocation at all. + +We will make a separate decision for the scrutinee and alternatives. + +However this can have a knock-on effect for fusion: consider + \v -> foldr k z (case x of I# y -> build ..y..) +Perhaps we can float the entire (case x of ...) out of the \v. Then +fusion will not happen, but we will get more sharing. But if we don't +float the case (as advocated here) we won't float the (build ...y..) +either, so fusion will happen. It can be a big effect, esp in some +artificial benchmarks (e.g. integer, queens), but there is no perfect +answer. + +-} + +annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id +-- See Note [Bottoming floats] for why we want to add +-- bottoming information right now +-- +-- n_extra are the number of extra value arguments added during floating +annotateBotStr id n_extra mb_str + = case mb_str of + Nothing -> id + Just (arity, sig) -> id `setIdArity` (arity + n_extra) + `setIdStrictness` (prependArgsStrictSig n_extra sig) + `setIdCprInfo` mkCprSig (arity + n_extra) botCpr + +notWorthFloating :: CoreExpr -> [Var] -> Bool +-- Returns True if the expression would be replaced by +-- something bigger than it is now. For example: +-- abs_vars = tvars only: return True if e is trivial, +-- but False for anything bigger +-- abs_vars = [x] (an Id): return True for trivial, or an application (f x) +-- but False for (f x x) +-- +-- One big goal is that floating should be idempotent. Eg if +-- we replace e with (lvl79 x y) and then run FloatOut again, don't want +-- to replace (lvl79 x y) with (lvl83 x y)! + +notWorthFloating e abs_vars + = go e (count isId abs_vars) + where + go (Var {}) n = n >= 0 + go (Lit lit) n = ASSERT( n==0 ) + litIsTrivial lit -- Note [Floating literals] + go (Tick t e) n = not (tickishIsCode t) && go e n + go (Cast e _) n = go e n + go (App e arg) n + -- See Note [Floating applications to coercions] + | Type {} <- arg = go e n + | n==0 = False + | is_triv arg = go e (n-1) + | otherwise = False + go _ _ = False + + is_triv (Lit {}) = True -- Treat all literals as trivial + is_triv (Var {}) = True -- (ie not worth floating) + is_triv (Cast e _) = is_triv e + is_triv (App e (Type {})) = is_triv e -- See Note [Floating applications to coercions] + is_triv (Tick t e) = not (tickishIsCode t) && is_triv e + is_triv _ = False + +{- +Note [Floating literals] +~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to float Integer literals, so that they get shared, +rather than being allocated every time round the loop. +Hence the litIsTrivial. + +Ditto literal strings (LitString), which we'd like to float to top +level, which is now possible. + +Note [Floating applications to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don’t float out variables applied only to type arguments, since the +extra binding would be pointless: type arguments are completely erased. +But *coercion* arguments aren’t (see Note [Coercion tokens] in +"GHC.CoreToStg" and Note [Count coercion arguments in boring contexts] in +"GHC.Core.Unfold"), so we still want to float out variables applied only to +coercion arguments. + +Note [Escaping a value lambda] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float even cheap expressions out of value lambdas, +because that saves allocation. Consider + f = \x. .. (\y.e) ... +Then we'd like to avoid allocating the (\y.e) every time we call f, +(assuming e does not mention x). An example where this really makes a +difference is simplrun009. + +Another reason it's good is because it makes SpecContr fire on functions. +Consider + f = \x. ....(f (\y.e)).... +After floating we get + lvl = \y.e + f = \x. ....(f lvl)... +and that is much easier for SpecConstr to generate a robust +specialisation for. + +However, if we are wrapping the thing in extra value lambdas (in +abs_vars), then nothing is saved. E.g. + f = \xyz. ...(e1[y],e2).... +If we float + lvl = \y. (e1[y],e2) + f = \xyz. ...(lvl y)... +we have saved nothing: one pair will still be allocated for each +call of 'f'. Hence the (not float_is_lam) in float_me. + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ + +The binding stuff works for top level too. +-} + +lvlBind :: LevelEnv + -> CoreBindWithFVs + -> LvlM (LevelledBind, LevelEnv) + +lvlBind env (AnnNonRec bndr rhs) + | isTyVar bndr -- Don't do anything for TyVar binders + -- (simplifier gets rid of them pronto) + || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) + -- so we will ignore this case for now + || not (profitableFloat env dest_lvl) + || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty)) + -- We can't float an unlifted binding to top level (except + -- literal strings), so we don't float it at all. It's a + -- bit brutal, but unlifted bindings aren't expensive either + + = -- No float + do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs + ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] + ; return (NonRec bndr' rhs', env') } + + -- Otherwise we are going to float + | null abs_vars + = do { -- No type abstraction; clone existing binder + rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive + is_bot mb_join_arity rhs + ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] + ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + + | otherwise + = do { -- Yes, type abstraction; create a new binder, extend substitution, etc + rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive + is_bot mb_join_arity rhs + ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] + ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str + ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } + + where + bndr_ty = idType bndr + ty_fvs = tyCoVarsOfType bndr_ty + rhs_fvs = freeVarsOf rhs + bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr + abs_vars = abstractVars dest_lvl env bind_fvs + dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join + + deann_rhs = deAnnotate rhs + mb_bot_str = exprBotStrictness_maybe deann_rhs + is_bot = isJust mb_bot_str + -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) + + n_extra = count isId abs_vars + mb_join_arity = isJoinId_maybe bndr + is_join = isJust mb_join_arity + +lvlBind env (AnnRec pairs) + | floatTopLvlOnly env && not (isTopLvl dest_lvl) + -- Only floating to the top level is allowed. + || not (profitableFloat env dest_lvl) + || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs) + -- This mightBeUnliftedType stuff is the same test as in the non-rec case + -- You might wonder whether we can have a recursive binding for + -- an unlifted value -- but we can if it's a /join binding/ (#16978) + -- (Ultimately I think we should not use GHC.Core.Opt.SetLevels to + -- float join bindings at all, but that's another story.) + = -- No float + do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs + lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r + ; rhss' <- mapM lvl_rhs pairs + ; return (Rec (bndrs' `zip` rhss'), env') } + + -- Otherwise we are going to float + | null abs_vars + = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs + ; new_rhss <- mapM (do_rhs new_env) pairs + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + +-- ToDo: when enabling the floatLambda stuff, +-- I think we want to stop doing this + | [(bndr,rhs)] <- pairs + , count isId abs_vars > 1 + = do -- Special case for self recursion where there are + -- several variables carried around: build a local loop: + -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars + -- This just makes the closures a bit smaller. If we don't do + -- this, allocation rises significantly on some programs + -- + -- We could elaborate it for the case where there are several + -- mutually recursive functions, but it's quite a bit more complicated + -- + -- This all seems a bit ad hoc -- sigh + let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + rhs_lvl = le_ctxt_lvl rhs_env + + (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] + let + (lam_bndrs, rhs_body) = collectAnnBndrs rhs + (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs + (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 + new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body + (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] + return (Rec [(TB poly_bndr (FloatMe dest_lvl) + , mkLams abs_vars_w_lvls $ + mkLams lam_bndrs2 $ + Let (Rec [( TB new_bndr (StayPut rhs_lvl) + , mkLams lam_bndrs2 new_rhs_body)]) + (mkVarApps (Var new_bndr) lam_bndrs1))] + , poly_env) + + | otherwise -- Non-null abs_vars + = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs + ; new_rhss <- mapM (do_rhs new_env) pairs + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + + where + (bndrs,rhss) = unzip pairs + is_join = isJoinId (head bndrs) + -- bndrs is always non-empty and if one is a join they all are + -- Both are checked by Lint + is_fun = all isFunction rhss + is_bot = False -- It's odd to have an unconditionally divergent + -- function in a Rec, and we don't much care what + -- happens to it. False is simple! + + do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive + is_bot (get_join bndr) + rhs + + get_join bndr | need_zap = Nothing + | otherwise = isJoinId_maybe bndr + need_zap = dest_lvl `ltLvl` joinCeilingLevel env + + -- Finding the free vars of the binding group is annoying + bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) + `unionDVarSet` + (fvDVarSet $ unionsFV [ idFVs bndr + | (bndr, (_,_)) <- pairs])) + `delDVarSetList` + bndrs + + ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs + dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join + abs_vars = abstractVars dest_lvl env bind_fvs + +profitableFloat :: LevelEnv -> Level -> Bool +profitableFloat env dest_lvl + = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda + || isTopLvl dest_lvl -- Going all the way to top level + + +---------------------------------------------------- +-- Three help functions for the type-abstraction case + +lvlRhs :: LevelEnv + -> RecFlag + -> Bool -- Is this a bottoming function + -> Maybe JoinArity + -> CoreExprWithFVs + -> LvlM LevelledExpr +lvlRhs env rec_flag is_bot mb_join_arity expr + = lvlFloatRhs [] (le_ctxt_lvl env) env + rec_flag is_bot mb_join_arity expr + +lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag + -> Bool -- Binding is for a bottoming function + -> Maybe JoinArity + -> CoreExprWithFVs + -> LvlM (Expr LevelledBndr) +-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline +lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs + = do { body' <- if not is_bot -- See Note [Floating from a RHS] + && any isId bndrs + then lvlMFE body_env True body + else lvlExpr body_env body + ; return (mkLams bndrs' body') } + where + (bndrs, body) | Just join_arity <- mb_join_arity + = collectNAnnBndrs join_arity rhs + | otherwise + = collectAnnBndrs rhs + (env1, bndrs1) = substBndrsSL NonRecursive env bndrs + all_bndrs = abs_vars ++ bndrs1 + (body_env, bndrs') | Just _ <- mb_join_arity + = lvlJoinBndrs env1 dest_lvl rec all_bndrs + | otherwise + = case lvlLamBndrs env1 dest_lvl all_bndrs of + (env2, bndrs') -> (placeJoinCeiling env2, bndrs') + -- The important thing here is that we call lvlLamBndrs on + -- all these binders at once (abs_vars and bndrs), so they + -- all get the same major level. Otherwise we create stupid + -- let-bindings inside, joyfully thinking they can float; but + -- in the end they don't because we never float bindings in + -- between lambdas + +{- Note [Floating from a RHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When floating the RHS of a let-binding, we don't always want to apply +lvlMFE to the body of a lambda, as we usually do, because the entire +binding body is already going to the right place (dest_lvl). + +A particular example is the top level. Consider + concat = /\ a -> foldr ..a.. (++) [] +We don't want to float the body of the lambda to get + lvl = /\ a -> foldr ..a.. (++) [] + concat = /\ a -> lvl a +That would be stupid. + +Previously this was avoided in a much nastier way, by testing strict_ctxt +in float_me in lvlMFE. But that wasn't even right because it would fail +to float out the error sub-expression in + f = \x. case x of + True -> error ("blah" ++ show x) + False -> ... + +But we must be careful: + +* If we had + f = \x -> factorial 20 + we /would/ want to float that (factorial 20) out! Functions are treated + differently: see the use of isFunction in the calls to destLevel. If + there are only type lambdas, then destLevel will say "go to top, and + abstract over the free tyvars" and we don't want that here. + +* But if we had + f = \x -> error (...x....) + we would NOT want to float the bottoming expression out to give + lvl = \x -> error (...x...) + f = \x -> lvl x + +Conclusion: use lvlMFE if there are + * any value lambdas in the original function, and + * this is not a bottoming function (the is_bot argument) +Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice +(e.g. #13369). +-} + +{- +************************************************************************ +* * +\subsection{Deciding floatability} +* * +************************************************************************ +-} + +substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) +substAndLvlBndrs is_rec env lvl bndrs + = lvlBndrs subst_env lvl subst_bndrs + where + (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs + +substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) +-- So named only to avoid the name clash with GHC.Core.Subst.substBndrs +substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs + = ( env { le_subst = subst' + , le_env = foldl' add_id id_env (bndrs `zip` bndrs') } + , bndrs') + where + (subst', bndrs') = case is_rec of + NonRecursive -> substBndrs subst bndrs + Recursive -> substRecBndrs subst bndrs + +lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) +-- Compute the levels for the binders of a lambda group +lvlLamBndrs env lvl bndrs + = lvlBndrs env new_lvl bndrs + where + new_lvl | any is_major bndrs = incMajorLvl lvl + | otherwise = incMinorLvl lvl + + is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) + -- The "probably" part says "don't float things out of a + -- probable one-shot lambda" + -- See Note [Computing one-shot info] in GHC.Types.Demand + +lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] + -> (LevelEnv, [LevelledBndr]) +lvlJoinBndrs env lvl rec bndrs + = lvlBndrs env new_lvl bndrs + where + new_lvl | isRec rec = incMajorLvl lvl + | otherwise = incMinorLvl lvl + -- Non-recursive join points are one-shot; recursive ones are not + +lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) +-- The binders returned are exactly the same as the ones passed, +-- apart from applying the substitution, but they are now paired +-- with a (StayPut level) +-- +-- The returned envt has le_ctxt_lvl updated to the new_lvl +-- +-- All the new binders get the same level, because +-- any floating binding is either going to float past +-- all or none. We never separate binders. +lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs + = ( env { le_ctxt_lvl = new_lvl + , le_join_ceil = new_lvl + , le_lvl_env = addLvls new_lvl lvl_env bndrs } + , map (stayPut new_lvl) bndrs) + +stayPut :: Level -> OutVar -> LevelledBndr +stayPut new_lvl bndr = TB bndr (StayPut new_lvl) + + -- Destination level is the max Id level of the expression + -- (We'll abstract the type variables, if any.) +destLevel :: LevelEnv + -> DVarSet -- Free vars of the term + -> TyCoVarSet -- Free in the /type/ of the term + -- (a subset of the previous argument) + -> Bool -- True <=> is function + -> Bool -- True <=> is bottom + -> Bool -- True <=> is a join point + -> Level +-- INVARIANT: if is_join=True then result >= join_ceiling +destLevel env fvs fvs_ty is_function is_bot is_join + | isTopLvl max_fv_id_level -- Float even joins if they get to top level + -- See Note [Floating join point bindings] + = tOP_LEVEL + + | is_join -- Never float a join point past the join ceiling + -- See Note [Join points] in GHC.Core.Opt.FloatOut + = if max_fv_id_level `ltLvl` join_ceiling + then join_ceiling + else max_fv_id_level + + | is_bot -- Send bottoming bindings to the top + = as_far_as_poss -- regardless; see Note [Bottoming floats] + -- Esp Bottoming floats (1) + + | Just n_args <- floatLams env + , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case + , is_function + , countFreeIds fvs <= n_args + = as_far_as_poss -- Send functions to top level; see + -- the comments with isFunction + + | otherwise = max_fv_id_level + where + join_ceiling = joinCeilingLevel env + max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the + -- tyvars will be abstracted + + as_far_as_poss = maxFvLevel' isId env fvs_ty + -- See Note [Floating and kind casts] + +{- Note [Floating and kind casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case x of + K (co :: * ~# k) -> let v :: Int |> co + v = e + in blah + +Then, even if we are abstracting over Ids, or if e is bottom, we can't +float v outside the 'co' binding. Reason: if we did we'd get + v' :: forall k. (Int ~# Age) => Int |> co +and now 'co' isn't in scope in that type. The underlying reason is +that 'co' is a value-level thing and we can't abstract over that in a +type (else we'd get a dependent type). So if v's /type/ mentions 'co' +we can't float it out beyond the binding site of 'co'. + +That's why we have this as_far_as_poss stuff. Usually as_far_as_poss +is just tOP_LEVEL; but occasionally a coercion variable (which is an +Id) mentioned in type prevents this. + +Example #14270 comment:15. +-} + + +isFunction :: CoreExprWithFVs -> Bool +-- The idea here is that we want to float *functions* to +-- the top level. This saves no work, but +-- (a) it can make the host function body a lot smaller, +-- and hence inlinable. +-- (b) it can also save allocation when the function is recursive: +-- h = \x -> letrec f = \y -> ...f...y...x... +-- in f x +-- becomes +-- f = \x y -> ...(f x)...y...x... +-- h = \x -> f x x +-- No allocation for f now. +-- We may only want to do this if there are sufficiently few free +-- variables. We certainly only want to do it for values, and not for +-- constructors. So the simple thing is just to look for lambdas +isFunction (_, AnnLam b e) | isId b = True + | otherwise = isFunction e +-- isFunction (_, AnnTick _ e) = isFunction e -- dubious +isFunction _ = False + +countFreeIds :: DVarSet -> Int +countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet + -- It's OK to use nonDetStrictFoldUDFM here because we're just counting things. + where + add :: Var -> Int -> Int + add v n | isId v = n+1 + | otherwise = n + +{- +************************************************************************ +* * +\subsection{Free-To-Level Monad} +* * +************************************************************************ +-} + +data LevelEnv + = LE { le_switches :: FloatOutSwitches + , le_ctxt_lvl :: Level -- The current level + , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids + , le_join_ceil:: Level -- Highest level to which joins float + -- Invariant: always >= le_ctxt_lvl + + -- See Note [le_subst and le_env] + , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids + -- The Id -> CoreExpr in the Subst is ignored + -- (since we want to substitute a LevelledExpr for + -- an Id via le_env) but we do use the Co/TyVar substs + , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids + } + +{- Note [le_subst and le_env] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We clone let- and case-bound variables so that they are still distinct +when floated out; hence the le_subst/le_env. (see point 3 of the +module overview comment). We also use these envs when making a +variable polymorphic because we want to float it out past a big +lambda. + +The le_subst and le_env always implement the same mapping, + in_x :-> out_x a b +where out_x is an OutVar, and a,b are its arguments (when +we perform abstraction at the same time as floating). + + le_subst maps to CoreExpr + le_env maps to LevelledExpr + +Since the range is always a variable or application, there is never +any difference between the two, but sadly the types differ. The +le_subst is used when substituting in a variable's IdInfo; the le_env +when we find a Var. + +In addition the le_env records a [OutVar] of variables free in the +OutExpr/LevelledExpr, just so we don't have to call freeVars +repeatedly. This list is always non-empty, and the first element is +out_x + +The domain of the both envs is *pre-cloned* Ids, though + +The domain of the le_lvl_env is the *post-cloned* Ids +-} + +initialEnv :: FloatOutSwitches -> LevelEnv +initialEnv float_lams + = LE { le_switches = float_lams + , le_ctxt_lvl = tOP_LEVEL + , le_join_ceil = panic "initialEnv" + , le_lvl_env = emptyVarEnv + , le_subst = emptySubst + , le_env = emptyVarEnv } + +addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level +addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl + +addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level +addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs + +floatLams :: LevelEnv -> Maybe Int +floatLams le = floatOutLambdas (le_switches le) + +floatConsts :: LevelEnv -> Bool +floatConsts le = floatOutConstants (le_switches le) + +floatOverSat :: LevelEnv -> Bool +floatOverSat le = floatOutOverSatApps (le_switches le) + +floatTopLvlOnly :: LevelEnv -> Bool +floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) + +incMinorLvlFrom :: LevelEnv -> Level +incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env) + +-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can +-- See Note [Binder-swap during float-out] +extendCaseBndrEnv :: LevelEnv + -> Id -- Pre-cloned case binder + -> Expr LevelledBndr -- Post-cloned scrutinee + -> LevelEnv +extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) + case_bndr (Var scrut_var) + | Many <- varMult case_bndr + = le { le_subst = extendSubstWithVar subst case_bndr scrut_var + , le_env = add_id id_env (case_bndr, scrut_var) } +extendCaseBndrEnv env _ _ = env + +-- See Note [Join ceiling] +placeJoinCeiling :: LevelEnv -> LevelEnv +placeJoinCeiling le@(LE { le_ctxt_lvl = lvl }) + = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' } + where + lvl' = asJoinCeilLvl (incMinorLvl lvl) + +maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level +maxFvLevel max_me env var_set + = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set + -- It's OK to use a non-deterministic fold here because maxIn commutes. + +maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level +-- Same but for TyCoVarSet +maxFvLevel' max_me env var_set + = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set + -- It's OK to use a non-deterministic fold here because maxIn commutes. + +maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level +maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl + = case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> foldr max_out lvl abs_vars + Nothing -> max_out in_var lvl + where + max_out out_var lvl + | max_me out_var = case lookupVarEnv lvl_env out_var of + Just lvl' -> maxLvl lvl' lvl + Nothing -> lvl + | otherwise = lvl -- Ignore some vars depending on max_me + +lookupVar :: LevelEnv -> Id -> LevelledExpr +lookupVar le v = case lookupVarEnv (le_env le) v of + Just (_, expr) -> expr + _ -> Var v + +-- Level to which join points are allowed to float (boundary of current tail +-- context). See Note [Join ceiling] +joinCeilingLevel :: LevelEnv -> Level +joinCeilingLevel = le_join_ceil + +abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] + -- Find the variables in fvs, free vars of the target expression, + -- whose level is greater than the destination level + -- These are the ones we are going to abstract out + -- + -- Note that to get reproducible builds, the variables need to be + -- abstracted in deterministic order, not dependent on the values of + -- Uniques. This is achieved by using DVarSets, deterministic free + -- variable computation and deterministic sort. + -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why + -- Uniques are not deterministic. +abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs + = -- NB: sortQuantVars might not put duplicates next to each other + map zap $ sortQuantVars $ + filter abstract_me $ + dVarSetElems $ + closeOverKindsDSet $ + substDVarSet subst in_fvs + -- NB: it's important to call abstract_me only on the OutIds the + -- come from substDVarSet (not on fv, which is an InId) + where + abstract_me v = case lookupVarEnv lvl_env v of + Just lvl -> dest_lvl `ltLvl` lvl + Nothing -> False + + -- We are going to lambda-abstract, so nuke any IdInfo, + -- and add the tyvars of the Id (if necessary) + zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || + not (isEmptyRuleInfo (idSpecialisation v)), + text "absVarsOf: discarding info on" <+> ppr v ) + setIdInfo v vanillaIdInfo + | otherwise = v + +type LvlM result = UniqSM result + +initLvl :: UniqSupply -> UniqSM a -> a +initLvl = initUs_ + +newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] + -> LvlM (LevelEnv, [OutId]) +-- The envt is extended to bind the new bndrs to dest_lvl, but +-- the le_ctxt_lvl is unaffected +newPolyBndrs dest_lvl + env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + abs_vars bndrs + = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer. + do { uniqs <- getUniquesM + ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs + bndr_prs = bndrs `zip` new_bndrs + env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs + , le_subst = foldl' add_subst subst bndr_prs + , le_env = foldl' add_id id_env bndr_prs } + ; return (env', new_bndrs) } + where + add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) + add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) + + mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id + transfer_join_info bndr $ + mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty + where + str = "poly_" ++ occNameString (getOccName bndr) + poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr)) + + -- If we are floating a join point to top level, it stops being + -- a join point. Otherwise it continues to be a join point, + -- but we may need to adjust its arity + dest_is_top = isTopLvl dest_lvl + transfer_join_info bndr new_bndr + | Just join_arity <- isJoinId_maybe bndr + , not dest_is_top + = new_bndr `asJoinId` join_arity + length abs_vars + | otherwise + = new_bndr + +newLvlVar :: LevelledExpr -- The RHS of the new binding + -> Maybe JoinArity -- Its join arity, if it is a join point + -> Bool -- True <=> the RHS looks like (makeStatic ...) + -> LvlM Id +newLvlVar lvld_rhs join_arity_maybe is_mk_static + = do { uniq <- getUniqueM + ; return (add_join_info (mk_id uniq rhs_ty)) + } + where + add_join_info var = var `asJoinId_maybe` join_arity_maybe + de_tagged_rhs = deTagExpr lvld_rhs + rhs_ty = exprType de_tagged_rhs + + mk_id uniq rhs_ty + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + | is_mk_static + = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) + rhs_ty + | otherwise + = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty + +-- | Clone the binders bound by a single-alternative case. +cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) +cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) + new_lvl vs + = do { us <- getUniqueSupplyM + ; let (subst', vs') = cloneBndrs subst us vs + -- N.B. We are not moving the body of the case, merely its case + -- binders. Consequently we should *not* set le_ctxt_lvl and + -- le_join_ceil. See Note [Setting levels when floating + -- single-alternative cases]. + env' = env { le_lvl_env = addLvls new_lvl lvl_env vs' + , le_subst = subst' + , le_env = foldl' add_id id_env (vs `zip` vs') } + + ; return (env', vs') } + +cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] + -> LvlM (LevelEnv, [OutVar]) +-- See Note [Need for cloning during float-out] +-- Works for Ids bound by let(rec) +-- The dest_lvl is attributed to the binders in the new env, +-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env +cloneLetVars is_rec + env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) + dest_lvl vs + = do { us <- getUniqueSupplyM + ; let vs1 = map zap vs + -- See Note [Zapping the demand info] + (subst', vs2) = case is_rec of + NonRecursive -> cloneBndrs subst us vs1 + Recursive -> cloneRecIdBndrs subst us vs1 + prs = vs `zip` vs2 + env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 + , le_subst = subst' + , le_env = foldl' add_id id_env prs } + + ; return (env', vs2) } + where + zap :: Var -> Var + zap v | isId v = zap_join (zapIdDemandInfo v) + | otherwise = v + + zap_join | isTopLvl dest_lvl = zapJoinId + | otherwise = id + +add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) +add_id id_env (v, v1) + | isTyVar v = delVarEnv id_env v + | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1) + +{- +Note [Zapping the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +VERY IMPORTANT: we must zap the demand info if the thing is going to +float out, because it may be less demanded than at its original +binding site. Eg + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict; but if we float v to top level, it isn't any more. + +Similarly, if we're floating a join point, it won't be one anymore, so we zap +join point information as well. +-} diff --git a/GHC/Core/Opt/Simplify.hs b/GHC/Core/Opt/Simplify.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify.hs @@ -0,0 +1,4064 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[Simplify]{The main module of the simplifier} +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} +module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.Driver.Session +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Utils +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import qualified GHC.Core.Make +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Core.Coercion hiding ( substCo, substCoVar ) +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.FamInstEnv ( topNormaliseType_maybe ) +import GHC.Core.DataCon + ( DataCon, dataConWorkId, dataConRepStrictness + , dataConRepArgTys, isUnboxedTupleCon + , StrictnessMark (..) ) +import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) +import GHC.Core +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey ) +import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd + , mkClosedStrictSig, topDmd, seqDmd, botDiv ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Types.Unique ( hasKey ) +import GHC.Core.Unfold +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType + , idArityType, etaExpandAT ) +import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg + , joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) +import GHC.Types.Basic +import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Types.Var ( isTyCoVar ) +import GHC.Data.Maybe ( orElse, isNothing ) +import Control.Monad +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Unit.Module ( moduleName, pprModuleName ) +import GHC.Core.Multiplicity +import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) + + +{- +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in GHC.Core.Opt.Pipeline + +Note [The big picture] +~~~~~~~~~~~~~~~~~~~~~~ +The general shape of the simplifier is this: + + simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + + * SimplEnv contains + - Simplifier mode (which includes DynFlags for convenience) + - Ambient substitution + - InScopeSet + + * SimplFloats contains + - Let-floats (which includes ok-for-spec case-floats) + - Join floats + - InScopeSet (including all the floats) + + * Expressions + simplExpr :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + The result of simplifying an /expression/ is (floats, expr) + - A bunch of floats (let bindings, join bindings) + - A simplified expression. + The overall result is effectively (let floats in expr) + + * Bindings + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + The result of simplifying a binding is + - A bunch of floats, the last of which is the simplified binding + There may be auxiliary bindings too; see prepareRhs + - An environment suitable for simplifying the scope of the binding + + The floats may also be empty, if the binding is inlined unconditionally; + in that case the returned SimplEnv will have an augmented substitution. + + The returned floats and env both have an in-scope set, and they are + guaranteed to be the same. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +The simplifier used to guarantee that the output had no shadowing, but +it does not do so any more. (Actually, it never did!) The reason is +documented with simplifyArgs. + + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +If the \x was on the RHS of a let, we'd eta expand to bring the two +lambdas together. And in general that's a good thing to do. Perhaps +we should eta expand wherever we find a (value) lambda? Then the eta +expansion at a let RHS can concentrate solely on the PAP case. + +Note [In-scope set as a substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Lookups in in-scope set], an in-scope set can act as +a substitution. Specifically, it acts as a substitution from variable to +variables /with the same unique/. + +Why do we need this? Well, during the course of the simplifier, we may want to +adjust inessential properties of a variable. For instance, when performing a +beta-reduction, we change + + (\x. e) u ==> let x = u in e + +We typically want to add an unfolding to `x` so that it inlines to (the +simplification of) `u`. + +We do that by adding the unfolding to the binder `x`, which is added to the +in-scope set. When simplifying occurrences of `x` (every occurrence!), they are +replaced by their “updated” version from the in-scope set, hence inherit the +unfolding. This happens in `SimplEnv.substId`. + +Another example. Consider + + case x of y { Node a b -> ...y... + ; Leaf v -> ...y... } + +In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we +want y's unfolding to be (Leaf v). We achieve this by adding the appropriate +unfolding to y, and re-adding it to the in-scope set. See the calls to +`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. + +It's quite convenient. This way we don't need to manipulate the substitution all +the time: every update to a binder is automatically reflected to its bound +occurrences. + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) +-- See Note [The big picture] +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- so that if a rewrite rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + -- See note [Glomming] in "GHC.Core.Opt.OccurAnal". + ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) + ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 + ; freeTick SimplifierDone + ; return (floats, env2) } + where + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) + simpl_binds env [] = return (emptyFloats env, env) + simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind + ; (floats, env2) <- simpl_binds env1 binds + ; return (float `addFloats` floats, env2) } + + simpl_bind env (Rec pairs) + = simplRecBind env TopLevel Nothing pairs + simpl_bind env (NonRec b r) + = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing + ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r } + +{- +************************************************************************ +* * + Lazy bindings +* * +************************************************************************ + +simplRecBind is used for + * recursive bindings only +-} + +simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont + -> [(InId, InExpr)] + -> SimplM (SimplFloats, SimplEnv) +simplRecBind env0 top_lvl mb_cont pairs0 + = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0 + ; (rec_floats, env1) <- go env_with_info triples + ; return (mkRecFloats rec_floats, env1) } + where + add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) + = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont + ; return (env', (bndr, bndr', rhs)) } + + go env [] = return (emptyFloats env, env) + + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont + old_bndr new_bndr rhs + ; (floats, env2) <- go env1 pairs + ; return (float `addFloats` floats, env2) } + +{- +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + +It assumes the binder has already been simplified, but not its IdInfo. +-} + +simplRecOrTopPair :: SimplEnv + -> TopLevelFlag -> RecFlag -> MaybeJoinCont + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM (SimplFloats, SimplEnv) + +simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs + | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env + = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} + trace_bind "pre-inline-uncond" $ + do { tick (PreInlineUnconditionally old_bndr) + ; return ( emptyFloats env, env' ) } + + | Just cont <- mb_cont + = {-#SCC "simplRecOrTopPair-join" #-} + ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr ) + trace_bind "join" $ + simplJoinBind env cont old_bndr new_bndr rhs env + + | otherwise + = {-#SCC "simplRecOrTopPair-normal" #-} + trace_bind "normal" $ + simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env + + where + dflags = seDynFlags env + + -- trace_bind emits a trace for each top-level binding, which + -- helps to locate the tracing for inlining and rule firing + trace_bind what thing_inside + | not (dopt Opt_D_verbose_core2core dflags) + = thing_inside + | otherwise + = traceAction dflags ("SimplBind " ++ what) + (ppr old_bndr) thing_inside + +-------------------------- +simplLazyBind :: SimplEnv + -> TopLevelFlag -> RecFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -- Not a JoinId + -- The OutId has IdInfo, except arity, unfolding + -- Ids only, no TyVars + -> InExpr -> SimplEnv -- The RHS and its environment + -> SimplM (SimplFloats, SimplEnv) +-- Precondition: not a JoinId +-- Precondition: rhs obeys the let/app invariant +-- NOT used for JoinIds +simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se + = ASSERT( isId bndr ) + ASSERT2( not (isJoinId bndr), ppr bndr ) + -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let rhs_env = rhs_se `setInScopeFromE` env + (tvs, body) = case collectTyAndValBinders rhs of + (tvs, [], body) + | surely_not_lam body -> (tvs, body) + _ -> ([], rhs) + + surely_not_lam (Lam {}) = False + surely_not_lam (Tick t e) + | not (tickishFloatable t) = surely_not_lam e + -- eta-reduction could float + surely_not_lam _ = True + -- Do not do the "abstract tyvar" thing if there's + -- a lambda inside, because it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce. + + + ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils + + -- Simplify the RHS + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont + + -- Never float join-floats out of a non-join let-binding + -- So wrap the body in the join-floats right now + -- Hence: body_floats1 consists only of let-floats + ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0 + + -- ANF-ise a constructor or PAP rhs + -- We get at most one float per argument here + ; (let_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-} + prepareBinding env top_lvl bndr bndr1 body1 + ; let body_floats2 = body_floats1 `addLetFloats` let_floats + + ; (rhs_floats, rhs') + <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) + then -- No floating, revert to body1 + {-#SCC "simplLazyBind-no-floating" #-} + do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont + ; return (emptyFloats env, rhs') } + + else if null tvs then -- Simple floating + {-#SCC "simplLazyBind-simple-floating" #-} + do { tick LetFloatFromLet + ; return (body_floats2, body2) } + + else -- Do type-abstraction first + {-#SCC "simplLazyBind-type-abstraction-first" #-} + do { tick LetFloatFromLet + ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl + tvs' body_floats2 body2 + ; let floats = foldl' extendFloats (emptyFloats env) poly_binds + ; rhs' <- mkLam env tvs' body3 rhs_cont + ; return (floats, rhs') } + + ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) + top_lvl Nothing bndr bndr2 rhs' + ; return (rhs_floats `addFloats` bind_float, env2) } + +-------------------------- +simplJoinBind :: SimplEnv + -> SimplCont + -> InId -> OutId -- Binder, both pre-and post simpl + -- The OutId has IdInfo, except arity, + -- unfolding + -> InExpr -> SimplEnv -- The right hand side and its env + -> SimplM (SimplFloats, SimplEnv) +simplJoinBind env cont old_bndr new_bndr rhs rhs_se + = do { let rhs_env = rhs_se `setInScopeFromE` env + ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont + ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' } + +-------------------------- +simplNonRecX :: SimplEnv + -> InId -- Old binder; not a JoinId + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) +-- A specialised variant of simplNonRec used when the RHS is already +-- simplified, notably in knownCon. It uses case-binding where necessary. +-- +-- Precondition: rhs satisfies the let/app invariant + +simplNonRecX env bndr new_rhs + | ASSERT2( not (isJoinId bndr), ppr bndr ) + isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return (emptyFloats env, env) -- Here c is dead, and we avoid + -- creating the binding c = (a,b) + + | Coercion co <- new_rhs + = return (emptyFloats env, extendCvSubst env bndr co) + + | otherwise + = do { (env', bndr') <- simplBinder env bndr + ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } + -- simplNonRecX is only used for NotTopLevel things + +-------------------------- +completeNonRecX :: TopLevelFlag -> SimplEnv + -> Bool + -> InId -- Old binder; not a JoinId + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) -- The new binding is in the floats +-- Precondition: rhs satisfies the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core + +completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs + = ASSERT2( not (isJoinId new_bndr), ppr new_bndr ) + do { (prepd_floats, new_bndr, new_rhs) + <- prepareBinding env top_lvl old_bndr new_bndr new_rhs + ; let floats = emptyFloats env `addLetFloats` prepd_floats + ; (rhs_floats, rhs2) <- + if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs + then -- Add the floats to the main env + do { tick LetFloatFromLet + ; return (floats, new_rhs) } + else -- Do not float; wrap the floats around the RHS + return (emptyFloats env, wrapFloats floats new_rhs) + + ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) + NotTopLevel Nothing + old_bndr new_bndr rhs2 + ; return (rhs_floats `addFloats` bind_float, env2) } + + +{- ********************************************************************* +* * + prepareBinding, prepareRhs, makeTrivial +* * +************************************************************************ + +Note [Cast worker/wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have a binding + x = e |> co +we want to do something very similar to worker/wrapper: + $wx = e + x = $wx |> co + +So now x can be inlined freely. There's a chance that e will be a +constructor application or function, or something like that, so moving +the coercion to the usage site may well cancel the coercions and lead +to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + t = T m + go 0 = 0 + go n = case t of { T m -> go (n-m) } + -- This case should optimise + +We call this making a cast worker/wrapper, and it's done by prepareBinding. + +We need to be careful with inline/noinline pragmas: + rec { {-# NOINLINE f #-} + f = (...g...) |> co + ; g = ...f... } +This is legitimate -- it tells GHC to use f as the loop breaker +rather than g. Now we do the cast thing, to get something like + rec { $wf = ...g... + ; f = $wf |> co + ; g = ...f... } +Where should the NOINLINE pragma go? If we leave it on f we'll get + rec { $wf = ...g... + ; {-# NOINLINE f #-} + f = $wf |> co + ; g = ...f... } +and that is bad: the whole point is that we want to inline that +cast! We want to transfer the pagma to $wf: + rec { {-# NOINLINE $wf #-} + $wf = ...g... + ; f = $wf |> co + ; g = ...f... } +It's exactly like worker/wrapper for strictness analysis: + f is the wrapper and must inline like crazy + $wf is the worker and must carry f's original pragma +See Note [Worker-wrapper for NOINLINE functions] in +GHC.Core.Opt.WorkWrap. + +See #17673, #18093, #18078. + +Note [Preserve strictness in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Cast worker/wrappers] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Cast w/w: unlifted] +~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT don't do cast worker/wrapper if 'e' has an unlifted type. +This *can* happen: + + foo :: Int = (error (# Int,Int #) "urk") + `cast` CoUnsafe (# Int,Int #) Int + +If do the makeTrivial thing to the error call, we'll get + foo = case error (# Int,Int #) "urk" of v -> v `cast` ... +But 'v' isn't in scope! + +These strange casts can happen as a result of case-of-case + bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of + (# p,q #) -> p+q + +NOTE: Nowadays we don't use casts for these error functions; +instead, we use (case erorr ... of {}). So I'm not sure +this Note makes much sense any more. +-} + +prepareBinding :: SimplEnv -> TopLevelFlag + -> InId -> OutId -> OutExpr + -> SimplM (LetFloats, OutId, OutExpr) + +prepareBinding env top_lvl old_bndr bndr rhs + | Cast rhs1 co <- rhs + -- Try for cast worker/wrapper + -- See Note [Cast worker/wrappers] + , not (isStableUnfolding (realIdUnfolding old_bndr)) + -- Don't make a cast w/w if the thing is going to be inlined anyway + , not (exprIsTrivial rhs1) + -- Nor if the RHS is trivial; then again it'll be inlined + , let ty1 = coercionLKind co + , not (isUnliftedType ty1) + -- Not if rhs has an unlifted type; see Note [Cast w/w: unlifted] + = do { (floats, new_id) <- makeTrivialBinding (getMode env) top_lvl + (getOccFS bndr) worker_info rhs1 ty1 + ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) + ; return (floats, bndr', Cast (Var new_id) co) } + + | otherwise + = do { (floats, rhs') <- prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs + ; return (floats, bndr, rhs') } + where + info = idInfo bndr + worker_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setCprInfo` cprInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` arityInfo info + -- We do /not/ want to transfer OccInfo, Rules, Unfolding + -- Note [Preserve strictness in cast w/w] + +mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma +-- See Note [Cast wrappers] +mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) + = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = NoUserInline -- See Note [Wrapper NoUserInline] + , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap + , inl_act = wrap_act -- See Note [Wrapper activation] + , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap + -- RuleMatchInfo is (and must be) unaffected + where + -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap + -- But simpler, because we don't need to disable during InitialPhase + wrap_act | isNeverActive act = activateDuringFinal + | otherwise = act + +{- Note [prepareRhs] +~~~~~~~~~~~~~~~~~~~~ +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does +-} + +prepareRhs :: SimplMode -> TopLevelFlag + -> FastString -- Base for any new variables + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Transforms a RHS into a better RHS by ANF'ing args +-- for expandable RHSs: constructors and PAPs +-- e.g x = Just e +-- becomes a = e +-- x = Just a +-- See Note [prepareRhs] +prepareRhs mode top_lvl occ rhs0 + = do { (_is_exp, floats, rhs1) <- go 0 rhs0 + ; return (floats, rhs1) } + where + go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) + go n_val_args (Cast rhs co) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Cast rhs' co) } + go n_val_args (App fun (Type ty)) + = do { (is_exp, floats, rhs') <- go n_val_args fun + ; return (is_exp, floats, App rhs' (Type ty)) } + go n_val_args (App fun arg) + = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun + ; case is_exp of + False -> return (False, emptyLetFloats, App fun arg) + True -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg + ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } + go n_val_args (Var fun) + = return (is_exp, emptyLetFloats, Var fun) + where + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in + -- 'GHC.Core.Opt.OccurAnal.occAnalApp' + + go n_val_args (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Tick t rhs') } + + -- On the other hand, for scoping ticks we need to be able to + -- copy them on the floats, which in turn is only allowed if + -- we can obtain non-counting ticks. + | (not (tickishCounts t) || tickishCanSplit t) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = mapLetFloats floats tickIt + ; return (is_exp, floats', Tick t rhs') } + + go _ other + = return (False, emptyLetFloats, other) + +makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd }) + = do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e + ; return (floats, arg { as_arg = e' }) } +makeTrivialArg _ arg + = return (emptyLetFloats, arg) -- CastBy, TyArg + +makeTrivial :: SimplMode -> TopLevelFlag -> Demand + -> FastString -- ^ A "friendly name" to build the new binder from + -> OutExpr -- ^ This expression satisfies the let/app invariant + -> SimplM (LetFloats, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] +makeTrivial mode top_lvl dmd occ_fs expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) + + | Cast expr' co <- expr + = do { (floats, triv_expr) <- makeTrivial mode top_lvl dmd occ_fs expr' + ; return (floats, Cast triv_expr co) } + + | otherwise + = do { (floats, new_id) <- makeTrivialBinding mode top_lvl occ_fs + id_info expr expr_ty + ; return (floats, Var new_id) } + where + id_info = vanillaIdInfo `setDemandInfo` dmd + expr_ty = exprType expr + +makeTrivialBinding :: SimplMode -> TopLevelFlag + -> FastString -- ^ a "friendly name" to build the new binder from + -> IdInfo + -> OutExpr -- ^ This expression satisfies the let/app invariant + -> OutType -- Type of the expression + -> SimplM (LetFloats, OutId) +makeTrivialBinding mode top_lvl occ_fs info expr expr_ty + = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr + ; uniq <- getUniqueM + ; let name = mkSystemVarName uniq occ_fs + var = mkLocalIdWithInfo name Many expr_ty info + + -- Now something very like completeBind, + -- but without the postInlineUnconditionally part + ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1 + ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2 + + ; let final_id = addLetBndrInfo var arity_type unf + bind = NonRec final_id expr2 + + ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) } + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl expr expr_ty + | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty + | otherwise = True + +{- Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +Literal strings are an exception. + + foo = Ptr "blob"# + +We want to turn this into: + + foo1 = "blob"# + foo = Ptr foo1 + +See Note [Core top-level string literals] in GHC.Core. + +************************************************************************ +* * + Completing a lazy binding +* * +************************************************************************ + +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings + +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + +It does *not* attempt to do let-to-case. Why? Because it is used for + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing +-} + +completeBind :: SimplEnv + -> TopLevelFlag -- Flag stuck into unfolding + -> MaybeJoinCont -- Required only for join point + -> InId -- Old binder + -> OutId -> OutExpr -- New binder and RHS + -> SimplM (SimplFloats, SimplEnv) +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt +-- +-- Binder /can/ be a JoinId +-- Precondition: rhs obeys the let/app invariant +completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) + _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) + + | otherwise + = ASSERT( isId new_bndr ) + do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info + + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils + ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs + + -- Simplify the unfolding + ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr + final_rhs (idType new_bndr) new_arity old_unf + + ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding + -- See Note [In-scope set as a substitution] + + ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs + + then -- Inline and discard the binding + do { tick (PostInlineUnconditionally old_bndr) + ; return ( emptyFloats env + , extendIdSubst env old_bndr $ + DoneEx final_rhs (isJoinId_maybe new_bndr)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else -- Keep the binding + -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ + return (mkFloatBind env (NonRec final_bndr final_rhs)) } + +addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId +addLetBndrInfo new_bndr new_arity_type new_unf + = new_bndr `setIdInfo` info5 + where + new_arity = arityTypeArity new_arity_type + is_bot = isBotArityType new_arity_type + + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unf + + -- Demand info: Note [Setting the demand info] + -- We also have to nuke demand info if for some reason + -- eta-expansion *reduces* the arity of the binding to less + -- than that of the strictness sig. This can happen: see Note [Arity decrease]. + info3 | isEvaldUnfolding new_unf + || (case strictnessInfo info2 of + StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) + = zapDemandInfo info2 `orElse` info2 + | otherwise + = info2 + + -- Bottoming bindings: see Note [Bottoming bindings] + info4 | is_bot = info3 `setStrictnessInfo` bot_sig + `setCprInfo` bot_cpr + | otherwise = info3 + + bot_sig = mkClosedStrictSig (replicate new_arity topDmd) botDiv + bot_cpr = mkCprSig new_arity botCpr + + -- Zap call arity info. We have used it by now (via + -- `tryEtaExpandRhs`), and the simplifier can invalidate this + -- information, leading to broken code later (e.g. #13479) + info5 = zapCallArityInfo info4 + + +{- Note [Arity decrease] +~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking the arity of a binding should not decrease. But it *can* +legitimately happen because of RULES. Eg + f = g @Int +where g has arity 2, will have arity 2. But if there's a rewrite rule + g @Int --> h +where h has arity 1, then f's arity will decrease. Here's a real-life example, +which is in the output of Specialise: + + Rec { + $dm {Arity 2} = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm #-} + + dInt = MkD .... opInt ... + opInt {Arity 1} = $dm dInt + + $s$dm {Arity 0} = \x. op dInt } + +Here opInt has arity 1; but when we apply the rule its arity drops to 0. +That's why Specialise goes to a little trouble to pin the right arity +on specialised functions too. + +Note [Bottoming bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = error "urk" + in ...(case x of )... +or + let f = \x. error (x ++ "urk") + in ...(case f "foo" of )... + +Then we'd like to drop the dead immediately. So it's good to +propagate the info that x's RHS is bottom to x's IdInfo as rapidly as +possible. + +We use tryEtaExpandRhs on every binding, and it turns out that the +arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already +does a simple bottoming-expression analysis. So all we need to do +is propagate that info to the binder's IdInfo. + +This showed up in #12150; see comment:16. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + + +************************************************************************ +* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +* * +************************************************************************ + +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. + +To see why it's important to do it after, consider this (real) example: + + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 + +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider + + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... + +Only in this second round can the \y be applied, and it +might do the same again. +-} + +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr env (Type ty) + = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] + ; return (Type ty') } + +simplExpr env expr + = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) + -- NB: Since 'expr' is term-valued, not (Type ty), this call + -- to exprType will succeed. exprType fails on (Type ty). + +simplExprC :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM OutExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $ + do { (floats, expr') <- simplExprF env expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ + return (wrapFloats floats expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF env e cont + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + ]) $ -} + simplExprF1 env e cont + +simplExprF1 :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF1 _ (Type ty) cont + = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) + -- simplExprF does only with term-valued expressions + -- The (Type ty) case is handled separately by simplExpr + -- and by the other callers of simplExprF + +simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont +simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont +simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont +simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont +simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont + +simplExprF1 env (App fun arg) cont + = {-#SCC "simplExprF1-App" #-} case arg of + Type ty -> do { -- The argument type will (almost) certainly be used + -- in the output program, so just force it now. + -- See Note [Avoiding space leaks in OutType] + arg' <- simplType env ty + + -- But use substTy, not simplType, to avoid forcing + -- the hole type; it will likely not be needed. + -- See Note [The hole type in ApplyToTy] + ; let hole' = substTy env (exprType fun) + + ; simplExprF env fun $ + ApplyToTy { sc_arg_ty = arg' + , sc_hole_ty = hole' + , sc_cont = cont } } + _ -> + -- Crucially, sc_hole_ty is a /lazy/ binding. It will + -- be forced only if we need to run contHoleType. + -- When these are forced, we might get quadratic behavior; + -- this quadratic blowup could be avoided by drilling down + -- to the function and getting its multiplicities all at once + -- (instead of one-at-a-time). But in practice, we have not + -- observed the quadratic behavior, so this extra entanglement + -- seems not worthwhile. + simplExprF env fun $ + ApplyToVal { sc_arg = arg, sc_env = env + , sc_hole_ty = substTy env (exprType fun) + , sc_dup = NoDup, sc_cont = cont } + +simplExprF1 env expr@(Lam {}) cont + = {-#SCC "simplExprF1-Lam" #-} + simplLam env zapped_bndrs body cont + -- The main issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info, UNLESS the remaining binders are one-shot + where + (bndrs, body) = collectBinders expr + zapped_bndrs | need_to_zap = map zap bndrs + | otherwise = bndrs + + need_to_zap = any zappable_bndr (drop n_args bndrs) + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyVar b = b + | otherwise = zapLamIdInfo b + +simplExprF1 env (Case scrut bndr _ alts) cont + = {-#SCC "simplExprF1-Case" #-} + simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr + , sc_alts = alts + , sc_env = env, sc_cont = cont }) + +simplExprF1 env (Let (Rec pairs) body) cont + | Just pairs' <- joinPointBindings_maybe pairs + = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont + + | otherwise + = {-#SCC "simplRecE" #-} simplRecE env pairs body cont + +simplExprF1 env (Let (NonRec bndr rhs) body) cont + | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) + = {-#SCC "simplExprF1-NonRecLet-Type" #-} + ASSERT( isTyVar bndr ) + do { ty' <- simplType env ty + ; simplExprF (extendTvSubst env bndr ty') body cont } + + | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs + = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont + + | otherwise + = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont + +{- Note [Avoiding space leaks in OutType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the simplifier is run for multiple iterations, we need to ensure +that any thunks in the output of one simplifier iteration are forced +by the evaluation of the next simplifier iteration. Otherwise we may +retain multiple copies of the Core program and leak a terrible amount +of memory (as in #13426). + +The simplifier is naturally strict in the entire "Expr part" of the +input Core program, because any expression may contain binders, which +we must find in order to extend the SimplEnv accordingly. But types +do not contain binders and so it is tempting to write things like + + simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! + +This is Bad because the result includes a thunk (substTy env ty) which +retains a reference to the whole simplifier environment; and the next +simplifier iteration will not force this thunk either, because the +line above is not strict in ty. + +So instead our strategy is for the simplifier to fully evaluate +OutTypes when it emits them into the output Core program, for example + + simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good + ; return (Type ty') } + +where the only difference from above is that simplType calls seqType +on the result of substTy. + +However, SimplCont can also contain OutTypes and it's not necessarily +a good idea to force types on the way in to SimplCont, because they +may end up not being used and forcing them could be a lot of wasted +work. T5631 is a good example of this. + +- For ApplyToTy's sc_arg_ty, we force the type on the way in because + the type will almost certainly appear as a type argument in the + output program. + +- For the hole types in Stop and ApplyToTy, we force the type when we + emit it into the output program, after obtaining it from + contResultType. (The hole type in ApplyToTy is only directly used + to form the result type in a new Stop continuation.) +-} + +--------------------------------- +-- Simplify a join point, adding the context. +-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: +-- \x1 .. xn -> e => \x1 .. xn -> E[e] +-- Note that we need the arity of the join point, since e may be a lambda +-- (though this is unlikely). See Note [Join points and case-of-case]. +simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont + -> SimplM OutExpr +simplJoinRhs env bndr expr cont + | Just arity <- isJoinId_maybe bndr + = do { let (join_bndrs, join_body) = collectNBinders arity expr + mult = contHoleScaling cont + ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) + ; join_body' <- simplExprC env' join_body cont + ; return $ mkLams join_bndrs' join_body' } + + | otherwise + = pprPanic "simplJoinRhs" (ppr bndr) + +--------------------------------- +simplType :: SimplEnv -> InType -> SimplM OutType + -- Kept monadic just so we can do the seqType + -- See Note [Avoiding space leaks in OutType] +simplType env ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty + where + new_ty = substTy env ty + +--------------------------------- +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion +simplCoercion env co + = do { dflags <- getDynFlags + ; let opt_co = optCoercion dflags (getTCvSubst env) co + ; seqCo opt_co `seq` return opt_co } + +----------------------------------- +-- | Push a TickIt context outwards past applications and cases, as +-- long as this is a non-scoping tick, to let case and application +-- optimisations apply. + +simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot + -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do + -- it this way, then it would take two passes of the simplifier to + -- reduce ((scc t (\x . e)) e'). + -- NB, don't do this with counting ticks, because if the expr is + -- bottom, then rebuildCall will discard the continuation. + +-- XXX: we cannot do this, because the simplifier assumes that +-- the context can be pushed into a case with a single branch. e.g. +-- scc case expensive of p -> e +-- becomes +-- case expensive of p -> scc e +-- +-- So I'm disabling this for now. It just means we will do more +-- simplifier iterations that necessary in some cases. + +-- | tickishScoped tickish && not (tickishCounts tickish) +-- = simplExprF env expr (TickIt tickish cont) + + -- For unscoped or soft-scoped ticks, we are allowed to float in new + -- cost, so we simply push the continuation inside the tick. This + -- has the effect of moving the tick to the outside of a case or + -- application context, allowing the normal case and application + -- optimisations to fire. + | tickish `tickishScopesLike` SoftScope + = do { (floats, expr') <- simplExprF env expr cont + ; return (floats, mkTick tickish expr') + } + + -- Push tick inside if the context looks like this will allow us to + -- do a case-of-case - see Note [case-of-scc-of-case] + | Select {} <- cont, Just expr' <- push_tick_inside + = simplExprF env expr' cont + + -- We don't want to move the tick, but we might still want to allow + -- floats to pass through with appropriate wrapping (or not, see + -- wrap_floats below) + --- | not (tickishCounts tickish) || tickishCanSplit tickish + -- = wrap_floats + + | otherwise + = no_floating_past_tick + + where + + -- Try to push tick inside a case, see Note [case-of-scc-of-case]. + push_tick_inside = + case expr0 of + Case scrut bndr ty alts + -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) + _other -> Nothing + where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) + movable t = not (tickishCounts t) || + t `tickishScopesLike` NoScope || + tickishCanSplit t + tickScrut e = foldr mkTick e ticks + -- Alternatives get annotated with all ticks that scope in some way, + -- but we don't want to count entries. + tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) + ts_scope = map mkNoCount $ + filter (not . (`tickishScopesLike` NoScope)) ticks + + no_floating_past_tick = + do { let (inc,outc) = splitCont cont + ; (floats, expr1) <- simplExprF env expr inc + ; let expr2 = wrapFloats floats expr1 + tickish' = simplTickish env tickish + ; rebuild env (mkTick tickish' expr2) outc + } + +-- Alternative version that wraps outgoing floats with the tick. This +-- results in ticks being duplicated, as we don't make any attempt to +-- eliminate the tick if we re-inline the binding (because the tick +-- semantics allows unrestricted inlining of HNFs), so I'm not doing +-- this any more. FloatOut will catch any real opportunities for +-- floating. +-- +-- wrap_floats = +-- do { let (inc,outc) = splitCont cont +-- ; (env', expr') <- simplExprF (zapFloats env) expr inc +-- ; let tickish' = simplTickish env tickish +-- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), +-- mkTick (mkNoCount tickish') rhs) +-- -- when wrapping a float with mkTick, we better zap the Id's +-- -- strictness info and arity, because it might be wrong now. +-- ; let env'' = addFloats env (mapFloats env' wrap_float) +-- ; rebuild env'' expr' (TickIt tickish' outc) +-- } + + + simplTickish env tickish + | Breakpoint n ids <- tickish + = Breakpoint n (map (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont (CastIt co c) = (CastIt co inc, outc) + where (inc,outc) = splitCont c + splitCont other = (mkBoringStop (contHoleType other), other) + + getDoneId (DoneId id) = id + getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst + getDoneId other = pprPanic "getDoneId" (ppr other) + +-- Note [case-of-scc-of-case] +-- It's pretty important to be able to transform case-of-case when +-- there's an SCC in the way. For example, the following comes up +-- in nofib/real/compress/Encode.hs: +-- +-- case scctick +-- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje +-- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> +-- (ww1_s13f, ww2_s13g, ww3_s13h) +-- } +-- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> +-- tick +-- (ww_s12Y, +-- ww1_s12Z, +-- PTTrees.PT +-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) +-- } +-- +-- We really want this case-of-case to fire, because then the 3-tuple +-- will go away (indeed, the CPR optimisation is relying on this +-- happening). But the scctick is in the way - we need to push it +-- inside to expose the case-of-case. So we perform this +-- transformation on the inner case: +-- +-- scctick c (case e of { p1 -> e1; ...; pn -> en }) +-- ==> +-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } +-- +-- So we've moved a constant amount of work out of the scc to expose +-- the case. We only do this when the continuation is interesting: in +-- for now, it has to be another Case (maybe generalise this later). + +{- +************************************************************************ +* * +\subsection{The main rebuilder} +* * +************************************************************************ +-} + +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +-- At this point the substitution in the SimplEnv should be irrelevant; +-- only the in-scope set matters +rebuild env expr cont + = case cont of + Stop {} -> return (emptyFloats env, expr) + TickIt t cont -> rebuild env (mkTick t expr) cont + CastIt co cont -> rebuild env (mkCast expr co) cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + + Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } + -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont + + StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } + -> rebuildCall env (addValArgTo fun expr fun_ty ) cont + StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body + , sc_env = se, sc_cont = cont } + -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr + -- expr satisfies let/app since it started life + -- in a call to simplNonRecE + ; (floats2, expr') <- simplLam env' bs body cont + ; return (floats1 `addFloats` floats2, expr') } + + ApplyToTy { sc_arg_ty = ty, sc_cont = cont} + -> rebuild env (App expr (Type ty)) cont + + ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} + -- See Note [Avoid redundant simplification] + -> do { (_, _, arg') <- simplArg env dup_flag se arg + ; rebuild env (App expr arg') cont } + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +{- Note [Optimising reflexivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important (for compiler performance) to get rid of reflexivity as soon +as it appears. See #11735, #14737, and #15019. + +In particular, we want to behave well on + + * e |> co1 |> co2 + where the two happen to cancel out entirely. That is quite common; + e.g. a newtype wrapping and unwrapping cancel. + + + * (f |> co) @t1 @t2 ... @tn x1 .. xm + Here we will use pushCoTyArg and pushCoValArg successively, which + build up NthCo stacks. Silly to do that if co is reflexive. + +However, we don't want to call isReflexiveCo too much, because it uses +type equality which is expensive on big types (#14737 comment:7). + +A good compromise (determined experimentally) seems to be to call +isReflexiveCo + * when composing casts, and + * at the end + +In investigating this I saw missed opportunities for on-the-fly +coercion shrinkage. See #15090. +-} + + +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont0 -- See Note [Optimising reflexivity] + else addCoerce co1 cont0 + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } + where + -- If the first parameter is MRefl, then simplifying revealed a + -- reflexive coercion. Omit. + addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont + addCoerceM MRefl cont = return cont + addCoerceM (MCo co) cont = addCoerce co cont + + addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont + addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] + | isReflexiveCo co' = return cont + | otherwise = addCoerce co' cont + where + co' = mkTransCo co1 co2 + + addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- addCoerceM m_co' tail + ; return (ApplyToTy { sc_arg_ty = arg_ty' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } + -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + + -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- where co :: (s1->s2) ~ (t1~t2) + -- co1 :: t1 ~ s1 + -- co2 :: s2 ~ t2 + addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = tail }) + | Just (co1, m_co2) <- pushCoValArg co + , let new_ty = coercionRKind co1 + , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg + -- See Note [Levity polymorphism invariants] in GHC.Core + -- test: typecheck/should_run/EtaExpandLevPoly + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- addCoerceM m_co2 tail + ; if isReflCo co1 + then return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) + -- Avoid simplifying if possible; + -- See Note [Avoiding exponential behaviour] + else do + { (dup', arg_se', arg') <- simplArg env dup arg_se arg + -- When we build the ApplyTo we can't mix the OutCoercion + -- 'co' with the InExpr 'arg', so we simplify + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- Example of use: #995 + ; return (ApplyToVal { sc_arg = mkCast arg' co1 + , sc_env = arg_se' + , sc_dup = dup' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } } + + addCoerce co cont + | isReflexiveCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt co cont) + +simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr + -> SimplM (DupFlag, StaticEnv, OutExpr) +simplArg env dup_flag arg_env arg + | isSimplified dup_flag + = return (dup_flag, arg_env, arg) + | otherwise + = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg + ; return (Simplified, zapSubstEnv arg_env, arg') } + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplLam env [] body cont + = simplExprF env body cont + +simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } + +simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_dup = dup }) + | isSimplified dup -- Don't re-simplify if we've simplified it once + -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; (floats1, env') <- simplNonRecX env zapped_bndr arg + ; (floats2, expr') <- simplLam env' bndrs body cont + ; return (floats1 `addFloats` floats2, expr') } + + | otherwise + = do { tick (BetaReduction bndr) + ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont } + where + zapped_bndr -- See Note [Zap unfolding when beta-reducing] + | isId bndr = zapStableUnfolding bndr + | otherwise = bndr + + -- Discard a non-counting tick on a lambda. This may change the + -- cost attribution slightly (moving the allocation of the + -- lambda elsewhere), but we don't care: optimisation changes + -- cost attribution all the time. +simplLam env bndrs body (TickIt tickish cont) + | not (tickishCounts tickish) + = simplLam env bndrs body cont + + -- Not enough args, so there are real lambdas left to put in the result +simplLam env bndrs body cont + = do { (env', bndrs') <- simplLamBndrs env bndrs + ; body' <- simplExpr env' body + ; new_lam <- mkLam env bndrs' body' cont + ; rebuild env' new_lam cont } + +------------- +simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Used for lambda binders. These sometimes have unfoldings added by +-- the worker/wrapper pass that must be preserved, because they can't +-- be reconstructed from context. For example: +-- f x = case x of (a,b) -> fw a b x +-- fw a b x{=(a,b)} = ... +-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. +simplLamBndr env bndr + | isId bndr && hasCoreUnfolding old_unf -- Special case + = do { (env1, bndr1) <- simplBinder env bndr + ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr + (idType bndr1) (idArityType bndr1) old_unf + ; let bndr2 = bndr1 `setIdUnfolding` unf' + ; return (modifyInScope env1 bndr2, bndr2) } + + | otherwise + = simplBinder env bndr -- Normal case + where + old_unf = idUnfolding bndr + +simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs + +------------------ +simplNonRecE :: SimplEnv + -> InId -- The binder, always an Id + -- Never a join point + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> ([InBndr], InExpr) -- Body of the let/lambda + -- \xs.e + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplNonRecE is used for +-- * non-top-level non-recursive non-join-point lets in expressions +-- * beta reduction +-- +-- simplNonRec env b (rhs, rhs_se) (bs, body) k +-- = let env in +-- cont< let b = rhs_se(rhs) in \bs.body > +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process +-- +-- Precondition: rhs satisfies the let/app invariant +-- Note [Core let/app invariant] in GHC.Core +-- +-- The "body" of the binding comes as a pair of ([InId],InExpr) +-- representing a lambda; so we recurse back to simplLam +-- Why? Because of the binder-occ-info-zapping done before +-- the call to simplLam in simplExprF (Lam ...) + +simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont + | ASSERT( isId bndr && not (isJoinId bndr) ) True + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se + = do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam env' bndrs body cont } + + -- Deal with strict bindings + | isStrictId bndr -- Includes coercions, and unlifted types + , sm_case_case (getMode env) + = simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + -- Deal with lazy bindings + | otherwise + = ASSERT( not (isTyVar bndr) ) + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing + ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; (floats2, expr') <- simplLam env3 bndrs body cont + ; return (floats1 `addFloats` floats2, expr') } + +------------------ +simplRecE :: SimplEnv + -> [(InId, InExpr)] + -> InExpr + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplRecE is used for +-- * non-top-level recursive lets in expressions +simplRecE env pairs body cont + = do { let bndrs = map fst pairs + ; MASSERT(all (not . isJoinId) bndrs) + ; env1 <- simplRecBndrs env bndrs + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs + ; (floats2, expr') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, expr') } + +{- Note [Avoiding exponential behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One way in which we can get exponential behaviour is if we simplify a +big expression, and the re-simplify it -- and then this happens in a +deeply-nested way. So we must be jolly careful about re-simplifying +an expression. That is why completeNonRecX does not try +preInlineUnconditionally. + +Example: + f BIG, where f has a RULE +Then + * We simplify BIG before trying the rule; but the rule does not fire + * We inline f = \x. x True + * So if we did preInlineUnconditionally we'd re-simplify (BIG True) + +However, if BIG has /not/ already been simplified, we'd /like/ to +simplify BIG True; maybe good things happen. That is why + +* simplLam has + - a case for (isSimplified dup), which goes via simplNonRecX, and + - a case for the un-simplified case, which goes via simplNonRecE + +* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, + in at least two places + - In simplCast/addCoerce, where we check for isReflCo + - In rebuildCall we avoid simplifying arguments before we have to + (see Note [Trying rewrite rules]) + + +Note [Zap unfolding when beta-reducing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lambda-bound variables can have stable unfoldings, such as + $j = \x. \b{Unf=Just x}. e +See Note [Case binders and join points] below; the unfolding for lets +us optimise e better. However when we beta-reduce it we want to +revert to using the actual value, otherwise we can end up in the +stupid situation of + let x = blah in + let b{Unf=Just x} = y + in ...b... +Here it'd be far better to drop the unfolding and use the actual RHS. + +************************************************************************ +* * + Join points +* * +********************************************************************* -} + +{- Note [Rules and unfolding for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + simplExpr (join j x = rhs ) cont + ( {- RULE j (p:ps) = blah -} ) + ( {- StableUnfolding j = blah -} ) + (in blah ) + +Then we will push 'cont' into the rhs of 'j'. But we should *also* push +'cont' into the RHS of + * Any RULEs for j, e.g. generated by SpecConstr + * Any stable unfolding for j, e.g. the result of an INLINE pragma + +Simplifying rules and stable-unfoldings happens a bit after +simplifying the right-hand side, so we remember whether or not it +is a join point, and what 'cont' is, in a value of type MaybeJoinCont + +#13900 was caused by forgetting to push 'cont' into the RHS +of a SpecConstr-generated RULE for a join point. +-} + +type MaybeJoinCont = Maybe SimplCont + -- Nothing => Not a join point + -- Just k => This is a join binding with continuation k + -- See Note [Rules and unfolding for join points] + +simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecJoinPoint env bndr rhs body cont + | ASSERT( isJoinId bndr ) True + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + = do { tick (PreInlineUnconditionally bndr) + ; simplExprF env' body cont } + + | otherwise + = wrapJoinCont env cont $ \ env cont -> + do { -- We push join_cont into the join RHS and the body; + -- and wrap wrap_cont around the whole thing + ; let mult = contHoleScaling cont + res_ty = contResultType cont + ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (Just cont) + ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env + ; (floats2, body') <- simplExprF env3 body cont + ; return (floats1 `addFloats` floats2, body') } + + +------------------ +simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplRecJoinPoint env pairs body cont + = wrapJoinCont env cont $ \ env cont -> + do { let bndrs = map fst pairs + mult = contHoleScaling cont + res_ty = contResultType cont + ; env1 <- simplRecJoinBndrs env bndrs mult res_ty + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 NotTopLevel (Just cont) pairs + ; (floats2, body') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, body') } + +-------------------- +wrapJoinCont :: SimplEnv -> SimplCont + -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplM (SimplFloats, OutExpr) +-- Deal with making the continuation duplicable if necessary, +-- and with the no-case-of-case situation. +wrapJoinCont env cont thing_inside + | contIsStop cont -- Common case; no need for fancy footwork + = thing_inside env cont + + | not (sm_case_case (getMode env)) + -- See Note [Join points with -fno-case-of-case] + = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 + ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont + ; return (floats2 `addFloats` floats3, expr3) } + + | otherwise + -- Normal case; see Note [Join points and case-of-case] + = do { (floats1, cont') <- mkDupableCont env cont + ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; return (floats1 `addFloats` floats2, result) } + + +-------------------- +trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont +-- Drop outer context from join point invocation (jump) +-- See Note [Join points and case-of-case] + +trimJoinCont _ Nothing cont + = cont -- Not a jump +trimJoinCont var (Just arity) cont + = trim arity cont + where + trim 0 cont@(Stop {}) + = cont + trim 0 cont + = mkBoringStop (contResultType cont) + trim n cont@(ApplyToVal { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } + trim n cont@(ApplyToTy { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } -- join arity counts types! + trim _ cont + = pprPanic "completeCall" $ ppr var $$ ppr cont + + +{- Note [Join points and case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we perform the case-of-case transform (or otherwise push continuations +inward), we want to treat join points specially. Since they're always +tail-called and we want to maintain this invariant, we can do this (for any +evaluation context E): + + E[join j = e + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> f 3] + + --> + + join j = E[e] + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> E[f 3] + +As is evident from the example, there are two components to this behavior: + + 1. When entering the RHS of a join point, copy the context inside. + 2. When a join point is invoked, discard the outer context. + +We need to be very careful here to remain consistent---neither part is +optional! + +We need do make the continuation E duplicable (since we are duplicating it) +with mkDupableCont. + + +Note [Join points with -fno-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose case-of-case is switched off, and we are simplifying + + case (join j x = in + case y of + A -> j 1 + B -> j 2 + C -> e) of + +Usually, we'd push the outer continuation (case . of ) into +both the RHS and the body of the join point j. But since we aren't doing +case-of-case we may then end up with this totally bogus result + + join x = case of in + case (case y of + A -> j 1 + B -> j 2 + C -> e) of + +This would be OK in the language of the paper, but not in GHC: j is no longer +a join point. We can only do the "push continuation into the RHS of the +join point j" if we also push the continuation right down to the /jumps/ to +j, so that it can evaporate there. If we are doing case-of-case, we'll get to + + join x = case of in + case y of + A -> j 1 + B -> j 2 + C -> case e of + +which is great. + +Bottom line: if case-of-case is off, we must stop pushing the continuation +inwards altogether at any join point. Instead simplify the (join ... in ...) +with a Stop continuation, and wrap the original continuation around the +outside. Surprisingly tricky! + + +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + | isTyVar var = return (Type (substTyVar env var)) + | isCoVar var = return (Coercion (substCoVar env var)) + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e + +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplIdF env var cont + = case substId env var of + ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont + -- Don't trim; haven't already simplified e, + -- so the cont is not embodied in e + + DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont) + + DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont) + -- Note [zapSubstEnv] + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! + +--------------------------------------------------------- +-- Dealing with a call site + +completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) +completeCall env var cont + | Just expr <- callSiteInline dflags var active_unf + lone_variable arg_infos interesting_cont + -- Inline the variable's RHS + = do { checkedTick (UnfoldingDone var) + ; dump_inline expr cont + ; simplExprF (zapSubstEnv env) expr cont } + + | otherwise + -- Don't inline; instead rebuild the call + = do { rule_base <- getSimplRules + ; let info = mkArgInfo env var (getRules rule_base var) + n_val_args call_cont + ; rebuildCall env info cont } + + where + dflags = seDynFlags env + (lone_variable, arg_infos, call_cont) = contArgs cont + n_val_args = length arg_infos + interesting_cont = interestingCallContext env call_cont + active_unf = activeUnfolding (getMode env) var + + log_inlining doc + = liftIO $ dumpAction dflags + (mkDumpStyle alwaysQualify) + (dumpOptionsFromFlag Opt_D_dump_inlinings) + "" FormatText doc + + dump_inline unfolding cont + | not (dopt Opt_D_dump_inlinings dflags) = return () + | not (dopt Opt_D_verbose_core2core dflags) + = when (isExternalName (idName var)) $ + log_inlining $ + sep [text "Inlining done:", nest 4 (ppr var)] + | otherwise + = liftIO $ log_inlining $ + sep [text "Inlining done: " <> ppr var, + nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont])] + +rebuildCall :: SimplEnv + -> ArgInfo + -> SimplCont + -> SimplM (SimplFloats, OutExpr) +-- We decided not to inline, so +-- - simplify the arguments +-- - try rewrite rules +-- - and rebuild + +---------- Bottoming applications -------------- +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + -- continuation to discard, else we do it + -- again and again! + = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] + return (emptyFloats env, castBottomExpr res cont_ty) + where + res = argInfoExpr fun rev_args + cont_ty = contResultType cont + +---------- Try rewrite RULES -------------- +-- See Note [Trying rewrite rules] +rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args + , ai_rules = Just (nr_wanted, rules) }) cont + | nr_wanted == 0 || no_more_args + , let info' = info { ai_rules = Nothing } + = -- We've accumulated a simplified call in + -- so try rewrite rules; see Note [RULEs apply to simplified arguments] + -- See also Note [Rules for recursive functions] + do { mb_match <- tryRules env rules fun (reverse rev_args) cont + ; case mb_match of + Just (env', rhs, cont') -> simplExprF env' rhs cont' + Nothing -> rebuildCall env info' cont } + where + no_more_args = case cont of + ApplyToTy {} -> False + ApplyToVal {} -> False + _ -> True + + +---------- Simplify applications and casts -------------- +rebuildCall env info (CastIt co cont) + = rebuildCall env (addCastTo info co) cont + +rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) + = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont + +---------- The runRW# rule. Do this after absorbing all arguments ------ +-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. +-- +-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o +-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) +rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_hole_ty = fun_ty }) + | fun_id `hasKey` runRWKey + , not (contIsStop cont) -- Don't fiddle around if the continuation is boring + , [ TyArg {}, TyArg {} ] <- rev_args + = do { s <- newId (fsLit "s") Many realWorldStatePrimTy + ; let (m,_,_) = splitFunTy fun_ty + env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] + ty' = contResultType cont + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s + , sc_env = env', sc_cont = cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + -- cont' applies to s, then K + ; body' <- simplExprC env' arg cont' + ; let arg' = Lam s body' + rr' = getRuntimeRep ty' + call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] + ; return (emptyFloats env, call') } + +rebuildCall env fun_info + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup_flag, sc_hole_ty = fun_ty + , sc_cont = cont }) + -- Argument is already simplified + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addValArgTo fun_info arg fun_ty) cont + + -- Strict arguments + | isStrictArgInfo fun_info + , sm_case_case (getMode env) + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setInScopeFromE` env) arg + (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty + , sc_dup = Simplified + , sc_cont = cont }) + -- Note [Shadowing] + + -- Lazy arguments + | otherwise + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg + (mkLazyArgStop arg_ty (lazyArgContext fun_info)) + ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } + where + arg_ty = funArgTy fun_ty + + +---------- No further useful info, revert to generic rebuild ------------ +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont + = rebuild env (argInfoExpr fun rev_args) cont + +{- Note [Trying rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet +simplified. We want to simplify enough arguments to allow the rules +to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone +is sufficient. Example: class ops + (+) dNumInt e2 e3 +If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the +latter's strictness when simplifying e2, e3. Moreover, suppose we have + RULE f Int = \x. x True + +Then given (f Int e1) we rewrite to + (\x. x True) e1 +without simplifying e1. Now we can inline x into its unique call site, +and absorb the True into it all in the same pass. If we simplified +e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. + +So we try to apply rules if either + (a) no_more_args: we've run out of argument that the rules can "see" + (b) nr_wanted: none of the rules wants any more arguments + + +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweep. + +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +This part of the simplifier may break the no-shadowing invariant +Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! + + +************************************************************************ +* * + Rewrite rules +* * +************************************************************************ +-} + +tryRules :: SimplEnv -> [CoreRule] + -> Id -> [ArgSpec] + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) + +tryRules env rules fn args call_cont + | null rules + = return Nothing + +{- Disabled until we fix #8326 + | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] + , [_type_arg, val_arg] <- args + , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont + , isDeadBinder bndr + = do { let enum_to_tag :: CoreAlt -> CoreAlt + -- Takes K -> e into tagK# -> e + -- where tagK# is the tag of constructor K + enum_to_tag (DataAlt con, [], rhs) + = ASSERT( isEnumerationTyCon (dataConTyCon con) ) + (LitAlt tag, [], rhs) + where + tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG)) + enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) + + new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts + new_bndr = setIdType bndr intPrimTy + -- The binder is dead, but should have the right type + ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } +-} + + | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env) + (activeRule (getMode env)) fn + (argInfoAppArgs args) rules + -- Fire a rule for the function + = do { checkedTick (RuleFired (ruleName rule)) + ; let cont' = pushSimplifiedArgs zapped_env + (drop (ruleArity rule) args) + call_cont + -- (ruleArity rule) says how + -- many args the rule consumed + + occ_anald_rhs = occurAnalyseExpr rule_rhs + -- See Note [Occurrence-analyse after rule firing] + ; dump rule rule_rhs + ; return (Just (zapped_env, occ_anald_rhs, cont')) } + -- The occ_anald_rhs and cont' are all Out things + -- hence zapping the environment + + | otherwise -- No rule fires + = do { nodump -- This ensures that an empty file is written + ; return Nothing } + + where + ropts = initRuleOpts dflags + dflags = seDynFlags env + zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + + printRuleModule rule + = parens (maybe (text "BUILTIN") + (pprModuleName . moduleName) + (ruleModule rule)) + + dump rule rule_rhs + | dopt Opt_D_dump_rule_rewrites dflags + = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ruleName rule) + , text "Module:" <+> printRuleModule rule + , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) + , text "After: " <+> hang (pprCoreExpr rule_rhs) 2 + (sep $ map ppr $ drop (ruleArity rule) args) + , text "Cont: " <+> ppr call_cont ] + + | dopt Opt_D_dump_rule_firings dflags + = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ruleName rule) + <+> printRuleModule rule + + | otherwise + = return () + + nodump + | dopt Opt_D_dump_rule_rewrites dflags + = liftIO $ do + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) + + | dopt Opt_D_dump_rule_firings dflags + = liftIO $ do + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) + + | otherwise + = return () + + log_rule dflags flag hdr details + = liftIO $ do + let sty = mkDumpStyle alwaysQualify + dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ + sep [text hdr, nest 4 details] + +trySeqRules :: SimplEnv + -> OutExpr -> InExpr -- Scrutinee and RHS + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) +-- See Note [User-defined RULES for seq] +trySeqRules in_env scrut rhs cont + = do { rule_base <- getSimplRules + ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } + where + no_cast_scrut = drop_casts scrut + scrut_ty = exprType no_cast_scrut + seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b + res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b + res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b + res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty + res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty + rhs_ty = substTy in_env (exprType rhs) + rhs_rep = getRuntimeRep rhs_ty + out_args = [ TyArg { as_arg_ty = rhs_rep + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = scrut_ty + , as_hole_ty = res1_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = res2_ty } + , ValArg { as_arg = no_cast_scrut + , as_dmd = seqDmd + , as_hole_ty = res3_ty } ] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = in_env, sc_cont = cont + , sc_hole_ty = res4_ty } + + -- Lazily evaluated, so we don't do most of this + + drop_casts (Cast e _) = drop_casts e + drop_casts e = e + +{- Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + case (scrut |> co) of _ -> rhs +look for rules that match the expression + seq @t1 @t2 scrut +where scrut :: t1 + rhs :: t2 + +If you find a match, rewrite it, and apply to 'rhs'. + +Notice that we can simply drop casts on the fly here, which +makes it more likely that a rule will match. + +See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Occurrence-analyse after rule firing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After firing a rule, we occurrence-analyse the instantiated RHS before +simplifying it. Usually this doesn't make much difference, but it can +be huge. Here's an example (simplCore/should_compile/T7785) + + map f (map f (map f xs) + += -- Use build/fold form of map, twice + map f (build (\cn. foldr (mapFB c f) n + (build (\cn. foldr (mapFB c f) n xs)))) + += -- Apply fold/build rule + map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) + += -- Beta-reduce + -- Alas we have no occurrence-analysed, so we don't know + -- that c is used exactly once + map f (build (\cn. let c1 = mapFB c f in + foldr (mapFB c1 f) n xs)) + += -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) + -- We can do this because (mapFB c n) is a PAP and hence expandable + map f (build (\cn. let c1 = mapFB c n in + foldr (mapFB c (f.f)) n x)) + +This is not too bad. But now do the same with the outer map, and +we get another use of mapFB, and t can interact with /both/ remaining +mapFB calls in the above expression. This is stupid because actually +that 'c1' binding is dead. The outer map introduces another c2. If +there is a deep stack of maps we get lots of dead bindings, and lots +of redundant work as we repeatedly simplify the result of firing rules. + +The easy thing to do is simply to occurrence analyse the result of +the rule firing. Note that this occ-anals not only the RHS of the +rule, but also the function arguments, which by now are OutExprs. +E.g. + RULE f (g x) = x+1 + +Call f (g BIG) --> (\x. x+1) BIG + +The rule binders are lambda-bound and applied to the OutExpr arguments +(here BIG) which lack all internal occurrence info. + +Is this inefficient? Not really: we are about to walk over the result +of the rule firing to simplify it, so occurrence analysis is at most +a constant factor. + +Possible improvement: occ-anal the rules when putting them in the +database; and in the simplifier just occ-anal the OutExpr arguments. +But that's more complicated and the rule RHS is usually tiny; so I'm +just doing the simple thing. + +Historical note: previously we did occ-anal the rules in Rule.hs, +but failed to occ-anal the OutExpr arguments, which led to the +nasty performance problem described above. + + +Note [Optimising tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an enumeration data type: + + data Foo = A | B | C + +Then we want to transform + + case tagToEnum# x of ==> case x of + A -> e1 DEFAULT -> e1 + B -> e2 1# -> e2 + C -> e3 2# -> e3 + +thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT +alternative we retain it (remember it comes first). If not the case must +be exhaustive, and we reflect that in the transformed version by adding +a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. +See #8317. + +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that we shouldn't apply rules for a loop breaker: +doing so might give rise to an infinite loop, because a RULE is +rather like an extra equation for the function: + RULE: f (g x) y = x+y + Eqn: f a y = a-y + +But it's too drastic to disable rules for loop breakers. +Even the foldr/build rule would be disabled, because foldr +is recursive, and hence a loop breaker: + foldr k z (build g) = g k z +So it's up to the programmer: rules can cause divergence + + +************************************************************************ +* * + Rebuilding a case expression +* * +************************************************************************ + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> let y# = x# in e + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise +this idea to look for a case where we're scrutinising a variable, and we know +that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be eliminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparison operations (e.g. in (>=) for Int.Int32) + +Note [Case to let transformation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a case over a lifted type has a single alternative, and is being +used as a strict 'let' (all isDeadBinder bndrs), we may want to do +this transformation: + + case e of r ===> let r = e in ...r... + _ -> ...r... + +We treat the unlifted and lifted cases separately: + +* Unlifted case: 'e' satisfies exprOkForSpeculation + (ok-for-spec is needed to satisfy the let/app invariant). + This turns case a +# b of r -> ...r... + into let r = a +# b in ...r... + and thence .....(a +# b).... + + However, if we have + case indexArray# a i of r -> ...r... + we might like to do the same, and inline the (indexArray# a i). + But indexArray# is not okForSpeculation, so we don't build a let + in rebuildCase (lest it get floated *out*), so the inlining doesn't + happen either. Annoying. + +* Lifted case: we need to be sure that the expression is already + evaluated (exprIsHNF). If it's not already evaluated + - we risk losing exceptions, divergence or + user-specified thunk-forcing + - even if 'e' is guaranteed to converge, we don't want to + create a thunk (call by need) instead of evaluating it + right away (call by value) + + However, we can turn the case into a /strict/ let if the 'r' is + used strictly in the body. Then we won't lose divergence; and + we won't build a thunk because the let is strict. + See also Note [Case-to-let for strictly-used binders] + + NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make. + We want to turn + case (absentError "foo") of r -> ...MkT r... + into + let r = absentError "foo" in ...MkT r... + + +Note [Case-to-let for strictly-used binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have this: + case of r { _ -> ..r.. } + +where 'r' is used strictly in (..r..), we can safely transform to + let r = in ...r... + +This is a Good Thing, because 'r' might be dead (if the body just +calls error), or might be used just once (in which case it can be +inlined); or we might be able to float the let-binding up or down. +E.g. #15631 has an example. + +Note that this can change the error behaviour. For example, we might +transform + case x of { _ -> error "bad" } + --> error "bad" +which is might be puzzling if 'x' currently lambda-bound, but later gets +let-bound to (error "good"). + +Nevertheless, the paper "A semantics for imprecise exceptions" allows +this transformation. If you want to fix the evaluation order, use +'pseq'. See #8900 for an example where the loss of this +transformation bit us in practice. + +See also Note [Empty case alternatives] in GHC.Core. + +Historical notes + +There have been various earlier versions of this patch: + +* By Sept 18 the code looked like this: + || scrut_is_demanded_var scrut + + scrut_is_demanded_var :: CoreExpr -> Bool + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + + This only fired if the scrutinee was a /variable/, which seems + an unnecessary restriction. So in #15631 I relaxed it to allow + arbitrary scrutinees. Less code, less to explain -- but the change + had 0.00% effect on nofib. + +* Previously, in Jan 13 the code looked like this: + || case_bndr_evald_next rhs + + case_bndr_evald_next :: CoreExpr -> Bool + -- See Note [Case binder next] + case_bndr_evald_next (Var v) = v == case_bndr + case_bndr_evald_next (Cast e _) = case_bndr_evald_next e + case_bndr_evald_next (App e _) = case_bndr_evald_next e + case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e + case_bndr_evald_next _ = False + + This patch was part of fixing #7542. See also + Note [Eta reduction of an eval'd function] in GHC.Core.Utils.) + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: Void# -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. + + +Note [FloatBinds from constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have FloatBinds coming from the constructor wrapper +(as in Note [exprIsConApp_maybe on data constructors with wrappers]), +we cannot float past them. We'd need to float the FloatBind +together with the simplify floats, unfortunately the +simplifier doesn't have case-floats. The simplest thing we can +do is to wrap all the floats here. The next iteration of the +simplifier will take care of all these cases and lets. + +Given data T = MkT !Bool, this allows us to simplify +case $WMkT b of { MkT x -> f x } +to +case b of { b' -> f b' }. + +We could try and be more clever (like maybe wfloats only contain +let binders, so we could float them). But the need for the +extra complication is not clear. +-} + +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (increasing order) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + , not (litIsLifted lit) + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } + + | Just (in_scope', wfloats, con, ty_args, other_args) + <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + , let env0 = setInScopeSet env in_scope' + = do { tick (KnownBranch case_bndr) + ; let scaled_wfloats = map scale_float wfloats + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env0 case_bndr alts cont + Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) + `mkTyApps` ty_args + `mkApps` other_args + in simple_rhs env0 scaled_wfloats con_app bs rhs + Just (_, bs, rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args + case_bndr bs rhs cont + } + where + simple_rhs env wfloats scrut' bs rhs = + ASSERT( null bs ) + do { (floats1, env') <- simplNonRecX env case_bndr scrut' + -- scrut is a constructor application, + -- hence satisfies let/app invariant + ; (floats2, expr') <- simplExprF env' rhs cont + ; case wfloats of + [] -> return (floats1 `addFloats` floats2, expr') + _ -> return + -- See Note [FloatBinds from constructor wrappers] + ( emptyFloats env, + GHC.Core.Make.wrapFloats wfloats $ + wrapFloats (floats1 `addFloats` floats2) expr' )} + + -- This scales case floats by the multiplicity of the continuation hole (see + -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because + -- they are aliases anyway. + scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = + let + scale_id id = scaleVarBy holeScaling id + in + GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float f = f + + holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr + -- We are in the following situation + -- case[p] case[q] u of { D x -> C v } of { C x -> w } + -- And we are producing case[??] u of { D x -> w[x\v]} + -- + -- What should the multiplicity `??` be? In order to preserve the usage of + -- variables in `u`, it needs to be `pq`. + -- + -- As an illustration, consider the following + -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } + -- Where C :: A %1 -> T is linear + -- If we were to produce a case[1], like the inner case, we would get + -- case[1] of { C x -> (x, x) } + -- Which is ill-typed with respect to linearity. So it needs to be a + -- case[Many]. + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont + -- See if we can get rid of the case altogether + -- See Note [Case elimination] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + -- See Note [Case to let transformation] + | all_dead_bndrs + , doCaseToLet scrut case_bndr + = do { tick (CaseElim case_bndr) + ; (floats1, env') <- simplNonRecX env case_bndr scrut + ; (floats2, expr') <- simplExprF env' rhs cont + ; return (floats1 `addFloats` floats2, expr') } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make + | is_plain_seq + = do { mb_rule <- trySeqRules env scrut rhs cont + ; case mb_rule of + Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont + + +doCaseToLet :: OutExpr -- Scrutinee + -> InId -- Case binder + -> Bool +-- The situation is case scrut of b { DEFAULT -> body } +-- Can we transform thus? let { b = scrut } in body +doCaseToLet scrut case_bndr + | isTyCoVar case_bndr -- Respect GHC.Core + = isTyCoArg scrut -- Note [Core type and coercion invariant] + + | isUnliftedType (idType case_bndr) + = exprOkForSpeculation scrut + + | otherwise -- Scrut has a lifted type + = exprIsHNF scrut + || isStrictDmd (idDemandInfo case_bndr) + -- See Note [Case-to-let for strictly-used binders] + +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- + +reallyRebuildCase env scrut case_bndr alts cont + | not (sm_case_case (getMode env)) + = do { case_expr <- simplAlts env scrut case_bndr alts + (mkBoringStop (contHoleType cont)) + ; rebuild env case_expr cont } + + | otherwise + = do { (floats, cont') <- mkDupableCaseCont env alts cont + ; case_expr <- simplAlts (env `setInScopeFromF` floats) + scrut (scaleIdBy holeScaling case_bndr) (scaleAltsBy holeScaling alts) cont' + ; return (floats, case_expr) } + where + holeScaling = contHoleScaling cont + -- Note [Scaling in case-of-case] + +{- +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +try to eliminate uses of v in the RHSs in favour of case_bndr; that +way, there's a chance that v will now only be used once, and hence +inlined. + +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyser; see +"GHC.Core.Opt.OccurAnal" Note [Binder swap]. + +Note [knownCon occ info] +~~~~~~~~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. + +Note [Case alternative occ info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are simply reconstructing a case (the common case), we always +zap the occurrence info on the binders in the alternatives. Even +if the case binder is dead, the scrutinee is usually a variable, and *that* +can bring the case-alternative binders back to life. +See Note [Add unfolding for scrutinee] + +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + +We'd like to transform + case e of (x :: F Int) { DEFAULT -> rhs } +===> + case e `cast` co of (x'::Int) + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. Notice that Note +[Case of cast] (in OccurAnal) may then apply to the result. + +We'd also like to eliminate empty types (#13468). So if + + data Void + type instance F Bool = Void + +then we'd like to transform + case (x :: F Bool) of { _ -> error "urk" } +===> + case (x |> co) of (x' :: Void) of {} + +Nota Bene: we used to have a built-in rule for 'seq' that dropped +casts, so that + case (x |> co) of { _ -> blah } +dropped the cast; in order to improve the chances of trySeqRules +firing. But that works in the /opposite/ direction to Note [Improving +seq] so there's a danger of flip/flopping. Better to make trySeqRules +insensitive to the cast, which is now is. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) + +Note [Scaling in case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When two cases commute, if done naively, the multiplicities will be wrong: + + case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] + { (z[Many], t[Many]) -> z + } + +The multiplicities here, are correct, but if I perform a case of case: + + case u of w[1] + { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and +`y` must have multiplicities `Many` not `1`! The correct solution is to make +all the `1`-s be `Many`-s instead: + + case u of w[Many] + { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +In general, when commuting two cases, the rule has to be: + + case (case … of x[p] {…}) of y[q] { … } + ===> case … of x[p*q] { … case … of y[q] { … } } + +This is materialised, in the simplifier, by the fact that every time we simplify +case alternatives with a continuation (the surrounded case (or more!)), we must +scale the entire case we are simplifying, by a scaling factor which can be +computed in the continuation (with function `contHoleScaling`). +-} + +simplAlts :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM OutExpr -- Returns the complete simplified case expression + +simplAlts env0 scrut case_bndr alts cont' + = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr + , text "cont':" <+> ppr cont' + , text "in_scope" <+> ppr (seInScope env0) ]) + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding + env2 = modifyInScope env1 case_bndr2 + -- See Note [Case binder evaluated-ness] + + ; fam_envs <- getFamEnvs + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut + case_bndr case_bndr2 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function + + ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts + ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ + + ; let alts_ty' = contResultType cont' + -- See Note [Avoiding space leaks in OutType] + ; seqType alts_ty' `seq` + mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' } + + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") Many ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + +------------------------------------ +simplAlt :: SimplEnv + -> Maybe OutExpr -- The scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) + = ASSERT( null bndrs ) + do { let env' = addBinderUnfolding env case_bndr' + (mkOtherCon imposs_deflt_cons) + -- Record the constructors that the case-binder *can't* be. + ; rhs' <- simplExprC env' rhs cont' + ; return (DEFAULT, [], rhs') } + +simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) + = ASSERT( null bndrs ) + do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (LitAlt lit, [], rhs') } + +simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) + = do { -- See Note [Adding evaluatedness info to pattern-bound variables] + let vs_with_evals = addEvals scrut' con vs + ; (env', vs') <- simplLamBndrs env vs_with_evals + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_app :: OutExpr + con_app = mkConApp2 con inst_tys' vs' + + ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app + ; rhs' <- simplExprC env'' rhs cont' + ; return (DataAlt con, vs', rhs') } + +{- Note [Adding evaluatedness info to pattern-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +addEvals records the evaluated-ness of the bound variables of +a case pattern. This is *important*. Consider + + data T = T !Int !Int + + case x of { T a b -> T (a+1) b } + +We really must record that b is already evaluated so that we don't +go and re-evaluate it when constructing the result. +See Note [Data-con worker strictness] in GHC.Core.DataCon + +NB: simplLamBndrs preserves this eval info + +In addition to handling data constructor fields with !s, addEvals +also records the fact that the result of seq# is always in WHNF. +See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226): + + case seq# v s of + (# s', v' #) -> E + +we want the compiler to be aware that v' is in WHNF in E. + +Open problem: we don't record that v itself is in WHNF (and we can't +do it here). The right thing is to do some kind of binder-swap; +see #15226 for discussion. +-} + +addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] +-- See Note [Adding evaluatedness info to pattern-bound variables] +addEvals scrut con vs + -- Deal with seq# applications + | Just scr <- scrut + , isUnboxedTupleCon con + , [s,x] <- vs + -- Use stripNArgs rather than collectArgsTicks to avoid building + -- a list of arguments only to throw it away immediately. + , Just (Var f) <- stripNArgs 4 scr + , Just SeqOp <- isPrimOpId_maybe f + , let x' = zapIdOccInfoAndSetEvald MarkedStrict x + = [s, x'] + + -- Deal with banged datacon fields +addEvals _scrut con vs = go vs the_strs + where + the_strs = dataConRepStrictness con + + go [] [] = [] + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs + go _ _ = pprPanic "Simplify.addEvals" + (ppr con $$ + ppr vs $$ + ppr_with_length (map strdisp the_strs) $$ + ppr_with_length (dataConRepArgTys con) $$ + ppr_with_length (dataConRepStrictness con)) + where + ppr_with_length list + = ppr list <+> parens (text "length =" <+> ppr (length list)) + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" + +zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id +zapIdOccInfoAndSetEvald str v = + setCaseBndrEvald str $ -- Add eval'dness info + zapIdOccInfo v -- And kill occ info; + -- see Note [Case alternative occ info] + +addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv +addAltUnfoldings env scrut case_bndr con_app + = do { let con_app_unf = mk_simple_unf con_app + env1 = addBinderUnfolding env case_bndr con_app_unf + + -- See Note [Add unfolding for scrutinee] + env2 | Many <- idMult case_bndr = case scrut of + Just (Var v) -> addBinderUnfolding env1 v con_app_unf + Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ + mk_simple_unf (Cast con_app (mkSymCo co)) + _ -> env1 + | otherwise = env1 + + ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) + ; return env2 } + where + mk_simple_unf = mkSimpleUnfolding (seDynFlags env) + +addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = WARN( not (eqType (idType bndr) (exprType tmpl)), + ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise + = modifyInScope env (bndr `setIdUnfolding` unf) + +zapBndrOccInfo :: Bool -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id + +{- Note [Case binder evaluated-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin on a (OtherCon []) unfolding to the case-binder of a Case, +even though it'll be over-ridden in every case alternative with a more +informative unfolding. Why? Because suppose a later, less clever, pass +simply replaces all occurrences of the case binder with the binder itself; +then Lint may complain about the let/app invariant. Example + case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in .... + ; K -> blah } + +The let/app invariant requires that y is evaluated in the call to +reallyUnsafePtrEq#, which it is. But we still want that to be true if we +propagate binders to occurrences. + +This showed up in #13027. + +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccurAnal has got rid of all such occurrences +See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimination -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +Exactly the same issue arises in GHC.Core.Opt.SpecConstr; +see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr + +HOWEVER, given + case x of y { Just a -> r1; Nothing -> r2 } +we do not want to add the unfolding x -> y to 'x', which might seem cool, +since 'y' itself has different unfoldings in r1 and r2. Reason: if we +did that, we'd have to zap y's deadness info and that is a very useful +piece of information. + +So instead we add the unfolding x -> Just a, and x -> Nothing in the +respective RHSs. + +Since this transformation is tantamount to a binder swap, the same caveat as in +Note [Suppressing binder-swaps on linear case] in OccurAnal apply. + + +************************************************************************ +* * +\subsection{Known constructor} +* * +************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. +-} + +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont + = do { (floats1, env1) <- bind_args env bs dc_args + ; (floats2, env2) <- bind_case_bndr env1 + ; (floats3, expr') <- simplExprF env2 rhs cont + ; case dc_floats of + [] -> + return (floats1 `addFloats` floats2 `addFloats` floats3, expr') + _ -> + return ( emptyFloats env + -- See Note [FloatBinds from constructor wrappers] + , GHC.Core.Make.wrapFloats dc_floats $ + wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } + where + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return (emptyFloats env', env') + + bind_args env' (b:bs') (Type ty : args) + = ASSERT( isTyVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (Coercion co : args) + = ASSERT( isCoVar b ) + bind_args (extendCvSubst env' b co) bs' args + + bind_args env' (b:bs') (arg : args) + = ASSERT( isId b ) + do { let b' = zap_occ b + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [knownCon occ info] + ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let/app invariant + ; (floats2, env3) <- bind_args env2 bs' args + ; return (floats1 `addFloats` floats2, env3) } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return (emptyFloats env, env) + | exprIsTrivial scrut = return (emptyFloats env + , extendIdSubst env bndr (DoneEx scrut Nothing)) + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are already OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifier might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr _ cont + = WARN( True, text "missingAlt" <+> ppr case_bndr ) + -- See Note [Avoiding space leaks in OutType] + let cont_ty = contResultType cont + in seqType cont_ty `seq` + return (emptyFloats env, mkImpossibleExpr cont_ty) + +{- +************************************************************************ +* * +\subsection{Duplicating continuations} +* * +************************************************************************ + +Consider + let x* = case e of { True -> e1; False -> e2 } + in b +where x* is a strict binding. Then mkDupableCont will be given +the continuation + case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop +and will split it into + dupable: case [] of { True -> $j1; False -> $j2 } ; stop + join floats: $j1 = e1, $j2 = e2 + non_dupable: let x* = [] in b; stop + +Putting this back together would give + let x* = let { $j1 = e1; $j2 = e2 } in + case e of { True -> $j1; False -> $j2 } + in b +(Of course we only do this if 'e' wants to duplicate that continuation.) +Note how important it is that the new join points wrap around the +inner expression, and not around the whole thing. + +In contrast, any let-bindings introduced by mkDupableCont can wrap +around the entire thing. + +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away. See #4930. +-} + +-------------------- +mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, SimplCont) +mkDupableCaseCont env alts cont + | altsWouldDup alts = mkDupableCont env cont + | otherwise = return (emptyFloats env, cont) + +altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative +altsWouldDup [] = False -- See Note [Bottom alternatives] +altsWouldDup [_] = False +altsWouldDup (alt:alts) + | is_bot_alt alt = altsWouldDup alts + | otherwise = not (all is_bot_alt alts) + where + is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs + +------------------------- +mkDupableCont :: SimplEnv + -> SimplCont + -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with + -- extra let/join-floats and in-scope variables + , SimplCont) -- dup_cont: duplicable continuation +mkDupableCont env cont + = mkDupableContWithDmds env (repeat topDmd) cont + +mkDupableContWithDmds + :: SimplEnv -> [Demand] -- Demands on arguments; always infinite + -> SimplCont -> SimplM ( SimplFloats, SimplCont) + +mkDupableContWithDmds env _ cont + | contIsDupable cont + = return (emptyFloats env, cont) + +mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn + +mkDupableContWithDmds env dmds (CastIt ty cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, CastIt ty cont') } + +-- Duplicating ticks for now, not sure if this is good or not +mkDupableContWithDmds env dmds (TickIt t cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, TickIt t cont') } + +mkDupableContWithDmds env _ + (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs + , sc_body = body, sc_env = se, sc_cont = cont}) +-- See Note [Duplicating StrictBind] +-- K[ let x = <> in b ] --> join j x = K[ b ] +-- j <> + = do { let sb_env = se `setInScopeFromE` env + ; (sb_env1, bndr') <- simplBinder sb_env bndr + ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont + -- No need to use mkDupableCont before simplLam; we + -- use cont once here, and then share the result if necessary + + ; let join_body = wrapFloats floats1 join_inner + res_ty = contResultType cont + + ; mkDupableStrictBind env bndr' join_body res_ty } + +mkDupableContWithDmds env _ + (StrictArg { sc_fun = fun, sc_cont = cont + , sc_fun_ty = fun_ty }) + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + | isNothing (isDataConId_maybe (ai_fun fun)) + , thumbsUpPlanA cont -- See point (3) of Note [Duplicating join points] + = -- Use Plan A of Note [Duplicating StrictArg] + do { let (_ : dmds) = ai_dmds fun + ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + -- Use the demands from the function to add the right + -- demand info on any bindings we make for further args + ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env)) + (ai_args fun) + ; return ( foldl' addLetFloats floats1 floats_s + , StrictArg { sc_fun = fun { ai_args = args' } + , sc_cont = cont' + , sc_fun_ty = fun_ty + , sc_dup = OkToDup} ) } + + | otherwise + = -- Use Plan B of Note [Duplicating StrictArg] + -- K[ f a b <> ] --> join j x = K[ f a b x ] + -- j <> + do { let rhs_ty = contResultType cont + (m,arg_ty,_) = splitFunTy fun_ty + ; arg_bndr <- newId (fsLit "arg") m arg_ty + ; let env' = env `addNewInScopeIds` [arg_bndr] + ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont + ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } + where + thumbsUpPlanA (StrictArg {}) = False + thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (Select {}) = True + thumbsUpPlanA (StrictBind {}) = True + thumbsUpPlanA (Stop {}) = True + +mkDupableContWithDmds env dmds + (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, ApplyToTy { sc_cont = cont' + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env dmds + (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se + , sc_cont = cont, sc_hole_ty = hole_ty }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { let (dmd:_) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + ; let env' = env `setInScopeFromF` floats1 + ; (_, se', arg') <- simplArg env' dup se arg + ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel dmd (fsLit "karg") arg' + ; let all_floats = floats1 `addLetFloats` let_floats2 + ; return ( all_floats + , ApplyToVal { sc_arg = arg'' + , sc_env = se' `setInScopeFromF` all_floats + -- Ensure that sc_env includes the free vars of + -- arg'' in its in-scope set, even if makeTrivial + -- has turned arg'' into a fresh variable + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup, sc_cont = cont' + , sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env _ + (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { tick (CaseOfCase case_bndr) + ; (floats, alt_cont) <- mkDupableCaseCont env alts cont + -- NB: We call mkDupableCaseCont here to make cont duplicable + -- (if necessary, depending on the number of alts) + -- And this is important: see Note [Fusing case continuations] + + ; let alt_env = se `setInScopeFromF` floats + ; let cont_scaling = contHoleScaling cont + -- See Note [Scaling in case-of-case] + ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts) + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr') + emptyJoinFloats alts' + + ; let all_floats = floats `addJoinFloats` join_floats + -- Note [Duplicated env] + ; return (all_floats + , Select { sc_dup = OkToDup + , sc_bndr = case_bndr' + , sc_alts = alts'' + , sc_env = zapSubstEnv se `setInScopeFromF` all_floats + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_cont = mkBoringStop (contResultType cont) } ) } + +mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType + -> SimplM (SimplFloats, SimplCont) +mkDupableStrictBind env arg_bndr join_rhs res_ty + | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points] + = return (emptyFloats env + , StrictBind { sc_bndr = arg_bndr, sc_bndrs = [] + , sc_body = join_rhs + , sc_env = zapSubstEnv env + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup + , sc_cont = mkBoringStop res_ty } ) + | otherwise + = do { join_bndr <- newJoinId [arg_bndr] res_ty + ; let arg_info = ArgInfo { ai_fun = join_bndr + , ai_rules = Nothing, ai_args = [] + , ai_encl = False, ai_dmds = repeat topDmd + , ai_discs = repeat 0 } + ; return ( addJoinFloats (emptyFloats env) $ + unitJoinFloat $ + NonRec join_bndr $ + Lam (setOneShotLambda arg_bndr) join_rhs + , StrictArg { sc_dup = OkToDup + , sc_fun = arg_info + , sc_fun_ty = idType join_bndr + , sc_cont = mkBoringStop res_ty + } ) } + +mkDupableAlt :: Platform -> OutId + -> JoinFloats -> OutAlt + -> SimplM (JoinFloats, OutAlt) +mkDupableAlt _platform case_bndr jfloats (con, bndrs', rhs') + | exprIsTrivial rhs' -- See point (2) of Note [Duplicating join points] + = return (jfloats, (con, bndrs', rhs')) + + | otherwise + = do { let rhs_ty' = exprType rhs' + scrut_ty = idType case_bndr + case_bndr_w_unf + = case con of + DEFAULT -> case_bndr + DataAlt dc -> setIdUnfolding case_bndr unf + where + -- See Note [Case binders and join points] + unf = mkInlineUnfolding rhs + rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' + + LitAlt {} -> WARN( True, text "mkDupableAlt" + <+> ppr case_bndr <+> ppr con ) + case_bndr + -- The case binder is alive but trivial, so why has + -- it not been substituted away? + + final_bndrs' + | isDeadBinder case_bndr = filter abstract_over bndrs' + | otherwise = bndrs' ++ [case_bndr_w_unf] + + abstract_over bndr + | isTyVar bndr = True -- Abstract over all type variables just in case + | otherwise = not (isDeadBinder bndr) + -- The deadness info on the new Ids is preserved by simplBinders + final_args = varsToCoreExprs final_bndrs' + -- Note [Join point abstraction] + + -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + join_rhs = mkLams really_final_bndrs rhs' + + ; join_bndr <- newJoinId final_bndrs' rhs_ty' + + ; let join_call = mkApps (Var join_bndr) final_args + alt' = (con, bndrs', join_call) + + ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) + , alt') } + -- See Note [Duplicated env] + +{- +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in GHC.Core.Opt.WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StrictBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See #4957 a fuller example. + +Note [Duplicating join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IN #19996 we discovered that we want to be really careful about +inlining join points. Consider + case (join $j x = K f x ) + (in case v of ) + ( p1 -> $j x1 ) of + ( p2 -> $j x2 ) + ( p3 -> $j x3 ) + K g y -> blah[g,y] + +Here the join-point RHS is very small, just a constructor +application (K x y). So we might inline it to get + case (case v of ) + ( p1 -> K f x1 ) of + ( p2 -> K f x2 ) + ( p3 -> K f x3 ) + K g y -> blah[g,y] + +But now we have to make `blah` into a join point, /abstracted/ +over `g` and `y`. In contrast, if we /don't/ inline $j we +don't need a join point for `blah` and we'll get + join $j x = let g=f, y=x in blah[g,y] + in case v of + p1 -> $j x1 + p2 -> $j x2 + p3 -> $j x3 + +This can make a /massive/ difference, because `blah` can see +what `f` is, instead of lambda-abstracting over it. + +To achieve this: + +1. Do not postInlineUnconditionally a join point, until the Final + phase. (The Final phase is still quite early, so we might consider + delaying still more.) + +2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for + all alternatives, except for exprIsTrival RHSs. Previously we used + exprIsDupable. This generates a lot more join points, but makes + them much more case-of-case friendly. + + It is definitely worth checking for exprIsTrivial, otherwise we get + an extra Simplifier iteration, because it is inlined in the next + round. + +3. By the same token we want to use Plan B in + Note [Duplicating StrictArg] when the RHS of the new join point + is a data constructor application. That same Note explains why we + want Plan A when the RHS of the new join point would be a + non-data-constructor application + +4. You might worry that $j will be inlined by the call-site inliner, + but it won't because the call-site context for a join is usually + extremely boring (the arguments come from the pattern match). + And if not, then perhaps inlining it would be a good idea. + + You might also wonder if we get UnfWhen, because the RHS of the + join point is no bigger than the call. But in the cases we care + about it will be a little bigger, because of that free `f` in + $j x = K f x + So for now we don't do anything special in callSiteInline + +There is a bit of tension between (2) and (3). Do we want to retain +the join point only when the RHS is +* a constructor application? or +* just non-trivial? +Currently, a bit ad-hoc, but we definitely want to retain the join +point for data constructors in mkDupalbleALt (point 2); that is the +whole point of #19996 described above. + +Historical Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this entire Note is now irrelevant. In Jun 21 we stopped +adding unfoldings to lambda binders (#17530). It was always a +hack and bit us in multiple small and not-so-small ways + +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutinises the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(a stable unfolding) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have a zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Funky mkLamTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkLamTypes. If the constructor has existentials +it's possible that the join point will be abstracted over +type variables as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with making a StrictArg continuation duplicable has turned out +to be one of the trickiest corners of the simplifier, giving rise +to several cases in which the simplier expanded the program's size +*exponentially*. They include + #13253 exponential inlining + #10421 ditto + #18140 strict constructors + #18282 another nested-function call case + +Suppose we have a call + f e1 (case x of { True -> r1; False -> r2 }) e3 +and f is strict in its second argument. Then we end up in +mkDupableCont with a StrictArg continuation for (f e1 <> e3). +There are two ways to make it duplicable. + +* Plan A: move the entire call inwards, being careful not + to duplicate e1 or e3, thus: + let a1 = e1 + a3 = e3 + in case x of { True -> f a1 r1 a3 + ; False -> f a1 r2 a3 } + +* Plan B: make a join point: + join $j x = f e1 x e3 + in case x of { True -> jump $j r1 + ; False -> jump $j r2 } + + Notice that Plan B is very like the way we handle strict bindings; + see Note [Duplicating StrictBind]. And Plan B is exactly what we'd + get if we turned use a case expression to evaluate the strict arg: + + case (case x of { True -> r1; False -> r2 }) of + r -> f e1 r e3 + + So, looking at Note [Duplicating join points], we also want Plan B + when `f` is a data constructor. + +Plan A is often good. Here's an example from #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') + +If we pushed the entire call for 'go' inside the case, we get +call-pattern specialisation for 'go', which is *crucial* for +this particular program. + +Here is another example. + && E (case x of { T -> F; F -> T }) + +Pushing the call inward (being careful not to duplicate E) + let a = E + in case x of { T -> && a F; F -> && a T } + +and now the (&& a F) etc can optimise. Moreover there might +be a RULE for the function that can fire when it "sees" the +particular case alterantive. + +But Plan A can have terrible, terrible behaviour. Here is a classic +case: + f (f (f (f (f True)))) + +Suppose f is strict, and has a body that is small enough to inline. +The innermost call inlines (seeing the True) to give + f (f (f (f (case v of { True -> e1; False -> e2 })))) + +Now, suppose we naively push the entire continuation into both +case branches (it doesn't look large, just f.f.f.f). We get + case v of + True -> f (f (f (f e1))) + False -> f (f (f (f e2))) + +And now the process repeats, so we end up with an exponentially large +number of copies of f. No good! + +CONCLUSION: we want Plan A in general, but do Plan B is there a +danger of this nested call behaviour. The function that decides +this is called thumbsUpPlanA. + +Note [Keeping demand info in StrictArg Plan A] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Following on from Note [Duplicating StrictArg], another common code +pattern that can go bad is this: + f (case x1 of { T -> F; F -> T }) + (case x2 of { T -> F; F -> T }) + ...etc... +when f is strict in all its arguments. (It might, for example, be a +strict data constructor whose wrapper has not yet been inlined.) + +We use Plan A (because there is no nesting) giving + let a2 = case x2 of ... + a3 = case x3 of ... + in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } + +Now we must be careful! a2 and a3 are small, and the OneOcc code in +postInlineUnconditionally may inline them both at both sites; see Note +Note [Inline small things to avoid creating a thunk] in +Simplify.Utils. But if we do inline them, the entire process will +repeat -- back to exponential behaviour. + +So we are careful to keep the demand-info on a2 and a3. Then they'll +be /strict/ let-bindings, which will be dealt with by StrictBind. +That's why contIsDupableWithDmds is careful to propagage demand +info to the auxiliary bindings it creates. See the Demand argument +to makeTrivial. + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a StrictBind duplicable in a very similar way to +that for case expressions. After all, + let x* = e in b is similar to case e of x -> b + +So we potentially make a join-point for the body, thus: + let x = <> in b ==> join j x = b + in j <> + +Just like StrictArg in fact -- and indeed they share code. + +Note [Join point abstraction] Historical note +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This note is now historical, describing how (in the past) we used +to add a void argument to nullary join points. But now that "join +point" is not a fuzzy concept but a formal syntactic construct (as +distinguished by the JoinId constructor of IdDetails), each of these +concerns is handled separately, with no need for a vestigial extra +argument. + +Join points always have at least one value argument, +for several reasons + +* If we try to lift a primitive-typed something out + for let-binding-purposes, we will *caseify* it (!), + with potentially-disastrous strictness results. So + instead we turn it into a function: \v -> e + where v::Void#. The value passed to this function is void, + which generates (almost) no code. + +* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now + we make the join point into a function whenever used_bndrs' + is empty. This makes the join-point more CPR friendly. + Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + + Now CPR doesn't w/w j because it's a thunk, so + that means that the enclosing function can't w/w either, + which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +* Let-no-escape. We want a join point to turn into a let-no-escape + so that it is implemented as a jump, and one of the conditions + for LNE is that it's not updatable. In CoreToStg, see + Note [What is a non-escaping let] + +* Floating. Since a join point will be entered once, no sharing is + gained by floating out, but something might be lost by doing + so because it might be allocated. + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + + + +************************************************************************ +* * + Unfoldings +* * +************************************************************************ +-} + +simplLetUnfolding :: SimplEnv-> TopLevelFlag + -> MaybeJoinCont + -> InId + -> OutExpr -> OutType -> ArityType + -> Unfolding -> SimplM Unfolding +simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf + | isStableUnfolding unf + = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf + | isExitJoinId id + = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify + | otherwise + = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs + +------------------- +mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource + -> InId -> OutExpr -> SimplM Unfolding +mkLetUnfolding !dflags top_lvl src id new_rhs + = is_bottoming `seq` -- See Note [Force bottoming field] + return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In GHC.Iface.Tidy we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. + where + -- Might as well force this, profiles indicate up to 0.5MB of thunks + -- just from this site. + !is_top_lvl = isTopLevel top_lvl + -- See Note [Force bottoming field] + !is_bottoming = isDeadEndId id + +------------------- +simplStableUnfolding :: SimplEnv -> TopLevelFlag + -> MaybeJoinCont -- Just k => a join point with continuation k + -> InId + -> OutType + -> ArityType -- Used to eta expand, but only for non-join-points + -> Unfolding + ->SimplM Unfolding +-- Note [Setting the new unfolding] +simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf + = case unf of + NoUnfolding -> return unf + BootUnfolding -> return unf + OtherCon {} -> return unf + + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders unf_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- case mb_cont of + Just cont -> -- Binder is a join point + -- See Note [Rules and unfolding for join points] + simplJoinRhs unf_env id expr cont + Nothing -> -- Binder is not a join point + do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty) + ; return (eta_expand expr') } + ; case guide of + UnfWhen { ug_arity = arity + , ug_unsat_ok = sat_ok + , ug_boring_ok = boring_ok + } + -- Happens for INLINE things + -- Really important to force new_boring_ok as otherwise + -- `ug_boring_ok` is a thunk chain of + -- inlineBoringExprOk expr0 + -- || inlineBoringExprOk expr1 || ... + -- See #20134 + -> let !new_boring_ok = boring_ok || inlineBoringOk expr' + guide' = + UnfWhen { ug_arity = arity + , ug_unsat_ok = sat_ok + , ug_boring_ok = new_boring_ok + + } + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. + -- A test case is #4138 + -- But retain a previous boring_ok of True; e.g. see + -- the way it is set in calcUnfoldingGuidanceWithArity + in return (mkCoreUnfolding src is_top_lvl expr' guide') + -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold + + _other -- Happens for INLINABLE things + -> mkLetUnfolding dflags top_lvl src id expr' } + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + + | otherwise -> return noUnfolding -- Discard unstable unfoldings + where + dflags = seDynFlags env + -- Forcing this can save about 0.5MB of max residency and the result + -- is small and easy to compute so might as well force it. + !is_top_lvl = isTopLevel top_lvl + act = idInlineActivation id + unf_env = updMode (updModeForStableUnfoldings act) env + -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils + + -- See Note [Eta-expand stable unfoldings] + eta_expand expr + | not eta_on = expr + | exprIsTrivial expr = expr + | otherwise = etaExpandAT id_arity expr + eta_on = sm_eta_expand (getMode env) + +{- Note [Eta-expand stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For INLINE/INLINABLE things (which get stable unfoldings) there's a danger +of getting + f :: Int -> Int -> Int -> Blah + [ Arity = 3 -- Good arity + , Unf=Stable (\xy. blah) -- Less good arity, only 2 + f = \pqr. e + +This can happen because f's RHS is optimised more vigorously than +its stable unfolding. Now suppose we have a call + g = f x +Because f has arity=3, g will have arity=2. But if we inline f (using +its stable unfolding) g's arity will reduce to 1, because +hasn't been optimised yet. This happened in the 'parsec' library, +for Text.Pasec.Char.string. + +Generally, if we know that 'f' has arity N, it seems sensible to +eta-expand the stable unfolding to arity N too. Simple and consistent. + +Wrinkles +* Don't eta-expand a trivial expr, else each pass will eta-reduce it, + and then eta-expand again. See Note [Do not eta-expand trivial expressions] + in GHC.Core.Opt.Simplify.Utils. +* Don't eta-expand join points; see Note [Do not eta-expand join points] + in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point + case (mb_cont = Just _) doesn't use eta_expand. + +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's a stable unfolding on a loop breaker (which happens for +INLINABLE), we hang on to the inlining. It's pretty dodgy, but the +user did say 'INLINE'. May need to revisit this choice. + +************************************************************************ +* * + Rules +* * +************************************************************************ + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" +-} + +addBndrRules :: SimplEnv -> InBndr -> OutBndr + -> MaybeJoinCont -- Just k for a join point binder + -- Nothing otherwise + -> SimplM (SimplEnv, OutBndr) +-- Rules are added back into the bin +addBndrRules env in_id out_id mb_cont + | null old_rules + = return (env, out_id) + | otherwise + = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont + ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules + ; return (modifyInScope env final_id, final_id) } + where + old_rules = ruleInfoRules (idSpecialisation in_id) + +simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] + -> MaybeJoinCont -> SimplM [CoreRule] +simplRules env mb_new_id rules mb_cont + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rhs_ty = substTy env' (exprType rhs) + rhs_cont = case mb_cont of -- See Note [Rules and unfolding for join points] + Nothing -> mkBoringStop rhs_ty + Just cont -> ASSERT2( join_ok, bad_join_msg ) + cont + rule_env = updMode updModeForRules env' + fn_name' = case mb_new_id of + Just id -> idName id + Nothing -> fn_name + + -- join_ok is an assertion check that the join-arity of the + -- binder matches that of the rule, so that pushing the + -- continuation into the RHS makes sense + join_ok = case mb_new_id of + Just id | Just join_arity <- isJoinId_maybe id + -> length args == join_arity + _ -> False + bad_join_msg = vcat [ ppr mb_new_id, ppr rule + , ppr (fmap isJoinId_maybe mb_new_id) ] + + ; args' <- mapM (simplExpr rule_env) args + ; rhs' <- simplExprC rule_env rhs rhs_cont + ; return (rule { ru_bndrs = bndrs' + , ru_fn = fn_name' + , ru_args = args' + , ru_rhs = rhs' }) } diff --git a/GHC/Core/Opt/Simplify/Env.hs b/GHC/Core/Opt/Simplify/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Env.hs @@ -0,0 +1,1021 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Simplify.Env ( + -- * The simplifier mode + setMode, getMode, updMode, seDynFlags, + + -- * Environments + SimplEnv(..), pprSimplEnv, -- Temp not abstract + mkSimplEnv, extendIdSubst, + extendTvSubst, extendCvSubst, + zapSubstEnv, setSubstEnv, + getInScope, setInScopeFromE, setInScopeFromF, + setInScopeSet, modifyInScope, addNewInScopeIds, + getSimplRules, + + -- * Substitution results + SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, + + -- * Simplifying 'Id' binders + simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, + simplBinder, simplBinders, + substTy, substTyVar, getTCvSubst, + substCo, substCoVar, + + -- * Floats + SimplFloats(..), emptyFloats, mkRecFloats, + mkFloatBind, addLetFloats, addJoinFloats, addFloats, + extendFloats, wrapFloats, + doFloatFromRhs, getTopFloatBinds, + + -- * LetFloats + LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, + addLetFlts, mapLetFloats, + + -- * JoinFloats + JoinFloat, JoinFloats, emptyJoinFloats, + wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Monad ( SimplMode(..) ) +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Multiplicity ( scaleScaled ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Data.OrdList +import GHC.Types.Id as Id +import GHC.Core.Make ( mkWildValBinder ) +import GHC.Driver.Session ( DynFlags ) +import GHC.Builtin.Types +import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) +import qualified GHC.Core.Type as Type +import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) +import qualified GHC.Core.Coercion as Coercion +import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Types.Basic +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Unique.FM ( pprUniqFM ) + +import Data.List (mapAccumL) + +{- +************************************************************************ +* * +\subsubsection{The @SimplEnv@ type} +* * +************************************************************************ +-} + +data SimplEnv + = SimplEnv { + ----------- Static part of the environment ----------- + -- Static in the sense of lexically scoped, + -- wrt the original expression + + seMode :: SimplMode + + -- The current substitution + , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType + , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion + , seIdSubst :: SimplIdSubst -- InId |--> OutExpr + + ----------- Dynamic part of the environment ----------- + -- Dynamic in the sense of describing the setup where + -- the expression finally ends up + + -- The current set of in-scope variables + -- They are all OutVars, and all bound in this module + , seInScope :: InScopeSet -- OutVars only + } + +data SimplFloats + = SimplFloats + { -- Ordinary let bindings + sfLetFloats :: LetFloats + -- See Note [LetFloats] + + -- Join points + , sfJoinFloats :: JoinFloats + -- Handled separately; they don't go very far + -- We consider these to be /inside/ sfLetFloats + -- because join points can refer to ordinary bindings, + -- but not vice versa + + -- Includes all variables bound by sfLetFloats and + -- sfJoinFloats, plus at least whatever is in scope where + -- these bindings land up. + , sfInScope :: InScopeSet -- All OutVars + } + +instance Outputable SimplFloats where + ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) + = text "SimplFloats" + <+> braces (vcat [ text "lets: " <+> ppr lf + , text "joins:" <+> ppr jf + , text "in_scope:" <+> ppr is ]) + +emptyFloats :: SimplEnv -> SimplFloats +emptyFloats env + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = emptyJoinFloats + , sfInScope = seInScope env } + +pprSimplEnv :: SimplEnv -> SDoc +-- Used for debugging; selective +pprSimplEnv env + = vcat [text "TvSubst:" <+> ppr (seTvSubst env), + text "CvSubst:" <+> ppr (seCvSubst env), + text "IdSubst:" <+> id_subst_doc, + text "InScope:" <+> in_scope_vars_doc + ] + where + id_subst_doc = pprUniqFM ppr (seIdSubst env) + in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) + (vcat . map ppr_one) + ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) + | otherwise = ppr v + +type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr + -- See Note [Extending the Subst] in GHC.Core.Subst + +-- | A substitution result. +data SimplSR + = DoneEx OutExpr (Maybe JoinArity) + -- If x :-> DoneEx e ja is in the SimplIdSubst + -- then replace occurrences of x by e + -- and ja = Just a <=> x is a join-point of arity a + -- See Note [Join arity in SimplIdSubst] + + + | DoneId OutId + -- If x :-> DoneId v is in the SimplIdSubst + -- then replace occurrences of x by v + -- and v is a join-point of arity a + -- <=> x is a join-point of arity a + + | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv + SimplIdSubst + InExpr + -- If x :-> ContEx tv cv id e is in the SimplISubst + -- then replace occurrences of x by (subst (tv,cv,id) e) + +instance Outputable SimplSR where + ppr (DoneId v) = text "DoneId" <+> ppr v + ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e + where + pp_mj = case mj of + Nothing -> empty + Just n -> parens (int n) + + ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, + ppr (filter_env tv), ppr (filter_env id) -}] + -- where + -- fvs = exprFreeVars e + -- filter_env env = filterVarEnv_Directly keep env + -- keep uniq _ = uniq `elemUFM_Directly` fvs + +{- +Note [SimplEnv invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +seInScope: + The in-scope part of Subst includes *all* in-scope TyVars and Ids + The elements of the set may have better IdInfo than the + occurrences of in-scope Ids, and (more important) they will + have a correctly-substituted type. So we use a lookup in this + set to replace occurrences + + The Ids in the InScopeSet are replete with their Rules, + and as we gather info about the unfolding of an Id, we replace + it in the in-scope set. + + The in-scope set is actually a mapping OutVar -> OutVar, and + in case expressions we sometimes bind + +seIdSubst: + The substitution is *apply-once* only, because InIds and OutIds + can overlap. + For example, we generally omit mappings + a77 -> a77 + from the substitution, when we decide not to clone a77, but it's quite + legitimate to put the mapping in the substitution anyway. + + Furthermore, consider + let x = case k of I# x77 -> ... in + let y = case k of I# x77 -> ... in ... + and suppose the body is strict in both x and y. Then the simplifier + will pull the first (case k) to the top; so the second (case k) will + cancel out, mapping x77 to, well, x77! But one is an in-Id and the + other is an out-Id. + + Of course, the substitution *must* applied! Things in its domain + simply aren't necessarily bound in the result. + +* substId adds a binding (DoneId new_id) to the substitution if + the Id's unique has changed + + Note, though that the substitution isn't necessarily extended + if the type of the Id changes. Why not? Because of the next point: + +* We *always, always* finish by looking up in the in-scope set + any variable that doesn't get a DoneEx or DoneVar hit in the substitution. + Reason: so that we never finish up with a "old" Id in the result. + An old Id might point to an old unfolding and so on... which gives a space + leak. + + [The DoneEx and DoneVar hits map to "new" stuff.] + +* It follows that substExpr must not do a no-op if the substitution is empty. + substType is free to do so, however. + +* When we come to a let-binding (say) we generate new IdInfo, including an + unfolding, attach it to the binder, and add this newly adorned binder to + the in-scope set. So all subsequent occurrences of the binder will get + mapped to the full-adorned binder, which is also the one put in the + binding site. + +* The in-scope "set" usually maps x->x; we use it simply for its domain. + But sometimes we have two in-scope Ids that are synomyms, and should + map to the same target: x->x, y->x. Notably: + case y of x { ... } + That's why the "set" is actually a VarEnv Var + +Note [Join arity in SimplIdSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to remember which incoming variables are join points: the occurrences +may not be marked correctly yet, and we're in change of propagating the change if +OccurAnal makes something a join point). + +Normally the in-scope set is where we keep the latest information, but +the in-scope set tracks only OutVars; if a binding is unconditionally +inlined (via DoneEx), it never makes it into the in-scope set, and we +need to know at the occurrence site that the variable is a join point +so that we know to drop the context. Thus we remember which join +points we're substituting. -} + +mkSimplEnv :: SimplMode -> SimplEnv +mkSimplEnv mode + = SimplEnv { seMode = mode + , seInScope = init_in_scope + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv } + -- The top level "enclosing CC" is "SUBSUMED". + +init_in_scope :: InScopeSet +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder Many unitTy)) + -- See Note [WildCard binders] + +{- +Note [WildCard binders] +~~~~~~~~~~~~~~~~~~~~~~~ +The program to be simplified may have wild binders + case e of wild { p -> ... } +We want to *rename* them away, so that there are no +occurrences of 'wild-id' (with wildCardKey). The easy +way to do that is to start of with a representative +Id in the in-scope set + +There can be *occurrences* of wild-id. For example, +GHC.Core.Make.mkCoreApp transforms + e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } +This is ok provided 'wild' isn't free in 'e', and that's the delicate +thing. Generally, you want to run the simplifier to get rid of the +wild-ids before doing much else. + +It's a very dark corner of GHC. Maybe it should be cleaned up. +-} + +getMode :: SimplEnv -> SimplMode +getMode env = seMode env + +seDynFlags :: SimplEnv -> DynFlags +seDynFlags env = sm_dflags (seMode env) + +setMode :: SimplMode -> SimplEnv -> SimplEnv +setMode mode env = env { seMode = mode } + +updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv +updMode upd env = env { seMode = upd (seMode env) } + +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = ASSERT2( isId var && not (isCoVar var), ppr var ) + env { seIdSubst = extendVarEnv subst var res } + +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res + = ASSERT2( isTyVar var, ppr var $$ ppr res ) + env {seTvSubst = extendVarEnv tsubst var res} + +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co + = ASSERT( isCoVar var ) + env {seCvSubst = extendVarEnv csubst var co} + +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env + +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} + +setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv +-- See Note [Setting the right in-scope set] +setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } + +setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv +setInScopeFromF env floats = env { seInScope = sfInScope floats } + +addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv + -- The new Ids are guaranteed to be freshly allocated +addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs + = env { seInScope = in_scope `extendInScopeSetList` vs, + seIdSubst = id_subst `delVarEnvList` vs } + -- Why delete? Consider + -- let x = a*b in (x, \x -> x+3) + -- We add [x |-> a*b] to the substitution, but we must + -- _delete_ it from the substitution when going inside + -- the (\x -> ...)! + +modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv +-- The variable should already be in scope, but +-- replace the existing version with this new one +-- which has more information +modifyInScope env@(SimplEnv {seInScope = in_scope}) v + = env {seInScope = extendInScopeSet in_scope v} + +{- Note [Setting the right in-scope set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + \x. (let x = e in b) arg[x] +where the let shadows the lambda. Really this means something like + \x1. (let x2 = e in b) arg[x1] + +- When we capture the 'arg' in an ApplyToVal continuation, we capture + the environment, which says what 'x' is bound to, namely x1 + +- Then that continuation gets pushed under the let + +- Finally we simplify 'arg'. We want + - the static, lexical environment binding x :-> x1 + - the in-scopeset from "here", under the 'let' which includes + both x1 and x2 + +It's important to have the right in-scope set, else we may rename a +variable to one that is already in scope. So we must pick up the +in-scope set from "here", but otherwise use the environment we +captured along with 'arg'. This transfer of in-scope set is done by +setInScopeFromE. +-} + +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} + +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } + +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e + +{- +************************************************************************ +* * +\subsection{LetFloats} +* * +************************************************************************ + +Note [LetFloats] +~~~~~~~~~~~~~~~~ +The LetFloats is a bunch of bindings, classified by a FloatFlag. + +* All of them satisfy the let/app invariant + +Examples + + NonRec x (y:ys) FltLifted + Rec [(x,rhs)] FltLifted + + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? + NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n + + NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge + +Can't happen: + NonRec x# (a /# b) -- Might fail; does not satisfy let/app + NonRec x# (f y) -- Might diverge; does not satisfy let/app +-} + +data LetFloats = LetFloats (OrdList OutBind) FloatFlag + -- See Note [LetFloats] + +type JoinFloat = OutBind +type JoinFloats = OrdList JoinFloat + +data FloatFlag + = FltLifted -- All bindings are lifted and lazy *or* + -- consist of a single primitive string literal + -- Hence ok to float to top level, or recursive + + | FltOkSpec -- All bindings are FltLifted *or* + -- strict (perhaps because unlifted, + -- perhaps because of a strict binder), + -- *and* ok-for-speculation + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + + | FltCareful -- At least one binding is strict (or unlifted) + -- and not guaranteed cheap + -- Do not float these bindings out of a lazy let + +instance Outputable LetFloats where + ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) + +instance Outputable FloatFlag where + ppr FltLifted = text "FltLifted" + ppr FltOkSpec = text "FltOkSpec" + ppr FltCareful = text "FltCareful" + +andFF :: FloatFlag -> FloatFlag -> FloatFlag +andFF FltCareful _ = FltCareful +andFF FltOkSpec FltCareful = FltCareful +andFF FltOkSpec _ = FltOkSpec +andFF FltLifted flt = flt + +doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool +-- If you change this function look also at FloatIn.noFloatFromRhs +doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs + = not (isNilOL fs) && want_to_float && can_float + where + want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs + -- See Note [Float when cheap or expandable] + can_float = case ff of + FltLifted -> True + FltOkSpec -> isNotTopLevel lvl && isNonRec rec + FltCareful -> isNotTopLevel lvl && isNonRec rec && str + +{- +Note [Float when cheap or expandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float a let from a let if the residual RHS is + a) cheap, such as (\x. blah) + b) expandable, such as (f b) if f is CONLIKE +But there are + - cheap things that are not expandable (eg \x. expensive) + - expandable things that are not cheap (eg (f b) where b is CONLIKE) +so we must take the 'or' of the two. +-} + +emptyLetFloats :: LetFloats +emptyLetFloats = LetFloats nilOL FltLifted + +emptyJoinFloats :: JoinFloats +emptyJoinFloats = nilOL + +unitLetFloat :: OutBind -> LetFloats +-- This key function constructs a singleton float with the right form +unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) + LetFloats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprIsTickedString rhs = FltLifted + -- String literals can be floated freely. + -- See Note [Core top-level string literals] in GHC.Core. + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) + FltCareful + -- Unlifted binders can only be let-bound if exprOkForSpeculation holds + +unitJoinFloat :: OutBind -> JoinFloats +unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind)) + unitOL bind + +mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) +-- Make a singleton SimplFloats, and +-- extend the incoming SimplEnv's in-scope set with its binders +-- These binders may already be in the in-scope set, +-- but may have by now been augmented with more IdInfo +mkFloatBind env bind + = (floats, env { seInScope = in_scope' }) + where + floats + | isJoinBind bind + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = unitJoinFloat bind + , sfInScope = in_scope' } + | otherwise + = SimplFloats { sfLetFloats = unitLetFloat bind + , sfJoinFloats = emptyJoinFloats + , sfInScope = in_scope' } + + in_scope' = seInScope env `extendInScopeSetBind` bind + +extendFloats :: SimplFloats -> OutBind -> SimplFloats +-- Add this binding to the floats, and extend the in-scope env too +extendFloats (SimplFloats { sfLetFloats = floats + , sfJoinFloats = jfloats + , sfInScope = in_scope }) + bind + | isJoinBind bind + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats + , sfJoinFloats = jfloats' } + | otherwise + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats' + , sfJoinFloats = jfloats } + where + in_scope' = in_scope `extendInScopeSetBind` bind + floats' = floats `addLetFlts` unitLetFloat bind + jfloats' = jfloats `addJoinFlts` unitJoinFloat bind + +addLetFloats :: SimplFloats -> LetFloats -> SimplFloats +-- Add the let-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addLetFloats floats let_floats@(LetFloats binds _) + = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) binds } + +addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats +addJoinFloats floats join_floats + = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) join_floats } + +extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet +extendInScopeSetBind in_scope bind + = extendInScopeSetList in_scope (bindersOf bind) + +addFloats :: SimplFloats -> SimplFloats -> SimplFloats +-- Add both let-floats and join-floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) + (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) + = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 + , sfJoinFloats = jf1 `addJoinFlts` jf2 + , sfInScope = in_scope } + +addLetFlts :: LetFloats -> LetFloats -> LetFloats +addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) + = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) + +letFloatBinds :: LetFloats -> [CoreBind] +letFloatBinds (LetFloats bs _) = fromOL bs + +addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats +addJoinFlts = appOL + +mkRecFloats :: SimplFloats -> SimplFloats +-- Flattens the floats from env2 into a single Rec group, +-- They must either all be lifted LetFloats or all JoinFloats +mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff + , sfJoinFloats = jbs + , sfInScope = in_scope }) + = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) + ASSERT2( isNilOL bs || isNilOL jbs, ppr floats ) + SimplFloats { sfLetFloats = floats' + , sfJoinFloats = jfloats' + , sfInScope = in_scope } + where + floats' | isNilOL bs = emptyLetFloats + | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) + jfloats' | isNilOL jbs = emptyJoinFloats + | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) + +wrapFloats :: SimplFloats -> OutExpr -> OutExpr +-- Wrap the floats around the expression; they should all +-- satisfy the let/app invariant, so mkLets should do the job just fine +wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ + , sfJoinFloats = jbs }) body + = foldrOL Let (wrapJoinFloats jbs body) bs + -- Note: Always safe to put the joins on the inside + -- since the values can't refer to them + +wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloatsX floats body + = ( floats { sfJoinFloats = emptyJoinFloats } + , wrapJoinFloats (sfJoinFloats floats) body ) + +wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr +-- Wrap the sfJoinFloats of the env around the expression, +-- and take them out of the SimplEnv +wrapJoinFloats join_floats body + = foldrOL Let body join_floats + +getTopFloatBinds :: SimplFloats -> [CoreBind] +getTopFloatBinds (SimplFloats { sfLetFloats = lbs + , sfJoinFloats = jbs}) + = ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings + letFloatBinds lbs + +mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats +mapLetFloats (LetFloats fs ff) fun + = LetFloats (mapOL app fs) ff + where + app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' + app (Rec bs) = Rec (map fun bs) + +{- +************************************************************************ +* * + Substitution of Vars +* * +************************************************************************ + +Note [Global Ids in the substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look up even a global (eg imported) Id in the substitution. Consider + case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } +The binder-swap in the occurrence analyser will add a binding +for a LocalId version of g (with the same unique though): + case X.g_34 of b { (a,b) -> let g_34 = b in + ... case X.g_34 of { (p,q) -> ...} ... } +So we want to look up the inner X.g_34 in the substitution, where we'll +find that it has been substituted by b. (Or conceivably cloned.) +-} + +substId :: SimplEnv -> InId -> SimplSR +-- Returns DoneEx only on a non-Var expression +substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] + Nothing -> DoneId (refineFromInScope in_scope v) + Just (DoneId v) -> DoneId (refineFromInScope in_scope v) + Just res -> res -- DoneEx non-var, or ContEx + + -- Get the most up-to-date thing from the in-scope set + -- Even though it isn't in the substitution, it may be in + -- the in-scope set with better IdInfo. + -- + -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify. + +refineFromInScope :: InScopeSet -> Var -> Var +refineFromInScope in_scope v + | isLocalId v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> WARN( True, ppr v ) v -- This is an error! + | otherwise = v + +lookupRecBndr :: SimplEnv -> InId -> OutId +-- Look up an Id which has been put into the envt by simplRecBndrs, +-- but where we have not yet done its RHS +lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of + Just (DoneId v) -> v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refineFromInScope in_scope v + +{- +************************************************************************ +* * +\section{Substituting an Id binder} +* * +************************************************************************ + + +These functions are in the monad only so that they can be made strict via seq. + +Note [Return type for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + (join j :: Char -> Int -> Int) 77 + ( j x = \y. y + ord x ) + (in case v of ) + ( A -> j 'x' ) + ( B -> j 'y' ) + ( C -> ) + +The simplifier pushes the "apply to 77" continuation inwards to give + + join j :: Char -> Int + j x = (\y. y + ord x) 77 + in case v of + A -> j 'x' + B -> j 'y' + C -> 77 + +Notice that the "apply to 77" continuation went into the RHS of the +join point. And that meant that the return type of the join point +changed!! + +That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr +takes a (Just res_ty) argument so that it knows to do the type-changing +thing. + +See also Note [Scaling join point arguments]. +-} + +simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplBinders env bndrs = mapAccumLM simplBinder env bndrs + +------------- +simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Used for lambda and case-bound variables +-- Clone Id if necessary, substitute type +-- Return with IdInfo already substituted, but (fragile) occurrence info zapped +-- The substitution is extended only if the variable is cloned, because +-- we *don't* need to use it to track occurrence info. +simplBinder env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr + ; seqTyVar tv `seq` return (env', tv) } + | otherwise = do { let (env', id) = substIdBndr env bndr + ; seqId id `seq` return (env', id) } + +--------------- +simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder +simplNonRecBndr env id + = do { let (env1, id1) = substIdBndr env id + ; seqId id1 `seq` return (env1, id1) } + +--------------- +simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders +simplRecBndrs env@(SimplEnv {}) ids + = ASSERT(all (not . isJoinId) ids) + do { let (env1, ids1) = mapAccumL substIdBndr env ids + ; seqIds ids1 `seq` return env1 } + + +--------------- +substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr env bndr + +--------------- +substNonCoVarIdBndr + :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) +-- Clone Id if necessary, substitute its type +-- Return an Id with its +-- * Type substituted +-- * UnfoldingInfo, Rules, WorkerInfo zapped +-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] +-- * Robust info, retained especially arity and demand info, +-- so that they are available to occurrences that occur in an +-- earlier binding of a letrec +-- +-- For the robust info, see Note [Arity robustness] +-- +-- Augment the substitution if the unique changed +-- Extend the in-scope set with the new Id +-- +-- Similar to GHC.Core.Subst.substIdBndr, except that +-- the type of id_subst differs +-- all fragile info is zapped +substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x) + +subst_id_bndr :: SimplEnv + -> InBndr -- Env and binder to transform + -> (OutId -> OutId) -- Adjust the type + -> (SimplEnv, OutBndr) +subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id adjust_type + = ASSERT2( not (isCoVar old_id), ppr old_id ) + (env { seInScope = in_scope `extendInScopeSet` new_id, + seIdSubst = new_subst }, new_id) + -- It's important that both seInScope and seIdSubt are updated with + -- the new_id, /after/ applying adjust_type. That's why adjust_type + -- is done here. If we did adjust_type in simplJoinBndr (the only + -- place that gives a non-identity adjust_type) we'd have to fiddle + -- afresh with both seInScope and seIdSubst + where + id1 = uniqAway in_scope old_id + id2 = substIdType env id1 + id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + new_id = adjust_type id3 + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id) + | otherwise + = delVarEnv id_subst old_id + +------------------------------------ +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () + +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids + +{- +Note [Arity robustness] +~~~~~~~~~~~~~~~~~~~~~~~ +We *do* transfer the arity from the in_id of a let binding to the +out_id. This is important, so that the arity of an Id is visible in +its own RHS. For example: + f = \x. ....g (\y. f y).... +We can eta-reduce the arg to g, because f is a value. But that +needs to be visible. + +This interacts with the 'state hack' too: + f :: Bool -> IO Int + f = \x. case x of + True -> f y + False -> \s -> ... +Can we eta-expand f? Only if we see that f has arity 1, and then we +take advantage of the 'state hack' on the result of +(f y) :: State# -> (State#, Int) to expand the arity one more. + +There is a disadvantage though. Making the arity visible in the RHS +allows us to eta-reduce + f = \x -> f x +to + f = f +which technically is not sound. This is very much a corner case, so +I'm not worried about it. Another idea is to ensure that f's arity +never decreases; its arity started as 1, and we should never eta-reduce +below that. + + +Note [Robust OccInfo] +~~~~~~~~~~~~~~~~~~~~~ +It's important that we *do* retain the loop-breaker OccInfo, because +that's what stops the Id getting inlined infinitely, in the body of +the letrec. +-} + + +{- ********************************************************************* +* * + Join points +* * +********************************************************************* -} + +simplNonRecJoinBndr :: SimplEnv -> InBndr + -> Mult -> OutType + -> SimplM (SimplEnv, OutBndr) + +-- A non-recursive let binder for a join point; +-- context being pushed inward may change the type +-- See Note [Return type for join points] +simplNonRecJoinBndr env id mult res_ty + = do { let (env1, id1) = simplJoinBndr mult res_ty env id + ; seqId id1 `seq` return (env1, id1) } + +simplRecJoinBndrs :: SimplEnv -> [InBndr] + -> Mult -> OutType + -> SimplM SimplEnv +-- Recursive let binders for join points; +-- context being pushed inward may change types +-- See Note [Return type for join points] +simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty + = ASSERT(all isJoinId ids) + do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +simplJoinBndr :: Mult -> OutType + -> SimplEnv -> InBndr + -> (SimplEnv, OutBndr) +simplJoinBndr mult res_ty env id + = subst_id_bndr env id (adjustJoinPointType mult res_ty) + +--------------- +adjustJoinPointType :: Mult + -> Type -- New result type + -> Id -- Old join-point Id + -> Id -- Adjusted jont-point Id +-- (adjustJoinPointType mult new_res_ty join_id) does two things: +-- +-- 1. Set the return type of the join_id to new_res_ty +-- See Note [Return type for join points] +-- +-- 2. Adjust the multiplicity of arrows in join_id's type, as +-- directed by 'mult'. See Note [Scaling join point arguments] +-- +-- INVARIANT: If any of the first n binders are foralls, those tyvars +-- cannot appear in the original result type. See isValidJoinPointType. +adjustJoinPointType mult new_res_ty join_id + = ASSERT( isJoinId join_id ) + setIdType join_id new_join_ty + where + orig_ar = idJoinArity join_id + orig_ty = idType join_id + + new_join_ty = go orig_ar orig_ty + + go 0 _ = new_res_ty + go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty + = mkPiTy (scale_bndr arg_bndr) $ + go (n-1) res_ty + | otherwise + = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty) + + scale_bndr (Anon af t) = Anon af (scaleScaled mult t) + scale_bndr b@(Named _) = b + +{- Note [Scaling join point arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a join point which is linear in its variable, in some context E: + +E[join j :: a %1 -> a + j x = x + in case v of + A -> j 'x' + B -> ] + +The simplifier changes to: + +join j :: a %1 -> a + j x = E[x] +in case v of + A -> j 'x' + B -> E[] + +If E uses its argument in a nonlinear way (e.g. a case['Many]), then +this is wrong: the join point has to change its type to a -> a. +Otherwise, we'd get a linearity error. + +See also Note [Return type for join points] and Note [Join points and case-of-case]. +-} + +{- +************************************************************************ +* * + Impedance matching to type substitution +* * +************************************************************************ +-} + +getTCvSubst :: SimplEnv -> TCvSubst +getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env + , seCvSubst = cv_env }) + = mkTCvSubst in_scope (tv_env, cv_env) + +substTy :: SimplEnv -> Type -> Type +substTy env ty = Type.substTy (getTCvSubst env) ty + +substTyVar :: SimplEnv -> TyVar -> Type +substTyVar env tv = Type.substTyVar (getTCvSubst env) tv + +substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr env tv + = case Type.substTyVarBndr (getTCvSubst env) tv of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getTCvSubst env) cv of + (TCvSubst in_scope' tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getTCvSubst env) co + +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || no_free_vars + = id + | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w + subst = TCvSubst in_scope tv_env cv_env + old_ty = idType id + old_w = varMult id diff --git a/GHC/Core/Opt/Simplify/Monad.hs b/GHC/Core/Opt/Simplify/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Monad.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE PatternSynonyms #-} +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} +-} + +{-# LANGUAGE DeriveFunctor #-} +module GHC.Core.Opt.Simplify.Monad ( + -- The monad + SimplM, + initSmpl, traceSmpl, + getSimplRules, getFamEnvs, + + -- Unique supply + MonadUnique(..), newId, newJoinId, + + -- Counting + SimplCount, tick, freeTick, checkedTick, + getSimplCount, zeroSimplCount, pprSimplCount, + plusSimplCount, isZeroSimplCount + ) where + +import GHC.Prelude + +import GHC.Types.Var ( Var, isId, mkLocalVar ) +import GHC.Types.Name ( mkSystemVarName ) +import GHC.Types.Id ( Id, mkSysLocalOrCoVar ) +import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) +import GHC.Core.Type ( Type, Mult ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Core ( RuleEnv(..) ) +import GHC.Core.Utils ( mkLamTypes ) +import GHC.Types.Unique.Supply +import GHC.Driver.Session +import GHC.Core.Opt.Monad +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad +import GHC.Utils.Error as Err +import GHC.Utils.Misc ( count ) +import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) +import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) +import Control.Monad ( ap ) +import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Exts( oneShot ) + +{- +************************************************************************ +* * +\subsection{Monad plumbing} +* * +************************************************************************ + +For the simplifier monad, we want to {\em thread} a unique supply and a counter. +(Command-line switches move around through the explicitly-passed SimplEnv.) +-} + +newtype SimplM result + = SM' { unSM :: SimplTopEnv -- Envt that does not change much + -> UniqSupply -- We thread the unique supply because + -- constantly splitting it is rather expensive + -> SimplCount + -> IO (result, UniqSupply, SimplCount)} + -- We only need IO here for dump output + deriving (Functor) + +pattern SM :: (SimplTopEnv -> UniqSupply -> SimplCount + -> IO (result, UniqSupply, SimplCount)) + -> SimplM result +-- This pattern synonym makes the simplifier monad eta-expand, +-- which as a very beneficial effect on compiler performance +-- (worth a 1-2% reduction in bytes-allocated). See #18202. +-- See Note [The one-shot state monad trick] in GHC.Core.Unify +pattern SM m <- SM' m + where + SM m = SM' (oneShot m) + +data SimplTopEnv + = STE { st_flags :: DynFlags + , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run + , st_rules :: RuleEnv + , st_fams :: (FamInstEnv, FamInstEnv) } + +initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) + -> UniqSupply -- No init count; set to 0 + -> Int -- Size of the bindings, used to limit + -- the number of ticks we allow + -> SimplM a + -> IO (a, SimplCount) + +initSmpl dflags rules fam_envs us size m + = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) + return (result, count) + where + env = STE { st_flags = dflags, st_rules = rules + , st_max_ticks = computeMaxTicks dflags size + , st_fams = fam_envs } + +computeMaxTicks :: DynFlags -> Int -> IntWithInf +-- Compute the max simplifier ticks as +-- (base-size + pgm-size) * magic-multiplier * tick-factor/100 +-- where +-- magic-multiplier is a constant that gives reasonable results +-- base-size is a constant to deal with size-zero programs +computeMaxTicks dflags size + = treatZeroAsInf $ + fromInteger ((toInteger (size + base_size) + * toInteger (tick_factor * magic_multiplier)) + `div` 100) + where + tick_factor = simplTickFactor dflags + base_size = 100 + magic_multiplier = 40 + -- MAGIC NUMBER, multiplies the simplTickFactor + -- We can afford to be generous; this is really + -- just checking for loops, and shouldn't usually fire + -- A figure of 20 was too small: see #5539. + +{-# INLINE thenSmpl #-} +{-# INLINE thenSmpl_ #-} +{-# INLINE returnSmpl #-} + + +instance Applicative SimplM where + pure = returnSmpl + (<*>) = ap + (*>) = thenSmpl_ + +instance Monad SimplM where + (>>) = (*>) + (>>=) = thenSmpl + +returnSmpl :: a -> SimplM a +returnSmpl e = SM (\_st_env us sc -> return (e, us, sc)) + +thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b +thenSmpl_ :: SimplM a -> SimplM b -> SimplM b + +thenSmpl m k + = SM $ \st_env us0 sc0 -> do + (m_result, us1, sc1) <- unSM m st_env us0 sc0 + unSM (k m_result) st_env us1 sc1 + +thenSmpl_ m k + = SM $ \st_env us0 sc0 -> do + (_, us1, sc1) <- unSM m st_env us0 sc0 + unSM k st_env us1 sc1 + +-- TODO: this specializing is not allowed +-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} +-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} +-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} + +traceSmpl :: String -> SDoc -> SimplM () +traceSmpl herald doc + = do { dflags <- getDynFlags + ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" + FormatText + (hang (text herald) 2 doc) } +{-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] + +{- +************************************************************************ +* * +\subsection{The unique supply} +* * +************************************************************************ +-} + +instance MonadUnique SimplM where + getUniqueSupplyM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> return (us1, us2, sc)) + + getUniqueM + = SM (\_st_env us sc -> case takeUniqFromSupply us of + (u, us') -> return (u, us', sc)) + + getUniquesM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> return (uniqsFromSupply us1, us2, sc)) + +instance HasDynFlags SimplM where + getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc)) + +instance MonadIO SimplM where + liftIO m = SM $ \_ us sc -> do + x <- m + return (x, us, sc) + +getSimplRules :: SimplM RuleEnv +getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) + +getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) +getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) + +newId :: FastString -> Mult -> Type -> SimplM Id +newId fs w ty = do uniq <- getUniqueM + return (mkSysLocalOrCoVar fs uniq w ty) + +newJoinId :: [Var] -> Type -> SimplM Id +newJoinId bndrs body_ty + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "$j") + join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] + arity = count isId bndrs + -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core + join_arity = length bndrs + details = JoinId join_arity + id_info = vanillaIdInfo `setArityInfo` arity +-- `setOccInfo` strongLoopBreaker + + ; return (mkLocalVar details name Many join_id_ty id_info) } + +{- +************************************************************************ +* * +\subsection{Counting up what we've done} +* * +************************************************************************ +-} + +getSimplCount :: SimplM SimplCount +getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) + +tick :: Tick -> SimplM () +tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) + +checkedTick :: Tick -> SimplM () +-- Try to take a tick, but fail if too many +checkedTick t + = SM (\st_env us sc -> + if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) + then throwGhcExceptionIO $ + PprProgramError "Simplifier ticks exhausted" (msg sc) + else let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) + where + msg sc = vcat + [ text "When trying" <+> ppr t + , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)." + , space + , text "If you need to increase the limit substantially, please file a" + , text "bug report and indicate the factor you needed." + , space + , text "If GHC was unable to complete compilation even" + <+> text "with a very large factor" + , text "(a thousand or more), please consult the" + <+> doubleQuotes (text "Known bugs or infelicities") + , text "section in the Users Guide before filing a report. There are a" + , text "few situations unlikely to occur in practical programs for which" + , text "simplifier non-termination has been judged acceptable." + , space + , pp_details sc + , pprSimplCount sc ] + pp_details sc + | hasDetailedCounts sc = empty + | otherwise = text "To see detailed counts use -ddump-simpl-stats" + + +freeTick :: Tick -> SimplM () +-- Record a tick, but don't add to the total tick count, which is +-- used to decide when nothing further has happened +freeTick t + = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc + in sc' `seq` return ((), us, sc')) diff --git a/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Utils.hs @@ -0,0 +1,2499 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +The simplifier utilities +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Simplify.Utils ( + -- Rebuilding + mkLam, mkCase, prepareAlts, tryEtaExpandRhs, + + -- Inlining, + preInlineUnconditionally, postInlineUnconditionally, + activeUnfolding, activeRule, + getUnfoldingInRuleMatch, + simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, + + -- The continuation type + SimplCont(..), DupFlag(..), StaticEnv, + isSimplified, contIsStop, + contIsDupable, contResultType, contHoleType, contHoleScaling, + contIsTrivial, contArgs, + countArgs, + mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, + interestingCallContext, + + -- ArgInfo + ArgInfo(..), ArgSpec(..), mkArgInfo, + addValArgTo, addCastTo, addTyArgTo, + argInfoExpr, argInfoAppArgs, pushSimplifiedArgs, + isStrictArgInfo, lazyArgContext, + + abstractFloats, + + -- Utilities + isExitJoinId + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) ) +import GHC.Driver.Session +import GHC.Core +import qualified GHC.Core.Subst +import GHC.Core.Ppr +import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Opt.Arity +import GHC.Core.Unfold +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var +import GHC.Types.Demand +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding( substTy ) +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) +import GHC.Core.Multiplicity +import GHC.Utils.Misc +import GHC.Data.OrdList ( isNilOL ) +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Core.Opt.ConstantFold +import GHC.Data.FastString ( fsLit ) + +import Control.Monad ( when ) +import Data.List ( sortBy ) + +{- +************************************************************************ +* * + The SimplCont and DupFlag types +* * +************************************************************************ + +A SimplCont allows the simplifier to traverse the expression in a +zipper-like fashion. The SimplCont represents the rest of the expression, +"above" the point of interest. + +You can also think of a SimplCont as an "evaluation context", using +that term in the way it is used for operational semantics. This is the +way I usually think of it, For example you'll often see a syntax for +evaluation context looking like + C ::= [] | C e | case C of alts | C `cast` co +That's the kind of thing we are doing here, and I use that syntax in +the comments. + + +Key points: + * A SimplCont describes a *strict* context (just like + evaluation contexts do). E.g. Just [] is not a SimplCont + + * A SimplCont describes a context that *does not* bind + any variables. E.g. \x. [] is not a SimplCont +-} + +data SimplCont + = Stop -- Stop[e] = e + OutType -- Type of the + CallCtxt -- Tells if there is something interesting about + -- the context, and hence the inliner + -- should be a bit keener (see interestingCallContext) + -- Specifically: + -- This is an argument of a function that has RULES + -- Inlining the call might allow the rule to fire + -- Never ValAppCxt (use ApplyToVal instead) + -- or CaseCtxt (use Select instead) + + | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] + OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion + SimplCont + + | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy/Val] + , sc_arg :: InExpr -- The argument, + , sc_env :: StaticEnv -- see Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] + { sc_arg_ty :: OutType -- Argument type + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy/Val] + , sc_cont :: SimplCont } + + | Select -- (Select alts K)[e] = K[ case e of alts ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId -- case binder + , sc_alts :: [InAlt] -- Alternatives + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + -- The two strict forms have no DupFlag, because we never duplicate them + | StrictBind -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b] + -- or, equivalently, = K[ (\x xs.b) e ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId + , sc_bndrs :: [InBndr] + , sc_body :: InExpr + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] + { sc_dup :: DupFlag -- Always Simplified or OkToDup + , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + -- plus demands and discount flags for *this* arg + -- and further args + -- So ai_dmds and ai_discs are never empty + , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), + -- presumably (arg_ty -> res_ty) + -- where res_ty is expected by sc_cont + , sc_cont :: SimplCont } + + | TickIt -- (TickIt t K)[e] = K[ tick t e ] + (Tickish Id) -- Tick tickish + SimplCont + +type StaticEnv = SimplEnv -- Just the static part is relevant + +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty + +perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type +perhapsSubstTy dup env ty + | isSimplified dup = ty + | otherwise = substTy env ty + +{- Note [StaticEnv invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pair up an InExpr or InAlts with a StaticEnv, which establishes the +lexical scope for that InExpr. When we simplify that InExpr/InAlts, we +use + - Its captured StaticEnv + - Overriding its InScopeSet with the larger one at the + simplification point. + +Why override the InScopeSet? Example: + (let y = ey in f) ex +By the time we simplify ex, 'y' will be in scope. + +However the InScopeSet in the StaticEnv is not irrelevant: it should +include all the free vars of applying the substitution to the InExpr. +Reason: contHoleType uses perhapsSubstTy to apply the substitution to +the expression, and that (rightly) gives ASSERT failures if the InScopeSet +isn't big enough. + +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both (ApplyToVal dup _ env k) + and (Select dup _ _ env k) +the following invariants hold + + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty + (and hence no need to re-simplify) +-} + +instance Outputable DupFlag where + ppr OkToDup = text "ok" + ppr NoDup = text "nodup" + ppr Simplified = text "simpl" + +instance Outputable SimplCont where + ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty + ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont + ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont + ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) + = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont + ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) + = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty) + 2 (pprParendExpr arg)) + $$ ppr cont + ppr (StrictBind { sc_bndr = b, sc_cont = cont }) + = (text "StrictBind" <+> ppr b) $$ ppr cont + ppr (StrictArg { sc_fun = ai, sc_cont = cont }) + = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont + ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = (text "Select" <+> ppr dup <+> ppr bndr) $$ + whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + + +{- Note [The hole type in ApplyToTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_hole_ty field of ApplyToTy records the type of the "hole" in the +continuation. It is absolutely necessary to compute contHoleType, but it is +not used for anything else (and hence may not be evaluated). + +Why is it necessary for contHoleType? Consider the continuation + ApplyToType Int (Stop Int) +corresponding to + ( @Int) :: Int +What is the type of ? It could be (forall a. Int) or (forall a. a), +and there is no way to know which, so we must record it. + +In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType +for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably +doesn't matter because we'll never compute them all. + +************************************************************************ +* * + ArgInfo and ArgSpec +* * +************************************************************************ +-} + +data ArgInfo + = ArgInfo { + ai_fun :: OutId, -- The function + ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + + ai_rules :: FunRules, -- Rules for this function + + ai_encl :: Bool, -- Flag saying whether this function + -- or an enclosing one has rules (recursively) + -- True => be keener to inline in all args + + ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) + -- Usually infinite, but if it is finite it guarantees + -- that the function diverges after being given + -- that number of args + + ai_discs :: [Int] -- Discounts for remaining value arguments (beyong ai_args) + -- non-zero => be keener to inline + -- Always infinite + } + +data ArgSpec + = ValArg { as_dmd :: Demand -- Demand placed on this argument + , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal + , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) + + | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy + , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) + + | CastBy OutCoercion -- Cast by this; c.f. CastIt + +instance Outputable ArgInfo where + ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds }) + = text "ArgInfo" <+> braces + (sep [ text "fun =" <+> ppr fun + , text "dmds =" <+> ppr dmds + , text "args =" <+> ppr args ]) + +instance Outputable ArgSpec where + ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg + ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty + ppr (CastBy c) = text "CastBy" <+> ppr c + +addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo +addValArgTo ai arg hole_ty + | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai + -- Pop the top demand and and discounts off + , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } + = ai { ai_args = arg_spec : ai_args ai + , ai_dmds = dmds + , ai_discs = discs + , ai_rules = decRules rules } + | otherwise + = pprPanic "addValArgTo" (ppr ai $$ ppr arg) + -- There should always be enough demands and discounts + +addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo +addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai + , ai_rules = decRules (ai_rules ai) } + where + arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } + +addCastTo :: ArgInfo -> OutCoercion -> ArgInfo +addCastTo ai co = ai { ai_args = CastBy co : ai_args ai } + +isStrictArgInfo :: ArgInfo -> Bool +-- True if the function is strict in the next argument +isStrictArgInfo (ArgInfo { ai_dmds = dmds }) + | dmd:_ <- dmds = isStrictDmd dmd + | otherwise = False + +argInfoAppArgs :: [ArgSpec] -> [OutExpr] +argInfoAppArgs [] = [] +argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast +argInfoAppArgs (ValArg { as_arg = arg } : as) = arg : argInfoAppArgs as +argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as + +pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont +pushSimplifiedArgs _env [] k = k +pushSimplifiedArgs env (arg : args) k + = case arg of + TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } + -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } + ValArg { as_arg = arg, as_hole_ty = hole_ty } + -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified + , sc_hole_ty = hole_ty, sc_cont = rest } + CastBy c -> CastIt c rest + where + rest = pushSimplifiedArgs env args k + -- The env has an empty SubstEnv + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +-- NB: the [ArgSpec] is reversed so that the first arg +-- in the list is the last one in the application +argInfoExpr fun rev_args + = go rev_args + where + go [] = Var fun + go (ValArg { as_arg = arg } : as) = go as `App` arg + go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty + go (CastBy co : as) = mkCast (go as) co + + +type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function + -- Nothing => No rules + -- Just (n, rules) => some rules, requiring at least n more type/value args + +decRules :: FunRules -> FunRules +decRules (Just (n, rules)) = Just (n-1, rules) +decRules Nothing = Nothing + +mkFunRules :: [CoreRule] -> FunRules +mkFunRules [] = Nothing +mkFunRules rs = Just (n_required, rs) + where + n_required = maximum (map ruleArity rs) + +{- +************************************************************************ +* * + Functions on SimplCont +* * +************************************************************************ +-} + +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty BoringCtxt + +mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in GHC.Core.Unfold +mkRhsStop ty = Stop ty RhsCtxt + +mkLazyArgStop :: OutType -> CallCtxt -> SimplCont +mkLazyArgStop ty cci = Stop ty cci + +------------------- +contIsRhsOrArg :: SimplCont -> Bool +contIsRhsOrArg (Stop {}) = True +contIsRhsOrArg (StrictBind {}) = True +contIsRhsOrArg (StrictArg {}) = True +contIsRhsOrArg _ = False + +contIsRhs :: SimplCont -> Bool +contIsRhs (Stop _ RhsCtxt) = True +contIsRhs _ = False + +------------------- +contIsStop :: SimplCont -> Bool +contIsStop (Stop {}) = True +contIsStop _ = False + +contIsDupable :: SimplCont -> Bool +contIsDupable (Stop {}) = True +contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k +contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] +contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... +contIsDupable (CastIt _ k) = contIsDupable k +contIsDupable _ = False + +------------------- +contIsTrivial :: SimplCont -> Bool +contIsTrivial (Stop {}) = True +contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k +contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k +contIsTrivial (CastIt _ k) = contIsTrivial k +contIsTrivial _ = False + +------------------- +contResultType :: SimplCont -> OutType +contResultType (Stop ty _) = ty +contResultType (CastIt _ k) = contResultType k +contResultType (StrictBind { sc_cont = k }) = contResultType k +contResultType (StrictArg { sc_cont = k }) = contResultType k +contResultType (Select { sc_cont = k }) = contResultType k +contResultType (ApplyToTy { sc_cont = k }) = contResultType k +contResultType (ApplyToVal { sc_cont = k }) = contResultType k +contResultType (TickIt _ k) = contResultType k + +contHoleType :: SimplCont -> OutType +contHoleType (Stop ty _) = ty +contHoleType (TickIt _ k) = contHoleType k +contHoleType (CastIt co _) = coercionLKind co +contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) + = perhapsSubstTy dup se (idType b) +contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty +contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val] +contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) + = perhapsSubstTy d se (idType b) + + +-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of +-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling +-- factor is p. And in E[G[]], the scaling factor is the product of the scaling +-- factor of E and that of G. +-- +-- The scaling factor at the hole of E[] is used to determine how a binder +-- should be scaled if it commutes with E. This appears, in particular, in the +-- case-of-case transformation. +contHoleScaling :: SimplCont -> Mult +contHoleScaling (Stop _ _) = One +contHoleScaling (CastIt _ k) = contHoleScaling k +contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (Select { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k }) + = w `mkMultMul` contHoleScaling k + where + (w, _, _) = splitFunTy fun_ty +contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k +contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k +contHoleScaling (TickIt _ k) = contHoleScaling k +------------------- +countArgs :: SimplCont -> Int +-- Count all arguments, including types, coercions, and other values +countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont +countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont +countArgs _ = 0 + +contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont + where + lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold + lone (ApplyToVal {}) = False -- NB: even a type application or cast + lone (CastIt {}) = False -- stops it being "lone" + lone _ = True + + go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) + = go (is_interesting arg se : args) k + go args (ApplyToTy { sc_cont = k }) = go args k + go args (CastIt _ k) = go args k + go args k = (False, reverse args, k) + + is_interesting arg se = interestingArg se arg + -- Do *not* use short-cutting substitution here + -- because we want to get as much IdInfo as possible + + +------------------- +mkArgInfo :: SimplEnv + -> Id + -> [CoreRule] -- Rules for function + -> Int -- Number of value args + -> SimplCont -- Context of the call + -> ArgInfo + +mkArgInfo env fun rules n_val_args call_cont + | n_val_args < idArity fun -- Note [Unsaturated functions] + = ArgInfo { ai_fun = fun, ai_args = [] + , ai_rules = fun_rules + , ai_encl = False + , ai_dmds = vanilla_dmds + , ai_discs = vanilla_discounts } + | otherwise + = ArgInfo { ai_fun = fun + , ai_args = [] + , ai_rules = fun_rules + , ai_encl = interestingArgContext rules call_cont + , ai_dmds = add_type_strictness (idType fun) arg_dmds + , ai_discs = arg_discounts } + where + fun_rules = mkFunRules rules + + vanilla_discounts, arg_discounts :: [Int] + vanilla_discounts = repeat 0 + arg_discounts = case idUnfolding fun of + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} + -> discounts ++ vanilla_discounts + _ -> vanilla_discounts + + vanilla_dmds, arg_dmds :: [Demand] + vanilla_dmds = repeat topDmd + + arg_dmds + | not (sm_inline (seMode env)) + = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] + | otherwise + = -- add_type_str fun_ty $ + case splitStrictSig (idStrictness fun) of + (demands, result_info) + | not (demands `lengthExceeds` n_val_args) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so its ok + -- (see GHC.Core.Op.Simplify.Utils.analyseCont) + if isDeadEndDiv result_info then + demands -- Finite => result is bottom + else + demands ++ vanilla_dmds + | otherwise + -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) + <+> ppr n_val_args <+> ppr demands ) + vanilla_dmds -- Not enough args, or no strictness + + add_type_strictness :: Type -> [Demand] -> [Demand] + -- If the function arg types are strict, record that in the 'strictness bits' + -- No need to instantiate because unboxed types (which dominate the strict + -- types) can't instantiate type variables. + -- add_type_strictness is done repeatedly (for each call); + -- might be better once-for-all in the function + -- But beware primops/datacons with no strictness + + add_type_strictness fun_ty dmds + | null dmds = [] + + | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty + = add_type_strictness fun_ty' dmds -- Look through foralls + + | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info + , dmd : rest_dmds <- dmds + , let dmd' = case isLiftedType_maybe arg_ty of + Just False -> strictenDmd dmd + _ -> dmd + = dmd' : add_type_strictness fun_ty' rest_dmds + -- If the type is levity-polymorphic, we can't know whether it's + -- strict. isLiftedType_maybe will return Just False only when + -- we're sure the type is unlifted. + + | otherwise + = dmds + +{- Note [Unsaturated functions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (test eyeball/inline4) + x = a:as + y = f x +where f has arity 2. Then we do not want to inline 'x', because +it'll just be floated out again. Even if f has lots of discounts +on its first argument -- it must be saturated for these to kick in + +Note [Do not expose strictness if sm_inline=False] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#15163 showed a case in which we had + + {-# INLINE [1] zip #-} + zip = undefined + + {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} + +If we expose zip's bottoming nature when simplifying the LHS of the +RULE we get + {-# RULES "foo" forall as bs. + stream (case zip of {}) = ..blah... #-} +discarding the arguments to zip. Usually this is fine, but on the +LHS of a rule it's not, because 'as' and 'bs' are now not bound on +the LHS. + +This is a pretty pathological example, so I'm not losing sleep over +it, but the simplest solution was to check sm_inline; if it is False, +which it is on the LHS of a rule (see updModeForRules), then don't +make use of the strictness info for the function. +-} + + +{- +************************************************************************ +* * + Interesting arguments +* * +************************************************************************ + +Note [Interesting call context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee, application etc.) then we +inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +Note [No case of case is boring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + case f x of + +we'd usually treat the context as interesting, to encourage 'f' to +inline. But if case-of-case is off, it's really not so interesting +after all, because we are unlikely to be able to push the case +expression into the branches of any case in f's unfolding. So, to +reduce unnecessary code expansion, we just make the context look boring. +This made a small compile-time perf improvement in perf/compiler/T6048, +and it looks plausible to me. +-} + +lazyArgContext :: ArgInfo -> CallCtxt +-- Use this for lazy arguments +lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +strictArgContext :: ArgInfo -> CallCtxt +strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) +-- Use this for strict arguments + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = RhsCtxt + -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we + -- want to be a bit more eager to inline g, because it may + -- expose an eval (on x perhaps) that can be eliminated or + -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 + -- It's worth an 18% improvement in allocation for this + -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' + +interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt +-- See Note [Interesting call context] +interestingCallContext env cont + = interesting cont + where + interesting (Select {}) + | sm_case_case (getMode env) = CaseCtxt + | otherwise = BoringCtxt + -- See Note [No case of case is boring] + + interesting (ApplyToVal {}) = ValAppCtxt + -- Can happen if we have (f Int |> co) y + -- If f has an INLINE prag we need to give it some + -- motivation to inline. See Note [Cast then apply] + -- in GHC.Core.Unfold + + interesting (StrictArg { sc_fun = fun }) = strictArgContext fun + interesting (StrictBind {}) = BoringCtxt + interesting (Stop _ cci) = cci + interesting (TickIt _ k) = interesting k + interesting (ApplyToTy { sc_cont = k }) = interesting k + interesting (CastIt _ k) = interesting k + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. + -- + -- It's also very important to inline in a strict context for things + -- like + -- foldr k z (f x) + -- Here, the context of (f x) is strict, and if f's unfolding is + -- a build it's *great* to inline it here. So we must ensure that + -- the context for (f x) is not totally uninteresting. + +interestingArgContext :: [CoreRule] -> SimplCont -> Bool +-- If the argument has form (f x y), where x,y are boring, +-- and f is marked INLINE, then we don't want to inline f. +-- But if the context of the argument is +-- g (f x y) +-- where g has rules, then we *do* want to inline f, in case it +-- exposes a rule that might fire. Similarly, if the context is +-- h (g (f x x)) +-- where h has rules, then we do want to inline f; hence the +-- call_cont argument to interestingArgContext +-- +-- The ai-rules flag makes this happen; if it's +-- set, the inliner gets just enough keener to inline f +-- regardless of how boring f's arguments are, if it's marked INLINE +-- +-- The alternative would be to *always* inline an INLINE function, +-- regardless of how boring its context is; but that seems overkill +-- For example, it'd mean that wrapper functions were always inlined +-- +-- The call_cont passed to interestingArgContext is the context of +-- the call itself, e.g. g in the example above +interestingArgContext rules call_cont + = notNull rules || enclosing_fn_has_rules + where + enclosing_fn_has_rules = go call_cont + + go (Select {}) = False + go (ApplyToVal {}) = False -- Shouldn't really happen + go (ApplyToTy {}) = False -- Ditto + go (StrictArg { sc_fun = fun }) = ai_encl fun + go (StrictBind {}) = False -- ?? + go (CastIt _ c) = go c + go (Stop _ RuleArgCtxt) = True + go (Stop _ _) = False + go (TickIt _ c) = go c + +{- Note [Interesting arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An argument is interesting if it deserves a discount for unfoldings +with a discount in that argument position. The idea is to avoid +unfolding a function that is applied only to variables that have no +unfolding (i.e. they are probably lambda bound): f x y z There is +little point in inlining f here. + +Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But +we must look through lets, eg (let x = e in C a b), because the let will +float, exposing the value, if we inline. That makes it different to +exprIsHNF. + +Before 2009 we said it was interesting if the argument had *any* structure +at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. + +But we don't regard (f x y) as interesting, unless f is unsaturated. +If it's saturated and f hasn't inlined, then it's probably not going +to now! + +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting +-} + +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +-- See Note [Interesting arguments] +interestingArg env e = go env 0 e + where + -- n is # value args to which the expression is applied + go env n (Var v) + = case substId env v of + DoneId v' -> go_var n v' + DoneEx e _ -> go (zapSubstEnv env) n e + ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e + + go _ _ (Lit {}) = ValueArg + go _ _ (Type _) = TrivArg + go _ _ (Coercion _) = TrivArg + go env n (App fn (Type _)) = go env n fn + go env n (App fn _) = go env (n+1) fn + go env n (Tick _ a) = go env n a + go env n (Cast e _) = go env n e + go env n (Lam v e) + | isTyVar v = go env n e + | n>0 = NonTrivArg -- (\x.b) e is NonTriv + | otherwise = ValueArg + go _ _ (Case {}) = NonTrivArg + go env n (Let b e) = case go env' n e of + ValueArg -> ValueArg + _ -> NonTrivArg + where + env' = env `addNewInScopeIds` bindersOf b + + go_var n v + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here + | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding + | n > 0 = NonTrivArg -- Saturated or unknown call + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding + -- See Note [Conlike is interesting] + | otherwise = TrivArg -- n==0, no useful unfolding + where + conlike_unfolding = isConLikeUnfolding (idUnfolding v) + +{- +************************************************************************ +* * + SimplMode +* * +************************************************************************ + +The SimplMode controls several switches; see its definition in +GHC.Core.Opt.Monad + sm_rules :: Bool -- Whether RULES are enabled + sm_inline :: Bool -- Whether inlining is enabled + sm_case_case :: Bool -- Whether case-of-case is enabled + sm_eta_expand :: Bool -- Whether eta-expansion is enabled +-} + +simplEnvForGHCi :: DynFlags -> SimplEnv +simplEnvForGHCi dflags + = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] + , sm_phase = InitialPhase + , sm_dflags = dflags + , sm_rules = rules_on + , sm_inline = False + , sm_eta_expand = eta_expand_on + , sm_case_case = True } + where + rules_on = gopt Opt_EnableRewriteRules dflags + eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags + -- Do not do any inlining, in case we expose some unboxed + -- tuple stuff that confuses the bytecode interpreter + +updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode +-- See Note [Simplifying inside stable unfoldings] +updModeForStableUnfoldings inline_rule_act current_mode + = current_mode { sm_phase = phaseFromActivation inline_rule_act + , sm_inline = True + , sm_eta_expand = False } + -- sm_eta_expand: see Note [No eta expansion in stable unfoldings] + -- For sm_rules, just inherit; sm_rules might be "off" + -- because of -fno-enable-rewrite-rules + where + phaseFromActivation (ActiveAfter _ n) = Phase n + phaseFromActivation _ = InitialPhase + +updModeForRules :: SimplMode -> SimplMode +-- See Note [Simplifying rules] +updModeForRules current_mode + = current_mode { sm_phase = InitialPhase + , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False] + , sm_rules = False + , sm_eta_expand = False } + +{- Note [Simplifying rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying a rule LHS, refrain from /any/ inlining or applying +of other RULES. + +Doing anything to the LHS is plain confusing, because it means that what the +rule matches is not what the user wrote. c.f. #10595, and #10528. +Moreover, inlining (or applying rules) on rule LHSs risks introducing +Ticks into the LHS, which makes matching trickier. #10665, #10745. + +Doing this to either side confounds tools like HERMIT, which seek to reason +about and apply the RULES as originally written. See #10829. + +There is, however, one case where we are pretty much /forced/ to transform the +LHS of a rule: postInlineUnconditionally. For instance, in the case of + + let f = g @Int in f + +We very much want to inline f into the body of the let. However, to do so (and +be able to safely drop f's binding) we must inline into all occurrences of f, +including those in the LHS of rules. + +This can cause somewhat surprising results; for instance, in #18162 we found +that a rule template contained ticks in its arguments, because +postInlineUnconditionally substituted in a trivial expression that contains +ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for +details. + +Note [No eta expansion in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a stable unfolding + + f :: Ord a => a -> IO () + -- Unfolding template + -- = /\a \(d:Ord a) (x:a). bla + +we do not want to eta-expand to + + f :: Ord a => a -> IO () + -- Unfolding template + -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co + +because not specialisation of the overloading doesn't work properly +(see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. + +So we disable eta-expansion in stable unfoldings. + +Note [Inlining in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something is inlined if + (i) the sm_inline flag is on, AND + (ii) the thing has an INLINE pragma, AND + (iii) the thing is inlinable in the earliest phase. + +Example of why (iii) is important: + {-# INLINE [~1] g #-} + g = ... + + {-# INLINE f #-} + f x = g (g x) + +If we were to inline g into f's inlining, then an importing module would +never be able to do + f e --> g (g e) ---> RULE fires +because the stable unfolding for f has had g inlined into it. + +On the other hand, it is bad not to do ANY inlining into an +stable unfolding, because then recursive knots in instance declarations +don't get unravelled. + +However, *sometimes* SimplGently must do no call-site inlining at all +(hence sm_inline = False). Before full laziness we must be careful +not to inline wrappers, because doing so 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. + +The no-inlining thing is also important for Template Haskell. You might be +compiling in one-shot mode with -O2; but when TH compiles a splice before +running it, we don't want to use -O2. Indeed, we don't want to inline +anything, because the byte-code interpreter might get confused about +unboxed tuples and suchlike. + +Note [Simplifying inside stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take care with simplification inside stable unfoldings (which come from +INLINE pragmas). + +First, consider the following example + let f = \pq -> BIG + in + let g = \y -> f y y + {-# INLINE g #-} + in ...g...g...g...g...g... +Now, if that's the ONLY occurrence of f, it might be inlined inside g, +and thence copied multiple times when g is inlined. HENCE we treat +any occurrence in a stable unfolding as a multiple occurrence, not a single +one; see OccurAnal.addRuleUsage. + +Second, we do want *do* to some modest rules/inlining stuff in stable +unfoldings, partly to eliminate senseless crap, and partly to break +the recursive knots generated by instance declarations. + +However, suppose we have + {-# INLINE f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's stable unfolding? Our model is that literally is substituted for +f when it is inlined. So our conservative plan (implemented by +updModeForStableUnfoldings) is this: + + ------------------------------------------------------------- + When simplifying the RHS of a stable unfolding, set the phase + to the phase in which the stable unfolding first becomes active + ------------------------------------------------------------- + +That ensures that + + a) Rules/inlinings that *cease* being active before p will + not apply to the stable unfolding, consistent with it being + inlined in its *original* form in phase p. + + b) Rules/inlinings that only become active *after* p will + not apply to the stable unfolding, again to be consistent with + inlining the *original* rhs in phase p. + +For example, + {-# INLINE f #-} + f x = ...g... + + {-# NOINLINE [1] g #-} + g y = ... + + {-# RULE h g = ... #-} +Here we must not inline g into f's RHS, even when we get to phase 0, +because when f is later inlined into some other module we want the +rule for h to fire. + +Similarly, consider + {-# INLINE f #-} + f x = ...g... + + g y = ... +and suppose that there are auto-generated specialisations and a strictness +wrapper for g. The specialisations get activation AlwaysActive, and the +strictness wrapper get activation (ActiveAfter 0). So the strictness +wrepper fails the test and won't be inlined into f's stable unfolding. That +means f can inline, expose the specialised call to g, so the specialisation +rules can fire. + +A note about wrappers +~~~~~~~~~~~~~~~~~~~~~ +It's also important not to inline a worker back into a wrapper. +A wrapper looks like + wraper = inline_me (\x -> ...worker... ) +Normally, the inline_me prevents the worker getting inlined into +the wrapper (initially, the worker's only call site!). But, +if the wrapper is sure to be called, the strictness analyser will +mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf +continuation. +-} + +activeUnfolding :: SimplMode -> Id -> Bool +activeUnfolding mode id + | isCompulsoryUnfolding (realIdUnfolding id) + = True -- Even sm_inline can't override compulsory unfoldings + | otherwise + = isActive (sm_phase mode) (idInlineActivation id) + && sm_inline mode + -- `or` isStableUnfolding (realIdUnfolding id) + -- Inline things when + -- (a) they are active + -- (b) sm_inline says so, except that for stable unfoldings + -- (ie pragmas) we inline anyway + +getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv +-- When matching in RULE, we want to "look through" an unfolding +-- (to see a constructor) if *rules* are on, even if *inlinings* +-- are not. A notable example is DFuns, which really we want to +-- match in rules like (op dfun) in gentle mode. Another example +-- is 'otherwise' which we want exprIsConApp_maybe to be able to +-- see very early on +getUnfoldingInRuleMatch env + = (in_scope, id_unf) + where + in_scope = seInScope env + mode = getMode env + id_unf id | unf_is_active id = idUnfolding id + | otherwise = NoUnfolding + unf_is_active id + | not (sm_rules mode) = -- active_unfolding_minimal id + isStableUnfolding (realIdUnfolding id) + -- Do we even need to test this? I think this InScopeEnv + -- is only consulted if activeRule returns True, which + -- never happens if sm_rules is False + | otherwise = isActive (sm_phase mode) (idInlineActivation id) + +---------------------- +activeRule :: SimplMode -> Activation -> Bool +-- Nothing => No rules at all +activeRule mode + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) + +{- +************************************************************************ +* * + preInlineUnconditionally +* * +************************************************************************ + +preInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~ +@preInlineUnconditionally@ examines a bndr to see if it is used just +once in a completely safe way, so that it is safe to discard the +binding inline its RHS at the (unique) usage site, REGARDLESS of how +big the RHS might be. If this is the case we don't simplify the RHS +first, but just inline it un-simplified. + +This is much better than first simplifying a perhaps-huge RHS and then +inlining and re-simplifying it. Indeed, it can be at least quadratically +better. Consider + + x1 = e1 + x2 = e2[x1] + x3 = e3[x2] + ...etc... + xN = eN[xN-1] + +We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. +This can happen with cascades of functions too: + + f1 = \x1.e1 + f2 = \xs.e2[f1] + f3 = \xs.e3[f3] + ...etc... + +THE MAIN INVARIANT is this: + + ---- preInlineUnconditionally invariant ----- + IF preInlineUnconditionally chooses to inline x = + THEN doing the inlining should not change the occurrence + info for the free vars of + ---------------------------------------------- + +For example, it's tempting to look at trivial binding like + x = y +and inline it unconditionally. But suppose x is used many times, +but this is the unique occurrence of y. Then inlining x would change +y's occurrence info, which breaks the invariant. It matters: y +might have a BIG rhs, which will now be dup'd at every occurrence of x. + + +Even RHSs labelled InlineMe aren't caught here, because there might be +no benefit from inlining at the call site. + +[Sept 01] Don't unconditionally inline a top-level thing, because that +can simply make a static thing into something built dynamically. E.g. + x = (a,b) + main = \s -> h x + +[Remember that we treat \s as a one-shot lambda.] No point in +inlining x unless there is something interesting about the call site. + +But watch out: if you aren't careful, some useful foldr/build fusion +can be lost (most notably in spectral/hartel/parstof) because the +foldr didn't see the build. Doing the dynamic allocation isn't a big +deal, in fact, but losing the fusion can be. But the right thing here +seems to be to do a callSiteInline based on the fact that there is +something interesting about the call site (it's strict). Hmm. That +seems a bit fragile. + +Conclusion: inline top level things gaily until FinalPhase (the last +phase), at which point don't. + +Note [pre/postInlineUnconditionally in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in gentle mode we want to do preInlineUnconditionally. The +reason is that too little clean-up happens if you don't inline +use-once things. Also a bit of inlining is *good* for full laziness; +it can expose constant sub-expressions. Example in +spectral/mandel/Mandel.hs, where the mandelset function gets a useful +let-float if you inline windowToViewport + +However, as usual for Gentle mode, do not inline things that are +inactive in the initial stages. See Note [Gentle mode]. + +Note [Stable unfoldings and preInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! +Example + + {-# INLINE f #-} + f :: Eq a => a -> a + f x = ... + + fInt :: Int -> Int + fInt = f Int dEqInt + + ...fInt...fInt...fInt... + +Here f occurs just once, in the RHS of fInt. But if we inline it there +it might make fInt look big, and we'll lose the opportunity to inline f +at each of fInt's call sites. The INLINE pragma will only inline when +the application is saturated for exactly this reason; and we don't +want PreInlineUnconditionally to second-guess it. A live example is +#3736. + c.f. Note [Stable unfoldings and postInlineUnconditionally] + +NB: if the pragma is INLINEABLE, then we don't want to behave in +this special way -- an INLINEABLE pragma just says to GHC "inline this +if you like". But if there is a unique occurrence, we want to inline +the stable unfolding, not the RHS. + +Note [Top-level bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't inline top-level Ids that are bottoming, even if they are used just +once, because FloatOut has gone to some trouble to extract them out. +Inlining them won't make the program run faster! + +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and the RHS of a let-binding +is a term (not a coercion) so we can't necessarily inline the latter in +the former. +-} + +preInlineUnconditionally + :: SimplEnv -> TopLevelFlag -> InId + -> InExpr -> StaticEnv -- These two go together + -> Maybe SimplEnv -- Returned env has extended substitution +-- Precondition: rhs satisfies the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +preInlineUnconditionally env top_lvl bndr rhs rhs_env + | not pre_inline_unconditionally = Nothing + | not active = Nothing + | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] + | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] + -- in module Exitify + | not (one_occ (idOccInfo bndr)) = Nothing + | not (isStableUnfolding unf) = Just (extend_subst_with rhs) + + -- Note [Stable unfoldings and preInlineUnconditionally] + | isInlinablePragma inline_prag + , Just inl <- maybeUnfoldingTemplate unf = Just (extend_subst_with inl) + | otherwise = Nothing + where + unf = idUnfolding bndr + extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) + + one_occ IAmDead = True -- Happens in ((\x.1) v) + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False + + pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env) + mode = getMode env + active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag) + -- See Note [pre/postInlineUnconditionally in gentle mode] + inline_prag = idInlinePragma bndr + +-- Be very careful before inlining inside a lambda, because (a) we must not +-- invalidate occurrence information, and (b) we want to avoid pushing a +-- single allocation (here) into multiple allocations (inside lambda). +-- Inlining a *function* with a single *saturated* call would be ok, mind you. +-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) +-- where +-- is_cheap = exprIsCheap rhs +-- ok = is_cheap && int_cxt + + -- int_cxt The context isn't totally boring + -- E.g. let f = \ab.BIG in \y. map f xs + -- Don't want to substitute for f, because then we allocate + -- its closure every time the \y is called + -- But: let f = \ab.BIG in \y. map (f y) xs + -- Now we do want to substitute for f, even though it's not + -- saturated, because we're going to allocate a closure for + -- (f y) every time round the loop anyhow. + + -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, + -- so substituting rhs inside a lambda doesn't change the occ info. + -- Sadly, not quite the same as exprIsHNF. + canInlineInLam (Lit _) = True + canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e + canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam _ = False + -- not ticks. Counting ticks cannot be duplicated, and non-counting + -- ticks around a Lam will disappear anyway. + + early_phase = sm_phase mode /= FinalPhase + -- If we don't have this early_phase test, consider + -- x = length [1,2,3] + -- The full laziness pass carefully floats all the cons cells to + -- top level, and preInlineUnconditionally floats them all back in. + -- Result is (a) static allocation replaced by dynamic allocation + -- (b) many simplifier iterations because this tickles + -- a related problem; only one inlining per pass + -- + -- On the other hand, I have seen cases where top-level fusion is + -- lost if we don't inline top level thing (e.g. string constants) + -- Hence the test for phase zero (which is the phase for all the final + -- simplifications). Until phase zero we take no special notice of + -- top level things, but then we become more leery about inlining + -- them. + +{- +************************************************************************ +* * + postInlineUnconditionally +* * +************************************************************************ + +postInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~~ +@postInlineUnconditionally@ decides whether to unconditionally inline +a thing based on the form of its RHS; in particular if it has a +trivial RHS. If so, we can inline and discard the binding altogether. + +NB: a loop breaker has must_keep_binding = True and non-loop-breakers +only have *forward* references. Hence, it's safe to discard the binding + +NOTE: This isn't our last opportunity to inline. We're at the binding +site right now, and we'll get another opportunity when we get to the +occurrence(s) + +Note that we do this unconditional inlining only for trivial RHSs. +Don't inline even WHNFs inside lambdas; doing so may simply increase +allocation when the function is called. This isn't the last chance; see +NOTE above. + +NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? +Because we don't even want to inline them into the RHS of constructor +arguments. See NOTE above + +NB: At one time even NOINLINE was ignored here: if the rhs is trivial +it's best to inline it anyway. We often get a=E; b=a from desugaring, +with both a and b marked NOINLINE. But that seems incompatible with +our new view that inlining is like a RULE, so I'm sticking to the 'active' +story for now. + +NB: unconditional inlining of this sort can introduce ticks in places that +may seem surprising; for instance, the LHS of rules. See Note [Simplfying +rules] for details. +-} + +postInlineUnconditionally + :: SimplEnv -> TopLevelFlag + -> OutId -- The binder (*not* a CoVar), including its unfolding + -> OccInfo -- From the InId + -> OutExpr + -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-ful bindings +postInlineUnconditionally env top_lvl bndr occ_info rhs + | not active = False + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] + | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] + | exprIsTrivial rhs = True + | isJoinId bndr -- See point (1) of Note [Duplicating join points] + , not (phase == FinalPhase) = False -- in Simplify.hs + | otherwise + = case occ_info of + OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br } + -- See Note [Inline small things to avoid creating a thunk] + + -> n_br < 100 -- See Note [Suppress exponential blowup] + + && smallEnoughToInline dflags unfolding -- Small enough to dup + -- ToDo: consider discount on smallEnoughToInline if int_cxt is true + -- + -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1 + -- Reason: doing so risks exponential behaviour. We simplify a big + -- expression, inline it, and simplify it again. But if the + -- very same thing happens in the big expression, we get + -- exponential cost! + -- PRINCIPLE: when we've already simplified an expression once, + -- make sure that we only inline it if it's reasonably small. + + && (in_lam == NotInsideLam || + -- Outside a lambda, we want to be reasonably aggressive + -- about inlining into multiple branches of case + -- e.g. let x = + -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } + -- Inlining can be a big win if C3 is the hot-spot, even if + -- the uses in C1, C2 are not 'interesting' + -- An example that gets worse if you add int_cxt here is 'clausify' + + (isCheapUnfolding unfolding && int_cxt == IsInteresting)) + -- isCheap => acceptable work duplication; in_lam may be true + -- int_cxt to prevent us inlining inside a lambda without some + -- good reason. See the notes on int_cxt in preInlineUnconditionally + + IAmDead -> True -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + + _ -> False + +-- Here's an example that we don't handle well: +-- let f = if b then Left (\x.BIG) else Right (\y.BIG) +-- in \y. ....case f of {...} .... +-- Here f is used just once, and duplicating the case work is fine (exprIsCheap). +-- But +-- - We can't preInlineUnconditionally because that would invalidate +-- the occ info for b. +-- - We can't postInlineUnconditionally because the RHS is big, and +-- that risks exponential behaviour +-- - We can't call-site inline, because the rhs is big +-- Alas! + + where + unfolding = idUnfolding bndr + dflags = seDynFlags env + phase = sm_phase (getMode env) + active = isActive phase (idInlineActivation bndr) + -- See Note [pre/postInlineUnconditionally in gentle mode] + +{- Note [Inline small things to avoid creating a thunk] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The point of examining occ_info here is that for *non-values* that +occur outside a lambda, the call-site inliner won't have a chance +(because it doesn't know that the thing only occurs once). The +pre-inliner won't have gotten it either, if the thing occurs in more +than one branch So the main target is things like + + let x = f y in + case v of + True -> case x of ... + False -> case x of ... + +This is very important in practice; e.g. wheel-seive1 doubles +in allocation if you miss this out. And bits of GHC itself start +to allocate more. An egregious example is test perf/compiler/T14697, +where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more. + +Note [Suppress exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #13253, and several related tickets, we got an exponential blowup +in code size from postInlineUnconditionally. The trouble comes when +we have + let j1a = case f y of { True -> p; False -> q } + j1b = case f y of { True -> q; False -> p } + j2a = case f (y+1) of { True -> j1a; False -> j1b } + j2b = case f (y+1) of { True -> j1b; False -> j1a } + ... + in case f (y+10) of { True -> j10a; False -> j10b } + +when there are many branches. In pass 1, postInlineUnconditionally +inlines j10a and j10b (they are both small). Now we have two calls +to j9a and two to j9b. In pass 2, postInlineUnconditionally inlines +all four of these calls, leaving four calls to j8a and j8b. Etc. +Yikes! This is exponential! + +A possible plan: stop doing postInlineUnconditionally +for some fixed, smallish number of branches, say 4. But that turned +out to be bad: see Note [Inline small things to avoid creating a thunk]. +And, as it happened, the problem with #13253 was solved in a +different way (Note [Duplicating StrictArg] in Simplify). + +So I just set an arbitrary, high limit of 100, to stop any +totally exponential behaviour. + +This still leaves the nasty possiblity that /ordinary/ inlining (not +postInlineUnconditionally) might inline these join points, each of +which is individually quiet small. I'm still not sure what to do +about this (e.g. see #15488). + +Note [Top level and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do postInlineUnconditionally for top-level things (even for +ones that are trivial): + + * Doing so will inline top-level error expressions that have been + carefully floated out by FloatOut. More generally, it might + replace static allocation with dynamic. + + * Even for trivial expressions there's a problem. Consider + {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} + blah xs = reverse xs + ruggle = sort + In one simplifier pass we might fire the rule, getting + blah xs = ruggle xs + but in *that* simplifier pass we must not do postInlineUnconditionally + on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' + + If the rhs is trivial it'll be inlined by callSiteInline, and then + the binding will be dead and discarded by the next use of OccurAnal + + * There is less point, because the main goal is to get rid of local + bindings used in multiple case branches. + + * The inliner should inline trivial things at call sites anyway. + + * The Id might be exported. We could check for that separately, + but since we aren't going to postInlineUnconditionally /any/ + top-level bindings, we don't need to test. + +Note [Stable unfoldings and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has a stable unfolding, +otherwise we lose the unfolding. Example + + -- f has stable unfolding with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the stable unfolding on f. Now f' +won't inline because 'e' is too big. + + c.f. Note [Stable unfoldings and preInlineUnconditionally] + + +************************************************************************ +* * + Rebuilding a lambda +* * +************************************************************************ +-} + +mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr +-- mkLam tries three things +-- a) eta reduction, if that gives a trivial expression +-- b) eta expansion [only if there are some value lambdas] + +mkLam _env [] body _cont + = return body +mkLam env bndrs body cont + = do { dflags <- getDynFlags + ; mkLam' dflags bndrs body } + where + mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr + mkLam' dflags bndrs (Cast body co) + | not (any bad bndrs) + -- Note [Casts and lambdas] + = do { lam <- mkLam' dflags bndrs body + ; return (mkCast lam (mkPiCos Representational bndrs co)) } + where + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + + mkLam' dflags bndrs body@(Lam {}) + = mkLam' dflags (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + + mkLam' dflags bndrs (Tick t expr) + | tickishFloatable t + = mkTick t <$> mkLam' dflags bndrs expr + + mkLam' dflags bndrs body + | gopt Opt_DoEtaReduction dflags + , Just etad_lam <- tryEtaReduce bndrs body + = do { tick (EtaReduction (head bndrs)) + ; return etad_lam } + + | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] + , sm_eta_expand (getMode env) + , any isRuntimeVar bndrs + , let body_arity = exprEtaExpandArity dflags body + , expandableArityType body_arity + = do { tick (EtaExpansion (head bndrs)) + ; let res = mkLams bndrs (etaExpandAT body_arity body) + ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) + , text "after" <+> ppr res]) + ; return res } + + | otherwise + = return (mkLams bndrs body) + +{- +Note [Eta expanding lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *do* want to eta-expand lambdas. Consider + f (\x -> case x of (a,b) -> \s -> blah) +where 's' is a state token, and hence can be eta expanded. This +showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather +important function! + +The eta-expansion will never happen unless we do it now. (Well, it's +possible that CorePrep will do it, but CorePrep only has a half-baked +eta-expander that can't deal with casts. So it's much better to do it +here.) + +However, when the lambda is let-bound, as the RHS of a let, we have a +better eta-expander (in the form of tryEtaExpandRhs), so we don't +bother to try expansion in mkLam in that case; hence the contIsRhs +guard. + +NB: We check the SimplEnv (sm_eta_expand), not DynFlags. + See Note [No eta expansion in stable unfoldings] + +Note [Casts and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\x. (\y. e) `cast` g1) `cast` g2 +There is a danger here that the two lambdas look separated, and the +full laziness pass might float an expression to between the two. + +So this equation in mkLam' floats the g1 out, thus: + (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) +where x:tx. + +In general, this floats casts outside lambdas, where (I hope) they +might meet and cancel with some other cast: + \x. e `cast` co ===> (\x. e) `cast` (tx -> co) + /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) + /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) + (if not (g `in` co)) + +Notice that it works regardless of 'e'. Originally it worked only +if 'e' was itself a lambda, but in some cases that resulted in +fruitless iteration in the simplifier. A good example was when +compiling Text.ParserCombinators.ReadPrec, where we had a definition +like (\x. Get `cast` g) +where Get is a constructor with nonzero arity. Then mkLam eta-expanded +the Get, and the next iteration eta-reduced it, and then eta-expanded +it again. + +Note also the side condition for the case of coercion binders. +It does not make sense to transform + /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) +because the latter is not well-kinded. + +************************************************************************ +* * + Eta expansion +* * +************************************************************************ +-} + +tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr + -> SimplM (ArityType, OutExpr) +-- See Note [Eta-expanding at let bindings] +-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then +-- (a) rhs' has manifest arity n +-- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom +tryEtaExpandRhs mode bndr rhs + | Just join_arity <- isJoinId_maybe bndr + = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs + oss = [idOneShotInfo id | id <- join_bndrs, isId id] + arity_type | exprIsDeadEnd join_body = ABot (length oss) + | otherwise = ATop oss + ; return (arity_type, rhs) } + -- Note [Do not eta-expand join points] + -- But do return the correct arity and bottom-ness, because + -- these are used to set the bndr's IdInfo (#15517) + -- Note [Invariants on join points] invariant 2b, in GHC.Core + + | sm_eta_expand mode -- Provided eta-expansion is on + , new_arity > old_arity -- And the current manifest arity isn't enough + , want_eta rhs + = do { tick (EtaExpansion bndr) + ; return (arity_type, etaExpandAT arity_type rhs) } + + | otherwise + = return (arity_type, rhs) + + where + dflags = sm_dflags mode + old_arity = exprArity rhs + + arity_type = findRhsArity dflags bndr rhs old_arity + `maxWithArity` idCallArity bndr + new_arity = arityTypeArity arity_type + + -- See Note [Which RHSs do we eta-expand?] + want_eta (Cast e _) = want_eta e + want_eta (Tick _ e) = want_eta e + want_eta (Lam b e) | isTyVar b = want_eta e + want_eta (App e a) | exprIsTrivial a = want_eta e + want_eta (Var {}) = False + want_eta (Lit {}) = False + want_eta _ = True +{- + want_eta _ = case arity_type of + ATop (os:_) -> isOneShotInfo os + ATop [] -> False + ABot {} -> True +-} + +{- +Note [Eta-expanding at let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now eta expand at let-bindings, which is where the payoff comes. +The most significant thing is that we can do a simple arity analysis +(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas + +One useful consequence of not eta-expanding lambdas is this example: + genMap :: C a => ... + {-# INLINE genMap #-} + genMap f xs = ... + + myMap :: D a => ... + {-# INLINE myMap #-} + myMap = genMap + +Notice that 'genMap' should only inline if applied to two arguments. +In the stable unfolding for myMap we'll have the unfolding + (\d -> genMap Int (..d..)) +We do not want to eta-expand to + (\d f xs -> genMap Int (..d..) f xs) +because then 'genMap' will inline, and it really shouldn't: at least +as far as the programmer is concerned, it's not applied to two +arguments! + +Note [Which RHSs do we eta-expand?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't eta-expand: + +* Trivial RHSs, e.g. f = g + If we eta expand do + f = \x. g x + we'll just eta-reduce again, and so on; so the + simplifier never terminates. + +* PAPs: see Note [Do not eta-expand PAPs] + +What about things like this? + f = case y of p -> \x -> blah + +Here we do eta-expand. This is a change (Jun 20), but if we have +really decided that f has arity 1, then putting that lambda at the top +seems like a Good idea. + +Note [Do not eta-expand PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have old_arity = manifestArity rhs, which meant that we +would eta-expand even PAPs. But this gives no particular advantage, +and can lead to a massive blow-up in code size, exhibited by #9020. +Suppose we have a PAP + foo :: IO () + foo = returnIO () +Then we can eta-expand do + foo = (\eta. (returnIO () |> sym g) eta) |> g +where + g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) + +But there is really no point in doing this, and it generates masses of +coercions and whatnot that eventually disappear again. For T9020, GHC +allocated 6.6G before, and 0.8G afterwards; and residency dropped from +1.8G to 45M. + +Moreover, if we eta expand + f = g d ==> f = \x. g d x +that might in turn make g inline (if it has an inline pragma), which +we might not want. After all, INLINE pragmas say "inline only when +saturated" so we don't want to be too gung-ho about saturating! + +But note that this won't eta-expand, say + f = \g -> map g +Does it matter not eta-expanding such functions? I'm not sure. Perhaps +strictness analysis will have less to bite on? + +Note [Do not eta-expand join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similarly to CPR (see Note [Don't w/w join points for CPR] in +GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's +eta-expansion, and eta-expanding a join point is fraught with issues like how to +deal with a cast: + + let join $j1 :: IO () + $j1 = ... + $j2 :: Int -> IO () + $j2 n = if n > 0 then $j1 + else ... + + => + + let join $j1 :: IO () + $j1 = (\eta -> ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + $j2 :: Int -> IO () + $j2 n = (\eta -> if n > 0 then $j1 + else ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + +The cast here can't be pushed inside the lambda (since it's not casting to a +function type), so the lambda has to stay, but it can't because it contains a +reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather +than try and detect this situation (and whatever other situations crop up!), we +don't bother; again, any surrounding eta-expansion will improve these join +points anyway, since an outer cast can *always* be pushed inside. By the time +CorePrep comes around, the code is very likely to look more like this: + + let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) + $j1 = (...) eta + $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) + $j2 = if n > 0 then $j1 + else (...) eta + + +************************************************************************ +* * +\subsection{Floating lets out of big lambdas} +* * +************************************************************************ + +Note [Floating and type abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + x = /\a. C e1 e2 +We'd like to float this to + y1 = /\a. e1 + y2 = /\a. e2 + x = /\a. C (y1 a) (y2 a) +for the usual reasons: we want to inline x rather vigorously. + +You may think that this kind of thing is rare. But in some programs it is +common. For example, if you do closure conversion you might get: + + data a :-> b = forall e. (e -> a -> b) :$ e + + f_cc :: forall a. a :-> a + f_cc = /\a. (\e. id a) :$ () + +Now we really want to inline that f_cc thing so that the +construction of the closure goes away. + +So I have elaborated simplLazyBind to understand right-hand sides that look +like + /\ a1..an. body + +and treat them specially. The real work is done in +GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing +in simplLazyBind as well. + +The same transformation is good when there are lets in the body: + + /\abc -> let(rec) x = e in b + ==> + let(rec) x' = /\abc -> let x = x' a b c in e + in + /\abc -> let x = x' a b c in b + +This is good because it can turn things like: + + let f = /\a -> letrec g = ... g ... in g +into + letrec g' = /\a -> ... g' a ... + in + let f = /\ a -> g' a + +which is better. In effect, it means that big lambdas don't impede +let-floating. + +This optimisation is CRUCIAL in eliminating the junk introduced by +desugaring mutually recursive definitions. Don't eliminate it lightly! + +[May 1999] If we do this transformation *regardless* then we can +end up with some pretty silly stuff. For example, + + let + st = /\ s -> let { x1=r1 ; x2=r2 } in ... + in .. +becomes + let y1 = /\s -> r1 + y2 = /\s -> r2 + st = /\s -> ...[y1 s/x1, y2 s/x2] + in .. + +Unless the "..." is a WHNF there is really no point in doing this. +Indeed it can make things worse. Suppose x1 is used strictly, +and is of the form + + x1* = case f y of { (a,b) -> e } + +If we abstract this wrt the tyvar we then can't do the case inline +as we would normally do. + +That's why the whole transformation is part of the same process that +floats let-bindings and constructor arguments out of RHSs. In particular, +it is guarded by the doFloatFromRhs call in simplLazyBind. + +Note [Which type variables to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Abstract only over the type variables free in the rhs wrt which the +new binding is abstracted. Note that + + * The naive approach of abstracting wrt the + tyvars free in the Id's /type/ fails. Consider: + /\ a b -> let t :: (a,b) = (e1, e2) + x :: a = fst t + in ... + Here, b isn't free in x's type, but we must nevertheless + abstract wrt b as well, because t's type mentions b. + Since t is floated too, we'd end up with the bogus: + poly_t = /\ a b -> (e1, e2) + poly_x = /\ a -> fst (poly_t a *b*) + + * We must do closeOverKinds. Example (#10934): + f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... + Here we want to float 't', but we must remember to abstract over + 'k' as well, even though it is not explicitly mentioned in the RHS, + otherwise we get + t = /\ (f:k->*) (a:k). AccFailure @ (f a) + which is obviously bogus. +-} + +abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats + -> OutExpr -> SimplM ([OutBind], OutExpr) +abstractFloats dflags top_lvl main_tvs floats body + = ASSERT( notNull body_floats ) + ASSERT( isNilOL (sfJoinFloats floats) ) + do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats + ; return (float_binds, GHC.Core.Subst.substExpr subst body) } + where + is_top_lvl = isTopLevel top_lvl + main_tv_set = mkVarSet main_tvs + body_floats = letFloatBinds (sfLetFloats floats) + empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) + + abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind) + abstract subst (NonRec id rhs) + = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id + ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' + subst' = GHC.Core.Subst.extendIdSubst subst id poly_app + ; return (subst', NonRec poly_id2 poly_rhs) } + where + rhs' = GHC.Core.Subst.substExpr subst rhs + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = scopedSort $ + filter (`elemVarSet` main_tv_set) $ + closeOverKindsList $ + exprSomeFreeVarsList isTyVar rhs' + + abstract subst (Rec prs) + = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids + ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) + poly_pairs = [ mk_poly2 poly_id tvs_here rhs' + | (poly_id, rhs) <- poly_ids `zip` rhss + , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] + ; return (subst', Rec poly_pairs) } + where + (ids,rhss) = unzip prs + -- For a recursive group, it's a bit of a pain to work out the minimal + -- set of tyvars over which to abstract: + -- /\ a b c. let x = ...a... in + -- letrec { p = ...x...q... + -- q = .....p...b... } in + -- ... + -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted + -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. + -- Since it's a pain, we just use the whole set, which is always safe + -- + -- If you ever want to be more selective, remember this bizarre case too: + -- x::a = x + -- Here, we must abstract 'x' over 'a'. + tvs_here = scopedSort main_tvs + + mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) + mk_poly1 tvs_here var + = do { uniq <- getUniqueM + ; let poly_name = setNameUnique (idName var) uniq -- Keep same name + poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id + mkLocalId poly_name (idMult var) poly_ty + ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } + -- In the olden days, it was crucial to copy the occInfo of the original var, + -- because we were looking at occurrence-analysed but as yet unsimplified code! + -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking + -- at already simplified code, so it doesn't matter + -- + -- It's even right to retain single-occurrence or dead-var info: + -- Suppose we started with /\a -> let x = E in B + -- where x occurs once in B. Then we transform to: + -- let x' = /\a -> E in /\a -> let x* = x' a in B + -- where x* has an INLINE prag on it. Now, once x* is inlined, + -- the occurrences of x' will be just the occurrences originally + -- pinned on x. + + mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) + mk_poly2 poly_id tvs_here rhs + = (poly_id `setIdUnfolding` unf, poly_rhs) + where + poly_rhs = mkLams tvs_here rhs + unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs + + -- We want the unfolding. Consider + -- let + -- x = /\a. let y = ... in Just y + -- in body + -- Then we float the y-binding out (via abstractFloats and addPolyBind) + -- but 'x' may well then be inlined in 'body' in which case we'd like the + -- opportunity to inline 'y' too. + +{- +Note [Abstract over coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the +type variable a. Rather than sort this mess out, we simply bale out and abstract +wrt all the type variables if any of them are coercion variables. + + +Historical note: if you use let-bindings instead of a substitution, beware of this: + + -- Suppose we start with: + -- + -- x = /\ a -> let g = G in E + -- + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E + -- + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) + +************************************************************************ +* * + prepareAlts +* * +************************************************************************ + +prepareAlts tries these things: + +1. filterAlts: eliminate alternatives that cannot match, including + the DEFAULT alternative. Here "cannot match" includes knowledge + from GADTs + +2. refineDefaultAlt: if the DEFAULT alternative can match only one + possible constructor, then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + See CoreUtils Note [Refine DEFAULT case alternatives] + +3. combineIdenticalAlts: combine identical alternatives into a DEFAULT. + See CoreUtils Note [Combine identical alternatives], which also + says why we do this on InAlts not on OutAlts + +4. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) + +It's a good idea to do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! +-} + +prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +-- The returned alternatives can be empty, none are possible +prepareAlts scrut case_bndr' alts + | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr') + -- Case binder is needed just for its type. Note that as an + -- OutId, it has maximum information; this is important. + -- Test simpl013 is an example + = do { us <- getUniquesM + ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts + (yes2, alts2) = refineDefaultAlt us (idMult case_bndr') tc tys idcs1 alts1 + -- the multiplicity on case_bndr's is the multiplicity of the + -- case expression The newly introduced patterns in + -- refineDefaultAlt must be scaled by this multiplicity + (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 + -- "idcs" stands for "impossible default data constructors" + -- i.e. the constructors that can't match the default case + ; when yes2 $ tick (FillInCaseDefault case_bndr') + ; when yes3 $ tick (AltMerge case_bndr') + ; return (idcs3, alts3) } + + | otherwise -- Not a data type, so nothing interesting happens + = return ([], alts) + where + imposs_cons = case scrut of + Var v -> otherCons (idUnfolding v) + _ -> [] + + +{- +************************************************************************ +* * + mkCase +* * +************************************************************************ + +mkCase tries these things + +* Note [Nerge nested cases] +* Note [Eliminate identity case] +* Note [Scrutinee constant folding] + +Note [Merge Nested Cases] +~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> let b'=b in rhsn + pn -> rhsn ... + ... po -> let b'=b in rhso + po -> rhso _ -> let b'=b in rhsd + _ -> rhsd + } + +which merges two cases in one case when -- the default alternative of +the outer case scrutises the same variable as the outer case. This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. + +Note [Eliminate Identity Case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of ===> e + True -> True; + False -> False + +and similar friends. + +Note [Scrutinee Constant Folding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case x op# k# of _ { ===> case x of _ { + a1# -> e1 (a1# inv_op# k#) -> e1 + a2# -> e2 (a2# inv_op# k#) -> e2 + ... ... + DEFAULT -> ed DEFAULT -> ed + + where (x op# k#) inv_op# k# == x + +And similarly for commuted arguments and for some unary operations. + +The purpose of this transformation is not only to avoid an arithmetic +operation at runtime but to allow other transformations to apply in cascade. + +Example with the "Merge Nested Cases" optimization (from #12877): + + main = case t of t0 + 0## -> ... + DEFAULT -> case t0 `minusWord#` 1## of t1 + 0## -> ... + DEFAULT -> case t1 `minusWord#` 1## of t2 + 0## -> ... + DEFAULT -> case t2 `minusWord#` 1## of _ + 0## -> ... + DEFAULT -> ... + + becomes: + + main = case t of _ + 0## -> ... + 1## -> ... + 2## -> ... + 3## -> ... + DEFAULT -> ... + +There are some wrinkles + +* Do not apply caseRules if there is just a single DEFAULT alternative + case e +# 3# of b { DEFAULT -> rhs } + If we applied the transformation here we would (stupidly) get + case a of b' { DEFAULT -> let b = e +# 3# in rhs } + and now the process may repeat, because that let will really + be a case. + +* The type of the scrutinee might change. E.g. + case tagToEnum (x :: Int#) of (b::Bool) + False -> e1 + True -> e2 + ==> + case x of (b'::Int#) + DEFAULT -> e1 + 1# -> e2 + +* The case binder may be used in the right hand sides, so we need + to make a local binding for it, if it is alive. e.g. + case e +# 10# of b + DEFAULT -> blah...b... + 44# -> blah2...b... + ===> + case e of b' + DEFAULT -> let b = b' +# 10# in blah...b... + 34# -> let b = 44# in blah2...b... + + Note that in the non-DEFAULT cases we know what to bind 'b' to, + whereas in the DEFAULT case we must reconstruct the original value. + But NB: we use b'; we do not duplicate 'e'. + +* In dataToTag we might need to make up some fake binders; + see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold +-} + +mkCase, mkCase1, mkCase2, mkCase3 + :: DynFlags + -> OutExpr -> OutId + -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order + -> SimplM OutExpr + +-------------------------------------------------- +-- 1. Merge Nested Cases +-------------------------------------------------- + +mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) + | gopt Opt_CaseMerge dflags + , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) + <- stripTicksTop tickishFloatable deflt_rhs + , inner_scrut_var == outer_bndr + = do { tick (CaseMerge outer_bndr) + + ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) + (con, args, wrap_rhs rhs) + -- Simplifier's no-shadowing invariant should ensure + -- that outer_bndr is not shadowed by the inner patterns + wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs + -- The let is OK even for unboxed binders, + + wrapped_alts | isDeadBinder inner_bndr = inner_alts + | otherwise = map wrap_alt inner_alts + + merged_alts = mergeAlts outer_alts wrapped_alts + -- NB: mergeAlts gives priority to the left + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + + ; fmap (mkTicks ticks) $ + mkCase1 dflags scrut outer_bndr alts_ty merged_alts + } + -- Warning: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- mkCase applied to them, so they won't have a case in their default + -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr + -- in munge_rhs may put a case into the DEFAULT branch! + +mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Eliminate Identity Case +-------------------------------------------------- + +mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case + | all identity_alt alts + = do { tick (CaseIdentity case_bndr) + ; return (mkTicks ticks $ re_cast scrut rhs1) } + where + ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) + identity_alt (con, args, rhs) = check_eq rhs con args + + check_eq (Cast rhs co) con args -- See Note [RHS casts] + = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args + check_eq (Tick t e) alt args + = tickishFloatable t && check_eq e alt args + + check_eq (Lit lit) (LitAlt lit') _ = lit == lit' + check_eq (Var v) _ _ | v == case_bndr = True + check_eq (Var v) (DataAlt con) args + | null arg_tys, null args = v == dataConWorkId con + -- Optimisation only + check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + check_eq _ _ _ = False + + arg_tys = tyConAppArgs (idType case_bndr) + + -- Note [RHS casts] + -- ~~~~~~~~~~~~~~~~ + -- We've seen this: + -- case e of x { _ -> x `cast` c } + -- And we definitely want to eliminate this case, to give + -- e `cast` c + -- So we throw away the cast from the RHS, and reconstruct + -- it at the other end. All the RHS casts must be the same + -- if (all identity_alt alts) holds. + -- + -- Don't worry about nested casts, because the simplifier combines them + + re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co + re_cast scrut _ = scrut + +mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Scrutinee Constant Folding +-------------------------------------------------- + +mkCase2 dflags scrut bndr alts_ty alts + | -- See Note [Scrutinee Constant Folding] + case alts of -- Not if there is just a DEFAULT alternative + [(DEFAULT,_,_)] -> False + _ -> True + , gopt Opt_CaseFolding dflags + , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut + = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') + + ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts + -- mapMaybeM: discard unreachable alternatives + -- See Note [Unreachable caseRules alternatives] + -- in GHC.Core.Opt.ConstantFold + + ; mkCase3 dflags scrut' bndr' alts_ty $ + add_default (re_sort alts') + } + + | otherwise + = mkCase3 dflags scrut bndr alts_ty alts + where + -- We need to keep the correct association between the scrutinee and its + -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with + -- "let bndr = ... in": + -- + -- case v + 10 of y =====> case v of y + -- 20 -> e1 10 -> let y = 20 in e1 + -- DEFAULT -> e2 DEFAULT -> let y = v + 10 in e2 + -- + -- Other transformations give: =====> case v of y' + -- 10 -> let y = 20 in e1 + -- DEFAULT -> let y = y' + 10 in e2 + -- + -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, + -- to construct an expression equivalent to the original one, for use + -- in the DEFAULT case + + tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id + -> CoreAlt -> SimplM (Maybe CoreAlt) + tx_alt tx_con mk_orig new_bndr (con, bs, rhs) + = case tx_con con of + Nothing -> return Nothing + Just con' -> do { bs' <- mk_new_bndrs new_bndr con' + ; return (Just (con', bs', rhs')) } + where + rhs' | isDeadBinder bndr = rhs + | otherwise = bindNonRec bndr orig_val rhs + + orig_val = case con of + DEFAULT -> mk_orig new_bndr + LitAlt l -> Lit l + DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs + + mk_new_bndrs new_bndr (DataAlt dc) + | not (isNullaryRepDataCon dc) + = -- For non-nullary data cons we must invent some fake binders + -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold + do { us <- getUniquesM + ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc + (tyConAppArgs (idType new_bndr)) + ; return (ex_tvs ++ arg_ids) } + mk_new_bndrs _ _ = return [] + + re_sort :: [CoreAlt] -> [CoreAlt] + -- Sort the alternatives to re-establish + -- GHC.Core Note [Case expression invariants] + re_sort alts = sortBy cmpAlt alts + + add_default :: [CoreAlt] -> [CoreAlt] + -- See Note [Literal cases] + add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts + add_default alts = alts + +{- Note [Literal cases] +~~~~~~~~~~~~~~~~~~~~~~~ +If we have + case tagToEnum (a ># b) of + False -> e1 + True -> e2 + +then caseRules for TagToEnum will turn it into + case tagToEnum (a ># b) of + 0# -> e1 + 1# -> e2 + +Since the case is exhaustive (all cases are) we can convert it to + case tagToEnum (a ># b) of + DEFAULT -> e1 + 1# -> e2 + +This may generate sligthtly better code (although it should not, since +all cases are exhaustive) and/or optimise better. I'm not certain that +it's necessary, but currently we do make this change. We do it here, +NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] +in GHC.Core.Opt.ConstantFold) +-} + +-------------------------------------------------- +-- Catch-all +-------------------------------------------------- +mkCase3 _dflags scrut bndr alts_ty alts + = return (Case scrut bndr alts_ty alts) + +-- See Note [Exitification] and Note [Do not inline exit join points] in +-- GHC.Core.Opt.Exitify +-- This lives here (and not in Id) because occurrence info is only valid on +-- InIds, so it's crucial that isExitJoinId is only called on freshly +-- occ-analysed code. It's not a generic function you can call anywhere. +isExitJoinId :: Var -> Bool +isExitJoinId id + = isJoinId id + && isOneOcc (idOccInfo id) + && occ_in_lam (idOccInfo id) == IsInsideLam + +{- +Note [Dead binders] +~~~~~~~~~~~~~~~~~~~~ +Note that dead-ness is maintained by the simplifier, so that it is +accurate after simplification as well as before. + + +Note [Cascading case merge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case merging should cascade in one sweep, because it +happens bottom-up + + case e of a { + DEFAULT -> case a of b + DEFAULT -> case b of c { + DEFAULT -> e + A -> ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> case a of b + DEFAULT -> let c = b in e + A -> let c = b in ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> let b = a in let c = b in e + A -> let b = a in let c = b in ea + B -> let b = a in eb + C -> ec + + +However here's a tricky case that we still don't catch, and I don't +see how to catch it in one pass: + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +After occurrence analysis (and its binder-swap) we get this + + case x of c1 { I# a1 -> + let x = c1 in -- Binder-swap addition + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +When we simplify the inner case x, we'll see that +x=c1=I# a1. So we'll bind a2 to a1, and get + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case a1 of ... + +This is correct, but we can't do a case merge in this sweep +because c2 /= a1. Reason: the binding c1=I# a1 went inwards +without getting changed to c1=I# c2. + +I don't think this is worth fixing, even if I knew how. It'll +all come out in the next pass anyway. +-} diff --git a/GHC/Core/Opt/SpecConstr.hs b/GHC/Core/Opt/SpecConstr.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/SpecConstr.hs @@ -0,0 +1,2362 @@ +{- +ToDo [Oct 2013] +~~~~~~~~~~~~~~~ +1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) +2. Nuke NoSpecConstr + + +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SpecConstr]{Specialise over constructors} +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Core.Opt.SpecConstr( + specConstrProgram, + SpecConstrAnnotation(..) + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils +import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) +import GHC.Core.FVs ( exprsFreeVarsList ) +import GHC.Core.Opt.Monad +import GHC.Types.Literal ( litIsLifted ) +import GHC.Driver.Types ( ModGuts(..) ) +import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs ) +import GHC.Core.DataCon +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.Rules +import GHC.Core.Type hiding ( substTy ) +import GHC.Core.TyCon ( tyConName ) +import GHC.Core.Multiplicity +import GHC.Types.Id +import GHC.Core.Ppr ( pprParendExpr ) +import GHC.Core.Make ( mkImpossibleExpr ) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) + , gopt, hasPprDebug ) +import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Serialized ( deserializeWithData ) +import GHC.Utils.Misc +import GHC.Data.Pair +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.FM +import GHC.Utils.Monad +import Control.Monad ( zipWithM ) +import Data.List +import GHC.Builtin.Names ( specTyConName ) +import GHC.Unit.Module +import GHC.Core.TyCon ( TyCon ) +import GHC.Exts( SpecConstrAnnotation(..) ) +import Data.Ord( comparing ) + +{- +----------------------------------------------------- + Game plan +----------------------------------------------------- + +Consider + drop n [] = [] + drop 0 xs = [] + drop n (x:xs) = drop (n-1) xs + +After the first time round, we could pass n unboxed. This happens in +numerical code too. Here's what it looks like in Core: + + drop n xs = case xs of + [] -> [] + (y:ys) -> case n of + I# n# -> case n# of + 0 -> [] + _ -> drop (I# (n# -# 1#)) xs + +Notice that the recursive call has an explicit constructor as argument. +Noticing this, we can make a specialised version of drop + + RULE: drop (I# n#) xs ==> drop' n# xs + + drop' n# xs = let n = I# n# in ...orig RHS... + +Now the simplifier will apply the specialisation in the rhs of drop', giving + + drop' n# xs = case xs of + [] -> [] + (y:ys) -> case n# of + 0 -> [] + _ -> drop' (n# -# 1#) xs + +Much better! + +We'd also like to catch cases where a parameter is carried along unchanged, +but evaluated each time round the loop: + + f i n = if i>0 || i>n then i else f (i*2) n + +Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. +In Core, by the time we've w/wd (f is strict in i) we get + + f i# n = case i# ># 0 of + False -> I# i# + True -> case n of { I# n# -> + case i# ># n# of + False -> I# i# + True -> f (i# *# 2#) n + +At the call to f, we see that the argument, n is known to be (I# n#), +and n is evaluated elsewhere in the body of f, so we can play the same +trick as above. + + +Note [Reboxing] +~~~~~~~~~~~~~~~ +We must be careful not to allocate the same constructor twice. Consider + f p = (...(case p of (a,b) -> e)...p..., + ...let t = (r,s) in ...t...(f t)...) +At the recursive call to f, we can see that t is a pair. But we do NOT want +to make a specialised copy: + f' a b = let p = (a,b) in (..., ...) +because now t is allocated by the caller, then r and s are passed to the +recursive call, which allocates the (r,s) pair again. + +This happens if + (a) the argument p is used in other than a case-scrutinisation way. + (b) the argument to the call is not a 'fresh' tuple; you have to + look into its unfolding to see that it's a tuple + +Hence the "OR" part of Note [Good arguments] below. + +ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves +allocation, but does perhaps save evals. In the RULE we'd have +something like + + f (I# x#) = f' (I# x#) x# + +If at the call site the (I# x) was an unfolding, then we'd have to +rely on CSE to eliminate the duplicate allocation.... This alternative +doesn't look attractive enough to pursue. + +ALTERNATIVE 3: ignore the reboxing problem. The trouble is that +the conservative reboxing story prevents many useful functions from being +specialised. Example: + foo :: Maybe Int -> Int -> Int + foo (Just m) 0 = 0 + foo x@(Just m) n = foo x (n-m) +Here the use of 'x' will clearly not require boxing in the specialised function. + +The strictness analyser has the same problem, in fact. Example: + f p@(a,b) = ... +If we pass just 'a' and 'b' to the worker, it might need to rebox the +pair to create (a,b). A more sophisticated analysis might figure out +precisely the cases in which this could happen, but the strictness +analyser does no such analysis; it just passes 'a' and 'b', and hopes +for the best. + +So my current choice is to make SpecConstr similarly aggressive, and +ignore the bad potential of reboxing. + + +Note [Good arguments] +~~~~~~~~~~~~~~~~~~~~~ +So we look for + +* A self-recursive function. Ignore mutual recursion for now, + because it's less common, and the code is simpler for self-recursion. + +* EITHER + + a) At a recursive call, one or more parameters is an explicit + constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + + OR + + b) At a recursive call, one or more parameters has an unfolding + that is an explicit constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + AND + Those are the only uses of the parameter (see Note [Reboxing]) + + +What to abstract over +~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a complication with type arguments. If the call +site looks like + + f p = ...f ((:) [a] x xs)... + +then our specialised function look like + + f_spec x xs = let p = (:) [a] x xs in ....as before.... + +This only makes sense if either + a) the type variable 'a' is in scope at the top of f, or + b) the type variable 'a' is an argument to f (and hence fs) + +Actually, (a) may hold for value arguments too, in which case +we may not want to pass them. Suppose 'x' is in scope at f's +defn, but xs is not. Then we'd like + + f_spec xs = let p = (:) [a] x xs in ....as before.... + +Similarly (b) may hold too. If x is already an argument at the +call, no need to pass it again. + +Finally, if 'a' is not in scope at the call site, we could abstract +it as we do the term variables: + + f_spec a x xs = let p = (:) [a] x xs in ...as before... + +So the grand plan is: + + * abstract the call site to a constructor-only pattern + e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) + + * Find the free variables of the abstracted pattern + + * Pass these variables, less any that are in scope at + the fn defn. But see Note [Shadowing] below. + + +NOTICE that we only abstract over variables that are not in scope, +so we're in no danger of shadowing variables used in "higher up" +in f_spec's RHS. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +In this pass we gather up usage information that may mention variables +that are bound between the usage site and the definition site; or (more +seriously) may be bound to something different at the definition site. +For example: + + f x = letrec g y v = let x = ... + in ...(g (a,b) x)... + +Since 'x' is in scope at the call site, we may make a rewrite rule that +looks like + RULE forall a,b. g (a,b) x = ... +But this rule will never match, because it's really a different 'x' at +the call site -- and that difference will be manifest by the time the +simplifier gets to it. [A worry: the simplifier doesn't *guarantee* +no-shadowing, so perhaps it may not be distinct?] + +Anyway, the rule isn't actually wrong, it's just not useful. One possibility +is to run deShadowBinds before running SpecConstr, but instead we run the +simplifier. That gives the simplest possible program for SpecConstr to +chew on; and it virtually guarantees no shadowing. + +Note [Specialising for constant parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This one is about specialising on a *constant* (but not necessarily +constructor) argument + + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (+1) + +It produces + + lvl_rmV :: GHC.Base.Int -> GHC.Base.Int + lvl_rmV = + \ (ds_dlk :: GHC.Base.Int) -> + case ds_dlk of wild_alH { GHC.Base.I# x_alG -> + GHC.Base.I# (GHC.Prim.+# x_alG 1) + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sme of ds_Xlw { + __DEFAULT -> + case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> + T.$wfoo ww1_Xmz lvl_rmV + }; + 0 -> 0 + } + +The recursive call has lvl_rmV as its argument, so we could create a specialised copy +with that argument baked in; that is, not passed at all. Now it can perhaps be inlined. + +When is this worth it? Call the constant 'lvl' +- If 'lvl' has an unfolding that is a constructor, see if the corresponding + parameter is scrutinised anywhere in the body. + +- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding + parameter is applied (...to enough arguments...?) + + Also do this is if the function has RULES? + +Also + +Note [Specialising for lambda parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (\n -> n-m) + +This is subtly different from the previous one in that we get an +explicit lambda as the argument: + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sm8 of ds_Xlr { + __DEFAULT -> + case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> + T.$wfoo + ww1_Xmq + (\ (n_ad3 :: GHC.Base.Int) -> + case n_ad3 of wild_alB { GHC.Base.I# x_alA -> + GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) + }) + }; + 0 -> 0 + } + +I wonder if SpecConstr couldn't be extended to handle this? After all, +lambda is a sort of constructor for functions and perhaps it already +has most of the necessary machinery? + +Furthermore, there's an immediate win, because you don't need to allocate the lambda +at the call site; and if perchance it's called in the recursive call, then you +may avoid allocating it altogether. Just like for constructors. + +Looks cool, but probably rare...but it might be easy to implement. + + +Note [SpecConstr for casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a :: * + data instance T Int = T Int + + foo n = ... + where + go (T 0) = 0 + go (T n) = go (T (n-1)) + +The recursive call ends up looking like + go (T (I# ...) `cast` g) +So we want to spot the constructor application inside the cast. +That's why we have the Cast case in argToPat + +Note [Local recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a *local* recursive group, we can see all the calls to the +function, so we seed the specialisation loop from the calls in the +body, not from the calls in the RHS. Consider: + + bar m n = foo n (n,n) (n,n) (n,n) (n,n) + where + foo n p q r s + | n == 0 = m + | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s } + | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s } + | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s } + | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) } + +If we start with the RHSs of 'foo', we get lots and lots of specialisations, +most of which are not needed. But if we start with the (single) call +in the rhs of 'bar' we get exactly one fully-specialised copy, and all +the recursive calls go to this fully-specialised copy. Indeed, the original +function is later collected as dead code. This is very important in +specialising the loops arising from stream fusion, for example in NDP where +we were getting literally hundreds of (mostly unused) specialisations of +a local function. + +In a case like the above we end up never calling the original un-specialised +function. (Although we still leave its code around just in case.) + +However, if we find any boring calls in the body, including *unsaturated* +ones, such as + letrec foo x y = ....foo... + in map foo xs +then we will end up calling the un-specialised function, so then we *should* +use the calls in the un-specialised RHS as seeds. We call these +"boring call patterns", and callsToPats reports if it finds any of these. + +Note [Seeding top-level recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This seeding is done in the binding for seed_calls in specRec. + +1. If all the bindings in a top-level recursive group are local (not + exported), then all the calls are in the rest of the top-level + bindings. This means we can specialise with those call patterns + ONLY, and NOT with the RHSs of the recursive group (exactly like + Note [Local recursive groups]) + +2. But if any of the bindings are exported, the function may be called + with any old arguments, so (for lack of anything better) we specialise + based on + (a) the call patterns in the RHS + (b) the call patterns in the rest of the top-level bindings + NB: before Apr 15 we used (a) only, but Dimitrios had an example + where (b) was crucial, so I added that. + Adding (b) also improved nofib allocation results: + multiplier: 4% better + minimax: 2.8% better + +Actually in case (2), instead of using the calls from the RHS, it +would be better to specialise in the importing module. We'd need to +add an INLINABLE pragma to the function, and then it can be +specialised in the importing scope, just as is done for type classes +in GHC.Core.Opt.Specialise.specImports. This remains to be done (#10346). + +Note [Top-level recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To get the call usage information from "the rest of the top level +bindings" (c.f. Note [Seeding top-level recursive groups]), we work +backwards through the top-level bindings so we see the usage before we +get to the binding of the function. Before we can collect the usage +though, we go through all the bindings and add them to the +environment. This is necessary because usage is only tracked for +functions in the environment. These two passes are called + 'go' and 'goEnv' +in specConstrProgram. (Looks a bit revolting to me.) + +Note [Do not specialise diverging functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Specialising a function that just diverges is a waste of code. +Furthermore, it broke GHC (simpl014) thus: + {-# STR Sb #-} + f = \x. case x of (a,b) -> f x +If we specialise f we get + f = \x. case x of (a,b) -> fspec a b +But fspec doesn't have decent strictness info. As it happened, +(f x) :: IO t, so the state hack applied and we eta expanded fspec, +and hence f. But now f's strictness is less than its arity, which +breaks an invariant. + + +Note [Forcing specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With stream fusion and in other similar cases, we want to fully +specialise some (but not necessarily all!) loops regardless of their +size and the number of specialisations. + +We allow a library to do this, in one of two ways (one which is +deprecated): + + 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. + + 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, + and then add *that* type as a parameter to the loop body + +The reason #2 is deprecated is because it requires GHCi, which isn't +available for things like a cross compiler using stage1. + +Here's a (simplified) example from the `vector` package. You may bring +the special 'force specialization' type into scope by saying: + + import GHC.Types (SPEC(..)) + +or by defining your own type (again, deprecated): + + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} + +(Note this is the exact same definition of GHC.Types.SPEC, just +without the annotation.) + +After that, you say: + + foldl :: (a -> b -> a) -> a -> Stream b -> a + {-# INLINE foldl #-} + foldl f z (Stream step s _) = foldl_loop SPEC z s + where + foldl_loop !sPEC z s = case step s of + Yield x s' -> foldl_loop sPEC (f z x) s' + Skip -> foldl_loop sPEC z s' + Done -> z + +SpecConstr will spot the SPEC parameter and always fully specialise +foldl_loop. Note that + + * We have to prevent the SPEC argument from being removed by + w/w which is why (a) SPEC is a sum type, and (b) we have to seq on + the SPEC argument. + + * And lastly, the SPEC argument is ultimately eliminated by + SpecConstr itself so there is no runtime overhead. + +This is all quite ugly; we ought to come up with a better design. + +ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set +sc_force to True when calling specLoop. This flag does four things: + + * Ignore specConstrThreshold, to specialise functions of arbitrary size + (see scTopBind) + * Ignore specConstrCount, to make arbitrary numbers of specialisations + (see specialise) + * Specialise even for arguments that are not scrutinised in the loop + (see argToPat; #4448) + * Only specialise on recursive types a finite number of times + (see is_too_recursive; #5550; Note [Limit recursive specialisation]) + +The flag holds only for specialising a single binding group, and NOT +for nested bindings. (So really it should be passed around explicitly +and not stored in ScEnv.) #14379 turned out to be caused by + f SPEC x = let g1 x = ... + in ... +We force-specialise f (because of the SPEC), but that generates a specialised +copy of g1 (as well as the original). Alas g1 has a nested binding g2; and +in each copy of g1 we get an unspecialised and specialised copy of g2; and so +on. Result, exponential. So the force-spec flag now only applies to one +level of bindings at a time. + +Mechanism for this one-level-only thing: + + - Switch it on at the call to specRec, in scExpr and scTopBinds + - Switch it off when doing the RHSs; + this can be done very conveniently in decreaseSpecCount + +What alternatives did I consider? + +* Annotating the loop itself doesn't work because (a) it is local and + (b) it will be w/w'ed and having w/w propagating annotations somehow + doesn't seem like a good idea. The types of the loop arguments + really seem to be the most persistent thing. + +* Annotating the types that make up the loop state doesn't work, + either, because (a) it would prevent us from using types like Either + or tuples here, (b) we don't want to restrict the set of types that + can be used in Stream states and (c) some types are fixed by the + user (e.g., the accumulator here) but we still want to specialise as + much as possible. + +Alternatives to ForceSpecConstr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of giving the loop an extra argument of type SPEC, we +also considered *wrapping* arguments in SPEC, thus + data SPEC a = SPEC a | SPEC2 + + loop = \arg -> case arg of + SPEC state -> + case state of (x,y) -> ... loop (SPEC (x',y')) ... + S2 -> error ... +The idea is that a SPEC argument says "specialise this argument +regardless of whether the function case-analyses it". But this +doesn't work well: + * SPEC must still be a sum type, else the strictness analyser + eliminates it + * But that means that 'loop' won't be strict in its real payload +This loss of strictness in turn screws up specialisation, because +we may end up with calls like + loop (SPEC (case z of (p,q) -> (q,p))) +Without the SPEC, if 'loop' were strict, the case would move out +and we'd see loop applied to a pair. But if 'loop' isn't strict +this doesn't look like a specialisable call. + +Note [Limit recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible for ForceSpecConstr to cause an infinite loop of specialisation. +Because there is no limit on the number of specialisations, a recursive call with +a recursive constructor as an argument (for example, list cons) will generate +a specialisation for that constructor. If the resulting specialisation also +contains a recursive call with the constructor, this could proceed indefinitely. + +For example, if ForceSpecConstr is on: + loop :: [Int] -> [Int] -> [Int] + loop z [] = z + loop z (x:xs) = loop (x:z) xs +this example will create a specialisation for the pattern + loop (a:b) c = loop' a b c + + loop' a b [] = (a:b) + loop' a b (x:xs) = loop (x:(a:b)) xs +and a new pattern is found: + loop (a:(b:c)) d = loop'' a b c d +which can continue indefinitely. + +Roman's suggestion to fix this was to stop after a couple of times on recursive types, +but still specialising on non-recursive types as much as possible. + +To implement this, we count the number of times we have gone round the +"specialise recursively" loop ('go' in 'specRec'). Once have gone round +more than N times (controlled by -fspec-constr-recursive=N) we check + + - If sc_force is off, and sc_count is (Just max) then we don't + need to do anything: trim_pats will limit the number of specs + + - Otherwise check if any function has now got more than (sc_count env) + specialisations. If sc_count is "no limit" then we arbitrarily + choose 10 as the limit (ugh). + +See #5550. Also #13623, where this test had become over-aggressive, +and we lost a wonderful specialisation that we really wanted! + +Note [NoSpecConstr] +~~~~~~~~~~~~~~~~~~~ +The ignoreDataCon stuff allows you to say + {-# ANN type T NoSpecConstr #-} +to mean "don't specialise on arguments of this type". It was added +before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised +regardless of size; and then we needed a way to turn that *off*. Now +that we have ForceSpecConstr, this NoSpecConstr is probably redundant. +(Used only for PArray, TODO: remove?) + +----------------------------------------------------- + Stuff not yet handled +----------------------------------------------------- + +Here are notes arising from Roman's work that I don't want to lose. + +Example 1 +~~~~~~~~~ + data T a = T !a + + foo :: Int -> T Int -> Int + foo 0 t = 0 + foo x t | even x = case t of { T n -> foo (x-n) t } + | otherwise = foo (x-1) t + +SpecConstr does no specialisation, because the second recursive call +looks like a boxed use of the argument. A pity. + + $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sFw = + \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> + case ww_sFo of ds_Xw6 [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { + __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; + 0 -> + case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> + case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> + $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy + } } }; + 0 -> 0 + +Example 2 +~~~~~~~~~ + data a :*: b = !a :*: !b + data T a = T !a + + foo :: (Int :*: T Int) -> Int + foo (0 :*: t) = 0 + foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) } + | otherwise = foo ((x-1) :*: t) + +Very similar to the previous one, except that the parameters are now in +a strict tuple. Before SpecConstr, we have + + $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sG3 = + \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T + GHC.Base.Int) -> + case ww_sFU of ds_Xws [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { + __DEFAULT -> + case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 + }; + 0 -> + case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> + case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 + } } }; + 0 -> 0 } + +We get two specialisations: +"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) + = Foo.$s$wfoo1 a_sFB sc_sGC ; +"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) + = Foo.$s$wfoo y_aFp sc_sGC ; + +But perhaps the first one isn't good. After all, we know that tpl_B2 is +a T (I# x) really, because T is strict and Int has one constructor. (We can't +unbox the strict fields, because T is polymorphic!) + +************************************************************************ +* * +\subsection{Top level wrapper stuff} +* * +************************************************************************ +-} + +specConstrProgram :: ModGuts -> CoreM ModGuts +specConstrProgram guts + = do + dflags <- getDynFlags + us <- getUniqueSupplyM + (_, annos) <- getFirstAnnotations deserializeWithData guts + this_mod <- getModule + let binds' = reverse $ fst $ initUs us $ do + -- Note [Top-level recursive groups] + (env, binds) <- goEnv (initScEnv dflags this_mod annos) + (mg_binds guts) + -- binds is identical to (mg_binds guts), except that the + -- binders on the LHS have been replaced by extendBndr + -- (SPJ this seems like overkill; I don't think the binders + -- will change at all; and we don't substitute in the RHSs anyway!!) + go env nullUsage (reverse binds) + + return (guts { mg_binds = binds' }) + where + -- See Note [Top-level recursive groups] + goEnv env [] = return (env, []) + goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind + (env'', binds') <- goEnv env' binds + return (env'', bind' : binds') + + -- Arg list of bindings is in reverse order + go _ _ [] = return [] + go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind + binds' <- go env usg' binds + return (bind' : binds') + +{- +************************************************************************ +* * +\subsection{Environment: goes downwards} +* * +************************************************************************ + +Note [Work-free values only in environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_vals field keeps track of in-scope value bindings, so +that if we come across (case x of Just y ->...) we can reduce the +case from knowing that x is bound to a pair. + +But only *work-free* values are ok here. For example if the envt had + x -> Just (expensive v) +then we do NOT want to expand to + let y = expensive v in ... +because the x-binding still exists and we've now duplicated (expensive v). + +This seldom happens because let-bound constructor applications are +ANF-ised, but it can happen as a result of on-the-fly transformations in +SpecConstr itself. Here is #7865: + + let { + a'_shr = + case xs_af8 of _ { + [] -> acc_af6; + : ds_dgt [Dmd=] ds_dgu [Dmd=] -> + (expensive x_af7, x_af7 + } } in + let { + ds_sht = + case a'_shr of _ { (p'_afd, q'_afe) -> + TSpecConstr_DoubleInline.recursive + (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) + } } in + +When processed knowing that xs_af8 was bound to a cons, we simplify to + a'_shr = (expensive x_af7, x_af7) +and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. +(There are other occurrences of a'_shr.) No no no. + +It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned +into a work-free value again, thus + a1 = expensive x_af7 + a'_shr = (a1, x_af7) +but that's more work, so until its shown to be important I'm going to +leave it for now. + +Note [Making SpecConstr keener] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this, in (perf/should_run/T9339) + last (filter odd [1..1000]) + +After optimisation, including SpecConstr, we get: + f :: Int# -> Int -> Int + f x y = case remInt# x 2# of + __DEFAULT -> case x of + __DEFAULT -> f (+# wild_Xp 1#) (I# x) + 1000000# -> ... + 0# -> case x of + __DEFAULT -> f (+# wild_Xp 1#) y + 1000000# -> y + +Not good! We build an (I# x) box every time around the loop. +SpecConstr (as described in the paper) does not specialise f, despite +the call (f ... (I# x)) because 'y' is not scrutinised in the body. +But it is much better to specialise f for the case where the argument +is of form (I# x); then we build the box only when returning y, which +is on the cold path. + +Another example: + + f x = ...(g x).... + +Here 'x' is not scrutinised in f's body; but if we did specialise 'f' +then the call (g x) might allow 'g' to be specialised in turn. + +So sc_keen controls whether or not we take account of whether argument is +scrutinised in the body. True <=> ignore that, and specialise whenever +the function is applied to a data constructor. +-} + +data ScEnv = SCE { sc_dflags :: DynFlags, + sc_module :: !Module, + sc_size :: Maybe Int, -- Size threshold + -- Nothing => no limit + + sc_count :: Maybe Int, -- Max # of specialisations for any one fn + -- Nothing => no limit + -- See Note [Avoiding exponential blowup] + + sc_recursive :: Int, -- Max # of specialisations over recursive type. + -- Stops ForceSpecConstr from diverging. + + sc_keen :: Bool, -- Specialise on arguments that are known + -- constructors, even if they are not + -- scrutinised in the body. See + -- Note [Making SpecConstr keener] + + sc_force :: Bool, -- Force specialisation? + -- See Note [Forcing specialisation] + + sc_subst :: Subst, -- Current substitution + -- Maps InIds to OutExprs + + sc_how_bound :: HowBoundEnv, + -- Binds interesting non-top-level variables + -- Domain is OutVars (*after* applying the substitution) + + sc_vals :: ValueEnv, + -- Domain is OutIds (*after* applying the substitution) + -- Used even for top-level bindings (but not imported ones) + -- The range of the ValueEnv is *work-free* values + -- such as (\x. blah), or (Just v) + -- but NOT (Just (expensive v)) + -- See Note [Work-free values only in environment] + + sc_annotations :: UniqFM Name SpecConstrAnnotation + } + +--------------------- +type HowBoundEnv = VarEnv HowBound -- Domain is OutVars + +--------------------- +type ValueEnv = IdEnv Value -- Domain is OutIds +data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors + -- The AltCon is never DEFAULT + | LambdaVal -- Inlinable lambdas or PAPs + +instance Outputable Value where + ppr (ConVal con args) = ppr con <+> interpp'SP args + ppr LambdaVal = text "" + +--------------------- +initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv +initScEnv dflags this_mod anns + = SCE { sc_dflags = dflags, + sc_module = this_mod, + sc_size = specConstrThreshold dflags, + sc_count = specConstrCount dflags, + sc_recursive = specConstrRecursive dflags, + sc_keen = gopt Opt_SpecConstrKeen dflags, + sc_force = False, + sc_subst = emptySubst, + sc_how_bound = emptyVarEnv, + sc_vals = emptyVarEnv, + sc_annotations = anns } + +data HowBound = RecFun -- These are the recursive functions for which + -- we seek interesting call patterns + + | RecArg -- These are those functions' arguments, or their sub-components; + -- we gather occurrence information for these + +instance Outputable HowBound where + ppr RecFun = text "RecFun" + ppr RecArg = text "RecArg" + +scForce :: ScEnv -> Bool -> ScEnv +scForce env b = env { sc_force = b } + +lookupHowBound :: ScEnv -> Id -> Maybe HowBound +lookupHowBound env id = lookupVarEnv (sc_how_bound env) id + +scSubstId :: ScEnv -> Id -> CoreExpr +scSubstId env v = lookupIdSubst (sc_subst env) v + +scSubstTy :: ScEnv -> Type -> Type +scSubstTy env ty = substTy (sc_subst env) ty + +scSubstCo :: ScEnv -> Coercion -> Coercion +scSubstCo env co = substCo (sc_subst env) co + +zapScSubst :: ScEnv -> ScEnv +zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } + +extendScInScope :: ScEnv -> [Var] -> ScEnv + -- Bring the quantified variables into scope +extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars } + + -- Extend the substitution +extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv +extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } + +extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv +extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs } + +extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv +extendHowBound env bndrs how_bound + = env { sc_how_bound = extendVarEnvList (sc_how_bound env) + [(bndr,how_bound) | bndr <- bndrs] } + +extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) +extendBndrsWith how_bound env bndrs + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') + where + (subst', bndrs') = substBndrs (sc_subst env) bndrs + hb_env' = sc_how_bound env `extendVarEnvList` + [(bndr,how_bound) | bndr <- bndrs'] + +extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) +extendBndrWith how_bound env bndr + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound + +extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) +extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') + where + (subst', bndrs') = substRecBndrs (sc_subst env) bndrs + +extendBndr :: ScEnv -> Var -> (ScEnv, Var) +extendBndr env bndr = (env { sc_subst = subst' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + +extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv +extendValEnv env _ Nothing = env +extendValEnv env id (Just cv) + | valueIsWorkFree cv -- Don't duplicate work!! #7865 + = env { sc_vals = extendVarEnv (sc_vals env) id cv } +extendValEnv env _ _ = env + +extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) +-- When we encounter +-- case scrut of b +-- C x y -> ... +-- we want to bind b, to (C x y) +-- NB1: Extends only the sc_vals part of the envt +-- NB2: Kill the dead-ness info on the pattern binders x,y, since +-- they are potentially made alive by the [b -> C x y] binding +extendCaseBndrs env scrut case_bndr con alt_bndrs + = (env2, alt_bndrs') + where + live_case_bndr = not (isDeadBinder case_bndr) + env1 | Var v <- stripTicksTopE (const True) scrut + = extendValEnv env v cval + | otherwise = env -- See Note [Add scrutinee to ValueEnv too] + env2 | live_case_bndr = extendValEnv env1 case_bndr cval + | otherwise = env1 + + alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } + = map zap alt_bndrs + | otherwise + = alt_bndrs + + cval = case con of + DEFAULT -> Nothing + LitAlt {} -> Just (ConVal con []) + DataAlt {} -> Just (ConVal con vanilla_args) + where + vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ + varsToCoreExprs alt_bndrs + + zap v | isTyVar v = v -- See NB2 above + | otherwise = zapIdOccInfo v + + +decreaseSpecCount :: ScEnv -> Int -> ScEnv +-- See Note [Avoiding exponential blowup] +decreaseSpecCount env n_specs + = env { sc_force = False -- See Note [Forcing specialisation] + , sc_count = case sc_count env of + Nothing -> Nothing + Just n -> Just (n `div` (n_specs + 1)) } + -- The "+1" takes account of the original function; + -- See Note [Avoiding exponential blowup] + +--------------------------------------------------- +-- See Note [Forcing specialisation] +ignoreType :: ScEnv -> Type -> Bool +ignoreDataCon :: ScEnv -> DataCon -> Bool +forceSpecBndr :: ScEnv -> Var -> Bool +forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var + +ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) + +ignoreType env ty + = case tyConAppTyCon_maybe ty of + Just tycon -> ignoreTyCon env tycon + _ -> False + +ignoreTyCon :: ScEnv -> TyCon -> Bool +ignoreTyCon env tycon + = lookupUFM (sc_annotations env) (tyConName tycon) == Just NoSpecConstr + +forceSpecFunTy :: ScEnv -> Type -> Bool +forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys + +forceSpecArgTy :: ScEnv -> Type -> Bool +forceSpecArgTy env ty + | Just ty' <- coreView ty = forceSpecArgTy env ty' + +forceSpecArgTy env ty + | Just (tycon, tys) <- splitTyConApp_maybe ty + , tycon /= funTyCon + = tyConName tycon == specTyConName + || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr + || any (forceSpecArgTy env) tys + +forceSpecArgTy _ _ = False + +{- +Note [Add scrutinee to ValueEnv too] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +By the time we get to the call (f y), the ValueEnv +will have a binding for y, and for c + y -> (a,b) + c -> I# v +BUT that's not enough! Looking at the call (f y) we +see that y is pair (a,b), but we also need to know what 'b' is. +So in extendCaseBndrs we must *also* add the binding + b -> I# v +else we lose a useful specialisation for f. This is necessary even +though the simplifier has systematically replaced uses of 'x' with 'y' +and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came +from outside the case. See #4908 for the live example. + +Note [Avoiding exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_count field of the ScEnv says how many times we are prepared to +duplicate a single function. But we must take care with recursive +specialisations. Consider + + let $j1 = let $j2 = let $j3 = ... + in + ...$j3... + in + ...$j2... + in + ...$j1... + +If we specialise $j1 then in each specialisation (as well as the original) +we can specialise $j2, and similarly $j3. Even if we make just *one* +specialisation of each, because we also have the original we'll get 2^n +copies of $j3, which is not good. + +So when recursively specialising we divide the sc_count by the number of +copies we are making at this level, including the original. + + +************************************************************************ +* * +\subsection{Usage information: flows upwards} +* * +************************************************************************ +-} + +data ScUsage + = SCU { + scu_calls :: CallEnv, -- Calls + -- The functions are a subset of the + -- RecFuns in the ScEnv + + scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences + } -- The domain is OutIds + +type CallEnv = IdEnv [Call] +data Call = Call Id [CoreArg] ValueEnv + -- The arguments of the call, together with the + -- env giving the constructor bindings at the call site + -- We keep the function mainly for debug output + +instance Outputable ScUsage where + ppr (SCU { scu_calls = calls, scu_occs = occs }) + = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls + , text "occs =" <+> ppr occs ]) + +instance Outputable Call where + ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) + +nullUsage :: ScUsage +nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } + +combineCalls :: CallEnv -> CallEnv -> CallEnv +combineCalls = plusVarEnv_C (++) + where +-- plus cs ds | length res > 1 +-- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs +-- , text "ds:" <+> ppr ds]) +-- res +-- | otherwise = res +-- where +-- res = cs ++ ds + +combineUsage :: ScUsage -> ScUsage -> ScUsage +combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), + scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } + +combineUsages :: [ScUsage] -> ScUsage +combineUsages [] = nullUsage +combineUsages us = foldr1 combineUsage us + +lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) +lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs + = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, + [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) + +data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument + | UnkOcc -- Used in some unknown way + + | ScrutOcc -- See Note [ScrutOcc] + (DataConEnv [ArgOcc]) -- How the sub-components are used + +type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon + +{- Note [ScrutOcc] +~~~~~~~~~~~~~~~~~~~ +An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, +is *only* taken apart or applied. + + Functions, literal: ScrutOcc emptyUFM + Data constructors: ScrutOcc subs, + +where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, +The domain of the UniqFM is the Unique of the data constructor + +The [ArgOcc] is the occurrences of the *pattern-bound* components +of the data structure. E.g. + data T a = forall b. MkT a b (b->a) +A pattern binds b, x::a, y::b, z::b->a, but not 'a'! + +-} + +instance Outputable ArgOcc where + ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs + ppr UnkOcc = text "unk-occ" + ppr NoOcc = text "no-occ" + +evalScrutOcc :: ArgOcc +evalScrutOcc = ScrutOcc emptyUFM + +-- Experimentally, this version of combineOcc makes ScrutOcc "win", so +-- that if the thing is scrutinised anywhere then we get to see that +-- in the overall result, even if it's also used in a boxed way +-- This might be too aggressive; see Note [Reboxing] Alternative 3 +combineOcc :: ArgOcc -> ArgOcc -> ArgOcc +combineOcc NoOcc occ = occ +combineOcc occ NoOcc = occ +combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) +combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys +combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs +combineOcc UnkOcc UnkOcc = UnkOcc + +combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] +combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys + +setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage +-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee +-- is a variable, and an interesting variable +setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Var v) occ + | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } + | otherwise = usg +setScrutOcc _env usg _other _occ -- Catch-all + = usg + +{- +************************************************************************ +* * +\subsection{The main recursive function} +* * +************************************************************************ + +The main recursive function gathers up usage information, and +creates specialised versions of functions. +-} + +scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) + -- The unique supply is needed when we invent + -- a new name for the specialised function and its args + +scExpr env e = scExpr' env e + +scExpr' env (Var v) = case scSubstId env v of + Var v' -> return (mkVarUsage env v' [], Var v') + e' -> scExpr (zapScSubst env) e' + +scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) +scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) +scExpr' _ e@(Lit {}) = return (nullUsage, e) +scExpr' env (Tick t e) = do (usg, e') <- scExpr env e + return (usg, Tick t e') +scExpr' env (Cast e co) = do (usg, e') <- scExpr env e + return (usg, mkCast e' (scSubstCo env co)) + -- Important to use mkCast here + -- See Note [SpecConstr call patterns] +scExpr' env e@(App _ _) = scApp env (collectArgs e) +scExpr' env (Lam b e) = do let (env', b') = extendBndr env b + (usg, e') <- scExpr env' e + return (usg, Lam b' e') + +scExpr' env (Case scrut b ty alts) + = do { (scrut_usg, scrut') <- scExpr env scrut + ; case isValue (sc_vals env) scrut' of + Just (ConVal con args) -> sc_con_app con args scrut' + _other -> sc_vanilla scrut_usg scrut' + } + where + sc_con_app con args scrut' -- Known constructor; simplify + = do { let (_, bs, rhs) = findAlt con alts + `orElse` (DEFAULT, [], mkImpossibleExpr ty) + alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) + ; scExpr alt_env' rhs } + + sc_vanilla scrut_usg scrut' -- Normal case + = do { let (alt_env,b') = extendBndrWith RecArg env b + -- Record RecArg for the components + + ; (alt_usgs, alt_occs, alts') + <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts + + ; let scrut_occ = foldr combineOcc NoOcc alt_occs + scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ + -- The combined usage of the scrutinee is given + -- by scrut_occ, which is passed to scScrut, which + -- in turn treats a bare-variable scrutinee specially + + ; return (foldr combineUsage scrut_usg' alt_usgs, + Case scrut' b' (scSubstTy env ty) alts') } + + sc_alt env scrut' b' (con,bs,rhs) + = do { let (env1, bs1) = extendBndrsWith RecArg env bs + (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 + ; (usg, rhs') <- scExpr env2 rhs + ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) + scrut_occ = case con of + DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) + _ -> ScrutOcc emptyUFM + ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } + +scExpr' env (Let (NonRec bndr rhs) body) + | isTyVar bndr -- Type-lets may be created by doBeta + = scExpr' (extendScSubst env bndr rhs) body + + | otherwise + = do { let (body_env, bndr') = extendBndr env bndr + ; rhs_info <- scRecRhs env (bndr',rhs) + + ; let body_env2 = extendHowBound body_env [bndr'] RecFun + -- Note [Local let bindings] + rhs' = ri_new_rhs rhs_info + body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') + + ; (body_usg, body') <- scExpr body_env3 body + + -- NB: For non-recursive bindings we inherit sc_force flag from + -- the parent function (see Note [Forcing specialisation]) + ; (spec_usg, specs) <- specNonRec env body_usg rhs_info + + ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } + `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg] + mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body') + } + + +-- A *local* recursive group: see Note [Local recursive groups] +scExpr' env (Let (Rec prs) body) + = do { let (bndrs,rhss) = unzip prs + (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + force_spec = any (forceSpecBndr env) bndrs' + -- Note [Forcing specialisation] + + ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; (body_usg, body') <- scExpr rhs_env2 body + + -- NB: start specLoop from body_usg + ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec) + body_usg rhs_infos + -- Do not unconditionally generate specialisations from rhs_usgs + -- Instead use them only if we find an unspecialised call + -- See Note [Local recursive groups] + + ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg] + bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs)) + -- zipWithEqual: length of returned [SpecInfo] + -- should be the same as incoming [RhsInfo] + + ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, + Let bind' body') } + +{- +Note [Local let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is not uncommon to find this + + let $j = \x. in ...$j True...$j True... + +Here $j is an arbitrary let-bound function, but it often comes up for +join points. We might like to specialise $j for its call patterns. +Notice the difference from a letrec, where we look for call patterns +in the *RHS* of the function. Here we look for call patterns in the +*body* of the let. + +At one point I predicated this on the RHS mentioning the outer +recursive function, but that's not essential and might even be +harmful. I'm not sure. +-} + +scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) + +scApp env (Var fn, args) -- Function is a variable + = ASSERT( not (null args) ) + do { args_w_usgs <- mapM (scExpr env) args + ; let (arg_usgs, args') = unzip args_w_usgs + arg_usg = combineUsages arg_usgs + ; case scSubstId env fn of + fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') + -- Do beta-reduction and try again + + Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', + mkApps (Var fn') args') + + other_fn' -> return (arg_usg, mkApps other_fn' args') } + -- NB: doing this ignores any usage info from the substituted + -- function, but I don't think that matters. If it does + -- we can fix it. + where + doBeta :: OutExpr -> [OutExpr] -> OutExpr + -- ToDo: adjust for System IF + doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) + doBeta fn args = mkApps fn args + +-- The function is almost always a variable, but not always. +-- In particular, if this pass follows float-in, +-- which it may, we can get +-- (let f = ...f... in f) arg1 arg2 +scApp env (other_fn, args) + = do { (fn_usg, fn') <- scExpr env other_fn + ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args + ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } + +---------------------- +mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage +mkVarUsage env fn args + = case lookupHowBound env fn of + Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] + , scu_occs = emptyVarEnv } + Just RecArg -> SCU { scu_calls = emptyVarEnv + , scu_occs = unitVarEnv fn arg_occ } + Nothing -> nullUsage + where + -- I rather think we could use UnkOcc all the time + arg_occ | null args = UnkOcc + | otherwise = evalScrutOcc + +---------------------- +scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) +scTopBindEnv env (Rec prs) + = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs RecFun + + prs' = zip bndrs' rhss + ; return (rhs_env2, Rec prs') } + where + (bndrs,rhss) = unzip prs + +scTopBindEnv env (NonRec bndr rhs) + = do { let (env1, bndr') = extendBndr env bndr + env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) + ; return (env2, NonRec bndr' rhs) } + +---------------------- +scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) + +{- +scTopBind _ usage _ + | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False + = error "false" +-} + +scTopBind env body_usage (Rec prs) + | Just threshold <- sc_size env + , not force_spec + , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) + -- No specialisation + = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ + do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss + ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) } + + | otherwise -- Do specialisation + = do { rhs_infos <- mapM (scRecRhs env) prs + + ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec) + body_usage rhs_infos + + ; return (body_usage `combineUsage` spec_usage, + Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) } + where + (bndrs,rhss) = unzip prs + force_spec = any (forceSpecBndr env) bndrs + -- Note [Forcing specialisation] + +scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions + = do { (rhs_usg', rhs') <- scExpr env rhs + ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } + +---------------------- +scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo +scRecRhs env (bndr,rhs) + = do { let (arg_bndrs,body) = collectBinders rhs + (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs + ; (body_usg, body') <- scExpr body_env body + ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' + ; return (RI { ri_rhs_usg = rhs_usg + , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' + , ri_lam_bndrs = arg_bndrs, ri_lam_body = body + , ri_arg_occs = arg_occs }) } + -- The arg_occs says how the visible, + -- lambda-bound binders of the RHS are used + -- (including the TyVar binders) + -- Two pats are the same if they match both ways + +---------------------- +ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] +ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) + (SI { si_specs = specs }) + = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++ + -- First the specialised bindings + + [(fn `addIdSpecialisations` rules, new_rhs)] + -- And now the original binding + where + rules = [r | OS { os_rule = r } <- specs] + +{- +************************************************************************ +* * + The specialiser itself +* * +************************************************************************ +-} + +data RhsInfo + = RI { ri_fn :: OutId -- The binder + , ri_new_rhs :: OutExpr -- The specialised RHS (in current envt) + , ri_rhs_usg :: ScUsage -- Usage info from specialising RHS + + , ri_lam_bndrs :: [InVar] -- The *original* RHS (\xs.body) + , ri_lam_body :: InExpr -- Note [Specialise original body] + , ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body + } + +data SpecInfo -- Info about specialisations for a particular Id + = SI { si_specs :: [OneSpec] -- The specialisations we have generated + + , si_n_specs :: Int -- Length of si_specs; used for numbering them + + , si_mb_unspec :: Maybe ScUsage -- Just cs => we have not yet used calls in the + } -- from calls in the *original* RHS as + -- seeds for new specialisations; + -- if you decide to do so, here is the + -- RHS usage (which has not yet been + -- unleashed) + -- Nothing => we have + -- See Note [Local recursive groups] + -- See Note [spec_usg includes rhs_usg] + + -- One specialisation: Rule plus definition +data OneSpec = + OS { os_pat :: CallPat -- Call pattern that generated this specialisation + , os_rule :: CoreRule -- Rule connecting original id with the specialisation + , os_id :: OutId -- Spec id + , os_rhs :: OutExpr } -- Spec rhs + +noSpecInfo :: SpecInfo +noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing } + +---------------------- +specNonRec :: ScEnv + -> ScUsage -- Body usage + -> RhsInfo -- Structure info usage info for un-specialised RHS + -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) + -- plus details of specialisations + +specNonRec env body_usg rhs_info + = specialise env (scu_calls body_usg) rhs_info + (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) }) + +---------------------- +specRec :: TopLevelFlag -> ScEnv + -> ScUsage -- Body usage + -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs + -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not) + -- plus details of specialisations + +specRec top_lvl env body_usg rhs_infos + = go 1 seed_calls nullUsage init_spec_infos + where + (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] + | isTopLevel top_lvl + , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs + = (all_calls, [noSpecInfo | _ <- rhs_infos]) + | otherwise -- Seed from body only + = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) } + | ri <- rhs_infos]) + + calls_in_body = scu_calls body_usg + calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos + all_calls = calls_in_rhss `combineCalls` calls_in_body + + -- Loop, specialising, until you get no new specialisations + go :: Int -- Which iteration of the "until no new specialisations" + -- loop we are on; first iteration is 1 + -> CallEnv -- Seed calls + -- Two accumulating parameters: + -> ScUsage -- Usage from earlier specialisations + -> [SpecInfo] -- Details of specialisations so far + -> UniqSM (ScUsage, [SpecInfo]) + go n_iter seed_calls usg_so_far spec_infos + | isEmptyVarEnv seed_calls + = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos) + -- , ppr seed_calls + -- , ppr body_usg ]) $ + return (usg_so_far, spec_infos) + + -- Limit recursive specialisation + -- See Note [Limit recursive specialisation] + | n_iter > sc_recursive env -- Too many iterations of the 'go' loop + , sc_force env || isNothing (sc_count env) + -- If both of these are false, the sc_count + -- threshold will prevent non-termination + , any ((> the_limit) . si_n_specs) spec_infos + = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ + return (usg_so_far, spec_infos) + + | otherwise + = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos) + -- , text "iteration" <+> int n_iter + -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) + -- ]) $ + do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos + ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg + extra_usg = combineUsages extra_usg_s + all_usg = usg_so_far `combineUsage` extra_usg + ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos } + + -- See Note [Limit recursive specialisation] + the_limit = case sc_count env of + Nothing -> 10 -- Ugh! + Just max -> max + + +---------------------- +specialise + :: ScEnv + -> CallEnv -- Info on newly-discovered calls to this function + -> RhsInfo + -> SpecInfo -- Original RHS plus patterns dealt with + -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage + +-- See Note [spec_usg includes rhs_usg] + +-- Note: this only generates *specialised* bindings +-- The original binding is added by ruleInfoBinds +-- +-- Note: the rhs here is the optimised version of the original rhs +-- So when we make a specialised copy of the RHS, we're starting +-- from an RHS whose nested functions have been optimised already. + +specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs + , ri_lam_body = body, ri_arg_occs = arg_occs }) + spec_info@(SI { si_specs = specs, si_n_specs = spec_count + , si_mb_unspec = mb_unspec }) + | isDeadEndId fn -- Note [Do not specialise diverging functions] + -- and do not generate specialisation seeds from its RHS + = -- pprTrace "specialise bot" (ppr fn) $ + return (nullUsage, spec_info) + + | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation] + || null arg_bndrs -- Only specialise functions + = -- pprTrace "specialise inactive" (ppr fn) $ + case mb_unspec of -- Behave as if there was a single, boring call + Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) + -- See Note [spec_usg includes rhs_usg] + Nothing -> return (nullUsage, spec_info) + + | Just all_calls <- lookupVarEnv bind_calls fn + = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ + do { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls + + ; let n_pats = length new_pats +-- ; if (not (null new_pats) || isJust mb_unspec) then +-- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" +-- , text "mb_unspec" <+> ppr (isJust mb_unspec) +-- , text "arg_occs" <+> ppr arg_occs +-- , text "good pats" <+> ppr new_pats]) $ +-- return () +-- else return () + + ; let spec_env = decreaseSpecCount env n_pats + ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) + (new_pats `zip` [spec_count..]) + -- See Note [Specialise original body] + + ; let spec_usg = combineUsages spec_usgs + + -- If there were any boring calls among the seeds (= all_calls), then those + -- calls will call the un-specialised function. So we should use the seeds + -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning + -- then in new_usg. + (new_usg, mb_unspec') + = case mb_unspec of + Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) + _ -> (spec_usg, mb_unspec) + +-- ; pprTrace "specialise return }" +-- (vcat [ ppr fn +-- , text "boring_call:" <+> ppr boring_call +-- , text "new calls:" <+> ppr (scu_calls new_usg)]) $ +-- return () + + ; return (new_usg, SI { si_specs = new_specs ++ specs + , si_n_specs = spec_count + n_pats + , si_mb_unspec = mb_unspec' }) } + + | otherwise -- No new seeds, so return nullUsage + = return (nullUsage, spec_info) + + + + +--------------------- +spec_one :: ScEnv + -> OutId -- Function + -> [InVar] -- Lambda-binders of RHS; should match patterns + -> InExpr -- Body of the original function + -> (CallPat, Int) + -> UniqSM (ScUsage, OneSpec) -- Rule and binding + +-- spec_one creates a specialised copy of the function, together +-- with a rule for using it. I'm very proud of how short this +-- function is, considering what it does :-). + +{- + Example + + In-scope: a, x::a + f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... + [c::*, v::(b,c) are presumably bound by the (...) part] + ==> + f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> + (...entire body of f...) [b -> (b,c), + y -> ((:) (a,(b,c)) (x,v) hw)] + + RULE: forall b::* c::*, -- Note, *not* forall a, x + v::(b,c), + hw::[(a,(b,c))] . + + f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw +-} + +spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) + = do { spec_uniq <- getUniqueM + ; let spec_env = extendScSubstList (extendScInScope env qvars) + (arg_bndrs `zip` pats) + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + fn_occ = nameOccName fn_name + spec_occ = mkSpecOcc fn_occ + -- We use fn_occ rather than fn in the rule_name string + -- as we don't want the uniq to end up in the rule, and + -- hence in the ABI, as that can cause spurious ABI + -- changes (#4012). + rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) + spec_name = mkInternalName spec_uniq spec_occ fn_loc +-- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn +-- <+> ppr pats <+> text "-->" <+> ppr spec_name) $ +-- return () + + -- Specialise the body + ; (spec_usg, spec_body) <- scExpr spec_env body + +-- ; pprTrace "done spec_one}" (ppr fn) $ +-- return () + + -- And build the results + ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) + qvars body_ty + -- Usual w/w hack to avoid generating + -- a spec_rhs of unlifted type and no args + + spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args + -- Annotate the variables with the strictness information from + -- the function (see Note [Strictness information in worker binders]) + + spec_join_arity | isJoinId fn = Just (length spec_lam_args) + | otherwise = Nothing + spec_id = mkLocalId spec_name Many + (mkLamTypes spec_lam_args body_ty) + -- See Note [Transfer strictness] + `setIdStrictness` spec_str + `setIdCprInfo` topCprSig + `setIdArity` count isId spec_lam_args + `asJoinId_maybe` spec_join_arity + spec_str = calcSpecStrictness fn spec_lam_args pats + + + -- Conditionally use result of new worker-wrapper transform + spec_rhs = mkLams spec_lam_args_str spec_body + body_ty = exprType spec_body + rule_rhs = mkVarApps (Var spec_id) spec_call_args + inline_act = idInlineActivation fn + this_mod = sc_module spec_env + rule = mkRule this_mod True {- Auto -} True {- Local -} + rule_name inline_act fn_name qvars pats rule_rhs + -- See Note [Transfer activation] + ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule + , os_id = spec_id + , os_rhs = spec_rhs }) } + + +-- See Note [Strictness information in worker binders] +handOutStrictnessInformation :: [Demand] -> [Var] -> [Var] +handOutStrictnessInformation = go + where + go _ [] = [] + go [] vs = vs + go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs + go dmds (v:vs) = v : go dmds vs + +calcSpecStrictness :: Id -- The original function + -> [Var] -> [CoreExpr] -- Call pattern + -> StrictSig -- Strictness of specialised thing +-- See Note [Transfer strictness] +calcSpecStrictness fn qvars pats + = mkClosedStrictSig spec_dmds div + where + spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] + StrictSig (DmdType _ dmds div) = idStrictness fn + + dmd_env = go emptyVarEnv dmds pats + + go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv + go env ds (Type {} : pats) = go env ds pats + go env ds (Coercion {} : pats) = go env ds pats + go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats + go env _ _ = env + + go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv + go_one env d (Var v) = extendVarEnv_C bothDmd env v d + go_one env d e + | Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict + , (Var _, args) <- collectArgs e = go env ds args + go_one env _ _ = env + +{- +Note [spec_usg includes rhs_usg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In calls to 'specialise', the returned ScUsage must include the rhs_usg in +the passed-in SpecInfo, unless there are no calls at all to the function. + +The caller can, indeed must, assume this. He should not combine in rhs_usg +himself, or he'll get rhs_usg twice -- and that can lead to an exponential +blowup of duplicates in the CallEnv. This is what gave rise to the massive +performance loss in #8852. + +Note [Specialise original body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RhsInfo for a binding keeps the *original* body of the binding. We +must specialise that, *not* the result of applying specExpr to the RHS +(which is also kept in RhsInfo). Otherwise we end up specialising a +specialised RHS, and that can lead directly to exponential behaviour. + +Note [Transfer activation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + This note is for SpecConstr, but exactly the same thing + happens in the overloading specialiser; see + Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise. + +In which phase should the specialise-constructor rules be active? +Originally I made them always-active, but Manuel found that this +defeated some clever user-written rules. Then I made them active only +in FinalPhase; after all, currently, the specConstr transformation is +only run after the simplifier has reached FinalPhase, but that meant +that specialisations didn't fire inside wrappers; see test +simplCore/should_compile/spec-inline. + +So now I just use the inline-activation of the parent Id, as the +activation for the specialisation RULE, just like the main specialiser; + +This in turn means there is no point in specialising NOINLINE things, +so we test for that. + +Note [Transfer strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must transfer strictness information from the original function to +the specialised one. Suppose, for example + + f has strictness SSx + and a RULE f (a:as) b = f_spec a as b + +Now we want f_spec to have strictness LLSx, otherwise we'll use call-by-need +when calling f_spec instead of call-by-value. And that can result in +unbounded worsening in space (cf the classic foldl vs foldl') + +See #3437 for a good example. + +The function calcSpecStrictness performs the calculation. + +Note [Strictness information in worker binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +After having calculated the strictness annotation for the worker (see Note +[Transfer strictness] above), we also want to have this information attached to +the worker’s arguments, for the benefit of later passes. The function +handOutStrictnessInformation decomposes the strictness annotation calculated by +calcSpecStrictness and attaches them to the variables. + +************************************************************************ +* * +\subsection{Argument analysis} +* * +************************************************************************ + +This code deals with analysing call-site arguments to see whether +they are constructor applications. + +Note [Free type variables of the qvar types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a call (f @a x True), that we want to specialise, what variables should +we quantify over. Clearly over 'a' and 'x', but what about any type variables +free in x's type? In fact we don't need to worry about them because (f @a) +can only be a well-typed application if its type is compatible with x, so any +variables free in x's type must be free in (f @a), and hence either be gathered +via 'a' itself, or be in scope at f's defn. Hence we just take + (exprsFreeVars pats). + +BUT phantom type synonyms can mess this reasoning up, + eg x::T b with type T b = Int +So we apply expandTypeSynonyms to the bound Ids. +See # 5458. Yuk. + +Note [SpecConstr call patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "call patterns" that we collect is going to become the LHS of a RULE. +It's important that it doesn't have + e |> Refl +or + e |> g1 |> g2 +because both of these will be optimised by Simplify.simplRule. In the +former case such optimisation benign, because the rule will match more +terms; but in the latter we may lose a binding of 'g1' or 'g2', and +end up with a rule LHS that doesn't bind the template variables +(#10602). + +The simplifier eliminates such things, but SpecConstr itself constructs +new terms by substituting. So the 'mkCast' in the Cast case of scExpr +is very important! + +Note [Choosing patterns] +~~~~~~~~~~~~~~~~~~~~~~~~ +If we get lots of patterns we may not want to make a specialisation +for each of them (code bloat), so we choose as follows, implemented +by trim_pats. + +* The flag -fspec-constr-count-N sets the sc_count field + of the ScEnv to (Just n). This limits the total number + of specialisations for a given function to N. + +* -fno-spec-constr-count sets the sc_count field to Nothing, + which switches of the limit. + +* The ghastly ForceSpecConstr trick also switches of the limit + for a particular function + +* Otherwise we sort the patterns to choose the most general + ones first; more general => more widely applicable. + +Note [SpecConstr and casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14270) a call like + + let f = e + in ... f (K @(a |> co)) ... + +where 'co' is a coercion variable not in scope at f's definition site. +If we aren't caereful we'll get + + let $sf a co = e (K @(a |> co)) + RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co + f = e + in ... + +But alas, when we match the call we won't bind 'co', because type-matching +(for good reasons) discards casts). + +I don't know how to solve this, so for now I'm just discarding any +call patterns that + * Mentions a coercion variable in a type argument + * That is not in scope at the binding of the function + +I think this is very rare. + +It is important (e.g. #14936) that this /only/ applies to +coercions mentioned in casts. We don't want to be discombobulated +by casts in terms! For example, consider + f ((e1,e2) |> sym co) +where, say, + f :: Foo -> blah + co :: Foo ~R (Int,Int) + +Here we definitely do want to specialise for that pair! We do not +match on the structure of the coercion; instead we just match on a +coercion variable, so the RULE looks like + + forall (x::Int, y::Int, co :: (Int,Int) ~R Foo) + f ((x,y) |> co) = $sf x y co + +Often the body of f looks like + f arg = ...(case arg |> co' of + (x,y) -> blah)... + +so that the specialised f will turn into + $sf x y co = let arg = (x,y) |> co + in ...(case arg>| co' of + (x,y) -> blah).... + +which will simplify to not use 'co' at all. But we can't guarantee +that co will end up unused, so we still pass it. Absence analysis +may remove it later. + +Note that this /also/ discards the call pattern if we have a cast in a +/term/, although in fact Rules.match does make a very flaky and +fragile attempt to match coercions. e.g. a call like + f (Maybe Age) (Nothing |> co) blah + where co :: Maybe Int ~ Maybe Age +will be discarded. It's extremely fragile to match on the form of a +coercion, so I think it's better just not to try. A more complicated +alternative would be to discard calls that mention coercion variables +only in kind-casts, but I'm doing the simple thing for now. +-} + +type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments + -- See Note [SpecConstr call patterns] + +callsToNewPats :: ScEnv -> Id + -> SpecInfo + -> [ArgOcc] -> [Call] + -> UniqSM (Bool, [CallPat]) + -- Result has no duplicate patterns, + -- nor ones mentioned in done_pats + -- Bool indicates that there was at least one boring pattern +callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls + = do { mb_pats <- mapM (callToPats env bndr_occs) calls + + ; let have_boring_call = any isNothing mb_pats + + good_pats :: [CallPat] + good_pats = catMaybes mb_pats + + -- Remove patterns we have already done + new_pats = filterOut is_done good_pats + is_done p = any (samePat p . os_pat) done_specs + + -- Remove duplicates + non_dups = nubBy samePat new_pats + + -- Remove ones that have too many worker variables + small_pats = filterOut too_big non_dups + too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars) + -- We are about to construct w/w pair in 'spec_one'. + -- Omit specialisation leading to high arity workers. + -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils + + -- Discard specialisations if there are too many of them + trimmed_pats = trim_pats env fn spec_info small_pats + +-- ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls +-- , text "done_specs:" <+> ppr (map os_pat done_specs) +-- , text "good_pats:" <+> ppr good_pats ]) $ +-- return () + + ; return (have_boring_call, trimmed_pats) } + + +trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat] +-- See Note [Choosing patterns] +trim_pats env fn (SI { si_n_specs = done_spec_count }) pats + | sc_force env + || isNothing mb_scc + || n_remaining >= n_pats + = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) + pats -- No need to trim + + | otherwise + = emit_trace $ -- Need to trim, so keep the best ones + take n_remaining sorted_pats + + where + n_pats = length pats + spec_count' = n_pats + done_spec_count + n_remaining = max_specs - done_spec_count + mb_scc = sc_count env + Just max_specs = mb_scc + + sorted_pats = map fst $ + sortBy (comparing snd) $ + [(pat, pat_cons pat) | pat <- pats] + -- Sort in order of increasing number of constructors + -- (i.e. decreasing generality) and pick the initial + -- segment of this list + + pat_cons :: CallPat -> Int + -- How many data constructors of literals are in + -- the pattern. More data-cons => less general + pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps + where + q_set = mkVarSet qs + n_cons (Var v) | v `elemVarSet` q_set = 0 + | otherwise = 1 + n_cons (Cast e _) = n_cons e + n_cons (App e1 e2) = n_cons e1 + n_cons e2 + n_cons (Lit {}) = 1 + n_cons _ = 0 + + emit_trace result + | debugIsOn || hasPprDebug (sc_dflags env) + -- Suppress this scary message for ordinary users! #5125 + = pprTrace "SpecConstr" msg result + | otherwise + = result + msg = vcat [ sep [ text "Function" <+> quotes (ppr fn) + , nest 2 (text "has" <+> + speakNOf spec_count' (text "call pattern") <> comma <+> + text "but the limit is" <+> int max_specs) ] + , text "Use -fspec-constr-count=n to set the bound" + , text "done_spec_count =" <+> int done_spec_count + , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats + , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] + + +callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) + -- The [Var] is the variables to quantify over in the rule + -- Type variables come first, since they may scope + -- over the following term variables + -- The [CoreExpr] are the argument patterns for the rule +callToPats env bndr_occs call@(Call _ args con_env) + | args `ltLength` bndr_occs -- Check saturated + = return Nothing + | otherwise + = do { let in_scope = substInScope (sc_subst env) + ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs + ; let pat_fvs = exprsFreeVarsList pats + -- To get determinism we need the list of free variables in + -- deterministic order. Otherwise we end up creating + -- lambdas with different argument orders. See + -- determinism/simplCore/should_compile/spec-inline-determ.hs + -- for an example. For explanation of determinism + -- considerations See Note [Unique Determinism] in GHC.Types.Unique. + + in_scope_vars = getInScopeVars in_scope + is_in_scope v = v `elemVarSet` in_scope_vars + qvars = filterOut is_in_scope pat_fvs + -- Quantify over variables that are not in scope + -- at the call site + -- See Note [Free type variables of the qvar types] + -- See Note [Shadowing] at the top + + (ktvs, ids) = partition isTyVar qvars + qvars' = scopedSort ktvs ++ map sanitise ids + -- Order into kind variables, type variables, term variables + -- The kind of a type variable may mention a kind variable + -- and the type of a term variable may mention a type variable + + sanitise id = updateIdTypeAndMult expandTypeSynonyms id + -- See Note [Free type variables of the qvar types] + + -- Bad coercion variables: see Note [SpecConstr and casts] + bad_covars :: CoVarSet + bad_covars = mapUnionVarSet get_bad_covars pats + get_bad_covars :: CoreArg -> CoVarSet + get_bad_covars (Type ty) + = filterVarSet (\v -> isId v && not (is_in_scope v)) $ + tyCoVarsOfType ty + get_bad_covars _ + = emptyVarSet + + ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ + WARN( not (isEmptyVarSet bad_covars) + , text "SpecConstr: bad covars:" <+> ppr bad_covars + $$ ppr call ) + if interesting && isEmptyVarSet bad_covars + then return (Just (qvars', pats)) + else return Nothing } + + -- argToPat takes an actual argument, and returns an abstracted + -- version, consisting of just the "constructor skeleton" of the + -- argument, with non-constructor sub-expression replaced by new + -- placeholder variables. For example: + -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) + +argToPat :: ScEnv + -> InScopeSet -- What's in scope at the fn defn site + -> ValueEnv -- ValueEnv at the call site + -> CoreArg -- A call arg (or component thereof) + -> ArgOcc + -> UniqSM (Bool, CoreArg) + +-- Returns (interesting, pat), +-- where pat is the pattern derived from the argument +-- interesting=True if the pattern is non-trivial (not a variable or type) +-- E.g. x:xs --> (True, x:xs) +-- f xs --> (False, w) where w is a fresh wildcard +-- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard +-- \x. x+y --> (True, \x. x+y) +-- lvl7 --> (True, lvl7) if lvl7 is bound +-- somewhere further out + +argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ + = return (False, arg) + +argToPat env in_scope val_env (Tick _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ + -- Note [Tick annotations in call patterns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Ignore Notes. In particular, we want to ignore any InlineMe notes + -- Perhaps we should not ignore profiling notes, but I'm going to + -- ride roughshod over them all for now. + --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules + +argToPat env in_scope val_env (Let _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ + -- See Note [Matching lets] in "GHC.Core.Rules" + -- Look through let expressions + -- e.g. f (let v = rhs in (v,w)) + -- Here we can specialise for f (v,w) + -- because the rule-matcher will look through the let. + +{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" + = argToPat env in_scope val_env rhs arg_occ +-} + +argToPat env in_scope val_env (Cast arg co) arg_occ + | not (ignoreType env ty2) + = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ + ; if not interesting then + wildCardPat ty2 + else do + { -- Make a wild-card pattern for the coercion + uniq <- getUniqueM + ; let co_name = mkSysTvName uniq (fsLit "sg") + co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) + ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } + where + Pair ty1 ty2 = coercionKind co + + + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite +argToPat in_scope val_env arg arg_occ + | is_value_lam arg + = return (True, arg) + where + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e + is_value_lam other = False +-} + + -- Check for a constructor application + -- NB: this *precedes* the Var case, so that we catch nullary constrs +argToPat env in_scope val_env arg arg_occ + | Just (ConVal (DataAlt dc) args) <- isValue val_env arg + , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] + , Just arg_occs <- mb_scrut dc + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs + ; return (True, + mkConApp dc (ty_args ++ args')) } + where + mb_scrut dc = case arg_occ of + ScrutOcc bs | Just occs <- lookupUFM bs dc + -> Just (occs) -- See Note [Reboxing] + _other | sc_force env || sc_keen env + -> Just (repeat UnkOcc) + | otherwise + -> Nothing + + -- Check if the argument is a variable that + -- (a) is used in an interesting way in the function body + -- (b) we know what its value is + -- In that case it counts as "interesting" +argToPat env in_scope val_env (Var v) arg_occ + | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) + is_value, -- (b) + -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] + -- So sc_keen focused just on f (I# x), where we have freshly-allocated + -- box that we can eliminate in the caller + not (ignoreType env (varType v)) + = return (True, Var v) + where + is_value + | isLocalId v = v `elemInScopeSet` in_scope + && isJust (lookupVarEnv val_env v) + -- Local variables have values in val_env + | otherwise = isValueUnfolding (idUnfolding v) + -- Imports have unfoldings + +-- I'm really not sure what this comment means +-- And by not wild-carding we tend to get forall'd +-- variables that are in scope, which in turn can +-- expose the weakness in let-matching +-- See Note [Matching lets] in GHC.Core.Rules + + -- Check for a variable bound inside the function. + -- Don't make a wild-card, because we may usefully share + -- e.g. f a = let x = ... in f (x,x) + -- NB: this case follows the lambda and con-app cases!! +-- argToPat _in_scope _val_env (Var v) _arg_occ +-- = return (False, Var v) + -- SLPJ : disabling this to avoid proliferation of versions + -- also works badly when thinking about seeding the loop + -- from the body of the let + -- f x y = letrec g z = ... in g (x,y) + -- We don't want to specialise for that *particular* x,y + + -- The default case: make a wild-card + -- We use this for coercions too +argToPat _env _in_scope _val_env arg _arg_occ + = wildCardPat (exprType arg) + +wildCardPat :: Type -> UniqSM (Bool, CoreArg) +wildCardPat ty + = do { uniq <- getUniqueM + ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty + ; return (False, varToCoreExpr id) } + +argsToPats :: ScEnv -> InScopeSet -> ValueEnv + -> [CoreArg] -> [ArgOcc] -- Should be same length + -> UniqSM (Bool, [CoreArg]) +argsToPats env in_scope val_env args occs + = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs + ; let (interesting_s, args') = unzip stuff + ; return (or interesting_s, args') } + +isValue :: ValueEnv -> CoreExpr -> Maybe Value +isValue _env (Lit lit) + | litIsLifted lit = Nothing + | otherwise = Just (ConVal (LitAlt lit) []) + +isValue env (Var v) + | Just cval <- lookupVarEnv env v + = Just cval -- You might think we could look in the idUnfolding here + -- but that doesn't take account of which branch of a + -- case we are in, which is the whole point + + | not (isLocalId v) && isCheapUnfolding unf + = isValue env (unfoldingTemplate unf) + where + unf = idUnfolding v + -- However we do want to consult the unfolding + -- as well, for let-bound constructors! + +isValue env (Lam b e) + | isTyVar b = case isValue env e of + Just _ -> Just LambdaVal + Nothing -> Nothing + | otherwise = Just LambdaVal + +isValue env (Tick t e) + | not (tickishIsCode t) + = isValue env e + +isValue _env expr -- Maybe it's a constructor application + | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr + = case isDataConWorkId_maybe fun of + + Just con | args `lengthAtLeast` dataConRepArity con + -- Check saturated; might be > because the + -- arity excludes type args + -> Just (ConVal (DataAlt con) args) + + _other | valArgCount args < idArity fun + -- Under-applied function + -> Just LambdaVal -- Partial application + + _other -> Nothing + +isValue _env _expr = Nothing + +valueIsWorkFree :: Value -> Bool +valueIsWorkFree LambdaVal = True +valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args + +samePat :: CallPat -> CallPat -> Bool +samePat (vs1, as1) (vs2, as2) + = all2 same as1 as2 + where + same (Var v1) (Var v2) + | v1 `elem` vs1 = v2 `elem` vs2 + | v2 `elem` vs2 = False + | otherwise = v1 == v2 + + same (Lit l1) (Lit l2) = l1==l2 + same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 + + same (Type {}) (Type {}) = True -- Note [Ignore type differences] + same (Coercion {}) (Coercion {}) = True + same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes + same (Cast e1 _) e2 = same e1 e2 + same e1 (Tick _ e2) = same e1 e2 + same e1 (Cast e2 _) = same e1 e2 + + same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) + False -- Let, lambda, case should not occur + bad (Case {}) = True + bad (Let {}) = True + bad (Lam {}) = True + bad _other = False + +{- +Note [Ignore type differences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want to generate specialisations where the call patterns +differ only in their type arguments! Not only is it utterly useless, +but it also means that (with polymorphic recursion) we can generate +an infinite number of specialisations. Example is Data.Sequence.adjustTree, +I think. +-} diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Specialise.hs @@ -0,0 +1,2957 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Tc.Utils.TcType hiding( substTy ) +import GHC.Core.Type hiding( substTy, extendTvSubstList ) +import GHC.Core.Multiplicity +import GHC.Core.Predicate +import GHC.Unit.Module( Module, HasModule(..) ) +import GHC.Core.Coercion( Coercion ) +import GHC.Core.Opt.Monad +import qualified GHC.Core.Subst as Core +import GHC.Core.Unfold +import GHC.Types.Var ( isLocalVar ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core +import GHC.Core.Rules +import GHC.Core.SimpleOpt ( collectBindersPushingCo ) +import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe + , mkCast, exprType ) +import GHC.Core.FVs +import GHC.Core.Opt.Arity ( etaExpandToJoinPointRule ) +import GHC.Types.Unique.Supply +import GHC.Types.Name +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Builtin.Types.Prim ( voidPrimTy ) +import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) +import GHC.Utils.Monad ( foldlM ) +import GHC.Types.Basic +import GHC.Driver.Types +import GHC.Data.Bag +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad.State +import GHC.Types.Unique.DFM +import GHC.Core.TyCo.Rep (TyCoBinder (..)) + +import Control.Monad + +{- +************************************************************************ +* * +\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} +* * +************************************************************************ + +These notes describe how we implement specialisation to eliminate +overloading. + +The specialisation pass works on Core +syntax, complete with all the explicit dictionary application, +abstraction and construction as added by the type checker. The +existing type checker remains largely as it is. + +One important thought: the {\em types} passed to an overloaded +function, and the {\em dictionaries} passed are mutually redundant. +If the same function is applied to the same type(s) then it is sure to +be applied to the same dictionary(s)---or rather to the same {\em +values}. (The arguments might look different but they will evaluate +to the same value.) + +Second important thought: we know that we can make progress by +treating dictionary arguments as static and worth specialising on. So +we can do without binding-time analysis, and instead specialise on +dictionary arguments and no others. + +The basic idea +~~~~~~~~~~~~~~ +Suppose we have + + let f = + in + +and suppose f is overloaded. + +STEP 1: CALL-INSTANCE COLLECTION + +We traverse , accumulating all applications of f to types and +dictionaries. + +(Might there be partial applications, to just some of its types and +dictionaries? In principle yes, but in practice the type checker only +builds applications of f to all its types and dictionaries, so partial +applications could only arise as a result of transformation, and even +then I think it's unlikely. In any case, we simply don't accumulate such +partial applications.) + + +STEP 2: EQUIVALENCES + +So now we have a collection of calls to f: + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... +Notice that f may take several type arguments. To avoid ambiguity, we +say that f is called at type t1/t2 and t3/t4. + +We take equivalence classes using equality of the *types* (ignoring +the dictionary args, which as mentioned previously are redundant). + +STEP 3: SPECIALISATION + +For each equivalence class, choose a representative (f t1 t2 d1 d2), +and create a local instance of f, defined thus: + + f@t1/t2 = t1 t2 d1 d2 + +f_rhs presumably has some big lambdas and dictionary lambdas, so lots +of simplification will now result. However we don't actually *do* that +simplification. Rather, we leave it for the simplifier to do. If we +*did* do it, though, we'd get more call instances from the specialised +RHS. We can work out what they are by instantiating the call-instance +set from f's RHS with the types t1, t2. + +Add this new id to f's IdInfo, to record that f has a specialised version. + +Before doing any of this, check that f's IdInfo doesn't already +tell us about an existing instance of f at the required type/s. +(This might happen if specialisation was applied more than once, or +it might arise from user SPECIALIZE pragmas.) + +Recursion +~~~~~~~~~ +Wait a minute! What if f is recursive? Then we can't just plug in +its right-hand side, can we? + +But it's ok. The type checker *always* creates non-recursive definitions +for overloaded recursive functions. For example: + + f x = f (x+x) -- Yes I know its silly + +becomes + + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl + +We still have recursion for non-overloaded functions which we +specialise, but the recursive call should get specialised to the +same recursive version. + + +Polymorphism 1 +~~~~~~~~~~~~~~ + +All this is crystal clear when the function is applied to *constant +types*; that is, types which have no type variables inside. But what if +it is applied to non-constant types? Suppose we find a call of f at type +t1/t2. There are two possibilities: + +(a) The free type variables of t1, t2 are in scope at the definition point +of f. In this case there's no problem, we proceed just as before. A common +example is as follows. Here's the Haskell: + + g y = let f x = x+x + in f y + f y + +After typechecking we have + + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) + +Notice that the call to f is at type type "a"; a non-constant type. +Both calls to f are at the same type, so we can specialise to give: + + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) + + +(b) The other case is when the type variables in the instance types +are *not* in scope at the definition point of f. The example we are +working with above is a good case. There are two instances of (+.sel a d), +but "a" is not in scope at the definition of +.sel. Can we do anything? +Yes, we can "common them up", a sort of limited common sub-expression deal. +This would give: + + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) + +This can save work, and can't be spotted by the type checker, because +the two instances of +.sel weren't originally at the same type. + +Further notes on (b) + +* There are quite a few variations here. For example, the defn of + +.sel could be floated outside the \y, to attempt to gain laziness. + It certainly mustn't be floated outside the \d because the d has to + be in scope too. + +* We don't want to inline f_rhs in this case, because +that will duplicate code. Just commoning up the call is the point. + +* Nothing gets added to +.sel's IdInfo. + +* Don't bother unless the equivalence class has more than one item! + +Not clear whether this is all worth it. It is of course OK to +simply discard call-instances when passing a big lambda. + +Polymorphism 2 -- Overloading +~~~~~~~~~~~~~~ +Consider a function whose most general type is + + f :: forall a b. Ord a => [a] -> b -> b + +There is really no point in making a version of g at Int/Int and another +at Int/Bool, because it's only instantiating the type variable "a" which +buys us any efficiency. Since g is completely polymorphic in b there +ain't much point in making separate versions of g for the different +b types. + +That suggests that we should identify which of g's type variables +are constrained (like "a") and which are unconstrained (like "b"). +Then when taking equivalence classes in STEP 2, we ignore the type args +corresponding to unconstrained type variable. In STEP 3 we make +polymorphic versions. Thus: + + f@t1/ = /\b -> t1 b d1 d2 + +We do this. + + +Dictionary floating +~~~~~~~~~~~~~~~~~~~ +Consider this + + f a (d::Num a) = let g = ... + in + ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + +Here, g is only called at one type, but the dictionary isn't in scope at the +definition point for g. Usually the type checker would build a +definition for d1 which enclosed g, but the transformation system +might have moved d1's defn inward. Solution: float dictionary bindings +outwards along with call instances. + +Consider + + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x + + +Before specialisation, leaving out type abstractions we have + + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x + +After specialising h we get a specialised version of h, like this: + + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) + +But we can't naively make an instance for g from this, because deq is not in scope +at the defn of g. Instead, we have to float out the (new) defn of deq +to widen its scope. Notice that this floating can't be done in advance -- it only +shows up when specialisation is done. + +User SPECIALIZE pragmas +~~~~~~~~~~~~~~~~~~~~~~~ +Specialisation pragmas can be digested by the type checker, and implemented +by adding extra definitions along with that of f, in the same way as before + + f@t1/t2 = t1 t2 d1 d2 + +Indeed the pragmas *have* to be dealt with by the type checker, because +only it knows how to build the dictionaries d1 and d2! For example + + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + +Here, the specialised version of g is an application of g's rhs to the +Ord dictionary for (Tree Int), which only the type checker can conjure +up. There might not even *be* one, if (Tree Int) is not an instance of +Ord! (All the other specialision has suitable dictionaries to hand +from actual calls.) + +Problem. The type checker doesn't have to hand a convenient , because +it is buried in a complex (as-yet-un-desugared) binding group. +Maybe we should say + + f@t1/t2 = f* t1 t2 d1 d2 + +where f* is the Id f with an IdInfo which says "inline me regardless!". +Indeed all the specialisation could be done in this way. +That in turn means that the simplifier has to be prepared to inline absolutely +any in-scope let-bound thing. + + +Again, the pragma should permit polymorphism in unconstrained variables: + + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} + +We *insist* that all overloaded type variables are specialised to ground types, +(and hence there can be no context inside a SPECIALIZE pragma). +We *permit* unconstrained type variables to be specialised to + - a ground type + - or left as a polymorphic type variable +but nothing in between. So + + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + +is *illegal*. (It can be handled, but it adds complication, and gains the +programmer nothing.) + + +SPECIALISING INSTANCE DECLARATIONS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} + +The original instance decl creates a dictionary-function +definition: + + dfun.Foo.List :: forall a. Foo a -> Foo [a] + +The SPECIALIZE pragma just makes a specialised copy, just as for +ordinary function definitions: + + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + +The information about what instance of the dfun exist gets added to +the dfun's IdInfo in the same way as a user-defined function too. + + +Automatic instance decl specialisation? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can instance decls be specialised automatically? It's tricky. +We could collect call-instance information for each dfun, but +then when we specialised their bodies we'd get new call-instances +for ordinary functions; and when we specialised their bodies, we might get +new call-instances of the dfuns, and so on. This all arises because of +the unrestricted mutual recursion between instance decls and value decls. + +Still, there's no actual problem; it just means that we may not do all +the specialisation we could theoretically do. + +Furthermore, instance decls are usually exported and used non-locally, +so we'll want to compile enough to get those specialisations done. + +Lastly, there's no such thing as a local instance decl, so we can +survive solely by spitting out *usage* information, and then reading that +back in as a pragma when next compiling the file. So for now, +we only specialise instance decls in response to pragmas. + + +SPITTING OUT USAGE INFORMATION +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To spit out usage information we need to traverse the code collecting +call-instance information for all imported (non-prelude?) functions +and data types. Then we equivalence-class it and spit it out. + +This is done at the top-level when all the call instances which escape +must be for imported functions and data types. + +*** Not currently done *** + + +Partial specialisation by pragmas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What about partial specialisation: + + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + +or even + + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + +Seems quite reasonable. Similar things could be done with instance decls: + + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + +Ho hum. Things are complex enough without this. I pass. + + +Requirements for the simplifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simplifier has to be able to take advantage of the specialisation. + +* When the simplifier finds an application of a polymorphic f, it looks in +f's IdInfo in case there is a suitable instance to call instead. This converts + + f t1 t2 d1 d2 ===> f_t1_t2 + +Note that the dictionaries get eaten up too! + +* Dictionary selection operations on constant dictionaries must be + short-circuited: + + +.sel Int d ===> +Int + +The obvious way to do this is in the same way as other specialised +calls: +.sel has inside it some IdInfo which tells that if it's applied +to the type Int then it should eat a dictionary and transform to +Int. + +In short, dictionary selectors need IdInfo inside them for constant +methods. + +* Exactly the same applies if a superclass dictionary is being + extracted: + + Eq.sel Int d ===> dEqInt + +* Something similar applies to dictionary construction too. Suppose +dfun.Eq.List is the function taking a dictionary for (Eq a) to +one for (Eq [a]). Then we want + + dfun.Eq.List Int d ===> dEq.List_Int + +Where does the Eq [Int] dictionary come from? It is built in +response to a SPECIALIZE pragma on the Eq [a] instance decl. + +In short, dfun Ids need IdInfo with a specialisation for each +constant instance of their instance declaration. + +All this uses a single mechanism: the SpecEnv inside an Id + + +What does the specialisation IdInfo look like? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The SpecEnv of an Id maps a list of types (the template) to an expression + + [Type] |-> Expr + +For example, if f has this RuleInfo: + + [Int, a] -> \d:Ord Int. f' a + +it means that we can replace the call + + f Int t ===> (\d. f' t) + +This chucks one dictionary away and proceeds with the +specialised version of f, namely f'. + + +What can't be done this way? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no way, post-typechecker, to get a dictionary for (say) +Eq a from a dictionary for Eq [a]. So if we find + + ==.sel [t] d + +we can't transform to + + eqList (==.sel t d') + +where + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + +Of course, we currently have no way to automatically derive +eqList, nor to connect it to the Eq [a] instance decl, but you +can imagine that it might somehow be possible. Taking advantage +of this is permanently ruled out. + +Still, this is no great hardship, because we intend to eliminate +overloading altogether anyway! + +A note about non-tyvar dictionaries +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Ids have types like + + forall a,b,c. Eq a -> Ord [a] -> tau + +This seems curious at first, because we usually only have dictionary +args whose types are of the form (C a) where a is a type variable. +But this doesn't hold for the functions arising from instance decls, +which sometimes get arguments with types of form (C (T a)) for some +type constructor T. + +Should we specialise wrt this compound-type dictionary? We used to say +"no", saying: + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." + +But it is simpler and more uniform to specialise wrt these dicts too; +and in future GHC is likely to support full fledged type signatures +like + f :: Eq [(a,b)] => ... + + +************************************************************************ +* * +\subsubsection{The new specialiser} +* * +************************************************************************ + +Our basic game plan is this. For let(rec) bound function + f :: (C a, D c) => (a,b,c,d) -> Bool + +* Find any specialised calls of f, (f ts ds), where + ts are the type arguments t1 .. t4, and + ds are the dictionary arguments d1 .. d2. + +* Add a new definition for f1 (say): + + f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + + Note that we abstract over the unconstrained type arguments. + +* Add the mapping + + [t1,b,t3,d] |-> \d1 d2 -> f1 b d + + to the specialisations of f. This will be used by the + simplifier to replace calls + (f t1 t2 t3 t4) da db + by + (\d1 d1 -> f1 t2 t4) da db + + All the stuff about how many dictionaries to discard, and what types + to apply the specialised function to, are handled by the fact that the + SpecEnv contains a template for the result of the specialisation. + +We don't build *partial* specialisations for f. For example: + + f :: Eq a => a -> a -> Bool + {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} + +Here, little is gained by making a specialised copy of f. +There's a distinct danger that the specialised version would +first build a dictionary for (Eq b, Eq c), and then select the (==) +method from it! Even if it didn't, not a great deal is saved. + +We do, however, generate polymorphic, but not overloaded, specialisations: + + f :: Eq a => [a] -> b -> b -> b + ... SPECIALISE f :: [Int] -> b -> b -> b ... + +Hence, the invariant is this: + + *** no specialised version is overloaded *** + + +************************************************************************ +* * +\subsubsection{The exported function} +* * +************************************************************************ +-} + +-- | Specialise calls to type-class overloaded functions occurring in a program. +specProgram :: ModGuts -> CoreM ModGuts +specProgram guts@(ModGuts { mg_module = this_mod + , mg_rules = local_rules + , mg_binds = binds }) + = do { dflags <- getDynFlags + + -- Specialise the bindings of this module + ; (binds', uds) <- runSpecM dflags this_mod (go binds) + + ; (spec_rules, spec_binds) <- specImports dflags this_mod top_env + local_rules uds + + ; return (guts { mg_binds = spec_binds ++ binds' + , mg_rules = spec_rules ++ local_rules }) } + where + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $ + bindersOfBinds binds + , se_interesting = emptyVarSet } + + go [] = return ([], emptyUDs) + go (bind:binds) = do (binds', uds) <- go binds + (bind', uds') <- specBind top_env bind uds + return (bind' ++ binds', uds') + +{- +Note [Wrap bindings returned by specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'specImports' returns a set of specialized bindings. However, these are lacking +necessary floated dictionary bindings, which are returned by +UsageDetails(ud_binds). These dictionaries need to be brought into scope with +'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, +for instance, the 'specImports' call in 'specProgram'. + + +Note [Disabling cross-module specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since GHC 7.10 we have performed specialisation of INLINABLE bindings living +in modules outside of the current module. This can sometimes uncover user code +which explodes in size when aggressively optimized. The +-fno-cross-module-specialise option was introduced to allow users to being +bitten by such instances to revert to the pre-7.10 behavior. + +See #10491 +-} + + +{- ********************************************************************* +* * + Specialising imported functions +* * +********************************************************************* -} + +specImports :: DynFlags -> Module -> SpecEnv + -> [CoreRule] + -> UsageDetails + -> CoreM ([CoreRule], [CoreBind]) +specImports dflags this_mod top_env local_rules + (MkUD { ud_binds = dict_binds, ud_calls = calls }) + | not $ gopt Opt_CrossModuleSpecialise dflags + -- See Note [Disabling cross-module specialisation] + = return ([], wrapDictBinds dict_binds []) + + | otherwise + = do { hpt_rules <- getRuleBase + ; let rule_base = extendRuleBaseList hpt_rules local_rules + + ; (spec_rules, spec_binds) <- spec_imports dflags this_mod top_env + [] rule_base + dict_binds calls + + -- Don't forget to wrap the specialized bindings with + -- bindings for the needed dictionaries. + -- See Note [Wrap bindings returned by specImports] + -- and Note [Glom the bindings if imported functions are specialised] + ; let final_binds + | null spec_binds = wrapDictBinds dict_binds [] + | otherwise = [Rec $ flattenBinds $ + wrapDictBinds dict_binds spec_binds] + + ; return (spec_rules, final_binds) + } + +-- | Specialise a set of calls to imported bindings +spec_imports :: DynFlags + -> Module + -> SpecEnv -- Passed in so that all top-level Ids are in scope + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> RuleBase -- Rules from this module and the home package + -- (but not external packages, which can change) + -> Bag DictBind -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallDetails -- Calls for imported things + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_imports dflags this_mod top_env + callers rule_base dict_binds calls + = do { let import_calls = dVarEnvElts calls + -- ; debugTraceMsg (text "specImports {" <+> + -- vcat [ text "calls:" <+> ppr import_calls + -- , text "dict_binds:" <+> ppr dict_binds ]) + ; (rules, spec_binds) <- go rule_base import_calls + -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls) + + ; return (rules, spec_binds) } + where + go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) + go _ [] = return ([], []) + go rb (cis : other_calls) + = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) + ; (rules1, spec_binds1) <- spec_import dflags this_mod top_env + callers rb dict_binds cis + -- ; debugTraceMsg (text "specImport }" <+> ppr cis) + + ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls + ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } + +spec_import :: DynFlags + -> Module + -> SpecEnv -- Passed in so that all top-level Ids are in scope + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> RuleBase -- Rules from this module + -> Bag DictBind -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallInfoSet -- Imported function and calls for it + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_import dflags this_mod top_env callers + rb dict_binds cis@(CIS fn _) + | isIn "specImport" fn callers + = return ([], []) -- No warning. This actually happens all the time + -- when specialising a recursive function, because + -- the RHS of the specialised function contains a recursive + -- call to the original function + + | null good_calls + = do { -- debugTraceMsg (text "specImport:no valid calls") + ; return ([], []) } + + | wantSpecImport dflags unfolding + , Just rhs <- maybeUnfoldingTemplate unfolding + = do { -- Get rules from the external package state + -- We keep doing this in case we "page-fault in" + -- more rules as we go along + ; hsc_env <- getHscEnv + ; eps <- liftIO $ hscEPS hsc_env + ; vis_orphs <- getVisibleOrphanMods + ; let full_rb = unionRuleBase rb (eps_rule_base eps) + rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn + + ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) + <- do { -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) + ; runSpecM dflags this_mod $ + specCalls (Just this_mod) top_env rules_for_fn good_calls fn rhs } + ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] + -- After the rules kick in we may get recursion, but + -- we rely on a global GlomBinds to sort that out later + -- See Note [Glom the bindings if imported functions are specialised] + + -- Now specialise any cascaded calls + -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1)) + ; (rules2, spec_binds2) <- spec_imports dflags this_mod top_env + (fn:callers) + (extendRuleBaseList rb rules1) + (dict_binds `unionBags` dict_binds1) + new_calls + + ; let final_binds = wrapDictBinds dict_binds1 $ + spec_binds2 ++ spec_binds1 + + ; return (rules2 ++ rules1, final_binds) } + + | otherwise + = do { tryWarnMissingSpecs dflags callers fn good_calls + ; return ([], [])} + + where + unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers + good_calls = filterCalls cis dict_binds + -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn + -- See Note [Avoiding loops in specImports] + +-- | Returns whether or not to show a missed-spec warning. +-- If -Wall-missed-specializations is on, show the warning. +-- Otherwise, if -Wmissed-specializations is on, only show a warning +-- if there is at least one imported function being specialized, +-- and if all imported functions are marked with an inline pragma +-- Use the most specific warning as the reason. +tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () +-- See Note [Warning about missed specialisations] +tryWarnMissingSpecs dflags callers fn calls_for_fn + | wopt Opt_WarnMissedSpecs dflags + && not (null callers) + && allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs + | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ Reason Opt_WarnAllMissedSpecs + | otherwise = return () + where + allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers + doWarn reason = + warnMsg reason + (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) + 2 (vcat [ text "when specialising" <+> quotes (ppr caller) + | caller <- callers]) + , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) + +wantSpecImport :: DynFlags -> Unfolding -> Bool +-- See Note [Specialise imported INLINABLE things] +wantSpecImport dflags unf + = case unf of + NoUnfolding -> False + BootUnfolding -> False + OtherCon {} -> False + DFunUnfolding {} -> True + CoreUnfolding { uf_src = src, uf_guidance = _guidance } + | gopt Opt_SpecialiseAggressively dflags -> True + | isStableSource src -> True + -- Specialise even INLINE things; it hasn't inlined yet, + -- so perhaps it never will. Moreover it may have calls + -- inside it that we want to specialise + | otherwise -> False -- Stable, not INLINE, hence INLINABLE + +{- Note [Avoiding loops in specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take great care when specialising instance declarations +(functions like $fOrdList) lest we accidentally build a recursive +dictionary. See Note [Avoiding loops]. + +The basic strategy of Note [Avoiding loops] is to use filterCalls +to discard loopy specialisations. But to do that we must ensure +that the in-scope dict-binds (passed to filterCalls) contains +all the needed dictionary bindings. In particular, in the recursive +call to spec_imorpts in spec_import, we must include the dict-binds +from the parent. Lacking this caused #17151, a really nasty bug. + +Here is what happened. +* Class struture: + Source is a superclass of Mut + Index is a superclass of Source + +* We started with these dict binds + dSource = $fSourcePix @Int $fIndexInt + dIndex = sc_sel dSource + dMut = $fMutPix @Int dIndex + and these calls to specialise + $fMutPix @Int dIndex + $fSourcePix @Int $fIndexInt + +* We specialised the call ($fMutPix @Int dIndex) + ==> new call ($fSourcePix @Int dIndex) + (because Source is a superclass of Mut) + +* We specialised ($fSourcePix @Int dIndex) + ==> produces specialised dict $s$fSourcePix, + a record with dIndex as a field + plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix + *** This is the bogus step *** + +* Now we decide not to specialise the call + $fSourcePix @Int $fIndexInt + because we alredy have a RULE that matches it + +* Finally the simplifer rewrites + dSource = $fSourcePix @Int $fIndexInt + ==> dSource = $s$fSourcePix + +Disaster. Now we have + +Rewrite dSource's RHS to $s$fSourcePix Disaster + dSource = $s$fSourcePix + dIndex = sc_sel dSource + $s$fSourcePix = MkSource dIndex ... + +Solution: filterCalls should have stopped the bogus step, +by seeing that dIndex transitively uses $fSourcePix. But +it can only do that if it sees all the dict_binds. Wow. + +-------------- +Here's another example (#13429). Suppose we have + class Monoid v => C v a where ... + +We start with a call + f @ [Integer] @ Integer $fC[]Integer + +Specialising call to 'f' gives dict bindings + $dMonoid_1 :: Monoid [Integer] + $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer + + $dC_1 :: C [Integer] (Node [Integer] Integer) + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + +...plus a recursive call to + f @ [Integer] @ (Node [Integer] Integer) $dC_1 + +Specialising that call gives + $dMonoid_2 :: Monoid [Integer] + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + + $dC_2 :: C [Integer] (Node [Integer] Integer) + $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 + +Now we have two calls to the imported function + M.$fCvNode :: Monoid v => C v a + M.$fCvNode @v @a m = C m some_fun + +But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) +for specialisation, else we get: + + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + $s$fCvNode = C $dMonoid_2 ... + RULE M.$fCvNode [Integer] _ _ = $s$fCvNode + +Now use the rule to rewrite the call in the RHS of $dC_1 +and we get a loop! + + +Note [specImport call stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising an imports function 'f', we may get new calls +of an imported fuction 'g', which we want to specialise in turn, +and similarly specialising 'g' might expose a new call to 'h'. + +We track the stack of enclosing functions. So when specialising 'h' we +haev a specImport call stack of [g,f]. We do this for two reasons: +* Note [Warning about missed specialisations] +* Note [Avoiding recursive specialisation] + +Note [Warning about missed specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + * In module Lib, you carefully mark a function 'foo' INLINABLE + * Import Lib(foo) into another module M + * Call 'foo' at some specialised type in M +Then you jolly well expect it to be specialised in M. But what if +'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be +specialised too. But if 'bar' is not marked INLINABLE it may well +not be specialised. The warning Opt_WarnMissedSpecs warns about this. + +It's more noisy to warning about a missed specialisation opportunity +for /every/ overloaded imported function, but sometimes useful. That +is what Opt_WarnAllMissedSpecs does. + +ToDo: warn about missed opportunities for local functions. + +Note [Avoiding recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise 'f' we may find new overloaded calls to 'g', 'h' in +'f's RHS. So we want to specialise g,h. But we don't want to +specialise f any more! It's possible that f's RHS might have a +recursive yet-more-specialised call, so we'd diverge in that case. +And if the call is to the same type, one specialisation is enough. +Avoiding this recursive specialisation loop is one reason for the +'callers' stack passed to specImports and specImport. + +Note [Specialise imported INLINABLE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What imported functions do we specialise? The basic set is + * DFuns and things with INLINABLE pragmas. +but with -fspecialise-aggressively we add + * Anything with an unfolding template + +#8874 has a good example of why we want to auto-specialise DFuns. + +We have the -fspecialise-aggressively flag (usually off), because we +risk lots of orphan modules from over-vigorous specialisation. +However it's not a big deal: anything non-recursive with an +unfolding-template will probably have been inlined already. + +Note [Glom the bindings if imported functions are specialised] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an imported, *recursive*, INLINABLE function + f :: Eq a => a -> a + f = /\a \d x. ...(f a d)... +In the module being compiled we have + g x = f (x::Int) +Now we'll make a specialised function + f_spec :: Int -> Int + f_spec = \x -> ...(f Int dInt)... + {-# RULE f Int _ = f_spec #-} + g = \x. f Int dInt x +Note that f_spec doesn't look recursive +After rewriting with the RULE, we get + f_spec = \x -> ...(f_spec)... +BUT since f_spec was non-recursive before it'll *stay* non-recursive. +The occurrence analyser never turns a NonRec into a Rec. So we must +make sure that f_spec is recursive. Easiest thing is to make all +the specialisations for imported bindings recursive. + + + +************************************************************************ +* * +\subsubsection{@specExpr@: the main function} +* * +************************************************************************ +-} + +data SpecEnv + = SE { se_subst :: Core.Subst + -- We carry a substitution down: + -- a) we must clone any binding that might float outwards, + -- to avoid name clashes + -- b) we carry a type substitution to use when analysing + -- the RHS of specialised bindings (no type-let!) + + + , se_interesting :: VarSet + -- Dict Ids that we know something about + -- and hence may be worth specialising against + -- See Note [Interesting dictionary arguments] + } + +instance Outputable SpecEnv where + ppr (SE { se_subst = subst, se_interesting = interesting }) + = text "SE" <+> braces (sep $ punctuate comma + [ text "subst =" <+> ppr subst + , text "interesting =" <+> ppr interesting ]) + +specVar :: SpecEnv -> Id -> CoreExpr +specVar env v = Core.lookupIdSubst (se_subst env) v + +specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) + +---------------- First the easy cases -------------------- +specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) +specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) +specExpr env (Var v) = return (specVar env v, emptyUDs) +specExpr _ (Lit lit) = return (Lit lit, emptyUDs) +specExpr env (Cast e co) + = do { (e', uds) <- specExpr env e + ; return ((mkCast e' (substCo env co)), uds) } +specExpr env (Tick tickish body) + = do { (body', uds) <- specExpr env body + ; return (Tick (specTickish env tickish) body', uds) } + +---------------- Applications might generate a call instance -------------------- +specExpr env expr@(App {}) + = go expr [] + where + go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg + (fun', uds_app) <- go fun (arg':args) + return (App fun' arg', uds_arg `plusUDs` uds_app) + + go (Var f) args = case specVar env f of + Var f' -> return (Var f', mkCallUDs env f' args) + e' -> return (e', emptyUDs) -- I don't expect this! + go other _ = specExpr env other + +---------------- Lambda/case require dumping of usage details -------------------- +specExpr env e@(Lam {}) + = specLam env' bndrs' body + where + (bndrs, body) = collectBinders e + (env', bndrs') = substBndrs env bndrs + -- More efficient to collect a group of binders together all at once + -- and we don't want to split a lambda group with dumped bindings + +specExpr env (Case scrut case_bndr ty alts) + = do { (scrut', scrut_uds) <- specExpr env scrut + ; (scrut'', case_bndr', alts', alts_uds) + <- specCase env scrut' case_bndr alts + ; return (Case scrut'' case_bndr' (substTy env ty) alts' + , scrut_uds `plusUDs` alts_uds) } + +---------------- Finally, let is the interesting case -------------------- +specExpr env (Let bind body) + = do { -- Clone binders + (rhs_env, body_env, bind') <- cloneBindSM env bind + + -- Deal with the body + ; (body', body_uds) <- specExpr body_env body + + -- Deal with the bindings + ; (binds', uds) <- specBind rhs_env bind' body_uds + + -- All done + ; return (foldr Let body' binds', uds) } + +-------------- +specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) +-- The binders have been substituted, but the body has not +specLam env bndrs body + | null bndrs + = specExpr env body + | otherwise + = do { (body', uds) <- specExpr env body + ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds + ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } + +-------------- +specTickish :: SpecEnv -> Tickish Id -> Tickish Id +specTickish env (Breakpoint ix ids) + = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] + -- drop vars from the list if they have a non-variable substitution. + -- should never happen, but it's harmless to drop them anyway. +specTickish _ other_tickish = other_tickish + +-------------- +specCase :: SpecEnv + -> CoreExpr -- Scrutinee, already done + -> Id -> [CoreAlt] + -> SpecM ( CoreExpr -- New scrutinee + , Id + , [CoreAlt] + , UsageDetails) +specCase env scrut' case_bndr [(con, args, rhs)] + | isDictId case_bndr -- See Note [Floating dictionaries out of cases] + , interestingDict env scrut' + , not (isDeadBinder case_bndr && null sc_args') + = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') + + ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') + [(con, args', Var sc_arg')] + | sc_arg' <- sc_args' ] + + -- Extend the substitution for RHS to map the *original* binders + -- to their floated versions. + mb_sc_flts :: [Maybe DictId] + mb_sc_flts = map (lookupVarEnv clone_env) args' + clone_env = zipVarEnv sc_args' sc_args_flt + subst_prs = (case_bndr, Var case_bndr_flt) + : [ (arg, Var sc_flt) + | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] + env_rhs' = env_rhs { se_subst = Core.extendIdSubstList (se_subst env_rhs) subst_prs + , se_interesting = se_interesting env_rhs `extendVarSetList` + (case_bndr_flt : sc_args_flt) } + + ; (rhs', rhs_uds) <- specExpr env_rhs' rhs + ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') + case_bndr_set = unitVarSet case_bndr_flt + sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs + , db_fvs = case_bndr_set } + | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] + flt_binds = scrut_bind : sc_binds + (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds + all_uds = flt_binds `addDictBinds` free_uds + alt' = (con, args', wrapDictBindsE dumped_dbs rhs') + ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } + where + (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) + sc_args' = filter is_flt_sc_arg args' + + clone_me bndr = do { uniq <- getUniqueM + ; return (mkUserLocalOrCoVar occ uniq wght ty loc) } + where + name = idName bndr + wght = idMult bndr + ty = idType bndr + occ = nameOccName name + loc = getSrcSpan name + + arg_set = mkVarSet args' + is_flt_sc_arg var = isId var + && not (isDeadBinder var) + && isDictTy var_ty + && tyCoVarsOfType var_ty `disjointVarSet` arg_set + where + var_ty = idType var + + +specCase env scrut case_bndr alts + = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts + ; return (scrut, case_bndr', alts', uds_alts) } + where + (env_alt, case_bndr') = substBndr env case_bndr + spec_alt (con, args, rhs) = do + (rhs', uds) <- specExpr env_rhs rhs + let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds + return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) + where + (env_rhs, args') = substBndrs env_alt args + +{- +Note [Floating dictionaries out of cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g = \d. case d of { MkD sc ... -> ...(f sc)... } +Naively we can't float d2's binding out of the case expression, +because 'sc' is bound by the case, and that in turn means we can't +specialise f, which seems a pity. + +So we invert the case, by floating out a binding +for 'sc_flt' thus: + sc_flt = case d of { MkD sc ... -> sc } +Now we can float the call instance for 'f'. Indeed this is just +what'll happen if 'sc' was originally bound with a let binding, +but case is more efficient, and necessary with equalities. So it's +good to work with both. + +You might think that this won't make any difference, because the +call instance will only get nuked by the \d. BUT if 'g' itself is +specialised, then transitively we should be able to specialise f. + +In general, given + case e of cb { MkD sc ... -> ...(f sc)... } +we transform to + let cb_flt = e + sc_flt = case cb_flt of { MkD sc ... -> sc } + in + case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } + +The "_flt" things are the floated binds; we use the current substitution +to substitute sc -> sc_flt in the RHS + +************************************************************************ +* * + Dealing with a binding +* * +************************************************************************ +-} + +specBind :: SpecEnv -- Use this for RHSs + -> CoreBind -- Binders are already cloned by cloneBindSM, + -- but RHSs are un-processed + -> UsageDetails -- Info on how the scope of the binding + -> SpecM ([CoreBind], -- New bindings + UsageDetails) -- And info to pass upstream + +-- Returned UsageDetails: +-- No calls for binders of this bind +specBind rhs_env (NonRec fn rhs) body_uds + = do { (rhs', rhs_uds) <- specExpr rhs_env rhs + + ; let zapped_fn = zapIdDemandInfo fn + -- We zap the demand info because the binding may float, + -- which would invaidate the demand info (see #17810 for example). + -- Destroying demand info is not terrible; specialisation is + -- always followed soon by demand analysis. + ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs + + ; let pairs = spec_defns ++ [(fn', rhs')] + -- fn' mentions the spec_defns in its rules, + -- so put the latter first + + combined_uds = body_uds1 `plusUDs` rhs_uds + + (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds + + final_binds :: [DictBind] + -- See Note [From non-recursive to recursive] + final_binds + | not (isEmptyBag dump_dbs) + , not (null spec_defns) + = [recWithDumpedDicts pairs dump_dbs] + | otherwise + = [mkDB $ NonRec b r | (b,r) <- pairs] + ++ bagToList dump_dbs + + ; if float_all then + -- Rather than discard the calls mentioning the bound variables + -- we float this (dictionary) binding along with the others + return ([], free_uds `snocDictBinds` final_binds) + else + -- No call in final_uds mentions bound variables, + -- so we can just leave the binding here + return (map db_bind final_binds, free_uds) } + + +specBind rhs_env (Rec pairs) body_uds + -- Note [Specialising a recursive group] + = do { let (bndrs,rhss) = unzip pairs + ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss + ; let scope_uds = body_uds `plusUDs` rhs_uds + -- Includes binds and calls arising from rhss + + ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs + + ; (bndrs3, spec_defns3, uds3) + <- if null spec_defns1 -- Common case: no specialisation + then return (bndrs1, [], uds1) + else do { -- Specialisation occurred; do it again + (bndrs2, spec_defns2, uds2) + <- specDefns rhs_env uds1 (bndrs1 `zip` rhss) + ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } + + ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 + final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') + dumped_dbs + + ; if float_all then + return ([], final_uds `snocDictBind` final_bind) + else + return ([db_bind final_bind], final_uds) } + + +--------------------------- +specDefns :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([OutId], -- Original Ids with RULES added + [(OutId,OutExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +-- Specialise a list of bindings (the contents of a Rec), but flowing usages +-- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } +-- Then if the input CallDetails has a specialised call for 'g', whose specialisation +-- in turn generates a specialised call for 'f', we catch that in this one sweep. +-- But not vice versa (it's a fixpoint problem). + +specDefns _env uds [] + = return ([], [], uds) +specDefns env uds ((bndr,rhs):pairs) + = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs + ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs + ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } + +--------------------------- +specDefn :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> OutId -> InExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +specDefn env body_uds fn rhs + = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + rules_for_me = idCoreRules fn + ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me + calls_for_me fn rhs + ; return ( fn `addIdSpecialisations` rules + , spec_defns + , body_uds_without_me `plusUDs` spec_uds) } + -- It's important that the `plusUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me + +--------------------------- +specCalls :: Maybe Module -- Just this_mod => specialising imported fn + -- Nothing => specialising local fn + -> SpecEnv + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> OutId -> InExpr + -> SpecM SpecInfo -- New rules, specialised bindings, and usage details + +-- This function checks existing rules, and does not create +-- duplicate ones. So the caller does not need to do this filtering. +-- See 'already_covered' + +type SpecInfo = ( [CoreRule] -- Specialisation rules + , [(Id,CoreExpr)] -- Specialised definition + , UsageDetails ) -- Usage details from specialised RHSs + +specCalls mb_mod env existing_rules calls_for_me fn rhs + -- The first case is the interesting one + | notNull calls_for_me -- And there are some calls to specialise + && not (isNeverActive (idInlineActivation fn)) + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] + +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisation] for why we do not +-- switch off specialisation for inline functions + + = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ + foldlM spec_call ([], [], emptyUDs) calls_for_me + + | otherwise -- No calls or RHS doesn't fit our preconceptions + = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, + text "Missed specialisation opportunity for" + <+> ppr fn $$ _trace_doc ) + -- Note [Specialisation shape] + -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ + return ([], [], emptyUDs) + where + _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ] + + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_local = isLocalId fn + is_dfun = isDFunId fn + + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] + + (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs + -- See Note [Account for casts in binding] + + in_scope = Core.substInScope (se_subst env) + + already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool + already_covered ropts new_rules args -- Note [Specialisations already covered] + = isJust (lookupRule ropts (in_scope, realIdUnfolding) + (const True) fn args + (new_rules ++ existing_rules)) + -- NB: we look both in the new_rules (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + + ---------------------------------------------------------- + -- Specialise to one particular call pattern + spec_call :: SpecInfo -- Accumulating parameter + -> CallInfo -- Call instance + -> SpecM SpecInfo + spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args }) + = -- See Note [Specialising Calls] + do { let all_call_args | is_dfun = call_args ++ repeat UnspecArg + | otherwise = call_args + -- See Note [Specialising DFuns] + ; ( useful, rhs_env2, leftover_bndrs + , rule_bndrs, rule_lhs_args + , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args + +-- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci +-- , text "useful: " <+> ppr useful +-- , text "rule_bndrs:" <+> ppr rule_bndrs +-- , text "lhs_args: " <+> ppr rule_lhs_args +-- , text "spec_bndrs:" <+> ppr spec_bndrs1 +-- , text "spec_args: " <+> ppr spec_args +-- , text "dx_binds: " <+> ppr dx_binds +-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) +-- , ppr dx_binds ]) $ +-- return () + + ; dflags <- getDynFlags + ; let ropts = initRuleOpts dflags + ; if not useful -- No useful specialisation + || already_covered ropts rules_acc rule_lhs_args + then return spec_acc + else + do { -- Run the specialiser on the specialised RHS + -- The "1" suffix is before we maybe add the void arg + ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body + ; let spec_fn_ty1 = exprType spec_rhs1 + + -- Maybe add a void arg to the specialised function, + -- to avoid unlifted bindings + -- See Note [Specialisations Must Be Lifted] + -- C.f. GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs + add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) + (spec_bndrs, spec_rhs, spec_fn_ty) + | add_void_arg = ( voidPrimId : spec_bndrs1 + , Lam voidArgId spec_rhs1 + , mkVisFunTyMany voidPrimTy spec_fn_ty1) + | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) + + join_arity_decr = length rule_lhs_args - length spec_bndrs + spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn + = Just (orig_join_arity - join_arity_decr) + | otherwise + = Nothing + + ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity + ; this_mod <- getModule + ; let + -- The rule to put in the function's specialisation is: + -- forall x @b d1' d2'. + -- f x @T1 @b @T2 d1' d2' = f1 x @b + -- See Note [Specialising Calls] + herald = case mb_mod of + Nothing -- Specialising local fn + -> text "SPEC" + Just this_mod -- Specialising imported fn + -> text "SPEC/" <> ppr this_mod + + rule_name = mkFastString $ showSDoc dflags $ + herald <+> ftext (occNameFS (getOccName fn)) + <+> hsep (mapMaybe ppr_call_key_ty call_args) + -- This name ends up in interface files, so use occNameString. + -- Otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + + rule_wout_eta = mkRule + this_mod + True {- Auto generated -} + is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + rule_bndrs + rule_lhs_args + (mkVarApps (Var spec_fn) spec_bndrs) + + spec_rule + = case isJoinId_maybe fn of + Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta + Nothing -> rule_wout_eta + + -- Add the { d1' = dx1; d2' = dx2 } usage stuff + -- See Note [Specialising Calls] + spec_uds = foldr consDictBind rhs_uds dx_binds + + -------------------------------------- + -- Add a suitable unfolding if the spec_inl_prag says so + -- See Note [Inline specialisations] + (spec_inl_prag, spec_unf) + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = (neverInlinePragma, noUnfolding) + -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" + + | InlinePragma { inl_inline = Inlinable } <- inl_prag + = (inl_prag { inl_inline = NoUserInline }, noUnfolding) + + | otherwise + = (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args) + rule_lhs_args fn_unf) + + -------------------------------------- + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in GHC.Core.Opt.Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_fn + arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs + spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr) + `setInlinePragma` spec_inl_prag + `setIdUnfolding` spec_unf + `asJoinId_maybe` spec_join_arity + + _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type + , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty + , ppr rhs_bndrs, ppr call_args + , ppr spec_rule + ] + + ; -- pprTrace "spec_call: rule" _rule_trace_doc + return ( spec_rule : rules_acc + , (spec_f_w_arity, spec_rhs) : pairs_acc + , spec_uds `plusUDs` uds_acc + ) } } + +{- Note [Specialising DFuns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DFuns have a special sort of unfolding (DFunUnfolding), and these are +hard to specialise a DFunUnfolding to give another DFunUnfolding +unless the DFun is fully applied (#18120). So, in the case of DFunIds +we simply extend the CallKey with trailing UnspecArgs, so we'll +generate a rule that completely saturates the DFun. + +There is an ASSERT that checks this, in the DFunUnfolding case of +GHC.Core.Unfold.specUnfolding. + +Note [Specialisation Must Preserve Sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function: + + f :: forall a. Eq a => a -> blah + f = + if expensive + then f1 + else f2 + +As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' +at 'Int', eg: + + $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) + + RULE "SPEC f" + forall (d :: Eq Int). + f Int _ = $sfIntf + +We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! + +To avoid this, we only generate specialisations for functions whose arity is +enough to bind all of the arguments we need to specialise. This ensures our +specialised functions don't do any work before receiving all of their dicts, +and thus avoids the 'f' case above. + +Note [Specialisations Must Be Lifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function 'f': + + f = forall a. Eq a => Array# a + +used like + + case x of + True -> ...f @Int dEqInt... + False -> 0 + +Naively, we might generate an (expensive) specialisation + + $sfInt :: Array# Int + +even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to +the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to +preserve laziness. + +Note [Specialising Calls] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a function with a complicated type: + + f :: forall a b c. Int -> Eq a => Show b => c -> Blah + f @a @b @c i dEqA dShowA x = blah + +and suppose it is called at: + + f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3 + +This call is described as a 'CallInfo' whose 'ci_key' is: + + [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1 + , SpecDict ($dfShow dShowT2), UnspecArg ] + +Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? +Because we must specialise the function on type variables that appear +free in its *dictionary* arguments; but not on type variables that do not +appear in any dictionaries, i.e. are fully polymorphic. + +Because this call has dictionaries applied, we'd like to specialise +the call on any type argument that appears free in those dictionaries. +In this case, those are [a :-> T1, b :-> T2]. + +We also need to substitute the dictionary binders with their +specialised dictionaries. The simplest substitution would be +[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates +work, since `$dfShow dShowT2` is a function application. Therefore, we +also want to *float the dictionary out* (via bindAuxiliaryDict), +creating a new dict binding + + dShow1 = $dfShow dShowT2 + +and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1]. + +With the substitutions in hand, we can generate a specialised function: + + $sf :: forall c. Int -> c -> Blah + $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) + +Note that the substitution is applied to the whole thing. This is +convenient, but just slightly fragile. Notably: + * There had better be no name clashes in a/b/c + +We must construct a rewrite rule: + + RULE "SPEC f @T1 @T2 _" + forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). + f @T1 @T2 @c i d1 d2 = $sf @c i + +In the rule, d1 and d2 are just wildcards, not used in the RHS. Note +additionally that 'x' isn't captured by this rule --- we bind only +enough etas in order to capture all of the *specialised* arguments. + +Note [Drop dead args from specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising a function, it’s possible some of the arguments may +actually be dead. For example, consider: + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +We might generate the following CallInfo for `f @Int`: + + [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] + +Normally we’d include both the x and y arguments in the +specialisation, since we’re not specialising on either of them. But +that’s silly, since x is actually unused! So we might as well drop it +in the specialisation: + + $sf :: Int -> String + $sf y = show y ++ "!" + + {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} + +This doesn’t save us much, since the arg would be removed later by +worker/wrapper, anyway, but it’s easy to do. Note, however, that we +only drop dead arguments if: + + 1. We don’t specialise on them. + 2. They come before an argument we do specialise on. + +Doing the latter would require eta-expanding the RULE, which could +make it match less often, so it’s not worth it. Doing the former could +be more useful --- it would stop us from generating pointless +specialisations --- but it’s more involved to implement and unclear if +it actually provides much benefit in practice. + +Note [Zap occ info in rule binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we generate a specialisation RULE, we need to drop occurrence +info on the binders. If we don’t, things go wrong when we specialise a +function like + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +since we’ll generate a RULE like + + RULE "SPEC f @Int" forall x [Occ=Dead]. + f @Int x $dShow = $sf + +and Core Lint complains, even though x only appears on the LHS (due to +Note [Drop dead args from specialisations]). + +Why is that a Lint error? Because the arguments on the LHS of a rule +are syntactically expressions, not patterns, so Lint treats the +appearance of x as a use rather than a binding. Fortunately, the +solution is simple: we just make sure to zap the occ info before +using ids as wildcard binders in a rule. + +Note [Account for casts in binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: Eq a => a -> IO () + {-# INLINABLE f + StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g + #-} + f = ... + +In f's stable unfolding we have done some modest simplification which +has pushed the cast to the outside. (I wonder if this is the Right +Thing, but it's what happens now; see GHC.Core.Opt.Simplify.Utils Note [Casts and +lambdas].) Now that stable unfolding must be specialised, so we want +to push the cast back inside. It would be terrible if the cast +defeated specialisation! Hence the use of collectBindersPushingCo. + +Note [Evidence foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#12212) that we are specialising + f :: forall a b. (Num a, F a ~ F b) => blah +with a=b=Int. Then the RULE will be something like + RULE forall (d:Num Int) (g :: F Int ~ F Int). + f Int Int d g = f_spec +But both varToCoreExpr (when constructing the LHS args), and the +simplifier (when simplifying the LHS args), will transform to + RULE forall (d:Num Int) (g :: F Int ~ F Int). + f Int Int d = f_spec +by replacing g with Refl. So now 'g' is unbound, which results in a later +crash. So we use Refl right off the bat, and do not forall-quantify 'g': + * varToCoreExpr generates a Refl + * exprsFreeIdsList returns the Ids bound by the args, + which won't include g + +You might wonder if this will match as often, but the simplifier replaces +complicated Refl coercions with Refl pretty aggressively. + +Note [Orphans and auto-generated rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise an INLINABLE function, or when we have +-fspecialise-aggressively, we auto-generate RULES that are orphans. +We don't want to warn about these, or we'd generate a lot of warnings. +Thus, we only warn about user-specified orphan rules. + +Indeed, we don't even treat the module as an orphan module if it has +auto-generated *rule* orphans. Orphan modules are read every time we +compile, so they are pretty obtrusive and slow down every compilation, +even non-optimised ones. (Reason: for type class instances it's a +type correctness issue.) But specialisation rules are strictly for +*optimisation* only so it's fine not to read the interface. + +What this means is that a SPEC rules from auto-specialisation in +module M will be used in other modules only if M.hi has been read for +some other reason, which is actually pretty likely. + +Note [From non-recursive to recursive] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in the non-recursive case, if any dict-binds depend on 'fn' we might +have built a recursive knot + + f a d x = + MkUD { ud_binds = NonRec d7 (MkD ..f..) + , ud_calls = ...(f T d7)... } + +The we generate + + Rec { fs x = [T/a, d7/d] + f a d x = + RULE f T _ = fs + d7 = ...f... } + +Here the recursion is only through the RULE. + +However we definitely should /not/ make the Rec in this wildly common +case: + d = ... + MkUD { ud_binds = NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +Here we want simply to add d to the floats, giving + MkUD { ud_binds = NonRec d (...) + NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +In general, we need only make this Rec if + - there are some specialisations (spec_binds non-empty) + - there are some dict_binds that depend on f (dump_dbs non-empty) + +Note [Avoiding loops] +~~~~~~~~~~~~~~~~~~~~~ +When specialising /dictionary functions/ we must be very careful to +avoid building loops. Here is an example that bit us badly, on +several distinct occasions. + +Here is one: #3591 + class Eq a => C a + instance Eq [a] => C [a] + +This translates to + dfun :: Eq [a] -> C [a] + dfun a d = MkD a d (meth d) + + d4 :: Eq [T] = + d2 :: C [T] = dfun T d4 + d1 :: Eq [T] = $p1 d2 + d3 :: C [T] = dfun T d1 + +None of these definitions is recursive. What happened was that we +generated a specialisation: + RULE forall d. dfun T d = dT :: C [T] + dT = (MkD a d (meth d)) [T/a, d1/d] + = MkD T d1 (meth d1) + +But now we use the RULE on the RHS of d2, to get + d2 = dT = MkD d1 (meth d1) + d1 = $p1 d2 + +and now d1 is bottom! The problem is that when specialising 'dfun' we +should first dump "below" the binding all floated dictionary bindings +that mention 'dfun' itself. So d2 and d3 (and hence d1) must be +placed below 'dfun', and thus unavailable to it when specialising +'dfun'. That in turn means that the call (dfun T d1) must be +discarded. On the other hand, the call (dfun T d4) is fine, assuming +d4 doesn't mention dfun. + +Solution: + Discard all calls that mention dictionaries that depend + (directly or indirectly) on the dfun we are specialising. + This is done by 'filterCalls' + +-------------- +Here's yet another example + + class C a where { foo,bar :: [a] -> [a] } + + instance C Int where + foo x = r_bar x + bar xs = reverse xs + + r_bar :: C a => [a] -> [a] + r_bar xs = bar (xs ++ xs) + +That translates to: + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs } + +The call (r_bar $fCInt) mentions $fCInt, + which mentions foo_help, + which mentions r_bar +But we DO want to specialise r_bar at Int: + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + RULE r_bar Int _ = r_bar_Int + + r_bar_Int xs = bar Int $fCInt (xs ++ xs) + } + +Note that, because of its RULE, r_bar joins the recursive +group. (In this case it'll unravel a short moment later.) + + +Note [Specialising a recursive group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let rec { f x = ...g x'... + ; g y = ...f y'.... } + in f 'a' +Here we specialise 'f' at Char; but that is very likely to lead to +a specialisation of 'g' at Char. We must do the latter, else the +whole point of specialisation is lost. + +But we do not want to keep iterating to a fixpoint, because in the +presence of polymorphic recursion we might generate an infinite number +of specialisations. + +So we use the following heuristic: + * Arrange the rec block in dependency order, so far as possible + (the occurrence analyser already does this) + + * Specialise it much like a sequence of lets + + * Then go through the block a second time, feeding call-info from + the RHSs back in the bottom, as it were + +In effect, the ordering maxmimises the effectiveness of each sweep, +and we do just two sweeps. This should catch almost every case of +monomorphic recursion -- the exception could be a very knotted-up +recursion with multiple cycles tied up together. + +This plan is implemented in the Rec case of specBindItself. + +Note [Specialisations already covered] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously don't want to generate two specialisations for the same +argument pattern. There are two wrinkles + +1. We do the already-covered test in specDefn, not when we generate +the CallInfo in mkCallUDs. We used to test in the latter place, but +we now iterate the specialiser somewhat, and the Id at the call site +might therefore not have all the RULES that we can see in specDefn + +2. What about two specialisations where the second is an *instance* +of the first? If the more specific one shows up first, we'll generate +specialisations for both. If the *less* specific one shows up first, +we *don't* currently generate a specialisation for the more specific +one. (See the call to lookupRule in already_covered.) Reasons: + (a) lookupRule doesn't say which matches are exact (bad reason) + (b) if the earlier specialisation is user-provided, it's + far from clear that we should auto-specialise further + +Note [Auto-specialisation and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + g :: Num a => a -> a + g = ... + + f :: (Int -> Int) -> Int + f w = ... + {-# RULE f g = 0 #-} + +Suppose that auto-specialisation makes a specialised version of +g::Int->Int That version won't appear in the LHS of the RULE for f. +So if the specialisation rule fires too early, the rule for f may +never fire. + +It might be possible to add new rules, to "complete" the rewrite system. +Thus when adding + RULE forall d. g Int d = g_spec +also add + RULE f g_spec = 0 + +But that's a bit complicated. For now we ask the programmer's help, +by *copying the INLINE activation pragma* to the auto-specialised +rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule +will also not be active until phase 2. And that's what programmers +should jolly well do anyway, even aside from specialisation, to ensure +that g doesn't inline too early. + +This in turn means that the RULE would never fire for a NOINLINE +thing so not much point in generating a specialisation at all. + +Note [Specialisation shape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only specialise a function if it has visible top-level lambdas +corresponding to its overloading. E.g. if + f :: forall a. Eq a => .... +then its body must look like + f = /\a. \d. ... + +Reason: when specialising the body for a call (f ty dexp), we want to +substitute dexp for d, and pick up specialised calls in the body of f. + +This doesn't always work. One example I came across was this: + newtype Gen a = MkGen{ unGen :: Int -> a } + + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) + + oneof = choose (1::Int) + +It's a silly example, but we get + choose = /\a. g `cast` co +where choose doesn't have any dict arguments. Thus far I have not +tried to fix this (wait till there's a real example). + +Mind you, then 'choose' will be inlined (since RHS is trivial) so +it doesn't matter. This comes up with single-method classes + + class C a where { op :: a -> a } + instance C a => C [a] where .... +==> + $fCList :: C a => C [a] + $fCList = $copList |> (...coercion>...) + ....(uses of $fCList at particular types)... + +So we suppress the WARN if the rhs is trivial. + +Note [Inline specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is what we do with the InlinePragma of the original function + * Activation/RuleMatchInfo: both transferred to the + specialised function + * InlineSpec: + (a) An INLINE pragma is transferred + (b) An INLINABLE pragma is *not* transferred + +Why (a): transfer INLINE pragmas? The point of INLINE was precisely to +specialise the function at its call site, and arguably that's not so +important for the specialised copies. BUT *pragma-directed* +specialisation now takes place in the typechecker/desugarer, with +manually specified INLINEs. The specialisation here is automatic. +It'd be very odd if a function marked INLINE was specialised (because +of some local use), and then forever after (including importing +modules) the specialised version wasn't INLINEd. After all, the +programmer said INLINE! + +You might wonder why we specialise INLINE functions at all. After +all they should be inlined, right? Two reasons: + + * Even INLINE functions are sometimes not inlined, when they aren't + applied to interesting arguments. But perhaps the type arguments + alone are enough to specialise (even though the args are too boring + to trigger inlining), and it's certainly better to call the + specialised version. + + * The RHS of an INLINE function might call another overloaded function, + and we'd like to generate a specialised version of that function too. + This actually happens a lot. Consider + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINABLE replicateM_ #-} + replicateM_ d x ma = ... + The strictness analyser may transform to + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINE replicateM_ #-} + replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma + + $wreplicateM_ :: (Monad m) => Int# -> m a -> m () + {-# INLINABLE $wreplicateM_ #-} + $wreplicateM_ = ... + Now an importing module has a specialised call to replicateM_, say + (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! + This particular example had a huge effect on the call to replicateM_ + in nofib/shootout/n-body. + +Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples. +Suppose we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int + f xs = letrec f' = ...f'... in f' +Then, when f is specialised and optimised we might get + wgo :: [Int] -> Int# + wgo = ...wgo... + f_spec :: [Int] -> Int + f_spec xs = case wgo xs of { r -> I# r } +and we clearly want to inline f_spec at call sites. But if we still +have the big, un-optimised of f (albeit specialised) captured in an +INLINABLE pragma for f_spec, we won't get that optimisation. + +So we simply drop INLINABLE pragmas when specialising. It's not really +a complete solution; ignoring specialisation for now, INLINABLE functions +don't get properly strictness analysed, for example. But it works well +for examples involving specialisation, which is the dominant use of +INLINABLE. See #4874. +-} + +{- ********************************************************************* +* * + SpecArg, and specHeader +* * +********************************************************************* -} + +-- | An argument that we might want to specialise. +-- See Note [Specialising Calls] for the nitty gritty details. +data SpecArg + = + -- | Type arguments that should be specialised, due to appearing + -- free in the type of a 'SpecDict'. + SpecType Type + + -- | Type arguments that should remain polymorphic. + | UnspecType + + -- | Dictionaries that should be specialised. mkCallUDs ensures + -- that only "interesting" dictionary arguments get a SpecDict; + -- see Note [Interesting dictionary arguments] + | SpecDict DictExpr + + -- | Value arguments that should not be specialised. + | UnspecArg + +instance Outputable SpecArg where + ppr (SpecType t) = text "SpecType" <+> ppr t + ppr UnspecType = text "UnspecType" + ppr (SpecDict d) = text "SpecDict" <+> ppr d + ppr UnspecArg = text "UnspecArg" + +specArgFreeVars :: SpecArg -> VarSet +specArgFreeVars (SpecType ty) = tyCoVarsOfType ty +specArgFreeVars (SpecDict dx) = exprFreeVars dx +specArgFreeVars UnspecType = emptyVarSet +specArgFreeVars UnspecArg = emptyVarSet + +isSpecDict :: SpecArg -> Bool +isSpecDict (SpecDict {}) = True +isSpecDict _ = False + +-- | Given binders from an original function 'f', and the 'SpecArg's +-- corresponding to its usage, compute everything necessary to build +-- a specialisation. +-- +-- We will use the running example from Note [Specialising Calls]: +-- +-- f :: forall a b c. Int -> Eq a => Show b => c -> Blah +-- f @a @b @c i dEqA dShowA x = blah +-- +-- Suppose we decide to specialise it at the following pattern: +-- +-- [ SpecType T1, SpecType T2, UnspecType, UnspecArg +-- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ] +-- +-- We'd eventually like to build the RULE +-- +-- RULE "SPEC f @T1 @T2 _" +-- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). +-- f @T1 @T2 @c i d1 d2 = $sf @c i +-- +-- and the specialisation '$sf' +-- +-- $sf :: forall c. Int -> c -> Blah +-- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) +-- +-- where dShow1 is a floated binding created by bindAuxiliaryDict. +-- +-- The cases for 'specHeader' below are presented in the same order as this +-- running example. The result of 'specHeader' for this example is as follows: +-- +-- ( -- Returned arguments +-- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] +-- , [x] +-- +-- -- RULE helpers +-- , [c, i, d1, d2] +-- , [T1, T2, c, i, d1, d2] +-- +-- -- Specialised function helpers +-- , [c, i, x] +-- , [dShow1 = $dfShow dShowT2] +-- , [T1, T2, c, i, dEqT1, dShow1] +-- ) +specHeader + :: SpecEnv + -> [InBndr] -- The binders from the original function 'f' + -> [SpecArg] -- From the CallInfo + -> SpecM ( Bool -- True <=> some useful specialisation happened + -- Not the same as any (isSpecDict args) because + -- the args might be longer than bndrs + + -- Returned arguments + , SpecEnv -- Substitution to apply to the body of 'f' + , [OutBndr] -- Leftover binders from the original function 'f' + -- that don’t have a corresponding SpecArg + + -- RULE helpers + , [OutBndr] -- Binders for the RULE + , [OutExpr] -- Args for the LHS of the rule + + -- Specialised function helpers + , [OutBndr] -- Binders for $sf + , [DictBind] -- Auxiliary dictionary bindings + , [OutExpr] -- Specialised arguments for unfolding + -- Same length as "args for LHS of rule" + ) + +-- We want to specialise on type 'T1', and so we must construct a substitution +-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding +-- details. +specHeader env (bndr : bndrs) (SpecType t : args) + = do { let env' = extendTvSubstList env [(bndr, t)] + ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( useful + , env'' + , leftover_bndrs + , rule_bs + , Type t : rule_es + , bs' + , dx + , Type t : spec_args + ) + } + +-- Next we have a type that we don't want to specialise. We need to perform +-- a substitution on it (in case the type refers to 'a'). Additionally, we need +-- to produce a binder, LHS argument and RHS argument for the resulting rule, +-- /and/ a binder for the specialised body. +specHeader env (bndr : bndrs) (UnspecType : args) + = do { let (env', bndr') = substBndr env bndr + ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( useful + , env'' + , leftover_bndrs + , bndr' : rule_bs + , varToCoreExpr bndr' : rule_es + , bndr' : bs' + , dx + , varToCoreExpr bndr' : spec_args + ) + } + +-- Next we want to specialise the 'Eq a' dict away. We need to construct +-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for +-- the nitty-gritty), as a LHS rule and unfolding details. +specHeader env (bndr : bndrs) (SpecDict d : args) + = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders] + ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d + ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( True -- Ha! A useful specialisation! + , env'' + , leftover_bndrs + -- See Note [Evidence foralls] + , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs + , varToCoreExpr bndr' : rule_es + , bs' + , maybeToList dx_bind ++ dx + , spec_dict : spec_args + ) + } + +-- Finally, we have the unspecialised argument 'i'. We need to produce +-- a binder, LHS and RHS argument for the RULE, and a binder for the +-- specialised body. +-- +-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is +-- why 'i' doesn't appear in our RULE above. But we have no guarantee that +-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so +-- this case must be here. +specHeader env (bndr : bndrs) (UnspecArg : args) + = do { -- see Note [Zap occ info in rule binders] + let (env', bndr') = substBndr env (zapIdOccInfo bndr) + ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( useful + , env'' + , leftover_bndrs + , bndr' : rule_bs + , varToCoreExpr bndr' : rule_es + , if isDeadBinder bndr + then bs' -- see Note [Drop dead args from specialisations] + else bndr' : bs' + , dx + , varToCoreExpr bndr' : spec_args + ) + } + +-- If we run out of binders, stop immediately +-- See Note [Specialisation Must Preserve Sharing] +specHeader env [] _ = pure (False, env, [], [], [], [], [], []) + +-- Return all remaining binders from the original function. These have the +-- invariant that they should all correspond to unspecialised arguments, so +-- it's safe to stop processing at this point. +specHeader env bndrs [] + = pure (False, env', bndrs', [], [], [], [], []) + where + (env', bndrs') = substBndrs env bndrs + + +-- | Binds a dictionary argument to a fresh name, to preserve sharing +bindAuxiliaryDict + :: SpecEnv + -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression + -> ( SpecEnv -- Substitute for orig_dict_id + , Maybe DictBind -- Auxiliary dict binding, if any + , OutExpr) -- Witnessing expression (always trivial) +bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting }) + orig_dict_id fresh_dict_id dict_expr + + -- If the dictionary argument is trivial, + -- don’t bother creating a new dict binding; just substitute + | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr + = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr + `Core.extendInScope` dict_id + -- See Note [Keep the old dictionaries interesting] + , se_interesting = interesting `extendVarSet` dict_id } + in (env', Nothing, dict_expr) + + | otherwise -- Non-trivial dictionary arg; make an auxiliary binding + = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr) + env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id) + `Core.extendInScope` fresh_dict_id + -- See Note [Make the new dictionaries interesting] + , se_interesting = interesting `extendVarSet` fresh_dict_id } + in (env', Just dict_bind, Var fresh_dict_id) + +{- +Note [Make the new dictionaries interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Important! We're going to substitute dx_id1 for d +and we want it to look "interesting", else we won't gather *any* +consequential calls. E.g. + f d = ...g d.... +If we specialise f for a call (f (dfun dNumInt)), we'll get +a consequent call (g d') with an auxiliary definition + d' = df dNumInt +We want that consequent call to look interesting + +Note [Keep the old dictionaries interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In bindAuxiliaryDict, we don’t bother creating a new dict binding if +the dict expression is trivial. For example, if we have + + f = \ @m1 (d1 :: Monad m1) -> ... + +and we specialize it at the pattern + + [SpecType IO, SpecArg $dMonadIO] + +it would be silly to create a new binding for $dMonadIO; it’s already +a binding! So we just extend the substitution directly: + + m1 :-> IO + d1 :-> $dMonadIO + +But this creates a new subtlety: the dict expression might be a dict +binding we floated out while specializing another function. For +example, we might have + + d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict + $sg = h @IO d2 + h = \ @m2 (d2 :: Applicative m2) -> ... + +and end up specializing h at the following pattern: + + [SpecType IO, SpecArg d2] + +When we created the d2 binding in the first place, we locally marked +it as interesting while specializing g as described above by +Note [Make the new dictionaries interesting]. But when we go to +specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the +knowledge that we should specialize on it. + +To fix this, we have to explicitly add d2 *back* to the interesting +set. That way, it will still be considered interesting while +specializing the body of h. See !2913. +-} + + +{- ********************************************************************* +* * + UsageDetails and suchlike +* * +********************************************************************* -} + +data UsageDetails + = MkUD { + ud_binds :: !(Bag DictBind), + -- See Note [Floated dictionary bindings] + -- The order is important; + -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 + -- (Remember, Bags preserve order in GHC.) + + ud_calls :: !CallDetails + + -- INVARIANT: suppose bs = bindersOf ud_binds + -- Then 'calls' may *mention* 'bs', + -- but there should be no calls *for* bs + } + +-- | A 'DictBind' is a binding along with a cached set containing its free +-- variables (both type variables and dictionaries) +data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } + +{- Note [Floated dictionary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We float out dictionary bindings for the reasons described under +"Dictionary floating" above. But not /just/ dictionary bindings. +Consider + + f :: Eq a => blah + f a d = rhs + + $c== :: T -> T -> Bool + $c== x y = ... + + $df :: Eq T + $df = Eq $c== ... + + gurgle = ...(f @T $df)... + +We gather the call info for (f @T $df), and we don't want to drop it +when we come across the binding for $df. So we add $df to the floats +and continue. But then we have to add $c== to the floats, and so on. +These all float above the binding for 'f', and now we can +successfully specialise 'f'. + +So the DictBinds in (ud_binds :: Bag DictBind) may contain +non-dictionary bindings too. +-} + +instance Outputable DictBind where + ppr (DB { db_bind = bind, db_fvs = fvs }) + = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind + , text "fvs: " <+> ppr fvs ]) + +instance Outputable UsageDetails where + ppr (MkUD { ud_binds = dbs, ud_calls = calls }) + = text "MkUD" <+> braces (sep (punctuate comma + [text "binds" <+> equals <+> ppr dbs, + text "calls" <+> equals <+> ppr calls])) + +emptyUDs :: UsageDetails +emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } + +------------------------------------------------------------ +type CallDetails = DIdEnv CallInfoSet + -- The order of specialized binds and rules depends on how we linearize + -- CallDetails, so to get determinism we must use a deterministic set here. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM + +data CallInfoSet = CIS Id (Bag CallInfo) + -- The list of types and dictionaries is guaranteed to + -- match the type of f + -- The Bag may contain duplicate calls (i.e. f @T and another f @T) + -- These dups are eliminated by already_covered in specCalls + +data CallInfo + = CI { ci_key :: [SpecArg] -- All arguments + , ci_fvs :: VarSet -- Free vars of the ci_key + -- call (including tyvars) + -- [*not* include the main id itself, of course] + } + +type DictExpr = CoreExpr + +ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet +ciSetFilter p (CIS id a) = CIS id (filterBag p a) + +instance Outputable CallInfoSet where + ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) + 2 (ppr map) + +pprCallInfo :: Id -> CallInfo -> SDoc +pprCallInfo fn (CI { ci_key = key }) + = ppr fn <+> ppr key + +ppr_call_key_ty :: SpecArg -> Maybe SDoc +ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty +ppr_call_key_ty UnspecType = Just $ char '_' +ppr_call_key_ty (SpecDict _) = Nothing +ppr_call_key_ty UnspecArg = Nothing + +instance Outputable CallInfo where + ppr (CI { ci_key = key, ci_fvs = _fvs }) + = text "CI" <> braces (sep (map ppr key)) + +unionCalls :: CallDetails -> CallDetails -> CallDetails +unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 + +unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet +unionCallInfoSet (CIS f calls1) (CIS _ calls2) = + CIS f (calls1 `unionBags` calls2) + +callDetailsFVs :: CallDetails -> VarSet +callDetailsFVs calls = + nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls + -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering + -- immediately by converting to a nondeterministic set. + +callInfoFVs :: CallInfoSet -> VarSet +callInfoFVs (CIS _ call_info) = + foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info + +getTheta :: [TyCoBinder] -> [PredType] +getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) + + +------------------------------------------------------------ +singleCall :: Id -> [SpecArg] -> UsageDetails +singleCall id args + = MkUD {ud_binds = emptyBag, + ud_calls = unitDVarEnv id $ CIS id $ + unitBag (CI { ci_key = args -- used to be tys + , ci_fvs = call_fvs }) } + where + call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args + -- The type args (tys) are guaranteed to be part of the dictionary + -- types, because they are just the constrained types, + -- and the dictionary is therefore sure to be bound + -- inside the binding for any type variables free in the type; + -- hence it's safe to neglect tyvars free in tys when making + -- the free-var set for this call + -- BUT I don't trust this reasoning; play safe and include tys_fvs + -- + -- We don't include the 'id' itself. + +mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails +mkCallUDs env f args + = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) + res + where + res = mkCallUDs' env f args + +mkCallUDs' env f args + | not (want_calls_for f) -- Imported from elsewhere + || null ci_key -- No useful specialisation + -- See also Note [Specialisations already covered] + = -- pprTrace "mkCallUDs: discarding" _trace_doc + emptyUDs + + | otherwise + = -- pprTrace "mkCallUDs: keeping" _trace_doc + singleCall f ci_key + where + _trace_doc = vcat [ppr f, ppr args, ppr ci_key] + pis = fst $ splitPiTys $ idType f + constrained_tyvars = tyCoVarsOfTypes $ getTheta pis + + ci_key :: [SpecArg] + ci_key = dropWhileEndLE (not . isSpecDict) $ + zipWith mk_spec_arg args pis + -- Drop trailing args until we get to a SpecDict + -- In this way the RULE has as few args as possible, + -- which broadens its applicability, since rules only + -- fire when saturated + + mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg + mk_spec_arg arg (Named bndr) + | binderVar bndr `elemVarSet` constrained_tyvars + = case arg of + Type ty -> SpecType ty + _ -> pprPanic "ci_key" $ ppr arg + | otherwise = UnspecType + + -- For "InvisArg", which are the type-class dictionaries, + -- we decide on a case by case basis if we want to specialise + -- on this argument; if so, SpecDict, if not UnspecArg + mk_spec_arg arg (Anon InvisArg pred) + | not (isIPLikePred (scaledThing pred)) + -- See Note [Type determines value] + , interestingDict env arg + -- See Note [Interesting dictionary arguments] + = SpecDict arg + + | otherwise = UnspecArg + + mk_spec_arg _ (Anon VisArg _) + = UnspecArg + + want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) + -- For imported things, we gather call instances if + -- there is an unfolding that we could in principle specialise + -- We might still decide not to use it (consulting dflags) + -- in specImports + -- Use 'realIdUnfolding' to ignore the loop-breaker flag! + +{- Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise on non-impicit-parameter predicates, because these +are the ones whose *type* determines their *value*. In particular, +with implicit params, the type args *don't* say what the value of the +implicit param is! See #7101. + +So we treat implicit params just like ordinary arguments for the +purposes of specialisation. Note that we still want to specialise +functions with implicit params if they have *other* dicts which are +class params; see #17930. + +Note [Interesting dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + \a.\d:Eq a. let f = ... in ...(f d)... +There really is not much point in specialising f wrt the dictionary d, +because the code for the specialised f is not improved at all, because +d is lambda-bound. We simply get junk specialisations. + +What is "interesting"? Just that it has *some* structure. But what about +variables? + + * A variable might be imported, in which case its unfolding + will tell us whether it has useful structure + + * Local variables are cloned on the way down (to avoid clashes when + we float dictionaries), and cloning drops the unfolding + (cloneIdBndr). Moreover, we make up some new bindings, and it's a + nuisance to give them unfoldings. So we keep track of the + "interesting" dictionaries as a VarSet in SpecEnv. + We have to take care to put any new interesting dictionary + bindings in the set. + +We accidentally lost accurate tracking of local variables for a long +time, because cloned variables don't have unfoldings. But makes a +massive difference in a few cases, eg #5113. For nofib as a +whole it's only a small win: 2.2% improvement in allocation for ansi, +1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. +-} + +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- A dictionary argument is interesting if it has *some* structure +-- NB: "dictionary" arguments include constraints of all sorts, +-- including equality constraints; hence the Coercion case +interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v) + || isDataConWorkId v + || v `elemVarSet` se_interesting env +interestingDict _ (Type _) = False +interestingDict _ (Coercion _) = False +interestingDict env (App fn (Type _)) = interestingDict env fn +interestingDict env (App fn (Coercion _)) = interestingDict env fn +interestingDict env (Tick _ a) = interestingDict env a +interestingDict env (Cast e _) = interestingDict env e +interestingDict _ _ = True + +plusUDs :: UsageDetails -> UsageDetails -> UsageDetails +plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) + (MkUD {ud_binds = db2, ud_calls = calls2}) + = MkUD { ud_binds = db1 `unionBags` db2 + , ud_calls = calls1 `unionCalls` calls2 } + +----------------------------- +_dictBindBndrs :: Bag DictBind -> [Id] +_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs + +-- | Construct a 'DictBind' from a 'CoreBind' +mkDB :: CoreBind -> DictBind +mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind } + +-- | Identify the free variables of a 'CoreBind' +bind_fvs :: CoreBind -> VarSet +bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) +bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs + where + bndrs = map fst prs + rhs_fvs = unionVarSets (map pair_fvs prs) + +pair_fvs :: (Id, CoreExpr) -> VarSet +pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs + `unionVarSet` idFreeVars bndr + -- idFreeVars: don't forget variables mentioned in + -- the rules of the bndr. C.f. OccAnal.addRuleUsage + -- Also tyvars mentioned in its type; they may not appear + -- in the RHS + -- type T a = Int + -- x :: T a = 3 + where + interesting :: InterestingVarFun + interesting v = isLocalVar v || (isId v && isDFunId v) + -- Very important: include DFunIds /even/ if it is imported + -- Reason: See Note [Avoiding loops], the second example + -- involving an imported dfun. We must know whether + -- a dictionary binding depends on an imported dfun, + -- in case we try to specialise that imported dfun + -- #13429 illustrates + +-- | Flatten a set of "dumped" 'DictBind's, and some other binding +-- pairs, into a single recursive binding. +recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind +recWithDumpedDicts pairs dbs + = DB { db_bind = Rec bindings, db_fvs = fvs } + where + (bindings, fvs) = foldr add ([], emptyVarSet) + (dbs `snocBag` mkDB (Rec pairs)) + add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc) + = case bind of + NonRec b r -> ((b,r) : prs_acc, fvs') + Rec prs1 -> (prs1 ++ prs_acc, fvs') + where + fvs' = fvs_acc `unionVarSet` fvs + +snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails +-- Add ud_binds to the tail end of the bindings in uds +snocDictBinds uds dbs + = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs } + +consDictBind :: DictBind -> UsageDetails -> UsageDetails +consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } + +addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails +addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds } + +snocDictBind :: UsageDetails -> DictBind -> UsageDetails +snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } + +wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] +wrapDictBinds dbs binds + = foldr add binds dbs + where + add (DB { db_bind = bind }) binds = bind : binds + +wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr +wrapDictBindsE dbs expr + = foldr add expr dbs + where + add (DB { db_bind = bind }) expr = Let bind expr + +---------------------- +dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) +-- Used at a lambda or case binder; just dump anything mentioning the binder +dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + | null bndrs = (uds, emptyBag) -- Common in case alternatives + | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ + (free_uds, dump_dbs) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor + deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be + -- no calls for any of the dicts in dump_dbs + +dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) +-- Used at a let(rec) binding. +-- We return a boolean indicating whether the binding itself is mentioned, +-- directly or indirectly, by any of the ud_calls; in that case we want to +-- float the binding itself; +-- See Note [Floated dictionary bindings] +dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ + (free_uds, dump_dbs, float_all) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsFor bndrs orig_calls + float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls + +callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) +callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace ("callsForMe") + -- (vcat [ppr fn, + -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), + -- text "Orig calls =" <+> ppr orig_calls, + -- text "Dep set =" <+> ppr dep_set, + -- text "Calls for me =" <+> ppr calls_for_me]) $ + (uds_without_me, calls_for_me) + where + uds_without_me = MkUD { ud_binds = orig_dbs + , ud_calls = delDVarEnv orig_calls fn } + calls_for_me = case lookupDVarEnv orig_calls fn of + Nothing -> [] + Just cis -> filterCalls cis orig_dbs + -- filterCalls: drop calls that (directly or indirectly) + -- refer to fn. See Note [Avoiding loops] + +---------------------- +filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo] +-- See Note [Avoiding loops] +filterCalls (CIS fn call_bag) dbs + = filter ok_call (bagToList call_bag) + where + dump_set = foldl' go (unitVarSet fn) dbs + -- This dump-set could also be computed by splitDictBinds + -- (_,_,dump_set) = splitDictBinds dbs {fn} + -- But this variant is shorter + + go so_far (DB { db_bind = bind, db_fvs = fvs }) + | fvs `intersectsVarSet` so_far + = extendVarSetList so_far (bindersOf bind) + | otherwise = so_far + + ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set + +---------------------- +splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) +-- splitDictBinds dbs bndrs returns +-- (free_dbs, dump_dbs, dump_set) +-- where +-- * dump_dbs depends, transitively on bndrs +-- * free_dbs does not depend on bndrs +-- * dump_set = bndrs `union` bndrs(dump_dbs) +splitDictBinds dbs bndr_set + = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs + -- Important that it's foldl' not foldr; + -- we're accumulating the set of dumped ids in dump_set + where + split_db (free_dbs, dump_dbs, dump_idset) db + | DB { db_bind = bind, db_fvs = fvs } <- db + , dump_idset `intersectsVarSet` fvs -- Dump it + = (free_dbs, dump_dbs `snocBag` db, + extendVarSetList dump_idset (bindersOf bind)) + + | otherwise -- Don't dump it + = (free_dbs `snocBag` db, dump_dbs, dump_idset) + + +---------------------- +deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails +-- Remove calls *mentioning* bs in any way +deleteCallsMentioning bs calls + = mapDVarEnv (ciSetFilter keep_call) calls + where + keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs + +deleteCallsFor :: [Id] -> CallDetails -> CallDetails +-- Remove calls *for* bs +deleteCallsFor bs calls = delDVarEnvList calls bs + +{- +************************************************************************ +* * +\subsubsection{Boring helper functions} +* * +************************************************************************ +-} + +newtype SpecM a = SpecM (State SpecState a) deriving (Functor) + +data SpecState = SpecState { + spec_uniq_supply :: UniqSupply, + spec_module :: Module, + spec_dflags :: DynFlags + } + +instance Applicative SpecM where + pure x = SpecM $ return x + (<*>) = ap + +instance Monad SpecM where + SpecM x >>= f = SpecM $ do y <- x + case f y of + SpecM z -> + z + +instance MonadFail SpecM where + fail str = SpecM $ error str + +instance MonadUnique SpecM where + getUniqueSupplyM + = SpecM $ do st <- get + let (us1, us2) = splitUniqSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us2 } + return us1 + + getUniqueM + = SpecM $ do st <- get + let (u,us') = takeUniqFromSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us' } + return u + +instance HasDynFlags SpecM where + getDynFlags = SpecM $ liftM spec_dflags get + +instance HasModule SpecM where + getModule = SpecM $ liftM spec_module get + +runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a +runSpecM dflags this_mod (SpecM spec) + = do us <- getUniqueSupplyM + let initialState = SpecState { + spec_uniq_supply = us, + spec_module = this_mod, + spec_dflags = dflags + } + return $ evalState spec initialState + +mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) +mapAndCombineSM _ [] = return ([], emptyUDs) +mapAndCombineSM f (x:xs) = do (y, uds1) <- f x + (ys, uds2) <- mapAndCombineSM f xs + return (y:ys, uds1 `plusUDs` uds2) + +extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv +extendTvSubstList env tv_binds + = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds } + +substTy :: SpecEnv -> Type -> Type +substTy env ty = Core.substTy (se_subst env) ty + +substCo :: SpecEnv -> Coercion -> Coercion +substCo env co = Core.substCo (se_subst env) co + +substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) +substBndr env bs = case Core.substBndr (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) +substBndrs env bs = case Core.substBndrs (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind) +-- Clone the binders of the bind; return new bind with the cloned binders +-- Return the substitution to use for RHSs, and the one to use for the body +cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) + = do { us <- getUniqueSupplyM + ; let (subst', bndr') = Core.cloneIdBndr subst us bndr + interesting' | interestingDict env rhs + = interesting `extendVarSet` bndr' + | otherwise = interesting + ; return (env, env { se_subst = subst', se_interesting = interesting' } + , NonRec bndr' rhs) } + +cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) + = do { us <- getUniqueSupplyM + ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs) + env' = env { se_subst = subst' + , se_interesting = interesting `extendVarSetList` + [ v | (v,r) <- pairs, interestingDict env r ] } + ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } + +newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr +-- Make up completely fresh binders for the dictionaries +-- Their bindings are going to float outwards +newDictBndr env b = do { uniq <- getUniqueM + ; let n = idName b + ty' = substTy env (idType b) + ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) } + +newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id + -- Give the new Id a similar occurrence name to the old one +newSpecIdSM old_id new_ty join_arity_maybe + = do { uniq <- getUniqueM + ; let name = idName old_id + new_occ = mkSpecOcc (nameOccName name) + new_id = mkUserLocal new_occ uniq Many new_ty (getSrcSpan name) + `asJoinId_maybe` join_arity_maybe + ; return new_id } + +{- + Old (but interesting) stuff about unboxed bindings + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +What should we do when a value is specialised to a *strict* unboxed value? + + map_*_* f (x:xs) = let h = f x + t = map f xs + in h:t + +Could convert let to case: + + map_*_Int# f (x:xs) = case f x of h# -> + let t = map f xs + in h#:t + +This may be undesirable since it forces evaluation here, but the value +may not be used in all branches of the body. In the general case this +transformation is impossible since the mutual recursion in a letrec +cannot be expressed as a case. + +There is also a problem with top-level unboxed values, since our +implementation cannot handle unboxed values at the top level. + +Solution: Lift the binding of the unboxed value and extract it when it +is used: + + map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# + t = map f xs + in case h of + _Lift h# -> h#:t + +Now give it to the simplifier and the _Lifting will be optimised away. + +The benefit is that we have given the specialised "unboxed" values a +very simple lifted semantics and then leave it up to the simplifier to +optimise it --- knowing that the overheads will be removed in nearly +all cases. + +In particular, the value will only be evaluated in the branches of the +program which use it, rather than being forced at the point where the +value is bound. For example: + + filtermap_*_* p f (x:xs) + = let h = f x + t = ... + in case p x of + True -> h:t + False -> t + ==> + filtermap_*_Int# p f (x:xs) + = let h = case (f x) of h# -> _Lift h# + t = ... + in case p x of + True -> case h of _Lift h# + -> h#:t + False -> t + +The binding for h can still be inlined in the one branch and the +_Lifting eliminated. + + +Question: When won't the _Lifting be eliminated? + +Answer: When they at the top-level (where it is necessary) or when +inlining would duplicate work (or possibly code depending on +options). However, the _Lifting will still be eliminated if the +strictness analyser deems the lifted binding strict. +-} diff --git a/GHC/Core/Opt/StaticArgs.hs b/GHC/Core/Opt/StaticArgs.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/StaticArgs.hs @@ -0,0 +1,434 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +************************************************************************ + + Static Argument Transformation pass + +************************************************************************ + +May be seen as removing invariants from loops: +Arguments of recursive functions that do not change in recursive +calls are removed from the recursion, which is done locally +and only passes the arguments which effectively change. + +Example: +map = /\ ab -> \f -> \xs -> case xs of + [] -> [] + (a:b) -> f a : map f b + +as map is recursively called with the same argument f (unmodified) +we transform it to + +map = /\ ab -> \f -> \xs -> let map' ys = case ys of + [] -> [] + (a:b) -> f a : map' b + in map' xs + +Notice that for a compiler that uses lambda lifting this is +useless as map' will be transformed back to what map was. + +We could possibly do the same for big lambdas, but we don't as +they will eventually be removed in later stages of the compiler, +therefore there is no penalty in keeping them. + +We only apply the SAT when the number of static args is > 2. This +produces few bad cases. See + should_transform +in saTransform. + +Here are the headline nofib results: + Size Allocs Runtime +Min +0.0% -13.7% -21.4% +Max +0.1% +0.0% +5.4% +Geometric Mean +0.0% -0.2% -6.9% + +The previous patch, to fix polymorphic floatout demand signatures, is +essential to make this work well! +-} + +{-# LANGUAGE CPP, PatternSynonyms #-} +module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Utils.Outputable + +import Data.List (mapAccumL) +import GHC.Data.FastString + +#include "HsVersions.h" + +doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram +doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds + where + sat_bind_threaded_us us bind = + let (us1, us2) = splitUniqSupply us + in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet)) + +-- We don't bother to SAT recursive groups since it can lead +-- to massive code expansion: see Andre Santos' thesis for details. +-- This means we only apply the actual SAT to Rec groups of one element, +-- but we want to recurse into the others anyway to discover other binds +satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo) +satBind (NonRec binder expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (NonRec binder expr', finalizeApp expr_app sat_info_expr) +satBind (Rec [(binder, rhs)]) interesting_ids = do + let interesting_ids' = interesting_ids `addOneToUniqSet` binder + (rhs_binders, rhs_body) = collectBinders rhs + (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids' + let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders) + sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body + + shadowing = binder `elementOfUniqSet` interesting_ids + sat_info_rhs'' = if shadowing + then sat_info_rhs' `delFromUFM` binder -- For safety + else sat_info_rhs' + + bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder) + rhs_binders rhs_body' + return (bind', sat_info_rhs'') +satBind (Rec pairs) interesting_ids = do + let (binders, rhss) = unzip pairs + rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss + let (rhss', sat_info_rhss') = unzip rhss_SATed + return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') + +data App = VarApp Id | TypeApp Type | CoApp Coercion +data Staticness a = Static a | NotStatic + +type IdAppInfo = (Id, SATInfo) + +type SATInfo = [Staticness App] +type IdSATInfo = IdEnv SATInfo +emptyIdSATInfo :: IdSATInfo +emptyIdSATInfo = emptyUFM + +{- +pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) + where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) +-} + +pprSATInfo :: SATInfo -> SDoc +pprSATInfo staticness = hcat $ map pprStaticness staticness + +pprStaticness :: Staticness App -> SDoc +pprStaticness (Static (VarApp _)) = text "SV" +pprStaticness (Static (TypeApp _)) = text "ST" +pprStaticness (Static (CoApp _)) = text "SC" +pprStaticness NotStatic = text "NS" + + +mergeSATInfo :: SATInfo -> SATInfo -> SATInfo +mergeSATInfo l r = zipWith mergeSA l r + where + mergeSA NotStatic _ = NotStatic + mergeSA _ NotStatic = NotStatic + mergeSA (Static (VarApp v)) (Static (VarApp v')) + | v == v' = Static (VarApp v) + | otherwise = NotStatic + mergeSA (Static (TypeApp t)) (Static (TypeApp t')) + | t `eqType` t' = Static (TypeApp t) + | otherwise = NotStatic + mergeSA (Static (CoApp c)) (Static (CoApp c')) + | c `eqCoercion` c' = Static (CoApp c) + | otherwise = NotStatic + mergeSA _ _ = pprPanic "mergeSATInfo" $ + text "Left:" + <> pprSATInfo l <> text ", " + <> text "Right:" + <> pprSATInfo r + +mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo +mergeIdSATInfo = plusUFM_C mergeSATInfo + +mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo +mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo + +bindersToSATInfo :: [Id] -> SATInfo +bindersToSATInfo vs = map (Static . binderToApp) vs + where binderToApp v | isId v = VarApp v + | isTyVar v = TypeApp $ mkTyVarTy v + | otherwise = CoApp $ mkCoVarCo v + +finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo +finalizeApp Nothing id_sat_info = id_sat_info +finalizeApp (Just (v, sat_info')) id_sat_info = + let sat_info'' = case lookupUFM id_sat_info v of + Nothing -> sat_info' + Just sat_info -> mergeSATInfo sat_info sat_info' + in extendVarEnv id_sat_info v sat_info'' + +satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo) +satTopLevelExpr expr interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (expr', finalizeApp expr_app sat_info_expr) + +satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) +satExpr var@(Var v) interesting_ids = do + let app_info = if v `elementOfUniqSet` interesting_ids + then Just (v, []) + else Nothing + return (var, emptyIdSATInfo, app_info) + +satExpr lit@(Lit _) _ = do + return (lit, emptyIdSATInfo, Nothing) + +satExpr (Lam binders body) interesting_ids = do + (body', sat_info, this_app) <- satExpr body interesting_ids + return (Lam binders body', finalizeApp this_app sat_info, Nothing) + +satExpr (App fn arg) interesting_ids = do + (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids + let satRemainder = boring fn' sat_info_fn + case fn_app of + Nothing -> satRemainder Nothing + Just (fn_id, fn_app_info) -> + -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) + let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) + in case arg of + Type t -> satRemainderWithStaticness $ Static (TypeApp t) + Coercion c -> satRemainderWithStaticness $ Static (CoApp c) + Var v -> satRemainderWithStaticness $ Static (VarApp v) + _ -> satRemainderWithStaticness $ NotStatic + where + boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) + boring fn' sat_info_fn app_info = + do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids + let sat_info_arg' = finalizeApp arg_app sat_info_arg + sat_info = mergeIdSATInfo sat_info_fn sat_info_arg' + return (App fn' arg', sat_info, app_info) + +satExpr (Case expr bndr ty alts) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + let sat_info_expr' = finalizeApp expr_app sat_info_expr + + zipped_alts' <- mapM satAlt alts + let (alts', sat_infos_alts) = unzip zipped_alts' + return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) + where + satAlt (con, bndrs, expr) = do + (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids + return ((con, bndrs, expr'), sat_info_expr) + +satExpr (Let bind body) interesting_ids = do + (body', sat_info_body, body_app) <- satExpr body interesting_ids + (bind', sat_info_bind) <- satBind bind interesting_ids + return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app) + +satExpr (Tick tickish expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Tick tickish expr', sat_info_expr, expr_app) + +satExpr ty@(Type _) _ = do + return (ty, emptyIdSATInfo, Nothing) + +satExpr co@(Coercion _) _ = do + return (co, emptyIdSATInfo, Nothing) + +satExpr (Cast expr coercion) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Cast expr' coercion, sat_info_expr, expr_app) + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ +-} + +type SatM result = UniqSM result + +runSAT :: UniqSupply -> SatM a -> a +runSAT = initUs_ + +newUnique :: SatM Unique +newUnique = getUniqueM + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ + +To do the transformation, the game plan is to: + +1. Create a small nonrecursive RHS that takes the + original arguments to the function but discards + the ones that are static and makes a call to the + SATed version with the remainder. We intend that + this will be inlined later, removing the overhead + +2. Bind this nonrecursive RHS over the original body + WITH THE SAME UNIQUE as the original body so that + any recursive calls to the original now go via + the small wrapper + +3. Rebind the original function to a new one which contains + our SATed function and just makes a call to it: + we call the thing making this call the local body + +Example: transform this + + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> body[map] +to + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> + letrec map' :: [a] -> [b] + -- The "worker function + map' = \(as:[a]) -> + let map :: forall a' b'. (a -> b) -> [a] -> [b] + -- The "shadow function + map = /\a'b'. \(f':(a->b) (as:[a]). + map' as + in body[map] + in map' as + +Note [Shadow binding] +~~~~~~~~~~~~~~~~~~~~~ +The calls to the inner map inside body[map] should get inlined +by the local re-binding of 'map'. We call this the "shadow binding". + +But we can't use the original binder 'map' unchanged, because +it might be exported, in which case the shadow binding won't be +discarded as dead code after it is inlined. + +So we use a hack: we make a new SysLocal binder with the *same* unique +as binder. (Another alternative would be to reset the export flag.) + +Note [Binder type capture] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that in the inner map (the "shadow function"), the static arguments +are discarded -- it's as if they were underscores. Instead, mentions +of these arguments (notably in the types of dynamic arguments) are bound +by the *outer* lambdas of the main function. So we must make up fresh +names for the static arguments so that they do not capture variables +mentioned in the types of dynamic args. + +In the map example, the shadow function must clone the static type +argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a' +is bound by the outer forall. We clone f' too for consistency, but +that doesn't matter either way because static Id arguments aren't +mentioned in the shadow binding at all. + +If we don't we get something like this: + +[Exported] +[Arity 3] +GHC.Base.until = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + letrec { + sat_worker_s1aU :: a_aiK -> a_aiK + [] + sat_worker_s1aU = + \ (x_a6X :: a_aiK) -> + let { + sat_shadow_r17 :: forall a_a3O. + (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O + [] + sat_shadow_r17 = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + sat_worker_s1aU x_a6X } in + case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { + GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); + GHC.Types.True -> x_a6X + }; } in + sat_worker_s1aU x_a6X + +Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK +type argument. This is bad because it means the application sat_worker_s1aU x_a6X +is not well typed. +-} + +saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body + | Just arg_staticness <- maybe_arg_staticness + , should_transform arg_staticness + = saTransform binder arg_staticness rhs_binders rhs_body + | otherwise + = return (Rec [(binder, mkLams rhs_binders rhs_body)]) + where + should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT + where + n_static_args = count isStaticValue staticness + +saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransform binder arg_staticness rhs_binders rhs_body + = do { shadow_lam_bndrs <- mapM clone binders_w_staticness + ; uniq <- newUnique + ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } + where + -- Running example: foldr + -- foldr \alpha \beta c n xs = e, for some e + -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic] + -- rhs_binders = [\alpha, \beta, c, n, xs] + -- rhs_body = e + + binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) + -- Any extra args are assumed NotStatic + + non_static_args :: [Var] + -- non_static_args = [xs] + -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] + non_static_args = [v | (v, NotStatic) <- binders_w_staticness] + + clone (bndr, NotStatic) = return bndr + clone (bndr, _ ) = do { uniq <- newUnique + ; return (setVarUnique bndr uniq) } + + -- new_rhs = \alpha beta c n xs -> + -- let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs -> + -- sat_worker xs + -- in e + -- in sat_worker xs + mk_new_rhs uniq shadow_lam_bndrs + = mkLams rhs_binders $ + Let (Rec [(rec_body_bndr, rec_body)]) + local_body + where + local_body = mkVarApps (Var rec_body_bndr) non_static_args + + rec_body = mkLams non_static_args $ + Let (NonRec shadow_bndr shadow_rhs) rhs_body + + -- See Note [Binder type capture] + shadow_rhs = mkLams shadow_lam_bndrs local_body + -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs + + rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq Many (exprType rec_body) + -- rec_body_bndr = sat_worker + + -- See Note [Shadow binding]; make a SysLocal + shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) + (idUnique binder) + Many + (exprType shadow_rhs) + +isStaticValue :: Staticness App -> Bool +isStaticValue (Static (VarApp _)) = True +isStaticValue _ = False diff --git a/GHC/Core/Opt/WorkWrap.hs b/GHC/Core/Opt/WorkWrap.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/WorkWrap.hs @@ -0,0 +1,789 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} +-} + +{-# LANGUAGE CPP #-} +module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where + +import GHC.Prelude + +import GHC.Core.Opt.Arity ( manifestArity ) +import GHC.Core +import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) +import GHC.Core.Utils ( exprType, exprIsHNF ) +import GHC.Core.FVs ( exprFreeVars ) +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Type +import GHC.Types.Unique.Supply +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.Opt.WorkWrap.Utils +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Core.FamInstEnv +import GHC.Utils.Monad + +#include "HsVersions.h" + +{- +We take Core bindings whose binders have: + +\begin{enumerate} + +\item Strictness attached (by the front-end of the strictness +analyser), and / or + +\item Constructed Product Result information attached by the CPR +analysis pass. + +\end{enumerate} + +and we return some ``plain'' bindings which have been +worker/wrapper-ified, meaning: + +\begin{enumerate} + +\item Functions have been split into workers and wrappers where +appropriate. If a function has both strictness and CPR properties +then only one worker/wrapper doing both transformations is produced; + +\item Binders' @IdInfos@ have been updated to reflect the existence of +these workers/wrappers (this is where we get STRICTNESS and CPR pragma +info for exported values). +\end{enumerate} +-} + +wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram + +wwTopBinds dflags fam_envs us top_binds + = initUs_ us $ do + top_binds' <- mapM (wwBind dflags fam_envs) top_binds + return (concat top_binds') + +{- +************************************************************************ +* * +\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} +* * +************************************************************************ + +@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in +turn. Non-recursive case first, then recursive... +-} + +wwBind :: DynFlags + -> FamInstEnvs + -> CoreBind + -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; + -- the caller will convert to Expr/Binding, + -- as appropriate. + +wwBind dflags fam_envs (NonRec binder rhs) = do + new_rhs <- wwExpr dflags fam_envs rhs + new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs + return [NonRec b e | (b,e) <- new_pairs] + -- Generated bindings must be non-recursive + -- because the original binding was. + +wwBind dflags fam_envs (Rec pairs) + = return . Rec <$> concatMapM do_one pairs + where + do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs + tryWW dflags fam_envs Recursive binder new_rhs + +{- +@wwExpr@ basically just walks the tree, looking for appropriate +annotations that can be used. Remember it is @wwBind@ that does the +matching by looking for strict arguments of the correct type. +@wwExpr@ is a version that just returns the ``Plain'' Tree. +-} + +wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr + +wwExpr _ _ e@(Type {}) = return e +wwExpr _ _ e@(Coercion {}) = return e +wwExpr _ _ e@(Lit {}) = return e +wwExpr _ _ e@(Var {}) = return e + +wwExpr dflags fam_envs (Lam binder expr) + = Lam new_binder <$> wwExpr dflags fam_envs expr + where new_binder | isId binder = zapIdUsedOnceInfo binder + | otherwise = binder + -- See Note [Zapping Used Once info in WorkWrap] + +wwExpr dflags fam_envs (App f a) + = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a + +wwExpr dflags fam_envs (Tick note expr) + = Tick note <$> wwExpr dflags fam_envs expr + +wwExpr dflags fam_envs (Cast expr co) = do + new_expr <- wwExpr dflags fam_envs expr + return (Cast new_expr co) + +wwExpr dflags fam_envs (Let bind expr) + = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr + +wwExpr dflags fam_envs (Case expr binder ty alts) = do + new_expr <- wwExpr dflags fam_envs expr + new_alts <- mapM ww_alt alts + let new_binder = zapIdUsedOnceInfo binder + -- See Note [Zapping Used Once info in WorkWrap] + return (Case new_expr new_binder ty new_alts) + where + ww_alt (con, binders, rhs) = do + new_rhs <- wwExpr dflags fam_envs rhs + let new_binders = [ if isId b then zapIdUsedOnceInfo b else b + | b <- binders ] + -- See Note [Zapping Used Once info in WorkWrap] + return (con, new_binders, new_rhs) + +{- +************************************************************************ +* * +\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} +* * +************************************************************************ + +@tryWW@ just accumulates arguments, converts strictness info from the +front-end into the proper form, then calls @mkWwBodies@ to do +the business. + +The only reason this is monadised is for the unique supply. + +Note [Don't w/w INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important to refrain from w/w-ing an INLINE function (ie one +with a stable unfolding) because the wrapper will then overwrite the +old stable unfolding with the wrapper code. + +Furthermore, if the programmer has marked something as INLINE, +we may lose by w/w'ing it. + +If the strictness analyser is run twice, this test also prevents +wrappers (which are INLINEd) from being re-done. (You can end up with +several liked-named Ids bouncing around at the same time---absolute +mischief.) + +Notice that we refrain from w/w'ing an INLINE function even if it is +in a recursive group. It might not be the loop breaker. (We could +test for loop-breaker-hood, but I'm not sure that ever matters.) + +Note [Worker-wrapper for INLINABLE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int -> a + f x y = ....f.... + +where f is strict in y, we might get a more efficient loop by w/w'ing +f. But that would make a new unfolding which would overwrite the old +one! So the function would no longer be INLNABLE, and in particular +will not be specialised at call sites in other modules. + +This comes in practice (#6056). + +Solution: do the w/w for strictness analysis, but transfer the Stable +unfolding to the *worker*. So we will get something like this: + + {-# INLINE[0] f #-} + f :: Ord a => [a] -> Int -> a + f d x y = case y of I# y' -> fw d x y' + + {-# INLINABLE[0] fw #-} + fw :: Ord a => [a] -> Int# -> a + fw d x y' = let y = I# y' in ...f... + +How do we "transfer the unfolding"? Easy: by using the old one, wrapped +in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. + +Note [Worker-wrapper for NOINLINE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to disable worker/wrapper for NOINLINE things, but it turns out +this can cause unnecessary reboxing of values. Consider + + {-# NOINLINE f #-} + f :: Int -> a + f x = error (show x) + + g :: Bool -> Bool -> Int -> Int + g True True p = f p + g False True p = p + 1 + g b False p = g b True p + +the strictness analysis will discover f and g are strict, but because f +has no wrapper, the worker for g will rebox p. So we get + + $wg x y p# = + let p = I# p# in -- Yikes! Reboxing! + case x of + False -> + case y of + False -> $wg False True p# + True -> +# p# 1# + True -> + case y of + False -> $wg True True p# + True -> case f p of { } + + g x y p = case p of (I# p#) -> $wg x y p# + +Now, in this case the reboxing will float into the True branch, and so +the allocation will only happen on the error path. But it won't float +inwards if there are multiple branches that call (f p), so the reboxing +will happen on every call of g. Disaster. + +Solution: do worker/wrapper even on NOINLINE things; but move the +NOINLINE pragma to the worker. + +(See #13143 for a real-world example.) + +It is crucial that we do this for *all* NOINLINE functions. #10069 +demonstrates what happens when we promise to w/w a (NOINLINE) leaf +function, but fail to deliver: + + data C = C Int# Int# + + {-# NOINLINE c1 #-} + c1 :: C -> Int# + c1 (C _ n) = n + + {-# NOINLINE fc #-} + fc :: C -> Int# + fc c = 2 *# c1 c + +Failing to w/w `c1`, but still w/wing `fc` leads to the following code: + + c1 :: C -> Int# + c1 (C _ n) = n + + $wfc :: Int# -> Int# + $wfc n = let c = C 0# n in 2 #* c1 c + + fc :: C -> Int# + fc (C _ n) = $wfc n + +Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place. +This generalises to any function that derives its strictness signature from +its callees, so we have to make sure that when a function announces particular +strictness properties, we have to w/w them accordingly, even if it means +splitting a NOINLINE function. + +Note [Worker activation] +~~~~~~~~~~~~~~~~~~~~~~~~ +Follows on from Note [Worker-wrapper for INLINABLE functions] + +It is *vital* that if the worker gets an INLINABLE pragma (from the +original function), then the worker has the same phase activation as +the wrapper (or later). That is necessary to allow the wrapper to +inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils +Note [Simplifying inside stable unfoldings]. + +If the original is NOINLINE, it's important that the work inherit the +original activation. Consider + + {-# NOINLINE expensive #-} + expensive x = x + 1 + + f y = let z = expensive y in ... + +If expensive's worker inherits the wrapper's activation, +we'll get this (because of the compromise in point (2) of +Note [Wrapper activation]) + + {-# NOINLINE[0] $wexpensive #-} + $wexpensive x = x + 1 + {-# INLINE[0] expensive #-} + expensive x = $wexpensive x + + f y = let z = expensive y in ... + +and $wexpensive will be immediately inlined into expensive, followed by +expensive into f. This effectively removes the original NOINLINE! + +Otherwise, nothing is lost by giving the worker the same activation as the +wrapper, because the worker won't have any chance of inlining until the +wrapper does; there's no point in giving it an earlier activation. + +Note [Don't w/w inline small non-loop-breaker things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we refrain from w/w-ing *small* functions, which are not +loop breakers, because they'll inline anyway. But we must take care: +it may look small now, but get to be big later after other inlining +has happened. So we take the precaution of adding an INLINE pragma to +any such functions. + +I made this change when I observed a big function at the end of +compilation with a useful strictness signature but no w-w. (It was +small during demand analysis, we refrained from w/w, and then got big +when something was inlined in its rhs.) When I measured it on nofib, +it didn't make much difference; just a few percent improved allocation +on one benchmark (bspt/Euclid.space). But nothing got worse. + +There is an infelicity though. We may get something like + f = g val +==> + g x = case gw x of r -> I# r + + f {- InlineStable, Template = g val -} + f = case gw x of r -> I# r + +The code for f duplicates that for g, without any real benefit. It +won't really be executed, because calls to f will go via the inlining. + +Note [Don't w/w join points for CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no point in exploiting CPR info on a join point. If the whole function +is getting CPR'd, then the case expression around the worker function will get +pushed into the join point by the simplifier, which will have the same effect +that w/w'ing for CPR would have - the result will be returned in an unboxed +tuple. + + f z = let join j x y = (x+1, y+1) + in case z of A -> j 1 2 + B -> j 2 3 + + => + + f z = case $wf z of (# a, b #) -> (a, b) + $wf z = case (let join j x y = (x+1, y+1) + in case z of A -> j 1 2 + B -> j 2 3) of (a, b) -> (# a, b #) + + => + + f z = case $wf z of (# a, b #) -> (a, b) + $wf z = let join j x y = (# x+1, y+1 #) + in case z of A -> j 1 2 + B -> j 2 3 + +Note that we still want to give @j@ the CPR property, so that @f@ has it. So +CPR *analyse* join points as regular functions, but don't *transform* them. + +Doing W/W for returned products on a join point would be tricky anyway, as the +worker could not be a join point because it would not be tail-called. However, +doing the *argument* part of W/W still works for join points, since the wrapper +body will make a tail call: + + f z = let join j x y = x + y + in ... + + => + + f z = let join $wj x# y# = x# +# y# + j x y = case x of I# x# -> + case y of I# y# -> + $wj x# y# + in ... + +Note [Wrapper activation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When should the wrapper inlining be active? + +1. It must not be active earlier than the current Activation of the + Id + +2. It should be active at some point, despite (1) because of + Note [Worker-wrapper for NOINLINE functions] + +3. For ordinary functions with no pragmas we want to inline the + wrapper as early as possible (#15056). Suppose another module + defines f x = g x x + and suppose there is some RULE for (g True True). Then if we have + a call (f True), we'd expect to inline 'f' and the RULE will fire. + But if f is w/w'd (which it might be), we want the inlining to + occur just as if it hadn't been. + + (This only matters if f's RHS is big enough to w/w, but small + enough to inline given the call site, but that can happen.) + +4. We do not want to inline the wrapper before specialisation. + module Foo where + f :: Num a => a -> Int -> a + f n 0 = n -- Strict in the Int, hence wrapper + f n x = f (n+n) (x-1) + + g :: Int -> Int + g x = f x x -- Provokes a specialisation for f + + module Bar where + import Foo + + h :: Int -> Int + h x = f 3 x + + In module Bar we want to give specialisations a chance to fire + before inlining f's wrapper. + + Historical note: At one stage I tried making the wrapper inlining + always-active, and that had a very bad effect on nofib/imaginary/x2n1; + a wrapper was inlined before the specialisation fired. + +Reminder: Note [Don't w/w INLINE things], so we don't need to worry + about INLINE things here. + +Conclusion: + - If the user said NOINLINE[n], respect that + + - If the user said NOINLINE, inline the wrapper only after + phase 0, the last user-visible phase. That means that all + rules will have had a chance to fire. + + What phase is after phase 0? Answer: FinalPhase, that's the reason it + exists. NB: Similar to InitialPhase, users can't write INLINE[Final] f; + it's syntactically illegal. + + - Otherwise inline wrapper in phase 2. That allows the + 'gentle' simplification pass to apply specialisation rules + + +Note [Wrapper NoUserInline] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The use an inl_inline of NoUserInline on the wrapper distinguishes +this pragma from one that was given by the user. In particular, CSE +will not happen if there is a user-specified pragma, but should happen +for w/w’ed things (#14186). +-} + +tryWW :: DynFlags + -> FamInstEnvs + -> RecFlag + -> Id -- The fn binder + -> CoreExpr -- The bound rhs; its innards + -- are already ww'd + -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; + -- if one, then no worker (only + -- the orig "wrapper" lives on); + -- if two, then a worker and a + -- wrapper. +tryWW dflags fam_envs is_rec fn_id rhs + -- See Note [Worker-wrapper for NOINLINE functions] + + | Just stable_unf <- certainlyWillInline dflags fn_info + = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] + -- See Note [Don't w/w INLINE things] + -- See Note [Don't w/w inline small non-loop-breaker things] + + | is_fun && is_eta_exp + = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs + + | is_thunk -- See Note [Thunk splitting] + = splitThunk dflags fam_envs is_rec new_fn_id rhs + + | otherwise + = return [ (new_fn_id, rhs) ] + + where + fn_info = idInfo fn_id + (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) + + cpr_ty = getCprSig (cprInfo fn_info) + -- Arity of the CPR sig should match idArity when it's not a join point. + -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal + cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info + , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) + ct_cpr cpr_ty + + new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) + -- See Note [Zapping DmdEnv after Demand Analyzer] and + -- See Note [Zapping Used Once info WorkWrap] + + is_fun = notNull wrap_dmds || isJoinId fn_id + -- See Note [Don't eta expand in w/w] + is_eta_exp = length wrap_dmds == manifestArity rhs + is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) + && not (isUnliftedType (idType fn_id)) + +{- +Note [Zapping DmdEnv after Demand Analyzer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the worker-wrapper pass we zap the DmdEnv. Why? + (a) it is never used again + (b) it wastes space + (c) it becomes incorrect as things are cloned, because + we don't push the substitution into it + +Why here? + * Because we don’t want to do it in the Demand Analyzer, as we never know + there when we are doing the last pass. + * We want them to be still there at the end of DmdAnal, so that + -ddump-str-anal contains them. + * We don’t want a second pass just for that. + * WorkWrap looks at all bindings anyway. + +We also need to do it in TidyCore.tidyLetBndr to clean up after the +final, worker/wrapper-less run of the demand analyser (see +Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal). + +Note [Zapping Used Once info in WorkWrap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the worker-wrapper pass we zap the used once info in demands and in +strictness signatures. + +Why? + * The simplifier may happen to transform code in a way that invalidates the + data (see #11731 for an example). + * It is not used in later passes, up to code generation. + +So as the data is useless and possibly wrong, we want to remove it. The most +convenient place to do that is the worker wrapper phase, as it runs after every +run of the demand analyser besides the very last one (which is the one where we +want to _keep_ the info for the code generator). + +We do not do it in the demand analyser for the same reasons outlined in +Note [Zapping DmdEnv after Demand Analyzer] above. + +Note [Don't eta expand in w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A binding where the manifestArity of the RHS is less than idArity of the binder +means GHC.Core.Opt.Arity didn't eta expand that binding. When this happens, it does so +for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have +a PAP, cast or trivial expression as RHS. + +Performing the worker/wrapper split will implicitly eta-expand the binding to +idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with +divergence, it's also broken for newtypes: + + f = (\xy.blah) |> co + where + co :: (Int -> Int -> Char) ~ T + +Then idArity is 2 (despite the type T), and it can have a StrictSig based on a +threshold of 2. But we can't w/w it without a type error. + +The situation is less grave for PAPs, but the implicit eta expansion caused a +compiler allocation regression in T15164, where huge recursive instance method +groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the +simplifier, when simply waiting for the PAPs to inline arrived at the same +output program. + +Note there is the worry here that such PAPs and trivial RHSs might not *always* +be inlined. That would lead to reboxing, because the analysis tacitly assumes +that we W/W'd for idArity and will propagate analysis information under that +assumption. So far, this doesn't seem to matter in practice. +See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. +-} + + +--------------------- +splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr + -> UniqSM [(Id, CoreExpr)] +splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs + = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do + -- The arity should match the signature + stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info + case stuff of + Just (work_demands, join_arity, wrap_fn, work_fn) -> do + work_uniq <- getUniqueM + let work_rhs = work_fn rhs + work_act = case fn_inline_spec of -- See Note [Worker activation] + NoInline -> inl_act fn_inl_prag + _ -> inl_act wrap_prag + + work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = fn_inline_spec + , inl_sat = Nothing + , inl_act = work_act + , inl_rule = FunLike } + -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] + -- inl_act: see Note [Worker activation] + -- inl_rule: it does not make sense for workers to be constructorlike. + + work_join_arity | isJoinId fn_id = Just join_arity + | otherwise = Nothing + -- worker is join point iff wrapper is join point + -- (see Note [Don't w/w join points for CPR]) + + work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + `setIdOccInfo` occInfo fn_info + -- Copy over occurrence info from parent + -- Notably whether it's a loop breaker + -- Doesn't matter much, since we will simplify next, but + -- seems right-er to do so + + `setInlinePragma` work_prag + + `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding + -- See Note [Worker-wrapper for INLINABLE functions] + + `setIdStrictness` mkClosedStrictSig work_demands div + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv + + `setIdCprInfo` mkCprSig work_arity work_cpr_info + + `setIdDemandInfo` worker_demand + + `setIdArity` work_arity + -- Set the arity so that the Core Lint check that the + -- arity is consistent with the demand type goes + -- through + `asJoinId_maybe` work_join_arity + + work_arity = length work_demands + + -- See Note [Demand on the Worker] + single_call = saturatedByOneShots arity (demandInfo fn_info) + worker_demand | single_call = mkWorkerDemand work_arity + | otherwise = topDmd + + wrap_rhs = wrap_fn work_id + wrap_prag = mkStrWrapperInlinePrag fn_inl_prag + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule dflags wrap_rhs arity + `setInlinePragma` wrap_prag + `setIdOccInfo` noOccInfo + -- Zap any loop-breaker-ness, to avoid bleating from Lint + -- about a loop breaker with an INLINE rule + + + + return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] + -- Worker first, because wrapper mentions it + + Nothing -> return [(fn_id, rhs)] + where + rhs_fvs = exprFreeVars rhs + fn_inl_prag = inlinePragInfo fn_info + fn_inline_spec = inl_inline fn_inl_prag + fn_unfolding = unfoldingInfo fn_info + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas + + -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, + -- see Note [Don't w/w join points for CPR]. + use_cpr_info | isJoinId fn_id = topCpr + | otherwise = cpr + -- Even if we don't w/w join points for CPR, we might still do so for + -- strictness. In which case a join point worker keeps its original CPR + -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker + -- doesn't have the CPR property anymore. + work_cpr_info | isJoinId fn_id = cpr + | otherwise = topCpr + + +mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma +mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) + = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = NoUserInline -- See Note [Wrapper NoUserInline] + , inl_sat = Nothing + , inl_act = wrap_act + , inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected + where + wrap_act = case act of -- See Note [Wrapper activation] + NeverActive -> activateDuringFinal + FinalActive -> act + ActiveAfter {} -> act + ActiveBefore {} -> activateAfterInitial + AlwaysActive -> activateAfterInitial + -- For the last two cases, see (4) in Note [Wrapper activation] + -- NB: the (ActiveBefore n) isn't quite right. We really want + -- it to be active *after* Initial but *before* n. We don't have + -- a way to say that, alas. + +{- +Note [Demand on the worker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If the original function is called once, according to its demand info, then +so is the worker. This is important so that the occurrence analyser can +attach OneShot annotations to the worker’s lambda binders. + + +Example: + + -- Original function + f [Demand=] :: (a,a) -> a + f = \p -> ... + + -- Wrapper + f [Demand=] :: a -> a -> a + f = \p -> case p of (a,b) -> $wf a b + + -- Worker + $wf [Demand=] :: Int -> Int + $wf = \a b -> ... + +We need to check whether the original function is called once, with +sufficiently many arguments. This is done using saturatedByOneShots, which +takes the arity of the original function (resp. the wrapper) and the demand on +the original function. + +The demand on the worker is then calculated using mkWorkerDemand, and always of +the form [Demand=] + + +Note [Do not split void functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this rather common form of binding: + $j = \x:Void# -> ...no use of x... + +Since x is not used it'll be marked as absent. But there is no point +in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Opt.WorkWrap.Utils.mkWorerArgs. + +If x has a more interesting type (eg Int, or Int#), there *is* a point +in w/w so that we don't pass the argument at all. + +Note [Thunk splitting] +~~~~~~~~~~~~~~~~~~~~~~ +Suppose x is used strictly (never mind whether it has the CPR +property). + + let + x* = x-rhs + in body + +splitThunk transforms like this: + + let + x* = case x-rhs of { I# a -> I# a } + in body + +Now simplifier will transform to + + case x-rhs of + I# a -> let x* = I# a + in body + +which is what we want. Now suppose x-rhs is itself a case: + + x-rhs = case e of { T -> I# a; F -> I# b } + +The join point will abstract over a, rather than over (which is +what would have happened before) which is fine. + +Notice that x certainly has the CPR property now! + +In fact, splitThunk uses the function argument w/w splitting +function, so that if x's demand is deeper (say U(U(L,L),L)) +then the splitting will go deeper too. +-} + +-- See Note [Thunk splitting] +-- splitThunk converts the *non-recursive* binding +-- x = e +-- into +-- x = let x = e +-- in case x of +-- I# y -> let x = I# y in x } +-- See comments above. Is it not beautifully short? +-- Moreover, it works just as well when there are +-- several binders, and if the binders are lifted +-- E.g. x = e +-- --> x = let x = e in +-- case x of (a,b) -> let x = (a,b) in x + +splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] +splitThunk dflags fam_envs is_rec fn_id rhs + = ASSERT(not (isJoinId fn_id)) + do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id] + ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] + ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive + return res + else return [(fn_id, rhs)] } diff --git a/GHC/Core/Opt/WorkWrap/Utils.hs b/GHC/Core/Opt/WorkWrap/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/WorkWrap/Utils.hs @@ -0,0 +1,1298 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +A library for the ``worker\/wrapper'' back-end to the strictness analyser +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.WorkWrap.Utils + ( mkWwBodies, mkWWstr, mkWorkerArgs + , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox + , findTypeShape + , isWorkerSmallEnough + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) +import GHC.Types.Id +import GHC.Types.Id.Info ( JoinArity ) +import GHC.Core.DataCon +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup + , mkCoreApp, mkCoreLet ) +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Builtin.Types ( tupleDataCon ) +import GHC.Builtin.Types.Prim ( voidPrimTy ) +import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) +import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Var.Set ( VarSet ) +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.Predicate ( isClassPred ) +import GHC.Types.RepType ( isVoidTy, typePrimRep ) +import GHC.Core.Coercion +import GHC.Core.FamInstEnv +import GHC.Types.Basic ( Boxity(..) ) +import GHC.Core.TyCon +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Data.List.SetOps + +{- +************************************************************************ +* * +\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} +* * +************************************************************************ + +Here's an example. The original function is: + +\begin{verbatim} +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +From this, we want to produce: +\begin{verbatim} +-- wrapper (an unfolding) +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + I# x# -> $wg a x# ys + -- call the worker; don't forget the type args! + +-- worker +$wg :: forall a . Int# -> [a] -> a + +$wg = \/\ a -> \ x# ys -> + let + x = I# x# + in + case x of -- note: body of g moved intact + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +Something we have to be careful about: Here's an example: + +\begin{verbatim} +-- "f" strictness: U(P)U(P) +f (I# a) (I# b) = a +# b + +g = f -- "g" strictness same as "f" +\end{verbatim} + +\tr{f} will get a worker all nice and friendly-like; that's good. +{\em But we don't want a worker for \tr{g}}, even though it has the +same strictness as \tr{f}. Doing so could break laziness, at best. + +Consequently, we insist that the number of strictness-info items is +exactly the same as the number of lambda-bound arguments. (This is +probably slightly paranoid, but OK in practice.) If it isn't the +same, we ``revise'' the strictness info, so that we won't propagate +the unusable strictness-info into the interfaces. + + +************************************************************************ +* * +\subsection{The worker wrapper core} +* * +************************************************************************ + +@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. +-} + +type WwResult + = ([Demand], -- Demands for worker (value) args + JoinArity, -- Number of worker (type OR value) args + Id -> CoreExpr, -- Wrapper body, lacking only the worker Id + CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs + +mkWwBodies :: DynFlags + -> FamInstEnvs + -> VarSet -- Free vars of RHS + -- See Note [Freshen WW arguments] + -> Id -- The original function + -> [Demand] -- Strictness of original function + -> CprResult -- Info about function result + -> UniqSM (Maybe WwResult) + +-- wrap_fn_args E = \x y -> E +-- work_fn_args E = E x y + +-- wrap_fn_str E = case x of { (a,b) -> +-- case a of { (a1,a2) -> +-- E a1 a2 b y }} +-- work_fn_str E = \a1 a2 b y -> +-- let a = (a1,a2) in +-- let x = (a,b) in +-- E + +mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info + = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) + -- See Note [Freshen WW arguments] + + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs empty_subst fun_ty demands + ; (useful1, work_args, wrap_fn_str, work_fn_str) + <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args + + -- Do CPR w/w. See Note [Always do CPR w/w] + ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) + <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info + + ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty + worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] + wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var + worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args + + ; if isWorkerSmallEnough dflags (length demands) work_args + && not (too_many_args_for_join_point wrap_args) + && ((useful1 && not only_one_void_argument) || useful2) + then return (Just (worker_args_dmds, length work_call_args, + wrapper_body, worker_body)) + else return Nothing + } + -- We use an INLINE unconditionally, even if the wrapper turns out to be + -- something trivial like + -- fw = ... + -- f = __inline__ (coerce T fw) + -- The point is to propagate the coerce to f's call sites, so even though + -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent + -- fw from being inlined into f's RHS + where + fun_ty = idType fun_id + mb_join_arity = isJoinId_maybe fun_id + has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id) + -- See Note [Do not unpack class dictionaries] + + -- Note [Do not split void functions] + only_one_void_argument + | [d] <- demands + , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty + , isAbsDmd d && isVoidTy arg_ty1 + = True + | otherwise + = False + + -- Note [Join points returning functions] + too_many_args_for_join_point wrap_args + | Just join_arity <- mb_join_arity + , wrap_args `lengthExceeds` join_arity + = WARN(True, text "Unable to worker/wrapper join point with arity " <+> + int join_arity <+> text "but" <+> + int (length wrap_args) <+> text "args") + True + | otherwise + = False + +-- See Note [Limit w/w arity] +isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool +isWorkerSmallEnough dflags old_n_args vars + = count isId vars <= max old_n_args (maxWorkerArgs dflags) + -- We count only Free variables (isId) to skip Type, Kind + -- variables which have no runtime representation. + -- Also if the function took 82 arguments before (old_n_args), it's fine if + -- it takes <= 82 arguments afterwards. + +{- +Note [Always do CPR w/w] +~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we refrained from doing CPR w/w for thunks, on the grounds that +we might duplicate work. But that is already handled by the demand analyser, +which doesn't give the CPR property if w/w might waste work: see +Note [CPR for thunks] in GHC.Core.Opt.DmdAnal. + +And if something *has* been given the CPR property and we don't w/w, it's +a disaster, because then the enclosing function might say it has the CPR +property, but now doesn't and there a cascade of disaster. A good example +is #5920. + +Note [Limit w/w arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Guard against high worker arity as it generates a lot of stack traffic. +A simplified example is #11565#comment:6 + +Current strategy is very simple: don't perform w/w transformation at all +if the result produces a wrapper with arity higher than -fmax-worker-args +and the number arguments before w/w (see #18122). + +It is a bit all or nothing, consider + + f (x,y) (a,b,c,d,e ... , z) = rhs + +Currently we will remove all w/w ness entirely. But actually we could +w/w on the (x,y) pair... it's the huge product that is the problem. + +Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd +solve f. But we can get a lot of args from deeply-nested products: + + g (a, (b, (c, (d, ...)))) = rhs + +This is harder to spot on an arg-by-arg basis. Previously mkWwStr was +given some "fuel" saying how many arguments it could add; when we ran +out of fuel it would stop w/wing. + +Still not very clever because it had a left-right bias. + +************************************************************************ +* * +\subsection{Making wrapper args} +* * +************************************************************************ + +During worker-wrapper stuff we may end up with an unlifted thing +which we want to let-bind without losing laziness. So we +add a void argument. E.g. + + f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z +==> + fw = /\ a -> \void -> E + f = /\ a -> \x y z -> fw realworld + +We use the state-token type which generates no code. +-} + +mkWorkerArgs :: DynFlags -> [Var] + -> Type -- Type of body + -> ([Var], -- Lambda bound args + [Var]) -- Args at call site +mkWorkerArgs dflags args res_ty + | any isId args || not needsAValueLambda + = (args, args) + | otherwise + = (args ++ [voidArgId], args ++ [voidPrimId]) + where + -- See "Making wrapper args" section above + needsAValueLambda = + lifted + -- We may encounter a levity-polymorphic result, in which case we + -- conservatively assume that we have laziness that needs preservation. + -- See #15186. + || not (gopt Opt_FunToThunk dflags) + -- see Note [Protecting the last value argument] + + -- Might the result be lifted? + lifted = + case isLiftedType_maybe res_ty of + Just lifted -> lifted + Nothing -> True + +{- +Note [Protecting the last value argument] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the user writes (\_ -> E), they might be intentionally disallowing +the sharing of E. Since absence analysis and worker-wrapper are keen +to remove such unused arguments, we add in a void argument to prevent +the function from becoming a thunk. + +The user can avoid adding the void argument with the -ffun-to-thunk +flag. However, this can create sharing, which may be bad in two ways. 1) It can +create a space leak. 2) It can prevent inlining *under a lambda*. If w/w +removes the last argument from a function f, then f now looks like a thunk, and +so f can't be inlined *under a lambda*. + +Note [Join points and beta-redexes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Originally, the worker would invoke the original function by calling it with +arguments, thus producing a beta-redex for the simplifier to munch away: + + \x y z -> e => (\x y z -> e) wx wy wz + +Now that we have special rules about join points, however, this is Not Good if +the original function is itself a join point, as then it may contain invocations +of other join points: + + join j1 x = ... + join j2 y = if y == 0 then 0 else j1 y + + => + + join j1 x = ... + join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy + join j2 y = case y of I# y# -> jump $wj2 y# + +There can't be an intervening lambda between a join point's declaration and its +occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: + + ... + let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y + ... + +Hence we simply do the beta-reduction here. (This would be harder if we had to +worry about hygiene, but luckily wy is freshly generated.) + +Note [Join points returning functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is crucial that the arity of a join point depends on its *callers,* not its +own syntax. What this means is that a join point can have "extra lambdas": + +f :: Int -> Int -> (Int, Int) -> Int +f x y = join j (z, w) = \(u, v) -> ... + in jump j (x, y) + +Typically this happens with functions that are seen as computing functions, +rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.) + +When we create the wrapper, it *must* be in "eta-contracted" form so that the +jump has the right number of arguments: + +f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... + j (z, w) = jump $wj z w + +(See Note [Join points and beta-redexes] for where the lets come from.) If j +were a function, we would instead say + +f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... + j (z, w) (u, v) = $wj z w u v + +Notice that the worker ends up with the same lambdas; it's only the wrapper we +have to be concerned about. + +FIXME Currently the functionality to produce "eta-contracted" wrappers is +unimplemented; we simply give up. + +************************************************************************ +* * +\subsection{Coercion stuff} +* * +************************************************************************ + +We really want to "look through" coerces. +Reason: I've seen this situation: + + let f = coerce T (\s -> E) + in \x -> case x of + p -> coerce T' f + q -> \s -> E2 + r -> coerce T' f + +If only we w/w'd f, we'd get + let f = coerce T (\s -> fw s) + fw = \s -> E + in ... + +Now we'll inline f to get + + let fw = \s -> E + in \x -> case x of + p -> fw + q -> \s -> E2 + r -> fw + +Now we'll see that fw has arity 1, and will arity expand +the \x to get what we want. +-} + +-- mkWWargs just does eta expansion +-- is driven off the function type and arity. +-- It chomps bites off foralls, arrows, newtypes +-- and keeps repeating that until it's satisfied the supplied arity + +mkWWargs :: TCvSubst -- Freshening substitution to apply to the type + -- See Note [Freshen WW arguments] + -> Type -- The type of the function + -> [Demand] -- Demands and one-shot info for value arguments + -> UniqSM ([Var], -- Wrapper args + CoreExpr -> CoreExpr, -- Wrapper fn + CoreExpr -> CoreExpr, -- Worker fn + Type) -- Type of wrapper body + +mkWWargs subst fun_ty demands + | null demands + = return ([], id, id, substTy subst fun_ty) + + | (dmd:demands') <- demands + , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty + = do { uniq <- getUniqueM + ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty) + id = mk_wrap_arg uniq arg_ty' dmd + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst fun_ty' demands' + ; return (id : wrap_args, + Lam id . wrap_fn_args, + apply_or_bind_then work_fn_args (varToCoreExpr id), + res_ty) } + + | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty + = do { uniq <- getUniqueM + ; let (subst', tv') = cloneTyVarBndr subst tv uniq + -- See Note [Freshen WW arguments] + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst' fun_ty' demands + ; return (tv' : wrap_args, + Lam tv' . wrap_fn_args, + apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')), + res_ty) } + + | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty + -- The newtype case is for when the function has + -- a newtype after the arrow (rare) + -- + -- It's also important when we have a function returning (say) a pair + -- wrapped in a newtype, at least if CPR analysis can look + -- through such newtypes, which it probably can since they are + -- simply coerces. + + = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst rep_ty demands + ; let co' = substCo subst co + ; return (wrap_args, + \e -> Cast (wrap_fn_args e) (mkSymCo co'), + \e -> work_fn_args (Cast e co'), + res_ty) } + + | otherwise + = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand + return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow + where + -- See Note [Join points and beta-redexes] + apply_or_bind_then k arg (Lam bndr body) + = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! + apply_or_bind_then k arg fun + = k $ mkCoreApp (text "mkWWargs") fun arg +applyToVars :: [Var] -> CoreExpr -> CoreExpr +applyToVars vars fn = mkVarApps fn vars + +mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id +mk_wrap_arg uniq (Scaled w ty) dmd + = mkSysLocalOrCoVar (fsLit "w") uniq w ty + `setIdDemandInfo` dmd + +{- Note [Freshen WW arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wen we do a worker/wrapper split, we must not in-scope names as the arguments +of the worker, else we'll get name capture. E.g. + + -- y1 is in scope from further out + f x = ..y1.. + +If we accidentally choose y1 as a worker argument disaster results: + + fww y1 y2 = let x = (y1,y2) in ...y1... + +To avoid this: + + * We use a fresh unique for both type-variable and term-variable binders + Originally we lacked this freshness for type variables, and that led + to the very obscure #12562. (A type variable in the worker shadowed + an outer term-variable binding.) + + * Because of this cloning we have to substitute in the type/kind of the + new binders. That's why we carry the TCvSubst through mkWWargs. + + So we need a decent in-scope set, just in case that type/kind + itself has foralls. We get this from the free vars of the RHS of the + function since those are the only variables that might be captured. + It's a lazy thunk, which will only be poked if the type/kind has a forall. + + Another tricky case was when f :: forall a. a -> forall a. a->a + (i.e. with shadowing), and then the worker used the same 'a' twice. + +************************************************************************ +* * +\subsection{Strictness stuff} +* * +************************************************************************ +-} + +mkWWstr :: DynFlags + -> FamInstEnvs + -> Bool -- True <=> INLINEABLE pragma on this function defn + -- See Note [Do not unpack class dictionaries] + -> [Var] -- Wrapper args; have their demand info on them + -- *Includes type variables* + -> UniqSM (Bool, -- Is this useful + [Var], -- Worker args + CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call + -- and without its lambdas + -- This fn adds the unboxing + + CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, + -- and lacking its lambdas. + -- This fn does the reboxing +mkWWstr dflags fam_envs has_inlineable_prag args + = go args + where + go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg + + go [] = return (False, [], nop_fn, nop_fn) + go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg + ; (useful2, args2, wrap_fn2, work_fn2) <- go args + ; return ( useful1 || useful2 + , args1 ++ args2 + , wrap_fn1 . wrap_fn2 + , work_fn1 . work_fn2) } + +{- +Note [Unpacking arguments with product and polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The argument is unpacked in a case if it has a product type and has a +strict *and* used demand put on it. I.e., arguments, with demands such +as the following ones: + + + + +will be unpacked, but + + or + +will not, because the pieces aren't used. This is quite important otherwise +we end up unpacking massive tuples passed to the bottoming function. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + +Does 'main' print "error 1" or "error no"? We don't really want 'f' +to unbox its second argument. This actually happened in GHC's onwn +source code, in Packages.applyPackageFlag, which ended up un-boxing +the enormous DynFlags tuple, and being strict in the +as-yet-un-filled-in unitState files. +-} + +---------------------- +-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) +-- * wrap_fn assumes wrap_arg is in scope, +-- brings into scope work_args (via cases) +-- * work_fn assumes work_args are in scope, a +-- brings into scope wrap_arg (via lets) +-- See Note [How to do the worker/wrapper split] +mkWWstr_one :: DynFlags -> FamInstEnvs + -> Bool -- True <=> INLINEABLE pragma on this function defn + -- See Note [Do not unpack class dictionaries] + -> Var + -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) +mkWWstr_one dflags fam_envs has_inlineable_prag arg + | isTyVar arg + = return (False, [arg], nop_fn, nop_fn) + + | isAbsDmd dmd + , Just work_fn <- mk_absent_let dflags fam_envs arg + -- Absent case. We can't always handle absence for arbitrary + -- unlifted types, so we need to choose just the cases we can + -- (that's what mk_absent_let does) + = return (True, [], nop_fn, work_fn) + + | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd + = unbox_one dflags fam_envs arg cs acdc + + | otherwise -- Other cases + = return (False, [arg], nop_fn, nop_fn) + + where + arg_ty = idType arg + dmd = idDemandInfo arg + +wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext) +wantToUnbox fam_envs has_inlineable_prag ty dmd = + case deepSplitProductType_maybe fam_envs ty of + Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys } + | isStrictDmd dmd + -- See Note [Unpacking arguments with product and polymorphic demands] + , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys) + -- See Note [Do not unpack class dictionaries] + , not (has_inlineable_prag && isClassPred ty) + -- See Note [mkWWstr and unsafeCoerce] + , cs `equalLength` con_arg_tys + -> Just (cs, dcac) + _ -> Nothing + where + split_prod_dmd_arity dmd arty + -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would + -- it know the arity?), but it should behave like , for some + -- suitable arity + | isSeqDmd dmd = Just (replicate arty absDmd) + -- Otherwise splitProdDmd_maybe does the job + | otherwise = splitProdDmd_maybe dmd + +unbox_one :: DynFlags -> FamInstEnvs -> Var + -> [Demand] + -> DataConAppContext + -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) +unbox_one dflags fam_envs arg cs + DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys + , dcac_arg_tys = inst_con_arg_tys + , dcac_co = co } + = do { (uniq1:uniqs) <- getUniquesM + ; let scale = scaleScaled (idMult arg) + scaled_inst_con_arg_tys = map (\(t,s) -> (scale t, s)) inst_con_arg_tys + -- See Note [Add demands for strict constructors] + cs' = addDataConStrictness data_con cs + unpk_args = zipWith3 mk_ww_arg uniqs scaled_inst_con_arg_tys cs' + unbox_fn = mkUnpackCase (Var arg) co (idMult arg) uniq1 + data_con unpk_args + arg_no_unf = zapStableUnfolding arg + -- See Note [Zap unfolding when beta-reducing] + -- in GHC.Core.Opt.Simplify; and see #13890 + rebox_fn = Let (NonRec arg_no_unf con_app) + con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co + ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args + ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } + -- Don't pass the arg, rebox instead + where + mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd + +---------------------- +nop_fn :: CoreExpr -> CoreExpr +nop_fn body = body + +addDataConStrictness :: DataCon -> [Demand] -> [Demand] +-- See Note [Add demands for strict constructors] +addDataConStrictness con ds + = zipWithEqual "addDataConStrictness" add ds strs + where + strs = dataConRepStrictness con + add dmd str | isMarkedStrict str = strictifyDmd dmd + | otherwise = dmd + +{- Note [How to do the worker/wrapper split] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The worker-wrapper transformation, mkWWstr_one, takes into account +several possibilities to decide if the function is worthy for +splitting: + +1. If an argument is absent, it would be silly to pass it to + the worker. Hence the isAbsDmd case. This case must come + first because a demand like or is possible. + E.g. comes from a function like + f x = error "urk" + and can come from Note [Add demands for strict constructors] + +2. If the argument is evaluated strictly, and we can split the + product demand (splitProdDmd_maybe), then unbox it and w/w its + pieces. For example + + f :: (Int, Int) -> Int + f p = (case p of (a,b) -> a) + 1 + is split to + f :: (Int, Int) -> Int + f p = case p of (a,b) -> $wf a + + $wf :: Int -> Int + $wf a = a + 1 + + and + g :: Bool -> (Int, Int) -> Int + g c p = case p of (a,b) -> + if c then a else b + is split to + g c p = case p of (a,b) -> $gw c a b + $gw c a b = if c then a else b + +2a But do /not/ split if the components are not used; that is, the + usage is just 'Used' rather than 'UProd'. In this case + splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing + a massive tuple which is barely used. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + + Here, f does not take 'pr' apart, and it's stupid to do so. + Imagine that it had millions of fields. This actually happened + in GHC itself where the tuple was DynFlags + +3. A plain 'seqDmd', which is head-strict with usage UHead, can't + be split by splitProdDmd_maybe. But we want it to behave just + like U(AAAA) for suitable number of absent demands. So we have + a special case for it, with arity coming from the data constructor. + +Note [Worker-wrapper for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to split if the result is bottom. +[Justification: there's no efficiency to be gained.] + +But it's sometimes bad not to make a wrapper. Consider + fw = \x# -> let x = I# x# in case e of + p1 -> error_fn x + p2 -> error_fn x + p3 -> the real stuff +The re-boxing code won't go away unless error_fn gets a wrapper too. +[We don't do reboxing now, but in general it's better to pass an +unboxed thing to f, and have it reboxed in the error cases....] + +Note [Add demands for strict constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program (due to Roman): + + data X a = X !a + + foo :: X Int -> Int -> Int + foo (X a) n = go 0 + where + go i | i < n = a + go (i+1) + | otherwise = 0 + +We want the worker for 'foo' too look like this: + + $wfoo :: Int# -> Int# -> Int# + +with the first argument unboxed, so that it is not eval'd each time +around the 'go' loop (which would otherwise happen, since 'foo' is not +strict in 'a'). It is sound for the wrapper to pass an unboxed arg +because X is strict, so its argument must be evaluated. And if we +*don't* pass an unboxed argument, we can't even repair it by adding a +`seq` thus: + + foo (X a) n = a `seq` go 0 + +because the seq is discarded (very early) since X is strict! + +So here's what we do + +* We leave the demand-analysis alone. The demand on 'a' in the + definition of 'foo' is ; the strictness info is Lazy + because foo's body may or may not evaluate 'a'; but the usage info + says that 'a' is unpacked and its content is used. + +* During worker/wrapper, if we unpack a strict constructor (as we do + for 'foo'), we use 'addDataConStrictness' to bump up the strictness on + the strict arguments of the data constructor. + +* That in turn means that, if the usage info supports doing so + (i.e. splitProdDmd_maybe returns Just), we will unpack that argument + -- even though the original demand (e.g. on 'a') was lazy. + +* What does "bump up the strictness" mean? Just add a head-strict + demand to the strictness! Even for a demand like we can + safely turn it into ; remember case (1) of + Note [How to do the worker/wrapper split]. + +The net effect is that the w/w transformation is more aggressive about +unpacking the strict arguments of a data constructor, when that +eagerness is supported by the usage info. + +There is the usual danger of reboxing, which as usual we ignore. But +if X is monomorphic, and has an UNPACK pragma, then this optimisation +is even more important. We don't want the wrapper to rebox an unboxed +argument, and pass an Int to $wfoo! + +This works in nested situations like + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = case f of BarPair x y -> + case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +The extra eagerness lets us produce a worker of type: + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated. + +--------- Historical note ------------ +We used to add data-con strictness demands when demand analysing case +expression. However, it was noticed in #15696 that this misses some cases. For +instance, consider the program (from T10482) + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = + case f of + BarPair x y -> case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +We really should be able to assume that `p` is already evaluated since it came +from a strict field of BarPair. This strictness would allow us to produce a +worker of type: + + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated + +Indeed before we fixed #15696 this would happen since we would float the inner +`case x` through the `case burble` to get: + + foo f k = + case f of + BarPair x y -> case x of + BarPair p q -> case burble of + True -> ... + False -> ... + +However, after fixing #15696 this could no longer happen (for the reasons +discussed in ticket:15696#comment:76). This means that the demand placed on `f` +would then be significantly weaker (since the False branch of the case on +`burble` is not strict in `p` or `q`). + +Consequently, we now instead account for data-con strictness in mkWWstr_one, +applying the strictness demands to the final result of DmdAnal. The result is +that we get the strict demand signature we wanted even if we can't float +the case on `x` up through the case on `burble`. + + +Note [mkWWstr and unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By using unsafeCoerce, it is possible to make the number of demands fail to +match the number of constructor arguments; this happened in #8037. +If so, the worker/wrapper split doesn't work right and we get a Core Lint +bug. The fix here is simply to decline to do w/w if that happens. + +Note [Record evaluated-ness in worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + data T = MkT !Int Int + + f :: T -> T + f x = e + +and f's is strict, and has the CPR property. The we are going to generate +this w/w split + + f x = case x of + MkT x1 x2 -> case $wf x1 x2 of + (# r1, r2 #) -> MkT r1 r2 + + $wfw x1 x2 = let x = MkT x1 x2 in + case e of + MkT r1 r2 -> (# r1, r2 #) + +Note that + +* In the worker $wf, inside 'e' we can be sure that x1 will be + evaluated (it came from unpacking the argument MkT. But that's no + immediately apparent in $wf + +* In the wrapper 'f', which we'll inline at call sites, we can be sure + that 'r1' has been evaluated (because it came from unpacking the result + MkT. But that is not immediately apparent from the wrapper code. + +Missing these facts isn't unsound, but it loses possible future +opportunities for optimisation. + +Solution: use setCaseBndrEvald when creating + (A) The arg binders x1,x2 in mkWstr_one + See #13077, test T13077 + (B) The result binders r1,r2 in mkWWcpr_help + See Trace #13077, test T13077a + And #13027 comment:20, item (4) +to record that the relevant binder is evaluated. + + +************************************************************************ +* * + Type scrutiny that is specific to demand analysis +* * +************************************************************************ + +Note [Do not unpack class dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + f :: Ord a => [a] -> Int -> a + {-# INLINABLE f #-} +and we worker/wrapper f, we'll get a worker with an INLINABLE pragma +(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), +which can still be specialised by the type-class specialiser, something like + fw :: Ord a => [a] -> Int# -> a + +BUT if f is strict in the Ord dictionary, we might unpack it, to get + fw :: (a->a->Bool) -> [a] -> Int# -> a +and the type-class specialiser can't specialise that. An example is +#6056. + +But in any other situation a dictionary is just an ordinary value, +and can be unpacked. So we track the INLINABLE pragma, and switch +off the unpacking in mkWWstr_one (see the isClassPred test). + +Historical note: #14955 describes how I got this fix wrong +the first time. +-} + +-- | Context for a 'DataCon' application with a hole for every field, including +-- surrounding coercions. +-- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'. +-- +-- Example: +-- +-- > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int) +-- +-- represents +-- +-- > Just @Int (_1 :: Int) |> co :: First Int +-- +-- where _1 is a hole for the first argument. The number of arguments is +-- determined by the length of @arg_tys@. +data DataConAppContext + = DataConAppContext + { dcac_dc :: !DataCon + , dcac_tys :: ![Type] + , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)] + , dcac_co :: !Coercion + } + +deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext +-- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) +-- then dc @ tys (args::arg_tys) :: rep_ty +-- co :: ty ~ rep_ty +-- Why do we return the strictness of the data-con arguments? +-- Answer: see Note [Record evaluated-ness in worker/wrapper] +deepSplitProductType_maybe fam_envs ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkRepReflCo ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , Just con <- isDataProductTyCon_maybe tc + , let arg_tys = dataConInstArgTys con tc_args + strict_marks = dataConRepStrictness con + = Just DataConAppContext { dcac_dc = con + , dcac_tys = tc_args + , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks + , dcac_co = co } +deepSplitProductType_maybe _ _ = Nothing + +deepSplitCprType_maybe + :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext +-- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co) +-- then dc @ tys (args::arg_tys) :: rep_ty +-- co :: ty ~ rep_ty +-- Why do we return the strictness of the data-con arguments? +-- Answer: see Note [Record evaluated-ness in worker/wrapper] +deepSplitCprType_maybe fam_envs con_tag ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkRepReflCo ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , isDataTyCon tc + , let cons = tyConDataCons tc + , cons `lengthAtLeast` con_tag -- This might not be true if we import the + -- type constructor via a .hs-bool file (#8743) + , let con = cons `getNth` (con_tag - fIRST_TAG) + arg_tys = dataConInstArgTys con tc_args + strict_marks = dataConRepStrictness con + , all isLinear arg_tys + -- Deactivates CPR worker/wrapper splits on constructors with non-linear + -- arguments, for the moment, because they require unboxed tuple with variable + -- multiplicity fields. + = Just DataConAppContext { dcac_dc = con + , dcac_tys = tc_args + , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks + , dcac_co = co } +deepSplitCprType_maybe _ _ _ = Nothing + +isLinear :: Scaled a -> Bool +isLinear (Scaled w _ ) = + case w of + One -> True + _ -> False + +findTypeShape :: FamInstEnvs -> Type -> TypeShape +-- Uncover the arrow and product shape of a type +-- The data type TypeShape is defined in GHC.Types.Demand +-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal +findTypeShape fam_envs ty + = go (setRecTcMaxBound 2 initRecTc) ty + -- You might think this bound of 2 is low, but actually + -- I think even 1 would be fine. This only bites for recursive + -- product types, which are rare, and we really don't want + -- to look deep into such products -- see #18034 + where + go rec_tc ty + | Just (_, _, res) <- splitFunTy_maybe ty + = TsFun (go rec_tc res) + + | Just (tc, tc_args) <- splitTyConApp_maybe ty + = go_tc rec_tc tc tc_args + + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_tc ty' + + | otherwise + = TsUnk + + go_tc rec_tc tc tc_args + | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args + = go rec_tc rhs + + | Just con <- isDataProductTyCon_maybe tc + , Just rec_tc <- if isTupleTyCon tc + then Just rec_tc + else checkRecTc rec_tc tc + -- We treat tuples specially because they can't cause loops. + -- Maybe we should do so in checkRecTc. + = TsProd (map (go rec_tc . scaledThing) (dataConInstArgTys con tc_args)) + + | Just (ty', _) <- instNewTyCon_maybe tc tc_args + , Just rec_tc <- checkRecTc rec_tc tc + = go rec_tc ty' + + | otherwise + = TsUnk + +{- +************************************************************************ +* * +\subsection{CPR stuff} +* * +************************************************************************ + + +@mkWWcpr@ takes the worker/wrapper pair produced from the strictness +info and adds in the CPR transformation. The worker returns an +unboxed tuple containing non-CPR components. The wrapper takes this +tuple and re-produces the correct structured output. + +The non-CPR results appear ordered in the unboxed tuple as if by a +left-to-right traversal of the result structure. +-} + +mkWWcpr :: Bool + -> FamInstEnvs + -> Type -- function body type + -> CprResult -- CPR analysis results + -> UniqSM (Bool, -- Is w/w'ing useful? + CoreExpr -> CoreExpr, -- New wrapper + CoreExpr -> CoreExpr, -- New worker + Type) -- Type of worker's body + +mkWWcpr opt_CprAnal fam_envs body_ty cpr + -- CPR explicitly turned off (or in -O0) + | not opt_CprAnal = return (False, id, id, body_ty) + -- CPR is turned on by default for -O and O2 + | otherwise + = case asConCpr cpr of + Nothing -> return (False, id, id, body_ty) -- No CPR info + Just con_tag | Just dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty + -> mkWWcpr_help dcac + | otherwise + -- See Note [non-algebraic or open body type warning] + -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) + return (False, id, id, body_ty) + +mkWWcpr_help :: DataConAppContext + -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) + +mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys + , dcac_arg_tys = arg_tys, dcac_co = co }) + | [arg1@(arg_ty1, _)] <- arg_tys + , isUnliftedType (scaledThing arg_ty1) + , isLinear arg_ty1 + -- Special case when there is a single result of unlifted, linear, type + -- + -- Wrapper: case (..call worker..) of x -> C x + -- Worker: case ( ..body.. ) of C x -> x + = do { (work_uniq : arg_uniq : _) <- getUniquesM + ; let arg = mk_ww_local arg_uniq arg1 + con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co + + ; return ( True + , \ wkr_call -> mkDefaultCase wkr_call arg con_app + , \ body -> mkUnpackCase body co One work_uniq data_con [arg] (varToCoreExpr arg) + -- varToCoreExpr important here: arg can be a coercion + -- Lacking this caused #10658 + , scaledThing arg_ty1 ) } + + | otherwise -- The general case + -- Wrapper: case (..call worker..) of (# a, b #) -> C a b + -- Worker: case ( ...body... ) of C a b -> (# a, b #) + -- + -- Remark on linearity: in both the case of the wrapper and the worker, + -- we build a linear case. All the multiplicity information is kept in + -- the constructors (both C and (#, #)). In particular (#,#) is + -- parametrised by the multiplicity of its fields. Specifically, in this + -- instance, the multiplicity of the fields of (#,#) is chosen to be the + -- same as those of C. + = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM + ; let wrap_wild = mk_ww_local wild_uniq (linear ubx_tup_ty,MarkedStrict) + args = zipWith mk_ww_local uniqs arg_tys + ubx_tup_ty = exprType ubx_tup_app + ubx_tup_app = mkCoreUbxTup (map (scaledThing . fst) arg_tys) (map varToCoreExpr args) + con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co + tup_con = tupleDataCon Unboxed (length arg_tys) + + ; return (True + , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild + (DataAlt tup_con) args con_app + , \ body -> mkUnpackCase body co One work_uniq data_con args ubx_tup_app + , ubx_tup_ty ) } + +mkUnpackCase :: CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr +-- (mkUnpackCase e co uniq Con args body) +-- returns +-- case e |> co of bndr { Con args -> body } + +mkUnpackCase (Tick tickish e) co mult uniq con args body -- See Note [Profiling and unpacking] + = Tick tickish (mkUnpackCase e co mult uniq con args body) +mkUnpackCase scrut co mult uniq boxing_con unpk_args body + = mkSingleAltCase casted_scrut bndr + (DataAlt boxing_con) unpk_args body + where + casted_scrut = scrut `mkCast` co + bndr = mk_ww_local uniq (Scaled mult (exprType casted_scrut), MarkedStrict) + -- An unpacking case can always be chosen linear, because the variables + -- are always passed to a constructor. This limits the +{- +Note [non-algebraic or open body type warning] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a few cases where the W/W transformation is told that something +returns a constructor, but the type at hand doesn't really match this. One +real-world example involves unsafeCoerce: + foo = IO a + foo = unsafeCoerce c_exit + foreign import ccall "c_exit" c_exit :: IO () +Here CPR will tell you that `foo` returns a () constructor for sure, but trying +to create a worker/wrapper for type `a` obviously fails. +(This was a real example until ee8e792 in libraries/base.) + +It does not seem feasible to avoid all such cases already in the analyser (and +after all, the analysis is not really wrong), so we simply do nothing here in +mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch +other cases where something went avoidably wrong. + +This warning also triggers for the stream fusion library within `text`. +We can'easily W/W constructed results like `Stream` because we have no simple +way to express existential types in the worker's type signature. + +Note [Profiling and unpacking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the original function looked like + f = \ x -> {-# SCC "foo" #-} E + +then we want the CPR'd worker to look like + \ x -> {-# SCC "foo" #-} (case E of I# x -> x) +and definitely not + \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) + +This transform doesn't move work or allocation +from one cost centre to another. + +Later [SDM]: presumably this is because we want the simplifier to +eliminate the case, and the scc would get in the way? I'm ok with +including the case itself in the cost centre, since it is morally +part of the function (post transformation) anyway. + + +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ + +Note [Absent errors] +~~~~~~~~~~~~~~~~~~~~ +We make a new binding for Ids that are marked absent, thus + let x = absentError "x :: Int" +The idea is that this binding will never be used; but if it +buggily is used we'll get a runtime error message. + +Coping with absence for *unlifted* types is important; see, for +example, #4306 and #15627. In the UnliftedRep case, we can +use LitRubbish, which we need to apply to the required type. +For the unlifted types of singleton kind like Float#, Addr#, etc. we +also find a suitable literal, using Literal.absentLiteralOf. We don't +have literals for every primitive type, so the function is partial. + +Note: I did try the experiment of using an error thunk for unlifted +things too, relying on the simplifier to drop it as dead code. +But this is fragile + + - It fails when profiling is on, which disables various optimisations + + - It fails when reboxing happens. E.g. + data T = MkT Int Int# + f p@(MkT a _) = ...g p.... + where g is /lazy/ in 'p', but only uses the first component. Then + 'f' is /strict/ in 'p', and only uses the first component. So we only + pass that component to the worker for 'f', which reconstructs 'p' to + pass it to 'g'. Alas we can't say + ...f (MkT a (absentError Int# "blah"))... + bacause `MkT` is strict in its Int# argument, so we get an absentError + exception when we shouldn't. Very annoying! + +So absentError is only used for lifted types. +-} + +-- | Tries to find a suitable dummy RHS to bind the given absent identifier to. +-- +-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding +-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be +-- found (currently only happens for bindings of 'VecRep' representation). +mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let dflags fam_envs arg + -- The lifted case: Bind 'absentError' + -- See Note [Absent errors] + | not (isUnliftedType arg_ty) + = Just (Let (NonRec lifted_arg abs_rhs)) + -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@ + -- See Note [Absent errors] + | [UnliftedRep] <- typePrimRep arg_ty + = Just (Let (NonRec arg unlifted_rhs)) + -- The monomorphic unlifted cases: Bind to some literal, if possible + -- See Note [Absent errors] + | Just tc <- tyConAppTyCon_maybe nty + , Just lit <- absentLiteralOf tc + = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co))) + | nty `eqType` voidPrimTy + = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co))) + | otherwise + = WARN( True, text "No absent value for" <+> ppr arg_ty ) + Nothing -- Can happen for 'State#' and things of 'VecRep' + where + lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr + -- Note in strictness signature that this is bottoming + -- (for the sake of the "empty case scrutinee not known to + -- diverge for sure lint" warning) + arg_ty = idType arg + + -- Normalise the type to have best chance of finding an absent literal + -- e.g. (#17852) data unlifted N = MkN Int# + -- f :: N -> a -> a + -- f _ x = x + (co, nty) = topNormaliseType_maybe fam_envs arg_ty + `orElse` (mkRepReflCo arg_ty, arg_ty) + + abs_rhs = mkAbsentErrorApp arg_ty msg + msg = showSDoc (gopt_set dflags Opt_SuppressUniques) + (ppr arg <+> ppr (idType arg) <+> file_msg) + file_msg = case outputFile dflags of + Nothing -> empty + Just f -> text "in output file " <+> quotes (text f) + -- We need to suppress uniques here because otherwise they'd + -- end up in the generated code as strings. This is bad for + -- determinism, because with different uniques the strings + -- will have different lengths and hence different costs for + -- the inliner leading to different inlining. + -- See also Note [Unique Determinism] in GHC.Types.Unique + unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] + +mk_ww_local :: Unique -> (Scaled Type, StrictnessMark) -> Id +-- The StrictnessMark comes form the data constructor and says +-- whether this field is strict +-- See Note [Record evaluated-ness in worker/wrapper] +mk_ww_local uniq (Scaled w ty,str) + = setCaseBndrEvald str $ + mkSysLocalOrCoVar (fsLit "ww") uniq w ty diff --git a/GHC/Core/PatSyn.hs b/GHC/Core/PatSyn.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/PatSyn.hs @@ -0,0 +1,489 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[PatSyn]{@PatSyn@: Pattern synonyms} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.PatSyn ( + -- * Main data types + PatSyn, mkPatSyn, + + -- ** Type deconstruction + patSynName, patSynArity, patSynIsInfix, + patSynArgs, + patSynMatcher, patSynBuilder, + patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, + patSynSig, patSynSigBndr, + patSynInstArgTys, patSynInstResTy, patSynFieldLabels, + patSynFieldType, + + updatePatSynIds, pprPatSynType + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Core.TyCo.Ppr +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Types.Basic +import GHC.Types.Var +import GHC.Types.FieldLabel + +import qualified Data.Data as Data +import Data.Function +import Data.List (find) + +{- +************************************************************************ +* * +\subsection{Pattern synonyms} +* * +************************************************************************ +-} + +-- | Pattern Synonym +-- +-- See Note [Pattern synonym representation] +-- See Note [Pattern synonym signature contexts] +data PatSyn + = MkPatSyn { + psName :: Name, + psUnique :: Unique, -- Cached from Name + + psArgs :: [Type], + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + psFieldLabels :: [FieldLabel], -- List of fields for a + -- record pattern synonym + -- INVARIANT: either empty if no + -- record pat syn or same length as + -- psArgs + + -- Universally-quantified type variables + psUnivTyVars :: [InvisTVBinder], + + -- Required dictionaries (may mention psUnivTyVars) + psReqTheta :: ThetaType, + + -- Existentially-quantified type vars + psExTyVars :: [InvisTVBinder], + + -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) + psProvTheta :: ThetaType, + + -- Result type + psResultTy :: Type, -- Mentions only psUnivTyVars + -- See Note [Pattern synonym result type] + + -- See Note [Matchers and builders for pattern synonyms] + psMatcher :: (Id, Bool), + -- Matcher function. + -- If Bool is True then prov_theta and arg_tys are empty + -- and type is + -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. Void# -> r) + -- -> (Void# -> r) + -- -> r + -- + -- Otherwise type is + -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta => arg_tys -> r) + -- -> (Void# -> r) + -- -> r + + psBuilder :: Maybe (Id, Bool) + -- Nothing => uni-directional pattern synonym + -- Just (builder, is_unlifted) => bi-directional + -- Builder function, of type + -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) + -- => arg_tys -> res_ty + -- See Note [Builder for pattern synonyms with unboxed type] + } + +{- Note [Pattern synonym signature contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a pattern synonym signature we write + pattern P :: req => prov => t1 -> ... tn -> res_ty + +Note that the "required" context comes first, then the "provided" +context. Moreover, the "required" context must not mention +existentially-bound type variables; that is, ones not mentioned in +res_ty. See lots of discussion in #10928. + +If there is no "provided" context, you can omit it; but you +can't omit the "required" part (unless you omit both). + +Example 1: + pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) + pattern P1 x = Just (3,x) + + We require (Num a, Eq a) to match the 3; there is no provided + context. + +Example 2: + data T2 where + MkT2 :: (Num a, Eq a) => a -> a -> T2 + + pattern P2 :: () => (Num a, Eq a) => a -> T2 + pattern P2 x = MkT2 3 x + + When we match against P2 we get a Num dictionary provided. + We can use that to check the match against 3. + +Example 3: + pattern P3 :: Eq a => a -> b -> T3 b + + This signature is illegal because the (Eq a) is a required + constraint, but it mentions the existentially-bound variable 'a'. + You can see it's existential because it doesn't appear in the + result type (T3 b). + +Note [Pattern synonym result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b = MkT b a + + pattern P :: a -> T [a] Bool + pattern P x = MkT True [x] + +P's psResultTy is (T a Bool), and it really only matches values of +type (T [a] Bool). For example, this is ill-typed + + f :: T p q -> String + f (P x) = "urk" + +This is different to the situation with GADTs: + + data S a where + MkS :: Int -> S Bool + +Now MkS (and pattern synonyms coming from MkS) can match a +value of type (S a), not just (S Bool); we get type refinement. + +That in turn means that if you have a pattern + + P x :: T [ty] Bool + +it's not entirely straightforward to work out the instantiation of +P's universal tyvars. You have to /match/ + the type of the pattern, (T [ty] Bool) +against + the psResultTy for the pattern synonym, T [a] Bool +to get the instantiation a := ty. + +This is very unlike DataCons, where univ tyvars match 1-1 the +arguments of the TyCon. + +Side note: I (SG) get the impression that instantiated return types should +generate a *required* constraint for pattern synonyms, rather than a *provided* +constraint like it's the case for GADTs. For example, I'd expect these +declarations to have identical semantics: + + pattern Just42 :: Maybe Int + pattern Just42 = Just 42 + + pattern Just'42 :: (a ~ Int) => Maybe a + pattern Just'42 = Just 42 + +The latter generates the proper required constraint, the former does not. +Also rather different to GADTs is the fact that Just42 doesn't have any +universally quantified type variables, whereas Just'42 or MkS above has. + +Note [Pattern synonym representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym declaration + + pattern P x = MkT [x] (Just 42) + +where + data T a where + MkT :: (Show a, Ord b) => [b] -> a -> T a + +so pattern P has type + + b -> T (Maybe t) + +with the following typeclass constraints: + + requires: (Eq t, Num t) + provides: (Show (Maybe t), Ord b) + +In this case, the fields of MkPatSyn will be set as follows: + + psArgs = [b] + psArity = 1 + psInfix = False + + psUnivTyVars = [t] + psExTyVars = [b] + psProvTheta = (Show (Maybe t), Ord b) + psReqTheta = (Eq t, Num t) + psResultTy = T (Maybe t) + +Note [Matchers and builders for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each pattern synonym P, we generate + + * a "matcher" function, used to desugar uses of P in patterns, + which implements pattern matching + + * A "builder" function (for bidirectional pattern synonyms only), + used to desugar uses of P in expressions, which constructs P-values. + +For the above example, the matcher function has type: + + $mP :: forall (r :: ?) t. (Eq t, Num t) + => T (Maybe t) + -> (forall b. (Show (Maybe t), Ord b) => b -> r) + -> (Void# -> r) + -> r + +with the following implementation: + + $mP @r @t $dEq $dNum scrut cont fail + = case scrut of + MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x + _ -> fail Void# + +Notice that the return type 'r' has an open kind, so that it can +be instantiated by an unboxed type; for example where we see + f (P x) = 3# + +The extra Void# argument for the failure continuation is needed so that +it is lazy even when the result type is unboxed. + +For the same reason, if the pattern has no arguments, an extra Void# +argument is added to the success continuation as well. + +For *bidirectional* pattern synonyms, we also generate a "builder" +function which implements the pattern synonym in an expression +context. For our running example, it will be: + + $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) + => b -> T (Maybe t) + $bP x = MkT [x] (Just 42) + +NB: the existential/universal and required/provided split does not +apply to the builder since you are only putting stuff in, not getting +stuff out. + +Injectivity of bidirectional pattern synonyms is checked in +tcPatToExpr which walks the pattern and returns its corresponding +expression when available. + +Note [Builder for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For bidirectional pattern synonyms that have no arguments and have an +unboxed type, we add an extra Void# argument to the builder, else it +would be a top-level declaration with an unboxed type. + + pattern P = 0# + + $bP :: Void# -> Int# + $bP _ = 0# + +This means that when typechecking an occurrence of P in an expression, +we must remember that the builder has this void argument. This is +done by GHC.Tc.TyCl.PatSyn.patSynBuilderOcc. + +Note [Pattern synonyms and the data type Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type of a pattern synonym is of the form (See Note +[Pattern synonym signatures] in GHC.Tc.Gen.Sig): + + forall univ_tvs. req => forall ex_tvs. prov => ... + +We cannot in general represent this by a value of type Type: + + - if ex_tvs is empty, then req and prov cannot be distinguished from + each other + - if req is empty, then univ_tvs and ex_tvs cannot be distinguished + from each other, and moreover, prov is seen as the "required" context + (as it is the only context) + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq PatSyn where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Uniquable PatSyn where + getUnique = psUnique + +instance NamedThing PatSyn where + getName = patSynName + +instance Outputable PatSyn where + ppr = ppr . getName + +instance OutputableBndr PatSyn where + pprInfixOcc = pprInfixName . getName + pprPrefixOcc = pprPrefixName . getName + +instance Data.Data PatSyn where + -- don't traverse? + toConstr _ = abstractConstr "PatSyn" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PatSyn" + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +-- | Build a new pattern synonym +mkPatSyn :: Name + -> Bool -- ^ Is the pattern synonym declared infix? + -> ([InvisTVBinder], ThetaType) -- ^ Universially-quantified type + -- variables and required dicts + -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts + -> [Type] -- ^ Original arguments + -> Type -- ^ Original result type + -> (Id, Bool) -- ^ Name of matcher + -> Maybe (Id, Bool) -- ^ Name of builder + -> [FieldLabel] -- ^ Names of fields for + -- a record pattern synonym + -> PatSyn + -- NB: The univ and ex vars are both in TyBinder form and TyVar form for + -- convenience. All the TyBinders should be Named! +mkPatSyn name declared_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + orig_args + orig_res_ty + matcher builder field_labels + = MkPatSyn {psName = name, psUnique = getUnique name, + psUnivTyVars = univ_tvs, + psExTyVars = ex_tvs, + psProvTheta = prov_theta, psReqTheta = req_theta, + psInfix = declared_infix, + psArgs = orig_args, + psArity = length orig_args, + psResultTy = orig_res_ty, + psMatcher = matcher, + psBuilder = builder, + psFieldLabels = field_labels + } + +-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification +patSynName :: PatSyn -> Name +patSynName = psName + +-- | Should the 'PatSyn' be presented infix? +patSynIsInfix :: PatSyn -> Bool +patSynIsInfix = psInfix + +-- | Arity of the pattern synonym +patSynArity :: PatSyn -> Arity +patSynArity = psArity + +patSynArgs :: PatSyn -> [Type] +patSynArgs = psArgs + +patSynFieldLabels :: PatSyn -> [FieldLabel] +patSynFieldLabels = psFieldLabels + +-- | Extract the type for any given labelled field of the 'DataCon' +patSynFieldType :: PatSyn -> FieldLabelString -> Type +patSynFieldType ps label + = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) + +patSynUnivTyVarBinders :: PatSyn -> [InvisTVBinder] +patSynUnivTyVarBinders = psUnivTyVars + +patSynExTyVars :: PatSyn -> [TyVar] +patSynExTyVars ps = binderVars (psExTyVars ps) + +patSynExTyVarBinders :: PatSyn -> [InvisTVBinder] +patSynExTyVarBinders = psExTyVars + +patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) +patSynSigBndr (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psResultTy = res_ty }) + = (univ_tvs, req, ex_tvs, prov, map unrestricted arg_tys, res_ty) + +patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Scaled Type], Type) +patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps + in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty) + +patSynMatcher :: PatSyn -> (Id,Bool) +patSynMatcher = psMatcher + +patSynBuilder :: PatSyn -> Maybe (Id, Bool) +patSynBuilder = psBuilder + +updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn +updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) + = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } + where + tidy_pr (id, dummy) = (tidy_fn id, dummy) + +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +-- Return the types of the argument patterns +-- e.g. data D a = forall b. MkD a b (b->a) +-- pattern P f x y = MkD (x,True) y f +-- D :: forall a. forall b. a -> b -> (b->a) -> D a +-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c +-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] +-- NB: the inst_tys should be both universal and existential +patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psExTyVars = ex_tvs, psArgs = arg_tys }) + inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = binderVars (univ_tvs ++ ex_tvs) + +patSynInstResTy :: PatSyn -> [Type] -> Type +-- Return the type of whole pattern +-- E.g. pattern P x y = Just (x,x,y) +-- P :: a -> b -> Just (a,a,b) +-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) +-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars +patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psResultTy = res_ty }) + inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) + substTyWith (binderVars univ_tvs) inst_tys res_ty + +-- | Print the type of a pattern synonym. The foralls are printed explicitly +pprPatSynType :: PatSyn -> SDoc +pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta + , psExTyVars = ex_tvs, psProvTheta = prov_theta + , psArgs = orig_args, psResultTy = orig_res_ty }) + = sep [ pprForAll $ tyVarSpecToBinders univ_tvs + , pprThetaArrowTy req_theta + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , pprType sigma_ty ] + where + sigma_ty = mkInvisForAllTys ex_tvs $ + mkInvisFunTysMany prov_theta $ + mkVisFunTysMany orig_args orig_res_ty + insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/GHC/Core/PatSyn.hs-boot b/GHC/Core/PatSyn.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/PatSyn.hs-boot @@ -0,0 +1,13 @@ +module GHC.Core.PatSyn where + +import GHC.Types.Basic (Arity) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type) +import GHC.Types.Var (TyVar) +import GHC.Types.Name (Name) + +data PatSyn + +patSynArity :: PatSyn -> Arity +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +patSynExTyVars :: PatSyn -> [TyVar] +patSynName :: PatSyn -> Name diff --git a/GHC/Core/Ppr.hs b/GHC/Core/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Ppr.hs @@ -0,0 +1,661 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +Printing of Core syntax +-} + +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Core.Ppr ( + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprCoreBindingWithSize, pprCoreBindingsWithSize, + pprRules, pprOptCo + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Stats (exprStats) +import GHC.Types.Literal( pprLiteral ) +import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr +import GHC.Core.Coercion +import GHC.Types.Basic +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.SrcLoc ( pprUserRealSpan ) + +{- +************************************************************************ +* * +\subsection{Public interfaces for Core printing (excluding instances)} +* * +************************************************************************ + +@pprParendCoreExpr@ puts parens around non-atomic Core expressions. +-} + +pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc +pprCoreBinding :: OutputableBndr b => Bind b -> SDoc +pprCoreExpr :: OutputableBndr b => Expr b -> SDoc +pprParendExpr :: OutputableBndr b => Expr b -> SDoc + +pprCoreBindings = pprTopBinds noAnn +pprCoreBinding = pprTopBind noAnn + +pprCoreBindingsWithSize :: [CoreBind] -> SDoc +pprCoreBindingWithSize :: CoreBind -> SDoc + +pprCoreBindingsWithSize = pprTopBinds sizeAnn +pprCoreBindingWithSize = pprTopBind sizeAnn + +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind noAnn bind + +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr + +{- +************************************************************************ +* * +\subsection{The guts} +* * +************************************************************************ +-} + +-- | A function to produce an annotation for a given right-hand-side +type Annotation b = Expr b -> SDoc + +-- | Annotate with the size of the right-hand-side +sizeAnn :: CoreExpr -> SDoc +sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) + +-- | No annotation +noAnn :: Expr b -> SDoc +noAnn _ = empty + +pprTopBinds :: OutputableBndr a + => Annotation a -- ^ generate an annotation to place before the + -- binding + -> [Bind a] -- ^ bindings to show + -> SDoc -- ^ the pretty result +pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) + +pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc +pprTopBind ann (NonRec binder expr) + = ppr_binding ann (binder,expr) $$ blankLine + +pprTopBind _ (Rec []) + = text "Rec { }" +pprTopBind ann (Rec (b:bs)) + = vcat [text "Rec {", + ppr_binding ann b, + vcat [blankLine $$ ppr_binding ann b | b <- bs], + text "end Rec }", + blankLine] + +ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc + +ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) +ppr_bind ann (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding ann bind <> semi + +ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc +ppr_binding ann (val_bdr, expr) + = vcat [ ann expr + , ppUnlessOption sdocSuppressTypeSignatures + (pprBndr LetBind val_bdr) + , pp_bind + ] + where + pp_val_bdr = pprPrefixOcc val_bdr + + pp_bind = case bndrIsJoin_maybe val_bdr of + Nothing -> pp_normal_bind + Just ar -> pp_join_bind ar + + pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr) + + -- For a join point of join arity n, we want to print j = \x1 ... xn -> e + -- as "j x1 ... xn = e" to differentiate when a join point returns a + -- lambda (the first rendering looks like a nullary join point returning + -- an n-argument function). + pp_join_bind join_arity + | bndrs `lengthAtLeast` join_arity + = hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs)) + 2 (equals <+> pprCoreExpr rhs) + | otherwise -- Yikes! A join-binding with too few lambda + -- Lint will complain, but we don't want to crash + -- the pretty-printer else we can't see what's wrong + -- So refer to printing j = e + = pp_normal_bind + where + (bndrs, body) = collectBinders expr + lhs_bndrs = take join_arity bndrs + rhs = mkLams (drop join_arity bndrs) body + +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprOptCo :: Coercion -> SDoc +-- Print a coercion optionally; i.e. honouring -dsuppress-coercions +pprOptCo co = sdocOption sdocSuppressCoercions $ \case + True -> angleBrackets (text "Co:" <> int (coercionSize co)) + False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)] + +ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +ppr_expr add_par (Var name) + | isJoinId name = add_par ((text "jump") <+> pp_name) + | otherwise = pp_name + where + pp_name = pprPrefixOcc name +ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) +ppr_expr add_par (Lit lit) = pprLiteral add_par lit + +ppr_expr add_par (Cast expr co) + = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] + +ppr_expr add_par expr@(Lam _ _) + = let + (bndrs, body) = collectBinders expr + in + add_par $ + hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (pprCoreExpr body) + +ppr_expr add_par expr@(App {}) + = sdocOption sdocSuppressTypeApplications $ \supp_ty_app -> + case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map pprArg args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = pprWithCommas pprCoreExpr val_args + args' + | supp_ty_app = val_args + | otherwise = args + parens + | null args' = id + | otherwise = add_par + in + case fun of + Var f -> case isDataConWorkId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated + , Just sort <- tyConTuple_maybe tc + -> tupleParens sort pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + _ -> parens (hang fun_doc 2 pp_args) + where + fun_doc | isJoinId f = text "jump" <+> ppr f + | otherwise = ppr f + + _ -> parens (hang (pprParendExpr fun) 2 pp_args) + } + +ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + = sdocOption sdocPrintCaseAsLet $ \case + True -> add_par $ -- See Note [Print case as let] + sep [ sep [ text "let! {" + <+> ppr_case_pat con args + <+> text "~" + <+> ppr_bndr var + , text "<-" <+> ppr_expr id expr + <+> text "} in" ] + , pprCoreExpr rhs + ] + False -> add_par $ + sep [sep [sep [ text "case" <+> pprCoreExpr expr + , whenPprDebug (text "return" <+> ppr ty) + , text "of" <+> ppr_bndr var + ] + , char '{' <+> ppr_case_pat con args <+> arrow + ] + , pprCoreExpr rhs + , char '}' + ] + where + ppr_bndr = pprBndr CaseBind + +ppr_expr add_par (Case expr var ty alts) + = add_par $ + sep [sep [text "case" + <+> pprCoreExpr expr + <+> whenPprDebug (text "return" <+> ppr ty), + text "of" <+> ppr_bndr var <+> char '{'], + nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), + char '}' + ] + where + ppr_bndr = pprBndr CaseBind + + +-- special cases: let ... in let ... +-- ("disgusting" SLPJ) + +{- +ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ + hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + nest 2 (pprCoreExpr rhs), + text "} in", + pprCoreExpr body ] + +ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (text "let {") + 2 (hsep [ppr_binding (val_bdr,rhs), + text "} in"]) + $$ + pprCoreExpr expr) +-} + + +-- General case (recursive case, too) +ppr_expr add_par (Let bind expr) + = add_par $ + sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), + pprCoreExpr expr] + where + keyword (NonRec b _) + | isJust (bndrIsJoin_maybe b) = text "join" + | otherwise = text "let" + keyword (Rec pairs) + | ((b,_):_) <- pairs + , isJust (bndrIsJoin_maybe b) = text "joinrec" + | otherwise = text "letrec" + +ppr_expr add_par (Tick tickish expr) + = sdocOption sdocSuppressTicks $ \case + True -> ppr_expr add_par expr + False -> add_par (sep [ppr tickish, pprCoreExpr expr]) + +pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc +pprCoreAlt (con, args, rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) + +ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc +ppr_case_pat (DataAlt dc) args + | Just sort <- tyConTuple_maybe tc + = tupleParens sort (pprWithCommas ppr_bndr args) + where + ppr_bndr = pprBndr CasePatBind + tc = dataConTyCon dc + +ppr_case_pat con args + = ppr con <+> (fsep (map ppr_bndr args)) + where + ppr_bndr = pprBndr CasePatBind + + +-- | Pretty print the argument in a function application. +pprArg :: OutputableBndr a => Expr a -> SDoc +pprArg (Type ty) + = ppUnlessOption sdocSuppressTypeApplications + (text "@" <> pprParendType ty) +pprArg (Coercion co) = text "@~" <> pprOptCo co +pprArg expr = pprParendExpr expr + +{- +Note [Print case as let] +~~~~~~~~~~~~~~~~~~~~~~~~ +Single-branch case expressions are very common: + case x of y { I# x' -> + case p of q { I# p' -> ... } } +These are, in effect, just strict let's, with pattern matching. +With -dppr-case-as-let we print them as such: + let! { I# x' ~ y <- x } in + let! { I# p' ~ q <- p } in ... + + +Other printing bits-and-bobs used with the general @pprCoreBinding@ +and @pprCoreExpr@ functions. + + +Note [Binding-site specific printing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust +the information printed. + +Let-bound binders are printed with their full type and idInfo. + +Case-bound variables (both the case binder and pattern variables) are printed +without a type and without their unfolding. + +Furthermore, a dead case-binder is completely ignored, while otherwise, dead +binders are printed as "_". +-} + +-- These instances are sadly orphans + +instance OutputableBndr Var where + pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName + bndrIsJoin_maybe = isJoinId_maybe + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b + bndrIsJoin_maybe (TB b _) = isJoinId_maybe b + +pprCoreBinder :: BindingSite -> Var -> SDoc +pprCoreBinder LetBind binder + | isTyVar binder = pprKindedTyVarBndr binder + | otherwise = pprTypedLetBinder binder $$ + ppIdInfo binder (idInfo binder) + +-- Lambda bound type variables are preceded by "@" +pprCoreBinder bind_site bndr + = getPprDebug $ \debug -> + pprTypedLamBinder bind_site debug bndr + +pprUntypedBinder :: Var -> SDoc +pprUntypedBinder binder + | isTyVar binder = text "@" <> ppr binder -- NB: don't print kind + | otherwise = pprIdBndr binder + +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc +-- For lambda and case binders, show the unfolding info (usually none) +pprTypedLamBinder bind_site debug_on var + = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> + case () of + _ + | not debug_on -- Show case-bound wild binders only if debug is on + , CaseBind <- bind_site + , isDeadBinder var -> empty + + | not debug_on -- Even dead binders can be one-shot + , isDeadBinder var -> char '_' <+> ppWhen (isId var) + (pprIdBndrInfo (idInfo var)) + + | not debug_on -- No parens, no kind info + , CaseBind <- bind_site -> pprUntypedBinder var + + | not debug_on + , CasePatBind <- bind_site -> pprUntypedBinder var + + | suppress_sigs -> pprUntypedBinder var + + | isTyVar var -> parens (pprKindedTyVarBndr var) + + | otherwise -> parens (hang (pprIdBndr var) + 2 (vcat [ dcolon <+> pprType (idType var) + , pp_unf])) + where + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info + | otherwise = empty + +pprTypedLetBinder :: Var -> SDoc +-- Print binder with a type or kind signature (not paren'd) +pprTypedLetBinder binder + = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> + case () of + _ + | isTyVar binder -> pprKindedTyVarBndr binder + | suppress_sigs -> pprIdBndr binder + | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + +pprKindedTyVarBndr :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +pprKindedTyVarBndr tyvar + = text "@" <> pprTyVar tyvar + +-- pprIdBndr does *not* print the type +-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness +pprIdBndr :: Id -> SDoc +pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id) + +pprIdBndrInfo :: IdInfo -> SDoc +pprIdBndrInfo info + = ppUnlessOption sdocSuppressIdInfo + (info `seq` doc) -- The seq is useful for poking on black holes + where + prag_info = inlinePragInfo info + occ_info = occInfo info + dmd_info = demandInfo info + lbv_info = oneShotInfo info + + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isNoOccInfo occ_info) + has_dmd = not $ isTopDmd dmd_info + has_lbv = not (hasNoOneShotInfo lbv_info) + + doc = showAttributes + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) + ] + +instance Outputable IdInfo where + ppr info = showAttributes + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (has_rules, text "RULES:" <+> vcat (map pprRule rules)) + ] + where + prag_info = inlinePragInfo info + has_prag = not (isDefaultInlinePragma prag_info) + + occ_info = occInfo info + has_occ = not (isManyOccs occ_info) + + dmd_info = demandInfo info + has_dmd = not $ isTopDmd dmd_info + + lbv_info = oneShotInfo info + has_lbv = not (hasNoOneShotInfo lbv_info) + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + has_str_info = not (isTopSig str_info) + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = ruleInfoRules (ruleInfo info) + has_rules = not (null rules) + +{- +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- +-} + +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = ppUnlessOption sdocSuppressIdInfo $ + showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_cpr_info, text "Cpr=" <> ppr cpr_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, one-shot info + -- printed out with all binders (when debug is on); + -- see GHC.Core.Ppr.pprIdBndr + where + pp_scope | isGlobalId id = text "GblId" + | isExportedId id = text "LclIdX" + | otherwise = text "LclId" + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + has_str_info = not (isTopSig str_info) + + cpr_info = cprInfo info + has_cpr_info = cpr_info /= topCprSig + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = ruleInfoRules (ruleInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] + +{- +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- +-} + +instance Outputable UnfoldingGuidance where + ppr UnfNever = text "NEVER" + ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) + = text "ALWAYS_IF" <> + parens (text "arity=" <> int arity <> comma <> + text "unsat_ok=" <> ppr unsat_ok <> comma <> + text "boring_ok=" <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ text "IF_ARGS", + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable UnfoldingSource where + ppr InlineCompulsory = text "Compulsory" + ppr InlineStable = text "InlineStable" + ppr InlineRhs = text "" + +instance Outputable Unfolding where + ppr NoUnfolding = text "No unfolding" + ppr BootUnfolding = text "No unfolding (from boot)" + ppr (OtherCon cs) = text "OtherCon" <+> ppr cs + ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = hang (text "DFun:" <+> ptext (sLit "\\") + <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (ppr con <+> sep (map ppr args)) + ppr (CoreUnfolding { uf_src = src + , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf + , uf_is_conlike=conlike, uf_is_work_free=wf + , uf_expandable=exp, uf_guidance=g }) + = text "Unf" <> braces (pp_info $$ pp_rhs) + where + pp_info = fsep $ punctuate comma + [ text "Src=" <> ppr src + , text "TopLvl=" <> ppr top + , text "Value=" <> ppr hnf + , text "ConLike=" <> ppr conlike + , text "WorkFree=" <> ppr wf + , text "Expandable=" <> ppr exp + , text "Guidance=" <> ppr g ] + pp_tmpl = ppUnlessOption sdocSuppressUnfoldings + (text "Tmpl=" <+> ppr rhs) + pp_rhs | isStableSource src = pp_tmpl + | otherwise = empty + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! + +{- +----------------------------------------------------- +-- Rules +----------------------------------------------------- +-} + +instance Outputable CoreRule where + ppr = pprRule + +pprRules :: [CoreRule] -> SDoc +pprRules rules = vcat (map pprRule rules) + +pprRule :: CoreRule -> SDoc +pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) + = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) + +pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) + = hang (doubleQuotes (ftext name) <+> ppr act) + 4 (sep [text "forall" <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (text "=" <+> pprCoreExpr rhs) + ]) + +{- +----------------------------------------------------- +-- Tickish +----------------------------------------------------- +-} + +instance Outputable id => Outputable (Tickish id) where + ppr (HpcTick modl ix) = + hcat [text "hpc<", + ppr modl, comma, + ppr ix, + text ">"] + ppr (Breakpoint ix vars) = + hcat [text "break<", + ppr ix, + text ">", + parens (hcat (punctuate comma (map ppr vars)))] + ppr (ProfNote { profNoteCC = cc, + profNoteCount = tick, + profNoteScope = scope }) = + case (tick,scope) of + (True,True) -> hcat [text "scctick<", ppr cc, char '>'] + (True,False) -> hcat [text "tick<", ppr cc, char '>'] + _ -> hcat [text "scc<", ppr cc, char '>'] + ppr (SourceNote span _) = + hcat [ text "src<", pprUserRealSpan True span, char '>'] diff --git a/GHC/Core/Ppr/TyThing.hs b/GHC/Core/Ppr/TyThing.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Ppr/TyThing.hs @@ -0,0 +1,205 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing TyThings +-- +-- (c) The GHC Team 2005 +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +module GHC.Core.Ppr.TyThing ( + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, + pprTypeForUser, + pprFamInst + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) +import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) + , showToHeader, pprIfaceDecl ) +import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) +import GHC.Driver.Types( tyThingParent_maybe ) +import GHC.Iface.Make ( tyThingToIfaceDecl ) +import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) +import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType ) +import GHC.Types.Name +import GHC.Types.Var.Env( emptyTidyEnv ) +import GHC.Utils.Outputable + +-- ----------------------------------------------------------------------------- +-- Pretty-printing entities that we get from the GHC API + +{- Note [Pretty printing via Iface syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our general plan for pretty-printing + - Types + - TyCons + - Classes + - Pattern synonyms + ...etc... + +is to convert them to Iface syntax, and pretty-print that. For example + - pprType converts a Type to an IfaceType, and pretty prints that. + - pprTyThing converts the TyThing to an IfaceDecl, + and pretty prints that. + +So Iface syntax plays a dual role: + - it's the internal version of an interface files + - it's used for pretty-printing + +Why do this? + +* A significant reason is that we need to be able + to pretty-print Iface syntax (to display Foo.hi), and it was a + pain to duplicate masses of pretty-printing goop, esp for + Type and IfaceType. + +* When pretty-printing (a type, say), we want to tidy (with + tidyType) to avoids having (forall a a. blah) where the two + a's have different uniques. + + Alas, for type constructors, TyCon, tidying does not work well, + because a TyCon includes DataCons which include Types, which mention + TyCons. And tidying can't tidy a mutually recursive data structure + graph, only trees. + +* Interface files contains fast-strings, not uniques, so the very same + tidying must take place when we convert to IfaceDecl. E.g. + GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon, + Class etc) to an IfaceDecl. + + Bottom line: IfaceDecls are already 'tidy', so it's straightforward + to print them. + +* An alternative I once explored was to ensure that TyCons get type + variables with distinct print-names. That's ok for type variables + but less easy for kind variables. Processing data type declarations + is already so complicated that I don't think it's sensible to add + the extra requirement that it generates only "pretty" types and + kinds. + +Consequences: + +- Iface syntax (and IfaceType) must contain enough information to + print nicely. Hence, for example, the IfaceAppArgs type, which + allows us to suppress invisible kind arguments in types + (see Note [Suppressing invisible arguments] in GHC.Iface.Type) + +- In a few places we have info that is used only for pretty-printing, + and is totally ignored when turning Iface syntax back into Core + (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon + stores a [IfaceAxBranch] that is used only for pretty-printing. + +- See Note [Free tyvars in IfaceType] in GHC.Iface.Type + +See #7730, #8776 for details -} + +-------------------- +-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. +pprFamInst :: FamInst -> SDoc +-- * For data instances we go via pprTyThing of the representational TyCon, +-- because there is already much cleverness associated with printing +-- data type declarations that I don't want to duplicate +-- * For type instances we print directly here; there is no TyCon +-- to give to pprTyThing +-- +-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes + +pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) + +pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt (getName axiom)) $ + hang (text "type instance" + <+> pprUserForAll (mkTyVarBinders Specified tvs) + -- See Note [Printing foralls in type family instances] + -- in GHC.Iface.Type + <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) + +---------------------------- +-- | Pretty-prints a 'TyThing' with its defining location. +pprTyThingLoc :: TyThing -> SDoc +pprTyThingLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThing showToHeader tyThing) + +-- | Pretty-prints the 'TyThing' header. For functions and data constructors +-- the function is equivalent to 'pprTyThing' but for type constructors +-- and classes it prints only the header part of the declaration. +pprTyThingHdr :: TyThing -> SDoc +pprTyThingHdr = pprTyThing showToHeader + +-- | Pretty-prints a 'TyThing' in context: that is, if the entity +-- is a data constructor, record selector, or class method, then +-- the entity's parent declaration is pretty-printed with irrelevant +-- parts omitted. +pprTyThingInContext :: ShowSub -> TyThing -> SDoc +pprTyThingInContext show_sub thing + = go [] thing + where + go ss thing + = case tyThingParent_maybe thing of + Just parent -> + go (getOccName thing : ss) parent + Nothing -> + pprTyThing + (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) }) + thing + +-- | Like 'pprTyThingInContext', but adds the defining location. +pprTyThingInContextLoc :: TyThing -> SDoc +pprTyThingInContextLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThingInContext showToHeader tyThing) + +-- | Pretty-prints a 'TyThing'. +pprTyThing :: ShowSub -> TyThing -> SDoc +-- We pretty-print 'TyThing' via 'IfaceDecl' +-- See Note [Pretty-printing TyThings] +pprTyThing ss ty_thing + = sdocWithDynFlags (\dflags -> pprIfaceDecl ss' (tyThingToIfaceDecl dflags ty_thing)) + where + ss' = case ss_how_much ss of + ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } + ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' } + _ -> ss + + ppr' = AltPpr $ ppr_bndr $ getName ty_thing + + ppr_bndr :: Name -> Maybe (OccName -> SDoc) + ppr_bndr name + | isBuiltInSyntax name + = Nothing + | otherwise + = case nameModule_maybe name of + Just mod -> Just $ \occ -> getPprStyle $ \sty -> + pprModulePrefix sty mod occ <> ppr occ + Nothing -> WARN( True, ppr name ) Nothing + -- Nothing is unexpected here; TyThings have External names + +pprTypeForUser :: Type -> SDoc +-- The type is tidied +pprTypeForUser ty + = pprSigmaType tidy_ty + where + (_, tidy_ty) = tidyOpenType emptyTidyEnv ty + -- Often the types/kinds we print in ghci are fully generalised + -- and have no free variables, but it turns out that we sometimes + -- print un-generalised kinds (eg when doing :k T), so it's + -- better to use tidyOpenType here + +showWithLoc :: SDoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> comment <+> loc) + -- The tab tries to make them line up a bit + where + comment = text "--" diff --git a/GHC/Core/Predicate.hs b/GHC/Core/Predicate.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Predicate.hs @@ -0,0 +1,326 @@ +{- + +Describes predicates as they are considered by the solver. + +-} + +module GHC.Core.Predicate ( + Pred(..), classifyPredType, + isPredTy, isEvVarType, + + -- Equality predicates + EqRel(..), eqRelRole, + isEqPrimPred, isEqPred, + getEqPredTys, getEqPredTys_maybe, getEqPredRole, + predTypeEqRel, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + + -- Class predicates + mkClassPred, isDictTy, + isClassPred, isEqPredClass, isCTupleClass, + getClassPredTys, getClassPredTys_maybe, + classMethodTy, classMethodInstTy, + + -- Implicit parameters + isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass, + + -- Evidence variables + DictId, isEvVar, isDictId + ) where + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Types.Var +import GHC.Core.Coercion + +import GHC.Builtin.Names + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Core.Multiplicity ( scaledThing ) + + +-- | A predicate in the solver. The solver tries to prove Wanted predicates +-- from Given ones. +data Pred + = ClassPred Class [Type] + | EqPred EqRel Type Type + | IrredPred PredType + | ForAllPred [TyVar] [PredType] PredType + -- ForAllPred: see Note [Quantified constraints] in GHC.Tc.Solver.Canonical + -- NB: There is no TuplePred case + -- Tuple predicates like (Eq a, Ord b) are just treated + -- as ClassPred, as if we had a tuple class with two superclasses + -- class (c1, c2) => (%,%) c1 c2 + +classifyPredType :: PredType -> Pred +classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 + | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 + + Just (tc, tys) + | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys + + _ | (tvs, rho) <- splitForAllTys ev_ty + , (theta, pred) <- splitFunTys rho + , not (null tvs && null theta) + -> ForAllPred tvs (map scaledThing theta) pred + + | otherwise + -> IrredPred ev_ty + +-- --------------------- Dictionary types --------------------------------- + +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = mkTyConApp (classTyCon clas) tys + +isDictTy :: Type -> Bool +isDictTy = isClassPred + +getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) +getClassPredTys ty = case getClassPredTys_maybe ty of + Just (clas, tys) -> (clas, tys) + Nothing -> pprPanic "getClassPredTys" (ppr ty) + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe ty = case splitTyConApp_maybe ty of + Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) + _ -> Nothing + +classMethodTy :: Id -> Type +-- Takes a class selector op :: forall a. C a => meth_ty +-- and returns the type of its method, meth_ty +-- The selector can be a superclass selector, in which case +-- you get back a superclass +classMethodTy sel_id + = funResultTy $ -- meth_ty + dropForAlls $ -- C a => meth_ty + varType sel_id -- forall a. C n => meth_ty + +classMethodInstTy :: Id -> [Type] -> Type +-- Takes a class selector op :: forall a b. C a b => meth_ty +-- and the types [ty1, ty2] at which it is instantiated, +-- returns the instantiated type of its method, meth_ty[t1/a,t2/b] +-- The selector can be a superclass selector, in which case +-- you get back a superclass +classMethodInstTy sel_id arg_tys + = funResultTy $ + piResultTys (varType sel_id) arg_tys + +-- --------------------- Equality predicates --------------------------------- + +-- | A choice of equality relation. This is separate from the type 'Role' +-- because 'Phantom' does not define a (non-trivial) equality relation. +data EqRel = NomEq | ReprEq + deriving (Eq, Ord) + +instance Outputable EqRel where + ppr NomEq = text "nominal equality" + ppr ReprEq = text "representational equality" + +eqRelRole :: EqRel -> Role +eqRelRole NomEq = Nominal +eqRelRole ReprEq = Representational + +getEqPredTys :: PredType -> (Type, Type) +getEqPredTys ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey + || tc `hasKey` eqReprPrimTyConKey + -> (ty1, ty2) + _ -> pprPanic "getEqPredTys" (ppr ty) + +getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) +getEqPredTys_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) + | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) + _ -> Nothing + +getEqPredRole :: PredType -> Role +getEqPredRole ty = eqRelRole (predTypeEqRel ty) + +-- | Get the equality relation relevant for a pred type. +predTypeEqRel :: PredType -> EqRel +predTypeEqRel ty + | Just (tc, _) <- splitTyConApp_maybe ty + , tc `hasKey` eqReprPrimTyConKey + = ReprEq + | otherwise + = NomEq + +{------------------------------------------- +Predicates on PredType +--------------------------------------------} + +{- +Note [Evidence for quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass mechanism in GHC.Tc.Solver.Canonical.makeSuperClasses risks +taking a quantified constraint like + (forall a. C a => a ~ b) +and generate superclass evidence + (forall a. C a => a ~# b) + +This is a funny thing: neither isPredTy nor isCoVarType are true +of it. So we are careful not to generate it in the first place: +see Note [Equality superclasses in quantified constraints] +in GHC.Tc.Solver.Canonical. +-} + +isEvVarType :: Type -> Bool +-- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b) +-- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +-- See Note [Evidence for quantified constraints] +isEvVarType ty = isCoVarType ty || isPredTy ty + +isEqPredClass :: Class -> Bool +-- True of (~) and (~~) +isEqPredClass cls = cls `hasKey` eqTyConKey + || cls `hasKey` heqTyConKey + +isClassPred, isEqPred, isEqPrimPred :: PredType -> Bool +isClassPred ty = case tyConAppTyCon_maybe ty of + Just tyCon | isClassTyCon tyCon -> True + _ -> False + +isEqPred ty -- True of (a ~ b) and (a ~~ b) + -- ToDo: should we check saturation? + | Just tc <- tyConAppTyCon_maybe ty + , Just cls <- tyConClass_maybe tc + = isEqPredClass cls + | otherwise + = False + +isEqPrimPred ty = isCoVarType ty + -- True of (a ~# b) (a ~R# b) + +isCTupleClass :: Class -> Bool +isCTupleClass cls = isTupleTyCon (classTyCon cls) + + +{- ********************************************************************* +* * + Implicit parameters +* * +********************************************************************* -} + +isIPTyCon :: TyCon -> Bool +isIPTyCon tc = tc `hasKey` ipClassKey + -- Class and its corresponding TyCon have the same Unique + +isIPClass :: Class -> Bool +isIPClass cls = cls `hasKey` ipClassKey + +isIPLikePred :: Type -> Bool +-- See Note [Local implicit parameters] +isIPLikePred = is_ip_like_pred initIPRecTc + + +is_ip_like_pred :: RecTcChecker -> Type -> Bool +is_ip_like_pred rec_clss ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , Just rec_clss' <- if isTupleTyCon tc -- Tuples never cause recursion + then Just rec_clss + else checkRecTc rec_clss tc + , Just cls <- tyConClass_maybe tc + = isIPClass cls || has_ip_super_classes rec_clss' cls tys + + | otherwise + = False -- Includes things like (D []) where D is + -- a Constraint-ranged family; #7785 + +hasIPSuperClasses :: Class -> [Type] -> Bool +-- See Note [Local implicit parameters] +hasIPSuperClasses = has_ip_super_classes initIPRecTc + +has_ip_super_classes :: RecTcChecker -> Class -> [Type] -> Bool +has_ip_super_classes rec_clss cls tys + = any ip_ish (classSCSelIds cls) + where + -- Check that the type of a superclass determines its value + -- sc_sel_id :: forall a b. C a b -> + ip_ish sc_sel_id = is_ip_like_pred rec_clss $ + classMethodInstTy sc_sel_id tys + +initIPRecTc :: RecTcChecker +initIPRecTc = setRecTcMaxBound 1 initRecTc + +{- Note [Local implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function isIPLikePred tells if this predicate, or any of its +superclasses, is an implicit parameter. + +Why are implicit parameters special? Unlike normal classes, we can +have local instances for implicit parameters, in the form of + let ?x = True in ... +So in various places we must be careful not to assume that any value +of the right type will do; we must carefully look for the innermost binding. +So isIPLikePred checks whether this is an implicit parameter, or has +a superclass that is an implicit parameter. + +Several wrinkles + +* We must be careful with superclasses, as #18649 showed. Haskell + doesn't allow an implicit parameter as a superclass + class (?x::a) => C a where ... + but with a constraint tuple we might have + (% Eq a, ?x::Int %) + and /its/ superclasses, namely (Eq a) and (?x::Int), /do/ include an + implicit parameter. + + With ConstraintKinds this can apply to /any/ class, e.g. + class sc => C sc where ... + Then (C (?x::Int)) has (?x::Int) as a superclass. So we must + instantiate and check each superclass, one by one, in + hasIPSuperClasses. + +* With -XRecursiveSuperClasses, the superclass hunt can go on forever, + so we need a RecTcChecker to cut it off. + +* Another apparent additional complexity involves type families. For + example, consider + type family D (v::*->*) :: Constraint + type instance D [] = () + f :: D v => v Char -> Int + If we see a call (f "foo"), we'll pass a "dictionary" + () |> (g :: () ~ D []) + and it's good to specialise f at this dictionary. + +So the question is: can an implicit parameter "hide inside" a +type-family constraint like (D a). Well, no. We don't allow + type instance D Maybe = ?x:Int +Hence the umbrella 'otherwise' case in is_ip_like_pred. See #7785. + +Small worries (Sept 20): +* I don't see what stops us having that 'type instance'. Indeed I + think nothing does. +* I'm a little concerned about type variables; such a variable might + be instantiated to an implicit parameter. I don't think this + matters in the cases for which isIPLikePred is used, and it's pretty + obscure anyway. +* The superclass hunt stops when it encounters the same class again, + but in principle we could have the same class, differently instantiated, + and the second time it could have an implicit parameter +I'm going to treat these as problems for another day. They are all exotic. -} + +{- ********************************************************************* +* * + Evidence variables +* * +********************************************************************* -} + +isEvVar :: Var -> Bool +isEvVar var = isEvVarType (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (varType id) diff --git a/GHC/Core/Rules.hs b/GHC/Core/Rules.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Rules.hs @@ -0,0 +1,1274 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[CoreRules]{Rewrite rules} +-} + +{-# LANGUAGE CPP #-} + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. +module GHC.Core.Rules ( + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'RuleInfo' rules + extendRuleInfo, addRuleInfo, + addIdSpecialisations, + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + + lookupRule, mkRule, roughTopNames, initRuleOpts + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core -- All of it +import GHC.Unit.Module ( Module ) +import GHC.Unit.Module.Env +import GHC.Core.Subst +import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) +import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars + , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) +import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks + , stripTicksTopT, stripTicksTopE + , isJoinBind ) +import GHC.Core.Ppr ( pprRules ) +import GHC.Core.Type as Type + ( Type, TCvSubst, extendTvSubst, extendCvSubst + , mkEmptyTCvSubst, substTy ) +import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) +import GHC.Builtin.Types ( anyTypeOfKind ) +import GHC.Core.Coercion as Coercion +import GHC.Core.Tidy ( tidyRules ) +import GHC.Types.Id +import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Unique.FM +import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) +import GHC.Types.Basic +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform ) +import GHC.Driver.Flags +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Utils.Misc as Utils +import Data.List +import Data.Ord +import Control.Monad ( guard ) + +{- +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* After the desugarer: + - The ModGuts initially contains mg_rules :: [CoreRule] of + locally-declared rules for imported Ids. + - Locally-declared rules for locally-declared Ids are attached to + the IdInfo for that Id. See Note [Attach rules to local ids] in + GHC.HsToCore.Binds + +* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to + mg_rules, so that the ModGuts has *all* the locally-declared rules. + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combing rules from all the modules + "below" us. That's why we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + packages, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop, we combine (b-d) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the GHC.Core.Opt.Monad, and + (d) from its mutable variable + [Of course this means that we won't see new EPS rules that come in + during a single simplifier iteration, but that probably does not + matter.] + + +************************************************************************ +* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +* * +************************************************************************ + +A @CoreRule@ holds details of one rule for an @Id@, which +includes its specialisations. + +For example, if a rule for @f@ contains the mapping: +\begin{verbatim} + forall a b d. [Type (List a), Type b, Var d] ===> f' a b +\end{verbatim} +then when we find an application of f to matching types, we simply replace +it by the matching RHS: +\begin{verbatim} + f (List Int) Bool dict ===> f' Int Bool +\end{verbatim} +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +Rule contains a template for the result of the specialisation. + +There is one more exciting case, which is dealt with in exactly the same +way. If the specialised value is unboxed then it is lifted at its +definition site and unlifted at its uses. For example: + + pi :: forall a. Num a => a + +might have a specialisation + + [Int#] ===> (case pi' of Lift pi# -> pi#) + +where pi' :: Lift Int# is the specialised version of pi. +-} + +mkRule :: Module -> Bool -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'GHC.Core.CoreRule' +mkRule this_mod is_auto is_local name act fn bndrs args rhs + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, + ru_rough = roughTopNames args, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = is_auto, ru_local = is_local } + where + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = extendNameSet (exprsOrphNames args) fn + + -- Since rules get eventually attached to one of the free names + -- from the definition when compiling the ABI hash, we should make + -- it deterministic. This chooses the one with minimal OccName + -- as opposed to uniq value. + local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names + orph = chooseOrphanAnchor local_lhs_names + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing +roughTopName (App f _) = roughTopName f +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] + , isDataConWorkId f || idArity f > 0 + = Just (idName f) +roughTopName (Tick t e) | tickishFloatable t + = roughTopName e +roughTopName _ = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = False + +{- +Note [Care with roughTopName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + module M where { x = a:b } + module N where { ...f x... + RULE f (p:q) = ... } +You'd expect the rule to match, because the matcher can +look through the unfolding of 'x'. So we must avoid roughTopName +returning 'M.x' for the call (f x), or else it'll say "can't match" +and we won't even try!! + +However, suppose we have + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... +where k is a *function* exported by M. We never really match +functions (lambdas) except by name, so in this case it seems like +a good idea to treat 'M.k' as a roughTopName of the call. +-} + +pprRulesForUser :: [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in GHC.Core.Ppr because it calls tidyRules +pprRulesForUser rules + = withPprStyle defaultUserStyle $ + pprRules $ + sortBy (comparing ruleName) $ + tidyRules emptyTidyEnv rules + +{- +************************************************************************ +* * + RuleInfo: the rules in an IdInfo +* * +************************************************************************ +-} + +extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo +extendRuleInfo (RuleInfo rs1 fvs1) rs2 + = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) + +addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo +addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) + = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + | null rules + = id + | otherwise + = setIdSpecialisation id $ + extendRuleInfo (idSpecialisation id) rules + +-- | Gather all the rules for locally bound identifiers from the supplied bindings +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +getRules :: RuleEnv -> Id -> [CoreRule] +-- See Note [Where rules are found] +getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn + = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules + where + imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] + +ruleIsVisible :: ModuleSet -> CoreRule -> Bool +ruleIsVisible _ BuiltinRule{} = True +ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } + = notOrphan orph || origin `elemModuleSet` vis_orphs + +{- Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id itself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + + +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- RuleBase itself is defined in GHC.Core, along with CoreRule + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +unionRuleBase :: RuleBase -> RuleBase -> RuleBase +unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ +-} + +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. +lookupRule :: RuleOpts -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in rule matching] +-- See comments on matchRule +lookupRule opts in_scope is_active fn args rules + = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ + case go [] rules of + [] -> Nothing + (m:ms) -> Just (findBest (fn,args') m ms) + where + rough_args = map roughTopName args + + -- Strip ticks from arguments, see note [Tick annotations in RULE + -- matching]. We only collect ticks if a rule actually matches - + -- this matters for performance tests. + args' = map (stripTicksTopE tickishFloatable) args + ticks = concatMap (stripTicksTopT tickishFloatable) args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) + | Just e <- matchRule opts in_scope is_active fn args' rough_args r + = go ((r,mkTicks ticks e):ms) rs + | otherwise + = -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, unfoldingTemplate unf) + -- | Var arg_id <- args + -- , let unf = idUnfolding arg_id + -- , isCheapUnfolding unf] ) + go ms rs + +findBest :: (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest _ (rule,ans) [] = (rule,ans) +findBest target (rule1,ans1) ((rule2,ans2):prs) + | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs + | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) + , text "Rule 1:" <+> pp_rule rule1 + , text "Rule 2:" <+> pp_rule rule2]) $ + findBest target (rule1,ans1) prs + | otherwise = findBest target (rule1,ans1) prs + where + (fn,args) = target + +isMoreSpecific :: CoreRule -> CoreRule -> Bool +-- This tests if one rule is more specific than another +-- We take the view that a BuiltinRule is less specific than +-- anything else, because we want user-define rules to "win" +-- In particular, class ops have a built-in rule, but we +-- any user-specific rules to win +-- eg (#4397) +-- truncate :: (RealFrac a, Integral b) => a -> b +-- {-# RULES "truncate/Double->Int" truncate = double2Int #-} +-- double2Int :: Double -> Int +-- We want the specific RULE to beat the built-in class-op rule +isMoreSpecific (BuiltinRule {}) _ = False +isMoreSpecific (Rule {}) (BuiltinRule {}) = True +isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2 + , ru_name = rule_name2, ru_rhs = rhs }) + = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs) + where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates + in_scope = mkInScopeSet (mkVarSet bndrs1) + -- Actually we should probably include the free vars + -- of rule1's args, but I can't be bothered + +noBlackList :: Activation -> Bool +noBlackList _ = False -- Nothing is black listed + +{- +Note [Extra args in rule matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +but the rule firing has only consumed as many of the input args +as the ruleArity says. It's up to the caller to keep track +of any left-over args. E.g. if you call + lookupRule ... f [e1, e2, e3] +and it returns Just (r, rhs), where r has ruleArity 2 +then the real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution +-} + +------------------------------------ +matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr + +-- If (matchRule rule args) returns Just (name,rhs) +-- then (f args) matches the rule, and the corresponding +-- rewritten RHS is rhs +-- +-- The returned expression is occurrence-analysed +-- +-- Example +-- +-- The rule +-- forall f g x. map f (map g x) ==> map (f . g) x +-- is stored +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- +-- Then the call: matchRule the_rule [e1,map e2 e3] +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- +-- Any 'surplus' arguments in the input are simply put on the end +-- of the output. + +matchRule opts rule_env _is_active fn args _rough_args + (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems + = case match_fn opts rule_env fn args of + Nothing -> Nothing + Just expr -> Just expr + +matchRule _ in_scope is_active _ args rough_args + (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing + | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs + + +-- | Initialize RuleOpts from DynFlags +initRuleOpts :: DynFlags -> RuleOpts +initRuleOpts dflags = RuleOpts + { roPlatform = targetPlatform dflags + , roNumConstantFolding = gopt Opt_NumConstantFolding dflags + , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags + } + + +--------------------------------------- +matchN :: InScopeEnv + -> RuleName -> [Var] -> [CoreExpr] + -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template + -> Maybe CoreExpr +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- Fail if there are two few actual arguments from the target to match the template + +matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs + = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es + ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) + (mkEmptyTCvSubst in_scope) $ + tmpl_vars `zip` tmpl_vars1 + bind_wrapper = rs_binds rule_subst + -- Floated bindings; see Note [Matching lets] + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + where + (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars + -- See Note [Cloning the template binders] + + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 + , rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } + + go _ subst [] _ = Just subst + go _ _ _ [] = Nothing -- Fail if too few actual args + go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e + ; go menv subst1 ts es } + + lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) + -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) + tcv_subst (tmpl_var, tmpl_var1) + | isId tmpl_var1 + = case lookupVarEnv id_subst tmpl_var1 of + Just e | Coercion co <- e + -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> (tcv_subst, e) + Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 + , let co = Coercion.substCo tcv_subst refl_co + -> -- See Note [Unbound RULE binders] + (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> unbound tmpl_var + + | otherwise + = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') + where + ty' = case lookupVarEnv tv_subst tmpl_var1 of + Just ty -> ty + Nothing -> fake_ty -- See Note [Unbound RULE binders] + fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) + -- This substitution is the sole reason we accumulate + -- TCvSubst in lookup_tmpl + + unbound tmpl_var + = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) + , text "Rule" <+> pprRuleName rule_name + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] + + +{- Note [Unbound RULE binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be the case that the binder in a rule is not actually +bound on the LHS: + +* Type variables. Type synonyms with phantom args can give rise to + unbound template type variables. Consider this (#10689, + simplCore/should_compile/T10689): + + type Foo a b = b + + f :: Eq a => a -> Bool + f x = x==x + + {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + finkle = f 'c' + + The rule looks like + forall (a::*) (d::Eq Char) (x :: Foo a Char). + f (Foo a Char) d x = True + + Matching the rule won't bind 'a', and legitimately so. We fudge by + pretending that 'a' is bound to (Any :: *). + +* Coercion variables. On the LHS of a RULE for a local binder + we might have + RULE forall (c :: a~b). f (x |> c) = e + Now, if that binding is inlined, so that a=b=Int, we'd get + RULE forall (c :: Int~Int). f (x |> c) = e + and now when we simplify the LHS (Simplify.simplRule) we + optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: + RULE forall (c :: Int~Int). f (x |> ) = e + and then perhaps drop it altogether. Now 'c' is unbound. + + It's tricky to be sure this never happens, so instead I + say it's OK to have an unbound coercion binder in a RULE + provided its type is (c :: t~t). Then, when the RULE + fires we can substitute for c. + + This actually happened (in a RULE for a local function) + in #13410, and also in test T10602. + +Note [Cloning the template binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match (example 1): + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has nothing to +do with the 'x' in the target. + +Likewise this one (example 2): + Template: forall x. f (\x.x) + Target: f (\y.y) + +We achieve this simply by using rnBndrL to clone the template +binders if they are already in scope. + +------ Historical note ------- +At one point I tried simply adding the template binders to the +in-scope set /without/ cloning them, but that failed in a horribly +obscure way in #14777. Problem was that during matching we look +up target-term variables in the in-scope set (see Note [Lookup +in-scope]). If a target-term variable happens to name-clash with a +template variable, that lookup will find the template variable, which +is /utterly/ bogus. In #14777, this transformed a term variable +into a type variable, and then crashed when we wanted its idInfo. +------ End of historical note ------- + + +************************************************************************ +* * + The main matcher +* * +********************************************************************* -} + +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The BindWrapper in a RuleSubst are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +data RuleMatchEnv + = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_tmpls :: VarSet -- Template variables + -- (after applying envL of rv_lcl) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- (domain disjoint from envR of rv_lcl) + -- See Note [Matching lets] + , rv_unf :: IdUnfoldingFun + } + +rvInScopeEnv :: RuleMatchEnv -> InScopeEnv +rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) + +data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the + , rs_id_subst :: IdSubstEnv -- template variables + , rs_binds :: BindWrapper -- Floated bindings + , rs_bndrs :: VarSet -- Variables bound by floated lets + } + +type BindWrapper = CoreExpr -> CoreExpr + -- See Notes [Matching lets] and [Matching cases] + -- we represent the floated bindings as a core-to-core function + +emptyRuleSubst :: RuleSubst +emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv + , rs_binds = \e -> e, rs_bndrs = emptyVarSet } + +-- At one stage I tried to match even if there are more +-- template args than real args. + +-- I now think this is probably a bad idea. +-- Should the template (map f xs) match (map g)? I think not. +-- For a start, in general eta expansion wastes work. +-- SLPJ July 99 + +match :: RuleMatchEnv + -> RuleSubst + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +-- We look through certain ticks. See Note [Tick annotations in RULE matching] +match renv subst e1 (Tick t e2) + | tickishFloatable t + = match renv subst' e1 e2 + where subst' = subst { rs_binds = rs_binds subst . mkTick t } +match renv subst (Tick t e1) e2 + -- Ignore ticks in rule template. + | tickishFloatable t + = match renv subst e1 e2 +match _ _ e@Tick{} _ + = pprPanic "Tick in rule" (ppr e) + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expression. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in GHC.Core.Unify.match +match renv subst (Var v1) e2 + = match_var renv subst v1 e2 + +match renv subst e1 (Var v2) -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') + = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' + where + v2' = lookupRnInScope rn_env v2 + rn_env = rv_lcl renv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR + +match renv subst e1 (Let bind e2) + | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ + not (isJoinBind bind) -- can't float join point out of argument position + , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + = match (renv { rv_fltR = flt_subst' }) + (subst { rs_binds = rs_binds subst . Let bind' + , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) + e1 e2 + where + flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) + (flt_subst', bind') = substBind flt_subst bind + new_bndrs = bindersOf bind' + +{- Disabled: see Note [Matching cases] below +match renv (tv_subst, id_subst, binds) e1 + (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) + | exprOkForSpeculation scrut -- See Note [Matching cases] + , okToFloat rn_env bndrs (exprFreeVars scrut) + = match (renv { me_env = rn_env' }) + (tv_subst, id_subst, binds . case_wrap) + e1 rhs + where + rn_env = me_env renv + rn_env' = extendRnInScopeList rn_env bndrs + bndrs = case_bndr : alt_bndrs + case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] +-} + +match _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst + +match renv subst (App f1 a1) (App f2 a2) + = do { subst' <- match renv subst f1 f2 + ; match renv subst' a1 a2 } + +match renv subst (Lam x1 e1) e2 + | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 + = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + in match renv' subst' e1 e2 + +match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 + ; let renv' = rnMatchBndr2 renv subst x1 x2 + ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted + } + +match renv subst (Type ty1) (Type ty2) + = match_ty renv subst ty1 ty2 +match renv subst (Coercion co1) (Coercion co2) + = match_co renv subst co1 co2 + +match renv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_co renv subst co1 co2 + ; match renv subst1 e1 e2 } + +-- Everything else fails +match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------- +match_co :: RuleMatchEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +match_co renv subst co1 co2 + | Just cv <- getCoVar_maybe co1 + = match_var renv subst cv (Coercion co2) + | Just (ty1, r1) <- isReflCo_maybe co1 + = do { (ty2, r2) <- isReflCo_maybe co2 + ; guard (r1 == r2) + ; match_ty renv subst ty1 ty2 } +match_co renv subst co1 co2 + | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 + = case splitTyConAppCo_maybe co2 of + Just (tc2, cos2) + | tc1 == tc2 + -> match_cos renv subst cos1 cos2 + _ -> Nothing +match_co renv subst co1 co2 + | Just (arg1, res1) <- splitFunCo_maybe co1 + = case splitFunCo_maybe co2 of + Just (arg2, res2) + -> match_cos renv subst [arg1, res1] [arg2, res2] + _ -> Nothing +match_co _ _ _co1 _co2 + -- Currently just deals with CoVarCo, TyConAppCo and Refl +#if defined(DEBUG) + = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing +#else + = Nothing +#endif + +match_cos :: RuleMatchEnv + -> RuleSubst + -> [Coercion] + -> [Coercion] + -> Maybe RuleSubst +match_cos renv subst (co1:cos1) (co2:cos2) = + do { subst' <- match_co renv subst co1 co2 + ; match_cos renv subst' cos1 cos2 } +match_cos _ subst [] [] = Just subst +match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing + +------------- +rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv subst x1 x2 + = renv { rv_lcl = rnBndr2 rn_env x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + where + rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) + -- Typically this is a no-op, but it may matter if + -- there are some floated let-bindings + +------------------------------------------ +match_alts :: RuleMatchEnv + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe RuleSubst +match_alts _ subst [] [] + = return subst +match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match renv' subst r1 r2 + ; match_alts renv subst1 alts1 alts2 } + where + renv' = foldl' mb renv (vs1 `zip` vs2) + mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 + +match_alts _ _ _ _ + = Nothing + +------------------------------------------ +okToFloat :: RnEnv2 -> VarSet -> Bool +okToFloat rn_env bind_fvs + = allVarSet not_captured bind_fvs + where + not_captured fv = not (inRnEnvR rn_env fv) + +------------------------------------------ +match_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst +match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) + subst v1 e2 + | v1' `elemVarSet` tmpls + = match_tmpl_var renv subst v1' e2 + + | otherwise -- v1' is not a template variable; check for an exact match with e2 + = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR + Var v2 | v1' == rnOccR rn_env v2 + -> Just subst + + | Var v2' <- lookupIdSubst flt_env v2 + , v1' == v2' + -> Just subst + + _ -> Nothing + + where + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + +------------------------------------------ +match_tmpl_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) + subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) + v1' e2 + | any (inRnEnvR rn_env) (exprFreeVarsList e2) + = Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | Just e1' <- lookupVarEnv id_subst v1' + = if eqExpr (rnInScopeSet rn_env) e1' e2' + then Just subst + else Nothing + + | otherwise + = -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + do { subst' <- match_ty renv subst (idType v1') (exprType e2) + ; return (subst' { rs_id_subst = id_subst' }) } + where + -- e2' is the result of applying flt_env to e2 + e2' | isEmptyVarSet let_bndrs = e2 + | otherwise = substExpr flt_env e2 + + id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' + -- No further renaming to do on e2', + -- because no free var of e2' is in the rnEnvR of the envt + +------------------------------------------ +match_ty :: RuleMatchEnv + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst +-- Matching Core types: use the matcher in GHC.Tc.Utils.TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + +match_ty renv subst ty1 ty2 + = do { tv_subst' + <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 + ; return (subst { rs_tv_subst = tv_subst' }) } + where + tv_subst = rs_tv_subst subst + +{- +Note [Expanding variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another Very Important rule: if the term being matched is a +variable, we expand it so long as its unfolding is "expandable". (Its +occurrence information is not necessarily up to date, so we don't use +it.) By "expandable" we mean a WHNF or a "constructor-like" application. +This is the key reason for "constructor-like" Ids. If we have + {-# NOINLINE [1] CONLIKE g #-} + {-# RULE f (g x) = h x #-} +then in the term + let v = g 3 in ....(f v).... +we want to make the rule fire, to replace (f v) with (h 3). + +Note [Do not expand locally-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* expand locally-bound variables, else there's a worry that the +unfolding might mention variables that are themselves renamed. +Example + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" +the entire match. + +Hence, (a) the guard (not (isLocallyBoundR v2)) + (b) when we expand we nuke the renaming envt (nukeRnEnvR). + +Note [Tick annotations in RULE matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to unconditionally look through ticks in both template and +expression being matched. This is actually illegal for counting or +cost-centre-scoped ticks, because we have no place to put them without +changing entry counts and/or costs. So now we just fail the match in +these cases. + +On the other hand, where we are allowed to insert new cost into the +tick scope, we can float them upwards to the rule application site. + +Moreover, we may encounter ticks in the template of a rule. There are a few +ways in which these may be introduced (e.g. #18162, #17619). Such ticks are +ignored by the matcher. See Note [Simplifying rules] in +GHC.Core.Opt.Simplify.Utils for details. + +cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr + +Note [Matching lets] +~~~~~~~~~~~~~~~~~~~~ +Matching a let-expression. Consider + RULE forall x. f (g x) = +and target expression + f (let { w=R } in g E)) +Then we'd like the rule to match, to generate + let { w=R } in (\x. ) E +In effect, we want to float the let-binding outward, to enable +the match to happen. This is the WHOLE REASON for accumulating +bindings in the RuleSubst + +We can only do this if the free variables of R are not bound by the +part of the target expression outside the let binding; e.g. + f (\v. let w = v+1 in g E) +Here we obviously cannot float the let-binding for w. Hence the +use of okToFloat. + +There are a couple of tricky points. + (a) What if floating the binding captures a variable? + f (let v = x+1 in v) v + --> NOT! + let v = x+1 in f (x+1) v + + (b) What if two non-nested let bindings bind the same variable? + f (let v = e1 in b1) (let v = e2 in b2) + --> NOT! + let v = e1 in let v = e2 in (f b2 b2) + See testsuite test "RuleFloatLet". + +Our cunning plan is this: + * Along with the growing substitution for template variables + we maintain a growing set of floated let-bindings (rs_binds) + plus the set of variables thus bound. + + * The RnEnv2 in the MatchEnv binds only the local binders + in the term (lambdas, case) + + * When we encounter a let in the term to be matched, we + check that does not mention any locally bound (lambda, case) + variables. If so we fail + + * We use GHC.Core.Subst.substBind to freshen the binding, using an + in-scope set that is the original in-scope variables plus the + rs_bndrs (currently floated let-bindings). So in (a) above + we'll freshen the 'v' binding; in (b) above we'll freshen + the *second* 'v' binding. + + * We apply that freshening substitution, in a lexically-scoped + way to the term, although lazily; this is the rv_fltR field. + + +Note [Matching cases] +~~~~~~~~~~~~~~~~~~~~~ +{- NOTE: This idea is currently disabled. It really only works if + the primops involved are OkForSpeculation, and, since + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + +Consider + f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + I# n# } } ) +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let +case, because the primops concerned are ok-for-speculation. +That is, we'd like to behave as if it had been + case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + f (I# n# } } ) + +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = $s$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to $wfoo is + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + +************************************************************************ +* * + Rule-check the program +* * +************************************************************************ + + We want to know what sites have rules that could have fired but didn't. + This pass runs over the tree (without changing it) and reports such. +-} + +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: RuleOpts -- ^ Rule options + -> CompilerPhase -- ^ Rule activation test + -> String -- ^ Rule pattern + -> (Id -> [CoreRule]) -- ^ Rules for an Id + -> CoreProgram -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram ropts phase rule_pat rules binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rules = rules + , rc_ropts = ropts + } + results = unionManyBags (map (ruleCheckBind env) binds) + line = text (replicate 20 '-') + +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, + rc_pattern :: String, + rc_rules :: Id -> [CoreRule], + rc_ropts :: RuleOpts +} + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec _ r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e +ruleCheck env (Lam _ e) = ruleCheck env e +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] + +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other _ = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleCheckFun env fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + where + name_match_rules = filter match (rc_rules env fn) + match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + n_args = length args + i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args + + check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule + + rule_herald (BuiltinRule { ru_name = name }) + = text "Builtin rule" <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = text "Rule" <+> doubleQuotes (ftext name) + + rule_info opts rule + | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule + = text "matches (which is very peculiar!)" + + rule_info _ (BuiltinRule {}) = text "does not match" + + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg + where + in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) + renv = RV { rv_lcl = mkRnEnv2 in_scope + , rv_tmpls = mkVarSet rule_bndrs + , rv_fltR = mkEmptySubst in_scope + , rv_unf = rc_id_unf env } diff --git a/GHC/Core/Seq.hs b/GHC/Core/Seq.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Seq.hs @@ -0,0 +1,115 @@ +-- | +-- Various utilities for forcing Core structures +-- +-- It can often be useful to force various parts of the AST. This module +-- provides a number of @seq@-like functions to accomplish this. + +module GHC.Core.Seq ( + -- * Utilities for forcing Core structures + seqExpr, seqExprs, seqUnfolding, seqRules, + megaSeqIdInfo, seqRuleInfo, seqBinds, + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Types.Id.Info +import GHC.Types.Demand( seqDemand, seqStrictSig ) +import GHC.Types.Cpr( seqCprSig ) +import GHC.Types.Basic( seqOccInfo ) +import GHC.Types.Var.Set( seqDVarSet ) +import GHC.Types.Var( varType, tyVarKind ) +import GHC.Core.Type( seqType, isTyVar ) +import GHC.Core.Coercion( seqCo ) +import GHC.Types.Id( Id, idInfo ) + +-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the +-- compiler +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqRuleInfo (ruleInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqDemand (demandInfo info) `seq` + seqStrictSig (strictnessInfo info) `seq` + seqCprSig (cprInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqOneShot (oneShotInfo info) `seq` + seqOccInfo (occInfo info) + +seqOneShot :: OneShotInfo -> () +seqOneShot l = l `seq` () + +seqRuleInfo :: RuleInfo -> () +seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs + +seqCaf :: CafInfo -> () +seqCaf c = c `seq` () + +seqRules :: [CoreRule] -> () +seqRules [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules + +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Lit lit) = lit `seq` () +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as +seqExpr (Cast e co) = seqExpr e `seq` seqCo co +seqExpr (Tick n e) = seqTickish n `seq` seqExpr e +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co + +seqExprs :: [CoreExpr] -> () +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqTickish :: Tickish Id -> () +seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () +seqTickish HpcTick{} = () +seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids +seqTickish SourceNote{} = () + +seqBndr :: CoreBndr -> () +seqBndr b | isTyVar b = seqType (tyVarKind b) + | otherwise = seqType (varType b) `seq` + megaSeqIdInfo (idInfo b) + +seqBndrs :: [CoreBndr] -> () +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBinds :: [Bind CoreBndr] -> () +seqBinds bs = foldr (seq . seqBind) () bs + +seqBind :: Bind CoreBndr -> () +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs :: [(CoreBndr, CoreExpr)] -> () +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts :: [CoreAlt] -> () +seqAlts [] = () +seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_is_value = b1, uf_is_work_free = b2, + uf_expandable = b3, uf_is_conlike = b4, + uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g + +seqUnfolding _ = () + +seqGuidance :: UnfoldingGuidance -> () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () diff --git a/GHC/Core/SimpleOpt.hs b/GHC/Core/SimpleOpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/SimpleOpt.hs @@ -0,0 +1,1603 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Core.SimpleOpt ( + -- ** Simple expression optimiser + simpleOptPgm, simpleOptExpr, simpleOptExprWith, + + -- ** Join points + joinPointBinding_maybe, joinPointBindings_maybe, + + -- ** Predicates on expressions + exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, + + -- ** Coercions and casts + pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core.Opt.Arity( etaExpandToJoinPoint ) + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils +import GHC.Core.FVs +import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding ) +import GHC.Core.Make ( FloatBind(..) ) +import GHC.Core.Ppr ( pprCoreBindings, pprRules ) +import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm ) +import GHC.Types.Literal +import GHC.Types.Id +import GHC.Types.Id.Info ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) +import GHC.Types.Var ( isNonCoVarId ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.DataCon +import GHC.Types.Demand( etaConvertStrictSig ) +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.TyCon ( tyConArity ) +import GHC.Core.Multiplicity +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Types.Basic +import GHC.Unit.Module ( Module ) +import GHC.Utils.Encoding +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Data.Pair +import GHC.Utils.Misc +import GHC.Data.Maybe ( orElse ) +import Data.List +import qualified Data.ByteString as BS + +{- +************************************************************************ +* * + The Simple Optimiser +* * +************************************************************************ + +Note [The simple optimiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simple optimiser is a lightweight, pure (non-monadic) function +that rapidly does a lot of simple optimisations, including + + - inlining things that occur just once, + or whose RHS turns out to be trivial + - beta reduction + - case of known constructor + - dead code elimination + +It does NOT do any call-site inlining; it only inlines a function if +it can do so unconditionally, dropping the binding. It thereby +guarantees to leave no un-reduced beta-redexes. + +It is careful to follow the guidance of "Secrets of the GHC inliner", +and in particular the pre-inline-unconditionally and +post-inline-unconditionally story, to do effective beta reduction on +functions called precisely once, without repeatedly optimising the same +expression. In fact, the simple optimiser is a good example of this +little dance in action; the full Simplifier is a lot more complicated. + +-} + +simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr +-- See Note [The simple optimiser] +-- Do simple optimisation on an expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or where the RHS is trivial +-- +-- We also inline bindings that bind a Eq# box: see +-- See Note [Getting the map/coerce RULE to work]. +-- +-- Also we convert functions to join points where possible (as +-- the occurrence analyser does most of the work anyway). +-- +-- The result is NOT guaranteed occurrence-analysed, because +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically + +simpleOptExpr dflags expr + = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) + simpleOptExprWith dflags init_subst expr + where + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + -- It's potentially important to make a proper in-scope set + -- Consider let x = ..y.. in \y. ...x... + -- Then we should remember to clone y before substituting + -- for x. It's very unlikely to occur, because we probably + -- won't *be* substituting for x if it occurs inside a + -- lambda. + -- + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + +simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr +-- See Note [The simple optimiser] +simpleOptExprWith dflags subst expr + = simple_opt_expr init_env (occurAnalyseExpr expr) + where + init_env = SOE { soe_dflags = dflags + , soe_inl = emptyVarEnv + , soe_subst = subst } + +---------------------- +simpleOptPgm :: DynFlags -> Module + -> CoreProgram -> [CoreRule] + -> IO (CoreProgram, [CoreRule]) +-- See Note [The simple optimiser] +simpleOptPgm dflags this_mod binds rules + = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore (pprCoreBindings occ_anald_binds $$ pprRules rules ); + + ; return (reverse binds', rules') } + where + occ_anald_binds = occurAnalysePgm this_mod + (\_ -> True) {- All unfoldings active -} + (\_ -> False) {- No rules active -} + rules binds + + (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds + final_subst = soe_subst final_env + + rules' = substRulesForImportedIds final_subst rules + -- We never unconditionally inline into rules, + -- hence paying just a substitution + + do_one (env, binds') bind + = case simple_opt_bind env bind TopLevel of + (env', Nothing) -> (env', binds') + (env', Just bind') -> (env', bind':binds') + +-- In these functions the substitution maps InVar -> OutExpr + +---------------------- +type SimpleClo = (SimpleOptEnv, InExpr) + +data SimpleOptEnv + = SOE { soe_dflags :: DynFlags + , soe_inl :: IdEnv SimpleClo + -- Deals with preInlineUnconditionally; things + -- that occur exactly once and are inlined + -- without having first been simplified + + , soe_subst :: Subst + -- Deals with cloning; includes the InScopeSet + } + +instance Outputable SimpleOptEnv where + ppr (SOE { soe_inl = inl, soe_subst = subst }) + = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl + , text "soe_subst =" <+> ppr subst ] + <+> text "}" + +emptyEnv :: DynFlags -> SimpleOptEnv +emptyEnv dflags + = SOE { soe_dflags = dflags + , soe_inl = emptyVarEnv + , soe_subst = emptySubst } + +soeZapSubst :: SimpleOptEnv -> SimpleOptEnv +soeZapSubst env@(SOE { soe_subst = subst }) + = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } + +soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv +-- Take in-scope set from env1, and the rest from env2 +soeSetInScope (SOE { soe_subst = subst1 }) + env2@(SOE { soe_subst = subst2 }) + = env2 { soe_subst = setInScope subst2 (substInScope subst1) } + +--------------- +simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr +simple_opt_clo env (e_env, e) + = simple_opt_expr (soeSetInScope env e_env) e + +simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr env expr + = go expr + where + subst = soe_subst env + in_scope = substInScope subst + in_scope_env = (in_scope, simpleUnfoldingFun) + + --------------- + go (Var v) + | Just clo <- lookupVarEnv (soe_inl env) v + = simple_opt_clo env clo + | otherwise + = lookupIdSubst (soe_subst env) v + + go (App e1 e2) = simple_app env e1 [(env,e2)] + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (go_co co) + go (Lit lit) = Lit lit + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) = mk_cast (go e) (go_co co) + go (Let bind body) = case simple_opt_bind env bind NotTopLevel of + (env', Nothing) -> simple_opt_expr env' body + (env', Just bind) -> Let bind (simple_opt_expr env' body) + + go lam@(Lam {}) = go_lam env [] lam + go (Case e b ty as) + -- See Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + -- We don't need to be concerned about floats when looking for coerce. + , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as + = case altcon of + DEFAULT -> go rhs + _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs + where + (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ + zipEqual "simpleOptExpr" bs es + + -- Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , [(DEFAULT, _, rhs)] <- as + , isCoVarType (varType b) + , (Var fun, _args) <- collectArgs e + , fun `hasKey` coercibleSCSelIdKey + -- without this last check, we get #11230 + = go rhs + + | otherwise + = Case e' b' (substTy subst ty) + (map (go_alt env') as) + where + e' = go e + (env', b') = subst_opt_bndr env b + + ---------------------- + go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co + + ---------------------- + go_alt env (con, bndrs, rhs) + = (con, bndrs', simple_opt_expr env' rhs) + where + (env', bndrs') = subst_opt_bndrs env bndrs + + ---------------------- + -- go_lam tries eta reduction + go_lam env bs' (Lam b e) + = go_lam env' (b':bs') e + where + (env', b') = subst_opt_bndr env b + go_lam env bs' e + | Just etad_e <- tryEtaReduce bs e' = etad_e + | otherwise = mkLams bs e' + where + bs = reverse bs' + e' = simple_opt_expr env e + +mk_cast :: CoreExpr -> CoercionR -> CoreExpr +-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check. +-- mkCast doesn't do that because the Simplifier does (in simplCast) +-- But in SimpleOpt it's nice to kill those nested casts (#18112) +mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCo` co2) +mk_cast (Tick t e) co = Tick t (mk_cast e co) +mk_cast e co | isReflexiveCo co = e + | otherwise = Cast e co + +---------------------- +-- simple_app collects arguments for beta reduction +simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr + +simple_app env (Var v) as + | Just (env', e) <- lookupVarEnv (soe_inl env) v + = simple_app (soeSetInScope env env') e as + + | let unf = idUnfolding v + , isCompulsoryUnfolding (idUnfolding v) + , isAlwaysActive (idInlineActivation v) + -- See Note [Unfold compulsory unfoldings in LHSs] + = simple_app (soeZapSubst env) (unfoldingTemplate unf) as + + | otherwise + , let out_fn = lookupIdSubst (soe_subst env) v + = finish_app env out_fn as + +simple_app env (App e1 e2) as + = simple_app env e1 ((env, e2) : as) + +simple_app env (Lam b e) (a:as) + = wrapLet mb_pr (simple_app env' e as) + where + (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel + +simple_app env (Tick t e) as + -- Okay to do "(Tick t e) x ==> Tick t (e x)"? + | t `tickishScopesLike` SoftScope + = mkTick t $ simple_app env e as + +-- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) +-- The let might appear there as a result of inlining +-- e.g. let f = let x = e in b +-- in f a1 a2 +-- (#13208) +-- However, do /not/ do this transformation for join points +-- See Note [simple_app and join points] +simple_app env (Let bind body) args + = case simple_opt_bind env bind NotTopLevel of + (env', Nothing) -> simple_app env' body args + (env', Just bind') + | isJoinBind bind' -> finish_app env expr' args + | otherwise -> Let bind' (simple_app env' body args) + where + expr' = Let bind' (simple_opt_expr env' body) + +simple_app env e as + = finish_app env (simple_opt_expr env e) as + +finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr +finish_app _ fun [] + = fun +finish_app env fun (arg:args) + = finish_app env (App fun (simple_opt_clo env arg)) args + +---------------------- +simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag + -> (SimpleOptEnv, Maybe OutBind) +simple_opt_bind env (NonRec b r) top_level + = (env', case mb_pr of + Nothing -> Nothing + Just (b,r) -> Just (NonRec b r)) + where + (b', r') = joinPointBinding_maybe b r `orElse` (b, r) + (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level + +simple_opt_bind env (Rec prs) top_level + = (env'', res_bind) + where + res_bind = Just (Rec (reverse rev_prs')) + prs' = joinPointBindings_maybe prs `orElse` prs + (env', bndrs') = subst_opt_bndrs env (map fst prs') + (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs') + do_pr (env, prs) ((b,r), b') + = (env', case mb_pr of + Just pr -> pr : prs + Nothing -> prs) + where + (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level + +---------------------- +simple_bind_pair :: SimpleOptEnv + -> InVar -> Maybe OutVar + -> SimpleClo + -> TopLevelFlag + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) + -- (simple_bind_pair subst in_var out_rhs) + -- either extends subst with (in_var -> out_rhs) + -- or returns Nothing +simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) + in_bndr mb_out_bndr clo@(rhs_env, in_rhs) + top_level + | Type ty <- in_rhs -- let a::* = TYPE ty in + , let out_ty = substTy (soe_subst rhs_env) ty + = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr in_rhs ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion co <- in_rhs + , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) + -- The previous two guards got rid of tyvars and coercions + -- See Note [Core type and coercion invariant] in GHC.Core + pre_inline_unconditionally + = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ active stable_unf top_level + where + stable_unf = isStableUnfolding (idUnfolding in_bndr) + active = isAlwaysActive (idInlineActivation in_bndr) + occ = idOccInfo in_bndr + + out_rhs | Just join_arity <- isJoinId_maybe in_bndr + = simple_join_rhs join_arity + | otherwise + = simple_opt_clo env clo + + simple_join_rhs join_arity -- See Note [Preserve join-binding arity] + = mkLams join_bndrs' (simple_opt_expr env_body join_body) + where + env0 = soeSetInScope env rhs_env + (join_bndrs, join_body) = collectNBinders join_arity in_rhs + (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs + + pre_inline_unconditionally :: Bool + pre_inline_unconditionally + | isExportedId in_bndr = False + | stable_unf = False + | not active = False -- Note [Inline prag in simplOpt] + | not (safe_to_inline occ) = False + | otherwise = True + + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline IAmALoopBreaker{} = False + safe_to_inline IAmDead = True + safe_to_inline OneOcc{ occ_in_lam = NotInsideLam + , occ_n_br = 1 } = True + safe_to_inline OneOcc{} = False + safe_to_inline ManyOccs{} = False + +------------------- +simple_out_bind :: TopLevelFlag + -> SimpleOptEnv + -> (InVar, OutExpr) + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) + | Type out_ty <- out_rhs + = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr out_ty $$ ppr out_rhs ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion out_co <- out_rhs + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr Nothing out_rhs + (idOccInfo in_bndr) True False top_level + +------------------- +simple_out_bind_pair :: SimpleOptEnv + -> InId -> Maybe OutId -> OutExpr + -> OccInfo -> Bool -> Bool -> TopLevelFlag + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ_info active stable_unf top_level + | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) + -- Type and coercion bindings are caught earlier + -- See Note [Core type and coercion invariant] + post_inline_unconditionally + = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } + , Nothing) + + | otherwise + = ( env', Just (out_bndr, out_rhs) ) + where + (env', bndr1) = case mb_out_bndr of + Just out_bndr -> (env, out_bndr) + Nothing -> subst_opt_bndr env in_bndr + out_bndr = add_info env' in_bndr top_level out_rhs bndr1 + + post_inline_unconditionally :: Bool + post_inline_unconditionally + | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] + | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] + | not active = False -- in GHC.Core.Opt.Simplify.Utils + | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | exprIsTrivial out_rhs = True + | coercible_hack = True + | otherwise = False + + is_loop_breaker = isWeakLoopBreaker occ_info + + -- See Note [Getting the map/coerce RULE to work] + coercible_hack | (Var fun, args) <- collectArgs out_rhs + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey + = all exprIsTrivial args + | otherwise + = False + +{- Note [Exported Ids and trivial RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously do not want to unconditionally inline an Id that is exported. +In GHC.Core.Opt.Simplify.Utils, Note [Top level and postInlineUnconditionally], we +explain why we don't inline /any/ top-level things unconditionally, even +trivial ones. But we do here! Why? In the simple optimiser + + * We do no rule rewrites + * We do no call-site inlining + +Those differences obviate the reasons for not inlining a trivial rhs, +and increase the benefit for doing so. So we unconditionally inline trivial +rhss here. + +Note [Preserve join-binding arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful /not/ to eta-reduce the RHS of a join point, lest we lose +the join-point arity invariant. #15108 was caused by simplifying +the RHS with simple_opt_expr, which does eta-reduction. Solution: +simplify the RHS of a join point by simplifying under the lambdas +(which of course should be there). + +Note [simple_app and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general for let-bindings we can do this: + (let { x = e } in b) a ==> let { x = e } in b a + +But not for join points! For two reasons: + +- We would need to push the continuation into the RHS: + (join { j = e } in b) a ==> let { j' = e a } in b[j'/j] a + NB ----^^ + and also change the type of j, hence j'. + That's a bit sophisticated for the very simple optimiser. + +- We might end up with something like + join { j' = e a } in + (case blah of ) + ( True -> j' void# ) a + ( False -> blah ) + and now the call to j' doesn't look like a tail call, and + Lint may reject. I say "may" because this is /explicitly/ + allowed in the "Compiling without Continuations" paper + (Section 3, "Managing \Delta"). But GHC currently does not + allow this slightly-more-flexible form. See GHC.Core + Note [Join points are less general than the paper]. + +The simple thing to do is to disable this transformation +for join points in the simple optimiser + +Note [The Let-Unfoldings Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A program has the Let-Unfoldings property iff: + +- For every let-bound variable f, whether top-level or nested, whether + recursive or not: + - Both the binding Id of f, and every occurrence Id of f, has an idUnfolding. + - For non-INLINE things, that unfolding will be f's right hand sids + - For INLINE things (which have a "stable" unfolding) that unfolding is + semantically equivalent to f's RHS, but derived from the original RHS of f + rather that its current RHS. + +Informally, we can say that in a program that has the Let-Unfoldings property, +all let-bound Id's have an explicit unfolding attached to them. + +Currently, the simplifier guarantees the Let-Unfoldings invariant for anything +it outputs. + +-} + +---------------------- +subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) +subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs + +subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) +subst_opt_bndr env bndr + | isTyVar bndr = (env { soe_subst = subst_tv }, tv') + | isCoVar bndr = (env { soe_subst = subst_cv }, cv') + | otherwise = subst_opt_id_bndr env bndr + where + subst = soe_subst env + (subst_tv, tv') = substTyVarBndr subst bndr + (subst_cv, cv') = substCoVarBndr subst bndr + +subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) +-- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by +-- add_info. +-- +-- Rather like SimplEnv.substIdBndr +-- +-- It's important to zap fragile OccInfo (which GHC.Core.Subst.substIdBndr +-- carefully does not do) because simplOptExpr invalidates it + +subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id + = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id) + where + Subst in_scope id_subst tv_subst cv_subst = subst + + id1 = uniqAway in_scope old_id + id2 = updateIdTypeAndMult (substTy subst) id1 + new_id = zapFragileIdInfo id2 + -- Zaps rules, unfolding, and fragile OccInfo + -- The unfolding and rules will get added back later, by add_info + + new_in_scope = in_scope `extendInScopeSet` new_id + + no_change = new_id == old_id + + -- Extend the substitution if the unique has changed, + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst + | no_change = delVarEnv id_subst old_id + | otherwise = extendVarEnv id_subst old_id (Var new_id) + + new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst + new_inl = delVarEnv inl old_id + +---------------------- +add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar +add_info env old_bndr top_level new_rhs new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = lazySetIdInfo new_bndr new_info + where + subst = soe_subst env + dflags = soe_dflags env + old_info = idInfo old_bndr + + -- Add back in the rules and unfolding which were + -- removed by zapFragileIdInfo in subst_opt_id_bndr. + -- + -- See Note [The Let-Unfoldings Invariant] + new_info = idInfo new_bndr `setRuleInfo` new_rules + `setUnfoldingInfo` new_unfolding + + old_rules = ruleInfo old_info + new_rules = substSpec subst new_bndr old_rules + + old_unfolding = unfoldingInfo old_info + new_unfolding | isStableUnfolding old_unfolding + = substUnfolding subst old_unfolding + | otherwise + = unfolding_from_rhs + + unfolding_from_rhs = mkUnfolding dflags InlineRhs + (isTopLevel top_level) + False -- may be bottom or not + new_rhs + +simpleUnfoldingFun :: IdUnfoldingFun +simpleUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr +wrapLet Nothing body = body +wrapLet (Just (b,r)) body = Let (NonRec b r) body + +{- +Note [Inline prag in simplOpt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there's an INLINE/NOINLINE pragma that restricts the phase in +which the binder can be inlined, we don't inline here; after all, +we don't know what phase we're in. Here's an example + + foo :: Int -> Int -> Int + {-# INLINE foo #-} + foo m n = inner m + where + {-# INLINE [1] inner #-} + inner m = m+n + + bar :: Int -> Int + bar n = foo n 1 + +When inlining 'foo' in 'bar' we want the let-binding for 'inner' +to remain visible until Phase 1 + +Note [Unfold compulsory unfoldings in LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user writes `RULES map coerce = coerce` as a rule, the rule +will only ever match if simpleOptExpr replaces coerce by its unfolding +on the LHS, because that is the core that the rule matching engine +will find. So do that for everything that has a compulsory +unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore. + +However, we don't want to inline 'seq', which happens to also have a +compulsory unfolding, so we only do this unfolding only for things +that are always-active. See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Getting the map/coerce RULE to work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to allow the "map/coerce" RULE to fire: + + {-# RULES "map/coerce" map coerce = coerce #-} + +The naive core produced for this is + + forall a b (dict :: Coercible * a b). + map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' + + where dict' :: Coercible [a] [b] + dict' = ... + +This matches literal uses of `map coerce` in code, but that's not what we +want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) +too. Some of this is addressed by compulsorily unfolding coerce on the LHS, +yielding + + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Getting better. But this isn't exactly what gets produced. This is because +Coercible essentially has ~R# as a superclass, and superclasses get eagerly +extracted during solving. So we get this: + + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Unfortunately, this still abstracts over a Coercible dictionary. We really +want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, +which transforms the above to (see also Note [Desugaring coerce as cast] in +Desugar) + + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + +Now, we need simpleOptExpr to fix this up. It does so by taking three +separate actions: + 1. Inline certain non-recursive bindings. The choice whether to inline + is made in simple_bind_pair. Note the rather specific check for + MkCoercible in there. + + 2. Stripping case expressions like the Coercible_SCSel one. + See the `Case` case of simple_opt_expr's `go` function. + + 3. Look for case expressions that unpack something that was + just packed and inline them. This is also done in simple_opt_expr's + `go` function. + +This is all a fair amount of special-purpose hackery, but it's for +a good cause. And it won't hurt other RULES and such that it comes across. + + +************************************************************************ +* * + Join points +* * +************************************************************************ +-} + +-- | Returns Just (bndr,rhs) if the binding is a join point: +-- If it's a JoinId, just return it +-- If it's not yet a JoinId but is always tail-called, +-- make it into a JoinId and return it. +-- In the latter case, eta-expand the RHS if necessary, to make the +-- lambdas explicit, as is required for join points +-- +-- Precondition: the InBndr has been occurrence-analysed, +-- so its OccInfo is valid +joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) +joinPointBinding_maybe bndr rhs + | not (isId bndr) + = Nothing + + | isJoinId bndr + = Just (bndr, rhs) + + | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) + , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs + , let str_sig = idStrictness bndr + str_arity = count isId bndrs -- Strictness demands are for Ids only + join_bndr = bndr `asJoinId` join_arity + `setIdStrictness` etaConvertStrictSig str_arity str_sig + = Just (join_bndr, mkLams bndrs body) + + | otherwise + = Nothing + +joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] +joinPointBindings_maybe bndrs + = mapM (uncurry joinPointBinding_maybe) bndrs + + +{- Note [Strictness and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + let f = \x. if x>200 then e1 else e1 + +and we know that f is strict in x. Then if we subsequently +discover that f is an arity-2 join point, we'll eta-expand it to + + let f = \x y. if x>200 then e1 else e1 + +and now it's only strict if applied to two arguments. So we should +adjust the strictness info. + +A more common case is when + + f = \x. error ".." + +and again its arity increases (#15517) +-} + +{- ********************************************************************* +* * + exprIsConApp_maybe +* * +************************************************************************ + +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if + + +Note [exprIsConApp_maybe on literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #9400 and #13317. + +Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core +they are represented as unpackCString# "abc"# by GHC.Core.Make.mkStringExprFS, or +unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. + +For optimizations we want to be able to treat it as a list, so they can be +decomposed when used in a case-statement. exprIsConApp_maybe detects those +calls to unpackCString# and returns: + +Just (':', [Char], ['a', unpackCString# "bc"]). + +We need to be careful about UTF8 strings here. ""# contains an encoded ByteString, so +we call utf8UnconsByteString to correctly deal with the encoding and splitting. + +We must also be careful about + lvl = "foo"# + ...(unpackCString# lvl)... +to ensure that we see through the let-binding for 'lvl'. Hence the +(exprIsLiteral_maybe .. arg) in the guard before the call to +dealWithStringLiteral. + +The tests for this function are in T9400. + +Note [Push coercions in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #13025 I found a case where we had + op (df @t1 @t2) -- op is a ClassOp +where + df = (/\a b. K e1 e2) |> g + +To get this to come out we need to simplify on the fly + ((/\a b. K e1 e2) |> g) @t1 @t2 + +Hence the use of pushCoArgs. + +Note [exprIsConApp_maybe on data constructors with wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: +- some data constructors have wrappers +- these wrappers inline late (see MkId Note [Activation for data constructor wrappers]) +- but we still want case-of-known-constructor to fire early. + +Example: + data T = MkT !Int + $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT + foo x = case $WMkT e of MkT y -> blah + +Here we want the case-of-known-constructor transformation to fire, giving + foo x = case e of x' -> let y = x' in blah + +Here's how exprIsConApp_maybe achieves this: + +0. Start with scrutinee = $WMkT e + +1. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked + as expandable. (See GHC.Core.Utils.isExpandableApp.) Now we have + scrutinee = (\n. case n of n' -> MkT n') e + +2. Beta-reduce the application, generating a floated 'let'. + See Note [beta-reduction in exprIsConApp_maybe] below. Now we have + scrutinee = case n of n' -> MkT n' + with floats {Let n = e} + +3. Float the "case x of x' ->" binding out. Now we have + scrutinee = MkT n' + with floats {Let n = e; case n of n' ->} + +And now we have a known-constructor MkT that we can return. + +Notice that both (2) and (3) require exprIsConApp_maybe to gather and return +a bunch of floats, both let and case bindings. + +Note that this strategy introduces some subtle scenarios where a data-con +wrapper can be replaced by a data-con worker earlier than we’d like, see +Note [exprIsConApp_maybe for data-con wrappers: tricky corner]. + +Note [beta-reduction in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is +typically a function. For instance, take the wrapper for MkT in Note +[exprIsConApp_maybe on data constructors with wrappers]: + + $WMkT n = case n of { n' -> T n' } + +If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT, +it will see + + (\n -> case n of { n' -> T n' }) arg + +In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction. + +We don't want to blindly substitute `arg` in the body of the function, because +it duplicates work. We can (and, in fact, used to) substitute `arg` in the body, +but only when `arg` is a variable (or something equally work-free). + +But, because of Note [exprIsConApp_maybe on data constructors with wrappers], +'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce +_always_: + + (\x -> body) arg + +Is transformed into + + let x = arg in body + +Which, effectively, means emitting a float `let x = arg` and recursively +analysing the body. + +For newtypes, this strategy requires that their wrappers have compulsory unfoldings. +Suppose we have + newtype T a b where + MkT :: a -> T b a -- Note args swapped + +This defines a worker function MkT, a wrapper function $WMkT, and an axT: + $WMkT :: forall a b. a -> T b a + $WMkT = /\b a. \(x:a). MkT a b x -- A real binding + + MkT :: forall a b. a -> T a b + MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding + + axiom axT :: a ~R# T a b + +Now we are optimising + case $WMkT (I# 3) |> sym axT of I# y -> ... +we clearly want to simplify this. If $WMkT did not have a compulsory +unfolding, we would end up with + let a = I#3 in case a of I# y -> ... +because in general, we do this on-the-fly beta-reduction + (\x. e) blah --> let x = blah in e +and then float the let. (Substitution would risk duplicating 'blah'.) + +But if the case-of-known-constructor doesn't actually fire (i.e. +exprIsConApp_maybe does not return Just) then nothing happens, and nothing +will happen the next time either. + +See test T16254, which checks the behavior of newtypes. + +Note [Don't float join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe should succeed on + let v = e in Just v +returning [x=e] as one of the [FloatBind]. But it must +NOT succeed on + join j x = rhs in Just v +because join-points can't be gaily floated. Consider + case (join j x = rhs in Just) of + K p q -> blah +We absolutely must not "simplify" this to + join j x = rhs + in blah +because j's return type is (Maybe t), quite different to blah's. + +You might think this could never happen, because j can't be +tail-called in the body if the body returns a constructor. But +in !3113 we had a /dead/ join point (which is not illegal), +and its return type was wonky. + +The simple thing is not to float a join point. The next iteration +of the simplifier will sort everything out. And it there is +a join point, the chances are that the body is not a constructor +application, so failing faster is good. + +Note [exprIsConApp_maybe for data-con wrappers: tricky corner] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking + + * exprIsConApp_maybe honours the inline phase; that is, it does not look + inside the unfolding for an Id unless its unfolding is active in this phase. + That phase-sensitivity is expressed in the InScopeEnv (specifically, the + IdUnfoldingFun component of the InScopeEnv) passed to exprIsConApp_maybe. + + * Data-constructor wrappers are active only in phase 0 (the last phase); + see Note [Activation for data constructor wrappers] in GHC.Types.Id.Make. + +On the face of it that means that exprIsConApp_maybe won't look inside data +constructor wrappers until phase 0. But that seems pretty Bad. So we cheat. +For data con wrappers we unconditionally look inside its unfolding, regardless +of phase, so that we get case-of-known-constructor to fire in every phase. + +Perhaps unsurprisingly, this cheating can backfire. An example: + + data T = C !A B + foo p q = let x = C e1 e2 in seq x $ f x + {-# RULE "wurble" f (C a b) = b #-} + +In Core, the RHS of foo is + + let x = $WC e1 e2 in case x of y { C _ _ -> f x } + +and after doing a binder swap and inlining x, we have: + + case $WC e1 e2 of y { C _ _ -> f y } + +Case-of-known-constructor fires, but now we have to reconstruct a binding for +`y` (which was dead before the binder swap) on the RHS of the case alternative. +Naturally, we’ll use the worker: + + case e1 of a { DEFAULT -> let y = C a e2 in f y } + +and after inlining `y`, we have: + + case e1 of a { DEFAULT -> f (C a e2) } + +Now we might hope the "wurble" rule would fire, but alas, it will not: we have +replaced $WC with C, but the (desugared) rule matches on $WC! We weren’t +supposed to inline $WC yet for precisely that reason (see Note [Activation for +data constructor wrappers]), but our cheating in exprIsConApp_maybe came back to +bite us. + +This is rather unfortunate, especially since this can happen inside stable +unfoldings as well as ordinary code (which really happened, see !3041). But +there is no obvious solution except to delay case-of-known-constructor on +data-con wrappers, and that cure would be worse than the disease. + +This Note exists solely to document the problem. +-} + +data ConCont = CC [CoreExpr] Coercion + -- Substitution already applied + +-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument +-- expression is a *saturated* constructor application of the form @let b1 in +-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the +-- *universally-quantified* type args of 'dc'. Floats can also be (and most +-- likely are) single-alternative case expressions. Why does +-- 'exprIsConApp_maybe' return floats? We may have to look through lets and +-- cases to detect that we are in the presence of a data constructor wrapper. In +-- this case, we need to return the lets and cases that we traversed. See Note +-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers +-- are unfolded late, but we really want to trigger case-of-known-constructor as +-- early as possible. See also Note [Activation for data constructor wrappers] +-- in "GHC.Types.Id.Make". +-- +-- We also return the incoming InScopeSet, augmented with +-- the binders from any [FloatBind] that we return +exprIsConApp_maybe :: HasDebugCallStack + => InScopeEnv -> CoreExpr + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) + where + go :: Either InScopeSet Subst + -- Left in-scope means "empty substitution" + -- Right subst means "apply this substitution to the CoreExpr" + -- NB: in the call (go subst floats expr cont) + -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' + -> [FloatBind] -> CoreExpr -> ConCont + -- Notice that the floats here are in reverse order + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + go subst floats (Tick t expr) cont + | not (tickishIsCode t) = go subst floats expr cont + + go subst floats (Cast expr co1) (CC args co2) + | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args + -- See Note [Push coercions in exprIsConApp_maybe] + = case m_co1' of + MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2)) + MRefl -> go subst floats expr (CC args' co2) + + go subst floats (App fun arg) (CC args co) + = go subst floats fun (CC (subst_expr subst arg : args) co) + + go subst floats (Lam bndr body) (CC (arg:args) co) + | exprIsTrivial arg -- Don't duplicate stuff! + = go (extend subst bndr arg) floats body (CC args co) + | otherwise + = let (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' arg) + in go subst' (float:floats) body (CC args co) + + go subst floats (Let (NonRec bndr rhs) expr) cont + | not (isJoinId bndr) + -- Crucial guard! See Note [Don't float join points] + = let rhs' = subst_expr subst rhs + (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' rhs') + in go subst' (float:floats) expr cont + + go subst floats (Case scrut b _ [(con, vars, expr)]) cont + = let + scrut' = subst_expr subst scrut + (subst', b') = subst_bndr subst b + (subst'', vars') = subst_bndrs subst' vars + float = FloatCase scrut' b' con vars' + in + go subst'' (float:floats) expr cont + + go (Right sub) floats (Var v) cont + = go (Left (substInScope sub)) + floats + (lookupIdSubst sub v) + cont + + go (Left in_scope) floats (Var fun) cont@(CC args co) + + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + = succeedWith in_scope floats $ + pushCoDataCon con args co + + -- Look through data constructor wrappers: they inline late (See Note + -- [Activation for data constructor wrappers]) but we want to do + -- case-of-known-constructor optimisation eagerly (see Note + -- [exprIsConApp_maybe on data constructors with wrappers]). + | isDataConWrapId fun + , let rhs = uf_tmpl (realIdUnfolding fun) + = go (Left in_scope) floats rhs cont + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let subst = mkOpenSubst in_scope (bndrs `zip` args) + = succeedWith in_scope floats $ + pushCoDataCon con (map (substExpr subst) dfun_args) co + + -- Look through unfoldings, but only arity-zero one; + -- if arity > 0 we are effectively inlining a function call, + -- and that is the business of callSiteInline. + -- In practice, without this test, most of the "hits" were + -- CPR'd workers getting inlined back into their wrappers, + | idArity fun == 0 + , Just rhs <- expandUnfolding_maybe unfolding + , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) + = go (Left in_scope') floats rhs cont + + -- See Note [exprIsConApp_maybe on literal strings] + | (fun `hasKey` unpackCStringIdKey) || + (fun `hasKey` unpackCStringUtf8IdKey) + , [arg] <- args + , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg + = succeedWith in_scope floats $ + dealWithStringLiteral fun str co + where + unfolding = id_unf fun + + go _ _ _ _ = Nothing + + succeedWith :: InScopeSet -> [FloatBind] + -> Maybe (DataCon, [Type], [CoreExpr]) + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + succeedWith in_scope rev_floats x + = do { (con, tys, args) <- x + ; let floats = reverse rev_floats + ; return (in_scope, floats, con, tys, args) } + + ---------------------------- + -- Operations on the (Either InScopeSet GHC.Core.Subst) + -- The Left case is wildly dominant + subst_co (Left {}) co = co + subst_co (Right s) co = GHC.Core.Subst.substCo s co + + subst_expr (Left {}) e = e + subst_expr (Right s) e = substExpr s e + + subst_bndr msubst bndr + = (Right subst', bndr') + where + (subst', bndr') = substBndr subst bndr + subst = case msubst of + Left in_scope -> mkEmptySubst in_scope + Right subst -> subst + + subst_bndrs subst bs = mapAccumL subst_bndr subst bs + + extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) + extend (Right s) v e = Right (extendSubst s v e) + + +-- See Note [exprIsConApp_maybe on literal strings] +dealWithStringLiteral :: Var -> BS.ByteString -> Coercion + -> Maybe (DataCon, [Type], [CoreExpr]) + +-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS +-- turns those into [] automatically, but just in case something else in GHC +-- generates a string literal directly. +dealWithStringLiteral fun str co = + case utf8UnconsByteString str of + Nothing -> pushCoDataCon nilDataCon [Type charTy] co + Just (char, charTail) -> + let char_expr = mkConApp charDataCon [mkCharLit char] + -- In singleton strings, just add [] instead of unpackCstring# ""#. + rest = if BS.null charTail + then mkConApp nilDataCon [Type charTy] + else App (Var fun) + (Lit (LitString charTail)) + + in pushCoDataCon consDataCon [Type charTy, char_expr, rest] co + +{- +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + +Note [DFun arity check] +~~~~~~~~~~~~~~~~~~~~~~~ +Here we check that the total number of supplied arguments (including +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in GHC.Core +-} + +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal +-- Same deal as exprIsConApp_maybe, but much simpler +-- Nevertheless we do need to look through unfoldings for +-- Integer and string literals, which are vigorously hoisted to top level +-- and not subsequently inlined +exprIsLiteral_maybe env@(_, id_unf) e + = case e of + Lit l -> Just l + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? + Var v + | Just rhs <- expandUnfolding_maybe (id_unf v) + , Just l <- exprIsLiteral_maybe env rhs + -> Just l + Var v + | Just rhs <- expandUnfolding_maybe (id_unf v) + , Just b <- matchBignum env rhs + -> Just b + e + | Just b <- matchBignum env e + -> Just b + + | otherwise + -> Nothing + where + matchBignum env e + | Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env e + , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg + = if + | dc == naturalNSDataCon -> Just (mkLitNatural i) + | dc == integerISDataCon -> Just (mkLitInteger i) + | otherwise -> Nothing + | otherwise + = Nothing + +{- +Note [exprIsLambda_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsLambda_maybe will, given an expression `e`, try to turn it into the form +`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through +casts (using the Push rule), and it unfolds function calls if the unfolding +has a greater arity than arguments are present. + +Currently, it is used in GHC.Core.Rules.match, and is required to make +"map coerce = coerce" match. +-} + +exprIsLambda_maybe :: InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[Tickish Id]) + -- See Note [exprIsLambda_maybe] + +-- The simple case: It is a lambda already +exprIsLambda_maybe _ (Lam x e) + = Just (x, e, []) + +-- Still straightforward: Ticks that we can float out of the way +exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) + | tickishFloatable t + , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + = Just (x, e, t:ts) + +-- Also possible: A casted lambda. Push the coercion inside +exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e + -- Only do value lambdas. + -- this implies that x is not in scope in gamma (makes this code simpler) + , not (isTyVar x) && not (isCoVar x) + , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co + , let res = Just (x',e',ts) + = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) + res + +-- Another attempt: See if we find a partial unfolding +exprIsLambda_maybe (in_scope_set, id_unf) e + | (Var f, as, ts) <- collectArgsTicks tickishFloatable e + , idArity f > count isValArg as + -- Make sure there is hope to get a lambda + , Just rhs <- expandUnfolding_maybe (id_unf f) + -- Optimize, for beta-reduction + , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as) + -- Recurse, because of possible casts + , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , let res = Just (x', e'', ts++ts') + = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) + res + +exprIsLambda_maybe _ _e + = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) + Nothing + + +{- ********************************************************************* +* * + The "push rules" +* * +************************************************************************ + +Here we implement the "push rules" from FC papers: + +* The push-argument rules, where we can move a coercion past an argument. + We have + (fun |> co) arg + and we want to transform it to + (fun arg') |> co' + for some suitable co' and transformed arg'. + +* The PushK rule for data constructors. We have + (K e1 .. en) |> co + and we want to transform to + (K e1' .. en') + by pushing the coercion into the arguments +-} + +pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) +pushCoArgs co [] = return ([], MCo co) +pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg + ; case m_co1 of + MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args + ; return (arg':args', m_co2) } + MRefl -> return (arg':args, MRefl) } + +pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +-- We have (fun |> co) arg, and we want to transform it to +-- (fun arg) |> co +-- This may fail, e.g. if (fun :: N) where N is a newtype +-- C.f. simplCast in GHC.Core.Opt.Simplify +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive +pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty + ; return (Type ty', m_co') } +pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co + ; return (val_arg `mkCast` arg_co, m_co') } + +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) +-- We have (fun |> co) @ty +-- Push the coercion through to return +-- (fun @ty') |> co' +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive; +-- it's faster not to compute it, though. +pushCoTyArg co ty + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (ty, Nothing) + + | isReflCo co + = Just (ty, MRefl) + + | isForAllTy_ty tyL + = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty ) + Just (ty `mkCastTy` co1, MCo co2) + + | otherwise + = Nothing + where + Pair tyL tyR = coercionKind co + -- co :: tyL ~ tyR + -- tyL = forall (a1 :: k1). ty1 + -- tyR = forall (a2 :: k2). ty2 + + co1 = mkSymCo (mkNthCo Nominal 0 co) + -- co1 :: k2 ~N k1 + -- Note that NthCo can extract a Nominal equality between the + -- kinds of the types related by a coercion between forall-types. + -- See the NthCo case in GHC.Core.Lint. + + co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) + -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] + -- Arg of mkInstCo is always nominal, hence mkNomReflCo + +pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion) +-- We have (fun |> co) arg +-- Push the coercion through to return +-- (fun (arg |> co_arg)) |> co_res +-- 'co' is always Representational +-- If the second returned Coercion is actually Nothing, then no cast is necessary; +-- the returned coercion would have been reflexive. +pushCoValArg co + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (mkRepReflCo arg, Nothing) + + | isReflCo co + = Just (mkRepReflCo arg, MRefl) + + | isFunTy tyL + , (co_mult, co1, co2) <- decomposeFunCo Representational co + , isReflexiveCo co_mult + -- We can't push the coercion in the case where co_mult isn't reflexivity: + -- it could be an unsafe axiom, and losing this information could yield + -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x) + -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int + -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed + + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) + -- then co1 :: tyL1 ~ tyR1 + -- co2 :: tyL2 ~ tyR2 + = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) + Just (mkSymCo co1, MCo co2) + + | otherwise + = Nothing + where + arg = funArgTy tyR + Pair tyL tyR = coercionKind co + +pushCoercionIntoLambda + :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) +-- This implements the Push rule from the paper on coercions +-- (\x. e) |> co +-- ===> +-- (\x'. e |> co') +pushCoercionIntoLambda in_scope x e co + | ASSERT(not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind co + , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2 + , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2 + , (co_mult, co1, co2) <- decomposeFunCo Representational co + , isReflexiveCo co_mult + -- We can't push the coercion in the case where co_mult isn't + -- reflexivity. See pushCoValArg for more details. + = let + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 `setIdMult` w1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') co1) + in Just (x', substExpr subst e `mkCast` co2) + | otherwise + = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) + Nothing + +pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion + -> Maybe (DataCon + , [Type] -- Universal type args + , [CoreExpr]) -- All other args incl existentials +-- Implement the KPush reduction rule as described in "Down with kinds" +-- The transformation applies iff we have +-- (C e1 ... en) `cast` co +-- where co :: (T t1 .. tn) ~ to_ty +-- The left-hand one must be a T, because exprIsConApp returned True +-- but the right-hand one might not be. (Though it usually will.) +pushCoDataCon dc dc_args co + | isReflCo co || from_ty `eqType` to_ty -- try cheap test first + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, map exprToType univ_ty_args, rest_args) + + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there's nothing wrong with it + + = let + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc + arg_tys = dataConRepArgTys dc + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args + + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx Representational + dc_univ_tyvars + omegas + dc_ex_tcvars + (map exprToType ex_args) + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + + to_ex_args = map Type to_ex_arg_tys + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, + ppr arg_tys, ppr dc_args, + ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc + , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] + in + ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) + Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + + | otherwise + = Nothing + + where + Pair from_ty to_ty = coercionKind co + +collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) +-- Collect lambda binders, pushing coercions inside if possible +-- E.g. (\x.e) |> g g :: -> blah +-- = (\x. e |> Nth 1 g) +-- +-- That is, +-- +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) +collectBindersPushingCo e + = go [] e + where + -- Peel off lambdas until we hit a cast. + go :: [Var] -> CoreExpr -> ([Var], CoreExpr) + -- The accumulator is in reverse order + go bs (Lam b e) = go (b:bs) e + go bs (Cast e co) = go_c bs e co + go bs e = (reverse bs, e) + + -- We are in a cast; peel off casts until we hit a lambda. + go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_c bs e c) is same as (go bs e (e |> c)) + go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) + go_c bs (Lam b e) co = go_lam bs b e co + go_c bs e co = (reverse bs, mkCast e co) + + -- We are in a lambda under a cast; peel off lambdas and build a + -- new coercion for the body. + go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) + go_lam bs b e co + | isTyVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy_ty tyL ) + isForAllTy_ty tyR + , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + + | isCoVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy_co tyL ) + isForAllTy_co tyR + , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + , let cov = mkCoVarCo b + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) + + | isId b + , let Pair tyL tyR = coercionKind co + , ASSERT( isFunTy tyL) isFunTy tyR + , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co + , isReflCo co_mult -- See Note [collectBindersPushingCo] + , isReflCo co_arg -- See Note [collectBindersPushingCo] + = go_c (b:bs) e co_res + + | otherwise = (reverse bs, mkCast (Lam b e) co) + +{- + +Note [collectBindersPushingCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We just look for coercions of form + # w -> blah +(and similarly for foralls) to keep this function simple. We could do +more elaborate stuff, but it'd involve substitution etc. + +-} diff --git a/GHC/Core/Stats.hs b/GHC/Core/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Stats.hs @@ -0,0 +1,137 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-2015 +-} + +-- | Functions to computing the statistics reflective of the "size" +-- of a Core expression +module GHC.Core.Stats ( + -- * Expression and bindings size + coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, exprStats, + ) where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Core +import GHC.Utils.Outputable +import GHC.Core.Coercion +import GHC.Types.Var +import GHC.Core.Type(Type, typeSize) +import GHC.Types.Id (isJoinId) + +data CoreStats = CS { cs_tm :: !Int -- Terms + , cs_ty :: !Int -- Types + , cs_co :: !Int -- Coercions + , cs_vb :: !Int -- Local value bindings + , cs_jb :: !Int } -- Local join bindings + + +instance Outputable CoreStats where + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 }) + = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, + text "types:" <+> intWithCommas i2 <> comma, + text "coercions:" <+> intWithCommas i3 <> comma, + text "joins:" <+> intWithCommas i5 <> char '/' <> + intWithCommas (i4 + i5) ]) + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2 + , cs_jb = j1+j2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldl' (\s a -> plusCS s (f a)) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS (bindStats TopLevel) + +bindStats :: TopLevelFlag -> CoreBind -> CoreStats +bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r +bindStats top_lvl (Rec prs) = sumCS (\(v,r) -> bindingStats top_lvl v r) prs + +bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats +bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +letBndrStats :: TopLevelFlag -> Var -> CoreStats +letBndrStats top_lvl v + | isTyVar v || isTopLevel top_lvl = bndrStats v + | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats + | otherwise = oneTM { cs_vb = 1 } `plusCS` ty_stats + where + ty_stats = tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats NotTopLevel b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b + `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Tick _ e) = exprStats e + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r + +altBndrStats :: [Var] -> CoreStats +-- Charge one for the alternative, not for each binder +altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = coercionSize co } + +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +coreBindsSize bs = sum (map bindSize bs) + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var _) = 1 +exprSize (Lit _) = 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = bndrSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b _ as) = exprSize e + bndrSize b + 1 + sum (map altSize as) +exprSize (Cast e _) = 1 + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type _) = 1 +exprSize (Coercion _) = 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote _ _ _) = 1 +tickSize _ = 1 + +bndrSize :: Var -> Int +bndrSize _ = 1 + +bndrsSize :: [Var] -> Int +bndrsSize = sum . map bndrSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = bndrSize b + exprSize e +bindSize (Rec prs) = sum (map pairSize prs) + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = bndrSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (_,bs,e) = bndrsSize bs + exprSize e diff --git a/GHC/Core/Subst.hs b/GHC/Core/Subst.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Subst.hs @@ -0,0 +1,760 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Core.Subst ( + -- * Main data types + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, + + -- ** Substituting into expressions and related types + deShadowBinds, substSpec, substRulesForImportedIds, + substTy, substCo, substExpr, substExprSC, substBind, substBindSC, + substUnfolding, substUnfoldingSC, + lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc, + substTickish, substDVarSet, substIdInfo, + + -- ** Operations on substitutions + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, + extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, + isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, + delBndr, delBndrs, + + -- ** Substituting and cloning binders + substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, + cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + ) where + +#include "HsVersions.h" + + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Seq +import GHC.Core.Utils +import qualified GHC.Core.Type as Type +import qualified GHC.Core.Coercion as Coercion + + -- We are defining local versions +import GHC.Core.Type hiding + ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) + +import GHC.Builtin.Names +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Name ( Name ) +import GHC.Types.Var +import GHC.Types.Id.Info +import GHC.Types.Unique.Supply +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable +import Data.List + + + +{- +************************************************************************ +* * +\subsection{Substitutions} +* * +************************************************************************ +-} + +-- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' +-- substitutions. +-- +-- Some invariants apply to how you use the substitution: +-- +-- 1. Note [The substitution invariant] in "GHC.Core.TyCo.Subst" +-- +-- 2. Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" +data Subst + = Subst InScopeSet -- Variables in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution from NcIds to CoreExprs + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from CoVars to Coercions + + -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] + -- This is what lets us deal with name capture properly + -- It's a hard invariant to check... + -- + -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with + -- Types.TvSubstEnv + -- + -- INVARIANT 3: See Note [Extending the Subst] + +{- +Note [Extending the Subst] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a core Subst, which binds Ids as well, we make a different choice for Ids +than we do for TyVars. + +For TyVars, see Note [Extending the TCvSubst] in GHC.Core.TyCo.Subst. + +For Ids, we have a different invariant + The IdSubstEnv is extended *only* when the Unique on an Id changes + Otherwise, we just extend the InScopeSet + +In consequence: + +* If all subst envs are empty, substExpr would be a + no-op, so substExprSC ("short cut") does nothing. + + However, substExpr still goes ahead and substitutes. Reason: we may + want to replace existing Ids with new ones from the in-scope set, to + avoid space leaks. + +* In substIdBndr, we extend the IdSubstEnv only when the unique changes + +* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, + substExpr does nothing (Note that the above rule for substIdBndr + maintains this property. If the incoming envts are both empty, then + substituting the type and IdInfo can't change anything.) + +* In lookupIdSubst, we *must* look up the Id in the in-scope set, because + it may contain non-trivial changes. Example: + (/\a. \x:a. ...x...) Int + We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change + so we only extend the in-scope set. Then we must look up in the in-scope + set when we find the occurrence of x. + +* The requirement to look up the Id in the in-scope set means that we + must NOT take no-op short cut when the IdSubst is empty. + We must still look up every Id in the in-scope set. + +* (However, we don't need to do so for expressions found in the IdSubst + itself, whose range is assumed to be correct wrt the in-scope set.) + +Why do we make a different choice for the IdSubstEnv than the +TvSubstEnv and CvSubstEnv? + +* For Ids, we change the IdInfo all the time (e.g. deleting the + unfolding), and adding it back later, so using the TyVar convention + would entail extending the substitution almost all the time + +* The simplifier wants to look up in the in-scope set anyway, in case it + can see a better unfolding from an enclosing case expression + +* For TyVars, only coercion variables can possibly change, and they are + easy to spot +-} + +-- | An environment for substituting for 'Id's +type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions + +---------------------------- +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv + +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs + +-- | Find the in-scope set: see "GHC.Core.TyCo.Subst" Note [The substitution invariant] +substInScope :: Subst -> InScopeSet +substInScope (Subst in_scope _ _ _) = in_scope + +-- | Remove all substitutions for 'Id's and 'Var's that might have been built up +-- while preserving the in-scope set +zapSubstEnv :: Subst -> Subst +zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is +-- such that TyCoSubst Note [The substitution invariant] +-- holds after extending the substitution like this +extendIdSubst :: Subst -> Id -> CoreExpr -> Subst +-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set +extendIdSubst (Subst in_scope ids tvs cvs) v r + = ASSERT2( isNonCoVarId v, ppr v $$ ppr r ) + Subst in_scope (extendVarEnv ids v r) tvs cvs + +-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' +extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst +extendIdSubstList (Subst in_scope ids tvs cvs) prs + = ASSERT( all (isNonCoVarId . fst) prs ) + Subst in_scope (extendVarEnvList ids prs) tvs cvs + +-- | Add a substitution for a 'TyVar' to the 'Subst' +-- The 'TyVar' *must* be a real TyVar, and not a CoVar +-- You must ensure that the in-scope set is such that +-- "GHC.Core.TyCo.Subst" Note [The substitution invariant] holds +-- after extending the substitution like this. +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) tv ty + = ASSERT( isTyVar tv ) + Subst in_scope ids (extendVarEnv tvs tv ty) cvs + +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList subst vrs + = foldl' extend subst vrs + where + extend subst (v, r) = extendTvSubst subst v r + +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': +-- you must ensure that the in-scope set satisfies +-- "GHC.Core.TyCo.Subst" Note [The substitution invariant] +-- after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r + = ASSERT( isCoVar v ) + Subst in_scope ids tvs (extendVarEnv cvs v r) + +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' +extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst subst var arg + = case arg of + Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty + Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co + _ -> ASSERT( isId var ) extendIdSubst subst var arg + +extendSubstWithVar :: Subst -> Var -> Var -> Subst +extendSubstWithVar subst v1 v2 + | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) + | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) + | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) + +-- | Add a substitution as appropriate to each of the terms being +-- substituted (whether expressions, types, or coercions). See also +-- 'extendSubst'. +extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst +extendSubstList subst [] = subst +extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs + +-- | Find the substitution for an 'Id' in the 'Subst' +lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr +lookupIdSubst (Subst in_scope ids _ _) v + | not (isLocalId v) = Var v + | Just e <- lookupVarEnv ids v = e + | Just v' <- lookupInScope in_scope v = Var v' + -- Vital! See Note [Extending the Subst] + | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v + $$ ppr in_scope) + Var v + +-- | Find the substitution for a 'TyVar' in the 'Subst' +lookupTCvSubst :: Subst -> TyVar -> Type +lookupTCvSubst (Subst _ _ tvs cvs) v + | isTyVar v + = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + | otherwise + = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v + +delBndr :: Subst -> Var -> Subst +delBndr (Subst in_scope ids tvs cvs) v + | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) + | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs + | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs + +delBndrs :: Subst -> [Var] -> Subst +delBndrs (Subst in_scope ids tvs cvs) vs + = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) + -- Easiest thing is just delete all from all! + +-- | Simultaneously substitute for a bunch of variables +-- No left-right shadowing +-- ie the substitution for (\x \y. e) a1 a2 +-- so neither x nor y scope over a1 a2 +mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst +mkOpenSubst in_scope pairs = Subst in_scope + (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) + (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) + +------------------------------ +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope + +-- | Add the 'Var' to the in-scope set, but do not remove +-- any existing substitutions for it +addInScopeSet :: Subst -> VarSet -> Subst +addInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs + +-- | Add the 'Var' to the in-scope set: as a side effect, +-- and remove any existing substitutions for it +extendInScope :: Subst -> Var -> Subst +extendInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendInScopeList :: Subst -> [Var] -> Subst +extendInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) + +-- | Optimized version of 'extendInScopeList' that can be used if you are certain +-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's +extendInScopeIds :: Subst -> [Id] -> Subst +extendInScopeIds (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) tvs cvs + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs + +-- Pretty printing, for debugging only + +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = text " in_scope_doc + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs + <> char '>' + where + in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) + +{- +************************************************************************ +* * + Substituting expressions +* * +************************************************************************ +-} + +substExprSC :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr +-- Just like substExpr, but a no-op if the substitution is empty +substExprSC subst orig_expr + | isEmptySubst subst = orig_expr + | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ + substExpr subst orig_expr + +-- | substExpr applies a substitution to an entire 'CoreExpr'. Remember, +-- you may only apply the substitution /once/: +-- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" +-- +-- Do *not* attempt to short-cut in the case of an empty substitution! +-- See Note [Extending the Subst] +substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr + -- HasDebugCallStack so we can track failures in lookupIdSubst +substExpr subst expr + = go expr + where + go (Var v) = lookupIdSubst subst v + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (substCo subst co) + go (Lit lit) = Lit lit + go (App fun arg) = App (go fun) (go arg) + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) = Cast (go e) (substCo subst co) + -- Do not optimise even identity coercions + -- Reason: substitution applies to the LHS of RULES, and + -- if you "optimise" an identity coercion, you may + -- lose a binder. We optimise the LHS of rules at + -- construction time + + go (Lam bndr body) = Lam bndr' (substExpr subst' body) + where + (subst', bndr') = substBndr subst bndr + + go (Let bind body) = Let bind' (substExpr subst' body) + where + (subst', bind') = substBind subst bind + + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + where + (subst', bndr') = substBndr subst bndr + + go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + +-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' +-- that should be used by subsequent substitutions. +substBind, substBindSC :: HasDebugCallStack => Subst -> CoreBind -> (Subst, CoreBind) + +substBindSC subst bind -- Short-cut if the substitution is empty + | not (isEmptySubst subst) + = substBind subst bind + | otherwise + = case bind of + NonRec bndr rhs -> (subst', NonRec bndr' rhs) + where + (subst', bndr') = substBndr subst bndr + Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' | isEmptySubst subst' + = rhss + | otherwise + = map (substExpr subst') rhss + +substBind subst (NonRec bndr rhs) + = (subst', NonRec bndr' (substExpr subst rhs)) + where + (subst', bndr') = substBndr subst bndr + +substBind subst (Rec pairs) + = (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' = map (substExpr subst') rhss + +-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply +-- by running over the bindings with an empty substitution, because substitution +-- returns a result that has no-shadowing guaranteed. +-- +-- (Actually, within a single /type/ there might still be shadowing, because +-- 'substTy' is a no-op for the empty substitution, but that's probably OK.) +-- +-- [Aug 09] This function is not used in GHC at the moment, but seems so +-- short and simple that I'm going to leave it here +deShadowBinds :: CoreProgram -> CoreProgram +deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) + +{- +************************************************************************ +* * + Substituting binders +* * +************************************************************************ + +Remember that substBndr and friends are used when doing expression +substitution only. Their only business is substitution, so they +preserve all IdInfo (suitably substituted). For example, we *want* to +preserve occ info in rules. +-} + +-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning +-- the result and an updated 'Subst' that should be used by subsequent substitutions. +-- 'IdInfo' is preserved by this process, although it is substituted into appropriately. +substBndr :: Subst -> Var -> (Subst, Var) +substBndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = substIdBndr (text "var-bndr") subst subst bndr + +-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right +substBndrs :: Subst -> [Var] -> (Subst, [Var]) +substBndrs subst bndrs = mapAccumL substBndr subst bndrs + +-- | Substitute in a mutually recursive group of 'Id's +substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +substRecBndrs subst bndrs + = (new_subst, new_bndrs) + where -- Here's the reason we need to pass rec_subst to subst_id + (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs + +substIdBndr :: SDoc + -> Subst -- ^ Substitution to use for the IdInfo + -> Subst -> Id -- ^ Substitution and Id to transform + -> (Subst, Id) -- ^ Transformed pair + -- NB: unfolding may be zapped + +substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id + = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ + (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) + where + id1 = uniqAway in_scope old_id -- id1 is cloned if necessary + id2 | no_type_change = id1 + | otherwise = updateIdTypeAndMult (substTy subst) id1 + + old_ty = idType old_id + old_w = idMult old_id + no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) + + -- new_id has the right IdInfo + -- The lazy-set is because we're in a loop here, with + -- rec_subst, when dealing with a mutually-recursive group + new_id = maybeModifyIdInfo mb_new_info id2 + mb_new_info = substIdInfo rec_subst id2 (idInfo id2) + -- NB: unfolding info may be zapped + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) + + no_change = id1 == old_id + -- See Note [Extending the Subst] + -- it's /not/ necessary to check mb_new_info and no_type_change + +{- +Now a variant that unconditionally allocates a new unique. +It also unconditionally zaps the OccInfo. +-} + +-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for +-- each variable in its output. It substitutes the IdInfo though. +cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) +cloneIdBndr subst us old_id + = clone_id subst subst (old_id, uniqFromSupply us) + +-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final +-- substitution from left to right +cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneIdBndrs subst us ids + = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) + +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrs subst us vs + = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) + +cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) +cloneBndr subst uniq v + | isTyVar v = cloneTyVarBndr subst v uniq + | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too + +-- | Clone a mutually recursive group of 'Id's +cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneRecIdBndrs subst us ids + = (subst', ids') + where + (subst', ids') = mapAccumL (clone_id subst') subst + (ids `zip` uniqsFromSupply us) + +-- Just like substIdBndr, except that it always makes a new unique +-- It is given the unique to use +clone_id :: Subst -- Substitution for the IdInfo + -> Subst -> (Id, Unique) -- Substitution and Id to transform + -> (Subst, Id) -- Transformed pair + +clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) + where + id1 = setVarUnique old_id uniq + id2 = substIdType subst id1 + new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 + (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) + | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) + +{- +************************************************************************ +* * + Types and Coercions +* * +************************************************************************ + +For types and coercions we just call the corresponding functions in +Type and Coercion, but we have to repackage the substitution, from a +Subst to a TCvSubst. +-} + +substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv + = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') + +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq + = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') + +substCoVarBndr :: Subst -> CoVar -> (Subst, CoVar) +substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv + = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of + (TCvSubst in_scope' tv_env' cv_env', cv') + -> (Subst in_scope' id_env tv_env' cv_env', cv') + +-- | See 'Type.substTy' +substTy :: Subst -> Type -> Type +substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty + +getTCvSubst :: Subst -> TCvSubst +getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv + +-- | See 'Coercion.substCo' +substCo :: HasCallStack => Subst -> Coercion -> Coercion +substCo subst co = Coercion.substCo (getTCvSubst subst) co + +{- +************************************************************************ +* * +\section{IdInfo substitution} +* * +************************************************************************ +-} + +substIdType :: Subst -> Id -> Id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id + | otherwise = + updateIdTypeAndMult (substTy subst) id + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + old_w = varMult id + +------------------ +-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo +substIdInfo subst new_id info + | nothing_to_do = Nothing + | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules + `setUnfoldingInfo` substUnfolding subst old_unf) + where + old_rules = ruleInfo info + old_unf = unfoldingInfo info + nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf) + +------------------ +-- | Substitutes for the 'Id's within an unfolding +substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding + -- Seq'ing on the returned Unfolding is enough to cause + -- all the substitutions to happen completely + +substUnfoldingSC subst unf -- Short-cut version + | isEmptySubst subst = unf + | otherwise = substUnfolding subst unf + +substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = args' } + where + (subst',bndrs') = substBndrs subst bndrs + args' = map (substExpr subst') args + +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) + -- Retain an InlineRule! + | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work + = NoUnfolding + | otherwise -- But keep a stable one! + = seqExpr new_tmpl `seq` + unf { uf_tmpl = new_tmpl } + where + new_tmpl = substExpr subst tmpl + +substUnfolding _ unf = unf -- NoUnfolding, OtherCon + +------------------ +substIdOcc :: Subst -> Id -> Id +-- These Ids should not be substituted to non-Ids +substIdOcc subst v = case lookupIdSubst subst v of + Var v' -> v' + other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) + +------------------ +-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' +substSpec :: Subst -> Id -> RuleInfo -> RuleInfo +substSpec subst new_id (RuleInfo rules rhs_fvs) + = seqRuleInfo new_spec `seq` new_spec + where + subst_ru_fn = const (idName new_id) + new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules) + (substDVarSet subst rhs_fvs) + +------------------ +substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] +substRulesForImportedIds subst rules + = map (substRule subst not_needed) rules + where + not_needed name = pprPanic "substRulesForImportedIds" (ppr name) + +------------------ +substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id +substRule _ _ rule@(BuiltinRule {}) = rule +substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_local = is_local }) + = rule { ru_bndrs = bndrs' + , ru_fn = if is_local + then subst_ru_fn fn_name + else fn_name + , ru_args = map (substExpr subst') args + , ru_rhs = substExpr subst' rhs } + -- Do NOT optimise the RHS (previously we did simplOptExpr here) + -- See Note [Substitute lazily] + where + (subst', bndrs') = substBndrs subst bndrs + +------------------ +substDVarSet :: Subst -> DVarSet -> DVarSet +substDVarSet subst fvs + = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs + where + subst_fv subst fv acc + | isId fv = expr_fvs (lookupIdSubst subst fv) isLocalVar emptyVarSet $! acc + | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc + +------------------ +substTickish :: Subst -> Tickish Id -> Tickish Id +substTickish subst (Breakpoint n ids) + = Breakpoint n (map do_one ids) + where + do_one = getIdFromTrivialExpr . lookupIdSubst subst +substTickish _subst other = other + +{- Note [Substitute lazily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions that substitute over IdInfo must be pretty lazy, because +they are knot-tied by substRecBndrs. + +One case in point was #10627 in which a rule for a function 'f' +referred to 'f' (at a different type) on the RHS. But instead of just +substituting in the rhs of the rule, we were calling simpleOptExpr, which +looked at the idInfo for 'f'; result <>. + +In any case we don't need to optimise the RHS of rules, or unfoldings, +because the simplifier will do that. + + +Note [substTickish] +~~~~~~~~~~~~~~~~~~~~~~ +A Breakpoint contains a list of Ids. What happens if we ever want to +substitute an expression for one of these Ids? + +First, we ensure that we only ever substitute trivial expressions for +these Ids, by marking them as NoOccInfo in the occurrence analyser. +Then, when substituting for the Id, we unwrap any type applications +and abstractions to get back to an Id, with getIdFromTrivialExpr. + +Second, we have to ensure that we never try to substitute a literal +for an Id in a breakpoint. We ensure this by never storing an Id with +an unlifted type in a Breakpoint - see GHC.HsToCore.Coverage.mkTickish. +Breakpoints can't handle free variables with unlifted types anyway. +-} + +{- +Note [Worker inlining] +~~~~~~~~~~~~~~~~~~~~~~ +A worker can get substituted away entirely. + - it might be trivial + - it might simply be very small +We do not treat an InlWrapper as an 'occurrence' in the occurrence +analyser, so it's possible that the worker is not even in scope any more. + +In all these cases we simply drop the special case, returning to +InlVanilla. The WARN is just so I can see if it happens a lot. +-} diff --git a/GHC/Core/Tidy.hs b/GHC/Core/Tidy.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Tidy.hs @@ -0,0 +1,289 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +This module contains "tidying" code for *nested* expressions, bindings, rules. +The code for *top-level* bindings is in GHC.Iface.Tidy. +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Core.Tidy ( + tidyExpr, tidyRules, tidyUnfolding + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Seq ( seqUnfolding ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand ( zapUsageEnvSig ) +import GHC.Core.Type ( tidyType, tidyVarBndr ) +import GHC.Core.Coercion ( tidyCo ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Unique (getUnique) +import GHC.Types.Unique.FM +import GHC.Types.Name hiding (tidyNameOcc) +import GHC.Types.SrcLoc +import GHC.Data.Maybe +import Data.List + +{- +************************************************************************ +* * +\subsection{Tidying expressions, rules} +* * +************************************************************************ +-} + +tidyBind :: TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyBind env (NonRec bndr rhs) + = tidyLetBndr env env bndr =: \ (env', bndr') -> + (env', NonRec bndr' (tidyExpr env' rhs)) + +tidyBind env (Rec prs) + = let + (bndrs, rhss) = unzip prs + (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs + in + map (tidyExpr env') rhss =: \ rhss' -> + (env', Rec (zip bndrs' rhss')) + + +------------ Expressions -------------- +tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) +tidyExpr _ (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) + +tidyExpr env (Let b e) + = tidyBind env b =: \ (env', b') -> + Let b' (tidyExpr env' e) + +tidyExpr env (Case e b ty alts) + = tidyBndr env b =: \ (env', b) -> + Case (tidyExpr env e) b (tidyType env ty) + (map (tidyAlt env') alts) + +tidyExpr env (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) + +------------ Case alternatives -------------- +tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt +tidyAlt env (con, vs, rhs) + = tidyBndrs env vs =: \ (env', vs) -> + (con, vs, tidyExpr env' rhs) + +------------ Tickish -------------- +tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id +tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) +tidyTickish _ other_tickish = other_tickish + +------------ Rules -------------- +tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] +tidyRules _ [] = [] +tidyRules env (rule : rules) + = tidyRule env rule =: \ rule -> + tidyRules env rules =: \ rules -> + (rule : rules) + +tidyRule :: TidyEnv -> CoreRule -> CoreRule +tidyRule _ rule@(BuiltinRule {}) = rule +tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, + ru_fn = fn, ru_rough = mb_ns }) + = tidyBndrs env bndrs =: \ (env', bndrs) -> + map (tidyExpr env') args =: \ args -> + rule { ru_bndrs = bndrs, ru_args = args, + ru_rhs = tidyExpr env' rhs, + ru_fn = tidyNameOcc env fn, + ru_rough = map (fmap (tidyNameOcc env')) mb_ns } + +{- +************************************************************************ +* * +\subsection{Tidying non-top-level binders} +* * +************************************************************************ +-} + +tidyNameOcc :: TidyEnv -> Name -> Name +-- In rules and instances, we have Names, and we must tidy them too +-- Fortunately, we can lookup in the VarEnv with a name +tidyNameOcc (_, var_env) n = case lookupUFM_Directly var_env (getUnique n) of + Nothing -> n + Just v -> idName v + +tidyVarOcc :: TidyEnv -> Var -> Var +tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v + +-- tidyBndr is used for lambda and case binders +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) +tidyBndr env var + | isTyCoVar var = tidyVarBndr env var + | otherwise = tidyIdBndr env var + +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars + +-- Non-top-level variables, not covars +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + mult' = tidyType env (idMult id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' mult' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + -- see Note [Preserve OneShotInfo] + `setOneShotInfo` oneShotInfo old_info + old_info = idInfo id + old_unf = unfoldingInfo old_info + new_unf = zapUnfolding old_unf -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + +tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings + -> TidyEnv -- The one to extend + -> Id -> (TidyEnv, Id) +-- Used for local (non-top-level) let(rec)s +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + mult' = tidyType env (idMult id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + details = idDetails id + id' = mkLocalVar details name' mult' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + -- We need to keep around any interesting strictness and + -- demand info because later on we may need to use it when + -- converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + -- But: Remove the usage demand here + -- (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Opt.WorkWrap) + -- + -- Similarly arity info for eta expansion in CorePrep + -- Don't attempt to recompute arity here; this is just tidying! + -- Trying to do so led to #17294 + -- + -- Set inline-prag info so that we preserve it across + -- separate compilation boundaries + old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` arityInfo old_info + `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + old_unf = unfoldingInfo old_info + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = zapUnfolding old_unf + -- See Note [Preserve evaluatedness] + + in + ((tidy_env', var_env'), id') } + +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding +tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + +tidyUnfolding tidy_env + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + unf_from_rhs + | isStableSource src + = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo + -- This seqIt avoids a space leak: otherwise the uf_is_value, + -- uf_is_conlike, ... fields may retain a reference to the + -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them) + + | otherwise + = unf_from_rhs + where seqIt unf = seqUnfolding unf `seq` unf +tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon + +{- +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and InlineRules, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + +Note [Preserve OneShotInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We keep the OneShotInfo because we want it to propagate into the interface. +Not all OneShotInfo is determined by a compiler analysis; some is added by a +call of GHC.Exts.oneShot, which is then discarded before the end of the +optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we +must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make. + +This applies to lambda binders only, hence it is stored in IfaceLamBndr. +-} + +(=:) :: a -> (a -> b) -> b +m =: k = m `seq` k m diff --git a/GHC/Core/TyCo/FVs.hs b/GHC/Core/TyCo/FVs.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/FVs.hs @@ -0,0 +1,992 @@ +{-# LANGUAGE CPP #-} + +module GHC.Core.TyCo.FVs + ( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, + + tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoFVsOfType, tyCoVarsOfTypeList, + tyCoFVsOfTypes, tyCoVarsOfTypesList, + deepTcvFolder, + + shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, + + shallowTyCoVarsOfCo, shallowTyCoVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfMCo, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCoDSet, + tyCoFVsOfCo, tyCoFVsOfCos, + tyCoVarsOfCoList, + + almostDevoidCoVarOfCo, + + -- Injective free vars + injectiveVarsOfType, injectiveVarsOfTypes, + invisibleVarsOfType, invisibleVarsOfTypes, + + -- No Free vars + noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + + -- * Well-scoped free variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- * Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Raw materials + Endo(..), runTyCoVars + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) + +import Data.Monoid as DM ( Endo(..), All(..) ) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Types.Var +import GHC.Utils.FV + +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Misc +import GHC.Utils.Panic + +{- +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +{- Note [Shallow and deep free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Definitions + +* Shallow free variables of a type: the variables + affected by substitution. Specifically, the (TyVarTy tv) + and (CoVar cv) that appear + - In the type and coercions appearing in the type + - In shallow free variables of the kind of a Forall binder + but NOT in the kind of the /occurrences/ of a type variable. + +* Deep free variables of a type: shallow free variables, plus + the deep free variables of the kinds of those variables. + That is, deepFVs( t ) = closeOverKinds( shallowFVs( t ) ) + +Examples: + + Type Shallow Deep + --------------------------------- + (a : (k:Type)) {a} {a,k} + forall (a:(k:Type)). a {k} {k} + (a:k->Type) (b:k) {a,b} {a,b,k} +-} + + +{- Note [Free variables of types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns +a VarSet that is closed over the types of its variables. More precisely, + if S = tyCoVarsOfType( t ) + and (a:k) is in S + then tyCoVarsOftype( k ) is a subset of S + +Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. + +We could /not/ close over the kinds of the variable occurrences, and +instead do so at call sites, but it seems that we always want to do +so, so it's easiest to do it here. + +It turns out that getting the free variables of types is performance critical, +so we profiled several versions, exploring different implementation strategies. + +1. Baseline version: uses FV naively. Essentially: + + tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty + + This is not nice, because FV introduces some overhead to implement + determinism, and through its "interesting var" function, neither of which + we need here, so they are a complete waste. + +2. UnionVarSet version: instead of reusing the FV-based code, we simply used + VarSets directly, trying to avoid the overhead of FV. E.g.: + + -- FV version: + tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c + + -- UnionVarSet version: + tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) + + This looks deceptively similar, but while FV internally builds a list- and + set-generating function, the VarSet functions manipulate sets directly, and + the latter performs a lot worse than the naive FV version. + +3. Accumulator-style VarSet version: this is what we use now. We do use VarSet + as our data structure, but delegate the actual work to a new + ty_co_vars_of_... family of functions, which use accumulator style and the + "in-scope set" filter found in the internals of FV, but without the + determinism overhead. + +See #14880. + +Note [Closing over free variable kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over +free variable kinds. In previous GHC versions, this happened naively: whenever +we would encounter an occurrence of a free type variable, we would close over +its kind. This, however is wrong for two reasons (see #14880): + +1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then + we don't want to have to traverse k more than once. + +2. Correctness. Imagine we have forall k. b -> k, where b has + kind k, for some k bound in an outer scope. If we look at b's kind inside + the forall, we'll collect that k is free and then remove k from the set of + free variables. This is plain wrong. We must instead compute that b is free + and then conclude that b's kind is free. + +An obvious first approach is to move the closing-over-kinds from the +occurrences of a type variable to after finding the free vars - however, this +turns out to introduce performance regressions, and isn't even entirely +correct. + +In fact, it isn't even important *when* we close over kinds; what matters is +that we handle each type var exactly once, and that we do it in the right +context. + +So the next approach we tried was to use the "in-scope set" part of FV or the +equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to +say "don't bother with variables we have already closed over". This should work +fine in theory, but the code is complicated and doesn't perform well. + +But there is a simpler way, which is implemented here. Consider the two points +above: + +1. Efficiency: we now have an accumulator, so the second time we encounter 'a', + we'll ignore it, certainly not looking at its kind - this is why + pre-checking set membership before inserting ends up not only being faster, + but also being correct. + +2. Correctness: we have an "in-scope set" (I think we should call it it a + "bound-var set"), specifying variables that are bound by a forall in the type + we are traversing; we simply ignore these variables, certainly not looking at + their kind. + +So now consider: + + forall k. b -> k + +where b :: k->Type is free; but of course, it's a different k! When looking at +b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose +this is our first encounter with b; we want the free vars of its kind. But we +want to behave as if we took the free vars of its kind at the end; that is, +with no bound vars in scope. + +So the solution is easy. The old code was this: + + ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) + +Now all we need to do is take the free vars of tyVarKind v *with an empty +bound-var set*, thus: + +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) + ^^^^^^^^^^^ + +And that's it. This works because a variable is either bound or free. If it is bound, +then we won't look at it at all. If it is free, then all the variables free in its +kind are free -- regardless of whether some local variable has the same Unique. +So if we're looking at a variable occurrence at all, then all variables in its +kind are free. +-} + +{- ********************************************************************* +* * + Endo for free variables +* * +********************************************************************* -} + +{- Note [Acumulating parameter free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can use foldType to build an accumulating-parameter version of a +free-var finder, thus: + + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType folder ty) emptyVarSet + +Recall that + foldType :: TyCoFolder env a -> env -> Type -> a + + newtype Endo a = Endo (a -> a) -- In Data.Monoid + instance Monoid a => Monoid (Endo a) where + (Endo f) `mappend` (Endo g) = Endo (f.g) + + appEndo :: Endo a -> a -> a + appEndo (Endo f) x = f x + +So `mappend` for Endos is just function composition. + +It's very important that, after optimisation, we end up with +* an arity-three function +* that is strict in the accumulator + + fvs env (TyVarTy v) acc + | v `elemVarSet` env = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + fvs env (AppTy t1 t2) = fvs env t1 (fvs env t2 acc) + ... + +The "strict in the accumulator" part is to ensure that in the +AppTy equation we don't build a thunk for (fvs env t2 acc). + +The optimiser does do all this, but not very robustly. It depends +critially on the basic arity-2 function not being exported, so that +all its calls are visibly to three arguments. This analysis is +done by the Call Arity pass. + +TL;DR: check this regularly! +-} + +runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet +{-# INLINE runTyCoVars #-} +runTyCoVars f = appEndo f emptyVarSet + +noView :: Type -> Maybe Type +noView _ = Nothing + +{- ********************************************************************* +* * + Deep free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + +tyCoVarsOfType :: Type -> TyCoVarSet +tyCoVarsOfType ty = runTyCoVars (deep_ty ty) +-- Alternative: +-- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty) + +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys) +-- Alternative: +-- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +-- See Note [Free variables of Coercions] +tyCoVarsOfCo co = runTyCoVars (deep_co co) + +tyCoVarsOfMCo :: MCoercion -> TyCoVarSet +tyCoVarsOfMCo MRefl = emptyVarSet +tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = runTyCoVars (deep_cos cos) + +deep_ty :: Type -> Endo TyCoVarSet +deep_tys :: [Type] -> Endo TyCoVarSet +deep_co :: Coercion -> Endo TyCoVarSet +deep_cos :: [Coercion] -> Endo TyCoVarSet +(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet + +deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +deepTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_tcv is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + +{- ********************************************************************* +* * + Shallow free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + + +shallowTyCoVarsOfType :: Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty) + +shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet +shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys) + +shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet +shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co) + +shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet +shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos) + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet +shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallow_ty :: Type -> Endo TyCoVarSet +shallow_tys :: [Type] -> Endo TyCoVarSet +shallow_co :: Coercion -> Endo TyCoVarSet +shallow_cos :: [Coercion] -> Endo TyCoVarSet +(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet + +shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +shallowTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole _ _ = mempty -- Ignore coercion holes + + +{- ********************************************************************* +* * + Free coercion variables +* * +********************************************************************* -} + + +{- Note [Finding free coercion varibles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here we are only interested in the free /coercion/ variables. +We can achieve this through a slightly differnet TyCo folder. + +Notice that we look deeply, into kinds. + +See #14880. +-} + +coVarsOfType :: Type -> CoVarSet +coVarsOfTypes :: [Type] -> CoVarSet +coVarsOfCo :: Coercion -> CoVarSet +coVarsOfCos :: [Coercion] -> CoVarSet + +coVarsOfType ty = runTyCoVars (deep_cv_ty ty) +coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys) +coVarsOfCo co = runTyCoVars (deep_cv_co co) +coVarsOfCos cos = runTyCoVars (deep_cv_cos cos) + +deep_cv_ty :: Type -> Endo CoVarSet +deep_cv_tys :: [Type] -> Endo CoVarSet +deep_cv_co :: Coercion -> Endo CoVarSet +deep_cv_cos :: [Coercion] -> Endo CoVarSet +(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet + +deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) +deepCoVarFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tyvar, tcf_covar = do_covar + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tyvar _ _ = mempty + -- This do_tyvar means we won't see any CoVars in this + -- TyVar's kind. This may be wrong; but it's the way it's + -- always been. And its awkward to change, because + -- the tyvar won't end up in the accumulator, so + -- we'd look repeatedly. Blargh. + + do_covar is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_cv_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_covar is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + + +{- ********************************************************************* +* * + Closing over kinds +* * +********************************************************************* -} + +------------- Closing over kinds ----------------- + +closeOverKinds :: TyCoVarSet -> TyCoVarSet +-- For each element of the input set, +-- add the deep free variables of its kind +closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs + where + do_one v acc = appEndo (deep_ty (varType v)) acc + +{- --------------- Alternative version 1 (using FV) ------------ +closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet +-} + +{- ---------------- Alternative version 2 ------------- + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyCoVarSet -> TyCoVarSet +closeOverKinds vs + = go vs vs + where + go :: VarSet -- Work list + -> VarSet -- Accumulator, always a superset of wl + -> VarSet + go wl acc + | isEmptyVarSet wl = acc + | otherwise = go wl_kvs (acc `unionVarSet` wl_kvs) + where + k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc + wl_kvs = nonDetFoldVarSet k emptyVarSet wl + -- wl_kvs = union of shallow free vars of the kinds of wl + -- but don't bother to collect vars in acc + +-} + +{- ---------------- Alternative version 3 ------------- +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyVarSet -> TyVarSet +closeOverKinds vs = close_over_kinds vs emptyVarSet + + +close_over_kinds :: TyVarSet -- Work list + -> TyVarSet -- Accumulator + -> TyVarSet +-- Precondition: in any call (close_over_kinds wl acc) +-- for every tv in acc, the shallow kind-vars of tv +-- are either in the work list wl, or in acc +-- Postcondition: result is the deep free vars of (wl `union` acc) +close_over_kinds wl acc + = nonDetFoldVarSet do_one acc wl + where + do_one :: Var -> TyVarSet -> TyVarSet + -- (do_one v acc) adds v and its deep free-vars to acc + do_one v acc | v `elemVarSet` acc + = acc + | otherwise + = close_over_kinds (shallowTyCoVarsOfType (varType v)) $ + acc `extendVarSet` v +-} + + +{- ********************************************************************* +* * + The FV versions return deterministic results +* * +********************************************************************* -} + +-- | Given a list of tyvars returns a deterministic FV computation that +-- returns the given tyvars with the kind variables free in the kinds of the +-- given tyvars. +closeOverKindsFV :: [TyVar] -> FV +closeOverKindsFV tvs = + mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministically ordered list. +closeOverKindsList :: [TyVar] -> [TyVar] +closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems + +-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty + +-- | `tyCoFVsOfType` that returns free variables of a type in deterministic +-- order. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfTypeList :: Type -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys + +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesList :: [Type] -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys + +-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. +-- The previous implementation used `unionVarSet` which is O(n+m) and can +-- make the function quadratic. +-- It's exported, so that it can be composed with +-- other functions that compute free variables. +-- See Note [FV naming conventions] in "GHC.Utils.FV". +-- +-- Eta-expanded because that makes it run faster (apparently) +-- See Note [FV eta expansion] in "GHC.Utils.FV" for explanation. +tyCoFVsOfType :: Type -> FV +-- See Note [Free variables of types] +tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) + | not (f v) = (acc_list, acc_set) + | v `elemVarSet` bound_vars = (acc_list, acc_set) + | v `elemVarSet` acc_set = (acc_list, acc_set) + | otherwise = tyCoFVsOfType (tyVarKind v) f + emptyVarSet -- See Note [Closing over free variable kinds] + (v:acc_list, extendVarSet acc_set v) +tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc +tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc +tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc +tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc +tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc +tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc +tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc + +tyCoFVsBndr :: TyCoVarBinder -> FV -> FV +-- Free vars of (forall b. ) +tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs + +tyCoFVsVarBndrs :: [Var] -> FV -> FV +tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars + +tyCoFVsVarBndr :: Var -> FV -> FV +tyCoFVsVarBndr var fvs + = tyCoFVsOfType (varType var) -- Free vars of its type/kind + `unionFV` delFV var fvs -- Delete it from the thing-inside + +tyCoFVsOfTypes :: [Type] -> FV +-- See Note [Free variables of types] +tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc +tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co + +tyCoFVsOfMCo :: MCoercion -> FV +tyCoFVsOfMCo MRefl = emptyFV +tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co + +tyCoFVsOfCo :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +-- See Note [Free variables of types] +tyCoFVsOfCo (Refl ty) fv_cand in_scope acc + = tyCoFVsOfType ty fv_cand in_scope acc +tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc + = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc +tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc + = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc + = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc +tyCoFVsOfCo (FunCo _ w co1 co2) fv_cand in_scope acc + = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc +tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc + = tyCoFVsOfCoVar v fv_cand in_scope acc +tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc + = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc + -- See Note [CoercionHoles and coercion free variables] +tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc + = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc +tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc + +tyCoFVsOfCoVar :: CoVar -> FV +tyCoFVsOfCoVar v fv_cand in_scope acc + = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc + +tyCoFVsOfProv :: UnivCoProvenance -> FV +tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfProv CorePrepProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +tyCoFVsOfCos :: [Coercion] -> FV +tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc + + +----- Whether a covar is /Almost Devoid/ in a type or coercion ---- + +-- | Given a covar and a coercion, returns True if covar is almost devoid in +-- the coercion. That is, covar can only appear in Refl and GRefl. +-- See last wrinkle in Note [Unused coercion variable in ForAllCo] in "GHC.Core.Coercion" +almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool +almostDevoidCoVarOfCo cv co = + almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool +almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and +almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into + -- the coercions +almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (AppCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv + = almost_devoid_co_var_of_co kind_co cv + && (v == cv || almost_devoid_co_var_of_co co cv) +almost_devoid_co_var_of_co (FunCo _ w co1 co2) cv + = almost_devoid_co_var_of_co w cv + && almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv +almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv +almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv + = almost_devoid_co_var_of_prov p cv + && almost_devoid_co_var_of_type t1 cv + && almost_devoid_co_var_of_type t2 cv +almost_devoid_co_var_of_co (SymCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (TransCo co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (NthCo _ _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (LRCo _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (InstCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (KindCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (SubCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv + = almost_devoid_co_var_of_cos cs cv + +almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool +almost_devoid_co_var_of_cos [] _ = True +almost_devoid_co_var_of_cos (co:cos) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_cos cos cv + +almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool +almost_devoid_co_var_of_prov (PhantomProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (ProofIrrelProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (PluginProv _) _ = True +almost_devoid_co_var_of_prov CorePrepProv _ = True + +almost_devoid_co_var_of_type :: Type -> CoVar -> Bool +almost_devoid_co_var_of_type (TyVarTy _) _ = True +almost_devoid_co_var_of_type (TyConApp _ tys) cv + = almost_devoid_co_var_of_types tys cv +almost_devoid_co_var_of_type (LitTy {}) _ = True +almost_devoid_co_var_of_type (AppTy fun arg) cv + = almost_devoid_co_var_of_type fun cv + && almost_devoid_co_var_of_type arg cv +almost_devoid_co_var_of_type (FunTy _ w arg res) cv + = almost_devoid_co_var_of_type w cv + && almost_devoid_co_var_of_type arg cv + && almost_devoid_co_var_of_type res cv +almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv + = almost_devoid_co_var_of_type (varType v) cv + && (v == cv || almost_devoid_co_var_of_type ty cv) +almost_devoid_co_var_of_type (CastTy ty co) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_type (CoercionTy co) cv + = almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool +almost_devoid_co_var_of_types [] _ = True +almost_devoid_co_var_of_types (ty:tys) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_types tys cv + + + +{- ********************************************************************* +* * + Injective free vars +* * +********************************************************************* -} + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- +-- For example, if @F@ is a non-injective type family, then: +-- +-- @ +-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} +-- @ +-- +-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. +-- More formally, if +-- @a@ is in @'injectiveVarsOfType' ty@ +-- and @S1(ty) ~ S2(ty)@, +-- then @S1(a) ~ S2(a)@, +-- where @S1@ and @S2@ are arbitrary substitutions. +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in "GHC.Tc.Instance.Family". + -> Type -> FV +injectiveVarsOfType look_under_tfs = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = + case tyConInjectivityInfo tc of + Injective inj + | look_under_tfs || not (isTypeFamilyTyCon tc) + -> mapUnionFV go $ + filterByList (inj ++ repeat True) tys + -- Oversaturated arguments to a tycon are + -- always injective, hence the repeat True + _ -> emptyFV + go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) + go LitTy{} = emptyFV + go (CastTy ty _) = go ty + go CoercionTy{} = emptyFV + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfTypes :: Bool -- ^ look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in "GHC.Tc.Instance.Family". + -> [Type] -> FV +injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs) + + +{- ********************************************************************* +* * + Invisible vars +* * +********************************************************************* -} + + +-- | Returns the set of variables that are used invisibly anywhere within +-- the given type. A variable will be included even if it is used both visibly +-- and invisibly. An invisible use site includes: +-- * In the kind of a variable +-- * In the kind of a bound variable in a forall +-- * In a coercion +-- * In a Specified or Inferred argument to a function +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +invisibleVarsOfType :: Type -> FV +invisibleVarsOfType = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` + invisibleVarsOfTypes visibles + where (invisibles, visibles) = partitionInvisibleTypes tc tys + go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty + go LitTy{} = emptyFV + go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty + go (CoercionTy co) = tyCoFVsOfCo co + +-- | Like 'invisibleVarsOfType', but for many types. +invisibleVarsOfTypes :: [Type] -> FV +invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType + + +{- ********************************************************************* +* * + No free vars +* * +********************************************************************* -} + +nfvFolder :: TyCoFolder TyCoVarSet DM.All +nfvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is tv = All (tv `elemVarSet` is) + do_hole _ _ = All True -- I'm unsure; probably never happens + do_bndr is tv _ = is `extendVarSet` tv + +nfv_ty :: Type -> DM.All +nfv_tys :: [Type] -> DM.All +nfv_co :: Coercion -> DM.All +(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet + +noFreeVarsOfType :: Type -> Bool +noFreeVarsOfType ty = DM.getAll (nfv_ty ty) + +noFreeVarsOfTypes :: [Type] -> Bool +noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys) + +noFreeVarsOfCo :: Coercion -> Bool +noFreeVarsOfCo co = getAll (nfv_co co) + + +{- ********************************************************************* +* * + scopedSort +* * +********************************************************************* -} + +{- Note [ScopedSort] +~~~~~~~~~~~~~~~~~~~~ +Consider + + foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () + +This function type is implicitly generalised over [a, b, k, k2]. These +variables will be Specified; that is, they will be available for visible +type application. This is because they are written in the type signature +by the user. + +However, we must ask: what order will they appear in? In cases without +dependency, this is easy: we just use the lexical left-to-right ordering +of first occurrence. With dependency, we cannot get off the hook so +easily. + +We thus state: + + * These variables appear in the order as given by ScopedSort, where + the input to ScopedSort is the left-to-right order of first occurrence. + +Note that this applies only to *implicit* quantification, without a +`forall`. If the user writes a `forall`, then we just use the order given. + +ScopedSort is defined thusly (as proposed in #15743): + * Work left-to-right through the input list, with a cursor. + * If variable v at the cursor is depended on by any earlier variable w, + move v immediately before the leftmost such w. + +INVARIANT: The prefix of variables before the cursor form a valid telescope. + +Note that ScopedSort makes sense only after type inference is done and all +types/kinds are fully settled and zonked. + +-} + +-- | Do a topological sort on a list of tyvars, +-- so that binders occur before occurrences +-- E.g. given [ a::k, k::*, b::k ] +-- it'll return a well-scoped list [ k::*, a::k, b::k ] +-- +-- This is a deterministic sorting operation +-- (that is, doesn't depend on Uniques). +-- +-- It is also meant to be stable: that is, variables should not +-- be reordered unnecessarily. This is specified in Note [ScopedSort] +-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType" + +scopedSort :: [TyCoVar] -> [TyCoVar] +scopedSort = go [] [] + where + go :: [TyCoVar] -- already sorted, in reverse order + -> [TyCoVarSet] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + + -> [TyCoVar] -- yet to be sorted + -> [TyCoVar] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: TyCoVar -- var to insert + -> [TyCoVar] -- sorted list, in reverse order + -> [TyCoVarSet] -- list of fvs, as above + -> ([TyCoVar], [TyCoVarSet]) -- augmented lists + insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) + insert tv (a:as) (fvs:fvss) + | tv `elemVarSet` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `unionVarSet` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) + where + fv_tv = tyCoVarsOfType (tyVarKind tv) + + -- lists not in correspondence + insert _ _ _ = panic "scopedSort" + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList + +-- | Get the free vars of types in scoped order +tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] +tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + diff --git a/GHC/Core/TyCo/Ppr.hs b/GHC/Core/TyCo/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Ppr.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | Pretty-printing types and coercions. +module GHC.Core.TyCo.Ppr + ( + -- * Precedence + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + + -- * Pretty-printing types + pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX, + pprTypeApp, pprTCvBndr, pprTCvBndrs, + pprSigmaType, + pprTheta, pprParendTheta, pprForAll, pprUserForAll, + pprTyVar, pprTyVars, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + pprDataCons, pprWithExplicitKindsWhen, + pprWithTYPE, pprSourceTyCon, + + + -- * Pretty-printing coercions + pprCo, pprParendCo, + + debugPprType, + + -- * Pretty-printing 'TyThing's + pprTyThingCategory, pprShortTyThing, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.CoreToIface + ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr + , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) + +import {-# SOURCE #-} GHC.Core.DataCon + ( dataConFullSig , dataConUserTyVarBinders + , DataCon ) + +import GHC.Core.Type ( isLiftedTypeKind, pattern One, pattern Many ) + +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs +import GHC.Core.Class +import GHC.Types.Var + +import GHC.Iface.Type + +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec + , funPrec, appPrec, maybeParen ) + +{- +%************************************************************************ +%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * +%************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note that any function which pretty-prints a @Type@ first converts the @Type@ +to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type. + +See Note [Precedence in types] in GHC.Types.Basic. +-} + +-------------------------------------------------------- +-- When pretty-printing types, we convert to IfaceType, +-- and pretty-print that. +-- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing +-------------------------------------------------------- + +pprType, pprParendType, pprTidiedType :: Type -> SDoc +pprType = pprPrecType topPrec +pprParendType = pprPrecType appPrec + +-- already pre-tidied +pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet + +pprPrecType :: PprPrec -> Type -> SDoc +pprPrecType = pprPrecTypeX emptyTidyEnv + +pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc +pprPrecTypeX env prec ty + = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if debug -- Use debugPprType when in + then debug_ppr_ty prec ty -- when in debug-style + else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) + -- NB: debug-style is used for -dppr-debug + -- dump-style is used for -ddump-tc-trace etc + +pprTyLit :: TyLit -> SDoc +pprTyLit = pprIfaceTyLit . toIfaceTyLit + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX env ty sty + | userStyle sty = tidyToIfaceTypeX env ty + | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceType :: Type -> IfaceType +tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv + +tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceTypeX to +-- leave them as IfaceFreeTyVar. This is super-important +-- for debug printing. +tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) + where + env' = tidyFreeTyCoVars env free_tcvs + free_tcvs = tyCoVarsOfTypeWellScoped ty + +------------ +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) +pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) + +tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion +tidyToIfaceCoSty co sty + | userStyle sty = tidyToIfaceCo co + | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceCo :: Coercion -> IfaceCoercion +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceCoercionX to +-- leave them as IfaceFreeCoVar. This is super-important +-- for debug printing. +tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) + where + env = tidyFreeTyCoVars emptyTidyEnv free_tcvs + free_tcvs = scopedSort $ tyCoVarsOfCoList co +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta = pprIfaceContext topPrec . map tidyToIfaceType + +pprParendTheta :: ThetaType -> SDoc +pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType + +------------------ +pprSigmaType :: Type -> SDoc +pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType + +pprForAll :: [TyCoVarBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) + +-- | Print a user-level forall; see @Note [When to print foralls]@ in +-- "GHC.Iface.Type". +pprUserForAll :: [TyCoVarBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr + +pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs tvs = sep (map pprTCvBndr tvs) + +pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr = pprTyVar . binderVar + +pprTyVars :: [TyVar] -> SDoc +pprTyVars tvs = sep (map pprTyVar tvs) + +pprTyVar :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +-- Here we do not go via IfaceType, because the duplication with +-- pprIfaceTvBndr is minimal, and the loss of uniques etc in +-- debug printing is disastrous +pprTyVar tv + | isLiftedTypeKind kind = ppr tv + | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) + where + kind = tyVarKind tv + +----------------- +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty topPrec ty + +debug_ppr_ty :: PprPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr l + +debug_ppr_ty _ (TyVarTy tv) + = ppr tv -- With -dppr-debug we get (tv :: kind) + +debug_ppr_ty prec ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) + = maybeParen prec funPrec $ + sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res] + where + arr = case af of + VisArg -> case mult of + One -> lollipop + Many -> arrow + w -> mulArrow (ppr w) + InvisArg -> case mult of + Many -> darrow + _ -> pprPanic "unexpected multiplicity" (ppr ty) + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec appPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) + +debug_ppr_ty _ (AppTy t1 t2) + = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) + 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish + -- TyConApp from AppTy + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec topPrec $ + hang (debug_ppr_ty topPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +debug_ppr_ty prec ty@(ForAllTy {}) + | (tvs, body) <- split ty + = maybeParen prec funPrec $ + hang (text "forall" <+> fsep (map ppr tvs) <> dot) + -- The (map ppr tvs) will print kind-annotated + -- tvs, because we are (usually) in debug-style + 2 (ppr body) + where + split ty | ForAllTy tv ty' <- ty + , (tvs, body) <- split ty' + = (tv:tvs, body) + | otherwise + = ([], ty) + +{- +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See #2766. +-} + +pprDataCons :: TyCon -> SDoc +pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons + where + sepWithVBars [] = empty + sepWithVBars docs = sep (punctuate (space <> vbar) docs) + +pprDataConWithArgs :: DataCon -> SDoc +pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] + where + (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc + user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc + forAllDoc = pprUserForAll user_bndrs + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType (map scaledThing arg_tys)) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys + = pprIfaceTypeApp topPrec (toIfaceTyCon tc) + (toIfaceTcArgs tc tys) + -- TODO: toIfaceTcArgs seems rather wasteful here + +------------------ +-- | Display all kind information (with @-fprint-explicit-kinds@) when the +-- provided 'Bool' argument is 'True'. +-- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". +pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc +pprWithExplicitKindsWhen b + = updSDocContext $ \ctx -> + if b then ctx { sdocPrintExplicitKinds = True } + else ctx + +-- | This variant preserves any use of TYPE in a type, effectively +-- locally setting -fprint-explicit-runtime-reps. +pprWithTYPE :: Type -> SDoc +pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $ + ppr ty + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon diff --git a/GHC/Core/TyCo/Ppr.hs-boot b/GHC/Core/TyCo/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Ppr.hs-boot @@ -0,0 +1,11 @@ +module GHC.Core.TyCo.Ppr where + +import {-# SOURCE #-} GHC.Types.Var ( TyVar ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) +import GHC.Utils.Outputable ( SDoc ) + +pprType :: Type -> SDoc +pprKind :: Kind -> SDoc +pprCo :: Coercion -> SDoc +pprTyLit :: TyLit -> SDoc +pprTyVar :: TyVar -> SDoc diff --git a/GHC/Core/TyCo/Rep.hs b/GHC/Core/TyCo/Rep.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Rep.hs @@ -0,0 +1,2065 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +\section[GHC.Core.TyCo.Rep]{Type and Coercion - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + GHC.Core.Class + GHC.Core.Coercion.Axiom + GHC.Core.TyCon imports GHC.Core.{Class, Coercion.Axiom} + GHC.Core.TyCo.Rep imports GHC.Core.{Class, Coercion.Axiom, TyCon} + GHC.Core.TyCo.Ppr imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.FVs imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst imports GHC.Core.TyCo.{Rep, FVs, Ppr} + GHC.Core.TyCo.Tidy imports GHC.Core.TyCo.{Rep, FVs} + GHC.Builtin.Types.Prim imports GHC.Core.TyCo.Rep ( including mkTyConTy ) + GHC.Core.Coercion imports GHC.Core.Type +-} + +-- We expose the relevant stuff from this module via the Type module +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms, BangPatterns, DeriveDataTypeable #-} + +module GHC.Core.TyCo.Rep ( + TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, + + -- * Types + Type(..), + + TyLit(..), + KindOrType, Kind, + KnotTied, + PredType, ThetaType, -- Synonyms + ArgFlag(..), AnonArgFlag(..), + + -- * Coercions + Coercion(..), + UnivCoProvenance(..), + CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar, + CoercionN, CoercionR, CoercionP, KindCoercion, + MCoercion(..), MCoercionR, MCoercionN, + + -- * Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, + mkForAllTy, mkForAllTys, mkInvisForAllTys, + mkPiTy, mkPiTys, + mkFunTyMany, + mkScaledFunTy, + mkVisFunTyMany, mkVisFunTysMany, + mkInvisFunTyMany, mkInvisFunTysMany, + mkTyConApp, + + -- * Functions over binders + TyCoBinder(..), TyCoVarBinder, TyBinder, + binderVar, binderVars, binderType, binderArgFlag, + delBinderVar, + isInvisibleArgFlag, isVisibleArgFlag, + isInvisibleBinder, isVisibleBinder, + isTyBinder, isNamedBinder, + + -- * Functions over coercions + pickLR, + + -- ** Analyzing types + TyCoFolder(..), foldTyCo, + + -- * Sizes + typeSize, coercionSize, provSize, + + -- * Multiplicities + Scaled(..), scaledMult, scaledThing, mapScaledType, Mult + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) + + -- Transitively pulls in a LOT of stuff, better to break the loop + +import {-# SOURCE #-} GHC.Core.ConLike ( ConLike(..), conLikeName ) + +-- friends: +import GHC.Iface.Type +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom + +-- others +import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey ) +import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy ) +import GHC.Types.Basic ( LeftOrRight(..), pickLR ) +import GHC.Types.Unique ( hasKey ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.IORef ( IORef ) -- for CoercionHole + +{- +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in GHC.Builtin.Types.Prim. + +It is also SOURCE-imported into "GHC.Types.Name" + + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See "GHC.Tc.Utils.Env" for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + +instance Outputable TyThing where + ppr = pprShortTyThing + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = conLikeName cl + +pprShortTyThing :: TyThing -> SDoc +-- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details +pprShortTyThing thing + = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory = text . capitalise . tyThingCategory + +tyThingCategory :: TyThing -> String +tyThingCategory (ATyCon tc) + | isClassTyCon tc = "class" + | otherwise = "type constructor" +tyThingCategory (ACoAxiom _) = "coercion axiom" +tyThingCategory (AnId _) = "identifier" +tyThingCategory (AConLike (RealDataCon _)) = "data constructor" +tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" + + +{- ********************************************************************** +* * + Type +* * +********************************************************************** -} + +-- | The key representation of types within the compiler + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', + -- must be another 'AppTy', or 'TyVarTy' + -- See Note [Respecting definitional equality] \(EQ1) about the + -- no 'CastTy' requirement + -- + -- 2) Argument type + + | TyConApp + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated applications of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | ForAllTy + {-# UNPACK #-} !TyCoVarBinder + Type -- ^ A Π type. + -- INVARIANT: If the binder is a coercion variable, it must + -- be mentioned in the Type. See + -- Note [Unused coercion variable in ForAllTy] + + | FunTy -- ^ FUN m t1 t2 Very common, so an important special case + -- See Note [Function types] + { ft_af :: AnonArgFlag -- Is this (->) or (=>)? + , ft_mult :: Mult -- Multiplicity + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + KindCoercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never reflexive + -- INVARIANT: The Type is not a CastTy (use TransCo instead) + -- INVARIANT: The Type is not a ForAllTy over a type variable + -- See Note [Respecting definitional equality] \(EQ2), (EQ3), (EQ4) + + | CoercionTy + Coercion -- ^ Injection of a Coercion into a type + -- This should only ever be used in the RHS of an AppTy, + -- in the list of a TyConApp, when applying a promoted + -- GADT data constructor + + deriving Data.Data + +instance Outputable Type where + ppr = pprType + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data) + +instance Outputable TyLit where + ppr = pprTyLit + +{- Note [Function types] +~~~~~~~~~~~~~~~~~~~~~~~~ +FFunTy is the constructor for a function type. Lots of things to say +about it! + +* FFunTy is the data constructor, meaning "full function type". + +* The function type constructor (->) has kind + (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> Type LiftedRep + mkTyConApp ensure that we convert a saturated application + TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 + dropping the 'r1' and 'r2' arguments; they are easily recovered + from 't1' and 't2'. + +* For the time being its RuntimeRep quantifiers are left + inferred. This is to allow for it to evolve. + +* The ft_af field says whether or not this is an invisible argument + VisArg: t1 -> t2 Ordinary function type + InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, + i.e. t1 :: Constraint + See Note [Types for coercions, predicates, and evidence] + + This visibility info makes no difference in Core; it matters + only when we regard the type as a Haskell source type. + +* FunTy is a (unidirectional) pattern synonym that allows + positional pattern matching (FunTy arg res), ignoring the + ArgFlag. +-} + +{- ----------------------- + Commented out until the pattern match + checker can handle it; see #16185 + + For now we use the CPP macro #define FunTy FFunTy _ + (see HsVersions.h) to allow pattern matching on a + (positional) FunTy constructor. + +{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp + , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} + +-- | 'FunTy' is a (uni-directional) pattern synonym for the common +-- case where we want to match on the argument/result type, but +-- ignoring the AnonArgFlag +pattern FunTy :: Type -> Type -> Type +pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } + + End of commented out block +---------------------------------- -} + +{- Note [Types for coercions, predicates, and evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat differently: + + (a) Predicate types + Test: isPredTy + Binders: DictIds + Kind: Constraint + Examples: (Eq a), and (a ~ b) + + (b) Coercion types are primitive, unboxed equalities + Test: isCoVarTy + Binders: CoVars (can appear in coercions) + Kind: TYPE (TupleRep []) + Examples: (t1 ~# t2) or (t1 ~R# t2) + + (c) Evidence types is the type of evidence manipulated by + the type constraint solver. + Test: isEvVarType + Binders: EvVars + Kind: Constraint or TYPE (TupleRep []) + Examples: all coercion types and predicate types + +Coercion types and predicate types are mutually exclusive, +but evidence types are a superset of both. + +When treated as a user type, + + - Predicates (of kind Constraint) are invisible and are + implicitly instantiated + + - Coercion types, and non-pred evidence types (i.e. not + of kind Constrain), are just regular old types, are + visible, and are not implicitly instantiated. + +In a FunTy { ft_af = InvisArg }, the argument type is always +a Predicate type. + +Note [Constraints in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do we allow a type constructor to have a kind like + S :: Eq a => a -> Type + +No, we do not. Doing so would mean would need a TyConApp like + S @k @(d :: Eq k) (ty :: k) + and we have no way to build, or decompose, evidence like + (d :: Eq k) at the type level. + +But we admit one exception: equality. We /do/ allow, say, + MkT :: (a ~ b) => a -> b -> Type a b + +Why? Because we can, without much difficulty. Moreover +we can promote a GADT data constructor (see TyCon +Note [Promoted data constructors]), like + data GT a b where + MkGT : a -> a -> GT a a +so programmers might reasonably expect to be able to +promote MkT as well. + +How does this work? + +* In GHC.Tc.Validity.checkConstraintsOK we reject kinds that + have constraints other than (a~b) and (a~~b). + +* In Inst.tcInstInvisibleTyBinder we instantiate a call + of MkT by emitting + [W] co :: alpha ~# beta + and producing the elaborated term + MkT @alpha @beta (Eq# alpha beta co) + We don't generate a boxed "Wanted"; we generate only a + regular old /unboxed/ primitive-equality Wanted, and build + the box on the spot. + +* How can we get such a MkT? By promoting a GADT-style data + constructor + data T a b where + MkT :: (a~b) => a -> b -> T a b + See DataCon.mkPromotedDataCon + and Note [Promoted data constructors] in GHC.Core.TyCon + +* We support both homogeneous (~) and heterogeneous (~~) + equality. (See Note [The equality types story] + in GHC.Builtin.Types.Prim for a primer on these equality types.) + +* How do we prevent a MkT having an illegal constraint like + Eq a? We check for this at use-sites; see GHC.Tc.Gen.HsType.tcTyVar, + specifically dc_theta_illegal_constraint. + +* Notice that nothing special happens if + K :: (a ~# b) => blah + because (a ~# b) is not a predicate type, and is never + implicitly instantiated. (Mind you, it's not clear how you + could creates a type constructor with such a kind.) See + Note [Types for coercions, predicates, and evidence] + +* The existence of promoted MkT with an equality-constraint + argument is the (only) reason that the AnonTCB constructor + of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). + For example, when we promote the data constructor + MkT :: forall a b. (a~b) => a -> b -> T a b + we get a PromotedDataCon with tyConBinders + Bndr (a :: Type) (NamedTCB Inferred) + Bndr (b :: Type) (NamedTCB Inferred) + Bndr (_ :: a ~ b) (AnonTCB InvisArg) + Bndr (_ :: a) (AnonTCB VisArg)) + Bndr (_ :: b) (AnonTCB VisArg)) + +* One might reasonably wonder who *unpacks* these boxes once they are + made. After all, there is no type-level `case` construct. The + surprising answer is that no one ever does. Instead, if a GADT + constructor is used on the left-hand side of a type family equation, + that occurrence forces GHC to unify the types in question. For + example: + + data G a where + MkG :: G Bool + + type family F (x :: G a) :: a where + F MkG = False + + When checking the LHS `F MkG`, GHC sees the MkG constructor and then must + unify F's implicit parameter `a` with Bool. This succeeds, making the equation + + F Bool (MkG @Bool ) = False + + Note that we never need unpack the coercion. This is because type + family equations are *not* parametric in their kind variables. That + is, we could have just said + + type family H (x :: G a) :: a where + H _ = False + + The presence of False on the RHS also forces `a` to become Bool, + giving us + + H Bool _ = False + + The fact that any of this works stems from the lack of phase + separation between types and kinds (unlike the very present phase + separation between terms and types). + + Once we have the ability to pattern-match on types below top-level, + this will no longer cut it, but it seems fine for now. + + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + +Note [Non-trivial definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is Int |> <*> the same as Int? YES! In order to reduce headaches, +we decide that any reflexive casts in types are just ignored. +(Indeed they must be. See Note [Respecting definitional equality].) +More generally, the `eqType` function, which defines Core's type equality +relation, ignores casts and coercion arguments, as long as the +two types have the same kind. This allows us to be a little sloppier +in keeping track of coercions, which is a good thing. It also means +that eqType does not depend on eqCoercion, which is also a good thing. + +Why is this sensible? That is, why is something different than α-equivalence +appropriate for the implementation of eqType? + +Anything smaller than ~ and homogeneous is an appropriate definition for +equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any +expression of type τ can be transmuted to one of type σ at any point by +casting. The same is true of expressions of type σ. So in some sense, τ and σ +are interchangeable. + +But let's be more precise. If we examine the typing rules of FC (say, those in +https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) +there are several places where the same metavariable is used in two different +premises to a rule. (For example, see Ty_App.) There is an implicit equality +check here. What definition of equality should we use? By convention, we use +α-equivalence. Take any rule with one (or more) of these implicit equality +checks. Then there is an admissible rule that uses ~ instead of the implicit +check, adding in casts as appropriate. + +The only problem here is that ~ is heterogeneous. To make the kinds work out +in the admissible rule that uses ~, it is necessary to homogenize the +coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; +we use η |> kind η, which is homogeneous. + +The effect of this all is that eqType, the implementation of the implicit +equality check, can use any homogeneous relation that is smaller than ~, as +those rules must also be admissible. + +A more drawn out argument around all of this is presented in Section 7.2 of +Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). + +What would go wrong if we insisted on the casts matching? See the beginning of +Section 8 in the unpublished paper above. Theoretically, nothing at all goes +wrong. But in practical terms, getting the coercions right proved to be +nightmarish. And types would explode: during kind-checking, we often produce +reflexive kind coercions. When we try to cast by these, mkCastTy just discards +them. But if we used an eqType that distinguished between Int and Int |> <*>, +then we couldn't discard -- the output of kind-checking would be enormous, +and we would need enormous casts with lots of CoherenceCo's to straighten +them out. + +Would anything go wrong if eqType respected type families? No, not at all. But +that makes eqType rather hard to implement. + +Thus, the guideline for eqType is that it should be the largest +easy-to-implement relation that is still smaller than ~ and homogeneous. The +precise choice of relation is somewhat incidental, as long as the smart +constructors and destructors in Type respect whatever relation is chosen. + +Another helpful principle with eqType is this: + + (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. + +This principle also tells us that eqType must relate only types with the +same kinds. + +Note [Respecting definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Non-trivial definitional equality] introduces the property (EQ). +How is this upheld? + +Any function that pattern matches on all the constructors will have to +consider the possibility of CastTy. Presumably, those functions will handle +CastTy appropriately and we'll be OK. + +More dangerous are the splitXXX functions. Let's focus on splitTyConApp. +We don't want it to fail on (T a b c |> co). Happily, if we have + (T a b c |> co) `eqType` (T d e f) +then co must be reflexive. Why? eqType checks that the kinds are equal, as +well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). +By the kind check, we know that (T a b c |> co) and (T d e f) have the same +kind. So the only way that co could be non-reflexive is for (T a b c) to have +a different kind than (T d e f). But because T's kind is closed (all tycon kinds +are closed), the only way for this to happen is that one of the arguments has +to differ, leading to a contradiction. Thus, co is reflexive. + +Accordingly, by eliminating reflexive casts, splitTyConApp need not worry +about outermost casts to uphold (EQ). Eliminating reflexive casts is done +in mkCastTy. + +Unforunately, that's not the end of the story. Consider comparing + (T a b c) =? (T a b |> (co -> )) (c |> co) +These two types have the same kind (Type), but the left type is a TyConApp +while the right type is not. To handle this case, we say that the right-hand +type is ill-formed, requiring an AppTy never to have a casted TyConApp +on its left. It is easy enough to pull around the coercions to maintain +this invariant, as done in Type.mkAppTy. In the example above, trying to +form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). +Both the casts there are reflexive and will be dropped. Huzzah. + +This idea of pulling coercions to the right works for splitAppTy as well. + +However, there is one hiccup: it's possible that a coercion doesn't relate two +Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, +then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't +be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not +`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate +our (EQ) property. + +In order to detect reflexive casts reliably, we must make sure not +to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). + +One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. +The kind of the body is the same as the kind of the ForAllTy. Accordingly, + + ForAllTy tv (ty |> co) and (ForAllTy tv ty) |> co + +are `eqType`. But only the first can be split by splitForAllTy. So we forbid +the second form, instead pushing the coercion inside to get the first form. +This is done in mkCastTy. + +In sum, in order to uphold (EQ), we need the following invariants: + + (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable + cast is one that relates either a FunTy to a FunTy or a + ForAllTy to a ForAllTy. + (EQ2) No reflexive casts in CastTy. + (EQ3) No nested CastTys. + (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). + See Note [Weird typing rule for ForAllTy] + +These invariants are all documented above, in the declaration for Type. + +Note [Unused coercion variable in ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + \(co:t1 ~ t2). e + +What type should we give to this expression? + (1) forall (co:t1 ~ t2) -> t + (2) (t1 ~ t2) -> t + +If co is used in t, (1) should be the right choice. +if co is not used in t, we would like to have (1) and (2) equivalent. + +However, we want to keep eqType simple and don't want eqType (1) (2) to return +True in any case. + +We decide to always construct (2) if co is not used in t. + +Thus in mkLamType, we check whether the variable is a coercion +variable (of type (t1 ~# t2), and whether it is un-used in the +body. If so, it returns a FunTy instead of a ForAllTy. + +There are cases we want to skip the check. For example, the check is +unnecessary when it is known from the context that the input variable +is a type variable. In those cases, we use mkForAllTy. + +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the (truncated) typing rule for the dependent ForAllTy: + + inner : TYPE r + tyvar is not free in r + ---------------------------------------- + ForAllTy (Bndr tyvar vis) inner : TYPE r + +Note that the kind of `inner` is the kind of the overall ForAllTy. This is +necessary because every ForAllTy over a type variable is erased at runtime. +Thus the runtime representation of a ForAllTy (as encoded, via TYPE rep, in +the kind) must be the same as the representation of the body. We must check +for skolem-escape, though. The skolem-escape would prevent a definition like + + undefined :: forall (r :: RuntimeRep) (a :: TYPE r). a + +because the type's kind (TYPE r) mentions the out-of-scope r. Luckily, the real +type of undefined is + + undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + +and that HasCallStack constraint neatly sidesteps the potential skolem-escape +problem. + +If the bound variable is a coercion variable: + + inner : TYPE r + covar is free in inner + ------------------------------------ + ForAllTy (Bndr covar vis) inner : Type + +Here, the kind of the ForAllTy is just Type, because coercion abstractions +are *not* erased. The "covar is free in inner" premise is solely to maintain +the representation invariant documented in +Note [Unused coercion variable in ForAllTy]. Though there is surface similarity +between this free-var check and the one in the tyvar rule, these two restrictions +are truly unrelated. + +-} + +-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See +-- Note [Type checking recursive type and class declarations] in +-- "GHC.Tc.TyCl" +type KnotTied ty = ty + +{- ********************************************************************** +* * + TyCoBinder and ArgFlag +* * +********************************************************************** -} + +-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [TyCoBinders] +data TyCoBinder + = Named TyCoVarBinder -- A type-lambda binder + | Anon AnonArgFlag (Scaled Type) -- A term-lambda binder. Type here can be CoercionTy. + -- Visibility is determined by the AnonArgFlag + deriving Data.Data + +instance Outputable TyCoBinder where + ppr (Anon af ty) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + -- See Note [Explicit Case Statement for Specificity] + ppr (Named (Bndr v (Invisible spec))) = case spec of + SpecifiedSpec -> char '@' <> ppr v + InferredSpec -> braces (ppr v) + + +-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' +-- in the 'Named' field. +type TyBinder = TyCoBinder + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyCoVarBinder -> VarSet +delBinderVar vars (Bndr tv _) = vars `delVarSet` tv + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyCoBinder -> Bool +isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis +isInvisibleBinder (Anon InvisArg _) = True +isInvisibleBinder (Anon VisArg _) = False + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyCoBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + +isNamedBinder :: TyCoBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder (Anon {}) = False + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: TyCoBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +{- Note [TyCoBinders] +~~~~~~~~~~~~~~~~~~~ +A ForAllTy contains a TyCoVarBinder. But a type can be decomposed +to a telescope consisting of a [TyCoBinder] + +A TyCoBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * A non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + + +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. + Each TyCoVarBinder + Bndr a tvis + is equipped with tvis::ArgFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term +| tvis :: ArgFlag +| tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f +| tvis = Specified: f :: forall a. type Arg optional: f or f @Int +| tvis = Required: T :: forall k -> type Arg required: T * +| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* Inferred. Function defn, with signature (explicit forall), marked as inferred: + f4 :: forall {a}. a -> a; f4 x = x + So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because the user marked it as such, even though it does appear + in the user-written signature for f4 + +* Inferred/Specified. Function signature with inferred kind polymorphism. + f5 :: a b -> Int + So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int + Here 'k' is Inferred (it's not mentioned in the type), + but 'a' and 'b' are Specified. + +* Specified. Function signature with explicit kind polymorphism + f6 :: a (b :: k) -> Int + This time 'k' is Specified, because it is mentioned explicitly, + so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + const :: forall a b. a -> b -> a + + Inferred: like Specified, but every binder is written in braces: + f :: forall {k} (a:k). S k a -> Int + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* Inferred variables correspond to "generalized" variables from the + Visible Type Applications paper (ESOP'16). + +Note [No Required TyCoBinder in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Required foralls for term variables, including pattern +synonyms and data constructors. Why? Because then an application +would need a /compulsory/ type argument (possibly without an "@"?), +thus (f Int); and we don't have concrete syntax for that. + +We could change this decision, but Required, Named TyCoBinders are rare +anyway. (Most are Anons.) + +However the type of a term can (just about) have a required quantifier; +see Note [Required quantifiers in the type of a term] in GHC.Tc.Gen.Expr. +-} + + +{- ********************************************************************** +* * + PredType +* * +********************************************************************** -} + + +-- | A type of the form @p@ of constraint kind represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to +-- have this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + + +%************************************************************************ +%* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by GHC.Builtin.Types.Prim, +which in turn is imported by Type +-} + +mkTyVarTy :: TyVar -> Type +mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) + TyVarTy v + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +mkTyCoVarTy :: TyCoVar -> Type +mkTyCoVarTy v + | isTyVar v + = TyVarTy v + | otherwise + = CoercionTy (CoVarCo v) + +mkTyCoVarTys :: [TyCoVar] -> [Type] +mkTyCoVarTys = map mkTyCoVarTy + +infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`, + `mkInvisFunTyMany` -- Associates to the right + +mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type +mkFunTy af mult arg res = FunTy { ft_af = af + , ft_mult = mult + , ft_arg = arg + , ft_res = res } + +mkScaledFunTy :: AnonArgFlag -> Scaled Type -> Type -> Type +mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res + +mkVisFunTy, mkInvisFunTy :: Mult -> Type -> Type -> Type +mkVisFunTy = mkFunTy VisArg +mkInvisFunTy = mkFunTy InvisArg + +mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type +mkFunTyMany af = mkFunTy af manyDataConTy + +-- | Special, common, case: Arrow type with mult Many +mkVisFunTyMany :: Type -> Type -> Type +mkVisFunTyMany = mkVisFunTy manyDataConTy + +mkInvisFunTyMany :: Type -> Type -> Type +mkInvisFunTyMany = mkInvisFunTy manyDataConTy + +-- | Make nested arrow types +mkVisFunTys :: [Scaled Type] -> Type -> Type +mkVisFunTys tys ty = foldr (mkScaledFunTy VisArg) ty tys + +mkVisFunTysMany :: [Type] -> Type -> Type +mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys + +mkInvisFunTysMany :: [Type] -> Type -> Type +mkInvisFunTysMany tys ty = foldr mkInvisFunTyMany ty tys + +-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder +-- See Note [Unused coercion variable in ForAllTy] +mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type +mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty + +-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right +mkForAllTys :: [TyCoVarBinder] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + +-- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right +mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type +mkInvisForAllTys tyvars ty = foldr ForAllTy ty $ tyVarSpecToBinders tyvars + +mkPiTy :: TyCoBinder -> Type -> Type +mkPiTy (Anon af ty1) ty2 = mkScaledFunTy af ty1 ty2 +mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty + +mkPiTys :: [TyCoBinder] -> Type -> Type +mkPiTys tbs ty = foldr mkPiTy ty tbs + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon + , [w, _rep1,_rep2,ty1,ty2] <- tys + -- The FunTyCon (->) is always a visible one + = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } + + -- Note [mkTyConApp and Type] + | tycon `hasKey` liftedTypeKindTyConKey + = ASSERT2( null tys, ppr tycon $$ ppr tys ) + liftedTypeKindTyConApp + | tycon `hasKey` manyDataConKey + -- There are a lot of occurrences of 'Many' so it's a small optimisation to + -- avoid reboxing every time `mkTyConApp` is called. + = ASSERT2( null tys, ppr tycon $$ ppr tys ) + manyDataConTy + | otherwise + = TyConApp tycon tys + +-- This is a single, global definition of the type `Type` +-- Defined here so it is only allocated once. +-- See Note [mkTyConApp and Type] +liftedTypeKindTyConApp :: Type +liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] + +{- +Note [mkTyConApp and Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whilst benchmarking it was observed in #17292 that GHC allocated a lot +of `TyConApp` constructors. Upon further inspection a large number of these +TyConApp constructors were all duplicates of `Type` applied to no arguments. + +``` +(From a sample of 100000 TyConApp closures) +0x45f3523 - 28732 - `Type` +0x420b840702 - 9629 - generic type constructors +0x42055b7e46 - 9596 +0x420559b582 - 9511 +0x420bb15a1e - 9509 +0x420b86c6ba - 9501 +0x42055bac1e - 9496 +0x45e68fd - 538 - `TYPE ...` +``` + +Therefore in `mkTyConApp` we have a special case for `Type` to ensure that +only one `TyConApp 'Type []` closure is allocated during the course of +compilation. In order to avoid a potentially expensive series of checks in +`mkTyConApp` only this egregious case is special cased at the moment. +-} + +{- +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. + -- - P, N, and R stand for coercions of the given role + -- - e stands for a coercion of a specific unknown role + -- (think "role polymorphism") + -- - "e" stands for an explicit role parameter indicating role e. + -- - _ stands for a parameter that is not a Role or Coercion. + + -- These ones mirror the shape of types + = -- Refl :: _ -> N + -- A special case reflexivity for a very common case: Nominal reflexivity + -- If you need Representational, use (GRefl Representational ty MRefl) + -- not (SubCo (Refl ty)) + Refl Type -- See Note [Refl invariant] + + -- GRefl :: "e" -> _ -> Maybe N -> e + -- See Note [Generalized reflexive coercion] + | GRefl Role Type MCoercionN -- See Note [Refl invariant] + -- Use (Refl ty), not (GRefl Nominal ty MRefl) + -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + -- TyCon is never a saturated (->); use FunCo instead + + | AppCo Coercion CoercionN -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyCoVar KindCoercion Coercion + -- ForAllCo :: _ -> N -> e -> e + + | FunCo Role CoercionN Coercion Coercion -- lift FunTy + -- FunCo :: "e" -> N -> e -> e -> e + -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? + -- Because the AnonArgFlag has no impact on Core; it is only + -- there to guide implicit instantiation of Haskell source + -- types, and that is irrelevant for coercions, which are + -- Core-only. + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> ?? -> e + | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] + -- See also [CoAxiom index] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. + -- See [Coercion axioms applied to coercions] + -- The roles of the argument coercions are determined + -- by the cab_roles field of the relevant branch of the CoAxiom + + | AxiomRuleCo CoAxiomRule [Coercion] + -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + + | UnivCo UnivCoProvenance Role Type Type + -- :: _ -> "e" -> _ -> _ -> e + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- Using NthCo on a ForAllCo gives an N coercion always + -- See Note [NthCo and newtypes] + -- + -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) + -- That is: the role of the entire coercion is redundantly cached here. + -- See Note [NthCo Cached Roles] + + | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion CoercionN + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo CoercionN -- Turns a ~N into a ~R + -- :: N -> R + + | HoleCo CoercionHole -- ^ See Note [Coercion holes] + -- Only present during typechecking + deriving Data.Data + +type CoercionN = Coercion -- always nominal +type CoercionR = Coercion -- always representational +type CoercionP = Coercion -- always phantom +type KindCoercion = CoercionN -- always nominal + +instance Outputable Coercion where + ppr = pprCo + +-- | A semantically more meaningful type to represent what may or may not be a +-- useful 'Coercion'. +data MCoercion + = MRefl + -- A trivial Reflexivity coercion + | MCo Coercion + -- Other coercions + deriving Data.Data +type MCoercionR = MCoercion +type MCoercionN = MCoercion + +instance Outputable MCoercion where + ppr MRefl = text "MRefl" + ppr (MCo co) = text "MCo" <+> ppr co + +{- Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: Refl lifting + Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. + For example + (Refl T) (Refl a) (Refl b) is normalised (by mkAPpCo) to (Refl (T a b)). + + You might think that a consequences is: + Every identity coercion has Refl at the root + + But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int + etc. So the consequence is only true of coercions that + have no coercion variables. + +Invariant 2: TyConAppCo + An application of (Refl T) to some coercions, at least one of which is + NOT the identity, is normalised to TyConAppCo. (They may not be + fully saturated however.) TyConAppCo coercions (like all coercions + other than Refl) are NEVER the identity. + +Note [Generalized reflexive coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GRefl is a generalized reflexive coercion (see #15192). It wraps a kind +coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing +rules for GRefl: + + ty : k1 + ------------------------------------ + GRefl r ty MRefl: ty ~r ty + + ty : k1 co :: k1 ~ k2 + ------------------------------------ + GRefl r ty (MCo co) : ty ~r ty |> co + +Consider we have + + g1 :: s ~r t + s :: k1 + g2 :: k1 ~ k2 + +and we want to construct a coercions co which has type + + (s |> g2) ~r t + +We can define + + co = Sym (GRefl r s g2) ; g1 + +It is easy to see that + + Refl == GRefl Nominal ty MRefl :: ty ~n ty + +A nominal reflexive coercion is quite common, so we keep the special form Refl to +save allocation. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [CoAxiom index] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) + +The Int in the AxiomInstCo constructor is the 0-indexed number +of the chosen branch. + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky, +because the kinds of the bound tyvars can be different. + +The typing rule is: + + + kind_co : k1 ~ k2 + tv1:k1 |- co : t1 ~ t2 + ------------------------------------------------------------------- + ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ + all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) + +First, the TyCoVar stored in a ForAllCo is really an optimisation: this field +should be a Name, as its kind is redundant. Thinking of the field as a Name +is helpful in understanding what a ForAllCo means. +The kind of TyCoVar always matches the left-hand kind of the coercion. + +The idea is that kind_co gives the two kinds of the tyvar. See how, in the +conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + +Of course, a type variable can't have different kinds at the same time. So, +we arbitrarily prefer the first kind when using tv1 in the inner coercion +co, which shows that t1 equals t2. + +The last wrinkle is that we need to fix the kinds in the conclusion. In +t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of +the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with +(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it +mentions the same name with different kinds, but it *is* well-kinded, noting +that `(tv1:k2) |> sym kind_co` has kind k1. + +This all really would work storing just a Name in the ForAllCo. But we can't +add Names to, e.g., VarSets, and there generally is just an impedance mismatch +in a bunch of places. So we use tv1. When we need tv2, we can use +setTyVarKind. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + + type instance F Int = Bool -- Axiom axF : F Int ~N Bool + newtype Age = MkAge Int -- Axiom axAge : Age ~R Int + data Foo a = MkFoo a -- Role on Foo's parameter is Representational + +TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool + For (TyConAppCo Nominal) all arguments must have role Nominal. Why? + So that Foo Age ~N Foo Int does *not* hold. + +TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool +TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int + For (TyConAppCo Representational), all arguments must have the roles + corresponding to the result of tyConRoles on the TyCon. This is the + whole point of having roles on the TyCon to begin with. So, we can + have Foo Age ~R Foo Int, if Foo's parameter has role R. + + If a Representational TyConAppCo is over-saturated (which is otherwise fine), + the spill-over arguments must all be at Nominal. This corresponds to the + behavior for AppCo. + +TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool + All arguments must have role Phantom. This one isn't strictly + necessary for soundness, but this choice removes ambiguity. + +The rules here dictate the roles of the parameters to mkTyConAppCo +(should be checked by Lint). + +Note [NthCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +NthCo, we'll get out a representational coercion. That is: + + NthCo r 0 co :: forall a b. a ~R b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +NthCo to be used on newtypes if the internal coercion is representational. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +Note [NthCo Cached Roles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we cache the role of NthCo in the NthCo constructor? +Because computing role(Nth i co) involves figuring out that + + co :: T tys1 ~ T tys2 + +using coercionKind, and finding (coercionRole co), and then looking +at the tyConRoles of T. Avoiding bad asymptotic behaviour here means +we have to compute the kind and role of a coercion simultaneously, +which makes the code complicated and inefficient. + +This only happens for NthCo. Caching the role solves the problem, and +allows coercionKind and coercionRole to be simple. + +See #11735 + +Note [InstCo roles] +~~~~~~~~~~~~~~~~~~~ +Here is (essentially) the typing rule for InstCo: + +g :: (forall a. t1) ~r (forall a. t2) +w :: s1 ~N s2 +------------------------------- InstCo +InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) + +Note that the Coercion w *must* be nominal. This is necessary +because the variable a might be used in a "nominal position" +(that is, a place where role inference would require a nominal +role) in t1 or t2. If we allowed w to be representational, we +could get bogus equalities. + +A more nuanced treatment might be able to relax this condition +somewhat, by checking if t1 and/or t2 use their bound variables +in nominal ways. If not, having w be representational is OK. + + +%************************************************************************ +%* * + UnivCoProvenance +%* * +%************************************************************************ + +A UnivCo is a coercion whose proof does not directly express its role +and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof). + +The different kinds of UnivCo are described by UnivCoProvenance. Really +each is entirely separate, but they all share the need to represent their +role and kind, which is done in the UnivCo constructor. + +-} + +-- | For simplicity, we have just one UnivCo that represents a coercion from +-- some type to some other type, with (in general) no restrictions on the +-- type. The UnivCoProvenance specifies more exactly what the coercion really +-- is and why a program should (or shouldn't!) trust the coercion. +-- It is reasonable to consider each constructor of 'UnivCoProvenance' +-- as a totally independent coercion form; their only commonality is +-- that they don't tell you what types they coercion between. (That info +-- is in the 'UnivCo' constructor of 'Coercion'. +data UnivCoProvenance + = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions + + | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions + + | PluginProv String -- ^ From a plugin, which asserts that this coercion + -- is sound. The string is for the use of the plugin. + + | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Pprep + + deriving Data.Data + +instance Outputable UnivCoProvenance where + ppr (PhantomProv _) = text "(phantom)" + ppr (ProofIrrelProv _) = text "(proof irrel.)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + ppr CorePrepProv = text "(CorePrep)" + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { ch_co_var :: CoVar + -- See Note [CoercionHoles and coercion free variables] + + , ch_blocker :: BlockSubstFlag -- should this hole block substitution? + -- See (2a) in TcCanonical + -- Note [Equalities with incompatible kinds] + , ch_ref :: IORef (Maybe Coercion) + } + +data BlockSubstFlag = YesBlockSubst + | NoBlockSubst + +coHoleCoVar :: CoercionHole -> CoVar +coHoleCoVar = ch_co_var + +setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole +setCoHoleCoVar h cv = h { ch_co_var = cv } + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) + +instance Outputable BlockSubstFlag where + ppr YesBlockSubst = text "YesBlockSubst" + ppr NoBlockSubst = text "NoBlockSubst" + +{- Note [Phantom coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = T1 | T2 +Then we have + T s ~R T t +for any old s,t. The witness for this is (TyConAppCo T Rep co), +where (co :: s ~P t) is a phantom coercion built with PhantomProv. +The role of the UnivCo is always Phantom. The Coercion stored is the +(nominal) kind coercion between the types + kind(s) ~N kind (t) + +Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~ +During typechecking, constraint solving for type classes works by + - Generate an evidence Id, d7 :: Num a + - Wrap it in a Wanted constraint, [W] d7 :: Num a + - Use the evidence Id where the evidence is needed + - Solve the constraint later + - When solved, add an enclosing let-binding let d7 = .... in .... + which actually binds d7 to the (Num a) evidence + +For equality constraints we use a different strategy. See Note [The +equality types story] in GHC.Builtin.Types.Prim for background on equality constraints. + - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just + like type classes above. (Indeed, boxed equality constraints *are* classes.) + - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) + we use a different plan + +For unboxed equalities: + - Generate a CoercionHole, a mutable variable just like a unification + variable + - Wrap the CoercionHole in a Wanted constraint; see GHC.Tc.Utils.TcEvDest + - Use the CoercionHole in a Coercion, via HoleCo + - Solve the constraint later + - When solved, fill in the CoercionHole by side effect, instead of + doing the let-binding thing + +The main reason for all this is that there may be no good place to let-bind +the evidence for unboxed equalities: + + - We emit constraints for kind coercions, to be used to cast a + type's kind. These coercions then must be used in types. Because + they might appear in a top-level type, there is no place to bind + these (unlifted) coercions in the usual way. + + - A coercion for (forall a. t1) ~ (forall a. t2) will look like + forall a. (coercion for t1~t2) + But the coercion for (t1~t2) may mention 'a', and we don't have + let-bindings within coercions. We could add them, but coercion + holes are easier. + + - Moreover, nothing is lost from the lack of let-bindings. For + dictionaries want to achieve sharing to avoid recomoputing the + dictionary. But coercions are entirely erased, so there's little + benefit to sharing. Indeed, even if we had a let-binding, we + always inline types and coercions at every use site and drop the + binding. + +Other notes about HoleCo: + + * INVARIANT: CoercionHole and HoleCo are used only during type checking, + and should never appear in Core. Just like unification variables; a Type + can contain a TcTyVar, but only during type checking. If, one day, we + use type-level information to separate out forms that can appear during + type-checking vs forms that can appear in core proper, holes in Core will + be ruled out. + + * See Note [CoercionHoles and coercion free variables] + + * Coercion holes can be compared for equality like other coercions: + by looking at the types coerced. + + +Note [CoercionHoles and coercion free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why does a CoercionHole contain a CoVar, as well as reference to +fill in? Because we want to treat that CoVar as a free variable of +the coercion. See #14584, and Note [What prevents a +constraint from floating] in GHC.Tc.Solver, item (4): + + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + +Here co2 is a CoercionHole. But we /must/ know that it is free in +co1, because that's all that stops it floating outside the +implication. + + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIrrelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~ Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) + where + co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) + co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] +-} + + +{- ********************************************************************* +* * + foldType and foldCoercion +* * +********************************************************************* -} + +{- Note [foldType] +~~~~~~~~~~~~~~~~~~ +foldType is a bit more powerful than perhaps it looks: + +* You can fold with an accumulating parameter, via + TyCoFolder env (Endo a) + Recall newtype Endo a = Endo (a->a) + +* You can fold monadically with a monad M, via + TyCoFolder env (M a) + provided you have + instance .. => Monoid (M a) + +Note [mapType vs foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define foldType here, but mapType in module Type. Why? + +* foldType is used in GHC.Core.TyCo.FVs for finding free variables. + It's a very simple function that analyses a type, + but does not construct one. + +* mapType constructs new types, and so it needs to call + the "smart constructors", mkAppTy, mkCastTy, and so on. + These are sophisticated functions, and can't be defined + here in GHC.Core.TyCo.Rep. + +Note [Specialising foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inline foldType at every call site (there are not many), so that it +becomes specialised for the particular monoid *and* TyCoFolder at +that site. This is just for efficiency, but walking over types is +done a *lot* in GHC, so worth optimising. + +We were worried that + TyCoFolder env (Endo a) +might not eta-expand. Recall newtype Endo a = Endo (a->a). + +In particular, given + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet + + tcf :: TyCoFolder enf (Endo a) + tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` tv + + +we want to end up with + fvs ty = go emptyVarSet ty emptyVarSet + where + go env (TyVarTy tv) acc = acc `extendVarSet` tv + ..etc.. + +And indeed this happens. + - Selections from 'tcf' are done at compile time + - 'go' is nicely eta-expanded. + +We were also worried about + deep_fvs :: Type -> TyCoVarSet + deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet + + deep_tcf :: TyCoFolder enf (Endo a) + deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = deep_fvs (varType tv) + `unionVarSet` acc + `extendVarSet` tv + +Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf. +But, amazingly, we get good code here too. GHC is careful not to makr +TyCoFolder data constructor for deep_tcf as a loop breaker, so the +record selections still cancel. And eta expansion still happens too. +-} + +data TyCoFolder env a + = TyCoFolder + { tcf_view :: Type -> Maybe Type -- Optional "view" function + -- E.g. expand synonyms + , tcf_tyvar :: env -> TyVar -> a + , tcf_covar :: env -> CoVar -> a + , tcf_hole :: env -> CoercionHole -> a + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". + + , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env + -- ^ The returned env is used in the extended scope + } + +{-# INLINE foldTyCo #-} -- See Note [Specialising foldType] +foldTyCo :: Monoid a => TyCoFolder env a -> env + -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a) +foldTyCo (TyCoFolder { tcf_view = view + , tcf_tyvar = tyvar + , tcf_tycobinder = tycobinder + , tcf_covar = covar + , tcf_hole = cohole }) env + = (go_ty env, go_tys env, go_co env, go_cos env) + where + go_ty env ty | Just ty' <- view ty = go_ty env ty' + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = go_ty env t1 `mappend` go_ty env t2 + go_ty _ (LitTy {}) = mempty + go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co + go_ty env (CoercionTy co) = go_co env co + go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res + go_ty env (TyConApp _ tys) = go_tys env tys + go_ty env (ForAllTy (Bndr tv vis) inner) + = let !env' = tycobinder env tv vis -- Avoid building a thunk here + in go_ty env (varType tv) `mappend` go_ty env' inner + + -- Explicit recursion becuase using foldr builds a local + -- loop (with env free) and I'm not confident it'll be + -- lambda lifted in the end + go_tys _ [] = mempty + go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts + + go_cos _ [] = mempty + go_cos env (c:cs) = go_co env c `mappend` go_cos env cs + + go_co env (Refl ty) = go_ty env ty + go_co env (GRefl _ ty MRefl) = go_ty env ty + go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co + go_co env (TyConAppCo _ _ args) = go_cos env args + go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (FunCo _ cw c1 c2) = go_co env cw `mappend` + go_co env c1 `mappend` + go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (AxiomInstCo _ _ args) = go_cos env args + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 + `mappend` go_ty env t2 + go_co env (SymCo co) = go_co env co + go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (AxiomRuleCo _ cos) = go_cos env cos + go_co env (NthCo _ _ co) = go_co env co + go_co env (LRCo _ co) = go_co env co + go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg + go_co env (KindCo co) = go_co env co + go_co env (SubCo co) = go_co env co + go_co env (ForAllCo tv kind_co co) + = go_co env kind_co `mappend` go_ty env (varType tv) + `mappend` go_co env' co + where + env' = tycobinder env tv Inferred + + go_prov env (PhantomProv co) = go_co env co + go_prov env (ProofIrrelProv co) = go_co env co + go_prov _ (PluginProv _) = mempty + go_prov _ CorePrepProv = mempty + +{- ********************************************************************* +* * + typeSize, coercionSize +* * +********************************************************************* -} + +-- NB: We put typeSize/coercionSize here because they are mutually +-- recursive, and have the CPR property. If we have mutual +-- recursion across a hi-boot file, we don't get the CPR property +-- and these functions allocate a tremendous amount of rubbish. +-- It's not critical (because typeSize is really only used in +-- debug mode, but I tripped over an example (T5642) in which +-- typeSize was one of the biggest single allocators in all of GHC. +-- And it's easy to fix, so I did. + +-- NB: typeSize does not respect `eqType`, in that two types that +-- are `eqType` may return different sizes. This is OK, because this +-- function is used only in reporting, not decision-making. + +typeSize :: Type -> Int +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy _ _ t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co + +coercionSize :: Coercion -> Int +coercionSize (Refl ty) = typeSize ty +coercionSize (GRefl _ ty MRefl) = typeSize ty +coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co +coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (AppCo co arg) = coercionSize co + coercionSize arg +coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h +coercionSize (FunCo _ w co1 co2) = 1 + coercionSize co1 + coercionSize co2 + + coercionSize w +coercionSize (CoVarCo _) = 1 +coercionSize (HoleCo _) = 1 +coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg +coercionSize (KindCo co) = 1 + coercionSize co +coercionSize (SubCo co) = 1 + coercionSize co +coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) + +provSize :: UnivCoProvenance -> Int +provSize (PhantomProv co) = 1 + coercionSize co +provSize (ProofIrrelProv co) = 1 + coercionSize co +provSize (PluginProv _) = 1 +provSize CorePrepProv = 1 + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These definitions are here to avoid module loops, and to keep +GHC.Core.Multiplicity above this module. + +-} + +-- | A shorthand for data with an attached 'Mult' element (the multiplicity). +data Scaled a = Scaled Mult a + deriving (Data.Data) + -- You might think that this would be a natural candiate for + -- Functor, Traversable but Krzysztof says (!3674) "it was too easy + -- to accidentally lift functions (substitutions, zonking etc.) from + -- Type -> Type to Scaled Type -> Scaled Type, ignoring + -- multiplicities and causing bugs". So we don't. + + +instance (Outputable a) => Outputable (Scaled a) where + ppr (Scaled _cnt t) = ppr t + -- Do not print the multiplicity here because it tends to be too verbose + +scaledMult :: Scaled a -> Mult +scaledMult (Scaled m _) = m + +scaledThing :: Scaled a -> a +scaledThing (Scaled _ t) = t + +-- | Apply a function to both the Mult and the Type in a 'Scaled Type' +mapScaledType :: (Type -> Type) -> Scaled Type -> Scaled Type +mapScaledType f (Scaled m t) = Scaled (f m) (f t) + +{- | +Mult is a type alias for Type. + +Mult must contain Type because multiplicity variables are mere type variables +(of kind Multiplicity) in Haskell. So the simplest implementation is to make +Mult be Type. + +Multiplicities can be formed with: +- One: GHC.Types.One (= oneDataCon) +- Many: GHC.Types.Many (= manyDataCon) +- Multiplication: GHC.Types.MultMul (= multMulTyCon) + +So that Mult feels a bit more structured, we provide pattern synonyms and smart +constructors for these. +-} +type Mult = Type diff --git a/GHC/Core/TyCo/Rep.hs-boot b/GHC/Core/TyCo/Rep.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Rep.hs-boot @@ -0,0 +1,28 @@ +module GHC.Core.TyCo.Rep where + +import GHC.Utils.Outputable ( Outputable ) +import Data.Data ( Data ) +import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) + +data Type +data TyThing +data Coercion +data UnivCoProvenance +data TyLit +data TyCoBinder +data MCoercion + +data Scaled a +type Mult = Type + +type PredType = Type +type Kind = Type +type ThetaType = [PredType] +type CoercionN = Coercion +type MCoercionN = MCoercion + +mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type +mkForAllTy :: Var -> ArgFlag -> Type -> Type + +instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom +instance Outputable Type diff --git a/GHC/Core/TyCo/Subst.hs b/GHC/Core/TyCo/Subst.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Subst.hs @@ -0,0 +1,1054 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +Type and Coercion - friends' interface +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Substitution into types and coercions. +module GHC.Core.TyCo.Subst + ( + -- * Substitutions + TCvSubst(..), TvSubstEnv, CvSubstEnv, + emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, + emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, + getTvSubstEnv, + getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, + isInScope, notElemTCvSubst, + setTvSubstEnv, setCvSubstEnv, zapTCvSubst, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendTCvSubstWithClone, + extendCvSubst, extendCvSubstWithClone, + extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + unionTCvSubst, zipTyEnv, zipCoEnv, + zipTvSubst, zipCvSubst, + zipTCvSubst, + mkTvSubstPrs, + + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, substTyAddInScope, substScaledTy, + substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, substScaledTyUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyWithInScope, + substTys, substScaledTys, substTheta, + lookupTyVar, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + cloneTyVarBndr, cloneTyVarBndrs, + substVarBndr, substVarBndrs, + substTyVarBndr, substTyVarBndrs, + substCoVarBndr, + substTyVar, substTyVars, substTyCoVars, + substForAllCoBndr, + substVarBndrUsing, substForAllCoBndrUsing, + checkValidSubst, isValidTCvSubst, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.Type + ( mkCastTy, mkAppTy, isCoercionTy ) +import {-# SOURCE #-} GHC.Core.Coercion + ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo + , mkNomReflCo, mkSubCo, mkSymCo + , mkFunCo, mkForAllCo, mkUnivCo + , mkAxiomInstCo, mkAppCo, mkGReflCo + , mkInstCo, mkLRCo, mkTyConAppCo + , mkCoercionType + , coercionKind, coercionLKind, coVarKindsTypesRole ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs + +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Data.Pair +import GHC.Utils.Misc +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable + +import Data.List (mapAccumL) + +{- +%************************************************************************ +%* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +%* * +%************************************************************************ +-} + +-- | Type & coercion substitution +-- +-- #tcvsubst_invariant# +-- The following invariants must hold of a 'TCvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substitution is only applied ONCE! This is because +-- in general such application will not reach a fixed point. +data TCvSubst + = TCvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables + CvSubstEnv -- Substitutes coercion variables + -- See Note [Substitutions apply only once] + -- and Note [Extending the TvSubstEnv] + -- and Note [Substituting types and coercions] + -- and Note [The substitution invariant] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- NB: A TvSubstEnv is used + -- both inside a TCvSubst (with the apply-once invariant + -- discussed in Note [Substitutions apply only once], + -- and also independently in the middle of matching, + -- and unification (see Types.Unify). + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +-- | A substitution of 'Coercion's for 'CoVar's +type CvSubstEnv = CoVarEnv Coercion + +{- Note [The substitution invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When calling (substTy subst ty) it should be the case that +the in-scope set in the substitution is a superset of both: + + (SIa) The free vars of the range of the substitution + (SIb) The free vars of ty minus the domain of the substitution + +The same rules apply to other substitutions (notably GHC.Core.Subst.Subst) + +* Reason for (SIa). Consider + substTy [a :-> Maybe b] (forall b. b->a) + we must rename the forall b, to get + forall b2. b2 -> Maybe b + Making 'b' part of the in-scope set forces this renaming to + take place. + +* Reason for (SIb). Consider + substTy [a :-> Maybe b] (forall b. (a,b,x)) + Then if we use the in-scope set {b}, satisfying (SIa), there is + a danger we will rename the forall'd variable to 'x' by mistake, + getting this: + forall x. (Maybe b, x, x) + Breaking (SIb) caused the bug from #11371. + +Note: if the free vars of the range of the substitution are freshly created, +then the problems of (SIa) can't happen, and so it would be sound to +ignore (SIa). + +Note [Substitutions apply only once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use TCvSubsts to instantiate things, and we might instantiate + forall a b. ty +with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + ******************************************************** + *** So a substitution must be applied precisely once *** + ******************************************************** + +A TCvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tcvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the subst envs are empty: +if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) +holds --- then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + +Note [Substituting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types and coercions are mutually recursive, and either may have variables +"belonging" to the other. Thus, every time we wish to substitute in a +type, we may also need to substitute in a coercion, and vice versa. +However, the constructor used to create type variables is distinct from +that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note +that it would be possible to use the CoercionTy constructor to combine +these environments, but that seems like a false economy. + +Note that the TvSubstEnv should *never* map a CoVar (built with the Id +constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, +the range of the TvSubstEnv should *never* include a type headed with +CoercionTy. +-} + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +composeTCvSubstEnv :: InScopeSet + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ +composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) + = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 + , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TCvSubst in_scope tenv1 cenv1 + +-- | Composes two substitutions, applying the second one provided first, +-- like in function composition. +composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) + = TCvSubst is3 tenv3 cenv3 + where + is3 = is1 `unionInScope` is2 + (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + +emptyTCvSubst :: TCvSubst +emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + +mkEmptyTCvSubst :: InScopeSet -> TCvSubst +mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv + +isEmptyTCvSubst :: TCvSubst -> Bool + -- See Note [Extending the TvSubstEnv] +isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst +mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst +mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv + +mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst +mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv + +getTvSubstEnv :: TCvSubst -> TvSubstEnv +getTvSubstEnv (TCvSubst _ env _) = env + +getCvSubstEnv :: TCvSubst -> CvSubstEnv +getCvSubstEnv (TCvSubst _ _ env) = env + +getTCvInScope :: TCvSubst -> InScopeSet +getTCvInScope (TCvSubst in_scope _ _) = in_scope + +-- | Returns the free variables of the types in the range of a substitution as +-- a non-deterministic set. +getTCvSubstRangeFVs :: TCvSubst -> VarSet +getTCvSubstRangeFVs (TCvSubst _ tenv cenv) + = unionVarSet tenvFVs cenvFVs + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +isInScope :: Var -> TCvSubst -> Bool +isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope + +notElemTCvSubst :: Var -> TCvSubst -> Bool +notElemTCvSubst v (TCvSubst _ tenv cenv) + | isTyVar v + = not (v `elemVarEnv` tenv) + | otherwise + = not (v `elemVarEnv` cenv) + +setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst +setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + +setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst +setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv + +zapTCvSubst :: TCvSubst -> TCvSubst +zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv + +extendTCvInScope :: TCvSubst -> Var -> TCvSubst +extendTCvInScope (TCvSubst in_scope tenv cenv) var + = TCvSubst (extendInScopeSet in_scope var) tenv cenv + +extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst +extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv + +extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst +extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv + +extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst +extendTCvSubst subst v ty + | isTyVar v + = extendTvSubst subst v ty + | CoercionTy co <- ty + = extendCvSubst subst v co + | otherwise + = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) + +extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone subst tcv + | isTyVar tcv = extendTvSubstWithClone subst tcv + | otherwise = extendCvSubstWithClone subst tcv + +extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubst (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv + +extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty + = ASSERT( isTyVar v ) + extendTvSubstAndInScope subst v ty +extendTvSubstBinderAndInScope subst (Anon {}) _ + = subst + +extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst +-- Adds a new tv -> tv mapping, /and/ extends the in-scope set +extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv tenv tv (mkTyVarTy tv')) + cenv + where + new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' + +extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst +extendCvSubst (TCvSubst in_scope tenv cenv) v co + = TCvSubst in_scope tenv (extendVarEnv cenv v co) + +extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst +extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + tenv + (extendVarEnv cenv cv (mkCoVarCo cv')) + where + new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' + +extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +-- Also extends the in-scope set +extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + (extendVarEnv tenv tv ty) + cenv + +extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTvSubstList subst tvs tys + = foldl2 extendTvSubst subst tvs tys + +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +-- Works when the ranges are disjoint +unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) + = ASSERT( tenv1 `disjointVarEnv` tenv2 + && cenv1 `disjointVarEnv` cenv2 ) + TCvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- mkTvSubstPrs and zipTvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No CoVars, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst +zipTvSubst tvs tys + = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv + where + tenv = zipTyEnv tvs tys + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No TyVars, please! +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst cvs cos + = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv + where + cenv = zipCoEnv cvs cos + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst tcvs tys + = zip_tcvsubst tcvs tys $ + mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys + where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + zip_tcvsubst (tv:tvs) (ty:tys) subst + = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) + zip_tcvsubst [] [] subst = subst -- empty case + zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" + (ppr tcvs <+> ppr tys) + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the +-- incoming environment. No CoVars, please! +mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst +mkTvSubstPrs prs = + ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) + mkTvSubst in_scope tenv + where tenv = mkVarEnv prs + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs + onlyTyVarsAndNoCoercionTy = + and [ isTyVar tv && not (isCoercionTy ty) + | (tv, ty) <- prs ] + +zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + | debugIsOn + , not (all isTyVar tyvars && (tyvars `equalLength` tys)) + = pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys) + | otherwise + = ASSERT( all (not . isCoercionTy) tys ) + mkVarEnv (zipEqual "zipTyEnv" tyvars tys) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos + | debugIsOn + , not (all isCoVar cvs) + = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) + | otherwise + = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + +instance Outputable TCvSubst where + ppr (TCvSubst ins tenv cenv) + = brackets $ sep[ text "TCvSubst", + nest 2 (text "In scope:" <+> ppr ins), + nest 2 (text "Type env:" <+> ppr tenv), + nest 2 (text "Co env:" <+> ppr cenv) ] + +{- +%************************************************************************ +%* * + Performing type or kind substitutions +%* * +%************************************************************************ + +Note [Sym and ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~ +In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, +how do we push sym into a ForAllCo? It's a little ugly. + +Here is the typing rule: + +h : k1 ~# k2 +(tv : k1) |- g : ty1 ~# ty2 +---------------------------- +ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# + (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) + +Here is what we want: + +ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# + (ForAllTy (tv : k1) ty1) + + +Because the kinds of the type variables to the right of the colon are the kinds +coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). + +Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want + +ForAllCo tv h' g' : + (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# + (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) + +We thus see that we want + +g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] + +and thus g' = sym (g[tv |-> tv |> h']). + +Putting it all together, we get this: + +sym (ForAllCo tv h g) +==> +ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) + +Note [Substituting in a coercion hole] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It seems highly suspicious to be substituting in a coercion that still +has coercion holes. Yet, this can happen in a situation like this: + + f :: forall k. k :~: Type -> () + f Refl = let x :: forall (a :: k). [a] -> ... + x = ... + +When we check x's type signature, we require that k ~ Type. We indeed +know this due to the Refl pattern match, but the eager unifier can't +make use of givens. So, when we're done looking at x's type, a coercion +hole will remain. Then, when we're checking x's definition, we skolemise +x's type (in order to, e.g., bring the scoped type variable `a` into scope). +This requires performing a substitution for the fresh skolem variables. + +This substitution needs to affect the kind of the coercion hole, too -- +otherwise, the kind will have an out-of-scope variable in it. More problematically +in practice (we won't actually notice the out-of-scope variable ever), skolems +in the kind might have too high a level, triggering a failure to uphold the +invariant that no free variables in a type have a higher level than the +ambient level in the type checker. In the event of having free variables in the +hole's kind, I'm pretty sure we'll always have an erroneous program, so we +don't need to worry what will happen when the hole gets filled in. After all, +a hole relating a locally-bound type variable will be unable to be solved. This +is why it's OK not to look through the IORef of a coercion hole during +substitution. + +-} + +-- | Type substitution, see 'zipTvSubst' +substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type +-- Works only if the domain of the substitution is a +-- superset of the type being substituted into +substTyWith tvs tys = {-#SCC "substTyWith" #-} + ASSERT( tvs `equalLength` tys ) + substTy (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type +substTyWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substTyUnchecked (zipTvSubst tvs tys) + +-- | Substitute tyvars within a type using a known 'InScopeSet'. +-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution +-- invariant]; specifically it should include the free vars of 'tys', +-- and of 'ty' minus the domain of the subst. +substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type +substTyWithInScope in_scope tvs tys ty = + ASSERT( tvs `equalLength` tys ) + substTy (mkTvSubst in_scope tenv) ty + where tenv = zipTyEnv tvs tys + +-- | Coercion substitution, see 'zipTvSubst' +substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) + substCo (zipTvSubst tvs tys) + +-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substCoUnchecked (zipTvSubst tvs tys) + + + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) + +-- | Type substitution, see 'zipTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) + substTys (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst' +substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) + substTys (zipCvSubst cvs cos) + +-- | Substitute within a 'Type' after adding the free variables of the type +-- to the in-scope set. This is useful for the case when the free variables +-- aren't already in the in-scope set or easily available. +-- See also Note [The substitution invariant]. +substTyAddInScope :: TCvSubst -> Type -> Type +substTyAddInScope subst ty = + substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + +-- | When calling `substTy` it should be the case that the in-scope set in +-- the substitution is a superset of the free vars of the range of the +-- substitution. +-- See also Note [The substitution invariant]. +isValidTCvSubst :: TCvSubst -> Bool +isValidTCvSubst (TCvSubst in_scope tenv cenv) = + (tenvFVs `varSetInScope` in_scope) && + (cenvFVs `varSetInScope` in_scope) + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +-- | This checks if the substitution satisfies the invariant from +-- Note [The substitution invariant]. +checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a + = ASSERT2( isValidTCvSubst subst, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$ + text "cenv" <+> ppr cenv $$ + text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos ) + ASSERT2( tysCosFVsInScope, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "cenv" <+> ppr cenv $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos $$ + text "needInScope" <+> ppr needInScope ) + a + where + substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv + -- It's OK to use nonDetKeysUFM here, because we only use this list to + -- remove some elements from a set + needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet` + shallowTyCoVarsOfCos cos) + `delListFromUniqSet_Directly` substDomain + tysCosFVsInScope = needInScope `varSetInScope` in_scope + + +-- | Substitute within a 'Type' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTy :: HasCallStack => TCvSubst -> Type -> Type +substTy subst ty + | isEmptyTCvSubst subst = ty + | otherwise = checkValidSubst subst [ty] [] $ + subst_ty subst ty + +-- | Substitute within a 'Type' disabling the sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked subst ty + | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +substScaledTy :: HasCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty + +substScaledTyUnchecked :: HasCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) scaled_ty + +-- | Substitute within several 'Type's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] +substTys subst tys + | isEmptyTCvSubst subst = tys + | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys + +substScaledTys :: HasCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTys subst scaled_tys + | isEmptyTCvSubst subst = scaled_tys + | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $ + map (mapScaledType (subst_ty subst)) scaled_tys + +-- | Substitute within several 'Type's disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTysUnchecked to +-- substTys and remove this function. Please don't use in new code. +substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +substScaledTysUnchecked :: TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (mapScaledType (subst_ty subst)) tys + +-- | Substitute within a 'ThetaType' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta = substTys + +-- | Substitute within a 'ThetaType' disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to +-- substTheta and remove this function. Please don't use in new code. +substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked = substTysUnchecked + + +subst_ty :: TCvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (TyVarTy tv) = substTyVar subst tv + go (AppTy fun arg) = (mkAppTy $! (go fun)) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go ty@(TyConApp tc []) = tc `seq` ty -- avoid allocation in this common case + go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys + -- NB: mkTyConApp, not TyConApp. + -- mkTyConApp has optimizations. + -- See Note [mkTyConApp and Type] in GHC.Core.TyCo.Rep + go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) + = let !mult' = go mult + !arg' = go arg + !res' = go res + in ty { ft_mult = mult', ft_arg = arg', ft_res = res' } + go (ForAllTy (Bndr tv vis) ty) + = case substVarBndrUnchecked subst tv of + (subst', tv') -> + (ForAllTy $! ((Bndr $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) + go (CoercionTy co) = CoercionTy $! (subst_co subst co) + +substTyVar :: TCvSubst -> TyVar -> Type +substTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + +substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVars subst = map $ substTyVar subst + +substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars subst = map $ substTyCoVar subst + +substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar subst tv + | isTyVar tv = substTyVar subst tv + | otherwise = CoercionTy $ substCoVar subst tv + +lookupTyVar :: TCvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TCvSubst] +lookupTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion +substCo subst co + | isEmptyTCvSubst subst = co + | otherwise = checkValidSubst subst [] [co] $ subst_co subst co + +-- | Substitute within a 'Coercion' disabling sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked subst co + | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos subst cos + | isEmptyTCvSubst subst = cos + | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos + +subst_co :: TCvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go_mco :: MCoercion -> MCoercion + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go :: Coercion -> Coercion + go (Refl ty) = mkNomReflCo $! (go_ty ty) + go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) + go (TyConAppCo r tc args)= let args' = map go args + in args' `seqList` mkTyConAppCo r tc args' + go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (ForAllCo tv kind_co co) + = case substForAllCoBndrUnchecked subst tv kind_co of + (subst', tv', kind_co') -> + ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co + go (FunCo r w co1 co2) = ((mkFunCo r $! go w) $! go co1) $! go co2 + go (CoVarCo cv) = substCoVar subst cv + go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos + go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! + (go_ty t1)) $! (go_ty t2) + go (SymCo co) = mkSymCo $! (go co) + go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) + go (NthCo r d co) = mkNthCo r d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (KindCo co) = mkKindCo $! (go co) + go (SubCo co) = mkSubCo $! (go co) + go (AxiomRuleCo c cs) = let cs1 = map go cs + in cs1 `seqList` AxiomRuleCo c cs1 + go (HoleCo h) = HoleCo $! go_hole h + + go_prov (PhantomProv kco) = PhantomProv (go kco) + go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) + go_prov p@(PluginProv _) = p + go_prov p@CorePrepProv = p + + -- See Note [Substituting in a coercion hole] + go_hole h@(CoercionHole { ch_co_var = cv }) + = h { ch_co_var = updateVarType go_ty cv } + +substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrUsing False (substCo subst) subst + +-- | Like 'substForAllCoBndr', but disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked subst + = substForAllCoBndrUsing False (substCoUnchecked subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, KindCoercion) +substForAllCoBndrUsing sym sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var + +substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> KindCoercion + -> (TCvSubst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + = ASSERT( isTyVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + , new_var, new_kind_co ) + where + new_env | no_change && not sym = delVarEnv tenv old_var + | sym = extendVarEnv tenv old_var $ + TyVarTy new_var `CastTy` new_kind_co + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + new_ki1 = coercionLKind new_kind_co + -- We could do substitution to (tyVarKind old_var). We don't do so because + -- we already substituted new_kind_co, which contains the kind information + -- we want. We don't want to do substitution once more. Also, in most cases, + -- new_kind_co is a Refl, in which case coercionKind is really fast. + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> CoVar -> KindCoercion + -> (TCvSubst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ASSERT( isCoVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + , new_var, new_kind_co ) + where + new_cenv | no_change && not sym = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair h1 h2 = coercionKind new_kind_co + + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type + new_var_type | sym = h2 + | otherwise = h1 + +substCoVar :: TCvSubst -> CoVar -> Coercion +substCoVar (TCvSubst _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + +substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupCoVar :: TCvSubst -> Var -> Maybe Coercion +lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v + +substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr = substTyVarBndrUsing substTy + +substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs = mapAccumL substTyVarBndr + +substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr = substVarBndrUsing substTy + +substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs = mapAccumL substVarBndr + +substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrUsing substTy + +-- | Like 'substVarBndr', but disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked = substVarBndrUsing substTyUnchecked + +substVarBndrUsing :: (TCvSubst -> Type -> Type) + -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing subst_fn subst v + | isTyVar v = substTyVarBndrUsing subst_fn subst v + | otherwise = substCoVarBndrUsing subst_fn subst v + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +-- Use the supplied function to substitute in the kind +substTyVarBndrUsing + :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind + -> TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) + ASSERT( isTyVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TCvSubst] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ + setTyVarKind old_var (subst_fn subst old_ki) + -- The uniqAway part makes sure the new variable is not already in scope + +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +substCoVarBndrUsing + :: (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + new_co = mkCoVarCo new_var + no_kind_change = noFreeVarsOfTypes [t1, t2] + no_change = new_var == old_var && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) new_var_type + + (_, _, t1, t2, role) = coVarKindsTypesRole old_var + t1' = subst_fn subst t1 + t2' = subst_fn subst t2 + new_var_type = mkCoercionType role t1' t2' + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) +cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq + = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars + (TCvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + where + old_ki = tyVarKind tv + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + + tv1 | no_kind_change = tv + | otherwise = setTyVarKind tv (substTy subst old_ki) + + tv' = setVarUnique tv1 uniq + +cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs subst [] _usupply = (subst, []) +cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) + where + (uniq, usupply') = takeUniqFromSupply usupply + (subst' , tv ) = cloneTyVarBndr subst t uniq + (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' diff --git a/GHC/Core/TyCo/Tidy.hs b/GHC/Core/TyCo/Tidy.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Tidy.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Tidying types and coercions for printing in error messages. +module GHC.Core.TyCo.Tidy + ( + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyCo, tidyCos, + tidyTyCoVarBinder, tidyTyCoVarBinders + ) where + +import GHC.Prelude + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) + +import GHC.Types.Name hiding (varName) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Utils.Misc (seqList) + +import Data.List (mapAccumL) + +{- +%************************************************************************ +%* * +\subsection{TidyType} +%* * +%************************************************************************ +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyVarBndrs tidy_env tvs + = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs + +tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyVarBndr tidy_env@(occ_env, subst) var + = case tidyOccName occ_env (getHelpfulOccName var) of + (occ_env', occ') -> ((occ_env', subst'), var') + where + subst' = extendVarEnv subst var var' + var' = updateVarType (tidyType tidy_env) (setVarName var name') + name' = tidyNameOcc name occ' + name = varName var + +avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv +-- Seed the occ_env with clashes among the names, see +-- Note [Tidying multiple names at once] in GHC.Types.Names.OccName +avoidNameClashes tvs (occ_env, subst) + = (avoidClashesOccEnv occ_env occs, subst) + where + occs = map getHelpfulOccName tvs + +getHelpfulOccName :: TyCoVar -> OccName +-- A TcTyVar with a System Name is probably a +-- unification variable; when we tidy them we give them a trailing +-- "0" (or 1 etc) so that they don't take precedence for the +-- un-modified name. Plus, indicating a unification variable in +-- this way is a helpful clue for users +getHelpfulOccName tv + | isSystemName name, isTcTyVar tv + = mkTyVarOcc (occNameString occ ++ "0") + | otherwise + = occ + where + name = varName tv + occ = getOccName name + +tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis + -> (TidyEnv, VarBndr TyCoVar vis) +tidyTyCoVarBinder tidy_env (Bndr tv vis) + = (tidy_env', Bndr tv' vis) + where + (tidy_env', tv') = tidyVarBndr tidy_env tv + +tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] + -> (TidyEnv, [VarBndr TyCoVar vis]) +tidyTyCoVarBinders tidy_env tvbs + = mapAccumL tidyTyCoVarBinder + (avoidNameClashes (binderVars tvbs) tidy_env) tvbs + +--------------- +tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyCoVars tidy_env tyvars + = fst (tidyOpenTyCoVars tidy_env tyvars) + +--------------- +tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars + +--------------- +tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyVarBndr' +tidyOpenTyCoVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> + let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) + in tidyVarBndr env' tyvar -- Treat it as a binder + +--------------- +tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar +tidyTyCoVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> updateVarType (tidyType env) tv + Just tv' -> tv' + +--------------- +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = map (tidyType env) tys + +--------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env ty@(FunTy _ w arg res) = let { !w' = tidyType env w + ; !arg' = tidyType env arg + ; !res' = tidyType env res } + in ty { ft_mult = w', ft_arg = arg', ft_res = res' } +tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty + where + (tvs, vis, body_ty) = splitForAllTys' ty + (env', tvs') = tidyVarBndrs env tvs +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) + + +-- The following two functions differ from mkForAllTys and splitForAllTys in that +-- they expect/preserve the ArgFlag argument. These belong to "GHC.Core.Type", but +-- how should they be named? +mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type +mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs + where + strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty + +splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) +splitForAllTys' ty = go ty [] [] + where + go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) + go ty tvs viss = (reverse tvs, reverse viss, ty) + + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys + = (env', tidyTypes (trimmed_occ_env, var_env) tys) + where + (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ + tyCoVarsOfTypesWellScoped tys + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the types, so that we don't gratuitously rename + -- the _bound_ variables of the types. + +--------------- +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in + (env', ty') + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType + +---------------- +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go (Refl ty) = Refl (tidyType env ty) + go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) + where (envp, tvp) = tidyVarBndr env tv + -- the case above duplicates a bit of work in tidying h and the kind + -- of tv. But the alternative is to use coercionKind, which seems worse. + go (FunCo r w co1 co2) = ((FunCo r $! go w) $! go co1) $! go co2 + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (HoleCo h) = HoleCo h + go (AxiomInstCo con ind cos) = let args = map go cos + in args `seqList` AxiomInstCo con ind args + go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! + tidyType env t1) $! tidyType env t2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo r d co) = NthCo r d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (KindCo co) = KindCo $! go co + go (SubCo co) = SubCo $! go co + go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos + in cos1 `seqList` AxiomRuleCo ax cos1 + + go_prov (PhantomProv co) = PhantomProv (go co) + go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) + go_prov p@(PluginProv _) = p + go_prov p@CorePrepProv = p + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) diff --git a/GHC/Core/TyCon.hs b/GHC/Core/TyCon.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCon.hs @@ -0,0 +1,2825 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @TyCon@ datatype +-} + +{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Core.TyCon( + -- * Main TyCon data types + TyCon, + AlgTyConRhs(..), visibleDataCons, + AlgTyConFlav(..), isNoParent, + FamTyConFlav(..), Role(..), Injectivity(..), + RuntimeRepInfo(..), TyConFlavour(..), + + -- * TyConBinder + TyConBinder, TyConBndrVis(..), TyConTyCoBinder, + mkNamedTyConBinder, mkNamedTyConBinders, + mkRequiredTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, + tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, + + -- ** Field labels + tyConFieldLabels, lookupTyConFieldLabel, + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkFunTyCon, + mkPrimTyCon, + mkKindTyCon, + mkLiftedPrimTyCon, + mkTupleTyCon, + mkSumTyCon, + mkDataTyConRhs, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkTcTyCon, + noTcTyConScopedTyVars, + + -- ** Predicates on TyCons + isAlgTyCon, isVanillaAlgTyCon, isConstraintKindCon, + isClassTyCon, isFamInstTyCon, + isFunTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, + isTypeSynonymTyCon, + mustBeSaturated, + isPromotedDataCon, isPromotedDataCon_maybe, + isKindTyCon, isLiftedTypeKindTyConName, + isTauTyCon, isFamFreeTyCon, + + isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, + isDataSumTyCon_maybe, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + tyConInjectivityInfo, + isBuiltInSynFamTyCon_maybe, + isUnliftedTyCon, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, + isImplicitTyCon, + isTyConWithSrcDataCons, + isTcTyCon, setTcTyConKind, + isTcLevPoly, + + -- ** Extracting information out of TyCons + tyConName, + tyConSkolem, + tyConKind, + tyConUnique, + tyConTyVars, tyConVisibleTyVars, + tyConCType, tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConSingleAlgDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConRoles, + tyConFlavour, + tyConTuple_maybe, tyConClass_maybe, tyConATs, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, famTcResVar, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + newTyConDataCon_maybe, + algTcFields, + tyConRuntimeRepInfo, + tyConBinders, tyConResKind, tyConInvisTVBinders, + tcTyConScopedTyVars, tcTyConIsPoly, + mkTyConTagMap, + + -- ** Manipulating TyCons + expandSynTyCon_maybe, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, mkTyConKind, + + -- ** Predicated on TyConFlavours + tcFlavourIsOpen, + + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + mkPrelTyConRepName, + tyConRepModOcc, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), + isVoidRep, isGcPtrRep, + primRepSizeB, + primElemRepSizeB, + primRepIsFloat, + primRepsCompatible, + primRepCompatible, + + -- * Recursion breaking + RecTcChecker, initRecTc, defaultRecTcMaxBound, + setRecTcMaxBound, checkRecTc + +) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import {-# SOURCE #-} GHC.Core.TyCo.Rep + ( Kind, Type, PredType, mkForAllTy, mkFunTyMany ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr + ( pprType ) +import {-# SOURCE #-} GHC.Builtin.Types + ( runtimeRepTyCon, constraintKind + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon, liftedTypeKind ) +import {-# SOURCE #-} GHC.Core.DataCon + ( DataCon, dataConExTyCoVars, dataConFieldLabels + , dataConTyCon, dataConFullSig + , isUnboxedSumCon ) + +import GHC.Utils.Binary +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.Class +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Core.Coercion.Axiom +import GHC.Builtin.Names +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Data.FastString.Env +import GHC.Types.FieldLabel +import GHC.Settings.Constants +import GHC.Utils.Misc +import GHC.Types.Unique( tyConRepNameUnique, dataConTyRepNameUnique ) +import GHC.Types.Unique.Set +import GHC.Unit.Module + +import qualified Data.Data as Data + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: * + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: * + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +We also support injective type families -- see Note [Injective type families] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make + +* Data type families are declared thus + data family T a :: * + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as he did with type + synonym families. He just sees constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~R R:TInt + + Note that this is a *representational* coercion + The R:TInt is the "representation TyCons". + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +* Data family instances may have a different arity than the data family. + See Note [Arity of data families] in GHC.Core.FamInstEnv + +* The data constructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a b where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~R R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConFlav of + + DataFamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is looked up (via tcLookupDataFamilyInst) + in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to + solve representational equalities like + T Int ~R# Bool + Here we look up (T Int), convert it to R:TInt, and then unwrap the + newtype R:TInt. + + It is also looked up in reduceTyFamApp_maybe. + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + should not think of a data family T as a *type function* at all, not + even an injective one! We can't allow even injective type functions + on the LHS of a type function: + type family injective G a :: * + type instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +* The tyConTyVars of the representation tycon are the tyvars that the + user wrote in the patterns. This is important in GHC.Tc.Deriv, where we + bring these tyvars into scope before type-checking the deriving + clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a famTcParent field of (Just cls_tc), which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyVars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no levity polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) + + +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [Injectivity annotation] in GHC.Hs.Decls + * [Renaming injectivity annotation] in GHC.Rename.Module + * [Verifying injectivity annotation] in GHC.Core.FamInstEnv + * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact + +************************************************************************ +* * + TyConBinder, TyConTyCoBinder +* * +************************************************************************ +-} + +type TyConBinder = VarBndr TyVar TyConBndrVis + +-- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really +-- contain CoVar. +type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis + +data TyConBndrVis + = NamedTCB ArgFlag + | AnonTCB AnonArgFlag + +instance Outputable TyConBndrVis where + ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag + ppr (AnonTCB af) = text "AnonTCB" <> ppr af + +mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder +mkAnonTyConBinder af tv = ASSERT( isTyVar tv) + Bndr tv (AnonTCB af) + +mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] +mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs + +mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder +-- The odd argument order supports currying +mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) + Bndr tv (NamedTCB vis) + +mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +-- | Make a Required TyConBinder. It chooses between NamedTCB and +-- AnonTCB based on whether the tv is mentioned in the dependent set +mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently + -> TyVar + -> TyConBinder +mkRequiredTyConBinder dep_set tv + | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv + | otherwise = mkAnonTyConBinder VisArg tv + +tyConBinderArgFlag :: TyConBinder -> ArgFlag +tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis + +tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag +tyConBndrVisArgFlag (NamedTCB vis) = vis +tyConBndrVisArgFlag (AnonTCB VisArg) = Required +tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] + +isNamedTyConBinder :: TyConBinder -> Bool +-- Identifies kind variables +-- E.g. data T k (a:k) = blah +-- Here 'k' is a NamedTCB, a variable used in the kind of other binders +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis + +isVisibleTcbVis :: TyConBndrVis -> Bool +isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis +isVisibleTcbVis (AnonTCB VisArg) = True +isVisibleTcbVis (AnonTCB InvisArg) = False + +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +-- Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: TyConBinder -> Kind -> Kind + mk (Bndr tv (AnonTCB af)) k = mkFunTyMany af (varType tv) k + mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k + +tyConInvisTVBinders :: [TyConBinder] -- From the TyCon + -> [InvisTVBinder] -- Suitable for the foralls of a term function +-- See Note [Building TyVarBinders from TyConBinders] +tyConInvisTVBinders tc_bndrs + = map mk_binder tc_bndrs + where + mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv + where + vis = case tc_vis of + AnonTCB VisArg -> SpecifiedSpec + AnonTCB InvisArg -> InferredSpec -- See Note [AnonTCB InvisArg] + NamedTCB Required -> SpecifiedSpec + NamedTCB (Invisible vis) -> vis + +-- Returns only tyvars, as covars are always inferred +tyConVisibleTyVars :: TyCon -> [TyVar] +tyConVisibleTyVars tc + = [ tv | Bndr tv vis <- tyConBinders tc + , isVisibleTcbVis vis ] + +{- Note [AnonTCB InvisArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's pretty rare to have an (AnonTCB InvisArg) binder. The +only way it can occur is through equality constraints in kinds. These +can arise in one of two ways: + +* In a PromotedDataCon whose kind has an equality constraint: + + 'MkT :: forall a b. (a~b) => blah + + See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and + Note [Promoted data constructors] in this module. +* In a data type whose kind has an equality constraint, as in the + following example from #12102: + + data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type + +When mapping an (AnonTCB InvisArg) to an ArgFlag, in +tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot +specify this arguments, even with visible type/kind application; +instead the type checker must fill it in. + +We map (AnonTCB VisArg) to Required, of course: the user must +provide it. It would be utterly wrong to do this for constraint +arguments, which is why AnonTCB must have the AnonArgFlag in +the first place. + +Note [Building TyVarBinders from TyConBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to build the quantified type of a value from +the TyConBinders of a type or class. For that we need not +TyConBinders but TyVarBinders (used in forall-type) E.g: + + * From data T a = MkT (Maybe a) + we are going to make a data constructor with type + MkT :: forall a. Maybe a -> T a + See the TyCoVarBinders passed to buildDataCon + + * From class C a where { op :: a -> Maybe a } + we are going to make a default method + $dmop :: forall a. C a => a -> Maybe a + See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType + +Both of these are user-callable. (NB: default methods are not callable +directly by the user but rather via the code generated by 'deriving', +which uses visible type application; see mkDefMethBind.) + +Since they are user-callable we must get their type-argument visibility +information right; and that info is in the TyConBinders. +Here is an example: + + data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * + +The TyCon has + + tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] + +The TyConBinders for App line up with App's kind, given above. + +But the DataCon MkApp has the type + MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b + +That is, its TyCoVarBinders should be + + dataConUnivTyVarBinders = [ Bndr (k:*) Inferred + , Bndr (a:k->*) Specified + , Bndr (b:k) Specified ] + +So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: + - variable names from the TyConBinders + - but changing Anon/Required to Specified + +The last part about Required->Specified comes from this: + data T k (a:k) b = MkT (a b) +Here k is Required in T's kind, but we don't have Required binders in +the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] +in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's TyCoBinders +-} + + +{- Note [The binders/kind/arity fields of a TyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All TyCons have this group of fields + tyConBinders :: [TyConBinder/TyConTyCoBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type/coercion variables on the LHS of the + type declaration. For example: + + type App a (b :: k) = a b + + tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) + , Bndr (a:k->*) AnonTCB + , Bndr (b:k) AnonTCB ] + + Note that there are three binders here, including the + kind variable k. + +* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep + for what the visibility flag means. + +* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and + that TyVar may scope over some other part of the TyCon's definition. Eg + type T a = a -> a + we have + tyConBinders = [ Bndr (a:*) AnonTCB ] + synTcRhs = a -> a + So the 'a' scopes over the synTcRhs + +* From the tyConBinders and tyConResKind we can get the tyConKind + E.g for our App example: + App :: forall k. (k->*) -> k -> * + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by etaExpandAlgTyCon +-} + +instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where + ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) + where + ppr_bi (AnonTCB VisArg) = text "anon-vis" + ppr_bi (AnonTCB InvisArg) = text "anon-invis" + ppr_bi (NamedTCB Required) = text "req" + -- See Note [Explicit Case Statement for Specificity] + ppr_bi (NamedTCB (Invisible spec)) = case spec of + SpecifiedSpec -> text "spec" + InferredSpec -> text "inf" + +instance Binary TyConBndrVis where + put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } + put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { af <- get bh; return (AnonTCB af) } + _ -> do { vis <- get bh; return (NamedTCB vis) } } + + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ +-} + + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @*@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @* -> *@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @*@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data TyCon + = -- | The function type constructor, @(->)@ + FunTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRepName :: TyConRepName + } + + -- | Algebraic data types, from + -- - @data@ declarations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- All these constructors are lifted and boxed except unboxed tuples + -- which should have an 'UnboxedAlgTyCon' parent. + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. + | AlgTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcFields :: FieldLabelEnv, -- ^ Maps a label to information + -- about the field + + algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + + } + + -- | Represents type synonyms + | SynonymTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars scope over: synTcRhs + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + synTcRhs :: Type, -- ^ Contains information about the expansion + -- of the synonym + + synIsTau :: Bool, -- True <=> the RHS of this synonym does not + -- have any foralls, after expanding any + -- nested synonyms + synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention + -- any type synonym families (data families + -- are fine), again after expanding any + -- nested synonyms + } + + -- | Represents families (both type and data) + -- Argument roles are all Nominal + | FamilyTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars connect an associated family TyCon + -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst + + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families + -- The class tycon in which the family is declared + -- See Note [Associated families and their parent class] + + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds (@*@, @#@, and @?@) + | PrimTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may + -- not contain bottom) but other are lifted, + -- e.g. @RealWorld@ + -- Only relevant if tyConKind = * + + primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons + -- i.e, *, #, ? + } + + -- | Represents promoted data constructor. + | PromotedDataCon { -- See Note [Promoted data constructors] + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConTyCoBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars + dataCon :: DataCon, -- ^ Corresponding data constructor + tcRepName :: TyConRepName, + promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' + } + + -- | These exist only during type-checking. See Note [How TcTyCons work] + -- in "GHC.Tc.TyCl" + | TcTyCon { + tyConUnique :: Unique, + tyConName :: Name, + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- NB: the TyConArity of a TcTyCon must match + -- the number of Required (positional, user-specified) + -- arguments to the type constructor; see the use + -- of tyConArity in generaliseTcTyCon + + tcTyConScopedTyVars :: [(Name,TyVar)], + -- ^ Scoped tyvars over the tycon's body + -- See Note [Scoped tyvars in a TcTyCon] + + tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? + + tcTyConFlavour :: TyConFlavour + -- ^ What sort of 'TyCon' this represents. + } +{- Note [Scoped tyvars in a TcTyCon] + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcTyConScopedTyVars field records the lexicial-binding connection +between the original, user-specified Name (i.e. thing in scope) and +the TcTyVar that the Name is bound to. + +Order *does* matter; the tcTyConScopedTyvars list consists of + specified_tvs ++ required_tvs + +where + * specified ones first + * required_tvs the same as tyConTyVars + * tyConArity = length required_tvs + +See also Note [How TcTyCons work] in GHC.Tc.TyCl +-} + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in mkTyConTagMap) + data_cons_size :: Int, + -- ^ Cached value: length data_cons + is_enum :: Bool -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + } + + | TupleTyCon { -- A boxed, unboxed, or constraint tuple + data_con :: DataCon, -- NB: it can be an *unboxed* tuple + tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint + -- tuple? + } + + -- | An unboxed sum type. + | SumTyCon { + data_cons :: [DataCon], + data_cons_size :: Int -- ^ Cached value: length data_cons + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched, + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check #1072. + nt_lev_poly :: Bool + -- 'True' if the newtype can be levity polymorphic when + -- fully applied to its arguments, 'False' otherwise. + -- This can only ever be 'True' with UnliftedNewtypes. + -- + -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt) + -- + -- This is cached to make it cheaper to check if a + -- variable binding is levity polymorphic, as used by + -- isTcLevPoly. + } + +mkSumTyConRhs :: [DataCon] -> AlgTyConRhs +mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) + +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon { + data_cons = cons, + data_cons_size = length cons, + is_enum = not (null cons) && all is_enum_con cons + -- See Note [Enumeration types] in GHC.Core.TyCon + } + where + is_enum_con con + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys + +-- | Some promoted datacons signify extra info relevant to GHC. For example, +-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' +-- constructor of 'PrimRep'. This data structure allows us to store this +-- information right in the 'TyCon'. The other approach would be to look +-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. +-- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType" +data RuntimeRepInfo + = NoRRI -- ^ an ordinary promoted data con + | RuntimeRep ([Type] -> [PrimRep]) + -- ^ A constructor of @RuntimeRep@. The argument to the function should + -- be the list of arguments to the promoted datacon. + | VecCount Int -- ^ A constructor of @VecCount@ + | VecElem PrimElemRep -- ^ A constructor of @VecElem@ + +-- | Extract those 'DataCon's that we are able to learn about. Note +-- that visibility in this sense does not correspond to visibility in +-- the context of any particular user program! +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs + +-- ^ Both type classes as well as family instances imply implicit +-- type constructors. These implicit type constructors refer to their parent +-- structure (ie, the class or family from which they derive) using a type of +-- the following form. +data AlgTyConFlav + = -- | An ordinary type constructor has no parent. + VanillaAlgTyCon + TyConRepName -- For Typeable + + -- | An unboxed type constructor. The TyConRepName is a Maybe since we + -- currently don't allow unboxed sums to be Typeable since there are too + -- many of them. See #13276. + | UnboxedAlgTyCon + (Maybe TyConRepName) + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in "GHC.Core.TyCo.Rep" + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- A *Representational* coercion, + -- of kind T ty1 ty2 ~R R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see + -- Note [Eta reduction for data families] in + -- GHC.Core.Coercion.Axiom + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + + -- E.g. data instance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" + <+> ppr tc <+> sep (map pprType tys) + +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class +-- name, if any +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedAlgTyCon {}) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc + +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False + +-------------------- + +data Injectivity + = NotInjective + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data family T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) + -- See Note [Closed type families] + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +instance Outputable FamTyConFlav where + ppr (DataFamilyTyCon n) = text "data family" <+> ppr n + ppr OpenSynFamilyTyCon = text "open type family" + ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" + ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax + ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" + ppr (BuiltInSynFamTyCon _) = text "built-in type family" + +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + +A non-empty closed type family has a single axiom with multiple +branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed +type family with no equations does not have an axiom, because there is +nothing for the axiom to prove! + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in GHC.Core.TyCon. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, + say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + 'MkT :: (Bool,Bool) -> T + *not* + 'MkT :: Bool -> Bool -> T + +* Similarly for GADTs: + data G a where + MkG :: forall b. b -> G [b] + The promoted data constructor has kind + 'MkG :: forall b. b -> G [b] + *not* + 'MkG :: forall a b. (a ~# [b]) => b -> G a + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a. + +We might also eta-contract the axiom: see Note [Newtype eta]. + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal (that is, does a coercion exist between them)? + Monad Parser + Monad IO +which we need to make the derived instance for Monad Parser. + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to IO, so that even unsaturated applications +of Parser will work right. This eta reduction is done when the type +constructor is built, and cached in NewTyCon. + +Here's an example that I think showed up in practice +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we get: + w2 = w1 `cast` Foo CoT +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 + +This eta-reduction is implemented in GHC.Tc.TyCl.Build.mkNewTyConRhs. + + +************************************************************************ +* * + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name + -- The Name of the top-level declaration for the Typeable world + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) + = Just rep_nm +tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) + = mb_rep_nm +tyConRepName_maybe (AlgTyCon { algTcParent = parent }) + | VanillaAlgTyCon rep_nm <- parent = Just rep_nm + | ClassTyCon _ rep_nm <- parent = Just rep_nm + | UnboxedAlgTyCon rep_nm <- parent = rep_nm +tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm +tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) + | isUnboxedSumCon dc -- see #13276 + = Nothing + | otherwise + = Just rep_nm +tyConRepName_maybe _ = Nothing + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> TyConRepName +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConTyRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | The name (and defining module) for the Typeable representation (TyCon) of a +-- type constructor. +-- +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) + where + rep_module + | tc_module == gHC_PRIM = gHC_TYPES + | otherwise = tc_module + + +{- ********************************************************************* +* * + PrimRep +* * +************************************************************************ + +Note [rep swamp] + +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width ("GHC.Cmm.Type") is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. + +The PrimRep type is closely related to the user-visible RuntimeRep type. +See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. + +-} + +-- | A 'PrimRep' is an abstraction of a type. It contains information that +-- the code generator needs in order to pass arguments, return results, +-- and store values of this type. See also Note [RuntimeRep and PrimRep] in +-- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". +data PrimRep + = VoidRep + | LiftedRep + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + | Int32Rep -- ^ Signed, 32-bit value + | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | IntRep -- ^ Signed, word-sized value + | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | Word32Rep -- ^ Unsigned, 32 bit value + | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | WordRep -- ^ Unsigned, word-sized value + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Show ) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Eq, Show ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + ppr r = text (show r) + +isVoidRep :: PrimRep -> Bool +isVoidRep VoidRep = True +isVoidRep _other = False + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep LiftedRep = True +isGcPtrRep UnliftedRep = True +isGcPtrRep _ = False + +-- A PrimRep is compatible with another iff one can be coerced to the other. +-- See Note [bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. +primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool +primRepCompatible platform rep1 rep2 = + (isUnboxed rep1 == isUnboxed rep2) && + (primRepSizeB platform rep1 == primRepSizeB platform rep2) && + (primRepIsFloat rep1 == primRepIsFloat rep2) + where + isUnboxed = not . isGcPtrRep + +-- More general version of `primRepCompatible` for types represented by zero or +-- more than one PrimReps. +primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool +primRepsCompatible platform reps1 reps2 = + length reps1 == length reps2 && + and (zipWith (primRepCompatible platform) reps1 reps2) + +-- | The size of a 'PrimRep' in bytes. +-- +-- This applies also when used in a constructor, where we allow packing the +-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will +-- take only 8 bytes, which for 64-bit arch will be equal to 1 word. +-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are +-- laid out. +primRepSizeB :: Platform -> PrimRep -> Int +primRepSizeB platform = \case + IntRep -> platformWordSizeInBytes platform + WordRep -> platformWordSizeInBytes platform + Int8Rep -> 1 + Int16Rep -> 2 + Int32Rep -> 4 + Int64Rep -> wORD64_SIZE + Word8Rep -> 1 + Word16Rep -> 2 + Word32Rep -> 4 + Word64Rep -> wORD64_SIZE + FloatRep -> fLOAT_SIZE + DoubleRep -> dOUBLE_SIZE + AddrRep -> platformWordSizeInBytes platform + LiftedRep -> platformWordSizeInBytes platform + UnliftedRep -> platformWordSizeInBytes platform + VoidRep -> 0 + (VecRep len rep) -> len * primElemRepSizeB rep + +primElemRepSizeB :: PrimElemRep -> Int +primElemRepSizeB Int8ElemRep = 1 +primElemRepSizeB Int16ElemRep = 2 +primElemRepSizeB Int32ElemRep = 4 +primElemRepSizeB Int64ElemRep = 8 +primElemRepSizeB Word8ElemRep = 1 +primElemRepSizeB Word16ElemRep = 2 +primElemRepSizeB Word32ElemRep = 4 +primElemRepSizeB Word64ElemRep = 8 +primElemRepSizeB FloatElemRep = 4 +primElemRepSizeB DoubleElemRep = 8 + +-- | Return if Rep stands for floating type, +-- returns Nothing for vector types. +primRepIsFloat :: PrimRep -> Maybe Bool +primRepIsFloat FloatRep = Just True +primRepIsFloat DoubleRep = Just True +primRepIsFloat (VecRep _ _) = Nothing +primRepIsFloat _ = Just False + + +{- +************************************************************************ +* * + Field labels +* * +************************************************************************ +-} + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabels :: TyCon -> [FieldLabel] +tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabelEnv :: TyCon -> FieldLabelEnv +tyConFieldLabelEnv tc + | isAlgTyCon tc = algTcFields tc + | otherwise = emptyDFsEnv + +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl + +-- | Make a map from strings to FieldLabels from all the data +-- constructors of this algebraic tycon +fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv +fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) + | fl <- dataConsFields (visibleDataCons rhs) ] + where + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs + + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +-- | Given the name of the function type constructor and it's kind, create the +-- corresponding 'TyCon'. It is recommended to use 'GHC.Core.TyCo.Rep.funTyCon' if you want +-- this functionality +mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon +mkFunTyCon name binders rep_nm + = FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConResKind = liftedTypeKind, + tyConKind = mkTyConKind binders liftedTypeKind, + tyConArity = length binders, + tcRepName = rep_nm + } + +-- | This is the making of an algebraic 'TyCon'. Notably, you have to +-- pass in the generic (in the -XGenerics sense) information about the +-- type constructor - you can get hold of it easily (see Generics +-- module) +mkAlgTyCon :: Name + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> TyCon +mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcFields = fieldsOfAlgTcRhs rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcGadtSyntax = gadt_syn + } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class + -> Name -> TyCon +mkClassTyCon name binders roles rhs clas tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) + False + +mkTupleTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Result kind of the 'TyCon' + -> Arity -- ^ Arity of the tuple 'TyCon' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> AlgTyConFlav + -> TyCon +mkTupleTyCon name binders res_kind arity con sort parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = binderVars binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = TupleTyCon { data_con = con, + tup_sort = sort }, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> Arity -- ^ Arity of the sum + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind arity tyvars cons parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = tyvars, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = mkSumTyConRhs cons, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +-- | Makes a tycon suitable for use during type-checking. It stores +-- a variety of details about the definition of the TyCon, but no +-- right-hand side. It lives only during the type-checking of a +-- mutually-recursive group of tycons; it is then zonked to a proper +-- TyCon in zonkTcTyCon. +-- See also Note [Kind checking recursive type and class declarations] +-- in "GHC.Tc.TyCl". +mkTcTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ /result/ kind only + -> [(Name,TcTyVar)] -- ^ Scoped type variables; + -- see Note [How TcTyCons work] in GHC.Tc.TyCl + -> Bool -- ^ Is this TcTyCon generalised already? + -> TyConFlavour -- ^ What sort of 'TyCon' this represents + -> TyCon +mkTcTyCon name binders res_kind scoped_tvs poly flav + = TcTyCon { tyConUnique = getUnique name + , tyConName = name + , tyConTyVars = binderVars binders + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tcTyConScopedTyVars = scoped_tvs + , tcTyConIsPoly = poly + , tcTyConFlavour = flav } + +-- | No scoped type variables (to be used with mkTcTyCon). +noTcTyConScopedTyVars :: [(Name, TcTyVar)] +noTcTyConScopedTyVars = [] + +-- | Create an unlifted primitive 'TyCon', such as @Int#@. +mkPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -> [Role] -> TyCon +mkPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) + +-- | Kind constructors +mkKindTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> Name -> TyCon +mkKindTyCon name binders res_kind roles rep_nm + = tc + where + tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + +-- | Create a lifted primitive 'TyCon' such as @RealWorld@ +mkLiftedPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> TyCon +mkLiftedPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + where rep_nm = mkPrelTyConRepName name + +mkPrimTyCon' :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -- (If you need a levity-polymorphic PrimTyCon, change + -- isTcLevPoly.) + -> [Role] + -> Bool -> Maybe TyConRepName -> TyCon +mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm + = PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length roles, + tcRoles = roles, + isUnlifted = is_unlifted, + primRepName = rep_nm + } + +-- | Create a type synonym 'TyCon' +mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> Type -> Bool -> Bool -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + = SynonymTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + synTcRhs = rhs, + synIsTau = is_tau, + synIsFamFree = is_fam_free + } + +-- | Create a type family 'TyCon' +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind resVar flav parent inj + = FamilyTyCon + { tyConUnique = nameUnique name + , tyConName = name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConTyVars = binderVars binders + , famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj + } + + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> TyConRepName + -> [TyConTyCoBinder] -> Kind -> [Role] + -> RuntimeRepInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info + = PromotedDataCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConArity = length roles, + tcRoles = roles, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + dataCon = con, + tcRepName = rep_name, + promDcRepInfo = rep_info + } + +isFunTyCon :: TyCon -> Bool +isFunTyCon (FunTyCon {}) = True +isFunTyCon _ = False + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True +isAbstractTyCon _ = False + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (PrimTyCon {}) = True +isPrimTyCon _ = False + +-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can +-- only be true for primitive and unboxed-tuple 'TyCon's +isUnliftedTyCon :: TyCon -> Bool +isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) + = is_unlifted +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | SumTyCon {} <- rhs + = True +isUnliftedTyCon _ = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (AlgTyCon {}) = True +isAlgTyCon _ = False + +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True +isVanillaAlgTyCon _ = False + +-- | Returns @True@ for the 'TyCon' of the 'Constraint' kind. +{-# INLINE isConstraintKindCon #-} -- See Note [Inlining coreView] in GHC.Core.Type +isConstraintKindCon :: TyCon -> Bool +-- NB: We intentionally match on AlgTyCon, because 'constraintKindTyCon' is +-- always an AlgTyCon (see 'pcTyCon' in TysWiredIn) and the record selector +-- for 'tyConUnique' would generate unreachable code for every other data +-- constructor of TyCon (see #18026). +isConstraintKindCon AlgTyCon { tyConUnique = u } = u == constraintKindTyConKey +isConstraintKindCon _ = False + +isDataTyCon :: TyCon -> Bool +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level +-- @case@ expressions, and they get info tables allocated for them. +-- +-- Generally, the function will be true for all @data@ types and false +-- for @newtype@s, unboxed tuples, unboxed sums and type family +-- 'TyCon's. But it is not guaranteed to return @True@ in all cases +-- that it could. +-- +-- NB: for a data type family, only the /instance/ 'TyCon's +-- get an info table. The family declaration 'TyCon' does not +isDataTyCon (AlgTyCon {algTcRhs = rhs}) + = case rhs of + TupleTyCon { tup_sort = sort } + -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False + DataTyCon {} -> True + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon _ = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) +-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) +-- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical" +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon _ Phantom = False +isInjectiveTyCon (FunTyCon {}) _ = True +isInjectiveTyCon (AlgTyCon {}) Nominal = True +isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational + = isGenInjAlgRhs rhs +isInjectiveTyCon (SynonymTyCon {}) _ = False +isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + Nominal = True +isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj +isInjectiveTyCon (FamilyTyCon {}) _ = False +isInjectiveTyCon (PrimTyCon {}) _ = True +isInjectiveTyCon (PromotedDataCon {}) _ = True +isInjectiveTyCon (TcTyCon {}) _ = True + -- Reply True for TcTyCon to minimise knock on type errors + -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl + +-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T tys ~X t), then (t's head ~X T). +-- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical" +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True +isGenerativeTyCon (FamilyTyCon {}) _ = False + -- in all other cases, injectivity implies generativity +isGenerativeTyCon tc r = isInjectiveTyCon tc r + +-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective +-- with respect to representational equality? +isGenInjAlgRhs :: AlgTyConRhs -> Bool +isGenInjAlgRhs (TupleTyCon {}) = True +isGenInjAlgRhs (SumTyCon {}) = True +isGenInjAlgRhs (DataTyCon {}) = True +isGenInjAlgRhs (AbstractTyCon {}) = False +isGenInjAlgRhs (NewTyCon {}) = False + +-- | Is this 'TyCon' that for a @newtype@ +isNewTyCon :: TyCon -> Bool +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True +isNewTyCon _ = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = co, + nt_rhs = rhs }}) + = Just (tvs, rhs, co) +unwrapNewTyCon_maybe _ = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, + nt_etad_rhs = (tvs,rhs) }}) + = Just (tvs, rhs, co) +unwrapNewTyConEtad_maybe _ = Nothing + +isProductTyCon :: TyCon -> Bool +-- True of datatypes or newtypes that have +-- one, non-existential, data constructor +-- See Note [Product types] +isProductTyCon tc@(AlgTyCon {}) + = case algTcRhs tc of + TupleTyCon {} -> True + DataTyCon{ data_cons = [data_con] } + -> null (dataConExTyCoVars data_con) + NewTyCon {} -> True + _ -> False +isProductTyCon _ = False + +isDataProductTyCon_maybe :: TyCon -> Maybe DataCon +-- True of datatypes (not newtypes) with +-- one, vanilla, data constructor +-- See Note [Product types] +isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [con] } + | null (dataConExTyCoVars con) -- non-existential + -> Just con + TupleTyCon { data_con = con } + -> Just con + _ -> Nothing +isDataProductTyCon_maybe _ = Nothing + +isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] +isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = cons } + | cons `lengthExceeds` 1 + , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + SumTyCon { data_cons = cons } + | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + _ -> Nothing +isDataSumTyCon_maybe _ = Nothing + +{- Note [Product types] +~~~~~~~~~~~~~~~~~~~~~~~ +A product type is + * A data type (not a newtype) + * With one, boxed data constructor + * That binds no existential type variables + +The main point is that product types are amenable to unboxing for + * Strict function calls; we can transform + f (D a b) = e + to + fw a b = e + via the worker/wrapper transformation. (Question: couldn't this + work for existentials too?) + + * CPR for function results; we can transform + f x y = let ... in D a b + to + fw x y = let ... in (# a, b #) + +Note that the data constructor /can/ have evidence arguments: equality +constraints, type classes etc. So it can be GADT. These evidence +arguments are simply value arguments, and should not get in the way. +-} + + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (SynonymTyCon {}) = True +isTypeSynonymTyCon _ = False + +isTauTyCon :: TyCon -> Bool +isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau +isTauTyCon _ = True + +isFamFreeTyCon :: TyCon -> Bool +isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free +isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isFamFreeTyCon _ = True + +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- + +-- | True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective and generative w.r.t nominal equality? +-- That is, if (T a b) ~N d e f, is it always the case that +-- (T ~N d), (a ~N e) and (b ~N f)? +-- Specifically NOT true of synonyms (open and otherwise) +-- +-- It'd be unusual to call mustBeSaturated on a regular H98 +-- type synonym, because you should probably have expanded it first +-- But regardless, it's not decomposable +mustBeSaturated :: TyCon -> Bool +mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res +isGadtSyntaxTyCon _ = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in GHC.Core.TyCon +isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) + = case rhs of + DataTyCon { is_enum = res } -> res + TupleTyCon {} -> arity == 0 + _ -> False +isEnumerationTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (FamilyTyCon {}) = True +isFamilyTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) + | OpenSynFamilyTyCon <- flav = True + | DataFamilyTyCon {} <- flav = True +isOpenFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) +isTypeFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isDataFamilyTyCon _ = False + +-- | Is this an open type family TyCon? +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenTypeFamilyTyCon _ = False + +-- | Is this a non-empty closed type family? Returns 'Nothing' for +-- abstract or empty closed families. +isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyConWithAxiom_maybe + (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb +isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing + +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an +-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is +-- injective), or 'NotInjective' otherwise. +tyConInjectivityInfo :: TyCon -> Injectivity +tyConInjectivityInfo tc + | FamilyTyCon { famTcInj = inj } <- tc + = inj + | isInjectiveTyCon tc Nominal + = Injective (replicate (tyConArity tc) True) + | otherwise + = NotInjective + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe + (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops +isBuiltInSynFamTyCon_maybe _ = Nothing + +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family + +-- | Is this TyCon for an associated type? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . tyConAssoc_maybe + +-- | Get the enclosing class TyCon (if there is one) for the given TyCon. +tyConAssoc_maybe :: TyCon -> Maybe TyCon +tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon +tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True +isTupleTyCon _ = False + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort} <- rhs = Just sort +tyConTuple_maybe _ = Nothing + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnboxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = isBoxed (tupleSortBoxity sort) +isBoxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) + | SumTyCon {} <- rhs + = True +isUnboxedSumTyCon _ = False + +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (PromotedDataCon {}) = True +isPromotedDataCon _ = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc +isPromotedDataCon_maybe _ = Nothing + +-- | Is this tycon really meant for use at the kind level? That is, +-- should it be permitted without -XDataKinds? +isKindTyCon :: TyCon -> Bool +isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys + +-- | These TyCons should be allowed at the kind level, even without +-- -XDataKinds. +kindTyConKeys :: UniqSet Unique +kindTyConKeys = unionManyUniqSets + ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] + : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon ] ) + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tuples are wired-in and implicit, +-- but constraint tuples are not) +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (FunTyCon {}) = True +isImplicitTyCon (PrimTyCon {}) = True +isImplicitTyCon (PromotedDataCon {}) = True +isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) + | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True + | otherwise = False +isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent +isImplicitTyCon (SynonymTyCon {}) = False +isImplicitTyCon (TcTyCon {}) = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc +tyConCType_maybe _ = Nothing + +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TcTyCon {}) = True +isTcTyCon _ = False + +setTcTyConKind :: TyCon -> Kind -> TyCon +-- Update the Kind of a TcTyCon +-- The new kind is always a zonked version of its previous +-- kind, so we don't need to update any other fields. +-- See Note [The Purely Kinded Invariant] in GHC.Tc.Gen.HsType +setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } +setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) + +-- | Could this TyCon ever be levity-polymorphic when fully applied? +-- True is safe. False means we're sure. Does only a quick check +-- based on the TyCon's category. +-- Precondition: The fully-applied TyCon has kind (TYPE blah) +isTcLevPoly :: TyCon -> Bool +isTcLevPoly FunTyCon{} = False +isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) + | UnboxedAlgTyCon _ <- parent + = True + | NewTyCon { nt_lev_poly = lev_poly } <- rhs + = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360) + | otherwise + = False +isTcLevPoly SynonymTyCon{} = True +isTcLevPoly FamilyTyCon{} = True +isTcLevPoly PrimTyCon{} = False +isTcLevPoly TcTyCon{} = False +isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +expandSynTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], + Type, + [tyco]) -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application + +-- ^ Expand a type synonym application, if any +expandSynTyCon_maybe tc tys + | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc + = case tys `listLengthCmp` arity of + GT -> Just (tvs `zip` tys, rhs, drop arity tys) + EQ -> Just (tvs `zip` tys, rhs, []) + LT -> Nothing + | otherwise + = Nothing + +---------------- + +-- | Check if the tycon actually refers to a proper `data` or `newtype` +-- with user defined constructors rather than one from a class or other +-- construction. + +-- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an +-- exported tycon can have a pattern synonym bundled with it, e.g., +-- module Foo (TyCon(.., PatSyn)) where +isTyConWithSrcDataCons :: TyCon -> Bool +isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = + case rhs of + DataTyCon {} -> isSrcParent + NewTyCon {} -> isSrcParent + TupleTyCon {} -> isSrcParent + _ -> False + where + isSrcParent = isNoParent parent +isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) + = True -- #14058 +isTyConWithSrcDataCons _ = False + + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) + = case rhs of + DataTyCon { data_cons = cons } -> Just cons + NewTyCon { data_con = con } -> Just [con] + TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons + _ -> Nothing +tyConDataCons_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. In any +-- other case, the function panics +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + NewTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleDataCon_maybe _ = Nothing + +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + Just c -> c + Nothing -> pprPanic "tyConDataCon" (ppr tc) + +tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon +-- Returns (Just con) for single-constructor +-- *algebraic* data types *not* newtypes +tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleAlgDataCon_maybe _ = Nothing + +-- | Determine the number of value constructors a 'TyCon' has. Panics if the +-- 'TyCon' is not algebraic or a tuple +tyConFamilySize :: TyCon -> Int +tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons_size = size } -> size + NewTyCon {} -> 1 + TupleTyCon {} -> 1 + SumTyCon { data_cons_size = size } -> size + _ -> pprPanic "tyConFamilySize 1" (ppr tc) +tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs other = pprPanic "algTyConRhs" (ppr other) + +-- | Extract type variable naming the result of injective type family +tyConFamilyResVar_maybe :: TyCon -> Maybe Name +tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res +tyConFamilyResVar_maybe _ = Nothing + +-- | Get the list of roles for the type parameters of a TyCon +tyConRoles :: TyCon -> [Role] +-- See also Note [TyCon Role signatures] +tyConRoles tc + = case tc of + { FunTyCon {} -> [Nominal, Nominal, Nominal, Representational, Representational] + ; AlgTyCon { tcRoles = roles } -> roles + ; SynonymTyCon { tcRoles = roles } -> roles + ; FamilyTyCon {} -> const_role Nominal + ; PrimTyCon { tcRoles = roles } -> roles + ; PromotedDataCon { tcRoles = roles } -> roles + ; TcTyCon {} -> const_role Nominal + } + where + const_role r = replicate (tyConArity tc) r + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) + = (tvs, rhs) +newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) + = length (fst tvs_rhs) +newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs +newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +newTyConDataCon_maybe :: TyCon -> Maybe DataCon +newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con +newTyConDataCon_maybe _ = Nothing + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@ +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid +tyConStupidTheta (FunTyCon {}) = [] +tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav +famTyConFlav_maybe _ = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True +isClassTyCon _ = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas +tyConClass_maybe _ = Nothing + +-- | Return the associated types of the 'TyCon', if any +tyConATs :: TyCon -> [TyCon] +tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas +tyConATs _ = [] + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) + = True +isFamInstTyCon _ = False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) + = Just (f, ts, ax) +tyConFamInstSig_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) + = Just (f, ts) +tyConFamInst_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) + = Just ax +tyConFamilyCoercion_maybe _ = Nothing + +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo +tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri +tyConRuntimeRepInfo _ = NoRRI + -- could panic in that second case. But Douglas Adams told me not to. + +{- +Note [Constructor tag allocation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking we need to allocate constructor tags to constructors. +They are allocated based on the position in the data_cons field of TyCon, +with the first constructor getting fIRST_TAG. + +We used to pay linear cost per constructor, with each constructor looking up +its relative index in the constructor list. That was quadratic and prohibitive +for large data types with more than 10k constructors. + +The current strategy is to build a NameEnv with a mapping from constructor's +Name to ConTag and pass it down to buildDataCon for efficient lookup. + +Relevant ticket: #14657 +-} + +mkTyConTagMap :: TyCon -> NameEnv ConTag +mkTyConTagMap tycon = + mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] + -- See Note [Constructor tag allocation] + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. +-} + +instance Eq TyCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc + where + pp_tc = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if ((debug || dumpStyle sty) && isTcTyCon tc) + then text "[tc]" + else empty + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving Eq + +instance Outputable TyConFlavour where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (DataFamilyFlavour (Just _)) = "associated data family" + go (DataFamilyFlavour Nothing) = "data family" + go (OpenTypeFamilyFlavour (Just _)) = "associated type family" + go (OpenTypeFamilyFlavour Nothing) = "type family" + go ClosedTypeFamilyFlavour = "type family" + go TypeSynonymFlavour = "type synonym" + go BuiltInTypeFlavour = "built-in type" + go PromotedDataConFlavour = "promoted data constructor" + +tyConFlavour :: TyCon -> TyConFlavour +tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) + | ClassTyCon _ _ <- parent = ClassFlavour + | otherwise = case rhs of + TupleTyCon { tup_sort = sort } + -> TupleFlavour (tupleSortBoxity sort) + SumTyCon {} -> SumFlavour + DataTyCon {} -> DataTypeFlavour + NewTyCon {} -> NewtypeFlavour + AbstractTyCon {} -> AbstractTypeFlavour +tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) + = case flav of + DataFamilyTyCon{} -> DataFamilyFlavour parent + OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour + AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour + BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour +tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour +tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour +tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav + +-- | Can this flavour of 'TyCon' appear unsaturated? +tcFlavourMustBeSaturated :: TyConFlavour -> Bool +tcFlavourMustBeSaturated ClassFlavour = False +tcFlavourMustBeSaturated DataTypeFlavour = False +tcFlavourMustBeSaturated NewtypeFlavour = False +tcFlavourMustBeSaturated DataFamilyFlavour{} = False +tcFlavourMustBeSaturated TupleFlavour{} = False +tcFlavourMustBeSaturated SumFlavour = False +tcFlavourMustBeSaturated AbstractTypeFlavour = False +tcFlavourMustBeSaturated BuiltInTypeFlavour = False +tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated TypeSynonymFlavour = True +tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True +tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True + +-- | Is this flavour of 'TyCon' an open type family or a data family? +tcFlavourIsOpen :: TyConFlavour -> Bool +tcFlavourIsOpen DataFamilyFlavour{} = True +tcFlavourIsOpen OpenTypeFamilyFlavour{} = True +tcFlavourIsOpen ClosedTypeFamilyFlavour = False +tcFlavourIsOpen ClassFlavour = False +tcFlavourIsOpen DataTypeFlavour = False +tcFlavourIsOpen NewtypeFlavour = False +tcFlavourIsOpen TupleFlavour{} = False +tcFlavourIsOpen SumFlavour = False +tcFlavourIsOpen AbstractTypeFlavour = False +tcFlavourIsOpen BuiltInTypeFlavour = False +tcFlavourIsOpen PromotedDataConFlavour = False +tcFlavourIsOpen TypeSynonymFlavour = False + +pprPromotionQuote :: TyCon -> SDoc +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc + = case tc of + PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types + _ -> empty + +instance NamedThing TyCon where + getName = tyConName + +instance Data.Data TyCon where + -- don't traverse? + toConstr _ = abstractConstr "TyCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "TyCon" + +instance Binary Injectivity where + put_ bh NotInjective = putByte bh 0 + put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs + + get bh = do { h <- getByte bh + ; case h of + 0 -> return NotInjective + _ -> do { xs <- get bh + ; return (Injective xs) } } + +{- +************************************************************************ +* * + Walking over recursive TyCons +* * +************************************************************************ + +Note [Expanding newtypes and products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that + * We can expand T, even though it's recursive. + * We can expand Id (Id Int), even though the Id shows up + twice at the outer level, because Id is non-recursive + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bail out if we see it again. + +We sometimes want to do the same for product types, so that the +strictness analyser doesn't unbox infinitely deeply. + +More precisely, we keep a *count* of how many times we've seen it. +This is to account for + data instance T (a,b) = MkT (T a) (T b) +Then (#10482) if we have a type like + T (Int,(Int,(Int,(Int,Int)))) +we can still unbox deeply enough during strictness analysis. +We have to treat T as potentially recursive, but it's still +good to be able to unwrap multiple layers. + +The function that manages all this is checkRecTc. +-} + +data RecTcChecker = RC !Int (NameEnv Int) + -- The upper bound, and the number of times + -- we have encountered each TyCon + +-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. +initRecTc :: RecTcChecker +initRecTc = RC defaultRecTcMaxBound emptyNameEnv + +-- | The default upper bound (100) for the number of times a 'RecTcChecker' is +-- allowed to encounter each 'TyCon'. +defaultRecTcMaxBound :: Int +defaultRecTcMaxBound = 100 +-- Should we have a flag for this? + +-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed +-- to encounter each 'TyCon'. +setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker +setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts + +checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker +-- Nothing => Recursion detected +-- Just rec_tcs => Keep going +checkRecTc (RC bound rec_nts) tc + = case lookupNameEnv rec_nts tc_name of + Just n | n >= bound -> Nothing + | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) + Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) + where + tc_name = tyConName tc + +-- | Returns whether or not this 'TyCon' is definite, or a hole +-- that may be filled in at some later point. See Note [Skolem abstract data] +tyConSkolem :: TyCon -> Bool +tyConSkolem = isHoleName . tyConName + +-- Note [Skolem abstract data] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Skolem abstract data arises from data declarations in an hsig file. +-- +-- The best analogy is to interpret the types declared in signature files as +-- elaborating to universally quantified type variables; e.g., +-- +-- unit p where +-- signature H where +-- data T +-- data S +-- module M where +-- import H +-- f :: (T ~ S) => a -> b +-- f x = x +-- +-- elaborates as (with some fake structural types): +-- +-- p :: forall t s. { f :: forall a b. t ~ s => a -> b } +-- p = { f = \x -> x } -- ill-typed +-- +-- It is clear that inside p, t ~ s is not provable (and +-- if we tried to write a function to cast t to s, that +-- would not work), but if we call p @Int @Int, clearly Int ~ Int +-- is provable. The skolem variables are all distinct from +-- one another, but we can't make assumptions like "f is +-- inaccessible", because the skolem variables will get +-- instantiated eventually! +-- +-- Skolem abstractness can apply to "non-abstract" data as well): +-- +-- unit p where +-- signature H1 where +-- data T = MkT +-- signature H2 where +-- data T = MkT +-- module M where +-- import qualified H1 +-- import qualified H2 +-- f :: (H1.T ~ H2.T) => a -> b +-- f x = x +-- +-- This is why the test is on the original name of the TyCon, +-- not whether it is abstract or not. diff --git a/GHC/Core/TyCon.hs-boot b/GHC/Core/TyCon.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCon.hs-boot @@ -0,0 +1,12 @@ +module GHC.Core.TyCon where + +import GHC.Prelude +import GHC.Types.Unique ( Uniquable ) + +data TyCon + +instance Uniquable TyCon + +isTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Type.hs @@ -0,0 +1,3271 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 +-- +-- Type - public interface + +{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Main functions for manipulating types and type-related things +module GHC.Core.Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), + Specificity(..), + KindOrType, PredType, ThetaType, + Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, + Mult, Scaled, + KnotTied, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, varType, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, + splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, + + mkVisFunTy, mkInvisFunTy, + mkVisFunTys, + mkVisFunTyMany, mkInvisFunTyMany, + mkVisFunTysMany, mkInvisFunTysMany, + splitFunTy, splitFunTy_maybe, + splitFunTys, funResultTy, funArgTy, + + mkTyConApp, mkTyConTy, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, tyConAppArgN, + tcSplitTyConApp_maybe, + splitListTyConApp_maybe, + repSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTy, mkSpecForAllTys, + mkVisForAllTys, mkTyCoInvForAllTy, + mkInfForAllTy, mkInfForAllTys, + splitForAllTys, + splitForAllTysReq, splitForAllTysInvis, + splitForAllVarBndrs, + splitForAllTy_maybe, splitForAllTy, + splitForAllTy_ty_maybe, splitForAllTy_co_maybe, + splitPiTy_maybe, splitPiTy, splitPiTys, + mkTyConBindersPreferAnon, + mkPiTy, mkPiTys, + piResultTy, piResultTys, + applyTysX, dropForAlls, + mkFamilyTyConApp, + buildSynTyCon, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + isLitTy, + + isPredTy, + + getRuntimeRep_maybe, kindRep_maybe, kindRep, + + mkCastTy, mkCoercionTy, splitCastTy_maybe, + + userTypeError_maybe, pprUserTypeErrorTy, + + coAxNthLHS, + stripCoercionTy, + + splitPiTysInvisible, splitPiTysInvisibleN, + invisibleTyBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, + partitionInvisibleTypes, partitionInvisibles, + tyConArgFlags, appTyArgFlags, + synTyConResKind, + + -- ** Analyzing types + TyCoMapper(..), mapTyCo, mapTyCoX, + TyCoFolder(..), foldTyCo, + + -- (Newtypes) + newTyConInstRhs, + + -- ** Binders + sameVis, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinder, mkTyVarBinders, + tyVarSpecToBinders, + mkAnonBinder, + isAnonTyCoBinder, + binderVar, binderVars, binderType, binderArgFlag, + tyCoBinderType, tyCoBinderVar_maybe, + tyBinderType, + binderRelevantType_maybe, + isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, + isInvisibleBinder, isNamedBinder, + tyConBindersTyCoBinders, + + -- ** Common type constructors + funTyCon, unrestrictedFunTyCon, + + -- ** Predicates on types + isTyVarTy, isFunTy, isCoercionTy, + isCoercionTy_maybe, isForAllTy, + isForAllTy_ty, isForAllTy_co, + isPiTy, isTauTy, isFamFreeTy, + isCoVarType, isAtomicTy, + + isValidJoinPointType, + tyConAppNeedsKindSig, + + -- *** Levity and boxity + isLiftedType_maybe, + isLiftedTypeKind, isUnliftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, + isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, + isAlgType, isDataFamilyAppType, + isPrimitiveType, isStrictType, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + getRuntimeRep, + + -- * Multiplicity + + isMultiplicityTy, isMultiplicityVar, + unrestricted, linear, tymult, + mkScaled, irrelevantMult, scaledSet, + pattern One, pattern Many, + isOneDataConTy, isManyDataConTy, + isLinearType, + + -- * Main data types representing Kinds + Kind, + + -- ** Finding the kind of a type + typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly, + tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, + tcIsRuntimeTypeKind, + + -- ** Common Kind + liftedTypeKind, + + -- * Type free variables + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, + + noFreeVarsOfType, + splitVisVarsOfType, splitVisVarsOfTypes, + expandTypeSynonyms, + typeSize, occCheckExpand, + + -- ** Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Well-scoped lists of variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- * Type comparison + eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, + nonDetCmpTypesX, nonDetCmpTc, + eqVarBndrs, + + -- * Forcing evaluation of types + seqType, seqTypes, + + -- * Other views onto Types + coreView, tcView, + + tyConsOfType, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + TCvSubst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + + mkTCvSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, + notElemTCvSubst, + getTvSubstEnv, setTvSubstEnv, + zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendCvSubst, + extendTvSubst, extendTvSubstBinderAndInScope, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + extendTvSubstWithClone, + extendTCvSubstWithClone, + isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptyTCvSubst, unionTCvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked, + substThetaUnchecked, substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyTyCoVarBinder, tidyTyCoVarBinders, + + -- * Kinds + isConstraintKindCon, + classifiesTypeWithValues, + isKindLevPoly + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Basic + +-- We import the representation and primitive functions from GHC.Core.TyCo.Rep. +-- Many things are reexported, but not the representation! + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs + +-- friends: +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set + +import GHC.Core.TyCon +import GHC.Builtin.Types.Prim +import {-# SOURCE #-} GHC.Builtin.Types + ( listTyCon, typeNatKind + , typeSymbolKind, liftedTypeKind + , constraintKind + , unrestrictedFunTyCon + , manyDataConTy, oneDataConTy ) +import GHC.Types.Name( Name ) +import GHC.Builtin.Names +import GHC.Core.Coercion.Axiom +import {-# SOURCE #-} GHC.Core.Coercion + ( mkNomReflCo, mkGReflCo, mkReflCo + , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo + , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo + , decomposePiCos, coercionKind, coercionLKind + , coercionRKind, coercionType + , isReflexiveCo, seqCo ) + +-- others +import GHC.Utils.Misc +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.List.SetOps +import GHC.Types.Unique ( nonDetCmpUnique ) + +import GHC.Data.Maybe ( orElse, expectJust ) +import Data.Maybe ( isJust ) +import Control.Monad ( guard ) + +-- $type_classification +-- #type_classification# +-- +-- Types are one of: +-- +-- [Unboxed] Iff its representation is other than a pointer +-- Unboxed types are also unlifted. +-- +-- [Lifted] Iff it has bottom as an element. +-- Closures always have lifted types: i.e. any +-- let-bound identifier in Core must have a lifted +-- type. Operationally, a lifted object is one that +-- can be entered. +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. This is /not/ the same as +-- lifted types, because we also include unboxed +-- tuples in this classification. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of its abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ + +Note [coreView vs tcView] +~~~~~~~~~~~~~~~~~~~~~~~~~ +So far as the typechecker is concerned, 'Constraint' and 'TYPE +LiftedRep' are distinct kinds. + +But in Core these two are treated as identical. + +We implement this by making 'coreView' convert 'Constraint' to 'TYPE +LiftedRep' on the fly. The function tcView (used in the type checker) +does not do this. + +See also #11715, which tracks removing this inconsistency. + +-} + +-- | Gives the typechecker view of a type. This unwraps synonyms but +-- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into +-- TYPE LiftedRep. Returns Nothing if no unwrapping happens. +-- See also Note [coreView vs tcView] +{-# INLINE tcView #-} +tcView :: Type -> Maybe Type +tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- The free vars of 'rhs' should all be bound by 'tenv', so it's + -- ok to use 'substTy' here. + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! +tcView _ = Nothing + +{-# INLINE coreView #-} +coreView :: Type -> Maybe Type +-- ^ This function Strips off the /top layer only/ of a type synonym +-- application (if any) its underlying representation type. +-- Returns Nothing if there is nothing to look through. +-- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. +-- +-- By being non-recursive and inlined, this case analysis gets efficiently +-- joined onto the case analysis that the caller is already doing +coreView ty@(TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- This equation is exactly like tcView + + -- At the Core level, Constraint = Type + -- See Note [coreView vs tcView] + | isConstraintKindCon tc + = ASSERT2( null tys, ppr ty ) + Just liftedTypeKind + +coreView _ = Nothing + +{-# INLINE coreFullView #-} +coreFullView :: Type -> Type +-- ^ Iterates 'coreView' until there is no more to synonym to expand. +-- See Note [Inlining coreView]. +coreFullView ty@(TyConApp tc _) + | isTypeSynonymTyCon tc || isConstraintKindCon tc = go ty + where + go ty + | Just ty' <- coreView ty = go ty' + | otherwise = ty + +coreFullView ty = ty + +{- Note [Inlining coreView] in GHC.Core.Type +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very common to have a function + + f :: Type -> ... + f ty | Just ty' <- coreView ty = f ty' + f (TyVarTy ...) = ... + f ... = ... + +If f is not otherwise recursive, the initial call to coreView +causes f to become recursive, which kills the possibility of +inlining. Instead, for non-recursive functions, we prefer to +use coreFullView, which guarantees to unwrap top-level type +synonyms. It can be inlined and is efficient and non-allocating +in its fast path. For this to really be fast, all calls made +on its fast path must also be inlined, linked back to this Note. +-} + +----------------------------------------------- +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +-- +-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, +-- not in the kinds of any TyCon or TyVar mentioned in the type. +-- +-- Keep this synchronized with 'synonymTyConsOfType' +expandTypeSynonyms ty + = go (mkEmptyTCvSubst in_scope) ty + where + in_scope = mkInScopeSet (tyCoVarsOfType ty) + + go subst (TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys + = let subst' = mkTvSubst in_scope (mkVarEnv tenv) + -- Make a fresh substitution; rhs has nothing to + -- do with anything that has happened so far + -- NB: if you make changes here, be sure to build an + -- /idempotent/ substitution, even in the nested case + -- type T a b = a -> b + -- type S x y = T y x + -- (#11665) + in mkAppTys (go subst' rhs) tys' + | otherwise + = TyConApp tc expanded_tys + where + expanded_tys = (map (go subst) tys) + + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst ty@(FunTy _ mult arg res) + = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res } + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_mco _ MRefl = MRefl + go_mco subst (MCo co) = MCo (go_co subst co) + + go_co subst (Refl ty) + = mkNomReflCo (go subst ty) + go_co subst (GRefl r ty mco) + = mkGReflCo r (go subst ty) (go_mco subst mco) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = mkTyConAppCo r tc (map (go_co subst) args) + go_co subst (AppCo co arg) + = mkAppCo (go_co subst co) (go_co subst arg) + go_co subst (ForAllCo tv kind_co co) + = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in + mkForAllCo tv' kind_co' (go_co subst' co) + go_co subst (FunCo r w co1 co2) + = mkFunCo r (go_co subst w) (go_co subst co1) (go_co subst co2) + go_co subst (CoVarCo cv) + = substCoVar subst cv + go_co subst (AxiomInstCo ax ind args) + = mkAxiomInstCo ax ind (map (go_co subst) args) + go_co subst (UnivCo p r t1 t2) + = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + go_co subst (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + go_co subst (NthCo r n co) + = mkNthCo r n (go_co subst co) + go_co subst (LRCo lr co) + = mkLRCo lr (go_co subst co) + go_co subst (InstCo co arg) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (KindCo co) + = mkKindCo (go_co subst co) + go_co subst (SubCo co) + = mkSubCo (go_co subst co) + go_co subst (AxiomRuleCo ax cs) + = AxiomRuleCo ax (map (go_co subst) cs) + go_co _ (HoleCo h) + = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) + go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) + go_prov _ p@(PluginProv _) = p + go_prov _ p@CorePrepProv = p + + -- the "False" and "const" are to accommodate the type of + -- substForAllCoBndrUsing, which is general enough to + -- handle coercion optimization (which sometimes swaps the + -- order of a coercion) + go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst + + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> Type +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +-- Treats * and Constraint as the same +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type +kindRep_maybe kind + | TyConApp tc [arg] <- coreFullView kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing + +-- | This version considers Constraint to be the same as *. Returns True +-- if the argument is equivalent to Type/Constraint and False otherwise. +-- See Note [Kind Constraint and kind Type] +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +isLiftedRuntimeRep :: Type -> Bool +-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep +-- False of type variables (a :: RuntimeRep) +-- and of other reps e.g. (IntRep :: RuntimeRep) +isLiftedRuntimeRep rep + | TyConApp rr_tc args <- coreFullView rep + , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True + | otherwise = False + +-- | Returns True if the kind classifies unlifted types and False otherwise. +-- Note that this returns False for levity-polymorphic kinds, which may +-- be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +isUnliftedRuntimeRep :: Type -> Bool +-- True of definitely-unlifted RuntimeReps +-- False of (LiftedRep :: RuntimeRep) +-- and of variables (a :: RuntimeRep) +isUnliftedRuntimeRep rep + | TyConApp rr_tc _ <- coreFullView rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] + = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + -- But be careful of type families (F tys) :: RuntimeRep + | otherwise {- Variables, applications -} + = False + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy ty + | TyConApp tc args <- coreFullView ty + , tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True + + | otherwise = False + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + +-- | Is this the type 'Multiplicity'? +isMultiplicityTy :: Type -> Bool +isMultiplicityTy ty + | TyConApp tc [] <- coreFullView ty = tc `hasKey` multiplicityTyConKey + | otherwise = False + +-- | Is a tyvar of type 'Multiplicity'? +isMultiplicityVar :: TyVar -> Bool +isMultiplicityVar = isMultiplicityTy . tyVarKind + +{- ********************************************************************* +* * + mapType +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for ForAllCo case of mapTyCoX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. +It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches +the left-hand kind of the coercion. This is convenient lots of the time, but +not when mapping a function over a coercion. + +The problem is that tcm_tybinder will affect the TyCoVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used +to implement zonking, and it's vital that they get specialised to the TcM +monad and the particular mapper in use. + +Even specialising to the monad alone made a 20% allocation difference +in perf/compiler/T5030. + +See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this +idiom. +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> m Coercion + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". + + , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) + -- ^ The returned env is used in the extended scope + + , tcm_tycon :: TyCon -> m TyCon + -- ^ This is used only for TcTyCons + -- a) To zonk TcTyCons + -- b) To turn TcTyCons into TyCons. + -- See Note [Type checking recursive type and class declarations] + -- in "GHC.Tc.TyCl" + } + +{-# INLINE mapTyCo #-} -- See Note [Specialising mappers] +mapTyCo :: Monad m => TyCoMapper () m + -> ( Type -> m Type + , [Type] -> m [Type] + , Coercion -> m Coercion + , [Coercion] -> m[Coercion]) +mapTyCo mapper + = case mapTyCoX mapper of + (go_ty, go_tys, go_co, go_cos) + -> (go_ty (), go_tys (), go_co (), go_cos ()) + +{-# INLINE mapTyCoX #-} -- See Note [Specialising mappers] +mapTyCoX :: Monad m => TyCoMapper env m + -> ( env -> Type -> m Type + , env -> [Type] -> m [Type] + , env -> Coercion -> m Coercion + , env -> [Coercion] -> m[Coercion]) +mapTyCoX (TyCoMapper { tcm_tyvar = tyvar + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon + , tcm_covar = covar + , tcm_hole = cohole }) + = (go_ty, go_tys, go_co, go_cos) + where + go_tys _ [] = return [] + go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys + + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 + go_ty _ ty@(LitTy {}) = return ty + go_ty env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co + go_ty env (CoercionTy co) = CoercionTy <$> go_co env co + + go_ty env ty@(FunTy _ w arg res) + = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res + ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } + + go_ty env ty@(TyConApp tc tys) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConApp tc' <$> go_tys env tys } + + -- Not a TcTyCon + | null tys -- Avoid allocation in this very + = return ty -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConApp tc <$> go_tys env tys + + go_ty env (ForAllTy (Bndr tv vis) inner) + = do { (env', tv') <- tycobinder env tv vis + ; inner' <- go_ty env' inner + ; return $ ForAllTy (Bndr tv' vis) inner' } + + go_cos _ [] = return [] + go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos + + go_mco _ MRefl = return MRefl + go_mco env (MCo co) = MCo <$> (go_co env co) + + go_co env (Refl ty) = Refl <$> go_ty env ty + go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco + go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 + go_co env (FunCo r cw c1 c2) = mkFunCo r <$> go_co env cw <*> go_co env c1 <*> go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov env p <*> pure r + <*> go_ty env t1 <*> go_ty env t2 + go_co env (SymCo co) = mkSymCo <$> go_co env co + go_co env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 + go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos + go_co env (NthCo r i co) = mkNthCo r i <$> go_co env co + go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co + go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg + go_co env (KindCo co) = mkKindCo <$> go_co env co + go_co env (SubCo co) = mkSubCo <$> go_co env co + go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos + go_co env co@(TyConAppCo r tc cos) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConAppCo r tc' <$> go_cos env cos } + + -- Not a TcTyCon + | null cos -- Avoid allocation in this very + = return co -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConAppCo r tc <$> go_cos env cos + go_co env (ForAllCo tv kind_co co) + = do { kind_co' <- go_co env kind_co + ; (env', tv') <- tycobinder env tv Inferred + ; co' <- go_co env' co + ; return $ mkForAllCo tv' kind_co' co' } + -- See Note [Efficiency for ForAllCo case of mapTyCoX] + + go_prov env (PhantomProv co) = PhantomProv <$> go_co env co + go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co + go_prov _ p@(PluginProv _) = return p + go_prov _ p@CorePrepProv = return p + + +{- +************************************************************************ +* * +\subsection{Constructor-specific functions} +* * +************************************************************************ + + +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ +-} + +-- | Attempts to obtain the type variable underlying a 'Type', and panics with the +-- given message if this is not a type variable type. See also 'getTyVar_maybe' +getTyVar :: String -> Type -> TyVar +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> panic ("getTyVar: " ++ msg) + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + +-- | Attempts to obtain the type variable underlying a 'Type' +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe = repGetTyVar_maybe . coreFullView + +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind ty +getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +getCastedTyVar_maybe ty = case coreFullView ty of + CastTy (TyVarTy tv) co -> Just (tv, co) + TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv)) + _ -> Nothing + +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing + +{- +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. + +Note [Decomposing fat arrow c=>t] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unify (a b) with (Eq a => ty)? If we do so, we end up with +a partial application like ((=>) Eq a) which doesn't make sense in +source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). +Here's an example (#9858) of how you might do it: + i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +but suppose we want that. But then in the call to 'i', we end +up decomposing (Eq Int => Int), and we definitely don't want that. + +This really only applies to the type checker; in Core, '=>' and '->' +are the same, as are 'Constraint' and '*'. But for now I've put +the test in repSplitAppTy_maybe, which applies throughout, because +the other calls to splitAppTy are in GHC.Core.Unify, which is also used by +the type checker (e.g. when matching type-function equations). + +-} + +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type + -- See Note [Respecting definitional equality], invariant (EQ1). +mkAppTy (CastTy fun_ty co) arg_ty + | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] + = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co + +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + -- + -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type + -- (T t1 t2 t3) one argument at a type, thus forming + -- (T t1), (T t1 t2), etc + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy + -- Why do this? See (EQ1) of + -- Note [Respecting definitional equality] + -- in GHC.Core.TyCo.Rep + = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers + where + (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys + (args_to_cast, leftovers) = splitAtList arg_cos arg_tys + casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 + +------------- +splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! +splitAppTy_maybe = repSplitAppTy_maybe . coreFullView + +------------- +repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any Core view stuff is already done +repSplitAppTy_maybe (FunTy _ w ty1 ty2) + = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +repSplitAppTy_maybe (AppTy ty1 ty2) + = Just (ty1, ty2) + +repSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! + +repSplitAppTy_maybe _other = Nothing + +-- This one doesn't break apart (c => t). +-- See Note [Decomposing fat arrow c=>t] +-- Defined here to avoid module loops between Unify and TcType. +tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that +-- any coreView stuff is already done. Refuses to look through (c => t) +tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 }) + | InvisArg <- af + = Nothing -- See Note [Decomposing fat arrow c=>t] + | otherwise + = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcRepSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! +tcRepSplitAppTy_maybe _other = Nothing + +------------- +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = case splitAppTy_maybe ty of + Just pr -> pr + Nothing -> panic "splitAppTy" + +------------- +splitAppTys :: Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split _ (FunTy _ w ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split orig_ty _ args = (orig_ty, args) + +-- | Like 'splitAppTys', but doesn't look through type synonyms +repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) +repSplitAppTys ty = split ty [] + where + split (AppTy ty arg) args = split ty (arg:args) + split (TyConApp tc tc_args) args + = let n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split (FunTy _ w ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split ty args = (ty, args) + +{- + LitTy + ~~~~~ +-} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty + | LitTy (NumTyLit n) <- coreFullView ty = Just n + | otherwise = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty + | LitTy (StrTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + +-- | Is this a type literal (symbol or numeric). +isLitTy :: Type -> Maybe TyLit +isLitTy ty + | LitTy l <- coreFullView ty = Just l + | otherwise = Nothing + +-- | Is this type a custom user error? +-- If so, give us the kind and the error message. +userTypeError_maybe :: Type -> Maybe Type +userTypeError_maybe t + = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + + ; guard (tyConName tc == errorMessageTypeErrorFamName) + ; return msg } + +-- | Render a type corresponding to a user type error into a SDoc. +pprUserTypeErrorTy :: Type -> SDoc +pprUserTypeErrorTy ty = + case splitTyConApp_maybe ty of + + -- Text "Something" + Just (tc,[txt]) + | tyConName tc == typeErrorTextDataConName + , Just str <- isStrLitTy txt -> ftext str + + -- ShowType t + Just (tc,[_k,t]) + | tyConName tc == typeErrorShowTypeDataConName -> ppr t + + -- t1 :<>: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorAppendDataConName -> + pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 + + -- t1 :$$: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorVAppendDataConName -> + pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 + + -- An unevaluated type function + _ -> ppr ty + + + + +{- +--------------------------------------------------------------------- + FunTy + ~~~~~ + +Note [Representation of function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Functions (e.g. Int -> Char) can be thought of as being applications +of funTyCon (known in Haskell surface syntax as (->)), (note that +`RuntimeRep' quantifiers are left inferred) + + (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep} + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> Type + +However, for efficiency's sake we represent saturated applications of (->) +with FunTy. For instance, the type, + + (->) r1 r2 a b + +is equivalent to, + + FunTy (Anon a) b + +Note how the RuntimeReps are implied in the FunTy representation. For this +reason we must be careful when recontructing the TyConApp representation (see, +for instance, splitTyConApp_maybe). + +In the compiler we maintain the invariant that all saturated applications of +(->) are represented with FunTy. + +See #11714. +-} + +splitFunTy :: Type -> (Type, Type, Type) +-- ^ Attempts to extract the argument and result types from a type, and +-- panics if that is not possible. See also 'splitFunTy_maybe' +splitFunTy = expectJust "splitFunTy" . splitFunTy_maybe + +{-# INLINE splitFunTy_maybe #-} +splitFunTy_maybe :: Type -> Maybe (Type, Type, Type) +-- ^ Attempts to extract the argument and result types from a type +splitFunTy_maybe ty + | FunTy _ w arg res <- coreFullView ty = Just (w, arg, res) + | otherwise = Nothing + +splitFunTys :: Type -> ([Scaled Type], Type) +splitFunTys ty = split [] ty ty + where + -- common case first + split args _ (FunTy _ w arg res) = split ((Scaled w arg):args) res res + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args orig_ty _ = (reverse args, orig_ty) + +funResultTy :: Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty + | FunTy { ft_res = res } <- coreFullView ty = res + | otherwise = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty + | FunTy { ft_arg = arg } <- coreFullView ty = arg + | otherwise = pprPanic "funArgTy" (ppr ty) + +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" +piResultTy :: HasDebugCallStack => Type -> Type -> Type +piResultTy ty arg = case piResultTy_maybe ty arg of + Just res -> res + Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) + +piResultTy_maybe :: Type -> Type -> Maybe Type +-- We don't need a 'tc' version, because +-- this function behaves the same for Type and Constraint +piResultTy_maybe ty arg = case coreFullView ty of + FunTy { ft_res = res } -> Just res + + ForAllTy (Bndr tv _) res + -> let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) + + _ -> Nothing + +-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) +-- where f :: f_ty +-- 'piResultTys' is interesting because: +-- 1. 'f_ty' may have more for-alls than there are args +-- 2. Less obviously, it may have fewer for-alls +-- For case 2. think of: +-- piResultTys (forall a.a) [forall b.b, Int] +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint + +-- This is a heavily used function (e.g. from typeKind), +-- so we pay attention to efficiency, especially in the special case +-- where there are no for-alls so we are just dropping arrows from +-- a function type/kind. +piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys ty [] = ty +piResultTys ty orig_args@(arg:args) + | FunTy { ft_res = res } <- ty + = piResultTys res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst init_subst tv arg) res args + + | Just ty' <- coreView ty + = piResultTys ty' orig_args + + | otherwise + = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) + where + init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + + go :: TCvSubst -> Type -> [Type] -> Type + go subst ty [] = substTyUnchecked subst ty + + go subst ty all_args@(arg:args) + | FunTy { ft_res = res } <- ty + = go subst res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args + + | Just ty' <- coreView ty + = go subst ty' all_args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) + all_args + + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without the explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infinite loop, which is very unhelpful + -- c.f. #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + +applyTysX :: [TyVar] -> Type -> [Type] -> Type +-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys +-- Assumes that (/\tvs. body_ty) is closed +applyTysX tvs body_ty arg_tys + = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff ) + ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) + mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) + (drop n_tvs arg_tys) + where + pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] + n_tvs = length tvs + + + +{- Note [Care with kind instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + T :: forall k. k +and we are finding the kind of + T (forall b. b -> b) * Int +Then + T (forall b. b->b) :: k[ k :-> forall b. b->b] + :: forall b. b -> b +So + T (forall b. b->b) * :: (b -> b)[ b :-> *] + :: * -> * + +In other words we must instantiate the forall! + +Similarly (#15428) + S :: forall k f. k -> f k +and we are finding the kind of + S * (* ->) Int Bool +We have + S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] + :: * -> * -> * +So again we must instantiate. + +The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. + +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ +-} + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +-- | Retrieve the tycon heading this type, if there is one. Does /not/ +-- look through synonyms. +tyConAppTyConPicky_maybe :: Type -> Maybe TyCon +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon +tyConAppTyConPicky_maybe _ = Nothing + + +-- | The same as @fst . splitTyConApp@ +{-# INLINE tyConAppTyCon_maybe #-} +tyConAppTyCon_maybe :: Type -> Maybe TyCon +tyConAppTyCon_maybe ty = case coreFullView ty of + TyConApp tc _ -> Just tc + FunTy {} -> Just funTyCon + _ -> Nothing + +tyConAppTyCon :: Type -> TyCon +tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) + +-- | The same as @snd . splitTyConApp@ +tyConAppArgs_maybe :: Type -> Maybe [Type] +tyConAppArgs_maybe ty = case coreFullView ty of + TyConApp _ tys -> Just tys + FunTy _ w arg res + | Just rep1 <- getRuntimeRep_maybe arg + , Just rep2 <- getRuntimeRep_maybe res + -> Just [w, rep1, rep2, arg, res] + _ -> Nothing + +tyConAppArgs :: Type -> [Type] +tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) + +tyConAppArgN :: Int -> Type -> Type +-- Executing Nth +tyConAppArgN n ty + = case tyConAppArgs_maybe ty of + Just tys -> tys `getNth` n + Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = case splitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitTyConApp" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe = repSplitTyConApp_maybe . coreFullView + +-- | Split a type constructor application into its type constructor and +-- applied types. Note that this may fail in the case of a 'FunTy' with an +-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind +-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your +-- type before using this function. +-- +-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. +tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +-- Defined here to avoid module loops between Unify and TcType. +tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' +tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +------------------- +repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +-- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This +-- assumes the synonyms have already been dealt with. +-- +-- Moreover, for a FunTy, it only succeeds if the argument types +-- have enough info to extract the runtime-rep arguments that +-- the funTyCon requires. This will usually be true; +-- but may be temporarily false during canonicalization: +-- see Note [FunTy and decomposing tycon applications] in "GHC.Tc.Solver.Canonical" +-- +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (FunTy _ w arg res) + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) +repSplitTyConApp_maybe _ = Nothing + +------------------- +-- | Attempts to tease a list type apart and gives the type of the elements if +-- successful (looks through type synonyms) +splitListTyConApp_maybe :: Type -> Maybe Type +splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of + Just (tc,[e]) | tc == listTyCon -> Just e + _other -> Nothing + +newTyConInstRhs :: TyCon -> [Type] -> Type +-- ^ Unwrap one 'layer' of newtype on a type constructor and its +-- arguments, using an eta-reduced version of the @newtype@ if possible. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + +{- +--------------------------------------------------------------------- + CastTy + ~~~~~~ +A casted type has its *kind* casted into something new. +-} + +splitCastTy_maybe :: Type -> Maybe (Type, Coercion) +splitCastTy_maybe ty + | CastTy ty' co <- coreFullView ty = Just (ty', co) + | otherwise = Nothing + +-- | Make a 'CastTy'. The Coercion must be nominal. Checks the +-- Coercion for reflexivity, dropping it if it's reflexive. +-- See Note [Respecting definitional equality] in "GHC.Core.TyCo.Rep" +mkCastTy :: Type -> Coercion -> Type +mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note +-- NB: Do the slow check here. This is important to keep the splitXXX +-- functions working properly. Otherwise, we may end up with something +-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) +-- fails under splitFunTy_maybe. This happened with the cheaper check +-- in test dependent/should_compile/dynamic-paper. + +mkCastTy (CastTy ty co1) co2 + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co2) + -- call mkCastTy again for the reflexivity check + +mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co + -- (EQ4) from the Note + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep. + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) + else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) + +mkCastTy ty co = CastTy ty co + +tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] +-- Return the tyConBinders in TyCoBinder form +tyConBindersTyCoBinders = map to_tyb + where + to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) + to_tyb (Bndr tv (AnonTCB af)) = Anon af (tymult (varType tv)) + + +{- +-------------------------------------------------------------------- + CoercionTy + ~~~~~~~~~~ +CoercionTy allows us to inject coercions into types. A CoercionTy +should appear only in the right-hand side of an application. +-} + +mkCoercionTy :: Coercion -> Type +mkCoercionTy = CoercionTy + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + +{- +--------------------------------------------------------------------- + SynTy + ~~~~~ + +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind. + + +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ +-} + +-- | Make a dependent forall over an 'Inferred' variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = mkVisFunTyMany (varType tv) ty + | otherwise + = ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar +mkInfForAllTy :: TyVar -> Type -> Type +mkInfForAllTy tv ty = ASSERT( isTyVar tv ) + ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Inferred', a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar +mkInfForAllTys :: [TyVar] -> Type -> Type +mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs + +-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', +-- a common case +mkSpecForAllTy :: TyVar -> Type -> Type +mkSpecForAllTy tv ty = ASSERT( isTyVar tv ) + -- covar is always Inferred, so input should be tyvar + ForAllTy (Bndr tv Specified) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Specified', a common case +mkSpecForAllTys :: [TyVar] -> Type -> Type +mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] + +-- | Given a list of type-level vars and the free vars of a result kind, +-- makes TyCoBinders, preferring anonymous binders +-- if the variable is, in fact, not dependent. +-- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) +-- We want (k:*) Named, (b:k) Anon, (c:k) Anon +-- +-- All non-coercion binders are /visible/. +mkTyConBindersPreferAnon :: [TyVar] -- ^ binders + -> TyCoVarSet -- ^ free variables of result + -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) + fst (go vars) + where + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars + go [] = ([], inner_tkvs) + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( Bndr v (AnonTCB VisArg) : binders + , fvs `unionVarSet` kind_vars ) + where + (binders, fvs) = go vs + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the list of tycovars and the result type. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTys :: Type -> ([TyCoVar], Type) +splitForAllTys ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Splits the longest initial sequence of ForAllTys' that satisfy +-- @argf_pred@, returning the binders transformed by @argf_pred@ +splitSomeForAllTys :: (ArgFlag -> Maybe af) -> Type -> ([VarBndr TyCoVar af], Type) +splitSomeForAllTys argf_pred ty = split ty ty [] + where + split _ (ForAllTy (Bndr tcv argf) ty) tvs + | Just argf' <- argf_pred argf = split ty ty (Bndr tcv argf' : tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTys', but only splits 'ForAllTy's with 'Required' type +-- variable binders. Furthermore, each returned tyvar is annotated with '()'. +splitForAllTysReq :: Type -> ([ReqTVBinder], Type) +splitForAllTysReq ty = splitSomeForAllTys argf_pred ty + where + argf_pred :: ArgFlag -> Maybe () + argf_pred Required = Just () + argf_pred (Invisible {}) = Nothing + +-- | Like 'splitForAllTys', but only splits 'ForAllTy's with 'Invisible' type +-- variable binders. Furthermore, each returned tyvar is annotated with its +-- 'Specificity'. +splitForAllTysInvis :: Type -> ([InvisTVBinder], Type) +splitForAllTysInvis ty = splitSomeForAllTys argf_pred ty + where + argf_pred :: ArgFlag -> Maybe Specificity + argf_pred Required = Nothing + argf_pred (Invisible spec) = Just spec + +-- | Like splitForAllTys, but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitTyVarForAllTys :: Type -> ([TyVar], Type) +splitTyVarForAllTys ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy ty + | ForAllTy {} <- coreFullView ty = True + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isTyVar tv + = True + + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is a covar binder +isForAllTy_co :: Type -> Bool +isForAllTy_co ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isCoVar tv + = True + + | otherwise = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy ty = case coreFullView ty of + ForAllTy {} -> True + FunTy {} -> True + _ -> False + +-- | Is this a function? +isFunTy :: Type -> Bool +isFunTy ty + | FunTy {} <- coreFullView ty = True + | otherwise = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTy :: Type -> (TyCoVar, Type) +splitForAllTy ty + | Just answer <- splitForAllTy_maybe ty = answer + | otherwise = pprPanic "splitForAllTy" (ppr ty) + +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go (ForAllTy _ res) = go res + go ty | Just ty' <- coreView ty = go ty' + go res = res + +-- | Attempts to take a forall type apart, but only if it's a proper forall, +-- with a named binder +splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty) + | otherwise = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. +splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_ty_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isTyVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. +splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_co_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isCoVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +{-# INLINE splitPiTy_maybe #-} -- callers will immediately deconstruct +splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) +splitPiTy_maybe ty = case coreFullView ty of + ForAllTy bndr ty -> Just (Named bndr, ty) + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> Just (Anon af (mkScaled w arg), res) + _ -> Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (TyCoBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) + +-- | Split off all TyCoBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([TyCoBinder], Type) +splitPiTys ty = split ty ty [] + where + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs + = split res res (Anon af (Scaled w arg) : bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Like 'splitPiTys' but split off only /named/ binders +-- and returns TyCoVarBinders rather than TyCoBinders +splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) +splitForAllVarBndrs ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllVarBndrs #-} + +invisibleTyBndrCount :: Type -> Int +-- Returns the number of leading invisible forall'd binders in the type +-- Includes invisible predicate arguments; e.g. for +-- e.g. forall {k}. (k ~ *) => k -> k +-- returns 2 not 1 +invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) + +-- Like splitPiTys, but returns only *invisible* binders, including constraints +-- Stops at the first visible binder +splitPiTysInvisible :: Type -> ([TyCoBinder], Type) +splitPiTysInvisible ty = split ty ty [] + where + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , isInvisibleArgFlag vis = split res res (Named b : bs) + split _ (FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res }) bs + = split res res (Anon InvisArg (mkScaled mult arg) : bs) + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) + +splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) +-- Same as splitPiTysInvisible, but stop when +-- - you have found 'n' TyCoBinders, +-- - or you run out of invisible binders +splitPiTysInvisibleN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) + | FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty + = split (n-1) res res (Anon InvisArg (Scaled mult arg) : bs) + | otherwise = (reverse bs, orig_ty) + +-- | Given a 'TyCon' and a list of argument types, filter out any invisible +-- (i.e., 'Inferred' or 'Specified') arguments. +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys + +-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' +-- arguments. +filterOutInferredTypes :: TyCon -> [Type] -> [Type] +filterOutInferredTypes tc tys = + filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys + +-- | Given a 'TyCon' and a list of argument types, partition the arguments +-- into: +-- +-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and +-- +-- 2. 'Required' (i.e., visible) arguments +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +partitionInvisibleTypes tc tys = + partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys + +-- | Given a list of things paired with their visibilities, partition the +-- things into (invisible things, visible things). +partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) +partitionInvisibles = partitionWith pick_invis + where + pick_invis :: (a, ArgFlag) -> Either a a + pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing + | otherwise = Right thing + +-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Wrinkle: consider the following scenario: +-- +-- > T :: forall k. k -> k +-- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get +-- +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n +-- +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] +tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) + +-- | Given a 'Type' and a list of argument types to which the 'Type' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Most of the time, the arguments will be 'Required', but not always. Consider +-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is +-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely +-- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, +-- since @f Type Bool@ would be represented in Core using 'AppTy's. +-- (See also #15792). +appTyArgFlags :: Type -> [Type] -> [ArgFlag] +appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) + +-- | Given a function kind and a list of argument types (where each argument's +-- kind aligns with the corresponding position in the argument kind), determine +-- each argument's visibility ('Inferred', 'Specified', or 'Required'). +fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] +fun_kind_arg_flags = go emptyTCvSubst + where + go subst ki arg_tys + | Just ki' <- coreView ki = go subst ki' arg_tys + go _ _ [] = [] + go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) + = argf : go subst' res_ki arg_tys + where + subst' = extendTvSubst subst tv arg_ty + go subst (TyVarTy tv) arg_tys + | Just ki <- lookupTyVar subst tv = go subst ki arg_tys + -- This FunTy case is important to handle kinds with nested foralls, such + -- as this kind (inspired by #16518): + -- + -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type + -- + -- Here, we want to get the following ArgFlags: + -- + -- [Inferred, Specified, Required, Required, Specified, Required] + -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type + go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) + = argf : go subst res_ki arg_tys + where + argf = case af of + VisArg -> Required + InvisArg -> Inferred + go _ _ arg_tys = map (const Required) arg_tys + -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is Required. + +-- @isTauTy@ tests if a type has no foralls or (=>) +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- coreView ty = isTauTy ty' +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy af w a b) = case af of + InvisArg -> False -- e.g., Eq a => b + VisArg -> isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b +isTauTy (ForAllTy {}) = False +isTauTy (CastTy ty _) = isTauTy ty +isTauTy (CoercionTy _) = False -- Not sure about this + +isAtomicTy :: Type -> Bool +-- True if the type is just a single token, and can be printed compactly +-- Used when deciding how to lay out type error messages; see the +-- call in GHC.Tc.Errors +isAtomicTy (TyVarTy {}) = True +isAtomicTy (LitTy {}) = True +isAtomicTy (TyConApp _ []) = True + +isAtomicTy ty | isLiftedTypeKind ty = True + -- 'Type' prints compactly as * + -- See GHC.Iface.Type.ppr_kind_type + +isAtomicTy _ = False + +{- +%************************************************************************ +%* * + TyCoBinders +%* * +%************************************************************************ +-} + +-- | Make an anonymous binder +mkAnonBinder :: AnonArgFlag -> Scaled Type -> TyCoBinder +mkAnonBinder = Anon + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isAnonTyCoBinder :: TyCoBinder -> Bool +isAnonTyCoBinder (Named {}) = False +isAnonTyCoBinder (Anon {}) = True + +tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar +tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv +tyCoBinderVar_maybe _ = Nothing + +tyCoBinderType :: TyCoBinder -> Type +tyCoBinderType (Named tvb) = binderType tvb +tyCoBinderType (Anon _ ty) = scaledThing ty + +tyBinderType :: TyBinder -> Type +tyBinderType (Named (Bndr tv _)) + = ASSERT( isTyVar tv ) + tyVarKind tv +tyBinderType (Anon _ ty) = scaledThing ty + +-- | Extract a relevant type, if there is one. +binderRelevantType_maybe :: TyCoBinder -> Maybe Type +binderRelevantType_maybe (Named {}) = Nothing +binderRelevantType_maybe (Anon _ ty) = Just (scaledThing ty) + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys ) + zipTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +isFamFreeTy :: Type -> Bool +isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' +isFamFreeTy (TyVarTy _) = True +isFamFreeTy (LitTy {}) = True +isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc +isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ w a b) = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b +isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty +isFamFreeTy (CastTy ty _) = isFamFreeTy ty +isFamFreeTy (CoercionTy _) = False -- Not sure about this + +-- | Does this type classify a core (unlifted) Coercion? +-- At either role nominal or representational +-- (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" +isCoVarType :: Type -> Bool + -- ToDo: should we check saturation? +isCoVarType ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> KnotTied Type -> TyCon +-- This function is here beucase here is where we have +-- isFamFree and isTauTy +buildSynTyCon name binders res_kind roles rhs + = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + where + is_tau = isTauTy rhs + is_fam_free = isFamFreeTy rhs + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | Returns Just True if this type is surely lifted, Just False +-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is +-- levity polymorphic), and panics if the kind does not have the shape +-- TYPE r. +isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool +isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of + ty' | isLiftedRuntimeRep ty' -> Just True + TyConApp {} -> Just False -- Everything else is unlifted + _ -> Nothing -- levity polymorphic + +-- | See "Type#type_classification" for what an unlifted type is. +-- Panics on levity polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- levity polymorphism. +isUnliftedType :: HasDebugCallStack => Type -> Bool + -- isUnliftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them +isUnliftedType ty + = not (isLiftedType_maybe ty `orElse` + pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ lifted or +-- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case) +mightBeUnliftedType :: Type -> Bool +mightBeUnliftedType ty + = case isLiftedType_maybe ty of + Just is_lifted -> not is_lifted + Nothing -> True + +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind + +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: +-- +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep +-- , String, Int# ] == [String, Int#] +-- +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not +-- possible. +getRuntimeRep_maybe :: HasDebugCallStack + => Type -> Maybe Type +getRuntimeRep_maybe = kindRep_maybe . typeKind + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. +getRuntimeRep :: HasDebugCallStack => Type -> Type +getRuntimeRep ty + = case getRuntimeRep_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + + +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- | Check whether a type is a data family type +isDataFamilyAppType :: Type -> Bool +isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool +isStrictType = isUnliftedType + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Determine whether a type could be the type of a join point of given total +-- arity, according to the polymorphism rule. A join point cannot be polymorphic +-- in its return type, since given +-- join j @a @b x y z = e1 in e2, +-- the types of e1 and e2 must be the same, and a and b are not in scope for e2. +-- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False +-- also if the type simply doesn't have enough arguments. +-- +-- Note that we need to know how many arguments (type *and* value) the putative +-- join point takes; for instance, if +-- j :: forall a. a -> Int +-- then j could be a binary join point returning an Int, but it could *not* be a +-- unary join point returning a -> Int. +-- +-- TODO: See Note [Excess polymorphism and join points] +isValidJoinPointType :: JoinArity -> Type -> Bool +isValidJoinPointType arity ty + = valid_under emptyVarSet arity ty + where + valid_under tvs arity ty + | arity == 0 + = tvs `disjointVarSet` tyCoVarsOfType ty + | Just (t, ty') <- splitForAllTy_maybe ty + = valid_under (tvs `extendVarSet` t) (arity-1) ty' + | Just (_, _, res_ty) <- splitFunTy_maybe ty + = valid_under tvs (arity-1) res_ty + | otherwise + = False + +{- Note [Excess polymorphism and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, if a function would be a join point except that it fails +the polymorphism rule (see Note [The polymorphism rule of join points] in +GHC.Core), it can still be made a join point with some effort. This is because +all tail calls must return the same type (they return to the same context!), and +thus if the return type depends on an argument, that argument must always be the +same. + +For instance, consider: + + let f :: forall a. a -> Char -> [a] + f @a x c = ... f @a y 'a' ... + in ... f @Int 1 'b' ... f @Int 2 'c' ... + +(where the calls are tail calls). `f` fails the polymorphism rule because its +return type is [a], where [a] is bound. But since the type argument is always +'Int', we can rewrite it as: + + let f' :: Int -> Char -> [Int] + f' x c = ... f' y 'a' ... + in ... f' 1 'b' ... f 2 'c' ... + +and now we can make f' a join point: + + join f' :: Int -> Char -> [Int] + f' x c = ... jump f' y 'a' ... + in ... jump f' 1 'b' ... jump f' 2 'c' ... + +It's not clear that this comes up often, however. TODO: Measure how often and +add this analysis if necessary. See #14620. + + +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + Comparison for types + (We don't use instances so that we know where it happens) +* * +************************************************************************ + +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use repSplitAppTy_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +-} + +eqType :: Type -> Type -> Bool +-- ^ Type equality on source types. Does not look through @newtypes@ or +-- 'PredType's, but it does look through type synonyms. +-- This first checks that the kinds of the types are equal and then +-- checks whether the types are equal, ignoring casts and coercions. +-- (The kind check is a recursive call, but since all kinds have type +-- @Type@, there is no need to check the types of kinds.) +-- See also Note [Non-trivial definitional equality] in "GHC.Core.TyCo.Rep". +eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 + -- It's OK to use nonDetCmpType here and eqType is deterministic, + -- nonDetCmpType does equality deterministically + +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 + -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, + -- nonDetCmpTypeX does equality deterministically + +-- | Type equality on lists of types, looking through type synonyms +-- but not newtypes. +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 + -- It's OK to use nonDetCmpType here and eqTypes is deterministic, + -- nonDetCmpTypes does equality deterministically + +eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqVarBndrs env [] [] + = Just env +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (varType tv1) (varType tv2) + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing + +-- Now here comes the real worker + +{- +Note [nonDetCmpType nondeterminism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX +uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for +ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, +comparing type variables is nondeterministic, note the call to nonDetCmpVar in +nonDetCmpTypeX. +See Note [Unique Determinism] for more details. +-} + +nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 + = EQ +nonDetCmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = nonDetCmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) +{-# INLINE nonDetCmpType #-} + +nonDetCmpTypes :: [Type] -> [Type] -> Ordering +nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) + +-- | An ordering relation between two 'Type's (known below as @t1 :: k1@ +-- and @t2 :: k2@) +data TypeOrdering = TLT -- ^ @t1 < t2@ + | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind. + | TGT -- ^ @t1 > t2@ + deriving (Eq, Ord, Enum, Bounded) + +nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep +nonDetCmpTypeX env orig_t1 orig_t2 = + case go env orig_t1 orig_t2 of + -- If there are casts then we also need to do a comparison of the kinds of + -- the types being compared + TEQX -> toOrdering $ go env k1 k2 + ty_ordering -> toOrdering ty_ordering + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + toOrdering :: TypeOrdering -> Ordering + toOrdering TLT = LT + toOrdering TEQ = EQ + toOrdering TEQX = EQ + toOrdering TGT = GT + + liftOrdering :: Ordering -> TypeOrdering + liftOrdering LT = TLT + liftOrdering EQ = TEQ + liftOrdering GT = TGT + + thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering + thenCmpTy TEQ rel = rel + thenCmpTy TEQX rel = hasCast rel + thenCmpTy rel _ = rel + + hasCast :: TypeOrdering -> TypeOrdering + hasCast TEQ = TEQX + hasCast rel = rel + + -- Returns both the resulting ordering relation between the two types + -- and whether either contains a cast. + go :: RnEnv2 -> Type -> Type -> TypeOrdering + go env t1 t2 + | Just t1' <- coreView t1 = go env t1' t2 + | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 + go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) + = go env (varType tv1) (varType tv2) + `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- repSplitAppTy_maybe ty2 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- repSplitAppTy_maybe ty1 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + = go env s1 s2 `thenCmpTy` go env t1 t2 `thenCmpTy` go env w1 w2 + -- Comparing multiplicities last because the test is usually true + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 + go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) + go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 + go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 + + go _ (CoercionTy {}) (CoercionTy {}) = TEQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 + + gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering + gos _ [] [] = TEQ + gos _ [] _ = TLT + gos _ _ [] = TGT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 + +------------- +nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering +nonDetCmpTypesX _ [] [] = EQ +nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 + `thenCmp` + nonDetCmpTypesX env tys1 tys2 +nonDetCmpTypesX _ [] _ = LT +nonDetCmpTypesX _ _ [] = GT + +------------- +-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as +-- recognized by Kind.isConstraintKindCon) which is considered a synonym for +-- 'Type' in Core. +-- See Note [Kind Constraint and kind Type] in "GHC.Core.Type". +-- See Note [nonDetCmpType nondeterminism] +nonDetCmpTc :: TyCon -> TyCon -> Ordering +nonDetCmpTc tc1 tc2 + = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) + u1 `nonDetCmpUnique` u2 + where + u1 = tyConUnique tc1 + u2 = tyConUnique tc2 + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ + +Note [typeKind vs tcTypeKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have two functions to get the kind of a type + + * typeKind ignores the distinction between Constraint and * + * tcTypeKind respects the distinction between Constraint and * + +tcTypeKind is used by the type inference engine, for which Constraint +and * are different; after that we use typeKind. + +See also Note [coreView vs tcView] + +Note [Kinding rules for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. +We then have + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + ty : TYPE rep + `a` is not free in rep +(FORALL) ----------------------- + forall a. ty : TYPE rep + +In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + t1 : Constraint + t2 : TYPE rep + (PRED1) ---------------- + t1 => t2 : Type + + t1 : Constraint + t2 : Constraint + (PRED2) --------------------- + t1 => t2 : Constraint + + ty : TYPE rep + `a` is not free in rep +(FORALL1) ----------------------- + forall a. ty : TYPE rep + + ty : Constraint +(FORALL2) ------------------------- + forall a. ty : Constraint + +Note that: +* The only way we distinguish '->' from '=>' is by the fact + that the argument is a PredTy. Both are FunTys + +Note [Phantom type variables in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type K (r :: RuntimeRep) = Type -- Note 'r' is unused + data T r :: K r -- T :: forall r -> K r + foo :: forall r. T r + +The body of the forall in foo's type has kind (K r), and +normally it would make no sense to have + forall r. (ty :: K r) +because the kind of the forall would escape the binding +of 'r'. But in this case it's fine because (K r) exapands +to Type, so we explicitly /permit/ the type + forall r. T r + +To accommodate such a type, in typeKind (forall a.ty) we use +occCheckExpand to expand any type synonyms in the kind of 'ty' +to eliminate 'a'. See kinding rule (FORALL) in +Note [Kinding rules for types] + +See also + * GHC.Core.Type.occCheckExpand + * GHC.Core.Utils.coreAltsType + * GHC.Tc.Validity.checkEscapingKind +all of which grapple with the same problem. + +See #14939. +-} + +----------------------------- +typeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (LitTy l) = typeLiteralKind l +typeKind (FunTy {}) = liftedTypeKind +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = coercionRKind co +typeKind (CoercionTy co) = coercionType co + +typeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (typeKind fun) args + +typeKind ty@(ForAllTy {}) + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "typeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = typeKind body + +--------------------------------------------- +-- Utilities to be used in GHC.Core.Unify, +-- which uses "tc" functions +--------------------------------------------- + +tcTypeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +tcTypeKind (LitTy l) = typeLiteralKind l +tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar +tcTypeKind (CastTy _ty co) = coercionRKind co +tcTypeKind (CoercionTy co) = coercionType co + +tcTypeKind (FunTy { ft_af = af, ft_res = res }) + | InvisArg <- af + , tcIsConstraintKind (tcTypeKind res) + = constraintKind -- Eq a => Ord a :: Constraint + | otherwise -- Eq a => a -> a :: TYPE LiftedRep + = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) + +tcTypeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (tcTypeKind fun) args + +tcTypeKind ty@(ForAllTy {}) + | tcIsConstraintKind body_kind + = constraintKind + + | otherwise + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "tcTypeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = tcTypeKind body + + +isPredTy :: HasDebugCallStack => Type -> Bool +-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +isPredTy ty = tcIsConstraintKind (tcTypeKind ty) + +-- tcIsConstraintKind stuff only makes sense in the typechecker +-- After that Constraint = Type +-- See Note [coreView vs tcView] +-- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) +tcIsConstraintKind :: Kind -> Bool +tcIsConstraintKind ty + | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , isConstraintKindCon tc + = ASSERT2( null args, ppr ty ) True + + | otherwise + = False + +-- | Is this kind equivalent to @*@? +-- +-- This considers 'Constraint' to be distinct from @*@. For a version that +-- treats them as the same type, see 'isLiftedTypeKind'. +tcIsLiftedTypeKind :: Kind -> Bool +tcIsLiftedTypeKind ty + | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , tc `hasKey` tYPETyConKey + = isLiftedRuntimeRep arg + | otherwise + = False + +-- | Is this kind equivalent to @TYPE r@ (for some unknown r)? +-- +-- This considers 'Constraint' to be distinct from @*@. +tcIsRuntimeTypeKind :: Kind -> Bool +tcIsRuntimeTypeKind ty + | Just (tc, _) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , tc `hasKey` tYPETyConKey + = True + | otherwise + = False + +tcReturnsConstraintKind :: Kind -> Bool +-- True <=> the Kind ultimately returns a Constraint +-- E.g. * -> Constraint +-- forall k. k -> Constraint +tcReturnsConstraintKind kind + | Just kind' <- tcView kind = tcReturnsConstraintKind kind' +tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc +tcReturnsConstraintKind _ = False + +-------------------------- +typeLiteralKind :: TyLit -> Kind +typeLiteralKind (NumTyLit {}) = typeNatKind +typeLiteralKind (StrTyLit {}) = typeSymbolKind + +-- | Returns True if a type is levity polymorphic. Should be the same +-- as (isKindLevPoly . typeKind) but much faster. +-- Precondition: The type has kind (TYPE blah) +isTypeLevPoly :: Type -> Bool +isTypeLevPoly = go + where + go ty@(TyVarTy {}) = check_kind ty + go ty@(AppTy {}) = check_kind ty + go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False + | otherwise = check_kind ty + go (ForAllTy _ ty) = go ty + go (FunTy {}) = False + go (LitTy {}) = False + go ty@(CastTy {}) = check_kind ty + go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) + + check_kind = isKindLevPoly . typeKind + +-- | Looking past all pi-types, is the end result potentially levity polymorphic? +-- Example: True for (forall r (a :: TYPE r). String -> a) +-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) +resultIsLevPoly :: Type -> Bool +resultIsLevPoly = isTypeLevPoly . snd . splitPiTys + + +{- ********************************************************************** +* * + Occurs check expansion +%* * +%********************************************************************* -} + +{- Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occCheckExpand b (F Int b) = Just [Int] +but + occCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occCheckExpand b (F (G b)) = Just (F Char) +even though we could also expand F to get rid of b. +-} + +occCheckExpand :: [Var] -> Type -> Maybe Type +-- See Note [Occurs check expansion] +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. +occCheckExpand vs_to_avoid ty + | null vs_to_avoid -- Efficient shortcut + = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase + + | otherwise + = go (mkVarSet vs_to_avoid, emptyVarEnv) ty + where + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type + -- The VarSet is the set of variables we are trying to avoid + -- The VarEnv carries mappings necessary + -- because of kind expansion + go cxt@(as, env) (TyVarTy tv') + | tv' `elemVarSet` as = Nothing + | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') + | otherwise = do { tv'' <- go_var cxt tv' + ; return (mkTyVarTy tv'') } + + go _ ty@(LitTy {}) = return ty + go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkAppTy ty1' ty2') } + go cxt ty@(FunTy _ w ty1 ty2) + = do { w' <- go cxt w + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) } + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go (as', env') body_ty + ; return (ForAllTy (Bndr tv' vis) body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go cxt ty@(TyConApp tc tys) + = case mapM (go cxt) tys of + Just tys' -> return (mkTyConApp tc tys') + Nothing | Just ty' <- tcView ty -> go cxt ty' + | otherwise -> Nothing + -- Failing that, try to expand a synonym + + go cxt (CastTy ty co) = do { ty' <- go cxt ty + ; co' <- go_co cxt co + ; return (mkCastTy ty' co') } + go cxt (CoercionTy co) = do { co' <- go_co cxt co + ; return (mkCoercionTy co') } + + ------------------ + go_var cxt v = updateVarTypeM (go cxt) v + -- Works for TyVar and CoVar + -- See Note [Occurrence checking: look inside kinds] + + ------------------ + go_mco _ MRefl = return MRefl + go_mco ctx (MCo co) = MCo <$> go_co ctx co + + ------------------ + go_co cxt (Refl ty) = do { ty' <- go cxt ty + ; return (mkNomReflCo ty') } + go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco + ; ty' <- go cxt ty + ; return (mkGReflCo r ty' mco') } + -- Note: Coercions do not contain type synonyms + go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args + ; return (mkTyConAppCo r tc args') } + go_co cxt (AppCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkAppCo co' arg') } + go_co cxt@(as, env) (ForAllCo tv kind_co body_co) + = do { kind_co' <- go_co cxt kind_co + ; let tv' = setVarType tv $ + coercionLKind kind_co' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go_co (as', env') body_co + ; return (ForAllCo tv' kind_co' body') } + go_co cxt (FunCo r w co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; w' <- go_co cxt w + ; return (mkFunCo r w' co1' co2') } + go_co cxt@(as,env) (CoVarCo c) + | c `elemVarSet` as = Nothing + | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') + | otherwise = do { c' <- go_var cxt c + ; return (mkCoVarCo c') } + go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) + ; return (HoleCo (h { ch_co_var = c' })) } + go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args + ; return (mkAxiomInstCo ax ind args') } + go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkUnivCo p' r ty1' ty2') } + go_co cxt (SymCo co) = do { co' <- go_co cxt co + ; return (mkSymCo co') } + go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (mkTransCo co1' co2') } + go_co cxt (NthCo r n co) = do { co' <- go_co cxt co + ; return (mkNthCo r n co') } + go_co cxt (LRCo lr co) = do { co' <- go_co cxt co + ; return (mkLRCo lr co') } + go_co cxt (InstCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkInstCo co' arg') } + go_co cxt (KindCo co) = do { co' <- go_co cxt co + ; return (mkKindCo co') } + go_co cxt (SubCo co) = do { co' <- go_co cxt co + ; return (mkSubCo co') } + go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs + ; return (mkAxiomRuleCo ax cs') } + + ------------------ + go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co + go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co + go_prov _ p@(PluginProv _) = return p + go_prov _ p@CorePrepProv = return p + + +{- +%************************************************************************ +%* * + Miscellaneous functions +%* * +%************************************************************************ + +-} +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + = go ty + where + go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyUniqSet + go (LitTy {}) = emptyUniqSet + go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys + go (AppTy a b) = go a `unionUniqSets` go b + go (FunTy _ w a b) = go w `unionUniqSets` + go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) + go (CastTy ty co) = go ty `unionUniqSets` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco + go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args + go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co + go_co (FunCo _ co_mult co1 co2) = go_co co_mult `unionUniqSets` go_co co1 `unionUniqSets` go_co co2 + go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args + go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (CoVarCo {}) = emptyUniqSet + go_co (HoleCo {}) = emptyUniqSet + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (NthCo _ _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_mco MRefl = emptyUniqSet + go_mco (MCo co) = go_co co + + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyUniqSet + go_prov CorePrepProv = emptyUniqSet + -- this last case can happen from the tyConsOfType used from + -- checkTauTvUpdate + + go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys + go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + + go_tc tc = unitUniqSet tc + go_ax ax = go_tc $ coAxiomTyCon ax + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) + +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +splitVisVarsOfType :: Type -> Pair TyCoVarSet +splitVisVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2 + go (ForAllTy (Bndr tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ varType tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitVisVarsOfTypes = foldMap splitVisVarsOfType + +{- +************************************************************************ +* * + Functions over Kinds +* * +************************************************************************ + +Note [Kind Constraint and kind Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The kind Constraint is the kind of classes and other type constraints. +The special thing about types of kind Constraint is that + * They are displayed with double arrow: + f :: Ord a => a -> a + * They are implicitly instantiated at call sites; so the type inference + engine inserts an extra argument of type (Ord a) at every call site + to f. + +However, once type inference is over, there is *no* distinction between +Constraint and Type. Indeed we can have coercions between the two. Consider + class C a where + op :: a -> a +For this single-method class we may generate a newtype, which in turn +generates an axiom witnessing + C a ~ (a -> a) +so on the left we have Constraint, and on the right we have Type. +See #7451. + +Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with +distinct uniques, they are treated as equal at all times except +during type inference. +-} + +-- | Tests whether the given kind (which should look like @TYPE x@) +-- is something other than a constructor tree (that is, constructors at every node). +-- E.g. True of TYPE k, TYPE (F Int) +-- False of TYPE 'LiftedRep +isKindLevPoly :: Kind -> Bool +isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) + -- the isLiftedTypeKind check is necessary b/c of Constraint + go k + where + go ty | Just ty' <- coreView ty = go ty' + go TyVarTy{} = True + go AppTy{} = True -- it can't be a TyConApp + go (TyConApp tc tys) = isFamilyTyCon tc || any go tys + go ForAllTy{} = True + go (FunTy _ w t1 t2) = go w || go t1 || go t2 + go LitTy{} = False + go CastTy{} = True + go CoercionTy{} = True + + _is_type = classifiesTypeWithValues k + +----------------------------------------- +-- Subkinding +-- The tc variants are used during type-checking, where ConstraintKind +-- is distinct from all other kinds +-- After type-checking (in core), Constraint and liftedTypeKind are +-- indistinguishable + +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, #, TYPE Lifted, TYPE v, Constraint. +classifiesTypeWithValues :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind +classifiesTypeWithValues k = isJust (kindRep_maybe k) + +{- +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. + +-} + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice + (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` + injectiveVarsOfType False (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + -- See Note [Explicit Case Statement for Specificity] + source_of_injectivity (Invisible spec) = case spec of + SpecifiedSpec -> spec_inj_pos + InferredSpec -> False + +{- +Note [Explicit Case Statement for Specificity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching against an `ArgFlag`, you should not pattern match against +the pattern synonyms 'Specified' or 'Inferred', as this results in a +non-exhaustive pattern match warning. +Instead, pattern match against 'Invisible spec' and do another case analysis on +this specificity argument. +The issue has been fixed in GHC 8.10 (ticket #17876). This hack can thus be +dropped once version 8.10 is used as the minimum version for building GHC. + +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app) +2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the +omitted arguments are only the inferred ones (e.g., in situations where +specified arguments are reified through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavey, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parametrized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These functions would prefer to be in GHC.Core.Multiplicity, but +they some are used elsewhere in this module, and wanted to bring +their friends here with them. +-} + +unrestricted, linear, tymult :: a -> Scaled a + +-- | Scale a payload by Many +unrestricted = Scaled Many + +-- | Scale a payload by One +linear = Scaled One + +-- | Scale a payload by Many; used for type arguments in core +tymult = Scaled Many + +irrelevantMult :: Scaled a -> a +irrelevantMult = scaledThing + +mkScaled :: Mult -> a -> Scaled a +mkScaled = Scaled + +scaledSet :: Scaled a -> b -> Scaled b +scaledSet (Scaled m _) b = Scaled m b + +pattern One :: Mult +pattern One <- (isOneDataConTy -> True) + where One = oneDataConTy + +pattern Many :: Mult +pattern Many <- (isManyDataConTy -> True) + where Many = manyDataConTy + +isManyDataConTy :: Mult -> Bool +isManyDataConTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` manyDataConKey +isManyDataConTy _ = False + +isOneDataConTy :: Mult -> Bool +isOneDataConTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` oneDataConKey +isOneDataConTy _ = False + +isLinearType :: Type -> Bool +-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function +-- where at least one argument is linear (or otherwise non-unrestricted). We use +-- this function to check whether it is safe to eta reduce an Id in CorePrep. It +-- is always safe to return 'True', because 'True' deactivates the optimisation. +isLinearType ty = case ty of + FunTy _ Many _ res -> isLinearType res + FunTy _ _ _ _ -> True + ForAllTy _ res -> isLinearType res + _ -> False diff --git a/GHC/Core/Type.hs-boot b/GHC/Core/Type.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Type.hs-boot @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Type where + +import GHC.Prelude +import {-# SOURCE #-} GHC.Core.TyCon +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) +import GHC.Utils.Misc + +isPredTy :: HasDebugCallStack => Type -> Bool +isCoercionTy :: Type -> Bool + +mkAppTy :: Type -> Type -> Type +mkCastTy :: Type -> Coercion -> Type +piResultTy :: HasDebugCallStack => Type -> Type -> Type + +coreView :: Type -> Maybe Type +tcView :: Type -> Maybe Type +isRuntimeRepTy :: Type -> Bool +isMultiplicityTy :: Type -> Bool +isLiftedTypeKind :: Type -> Bool + +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +tyConAppTyCon_maybe :: Type -> Maybe TyCon + +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/GHC/Core/Unfold.hs b/GHC/Core/Unfold.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Unfold.hs @@ -0,0 +1,1650 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Core-syntax unfoldings + +Unfoldings (which can travel across module boundaries) are in Core +syntax (namely @CoreExpr@s). + +The type @Unfolding@ sits ``above'' simply-Core-expressions +unfoldings, capturing ``higher-level'' things we know about a binding, +usually things that the simplifier found out (e.g., ``it's a +literal''). In the corner of a @CoreUnfolding@ unfolding, you will +find, unsurprisingly, a Core expression. +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Unfold ( + Unfolding, UnfoldingGuidance, -- Abstract types + + noUnfolding, + mkUnfolding, mkCoreUnfolding, + mkFinalUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, + mkInlineUnfolding, mkInlineUnfoldingWithArity, + mkInlinableUnfolding, mkWwInlineRule, + mkCompulsoryUnfolding, mkDFunUnfolding, + specUnfolding, + + ArgSummary(..), + + couldBeSmallEnoughToInline, inlineBoringOk, + certainlyWillInline, smallEnoughToInline, + + callSiteInline, CallCtxt(..), + + -- Reexport from GHC.Core.Subst (it only live there so it can be used + -- by the Very Simple Optimiser) + exprIsConApp_maybe, exprIsLiteral_maybe + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.SimpleOpt +import GHC.Core.Opt.Arity ( manifestArity ) +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Types.Demand ( StrictSig, isDeadEndSig ) +import GHC.Core.DataCon +import GHC.Types.Literal +import GHC.Builtin.PrimOps +import GHC.Types.Id.Info +import GHC.Types.Basic ( Arity, InlineSpec(..), inlinePragmaSpec ) +import GHC.Core.Type +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.ForeignCall +import GHC.Types.Name +import GHC.Utils.Error + +import qualified Data.ByteString as BS +import Data.List + +{- +************************************************************************ +* * +\subsection{Making unfoldings} +* * +************************************************************************ +-} + +mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding +-- "Final" in the sense that this is a GlobalId that will not be further +-- simplified; so the unfolding should be occurrence-analysed +mkFinalUnfolding dflags src strict_sig expr + = mkUnfolding dflags src + True {- Top level -} + (isDeadEndSig strict_sig) + expr + +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding InlineCompulsory True + (simpleOptExpr unsafeGlobalDynFlags expr) + (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter + , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) + + +-- Note [Top-level flag on inline rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Slight hack: note that mk_inline_rules conservatively sets the +-- top-level flag to True. It gets set more accurately by the simplifier +-- Simplify.simplUnfolding. + +mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkSimpleUnfolding dflags rhs + = mkUnfolding dflags InlineRhs False False rhs + +mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding bndrs con ops + = DFunUnfolding { df_bndrs = bndrs + , df_con = con + , df_args = map occurAnalyseExpr ops } + -- See Note [Occurrence analysis of unfoldings] + +mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule dflags expr arity + = mkCoreUnfolding InlineStable True + (simpleOptExpr dflags expr) + (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtNotOk }) + +mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding +-- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap +mkWorkerUnfolding dflags work_fn + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl }) + | isStableSource src + = mkCoreUnfolding src top_lvl new_tmpl guidance + where + new_tmpl = simpleOptExpr dflags (work_fn tmpl) + guidance = calcUnfoldingGuidance dflags False new_tmpl + +mkWorkerUnfolding _ _ _ = noUnfolding + +-- | Make an unfolding that may be used unsaturated +-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its +-- manifest arity (the number of outer lambdas applications will +-- resolve before doing any work). +mkInlineUnfolding :: CoreExpr -> Unfolding +mkInlineUnfolding expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr unsafeGlobalDynFlags expr + guide = UnfWhen { ug_arity = manifestArity expr' + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boring_ok } + boring_ok = inlineBoringOk expr' + +-- | Make an unfolding that will be used once the RHS has been saturated +-- to the given arity. +mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding +mkInlineUnfoldingWithArity arity expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr unsafeGlobalDynFlags expr + guide = UnfWhen { ug_arity = arity + , ug_unsat_ok = needSaturated + , ug_boring_ok = boring_ok } + -- See Note [INLINE pragmas and boring contexts] as to why we need to look + -- at the arity here. + boring_ok | arity == 0 = True + | otherwise = inlineBoringOk expr' + +mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkInlinableUnfolding dflags expr + = mkUnfolding dflags InlineStable False False expr' + where + expr' = simpleOptExpr dflags expr + +specUnfolding :: DynFlags + -> [Var] -> (CoreExpr -> CoreExpr) + -> [CoreArg] -- LHS arguments in the RULE + -> Unfolding -> Unfolding +-- See Note [Specialising unfoldings] +-- specUnfolding spec_bndrs spec_args unf +-- = \spec_bndrs. unf spec_args +-- +specUnfolding dflags spec_bndrs spec_app rule_lhs_args + df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) + = ASSERT2( rule_lhs_args `equalLength` old_bndrs + , ppr df $$ ppr rule_lhs_args ) + -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise + mkDFunUnfolding spec_bndrs con (map spec_arg args) + -- For DFunUnfoldings we transform + -- \obs. MkD ... + -- to + -- \sbs. MkD ((\obs. ) spec_args) ... ditto + where + spec_arg arg = simpleOptExpr dflags $ + spec_app (mkLams old_bndrs arg) + -- The beta-redexes created by spec_app will be + -- simplified away by simplOptExpr + +specUnfolding dflags spec_bndrs spec_app rule_lhs_args + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl + , uf_guidance = old_guidance }) + | isStableSource src -- See Note [Specialising unfoldings] + , UnfWhen { ug_arity = old_arity } <- old_guidance + = mkCoreUnfolding src top_lvl new_tmpl + (old_guidance { ug_arity = old_arity - arity_decrease }) + where + new_tmpl = simpleOptExpr dflags $ + mkLams spec_bndrs $ + spec_app tmpl -- The beta-redexes created by spec_app + -- will besimplified away by simplOptExpr + arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs + + +specUnfolding _ _ _ _ _ = noUnfolding + +{- Note [Specialising unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise a function for some given type-class arguments, we use +specUnfolding to specialise its unfolding. Some important points: + +* If the original function has a DFunUnfolding, the specialised one + must do so too! Otherwise we lose the magic rules that make it + interact with ClassOps + +* There is a bit of hack for INLINABLE functions: + f :: Ord a => .... + f = + {- INLINABLE f #-} + Now if we specialise f, should the specialised version still have + an INLINABLE pragma? If it does, we'll capture a specialised copy + of as its unfolding, and that probably won't inline. But + if we don't, the specialised version of might be small + enough to inline at a call site. This happens with Control.Monad.liftM3, + and can cause a lot more allocation as a result (nofib n-body shows this). + + Moreover, keeping the INLINABLE thing isn't much help, because + the specialised function (probably) isn't overloaded any more. + + Conclusion: drop the INLINEALE pragma. In practice what this means is: + if a stable unfolding has UnfoldingGuidance of UnfWhen, + we keep it (so the specialised thing too will always inline) + if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs + (which arises from INLINABLE), we discard it + +Note [Honour INLINE on 0-ary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + x = + {-# INLINE x #-} + + f y = ...x... + +The semantics of an INLINE pragma is + + inline x at every call site, provided it is saturated; + that is, applied to at least as many arguments as appear + on the LHS of the Haskell source definition. + +(This source-code-derived arity is stored in the `ug_arity` field of +the `UnfoldingGuidance`.) + +In the example, x's ug_arity is 0, so we should inline it at every use +site. It's rare to have such an INLINE pragma (usually INLINE Is on +functions), but it's occasionally very important (#15578, #15519). +In #15519 we had something like + x = case (g a b) of I# r -> T r + {-# INLINE x #-} + f y = ...(h x).... + +where h is strict. So we got + f y = ...(case g a b of I# r -> h (T r))... + +and that in turn allowed SpecConstr to ramp up performance. + +How do we deliver on this? By adjusting the ug_boring_ok +flag in mkInlineUnfoldingWithArity; see +Note [INLINE pragmas and boring contexts] + +NB: there is a real risk that full laziness will float it right back +out again. Consider again + x = factorial 200 + {-# INLINE x #-} + f y = ...x... + +After inlining we get + f y = ...(factorial 200)... + +but it's entirely possible that full laziness will do + lvl23 = factorial 200 + f y = ...lvl23... + +That's a problem for another day. + +Note [INLINE pragmas and boring contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An INLINE pragma uses mkInlineUnfoldingWithArity to build the +unfolding. That sets the ug_boring_ok flag to False if the function +is not tiny (inlineBoringOK), so that even INLINE functions are not +inlined in an utterly boring context. E.g. + \x y. Just (f y x) +Nothing is gained by inlining f here, even if it has an INLINE +pragma. + +But for 0-ary bindings, we want to inline regardless; see +Note [Honour INLINE on 0-ary bindings]. + +I'm a bit worried that it's possible for the same kind of problem +to arise for non-0-ary functions too, but let's wait and see. +-} + +mkUnfolding :: DynFlags -> UnfoldingSource + -> Bool -- Is top-level + -> Bool -- Definitely a bottoming binding + -- (only relevant for top-level bindings) + -> CoreExpr + -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding dflags src top_lvl is_bottoming expr + = mkCoreUnfolding src top_lvl expr guidance + where + is_top_bottoming = top_lvl && is_bottoming + guidance = calcUnfoldingGuidance dflags is_top_bottoming expr + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! + -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + -- See Note [Occurrence analysis of unfoldings] + uf_src = src, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_work_free = exprIsWorkFree expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + + +{- +Note [Occurrence analysis of unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do occurrence-analysis of unfoldings once and for all, when the +unfolding is built, rather than each time we inline them. + +But given this decision it's vital that we do +*always* do it. Consider this unfolding + \x -> letrec { f = ...g...; g* = f } in body +where g* is (for some strange reason) the loop breaker. If we don't +occ-anal it when reading it in, we won't mark g as a loop breaker, and +we may inline g entirely in body, dropping its binding, and leaving +the occurrence in f out of scope. This happened in #8892, where +the unfolding in question was a DFun unfolding. + +But more generally, the simplifier is designed on the +basis that it is looking at occurrence-analysed expressions, so better +ensure that they actually are. + +Note [Calculate unfolding guidance on the non-occ-anal'd expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we give the non-occur-analysed expression to +calcUnfoldingGuidance. In some ways it'd be better to occur-analyse +first; for example, sometimes during simplification, there's a large +let-bound thing which has been substituted, and so is now dead; so +'expr' contains two copies of the thing while the occurrence-analysed +expression doesn't. + +Nevertheless, we *don't* and *must not* occ-analyse before computing +the size because + +a) The size computation bales out after a while, whereas occurrence + analysis does not. + +b) Residency increases sharply if you occ-anal first. I'm not + 100% sure why, but it's a large effect. Compiling Cabal went + from residency of 534M to over 800M with this one change. + +This can occasionally mean that the guidance is very pessimistic; +it gets fixed up next round. And it should be rare, because large +let-bound things that are dead are usually caught by preInlineUnconditionally + + +************************************************************************ +* * +\subsection{The UnfoldingGuidance type} +* * +************************************************************************ +-} + +inlineBoringOk :: CoreExpr -> Bool +-- See Note [INLINE for small functions] +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- This is a quick and dirty version. It doesn't attempt +-- to deal with (\x y z -> x (y z)) +-- The really important one is (x `cast` c) +inlineBoringOk e + = go 0 e + where + go :: Int -> CoreExpr -> Bool + go credit (Lam x e) | isId x = go (credit+1) e + | otherwise = go credit e + -- See Note [Count coercion arguments in boring contexts] + go credit (App f (Type {})) = go credit f + go credit (App f a) | credit > 0 + , exprIsTrivial a = go (credit-1) f + go credit (Tick _ e) = go credit e -- dubious + go credit (Cast e _) = go credit e + go credit (Case scrut _ _ [(_,_,rhs)]) -- See Note [Inline unsafeCoerce] + | isUnsafeEqualityProof scrut = go credit rhs + go _ (Var {}) = boringCxtOk + go _ _ = boringCxtNotOk + +calcUnfoldingGuidance + :: DynFlags + -> Bool -- Definitely a top-level, bottoming binding + -> CoreExpr -- Expression to look at + -> UnfoldingGuidance +calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr) + | not (tickishIsCode t) -- non-code ticks don't matter for unfolding + = calcUnfoldingGuidance dflags is_top_bottoming expr +calcUnfoldingGuidance dflags is_top_bottoming expr + = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline expr n_val_bndrs size + -> UnfWhen { ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtOk + , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] + + | is_top_bottoming + -> UnfNever -- See Note [Do not inline top-level bottoming functions] + + | otherwise + -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs + , ug_size = size + , ug_res = scrut_discount } + + where + (bndrs, body) = collectBinders expr + bOMB_OUT_SIZE = ufCreationThreshold dflags + -- Bomb out if size gets bigger than this + val_bndrs = filter isId bndrs + n_val_bndrs = length val_bndrs + + mk_discount :: Bag (Id,Int) -> Id -> Int + mk_discount cbs bndr = foldl' combine 0 cbs + where + combine acc (bndr', disc) + | bndr == bndr' = acc `plus_disc` disc + | otherwise = acc + + plus_disc :: Int -> Int -> Int + plus_disc | isFunTy (idType bndr) = max + | otherwise = (+) + -- See Note [Function and non-function discounts] + +{- Note [Inline unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We really want to inline unsafeCoerce, even when applied to boring +arguments. It doesn't look as if its RHS is smaller than the call + unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x +but that case is discarded -- see Note [Implementing unsafeCoerce] +in base:Unsafe.Coerce. + +Moreover, if we /don't/ inline it, we may be left with + f (unsafeCoerce x) +which will build a thunk -- bad, bad, bad. + +Conclusion: we really want inlineBoringOk to be True of the RHS of +unsafeCoerce. This is (U4) in Note [Implementing unsafeCoerce]. + +Note [Computing the size of an expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of sizeExpr is obvious enough: count nodes. But getting the +heuristics right has taken a long time. Here's the basic strategy: + + * Variables, literals: 0 + (Exception for string literals, see litSize.) + + * Function applications (f e1 .. en): 1 + #value args + + * Constructor applications: 1, regardless of #args + + * Let(rec): 1 + size of components + + * Note, cast: 0 + +Examples + + Size Term + -------------- + 0 42# + 0 x + 0 True + 2 f x + 1 Just x + 4 f (g x) + +Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's +a function call to account for. Notice also that constructor applications +are very cheap, because exposing them to a caller is so valuable. + +[25/5/11] All sizes are now multiplied by 10, except for primops +(which have sizes like 1 or 4. This makes primops look fantastically +cheap, and seems to be almost universally beneficial. Done partly as a +result of #4978. + +Note [Do not inline top-level bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatOut pass has gone to some trouble to float out calls to 'error' +and similar friends. See Note [Bottoming floats] in GHC.Core.Opt.SetLevels. +Do not re-inline them! But we *do* still inline if they are very small +(the uncondInline stuff). + +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + g y = f y +Then f's RHS is no larger than its LHS, so we should inline it into +even the most boring context. In general, f the function is +sufficiently small that its body is as small as the call itself, the +inline unconditionally, regardless of how boring the context is. + +Things to note: + +(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) + than the thing it's replacing. Notice that + (f x) --> (g 3) -- YES, unconditionally + (f x) --> x : [] -- YES, *even though* there are two + -- arguments to the cons + x --> g 3 -- NO + x --> Just v -- NO + + It's very important not to unconditionally replace a variable by + a non-atomic term. + +(2) We do this even if the thing isn't saturated, else we end up with the + silly situation that + f x y = x + ...map (f 3)... + doesn't inline. Even in a boring context, inlining without being + saturated will give a lambda instead of a PAP, and will be more + efficient at runtime. + +(3) However, when the function's arity > 0, we do insist that it + has at least one value argument at the call site. (This check is + made in the UnfWhen case of callSiteInline.) Otherwise we find this: + f = /\a \x:a. x + d = /\b. MkD (f b) + If we inline f here we get + d = /\b. MkD (\x:b. x) + and then prepareRhs floats out the argument, abstracting the type + variables, so we end up with the original again! + +(4) We must be much more cautious about arity-zero things. Consider + let x = y +# z in ... + In *size* terms primops look very small, because the generate a + single instruction, but we do not want to unconditionally replace + every occurrence of x with (y +# z). So we only do the + unconditional-inline thing for *trivial* expressions. + + NB: you might think that PostInlineUnconditionally would do this + but it doesn't fire for top-level things; see GHC.Core.Opt.Simplify.Utils + Note [Top level and postInlineUnconditionally] + +Note [Count coercion arguments in boring contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In inlineBoringOK, we ignore type arguments when deciding whether an +expression is okay to inline into boring contexts. This is good, since +if we have a definition like + + let y = x @Int in f y y + +there’s no reason not to inline y at both use sites — no work is +actually duplicated. It may seem like the same reasoning applies to +coercion arguments, and indeed, in #17182 we changed inlineBoringOK to +treat coercions the same way. + +However, this isn’t a good idea: unlike type arguments, which have +no runtime representation, coercion arguments *do* have a runtime +representation (albeit the zero-width VoidRep, see Note [Coercion tokens] +in "GHC.CoreToStg"). This caused trouble in #17787 for DataCon wrappers for +nullary GADT constructors: the wrappers would be inlined and each use of +the constructor would lead to a separate allocation instead of just +sharing the wrapper closure. + +The solution: don’t ignore coercion arguments after all. +-} + +uncondInline :: CoreExpr -> Arity -> Int -> Bool +-- Inline unconditionally if there no size increase +-- Size of call is arity (+1 for the function) +-- See Note [INLINE for small functions] +uncondInline rhs arity size + | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) + | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) + +sizeExpr :: DynFlags + -> Int -- Bomb out if it gets bigger than this + -> [Id] -- Arguments; we're interested in which of these + -- get case'd + -> CoreExpr + -> ExprSize + +-- Note [Computing the size of an expression] + +sizeExpr dflags bOMB_OUT_SIZE top_args expr + = size_up expr + where + size_up (Cast e _) = size_up e + size_up (Tick _ e) = size_up e + size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero + size_up (Lit lit) = sizeN (litSize lit) + size_up (Var f) | isRealWorldId f = sizeZero + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call f [] 0 + + size_up (App fun arg) + | isTyCoArg arg = size_up fun + | otherwise = size_up arg `addSizeNSD` + size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) + + size_up (Lam b e) + | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) + | otherwise = size_up e + + size_up (Let (NonRec binder rhs) body) + = size_up_rhs (binder, rhs) `addSizeNSD` + size_up body `addSizeN` + size_up_alloc binder + + size_up (Let (Rec pairs) body) + = foldr (addSizeNSD . size_up_rhs) + (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) + pairs + + size_up (Case e _ _ alts) + | null alts + = size_up e -- case e of {} never returns, so take size of scrutinee + + size_up (Case e _ _ alts) + -- Now alts is non-empty + | Just v <- is_top_arg e -- We are scrutinising an argument variable + = let + alt_sizes = map size_up_alt alts + + -- alts_size tries to compute a good discount for + -- the case when we are scrutinising an argument variable + alts_size (SizeIs tot tot_disc tot_scrut) + -- Size of all alternatives + (SizeIs max _ _) + -- Size of biggest alternative + = SizeIs tot (unitBag (v, 20 + tot - max) + `unionBags` tot_disc) tot_scrut + -- If the variable is known, we produce a + -- discount that will take us back to 'max', + -- the size of the largest alternative The + -- 1+ is a little discount for reduced + -- allocation in the caller + -- + -- Notice though, that we return tot_disc, + -- the total discount from all branches. I + -- think that's right. + + alts_size tot_size _ = tot_size + in + alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) + -- Good to inline if an arg is scrutinised, because + -- that may eliminate allocation in the caller + -- And it eliminates the case itself + where + is_top_arg (Var v) | v `elem` top_args = Just v + is_top_arg (Cast e _) = is_top_arg e + is_top_arg _ = Nothing + + + size_up (Case e _ _ alts) = size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + where + case_size + | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) + | otherwise = sizeZero + -- Normally we don't charge for the case itself, but + -- we charge one per alternative (see size_up_alt, + -- below) to account for the cost of the info table + -- and comparisons. + -- + -- However, in certain cases (see is_inline_scrut + -- below), no code is generated for the case unless + -- there are multiple alts. In these cases we + -- subtract one, making the first alt free. + -- e.g. case x# +# y# of _ -> ... should cost 1 + -- case touch# x# of _ -> ... should cost 0 + -- (see #4978) + -- + -- I would like to not have the "lengthAtMost alts 1" + -- condition above, but without that some programs got worse + -- (spectral/hartel/event and spectral/para). I don't fully + -- understand why. (SDM 24/5/11) + + -- unboxed variables, inline primops and unsafe foreign calls + -- are all "inline" things: + is_inline_scrut (Var v) = isUnliftedType (idType v) + is_inline_scrut scrut + | (Var f, _) <- collectArgs scrut + = case idDetails f of + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op -> not (primOpOutOfLine op) + _other -> False + | otherwise + = False + + size_up_rhs (bndr, rhs) + | Just join_arity <- isJoinId_maybe bndr + -- Skip arguments to join point + , (_bndrs, body) <- collectNBinders join_arity rhs + = size_up body + | otherwise + = size_up rhs + + ------------ + -- size_up_app is used when there's ONE OR MORE value args + size_up_app (App fun arg) args voids + | isTyCoArg arg = size_up_app fun args voids + | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) + | otherwise = size_up arg `addSizeNSD` + size_up_app fun (arg:args) voids + size_up_app (Var fun) args voids = size_up_call fun args voids + size_up_app (Tick _ expr) args voids = size_up_app expr args voids + size_up_app (Cast expr _) args voids = size_up_app expr args voids + size_up_app other args voids = size_up other `addSizeN` + callSize (length args) voids + -- if the lhs is not an App or a Var, or an invisible thing like a + -- Tick or Cast, then we should charge for a complete call plus the + -- size of the lhs itself. + + ------------ + size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize + size_up_call fun val_args voids + = case idDetails fun of + FCallId _ -> sizeN (callSize (length val_args) voids) + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op -> primOpSize op (length val_args) + ClassOpId _ -> classOpSize dflags top_args val_args + _ -> funSize dflags top_args fun (length val_args) voids + + ------------ + size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 + -- Don't charge for args, so that wrappers look cheap + -- (See comments about wrappers with Case) + -- + -- IMPORTANT: *do* charge 1 for the alternative, else we + -- find that giant case nests are treated as practically free + -- A good example is Foreign.C.Error.errnoToIOError + + ------------ + -- Cost to allocate binding with given binder + size_up_alloc bndr + | isTyVar bndr -- Doesn't exist at runtime + || isJoinId bndr -- Not allocated at all + || isUnliftedType (idType bndr) -- Doesn't live in heap + = 0 + | otherwise + = 10 + + ------------ + -- These addSize things have to be here because + -- I don't want to give them bOMB_OUT_SIZE as an argument + addSizeN TooBig _ = TooBig + addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d + + -- addAltSize is used to add the sizes of case alternatives + addAltSize TooBig _ = TooBig + addAltSize _ TooBig = TooBig + addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + (d1 + d2) -- Note [addAltSize result discounts] + + -- This variant ignores the result discount from its LEFT argument + -- It's used when the second argument isn't part of the result + addSizeNSD TooBig _ = TooBig + addSizeNSD _ TooBig = TooBig + addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + d2 -- Ignore d1 + + isRealWorldId id = idType id `eqType` realWorldStatePrimTy + + -- an expression of type State# RealWorld must be a variable + isRealWorldExpr (Var id) = isRealWorldId id + isRealWorldExpr (Tick _ e) = isRealWorldExpr e + isRealWorldExpr _ = False + +-- | Finds a nominal size of a string literal. +litSize :: Literal -> Int +-- Used by GHC.Core.Unfold.sizeExpr +litSize (LitNumber LitNumInteger _) = 100 -- Note [Size of literal integers] +litSize (LitNumber LitNumNatural _) = 100 +litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) + -- If size could be 0 then @f "x"@ might be too small + -- [Sept03: make literal strings a bit bigger to avoid fruitless + -- duplication of little strings] +litSize _other = 0 -- Must match size of nullary constructors + -- Key point: if x |-> 4, then x must inline unconditionally + -- (eg via case binding) + +classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize +-- See Note [Conlike is interesting] +classOpSize _ _ [] + = sizeZero +classOpSize dflags top_args (arg1 : other_args) + = SizeIs size arg_discount 0 + where + size = 20 + (10 * length other_args) + -- If the class op is scrutinising a lambda bound dictionary then + -- give it a discount, to encourage the inlining of this function + -- The actual discount is rather arbitrarily chosen + arg_discount = case arg1 of + Var dict | dict `elem` top_args + -> unitBag (dict, ufDictDiscount dflags) + _other -> emptyBag + +-- | The size of a function call +callSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +callSize n_val_args voids = 10 * (1 + n_val_args - voids) + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + +-- | The size of a jump to a join point +jumpSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) + -- A jump is 20% the size of a function call. Making jumps free reopens + -- bug #6048, but making them any more expensive loses a 21% improvement in + -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a + -- better solution? + +funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize +-- Size for functions that are not constructors or primops +-- Note [Function applications] +funSize dflags top_args fun n_val_args voids + | fun `hasKey` buildIdKey = buildSize + | fun `hasKey` augmentIdKey = augmentSize + | otherwise = SizeIs size arg_discount res_discount + where + some_val_args = n_val_args > 0 + is_join = isJoinId fun + + size | is_join = jumpSize n_val_args voids + | not some_val_args = 0 + | otherwise = callSize n_val_args voids + + -- DISCOUNTS + -- See Note [Function and non-function discounts] + arg_discount | some_val_args && fun `elem` top_args + = unitBag (fun, ufFunAppDiscount dflags) + | otherwise = emptyBag + -- If the function is an argument and is applied + -- to some values, give it an arg-discount + + res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags + | otherwise = 0 + -- If the function is partially applied, show a result discount +-- XXX maybe behave like ConSize for eval'd variable + +conSize :: DataCon -> Int -> ExprSize +conSize dc n_val_args + | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables + +-- See Note [Unboxed tuple size and result discount] + | isUnboxedTupleCon dc = SizeIs 0 emptyBag 10 + +-- See Note [Constructor size and result discount] + | otherwise = SizeIs 10 emptyBag 10 + +{- Note [Constructor size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Treat a constructors application as size 10, regardless of how many +arguments it has; we are keen to expose them (and we charge separately +for their args). We can't treat them as size zero, else we find that +(Just x) has size 0, which is the same as a lone variable; and hence +'v' will always be replaced by (Just x), where v is bound to Just x. + +The "result discount" is applied if the result of the call is +scrutinised (say by a case). For a constructor application that will +mean the constructor application will disappear, so we don't need to +charge it to the function. So the discount should at least match the +cost of the constructor application, namely 10. + +Historical note 1: Until Jun 2020 we gave it a "bit of extra +incentive" via a discount of 10*(1 + n_val_args), but that was FAR too +much (#18282). In particular, consider a huge case tree like + + let r = case y1 of + Nothing -> B1 a b c + Just v1 -> case y2 of + Nothing -> B1 c b a + Just v2 -> ... + +If conSize gives a cost of 10 (regardless of n_val_args) and a +discount of 10, that'll make each alternative RHS cost zero. We +charge 10 for each case alternative (see size_up_alt). If we give a +bigger discount (say 20) in conSize, we'll make the case expression +cost *nothing*, and that can make a huge case tree cost nothing. This +leads to massive, sometimes exponenial inlinings (#18282). In short, +don't give a discount that give a negative size to a sub-expression! + +Historical note 2: Much longer ago, Simon M tried a MUCH bigger +discount: (10 * (10 + n_val_args)), and said it was an "unambiguous +win", but its terribly dangerous because a function with many many +case branches, each finishing with a constructor, can have an +arbitrarily large discount. This led to terrible code bloat: see +#6099. + +Note [Unboxed tuple size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +However, unboxed tuples count as size zero. I found occasions where we had + f x y z = case op# x y z of { s -> (# s, () #) } +and f wasn't getting inlined. + +I tried giving unboxed tuples a *result discount* of zero (see the +commented-out line). Why? When returned as a result they do not +allocate, so maybe we don't want to charge so much for them. If you +have a non-zero discount here, we find that workers often get inlined +back into wrappers, because it look like + f x = case $wf x of (# a,b #) -> (a,b) +and we are keener because of the case. However while this change +shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% +more. All other changes were very small. So it's not a big deal but I +didn't adopt the idea. + +When fixing #18282 (see Note [Constructor size and result discount]) +I changed the result discount to be just 10, not 10*(1+n_val_args). + +Note [Function and non-function discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want a discount if the function is applied. A good example is +monadic combinators with continuation arguments, where inlining is +quite important. + +But we don't want a big discount when a function is called many times +(see the detailed comments with #6048) because if the function is +big it won't be inlined at its many call sites and no benefit results. +Indeed, we can get exponentially big inlinings this way; that is what +#6048 is about. + +On the other hand, for data-valued arguments, if there are lots of +case expressions in the body, each one will get smaller if we apply +the function to a constructor application, so we *want* a big discount +if the argument is scrutinised by many case expressions. + +Conclusion: + - For functions, take the max of the discounts + - For data values, take the sum of the discounts + + +Note [Literal integer size] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal integers *can* be big (mkInteger [...coefficients...]), but +need not be (IS n). We just use an arbitrary big-ish constant here +so that, in particular, we don't inline top-level defns like + n = IS 5 +There's no point in doing so -- any optimisations will see the IS +through n's unfolding. Nor will a big size inhibit unfoldings functions +that mention a literal Integer, because the float-out pass will float +all those constants to top level. +-} + +primOpSize :: PrimOp -> Int -> ExprSize +primOpSize op n_val_args + = if primOpOutOfLine op + then sizeN (op_size + n_val_args) + else sizeN op_size + where + op_size = primOpCodeSize op + + +buildSize :: ExprSize +buildSize = SizeIs 0 emptyBag 40 + -- We really want to inline applications of build + -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) + -- Indeed, we should add a result_discount because build is + -- very like a constructor. We don't bother to check that the + -- build is saturated (it usually is). The "-2" discounts for the \c n, + -- The "4" is rather arbitrary. + +augmentSize :: ExprSize +augmentSize = SizeIs 0 emptyBag 40 + -- Ditto (augment t (\cn -> e) ys) should cost only the cost of + -- e plus ys. The -2 accounts for the \cn + +-- When we return a lambda, give a discount if it's used (applied) +lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize +lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags) +lamScrutDiscount _ TooBig = TooBig + +{- +Note [addAltSize result discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding the size of alternatives, we *add* the result discounts +too, rather than take the *maximum*. For a multi-branch case, this +gives a discount for each branch that returns a constructor, making us +keener to inline. I did try using 'max' instead, but it makes nofib +'rewrite' and 'puzzle' allocate significantly more, and didn't make +binary sizes shrink significantly either. + +Note [Discounts and thresholds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constants for discounts and thesholds are defined in "GHC.Driver.Session", +all of form ufXxxx. They are: + +ufCreationThreshold + At a definition site, if the unfolding is bigger than this, we + may discard it altogether + +ufUseThreshold + At a call site, if the unfolding, less discounts, is smaller than + this, then it's small enough inline + +ufDictDiscount + The discount for each occurrence of a dictionary argument + as an argument of a class method. Should be pretty small + else big functions may get inlined + +ufFunAppDiscount + Discount for a function argument that is applied. Quite + large, because if we inline we avoid the higher-order call. + +ufDearOp + The size of a foreign call or not-dupable PrimOp + +ufVeryAggressive + If True, the compiler ignores all the thresholds and inlines very + aggressively. It still adheres to arity, simplifier phase control and + loop breakers. + + +Historical Note: Before April 2020 we had another factor, +ufKeenessFactor, which would scale the discounts before they were subtracted +from the size. This was justified with the following comment: + + -- We multiply the raw discounts (args_discount and result_discount) + -- ty opt_UnfoldingKeenessFactor because the former have to do with + -- *size* whereas the discounts imply that there's some extra + -- *efficiency* to be gained (e.g. beta reductions, case reductions) + -- by inlining. + +However, this is highly suspect since it means that we subtract a *scaled* size +from an absolute size, resulting in crazy (e.g. negative) scores in some cases +(#15304). We consequently killed off ufKeenessFactor and bumped up the +ufUseThreshold to compensate. + + +Note [Function applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a function application (f a b) + + - If 'f' is an argument to the function being analysed, + and there's at least one value arg, record a FunAppDiscount for f + + - If the application if a PAP (arity > 2 in this example) + record a *result* discount (because inlining + with "extra" args in the call may mean that we now + get a saturated application) + +Code for manipulating sizes +-} + +-- | The size of a candidate expression for unfolding +data ExprSize + = TooBig + | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found + , _es_args :: !(Bag (Id,Int)) + -- ^ Arguments cased herein, and discount for each such + , _es_discount :: {-# UNPACK #-} !Int + -- ^ Size to subtract if result is scrutinised by a case + -- expression + } + +instance Outputable ExprSize where + ppr TooBig = text "TooBig" + ppr (SizeIs a _ c) = brackets (int a <+> int c) + +-- subtract the discount before deciding whether to bale out. eg. we +-- want to inline a large constructor application into a selector: +-- tup = (a_1, ..., a_99) +-- x = case tup of ... +-- +mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize +mkSizeIs max n xs d | (n - d) > max = TooBig + | otherwise = SizeIs n xs d + +maxSize :: ExprSize -> ExprSize -> ExprSize +maxSize TooBig _ = TooBig +maxSize _ TooBig = TooBig +maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 + | otherwise = s2 + +sizeZero :: ExprSize +sizeN :: Int -> ExprSize + +sizeZero = SizeIs 0 emptyBag 0 +sizeN n = SizeIs n emptyBag 0 + +{- +************************************************************************ +* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +* * +************************************************************************ + +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. +-} + +couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline dflags threshold rhs + = case sizeExpr dflags threshold [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs + +---------------- +smallEnoughToInline :: DynFlags -> Unfolding -> Bool +smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) + = size <= ufUseThreshold dflags +smallEnoughToInline _ _ + = False + +---------------- + +certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding +-- ^ Sees if the unfolding is pretty certain to inline. +-- If so, return a *stable* unfolding for it, that will always inline. +certainlyWillInline dflags fn_info + = case unfoldingInfo fn_info of + CoreUnfolding { uf_tmpl = e, uf_guidance = g } + | loop_breaker -> Nothing -- Won't inline, so try w/w + | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] + | otherwise -> do_cunf e g -- Depends on size, so look at that + + DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense + -- to do so, and even if it is currently a + -- loop breaker, it may not be later + + _other_unf -> Nothing + + where + loop_breaker = isStrongLoopBreaker (occInfo fn_info) + noinline = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline + fn_unf = unfoldingInfo fn_info + + do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding + do_cunf _ UnfNever = Nothing + do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) + -- INLINE functions have UnfWhen + + -- The UnfIfGoodArgs case seems important. If we w/w small functions + -- binary sizes go up by 10%! (This is with SplitObjs.) + -- I'm not totally sure why. + -- INLINABLE functions come via this path + -- See Note [certainlyWillInline: INLINABLE] + do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) + | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] + , not (isDeadEndSig (strictnessInfo fn_info)) + -- Do not unconditionally inline a bottoming functions even if + -- it seems smallish. We've carefully lifted it out to top level, + -- so we don't want to re-inline it. + , let unf_arity = length args + , size - (10 * (unf_arity + 1)) <= ufUseThreshold dflags + = Just (fn_unf { uf_src = InlineStable + , uf_guidance = UnfWhen { ug_arity = unf_arity + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = inlineBoringOk expr } }) + -- Note the "unsaturatedOk". A function like f = \ab. a + -- will certainly inline, even if partially applied (f e), so we'd + -- better make sure that the transformed inlining has the same property + | otherwise + = Nothing + +{- Note [certainlyWillInline: be careful of thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't claim that thunks will certainly inline, because that risks work +duplication. Even if the work duplication is not great (eg is_cheap +holds), it can make a big difference in an inner loop In #5623 we +found that the WorkWrap phase thought that + y = case x of F# v -> F# (v +# v) +was certainlyWillInline, so the addition got duplicated. + +Note that we check arityInfo instead of the arity of the unfolding to detect +this case. This is so that we don't accidentally fail to inline small partial +applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2 +(say). Here there is no risk of work duplication, and the RHS is tiny, so +certainlyWillInline should return True. But `unf_arity` is zero! However f's +arity, gotten from `arityInfo fn_info`, is 1. + +Failing to say that `f` will inline forces W/W to generate a potentially huge +worker for f that will immediately cancel with `g`'s wrapper anyway, causing +unnecessary churn in the Simplifier while arriving at the same result. + +Note [certainlyWillInline: INLINABLE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +certainlyWillInline /must/ return Nothing for a large INLINABLE thing, +even though we have a stable inlining, so that strictness w/w takes +place. It makes a big difference to efficiency, and the w/w pass knows +how to transfer the INLINABLE info to the worker; see WorkWrap +Note [Worker-wrapper for INLINABLE functions] + +************************************************************************ +* * +\subsection{callSiteInline} +* * +************************************************************************ + +This is the key function. It decides whether to inline a variable at a call site + +callSiteInline is used at call sites, so it is a bit more generous. +It's a very important function that embodies lots of heuristics. +A non-WHNF can be inlined if it doesn't occur inside a lambda, +and occurs exactly once or + occurs once in each branch of a case and is small + +If the thing is in WHNF, there's no danger of duplicating work, +so we can inline if it occurs once, or is small + +NOTE: we don't want to inline top-level functions that always diverge. +It just makes the code bigger. Tt turns out that the convenient way to prevent +them inlining is to give them a NOINLINE pragma, which we do in +StrictAnal.addStrictnessInfoToTopId +-} + +callSiteInline :: DynFlags + -> Id -- The Id + -> Bool -- True <=> unfolding is active + -> Bool -- True if there are no arguments at all (incl type args) + -> [ArgSummary] -- One for each value arg; True if it is interesting + -> CallCtxt -- True <=> continuation is interesting + -> Maybe CoreExpr -- Unfolding, if any + +data ArgSummary = TrivArg -- Nothing interesting + | NonTrivArg -- Arg has structure + | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] + +instance Outputable ArgSummary where + ppr TrivArg = text "TrivArg" + ppr NonTrivArg = text "NonTrivArg" + ppr ValueArg = text "ValueArg" + +nonTriv :: ArgSummary -> Bool +nonTriv TrivArg = False +nonTriv _ = True + +data CallCtxt + = BoringCtxt + | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | DiscArgCtxt -- Argument of a function with non-zero arg discount + | RuleArgCtxt -- We are somewhere in the argument of a function with rules + + | ValAppCtxt -- We're applied to at least one value arg + -- This arises when we have ((f x |> co) y) + -- Then the (f x) has argument 'x' but in a ValAppCtxt + + | CaseCtxt -- We're the scrutinee of a case + -- that decomposes its scrutinee + +instance Outputable CallCtxt where + ppr CaseCtxt = text "CaseCtxt" + ppr ValAppCtxt = text "ValAppCtxt" + ppr BoringCtxt = text "BoringCtxt" + ppr RhsCtxt = text "RhsCtxt" + ppr DiscArgCtxt = text "DiscArgCtxt" + ppr RuleArgCtxt = text "RuleArgCtxt" + +callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info + = case idUnfolding id of + -- idUnfolding checks for loop-breakers, returning NoUnfolding + -- Things with an INLINE pragma may have an unfolding *and* + -- be a loop breaker (maybe the knot is not yet untied) + CoreUnfolding { uf_tmpl = unf_template + , uf_is_work_free = is_wf + , uf_guidance = guidance, uf_expandable = is_exp } + | active_unfolding -> tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template + is_wf is_exp guidance + | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing + NoUnfolding -> Nothing + BootUnfolding -> Nothing + OtherCon {} -> Nothing + DFunUnfolding {} -> Nothing -- Never unfold a DFun + +-- | Report the inlining of an identifier's RHS to the user, if requested. +traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a +traceInline dflags inline_id str doc result + -- We take care to ensure that doc is used in only one branch, ensuring that + -- the simplifier can push its allocation into the branch. See Note [INLINE + -- conditional tracing utilities]. + | enable = traceAction dflags str doc result + | otherwise = result + where + enable + | dopt Opt_D_dump_verbose_inlinings dflags + = True + | Just prefix <- inlineCheck dflags + = prefix `isPrefixOf` occNameString (getOccName inline_id) + | otherwise + = False +{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities] + +tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance + -> Maybe CoreExpr +tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template + is_wf is_exp guidance + = case guidance of + UnfNever -> traceInline dflags id str (text "UnfNever") Nothing + + UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags) + -- See Note [INLINE for small functions (3)] + -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template) + | otherwise + -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing + where + some_benefit = calc_some_benefit uf_arity + enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) + + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + | ufVeryAggressive dflags + -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + | is_wf && some_benefit && small_enough + -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + | otherwise + -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing + where + some_benefit = calc_some_benefit (length arg_discounts) + extra_doc = text "discounted size =" <+> int discounted_size + discounted_size = size - discount + small_enough = discounted_size <= ufUseThreshold dflags + discount = computeDiscount arg_discounts res_discount arg_infos cont_info + + where + mk_doc some_benefit extra_doc yes_or_no + = vcat [ text "arg infos" <+> ppr arg_infos + , text "interesting continuation" <+> ppr cont_info + , text "some_benefit" <+> ppr some_benefit + , text "is exp:" <+> ppr is_exp + , text "is work-free:" <+> ppr is_wf + , text "guidance" <+> ppr guidance + , extra_doc + , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] + + str = "Considering inlining: " ++ showSDocDump dflags (ppr id) + n_val_args = length arg_infos + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + calc_some_benefit :: Arity -> Bool -- The Arity is the number of args + -- expected by the unfolding + calc_some_benefit uf_arity + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | otherwise = interesting_args -- Saturated or over-saturated + || interesting_call + where + saturated = n_val_args >= uf_arity + over_saturated = n_val_args > uf_arity + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + interesting_call + | over_saturated + = True + | otherwise + = case cont_info of + CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] + ValAppCtxt -> True -- Note [Cast then apply] + RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] + DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + RhsCtxt -> uf_arity > 0 -- + _other -> False -- See Note [Nested functions] + + +{- +Note [Unfold into lazy contexts], Note [RHS of lets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the call is the argument of a function with a RULE, or the RHS of a let, +we are a little bit keener to inline. For example + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. Also + x = f v +could be expensive whereas + x = case v of (a,b) -> a +is patently cheap and may allow more eta expansion. +So we treat the RHS of a let as not-totally-boring. + +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Types.False -> y GHC.Types.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [Things to watch] +~~~~~~~~~~~~~~~~~~~~~~ +* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } + Assume x is exported, so not inlined unconditionally. + Then we want x to inline unconditionally; no reason for it + not to, and doing so avoids an indirection. + +* { x = I# 3; ....f x.... } + Make sure that x does not inline unconditionally! + Lest we get extra allocation. + +Note [Inlining an InlineRule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An InlineRules is used for + (a) programmer INLINE pragmas + (b) inlinings from worker/wrapper + +For (a) the RHS may be large, and our contract is that we *only* inline +when the function is applied to all the arguments on the LHS of the +source-code defn. (The uf_arity in the rule.) + +However for worker/wrapper it may be worth inlining even if the +arity is not satisfied (as we do in the CoreUnfolding case) so we don't +require saturation. + +Note [Nested functions] +~~~~~~~~~~~~~~~~~~~~~~~ +At one time we treated a call of a non-top-level function as +"interesting" (regardless of how boring the context) in the hope +that inlining it would eliminate the binding, and its allocation. +Specifically, in the default case of interesting_call we had + _other -> not is_top && uf_arity > 0 + +But actually postInlineUnconditionally does some of this and overall +it makes virtually no difference to nofib. So I simplified away this +special case + +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. ) |> co ) + co :: (forall a. a -> a) ~ (forall a. T a) + ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... + +We need to inline myIndex to unravel this; but the actual call (myIndex a) has +no value arguments. The ValAppCtxt gives it enough incentive to inline. + +Note [Inlining in ArgCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The condition (arity > 0) here is very important, because otherwise +we end up inlining top-level stuff into useless places; eg + x = I# 3# + f = \y. g x +This can make a very big difference: it adds 16% to nofib 'integer' allocs, +and 20% to 'power'. + +At one stage I replaced this condition by 'True' (leading to the above +slow-down). The motivation was test eyeball/inline1.hs; but that seems +to work ok now. + +NOTE: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + +Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~ which appears below +The "lone-variable" case is important. I spent ages messing about +with unsatisfactory variants, but this is nice. The idea is that if a +variable appears all alone + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt +AND + it is bound to a cheap expression + +then we should not inline it (unless there is some other reason, +e.g. it is the sole occurrence). That is what is happening at +the use of 'lone_variable' in 'interesting_call'. + +Why? At least in the case-scrutinee situation, turning + let x = (a,b) in case x of y -> ... +into + let x = (a,b) in case (a,b) of y -> ... +and thence to + let x = (a,b) in let y = (a,b) in ... +is bad if the binding for x will remain. + +Another example: I discovered that strings +were getting inlined straight back into applications of 'error' +because the latter is strict. + s = "foo" + f = \x -> ...(error s)... + +Fundamentally such contexts should not encourage inlining because, provided +the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the +context can ``see'' the unfolding of the variable (e.g. case or a +RULE) so there's no gain. + +However, watch out: + + * Consider this: + foo = _inline_ (\n. [n]) + bar = _inline_ (foo 20) + baz = \n. case bar of { (m:_) -> m + n } + Here we really want to inline 'bar' so that we can inline 'foo' + and the whole thing unravels as it should obviously do. This is + important: in the NDP project, 'bar' generates a closure data + structure rather than a list. + + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as cheap; because that is when exprIsConApp_maybe + looks through the unfolding. Hence the "&& is_wf" in the + InlineRule branch. + + * Even a type application or coercion isn't a lone variable. + Consider + case $fMonadST @ RealWorld of { :DMonad a b c -> c } + We had better inline that sucker! The case won't see through it. + + For now, I'm treating treating a variable applied to types + in a *lazy* context "lone". The motivating example was + f = /\a. \x. BIG + g = /\a. \y. h (f a) + There's no advantage in inlining f here, and perhaps + a significant disadvantage. Hence some_val_args in the Stop case + +Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lone-variable test says "don't inline if a case expression +scrutinises a lone variable whose unfolding is cheap". It's very +important that, under these circumstances, exprIsConApp_maybe +can spot a constructor application. So, for example, we don't +consider + let x = e in (x,x) +to be cheap, and that's good because exprIsConApp_maybe doesn't +think that expression is a constructor application. + +In the 'not (lone_variable && is_wf)' test, I used to test is_value +rather than is_wf, which was utterly wrong, because the above +expression responds True to exprIsHNF, which is what sets is_value. + +This kind of thing can occur if you have + + {-# INLINE foo #-} + foo = let x = e in (x,x) + +which Roman did. + + +-} + +computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt + -> Int +computeDiscount arg_discounts res_discount arg_infos cont_info + + = 10 -- Discount of 10 because the result replaces the call + -- so we count 10 for the function itself + + + 10 * length actual_arg_discounts + -- Discount of 10 for each arg supplied, + -- because the result replaces the call + + + total_arg_discount + res_discount' + where + actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos + total_arg_discount = sum actual_arg_discounts + + mk_arg_discount _ TrivArg = 0 + mk_arg_discount _ NonTrivArg = 10 + mk_arg_discount discount ValueArg = discount + + res_discount' + | LT <- arg_discounts `compareLength` arg_infos + = res_discount -- Over-saturated + | otherwise + = case cont_info of + BoringCtxt -> 0 + CaseCtxt -> res_discount -- Presumably a constructor + ValAppCtxt -> res_discount -- Presumably a function + _ -> 40 `min` res_discount + -- ToDo: this 40 `min` res_discount doesn't seem right + -- for DiscArgCtxt it shouldn't matter because the function will + -- get the arg discount for any non-triv arg + -- for RuleArgCtxt we do want to be keener to inline; but not only + -- constructor results + -- for RhsCtxt I suppose that exposing a data con is good in general + -- And 40 seems very arbitrary + -- + -- res_discount can be very large when a function returns + -- constructors; but we only want to invoke that large discount + -- when there's a case continuation. + -- Otherwise we, rather arbitrarily, threshold it. Yuk. + -- But we want to avoid inlining large functions that return + -- constructors into contexts that are simply "interesting" diff --git a/GHC/Core/Unfold.hs-boot b/GHC/Core/Unfold.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Unfold.hs-boot @@ -0,0 +1,16 @@ +module GHC.Core.Unfold ( + mkUnfolding, mkInlineUnfolding + ) where + +import GHC.Prelude +import GHC.Core +import GHC.Driver.Session + +mkInlineUnfolding :: CoreExpr -> Unfolding + +mkUnfolding :: DynFlags + -> UnfoldingSource + -> Bool + -> Bool + -> CoreExpr + -> Unfolding diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Unify.hs @@ -0,0 +1,1670 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Core.Unify ( + tcMatchTy, tcMatchTyKi, + tcMatchTys, tcMatchTyKis, + tcMatchTyX, tcMatchTysX, tcMatchTyKisX, + tcMatchTyX_BM, ruleMatchTyKiX, + + -- * Rough matching + roughMatchTcs, instanceCantMatch, + typesCantMatch, + + -- Side-effect free unification + tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, + tcUnifyTysFG, tcUnifyTyWithTFs, + BindFlag(..), + UnifyResult, UnifyResultM(..), + + -- Matching a type against a lifted type (coercion) + liftCoMatch + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name( Name ) +import GHC.Core.Type hiding ( getTvSubstEnv ) +import GHC.Core.Coercion hiding ( getCvSubstEnv ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) +import GHC.Core.TyCo.Subst ( mkTvSubst ) +import GHC.Utils.FV( FV, fvVarSet, fvVarList ) +import GHC.Utils.Misc +import GHC.Data.Pair +import GHC.Utils.Outputable +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Exts( oneShot ) + +import Control.Monad +import Control.Applicative hiding ( empty ) +import qualified Control.Applicative + +{- + +Unification is much tricker than you might think. + +1. The substitution we generate binds the *template type variables* + which are given to us explicitly. + +2. We want to match in the presence of foralls; + e.g (forall a. t1) ~ (forall b. t2) + + That is what the RnEnv2 is for; it does the alpha-renaming + that makes it as if a and b were the same variable. + Initialising the RnEnv2, so that it can generate a fresh + binder when necessary, entails knowing the free variables of + both types. + +3. We must be careful not to bind a template type variable to a + locally bound variable. E.g. + (forall a. x) ~ (forall b. b) + where x is the template type variable. Then we do not want to + bind x to a/b! This is a kind of occurs check. + The necessary locals accumulate in the RnEnv2. + +Note [tcMatchTy vs tcMatchTyKi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module offers two variants of matching: with kinds and without. +The TyKi variant takes two types, of potentially different kinds, +and matches them. Along the way, it necessarily also matches their +kinds. The Ty variant instead assumes that the kinds are already +eqType and so skips matching up the kinds. + +How do you choose between them? + +1. If you know that the kinds of the two types are eqType, use + the Ty variant. It is more efficient, as it does less work. + +2. If the kinds of variables in the template type might mention type families, + use the Ty variant (and do other work to make sure the kinds + work out). These pure unification functions do a straightforward + syntactic unification and do no complex reasoning about type + families. Note that the types of the variables in instances can indeed + mention type families, so instance lookup must use the Ty variant. + + (Nothing goes terribly wrong -- no panics -- if there might be type + families in kinds in the TyKi variant. You just might get match + failure even though a reducing a type family would lead to success.) + +3. Otherwise, if you're sure that the variable kinds do not mention + type families and you're not already sure that the kind of the template + equals the kind of the target, then use the TyKi version. +-} + +-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) +-- @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might bind coercion variables, +-- if the variable is an argument to a GADT constructor. +-- +-- Precondition: typeKind ty1 `eqType` typeKind ty2 +-- +-- We don't pass in a set of "template variables" to be bound +-- by the match, because tcMatchTy (and similar functions) are +-- always used on top-level types, so we can bind any of the +-- free variables of the LHS. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTy :: Type -> Type -> Maybe TCvSubst +tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] + +tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst + -> Type -> Type -> Maybe TCvSubst +tcMatchTyX_BM bind_me subst ty1 ty2 + = tc_match_tys_x bind_me False subst [ty1] [ty2] + +-- | Like 'tcMatchTy', but allows the kinds of the types to differ, +-- and thus matches them as well. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKi :: Type -> Type -> Maybe TCvSubst +tcMatchTyKi ty1 ty2 + = tc_match_tys (const BindMe) True [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyX :: TCvSubst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TCvSubst +tcMatchTyX subst ty1 ty2 + = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTys :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot; in principle the template + -- variables could be free in the target +tcMatchTys tys1 tys2 + = tc_match_tys (const BindMe) False tys1 tys2 + +-- | Like 'tcMatchTyKi' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKis :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKis tys1 tys2 + = tc_match_tys (const BindMe) True tys1 tys2 + +-- | Like 'tcMatchTys', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTysX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTysX subst tys1 tys2 + = tc_match_tys_x (const BindMe) False subst tys1 tys2 + +-- | Like 'tcMatchTyKis', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKisX subst tys1 tys2 + = tc_match_tys_x (const BindMe) True subst tys1 tys2 + +-- | Same as tc_match_tys_x, but starts with an empty substitution +tc_match_tys :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys bind_me match_kis tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 + where + in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + +-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' +tc_match_tys_x :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> TCvSubst + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + = case tc_unify_tys bind_me + False -- Matching, not unifying + False -- Not an injectivity check + match_kis + (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of + Unifiable (tv_env', cv_env') + -> Just $ TCvSubst in_scope tv_env' cv_env' + _ -> Nothing + +-- | This one is called from the expression matcher, +-- which already has a MatchEnv in hand +ruleMatchTyKiX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpl_tvs) False False + True -- <-- this means to match the kinds + rn_env tenv emptyCvSubstEnv [tmpl] [target] of + Unifiable (tenv', _) -> Just tenv' + _ -> Nothing + +matchBindFun :: TyCoVarSet -> TyVar -> BindFlag +matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem + + +{- ********************************************************************* +* * + Rough matching +* * +********************************************************************* -} + +-- See Note [Rough match] field in GHC.Core.InstEnv + +roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs tys = map rough tys + where + rough ty + | Just (ty', _) <- splitCastTy_maybe ty = rough ty' + | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) + | otherwise = Nothing + +instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: Maybe Name -> Maybe Name -> Bool +itemCantMatch (Just t) (Just a) = t /= a +itemCantMatch _ _ = False + + +{- +************************************************************************ +* * + GADTs +* * +************************************************************************ + +Note [Pruning dead case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider data T a where + T1 :: T Int + T2 :: T a + + newtype X = MkX Int + newtype Y = MkY Char + + type family F a + type instance F Bool = Int + +Now consider case x of { T1 -> e1; T2 -> e2 } + +The question before the house is this: if I know something about the type +of x, can I prune away the T1 alternative? + +Suppose x::T Char. It's impossible to construct a (T Char) using T1, + Answer = YES we can prune the T1 branch (clearly) + +Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated +to 'Bool', in which case x::T Int, so + ANSWER = NO (clearly) + +We see here that we want precisely the apartness check implemented within +tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely +apart. Note that since we are simply dropping dead code, a conservative test +suffices. +-} + +-- | Given a list of pairs of types, are any two members of a pair surely +-- apart, even after arbitrary type function evaluation and substitution? +typesCantMatch :: [(Type,Type)] -> Bool +-- See Note [Pruning dead case alternatives] +typesCantMatch prs = any (uncurry cant_match) prs + where + cant_match :: Type -> Type -> Bool + cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of + SurelyApart -> True + _ -> False + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [Fine-grained unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. But, a substitution to +*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. +Why do we care? Consider these two type family instances: + +type instance F x x = Int +type instance F [y] y = Bool + +If we also have + +type instance Looper = [Looper] + +then the instances potentially overlap. The solution is to use unification +over infinite terms. This is possible (see [1] for lots of gory details), but +a full algorithm is a little more power than we need. Instead, we make a +conservative approximation and just omit the occurs check. + +[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf + +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. + +tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check +failure ("MaybeApart"), or general failure ("SurelyApart"). + +See also #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: + +(a, a, Int) ~ (b, [b], Bool) + +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Fine-grained unification]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. + +Note [Unification with skolems] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we discover that two types unify if and only if a skolem variable is +substituted, we can't properly unify the types. But, that skolem variable +may later be instantiated with a unifyable type. So, we return maybeApart +in these cases. +-} + +-- | Simple unification of two types; all type variables are bindable +-- Precondition: the kinds are already equal +tcUnifyTy :: Type -> Type -- All tyvars are bindable + -> Maybe TCvSubst + -- A regular one-shot (idempotent) substitution +tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] + +-- | Like 'tcUnifyTy', but also unifies the kinds +tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst +tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] + +-- | Unify two types, treating type family applications as possibly unifying +-- with anything and looking through injective type family applications. +-- Precondition: kinds are the same +tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; + -- False <=> do one-way matching. + -- See end of sec 5.2 from the paper + -> Type -> Type -> Maybe TCvSubst +-- This algorithm is an implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. +-- The code is incorporated with the standard unifier for convenience, but +-- its operation should match the specification in the paper. +tcUnifyTyWithTFs twoWay t1 t2 + = case tc_unify_tys (const BindMe) twoWay True False + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (subst, _) -> Just $ maybe_fix subst + MaybeApart (subst, _) -> Just $ maybe_fix subst + -- we want to *succeed* in questionable cases. This is a + -- pre-unification algorithm. + SurelyApart -> Nothing + where + in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] + rn_env = mkRnEnv2 in_scope + + maybe_fix | twoWay = niFixTCvSubst + | otherwise = mkTvSubst in_scope -- when matching, don't confuse + -- domain with range + +----------------- +tcUnifyTys :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst + -- ^ A regular one-shot (idempotent) substitution + -- that unifies the erased types. See comments + -- for 'tcUnifyTysFG' + +-- The two types may have common type variables, and indeed do so in the +-- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD +tcUnifyTys bind_fn tys1 tys2 + = case tcUnifyTysFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- | Like 'tcUnifyTys' but also unifies the kinds +tcUnifyTyKis :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst +tcUnifyTyKis bind_fn tys1 tys2 + = case tcUnifyTyKisFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. See Note [Fine-grained unification] +type UnifyResult = UnifyResultM TCvSubst +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart a -- the subst has as much as we know + -- it must be part of a most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + deriving Functor + +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + + SurelyApart >>= _ = SurelyApart + MaybeApart x >>= f = case f x of + Unifiable y -> MaybeApart y + other -> other + Unifiable x >>= f = f x + +instance Alternative UnifyResultM where + empty = SurelyApart + + a@(Unifiable {}) <|> _ = a + _ <|> b@(Unifiable {}) = b + a@(MaybeApart {}) <|> _ = a + _ <|> b@(MaybeApart {}) = b + SurelyApart <|> SurelyApart = SurelyApart + +instance MonadPlus UnifyResultM + +-- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose +-- domain elements all respond 'BindMe' to @bind_tv@) such that +-- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned +-- Coercions. This version requires that the kinds of the types are the same, +-- if you unify left-to-right. +tcUnifyTysFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fn tys1 tys2 + = tc_unify_tys_fg False bind_fn tys1 tys2 + +tcUnifyTyKisFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTyKisFG bind_fn tys1 tys2 + = tc_unify_tys_fg True bind_fn tys1 tys2 + +tc_unify_tys_fg :: Bool + -> (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tc_unify_tys_fg match_kis bind_fn tys1 tys2 + = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env + emptyTvSubstEnv emptyCvSubstEnv + tys1 tys2 + ; return $ niFixTCvSubst env } + where + vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + env = mkRnEnv2 $ mkInScopeSet vars + +-- | This function is actually the one to call the unifier -- a little +-- too general for outside clients, though. +tc_unify_tys :: (TyVar -> BindFlag) + -> AmIUnifying -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> Bool -- ^ True <=> treat the kinds as well + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then +-- the kinds of the types should be the same. However, this doesn't work, +-- as the types may be a dependent telescope, where later types have kinds +-- that mention variables occurring earlier in the list of types. Here's an +-- example (from typecheck/should_fail/T12709): +-- template: [rep :: RuntimeRep, a :: TYPE rep] +-- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] +-- We can see that matching the first pair will make the kinds of the second +-- pair equal. Yet, we still don't need a separate pass to unify the kinds +-- of these types, so it's appropriate to use the Ty variant of unification. +-- See also Note [tcMatchTy vs tcMatchTyKi]. +tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 + = initUM tv_env cv_env $ + do { when match_kis $ + unify_tys env kis1 kis2 + ; unify_tys env tys1 tys2 + ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } + where + env = UMEnv { um_bind_fun = bind_fn + , um_skols = emptyVarSet + , um_unif = unif + , um_inj_tf = inj_check + , um_rn_env = rn_env } + + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 + +instance Outputable a => Outputable (UnifyResultM a) where + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart x) = text "MaybeApart" <+> ppr x + +{- +************************************************************************ +* * + Non-idempotent substitution +* * +************************************************************************ + +Note [Non-idempotent substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During unification we use a TvSubstEnv/CvSubstEnv pair that is + (a) non-idempotent + (b) loop-free; ie repeatedly applying it yields a fixed point + +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is much trickier than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitution to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in #9106. + +It gets worse. In #14164 we wanted to take the fixpoint of +this substitution + [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) + (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) + , a_aY6 :-> a_aXQ ] + +We have to apply the substitution for a_aY6 two levels deep inside +the invocation of F! We don't have a function that recursively +applies substitutions inside the kinds of variable occurrences (and +probably rightly so). + +So, we work as follows: + + 1. Start with the current substitution (which we are + trying to fixpoint + [ xs :-> F a (z :: a) (rest :: G a (z :: a)) + , a :-> b ] + + 2. Take all the free vars of the range of the substitution: + {a, z, rest, b} + NB: the free variable finder closes over + the kinds of variable occurrences + + 3. If none are in the domain of the substitution, stop. + We have found a fixpoint. + + 4. Remove the variables that are bound by the substitution, leaving + {z, rest, b} + + 5. Do a topo-sort to put them in dependency order: + [ b :: *, z :: a, rest :: G a z ] + + 6. Apply the substitution left-to-right to the kinds of these + tyvars, extending it each time with a new binding, so we + finish up with + [ xs :-> ..as before.. + , a :-> b + , b :-> b :: * + , z :-> z :: b + , rest :-> rest :: G b (z :: b) ] + Note that rest now has the right kind + + 7. Apply this extended substitution (once) to the range of + the /original/ substitution. (Note that we do the + extended substitution would go on forever if you tried + to find its fixpoint, because it maps z to z.) + + 8. And go back to step 1 + +In Step 6 we use the free vars from Step 2 as the initial +in-scope set, because all of those variables appear in the +range of the substitution, so they must all be in the in-scope +set. But NB that the type substitution engine does not look up +variables in the in-scope set; it is used only to ensure no +shadowing. +-} + +niFixTCvSubst :: TvSubstEnv -> TCvSubst +-- Find the idempotent fixed point of the non-idempotent substitution +-- This is surprisingly tricky: +-- see Note [Finding the substitution fixpoint] +-- ToDo: use laziness instead of iteration? +niFixTCvSubst tenv + | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) + | otherwise = subst + where + range_fvs :: FV + range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) + -- It's OK to use nonDetEltsUFM here because the + -- order of range_fvs, range_tvs is immaterial + + range_tvs :: [TyVar] + range_tvs = fvVarList range_fvs + + not_fixpoint = any in_domain range_tvs + in_domain tv = tv `elemVarEnv` tenv + + free_tvs = scopedSort (filterOut in_domain range_tvs) + + -- See Note [Finding the substitution fixpoint], Step 6 + init_in_scope = mkInScopeSet (fvVarSet range_fvs) + subst = foldl' add_free_tv + (mkTvSubst init_in_scope tenv) + free_tvs + + add_free_tv :: TCvSubst -> TyVar -> TCvSubst + add_free_tv subst tv + = extendTvSubst subst tv (mkTyVarTy tv') + where + tv' = updateTyVarKind (substTy subst) tv + +niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet +-- Apply the non-idempotent substitution to a set of type variables, +-- remembering that the substitution isn't necessarily idempotent +-- This is used in the occurs check, before extending the substitution +niSubstTvSet tsubst tvs + = nonDetStrictFoldUniqSet (unionVarSet . get) emptyVarSet tvs + -- It's OK to use a non-deterministic fold here because we immediately forget + -- the ordering by creating a set. + where + get tv + | Just ty <- lookupVarEnv tsubst tv + = niSubstTvSet tsubst (tyCoVarsOfType ty) + + | otherwise + = unitVarSet tv + +{- +************************************************************************ +* * + unify_ty: the main workhorse +* * +************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The pure unifier, unify_ty, defined in this module, tries to work out +a substitution to make two types say True to eqType. NB: eqType is +itself not purely syntactic; it accounts for CastTys; +see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + +Unlike the "impure unifiers" in the typechecker (the eager unifier in +GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Canonical), the pure +unifier It does /not/ work up to ~. + +The algorithm implemented here is rather delicate, and we depend on it +to uphold certain properties. This is a summary of these required +properties. Any reference to "flattening" refers to the flattening +algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.FamInstEnv), not +the flattening algorithm in the solver. + +Notation: + θ,φ substitutions + ξ type-function-free types + τ,σ other types + τ♭ type τ, flattened + + ≡ eqType + +(U1) Soundness. + If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). + θ is a most general unifier for τ₁ and τ₂. + +(U2) Completeness. + If (unify ξ₁ ξ₂) = SurelyApart, + then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). + +These two properties are stated as Property 11 in the "Closed Type Families" +paper (POPL'14). Below, this paper is called [CTF]. + +(U3) Apartness under substitution. + If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, + for any θ. (Property 12 from [CTF]) + +(U4) Apart types do not unify. + If (unify ξ τ♭) = SurelyApart, then there exists no θ + such that θ(ξ) = θ(τ). (Property 13 from [CTF]) + +THEOREM. Completeness w.r.t ~ + If (unify τ₁♭ τ₂♭) = SurelyApart, + then there exists no proof that (τ₁ ~ τ₂). + +PROOF. See appendix of [CTF]. + + +The unification algorithm is used for type family injectivity, as described +in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run +in this mode, it has the following properties. + +(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even + after arbitrary type family reductions. Note that σ and τ are + not flattened here. + +(I2) If (unify σ τ) = MaybeApart θ, and if some + φ exists such that φ(σ) ~ φ(τ), then φ extends θ. + + +Furthermore, the RULES matching algorithm requires this property, +but only when using this algorithm for matching: + +(M1) If (match σ τ) succeeds with θ, then all matchable tyvars + in σ are bound in θ. + + Property M1 means that we must extend the substitution with, + say (a ↦ a) when appropriate during matching. + See also Note [Self-substitution when matching]. + +(M2) Completeness of matching. + If θ(σ) = τ, then (match σ τ) = Unifiable φ, + where θ is an extension of φ. + +Sadly, property M2 and I2 conflict. Consider + +type family F1 a b where + F1 Int Bool = Char + F1 Double String = Char + +Consider now two matching problems: + +P1. match (F1 a Bool) (F1 Int Bool) +P2. match (F1 a Bool) (F1 Double String) + +In case P1, we must find (a ↦ Int) to satisfy M2. +In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note +that the correct mapping for I2 is (a ↦ Int). There is no way to discover +this, but we mustn't map a to anything else!) + +We thus must parameterize the algorithm over whether it's being used +for an injectivity check (refrain from looking at non-injective arguments +to type families) or not (do indeed look at those arguments). This is +implemented by the uf_inj_tf field of UmEnv. + +(It's all a question of whether or not to include equation (7) from Fig. 2 +of [ITF].) + +This extra parameter is a bit fiddly, perhaps, but seemingly less so than +having two separate, almost-identical algorithms. + +Note [Self-substitution when matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should happen when we're *matching* (not unifying) a1 with a1? We +should get a substitution [a1 |-> a1]. A successful match should map all +the template variables (except ones that disappear when expanding synonyms). +But when unifying, we don't want to do this, because we'll then fall into +a loop. + +This arrangement affects the code in three places: + - If we're matching a refined template variable, don't recur. Instead, just + check for equality. That is, if we know [a |-> Maybe a] and are matching + (a ~? Maybe Int), we want to just fail. + + - Skip the occurs check when matching. This comes up in two places, because + matching against variables is handled separately from matching against + full-on types. + +Note that this arrangement was provoked by a real failure, where the same +unique ended up in the template as in the target. (It was a rule firing when +compiling Data.List.NonEmpty.) + +Note [Matching coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + +We would like that to be accepted. For that to work, we need to introduce +a coercion variable on the left and then use it on the right. Accordingly, +at use sites of Foo, we need to be able to use matching to figure out the +value for the coercion. (See the desugared version: + + axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) + +) We never want this action to happen during *unification* though, when +all bets are off. + +Note [Kind coercions in Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to match/unify while ignoring casts. But, we can't just ignore +them completely, or we'll end up with ill-kinded substitutions. For example, +say we're matching `a` with `ty |> co`. If we just drop the cast, we'll +return [a |-> ty], but `a` and `ty` might have different kinds. We can't +just match/unify their kinds, either, because this might gratuitously +fail. After all, `co` is the witness that the kinds are the same -- they +may look nothing alike. + +So, we pass a kind coercion to the match/unify worker. This coercion witnesses +the equality between the substed kind of the left-hand type and the substed +kind of the right-hand type. Note that we do not unify kinds at the leaves +(as we did previously). We thus have + +INVARIANT: In the call + unify_ty ty1 ty2 kco +it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where +`subst` is the ambient substitution in the UM monad. + +To get this coercion, we first have to match/unify +the kinds before looking at the types. Happily, we need look only one level +up, as all kinds are guaranteed to have kind *. + +When we're working with type applications (either TyConApp or AppTy) we +need to worry about establishing INVARIANT, as the kinds of the function +& arguments aren't (necessarily) included in the kind of the result. +When unifying two TyConApps, this is easy, because the two TyCons are +the same. Their kinds are thus the same. As long as we unify left-to-right, +we'll be sure to unify types' kinds before the types themselves. (For example, +think about Proxy :: forall k. k -> *. Unifying the first args matches up +the kinds of the second args.) + +For AppTy, we must unify the kinds of the functions, but once these are +unified, we can continue unifying arguments without worrying further about +kinds. + +The interface to this module includes both "...Ty" functions and +"...TyKi" functions. The former assume that INVARIANT is already +established, either because the kinds are the same or because the +list of types being passed in are the well-typed arguments to some +type constructor (see two paragraphs above). The latter take a separate +pre-pass over the kinds to establish INVARIANT. Sometimes, it's important +not to take the second pass, as it caused #12442. + +We thought, at one point, that this was all unnecessary: why should +casts be in types in the first place? But they are sometimes. In +dependent/should_compile/KindEqualities2, we see, for example the +constraint Num (Int |> (blah ; sym blah)). We naturally want to find +a dictionary for that constraint, which requires dealing with +coercions in this manner. + +Note [Matching in the presence of casts (1)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching, it is crucial that no variables from the template +end up in the range of the matching substitution (obviously!). +When unifying, that's not a constraint; instead we take the fixpoint +of the substitution at the end. + +So what should we do with this, when matching? + unify_ty (tmpl |> co) tgt kco + +Previously, wrongly, we pushed 'co' in the (horrid) accumulating +'kco' argument like this: + unify_ty (tmpl |> co) tgt kco + = unify_ty tmpl tgt (kco ; co) + +But that is obviously wrong because 'co' (from the template) ends +up in 'kco', which in turn ends up in the range of the substitution. + +This all came up in #13910. Because we match tycon arguments +left-to-right, the ambient substitution will already have a matching +substitution for any kinds; so there is an easy fix: just apply +the substitution-so-far to the coercion from the LHS. + +Note that + +* When matching, the first arg of unify_ty is always the template; + we never swap round. + +* The above argument is distressingly indirect. We seek a + better way. + +* One better way is to ensure that type patterns (the template + in the matching process) have no casts. See #14119. + +Note [Matching in the presence of casts (2)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) +and we are matching + tcMatchTy (T k (a::k)) (T j (b::j)) + +Then we'll match k :-> j, as expected. But then in unify_tys +we invoke + unify_tys env (a::k) (b::j) (Refl j) + +Although we have unified k and j, it's very important that we put +(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. +If we put (Refl k) we'd end up with the substitution + a :-> b |> Refl k +which is bogus because one of the template variables, k, +appears in the range of the substitution. Eek. + +Similar care is needed in unify_ty_app. + + +Note [Polykinded tycon applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: forall k. Type -> K +and we are unifying + ty1: T @Type Int :: Type + ty2: T @(Type->Type) Int Int :: Type + +These two TyConApps have the same TyCon at the front but they +(legitimately) have different numbers of arguments. They +are surelyApart, so we can report that without looking any +further (see #15704). +-} + +-------------- unify_ty: the main workhorse ----------- + +type AmIUnifying = Bool -- True <=> Unifying + -- False <=> Matching + +unify_ty :: UMEnv + -> Type -> Type -- Types to be unified and a co + -> CoercionN -- A coercion between their kinds + -- See Note [Kind coercions in Unify] + -> UM () +-- See Note [Specification of unification] +-- Respects newtypes, PredTypes + +unify_ty env ty1 ty2 kco + -- TODO: More commentary needed here + | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco + | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco + | CastTy ty1' co <- ty1 = if um_unif env + then unify_ty env ty1' ty2 (co `mkTransCo` kco) + else -- See Note [Matching in the presence of casts (1)] + do { subst <- getSubst env + ; let co' = substCo subst co + ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } + | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) + +unify_ty env (TyVarTy tv1) ty2 kco + = uVar env tv1 ty2 kco +unify_ty env ty1 (TyVarTy tv2) kco + | um_unif env -- If unifying, can swap args + = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) + +unify_ty env ty1 ty2 _kco + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 + , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) + = if isInjectiveTyCon tc1 Nominal + then unify_tys env tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case tyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs + | otherwise + = repeat False + + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 + + ; unify_tys env inj_tys1 inj_tys2 + ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] + don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } + + | Just (tc1, _) <- mb_tc_app1 + , not (isGenerativeTyCon tc1 Nominal) + -- E.g. unify_ty (F ty1) b = MaybeApart + -- because the (F ty1) behaves like a variable + -- NB: if unifying, we have already dealt + -- with the 'ty2 = variable' case + = maybeApart + + | Just (tc2, _) <- mb_tc_app2 + , not (isGenerativeTyCon tc2 Nominal) + , um_unif env + -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) + -- because the (F ty2) behaves like a variable + -- NB: we have already dealt with the 'ty1 = variable' case + = maybeApart + + where + mb_tc_app1 = tcSplitTyConApp_maybe ty1 + mb_tc_app2 = tcSplitTyConApp_maybe ty2 + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp, so use splitAppTy_maybe + -- NB: we've already dealt with type variables, + -- so if one type is an App the other one jolly well better be too +unify_ty env (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty env ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco + = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) + ; let env' = umRnBndr2 env tv1 tv2 + ; unify_ty env' ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty env (CoercionTy co1) (CoercionTy co2) kco + = do { c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not (um_unif env) + , not (cv `elemVarEnv` c_subst) + , BindMe <- tvBindFlag env cv + -> do { checkRnEnv env (tyCoVarsOfCo co2) + ; let (_, co_l, co_r) = decomposeFunCo Nominal kco + -- Because the coercion is nominal, it should be safe to + -- ignore the multiplicity coercion. + -- cv :: t1 ~ t2 + -- co2 :: s1 ~ s2 + -- co_l :: t1 ~ s1 + -- co_r :: t2 ~ s2 + ; extendCvEnv cv (co_l `mkTransCo` + co2 `mkTransCo` + mkSymCo co_r) } + _ -> return () } + +unify_ty _ _ _ _ = surelyApart + +unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () +unify_ty_app env ty1 ty1args ty2 ty2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 + = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) + + | otherwise + = do { let ki1 = typeKind ty1 + ki2 = typeKind ty2 + -- See Note [Kind coercions in Unify] + ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) + ; unify_ty env ty1 ty2 (mkNomReflCo ki2) + -- Very important: 'ki2' not 'ki1' + -- See Note [Matching in the presence of casts (2)] + ; unify_tys env ty1args ty2args } + +unify_tys :: UMEnv -> [Type] -> [Type] -> UM () +unify_tys env orig_xs orig_ys + = go orig_xs orig_ys + where + go [] [] = return () + go (x:xs) (y:ys) + -- See Note [Kind coercions in Unify] + = do { unify_ty env x y (mkNomReflCo $ typeKind y) + -- Very important: 'y' not 'x' + -- See Note [Matching in the presence of casts (2)] + ; go xs ys } + go _ _ = surelyApart + -- Possibly different saturations of a polykinded tycon + -- See Note [Polykinded tycon applications] + +--------------------------------- +uVar :: UMEnv + -> InTyVar -- Variable to be unified + -> Type -- with this Type + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +uVar env tv1 ty kco + = do { -- Apply the ambient renaming + let tv1' = umRnOccL env tv1 + + -- Check to see whether tv1 is refined by the substitution + ; subst <- getTvSubstEnv + ; case (lookupVarEnv subst tv1') of + Just ty' | um_unif env -- Unifying, so call + -> unify_ty env ty' ty kco -- back into unify + | otherwise + -> -- Matching, we don't want to just recur here. + -- this is because the range of the subst is the target + -- type, not the template type. So, just check for + -- normal type equality. + guard ((ty' `mkCastTy` kco) `eqType` ty) + Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue + +uUnrefined :: UMEnv + -> OutTyVar -- variable to be unified + -> Type -- with this Type + -> Type -- (version w/ expanded synonyms) + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +-- We know that tv1 isn't refined + +uUnrefined env tv1' ty2 ty2' kco + | Just ty2'' <- coreView ty2' + = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms + -- This is essential, in case we have + -- type Foo a = a + -- and then unify a ~ Foo a + + | TyVarTy tv2 <- ty2' + = do { let tv2' = umRnOccR env tv2 + ; unless (tv1' == tv2' && um_unif env) $ do + -- If we are unifying a ~ a, just return immediately + -- Do not extend the substitution + -- See Note [Self-substitution when matching] + + -- Check to see whether tv2 is refined + { subst <- getTvSubstEnv + ; case lookupVarEnv subst tv2 of + { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco + ; _ -> + + do { -- So both are unrefined + -- Bind one or the other, depending on which is bindable + ; let b1 = tvBindFlag env tv1' + b2 = tvBindFlag env tv2' + ty1 = mkTyVarTy tv1' + ; case (b1, b2) of + (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + (_, BindMe) | um_unif env + -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco) + + _ | tv1' == tv2' -> return () + -- How could this happen? If we're only matching and if + -- we're comparing forall-bound variables. + + _ -> maybeApart -- See Note [Unification with skolems] + }}}} + +uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable + = case tvBindFlag env tv1' of + Skolem -> maybeApart -- See Note [Unification with skolems] + BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + +bindTv :: UMEnv -> OutTyVar -> Type -> UM () +-- OK, so we want to extend the substitution with tv := ty +-- But first, we must do a couple of checks +bindTv env tv1 ty2 + = do { let free_tvs2 = tyCoVarsOfType ty2 + + -- Make sure tys mentions no local variables + -- E.g. (forall a. b) ~ (forall a. [a]) + -- We should not unify b := [a]! + ; checkRnEnv env free_tvs2 + + -- Occurs check, see Note [Fine-grained unification] + -- Make sure you include 'kco' (which ty2 does) #14846 + ; occurs <- occursCheck env tv1 free_tvs2 + + ; if occurs then maybeApart + else extendTvEnv tv1 ty2 } + +occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool +occursCheck env tv free_tvs + | um_unif env + = do { tsubst <- getTvSubstEnv + ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } + + | otherwise -- Matching; no occurs check + = return False -- See Note [Self-substitution when matching] + +{- +%************************************************************************ +%* * + Binding decisions +* * +************************************************************************ +-} + +data BindFlag + = BindMe -- A regular type variable + + | Skolem -- This type variable is a skolem constant + -- Don't bind it; it only matches itself + deriving Eq + +{- +************************************************************************ +* * + Unification monad +* * +************************************************************************ +-} + +{- Note [The one-shot state monad trick] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many places in GHC use a state monad, and we really want those +functions to be eta-expanded (#18202). Consider + + newtype M a = MkM (State -> (State, a)) + + instance Monad M where + mf >>= k = MkM (\s -> case mf of MkM f -> + case f s of (s',r) -> + case k r of MkM g -> + g s') + + foo :: Int -> M Int + foo x = g y >>= \r -> h r + where + y = expensive x + +In general, you might say (map (foo 4) xs), and expect (expensive 4) +to be evaluated only once. So foo should have arity 1 (not 2). +But that's rare, and if you /aren't/ re-using (M a) values it's much +more efficient to make foo have arity 2. + +See https://www.joachim-breitner.de/blog/763-Faster_Winter_5__Eta-Expanding_ReaderT + +So here is the trick. Define + + data M a = MkM' (State -> (State, a)) + pattern MkM f <- MkM' f + where + MkM f = MkM' (oneShot f) + +The patten synonm means that whenever we write (MkM f), we'll +actually get (MkM' (oneShot f)), so we'll pin a one-shot flag +on f's lambda-binder. Now look at foo: + + foo = \x. g (expensive x) >>= \r -> h r + = \x. let mf = g (expensive x) + k = \r -> h r + in MkM' (oneShot (\s -> case mf of MkM' f -> + case f s of (s',r) -> + case k r of MkM' g -> + g s')) + -- The MkM' are just newtype casts nt_co + = \x. let mf = g (expensive x) + k = \r -> h r + in (\s{os}. case (mf |> nt_co) s of (s',r) -> + (k r) |> nt_co s') + |> sym nt_co + + -- Float into that \s{os} + = \x. (\s{os}. case (g (expensive x) |> nt_co) s of (s',r) -> + h r |> nt_co s') + |> sym nt_co + +and voila! In summary: + +* It's a very simple, two-line change + +* It eta-expands all uses of the monad, automatically + +* It is very similar to the built-in "state hack" (see + GHC.Core.Opt.Arity Note [The state-transformer hack]) but the trick + described here is applicable on a monad-by-monad basis under + programmer control. + +* Beware: itt changes the behaviour of + map (foo 3) xs + ToDo: explain what to do if you want to do this +-} + +data UMEnv + = UMEnv { um_unif :: AmIUnifying + + , um_inj_tf :: Bool + -- Checking for injectivity? + -- See (end of) Note [Specification of unification] + + , um_rn_env :: RnEnv2 + -- Renaming InTyVars to OutTyVars; this eliminates + -- shadowing, and lines up matching foralls on the left + -- and right + + , um_skols :: TyVarSet + -- OutTyVars bound by a forall in this unification; + -- Do not bind these in the substitution! + -- See the function tvBindFlag + + , um_bind_fun :: TyVar -> BindFlag + -- User-supplied BindFlag function, + -- for variables not in um_skols + } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv } + +newtype UM a + = UM' { unUM :: UMState -> UnifyResultM (UMState, a) } + -- See Note [The one-shot state monad trick] + deriving (Functor) + +pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a +-- See Note [The one-shot state monad trick] +pattern UM m <- UM' m + where + UM m = UM' (oneShot m) + +instance Applicative UM where + pure a = UM (\s -> pure (s, a)) + (<*>) = ap + +instance Monad UM where + m >>= k = UM (\state -> + do { (state', v) <- unUM m state + ; unUM (k v) state' }) + +-- need this instance because of a use of 'guard' above +instance Alternative UM where + empty = UM (\_ -> Control.Applicative.empty) + m1 <|> m2 = UM (\state -> + unUM m1 state <|> + unUM m2 state) + +instance MonadPlus UM + +instance MonadFail UM where + fail _ = UM (\_ -> SurelyApart) -- failed pattern match + +initUM :: TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM a -> UnifyResultM a +initUM subst_env cv_subst_env um + = case unUM um state of + Unifiable (_, subst) -> Unifiable subst + MaybeApart (_, subst) -> MaybeApart subst + SurelyApart -> SurelyApart + where + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env } + +tvBindFlag :: UMEnv -> OutTyVar -> BindFlag +tvBindFlag env tv + | tv `elemVarSet` um_skols env = Skolem + | otherwise = um_bind_fun env tv + +getTvSubstEnv :: UM TvSubstEnv +getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) + +getCvSubstEnv :: UM CvSubstEnv +getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) + +getSubst :: UMEnv -> UM TCvSubst +getSubst env = do { tv_env <- getTvSubstEnv + ; cv_env <- getCvSubstEnv + ; let in_scope = rnInScopeSet (um_rn_env env) + ; return (mkTCvSubst in_scope (tv_env, cv_env)) } + +extendTvEnv :: TyVar -> Type -> UM () +extendTvEnv tv ty = UM $ \state -> + Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) + +extendCvEnv :: CoVar -> Coercion -> UM () +extendCvEnv cv co = UM $ \state -> + Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) + +umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv +umRnBndr2 env v1 v2 + = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } + where + (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 + +checkRnEnv :: UMEnv -> VarSet -> UM () +checkRnEnv env varset + | isEmptyVarSet skol_vars = return () + | varset `disjointVarSet` skol_vars = return () + | otherwise = maybeApart + -- ToDo: why MaybeApart? + -- I think SurelyApart would be right + where + skol_vars = um_skols env + -- NB: That isEmptyVarSet guard is a critical optimization; + -- it means we don't have to calculate the free vars of + -- the type, often saving quite a bit of allocation. + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: UM () -> UM () +don'tBeSoSure um = UM $ \ state -> + case unUM um state of + SurelyApart -> MaybeApart (state, ()) + other -> other + +umRnOccL :: UMEnv -> TyVar -> TyVar +umRnOccL env v = rnOccL (um_rn_env env) v + +umRnOccR :: UMEnv -> TyVar -> TyVar +umRnOccR env v = rnOccR (um_rn_env env) v + +umSwapRn :: UMEnv -> UMEnv +umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } + +maybeApart :: UM () +maybeApart = UM (\state -> MaybeApart (state, ())) + +surelyApart :: UM a +surelyApart = UM (\_ -> SurelyApart) + +{- +%************************************************************************ +%* * + Matching a (lifted) type against a coercion +%* * +%************************************************************************ + +This section defines essentially an inverse to liftCoSubst. It is defined +here to avoid a dependency from Coercion on this module. + +-} + +data MatchEnv = ME { me_tmpls :: TyVarSet + , me_env :: RnEnv2 } + +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, +-- where @==@ there means that the result of 'liftCoSubst' has the same +-- type as the original co; but may be different under the hood. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +-- Note that this function is incomplete -- it might return Nothing +-- when there does indeed exist a possible lifting context. +-- +-- This function is incomplete in that it doesn't respect the equality +-- in `eqType`. That is, it's possible that this will succeed for t1 and +-- fail for t2, even when t1 `eqType` t2. That's because it depends on +-- there being a very similar structure between the type and the coercion. +-- This incompleteness shouldn't be all that surprising, especially because +-- it depends on the structure of the coercion, which is a silly thing to do. +-- +-- The lifting context produced doesn't have to be exacting in the roles +-- of the mappings. This is because any use of the lifting context will +-- also require a desired role. Thus, this algorithm prefers mapping to +-- nominal coercions where it can do so. +liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext +liftCoMatch tmpls ty co + = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co + ; cenv2 <- ty_co_match menv cenv1 ty co + (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) + ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + + ki = typeKind ty + ki_co = promoteCoercion co + ki_ki_co = mkNomReflCo liftedTypeKind + + Pair co_lkind co_rkind = coercionKind ki_co + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -- ^ ambient helpful info + -> LiftCoEnv -- ^ incoming subst + -> Type -- ^ ty, type to match + -> Coercion -- ^ co, coercion to match against + -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co + -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co + -> Maybe LiftCoEnv +ty_co_match menv subst ty co lkco rkco + | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco + + -- handle Refl case: + | tyCoVarsOfType ty `isNotInDomainOf` subst + , Just (ty', _) <- isReflCo_maybe co + , ty `eqType` ty' + = Just subst + + where + isNotInDomainOf :: VarSet -> VarEnv a -> Bool + isNotInDomainOf set env + = noneSet (\v -> elemVarEnv v env) set + + noneSet :: (Var -> Bool) -> VarSet -> Bool + noneSet f = allVarSet (not . f) + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + -- See Note [Matching in the presence of casts (1)] + = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) + substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' + substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' + in + ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) + (substed_co_r `mkTransCo` rkco) + + | SymCo co' <- co + = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst (TyVarTy tv1) co lkco rkco + | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 + = if eqCoercionX (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) + then Nothing -- occurs check failed + else Just $ extendVarEnv subst tv1' $ + castCoercionKind co (mkSymCo lkco) (mkSymCo rkco) + + | otherwise + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + + -- just look through SubCo's. We don't really care about roles here. +ty_co_match menv subst ty (SubCo co) lkco rkco + = ty_co_match menv subst ty co lkco rkco + +ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco + | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] +ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + -- yes, the one from Type, not TcType; this is for coercion optimization + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco + = ty_co_match_tc menv subst tc1 tys tc2 cos +ty_co_match menv subst (FunTy _ w ty1 ty2) co _lkco _rkco + -- Despite the fact that (->) is polymorphic in five type variables (two + -- runtime rep, a multiplicity and two types), we shouldn't need to + -- explicitly unify the runtime reps here; unifying the types themselves + -- should be sufficient. See Note [Representation of function types]. + | Just (tc, [co_mult, _,_,co1,co2]) <- splitTyConAppCo_maybe co + , tc == funTyCon + = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co_mult,co1,co2] + in ty_co_match_args menv subst [w, ty1, ty2] [co_mult, co1, co2] lkcos rkcos + +ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) + (ForAllCo tv2 kind_co2 co2) + lkco rkco + | isTyVar tv1 && isTyVar tv2 + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 + ki_ki_co ki_ki_co + ; let rn_env0 = me_env menv + rn_env1 = rnBndr2 rn_env0 tv1 tv2 + menv' = menv { me_env = rn_env1 } + ; ty_co_match menv' subst1 ty1 co2 lkco rkco } + where + ki_ki_co = mkNomReflCo liftedTypeKind + +-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) +-- (ForAllCo cv2 kind_co2 co2) +-- lkco rkco +-- | isCoVar cv1 && isCoVar cv2 +-- We seems not to have enough information for this case +-- 1. Given: +-- cv1 :: (s1 :: k1) ~r (s2 :: k2) +-- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) +-- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) +-- :: s1' ~ t1 +-- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) +-- :: s2' ~ t2 +-- Wanted: +-- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 +-- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 +-- Question: How do we get kcoi? +-- 2. Given: +-- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep +-- rkco :: <*> +-- Wanted: +-- ty_co_match menv' subst2 ty1 co2 lkco' rkco' +-- Question: How do we get lkco' and rkco'? + +ty_co_match _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco + = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) + +ty_co_match menv subst ty co1 lkco rkco + | Just (CastTy t co, r) <- isReflCo_maybe co1 + -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us + -- t |> co ~ t ; ; t ~ t |> co + -- But transitive coercions are not helpful. Therefore we deal + -- with it here: we do recursion on the smaller reflexive coercion, + -- while propagating the correct kind coercions. + = let kco' = mkSymCo co + in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') + (rkco `mkTransCo` kco') + + +ty_co_match menv subst ty co lkco rkco + | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco + | otherwise = Nothing + +ty_co_match_tc :: MatchEnv -> LiftCoEnv + -> TyCon -> [Type] + -> TyCon -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_tc menv subst tc1 tys1 tc2 cos2 + = do { guard (tc1 == tc2) + ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } + where + Pair lkcos rkcos + = traverse (fmap mkNomReflCo . coercionKind) cos2 + +ty_co_match_app :: MatchEnv -> LiftCoEnv + -> Type -> [Type] -> Coercion -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_app menv subst ty1 ty1args co2 co2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (co2', co2a) <- splitAppCo_maybe co2 + = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) + + | otherwise + = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 + ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco + ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args + ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } + where + ki1 = typeKind ty1 + ki2 = promoteCoercion co2 + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] + -> [Coercion] -> [Coercion] -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_args _ subst [] [] _ _ = Just subst +ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) + = do { subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args lkcos rkcos } +ty_co_match_args _ _ _ _ _ _ = Nothing + +pushRefl :: Coercion -> Maybe Coercion +pushRefl co = + case (isReflCo_maybe co) of + Just (AppTy ty1 ty2, Nominal) + -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) + Just (FunTy _ w ty1 ty2, r) + | Just rep1 <- getRuntimeRep_maybe ty1 + , Just rep2 <- getRuntimeRep_maybe ty2 + -> Just (TyConAppCo r funTyCon [ multToCo w, mkReflCo r rep1, mkReflCo r rep2 + , mkReflCo r ty1, mkReflCo r ty2 ]) + Just (TyConApp tc tys, r) + -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) + Just (ForAllTy (Bndr tv _) ty, r) + -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) + -- NB: NoRefl variant. Otherwise, we get a loop! + _ -> Nothing diff --git a/GHC/Core/UsageEnv.hs b/GHC/Core/UsageEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/UsageEnv.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ViewPatterns #-} +module GHC.Core.UsageEnv (UsageEnv, addUsage, scaleUsage, zeroUE, + lookupUE, scaleUE, deleteUE, addUE, Usage(..), unitUE, + bottomUE, supUE, supUEs) where + +import Data.Foldable +import GHC.Prelude +import GHC.Core.Multiplicity +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable + +-- +-- * Usage environments +-- + +-- The typechecker and the linter output usage environments. See Note [Usages] +-- in Multiplicity. Every absent name being considered to map to 'Zero' of +-- 'Bottom' depending on a flag. See Note [Zero as a usage] in Multiplicity, see +-- Note [Bottom as a usage] in Multiplicity. + +data Usage = Zero | Bottom | MUsage Mult + +instance Outputable Usage where + ppr Zero = text "0" + ppr Bottom = text "Bottom" + ppr (MUsage x) = ppr x + +addUsage :: Usage -> Usage -> Usage +addUsage Zero x = x +addUsage x Zero = x +addUsage Bottom x = x +addUsage x Bottom = x +addUsage (MUsage x) (MUsage y) = MUsage $ mkMultAdd x y + +scaleUsage :: Mult -> Usage -> Usage +scaleUsage One Bottom = Bottom +scaleUsage _ Zero = Zero +scaleUsage x Bottom = MUsage x +scaleUsage x (MUsage y) = MUsage $ mkMultMul x y + +-- For now, we use extra multiplicity Bottom for empty case. +data UsageEnv = UsageEnv (NameEnv Mult) Bool + +unitUE :: NamedThing n => n -> Mult -> UsageEnv +unitUE x w = UsageEnv (unitNameEnv (getName x) w) False + +zeroUE, bottomUE :: UsageEnv +zeroUE = UsageEnv emptyNameEnv False + +bottomUE = UsageEnv emptyNameEnv True + +addUE :: UsageEnv -> UsageEnv -> UsageEnv +addUE (UsageEnv e1 b1) (UsageEnv e2 b2) = + UsageEnv (plusNameEnv_C mkMultAdd e1 e2) (b1 || b2) + +scaleUE :: Mult -> UsageEnv -> UsageEnv +scaleUE One ue = ue +scaleUE w (UsageEnv e _) = + UsageEnv (mapNameEnv (mkMultMul w) e) False + +supUE :: UsageEnv -> UsageEnv -> UsageEnv +supUE (UsageEnv e1 False) (UsageEnv e2 False) = + UsageEnv (plusNameEnv_CD mkMultSup e1 Many e2 Many) False +supUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_CD2 combineUsage e1 e2) (b1 && b2) + where combineUsage (Just x) (Just y) = mkMultSup x y + combineUsage Nothing (Just x) | b1 = x + | otherwise = Many + combineUsage (Just x) Nothing | b2 = x + | otherwise = Many + combineUsage Nothing Nothing = pprPanic "supUE" (ppr e1 <+> ppr e2) +-- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. + +supUEs :: [UsageEnv] -> UsageEnv +supUEs = foldr supUE bottomUE + + +deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv +deleteUE (UsageEnv e b) x = UsageEnv (delFromNameEnv e (getName x)) b + +-- | |lookupUE x env| returns the multiplicity assigned to |x| in |env|, if |x| is not +-- bound in |env|, then returns |Zero| or |Bottom|. +lookupUE :: NamedThing n => UsageEnv -> n -> Usage +lookupUE (UsageEnv e has_bottom) x = + case lookupNameEnv e (getName x) of + Just w -> MUsage w + Nothing -> if has_bottom then Bottom else Zero + +instance Outputable UsageEnv where + ppr (UsageEnv ne b) = text "UsageEnv:" <+> ppr ne <+> ppr b diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Utils.hs @@ -0,0 +1,2624 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} + +-- | Commonly useful utilities for manipulating the Core language +module GHC.Core.Utils ( + -- * Constructing expressions + mkCast, + mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, + bindNonRec, needsCaseBinding, + mkAltExpr, mkDefaultCase, mkSingleAltCase, + + -- * Taking expressions apart + findDefault, addDefault, findAlt, isDefaultAlt, + mergeAlts, trimConArgs, + filterAlts, combineIdenticalAlts, refineDefaultAlt, + scaleAltsBy, + + -- * Properties of expressions + exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, + mkFunctionType, + isExprLevPoly, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, + getIdFromTrivialExpr_maybe, + exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, + exprIsConLike, + isCheapApp, isExpandableApp, + exprIsTickedString, exprIsTickedString_maybe, + exprIsTopLevelBindable, + altsAreExhaustive, + + -- * Equality + cheapEqExpr, cheapEqExpr', eqExpr, + diffExpr, diffBinds, + + -- * Eta reduction + tryEtaReduce, + + -- * Manipulating data constructors and types + exprToType, exprToCoercion_maybe, + applyTypeToArgs, applyTypeToArg, + dataConRepInstPat, dataConRepFSInstPat, + isEmptyTy, + + -- * Working with ticks + stripTicksTop, stripTicksTopE, stripTicksTopT, + stripTicksE, stripTicksT, + + -- * StaticPtr + collectMakeStaticArgs, + + -- * Join points + isJoinBind, + + -- * unsafeEqualityProof + isUnsafeEqualityProof, + + -- * Dumping stuff + dumpIdInfoOfProgram + ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Core +import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofName ) +import GHC.Core.Ppr +import GHC.Core.FVs( exprFreeVars ) +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Builtin.PrimOps +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Builtin.Names( absentErrorIdKey ) +import GHC.Core.Type as Type +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.Multiplicity +import GHC.Types.Unique +import GHC.Utils.Outputable +import GHC.Builtin.Types.Prim +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.List.SetOps( minusList ) +import GHC.Types.Basic ( Arity ) +import GHC.Utils.Misc +import GHC.Data.Pair +import Data.ByteString ( ByteString ) +import Data.Function ( on ) +import Data.List +import Data.Ord ( comparing ) +import GHC.Data.OrdList +import qualified Data.Set as Set +import GHC.Types.Unique.Set + +{- +************************************************************************ +* * +\subsection{Find the type of a Core atom/expression} +* * +************************************************************************ +-} + +exprType :: CoreExpr -> Type +-- ^ Recover the type of a well-typed Core expression. Fails when +-- applied to the actual 'GHC.Core.Type' expression as it cannot +-- really be said to have a type +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let bind body) + | NonRec tv rhs <- bind -- See Note [Type bindings] + , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) + | otherwise = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkLamType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs e (exprType fun) args + +exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy + +coreAltType :: CoreAlt -> Type +-- ^ Returns the type of the alternatives right hand side +coreAltType alt@(_,bs,rhs) + = case occCheckExpand bs rhs_ty of + -- Note [Existential variables and silly type synonyms] + Just ty -> ty + Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) + where + rhs_ty = exprType rhs + +coreAltsType :: [CoreAlt] -> Type +-- ^ Returns the type of the first alternative, which should be the same as for all alternatives +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "corAltsType" + +mkLamType :: Var -> Type -> Type +-- ^ Makes a @(->)@ type or an implicit forall type, depending +-- on whether it is given a type variable or a term variable. +-- This is used, for example, when producing the type of a lambda. +-- Always uses Inferred binders. +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments + +mkLamType v body_ty + | isTyVar v + = mkForAllTy v Inferred body_ty + + | isCoVar v + , v `elemVarSet` tyCoVarsOfType body_ty + = mkForAllTy v Required body_ty + + | otherwise + = mkFunctionType (varMult v) (varType v) body_ty + +mkFunctionType :: Mult -> Type -> Type -> Type +-- This one works out the AnonArgFlag from the argument type +-- See GHC.Types.Var Note [AnonArgFlag] +mkFunctionType mult arg_ty res_ty + | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag] + = ASSERT(eqType mult Many) + mkInvisFunTy mult arg_ty res_ty + + | otherwise + = mkVisFunTy mult arg_ty res_ty + +mkLamTypes vs ty = foldr mkLamType ty vs + +-- | Is this expression levity polymorphic? This should be the +-- same as saying (isKindLevPoly . typeKind . exprType) but +-- much faster. +isExprLevPoly :: CoreExpr -> Bool +isExprLevPoly = go + where + go (Var _) = False -- no levity-polymorphic binders + go (Lit _) = False -- no levity-polymorphic literals + go e@(App f _) | not (go_app f) = False + | otherwise = check_type e + go (Lam _ _) = False + go (Let _ e) = go e + go e@(Case {}) = check_type e -- checking type is fast + go e@(Cast {}) = check_type e + go (Tick _ e) = go e + go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) + go (Coercion {}) = False -- this case can happen in GHC.Core.Opt.SetLevels + + check_type = isTypeLevPoly . exprType -- slow approach + + -- if the function is a variable (common case), check its + -- levityInfo. This might mean we don't need to look up and compute + -- on the type. Spec of these functions: return False if there is + -- no possibility, ever, of this expression becoming levity polymorphic, + -- no matter what it's applied to; return True otherwise. + -- returning True is always safe. See also Note [Levity info] in + -- IdInfo + go_app (Var id) = not (isNeverLevPolyId id) + go_app (Lit _) = False + go_app (App f _) = go_app f + go_app (Lam _ e) = go_app e + go_app (Let _ e) = go_app e + go_app (Case _ _ ty _) = resultIsLevPoly ty + go_app (Cast _ co) = resultIsLevPoly (coercionRKind co) + go_app (Tick _ e) = go_app e + go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) + go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) + + +{- +Note [Type bindings] +~~~~~~~~~~~~~~~~~~~~ +Core does allow type bindings, although such bindings are +not much used, except in the output of the desugarer. +Example: + let a = Int in (\x:a. x) +Given this, exprType must be careful to substitute 'a' in the +result type (#8522). + +Note [Existential variables and silly type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T (Funny a) + type Funny a = Bool + f :: T -> Bool + f (T x) = x + +Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. +That means that 'exprType' and 'coreAltsType' may give a result that *appears* +to mention an out-of-scope type variable. See #3409 for a more real-world +example. + +Various possibilities suggest themselves: + + - Ignore the problem, and make Lint not complain about such variables + + - Expand all type synonyms (or at least all those that discard arguments) + This is tricky, because at least for top-level things we want to + retain the type the user originally specified. + + - Expand synonyms on the fly, when the problem arises. That is what + we are doing here. It's not too expensive, I think. + +Note that there might be existentially quantified coercion variables, too. +-} + +-- Not defined with applyTypeToArg because you can't print from GHC.Core. +applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type +-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. +-- The first argument is just for debugging, and gives some context +applyTypeToArgs e op_ty args + = go op_ty args + where + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args + go op_ty (_ : args) | Just (_, _, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args + go _ args = pprPanic "applyTypeToArgs" (panic_msg args) + + -- go_ty_args: accumulate type arguments so we can + -- instantiate all at once with piResultTys + go_ty_args op_ty rev_tys (Type ty : args) + = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys (Coercion co : args) + = go_ty_args op_ty (mkCoercionTy co : rev_tys) args + go_ty_args op_ty rev_tys args + = go (piResultTys op_ty (reverse rev_tys)) args + + panic_msg as = vcat [ text "Expression:" <+> pprCoreExpr e + , text "Type:" <+> ppr op_ty + , text "Args:" <+> ppr args + , text "Args':" <+> ppr as ] + + +{- +************************************************************************ +* * +\subsection{Attaching notes} +* * +************************************************************************ +-} + +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions +mkCast :: CoreExpr -> CoercionR -> CoreExpr +mkCast e co + | ASSERT2( coercionRole co == Representational + , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") + <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) + isReflCo co + = e + +mkCast (Coercion e_co) co + | isCoVarType (coercionRKind co) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce + = Coercion (mkCoCast e_co co) + +mkCast (Cast expr co2) co + = WARN(let { from_ty = coercionLKind co; + to_ty2 = coercionRKind co2 } in + not (from_ty `eqType` to_ty2), + vcat ([ text "expr:" <+> ppr expr + , text "co2:" <+> ppr co2 + , text "co:" <+> ppr co ]) ) + mkCast expr (mkTransCo co2 co) + +mkCast (Tick t expr) co + = Tick t (mkCast expr co) + +mkCast expr co + = let from_ty = coercionLKind co in + WARN( not (from_ty `eqType` exprType expr), + text "Trying to coerce" <+> text "(" <> ppr expr + $$ text "::" <+> ppr (exprType expr) <> text ")" + $$ ppr co $$ ppr (coercionType co) + $$ callStackDoc ) + (Cast expr co) + +-- | Wraps the given expression in the source annotation, dropping the +-- annotation if possible. +mkTick :: Tickish Id -> CoreExpr -> CoreExpr +mkTick t orig_expr = mkTick' id id orig_expr + where + -- Some ticks (cost-centres) can be split in two, with the + -- non-counting part having laxer placement properties. + canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + + mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) + -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) + -> CoreExpr -- ^ current expression + -> CoreExpr + mkTick' top rest expr = case expr of + + -- Cost centre ticks should never be reordered relative to each + -- other. Therefore we can stop whenever two collide. + Tick t2 e + | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + + -- Otherwise we assume that ticks of different placements float + -- through each other. + | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + + -- For annotations this is where we make sure to not introduce + -- redundant ticks. + | tickishContains t t2 -> mkTick' top rest e + | tickishContains t2 t -> orig_expr + | otherwise -> mkTick' top (rest . Tick t2) e + + -- Ticks don't care about types, so we just float all ticks + -- through them. Note that it's not enough to check for these + -- cases top-level. While mkTick will never produce Core with type + -- expressions below ticks, such constructs can be the result of + -- unfoldings. We therefore make an effort to put everything into + -- the right place no matter what we start with. + Cast e co -> mkTick' (top . flip Cast co) rest e + Coercion co -> Coercion co + + Lam x e + -- Always float through type lambdas. Even for non-type lambdas, + -- floating is allowed for all but the most strict placement rule. + | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime + -> mkTick' (top . Lam x) rest e + + -- If it is both counting and scoped, we split the tick into its + -- two components, often allowing us to keep the counting tick on + -- the outside of the lambda and push the scoped tick inside. + -- The point of this is that the counting tick can probably be + -- floated, and the lambda may then be in a position to be + -- beta-reduced. + | canSplit + -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + + App f arg + -- Always float through type applications. + | not (isRuntimeArg arg) + -> mkTick' (top . flip App arg) rest f + + -- We can also float through constructor applications, placement + -- permitting. Again we can split. + | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -> if tickishPlace t == PlaceCostCentre + then top $ rest $ tickHNFArgs t expr + else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + + Var x + | notFunction && tickishPlace t == PlaceCostCentre + -> orig_expr + | notFunction && canSplit + -> top $ Tick (mkNoScope t) $ rest expr + where + -- SCCs can be eliminated on variables provided the variable + -- is not a function. In these cases the SCC makes no difference: + -- the cost of evaluating the variable will be attributed to its + -- definition site. When the variable refers to a function, however, + -- an SCC annotation on the variable affects the cost-centre stack + -- when the function is called, so we must retain those. + notFunction = not (isFunTy (idType x)) + + Lit{} + | tickishPlace t == PlaceCostCentre + -> orig_expr + + -- Catch-all: Annotate where we stand + _any -> top $ Tick t $ rest expr + +mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr +mkTicks ticks expr = foldr mkTick expr ticks + +isSaturatedConApp :: CoreExpr -> Bool +isSaturatedConApp e = go e [] + where go (App f a) as = go f (a:as) + go (Var fun) args + = isConLikeId fun && idArity fun == valArgCount args + go (Cast f _) as = go f as + go _ _ = False + +mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr +mkTickNoHNF t e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + +-- push a tick into the arguments of a HNF (call or constructor app) +tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr +tickHNFArgs t e = push t e + where + push t (App f (Type u)) = App (push t f) (Type u) + push t (App f arg) = App (push t f) (mkTick t arg) + push _t e = e + +-- | Strip ticks satisfying a predicate from top of an expression +stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) +stripTicksTop p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the remaining expression +stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksTopE p = go + where go (Tick t e) | p t = go e + go other = other + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the ticks +stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksTopT p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts _ = ts + +-- | Completely strip ticks satisfying a predicate from an +-- expression. Note this is O(n) in the size of the expression! +stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksE p expr = go expr + where go (App e a) = App (go e) (go a) + go (Lam b e) = Lam b (go e) + go (Let b e) = Let (go_bs b) (go e) + go (Case e b t as) = Case (go e) b t (map go_a as) + go (Cast e c) = Cast (go e) c + go (Tick t e) + | p t = go e + | otherwise = Tick t (go e) + go other = other + go_bs (NonRec b e) = NonRec b (go e) + go_bs (Rec bs) = Rec (map go_b bs) + go_b (b, e) = (b, go e) + go_a (c,bs,e) = (c,bs, go e) + +stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksT p expr = fromOL $ go expr + where go (App e a) = go e `appOL` go a + go (Lam _ e) = go e + go (Let b e) = go_bs b `appOL` go e + go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) + go (Cast e _) = go e + go (Tick t e) + | p t = t `consOL` go e + | otherwise = go e + go _ = nilOL + go_bs (NonRec _ e) = go e + go_bs (Rec bs) = concatOL (map go_b bs) + go_b (_, e) = go e + go_a (_, _, e) = go e + +{- +************************************************************************ +* * +\subsection{Other expression construction} +* * +************************************************************************ +-} + +bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr +-- ^ @bindNonRec x r b@ produces either: +-- +-- > let x = r in b +-- +-- or: +-- +-- > case r of x { _DEFAULT_ -> b } +-- +-- depending on whether we have to use a @case@ or @let@ +-- binding for the expression (see 'needsCaseBinding'). +-- It's used by the desugarer to avoid building bindings +-- that give Core Lint a heart attack, although actually +-- the simplifier deals with them perfectly well. See +-- also 'GHC.Core.Make.mkCoreLet' +bindNonRec bndr rhs body + | isTyVar bndr = let_bind + | isCoVar bndr = if isCoArg rhs then let_bind + {- See Note [Binding coercions] -} else case_bind + | isJoinId bndr = let_bind + | needsCaseBinding (idType bndr) rhs = case_bind + | otherwise = let_bind + where + case_bind = mkDefaultCase rhs bndr body + let_bind = Let (NonRec bndr rhs) body + +-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression +-- as per the invariants of 'CoreExpr': see "GHC.Core#let_app_invariant" +needsCaseBinding :: Type -> CoreExpr -> Bool +needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) + +mkAltExpr :: AltCon -- ^ Case alternative constructor + -> [CoreBndr] -- ^ Things bound by the pattern match + -> [Type] -- ^ The type arguments to the case alternative + -> CoreExpr +-- ^ This guy constructs the value that the scrutinee must have +-- given that you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" + +mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr +-- Make (case x of y { DEFAULT -> e } +mkDefaultCase scrut case_bndr body + = Case scrut case_bndr (exprType body) [(DEFAULT, [], body)] + +mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr +-- Use this function if possible, when building a case, +-- because it ensures that the type on the Case itself +-- doesn't mention variables bound by the case +-- See Note [Care with the type of a case expression] +mkSingleAltCase scrut case_bndr con bndrs body + = Case scrut case_bndr case_ty [(con,bndrs,body)] + where + body_ty = exprType body + + case_ty -- See Note [Care with the type of a case expression] + | Just body_ty' <- occCheckExpand bndrs body_ty + = body_ty' + + | otherwise + = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) + +{- Note [Care with the type of a case expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a phantom type synonym + type S a = Int +and we want to form the case expression + case x of K (a::*) -> (e :: S a) + +We must not make the type field of the case-expression (S a) because +'a' isn't in scope. Hence the call to occCheckExpand. This caused +issue #17056. + +NB: this situation can only arise with type synonyms, which can +falsely "mention" type variables that aren't "really there", and which +can be eliminated by expanding the synonym. + +Note [Binding coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider binding a CoVar, c = e. Then, we must satisfy +Note [Core type and coercion invariant] in GHC.Core, +which allows only (Coercion co) on the RHS. + +************************************************************************ +* * + Operations oer case alternatives +* * +************************************************************************ + +The default alternative must be first, if it exists at all. +This makes it easy to find, though it makes matching marginally harder. +-} + +-- | Extract the default case alternative +findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) +findDefault alts = (alts, Nothing) + +addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)] +addDefault alts Nothing = alts +addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts + +isDefaultAlt :: (AltCon, a, b) -> Bool +isDefaultAlt (DEFAULT, _, _) = True +isDefaultAlt _ = False + +-- | Find the case alternative corresponding to a particular +-- constructor: panics if no such constructor exists +findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) + -- A "Nothing" result *is* legitimate + -- See Note [Unreachable code] +findAlt con alts + = case alts of + (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) + _ -> go alts Nothing + where + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> Just alt + GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt + +{- Note [Unreachable code] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible (although unusual) for GHC to find a case expression +that cannot match. For example: + + data Col = Red | Green | Blue + x = Red + f v = case x of + Red -> ... + _ -> ...(case x of { Green -> e1; Blue -> e2 })... + +Suppose that for some silly reason, x isn't substituted in the case +expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff +gets in the way; cf #3118.) Then the full-laziness pass might produce +this + + x = Red + lvl = case x of { Green -> e1; Blue -> e2 }) + f v = case x of + Red -> ... + _ -> ...lvl... + +Now if x gets inlined, we won't be able to find a matching alternative +for 'Red'. That's because 'lvl' is unreachable. So rather than crashing +we generate (error "Inaccessible alternative"). + +Similar things can happen (augmented by GADTs) when the Simplifier +filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. +-} + +--------------------------------- +mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] +-- ^ Merge alternatives preserving order; alternatives in +-- the first argument shadow ones in the second +mergeAlts [] as2 = as2 +mergeAlts as1 [] = as1 +mergeAlts (a1:as1) (a2:as2) + = case a1 `cmpAlt` a2 of + LT -> a1 : mergeAlts as1 (a2:as2) + EQ -> a1 : mergeAlts as1 as2 -- Discard a2 + GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- ^ Given: +-- +-- > case (C a b x y) of +-- > C b x y -> ... +-- +-- We want to drop the leading type argument of the scrutinee +-- leaving the arguments to match against the pattern + +trimConArgs DEFAULT args = ASSERT( null args ) [] +trimConArgs (LitAlt _) args = ASSERT( null args ) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args + +filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) + -> [Type] -- ^ And its type arguments + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [(AltCon, [Var], a)] -- ^ Alternatives + -> ([AltCon], [(AltCon, [Var], a)]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts _tycon inst_tys imposs_cons alts + = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | (con,_,_) <- alts_wo_default] + + trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default + + imposs_cons_set = Set.fromList imposs_cons + imposs_deflt_cons = + imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + impossible_alt :: [Type] -> (AltCon, a, b) -> Bool + impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False + +-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. +-- See Note [Refine DEFAULT case alternatives] +refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders + -> Mult -- ^ Multiplicity annotation of the case expression + -> TyCon -- ^ Type constructor of scrutinee's type + -> [Type] -- ^ Type arguments of scrutinee's type + -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) + -> [CoreAlt] + -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' +refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts + | (DEFAULT,_,rhs) : rest_alts <- all_alts + , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: + -- case x of { DEFAULT -> e } + -- and we don't want to fill in a default for them! + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] + -- We now know it's a data type, so we can use + -- UniqSet rather than Set (more efficient) + impossible con = con `elementOfUniqSet` imposs_data_cons + || dataConCannotMatch tys con + = case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, rest_alts) + + -- It matches exactly one constructor, so fill it in: + [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) + -- We need the mergeAlts to keep the alternatives in the right order + where + (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys + + -- It matches more than one, so do nothing + _ -> (False, all_alts) + + | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + = (False, all_alts) + + | otherwise -- The common case + = (False, all_alts) + +{- Note [Refine DEFAULT case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +refineDefaultAlt replaces the DEFAULT alt with a constructor if there +is one possible value it could be. + +The simplest example being + foo :: () -> () + foo x = case x of !_ -> () +which rewrites to + foo :: () -> () + foo x = case x of () -> () + +There are two reasons in general why replacing a DEFAULT alternative +with a specific constructor is desirable. + +1. We can simplify inner expressions. For example + + data Foo = Foo1 () + + test :: Foo -> () + test x = case x of + DEFAULT -> mid (case x of + Foo1 x1 -> x1) + + refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then + x becomes bound to `Foo ip1` so is inlined into the other case + which causes the KnownBranch optimisation to kick in. If we don't + refine DEFAULT to `Foo ip1`, we are left with both case expressions. + +2. combineIdenticalAlts does a better job. For exapple (Simon Jacobi) + data D = C0 | C1 | C2 + + case e of + DEFAULT -> e0 + C0 -> e1 + C1 -> e1 + + When we apply combineIdenticalAlts to this expression, it can't + combine the alts for C0 and C1, as we already have a default case. + But if we apply refineDefaultAlt first, we get + case e of + C0 -> e1 + C1 -> e1 + C2 -> e0 + and combineIdenticalAlts can turn that into + case e of + DEFAULT -> e1 + C2 -> e0 + + It isn't obvious that refineDefaultAlt does this but if you look + at its one call site in GHC.Core.Opt.Simplify.Utils then the + `imposs_deflt_cons` argument is populated with constructors which + are matched elsewhere. + +Note [Combine identical alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If several alternatives are identical, merge them into a single +DEFAULT alternative. I've occasionally seen this making a big +difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x + +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +To avoid an expensive test, we just merge branches equal to the *first* +alternative; this picks up the common cases + a) all branches equal + b) some branches equal to the DEFAULT (which occurs first) + +The case where Combine Identical Alternatives transformation showed up +was like this (base/Foreign/C/Err/Error.hs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + +Note [Combine identical alternatives: wrinkles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +* It's important that we try to combine alternatives *before* + simplifying them, rather than after. Reason: because + Simplify.simplAlt may zap the occurrence info on the binders in the + alternatives, which in turn defeats combineIdenticalAlts use of + isDeadBinder (see #7360). + + You can see this in the call to combineIdenticalAlts in + GHC.Core.Opt.Simplify.Utils.prepareAlts. Here the alternatives have type InAlt + (the "In" meaning input) rather than OutAlt. + +* combineIdenticalAlts does not work well for nullary constructors + case x of y + [] -> f [] + (_:_) -> f y + Here we won't see that [] and y are the same. Sigh! This problem + is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version + of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have + here. + See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE). + +Note [Care with impossible-constructors when combining alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#10538) + data T = A | B | C | D + + case x::T of (Imposs-default-cons {A,B}) + DEFAULT -> e1 + A -> e2 + B -> e1 + +When calling combineIdentialAlts, we'll have computed that the +"impossible constructors" for the DEFAULT alt is {A,B}, since if x is +A or B we'll take the other alternatives. But suppose we combine B +into the DEFAULT, to get + + case x::T of (Imposs-default-cons {A}) + DEFAULT -> e1 + A -> e2 + +Then we must be careful to trim the impossible constructors to just {A}, +else we risk compiling 'e1' wrong! + +Not only that, but we take care when there is no DEFAULT beforehand, +because we are introducing one. Consider + + case x of (Imposs-default-cons {A,B,C}) + A -> e1 + B -> e2 + C -> e1 + +Then when combining the A and C alternatives we get + + case x of (Imposs-default-cons {B}) + DEFAULT -> e1 + B -> e2 + +Note that we have a new DEFAULT branch that we didn't have before. So +we need delete from the "impossible-default-constructors" all the +known-con alternatives that we have eliminated. (In #11172 we +missed the first one.) + +-} + +combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT + -> [CoreAlt] + -> (Bool, -- True <=> something happened + [AltCon], -- New constructors that cannot match DEFAULT + [CoreAlt]) -- New alternatives +-- See Note [Combine identical alternatives] +-- True <=> we did some combining, result is a single DEFAULT alternative +combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) + | all isDeadBinder bndrs1 -- Remember the default + , not (null elim_rest) -- alternative comes first + = (True, imposs_deflt_cons', deflt_alt : filtered_rest) + where + (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts + deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) + + -- See Note [Care with impossible-constructors when combining alternatives] + imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons + elim_cons = elim_con1 ++ map fstOf3 elim_rest + elim_con1 = case con1 of -- Don't forget con1! + DEFAULT -> [] -- See Note [ + _ -> [con1] + + cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 + identical_to_alt1 (_con,bndrs,rhs) + = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 + tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest + +combineIdenticalAlts imposs_cons alts + = (False, imposs_cons, alts) + +-- Scales the multiplicity of the binders of a list of case alternatives. That +-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled. +scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] +scaleAltsBy w alts = map scaleAlt alts + where + scaleAlt :: CoreAlt -> CoreAlt + scaleAlt (con, bndrs, rhs) = (con, map scaleBndr bndrs, rhs) + + scaleBndr :: CoreBndr -> CoreBndr + scaleBndr b = scaleVarBy w b + + +{- ********************************************************************* +* * + exprIsTrivial +* * +************************************************************************ + +Note [exprIsTrivial] +~~~~~~~~~~~~~~~~~~~~ +@exprIsTrivial@ is true of expressions we are unconditionally happy to + duplicate; simple variables and constants, and type + applications. Note that primop Ids aren't considered + trivial unless + +Note [Variables are trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like \$wJust, is +really short for (\x -> \$wJust x), because \$wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + +Note [Tick trivial] +~~~~~~~~~~~~~~~~~~~ +Ticks are only trivial if they are pure annotations. If we treat +"tick x" as trivial, it will be inlined inside lambdas and the +entry count will be skewed, for example. Furthermore "scc x" will +turn into just "x" in mkTick. + +Note [Empty case is trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression (case (x::Int) Bool of {}) is just a type-changing +case used when we are sure that 'x' will not return. See +Note [Empty case alternatives] in GHC.Core. + +If the scrutinee is trivial, then so is the whole expression; and the +CoreToSTG pass in fact drops the case expression leaving only the +scrutinee. + +Having more trivial expressions is good. Moreover, if we don't treat +it as trivial we may land up with let-bindings like + let v = case x of {} in ... +and after CoreToSTG that gives + let v = x in ... +and that confuses the code generator (#11155). So best to kill +it off at source. +-} + +exprIsTrivial :: CoreExpr -> Bool +-- If you modify this function, you may also +-- need to modify getIdFromTrivialExpr +exprIsTrivial (Var _) = True -- See Note [Variables are trivial] +exprIsTrivial (Type _) = True +exprIsTrivial (Coercion _) = True +exprIsTrivial (Lit lit) = litIsTrivial lit +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e +exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e +exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e + -- See Note [Tick trivial] +exprIsTrivial (Cast e _) = exprIsTrivial e +exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] +exprIsTrivial _ = False + +{- +Note [getIdFromTrivialExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When substituting in a breakpoint we need to strip away the type cruft +from a trivial expression and get back to the Id. The invariant is +that the expression we're substituting was originally trivial +according to exprIsTrivial, AND the expression is not a literal. +See Note [substTickish] for how breakpoint substitution preserves +this extra invariant. + +We also need this functionality in CorePrep to extract out Id of a +function which we are saturating. However, in this case we don't know +if the variable actually refers to a literal; thus we use +'getIdFromTrivialExpr_maybe' to handle this case. See test +T12076lit for an example where this matters. +-} + +getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id +getIdFromTrivialExpr e + = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) + (getIdFromTrivialExpr_maybe e) + +getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id +-- See Note [getIdFromTrivialExpr] +-- Th equations for this should line up with those for exprIsTrivial +getIdFromTrivialExpr_maybe e + = go e + where + go (App f t) | not (isRuntimeArg t) = go f + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (Lam b e) | not (isRuntimeVar b) = go e + go (Case e _ _ []) = go e + go (Var v) = Just v + go _ = Nothing + +{- +exprIsDeadEnd is a very cheap and cheerful function; it may return +False for bottoming expressions, but it never costs much to ask. See +also GHC.Core.Opt.Arity.exprBotStrictness_maybe, but that's a bit more +expensive. +-} + +exprIsDeadEnd :: CoreExpr -> Bool +-- See Note [Bottoming expressions] +exprIsDeadEnd e + | isEmptyTy (exprType e) + = True + | otherwise + = go 0 e + where + go n (Var v) = isDeadEndId v && n >= idArity v + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go n (Lam v e) | isTyVar v = go n e + go _ (Case _ _ _ alts) = null alts + -- See Note [Empty case alternatives] in GHC.Core + go _ _ = False + +{- Note [Bottoming expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bottoming expression is guaranteed to diverge, or raise an +exception. We can test for it in two different ways, and exprIsDeadEnd +checks for both of these situations: + +* Visibly-bottom computations. For example + (error Int "Hello") + is visibly bottom. The strictness analyser also finds out if + a function diverges or raises an exception, and puts that info + in its strictness signature. + +* Empty types. If a type is empty, its only inhabitant is bottom. + For example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} + Since T has no data constructors, the case alternatives are of course + empty. However note that 'x' is not bound to a visibly-bottom value; + it's the *type* that tells us it's going to diverge. + +A GADT may also be empty even though it has constructors: + data T a where + T1 :: a -> T Bool + T2 :: T Int + ...(case (x::T Char) of {})... +Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), +which is likewise uninhabited. + + +************************************************************************ +* * + exprIsDupable +* * +************************************************************************ + +Note [exprIsDupable] +~~~~~~~~~~~~~~~~~~~~ +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in code size. This will only happen in different case + branches, so there's no issue about duplicating work. + + That is, exprIsDupable returns True of (f x) even if + f is very very expensive to call. + + Its only purpose is to avoid fruitless let-binding + and then inlining of case join points +-} + +exprIsDupable :: Platform -> CoreExpr -> Bool +exprIsDupable platform e + = isJust (go dupAppSize e) + where + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (App f a) | Just n' <- go n a = go n' f + go n (Lit lit) | litIsDupable platform lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) + +dupAppSize :: Int +dupAppSize = 8 -- Size of term we are prepared to duplicate + -- This is *just* big enough to make test MethSharing + -- inline enough join points. Really it should be + -- smaller, and could be if we fixed #4960. + +{- +************************************************************************ +* * + exprIsCheap, exprIsExpandable +* * +************************************************************************ + +Note [exprIsWorkFree] +~~~~~~~~~~~~~~~~~~~~~ +exprIsWorkFree is used when deciding whether to inline something; we +don't inline it if doing so might duplicate work, by peeling off a +complete copy of the expression. Here we do not want even to +duplicate a primop (#5623): + eg let x = a #+ b in x +# x + we do not want to inline/duplicate x + +Previously we were a bit more liberal, which led to the primop-duplicating +problem. However, being more conservative did lead to a big regression in +one nofib benchmark, wheel-sieve1. The situation looks like this: + + let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool + noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> + case GHC.Prim.<=# x_aRs 2 of _ { + GHC.Types.False -> notDivBy ps_adM qs_adN; + GHC.Types.True -> lvl_r2Eb }} + go = \x. ...(noFactor (I# y))....(go x')... + +The function 'noFactor' is heap-allocated and then called. Turns out +that 'notDivBy' is strict in its THIRD arg, but that is invisible to +the caller of noFactor, which therefore cannot do w/w and +heap-allocates noFactor's argument. At the moment (May 12) we are just +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which +in turn was making inner loops of array calculations runs slow (#5623) + +Note [Case expressions are work-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are case-expressions work-free? Consider + let v = case x of (p,q) -> p + go = \y -> ...case v of ... +Should we inline 'v' at its use site inside the loop? At the moment +we do. I experimented with saying that case are *not* work-free, but +that increased allocation slightly. It's a fairly small effect, and at +the moment we go for the slightly more aggressive version which treats +(case x of ....) as work-free if the alternatives are. + +Moreover it improves arities of overloaded functions where +there is only dictionary selection (no construction) involved + +Note [exprIsCheap] +~~~~~~~~~~~~~~~~~~ + +See also Note [Interaction of exprIsCheap and lone variables] in GHC.Core.Unfold + +@exprIsCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +[Note that that's not the same as exprIsDupable; an expression might be +big, and hence not dupable, but still cheap.] + +By ``cheap'' we mean a computation we're willing to: + push inside a lambda, or + inline at more than one place +That might mean it gets evaluated more than once, instead of being +shared. The main examples of things which aren't WHNF but are +``cheap'' are: + + * case e of + pi -> ei + (where e, and all the ei are cheap) + + * let x = e in b + (where e and b are cheap) + + * op x1 ... xn + (where op is a cheap primitive operator) + + * error "foo" + (because we are happy to substitute it inside a lambda) + +Notice that a variable is considered 'cheap': we can push it inside a lambda, +because sharing will make sure it is only evaluated once. + +Note [exprIsCheap and exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that exprIsHNF does not imply exprIsCheap. Eg + let x = fac 20 in Just x +This responds True to exprIsHNF (you can discard a seq), but +False to exprIsCheap. + +Note [Arguments and let-bindings exprIsCheapX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What predicate should we apply to the argument of an application, or the +RHS of a let-binding? + +We used to say "exprIsTrivial arg" due to concerns about duplicating +nested constructor applications, but see #4978. So now we just recursively +use exprIsCheapX. + +We definitely want to treat let and app the same. The principle here is +that + let x = blah in f x +should behave equivalently to + f blah + +This in turn means that the 'letrec g' does not prevent eta expansion +in this (which it previously was): + f = \x. let v = case x of + True -> letrec g = \w. blah + in g + False -> \x. x + in \w. v True +-} + +-------------------- +exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] +exprIsWorkFree = exprIsCheapX isWorkFreeApp + +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheapX isCheapApp + +exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool +exprIsCheapX ok_app e + = ok e + where + ok e = go 0 e + + -- n is the number of value arguments + go n (Var v) = ok_app v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Case scrut _ _ alts) = ok scrut && + and [ go n rhs | (_,_,rhs) <- alts ] + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = go (n+1) f && ok e + | otherwise = go n f + go n (Let (NonRec _ r) e) = go n e && ok r + go n (Let (Rec prs) e) = go n e && all (ok . snd) prs + + -- Case: see Note [Case expressions are work-free] + -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] + + +{- Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) +-} + +------------------------------------- +exprIsExpandable :: CoreExpr -> Bool +-- See Note [exprIsExpandable] +exprIsExpandable e + = ok e + where + ok e = go 0 e + + -- n is the number of value arguments + go n (Var v) = isExpandableApp v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = go (n+1) f && ok e + | otherwise = go n f + go _ (Case {}) = False + go _ (Let {}) = False + + +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + +isWorkFreeApp :: CheapAppFun +isWorkFreeApp fn n_val_args + | n_val_args == 0 -- No value args + = True + | n_val_args < idArity fn -- Partial application + = True + | otherwise + = case idDetails fn of + DataConWorkId {} -> True + _ -> False + +isCheapApp :: CheapAppFun +isCheapApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] + | otherwise + = case idDetails fn of + DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId op -> primOpIsCheap op + _ -> False + -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + +isExpandableApp :: CheapAppFun +isExpandableApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | otherwise + = case idDetails fn of + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId {} -> False + _ | isDeadEndId fn -> False + -- See Note [isExpandableApp: bottoming functions] + | isConLikeId fn -> True + | all_args_are_preds -> True + | otherwise -> False + + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + all_args_are_preds = all_pred_args n_val_args (idType fn) + + all_pred_args n_val_args ty + | n_val_args == 0 + = True + + | Just (bndr, ty) <- splitPiTy_maybe ty + = case bndr of + Named {} -> all_pred_args n_val_args ty + Anon InvisArg _ -> all_pred_args (n_val_args-1) ty + Anon VisArg _ -> False + + | otherwise + = False + +{- Note [isCheapApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm not sure why we have a special case for bottoming +functions in isCheapApp. Maybe we don't need it. + +Note [isExpandableApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that isExpandableApp does not respond True to bottoming +functions. Recall undefined :: HasCallStack => a +Suppose isExpandableApp responded True to (undefined d), and we had: + + x = undefined + +Then Simplify.prepareRhs would ANF the RHS: + + d = + x = undefined d + +This is already bad: we gain nothing from having x bound to (undefined +var), unlike the case for data constructors. Worse, we get the +simplifier loop described in OccurAnal Note [Cascading inlines]. +Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will +certainly_inline; so we end up inlining d right back into x; but in +the end x doesn't inline because it is bottom (preInlineUnconditionally); +so the process repeats.. We could elaborate the certainly_inline logic +some more, but it's better just to treat bottoming bindings as +non-expandable, because ANFing them is a bad idea in the first place. + +Note [Record selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm experimenting with making record selection +look cheap, so we will substitute it inside a +lambda. Particularly for dictionary field selection. + +BUT: Take care with (sel d x)! The (sel d) might be cheap, but +there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +He'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. + + +************************************************************************ +* * + exprOkForSpeculation +* * +************************************************************************ +-} + +----------------------------- +-- | 'exprOkForSpeculation' returns True of an expression that is: +-- +-- * Safe to evaluate even if normal order eval might not +-- evaluate the expression at all, or +-- +-- * Safe /not/ to evaluate even if normal order would do so +-- +-- It is usually called on arguments of unlifted type, but not always +-- In particular, Simplify.rebuildCase calls it on lifted types +-- when a 'case' is a plain 'seq'. See the example in +-- Note [exprOkForSpeculation: case expressions] below +-- +-- Precisely, it returns @True@ iff: +-- a) The expression guarantees to terminate, +-- b) soon, +-- c) without causing a write side effect (e.g. writing a mutable variable) +-- d) without throwing a Haskell exception +-- e) without risking an unchecked runtime exception (array out of bounds, +-- divide by zero) +-- +-- For @exprOkForSideEffects@ the list is the same, but omitting (e). +-- +-- Note that +-- exprIsHNF implies exprOkForSpeculation +-- exprOkForSpeculation implies exprOkForSideEffects +-- +-- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps" +-- and Note [Transformations affected by can_fail and has_side_effects] +-- +-- As an example of the considerations in this test, consider: +-- +-- > let x = case y# +# 1# of { r# -> I# r# } +-- > in E +-- +-- being translated to: +-- +-- > case y# +# 1# of { r# -> +-- > let x = I# r# +-- > in E +-- > } +-- +-- We can only do this if the @y + 1@ is ok for speculation: it has no +-- side effects, and can't diverge or raise an exception. + +exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool +exprOkForSpeculation = expr_ok primOpOkForSpeculation +exprOkForSideEffects = expr_ok primOpOkForSideEffects + +expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool +expr_ok _ (Lit _) = True +expr_ok _ (Type _) = True +expr_ok _ (Coercion _) = True + +expr_ok primop_ok (Var v) = app_ok primop_ok v [] +expr_ok primop_ok (Cast e _) = expr_ok primop_ok e +expr_ok primop_ok (Lam b e) + | isTyVar b = expr_ok primop_ok e + | otherwise = True + +-- Tick annotations that *tick* cannot be speculated, because these +-- are meant to identify whether or not (and how often) the particular +-- source expression was evaluated at runtime. +expr_ok primop_ok (Tick tickish e) + | tickishCounts tickish = False + | otherwise = expr_ok primop_ok e + +expr_ok _ (Let {}) = False + -- Lets can be stacked deeply, so just give up. + -- In any case, the argument of exprOkForSpeculation is + -- usually in a strict context, so any lets will have been + -- floated away. + +expr_ok primop_ok (Case scrut bndr _ alts) + = -- See Note [exprOkForSpeculation: case expressions] + expr_ok primop_ok scrut + && isUnliftedType (idType bndr) + && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && altsAreExhaustive alts + +expr_ok primop_ok other_expr + | (expr, args) <- collectArgs other_expr + = case stripTicksTopE (not . tickishCounts) expr of + Var f -> app_ok primop_ok f args + -- 'LitRubbish' is the only literal that can occur in the head of an + -- application and will not be matched by the above case (Var /= Lit). + Lit lit -> ASSERT( lit == rubbishLit ) True + _ -> False + +----------------------------- +app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool +app_ok primop_ok fun args + = case idDetails fun of + DFunId new_type -> not new_type + -- DFuns terminate, unless the dict is implemented + -- with a newtype in which case they may not + + DataConWorkId {} -> True + -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + PrimOpId op + | isDivOp op + , [arg1, Lit lit] <- args + -> not (isZeroLit lit) && expr_ok primop_ok arg1 + -- Special case for dividing operations that fail + -- In general they are NOT ok-for-speculation + -- (which primop_ok will catch), but they ARE OK + -- if the divisor is definitely non-zero. + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner loop + + | SeqOp <- op -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp] + -> False -- for the special cases for SeqOp and DataToTagOp + | DataToTagOp <- op + -> False + | KeepAliveOp <- op + -> False + + | otherwise + -> primop_ok op -- Check the primop itself + && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments + + _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF + || idArity fun > n_val_args -- Partial apps + -- NB: even in the nullary case, do /not/ check + -- for evaluated-ness of the fun; + -- see Note [exprOkForSpeculation and evaluated variables] + where + n_val_args = valArgCount args + where + (arg_tys, _) = splitPiTys (idType fun) + + primop_arg_ok :: TyBinder -> CoreExpr -> Bool + primop_arg_ok (Named _) _ = True -- A type argument + primop_arg_ok (Anon _ ty) arg -- A term argument + | isUnliftedType (scaledThing ty) = expr_ok primop_ok arg + | otherwise = True -- See Note [Primops with lifted arguments] + +----------------------------- +altsAreExhaustive :: [Alt b] -> Bool +-- True <=> the case alternatives are definitely exhaustive +-- False <=> they may or may not be +altsAreExhaustive [] + = False -- Should not happen +altsAreExhaustive ((con1,_,_) : alts) + = case con1 of + DEFAULT -> True + LitAlt {} -> False + DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) + -- It is possible to have an exhaustive case that does not + -- enumerate all constructors, notably in a GADT match, but + -- we behave conservatively here -- I don't think it's important + -- enough to deserve special treatment + +-- | True of dyadic operators that can fail only if the second arg is zero! +isDivOp :: PrimOp -> Bool +-- This function probably belongs in GHC.Builtin.PrimOps, or even in +-- an automagically generated file.. but it's such a +-- special case I thought I'd leave it here for now. +isDivOp IntQuotOp = True +isDivOp IntRemOp = True +isDivOp WordQuotOp = True +isDivOp WordRemOp = True +isDivOp FloatDivOp = True +isDivOp DoubleDivOp = True +isDivOp _ = False + +{- Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprOkForSpeculation accepts very special case expressions. +Reason: (a ==# b) is ok-for-speculation, but the litEq rules +in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to + case a of { DEFAULT -> 0#; 3# -> 1# } +for excellent reasons described in + GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case]. +So, annoyingly, we want that case expression to be +ok-for-speculation too. Bother. + +But we restrict it sharply: + +* We restrict it to unlifted scrutinees. Consider this: + case x of y { + DEFAULT -> ... (let v::Int# = case y of { True -> e1 + ; False -> e2 } + in ...) ... + + Does the RHS of v satisfy the let/app invariant? Previously we said + yes, on the grounds that y is evaluated. But the binder-swap done + by GHC.Core.Opt.SetLevels would transform the inner alternative to + DEFAULT -> ... (let v::Int# = case x of { ... } + in ...) .... + which does /not/ satisfy the let/app invariant, because x is + not evaluated. See Note [Binder-swap during float-out] + in GHC.Core.Opt.SetLevels. To avoid this awkwardness it seems simpler + to stick to unlifted scrutinees where the issue does not + arise. + +* We restrict it to exhaustive alternatives. A non-exhaustive + case manifestly isn't ok-for-speculation. for example, + this is a valid program (albeit a slightly dodgy one) + let v = case x of { B -> ...; C -> ... } + in case x of + A -> ... + _ -> ...v...v.... + Should v be considered ok-for-speculation? Its scrutinee may be + evaluated, but the alternatives are incomplete so we should not + evaluate it strictly. + + Now, all this is for lifted types, but it'd be the same for any + finite unlifted type. We don't have many of them, but we might + add unlifted algebraic types in due course. + + +----- Historical note: #15696: -------- + Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide + floating of single-alternative cases; it now uses exprIsHNF + Note [Floating single-alternative cases]. + + But in those days, consider + case e of x { DEAFULT -> + ...(case x of y + A -> ... + _ -> ...(case (case x of { B -> p; C -> p }) of + I# r -> blah)... + If GHC.Core.Opt.SetLevels considers the inner nested case as + ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels). + So we'd float to: + case e of x { DEAFULT -> + case (case x of { B -> p; C -> p }) of I# r -> + ...(case x of y + A -> ... + _ -> ...blah...)... + which is utterly bogus (seg fault); see #5453. + +----- Historical note: #3717: -------- + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +In earlier GHCs, we got this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 } + +Before join-points etc we could only get rid of two cases (which are +redundant) by recognising that the (case <# ds 5 of { ... }) is +ok-for-speculation, even though it has /lifted/ type. But now join +points do the job nicely. +------- End of historical note ------------ + + +Note [Primops with lifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this ok-for-speculation (see #13027)? + reallyUnsafePtrEq# a b +Well, yes. The primop accepts lifted arguments and does not +evaluate them. Indeed, in general primops are, well, primitive +and do not perform evaluation. + +Bottom line: + * In exprOkForSpeculation we simply ignore all lifted arguments. + * In the rare case of primops that /do/ evaluate their arguments, + (namely DataToTagOp and SeqOp) return False; see + Note [exprOkForSpeculation and evaluated variables] + +Note [exprOkForSpeculation and SeqOp/DataToTagOp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most primops with lifted arguments don't evaluate them +(see Note [Primops with lifted arguments]), so we can ignore +that argument entirely when doing exprOkForSpeculation. + +But DataToTagOp and SeqOp are exceptions to that rule. +For reasons described in Note [exprOkForSpeculation and +evaluated variables], we simply return False for them. + +Not doing this made #5129 go bad. +Lots of discussion in #15696. + +Note [exprOkForSpeculation and evaluated variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that + seq# :: forall a s. a -> State# s -> (# State# s, a #) + dataToTag# :: forall a. a -> Int# +must always evaluate their first argument. + +Now consider these examples: + * case x of y { DEFAULT -> ....y.... } + Should 'y' (alone) be considered ok-for-speculation? + + * case x of y { DEFAULT -> ....f (dataToTag# y)... } + Should (dataToTag# y) be considered ok-for-spec? + +You could argue 'yes', because in the case alternative we know that +'y' is evaluated. But the binder-swap transformation, which is +extremely useful for float-out, changes these expressions to + case x of y { DEFAULT -> ....x.... } + case x of y { DEFAULT -> ....f (dataToTag# x)... } + +And now the expression does not obey the let/app invariant! Yikes! +Moreover we really might float (f (dataToTag# x)) outside the case, +and then it really, really doesn't obey the let/app invariant. + +The solution is simple: exprOkForSpeculation does not try to take +advantage of the evaluated-ness of (lifted) variables. And it returns +False (always) for DataToTagOp and SeqOp. + +Note that exprIsHNF /can/ and does take advantage of evaluated-ness; +it doesn't have the trickiness of the let/app invariant to worry about. + +************************************************************************ +* * + exprIsHNF, exprIsConLike +* * +************************************************************************ +-} + +-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] +-- ~~~~~~~~~~~~~~~~ +-- | exprIsHNF returns true for expressions that are certainly /already/ +-- evaluated to /head/ normal form. This is used to decide whether it's ok +-- to change: +-- +-- > case x of _ -> e +-- +-- into: +-- +-- > e +-- +-- and to decide whether it's safe to discard a 'seq'. +-- +-- So, it does /not/ treat variables as evaluated, unless they say they are. +-- However, it /does/ treat partial applications and constructor applications +-- as values, even if their arguments are non-trivial, provided the argument +-- type is lifted. For example, both of these are values: +-- +-- > (:) (f x) (map f xs) +-- > map (...redex...) +-- +-- because 'seq' on such things completes immediately. +-- +-- For unlifted argument types, we have to be careful: +-- +-- > C (f x :: Int#) +-- +-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't +-- happen: see "GHC.Core#let_app_invariant". This invariant states that arguments of +-- unboxed type must be ok-for-speculation (or trivial). +exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding + +-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as +-- data constructors. Conlike arguments are considered interesting by the +-- inliner. +exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP +exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding + +-- | Returns true for values or value-like expressions. These are lambdas, +-- constructors / CONLIKE functions (as determined by the function argument) +-- or PAPs. +-- +exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +exprIsHNFlike is_con is_con_unf = is_hnf_like + where + is_hnf_like (Var v) -- NB: There are no value args at this point + = id_app_is_value v 0 -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings + || is_con_unf (idUnfolding v) + -- Check the thing's unfolding; it might be bound to a value + -- or to a guaranteed-evaluated variable (isEvaldUnfolding) + -- Contrast with Note [exprOkForSpeculation and evaluated variables] + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop + + is_hnf_like (Lit _) = True + is_hnf_like (Type _) = True -- Types are honorary Values; + -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions + is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Tick tickish e) = not (tickishCounts tickish) + && is_hnf_like e + -- See Note [exprIsHNF Tick] + is_hnf_like (Cast e _) = is_hnf_like e + is_hnf_like (App e a) + | isValArg a = app_is_value e 1 + | otherwise = is_hnf_like e + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like _ = False + + -- 'n' is the number of value args to which the expression is applied + -- And n>0: there is at least one value argument + app_is_value :: CoreExpr -> Int -> Bool + app_is_value (Var f) nva = id_app_is_value f nva + app_is_value (Tick _ f) nva = app_is_value f nva + app_is_value (Cast f _) nva = app_is_value f nva + app_is_value (App f a) nva + | isValArg a = app_is_value f (nva + 1) + | otherwise = app_is_value f nva + app_is_value _ _ = False + + id_app_is_value id n_val_args + = is_con id + || idArity id > n_val_args + || id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in GHC.Core.Make + -- absentError behaves like an honorary data constructor + + +{- +Note [exprIsHNF Tick] + +We can discard source annotations on HNFs as long as they aren't +tick-like: + + scc c (\x . e) => \x . e + scc c (C x1..xn) => C x1..xn + +So we regard these as HNFs. Tick annotations that tick are not +regarded as HNF if the expression they surround is HNF, because the +tick is there to tell us that the expression was evaluated, so we +don't want to discard a seq on it. +-} + +-- | Can we bind this 'CoreExpr' at the top level? +exprIsTopLevelBindable :: CoreExpr -> Type -> Bool +-- See Note [Core top-level string literals] +-- Precondition: exprType expr = ty +-- Top-level literal strings can't even be wrapped in ticks +-- see Note [Core top-level string literals] in "GHC.Core" +exprIsTopLevelBindable expr ty + = not (mightBeUnliftedType ty) + -- Note that 'expr' may be levity polymorphic here consequently we must use + -- 'mightBeUnliftedType' rather than 'isUnliftedType' as the latter would panic. + || exprIsTickedString expr + +-- | Check if the expression is zero or more Ticks wrapped around a literal +-- string. +exprIsTickedString :: CoreExpr -> Bool +exprIsTickedString = isJust . exprIsTickedString_maybe + +-- | Extract a literal string from an expression that is zero or more Ticks +-- wrapped around a literal string. Returns Nothing if the expression has a +-- different shape. +-- Used to "look through" Ticks in places that need to handle literal strings. +exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString +exprIsTickedString_maybe (Lit (LitString bs)) = Just bs +exprIsTickedString_maybe (Tick t e) + -- we don't tick literals with CostCentre ticks, compare to mkTick + | tickishPlace t == PlaceCostCentre = Nothing + | otherwise = exprIsTickedString_maybe e +exprIsTickedString_maybe _ = Nothing + +{- +************************************************************************ +* * + Instantiating data constructors +* * +************************************************************************ + +These InstPat functions go here to avoid circularity between DataCon and Id +-} + +dataConRepInstPat :: [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) + +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat + +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> Mult -- The multiplicity annotation of the case expression: scales the multiplicity of variables + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyCoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple +-- (ex_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- arg_ids are indended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a ~ (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat fss uniqs mult con inst_tys + = ASSERT( univ_tvs `equalLength` inst_tys ) + (ex_bndrs, arg_ids) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyCoVars con + arg_tys = dataConRepArgTys con + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys + n_ex = length ex_tvs + + -- split the Uniques and FastStrings + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss + + -- Make the instantiating substitution for universals + univ_subst = zipTvSubst univ_tvs inst_tys + + -- Make existential type variables, applying and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv + new_tv + , new_tv) + where + new_tv | isTyVar tv + = mkTyVar (mkSysTvName uniq fs) kind + | otherwise + = mkCoVar (mkSystemVarName uniq fs) kind + kind = Type.substTyUnchecked subst (varType tv) + + -- Make value vars, instantiating types + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs (Scaled m ty) str + = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] + mkLocalIdOrCoVar name (mult `mkMultMul` m) (Type.substTy full_subst ty) + where + name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan + +{- +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt + +************************************************************************ +* * + Equality +* * +************************************************************************ +-} + +-- | A cheap equality test which bales out fast! +-- If it returns @True@ the arguments are definitely equal, +-- otherwise, they may or may not be equal. +cheapEqExpr :: Expr b -> Expr b -> Bool +cheapEqExpr = cheapEqExpr' (const False) + +-- | Cheap expression equality test, can ignore ticks by type. +cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool +{-# INLINE cheapEqExpr' #-} +cheapEqExpr' ignoreTick e1 e2 + = go e1 e2 + where + go (Var v1) (Var v2) = v1 == v2 + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = t1 `eqType` t2 + go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 + go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2 + go (Cast e1 t1) (Cast e2 t2) = e1 `go` e2 && t1 `eqCoercion` t2 + + go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2 + go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2 + go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2 + + go _ _ = False + + + +eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool +-- Compares for equality, modulo alpha +eqExpr in_scope e1 e2 + = go (mkRnEnv2 in_scope) e1 e2 + where + go env (Var v1) (Var v2) + | rnOccL env v1 == rnOccR env v2 + = True + + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = eqTypeX env t1 t2 + go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 + go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 + go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 + + go env (Lam b1 e1) (Lam b2 e2) + = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + && go (rnBndr2 env b1 b2) e1 e2 + + go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go env r1 r2 -- No need to check binder types, since RHSs match + && go (rnBndr2 env v1 v2) e1 e2 + + go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = equalLength ps1 ps2 + && all2 (go env') rs1 rs2 && go env' e1 e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env' = rnBndrs2 env bs1 bs2 + + go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] in GHC.Data.TrieMap + = null a2 && go env e1 e2 && eqTypeX env t1 t2 + | otherwise + = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + + go _ _ _ = False + + ----------- + go_alt env (c1, bs1, e1) (c2, bs2, e2) + = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 + +eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool +eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) + = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids +eqTickish _ l r = l == r + +-- | Finds differences between core expressions, modulo alpha and +-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be +-- checked for differences as well. +diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] +diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] +diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] +diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] +diffExpr _ env (Coercion co1) (Coercion co2) + | eqCoercionX env co1 co2 = [] +diffExpr top env (Cast e1 co1) (Cast e2 co2) + | eqCoercionX env co1 co2 = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) e2 + | not (tickishIsCode n1) = diffExpr top env e1 e2 +diffExpr top env e1 (Tick n2 e2) + | not (tickishIsCode n2) = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) (Tick n2 e2) + | eqTickish env n1 n2 = diffExpr top env e1 e2 + -- The error message of failed pattern matches will contain + -- generated names, which are allowed to differ. +diffExpr _ _ (App (App (Var absent) _) _) + (App (App (Var absent2) _) _) + | isDeadEndId absent && isDeadEndId absent2 = [] +diffExpr top env (App f1 a1) (App f2 a2) + = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 +diffExpr top env (Lam b1 e1) (Lam b2 e2) + | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = diffExpr top (rnBndr2 env b1 b2) e1 e2 +diffExpr top env (Let bs1 e1) (Let bs2 e2) + = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) + in ds ++ diffExpr top env' e1 e2 +diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 + -- See Note [Empty case alternatives] in GHC.Data.TrieMap + = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) + where env' = rnBndr2 env b1 b2 + diffAlt (c1, bs1, e1) (c2, bs2, e2) + | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] + | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 +diffExpr _ _ e1 e2 + = [fsep [ppr e1, text "/=", ppr e2]] + +-- | Finds differences between core bindings, see @diffExpr@. +-- +-- The main problem here is that while we expect the binds to have the +-- same order in both lists, this is not guaranteed. To do this +-- properly we'd either have to do some sort of unification or check +-- all possible mappings, which would be seriously expensive. So +-- instead we simply match single bindings as far as we can. This +-- leaves us just with mutually recursive and/or mismatching bindings, +-- which we then speculatively match by ordering them. It's by no means +-- perfect, but gets the job done well enough. +diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] + -> ([SDoc], RnEnv2) +diffBinds top env binds1 = go (length binds1) env binds1 + where go _ env [] [] + = ([], env) + go fuel env binds1 binds2 + -- No binds left to compare? Bail out early. + | null binds1 || null binds2 + = (warn env binds1 binds2, env) + -- Iterated over all binds without finding a match? Then + -- try speculatively matching binders by order. + | fuel == 0 + = if not $ env `inRnEnvL` fst (head binds1) + then let env' = uncurry (rnBndrs2 env) $ unzip $ + zip (sort $ map fst binds1) (sort $ map fst binds2) + in go (length binds1) env' binds1 binds2 + -- If we have already tried that, give up + else (warn env binds1 binds2, env) + go fuel env ((bndr1,expr1):binds1) binds2 + | let matchExpr (bndr,expr) = + (not top || null (diffIdInfo env bndr bndr1)) && + null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) + , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 + = go (length binds1) (rnBndr2 env bndr1 bndr2) + binds1 (binds2l ++ binds2r) + | otherwise -- No match, so push back (FIXME O(n^2)) + = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 + go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough + + -- We have tried everything, but couldn't find a good match. So + -- now we just return the comparison results when we pair up + -- the binds in a pseudo-random order. + warn env binds1 binds2 = + concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ + unmatched "unmatched left-hand:" (drop l binds1') ++ + unmatched "unmatched right-hand:" (drop l binds2') + where binds1' = sortBy (comparing fst) binds1 + binds2' = sortBy (comparing fst) binds2 + l = min (length binds1') (length binds2') + unmatched _ [] = [] + unmatched txt bs = [text txt $$ ppr (Rec bs)] + diffBind env (bndr1,expr1) (bndr2,expr2) + | ds@(_:_) <- diffExpr top env expr1 expr2 + = locBind "in binding" bndr1 bndr2 ds + | otherwise + = diffIdInfo env bndr1 bndr2 + +-- | Find differences in @IdInfo@. We will especially check whether +-- the unfoldings match, if present (see @diffUnfold@). +diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] +diffIdInfo env bndr1 bndr2 + | arityInfo info1 == arityInfo info2 + && cafInfo info1 == cafInfo info2 + && oneShotInfo info1 == oneShotInfo info2 + && inlinePragInfo info1 == inlinePragInfo info2 + && occInfo info1 == occInfo info2 + && demandInfo info1 == demandInfo info2 + && callArityInfo info1 == callArityInfo info2 + && levityInfo info1 == levityInfo info2 + = locBind "in unfolding of" bndr1 bndr2 $ + diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) + | otherwise + = locBind "in Id info of" bndr1 bndr2 + [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] + where info1 = idInfo bndr1; info2 = idInfo bndr2 + +-- | Find differences in unfoldings. Note that we will not check for +-- differences of @IdInfo@ in unfoldings, as this is generally +-- redundant, and can lead to an exponential blow-up in complexity. +diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] +diffUnfold _ NoUnfolding NoUnfolding = [] +diffUnfold _ BootUnfolding BootUnfolding = [] +diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] +diffUnfold env (DFunUnfolding bs1 c1 a1) + (DFunUnfolding bs2 c2 a2) + | c1 == c2 && equalLength bs1 bs2 + = concatMap (uncurry (diffExpr False env')) (zip a1 a2) + where env' = rnBndrs2 env bs1 bs2 +diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) + (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) + | v1 == v2 && cl1 == cl2 + && wf1 == wf2 && x1 == x2 && g1 == g2 + = diffExpr False env t1 t2 +diffUnfold _ uf1 uf2 + = [fsep [ppr uf1, text "/=", ppr uf2]] + +-- | Add location information to diff messages +locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] +locBind loc b1 b2 diffs = map addLoc diffs + where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) + bindLoc | b1 == b2 = ppr b1 + | otherwise = ppr b1 <> char '/' <> ppr b2 + +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try for eta reduction here, but *only* if we get all the way to an +trivial expression. We don't want to remove extra lambdas unless we +are going to avoid allocating this thing altogether. + +There are some particularly delicate points here: + +* We want to eta-reduce if doing so leaves a trivial expression, + *including* a cast. For example + \x. f |> co --> f |> co + (provided co doesn't mention x) + +* Eta reduction is not valid in general: + \x. bot /= bot + This matters, partly for old-fashioned correctness reasons but, + worse, getting it wrong can yield a seg fault. Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it + *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands + the definition again, so that it does not terminate after all. + Result: seg-fault because the boolean case actually gets a function value. + See #1947. + + So it's important to do the right thing. + +* With linear types, eta-reduction can break type-checking: + f :: A ⊸ B + g :: A -> B + g = \x. f x + + The above is correct, but eta-reducing g would yield g=f, the linter will + complain that g and f don't have the same type. + +* Note [Arity care]: we need to be careful if we just look at f's + arity. Currently (Dec07), f's arity is visible in its own RHS (see + Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the + arity when checking that 'f' is a value. Otherwise we will + eta-reduce + f = \x. f x + to + f = f + Which might change a terminating program (think (f `seq` e)) to a + non-terminating one. So we check for being a loop breaker first. + + However for GlobalIds we can look at the arity; and for primops we + must, since they have no unfolding. + +* Regardless of whether 'f' is a value, we always want to + reduce (/\a -> f a) to f + This came up in a RULE: foldr (build (/\a -> g a)) + did not match foldr (build (/\b -> ...something complex...)) + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc isDictId + +* Never *reduce* arity. For example + f = \xy. g x y + Then if h has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + +These delicacies are why we don't use exprIsTrivial and exprIsHNF here. +Alas. + +Note [Eta reduction with casted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:t3). f (x |> g)) :: t3 -> t2 + where + f :: t1 -> t2 + g :: t3 ~ t1 +This should be eta-reduced to + + f |> (sym g -> t2) + +So we need to accumulate a coercion, pushing it inward (past +variable arguments only) thus: + f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x + f (x:t) |> co --> (f |> (t -> co)) x + f @ a |> co --> (f |> (forall a.co)) @ a + f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) +These are the equations for ok_arg. + +It's true that we could also hope to eta reduce these: + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) +But the simplifier pushes those casts outwards, so we don't +need to address that here. +-} + +-- When updating this function, make sure to update +-- CorePrep.tryEtaReducePrep as well! +tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr +tryEtaReduce bndrs body + = go (reverse bndrs) body (mkRepReflCo (exprType body)) + where + incoming_arity = count isId bndrs + + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> Coercion -- Of type tr ~ ts + -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts + -- See Note [Eta reduction with casted arguments] + -- for why we have an accumulating coercion + go [] fun co + | ok_fun fun + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + , not (any (`elemVarSet` used_vars) bndrs) + = Just (mkCast fun co) -- Check for any of the binders free in the result + -- including the accumulated coercion + + go bs (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co (exprType fun) + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go _ _ _ = Nothing -- Failure! + + --------------- + -- Note [Eta reduction conditions] + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs + ok_fun _fun = False + + --------------- + ok_fun_id fun = fun_arity fun >= incoming_arity + + --------------- + fun_arity fun -- See Note [Arity care] + | isLocalId fun + , isStrongLoopBreaker (idOccInfo fun) = 0 + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction of an eval'd function] + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvVar v + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Type -- Type of the function to which the argument is applied + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) + , [Tickish Var]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co _ + | Just tv <- getTyVar_maybe ty + , bndr == tv = Just (mkHomoForAllCos [tv] co, []) + ok_arg bndr (Var v) co fun_ty + | bndr == v + , let mult = idMult bndr + , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty + , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort + = let reflCo = mkRepReflCo (idType bndr) + in Just (mkFunCo Representational (multToCo mult) reflCo co, []) + ok_arg bndr (Cast e co_arg) co fun_ty + | (ticks, Var v) <- stripTicksTop tickishFloatable e + , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty + , bndr == v + , fun_mult `eqType` idMult bndr + = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg bndr (Tick t arg) co fun_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty + = Just (co', t:ticks) + + ok_arg _ _ _ _ = Nothing + +{- +Note [Eta reduction of an eval'd function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell it is not true that f = \x. f x +because f might be bottom, and 'seq' can distinguish them. + +But it *is* true that f = f `seq` \x. f x +and we'd like to simplify the latter to the former. This amounts +to the rule that + * when there is just *one* value argument, + * f is not bottom +we can eta-reduce \x. f x ===> f + +This turned up in #7542. + + +************************************************************************ +* * +\subsection{Determining non-updatable right-hand-sides} +* * +************************************************************************ + +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). + +If this happens we simply make the RHS into an updatable thunk, +and 'execute' it rather than allocating it statically. +-} + +{- +************************************************************************ +* * +\subsection{Type utilities} +* * +************************************************************************ +-} + +-- | True if the type has no non-bottom elements, e.g. when it is an empty +-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. +-- See Note [Bottoming expressions] +-- +-- See Note [No alternatives lint check] for another use of this function. +isEmptyTy :: Type -> Bool +isEmptyTy ty + -- Data types where, given the particular type parameters, no data + -- constructor matches, are empty. + -- This includes data types with no constructors, e.g. Data.Void.Void. + | Just (tc, inst_tys) <- splitTyConApp_maybe ty + , Just dcs <- tyConDataCons_maybe tc + , all (dataConCannotMatch inst_tys) dcs + = True + | otherwise + = False + +{- +***************************************************** +* +* StaticPtr +* +***************************************************** +-} + +-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields +-- @Just (makeStatic, t, srcLoc, e)@. +-- +-- Returns @Nothing@ for every other expression. +collectMakeStaticArgs + :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) +collectMakeStaticArgs e + | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e + , idName b == makeStaticName = Just (fun, t, loc, arg) +collectMakeStaticArgs _ = Nothing + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Does this binding bind a join point (or a recursive group of join points)? +isJoinBind :: CoreBind -> Bool +isJoinBind (NonRec b _) = isJoinId b +isJoinBind (Rec ((b, _) : _)) = isJoinId b +isJoinBind _ = False + +dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> CoreProgram -> SDoc +dumpIdInfoOfProgram ppr_id_info binds = vcat (map printId ids) + where + ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) + getIds (NonRec i _) = [ i ] + getIds (Rec bs) = map fst bs + printId id | isExportedId id = ppr id <> colon <+> (ppr_id_info (idInfo id)) + | otherwise = empty + + +{- ********************************************************************* +* * + unsafeEqualityProof +* * +********************************************************************* -} + +isUnsafeEqualityProof :: CoreExpr -> Bool +-- See (U3) and (U4) in +-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce +isUnsafeEqualityProof e + | Var v `App` Type _ `App` Type _ `App` Type _ <- e + = idName v == unsafeEqualityProofName + | otherwise + = False + diff --git a/GHC/Core/Utils.hs-boot b/GHC/Core/Utils.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Utils.hs-boot @@ -0,0 +1,6 @@ +module GHC.Core.Utils where + +import GHC.Core.Multiplicity +import GHC.Core.Type + +mkFunctionType :: Mult -> Type -> Type -> Type diff --git a/GHC/CoreToByteCode.hs b/GHC/CoreToByteCode.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToByteCode.hs @@ -0,0 +1,2066 @@ +{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -fprof-auto-top #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | GHC.CoreToByteCode: Generate bytecode from Core +module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.ByteCode.Instr +import GHC.ByteCode.Asm +import GHC.ByteCode.Types + +import GHC.Runtime.Interpreter +import GHCi.FFI +import GHCi.RemoteTypes +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Name +import GHC.Types.Id.Make +import GHC.Types.Id +import GHC.Types.ForeignCall +import GHC.Driver.Types +import GHC.Core.Utils +import GHC.Core +import GHC.Core.Ppr +import GHC.Types.Literal +import GHC.Builtin.PrimOps +import GHC.Core.FVs +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Utils.Misc +import GHC.Types.Var.Set +import GHC.Builtin.Types.Prim +import GHC.Core.TyCo.Ppr ( pprType ) +import GHC.Utils.Error +import GHC.Types.Unique +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +import GHC.StgToCmm.Layout +import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) +import GHC.Data.Bitmap +import GHC.Data.OrdList +import GHC.Data.Maybe +import GHC.Types.Var.Env +import GHC.Builtin.Names ( unsafeEqualityProofName ) + +import Data.List +import Foreign +import Control.Monad +import Data.Char + +import GHC.Types.Unique.Supply +import GHC.Unit.Module + +import Control.Exception +import Data.Array +import Data.ByteString (ByteString) +import Data.Map (Map) +import Data.IntMap (IntMap) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified GHC.Data.FiniteMap as Map +import Data.Ord +import GHC.Stack.CCS +import Data.Either ( partitionEithers ) + +-- ----------------------------------------------------------------------------- +-- Generating byte code for a complete module + +byteCodeGen :: HscEnv + -> Module + -> CoreProgram + -> [TyCon] + -> Maybe ModBreaks + -> IO CompiledByteCode +byteCodeGen hsc_env this_mod binds tycs mb_modBreaks + = withTiming dflags + (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) + (const ()) $ do + -- Split top-level binds into strings and others. + -- See Note [generating code for top-level string literal bindings]. + let (strings, flatBinds) = partitionEithers $ do -- list monad + (bndr, rhs) <- flattenBinds binds + return $ case exprIsTickedString_maybe rhs of + Just str -> Left (bndr, str) + _ -> Right (bndr, simpleFreeVars rhs) + stringPtrs <- allocateTopStrings hsc_env strings + + us <- mkSplitUniqSupply 'y' + (BcM_State{..}, proto_bcos) <- + runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ + mapM schemeTopBind flatBinds + + when (notNull ffis) + (panic "GHC.CoreToByteCode.byteCodeGen: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-BCOs" FormatByteCode + (vcat (intersperse (char ' ') (map ppr proto_bcos))) + + cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs) + (case modBreaks of + Nothing -> Nothing + Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) + + -- Squash space leaks in the CompiledByteCode. This is really + -- important, because when loading a set of modules into GHCi + -- we don't touch the CompiledByteCode until the end when we + -- do linking. Forcing out the thunks here reduces space + -- usage by more than 50% when loading a large number of + -- modules. + evaluate (seqCompiledByteCode cbc) + + return cbc + + where dflags = hsc_dflags hsc_env + +allocateTopStrings + :: HscEnv + -> [(Id, ByteString)] + -> IO [(Var, RemotePtr ())] +allocateTopStrings hsc_env topStrings = do + let !(bndrs, strings) = unzip topStrings + ptrs <- iservCmd hsc_env $ MallocStrings strings + return $ zip bndrs ptrs + +{- +Note [generating code for top-level string literal bindings] + +Here is a summary on how the byte code generator deals with top-level string +literals: + +1. Top-level string literal bindings are separated from the rest of the module. + +2. The strings are allocated via iservCmd, in allocateTopStrings + +3. The mapping from binders to allocated strings (topStrings) are maintained in + BcM and used when generating code for variable references. +-} + +-- ----------------------------------------------------------------------------- +-- Generating byte code for an expression + +-- Returns: the root BCO for this expression +coreExprToBCOs :: HscEnv + -> Module + -> CoreExpr + -> IO UnlinkedBCO +coreExprToBCOs hsc_env this_mod expr + = withTiming dflags + (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) + (const ()) $ do + -- create a totally bogus name for the top-level BCO; this + -- should be harmless, since it's never used for anything + let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") + + -- the uniques are needed to generate fresh variables when we introduce new + -- let bindings for ticked expressions + us <- mkSplitUniqSupply 'y' + (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) + <- runBc hsc_env us this_mod Nothing emptyVarEnv $ + schemeR [] (invented_name, simpleFreeVars expr) + + when (notNull mallocd) + (panic "GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode + (ppr proto_bco) + + assembleOneBCO hsc_env proto_bco + where dflags = hsc_dflags hsc_env + +-- The regular freeVars function gives more information than is useful to +-- us here. We need only the free variables, not everything in an FVAnn. +-- Historical note: At one point FVAnn was more sophisticated than just +-- a set. Now it isn't. So this function is much simpler. Keeping it around +-- so that if someone changes FVAnn, they will get a nice type error right +-- here. +simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet +simpleFreeVars = freeVars + +-- ----------------------------------------------------------------------------- +-- Compilation schema for the bytecode generator + +type BCInstrList = OrdList BCInstr + +newtype ByteOff = ByteOff Int + deriving (Enum, Eq, Integral, Num, Ord, Real) + +newtype WordOff = WordOff Int + deriving (Enum, Eq, Integral, Num, Ord, Real) + +wordsToBytes :: Platform -> WordOff -> ByteOff +wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral + +-- Used when we know we have a whole number of words +bytesToWords :: Platform -> ByteOff -> WordOff +bytesToWords platform (ByteOff bytes) = + let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform) + in if r == 0 + then fromIntegral q + else panic $ "GHC.CoreToByteCode.bytesToWords: bytes=" ++ show bytes + +wordSize :: Platform -> ByteOff +wordSize platform = ByteOff (platformWordSizeInBytes platform) + +type Sequel = ByteOff -- back off to this depth before ENTER + +type StackDepth = ByteOff + +-- | Maps Ids to their stack depth. This allows us to avoid having to mess with +-- it after each push/pop. +type BCEnv = Map Id StackDepth -- To find vars on the stack + +{- +ppBCEnv :: BCEnv -> SDoc +ppBCEnv p + = text "begin-env" + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) + $$ text "end-env" + where + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var) + cmp_snd x y = compare (snd x) (snd y) +-} + +-- Create a BCO and do a spot of peephole optimisation on the insns +-- at the same time. +mkProtoBCO + :: DynFlags + -> name + -> BCInstrList + -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) + -- ^ original expression; for debugging only + -> Int + -> Word16 + -> [StgWord] + -> Bool -- True <=> is a return point, rather than a function + -> [FFIInfo] + -> ProtoBCO name +mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis + = ProtoBCO { + protoBCOName = nm, + protoBCOInstrs = maybe_with_stack_check, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin, + protoBCOFFIs = ffis + } + where + -- Overestimate the stack usage (in words) of this BCO, + -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit + -- stack check. (The interpreter always does a stack check + -- for iNTERP_STACK_CHECK_THRESH words at the start of each + -- BCO anyway, so we only need to add an explicit one in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_with_stack_check + | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d + -- don't do stack checks at return points, + -- everything is aggregated up to the top BCO + -- (which must be a function). + -- That is, unless the stack usage is >= AP_STACK_SPLIM, + -- see bug #1466. + | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH + = STKCHECK stack_usage : peep_d + | otherwise + = peep_d -- the supposedly common case + + -- We assume that this sum doesn't wrap + stack_usage = sum (map bciStackUse peep_d) + + -- Merge local pushes + peep_d = peep (fromOL instrs_ordlist) + + peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) + = PUSH_LLL off1 (off2-1) (off3-2) : peep rest + peep (PUSH_L off1 : PUSH_L off2 : rest) + = PUSH_LL off1 (off2-1) : peep rest + peep (i:rest) + = i : peep rest + peep [] + = [] + +argBits :: Platform -> [ArgRep] -> [Bool] +argBits _ [] = [] +argBits platform (rep : args) + | isFollowableArg rep = False : argBits platform args + | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args + +-- ----------------------------------------------------------------------------- +-- schemeTopBind + +-- Compile code for the right-hand side of a top-level binding + +schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name) +schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con = do + dflags <- getDynFlags + -- Special case for the worker of a nullary data con. + -- It'll look like this: Nil = /\a -> Nil a + -- If we feed it into schemeR, we'll get + -- Nil = Nil + -- because mkConAppCode treats nullary constructor applications + -- by just re-using the single top-level definition. So + -- for the worker itself, we must allocate it directly. + -- ioToBc (putStrLn $ "top level BCO") + emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER]) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + + | otherwise + = schemeR [{- No free variables -}] (getName id, rhs) + + +-- ----------------------------------------------------------------------------- +-- schemeR + +-- Compile code for a right-hand side, to give a BCO that, +-- when executed with the free variables and arguments on top of the stack, +-- will return with a pointer to the result on top of the stack, after +-- removing the free variables and arguments. +-- +-- Park the resulting BCO in the monad. Also requires the +-- name of the variable to which this value was bound, +-- so as to give the resulting BCO a name. + +schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. + -> (Name, AnnExpr Id DVarSet) + -> BcM (ProtoBCO Name) +schemeR fvs (nm, rhs) +{- + | trace (showSDoc ( + (char ' ' + $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined + | otherwise +-} + = schemeR_wrk fvs nm rhs (collect rhs) + +-- If an expression is a lambda, return the +-- list of arguments to the lambda (in R-to-L order) and the +-- underlying expression +collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) +collect (_, e) = go [] e + where + go xs e | Just e' <- bcView e = go xs e' + go xs (AnnLam x (_,e)) + | typePrimRep (idType x) `lengthExceeds` 1 + = multiValException + | otherwise + = go (x:xs) e + go xs not_lambda = (reverse xs, not_lambda) + +schemeR_wrk + :: [Id] + -> Name + -> AnnExpr Id DVarSet -- expression e, for debugging only + -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e + -> BcM (ProtoBCO Name) +schemeR_wrk fvs nm original_body (args, body) + = do + dflags <- getDynFlags + let + platform = targetPlatform dflags + all_args = reverse args ++ fvs + arity = length all_args + -- all_args are the args in reverse order. We're compiling a function + -- \fv1..fvn x1..xn -> e + -- i.e. the fvs come first + + -- Stack arguments always take a whole number of words, we never pack + -- them unlike constructor fields. + szsb_args = map (wordsToBytes platform . idSizeW platform) all_args + sum_szsb_args = sum szsb_args + p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) + + -- make the arg bitmap + bits = argBits platform (reverse (map bcIdArgRep all_args)) + bitmap_size = genericLength bits + bitmap = mkBitmap platform bits + body_code <- schemeER_wrk sum_szsb_args p_init body + + emitBc (mkProtoBCO dflags nm body_code (Right original_body) + arity bitmap_size bitmap False{-not alts-}) + +-- introduce break instructions for ticked expressions +schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +schemeER_wrk d p rhs + | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs + = do code <- schemeE d 0 p newRhs + cc_arr <- getCCArray + this_mod <- moduleName <$> getCurrentModule + dflags <- getDynFlags + let platform = targetPlatform dflags + let idOffSets = getVarOffSets platform d p fvs + let breakInfo = CgBreakInfo + { cgb_vars = idOffSets + , cgb_resty = exprType (deAnnotate' newRhs) + } + newBreakInfo tick_no breakInfo + hsc_env <- getHscEnv + let cc | Just interp <- hsc_interp hsc_env + , interpreterProfiled interp + = cc_arr ! tick_no + | otherwise = toRemotePtr nullPtr + let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc + return $ breakInstr `consOL` code + | otherwise = schemeE d 0 p rhs + +getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)] +getVarOffSets platform depth env = map getOffSet + where + getOffSet id = case lookupBCEnv_maybe id env of + Nothing -> Nothing + Just offset -> + -- michalt: I'm not entirely sure why we need the stack + -- adjustment by 2 here. I initially thought that there's + -- something off with getIdValFromApStack (the only user of this + -- value), but it looks ok to me. My current hypothesis is that + -- this "adjustment" is needed due to stack manipulation for + -- BRK_FUN in Interpreter.c In any case, this is used only when + -- we trigger a breakpoint. + let !var_depth_ws = + trunc16W $ bytesToWords platform (depth - offset) + 2 + in Just (id, var_depth_ws) + +truncIntegral16 :: Integral a => a -> Word16 +truncIntegral16 w + | w > fromIntegral (maxBound :: Word16) + = panic "stack depth overflow" + | otherwise + = fromIntegral w + +trunc16B :: ByteOff -> Word16 +trunc16B = truncIntegral16 + +trunc16W :: WordOff -> Word16 +trunc16W = truncIntegral16 + +fvsToEnv :: BCEnv -> DVarSet -> [Id] +-- Takes the free variables of a right-hand side, and +-- delivers an ordered list of the local variables that will +-- be captured in the thunk for the RHS +-- The BCEnv argument tells which variables are in the local +-- environment: these are the ones that should be captured +-- +-- The code that constructs the thunk, and the code that executes +-- it, have to agree about this layout +fvsToEnv p fvs = [v | v <- dVarSetElems fvs, + isId v, -- Could be a type variable + v `Map.member` p] + +-- ----------------------------------------------------------------------------- +-- schemeE + +returnUnboxedAtom + :: StackDepth + -> Sequel + -> BCEnv + -> AnnExpr' Id DVarSet + -> ArgRep + -> BcM BCInstrList +-- Returning an unlifted value. +-- Heave it on the stack, SLIDE, and RETURN. +returnUnboxedAtom d s p e e_rep = do + dflags <- getDynFlags + let platform = targetPlatform dflags + (push, szb) <- pushAtom d p e + return (push -- value onto stack + `appOL` mkSlideB platform szb (d - s) -- clear to sequel + `snocOL` RETURN_UBX e_rep) -- go + +-- Compile code to apply the given expression to the remaining args +-- on the stack, returning a HNF. +schemeE + :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +schemeE d s p e + | Just e' <- bcView e + = schemeE d s p e' + +-- Delegate tail-calls to schemeT. +schemeE d s p e@(AnnApp _ _) = schemeT d s p e + +schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit)) +schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V + +schemeE d s p e@(AnnVar v) + -- See Note [Not-necessarily-lifted join points], step 3. + | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId] + | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) + | otherwise = schemeT d s p e + +schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) + | (AnnVar v, args_r_to_l) <- splitApp rhs, + Just data_con <- isDataConWorkId_maybe v, + dataConRepArity data_con == length args_r_to_l + = do -- Special case for a non-recursive let whose RHS is a + -- saturated constructor application. + -- Just allocate the constructor and carry on + alloc_code <- mkConAppCode d s p data_con args_r_to_l + platform <- targetPlatform <$> getDynFlags + let !d2 = d + wordSize platform + body_code <- schemeE d2 s (Map.insert x d2 p) body + return (alloc_code `appOL` body_code) + +-- General case for let. Generates correct, if inefficient, code in +-- all situations. +schemeE d s p (AnnLet binds (_,body)) = do + platform <- targetPlatform <$> getDynFlags + let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) + AnnRec xs_n_rhss -> unzip xs_n_rhss + n_binds = genericLength xs + + fvss = map (fvsToEnv p' . fst) rhss + + -- See Note [Not-necessarily-lifted join points], step 2. + (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss + + -- Sizes of free vars + size_w = trunc16W . idSizeW platform + sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss + + -- the arity of each rhs + arities = map (genericLength . fst . collect) rhss' + + -- This p', d' defn is safe because all the items being pushed + -- are ptrs, so all have size 1 word. d' and p' reflect the stack + -- after the closures have been allocated in the heap (but not + -- filled in), and pointers to them parked on the stack. + offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform)) + p' = Map.insertList (zipE xs' offsets) p + d' = d + wordsToBytes platform n_binds + zipE = zipEqual "schemeE" + + -- ToDo: don't build thunks for things with no free variables + build_thunk + :: StackDepth + -> [Id] + -> Word16 + -> ProtoBCO Name + -> Word16 + -> Word16 + -> BcM BCInstrList + build_thunk _ [] size bco off arity + = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP + build_thunk dd (fv:fvs) size bco off arity = do + (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv) + more_push_code <- + build_thunk (dd + pushed_szb) fvs size bco off arity + return (push_code `appOL` more_push_code) + + alloc_code = toOL (zipWith mkAlloc sizes arities) + where mkAlloc sz 0 + | is_tick = ALLOC_AP_NOUPD sz + | otherwise = ALLOC_AP sz + mkAlloc sz arity = ALLOC_PAP arity sz + + is_tick = case binds of + AnnNonRec id _ -> occNameFS (getOccName id) == tickFS + _other -> False + + compile_bind d' fvs x rhs size arity off = do + bco <- schemeR fvs (getName x,rhs) + build_thunk d' fvs size bco off arity + + compile_binds = + [ compile_bind d' fvs x rhs size arity (trunc16W n) + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1] + ] + body_code <- schemeE d' s p' body + thunk_codes <- sequence compile_binds + return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) + +-- Introduce a let binding for a ticked case expression. This rule +-- *should* only fire when the expression was not already let-bound +-- (the code gen for let bindings should take care of that). Todo: we +-- call exprFreeVars on a deAnnotated expression, this may not be the +-- best way to calculate the free vars but it seemed like the least +-- intrusive thing to do +schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) + | isLiftedTypeKind (typeKind ty) + = do id <- newId ty + -- Todo: is emptyVarSet correct on the next line? + let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id) + schemeE d s p letExp + + | otherwise + = do -- If the result type is not definitely lifted, then we must generate + -- let f = \s . tick e + -- in f realWorld# + -- When we stop at the breakpoint, _result will have an unlifted + -- type and hence won't be bound in the environment, but the + -- breakpoint will otherwise work fine. + -- + -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where + -- r :: RuntimeRep is a variable. This can happen in the + -- continuations for a pattern-synonym matcher + -- match = /\(r::RuntimeRep) /\(a::TYPE r). + -- \(k :: Int -> a) \(v::T). + -- case v of MkV n -> k n + -- Here (k n) :: a :: Type r, so we don't know if it's lifted + -- or not; but that should be fine provided we add that void arg. + + id <- newId (mkVisFunTyMany realWorldStatePrimTy ty) + st <- newId realWorldStatePrimTy + let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp))) + (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id) + (emptyDVarSet, AnnVar realWorldPrimId))) + schemeE d s p letExp + + where + exp' = deAnnotate' exp + fvs = exprFreeVarsDSet exp' + ty = exprType exp' + +-- ignore other kinds of tick +schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs + +-- no alts: scrut is guaranteed to diverge +schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut + +-- handle pairs with one void argument (e.g. state token) +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc + -- Convert + -- case .... of x { (# V'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- because the return convention for both are identical. + -- + -- Note that it does not matter losing the void-rep thing from the + -- envt (it won't be bound now) because we never look such things up. + , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of + ([], [_]) + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) + ([_], []) + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + _ -> Nothing + = res + +-- handle unit tuples +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) + | isUnboxedTupleCon dc + , typePrimRep (idType bndr) `lengthAtMost` 1 + = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + +-- handle nullary tuples +schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) + | isUnboxedTupleType (idType bndr) + , Just ty <- case typePrimRep (idType bndr) of + [_] -> Just (unwrapType (idType bndr)) + [] -> Just voidPrimTy + _ -> Nothing + -- handles any pattern with a single non-void binder; in particular I/O + -- monad returns (# RealWorld#, a #) + = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) + +schemeE d s p (AnnCase scrut bndr _ alts) + = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} + +schemeE _ _ _ expr + = pprPanic "GHC.CoreToByteCode.schemeE: unhandled case" + (pprCoreExpr (deAnnotate' expr)) + +-- Is this Id a not-necessarily-lifted join point? +-- See Note [Not-necessarily-lifted join points], step 1 +isNNLJoinPoint :: Id -> Bool +isNNLJoinPoint x = isJoinId x && + Just True /= isLiftedType_maybe (idType x) + +-- If necessary, modify this Id and body to protect not-necessarily-lifted join points. +-- See Note [Not-necessarily-lifted join points], step 2. +protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet) +protectNNLJoinPointBind x rhs@(fvs, _) + | isNNLJoinPoint x + = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs)) + + | otherwise + = (x, rhs) + +-- Update an Id's type to take a Void# argument. +-- Precondition: the Id is a not-necessarily-lifted join point. +-- See Note [Not-necessarily-lifted join points] +protectNNLJoinPointId :: Id -> Id +protectNNLJoinPointId x + = ASSERT( isNNLJoinPoint x ) + updateIdTypeButNotMult (voidPrimTy `mkVisFunTyMany`) x + +{- + Ticked Expressions + ------------------ + + The idea is that the "breakpoint E" is really just an annotation on + the code. When we find such a thing, we pull out the useful information, + and then compile the code as if it was just the expression E. + +Note [Not-necessarily-lifted join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point variable is essentially a goto-label: it is, for example, +never used as an argument to another function, and it is called only +in tail position. See Note [Join points] and Note [Invariants on join points], +both in GHC.Core. Because join points do not compile to true, red-blooded +variables (with, e.g., registers allocated to them), they are allowed +to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points] +in GHC.Core.) + +However, in this byte-code generator, join points *are* treated just as +ordinary variables. There is no check whether a binding is for a join point +or not; they are all treated uniformly. (Perhaps there is a missed optimization +opportunity here, but that is beyond the scope of my (Richard E's) Thursday.) + +We thus must have *some* strategy for dealing with levity-polymorphic and +unlifted join points. Levity-polymorphic variables are generally not allowed +(though levity-polymorphic join points *are*; see Note [Invariants on join points] +in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly. +The questionable join points are *not-necessarily-lifted join points* +(NNLJPs). (Not having such a strategy led to #16509, which panicked in the +isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy: + +1. Detect NNLJPs. This is done in isNNLJoinPoint. + +2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the + type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.) + Note that functions are never levity-polymorphic, so this transformation + changes an NNLJP to a non-levity-polymorphic join point. This is done + in protectNNLJoinPointBind, called from the AnnLet case of schemeE. + +3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId), + being careful to note the new type of the NNLJP. This is done in the AnnVar + case of schemeE, with help from protectNNLJoinPointId. + +Here is an example. Suppose we have + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + join j :: a + j = error @r @a "bloop" + in case x of + A -> j + B -> j + C -> error @r @a "blurp" + +Our plan is to behave is if the code was + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + let j :: (Void# -> a) + j = \ _ -> error @r @a "bloop" + in case x of + A -> j void# + B -> j void# + C -> error @r @a "blurp" + +It's a bit hacky, but it works well in practice and is local. I suspect the +Right Fix is to take advantage of join points as goto-labels. + +-} + +-- Compile code to do a tail call. Specifically, push the fn, +-- slide the on-stack app back down to the sequel depth, +-- and enter. Four cases: +-- +-- 0. (Nasty hack). +-- An application "GHC.Prim.tagToEnum# unboxed-int". +-- The int will be on the stack. Generate a code sequence +-- to convert it to the relevant constructor, SLIDE and ENTER. +-- +-- 1. The fn denotes a ccall. Defer to generateCCall. +-- +-- 2. (Another nasty hack). Spot (# a::V, b #) and treat +-- it simply as b -- since the representations are identical +-- (the V takes up zero stack space). Also, spot +-- (# b #) and treat it as b. +-- +-- 3. Application of a constructor, by defn saturated. +-- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- then the ptrs, and then do PACK and RETURN. +-- +-- 4. Otherwise, it must be a function call. Push the args +-- right to left, SLIDE and ENTER. + +schemeT :: StackDepth -- Stack depth + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> AnnExpr' Id DVarSet + -> BcM BCInstrList + +schemeT d s p app + + -- Case 0 + | Just (arg, constr_names) <- maybe_is_tagToEnum_call app + = implement_tagToId d s p arg constr_names + + -- Case 1 + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = if isSupportedCConv ccall_spec + then generateCCall d s p ccall_spec fn args_r_to_l + else unsupportedCConvException + + + -- Case 2: Constructor application + | Just con <- maybe_saturated_dcon + , isUnboxedTupleCon con + = case args_r_to_l of + [arg1,arg2] | isVAtom arg1 -> + unboxedTupleReturn d s p arg2 + [arg1,arg2] | isVAtom arg2 -> + unboxedTupleReturn d s p arg1 + _other -> multiValException + + -- Case 3: Ordinary data constructor + | Just con <- maybe_saturated_dcon + = do alloc_con <- mkConAppCode d s p con args_r_to_l + dflags <- getDynFlags + let platform = targetPlatform dflags + return (alloc_con `appOL` + mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` + ENTER) + + -- Case 4: Tail call of function + | otherwise + = doTailCall d s p fn args_r_to_l + + where + -- Extract the args (R->L) and fn + -- The function will necessarily be a variable, + -- because we are compiling a tail call + (AnnVar fn, args_r_to_l) = splitApp app + + -- Only consider this to be a constructor application iff it is + -- saturated. Otherwise, we'll call the constructor wrapper. + n_args = length args_r_to_l + maybe_saturated_dcon + = case isDataConWorkId_maybe fn of + Just con | dataConRepArity con == n_args -> Just con + _ -> Nothing + +-- ----------------------------------------------------------------------------- +-- Generate code to build a constructor application, +-- leaving it on top of the stack + +mkConAppCode + :: StackDepth + -> Sequel + -> BCEnv + -> DataCon -- The data constructor + -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order + -> BcM BCInstrList +mkConAppCode _ _ _ con [] -- Nullary constructor + = ASSERT( isNullaryRepDataCon con ) + return (unitOL (PUSH_G (getName (dataConWorkId con)))) + -- Instead of doing a PACK, which would allocate a fresh + -- copy of this constructor, use the single shared version. + +mkConAppCode orig_d _ p con args_r_to_l = + ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code + where + app_code = do + dflags <- getDynFlags + let platform = targetPlatform dflags + + -- The args are initially in reverse order, but mkVirtHeapOffsets + -- expects them to be left-to-right. + let non_voids = + [ NonVoid (prim_rep, arg) + | arg <- reverse args_r_to_l + , let prim_rep = atomPrimRep arg + , not (isVoidRep prim_rep) + ] + (_, _, args_offsets) = + mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids + + do_pushery !d (arg : args) = do + (push, arg_bytes) <- case arg of + (Padding l _) -> return $! pushPadding l + (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !d [] = do + let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d) + return (unitOL (PACK con n_arg_words)) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args_offsets) + + +-- ----------------------------------------------------------------------------- +-- Returning an unboxed tuple with one non-void component (the only +-- case we can handle). +-- +-- Remember, we don't want to *evaluate* the component that is being +-- returned, even if it is a pointed type. We always just return. + +unboxedTupleReturn + :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg) + +-- ----------------------------------------------------------------------------- +-- Generate code for a tail-call + +doTailCall + :: StackDepth + -> Sequel + -> BCEnv + -> Id + -> [AnnExpr' Id DVarSet] + -> BcM BCInstrList +doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args) + where + do_pushes !d [] reps = do + ASSERT( null reps ) return () + (push_fn, sz) <- pushAtom d p (AnnVar fn) + dflags <- getDynFlags + let platform = targetPlatform dflags + ASSERT( sz == wordSize platform ) return () + let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s) + return (push_fn `appOL` (slide `appOL` unitOL ENTER)) + do_pushes !d args reps = do + let (push_apply, n, rest_of_reps) = findPushSeq reps + (these_args, rest_of_args) = splitAt n args + (next_d, push_code) <- push_seq d these_args + dflags <- getDynFlags + let platform = targetPlatform dflags + instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction + return (push_code `appOL` (push_apply `consOL` instrs)) + + push_seq d [] = return (d, nilOL) + push_seq d (arg:args) = do + (push_code, sz) <- pushAtom d p arg + (final_d, more_push_code) <- push_seq (d + sz) args + return (final_d, push_code `appOL` more_push_code) + +-- v. similar to CgStackery.findMatch, ToDo: merge +findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) +findPushSeq (P: P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPPP, 6, rest) +findPushSeq (P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPP, 5, rest) +findPushSeq (P: P: P: P: rest) + = (PUSH_APPLY_PPPP, 4, rest) +findPushSeq (P: P: P: rest) + = (PUSH_APPLY_PPP, 3, rest) +findPushSeq (P: P: rest) + = (PUSH_APPLY_PP, 2, rest) +findPushSeq (P: rest) + = (PUSH_APPLY_P, 1, rest) +findPushSeq (V: rest) + = (PUSH_APPLY_V, 1, rest) +findPushSeq (N: rest) + = (PUSH_APPLY_N, 1, rest) +findPushSeq (F: rest) + = (PUSH_APPLY_F, 1, rest) +findPushSeq (D: rest) + = (PUSH_APPLY_D, 1, rest) +findPushSeq (L: rest) + = (PUSH_APPLY_L, 1, rest) +findPushSeq _ + = panic "GHC.CoreToByteCode.findPushSeq" + +-- ----------------------------------------------------------------------------- +-- Case expressions + +doCase + :: StackDepth + -> Sequel + -> BCEnv + -> AnnExpr Id DVarSet + -> Id + -> [AnnAlt Id DVarSet] + -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, + -- don't enter the result + -> BcM BCInstrList +doCase d s p (_,scrut) bndr alts is_unboxed_tuple + | typePrimRep (idType bndr) `lengthExceeds` 1 + = multiValException + + | otherwise + = do + dflags <- getDynFlags + hsc_env <- getHscEnv + let + platform = targetPlatform dflags + profiling + | Just interp <- hsc_interp hsc_env + = interpreterProfiled interp + | otherwise = False + + -- Top of stack is the return itbl, as usual. + -- underneath it is the pointer to the alt_code BCO. + -- When an alt is entered, it assumes the returned value is + -- on top of the itbl. + ret_frame_size_b :: StackDepth + ret_frame_size_b = 2 * wordSize platform + + -- The extra frame we push to save/restore the CCCS when profiling + save_ccs_size_b | profiling = 2 * wordSize platform + | otherwise = 0 + + -- An unlifted value gets an extra info table pushed on top + -- when it is returned. + unlifted_itbl_size_b :: StackDepth + unlifted_itbl_size_b | isAlgCase = 0 + | otherwise = wordSize platform + + -- depth of stack after the return value has been pushed + d_bndr = + d + ret_frame_size_b + wordsToBytes platform (idSizeW platform bndr) + + -- depth of stack after the extra info table for an unboxed return + -- has been pushed, if any. This is the stack depth at the + -- continuation. + d_alts = d_bndr + unlifted_itbl_size_b + + -- Env in which to compile the alts, not including + -- any vars bound by the alts themselves + p_alts0 = Map.insert bndr d_bndr p + + p_alts = case is_unboxed_tuple of + Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0 + Nothing -> p_alts0 + + bndr_ty = idType bndr + isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple + + -- given an alt, return a discr and code for it. + codeAlt (DEFAULT, _, (_,rhs)) + = do rhs_code <- schemeE d_alts s p_alts rhs + return (NoDiscr, rhs_code) + + codeAlt alt@(_, bndrs, (_,rhs)) + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_alts s p_alts rhs + return (my_discr alt, rhs_code) + -- If an alt attempts to match on an unboxed tuple or sum, we must + -- bail out, as the bytecode compiler can't handle them. + -- (See #14608.) + | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs + = multiValException + -- algebraic alt with some binders + | otherwise = + let (tot_wds, _ptrs_wds, args_offsets) = + mkVirtHeapOffsets dflags NoHeader + [ NonVoid (bcIdPrimRep id, id) + | NonVoid id <- nonVoidIds real_bndrs + ] + size = WordOff tot_wds + + stack_bot = d_alts + wordsToBytes platform size + + -- convert offsets from Sp into offsets into the virtual stack + p' = Map.insertList + [ (arg, stack_bot - ByteOff offset) + | (NonVoid arg, offset) <- args_offsets ] + p_alts + in do + MASSERT(isAlgCase) + rhs_code <- schemeE stack_bot s p' rhs + return (my_discr alt, + unitOL (UNPACK (trunc16W size)) `appOL` rhs_code) + where + real_bndrs = filterOut isTyVar bndrs + + my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} + my_discr (DataAlt dc, _, _) + | isUnboxedTupleCon dc || isUnboxedSumCon dc + = multiValException + | otherwise + = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) + my_discr (LitAlt l, _, _) + = case l of LitNumber LitNumInt i -> DiscrI (fromInteger i) + LitNumber LitNumWord w -> DiscrW (fromInteger w) + LitFloat r -> DiscrF (fromRational r) + LitDouble r -> DiscrD (fromRational r) + LitChar i -> DiscrI (ord i) + _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) + + maybe_ncons + | not isAlgCase = Nothing + | otherwise + = case [dc | (DataAlt dc, _, _) <- alts] of + [] -> Nothing + (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) + + -- the bitmap is relative to stack depth d, i.e. before the + -- BCO, info table and return value are pushed on. + -- This bit of code is v. similar to buildLivenessMask in CgBindery, + -- except that here we build the bitmap from the known bindings of + -- things that are pointers, whereas in CgBindery the code builds the + -- bitmap from the free slots and unboxed bindings. + -- (ToDo: merge?) + -- + -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. + -- The bitmap must cover the portion of the stack up to the sequel only. + -- Previously we were building a bitmap for the whole depth (d), but we + -- really want a bitmap up to depth (d-s). This affects compilation of + -- case-of-case expressions, which is the only time we can be compiling a + -- case expression with s /= 0. + bitmap_size = trunc16W $ bytesToWords platform (d - s) + bitmap_size' :: Int + bitmap_size' = fromIntegral bitmap_size + bitmap = intsToReverseBitmap platform bitmap_size'{-size-} + (sort (filter (< bitmap_size') rel_slots)) + where + binds = Map.toList p + -- NB: unboxed tuple cases bind the scrut binder to the same offset + -- as one of the alt binders, so we have to remove any duplicates here: + rel_slots = nub $ map fromIntegral $ concatMap spread binds + spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ] + | otherwise = [] + where rel_offset = trunc16W $ bytesToWords platform (d - offset) + + alt_stuff <- mapM codeAlt alts + alt_final <- mkMultiBranch maybe_ncons alt_stuff + + let + alt_bco_name = getName bndr + alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) + 0{-no arity-} bitmap_size bitmap True{-is alts-} +-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ +-- "\n bitmap = " ++ show bitmap) $ do + + scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b) + (d + ret_frame_size_b + save_ccs_size_b) + p scrut + alt_bco' <- emitBc alt_bco + let push_alts + | isAlgCase = PUSH_ALTS alt_bco' + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty) + return (push_alts `consOL` scrut_code) + + +-- ----------------------------------------------------------------------------- +-- Deal with a CCall. + +-- Taggedly push the args onto the stack R->L, +-- deferencing ForeignObj#s and adjusting addrs to point to +-- payloads in Ptr/Byte arrays. Then, generate the marshalling +-- (machine) code for the ccall, and create bytecodes to call that and +-- then return in the right way. + +generateCCall + :: StackDepth + -> Sequel + -> BCEnv + -> CCallSpec -- where to call + -> Id -- of target, for type info + -> [AnnExpr' Id DVarSet] -- args (atoms) + -> BcM BCInstrList +generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l + = do + dflags <- getDynFlags + + let + platform = targetPlatform dflags + -- useful constants + addr_size_b :: ByteOff + addr_size_b = wordSize platform + + -- Get the args on the stack, with tags and suitably + -- dereferenced for the CCall. For each arg, return the + -- depth to the first word of the bits for that arg, and the + -- ArgRep of what was actually pushed. + + pargs + :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)] + pargs _ [] = return [] + pargs d (a:az) + = let arg_ty = unwrapType (exprType (deAnnotate' a)) + + in case tyConAppTyCon_maybe arg_ty of + -- Don't push the FO; instead push the Addr# it + -- contains. + Just t + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + -> do rest <- pargs (d + addr_size_b) az + code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon + -> do rest <- pargs (d + addr_size_b) az + code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + -> do rest <- pargs (d + addr_size_b) az + code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + -- Default case: push taggedly, but otherwise intact. + _ + -> do (code_a, sz_a) <- pushAtom d p a + rest <- pargs (d + sz_a) az + return ((code_a, atomPrimRep a) : rest) + + -- Do magic for Ptr/Byte arrays. Push a ptr to the array on + -- the stack but then advance it over the headers, so as to + -- point to the payload. + parg_ArrayishRep + :: Word16 + -> StackDepth + -> BCEnv + -> AnnExpr' Id DVarSet + -> BcM BCInstrList + parg_ArrayishRep hdrSize d p a + = do (push_fo, _) <- pushAtom d p a + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr#. + return (push_fo `snocOL` SWIZZLE 0 hdrSize) + + code_n_reps <- pargs d0 args_r_to_l + let + (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps + a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l) + + push_args = concatOL pushs_arg + !d_after_args = d0 + wordsToBytes platform a_reps_sizeW + a_reps_pushed_RAW + | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l)) + = panic "GHC.CoreToByteCode.generateCCall: missing or invalid World token?" + | otherwise + = reverse (tail a_reps_pushed_r_to_l) + + -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. + -- push_args is the code to do that. + -- d_after_args is the stack depth once the args are on. + + -- Get the result rep. + (returns_void, r_rep) + = case maybe_getCCallReturnRep (idType fn) of + Nothing -> (True, VoidRep) + Just rr -> (False, rr) + {- + Because the Haskell stack grows down, the a_reps refer to + lowest to highest addresses in that order. The args for the call + are on the stack. Now push an unboxed Addr# indicating + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the + Addr# just pushed, and a literal field holding the mallocville + address of the piece of marshalling code we generate. + So, just prior to the CCALL insn, the stack looks like this + (growing down, as usual): + + + ... + + Addr# address_of_C_fn + (must be an unboxed type) + + The interpreter then calls the marshall code mentioned + in the CCALL insn, passing it (& ), + that is, the addr of the topmost word in the stack. + When this returns, the placeholder will have been + filled in. The placeholder is slid down to the sequel + depth, and we RETURN. + + This arrangement makes it simple to do f-i-dynamic since the Addr# + value is the first arg anyway. + + The marshalling code is generated specifically for this + call site, and so knows exactly the (Haskell) stack + offsets of the args, fn address and placeholder. It + copies the args to the C stack, calls the stacked addr, + and parks the result back in the placeholder. The interpreter + calls it as a normal C call, assuming it has a signature + void marshall_code ( StgWord* ptr_to_top_of_stack ) + -} + -- resolve static address + maybe_static_target :: Maybe Literal + maybe_static_target = + case target of + DynamicTarget -> Nothing + StaticTarget _ _ _ False -> + panic "generateCCall: unexpected FFI value import" + StaticTarget _ target _ True -> + Just (LitLabel target mb_size IsFunction) + where + mb_size + | OSMinGW32 <- platformOS platform + , StdCallConv <- cconv + = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform) + | otherwise + = Nothing + + let + is_static = isJust maybe_static_target + + -- Get the arg reps, zapping the leading Addr# in the dynamic case + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + | is_static = a_reps_pushed_RAW + | otherwise = if null a_reps_pushed_RAW + then panic "GHC.CoreToByteCode.generateCCall: dyn with no args" + else tail a_reps_pushed_RAW + + -- push the Addr# + (push_Addr, d_after_Addr) + | Just machlabel <- maybe_static_target + = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a V (tag). + r_sizeW = repSizeWords platform r_rep + d_after_r = d_after_Addr + wordsToBytes platform r_sizeW + push_r = + if returns_void + then nilOL + else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW)) + + -- generate the marshalling code we're going to call + + -- Offset of the next stack frame down the stack. The CCALL + -- instruction needs to describe the chunk of stack containing + -- the ccall args to the GC, so it needs to know how large it + -- is. See comment in Interpreter.c with the CCALL instruction. + stk_offset = trunc16W $ bytesToWords platform (d_after_r - s) + + conv = case cconv of + CCallConv -> FFICCall + StdCallConv -> FFIStdCall + _ -> panic "GHC.CoreToByteCode: unexpected calling convention" + + -- the only difference in libffi mode is that we prepare a cif + -- describing the call type by calling libffi, and we attach the + -- address of this to the CCALL instruction. + + + let ffires = primRepToFFIType platform r_rep + ffiargs = map (primRepToFFIType platform) a_reps + hsc_env <- getHscEnv + token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires) + recordFFIBc token + + let + -- do the call + do_call = unitOL (CCALL stk_offset token flags) + where flags = case safety of + PlaySafe -> 0x0 + PlayInterruptible -> 0x1 + PlayRisky -> 0x2 + + -- slide and return + d_after_r_min_s = bytesToWords platform (d_after_r - s) + wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW) + `snocOL` RETURN_UBX (toArgRep r_rep) + --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ + return ( + push_args `appOL` + push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup + ) + +primRepToFFIType :: Platform -> PrimRep -> FFIType +primRepToFFIType platform r + = case r of + VoidRep -> FFIVoid + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> FFISInt64 + Word64Rep -> FFIUInt64 + AddrRep -> FFIPointer + FloatRep -> FFIFloat + DoubleRep -> FFIDouble + _ -> panic "primRepToFFIType" + where + (signed_word, unsigned_word) = case platformWordSize platform of + PW4 -> (FFISInt32, FFIUInt32) + PW8 -> (FFISInt64, FFIUInt64) + +-- Make a dummy literal, to be used as a placeholder for FFI return +-- values on the stack. +mkDummyLiteral :: Platform -> PrimRep -> Literal +mkDummyLiteral platform pr + = case pr of + IntRep -> mkLitInt platform 0 + WordRep -> mkLitWord platform 0 + Int64Rep -> mkLitInt64 0 + Word64Rep -> mkLitWord64 0 + AddrRep -> LitNullAddr + DoubleRep -> LitDouble 0 + FloatRep -> LitFloat 0 + _ -> pprPanic "mkDummyLiteral" (ppr pr) + + +-- Convert (eg) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) +-- +-- to Just IntRep +-- and check that an unboxed pair is returned wherein the first arg is V'd. +-- +-- Alternatively, for call-targets returning nothing, convert +-- +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) +-- +-- to Nothing + +maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep fn_ty + = let + (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) + r_reps = typePrimRepArgs r_ty + + blargh :: a -- Used at more than one type + blargh = pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) + in + case r_reps of + [] -> panic "empty typePrimRepArgs" + [VoidRep] -> Nothing + [rep] + | isGcPtrRep rep -> blargh + | otherwise -> Just rep + + -- if it was, it would be impossible to create a + -- valid return value placeholder on the stack + _ -> blargh + +maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) +-- Detect and extract relevant info for the tagToEnum kludge. +maybe_is_tagToEnum_call app + | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app + , Just TagToEnumOp <- isPrimOpId_maybe v + = Just (snd arg, extract_constr_Names t) + | otherwise + = Nothing + where + extract_constr_Names ty + | rep_ty <- unwrapType ty + , Just tyc <- tyConAppTyCon_maybe rep_ty + , isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See "GHC.Core.DataCon" for details. + | otherwise + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) + +{- ----------------------------------------------------------------------------- +Note [Implementing tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(implement_tagToId arg names) compiles code which takes an argument +'arg', (call it i), and enters the i'th closure in the supplied list +as a consequence. The [Name] is a list of the constructors of this +(enumeration) type. + +The code we generate is this: + push arg + push bogus-word + + TESTEQ_I 0 L1 + PUSH_G + JMP L_Exit + + L1: TESTEQ_I 1 L2 + PUSH_G + JMP L_Exit + ...etc... + Ln: TESTEQ_I n L_fail + PUSH_G + JMP L_Exit + + L_fail: CASEFAIL + + L_exit: SLIDE 1 n + ENTER + +The 'bogus-word' push is because TESTEQ_I expects the top of the stack +to have an info-table, and the next word to have the value to be +tested. This is very weird, but it's the way it is right now. See +Interpreter.c. We don't actually need an info-table here; we just +need to have the argument to be one-from-top on the stack, hence pushing +a 1-word null. See #8383. +-} + + +implement_tagToId + :: StackDepth + -> Sequel + -> BCEnv + -> AnnExpr' Id DVarSet + -> [Name] + -> BcM BCInstrList +-- See Note [Implementing tagToEnum#] +implement_tagToId d s p arg names + = ASSERT( notNull names ) + do (push_arg, arg_bytes) <- pushAtom d p arg + labels <- getLabelsBc (genericLength names) + label_fail <- getLabelBc + label_exit <- getLabelBc + dflags <- getDynFlags + let infos = zip4 labels (tail labels ++ [label_fail]) + [0 ..] names + platform = targetPlatform dflags + steps = map (mkStep label_exit) infos + slide_ws = bytesToWords platform (d - s + arg_bytes) + + return (push_arg + `appOL` unitOL (PUSH_UBX LitNullAddr 1) + -- Push bogus word (see Note [Implementing tagToEnum#]) + `appOL` concatOL steps + `appOL` toOL [ LABEL label_fail, CASEFAIL, + LABEL label_exit ] + `appOL` mkSlideW 1 (slide_ws + 1) + -- "+1" to account for bogus word + -- (see Note [Implementing tagToEnum#]) + `appOL` unitOL ENTER) + where + mkStep l_exit (my_label, next_label, n, name_for_n) + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G name_for_n, + JMP l_exit] + + +-- ----------------------------------------------------------------------------- +-- pushAtom + +-- Push an atom onto the stack, returning suitable code & number of +-- stack words used. +-- +-- The env p must map each variable to the highest- numbered stack +-- slot for it. For example, if the stack has depth 4 and we +-- tagged-ly push (v :: Int#) on it, the value will be in stack[4], +-- the tag in stack[5], the stack will have depth 6, and p must map v +-- to 5 and not to 4. Stack locations are numbered from zero, so a +-- depth 6 stack has valid words 0 .. 5. + +pushAtom + :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) +pushAtom d p e + | Just e' <- bcView e + = pushAtom d p e' + +pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, + = return (nilOL, 0) -- treated just like a variable V + +-- See Note [Empty case alternatives] in GHC.Core +-- and Note [Bottoming expressions] in GHC.Core.Utils: +-- The scrutinee of an empty case evaluates to bottom +pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 + = pushAtom d p a + +pushAtom d p (AnnVar var) + | [] <- typePrimRep (idType var) + = return (nilOL, 0) + + | isFCallId var + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var) + + | Just primop <- isPrimOpId_maybe var + = do + platform <- targetPlatform <$> getDynFlags + return (unitOL (PUSH_PRIMOP primop), wordSize platform) + + | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable + = do platform <- targetPlatform <$> getDynFlags + + let !szb = idSizeCon platform var + with_instr instr = do + let !off_b = trunc16B $ d - d_v + return (unitOL (instr off_b), wordSize platform) + + case szb of + 1 -> with_instr PUSH8_W + 2 -> with_instr PUSH16_W + 4 -> with_instr PUSH32_W + _ -> do + let !szw = bytesToWords platform szb + !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1 + return (toOL (genericReplicate szw (PUSH_L off_w)), szb) + -- d - d_v offset from TOS to the first slot of the object + -- + -- d - d_v + sz - 1 offset from the TOS of the last slot of the object + -- + -- Having found the last slot, we proceed to copy the right number of + -- slots on to the top of the stack. + + | otherwise -- var must be a global variable + = do topStrings <- getTopStrings + platform <- targetPlatform <$> getDynFlags + case lookupVarEnv topStrings var of + Just ptr -> pushAtom d p $ AnnLit $ mkLitWord platform $ + fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr + Nothing -> do + let sz = idSizeCon platform var + MASSERT( sz == wordSize platform ) + return (unitOL (PUSH_G (getName var)), sz) + + +pushAtom _ _ (AnnLit lit) = do + platform <- targetPlatform <$> getDynFlags + let code rep + = let size_words = WordOff (argRepSizeW platform rep) + in return (unitOL (PUSH_UBX lit (trunc16W size_words)), + wordsToBytes platform size_words) + + case lit of + LitLabel _ _ _ -> code N + LitFloat _ -> code F + LitDouble _ -> code D + LitChar _ -> code N + LitNullAddr -> code N + LitString _ -> code N + LitRubbish -> code N + LitNumber nt _ -> case nt of + LitNumInt -> code N + LitNumWord -> code N + LitNumInt64 -> code L + LitNumWord64 -> code L + -- No LitInteger's or LitNatural's should be left by the time this is + -- called. CorePrep should have converted them all to a real core + -- representation. + LitNumInteger -> panic "pushAtom: LitInteger" + LitNumNatural -> panic "pushAtom: LitNatural" + +pushAtom _ _ expr + = pprPanic "GHC.CoreToByteCode.pushAtom" + (pprCoreExpr (deAnnotate' expr)) + + +-- | Push an atom for constructor (i.e., PACK instruction) onto the stack. +-- This is slightly different to @pushAtom@ due to the fact that we allow +-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. +pushConstrAtom + :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) + +pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) = + return (unitOL (PUSH_UBX32 lit), 4) + +pushConstrAtom d p (AnnVar v) + | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable + platform <- targetPlatform <$> getDynFlags + let !szb = idSizeCon platform v + done instr = do + let !off = trunc16B $ d - d_v + return (unitOL (instr off), szb) + case szb of + 1 -> done PUSH8 + 2 -> done PUSH16 + 4 -> done PUSH32 + _ -> pushAtom d p (AnnVar v) + +pushConstrAtom d p expr = pushAtom d p expr + +pushPadding :: Int -> (BCInstrList, ByteOff) +pushPadding !n = go n (nilOL, 0) + where + go n acc@(!instrs, !off) = case n of + 0 -> acc + 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1) + 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2) + 3 -> go 1 (go 2 acc) + 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4) + _ -> go (n - 4) (go 4 acc) + +-- ----------------------------------------------------------------------------- +-- Given a bunch of alts code and their discrs, do the donkey work +-- of making a multiway branch using a switch tree. +-- What a load of hassle! + +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt + -- a hint; generates better code + -- Nothing is always safe + -> [(Discr, BCInstrList)] + -> BcM BCInstrList +mkMultiBranch maybe_ncons raw_ways = do + lbl_default <- getLabelBc + + let + mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList + mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) + -- shouldn't happen? + + mkTree [val] range_lo range_hi + | range_lo == range_hi + = return (snd val) + | null defaults -- Note [CASEFAIL] + = do lbl <- getLabelBc + return (testEQ (fst val) lbl + `consOL` (snd val + `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) + | otherwise + = return (testEQ (fst val) lbl_default `consOL` snd val) + + -- Note [CASEFAIL] It may be that this case has no default + -- branch, but the alternatives are not exhaustive - this + -- happens for GADT cases for example, where the types + -- prove that certain branches are impossible. We could + -- just assume that the other cases won't occur, but if + -- this assumption was wrong (because of a bug in GHC) + -- then the result would be a segfault. So instead we + -- emit an explicit test and a CASEFAIL instruction that + -- causes the interpreter to barf() if it is ever + -- executed. + + mkTree vals range_lo range_hi + = let n = length vals `div` 2 + vals_lo = take n vals + vals_hi = drop n vals + v_mid = fst (head vals_hi) + in do + label_geq <- getLabelBc + code_lo <- mkTree vals_lo range_lo (dec v_mid) + code_hi <- mkTree vals_hi v_mid range_hi + return (testLT v_mid label_geq + `consOL` (code_lo + `appOL` unitOL (LABEL label_geq) + `appOL` code_hi)) + + the_default + = case defaults of + [] -> nilOL + [(_, def)] -> LABEL lbl_default `consOL` def + _ -> panic "mkMultiBranch/the_default" + instrs <- mkTree notd_ways init_lo init_hi + return (instrs `appOL` the_default) + where + (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways + notd_ways = sortBy (comparing fst) not_defaults + + testLT (DiscrI i) fail_label = TESTLT_I i fail_label + testLT (DiscrW i) fail_label = TESTLT_W i fail_label + testLT (DiscrF i) fail_label = TESTLT_F i fail_label + testLT (DiscrD i) fail_label = TESTLT_D i fail_label + testLT (DiscrP i) fail_label = TESTLT_P i fail_label + testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" + + testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label + testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label + testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label + testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label + testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label + testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" + + -- None of these will be needed if there are no non-default alts + (init_lo, init_hi) + | null notd_ways + = panic "mkMultiBranch: awesome foursome" + | otherwise + = case fst (head notd_ways) of + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" + + (algMinBound, algMaxBound) + = case maybe_ncons of + -- XXX What happens when n == 0? + Just n -> (0, fromIntegral n - 1) + Nothing -> (minBound, maxBound) + + isNoDiscr NoDiscr = True + isNoDiscr _ = False + + dec (DiscrI i) = DiscrI (i-1) + dec (DiscrW w) = DiscrW (w-1) + dec (DiscrP i) = DiscrP (i-1) + dec other = other -- not really right, but if you + -- do cases on floating values, you'll get what you deserve + + -- same snotty comment applies to the following + minF, maxF :: Float + minD, maxD :: Double + minF = -1.0e37 + maxF = 1.0e37 + minD = -1.0e308 + maxD = 1.0e308 + + +-- ----------------------------------------------------------------------------- +-- Supporting junk for the compilation schemes + +-- Describes case alts +data Discr + = DiscrI Int + | DiscrW Word + | DiscrF Float + | DiscrD Double + | DiscrP Word16 + | NoDiscr + deriving (Eq, Ord) + +instance Outputable Discr where + ppr (DiscrI i) = int i + ppr (DiscrW w) = text (show w) + ppr (DiscrF f) = text (show f) + ppr (DiscrD d) = text (show d) + ppr (DiscrP i) = ppr i + ppr NoDiscr = text "DEF" + + +lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff +lookupBCEnv_maybe = Map.lookup + +idSizeW :: Platform -> Id -> WordOff +idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep + +idSizeCon :: Platform -> Id -> ByteOff +idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep + +bcIdArgRep :: Id -> ArgRep +bcIdArgRep = toArgRep . bcIdPrimRep + +bcIdPrimRep :: Id -> PrimRep +bcIdPrimRep id + | [rep] <- typePrimRepArgs (idType id) + = rep + | otherwise + = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) + +repSizeWords :: Platform -> PrimRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep) + +isFollowableArg :: ArgRep -> Bool +isFollowableArg P = True +isFollowableArg _ = False + +isVoidArg :: ArgRep -> Bool +isVoidArg V = True +isVoidArg _ = False + +-- See bug #1257 +multiValException :: a +multiValException = throwGhcException (ProgramError + ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++ + " Possibly due to foreign import/export decls in source.\n"++ + " Workaround: use -fobject-code, or compile this module to .o separately.")) + +-- | Indicate if the calling convention is supported +isSupportedCConv :: CCallSpec -> Bool +isSupportedCConv (CCallSpec _ cconv _) = case cconv of + CCallConv -> True -- we explicitly pattern match on every + StdCallConv -> True -- convention to ensure that a warning + PrimCallConv -> False -- is triggered when a new one is added + JavaScriptCallConv -> False + CApiConv -> False + +-- See bug #10462 +unsupportedCConvException :: a +unsupportedCConvException = throwGhcException (ProgramError + ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ + " Workaround: use -fobject-code, or compile this module to .o separately.")) + +mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr +mkSlideB platform !nb !db = mkSlideW n d + where + !n = trunc16W $ bytesToWords platform nb + !d = bytesToWords platform db + +mkSlideW :: Word16 -> WordOff -> OrdList BCInstr +mkSlideW !n !ws + | ws > fromIntegral limit + -- If the amount to slide doesn't fit in a Word16, generate multiple slide + -- instructions + = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit) + | ws == 0 + = nilOL + | otherwise + = unitOL (SLIDE n $ fromIntegral ws) + where + limit :: Word16 + limit = maxBound + +splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) + -- The arguments are returned in *right-to-left* order +splitApp e | Just e' <- bcView e = splitApp e' +splitApp (AnnApp (_,f) (_,a)) = case splitApp f of + (f', as) -> (f', a:as) +splitApp e = (e, []) + + +bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) +-- The "bytecode view" of a term discards +-- a) type abstractions +-- b) type applications +-- c) casts +-- d) ticks (but not breakpoints) +-- e) case unsafeEqualityProof of UnsafeRefl -> e ==> e +-- Type lambdas *can* occur in random expressions, +-- whereas value lambdas cannot; that is why they are nuked here +bcView (AnnCast (_,e) _) = Just e +bcView (AnnLam v (_,e)) | isTyVar v = Just e +bcView (AnnApp (_,e) (_, AnnType _)) = Just e +bcView (AnnTick Breakpoint{} _) = Nothing +bcView (AnnTick _other_tick (_,e)) = Just e +bcView (AnnCase (_,e) _ _ alts) -- Handle unsafe equality proof + | AnnVar id <- bcViewLoop e + , idName id == unsafeEqualityProofName + , [(_, _, (_, rhs))] <- alts + = Just rhs +bcView _ = Nothing + +bcViewLoop :: AnnExpr' Var ann -> AnnExpr' Var ann +bcViewLoop e = + case bcView e of + Nothing -> e + Just e' -> bcViewLoop e' + +isVAtom :: AnnExpr' Var ann -> Bool +isVAtom e | Just e' <- bcView e = isVAtom e' +isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) +isVAtom (AnnCoercion {}) = True +isVAtom _ = False + +atomPrimRep :: AnnExpr' Id ann -> PrimRep +atomPrimRep e | Just e' <- bcView e = atomPrimRep e' +atomPrimRep (AnnVar v) = bcIdPrimRep v +atomPrimRep (AnnLit l) = typePrimRep1 (literalType l) + +-- #12128: +-- A case expression can be an atom because empty cases evaluate to bottom. +-- See Note [Empty case alternatives] in GHC.Core +atomPrimRep (AnnCase _ _ ty _) = + ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep +atomPrimRep (AnnCoercion {}) = VoidRep +atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) + +atomRep :: AnnExpr' Id ann -> ArgRep +atomRep e = toArgRep (atomPrimRep e) + +-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which +-- has initial depth @original_depth@. Return the values which the stack +-- environment should map these items to. +mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] +mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) + +typeArgRep :: Type -> ArgRep +typeArgRep = toArgRep . typePrimRep1 + +-- ----------------------------------------------------------------------------- +-- The bytecode generator's monad + +data BcM_State + = BcM_State + { bcm_hsc_env :: HscEnv + , uniqSupply :: UniqSupply -- for generating fresh variable names + , thisModule :: Module -- current module (for breakpoints) + , nextlabel :: Word16 -- for generating local labels + , ffis :: [FFIInfo] -- ffi info blocks, to free later + -- Should be free()d when it is GCd + , modBreaks :: Maybe ModBreaks -- info about breakpoints + , breakInfo :: IntMap CgBreakInfo + , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals + -- See Note [generating code for top-level string literal bindings]. + } + +newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) + +ioToBc :: IO a -> BcM a +ioToBc io = BcM $ \st -> do + x <- io + return (st, x) + +runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks + -> IdEnv (RemotePtr ()) + -> BcM r + -> IO (BcM_State, r) +runBc hsc_env us this_mod modBreaks topStrings (BcM m) + = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings) + +thenBc :: BcM a -> (a -> BcM b) -> BcM b +thenBc (BcM expr) cont = BcM $ \st0 -> do + (st1, q) <- expr st0 + let BcM k = cont q + (st2, r) <- k st1 + return (st2, r) + +thenBc_ :: BcM a -> BcM b -> BcM b +thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do + (st1, _) <- expr st0 + (st2, r) <- cont st1 + return (st2, r) + +returnBc :: a -> BcM a +returnBc result = BcM $ \st -> (return (st, result)) + +instance Applicative BcM where + pure = returnBc + (<*>) = ap + (*>) = thenBc_ + +instance Monad BcM where + (>>=) = thenBc + (>>) = (*>) + +instance HasDynFlags BcM where + getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) + +getHscEnv :: BcM HscEnv +getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) + +emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) +emitBc bco + = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) + +recordFFIBc :: RemotePtr C_ffi_cif -> BcM () +recordFFIBc a + = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) + +getLabelBc :: BcM Word16 +getLabelBc + = BcM $ \st -> do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (st{nextlabel = nl + 1}, nl) + +getLabelsBc :: Word16 -> BcM [Word16] +getLabelsBc n + = BcM $ \st -> let ctr = nextlabel st + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) + +getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre)) +getCCArray = BcM $ \st -> + let breaks = expectJust "GHC.CoreToByteCode.getCCArray" $ modBreaks st in + return (st, modBreaks_ccs breaks) + + +newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM () +newBreakInfo ix info = BcM $ \st -> + return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) + +newUnique :: BcM Unique +newUnique = BcM $ + \st -> case takeUniqFromSupply (uniqSupply st) of + (uniq, us) -> let newState = st { uniqSupply = us } + in return (newState, uniq) + +getCurrentModule :: BcM Module +getCurrentModule = BcM $ \st -> return (st, thisModule st) + +getTopStrings :: BcM (IdEnv (RemotePtr ())) +getTopStrings = BcM $ \st -> return (st, topStrings st) + +newId :: Type -> BcM Id +newId ty = do + uniq <- newUnique + return $ mkSysLocal tickFS uniq Many ty + +tickFS :: FastString +tickFS = fsLit "ticked" diff --git a/GHC/CoreToIface.hs b/GHC/CoreToIface.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToIface.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] + +-- | Functions for converting Core things to interface file things. +module GHC.CoreToIface + ( -- * Binders + toIfaceTvBndr + , toIfaceTvBndrs + , toIfaceIdBndr + , toIfaceBndr + , toIfaceForAllBndr + , toIfaceTyCoVarBinders + , toIfaceTyVar + -- * Types + , toIfaceType, toIfaceTypeX + , toIfaceKind + , toIfaceTcArgs + , toIfaceTyCon + , toIfaceTyCon_name + , toIfaceTyLit + -- * Tidying types + , tidyToIfaceType + , tidyToIfaceContext + , tidyToIfaceTcArgs + -- * Coercions + , toIfaceCoercion, toIfaceCoercionX + -- * Pattern synonyms + , patSynToIfaceDecl + -- * Expressions + , toIfaceExpr + , toIfaceBang + , toIfaceSrcBang + , toIfaceLetBndr + , toIfaceIdDetails + , toIfaceIdInfo + , toIfUnfolding + , toIfaceTickish + , toIfaceBind + , toIfaceAlt + , toIfaceCon + , toIfaceApp + , toIfaceVar + -- * Other stuff + , toIfaceLFInfo + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Iface.Syntax +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.StgToCmm.Types +import GHC.Core +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom +import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon ) +import GHC.Builtin.Types ( heqTyCon ) +import GHC.Types.Id.Make ( noinlineIdName ) +import GHC.Builtin.Names +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.PatSyn +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy ( tidyCo ) +import GHC.Types.Demand ( isTopSig ) +import GHC.Types.Cpr ( topCprSig ) + +import Data.Maybe ( catMaybes ) + +{- Note [Avoiding space leaks in toIface*] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Building a interface file depends on the output of the simplifier. +If we build these lazily this would mean keeping the Core AST alive +much longer than necessary causing a space "leak". + +This happens for example when we only write the interface file to disk +after code gen has run, in which case we might carry megabytes of core +AST in the heap which is no longer needed. + +We avoid this in two ways. +* First we use -XStrict in GHC.CoreToIface which avoids many thunks + to begin with. +* Second we define NFData instance for Iface syntax and use them to + force any remaining thunks. + +-XStrict is not sufficient as patterns of the form `f (g x)` would still +result in a thunk being allocated for `g x`. + +NFData is sufficient for the space leak, but using -XStrict reduces allocation +by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370). +It's essentially free performance hence we use -XStrict on top of NFData. + +MR !1633 on gitlab, has more discussion on the topic. +-} + +---------------- +toIfaceTvBndr :: TyVar -> IfaceTvBndr +toIfaceTvBndr = toIfaceTvBndrX emptyVarSet + +toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr +toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) + , toIfaceTypeX fr (tyVarKind tyvar) + ) + +toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] +toIfaceTvBndrs = map toIfaceTvBndr + +toIfaceIdBndr :: Id -> IfaceIdBndr +toIfaceIdBndr = toIfaceIdBndrX emptyVarSet + +toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr +toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar) + , occNameFS (getOccName covar) + , toIfaceTypeX fr (varType covar) + ) + +toIfaceBndr :: Var -> IfaceBndr +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) + | otherwise = IfaceTvBndr (toIfaceTvBndr var) + +toIfaceBndrX :: VarSet -> Var -> IfaceBndr +toIfaceBndrX fr var + | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) + | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) + +toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis +toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis + +toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] +toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder + +{- +************************************************************************ +* * + Conversion from Type to IfaceType +* * +************************************************************************ +-} + +toIfaceKind :: Type -> IfaceType +toIfaceKind = toIfaceType + +--------------------- +toIfaceType :: Type -> IfaceType +toIfaceType = toIfaceTypeX emptyVarSet + +toIfaceTypeX :: VarSet -> Type -> IfaceType +-- (toIfaceTypeX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +-- +-- Synonyms are retained in the interface type +toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in GHC.Iface.Type + | tv `elemVarSet` fr = IfaceFreeTyVar tv + | otherwise = IfaceTyVar (toIfaceTyVar tv) +toIfaceTypeX fr ty@(AppTy {}) = + -- Flatten as many argument AppTys as possible, then turn them into an + -- IfaceAppArgs list. + -- See Note [Suppressing invisible arguments] in GHC.Iface.Type. + let (head, args) = splitAppTys ty + in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args) +toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) +toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) + (toIfaceTypeX (fr `delVarSet` binderVar b) t) +toIfaceTypeX fr (FunTy { ft_arg = t1, ft_mult = w, ft_res = t2, ft_af = af }) + = IfaceFunTy af (toIfaceTypeX fr w) (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) +toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) +toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) + +toIfaceTypeX fr (TyConApp tc tys) + -- tuples + | Just sort <- tyConTuple_maybe tc + , n_tys == arity + = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys) + + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , n_tys == 2*arity + = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) + + | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] + , (k1:k2:_) <- tys + = let info = IfaceTyConInfo NotPromoted sort + sort | k1 `eqType` k2 = IfaceEqualityTyCon + | otherwise = IfaceNormalTyCon + in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) + + -- other applications + | otherwise + = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys) + where + arity = tyConArity tc + n_tys = length tys + +toIfaceTyVar :: TyVar -> FastString +toIfaceTyVar = occNameFS . getOccName + +toIfaceCoVar :: CoVar -> FastString +toIfaceCoVar = occNameFS . getOccName + +toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet + +toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis + +---------------- +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc + = IfaceTyCon tc_name info + where + tc_name = tyConName tc + info = IfaceTyConInfo promoted sort + promoted | isPromotedDataCon tc = IsPromoted + | otherwise = NotPromoted + + tupleSort :: TyCon -> Maybe IfaceTyConSort + tupleSort tc' = + case tyConTuple_maybe tc' of + Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 + in Just $ IfaceTupleTyCon arity UnboxedTuple + Just sort -> let arity = tyConArity tc' + in Just $ IfaceTupleTyCon arity sort + Nothing -> Nothing + + sort + | Just tsort <- tupleSort tc = tsort + + | Just dcon <- isPromotedDataCon_maybe tc + , let tc' = dataConTyCon dcon + , Just tsort <- tupleSort tc' = tsort + + | isUnboxedSumTyCon tc + , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) + + | otherwise = IfaceNormalTyCon + + +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name n = IfaceTyCon n info + where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon + -- Used for the "rough-match" tycon stuff, + -- where pretty-printing is not an issue + +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x + +---------------- +toIfaceCoercion :: Coercion -> IfaceCoercion +toIfaceCoercion = toIfaceCoercionX emptyVarSet + +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +-- (toIfaceCoercionX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +toIfaceCoercionX fr co + = go co + where + go_mco MRefl = IfaceMRefl + go_mco (MCo co) = IfaceMCo $ go co + + go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) + go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) + go (CoVarCo cv) + -- See [TcTyVars in IfaceType] in GHC.Iface.Type + | cv `elemVarSet` fr = IfaceFreeCoVar cv + | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) + + go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) + go (SymCo co) = IfaceSymCo (go co) + go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) + go (NthCo _r d co) = IfaceNthCo d (go co) + go (LRCo lr co) = IfaceLRCo lr (go co) + go (InstCo co arg) = IfaceInstCo (go co) (go arg) + go (KindCo c) = IfaceKindCo (go c) + go (SubCo co) = IfaceSubCo (go co) + go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) + go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) + go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r + (toIfaceTypeX fr t1) + (toIfaceTypeX fr t2) + go (TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [_,_,_,_, _] <- cos = pprPanic "toIfaceCoercion" empty + | otherwise = + IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) + go (FunCo r w co1 co2) = IfaceFunCo r (go w) (go co1) (go co2) + + go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) + (toIfaceCoercionX fr' k) + (toIfaceCoercionX fr' co) + where + fr' = fr `delVarSet` tv + + go_prov :: UnivCoProvenance -> IfaceUnivCoProv + go_prov (PhantomProv co) = IfacePhantomProv (go co) + go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) + go_prov (PluginProv str) = IfacePluginProv str + go_prov CorePrepProv = pprPanic "toIfaceCoercionX" empty + -- CorePrepProv only happens after the iface file is generated + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgs = toIfaceTcArgsX emptyVarSet + +toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args + +toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs +toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args + +toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs +-- See Note [Suppressing invisible arguments] in GHC.Iface.Type +-- We produce a result list of args describing visibility +-- The awkward case is +-- T :: forall k. * -> k +-- And consider +-- T (forall j. blah) * blib +-- Is 'blib' visible? It depends on the visibility flag on j, +-- so we have to substitute for k. Annoying! +toIfaceAppArgsX fr kind ty_args + = go (mkEmptyTCvSubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = IA_Nil + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + = IA_Arg t' vis ts' + where + t' = toIfaceTypeX fr t + ts' = go (extendTCvSubst env tv t) res ts + + go env (FunTy { ft_af = af, ft_res = res }) (t:ts) + = IA_Arg (toIfaceTypeX fr t) argf (go env res ts) + where + argf = case af of + VisArg -> Required + InvisArg -> Inferred + -- It's rare for a kind to have a constraint argument, but + -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon. + + go env ty ts@(t1:ts1) + | not (isEmptyTCvSubst env) + = go (zapTCvSubst env) (substTy env ty) ts + -- See Note [Care with kind instantiation] in GHC.Core.Type + + | otherwise + = -- There's a kind error in the type we are trying to print + -- e.g. kind = k, ty_args = [Int] + -- This is probably a compiler bug, so we print a trace and + -- carry on as if it were FunTy. Without the test for + -- isEmptyTCvSubst we'd get an infinite loop (#15473) + WARN( True, ppr kind $$ ppr ty_args ) + IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) + +tidyToIfaceType :: TidyEnv -> Type -> IfaceType +tidyToIfaceType env ty = toIfaceType (tidyType env ty) + +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs +tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) + +tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext +tidyToIfaceContext env theta = map (tidyToIfaceType env) theta + +{- +************************************************************************ +* * + Conversion of pattern synonyms +* * +************************************************************************ +-} + +patSynToIfaceDecl :: PatSyn -> IfaceDecl +patSynToIfaceDecl ps + = IfacePatSyn { ifName = getName $ ps + , ifPatMatcher = to_if_pr (patSynMatcher ps) + , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) + , ifPatIsInfix = patSynIsInfix ps + , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' + , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' + , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta + , ifPatReqCtxt = tidyToIfaceContext env2 req_theta + , ifPatArgs = map (tidyToIfaceType env2 . scaledThing) args + , ifPatTy = tidyToIfaceType env2 rhs_ty + , ifFieldLabels = (patSynFieldLabels ps) + } + where + (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps + univ_bndrs = patSynUnivTyVarBinders ps + ex_bndrs = patSynExTyVarBinders ps + (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs + to_if_pr (id, needs_dummy) = (idName id, needs_dummy) + +{- +************************************************************************ +* * + Conversion of other things +* * +************************************************************************ +-} + +toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang +toIfaceBang _ HsLazy = IfNoBang +toIfaceBang _ (HsUnpack Nothing) = IfUnpack +toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) +toIfaceBang _ HsStrict = IfStrict + +toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang +toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang + +toIfaceLetBndr :: Id -> IfaceLetBndr +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) + (toIfaceJoinInfo (isJoinId_maybe id)) + -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr + -- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax + +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = + let iface = case tc of + RecSelData ty_con -> Left (toIfaceTyCon ty_con) + RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) + in IfRecSelId iface n + + -- The remaining cases are all "implicit Ids" which don't + -- appear in interface files at all +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected; the other + +toIfaceIdInfo :: IdInfo -> IfaceIdInfo +toIfaceIdInfo id_info + = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo, + inline_hsinfo, unfold_hsinfo, levity_hsinfo] + -- NB: strictness and arity must appear in the list before unfolding + -- See GHC.IfaceToCore.tcUnfolding + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_info + caf_hsinfo = case caf_info of + NoCafRefs -> Just HsNoCafRefs + _other -> Nothing + + ------------ Strictness -------------- + -- No point in explicitly exporting TopSig + sig_info = strictnessInfo id_info + strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) + | otherwise = Nothing + + ------------ CPR -------------- + cpr_info = cprInfo id_info + cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info) + | otherwise = Nothing + ------------ Unfolding -------------- + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) + + ------------ Inline prag -------------- + inline_prag = inlinePragInfo id_info + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | otherwise = Just (HsInline inline_prag) + + ------------ Levity polymorphism ---------- + levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity + | otherwise = Nothing + +toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo +toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar +toIfaceJoinInfo Nothing = IfaceNotJoinPoint + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs + , uf_src = src + , uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineStable + -> case guidance of + UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + -> IfInlineRule arity unsat_ok boring_ok if_rhs + _other -> IfCoreUnfold True if_rhs + InlineCompulsory -> IfCompulsory if_rhs + InlineRhs -> IfCoreUnfold False if_rhs + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + where + if_rhs = toIfaceExpr rhs + +toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ (OtherCon {}) = Nothing + -- The binding site of an Id doesn't have OtherCon, except perhaps + -- where we have called zapUnfolding; and that evald'ness info is + -- not needed by importing modules + +toIfUnfolding _ BootUnfolding = Nothing + -- Can't happen; we only have BootUnfolding for imported binders + +toIfUnfolding _ NoUnfolding = Nothing + +{- +************************************************************************ +* * + Conversion of expressions +* * +************************************************************************ +-} + +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) + | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) + | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) +toIfaceExpr (Tick t e) + | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) + | otherwise = toIfaceExpr e + +toIfaceOneShot :: Id -> IfaceOneShot +toIfaceOneShot id | isId id + , OneShotLam <- oneShotInfo (idInfo id) + = IfaceOneShot + | otherwise + = IfaceNoOneShot + +--------------------- +toIfaceTickish :: Tickish Id -> Maybe IfaceTickish +toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) +toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) +toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) +toIfaceTickish (Breakpoint {}) = Nothing + -- Ignore breakpoints, since they are relevant only to GHCi, and + -- should not be serialised (#8333) + +--------------------- +toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] + +--------------------- +toIfaceAlt :: (AltCon, [Var], CoreExpr) + -> (IfaceConAlt, [FastString], IfaceExpr) +toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) + +--------------------- +toIfaceCon :: AltCon -> IfaceConAlt +toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | saturated + , Just tup_sort <- tyConTuple_maybe tc + -> IfaceTuple tup_sort tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map toIfaceExpr val_args + tc = dataConTyCon dc + + _ -> mkIfaceApps (toIfaceVar v) as + +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as + +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr +mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as + +--------------------- +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | isBootUnfolding (idUnfolding v) + = -- See Note [Inlining and hs-boot files] + IfaceApp (IfaceApp (IfaceExt noinlineIdName) + (IfaceType (toIfaceType (idType v)))) + (IfaceExt name) -- don't use mkIfaceApps, or infinite loop + + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) + -- Foreign calls have special syntax + + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (getOccFS name) + where name = idName v + + +--------------------- +toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo +toIfaceLFInfo nm lfi = case lfi of + LFReEntrant top_lvl arity no_fvs _arg_descr -> + -- Exported LFReEntrant closures are top level, and top-level closures + -- don't have free variables + ASSERT2(isTopLevel top_lvl, ppr nm) + ASSERT2(no_fvs, ppr nm) + IfLFReEntrant arity + LFThunk top_lvl no_fvs updatable sfi mb_fun -> + -- Exported LFThunk closures are top level (which don't have free + -- variables) and non-standard (see cgTopRhsClosure) + ASSERT2(isTopLevel top_lvl, ppr nm) + ASSERT2(no_fvs, ppr nm) + ASSERT2(sfi == NonStandardThunk, ppr nm) + IfLFThunk updatable mb_fun + LFCon dc -> + IfLFCon (dataConName dc) + LFUnknown mb_fun -> + IfLFUnknown mb_fun + LFUnlifted -> + IfLFUnlifted + LFLetNoEscape -> + panic "toIfaceLFInfo: LFLetNoEscape" + +{- Note [Inlining and hs-boot files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example (#10083, #12789): + + ---------- RSR.hs-boot ------------ + module RSR where + data RSR + eqRSR :: RSR -> RSR -> Bool + + ---------- SR.hs ------------ + module SR where + import {-# SOURCE #-} RSR + data SR = MkSR RSR + eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 + + ---------- RSR.hs ------------ + module RSR where + import SR + data RSR = MkRSR SR -- deriving( Eq ) + eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) + foo x y = not (eqRSR x y) + +When compiling RSR we get this code + + RSR.eqRSR :: RSR -> RSR -> Bool + RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> + case ds1 of _ { RSR.MkRSR s1 -> + case ds2 of _ { RSR.MkRSR s2 -> + SR.eqSR s1 s2 }} + + RSR.foo :: RSR -> RSR -> Bool + RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) + +Now, when optimising foo: + Inline eqRSR (small, non-rec) + Inline eqSR (small, non-rec) +but the result of inlining eqSR from SR is another call to eqRSR, so +everything repeats. Neither eqSR nor eqRSR are (apparently) loop +breakers. + +Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR +with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means +that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly +as would have been the case if `foo` had been defined in SR.hs (and +marked as a loop-breaker). + +But how do we arrange for this to happen? There are two ingredients: + + 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), + for every variable reference we see if we are referring to an + 'Id' that came from an hs-boot file. If so, we add a `noinline` + to the reference. + + 2. But how do we know if a reference came from an hs-boot file + or not? We could record this directly in the 'IdInfo', but + actually we deduce this by looking at the unfolding: 'Id's + that come from boot files are given a special unfolding + (upon typechecking) 'BootUnfolding' which say that there is + no unfolding, and the reason is because the 'Id' came from + a boot file. + +Here is a solution that doesn't work: when compiling RSR, +add a NOINLINE pragma to every function exported by the boot-file +for RSR (if it exists). Doing so makes the bootstrapped GHC itself +slower by 8% overall (on #9872a-d, and T1969: the reason +is that these NOINLINE'd functions now can't be profitably inlined +outside of the hs-boot loop. + +-} diff --git a/GHC/CoreToIface.hs-boot b/GHC/CoreToIface.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/CoreToIface.hs-boot @@ -0,0 +1,18 @@ +module GHC.CoreToIface where + +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) +import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) +import GHC.Types.Var ( VarBndr, TyCoVar ) +import GHC.Types.Var.Env ( TidyEnv ) +import GHC.Core.TyCon ( TyCon ) +import GHC.Types.Var.Set( VarSet ) + +-- For GHC.Core.TyCo.Rep +toIfaceTypeX :: VarSet -> Type -> IfaceType +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs diff --git a/GHC/CoreToStg.hs b/GHC/CoreToStg.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToStg.hs @@ -0,0 +1,944 @@ +{-# LANGUAGE CPP, DeriveFunctor #-} + +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- + +-------------------------------------------------------------- +-- Converting Core to STG Syntax +-------------------------------------------------------------- + +-- And, as we have the info in hand, we may convert some lets to +-- let-no-escapes. + +module GHC.CoreToStg ( coreToStg ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Utils ( exprType, findDefault, isJoinBind + , exprIsTickedString_maybe ) +import GHC.Core.Opt.Arity ( manifestArity ) +import GHC.Stg.Syntax + +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Core.TyCon +import GHC.Types.Id.Make ( coercionTokenId ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.DataCon +import GHC.Types.CostCentre +import GHC.Types.Var.Env +import GHC.Unit.Module +import GHC.Types.Name ( isExternalName, nameModule_maybe ) +import GHC.Types.Basic ( Arity ) +import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId ) +import GHC.Types.Literal +import GHC.Utils.Outputable +import GHC.Utils.Monad +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Driver.Session +import GHC.Driver.Ways +import GHC.Types.ForeignCall +import GHC.Types.Demand ( isUsedOnce ) +import GHC.Builtin.PrimOps ( PrimCall(..) ) +import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) + +import Data.List.NonEmpty (nonEmpty, toList) +import Data.Maybe (fromMaybe) +import Control.Monad (ap) +import qualified Data.Set as Set + +-- Note [Live vs free] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- The two are not the same. Liveness is an operational property rather +-- than a semantic one. A variable is live at a particular execution +-- point if it can be referred to directly again. In particular, a dead +-- variable's stack slot (if it has one): +-- +-- - should be stubbed to avoid space leaks, and +-- - may be reused for something else. +-- +-- There ought to be a better way to say this. Here are some examples: +-- +-- let v = [q] \[x] -> e +-- in +-- ...v... (but no q's) +-- +-- Just after the `in', v is live, but q is dead. If the whole of that +-- let expression was enclosed in a case expression, thus: +-- +-- case (let v = [q] \[x] -> e in ...v...) of +-- alts[...q...] +-- +-- (ie `alts' mention `q'), then `q' is live even after the `in'; because +-- we'll return later to the `alts' and need it. +-- +-- Let-no-escapes make this a bit more interesting: +-- +-- let-no-escape v = [q] \ [x] -> e +-- in +-- ...v... +-- +-- Here, `q' is still live at the `in', because `v' is represented not by +-- a closure but by the current stack state. In other words, if `v' is +-- live then so is `q'. Furthermore, if `e' mentions an enclosing +-- let-no-escaped variable, then its free variables are also live if `v' is. + +-- Note [What are these SRTs all about?] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider the Core program, +-- +-- fibs = go 1 1 +-- where go a b = let c = a + c +-- in c : go b c +-- add x = map (\y -> x*y) fibs +-- +-- In this case we have a CAF, 'fibs', which is quite large after evaluation and +-- has only one possible user, 'add'. Consequently, we want to ensure that when +-- all references to 'add' die we can garbage collect any bit of 'fibs' that we +-- have evaluated. +-- +-- However, how do we know whether there are any references to 'fibs' still +-- around? Afterall, the only reference to it is buried in the code generated +-- for 'add'. The answer is that we record the CAFs referred to by a definition +-- in its info table, namely a part of it known as the Static Reference Table +-- (SRT). +-- +-- Since SRTs are so common, we use a special compact encoding for them in: we +-- produce one table containing a list of CAFs in a module and then include a +-- bitmap in each info table describing which entries of this table the closure +-- references. +-- +-- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki. + +-- Note [What is a non-escaping let] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- NB: Nowadays this is recognized by the occurrence analyser by turning a +-- "non-escaping let" into a join point. The following is then an operational +-- account of join points. +-- +-- Consider: +-- +-- let x = fvs \ args -> e +-- in +-- if ... then x else +-- if ... then x else ... +-- +-- `x' is used twice (so we probably can't unfold it), but when it is +-- entered, the stack is deeper than it was when the definition of `x' +-- happened. Specifically, if instead of allocating a closure for `x', +-- we saved all `x's fvs on the stack, and remembered the stack depth at +-- that moment, then whenever we enter `x' we can simply set the stack +-- pointer(s) to these remembered (compile-time-fixed) values, and jump +-- to the code for `x'. +-- +-- All of this is provided x is: +-- 1. non-updatable; +-- 2. guaranteed to be entered before the stack retreats -- ie x is not +-- buried in a heap-allocated closure, or passed as an argument to +-- something; +-- 3. all the enters have exactly the right number of arguments, +-- no more no less; +-- 4. all the enters are tail calls; that is, they return to the +-- caller enclosing the definition of `x'. +-- +-- Under these circumstances we say that `x' is non-escaping. +-- +-- An example of when (4) does not hold: +-- +-- let x = ... +-- in case x of ...alts... +-- +-- Here, `x' is certainly entered only when the stack is deeper than when +-- `x' is defined, but here it must return to ...alts... So we can't just +-- adjust the stack down to `x''s recalled points, because that would lost +-- alts' context. +-- +-- Things can get a little more complicated. Consider: +-- +-- let y = ... +-- in let x = fvs \ args -> ...y... +-- in ...x... +-- +-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a +-- non-escaping way in ...y..., then `y' is non-escaping. +-- +-- `x' can even be recursive! Eg: +-- +-- letrec x = [y] \ [v] -> if v then x True else ... +-- in +-- ...(x b)... + +-- Note [Cost-centre initialization plan] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`, +-- and the fields were then fixed by a separate pass `stgMassageForProfiling`. +-- We now initialize these correctly. The initialization works like this: +-- +-- - For non-top level bindings always use `currentCCS`. +-- +-- - For top-level bindings, check if the binding is a CAF +-- +-- - CAF: If -fcaf-all is enabled, create a new CAF just for this CAF +-- and use it. Note that these new cost centres need to be +-- collected to be able to generate cost centre initialization +-- code, so `coreToTopStgRhs` now returns `CollectedCCs`. +-- +-- If -fcaf-all is not enabled, use "all CAFs" cost centre. +-- +-- - Non-CAF: Top-level (static) data is not counted in heap profiles; nor +-- do we set CCCS from it; so we just slam in +-- dontCareCostCentre. + +-- Note [Coercion tokens] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- In coreToStgArgs, we drop type arguments completely, but we replace +-- coercions with a special coercionToken# placeholder. Why? Consider: +-- +-- f :: forall a. Int ~# Bool -> a +-- f = /\a. \(co :: Int ~# Bool) -> error "impossible" +-- +-- If we erased the coercion argument completely, we’d end up with just +-- f = error "impossible", but then f `seq` () would be ⊥! +-- +-- This is an artificial example, but back in the day we *did* treat +-- coercion lambdas like type lambdas, and we had bug reports as a +-- result. So now we treat coercion lambdas like value lambdas, but we +-- treat coercions themselves as zero-width arguments — coercionToken# +-- has representation VoidRep — which gets the best of both worlds. +-- +-- (For the gory details, see also the (unpublished) paper, “Practical +-- aspects of evidence-based compilation in System FC.”) + +-- -------------------------------------------------------------- +-- Setting variable info: top-level, binds, RHSs +-- -------------------------------------------------------------- + +coreToStg :: DynFlags -> Module -> CoreProgram + -> ([StgTopBinding], CollectedCCs) +coreToStg dflags this_mod pgm + = (pgm', final_ccs) + where + (_, (local_ccs, local_cc_stacks), pgm') + = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm + + prof = WayProf `Set.member` ways dflags + + final_ccs + | prof && gopt Opt_AutoSccsOnIndividualCafs dflags + = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC + | prof + = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks) + | otherwise + = emptyCollectedCCs + + (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod + +coreTopBindsToStg + :: DynFlags + -> Module + -> IdEnv HowBound -- environment for the bindings + -> CollectedCCs + -> CoreProgram + -> (IdEnv HowBound, CollectedCCs, [StgTopBinding]) + +coreTopBindsToStg _ _ env ccs [] + = (env, ccs, []) +coreTopBindsToStg dflags this_mod env ccs (b:bs) + | NonRec _ rhs <- b, isTyCoArg rhs + = coreTopBindsToStg dflags this_mod env1 ccs1 bs + | otherwise + = (env2, ccs2, b':bs') + where + (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b + (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs + +coreTopBindToStg + :: DynFlags + -> Module + -> IdEnv HowBound + -> CollectedCCs + -> CoreBind + -> (IdEnv HowBound, CollectedCCs, StgTopBinding) + +coreTopBindToStg _ _ env ccs (NonRec id e) + | Just str <- exprIsTickedString_maybe e + -- top-level string literal + -- See Note [Core top-level string literals] in GHC.Core + = let + env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet 0 + in (env', ccs, StgTopStringLit id str) + +coreTopBindToStg dflags this_mod env ccs (NonRec id rhs) + = let + env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet $! manifestArity rhs + + (stg_rhs, ccs') = + initCts dflags env $ + coreToTopStgRhs dflags ccs this_mod (id,rhs) + + bind = StgTopLifted $ StgNonRec id stg_rhs + in + -- NB: previously the assertion printed 'rhs' and 'bind' + -- as well as 'id', but that led to a black hole + -- where printing the assertion error tripped the + -- assertion again! + (env', ccs', bind) + +coreTopBindToStg dflags this_mod env ccs (Rec pairs) + = ASSERT( not (null pairs) ) + let + binders = map fst pairs + + extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) + | (b, rhs) <- pairs ] + env' = extendVarEnvList env extra_env' + + -- generate StgTopBindings and CAF cost centres created for CAFs + (ccs', stg_rhss) + = initCts dflags env' $ do + mapAccumLM (\ccs rhs -> do + (rhs', ccs') <- + coreToTopStgRhs dflags ccs this_mod rhs + return (ccs', rhs')) + ccs + pairs + + bind = StgTopLifted $ StgRec (zip binders stg_rhss) + in + (env', ccs', bind) + +coreToTopStgRhs + :: DynFlags + -> CollectedCCs + -> Module + -> (Id,CoreExpr) + -> CtsM (StgRhs, CollectedCCs) + +coreToTopStgRhs dflags ccs this_mod (bndr, rhs) + = do { new_rhs <- coreToStgExpr rhs + + ; let (stg_rhs, ccs') = + mkTopStgRhs dflags this_mod ccs bndr new_rhs + stg_arity = + stgRhsArity stg_rhs + + ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, + ccs') } + where + -- It's vital that the arity on a top-level Id matches + -- the arity of the generated STG binding, else an importing + -- module will use the wrong calling convention + -- (#2844 was an example where this happened) + -- NB1: we can't move the assertion further out without + -- blocking the "knot" tied in coreTopBindsToStg + -- NB2: the arity check is only needed for Ids with External + -- Names, because they are externally visible. The CorePrep + -- pass introduces "sat" things with Local Names and does + -- not bother to set their Arity info, so don't fail for those + arity_ok stg_arity + | isExternalName (idName bndr) = id_arity == stg_arity + | otherwise = True + id_arity = idArity bndr + mk_arity_msg stg_arity + = vcat [ppr bndr, + text "Id arity:" <+> ppr id_arity, + text "STG arity:" <+> ppr stg_arity] + +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- + +coreToStgExpr + :: CoreExpr + -> CtsM StgExpr + +-- The second and third components can be derived in a simple bottom up pass, not +-- dependent on any decisions about which variables will be let-no-escaped or +-- not. The first component, that is, the decorated expression, may then depend +-- on these components, but it in turn is not scrutinised as the basis for any +-- decisions. Hence no black holes. + +-- No LitInteger's or LitNatural's should be left by the time this is called. +-- CorePrep should have converted them all to a real core representation. +coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" +coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" +coreToStgExpr (Lit l) = return (StgLit l) +coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) + -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in + -- a STG to Cmm pass. + = coreToStgExpr (Var unitDataConId) +coreToStgExpr (Var v) = coreToStgApp v [] [] +coreToStgExpr (Coercion _) + -- See Note [Coercion tokens] + = coreToStgApp coercionTokenId [] [] + +coreToStgExpr expr@(App _ _) + = coreToStgApp f args ticks + where + (f, args, ticks) = myCollectArgs expr + +coreToStgExpr expr@(Lam _ _) + = let + (args, body) = myCollectBinders expr + args' = filterStgBinders args + in + extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do + body' <- coreToStgExpr body + let + result_expr = case nonEmpty args' of + Nothing -> body' + Just args'' -> StgLam args'' body' + + return result_expr + +coreToStgExpr (Tick tick expr) + = do case tick of + HpcTick{} -> return () + ProfNote{} -> return () + SourceNote{} -> return () + Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen" + expr2 <- coreToStgExpr expr + return (StgTick tick expr2) + +coreToStgExpr (Cast expr _) + = coreToStgExpr expr + +-- Cases require a little more real work. + +{- +coreToStgExpr (Case scrut _ _ []) + = coreToStgExpr scrut + -- See Note [Empty case alternatives] in GHC.Core If the case + -- alternatives are empty, the scrutinee must diverge or raise an + -- exception, so we can just dive into it. + -- + -- Of course this may seg-fault if the scrutinee *does* return. A + -- belt-and-braces approach would be to move this case into the + -- code generator, and put a return point anyway that calls a + -- runtime system error function. + +coreToStgExpr e0@(Case scrut bndr _ [alt]) = do + | isUnsafeEqualityProof scrut + , isDeadBinder bndr -- We can only discard the case if the case-binder is dead + -- It usually is, but see #18227 + , (_,_,rhs) <- alt + = coreToStgExpr rhs + -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce +-} + +-- The normal case for case-expressions +coreToStgExpr (Case scrut bndr _ alts) + = do { scrut2 <- coreToStgExpr scrut + ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts) + ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) } + where + vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr) + vars_alt (con, binders, rhs) + | DataAlt c <- con, c == unboxedUnitDataCon + = -- This case is a bit smelly. + -- See Note [Nullary unboxed tuple] in GHC.Core.Type + -- where a nullary tuple is mapped to (State# World#) + ASSERT( null binders ) + do { rhs2 <- coreToStgExpr rhs + ; return (DEFAULT, [], rhs2) } + | otherwise + = let -- Remove type variables + binders' = filterStgBinders binders + in + extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do + rhs2 <- coreToStgExpr rhs + return (con, binders', rhs2) + +coreToStgExpr (Let bind body) = do + coreToStgLet bind body + +coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) + +mkStgAltType :: Id -> [CoreAlt] -> AltType +mkStgAltType bndr alts + | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty + = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples + + | otherwise + = case prim_reps of + [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of + Just tc + | isAbstractTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) + PolyAlt + Nothing -> PolyAlt + [unlifted] -> PrimAlt unlifted + not_unary -> MultiValAlt (length not_unary) + where + bndr_ty = idType bndr + prim_reps = typePrimRep bndr_ty + + _is_poly_alt_tycon tc + = isFunTyCon tc + || isPrimTyCon tc -- "Any" is lifted but primitive + || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict + -- function application where argument has a + -- type-family type + + -- Sometimes, the TyCon is a AbstractTyCon which may not have any + -- constructors inside it. Then we may get a better TyCon by + -- grabbing the one from a constructor alternative + -- if one exists. + look_for_better_tycon + | ((DataAlt con, _, _) : _) <- data_alts = + AlgAlt (dataConTyCon con) + | otherwise = + ASSERT(null data_alts) + PolyAlt + where + (data_alts, _deflt) = findDefault alts + +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- + +coreToStgApp :: Id -- Function + -> [CoreArg] -- Arguments + -> [Tickish Id] -- Debug ticks + -> CtsM StgExpr +coreToStgApp f args ticks = do + (args', ticks') <- coreToStgArgs args + how_bound <- lookupVarCts f + + let + n_val_args = valArgCount args + + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- let f = \ab -> e in f + -- No point in having correct arity info for f! + -- Hence the hasArity stuff below. + -- NB: f_arity is only consulted for LetBound things + f_arity = stgArity f how_bound + saturated = f_arity <= n_val_args + + res_ty = exprType (mkApps (Var f) args) + app = case idDetails f of + DataConWorkId dc + | saturated -> StgConApp dc args' + (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) + + -- Some primitive operator that might be implemented as a library call. + -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps + -- we require that primop applications be saturated. + PrimOpId op -> ASSERT( saturated ) + StgOpApp (StgPrimOp op) args' res_ty + + -- A call to some primitive Cmm function. + FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) + PrimCallConv _)) + -> ASSERT( saturated ) + StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty + + -- A regular foreign call. + FCallId call -> ASSERT( saturated ) + StgOpApp (StgFCallOp call (idType f)) args' res_ty + + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') + _other -> StgApp f args' + + tapp = foldr StgTick app (ticks ++ ticks') + + -- Forcing these fixes a leak in the code generator, noticed while + -- profiling for trac #4367 + app `seq` return tapp + +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- + +coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id]) +coreToStgArgs [] + = return ([], []) + +coreToStgArgs (Type _ : args) = do -- Type argument + (args', ts) <- coreToStgArgs args + return (args', ts) + +coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion tokens] + = do { (args', ts) <- coreToStgArgs args + ; return (StgVarArg coercionTokenId : args', ts) } + +coreToStgArgs (Tick t e : args) + = ASSERT( not (tickishIsCode t) ) + do { (args', ts) <- coreToStgArgs (e : args) + ; return (args', t:ts) } + +coreToStgArgs (arg : args) = do -- Non-type argument + (stg_args, ticks) <- coreToStgArgs args + arg' <- coreToStgExpr arg + let + (aticks, arg'') = stripStgTicksTop tickishFloatable arg' + stg_arg = case arg'' of + StgApp v [] -> StgVarArg v + StgConApp con [] _ -> StgVarArg (dataConWorkId con) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg) + + -- WARNING: what if we have an argument like (v `cast` co) + -- where 'co' changes the representation type? + -- (This really only happens if co is unsafe.) + -- Then all the getArgAmode stuff in CgBindery will set the + -- cg_rep of the CgIdInfo based on the type of v, rather + -- than the type of 'co'. + -- This matters particularly when the function is a primop + -- or foreign call. + -- Wanted: a better solution than this hacky warning + + platform <- targetPlatform <$> getDynFlags + let + arg_rep = typePrimRep (exprType arg) + stg_arg_rep = typePrimRep (stgArgType stg_arg) + bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) + + WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg ) + return (stg_arg : stg_args, ticks ++ aticks) + + +-- --------------------------------------------------------------------------- +-- The magic for lets: +-- --------------------------------------------------------------------------- + +coreToStgLet + :: CoreBind -- bindings + -> CoreExpr -- body + -> CtsM StgExpr -- new let + +coreToStgLet bind body + | NonRec _ rhs <- bind, isTyCoArg rhs + = coreToStgExpr body + + | otherwise + = do { (bind2, env_ext) <- vars_bind bind + + -- Do the body + ; body2 <- extendVarEnvCts env_ext $ + coreToStgExpr body + + -- Compute the new let-expression + ; let new_let | isJoinBind bind + = StgLetNoEscape noExtFieldSilent bind2 body2 + | otherwise + = StgLet noExtFieldSilent bind2 body2 + + ; return new_let } + where + mk_binding binder rhs + = (binder, LetBound NestedLet (manifestArity rhs)) + + vars_bind :: CoreBind + -> CtsM (StgBinding, + [(Id, HowBound)]) -- extension to environment + + vars_bind (NonRec binder rhs) = do + rhs2 <- coreToStgRhs (binder,rhs) + let + env_ext_item = mk_binding binder rhs + + return (StgNonRec binder rhs2, [env_ext_item]) + + vars_bind (Rec pairs) + = let + binders = map fst pairs + env_ext = [ mk_binding b rhs + | (b,rhs) <- pairs ] + in + extendVarEnvCts env_ext $ do + rhss2 <- mapM coreToStgRhs pairs + return (StgRec (binders `zip` rhss2), env_ext) + +coreToStgRhs :: (Id,CoreExpr) + -> CtsM StgRhs + +coreToStgRhs (bndr, rhs) = do + new_rhs <- coreToStgExpr rhs + return (mkStgRhs bndr new_rhs) + +-- Generate a top-level RHS. Any new cost centres generated for CAFs will be +-- appended to `CollectedCCs` argument. +mkTopStgRhs :: DynFlags -> Module -> CollectedCCs + -> Id -> StgExpr -> (StgRhs, CollectedCCs) + +mkTopStgRhs dflags this_mod ccs bndr rhs + | StgLam bndrs body <- rhs + = -- StgLam can't have empty arguments, so not CAF + ( StgRhsClosure noExtFieldSilent + dontCareCCS + ReEntrant + (toList bndrs) body + , ccs ) + + | StgConApp con args _ <- unticked_rhs + , -- Dynamic StgConApps are updatable + not (isDllConApp dflags this_mod con args) + = -- CorePrep does this right, but just to make sure + ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con) + , ppr bndr $$ ppr con $$ ppr args) + ( StgRhsCon dontCareCCS con args, ccs ) + + -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. + | gopt Opt_AutoSccsOnIndividualCafs dflags + = ( StgRhsClosure noExtFieldSilent + caf_ccs + upd_flag [] rhs + , collectCC caf_cc caf_ccs ccs ) + + | otherwise + = ( StgRhsClosure noExtFieldSilent + all_cafs_ccs + upd_flag [] rhs + , ccs ) + + where + unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs + + upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable + + -- CAF cost centres generated for -fcaf-all + caf_cc = mkAutoCC bndr modl + caf_ccs = mkSingletonCCS caf_cc + -- careful: the binder might be :Main.main, + -- which doesn't belong to module mod_name. + -- bug #249, tests prof001, prof002 + modl | Just m <- nameModule_maybe (idName bndr) = m + | otherwise = this_mod + + -- default CAF cost centre + (_, all_cafs_ccs) = getAllCAFsCC this_mod + +-- Generate a non-top-level RHS. Cost-centre is always currentCCS, +-- see Note [Cost-centre initialization plan]. +mkStgRhs :: Id -> StgExpr -> StgRhs +mkStgRhs bndr rhs + | StgLam bndrs body <- rhs + = StgRhsClosure noExtFieldSilent + currentCCS + ReEntrant + (toList bndrs) body + + | isJoinId bndr -- must be a nullary join point + = ASSERT(idJoinArity bndr == 0) + StgRhsClosure noExtFieldSilent + currentCCS + ReEntrant -- ignored for LNE + [] rhs + + | StgConApp con args _ <- unticked_rhs + = StgRhsCon currentCCS con args + + | otherwise + = StgRhsClosure noExtFieldSilent + currentCCS + upd_flag [] rhs + where + unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs + + upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable + + {- + SDM: disabled. Eval/Apply can't handle functions with arity zero very + well; and making these into simple non-updatable thunks breaks other + assumptions (namely that they will be entered only once). + + upd_flag | isPAP env rhs = ReEntrant + | otherwise = Updatable + +-- Detect thunks which will reduce immediately to PAPs, and make them +-- non-updatable. This has several advantages: +-- +-- - the non-updatable thunk behaves exactly like the PAP, +-- +-- - the thunk is more efficient to enter, because it is +-- specialised to the task. +-- +-- - we save one update frame, one stg_update_PAP, one update +-- and lots of PAP_enters. +-- +-- - in the case where the thunk is top-level, we save building +-- a black hole and furthermore the thunk isn't considered to +-- be a CAF any more, so it doesn't appear in any SRTs. +-- +-- We do it here, because the arity information is accurate, and we need +-- to do it before the SRT pass to save the SRT entries associated with +-- any top-level PAPs. + +isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args + where + arity = stgArity f (lookupBinding env f) +isPAP env _ = False + +-} + +{- ToDo: + upd = if isOnceDem dem + then (if isNotTop toplev + then SingleEntry -- HA! Paydirt for "dem" + else + (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $ + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. +-} + +-- --------------------------------------------------------------------------- +-- A monad for the core-to-STG pass +-- --------------------------------------------------------------------------- + +-- There's a lot of stuff to pass around, so we use this CtsM +-- ("core-to-STG monad") monad to help. All the stuff here is only passed +-- *down*. + +newtype CtsM a = CtsM + { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs + -> IdEnv HowBound + -> a + } + deriving (Functor) + +data HowBound + = ImportBound -- Used only as a response to lookupBinding; never + -- exists in the range of the (IdEnv HowBound) + + | LetBound -- A let(rec) in this module + LetInfo -- Whether top level or nested + Arity -- Its arity (local Ids don't have arity info at this point) + + | LambdaBound -- Used for both lambda and case + deriving (Eq) + +data LetInfo + = TopLet -- top level things + | NestedLet + deriving (Eq) + +-- For a let(rec)-bound variable, x, we record LiveInfo, the set of +-- variables that are live if x is live. This LiveInfo comprises +-- (a) dynamic live variables (ones with a non-top-level binding) +-- (b) static live variables (CAFs or things that refer to CAFs) +-- +-- For "normal" variables (a) is just x alone. If x is a let-no-escaped +-- variable then x is represented by a code pointer and a stack pointer +-- (well, one for each stack). So all of the variables needed in the +-- execution of x are live if x is, and are therefore recorded in the +-- LetBound constructor; x itself *is* included. +-- +-- The set of dynamic live variables is guaranteed ot have no further +-- let-no-escaped variables in it. + +-- The std monad functions: + +initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a +initCts dflags env m = unCtsM m dflags env + + + +{-# INLINE thenCts #-} +{-# INLINE returnCts #-} + +returnCts :: a -> CtsM a +returnCts e = CtsM $ \_ _ -> e + +thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b +thenCts m k = CtsM $ \dflags env + -> unCtsM (k (unCtsM m dflags env)) dflags env + +instance Applicative CtsM where + pure = returnCts + (<*>) = ap + +instance Monad CtsM where + (>>=) = thenCts + +instance HasDynFlags CtsM where + getDynFlags = CtsM $ \dflags _ -> dflags + +-- Functions specific to this monad: + +extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a +extendVarEnvCts ids_w_howbound expr + = CtsM $ \dflags env + -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound) + +lookupVarCts :: Id -> CtsM HowBound +lookupVarCts v = CtsM $ \_ env -> lookupBinding env v + +lookupBinding :: IdEnv HowBound -> Id -> HowBound +lookupBinding env v = case lookupVarEnv env v of + Just xx -> xx + Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound + +getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) +getAllCAFsCC this_mod = + let + span = mkGeneralSrcSpan (mkFastString "") -- XXX do better + all_cafs_cc = mkAllCafsCC this_mod span + all_cafs_ccs = mkSingletonCCS all_cafs_cc + in + (all_cafs_cc, all_cafs_ccs) + +-- Misc. + +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs = filter isId bndrs + +myCollectBinders :: Expr Var -> ([Var], Expr Var) +myCollectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs (Cast e _) = go bs e + go bs e = (reverse bs, e) + +-- | Precondition: argument expression is an 'App', and there is a 'Var' at the +-- head of the 'App' chain. +myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) +myCollectArgs expr + = go expr [] [] + where + go (Var v) as ts = (v, as, ts) + go (App f a) as ts = go f (a:as) ts + go (Tick t e) as ts = ASSERT( all isTypeArg as ) + go e as (t:ts) -- ticks can appear in type apps + go (Cast e _) as ts = go e as ts + go (Lam b e) as ts + | isTyVar b = go e as ts -- Note [Collect args] + go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) + +-- Note [Collect args] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- This big-lambda case occurred following a rather obscure eta expansion. +-- It all seems a bit yukky to me. + +stgArity :: Id -> HowBound -> Arity +stgArity _ (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity _ LambdaBound = 0 diff --git a/GHC/CoreToStg/Prep.hs b/GHC/CoreToStg/Prep.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToStg/Prep.hs @@ -0,0 +1,2195 @@ +{- +(c) The University of Glasgow, 1994-2006 + + +Core pass to saturate constructors and PrimOps +-} + +{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.CoreToStg.Prep + ( corePrepPgm + , corePrepExpr + , mkConvertNumLiteral + ) +where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Core.Opt.OccurAnal + +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) +import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId ) +import GHC.Driver.Types +import GHC.Builtin.Names +import GHC.Core.Utils +import GHC.Core.Opt.Arity +import GHC.Core.FVs +import GHC.Core.Opt.Monad ( CoreToDo(..) ) +import GHC.Core.Lint ( endPassIO ) +import GHC.Core +import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here +import GHC.Core.Type +import GHC.Types.Literal +import GHC.Core.Coercion +import GHC.Tc.Utils.Env +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Builtin.Types +import GHC.Core.DataCon +import GHC.Types.Basic +import GHC.Unit.Module +import GHC.Types.Unique.Supply +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Driver.Ways +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) +import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) +import GHC.Data.Pair +import Data.Bits +import GHC.Utils.Monad ( mapAccumLM ) +import Data.List ( unfoldr ) +import Data.Functor.Identity +import Control.Monad +import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) +import qualified Data.Set as S + +{- +-- --------------------------------------------------------------------------- +-- Note [CorePrep Overview] +-- --------------------------------------------------------------------------- + +The goal of this pass is to prepare for code generation. + +1. Saturate constructor and primop applications. + +2. Convert to A-normal form; that is, function arguments + are always variables. + + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) + + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) + +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] + +4. Ensure that *value* lambdas only occur as the RHS of a binding + (The code generator can't deal with anything else.) + Type lambdas are ok, however, because the code gen discards them. + +5. [Not any more; nuked Jun 2002] Do the seq/par munging. + +6. Clone all local Ids. + This means that all such Ids are unique, rather than the + weaker guarantee of no clashes which the simplifier provides. + And that is what the code generator needs. + + We don't clone TyVars or CoVars. The code gen doesn't need that, + and doing so would be tiresome because then we'd need + to substitute in types and coercions. + +7. Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + +8. Inject bindings for the "implicit" Ids: + * Constructor wrappers + * Constructor workers + We want curried definitions for all of these in case they + aren't inlined by some caller. + +9. Replace (lazy e) by e. See Note [lazyId magic] in GHC.Types.Id.Make + Also replace (noinline e) by e. + +10. Convert bignum literals (LitNatural and LitInteger) into their + core representation. + +11. Uphold tick consistency while doing this: We move ticks out of + (non-type) applications where we can, and make sure that we + annotate according to scoping rules when floating. + +12. Collect cost centres (including cost centres in unfoldings) if we're in + profiling mode. We have to do this here beucase we won't have unfoldings + after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules]. + +13. Eliminate case clutter in favour of unsafe coercions. + See Note [Unsafe coercions] + +14. Eliminate some magic Ids, specifically + runRW# (\s. e) ==> e[readWorldId/s] + lazy e ==> e + noinline e ==> e + ToDo: keepAlive# ... + This is done in cpeApp + +This is all done modulo type applications and abstractions, so that +when type erasure is done for conversion to STG, we don't end up with +any trivial or useless bindings. + +Note [Unsafe coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +CorePrep does these two transformations: + +* Convert empty case to cast with an unsafe coercion + (case e of {}) ===> e |> unsafe-co + See Note [Empty case alternatives] in GHC.Core: if the case + alternatives are empty, the scrutinee must diverge or raise an + exception, so we can just dive into it. + + Of course, if the scrutinee *does* return, we may get a seg-fault. + A belt-and-braces approach would be to persist empty-alternative + cases to code generator, and put a return point anyway that calls a + runtime system error function. + + Notice that eliminating empty case can lead to an ill-kinded coercion + case error @Int "foo" of {} :: Int# + ===> error @Int "foo" |> unsafe-co + where unsafe-co :: Int ~ Int# + But that's fine because the expression diverges anyway. And it's + no different to what happened before. + +* Eliminate unsafeEqualityProof in favour of an unsafe coercion + case unsafeEqualityProof of UnsafeRefl g -> e + ===> e[unsafe-co/g] + See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + + Note that this requiresuse ot substitute 'unsafe-co' for 'g', and + that is the main (current) reason for cpe_tyco_env in CorePrepEnv. + Tiresome, but not difficult. + +These transformations get rid of "case clutter", leaving only casts. +We are doing no further significant tranformations, so the reasons +for the case forms have disappeared. And it is extremely helpful for +the ANF-ery, CoreToStg, and backends, if trivial expressions really do +look trivial. #19700 was an example. + +In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 CorePrepProv). + +Note [CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the syntax of the Core produced by CorePrep: + + Trivial expressions + arg ::= lit | var + | arg ty | /\a. arg + | truv co | /\c. arg | arg |> co + + Applications + app ::= lit | var | app arg | app ty | app co | app |> co + + Expressions + body ::= app + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co + + Right hand sides (only place where value lambdas can occur) + rhs ::= /\a.rhs | \x.rhs | body + +We define a synonym for each of these non-terminals. Functions +with the corresponding name produce a result in that syntax. +-} + +type CpeArg = CoreExpr -- Non-terminal 'arg' +type CpeApp = CoreExpr -- Non-terminal 'app' +type CpeBody = CoreExpr -- Non-terminal 'body' +type CpeRhs = CoreExpr -- Non-terminal 'rhs' + +{- +************************************************************************ +* * + Top level stuff +* * +************************************************************************ +-} + +corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] + -> IO (CoreProgram, S.Set CostCentre) +corePrepPgm hsc_env this_mod mod_loc binds data_tycons = + withTiming dflags + (text "CorePrep"<+>brackets (ppr this_mod)) + (const ()) $ do + us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + + let cost_centres + | WayProf `S.member` ways dflags + = collectCostCentres this_mod binds + | otherwise + = S.empty + + implicit_binds = mkDataConWorkers dflags mod_loc data_tycons + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + + binds_out = initUs_ us $ do + floats1 <- corePrepTopBinds initialCorePrepEnv binds + floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds + return (deFloatTop (floats1 `appendFloats` floats2)) + + endPassIO hsc_env alwaysQualify CorePrep binds_out [] + return (binds_out, cost_centres) + where + dflags = hsc_dflags hsc_env + +corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr +corePrepExpr hsc_env expr = do + let dflags = hsc_dflags hsc_env + withTiming dflags (text "CorePrep [expr]") (const ()) $ do + us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + return new_expr + +corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats +-- Note [Floating out of top level bindings] +corePrepTopBinds initialCorePrepEnv binds + = go initialCorePrepEnv binds + where + go _ [] = return emptyFloats + go env (bind : binds) = do (env', floats, maybe_new_bind) + <- cpeBind TopLevel env bind + MASSERT(isNothing maybe_new_bind) + -- Only join points get returned this way by + -- cpeBind, and no join point may float to top + floatss <- go env' binds + return (floats `appendFloats` floatss) + +mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind] +-- See Note [Data constructor workers] +-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy +mkDataConWorkers dflags mod_loc data_tycons + = [ NonRec id (tick_it (getName data_con) (Var id)) + -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it + data_con <- tyConDataCons tycon, + let id = dataConWorkId data_con + ] + where + -- If we want to generate debug info, we put a source note on the + -- worker. This is useful, especially for heap profiling. + tick_it name + | debugLevel dflags == 0 = id + | RealSrcSpan span _ <- nameSrcSpan name = tick span + | Just file <- ml_hs_file mod_loc = tick (span1 file) + | otherwise = tick (span1 "???") + where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name)) + span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 + +{- +Note [Floating out of top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: we do need to float out of top-level bindings +Consider x = length [True,False] +We want to get + s1 = False : [] + s2 = True : s1 + x = length s2 + +We return a *list* of bindings, because we may start with + x* = f (g y) +where x is demanded, in which case we want to finish with + a = g y + x* = f a +And then x will actually end up case-bound + +Note [Join points and floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Join points can float out of other join points but not out of value bindings: + + let z = + let w = ... in -- can float + join k = ... in -- can't float + ... jump k ... + join j x1 ... xn = + let y = ... in -- can float (but don't want to) + join h = ... in -- can float (but not much point) + ... jump h ... + in ... + +Here, the jump to h remains valid if h is floated outward, but the jump to k +does not. + +We don't float *out* of join points. It would only be safe to float out of +nullary join points (or ones where the arguments are all either type arguments +or dead binders). Nullary join points aren't ever recursive, so they're always +effectively one-shot functions, which we don't float out of. We *could* float +join points from nullary join points, but there's no clear benefit at this +stage. + +Note [Data constructor workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Create any necessary "implicit" bindings for data con workers. We +create the rather strange (non-recursive!) binding + + $wC = \x y -> $wC x y + +i.e. a curried constructor that allocates. This means that we can +treat the worker for a constructor like any other function in the rest +of the compiler. The point here is that CoreToStg will generate a +StgConApp for the RHS, rather than a call to the worker (which would +give a loop). As Lennart says: the ice is thin here, but it works. + +Hmm. Should we create bindings for dictionary constructors? They are +always fully applied, and the bindings are just there to support +partial applications. But it's easier to let them through. + + +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this (see #4962): + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown + +After specialisation and SpecConstr, we would get something like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... + +Note that the g$Bool and g$Unit functions are actually dead code: they +are only kept alive by the occurrence analyser because they are +referred to by the rules of g, which is being kept alive by the fact +that it is used (unspecialised) in the returned pair. + +However, at the CorePrep stage there is no way that the rules for g +will ever fire, and it really seems like a shame to produce an output +program that goes to the trouble of allocating a closure for the +unreachable g$Bool and g$Unit functions. + +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + + * In deFloatTop, run a simple dead code analyser on each top-level + RHS to drop the dead local bindings. + +The reason we don't just OccAnal the whole output of CorePrep is that +the tidier ensures that all top-level binders are GlobalIds, so they +don't show up in the free variables any longer. So if you run the +occurrence analyser on the output of CoreTidy (or later) you e.g. turn +this program: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + +Note [keepAlive# magic] +~~~~~~~~~~~~~~~~~~~~~~~ +When interacting with foreign code, it is often necessary for the user to +extend the lifetime of a heap object beyond the lifetime that would be apparent +from the on-heap references alone. For instance, a program like: + + foreign import safe "hello" hello :: ByteArray# -> IO () + + callForeign :: IO () + callForeign = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + unIO hello barr s1 + +As-written this program is susceptible to memory-unsafety since there are +no references to `barr` visible to the garbage collector. Consequently, if a +garbage collection happens during the execution of the C function `hello`, it +may be that the array is freed while in use by the foreign function. + +To address this, we introduced a new primop, keepAlive#, which "scopes over" +the computation needing the kept-alive value: + + keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b). + a -> State# RealWorld -> (State# RealWorld -> b) -> b + +When entered, an application (keepAlive# x s k) will apply `k` to the state +token, evaluating it to WHNF. However, during the course of this evaluation +will *guarantee* that `x` is considered to be alive. + +There are a few things to note here: + + - we are RuntimeRep-polymorphic in the value to be kept-alive. This is + necessary since we will often (but not always) be keeping alive something + unlifted (like a ByteArray#) + + - we are RuntimeRep-polymorphic in the result value since the result may take + many forms (e.g. a boxed value, a raw state token, or a (# State s, result #). + +We implement this operation by desugaring to touch# during CorePrep (see +GHC.CoreToStg.Prep.cpeApp). Specifically, + + keepAlive# x s0 k + +is transformed to: + + case k s0 of r -> + case touch# x realWorld# of s1 -> + r + +Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a +pointer to `x` and entering `k s0`. This compilation strategy is safe +because we do no optimization on STG that would drop or re-order the +continuation containing the `touch#`. However, if we were to become more +aggressive in our STG pipeline then we would need to revisit this. + +Beyond this CorePrep transformation, there is very little special about +keepAlive#. However, we did explore (and eventually gave up on) +an optimisation which would allow unboxing of constructed product results, +which we describe below. + + +Lost optimisation: CPR unboxing +-------------------------------- +One unfortunate property of this approach is that the simplifier is unable to +unbox the result of a keepAlive# expression. For instance, consider the program: + + case keepAlive# arr s0 ( + \s1 -> case peekInt arr s1 of + (# s2, r #) -> I# r + ) of + I# x -> ... + +This is a surprisingly common pattern, previously used, e.g., in +GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around +with optimising this away by pushing strict contexts (like the +`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can +recover unboxing, it can also unfortunately in general change the asymptotic +memory (namely stack) behavior of the program. For instance, consider + + writeN = + ... + case keepAlive# x s0 (\s1 -> something s1) of + (# s2, x #) -> + writeN ... + +As it is tail-recursive, this program will run in constant space. However, if +we push outer case into the continuation we get: + + writeN = + + case keepAlive# x s0 (\s1 -> + case something s1 of + (# s2, x #) -> + writeN ... + ) of + ... + +Which ends up building a stack which is linear in the recursion depth. For this +reason, we ended up giving up on this optimisation. + + +Historical note: touch# and its inadequacy +------------------------------------------ +Prior to the introduction of `keepAlive#` we instead addressed the need for +lifetime extension with the `touch#` primop: + + touch# :: a -> State# s -> State# s + +This operation would ensure that the `a` value passed as the first argument was +considered "alive" at the time the primop application is entered. + +For instance, the user might modify `callForeign` as: + + callForeign :: IO () + callForeign s0 = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + case unIO hello barr s1 of (# s2, () #) -> + case touch# barr s2 of s3 -> + (# s3, () #) + +However, in #14346 we discovered that this primop is insufficient in the +presence of simplification. For instance, consider a program like: + + callForeign :: IO () + callForeign s0 = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + case unIO (forever $ hello barr) s1 of (# s2, () #) -> + case touch# barr s2 of s3 -> + (# s3, () #) + +In this case the Simplifier may realize that (forever $ hello barr) +will never return and consequently that the `touch#` that follows is dead code. +As such, it will be dropped, resulting in memory unsoundness. +This unsoundness lead to the introduction of keepAlive#. + + + +Other related tickets: + + - #15544 + - #17760 + - #14375 + - #15260 + - #18061 + +************************************************************************ +* * + The main code +* * +************************************************************************ +-} + +cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, + Floats, -- Floating value bindings + Maybe CoreBind) -- Just bind' <=> returned new bind; no float + -- Nothing <=> added bind' to floats instead +cpeBind top_lvl env (NonRec bndr rhs) + | not (isJoinId bndr) + = do { (env1, bndr1) <- cpCloneBndr env bndr + ; let dmd = idDemandInfo bndr + is_unlifted = isUnliftedType (idType bndr) + ; (floats, rhs1) <- cpePair top_lvl NonRecursive + dmd is_unlifted + env bndr1 rhs + -- See Note [Inlining in CorePrep] + ; let triv_rhs = exprIsTrivial rhs1 + env2 | triv_rhs = extendCorePrepEnvExpr env1 bndr rhs1 + | otherwise = env1 + floats1 | triv_rhs, isInternalName (idName bndr) + = floats + | otherwise + = addFloat floats new_float + + new_float = mkFloat dmd is_unlifted bndr1 rhs1 + + ; return (env2, floats1, Nothing) } + + | otherwise -- A join point; see Note [Join points and floating] + = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point + do { (_, bndr1) <- cpCloneBndr env bndr + ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs + ; return (extendCorePrepEnv env bndr bndr2, + emptyFloats, + Just (NonRec bndr2 rhs1)) } + +cpeBind top_lvl env (Rec pairs) + | not (isJoinId (head bndrs)) + = do { (env', bndrs1) <- cpCloneBndrs env bndrs + ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') + bndrs1 rhss + + ; let (floats_s, rhss1) = unzip stuff + all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) + (concatFloats floats_s) + + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), + unitFloat (FloatLet (Rec all_pairs)), + Nothing) } + + | otherwise -- See Note [Join points and floating] + = do { (env', bndrs1) <- cpCloneBndrs env bndrs + ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss + + ; let bndrs2 = map fst pairs1 + ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2), + emptyFloats, + Just (Rec pairs1)) } + where + (bndrs, rhss) = unzip pairs + + -- Flatten all the floats, and the current + -- group into a single giant Rec + add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 + add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 + add_float b _ = pprPanic "cpeBind" (ppr b) + +--------------- +cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool + -> CorePrepEnv -> OutId -> CoreExpr + -> UniqSM (Floats, CpeRhs) +-- Used for all bindings +-- The binder is already cloned, hence an OutId +cpePair top_lvl is_rec dmd is_unlifted env bndr rhs + = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair + do { (floats1, rhs1) <- cpeRhsE env rhs + + -- See if we are allowed to float this stuff out of the RHS + ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 + + -- Make the arity match up + ; (floats3, rhs3) + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) + -- Note [Silly extra arguments] + (do { v <- newVar (idType bndr) + ; let float = mkFloat topDmd False v rhs2 + ; return ( addFloat floats2 float + , cpeEtaExpand arity (Var v)) }) + + -- Wrap floating ticks + ; let (floats4, rhs4) = wrapTicks floats3 rhs3 + + ; return (floats4, rhs4) } + where + arity = idArity bndr -- We must match this arity + + --------------------- + float_from_rhs floats rhs + | isEmptyFloats floats = return (emptyFloats, rhs) + | isTopLevel top_lvl = float_top floats rhs + | otherwise = float_nested floats rhs + + --------------------- + float_nested floats rhs + | wantFloatNested is_rec dmd is_unlifted floats rhs + = return (floats, rhs) + | otherwise = dontFloat floats rhs + + --------------------- + float_top floats rhs + | allLazyTop floats + = return (floats, rhs) + + | Just floats <- canFloat floats rhs + = return floats + + | otherwise + = dontFloat floats rhs + +dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody) +-- Non-empty floats, but do not want to float from rhs +-- So wrap the rhs in the floats +-- But: rhs1 might have lambdas, and we can't +-- put them inside a wrapBinds +dontFloat floats1 rhs + = do { (floats2, body) <- rhsToBody rhs + ; return (emptyFloats, wrapBinds floats1 $ + wrapBinds floats2 body) } + +{- Note [Silly extra arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we had this + f{arity=1} = \x\y. e +We *must* match the arity on the Id, so we have to generate + f' = \x\y. e + f = \x. f' x + +It's a bizarre case: why is the arity on the Id wrong? Reason +(in the days of __inline_me__): + f{arity=0} = __inline_me__ (let v = expensive in \xy. e) +When InlineMe notes go away this won't happen any more. But +it seems good for CorePrep to be robust. +-} + +--------------- +cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr + -> UniqSM (JoinId, CpeRhs) +-- Used for all join bindings +-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils +cpeJoinPair env bndr rhs + = ASSERT(isJoinId bndr) + do { let Just join_arity = isJoinId_maybe bndr + (bndrs, body) = collectNBinders join_arity rhs + + ; (env', bndrs') <- cpCloneBndrs env bndrs + + ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts + -- with a lambda + + ; let rhs' = mkCoreLams bndrs' body' + bndr' = bndr `setIdUnfolding` evaldUnfolding + `setIdArity` count isId bndrs + -- See Note [Arity and join points] + + ; return (bndr', rhs') } + +{- +Note [Arity and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Up to now, we've allowed a join point to have an arity greater than its join +arity (minus type arguments), since this is what's useful for eta expansion. +However, for code gen purposes, its arity must be exactly the number of value +arguments it will be called with, and it must have exactly that many value +lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS: + + join j x y z = \w -> ... in ... + => + join j x y z = (let f = \w -> ... in f) in ... + +This is also what happens with Note [Silly extra arguments]. Note that it's okay +for us to mess with the arity because a join point is never exported. +-} + +-- --------------------------------------------------------------------------- +-- CpeRhs: produces a result satisfying CpeRhs +-- --------------------------------------------------------------------------- + +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- If +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) +-- +-- For example +-- f (g x) ===> ([v = g x], f v) + +cpeRhsE env (Type ty) + = return (emptyFloats, Type (cpSubstTy env ty)) +cpeRhsE env (Coercion co) + = return (emptyFloats, Coercion (cpSubstCo env co)) +cpeRhsE env expr@(Lit (LitNumber nt i)) + = case cpe_convertNumLit env nt i of + Nothing -> return (emptyFloats, expr) + Just e -> cpeRhsE env e +cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr +cpeRhsE env expr@(App {}) = cpeApp env expr + +cpeRhsE env (Let bind body) + = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind + ; (body_floats, body') <- cpeRhsE env' body + ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' + Nothing -> body' + ; return (bind_floats `appendFloats` body_floats, expr') } + +cpeRhsE env (Tick tickish expr) + | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope + = do { (floats, body) <- cpeRhsE env expr + -- See [Floating Ticks in CorePrep] + ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) } + | otherwise + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, mkTick tickish' body) } + where + tickish' | Breakpoint n fvs <- tickish + -- See also 'substTickish' + = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) + | otherwise + = tickish + +cpeRhsE env (Cast expr co) + = do { (floats, expr') <- cpeRhsE env expr + ; return (floats, Cast expr' (cpSubstCo env co)) } + +cpeRhsE env expr@(Lam {}) + = do { let (bndrs,body) = collectBinders expr + ; (env', bndrs') <- cpCloneBndrs env bndrs + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } + +-- Eliminate empty case +-- See Note [Unsafe coercions] +cpeRhsE env (Case scrut _ ty []) + = do { (floats, scrut') <- cpeRhsE env scrut + ; let ty' = cpSubstTy env ty + co' = mkUnsafeCo Representational (exprType scrut') ty' + ; return (floats, Cast scrut' co') } + -- This can give rise to + -- Warning: Unsafe coercion: between unboxed and boxed value + -- but it's fine because 'scrut' diverges + +-- Eliminate unsafeEqualityProof +-- See Note [Unsafe coercions] +cpeRhsE env (Case scrut bndr _ alts) + | isUnsafeEqualityProof scrut + , isDeadBinder bndr -- We can only discard the case if the case-binder + -- is dead. It usually is, but see #18227 + , [(_, [co_var], rhs)] <- alts + , let Pair ty1 ty2 = coVarTypes co_var + the_co = mkUnsafeCo Nominal (cpSubstTy env ty1) (cpSubstTy env ty2) + env' = extendCoVarEnv env co_var the_co + = cpeRhsE env' rhs + +cpeRhsE env (Case scrut bndr ty alts) + = do { (floats, scrut') <- cpeBody env scrut + ; (env', bndr2) <- cpCloneBndr env bndr + ; let alts' + -- This flag is intended to aid in debugging strictness + -- analysis bugs. These are particularly nasty to chase down as + -- they may manifest as segmentation faults. When this flag is + -- enabled we instead produce an 'error' expression to catch + -- the case where a function we think should bottom + -- unexpectedly returns. + | gopt Opt_CatchBottoms (cpe_dynFlags env) + , not (altsAreExhaustive alts) + = addDefault alts (Just err) + | otherwise = alts + where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty + "Bottoming expression returned" + ; alts'' <- mapM (sat_alt env') alts' + + ; return (floats, Case scrut' bndr2 ty alts'') } + where + sat_alt env (con, bs, rhs) + = do { (env2, bs') <- cpCloneBndrs env bs + ; rhs' <- cpeBodyNF env2 rhs + ; return (con, bs', rhs') } + +-- --------------------------------------------------------------------------- +-- CpeBody: produces a result satisfying CpeBody +-- --------------------------------------------------------------------------- + +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without +-- producing any floats (any generated floats are immediately +-- let-bound using 'wrapBinds'). Generally you want this, esp. +-- when you've reached a binding form (e.g., a lambda) and +-- floating any further would be incorrect. +cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody +cpeBodyNF env expr + = do { (floats, body) <- cpeBody env expr + ; return (wrapBinds floats body) } + +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce +-- a list of 'Floats' which are being propagated upwards. In +-- fact, this function is used in only two cases: to +-- implement 'cpeBodyNF' (which is what you usually want), +-- and in the case when a let-binding is in a case scrutinee--here, +-- we can always float out: +-- +-- case (let x = y in z) of ... +-- ==> let x = y in case z of ... +-- +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody env expr + = do { (floats1, rhs) <- cpeRhsE env expr + ; (floats2, body) <- rhsToBody rhs + ; return (floats1 `appendFloats` floats2, body) } + +-------- +rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) +-- Remove top level lambdas by let-binding + +rhsToBody (Tick t expr) + | tickishScoped t == NoScope -- only float out of non-scoped annotations + = do { (floats, expr') <- rhsToBody expr + ; return (floats, mkTick t expr') } + +rhsToBody (Cast e co) + -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + = do { (floats, e') <- rhsToBody e + ; return (floats, Cast e' co) } + +rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep bndrs body + = return (emptyFloats, no_lam_result) + | all isTyVar bndrs -- Type lambdas are ok + = return (emptyFloats, expr) + | otherwise -- Some value lambdas + = do { let rhs = cpeEtaExpand (exprArity expr) expr + ; fn <- newVar (exprType rhs) + ; let float = FloatLet (NonRec fn rhs) + ; return (unitFloat float, Var fn) } + where + (bndrs,body) = collectBinders expr + +rhsToBody expr = return (emptyFloats, expr) + + + +-- --------------------------------------------------------------------------- +-- CpeApp: produces a result satisfying CpeApp +-- --------------------------------------------------------------------------- + +data ArgInfo = CpeApp CoreArg + | CpeCast Coercion + | CpeTick (Tickish Id) + +instance Outputable ArgInfo where + ppr (CpeApp arg) = text "app" <+> ppr arg + ppr (CpeCast co) = text "cast" <+> ppr co + ppr (CpeTick tick) = text "tick" <+> ppr tick + +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- May return a CpeRhs because of saturating primops +cpeApp top_env expr + = do { let (terminal, args, depth) = collect_args expr + ; cpe_app top_env terminal args depth + } + + where + -- We have a nested data structure of the form + -- e `App` a1 `App` a2 ... `App` an, convert it into + -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth) + -- We use 'ArgInfo' because we may also need to + -- record casts and ticks. Depth counts the number + -- of arguments that would consume strictness information + -- (so, no type or coercion arguments.) + collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int) + collect_args e = go e [] 0 + where + go (App fun arg) as !depth + = go fun (CpeApp arg : as) + (if isTyCoArg arg then depth else depth + 1) + go (Cast fun co) as depth + = go fun (CpeCast co : as) depth + go (Tick tickish fun) as depth + | tickishPlace tickish == PlaceNonLam + && tickish `tickishScopesLike` SoftScope + = go fun (CpeTick tickish : as) depth + go terminal as depth = (terminal, as, depth) + + cpe_app :: CorePrepEnv + -> CoreExpr + -> [ArgInfo] + -> Int + -> UniqSM (Floats, CpeRhs) + cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth + | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and + || f `hasKey` noinlineIdKey -- Replace (noinline a) with a + -- Consider the code: + -- + -- lazy (f x) y + -- + -- We need to make sure that we need to recursively collect arguments on + -- "f x", otherwise we'll float "f x" out (it's not a variable) and + -- end up with this awful -ddump-prep: + -- + -- case f x of f_x { + -- __DEFAULT -> f_x y + -- } + -- + -- rather than the far superior "f x y". Test case is par01. + = let (terminal, args', depth') = collect_args arg + in cpe_app env terminal (args' ++ args) (depth + depth' - 1) + + -- See Note [keepAlive# magic]. + cpe_app env + (Var f) + args + n + | Just KeepAliveOp <- isPrimOpId_maybe f + , CpeApp (Type arg_rep) + : CpeApp (Type arg_ty) + : CpeApp (Type _result_rep) + : CpeApp (Type result_ty) + : CpeApp arg + : CpeApp s0 + : CpeApp k + : rest <- args + = do { y <- newVar (cpSubstTy env result_ty) + ; s2 <- newVar realWorldStatePrimTy + ; -- beta reduce if possible + ; (floats, k') <- case k of + Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2) + _ -> cpe_app env k (CpeApp s0 : rest) (n-1) + ; let touchId = mkPrimOpId TouchOp + expr = Case k' y result_ty [(DEFAULT, [], rhs)] + rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId] + in Case scrut s2 result_ty [(DEFAULT, [], Var y)] + ; (floats', expr') <- cpeBody env expr + ; return (floats `appendFloats` floats', expr') + } + | Just KeepAliveOp <- isPrimOpId_maybe f + = panic "invalid keepAlive# application" + + cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n + | f `hasKey` runRWKey + -- N.B. While it may appear that n == 1 in the case of runRW# + -- applications, keep in mind that we may have applications that return + , n >= 1 + -- See Note [runRW magic] + -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this + -- is why we return a CorePrepEnv as well) + = case arg of + Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2) + _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1) + -- TODO: What about casts? + + cpe_app env (Var v) args depth + = do { v1 <- fiddleCCall v + ; let e2 = lookupCorePrepEnv env v1 + hd = getIdFromTrivialExpr_maybe e2 + -- NB: depth from collect_args is right, because e2 is a trivial expression + -- and thus its embedded Id *must* be at the same depth as any + -- Apps it is under are type applications only (c.f. + -- exprIsTrivial). But note that we need the type of the + -- expression, not the id. + ; (app, floats) <- rebuild_app env args e2 emptyFloats stricts + ; mb_saturate hd app floats depth } + where + stricts = case idStrictness v of + StrictSig (DmdType _ demands _) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd + + -- We inlined into something that's not a var and has no args. + -- Bounce it back up to cpeRhsE. + cpe_app env fun [] _ = cpeRhsE env fun + + -- N-variable fun, better let-bind it + cpe_app env fun args depth + = do { (fun_floats, fun') <- cpeArg env evalDmd fun + -- The evalDmd says that it's sure to be evaluated, + -- so we'll end up case-binding it + ; (app, floats) <- rebuild_app env args fun' fun_floats [] + ; mb_saturate Nothing app floats depth } + + -- Saturate if necessary + mb_saturate head app floats depth = + case head of + Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth + ; return (floats, sat_app) } + _other -> return (floats, app) + + -- Deconstruct and rebuild the application, floating any non-atomic + -- arguments to the outside. We collect the type of the expression, + -- the head of the application, and the number of actual value arguments, + -- all of which are used to possibly saturate this application if it + -- has a constructor or primop at the head. + rebuild_app + :: CorePrepEnv + -> [ArgInfo] -- The arguments (inner to outer) + -> CpeApp + -> Floats + -> [Demand] + -> UniqSM (CpeApp, Floats) + rebuild_app _ [] app floats ss + = ASSERT(null ss) -- make sure we used all the strictness info + return (app, floats) + + rebuild_app env (a : as) fun' floats ss = case a of + + CpeApp (Type arg_ty) + -> rebuild_app env as (App fun' (Type arg_ty')) floats ss + where + arg_ty' = cpSubstTy env arg_ty + + CpeApp (Coercion co) + -> rebuild_app env as (App fun' (Coercion co')) floats ss + where + co' = cpSubstCo env co + + CpeApp arg -> do + let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make + = case (ss, isLazyExpr arg) of + (_ : ss_rest, True) -> (topDmd, ss_rest) + (ss1 : ss_rest, False) -> (ss1, ss_rest) + ([], _) -> (topDmd, []) + (fs, arg') <- cpeArg top_env ss1 arg + rebuild_app env as (App fun' arg') (fs `appendFloats` floats) ss_rest + + CpeCast co + -> rebuild_app env as (Cast fun' co') floats ss + where + co' = cpSubstCo env co + + CpeTick tickish + -- See [Floating Ticks in CorePrep] + -> rebuild_app env as fun' (addFloat floats (FloatTick tickish)) ss + +isLazyExpr :: CoreExpr -> Bool +-- See Note [lazyId magic] in GHC.Types.Id.Make +isLazyExpr (Cast e _) = isLazyExpr e +isLazyExpr (Tick _ e) = isLazyExpr e +isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey +isLazyExpr _ = False + +{- Note [runRW magic] +~~~~~~~~~~~~~~~~~~~~~ +Some definitions, for instance @runST@, must have careful control over float out +of the bindings in their body. Consider this use of @runST@, + + f x = runST ( \ s -> let (a, s') = newArray# 100 [] s + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' ) + +If we inline @runST@, we'll get: + + f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +And now if we allow the @newArray#@ binding to float out to become a CAF, +we end up with a result that is totally and utterly wrong: + + f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! + in \ x -> + let (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +All calls to @f@ will share a {\em single} array! Clearly this is nonsense and +must be prevented. + +This is what @runRW#@ gives us: by being inlined extremely late in the +optimization (right before lowering to STG, in CorePrep), we can ensure that +no further floating will occur. This allows us to safely inline things like +@runST@, which are otherwise needlessly expensive (see #10678 and #5916). + +'runRW' has a variety of quirks: + + * 'runRW' is known-key with a NOINLINE definition in + GHC.Magic. This definition is used in cases where runRW is curried. + + * In addition to its normal Haskell definition in GHC.Magic, we give it + a special late inlining here in CorePrep and GHC.CoreToByteCode, avoiding + the incorrect sharing due to float-out noted above. + + * It is levity-polymorphic: + + runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) + => (State# RealWorld -> (# State# RealWorld, o #)) + -> (# State# RealWorld, o #) + + * It has some special simplification logic to allow unboxing of results when + runRW# appears in a strict context. See Note [Simplification of runRW#] + below. + + * Since its body is inlined, we allow runRW#'s argument to contain jumps to + join points. That is, the following is allowed: + + join j x = ... + in runRW# @_ @_ (\s -> ... jump j 42 ...) + + The Core Linter knows about this. See Note [Linting of runRW#] in + GHC.Core.Lint for details. + + The occurrence analyser and SetLevels also know about this, as described in + Note [Simplification of runRW#]. + +Other relevant Notes: + + * Note [Simplification of runRW#] below, describing a transformation of runRW + applications in strict contexts performed by the simplifier. + * Note [Linting of runRW#] in GHC.Core.Lint + * Note [runRW arg] below, describing a non-obvious case where the + late-inlining could go wrong. + + + Note [runRW arg] +~~~~~~~~~~~~~~~~~~~ +Consider the Core program (from #11291), + + runRW# (case bot of {}) + +The late inlining logic in cpe_app would transform this into: + + (case bot of {}) realWorldPrimId# + +Which would rise to a panic in CoreToStg.myCollectArgs, which expects only +variables in function position. + +However, as runRW#'s strictness signature captures the fact that it will call +its argument this can't happen: the simplifier will transform the bottoming +application into simply (case bot of {}). + +Note that this reasoning does *not* apply to non-bottoming continuations like: + + hello :: Bool -> Int + hello n = + runRW# ( + case n of + True -> \s -> 23 + _ -> \s -> 10) + +Why? The difference is that (case bot of {}) is considered by okCpeArg to be +trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both +the function and the arguments) will forgo binding it to a variable. By +contrast, in the non-bottoming case of `hello` above the function will be +deemed non-trivial and consequently will be case-bound. + + +Note [Simplification of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the program, + + case runRW# (\s -> I# 42#) of + I# n# -> f n# + +There is no reason why we should allocate an I# constructor given that we +immediately destructure it. + +To avoid this the simplifier has a special transformation rule, specific to +runRW#, that pushes a strict context into runRW#'s continuation. See the +`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`. That is, it transforms + + K[ runRW# @r @ty cont ] + ~> + runRW# @r @ty (\s -> K[cont s]) + +This has a few interesting implications. Consider, for instance, this program: + + join j = ... + in case runRW# @r @ty cont of + result -> jump j result + +Performing the transform described above would result in: + + join j x = ... + in runRW# @r @ty (\s -> + case cont of in + result -> jump j result + ) + +If runRW# were a "normal" function this call to join point j would not be +allowed in its continuation argument. However, since runRW# is inlined (as +described in Note [runRW magic] above), such join point occurences are +completely fine. Both occurrence analysis (see the runRW guard in occAnalApp) +and Core Lint (see the App case of lintCoreExpr) have special treatment for +runRW# applications. See Note [Linting of runRW#] for details on the latter. + +Moreover, it's helpful to ensure that runRW's continuation isn't floated out +For instance, if we have + + runRW# (\s -> do_something) + +where do_something contains only top-level free variables, we may be tempted to +float the argument to the top-level. However, we must resist this urge as since +doing so would then require that runRW# produce an allocation and call, e.g.: + + let lvl = \s -> do_somethign + in + ....(runRW# lvl).... + +whereas without floating the inlining of the definition of runRW would result +in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special +treatment for runRW# applications, ensure the arguments are not floated as +MFEs. + +Now that we float evaluation context into runRW#, we also have to give runRW# a +special higher-order CPR transformer lest we risk #19822. E.g., + + case runRW# (\s -> doThings) of x -> Data.Text.Text x something something' + ~> + runRW# (\s -> case doThings s of x -> Data.Text.Text x something something') + +The former had the CPR property, and so should the latter. + +Other considered designs +------------------------ + +One design that was rejected was to *require* that runRW#'s continuation be +headed by a lambda. However, this proved to be quite fragile. For instance, +SetLevels is very eager to float bottoming expressions. For instance given +something of the form, + + runRW# @r @ty (\s -> case expr of x -> undefined) + +SetLevels will see that the body the lambda is bottoming and will consequently +float it to the top-level (assuming expr has no free coercion variables which +prevent this). We therefore end up with + + runRW# @r @ty (\s -> lvl s) + +Which the simplifier will beta reduce, leaving us with + + runRW# @r @ty lvl + +Breaking our desired invariant. Ultimately we decided to simply accept that +the continuation may not be a manifest lambda. + + +-- --------------------------------------------------------------------------- +-- CpeArg: produces a result satisfying CpeArg +-- --------------------------------------------------------------------------- + +Note [ANF-ising literal string arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a program like, + + data Foo = Foo Addr# + + foo = Foo "turtle"# + +When we go to ANFise this we might think that we want to float the string +literal like we do any other non-trivial argument. This would look like, + + foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s } + +However, this 1) isn't necessary since strings are in a sense "trivial"; and 2) +wreaks havoc on the CAF annotations that we produce here since we the result +above is caffy since it is updateable. Ideally at some point in the future we +would like to just float the literal to the top level as suggested in #11312, + + s = "turtle"# + foo = Foo s + +However, until then we simply add a special case excluding literals from the +floating done by cpeArg. +-} + +mkUnsafeCo :: Role -> Type -> Type -> Coercion +mkUnsafeCo role ty1 ty2 = mkUnivCo CorePrepProv role ty1 ty2 + +-- | Is an argument okay to CPE? +okCpeArg :: CoreExpr -> Bool +-- Don't float literals. See Note [ANF-ising literal string arguments]. +okCpeArg (Lit _) = False +-- Do not eta expand a trivial argument +okCpeArg expr = not (exprIsTrivial expr) + +-- This is where we arrange that a non-trivial argument is let-bound +cpeArg :: CorePrepEnv -> Demand + -> CoreArg -> UniqSM (Floats, CpeArg) +cpeArg env dmd arg + = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + ; let arg_ty = exprType arg1 + is_unlifted = isUnliftedType arg_ty + want_float = wantFloatNested NonRecursive dmd is_unlifted + ; (floats2, arg2) <- if want_float floats1 arg1 + then return (floats1, arg1) + else dontFloat floats1 arg1 + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds + + ; if okCpeArg arg2 + then do { v <- newVar arg_ty + ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 + arg_float = mkFloat dmd is_unlifted v arg3 + ; return (addFloat floats2 arg_float, varToCoreExpr v) } + else return (floats2, arg2) + } + +{- +Note [Floating unlifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider C (let v* = expensive in v) + +where the "*" indicates "will be demanded". Usually v will have been +inlined by now, but let's suppose it hasn't (see #2756). Then we +do *not* want to get + + let v* = expensive in C v + +because that has different strictness. Hence the use of 'allLazy'. +(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) + + +------------------------------------------------------------------------------ +-- Building the saturated syntax +-- --------------------------------------------------------------------------- + +Note [Eta expansion of hasNoBinding things in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +maybeSaturate deals with eta expanding to saturate things that can't deal with +unsaturated applications (identified by 'hasNoBinding', currently just +foreign calls and unboxed tuple/sum constructors). + +Historical Note: Note that eta expansion in CorePrep used to be very fragile +due to the "prediction" of CAFfyness that we used to make during tidying. +We previously saturated primop +applications here as well but due to this fragility (see #16846) we now deal +with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. +-} + +maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs +maybeSaturate fn expr n_args + | hasNoBinding fn -- There's no binding + = return sat_expr + + | otherwise + = return expr + where + fn_arity = idArity fn + excess_arity = fn_arity - n_args + sat_expr = cpeEtaExpand excess_arity expr + +{- +************************************************************************ +* * + Simple GHC.Core operations +* * +************************************************************************ +-} + +{- +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- + +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~~ +Eta expand to match the arity claimed by the binder Remember, +CorePrep must not change arity + +Eta expansion might not have happened already, because it is done by +the simplifier only when there at least one lambda already. + +NB1:we could refrain when the RHS is trivial (which can happen + for exported things). This would reduce the amount of code + generated (a little) and make things a little words for + code compiled without -O. The case in point is data constructor + wrappers. + +NB2: we have to be careful that the result of etaExpand doesn't + invalidate any of the assumptions that CorePrep is attempting + to establish. One possible cause is eta expanding inside of + an SCC note - we're now careful in etaExpand to make sure the + SCC is pushed inside any new lambdas that are generated. + +Note [Eta expansion and the CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out to be much much easier to do eta expansion +*after* the main CorePrep stuff. But that places constraints +on the eta expander: given a CpeRhs, it must return a CpeRhs. + +For example here is what we do not want: + f = /\a -> g (h 3) -- h has arity 2 +After ANFing we get + f = /\a -> let s = h 3 in g s +and now we do NOT want eta expansion to give + f = /\a -> \ y -> (let s = h 3 in g s) y + +Instead GHC.Core.Opt.Arity.etaExpand gives + f = /\a -> \y -> let s = h 3 in g s y + +-} + +cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs +cpeEtaExpand arity expr + | arity == 0 = expr + | otherwise = etaExpand arity expr + +{- +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- + +Why try eta reduction? Hasn't the simplifier already done eta? +But the simplifier only eta reduces if that leaves something +trivial (like f, or f Int). But for deLam it would be enough to +get to a partial application: + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } +-} + +-- When updating this function, make sure it lines up with +-- GHC.Core.Utils.tryEtaReduce! +tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr +tryEtaReducePrep bndrs expr@(App _ _) + | ok_to_eta_reduce f + , n_remaining >= 0 + , and (zipWith ok bndrs last_args) + , not (any (`elemVarSet` fvs_remaining) bndrs) + , exprIsHNF remaining_expr -- Don't turn value into a non-value + -- else the behaviour with 'seq' changes + = Just remaining_expr + where + (f, args) = collectArgs expr + remaining_expr = mkApps f remaining_args + fvs_remaining = exprFreeVars remaining_expr + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs + + ok bndr (Var arg) = bndr == arg + ok _ _ = False + + -- We can't eta reduce something which must be saturated. + ok_to_eta_reduce (Var f) = not (hasNoBinding f) && not (isLinearType (idType f)) + ok_to_eta_reduce _ = False -- Safe. ToDo: generalise + + +tryEtaReducePrep bndrs (Tick tickish e) + | tickishFloatable tickish + = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e + +tryEtaReducePrep _ _ = Nothing + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ + +Note [Pin demand info on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin demand info on floated lets, so that we can see the one-shot thunks. +-} + +data FloatingBind + = FloatLet CoreBind -- Rhs of bindings are CpeRhss + -- They are always of lifted type; + -- unlifted ones are done with FloatCase + + | FloatCase + CpeBody -- Always ok-for-speculation + Id -- Case binder + AltCon [Var] -- Single alternative + Bool -- Ok-for-speculation; False of a strict, + -- but lifted binding + + -- | See Note [Floating Ticks in CorePrep] + | FloatTick (Tickish Id) + +data Floats = Floats OkToSpec (OrdList FloatingBind) + +instance Outputable FloatingBind where + ppr (FloatLet b) = ppr b + ppr (FloatCase r b k bs ok) = text "case" <> braces (ppr ok) <+> ppr r + <+> text "of"<+> ppr b <> text "@" + <> case bs of + [] -> ppr k + _ -> parens (ppr k <+> ppr bs) + ppr (FloatTick t) = ppr t + +instance Outputable Floats where + ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+> + braces (vcat (map ppr (fromOL fs))) + +instance Outputable OkToSpec where + ppr OkToSpec = text "OkToSpec" + ppr IfUnboxedOk = text "IfUnboxedOk" + ppr NotOkToSpec = text "NotOkToSpec" + +-- Can we float these binds out of the rhs of a let? We cache this decision +-- to avoid having to recompute it in a non-linear way when there are +-- deeply nested lets. +data OkToSpec + = OkToSpec -- Lazy bindings of lifted type + | IfUnboxedOk -- A mixture of lazy lifted bindings and n + -- ok-to-speculate unlifted bindings + | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings + +mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind +mkFloat dmd is_unlifted bndr rhs + | is_strict + , not is_hnf = FloatCase rhs bndr DEFAULT [] (exprOkForSpeculation rhs) + -- Don't make a case for a HNF binding, even if it's strict + -- Otherwise we get case (\x -> e) of ...! + + | is_unlifted = ASSERT2( exprOkForSpeculation rhs, ppr rhs ) + FloatCase rhs bndr DEFAULT [] True + | is_hnf = FloatLet (NonRec bndr rhs) + | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) + -- See Note [Pin demand info on floats] + where + is_hnf = exprIsHNF rhs + is_strict = isStrictDmd dmd + +emptyFloats :: Floats +emptyFloats = Floats OkToSpec nilOL + +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ bs) = isNilOL bs + +wrapBinds :: Floats -> CpeBody -> CpeBody +wrapBinds (Floats _ binds) body + = foldrOL mk_bind body binds + where + mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [(con,bs,body)] + mk_bind (FloatLet bind) body = Let bind body + mk_bind (FloatTick tickish) body = mkTick tickish body + +addFloat :: Floats -> FloatingBind -> Floats +addFloat (Floats ok_to_spec floats) new_float + = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) + where + check (FloatLet {}) = OkToSpec + check (FloatCase _ _ _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + check FloatTick{} = OkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level + +unitFloat :: FloatingBind -> Floats +unitFloat = addFloat emptyFloats + +appendFloats :: Floats -> Floats -> Floats +appendFloats (Floats spec1 floats1) (Floats spec2 floats2) + = Floats (combine spec1 spec2) (floats1 `appOL` floats2) + +concatFloats :: [Floats] -> OrdList FloatingBind +concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL + +combine :: OkToSpec -> OkToSpec -> OkToSpec +combine NotOkToSpec _ = NotOkToSpec +combine _ NotOkToSpec = NotOkToSpec +combine IfUnboxedOk _ = IfUnboxedOk +combine _ IfUnboxedOk = IfUnboxedOk +combine _ _ = OkToSpec + +deFloatTop :: Floats -> [CoreBind] +-- For top level only; we don't expect any FloatCases +deFloatTop (Floats _ floats) + = foldrOL get [] floats + where + get (FloatLet b) bs = get_bind b : bs + get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs + get b _ = pprPanic "corePrepPgm" (ppr b) + + -- See Note [Dead code in CorePrep] + get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) + get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] + +--------------------------------------------------------------------------- + +canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) +canFloat (Floats ok_to_spec fs) rhs + | OkToSpec <- ok_to_spec -- Worth trying + , Just fs' <- go nilOL (fromOL fs) + = Just (Floats OkToSpec fs', rhs) + | otherwise + = Nothing + where + go :: OrdList FloatingBind -> [FloatingBind] + -> Maybe (OrdList FloatingBind) + + go (fbs_out) [] = Just fbs_out + + go fbs_out (fb@(FloatLet _) : fbs_in) + = go (fbs_out `snocOL` fb) fbs_in + + go fbs_out (ft@FloatTick{} : fbs_in) + = go (fbs_out `snocOL` ft) fbs_in + + go _ (FloatCase{} : _) = Nothing + + +wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool +wantFloatNested is_rec dmd is_unlifted floats rhs + = isEmptyFloats floats + || isStrictDmd dmd + || is_unlifted + || (allLazyNested is_rec floats && exprIsHNF rhs) + -- Why the test for allLazyNested? + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early + +allLazyTop :: Floats -> Bool +allLazyTop (Floats OkToSpec _) = True +allLazyTop _ = False + +allLazyNested :: RecFlag -> Floats -> Bool +allLazyNested _ (Floats OkToSpec _) = True +allLazyNested _ (Floats NotOkToSpec _) = False +allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec + +{- +************************************************************************ +* * + Cloning +* * +************************************************************************ +-} + +-- --------------------------------------------------------------------------- +-- The environment +-- --------------------------------------------------------------------------- + +{- Note [Inlining in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a subtle but important invariant that must be upheld in the output +of CorePrep: there are no "trivial" updatable thunks. Thus, this Core +is impermissible: + + let x :: () + x = y + +(where y is a reference to a GLOBAL variable). Thunks like this are silly: +they can always be profitably replaced by inlining x with y. Consequently, +the code generator/runtime does not bother implementing this properly +(specifically, there is no implementation of stg_ap_0_upd_info, which is the +stack frame that would be used to update this thunk. The "0" means it has +zero free variables.) + +In general, the inliner is good at eliminating these let-bindings. However, +there is one case where these trivial updatable thunks can arise: when +we are optimizing away 'lazy' (see Note [lazyId magic], and also +'cpeRhsE'.) Then, we could have started with: + + let x :: () + x = lazy @ () y + +which is a perfectly fine, non-trivial thunk, but then CorePrep will +drop 'lazy', giving us 'x = y' which is trivial and impermissible. +The solution is CorePrep to have a miniature inlining pass which deals +with cases like this. We can then drop the let-binding altogether. + +Why does the removal of 'lazy' have to occur in CorePrep? +The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the +main reason is that lazy must appear in unfoldings (optimizer +output) and it must prevent call-by-value for catch# (which +is implemented by CorePrep.) + +An alternate strategy for solving this problem is to have the +inliner treat 'lazy e' as a trivial expression if 'e' is trivial. +We decided not to adopt this solution to keep the definition +of 'exprIsTrivial' simple. + +There is ONE caveat however: for top-level bindings we have +to preserve the binding so that we float the (hacky) non-recursive +binding for data constructors; see Note [Data constructor workers]. + +Note [CorePrep inlines trivial CoreExpr not Id] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an +IdEnv Id? Naively, we might conjecture that trivial updatable thunks +as per Note [Inlining in CorePrep] always have the form +'lazy @ SomeType gbl_id'. But this is not true: the following is +perfectly reasonable Core: + + let x :: () + x = lazy @ (forall a. a) y @ Bool + +When we inline 'x' after eliminating 'lazy', we need to replace +occurrences of 'x' with 'y @ bool', not just 'y'. Situations like +this can easily arise with higher-rank types; thus, cpe_env must +map to CoreExprs, not Ids. + +-} + +data CorePrepEnv + = CPE { cpe_dynFlags :: DynFlags + , cpe_env :: IdEnv CoreExpr -- Clone local Ids + -- ^ This environment is used for three operations: + -- + -- 1. To support cloning of local Ids so that they are + -- all unique (see item (6) of CorePrep overview). + -- + -- 2. To support beta-reduction of runRW, see + -- Note [runRW magic] and Note [runRW arg]. + -- + -- 3. To let us inline trivial RHSs of non top-level let-bindings, + -- see Note [lazyId magic], Note [Inlining in CorePrep] + -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076) + + , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv] + + , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr + -- ^ Convert some numeric literals (Integer, Natural) into their + -- final Core form + } + +mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv +mkInitialCorePrepEnv hsc_env = do + convertNumLit <- mkConvertNumLiteral hsc_env + return $ CPE + { cpe_dynFlags = hsc_dflags hsc_env + , cpe_env = emptyVarEnv + , cpe_tyco_env = Nothing + , cpe_convertNumLit = convertNumLit + } + +extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv +extendCorePrepEnv cpe id id' + = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') } + +extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv +extendCorePrepEnvExpr cpe id expr + = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr } + +extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv +extendCorePrepEnvList cpe prs + = cpe { cpe_env = extendVarEnvList (cpe_env cpe) + (map (\(id, id') -> (id, Var id')) prs) } + +lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr +lookupCorePrepEnv cpe id + = case lookupVarEnv (cpe_env cpe) id of + Nothing -> Var id + Just exp -> exp + +------------------------------------------------------------------------------ +-- CpeTyCoEnv +-- --------------------------------------------------------------------------- + +{- Note [CpeTyCoEnv] +~~~~~~~~~~~~~~~~~~~~ +The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution +for type and coercion varibles + +* We need the coercion substitution to support the elimination of + unsafeEqualityProof (see Note [Unsafe coercions]) + +* We need the type substitution in case one of those unsafe + coercions occurs in the kind of tyvar binder (sigh) + +We don't need an in-scope set because we don't clone any of these +binders at all, so no new capture can take place. + +The cpe_tyco_env is almost always empty -- it only gets populated +when we get under an usafeEqualityProof. Hence the Maybe CpeTyCoEnv, +which makes everything into a no-op in the common case. +-} + +data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv + +emptyTCE :: CpeTyCoEnv +emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv + +extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv +extend_tce_cv (TCE tv_env cv_env) cv co + = TCE tv_env (extendVarEnv cv_env cv co) + +extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv +extend_tce_tv (TCE tv_env cv_env) tv ty + = TCE (extendVarEnv tv_env tv ty) cv_env + +lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion +lookup_tce_cv (TCE _ cv_env) cv + = case lookupVarEnv cv_env cv of + Just co -> co + Nothing -> mkCoVarCo cv + +lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type +lookup_tce_tv (TCE tv_env _) tv + = case lookupVarEnv tv_env tv of + Just ty -> ty + Nothing -> mkTyVarTy tv + +extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv +extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co + = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) } + where + tce = mb_tce `orElse` emptyTCE + + +cpSubstTy :: CorePrepEnv -> Type -> Type +cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty + = case mb_env of + Just env -> runIdentity (subst_ty env ty) + Nothing -> ty + +cpSubstCo :: CorePrepEnv -> Coercion -> Coercion +cpSubstCo (CPE { cpe_tyco_env = mb_env }) co + = case mb_env of + Just tce -> runIdentity (subst_co tce co) + Nothing -> co + +subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity +subst_tyco_mapper = TyCoMapper + { tcm_tyvar = \env tv -> return (lookup_tce_tv env tv) + , tcm_covar = \env cv -> return (lookup_tce_cv env cv) + , tcm_hole = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole) + , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv + then return (subst_tv_bndr env tcv) + else return (subst_cv_bndr env tcv) + , tcm_tycon = \tc -> return tc } + +subst_ty :: CpeTyCoEnv -> Type -> Identity Type +subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion +(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper + +cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar) +cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv + = case mb_env of + Nothing -> (env, tv) + Just tce -> (env { cpe_tyco_env = Just tce' }, tv') + where + (tce', tv') = subst_tv_bndr tce tv + +subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar) +subst_tv_bndr tce tv + = (extend_tce_tv tce tv (mkTyVarTy tv'), tv') + where + tv' = mkTyVar (tyVarName tv) kind' + kind' = runIdentity $ subst_ty tce $ tyVarKind tv + +cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar) +cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv + = case mb_env of + Nothing -> (env, cv) + Just tce -> (env { cpe_tyco_env = Just tce' }, cv') + where + (tce', cv') = subst_cv_bndr tce cv + +subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar) +subst_cv_bndr tce cv + = (extend_tce_cv tce cv (mkCoVarCo cv'), cv') + where + cv' = mkCoVar (varName cv) ty' + ty' = runIdentity (subst_ty tce $ varType cv) + +------------------------------------------------------------------------------ +-- Cloning binders +-- --------------------------------------------------------------------------- + +cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar]) +cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs + +cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) +cpCloneBndr env bndr + | isTyVar bndr + = return (cpSubstTyVarBndr env bndr) + + | isCoVar bndr + = return (cpSubstCoVarBndr env bndr) + + | otherwise + = do { bndr' <- clone_it bndr + + -- Drop (now-useless) rules/unfoldings + -- See Note [Drop unfoldings and rules] + -- and Note [Preserve evaluatedness] in GHC.Core.Tidy + ; let unfolding' = zapUnfolding (realIdUnfolding bndr) + -- Simplifier will set the Id's unfolding + + bndr'' = bndr' `setIdUnfolding` unfolding' + `setIdSpecialisation` emptyRuleInfo + + ; return (extendCorePrepEnv env bndr bndr'', bndr'') } + where + clone_it bndr + | isLocalId bndr + = do { uniq <- getUniqueM + ; let ty' = cpSubstTy env (idType bndr) + ; return (setVarUnique (setIdType bndr ty') uniq) } + + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + = return bndr + +{- Note [Drop unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to drop the unfolding/rules on every Id: + + - We are now past interface-file generation, and in the + codegen pipeline, so we really don't need full unfoldings/rules + + - The unfolding/rule may be keeping stuff alive that we'd like + to discard. See Note [Dead code in CorePrep] + + - Getting rid of unnecessary unfoldings reduces heap usage + + - We are changing uniques, so if we didn't discard unfoldings/rules + we'd have to substitute in them + +HOWEVER, we want to preserve evaluated-ness; +see Note [Preserve evaluatedness] in GHC.Core.Tidy. +-} + +------------------------------------------------------------------------------ +-- Cloning ccall Ids; each must have a unique name, +-- to give the code generator a handle to hang it on +-- --------------------------------------------------------------------------- + +fiddleCCall :: Id -> UniqSM Id +fiddleCCall id + | isFCallId id = (id `setVarUnique`) <$> getUniqueM + | otherwise = return id + +------------------------------------------------------------------------------ +-- Generating new binders +-- --------------------------------------------------------------------------- + +newVar :: Type -> UniqSM Id +newVar ty + = seqType ty `seq` do + uniq <- getUniqueM + return (mkSysLocalOrCoVar (fsLit "sat") uniq Many ty) + + +------------------------------------------------------------------------------ +-- Floating ticks +-- --------------------------------------------------------------------------- +-- +-- Note [Floating Ticks in CorePrep] +-- +-- It might seem counter-intuitive to float ticks by default, given +-- that we don't actually want to move them if we can help it. On the +-- other hand, nothing gets very far in CorePrep anyway, and we want +-- to preserve the order of let bindings and tick annotations in +-- relation to each other. For example, if we just wrapped let floats +-- when they pass through ticks, we might end up performing the +-- following transformation: +-- +-- src<...> let foo = bar in baz +-- ==> let foo = src<...> bar in src<...> baz +-- +-- Because the let-binding would float through the tick, and then +-- immediately materialize, achieving nothing but decreasing tick +-- accuracy. The only special case is the following scenario: +-- +-- let foo = src<...> (let a = b in bar) in baz +-- ==> let foo = src<...> bar; a = src<...> b in baz +-- +-- Here we would not want the source tick to end up covering "baz" and +-- therefore refrain from pushing ticks outside. Instead, we copy them +-- into the floating binds (here "a") in cpePair. Note that where "b" +-- or "bar" are (value) lambdas we have to push the annotations +-- further inside in order to uphold our rules. +-- +-- All of this is implemented below in @wrapTicks@. + +-- | Like wrapFloats, but only wraps tick floats +wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) +wrapTicks (Floats flag floats0) expr = + (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1)) + where (floats1, ticks1) = foldlOL go ([], []) $ floats0 + -- Deeply nested constructors will produce long lists of + -- redundant source note floats here. We need to eliminate + -- those early, as relying on mkTick to spot it after the fact + -- can yield O(n^3) complexity [#11095] + go (floats, ticks) (FloatTick t) + = ASSERT(tickishPlace t == PlaceNonLam) + (floats, if any (flip tickishContains t) ticks + then ticks else t:ticks) + go (floats, ticks) f + = (foldr wrap f (reverse ticks):floats, ticks) + + wrap t (FloatLet bind) = FloatLet (wrapBind t bind) + wrap t (FloatCase r b con bs ok) = FloatCase (mkTick t r) b con bs ok + wrap _ other = pprPanic "wrapTicks: unexpected float!" + (ppr other) + wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) + wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) + +------------------------------------------------------------------------------ +-- Collecting cost centres +-- --------------------------------------------------------------------------- + +-- | Collect cost centres defined in the current module, including those in +-- unfoldings. +collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre +collectCostCentres mod_name + = foldl' go_bind S.empty + where + go cs e = case e of + Var{} -> cs + Lit{} -> cs + App e1 e2 -> go (go cs e1) e2 + Lam _ e -> go cs e + Let b e -> go (go_bind cs b) e + Case scrt _ _ alts -> go_alts (go cs scrt) alts + Cast e _ -> go cs e + Tick (ProfNote cc _ _) e -> + go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e + Tick _ e -> go cs e + Type{} -> cs + Coercion{} -> cs + + go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e) + + go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre + go_bind cs (NonRec b e) = + go (maybe cs (go cs) (get_unf b)) e + go_bind cs (Rec bs) = + foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs + + -- Unfoldings may have cost centres that in the original definion are + -- optimized away, see #5889. + get_unf = maybeUnfoldingTemplate . realIdUnfolding + + +------------------------------------------------------------------------------ +-- Numeric literals +-- --------------------------------------------------------------------------- + +-- | Create a function that converts Bignum literals into their final CoreExpr +mkConvertNumLiteral + :: HscEnv + -> IO (LitNumType -> Integer -> Maybe CoreExpr) +mkConvertNumLiteral hsc_env = do + let + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + guardBignum act + | homeUnitId dflags == primUnitId + = return $ panic "Bignum literals are not supported in ghc-prim" + | homeUnitId dflags == bignumUnitId + = return $ panic "Bignum literals are not supported in ghc-bignum" + | otherwise = act + + lookupBignumId n = guardBignum (tyThingId <$> lookupGlobal hsc_env n) + + -- The lookup is done here but the failure (panic) is reported lazily when we + -- try to access the `bigNatFromWordList` function. + -- + -- If we ever get built-in ByteArray# literals, we could avoid the lookup by + -- directly using the Integer/Natural wired-in constructors for big numbers. + + bignatFromWordListId <- lookupBignumId bignatFromWordListName + + let + convertNumLit nt i = case nt of + LitNumInteger -> Just (convertInteger i) + LitNumNatural -> Just (convertNatural i) + _ -> Nothing + + convertInteger i + | platformInIntRange platform i -- fit in a Int# + = mkConApp integerISDataCon [Lit (mkLitInt platform i)] + + | otherwise -- build a BigNat and embed into IN or IP + = let con = if i > 0 then integerIPDataCon else integerINDataCon + in mkBigNum con (convertBignatPrim (abs i)) + + convertNatural i + | platformInWordRange platform i -- fit in a Word# + = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)] + + | otherwise --build a BigNat and embed into NB + = mkBigNum naturalNBDataCon (convertBignatPrim i) + + -- we can't simply generate: + -- + -- NB (bigNatFromWordList# [W# 10, W# 20]) + -- + -- using `mkConApp` because it isn't in ANF form. Instead we generate: + -- + -- case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba } + -- + -- via `mkCoreApps` + + mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba] + + convertBignatPrim i = + let + target = targetPlatform dflags + + -- ByteArray# literals aren't supported (yet). Were they supported, + -- we would use them directly. We would need to handle + -- wordSize/endianness conversion between host and target + -- wordSize = platformWordSize platform + -- byteOrder = platformByteOrder platform + + -- For now we build a list of Words and we produce + -- `bigNatFromWordList# list_of_words` + + words = mkListExpr wordTy (reverse (unfoldr f i)) + where + f 0 = Nothing + f x = let low = x .&. mask + high = x `shiftR` bits + in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high) + bits = platformWordSizeInBits target + mask = 2 ^ bits - 1 + + in mkApps (Var bignatFromWordListId) [words] + + + return convertNumLit + diff --git a/GHC/Data/Bag.hs b/GHC/Data/Bag.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Bag.hs @@ -0,0 +1,335 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Bag: an unordered collection with duplicates +-} + +{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor #-} + +module GHC.Data.Bag ( + Bag, -- abstract type + + emptyBag, unitBag, unionBags, unionManyBags, + mapBag, + elemBag, lengthBag, + filterBag, partitionBag, partitionBagWith, + concatBag, catBagMaybes, foldBag, + isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, + listToBag, bagToList, mapAccumBagL, + concatMapBag, concatMapBagPair, mapMaybeBag, + mapBagM, mapBagM_, + flatMapBagM, flatMapBagPairM, + mapAndUnzipBagM, mapAccumBagLM, + anyBagM, filterBagM + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import GHC.Utils.Monad +import Control.Monad +import Data.Data +import Data.Maybe( mapMaybe ) +import Data.List ( partition, mapAccumL ) +import qualified Data.Foldable as Foldable + +infixr 3 `consBag` +infixl 3 `snocBag` + +data Bag a + = EmptyBag + | UnitBag a + | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty + | ListBag [a] -- INVARIANT: the list is non-empty + deriving (Functor) + +emptyBag :: Bag a +emptyBag = EmptyBag + +unitBag :: a -> Bag a +unitBag = UnitBag + +lengthBag :: Bag a -> Int +lengthBag EmptyBag = 0 +lengthBag (UnitBag {}) = 1 +lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 +lengthBag (ListBag xs) = length xs + +elemBag :: Eq a => a -> Bag a -> Bool +elemBag _ EmptyBag = False +elemBag x (UnitBag y) = x == y +elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 +elemBag x (ListBag ys) = any (x ==) ys + +unionManyBags :: [Bag a] -> Bag a +unionManyBags xs = foldr unionBags EmptyBag xs + +-- This one is a bit stricter! The bag will get completely evaluated. + +unionBags :: Bag a -> Bag a -> Bag a +unionBags EmptyBag b = b +unionBags b EmptyBag = b +unionBags b1 b2 = TwoBags b1 b2 + +consBag :: a -> Bag a -> Bag a +snocBag :: Bag a -> a -> Bag a + +consBag elt bag = (unitBag elt) `unionBags` bag +snocBag bag elt = bag `unionBags` (unitBag elt) + +isEmptyBag :: Bag a -> Bool +isEmptyBag EmptyBag = True +isEmptyBag _ = False -- NB invariants + +isSingletonBag :: Bag a -> Bool +isSingletonBag EmptyBag = False +isSingletonBag (UnitBag _) = True +isSingletonBag (TwoBags _ _) = False -- Neither is empty +isSingletonBag (ListBag xs) = isSingleton xs + +filterBag :: (a -> Bool) -> Bag a -> Bag a +filterBag _ EmptyBag = EmptyBag +filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag +filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 + where sat1 = filterBag pred b1 + sat2 = filterBag pred b2 +filterBag pred (ListBag vs) = listToBag (filter pred vs) + +filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) +filterBagM _ EmptyBag = return EmptyBag +filterBagM pred b@(UnitBag val) = do + flag <- pred val + if flag then return b + else return EmptyBag +filterBagM pred (TwoBags b1 b2) = do + sat1 <- filterBagM pred b1 + sat2 <- filterBagM pred b2 + return (sat1 `unionBags` sat2) +filterBagM pred (ListBag vs) = do + sat <- filterM pred vs + return (listToBag sat) + +allBag :: (a -> Bool) -> Bag a -> Bool +allBag _ EmptyBag = True +allBag p (UnitBag v) = p v +allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 +allBag p (ListBag xs) = all p xs + +anyBag :: (a -> Bool) -> Bag a -> Bool +anyBag _ EmptyBag = False +anyBag p (UnitBag v) = p v +anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 +anyBag p (ListBag xs) = any p xs + +anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool +anyBagM _ EmptyBag = return False +anyBagM p (UnitBag v) = p v +anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 + if flag then return True + else anyBagM p b2 +anyBagM p (ListBag xs) = anyM p xs + +concatBag :: Bag (Bag a) -> Bag a +concatBag bss = foldr add emptyBag bss + where + add bs rs = bs `unionBags` rs + +catBagMaybes :: Bag (Maybe a) -> Bag a +catBagMaybes bs = foldr add emptyBag bs + where + add Nothing rs = rs + add (Just x) rs = x `consBag` rs + +partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, + Bag a {- Don't -}) +partitionBag _ EmptyBag = (EmptyBag, EmptyBag) +partitionBag pred b@(UnitBag val) + = if pred val then (b, EmptyBag) else (EmptyBag, b) +partitionBag pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBag pred b1 + (sat2, fail2) = partitionBag pred b2 +partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partition pred vs + + +partitionBagWith :: (a -> Either b c) -> Bag a + -> (Bag b {- Left -}, + Bag c {- Right -}) +partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) +partitionBagWith pred (UnitBag val) + = case pred val of + Left a -> (UnitBag a, EmptyBag) + Right b -> (EmptyBag, UnitBag b) +partitionBagWith pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBagWith pred b1 + (sat2, fail2) = partitionBagWith pred b2 +partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partitionWith pred vs + +foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative + -> (a -> r) -- Replace UnitBag with this + -> r -- Replace EmptyBag with this + -> Bag a + -> r + +{- Standard definition +foldBag t u e EmptyBag = e +foldBag t u e (UnitBag x) = u x +foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) +foldBag t u e (ListBag xs) = foldr (t.u) e xs +-} + +-- More tail-recursive definition, exploiting associativity of "t" +foldBag _ _ e EmptyBag = e +foldBag t u e (UnitBag x) = u x `t` e +foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 +foldBag t u e (ListBag xs) = foldr (t.u) e xs + +mapBag :: (a -> b) -> Bag a -> Bag b +mapBag = fmap + +concatMapBag :: (a -> Bag b) -> Bag a -> Bag b +concatMapBag _ EmptyBag = EmptyBag +concatMapBag f (UnitBag x) = f x +concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) +concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs + +concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) +concatMapBagPair _ EmptyBag = (EmptyBag, EmptyBag) +concatMapBagPair f (UnitBag x) = f x +concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2) + where + (r1, s1) = concatMapBagPair f b1 + (r2, s2) = concatMapBagPair f b2 +concatMapBagPair f (ListBag xs) = foldr go (emptyBag, emptyBag) xs + where + go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2) + where + (r1, r2) = f a + +mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b +mapMaybeBag _ EmptyBag = EmptyBag +mapMaybeBag f (UnitBag x) = case f x of + Nothing -> EmptyBag + Just y -> UnitBag y +mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) +mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) + +mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) +mapBagM _ EmptyBag = return EmptyBag +mapBagM f (UnitBag x) = do r <- f x + return (UnitBag r) +mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 + r2 <- mapBagM f b2 + return (TwoBags r1 r2) +mapBagM f (ListBag xs) = do rs <- mapM f xs + return (ListBag rs) + +mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () +mapBagM_ _ EmptyBag = return () +mapBagM_ f (UnitBag x) = f x >> return () +mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 +mapBagM_ f (ListBag xs) = mapM_ f xs + +flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) +flatMapBagM _ EmptyBag = return EmptyBag +flatMapBagM f (UnitBag x) = f x +flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 + r2 <- flatMapBagM f b2 + return (r1 `unionBags` r2) +flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs + where + k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } + +flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) +flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) +flatMapBagPairM f (UnitBag x) = f x +flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 + (r2,s2) <- flatMapBagPairM f b2 + return (r1 `unionBags` r2, s1 `unionBags` s2) +flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs + where + k x (r2,s2) = do { (r1,s1) <- f x + ; return (r1 `unionBags` r2, s1 `unionBags` s2) } + +mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) +mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) +mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x + return (UnitBag r, UnitBag s) +mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 + (r2,s2) <- mapAndUnzipBagM f b2 + return (TwoBags r1 r2, TwoBags s1 s2) +mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs + let (rs,ss) = unzip ts + return (ListBag rs, ListBag ss) + +mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> (acc, Bag y) -- ^ final state, outputs +mapAccumBagL _ s EmptyBag = (s, EmptyBag) +mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) +mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 + (s2, b2') = mapAccumBagL f s1 b2 + in (s2, TwoBags b1' b2') +mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs + in (s', ListBag xs') + +mapAccumBagLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> m (acc, Bag y) -- ^ final state, outputs +mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) +mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } +mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 + ; (s2, b2') <- mapAccumBagLM f s1 b2 + ; return (s2, TwoBags b1' b2') } +mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs + ; return (s', ListBag xs') } + +listToBag :: [a] -> Bag a +listToBag [] = EmptyBag +listToBag [x] = UnitBag x +listToBag vs = ListBag vs + +bagToList :: Bag a -> [a] +bagToList b = foldr (:) [] b + +instance (Outputable a) => Outputable (Bag a) where + ppr bag = braces (pprWithCommas ppr (bagToList bag)) + +instance Data a => Data (Bag a) where + gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly + toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Bag" + dataCast1 x = gcast1 x + +instance Foldable.Foldable Bag where + foldr _ z EmptyBag = z + foldr k z (UnitBag x) = k x z + foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 + foldr k z (ListBag xs) = foldr k z xs + + foldl _ z EmptyBag = z + foldl k z (UnitBag x) = k z x + foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 + foldl k z (ListBag xs) = foldl k z xs + + foldl' _ z EmptyBag = z + foldl' k z (UnitBag x) = k z x + foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 + foldl' k z (ListBag xs) = foldl' k z xs + +instance Traversable Bag where + traverse _ EmptyBag = pure EmptyBag + traverse f (UnitBag x) = UnitBag <$> f x + traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 + traverse f (ListBag xs) = ListBag <$> traverse f xs diff --git a/GHC/Data/Bitmap.hs b/GHC/Data/Bitmap.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Bitmap.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE BangPatterns #-} + +-- +-- (c) The University of Glasgow 2003-2006 +-- + +-- Functions for constructing bitmaps, which are used in various +-- places in generated code (stack frame liveness masks, function +-- argument liveness masks, SRT bitmaps). + +module GHC.Data.Bitmap ( + Bitmap, mkBitmap, + intsToReverseBitmap, + mAX_SMALL_BITMAP_SIZE, + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Runtime.Heap.Layout + +import Data.Bits + +{-| +A bitmap represented by a sequence of 'StgWord's on the /target/ +architecture. These are used for bitmaps in info tables and other +generated code which need to be emitted as sequences of StgWords. +-} +type Bitmap = [StgWord] + +-- | Make a bitmap from a sequence of bits +mkBitmap :: Platform -> [Bool] -> Bitmap +mkBitmap _ [] = [] +mkBitmap platform stuff = chunkToBitmap platform chunk : mkBitmap platform rest + where (chunk, rest) = splitAt (platformWordSizeInBits platform) stuff + +chunkToBitmap :: Platform -> [Bool] -> StgWord +chunkToBitmap platform chunk = + foldl' (.|.) (toStgWord platform 0) [ oneAt n | (True,n) <- zip chunk [0..] ] + where + oneAt :: Int -> StgWord + oneAt i = toStgWord platform 1 `shiftL` i + +-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap. +-- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero, +-- just to make the bitmap easier to read). +-- +-- The list of @Int@s /must/ be already sorted and duplicate-free. +intsToReverseBitmap :: Platform + -> Int -- ^ size in bits + -> [Int] -- ^ sorted indices of zeros free of duplicates + -> Bitmap +intsToReverseBitmap platform size = go 0 + where + word_sz = platformWordSizeInBits platform + oneAt :: Int -> StgWord + oneAt i = toStgWord platform 1 `shiftL` i + + -- It is important that we maintain strictness here. + -- See Note [Strictness when building Bitmaps]. + go :: Int -> [Int] -> Bitmap + go !pos slots + | size <= pos = [] + | otherwise = + (foldl' xor (toStgWord platform init) (map (\i->oneAt (i - pos)) these)) : + go (pos + word_sz) rest + where + (these,rest) = span (< (pos + word_sz)) slots + remain = size - pos + init + | remain >= word_sz = -1 + | otherwise = (1 `shiftL` remain) - 1 + +{- + +Note [Strictness when building Bitmaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One of the places where @Bitmap@ is used is in building Static Reference +Tables (SRTs) (in @GHC.Cmm.Info.Build.procpointSRT@). In #7450 it was noticed +that some test cases (particularly those whose C-- have large numbers of CAFs) +produced large quantities of allocations from this function. + +The source traced back to 'intsToBitmap', which was lazily subtracting the word +size from the elements of the tail of the @slots@ list and recursively invoking +itself with the result. This resulted in large numbers of subtraction thunks +being built up. Here we take care to avoid passing new thunks to the recursive +call. Instead we pass the unmodified tail along with an explicit position +accumulator, which get subtracted in the fold when we compute the Word. + +-} + +{- | +Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h. +Some kinds of bitmap pack a size\/bitmap into a single word if +possible, or fall back to an external pointer when the bitmap is too +large. This value represents the largest size of bitmap that can be +packed into a single word. +-} +mAX_SMALL_BITMAP_SIZE :: Platform -> Int +mAX_SMALL_BITMAP_SIZE platform = + case platformWordSize platform of + PW4 -> 27 -- On 32-bit: 5 bits for size, 27 bits for bitmap + PW8 -> 58 -- On 64-bit: 6 bits for size, 58 bits for bitmap diff --git a/GHC/Data/BooleanFormula.hs b/GHC/Data/BooleanFormula.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/BooleanFormula.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} + +-------------------------------------------------------------------------------- +-- | Boolean formulas without quantifiers and without negation. +-- Such a formula consists of variables, conjunctions (and), and disjunctions (or). +-- +-- This module is used to represent minimal complete definitions for classes. +-- +module GHC.Data.BooleanFormula ( + BooleanFormula(..), LBooleanFormula, + mkFalse, mkTrue, mkAnd, mkOr, mkVar, + isFalse, isTrue, + eval, simplify, isUnsatisfied, + implies, impliesAtom, + pprBooleanFormula, pprBooleanFormulaNice + ) where + +import GHC.Prelude + +import Data.List ( nub, intersperse ) +import Data.Data + +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Binary +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.Set + +---------------------------------------------------------------------- +-- Boolean formula type and smart constructors +---------------------------------------------------------------------- + +type LBooleanFormula a = Located (BooleanFormula a) + +data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] + | Parens (LBooleanFormula a) + deriving (Eq, Data, Functor, Foldable, Traversable) + +mkVar :: a -> BooleanFormula a +mkVar = Var + +mkFalse, mkTrue :: BooleanFormula a +mkFalse = Or [] +mkTrue = And [] + +-- Convert a Bool to a BooleanFormula +mkBool :: Bool -> BooleanFormula a +mkBool False = mkFalse +mkBool True = mkTrue + +-- Make a conjunction, and try to simplify +mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a +mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd + where + -- See Note [Simplification of BooleanFormulas] + fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] + fromAnd (L _ (And xs)) = Just xs + -- assume that xs are already simplified + -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs + fromAnd (L _ (Or [])) = Nothing + -- in case of False we bail out, And [..,mkFalse,..] == mkFalse + fromAnd x = Just [x] + mkAnd' [x] = unLoc x + mkAnd' xs = And xs + +mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a +mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr (L _ (Or xs)) = Just xs + fromOr (L _ (And [])) = Nothing + fromOr x = Just [x] + mkOr' [x] = unLoc x + mkOr' xs = Or xs + + +{- +Note [Simplification of BooleanFormulas] +~~~~~~~~~~~~~~~~~~~~~~ +The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, + 1. Collapsing nested ands and ors, so + `(mkAnd [x, And [y,z]]` + is represented as + `And [x,y,z]` + Implemented by `fromAnd`/`fromOr` + 2. Collapsing trivial ands and ors, so + `mkAnd [x]` becomes just `x`. + Implemented by mkAnd' / mkOr' + 3. Conjunction with false, disjunction with true is simplified, i.e. + `mkAnd [mkFalse,x]` becomes `mkFalse`. + 4. Common subexpression elimination: + `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. + +This simplification is not exhaustive, in the sense that it will not produce +the smallest possible equivalent expression. For example, +`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently +is not. A general simplifier would need to use something like BDDs. + +The reason behind the (crude) simplifier is to make for more user friendly +error messages. E.g. for the code + > class Foo a where + > {-# MINIMAL bar, (foo, baq | foo, quux) #-} + > instance Foo Int where + > bar = ... + > baz = ... + > quux = ... +We don't show a ridiculous error message like + Implement () and (either (`foo' and ()) or (`foo' and ())) +-} + +---------------------------------------------------------------------- +-- Evaluation and simplification +---------------------------------------------------------------------- + +isFalse :: BooleanFormula a -> Bool +isFalse (Or []) = True +isFalse _ = False + +isTrue :: BooleanFormula a -> Bool +isTrue (And []) = True +isTrue _ = False + +eval :: (a -> Bool) -> BooleanFormula a -> Bool +eval f (Var x) = f x +eval f (And xs) = all (eval f . unLoc) xs +eval f (Or xs) = any (eval f . unLoc) xs +eval f (Parens x) = eval f (unLoc x) + +-- Simplify a boolean formula. +-- The argument function should give the truth of the atoms, or Nothing if undecided. +simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a +simplify f (Var a) = case f a of + Nothing -> Var a + Just b -> mkBool b +simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) +simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) +simplify f (Parens x) = simplify f (unLoc x) + +-- Test if a boolean formula is satisfied when the given values are assigned to the atoms +-- if it is, returns Nothing +-- if it is not, return (Just remainder) +isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) +isUnsatisfied f bf + | isTrue bf' = Nothing + | otherwise = Just bf' + where + f' x = if f x then Just True else Nothing + bf' = simplify f' bf + +-- prop_simplify: +-- eval f x == True <==> isTrue (simplify (Just . f) x) +-- eval f x == False <==> isFalse (simplify (Just . f) x) + +-- If the boolean formula holds, does that mean that the given atom is always true? +impliesAtom :: Eq a => BooleanFormula a -> a -> Bool +Var x `impliesAtom` y = x == y +And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs + -- we have all of xs, so one of them implying y is enough +Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs +Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y + +implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool +implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) + where + go :: Uniquable a => Clause a -> Clause a -> Bool + go l@Clause{ clauseExprs = hyp:hyps } r = + case hyp of + Var x | memberClauseAtoms x r -> True + | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r + Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r + And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r + Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' + go l r@Clause{ clauseExprs = con:cons } = + case con of + Var x | memberClauseAtoms x l -> True + | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } + Parens con' -> go l r { clauseExprs = unLoc con':cons } + And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' + Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } + go _ _ = False + +-- A small sequent calculus proof engine. +data Clause a = Clause { + clauseAtoms :: UniqSet a, + clauseExprs :: [BooleanFormula a] + } +extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a +extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } + +memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool +memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c + +---------------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------------- + +-- Pretty print a BooleanFormula, +-- using the arguments as pretty printers for Var, And and Or respectively +pprBooleanFormula' :: (Rational -> a -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula' pprVar pprAnd pprOr = go + where + go p (Var x) = pprVar p x + go p (And []) = cparen (p > 0) $ empty + go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) + go _ (Or []) = keyword $ text "FALSE" + go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) + go p (Parens x) = go p (unLoc x) + +-- Pretty print in source syntax, "a | b | c,d,e" +pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr + where + pprAnd p = cparen (p > 3) . fsep . punctuate comma + pprOr p = cparen (p > 2) . fsep . intersperse vbar + +-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? +pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc +pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 + where + pprVar _ = quotes . ppr + pprAnd p = cparen (p > 1) . pprAnd' + pprAnd' [] = empty + pprAnd' [x,y] = x <+> text "and" <+> y + pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs + pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) + +instance (OutputableBndr a) => Outputable (BooleanFormula a) where + ppr = pprBooleanFormulaNormal + +pprBooleanFormulaNormal :: (OutputableBndr a) + => BooleanFormula a -> SDoc +pprBooleanFormulaNormal = go + where + go (Var x) = pprPrefixOcc x + go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) + go (Or []) = keyword $ text "FALSE" + go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) + go (Parens x) = parens (go $ unLoc x) + + +---------------------------------------------------------------------- +-- Binary +---------------------------------------------------------------------- + +instance Binary a => Binary (BooleanFormula a) where + put_ bh (Var x) = putByte bh 0 >> put_ bh x + put_ bh (And xs) = putByte bh 1 >> put_ bh xs + put_ bh (Or xs) = putByte bh 2 >> put_ bh xs + put_ bh (Parens x) = putByte bh 3 >> put_ bh x + + get bh = do + h <- getByte bh + case h of + 0 -> Var <$> get bh + 1 -> And <$> get bh + 2 -> Or <$> get bh + _ -> Parens <$> get bh diff --git a/GHC/Data/EnumSet.hs b/GHC/Data/EnumSet.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/EnumSet.hs @@ -0,0 +1,35 @@ +-- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' +-- things. +module GHC.Data.EnumSet + ( EnumSet + , member + , insert + , delete + , toList + , fromList + , empty + ) where + +import GHC.Prelude + +import qualified Data.IntSet as IntSet + +newtype EnumSet a = EnumSet IntSet.IntSet + +member :: Enum a => a -> EnumSet a -> Bool +member x (EnumSet s) = IntSet.member (fromEnum x) s + +insert :: Enum a => a -> EnumSet a -> EnumSet a +insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s + +delete :: Enum a => a -> EnumSet a -> EnumSet a +delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s + +toList :: Enum a => EnumSet a -> [a] +toList (EnumSet s) = map toEnum $ IntSet.toList s + +fromList :: Enum a => [a] -> EnumSet a +fromList = EnumSet . IntSet.fromList . map fromEnum + +empty :: EnumSet a +empty = EnumSet IntSet.empty diff --git a/GHC/Data/FastMutInt.hs b/GHC/Data/FastMutInt.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FastMutInt.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Unboxed mutable Ints + +module GHC.Data.FastMutInt( + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, + + FastMutPtr, newFastMutPtr, + readFastMutPtr, writeFastMutPtr + ) where + +import GHC.Prelude + +import Data.Bits +import GHC.Base +import GHC.Ptr + +newFastMutInt :: IO FastMutInt +readFastMutInt :: FastMutInt -> IO Int +writeFastMutInt :: FastMutInt -> Int -> IO () + +newFastMutPtr :: IO FastMutPtr +readFastMutPtr :: FastMutPtr -> IO (Ptr a) +writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where !(I# size) = finiteBitSize (0 :: Int) + +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) + +newFastMutPtr = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutPtr arr #) } + -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' + where !(I# size) = finiteBitSize (0 :: Int) + +readFastMutPtr (FastMutPtr arr) = IO $ \s -> + case readAddrArray# arr 0# s of { (# s, i #) -> + (# s, Ptr i #) } + +writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> + case writeAddrArray# arr 0# i s of { s -> + (# s, () #) } diff --git a/GHC/Data/FastString.hs b/GHC/Data/FastString.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FastString.hs @@ -0,0 +1,657 @@ +-- (c) The University of Glasgow, 1997-2006 + +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, + GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | +-- There are two principal string types used internally by GHC: +-- +-- ['FastString'] +-- +-- * A compact, hash-consed, representation of character strings. +-- * Comparison is O(1), and you can get a 'GHC.Types.Unique.Unique' from them. +-- * Generated by 'fsLit'. +-- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ftext'. +-- +-- ['PtrString'] +-- +-- * Pointer and size of a Latin-1 encoded string. +-- * Practically no operations. +-- * Outputting them is fast. +-- * Generated by 'sLit'. +-- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext' +-- * Requires manual memory management. +-- Improper use may lead to memory leaks or dangling pointers. +-- * It assumes Latin-1 as the encoding, therefore it cannot represent +-- arbitrary Unicode strings. +-- +-- Use 'PtrString' unless you want the facilities of 'FastString'. +module GHC.Data.FastString + ( + -- * ByteString + bytesFS, + fastStringToByteString, + mkFastStringByteString, + fastZStringToByteString, + unsafeMkByteString, + + -- * ShortByteString + fastStringToShortByteString, + mkFastStringShortByteString, + + -- * FastZString + FastZString, + hPutFZS, + zString, + lengthFZS, + + -- * FastStrings + FastString(..), -- not abstract, for now. + + -- ** Construction + fsLit, + mkFastString, + mkFastStringBytes, + mkFastStringByteList, + mkFastString#, + + -- ** Deconstruction + unpackFS, -- :: FastString -> String + + -- ** Encoding + zEncodeFS, + + -- ** Operations + uniqueOfFS, + lengthFS, + nullFS, + appendFS, + headFS, + concatFS, + consFS, + nilFS, + isUnderscoreFS, + + -- ** Outputting + hPutFS, + + -- ** Internal + getFastStringTable, + getFastStringZEncCounter, + + -- * PtrStrings + PtrString (..), + + -- ** Construction + sLit, + mkPtrString#, + mkPtrString, + + -- ** Deconstruction + unpackPtrString, + + -- ** Operations + lengthPS + ) where + +#include "HsVersions.h" + +import GHC.Prelude as Prelude + +import GHC.Utils.Encoding +import GHC.Utils.IO.Unsafe +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Monad +import Data.ByteString (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Short.Internal as SBS +import Foreign.C +import System.IO +import Data.Data +import Data.IORef +import Data.Char +import Data.Semigroup as Semi + +import Foreign + +#if GHC_STAGE >= 2 +import GHC.Conc.Sync (sharedCAF) +#endif + +#if __GLASGOW_HASKELL__ < 811 +import GHC.Base (unpackCString#,unpackNBytes#) +#endif +import GHC.Exts +import GHC.IO + +-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' +bytesFS, fastStringToByteString :: FastString -> ByteString +bytesFS = fastStringToByteString + +{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-} +fastStringToByteString f = SBS.fromShort $ fs_sbs f + +fastStringToShortByteString :: FastString -> ShortByteString +fastStringToShortByteString = fs_sbs + +fastZStringToByteString :: FastZString -> ByteString +fastZStringToByteString (FastZString bs) = bs + +-- This will drop information if any character > '\xFF' +unsafeMkByteString :: String -> ByteString +unsafeMkByteString = BSC.pack + +hashFastString :: FastString -> Int +hashFastString fs = hashStr $ fs_sbs fs + +-- ----------------------------------------------------------------------------- + +newtype FastZString = FastZString ByteString + deriving NFData + +hPutFZS :: Handle -> FastZString -> IO () +hPutFZS handle (FastZString bs) = BS.hPut handle bs + +zString :: FastZString -> String +zString (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen + +lengthFZS :: FastZString -> Int +lengthFZS (FastZString bs) = BS.length bs + +mkFastZStringString :: String -> FastZString +mkFastZStringString str = FastZString (BSC.pack str) + +-- ----------------------------------------------------------------------------- + +{-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All +'FastString's are stored in a global hashtable to support fast O(1) +comparison. + +It is also associated with a lazy reference to the Z-encoding +of this string which is used by the compiler internally. +-} +data FastString = FastString { + uniq :: {-# UNPACK #-} !Int, -- unique id + n_chars :: {-# UNPACK #-} !Int, -- number of chars + fs_sbs :: {-# UNPACK #-} !ShortByteString, + fs_zenc :: FastZString + -- ^ Lazily computed z-encoding of this string. + -- + -- Since 'FastString's are globally memoized this is computed at most + -- once for any given string. + } + +instance Eq FastString where + f1 == f2 = uniq f1 == uniq f2 + +instance Ord FastString where + -- Compares lexicographically, not by unique + a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + compare a b = cmpFS a b + +instance IsString FastString where + fromString = fsLit + +instance Semi.Semigroup FastString where + (<>) = appendFS + +instance Monoid FastString where + mempty = nilFS + mappend = (Semi.<>) + mconcat = concatFS + +instance Show FastString where + show fs = show (unpackFS fs) + +instance Data FastString where + -- don't traverse? + toConstr _ = abstractConstr "FastString" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "FastString" + +instance NFData FastString where + rnf fs = seq fs () + +cmpFS :: FastString -> FastString -> Ordering +cmpFS fs1 fs2 = + if uniq fs1 == uniq fs2 then EQ else + compare (fs_sbs fs1) (fs_sbs fs2) + +-- ----------------------------------------------------------------------------- +-- Construction + +{- +Internally, the compiler will maintain a fast string symbol table, providing +sharing and fast comparison. Creation of new @FastString@s then covertly does a +lookup, re-using the @FastString@ if there was a hit. + +The design of the FastString hash table allows for lockless concurrent reads +and updates to multiple buckets with low synchronization overhead. + +See Note [Updating the FastString table] on how it's updated. +-} +data FastStringTable = FastStringTable + {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets + {-# UNPACK #-} !(IORef Int) -- number of computed z-encodings for all buckets + (Array# (IORef FastStringTableSegment)) -- concurrent segments + +data FastStringTableSegment = FastStringTableSegment + {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment + {-# UNPACK #-} !(IORef Int) -- the number of elements + (MutableArray# RealWorld [FastString]) -- buckets in this segment + +{- +Following parameters are determined based on: + +* Benchmark based on testsuite/tests/utils/should_run/T14854.hs +* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@: + on 2018-10-24, we have 13920 entries. +-} +segmentBits, numSegments, segmentMask, initialNumBuckets :: Int +segmentBits = 8 +numSegments = 256 -- bit segmentBits +segmentMask = 0xff -- bit segmentBits - 1 +initialNumBuckets = 64 + +hashToSegment# :: Int# -> Int# +hashToSegment# hash# = hash# `andI#` segmentMask# + where + !(I# segmentMask#) = segmentMask + +hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int# +hashToIndex# buckets# hash# = + (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size# + where + !(I# segmentBits#) = segmentBits + size# = sizeofMutableArray# buckets# + +maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment +maybeResizeSegment segmentRef = do + segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef + let oldSize# = sizeofMutableArray# old# + newSize# = oldSize# *# 2# + (I# n#) <- readIORef counter + if isTrue# (n# <# newSize#) -- maximum load of 1 + then return segment + else do + resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# -> + case newArray# newSize# [] s1# of + (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #) + forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do + fsList <- IO $ readArray# old# i# + forM_ fsList $ \fs -> do + let -- Shall we store in hash value in FastString instead? + !(I# hash#) = hashFastString fs + idx# = hashToIndex# new# hash# + IO $ \s1# -> + case readArray# new# idx# s1# of + (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of + s3# -> (# s3#, () #) + writeIORef segmentRef resizedSegment + return resizedSegment + +{-# NOINLINE stringTable #-} +stringTable :: FastStringTable +stringTable = unsafePerformIO $ do + let !(I# numSegments#) = numSegments + !(I# initialNumBuckets#) = initialNumBuckets + loop a# i# s1# + | isTrue# (i# ==# numSegments#) = s1# + | otherwise = case newMVar () `unIO` s1# of + (# s2#, lock #) -> case newIORef 0 `unIO` s2# of + (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of + (# s4#, buckets# #) -> case newIORef + (FastStringTableSegment lock counter buckets#) `unIO` s4# of + (# s5#, segment #) -> case writeArray# a# i# segment s5# of + s6# -> loop a# (i# +# 1#) s6# + uid <- newIORef 603979776 -- ord '$' * 0x01000000 + n_zencs <- newIORef 0 + tab <- IO $ \s1# -> + case newArray# numSegments# (panic "string_table") s1# of + (# s2#, arr# #) -> case loop arr# 0# s2# of + s3# -> case unsafeFreezeArray# arr# s3# of + (# s4#, segments# #) -> + (# s4#, FastStringTable uid n_zencs segments# #) + + -- use the support wired into the RTS to share this CAF among all images of + -- libHSghc +#if GHC_STAGE < 2 + return tab +#else + sharedCAF tab getOrSetLibHSghcFastStringTable + +-- from the RTS; thus we cannot use this mechanism when GHC_STAGE<2; the previous +-- RTS might not have this symbol +foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" + getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) +#endif + +{- + +We include the FastString table in the `sharedCAF` mechanism because we'd like +FastStrings created by a Core plugin to have the same uniques as corresponding +strings created by the host compiler itself. For example, this allows plugins +to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or +even re-invoke the parser. + +In particular, the following little sanity test was failing in a plugin +prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not +be looked up /by the plugin/. + + let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" + putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts + +`mkTcOcc` involves the lookup (or creation) of a FastString. Since the +plugin's FastString.string_table is empty, constructing the RdrName also +allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These +uniques are almost certainly unequal to the ones that the host compiler +originally assigned to those FastStrings. Thus the lookup fails since the +domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's +unique. + +Maintaining synchronization of the two instances of this global is rather +difficult because of the uses of `unsafePerformIO` in this module. Not +synchronizing them risks breaking the rather major invariant that two +FastStrings with the same unique have the same string. Thus we use the +lower-level `sharedCAF` mechanism that relies on Globals.c. + +-} + +mkFastString# :: Addr# -> FastString +mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) + where ptr = Ptr a# + +{- Note [Updating the FastString table] + +We use a concurrent hashtable which contains multiple segments, each hash value +always maps to the same segment. Read is lock-free, write to the a segment +should acquire a lock for that segment to avoid race condition, writes to +different segments are independent. + +The procedure goes like this: + +1. Find out which segment to operate on based on the hash value +2. Read the relevant bucket and perform a look up of the string. +3. If it exists, return it. +4. Otherwise grab a unique ID, create a new FastString and atomically attempt + to update the relevant segment with this FastString: + + * Resize the segment by doubling the number of buckets when the number of + FastStrings in this segment grows beyond the threshold. + * Double check that the string is not in the bucket. Another thread may have + inserted it while we were creating our string. + * Return the existing FastString if it exists. The one we preemptively + created will get GCed. + * Otherwise, insert and return the string we created. +-} + +mkFastStringWith + :: (Int -> IORef Int-> IO FastString) -> ShortByteString -> IO FastString +mkFastStringWith mk_fs sbs = do + FastStringTableSegment lock _ buckets# <- readIORef segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + res <- bucket_match bucket sbs + case res of + Just found -> return found + Nothing -> do + -- The withMVar below is not dupable. It can lead to deadlock if it is + -- only run partially and putMVar is not called after takeMVar. + noDuplicate + n <- get_uid + new_fs <- mk_fs n n_zencs + withMVar lock $ \_ -> insert new_fs + where + !(FastStringTable uid n_zencs segments#) = stringTable + get_uid = atomicModifyIORef' uid $ \n -> (n+1,n) + + !(I# hash#) = hashStr sbs + (# segmentRef #) = indexArray# segments# (hashToSegment# hash#) + insert fs = do + FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + res <- bucket_match bucket sbs + case res of + -- The FastString was added by another thread after previous read and + -- before we acquired the write lock. + Just found -> return found + Nothing -> do + IO $ \s1# -> + case writeArray# buckets# idx# (fs: bucket) s1# of + s2# -> (# s2#, () #) + modifyIORef' counter succ + return fs + +bucket_match :: [FastString] -> ShortByteString -> IO (Maybe FastString) +bucket_match [] _ = return Nothing +bucket_match (fs@(FastString {fs_sbs=fs_sbs}) : ls) sbs + | fs_sbs == sbs = return (Just fs) + | otherwise = bucket_match ls sbs + +mkFastStringBytes :: Ptr Word8 -> Int -> FastString +mkFastStringBytes !ptr !len = + -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- idempotent. + unsafeDupablePerformIO $ do + sbs <- newSBSFromPtr ptr len + mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString +newSBSFromPtr (Ptr src#) (I# len#) = do + IO $ \s -> + case newByteArray# len# s of { (# s, dst# #) -> + case copyAddrToByteArray# src# dst# 0# len# s of { s -> + case unsafeFreezeByteArray# dst# s of { (# s, ba# #) -> + (# s, SBS.SBS ba# #) }}} + +-- | Create a 'FastString' by copying an existing 'ByteString' +mkFastStringByteString :: ByteString -> FastString +mkFastStringByteString bs = + let sbs = SBS.toShort bs in + inlinePerformIO $ + mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +-- | Create a 'FastString' from an existing 'ShortByteString' without +-- copying. +mkFastStringShortByteString :: ShortByteString -> FastString +mkFastStringShortByteString sbs = + inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +-- | Creates a UTF-8 encoded 'FastString' from a 'String' +mkFastString :: String -> FastString +mkFastString str = + inlinePerformIO $ do + sbs <- utf8EncodeShortByteString str + mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + +-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ +mkFastStringByteList :: [Word8] -> FastString +mkFastStringByteList str = mkFastStringShortByteString (SBS.pack str) + +-- | Creates a (lazy) Z-encoded 'FastString' from a 'ShortByteString' and +-- account the number of forced z-strings into the passed 'IORef'. +mkZFastString :: IORef Int -> ShortByteString -> FastZString +mkZFastString n_zencs sbs = unsafePerformIO $ do + atomicModifyIORef' n_zencs $ \n -> (n+1, ()) + return $ mkFastZStringString (zEncodeString (utf8DecodeShortByteString sbs)) + +mkNewFastStringShortByteString :: ShortByteString -> Int + -> IORef Int -> IO FastString +mkNewFastStringShortByteString sbs uid n_zencs = do + let zstr = mkZFastString n_zencs sbs + chars <- countUTF8Chars sbs + return (FastString uid chars sbs zstr) + +hashStr :: ShortByteString -> Int + -- produce a hash value between 0 & m (inclusive) +hashStr sbs@(SBS.SBS ba#) = loop 0# 0# + where + !(I# len#) = SBS.length sbs + loop h n = + if isTrue# (n ==# len#) then + I# h + else + let + -- DO NOT move this let binding! indexCharOffAddr# reads from the + -- pointer so we need to evaluate this based on the length check + -- above. Not doing this right caused #17909. + !c = indexInt8Array# ba# n + !h2 = (h *# 16777619#) `xorI#` c + in + loop h2 (n +# 1#) + +-- ----------------------------------------------------------------------------- +-- Operations + +-- | Returns the length of the 'FastString' in characters +lengthFS :: FastString -> Int +lengthFS fs = n_chars fs + +-- | Returns @True@ if the 'FastString' is empty +nullFS :: FastString -> Bool +nullFS fs = SBS.null $ fs_sbs fs + +-- | Unpacks and decodes the FastString +unpackFS :: FastString -> String +unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs + +-- | Returns a Z-encoded version of a 'FastString'. This might be the +-- original, if it was already Z-encoded. The first time this +-- function is applied to a particular 'FastString', the results are +-- memoized. +-- +zEncodeFS :: FastString -> FastZString +zEncodeFS fs = fs_zenc fs + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastStringByteString + $ BS.append (bytesFS fs1) (bytesFS fs2) + +concatFS :: [FastString] -> FastString +concatFS = mkFastStringShortByteString . mconcat . map fs_sbs + +headFS :: FastString -> Char +headFS fs + | SBS.null $ fs_sbs fs = panic "headFS: Empty FastString" +headFS fs = head $ unpackFS fs + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastString (c : unpackFS fs) + +uniqueOfFS :: FastString -> Int +uniqueOfFS fs = uniq fs + +nilFS :: FastString +nilFS = mkFastString "" + +isUnderscoreFS :: FastString -> Bool +isUnderscoreFS fs = fs == fsLit "_" + +-- ----------------------------------------------------------------------------- +-- Stats + +getFastStringTable :: IO [[[FastString]]] +getFastStringTable = + forM [0 .. numSegments - 1] $ \(I# i#) -> do + let (# segmentRef #) = indexArray# segments# i# + FastStringTableSegment _ _ buckets# <- readIORef segmentRef + let bucketSize = I# (sizeofMutableArray# buckets#) + forM [0 .. bucketSize - 1] $ \(I# j#) -> + IO $ readArray# buckets# j# + where + !(FastStringTable _ _ segments#) = stringTable + +getFastStringZEncCounter :: IO Int +getFastStringZEncCounter = readIORef n_zencs + where + !(FastStringTable _ n_zencs _) = stringTable + +-- ----------------------------------------------------------------------------- +-- Outputting 'FastString's + +-- |Outputs a 'FastString' with /no decoding at all/, that is, you +-- get the actual bytes in the 'FastString' written to the 'Handle'. +hPutFS :: Handle -> FastString -> IO () +hPutFS handle fs = BS.hPut handle $ bytesFS fs + +-- ToDo: we'll probably want an hPutFSLocal, or something, to output +-- in the current locale's encoding (for error messages and suchlike). + +-- ----------------------------------------------------------------------------- +-- PtrStrings, here for convenience only. + +-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. +data PtrString = PtrString !(Ptr Word8) !Int + +-- | Wrap an unboxed address into a 'PtrString'. +mkPtrString# :: Addr# -> PtrString +mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) + +-- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 +-- encoding. The original string must not contain non-Latin-1 characters +-- (above codepoint @0xff@). +{-# INLINE mkPtrString #-} +mkPtrString :: String -> PtrString +mkPtrString s = + -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks + -- and because someone might be using `eqAddr#` to check for string equality. + unsafePerformIO (do + let len = length s + p <- mallocBytes len + let + loop :: Int -> String -> IO () + loop !_ [] = return () + loop n (c:cs) = do + pokeByteOff p n (fromIntegral (ord c) :: Word8) + loop (1+n) cs + loop 0 s + return (PtrString p len) + ) + +-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. +-- This does not free the memory associated with 'PtrString'. +unpackPtrString :: PtrString -> String +unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# + +-- | Return the length of a 'PtrString' +lengthPS :: PtrString -> Int +lengthPS (PtrString _ n) = n + +-- ----------------------------------------------------------------------------- +-- under the carpet + +foreign import ccall unsafe "strlen" + ptrStrLength :: Ptr Word8 -> Int + +{-# NOINLINE sLit #-} +sLit :: String -> PtrString +sLit x = mkPtrString x + +{-# NOINLINE fsLit #-} +fsLit :: String -> FastString +fsLit x = mkFastString x + +{-# RULES "slit" + forall x . sLit (unpackCString# x) = mkPtrString# x #-} +{-# RULES "fslit" + forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/GHC/Data/FastString/Env.hs b/GHC/Data/FastString/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FastString/Env.hs @@ -0,0 +1,100 @@ +{- +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +-} + +-- | FastStringEnv: FastString environments +module GHC.Data.FastString.Env ( + -- * FastString environments (maps) + FastStringEnv, + + -- ** Manipulating these environments + mkFsEnv, + emptyFsEnv, unitFsEnv, + extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, + extendFsEnvList, extendFsEnvList_C, + filterFsEnv, + plusFsEnv, plusFsEnv_C, alterFsEnv, + lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, + elemFsEnv, mapFsEnv, + + -- * Deterministic FastString environments (maps) + DFastStringEnv, + + -- ** Manipulating these environments + mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv + ) where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Data.Maybe +import GHC.Data.FastString + + +-- | A non-deterministic set of FastStrings. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why it's not +-- deterministic and why it matters. Use DFastStringEnv if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code. +type FastStringEnv a = UniqFM FastString a -- Domain is FastString + +emptyFsEnv :: FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a +alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a +extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a +extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a +plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a +extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a +delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a +elemFsEnv :: FastString -> FastStringEnv a -> Bool +unitFsEnv :: FastString -> a -> FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +lookupFsEnv_NF :: FastStringEnv a -> FastString -> a +filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt +mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 + +emptyFsEnv = emptyUFM +unitFsEnv x y = unitUFM x y +extendFsEnv x y z = addToUFM x y z +extendFsEnvList x l = addListToUFM x l +lookupFsEnv x y = lookupUFM x y +alterFsEnv = alterUFM +mkFsEnv l = listToUFM l +elemFsEnv x y = elemUFM x y +plusFsEnv x y = plusUFM x y +plusFsEnv_C f x y = plusUFM_C f x y +extendFsEnv_C f x y z = addToUFM_C f x y z +mapFsEnv f x = mapUFM f x +extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendFsEnvList_C x y z = addListToUFM_C x y z +delFromFsEnv x y = delFromUFM x y +delListFromFsEnv x y = delListFromUFM x y +filterFsEnv x y = filterUFM x y + +lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) + +-- Deterministic FastStringEnv +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DFastStringEnv. + +type DFastStringEnv a = UniqDFM FastString a -- Domain is FastString + +emptyDFsEnv :: DFastStringEnv a +emptyDFsEnv = emptyUDFM + +dFsEnvElts :: DFastStringEnv a -> [a] +dFsEnvElts = eltsUDFM + +mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a +mkDFsEnv l = listToUDFM l + +lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a +lookupDFsEnv = lookupUDFM diff --git a/GHC/Data/FiniteMap.hs b/GHC/Data/FiniteMap.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FiniteMap.hs @@ -0,0 +1,31 @@ +-- Some extra functions to extend Data.Map + +module GHC.Data.FiniteMap ( + insertList, + insertListWith, + deleteList, + foldRight, foldRightWithKey + ) where + +import GHC.Prelude + +import Data.Map (Map) +import qualified Data.Map as Map + +insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt +insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs + +insertListWith :: Ord key + => (elt -> elt -> elt) + -> [(key,elt)] + -> Map key elt + -> Map key elt +insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs + +deleteList :: Ord key => [key] -> Map key elt -> Map key elt +deleteList ks m = foldl' (flip Map.delete) m ks + +foldRight :: (elt -> a -> a) -> a -> Map key elt -> a +foldRight = Map.foldr +foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a +foldRightWithKey = Map.foldrWithKey diff --git a/GHC/Data/Graph/Base.hs b/GHC/Data/Graph/Base.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Base.hs @@ -0,0 +1,107 @@ + +-- | Types for the general graph colorer. +module GHC.Data.Graph.Base ( + Triv, + Graph (..), + initGraph, + graphMapModify, + + Node (..), newNode, +) + + +where + +import GHC.Prelude + +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + + +-- | A fn to check if a node is trivially colorable +-- For graphs who's color classes are disjoint then a node is 'trivially colorable' +-- when it has less neighbors and exclusions than available colors for that node. +-- +-- For graph's who's color classes overlap, ie some colors alias other colors, then +-- this can be a bit more tricky. There is a general way to calculate this, but +-- it's likely be too slow for use in the code. The coloring algorithm takes +-- a canned function which can be optimised by the user to be specific to the +-- specific graph being colored. +-- +-- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" +-- Smith, Ramsey, Holloway - PLDI 2004. +-- +type Triv k cls color + = cls -- the class of the node we're trying to color. + -> UniqSet k -- the node's neighbors. + -> UniqSet color -- the node's exclusions. + -> Bool + + +-- | The Interference graph. +-- There used to be more fields, but they were turfed out in a previous revision. +-- maybe we'll want more later.. +-- +data Graph k cls color + = Graph { + -- | All active nodes in the graph. + graphMap :: UniqFM k (Node k cls color) } + + +-- | An empty graph. +initGraph :: Graph k cls color +initGraph + = Graph + { graphMap = emptyUFM } + + +-- | Modify the finite map holding the nodes in the graph. +graphMapModify + :: (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)) + -> Graph k cls color -> Graph k cls color + +graphMapModify f graph + = graph { graphMap = f (graphMap graph) } + + + +-- | Graph nodes. +-- Represents a thing that can conflict with another thing. +-- For the register allocater the nodes represent registers. +-- +data Node k cls color + = Node { + -- | A unique identifier for this node. + nodeId :: k + + -- | The class of this node, + -- determines the set of colors that can be used. + , nodeClass :: cls + + -- | The color of this node, if any. + , nodeColor :: Maybe color + + -- | Neighbors which must be colored differently to this node. + , nodeConflicts :: UniqSet k + + -- | Colors that cannot be used by this node. + , nodeExclusions :: UniqSet color + + -- | Colors that this node would prefer to be, in descending order. + , nodePreference :: [color] + + -- | Neighbors that this node would like to be colored the same as. + , nodeCoalesce :: UniqSet k } + + +-- | An empty node. +newNode :: k -> cls -> Node k cls color +newNode k cls + = Node + { nodeId = k + , nodeClass = cls + , nodeColor = Nothing + , nodeConflicts = emptyUniqSet + , nodeExclusions = emptyUniqSet + , nodePreference = [] + , nodeCoalesce = emptyUniqSet } diff --git a/GHC/Data/Graph/Color.hs b/GHC/Data/Graph/Color.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Color.hs @@ -0,0 +1,384 @@ +-- | Graph Coloring. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Data.Graph.Color ( + module GHC.Data.Graph.Base, + module GHC.Data.Graph.Ops, + module GHC.Data.Graph.Ppr, + colorGraph +) + +where + +import GHC.Prelude + +import GHC.Data.Graph.Base +import GHC.Data.Graph.Ops +import GHC.Data.Graph.Ppr + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable + +import Data.Maybe +import Data.List + + +-- | Try to color a graph with this set of colors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- +colorGraph + :: forall k cls color. + ( Uniquable k, Uniquable cls, Uniquable color + , Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k k ) -- map of regs (r1 -> r2) that were coalesced + -- r1 should be replaced by r2 in the source + +colorGraph iterative spinCount colors triv spill graph0 + = let + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. + -- + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2 :: [(k,k)]) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalescing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + + +-- | Scan through the conflict graph separating out trivially colorable and +-- potentially uncolorable (problem) nodes. +-- +-- Checking whether a node is trivially colorable or not is a reasonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. +-- +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. + +colorScan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan + + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + +colorScan iterative triv spill graph + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spin iterative triv spill graph + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are available + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound@(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + +-- Select: +-- we couldn't find any triv nodes or things to freeze or coalesce, +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. +-- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce + + +-- | Try to assign a color to all these nodes. + +assignColors + :: forall k cls color. + ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' :: UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> [k] + -> ( Graph k cls color -- the colored graph + , [k]) + assignColors' _ graph prob [] + = (graph, prob) + + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of + + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks + + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks + + + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + + | otherwise + = Nothing + + + +-- | Select a color for a certain node +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. +-- +selectColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM cls (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> k -- ^ key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ nonDetEltsUniqSet + $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + colors_conflict = mkUniqSet + $ catMaybes + $ map nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concatMap nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- nonDetEltsUniqSet colors_ok + -- See Note [Unique Determinism and code generation] + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor + + + diff --git a/GHC/Data/Graph/Directed.hs b/GHC/Data/Graph/Directed.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Directed.hs @@ -0,0 +1,524 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Data.Graph.Directed ( + Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + + SCC(..), Node(..), flattenSCC, flattenSCCs, + stronglyConnCompG, + topologicalSortG, + verticesG, edgesG, hasVertexG, + reachableG, reachablesG, transposeG, + emptyG, + + findCycle, + + -- For backwards compatibility with the simpler version of Digraph + stronglyConnCompFromEdgedVerticesOrd, + stronglyConnCompFromEdgedVerticesOrdR, + stronglyConnCompFromEdgedVerticesUniq, + stronglyConnCompFromEdgedVerticesUniqR, + + -- Simple way to classify edges + EdgeType(..), classifyEdges + ) where + +#include "HsVersions.h" + +------------------------------------------------------------------------------ +-- A version of the graph algorithms described in: +-- +-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' +-- by David King and John Launchbury +-- +-- Also included is some additional code for printing tree structures ... +-- +-- If you ever find yourself in need of algorithms for classifying edges, +-- or finding connected/biconnected components, consult the history; Sigbjorn +-- Finne contributed some implementations in 1997, although we've since +-- removed them since they were not used anywhere in GHC. +------------------------------------------------------------------------------ + + +import GHC.Prelude + +import GHC.Utils.Misc ( minWith, count ) +import GHC.Utils.Outputable +import GHC.Data.Maybe ( expectJust ) + +-- std interfaces +import Data.Maybe +import Data.Array +import Data.List hiding (transpose) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.Graph as G +import Data.Graph hiding (Graph, Edge, transposeG, reachable) +import Data.Tree +import GHC.Types.Unique +import GHC.Types.Unique.FM + +{- +************************************************************************ +* * +* Graphs and Graph Construction +* * +************************************************************************ + +Note [Nodes, keys, vertices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A 'node' is a big blob of client-stuff + + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison + + * Digraph then maps each 'key' to a Vertex (Int) which is + arranged densely in 0.n +-} + +data Graph node = Graph { + gr_int_graph :: IntGraph, + gr_vertex_to_node :: Vertex -> node, + gr_node_to_vertex :: node -> Maybe Vertex + } + +data Edge node = Edge node node + +{-| Representation for nodes of the Graph. + + * The @payload@ is user data, just carried around in this module + + * The @key@ is the node identifier. + Key has an Ord instance for performance reasons. + + * The @[key]@ are the dependencies of the node; + it's ok to have extra keys in the dependencies that + are not the key of any Node in the graph +-} +data Node key payload = DigraphNode { + node_payload :: payload, -- ^ User data + node_key :: key, -- ^ User defined node id + node_dependencies :: [key] -- ^ Dependencies/successors of the node + } + + +instance (Outputable a, Outputable b) => Outputable (Node a b) where + ppr (DigraphNode a b c) = ppr (a, b, c) + +emptyGraph :: Graph a +emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) + +-- See Note [Deterministic SCC] +graphFromEdgedVertices + :: ReduceFn key payload + -> [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVertices _reduceFn [] = emptyGraph +graphFromEdgedVertices reduceFn edged_vertices = + Graph graph vertex_fn (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_fn, key_vertex, numbered_nodes) = + reduceFn edged_vertices key_extractor + graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) + | (v, (node_dependencies -> ks)) <- numbered_nodes] + -- We normalize outgoing edges by sorting on node order, so + -- that the result doesn't depend on the order of the edges + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesOrd + :: Ord key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq + +type ReduceFn key payload = + [Node key payload] -> (Node key payload -> key) -> + (Bounds, Vertex -> Node key payload + , key -> Maybe Vertex, [(Vertex, Node key payload)]) + +{- +Note [reduceNodesIntoVertices implementations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +reduceNodesIntoVertices is parameterized by the container type. +This is to accommodate key types that don't have an Ord instance +and hence preclude the use of Data.Map. An example of such type +would be Unique, there's no way to implement Ord Unique +deterministically. + +For such types, there's a version with a Uniquable constraint. +This leaves us with two versions of every function that depends on +reduceNodesIntoVertices, one with Ord constraint and the other with +Uniquable constraint. +For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. + +The Uniq version should be a tiny bit more efficient since it uses +Data.IntMap internally. +-} +reduceNodesIntoVertices + :: ([(key, Vertex)] -> m) + -> (key -> m -> Maybe Vertex) + -> ReduceFn key payload +reduceNodesIntoVertices fromList lookup nodes key_extractor = + (bounds, (!) vertex_map, key_vertex, numbered_nodes) + where + max_v = length nodes - 1 + bounds = (0, max_v) :: (Vertex, Vertex) + + -- Keep the order intact to make the result depend on input order + -- instead of key order + numbered_nodes = zip [0..] nodes + vertex_map = array bounds numbered_nodes + + key_map = fromList + [ (key_extractor node, v) | (v, node) <- numbered_nodes ] + key_vertex k = lookup k key_map + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload +reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload +reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) + +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} + +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = go Set.empty (new_work root_deps []) [] + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (node_key node, node) | node <- graph ] + + -- Find the node with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + root :: Node key payload + root = fst (minWith snd [ (node, count (`Map.member` env) + (node_dependencies node)) + | node <- graph ]) + DigraphNode root_payload root_key root_deps = root + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((DigraphNode payload key deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] + +{- +************************************************************************ +* * +* Strongly Connected Component wrappers for Graph +* * +************************************************************************ + +Note: the components are returned topologically sorted: later components +depend on earlier ones, but not vice versa i.e. later components only have +edges going from them to earlier ones. +-} + +{- +Note [Deterministic SCC] +~~~~~~~~~~~~~~~~~~~~~~~~ +stronglyConnCompFromEdgedVerticesUniq, +stronglyConnCompFromEdgedVerticesUniqR, +stronglyConnCompFromEdgedVerticesOrd and +stronglyConnCompFromEdgedVerticesOrdR +provide a following guarantee: +Given a deterministically ordered list of nodes it returns a deterministically +ordered list of strongly connected components, where the list of vertices +in an SCC is also deterministically ordered. +Note that the order of edges doesn't need to be deterministic for this to work. +We use the order of nodes to normalize the order of edges. +-} + +stronglyConnCompG :: Graph node -> [SCC node] +stronglyConnCompG graph = decodeSccs graph forest + where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) + +decodeSccs :: Graph node -> Forest Vertex -> [SCC node] +decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest + = map decode forest + where + decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] + | otherwise = AcyclicSCC (vertex_fn v) + decode other = CyclicSCC (dec other []) + where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrd + :: Ord key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesOrd + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesUniq + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrdR + :: Ord key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesOrdR = + stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniqR + :: Uniquable key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesUniqR = + stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq + +{- +************************************************************************ +* * +* Misc wrappers for Graph +* * +************************************************************************ +-} + +topologicalSortG :: Graph node -> [node] +topologicalSortG graph = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) + +reachableG :: Graph node -> node -> [node] +reachableG graph from = map (gr_vertex_to_node graph) result + where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) + result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] + +-- | Given a list of roots return all reachable nodes. +reachablesG :: Graph node -> [node] -> [node] +reachablesG graph froms = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.reachable" #-} + reachable (gr_int_graph graph) vs + vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] + +hasVertexG :: Graph node -> node -> Bool +hasVertexG graph node = isJust $ gr_node_to_vertex graph node + +verticesG :: Graph node -> [node] +verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) + +edgesG :: Graph node -> [Edge node] +edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) + where v2n = gr_vertex_to_node graph + +transposeG :: Graph node -> Graph node +transposeG graph = Graph (G.transposeG (gr_int_graph graph)) + (gr_vertex_to_node graph) + (gr_node_to_vertex graph) + +emptyG :: Graph node -> Bool +emptyG g = graphEmpty (gr_int_graph g) + +{- +************************************************************************ +* * +* Showing Graphs +* * +************************************************************************ +-} + +instance Outputable node => Outputable (Graph node) where + ppr graph = vcat [ + hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), + hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) + ] + +instance Outputable node => Outputable (Edge node) where + ppr (Edge from to) = ppr from <+> text "->" <+> ppr to + +graphEmpty :: G.Graph -> Bool +graphEmpty g = lo > hi + where (lo, hi) = bounds g + +{- +************************************************************************ +* * +* IntGraphs +* * +************************************************************************ +-} + +type IntGraph = G.Graph + +{- +------------------------------------------------------------ +-- Depth first search numbering +------------------------------------------------------------ +-} + +-- Data.Tree has flatten for Tree, but nothing for Forest +preorderF :: Forest a -> [a] +preorderF ts = concatMap flatten ts + +{- +------------------------------------------------------------ +-- Finding reachable vertices +------------------------------------------------------------ +-} + +-- This generalizes reachable which was found in Data.Graph +reachable :: IntGraph -> [Vertex] -> [Vertex] +reachable g vs = preorderF (dfs g vs) + +{- +************************************************************************ +* * +* Classify Edge Types +* * +************************************************************************ +-} + +-- Remark: While we could generalize this algorithm this comes at a runtime +-- cost and with no advantages. If you find yourself using this with graphs +-- not easily represented using Int nodes please consider rewriting this +-- using the more general Graph type. + +-- | Edge direction based on DFS Classification +data EdgeType + = Forward + | Cross + | Backward -- ^ Loop back towards the root node. + -- Eg backjumps in loops + | SelfLoop -- ^ v -> v + deriving (Eq,Ord) + +instance Outputable EdgeType where + ppr Forward = text "Forward" + ppr Cross = text "Cross" + ppr Backward = text "Backward" + ppr SelfLoop = text "SelfLoop" + +newtype Time = Time Int deriving (Eq,Ord,Num,Outputable) + +--Allow for specialization +{-# INLINEABLE classifyEdges #-} + +-- | Given a start vertex, a way to get successors from a node +-- and a list of (directed) edges classify the types of edges. +classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) + -> [(key,key)] -> [((key, key), EdgeType)] +classifyEdges root getSucc edges = + --let uqe (from,to) = (getUnique from, getUnique to) + --in pprTrace "Edges:" (ppr $ map uqe edges) $ + zip edges $ map classify edges + where + (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root + classify :: (key,key) -> EdgeType + classify (from,to) + | startFrom < startTo + , endFrom > endTo + = Forward + | startFrom > startTo + , endFrom < endTo + = Backward + | startFrom > startTo + , endFrom > endTo + = Cross + | getUnique from == getUnique to + = SelfLoop + | otherwise + = pprPanic "Failed to classify edge of Graph" + (ppr (getUnique from, getUnique to)) + + where + getTime event node + | Just time <- lookupUFM event node + = time + | otherwise + = pprPanic "Failed to classify edge of CFG - not not timed" + (text "edges" <> ppr (getUnique from, getUnique to) + <+> ppr starts <+> ppr ends ) + startFrom = getTime starts from + startTo = getTime starts to + endFrom = getTime ends from + endTo = getTime ends to + + addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key + -> (Time, UniqFM key Time, UniqFM key Time) + addTimes (time,starts,ends) n + --Dont reenter nodes + | elemUFM n starts + = (time,starts,ends) + | otherwise = + let + starts' = addToUFM starts n time + time' = time + 1 + succs = getSucc n :: [key] + (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs + ends'' = addToUFM ends' n time'' + in + (time'' + 1, starts'', ends'') diff --git a/GHC/Data/Graph/Ops.hs b/GHC/Data/Graph/Ops.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Ops.hs @@ -0,0 +1,698 @@ +-- | Basic operations on graphs. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Data.Graph.Ops + ( addNode + , delNode + , getNode + , lookupNode + , modNode + + , size + , union + + , addConflict + , delConflict + , addConflicts + + , addCoalesce + , delCoalesce + + , addExclusion + , addExclusions + + , addPreference + , coalesceNodes + , coalesceGraph + , freezeNode + , freezeOneInGraph + , freezeAllInGraph + , scanGraph + , setColor + , validateGraph + , slurpNodeConflictCount + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List hiding (union) +import Data.Maybe + +-- | Lookup a node from the graph. +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) + +lookupNode graph k + = lookupUFM (graphMap graph) k + + +-- | Get a node from the graph, throwing an error if it's not there +getNode + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color + +getNode graph k + = case lookupUFM (graphMap graph) k of + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" + + +-- | Add a node to the graph, linking up its edges +addNode :: Uniquable k + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + +addNode k node graph + = let + -- add back conflict edges from other nodes to this one + map_conflict = + nonDetStrictFoldUniqSet + -- It's OK to use a non-deterministic fold here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeConflicts = + addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce = + nonDetStrictFoldUniqSet + -- It's OK to use a non-deterministic fold here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeCoalesce = + addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + + +-- | Delete a node and all its edges from the graph. +delNode :: (Uniquable k) + => k -> Graph k cls color -> Maybe (Graph k cls color) + +delNode k graph + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ nonDetEltsUniqSet (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ nonDetEltsUniqSet (nodeCoalesce node) + -- See Note [Unique Determinism and code generation] + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing + + +-- | Modify a node in the graph. +-- returns Nothing if the node isn't present. +-- +modNode :: Uniquable k + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) + +modNode f k graph + = case lookupNode graph k of + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph + + Nothing -> Nothing + + +-- | Get the size of the graph, O(n) +size :: Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + + +-- | Union two graphs together. +union :: Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } + + +-- | Add a conflict between nodes to the graph, creating the nodes required. +-- Conflicts are virtual regs which need to be colored differently. +addConflict + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addConflict (u1, c1) (u2, c2) + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + +-- | Delete a conflict edge. k1 -> k2 +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delConflict k1 k2 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 + + +-- | Add some conflicts to the graph, creating nodes if required. +-- All the nodes in the set are taken to conflict with each other. +addConflicts + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color + +addConflicts conflicts getClass + + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- nonDetEltsUniqSet conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ nonDetEltsUniqSet conflicts + -- See Note [Unique Determinism and code generation] + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM k (Node k cls color) + -> UniqFM k (Node k cls color) +addConflictSet1 u getClass set + = case delOneFromUniqSet set u of + set' -> adjustWithDefaultUFM + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u + + +-- | Add an exclusion to the graph, creating nodes if required. +-- These are extra colors that the node cannot use. +addExclusion + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u + +addExclusions + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color + +addExclusions u getClass colors graph + = foldr (addExclusion u getClass) graph colors + + +-- | Add a coalescence edge to the graph, creating nodes if required. +-- It is considered adventageous to assign the same color to nodes in a coalesence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 + . addCoalesce u2 c2 u1) + + +-- | Delete a coalescence edge (k1 -> k2) from the graph. +delCoalesce + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delCoalesce k1 k2 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 + + +-- | Add a color preference to the graph, creating nodes if required. +-- The most recently added preference is the most preferred. +-- The algorithm tries to assign a node it's preferred color if possible. +-- +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u + + +-- | Do aggressive coalescing on this graph. +-- returns the new graph and the list of pairs of nodes that got coalesced together. +-- for each pair, the resulting node will have the least key and be second in the pair. +-- +coalesceGraph + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. + +coalesceGraph aggressive triv graph + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) +coalesceGraph' aggressive triv graph kkPairsAcc + = let + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] + -- See Note [Unique Determinism and code generation] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + + +-- | Coalesce this pair of nodes unconditionally \/ aggressively. +-- The resulting node is the one with the least key. +-- +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one +-- +-- Nothing if either of the nodes weren't in the graph + +coalesceNodes + :: (Uniquable k, Ord k, Eq cls) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes aggressive triv graph (k1, k2) + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) + + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax + + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) + + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax + + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) + +coalesceNodes_merge + :: (Uniquable k, Eq cls) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: Uniquable k + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_check aggressive triv graph kMin kMax node + + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) + + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 + + in (graph3, Just (kMax, kMin)) + + +-- | Freeze a node +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. +-- +freezeNode + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen + +freezeNode k + = graphMapModify + $ \fm -> + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } + + fm1 = addToUFM fm k node' + + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. + + fm2 = nonDetStrictFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + -- It's OK to use a non-deterministic fold here because the + -- operation is commutative + $ nodeCoalesce node + + in fm2 + + +-- | Freeze one node in the graph +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. +-- +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. +-- +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. +-- +freezeOneInGraph + :: (Uniquable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze + +freezeOneInGraph graph + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + + in case candidates of + + -- there wasn't anything available to freeze + [] -> (graph, False) + + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) + + +-- | Freeze all the nodes in the graph +-- for debugging the iterative allocator. +-- +freezeAllInGraph + :: (Uniquable k) + => Graph k cls color + -> Graph k cls color + +freezeAllInGraph graph + = foldr freezeNode graph + $ map nodeId + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | Find all the nodes in the graph that meet some criteria +-- +scanGraph + :: (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] + +scanGraph match graph + = filter match $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | validate the internal structure of a graph +-- all its edges should point to valid nodes +-- If they don't then throw an error +-- +validateGraph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph + +validateGraph doc isColored graph + + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Graph has edges that point to non-existent nodes" + $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ nonDetEltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph + + +-- | If this node is colored, check that all the nodes which +-- conflict with it have different colors. +checkNode + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + +checkNode graph node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ nonDetEltsUniqSet $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False + + | otherwise + = True + + + +-- | Slurp out a map of how many nodes had a certain number of conflict neighbours + +slurpNodeConflictCount + :: Graph k cls color + -> UniqFM Int (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + +slurpNodeConflictCount graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ nonDetEltsUFM + -- See Note [Unique Determinism and code generation] + $ graphMap graph + + +-- | Set the color of a certain node +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + +setColor u color + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM k a -> UniqFM k a + +adjustWithDefaultUFM f def k map + = addToUFM_C + (\old _ -> f old) + map + k def + +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM k a -> UniqFM k a + +adjustUFM_C f k map + = case lookupUFM map k of + Nothing -> map + Just a -> addToUFM map k (f a) + diff --git a/GHC/Data/Graph/Ppr.hs b/GHC/Data/Graph/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Ppr.hs @@ -0,0 +1,173 @@ + +-- | Pretty printing of graphs. + +module GHC.Data.Graph.Ppr + ( dumpGraph + , dotGraph + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List (mapAccumL) +import Data.Maybe + + +-- | Pretty print a graph in a somewhat human readable format. +dumpGraph + :: (Outputable k, Outputable color) + => Graph k cls color -> SDoc + +dumpGraph graph + = text "Graph" + $$ pprUFM (graphMap graph) (vcat . map dumpNode) + +dumpNode + :: (Outputable k, Outputable color) + => Node k cls color -> SDoc + +dumpNode node + = text "Node " <> ppr (nodeId node) + $$ text "conflicts " + <> parens (int (sizeUniqSet $ nodeConflicts node)) + <> text " = " + <> ppr (nodeConflicts node) + + $$ text "exclusions " + <> parens (int (sizeUniqSet $ nodeExclusions node)) + <> text " = " + <> ppr (nodeExclusions node) + + $$ text "coalesce " + <> parens (int (sizeUniqSet $ nodeCoalesce node)) + <> text " = " + <> ppr (nodeCoalesce node) + + $$ space + + + +-- | Pretty print a graph in graphviz .dot format. +-- Conflicts get solid edges. +-- Coalescences get dashed edges. +dotGraph + :: ( Uniquable k + , Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) -- ^ What graphviz color to use for each node color + -- It's usually safe to return X11 style colors here, + -- ie "red", "green" etc or a hex triplet #aaff55 etc + -> Triv k cls color + -> Graph k cls color -> SDoc + +dotGraph colorMap triv graph + = let nodes = nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + in vcat + ( [ text "graph G {" ] + ++ map (dotNode colorMap triv) nodes + ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) + ++ [ text "}" + , space ]) + + +dotNode :: ( Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) + -> Triv k cls color + -> Node k cls color -> SDoc + +dotNode colorMap triv node + = let name = ppr $ nodeId node + cls = ppr $ nodeClass node + + excludes + = hcat $ punctuate space + $ map (\n -> text "-" <> ppr n) + $ nonDetEltsUniqSet $ nodeExclusions node + -- See Note [Unique Determinism and code generation] + + preferences + = hcat $ punctuate space + $ map (\n -> text "+" <> ppr n) + $ nodePreference node + + expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] + then empty + else text "\\n" <> (excludes <+> preferences) + + -- if the node has been colored then show that, + -- otherwise indicate whether it looks trivially colorable. + color + | Just c <- nodeColor node + = text "\\n(" <> ppr c <> text ")" + + | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = text "\\n(" <> text "triv" <> text ")" + + | otherwise + = text "\\n(" <> text "spill?" <> text ")" + + label = name <> text " :: " <> cls + <> expref + <> color + + pcolorC = case nodeColor node of + Nothing -> text "style=filled fillcolor=white" + Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) + + + pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" + <> space <> doubleQuotes name + <> text ";" + + in pout + + +-- | Nodes in the graph are doubly linked, but we only want one edge for each +-- conflict if the graphviz graph. Traverse over the graph, but make sure +-- to only print the edges for each node once. + +dotNodeEdges + :: ( Uniquable k + , Outputable k) + => UniqSet k + -> Node k cls color + -> (UniqSet k, Maybe SDoc) + +dotNodeEdges visited node + | elementOfUniqSet (nodeId node) visited + = ( visited + , Nothing) + + | otherwise + = let dconflicts + = map (dotEdgeConflict (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeConflicts node) visited + + dcoalesces + = map (dotEdgeCoalesce (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeCoalesce node) visited + + out = vcat dconflicts + $$ vcat dcoalesces + + in ( addOneToUniqSet visited (nodeId node) + , Just out) + + where dotEdgeConflict u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> text ";" + + dotEdgeCoalesce u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> space <> text "[ style = dashed ];" diff --git a/GHC/Data/Graph/UnVar.hs b/GHC/Data/Graph/UnVar.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/UnVar.hs @@ -0,0 +1,145 @@ +{- + +Copyright (c) 2014 Joachim Breitner + +A data structure for undirected graphs of variables +(or in plain terms: Sets of unordered pairs of numbers) + + +This is very specifically tailored for the use in CallArity. In particular it +stores the graph as a union of complete and complete bipartite graph, which +would be very expensive to store as sets of edges or as adjanceny lists. + +It does not normalize the graphs. This means that g `unionUnVarGraph` g is +equal to g, but twice as expensive and large. + +-} +module GHC.Data.Graph.UnVar + ( UnVarSet + , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets + , delUnVarSet + , elemUnVarSet, isEmptyUnVarSet + , UnVarGraph + , emptyUnVarGraph + , unionUnVarGraph, unionUnVarGraphs + , completeGraph, completeBipartiteGraph + , neighbors + , hasLoopAt + , delNode + ) where + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Utils.Outputable +import GHC.Data.Bag +import GHC.Types.Unique + +import qualified Data.IntSet as S + +-- We need a type for sets of variables (UnVarSet). +-- We do not use VarSet, because for that we need to have the actual variable +-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. +-- Therefore, use a IntSet directly (which is likely also a bit more efficient). + +-- Set of uniques, i.e. for adjancet nodes +newtype UnVarSet = UnVarSet (S.IntSet) + deriving Eq + +k :: Var -> Int +k v = getKey (getUnique v) + +emptyUnVarSet :: UnVarSet +emptyUnVarSet = UnVarSet S.empty + +elemUnVarSet :: Var -> UnVarSet -> Bool +elemUnVarSet v (UnVarSet s) = k v `S.member` s + + +isEmptyUnVarSet :: UnVarSet -> Bool +isEmptyUnVarSet (UnVarSet s) = S.null s + +delUnVarSet :: UnVarSet -> Var -> UnVarSet +delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s + +mkUnVarSet :: [Var] -> UnVarSet +mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs + +varEnvDom :: VarEnv a -> UnVarSet +varEnvDom ae = UnVarSet $ ufmToSet_Directly ae + +unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) + +unionUnVarSets :: [UnVarSet] -> UnVarSet +unionUnVarSets = foldr unionUnVarSet emptyUnVarSet + +instance Outputable UnVarSet where + ppr (UnVarSet s) = braces $ + hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] + + +-- The graph type. A list of complete bipartite graphs +data Gen = CBPG UnVarSet UnVarSet -- complete bipartite + | CG UnVarSet -- complete +newtype UnVarGraph = UnVarGraph (Bag Gen) + +emptyUnVarGraph :: UnVarGraph +emptyUnVarGraph = UnVarGraph emptyBag + +unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph +{- +Premature optimisation, it seems. +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s1 == s3 && s2 == s4 + = pprTrace "unionUnVarGraph fired" empty $ + completeGraph (s1 `unionUnVarSet` s2) +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s2 == s3 && s1 == s4 + = pprTrace "unionUnVarGraph fired2" empty $ + completeGraph (s1 `unionUnVarSet` s2) +-} +unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) + = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ + UnVarGraph (g1 `unionBags` g2) + +unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph +unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph + +-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } +completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph +completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 + +completeGraph :: UnVarSet -> UnVarGraph +completeGraph s = prune $ UnVarGraph $ unitBag $ CG s + +neighbors :: UnVarGraph -> Var -> UnVarSet +neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g + where go (CG s) = (if v `elemUnVarSet` s then [s] else []) + go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ + (if v `elemUnVarSet` s2 then [s1] else []) + +-- hasLoopAt G v <=> v--v ∈ G +hasLoopAt :: UnVarGraph -> Var -> Bool +hasLoopAt (UnVarGraph g) v = any go $ bagToList g + where go (CG s) = v `elemUnVarSet` s + go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 + + +delNode :: UnVarGraph -> Var -> UnVarGraph +delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g + where go (CG s) = CG (s `delUnVarSet` v) + go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) + +prune :: UnVarGraph -> UnVarGraph +prune (UnVarGraph g) = UnVarGraph $ filterBag go g + where go (CG s) = not (isEmptyUnVarSet s) + go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) + +instance Outputable Gen where + ppr (CG s) = ppr s <> char '²' + ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 +instance Outputable UnVarGraph where + ppr (UnVarGraph g) = ppr g diff --git a/GHC/Data/IOEnv.hs b/GHC/Data/IOEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/IOEnv.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | The IO Monad with an environment +-- +-- The environment is passed around as a Reader monad but +-- as its in the IO monad, mutable references can be used +-- for updating state. +-- +module GHC.Data.IOEnv ( + IOEnv, -- Instance of Monad + + -- Monad utilities + module GHC.Utils.Monad, + + -- Errors + failM, failWithM, + IOEnvFailure(..), + + -- Getting at the environment + getEnv, setEnv, updEnv, + + runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, + tryM, tryAllM, tryMostM, fixM, + + -- I/O operations + IORef, newMutVar, readMutVar, writeMutVar, updMutVar, + atomicUpdMutVar, atomicUpdMutVar' + ) where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Utils.Exception +import GHC.Unit.Module +import GHC.Utils.Panic + +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, + atomicModifyIORef, atomicModifyIORef' ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( fixIO ) +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import GHC.Utils.Monad +import Control.Applicative (Alternative(..)) +import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) +import Control.Concurrent (forkIO, killThread) + +---------------------------------------------------------------------- +-- Defining the monad type +---------------------------------------------------------------------- + + +newtype IOEnv env a = IOEnv (env -> IO a) + deriving (Functor) + deriving (MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT env IO) + +unIOEnv :: IOEnv env a -> (env -> IO a) +unIOEnv (IOEnv m) = m + +instance Monad (IOEnv m) where + (>>=) = thenM + (>>) = (*>) + +instance MonadFail (IOEnv m) where + fail _ = failM -- Ignore the string + +instance Applicative (IOEnv m) where + pure = returnM + IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) + (*>) = thenM_ + +returnM :: a -> IOEnv env a +returnM a = IOEnv (\ _ -> return a) + +thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b +thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; + unIOEnv (f r) env }) + +thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b +thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) + +failM :: IOEnv env a +failM = IOEnv (\ _ -> throwIO IOEnvFailure) + +failWithM :: String -> IOEnv env a +failWithM s = IOEnv (\ _ -> ioError (userError s)) + +data IOEnvFailure = IOEnvFailure + +instance Show IOEnvFailure where + show IOEnvFailure = "IOEnv failure" + +instance Exception IOEnvFailure + +instance ContainsDynFlags env => HasDynFlags (IOEnv env) where + getDynFlags = do env <- getEnv + return $! extractDynFlags env + +instance ContainsModule env => HasModule (IOEnv env) where + getModule = do env <- getEnv + return $ extractModule env + +---------------------------------------------------------------------- +-- Fundamental combinators specific to the monad +---------------------------------------------------------------------- + + +--------------------------- +runIOEnv :: env -> IOEnv env a -> IO a +runIOEnv env (IOEnv m) = m env + + +--------------------------- +{-# NOINLINE fixM #-} + -- Aargh! Not inlining fixM alleviates a space leak problem. + -- Normally fixM is used with a lazy tuple match: if the optimiser is + -- shown the definition of fixM, it occasionally transforms the code + -- in such a way that the code generator doesn't spot the selector + -- thunks. Sigh. + +fixM :: (a -> IOEnv env a) -> IOEnv env a +fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) + + +--------------------------- +tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) +-- Reflect UserError exceptions (only) into IOEnv monad +-- Other exceptions are not caught; they are simply propagated as exns +-- +-- The idea is that errors in the program being compiled will give rise +-- to UserErrors. But, say, pattern-match failures in GHC itself should +-- not be caught here, else they'll be reported as errors in the program +-- begin compiled! +tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) + +tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) +tryIOEnvFailure = try + +tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) +-- Catch *all* synchronous exceptions +-- This is used when running a Template-Haskell splice, when +-- even a pattern-match failure is a programmer error +tryAllM (IOEnv thing) = IOEnv (\ env -> safeTry (thing env)) + +-- | Like 'try', but doesn't catch asynchronous exceptions +safeTry :: IO a -> IO (Either SomeException a) +safeTry act = do + var <- newEmptyMVar + -- uninterruptible because we want to mask around 'killThread', which is interruptible. + uninterruptibleMask $ \restore -> do + -- Fork, so that 'act' is safe from all asynchronous exceptions other than the ones we send it + t <- forkIO $ try (restore act) >>= putMVar var + restore (readMVar var) + `catch` \(e :: SomeException) -> do + -- Control reaches this point only if the parent thread was sent an async exception + -- In that case, kill the 'act' thread and re-raise the exception + killThread t + throwIO e + +tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) +tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) + +--------------------------- +unsafeInterleaveM :: IOEnv env a -> IOEnv env a +unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) + +uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a +uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) + +---------------------------------------------------------------------- +-- Alternative/MonadPlus +---------------------------------------------------------------------- + +instance Alternative (IOEnv env) where + empty = IOEnv (const empty) + m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) + +instance MonadPlus (IOEnv env) + +---------------------------------------------------------------------- +-- Accessing input/output +---------------------------------------------------------------------- + +newMutVar :: a -> IOEnv env (IORef a) +newMutVar val = liftIO (newIORef val) + +writeMutVar :: IORef a -> a -> IOEnv env () +writeMutVar var val = liftIO (writeIORef var val) + +readMutVar :: IORef a -> IOEnv env a +readMutVar var = liftIO (readIORef var) + +updMutVar :: IORef a -> (a -> a) -> IOEnv env () +updMutVar var upd = liftIO (modifyIORef var upd) + +-- | Atomically update the reference. Does not force the evaluation of the +-- new variable contents. For strict update, use 'atomicUpdMutVar''. +atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) + +-- | Strict variant of 'atomicUpdMutVar'. +atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) + +---------------------------------------------------------------------- +-- Accessing the environment +---------------------------------------------------------------------- + +getEnv :: IOEnv env env +{-# INLINE getEnv #-} +getEnv = IOEnv (\ env -> return env) + +-- | Perform a computation with a different environment +setEnv :: env' -> IOEnv env' a -> IOEnv env a +{-# INLINE setEnv #-} +setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) + +-- | Perform a computation with an altered environment +updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a +{-# INLINE updEnv #-} +updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) diff --git a/GHC/Data/List/SetOps.hs b/GHC/Data/List/SetOps.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List/SetOps.hs @@ -0,0 +1,177 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} + +-- | Set-like operations on lists +-- +-- Avoid using them as much as possible +module GHC.Data.List.SetOps ( + unionLists, minusList, + + -- Association lists + Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, + + -- Duplicate handling + hasNoDups, removeDups, findDupsEq, + equivClasses, + + -- Indexing + getNth + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Set as S + +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) + xs !! n + +{- +************************************************************************ +* * + Treating lists as sets + Assumes the lists contain no duplicates, but are unordered +* * +************************************************************************ +-} + + +-- | Assumes that the arguments contain no duplicates +unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] +-- We special case some reasonable common patterns. +unionLists xs [] = xs +unionLists [] ys = ys +unionLists [x] ys + | isIn "unionLists" x ys = ys + | otherwise = x:ys +unionLists xs [y] + | isIn "unionLists" y xs = xs + | otherwise = y:xs +unionLists xs ys + = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys) + [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys + +-- | Calculate the set difference of two lists. This is +-- /O((m + n) log n)/, where we subtract a list of /n/ elements +-- from a list of /m/ elements. +-- +-- Extremely short cases are handled specially: +-- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1, +-- it takes /O(n)/ time. +minusList :: Ord a => [a] -> [a] -> [a] +-- There's no point building a set to perform just one lookup, so we handle +-- extremely short lists specially. It might actually be better to use +-- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5). +-- The tipping point will be somewhere in the area of where /m/ and /log n/ +-- become comparable, but we probably don't want to work too hard on this. +minusList [] _ = [] +minusList xs@[x] ys + | x `elem` ys = [] + | otherwise = xs +-- Using an empty set or a singleton would also be silly, so let's not. +minusList xs [] = xs +minusList xs [y] = filter (/= y) xs +-- When each list has at least two elements, we build a set from the +-- second argument, allowing us to filter the first argument fairly +-- efficiently. +minusList xs ys = filter (`S.notMember` yss) xs + where + yss = S.fromList ys + +{- +************************************************************************ +* * +\subsection[Utils-assoc]{Association lists} +* * +************************************************************************ + +Inefficient finite maps based on association lists and equality. +-} + +-- A finite mapping based on equality and association lists +type Assoc a b = [(a,b)] + +assoc :: (Eq a) => String -> Assoc a b -> a -> b +assocDefault :: (Eq a) => b -> Assoc a b -> a -> b +assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b +assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b +assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b + +assocDefaultUsing _ deflt [] _ = deflt +assocDefaultUsing eq deflt ((k,v) : rest) key + | k `eq` key = v + | otherwise = assocDefaultUsing eq deflt rest key + +assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key +assocDefault deflt list key = assocDefaultUsing (==) deflt list key +assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +{- +************************************************************************ +* * +\subsection[Utils-dups]{Duplicate-handling} +* * +************************************************************************ +-} + +hasNoDups :: (Eq a) => [a] -> Bool + +hasNoDups xs = f [] xs + where + f _ [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far + then False + else f (x:seen_so_far) xs + + is_elem = isIn "hasNoDups" + +equivClasses :: (a -> a -> Ordering) -- Comparison + -> [a] + -> [NonEmpty a] + +equivClasses _ [] = [] +equivClasses _ [stuff] = [stuff :| []] +equivClasses cmp items = NE.groupBy eq (L.sortBy cmp items) + where + eq a b = case cmp a b of { EQ -> True; _ -> False } + +removeDups :: (a -> a -> Ordering) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [NonEmpty a]) -- List of duplicate groups. One representative + -- from each group appears in the first result + +removeDups _ [] = ([], []) +removeDups _ [x] = ([x],[]) +removeDups cmp xs + = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') -> + (xs', dups) } + where + collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) + collect_dups dups_so_far (x :| []) = (dups_so_far, x) + collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) + +findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] +findDupsEq _ [] = [] +findDupsEq eq (x:xs) | L.null eq_xs = findDupsEq eq xs + | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs + where (eq_xs, neq_xs) = L.partition (eq x) xs diff --git a/GHC/Data/Maybe.hs b/GHC/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Maybe.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Data.Maybe ( + module Data.Maybe, + + MaybeErr(..), -- Instance of Monad + failME, isSuccess, + + orElse, + firstJust, firstJusts, + whenIsJust, + expectJust, + rightToMaybe, + + -- * MaybeT + MaybeT(..), liftMaybeT, tryMaybeT + ) where + +import GHC.Prelude + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Exception (catch, SomeException(..)) +import Data.Maybe +import GHC.Utils.Misc (HasCallStack) + +infixr 4 `orElse` + +{- +************************************************************************ +* * +\subsection[Maybe type]{The @Maybe@ type} +* * +************************************************************************ +-} + +firstJust :: Maybe a -> Maybe a -> Maybe a +firstJust a b = firstJusts [a, b] + +-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or +-- @Nothing@ otherwise. +firstJusts :: [Maybe a] -> Maybe a +firstJusts = msum + +expectJust :: HasCallStack => String -> Maybe a -> a +{-# INLINE expectJust #-} +expectJust _ (Just x) = x +expectJust err Nothing = error ("expectJust " ++ err) + +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () + +-- | Flipped version of @fromMaybe@, useful for chaining. +orElse :: Maybe a -> a -> a +orElse = flip fromMaybe + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe (Left _) = Nothing +rightToMaybe (Right x) = Just x + +{- +************************************************************************ +* * +\subsection[MaybeT type]{The @MaybeT@ monad transformer} +* * +************************************************************************ +-} + +-- We had our own MaybeT in the past. Now we reuse transformer's MaybeT + +liftMaybeT :: Monad m => m a -> MaybeT m a +liftMaybeT act = MaybeT $ Just `liftM` act + +-- | Try performing an 'IO' action, failing on error. +tryMaybeT :: IO a -> MaybeT IO a +tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler + where + handler (SomeException _) = return Nothing + +{- +************************************************************************ +* * +\subsection[MaybeErr type]{The @MaybeErr@ type} +* * +************************************************************************ +-} + +data MaybeErr err val = Succeeded val | Failed err + deriving (Functor) + +instance Applicative (MaybeErr err) where + pure = Succeeded + (<*>) = ap + +instance Monad (MaybeErr err) where + Succeeded v >>= k = k v + Failed e >>= _ = Failed e + +isSuccess :: MaybeErr err val -> Bool +isSuccess (Succeeded {}) = True +isSuccess (Failed {}) = False + +failME :: err -> MaybeErr err val +failME e = Failed e diff --git a/GHC/Data/OrdList.hs b/GHC/Data/OrdList.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/OrdList.hs @@ -0,0 +1,192 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + + +-} +{-# LANGUAGE DeriveFunctor #-} + +{-# LANGUAGE BangPatterns #-} + +-- | Provide trees (of instructions), so that lists of instructions can be +-- appended in linear time. +module GHC.Data.OrdList ( + OrdList, + nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, + headOL, + mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse, + strictlyEqOL, strictlyOrdOL +) where + +import GHC.Prelude +import Data.Foldable + +import GHC.Utils.Outputable + +import qualified Data.Semigroup as Semigroup + +infixl 5 `appOL` +infixl 5 `snocOL` +infixr 5 `consOL` + +data OrdList a + = None + | One a + | Many [a] -- Invariant: non-empty + | Cons a (OrdList a) + | Snoc (OrdList a) a + | Two (OrdList a) -- Invariant: non-empty + (OrdList a) -- Invariant: non-empty + deriving (Functor) + +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that + +instance Semigroup (OrdList a) where + (<>) = appOL + +instance Monoid (OrdList a) where + mempty = nilOL + mappend = (Semigroup.<>) + mconcat = concatOL + +instance Foldable OrdList where + foldr = foldrOL + foldl' = foldlOL + toList = fromOL + null = isNilOL + length = lengthOL + +instance Traversable OrdList where + traverse f xs = toOL <$> traverse f (fromOL xs) + +nilOL :: OrdList a +isNilOL :: OrdList a -> Bool + +unitOL :: a -> OrdList a +snocOL :: OrdList a -> a -> OrdList a +consOL :: a -> OrdList a -> OrdList a +appOL :: OrdList a -> OrdList a -> OrdList a +concatOL :: [OrdList a] -> OrdList a +headOL :: OrdList a -> a +lastOL :: OrdList a -> a +lengthOL :: OrdList a -> Int + +nilOL = None +unitOL as = One as +snocOL as b = Snoc as b +consOL a bs = Cons a bs +concatOL aas = foldr appOL None aas + +headOL None = panic "headOL" +headOL (One a) = a +headOL (Many as) = head as +headOL (Cons a _) = a +headOL (Snoc as _) = headOL as +headOL (Two as _) = headOL as + +lastOL None = panic "lastOL" +lastOL (One a) = a +lastOL (Many as) = last as +lastOL (Cons _ as) = lastOL as +lastOL (Snoc _ a) = a +lastOL (Two _ as) = lastOL as + +lengthOL None = 0 +lengthOL (One _) = 1 +lengthOL (Many as) = length as +lengthOL (Cons _ as) = 1 + length as +lengthOL (Snoc as _) = 1 + length as +lengthOL (Two as bs) = length as + length bs + +isNilOL None = True +isNilOL _ = False + +None `appOL` b = b +a `appOL` None = a +One a `appOL` b = Cons a b +a `appOL` One b = Snoc a b +a `appOL` b = Two a b + +fromOL :: OrdList a -> [a] +fromOL a = go a [] + where go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = a : go b acc + go (Snoc a b) acc = go a (b:acc) + go (Two a b) acc = go a (go b acc) + go (Many xs) acc = xs ++ acc + +fromOLReverse :: OrdList a -> [a] +fromOLReverse a = go a [] + -- acc is already in reverse order + where go :: OrdList a -> [a] -> [a] + go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = go b (a : acc) + go (Snoc a b) acc = b : go a acc + go (Two a b) acc = go b (go a acc) + go (Many xs) acc = reverse xs ++ acc + +mapOL :: (a -> b) -> OrdList a -> OrdList b +mapOL = fmap + +foldrOL :: (a->b->b) -> b -> OrdList a -> b +foldrOL _ z None = z +foldrOL k z (One x) = k x z +foldrOL k z (Cons x xs) = k x (foldrOL k z xs) +foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs +foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 +foldrOL k z (Many xs) = foldr k z xs + +-- | Strict left fold. +foldlOL :: (b->a->b) -> b -> OrdList a -> b +foldlOL _ z None = z +foldlOL k z (One x) = k z x +foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs +foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x +foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 +foldlOL k z (Many xs) = foldl' k z xs + +toOL :: [a] -> OrdList a +toOL [] = None +toOL [x] = One x +toOL xs = Many xs + +reverseOL :: OrdList a -> OrdList a +reverseOL None = None +reverseOL (One x) = One x +reverseOL (Cons a b) = Snoc (reverseOL b) a +reverseOL (Snoc a b) = Cons b (reverseOL a) +reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) +reverseOL (Many xs) = Many (reverse xs) + +-- | Compare not only the values but also the structure of two lists +strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool +strictlyEqOL None None = True +strictlyEqOL (One x) (One y) = x == y +strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs +strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs +strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2 +strictlyEqOL (Many as) (Many bs) = as == bs +strictlyEqOL _ _ = False + +-- | Compare not only the values but also the structure of two lists +strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering +strictlyOrdOL None None = EQ +strictlyOrdOL None _ = LT +strictlyOrdOL (One x) (One y) = compare x y +strictlyOrdOL (One _) _ = LT +strictlyOrdOL (Cons a as) (Cons b bs) = + compare a b `mappend` strictlyOrdOL as bs +strictlyOrdOL (Cons _ _) _ = LT +strictlyOrdOL (Snoc as a) (Snoc bs b) = + compare a b `mappend` strictlyOrdOL as bs +strictlyOrdOL (Snoc _ _) _ = LT +strictlyOrdOL (Two a1 a2) (Two b1 b2) = + (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2) +strictlyOrdOL (Two _ _) _ = LT +strictlyOrdOL (Many as) (Many bs) = compare as bs +strictlyOrdOL (Many _ ) _ = GT + + diff --git a/GHC/Data/Pair.hs b/GHC/Data/Pair.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Pair.hs @@ -0,0 +1,68 @@ +{- +A simple homogeneous pair type with useful Functor, Applicative, and +Traversable instances. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Data.Pair + ( Pair(..) + , unPair + , toPair + , swap + , pLiftFst + , pLiftSnd + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Outputable +import qualified Data.Semigroup as Semi + +data Pair a = Pair { pFst :: a, pSnd :: a } + deriving (Functor) +-- Note that Pair is a *unary* type constructor +-- whereas (,) is binary + +-- The important thing about Pair is that it has a *homogeneous* +-- Functor instance, so you can easily apply the same function +-- to both components + +instance Applicative Pair where + pure x = Pair x x + (Pair f g) <*> (Pair x y) = Pair (f x) (g y) + +instance Foldable Pair where + foldMap f (Pair x y) = f x `mappend` f y + +instance Traversable Pair where + traverse f (Pair x y) = Pair <$> f x <*> f y + +instance Semi.Semigroup a => Semi.Semigroup (Pair a) where + Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) + +instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where + mempty = Pair mempty mempty + mappend = (Semi.<>) + +instance Outputable a => Outputable (Pair a) where + ppr (Pair a b) = ppr a <+> char '~' <+> ppr b + +unPair :: Pair a -> (a,a) +unPair (Pair x y) = (x,y) + +toPair :: (a,a) -> Pair a +toPair (x,y) = Pair x y + +swap :: Pair a -> Pair a +swap (Pair x y) = Pair y x + +pLiftFst :: (a -> a) -> Pair a -> Pair a +pLiftFst f (Pair a b) = Pair (f a) b + +pLiftSnd :: (a -> a) -> Pair a -> Pair a +pLiftSnd f (Pair a b) = Pair a (f b) diff --git a/GHC/Data/Stream.hs b/GHC/Data/Stream.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Stream.hs @@ -0,0 +1,135 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2012 +-- +-- ----------------------------------------------------------------------------- + +-- | Monadic streams +module GHC.Data.Stream ( + Stream(..), yield, liftIO, + collect, collect_, consume, fromList, + map, mapM, mapAccumL, mapAccumL_ + ) where + +import GHC.Prelude hiding (map,mapM) + +import Control.Monad hiding (mapM) + +-- | +-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence +-- of elements of type @a@ followed by a result of type @b@. +-- +-- More concretely, a value of type @Stream m a b@ can be run using @runStream@ +-- in the Monad @m@, and it delivers either +-- +-- * the final result: @Left b@, or +-- * @Right (a,str)@, where @a@ is the next element in the stream, and @str@ +-- is a computation to get the rest of the stream. +-- +-- Stream is itself a Monad, and provides an operation 'yield' that +-- produces a new element of the stream. This makes it convenient to turn +-- existing monadic computations into streams. +-- +-- The idea is that Stream is useful for making a monadic computation +-- that produces values from time to time. This can be used for +-- knitting together two complex monadic operations, so that the +-- producer does not have to produce all its values before the +-- consumer starts consuming them. We make the producer into a +-- Stream, and the consumer pulls on the stream each time it wants a +-- new value. +-- +newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) } + +instance Monad f => Functor (Stream f a) where + fmap = liftM + +instance Monad m => Applicative (Stream m a) where + pure a = Stream (return (Left a)) + (<*>) = ap + +instance Monad m => Monad (Stream m a) where + + Stream m >>= k = Stream $ do + r <- m + case r of + Left b -> runStream (k b) + Right (a,str) -> return (Right (a, str >>= k)) + +yield :: Monad m => a -> Stream m a () +yield a = Stream (return (Right (a, return ()))) + +liftIO :: IO a -> Stream IO b a +liftIO io = Stream $ io >>= return . Left + +-- | Turn a Stream into an ordinary list, by demanding all the elements. +collect :: Monad m => Stream m a () -> m [a] +collect str = go str [] + where + go str acc = do + r <- runStream str + case r of + Left () -> return (reverse acc) + Right (a, str') -> go str' (a:acc) + +-- | Turn a Stream into an ordinary list, by demanding all the elements. +collect_ :: Monad m => Stream m a r -> m ([a], r) +collect_ str = go str [] + where + go str acc = do + r <- runStream str + case r of + Left r -> return (reverse acc, r) + Right (a, str') -> go str' (a:acc) + +consume :: Monad m => Stream m a b -> (a -> m ()) -> m b +consume str f = do + r <- runStream str + case r of + Left ret -> return ret + Right (a, str') -> do + f a + consume str' f + +-- | Turn a list into a 'Stream', by yielding each element in turn. +fromList :: Monad m => [a] -> Stream m a () +fromList = mapM_ yield + +-- | Apply a function to each element of a 'Stream', lazily +map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x +map f str = Stream $ do + r <- runStream str + case r of + Left x -> return (Left x) + Right (a, str') -> return (Right (f a, map f str')) + +-- | Apply a monadic operation to each element of a 'Stream', lazily +mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x +mapM f str = Stream $ do + r <- runStream str + case r of + Left x -> return (Left x) + Right (a, str') -> do + b <- f a + return (Right (b, mapM f str')) + +-- | analog of the list-based 'mapAccumL' on Streams. This is a simple +-- way to map over a Stream while carrying some state around. +mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a () + -> Stream m b c +mapAccumL f c str = Stream $ do + r <- runStream str + case r of + Left () -> return (Left c) + Right (a, str') -> do + (c',b) <- f c a + return (Right (b, mapAccumL f c' str')) + +mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r + -> Stream m b (c, r) +mapAccumL_ f c str = Stream $ do + r <- runStream str + case r of + Left r -> return (Left (c, r)) + Right (a, str') -> do + (c',b) <- f c a + return (Right (b, mapAccumL_ f c' str')) diff --git a/GHC/Data/StringBuffer.hs b/GHC/Data/StringBuffer.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/StringBuffer.hs @@ -0,0 +1,396 @@ +{- +(c) The University of Glasgow 2006 +(c) The University of Glasgow, 1997-2006 + + +Buffers for scanning string input stored in external arrays. +-} + +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +module GHC.Data.StringBuffer + ( + StringBuffer(..), + -- non-abstract for vs\/HaskellService + + -- * Creation\/destruction + hGetStringBuffer, + hGetStringBufferBlock, + hPutStringBuffer, + appendStringBuffers, + stringToStringBuffer, + + -- * Inspection + nextChar, + currentChar, + prevChar, + atEnd, + + -- * Moving and comparison + stepOn, + offsetBytes, + byteDiff, + atLine, + + -- * Conversion + lexemeToString, + lexemeToFastString, + decodePrevNChars, + + -- * Parsing integers + parseUnsignedInteger, + + -- * Checking for bi-directional format characters + containsBidirectionalFormatChar, + bidirectionalFormatChars + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Utils.IO.Unsafe +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import Data.Maybe +import Control.Exception +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) + +import GHC.Exts + +import Foreign +#if MIN_VERSION_base(4,15,0) +import GHC.ForeignPtr (unsafeWithForeignPtr) +#else +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif + +-- ----------------------------------------------------------------------------- +-- The StringBuffer type + +-- |A StringBuffer is an internal pointer to a sized chunk of bytes. +-- The bytes are intended to be *immutable*. There are pure +-- operations to read the contents of a StringBuffer. +-- +-- A StringBuffer may have a finalizer, depending on how it was +-- obtained. +-- +data StringBuffer + = StringBuffer { + buf :: {-# UNPACK #-} !(ForeignPtr Word8), + len :: {-# UNPACK #-} !Int, -- length + cur :: {-# UNPACK #-} !Int -- current pos + } + -- The buffer is assumed to be UTF-8 encoded, and furthermore + -- we add three @\'\\0\'@ bytes to the end as sentinels so that the + -- decoder doesn't have to check for overflow at every single byte + -- of a multibyte sequence. + +instance Show StringBuffer where + showsPrec _ s = showString "" + +-- ----------------------------------------------------------------------------- +-- Creation / Destruction + +-- | Read a file into a 'StringBuffer'. The resulting buffer is automatically +-- managed by the garbage collector. +hGetStringBuffer :: FilePath -> IO StringBuffer +hGetStringBuffer fname = do + h <- openBinaryFile fname ReadMode + size_i <- hFileSize h + offset_i <- skipBOM h size_i 0 -- offset is 0 initially + let size = fromIntegral $ size_i - offset_i + buf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr buf $ \ptr -> do + r <- if size == 0 then return 0 else hGetBuf h ptr size + hClose h + if (r /= size) + then ioError (userError "short read of file") + else newUTF8StringBuffer buf ptr size + +hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer +hGetStringBufferBlock handle wanted + = do size_i <- hFileSize handle + offset_i <- hTell handle >>= skipBOM handle size_i + let size = min wanted (fromIntegral $ size_i-offset_i) + buf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr buf $ \ptr -> + do r <- if size == 0 then return 0 else hGetBuf handle ptr size + if r /= size + then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) + else newUTF8StringBuffer buf ptr size + +hPutStringBuffer :: Handle -> StringBuffer -> IO () +hPutStringBuffer hdl (StringBuffer buf len cur) + = unsafeWithForeignPtr (plusForeignPtr buf cur) $ \ptr -> + hPutBuf hdl ptr len + +-- | Skip the byte-order mark if there is one (see #1744 and #6016), +-- and return the new position of the handle in bytes. +-- +-- This is better than treating #FEFF as whitespace, +-- because that would mess up layout. We don't have a concept +-- of zero-width whitespace in Haskell: all whitespace codepoints +-- have a width of one column. +skipBOM :: Handle -> Integer -> Integer -> IO Integer +skipBOM h size offset = + -- Only skip BOM at the beginning of a file. + if size > 0 && offset == 0 + then do + -- Validate assumption that handle is in binary mode. + ASSERTM( hGetEncoding h >>= return . isNothing ) + -- Temporarily select utf8 encoding with error ignoring, + -- to make `hLookAhead` and `hGetChar` return full Unicode characters. + bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do + c <- hLookAhead h + if c == '\xfeff' + then hGetChar h >> hTell h + else return offset + else return offset + where + safeEncoding = mkUTF8 IgnoreCodingFailure + +newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer +newUTF8StringBuffer buf ptr size = do + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return $ StringBuffer buf size 0 + +appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer +appendStringBuffers sb1 sb2 + = do newBuf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr newBuf $ \ptr -> + unsafeWithForeignPtr (buf sb1) $ \sb1Ptr -> + unsafeWithForeignPtr (buf sb2) $ \sb2Ptr -> + do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len + copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len + pokeArray (ptr `advancePtr` size) [0,0,0] + return (StringBuffer newBuf size 0) + where sb1_len = calcLen sb1 + sb2_len = calcLen sb2 + calcLen sb = len sb - cur sb + size = sb1_len + sb2_len + +-- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer +-- is automatically managed by the garbage collector. +stringToStringBuffer :: String -> StringBuffer +stringToStringBuffer str = + unsafePerformIO $ do + let size = utf8EncodedLength str + buf <- mallocForeignPtrArray (size+3) + unsafeWithForeignPtr buf $ \ptr -> do + utf8EncodeString ptr str + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return (StringBuffer buf size 0) + +-- ----------------------------------------------------------------------------- +-- Grab a character + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well +-- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The +-- behavior is undefined if the 'StringBuffer' is empty. The result shares +-- the same buffer as the original. Similar to 'utf8DecodeChar', if the +-- character cannot be decoded as UTF-8, @\'\\0\'@ is returned. +{-# INLINE nextChar #-} +nextChar :: StringBuffer -> (Char,StringBuffer) +nextChar (StringBuffer buf len (I# cur#)) = + -- Getting our fingers dirty a little here, but this is performance-critical + inlinePerformIO $ + unsafeWithForeignPtr buf $ \(Ptr a#) -> + case utf8DecodeCharAddr# (a# `plusAddr#` cur#) 0# of + (# c#, nBytes# #) -> + let cur' = I# (cur# +# nBytes#) in + return (C# c#, StringBuffer buf len cur') + + +bidirectionalFormatChars :: [(Char,String)] +bidirectionalFormatChars = + [ ('\x202a' , "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)") + , ('\x202b' , "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)") + , ('\x202c' , "U+202C POP DIRECTIONAL FORMATTING (PDF)") + , ('\x202d' , "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)") + , ('\x202e' , "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)") + , ('\x2066' , "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)") + , ('\x2067' , "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)") + , ('\x2068' , "U+2068 FIRST STRONG ISOLATE (FSI)") + , ('\x2069' , "U+2069 POP DIRECTIONAL ISOLATE (PDI)") + ] + +{-| Returns true if the buffer contains Unicode bi-directional formatting +characters. + +https://www.unicode.org/reports/tr9/#Bidirectional_Character_Types + +Bidirectional format characters are one of +'\x202a' : "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)" +'\x202b' : "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)" +'\x202c' : "U+202C POP DIRECTIONAL FORMATTING (PDF)" +'\x202d' : "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)" +'\x202e' : "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)" +'\x2066' : "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)" +'\x2067' : "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)" +'\x2068' : "U+2068 FIRST STRONG ISOLATE (FSI)" +'\x2069' : "U+2069 POP DIRECTIONAL ISOLATE (PDI)" + +This list is encoded in 'bidirectionalFormatChars' + +-} +{-# INLINE containsBidirectionalFormatChar #-} +containsBidirectionalFormatChar :: StringBuffer -> Bool +containsBidirectionalFormatChar (StringBuffer buf (I# len#) (I# cur#)) + = inlinePerformIO $ unsafeWithForeignPtr buf $ \(Ptr a#) -> do + let go :: Int# -> Bool + go i | isTrue# (i >=# len#) = False + | otherwise = case utf8DecodeCharAddr# a# i of + (# '\x202a'# , _ #) -> True + (# '\x202b'# , _ #) -> True + (# '\x202c'# , _ #) -> True + (# '\x202d'# , _ #) -> True + (# '\x202e'# , _ #) -> True + (# '\x2066'# , _ #) -> True + (# '\x2067'# , _ #) -> True + (# '\x2068'# , _ #) -> True + (# '\x2069'# , _ #) -> True + (# _, bytes #) -> go (i +# bytes) + pure $! go cur# + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous +-- to 'Data.List.head'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character +-- cannot be decoded as UTF-8, @\'\\0\'@ is returned. +currentChar :: StringBuffer -> Char +currentChar = fst . nextChar + +prevChar :: StringBuffer -> Char -> Char +prevChar (StringBuffer _ _ 0) deflt = deflt +prevChar (StringBuffer buf _ cur) _ = + inlinePerformIO $ + unsafeWithForeignPtr buf $ \p -> do + p' <- utf8PrevChar (p `plusPtr` cur) + return (fst (utf8DecodeChar p')) + +-- ----------------------------------------------------------------------------- +-- Moving + +-- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous +-- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. The result shares the same buffer as the +-- original. +stepOn :: StringBuffer -> StringBuffer +stepOn s = snd (nextChar s) + +-- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ +-- If there aren't enough characters, the returned 'StringBuffer' will be +-- invalid and any use of it may lead to undefined behavior. The result +-- shares the same buffer as the original. +offsetBytes :: Int -- ^ @n@, the number of bytes + -> StringBuffer + -> StringBuffer +offsetBytes i s = s { cur = cur s + i } + +-- | Compute the difference in offset between two 'StringBuffer's that share +-- the same buffer. __Warning:__ The behavior is undefined if the +-- 'StringBuffer's use separate buffers. +byteDiff :: StringBuffer -> StringBuffer -> Int +byteDiff s1 s2 = cur s2 - cur s1 + +-- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). +atEnd :: StringBuffer -> Bool +atEnd (StringBuffer _ l c) = l == c + +-- | Computes a 'StringBuffer' which points to the first character of the +-- wanted line. Lines begin at 1. +atLine :: Int -> StringBuffer -> Maybe StringBuffer +atLine line sb@(StringBuffer buf len _) = + inlinePerformIO $ + unsafeWithForeignPtr buf $ \p -> do + p' <- skipToLine line len p + if p' == nullPtr + then return Nothing + else + let + delta = p' `minusPtr` p + in return $ Just (sb { cur = delta + , len = len - delta + }) + +skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) +skipToLine !line !len !op0 = go 1 op0 + where + !opend = op0 `plusPtr` len + + go !i_line !op + | op >= opend = pure nullPtr + | i_line == line = pure op + | otherwise = do + w <- peek op :: IO Word8 + case w of + 10 -> go (i_line + 1) (plusPtr op 1) + 13 -> do + -- this is safe because a 'StringBuffer' is + -- guaranteed to have 3 bytes sentinel values. + w' <- peek (plusPtr op 1) :: IO Word8 + case w' of + 10 -> go (i_line + 1) (plusPtr op 2) + _ -> go (i_line + 1) (plusPtr op 1) + _ -> go i_line (plusPtr op 1) + +-- ----------------------------------------------------------------------------- +-- Conversion + +-- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. +-- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, +-- they will be replaced with @\'\\0\'@. +lexemeToString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> String +lexemeToString _ 0 = "" +lexemeToString (StringBuffer buf _ cur) bytes = + utf8DecodeStringLazy buf cur bytes + +lexemeToFastString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> FastString +lexemeToFastString _ 0 = nilFS +lexemeToFastString (StringBuffer buf _ cur) len = + inlinePerformIO $ + unsafeWithForeignPtr buf $ \ptr -> + return $! mkFastStringBytes (ptr `plusPtr` cur) len + +-- | Return the previous @n@ characters (or fewer if we are less than @n@ +-- characters into the buffer. +decodePrevNChars :: Int -> StringBuffer -> String +decodePrevNChars n (StringBuffer buf _ cur) = + inlinePerformIO $ unsafeWithForeignPtr buf $ \p0 -> + go p0 n "" (p0 `plusPtr` (cur - 1)) + where + go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String + go buf0 n acc p | n == 0 || buf0 >= p = return acc + go buf0 n acc p = do + p' <- utf8PrevChar p + let (c,_) = utf8DecodeChar p' + go buf0 (n - 1) (c:acc) p' + +-- ----------------------------------------------------------------------------- +-- Parsing integer strings in various bases +parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer +parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int + = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let + go i x | i == len = x + | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of + '_' -> go (i + 1) x -- skip "_" (#14473) + char -> go (i + 1) (x * radix + toInteger (char_to_int char)) + in go 0 0 diff --git a/GHC/Data/TrieMap.hs b/GHC/Data/TrieMap.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/TrieMap.hs @@ -0,0 +1,406 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module GHC.Data.TrieMap( + -- * Maps over 'Maybe' values + MaybeMap, + -- * Maps over 'List' values + ListMap, + -- * Maps over 'Literal's + LiteralMap, + -- * 'TrieMap' class + TrieMap(..), insertTM, deleteTM, + + -- * Things helpful for adding additional Instances. + (>.>), (|>), (|>>), XT, + foldMaybe, + -- * Map for leaf compression + GenMap, + lkG, xtG, mapG, fdG, + xtList, lkList + + ) where + +import GHC.Prelude + +import GHC.Types.Literal +import GHC.Types.Unique.DFM +import GHC.Types.Unique( Uniquable ) + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import GHC.Utils.Outputable +import Control.Monad( (>=>) ) +import Data.Kind( Type ) + +{- +This module implements TrieMaps, which are finite mappings +whose key is a structured value like a CoreExpr or Type. + +This file implements tries over general data structures. +Implementation for tries over Core Expressions/Types are +available in GHC.Core.Map. + +The regular pattern for handling TrieMaps on data structures was first +described (to my knowledge) in Connelly and Morris's 1995 paper "A +generalization of the Trie Data Structure"; there is also an accessible +description of the idea in Okasaki's book "Purely Functional Data +Structures", Section 10.3.2 + +************************************************************************ +* * + The TrieMap class +* * +************************************************************************ +-} + +type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) + -- or an existing elt (Just) + +class TrieMap m where + type Key m :: Type + emptyTM :: m a + lookupTM :: forall b. Key m -> m b -> Maybe b + alterTM :: forall b. Key m -> XT b -> m b -> m b + mapTM :: (a->b) -> m a -> m b + + foldTM :: (a -> b -> b) -> m a -> b -> b + -- The unusual argument order here makes + -- it easy to compose calls to foldTM; + -- see for example fdE below + +insertTM :: TrieMap m => Key m -> a -> m a -> m a +insertTM k v m = alterTM k (\_ -> Just v) m + +deleteTM :: TrieMap m => Key m -> m a -> m a +deleteTM k m = alterTM k (\_ -> Nothing) m + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +(>.>) :: (a -> b) -> (b -> c) -> a -> c +-- Reverse function composition (do f first, then g) +infixr 1 >.> +(f >.> g) x = g (f x) +infixr 1 |>, |>> + +(|>) :: a -> (a->b) -> b -- Reverse application +x |> f = f x + +---------------------- +(|>>) :: TrieMap m2 + => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) + -> (m2 a -> m2 a) + -> m1 (m2 a) -> m1 (m2 a) +(|>>) f g = f (Just . g . deMaybe) + +deMaybe :: TrieMap m => Maybe (m a) -> m a +deMaybe Nothing = emptyTM +deMaybe (Just m) = m + +{- +************************************************************************ +* * + IntMaps +* * +************************************************************************ +-} + +instance TrieMap IntMap.IntMap where + type Key IntMap.IntMap = Int + emptyTM = IntMap.empty + lookupTM k m = IntMap.lookup k m + alterTM = xtInt + foldTM k m z = IntMap.foldr k z m + mapTM f m = IntMap.map f m + +xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a +xtInt k f m = IntMap.alter f k m + +instance Ord k => TrieMap (Map.Map k) where + type Key (Map.Map k) = k + emptyTM = Map.empty + lookupTM = Map.lookup + alterTM k f m = Map.alter f k m + foldTM k m z = Map.foldr k z m + mapTM f m = Map.map f m + + +{- +Note [foldTM determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We want foldTM to be deterministic, which is why we have an instance of +TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that +go wrong if foldTM is nondeterministic. Consider: + + f a b = return (a <> b) + +Depending on the order that the typechecker generates constraints you +get either: + + f :: (Monad m, Monoid a) => a -> a -> m a + +or: + + f :: (Monoid a, Monad m) => a -> a -> m a + +The generated code will be different after desugaring as the dictionaries +will be bound in different orders, leading to potential ABI incompatibility. + +One way to solve this would be to notice that the typeclasses could be +sorted alphabetically. + +Unfortunately that doesn't quite work with this example: + + f a b = let x = a <> a; y = b <> b in x + +where you infer: + + f :: (Monoid m, Monoid m1) => m1 -> m -> m1 + +or: + + f :: (Monoid m1, Monoid m) => m1 -> m -> m1 + +Here you could decide to take the order of the type variables in the type +according to depth first traversal and use it to order the constraints. + +The real trouble starts when the user enables incoherent instances and +the compiler has to make an arbitrary choice. Consider: + + class T a b where + go :: a -> b -> String + + instance (Show b) => T Int b where + go a b = show a ++ show b + + instance (Show a) => T a Bool where + go a b = show a ++ show b + + f = go 10 True + +GHC is free to choose either dictionary to implement f, but for the sake of +determinism we'd like it to be consistent when compiling the same sources +with the same flags. + +inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it +gets converted to a bag of (Wanted) Cts using a fold. Then in +solve_simple_wanteds it's merged with other WantedConstraints. We want the +conversion to a bag to be deterministic. For that purpose we use UniqDFM +instead of UniqFM to implement the TrieMap. + +See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made +deterministic. +-} + +instance forall key. Uniquable key => TrieMap (UniqDFM key) where + type Key (UniqDFM key) = key + emptyTM = emptyUDFM + lookupTM k m = lookupUDFM m k + alterTM k f m = alterUDFM f m k + foldTM k m z = foldUDFM k z m + mapTM f m = mapUDFM f m + +{- +************************************************************************ +* * + Maybes +* * +************************************************************************ + +If m is a map from k -> val +then (MaybeMap m) is a map from (Maybe k) -> val +-} + +data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } + +instance TrieMap m => TrieMap (MaybeMap m) where + type Key (MaybeMap m) = Maybe (Key m) + emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } + lookupTM = lkMaybe lookupTM + alterTM = xtMaybe alterTM + foldTM = fdMaybe + mapTM = mapMb + +mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b +mapMb f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } + +lkMaybe :: (forall b. k -> m b -> Maybe b) + -> Maybe k -> MaybeMap m a -> Maybe a +lkMaybe _ Nothing = mm_nothing +lkMaybe lk (Just x) = mm_just >.> lk x + +xtMaybe :: (forall b. k -> XT b -> m b -> m b) + -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a +xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } +xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } + +fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b +fdMaybe k m = foldMaybe k (mm_nothing m) + . foldTM k (mm_just m) + +{- +************************************************************************ +* * + Lists +* * +************************************************************************ +-} + +data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + +instance TrieMap m => TrieMap (ListMap m) where + type Key (ListMap m) = [Key m] + emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } + lookupTM = lkList lookupTM + alterTM = xtList alterTM + foldTM = fdList + mapTM = mapList + +instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where + ppr m = text "List elts" <+> ppr (foldTM (:) m []) + +mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b +mapList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } + +lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> [k] -> ListMap m a -> Maybe a +lkList _ [] = lm_nil +lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs + +xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> [k] -> XT a -> ListMap m a -> ListMap m a +xtList _ [] f m = m { lm_nil = f (lm_nil m) } +xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } + +fdList :: forall m a b. TrieMap m + => (a -> b -> b) -> ListMap m a -> b -> b +fdList k m = foldMaybe k (lm_nil m) + . foldTM (fdList k) (lm_cons m) + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b + +{- +************************************************************************ +* * + Basic maps +* * +************************************************************************ +-} + +type LiteralMap a = Map.Map Literal a + +{- +************************************************************************ +* * + GenMap +* * +************************************************************************ + +Note [Compressed TrieMap] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The GenMap constructor augments TrieMaps with leaf compression. This helps +solve the performance problem detailed in #9960: suppose we have a handful +H of entries in a TrieMap, each with a very large key, size K. If you fold over +such a TrieMap you'd expect time O(H). That would certainly be true of an +association list! But with TrieMap we actually have to navigate down a long +singleton structure to get to the elements, so it takes time O(K*H). This +can really hurt on many type-level computation benchmarks: +see for example T9872d. + +The point of a TrieMap is that you need to navigate to the point where only one +key remains, and then things should be fast. So the point of a SingletonMap +is that, once we are down to a single (key,value) pair, we stop and +just use SingletonMap. + +'EmptyMap' provides an even more basic (but essential) optimization: if there is +nothing in the map, don't bother building out the (possibly infinite) recursive +TrieMap structure! + +Compressed triemaps are heavily used by GHC.Core.Map. So we have to mark some things +as INLINEABLE to permit specialization. +-} + +data GenMap m a + = EmptyMap + | SingletonMap (Key m) a + | MultiMap (m a) + +instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where + ppr EmptyMap = text "Empty map" + ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v + ppr (MultiMap m) = ppr m + +-- TODO undecidable instance +instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where + type Key (GenMap m) = Key m + emptyTM = EmptyMap + lookupTM = lkG + alterTM = xtG + foldTM = fdG + mapTM = mapG + +--We want to be able to specialize these functions when defining eg +--tries over (GenMap CoreExpr) which requires INLINEABLE + +{-# INLINEABLE lkG #-} +lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a +lkG _ EmptyMap = Nothing +lkG k (SingletonMap k' v') | k == k' = Just v' + | otherwise = Nothing +lkG k (MultiMap m) = lookupTM k m + +{-# INLINEABLE xtG #-} +xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a +xtG k f EmptyMap + = case f Nothing of + Just v -> SingletonMap k v + Nothing -> EmptyMap +xtG k f m@(SingletonMap k' v') + | k' == k + -- The new key matches the (single) key already in the tree. Hence, + -- apply @f@ to @Just v'@ and build a singleton or empty map depending + -- on the 'Just'/'Nothing' response respectively. + = case f (Just v') of + Just v'' -> SingletonMap k' v'' + Nothing -> EmptyMap + | otherwise + -- We've hit a singleton tree for a different key than the one we are + -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then + -- we can just return the old map. If not, we need a map with *two* + -- entries. The easiest way to do that is to insert two items into an empty + -- map of type @m a@. + = case f Nothing of + Nothing -> m + Just v -> emptyTM |> alterTM k' (const (Just v')) + >.> alterTM k (const (Just v)) + >.> MultiMap +xtG k f (MultiMap m) = MultiMap (alterTM k f m) + +{-# INLINEABLE mapG #-} +mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b +mapG _ EmptyMap = EmptyMap +mapG f (SingletonMap k v) = SingletonMap k (f v) +mapG f (MultiMap m) = MultiMap (mapTM f m) + +{-# INLINEABLE fdG #-} +fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b +fdG _ EmptyMap = \z -> z +fdG k (SingletonMap _ v) = \z -> k v z +fdG k (MultiMap m) = foldTM k m diff --git a/GHC/Data/UnionFind.hs b/GHC/Data/UnionFind.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/UnionFind.hs @@ -0,0 +1,91 @@ +{- Union-find data structure compiled from Distribution.Utils.UnionFind -} +module GHC.Data.UnionFind where + +import GHC.Prelude +import Data.STRef +import Control.Monad.ST +import Control.Monad + +-- | A variable which can be unified; alternately, this can be thought +-- of as an equivalence class with a distinguished representative. +newtype Point s a = Point (STRef s (Link s a)) + deriving (Eq) + +-- | Mutable write to a 'Point' +writePoint :: Point s a -> Link s a -> ST s () +writePoint (Point v) = writeSTRef v + +-- | Read the current value of 'Point'. +readPoint :: Point s a -> ST s (Link s a) +readPoint (Point v) = readSTRef v + +-- | The internal data structure for a 'Point', which either records +-- the representative element of an equivalence class, or a link to +-- the 'Point' that actually stores the representative type. +data Link s a + -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) + +-- | Create a fresh equivalence class with one element. +fresh :: a -> ST s (Point s a) +fresh desc = do + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) + +-- | Flatten any chains of links, returning a 'Point' +-- which points directly to the canonical representation. +repr :: Point s a -> ST s (Point s a) +repr point = readPoint point >>= \r -> + case r of + Link point' -> do + point'' <- repr point' + when (point'' /= point') $ do + writePoint point =<< readPoint point' + return point'' + Info _ _ -> return point + +-- | Return the canonical element of an equivalence +-- class 'Point'. +find :: Point s a -> ST s a +find point = + -- Optimize length 0 and 1 case at expense of + -- general case + readPoint point >>= \r -> + case r of + Info _ d_ref -> readSTRef d_ref + Link point' -> readPoint point' >>= \r' -> + case r' of + Info _ d_ref -> readSTRef d_ref + Link _ -> repr point >>= find + +-- | Unify two equivalence classes, so that they share +-- a canonical element. Keeps the descriptor of point2. +union :: Point s a -> Point s a -> ST s () +union refpoint1 refpoint2 = do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do + l1 <- readPoint point1 + l2 <- readPoint point2 + case (l1, l2) of + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" + +-- | Test if two points are in the same equivalence class. +equivalent :: Point s a -> Point s a -> ST s Bool +equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2) + diff --git a/GHC/Driver/Backend.hs b/GHC/Driver/Backend.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backend.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | Code generation backends +module GHC.Driver.Backend + ( Backend (..) + , platformDefaultBackend + , platformNcgSupported + ) +where + +import GHC.Prelude +import GHC.Platform + +-- | Backend +data Backend + = NCG -- ^ Native code generator backend + | LLVM -- ^ LLVM backend + | ViaC -- ^ Via-C backend + | Interpreter -- ^ Interpreter + deriving (Eq,Ord,Show,Read) + +-- | Default backend to use for the given platform. +platformDefaultBackend :: Platform -> Backend +platformDefaultBackend platform = if + | platformUnregisterised platform -> ViaC + | platformNcgSupported platform -> NCG + | otherwise -> LLVM + + +-- | Is the platform supported by the Native Code Generator? +platformNcgSupported :: Platform -> Bool +platformNcgSupported platform = if + | platformUnregisterised platform -> False -- NCG doesn't support unregisterised ABI + | ncgValidArch -> True + | otherwise -> False + where + ncgValidArch = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchPPC -> True + ArchPPC_64 {} -> True + ArchSPARC -> True + _ -> False diff --git a/GHC/Driver/Backpack.hs b/GHC/Driver/Backpack.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backpack.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} + +-- | This is the driver for the 'ghc --backpack' mode, which +-- is a reimplementation of the "package manager" bits of +-- Backpack directly in GHC. The basic method of operation +-- is to compile packages and then directly insert them into +-- GHC's in memory database. +-- +-- The compilation products of this mode aren't really suitable +-- for Cabal, because GHC makes up component IDs for the things +-- it builds and doesn't serialize out the database contents. +-- But it's still handy for constructing tests. + +module GHC.Driver.Backpack (doBackpack) where + +#include "HsVersions.h" + +import GHC.Prelude + +-- In a separate module because it hooks into the parser. +import GHC.Driver.Backpack.Syntax + +import GHC.Parser.Annotation +import GHC hiding (Failed, Succeeded) +import GHC.Parser +import GHC.Parser.Lexer +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Tc.Utils.Monad +import GHC.Tc.Module +import GHC.Unit +import GHC.Driver.Types +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Error +import GHC.Types.SrcLoc +import GHC.Driver.Main +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Utils.Outputable +import GHC.Data.Maybe +import GHC.Parser.Header +import GHC.Iface.Recomp +import GHC.Driver.Make +import GHC.Types.Unique.DSet +import GHC.Builtin.Names +import GHC.Types.Basic hiding (SuccessFlag(..)) +import GHC.Driver.Finder +import GHC.Utils.Misc + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Panic +import Data.List ( partition ) +import System.Exit +import Control.Monad +import System.FilePath +import Data.Version + +-- for the unification +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map + +-- | Entry point to compile a Backpack file. +doBackpack :: [FilePath] -> Ghc () +doBackpack [src_filename] = do + -- Apply options from file to dflags + dflags0 <- getDynFlags + let dflags1 = dflags0 + src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename + (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts + modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) + -- Cribbed from: preprocessFile / GHC.Driver.Pipeline + liftIO $ checkProcessArgsResult dflags unhandled_flags + liftIO $ handleFlagWarnings dflags warns + -- TODO: Preprocessing not implemented + + buf <- liftIO $ hGetStringBuffer src_filename + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great + case unP parseBackpack (mkPState dflags buf loc) of + PFailed pst -> throwErrors (getErrorMessages pst dflags) + POk _ pkgname_bkp -> do + -- OK, so we have an LHsUnit PackageName, but we want an + -- LHsUnit HsComponentId. So let's rename it. + let pkgstate = unitState dflags + let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp + initBkpM src_filename bkp $ + forM_ (zip [1..] bkp) $ \(i, lunit) -> do + let comp_name = unLoc (hsunitName (unLoc lunit)) + msgTopPackage (i,length bkp) comp_name + innerBkpM $ do + let (cid, insts) = computeUnitId lunit + if null insts + then if cid == Indefinite (UnitId (fsLit "main")) Nothing + then compileExe lunit + else compileUnit cid [] + else typecheckUnit cid insts +doBackpack _ = + throwGhcException (CmdLineError "--backpack can only process a single file") + +computeUnitId :: LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)]) +computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) + where + cid = hsComponentId (unLoc (hsunitName unit)) + reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) + get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname + get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet + get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet + get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = + unitFreeModuleHoles (convertHsComponentId hsuid) + +-- | Tiny enum for all types of Backpack operations we may do. +data SessionType + -- | A compilation operation which will result in a + -- runnable executable being produced. + = ExeSession + -- | A type-checking operation which produces only + -- interface files, no object files. + | TcSession + -- | A compilation operation which produces both + -- interface files and object files. + | CompSession + deriving (Eq) + +-- | Create a temporary Session to do some sort of type checking or +-- compilation. +withBkpSession :: IndefUnitId + -> [(ModuleName, Module)] + -> [(Unit, ModRenaming)] + -> SessionType -- what kind of session are we doing + -> BkpM a -- actual action to run + -> BkpM a +withBkpSession cid insts deps session_type do_this = do + dflags <- getDynFlags + let cid_fs = unitIdFS (indefUnit cid) + is_primary = False + uid_str = unpackFS (mkInstantiatedUnitHash cid insts) + cid_str = unpackFS cid_fs + -- There are multiple units in a single Backpack file, so we + -- need to separate out the results in those cases. Right now, + -- we follow this hierarchy: + -- $outputdir/$compid --> typecheck results + -- $outputdir/$compid/$unitid --> compile results + key_base p | Just f <- p dflags = f + | otherwise = "." + sub_comp p | is_primary = p + | otherwise = p cid_str + outdir p | CompSession <- session_type + -- Special case when package is definite + , not (null insts) = sub_comp (key_base p) uid_str + | otherwise = sub_comp (key_base p) + withTempSession (overHscDynFlags (\dflags -> + -- If we're type-checking an indefinite package, we want to + -- turn on interface writing. However, if the user also + -- explicitly passed in `-fno-code`, we DON'T want to write + -- interfaces unless the user also asked for `-fwrite-interface`. + -- See Note [-fno-code mode] + (case session_type of + -- Make sure to write interfaces when we are type-checking + -- indefinite packages. + TcSession | hscTarget dflags /= HscNothing + -> flip gopt_set Opt_WriteInterface + | otherwise -> id + CompSession -> id + ExeSession -> id) $ + dflags { + hscTarget = case session_type of + TcSession -> HscNothing + _ -> hscTarget dflags, + homeUnitInstantiations = insts, + -- if we don't have any instantiation, don't + -- fill `homeUnitInstanceOfId` as it makes no + -- sense (we're not instantiating anything) + homeUnitInstanceOfId = if null insts then Nothing else Just cid, + homeUnitId = + case session_type of + TcSession -> newUnitId cid Nothing + -- No hash passed if no instances + _ | null insts -> newUnitId cid Nothing + | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)), + -- Setup all of the output directories according to our hierarchy + objectDir = Just (outdir objectDir), + hiDir = Just (outdir hiDir), + stubDir = Just (outdir stubDir), + -- Unset output-file for non exe builds + outputFile = if session_type == ExeSession + then outputFile dflags + else Nothing, + -- Clear the import path so we don't accidentally grab anything + importPaths = [], + -- Synthesized the flags + packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> + let state = unitState dflags + uid = unwireUnit state (improveUnit state $ renameHoleUnit state (listToUFM insts) uid0) + in ExposePackage + (showSDoc dflags + (text "-unit-id" <+> ppr uid <+> ppr rn)) + (UnitIdArg uid) rn) deps + } )) $ do + dflags <- getSessionDynFlags + -- pprTrace "flags" (ppr insts <> ppr deps) $ return () + setSessionDynFlags dflags -- calls initUnits + do_this + +withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a +withBkpExeSession deps do_this = do + withBkpSession (Indefinite (UnitId (fsLit "main")) Nothing) [] deps ExeSession do_this + +getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId) +getSource cid = do + bkp_env <- getBkpEnv + case Map.lookup cid (bkp_table bkp_env) of + Nothing -> pprPanic "missing needed dependency" (ppr cid) + Just lunit -> return lunit + +typecheckUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () +typecheckUnit cid insts = do + lunit <- getSource cid + buildUnit TcSession cid insts lunit + +compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () +compileUnit cid insts = do + -- Let everyone know we're building this unit + msgUnitId (mkVirtUnit cid insts) + lunit <- getSource cid + buildUnit CompSession cid insts lunit + +-- | Compute the dependencies with instantiations of a syntactic +-- HsUnit; e.g., wherever you see @dependency p[A=]@ in a +-- unit file, return the 'Unit' corresponding to @p[A=]@. +-- The @include_sigs@ parameter controls whether or not we also +-- include @dependency signature@ declarations in this calculation. +-- +-- Invariant: this NEVER returns UnitId. +hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)] +hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) + where + get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) + | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)] + | otherwise = [] + where + go Nothing = ModRenaming True [] + go (Just lrns) = ModRenaming False (map convRn lrns) + where + convRn (L _ (Renaming (L _ from) Nothing)) = (from, from) + convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) + get_dep _ = [] + +buildUnit :: SessionType -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit session cid insts lunit = do + -- NB: include signature dependencies ONLY when typechecking. + -- If we're compiling, it's not necessary to recursively + -- compile a signature since it isn't going to produce + -- any object files. + let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) + raw_deps = map fst deps_w_rns + dflags <- getDynFlags + -- The compilation dependencies are just the appropriately filled + -- in unit IDs which must be compiled before we can compile. + let hsubst = listToUFM insts + deps0 = map (renameHoleUnit (unitState dflags) hsubst) raw_deps + + -- Build dependencies OR make sure they make sense. BUT NOTE, + -- we can only check the ones that are fully filled; the rest + -- we have to defer until we've typechecked our local signature. + -- TODO: work this into GHC.Driver.Make!! + forM_ (zip [1..] deps0) $ \(i, dep) -> + case session of + TcSession -> return () + _ -> compileInclude (length deps0) (i, dep) + + dflags <- getDynFlags + -- IMPROVE IT + let deps = map (improveUnit (unitState dflags)) deps0 + + mb_old_eps <- case session of + TcSession -> fmap Just getEpsGhc + _ -> return Nothing + + conf <- withBkpSession cid insts deps_w_rns session $ do + + dflags <- getDynFlags + mod_graph <- hsunitModuleGraph dflags (unLoc lunit) + -- pprTrace "mod_graph" (ppr mod_graph) $ return () + + msg <- mkBackpackMsg + ok <- load' LoadAllTargets (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + + let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags + export_mod ms = (ms_mod_name ms, ms_mod ms) + -- Export everything! + mods = [ export_mod ms | ms <- mgModSummaries mod_graph + , ms_hsc_src ms == HsSrcFile ] + + -- Compile relevant only + hsc_env <- getSession + let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) + linkables = map (expectJust "bkp link" . hm_linkable) + . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) + $ home_mod_infos + getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + state = unitState (hsc_dflags hsc_env) + + let compat_fs = unitIdFS (indefUnit cid) + compat_pn = PackageName compat_fs + + return GenericUnitInfo { + -- Stub data + unitAbiHash = "", + unitPackageId = PackageId compat_fs, + unitPackageName = compat_pn, + unitPackageVersion = makeVersion [], + unitId = toUnitId (homeUnit dflags), + unitComponentName = Nothing, + unitInstanceOf = cid, + unitInstantiations = insts, + -- Slight inefficiency here haha + unitExposedModules = map (\(m,n) -> (m,Just n)) mods, + unitHiddenModules = [], -- TODO: doc only + unitDepends = case session of + -- Technically, we should state that we depend + -- on all the indefinite libraries we used to + -- typecheck this. However, this field isn't + -- really used for anything, so we leave it + -- blank for now. + TcSession -> [] + _ -> map (toUnitId . unwireUnit state) + $ deps ++ [ moduleUnit mod + | (_, mod) <- insts + , not (isHoleModule mod) ], + unitAbiDepends = [], + unitLinkerOptions = case session of + TcSession -> [] + _ -> obj_files, + unitImportDirs = [ hi_dir ], + unitIsExposed = False, + unitIsIndefinite = case session of + TcSession -> True + _ -> False, + -- nope + unitLibraries = [], + unitExtDepLibsSys = [], + unitExtDepLibsGhc = [], + unitLibraryDynDirs = [], + unitLibraryDirs = [], + unitExtDepFrameworks = [], + unitExtDepFrameworkDirs = [], + unitCcOptions = [], + unitIncludes = [], + unitIncludeDirs = [], + unitHaddockInterfaces = [], + unitHaddockHTMLs = [], + unitIsTrusted = False + } + + + addPackage conf + case mb_old_eps of + Just old_eps -> updateEpsGhc_ (const old_eps) + _ -> return () + +compileExe :: LHsUnit HsComponentId -> BkpM () +compileExe lunit = do + msgUnitId mainUnit + let deps_w_rns = hsunitDeps False (unLoc lunit) + deps = map fst deps_w_rns + -- no renaming necessary + forM_ (zip [1..] deps) $ \(i, dep) -> + compileInclude (length deps) (i, dep) + withBkpExeSession deps_w_rns $ do + dflags <- getDynFlags + mod_graph <- hsunitModuleGraph dflags (unLoc lunit) + msg <- mkBackpackMsg + ok <- load' LoadAllTargets (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + +-- | Register a new virtual unit database containing a single unit +addPackage :: GhcMonad m => UnitInfo -> m () +addPackage pkg = do + dflags <- GHC.getSessionDynFlags + case unitDatabases dflags of + Nothing -> panic "addPackage: called too early" + Just dbs -> do + let newdb = UnitDatabase + { unitDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")" + , unitDatabaseUnits = [pkg] + } + GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) }) + +compileInclude :: Int -> (Int, Unit) -> BkpM () +compileInclude n (i, uid) = do + hsc_env <- getSession + let pkgs = unitState (hsc_dflags hsc_env) + msgInclude (i, n) uid + -- Check if we've compiled it already + case uid of + HoleUnit -> return () + RealUnit _ -> return () + VirtUnit i -> case lookupUnit pkgs uid of + Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i) + Just _ -> return () + +-- ---------------------------------------------------------------------------- +-- Backpack monad + +-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state +-- beyond the 'Session', c.f. 'BkpEnv'. +type BkpM = IOEnv BkpEnv + +-- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv', +-- because we are going to update the 'HscEnv' as we go. +data BkpEnv + = BkpEnv { + -- | The session + bkp_session :: Session, + -- | The filename of the bkp file we're compiling + bkp_filename :: FilePath, + -- | Table of source units which we know how to compile + bkp_table :: Map IndefUnitId (LHsUnit HsComponentId), + -- | When a package we are compiling includes another package + -- which has not been compiled, we bump the level and compile + -- that. + bkp_level :: Int + } + +-- Blah, to get rid of the default instance for IOEnv +-- TODO: just make a proper new monad for BkpM, rather than use IOEnv +instance {-# OVERLAPPING #-} HasDynFlags BkpM where + getDynFlags = fmap hsc_dflags getSession + +instance GhcMonad BkpM where + getSession = do + Session s <- fmap bkp_session getEnv + readMutVar s + setSession hsc_env = do + Session s <- fmap bkp_session getEnv + writeMutVar s hsc_env + +-- | Get the current 'BkpEnv'. +getBkpEnv :: BkpM BkpEnv +getBkpEnv = getEnv + +-- | Get the nesting level, when recursively compiling modules. +getBkpLevel :: BkpM Int +getBkpLevel = bkp_level `fmap` getBkpEnv + +-- | Apply a function on 'DynFlags' on an 'HscEnv' +overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv +overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) } + +-- | Run a 'BkpM' computation, with the nesting level bumped one. +innerBkpM :: BkpM a -> BkpM a +innerBkpM do_this = do + -- NB: withTempSession mutates, so we don't have to worry + -- about bkp_session being stale. + updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this + +-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot. +updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () +updateEpsGhc_ f = do + hsc_env <- getSession + liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ())) + +-- | Get the EPS from a 'GhcMonad'. +getEpsGhc :: GhcMonad m => m ExternalPackageState +getEpsGhc = do + hsc_env <- getSession + liftIO $ readIORef (hsc_EPS hsc_env) + +-- | Run 'BkpM' in 'Ghc'. +initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a +initBkpM file bkp m = do + reifyGhc $ \session -> do + let env = BkpEnv { + bkp_session = session, + bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], + bkp_filename = file, + bkp_level = 0 + } + runIOEnv env m + +-- ---------------------------------------------------------------------------- +-- Messaging + +-- | Print a compilation progress message, but with indentation according +-- to @level@ (for nested compilation). +backpackProgressMsg :: Int -> DynFlags -> String -> IO () +backpackProgressMsg level dflags msg = + compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg + +-- | Creates a 'Messager' for Backpack compilation; this is basically +-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which +-- handles indentation. +mkBackpackMsg :: BkpM Messager +mkBackpackMsg = do + level <- getBkpLevel + return $ \hsc_env mod_index recomp mod_summary -> + let dflags = hsc_dflags hsc_env + showMsg msg reason = + backpackProgressMsg level dflags $ + showModuleIndex mod_index ++ + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary + ++ reason + in case recomp of + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" + | otherwise -> return () + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + +-- | 'PprStyle' for Backpack messages; here we usually want the module to +-- be qualified (so we can tell how it was instantiated.) But we try not +-- to qualify packages so we can use simple names for them. +backpackStyle :: PprStyle +backpackStyle = + mkUserStyle + (QueryQualify neverQualifyNames + alwaysQualifyModules + neverQualifyPackages) AllTheWay + +-- | Message when we initially process a Backpack unit. +msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () +msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn + +-- | Message when we instantiate a Backpack unit. +msgUnitId :: Unit -> BkpM () +msgUnitId pk = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ "Instantiating " ++ renderWithStyle + (initSDocContext dflags backpackStyle) + (ppr pk) + +-- | Message when we include a Backpack unit. +msgInclude :: (Int,Int) -> Unit -> BkpM () +msgInclude (i,n) uid = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ showModuleIndex (i, n) ++ "Including " ++ + renderWithStyle (initSDocContext dflags backpackStyle) + (ppr uid) + +-- ---------------------------------------------------------------------------- +-- Conversion from PackageName to HsComponentId + +type PackageNameMap a = Map PackageName a + +-- For now, something really simple, since we're not actually going +-- to use this for anything +unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId) +unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) + = (pn, HsComponentId pn (mkIndefUnitId pkgstate fs)) + +bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId +bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units) + +renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] +renameHsUnits pkgstate m units = map (fmap renameHsUnit) units + where + + renamePackageName :: PackageName -> HsComponentId + renamePackageName pn = + case Map.lookup pn m of + Nothing -> + case lookupPackageName pkgstate pn of + Nothing -> error "no package name" + Just cid -> HsComponentId pn cid + Just hscid -> hscid + + renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId + renameHsUnit u = + HsUnit { + hsunitName = fmap renamePackageName (hsunitName u), + hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u) + } + + renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId + renameHsUnitDecl (DeclD a b c) = DeclD a b c + renameHsUnitDecl (IncludeD idecl) = + IncludeD IncludeDecl { + idUnitId = fmap renameHsUnitId (idUnitId idecl), + idModRenaming = idModRenaming idecl, + idSignatureInclude = idSignatureInclude idecl + } + + renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId + renameHsUnitId (HsUnitId ln subst) + = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst) + + renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId + renameHsModuleSubst (lk, lm) + = (lk, fmap renameHsModuleId lm) + + renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId + renameHsModuleId (HsModuleVar lm) = HsModuleVar lm + renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm + +convertHsComponentId :: HsUnitId HsComponentId -> Unit +convertHsComponentId (HsUnitId (L _ hscid) subst) + = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) + +convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) +convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) + +convertHsModuleId :: HsModuleId HsComponentId -> Module +convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname +convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname + + + +{- +************************************************************************ +* * + Module graph construction +* * +************************************************************************ +-} + +-- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications: +-- +-- 1. Every module is required to be mentioned, so we don't do any funny +-- business with targets or recursively grabbing dependencies. (We +-- could support this in principle). +-- 2. We support inline modules, whose summary we have to synthesize ourself. +-- +-- We don't bother trying to support GHC.Driver.Make for now, it's more trouble +-- than it's worth for inline modules. +hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph +hsunitModuleGraph dflags unit = do + let decls = hsunitBody unit + pn = hsPackageName (unLoc (hsunitName unit)) + + -- 1. Create a HsSrcFile/HsigFile summary for every + -- explicitly mentioned module/signature. + let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do + Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod + get_decl _ = return Nothing + nodes <- catMaybes `fmap` mapM get_decl decls + + -- 2. For each hole which does not already have an hsig file, + -- create an "empty" hsig file to induce compilation for the + -- requirement. + let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) + | n <- nodes ] + req_nodes <- fmap catMaybes . forM (homeUnitInstantiations dflags) $ \(mod_name, _) -> + let has_local = Map.member (mod_name, True) node_map + in if has_local + then return Nothing + else fmap Just $ summariseRequirement pn mod_name + + -- 3. Return the kaboodle + return $ mkModuleGraph $ nodes ++ req_nodes + +summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary +summariseRequirement pn mod_name = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + let PackageName pn_fs = pn + location <- liftIO $ mkHomeModLocation2 dflags mod_name + (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" + + env <- getBkpEnv + time <- liftIO $ getModificationUTCTime (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) + + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name + + return ModSummary { + ms_mod = mod, + ms_hsc_src = HsigFile, + ms_location = location, + ms_hs_date = time, + ms_obj_date = Nothing, + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp, + ms_srcimps = [], + ms_textual_imps = extra_sig_imports, + ms_parsed_mod = Just (HsParsedModule { + hpm_module = L loc (HsModule { + hsmodLayout = NoLayoutInfo, + hsmodName = Just (L loc mod_name), + hsmodExports = Nothing, + hsmodImports = [], + hsmodDecls = [], + hsmodDeprecMessage = Nothing, + hsmodHaddockModHeader = Nothing + }), + hpm_src_files = [], + hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] + }), + ms_hspp_file = "", -- none, it came inline + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + +summariseDecl :: PackageName + -> HscSource + -> Located ModuleName + -> Maybe (Located HsModule) + -> BkpM ModSummary +summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod +summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing + = do hsc_env <- getSession + let dflags = hsc_dflags hsc_env + -- TODO: this looks for modules in the wrong place + r <- liftIO $ summariseModule hsc_env + Map.empty -- GHC API recomp not supported + (hscSourceToIsBoot hsc_src) + lmodname + True -- Target lets you disallow, but not here + Nothing -- GHC API buffer support not supported + [] -- No exclusions + case r of + Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) + Just (Left err) -> throwErrors err + Just (Right summary) -> return summary + +-- | Up until now, GHC has assumed a single compilation target per source file. +-- Backpack files with inline modules break this model, since a single file +-- may generate multiple output files. How do we decide to name these files? +-- Should there only be one output file? This function our current heuristic, +-- which is we make a "fake" module and use that. +hsModuleToModSummary :: PackageName + -> HscSource + -> ModuleName + -> Located HsModule + -> BkpM ModSummary +hsModuleToModSummary pn hsc_src modname + hsmod = do + let imps = hsmodImports (unLoc hsmod) + loc = getLoc hsmod + hsc_env <- getSession + -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation + -- Use the PACKAGE NAME to find the location + let PackageName unit_fs = pn + dflags = hsc_dflags hsc_env + -- Unfortunately, we have to define a "fake" location in + -- order to appease the various code which uses the file + -- name to figure out where to put, e.g. object files. + -- To add insult to injury, we don't even actually use + -- these filenames to figure out where the hi files go. + -- A travesty! + location0 <- liftIO $ mkHomeModLocation2 dflags modname + (unpackFS unit_fs + moduleNameSlashes modname) + (case hsc_src of + HsigFile -> "hsig" + HsBootFile -> "hs-boot" + HsSrcFile -> "hs") + -- DANGEROUS: bootifying can POISON the module finder cache + let location = case hsc_src of + HsBootFile -> addBootSuffixLocnOut location0 + _ -> location0 + -- This duplicates a pile of logic in GHC.Driver.Make + env <- getBkpEnv + time <- liftIO $ getModificationUTCTime (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + + -- Also copied from 'getImports' + let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports modname loc + implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname + + let normal_imports = map convImport (implicit_imports ++ ordinary_imps) + required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports + + -- So that Finder can find it, even though it doesn't exist... + this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location + return ModSummary { + ms_mod = this_mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = (case hiDir dflags of + Nothing -> "" + Just d -> d) ".." moduleNameSlashes modname <.> "hi", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing, + ms_srcimps = map convImport src_idecls, + ms_textual_imps = normal_imports + -- We have to do something special here: + -- due to merging, requirements may end up with + -- extra imports + ++ extra_sig_imports + ++ required_by_imports, + -- This is our hack to get the parse tree to the right spot + ms_parsed_mod = Just (HsParsedModule { + hpm_module = hsmod, + hpm_src_files = [], -- TODO if we preprocessed it + hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] -- BOGUS + }), + ms_hs_date = time, + ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp + } + +-- | Create a new, externally provided hashed unit id from +-- a hash. +newUnitId :: IndefUnitId -> Maybe FastString -> UnitId +newUnitId uid mhash = case mhash of + Nothing -> indefUnit uid + Just hash -> UnitId (unitIdFS (indefUnit uid) `appendFS` mkFastString "+" `appendFS` hash) diff --git a/GHC/Driver/Backpack/Syntax.hs b/GHC/Driver/Backpack/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backpack/Syntax.hs @@ -0,0 +1,82 @@ +-- | This is the syntax for bkp files which are parsed in 'ghc --backpack' +-- mode. This syntax is used purely for testing purposes. + +module GHC.Driver.Backpack.Syntax ( + -- * Backpack abstract syntax + HsUnitId(..), + LHsUnitId, + HsModuleSubst, + LHsModuleSubst, + HsModuleId(..), + LHsModuleId, + HsComponentId(..), + LHsUnit, HsUnit(..), + LHsUnitDecl, HsUnitDecl(..), + IncludeDecl(..), + LRenaming, Renaming(..), + ) where + +import GHC.Prelude + +import GHC.Driver.Phases +import GHC.Hs +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Unit + +{- +************************************************************************ +* * + User syntax +* * +************************************************************************ +-} + +data HsComponentId = HsComponentId { + hsPackageName :: PackageName, + hsComponentId :: IndefUnitId + } + +instance Outputable HsComponentId where + ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn + +data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] +type LHsUnitId n = Located (HsUnitId n) + +type HsModuleSubst n = (Located ModuleName, LHsModuleId n) +type LHsModuleSubst n = Located (HsModuleSubst n) + +data HsModuleId n = HsModuleVar (Located ModuleName) + | HsModuleId (LHsUnitId n) (Located ModuleName) +type LHsModuleId n = Located (HsModuleId n) + +-- | Top level @unit@ declaration in a Backpack file. +data HsUnit n = HsUnit { + hsunitName :: Located n, + hsunitBody :: [LHsUnitDecl n] + } +type LHsUnit n = Located (HsUnit n) + +-- | A declaration in a package, e.g. a module or signature definition, +-- or an include. +data HsUnitDecl n + = DeclD HscSource (Located ModuleName) (Maybe (Located HsModule)) + | IncludeD (IncludeDecl n) +type LHsUnitDecl n = Located (HsUnitDecl n) + +-- | An include of another unit +data IncludeDecl n = IncludeDecl { + idUnitId :: LHsUnitId n, + idModRenaming :: Maybe [ LRenaming ], + -- | Is this a @dependency signature@ include? If so, + -- we don't compile this include when we instantiate this + -- unit (as there should not be any modules brought into + -- scope.) + idSignatureInclude :: Bool + } + +-- | Rename a module from one name to another. The identity renaming +-- means that the module should be brought into scope. +data Renaming = Renaming { renameFrom :: Located ModuleName + , renameTo :: Maybe (Located ModuleName) } +type LRenaming = Located Renaming diff --git a/GHC/Driver/CmdLine.hs b/GHC/Driver/CmdLine.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/CmdLine.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +------------------------------------------------------------------------------- +-- +-- | Command-line parser +-- +-- This is an abstract command-line parser used by DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.CmdLine + ( + processArgs, OptKind(..), GhcFlagMode(..), + CmdLineP(..), getCmdLineState, putCmdLineState, + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, + errorsToGhcException, + + Err(..), Warn(..), WarnReason(..), + + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, + deprecate + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Bag +import GHC.Types.SrcLoc +import GHC.Utils.Json + +import Data.Function +import Data.List + +import Control.Monad (liftM, ap) + +-------------------------------------------------------- +-- The Flag and OptKind types +-------------------------------------------------------- + +data Flag m = Flag + { flagName :: String, -- Flag, without the leading "-" + flagOptKind :: OptKind m, -- What to do if we see it + flagGhcMode :: GhcFlagMode -- Which modes this flag affects + } + +defFlag :: String -> OptKind m -> Flag m +defFlag name optKind = Flag name optKind AllModes + +defGhcFlag :: String -> OptKind m -> Flag m +defGhcFlag name optKind = Flag name optKind OnlyGhc + +defGhciFlag :: String -> OptKind m -> Flag m +defGhciFlag name optKind = Flag name optKind OnlyGhci + +defHiddenFlag :: String -> OptKind m -> Flag m +defHiddenFlag name optKind = Flag name optKind HiddenFlag + +-- | GHC flag modes describing when a flag has an effect. +data GhcFlagMode + = OnlyGhc -- ^ The flag only affects the non-interactive GHC + | OnlyGhci -- ^ The flag only affects the interactive GHC + | AllModes -- ^ The flag affects multiple ghc modes + | HiddenFlag -- ^ This flag should not be seen in cli completion + +data OptKind m -- Suppose the flag is -f + = NoArg (EwM m ()) -- -f all by itself + | HasArg (String -> EwM m ()) -- -farg or -f arg + | SepArg (String -> EwM m ()) -- -f arg + | Prefix (String -> EwM m ()) -- -farg + | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn + | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn + | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn + + +-------------------------------------------------------- +-- The EwM monad +-------------------------------------------------------- + +-- | Used when filtering warnings: if a reason is given +-- it can be filtered out when displaying. +data WarnReason + = NoReason + | ReasonDeprecatedFlag + | ReasonUnrecognisedFlag + deriving (Eq, Show) + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json reason = JSString $ show reason + +-- | A command-line error message +newtype Err = Err { errMsg :: Located String } + +-- | A command-line warning message and the reason it arose +data Warn = Warn + { warnReason :: WarnReason, + warnMsg :: Located String + } + +type Errs = Bag Err +type Warns = Bag Warn + +-- EwM ("errors and warnings monad") is a monad +-- transformer for m that adds an (err, warn) state +newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg + -> Errs -> Warns + -> m (Errs, Warns, a) } + +instance Monad m => Functor (EwM m) where + fmap = liftM + +instance Monad m => Applicative (EwM m) where + pure v = EwM (\_ e w -> return (e, w, v)) + (<*>) = ap + +instance Monad m => Monad (EwM m) where + (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w + unEwM (k r) l e' w') + +runEwM :: EwM m a -> m (Errs, Warns, a) +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag + +setArg :: Located String -> EwM m () -> EwM m () +setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + +addErr :: Monad m => String -> EwM m () +addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) + +addWarn :: Monad m => String -> EwM m () +addWarn = addFlagWarn NoReason + +addFlagWarn :: Monad m => WarnReason -> String -> EwM m () +addFlagWarn reason msg = EwM $ + (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) + +deprecate :: Monad m => String -> EwM m () +deprecate s = do + arg <- getArg + addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) + +getArg :: Monad m => EwM m String +getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) + +getCurLoc :: Monad m => EwM m SrcSpan +getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) + +liftEwM :: Monad m => m a -> EwM m a +liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) + + +-------------------------------------------------------- +-- A state monad for use in the command-line parser +-------------------------------------------------------- + +-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) +newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } + deriving (Functor) + +instance Applicative (CmdLineP s) where + pure a = CmdLineP $ \s -> (a, s) + (<*>) = ap + +instance Monad (CmdLineP s) where + m >>= k = CmdLineP $ \s -> + let (a, s') = runCmdLine m s + in runCmdLine (k a) s' + + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP $ \s -> (s,s) +putCmdLineState :: s -> CmdLineP s () +putCmdLineState s = CmdLineP $ \_ -> ((),s) + + +-------------------------------------------------------- +-- Processing arguments +-------------------------------------------------------- + +processArgs :: Monad m + => [Flag m] -- cmdline parser spec + -> [Located String] -- args + -> m ( [Located String], -- spare args + [Err], -- errors + [Warn] ) -- warnings +processArgs spec args = do + (errs, warns, spare) <- runEwM action + return (spare, bagToList errs, bagToList warns) + where + action = process args [] + + -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process [] spare = return (reverse spare) + + process (locArg@(L _ ('-' : arg)) : args) spare = + case findArg spec arg of + Just (rest, opt_kind) -> + case processOneArg opt_kind rest arg args of + Left err -> + let b = process args spare + in (setArg locArg $ addErr err) >> b + + Right (action,rest) -> + let b = process rest spare + in (setArg locArg $ action) >> b + + Nothing -> process args (locArg : spare) + + process (arg : args) spare = process args (arg : spare) + + +processOneArg :: OptKind m -> String -> String -> [Located String] + -> Either String (EwM m (), [Located String]) +processOneArg opt_kind rest arg args + = let dash_arg = '-' : arg + rest_no_eq = dropEq rest + in case opt_kind of + NoArg a -> ASSERT(null rest) Right (a, args) + + HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #9776 + SepArg f -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #12625 + Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> missingArgErr dash_arg + + PassFlag f | notNull rest -> unknownFlagErr dash_arg + | otherwise -> Right (f dash_arg, args) + + OptIntSuffix f | null rest -> Right (f Nothing, args) + | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed float argument in " ++ dash_arg) + + OptPrefix f -> Right (f rest_no_eq, args) + AnySuffix f -> Right (f dash_arg, args) + +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg spec arg = + case sortBy (compare `on` (length . fst)) -- prefer longest matching flag + [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [stripPrefix (flagName flag) arg], + arg_ok optKind rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +arg_ok :: OptKind t -> [Char] -> String -> Bool +arg_ok (NoArg _) rest _ = null rest +arg_ok (HasArg _) _ _ = True +arg_ok (SepArg _) rest _ = null rest +arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t + -- to improve error message (#12625) +arg_ok (OptIntSuffix _) _ _ = True +arg_ok (IntSuffix _) _ _ = True +arg_ok (FloatSuffix _) _ _ = True +arg_ok (OptPrefix _) _ _ = True +arg_ok (PassFlag _) rest _ = null rest +arg_ok (AnySuffix _) _ _ = True + +-- | Parse an Int +-- +-- Looks for "433" or "=342", with no trailing gubbins +-- * n or =n => Just n +-- * gibberish => Nothing +parseInt :: String -> Maybe Int +parseInt s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +parseFloat :: String -> Maybe Float +parseFloat s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +-- | Discards a leading equals sign +dropEq :: String -> String +dropEq ('=' : s) = s +dropEq s = s + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-------------------------------------------------------- +-- Utils +-------------------------------------------------------- + + +-- See Note [Handling errors when parsing flags] +errorsToGhcException :: [(String, -- Location + String)] -- Error + -> GhcException +errorsToGhcException errs = + UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] + +{- Note [Handling errors when parsing commandline flags] + +Parsing of static and mode flags happens before any session is started, i.e., +before the first call to 'GHC.withGhc'. Therefore, to report errors for +invalid usage of these two types of flags, we can not call any function that +needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags +is not set either). So we always print "on the commandline" as the location, +which is true except for Api users, which is probably ok. + +When reporting errors for invalid usage of dynamic flags we /can/ make use of +DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. + +Before, we called unsafeGlobalDynFlags when an invalid (combination of) +flag(s) was given on the commandline, resulting in panics (#9963). +-} diff --git a/GHC/Driver/CodeOutput.hs b/GHC/Driver/CodeOutput.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/CodeOutput.hs @@ -0,0 +1,293 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section{Code output phase} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Driver.CodeOutput + ( codeOutput + , outputForeignStubs + , profilingInitCode + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.CmmToAsm ( nativeCodeGen ) +import GHC.CmmToLlvm ( llvmCodeGen ) + +import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) + +import GHC.Driver.Finder ( mkStubPaths ) +import GHC.CmmToC ( writeC ) +import GHC.Cmm.Lint ( cmmLint ) +import GHC.Cmm ( RawCmmGroup ) +import GHC.Cmm.CLabel +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Data.Stream ( Stream ) +import qualified GHC.Data.Stream as Stream +import GHC.SysTools.FileCleanup + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Unit +import GHC.Types.SrcLoc +import GHC.Types.CostCentre + +import Control.Exception +import System.Directory +import System.FilePath +import System.IO + +{- +************************************************************************ +* * +\subsection{Steering} +* * +************************************************************************ +-} + +codeOutput :: DynFlags + -> Module + -> FilePath + -> ModLocation + -> ForeignStubs + -> [(ForeignSrcLang, FilePath)] + -- ^ additional files to be compiled with the C compiler + -> [UnitId] + -> Stream IO RawCmmGroup a -- Compiled C-- + -> IO (FilePath, + (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), + [(ForeignSrcLang, FilePath)]{-foreign_fps-}, + a) + +codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps + cmm_stream + = + do { + -- Lint each CmmGroup as it goes past + ; let linted_cmm_stream = + if gopt Opt_DoCmmLinting dflags + then Stream.mapM do_lint cmm_stream + else cmm_stream + + do_lint cmm = withTimingSilent + dflags + (text "CmmLint"<+>brackets (ppr this_mod)) + (const ()) $ do + { case cmmLint dflags cmm of + Just err -> do { log_action dflags + dflags + NoReason + SevDump + noSrcSpan + $ withPprStyle defaultDumpStyle err + ; ghcExit dflags 1 + } + Nothing -> return () + ; return cmm + } + + ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; a <- case hscTarget dflags of + HscAsm -> outputAsm dflags this_mod location filenm + linted_cmm_stream + HscC -> outputC dflags filenm linted_cmm_stream pkg_deps + HscLlvm -> outputLlvm dflags filenm linted_cmm_stream + HscInterpreted -> panic "codeOutput: HscInterpreted" + HscNothing -> panic "codeOutput: HscNothing" + ; return (filenm, stubs_exist, foreign_fps, a) + } + +doOutput :: String -> (Handle -> IO a) -> IO a +doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action + +{- +************************************************************************ +* * +\subsection{C} +* * +************************************************************************ +-} + +outputC :: DynFlags + -> FilePath + -> Stream IO RawCmmGroup a + -> [UnitId] + -> IO a + +outputC dflags filenm cmm_stream packages + = do + withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + let pkg_names = map unitIdString packages + doOutput filenm $ \ h -> do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h "#include \"Stg.h\"\n" + Stream.consume cmm_stream (writeC dflags h) + +{- +************************************************************************ +* * +\subsection{Assembler} +* * +************************************************************************ +-} + +outputAsm :: DynFlags -> Module -> ModLocation -> FilePath + -> Stream IO RawCmmGroup a + -> IO a +outputAsm dflags this_mod location filenm cmm_stream + = do ncg_uniqs <- mkSplitUniqSupply 'n' + + debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + + {-# SCC "OutputAsm" #-} doOutput filenm $ + \h -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream + +{- +************************************************************************ +* * +\subsection{LLVM} +* * +************************************************************************ +-} + +outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputLlvm dflags filenm cmm_stream + = do {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen dflags f cmm_stream + +{- +************************************************************************ +* * +\subsection{Foreign import/export} +* * +************************************************************************ +-} + +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs + -> IO (Bool, -- Header file created + Maybe FilePath) -- C file created +outputForeignStubs dflags mod location stubs + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags TFL_CurrentModule "c" + + case stubs of + NoStubs -> + return (False, Nothing) + + ForeignStubs h_code c_code -> do + let + stub_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc dflags stub_c_output_d + + -- Header file protos for "foreign export"ed functions. + stub_h_output_d = pprCode CStyle h_code + stub_h_output_w = showSDoc dflags stub_h_output_d + + createDirectoryIfMissing True (takeDirectory stub_h) + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export header file" + FormatC + stub_h_output_d + + -- we need the #includes from the rts package for the stub files + let rts_includes = + let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in + concatMap mk_include (unitIncludes rts_pkg) + mk_include i = "#include \"" ++ i ++ "\"\n" + + -- wrapper code mentions the ffi_arg type, which comes from ffi.h + ffi_includes + | platformMisc_libFFI $ platformMisc dflags = "#include \n" + | otherwise = "" + + stub_h_file_exists + <- outputForeignStubs_help stub_h stub_h_output_w + ("#include \n" ++ cplusplus_hdr) cplusplus_ftr + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export stubs" FormatC stub_c_output_d + + stub_c_file_exists + <- outputForeignStubs_help stub_c stub_c_output_w + ("#define IN_STG_CODE 0\n" ++ + "#include \n" ++ + rts_includes ++ + ffi_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. + + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where + cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n" + cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" + + +-- Don't use doOutput for dumping the f. export stubs +-- since it is more than likely that the stubs file will +-- turn out to be empty, in which case no file should be created. +outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool +outputForeignStubs_help _fname "" _header _footer = return False +outputForeignStubs_help fname doc_str header footer + = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") + return True + +-- ----------------------------------------------------------------------------- +-- Initialising cost centres + +-- We must produce declarations for the cost-centres defined in this +-- module; + +-- | Generate code to initialise cost centres +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, singleton_CCSs) + = vcat + $ map emit_cc_decl local_CCs + ++ map emit_ccs_decl singleton_CCSs + ++ [emit_cc_list local_CCs] + ++ [emit_ccs_list singleton_CCSs] + ++ [ text "static void prof_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void prof_init_" <> ppr this_mod <> text "(void)" + , braces (vcat + [ text "registerCcList" <> parens local_cc_list_label <> semi + , text "registerCcsList" <> parens singleton_cc_list_label <> semi + ]) + ] + where + emit_cc_decl cc = + text "extern CostCentre" <+> cc_lbl <> text "[];" + where cc_lbl = ppr (mkCCLabel cc) + local_cc_list_label = text "local_cc_" <> ppr this_mod + emit_cc_list ccs = + text "static CostCentre *" <> local_cc_list_label <> text "[] =" + <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma + | cc <- ccs + ] ++ [text "NULL"]) + <> semi + + emit_ccs_decl ccs = + text "extern CostCentreStack" <+> ccs_lbl <> text "[];" + where ccs_lbl = ppr (mkCCSLabel ccs) + singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod + emit_ccs_list ccs = + text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" + <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma + | cc <- ccs + ] ++ [text "NULL"]) + <> semi diff --git a/GHC/Driver/Finder.hs b/GHC/Driver/Finder.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Finder.hs @@ -0,0 +1,851 @@ +{- +(c) The University of Glasgow, 2000-2006 + +\section[Finder]{Module Finder} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Driver.Finder ( + flushFinderCaches, + FindResult(..), + findImportedModule, + findPluginModule, + findExactModule, + findHomeModule, + findExposedPackageModule, + mkHomeModLocation, + mkHomeModLocation2, + mkHiOnlyModLocation, + mkHiPath, + mkObjPath, + addHomeModuleToFinder, + uncacheModule, + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + + cannotFindModule, + cannotFindInterface, + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Unit +import GHC.Driver.Types +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Builtin.Names ( gHC_PRIM ) +import GHC.Driver.Session +import GHC.Driver.Ways +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe ( expectJust ) + +import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) +import System.Directory +import System.FilePath +import Control.Monad +import Data.Time + + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllUnits for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + +-- remove all the home modules from the cache; package modules are +-- assumed to not move around during a session. +flushFinderCaches :: HscEnv -> IO () +flushFinderCaches hsc_env = + atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) + where + this_pkg = homeUnit (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True + | otherwise = False + +addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () +addToFinderCache ref key val = + atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) + +removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO () +removeFromFinderCache ref key = + atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) + +lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) +lookupFinderCache ref key = do + c <- readIORef ref + return $! lookupInstalledModuleEnv c key + +-- ----------------------------------------------------------------------------- +-- The three external entry points + +-- | Locate a module that was imported by the user. We have the +-- module's name, and possibly a package name. Without a package +-- name, this function will use the search path and the known exposed +-- packages to find the module, if a package is specified then only +-- that package is searched for the module. + +findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult +findImportedModule hsc_env mod_name mb_pkg = + case mb_pkg of + Nothing -> unqual_import + Just pkg | pkg == fsLit "this" -> home_import -- "this" is special + | otherwise -> pkg_import + where + home_import = findHomeModule hsc_env mod_name + + pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg + + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name Nothing + +-- | Locate a plugin module requested by the user, for a compiler +-- plugin. This consults the same set of exposed packages as +-- 'findImportedModule', unless @-hide-all-plugin-packages@ or +-- @-plugin-package@ are specified. +findPluginModule :: HscEnv -> ModuleName -> IO FindResult +findPluginModule hsc_env mod_name = + findHomeModule hsc_env mod_name + `orIfNotFound` + findExposedPluginPackageModule hsc_env mod_name + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). + +findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult +findExactModule hsc_env mod = + let dflags = hsc_dflags hsc_env + in if moduleUnit mod `unitIdEq` homeUnit dflags + then findInstalledHomeModule hsc_env (moduleName mod) + else findPackageModule hsc_env mod + +-- ----------------------------------------------------------------------------- +-- Helpers + +-- | Given a monadic actions @this@ and @or_this@, first execute +-- @this@. If the returned 'FindResult' is successful, return +-- it; otherwise, execute @or_this@. If both failed, this function +-- also combines their failure messages in a reasonable way. +orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult +orIfNotFound this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + _other -> return res + +-- | Helper function for 'findHomeModule': this function wraps an IO action +-- which would look up @mod_name@ in the file system (the home package), +-- and first consults the 'hsc_FC' cache to see if the lookup has already +-- been done. Otherwise, do the lookup (with the IO action) and save +-- the result in the finder cache and the module location cache (if it +-- was successful.) +homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult +homeSearchCache hsc_env mod_name do_this = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + modLocationCache hsc_env mod do_this + +findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString + -> IO FindResult +findExposedPackageModule hsc_env mod_name mb_pkg + = findLookupResult hsc_env + $ lookupModuleWithSuggestions + (unitState (hsc_dflags hsc_env)) mod_name mb_pkg + +findExposedPluginPackageModule :: HscEnv -> ModuleName + -> IO FindResult +findExposedPluginPackageModule hsc_env mod_name + = findLookupResult hsc_env + $ lookupPluginModuleWithSuggestions + (unitState (hsc_dflags hsc_env)) mod_name Nothing + +findLookupResult :: HscEnv -> LookupResult -> IO FindResult +findLookupResult hsc_env r = case r of + LookupFound m pkg_conf -> do + let im = fst (getModuleInstantiation m) + r' <- findPackageModule_ hsc_env im (fst pkg_conf) + case r' of + -- TODO: ghc -M is unlikely to do the right thing + -- with just the location of the thing that was + -- instantiated; you probably also need all of the + -- implicit locations from the instances + InstalledFound loc _ -> return (Found loc m) + InstalledNoPackage _ -> return (NoPackage (moduleUnit m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m) + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = []}) + LookupMultiple rs -> + return (FoundMultiple rs) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens + , fr_unusables = [] + , fr_suggestions = [] }) + LookupUnusable unusable -> + let unusables' = map get_unusable unusable + get_unusable (m, ModUnusable r) = (moduleUnit m, r) + get_unusable (_, r) = + pprPanic "findLookupResult: unexpected origin" (ppr r) + in return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = unusables' + , fr_suggestions = [] }) + LookupNotFound suggest -> do + let suggest' + | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest + | otherwise = [] + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = suggest' }) + +modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult +modLocationCache hsc_env mod do_this = do + m <- lookupFinderCache (hsc_FC hsc_env) mod + case m of + Just result -> return result + Nothing -> do + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod result + return result + +mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule +mkHomeInstalledModule dflags mod_name = + let iuid = homeUnitId dflags + in Module iuid mod_name + +-- This returns a module because it's more convenient for users +addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module +addHomeModuleToFinder hsc_env mod_name loc = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) + return (mkHomeModule (hsc_dflags hsc_env) mod_name) + +uncacheModule :: HscEnv -> ModuleName -> IO () +uncacheModule hsc_env mod_name = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + removeFromFinderCache (hsc_FC hsc_env) mod + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule hsc_env mod_name = do + r <- findInstalledHomeModule hsc_env mod_name + return $ case r of + InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_unusables = [], + fr_suggestions = [] + } + where + dflags = hsc_dflags hsc_env + uid = homeUnit dflags + +-- | Implements the search for a module name in the home package only. Calling +-- this function directly is usually *not* what you want; currently, it's used +-- as a building block for the following operations: +-- +-- 1. When you do a normal package lookup, we first check if the module +-- is available in the home module, before looking it up in the package +-- database. +-- +-- 2. When you have a package qualified import with package name "this", +-- we shortcut to the home module. +-- +-- 3. When we look up an exact 'Module', if the unit id associated with +-- the module is the current home module do a look up in the home module. +-- +-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to +-- call this.) +findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule hsc_env mod_name = + homeSearchCache hsc_env mod_name $ + let + dflags = hsc_dflags hsc_env + home_path = importPaths dflags + hisuf = hiSuf dflags + mod = mkHomeInstalledModule dflags mod_name + + source_exts = + [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") + , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") + , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") + , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") + ] + + -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that + -- when hiDir field is set in dflags, we know to look there (see #16500) + hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name) + , (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts + in + + -- special case for GHC.Prim; we won't find it in the filesystem. + -- This is important only when compiling the base package (where GHC.Prim + -- is a home module). + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else searchPathExts home_path mod exts + + +-- | Search for a module in external packages only. +findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult +findPackageModule hsc_env mod = do + let + dflags = hsc_dflags hsc_env + pkg_id = moduleUnit mod + pkgstate = unitState dflags + -- + case lookupUnitId pkgstate pkg_id of + Nothing -> return (InstalledNoPackage pkg_id) + Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf + +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2) +-- the 'UnitInfo' must be consistent with the unit id in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. +findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult +findPackageModule_ hsc_env mod pkg_conf = + ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) ) + modLocationCache hsc_env mod $ + + -- special case for GHC.Prim; we won't find it in the filesystem. + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else + + let + dflags = hsc_dflags hsc_env + tag = waysBuildTag (ways dflags) + + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = "hi" + | otherwise = tag ++ "_hi" + + mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf + + import_dirs = unitImportDirs pkg_conf + -- we never look for a .hi-boot file in an external package; + -- .hi-boot files only make sense for the home package. + in + case import_dirs of + [one] | MkDepend <- ghcMode dflags -> do + -- there's only one place that this .hi file can be, so + -- don't bother looking for it. + let basename = moduleNameSlashes (moduleName mod) + loc <- mk_hi_loc one basename + return (InstalledFound loc mod) + _otherwise -> + searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts + :: [FilePath] -- paths to search + -> InstalledModule -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action + ) + ] + -> IO InstalledFindResult + +searchPathExts paths mod exts + = do result <- search to_search +{- + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result + + where + basename = moduleNameSlashes (moduleName mod) + + to_search :: [(FilePath, IO ModLocation)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path basename + file = base <.> ext + ] + + search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) + + search ((file, mk_result) : rest) = do + b <- doesFileExist file + if b + then do { loc <- mk_result; return (InstalledFound loc mod) } + else search rest + +mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt + -> FilePath -> BaseName -> IO ModLocation +mkHomeModLocationSearched dflags mod suff path basename = do + mkHomeModLocation2 dflags mod (path basename) suff + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): (moduleNameSlashes mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do + let (basename,extension) = splitExtension src_filename + mkHomeModLocation2 dflags mod basename extension + +mkHomeModLocation2 :: DynFlags + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation +mkHomeModLocation2 dflags mod src_basename ext = do + let mod_basename = moduleNameSlashes mod + + obj_fn = mkObjPath dflags src_basename mod_basename + hi_fn = mkHiPath dflags src_basename mod_basename + hie_fn = mkHiePath dflags src_basename mod_basename + + return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn, + ml_hie_file = hie_fn }) + +mkHomeModHiOnlyLocation :: DynFlags + -> ModuleName + -> FilePath + -> BaseName + -> IO ModLocation +mkHomeModHiOnlyLocation dflags mod path basename = do + loc <- mkHomeModLocation2 dflags mod (path basename) "" + return loc { ml_hs_file = Nothing } + +mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String + -> IO ModLocation +mkHiOnlyModLocation dflags hisuf path basename + = do let full_basename = path basename + obj_fn = mkObjPath dflags full_basename basename + hie_fn = mkHiePath dflags full_basename basename + return ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn, + ml_hie_file = hie_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkObjPath dflags basename mod_basename = obj_basename <.> osuf + where + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename + + +-- | Constructs the filename of a .hi file for a given source file. +-- Does /not/ check whether the .hi file exists +mkHiPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiPath dflags basename mod_basename = hi_basename <.> hisuf + where + hidir = hiDir dflags + hisuf = hiSuf dflags + + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename + +-- | Constructs the filename of a .hie file for a given source file. +-- Does /not/ check whether the .hie file exists +mkHiePath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf + where + hiedir = hieDir dflags + hiesuf = hieSuf dflags + + hie_basename | Just dir <- hiedir = dir mod_basename + | otherwise = basename + + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: DynFlags + -> ModuleName + -> ModLocation + -> FilePath + +mkStubPaths dflags mod location + = let + stubdir = stubDir dflags + + mod_basename = moduleNameSlashes mod + src_basename = dropExtension $ expectJust "mkStubPaths" + (ml_hs_file location) + + stub_basename0 + | Just dir <- stubdir = dir mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + stub_basename <.> "h" + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) + +-- ----------------------------------------------------------------------------- +-- Error messages + +cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc +cannotFindModule flags mod res = + cantFindErr (sLit cannotFindMsg) + (sLit "Ambiguous module name") + flags mod res + where + cannotFindMsg = + case res of + NotFound { fr_mods_hidden = hidden_mods + , fr_pkgs_hidden = hidden_pkgs + , fr_unusables = unusables } + | not (null hidden_mods && null hidden_pkgs && null unusables) + -> "Could not load module" + _ -> "Could not find module" + +cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc +cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") + (sLit "Ambiguous interface for") + +cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult + -> SDoc +cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + sep [text "it was found in multiple packages:", + hsep (map ppr pkgs) ] + ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (moduleUnit m : xs) + unambiguousPackage _ _ = Nothing + + pprMod (m, o) = text "it is bound as" <+> ppr m <+> + text "by" <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [text "package" <+> ppr (moduleUnit m)] + else [] ++ + map ((text "a reexport in package" <+>) + .ppr.mkUnit) res ++ + if f then [text "a package flag"] else [] + ) + +cantFindErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + pkgs = unitState dflags + more_info + = case find_result of + NoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" + + NotFound { fr_paths = files, fr_pkg = mb_pkg + , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens + , fr_unusables = unusables, fr_suggestions = suggest } + | Just pkg <- mb_pkg, pkg /= homeUnit dflags + -> not_found_in_package pkg files + + | not (null suggest) + -> pp_suggestions suggest $$ tried_these files dflags + + | null files && null mod_hiddens && + null pkg_hiddens && null unusables + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> vcat (map pkg_hidden pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ + vcat (map unusable unusables) $$ + tried_these files dflags + + _ -> panic "cantFindErr" + + build_tag = waysBuildTag (ways dflags) + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files dflags + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files dflags + + pkg_hidden :: Unit -> SDoc + pkg_hidden uid = + text "It is a member of the hidden package" + <+> quotes (ppr uid) + --FIXME: we don't really want to show the unit id here we should + -- show the source package id or installed package id if it's ambiguous + <> dot $$ pkg_hidden_hint uid + pkg_hidden_hint uid + | gopt Opt_BuildingCabalPackage dflags + = let pkg = expectJust "pkg_hidden" (lookupUnit pkgs uid) + in text "Perhaps you need to add" <+> + quotes (ppr (unitPackageName pkg)) <+> + text "to the build-depends in your .cabal file." + | Just pkg <- lookupUnit pkgs uid + = text "You can run" <+> + quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> + text "to expose it." $$ + text "(Note: this unloads all the modules in the current scope.)" + | otherwise = Outputable.empty + + mod_hidden pkg = + text "it is a hidden module in the package" <+> quotes (ppr pkg) + + unusable (pkg, reason) + = text "It is a member of the package" + <+> quotes (ppr pkg) + $$ pprReason (text "which is") reason + + pp_suggestions :: [ModuleSuggestion] -> SDoc + pp_suggestions sugs + | null sugs = Outputable.empty + | otherwise = hang (text "Perhaps you meant") + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty + provenance (ModOrigin{ fromOrigUnit = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (text "from" <+> ppr (moduleUnit mod)) + | f && moduleName mod == m + = parens (text "from" <+> ppr (moduleUnit mod)) + | (pkg:_) <- res + = parens (text "from" <+> ppr (mkUnit pkg) + <> comma <+> text "reexporting" <+> ppr mod) + | f + = parens (text "defined via package flags to be" + <+> ppr mod) + | otherwise = Outputable.empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty + provenance (ModOrigin{ fromOrigUnit = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (text "needs flag -package-id" + <+> ppr (moduleUnit mod)) + | (pkg:_) <- rhs + = parens (text "needs flag -package-id" + <+> ppr (mkUnit pkg)) + | otherwise = Outputable.empty + +cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName + -> InstalledFindResult -> SDoc +cantFindInstalledErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + InstalledNoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" $$ looks_like_srcpkgid pkg + + InstalledNotFound files mb_pkg + | Just pkg <- mb_pkg, not (pkg `unitIdEq` homeUnit dflags) + -> not_found_in_package pkg files + + | null files + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> tried_these files dflags + + _ -> panic "cantFindInstalledErr" + + build_tag = waysBuildTag (ways dflags) + pkgstate = unitState dflags + + looks_like_srcpkgid :: UnitId -> SDoc + looks_like_srcpkgid pk + -- Unsafely coerce a unit id (i.e. an installed package component + -- identifier) into a PackageId and see if it means anything. + | (pkg:pkgs) <- searchPackageId pkgstate (PackageId (unitIdFS pk)) + = parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ + (if null pkgs then Outputable.empty + else text "and" <+> int (length pkgs) <+> text "other candidates")) + -- Todo: also check if it looks like a package name! + | otherwise = Outputable.empty + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files dflags + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files dflags + +tried_these :: [FilePath] -> DynFlags -> SDoc +tried_these files dflags + | null files = Outputable.empty + | verbosity dflags < 3 = + text "Use -v (or `:set -v` in ghci) " <> + text "to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Flags.hs @@ -0,0 +1,529 @@ +module GHC.Driver.Flags + ( DumpFlag(..) + , GeneralFlag(..) + , WarningFlag(..) + , WarnReason (..) + , Language(..) + , optimisationFlags + ) +where + +import GHC.Prelude +import GHC.Utils.Outputable +import GHC.Data.EnumSet as EnumSet +import GHC.Utils.Json + +-- | Debugging flags +data DumpFlag +-- See Note [Updating flag description in the User's Guide] + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_cmm_from_stg + | Opt_D_dump_cmm_raw + | Opt_D_dump_cmm_verbose_by_proc + -- All of the cmm subflags (there are a lot!) automatically + -- enabled if you run -ddump-cmm-verbose-by-proc + -- Each flag corresponds to exact stage of Cmm pipeline. + | Opt_D_dump_cmm_verbose + -- same as -ddump-cmm-verbose-by-proc but writes each stage + -- to a separate file (if used with -ddump-to-file) + | Opt_D_dump_cmm_cfg + | Opt_D_dump_cmm_cbe + | Opt_D_dump_cmm_switch + | Opt_D_dump_cmm_proc + | Opt_D_dump_cmm_sp + | Opt_D_dump_cmm_sink + | Opt_D_dump_cmm_caf + | Opt_D_dump_cmm_procmap + | Opt_D_dump_cmm_split + | Opt_D_dump_cmm_info + | Opt_D_dump_cmm_cps + -- end cmm subflags + | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. + | Opt_D_dump_asm + | Opt_D_dump_asm_native + | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_regalloc + | Opt_D_dump_asm_regalloc_stages + | Opt_D_dump_asm_conflicts + | Opt_D_dump_asm_stats + | Opt_D_dump_asm_expanded + | Opt_D_dump_llvm + | Opt_D_dump_core_stats + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_ds_preopt + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_verbose_inlinings + | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites + | Opt_D_dump_simpl_trace + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_parsed_ast + | Opt_D_dump_rn + | Opt_D_dump_rn_ast + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg -- CoreToStg output + | Opt_D_dump_stg_unarised -- STG after unarise + | Opt_D_dump_stg_final -- STG after stg2stg + | Opt_D_dump_call_arity + | Opt_D_dump_exitify + | Opt_D_dump_stranal + | Opt_D_dump_str_signatures + | Opt_D_dump_cpranal + | Opt_D_dump_cpr_signatures + | Opt_D_dump_tc + | Opt_D_dump_tc_ast + | Opt_D_dump_hie + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_tc_trace + | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker + | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace + | Opt_D_dump_splices + | Opt_D_th_dec_file + | Opt_D_dump_BCOs + | Opt_D_dump_ticked + | Opt_D_dump_rtti + | Opt_D_source_stats + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map + | Opt_D_dump_timings + | Opt_D_dump_view_pattern_commoning + | Opt_D_verbose_core2core + | Opt_D_dump_debug + | Opt_D_dump_json + | Opt_D_ppr_debug + | Opt_D_no_debug_output + deriving (Eq, Show, Enum) + +-- | Enumerates the simple on-or-off dynamic flags +data GeneralFlag +-- See Note [Updating flag description in the User's Guide] + + = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_D_faststring_stats + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoLinearCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + | Opt_DoAsmLinting + | Opt_DoAnnotationLinting + | Opt_NoLlvmMangler -- hidden flag + | Opt_FastLlvm -- hidden flag + | Opt_NoTypeableBinds + + | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_ShowWarnGroups -- Show the group a warning belongs to + | Opt_HideSourcePaths -- Hide module source/object paths + + | Opt_PrintExplicitForalls + | Opt_PrintExplicitKinds + | Opt_PrintExplicitCoercions + | Opt_PrintExplicitRuntimeReps + | Opt_PrintEqualityRelations + | Opt_PrintAxiomIncomps + | Opt_PrintUnicodeSyntax + | Opt_PrintExpandedSynonyms + | Opt_PrintPotentialInstances + | Opt_PrintTypecheckerElaboration + + -- optimisation opts + | Opt_CallArity + | Opt_Exitification + | Opt_Strictness + | Opt_LateDmdAnal -- #6087 + | Opt_KillAbsence + | Opt_KillOneShot + | Opt_FullLaziness + | Opt_FloatIn + | Opt_LateSpecialise + | Opt_Specialise + | Opt_SpecialiseAggressively + | Opt_CrossModuleSpecialise + | Opt_StaticArgumentTransformation + | Opt_CSE + | Opt_StgCSE + | Opt_StgLiftLams + | Opt_LiberateCase + | Opt_SpecConstr + | Opt_SpecConstrKeen + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_CaseFolding -- Constant folding through case-expressions + | Opt_UnboxStrictFields + | Opt_UnboxSmallStrictFields + | Opt_DictsCheap + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices + | Opt_RegsGraph -- do graph coloring register allocation + | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- Be picky about how we treat bottom + | Opt_LlvmTBAA -- Use LLVM TBAA infrastructure for improving AA (hidden flag) + | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) + | Opt_IrrefutableTuples + | Opt_CmmSink + | Opt_CmmStaticPred + | Opt_CmmElimCommonBlocks + | Opt_AsmShortcutting + | Opt_OmitYields + | Opt_FunToThunk -- allow GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs to remove all value lambdas + | Opt_DictsStrict -- be strict in argument dictionaries + | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors + | Opt_Loopification -- See Note [Self-recursive tail calls] + | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. + | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. + | Opt_CprAnal + | Opt_WorkerWrapper + | Opt_SolveConstantDicts + | Opt_AlignmentSanitisation + | Opt_CatchBottoms + | Opt_NumConstantFolding + + -- PreInlining is on by default. The option is there just to see how + -- bad things get if you turn it off! + | Opt_SimplPreInlining + + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + | Opt_WriteInterface -- forces .hi files to be written even with -fno-code + | Opt_WriteHie -- generate .hie files + + -- profiling opts + | Opt_AutoSccsOnIndividualCafs + | Opt_ProfCountEntries + + -- misc opts + | Opt_Pp + | Opt_ForceRecomp + | Opt_IgnoreOptimChanges + | Opt_IgnoreHpcChanges + | Opt_ExcessPrecision + | Opt_EagerBlackHoling + | Opt_NoHsMain + | Opt_SplitSections + | Opt_StgStats + | Opt_HideAllPackages + | Opt_HideAllPluginPackages + | Opt_PrintBindResult + | Opt_Haddock + | Opt_HaddockOptions + | Opt_BreakOnException + | Opt_BreakOnError + | Opt_PrintEvldWithShow + | Opt_PrintBindContents + | Opt_GenManifest + | Opt_EmbedManifest + | Opt_SharedImplib + | Opt_BuildingCabalPackage + | Opt_IgnoreDotGhci + | Opt_GhciSandbox + | Opt_GhciHistory + | Opt_GhciLeakCheck + | Opt_ValidateHie + | Opt_LocalGhciHistory + | Opt_NoIt + | Opt_HelpfulErrors + | Opt_DeferTypeErrors + | Opt_DeferTypedHoles + | Opt_DeferOutOfScopeVariables + | Opt_PIC -- ^ @-fPIC@ + | Opt_PIE -- ^ @-fPIE@ + | Opt_PICExecutable -- ^ @-pie@ + | Opt_ExternalDynamicRefs + | Opt_Ticky + | Opt_Ticky_Allocd + | Opt_Ticky_LNE + | Opt_Ticky_Dyn_Thunk + | Opt_RPath + | Opt_RelativeDynlibPaths + | Opt_Hpc + | Opt_FlatCache + | Opt_ExternalInterpreter + | Opt_OptimalApplicativeDo + | Opt_VersionMacros + | Opt_WholeArchiveHsLibs + -- copy all libs into a single folder prior to linking binaries + -- this should elivate the excessive command line limit restrictions + -- on windows, by only requiring a single -L argument instead of + -- one for each dependency. At the time of this writing, gcc + -- forwards all -L flags to the collect2 command without using a + -- response file and as such breaking apart. + | Opt_SingleLibFolder + | Opt_KeepCAFs + | Opt_KeepGoing + | Opt_ByteCodeIfUnboxed + | Opt_LinkRts + + -- output style opts + | Opt_ErrorSpans -- Include full span info in error messages, + -- instead of just the start position. + | Opt_DeferDiagnostics + | Opt_DiagnosticsShowCaret -- Show snippets of offending code + | Opt_PprCaseAsLet + | Opt_PprShowTicks + | Opt_ShowHoleConstraints + -- Options relating to the display of valid hole fits + -- when generating an error message for a typed hole + -- See Note [Valid hole fits include] in GHC.Tc.Errors.Hole + | Opt_ShowValidHoleFits + | Opt_SortValidHoleFits + | Opt_SortBySizeHoleFits + | Opt_SortBySubsumHoleFits + | Opt_AbstractRefHoleFits + | Opt_UnclutterValidHoleFits + | Opt_ShowTypeAppOfHoleFits + | Opt_ShowTypeAppVarsOfHoleFits + | Opt_ShowDocsOfHoleFits + | Opt_ShowTypeOfHoleFits + | Opt_ShowProvOfHoleFits + | Opt_ShowMatchesOfHoleFits + + | Opt_ShowLoadedModules + | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] + + -- Suppress all coercions, them replacing with '...' + | Opt_SuppressCoercions + | Opt_SuppressVarKinds + -- Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- Suppress type applications. + | Opt_SuppressTypeApplications + -- Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressUnfoldings + -- Suppress the details of even stable unfoldings + | Opt_SuppressTypeSignatures + -- Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + | Opt_SuppressStgExts + | Opt_SuppressTicks -- Replaces Opt_PprShowTicks + | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps + + -- temporary flags + | Opt_AutoLinkPackages + | Opt_ImplicitImportQualified + + -- keeping stuff + | Opt_KeepHscppFiles + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepTmpFiles + | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles + | Opt_KeepHiFiles + | Opt_KeepOFiles + + | Opt_BuildDynamicToo + + -- safe haskell flags + | Opt_DistrustAllPackages + | Opt_PackageTrust + | Opt_PluginTrustworthy + + | Opt_G_NoStateHack + | Opt_G_NoOptCoercion + deriving (Eq, Show, Enum) + +-- Check whether a flag should be considered an "optimisation flag" +-- for purposes of recompilation avoidance (see +-- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is +-- not a guarantee that the flag has no other effect. We could, and +-- perhaps should, separate out the flags that have some minor impact on +-- program semantics and/or error behavior (e.g., assertions), but +-- then we'd need to go to extra trouble (and an additional flag) +-- to allow users to ignore the optimisation level even though that +-- means ignoring some change. +optimisationFlags :: EnumSet GeneralFlag +optimisationFlags = EnumSet.fromList + [ Opt_CallArity + , Opt_Strictness + , Opt_LateDmdAnal + , Opt_KillAbsence + , Opt_KillOneShot + , Opt_FullLaziness + , Opt_FloatIn + , Opt_LateSpecialise + , Opt_Specialise + , Opt_SpecialiseAggressively + , Opt_CrossModuleSpecialise + , Opt_StaticArgumentTransformation + , Opt_CSE + , Opt_StgCSE + , Opt_StgLiftLams + , Opt_LiberateCase + , Opt_SpecConstr + , Opt_SpecConstrKeen + , Opt_DoLambdaEtaExpansion + , Opt_IgnoreAsserts + , Opt_DoEtaReduction + , Opt_CaseMerge + , Opt_CaseFolding + , Opt_UnboxStrictFields + , Opt_UnboxSmallStrictFields + , Opt_DictsCheap + , Opt_EnableRewriteRules + , Opt_RegsGraph + , Opt_RegsIterative + , Opt_PedanticBottoms + , Opt_LlvmTBAA + , Opt_LlvmFillUndefWithGarbage + , Opt_IrrefutableTuples + , Opt_CmmSink + , Opt_CmmElimCommonBlocks + , Opt_AsmShortcutting + , Opt_OmitYields + , Opt_FunToThunk + , Opt_DictsStrict + , Opt_DmdTxDictSel + , Opt_Loopification + , Opt_CfgBlocklayout + , Opt_WeightlessBlocklayout + , Opt_CprAnal + , Opt_WorkerWrapper + , Opt_SolveConstantDicts + , Opt_CatchBottoms + , Opt_IgnoreAsserts + ] + +data WarningFlag = +-- See Note [Updating flag description in the User's Guide] + Opt_WarnDuplicateExports + | Opt_WarnDuplicateConstraints + | Opt_WarnRedundantConstraints + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSignatures + | Opt_WarnMissingLocalSignatures + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedTopBinds + | Opt_WarnUnusedLocalBinds + | Opt_WarnUnusedPatternBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnUnusedTypePatterns + | Opt_WarnUnusedForalls + | Opt_WarnUnusedRecordWildcards + | Opt_WarnRedundantRecordWildcards + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8 + | Opt_WarnSemigroup -- since 8.0 + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + | Opt_WarnUnsafe + | Opt_WarnSafe + | Opt_WarnTrustworthySafe + | Opt_WarnMissedSpecs + | Opt_WarnAllMissedSpecs + | Opt_WarnUnsupportedCallingConventions + | Opt_WarnUnsupportedLlvmVersion + | Opt_WarnMissedExtraSharedLib + | Opt_WarnInlineRuleShadowing + | Opt_WarnTypedHoles + | Opt_WarnPartialTypeSignatures + | Opt_WarnMissingExportedSignatures + | Opt_WarnUntickedPromotedConstructors + | Opt_WarnDerivingTypeable + | Opt_WarnDeferredTypeErrors + | Opt_WarnDeferredOutOfScopeVariables + | Opt_WarnNonCanonicalMonadInstances -- since 8.0 + | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 + | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 + | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 + | Opt_WarnUnrecognisedWarningFlags -- since 8.0 + | Opt_WarnSimplifiableClassConstraints -- Since 8.2 + | Opt_WarnCPPUndef -- Since 8.2 + | Opt_WarnUnbangedStrictPatterns -- Since 8.2 + | Opt_WarnMissingHomeModules -- Since 8.2 + | Opt_WarnPartialFields -- Since 8.4 + | Opt_WarnMissingExportList + | Opt_WarnInaccessibleCode + | Opt_WarnStarIsType -- Since 8.6 + | Opt_WarnStarBinder -- Since 8.6 + | Opt_WarnImplicitKindVars -- Since 8.6 + | Opt_WarnSpaceAfterBang + | Opt_WarnMissingDerivingStrategies -- Since 8.8 + | Opt_WarnPrepositiveQualifiedModule -- Since TBD + | Opt_WarnUnusedPackages -- Since 8.10 + | Opt_WarnInferredSafeImports -- Since 8.10 + | Opt_WarnMissingSafeHaskellMode -- Since 8.10 + | Opt_WarnCompatUnqualifiedImports -- Since 8.10 + | Opt_WarnDerivingDefaults + | Opt_WarnInvalidHaddock -- Since 8.12 + | Opt_WarnUnicodeBidirectionalFormatCharacters -- Since 9.0.2 + deriving (Eq, Show, Enum) + +-- | Used when outputting warnings: if a reason is given, it is +-- displayed. If a warning isn't controlled by a flag, this is made +-- explicit at the point of use. +data WarnReason + = NoReason + -- | Warning was enabled with the flag + | Reason !WarningFlag + -- | Warning was made an error because of -Werror or -Werror=WarningFlag + | ErrReason !(Maybe WarningFlag) + deriving Show + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json (Reason wf) = JSString (show wf) + json (ErrReason Nothing) = JSString "Opt_WarnIsError" + json (ErrReason (Just wf)) = JSString (show wf) + + +data Language = Haskell98 | Haskell2010 + deriving (Eq, Enum, Show, Bounded) + +instance Outputable Language where + ppr = text . show diff --git a/GHC/Driver/Hooks.hs b/GHC/Driver/Hooks.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Hooks.hs @@ -0,0 +1,122 @@ +-- \section[Hooks]{Low level API hooks} + +-- NB: this module is SOURCE-imported by DynFlags, and should primarily +-- refer to *types*, rather than *code* + +{-# LANGUAGE CPP, RankNTypes #-} + +module GHC.Driver.Hooks + ( Hooks + , emptyHooks + , lookupHook + , getHooked + -- the hooks: + , dsForeignsHook + , tcForeignImportsHook + , tcForeignExportsHook + , hscFrontendHook + , hscCompileCoreExprHook + , ghcPrimIfaceHook + , runPhaseHook + , runMetaHook + , linkHook + , runRnSpliceHook + , getValueSafelyHook + , createIservProcessHook + , stgToCmmHook + , cmmToRawCmmHook + ) +where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Types +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Data.OrdList +import GHC.Tc.Types +import GHC.Data.Bag +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Id +import GHC.Core +import GHCi.RemoteTypes +import GHC.Types.SrcLoc +import GHC.Core.Type +import System.Process +import GHC.Types.Basic +import GHC.Unit.Module +import GHC.Core.TyCon +import GHC.Types.CostCentre +import GHC.Stg.Syntax +import GHC.Data.Stream +import GHC.Cmm +import GHC.Hs.Extension +import GHC.StgToCmm.Types (ModuleLFInfos) + +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Hooks} +* * +************************************************************************ +-} + +-- | Hooks can be used by GHC API clients to replace parts of +-- the compiler pipeline. If a hook is not installed, GHC +-- uses the default built-in behaviour + +emptyHooks :: Hooks +emptyHooks = Hooks + { dsForeignsHook = Nothing + , tcForeignImportsHook = Nothing + , tcForeignExportsHook = Nothing + , hscFrontendHook = Nothing + , hscCompileCoreExprHook = Nothing + , ghcPrimIfaceHook = Nothing + , runPhaseHook = Nothing + , runMetaHook = Nothing + , linkHook = Nothing + , runRnSpliceHook = Nothing + , getValueSafelyHook = Nothing + , createIservProcessHook = Nothing + , stgToCmmHook = Nothing + , cmmToRawCmmHook = Nothing + } + +data Hooks = Hooks + { dsForeignsHook :: Maybe ([LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) + , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)) + , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)) + , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) + , hscCompileCoreExprHook :: + Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) + , ghcPrimIfaceHook :: Maybe ModIface + , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath)) + , runMetaHook :: Maybe (MetaHook TcM) + , linkHook :: Maybe (GhcLink -> DynFlags -> Bool + -> HomePackageTable -> IO SuccessFlag) + , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)) + , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type + -> IO (Maybe HValue)) + , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) + , stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs + -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos) + , cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a + -> IO (Stream IO RawCmmGroup a)) + } + +getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a +getHooked hook def = fmap (lookupHook hook def) getDynFlags + +lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a +lookupHook hook def = fromMaybe def . hook . hooks diff --git a/GHC/Driver/Hooks.hs-boot b/GHC/Driver/Hooks.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Hooks.hs-boot @@ -0,0 +1,7 @@ +module GHC.Driver.Hooks where + +import GHC.Prelude () + +data Hooks + +emptyHooks :: Hooks diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Main.hs @@ -0,0 +1,2037 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fprof-auto-top #-} + +------------------------------------------------------------------------------- +-- +-- | Main API for compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in "GHC.Driver.Pipeline" +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- We use the Hsc monad to deal with warning messages consistently: +-- specifically, while executing within an Hsc monad, warnings are +-- collected. When a Hsc monad returns to an IO monad, the +-- warnings are printed, or compilation aborts if the @-Werror@ +-- flag is enabled. +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.Main + ( + -- * Making an HscEnv + newHscEnv + + -- * Compiling complete source files + , Messager, batchMsg + , HscStatus (..) + , hscIncrementalCompile + , initModDetails + , hscMaybeWriteIface + , hscCompileCmmFile + + , hscGenHardCode + , hscInteractive + + -- * Running passes separately + , hscParse + , hscTypecheckRename + , hscDesugar + , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + + -- * Safe Haskell + , hscCheckSafe + , hscGetSafe + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo + , hscIsGHCiMonad + , hscGetModuleInterface + , hscRnImportDecls + , hscTcRnLookupRdrName + , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt + , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls + , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType + , hscParseExpr + , hscParseType + , hscCompileCoreExpr + -- * Low-level exports for hooks + , hscCompileCoreExpr' + -- We want to make sure that we export enough to be able to redefine + -- hsc_typecheck in client code + , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen + , getHscEnv + , hscSimpleIface' + , oneShotMsg + , dumpIfaceStats + , ioMsgMaybe + , showModuleIndex + , hscAddSptEntries + ) where + +import GHC.Prelude + +import Data.Data hiding (Fixity, TyCon) +import Data.Maybe ( fromJust ) +import GHC.Types.Id +import GHC.Runtime.Interpreter ( addSptEntry ) +import GHCi.RemoteTypes ( ForeignHValue ) +import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) +import GHC.Runtime.Linker +import GHC.Core.Tidy ( tidyExpr ) +import GHC.Core.Type ( Type, Kind ) +import GHC.Core.Lint ( lintInteractiveExpr ) +import GHC.Types.Var.Env ( emptyTidyEnv ) +import GHC.Utils.Panic +import GHC.Core.ConLike + +import GHC.Parser.Annotation +import GHC.Unit.Module +import GHC.Unit.State +import GHC.Types.Name.Reader +import GHC.Hs +import GHC.Hs.Dump +import GHC.Core +import GHC.Data.StringBuffer +import GHC.Parser +import GHC.Parser.Lexer as Lexer +import GHC.Types.SrcLoc +import GHC.Tc.Module +import GHC.IfaceToCore ( typecheckIface ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) +import GHC.Types.Name.Cache ( initNameCache ) +import GHC.Builtin.Utils +import GHC.Core.Opt.Pipeline +import GHC.HsToCore +import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface ) +import GHC.Iface.Make +import GHC.Iface.Recomp +import GHC.Iface.Tidy +import GHC.CoreToStg.Prep +import GHC.CoreToStg ( coreToStg ) +import GHC.Stg.Syntax +import GHC.Stg.FVs ( annTopBindingsFreeVars ) +import GHC.Stg.Pipeline ( stg2stg ) +import qualified GHC.StgToCmm as StgToCmm ( codeGen ) +import GHC.Types.CostCentre +import GHC.Core.TyCon +import GHC.Types.Name +import GHC.Cmm +import GHC.Cmm.Parser ( parseCmmFile ) +import GHC.Cmm.Info.Build +import GHC.Cmm.Pipeline +import GHC.Cmm.Info +import GHC.Driver.CodeOutput +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Utils.Fingerprint ( Fingerprint ) +import GHC.Driver.Hooks +import GHC.Tc.Utils.Env +import GHC.Builtin.Names +import GHC.Driver.Plugins +import GHC.Runtime.Loader ( initializePlugins ) +import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) + +import GHC.Driver.Session +import GHC.Utils.Error + +import GHC.Utils.Outputable +import GHC.Types.Name.Env +import GHC.Hs.Stats ( ppSourceStats ) +import GHC.Driver.Types +import GHC.Data.FastString +import GHC.Types.Unique.Supply +import GHC.Data.Bag +import GHC.Utils.Exception +import qualified GHC.Data.Stream as Stream +import GHC.Data.Stream (Stream) + +import GHC.Utils.Misc + +import Data.List ( nub, isPrefixOf, partition ) +import Control.Monad +import Data.IORef +import System.FilePath as FilePath +import System.Directory +import System.IO (fixIO) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Set (Set) +import Data.Functor +import Control.DeepSeq (force) +import Data.Bifunctor (first) + +import GHC.Iface.Ext.Ast ( mkHieFile ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..)) +import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) +import Data.List.NonEmpty (NonEmpty ((:|))) + +#include "HsVersions.h" + + +{- ********************************************************************** +%* * + Initialisation +%* * +%********************************************************************* -} + +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags = do + eps_var <- newIORef (initExternalPackageState dflags) + us <- mkSplitUniqSupply 'r' + nc_var <- newIORef (initNameCache us knownKeyNames) + fc_var <- newIORef emptyInstalledModuleEnv + emptyDynLinker <- uninitializedLinker + return HscEnv { hsc_dflags = dflags + , hsc_targets = [] + , hsc_mod_graph = emptyMG + , hsc_IC = emptyInteractiveContext dflags + , hsc_HPT = emptyHomePackageTable + , hsc_EPS = eps_var + , hsc_NC = nc_var + , hsc_FC = fc_var + , hsc_type_env_var = Nothing + , hsc_interp = Nothing + , hsc_dynLinker = emptyDynLinker + } + +-- ----------------------------------------------------------------------------- + +getWarnings :: Hsc WarningMessages +getWarnings = Hsc $ \_ w -> return (w, w) + +clearWarnings :: Hsc () +clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) + +logWarnings :: WarningMessages -> Hsc () +logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +handleWarnings :: Hsc () +handleWarnings = do + dflags <- getDynFlags + w <- getWarnings + liftIO $ printOrThrowWarnings dflags w + clearWarnings + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not $ isEmptyBag errs) $ throwErrors errs + +-- | Log warnings and throw errors, assuming the messages +-- contain at least one error (e.g. coming from PFailed) +handleWarningsThrowErrors :: Messages -> Hsc a +handleWarningsThrowErrors (warns, errs) = do + logWarnings warns + dflags <- getDynFlags + (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings + liftIO $ printBagOfErrors dflags wWarns + throwErrors (unionBags errs wErrs) + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + ((warns,errs), mb_r) <- liftIO ioA + logWarnings warns + case mb_r of + Nothing -> throwErrors errs + Just r -> ASSERT( isEmptyBag errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + ((warns,_errs), mb_r) <- liftIO $ ioA + logWarnings warns + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] +hscTcRnLookupRdrName hsc_env0 rdr_name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name + -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) +hscTcRnGetInfo hsc_env0 name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } + +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name + = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name + +hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations +hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls + +-- ----------------------------------------------------------------------------- +-- | parse a file, returning the abstract syntax + +hscParse :: HscEnv -> ModSummary -> IO HsParsedModule +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc HsParsedModule +hscParse' mod_summary + | Just r <- ms_parsed_mod mod_summary = return r + | otherwise = {-# SCC "Parser" #-} + withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) + (const ()) $ do + dflags <- getDynFlags + let src_filename = ms_hspp_file mod_summary + maybe_src_buf = ms_hspp_buf mod_summary + + -------------------------- Parser ---------------- + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> liftIO $ hGetStringBuffer src_filename + + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do + case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of + Nothing -> pure () + Just ((loc,chr,desc) :| xs) -> + let span = mkSrcSpanPs $ mkPsSpan loc (advancePsLoc loc chr) + warn = makeIntoWarning (Reason Opt_WarnUnicodeBidirectionalFormatCharacters) $ mkLongWarnMsg dflags span neverQualify msg empty + msg = text "A unicode bidirectional formatting character" <+> parens (text desc) + $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file" + $$ (case xs of + [] -> empty + xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs + where + pprChars [] = empty + pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc + $$ pprChars xs) + $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors" + + in liftIO $ printOrThrowWarnings dflags (unitBag warn) + + let parseMod | HsigFile == ms_hsc_src mod_summary + = parseSignature + | otherwise = parseModule + + case unP parseMod (mkPState dflags buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getMessages pst dflags) + POk pst rdr_module -> do + let (warns, errs) = getMessages pst dflags + logWarnings warns + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + FormatText (ppSourceStats False rdr_module) + when (not $ isEmptyBag errs) $ throwErrors errs + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "" and "" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = FilePath.normalise src_filename + srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) + $ filter (not . (== n_hspp)) + $ map FilePath.normalise + $ filter (not . isPrefixOf "<") + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location mod_summary) of + Just f -> filter (/= FilePath.normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + let api_anns = ApiAnns { + apiAnnItems = M.fromListWith (++) $ annotations pst, + apiAnnEofPos = eof_pos pst, + apiAnnComments = M.fromList (annotations_comments pst), + apiAnnRogueComments = comment_q pst + } + res = HsParsedModule { + hpm_module = rdr_module, + hpm_src_files = srcs2, + hpm_annotations = api_anns + } + + -- apply parse transformation of plugins + let applyPluginAction p opts + = parsedResultAction p opts mod_summary + withPlugins dflags applyPluginAction res + +checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String)) +checkBidirectionFormatChars start_loc sb + | containsBidirectionalFormatChar sb = Just $ go start_loc sb + | otherwise = Nothing + where + go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String) + go loc sb + | atEnd sb = panic "checkBidirectionFormatChars: no char found" + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb + | otherwise -> go (advancePsLoc loc chr) sb + + go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)] + go1 loc sb + | atEnd sb = [] + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) : go1 (advancePsLoc loc chr) sb + | otherwise -> go1 (advancePsLoc loc chr) sb + + +-- ----------------------------------------------------------------------------- +-- | If the renamed source has been kept, extract it. Dump it if requested. + + +extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- Hsc $ \e w -> return (e, w) + liftIO $ do + -- Validate Scopes + case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of + [] -> putMsg dflags $ text "Got valid scopes" + xs -> do + putMsg dflags $ text "Got invalid scopes" + mapM_ (putMsg dflags) xs + -- Roundtrip testing + file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg dflags $ text "Got no roundtrip errors" + xs -> do + putMsg dflags $ text "Got roundtrip errors" + mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs + return rn_info + + +-- ----------------------------------------------------------------------------- +-- | Rename and typecheck a module, additionally returning the renamed syntax +hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule + -> IO (TcGblEnv, RenamedStuff) +hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ + hsc_typecheck True mod_summary (Just rdr_module) + + +-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack +-- b) concerning dumping rename info and hie files. It would be nice to further +-- separate this stuff out, probably in conjunction better separating renaming +-- and type checking (#17781). +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkHomeModule dflags mod_name + inner_mod = canonicalizeHomeModule dflags mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + MASSERT( isHomeModule dflags outer_mod ) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing + ioMsgMaybe $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + -- TODO are we extracting anything when we merely instantiate a signature? + -- If not, try to move this into the "else" case above. + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' sum save_rn_syntax mod = do + hsc_env <- getHscEnv + dflags <- getDynFlags + + -- -Wmissing-safe-haskell-mode + when (not (safeHaskellModeEnabled dflags) + && wopt Opt_WarnMissingSafeHaskellMode dflags) $ + logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ + mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $ + warnMissingSafeHaskellMode + + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env sum + save_rn_syntax mod + + -- See Note [Safe Haskell Overlapping Instances Implementation] + -- although this is used for more than just that failure case. + (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res) + let allSafeOK = safeInferred dflags && tcSafeOK + + -- end of the safe haskell line, how to respond to user? + if not (safeHaskellOn dflags) + || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafeInfer tcg_res whyUnsafe + + -- module (could be) safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') + when safe $ do + case wopt Opt_WarnSafe dflags of + True + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnSafe) $ + mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ + errSafe tcg_res') + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ + mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ + errTwthySafe tcg_res') + False -> return () + return tcg_res' + where + pprMod t = ppr $ moduleName $ tcg_mod t + errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" + errTwthySafe t = quotes (pprMod t) + <+> text "is marked as Trustworthy but has been inferred as safe!" + warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum)) + <+> text "is missing Safe Haskell mode" + +-- | Convert a typechecked module to Core +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result = + runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result + +hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_location tc_result = do + hsc_env <- getHscEnv + r <- ioMsgMaybe $ + {-# SCC "deSugar" #-} + deSugar hsc_env mod_location tc_result + + -- always check -Werror after desugaring, this is the last opportunity for + -- warnings to arise before the backend. + handleWarnings + return r + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result + + +{- ********************************************************************** +%* * + The main compiler pipeline +%* * +%********************************************************************* -} + +{- + -------------------------------- + The compilation proper + -------------------------------- + +It's the task of the compilation proper to compile Haskell, hs-boot and core +files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all +(the module is still parsed and type-checked. This feature is mostly used by +IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', +'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' +mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode +targets byte-code. + +The modes are kept separate because of their different types and meanings: + + * In 'one-shot' mode, we're only compiling a single file and can therefore + discard the new ModIface and ModDetails. This is also the reason it only + targets hard-code; compiling to byte-code or nothing doesn't make sense when + we discard the result. + + * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface + and ModDetails. 'Batch' mode doesn't target byte-code since that require us to + return the newly compiled byte-code. + + * 'Nothing' mode has exactly the same type as 'batch' mode but they're still + kept separate. This is because compiling to nothing is fairly special: We + don't output any interface files, we don't run the simplifier and we don't + generate any code. + + * 'Interactive' mode is similar to 'batch' mode except that we return the + compiled byte-code together with the ModIface and ModDetails. + +Trying to compile a hs-boot file to byte-code will result in a run-time error. +This is the only thing that isn't caught by the type-system. +-} + + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () + +-- | This function runs GHC's frontend with recompilation +-- avoidance. Specifically, it checks if recompilation is needed, +-- and if it is, it parses and typechecks the input module. +-- It does not write out the results of typechecking (See +-- compileOne and hscIncrementalCompile). +hscIncrementalFrontend :: Bool -- always do basic recompilation check? + -> Maybe TcGblEnv + -> Maybe Messager + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface, if available + -> (Int,Int) -- (i,n) = module i of n (for msgs) + -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)) + +hscIncrementalFrontend + always_do_basic_recompilation_check m_tc_result + mHscMessage mod_summary source_modified mb_old_iface mod_index + = do + hsc_env <- getHscEnv + + let msg what = case mHscMessage of + Just hscMessage -> hscMessage hsc_env mod_index what mod_summary + Nothing -> return () + + skip iface = do + liftIO $ msg UpToDate + return $ Left iface + + compile mb_old_hash reason = do + liftIO $ msg reason + (tc_result, _) <- hsc_typecheck False mod_summary Nothing + return $ Right (FrontendTypecheck tc_result, mb_old_hash) + + stable = case source_modified of + SourceUnmodifiedAndStable -> True + _ -> False + + case m_tc_result of + Just tc_result + | not always_do_basic_recompilation_check -> + return $ Right (FrontendTypecheck tc_result, Nothing) + _ -> do + (recomp_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary + source_modified mb_old_iface + -- save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface + + case mb_checked_iface of + Just iface | not (recompileRequired recomp_reqd) -> + -- If the module used TH splices when it was last + -- compiled, then the recompilation check is not + -- accurate enough (#481) and we must ignore + -- it. However, if the module is stable (none of + -- the modules it depends on, directly or + -- indirectly, changed), then we *can* skip + -- recompilation. This is why the SourceModified + -- type contains SourceUnmodifiedAndStable, and + -- it's pretty important: otherwise ghc --make + -- would always recompile TH modules, even if + -- nothing at all has changed. Stability is just + -- the same check that make is doing for us in + -- one-shot mode. + case m_tc_result of + Nothing + | mi_used_th iface && not stable -> + compile mb_old_hash (RecompBecause "TH") + _ -> + skip iface + _ -> + case m_tc_result of + Nothing -> compile mb_old_hash recomp_reqd + Just tc_result -> + return $ Right (FrontendTypecheck tc_result, mb_old_hash) + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + +-- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts +-- of the pipeline. +-- We return a interface if we already had an old one around and recompilation +-- was not needed. Otherwise it will be created during later passes when we +-- run the compilation pipeline. +hscIncrementalCompile :: Bool + -> Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> (Int,Int) + -> IO (HscStatus, DynFlags) +hscIncrementalCompile always_do_basic_recompilation_check m_tc_result + mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index + = do + dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env') + let hsc_env'' = hsc_env' { hsc_dflags = dflags } + + -- One-shot mode needs a knot-tying mutable variable for interface + -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. + -- See also Note [hsc_type_env_var hack] + type_env_var <- newIORef emptyNameEnv + let mod = ms_mod mod_summary + hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env'')) + = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) } + | otherwise + = hsc_env'' + + -- NB: enter Hsc monad here so that we don't bail out early with + -- -Werror on typechecker warnings; we also want to run the desugarer + -- to get those warnings too. (But we'll always exit at that point + -- because the desugarer runs ioMsgMaybe.) + runHsc hsc_env $ do + e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage + mod_summary source_modified mb_old_iface mod_index + case e of + -- We didn't need to do any typechecking; the old interface + -- file on disk was good enough. + Left iface -> do + details <- liftIO $ initModDetails hsc_env mod_summary iface + return (HscUpToDate iface details, dflags) + -- We finished type checking. (mb_old_hash is the hash of + -- the interface that existed on disk; it's possible we had + -- to retypecheck but the resulting interface is exactly + -- the same.) + Right (FrontendTypecheck tc_result, mb_old_hash) -> do + status <- finish mod_summary tc_result mb_old_hash + return (status, dflags) + +-- Knot tying! See Note [Knot-tying typecheckIface] +-- See Note [ModDetails and --make mode] +initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails +initModDetails hsc_env mod_summary iface = + fixIO $ \details' -> do + let hsc_env' = hsc_env { + hsc_HPT = addToHpt (hsc_HPT hsc_env) + (ms_mod_name mod_summary) + (HomeModInfo iface details' Nothing) + } + -- NB: This result is actually not that useful + -- in one-shot mode, since we're not going to do + -- any further typechecking. It's much more useful + -- in make mode, since this HMI will go into the HPT. + genModDetails hsc_env' iface + + +{- +Note [ModDetails and --make mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +An interface file consists of two parts + +* The `ModIface` which ends up getting written to disk. + The `ModIface` is a completely acyclic tree, which can be serialised + and de-serialised completely straightforwardly. The `ModIface` is + also the structure that is finger-printed for recompilation control. + +* The `ModDetails` which provides a more structured view that is suitable + for usage during compilation. The `ModDetails` is heavily cyclic: + An `Id` contains a `Type`, which mentions a `TyCon` that contains kind + that mentions other `TyCons`; the `Id` also includes an unfolding that + in turn mentions more `Id`s; And so on. + +The `ModIface` can be created from the `ModDetails` and the `ModDetails` from +a `ModIface`. + +During tidying, just before interfaces are written to disk, +the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_). +Then when GHC needs to restart typechecking from a certain point it can read the +interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface). +The key part about the loading is that the ModDetails is regenerated lazily +from the ModIface, so that there's only a detailed in-memory representation +for declarations which are actually used from the interface. This mode is +also used when reading interface files from external packages. + +In the old --make mode implementation, the interface was written after compiling a module +but the in-memory ModDetails which was used to compute the ModIface was retained. +The result was that --make mode used much more memory than `-c` mode, because a large amount of +information about a module would be kept in the ModDetails but never used. + +The new idea is that even in `--make` mode, when there is an in-memory `ModDetails` +at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that +we only have to keep the `ModIface` decls in memory and then lazily load +detailed representations if needed. It turns out this makes a really big difference +to memory usage, halving maximum memory used in some cases. + +See !5492 and #13586 +-} + +-- Runs the post-typechecking frontend (desugar and simplify). We want to +-- generate most of the interface as late as possible. This gets us up-to-date +-- and good unfoldings and other info in the interface file. +-- +-- We might create a interface right away, in which case we also return the +-- updated HomeModInfo. But we might also need to run the backend first. In the +-- later case Status will be HscRecomp and we return a function from ModIface -> +-- HomeModInfo. +-- +-- HscRecomp in turn will carry the information required to compute a interface +-- when passed the result of the code generator. So all this can and is done at +-- the call site of the backend code gen if it is run. +finish :: ModSummary + -> TcGblEnv + -> Maybe Fingerprint + -> Hsc HscStatus +finish summary tc_result mb_old_hash = do + hsc_env <- getHscEnv + let dflags = hsc_dflags hsc_env + target = hscTarget dflags + hsc_src = ms_hsc_src summary + + -- Desugar, if appropriate + -- + -- We usually desugar even when we are not generating code, otherwise we + -- would miss errors thrown by the desugaring (see #10600). The only + -- exceptions are when the Module is Ghc.Prim or when it is not a + -- HsSrcFile Module. + mb_desugar <- + if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile + then Just <$> hscDesugar' (ms_location summary) tc_result + else pure Nothing + + -- Simplify, if appropriate, and (whether we simplified or not) generate an + -- interface file. + case mb_desugar of + -- Just cause we desugared doesn't mean we are generating code, see above. + Just desugared_guts | target /= HscNothing -> do + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + + (cg_guts, details) <- {-# SCC "CoreTidy" #-} + liftIO $ tidyProgram hsc_env simplified_guts + + let !partial_iface = + {-# SCC "GHC.Driver.Main.mkPartialIface" #-} + -- This `force` saves 2M residency in test T10370 + -- See Note [Avoiding space leaks in toIface*] for details. + force (mkPartialIface hsc_env details simplified_guts) + + return HscRecomp { hscs_guts = cg_guts, + hscs_mod_location = ms_location summary, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_hash, + hscs_iface_dflags = dflags } + + -- We are not generating code, so we can skip simplification + -- and generate a simple interface. + _ -> do + (iface, mb_old_iface_hash, details) <- liftIO $ + hscSimpleIface hsc_env tc_result mb_old_hash + + liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) + + return $ case (target, hsc_src) of + (HscNothing, _) -> HscNotGeneratingCode iface details + (_, HsBootFile) -> HscUpdateBoot iface details + (_, HsigFile) -> HscUpdateSig iface details + _ -> panic "finish" + +{- +Note [Writing interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We write interface files in GHC.Driver.Main and GHC.Driver.Pipeline using +hscMaybeWriteIface, but only once per compilation (twice with dynamic-too). + +* If a compilation does NOT require (re)compilation of the hard code we call + hscMaybeWriteIface inside GHC.Driver.Main:finish. +* If we run in One Shot mode and target bytecode we write it in compileOne' +* Otherwise we must be compiling to regular hard code and require recompilation. + In this case we create the interface file inside RunPhase using the interface + generator contained inside the HscRecomp status. +-} +hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () +hscMaybeWriteIface dflags iface old_iface location = do + let force_write_interface = gopt Opt_WriteInterface dflags + write_interface = case hscTarget dflags of + HscNothing -> False + HscInterpreted -> False + _ -> True + no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) + + when (write_interface || force_write_interface) $ + hscWriteIface dflags iface no_change location + +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + +-- NB: this must be knot-tied appropriately, see hscIncrementalCompile +genModDetails :: HscEnv -> ModIface -> IO ModDetails +genModDetails hsc_env old_iface + = do + new_details <- {-# SCC "tcRnIface" #-} + initIfaceLoad hsc_env (typecheckIface old_iface) + dumpIfaceStats hsc_env + return new_details + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: HscEnv -> RecompileRequired -> IO () +oneShotMsg hsc_env recomp = + case recomp of + UpToDate -> + compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required" + _ -> + return () + +batchMsg :: Messager +batchMsg hsc_env mod_index recomp mod_summary = + case recomp of + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" + | otherwise -> return () + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + where + dflags = hsc_dflags hsc_env + showMsg msg reason = + compilationProgressMsg dflags $ + (showModuleIndex mod_index ++ + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary) + ++ reason + +-------------------------------------------------------------- +-- Safe Haskell +-------------------------------------------------------------- + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + +-- Note [Safe Haskell Inference] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell does Safe inference on modules that don't have any specific +-- safe haskell mode flag. The basic approach to this is: +-- * When deciding if we need to do a Safe language check, treat +-- an unmarked module as having -XSafe mode specified. +-- * For checks, don't throw errors but return them to the caller. +-- * Caller checks if there are errors: +-- * For modules explicitly marked -XSafe, we throw the errors. +-- * For unmarked modules (inference mode), we drop the errors +-- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `-Wsafe`, `-Wunsafe` and +-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. + + +-- | Check that the safe imports of the module being compiled are valid. +-- If not we either issue a compilation error if the module is explicitly +-- using Safe Haskell, or mark the module as unsafe if we're in safe +-- inference mode. +hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv +hscCheckSafeImports tcg_env = do + dflags <- getDynFlags + tcg_env' <- checkSafeImports tcg_env + checkRULES dflags tcg_env' + + where + checkRULES dflags tcg_env' = do + case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logWarnings $ warns dflags (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + + warns dflags rules = listToBag $ map (warnRules dflags) rules + + warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg + warnRules dflags (L loc (HsRule { rd_name = n })) = + mkPlainWarnMsg dflags loc $ + text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ + text "User defined rules are disabled under Safe Haskell" + +-- | Validate that safe imported modules are actually safe. For modules in the +-- HomePackage (the package the module we are compiling in resides) this just +-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules +-- that reside in another package we also must check that the external package +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. +-- +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a +-- module are collected and unioned. Specifically see the Note [Tracking Trust +-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in +-- "GHC.Rename.Names". +checkSafeImports :: TcGblEnv -> Hsc TcGblEnv +checkSafeImports tcg_env + = do + dflags <- getDynFlags + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + + -- We want to use the warning state specifically for detecting if safe + -- inference has failed, so store and clear any existing warnings. + oldErrs <- getWarnings + clearWarnings + + -- Check safe imports are correct + safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safeErrs <- getWarnings + clearWarnings + + -- Check non-safe imports are correct if inferring safety + -- See the Note [Safe Haskell Inference] + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyBag, S.empty) + True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + infErrs <- getWarnings + clearWarnings + return (infErrs, infPkgs) + + -- restore old errors + logWarnings oldErrs + + case (isEmptyBag safeErrs) of + -- Failed safe check + False -> liftIO . throwIO . mkSrcErr $ safeErrs + + -- Passed safe check + True -> do + let infPassed = isEmptyBag infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust pkgReqs + let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } + + where + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods + imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) + imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) + pkgReqs = imp_trust_pkgs impInfo -- [Unit] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" + condense (m, x:xs) = do imv <- foldlM cond' x xs + return (m, imv_span imv, imv_is_safe imv) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1 v2 + | imv_is_safe v1 /= imv_is_safe v2 + = do + dflags <- getDynFlags + throwOneError $ mkPlainErrMsg dflags (imv_span v1) + (text "Module" <+> ppr (imv_name v1) <+> + (text $ "is imported both as a safe and unsafe import!")) + | otherwise + = return v1 + + -- easier interface to work with + checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId) + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + Bool -> ImportAvails + pkgTrustReqs dflags req inf infPassed | safeInferOn dflags + && not (safeHaskellModeEnabled dflags) && infPassed + = emptyImportAvails { + imp_trust_pkgs = req `S.union` inf + } + pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } + +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + pkgs <- snd `fmap` hscCheckSafe' m l + when (packageTrustOn dflags) $ checkPkgTrust pkgs + errs <- getWarnings + return $ isEmptyBag errs + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe hsc_env m l = runHsc hsc_env $ do + (self, pkgs) <- hscCheckSafe' m l + good <- isEmptyBag `fmap` getWarnings + clearWarnings -- don't want them printed... + let pkgs' | Just p <- self = S.insert p pkgs + | otherwise = pkgs + return (good, pkgs') + +-- | Is a module trusted? If not, throw or log errors depending on the type. +-- Return (regardless of trusted or not) if the trust type requires the modules +-- own package be trusted and a list of other packages required to be trusted +-- (these later ones haven't been checked) but the own package trust has been. +hscCheckSafe' :: Module -> SrcSpan + -> Hsc (Maybe UnitId, Set UnitId) +hscCheckSafe' m l = do + dflags <- getDynFlags + (tw, pkgs) <- isModSafe m l + case tw of + False -> return (Nothing, pkgs) + True | isHomeModule dflags m -> return (Nothing, pkgs) + -- TODO: do we also have to check the trust of the instantiation? + -- Not necessary if that is reflected in dependencies + | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) + where + isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe m l = do + dflags <- getDynFlags + iface <- lookup' m + case iface of + -- can't load iface to check trust! + Nothing -> throwOneError $ mkPlainErrMsg dflags l + $ text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" + + -- got iface, check trust + Just iface' -> + let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] + -- check package is trusted + safeP = packageTrusted dflags trust trust_own_pkg m + -- pkg trust reqs + pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' + -- warn if Safe module imports Safe-Inferred module. + warns = if wopt Opt_WarnInferredSafeImports dflags + && safeLanguageOn dflags + && trust == Sf_SafeInferred + then inferredImportWarn + else emptyBag + -- General errors we throw but Safe errors we log + errs = case (safeM, safeP) of + (True, True ) -> emptyBag + (True, False) -> pkgTrustErr + (False, _ ) -> modTrustErr + in do + logWarnings warns + logWarnings errs + return (trust == Sf_Trustworthy, pkgRs) + + where + state = unitState dflags + inferredImportWarn = unitBag + $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) + $ mkWarnMsg dflags l (pkgQual state) + $ sep + [ text "Importing Safe-Inferred module " + <> ppr (moduleName m) + <> text " from explicitly Safe module" + ] + pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" <> ppr (moduleUnit m) + <> text ") the module resides in isn't trusted." + ] + modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] + + -- | Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted _ Sf_None _ _ = False -- shouldn't hit these cases + packageTrusted _ Sf_Ignore _ _ = False -- shouldn't hit these cases + packageTrusted _ Sf_Unsafe _ _ = False -- prefer for completeness. + packageTrusted dflags _ _ _ + | not (packageTrustOn dflags) = True + packageTrusted _ Sf_Safe False _ = True + packageTrusted _ Sf_SafeInferred False _ = True + packageTrusted dflags _ _ m + | isHomeModule dflags m = True + | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule homePkgT pkgIfaceT m + -- the 'lookupIfaceByModule' method will always fail when calling from GHCi + -- as the compiler hasn't filled in the various module tables + -- so we need to call 'getModuleInterface' to load from disk + iface' <- case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + return iface' + + +-- | Check the list of packages are trusted. +checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust pkgs = do + dflags <- getDynFlags + let errors = S.foldr go [] pkgs + state = unitState dflags + go pkg acc + | unitIsTrusted $ unsafeLookupUnitId state pkg + = acc + | otherwise + = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state) + $ text "The package (" <> ppr pkg <> text ") is required" <> + text " to be trusted but it isn't!" + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + +-- | Set module to unsafe and (potentially) wipe trust information. +-- +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do + dflags <- getDynFlags + + when (wopt Opt_WarnUnsafe dflags) + (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ + mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + + liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) + -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case not (safeHaskellModeEnabled dflags) of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env + + where + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$ + (vcat $ badInsts $ tcg_insts tcg_env) + ] + badFlags df = concatMap (badFlag df) unsafeFlagsForInfer + badFlag df (str,loc,on,_) + | on df = [mkLocMessage SevOutput (loc df) $ + text str <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + badInsts insts = concatMap badInst insts + + checkOverlap (NoOverlap _) = False + checkOverlap _ = True + + badInst ins | checkOverlap (overlapMode (is_flag ins)) + = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ + ppr (overlapMode $ is_flag ins) <+> + text "overlap mode isn't allowed in Safe Haskell"] + | otherwise = [] + + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env + +-------------------------------------------------------------- +-- Simplifiers +-------------------------------------------------------------- + +hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts +hscSimplify hsc_env plugins modguts = + runHsc hsc_env $ hscSimplify' plugins modguts + +hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts +hscSimplify' plugins ds_result = do + hsc_env <- getHscEnv + let hsc_env_with_plugins = hsc_env + { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins + } + {-# SCC "Core2Core" #-} + liftIO $ core2core hsc_env_with_plugins ds_result + +-------------------------------------------------------------- +-- Interface generators +-------------------------------------------------------------- + +-- | Generate a striped down interface file, e.g. for boot files or when ghci +-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] +hscSimpleIface :: HscEnv + -> TcGblEnv + -> Maybe Fingerprint + -> IO (ModIface, Maybe Fingerprint, ModDetails) +hscSimpleIface hsc_env tc_result mb_old_iface + = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface + +hscSimpleIface' :: TcGblEnv + -> Maybe Fingerprint + -> Hsc (ModIface, Maybe Fingerprint, ModDetails) +hscSimpleIface' tc_result mb_old_iface = do + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result + new_iface + <- {-# SCC "MkFinalIface" #-} + liftIO $ + mkIfaceTc hsc_env safe_mode details tc_result + -- And the answer is ... + liftIO $ dumpIfaceStats hsc_env + return (new_iface, mb_old_iface, details) + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- +{- +Note [Interface filename extensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +ModLocation only contains the base names, however when generating dynamic files +the actual extension might differ from the default. + +So we only load the base name from ModLocation and replace the actual extension +according to the information in DynFlags. + +If we generate a interface file right after running the core pipeline we will +have set -dynamic-too and potentially generate both interface files at the same +time. + +If we generate a interface file after running the backend then dynamic-too won't +be set, however then the extension will be contained in the dynflags instead so +things still work out fine. +-} + +hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO () +hscWriteIface dflags iface no_change mod_location = do + -- mod_location only contains the base name, so we rebuild the + -- correct file extension from the dynflags. + let ifaceBaseFile = ml_hi_file mod_location + unless no_change $ + let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags) + in {-# SCC "writeIface" #-} + writeIface dflags ifaceFile iface + whenGeneratingDynamicToo dflags $ do + -- TODO: We should do a no_change check for the dynamic + -- interface file too + -- When we generate iface files after core + let dynDflags = dynamicTooMkDynamicDynFlags dflags + -- dynDflags will have set hiSuf correctly. + dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags) + + writeIface dynDflags dynIfaceFile iface + where + buildIfName :: String -> String -> String + buildIfName baseName suffix + | Just name <- outputHi dflags + = name + | otherwise + = let with_hi = replaceExtension baseName suffix + in addBootSuffix_maybe (mi_boot iface) with_hi + +-- | Compile to hard-code. +hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos) + -- ^ @Just f@ <=> _stub.c is f +hscGenHardCode hsc_env cgguts location output_filename = do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info } = cgguts + dflags = hsc_dflags hsc_env + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env this_mod location + core_binds data_tycons + ----------------- Convert to STG ------------------ + (stg_binds, (caf_ccs, caf_cc_stacks)) + <- {-# SCC "CoreToStg" #-} + myCoreToStg dflags this_mod prepd_binds + + let cost_centre_info = + (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + prof_init + | sccProfilingEnabled dflags = profilingInitCode this_mod cost_centre_info + | otherwise = empty + foreign_stubs = foreign_stubs0 `appendStubC` prof_init + + ------------------ Code generation ------------------ + + -- The back-end is streamed: each top-level function goes + -- from Stg all the way to asm before dealing with the next + -- top-level function, so showPass isn't very useful here. + -- Hence we have one showPass for the whole backend, the + -- next showPass after this will be "Assembler". + withTiming dflags + (text "CodeGen"<+>brackets (ppr this_mod)) + (const ()) $ do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod data_tycons + cost_centre_info + stg_binds hpc_info + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + lookupHook (\x -> cmmToRawCmmHook x) + (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms + + let dump a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a) + return a + rawcmms1 = Stream.mapM dump rawcmms0 + + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) + <- {-# SCC "codeOutput" #-} + codeOutput dflags this_mod output_filename location + foreign_stubs foreign_files dependencies rawcmms1 + return (output_filename, stub_c_exists, foreign_fps, cg_infos) + + +hscInteractive :: HscEnv + -> CgGuts + -> ModLocation + -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) +hscInteractive hsc_env cgguts location = do + let dflags = hsc_dflags hsc_env + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks, + cg_spt_entries = spt_entries } = cgguts + + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + (prepd_binds, _) <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env this_mod location core_binds data_tycons + ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks + ------------------ Create f-x-dynamic C-side stuff ----- + (_istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags this_mod location foreign_stubs + return (istub_c_exists, comp_bc, spt_entries) + +------------------------------ + +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () +hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + cmm <- ioMsgMaybe $ parseCmmFile dflags filename + liftIO $ do + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) + let -- Make up a module name to give the NCG. We can't pass bottom here + -- lest we reproduce #11784. + mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename + cmm_mod = mkHomeModule dflags mod_name + + -- Compile decls in Cmm files one decl at a time, to avoid re-ordering + -- them in SRT analysis. + -- + -- Re-ordering here causes breakage when booting with C backend because + -- in C we must declare before use, but SRT algorithm is free to + -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A] + cmmgroup <- + concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm + + unless (null cmmgroup) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" + FormatCMM (ppr cmmgroup) + rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) + (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) + _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] + rawCmms + return () + where + no_loc = ModLocation{ ml_hs_file = Just filename, + ml_hi_file = panic "hscCompileCmmFile: no hi file", + ml_obj_file = panic "hscCompileCmmFile: no obj file", + ml_hie_file = panic "hscCompileCmmFile: no hie file"} + +-------------------- Stuff for new code gen --------------------- + +{- +Note [Forcing of stg_binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The two last steps in the STG pipeline are: + +* Sorting the bindings in dependency order. +* Annotating them with free variables. + +We want to make sure we do not keep references to unannotated STG bindings +alive, nor references to bindings which have already been compiled to Cmm. + +We explicitly force the bindings to avoid this. + +This reduces residency towards the end of the CodeGen phase significantly +(5-10%). +-} + +doCodeGen :: HscEnv -> Module -> [TyCon] + -> CollectedCCs + -> [StgTopBinding] + -> HpcInfo + -> IO (Stream IO CmmGroupSRTs CgInfos) + -- Note we produce a 'Stream' of CmmGroups, so that the + -- backend can be run incrementally. Otherwise it generates all + -- the C-- up front, which has a significant space cost. +doCodeGen hsc_env this_mod data_tycons + cost_centre_info stg_binds hpc_info = do + let dflags = hsc_dflags hsc_env + + let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds + + dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) + + let cmm_stream :: Stream IO CmmGroup ModuleLFInfos + -- See Note [Forcing of stg_binds] + cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} + lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons + cost_centre_info stg_binds_w_fvs hpc_info + + -- codegen consumes a stream of CmmGroup, and produces a new + -- stream of CmmGroup (not necessarily synchronised: one + -- CmmGroup on input may produce many CmmGroups on output due + -- to proc-point splitting). + + let dump1 a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg + "Cmm produced by codegen" FormatCMM (ppr a) + return a + + ppr_stream1 = Stream.mapM dump1 cmm_stream + + pipeline_stream :: Stream IO CmmGroupSRTs CgInfos + pipeline_stream = do + (non_cafs, lf_infos) <- + {-# SCC "cmmPipeline" #-} + Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 + <&> first (srtMapNonCAFs . moduleSRTMap) + + return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos } + + dump2 a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a) + return a + + return (Stream.mapM dump2 pipeline_stream) + +myCoreToStg :: DynFlags -> Module -> CoreProgram + -> IO ( [StgTopBinding] -- output program + , CollectedCCs ) -- CAF cost centre info (declared and used) +myCoreToStg dflags this_mod prepd_binds = do + let (stg_binds, cost_centre_info) + = {-# SCC "Core2Stg" #-} + coreToStg dflags this_mod prepd_binds + + stg_binds2 + <- {-# SCC "Stg2Stg" #-} + stg2stg dflags this_mod stg_binds + + return (stg_binds2, cost_centre_info) + + +{- ********************************************************************** +%* * +\subsection{Compiling a do-statement} +%* * +%********************************************************************* -} + +{- +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types +-} + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmtWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt + case maybe_stmt of + Nothing -> return Nothing + + Just parsed_stmt -> do + hsc_env <- getHscEnv + liftIO $ hscParsedStmt hsc_env parsed_stmt + +hscParsedStmt :: HscEnv + -> GhciLStmt GhcPs -- ^ The parsed statement + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do + -- Rename and typecheck it + (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt + + -- Desugar it + ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr + liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) + handleWarnings + + -- Then code-gen, and link it + -- It's important NOT to have package 'interactive' as thisUnitId + -- for linking, else we try to link 'main' and can't find it. + -- Whereas the linker already knows to ignore 'interactive' + let src_span = srcLocSpan interactiveSrcLoc + hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + + return $ Just (ids, hval, fix_env) + +-- | Compile a decls +hscDecls :: HscEnv + -> String -- ^ The statement + -> IO ([TyThing], InteractiveContext) +hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "" 1 + +hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs] +hscParseDeclsWithLocation hsc_env source line_num str = do + L _ (HsModule{ hsmodDecls = decls }) <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source line_num parseModule str + return decls + +-- | Compile a decls +hscDeclsWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ([TyThing], InteractiveContext) +hscDeclsWithLocation hsc_env str source linenumber = do + L _ (HsModule{ hsmodDecls = decls }) <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source linenumber parseModule str + hscParsedDecls hsc_env decls + +hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) +hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do + {- Rename and typecheck it -} + hsc_env <- getHscEnv + tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls + + {- Grab the new instances -} + -- We grab the whole environment because of the overlapping that may have + -- been done. See the notes at the definition of InteractiveContext + -- (ic_instances) for more details. + let defaults = tcg_default tc_gblenv + + {- Desugar it -} + -- We use a basically null location for iNTERACTIVE + let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", + ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file", + ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" } + ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv + + {- Simplify -} + simpl_mg <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tc_gblenv) + hscSimplify hsc_env plugins ds_result + + {- Tidy -} + (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg + + let !CgGuts{ cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_modBreaks = mod_breaks } = tidy_cg + + !ModDetails { md_insts = cls_insts + , md_fam_insts = fam_insts } = mod_details + -- Get the *tidied* cls_insts and fam_insts + + data_tycons = filter isDataTyCon tycons + + {- Prepare For Code Generation -} + -- Do saturation and convert to A-normal form + (prepd_binds, _) <- {-# SCC "CorePrep" #-} + liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons + + {- Generate byte code -} + cbc <- liftIO $ byteCodeGen hsc_env this_mod + prepd_binds data_tycons mod_breaks + + let src_span = srcLocSpan interactiveSrcLoc + liftIO $ linkDecls hsc_env src_span cbc + + {- Load static pointer table entries -} + liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) + patsyns = mg_patsyns simpl_mg + + ext_ids = [ id | id <- bindersOfBinds core_binds + , isExternalName (idName id) + , not (isDFunId id || isImplicitId id) ] + -- We only need to keep around the external bindings + -- (as decided by GHC.Iface.Tidy), since those are the only ones + -- that might later be looked up by name. But we can exclude + -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Driver.Types + -- - Implicit Ids, which are implicit in tcs + -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv + + new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns + ictxt = hsc_IC hsc_env + -- See Note [Fixity declarations in GHCi] + fix_env = tcg_fix_env tc_gblenv + new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts + fam_insts defaults fix_env + return (new_tythings, new_ictxt) + +-- | Load the given static-pointer table entries into the interpreter. +-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () +hscAddSptEntries hsc_env entries = do + let add_spt_entry :: SptEntry -> IO () + add_spt_entry (SptEntry i fpr) = do + val <- getHValue hsc_env (idName i) + addSptEntry hsc_env fpr val + mapM_ add_spt_entry entries + +{- + Note [Fixity declarations in GHCi] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + To support fixity declarations on types defined within GHCi (as requested + in #10018) we record the fixity environment in InteractiveContext. + When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this + fixity environment and uses it to initialize the global typechecker environment. + After the typechecker has finished its business, an updated fixity environment + (reflecting whatever fixity declarations were present in the statements we + passed it) will be returned from hscParsedStmt. This is passed to + updateFixityEnv, which will stuff it back into InteractiveContext, to be + used in evaluating the next statement. + +-} + +hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) +hscImport hsc_env str = runInteractiveHsc hsc_env $ do + (L _ (HsModule{hsmodImports=is})) <- + hscParseThing parseModule str + case is of + [L _ i] -> return i + _ -> liftIO $ throwOneError $ + mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ + text "parse error in import declaration" + +-- | Typecheck an expression (but don't run it) +hscTcExpr :: HscEnv + -> TcRnExprMode + -> String -- ^ The expression + -> IO Type +hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + parsed_expr <- hscParseExpr expr + ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr + +-- | Find the kind of a type, after generalisation +hscKcType + :: HscEnv + -> Bool -- ^ Normalise the type + -> String -- ^ The type as a string + -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty + +hscParseExpr :: String -> Hsc (LHsExpr GhcPs) +hscParseExpr expr = do + hsc_env <- getHscEnv + maybe_stmt <- hscParseStmt expr + case maybe_stmt of + Just (L _ (BodyStmt _ expr _ _)) -> return expr + _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan + (text "not an expression:" <+> quotes (text expr)) + +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmt = hscParseThing parseStmt + +hscParseStmtWithLocation :: String -> Int -> String + -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + +hscParseType :: String -> Hsc (LHsType GhcPs) +hscParseType = hscParseThing parseType + +hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier hsc_env str = + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str + +hscParseThing :: (Outputable thing, Data thing) + => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "" 1 + +hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int + -> Lexer.P thing -> String -> Hsc thing +hscParseThingWithLocation source linenumber parser str + = withTimingD + (text "Parser [source]") + (const ()) $ {-# SCC "Parser" #-} do + dflags <- getDynFlags + + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 + + case unP parser (mkPState dflags buf loc) of + PFailed pst -> do + handleWarningsThrowErrors (getMessages pst dflags) + + POk pst thing -> do + logWarningsReportErrors (getMessages pst dflags) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan thing) + return thing + + +{- ********************************************************************** +%* * + Desugar, simplify, convert to bytecode, and link an expression +%* * +%********************************************************************* -} + +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr hsc_env = + lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env + +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr' hsc_env srcspan ds_expr + = do { {- Simplify it -} + simpl_expr <- simplifyExpr hsc_env ds_expr + + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr hsc_env tidy_expr + + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs hsc_env + (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos + + ; return hval } + + +{- ********************************************************************** +%* * + Statistics on reading interfaces +%* * +%********************************************************************* -} + +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env = do + eps <- readIORef (hsc_EPS hsc_env) + dumpIfSet dflags (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) + where + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags + + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> String +showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] " + where + n_str = show n + i_str = show i + padded = replicate (length n_str - length i_str) ' ' ++ i_str diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Make.hs @@ -0,0 +1,2780 @@ +{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- +module GHC.Driver.Make ( + depanal, depanalE, depanalPartial, + load, load', LoadHowMuch(..), + + downsweep, + + topSortModuleGraph, + + ms_home_srcimps, ms_home_imps, + + summariseModule, + hscSourceToIsBoot, + findExtraSigImports, + implicitRequirements, + + noModError, cyclicModuleErr, + moduleGraphNodes, SummaryNode, + IsBootInterface(..) + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import qualified GHC.Runtime.Linker as Linker + +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Driver.Finder +import GHC.Driver.Monad +import GHC.Parser.Header +import GHC.Driver.Types +import GHC.Unit.Module +import GHC.IfaceToCore ( typecheckIface ) +import GHC.Tc.Utils.Monad ( initIfaceCheck ) +import GHC.Driver.Main + +import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) +import GHC.Types.Basic +import GHC.Data.Graph.Directed +import GHC.Utils.Exception ( tryIO ) +import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) +import GHC.Types.Name +import GHC.Utils.Monad ( allM ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.SrcLoc +import GHC.Data.StringBuffer +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet +import GHC.Tc.Utils.Backpack +import GHC.Unit.State +import GHC.Types.Unique.Set +import GHC.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.Name.Env +import GHC.SysTools.FileCleanup + + +import Data.Either ( rights, partitionEithers ) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import qualified GHC.Data.FiniteMap as Map ( insertListWith ) + +import Control.Concurrent ( forkIOWithUnmask, killThread ) +import qualified GHC.Conc as CC +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) +import qualified Control.Monad.Catch as MC +import Data.IORef +import Data.List +import qualified Data.List as List +import Data.Foldable (toList) +import Data.Maybe +import Data.Ord ( comparing ) +import Data.Time +import System.Directory +import System.FilePath +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) + +import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) + +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- In case of errors, just throw them. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots + if isEmptyBag errs + then pure mod_graph + else throwErrors errs + +-- | Perform dependency analysis like in 'depanal'. +-- In case of errors, the errors and an empty module graph are returned. +depanalE :: GhcMonad m => -- New for #17459 + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) +depanalE excluded_mods allow_dup_roots = do + hsc_env <- getSession + (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots + if isEmptyBag errs + then do + let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph + unused_pkg_err = warnUnusedPackages hsc_env mod_graph + warns = unused_home_mod_err ++ unused_pkg_err + when (not $ null warns) $ + logWarnings (listToBag warns) + setSession hsc_env { hsc_mod_graph = mod_graph } + pure (errs, mod_graph) + else do + -- We don't have a complete module dependency graph, + -- The graph may be disconnected and is unusable. + setSession hsc_env { hsc_mod_graph = emptyMG } + pure (errs, emptyMG) + + +-- | Perform dependency analysis like 'depanal' but return a partial module +-- graph even in the face of problems with some modules. +-- +-- Modules which have parse errors in the module header, failing +-- preprocessors or other issues preventing them from being summarised will +-- simply be absent from the returned module graph. +-- +-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the +-- new module graph. +depanalPartial + :: GhcMonad m + => [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) + -- ^ possibly empty 'Bag' of errors and a module graph. +depanalPartial excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + withTiming dflags (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + -- Home package modules may have been moved or deleted, and new + -- source files may have appeared in the home package that shadow + -- external package modules, so we have to discard the existing + -- cached finder data. + liftIO $ flushFinderCaches hsc_env + + mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph) + excluded_mods allow_dup_roots + let + (errs, mod_summaries) = partitionEithers mod_summariesE + mod_graph = mkModuleGraph mod_summaries + return (unionManyBags errs, mod_graph) + +-- Note [Missing home modules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed +-- in a command line. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns user about modules, not listed +-- neither in `exposed-modules`, nor in `other-modules`. +-- +-- Here "home module" means a module, that doesn't come from an other package. +-- +-- For example, if GHC is invoked with modules "A" and "B" as targets, +-- but "A" imports some other module "C", then GHC will issue a warning +-- about module "C" not being listed in a command line. +-- +-- The warning in enabled by `-Wmissing-home-modules`. See #13129 +warnMissingHomeModules :: HscEnv -> ModuleGraph -> [ErrMsg] +warnMissingHomeModules hsc_env mod_graph = + if (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) + then [warn] + else [] + where + dflags = hsc_dflags hsc_env + targets = map targetId (hsc_targets hsc_env) + + is_known_module mod = any (is_my_target mod) targets + + -- We need to be careful to handle the case where (possibly + -- path-qualified) filenames (aka 'TargetFile') rather than module + -- names are being passed on the GHC command-line. + -- + -- For instance, `ghc --make src-exe/Main.hs` and + -- `ghc --make -isrc-exe Main` are supposed to be equivalent. + -- Note also that we can't always infer the associated module name + -- directly from the filename argument. See #13727. + is_my_target mod (TargetModule name) + = moduleName (ms_mod mod) == name + is_my_target mod (TargetFile target_file _) + | Just mod_file <- ml_hs_file (ms_location mod) + = target_file == mod_file || + + -- Don't warn on B.hs-boot if B.hs is specified (#16551) + addBootSuffix target_file == mod_file || + + -- We can get a file target even if a module name was + -- originally specified in a command line because it can + -- be converted in guessTarget (by appending .hs/.lhs). + -- So let's convert it back and compare with module name + mkModuleName (fst $ splitExtension target_file) + == moduleName (ms_mod mod) + is_my_target _ _ = False + + missing = map (moduleName . ms_mod) $ + filter (not . is_known_module) (mgModSummaries mod_graph) + + msg + | gopt Opt_BuildingCabalPackage dflags + = hang + (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ") + 4 + (sep (map ppr missing)) + | otherwise + = + hang + (text "Modules are not listed in command line but needed for compilation: ") + 4 + (sep (map ppr missing)) + warn = makeIntoWarning + (Reason Opt_WarnMissingHomeModules) + (mkPlainErrMsg dflags noSrcSpan msg) + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'GHC.Driver.Session.hscTarget') compiling +-- and loading may result in files being created on disk. +-- +-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether +-- successful or not. +-- +-- If errors are encountered during dependency analysis, the module `depanalE` +-- returns together with the errors an empty ModuleGraph. +-- After processing this empty ModuleGraph, the errors of depanalE are thrown. +-- All other errors are reported using the 'defaultWarnErrLogger'. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + (errs, mod_graph) <- depanalE [] False -- #17459 + success <- load' how_much (Just batchMsg) mod_graph + if isEmptyBag errs + then pure success + else throwErrors errs + +-- Note [Unused packages] +-- +-- Cabal passes `--package-id` flag for each direct dependency. But GHC +-- loads them lazily, so when compilation is done, we have a list of all +-- actually loaded packages. All the packages, specified on command line, +-- but never loaded, are probably unused dependencies. + +warnUnusedPackages :: HscEnv -> ModuleGraph -> [ErrMsg] +warnUnusedPackages hsc_env mod_graph = + let dflags = hsc_dflags hsc_env + state = unitState dflags + + -- Only need non-source imports here because SOURCE imports are always HPT + loadedPackages = concat $ + mapMaybe (\(fs, mn) -> lookupModulePackage state (unLoc mn) fs) + $ concatMap ms_imps (mgModSummaries mod_graph) + + requestedArgs = mapMaybe packageArg (packageFlags dflags) + + unusedArgs + = filter (\arg -> not $ any (matching state arg) loadedPackages) + requestedArgs + + warn = makeIntoWarning + (Reason Opt_WarnUnusedPackages) + (mkPlainErrMsg dflags noSrcSpan msg) + msg = vcat [ text "The following packages were specified" <+> + text "via -package or -package-id flags," + , text "but were not needed for compilation:" + , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] + + in if not (null unusedArgs) && wopt Opt_WarnUnusedPackages dflags + then [warn] + else [] + + where + packageArg (ExposePackage _ arg _) = Just arg + packageArg _ = Nothing + + pprUnusedArg (PackageArg str) = text str + pprUnusedArg (UnitIdArg uid) = ppr uid + + withDash = (<+>) (text "-") + + matchingStr :: String -> UnitInfo -> Bool + matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + + matching :: UnitState -> PackageArg -> UnitInfo -> Bool + matching _ (PackageArg str) p = matchingStr str p + matching state (UnitIdArg uid) p = uid == realUnit state p + + -- For wired-in packages, we have to unwire their id, + -- otherwise they won't match package flags + realUnit :: UnitState -> UnitInfo -> Unit + realUnit state + = unwireUnit state + . RealUnit + . Definite + . unitId + +-- | Generalized version of 'load' which also supports a custom +-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally +-- produced by calling 'depanal'. +load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' how_much mHscMessage mod_graph = do + modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = + mkUniqSet [ ms_mod_name s + | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot] + -- TODO: Figure out what the correct form of this assert is. It's violated + -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot + -- files without corresponding hs files. + -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + -- not (ms_mod_name s `elem` all_home_mods)] + -- ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elementOfUniqSet` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- nonDetEltsUniqSet stable_obj ++ + nonDetEltsUniqSet stable_bco, + -- It's OK to use nonDetEltsUniqSet here + -- because it only affects linking. Besides + -- this list only serves as a poor man's set. + Just hmi <- [lookupHpt pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + stable_mod_summary ms ] + + stable_mod_summary ms = + ms_mod_name ms `elementOfUniqSet` stable_obj || + ms_mod_name ms `elementOfUniqSet` stable_bco + + -- the modules from partial_mg that are not also stable + -- NB. also keep cycles, we need to emit an error message later + unstable_mg = filter not_stable partial_mg + where not_stable (CyclicSCC _) = True + not_stable (AcyclicSCC ms) + = not $ stable_mod_summary ms + + -- Load all the stable modules first, before attempting to load + -- an unstable module (#7231). + mg = stable_mg ++ unstable_mg + + -- clean up between compilations + let cleanup = cleanCurrentModuleTempFiles . hsc_dflags + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + n_jobs <- case parMakeCount dflags of + Nothing -> liftIO getNumProcessors + Just n -> return n + let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs + | otherwise = upsweep + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ + upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ cleanCurrentModuleTempFiles dflags + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = gopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = mgElemModule mod_graph main_mod + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + if ghcLink dflags == LinkBinary && isJust ofile && not do_linking + then do + liftIO $ errorMsg dflags $ text + ("output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + -- This should be an error, not a warning (#10895). + loadFinish Failed linkresult + else + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let (mods_to_clean, mods_to_keep) = + partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone + hsc_env1 <- getSession + let hpt4 = hsc_HPT hsc_env1 + -- We must change the lifetime to TFL_CurrentModule for any temp + -- file created for an element of mod_to_clean during the upsweep. + -- These include preprocessed files and object files for loaded + -- modules. + unneeded_temps = concat + [ms_hspp_file : object_files + | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean + , let object_files = maybe [] linkableObjs $ + lookupHpt hpt4 (moduleName ms_mod) + >>= hm_linkable + ] + liftIO $ + changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps + liftIO $ cleanCurrentModuleTempFiles dflags + + let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + hpt4 + + -- Clean up after ourselves + + -- there should be no Nothings where linkables should be, now + let just_linkables = + isNoLink (ghcLink dflags) + || allHpt (isJust.hm_linkable) + (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface) + hpt5) + ASSERT( just_linkables ) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } + loadFinish Failed linkresult + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag + +-- If the link failed, unload everything and return. +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded + = do modifySession discardIC + return all_ok + + +-- | Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- | Discard the contents of the InteractiveContext, but keep the DynFlags. +-- It will also keep ic_int_print and ic_monad if their names are from +-- external packages. +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print + , ic_monad = new_ic_monad } } + where + -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic + !new_ic_int_print = keep_external_name ic_int_print + !new_ic_monad = keep_external_name ic_monad + dflags = ic_dflags old_ic + old_ic = hsc_IC hsc_env + empty_ic = emptyInteractiveContext dflags + keep_external_name ic_name + | nameIsFromExternalPackage this_pkg old_name = old_name + | otherwise = ic_name empty_ic + where + this_pkg = homeUnit dflags + old_name = ic_name old_ic + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + -- Force mod_graph to avoid leaking env + !mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + ms <- mgLookupModule mod_graph (mainModIs dflags) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + + name_exe = do +#if defined(mingw32_HOST_OS) + -- we must add the .exe extension unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 + name' <- fmap (<.> "exe") name +#else + name' <- name +#endif + mainModuleSrcPath' <- mainModuleSrcPath + -- #9930: don't clobber input files (unless they ask for it) + if name' == mainModuleSrcPath' + then throwGhcException . UsageError $ + "default output name would overwrite the input file; " ++ + "must specify -o explicitly" + else Just name' + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- +-- +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. +pruneHomePackageTable :: HomePackageTable + -> [ModSummary] + -> StableModules + -> HomePackageTable +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapHpt prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + + is_stable m = + m `elementOfUniqSet` stable_obj || + m `elementOfUniqSet` stable_bco + +-- ----------------------------------------------------------------------------- +-- +-- | Return (names of) all those in modsDone who are part of a cycle as defined +-- by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module +findPartiallyCompletedCycles modsDone theGraph + = Set.unions + [mods_in_this_cycle + | CyclicSCC vs <- theGraph -- Acyclic? Not interesting. + , let names_in_this_cycle = Set.fromList (map ms_mod vs) + mods_in_this_cycle = + Set.intersection (Set.fromList modsDone) names_in_this_cycle + -- If size mods_in_this_cycle == size names_in_this_cycle, + -- then this cycle has already been completed and we're not + -- interested. + , Set.size mods_in_this_cycle < Set.size names_in_this_cycle] + + +-- --------------------------------------------------------------------------- +-- +-- | Unloading +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of + LinkInMemory -> Linker.unload hsc_env stable_linkables + _other -> return () + +-- ----------------------------------------------------------------------------- +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. + + - Note that even if an object is stable, we may end up recompiling + if the interface is out of date because an *external* interface + has changed. The current code in GHC.Driver.Make handles this case + fairly poorly, so be careful. +-} + +type StableModules = + ( UniqSet ModuleName -- stableObject + , UniqSet ModuleName -- stableBCO + ) + + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> UniqSet ModuleName -- all home modules + -> StableModules + +checkStability hpt sccs all_home_mods = + foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs + where + checkSCC :: StableModules -> SCC ModSummary -> StableModules + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco) + | stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = + m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps + stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearest second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + -- + -- But see #5527, where someone ran into this and it caused + -- a problem. + + bco_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | otherwise = case lookupHpt hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +{- Parallel Upsweep + - + - The parallel upsweep attempts to concurrently compile the modules in the + - compilation graph using multiple Haskell threads. + - + - The Algorithm + - + - A Haskell thread is spawned for each module in the module graph, waiting for + - its direct dependencies to finish building before it itself begins to build. + - + - Each module is associated with an initially empty MVar that stores the + - result of that particular module's compile. If the compile succeeded, then + - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that + - module, and the module's HMI is deleted from the old HPT (synchronized by an + - IORef) to save space. + - + - Instead of immediately outputting messages to the standard handles, all + - compilation output is deferred to a per-module TQueue. A QSem is used to + - limit the number of workers that are compiling simultaneously. + - + - Meanwhile, the main thread sequentially loops over all the modules in the + - module graph, outputting the messages stored in each module's TQueue. +-} + +-- | Each module is given a unique 'LogQueue' to redirect compilation messages +-- to. A 'Nothing' value contains the result of compilation, and denotes the +-- end of the message queue. +data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)]) + !(MVar ()) + +-- | The graph of modules to compile and their corresponding result 'MVar' and +-- 'LogQueue'. +type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)] + +-- | Build a 'CompilationGraph' out of a list of strongly-connected modules, +-- also returning the first, if any, encountered module cycle. +buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary]) +buildCompGraph [] = return ([], Nothing) +buildCompGraph (scc:sccs) = case scc of + AcyclicSCC ms -> do + mvar <- newEmptyMVar + log_queue <- do + ref <- newIORef [] + sem <- newEmptyMVar + return (LogQueue ref sem) + (rest,cycle) <- buildCompGraph sccs + return ((ms,mvar,log_queue):rest, cycle) + CyclicSCC mss -> return ([], Just mss) + +-- | A Module and whether it is a boot module. +-- +-- We need to treat boot modules specially when building compilation graphs, +-- since they break cycles. Regular source files and signature files are treated +-- equivalently. +type BuildModule = ModuleWithIsBoot + +-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements +-- of 'BuildModule'. We conflate signatures and modules because they are bound +-- in the same namespace; only boot interfaces can be disambiguated with +-- `import {-# SOURCE #-}`. +hscSourceToIsBoot :: HscSource -> IsBootInterface +hscSourceToIsBoot HsBootFile = IsBoot +hscSourceToIsBoot _ = NotBoot + +mkBuildModule :: ModSummary -> BuildModule +mkBuildModule ms = GWIB + { gwib_mod = ms_mod ms + , gwib_isBoot = isBootSummary ms + } + +mkHomeBuildModule :: ModSummary -> ModuleNameWithIsBoot +mkHomeBuildModule ms = GWIB + { gwib_mod = moduleName $ ms_mod ms + , gwib_isBoot = isBootSummary ms + } + +-- | The entry point to the parallel upsweep. +-- +-- See also the simpler, sequential 'upsweep'. +parUpsweep + :: GhcMonad m + => Int + -- ^ The number of workers we wish to run in parallel + -> Maybe Messager + -> HomePackageTable + -> StableModules + -> (HscEnv -> IO ()) + -> [SCC ModSummary] + -> m (SuccessFlag, + [ModSummary]) +parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + when (not (null (instantiatedUnitsToCheck dflags))) $ + throwGhcException (ProgramError "Backpack typechecking not supported with -j") + + -- The bits of shared state we'll be using: + + -- The global HscEnv is updated with the module's HMI when a module + -- successfully compiles. + hsc_env_var <- liftIO $ newMVar hsc_env + + -- The old HPT is used for recompilation checking in upsweep_mod. When a + -- module successfully gets compiled, its HMI is pruned from the old HPT. + old_hpt_var <- liftIO $ newIORef old_hpt + + -- What we use to limit parallelism with. + par_sem <- liftIO $ newQSem n_jobs + + + let updNumCapabilities = liftIO $ do + n_capabilities <- getNumCapabilities + n_cpus <- getNumProcessors + -- Setting number of capabilities more than + -- CPU count usually leads to high userspace + -- lock contention. #9221 + let n_caps = min n_jobs n_cpus + unless (n_capabilities /= 1) $ setNumCapabilities n_caps + return n_capabilities + -- Reset the number of capabilities once the upsweep ends. + let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n + + MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do + + -- Sync the global session with the latest HscEnv once the upsweep ends. + let finallySyncSession io = io `MC.finally` do + hsc_env <- liftIO $ readMVar hsc_env_var + setSession hsc_env + + finallySyncSession $ do + + -- Build the compilation graph out of the list of SCCs. Module cycles are + -- handled at the very end, after some useful work gets done. Note that + -- this list is topologically sorted (by virtue of 'sccs' being sorted so). + (comp_graph,cycle) <- liftIO $ buildCompGraph sccs + let comp_graph_w_idx = zip comp_graph [1..] + + -- The list of all loops in the compilation graph. + -- NB: For convenience, the last module of each loop (aka the module that + -- finishes the loop) is prepended to the beginning of the loop. + let graph = map fstOf3 (reverse comp_graph) + boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms == IsBoot] + comp_graph_loops = go graph boot_modules + where + remove ms bm = case isBootSummary ms of + IsBoot -> delModuleSet bm (ms_mod ms) + NotBoot -> bm + go [] _ = [] + go mg@(ms:mss) boot_modules + | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules) + = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules) + | otherwise + = go mss (remove ms boot_modules) + + -- Build a Map out of the compilation graph with which we can efficiently + -- look up the result MVar associated with a particular home module. + let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int) + home_mod_map = + Map.fromList [ (mkBuildModule ms, (mvar, idx)) + | ((ms,mvar,_),idx) <- comp_graph_w_idx ] + + + liftIO $ label_self "main --make thread" + -- For each module in the module graph, spawn a worker thread that will + -- compile this module. + let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> + forkIOWithUnmask $ \unmask -> do + liftIO $ label_self $ unwords + [ "worker --make thread" + , "for module" + , show (moduleNameString (ms_mod_name mod)) + , "number" + , show mod_idx + ] + -- Replace the default log_action with one that writes each + -- message to the module's log_queue. The main thread will + -- deal with synchronously printing these messages. + -- + -- Use a local filesToClean var so that we can clean up + -- intermediate files in a timely fashion (as soon as + -- compilation for that module is finished) without having to + -- worry about accidentally deleting a simultaneous compile's + -- important files. + lcl_files_to_clean <- newIORef emptyFilesToClean + let lcl_dflags = dflags { log_action = parLogAction log_queue + , filesToClean = lcl_files_to_clean } + + -- Unmask asynchronous exceptions and perform the thread-local + -- work to compile the module (see parUpsweep_one). + m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $ + parUpsweep_one mod home_mod_map comp_graph_loops + lcl_dflags mHscMessage cleanup + par_sem hsc_env_var old_hpt_var + stable_mods mod_idx (length sccs) + + res <- case m_res of + Right flag -> return flag + Left exc -> do + -- Don't print ThreadKilled exceptions: they are used + -- to kill the worker thread in the event of a user + -- interrupt, and the user doesn't have to be informed + -- about that. + when (fromException exc /= Just ThreadKilled) + (errorMsg lcl_dflags (text (show exc))) + return Failed + + -- Populate the result MVar. + putMVar mvar res + + -- Write the end marker to the message queue, telling the main + -- thread that it can stop waiting for messages from this + -- particular compile. + writeLogQueue log_queue Nothing + + -- Add the remaining files that weren't cleaned up to the + -- global filesToClean ref, for cleanup later. + FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } <- readIORef (filesToClean lcl_dflags) + addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files + addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files + + -- Kill all the workers, masking interrupts (since killThread is + -- interruptible). XXX: This is not ideal. + ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread } + + + -- Spawn the workers, making sure to kill them later. Collect the results + -- of each compile. + results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ -> + -- Loop over each module in the compilation graph in order, printing + -- each message from its log_queue. + forM comp_graph $ \(mod,mvar,log_queue) -> do + printLogs dflags log_queue + result <- readMVar mvar + if succeeded result then return (Just mod) else return Nothing + + + -- Collect and return the ModSummaries of all the successful compiles. + -- NB: Reverse this list to maintain output parity with the sequential upsweep. + let ok_results = reverse (catMaybes results) + + -- Handle any cycle in the original compilation graph and return the result + -- of the upsweep. + case cycle of + Just mss -> do + liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) + return (Failed,ok_results) + Nothing -> do + let success_flag = successIf (all isJust results) + return (success_flag,ok_results) + + where + writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO () + writeLogQueue (LogQueue ref sem) msg = do + atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) + _ <- tryPutMVar sem () + return () + + -- The log_action callback that is used to synchronize messages from a + -- worker thread. + parLogAction :: LogQueue -> LogAction + parLogAction log_queue _dflags !reason !severity !srcSpan !msg = do + writeLogQueue log_queue (Just (reason,severity,srcSpan,msg)) + + -- Print each message from the log_queue using the log_action from the + -- session's DynFlags. + printLogs :: DynFlags -> LogQueue -> IO () + printLogs !dflags (LogQueue ref sem) = read_msgs + where read_msgs = do + takeMVar sem + msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) + print_loop msgs + + print_loop [] = read_msgs + print_loop (x:xs) = case x of + Just (reason,severity,srcSpan,msg) -> do + putLogMsg dflags reason severity srcSpan msg + print_loop xs + -- Exit the loop once we encounter the end marker. + Nothing -> return () + +-- The interruptible subset of the worker threads' work. +parUpsweep_one + :: ModSummary + -- ^ The module we wish to compile + -> Map BuildModule (MVar SuccessFlag, Int) + -- ^ The map of home modules and their result MVar + -> [[BuildModule]] + -- ^ The list of all module loops within the compilation graph. + -> DynFlags + -- ^ The thread-local DynFlags + -> Maybe Messager + -- ^ The messager + -> (HscEnv -> IO ()) + -- ^ The callback for cleaning up intermediate files + -> QSem + -- ^ The semaphore for limiting the number of simultaneous compiles + -> MVar HscEnv + -- ^ The MVar that synchronizes updates to the global HscEnv + -> IORef HomePackageTable + -- ^ The old HPT + -> StableModules + -- ^ Sets of stable objects and BCOs + -> Int + -- ^ The index of this module + -> Int + -- ^ The total number of modules + -> IO SuccessFlag + -- ^ The result of this compile +parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem + hsc_env_var old_hpt_var stable_mods mod_index num_mods = do + + let this_build_mod = mkBuildModule mod + + let home_imps = map unLoc $ ms_home_imps mod + let home_src_imps = map unLoc $ ms_home_srcimps mod + + -- All the textual imports of this module. + let textual_deps = Set.fromList $ + zipWith f home_imps (repeat NotBoot) ++ + zipWith f home_src_imps (repeat IsBoot) + where f mn isBoot = GWIB + { gwib_mod = mkHomeModule lcl_dflags mn + , gwib_isBoot = isBoot + } + + -- Dealing with module loops + -- ~~~~~~~~~~~~~~~~~~~~~~~~~ + -- + -- Not only do we have to deal with explicit textual dependencies, we also + -- have to deal with implicit dependencies introduced by import cycles that + -- are broken by an hs-boot file. We have to ensure that: + -- + -- 1. A module that breaks a loop must depend on all the modules in the + -- loop (transitively or otherwise). This is normally always fulfilled + -- by the module's textual dependencies except in degenerate loops, + -- e.g.: + -- + -- A.hs imports B.hs-boot + -- B.hs doesn't import A.hs + -- C.hs imports A.hs, B.hs + -- + -- In this scenario, getModLoop will detect the module loop [A,B] but + -- the loop finisher B doesn't depend on A. So we have to explicitly add + -- A in as a dependency of B when we are compiling B. + -- + -- 2. A module that depends on a module in an external loop can't proceed + -- until the entire loop is re-typechecked. + -- + -- These two invariants have to be maintained to correctly build a + -- compilation graph with one or more loops. + + + -- The loop that this module will finish. After this module successfully + -- compiles, this loop is going to get re-typechecked. + let finish_loop = listToMaybe + [ tail loop | loop <- comp_graph_loops + , head loop == this_build_mod ] + + -- If this module finishes a loop then it must depend on all the other + -- modules in that loop because the entire module loop is going to be + -- re-typechecked once this module gets compiled. These extra dependencies + -- are this module's "internal" loop dependencies, because this module is + -- inside the loop in question. + let int_loop_deps = Set.fromList $ + case finish_loop of + Nothing -> [] + Just loop -> filter (/= this_build_mod) loop + + -- If this module depends on a module within a loop then it must wait for + -- that loop to get re-typechecked, i.e. it must wait on the module that + -- finishes that loop. These extra dependencies are this module's + -- "external" loop dependencies, because this module is outside of the + -- loop(s) in question. + let ext_loop_deps = Set.fromList + [ head loop | loop <- comp_graph_loops + , any (`Set.member` textual_deps) loop + , this_build_mod `notElem` loop ] + + + let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps] + + -- All of the module's home-module dependencies. + let home_deps_with_idx = + [ home_dep | dep <- Set.toList all_deps + , Just home_dep <- [Map.lookup dep home_mod_map] ] + + -- Sort the list of dependencies in reverse-topological order. This way, by + -- the time we get woken up by the result of an earlier dependency, + -- subsequent dependencies are more likely to have finished. This step + -- effectively reduces the number of MVars that each thread blocks on. + let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx + + -- Wait for the all the module's dependencies to finish building. + deps_ok <- allM (fmap succeeded . readMVar) home_deps + + -- We can't build this module if any of its dependencies failed to build. + if not deps_ok + then return Failed + else do + -- Any hsc_env at this point is OK to use since we only really require + -- that the HPT contains the HMIs of our dependencies. + hsc_env <- readMVar hsc_env_var + old_hpt <- readIORef old_hpt_var + + let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) + + -- Limit the number of parallel compiles. + let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem) + mb_mod_info <- withSem par_sem $ + handleSourceError (\err -> do logger err; return Nothing) $ do + -- Have the ModSummary and HscEnv point to our local log_action + -- and filesToClean var. + let lcl_mod = localize_mod mod + let lcl_hsc_env = localize_hsc_env hsc_env + + -- Re-typecheck the loop + -- This is necessary to make sure the knot is tied when + -- we close a recursive module loop, see bug #12035. + type_env_var <- liftIO $ newIORef emptyNameEnv + let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var = + Just (ms_mod lcl_mod, type_env_var) } + lcl_hsc_env'' <- case finish_loop of + Nothing -> return lcl_hsc_env' + -- In the non-parallel case, the retypecheck prior to + -- typechecking the loop closer includes all modules + -- EXCEPT the loop closer. However, our precomputed + -- SCCs include the loop closer, so we have to filter + -- it out. + Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $ + filter (/= moduleName (gwib_mod this_build_mod)) $ + map (moduleName . gwib_mod) loop + + -- Compile the module. + mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods + lcl_mod mod_index num_mods + return (Just mod_info) + + case mb_mod_info of + Nothing -> return Failed + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Prune the old HPT unless this is an hs-boot module. + unless (isBootSummary mod == IsBoot) $ + atomicModifyIORef' old_hpt_var $ \old_hpt -> + (delFromHpt old_hpt this_mod, ()) + + -- Update and fetch the global HscEnv. + lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do + let hsc_env' = hsc_env + { hsc_HPT = addToHpt (hsc_HPT hsc_env) + this_mod mod_info } + -- We've finished typechecking the module, now we must + -- retypecheck the loop AGAIN to ensure unfoldings are + -- updated. This time, however, we include the loop + -- closer! + hsc_env'' <- case finish_loop of + Nothing -> return hsc_env' + Just loop -> typecheckLoop lcl_dflags hsc_env' $ + map (moduleName . gwib_mod) loop + return (hsc_env'', localize_hsc_env hsc_env'') + + -- Clean up any intermediate files. + cleanup lcl_hsc_env' + return Succeeded + + where + localize_mod mod + = mod { ms_hspp_opts = (ms_hspp_opts mod) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + + localize_hsc_env hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + +-- ----------------------------------------------------------------------------- +-- +-- | The upsweep +-- +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. +-- +-- There better had not be any cyclic groups here -- we check for them. +upsweep + :: GhcMonad m + => Maybe Messager + -> HomePackageTable -- ^ HPT from last time round (pruned) + -> StableModules -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep mHscMessage old_hpt stable_mods cleanup sccs = do + dflags <- getSessionDynFlags + (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) + (instantiatedUnitsToCheck dflags) done_holes + return (res, reverse $ mgModSummaries done) + where + done_holes = emptyUniqSet + + keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do + let sum_deps ms (AcyclicSCC mod) = + if any (flip elem $ unfilteredEdges False mod) ms + then mkHomeBuildModule mod:ms + else ms + sum_deps ms _ = ms + dep_closure = foldl' sum_deps this_mods mods + dropped_ms = drop (length this_mods) (reverse dep_closure) + prunable (AcyclicSCC mod) = elem (mkHomeBuildModule mod) dep_closure + prunable _ = False + mods' = filter (not . prunable) mods + nmods' = nmods - length dropped_ms + + when (not $ null dropped_ms) $ do + dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ gwib_mod <$> dropped_ms) + (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes + return (Failed, done') + + upsweep' + :: GhcMonad m + => HomePackageTable + -> ModuleGraph + -> [SCC ModSummary] + -> Int + -> Int + -> [Unit] + -> UniqSet ModuleName + -> m (SuccessFlag, ModuleGraph) + upsweep' _old_hpt done + [] _ _ uids_to_check _ + = do hsc_env <- getSession + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) uids_to_check + return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + if gopt Opt_KeepGoing dflags + then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods + uids_to_check done_holes + else return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- TODO: Cache this, so that we don't repeatedly re-check + -- our imports when you run --make. + let (ready_uids, uids_to_check') + = partition (\uid -> isEmptyUniqDSet + (unitFreeModuleHoles uid `uniqDSetMinusUniqSet` done_holes)) + uids_to_check + done_holes' + | ms_hsc_src mod == HsigFile + = addOneToUniqSet done_holes (ms_mod_name mod) + | otherwise = done_holes + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) ready_uids + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + -- Get ready to tie the knot + type_env_var <- liftIO $ newIORef emptyNameEnv + let hsc_env1 = hsc_env { hsc_type_env_var = + Just (ms_mod mod, type_env_var) } + setSession hsc_env1 + + -- Lazily reload the HPT modules participating in the loop. + -- See Note [Tying the knot]--if we don't throw out the old HPT + -- and reinitalize the knot-tying process, anything that was forced + -- while we were previously typechecking won't get updated, this + -- was bug #12035. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done + setSession hsc_env2 + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> do + dflags <- getSessionDynFlags + if gopt Opt_KeepGoing dflags + then keep_going [mkHomeBuildModule mod] old_hpt done mods mod_index nmods + uids_to_check done_holes + else return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info + hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probably for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled + -- every time. + old_hpt1 = case isBootSummary mod of + IsBoot -> old_hpt + NotBoot -> delFromHpt old_hpt this_mod + + done' = extendMG done mod + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. We have to do this again + -- to make sure we have the final unfoldings, which may + -- not have been computed accurately in the previous + -- retypecheck. + hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' + setSession hsc_env4 + + -- Add any necessary entries to the static pointer + -- table. See Note [Grand plan for static forms] in + -- GHC.Iface.Tidy.StaticPtrTable. + when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ + liftIO $ hscAddSptEntries hsc_env4 + [ spt + | Just linkable <- pure $ hm_linkable mod_info + , unlinked <- linkableUnlinked linkable + , BCOs _ spts <- pure unlinked + , spt <- spts + ] + + upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' + +-- | Return a list of instantiated units to type check from the UnitState. +-- +-- Use explicit (instantiated) units as roots and also return their +-- instantiations that are themselves instantiations and so on recursively. +instantiatedUnitsToCheck :: DynFlags -> [Unit] +instantiatedUnitsToCheck dflags = + nubSort $ concatMap goUnit (explicitUnits (unitState dflags)) + where + goUnit HoleUnit = [] + goUnit (RealUnit _) = [] + goUnit uid@(VirtUnit i) = uid : concatMap (goUnit . moduleUnit . snd) (instUnitInsts i) + +maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) +maybeGetIfaceDate dflags location + | writeInterfaceOnlyMode dflags + -- Minor optimization: it should be harmless to check the hi file location + -- always, but it's better to avoid hitting the filesystem if possible. + = modificationTimeIfExists (ml_hi_file location) + | otherwise + = return Nothing + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> Maybe Messager + -> HomePackageTable + -> StableModules + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo +upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj + is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco + + old_hmi = lookupHpt old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fllvm to -fasm and vice-versa, or away from -fno-code, + -- otherwise we could end up trying to link object code to byte + -- code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + && not (prevailing_target == HscNothing) + && not (prevailing_target == HscInterpreted) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary == IsBoot -> Just iface + | mi_boot iface == NotBoot -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo + compile_it mb_linkable src_modified = + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods + mb_old_iface mb_linkable src_modified + + compile_it_discard_iface :: Maybe Linkable -> SourceModified + -> IO HomeModInfo + compile_it_discard_iface mb_linkable src_modified = + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods + Nothing mb_linkable src_modified + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) SourceUnmodifiedAndStable + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) SourceUnmodified + + -- See Note [Recompilation checking in -fno-code mode] + | writeInterfaceOnlyMode dflags, + Just if_date <- mb_if_date, + if_date >= hs_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping tc'd mod:" <+> ppr this_mod_name) + compile_it Nothing SourceUnmodified + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing SourceModified + + +{- Note [-fno-code mode] +~~~~~~~~~~~~~~~~~~~~~~~~ +GHC offers the flag -fno-code for the purpose of parsing and typechecking a +program without generating object files. This is intended to be used by tooling +and IDEs to provide quick feedback on any parser or type errors as cheaply as +possible. + +When GHC is invoked with -fno-code no object files or linked output will be +generated. As many errors and warnings as possible will be generated, as if +-fno-code had not been passed. The session DynFlags will have +hscTarget == HscNothing. + +-fwrite-interface +~~~~~~~~~~~~~~~~ +Whether interface files are generated in -fno-code mode is controlled by the +-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is +not also passed. Recompilation avoidance requires interface files, so passing +-fno-code without -fwrite-interface should be avoided. If -fno-code were +re-implemented today, -fwrite-interface would be discarded and it would be +considered always on; this behaviour is as it is for backwards compatibility. + +================================================================ +IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER +================================================================ + +Template Haskell +~~~~~~~~~~~~~~~~ +A module using template haskell may invoke an imported function from inside a +splice. This will cause the type-checker to attempt to execute that code, which +would fail if no object files had been generated. See #8025. To rectify this, +during the downsweep we patch the DynFlags in the ModSummary of any home module +that is imported by a module that uses template haskell, to generate object +code. + +The flavour of generated object code is chosen by defaultObjectTarget for the +target platform. It would likely be faster to generate bytecode, but this is not +supported on all platforms(?Please Confirm?), and does not support the entirety +of GHC haskell. See #1257. + +The object files (and interface files if -fwrite-interface is disabled) produced +for template haskell are written to temporary files. + +Note that since template haskell can run arbitrary IO actions, -fno-code mode +is no more secure than running without it. + +Potential TODOS: +~~~~~ +* Remove -fwrite-interface and have interface files always written in -fno-code + mode +* Both .o and .dyn_o files are generated for template haskell, but we only need + .dyn_o. Fix it. +* In make mode, a message like + Compiling A (A.hs, /tmp/ghc_123.o) + is shown if downsweep enabled object code generation for A. Perhaps we should + show "nothing" or "temporary object file" instead. Note that one + can currently use -keep-tmp-files and inspect the generated file with the + current behaviour. +* Offer a -no-codedir command line option, and write what were temporary + object files there. This would speed up recompilation. +* Use existing object files (if they are up to date) instead of always + generating temporary ones. +-} + +-- Note [Recompilation checking in -fno-code mode] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we are compiling with -fno-code -fwrite-interface, there won't +-- be any object code that we can compare against, nor should there +-- be: we're *just* generating interface files. In this case, we +-- want to check if the interface file is new, in lieu of the object +-- file. See also #9243. + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToHpt [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupHpt hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function GHC.IfaceToCore.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | Just loop <- getModLoop ms mss appearsAsBoot + -- SOME hs-boot files should still + -- get used, just not the loop-closer. + , let non_boot = filter (\l -> not (isBootSummary l == IsBoot && + ms_mod l == ms_mod ms)) loop + = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + mss = mgModSummaries graph + appearsAsBoot = (`elemModuleSet` mgBootModules graph) + +-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a +-- corresponding boot file in @graph@, return the set of modules which +-- transitively depend on this boot file. This function is slightly misnamed, +-- but its name "getModLoop" alludes to the fact that, when getModLoop is called +-- with a graph that does not contain @ms@ (non-parallel case) or is an +-- SCC with hs-boot nodes dropped (parallel-case), the modules which +-- depend on the hs-boot file are typically (but not always) the +-- modules participating in the recursive module loop. The returned +-- list includes the hs-boot file. +-- +-- Example: +-- let g represent the module graph: +-- C.hs +-- A.hs-boot imports C.hs +-- B.hs imports A.hs-boot +-- A.hs imports B.hs +-- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs] +-- +-- It would also be permissible to omit A.hs from the graph, +-- in which case the result is [A.hs-boot, B.hs] +-- +-- Example: +-- A counter-example to the claim that modules returned +-- by this function participate in the loop occurs here: +-- +-- let g represent the module graph: +-- C.hs +-- A.hs-boot imports C.hs +-- B.hs imports A.hs-boot +-- A.hs imports B.hs +-- D.hs imports A.hs-boot +-- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs] +-- +-- Arguably, D.hs should import A.hs, not A.hs-boot, but +-- a dependency on the boot file is not illegal. +-- +getModLoop + :: ModSummary + -> [ModSummary] + -> (Module -> Bool) -- check if a module appears as a boot module in 'graph' + -> Maybe [ModSummary] +getModLoop ms graph appearsAsBoot + | isBootSummary ms == NotBoot + , appearsAsBoot this_mod + , let mss = reachableBackwards (ms_mod_name ms) graph + = Just mss + | otherwise + = Nothing + where + this_mod = ms_mod ms + +-- NB: sometimes mods has duplicates; this is harmless because +-- any duplicates get clobbered in addListToHpt and never get forced. +typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop dflags hsc_env mods = do + debugTraceMsg dflags 2 $ + text "Re-typechecking loop: " <> ppr mods + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToHpt old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ node_payload node | node <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node $ GWIB mod IsBoot) + +-- --------------------------------------------------------------------------- +-- +-- | Topological sort of the module graph +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> ModuleGraph + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModSummary] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + summaries = mgModSummaries module_graph + -- stronglyConnCompG flips the original order, so if we reverse + -- the summaries we get a stable topological sort. + (graph, lookup_node) = + moduleGraphNodes drop_hs_boot_nodes (reverse summaries) + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node $ GWIB root_mod NotBoot + , graph `hasVertexG` node + = node + | otherwise + = throwGhcException (ProgramError "module does not exist") + in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) + +type SummaryNode = Node Int ModSummary + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey = node_key + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary = node_payload + +unfilteredEdges :: Bool -> ModSummary -> [ModuleNameWithIsBoot] +unfilteredEdges drop_hs_boot_nodes ms = + (flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++ + (flip GWIB NotBoot . unLoc <$> ms_home_imps ms) ++ + [ GWIB (ms_mod_name ms) IsBoot + | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile + -- see [boot-edges] below + ] + where + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature + | otherwise = IsBoot + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, ModuleNameWithIsBoot -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: ModuleNameWithIsBoot -> Maybe SummaryNode + lookup_node mnwib = Map.lookup mnwib node_map + + lookup_key :: ModuleNameWithIsBoot -> Maybe Int + lookup_key = fmap summaryNodeKey . lookup_node + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ (mkHomeBuildModule s, node) + | node <- nodes + , let s = summaryNodeSummary node + ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s == IsBoot && drop_hs_boot_nodes) + ] + + out_edge_keys :: [ModuleNameWithIsBoot] -> [Int] + out_edge_keys = mapMaybe lookup_key + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else False + +-- The nodes of the graph are keyed by (mod, is boot?) pairs +-- NB: hsig files show up as *normal* nodes (not boot!), since they don't +-- participate in cycles (for now) +type NodeKey = ModuleNameWithIsBoot +type NodeMap a = Map.Map NodeKey a + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) + = GWIB + { gwib_mod = moduleName mod + , gwib_isBoot = hscSourceToIsBoot boot + } + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + dflags <- getDynFlags + when (wopt Opt_WarnUnusedImports dflags) + (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) + where check dflags ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn dflags i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: DynFlags -> Located ModuleName -> WarnMsg + warn dflags (L loc mod) = + mkPlainErrMsg dflags loc + (text "Warning: {-# SOURCE #-} unnecessary in import of " + <+> quotes (ppr mod)) + + +----------------------------------------------------------------------------- +-- +-- | Downsweep (dependency analysis) +-- +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. +-- +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [Either ErrorMessages ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = do + rootSummaries <- mapM getRootSummary roots + let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 + root_map = mkRootMap rootSummariesOk + checkDuplicates root_map + map0 <- loop (concatMap calcDeps rootSummariesOk) root_map + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + map1 <- if hscTarget dflags == HscNothing + then enableCodeGenForTH + (defaultObjectTarget dflags) + map0 + else if hscTarget dflags == HscInterpreted + then enableCodeGenForUnboxedTuplesOrSums + (defaultObjectTarget dflags) + map0 + else return map0 + if null errs + then pure $ concat $ nodeMapElts map1 + else pure $ map Left errs + where + calcDeps = msDeps + + dflags = hsc_dflags hsc_env + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO (Either ErrorMessages ModSummary) + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists || isJust maybe_buf + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> return $ Left $ moduleNotFoundErr dflags modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map + + loop :: [GenWithIsBoot (Located ModuleName)] + -- Work list: process these modules + -> NodeMap [Either ErrorMessages ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO (NodeMap [Either ErrorMessages ModSummary]) + -- The result is the completed NodeMap + loop [] done = return done + loop (s : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr dflags (rights summs); return Map.empty } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just (Left e) -> loop ss (Map.insert key [Left e] done) + Just (Right s)-> do + new_map <- + loop (calcDeps s) (Map.insert key [Right s] done) + loop ss new_map + where + GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s + wanted_mod = L loc mod + key = GWIB + { gwib_mod = unLoc wanted_mod + , gwib_isBoot = is_boot + } + +-- | Update the every ModSummary that is depended on +-- by a module that needs template haskell. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- See Note [-fno-code mode] +enableCodeGenForTH :: HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenForTH = + enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession + where + condition = isTemplateHaskellOrQQNonBoot + should_modify (ModSummary { ms_hspp_opts = dflags }) = + hscTarget dflags == HscNothing && + -- Don't enable codegen for TH on indefinite packages; we + -- can't compile anything anyway! See #16219. + homeUnitIsDefinite dflags + +-- | Update the every ModSummary that is depended on +-- by a module that needs unboxed tuples. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- +-- This is used in order to load code that uses unboxed tuples +-- or sums into GHCi while still allowing some code to be interpreted. +enableCodeGenForUnboxedTuplesOrSums :: HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenForUnboxedTuplesOrSums = + enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule + where + condition ms = + unboxed_tuples_or_sums (ms_hspp_opts ms) && + not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) && + (isBootSummary ms == NotBoot) + unboxed_tuples_or_sums d = + xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d + should_modify (ModSummary { ms_hspp_opts = dflags }) = + hscTarget dflags == HscInterpreted + +-- | Helper used to implement 'enableCodeGenForTH' and +-- 'enableCodeGenForUnboxedTuples'. In particular, this enables +-- unoptimized code generation for all modules that meet some +-- condition (first parameter), or are dependencies of those +-- modules. The second parameter is a condition to check before +-- marking modules for code generation. +enableCodeGenWhen + :: (ModSummary -> Bool) + -> (ModSummary -> Bool) + -> TempFileLifetime + -> TempFileLifetime + -> HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenWhen condition should_modify staticLife dynLife target nodemap = + traverse (traverse (traverse enable_code_gen)) nodemap + where + enable_code_gen ms + | ModSummary + { ms_mod = ms_mod + , ms_location = ms_location + , ms_hsc_src = HsSrcFile + , ms_hspp_opts = dflags + } <- ms + , should_modify ms + , ms_mod `Set.member` needs_codegen_set + = do + let new_temp_file suf dynsuf = do + tn <- newTempName dflags staticLife suf + let dyn_tn = tn -<.> dynsuf + addFilesToClean dflags dynLife [dyn_tn] + return tn + -- We don't want to create .o or .hi files unless we have been asked + -- to by the user. But we need them, so we patch their locations in + -- the ModSummary with temporary files. + -- + (hi_file, o_file) <- + -- If ``-fwrite-interface` is specified, then the .o and .hi files + -- are written into `-odir` and `-hidir` respectively. #16670 + if gopt Opt_WriteInterface dflags + then return (ml_hi_file ms_location, ml_obj_file ms_location) + else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags)) + <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags)) + return $ + ms + { ms_location = + ms_location {ml_hi_file = hi_file, ml_obj_file = o_file} + , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target} + } + | otherwise = return ms + + needs_codegen_set = transitive_deps_set + [ ms + | mss <- Map.elems nodemap + , Right ms <- mss + , condition ms + ] + + -- find the set of all transitive dependencies of a list of modules. + transitive_deps_set modSums = foldl' go Set.empty modSums + where + go marked_mods ms@ModSummary{ms_mod} + | ms_mod `Set.member` marked_mods = marked_mods + | otherwise = + let deps = + [ dep_ms + -- If a module imports a boot module, msDeps helpfully adds a + -- dependency to that non-boot module in it's result. This + -- means we don't have to think about boot modules here. + | dep <- msDeps ms + , NotBoot == gwib_isBoot dep + , dep_ms_0 <- toList $ Map.lookup (unLoc <$> dep) nodemap + , dep_ms_1 <- toList $ dep_ms_0 + , dep_ms <- toList $ dep_ms_1 + ] + new_marked_mods = Set.insert ms_mod marked_mods + in foldl' go new_marked_mods deps + +mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [Right s]) | s <- summaries ] + Map.empty + +-- | Returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)] +msDeps s = [ d + | m <- ms_home_srcimps s + , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot } + , GWIB { gwib_mod = m, gwib_isBoot = NotBoot } + ] + ] + ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot } + | m <- ms_home_imps s + ] + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,UTCTime) + -> IO (Either ErrorMessages ModSummary) + +summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries src_fn + = do + let location = ms_location old_summary + dflags = hsc_dflags hsc_env + + src_timestamp <- get_src_timestamp + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationUTCTime may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + checkSummaryTimestamp + hsc_env dflags obj_allowed NotBoot (new_summary src_fn) + old_summary location src_timestamp + + | otherwise + = do src_timestamp <- get_src_timestamp + new_summary src_fn src_timestamp + where + get_src_timestamp = case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationUTCTime src_fn + -- getModificationUTCTime may fail + + new_summary src_fn src_timestamp = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf + + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = NotBoot + , nms_hsc_src = + if isHaskellSigFilename src_fn + then HsigFile + else HsSrcFile + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x + +checkSummaryTimestamp + :: HscEnv -> DynFlags -> Bool -> IsBootInterface + -> (UTCTime -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> UTCTime + -> IO (Either e ModSummary) +checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot new_summary + old_summary location src_timestamp + | ms_hs_date old_summary == src_timestamp && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location is_boot + else return Nothing + + -- We have to repopulate the Finder's cache for file targets + -- because the file might not even be on the regular search path + -- and it was likely flushed in depanal. This is not technically + -- needed when we're called from sumariseModule but it shouldn't + -- hurt. + _ <- addHomeModuleToFinder hsc_env + (moduleName (ms_mod old_summary)) location + + hi_timestamp <- maybeGetIfaceDate dflags location + hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + + return $ Right old_summary + { ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + } + + | otherwise = + -- source changed: re-summarise. + new_summary src_timestamp + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe (Either ErrorMessages ModSummary)) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup + (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot }) + old_summary_map + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> + Just <$> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationUTCTime src_fn) + case m of + Right t -> + Just <$> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + check_timestamp old_summary location src_fn = + checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot + (new_summary location (ms_mod old_summary) src_fn) + old_summary location + + find_it = do + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + Just <$> just_found location mod + + _ -> return Nothing + -- Not found + -- (If it is TRULY not found at all, we'll + -- error when we actually try to compile) + + just_found location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' = case is_boot of + IsBoot -> addBootSuffixLocn location + NotBoot -> location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> return $ Left $ noHsFileErr dflags loc src_fn + Just t -> new_summary location' mod src_fn t + + new_summary location mod src_fn src_timestamp + = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src + | is_boot == IsBoot = HsBootFile + | isHaskellSigFilename src_fn = HsigFile + | otherwise = HsSrcFile + + when (pi_mod_name /= wanted_mod) $ + throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr pi_mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations dflags))) $ + let suggested_instantiated_with = + hcat (punctuate comma $ + [ ppr k <> text "=" <> ppr v + | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) + : homeUnitInstantiations dflags) + ]) + in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "Unexpected signature:" <+> quotes (ppr pi_mod_name) + $$ if gopt Opt_BuildingCabalPackage dflags + then parens (text "Try adding" <+> quotes (ppr pi_mod_name) + <+> text "to the" + <+> quotes (text "signatures") + <+> text "field in your Cabal file.") + else parens (text "Try passing -instantiated-with=\"" <> + suggested_instantiated_with <> text "\"" $$ + text "replacing <" <> ppr pi_mod_name <> text "> as necessary.") + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = is_boot + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } + +-- | Convenience named arguments for 'makeNewModSummary' only used to make +-- code more readable, not exported. +data MakeNewModSummary + = MakeNewModSummary + { nms_src_fn :: FilePath + , nms_src_timestamp :: UTCTime + , nms_is_boot :: IsBootInterface + , nms_hsc_src :: HscSource + , nms_location :: ModLocation + , nms_mod :: Module + , nms_obj_allowed :: Bool + , nms_preimps :: PreprocessedImports + } + +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary +makeNewModSummary hsc_env MakeNewModSummary{..} = do + let PreprocessedImports{..} = nms_preimps + let dflags = hsc_dflags hsc_env + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- liftIO $ + if isObjectTarget (hscTarget dflags) + || nms_obj_allowed -- bug #1205 + then getObjTimestamp nms_location nms_is_boot + else return Nothing + + hi_timestamp <- maybeGetIfaceDate dflags nms_location + hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) + + extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name + required_by_imports <- implicitRequirements hsc_env pi_theimps + + return $ ModSummary + { ms_mod = nms_mod + , ms_hsc_src = nms_hsc_src + , ms_location = nms_location + , ms_hspp_file = pi_hspp_fn + , ms_hspp_opts = pi_local_dflags + , ms_hspp_buf = Just pi_hspp_buf + , ms_parsed_mod = Nothing + , ms_srcimps = pi_srcimps + , ms_textual_imps = + pi_theimps ++ extra_sig_imports ++ required_by_imports + , ms_hs_date = nms_src_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + , ms_obj_date = obj_timestamp + } + +getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime) +getObjTimestamp location is_boot + = case is_boot of + IsBoot -> return Nothing + NotBoot -> modificationTimeIfExists (ml_obj_file location) + +data PreprocessedImports + = PreprocessedImports + { pi_local_dflags :: DynFlags + , pi_srcimps :: [(Maybe FastString, Located ModuleName)] + , pi_theimps :: [(Maybe FastString, Located ModuleName)] + , pi_hspp_fn :: FilePath + , pi_hspp_buf :: StringBuffer + , pi_mod_name_loc :: SrcSpan + , pi_mod_name :: ModuleName + } + +-- Preprocess the source file and get its imports +-- The pi_local_dflags contains the OPTIONS pragmas +getPreprocessedImports + :: HscEnv + -> FilePath + -> Maybe Phase + -> Maybe (StringBuffer, UTCTime) + -- ^ optional source code buffer and modification time + -> ExceptT ErrorMessages IO PreprocessedImports +getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do + (pi_local_dflags, pi_hspp_fn) + <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase + pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn + (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name) + <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn + return PreprocessedImports {..} + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +-- Defer and group warning, error and fatal messages so they will not get lost +-- in the regular output. +withDeferredDiagnostics :: GhcMonad m => m a -> m a +withDeferredDiagnostics f = do + dflags <- getDynFlags + if not $ gopt Opt_DeferDiagnostics dflags + then f + else do + warnings <- liftIO $ newIORef [] + errors <- liftIO $ newIORef [] + fatals <- liftIO $ newIORef [] + + let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do + let action = putLogMsg dflags reason severity srcSpan msg + case severity of + SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) + SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) + SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ()) + _ -> action + + printDeferredDiagnostics = liftIO $ + forM_ [warnings, errors, fatals] $ \ref -> do + -- This IORef can leak when the dflags leaks, so let us always + -- reset the content. + actions <- atomicModifyIORef' ref $ \i -> ([], i) + sequence_ $ reverse actions + + setLogAction action = modifySession $ \hsc_env -> + hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } } + + MC.bracket + (setLogAction deferDiagnostics) + (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) + (\_ -> f) + +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages +noHsFileErr dflags loc path + = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path + +moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages +moduleNotFoundErr dflags mod + = unitBag $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" + +multiRootsErr :: DynFlags -> [ModSummary] -> IO () +multiRootsErr _ [] = panic "multiRootsErr" +multiRootsErr dflags summs@(summ1:_) + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +keepGoingPruneErr :: [ModuleName] -> SDoc +keepGoingPruneErr ms + = vcat (( text "-fkeep-going in use, removing the following" <+> + text "dependencies and continuing:"): + map (nest 6 . ppr) ms ) + +cyclicModuleErr :: [ModSummary] -> SDoc +-- From a strongly connected component we find +-- a single cycle to report +cyclicModuleErr mss + = ASSERT( not (null mss) ) + case findCycle graph of + Nothing -> text "Unexpected non-cycle" <+> ppr mss + Just path -> vcat [ text "Module imports form a cycle:" + , nest 2 (show_path path) ] + where + graph :: [Node NodeKey ModSummary] + graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss] + + get_deps :: ModSummary -> [NodeKey] + get_deps ms = + [ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot } + | m <- ms_home_srcimps ms ] ++ + [ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot } + | m <- ms_home_imps ms ] + + show_path [] = panic "show_path" + show_path [m] = text "module" <+> ppr_ms m + <+> text "imports itself" + show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1) + : nest 6 (text "imports" <+> ppr_ms m2) + : go ms ) + where + go [] = [text "which imports" <+> ppr_ms m1] + go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms + + + ppr_ms :: ModSummary -> SDoc + ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> + (parens (text (msHsFilePath ms))) diff --git a/GHC/Driver/MakeFile.hs b/GHC/Driver/MakeFile.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/MakeFile.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Makefile Dependency Generation +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.MakeFile + ( doMkDependHS + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import qualified GHC +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Driver.Types +import qualified GHC.SysTools as SysTools +import GHC.Unit.Module +import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Driver.Finder +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.SrcLoc +import Data.List +import GHC.Data.FastString +import GHC.SysTools.FileCleanup + +import GHC.Utils.Exception +import GHC.Utils.Error + +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error ( isEOFError ) +import Control.Monad ( when, forM_ ) +import Data.Maybe ( isJust ) +import Data.IORef +import qualified Data.Set as Set + +----------------------------------------------------------------- +-- +-- The main function +-- +----------------------------------------------------------------- + +doMkDependHS :: GhcMonad m => [FilePath] -> m () +doMkDependHS srcs = do + -- Initialisation + dflags0 <- GHC.getSessionDynFlags + + -- We kludge things a bit for dependency generation. Rather than + -- generating dependencies for each way separately, we generate + -- them once and then duplicate them for each way's osuf/hisuf. + -- We therefore do the initial dependency generation with an empty + -- way and .o/.hi extensions, regardless of any flags that might + -- be specified. + let dflags = dflags0 { + ways = Set.empty, + hiSuf = "hi", + objectSuf = "o" + } + GHC.setSessionDynFlags dflags + + when (null (depSuffixes dflags)) $ liftIO $ + throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") + + files <- liftIO $ beginMkDependHS dflags + + -- Do the downsweep to find all the modules + targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs + GHC.setTargets targets + let excl_mods = depExcludeMods dflags + module_graph <- GHC.depanal excl_mods True {- Allow dup roots -} + + -- Sort into dependency order + -- There should be no cycles + let sorted = GHC.topSortModuleGraph False module_graph Nothing + + -- Print out the dependencies if wanted + liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + + -- Process them one by one, dumping results into makefile + -- and complaining about cycles + hsc_env <- getSession + root <- liftIO getCurrentDirectory + mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles dflags module_graph + + -- Tidy up + liftIO $ endMkDependHS dflags files + + -- Unconditional exiting is a bad idea. If an error occurs we'll get an + --exception; if that is not caught it's fine, but at least we have a + --chance to find out exactly what went wrong. Uncomment the following + --line if you disagree. + + --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) + +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- + +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file + +beginMkDependHS :: DynFlags -> IO MkDepFiles +beginMkDependHS dflags = do + -- open a new temp file in which to stuff the dependency info + -- as we go along. + tmp_file <- newTempName dflags TFL_CurrentModule "dep" + tmp_hdl <- openFile tmp_file WriteMode + + -- open the makefile + let makefile = depMakefile dflags + exists <- doesFileExist makefile + mb_make_hdl <- + if not exists + then return Nothing + else do + makefile_hdl <- openFile makefile ReadMode + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + catchIO chuck + (\e -> if isEOFError e then return () else ioError e) + + return (Just makefile_hdl) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) + + +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: DynFlags + -> HscEnv + -> [ModuleName] + -> FilePath + -> Handle -- Write dependencies to here + -> SCC ModSummary + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps dflags _ _ _ _ (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) + +processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) + = do { let extra_suffixes = depSuffixes dflags + include_pkg_deps = depIncludePkgDeps dflags + src_file = msHsFilePath node + obj_file = msObjFilePath node + obj_files = insertSuffixes obj_file extra_suffixes + + do_imp loc is_boot pkg_qual imp_mod + = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod + is_boot include_pkg_deps + ; case mb_hi of { + Nothing -> return () ; + Just hi_file -> do + { let hi_files = insertSuffixes hi_file extra_suffixes + write_dep (obj,hi) = writeDependency root hdl [obj] hi + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + ; mapM_ write_dep (obj_files `zip` hi_files) }}} + + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + ; writeDependency root hdl obj_files src_file + + -- add dependency between objects and their corresponding .hi-boot + -- files if the module has a corresponding .hs-boot file (#14482) + ; when (isBootSummary node == IsBoot) $ do + let hi_boot = msHiFilePath node + let obj = removeBootSuffix (msObjFilePath node) + forM_ extra_suffixes $ \suff -> do + let way_obj = insertSuffixes obj [suff] + let way_hi_boot = insertSuffixes hi_boot [suff] + mapM_ (writeDependency root hdl way_obj) way_hi_boot + + -- Emit a dependency for each CPP import + ; when (depIncludeCppDeps dflags) $ do + -- CPP deps are descovered in the module parsing phase by parsing + -- comment lines left by the preprocessor. + -- Note that GHC.parseModule may throw an exception if the module + -- fails to parse, which may not be desirable (see #16616). + { session <- Session <$> newIORef hsc_env + ; parsedMod <- reflectGhc (GHC.parseModule node) session + ; mapM_ (writeDependency root hdl obj_files) + (GHC.pm_extra_src_files parsedMod) + } + + -- Emit a dependency for each import + + ; let do_imps is_boot idecls = sequence_ + [ do_imp loc is_boot mb_pkg mod + | (mb_pkg, L loc mod) <- idecls, + mod `notElem` excl_mods ] + + ; do_imps IsBoot (ms_srcimps node) + ; do_imps NotBoot (ms_imps node) + } + + +findDependency :: HscEnv + -> SrcSpan + -> Maybe FastString -- package qualifier, if any + -> ModuleName -- Imported module + -> IsBootInterface -- Source import + -> Bool -- Record dependency on package modules + -> IO (Maybe FilePath) -- Interface file +findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps + = do { -- Find the module; this will be fast because + -- we've done it once during downsweep + r <- findImportedModule hsc_env imp pkg + ; case r of + Found loc _ + -- Home package: just depend on the .hi or hi-boot file + | isJust (ml_hs_file loc) || include_pkg_deps + -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + + -- Not in this package: we don't need a dependency + | otherwise + -> return Nothing + + fail -> + let dflags = hsc_dflags hsc_env + in throwOneError $ mkPlainErrMsg dflags srcloc $ + cannotFindModule dflags imp fail + } + +----------------------------- +writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () +-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency +-- t1 t2 : dep +writeDependency root hdl targets dep + = do let -- We need to avoid making deps on + -- c:/foo/... + -- on cygwin as make gets confused by the : + -- Making relative deps avoids some instances of this. + dep' = makeRelative root dep + forOutput = escapeSpaces . reslash Forwards . normalise + output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' + hPutStrLn hdl output + +----------------------------- +insertSuffixes + :: FilePath -- Original filename; e.g. "foo.o" + -> [String] -- Suffix prefixes e.g. ["x_", "y_"] + -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] + -- Note that the extra bit gets inserted *before* the old suffix + -- We assume the old suffix contains no dots, so we know where to + -- split it +insertSuffixes file_name extras + = [ basename <.> (extra ++ suffix) | extra <- extras ] + where + (basename, suffix) = case splitExtension file_name of + -- Drop the "." from the extension + (b, s) -> (b, drop 1 s) + + +----------------------------------------------------------------- +-- +-- endMkDependHs +-- Complete the makefile, close the tmp file etc +-- +----------------------------------------------------------------- + +endMkDependHS :: DynFlags -> MkDepFiles -> IO () + +endMkDependHS dflags + (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + = do + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + case makefile_hdl of + Nothing -> return () + Just hdl -> do + + -- slurp the rest of the original makefile and copy it into the output + let slurp = do + l <- hGetLine hdl + hPutStrLn tmp_hdl l + slurp + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + + hClose hdl + + hClose tmp_hdl -- make sure it's flushed + + -- Create a backup of the original makefile + when (isJust makefile_hdl) + (SysTools.copy dflags ("Backing up " ++ makefile) + makefile (makefile++".bak")) + + -- Copy the new makefile in place + SysTools.copy dflags "Installing new makefile" tmp_file makefile + + +----------------------------------------------------------------- +-- Module cycles +----------------------------------------------------------------- + +dumpModCycles :: DynFlags -> ModuleGraph -> IO () +dumpModCycles dflags module_graph + | not (dopt Opt_D_dump_mod_cycles dflags) + = return () + + | null cycles + = putMsg dflags (text "No module cycles") + + | otherwise + = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) + where + + cycles :: [[ModSummary]] + cycles = + [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ] + + pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------")) + $$ pprCycle c $$ blankLine + | (n,c) <- [1..] `zip` cycles ] + +pprCycle :: [ModSummary] -> SDoc +-- Print a cycle, but show only the imports within the cycle +pprCycle summaries = pp_group (CyclicSCC summaries) + where + cycle_mods :: [ModuleName] -- The modules in this cycle + cycle_mods = map (moduleName . ms_mod) summaries + + pp_group (AcyclicSCC ms) = pp_ms ms + pp_group (CyclicSCC mss) + = ASSERT( not (null boot_only) ) + -- The boot-only list must be non-empty, else there would + -- be an infinite chain of non-boot imports, and we've + -- already checked for that in processModDeps + pp_ms loop_breaker $$ vcat (map pp_group groups) + where + (boot_only, others) = partition is_boot_only mss + is_boot_only ms = not (any in_group (map snd (ms_imps ms))) + in_group (L _ m) = m `elem` group_mods + group_mods = map (moduleName . ms_mod) mss + + loop_breaker = head boot_only + all_others = tail boot_only ++ others + groups = + GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing + + pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) + <+> (pp_imps empty (map snd (ms_imps summary)) $$ + pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) + where + mod_str = moduleNameString (moduleName (ms_mod summary)) + + pp_imps :: SDoc -> [Located ModuleName] -> SDoc + pp_imps _ [] = empty + pp_imps what lms + = case [m | L _ m <- lms, m `elem` cycle_mods] of + [] -> empty + ms -> what <+> text "imports" <+> + pprWithCommas ppr ms + +----------------------------------------------------------------- +-- +-- Flags +-- +----------------------------------------------------------------- + +depStartMarker, depEndMarker :: String +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" + diff --git a/GHC/Driver/Monad.hs b/GHC/Driver/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Monad.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP, DeriveFunctor, DerivingVia, RankNTypes #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GHC.Driver.Monad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, withTempSession, + + -- ** Warnings + logWarnings, printException, + WarnErrLogger, defaultWarnErrLogger + ) where + +import GHC.Prelude + +import GHC.Utils.Monad +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Utils.Exception +import GHC.Utils.Error + +import Control.Monad +import Control.Monad.Catch as MC +import Control.Monad.Trans.Reader +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `MC.finally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of warnings. + +logWarnings :: GhcMonad m => WarningMessages -> m () +logWarnings warns = do + dflags <- getSessionDynFlags + liftIO $ printOrThrowWarnings dflags warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } + deriving (Functor) + deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO) + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance Applicative Ghc where + pure a = Ghc $ \_ -> return a + g <*> m = do f <- g; a <- m; return (f a) + +instance Monad Ghc where + m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s + +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + +instance MonadFix Ghc where + mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) + +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } + deriving (Functor) + deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m) + +liftGhcT :: m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance Applicative m => Applicative (GhcT m) where + pure x = GhcT $ \_ -> pure x + g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s + +instance Monad m => Monad (GhcT m) where + m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s + +instance MonadIO m => MonadIO (GhcT m) where + liftIO ioA = GhcT $ \_ -> liftIO ioA + +instance MonadIO m => HasDynFlags (GhcT m) where + getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) + +instance ExceptionMonad m => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' + + +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +-- | A function called to log warnings and errors. +type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e + diff --git a/GHC/Driver/Phases.hs b/GHC/Driver/Phases.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Phases.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2002 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Phases ( + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + Phase(..), + happensBefore, eqPhase, anyHsc, isStopLn, + startPhase, + phaseInputExt, + + isHaskellishSuffix, + isHaskellSrcSuffix, + isBackpackishSuffix, + isObjectSuffix, + isCishSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isHaskellSigSuffix, + isSourceSuffix, + + isHaskellishTarget, + + isHaskellishFilename, + isHaskellSrcFilename, + isHaskellSigFilename, + isObjectFilename, + isCishFilename, + isDynLibFilename, + isHaskellUserSrcFilename, + isSourceFilename + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Platform +import System.FilePath +import GHC.Utils.Binary +import GHC.Utils.Misc + +----------------------------------------------------------------------------- +-- 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 +-} + +-- Note [HscSource types] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- There are three types of source file for Haskell code: +-- +-- * HsSrcFile is an ordinary hs file which contains code, +-- +-- * HsBootFile is an hs-boot file, which is used to break +-- recursive module imports (there will always be an +-- HsSrcFile associated with it), and +-- +-- * HsigFile is an hsig file, which contains only type +-- signatures and is used to specify signatures for +-- modules. +-- +-- Syntactically, hs-boot files and hsig files are quite similar: they +-- only include type signatures and must be associated with an +-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code +-- which is indifferent to which. However, there are some important +-- differences, mostly owing to the fact that hsigs are proper +-- modules (you `import Sig` directly) whereas HsBootFiles are +-- temporary placeholders (you `import {-# SOURCE #-} Mod). +-- When we finish compiling the true implementation of an hs-boot, +-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +-- other hand, is never replaced (in particular, we *cannot* use the +-- HomeModInfo of the original HsSrcFile backing the signature, since it +-- will export too many symbols.) +-- +-- Additionally, while HsSrcFile is the only Haskell file +-- which has *code*, we do generate .o files for HsigFile, because +-- this is how the recompilation checker figures out if a file +-- needs to be recompiled. These are fake object files which +-- should NOT be linked against. + +data HscSource + = HsSrcFile | HsBootFile | HsigFile + deriving( Eq, Ord, Show ) + -- Ord needed for the finite maps we build in CompManager + +instance Binary HscSource where + put_ bh HsSrcFile = putByte bh 0 + put_ bh HsBootFile = putByte bh 1 + put_ bh HsigFile = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return HsSrcFile + 1 -> return HsBootFile + _ -> return HsigFile + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" + +-- See Note [isHsBootOrSig] +isHsBootOrSig :: HscSource -> Bool +isHsBootOrSig HsBootFile = True +isHsBootOrSig HsigFile = True +isHsBootOrSig _ = False + +isHsigFile :: HscSource -> Bool +isHsigFile HsigFile = True +isHsigFile _ = False + +data Phase + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource + | Ccxx -- Compile C++ + | Cc -- Compile C + | Cobjc -- Compile Objective-C + | Cobjcxx -- Compile Objective-C++ + | HCc -- Haskellised C (as opposed to vanilla C) compilation + | As Bool -- Assembler for regular assembly files (Bool: with-cpp) + | LlvmOpt -- Run LLVM opt tool over llvm assembly + | LlvmLlc -- LLVM bitcode to native assembly + | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code + | MergeForeign -- merge in the foreign object files + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + -- There is no runPhase case for it. + | StopLn -- Stop, but linking will follow, so generate .o file + deriving (Eq, Show) + +instance Outputable Phase where + ppr p = text (show p) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopLn :: Phase -> Bool +isStopLn StopLn = True +isStopLn _ = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +-- NB: the HscSource field can be 'bot'; see anyHsc above +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True +eqPhase HCc HCc = True +eqPhase (As x) (As y) = x == y +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True +eqPhase LlvmMangle LlvmMangle = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase MergeForeign MergeForeign = True +eqPhase StopLn StopLn = True +eqPhase Ccxx Ccxx = True +eqPhase Cobjcxx Cobjcxx = True +eqPhase _ _ = False + +{- Note [Partial ordering on phases] + +We want to know which phases will occur before which others. This is used for +sanity checking, to ensure that the pipeline will stop at some point (see +GHC.Driver.Pipeline.runPipeline). + +A < B iff A occurs before B in a normal compilation pipeline. + +There is explicitly not a total ordering on phases, because in registerised +builds, the phase `HsC` doesn't happen before nor after any other phase. + +Although we check that a normal user doesn't set the stop_phase to HsC through +use of -C with registerised builds (in Main.checkOptions), it is still +possible for a ghc-api user to do so. So be careful when using the function +happensBefore, and don't think that `not (a <= b)` implies `b < a`. +-} +happensBefore :: Platform -> Phase -> Phase -> Bool +happensBefore platform p1 p2 = p1 `happensBefore'` p2 + where StopLn `happensBefore'` _ = False + x `happensBefore'` y = after_x `eqPhase` y + || after_x `happensBefore'` y + where after_x = nextPhase platform x + +nextPhase :: Platform -> Phase -> Phase +nextPhase platform p + -- A conservative approximation to the next phase, used in happensBefore + = case p of + Unlit sf -> Cpp sf + Cpp sf -> HsPp sf + HsPp sf -> Hsc sf + Hsc _ -> maybeHCc + LlvmOpt -> LlvmLlc + LlvmLlc -> LlvmMangle + LlvmMangle -> As False + As _ -> MergeForeign + Ccxx -> As False + Cc -> As False + Cobjc -> As False + Cobjcxx -> As False + CmmCpp -> Cmm + Cmm -> maybeHCc + HCc -> As False + MergeForeign -> StopLn + StopLn -> panic "nextPhase: nothing after StopLn" + where maybeHCc = if platformUnregisterised platform + then HCc + else As False + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase :: String -> Phase +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "lhsig" = Unlit HsigFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hsig" = Cpp HsigFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Ccxx +startPhase "C" = Cc +startPhase "m" = Cobjc +startPhase "M" = Cobjcxx +startPhase "mm" = Cobjcxx +startPhase "cc" = Ccxx +startPhase "cxx" = Ccxx +startPhase "s" = As False +startPhase "S" = As True +startPhase "ll" = LlvmOpt +startPhase "bc" = LlvmLlc +startPhase "lm_s" = LlvmMangle +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase _ = StopLn -- all unknown file types + +-- This is used to determine the extension for the output from the +-- current phase (if it generates a new file). The extension depends +-- on the next phase in the pipeline. +phaseInputExt :: Phase -> String +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit HsigFile) = "lhsig" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPipeline uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Ccxx = "cpp" +phaseInputExt Cobjc = "m" +phaseInputExt Cobjcxx = "mm" +phaseInputExt Cc = "c" +phaseInputExt (As True) = "S" +phaseInputExt (As False) = "s" +phaseInputExt LlvmOpt = "ll" +phaseInputExt LlvmLlc = "bc" +phaseInputExt LlvmMangle = "lm_s" +phaseInputExt CmmCpp = "cmmcpp" +phaseInputExt Cmm = "cmm" +phaseInputExt MergeForeign = "o" +phaseInputExt StopLn = "o" + +haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, + haskellish_user_src_suffixes, haskellish_sig_suffixes + :: [String] +-- When a file with an extension in the haskellish_src_suffixes group is +-- loaded in --make mode, its imports will be loaded too. +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp" ] +haskellish_suffixes = haskellish_src_suffixes ++ + [ "hc", "cmm", "cmmcpp" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] + +-- Will not be deleted as temp files: +haskellish_user_src_suffixes = + haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] +haskellish_sig_suffixes = [ "hsig", "lhsig" ] +backpackish_suffixes = [ "bkp" ] + +objish_suffixes :: Platform -> [String] +-- Use the appropriate suffix for the system on which +-- the GHC-compiled code will run +objish_suffixes platform = case platformOS platform of + OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] + _ -> [ "o" ] + +dynlib_suffixes :: Platform -> [String] +dynlib_suffixes platform = case platformOS platform of + OSMinGW32 -> ["dll", "DLL"] + OSDarwin -> ["dylib", "so"] + _ -> ["so"] + +isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, + isHaskellUserSrcSuffix, isHaskellSigSuffix + :: String -> Bool +isHaskellishSuffix s = s `elem` haskellish_suffixes +isBackpackishSuffix s = s `elem` backpackish_suffixes +isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes + +isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool +isObjectSuffix platform s = s `elem` objish_suffixes platform +isDynLibSuffix platform s = s `elem` dynlib_suffixes platform + +isSourceSuffix :: String -> Bool +isSourceSuffix suff = isHaskellishSuffix suff + || isCishSuffix suff + || isBackpackishSuffix suff + +-- | When we are given files (modified by -x arguments) we need +-- to determine if they are Haskellish or not to figure out +-- how we should try to compile it. The rules are: +-- +-- 1. If no -x flag was specified, we check to see if +-- the file looks like a module name, has no extension, +-- or has a Haskell source extension. +-- +-- 2. If an -x flag was specified, we just make sure the +-- specified suffix is a Haskell one. +isHaskellishTarget :: (String, Maybe Phase) -> Bool +isHaskellishTarget (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) +isHaskellishTarget (_,Just phase) = + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + , StopLn] + +isHaskellishFilename, isHaskellSrcFilename, isCishFilename, + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + :: FilePath -> Bool +-- takeExtension return .foo, so we drop 1 to get rid of the . +isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) +isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) +isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) +isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) + +isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool +isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) +isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline.hs @@ -0,0 +1,2401 @@ +{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Pipeline ( + -- Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- Interfaces for the batch-mode driver + linkBinary, + + -- Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compileOne, compileOne', + link, + + -- Exports for hooks to override runPhase and link + PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), + phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, + hscPostBackendPhase, getLocation, setModLocation, setDynFlags, + runPhase, exeFileName, + maybeCreateManifest, + doCpp, + linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode + ) where + +#include +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Pipeline.Monad +import GHC.Unit.State +import GHC.Driver.Ways +import GHC.Parser.Header +import GHC.Driver.Phases +import GHC.SysTools +import GHC.SysTools.ExtraObj +import GHC.Driver.Main +import GHC.Driver.Finder +import GHC.Driver.Types hiding ( Hsc ) +import GHC.Utils.Outputable +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) +import GHC.Types.Basic ( SuccessFlag(..) ) +import GHC.Data.Maybe ( expectJust ) +import GHC.Types.SrcLoc +import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) +import GHC.Utils.Monad +import GHC.Platform +import GHC.Tc.Types +import GHC.Driver.Hooks +import qualified GHC.LanguageExtensions as LangExt +import GHC.SysTools.FileCleanup +import GHC.SysTools.Ar +import GHC.Settings +import GHC.Data.Bag ( unitBag ) +import GHC.Data.FastString ( mkFastString ) +import GHC.Iface.Make ( mkFullIface ) + +import GHC.Utils.Exception as Exception +import System.Directory +import System.FilePath +import System.IO +import Control.Monad +import qualified Control.Monad.Catch as MC (handle) +import Data.List ( isInfixOf, intercalate ) +import Data.Maybe +import Data.Version +import Data.Either ( partitionEithers ) + +import Data.Time ( UTCTime ) + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- | Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: HscEnv + -> FilePath -- ^ input filename + -> Maybe InputFileBuffer + -- ^ optional buffer to use instead of reading the input file + -> Maybe Phase -- ^ starting phase + -> IO (Either ErrorMessages (DynFlags, FilePath)) +preprocess hsc_env input_fn mb_input_buf mb_phase = + handleSourceError (\err -> return (Left (srcErrorMessages err))) $ + MC.handle handler $ + fmap Right $ do + MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) + (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) + Nothing + -- We keep the processed file for the whole session to save on + -- duplicated work in ghci. + (Temporary TFL_GhcSession) + Nothing{-no ModLocation-} + []{-no foreign objects-} + -- We stop before Hsc phase so we shouldn't generate an interface + MASSERT(isNothing mb_iface) + return (dflags, fp) + where + srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 + handler (ProgramError msg) = return $ Left $ unitBag $ + mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg + handler ex = throwGhcExceptionIO ex + +-- --------------------------------------------------------------------------- + +-- | Compile +-- +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. +-- +-- NB. No old interface can also mean that the source has changed. + +compileOne :: HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne = compileOne' Nothing (Just batchMsg) + +compileOne' :: Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne' m_tc_result mHscMessage + hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable + source_modified0 + = do + + debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) + + -- Run the pipeline up to codeGen (so everything up to, but not including, STG) + (status, plugin_dflags) <- hscIncrementalCompile + always_do_basic_recompilation_check + m_tc_result mHscMessage + hsc_env summary source_modified mb_old_iface (mod_index, nmods) + + let flags = hsc_dflags hsc_env0 + in do unless (gopt Opt_KeepHiFiles flags) $ + addFilesToClean flags TFL_CurrentModule $ + [ml_hi_file $ ms_location summary] + unless (gopt Opt_KeepOFiles flags) $ + addFilesToClean flags TFL_GhcSession $ + [ml_obj_file $ ms_location summary] + + -- Use an HscEnv with DynFlags updated with the plugin info (returned from + -- hscIncrementalCompile) + let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags } + + case (status, hsc_lang) of + (HscUpToDate iface hmi_details, _) -> + -- TODO recomp014 triggers this assert. What's going on?! + -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) + return $! HomeModInfo iface hmi_details mb_old_linkable + (HscNotGeneratingCode iface hmi_details, HscNothing) -> + let mb_linkable = if isHsBootOrSig src_flavour + then Nothing + -- TODO: Questionable. + else Just (LM (ms_hs_date summary) this_mod []) + in return $! HomeModInfo iface hmi_details mb_linkable + (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode" + (_, HscNothing) -> panic "compileOne HscNothing" + (HscUpdateBoot iface hmi_details, HscInterpreted) -> do + return $! HomeModInfo iface hmi_details Nothing + (HscUpdateBoot iface hmi_details, _) -> do + touchObjectFile dflags object_filename + return $! HomeModInfo iface hmi_details Nothing + (HscUpdateSig iface hmi_details, HscInterpreted) -> do + let !linkable = LM (ms_hs_date summary) this_mod [] + return $! HomeModInfo iface hmi_details (Just linkable) + (HscUpdateSig iface hmi_details, _) -> do + output_fn <- getOutputFilename next_phase + (Temporary TFL_CurrentModule) basename dflags + next_phase (Just location) + + -- #10660: Use the pipeline instead of calling + -- compileEmptyStub directly, so -dynamic-too gets + -- handled properly + _ <- runPipeline StopLn hsc_env' + (output_fn, + Nothing, + Just (HscOut src_flavour + mod_name (HscUpdateSig iface hmi_details))) + (Just basename) + Persistent + (Just location) + [] + o_time <- getModificationUTCTime object_filename + let !linkable = LM o_time this_mod [DotO object_filename] + return $! HomeModInfo iface hmi_details (Just linkable) + (HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do + -- In interpreted mode the regular codeGen backend is not run so we + -- generate a interface without codeGen info. + let hsc_env'' = hsc_env'{hsc_dflags=iface_dflags} + final_iface <- mkFullIface hsc_env'' partial_iface Nothing + -- Reconstruct the `ModDetails` from the just-constructed `ModIface` + -- See Note [ModDetails and --make mode] + hmi_details <- liftIO $ initModDetails hsc_env'' summary final_iface + liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary) + + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc spt_entries] + unlinked_time = ms_hs_date summary + -- Why do we use the timestamp of the source file here, + -- rather than the current time? This works better in + -- the case where the local clock is out of sync + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let !linkable = LM unlinked_time (ms_mod summary) + (hs_unlinked ++ stub_o) + return $! HomeModInfo final_iface hmi_details (Just linkable) + (HscRecomp{}, _) -> do + output_fn <- getOutputFilename next_phase + (Temporary TFL_CurrentModule) + basename dflags next_phase (Just location) + -- We're in --make mode: finish the compilation pipeline. + (_, _, Just iface) <- runPipeline StopLn hsc_env' + (output_fn, + Nothing, + Just (HscOut src_flavour mod_name status)) + (Just basename) + Persistent + (Just location) + [] + -- The object filename comes from the ModLocation + o_time <- getModificationUTCTime object_filename + let !linkable = LM o_time this_mod [DotO object_filename] + -- See Note [ModDetails and --make mode] + details <- initModDetails hsc_env' summary iface + return $! HomeModInfo iface details (Just linkable) + + where dflags0 = ms_hspp_opts summary + this_mod = ms_mod summary + location = ms_location summary + input_fn = expectJust "compile:hs" (ml_hs_file location) + input_fnpp = ms_hspp_file summary + mod_graph = hsc_mod_graph hsc_env0 + needsLinker = needsTemplateHaskellOrQQ mod_graph + isDynWay = any (== WayDyn) (ways dflags0) + isProfWay = any (== WayProf) (ways dflags0) + internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) + + src_flavour = ms_hsc_src summary + mod_name = ms_mod_name summary + next_phase = hscPostBackendPhase src_flavour hsc_lang + object_filename = ml_obj_file location + + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so + -- the linker can correctly load the object files. This isn't necessary + -- when using -fexternal-interpreter. + dflags1 = if hostIsDynamic && internalInterpreter && + not isDynWay && not isProfWay && needsLinker + then gopt_set dflags0 Opt_BuildDynamicToo + else dflags0 + + -- #16331 - when no "internal interpreter" is available but we + -- need to process some TemplateHaskell or QuasiQuotes, we automatically + -- turn on -fexternal-interpreter. + dflags2 = if not internalInterpreter && needsLinker + then gopt_set dflags1 Opt_ExternalInterpreter + else dflags1 + + basename = dropExtension input_fn + + -- We add the directory in which the .hs files resides) to the import + -- path. This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + current_dir = takeDirectory basename + old_paths = includePaths dflags2 + !prevailing_dflags = hsc_dflags hsc_env0 + dflags = + dflags2 { includePaths = addImplicitQuoteInclude old_paths [current_dir] + , log_action = log_action prevailing_dflags } + -- use the prevailing log_action / log_finaliser, + -- not the one cached in the summary. This is so + -- that we can change the log_action without having + -- to re-summarize all the source files. + hsc_env = hsc_env0 {hsc_dflags = dflags} + + -- Figure out what lang we're generating + hsc_lang = hscTarget dflags + + -- -fforce-recomp should also work with --make + force_recomp = gopt Opt_ForceRecomp dflags + source_modified + | force_recomp = SourceModified + | otherwise = source_modified0 + + always_do_basic_recompilation_check = case hsc_lang of + HscInterpreted -> True + _ -> False + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support), and cc files. + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeForeigns phase). +-- +-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files +-- from TH, that are then compiled and linked to the module. This is +-- useful to implement facilities such as inline-c. + +compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath +compileForeign _ RawObject object_file = return object_file +compileForeign hsc_env lang stub_c = do + let phase = case lang of + LangC -> Cc + LangCxx -> Ccxx + LangObjc -> Cobjc + LangObjcxx -> Cobjcxx + LangAsm -> As True -- allow CPP +#if __GLASGOW_HASKELL__ < 811 + RawObject -> panic "compileForeign: should be unreachable" +#endif + (_, stub_o, _) <- runPipeline StopLn hsc_env + (stub_c, Nothing, Just (RealPhase phase)) + Nothing (Temporary TFL_GhcSession) + Nothing{-no ModLocation-} + [] + return stub_o + +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c + +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () +compileEmptyStub dflags hsc_env basename location mod_name = do + -- To maintain the invariant that every Haskell file + -- compiles to object code, we make an empty (but + -- valid) stub object file for signatures. However, + -- we make sure this object file has a unique symbol, + -- so that ranlib on OS X doesn't complain, see + -- https://gitlab.haskell.org/ghc/ghc/issues/12673 + -- and https://github.com/haskell/cabal/issues/2257 + empty_stub <- newTempName dflags TFL_CurrentModule "c" + let src = text "int" <+> ppr (mkHomeModule dflags mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) + _ <- runPipeline StopLn hsc_env + (empty_stub, Nothing, Nothing) + (Just basename) + Persistent + (Just location) + [] + return () + +-- --------------------------------------------------------------------------- +-- Link +-- +-- Note [Dynamic linking on macOS] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Since macOS Sierra (10.14), the dynamic system linker enforces +-- a limit on the Load Commands. Specifically the Load Command Size +-- Limit is at 32K (32768). The Load Commands contain the install +-- name, dependencies, runpaths, and a few other commands. We however +-- only have control over the install name, dependencies and runpaths. +-- +-- The install name is the name by which this library will be +-- referenced. This is such that we do not need to bake in the full +-- absolute location of the library, and can move the library around. +-- +-- The dependency commands contain the install names from of referenced +-- libraries. Thus if a libraries install name is @rpath/libHS...dylib, +-- that will end up as the dependency. +-- +-- Finally we have the runpaths, which informs the linker about the +-- directories to search for the referenced dependencies. +-- +-- The system linker can do recursive linking, however using only the +-- direct dependencies conflicts with ghc's ability to inline across +-- packages, and as such would end up with unresolved symbols. +-- +-- Thus we will pass the full dependency closure to the linker, and then +-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs). +-- +-- We still need to add the relevant runpaths, for the dynamic linker to +-- lookup the referenced libraries though. The linker (ld64) does not +-- have any option to dead strip runpaths; which makes sense as runpaths +-- can be used for dependencies of dependencies as well. +-- +-- The solution we then take in GHC is to not pass any runpaths to the +-- linker at link time, but inject them after the linking. For this to +-- work we'll need to ask the linker to create enough space in the header +-- to add more runpaths after the linking (-headerpad 8000). +-- +-- After the library has been linked by $LD (usually ld64), we will use +-- otool to inspect the libraries left over after dead stripping, compute +-- the relevant runpaths, and inject them into the linked product using +-- the install_name_tool command. +-- +-- This strategy should produce the smallest possible set of load commands +-- while still retaining some form of relocatability via runpaths. +-- +-- The only way I can see to reduce the load command size further would be +-- by shortening the library names, or start putting libraries into the same +-- folders, such that one runpath would be sufficient for multiple/all +-- libraries. +link :: GhcLink -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +link ghcLink dflags + = lookupHook linkHook l dflags ghcLink dflags + where + l LinkInMemory _ _ _ + = if platformMisc_ghcWithInterpreter $ platformMisc dflags + then -- Not Linking...(demand linker will do the job) + return Succeeded + else panicBadLink LinkInMemory + + l NoLink _ _ _ + = return Succeeded + + l LinkBinary dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkStaticLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkDynLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) + +link' :: DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +link' dflags batch_attempt_linking hpt + | batch_attempt_linking + = do + let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + home_mod_infos = eltsHpt hpt + + -- the packages we depend on + pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos + + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos + + debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + exe_file = exeFileName staticLink dflags + + linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps + + if not (gopt Opt_ForceRecomp dflags) && not linking_needed + then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") + return Succeeded + else do + + compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") + + -- Don't showPass in Batch mode; doLink will do that for us. + let link = case ghcLink dflags of + LinkBinary -> linkBinary + LinkStaticLib -> linkStaticLib + LinkDynLib -> linkDynLibCheck + other -> panicBadLink other + link dflags obj_files pkg_deps + + debugTraceMsg dflags 3 (text "link: done") + + -- linkBinary only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + + +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool +linkingNeeded dflags staticLink linkables pkg_deps = do + -- if the modification time on the executable is later than the + -- modification times on all of the objects and libraries, then omit + -- linking (unless the -fforce-recomp flag was given). + let exe_file = exeFileName staticLink dflags + e_exe_time <- tryIO $ getModificationUTCTime exe_file + case e_exe_time of + Left _ -> return True + Right t -> do + -- first check object files and extra_ld_inputs + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs + let (errs,extra_times) = partitionEithers e_extra_times + let obj_times = map linkableTime linkables ++ extra_times + if not (null errs) || any (t <) obj_times + then return True + else do + + -- next, check libraries. XXX this only checks Haskell libraries, + -- not extra_libraries or -l things from the command line. + let pkgstate = unitState dflags + let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib) + | Just c <- map (lookupUnitId pkgstate) pkg_deps, + lib <- packageHsLibs dflags c ] + + pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs + if any isNothing pkg_libfiles then return True else do + e_lib_times <- mapM (tryIO . getModificationUTCTime) + (catMaybes pkg_libfiles) + let (lib_errs,lib_times) = partitionEithers e_lib_times + if not (null lib_errs) || any (t <) lib_times + then return True + else checkLinkInfo dflags pkg_deps exe_file + +findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) +findHSLib dflags dirs lib = do + let batch_lib_file = if WayDyn `notElem` ways dflags + then "lib" ++ lib <.> "a" + else mkSOName (targetPlatform dflags) lib + found <- filterM doesFileExist (map ( batch_lib_file) dirs) + case found of + [] -> return Nothing + (x:_) -> return (Just x) + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () +oneShot hsc_env stop_phase srcs = do + o_files <- mapM (compileFile hsc_env stop_phase) srcs + doLink (hsc_dflags hsc_env) stop_phase o_files + +compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath +compileFile hsc_env stop_phase (src, mb_phase) = do + exists <- doesFileExist src + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + + let + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + -- If we are doing -fno-code, then act as if the output is + -- 'Temporary'. This stops GHC trying to copy files to their + -- final location. + | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule + | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + + ( _, out_file, _) <- runPipeline stop_phase hsc_env + (src, Nothing, fmap RealPhase mb_phase) + Nothing + output + Nothing{-no ModLocation-} [] + return out_file + + +doLink :: DynFlags -> Phase -> [FilePath] -> IO () +doLink dflags stop_phase o_files + | not (isStopLn stop_phase) + = return () -- We stopped before the linking phase + + | otherwise + = case ghcLink dflags of + NoLink -> return () + LinkBinary -> linkBinary dflags o_files [] + LinkStaticLib -> linkStaticLib dflags o_files [] + LinkDynLib -> linkDynLibCheck dflags o_files [] + other -> panicBadLink other + + +-- --------------------------------------------------------------------------- + +-- | Run a compilation pipeline, consisting of multiple phases. +-- +-- This is the interface to the compilation pipeline, which runs +-- a series of compilation steps on a single source file, specifying +-- at which stage to stop. +-- +-- The DynFlags can be modified by phases in the pipeline (eg. by +-- OPTIONS_GHC pragmas), and the changes affect later phases in the +-- pipeline. +runPipeline + :: Phase -- ^ When to stop + -> HscEnv -- ^ Compilation environment + -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus) + -- ^ Pipeline input file name, optional + -- buffer and maybe -x suffix + -> Maybe FilePath -- ^ original basename (if different from ^^^) + -> PipelineOutput -- ^ Output filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> [FilePath] -- ^ foreign objects + -> IO (DynFlags, FilePath, Maybe ModIface) + -- ^ (final flags, output filename, interface) +runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) + mb_basename output maybe_loc foreign_os + + = do let + dflags0 = hsc_dflags hsc_env0 + + -- Decide where dump files should go based on the pipeline output + dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + hsc_env = hsc_env0 {hsc_dflags = dflags} + + (input_basename, suffix) = splitExtension input_fn + suffix' = drop 1 suffix -- strip off the . + basename | Just b <- mb_basename = b + | otherwise = input_basename + + -- If we were given a -x flag, then use that phase to start from + start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase + + isHaskell (RealPhase (Unlit _)) = True + isHaskell (RealPhase (Cpp _)) = True + isHaskell (RealPhase (HsPp _)) = True + isHaskell (RealPhase (Hsc _)) = True + isHaskell (HscOut {}) = True + isHaskell _ = False + + isHaskellishFile = isHaskell start_phase + + env = PipeEnv{ stop_phase, + src_filename = input_fn, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + when (isBackpackishSuffix suffix') $ + throwGhcExceptionIO (UsageError + ("use --backpack to process " ++ input_fn)) + + -- We want to catch cases of "you can't get there from here" before + -- we start the pipeline, because otherwise it will just run off the + -- end. + let happensBefore' = happensBefore (targetPlatform dflags) + case start_phase of + RealPhase start_phase' -> + -- See Note [Partial ordering on phases] + -- Not the same as: (stop_phase `happensBefore` start_phase') + when (not (start_phase' `happensBefore'` stop_phase || + start_phase' `eqPhase` stop_phase)) $ + throwGhcExceptionIO (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + HscOut {} -> return () + + -- Write input buffer to temp file if requested + input_fn' <- case (start_phase, mb_input_buf) of + (RealPhase real_start_phase, Just input_buf) -> do + let suffix = phaseInputExt real_start_phase + fn <- newTempName dflags TFL_CurrentModule suffix + hdl <- openBinaryFile fn WriteMode + -- Add a LINE pragma so reported source locations will + -- mention the real input file, not this temp file. + hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" + hPutStringBuffer hdl input_buf + hClose hdl + return fn + (_, _) -> return input_fn + + debugTraceMsg dflags 4 (text "Running the pipeline") + r <- runPipeline' start_phase hsc_env env input_fn' + maybe_loc foreign_os + + -- If we are compiling a Haskell module, and doing + -- -dynamic-too, but couldn't do the -dynamic-too fast + -- path, then rerun the pipeline for the dyn way + let dflags = hsc_dflags hsc_env + -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) + when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do + when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do + debugTraceMsg dflags 4 + (text "Running the pipeline again for -dynamic-too") + let dflags' = dynamicTooMkDynamicDynFlags dflags + hsc_env' <- newHscEnv dflags' + _ <- runPipeline' start_phase hsc_env' env input_fn' + maybe_loc foreign_os + return () + return r + +runPipeline' + :: PhasePlus -- ^ When to start + -> HscEnv -- ^ Compilation environment + -> PipeEnv + -> FilePath -- ^ Input filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> [FilePath] -- ^ foreign objects, if we have one + -> IO (DynFlags, FilePath, Maybe ModIface) + -- ^ (final flags, output filename, interface) +runPipeline' start_phase hsc_env env input_fn + maybe_loc foreign_os + = do + -- Execute the pipeline... + let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing } + (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state + return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state) + +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + env <- getPipeEnv + dflags <- getDynFlags + -- See Note [Partial ordering on phases] + let happensBefore' = happensBefore (targetPlatform dflags) + stopPhase = stop_phase env + case phase of + RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done + -> -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file, remembering to prepend a {-# LINE #-} pragma so that + -- further compilation stages can tell what the original filename was. + case output_spec env of + Temporary _ -> + return input_fn + output -> + do pst <- getPipeState + final_fn <- liftIO $ getOutputFilename + stopPhase output (src_basename env) + dflags stopPhase (maybe_loc pst) + when (final_fn /= input_fn) $ do + let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") + line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") + liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn + return final_fn + + + | not (realPhase `happensBefore'` stopPhase) + -- Something has gone wrong. We'll try to cover all the cases when + -- this could happen, so if we reach here it is a panic. + -- eg. it might happen if the -C flag is used on a source file that + -- has {-# OPTIONS -fasm #-}. + -> panic ("pipeLoop: at phase " ++ show realPhase ++ + " but I wanted to stop at phase " ++ show stopPhase) + + _ + -> do liftIO $ debugTraceMsg dflags 4 + (text "Running phase" <+> ppr phase) + (next_phase, output_fn) <- runHookedPhase phase input_fn dflags + case phase of + HscOut {} -> do + -- We don't pass Opt_BuildDynamicToo to the backend + -- in DynFlags. + -- Instead it's run twice with flags accordingly set + -- per run. + let noDynToo = pipeLoop next_phase output_fn + let dynToo = do + setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo + r <- pipeLoop next_phase output_fn + setDynFlags $ dynamicTooMkDynamicDynFlags dflags + -- TODO shouldn't ignore result: + _ <- pipeLoop phase input_fn + return r + ifGeneratingDynamicToo dflags dynToo noDynToo + _ -> pipeLoop next_phase output_fn + +runHookedPhase :: PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath) +runHookedPhase pp input dflags = + lookupHook runPhaseHook runPhase dflags pp input dflags + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. + +-- | Computes the next output filename after we run @next_phase@. +-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad +-- (which specifies all of the ambient information.) +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + liftIO $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc + +-- | Computes the next output filename for something in the compilation +-- pipeline. This is controlled by several variables: +-- +-- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This +-- is used to tell if we're in the last phase or not, because +-- in that case flags like @-o@ may be important. +-- 2. 'PipelineOutput': is this intended to be a 'Temporary' or +-- 'Persistent' build output? Temporary files just go in +-- a fresh temporary name. +-- 3. 'String': what was the basename of the original input file? +-- 4. 'DynFlags': the obvious thing +-- 5. 'Phase': the phase we want to determine the output filename of. +-- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're +-- compiling; this can be used to override the default output +-- of an object file. (TODO: do we actually need this?) +getOutputFilename + :: Phase -> PipelineOutput -> String + -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath +getOutputFilename stop_phase output basename dflags next_phase maybe_location + | is_last_phase, Persistent <- output = persistent_fn + | is_last_phase, SpecificFile <- output = case outputFile dflags of + Just f -> return f + Nothing -> + panic "SpecificFile: No filename" + | keep_this_output = persistent_fn + | Temporary lifetime <- output = newTempName dflags lifetime suffix + | otherwise = newTempName dflags TFL_CurrentModule + suffix + where + hcsuf = hcSuf dflags + odir = objectDir dflags + osuf = objectSuf dflags + keep_hc = gopt Opt_KeepHcFiles dflags + keep_hscpp = gopt Opt_KeepHscppFiles dflags + keep_s = gopt Opt_KeepSFiles dflags + keep_bc = gopt Opt_KeepLlvmFiles dflags + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeForeign = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + As _ | keep_s -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + HsPp _ | keep_hscpp -> True -- See #10869 + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename <.> suffix + + odir_persistent + | Just loc <- maybe_location = ml_obj_file loc + | Just d <- odir = d persistent + | otherwise = persistent + + +-- | LLVM Options. These are flags to be passed to opt and llc, to ensure +-- consistency we list them in pairs, so that they form groups. +llvmOptions :: DynFlags + -> [(String, String)] -- ^ pairs of (opt, llc) arguments +llvmOptions dflags = + [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] + ++ [("-relocation-model=" ++ rmodel + ,"-relocation-model=" ++ rmodel) | not (null rmodel)] + ++ [("-stack-alignment=" ++ (show align) + ,"-stack-alignment=" ++ (show align)) | align > 0 ] + + -- Additional llc flags + ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) + , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] + ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] + + where target = platformMisc_llvmTarget $ platformMisc dflags + Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags) + + -- Relocation models + rmodel | gopt Opt_PIC dflags = "pic" + | positionIndependent dflags = "pic" + | WayDyn `elem` ways dflags = "dynamic-no-pic" + | otherwise = "static" + + align :: Int + align = case platformArch (targetPlatform dflags) of + ArchX86_64 | isAvxEnabled dflags -> 32 + _ -> 0 + + attrs :: String + attrs = intercalate "," $ mattr + ++ ["+sse42" | isSse4_2Enabled dflags ] + ++ ["+sse2" | isSse2Enabled dflags ] + ++ ["+sse" | isSseEnabled dflags ] + ++ ["+avx512f" | isAvx512fEnabled dflags ] + ++ ["+avx2" | isAvx2Enabled dflags ] + ++ ["+avx" | isAvxEnabled dflags ] + ++ ["+avx512cd"| isAvx512cdEnabled dflags ] + ++ ["+avx512er"| isAvx512erEnabled dflags ] + ++ ["+avx512pf"| isAvx512pfEnabled dflags ] + ++ ["+bmi" | isBmiEnabled dflags ] + ++ ["+bmi2" | isBmi2Enabled dflags ] + +-- ----------------------------------------------------------------------------- +-- | Each phase in the pipeline returns the next phase to execute, and the +-- name of the file in which the output was placed. +-- +-- We must do things dynamically this way, because we often don't know +-- what the rest of the phases will be until part-way through the +-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning +-- of a source file can change the latter stages of the pipeline from +-- taking the LLVM route to using the native code generator. +-- +runPhase :: PhasePlus -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (PhasePlus, -- next phase to run + FilePath) -- output filename + + -- Invariant: the output filename always contains the output + -- Interesting case: Hsc when there is no recompilation to do + -- Then the output filename is still a .o file + + +------------------------------------------------------------------------------- +-- Unlit phase + +runPhase (RealPhase (Unlit sf)) input_fn dflags + = do + output_fn <- phaseOutputFilename (Cpp sf) + + let flags = [ -- The -h option passes the file name for unlit to + -- put in a #line directive + GHC.SysTools.Option "-h" + -- See Note [Don't normalise input filenames]. + , GHC.SysTools.Option $ escape input_fn + , GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.FileOption "" output_fn + ] + + liftIO $ GHC.SysTools.runUnlit dflags flags + + return (RealPhase (Cpp sf), output_fn) + where + -- escape the characters \, ", and ', but don't try to escape + -- Unicode or anything else (so we don't use Util.charToC + -- here). If we get this wrong, then in + -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in + -- a SrcLoc is the same as the source filenaame, the two will + -- look bogusly different. See test: + -- libraries/hpc/tests/function/subdir/tough2.hs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] + +------------------------------------------------------------------------------- +-- Cpp phase : (a) gets OPTIONS out of file +-- (b) runs cpp if necessary + +runPhase (RealPhase (Cpp sf)) input_fn dflags0 + = do + src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + + if not (xopt LangExt.Cpp dflags1) then do + -- we have to be careful to emit warnings only once. + unless (gopt Opt_Pp dflags1) $ + liftIO $ handleFlagWarnings dflags1 warns + + -- no need to preprocess CPP, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (HsPp sf), input_fn) + else do + output_fn <- phaseOutputFilename (HsPp sf) + liftIO $ doCpp dflags1 True{-raw-} + input_fn output_fn + -- re-read the pragmas now that we've preprocessed the file + -- See #2464,#3457 + src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn + (dflags2, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + liftIO $ checkProcessArgsResult dflags2 unhandled_flags + unless (gopt Opt_Pp dflags2) $ + liftIO $ handleFlagWarnings dflags2 warns + -- the HsPp pass below will emit warnings + + setDynFlags dflags2 + + return (RealPhase (HsPp sf), output_fn) + +------------------------------------------------------------------------------- +-- HsPp phase + +runPhase (RealPhase (HsPp sf)) input_fn dflags + = do + if not (gopt Opt_Pp dflags) then + -- no need to preprocess, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (Hsc sf), input_fn) + else do + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + liftIO $ GHC.SysTools.runPp dflags + ( [ GHC.SysTools.Option orig_fn + , GHC.SysTools.Option input_fn + , GHC.SysTools.FileOption "" output_fn + ] + ) + + -- re-read pragmas now that we've parsed the file (see #3674) + src_opts <- liftIO $ getOptionsFromFile dflags output_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ handleFlagWarnings dflags1 warns + + return (RealPhase (Hsc sf), output_fn) + +----------------------------------------------------------------------------- +-- Hsc phase + +-- Compilation of a single module, in "legacy" mode (_not_ under +-- the direction of the compilation manager). +runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 + = do -- normal Hsc mode, not mkdependHS + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv + + -- we add the current directory (i.e. the directory in which + -- the .hs files resides) to the include path, since this is + -- what gcc does, and it's probably what you want. + let current_dir = takeDirectory basename + new_includes = addImplicitQuoteInclude paths [current_dir] + paths = includePaths dflags0 + dflags = dflags0 { includePaths = new_includes } + + setDynFlags dflags + + -- gather the imports and module name + (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do + do + buf <- hGetStringBuffer input_fn + eimps <- getImports dflags buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors errs + Right (src_imps,imps,L _ mod_name) -> return + (Just buf, mod_name, imps, src_imps) + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + location <- getLocation src_flavour mod_name + + let o_file = ml_obj_file location -- The real object file + hi_file = ml_hi_file location + hie_file = ml_hie_file location + dest_file | writeInterfaceOnlyMode dflags + = hi_file + | otherwise + = o_file + + -- Figure out if the source has changed, for recompilation avoidance. + -- + -- Setting source_unchanged to True means that M.o (or M.hie) seems + -- to be up to date wrt M.hs; so no need to recompile unless imports have + -- changed (which the compiler itself figures out). + -- Setting source_unchanged to False tells the compiler that M.o is out of + -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) + + source_unchanged <- liftIO $ + if not (isStopLn stop) + -- SourceModified unconditionally if + -- (a) recompilation checker is off, or + -- (b) we aren't going all the way to .o file (e.g. ghc -S) + then return SourceModified + -- Otherwise look at file modification dates + else do dest_file_mod <- sourceModified dest_file src_timestamp + hie_file_mod <- if gopt Opt_WriteHie dflags + then sourceModified hie_file + src_timestamp + else pure False + if dest_file_mod || hie_file_mod + then return SourceModified + else return SourceUnmodified + + PipeState{hsc_env=hsc_env'} <- getPipeState + + -- Tell the finder cache about this module + mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location + + -- Make the ModSummary to hand to hscMain + let + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location, + ms_hs_date = src_timestamp, + ms_obj_date = Nothing, + ms_parsed_mod = Nothing, + ms_iface_date = Nothing, + ms_hie_date = Nothing, + ms_textual_imps = imps, + ms_srcimps = src_imps } + + -- run the compiler! + let msg hsc_env _ what _ = oneShotMsg hsc_env what + (result, plugin_dflags) <- + liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' + mod_summary source_unchanged Nothing (1,1) + + -- In the rest of the pipeline use the dflags with plugin info + setDynFlags plugin_dflags + + return (HscOut src_flavour mod_name result, + panic "HscOut doesn't have an input filename") + +runPhase (HscOut src_flavour mod_name result) _ dflags = do + location <- getLocation src_flavour mod_name + setModLocation location + + let o_file = ml_obj_file location -- The real object file + hsc_lang = hscTarget dflags + next_phase = hscPostBackendPhase src_flavour hsc_lang + + case result of + HscNotGeneratingCode _ _ -> + return (RealPhase StopLn, + panic "No output filename from Hsc when no-code") + HscUpToDate _ _ -> + do liftIO $ touchObjectFile dflags o_file + -- The .o file must have a later modification date + -- than the source file (else we wouldn't get Nothing) + -- but we touch it anyway, to keep 'make' happy (we think). + return (RealPhase StopLn, o_file) + HscUpdateBoot _ _ -> + do -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + liftIO $ touchObjectFile dflags o_file + return (RealPhase StopLn, o_file) + HscUpdateSig _ _ -> + do -- We need to create a REAL but empty .o file + -- because we are going to attempt to put it in a library + PipeState{hsc_env=hsc_env'} <- getPipeState + let input_fn = expectJust "runPhase" (ml_hs_file location) + basename = dropExtension input_fn + liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name + return (RealPhase StopLn, o_file) + HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags } + -> do output_fn <- phaseOutputFilename next_phase + + PipeState{hsc_env=hsc_env'} <- getPipeState + + (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $ + hscGenHardCode hsc_env' cgguts mod_location output_fn + + final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos)) + setIface final_iface + + -- See Note [Writing interface files] + let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo + liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location + + stub_o <- liftIO (mapM (compileStub hsc_env') mStub) + foreign_os <- liftIO $ + mapM (uncurry (compileForeign hsc_env')) foreign_files + setForeignOs (maybe [] return stub_o ++ foreign_os) + + return (RealPhase next_phase, outputFilename) + +----------------------------------------------------------------------------- +-- Cmm phase + +runPhase (RealPhase CmmCpp) input_fn dflags + = do output_fn <- phaseOutputFilename Cmm + liftIO $ doCpp dflags False{-not raw-} + input_fn output_fn + return (RealPhase Cmm, output_fn) + +runPhase (RealPhase Cmm) input_fn dflags + = do let hsc_lang = hscTarget dflags + let next_phase = hscPostBackendPhase HsSrcFile hsc_lang + output_fn <- phaseOutputFilename next_phase + PipeState{hsc_env} <- getPipeState + liftIO $ hscCompileCmmFile hsc_env input_fn output_fn + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- Cc phase + +runPhase (RealPhase cc_phase) input_fn dflags + | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] + = do + let platform = targetPlatform dflags + hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = includePaths dflags + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return [] + + -- add package include paths even if we're just compiling .c + -- files; this is the Value Add(TM) that using ghc instead of + -- gcc gives you :) + pkg_include_dirs <- liftIO $ getUnitIncludePath dflags pkgs + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths ++ + includePathsQuoteImplicit cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + -- pass -D or -optP to preprocessor when compiling foreign C files + -- (#16737). Doing it in this way is simpler and also enable the C + -- compiler to perform preprocessing and parsing in a single pass, + -- but it may introduce inconsistency if a different pgm_P is specified. + let more_preprocessor_opts = concat + [ ["-Xpreprocessor", i] + | not hcc + , i <- getOpts dflags opt_P + ] + + let gcc_extra_viac_flags = extraGccViaCFlags dflags + let pic_c_flags = picCCOpts dflags + + let verbFlags = getVerbFlags dflags + + -- cc-options are not passed when compiling .hc files. Our + -- hc code doesn't not #include any header files anyway, so these + -- options aren't necessary. + pkg_extra_cc_opts <- liftIO $ + if hcc + then return [] + else getUnitExtraCcOpts dflags pkgs + + framework_paths <- + if platformUsesFrameworks platform + then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath dflags pkgs + let cmdlineFrameworkPaths = frameworkPaths dflags + return $ map ("-F"++) + (cmdlineFrameworkPaths ++ pkgFrameworkPaths) + else return [] + + let cc_opt | optLevel dflags >= 2 = [ "-O2" ] + | optLevel dflags >= 1 = [ "-O" ] + | otherwise = [] + + -- Decide next phase + let next_phase = As False + output_fn <- phaseOutputFilename next_phase + + let + more_hcc_opts = + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if platformArch platform == ArchX86 && + not (gopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ + + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + ghcVersionH <- liftIO $ getGhcVersionPathName dflags + + liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ++ map GHC.SysTools.Option ( + pic_c_flags + + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (if platformOS platform == OSMinGW32 && + homeUnitId dflags == baseUnitId + then [ "-DCOMPILING_BASE_PACKAGE" ] + else []) + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. See #2872, commit + -- 5bd3072ac30216a505151601884ac88bf404c9f2 + ++ (if platformArch platform == ArchSPARC + then ["-mcpu=v9"] + else []) + + -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. + ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) + then ["-Wimplicit"] + else []) + + ++ (if hcc + then gcc_extra_viac_flags ++ more_hcc_opts + else []) + ++ verbFlags + ++ [ "-S" ] + ++ cc_opt + ++ [ "-include", ghcVersionH ] + ++ framework_paths + ++ include_paths + ++ more_preprocessor_opts + ++ pkg_extra_cc_opts + )) + + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- As, SpitAs phase : Assembler + +-- This is for calling the assembler on a regular assembly file +runPhase (RealPhase (As with_cpp)) input_fn dflags + = do + -- LLVM from version 3.0 onwards doesn't support the OS X system + -- assembler, so we use clang as the assembler instead. (#5636) + let as_prog | hscTarget dflags == HscLlvm && + platformOS (targetPlatform dflags) == OSDarwin + = GHC.SysTools.runClang + | otherwise = GHC.SysTools.runAs + + let cmdline_include_paths = includePaths dflags + let pic_c_flags = picCCOpts dflags + + next_phase <- maybeMergeForeign + output_fn <- phaseOutputFilename next_phase + + -- we create directories for the object file, because it + -- might be a hierarchical module. + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + + ccInfo <- liftIO $ getCompilerInfo dflags + let global_includes = [ GHC.SysTools.Option ("-I" ++ p) + | p <- includePathsGlobal cmdline_include_paths ] + let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) + | p <- includePathsQuote cmdline_include_paths ++ + includePathsQuoteImplicit cmdline_include_paths] + let runAssembler inputFilename outputFilename + = liftIO $ do + withAtomicRename outputFilename $ \temp_outputFilename -> do + as_prog + dflags + (local_includes ++ global_includes + -- See Note [-fPIC for assembler] + ++ map GHC.SysTools.Option pic_c_flags + -- See Note [Produce big objects on Windows] + ++ [ GHC.SysTools.Option "-Wa,-mbig-obj" + | platformOS (targetPlatform dflags) == OSMinGW32 + , not $ target32Bit (targetPlatform dflags) + ] + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction so we have to make sure that the assembler accepts the + -- instruction set. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [GHC.SysTools.Option "-mcpu=v9"] + else []) + ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [GHC.SysTools.Option "-Qunused-arguments"] + else []) + ++ [ GHC.SysTools.Option "-x" + , if with_cpp + then GHC.SysTools.Option "assembler-with-cpp" + else GHC.SysTools.Option "assembler" + , GHC.SysTools.Option "-c" + , GHC.SysTools.FileOption "" inputFilename + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" temp_outputFilename + ]) + + liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") + runAssembler input_fn output_fn + + return (RealPhase next_phase, output_fn) + + +----------------------------------------------------------------------------- +-- LlvmOpt phase +runPhase (RealPhase LlvmOpt) input_fn dflags + = do + output_fn <- phaseOutputFilename LlvmLlc + + liftIO $ GHC.SysTools.runLlvmOpt dflags + ( optFlag + ++ defaultOptions ++ + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn] + ) + + return (RealPhase LlvmLlc, output_fn) + where + -- we always (unless -optlo specified) run Opt since we rely on it to + -- fix up some pretty big deficiencies in the code we generate + optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] + llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of + Just passes -> passes + Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " + ++ "is missing passes for level " + ++ show optIdx) + + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null (getOpts dflags opt_lo) + then map GHC.SysTools.Option $ words llvmOpts + else [] + + defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst + $ unzip (llvmOptions dflags) + +----------------------------------------------------------------------------- +-- LlvmLlc phase + +runPhase (RealPhase LlvmLlc) input_fn dflags + = do + next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + | gopt Opt_NoLlvmMangler dflags -> return (As False) + | otherwise -> return LlvmMangle + + output_fn <- phaseOutputFilename next_phase + + liftIO $ GHC.SysTools.runLlvmLlc dflags + ( optFlag + ++ defaultOptions + ++ [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ) + + return (RealPhase next_phase, output_fn) + where + -- Note [Clamping of llc optimizations] + -- + -- See #13724 + -- + -- we clamp the llc optimization between [1,2]. This is because passing -O0 + -- to llc 3.9 or llc 4.0, the naive register allocator can fail with + -- + -- Error while trying to spill R1 from class GPR: Cannot scavenge register + -- without an emergency spill slot! + -- + -- Observed at least with target 'arm-unknown-linux-gnueabihf'. + -- + -- + -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile + -- rts/HeapStackCheck.cmm + -- + -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40 + -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358 + -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26 + -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876 + -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699 + -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381 + -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457 + -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20 + -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134 + -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498 + -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67 + -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920 + -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133 + -- 13 llc 0x000000010195bf0b main + 491 + -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1 + -- Stack dump: + -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'. + -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"' + -- + -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa + -- + llvmOpts = case optLevel dflags of + 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. + 1 -> "-O1" + _ -> "-O2" + + optFlag = if null (getOpts dflags opt_lc) + then map GHC.SysTools.Option $ words llvmOpts + else [] + + defaultOptions = map GHC.SysTools.Option . concatMap words . snd + $ unzip (llvmOptions dflags) + + +----------------------------------------------------------------------------- +-- LlvmMangle phase + +runPhase (RealPhase LlvmMangle) input_fn dflags + = do + let next_phase = As False + output_fn <- phaseOutputFilename next_phase + liftIO $ llvmFixupAsm dflags input_fn output_fn + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- merge in stub objects + +runPhase (RealPhase MergeForeign) input_fn dflags + = do + PipeState{foreign_os} <- getPipeState + output_fn <- phaseOutputFilename StopLn + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + if null foreign_os + then panic "runPhase(MergeForeign): no foreign objects" + else do + liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn + return (RealPhase StopLn, output_fn) + +-- warning suppression +runPhase (RealPhase other) _input_fn _dflags = + panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeForeign :: CompPipeline Phase +maybeMergeForeign + = do + PipeState{foreign_os} <- getPipeState + if null foreign_os then return StopLn else return MergeForeign + +getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation +getLocation src_flavour mod_name = do + dflags <- getDynFlags + + PipeEnv{ src_basename=basename, + src_suffix=suff } <- getPipeEnv + PipeState { maybe_loc=maybe_loc} <- getPipeState + case maybe_loc of + -- Build a ModLocation to pass to hscMain. + -- The source filename is rather irrelevant by now, but it's used + -- by hscMain for messages. hscMain also needs + -- the .hi and .o filenames. If we already have a ModLocation + -- then simply update the extensions of the interface and object + -- files to match the DynFlags, otherwise use the logic in Finder. + Just l -> return $ l + { ml_hs_file = Just $ basename <.> suff + , ml_hi_file = ml_hi_file l -<.> hiSuf dflags + , ml_obj_file = ml_obj_file l -<.> objectSuf dflags + } + _ -> do + location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff + + -- Boot-ify it if necessary + let location2 + | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile + -- above + let expl_o_file = outputFile dflags + location4 | Just ofile <- expl_o_file + , isNoLink (ghcLink dflags) + = location3 { ml_obj_file = ofile } + | otherwise = location3 + return location4 + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [UnitId] +getHCFilePackages filename = + Exception.bracket (openFile filename ReadMode) hClose $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToUnitId (words rest)) + _other -> + return [] + +----------------------------------------------------------------------------- +-- Static linking, of .o files + +-- The list of packages passed to link is the list of packages on +-- which this program depends, as discovered by the compilation +-- manager. It is combined with the list of packages that the user +-- specifies on the command line with -package flags. +-- +-- In one-shot linking mode, we can't discover the package +-- dependencies (because we haven't actually done any compilation or +-- read any interface files), so the user must explicitly specify all +-- the packages. + +{- +Note [-Xlinker -rpath vs -Wl,-rpath] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-Wl takes a comma-separated list of options which in the case of +-Wl,-rpath -Wl,some,path,with,commas parses the path with commas +as separate options. +Buck, the build system, produces paths with commas in them. + +-Xlinker doesn't have this disadvantage and as far as I can tell +it is supported by both gcc and clang. Anecdotally nvcc supports +-Xlinker, but not -Wl. +-} + +linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO () +linkBinary = linkBinary' False + +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink dflags o_files dep_units = do + let platform = targetPlatform dflags + toolSettings' = toolSettings dflags + verbFlags = getVerbFlags dflags + output_fn = exeFileName staticLink dflags + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d output_fn) + pkg_lib_paths <- getUnitLibraryPath dflags dep_units + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + WayDyn `elem` ways dflags + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "$ORIGIN" + (l `makeRelativeTo` full_output_fn) + else l + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + rpath = if useXLinkerRPath dflags (platformOS platform) + then ["-Xlinker", "-rpath", "-Xlinker", libpath] + else [] + -- Solaris 11's linker does not support -rpath-link option. It silently + -- ignores it and then complains about next option which is -l as being a directory and not expected object file, E.g + -- ld: elf error: file + -- /tmp/ghc-src/libraries/base/dist-install/build: + -- elf_begin: I/O error: region read: Is a directory + rpathlink = if (platformOS platform) == OSSolaris2 + then [] + else ["-Xlinker", "-rpath-link", "-Xlinker", l] + in ["-L" ++ l] ++ rpathlink ++ rpath + | osMachOTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + WayDyn `elem` ways dflags && + useXLinkerRPath dflags (platformOS platform) + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "@loader_path" + (l `makeRelativeTo` full_output_fn) + else l + in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] + | otherwise = ["-L" ++ l] + + pkg_lib_path_opts <- + if gopt Opt_SingleLibFolder dflags + then do + libs <- getLibs dflags dep_units + tmpDir <- newTempDir dflags + sequence_ [ copyFile lib (tmpDir basename) + | (lib, basename) <- libs] + return [ "-L" ++ tmpDir ] + else pure pkg_lib_path_opts + + let + dead_strip + | gopt Opt_WholeArchiveHsLibs dflags = [] + | otherwise = if osSubsectionsViaSymbols (platformOS platform) + then ["-Wl,-dead_strip"] + else [] + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units + + let + (pre_hs_libs, post_hs_libs) + | gopt Opt_WholeArchiveHsLibs dflags + = if platformOS platform == OSDarwin + then (["-Wl,-all_load"], []) + -- OS X does not have a flag to turn off -all_load + else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) + | otherwise + = ([],[]) + + pkg_link_opts <- do + (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units + return $ if staticLink + then package_hs_libs -- If building an executable really means making a static + -- library (e.g. iOS), then we only keep the -l options for + -- HS packages, because libtool doesn't accept other options. + -- In the case of iOS these need to be added by hand to the + -- final link in Xcode. + else other_flags ++ dead_strip + ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs + ++ extra_libs + -- -Wl,-u, contained in other_flags + -- needs to be put before -l, + -- otherwise Solaris linker fails linking + -- a binary with unresolved symbols in RTS + -- which are defined in base package + -- the reason for this is a note in ld(1) about + -- '-u' option: "The placement of this option + -- on the command line is significant. + -- This option must be placed before the library + -- that defines the symbol." + + -- frameworks + pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units + let framework_opts = getFrameworkOpts dflags platform + + -- probably _stub.o files + let extra_ld_inputs = ldInputs dflags + + rc_objs <- maybeCreateManifest dflags output_fn + + let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args + | platformOS platform == OSDarwin + = GHC.SysTools.runLink dflags args >> GHC.SysTools.runInjectRPaths dflags pkg_lib_paths output_fn + | otherwise + = GHC.SysTools.runLink dflags args + + link dflags ( + map GHC.SysTools.Option verbFlags + ++ [ GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ++ libmLinkOpts + ++ map GHC.SysTools.Option ( + [] + + -- See Note [No PIE when linking] + ++ picCCOpts dflags + + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_compact_unwind' + -- C++/Objective-C exceptions cannot use optimised + -- stack unwinding code. The optimised form is the + -- default in Xcode 4 on at least x86_64, and + -- without this flag we're also seeing warnings + -- like + -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog + -- on x86. + ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' && + not staticLink && + (platformOS platform == OSDarwin) && + case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchARM {} -> True + ArchAArch64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- '-Wl,-read_only_relocs,suppress' + -- ld gives loads of warnings like: + -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure + -- when linking any program. We're not sure + -- whether this is something we ought to fix, but + -- for now this flags silences them. + ++ (if platformOS platform == OSDarwin && + platformArch platform == ArchX86 && + not staticLink + then ["-Wl,-read_only_relocs,suppress"] + else []) + + ++ (if toolSettings_ldIsGnuLd toolSettings' && + not (gopt Opt_WholeArchiveHsLibs dflags) + then ["-Wl,--gc-sections"] + else []) + + ++ o_files + ++ lib_path_opts) + ++ extra_ld_inputs + ++ map GHC.SysTools.Option ( + rc_objs + ++ framework_opts + ++ pkg_lib_path_opts + ++ extraLinkObj:noteLinkObjs + ++ pkg_link_opts + ++ pkg_framework_opts + ++ (if platformOS platform == OSDarwin + -- dead_strip_dylibs, will remove unused dylibs, and thus save + -- space in the load commands. The -headerpad is necessary so + -- that we can inject more @rpath's later for the left over + -- libraries during runInjectRpaths phase. + -- + -- See Note [Dynamic linking on macOS]. + then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] + else []) + )) + +exeFileName :: Bool -> DynFlags -> FilePath +exeFileName staticLink dflags + | Just s <- outputFile dflags = + case platformOS (targetPlatform dflags) of + OSMinGW32 -> s "exe" + _ -> if staticLink + then s "a" + else s + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.exe" + else if staticLink + then "liba.a" + else "a.out" + where s ext | null (takeExtension s) = s <.> ext + | otherwise = s + +maybeCreateManifest + :: DynFlags + -> FilePath -- filename of executable + -> IO [FilePath] -- extra objects to embed, maybe +maybeCreateManifest dflags exe_filename + | platformOS (targetPlatform dflags) == OSMinGW32 && + gopt Opt_GenManifest dflags + = do let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "\n"++ + " \n"++ + " \n\n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + "\n" + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (gopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags TFL_CurrentModule "rc" + rc_obj_filename <- + newTempName dflags TFL_GhcSession (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + runWindres dflags $ map GHC.SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + removeFile manifest_filename + + return [rc_obj_filename] + | otherwise = return [] + + +linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () +linkDynLibCheck dflags o_files dep_units + = do + when (haveRtsOptsFlags dflags) $ do + putLogMsg dflags NoReason SevInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + linkDynLib dflags o_files dep_units + +-- | Linking a static lib will not really link anything. It will merely produce +-- a static archive of all dependent static libraries. The resulting library +-- will still need to be linked with any remaining link flags. +linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO () +linkStaticLib dflags o_files dep_units = do + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + modules = o_files ++ extra_ld_inputs + output_fn = exeFileName True dflags + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d output_fn) + output_exists <- doesFileExist full_output_fn + (when output_exists) $ removeFile full_output_fn + + pkg_cfgs_init <- getPreloadUnitsAnd dflags dep_units + + let pkg_cfgs + | gopt Opt_LinkRts dflags + = pkg_cfgs_init + | otherwise + = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init + + archives <- concatMapM (collectArchives dflags) pkg_cfgs + + ar <- foldl mappend + <$> (Archive <$> mapM loadObj modules) + <*> mapM loadAr archives + + if toolSettings_ldIsGnuLd (toolSettings dflags) + then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar + else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar + + -- run ranlib over the archive. write*Ar does *not* create the symbol index. + runRanlib dflags [GHC.SysTools.FileOption "" output_fn] + +-- ----------------------------------------------------------------------------- +-- Running CPP + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getUnitIncludePath dflags [] + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths ++ + includePathsQuoteImplicit cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = GHC.SysTools.runCpp dflags args + | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args) + + let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags + targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags + isWindows = (platformOS $ targetPlatform dflags) == OSMinGW32 + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", + "-D" ++ targetOS ++ "_HOST_OS", + "-D" ++ targetArch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let io_manager_defs = + [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++ + [ "-D__IO_MANAGER_MIO__=1" ] + + let sse_defs = + [ "-D__SSE__" | isSseEnabled dflags ] ++ + [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let state = unitState dflags + uids = explicitUnits state + pkgs = catMaybes (map (lookupUnit state) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [GHC.SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map GHC.SysTools.Option verbFlags + ++ map GHC.SysTools.Option include_paths + ++ map GHC.SysTools.Option hsSourceCppOpts + ++ map GHC.SysTools.Option target_defs + ++ map GHC.SysTools.Option backend_defs + ++ map GHC.SysTools.Option th_defs + ++ map GHC.SysTools.Option hscpp_opts + ++ map GHC.SysTools.Option sse_defs + ++ map GHC.SysTools.Option avx_defs + ++ map GHC.SysTools.Option io_manager_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ GHC.SysTools.Option "-x" + , GHC.SysTools.Option "assembler-with-cpp" + , GHC.SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ = + return [] + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = unitPackageVersion pkg + pkgname = map fixchar (unitPackageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +{- +Note [Produce big objects on Windows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The Windows Portable Executable object format has a limit of 32k sections, which +we tend to blow through pretty easily. Thankfully, there is a "big object" +extension, which raises this limit to 2^32. However, it must be explicitly +enabled in the toolchain: + + * the assembler accepts the -mbig-obj flag, which causes it to produce a + bigobj-enabled COFF object. + + * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name + suggests, this tells the linker to produce a bigobj-enabled COFF object, no a + PE executable. + +We must enable bigobj output in a few places: + + * When merging object files (GHC.Driver.Pipeline.joinObjectFiles) + + * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) + +Unfortunately the big object format is not supported on 32-bit targets so +none of this can be used in that case. + + +Note [Merging object files for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHCi can usually loads standard linkable object files using GHC's linker +implementation. However, most users build their projects with -split-sections, +meaning that such object files can have an extremely high number of sections. +As the linker must map each of these sections individually, loading such object +files is very inefficient. + +To avoid this inefficiency, we use the linker's `-r` flag and a linker script +to produce a merged relocatable object file. This file will contain a singe +text section section and can consequently be mapped far more efficiently. As +gcc tends to do unpredictable things to our linker command line, we opt to +invoke ld directly in this case, in contrast to our usual strategy of linking +via gcc. + +-} + +joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles dflags o_files output_fn = do + let toolSettings' = toolSettings dflags + ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' + osInfo = platformOS (targetPlatform dflags) + ld_r args = GHC.SysTools.runMergeObjects dflags ( + -- See Note [Produce big objects on Windows] + concat + [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"] + | OSMinGW32 == osInfo + , not $ target32Bit (targetPlatform dflags) + ] + ++ map GHC.SysTools.Option ld_build_id + ++ [ GHC.SysTools.Option "-o", + GHC.SysTools.FileOption "" output_fn ] + ++ args) + + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"] + | otherwise = [] + + if ldIsGnuLd + then do + script <- newTempName dflags TFL_CurrentModule "ldscript" + cwd <- getCurrentDirectory + let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" + ld_r [GHC.SysTools.FileOption "" script] + else if toolSettings_ldSupportsFilelist toolSettings' + then do + filelist <- newTempName dflags TFL_CurrentModule "filelist" + writeFile filelist $ unlines o_files + ld_r [GHC.SysTools.Option "-filelist", + GHC.SysTools.FileOption "" filelist] + else do + ld_r (map (GHC.SysTools.FileOption "") o_files) + +-- ----------------------------------------------------------------------------- +-- Misc. + +writeInterfaceOnlyMode :: DynFlags -> Bool +writeInterfaceOnlyMode dflags = + gopt Opt_WriteInterface dflags && + HscNothing == hscTarget dflags + +-- | Figure out if a source file was modified after an output file (or if we +-- anyways need to consider the source file modified since the output is gone). +sourceModified :: FilePath -- ^ destination file we are looking for + -> UTCTime -- ^ last time of modification of source file + -> IO Bool -- ^ do we need to regenerate the output? +sourceModified dest_file src_timestamp = do + dest_file_exists <- doesFileExist dest_file + if not dest_file_exists + then return True -- Need to recompile + else do t2 <- getModificationUTCTime dest_file + return (t2 <= src_timestamp) + +-- | What phase to run after one of the backend code generators has run +hscPostBackendPhase :: HscSource -> HscTarget -> Phase +hscPostBackendPhase HsBootFile _ = StopLn +hscPostBackendPhase HsigFile _ = StopLn +hscPostBackendPhase _ hsc_lang = + case hsc_lang of + HscC -> HCc + HscAsm -> As False + HscLlvm -> LlvmOpt + HscNothing -> StopLn + HscInterpreted -> StopLn + +touchObjectFile :: DynFlags -> FilePath -> IO () +touchObjectFile dflags path = do + createDirectoryIfMissing True $ takeDirectory path + GHC.SysTools.touch dflags "Touching object file" path + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map ( "ghcversion.h")) <$> + (getUnitIncludePath dflags [rtsUnitId]) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +-- Note [-fPIC for assembler] +-- When compiling .c source file GHC's driver pipeline basically +-- does the following two things: +-- 1. ${CC} -S 'PIC_CFLAGS' source.c +-- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S +-- +-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? +-- Because on some architectures (at least sparc32) assembler also chooses +-- the relocation type! +-- Consider the following C module: +-- +-- /* pic-sample.c */ +-- int v; +-- void set_v (int n) { v = n; } +-- int get_v (void) { return v; } +-- +-- $ gcc -S -fPIC pic-sample.c +-- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary +-- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary +-- +-- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od +-- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od +-- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od +-- +-- Most of architectures won't show any difference in this test, but on sparc32 +-- the following assembly snippet: +-- +-- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 +-- +-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: +-- +-- 3c: 2f 00 00 00 sethi %hi(0), %l7 +-- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 +-- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 + +{- Note [Don't normalise input filenames] + +Summary + We used to normalise input filenames when starting the unlit phase. This + broke hpc in `--make` mode with imported literate modules (#2991). + +Introduction + 1) --main + When compiling a module with --main, GHC scans its imports to find out which + other modules it needs to compile too. It turns out that there is a small + difference between saying `ghc --make A.hs`, when `A` imports `B`, and + specifying both modules on the command line with `ghc --make A.hs B.hs`. In + the former case, the filename for B is inferred to be './B.hs' instead of + 'B.hs'. + + 2) unlit + When GHC compiles a literate haskell file, the source code first needs to go + through unlit, which turns it into normal Haskell source code. At the start + of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the + option `-h` and the name of the original file. We used to normalise this + filename using System.FilePath.normalise, which among other things removes + an initial './'. unlit then uses that filename in #line directives that it + inserts in the transformed source code. + + 3) SrcSpan + A SrcSpan represents a portion of a source code file. It has fields + linenumber, start column, end column, and also a reference to the file it + originated from. The SrcSpans for a literate haskell file refer to the + filename that was passed to unlit -h. + + 4) -fhpc + At some point during compilation with -fhpc, in the function + `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a + `SrcSpan` refers to with the name of the file we are currently compiling. + For some reason I don't yet understand, they can sometimes legitimally be + different, and then hpc ignores that SrcSpan. + +Problem + When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate + module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the + start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). + Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are + still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), + doesn't include ticks for B, and we have unhappy customers (#2991). + +Solution + Do not normalise `input_fn` when starting the unlit phase. + +Alternative solution + Another option would be to not compare the two filenames on equality, but to + use System.FilePath.equalFilePath. That function first normalises its + arguments. The problem is that by the time we need to do the comparison, the + filenames have been turned into FastStrings, probably for performance + reasons, so System.FilePath.equalFilePath can not be used directly. + +Archeology + The call to `normalise` was added in a commit called "Fix slash + direction on Windows with the new filePath code" (c9b6b5e8). The problem + that commit was addressing has since been solved in a different manner, in a + commit called "Fix the filename passed to unlit" (1eedbc6b). So the + `normalise` is no longer necessary. +-} diff --git a/GHC/Driver/Pipeline/Monad.hs b/GHC/Driver/Pipeline/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Pipeline/Monad.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | The CompPipeline monad and associated ops +-- +-- Defined in separate module so that it can safely be imported from Hooks +module GHC.Driver.Pipeline.Monad ( + CompPipeline(..), evalP + , PhasePlus(..) + , PipeEnv(..), PipeState(..), PipelineOutput(..) + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface + , pipeStateDynFlags, pipeStateModIface + ) where + +import GHC.Prelude + +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Driver.Phases +import GHC.Driver.Types +import GHC.Unit.Module +import GHC.SysTools.FileCleanup (TempFileLifetime) + +import Control.Monad + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + deriving (Functor) + +evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a) +evalP (P f) env st = f env st + +instance Applicative CompPipeline where + pure a = P $ \_env state -> return (state, a) + (<*>) = ap + +instance Monad CompPipeline where + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +instance MonadIO CompPipeline where + liftIO m = P $ \_env state -> do a <- m; return (state, a) + +data PhasePlus = RealPhase Phase + | HscOut HscSource ModuleName HscStatus + +instance Outputable PhasePlus where + ppr (RealPhase p) = ppr p + ppr (HscOut {}) = text "HscOut" + +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_filename :: String, -- ^ basename of original input source + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + foreign_os :: [FilePath], + -- ^ additional object files resulting from compiling foreign + -- code. They come from two sources: foreign stubs, and + -- add{C,Cxx,Objc,Objcxx}File from template haskell + iface :: Maybe ModIface + -- ^ Interface generated by HscOut phase. Only available after the + -- phase runs. + } + +pipeStateDynFlags :: PipeState -> DynFlags +pipeStateDynFlags = hsc_dflags . hsc_env + +pipeStateModIface :: PipeState -> Maybe ModIface +pipeStateModIface = iface + +data PipelineOutput + = Temporary TempFileLifetime + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile + -- ^ The output must go into the specific outputFile in DynFlags. + -- We don't store the filename in the constructor as it changes + -- when doing -dynamic-too. + deriving Show + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setForeignOs :: [FilePath] -> CompPipeline () +setForeignOs os = P $ \_env state -> + return (state{ foreign_os = os }, ()) + +setIface :: ModIface -> CompPipeline () +setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ()) diff --git a/GHC/Driver/Plugins.hs b/GHC/Driver/Plugins.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Plugins.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +-- | Definitions for writing /plugins/ for GHC. Plugins can hook into +-- several areas of the compiler. See the 'Plugin' type. These plugins +-- include type-checker plugins, source plugins, and core-to-core plugins. + +module GHC.Driver.Plugins ( + -- * Plugins + Plugin(..) + , defaultPlugin + , CommandLineOption + -- ** Recompilation checking + , purePlugin, impurePlugin, flagRecompile + , PluginRecompile(..) + + -- * Plugin types + -- ** Frontend plugins + , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction + -- ** Core plugins + -- | Core plugins allow plugins to register as a Core-to-Core pass. + , CorePlugin + -- ** Typechecker plugins + -- | Typechecker plugins allow plugins to provide evidence to the + -- typechecker. + , TcPlugin + -- ** Source plugins + -- | GHC offers a number of points where plugins can access and modify its + -- front-end (\"source\") representation. These include: + -- + -- - access to the parser result with 'parsedResultAction' + -- - access to the renamed AST with 'renamedResultAction' + -- - access to the typechecked AST with 'typeCheckResultAction' + -- - access to the Template Haskell splices with 'spliceRunAction' + -- - access to loaded interface files with 'interfaceLoadAction' + -- + , keepRenamedSource + -- ** Hole fit plugins + -- | hole fit plugins allow plugins to change the behavior of valid hole + -- fit suggestions + , HoleFitPluginR + + -- * Internal + , PluginWithArgs(..), plugins, pluginRecompile' + , LoadedPlugin(..), lpModuleName + , StaticPlugin(..) + , mapPlugins, withPlugins, withPlugins_ + ) where + +import GHC.Prelude + +import GHC.Core.Opt.Monad ( CoreToDo, CoreM ) +import qualified GHC.Tc.Types +import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) +import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR ) +import GHC.Hs +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Driver.Monad +import GHC.Driver.Phases +import GHC.Unit.Module +import GHC.Utils.Fingerprint +import Data.List (sort) +import GHC.Utils.Outputable (Outputable(..), text, (<+>)) + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup + +import Control.Monad + +-- | Command line options gathered from the -PModule.Name:stuff syntax +-- are given to you as this type +type CommandLineOption = String + +-- | 'Plugin' is the compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatibility when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in +-- the future. +data Plugin = Plugin { + installCoreToDos :: CorePlugin + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify the + -- pipeline in a nondeterministic order. + , tcPlugin :: TcPlugin + -- ^ An optional typechecker plugin, which may modify the + -- behaviour of the constraint solver. + , holeFitPlugin :: HoleFitPlugin + -- ^ An optional plugin to handle hole fits, which may re-order + -- or change the list of valid hole fits and refinement hole fits. + , dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags + -- ^ An optional plugin to update 'DynFlags', right after + -- plugin loading. This can be used to register hooks + -- or tweak any field of 'DynFlags' before doing + -- actual work on a module. + -- + -- @since 8.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile + -- ^ Specify how the plugin should affect recompilation. + , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule + -> Hsc HsParsedModule + -- ^ Modify the module when it is parsed. This is called by + -- "GHC.Driver.Main" when the parsing is successful. + , renamedResultAction :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) + -- ^ Modify each group after it is renamed. This is called after each + -- `HsGroup` has been renamed. + , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv + -> TcM TcGblEnv + -- ^ Modify the module when it is type checked. This is called at the + -- very end of typechecking. + , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc + -> TcM (LHsExpr GhcTc) + -- ^ Modify the TH splice or quasiqoute before it is run. + , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface + -> IfM lcl ModIface + -- ^ Modify an interface that have been loaded. This is called by + -- "GHC.Iface.Load" when an interface is successfully loaded. Not applied to + -- the loading of the plugin interface. Tools that rely on information from + -- modules other than the currently compiled one should implement this + -- function. + } + +-- Note [Source plugins] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `Plugin` datatype have been extended by fields that allow access to the +-- different inner representations that are generated during the compilation +-- process. These fields are `parsedResultAction`, `renamedResultAction`, +-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`. +-- +-- The main purpose of these plugins is to help tool developers. They allow +-- development tools to extract the information about the source code of a big +-- Haskell project during the normal build procedure. In this case the plugin +-- acts as the tools access point to the compiler that can be controlled by +-- compiler flags. This is important because the manipulation of compiler flags +-- is supported by most build environment. +-- +-- For the full discussion, check the full proposal at: +-- https://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal + +data PluginWithArgs = PluginWithArgs + { paPlugin :: Plugin + -- ^ the actual callable plugin + , paArguments :: [CommandLineOption] + -- ^ command line arguments for the plugin + } + +-- | A plugin with its arguments. The result of loading the plugin. +data LoadedPlugin = LoadedPlugin + { lpPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + , lpModule :: ModIface + -- ^ the module containing the plugin + } + +-- | A static plugin with its arguments. For registering compiled-in plugins +-- through the GHC API. +data StaticPlugin = StaticPlugin + { spPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + } + +lpModuleName :: LoadedPlugin -> ModuleName +lpModuleName = moduleName . mi_module . lpModule + +pluginRecompile' :: PluginWithArgs -> IO PluginRecompile +pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args + +data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint + +instance Outputable PluginRecompile where + ppr ForceRecompile = text "ForceRecompile" + ppr NoForceRecompile = text "NoForceRecompile" + ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp + +instance Semigroup PluginRecompile where + ForceRecompile <> _ = ForceRecompile + NoForceRecompile <> r = r + MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp + MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp']) + MaybeRecompile _fp <> ForceRecompile = ForceRecompile + +instance Monoid PluginRecompile where + mempty = NoForceRecompile + +type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin +type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR + +purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile +purePlugin _args = return NoForceRecompile + +impurePlugin _args = return ForceRecompile + +flagRecompile = + return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort + +-- | Default plugin: does nothing at all, except for marking that safe +-- inference has failed unless @-fplugin-trustworthy@ is passed. For +-- compatibility reason you should base all your plugin definitions on this +-- default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + , tcPlugin = const Nothing + , holeFitPlugin = const Nothing + , dynflagsPlugin = const return + , pluginRecompile = impurePlugin + , renamedResultAction = \_ env grp -> return (env, grp) + , parsedResultAction = \_ _ -> return + , typeCheckResultAction = \_ _ -> return + , spliceRunAction = \_ -> return + , interfaceLoadAction = \_ -> return + } + + +-- | A renamer plugin which mades the renamed source available in +-- a typechecker plugin. +keepRenamedSource :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) +keepRenamedSource _ gbl_env group = + return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env) + , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group) + where + update_exports Nothing = Just [] + update_exports m = m + + update Nothing = Just emptyRnGroup + update m = m + + +type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a +type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () + +plugins :: DynFlags -> [PluginWithArgs] +plugins df = + map lpPlugin (cachedPlugins df) ++ + map spPlugin (staticPlugins df) + +-- | Perform an operation by using all of the plugins in turn. +withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a +withPlugins df transformation input = foldM go input (plugins df) + where + go arg (PluginWithArgs p opts) = transformation p opts arg + +mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a] +mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df) + +-- | Perform a constant operation by using all of the plugins in turn. +withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m () +withPlugins_ df transformation input + = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input) + (plugins df) + +type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () +data FrontendPlugin = FrontendPlugin { + frontend :: FrontendPluginAction + } +defaultFrontendPlugin :: FrontendPlugin +defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } diff --git a/GHC/Driver/Plugins.hs-boot b/GHC/Driver/Plugins.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Plugins.hs-boot @@ -0,0 +1,10 @@ +-- The plugins datatype is stored in DynFlags, so it needs to be +-- exposed without importing all of its implementation. +module GHC.Driver.Plugins where + +import GHC.Prelude () + +data Plugin + +data LoadedPlugin +data StaticPlugin diff --git a/GHC/Driver/Session.hs b/GHC/Driver/Session.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Session.hs @@ -0,0 +1,5335 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} + +------------------------------------------------------------------------------- +-- +-- | Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from compilation +-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each +-- session can be using different dynamic flags. Dynamic flags can also be set +-- at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Driver.Session ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), WarnReason(..), + Language(..), + PlatformConstants(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), + ProfAuto(..), + glasgowExtsFlags, + warningGroups, warningHierarchies, + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + lang_set, + whenGeneratingDynamicToo, ifGeneratingDynamicToo, + whenCannotGenerateDynamicToo, + dynamicTooMkDynamicDynFlags, + dynamicOutputFile, + sccProfilingEnabled, + DynFlags(..), + FlagSpec(..), + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgDbRef(..), + Option(..), showOpt, + DynLibLoader(..), + fFlags, fLangFlags, xFlags, + wWarningFlags, + dynFlagDependencies, + makeDynFlagsConsistent, + positionIndependent, + optimisationFlags, + setFlagsFromEnvFile, + + addWay', + + homeUnit, mkHomeModule, isHomeModule, + + -- ** Log output + putLogMsg, + + -- ** Safe Haskell + SafeHaskellMode(..), + safeHaskellOn, safeHaskellModeEnabled, + safeImportsOn, safeLanguageOn, safeInferOn, + packageTrustOn, + safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, unsafeFlagsForInfer, + + -- ** LLVM Targets + LlvmTarget(..), LlvmConfig(..), + + -- ** System tool settings and locations + Settings(..), + sProgramName, + sProjectVersion, + sGhcUsagePath, + sGhciUsagePath, + sToolDir, + sTopDir, + sTmpDir, + sGlobalPackageDatabasePath, + sLdSupportsCompactUnwind, + sLdSupportsBuildId, + sLdSupportsFilelist, + sLdIsGnuLd, + sGccSupportsNoPie, + sPgm_L, + sPgm_P, + sPgm_F, + sPgm_c, + sPgm_a, + sPgm_l, + sPgm_lm, + sPgm_dll, + sPgm_T, + sPgm_windres, + sPgm_libtool, + sPgm_ar, + sPgm_ranlib, + sPgm_lo, + sPgm_lc, + sPgm_lcc, + sPgm_i, + sOpt_L, + sOpt_P, + sOpt_P_fingerprint, + sOpt_F, + sOpt_c, + sOpt_cxx, + sOpt_a, + sOpt_l, + sOpt_lm, + sOpt_windres, + sOpt_lo, + sOpt_lc, + sOpt_lcc, + sOpt_i, + sExtraGccViaCFlags, + sTargetPlatformString, + sGhcWithInterpreter, + sGhcWithSMP, + sGhcRTSWays, + sLibFFI, + sGhcThreaded, + sGhcDebugged, + sGhcRtsWithLibdw, + GhcNameVersion(..), + FileSettings(..), + PlatformMisc(..), + settings, + programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, tmpDir, + versionedAppDir, versionedFilePath, + extraGccViaCFlags, globalPackageDatabasePath, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T, + pgm_windres, pgm_libtool, pgm_ar, pgm_otool, pgm_install_name_tool, + pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i, + opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, + opt_P_signature, + opt_windres, opt_lo, opt_lc, opt_lcc, + + -- ** Manipulating DynFlags + addPluginModuleName, + defaultDynFlags, -- Settings -> DynFlags + defaultWays, + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultLogAction, + defaultLogActionHPrintDoc, + defaultLogActionHPutStrDoc, + defaultFlushOut, + defaultFlushErr, + + getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] + getVerbFlags, + updOptLevel, + setTmpDir, + setUnitId, + canonicalizeHomeModule, + canonicalizeModuleIfHome, + + TurnOnFlag, + turnOn, + turnOff, + impliedGFlags, + impliedOffGFlags, + impliedXFlags, + + -- ** Parsing DynFlags + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + parseDynamicFlagsFull, + + -- ** Available DynFlags + allNonDeprecatedFlags, + flagsAll, + flagsDynamic, + flagsPackage, + flagsForCompletion, + + supportedLanguagesAndExtensions, + languageExtensions, + + -- ** DynFlags C compiler options + picCCOpts, picPOpts, + + -- * Compiler configuration suitable for display to the user + compilerInfo, + +#include "GHCConstantsHaskellExports.hs" + bLOCK_SIZE_W, + wordAlignment, + tAG_MASK, + mAX_PTR_TAG, + + unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, + + -- * SSE and AVX + isSseEnabled, + isSse2Enabled, + isSse4_2Enabled, + isBmiEnabled, + isBmi2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + + -- * Linker/compiler information + LinkerInfo(..), + CompilerInfo(..), + useXLinkerRPath, + + -- * File cleanup + FilesToClean(..), emptyFilesToClean, + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + addImplicitQuoteInclude, + + -- * SDoc + initSDocContext, initDefaultSDocContext, + + -- * Make use of the Cmm CFG + CfgWeights(..) + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.UniqueSubdir (uniqueSubdir) +import GHC.Unit.Types +import GHC.Unit.Parser +import GHC.Unit.Module +import {-# SOURCE #-} GHC.Driver.Plugins +import {-# SOURCE #-} GHC.Driver.Hooks +import GHC.Builtin.Names ( mAIN ) +import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase, updateIndefUnitId) +import GHC.Driver.Phases ( Phase(..), phaseInputExt ) +import GHC.Driver.Flags +import GHC.Driver.Ways +import GHC.Driver.Backend +import GHC.Settings.Config +import GHC.Utils.CliOption +import GHC.Driver.CmdLine hiding (WarnReason(..)) +import qualified GHC.Driver.CmdLine as Cmd +import GHC.Settings.Constants +import GHC.Utils.Panic +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Monad +import qualified GHC.Utils.Ppr as Pretty +import GHC.Types.SrcLoc +import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) +import GHC.Data.FastString +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable +import GHC.Settings + +import {-# SOURCE #-} GHC.Utils.Error + ( Severity(..), MsgDoc, mkLocMessageAnn + , getCaretDiagnostic, DumpAction, TraceAction + , defaultDumpAction, defaultTraceAction ) +import GHC.Utils.Json +import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) +import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except + +import Data.Ord +import Data.Bits +import Data.Char +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import System.FilePath +import System.Directory +import System.Environment (lookupEnv) +import System.IO +import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R + +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet + +import GHC.Foreign (withCString, peekCString) +import qualified GHC.LanguageExtensions as LangExt + +#if GHC_STAGE >= 2 +-- used by SHARED_GLOBAL_VAR +import Foreign (Ptr) +#endif + +-- Note [Updating flag description in the User's Guide] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you modify anything in this file please make sure that your changes are +-- described in the User's Guide. Please update the flag description in the +-- users guide (docs/users_guide) whenever you add or change a flag. + +-- Note [Supporting CLI completion] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The command line interface completion (in for example bash) is an easy way +-- for the developer to learn what flags are available from GHC. +-- GHC helps by separating which flags are available when compiling with GHC, +-- and which flags are available when using GHCi. +-- A flag is assumed to either work in both these modes, or only in one of them. +-- When adding or changing a flag, please consider for which mode the flag will +-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, +-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. + +-- Note [Adding a language extension] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are a few steps to adding (or removing) a language extension, +-- +-- * Adding the extension to GHC.LanguageExtensions +-- +-- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +-- is the canonical list of language extensions known by GHC. +-- +-- * Adding a flag to DynFlags.xFlags +-- +-- This is fairly self-explanatory. The name should be concise, memorable, +-- and consistent with any previous implementations of the similar idea in +-- other Haskell compilers. +-- +-- * Adding the flag to the documentation +-- +-- This is the same as any other flag. See +-- Note [Updating flag description in the User's Guide] +-- +-- * Adding the flag to Cabal +-- +-- The Cabal library has its own list of all language extensions supported +-- by all major compilers. This is the list that user code being uploaded +-- to Hackage is checked against to ensure language extension validity. +-- Consequently, it is very important that this list remains up-to-date. +-- +-- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) +-- whose job it is to ensure these GHC's extensions are consistent with +-- Cabal. +-- +-- The recommended workflow is, +-- +-- 1. Temporarily add your new language extension to the +-- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't +-- break while Cabal is updated. +-- +-- 2. After your GHC change is accepted, submit a Cabal pull request adding +-- your new extension to Cabal's list (found in +-- Cabal/Language/Haskell/Extension.hs). +-- +-- 3. After your Cabal change is accepted, let the GHC developers know so +-- they can update the Cabal submodule and remove the extensions from +-- expectedGhcOnlyExtensions. +-- +-- * Adding the flag to the GHC Wiki +-- +-- There is a change log tracking language extension additions and removals +-- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history +-- +-- See #4437 and #8176. + +-- ----------------------------------------------------------------------------- +-- DynFlags + + +-- | Used to differentiate the scope an include needs to apply to. +-- We have to split the include paths to avoid accidentally forcing recursive +-- includes since -I overrides the system search paths. See #14312. +data IncludeSpecs + = IncludeSpecs { includePathsQuote :: [String] + , includePathsGlobal :: [String] + -- | See note [Implicit include paths] + , includePathsQuoteImplicit :: [String] + } + deriving Show + +-- | Append to the list of includes a path that shall be included using `-I` +-- when the C compiler is called. These paths override system search paths. +addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addGlobalInclude spec paths = let f = includePathsGlobal spec + in spec { includePathsGlobal = f ++ paths } + +-- | Append to the list of includes a path that shall be included using +-- `-iquote` when the C compiler is called. These paths only apply when quoted +-- includes are used. e.g. #include "foo.h" +addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addQuoteInclude spec paths = let f = includePathsQuote spec + in spec { includePathsQuote = f ++ paths } + +-- | These includes are not considered while fingerprinting the flags for iface +-- | See note [Implicit include paths] +addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addImplicitQuoteInclude spec paths = let f = includePathsQuoteImplicit spec + in spec { includePathsQuoteImplicit = f ++ paths } + + +-- | Concatenate and flatten the list of global and quoted includes returning +-- just a flat list of paths. +flattenIncludes :: IncludeSpecs -> [String] +flattenIncludes specs = + includePathsQuote specs ++ + includePathsQuoteImplicit specs ++ + includePathsGlobal specs + +{- Note [Implicit include paths] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The compile driver adds the path to the folder containing the source file being + compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags' + that are used later to compute the interface file. Because of this, + the flags fingerprint derived from these 'DynFlags' and recorded in the + interface file will end up containing the absolute path to the source folder. + + Build systems with a remote cache like Bazel or Buck (or Shake, see #16956) + store the build artifacts produced by a build BA for reuse in subsequent builds. + + Embedding source paths in interface fingerprints will thwart these attemps and + lead to unnecessary recompilations when the source paths in BA differ from the + source paths in subsequent builds. + -} + + +-- | The various Safe Haskell modes +data SafeHaskellMode + = Sf_None -- ^ inferred unsafe + | Sf_Unsafe -- ^ declared and checked + | Sf_Trustworthy -- ^ declared and checked + | Sf_Safe -- ^ declared and checked + | Sf_SafeInferred -- ^ inferred as safe + | Sf_Ignore -- ^ @-fno-safe-haskell@ state + deriving (Eq) + +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + show Sf_SafeInferred = "Safe-Inferred" + show Sf_Ignore = "Ignore" + +instance Outputable SafeHaskellMode where + ppr = text . show + +-- | Contains not only a collection of 'GeneralFlag's but also a plethora of +-- information relating to the compilation of a single file or GHC session +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + hscTarget :: HscTarget, + + -- formerly Settings + ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, + fileSettings :: {-# UNPACK #-} !FileSettings, + targetPlatform :: Platform, -- Filled in by SysTools + toolSettings :: {-# UNPACK #-} !ToolSettings, + platformMisc :: {-# UNPACK #-} !PlatformMisc, + platformConstants :: PlatformConstants, + rawSettings :: [(String, String)], + + llvmConfig :: LlvmConfig, + -- ^ N.B. It's important that this field is lazy since we load the LLVM + -- configuration lazily. See Note [LLVM Configuration] in "GHC.SysTools". + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] + optLevel :: Int, -- ^ Optimisation level + debugLevel :: Int, -- ^ How much debug information to produce + simplPhases :: Int, -- ^ Number of simplifier phases + maxSimplIterations :: Int, -- ^ Max simplifier iterations + ruleCheck :: Maybe String, + inlineCheck :: Maybe String, -- ^ A prefix to report inlining decisions about + strictnessBefore :: [Int], -- ^ Additional demand analysis + + parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel + -- in --make mode, where Nothing ==> compile as + -- many in parallel as there are CPUs. + + enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? + ghcHeapSize :: Maybe Int, -- ^ The heap size to set. + + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages + maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show + -- in typed hole error messages + maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole + -- fits to show in typed hole error + -- messages + refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for + -- refinement hole fits in typed hole + -- error messages + maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show + -- in non-exhaustiveness warnings + maxPmCheckModels :: Int, -- ^ Soft limit on the number of models + -- the pattern match checker checks + -- a pattern against. A safe guard + -- against exponential blow-up. + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr + specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function + specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types + -- Not optional; otherwise ForceSpecConstr can diverge. + binBlobThreshold :: Word, -- ^ Binary literals (e.g. strings) whose size is above + -- this threshold will be dumped in a binary file + -- by the assembler code generator (0 to disable) + liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See 'GHC.Core.Opt.Monad.FloatOutSwitches' + + liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- recursive function. + liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- non-recursive function. + liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call + -- into an unknown call. + + cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. + + historySize :: Int, -- ^ Simplification history size + + importPaths :: [FilePath], + mainModIs :: Module, + mainFunIs :: Maybe String, + reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth + solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver + -- Typically only 1 is needed + + homeUnitId :: UnitId, -- ^ Target home unit-id + homeUnitInstanceOfId :: Maybe IndefUnitId, -- ^ Unit-id to instantiate + homeUnitInstantiations:: [(ModuleName, Module)], -- ^ How to instantiate `homeUnitInstanceOfId` unit + + -- ways + ways :: Set Way, -- ^ Way flags from the command line + + -- For object splitting + splitInfo :: Maybe (String,Int), + + -- paths etc. + objectDir :: Maybe String, + dylibInstallName :: Maybe String, + hiDir :: Maybe String, + hieDir :: Maybe String, + stubDir :: Maybe String, + dumpDir :: Maybe String, + + objectSuf :: String, + hcSuf :: String, + hiSuf :: String, + hieSuf :: String, + + canGenerateDynamicToo :: IORef Bool, + dynObjectSuf :: String, + dynHiSuf :: String, + + outputFile :: Maybe String, + dynOutputFile :: Maybe String, + outputHi :: Maybe String, + dynLibLoader :: DynLibLoader, + + -- | This is set by 'GHC.Driver.Pipeline.runPipeline' based on where + -- its output is going. + dumpPrefix :: Maybe FilePath, + + -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.runPipeline'. + -- Set by @-ddump-file-prefix@ + dumpPrefixForce :: Maybe FilePath, + + ldInputs :: [Option], + + includePaths :: IncludeSpecs, + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + + rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, + rtsOptsSuggestions :: Bool, + + hpcDir :: String, -- ^ Path to store the .mix files + + -- Plugins + pluginModNames :: [ModuleName], + pluginModNameOpts :: [(ModuleName,String)], + frontendPluginOpts :: [String], + -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + cachedPlugins :: [LoadedPlugin], + -- ^ plugins dynamically loaded after processing arguments. What will be + -- loaded here is directed by pluginModNames. Arguments are loaded from + -- pluginModNameOpts. The purpose of this field is to cache the plugins so + -- they don't have to be loaded each time they are needed. See + -- 'GHC.Runtime.Loader.initializePlugins'. + staticPlugins :: [StaticPlugin], + -- ^ static plugins which do not need dynamic loading. These plugins are + -- intended to be added by GHC API users directly to this list. + -- + -- To add dynamically loaded plugins through the GHC API see + -- 'addPluginModuleName' instead. + + -- GHC API hooks + hooks :: Hooks, + + -- For ghc -M + depMakefile :: FilePath, + depIncludePkgDeps :: Bool, + depIncludeCppDeps :: Bool, + depExcludeMods :: [ModuleName], + depSuffixes :: [String], + + -- Package flags + packageDBFlags :: [PackageDBFlag], + -- ^ The @-package-db@ flags given on the command line, In + -- *reverse* order that they're specified on the command line. + -- This is intended to be applied with the list of "initial" + -- package databases derived from @GHC_PACKAGE_PATH@; see + -- 'getUnitDbRefs'. + + ignorePackageFlags :: [IgnorePackageFlag], + -- ^ The @-ignore-package@ flags from the command line. + -- In *reverse* order that they're specified on the command line. + packageFlags :: [PackageFlag], + -- ^ The @-package@ and @-hide-package@ flags from the command-line. + -- In *reverse* order that they're specified on the command line. + pluginPackageFlags :: [PackageFlag], + -- ^ The @-plugin-package-id@ flags from command line. + -- In *reverse* order that they're specified on the command line. + trustFlags :: [TrustFlag], + -- ^ The @-trust@ and @-distrust@ flags. + -- In *reverse* order that they're specified on the command line. + packageEnv :: Maybe FilePath, + -- ^ Filepath to the package environment file (if overriding default) + + unitDatabases :: Maybe [UnitDatabase UnitId], + -- ^ Stack of unit databases for the target platform. + -- + -- This field is populated by `initUnits`. + -- + -- 'Nothing' means the databases have never been read from disk. If + -- `initUnits` is called again, it doesn't reload the databases from + -- disk. + + unitState :: UnitState, + -- ^ Consolidated unit database built by 'initUnits' from the unit + -- databases in 'unitDatabases' and flags ('-ignore-package', etc.). + -- + -- It also contains mapping from module names to actual Modules. + + -- Temporary files + -- These have to be IORefs, because the defaultCleanupHandler needs to + -- know what to clean when an exception happens + filesToClean :: IORef FilesToClean, + dirsToClean :: IORef (Map FilePath FilePath), + -- The next available suffix to uniquely name a temp file, updated atomically + nextTempSuffix :: IORef Int, + + -- Names of files which were generated from -ddump-to-file; used to + -- track which ones we need to truncate because it's our first run + -- through + generatedDumps :: IORef (Set FilePath), + + -- hsc dynamic flags + dumpFlags :: EnumSet DumpFlag, + generalFlags :: EnumSet GeneralFlag, + warningFlags :: EnumSet WarningFlag, + fatalWarningFlags :: EnumSet WarningFlag, + -- Don't change this without updating extensionFlags: + language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, + deriveViaOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, + incoherentOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, + warnSafeOnLoc :: SrcSpan, + warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, + -- Don't change this without updating extensionFlags: + -- Here we collect the settings of the language extensions + -- from the command line, the ghci config file and + -- from interactive :set / :seti commands. + extensions :: [OnOff LangExt.Extension], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used + -- by template-haskell + extensionFlags :: EnumSet LangExt.Extension, + + -- Unfolding control + -- See Note [Discounts and thresholds] in GHC.Core.Unfold + ufCreationThreshold :: Int, + ufUseThreshold :: Int, + ufFunAppDiscount :: Int, + ufDictDiscount :: Int, + ufDearOp :: Int, + ufVeryAggressive :: Bool, + + maxWorkerArgs :: Int, + + ghciHistSize :: Int, + + -- | MsgDoc output action: use "GHC.Utils.Error" instead of this if you can + log_action :: LogAction, + dump_action :: DumpAction, + trace_action :: TraceAction, + flushOut :: FlushOut, + flushErr :: FlushErr, + + ghcVersionFile :: Maybe FilePath, + haddockOptions :: Maybe String, + + -- | GHCi scripts specified by -ghci-script, in reverse order + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + + useUnicode :: Bool, + useColor :: OverridingBool, + canUseColor :: Bool, + colScheme :: Col.Scheme, + + -- | what kind of {-# SCC #-} to add automatically + profAuto :: ProfAuto, + + interactivePrint :: Maybe String, + + nextWrapperNum :: IORef (ModuleEnv Int), + + -- | Machine dependent flags (-m\ stuff) + sseVersion :: Maybe SseVersion, + bmiVersion :: Maybe BmiVersion, + avx :: Bool, + avx2 :: Bool, + avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. + avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. + avx512f :: Bool, -- Enable AVX-512 instructions. + avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. + + -- | Run-time linker information (what options we need, etc.) + rtldInfo :: IORef (Maybe LinkerInfo), + + -- | Run-time compiler information + rtccInfo :: IORef (Maybe CompilerInfo), + + -- Constants used to control the amount of optimization done. + + -- | Max size, in bytes, of inline array allocations. + maxInlineAllocSize :: Int, + + -- | Only inline memcpy if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemcpyInsns :: Int, + + -- | Only inline memset if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemsetInsns :: Int, + + -- | Reverse the order of error messages in GHC/GHCi + reverseErrors :: Bool, + + -- | Limit the maximum number of errors to show + maxErrors :: Maybe Int, + + -- | Unique supply configuration for testing build determinism + initialUnique :: Int, + uniqueIncrement :: Int, + + -- | Temporary: CFG Edge weights for fast iterations + cfgWeightInfo :: CfgWeights +} + +-- | Edge weights to use when generating a CFG from CMM +data CfgWeights + = CFGWeights + { uncondWeight :: Int + , condBranchWeight :: Int + , switchWeight :: Int + , callWeight :: Int + , likelyCondWeight :: Int + , unlikelyCondWeight :: Int + , infoTablePenalty :: Int + , backEdgeBonus :: Int + } + +defaultCfgWeights :: CfgWeights +defaultCfgWeights + = CFGWeights + { uncondWeight = 1000 + , condBranchWeight = 800 + , switchWeight = 1 + , callWeight = -10 + , likelyCondWeight = 900 + , unlikelyCondWeight = 300 + , infoTablePenalty = 300 + , backEdgeBonus = 400 + } + +parseCfgWeights :: String -> CfgWeights -> CfgWeights +parseCfgWeights s oldWeights = + foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments + where + assignments = map assignment $ settings s + update "uncondWeight" n w = + w {uncondWeight = n} + update "condBranchWeight" n w = + w {condBranchWeight = n} + update "switchWeight" n w = + w {switchWeight = n} + update "callWeight" n w = + w {callWeight = n} + update "likelyCondWeight" n w = + w {likelyCondWeight = n} + update "unlikelyCondWeight" n w = + w {unlikelyCondWeight = n} + update "infoTablePenalty" n w = + w {infoTablePenalty = n} + update "backEdgeBonus" n w = + w {backEdgeBonus = n} + update other _ _ + = panic $ other ++ + " is not a cfg weight parameter. " ++ + exampleString + settings s + | (s1,rest) <- break (== ',') s + , null rest + = [s1] + | (s1,rest) <- break (== ',') s + = s1 : settings (drop 1 rest) + + assignment as + | (name, _:val) <- break (== '=') as + = (name,read val) + | otherwise + = panic $ "Invalid cfg parameters." ++ exampleString + + exampleString = "Example parameters: uncondWeight=1000," ++ + "condBranchWeight=800,switchWeight=0,callWeight=300" ++ + ",likelyCondWeight=900,unlikelyCondWeight=300" ++ + ",infoTablePenalty=300,backEdgeBonus=400" + +class HasDynFlags m where + getDynFlags :: m DynFlags + +{- It would be desirable to have the more generalised + + instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where + getDynFlags = lift getDynFlags + +instance definition. However, that definition would overlap with the +`HasDynFlags (GhcT m)` instance. Instead we define instances for a +couple of common Monad transformers explicitly. -} + +instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where + getDynFlags = lift getDynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum) + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +-- | See Note [LLVM Configuration] in "GHC.SysTools". +data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] + , llvmPasses :: [(Int, String)] + } + +----------------------------------------------------------------------------- +-- Accessessors from 'DynFlags' + +-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the +-- vast majority of code. But GHCi questionably uses this to produce a default +-- 'DynFlags' from which to compute a flags diff for printing. +settings :: DynFlags -> Settings +settings dflags = Settings + { sGhcNameVersion = ghcNameVersion dflags + , sFileSettings = fileSettings dflags + , sTargetPlatform = targetPlatform dflags + , sToolSettings = toolSettings dflags + , sPlatformMisc = platformMisc dflags + , sPlatformConstants = platformConstants dflags + , sRawSettings = rawSettings dflags + } + +programName :: DynFlags -> String +programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags +projectVersion :: DynFlags -> String +projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags +toolDir :: DynFlags -> Maybe FilePath +toolDir dflags = fileSettings_toolDir $ fileSettings dflags +topDir :: DynFlags -> FilePath +topDir dflags = fileSettings_topDir $ fileSettings dflags +tmpDir :: DynFlags -> String +tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags +globalPackageDatabasePath :: DynFlags -> FilePath +globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags +pgm_L :: DynFlags -> String +pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags +pgm_F :: DynFlags -> String +pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags +pgm_c :: DynFlags -> String +pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags +pgm_lm :: DynFlags -> (String,[Option]) +pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags +pgm_T :: DynFlags -> String +pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags +pgm_windres :: DynFlags -> String +pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags +pgm_libtool :: DynFlags -> String +pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags +pgm_lcc :: DynFlags -> (String,[Option]) +pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags +pgm_ar :: DynFlags -> String +pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags +pgm_otool :: DynFlags -> String +pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags +pgm_install_name_tool :: DynFlags -> String +pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags +pgm_ranlib :: DynFlags -> String +pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags +pgm_i :: DynFlags -> String +pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags +opt_L :: DynFlags -> [String] +opt_L dflags = toolSettings_opt_L $ toolSettings dflags +opt_P :: DynFlags -> [String] +opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_P (toolSettings dflags) + +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_P_signature :: DynFlags -> ([String], Fingerprint) +opt_P_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , toolSettings_opt_P_fingerprint $ toolSettings dflags + ) + +opt_F :: DynFlags -> [String] +opt_F dflags= toolSettings_opt_F $ toolSettings dflags +opt_c :: DynFlags -> [String] +opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_c (toolSettings dflags) +opt_cxx :: DynFlags -> [String] +opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags +opt_a :: DynFlags -> [String] +opt_a dflags= toolSettings_opt_a $ toolSettings dflags +opt_l :: DynFlags -> [String] +opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_l (toolSettings dflags) +opt_lm :: DynFlags -> [String] +opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags +opt_windres :: DynFlags -> [String] +opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags +opt_lcc :: DynFlags -> [String] +opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags +opt_lo :: DynFlags -> [String] +opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags +opt_lc :: DynFlags -> [String] +opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags +opt_i :: DynFlags -> [String] +opt_i dflags= toolSettings_opt_i $ toolSettings dflags + +-- | The directory for this version of ghc in the user's app directory +-- (typically something like @~/.ghc/x86_64-linux-7.6.3@) +-- +versionedAppDir :: String -> PlatformMini -> MaybeT IO FilePath +versionedAppDir appname platform = do + -- Make sure we handle the case the HOME isn't set (see #11678) + appdir <- tryMaybeT $ getAppUserDataDirectory appname + return $ appdir versionedFilePath platform + +versionedFilePath :: PlatformMini -> FilePath +versionedFilePath platform = uniqueSubdir platform + +-- | The target code type of the compilation (if any). +-- +-- Whenever you change the target, also make sure to set 'ghcLink' to +-- something sensible. +-- +-- 'HscNothing' can be used to avoid generating any output, however, note +-- that: +-- +-- * If a program uses Template Haskell the typechecker may need to run code +-- from an imported module. To facilitate this, code generation is enabled +-- for modules imported by modules that use template haskell. +-- See Note [-fno-code mode]. +-- +data HscTarget + = HscC -- ^ Generate C code. + | HscAsm -- ^ Generate assembly using the native code generator. + | HscLlvm -- ^ Generate assembly using the llvm code generator. + | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') + | HscNothing -- ^ Don't generate any code. See notes above. + deriving (Eq, Show) + +-- | Will this target result in an object file on the disk? +isObjectTarget :: HscTarget -> Bool +isObjectTarget HscC = True +isObjectTarget HscAsm = True +isObjectTarget HscLlvm = True +isObjectTarget _ = False + +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + +-- | The 'GhcMode' tells us whether we're doing multi-module +-- compilation (controlled via the "GHC" API) or one-shot +-- (single-module) compilation. This makes a difference primarily to +-- the "GHC.Driver.Finder": in one-shot mode we look for interface files for +-- imported modules, but in multi-module mode we look for source files +-- in order to check whether they need to be recompiled. +data GhcMode + = CompManager -- ^ @\-\-make@, GHCi, etc. + | OneShot -- ^ @ghc -c Foo.hs@ + | MkDepend -- ^ @ghc -M@, see "GHC.Driver.Finder" for why we need this + deriving Eq + +instance Outputable GhcMode where + ppr CompManager = text "CompManager" + ppr OneShot = text "OneShot" + ppr MkDepend = text "MkDepend" + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +-- | What to do in the link step, if there is one. +data GhcLink + = NoLink -- ^ Don't link at all + | LinkBinary -- ^ Link object code into a binary + | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both + -- bytecode and object code). + | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib + deriving (Eq, Show) + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink _ = False + +-- | We accept flags which make packages visible, but how they select +-- the package varies; this data type reflects what selection criterion +-- is used. +data PackageArg = + PackageArg String -- ^ @-package@, by 'PackageName' + | UnitIdArg Unit -- ^ @-package-id@, by 'Unit' + deriving (Eq, Show) + +instance Outputable PackageArg where + ppr (PackageArg pn) = text "package" <+> text pn + ppr (UnitIdArg uid) = text "unit" <+> ppr uid + +-- | Represents the renaming that may be associated with an exposed +-- package, e.g. the @rns@ part of @-package "foo (rns)"@. +-- +-- Here are some example parsings of the package flags (where +-- a string literal is punned to be a 'ModuleName': +-- +-- * @-package foo@ is @ModRenaming True []@ +-- * @-package foo ()@ is @ModRenaming False []@ +-- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ +-- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ +-- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ +data ModRenaming = ModRenaming { + modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? + modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope + -- under name @n@. + } deriving (Eq) +instance Outputable ModRenaming where + ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) + +-- | Flags for manipulating the set of non-broken packages. +newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ + deriving (Eq) + +-- | Flags for manipulating package trust. +data TrustFlag + = TrustPackage String -- ^ @-trust@ + | DistrustPackage String -- ^ @-distrust@ + deriving (Eq) + +-- | Flags for manipulating packages visibility. +data PackageFlag + = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ + | HidePackage String -- ^ @-hide-package@ + deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + +data PackageDBFlag + = PackageDB PkgDbRef + | NoUserPackageDB + | NoGlobalPackageDB + | ClearPackageDBs + deriving (Eq) + +packageFlagsChanged :: DynFlags -> DynFlags -> Bool +packageFlagsChanged idflags1 idflags0 = + packageFlags idflags1 /= packageFlags idflags0 || + ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || + pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || + trustFlags idflags1 /= trustFlags idflags0 || + packageDBFlags idflags1 /= packageDBFlags idflags0 || + packageGFlags idflags1 /= packageGFlags idflags0 + where + packageGFlags dflags = map (`gopt` dflags) + [ Opt_HideAllPackages + , Opt_HideAllPluginPackages + , Opt_AutoLinkPackages ] + +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + +-- | The 'HscTarget' value corresponding to the default way to create +-- object files on the current platform. + +defaultHscTarget :: Platform -> HscTarget +defaultHscTarget platform + | platformUnregisterised platform = HscC + | NCG <- platformDefaultBackend platform = HscAsm + | otherwise = HscLlvm + +defaultObjectTarget :: DynFlags -> HscTarget +defaultObjectTarget dflags = defaultHscTarget + (targetPlatform dflags) + +data DynLibLoader + = Deployable + | SystemDependent + deriving Eq + +data RtsOptsEnabled + = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly + | RtsOptsAll + deriving (Show) + +-- | Are we building with @-fPIE@ or @-fPIC@ enabled? +positionIndependent :: DynFlags -> Bool +positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags + +whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) + +ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g + +whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenCannotGenerateDynamicToo dflags f + = ifCannotGenerateDynamicToo dflags f (return ()) + +ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifCannotGenerateDynamicToo dflags f g + = generateDynamicTooConditional dflags g f g + +generateDynamicTooConditional :: MonadIO m + => DynFlags -> m a -> m a -> m a -> m a +generateDynamicTooConditional dflags canGen cannotGen notTryingToGen + = if gopt Opt_BuildDynamicToo dflags + then do let ref = canGenerateDynamicToo dflags + b <- liftIO $ readIORef ref + if b then canGen else cannotGen + else notTryingToGen + +dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags +dynamicTooMkDynamicDynFlags dflags0 + = let dflags1 = addWay' WayDyn dflags0 + dflags2 = dflags1 { + outputFile = dynOutputFile dflags1, + hiSuf = dynHiSuf dflags1, + objectSuf = dynObjectSuf dflags1 + } + dflags3 = gopt_unset dflags2 Opt_BuildDynamicToo + in dflags3 + +-- | Compute the path of the dynamic object corresponding to an object file. +dynamicOutputFile :: DynFlags -> FilePath -> FilePath +dynamicOutputFile dflags outputFile = dynOut outputFile + where + dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension + +----------------------------------------------------------------------------- + +-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value +initDynFlags :: DynFlags -> IO DynFlags +initDynFlags dflags = do + let -- We can't build with dynamic-too on Windows, as labels before + -- the fork point are different depending on whether we are + -- building dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo + refNextTempSuffix <- newIORef 0 + refFilesToClean <- newIORef emptyFilesToClean + refDirsToClean <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty + refRtldInfo <- newIORef Nothing + refRtccInfo <- newIORef Nothing + wrapperNum <- newIORef emptyModuleEnv + canUseUnicode <- do let enc = localeEncoding + str = "‘’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False + ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" + let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode + maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" + maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" + let adjustCols (Just env) = Col.parseScheme env + adjustCols Nothing = id + let (useColor', colScheme') = + (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) + (useColor dflags, colScheme dflags) + return dflags{ + canGenerateDynamicToo = refCanGenerateDynamicToo, + nextTempSuffix = refNextTempSuffix, + filesToClean = refFilesToClean, + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps, + nextWrapperNum = wrapperNum, + useUnicode = useUnicode', + useColor = useColor', + canUseColor = stderrSupportsAnsiColors, + colScheme = colScheme', + rtldInfo = refRtldInfo, + rtccInfo = refRtccInfo + } + +-- | The normal 'DynFlags'. Note that they are not suitable for use in this form +-- and must be fully initialized by 'GHC.runGhc' first. +defaultDynFlags :: Settings -> LlvmConfig -> DynFlags +defaultDynFlags mySettings llvmConfig = +-- See Note [Updating flag description in the User's Guide] + DynFlags { + ghcMode = CompManager, + ghcLink = LinkBinary, + hscTarget = defaultHscTarget (sTargetPlatform mySettings), + verbosity = 0, + optLevel = 0, + debugLevel = 0, + simplPhases = 2, + maxSimplIterations = 4, + ruleCheck = Nothing, + inlineCheck = Nothing, + binBlobThreshold = 500000, -- 500K is a good default (see #16190) + maxRelevantBinds = Just 6, + maxValidHoleFits = Just 6, + maxRefHoleFits = Just 6, + refLevelHoleFits = Nothing, + maxUncoveredPatterns = 4, + maxPmCheckModels = 30, + simplTickFactor = 100, + specConstrThreshold = Just 2000, + specConstrCount = Just 3, + specConstrRecursive = 3, + liberateCaseThreshold = Just 2000, + floatLamArgs = Just 0, -- Default: float only if no fvs + liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsKnown = False, -- Default: don't turn known calls into unknown ones + cmmProcAlignment = Nothing, + + historySize = 20, + strictnessBefore = [], + + parMakeCount = Just 1, + + enableTimeStats = False, + ghcHeapSize = Nothing, + + importPaths = ["."], + mainModIs = mAIN, + mainFunIs = Nothing, + reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, + solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, + + homeUnitId = mainUnitId, + homeUnitInstanceOfId = Nothing, + homeUnitInstantiations = [], + + objectDir = Nothing, + dylibInstallName = Nothing, + hiDir = Nothing, + hieDir = Nothing, + stubDir = Nothing, + dumpDir = Nothing, + + objectSuf = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf = "hi", + hieSuf = "hie", + + canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", + dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, + dynHiSuf = "dyn_hi", + + pluginModNames = [], + pluginModNameOpts = [], + frontendPluginOpts = [], + cachedPlugins = [], + staticPlugins = [], + hooks = emptyHooks, + + outputFile = Nothing, + dynOutputFile = Nothing, + outputHi = Nothing, + dynLibLoader = SystemDependent, + dumpPrefix = Nothing, + dumpPrefixForce = Nothing, + ldInputs = [], + includePaths = IncludeSpecs [] [] [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, + rtsOptsSuggestions = True, + + hpcDir = ".hpc", + + packageDBFlags = [], + packageFlags = [], + pluginPackageFlags = [], + ignorePackageFlags = [], + trustFlags = [], + packageEnv = Nothing, + unitDatabases = Nothing, + unitState = emptyUnitState, + ways = defaultWays mySettings, + splitInfo = Nothing, + + ghcNameVersion = sGhcNameVersion mySettings, + fileSettings = sFileSettings mySettings, + toolSettings = sToolSettings mySettings, + targetPlatform = sTargetPlatform mySettings, + platformMisc = sPlatformMisc mySettings, + platformConstants = sPlatformConstants mySettings, + rawSettings = sRawSettings mySettings, + + -- See Note [LLVM configuration]. + llvmConfig = llvmConfig, + + -- ghc -M values + depMakefile = "Makefile", + depIncludePkgDeps = False, + depIncludeCppDeps = False, + depExcludeMods = [], + depSuffixes = [], + -- end of ghc -M values + nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", + filesToClean = panic "defaultDynFlags: No filesToClean", + dirsToClean = panic "defaultDynFlags: No dirsToClean", + generatedDumps = panic "defaultDynFlags: No generatedDumps", + ghcVersionFile = Nothing, + haddockOptions = Nothing, + dumpFlags = EnumSet.empty, + generalFlags = EnumSet.fromList (defaultFlags mySettings), + warningFlags = EnumSet.fromList standardWarnings, + fatalWarningFlags = EnumSet.empty, + ghciScripts = [], + language = Nothing, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, + deriveViaOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, + incoherentOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, + warnSafeOnLoc = noSrcSpan, + warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], + + ufCreationThreshold = 750, + -- The ufCreationThreshold threshold must be reasonably high + -- to take account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to + -- inline into Csg.calc (The unfolding for sqr never makes it + -- into the interface file.) + + ufUseThreshold = 90, + -- Last adjusted upwards in #18282, when I reduced + -- the result discount for constructors. + + ufFunAppDiscount = 60, + -- Be fairly keen to inline a function if that means + -- we'll be able to pick the right method from a dictionary + + ufDictDiscount = 30, + ufDearOp = 40, + ufVeryAggressive = False, + + maxWorkerArgs = 10, + + ghciHistSize = 50, -- keep a log of length 50 by default + + -- Logging + + log_action = defaultLogAction, + dump_action = defaultDumpAction, + trace_action = defaultTraceAction, + + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, + pprUserLength = 5, + pprCols = 100, + useUnicode = False, + useColor = Auto, + canUseColor = False, + colScheme = Col.defaultScheme, + profAuto = NoProfAuto, + interactivePrint = Nothing, + nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", + sseVersion = Nothing, + bmiVersion = Nothing, + avx = False, + avx2 = False, + avx512cd = False, + avx512er = False, + avx512f = False, + avx512pf = False, + rtldInfo = panic "defaultDynFlags: no rtldInfo", + rtccInfo = panic "defaultDynFlags: no rtccInfo", + + maxInlineAllocSize = 128, + maxInlineMemcpyInsns = 32, + maxInlineMemsetInsns = 32, + + initialUnique = 0, + uniqueIncrement = 1, + + reverseErrors = False, + maxErrors = Nothing, + cfgWeightInfo = defaultCfgWeights + } + +defaultWays :: Settings -> Set Way +defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) + then Set.singleton WayDyn + else Set.empty + +-------------------------------------------------------------------------- +-- +-- Note [JSON Error Messages] +-- +-- When the user requests the compiler output to be dumped as json +-- we used to collect them all in an IORef and then print them at the end. +-- This doesn't work very well with GHCi. (See #14078) So instead we now +-- use the simpler method of just outputting a JSON document inplace to +-- stdout. +-- +-- Before the compiler calls log_action, it has already turned the `ErrMsg` +-- into a formatted message. This means that we lose some possible +-- information to provide to the user but refactoring log_action is quite +-- invasive as it is called in many places. So, for now I left it alone +-- and we can refine its behaviour as users request different output. + +type FatalMessager = String -> IO () + +type LogAction = DynFlags + -> WarnReason + -> Severity + -> SrcSpan + -> MsgDoc + -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr + + +-- See Note [JSON Error Messages] +-- +jsonLogAction :: LogAction +jsonLogAction dflags reason severity srcSpan msg + = do + defaultLogActionHPutStrDoc dflags stdout + (withPprStyle (mkCodeStyle CStyle) (doc $$ text "")) + where + doc = renderJSON $ + JSObject [ ( "span", json srcSpan ) + , ( "doc" , JSString (showSDoc dflags msg) ) + , ( "severity", json severity ) + , ( "reason" , json reason ) + ] + + +defaultLogAction :: LogAction +defaultLogAction dflags reason severity srcSpan msg + = case severity of + SevOutput -> printOut msg + SevDump -> printOut (msg $$ blankLine) + SevInteractive -> putStrSDoc msg + SevInfo -> printErrs msg + SevFatal -> printErrs msg + SevWarning -> printWarns + SevError -> printWarns + where + printOut = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags stdout + -- Pretty print the warning flag, if any (#10752) + message = mkLocMessageAnn flagMsg severity srcSpan msg + + printWarns = do + hPutChar stderr '\n' + caretDiagnostic <- + if gopt Opt_DiagnosticsShowCaret dflags + then getCaretDiagnostic severity srcSpan + else pure empty + printErrs $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic) + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + + flagMsg = + case reason of + NoReason -> Nothing + Reason wflag -> do + spec <- flagSpecOf wflag + return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) + ErrReason Nothing -> + return "-Werror" + ErrReason (Just wflag) -> do + spec <- flagSpecOf wflag + return $ + "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ + ", -Werror=" ++ flagSpecName spec + + warnFlagGrp flag + | gopt Opt_ShowWarnGroups dflags = + case smallestGroups flag of + [] -> "" + groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + | otherwise = "" + +-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO () +defaultLogActionHPrintDoc dflags h d + = defaultLogActionHPutStrDoc dflags h (d $$ text "") + +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO () +defaultLogActionHPutStrDoc dflags h d + -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + = printSDoc ctx Pretty.PageMode h d + where ctx = initSDocContext dflags defaultUserStyle + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + +{- +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +data OnOff a = On a + | Off a + deriving (Eq, Show) + +instance Outputable a => Outputable (OnOff a) where + ppr (On x) = text "On" <+> ppr x + ppr (Off x) = text "Off" <+> ppr x + +-- OnOffs accumulate in reverse order, so we use foldr in order to +-- process them in the right order +flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension +flattenExtensionFlags ml = foldr f defaultExtensionFlags + where f (On f) flags = EnumSet.insert f flags + f (Off f) flags = EnumSet.delete f flags + defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) + +-- | The language extensions implied by the various language variants. +-- When updating this be sure to update the flag documentation in +-- @docs/users_guide/exts@. +languageExtensions :: Maybe Language -> [LangExt.Extension] + +languageExtensions Nothing + -- Nothing => the default case + = LangExt.NondecreasingIndentation -- This has been on by default for some time + : delete LangExt.DatatypeContexts -- The Haskell' committee decided to + -- remove datatype contexts from the + -- language: + -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html + (languageExtensions (Just Haskell2010)) + + -- NB: MonoPatBinds is no longer the default + +languageExtensions (Just Haskell98) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.NPlusKPatterns, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.NondecreasingIndentation + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + ] + +languageExtensions (Just Haskell2010) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.RelaxedPolyRec] + +hasPprDebug :: DynFlags -> Bool +hasPprDebug = dopt Opt_D_ppr_debug + +hasNoDebugOutput :: DynFlags -> Bool +hasNoDebugOutput = dopt Opt_D_no_debug_output + +hasNoStateHack :: DynFlags -> Bool +hasNoStateHack = gopt Opt_G_NoStateHack + +hasNoOptCoercion :: DynFlags -> Bool +hasNoOptCoercion = gopt Opt_G_NoOptCoercion + + +-- | Test whether a 'DumpFlag' is set +dopt :: DumpFlag -> DynFlags -> Bool +dopt f dflags = (f `EnumSet.member` dumpFlags dflags) + || (verbosity dflags >= 4 && enableIfVerbose f) + where enableIfVerbose Opt_D_dump_tc_trace = False + enableIfVerbose Opt_D_dump_rn_trace = False + enableIfVerbose Opt_D_dump_cs_trace = False + enableIfVerbose Opt_D_dump_if_trace = False + enableIfVerbose Opt_D_dump_vt_trace = False + enableIfVerbose Opt_D_dump_tc = False + enableIfVerbose Opt_D_dump_rn = False + enableIfVerbose Opt_D_dump_rn_stats = False + enableIfVerbose Opt_D_dump_hi_diffs = False + enableIfVerbose Opt_D_verbose_core2core = False + enableIfVerbose Opt_D_verbose_stg2stg = False + enableIfVerbose Opt_D_dump_splices = False + enableIfVerbose Opt_D_th_dec_file = False + enableIfVerbose Opt_D_dump_rule_firings = False + enableIfVerbose Opt_D_dump_rule_rewrites = False + enableIfVerbose Opt_D_dump_simpl_trace = False + enableIfVerbose Opt_D_dump_rtti = False + enableIfVerbose Opt_D_dump_inlinings = False + enableIfVerbose Opt_D_dump_verbose_inlinings = False + enableIfVerbose Opt_D_dump_core_stats = False + enableIfVerbose Opt_D_dump_asm_stats = False + enableIfVerbose Opt_D_dump_types = False + enableIfVerbose Opt_D_dump_simpl_iterations = False + enableIfVerbose Opt_D_dump_ticked = False + enableIfVerbose Opt_D_dump_view_pattern_commoning = False + enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False + enableIfVerbose Opt_D_dump_ec_trace = False + enableIfVerbose _ = True + +-- | Set a 'DumpFlag' +dopt_set :: DynFlags -> DumpFlag -> DynFlags +dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } + +-- | Unset a 'DumpFlag' +dopt_unset :: DynFlags -> DumpFlag -> DynFlags +dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } + +-- | Test whether a 'GeneralFlag' is set +gopt :: GeneralFlag -> DynFlags -> Bool +gopt f dflags = f `EnumSet.member` generalFlags dflags + +-- | Set a 'GeneralFlag' +gopt_set :: DynFlags -> GeneralFlag -> DynFlags +gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } + +-- | Unset a 'GeneralFlag' +gopt_unset :: DynFlags -> GeneralFlag -> DynFlags +gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } + +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `EnumSet.member` warningFlags dflags + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } + +-- | Test whether a 'WarningFlag' is set as fatal +wopt_fatal :: WarningFlag -> DynFlags -> Bool +wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags + +-- | Mark a 'WarningFlag' as fatal (do not set the flag) +wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_set_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } + +-- | Mark a 'WarningFlag' as not fatal +wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_unset_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + +-- | Test whether a 'LangExt.Extension' is set +xopt :: LangExt.Extension -> DynFlags -> Bool +xopt f dflags = f `EnumSet.member` extensionFlags dflags + +-- | Set a 'LangExt.Extension' +xopt_set :: DynFlags -> LangExt.Extension -> DynFlags +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Unset a 'LangExt.Extension' +xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Set or unset a 'LangExt.Extension', unless it has been explicitly +-- set or unset before. +xopt_set_unlessExplSpec + :: LangExt.Extension + -> (DynFlags -> LangExt.Extension -> DynFlags) + -> DynFlags -> DynFlags +xopt_set_unlessExplSpec ext setUnset dflags = + let referedExts = stripOnOff <$> extensions dflags + stripOnOff (On x) = x + stripOnOff (Off x) = x + in + if ext `elem` referedExts then dflags else setUnset dflags ext + +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + +-- | Set the Haskell language standard to use +setLanguage :: Language -> DynP () +setLanguage l = upd (`lang_set` Just l) + +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = gopt Opt_PackageTrust + +-- | Is Safe Haskell on in some way (including inference mode) +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags + +safeHaskellModeEnabled :: DynFlags -> Bool +safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy + , Sf_Safe ] + + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Is the Safe Haskell safe inference mode active +safeInferOn :: DynFlags -> Bool +safeInferOn = safeInfer + +-- | Test if Safe Imports are on in some form +safeImportsOn :: DynFlags -> Bool +safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || + safeHaskell dflags == Sf_Trustworthy || + safeHaskell dflags == Sf_Safe + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inferrence on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq d = safeLanguageOn d + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq d = safeLanguageOn d + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b | a == Sf_None = return b + | b == Sf_None = return a + | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore + | a == b = return a + | otherwise = addErr errm >> pure a + where errm = "Incompatible Safe Haskell flags! (" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags, unsafeFlagsForInfer + :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt LangExt.GeneralizedNewtypeDeriving, + flip xopt_unset LangExt.GeneralizedNewtypeDeriving) + , ("-XDerivingVia", deriveViaOnLoc, + xopt LangExt.DerivingVia, + flip xopt_unset LangExt.DerivingVia) + , ("-XTemplateHaskell", thOnLoc, + xopt LangExt.TemplateHaskell, + flip xopt_unset LangExt.TemplateHaskell) + ] +unsafeFlagsForInfer = unsafeFlags + + +-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order +getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from + -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors + -> [a] -- ^ Correctly ordered extracted options +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +-- | Gets the verbosity flag for the current verbosity level. This is fed to +-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] + +setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, + setDynObjectSuf, setDynHiSuf, + setDylibInstallName, + setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, + setPgmP, addOptl, addOptc, addOptcxx, addOptP, + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint + :: String -> DynFlags -> DynFlags +setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce + :: Maybe String -> DynFlags -> DynFlags + +setObjectDir f d = d { objectDir = Just f} +setHiDir f d = d { hiDir = Just f} +setHieDir f d = d { hieDir = Just f} +setStubDir f d = d { stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). +setDumpDir f d = d { dumpDir = Just f} +setOutputDir f = setObjectDir f + . setHieDir f + . setHiDir f + . setStubDir f + . setDumpDir f +setDylibInstallName f d = d { dylibInstallName = Just f} + +setObjectSuf f d = d { objectSuf = f} +setDynObjectSuf f d = d { dynObjectSuf = f} +setHiSuf f d = d { hiSuf = f} +setHieSuf f d = d { hieSuf = f} +setDynHiSuf f d = d { dynHiSuf = f} +setHcSuf f d = d { hcSuf = f} + +setOutputFile f d = d { outputFile = f} +setDynOutputFile f d = d { dynOutputFile = f} +setOutputHi f d = d { outputHi = f} + +setJsonLogAction :: DynFlags -> DynFlags +setJsonLogAction d = d { log_action = jsonLogAction } + +-- | Make a module in home unit +mkHomeModule :: DynFlags -> ModuleName -> Module +mkHomeModule dflags = mkModule (homeUnit dflags) + +-- | Test if the module comes from the home unit +isHomeModule :: DynFlags -> Module -> Bool +isHomeModule dflags m = moduleUnit m == homeUnit dflags + +-- | Get home unit +homeUnit :: DynFlags -> Unit +homeUnit dflags = + case (homeUnitInstanceOfId dflags, homeUnitInstantiations dflags) of + (Nothing,[]) -> RealUnit (Definite (homeUnitId dflags)) + (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with") + (Just u, is) + -- detect fully indefinite units: all their instantiations are hole + -- modules and the home unit id is the same as the instantiating unit + -- id (see Note [About units] in GHC.Unit) + | all (isHoleModule . snd) is && indefUnit u == homeUnitId dflags + -> mkVirtUnit (updateIndefUnitId (unitState dflags) u) is + -- otherwise it must be that we compile a fully definite units + -- TODO: error when the unit is partially instantiated?? + | otherwise + -> RealUnit (Definite (homeUnitId dflags)) + +parseUnitInsts :: String -> Instantiations +parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') + parseEntry = do + n <- parseModuleName + _ <- R.char '=' + m <- parseHoleyModule + return (n, m) + +setUnitInstantiations :: String -> DynFlags -> DynFlags +setUnitInstantiations s d = + d { homeUnitInstantiations = parseUnitInsts s } + +setUnitInstanceOf :: String -> DynFlags -> DynFlags +setUnitInstanceOf s d = + d { homeUnitInstanceOfId = Just (Indefinite (UnitId (fsLit s)) Nothing) } + +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +clearPluginModuleNames :: DynFlags -> DynFlags +clearPluginModuleNames d = + d { pluginModNames = [] + , pluginModNameOpts = [] + , cachedPlugins = [] } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + +addFrontendPluginOption :: String -> DynFlags -> DynFlags +addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } + +parseDynLibLoaderMode f d = + case splitAt 8 f of + ("deploy", "") -> d { dynLibLoader = Deployable } + ("sysdep", "") -> d { dynLibLoader = SystemDependent } + _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) + +setDumpPrefixForce f d = d { dumpPrefixForce = f} + +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) + where (pgm:args) = words f +addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) +addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) +addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + -- See Note [Repeated -optP hashing] + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + + +setDepMakefile :: FilePath -> DynFlags -> DynFlags +setDepMakefile f d = d { depMakefile = f } + +setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags +setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } + +setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags +setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } + +addDepExcludeMod :: String -> DynFlags -> DynFlags +addDepExcludeMod m d + = d { depExcludeMods = mkModuleName m : depExcludeMods d } + +addDepSuffix :: FilePath -> DynFlags -> DynFlags +addDepSuffix s d = d { depSuffixes = s : depSuffixes d } + +addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} + +addGhcVersionFile :: FilePath -> DynFlags -> DynFlags +addGhcVersionFile f d = d { ghcVersionFile = Just f } + +addHaddockOpts f d = d { haddockOptions = Just f} + +addGhciScript f d = d { ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d { interactivePrint = Just f} + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevel :: Int -> DynFlags -> DynFlags +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level +updOptLevel n dfs + = dfs2{ optLevel = final_n } + where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 + dfs1 = foldr (flip gopt_unset) dfs remove_gopts + dfs2 = foldr (flip gopt_set) dfs1 extra_gopts + + extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] + +{- ********************************************************************** +%* * + DynFlags parser +%* * +%********************************************************************* -} + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + + +-- | Parse dynamic flags from a list of command line arguments. Returns +-- the parsed 'DynFlags', the left-over arguments, and a list of warnings. +-- Throws a 'UsageError' if errors occurred during parsing (such as unknown +-- flags or missing arguments). +parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + + +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull :: MonadIO m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse + -> m (DynFlags, [Located String], [Warn]) +parseDynamicFlagsFull activeFlags cmdline dflags0 args = do + let ((leftover, errs, warns), dflags1) + = runCmdLine (processArgs activeFlags args) dflags0 + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ + map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs + + -- check for disabled flags in safe haskell + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + theWays = ways dflags2 + + unless (allowed_combination theWays) $ liftIO $ + throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc (Set.toAscList theWays)))) + + let chooseOutput + | isJust (outputFile dflags2) -- Only iff user specified -o ... + , not (isJust (dynOutputFile dflags2)) -- but not -dyno + = return $ dflags2 { dynOutputFile = Just $ dynamicOutputFile dflags2 outFile } + | otherwise + = return dflags2 + where + outFile = fromJust $ outputFile dflags2 + dflags3 <- ifGeneratingDynamicToo dflags2 chooseOutput (return dflags2) + + let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3 + + -- Set timer stats & heap size + when (enableTimeStats dflags4) $ liftIO enableTimingStats + case (ghcHeapSize dflags4) of + Just x -> liftIO (setHeapSize x) + _ -> return () + + liftIO $ setUnsafeGlobalDynFlags dflags4 + + let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) + + return (dflags4, leftover, warns' ++ warns) + +-- | Write an error or warning to the 'LogOutput'. +putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO () +putLogMsg dflags = log_action dflags dflags + +-- | Check (and potentially disable) any extensions that aren't allowed +-- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags + + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure (loc df) str) + | otherwise = (df, warns) + + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " + ++ str] + +safeFlagCheck cmdl dflags = + case (safeInferOn dflags) of + True | safeFlags -> (dflags', warn) + True -> (dflags' { safeInferred = False }, warn) + False -> (dflags', warn) + + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, []) + + pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] + + -- Have we inferred Unsafe? See Note [GHC.Driver.Main . Safe Haskell Inference] + safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + + +{- ********************************************************************** +%* * + DynFlags specifications +%* * +%********************************************************************* -} + +-- | All dynamic flags option strings without the deprecated ones. +-- These are the user facing strings for enabling and disabling options. +allNonDeprecatedFlags :: [String] +allNonDeprecatedFlags = allFlagsDeps False + +-- | All flags with possibility to filter deprecated ones +allFlagsDeps :: Bool -> [String] +allFlagsDeps keepDeprecated = [ '-':flagName flag + | (deprecated, flag) <- flagsAllDeps + , keepDeprecated || not (isDeprecated deprecated)] + where isDeprecated Deprecated = True + isDeprecated _ = False + +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = map snd flagsAllDeps + +-- All dynamic flags present in GHC with deprecation information. +flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] +flagsAllDeps = package_flags_deps ++ dynamic_flags_deps + + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = map snd dynamic_flags_deps + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = map snd package_flags_deps + +----------------Helpers to make flags and keep deprecation information---------- + +type FlagMaker m = String -> OptKind m -> Flag m +type DynFlagMaker = FlagMaker (CmdLineP DynFlags) +data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) + +-- Make a non-deprecated flag +make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_ord_flag fm name kind = (NotDeprecated, fm name kind) + +-- Make a deprecated flag +make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_dep_flag fm name kind message = (Deprecated, + fm name $ add_dep_message kind message) + +add_dep_message :: OptKind (CmdLineP DynFlags) -> String + -> OptKind (CmdLineP DynFlags) +add_dep_message (NoArg f) message = NoArg $ f >> deprecate message +add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message +add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message +add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message +add_dep_message (OptPrefix f) message = + OptPrefix $ \s -> f s >> deprecate message +add_dep_message (OptIntSuffix f) message = + OptIntSuffix $ \oi -> f oi >> deprecate message +add_dep_message (IntSuffix f) message = + IntSuffix $ \i -> f i >> deprecate message +add_dep_message (FloatSuffix f) message = + FloatSuffix $ \fl -> f fl >> deprecate message +add_dep_message (PassFlag f) message = + PassFlag $ \s -> f s >> deprecate message +add_dep_message (AnySuffix f) message = + AnySuffix $ \s -> f s >> deprecate message + +----------------------- The main flags themselves ------------------------------ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +dynamic_flags_deps = [ + make_dep_flag defFlag "n" (NoArg $ return ()) + "The -n flag is deprecated and no longer has any effect" + , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) + , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) + , (Deprecated, defFlag "#include" + (HasArg (\_s -> + deprecate ("-#include and INCLUDE pragmas are " ++ + "deprecated: They no longer have any effect")))) + , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) + + , make_ord_flag defGhcFlag "j" (OptIntSuffix + (\n -> case n of + Just n + | n > 0 -> upd (\d -> d { parMakeCount = Just n }) + | otherwise -> addErr "Syntax: -j[n] where n > 0" + Nothing -> upd (\d -> d { parMakeCount = Nothing }))) + -- When the number of parallel builds + -- is omitted, it is the same + -- as specifying that the number of + -- parallel builds is equal to the + -- result of getNumProcessors + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitInstantiations) + , make_ord_flag defFlag "this-component-id" (sepArg setUnitInstanceOf) + + -- RTS options ------------------------------------------------------------- + , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> + d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) + + , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> + d { enableTimeStats = True }))) + + ------- ways --------------------------------------------------------------- + , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf)) + , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) + , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) + , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) + + , make_ord_flag defGhcFlag "ticky" + (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) + , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn)) + , make_ord_flag defGhcFlag "rdynamic" $ noArg $ +#if defined(linux_HOST_OS) + addOptl "-rdynamic" +#elif defined(mingw32_HOST_OS) + addOptl "-Wl,--export-all-symbols" +#else + -- ignored for compat w/ gcc: + id +#endif + , make_ord_flag defGhcFlag "relative-dynlib-paths" + (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) + , make_ord_flag defGhcFlag "copy-libs-when-linking" + (NoArg (setGeneralFlag Opt_SingleLibFolder)) + , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) + , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) + + ------- Specific phases -------------------------------------------- + -- need to appear before -pgmL to be parsed as LLVM flags. + , make_ord_flag defFlag "pgmlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } + , make_ord_flag defFlag "pgmlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) } + , make_ord_flag defFlag "pgmlm" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm = (f,[]) } + , make_ord_flag defFlag "pgmi" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } + , make_ord_flag defFlag "pgmL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } + , make_ord_flag defFlag "pgmP" + (hasArg setPgmP) + , make_ord_flag defFlag "pgmF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } + , make_ord_flag defFlag "pgmc" + $ hasArg $ \f -> alterToolSettings $ \s -> s + { toolSettings_pgm_c = f + , -- Don't pass -no-pie with -pgmc + -- (see #15319) + toolSettings_ccSupportsNoPie = False + } + , make_ord_flag defFlag "pgmc-supports-no-pie" + $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True } + , make_ord_flag defFlag "pgms" + (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) + , make_ord_flag defFlag "pgma" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } + , make_ord_flag defFlag "pgml" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_l = (f,[]) } + , make_ord_flag defFlag "pgmdll" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) } + , make_ord_flag defFlag "pgmwindres" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } + , make_ord_flag defFlag "pgmlibtool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f } + , make_ord_flag defFlag "pgmar" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } + , make_ord_flag defFlag "pgmotool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f} + , make_ord_flag defFlag "pgminstall_name_tool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f} + , make_ord_flag defFlag "pgmranlib" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } + + + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , make_ord_flag defFlag "optlm" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm = f : toolSettings_opt_lm s } + , make_ord_flag defFlag "optlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } + , make_ord_flag defFlag "optlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc = f : toolSettings_opt_lc s } + , make_ord_flag defFlag "opti" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } + , make_ord_flag defFlag "optL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } + , make_ord_flag defFlag "optP" + (hasArg addOptP) + , make_ord_flag defFlag "optF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } + , make_ord_flag defFlag "optc" + (hasArg addOptc) + , make_ord_flag defFlag "optcxx" + (hasArg addOptcxx) + , make_ord_flag defFlag "opta" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } + , make_ord_flag defFlag "optl" + (hasArg addOptl) + , make_ord_flag defFlag "optwindres" + $ hasArg $ \f -> + alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } + + , make_ord_flag defGhcFlag "split-objs" + (NoArg $ addWarn "ignoring -split-objs") + + , make_ord_flag defGhcFlag "split-sections" + (noArgM (\dflags -> do + if platformHasSubsectionsViaSymbols (targetPlatform dflags) + then do addWarn $ + "-split-sections is not useful on this platform " ++ + "since it always uses subsections via symbols. Ignoring." + return dflags + else return (gopt_set dflags Opt_SplitSections))) + + -------- ghc -M ----------------------------------------------------- + , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) + , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "include-cpp-deps" + (noArg (setDepIncludeCppDeps True)) + , make_ord_flag defGhcFlag "include-pkg-deps" + (noArg (setDepIncludePkgDeps True)) + , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + + -------- Linking ---------------------------------------------------- + , make_ord_flag defGhcFlag "no-link" + (noArg (\d -> d { ghcLink=NoLink })) + , make_ord_flag defGhcFlag "shared" + (noArg (\d -> d { ghcLink=LinkDynLib })) + , make_ord_flag defGhcFlag "staticlib" + (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib }))) + , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) + , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) + + ------- Libraries --------------------------------------------------- + , make_ord_flag defFlag "L" (Prefix addLibraryPath) + , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) + , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) + + ------- Output Redirection ------------------------------------------ + , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) + , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) + , make_ord_flag defGhcFlag "dyno" + (sepArg (setDynOutputFile . Just)) + , make_ord_flag defGhcFlag "ohi" + (hasArg (setOutputHi . Just )) + , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) + , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) + , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) + , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) + , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) + , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) + , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) + , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) + , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) + , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) + , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) + , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) + , make_ord_flag defGhcFlag "ddump-file-prefix" + (hasArg (setDumpPrefixForce . Just)) + + , make_ord_flag defGhcFlag "dynamic-too" + (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + + ------- Keeping temporary files ------------------------------------- + -- These can be singular (think ghc -c) or plural (think ghc --make) + , make_ord_flag defGhcFlag "keep-hc-file" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hc-files" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-file" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-files" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-s-file" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-s-files" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-llvm-file" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + , make_ord_flag defGhcFlag "keep-llvm-files" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + -- This only makes sense as plural + , make_ord_flag defGhcFlag "keep-tmp-files" + (NoArg (setGeneralFlag Opt_KeepTmpFiles)) + , make_ord_flag defGhcFlag "keep-hi-file" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-file" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-hi-files" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-files" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-o-file" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-file" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "keep-o-files" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-files" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + + ------- Miscellaneous ---------------------------------------------- + , make_ord_flag defGhcFlag "no-auto-link-packages" + (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) + , make_ord_flag defGhcFlag "no-hs-main" + (NoArg (setGeneralFlag Opt_NoHsMain)) + , make_ord_flag defGhcFlag "fno-state-hack" + (NoArg (setGeneralFlag Opt_G_NoStateHack)) + , make_ord_flag defGhcFlag "fno-opt-coercion" + (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) + , make_ord_flag defGhcFlag "with-rtsopts" + (HasArg setRtsOpts) + , make_ord_flag defGhcFlag "rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=all" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=some" + (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , make_ord_flag defGhcFlag "rtsopts=none" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "rtsopts=ignore" + (NoArg (setRtsOptsEnabled RtsOptsIgnore)) + , make_ord_flag defGhcFlag "rtsopts=ignoreAll" + (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) + , make_ord_flag defGhcFlag "no-rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "no-rtsopts-suggestions" + (noArg (\d -> d {rtsOptsSuggestions = False})) + , make_ord_flag defGhcFlag "dhex-word-literals" + (NoArg (setGeneralFlag Opt_HexWordLiterals)) + + , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) + , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) + , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "no-haddock" (NoArg (unSetGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) + , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) + , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) + , make_ord_flag defGhcFlag "ticky-allocd" + (NoArg (setGeneralFlag Opt_Ticky_Allocd)) + , make_ord_flag defGhcFlag "ticky-LNE" + (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , make_ord_flag defGhcFlag "ticky-dyn-thunk" + (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) + ------- recompilation checker -------------------------------------- + , make_dep_flag defGhcFlag "recomp" + (NoArg $ unSetGeneralFlag Opt_ForceRecomp) + "Use -fno-force-recomp instead" + , make_dep_flag defGhcFlag "no-recomp" + (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" + , make_ord_flag defFlag "fmax-errors" + (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) + , make_ord_flag defFlag "fno-max-errors" + (noArg (\d -> d { maxErrors = Nothing })) + , make_ord_flag defFlag "freverse-errors" + (noArg (\d -> d {reverseErrors = True} )) + , make_ord_flag defFlag "fno-reverse-errors" + (noArg (\d -> d {reverseErrors = False} )) + + ------ HsCpp opts --------------------------------------------------- + , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) + , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) + + ------- Include/Import Paths ---------------------------------------- + , make_ord_flag defFlag "I" (Prefix addIncludePath) + , make_ord_flag defFlag "i" (OptPrefix addImportPath) + + ------ Output style options ----------------------------------------- + , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> + d { pprUserLength = n })) + , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> + d { pprCols = n })) + , make_ord_flag defFlag "fdiagnostics-color=auto" + (NoArg (upd (\d -> d { useColor = Auto }))) + , make_ord_flag defFlag "fdiagnostics-color=always" + (NoArg (upd (\d -> d { useColor = Always }))) + , make_ord_flag defFlag "fdiagnostics-color=never" + (NoArg (upd (\d -> d { useColor = Never }))) + + -- Suppress all that is suppressable in core dumps. + -- Except for uniques, as some simplifier phases introduce new variables that + -- have otherwise identical names. + , make_ord_flag defGhcFlag "dsuppress-all" + (NoArg $ do setGeneralFlag Opt_SuppressCoercions + setGeneralFlag Opt_SuppressVarKinds + setGeneralFlag Opt_SuppressModulePrefixes + setGeneralFlag Opt_SuppressTypeApplications + setGeneralFlag Opt_SuppressIdInfo + setGeneralFlag Opt_SuppressTicks + setGeneralFlag Opt_SuppressStgExts + setGeneralFlag Opt_SuppressTypeSignatures + setGeneralFlag Opt_SuppressTimestamps) + + ------ Debugging ---------------------------------------------------- + , make_ord_flag defGhcFlag "dstg-stats" + (NoArg (setGeneralFlag Opt_StgStats)) + + , make_ord_flag defGhcFlag "ddump-cmm" + (setDumpFlag Opt_D_dump_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-from-stg" + (setDumpFlag Opt_D_dump_cmm_from_stg) + , make_ord_flag defGhcFlag "ddump-cmm-raw" + (setDumpFlag Opt_D_dump_cmm_raw) + , make_ord_flag defGhcFlag "ddump-cmm-verbose" + (setDumpFlag Opt_D_dump_cmm_verbose) + , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" + (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) + , make_ord_flag defGhcFlag "ddump-cmm-cfg" + (setDumpFlag Opt_D_dump_cmm_cfg) + , make_ord_flag defGhcFlag "ddump-cmm-cbe" + (setDumpFlag Opt_D_dump_cmm_cbe) + , make_ord_flag defGhcFlag "ddump-cmm-switch" + (setDumpFlag Opt_D_dump_cmm_switch) + , make_ord_flag defGhcFlag "ddump-cmm-proc" + (setDumpFlag Opt_D_dump_cmm_proc) + , make_ord_flag defGhcFlag "ddump-cmm-sp" + (setDumpFlag Opt_D_dump_cmm_sp) + , make_ord_flag defGhcFlag "ddump-cmm-sink" + (setDumpFlag Opt_D_dump_cmm_sink) + , make_ord_flag defGhcFlag "ddump-cmm-caf" + (setDumpFlag Opt_D_dump_cmm_caf) + , make_ord_flag defGhcFlag "ddump-cmm-procmap" + (setDumpFlag Opt_D_dump_cmm_procmap) + , make_ord_flag defGhcFlag "ddump-cmm-split" + (setDumpFlag Opt_D_dump_cmm_split) + , make_ord_flag defGhcFlag "ddump-cmm-info" + (setDumpFlag Opt_D_dump_cmm_info) + , make_ord_flag defGhcFlag "ddump-cmm-cps" + (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-cmm-opt" + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-cfg-weights" + (setDumpFlag Opt_D_dump_cfg_weights) + , make_ord_flag defGhcFlag "ddump-core-stats" + (setDumpFlag Opt_D_dump_core_stats) + , make_ord_flag defGhcFlag "ddump-asm" + (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-asm-native" + (setDumpFlag Opt_D_dump_asm_native) + , make_ord_flag defGhcFlag "ddump-asm-liveness" + (setDumpFlag Opt_D_dump_asm_liveness) + , make_ord_flag defGhcFlag "ddump-asm-regalloc" + (setDumpFlag Opt_D_dump_asm_regalloc) + , make_ord_flag defGhcFlag "ddump-asm-conflicts" + (setDumpFlag Opt_D_dump_asm_conflicts) + , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , make_ord_flag defGhcFlag "ddump-asm-stats" + (setDumpFlag Opt_D_dump_asm_stats) + , make_ord_flag defGhcFlag "ddump-asm-expanded" + (setDumpFlag Opt_D_dump_asm_expanded) + , make_ord_flag defGhcFlag "ddump-llvm" + (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm) + , make_ord_flag defGhcFlag "ddump-deriv" + (setDumpFlag Opt_D_dump_deriv) + , make_ord_flag defGhcFlag "ddump-ds" + (setDumpFlag Opt_D_dump_ds) + , make_ord_flag defGhcFlag "ddump-ds-preopt" + (setDumpFlag Opt_D_dump_ds_preopt) + , make_ord_flag defGhcFlag "ddump-foreign" + (setDumpFlag Opt_D_dump_foreign) + , make_ord_flag defGhcFlag "ddump-inlinings" + (setDumpFlag Opt_D_dump_inlinings) + , make_ord_flag defGhcFlag "ddump-verbose-inlinings" + (setDumpFlag Opt_D_dump_verbose_inlinings) + , make_ord_flag defGhcFlag "ddump-rule-firings" + (setDumpFlag Opt_D_dump_rule_firings) + , make_ord_flag defGhcFlag "ddump-rule-rewrites" + (setDumpFlag Opt_D_dump_rule_rewrites) + , make_ord_flag defGhcFlag "ddump-simpl-trace" + (setDumpFlag Opt_D_dump_simpl_trace) + , make_ord_flag defGhcFlag "ddump-occur-anal" + (setDumpFlag Opt_D_dump_occur_anal) + , make_ord_flag defGhcFlag "ddump-parsed" + (setDumpFlag Opt_D_dump_parsed) + , make_ord_flag defGhcFlag "ddump-parsed-ast" + (setDumpFlag Opt_D_dump_parsed_ast) + , make_ord_flag defGhcFlag "ddump-rn" + (setDumpFlag Opt_D_dump_rn) + , make_ord_flag defGhcFlag "ddump-rn-ast" + (setDumpFlag Opt_D_dump_rn_ast) + , make_ord_flag defGhcFlag "ddump-simpl" + (setDumpFlag Opt_D_dump_simpl) + , make_ord_flag defGhcFlag "ddump-simpl-iterations" + (setDumpFlag Opt_D_dump_simpl_iterations) + , make_ord_flag defGhcFlag "ddump-spec" + (setDumpFlag Opt_D_dump_spec) + , make_ord_flag defGhcFlag "ddump-prep" + (setDumpFlag Opt_D_dump_prep) + , make_ord_flag defGhcFlag "ddump-stg" + (setDumpFlag Opt_D_dump_stg) + , make_ord_flag defGhcFlag "ddump-stg-unarised" + (setDumpFlag Opt_D_dump_stg_unarised) + , make_ord_flag defGhcFlag "ddump-stg-final" + (setDumpFlag Opt_D_dump_stg_final) + , make_ord_flag defGhcFlag "ddump-call-arity" + (setDumpFlag Opt_D_dump_call_arity) + , make_ord_flag defGhcFlag "ddump-exitify" + (setDumpFlag Opt_D_dump_exitify) + , make_ord_flag defGhcFlag "ddump-stranal" + (setDumpFlag Opt_D_dump_stranal) + , make_ord_flag defGhcFlag "ddump-str-signatures" + (setDumpFlag Opt_D_dump_str_signatures) + , make_ord_flag defGhcFlag "ddump-cpranal" + (setDumpFlag Opt_D_dump_cpranal) + , make_ord_flag defGhcFlag "ddump-cpr-signatures" + (setDumpFlag Opt_D_dump_cpr_signatures) + , make_ord_flag defGhcFlag "ddump-tc" + (setDumpFlag Opt_D_dump_tc) + , make_ord_flag defGhcFlag "ddump-tc-ast" + (setDumpFlag Opt_D_dump_tc_ast) + , make_ord_flag defGhcFlag "ddump-hie" + (setDumpFlag Opt_D_dump_hie) + , make_ord_flag defGhcFlag "ddump-types" + (setDumpFlag Opt_D_dump_types) + , make_ord_flag defGhcFlag "ddump-rules" + (setDumpFlag Opt_D_dump_rules) + , make_ord_flag defGhcFlag "ddump-cse" + (setDumpFlag Opt_D_dump_cse) + , make_ord_flag defGhcFlag "ddump-worker-wrapper" + (setDumpFlag Opt_D_dump_worker_wrapper) + , make_ord_flag defGhcFlag "ddump-rn-trace" + (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-if-trace" + (setDumpFlag Opt_D_dump_if_trace) + , make_ord_flag defGhcFlag "ddump-cs-trace" + (setDumpFlag Opt_D_dump_cs_trace) + , make_ord_flag defGhcFlag "ddump-tc-trace" + (NoArg (do setDumpFlag' Opt_D_dump_tc_trace + setDumpFlag' Opt_D_dump_cs_trace)) + , make_ord_flag defGhcFlag "ddump-ec-trace" + (setDumpFlag Opt_D_dump_ec_trace) + , make_ord_flag defGhcFlag "ddump-vt-trace" + (setDumpFlag Opt_D_dump_vt_trace) + , make_ord_flag defGhcFlag "ddump-splices" + (setDumpFlag Opt_D_dump_splices) + , make_ord_flag defGhcFlag "dth-dec-file" + (setDumpFlag Opt_D_th_dec_file) + + , make_ord_flag defGhcFlag "ddump-rn-stats" + (setDumpFlag Opt_D_dump_rn_stats) + , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-simpl-stats" + (setDumpFlag Opt_D_dump_simpl_stats) + , make_ord_flag defGhcFlag "ddump-bcos" + (setDumpFlag Opt_D_dump_BCOs) + , make_ord_flag defGhcFlag "dsource-stats" + (setDumpFlag Opt_D_source_stats) + , make_ord_flag defGhcFlag "dverbose-core2core" + (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) + , make_ord_flag defGhcFlag "dverbose-stg2stg" + (setDumpFlag Opt_D_verbose_stg2stg) + , make_ord_flag defGhcFlag "ddump-hi" + (setDumpFlag Opt_D_dump_hi) + , make_ord_flag defGhcFlag "ddump-minimal-imports" + (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) + , make_ord_flag defGhcFlag "ddump-hpc" + (setDumpFlag Opt_D_dump_ticked) -- back compat + , make_ord_flag defGhcFlag "ddump-ticked" + (setDumpFlag Opt_D_dump_ticked) + , make_ord_flag defGhcFlag "ddump-mod-cycles" + (setDumpFlag Opt_D_dump_mod_cycles) + , make_ord_flag defGhcFlag "ddump-mod-map" + (setDumpFlag Opt_D_dump_mod_map) + , make_ord_flag defGhcFlag "ddump-timings" + (setDumpFlag Opt_D_dump_timings) + , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" + (setDumpFlag Opt_D_dump_view_pattern_commoning) + , make_ord_flag defGhcFlag "ddump-to-file" + (NoArg (setGeneralFlag Opt_DumpToFile)) + , make_ord_flag defGhcFlag "ddump-hi-diffs" + (setDumpFlag Opt_D_dump_hi_diffs) + , make_ord_flag defGhcFlag "ddump-rtti" + (setDumpFlag Opt_D_dump_rtti) + , make_ord_flag defGhcFlag "dcore-lint" + (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , make_ord_flag defGhcFlag "dlinear-core-lint" + (NoArg (setGeneralFlag Opt_DoLinearCoreLinting)) + , make_ord_flag defGhcFlag "dstg-lint" + (NoArg (setGeneralFlag Opt_DoStgLinting)) + , make_ord_flag defGhcFlag "dcmm-lint" + (NoArg (setGeneralFlag Opt_DoCmmLinting)) + , make_ord_flag defGhcFlag "dasm-lint" + (NoArg (setGeneralFlag Opt_DoAsmLinting)) + , make_ord_flag defGhcFlag "dannot-lint" + (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) + , make_ord_flag defGhcFlag "dshow-passes" + (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) + , make_ord_flag defGhcFlag "dfaststring-stats" + (NoArg (setGeneralFlag Opt_D_faststring_stats)) + , make_ord_flag defGhcFlag "dno-llvm-mangler" + (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag + , make_ord_flag defGhcFlag "dno-typeable-binds" + (NoArg (setGeneralFlag Opt_NoTypeableBinds)) + , make_ord_flag defGhcFlag "ddump-debug" + (setDumpFlag Opt_D_dump_debug) + , make_ord_flag defGhcFlag "ddump-json" + (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) + , make_ord_flag defGhcFlag "dppr-debug" + (setDumpFlag Opt_D_ppr_debug) + , make_ord_flag defGhcFlag "ddebug-output" + (noArg (flip dopt_unset Opt_D_no_debug_output)) + , make_ord_flag defGhcFlag "dno-debug-output" + (setDumpFlag Opt_D_no_debug_output) + + ------ Machine dependent (-m) stuff --------------------------- + + , make_ord_flag defGhcFlag "msse" (noArg (\d -> + d { sseVersion = Just SSE1 })) + , make_ord_flag defGhcFlag "msse2" (noArg (\d -> + d { sseVersion = Just SSE2 })) + , make_ord_flag defGhcFlag "msse3" (noArg (\d -> + d { sseVersion = Just SSE3 })) + , make_ord_flag defGhcFlag "msse4" (noArg (\d -> + d { sseVersion = Just SSE4 })) + , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> + d { sseVersion = Just SSE42 })) + , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> + d { bmiVersion = Just BMI1 })) + , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> + d { bmiVersion = Just BMI2 })) + , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) + , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) + , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> + d { avx512cd = True })) + , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> + d { avx512er = True })) + , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) + , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> + d { avx512pf = True })) + + ------ Warning opts ------------------------------------------------- + , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Werror" + (NoArg (do { setGeneralFlag Opt_WarnIsError + ; mapM_ setFatalWarningFlag minusWeverythingOpts })) + , make_ord_flag defFlag "Wwarn" + (NoArg (do { unSetGeneralFlag Opt_WarnIsError + ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) + -- Opt_WarnIsError is still needed to pass -Werror + -- to CPP; see runCpp in SysTools + , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + "Use -w or -Wno-everything instead" + , make_ord_flag defFlag "w" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + + -- New-style uniform warning sets + -- + -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything + , make_ord_flag defFlag "Weverything" (NoArg (mapM_ + setWarningFlag minusWeverythingOpts)) + , make_ord_flag defFlag "Wno-everything" + (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) + + , make_ord_flag defFlag "Wall" (NoArg (mapM_ + setWarningFlag minusWallOpts)) + , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ + unSetWarningFlag minusWallOpts)) + + , make_ord_flag defFlag "Wextra" (NoArg (mapM_ + setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ + unSetWarningFlag minusWOpts)) + + , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ + setWarningFlag standardWarnings)) + , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ + unSetWarningFlag standardWarnings)) + + , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ + setWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ + unSetWarningFlag minusWcompatOpts)) + + ------ Plugin flags ------------------------------------------------ + , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) + , make_ord_flag defGhcFlag "fplugin-trustworthy" + (NoArg (setGeneralFlag Opt_PluginTrustworthy)) + , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) + , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) + , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) + + ------ Optimisation flags ------------------------------------------ + , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) + "Use -O0 instead" + , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> + setOptLevel (mb_n `orElse` 1))) + -- If the number is missing, use 1 + + , make_ord_flag defFlag "fbinary-blob-threshold" + (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n })) + + , make_ord_flag defFlag "fmax-relevant-binds" + (intSuffix (\n d -> d { maxRelevantBinds = Just n })) + , make_ord_flag defFlag "fno-max-relevant-binds" + (noArg (\d -> d { maxRelevantBinds = Nothing })) + + , make_ord_flag defFlag "fmax-valid-hole-fits" + (intSuffix (\n d -> d { maxValidHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-valid-hole-fits" + (noArg (\d -> d { maxValidHoleFits = Nothing })) + , make_ord_flag defFlag "fmax-refinement-hole-fits" + (intSuffix (\n d -> d { maxRefHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-refinement-hole-fits" + (noArg (\d -> d { maxRefHoleFits = Nothing })) + , make_ord_flag defFlag "frefinement-level-hole-fits" + (intSuffix (\n d -> d { refLevelHoleFits = Just n })) + , make_ord_flag defFlag "fno-refinement-level-hole-fits" + (noArg (\d -> d { refLevelHoleFits = Nothing })) + + , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" + (noArg id) + "vectors registers are now passed in registers by default." + , make_ord_flag defFlag "fmax-uncovered-patterns" + (intSuffix (\n d -> d { maxUncoveredPatterns = n })) + , make_ord_flag defFlag "fmax-pmcheck-models" + (intSuffix (\n d -> d { maxPmCheckModels = n })) + , make_ord_flag defFlag "fsimplifier-phases" + (intSuffix (\n d -> d { simplPhases = n })) + , make_ord_flag defFlag "fmax-simplifier-iterations" + (intSuffix (\n d -> d { maxSimplIterations = n })) + , (Deprecated, defFlag "fmax-pmcheck-iterations" + (intSuffixM (\_ d -> + do { deprecate $ "use -fmax-pmcheck-models instead" + ; return d }))) + , make_ord_flag defFlag "fsimpl-tick-factor" + (intSuffix (\n d -> d { simplTickFactor = n })) + , make_ord_flag defFlag "fspec-constr-threshold" + (intSuffix (\n d -> d { specConstrThreshold = Just n })) + , make_ord_flag defFlag "fno-spec-constr-threshold" + (noArg (\d -> d { specConstrThreshold = Nothing })) + , make_ord_flag defFlag "fspec-constr-count" + (intSuffix (\n d -> d { specConstrCount = Just n })) + , make_ord_flag defFlag "fno-spec-constr-count" + (noArg (\d -> d { specConstrCount = Nothing })) + , make_ord_flag defFlag "fspec-constr-recursive" + (intSuffix (\n d -> d { specConstrRecursive = n })) + , make_ord_flag defFlag "fliberate-case-threshold" + (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) + , make_ord_flag defFlag "fno-liberate-case-threshold" + (noArg (\d -> d { liberateCaseThreshold = Nothing })) + , make_ord_flag defFlag "drule-check" + (sepArg (\s d -> d { ruleCheck = Just s })) + , make_ord_flag defFlag "dinline-check" + (sepArg (\s d -> d { inlineCheck = Just s })) + , make_ord_flag defFlag "freduction-depth" + (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) + , make_ord_flag defFlag "fconstraint-solver-iterations" + (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) + , (Deprecated, defFlag "fcontext-stack" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , (Deprecated, defFlag "ftype-function-depth" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , make_ord_flag defFlag "fstrictness-before" + (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) + , make_ord_flag defFlag "ffloat-lam-args" + (intSuffix (\n d -> d { floatLamArgs = Just n })) + , make_ord_flag defFlag "ffloat-all-lams" + (noArg (\d -> d { floatLamArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = True })) + , make_ord_flag defFlag "fno-stg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = False })) + , make_ord_flag defFlag "fproc-alignment" + (intSuffix (\n d -> d { cmmProcAlignment = Just n })) + , make_ord_flag defFlag "fblock-layout-weights" + (HasArg (\s -> + upd (\d -> d { cfgWeightInfo = + parseCfgWeights s (cfgWeightInfo d)}))) + , make_ord_flag defFlag "fhistory-size" + (intSuffix (\n d -> d { historySize = n })) + , make_ord_flag defFlag "funfolding-creation-threshold" + (intSuffix (\n d -> d {ufCreationThreshold = n})) + , make_ord_flag defFlag "funfolding-use-threshold" + (intSuffix (\n d -> d {ufUseThreshold = n})) + , make_ord_flag defFlag "funfolding-fun-discount" + (intSuffix (\n d -> d {ufFunAppDiscount = n})) + , make_ord_flag defFlag "funfolding-dict-discount" + (intSuffix (\n d -> d {ufDictDiscount = n})) + , make_dep_flag defFlag "funfolding-keeness-factor" + (floatSuffix (\_ d -> d)) + "-funfolding-keeness-factor is no longer respected as of GHC 9.0" + , make_ord_flag defFlag "fmax-worker-args" + (intSuffix (\n d -> d {maxWorkerArgs = n})) + , make_ord_flag defGhciFlag "fghci-hist-size" + (intSuffix (\n d -> d {ghciHistSize = n})) + , make_ord_flag defGhcFlag "fmax-inline-alloc-size" + (intSuffix (\n d -> d { maxInlineAllocSize = n })) + , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" + (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) + , make_ord_flag defGhcFlag "fmax-inline-memset-insns" + (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) + , make_ord_flag defGhcFlag "dinitial-unique" + (intSuffix (\n d -> d { initialUnique = n })) + , make_ord_flag defGhcFlag "dunique-increment" + (intSuffix (\n d -> d { uniqueIncrement = n })) + + ------ Profiling ---------------------------------------------------- + + -- OLD profiling flags + , make_dep_flag defGhcFlag "auto-all" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + "Use -fprof-auto instead" + , make_dep_flag defGhcFlag "no-auto-all" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "auto" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + "Use -fprof-auto-exported instead" + , make_dep_flag defGhcFlag "no-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "caf-all" + (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fprof-cafs instead" + , make_dep_flag defGhcFlag "no-caf-all" + (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fno-prof-cafs instead" + + -- NEW profiling flags + , make_ord_flag defGhcFlag "fprof-auto" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + , make_ord_flag defGhcFlag "fprof-auto-top" + (noArg (\d -> d { profAuto = ProfAutoTop } )) + , make_ord_flag defGhcFlag "fprof-auto-exported" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + , make_ord_flag defGhcFlag "fprof-auto-calls" + (noArg (\d -> d { profAuto = ProfAutoCalls } )) + , make_ord_flag defGhcFlag "fno-prof-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + + ------ Compiler flags ----------------------------------------------- + + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) + , make_ord_flag defGhcFlag "fvia-c" (NoArg + (deprecate $ "The -fvia-c flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fvia-C" (NoArg + (deprecate $ "The -fvia-C flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) + + , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> + d { ghcLink=NoLink }) >> setTarget HscNothing)) + , make_ord_flag defFlag "fbyte-code" (NoArg ((upd $ \d -> + -- Enabling Opt_ByteCodeIfUnboxed is a workaround for #18955. + -- See the comments for resetOptByteCodeIfUnboxed for more details. + gopt_set d Opt_ByteCodeIfUnboxed) >> setTarget HscInterpreted)) + , make_ord_flag defFlag "fobject-code" $ NoArg $ do + dflags <- liftEwM getCmdLineState + setTarget $ defaultObjectTarget dflags + + , make_dep_flag defFlag "fglasgow-exts" + (NoArg enableGlasgowExts) "Use individual extensions instead" + , make_dep_flag defFlag "fno-glasgow-exts" + (NoArg disableGlasgowExts) "Use individual extensions instead" + , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) + , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg + disableUnusedBinds) + + ------ Safe Haskell flags ------------------------------------------- + , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) + , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> + d { safeInfer = False })) + , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) + + ------ position independent flags ---------------------------------- + , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIE)) + , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIE)) + + ------ Debugging flags ---------------------------------------------- + , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) + ] + ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) + wWarningFlagsDeps + ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) + wWarningFlagsDeps + ++ [ (NotDeprecated, unrecognisedWarning "W"), + (Deprecated, unrecognisedWarning "fwarn-"), + (Deprecated, unrecognisedWarning "fno-warn-") ] + ++ [ make_ord_flag defFlag "Werror=compat" + (NoArg (mapM_ setWErrorFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-error=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wwarn=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ] + ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps + ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps + ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps + ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps + ++ [ make_dep_flag defFlag "XGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures " ++ + "and -XDeriveGeneric for generic programming support.") + , make_dep_flag defFlag "XNoGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures and " ++ + "-XDeriveGeneric for generic programming support.") ] + +-- | This is where we handle unrecognised warning flags. We only issue a warning +-- if -Wunrecognised-warning-flags is set. See #11429 for context. +unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) +unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) + where + action :: String -> EwM (CmdLineP DynFlags) () + action flag = do + f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState + when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $ + "unrecognised warning flag: -" ++ prefix ++ flag + +-- See Note [Supporting CLI completion] +package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +package_flags_deps = [ + ------- Packages ---------------------------------------------------- + make_ord_flag defFlag "package-db" + (HasArg (addPkgDbRef . PkgDbPath)) + , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) + , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) + , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) + , make_ord_flag defFlag "global-package-db" + (NoArg (addPkgDbRef GlobalPkgDb)) + , make_ord_flag defFlag "user-package-db" + (NoArg (addPkgDbRef UserPkgDb)) + -- backwards compat with GHC<=7.4 : + , make_dep_flag defFlag "package-conf" + (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + , make_dep_flag defFlag "no-user-package-conf" + (NoArg removeUserPkgDb) "Use -no-user-package-db instead" + , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do + upd (setUnitId name)) + , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) + , make_ord_flag defFlag "package" (HasArg exposePackage) + , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) + , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) + , make_ord_flag defFlag "package-id" (HasArg exposePackageId) + , make_ord_flag defFlag "hide-package" (HasArg hidePackage) + , make_ord_flag defFlag "hide-all-packages" + (NoArg (setGeneralFlag Opt_HideAllPackages)) + , make_ord_flag defFlag "hide-all-plugin-packages" + (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) + , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) + , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) + , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" + , make_ord_flag defFlag "distrust-all-packages" + (NoArg (setGeneralFlag Opt_DistrustAllPackages)) + , make_ord_flag defFlag "trust" (HasArg trustPackage) + , make_ord_flag defFlag "distrust" (HasArg distrustPackage) + ] + where + setPackageEnv env = upd $ \s -> s { packageEnv = Just env } + +-- | Make a list of flags for shell completion. +-- Filter all available flags into two groups, for interactive GHC vs all other. +flagsForCompletion :: Bool -> [String] +flagsForCompletion isInteractive + = [ '-':flagName flag + | flag <- flagsAll + , modeFilter (flagGhcMode flag) + ] + where + modeFilter AllModes = True + modeFilter OnlyGhci = isInteractive + modeFilter OnlyGhc = not isInteractive + modeFilter HiddenFlag = False + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +data FlagSpec flag + = FlagSpec + { flagSpecName :: String -- ^ Flag in string form + , flagSpecFlag :: flag -- ^ Flag in internal form + , flagSpecAction :: (TurnOnFlag -> DynP ()) + -- ^ Extra action to run when the flag is found + -- Typically, emit a warning or error + , flagSpecGhcMode :: GhcFlagMode + -- ^ In which ghc mode the flag has effect + } + +-- | Define a new flag. +flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagSpec name flag = flagSpec' name flag nop + +-- | Define a new flag with an effect. +flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) + +-- | Define a new deprecated flag with an effect. +depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecOp name flag act dep = + (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) + +-- | Define a new deprecated flag. +depFlagSpec :: String -> flag -> String + -> (Deprecation, FlagSpec flag) +depFlagSpec name flag dep = depFlagSpecOp name flag nop dep + +-- | Define a new deprecated flag with an effect where the deprecation message +-- depends on the flag value +depFlagSpecOp' :: String + -> flag + -> (TurnOnFlag -> DynP ()) + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpecOp' name flag act dep = + (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) + AllModes) + +-- | Define a new deprecated flag where the deprecation message +-- depends on the flag value +depFlagSpec' :: String + -> flag + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep + + +-- | Define a new deprecated flag where the deprecation message +-- is shown depending on the flag value +depFlagSpecCond :: String + -> flag + -> (TurnOnFlag -> Bool) + -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecCond name flag cond dep = + (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) + AllModes) + +-- | Define a new flag for GHCi. +flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagGhciSpec name flag = flagGhciSpec' name flag nop + +-- | Define a new flag for GHCi with an effect. +flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) + +-- | Define a new flag invisible to CLI completion. +flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagHiddenSpec name flag = flagHiddenSpec' name flag nop + +-- | Define a new flag invisible to CLI completion with an effect. +flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act + HiddenFlag) + +-- | Hide a 'FlagSpec' from being displayed in @--show-options@. +-- +-- This is for example useful for flags that are obsolete, but should not +-- (yet) be deprecated for compatibility reasons. +hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) +hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) + +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on + -> String -- ^ The flag prefix + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> (Deprecation, FlagSpec flag) -- ^ Specification of + -- this particular flag + -> (Deprecation, Flag (CmdLineP DynFlags)) +mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) + = (dep, + Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) + +deprecatedForExtension :: String -> TurnOnFlag -> String +deprecatedForExtension lang turn_on + = "use -X" ++ flag ++ + " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" + where + flag | turn_on = lang + | otherwise = "No" ++ lang + +useInstead :: String -> String -> TurnOnFlag -> String +useInstead prefix flag turn_on + = "Use " ++ prefix ++ no ++ flag ++ " instead" + where + no = if turn_on then "" else "no-" + +nop :: TurnOnFlag -> DynP () +nop _ = return () + +-- | Find the 'FlagSpec' for a 'WarningFlag'. +flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) +flagSpecOf flag = listToMaybe $ filter check wWarningFlags + where + check fs = flagSpecFlag fs == flag + +-- | These @-W\@ flags can all be reversed with @-Wno-\@ +wWarningFlags :: [FlagSpec WarningFlag] +wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) + +wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] +wWarningFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "alternative-layout-rule-transitional" + Opt_WarnAlternativeLayoutRuleTransitional, + depFlagSpec "auto-orphans" Opt_WarnAutoOrphans + "it has no effect", + flagSpec "cpp-undef" Opt_WarnCPPUndef, + flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, + flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, + flagSpec "deferred-out-of-scope-variables" + Opt_WarnDeferredOutOfScopeVariables, + flagSpec "deprecations" Opt_WarnWarningsDeprecations, + flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags, + flagSpec "deriving-defaults" Opt_WarnDerivingDefaults, + flagSpec "deriving-typeable" Opt_WarnDerivingTypeable, + flagSpec "dodgy-exports" Opt_WarnDodgyExports, + flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports, + flagSpec "dodgy-imports" Opt_WarnDodgyImports, + flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations, + depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints + "it is subsumed by -Wredundant-constraints", + flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, + flagSpec "duplicate-exports" Opt_WarnDuplicateExports, + depFlagSpec "hi-shadowing" Opt_WarnHiShadows + "it is not used, and was never implemented", + flagSpec "inaccessible-code" Opt_WarnInaccessibleCode, + flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, + depFlagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars + "it is now an error", + flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, + flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, + flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, + flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing, + flagSpec "identities" Opt_WarnIdentities, + flagSpec "missing-fields" Opt_WarnMissingFields, + flagSpec "missing-import-lists" Opt_WarnMissingImportList, + flagSpec "missing-export-lists" Opt_WarnMissingExportList, + depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures + "it is replaced by -Wmissing-local-signatures", + flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures, + flagSpec "missing-methods" Opt_WarnMissingMethods, + flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances, + flagSpec "semigroup" Opt_WarnSemigroup, + flagSpec "missing-signatures" Opt_WarnMissingSignatures, + depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures + "it is replaced by -Wmissing-exported-signatures", + flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures, + flagSpec "monomorphism-restriction" Opt_WarnMonomorphism, + flagSpec "name-shadowing" Opt_WarnNameShadowing, + flagSpec "noncanonical-monad-instances" + Opt_WarnNonCanonicalMonadInstances, + depFlagSpec "noncanonical-monadfail-instances" + Opt_WarnNonCanonicalMonadInstances + "fail is no longer a method of Monad", + flagSpec "noncanonical-monoid-instances" + Opt_WarnNonCanonicalMonoidInstances, + flagSpec "orphans" Opt_WarnOrphans, + flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, + flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, + flagSpec "missed-specialisations" Opt_WarnMissedSpecs, + flagSpec "missed-specializations" Opt_WarnMissedSpecs, + flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, + flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs, + flagSpec' "safe" Opt_WarnSafe setWarnSafe, + flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe, + flagSpec "inferred-safe-imports" Opt_WarnInferredSafeImports, + flagSpec "missing-safe-haskell-mode" Opt_WarnMissingSafeHaskellMode, + flagSpec "tabs" Opt_WarnTabs, + flagSpec "type-defaults" Opt_WarnTypeDefaults, + flagSpec "typed-holes" Opt_WarnTypedHoles, + flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures, + flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, + flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe, + flagSpec "unsupported-calling-conventions" + Opt_WarnUnsupportedCallingConventions, + flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, + flagSpec "missed-extra-shared-lib" Opt_WarnMissedExtraSharedLib, + flagSpec "unticked-promoted-constructors" + Opt_WarnUntickedPromotedConstructors, + flagSpec "unused-do-bind" Opt_WarnUnusedDoBind, + flagSpec "unused-foralls" Opt_WarnUnusedForalls, + flagSpec "unused-imports" Opt_WarnUnusedImports, + flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds, + flagSpec "unused-matches" Opt_WarnUnusedMatches, + flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds, + flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, + flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, + flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards, + flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards, + flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, + flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, + flagSpec "missing-pattern-synonym-signatures" + Opt_WarnMissingPatternSynonymSignatures, + flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies, + flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, + flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, + flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, + flagSpec "star-binder" Opt_WarnStarBinder, + flagSpec "star-is-type" Opt_WarnStarIsType, + depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang + "bang patterns can no longer be written with a space", + flagSpec "partial-fields" Opt_WarnPartialFields, + flagSpec "prepositive-qualified-module" + Opt_WarnPrepositiveQualifiedModule, + flagSpec "unused-packages" Opt_WarnUnusedPackages, + flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports, + flagSpec "invalid-haddock" Opt_WarnInvalidHaddock, + flagSpec "unicode-bidirectional-format-characters" Opt_WarnUnicodeBidirectionalFormatCharacters + ] + +-- | These @-\@ flags can all be reversed with @-no-\@ +negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +negatableFlagsDeps = [ + flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] + +-- | These @-d\@ flags can all be reversed with @-dno-\@ +dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +dFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, + depFlagSpec' "ppr-ticks" Opt_PprShowTicks + (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "suppress-ticks" Opt_SuppressTicks, + depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts + (useInstead "-d" "suppress-stg-exts"), + flagSpec "suppress-stg-exts" Opt_SuppressStgExts, + flagSpec "suppress-coercions" Opt_SuppressCoercions, + flagSpec "suppress-idinfo" Opt_SuppressIdInfo, + flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, + flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, + flagSpec "suppress-timestamps" Opt_SuppressTimestamps, + flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, + flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, + flagSpec "suppress-uniques" Opt_SuppressUniques, + flagSpec "suppress-var-kinds" Opt_SuppressVarKinds + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fFlags :: [FlagSpec GeneralFlag] +fFlags = map snd fFlagsDeps + +fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +fFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "asm-shortcutting" Opt_AsmShortcutting, + flagGhciSpec "break-on-error" Opt_BreakOnError, + flagGhciSpec "break-on-exception" Opt_BreakOnException, + flagSpec "building-cabal-package" Opt_BuildingCabalPackage, + flagSpec "call-arity" Opt_CallArity, + flagSpec "exitification" Opt_Exitification, + flagSpec "case-merge" Opt_CaseMerge, + flagSpec "case-folding" Opt_CaseFolding, + flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, + flagSpec "cmm-sink" Opt_CmmSink, + flagSpec "cmm-static-pred" Opt_CmmStaticPred, + flagSpec "cse" Opt_CSE, + flagSpec "stg-cse" Opt_StgCSE, + flagSpec "stg-lift-lams" Opt_StgLiftLams, + flagSpec "cpr-anal" Opt_CprAnal, + flagSpec "defer-diagnostics" Opt_DeferDiagnostics, + flagSpec "defer-type-errors" Opt_DeferTypeErrors, + flagSpec "defer-typed-holes" Opt_DeferTypedHoles, + flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, + flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, + flagSpec "dicts-cheap" Opt_DictsCheap, + flagSpec "dicts-strict" Opt_DictsStrict, + flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, + flagSpec "do-eta-reduction" Opt_DoEtaReduction, + flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, + flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, + flagSpec "error-spans" Opt_ErrorSpans, + flagSpec "excess-precision" Opt_ExcessPrecision, + flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, + flagSpec "external-interpreter" Opt_ExternalInterpreter, + flagSpec "flat-cache" Opt_FlatCache, + flagSpec "float-in" Opt_FloatIn, + flagSpec "force-recomp" Opt_ForceRecomp, + flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, + flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, + flagSpec "full-laziness" Opt_FullLaziness, + flagSpec "fun-to-thunk" Opt_FunToThunk, + flagSpec "gen-manifest" Opt_GenManifest, + flagSpec "ghci-history" Opt_GhciHistory, + flagSpec "ghci-leak-check" Opt_GhciLeakCheck, + flagSpec "validate-ide-info" Opt_ValidateHie, + flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, + flagGhciSpec "no-it" Opt_NoIt, + flagSpec "ghci-sandbox" Opt_GhciSandbox, + flagSpec "helpful-errors" Opt_HelpfulErrors, + flagSpec "hpc" Opt_Hpc, + flagSpec "ignore-asserts" Opt_IgnoreAsserts, + flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, + flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, + flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, + flagSpec "keep-going" Opt_KeepGoing, + flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "late-specialise" Opt_LateSpecialise, + flagSpec "liberate-case" Opt_LiberateCase, + flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, + flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, + flagSpec "loopification" Opt_Loopification, + flagSpec "block-layout-cfg" Opt_CfgBlocklayout, + flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, + flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, + flagSpec "omit-yields" Opt_OmitYields, + flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, + flagSpec "pedantic-bottoms" Opt_PedanticBottoms, + flagSpec "pre-inlining" Opt_SimplPreInlining, + flagGhciSpec "print-bind-contents" Opt_PrintBindContents, + flagGhciSpec "print-bind-result" Opt_PrintBindResult, + flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, + flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, + flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, + flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, + flagSpec "print-equality-relations" Opt_PrintEqualityRelations, + flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, + flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, + flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, + flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, + flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, + flagSpec "prof-count-entries" Opt_ProfCountEntries, + flagSpec "regs-graph" Opt_RegsGraph, + flagSpec "regs-iterative" Opt_RegsIterative, + depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules + (useInstead "-f" "enable-rewrite-rules"), + flagSpec "shared-implib" Opt_SharedImplib, + flagSpec "spec-constr" Opt_SpecConstr, + flagSpec "spec-constr-keen" Opt_SpecConstrKeen, + flagSpec "specialise" Opt_Specialise, + flagSpec "specialize" Opt_Specialise, + flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, + flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, + flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, + flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, + flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, + flagSpec "strictness" Opt_Strictness, + flagSpec "use-rpaths" Opt_RPath, + flagSpec "write-interface" Opt_WriteInterface, + flagSpec "write-ide-info" Opt_WriteHie, + flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, + flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, + flagSpec "version-macros" Opt_VersionMacros, + flagSpec "worker-wrapper" Opt_WorkerWrapper, + flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, + flagSpec "catch-bottoms" Opt_CatchBottoms, + flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, + flagSpec "num-constant-folding" Opt_NumConstantFolding, + flagSpec "show-warning-groups" Opt_ShowWarnGroups, + flagSpec "hide-source-paths" Opt_HideSourcePaths, + flagSpec "show-loaded-modules" Opt_ShowLoadedModules, + flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, + flagSpec "keep-cafs" Opt_KeepCAFs, + flagSpec "link-rts" Opt_LinkRts + ] + ++ fHoleFlags + +-- | These @-f\@ flags have to do with the typed-hole error message or +-- the valid hole fits in that message. See Note [Valid hole fits include ...] +-- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with +-- @-fno-\@ +fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] +fHoleFlags = [ + flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, + depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits + (useInstead "-f" "show-valid-hole-fits"), + flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, + -- Sorting settings + flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, + flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, + flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, + flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, + -- Output format settings + flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, + flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, + flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, + flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, + flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, + flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, + flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fLangFlags :: [FlagSpec LangExt.Extension] +fLangFlags = map snd fLangFlagsDeps + +fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +fLangFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + depFlagSpecOp' "th" LangExt.TemplateHaskell + checkTemplateHaskellOk + (deprecatedForExtension "TemplateHaskell"), + depFlagSpec' "fi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "ffi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "arrows" LangExt.Arrows + (deprecatedForExtension "Arrows"), + depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude + (deprecatedForExtension "ImplicitPrelude"), + depFlagSpec' "bang-patterns" LangExt.BangPatterns + (deprecatedForExtension "BangPatterns"), + depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction + (deprecatedForExtension "MonomorphismRestriction"), + depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds + (deprecatedForExtension "MonoPatBinds"), + depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules + (deprecatedForExtension "ExtendedDefaultRules"), + depFlagSpec' "implicit-params" LangExt.ImplicitParams + (deprecatedForExtension "ImplicitParams"), + depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances + (deprecatedForExtension "OverlappingInstances"), + depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances + (deprecatedForExtension "UndecidableInstances"), + depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances + (deprecatedForExtension "IncoherentInstances") + ] + +supportedLanguages :: [String] +supportedLanguages = map (flagSpecName . snd) languageFlagsDeps + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps + +supportedExtensions :: PlatformMini -> [String] +supportedExtensions targetPlatformMini = concatMap toFlagSpecNamePair xFlags + where + toFlagSpecNamePair flg + -- IMPORTANT! Make sure that `ghc --supported-extensions` omits + -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the + -- box. See also GHC #11102 and #16331 for more details about + -- the rationale + | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] + | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] + | otherwise = [name, noName] + where + isAIX = platformMini_os targetPlatformMini == OSAIX + noName = "No" ++ name + name = flagSpecName flg + +supportedLanguagesAndExtensions :: PlatformMini -> [String] +supportedLanguagesAndExtensions targetPlatformMini = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions targetPlatformMini + +-- | These -X flags cannot be reversed with -XNo +languageFlagsDeps :: [(Deprecation, FlagSpec Language)] +languageFlagsDeps = [ + flagSpec "Haskell98" Haskell98, + flagSpec "Haskell2010" Haskell2010 + ] + +-- | These -X flags cannot be reversed with -XNo +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] +safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] + where mkF flag = flagSpec (show flag) flag + +-- | These -X flags can all be reversed with -XNo +xFlags :: [FlagSpec LangExt.Extension] +xFlags = map snd xFlagsDeps + +xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +xFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- See Note [Adding a language extension] +-- Please keep the list of flags below sorted alphabetically + flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, + flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, + flagSpec "AlternativeLayoutRuleTransitional" + LangExt.AlternativeLayoutRuleTransitional, + flagSpec "Arrows" LangExt.Arrows, + depFlagSpecCond "AutoDeriveTypeable" LangExt.AutoDeriveTypeable + id + ("Typeable instances are created automatically " ++ + "for all types since GHC 8.2."), + flagSpec "BangPatterns" LangExt.BangPatterns, + flagSpec "BinaryLiterals" LangExt.BinaryLiterals, + flagSpec "CApiFFI" LangExt.CApiFFI, + flagSpec "CPP" LangExt.Cpp, + flagSpec "CUSKs" LangExt.CUSKs, + flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, + flagSpec "ConstraintKinds" LangExt.ConstraintKinds, + flagSpec "DataKinds" LangExt.DataKinds, + depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts + id + ("It was widely considered a misfeature, " ++ + "and has been removed from the Haskell language."), + flagSpec "DefaultSignatures" LangExt.DefaultSignatures, + flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, + flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, + flagSpec "DeriveFoldable" LangExt.DeriveFoldable, + flagSpec "DeriveFunctor" LangExt.DeriveFunctor, + flagSpec "DeriveGeneric" LangExt.DeriveGeneric, + flagSpec "DeriveLift" LangExt.DeriveLift, + flagSpec "DeriveTraversable" LangExt.DeriveTraversable, + flagSpec "DerivingStrategies" LangExt.DerivingStrategies, + flagSpec' "DerivingVia" LangExt.DerivingVia + setDeriveVia, + flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, + flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, + flagSpec "BlockArguments" LangExt.BlockArguments, + depFlagSpec' "DoRec" LangExt.RecursiveDo + (deprecatedForExtension "RecursiveDo"), + flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, + flagSpec "EmptyCase" LangExt.EmptyCase, + flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, + flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, + flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, + flagSpec "ExplicitForAll" LangExt.ExplicitForAll, + flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, + flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, + flagSpec "FlexibleContexts" LangExt.FlexibleContexts, + flagSpec "FlexibleInstances" LangExt.FlexibleInstances, + flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, + flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, + flagSpec "GADTSyntax" LangExt.GADTSyntax, + flagSpec "GADTs" LangExt.GADTs, + flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, + flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec "ImplicitParams" LangExt.ImplicitParams, + flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, + flagSpec "ImportQualifiedPost" LangExt.ImportQualifiedPost, + flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, + flagSpec' "IncoherentInstances" LangExt.IncoherentInstances + setIncoherentInsts, + flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, + flagSpec "InstanceSigs" LangExt.InstanceSigs, + flagSpec "ApplicativeDo" LangExt.ApplicativeDo, + flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, + flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, + flagSpec "KindSignatures" LangExt.KindSignatures, + flagSpec "LambdaCase" LangExt.LambdaCase, + flagSpec "LexicalNegation" LangExt.LexicalNegation, + flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, + flagSpec "LinearTypes" LangExt.LinearTypes, + flagSpec "MagicHash" LangExt.MagicHash, + flagSpec "MonadComprehensions" LangExt.MonadComprehensions, + depFlagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring + "MonadFailDesugaring is now the default behavior", + flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, + depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds + id + "Experimental feature now removed; has no effect", + flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, + flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, + flagSpec "MultiWayIf" LangExt.MultiWayIf, + flagSpec "NumericUnderscores" LangExt.NumericUnderscores, + flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, + flagSpec "NamedFieldPuns" LangExt.RecordPuns, + flagSpec "NamedWildCards" LangExt.NamedWildCards, + flagSpec "NegativeLiterals" LangExt.NegativeLiterals, + flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, + flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, + depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses + (deprecatedForExtension "MultiParamTypeClasses"), + flagSpec "NumDecimals" LangExt.NumDecimals, + depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances + setOverlappingInsts + "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", + flagSpec "OverloadedLabels" LangExt.OverloadedLabels, + flagSpec "OverloadedLists" LangExt.OverloadedLists, + flagSpec "OverloadedStrings" LangExt.OverloadedStrings, + flagSpec "PackageImports" LangExt.PackageImports, + flagSpec "ParallelArrays" LangExt.ParallelArrays, + flagSpec "ParallelListComp" LangExt.ParallelListComp, + flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, + flagSpec "PatternGuards" LangExt.PatternGuards, + depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + flagSpec "PatternSynonyms" LangExt.PatternSynonyms, + flagSpec "PolyKinds" LangExt.PolyKinds, + flagSpec "PolymorphicComponents" LangExt.RankNTypes, + flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints, + flagSpec "PostfixOperators" LangExt.PostfixOperators, + flagSpec "QuasiQuotes" LangExt.QuasiQuotes, + flagSpec "QualifiedDo" LangExt.QualifiedDo, + flagSpec "Rank2Types" LangExt.RankNTypes, + flagSpec "RankNTypes" LangExt.RankNTypes, + flagSpec "RebindableSyntax" LangExt.RebindableSyntax, + depFlagSpec' "RecordPuns" LangExt.RecordPuns + (deprecatedForExtension "NamedFieldPuns"), + flagSpec "RecordWildCards" LangExt.RecordWildCards, + flagSpec "RecursiveDo" LangExt.RecursiveDo, + flagSpec "RelaxedLayout" LangExt.RelaxedLayout, + depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec + not + "You can't turn off RelaxedPolyRec any more", + flagSpec "RoleAnnotations" LangExt.RoleAnnotations, + flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, + flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, + flagSpec "StarIsType" LangExt.StarIsType, + flagSpec "StaticPointers" LangExt.StaticPointers, + flagSpec "Strict" LangExt.Strict, + flagSpec "StrictData" LangExt.StrictData, + flagSpec' "TemplateHaskell" LangExt.TemplateHaskell + checkTemplateHaskellOk, + flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, + flagSpec "StandaloneKindSignatures" LangExt.StandaloneKindSignatures, + flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, + flagSpec "TransformListComp" LangExt.TransformListComp, + flagSpec "TupleSections" LangExt.TupleSections, + flagSpec "TypeApplications" LangExt.TypeApplications, + flagSpec "TypeInType" LangExt.TypeInType, + flagSpec "TypeFamilies" LangExt.TypeFamilies, + flagSpec "TypeOperators" LangExt.TypeOperators, + flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, + flagSpec "UnboxedTuples" LangExt.UnboxedTuples, + flagSpec "UnboxedSums" LangExt.UnboxedSums, + flagSpec "UndecidableInstances" LangExt.UndecidableInstances, + flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, + flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, + flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, + flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes, + flagSpec "ViewPatterns" LangExt.ViewPatterns + ] + +defaultFlags :: Settings -> [GeneralFlag] +defaultFlags settings +-- See Note [Updating flag description in the User's Guide] + = [ Opt_AutoLinkPackages, + Opt_DiagnosticsShowCaret, + Opt_EmbedManifest, + Opt_FlatCache, + Opt_GenManifest, + Opt_GhciHistory, + Opt_GhciSandbox, + Opt_HelpfulErrors, + Opt_KeepHiFiles, + Opt_KeepOFiles, + Opt_OmitYields, + Opt_PrintBindContents, + Opt_ProfCountEntries, + Opt_SharedImplib, + Opt_SimplPreInlining, + Opt_VersionMacros, + Opt_RPath + ] + + ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] + -- The default -O0 options + + ++ default_PIC platform + + ++ concatMap (wayGeneralFlags platform) (defaultWays settings) + ++ validHoleFitDefaults + + where platform = sTargetPlatform settings + +-- | These are the default settings for the display and sorting of valid hole +-- fits in typed-hole error messages. See Note [Valid hole fits include ...] + -- in the "GHC.Tc.Errors.Hole" module. +validHoleFitDefaults :: [GeneralFlag] +validHoleFitDefaults + = [ Opt_ShowTypeAppOfHoleFits + , Opt_ShowTypeOfHoleFits + , Opt_ShowProvOfHoleFits + , Opt_ShowMatchesOfHoleFits + , Opt_ShowValidHoleFits + , Opt_SortValidHoleFits + , Opt_SortBySizeHoleFits + , Opt_ShowHoleConstraints ] + + +validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +validHoleFitsImpliedGFlags + = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) + , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] + +default_PIC :: Platform -> [GeneralFlag] +default_PIC platform = + case (platformOS platform, platformArch platform) of + -- Darwin always requires PIC. Especially on more recent macOS releases + -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses + -- while we could work around this on x86_64 (like WINE does), we won't be + -- able on aarch64, where this is enforced. + (OSDarwin, ArchX86_64) -> [Opt_PIC] + -- For AArch64, we need to always have PIC enabled. The relocation model + -- on AArch64 does not permit arbitrary relocations. Under ASLR, we can't + -- control much how far apart symbols are in memory for our in-memory static + -- linker; and thus need to ensure we get sufficiently capable relocations. + -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top + -- of that. Subsequently we expect all code on aarch64/linux (and macOS) to + -- be built with -fPIC. + (OSDarwin, ArchAArch64) -> [Opt_PIC] + (OSLinux, ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs] + (OSLinux, ArchARM {}) -> [Opt_PIC, Opt_ExternalDynamicRefs] + (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in + -- OpenBSD since 5.3 release + -- (1 May 2013) we need to + -- always generate PIC. See + -- #10597 for more + -- information. + _ -> [] + +-- General flags that are switched on/off when other general flags are switched +-- on +impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) + ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) + ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting) + ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ] ++ validHoleFitsImpliedGFlags + +-- General flags that are switched on/off when other general flags are switched +-- off +impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] + +impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) + , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) + , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) + , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) + , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) + , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) + , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) + , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 + , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) + + , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! + + , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) + + , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) + , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) + , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) + + , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures + , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. + , (LangExt.TypeInType, turnOn, LangExt.DataKinds) + , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) + , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) + + -- Standalone kind signatures are a replacement for CUSKs. + , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) + , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) + + , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) + + , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) + + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) + , (LangExt.Strict, turnOn, LangExt.StrictData) + ] + +-- Note [When is StarIsType enabled] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The StarIsType extension determines whether to treat '*' as a regular type +-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType +-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is +-- enabled. +-- +-- Programs that use TypeOperators might expect to repurpose '*' for +-- multiplication or another binary operation, but making TypeOperators imply +-- NoStarIsType caused too much breakage on Hackage. +-- + +-- Note [Documenting optimisation flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of flags enabled for particular optimisation levels +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-optimisation.rst +-- +-- Make sure to note whether a flag is implied by -O0, -O or -O2. + +optLevelFlags :: [([Int], GeneralFlag)] +-- Default settings of flags, before any command-line overrides +optLevelFlags -- see Note [Documenting optimisation flags] + = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] + , ([0,1,2], Opt_DmdTxDictSel) + , ([0,1,2], Opt_LlvmTBAA) + + , ([0], Opt_IgnoreInterfacePragmas) + , ([0], Opt_OmitInterfacePragmas) + + , ([1,2], Opt_CallArity) + , ([1,2], Opt_Exitification) + , ([1,2], Opt_CaseMerge) + , ([1,2], Opt_CaseFolding) + , ([1,2], Opt_CmmElimCommonBlocks) + , ([2], Opt_AsmShortcutting) + , ([1,2], Opt_CmmSink) + , ([1,2], Opt_CmmStaticPred) + , ([1,2], Opt_CSE) + , ([1,2], Opt_StgCSE) + , ([2], Opt_StgLiftLams) + + , ([1,2], Opt_EnableRewriteRules) + -- Off for -O0. Otherwise we desugar list literals + -- to 'build' but don't run the simplifier passes that + -- would rewrite them back to cons cells! This seems + -- silly, and matters for the GHCi debugger. + + , ([1,2], Opt_FloatIn) + , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_IgnoreAsserts) + , ([1,2], Opt_Loopification) + , ([1,2], Opt_CfgBlocklayout) -- Experimental + + , ([1,2], Opt_Specialise) + , ([1,2], Opt_CrossModuleSpecialise) + , ([1,2], Opt_Strictness) + , ([1,2], Opt_UnboxSmallStrictFields) + , ([1,2], Opt_CprAnal) + , ([1,2], Opt_WorkerWrapper) + , ([1,2], Opt_SolveConstantDicts) + , ([1,2], Opt_NumConstantFolding) + + , ([2], Opt_LiberateCase) + , ([2], Opt_SpecConstr) +-- , ([2], Opt_RegsGraph) +-- RegsGraph suffers performance regression. See #7679 +-- , ([2], Opt_StaticArgumentTransformation) +-- Static Argument Transformation needs investigation. See #9374 + ] + + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +-- Note [Documenting warning flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of warning enabled by default +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-warnings.rst + +-- | Warning groups. +-- +-- As all warnings are in the Weverything set, it is ignored when +-- displaying to the user which group a warning is in. +warningGroups :: [(String, [WarningFlag])] +warningGroups = + [ ("compat", minusWcompatOpts) + , ("unused-binds", unusedBindsFlags) + , ("default", standardWarnings) + , ("extra", minusWOpts) + , ("all", minusWallOpts) + , ("everything", minusWeverythingOpts) + ] + +-- | Warning group hierarchies, where there is an explicit inclusion +-- relation. +-- +-- Each inner list is a hierarchy of warning groups, ordered from +-- smallest to largest, where each group is a superset of the one +-- before it. +-- +-- Separating this from 'warningGroups' allows for multiple +-- hierarchies with no inherent relation to be defined. +-- +-- The special-case Weverything group is not included. +warningHierarchies :: [[String]] +warningHierarchies = hierarchies ++ map (:[]) rest + where + hierarchies = [["default", "extra", "all"]] + rest = filter (`notElem` "everything" : concat hierarchies) $ + map fst warningGroups + +-- | Find the smallest group in every hierarchy which a warning +-- belongs to, excluding Weverything. +smallestGroups :: WarningFlag -> [String] +smallestGroups flag = mapMaybe go warningHierarchies where + -- Because each hierarchy is arranged from smallest to largest, + -- the first group we find in a hierarchy which contains the flag + -- is the smallest. + go (group:rest) = fromMaybe (go rest) $ do + flags <- lookup group warningGroups + guard (flag `elem` flags) + pure (Just group) + go [] = Nothing + +-- | Warnings enabled unless specified otherwise +standardWarnings :: [WarningFlag] +standardWarnings -- see Note [Documenting warning flags] + = [ Opt_WarnOverlappingPatterns, + Opt_WarnWarningsDeprecations, + Opt_WarnDeprecatedFlags, + Opt_WarnDeferredTypeErrors, + Opt_WarnTypedHoles, + Opt_WarnDeferredOutOfScopeVariables, + Opt_WarnPartialTypeSignatures, + Opt_WarnUnrecognisedPragmas, + Opt_WarnDuplicateExports, + Opt_WarnDerivingDefaults, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnWrongDoBind, + Opt_WarnUnsupportedCallingConventions, + Opt_WarnDodgyForeignImports, + Opt_WarnInlineRuleShadowing, + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion, + Opt_WarnMissedExtraSharedLib, + Opt_WarnTabs, + Opt_WarnUnrecognisedWarningFlags, + Opt_WarnSimplifiableClassConstraints, + Opt_WarnStarBinder, + Opt_WarnInaccessibleCode, + Opt_WarnSpaceAfterBang, + Opt_WarnUnicodeBidirectionalFormatCharacters + ] + +-- | Things you get with -W +minusWOpts :: [WarningFlag] +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedTopBinds, + Opt_WarnUnusedLocalBinds, + Opt_WarnUnusedPatternBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedForalls, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyExports, + Opt_WarnDodgyImports, + Opt_WarnUnbangedStrictPatterns + ] + +-- | Things you get with -Wall +minusWallOpts :: [WarningFlag] +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSignatures, + Opt_WarnHiShadows, + Opt_WarnOrphans, + Opt_WarnUnusedDoBind, + Opt_WarnTrustworthySafe, + Opt_WarnUntickedPromotedConstructors, + Opt_WarnMissingPatternSynonymSignatures, + Opt_WarnUnusedRecordWildcards, + Opt_WarnRedundantRecordWildcards, + Opt_WarnStarIsType + ] + +-- | Things you get with -Weverything, i.e. *all* known warnings flags +minusWeverythingOpts :: [WarningFlag] +minusWeverythingOpts = [ toEnum 0 .. ] + +-- | Things you get with -Wcompat. +-- +-- This is intended to group together warnings that will be enabled by default +-- at some point in the future, so that library authors eager to make their +-- code future compatible to fix issues before they even generate warnings. +minusWcompatOpts :: [WarningFlag] +minusWcompatOpts + = [ Opt_WarnSemigroup + , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnStarIsType + , Opt_WarnCompatUnqualifiedImports + ] + +enableUnusedBinds :: DynP () +enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags + +disableUnusedBinds :: DynP () +disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags + +-- Things you get with -Wunused-binds +unusedBindsFlags :: [WarningFlag] +unusedBindsFlags = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + ] + +enableGlasgowExts :: DynP () +enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls + mapM_ setExtensionFlag glasgowExtsFlags + +disableGlasgowExts :: DynP () +disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls + mapM_ unSetExtensionFlag glasgowExtsFlags + +-- Please keep what_glasgow_exts_does.rst up to date with this list +glasgowExtsFlags :: [LangExt.Extension] +glasgowExtsFlags = [ + LangExt.ConstrainedClassMethods + , LangExt.DeriveDataTypeable + , LangExt.DeriveFoldable + , LangExt.DeriveFunctor + , LangExt.DeriveGeneric + , LangExt.DeriveTraversable + , LangExt.EmptyDataDecls + , LangExt.ExistentialQuantification + , LangExt.ExplicitNamespaces + , LangExt.FlexibleContexts + , LangExt.FlexibleInstances + , LangExt.ForeignFunctionInterface + , LangExt.FunctionalDependencies + , LangExt.GeneralizedNewtypeDeriving + , LangExt.ImplicitParams + , LangExt.KindSignatures + , LangExt.LiberalTypeSynonyms + , LangExt.MagicHash + , LangExt.MultiParamTypeClasses + , LangExt.ParallelListComp + , LangExt.PatternGuards + , LangExt.PostfixOperators + , LangExt.RankNTypes + , LangExt.RecursiveDo + , LangExt.ScopedTypeVariables + , LangExt.StandaloneDeriving + , LangExt.TypeOperators + , LangExt.TypeSynonymInstances + , LangExt.UnboxedTuples + , LangExt.UnicodeSyntax + , LangExt.UnliftedFFITypes ] + +setWarnSafe :: Bool -> DynP () +setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) +setWarnSafe False = return () + +setWarnUnsafe :: Bool -> DynP () +setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) +setWarnUnsafe False = return () + +setPackageTrust :: DynP () +setPackageTrust = do + setGeneralFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + +setGenDeriving :: TurnOnFlag -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + +setDeriveVia :: TurnOnFlag -> DynP () +setDeriveVia True = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l }) +setDeriveVia False = return () + +setOverlappingInsts :: TurnOnFlag -> DynP () +setOverlappingInsts False = return () +setOverlappingInsts True = do + l <- getCurLoc + upd (\d -> d { overlapInstLoc = l }) + +setIncoherentInsts :: TurnOnFlag -> DynP () +setIncoherentInsts False = return () +setIncoherentInsts True = do + l <- getCurLoc + upd (\d -> d { incoherentOnLoc = l }) + +checkTemplateHaskellOk :: TurnOnFlag -> DynP () +checkTemplateHaskellOk _turn_on + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) + +{- ********************************************************************** +%* * + DynFlags constructors +%* * +%********************************************************************* -} + +type DynP = EwM (CmdLineP DynFlags) + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' + +--------------- Constructor functions for OptKind ----------------- +noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +noArg fn = NoArg (upd fn) + +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + +hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +hasArg fn = HasArg (upd . fn) + +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + +intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffix fn = IntSuffix (\n -> upd (fn n)) + +intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffixM fn = IntSuffix (\n -> updM (fn n)) + +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + +setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +-------------------------- +addWay :: Way -> DynP () +addWay w = upd (addWay' w) + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = let platform = targetPlatform dflags0 + dflags1 = dflags0 { ways = Set.insert w (ways dflags0) } + dflags2 = foldr setGeneralFlag' dflags1 + (wayGeneralFlags platform w) + dflags3 = foldr unSetGeneralFlag' dflags2 + (wayUnsetGeneralFlags platform w) + in dflags3 + +removeWayDyn :: DynP () +removeWayDyn = upd (\dfs -> dfs { ways = Set.filter (WayDyn /=) (ways dfs) }) + +-------------------------- +setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () +setGeneralFlag f = upd (setGeneralFlag' f) +unSetGeneralFlag f = upd (unSetGeneralFlag' f) + +setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedGFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setGeneralFlag recursively, in case the implied flags + -- implies further flags + +unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedOffGFlags, f' == f ] + -- In general, when you un-set f, we don't un-set the things it implies. + -- There are however some exceptions, e.g., -fno-strictness implies + -- -fno-worker-wrapper. + -- + -- NB: use unSetGeneralFlag' recursively, in case the implied off flags + -- imply further flags. + +-------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () +setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) +unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) + +setWErrorFlag :: WarningFlag -> DynP () +setWErrorFlag flag = + do { setWarningFlag flag + ; setFatalWarningFlag flag } + +-------------------------- +setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () +setExtensionFlag f = upd (setExtensionFlag' f) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + deps = [ if turn_on then setExtensionFlag' d + else unSetExtensionFlag' d + | (f', turn_on, d) <- impliedXFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setExtensionFlag recursively, in case the implied flags + -- implies further flags + +unSetExtensionFlag' f dflags = xopt_unset dflags f + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + +-------------------------- +alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags +alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) } + +alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags +alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } + +-------------------------- +setDumpFlag' :: DumpFlag -> DynP () +setDumpFlag' dump_flag + = do upd (\dfs -> dopt_set dfs dump_flag) + when want_recomp forceRecompile + where -- Certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs, + Opt_D_no_debug_output] + +forceRecompile :: DynP () +-- Whenever we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, +-- don't switch it off in --make mode, else *everything* gets +-- recompiled which probably isn't what you want +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) + where + force_recomp dfs = isOneShot (ghcMode dfs) + + +setVerboseCore2Core :: DynP () +setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core + +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) + +setDebugLevel :: Maybe Int -> DynP () +setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 }) + +data PkgDbRef + = GlobalPkgDb + | UserPkgDb + | PkgDbPath FilePath + deriving Eq + +addPkgDbRef :: PkgDbRef -> DynP () +addPkgDbRef p = upd $ \s -> + s { packageDBFlags = PackageDB p : packageDBFlags s } + +removeUserPkgDb :: DynP () +removeUserPkgDb = upd $ \s -> + s { packageDBFlags = NoUserPackageDB : packageDBFlags s } + +removeGlobalPkgDb :: DynP () +removeGlobalPkgDb = upd $ \s -> + s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } + +clearPkgDb :: DynP () +clearPkgDb = upd $ \s -> + s { packageDBFlags = ClearPackageDBs : packageDBFlags s } + +parsePackageFlag :: String -- the flag + -> ReadP PackageArg -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag flag arg_parse str + = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where doc = flag ++ " " ++ str + parse = do + pkg_arg <- tok arg_parse + let mk_expose = ExposePackage doc pkg_arg + ( do _ <- tok $ string "with" + fmap (mk_expose . ModRenaming True) parseRns + <++ fmap (mk_expose . ModRenaming False) parseRns + <++ return (mk_expose (ModRenaming True []))) + parseRns = do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return rns + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (orig, new) + +++ + return (orig, orig)) + tok m = m >>= \x -> skipSpaces >> return x + +exposePackage, exposePackageId, hidePackage, + exposePluginPackage, exposePluginPackageId, + ignorePackage, + trustPackage, distrustPackage :: String -> DynP () +exposePackage p = upd (exposePackage' p) +exposePackageId p = + upd (\s -> s{ packageFlags = + parsePackageFlag "-package-id" parseUnitArg p : packageFlags s }) +exposePluginPackage p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) +exposePluginPackageId p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) + +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) + +exposePackage' :: String -> DynFlags -> DynFlags +exposePackage' p dflags + = dflags { packageFlags = + parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } + +parsePackageArg :: ReadP PackageArg +parsePackageArg = + fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) + +parseUnitArg :: ReadP PackageArg +parseUnitArg = + fmap UnitIdArg parseUnit + +setUnitId :: String -> DynFlags -> DynFlags +setUnitId p d = d { homeUnitId = stringToUnitId p } + +-- | Given a 'ModuleName' of a signature in the home library, find +-- out how it is instantiated. E.g., the canonical form of +-- A in @p[A=q[]:A]@ is @q[]:A@. +canonicalizeHomeModule :: DynFlags -> ModuleName -> Module +canonicalizeHomeModule dflags mod_name = + case lookup mod_name (homeUnitInstantiations dflags) of + Nothing -> mkHomeModule dflags mod_name + Just mod -> mod + +canonicalizeModuleIfHome :: DynFlags -> Module -> Module +canonicalizeModuleIfHome dflags mod + = if homeUnit dflags == moduleUnit mod + then canonicalizeHomeModule dflags (moduleName mod) + else mod + +-- If we're linking a binary, then only targets that produce object +-- code are allowed (requests for other target types are ignored). +setTarget :: HscTarget -> DynP () +setTarget l = upd $ \ dfs -> + if ghcLink dfs /= LinkBinary || isObjectTarget l + then dfs{ hscTarget = l } + else dfs + +-- Changes the target only if we're compiling object code. This is +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm +-- can be safely used in an OPTIONS_GHC pragma. +setObjTarget :: HscTarget -> DynP () +setObjTarget l = updM set + where + set dflags + | isObjectTarget (hscTarget dflags) + = return $ dflags { hscTarget = l } + | otherwise = return dflags + +setOptLevel :: Int -> DynFlags -> DynP DynFlags +setOptLevel n dflags = return (updOptLevel n dflags) + +checkOptLevel :: Int -> DynFlags -> Either String DynFlags +checkOptLevel n dflags + | hscTarget dflags == HscInterpreted && n > 0 + = Left "-O conflicts with --interactive; -O ignored." + | otherwise + = Right dflags + +setMainIs :: String -> DynP () +setMainIs arg + | not (null main_fn) && isLower (head main_fn) + -- The arg looked like "Foo.Bar.baz" + = upd $ \d -> d { mainFunIs = Just main_fn, + mainModIs = mkModule mainUnit (mkModuleName main_mod) } + + | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + = upd $ \d -> d { mainModIs = mkModule mainUnit (mkModuleName arg) } + + | otherwise -- The arg looked like "baz" + = upd $ \d -> d { mainFunIs = Just arg } + where + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + +-- ----------------------------------------------------------------------------- +-- Load dynflags from environment files. + +setFlagsFromEnvFile :: FilePath -> String -> DynP () +setFlagsFromEnvFile envfile content = do + setGeneralFlag Opt_HideAllPackages + parseEnvFile envfile content + +parseEnvFile :: FilePath -> String -> DynP () +parseEnvFile envfile = mapM_ parseEntry . lines + where + parseEntry str = case words str of + ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str + ["clear-package-db"] -> clearPkgDb + ["global-package-db"] -> addPkgDbRef GlobalPkgDb + ["user-package-db"] -> addPkgDbRef UserPkgDb + ["package-id", pkgid] -> exposePackageId pkgid + (('-':'-':_):_) -> return () -- comments + -- and the original syntax introduced in 7.10: + [pkgid] -> exposePackageId pkgid + [] -> return () + _ -> throwGhcException $ CmdLineError $ + "Can't parse environment file entry: " + ++ envfile ++ ": " ++ str + + +----------------------------------------------------------------------------- +-- Paths & Libraries + +addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = + addGlobalInclude (includePaths s) (splitPathList p)}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +#if !defined(mingw32_HOST_OS) +split_marker :: Char +split_marker = ':' -- not configurable (ToDo) +#endif + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#if !defined(mingw32_HOST_OS) + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- ":/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, _:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir } + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 + +----------------------------------------------------------------------------- +-- RTS opts + +setRtsOpts :: String -> DynP () +setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} + +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + +----------------------------------------------------------------------------- +-- Hpc stuff + +setOptHpcDir :: String -> DynP () +setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +-- There are some options that we need to pass to gcc when compiling +-- Haskell code via C, but are only supported by recent versions of +-- gcc. The configure script decides which of these options we need, +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. +-- +-- The options below are not dependent on the version of gcc, only the +-- platform. + +picCCOpts :: DynFlags -> [String] +picCCOpts dflags = pieOpts ++ picOpts + where + picOpts = + case platformOS (targetPlatform dflags) of + OSDarwin + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] + | otherwise -> ["-mdynamic-no-pic"] + OSMinGW32 -- no -fPIC for Windows + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] + | otherwise -> [] + _ + -- we need -fPIC for C files when we are compiling with -dynamic, + -- otherwise things like stub.c files don't get compiled + -- correctly. They need to reference data in the Haskell + -- objects, but can't without -fPIC. See + -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code + | gopt Opt_PIC dflags || WayDyn `Set.member` ways dflags -> + ["-fPIC", "-U__PIC__", "-D__PIC__"] + -- gcc may be configured to have PIC on by default, let's be + -- explicit here, see #15847 + | otherwise -> ["-fno-PIC"] + + pieOpts + | gopt Opt_PICExecutable dflags = ["-pie"] + -- See Note [No PIE when linking] + | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"] + | otherwise = [] + + +{- +Note [No PIE while linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by +default in their gcc builds. This is incompatible with -r as it implies that we +are producing an executable. Consequently, we must manually pass -no-pie to gcc +when joining object files or linking dynamic libraries. Unless, of course, the +user has explicitly requested a PIE executable with -pie. See #12759. +-} + +picPOpts :: DynFlags -> [String] +picPOpts dflags + | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- Compiler Info + +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) + (rawSettings dflags) + ++ [("Project version", projectVersion dflags), + ("Project Git commit id", cProjectGitCommitId), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), + ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), + ("Object splitting supported", showBool False), + ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), + ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + -- Whether or not we support @-dynamic-too@ + ("Support dynamic-too", showBool $ not isWindows), + -- Whether or not we support the @-j@ flag with @--make@. + ("Support parallel --make", "YES"), + -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in + -- installed package info. + ("Support reexported-modules", "YES"), + -- Whether or not we support extended @-package foo (Foo)@ syntax. + ("Support thinning and renaming package flags", "YES"), + -- Whether or not we support Backpack. + ("Support Backpack", "YES"), + -- If true, we require that the 'id' field in installed package info + -- match what is passed to the @-this-unit-id@ flag for modules + -- built in it + ("Requires unified installed package IDs", "YES"), + -- Whether or not we support the @-this-package-key@ flag. Prefer + -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@ + -- flag has been removed, otherwise it breaks Cabal... + ("Uses package keys", "YES"), + -- Whether or not we support the @-this-unit-id@ flag + ("Uses unit IDs", "YES"), + -- Whether or not GHC compiles libraries as dynamic by default + ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), + -- Whether or not GHC was compiled using -dynamic + ("GHC Dynamic", showBool hostIsDynamic), + -- Whether or not GHC was compiled using -prof + ("GHC Profiled", showBool hostIsProfiled), + ("Debug on", showBool debugIsOn), + ("LibDir", topDir dflags), + -- The path of the global package database used by GHC + ("Global Package DB", globalPackageDatabasePath dflags) + ] + where + showBool True = "YES" + showBool False = "NO" + isWindows = platformOS (targetPlatform dflags) == OSMinGW32 + expandDirectories :: FilePath -> Maybe FilePath -> String -> String + expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd + +-- Produced by deriveConstants +#include "GHCConstantsHaskellWrappers.hs" + +bLOCK_SIZE_W :: DynFlags -> Int +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` platformWordSizeInBytes platform + where platform = targetPlatform dflags + +wordAlignment :: Platform -> Alignment +wordAlignment platform = alignmentOf (platformWordSizeInBytes platform) + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK + +{- ----------------------------------------------------------------------------- +Note [DynFlags consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +the flags; this is because API clients may parse flags but update the +DynFlags afterwords, before finally running code inside a session (see +T10052 and #10052). +-} + +-- | Resolve any internal inconsistencies in a set of 'DynFlags'. +-- Returns the consistent 'DynFlags' as well as a list of warnings +-- to report to the user. +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) +-- Whenever makeDynFlagsConsistent does anything, it starts over, to +-- ensure that a later change doesn't invalidate an earlier check. +-- Be careful not to introduce potential loops! +makeDynFlagsConsistent dflags + -- Disable -dynamic-too on Windows (#8228, #7134, #5987) + | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is not supported on Windows" + in loop dflags' warn + + -- Via-C backend only supports unregisterised convention. Switch to a backend + -- supporting it if possible. + | hscTarget dflags == HscC && + not (platformUnregisterised (targetPlatform dflags)) + = case platformDefaultBackend (targetPlatform dflags) of + NCG -> let dflags' = dflags { hscTarget = HscAsm } + warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C" + in loop dflags' warn + LLVM -> let dflags' = dflags { hscTarget = HscLlvm } + warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C" + in loop dflags' warn + _ -> pgmError "Compiling via C is only supported with unregisterised ABI but target platform doesn't use it." + | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted + = let dflags' = gopt_unset dflags Opt_Hpc + warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." + in loop dflags' warn + + | hscTarget dflags `elem` [HscAsm, HscLlvm] && + platformUnregisterised (targetPlatform dflags) + = loop (dflags { hscTarget = HscC }) + "Target platform uses unregisterised ABI, so compiling via C" + + | hscTarget dflags == HscAsm && + not (platformNcgSupported $ targetPlatform dflags) + = let dflags' = dflags { hscTarget = HscLlvm } + warn = "Native code generator doesn't support target platform, so using LLVM" + in loop dflags' warn + + | not (osElfTarget os) && gopt Opt_PIE dflags + = loop (gopt_unset dflags Opt_PIE) + "Position-independent only supported on ELF platforms" + | os == OSDarwin && + arch == ArchX86_64 && + not (gopt Opt_PIC dflags) + = loop (gopt_set dflags Opt_PIC) + "Enabling -fPIC as it is always on for this platform" + | Left err <- checkOptLevel (optLevel dflags) dflags + = loop (updOptLevel 0 dflags) err + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , hostIsProfiled + , isObjectTarget (hscTarget dflags) + , WayProf `Set.notMember` ways dflags + = loop dflags{ways = Set.insert WayProf (ways dflags)} + "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" + + | otherwise = (dflags, []) + where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") + loop updated_dflags warning + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws) -> (dflags', L loc warning : ws) + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + +-------------------------------------------------------------------------- +-- Do not use unsafeGlobalDynFlags! +-- +-- unsafeGlobalDynFlags is a hack, necessary because we need to be able +-- to show SDocs when tracing, but we don't always have DynFlags +-- available. +-- +-- Do not use it if you can help it. You may get the wrong value, or this +-- panic! + +-- | This is the value that 'unsafeGlobalDynFlags' takes before it is +-- initialized. +defaultGlobalDynFlags :: DynFlags +defaultGlobalDynFlags = + (defaultDynFlags settings llvmConfig) { verbosity = 2 } + where + settings = panic "v_unsafeGlobalDynFlags: settings not initialised" + llvmConfig = panic "v_unsafeGlobalDynFlags: llvmConfig not initialised" + +#if GHC_STAGE < 2 +GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) +#else +SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags + , getOrSetLibHSghcGlobalDynFlags + , "getOrSetLibHSghcGlobalDynFlags" + , defaultGlobalDynFlags + , DynFlags ) +#endif + +unsafeGlobalDynFlags :: DynFlags +unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags + +setUnsafeGlobalDynFlags :: DynFlags -> IO () +setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags + +-- ----------------------------------------------------------------------------- +-- SSE and AVX + +-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to +-- check if SSE is enabled, we might have x86-64 imply the -msse2 +-- flag. + +isSseEnabled :: DynFlags -> Bool +isSseEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> True + ArchX86 -> True + _ -> False + +isSse2Enabled :: DynFlags -> Bool +isSse2Enabled dflags = case platformArch (targetPlatform dflags) of + -- We Assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + ArchX86_64 -> True + ArchX86 -> True + _ -> False + + +isSse4_2Enabled :: DynFlags -> Bool +isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 + +isAvxEnabled :: DynFlags -> Bool +isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags + +isAvx2Enabled :: DynFlags -> Bool +isAvx2Enabled dflags = avx2 dflags || avx512f dflags + +isAvx512cdEnabled :: DynFlags -> Bool +isAvx512cdEnabled dflags = avx512cd dflags + +isAvx512erEnabled :: DynFlags -> Bool +isAvx512erEnabled dflags = avx512er dflags + +isAvx512fEnabled :: DynFlags -> Bool +isAvx512fEnabled dflags = avx512f dflags + +isAvx512pfEnabled :: DynFlags -> Bool +isAvx512pfEnabled dflags = avx512pf dflags + +-- ----------------------------------------------------------------------------- +-- BMI2 + +isBmiEnabled :: DynFlags -> Bool +isBmiEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI1 + ArchX86 -> bmiVersion dflags >= Just BMI1 + _ -> False + +isBmi2Enabled :: DynFlags -> Bool +isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI2 + ArchX86 -> bmiVersion dflags >= Just BMI2 + _ -> False + +-- | Indicate if cost-centre profiling is enabled +sccProfilingEnabled :: DynFlags -> Bool +sccProfilingEnabled dflags = ways dflags `hasWay` WayProf + +-- ----------------------------------------------------------------------------- +-- Linker/compiler information + +-- LinkerInfo contains any extra options needed by the system linker. +data LinkerInfo + = GnuLD [Option] + | GnuGold [Option] + | LlvmLLD [Option] + | DarwinLD [Option] + | SolarisLD [Option] + | AixLD [Option] + | UnknownLD + deriving Eq + +-- CompilerInfo tells us which C compiler we're using +data CompilerInfo + = GCC + | Clang + | AppleClang + | AppleClang51 + | UnknownCC + deriving Eq + + +-- | Should we use `-XLinker -rpath` when linking or not? +-- See Note [-fno-use-rpaths] +useXLinkerRPath :: DynFlags -> OS -> Bool +useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS] +useXLinkerRPath dflags _ = gopt Opt_RPath dflags + +{- +Note [-fno-use-rpaths] +~~~~~~~~~~~~~~~~~~~~~~ + +First read, Note [Dynamic linking on macOS] to understand why on darwin we never +use `-XLinker -rpath`. + +The specification of `Opt_RPath` is as follows: + +The default case `-fuse-rpaths`: +* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath + afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin + as things stand but it wasn't documented in the user guide before this patch how + `-fuse-rpaths` should behave and the fact it was always disabled on darwin. +* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable, + this is the normal way you should set the rpath. + +The case of `-fno-use-rpaths` +* Never inject anything into the rpath. + +When this was first implemented, `Opt_RPath` was disabled on darwin, but +the rpath was still always augmented by `runInjectRPaths`, and there was no way to +stop this. This was problematic because you couldn't build an executable in CI +with a clean rpath. + +-} + +-- ----------------------------------------------------------------------------- +-- RTS hooks + +-- Convert sizes like "3.5M" into integers +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = readRational m + pred c = isDigit c || c == '.' + +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () + +-- ----------------------------------------------------------------------------- +-- Types for managing temporary files. +-- +-- these are here because FilesToClean is used in DynFlags + +-- | A collection of files that must be deleted before ghc exits. +-- The current collection +-- is stored in an IORef in DynFlags, 'filesToClean'. +data FilesToClean = FilesToClean { + ftcGhcSession :: !(Set FilePath), + -- ^ Files that will be deleted at the end of runGhc(T) + ftcCurrentModule :: !(Set FilePath) + -- ^ Files that will be deleted the next time + -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the + -- end of the session. + } + +-- | An empty FilesToClean +emptyFilesToClean :: FilesToClean +emptyFilesToClean = FilesToClean Set.empty Set.empty + + +-- | Initialize the pretty-printing options +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags style = SDC + { sdocStyle = style + , sdocColScheme = colScheme dflags + , sdocLastColour = Col.colReset + , sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags) + , sdocDefaultDepth = pprUserLength dflags + , sdocLineLength = pprCols dflags + , sdocCanUseUnicode = useUnicode dflags + , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags + , sdocPprDebug = dopt Opt_D_ppr_debug dflags + , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags + , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags + , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags + , sdocPrintAxiomIncomps = gopt Opt_PrintAxiomIncomps dflags + , sdocPrintExplicitKinds = gopt Opt_PrintExplicitKinds dflags + , sdocPrintExplicitCoercions = gopt Opt_PrintExplicitCoercions dflags + , sdocPrintExplicitRuntimeReps = gopt Opt_PrintExplicitRuntimeReps dflags + , sdocPrintExplicitForalls = gopt Opt_PrintExplicitForalls dflags + , sdocPrintPotentialInstances = gopt Opt_PrintPotentialInstances dflags + , sdocPrintEqualityRelations = gopt Opt_PrintEqualityRelations dflags + , sdocSuppressTicks = gopt Opt_SuppressTicks dflags + , sdocSuppressTypeSignatures = gopt Opt_SuppressTypeSignatures dflags + , sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags + , sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags + , sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags + , sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags + , sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags + , sdocSuppressUniques = gopt Opt_SuppressUniques dflags + , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags + , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags + , sdocErrorSpans = gopt Opt_ErrorSpans dflags + , sdocStarIsType = xopt LangExt.StarIsType dflags + , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags + , sdocLinearTypes = xopt LangExt.LinearTypes dflags + , sdocPrintTypeAbbreviations = True + , sdocDynFlags = dflags + } + +-- | Initialize the pretty-printing options using the default user style +initDefaultSDocContext :: DynFlags -> SDocContext +initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle diff --git a/GHC/Driver/Session.hs-boot b/GHC/Driver/Session.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Session.hs-boot @@ -0,0 +1,15 @@ +module GHC.Driver.Session where + +import GHC.Prelude +import GHC.Platform +import {-# SOURCE #-} GHC.Utils.Outputable +import {-# SOURCE #-} GHC.Unit.State + +data DynFlags + +targetPlatform :: DynFlags -> Platform +unitState :: DynFlags -> UnitState +unsafeGlobalDynFlags :: DynFlags +hasPprDebug :: DynFlags -> Bool +hasNoDebugOutput :: DynFlags -> Bool +initSDocContext :: DynFlags -> PprStyle -> SDocContext diff --git a/GHC/Driver/Types.hs b/GHC/Driver/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Types.hs @@ -0,0 +1,3407 @@ +{- +(c) The University of Glasgow, 2006 + +\section[GHC.Driver.Types]{Types for the per-module compiler} +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} + +-- | Types for the per-module compiler +module GHC.Driver.Types ( + -- * compilation state + HscEnv(..), hscEPS, + FinderCache, FindResult(..), InstalledFindResult(..), + Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, + HscStatus(..), + + -- * ModuleGraph + ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG, + mgModSummaries, mgElemModule, mgLookupModule, + needsTemplateHaskellOrQQ, mgBootModules, + + -- * Hsc monad + Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc, + + -- * Information about modules + ModDetails(..), emptyModDetails, + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, + ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), + ForeignSrcLang(..), + phaseForeignLanguage, + + ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps, + home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary, + msHsFilePath, msHiFilePath, msObjFilePath, + SourceModified(..), isTemplateHaskellOrQQNonBoot, + + -- * Information about the module being compiled + -- (re-exported from GHC.Driver.Phases) + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + + + -- * State relating to modules in this package + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + lookupHpt, eltsHpt, filterHpt, allHpt, anyHpt, mapHpt, delFromHpt, + addToHpt, addListToHpt, lookupHptDirectly, listToHpt, + hptCompleteSigs, + hptInstances, hptRules, pprHPT, + + -- * State relating to known packages + ExternalPackageState(..), EpsStats(..), addEpsInStats, + PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, + lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule, + + PackageInstEnv, PackageFamInstEnv, PackageRuleBase, + PackageCompleteMatchMap, + + mkSOName, mkHsSOName, soExt, + + -- * Metaprogramming + MetaRequest(..), + MetaResult, -- data constructors not exported to ensure correct response type + metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, + MetaHook, + + -- * Annotations + prepareAnnotations, + + -- * Interactive context + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, + extendInteractiveContext, extendInteractiveContextWithIds, + substInteractiveContext, + setInteractivePrintName, icInteractiveModule, + InteractiveImport(..), setInteractivePackage, + mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, + + -- * Interfaces + ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..), + mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, + emptyIfaceWarnCache, mi_boot, mi_fix, + mi_semantic_module, + mi_free_holes, + renameFreeHoles, + + -- * Fixity + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, + + -- * TyThings and type environments + TyThing(..), tyThingAvailInfo, + tyThingTyCon, tyThingDataCon, tyThingConLike, + tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, + implicitTyThings, implicitTyConThings, implicitClassThings, + isImplicitTyThing, + + TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, + typeEnvFromEntities, mkTypeEnvWithImplicits, + extendTypeEnv, extendTypeEnvList, + extendTypeEnvWithIds, plusTypeEnv, + lookupTypeEnv, + typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, + typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, + + -- * MonadThings + MonadThings(..), + + -- * Information on imports and exports + WhetherHasOrphans, IsBootInterface(..), Usage(..), + Dependencies(..), noDependencies, + updNameCache, + IfaceExport, + + -- * Warnings + Warnings(..), WarningTxt(..), plusWarns, + + -- * Linker stuff + Linkable(..), isObjectLinkable, linkableObjs, + Unlinked(..), CompiledByteCode, + isObject, nameOfObject, isInterpretable, byteCodeOfObject, + + -- * Program coverage + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, + + -- * Breakpoints + ModBreaks (..), emptyModBreaks, + + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, IsSafeImport, + + -- * result of the parser + HsParsedModule(..), + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, throwErrors, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, + + -- * COMPLETE signature + CompleteMatch(..), CompleteMatchMap, + mkCompleteMatchMap, extendCompleteMatchMap, + + -- * Exstensible Iface fields + ExtensibleFields(..), FieldName, + emptyExtensibleFields, + readField, readIfaceField, readIfaceFieldWith, + writeField, writeIfaceField, writeIfaceFieldWith, + deleteField, deleteIfaceField, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.ByteCode.Types +import GHC.Runtime.Eval.Types ( Resume ) +import GHC.Runtime.Interpreter.Types (Interp) +import GHC.ForeignSrcLang + +import GHC.Types.Unique.FM +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Types.Avail +import GHC.Unit +import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) +import GHC.Core.FamInstEnv +import GHC.Core ( CoreProgram, RuleBase, CoreRule ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info ( IdDetails(..), RecSelParent(..)) +import GHC.Core.Type + +import GHC.Parser.Annotation ( ApiAnns ) +import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Builtin.Names ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) +import GHC.Builtin.Types +import GHC.Driver.CmdLine +import GHC.Driver.Session +import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) +import GHC.Driver.Phases + ( Phase, HscSource(..), hscSourceString + , isHsBootOrSig, isHsigFile ) +import qualified GHC.Driver.Phases as Phase +import GHC.Types.Basic +import GHC.Iface.Syntax +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.DFM +import GHC.Data.FastString +import GHC.Data.StringBuffer ( StringBuffer ) +import GHC.Utils.Fingerprint +import GHC.Utils.Monad +import GHC.Data.Bag +import GHC.Utils.Binary +import GHC.Utils.Error +import GHC.Types.Name.Cache +import GHC.Platform +import GHC.Utils.Misc +import GHC.Types.Unique.DSet +import GHC.Serialized ( Serialized ) +import qualified GHC.LanguageExtensions as LangExt + +import Foreign +import Control.Monad ( guard, liftM, ap, forM, forM_, replicateM ) +import Data.IORef +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Time +import GHC.Utils.Exception +import System.FilePath +import Control.DeepSeq +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class +import Control.Monad.Catch as MC (MonadCatch, catch) + +-- ----------------------------------------------------------------------------- +-- Compilation state +-- ----------------------------------------------------------------------------- + +-- | Status of a compilation to hard-code +data HscStatus + -- | Nothing to do. + = HscNotGeneratingCode ModIface ModDetails + -- | Nothing to do because code already exists. + | HscUpToDate ModIface ModDetails + -- | Update boot file result. + | HscUpdateBoot ModIface ModDetails + -- | Generate signature file (backpack) + | HscUpdateSig ModIface ModDetails + -- | Recompile this module. + | HscRecomp + { hscs_guts :: CgGuts + -- ^ Information for the code generator. + , hscs_mod_location :: !ModLocation + -- ^ Module info + , hscs_partial_iface :: !PartialModIface + -- ^ Partial interface + , hscs_old_iface_hash :: !(Maybe Fingerprint) + -- ^ Old interface hash for this compilation, if an old interface file + -- exists. Pass to `hscMaybeWriteIface` when writing the interface to + -- avoid updating the existing interface when the interface isn't + -- changed. + , hscs_iface_dflags :: !DynFlags + -- ^ Generate final iface using this DynFlags. + -- FIXME (osa): I don't understand why this is necessary, but I spent + -- almost two days trying to figure this out and I couldn't .. perhaps + -- someone who understands this code better will remove this later. + } +-- Should HscStatus contain the HomeModInfo? +-- All places where we return a status we also return a HomeModInfo. + +-- ----------------------------------------------------------------------------- +-- The Hsc monad: Passing an environment and warning state + +newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) + deriving (Functor) + +instance Applicative Hsc where + pure a = Hsc $ \_ w -> return (a, w) + (<*>) = ap + +instance Monad Hsc where + Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w + case k a of + Hsc k' -> k' e w1 + +instance MonadIO Hsc where + liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) + +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env (Hsc hsc) = do + (a, w) <- hsc hsc_env emptyBag + printOrThrowWarnings (hsc_dflags hsc_env) w + return a + +mkInteractiveHscEnv :: HscEnv -> HscEnv +mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags } + where + interactive_dflags = ic_dflags (hsc_IC hsc_env) + +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) + +-- ----------------------------------------------------------------------------- +-- Source Errors + +-- When the compiler (GHC.Driver.Main) discovers errors, it throws an +-- exception in the IO monad. + +mkSrcErr :: ErrorMessages -> SourceError +mkSrcErr = SourceError + +srcErrorMessages :: SourceError -> ErrorMessages +srcErrorMessages (SourceError msgs) = msgs + +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + +throwErrors :: MonadIO io => ErrorMessages -> io a +throwErrors = liftIO . throwIO . mkSrcErr + +throwOneError :: MonadIO io => ErrMsg -> io a +throwOneError = throwErrors . unitBag + +-- | A source error is an error that is caused by one or more errors in the +-- source code. A 'SourceError' is thrown by many functions in the +-- compilation pipeline. Inside GHC these errors are merely printed via +-- 'log_action', but API clients may treat them differently, for example, +-- insert them into a list box. If you want the default behaviour, use the +-- idiom: +-- +-- > handleSourceError printExceptionAndWarnings $ do +-- > ... api calls that may fail ... +-- +-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. +-- This list may be empty if the compiler failed due to @-Werror@ +-- ('Opt_WarnIsError'). +-- +-- See 'printExceptionAndWarnings' for more information on what to take care +-- of when writing a custom error handler. +newtype SourceError = SourceError ErrorMessages + +instance Show SourceError where + show (SourceError msgs) = unlines . map show . bagToList $ msgs + +instance Exception SourceError + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleSourceError :: (MonadCatch m) => + (SourceError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleSourceError handler act = + MC.catch act (\(e :: SourceError) -> handler e) + +-- | An error thrown if the GHC API is used in an incorrect fashion. +newtype GhcApiError = GhcApiError String + +instance Show GhcApiError where + show (GhcApiError msg) = msg + +instance Exception GhcApiError + +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns = do + let (make_error, warns') = + mapAccumBagL + (\make_err warn -> + case isWarnMsgFatal dflags warn of + Nothing -> + (make_err, warn) + Just err_reason -> + (True, warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason + })) + False warns + if make_error + then throwIO (mkSrcErr warns') + else printBagOfErrors dflags warns + +handleFlagWarnings :: DynFlags -> [Warn] -> IO () +handleFlagWarnings dflags warns = do + let warns' = filter (shouldPrintWarning dflags . warnReason) warns + + -- It would be nicer if warns :: [Located MsgDoc], but that + -- has circular import problems. + bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) + | Warn _ (L loc warn) <- warns' ] + + printOrThrowWarnings dflags bag + +-- Given a warn reason, check to see if it's associated -W opt is enabled +shouldPrintWarning :: DynFlags -> GHC.Driver.CmdLine.WarnReason -> Bool +shouldPrintWarning dflags ReasonDeprecatedFlag + = wopt Opt_WarnDeprecatedFlags dflags +shouldPrintWarning dflags ReasonUnrecognisedFlag + = wopt Opt_WarnUnrecognisedWarningFlags dflags +shouldPrintWarning _ _ + = True + +{- +************************************************************************ +* * +\subsection{HscEnv} +* * +************************************************************************ +-} + +-- | HscEnv is like 'Session', except that some of the fields are immutable. +-- An HscEnv is used to compile a single module from plain Haskell source +-- code (after preprocessing) to either C, assembly or C--. It's also used +-- to store the dynamic linker state to allow for multiple linkers in the +-- same address space. +-- Things like the module graph don't change during a single compilation. +-- +-- Historical note: \"hsc\" used to be the name of the compiler binary, +-- when there was a separate driver and compiler. To compile a single +-- module, the driver would invoke hsc on the source code... so nowadays +-- we think of hsc as the layer of the compiler that deals with compiling +-- a single module. +data HscEnv + = HscEnv { + hsc_dflags :: DynFlags, + -- ^ The dynamic flag settings + + hsc_targets :: [Target], + -- ^ The targets (or roots) of the current session + + hsc_mod_graph :: ModuleGraph, + -- ^ The module graph of the current session + + hsc_IC :: InteractiveContext, + -- ^ The context for evaluating interactive statements + + hsc_HPT :: HomePackageTable, + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'hsc_HPT' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), + -- ^ Information about the currently loaded external packages. + -- This is mutable because packages will be demand-loaded during + -- a compilation run as required. + + hsc_NC :: {-# UNPACK #-} !(IORef NameCache), + -- ^ As with 'hsc_EPS', this is side-effected by compiling to + -- reflect sucking in interface files. They cache the state of + -- external interface files, in effect. + + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + -- ^ The cached result of performing finding in the file system + + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) + -- ^ Used for one-shot compilation only, to initialise + -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for + -- 'GHC.Tc.Utils.TcGblEnv'. See also Note [hsc_type_env_var hack] + + , hsc_interp :: Maybe Interp + -- ^ target code interpreter (if any) to use for TH and GHCi. + -- See Note [Target code interpreter] + + , hsc_dynLinker :: DynLinker + -- ^ dynamic linker. + + } + +{- + +Note [Target code interpreter] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Template Haskell and GHCi use an interpreter to execute code that is built for +the compiler target platform (= code host platform) on the compiler host +platform (= code build platform). + +The internal interpreter can be used when both platforms are the same and when +the built code is compatible with the compiler itself (same way, etc.). This +interpreter is not always available: for instance stage1 compiler doesn't have +it because there might be an ABI mismatch between the code objects (built by +stage1 compiler) and the stage1 compiler itself (built by stage0 compiler). + +In most cases, an external interpreter can be used instead: it runs in a +separate process and it communicates with the compiler via a two-way message +passing channel. The process is lazily spawned to avoid overhead when it is not +used. + +The target code interpreter to use can be selected per session via the +`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in +which case Template Haskell and GHCi will fail to run. The interpreter to use is +configured via command-line flags (in `GHC.setSessionDynFlags`). + + +-} + +-- Note [hsc_type_env_var hack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- hsc_type_env_var is used to initialize tcg_type_env_var, and +-- eventually it is the mutable variable that is queried from +-- if_rec_types to get a TypeEnv. So, clearly, it's something +-- related to knot-tying (see Note [Tying the knot]). +-- hsc_type_env_var is used in two places: initTcRn (where +-- it initializes tcg_type_env_var) and initIfaceCheck +-- (where it initializes if_rec_types). +-- +-- But why do we need a way to feed a mutable variable in? Why +-- can't we just initialize tcg_type_env_var when we start +-- typechecking? The problem is we need to knot-tie the +-- EPS, and we may start adding things to the EPS before type +-- checking starts. +-- +-- Here is a concrete example. Suppose we are running +-- "ghc -c A.hs", and we have this file system state: +-- +-- A.hs-boot A.hi-boot **up to date** +-- B.hs B.hi **up to date** +-- A.hs A.hi **stale** +-- +-- The first thing we do is run checkOldIface on A.hi. +-- checkOldIface will call loadInterface on B.hi so it can +-- get its hands on the fingerprints, to find out if A.hi +-- needs recompilation. But loadInterface also populates +-- the EPS! And so if compilation turns out to be necessary, +-- as it is in this case, the thunks we put into the EPS for +-- B.hi need to have the correct if_rec_types mutable variable +-- to query. +-- +-- If the mutable variable is only allocated WHEN we start +-- typechecking, then that's too late: we can't get the +-- information to the thunks. So we need to pre-commit +-- to a type variable in 'hscIncrementalCompile' BEFORE we +-- check the old interface. +-- +-- This is all a massive hack because arguably checkOldIface +-- should not populate the EPS. But that's a refactor for +-- another day. + +-- | Retrieve the ExternalPackageState cache. +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) + +-- | A compilation target. +-- +-- A target may be supplied with the actual text of the +-- module. If so, use this instead of the file contents (this +-- is for use in an IDE where the file hasn't been saved by +-- the user yet). +data Target + = Target { + targetId :: !TargetId, -- ^ module or filename + targetAllowObjCode :: !Bool, -- ^ object code allowed? + targetContents :: !(Maybe (InputFileBuffer, UTCTime)) + -- ^ Optional in-memory buffer containing the source code GHC should + -- use for this target instead of reading it from disk. + -- + -- Since GHC version 8.10 modules which require preprocessors such as + -- Literate Haskell or CPP to run are also supported. + -- + -- If a corresponding source file does not exist on disk this will + -- result in a 'SourceError' exception if @targetId = TargetModule _@ + -- is used. However together with @targetId = TargetFile _@ GHC will + -- not complain about the file missing. + } + +data TargetId + = TargetModule ModuleName + -- ^ A module name: search for the file + | TargetFile FilePath (Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. + deriving Eq + +type InputFileBuffer = StringBuffer + +pprTarget :: Target -> SDoc +pprTarget (Target id obj _) = + (if obj then char '*' else empty) <> pprTargetId id + +instance Outputable Target where + ppr = pprTarget + +pprTargetId :: TargetId -> SDoc +pprTargetId (TargetModule m) = ppr m +pprTargetId (TargetFile f _) = text f + +instance Outputable TargetId where + ppr = pprTargetId + +{- +************************************************************************ +* * +\subsection{Package and Module Tables} +* * +************************************************************************ +-} + +-- | Helps us find information about modules in the home package +type HomePackageTable = DModuleNameEnv HomeModInfo + -- Domain = modules in the home package that have been fully compiled + -- "home" unit id cached here for convenience + +-- | Helps us find information about modules in the imported packages +type PackageIfaceTable = ModuleEnv ModIface + -- Domain = modules in the imported packages + +-- | Constructs an empty HomePackageTable +emptyHomePackageTable :: HomePackageTable +emptyHomePackageTable = emptyUDFM + +-- | Constructs an empty PackageIfaceTable +emptyPackageIfaceTable :: PackageIfaceTable +emptyPackageIfaceTable = emptyModuleEnv + +pprHPT :: HomePackageTable -> SDoc +-- A bit arbitrary for now +pprHPT hpt = pprUDFM hpt $ \hms -> + vcat [ hang (ppr (mi_module (hm_iface hm))) + 2 (ppr (md_types (hm_details hm))) + | hm <- hms ] + +lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo +lookupHpt = lookupUDFM + +lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo +lookupHptDirectly = lookupUDFM_Directly + +eltsHpt :: HomePackageTable -> [HomeModInfo] +eltsHpt = eltsUDFM + +filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable +filterHpt = filterUDFM + +allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +allHpt = allUDFM + +anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +anyHpt = anyUDFM + +mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable +mapHpt = mapUDFM + +delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable +delFromHpt = delFromUDFM + +addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable +addToHpt = addToUDFM + +addListToHpt + :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable +addListToHpt = addListToUDFM + +listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable +listToHpt = listToUDFM + +lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo +-- The HPT is indexed by ModuleName, not Module, +-- we must check for a hit on the right Module +lookupHptByModule hpt mod + = case lookupHpt hpt (moduleName mod) of + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + +-- | Information about modules in the package being compiled +data HomeModInfo + = HomeModInfo { + hm_iface :: !ModIface, + -- ^ The basic loaded interface file: every loaded module has one of + -- these, even if it is imported from another package + hm_details :: !ModDetails, + -- ^ Extra information that has been created from the 'ModIface' for + -- the module, typically during typechecking + hm_linkable :: !(Maybe Linkable) + -- ^ The actual artifact we would like to link to access things in + -- this module. + -- + -- 'hm_linkable' might be Nothing: + -- + -- 1. If this is an .hs-boot module + -- + -- 2. Temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- + -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields + -- in the 'HomePackageTable' will be @Just@. + -- + -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the + -- 'HomeModInfo' by building a new 'ModDetails' from the old + -- 'ModIface' (only). + } + +-- | Find the 'ModIface' for a 'Module', searching in both the loaded home +-- and external package module information +lookupIfaceByModule + :: HomePackageTable + -> PackageIfaceTable + -> Module + -> Maybe ModIface +lookupIfaceByModule hpt pit mod + = case lookupHptByModule hpt mod of + Just hm -> Just (hm_iface hm) + Nothing -> lookupModuleEnv pit mod + +-- If the module does come from the home package, why do we look in the PIT as well? +-- (a) In OneShot mode, even home-package modules accumulate in the PIT +-- (b) Even in Batch (--make) mode, there is *one* case where a home-package +-- module is in the PIT, namely GHC.Prim when compiling the base package. +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package +-- of its own, but it doesn't seem worth the bother. + +hptCompleteSigs :: HscEnv -> [CompleteMatch] +hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +-- Used in @tcRnImports@, to select the instances that are in the +-- transitive closure of imports from the currently compiled module. +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) +hptInstances hsc_env want_this_module + = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do + guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) + let details = hm_details mod_info + return (md_insts details, md_fam_insts details) + in (concat insts, concat famInsts) + +-- | Get rules from modules "below" this one (in the dependency sense) +hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule] +hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False + + +-- | Get annotations from modules "below" this one (in the dependency sense) +hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation] +hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env + +hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] +hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) + +-- | Get things from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a] +hptSomeThingsBelowUs extract include_hi_boot hsc_env deps + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] + + | otherwise + = let hpt = hsc_HPT hsc_env + in + [ thing + | -- Find each non-hi-boot module below me + GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps + , include_hi_boot || (is_boot == NotBoot) + + -- unsavoury: when compiling the base package with --make, we + -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't + -- be in the HPT, because we never compile it; it's in the EPT + -- instead. ToDo: clean up, and remove this slightly bogus filter: + , mod /= moduleName gHC_PRIM + + -- Look it up in the HPT + , let things = case lookupHpt hpt mod of + Just info -> extract info + Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] + msg = vcat [text "missing module" <+> ppr mod, + text "Probable cause: out-of-date interface files"] + -- This really shouldn't happen, but see #962 + + -- And get its dfuns + , thing <- things ] + + +{- +************************************************************************ +* * +\subsection{Metaprogramming} +* * +************************************************************************ +-} + +-- | The supported metaprogramming result types +data MetaRequest + = MetaE (LHsExpr GhcPs -> MetaResult) + | MetaP (LPat GhcPs -> MetaResult) + | MetaT (LHsType GhcPs -> MetaResult) + | MetaD ([LHsDecl GhcPs] -> MetaResult) + | MetaAW (Serialized -> MetaResult) + +-- | data constructors not exported to ensure correct result type +data MetaResult + = MetaResE { unMetaResE :: LHsExpr GhcPs } + | MetaResP { unMetaResP :: LPat GhcPs } + | MetaResT { unMetaResT :: LHsType GhcPs } + | MetaResD { unMetaResD :: [LHsDecl GhcPs] } + | MetaResAW { unMetaResAW :: Serialized } + +type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult + +metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) +metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) + +metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) +metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) + +metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) +metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) + +metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] +metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) + +metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized +metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) + +{- +************************************************************************ +* * +\subsection{Dealing with Annotations} +* * +************************************************************************ +-} + +-- | Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +prepareAnnotations hsc_env mb_guts = do + eps <- hscEPS hsc_env + let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts + other_pkg_anns = eps_ann_env eps + ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, + Just home_pkg_anns, + Just other_pkg_anns] + return ann_env + +{- +************************************************************************ +* * +\subsection{The Finder cache} +* * +************************************************************************ +-} + +-- | The 'FinderCache' maps modules to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +type FinderCache = InstalledModuleEnv InstalledFindResult + +data InstalledFindResult + = InstalledFound ModLocation InstalledModule + | InstalledNoPackage UnitId + | InstalledNotFound [FilePath] (Maybe UnitId) + +-- | The result of searching for an imported module. +-- +-- NB: FindResult manages both user source-import lookups +-- (which can result in 'Module') as well as direct imports +-- for interfaces (which always result in 'InstalledModule'). +data FindResult + = Found ModLocation Module + -- ^ The module was found + | NoPackage Unit + -- ^ The requested unit was not found + | FoundMultiple [(Module, ModuleOrigin)] + -- ^ _Error_: both in multiple packages + + -- | Not found + | NotFound + { fr_paths :: [FilePath] -- ^ Places where I looked + + , fr_pkg :: Maybe Unit -- ^ Just p => module is in this unit's + -- manifest, but couldn't find the + -- .hi file + + , fr_mods_hidden :: [Unit] -- ^ Module is in these units, + -- but the *module* is hidden + + , fr_pkgs_hidden :: [Unit] -- ^ Module is in these units, + -- but the *unit* is hidden + + -- | Module is in these units, but it is unusable + , fr_unusables :: [(Unit, UnusableUnitReason)] + + , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules + } + +{- +************************************************************************ +* * +\subsection{Symbol tables and Module details} +* * +************************************************************************ +-} + +{- Note [Interface file stages] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Interface files have two possible stages. + +* A partial stage built from the result of the core pipeline. +* A fully instantiated form. Which also includes fingerprints and + potentially information provided by backends. + +We can build a full interface file two ways: +* Directly from a partial one: + Then we omit backend information and mostly compute fingerprints. +* From a partial one + information produced by a backend. + Then we store the provided information and fingerprint both. +-} + +type PartialModIface = ModIface_ 'ModIfaceCore +type ModIface = ModIface_ 'ModIfaceFinal + +-- | Extends a PartialModIface with information which is either: +-- * Computed after codegen +-- * Or computed just before writing the iface to disk. (Hashes) +-- In order to fully instantiate it. +data ModIfaceBackend = ModIfaceBackend + { mi_iface_hash :: !Fingerprint + -- ^ Hash of the whole interface + , mi_mod_hash :: !Fingerprint + -- ^ Hash of the ABI only + , mi_flag_hash :: !Fingerprint + -- ^ Hash of the important flags used when compiling the module, excluding + -- optimisation flags + , mi_opt_hash :: !Fingerprint + -- ^ Hash of optimisation flags + , mi_hpc_hash :: !Fingerprint + -- ^ Hash of hpc flags + , mi_plugin_hash :: !Fingerprint + -- ^ Hash of plugins + , mi_orphan :: !WhetherHasOrphans + -- ^ Whether this module has orphans + , mi_finsts :: !WhetherHasFamInst + -- ^ Whether this module has family instances. See Note [The type family + -- instance consistency story]. + , mi_exp_hash :: !Fingerprint + -- ^ Hash of export list + , mi_orphan_hash :: !Fingerprint + -- ^ Hash for orphan rules, class and family instances combined + + -- Cached environments for easy lookup. These are computed (lazily) from + -- other fields and are not put into the interface file. + -- Not really produced by the backend but there is no need to create them + -- any earlier. + , mi_warn_fn :: !(OccName -> Maybe WarningTxt) + -- ^ Cached lookup for 'mi_warns' + , mi_fix_fn :: !(OccName -> Maybe Fixity) + -- ^ Cached lookup for 'mi_fixities' + , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) + -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that + -- the thing isn't in decls. It's useful to know that when seeing if we are + -- up to date wrt. the old interface. The 'OccName' is the parent of the + -- name, if it has one. + } + +data ModIfacePhase + = ModIfaceCore + -- ^ Partial interface built based on output of core pipeline. + | ModIfaceFinal + +-- | Selects a IfaceDecl representation. +-- For fully instantiated interfaces we also maintain +-- a fingerprint, which is used for recompilation checks. +type family IfaceDeclExts (phase :: ModIfacePhase) where + IfaceDeclExts 'ModIfaceCore = IfaceDecl + IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) + +type family IfaceBackendExts (phase :: ModIfacePhase) where + IfaceBackendExts 'ModIfaceCore = () + IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend + + + +-- | A 'ModIface' plus a 'ModDetails' summarises everything we know +-- about a compiled module. The 'ModIface' is the stuff *before* linking, +-- and can be written out to an interface file. The 'ModDetails is after +-- linking and can be completely recovered from just the 'ModIface'. +-- +-- When we read an interface file, we also construct a 'ModIface' from it, +-- except that we explicitly make the 'mi_decls' and a few other fields empty; +-- as when reading we consolidate the declarations etc. into a number of indexed +-- maps and environments in the 'ExternalPackageState'. +data ModIface_ (phase :: ModIfacePhase) + = ModIface { + mi_module :: !Module, -- ^ Name of the module we are for + mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? + + mi_hsc_src :: !HscSource, -- ^ Boot? Signature? + + mi_deps :: Dependencies, + -- ^ The dependencies of the module. This is + -- consulted for directly-imported modules, but not + -- for anything else (hence lazy) + + mi_usages :: [Usage], + -- ^ Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the hash of this module) + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + mi_exports :: ![IfaceExport], + -- ^ Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + -- Records the modules that are the declaration points for things + -- exported by this module, and the 'OccName's of those things + + + mi_used_th :: !Bool, + -- ^ Module required TH splices when it was compiled. + -- This disables recompilation avoidance (see #481). + + mi_fixities :: [(OccName,Fixity)], + -- ^ Fixities + -- NOT STRICT! we read this field lazily from the interface file + + mi_warns :: Warnings, + -- ^ Warnings + -- NOT STRICT! we read this field lazily from the interface file + + mi_anns :: [IfaceAnnotation], + -- ^ Annotations + -- NOT STRICT! we read this field lazily from the interface file + + + mi_decls :: [IfaceDeclExts phase], + -- ^ Type, class and variable declarations + -- The hash of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the hash of the parent class/tycon changes + + mi_globals :: !(Maybe GlobalRdrEnv), + -- ^ Binds all the things defined at the top level in + -- the /original source/ code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + -- + -- (We need the source file to figure out the + -- top-level environment, if we didn't compile this module + -- from source then this field contains @Nothing@). + -- + -- Strictly speaking this field should live in the + -- 'HomeModInfo', but that leads to more plumbing. + + -- Instance declarations and rules + mi_insts :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules :: [IfaceRule], -- ^ Sorted rules + + mi_hpc :: !AnyHpcUsage, + -- ^ True if this program uses Hpc at any point in the program. + + mi_trust :: !IfaceTrustInfo, + -- ^ Safe Haskell Trust information for this module. + + mi_trust_pkg :: !Bool, + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [Trust Own Package] in GHC.Rename.Names + mi_complete_sigs :: [IfaceCompleteMatch], + + mi_doc_hdr :: Maybe HsDocString, + -- ^ Module header. + + mi_decl_docs :: DeclDocMap, + -- ^ Docs on declarations. + + mi_arg_docs :: ArgDocMap, + -- ^ Docs on arguments. + + mi_final_exts :: !(IfaceBackendExts phase), + -- ^ Either `()` or `ModIfaceBackend` for + -- a fully instantiated interface. + + mi_ext_fields :: ExtensibleFields + -- ^ Additional optional fields, where the Map key represents + -- the field name, resulting in a (size, serialized data) pair. + -- Because the data is intended to be serialized through the + -- internal `Binary` class (increasing compatibility with types + -- using `Name` and `FastString`, such as HIE), this format is + -- chosen over `ByteString`s. + } + +-- | Old-style accessor for whether or not the ModIface came from an hs-boot +-- file. +mi_boot :: ModIface -> IsBootInterface +mi_boot iface = if mi_hsc_src iface == HsBootFile + then IsBoot + else NotBoot + +-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be +-- found, 'defaultFixity' is returned instead. +mi_fix :: ModIface -> OccName -> Fixity +mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity + +-- | The semantic module for this interface; e.g., if it's a interface +-- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' +-- will be @@. +mi_semantic_module :: ModIface_ a -> Module +mi_semantic_module iface = case mi_sig_of iface of + Nothing -> mi_module iface + Just mod -> mod + +-- | The "precise" free holes, e.g., the signatures that this +-- 'ModIface' depends on. +mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes iface = + case getModuleInstantiation (mi_module iface) of + (_, Just indef) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef)) + _ -> emptyUniqDSet + where + cands = map gwib_mod $ dep_mods $ mi_deps iface + +-- | Given a set of free holes, and a unit identifier, rename +-- the free holes according to the instantiation of the unit +-- identifier. For example, if we have A and B free, and +-- our unit identity is @p[A=,B=impl:B]@, the renamed free +-- holes are just C. +renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName +renameFreeHoles fhs insts = + unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) + where + hmap = listToUFM insts + lookup_impl mod_name + | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod + -- It wasn't actually a hole + | otherwise = emptyUniqDSet + +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we + -- can deal with it's pointer in the header + -- when we write the actual file + mi_final_exts = ModIfaceBackend { + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash + }}) = do + put_ bh mod + put_ bh sig_of + put_ bh hsc_src + put_ bh iface_hash + put_ bh mod_hash + put_ bh flag_hash + put_ bh opt_hash + put_ bh hpc_hash + put_ bh plugin_hash + put_ bh orphan + put_ bh hasFamInsts + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg + put_ bh complete_sigs + lazyPut bh doc_hdr + lazyPut bh decl_docs + lazyPut bh arg_docs + + get bh = do + mod <- get bh + sig_of <- get bh + hsc_src <- get bh + iface_hash <- get bh + mod_hash <- get bh + flag_hash <- get bh + opt_hash <- get bh + hpc_hash <- get bh + plugin_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- get bh + hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh + complete_sigs <- get bh + doc_hdr <- lazyGet bh + decl_docs <- lazyGet bh + arg_docs <- lazyGet bh + return (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt + -- with specially when the file is read + mi_final_exts = ModIfaceBackend { + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash, + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls + }}) + +-- | The original names declared of a certain module that are exported +type IfaceExport = AvailInfo + +emptyPartialModIface :: Module -> PartialModIface +emptyPartialModIface mod + = ModIface { mi_module = mod, + mi_sig_of = Nothing, + mi_hsc_src = HsSrcFile, + mi_deps = noDependencies, + mi_usages = [], + mi_exports = [], + mi_used_th = False, + mi_fixities = [], + mi_warns = NoWarnings, + mi_anns = [], + mi_insts = [], + mi_fam_insts = [], + mi_rules = [], + mi_decls = [], + mi_globals = Nothing, + mi_hpc = False, + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False, + mi_complete_sigs = [], + mi_doc_hdr = Nothing, + mi_decl_docs = emptyDeclDocMap, + mi_arg_docs = emptyArgDocMap, + mi_final_exts = (), + mi_ext_fields = emptyExtensibleFields + } + +emptyFullModIface :: Module -> ModIface +emptyFullModIface mod = + (emptyPartialModIface mod) + { mi_decls = [] + , mi_final_exts = ModIfaceBackend + { mi_iface_hash = fingerprint0, + mi_mod_hash = fingerprint0, + mi_flag_hash = fingerprint0, + mi_opt_hash = fingerprint0, + mi_hpc_hash = fingerprint0, + mi_plugin_hash = fingerprint0, + mi_orphan = False, + mi_finsts = False, + mi_exp_hash = fingerprint0, + mi_orphan_hash = fingerprint0, + mi_warn_fn = emptyIfaceWarnCache, + mi_fix_fn = emptyIfaceFixCache, + mi_hash_fn = emptyIfaceHashCache } } + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl' add_decl emptyOccEnv pairs + add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) + where + add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + + +-- | The 'ModDetails' is essentially a cache for information in the 'ModIface' +-- for home modules only. Information relating to packages will be loaded into +-- global environments in 'ExternalPackageState'. +data ModDetails + = ModDetails { + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], + md_types :: !TypeEnv, -- ^ Local type environment for this particular module + -- Includes Ids, TyCons, PatSyns + md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module + md_fam_insts :: ![FamInst], + md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules + md_anns :: ![Annotation], -- ^ Annotations present in this module: currently + -- they only annotate things also declared in this module + md_complete_sigs :: [CompleteMatch] + -- ^ Complete match pragmas for this module + } + +-- | Constructs an empty ModDetails +emptyModDetails :: ModDetails +emptyModDetails + = ModDetails { md_types = emptyTypeEnv, + md_exports = [], + md_insts = [], + md_rules = [], + md_fam_insts = [], + md_anns = [], + md_complete_sigs = [] } + +-- | Records the modules directly imported by a module for extracting e.g. +-- usage information, and also to give better error message +type ImportedMods = ModuleEnv [ImportedBy] + +-- | If a module was "imported" by the user, we associate it with +-- more detailed usage information 'ImportedModsVal'; a module +-- imported by the system only gets used for usage information. +data ImportedBy + = ImportedByUser ImportedModsVal + | ImportedBySystem + +importedByUser :: [ImportedBy] -> [ImportedModsVal] +importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys +importedByUser (ImportedBySystem : bys) = importedByUser bys +importedByUser [] = [] + +data ImportedModsVal + = ImportedModsVal { + imv_name :: ModuleName, -- ^ The name the module is imported with + imv_span :: SrcSpan, -- ^ the source span of the whole import + imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import + imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import + imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide + -- NB. BangPattern here: otherwise this leaks. (#15111) + imv_qualified :: Bool -- ^ whether this is a qualified import + } + +-- | A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a 'ModIface' and +-- 'ModDetails' are extracted and the ModGuts is discarded. +data ModGuts + = ModGuts { + mg_module :: !Module, -- ^ Module being compiled + mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module + mg_loc :: SrcSpan, -- ^ For error messages from inner passes + mg_exports :: ![AvailInfo], -- ^ What it exports + mg_deps :: !Dependencies, -- ^ What it depends on, directly or + -- otherwise + mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. + + mg_used_th :: !Bool, -- ^ Did we run a TH splice? + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. + mg_tcs :: ![TyCon], -- ^ TyCons declared in this module + -- (includes TyCons for classes) + mg_insts :: ![ClsInst], -- ^ Class instances declared in this module + mg_fam_insts :: ![FamInst], + -- ^ Family instances declared in this module + mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module + mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains + -- See Note [Overall plumbing for rules] in "GHC.Core.Rules" + mg_binds :: !CoreProgram, -- ^ Bindings for this module + mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module + mg_foreign_files :: ![(ForeignSrcLang, FilePath)], + -- ^ Files to be compiled with the C compiler + mg_warns :: !Warnings, -- ^ Warnings declared in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, -- ^ Class instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_inst_env' + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_fam_inst_env' + + mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode + mg_trust_pkg :: Bool, -- ^ Do we need to trust our + -- own package for Safe Haskell? + -- See Note [Trust Own Package] + -- in "GHC.Rename.Names" + + mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. + mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. + mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. + } + +-- The ModGuts takes on several slightly different forms: +-- +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached + +--------------------------------------------------------- +-- The Tidy pass forks the information about this module: +-- * one lot goes to interface file generation (ModIface) +-- and later compilations (ModDetails) +-- * the other lot goes to code generation (CgGuts) + +-- | A restricted form of 'ModGuts' for code generation purposes +data CgGuts + = CgGuts { + cg_module :: !Module, + -- ^ Module being compiled + + cg_tycons :: [TyCon], + -- ^ Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables. Includes newtypes, just for the benefit of + -- External Core + + cg_binds :: CoreProgram, + -- ^ The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data constructor wrappers. But *not* + -- data constructor workers; reason: we regard them + -- as part of the code-gen of tycons + + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign_files :: ![(ForeignSrcLang, FilePath)], + cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to + -- generate #includes for C code gen + cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information + cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints + cg_spt_entries :: [SptEntry] + -- ^ Static pointer table entries for static forms defined in + -- the module. + -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable" + } + +----------------------------------- +-- | Foreign export stubs +data ForeignStubs + = NoStubs + -- ^ We don't have any stubs + | ForeignStubs SDoc SDoc + -- ^ There are some stubs. Parameters: + -- + -- 1) Header file prototypes for + -- "foreign exported" functions + -- + -- 2) C stubs to use when calling + -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) + +{- +************************************************************************ +* * + The interactive context +* * +************************************************************************ + +Note [The interactive package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules + interactive:Ghci1 + interactive:Ghci2 + ...etc... +with each bunch of declarations using a new module, all sharing a +common package 'interactive' (see Module.interactiveUnitId, and +GHC.Builtin.Names.mkInteractiveModule). + +This scheme deals well with shadowing. For example: + + ghci> data T = A + ghci> data T = B + ghci> :i A + data Ghci1.T = A -- Defined at :2:10 + +Here we must display info about constructor A, but its type T has been +shadowed by the second declaration. But it has a respectable +qualified name (Ghci1.T), and its source location says where it was +defined. + +So the main invariant continues to hold, that in any session an +original name M.T only refers to one unique thing. (In a previous +iteration both the T's above were called :Interactive.T, albeit with +different uniques, which gave rise to all sorts of trouble.) + +The details are a bit tricky though: + + * The field ic_mod_index counts which Ghci module we've got up to. + It is incremented when extending ic_tythings + + * ic_tythings contains only things from the 'interactive' package. + + * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go + in the Home Package Table (HPT). When you say :load, that's when we + extend the HPT. + + * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'. + It stays as 'main' (or whatever -this-unit-id says), and is the + package to which :load'ed modules are added to. + + * So how do we arrange that declarations at the command prompt get to + be in the 'interactive' package? Simply by setting the tcg_mod + field of the TcGblEnv to "interactive:Ghci1". This is done by the + call to initTc in initTcInteractive, which in turn get the module + from it 'icInteractiveModule' field of the interactive context. + + The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says. + + * The main trickiness is that the type environment (tcg_type_env) and + fixity envt (tcg_fix_env), now contain entities from all the + interactive-package modules (Ghci1, Ghci2, ...) together, rather + than just a single module as is usually the case. So you can't use + "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs + the HPT/PTE. This is a change, but not a problem provided you + know. + +* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields + of the TcGblEnv, which collect "things defined in this module", all + refer to stuff define in a single GHCi command, *not* all the commands + so far. + + In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from + all GhciN modules, which makes sense -- they are all "home package" + modules. + + +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in GHCi are currently + a) GlobalIds, with + b) An External Name, like Ghci4.foo + See Note [The interactive package] above + c) A tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) Having an External Name is important because of Note + [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + +Where do interactively-bound Ids come from? + + - GHCi REPL Stmts e.g. + ghci> let foo x = x+1 + These start with an Internal Name because a Stmt is a local + construct, so the renamer naturally builds an Internal name for + each of its binders. Then in tcRnStmt they are externalised via + GHC.Tc.Module.externaliseAndTidyId, so they get Names like Ghic4.foo. + + - Ids bound by the debugger etc have Names constructed by + GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by + mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are + all Global, External. + + - TyCons, Classes, and Ids bound by other top-level declarations in + GHCi (eg foreign import, record selectors) also get External + Names, with Ghci9 (or 8, or 7, etc) as the module name. + + +Note [ic_tythings] +~~~~~~~~~~~~~~~~~~ +The ic_tythings field contains + * The TyThings declared by the user at the command prompt + (eg Ids, TyCons, Classes) + + * The user-visible Ids that arise from such things, which + *don't* come from 'implicitTyThings', notably: + - record selectors + - class ops + The implicitTyThings are readily obtained from the TyThings + but record selectors etc are not + +It does *not* contain + * DFunIds (they can be gotten from ic_instances) + * CoAxioms (ditto) + +See also Note [Interactively-bound Ids in GHCi] + +Note [Override identical instances in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you declare a new instance in GHCi that is identical to a previous one, +we simply override the previous one; we don't regard it as overlapping. +e.g. Prelude> data T = A | B + Prelude> instance Eq T where ... + Prelude> instance Eq T where ... -- This one overrides + +It's exactly the same for type-family instances. See #7102 +-} + +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHCi session. +data InteractiveContext + = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interactive expressions + -- and statements. + + ic_mod_index :: Int, + -- ^ Each GHCi stmt or declaration brings some new things into + -- scope. We give them names like interactive:Ghci9.T, + -- where the ic_index is the '9'. The ic_mod_index is + -- incremented whenever we add something to ic_tythings + -- See Note [The interactive package] + + ic_imports :: [InteractiveImport], + -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with + -- these imports + -- + -- This field is only stored here so that the client + -- can retrieve it with GHC.getContext. GHC itself doesn't + -- use it, but does reset it to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + + ic_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition (ie most recent at the front) + -- See Note [ic_tythings] + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The cached 'GlobalRdrEnv', built by + -- 'GHC.Runtime.Eval.setContext' and updated regularly + -- It contains everything in scope at the command line, + -- including everything in ic_tythings + + ic_instances :: ([ClsInst], [FamInst]), + -- ^ All instances and family instances created during + -- this session. These are grabbed en masse after each + -- update to be sure that proper overlapping is retained. + -- That is, rather than re-check the overlapping each + -- time we update the context, we just take the results + -- from the instance code that already does that. + + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_default :: Maybe [Type], + -- ^ The current default types, set by a 'default' declaration + + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + + ic_cwd :: Maybe FilePath + -- virtual CWD of the program + } + +data InteractiveImport + = IIDecl (ImportDecl GhcPs) + -- ^ Bring the exports of a particular module + -- (filtered by an import decl) into scope + + | IIModule ModuleName + -- ^ Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. + + +-- | Constructs an empty InteractiveContext. +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { + ic_dflags = dflags, + ic_imports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_mod_index = 1, + ic_tythings = [], + ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + ic_monad = ioTyConName, -- IO monad by default + ic_int_print = printName, -- System.IO.print by default + ic_default = Nothing, + ic_resume = [], + ic_cwd = Nothing } + +icInteractiveModule :: InteractiveContext -> Module +icInteractiveModule (InteractiveContext { ic_mod_index = index }) + = mkInteractiveModule index + +-- | This function returns the list of visible TyThings (useful for +-- e.g. showBindings) +icInScopeTTs :: InteractiveContext -> [TyThing] +icInScopeTTs = ic_tythings + +-- | Get the PrintUnqualified function based on the flags and this InteractiveContext +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified dflags grenv + +-- | extendInteractiveContext is called with new TyThings recently defined to update the +-- InteractiveContext to include them. Ids are easily removed when shadowed, +-- but Classes and TyCons are not. Some work could be done to determine +-- whether they are entirely shadowed, but as you could still have references +-- to them (e.g. instances for classes or values of the type for TyCons), it's +-- not clear whether removing them is even the appropriate behavior. +extendInteractiveContext :: InteractiveContext + -> [TyThing] + -> [ClsInst] -> [FamInst] + -> Maybe [Type] + -> FixityEnv + -> InteractiveContext +extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + -- Always bump this; even instances should create + -- a new mod_index (#9426) + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings + , ic_instances = ( new_cls_insts ++ old_cls_insts + , new_fam_insts ++ fam_insts ) + -- we don't shadow old family instances (#7102), + -- so don't need to remove them here + , ic_default = defaults + , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] + } + where + new_ids = [id | AnId id <- new_tythings] + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) + + -- Discard old instances that have been fully overridden + -- See Note [Override identical instances in GHCi] + (cls_insts, fam_insts) = ic_instances ictxt + old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts + +extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext +-- Just a specialised version +extendInteractiveContextWithIds ictxt new_ids + | null new_ids = ictxt + | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } + where + new_tythings = map AnId new_ids + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) + +shadowed_by :: [Id] -> TyThing -> Bool +shadowed_by ids = shadowed + where + shadowed id = getOccName id `elemOccSet` new_occs + new_occs = mkOccSet (map getOccName ids) + +-- | Set the 'DynFlags.homeUnitId' to 'interactive' +setInteractivePackage :: HscEnv -> HscEnv +setInteractivePackage hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { homeUnitId = interactiveUnitId } } + +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + + -- ToDo: should not add Ids to the gbl env here + +-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the GlobalRdrEnv. +icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv +icExtendGblRdrEnv env tythings + = foldr add env tythings -- Foldr makes things in the front of + -- the list shadow things at the back + where + -- One at a time, to ensure each shadows the previous ones + add thing env + | is_sub_bndr thing + = env + | otherwise + = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) + where + env1 = shadowNames env (concatMap availNames avail) + avail = tyThingAvailInfo thing + + -- Ugh! The new_tythings may include record selectors, since they + -- are not implicit-ids, and must appear in the TypeEnv. But they + -- will also be brought into scope by the corresponding (ATyCon + -- tc). And we want the latter, because that has the correct + -- parent (#10520) + is_sub_bndr (AnId f) = case idDetails f of + RecSelId {} -> True + ClassOpId {} -> True + _ -> False + is_sub_bndr _ = False + +substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext +substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst + | isEmptyTCvSubst subst = ictxt + | otherwise = ictxt { ic_tythings = map subst_ty tts } + where + subst_ty (AnId id) + = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id + -- Variables in the interactive context *can* mention free type variables + -- because of the runtime debugger. Otherwise you'd expect all + -- variables bound in the interactive context to be closed. + subst_ty tt + = tt + +instance Outputable InteractiveImport where + ppr (IIModule m) = char '*' <> ppr m + ppr (IIDecl d) = ppr d + +{- +************************************************************************ +* * + Building a PrintUnqualified +* * +************************************************************************ + +Note [Printing original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" NameUnqual + 2. There is an X for which X.T + uniquely maps to P:M.T ---> "X.T" NameQual X + 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 + 4. Otherwise ---> "P:M.T" NameNotInScope2 + +(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at +all. In these cases we still want to refer to the name as "M.T", *but* +"M.T" might mean something else in the current scope (e.g. if there's +an "import X as M"), so to avoid confusion we avoid using "M.T" if +there's already a binding for it. Instead we write P:M.T. + +There's one further subtlety: in case (3), what if there are two +things around, P1:M.T and P2:M.T? Then we don't want to print both of +them as M.T! However only one of the modules P1:M and P2:M can be +exposed (say P2), so we use M.T for that, and P1:M.T for the other one. +This is handled by the qual_mod component of PrintUnqualified, inside +the (ppr mod) of case (3), in Name.pprModulePrefix + +Note [Printing unit ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +instantiated units, the situation can be different: if the key is instantiated +with some holes, we should try to give the user some more useful information. +-} + +-- | Creates some functions that work out the best ways to format +-- names for the user according to a set of heuristics. +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = QueryQualify qual_name + (mkQualModule dflags) + (mkQualPackage pkgs) + where + pkgs = unitState dflags + qual_name mod occ + | [gre] <- unqual_gres + , right_name gre + = NameUnqual -- If there's a unique entity that's in scope + -- unqualified with 'occ' AND that entity is + -- the right one, then we can use the unqualified name + + | [] <- unqual_gres + , any is_name forceUnqualNames + , not (isDerivedOccName occ) + = NameUnqual -- Don't qualify names that come from modules + -- that come with GHC, often appear in error messages, + -- but aren't typically in scope. Doing this does not + -- cause ambiguity, and it reduces the amount of + -- qualification in error messages thus improving + -- readability. + -- + -- A motivating example is 'Constraint'. It's often not + -- in scope, but printing GHC.Prim.Constraint seems + -- overkill. + + | [gre] <- qual_gres + = NameQual (greQualModName gre) + + | null qual_gres + = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 + + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False + where + is_name :: Name -> Bool + is_name name = ASSERT2( isExternalName name, ppr name ) + nameModule name == mod && nameOccName name == occ + + forceUnqualNames :: [Name] + forceUnqualNames = + map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] + ++ [ eqTyConName ] + + right_name gre = nameModule_maybe (gre_name gre) == Just mod + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: DynFlags -> QueryQualifyModule +mkQualModule dflags mod + | isHomeModule dflags mod = False + + | [(_, pkgconfig)] <- lookup, + mkUnit pkgconfig == moduleUnit mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllUnits (unitState dflags) (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a unit id if the package ID would be ambiguous. +mkQualPackage :: UnitState -> QueryQualifyPackage +mkQualPackage pkgs uid + | uid == mainUnit || uid == interactiveUnit + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | Just pkgid <- mb_pkgid + , searchPackageId pkgs pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where mb_pkgid = fmap unitPackageId (lookupUnit pkgs uid) + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: UnitState -> PrintUnqualified +pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs } + +{- +************************************************************************ +* * + Implicit TyThings +* * +************************************************************************ + +Note [Implicit TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~ + DEFINITION: An "implicit" TyThing is one that does not have its own + IfaceDecl in an interface file. Instead, its binding in the type + environment is created as part of typechecking the IfaceDecl for + some other thing. + +Examples: + * All DataCons are implicit, because they are generated from the + IfaceDecl for the data/newtype. Ditto class methods. + + * Record selectors are *not* implicit, because they get their own + free-standing IfaceDecl. + + * Associated data/type families are implicit because they are + included in the IfaceDecl of the parent class. (NB: the + IfaceClass decl happens to use IfaceDecl recursively for the + associated types, but that's irrelevant here.) + + * Dictionary function Ids are not implicit. + + * Axioms for newtypes are implicit (same as above), but axioms + for data/type family instances are *not* implicit (like DFunIds). +-} + +-- | Determine the 'TyThing's brought into scope by another 'TyThing' +-- /other/ than itself. For example, Id's don't have any implicit TyThings +-- as they just bring themselves into scope, but classes bring their +-- dictionary datatype, type constructor and some selector functions into +-- scope, just for a start! + +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in 'GHC.Iface.Load.loadDecl' (see note [Tricky iface loop]) +-- The order of the list does not matter. +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AConLike cl) = implicitConLikeThings cl + +implicitConLikeThings :: ConLike -> [TyThing] +implicitConLikeThings (RealDataCon dc) + = dataConImplicitTyThings dc + +implicitConLikeThings (PatSynCon {}) + = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher + -- are not "implicit"; they are simply new top-level bindings, + -- and they have their own declaration in an interface file + -- Unless a record pat syn when there are implicit selectors + -- They are still not included here as `implicitConLikeThings` is + -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked + -- by `tcTopValBinds`. + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + + -- associated types + -- No recursive call for the classATs, because they + -- are only the family decls; they have no implicit things + map ATyCon (classATs cl) ++ + + -- superclass and operation selectors + map AnId (classAllSelIds cl) + +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = class_stuff ++ + -- fields (names of selectors) + + -- (possibly) implicit newtype axioms + -- or type family axioms + implicitCoTyCon tc ++ + + -- for each data constructor in order, + -- the constructor, worker, and (possibly) wrapper + [ thing | dc <- tyConDataCons tc + , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] + -- NB. record selectors are *not* implicit, they have fully-fledged + -- bindings that pass through the compilation pipeline as normal. + where + class_stuff = case tyConClass_maybe tc of + Nothing -> [] + Just cl -> implicitClassThings cl + +-- For newtypes and closed type families (only) add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc + = [ACoAxiom co] + | otherwise = [] + +-- | Returns @True@ if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (AConLike cl) = case cl of + RealDataCon {} -> True + PatSynCon {} -> False +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax + +-- | tyThingParent_maybe x returns (Just p) +-- when pprTyThingInContext should print a declaration for p +-- (albeit with some "..." in it) when asked to show x +-- It returns the *immediate* parent. So a datacon returns its tycon +-- but the tycon could be the associated type of a class, so it in turn +-- might have a parent. +tyThingParent_maybe :: TyThing -> Maybe TyThing +tyThingParent_maybe (AConLike cl) = case cl of + RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) + PatSynCon{} -> Nothing +tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of + Just tc -> Just (ATyCon tc) + Nothing -> Nothing +tyThingParent_maybe (AnId id) = case idDetails id of + RecSelId { sel_tycon = RecSelData tc } -> + Just (ATyCon tc) + ClassOpId cls -> + Just (ATyCon (classTyCon cls)) + _other -> Nothing +tyThingParent_maybe _other = Nothing + +tyThingsTyCoVars :: [TyThing] -> TyCoVarSet +tyThingsTyCoVars tts = + unionVarSets $ map ttToVarSet tts + where + ttToVarSet (AnId id) = tyCoVarsOfType $ idType id + ttToVarSet (AConLike cl) = case cl of + RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc + PatSynCon{} -> emptyVarSet + ttToVarSet (ATyCon tc) + = case tyConClass_maybe tc of + Just cls -> (mkVarSet . fst . classTvsFds) cls + Nothing -> tyCoVarsOfType $ tyConKind tc + ttToVarSet (ACoAxiom _) = emptyVarSet + +-- | The Names that a TyThing should bring into scope. Used to build +-- the GlobalRdrEnv for the InteractiveContext. +tyThingAvailInfo :: TyThing -> [AvailInfo] +tyThingAvailInfo (ATyCon t) + = case tyConClass_maybe t of + Just c -> [AvailTC n (n : map getName (classMethods c) + ++ map getName (classATs c)) + [] ] + where n = getName c + Nothing -> [AvailTC n (n : map getName dcs) flds] + where n = getName t + dcs = tyConDataCons t + flds = tyConFieldLabels t +tyThingAvailInfo (AConLike (PatSynCon p)) + = map avail ((getName p) : map flSelector (patSynFieldLabels p)) +tyThingAvailInfo t + = [avail (getName t)] + +{- +************************************************************************ +* * + TypeEnv +* * +************************************************************************ +-} + +-- | A map from 'Name's to 'TyThing's, constructed by typechecking +-- local declarations or interface files +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] +typeEnvIds :: TypeEnv -> [Id] +typeEnvPatSyns :: TypeEnv -> [PatSyn] +typeEnvDataCons :: TypeEnv -> [DataCon] +typeEnvClasses :: TypeEnv -> [Class] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nameEnvElts env +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] +typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] +typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] +typeEnvClasses env = [cl | tc <- typeEnvTyCons env, + Just cl <- [tyConClass_maybe tc]] + +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things + +mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv +mkTypeEnvWithImplicits things = + mkTypeEnv things + `plusNameEnv` + mkTypeEnv (concatMap implicitTyThings things) + +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs famInsts = + mkTypeEnv ( map AnId ids + ++ map ATyCon all_tcs + ++ concatMap implicitTyConThings all_tcs + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts + ) + where + all_tcs = tcs ++ famInstsRepTyCons famInsts + +lookupTypeEnv = lookupNameEnv + +-- Extend the type environment +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl' extendTypeEnv env things + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] + +plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv +plusTypeEnv env1 env2 = plusNameEnv env1 env2 + +-- | Find the 'TyThing' for the given 'Name' by using all the resources +-- at our disposal: the compiled modules in the 'HomePackageTable' and the +-- compiled modules in other packages that live in 'PackageTypeEnv'. Note +-- that this does NOT look up the 'TyThing' in the module being compiled: you +-- have to do that yourself, if desired +lookupType :: DynFlags + -> HomePackageTable + -> PackageTypeEnv + -> Name + -> Maybe TyThing + +lookupType dflags hpt pte name + | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT + = lookupNameEnv pte name + | otherwise + = case lookupHptByModule hpt mod of + Just hm -> lookupNameEnv (md_types (hm_details hm)) name + Nothing -> lookupNameEnv pte name + where + mod = ASSERT2( isExternalName name, ppr name ) + if isHoleName name + then mkHomeModule dflags (moduleName (nameModule name)) + else nameModule name + +-- | As 'lookupType', but with a marginally easier-to-use interface +-- if you have a 'HscEnv' +lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) +lookupTypeHscEnv hsc_env name = do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType dflags hpt (eps_PTE eps) name + where + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + +-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise +tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) + +-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise +tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon +tyThingDataCon (AConLike (RealDataCon dc)) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. +-- Panics otherwise +tyThingConLike :: HasDebugCallStack => TyThing -> ConLike +tyThingConLike (AConLike dc) = dc +tyThingConLike other = pprPanic "tyThingConLike" (ppr other) + +-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise +tyThingId :: HasDebugCallStack => TyThing -> Id +tyThingId (AnId id) = id +tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (ppr other) + +{- +************************************************************************ +* * +\subsection{MonadThings and friends} +* * +************************************************************************ +-} + +-- | Class that abstracts out the common ability of the monads in GHC +-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides +-- a number of related convenience functions for accessing particular +-- kinds of 'TyThing' +class Monad m => MonadThings m where + lookupThing :: Name -> m TyThing + + lookupId :: Name -> m Id + lookupId = liftM tyThingId . lookupThing + + lookupDataCon :: Name -> m DataCon + lookupDataCon = liftM tyThingDataCon . lookupThing + + lookupTyCon :: Name -> m TyCon + lookupTyCon = liftM tyThingTyCon . lookupThing + +-- Instance used in GHC.HsToCore.Quote +instance MonadThings m => MonadThings (ReaderT s m) where + lookupThing = lift . lookupThing + +{- +************************************************************************ +* * +\subsection{Auxiliary types} +* * +************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere +-} + +------------------ Warnings ------------------------- +-- | Warning information for a module +data Warnings + = NoWarnings -- ^ Nothing deprecated + | WarnAll WarningTxt -- ^ Whole module deprecated + | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated + + -- Only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. + deriving( Eq ) + +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + +-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' +mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt +mkIfaceWarnCache NoWarnings = \_ -> Nothing +mkIfaceWarnCache (WarnAll t) = \_ -> Just t +mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) + +emptyIfaceWarnCache :: OccName -> Maybe WarningTxt +emptyIfaceWarnCache _ = Nothing + +plusWarns :: Warnings -> Warnings -> Warnings +plusWarns d NoWarnings = d +plusWarns NoWarnings d = d +plusWarns _ (WarnAll t) = WarnAll t +plusWarns (WarnAll t) _ = WarnAll t +plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) + +-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Maybe Fixity +emptyIfaceFixCache _ = Nothing + +-- | Fixity environment mapping names to their fixities +type FixityEnv = NameEnv FixItem + +-- | Fixity information for an 'Name'. We keep the OccName in the range +-- so that we can generate an interface from it +data FixItem = FixItem OccName Fixity + +instance Outputable FixItem where + ppr (FixItem occ fix) = ppr fix <+> ppr occ + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity + +{- +************************************************************************ +* * +\subsection{WhatsImported} +* * +************************************************************************ +-} + +-- | Records whether a module has orphans. An \"orphan\" is one of: +-- +-- * An instance declaration in a module other than the definition +-- module for one of the type constructors or classes in the instance head +-- +-- * A rewrite rule in a module other than the one defining +-- the function in the head of the rule +-- +type WhetherHasOrphans = Bool + +-- | Does this module define family instances? +type WhetherHasFamInst = Bool + +-- | Dependency information about ALL modules and packages below this one +-- in the import hierarchy. +-- +-- Invariant: the dependencies of a module @M@ never includes @M@. +-- +-- Invariant: none of the lists contain duplicates. +data Dependencies + = Deps { dep_mods :: [ModuleNameWithIsBoot] + -- ^ All home-package modules transitively below this one + -- I.e. modules that this one imports, or that are in the + -- dep_mods of those directly-imported modules + + , dep_pkgs :: [(UnitId, Bool)] + -- ^ All packages transitively below this module + -- I.e. packages to which this module's direct imports belong, + -- or that are in the dep_pkgs of those modules + -- The bool indicates if the package is required to be + -- trusted when the module is imported as a safe import + -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names + + , dep_orphs :: [Module] + -- ^ Transitive closure of orphan modules (whether + -- home or external pkg). + -- + -- (Possible optimization: don't include family + -- instance orphans as they are anyway included in + -- 'dep_finsts'. But then be careful about code + -- which relies on dep_orphs having the complete list!) + -- This does NOT include us, unlike 'imp_orphs'. + + , dep_finsts :: [Module] + -- ^ Transitive closure of depended upon modules which + -- contain family instances (whether home or external). + -- This is used by 'checkFamInstConsistency'. This + -- does NOT include us, unlike 'imp_finsts'. See Note + -- [The type family instance consistency story]. + + , dep_plgins :: [ModuleName] + -- ^ All the plugins used while compiling this module. + } + deriving( Eq ) + -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints + -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies. + +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + put_ bh (dep_plgins deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + fis <- get bh + pl <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis, dep_plgins = pl }) + +noDependencies :: Dependencies +noDependencies = Deps [] [] [] [] [] + +-- | Records modules for which changes may force recompilation of this module +-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- This differs from Dependencies. A module X may be in the dep_mods of this +-- module (via an import chain) but if we don't use anything from X it won't +-- appear in our Usage +data Usage + -- | Module from another package + = UsagePackageModule { + usg_mod :: Module, + -- ^ External package module depended on + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } + -- | Module from the current package + | UsageHomeModule { + usg_mod_name :: ModuleName, + -- ^ Name of the module + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_entities :: [(OccName,Fingerprint)], + -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. + -- NB: usages are for parent names only, e.g. type constructors + -- but not the associated data constructors. + usg_exports :: Maybe Fingerprint, + -- ^ Fingerprint for the export list of this module, + -- if we directly imported it (and hence we depend on its export list) + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } -- ^ Module from the current package + -- | A file upon which the module depends, e.g. a CPP #include, or using TH's + -- 'addDependentFile' + | UsageFile { + usg_file_path :: FilePath, + -- ^ External file dependency. From a CPP #include or TH + -- addDependentFile. Should be absolute. + usg_file_hash :: Fingerprint + -- ^ 'Fingerprint' of the file contents. + + -- Note: We don't consider things like modification timestamps + -- here, because there's no reason to recompile if the actual + -- contents don't change. This previously lead to odd + -- recompilation behaviors; see #8114 + } + -- | A requirement which was merged into this one. + | UsageMergedRequirement { + usg_mod :: Module, + usg_mod_hash :: Fingerprint + } + deriving( Eq ) + -- The export list field is (Just v) if we depend on the export list: + -- i.e. we imported the module directly, whether or not we + -- enumerated the things we imported, or just imported + -- everything + -- We need to recompile if M's exports change, because + -- if the import was import M, we might now have a name clash + -- in the importing module. + -- if the import was import M(x) M might no longer export x + -- The only way we don't depend on the export list is if we have + -- import M() + -- And of course, for modules that aren't imported directly we don't + -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_file_hash usg) + + put_ bh usg@UsageMergedRequirement{} = do + putByte bh 3 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + hash <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash } + 3 -> do + mod <- get bh + hash <- get bh + return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } + i -> error ("Binary.get(Usage): " ++ show i) + +{- +************************************************************************ +* * + The External Package State +* * +************************************************************************ +-} + +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv +type PackageAnnEnv = AnnEnv +type PackageCompleteMatchMap = CompleteMatchMap + +-- | Information about other packages that we have slurped in by reading +-- their interface files +data ExternalPackageState + = EPS { + eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot), + -- ^ In OneShot mode (only), home-package modules + -- accumulate in the external package state, and are + -- sucked in lazily. For these home-pkg modules + -- (only) we need to record which are boot modules. + -- We set this field after loading all the + -- explicitly-imported interfaces, but before doing + -- anything else + -- + -- The 'ModuleName' part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from 'GHC.Tc.Utils.imp_dep_mods' + + eps_PIT :: !PackageIfaceTable, + -- ^ The 'ModIface's for modules in external packages + -- whose interfaces we have opened. + -- The declarations in these interface files are held in the + -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' + -- fields of this record, not in the 'mi_decls' fields of the + -- interface we have sucked in. + -- + -- What /is/ in the PIT is: + -- + -- * The Module + -- + -- * Fingerprint info + -- + -- * Its exports + -- + -- * Fixities + -- + -- * Deprecations and warnings + + eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), + -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on + -- the 'eps_PIT' for this information, EXCEPT that when + -- we do dependency analysis, we need to look at the + -- 'Dependencies' of our imports to determine what their + -- precise free holes are ('moduleFreeHolesPrecise'). We + -- don't want to repeatedly reread in the interface + -- for every import, so cache it here. When the PIT + -- gets filled in we can drop these entries. + + eps_PTE :: !PackageTypeEnv, + -- ^ Result of typechecking all the external package + -- interface files we have sucked in. The domain of + -- the mapping is external-package modules + + eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated + -- from all the external-package modules + eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated + -- from all the external-package modules + eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated + -- from all the external-package modules + eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated + -- from all the external-package modules + eps_complete_matches :: !PackageCompleteMatchMap, + -- ^ The total 'CompleteMatchMap' accumulated + -- from all the external-package modules + + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external + -- packages, keyed off the module that declared them + + eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages + } + +-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. +-- \"In\" means stuff that is just /read/ from interface files, +-- \"Out\" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- ^ Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } + +{- +Names in a NameCache are always stored as a Global, and have the SrcLoc +of their binding locations. + +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. +-} + +updNameCache :: IORef NameCache + -> (NameCache -> (NameCache, c)) -- The updating function + -> IO c +updNameCache ncRef upd_fn + = atomicModifyIORef' ncRef upd_fn + +mkSOName :: Platform -> FilePath -> FilePath +mkSOName platform root + = case platformOS platform of + OSMinGW32 -> root <.> soExt platform + _ -> ("lib" ++ root) <.> soExt platform + +mkHsSOName :: Platform -> FilePath -> FilePath +mkHsSOName platform root = ("lib" ++ root) <.> soExt platform + +soExt :: Platform -> FilePath +soExt platform + = case platformOS platform of + OSDarwin -> "dylib" + OSMinGW32 -> "dll" + _ -> "so" + +{- +************************************************************************ +* * + The module graph and ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +* * +************************************************************************ +-} + +-- | A ModuleGraph contains all the nodes from the home package (only). +-- There will be a node for each source module, plus a node for each hi-boot +-- module. +-- +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. +data ModuleGraph = ModuleGraph + { mg_mss :: [ModSummary] + , mg_non_boot :: ModuleEnv ModSummary + -- a map of all non-boot ModSummaries keyed by Modules + , mg_boot :: ModuleSet + -- a set of boot Modules + , mg_needs_th_or_qq :: !Bool + -- does any of the modules in mg_mss require TemplateHaskell or + -- QuasiQuotes? + } + +-- | Determines whether a set of modules requires Template Haskell or +-- Quasi Quotes +-- +-- Note that if the session's 'DynFlags' enabled Template Haskell when +-- 'depanal' was called, then each module in the returned module graph will +-- have Template Haskell enabled whether it is actually needed or not. +needsTemplateHaskellOrQQ :: ModuleGraph -> Bool +needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg + +-- | Map a function 'f' over all the 'ModSummaries'. +-- To preserve invariants 'f' can't change the isBoot status. +mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph +mapMG f mg@ModuleGraph{..} = mg + { mg_mss = map f mg_mss + , mg_non_boot = mapModuleEnv f mg_non_boot + } + +mgBootModules :: ModuleGraph -> ModuleSet +mgBootModules ModuleGraph{..} = mg_boot + +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries = mg_mss + +mgElemModule :: ModuleGraph -> Module -> Bool +mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot + +-- | Look up a ModSummary in the ModuleGraph +mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary +mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m + +emptyMG :: ModuleGraph +emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False + +isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool +isTemplateHaskellOrQQNonBoot ms = + (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) + || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && + (isBootSummary ms == NotBoot) + +-- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is +-- not an element of the ModuleGraph. +extendMG :: ModuleGraph -> ModSummary -> ModuleGraph +extendMG ModuleGraph{..} ms = ModuleGraph + { mg_mss = ms:mg_mss + , mg_non_boot = case isBootSummary ms of + IsBoot -> mg_non_boot + NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms + , mg_boot = case isBootSummary ms of + NotBoot -> mg_boot + IsBoot -> extendModuleSet mg_boot (ms_mod ms) + , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms + } + +mkModuleGraph :: [ModSummary] -> ModuleGraph +mkModuleGraph = foldr (flip extendMG) emptyMG + +-- | A single node in a 'ModuleGraph'. The nodes of the module graph +-- are one of: +-- +-- * A regular Haskell source module +-- * A hi-boot source module +-- +data ModSummary + = ModSummary { + ms_mod :: Module, + -- ^ Identity of the module + ms_hsc_src :: HscSource, + -- ^ The module source either plain Haskell or hs-boot + ms_location :: ModLocation, + -- ^ Location of the various files belonging to the module + ms_hs_date :: UTCTime, + -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, + -- ^ Timestamp of object, if we have one + ms_iface_date :: Maybe UTCTime, + -- ^ Timestamp of hi file, if we *only* are typechecking (it is + -- 'Nothing' otherwise. + -- See Note [Recompilation checking in -fno-code mode] and #9243 + ms_hie_date :: Maybe UTCTime, + -- ^ Timestamp of hie file, if we have one + ms_srcimps :: [(Maybe FastString, Located ModuleName)], + -- ^ Source imports of the module + ms_textual_imps :: [(Maybe FastString, Located ModuleName)], + -- ^ Non-source imports of the module from the module *text* + ms_parsed_mod :: Maybe HsParsedModule, + -- ^ The parsed, nonrenamed source, if we have it. This is also + -- used to support "inline module syntax" in Backpack files. + ms_hspp_file :: FilePath, + -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, + -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ + -- pragmas in the modules source code + ms_hspp_buf :: Maybe StringBuffer + -- ^ The actual preprocessed source, if we have it + } + +ms_installed_mod :: ModSummary -> InstalledModule +ms_installed_mod = fst . getModuleInstantiation . ms_mod + +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + +ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] +ms_imps ms = + ms_textual_imps ms ++ + map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + mk_additional_import mod_nm = (Nothing, noLoc mod_nm) + +home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] +home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, + isLocal mb_pkg ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +-- | Like 'ms_home_imps', but for SOURCE imports. +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +-- | All of the (possibly) home module imports from a +-- 'ModSummary'; that is to say, each of these module names +-- could be a home import if an appropriately named file +-- existed. (This is in contrast to package qualified +-- imports, which are guaranteed not to be home imports.) +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + +msDynObjFilePath :: ModSummary -> DynFlags -> FilePath +msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms) + +-- | Did this 'ModSummary' originate from a hs-boot file? +isBootSummary :: ModSummary -> IsBootInterface +isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary = showSDoc dflags $ + if gopt Opt_HideSourcePaths dflags + then text mod_str + else hsep $ + [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') + , char '(' + , text (op $ msHsFilePath mod_summary) <> char ',' + ] ++ + if gopt Opt_BuildDynamicToo dflags + then [ text obj_file <> char ',' + , text dyn_file + , char ')' + ] + else [ text obj_file, char ')' ] + where + op = normalise + mod = moduleName (ms_mod mod_summary) + mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) + dyn_file = op $ msDynObjFilePath mod_summary dflags + obj_file = case target of + HscInterpreted | recomp -> "interpreted" + HscNothing -> "nothing" + _ -> (op $ msObjFilePath mod_summary) + +{- +************************************************************************ +* * +\subsection{Recompilation} +* * +************************************************************************ +-} + +-- | Indicates whether a given module's source has been modified since it +-- was last compiled. +data SourceModified + = SourceModified + -- ^ the source has been modified + | SourceUnmodified + -- ^ the source has not been modified. Compilation may or may + -- not be necessary, depending on whether any dependencies have + -- changed since we last compiled. + | SourceUnmodifiedAndStable + -- ^ the source has not been modified, and furthermore all of + -- its (transitive) dependencies are up to date; it definitely + -- does not need to be recompiled. This is important for two + -- reasons: (a) we can omit the version check in checkOldIface, + -- and (b) if the module used TH splices we don't need to force + -- recompilation. + +{- +************************************************************************ +* * +\subsection{Hpc Support} +* * +************************************************************************ +-} + +-- | Information about a modules use of Haskell Program Coverage +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? + } + +-- | This is used to signal if one of my imports used HPC instrumentation +-- even if there is no module-local HPC usage +type AnyHpcUsage = Bool + +emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo = NoHpcInfo + +-- | Find out if HPC is used by this module or any of the modules +-- it depends upon +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used + +{- +************************************************************************ +* * +\subsection{Safe Haskell Support} +* * +************************************************************************ + +This stuff here is related to supporting the Safe Haskell extension, +primarily about storing under what trust type a module has been compiled. +-} + +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + Sf_SafeInferred -> 4 + Sf_Ignore -> 0 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_Unsafe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe +numToTrustInfo 4 = setSafeMode Sf_SafeInferred +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = text "none" + ppr (TrustInfo Sf_Ignore) = text "none" + ppr (TrustInfo Sf_Unsafe) = text "unsafe" + ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" + ppr (TrustInfo Sf_Safe) = text "safe" + ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) + +{- +************************************************************************ +* * +\subsection{Parser result} +* * +************************************************************************ +-} + +data HsParsedModule = HsParsedModule { + hpm_module :: Located HsModule, + hpm_src_files :: [FilePath], + -- ^ extra source files (e.g. from #includes). The lexer collects + -- these from '# ' pragmas, which the C preprocessor + -- leaves behind. These files and their timestamps are stored in + -- the .hi file, so that we can force recompilation if any of + -- them change (#3589) + hpm_annotations :: ApiAnns + -- See note [Api annotations] in GHC.Parser.Annotation + } + +{- +************************************************************************ +* * +\subsection{Linkable stuff} +* * +************************************************************************ + +This stuff is in here, rather than (say) in "GHC.Runtime.Linker", because the "GHC.Runtime.Linker" +stuff is the *dynamic* linker, and isn't present in a stage-1 compiler +-} + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = not (null unlinked) && all isObject unlinked + where unlinked = linkableUnlinked l + -- A linkable with no Unlinked's is treated as a BCO. We can + -- generate a linkable with no Unlinked's as a result of + -- compiling a module in HscNothing mode, and this choice + -- happens to work well with checkStability in module GHC. + +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + +------------------------------------------- + +-- | Is this an actual file on disk we can link in somehow? +isObject :: Unlinked -> Bool +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +-- | Is this a bytecode linkable with no file on disk? +isInterpretable :: Unlinked -> Bool +isInterpretable = not . isObject + +-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object +nameOfObject :: Unlinked -> FilePath +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn +nameOfObject other = pprPanic "nameOfObject" (ppr other) + +-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) + + +------------------------------------------- + +-- | A list of conlikes which represents a complete pattern match. +-- These arise from @COMPLETE@ signatures. + +-- See Note [Implementation of COMPLETE signatures] +data CompleteMatch = CompleteMatch { + completeMatchConLikes :: [Name] + -- ^ The ConLikes that form a covering family + -- (e.g. Nothing, Just) + , completeMatchTyCon :: Name + -- ^ The TyCon that they cover (e.g. Maybe) + } + +instance Outputable CompleteMatch where + ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl + <+> dcolon <+> ppr ty + +-- | A map keyed by the 'completeMatchTyCon' which has type Name. + +-- See Note [Implementation of COMPLETE signatures] +type CompleteMatchMap = UniqFM Name [CompleteMatch] + +mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap +mkCompleteMatchMap = extendCompleteMatchMap emptyUFM + +extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] + -> CompleteMatchMap +extendCompleteMatchMap = foldl' insertMatch + where + insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap + insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] + +{- +Note [Implementation of COMPLETE signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A COMPLETE signature represents a set of conlikes (i.e., constructors or +pattern synonyms) such that if they are all pattern-matched against in a +function, it gives rise to a total function. An example is: + + newtype Boolean = Boolean Int + pattern F, T :: Boolean + pattern F = Boolean 0 + pattern T = Boolean 1 + {-# COMPLETE F, T #-} + + -- This is a total function + booleanToInt :: Boolean -> Int + booleanToInt F = 0 + booleanToInt T = 1 + +COMPLETE sets are represented internally in GHC with the CompleteMatch data +type. For example, {-# COMPLETE F, T #-} would be represented as: + + CompleteMatch { complateMatchConLikes = [F, T] + , completeMatchTyCon = Boolean } + +Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the +cases in which it's ambiguous, you can also explicitly specify it in the source +language by writing this: + + {-# COMPLETE F, T :: Boolean #-} + +For efficiency purposes, GHC collects all of the CompleteMatches that it knows +about into a CompleteMatchMap, which is a map that is keyed by the +completeMatchTyCon. In other words, you could have a multiple COMPLETE sets +for the same TyCon: + + {-# COMPLETE F, T1 :: Boolean #-} + {-# COMPLETE F, T2 :: Boolean #-} + +And looking up the values in the CompleteMatchMap associated with Boolean +would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. +dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup. + +Also see Note [Typechecking Complete Matches] in GHC.Tc.Gen.Bind for a more detailed +explanation for how GHC ensures that all the conlikes in a COMPLETE set are +consistent. +-} + +-- | Foreign language of the phase if the phase deals with a foreign code +phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang +phaseForeignLanguage phase = case phase of + Phase.Cc -> Just LangC + Phase.Ccxx -> Just LangCxx + Phase.Cobjc -> Just LangObjc + Phase.Cobjcxx -> Just LangObjcxx + Phase.HCc -> Just LangC + Phase.As _ -> Just LangAsm + Phase.MergeForeign -> Just RawObject + _ -> Nothing + +------------------------------------------- + +-- Take care, this instance only forces to the degree necessary to +-- avoid major space leaks. +instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where + rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) = + rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` + f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` + rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 + `seq` rnf f24 + +{- +************************************************************************ +* * +\subsection{Extensible Iface Fields} +* * +************************************************************************ +-} + +type FieldName = String + +newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) } + +instance Binary ExtensibleFields where + put_ bh (ExtensibleFields fs) = do + put_ bh (Map.size fs :: Int) + + -- Put the names of each field, and reserve a space + -- for a payload pointer after each name: + header_entries <- forM (Map.toList fs) $ \(name, dat) -> do + put_ bh name + field_p_p <- tellBin bh + put_ bh field_p_p + return (field_p_p, dat) + + -- Now put the payloads and use the reserved space + -- to point to the start of each payload: + forM_ header_entries $ \(field_p_p, dat) -> do + field_p <- tellBin bh + putAt bh field_p_p field_p + seekBin bh field_p + put_ bh dat + + get bh = do + n <- get bh :: IO Int + + -- Get the names and field pointers: + header_entries <- replicateM n $ do + (,) <$> get bh <*> get bh + + -- Seek to and get each field's payload: + fields <- forM header_entries $ \(name, field_p) -> do + seekBin bh field_p + dat <- get bh + return (name, dat) + + return . ExtensibleFields . Map.fromList $ fields + +instance NFData ExtensibleFields where + rnf (ExtensibleFields fs) = rnf fs + +emptyExtensibleFields :: ExtensibleFields +emptyExtensibleFields = ExtensibleFields Map.empty + +-------------------------------------------------------------------------------- +-- | Reading + +readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a) +readIfaceField name = readIfaceFieldWith name get + +readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a) +readField name = readFieldWith name get + +readIfaceFieldWith :: FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a) +readIfaceFieldWith name read iface = readFieldWith name read (mi_ext_fields iface) + +readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a) +readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$> + Map.lookup name (getExtensibleFields fields) + +-------------------------------------------------------------------------------- +-- | Writing + +writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface +writeIfaceField name x = writeIfaceFieldWith name (`put_` x) + +writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields +writeField name x = writeFieldWith name (`put_` x) + +writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface +writeIfaceFieldWith name write iface = do + fields <- writeFieldWith name write (mi_ext_fields iface) + return iface{ mi_ext_fields = fields } + +writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields +writeFieldWith name write fields = do + bh <- openBinMem (1024 * 1024) + write bh + -- + bd <- handleData bh + return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields) + +deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields +deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs + +deleteIfaceField :: FieldName -> ModIface -> ModIface +deleteIfaceField name iface = iface { mi_ext_fields = deleteField name (mi_ext_fields iface) } diff --git a/GHC/Driver/Ways.hs b/GHC/Driver/Ways.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Ways.hs @@ -0,0 +1,202 @@ +-- | 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+threaded. +-- +-- There are two kinds of ways: +-- - RTS only: only affect the runtime system (RTS) and don't affect code +-- generation (e.g. threaded, debug) +-- - Full ways: affect code generation and the RTS (e.g. profiling, dynamic +-- linking) +-- +-- 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. +module GHC.Driver.Ways + ( Way(..) + , hasWay + , allowed_combination + , wayGeneralFlags + , wayUnsetGeneralFlags + , wayOptc + , wayOptl + , wayOptP + , wayDesc + , wayRTSOnly + , wayTag + , waysTag + , waysBuildTag + -- * Host GHC ways + , hostFullWays + , hostIsProfiled + , hostIsDynamic + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Driver.Flags + +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List (intersperse) +import System.IO.Unsafe ( unsafeDupablePerformIO ) + +-- | A way +-- +-- Don't change the constructor order as it us used by `waysTag` to create a +-- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal). +data Way + = WayCustom String -- ^ for GHC API clients building custom variants + | WayThreaded -- ^ (RTS only) Multithreaded runtime system + | WayDebug -- ^ Debugging, enable trace messages and extra checks + | WayProf -- ^ Profiling, enable cost-centre stacks and profiling reports + | WayEventLog -- ^ (RTS only) enable event logging + | WayDyn -- ^ Dynamic linking + deriving (Eq, Ord, Show) + +-- | Test if a ways is enabled +hasWay :: Set Way -> Way -> Bool +hasWay ws w = Set.member w ws + +-- | Check if a combination of ways is allowed +allowed_combination :: Set Way -> Bool +allowed_combination ways = not disallowed + where + disallowed = or [ hasWay ways x && hasWay ways y + | (x,y) <- couples + ] + -- List of disallowed couples of ways + couples = [] -- we don't have any disallowed combination of ways nowadays + +-- | Unique tag associated to a list of ways +waysTag :: Set Way -> String +waysTag = concat . intersperse "_" . map wayTag . Set.toAscList + +-- | Unique build-tag associated to a list of ways +-- +-- RTS only ways are filtered out because they have no impact on the build. +waysBuildTag :: Set Way -> String +waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws) + + +-- | Unique build-tag associated to a way +wayTag :: Way -> String +wayTag (WayCustom xs) = xs +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" + +-- | Return true for ways that only impact the RTS, not the generated code +wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayEventLog = True + +wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" + +-- | Turn these flags on when enabling this way +wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] +wayGeneralFlags _ WayThreaded = [] +wayGeneralFlags _ WayDebug = [] +wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] + -- We could get away without adding -fPIC when compiling the + -- modules of a program that is to be linked with -dynamic; the + -- program itself does not need to be position-independent, only + -- the libraries need to be. HOWEVER, GHCi links objects into a + -- .so before loading the .so using the system linker. Since only + -- PIC objects can be linked into a .so, we have to compile even + -- modules of the main program with -fPIC when using -dynamic. +wayGeneralFlags _ WayProf = [] +wayGeneralFlags _ WayEventLog = [] + +-- | Turn these flags off when enabling this way +wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] +wayUnsetGeneralFlags _ WayThreaded = [] +wayUnsetGeneralFlags _ WayDebug = [] +wayUnsetGeneralFlags _ WayDyn = [Opt_SplitSections] + -- There's no point splitting when we're going to be dynamically linking. + -- Plus it breaks compilation on OSX x86. +wayUnsetGeneralFlags _ WayProf = [] +wayUnsetGeneralFlags _ WayEventLog = [] + +-- | Pass these options to the C compiler when enabling this way +wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] +wayOptc platform WayThreaded = case platformOS platform of + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptc _ WayDebug = [] +wayOptc _ WayDyn = [] +wayOptc _ WayProf = ["-DPROFILING"] +wayOptc _ WayEventLog = ["-DTRACING"] + +-- | Pass these options to linker when enabling this way +wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] +wayOptl platform WayThreaded = + case platformOS platform of + -- N.B. FreeBSD cc throws a warning if we pass -pthread without + -- actually using any pthread symbols. + OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptl _ WayDebug = [] +wayOptl _ WayDyn = [] +wayOptl _ WayProf = [] +wayOptl _ WayEventLog = [] + +-- | Pass these options to the preprocessor when enabling this way +wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] +wayOptP _ WayThreaded = [] +wayOptP _ WayDebug = [] +wayOptP _ WayDyn = [] +wayOptP _ WayProf = ["-DPROFILING"] +wayOptP _ WayEventLog = ["-DTRACING"] + + +-- | Consult the RTS to find whether it has been built with profiling enabled. +hostIsProfiled :: Bool +hostIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 + +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO Int + +-- | Consult the RTS to find whether GHC itself has been built with +-- dynamic linking. This can't be statically known at compile-time, +-- because we build both the static and dynamic versions together with +-- -dynamic-too. +hostIsDynamic :: Bool +hostIsDynamic = unsafeDupablePerformIO rtsIsDynamicIO /= 0 + +foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int + +-- | Return host "full" ways (i.e. ways that have an impact on the compilation, +-- not RTS only ways). These ways must be used when compiling codes targeting +-- the internal interpreter. +hostFullWays :: Set Way +hostFullWays = Set.unions + [ if hostIsDynamic then Set.singleton WayDyn else Set.empty + , if hostIsProfiled then Set.singleton WayProf else Set.empty + ] diff --git a/GHC/Hs.hs b/GHC/Hs.hs --- a/GHC/Hs.hs +++ b/GHC/Hs.hs @@ -12,8 +12,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data @@ -25,10 +25,9 @@ module GHC.Hs.ImpExp, module GHC.Hs.Lit, module GHC.Hs.Pat, - module GHC.Hs.Types, + module GHC.Hs.Type, module GHC.Hs.Utils, module GHC.Hs.Doc, - module GHC.Hs.PlaceHolder, module GHC.Hs.Extension, Fixity, @@ -36,26 +35,25 @@ ) where -- friends: -import GhcPrelude +import GHC.Prelude import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Hs.ImpExp import GHC.Hs.Lit -import GHC.Hs.PlaceHolder import GHC.Hs.Extension import GHC.Hs.Pat -import GHC.Hs.Types -import BasicTypes ( Fixity, WarningTxt ) +import GHC.Hs.Type +import GHC.Types.Basic ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances -- others: -import Outputable -import SrcLoc -import Module ( ModuleName ) +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Unit.Module ( ModuleName ) -- libraries: import Data.Data hiding ( Fixity ) @@ -63,12 +61,15 @@ -- | Haskell Module -- -- All we actually declare here is the top-level structure for a module. -data HsModule pass +data HsModule = HsModule { + hsmodLayout :: LayoutInfo, + -- ^ Layout info for the module. + -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. hsmodName :: Maybe (Located ModuleName), -- ^ @Nothing@: \"module X where\" is omitted (in which case the next -- field is Nothing too) - hsmodExports :: Maybe (Located [LIE pass]), + hsmodExports :: Maybe (Located [LIE GhcPs]), -- ^ Export list -- -- - @Nothing@: export list omitted, so export everything @@ -78,53 +79,51 @@ -- - @Just [...]@: as you would expect... -- -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' + -- ,'GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation - hsmodImports :: [LImportDecl pass], + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + hsmodImports :: [LImportDecl GhcPs], -- ^ We snaffle interesting stuff out of the imported interfaces early -- on, adding that info to TyDecls/etc; so this list is often empty, -- downstream. - hsmodDecls :: [LHsDecl pass], + hsmodDecls :: [LHsDecl GhcPs], -- ^ Type, class, value, and interface signature decls hsmodDeprecMessage :: Maybe (Located WarningTxt), -- ^ reason\/explanation for warning/deprecation of this module -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' + -- ,'GHC.Parser.Annotation.AnnClose' -- - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation hsmodHaddockModHeader :: Maybe LHsDocString -- ^ Haddock module info and description, unparsed -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' + -- ,'GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation } - -- ^ 'ApiAnnotation.AnnKeywordId's + -- ^ 'GHC.Parser.Annotation.AnnKeywordId's -- - -- - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere' + -- - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere' -- - -- - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnClose' for explicit braces and semi around + -- - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around -- hsmodImports,hsmodDecls if this style is used. - -- For details on above see note [Api annotations] in ApiAnnotation --- deriving instance (DataIdLR name name) => Data (HsModule name) -deriving instance Data (HsModule GhcPs) -deriving instance Data (HsModule GhcRn) -deriving instance Data (HsModule GhcTc) + -- For details on above see note [Api annotations] in GHC.Parser.Annotation -instance (OutputableBndrId p) => Outputable (HsModule (GhcPass p)) where +deriving instance Data HsModule - ppr (HsModule Nothing _ imports decls _ mbDoc) +instance Outputable HsModule where + + ppr (HsModule _ Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule (Just name) exports imports decls deprec mbDoc) + ppr (HsModule _ (Just name) exports imports decls deprec mbDoc) = vcat [ pp_mb mbDoc, case exports of diff --git a/GHC/Hs/Binds.hs b/GHC/Hs/Binds.hs --- a/GHC/Hs/Binds.hs +++ b/GHC/Hs/Binds.hs @@ -12,15 +12,18 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} module GHC.Hs.Binds where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr, MatchGroup, pprFunBind, @@ -28,23 +31,22 @@ import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) import GHC.Hs.Extension -import GHC.Hs.Types -import CoreSyn -import TcEvidence -import Type -import NameSet -import BasicTypes -import Outputable -import SrcLoc -import Var -import Bag -import FastString -import BooleanFormula (LBooleanFormula) -import DynFlags +import GHC.Hs.Type +import GHC.Core +import GHC.Tc.Types.Evidence +import GHC.Core.Type +import GHC.Types.Name.Set +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.BooleanFormula (LBooleanFormula) import Data.Data hiding ( Fixity ) import Data.List hiding ( foldr ) -import Data.Ord +import Data.Function {- ************************************************************************ @@ -92,7 +94,7 @@ -- ^ Empty Local Bindings | XHsLocalBindsLR - (XXHsLocalBindsLR idL idR) + !(XXHsLocalBindsLR idL idR) type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField @@ -124,7 +126,7 @@ -- After renaming RHS; idR can be Name or Id Dependency analysed, -- later bindings in the list may depend on earlier ones. | XValBindsLR - (XXValBindsLR idL idR) + !(XXValBindsLR idL idR) -- --------------------------------------------------------------------- -- Deal with ValBindsOut @@ -196,7 +198,7 @@ -- and variables @f = \x -> e@ -- and strict variables @!x = x + 1@ -- - -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. + -- Reason 1: Special case for type inference: see 'GHC.Tc.Gen.Bind.tcMonoBinds'. -- -- Reason 2: Instance decls can only have FunBinds, which is convenient. -- If you change this, you'll need to change e.g. rnMethodBinds @@ -209,39 +211,39 @@ -- 'MatchContext'. See Note [FunBind vs PatBind] for -- details about the relationship between FunBind and PatBind. -- - -- 'ApiAnnotation.AnnKeywordId's + -- 'GHC.Parser.Annotation.AnnKeywordId's -- - -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches + -- - 'GHC.Parser.Annotation.AnnFunId', attached to each element of fun_matches -- - -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + -- - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', + -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation FunBind { - fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains - -- the locally-bound - -- free variables of this defn. - -- See Note [Bind free vars] + fun_ext :: XFunBind idL idR, + -- ^ After the renamer (but before the type-checker), this contains the + -- locally-bound free variables of this defn. See Note [Bind free vars] + -- + -- After the type-checker, this contains a coercion from the type of + -- the MatchGroup to the type of the Id. Example: + -- + -- @ + -- f :: Int -> forall a. a -> a + -- f x y = y + -- @ + -- + -- Then the MatchGroup will have type (Int -> a' -> a') + -- (with a free type variable a'). The coercion will take + -- a CoreExpr of this type and convert it to a CoreExpr of + -- type Int -> forall a'. a' -> a' + -- Notice that the coercion captures the free a'. + fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload - fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of - -- the Id. Example: - -- - -- @ - -- f :: Int -> forall a. a -> a - -- f x y = y - -- @ - -- - -- Then the MatchGroup will have type (Int -> a' -> a') - -- (with a free type variable a'). The coercion will take - -- a CoreExpr of this type and convert it to a CoreExpr of - -- type Int -> forall a'. a' -> a' - -- Notice that the coercion captures the free a'. - fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any } @@ -253,11 +255,11 @@ -- relationship between FunBind and PatBind. -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang', + -- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', + -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | PatBind { pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] pat_lhs :: LPat idL, @@ -274,9 +276,7 @@ | VarBind { var_ext :: XVarBind idL idR, var_id :: IdP idL, - var_rhs :: LHsExpr idR, -- ^ Located only for consistency - var_inline :: Bool -- ^ True <=> inline this binding regardless - -- (used for implication constraints only) + var_rhs :: LHsExpr idR -- ^ Located only for consistency } -- | Abstraction Bindings @@ -291,7 +291,7 @@ abs_exports :: [ABExport idL], -- | Evidence bindings - -- Why a list? See TcInstDcls + -- Why a list? See "GHC.Tc.TyCl.Instance" -- Note [Typechecking plan for instance declarations] abs_ev_binds :: [TcEvBinds], @@ -305,14 +305,14 @@ | PatSynBind (XPatSynBind idL idR) (PatSynBind idL idR) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', - -- 'ApiAnnotation.AnnWhere' - -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', + -- 'GHC.Parser.Annotation.AnnLarrow','GHC.Parser.Annotation.AnnEqual', + -- 'GHC.Parser.Annotation.AnnWhere' + -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@ - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation - | XHsBindsLR (XXHsBindsLR idL idR) + | XHsBindsLR !(XXHsBindsLR idL idR) data NPatBindTc = NPatBindTc { pat_fvs :: NameSet, -- ^ Free variables @@ -320,8 +320,8 @@ } deriving Data type instance XFunBind (GhcPass pL) GhcPs = NoExtField -type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables -type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcTc = HsWrapper -- See comments on FunBind.fun_ext type instance XPatBind GhcPs (GhcPass pR) = NoExtField type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables @@ -345,7 +345,7 @@ -- -- See Note [AbsBinds] --- | Abtraction Bindings Export +-- | Abstraction Bindings Export data ABExport p = ABE { abe_ext :: XABE p , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id @@ -354,18 +354,18 @@ -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas } - | XABExport (XXABExport p) + | XABExport !(XXABExport p) type instance XABE (GhcPass p) = NoExtField type instance XXABExport (GhcPass p) = NoExtCon --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' --- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, --- 'ApiAnnotation.AnnClose' @'}'@, +-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', +-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow', +-- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@, +-- 'GHC.Parser.Annotation.AnnClose' @'}'@, --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | Pattern Synonym binding data PatSynBind idL idR @@ -377,7 +377,7 @@ psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality } - | XPatSynBind (XXPatSynBind idL idR) + | XPatSynBind !(XXPatSynBind idL idR) type instance XPSB (GhcPass idL) GhcPs = NoExtField type instance XPSB (GhcPass idL) GhcRn = NameSet @@ -407,7 +407,7 @@ gp = ...same again, with gm instead of fm -The 'fwrap' is an impedence-matcher that typically does nothing; see +The 'fwrap' is an impedance-matcher that typically does nothing; see Note [ABExport wrapper]. This is a pretty bad translation, because it duplicates all the bindings. @@ -562,7 +562,7 @@ undef = /\ a. \ (d:HasCallStack) -> error a d "undef" The abs_sig field supports this direct desugaring, with no local -let-bining. When abs_sig = True +let-binding. When abs_sig = True * the abs_binds is single FunBind @@ -572,7 +572,7 @@ and hence the abs_binds is non-recursive (it binds the mono_id but refers to the poly_id -These properties are exploited in DsBinds.dsAbsBinds to +These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to generate code without a let-binding. Note [ABExport wrapper] @@ -590,7 +590,7 @@ The abe_wrap field deals with impedance-matching between (/\a b. case tup a b of { (f,g) -> f }) and the thing we really want, which may have fewer type -variables. The action happens in TcBinds.mkExport. +variables. The action happens in GHC.Tc.Gen.Bind.mkExport. Note [Bind free vars] ~~~~~~~~~~~~~~~~~~~~~ @@ -598,14 +598,14 @@ of the definition. It is used for the following purposes a) Dependency analysis prior to type checking - (see TcBinds.tc_group) + (see GHC.Tc.Gen.Bind.tc_group) b) Deciding whether we can do generalisation of the binding - (see TcBinds.decideGeneralisationPlan) + (see GHC.Tc.Gen.Bind.decideGeneralisationPlan) c) Deciding whether the binding can be used in static forms - (see TcExpr.checkClosedInStaticForm for the HsStatic case and - TcBinds.isClosedBndrGroup). + (see GHC.Tc.Gen.Expr.checkClosedInStaticForm for the HsStatic case and + GHC.Tc.Gen.Bind.isClosedBndrGroup). Specifically, @@ -623,7 +623,6 @@ ppr (HsValBinds _ bs) = ppr bs ppr (HsIPBinds _ bs) = ppr bs ppr (EmptyLocalBinds _) = empty - ppr (XHsLocalBindsLR x) = ppr x instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where @@ -631,11 +630,10 @@ = pprDeclList (pprLHsBindsForUser binds sigs) ppr (XValBindsLR (NValBinds sccs sigs)) - = getPprStyle $ \ sty -> - if debugStyle sty then -- Print with sccs showing - vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) - else - pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) + = getPprDebug $ \case + -- Print with sccs showing + True -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + False -> pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) where ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds pp_rec Recursive = text "rec" @@ -665,7 +663,7 @@ decls = [(loc, ppr sig) | L loc sig <- sigs] ++ [(loc, ppr bind) | L loc bind <- bagToList binds] - sort_by_loc decls = sortBy (comparing fst) decls + sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls pprDeclList :: [SDoc] -> SDoc -- Braces with a space -- Print a bunch of declarations @@ -682,19 +680,6 @@ emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) emptyLocalBinds = EmptyLocalBinds noExtField --- AZ:These functions do not seem to be used at all? -isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool -isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds -isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds -isEmptyLocalBindsTc (EmptyLocalBinds _) = True -isEmptyLocalBindsTc (XHsLocalBindsLR _) = True - -isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds -isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds -isEmptyLocalBindsPR (EmptyLocalBinds _) = True -isEmptyLocalBindsPR (XHsLocalBindsLR _) = True - eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool eqEmptyLocalBinds (EmptyLocalBinds _) = True eqEmptyLocalBinds _ = False @@ -728,7 +713,8 @@ => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) +ppr_monobind :: forall idL idR. + (OutputableBndrId idL, OutputableBndrId idR) => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) @@ -736,40 +722,39 @@ ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, - fun_co_fn = wrap, fun_matches = matches, - fun_tick = ticks }) + fun_tick = ticks, + fun_ext = wrap }) = pprTicks empty (if null ticks then empty else text "-- ticks = " <> ppr ticks) $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches - $$ whenPprDebug (ppr wrap) + $$ whenPprDebug (pprIfTc @idR $ ppr wrap) + ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags then - -- Show extra information (bug number: #10662) - hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) - <+> brackets (interpp'SP dictvars)) - 2 $ braces $ vcat - [ text "Exports:" <+> - brackets (sep (punctuate comma (map ppr exports))) - , text "Exported types:" <+> - vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] - , text "Binds:" <+> pprLHsBinds val_binds - , text "Evidence:" <+> ppr ev_binds ] - else - pprLHsBinds val_binds -ppr_monobind (XHsBindsLR x) = ppr x + = sdocOption sdocPrintTypecheckerElaboration $ \case + False -> pprLHsBinds val_binds + True -> -- Show extra information (bug number: #10662) + hang (text "AbsBinds" + <+> sep [ brackets (interpp'SP tyvars) + , brackets (interpp'SP dictvars) ]) + 2 $ braces $ vcat + [ text "Exports:" <+> + brackets (sep (punctuate comma (map ppr exports))) + , text "Exported types:" <+> + vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , text "Binds:" <+> pprLHsBinds val_binds + , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) + ] instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) - = vcat [ ppr gbl <+> text "<=" <+> ppr lcl + = vcat [ sep [ ppr gbl, nest 2 (text "<=" <+> ppr lcl) ] , nest 2 (pprTcSpecPrags prags) - , nest 2 (text "wrap:" <+> ppr wrap)] - ppr (XABExport x) = ppr x + , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ] instance (OutputableBndrId l, OutputableBndrId r, Outputable (XXPatSynBind (GhcPass l) (GhcPass r))) @@ -792,7 +777,6 @@ ImplicitBidirectional -> ppr_simple equals ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ (nest 2 $ pprFunBind mg) - ppr (XPatSynBind x) = ppr x pprTicks :: SDoc -> SDoc -> SDoc -- Print stuff about ticks only when -dppr-debug is on, to avoid @@ -800,9 +784,11 @@ -- Also print ticks in dumpStyle, so that -ddump-hpc actually does -- something useful. pprTicks pp_no_debug pp_when_debug - = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty - then pp_when_debug - else pp_no_debug) + = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if debug || dumpStyle sty + then pp_when_debug + else pp_no_debug {- ************************************************************************ @@ -819,7 +805,7 @@ [LIPBind id] -- TcEvBinds -- Only in typechecker output; binds -- -- uses of the implicit parameters - | XHsIPBinds (XXHsIPBinds id) + | XHsIPBinds !(XXHsIPBinds id) type instance XIPBinds GhcPs = NoExtField type instance XIPBinds GhcRn = NoExtField @@ -831,18 +817,16 @@ isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool isEmptyIPBindsPR (IPBinds _ is) = null is -isEmptyIPBindsPR (XHsIPBinds _) = True isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -isEmptyIPBindsTc (XHsIPBinds _) = True -- | Located Implicit Parameter Binding type LIPBind id = Located (IPBind id) --- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a -- list --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | Implicit parameter bindings. -- @@ -851,15 +835,15 @@ -- (Right d), where "d" is the name of the dictionary holding the -- evidence for the implicit parameter. -- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual' --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation data IPBind id = IPBind (XCIPBind id) (Either (Located HsIPName) (IdP id)) (LHsExpr id) - | XIPBind (XXIPBind id) + | XIPBind !(XXIPBind id) type instance XCIPBind (GhcPass p) = NoExtField type instance XXIPBind (GhcPass p) = NoExtCon @@ -867,15 +851,13 @@ instance OutputableBndrId p => Outputable (HsIPBinds (GhcPass p)) where ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) - $$ whenPprDebug (ppr ds) - ppr (XHsIPBinds x) = ppr x + $$ whenPprDebug (pprIfTc @p $ ppr ds) instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip Right id -> pprBndr LetBind id - ppr (XIPBind x) = ppr x {- ************************************************************************ @@ -907,10 +889,10 @@ -- signature that brought them into scope, in this third field to be -- more specific. -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnComma' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon', + -- 'GHC.Parser.Annotation.AnnComma' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation TypeSig (XTypeSig pass) [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah @@ -920,11 +902,11 @@ -- -- > pattern Single :: () => (Show a) => a -> [a] -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' - -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', + -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall' + -- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) -- P :: forall a b. Req => Prov => ty @@ -936,8 +918,8 @@ -- default op :: Eq a => a -> a -- Generic default -- No wildcards allowed here -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnDcolon' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault', + -- 'GHC.Parser.Annotation.AnnDcolon' | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) -- | A type signature in generated code, notably the code @@ -952,23 +934,23 @@ -- > infixl 8 *** -- -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', - -- 'ApiAnnotation.AnnVal' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix', + -- 'GHC.Parser.Annotation.AnnVal' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | FixSig (XFixSig pass) (FixitySig pass) -- | An inline pragma -- -- > {#- INLINE f #-} -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, - -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# INLINE'@ and @'['@, + -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde', + -- 'GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | InlineSig (XInlineSig pass) (Located (IdP pass)) -- Function name InlinePragma -- Never defaultInlinePragma @@ -977,14 +959,14 @@ -- -- > {-# SPECIALISE f :: Int -> Int #-} -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, - -- 'ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, - -- 'ApiAnnotation.AnnDcolon' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, + -- 'GHC.Parser.Annotation.AnnTilde', + -- 'GHC.Parser.Annotation.AnnVal', + -- 'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@, + -- 'GHC.Parser.Annotation.AnnDcolon' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | SpecSig (XSpecSig pass) (Located (IdP pass)) -- Specialise a function or datatype ... [LHsSigType pass] -- ... to these types @@ -999,25 +981,25 @@ -- (Class tys); should be a specialisation of the -- current instance declaration -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | A minimal complete definition pragma -- -- > {-# MINIMAL a | (b, c | (d | e)) #-} -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma', + -- 'GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | MinimalSig (XMinimalSig pass) SourceText (LBooleanFormula (Located (IdP pass))) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | A "set cost centre" pragma for declarations -- @@ -1028,7 +1010,7 @@ -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (Located (IdP pass)) -- Function name (Maybe (Located StringLiteral)) -- | A complete match pragma @@ -1042,7 +1024,7 @@ SourceText (Located [Located (IdP pass)]) (Maybe (Located (IdP pass))) - | XSig (XXSig pass) + | XSig !(XXSig pass) type instance XTypeSig (GhcPass p) = NoExtField type instance XPatSynSig (GhcPass p) = NoExtField @@ -1062,7 +1044,7 @@ -- | Fixity Signature data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity - | XFixitySig (XXFixitySig pass) + | XFixitySig !(XXFixitySig pass) type instance XFixitySig (GhcPass p) = NoExtField type instance XXFixitySig (GhcPass p) = NoExtCon @@ -1202,14 +1184,12 @@ <+> opt_sig) where opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty -ppr_sig (XSig x) = ppr x instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) - ppr (XFixitySig x) = ppr x pragBrackets :: SDoc -> SDoc pragBrackets doc = text "{-#" <+> doc <+> text "#-}" diff --git a/GHC/Hs/Decls.hs b/GHC/Hs/Decls.hs --- a/GHC/Hs/Decls.hs +++ b/GHC/Hs/Decls.hs @@ -5,14 +5,19 @@ {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + -- | Abstract syntax of global declarations. -- -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, @@ -84,36 +89,39 @@ resultVariableName, familyDeclLName, familyDeclName, -- * Grouping - HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls, + hsGroupTopLevelFixitySigs, + partitionBindsAndSigs, ) where -- friends: -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, HsSplice, pprExpr, pprSpliceDecl ) -- Because Expr imports Decls via HsBracket import GHC.Hs.Binds -import GHC.Hs.Types +import GHC.Hs.Type import GHC.Hs.Doc -import TyCon -import BasicTypes -import Coercion -import ForeignCall +import GHC.Core.TyCon +import GHC.Types.Basic +import GHC.Core.Coercion +import GHC.Types.ForeignCall import GHC.Hs.Extension -import NameSet +import GHC.Types.Name +import GHC.Types.Name.Set -- others: -import Class -import Outputable -import Util -import SrcLoc -import Type +import GHC.Core.Class +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.SrcLoc +import GHC.Core.Type -import Bag -import Maybes +import GHC.Data.Bag +import GHC.Data.Maybe import Data.Data hiding (TyCon,Fixity, Infix) {- @@ -127,10 +135,10 @@ type LHsDecl p = Located (HsDecl p) -- ^ When in a list this may have -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' -- --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | A Haskell Declaration data HsDecl p @@ -149,7 +157,7 @@ -- (Includes quasi-quotes) | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration - | XHsDecl (XXHsDecl p) + | XHsDecl !(XXHsDecl p) type instance XTyClD (GhcPass _) = NoExtField type instance XInstD (GhcPass _) = NoExtField @@ -167,18 +175,81 @@ type instance XRoleAnnotD (GhcPass _) = NoExtField type instance XXHsDecl (GhcPass _) = NoExtCon --- NB: all top-level fixity decls are contained EITHER --- EITHER SigDs --- OR in the ClassDecls in TyClDs +{- +Note [Top-level fixity signatures in an HsGroup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An `HsGroup p` stores every top-level fixity declarations in one of two places: + +1. hs_fixds :: [LFixitySig p] + + This stores fixity signatures for top-level declarations (e.g., functions, + data constructors, classes, type families, etc.) as well as fixity + signatures for class methods written outside of the class, as in this + example: + + infixl 4 `m1` + class C1 a where + m1 :: a -> a -> a + +2. hs_tyclds :: [TyClGroup p] + + Each type class can be found in a TyClDecl inside a TyClGroup, and that + TyClDecl stores the fixity signatures for its methods written inside of the + class, as in this example: + + class C2 a where + infixl 4 `m2` + m2 :: a -> a -> a + +The story for fixity signatures for class methods is made slightly complicated +by the fact that they can appear both inside and outside of the class itself, +and both forms of fixity signatures are considered top-level. This matters +in `GHC.Rename.Module.rnSrcDecls`, which must create a fixity environment out +of all top-level fixity signatures before doing anything else. Therefore, +`rnSrcDecls` must be aware of both (1) and (2) above. The +`hsGroupTopLevelFixitySigs` function is responsible for collecting this +information from an `HsGroup`. + +One might wonder why we even bother separating top-level fixity signatures +into two places at all. That is, why not just take the fixity signatures +from `hs_tyclds` and put them into `hs_fixds` so that they are all in one +location? This ends up causing problems for `GHC.HsToCore.Quote.repTopDs`, +which translates each fixity signature in `hs_fixds` and `hs_tyclds` into a +Template Haskell `Dec`. If there are any duplicate signatures between the two +fields, this will result in an error (#17608). +-} + +-- | Partition a list of HsDecls into function/pattern bindings, signatures, +-- type family declarations, type family instances, and documentation comments. -- --- The former covers --- a) data constructors --- b) class methods (but they can be also done in the --- signatures of class decls) --- c) imported functions (that have an IfacSig) --- d) top level decls +-- Panics when given a declaration that cannot be put into any of the output +-- groups. -- --- The latter is for class methods only +-- The primary use of this function is to implement +-- 'GHC.Parser.PostProcess.cvBindsAndSigs'. +partitionBindsAndSigs + :: [LHsDecl GhcPs] + -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) +partitionBindsAndSigs = go + where + go [] = (emptyBag, [], [], [], [], []) + go ((L l decl) : ds) = + let (bs, ss, ts, tfis, dfis, docs) = go ds in + case decl of + ValD _ b + -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs) + SigD _ s + -> (bs, L l s : ss, ts, tfis, dfis, docs) + TyClD _ (FamDecl _ t) + -> (bs, ss, L l t : ts, tfis, dfis, docs) + InstD _ (TyFamInstD { tfid_inst = tfi }) + -> (bs, ss, ts, L l tfi : tfis, dfis, docs) + InstD _ (DataFamInstD { dfid_inst = dfi }) + -> (bs, ss, ts, tfis, L l dfi : dfis, docs) + DocD _ d + -> (bs, ss, ts, tfis, dfis, L l d : docs) + _ -> pprPanic "partitionBindsAndSigs" (ppr decl) -- | Haskell Group -- @@ -199,8 +270,10 @@ hs_derivds :: [LDerivDecl p], hs_fixds :: [LFixitySig p], - -- Snaffled out of both top-level fixity signatures, - -- and those in class declarations + -- A list of fixity signatures defined for top-level + -- declarations and class methods (defined outside of the class + -- itself). + -- See Note [Top-level fixity signatures in an HsGroup] hs_defds :: [LDefaultDecl p], hs_fords :: [LForeignDecl p], @@ -210,7 +283,7 @@ hs_docs :: [LDocDecl] } - | XHsGroup (XXHsGroup p) + | XHsGroup !(XXHsGroup p) type instance XCHsGroup (GhcPass _) = NoExtField type instance XXHsGroup (GhcPass _) = NoExtCon @@ -232,6 +305,18 @@ hs_splcds = [], hs_docs = [] } +-- | The fixity signatures for each top-level declaration and class method +-- in an 'HsGroup'. +-- See Note [Top-level fixity signatures in an HsGroup] +hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)] +hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) = + fixds ++ cls_fixds + where + cls_fixds = [ L loc sig + | L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds + , L loc (FixSig _ sig) <- sigs + ] + appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p) appendGroups @@ -273,7 +358,6 @@ hs_warnds = warnds1 ++ warnds2, hs_ruleds = rulds1 ++ rulds2, hs_docs = docs1 ++ docs2 } -appendGroups _ _ = panic "appendGroups" instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where ppr (TyClD _ dcl) = ppr dcl @@ -290,7 +374,6 @@ ppr (SpliceD _ dd) = ppr dd ppr (DocD _ doc) = ppr doc ppr (RoleAnnotD _ ra) = ppr ra - ppr (XHsDecl x) = ppr x instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where ppr (HsGroup { hs_valds = val_decls, @@ -325,7 +408,6 @@ vcat_mb _ [] = empty vcat_mb gap (Nothing : ds) = vcat_mb gap ds vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds - ppr (XHsGroup x) = ppr x -- | Located Splice Declaration type LSpliceDecl pass = Located (SpliceDecl pass) @@ -336,7 +418,7 @@ (XSpliceDecl p) (Located (HsSplice p)) SpliceExplicitFlag - | XSpliceDecl (XXSpliceDecl p) + | XSpliceDecl !(XXSpliceDecl p) type instance XSpliceDecl (GhcPass _) = NoExtField type instance XXSpliceDecl (GhcPass _) = NoExtCon @@ -344,7 +426,6 @@ instance OutputableBndrId p => Outputable (SpliceDecl (GhcPass p)) where ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f - ppr (XSpliceDecl x) = ppr x {- ************************************************************************ @@ -383,11 +464,11 @@ (See RnHiFiles.getSysBinders) - When typechecking the decl, we build the implicit TyCons and Ids. - When doing so we look them up in the name cache (RnEnv.lookupSysName), + When doing so we look them up in the name cache (GHC.Rename.Env.lookupSysName), to ensure correct module and provenance is set These are the two places that we have to conjure up the magic derived -names. (The actual magic is in OccName.mkWorkerOcc, etc.) +names. (The actual magic is in GHC.Types.Name.Occurrence.mkWorkerOcc, etc.) Default methods ~~~~~~~~~~~~~~~ @@ -396,7 +477,7 @@ - If there is a default method name at all, it's recorded in the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field. - (DefMethInfo is defined in Class.hs) + (DefMethInfo is defined in GHC.Core.Class) Source-code class decls and interface-code class decls are treated subtly differently, which has given me a great deal of confusion over the years. @@ -406,7 +487,7 @@ In *source-code* class declarations: - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName - This is done by RdrHsSyn.mkClassOpSigDM + This is done by GHC.Parser.PostProcess.mkClassOpSigDM - The renamer renames it to a Name @@ -441,7 +522,7 @@ The type checker makes up new source-code instance declarations (e.g. from 'deriving' or generic default methods --- see -TcInstDcls.tcInstDecls1). So we can't generate the names for +GHC.Tc.TyCl.Instance.tcInstDecls1). So we can't generate the names for dictionary functions in advance (we don't know how many we need). On the other hand for interface-file instance declarations, the decl @@ -492,40 +573,40 @@ data TyClDecl pass = -- | @type/data family T :: *->*@ -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow', - -- 'ApiAnnotation.AnnVbar' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', + -- 'GHC.Parser.Annotation.AnnData', + -- 'GHC.Parser.Annotation.AnnFamily','GHC.Parser.Annotation.AnnDcolon', + -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpenP', + -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnCloseP', + -- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnRarrow', + -- 'GHC.Parser.Annotation.AnnVbar' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } | -- | @type@ declaration -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnEqual', + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', + -- 'GHC.Parser.Annotation.AnnEqual', - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these -- include outer binders - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdRhs :: LHsType pass } -- ^ RHS of type declaration | -- | @data@ declaration -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnFamily', - -- 'ApiAnnotation.AnnNewType', - -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon' - -- 'ApiAnnotation.AnnWhere', + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData', + -- 'GHC.Parser.Annotation.AnnFamily', + -- 'GHC.Parser.Annotation.AnnNewType', + -- 'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnDcolon' + -- 'GHC.Parser.Annotation.AnnWhere', - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables @@ -533,10 +614,10 @@ , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdDataDefn :: HsDataDefn pass } - | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdCtxt :: LHsContext pass, -- ^ Context... - tcdLName :: Located (IdP pass), -- ^ Name of the class - tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... + tcdLName :: Located (IdP pass), -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration tcdFDs :: [LHsFunDep pass], -- ^ Functional deps tcdSigs :: [LSig pass], -- ^ Methods' signatures @@ -545,15 +626,15 @@ tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults tcdDocs :: [LDocDecl] -- ^ Haddock docs } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - -- - The tcdFDs will have 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnComma' - -- 'ApiAnnotation.AnnRarrow' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass', + -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose' + -- - The tcdFDs will have 'GHC.Parser.Annotation.AnnVbar', + -- 'GHC.Parser.Annotation.AnnComma' + -- 'GHC.Parser.Annotation.AnnRarrow' - -- For details on above see note [Api annotations] in ApiAnnotation - | XTyClDecl (XXTyClDecl pass) + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XTyClDecl !(XXTyClDecl pass) type LHsFunDep pass = Located (FunDep (Located (IdP pass))) @@ -580,7 +661,7 @@ own right. However we are careful to use the same name 'a', so that we can match things up. -c.f. Note [Associated type tyvar names] in Class.hs +c.f. Note [Associated type tyvar names] in GHC.Core.Class Note [Family instance declaration binders] -} @@ -594,10 +675,29 @@ type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn -type instance XClassDecl GhcPs = NoExtField +type instance XClassDecl GhcPs = LayoutInfo -- See Note [Class LayoutInfo] type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs +{- Note [Class LayoutInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The LayoutInfo is used to associate Haddock comments with parts of the declaration. +Compare the following examples: + + class C a where + f :: a -> Int + -- ^ comment on f + + class C a where + f :: a -> Int + -- ^ comment on C + +Notice how "comment on f" and "comment on C" differ only by indentation level. +Thus we have to record the indentation level of the class declarations. + +See also Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock +-} + type instance XXTyClDecl (GhcPass _) = NoExtCon -- Simple classifiers for TyClDecl @@ -656,17 +756,12 @@ tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) = ln -tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec))) - = noExtCon nec -tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p)) tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd tyClDeclLName (SynDecl { tcdLName = ln }) = ln tyClDeclLName (DataDecl { tcdLName = ln }) = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln -tyClDeclLName (XTyClDecl nec) = noExtCon nec tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p) tcdName = unLoc . tyClDeclLName @@ -705,8 +800,6 @@ = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs) hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -hsDeclHasCusk (FamDecl { tcdFam = XFamilyDecl nec }) = noExtCon nec -hsDeclHasCusk (XTyClDecl nec) = noExtCon nec -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -742,8 +835,6 @@ <+> pp_vanilla_decl_head lclas tyvars fixity context <+> pprFundeps (map unLoc fds) - ppr (XTyClDecl x) = ppr x - instance OutputableBndrId p => Outputable (TyClGroup (GhcPass p)) where ppr (TyClGroup { group_tyclds = tyclds @@ -757,7 +848,6 @@ ppr tyclds $$ ppr roles $$ ppr instds - ppr (XTyClGroup x) = ppr x pp_vanilla_decl_head :: (OutputableBndrId p) => Located (IdP (GhcPass p)) @@ -779,20 +869,14 @@ | otherwise = hsep [ pprPrefixOcc (unLoc thing) , hsep (map (ppr.unLoc) (varl:varsr))] pp_tyvars [] = pprPrefixOcc (unLoc thing) -pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc pprTyClDeclFlavour (ClassDecl {}) = text "class" pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" -pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl nec }) - = noExtCon nec pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) = ppr nd -pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) - = ppr x -pprTyClDeclFlavour (XTyClDecl x) = ppr x {- Note [CUSKs: complete user-supplied kind signatures] @@ -840,16 +924,16 @@ NOTE THAT * A CUSK does /not/ mean that everything about the kind signature is - fully specified by the user. Look at T4 and f4: we had do do kind + fully specified by the user. Look at T4 and f4: we had to do kind inference to figure out the kind-quantification. But in both cases (T4 and f4) that inference is done looking /only/ at the header of T4 (or signature for f4), not at the definition thereof. * The CUSK completely fixes the kind of the type constructor, forever. - * The precise rules, for each declaration form, for whethher a declaration + * The precise rules, for each declaration form, for whether a declaration has a CUSK are given in the user manual section "Complete user-supplied - kind signatures and polymorphic recursion". BUt they simply implement + kind signatures and polymorphic recursion". But they simply implement PRINCIPLE above. * Open type families are interesting: @@ -910,8 +994,8 @@ depend on group_tyclds, or on earlier TyClGroups, but not on later ones. -See Note [Dependency analsis of type, class, and instance decls] -in RnSource for more info. +See Note [Dependency analysis of type, class, and instance decls] +in GHC.Rename.Module for more info. -} -- | Type or Class Group @@ -921,7 +1005,7 @@ , group_roles :: [LRoleAnnotDecl pass] , group_kisigs :: [LStandaloneKindSig pass] , group_instds :: [LInstDecl pass] } - | XTyClGroup (XXTyClGroup pass) + | XTyClGroup !(XXTyClGroup pass) type instance XCTyClGroup (GhcPass _) = NoExtField type instance XXTyClGroup (GhcPass _) = NoExtCon @@ -1006,7 +1090,7 @@ Here injectivity annotation would consist of two comma-separated injectivity conditions. -See also Note [Injective type families] in TyCon +See also Note [Injective type families] in GHC.Core.TyCon -} -- | Located type Family Result Signature @@ -1015,24 +1099,24 @@ -- | type Family Result Signature data FamilyResultSig pass = -- see Note [FamilyResultSig] NoSig (XNoSig pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | KindSig (XCKindSig pass) (LHsKind pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnCloseP' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon', + -- 'GHC.Parser.Annotation.AnnCloseP' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation - | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' - | XFamilyResultSig (XXFamilyResultSig pass) + | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon', + -- 'GHC.Parser.Annotation.AnnCloseP', 'GHC.Parser.Annotation.AnnEqual' + | XFamilyResultSig !(XXFamilyResultSig pass) - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation type instance XNoSig (GhcPass _) = NoExtField type instance XCKindSig (GhcPass _) = NoExtField @@ -1055,15 +1139,15 @@ , fdResultSig :: LFamilyResultSig pass -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann } - | XFamilyDecl (XXFamilyDecl pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', - -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', - -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP', - -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow', - -- 'ApiAnnotation.AnnVbar' + | XFamilyDecl !(XXFamilyDecl pass) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', + -- 'GHC.Parser.Annotation.AnnData', 'GHC.Parser.Annotation.AnnFamily', + -- 'GHC.Parser.Annotation.AnnWhere', 'GHC.Parser.Annotation.AnnOpenP', + -- 'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnCloseP', + -- 'GHC.Parser.Annotation.AnnEqual', 'GHC.Parser.Annotation.AnnRarrow', + -- 'GHC.Parser.Annotation.AnnVbar' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation type instance XCFamilyDecl (GhcPass _) = NoExtField type instance XXFamilyDecl (GhcPass _) = NoExtCon @@ -1082,10 +1166,10 @@ -- This will be represented as "InjectivityAnn `r` [`a`, `c`]" data InjectivityAnn pass = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)] - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation data FamilyInfo pass = DataFamily @@ -1099,7 +1183,6 @@ familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p)) familyDeclLName (FamilyDecl { fdLName = n }) = n -familyDeclLName (XFamilyDecl nec) = noExtCon nec familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p) familyDeclName = unLoc . familyDeclLName @@ -1109,10 +1192,8 @@ famResultKindSignature (KindSig _ ki) = Just ki famResultKindSignature (TyVarSig _ bndr) = case unLoc bndr of - UserTyVar _ _ -> Nothing - KindedTyVar _ _ ki -> Just ki - XTyVarBndr nec -> noExtCon nec -famResultKindSignature (XFamilyResultSig nec) = noExtCon nec + UserTyVar _ _ _ -> Nothing + KindedTyVar _ _ _ ki -> Just ki -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) @@ -1145,7 +1226,6 @@ NoSig _ -> empty KindSig _ kind -> dcolon <+> ppr kind TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr - XFamilyResultSig nec -> noExtCon nec pp_inj = case mb_inj of Just (L _ (InjectivityAnn lhs rhs)) -> hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] @@ -1157,7 +1237,6 @@ Nothing -> text ".." Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) _ -> (empty, empty) -pprFamilyDecl _ (XFamilyDecl nec) = noExtCon nec pprFlavour :: FamilyInfo pass -> SDoc pprFlavour DataFamily = text "data" @@ -1204,11 +1283,11 @@ -- For @data T a where { T1 :: T a }@ -- the 'LConDecls' all have 'ConDeclGADT'. - dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' claues + dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' clause - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation } - | XHsDataDefn (XXHsDataDefn pass) + | XHsDataDefn !(XXHsDataDefn pass) type instance XCHsDataDefn (GhcPass _) = NoExtField @@ -1228,12 +1307,12 @@ -- | A single @deriving@ clause of a data declaration. -- --- - 'ApiAnnotation.AnnKeywordId' : --- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock', --- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', --- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' +-- - 'GHC.Parser.Annotation.AnnKeywordId' : +-- 'GHC.Parser.Annotation.AnnDeriving', 'GHC.Parser.Annotation.AnnStock', +-- 'GHC.Parser.Annotation.AnnAnyClass', 'Api.AnnNewtype', +-- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' data HsDerivingClause pass - -- See Note [Deriving strategies] in TcDeriv + -- See Note [Deriving strategies] in GHC.Tc.Deriv = HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause pass , deriv_clause_strategy :: Maybe (LDerivStrategy pass) @@ -1249,7 +1328,7 @@ -- -- should produce a derived instance for @C [a] (T b)@. } - | XHsDerivingClause (XXHsDerivingClause pass) + | XHsDerivingClause !(XXHsDerivingClause pass) type instance XCHsDerivingClause (GhcPass _) = NoExtField type instance XXHsDerivingClause (GhcPass _) = NoExtCon @@ -1276,7 +1355,6 @@ case dcs of Just (L _ via@ViaStrategy{}) -> (empty, ppr via) _ -> (ppDerivStrategy dcs, empty) - ppr (XHsDerivingClause x) = ppr x -- | Located Standalone Kind Signature type LStandaloneKindSig pass = Located (StandaloneKindSig pass) @@ -1285,14 +1363,13 @@ = StandaloneKindSig (XStandaloneKindSig pass) (Located (IdP pass)) -- Why a single binder? See #16754 (LHsSigType pass) -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures] - | XStandaloneKindSig (XXStandaloneKindSig pass) + | XStandaloneKindSig !(XXStandaloneKindSig pass) type instance XStandaloneKindSig (GhcPass p) = NoExtField type instance XXStandaloneKindSig (GhcPass p) = NoExtCon standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -standaloneKindSigName (XStandaloneKindSig nec) = noExtCon nec {- Note [Wildcards in standalone kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1322,10 +1399,10 @@ -- | Located data Constructor Declaration type LConDecl pass = Located (ConDecl pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when + -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when -- in a GADT constructor list - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | -- @@ -1343,13 +1420,13 @@ -- Int `MkT` Int :: T Int -- @ -- --- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow', --- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot' +-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', +-- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnCLose', +-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnVbar', +-- 'GHC.Parser.Annotation.AnnDarrow','GHC.Parser.Annotation.AnnDarrow', +-- 'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot' --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | data Constructor Declaration data ConDecl pass @@ -1357,13 +1434,14 @@ { con_g_ext :: XConDeclGADT pass , con_names :: [Located (IdP pass)] - -- The next four fields describe the type after the '::' + -- The following fields describe the type after the '::' -- See Note [GADT abstract syntax] - -- The following field is Located to anchor API Annotations, - -- AnnForall and AnnDot. - , con_forall :: Located Bool -- ^ True <=> explicit forall + , con_forall :: Located Bool -- ^ True <=> explicit forall -- False => hsq_explicit is empty - , con_qvars :: LHsQTyVars pass + -- + -- The 'XRec' is used to anchor API + -- annotations, AnnForall and AnnDot. + , con_qvars :: [LHsTyVarBndr Specificity pass] -- Whether or not there is an /explicit/ forall, we still -- need to capture the implicitly-bound type/kind variables @@ -1384,72 +1462,160 @@ -- e.g. data T a = forall b. MkT b (b->a) -- con_ex_tvs = {b} -- False => con_ex_tvs is empty - , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon + , con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } - | XConDecl (XXConDecl pass) + | XConDecl !(XXConDecl pass) -type instance XConDeclGADT (GhcPass _) = NoExtField +type instance XConDeclGADT GhcPs = NoExtField +type instance XConDeclGADT GhcRn = [Name] -- Implicitly bound type variables +type instance XConDeclGADT GhcTc = NoExtField + type instance XConDeclH98 (GhcPass _) = NoExtField -type instance XXConDecl (GhcPass _) = NoExtCon +type instance XXConDecl (GhcPass _) = NoExtCon + {- Note [GADT abstract syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a wrinkle in ConDeclGADT +The types of both forms of GADT constructors are very structured, as they +must consist of the quantified type variables (if provided), followed by the +context (if provided), followed by the argument types (if provided), followed +by the result type. (See "Wrinkle: No nested foralls or contexts" below for +more discussion on the restrictions imposed here.) As a result, instead of +storing the type of a GADT constructor as a single LHsType, we split it up +into its constituent components for easier access. -* For record syntax, it's all uniform. Given: - data T a where - K :: forall a. Ord a => { x :: [a], ... } -> T a - we make the a ConDeclGADT for K with - con_qvars = {a} - con_mb_cxt = Just [Ord a] - con_args = RecCon - con_res_ty = T a +There are two broad ways to classify GADT constructors: - We need the RecCon before the reanmer, so we can find the record field - binders in GHC.Hs.Utils.hsConDeclsBinders. +* Record-syntax constructors. For example: -* However for a GADT constr declaration which is not a record, it can - be hard parse until we know operator fixities. Consider for example - C :: a :*: b -> a :*: b -> a :+: b - Initially this type will parse as - a :*: (b -> (a :*: (b -> (a :+: b)))) - so it's hard to split up the arguments until we've done the precedence - resolution (in the renamer). + data T a where + K :: forall a. Ord a => { x :: [a], ... } -> T a - So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr - type into the res_ty for a ConDeclGADT for now, and use - PrefixCon [] - con_args = PrefixCon [] - con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) +* Prefix constructors, which do not use record syntax. For example: - - In the renamer (RnSource.rnConDecl), we unravel it afer - operator fixities are sorted. So we generate. So we end - up with - con_args = PrefixCon [ a :*: b, a :*: b ] - con_res_ty = a :+: b + data T a where + K :: forall a. Ord a => [a] -> ... -> T a + +This distinction is recorded in the `con_args :: HsConDetails pass`, which +tracks if we're dealing with a RecCon or PrefixCon. It is easy to distinguish +the two in the AST since record GADT constructors use HsRecTy. This distinction +is made in GHC.Parser.PostProcess.mkGadtDecl. + +It is worth elaborating a bit more on the process of splitting the argument +types of a GADT constructor, since there are some non-obvious details involved. +While splitting the argument types of a record GADT constructor is easy (they +are stored in an HsRecTy), splitting the arguments of a prefix GADT constructor +is trickier. The basic idea is that we must split along the outermost function +arrows ((->) and (%1 ->)) in the type, which GHC.Hs.Type.splitHsFunType +accomplishes. But what about type operators? Consider: + + C :: a :*: b -> a :*: b -> a :+: b + +This could parse in many different ways depending on the precedences of each +type operator. In particular, if (:*:) were to have lower precedence than (->), +then it could very well parse like this: + + a :*: ((b -> a) :*: ((b -> a) :+: b))) + +This would give the false impression that the whole type is part of one large +return type, with no arguments. Note that we do not fully resolve the exact +precedences of each user-defined type operator until the renamer, so this a +more difficult task for the parser. + +Fortunately, there is no risk of the above happening. GHC's parser gives +special treatment to function arrows, and as a result, they are always parsed +with a lower precedence than any other type operator. As a result, the type +above is actually parsed like this: + + (a :*: b) -> ((a :*: b) -> (a :+: b)) + +While we won't know the exact precedences of (:*:) and (:+:) until the renamer, +all we are concerned about in the parser is identifying the overall shape of +the argument and result types, which we can accomplish by piggybacking on the +special treatment given to function arrows. In a future where function arrows +aren't given special status in the parser, we will likely have to modify +GHC.Parser.PostProcess.mergeOps to preserve this trick. + +----- +-- Wrinkle: No nested foralls or contexts +----- + +GADT constructors provide some freedom to change the order of foralls in their +types (see Note [DataCon user type variable binders] in GHC.Core.DataCon), but +this freedom is still limited. GADTs still require that all quantification +occurs "prenex". That is, any explicitly quantified type variables must occur +at the front of the GADT type, followed by any contexts, followed by the body of +the GADT type, in precisely that order. For instance: + + data T where + MkT1 :: forall a b. (Eq a, Eq b) => a -> b -> T + -- OK + MkT2 :: forall a. Eq a => forall b. a -> b -> T + -- Rejected, `forall b` is nested + MkT3 :: forall a b. Eq a => Eq b => a -> b -> T + -- Rejected, `Eq b` is nested + MkT4 :: Int -> forall a. a -> T + -- Rejected, `forall a` is nested + MkT5 :: forall a. Int -> Eq a => a -> T + -- Rejected, `Eq a` is nested + MkT6 :: (forall a. a -> T) + -- Rejected, `forall a` is nested due to the surrounding parentheses + MkT7 :: (Eq a => a -> t) + -- Rejected, `Eq a` is nested due to the surrounding parentheses + +For the full details, see the "Formal syntax for GADTs" section of the GHC +User's Guide. GHC enforces that GADT constructors do not have nested `forall`s +or contexts in two parts: + +1. GHC, in the process of splitting apart a GADT's type, + extracts out the leading `forall` and context (if they are provided). To + accomplish this splitting, the renamer uses the + GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove + parentheses surrounding the leading `forall` or context (as these + parentheses can be syntactically significant). If the third result returned + by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must + be nested, so they will be rejected. + + Note that this step applies to both prefix and record GADTs alike, as they + both have syntax which permits `forall`s and contexts. The difference is + where this step happens: + + * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot + split until after the type operator fixities have been resolved. + * For record GADTs, this happens in the parser (in mkGadtDecl). +2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of + rnConDecl) will then check for nested `forall`s/contexts in the body of a + prefix GADT type, after it has determined what all of the argument types are. + This step is necessary to catch examples like MkT4 above, where the nested + quantification occurs after a visible argument type. -} -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass - = HsConDetails (LBangType pass) (Located [LConDeclField pass]) + = HsConDetails (HsScaled pass (LBangType pass)) (Located [LConDeclField pass]) -getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))] +getConNames :: ConDecl GhcRn -> [Located Name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -getConNames (XConDecl nec) = noExtCon nec -getConArgs :: ConDecl pass -> HsConDeclDetails pass +getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn getConArgs d = con_args d -hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] +hsConDeclArgTys :: HsConDeclDetails pass -> [HsScaled pass (LBangType pass)] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] -hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) +hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds) + -- Remark: with the record syntax, constructors have all their argument + -- linear, despite the fact that projections do not make sense on linear + -- constructors. The design here is that the record projection themselves are + -- typed to take an unrestricted argument (that is the record itself is + -- unrestricted). By the transfer property, projections are then correct in + -- that all the non-projected fields have multiplicity Many, and can be dropped. hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] hsConDeclTheta Nothing = [] @@ -1478,7 +1644,6 @@ Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) -pp_data_defn _ (XHsDataDefn x) = ppr x instance OutputableBndrId p => Outputable (HsDataDefn (GhcPass p)) where @@ -1488,32 +1653,43 @@ => Outputable (StandaloneKindSig (GhcPass p)) where ppr (StandaloneKindSig _ v ki) = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki - ppr (XStandaloneKindSig nec) = noExtCon nec instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (OutputableBndrId p) => [LConDecl (GhcPass p)] -> SDoc -pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax +pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc +pp_condecls cs + | gadt_syntax -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) -pp_condecls cs -- In H98 syntax + | otherwise -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) + where + gadt_syntax = case cs of + [] -> False + (L _ ConDeclH98{} : _) -> False + (L _ ConDeclGADT{} : _) -> True instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl -pprConDecl :: (OutputableBndrId p) => ConDecl (GhcPass p) -> SDoc +pprConDecl :: forall p. OutputableBndrId p => ConDecl (GhcPass p) -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_ex_tvs = ex_tvs , con_mb_cxt = mcxt , con_args = args , con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll ForallInvis ex_tvs cxt, ppr_details args] + = sep [ ppr_mbDoc doc + , pprHsForAll (mkHsForAllInvisTele ex_tvs) cxt + , ppr_details args ] where - ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] + -- In ppr_details: let's not print the multiplicities (they are always 1, by + -- definition) as they do not appear in an actual declaration. + ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1), + pprInfixOcc con, + ppr (hsScaledThing t2)] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con - : map (pprHsType . unLoc) tys) + : map (pprHsType . unLoc . hsScaledThing) tys) ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) cxt = fromMaybe noLHsContext mcxt @@ -1522,7 +1698,7 @@ , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt, + <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt, ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) where get_args (PrefixCon args) = map ppr args @@ -1534,8 +1710,6 @@ ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) ppr_arrow_chain [] = empty -pprConDecl (XConDecl x) = ppr x - ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) @@ -1572,10 +1746,10 @@ -- | Located Type Family Instance Equation type LTyFamInstEqn pass = Located (TyFamInstEqn pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' -- when in a list --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | Haskell Type Patterns type HsTyPats pass = [LHsTypeArg pass] @@ -1631,10 +1805,10 @@ -- | Type Family Instance Declaration newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnInstance', + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', + -- 'GHC.Parser.Annotation.AnnInstance', - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation ----------------- Data family instances ------------- @@ -1645,13 +1819,13 @@ newtype DataFamInstDecl pass = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', - -- 'ApiAnnotation.AnnDcolon' - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData', + -- 'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnInstance', + -- 'GHC.Parser.Annotation.AnnDcolon' + -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation ----------------- Family instances (common types) ------------- @@ -1673,16 +1847,16 @@ = FamEqn { feqn_ext :: XCFamEqn pass rhs , feqn_tycon :: Located (IdP pass) - , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars + , feqn_bndrs :: Maybe [LHsTyVarBndr () pass] -- ^ Optional quantified type vars , feqn_pats :: HsTyPats pass , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' - | XFamEqn (XXFamEqn pass rhs) + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual' + | XFamEqn !(XXFamEqn pass rhs) - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation type instance XCFamEqn (GhcPass _) r = NoExtField type instance XXFamEqn (GhcPass _) r = NoExtCon @@ -1704,18 +1878,18 @@ , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances , cid_overlap_mode :: Maybe (Located OverlapMode) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose', + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose', - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation } -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance', - -- 'ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInstance', + -- 'GHC.Parser.Annotation.AnnWhere', + -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', - -- For details on above see note [Api annotations] in ApiAnnotation - | XClsInstDecl (XXClsInstDecl pass) + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XClsInstDecl !(XXClsInstDecl pass) type instance XCClsInstDecl (GhcPass _) = NoExtField type instance XXClsInstDecl (GhcPass _) = NoExtCon @@ -1736,7 +1910,7 @@ | TyFamInstD -- type family instance { tfid_ext :: XTyFamInstD pass , tfid_inst :: TyFamInstDecl pass } - | XInstDecl (XXInstDecl pass) + | XInstDecl !(XXInstDecl pass) type instance XClsInstD (GhcPass _) = NoExtField type instance XDataFamInstD (GhcPass _) = NoExtField @@ -1768,8 +1942,6 @@ , feqn_fixity = fixity , feqn_rhs = rhs }}) = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs -ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x -ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x instance OutputableBndrId p => Outputable (DataFamInstDecl (GhcPass p)) where @@ -1789,32 +1961,20 @@ <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt -- pp_data_defn pretty-prints the kind sig. See #14817. -pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) - = ppr x -pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) - = ppr x - pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) = ppr nd -pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = XHsDataDefn x}}}) - = ppr x -pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) - = ppr x -pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) - = ppr x pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) - -> Maybe [LHsTyVarBndr (GhcPass p)] + -> Maybe [LHsTyVarBndr () (GhcPass p)] -> HsTyPats (GhcPass p) -> LexicalFixity -> LHsContext (GhcPass p) -> SDoc pprHsFamInstLHS thing bndrs typats fixity mb_ctxt - = hsep [ pprHsExplicitForAll ForallInvis bndrs + = hsep [ pprHsExplicitForAll bndrs , pprLHsContext mb_ctxt , pp_pats typats ] where @@ -1846,7 +2006,6 @@ where top_matter = text "instance" <+> ppOverlapPragma mbOverlap <+> ppr inst_ty - ppr (XClsInstDecl x) = ppr x ppDerivStrategy :: OutputableBndrId p => Maybe (LDerivStrategy (GhcPass p)) -> SDoc @@ -1873,7 +2032,6 @@ ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl - ppr (XInstDecl x) = ppr x -- Extract the declarations of associated data types from an instance @@ -1881,12 +2039,11 @@ instDeclDataFamInsts inst_decls = concatMap do_one inst_decls where + do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)] do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) = map unLoc fam_insts do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] - do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec - do_one (L _ (XInstDecl nec)) = noExtCon nec {- ************************************************************************ @@ -1912,18 +2069,18 @@ -- -- Which signifies that the context should be inferred. - -- See Note [Inferring the instance context] in TcDerivInfer. + -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. , deriv_strategy :: Maybe (LDerivStrategy pass) , deriv_overlap_mode :: Maybe (Located OverlapMode) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', - -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', - -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDeriving', + -- 'GHC.Parser.Annotation.AnnInstance', 'GHC.Parser.Annotation.AnnStock', + -- 'GHC.Parser.Annotation.AnnAnyClass', 'Api.AnnNewtype', + -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation } - | XDerivDecl (XXDerivDecl pass) + | XDerivDecl !(XXDerivDecl pass) type instance XCDerivDecl (GhcPass _) = NoExtField type instance XXDerivDecl (GhcPass _) = NoExtCon @@ -1938,7 +2095,6 @@ , text "instance" , ppOverlapPragma o , ppr ty ] - ppr (XDerivDecl x) = ppr x {- ************************************************************************ @@ -1953,7 +2109,7 @@ -- | Which technique the user explicitly requested when deriving an instance. data DerivStrategy pass - -- See Note [Deriving strategies] in TcDeriv + -- See Note [Deriving strategies] in GHC.Tc.Deriv = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a -- custom instance for the data type. This only works -- for certain types that GHC knows about (e.g., 'Eq', @@ -1973,7 +2129,10 @@ ppr StockStrategy = text "stock" ppr AnyclassStrategy = text "anyclass" ppr NewtypeStrategy = text "newtype" - ppr (ViaStrategy ty) = text "via" <+> ppr ty + ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of + GhcPs -> ppr ty + GhcRn -> ppr ty + GhcTc -> ppr ty -- | A short description of a @DerivStrategy'@. derivStrategyName :: DerivStrategy a -> SDoc @@ -2017,11 +2176,11 @@ -- | Default Declaration data DefaultDecl pass = DefaultDecl (XCDefaultDecl pass) [LHsType pass] - -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnDefault', + -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation - | XDefaultDecl (XXDefaultDecl pass) + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XDefaultDecl !(XXDefaultDecl pass) type instance XCDefaultDecl (GhcPass _) = NoExtField type instance XXDefaultDecl (GhcPass _) = NoExtCon @@ -2030,7 +2189,6 @@ => Outputable (DefaultDecl (GhcPass p)) where ppr (DefaultDecl _ tys) = text "default" <+> parens (interpp'SP tys) - ppr (XDefaultDecl x) = ppr x {- ************************************************************************ @@ -2063,12 +2221,12 @@ , fd_sig_ty :: LHsSigType pass -- sig_ty , fd_fe :: ForeignExport } -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', - -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', - -- 'ApiAnnotation.AnnDcolon' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign', + -- 'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport', + -- 'GHC.Parser.Annotation.AnnDcolon' - -- For details on above see note [Api annotations] in ApiAnnotation - | XForeignDecl (XXForeignDecl pass) + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XForeignDecl !(XXForeignDecl pass) {- In both ForeignImport and ForeignExport: @@ -2142,7 +2300,6 @@ ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) - ppr (XForeignDecl x) = ppr x instance Outputable ForeignImport where ppr (CImport cconv safety mHeader spec (L _ srcText)) = @@ -2179,7 +2336,7 @@ {- ************************************************************************ * * -\subsection{Transformation rules} +\subsection{Rewrite rules} * * ************************************************************************ -} @@ -2187,12 +2344,12 @@ -- | Located Rule Declarations type LRuleDecls pass = Located (RuleDecls pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass , rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } - | XRuleDecls (XXRuleDecls pass) + | XRuleDecls !(XXRuleDecls pass) type instance XCRuleDecls (GhcPass _) = NoExtField type instance XXRuleDecls (GhcPass _) = NoExtCon @@ -2206,9 +2363,9 @@ { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS , rd_name :: Located (SourceText,RuleName) - -- ^ Note [Pragma source text] in BasicTypes + -- ^ Note [Pragma source text] in "GHC.Types.Basic" , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] + , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] -- ^ Forall'd type vars , rd_tmvs :: [LRuleBndr pass] -- ^ Forall'd term vars, before typechecking; after typechecking @@ -2217,13 +2374,13 @@ , rd_rhs :: Located (HsExpr pass) } -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', - -- 'ApiAnnotation.AnnEqual', - | XRuleDecl (XXRuleDecl pass) + -- - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnTilde', + -- 'GHC.Parser.Annotation.AnnVal', + -- 'GHC.Parser.Annotation.AnnClose', + -- 'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot', + -- 'GHC.Parser.Annotation.AnnEqual', + | XRuleDecl !(XXRuleDecl pass) data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS deriving Data @@ -2243,19 +2400,19 @@ -- | Rule Binder data RuleBndr pass = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) - | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass) - | XRuleBndr (XXRuleBndr pass) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass) + | XRuleBndr !(XXRuleBndr pass) -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation type instance XCRuleBndr (GhcPass _) = NoExtField type instance XRuleBndrSig (GhcPass _) = NoExtField type instance XXRuleBndr (GhcPass _) = NoExtCon -collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] +collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc @@ -2266,7 +2423,6 @@ , rds_rules = rules }) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" - ppr (XRuleDecls x) = ppr x instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where ppr (HsRule { rd_name = name @@ -2284,12 +2440,10 @@ pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot pp_forall_tm Nothing | null tms = empty pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot - ppr (XRuleDecl x) = ppr x instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where ppr (RuleBndr _ name) = ppr name ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) - ppr (XRuleBndr x) = ppr x {- ************************************************************************ @@ -2333,13 +2487,13 @@ -- | Located Warning Declarations type LWarnDecls pass = Located (WarnDecls pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass , wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } - | XWarnDecls (XXWarnDecls pass) + | XWarnDecls !(XXWarnDecls pass) type instance XWarnings (GhcPass _) = NoExtField type instance XXWarnDecls (GhcPass _) = NoExtCon @@ -2349,7 +2503,7 @@ -- | Warning pragma Declaration data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt - | XWarnDecl (XXWarnDecl pass) + | XWarnDecl !(XXWarnDecl pass) type instance XWarning (GhcPass _) = NoExtField type instance XXWarnDecl (GhcPass _) = NoExtCon @@ -2360,14 +2514,12 @@ ppr (Warnings _ (SourceText src) decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" - ppr (XWarnDecls x) = ppr x instance OutputableBndr (IdP (GhcPass p)) => Outputable (WarnDecl (GhcPass p)) where ppr (Warning _ thing txt) = hsep ( punctuate comma (map ppr thing)) <+> ppr txt - ppr (XWarnDecl x) = ppr x {- ************************************************************************ @@ -2383,15 +2535,15 @@ -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (AnnProvenance (IdP pass)) (Located (HsExpr pass)) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnType' - -- 'ApiAnnotation.AnnModule' - -- 'ApiAnnotation.AnnClose' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnType' + -- 'GHC.Parser.Annotation.AnnModule' + -- 'GHC.Parser.Annotation.AnnClose' - -- For details on above see note [Api annotations] in ApiAnnotation - | XAnnDecl (XXAnnDecl pass) + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XAnnDecl !(XXAnnDecl pass) type instance XHsAnnotation (GhcPass _) = NoExtField type instance XXAnnDecl (GhcPass _) = NoExtCon @@ -2399,7 +2551,6 @@ instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where ppr (HsAnnotation _ _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] - ppr (XAnnDecl x) = ppr x -- | Annotation Provenance data AnnProvenance name = ValueAnnProvenance (Located name) @@ -2440,11 +2591,11 @@ = RoleAnnotDecl (XCRoleAnnotDecl pass) (Located (IdP pass)) -- type constructor [Located (Maybe Role)] -- optional annotations - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnRole' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', + -- 'GHC.Parser.Annotation.AnnRole' - -- For details on above see note [Api annotations] in ApiAnnotation - | XRoleAnnotDecl (XXRoleAnnotDecl pass) + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XRoleAnnotDecl !(XXRoleAnnotDecl pass) type instance XCRoleAnnotDecl (GhcPass _) = NoExtField type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon @@ -2457,8 +2608,6 @@ where pp_role Nothing = underscore pp_role (Just r) = ppr r - ppr (XRoleAnnotDecl x) = ppr x roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p) roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name -roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec diff --git a/GHC/Hs/Doc.hs b/GHC/Hs/Doc.hs --- a/GHC/Hs/Doc.hs +++ b/GHC/Hs/Doc.hs @@ -7,6 +7,7 @@ , LHsDocString , mkHsDocString , mkHsDocStringUtf8ByteString + , isEmptyDocString , unpackHDS , hsDocStringToByteString , ppr_mbDoc @@ -23,14 +24,14 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Binary -import Encoding -import FastFunctions -import Name -import Outputable -import SrcLoc +import GHC.Utils.Binary +import GHC.Utils.Encoding +import GHC.Utils.IO.Unsafe +import GHC.Types.Name +import GHC.Utils.Outputable as Outputable +import GHC.Types.SrcLoc import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -63,6 +64,9 @@ instance Outputable HsDocString where ppr = doubleQuotes . text . unpackHDS + +isEmptyDocString :: HsDocString -> Bool +isEmptyDocString (HsDocString bs) = BS.null bs mkHsDocString :: String -> HsDocString mkHsDocString s = diff --git a/GHC/Hs/Dump.hs b/GHC/Hs/Dump.hs --- a/GHC/Hs/Dump.hs +++ b/GHC/Hs/Dump.hs @@ -15,21 +15,20 @@ BlankSrcSpan(..), ) where -import GhcPrelude +import GHC.Prelude import Data.Data hiding (Fixity) -import Bag -import BasicTypes -import FastString -import NameSet -import Name -import DataCon -import SrcLoc +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Types.Name.Set +import GHC.Types.Name +import GHC.Core.DataCon +import GHC.Types.SrcLoc import GHC.Hs -import OccName hiding (occName) -import Var -import Module -import Outputable +import GHC.Types.Var +import GHC.Unit.Module +import GHC.Utils.Outputable import qualified Data.ByteString as B @@ -110,7 +109,7 @@ occName n = braces $ text "OccName: " - <> text (OccName.occNameString n) + <> text (occNameString n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName: " <> ppr m diff --git a/GHC/Hs/Expr.hs b/GHC/Hs/Expr.hs --- a/GHC/Hs/Expr.hs +++ b/GHC/Hs/Expr.hs @@ -7,2903 +7,3090 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | Abstract Haskell syntax for expressions. -module GHC.Hs.Expr where - -#include "HsVersions.h" - --- friends: -import GhcPrelude - -import GHC.Hs.Decls -import GHC.Hs.Pat -import GHC.Hs.Lit -import GHC.Hs.PlaceHolder ( NameOrRdrName ) -import GHC.Hs.Extension -import GHC.Hs.Types -import GHC.Hs.Binds - --- others: -import TcEvidence -import CoreSyn -import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) -import Name -import NameSet -import RdrName ( GlobalRdrEnv ) -import BasicTypes -import ConLike -import SrcLoc -import Util -import Outputable -import FastString -import Type -import TysWiredIn (mkTupleStr) -import TcType (TcType) -import {-# SOURCE #-} TcRnTypes (TcLclEnv) - --- libraries: -import Data.Data hiding (Fixity(..)) -import qualified Data.Data as Data (Fixity(..)) -import Data.Maybe (isNothing) - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) - -{- -************************************************************************ -* * -\subsection{Expressions proper} -* * -************************************************************************ --} - --- * Expressions proper - --- | Located Haskell Expression -type LHsExpr p = Located (HsExpr p) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - -------------------------- --- | Post-Type checking Expression --- --- PostTcExpr is an evidence expression attached to the syntax tree by the --- type checker (c.f. postTcType). -type PostTcExpr = HsExpr GhcTc - --- | Post-Type checking Table --- --- We use a PostTcTable where there are a bunch of pieces of evidence, more --- than is convenient to keep individually. -type PostTcTable = [(Name, PostTcExpr)] - -------------------------- --- | Syntax Expression --- --- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, --- by the renamer. It's used for rebindable syntax. --- --- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for --- @(>>=)@, and then instantiated by the type checker with its type args --- etc --- --- This should desugar to --- --- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) --- > (syn_arg_wraps[1] arg1) ... --- --- where the actual arguments come from elsewhere in the AST. --- This could be defined using @GhcPass p@ and such, but it's --- harder to get it all to work out that way. ('noSyntaxExpr' is hard to --- write, for example.) -data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p - , syn_arg_wraps :: [HsWrapper] - , syn_res_wrap :: HsWrapper } - --- | This is used for rebindable-syntax pieces that are too polymorphic --- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: HsExpr (GhcPass p) -noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) - -noSyntaxExpr :: SyntaxExpr (GhcPass p) - -- Before renaming, and sometimes after, - -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField - (HsString NoSourceText - (fsLit "noSyntaxExpr")) - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers. -mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p) -mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the --- renamer), missing its HsWrappers. -mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name - -- don't care about filling in syn_arg_wraps because we're clearly - -- not past the typechecker - -instance OutputableBndrId p - => Outputable (SyntaxExpr (GhcPass p)) where - ppr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = sdocWithDynFlags $ \ dflags -> - getPprStyle $ \s -> - if debugStyle s || gopt Opt_PrintExplicitCoercions dflags - then ppr expr <> braces (pprWithCommas ppr arg_wraps) - <> braces (ppr res_wrap) - else ppr expr - --- | Command Syntax Table (for Arrow syntax) -type CmdSyntaxTable p = [(Name, HsExpr p)] --- See Note [CmdSyntaxTable] - -{- -Note [CmdSyntaxtable] -~~~~~~~~~~~~~~~~~~~~~ -Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps -track of the methods needed for a Cmd. - -* Before the renamer, this list is an empty list - -* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ - For example, for the 'arr' method - * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) - * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) - where @arr_22@ is whatever 'arr' is in scope - -* After the type checker, it takes the form [(std_name, )] - where is the evidence for the method. This evidence is - instantiated with the class, but is still polymorphic in everything - else. For example, in the case of 'arr', the evidence has type - forall b c. (b->c) -> a b c - where 'a' is the ambient type of the arrow. This polymorphism is - important because the desugarer uses the same evidence at multiple - different types. - -This is Less Cool than what we normally do for rebindable syntax, which is to -make fully-instantiated piece of evidence at every use site. The Cmd way -is Less Cool because - * The renamer has to predict which methods are needed. - See the tedious RnExpr.methodNamesCmd. - - * The desugarer has to know the polymorphic type of the instantiated - method. This is checked by Inst.tcSyntaxName, but is less flexible - than the rest of rebindable syntax, where the type is less - pre-ordained. (And this flexibility is useful; for example we can - typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) --} - --- | An unbound variable; used for treating --- out-of-scope variables as expression holes --- --- Either "x", "y" Plain OutOfScope --- or "_", "_x" A TrueExprHole --- --- Both forms indicate an out-of-scope variable, but the latter --- indicates that the user /expects/ it to be out of scope, and --- just wants GHC to report its type -data UnboundVar - = OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope - -- variable, together with the GlobalRdrEnv - -- with respect to which it is unbound - - -- See Note [OutOfScope and GlobalRdrEnv] - - | TrueExprHole OccName -- ^ A "true" expression hole (_ or _x) - - deriving Data - -instance Outputable UnboundVar where - ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ) - ppr (TrueExprHole occ) = text "ExprHole" <> parens (ppr occ) - -unboundVarOcc :: UnboundVar -> OccName -unboundVarOcc (OutOfScope occ _) = occ -unboundVarOcc (TrueExprHole occ) = occ - -{- -Note [OutOfScope and GlobalRdrEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To understand why we bundle a GlobalRdrEnv with an out-of-scope variable, -consider the following module: - - module A where - - foo :: () - foo = bar - - bat :: [Double] - bat = [1.2, 3.4] - - $(return []) - - bar = () - bad = False - -When A is compiled, the renamer determines that `bar` is not in scope in the -declaration of `foo` (since `bar` is declared in the following inter-splice -group). Once it has finished typechecking the entire module, the typechecker -then generates the associated error message, which specifies both the type of -`bar` and a list of possible in-scope alternatives: - - A.hs:6:7: error: - • Variable not in scope: bar :: () - • ‘bar’ (line 13) is not in scope before the splice on line 11 - Perhaps you meant ‘bat’ (line 9) - -When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the -typechecker must provide a GlobalRdrEnv. If it provided the current one, which -contains top-level declarations for the entire module, the error message would -incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives -for `bar` (see #11680). Instead, the typechecker must use the same -GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope. - -To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope -`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to -look it up in some global store? Unfortunately, no. The problem is that -location information is not always sufficient for this task. This is most -apparent when dealing with the TH function addTopDecls, which adds its -declarations to the FOLLOWING inter-splice group. Consider these declarations: - - ex9 = cat -- cat is NOT in scope here - - $(do ------------------------------------------------------------- - ds <- [d| f = cab -- cat and cap are both in scope here - cat = () - |] - addTopDecls ds - [d| g = cab -- only cap is in scope here - cap = True - |]) - - ex10 = cat -- cat is NOT in scope here - - $(return []) ----------------------------------------------------- - - ex11 = cat -- cat is in scope - -Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs -the GlobalRdrEnvs which were used when they were renamed. These GlobalRdrEnvs -are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the -locations of the two `cab`s are the same (they are both created in the same -splice). Thus, we must include some additional information with each `cab` to -allow the typechecker to obtain the correct GlobalRdrEnv. Clearly, the simplest -information to use is the GlobalRdrEnv itself. --} - --- | A Haskell expression. -data HsExpr p - = HsVar (XVar p) - (Located (IdP p)) -- ^ Variable - - -- See Note [Located RdrNames] - - | HsUnboundVar (XUnboundVar p) - UnboundVar -- ^ Unbound variable; also used for "holes" - -- (_ or _x). - -- Turned from HsVar to HsUnboundVar by the - -- renamer, when it finds an out-of-scope - -- variable or hole. - -- Turned into HsVar by type checker, to support - -- deferred type errors. - - | HsConLikeOut (XConLikeOut p) - ConLike -- ^ After typechecker only; must be different - -- HsVar for pretty printing - - | HsRecFld (XRecFld p) - (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector - -- Not in use after typechecking - - | HsOverLabel (XOverLabel p) - (Maybe (IdP p)) FastString - -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) - -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the - -- in-scope 'fromLabel'. - -- NB: Not in use after typechecking - - | HsIPVar (XIPVar p) - HsIPName -- ^ Implicit parameter (not in use after typechecking) - | HsOverLit (XOverLitE p) - (HsOverLit p) -- ^ Overloaded literals - - | HsLit (XLitE p) - (HsLit p) -- ^ Simple (non-overloaded) literals - - | HsLam (XLam p) - (MatchGroup p (LHsExpr p)) - -- ^ Lambda abstraction. Currently always a single match - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application - - | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application - -- - -- Explicit type argument; e.g f @Int x y - -- NB: Has wildcards, but no implicit quantification - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', - - -- | Operator applications: - -- NB Bracketed ops such as (+) come out as Vars. - - -- NB We need an expr for the operator in an OpApp/Section since - -- the typechecker may need to apply the operator to a few types. - - | OpApp (XOpApp p) - (LHsExpr p) -- left operand - (LHsExpr p) -- operator - (LHsExpr p) -- right operand - - -- | Negation operator. Contains the negated expression and the name - -- of 'negate' - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' - - -- For details on above see note [Api annotations] in ApiAnnotation - | NegApp (XNegApp p) - (LHsExpr p) - (SyntaxExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsPar (XPar p) - (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - - | SectionL (XSectionL p) - (LHsExpr p) -- operand; see Note [Sections in HsSyn] - (LHsExpr p) -- operator - | SectionR (XSectionR p) - (LHsExpr p) -- operator; see Note [Sections in HsSyn] - (LHsExpr p) -- operand - - -- | Used for explicit tuples and sections thereof - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - -- Note [ExplicitTuple] - | ExplicitTuple - (XExplicitTuple p) - [LHsTupArg p] - Boxity - - -- | Used for unboxed sum types - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@, - -- - -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before - -- the expression, (arity - alternative) after it - | ExplicitSum - (XExplicitSum p) - ConTag -- Alternative (one-based) - Arity -- Sum arity - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', - -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCase (XCase p) - (LHsExpr p) - (MatchGroup p (LHsExpr p)) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', - -- 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnElse', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (XIf p) - (Maybe (SyntaxExpr p)) -- cond function - -- Nothing => use the built-in 'if' - -- See Note [Rebindable if] - (LHsExpr p) -- predicate - (LHsExpr p) -- then part - (LHsExpr p) -- else part - - -- | Multi-way if - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf' - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] - - -- | let(rec) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', - -- 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (XLet p) - (LHsLocalBinds p) - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', - -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsDo (XDo p) -- Type of the whole expression - (HsStmtContext Name) -- The parameterisation is unimportant - -- because in this context we never use - -- the PatGuard or ParStmt variant - (Located [ExprLStmt p]) -- "do":one or more stmts - - -- | Syntactic list: [a,b,c,...] - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - -- See Note [Empty lists] - | ExplicitList - (XExplicitList p) -- Gives type of components of list - (Maybe (SyntaxExpr p)) - -- For OverloadedLists, the fromListN witness - [LHsExpr p] - - -- | Record construction - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecordCon - { rcon_ext :: XRecordCon p - , rcon_con_name :: Located (IdP p) -- The constructor name; - -- not used after type checking - , rcon_flds :: HsRecordBinds p } -- The fields - - -- | Record update - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecordUpd - { rupd_ext :: XRecordUpd p - , rupd_expr :: LHsExpr p - , rupd_flds :: [LHsRecUpdField p] - } - -- For a type family, the arg types are of the *instance* tycon, - -- not the family tycon - - -- | Expression with an explicit type signature. @e :: type@ - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExprWithTySig - (XExprWithTySig p) - - (LHsExpr p) - (LHsSigWcType (NoGhcTc p)) - - -- | Arithmetic sequence - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | ArithSeq - (XArithSeq p) - (Maybe (SyntaxExpr p)) - -- For OverloadedLists, the fromList witness - (ArithSeqInfo p) - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsSCC (XSCC p) - SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- "set cost centre" SCC pragma - (LHsExpr p) -- expr whose cost is to be measured - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, - -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreAnn (XCoreAnn p) - SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- hdaume: core annotation - (LHsExpr p) - - ----------------------------------------------------------- - -- MetaHaskell Extensions - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ', - -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsBracket (XBracket p) (HsBracket p) - - -- See Note [Pending Splices] - | HsRnBracketOut - (XRnBracketOut p) - (HsBracket GhcRn) -- Output of the renamer is the *original* renamed - -- expression, plus - [PendingRnSplice] -- _renamed_ splices to be type checked - - | HsTcBracketOut - (XTcBracketOut p) - (HsBracket GhcRn) -- Output of the type checker is the *original* - -- renamed expression, plus - [PendingTcSplice] -- _typechecked_ splices to be - -- pasted back in by the desugarer - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceE (XSpliceE p) (HsSplice p) - - ----------------------------------------------------------- - -- Arrow notation extension - - -- | @proc@ notation for Arrows - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc', - -- 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsProc (XProc p) - (LPat p) -- arrow abstraction, proc - (LHsCmdTop p) -- body of the abstraction - -- always has an empty stack - - --------------------------------------- - -- static pointers extension - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (XStatic p) -- Free variables of the body - (LHsExpr p) -- Body - - --------------------------------------- - -- Haskell program coverage (Hpc) Support - - | HsTick - (XTick p) - (Tickish (IdP p)) - (LHsExpr p) -- sub-expression - - | HsBinTick - (XBinTick p) - Int -- module-local tick number for True - Int -- module-local tick number for False - (LHsExpr p) -- sub-expression - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnMinus', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsTickPragma -- A pragma introduced tick - (XTickPragma p) - SourceText -- Note [Pragma source text] in BasicTypes - (StringLiteral,(Int,Int),(Int,Int)) - -- external span for this tick - ((SourceText,SourceText),(SourceText,SourceText)) - -- Source text for the four integers used in the span. - -- See note [Pragma source text] in BasicTypes - (LHsExpr p) - - --------------------------------------- - -- Finally, HsWrap appears only in typechecker output - -- The contained Expr is *NOT* itself an HsWrap. - -- See Note [Detecting forced eta expansion] in DsExpr. This invariant - -- is maintained by GHC.Hs.Utils.mkHsWrap. - - | HsWrap (XWrap p) - HsWrapper -- TRANSLATION - (HsExpr p) - - | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor - - --- | Extra data fields for a 'RecordCon', added by the type checker -data RecordConTc = RecordConTc - { rcon_con_like :: ConLike -- The data constructor or pattern synonym - , rcon_con_expr :: PostTcExpr -- Instantiated constructor function - } - --- | Extra data fields for a 'RecordUpd', added by the type checker -data RecordUpdTc = RecordUpdTc - { rupd_cons :: [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] - } deriving Data - --- --------------------------------------------------------------------- - -type instance XVar (GhcPass _) = NoExtField -type instance XUnboundVar (GhcPass _) = NoExtField -type instance XConLikeOut (GhcPass _) = NoExtField -type instance XRecFld (GhcPass _) = NoExtField -type instance XOverLabel (GhcPass _) = NoExtField -type instance XIPVar (GhcPass _) = NoExtField -type instance XOverLitE (GhcPass _) = NoExtField -type instance XLitE (GhcPass _) = NoExtField -type instance XLam (GhcPass _) = NoExtField -type instance XLamCase (GhcPass _) = NoExtField -type instance XApp (GhcPass _) = NoExtField - -type instance XAppTypeE (GhcPass _) = NoExtField - -type instance XOpApp GhcPs = NoExtField -type instance XOpApp GhcRn = Fixity -type instance XOpApp GhcTc = Fixity - -type instance XNegApp (GhcPass _) = NoExtField -type instance XPar (GhcPass _) = NoExtField -type instance XSectionL (GhcPass _) = NoExtField -type instance XSectionR (GhcPass _) = NoExtField -type instance XExplicitTuple (GhcPass _) = NoExtField - -type instance XExplicitSum GhcPs = NoExtField -type instance XExplicitSum GhcRn = NoExtField -type instance XExplicitSum GhcTc = [Type] - -type instance XCase (GhcPass _) = NoExtField -type instance XIf (GhcPass _) = NoExtField - -type instance XMultiIf GhcPs = NoExtField -type instance XMultiIf GhcRn = NoExtField -type instance XMultiIf GhcTc = Type - -type instance XLet (GhcPass _) = NoExtField - -type instance XDo GhcPs = NoExtField -type instance XDo GhcRn = NoExtField -type instance XDo GhcTc = Type - -type instance XExplicitList GhcPs = NoExtField -type instance XExplicitList GhcRn = NoExtField -type instance XExplicitList GhcTc = Type - -type instance XRecordCon GhcPs = NoExtField -type instance XRecordCon GhcRn = NoExtField -type instance XRecordCon GhcTc = RecordConTc - -type instance XRecordUpd GhcPs = NoExtField -type instance XRecordUpd GhcRn = NoExtField -type instance XRecordUpd GhcTc = RecordUpdTc - -type instance XExprWithTySig (GhcPass _) = NoExtField - -type instance XArithSeq GhcPs = NoExtField -type instance XArithSeq GhcRn = NoExtField -type instance XArithSeq GhcTc = PostTcExpr - -type instance XSCC (GhcPass _) = NoExtField -type instance XCoreAnn (GhcPass _) = NoExtField -type instance XBracket (GhcPass _) = NoExtField - -type instance XRnBracketOut (GhcPass _) = NoExtField -type instance XTcBracketOut (GhcPass _) = NoExtField - -type instance XSpliceE (GhcPass _) = NoExtField -type instance XProc (GhcPass _) = NoExtField - -type instance XStatic GhcPs = NoExtField -type instance XStatic GhcRn = NameSet -type instance XStatic GhcTc = NameSet - -type instance XTick (GhcPass _) = NoExtField -type instance XBinTick (GhcPass _) = NoExtField -type instance XTickPragma (GhcPass _) = NoExtField -type instance XWrap (GhcPass _) = NoExtField -type instance XXExpr (GhcPass _) = NoExtCon - --- --------------------------------------------------------------------- - --- | Located Haskell Tuple Argument --- --- 'HsTupArg' is used for tuple sections --- @(,a,)@ is represented by --- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ --- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ -type LHsTupArg id = Located (HsTupArg id) --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Tuple Argument -data HsTupArg id - = Present (XPresent id) (LHsExpr id) -- ^ The argument - | Missing (XMissing id) -- ^ The argument is missing, but this is its type - | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point - -type instance XPresent (GhcPass _) = NoExtField - -type instance XMissing GhcPs = NoExtField -type instance XMissing GhcRn = NoExtField -type instance XMissing GhcTc = Type - -type instance XXTupArg (GhcPass _) = NoExtCon - -tupArgPresent :: LHsTupArg id -> Bool -tupArgPresent (L _ (Present {})) = True -tupArgPresent (L _ (Missing {})) = False -tupArgPresent (L _ (XTupArg {})) = False - -{- -Note [Parens in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~ -HsPar (and ParPat in patterns, HsParTy in types) is used as follows - - * HsPar is required; the pretty printer does not add parens. - - * HsPars are respected when rearranging operator fixities. - So a * (b + c) means what it says (where the parens are an HsPar) - - * For ParPat and HsParTy the pretty printer does add parens but this should be - a no-op for ParsedSource, based on the pretty printer round trip feature - introduced in - https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c - - * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or - not they are strictly necessary. This should be addressed when #13238 is - completed, to be treated the same as HsPar. - - -Note [Sections in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~~~ -Sections should always appear wrapped in an HsPar, thus - HsPar (SectionR ...) -The parser parses sections in a wider variety of situations -(See Note [Parsing sections]), but the renamer checks for those -parens. This invariant makes pretty-printing easier; we don't need -a special case for adding the parens round sections. - -Note [Rebindable if] -~~~~~~~~~~~~~~~~~~~~ -The rebindable syntax for 'if' is a bit special, because when -rebindable syntax is *off* we do not want to treat - (if c then t else e) -as if it was an application (ifThenElse c t e). Why not? -Because we allow an 'if' to return *unboxed* results, thus - if blah then 3# else 4# -whereas that would not be possible using a all to a polymorphic function -(because you can't call a polymorphic function at an unboxed type). - -So we use Nothing to mean "use the old built-in typing rule". - -Note [Record Update HsWrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a wrapper in RecordUpd which is used for the *required* -constraints for pattern synonyms. This wrapper is created in the -typechecking and is then directly used in the desugaring without -modification. - -For example, if we have the record pattern synonym P, - pattern P :: (Show a) => a -> Maybe a - pattern P{x} = Just x - - foo = (Just True) { x = False } -then `foo` desugars to something like - foo = case Just True of - P x -> P False -hence we need to provide the correct dictionaries to P's matcher on -the RHS so that we can build the expression. - -Note [Located RdrNames] -~~~~~~~~~~~~~~~~~~~~~~~ -A number of syntax elements have seemingly redundant locations attached to them. -This is deliberate, to allow transformations making use of the API Annotations -to easily correlate a Located Name in the RenamedSource with a Located RdrName -in the ParsedSource. - -There are unfortunately enough differences between the ParsedSource and the -RenamedSource that the API Annotations cannot be used directly with -RenamedSource, so this allows a simple mapping to be used based on the location. - -Note [ExplicitTuple] -~~~~~~~~~~~~~~~~~~~~ -An ExplicitTuple is never just a data constructor like (,,,). -That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least -one `Present` member (and is thus never empty). - -A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an -`ExplicitTuple`, and stays that way. This is important for two reasons: - - 1. We don't need -XTupleSections for (,,,) - 2. The type variables in (,,,) can be instantiated with visible type application. - That is, - - (,,) :: forall a b c. a -> b -> c -> (a,b,c) - (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c) - - Note that the tuple section has *inferred* arguments, while the data - constructor has *specified* ones. - (See Note [Required, Specified, and Inferred for types] in TcTyClsDecls - for background.) - -Sadly, the grammar for this is actually ambiguous, and it's only thanks to the -preference of a shift in a shift/reduce conflict that the parser works as this -Note details. Search for a reference to this Note in Parser.y for further -explanation. - -Note [Empty lists] -~~~~~~~~~~~~~~~~~~ -An empty list could be considered either a data constructor (stored with -HsVar) or an ExplicitList. This Note describes how empty lists flow through the -various phases and why. - -Parsing -------- -An empty list is parsed by the sysdcon nonterminal. It thus comes to life via -HsVar nilDataCon (defined in TysWiredIn). A freshly-parsed (HsExpr GhcPs) empty list -is never a ExplicitList. - -Renaming --------- -If -XOverloadedLists is enabled, we must type-check the empty list as if it -were a call to fromListN. (This is true regardless of the setting of --XRebindableSyntax.) This is very easy if the empty list is an ExplicitList, -but an annoying special case if it's an HsVar. So the renamer changes a -HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on. -(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr. - -Type-checking -------------- -We want to accept an expression like [] @Int. To do this, we must infer that -[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside. -However, the type-checking for explicit lists works differently: [x,y,z] is never -polymorphic. Instead, we unify the types of x, y, and z together, and use the -unified type as the argument to the cons and nil constructors. Thus, treating -[] as an empty ExplicitList in the type-checker would prevent [] @Int from working. - -However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed: -it's just like fromListN 0 [] @Int. Since - fromListN :: forall list. IsList list => Int -> [Item list] -> list -that expression really should be rejected. Thus, the renamer's behaviour is -exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as -an empty ExplicitList when -XOverloadedLists. - -See also #13680, which requested [] @Int to work. --} - -instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where - ppr expr = pprExpr expr - ------------------------ --- pprExpr, pprLExpr, pprBinds call pprDeeper; --- the underscore versions do not -pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc -pprLExpr (L _ e) = pprExpr e - -pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e - | otherwise = pprDeeper (ppr_expr e) - -isQuietHsExpr :: HsExpr id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsExpr (HsPar {}) = True --- applications don't display anything themselves -isQuietHsExpr (HsApp {}) = True -isQuietHsExpr (HsAppType {}) = True -isQuietHsExpr (OpApp {}) = True -isQuietHsExpr _ = False - -pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) - => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc -pprBinds b = pprDeeper (ppr b) - ------------------------ -ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc -ppr_lexpr e = ppr_expr (unLoc e) - -ppr_expr :: forall p. (OutputableBndrId p) - => HsExpr (GhcPass p) -> SDoc -ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v -ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) -ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c -ppr_expr (HsIPVar _ v) = ppr v -ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l -ppr_expr (HsLit _ lit) = ppr lit -ppr_expr (HsOverLit _ lit) = ppr lit -ppr_expr (HsPar _ e) = parens (ppr_lexpr e) - -ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) - = vcat [pprWithSourceText stc (text "{-# CORE") - <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" - , ppr_lexpr e] - -ppr_expr e@(HsApp {}) = ppr_apps e [] -ppr_expr e@(HsAppType {}) = ppr_apps e [] - -ppr_expr (OpApp _ e1 op e2) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - - where - pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens - pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear - - pp_prefixly - = hang (ppr op) 2 (sep [pp_e1, pp_e2]) - - pp_infixly pp_op - = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) - -ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e - -ppr_expr (SectionL _ expr op) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - where - pp_expr = pprDebugParendExpr opPrec expr - - pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) - 4 (hsep [pp_expr, text "x_ )"]) - - pp_infixly v = (sep [pp_expr, v]) - -ppr_expr (SectionR _ op expr) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - where - pp_expr = pprDebugParendExpr opPrec expr - - pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) - 4 (pp_expr <> rparen) - - pp_infixly v = sep [v, pp_expr] - -ppr_expr (ExplicitTuple _ exprs boxity) - -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Unit x`, not `(x)` - | [dL -> L _ (Present _ expr)] <- exprs - , Boxed <- boxity - = hsep [text (mkTupleStr Boxed 1), ppr expr] - | otherwise - = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) - where - ppr_tup_args [] = [] - ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es - ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es - ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es - - punc (Present {} : _) = comma <> space - punc (Missing {} : _) = comma - punc (XTupArg {} : _) = comma <> space - punc [] = empty - -ppr_expr (ExplicitSum _ alt arity expr) - = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" - where - ppr_bars n = hsep (replicate n (char '|')) - -ppr_expr (HsLam _ matches) - = pprMatches matches - -ppr_expr (HsLamCase _ matches) - = sep [ sep [text "\\case"], - nest 2 (pprMatches matches) ] - -ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches matches) <+> char '}'] -ppr_expr (HsCase _ expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], - nest 2 (pprMatches matches) ] - -ppr_expr (HsIf _ _ e1 e2 e3) - = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], - nest 4 (ppr e2), - text "else", - nest 4 (ppr e3)] - -ppr_expr (HsMultiIf _ alts) - = hang (text "if") 3 (vcat (map ppr_alt alts)) - where ppr_alt (L _ (GRHS _ guards expr)) = - hang vbar 2 (ppr_one one_alt) - where - ppr_one [] = panic "ppr_exp HsMultiIf" - ppr_one (h:t) = hang h 2 (sep t) - one_alt = [ interpp'SP guards - , text "->" <+> pprDeeper (ppr expr) ] - ppr_alt (L _ (XGRHS x)) = ppr x - --- special case: let ... in let ... -ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), - ppr_lexpr expr] - -ppr_expr (HsLet _ (L _ binds) expr) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr expr)] - -ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts - -ppr_expr (ExplicitList _ _ exprs) - = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) - -ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) - = hang (ppr con_id) 2 (ppr rbinds) - -ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) - = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) - -ppr_expr (ExprWithTySig _ expr sig) - = hang (nest 2 (ppr_lexpr expr) <+> dcolon) - 4 (ppr sig) - -ppr_expr (ArithSeq _ _ info) = brackets (ppr info) - -ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) - = sep [ pprWithSourceText st (text "{-# SCC") - -- no doublequotes if stl empty, for the case where the SCC was written - -- without quotes. - <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", - ppr expr ] - -ppr_expr (HsWrap _ co_fn e) - = pprHsWrapper co_fn (\parens -> if parens then pprExpr e - else pprExpr e) - -ppr_expr (HsSpliceE _ s) = pprSplice s -ppr_expr (HsBracket _ b) = pprHsBracket b -ppr_expr (HsRnBracketOut _ e []) = ppr e -ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps -ppr_expr (HsTcBracketOut _ e []) = ppr e -ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps - -ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) - = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] -ppr_expr (HsProc _ pat (L _ (XCmdTop x))) - = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x] - -ppr_expr (HsStatic _ e) - = hsep [text "static", ppr e] - -ppr_expr (HsTick _ tickish exp) - = pprTicks (ppr exp) $ - ppr tickish <+> ppr_lexpr exp -ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) - = pprTicks (ppr exp) $ - hcat [text "bintick<", - ppr tickIdTrue, - text ",", - ppr tickIdFalse, - text ">(", - ppr exp, text ")"] -ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) - = pprTicks (ppr exp) $ - hcat [text "tickpragma<", - pprExternalSrcLoc externalSrcLoc, - text ">(", - ppr exp, - text ")"] - -ppr_expr (HsRecFld _ f) = ppr f -ppr_expr (XExpr x) = ppr x - -ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc -ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) -ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) -ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) -ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) -ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e -ppr_infix_expr _ = Nothing - -ppr_apps :: (OutputableBndrId p) - => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] - -> SDoc -ppr_apps (HsApp _ (L _ fun) arg) args - = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) arg) args - = ppr_apps fun (Right arg : args) -ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) - where - pp (Left arg) = ppr arg - -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - -- = char '@' <> pprHsType arg - pp (Right arg) - = char '@' <> ppr arg - -pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) - = ppr (src,(n1,n2),(n3,n4)) - -{- -HsSyn records exactly where the user put parens, with HsPar. -So generally speaking we print without adding any parens. -However, some code is internally generated, and in some places -parens are absolutely required; so for these places we use -pprParendLExpr (but don't print double parens of course). - -For operator applications we don't add parens, because the operator -fixities should do the job, except in debug mode (-dppr-debug) so we -can see the structure of the parse tree. --} - -pprDebugParendExpr :: (OutputableBndrId p) - => PprPrec -> LHsExpr (GhcPass p) -> SDoc -pprDebugParendExpr p expr - = getPprStyle (\sty -> - if debugStyle sty then pprParendLExpr p expr - else pprLExpr expr) - -pprParendLExpr :: (OutputableBndrId p) - => PprPrec -> LHsExpr (GhcPass p) -> SDoc -pprParendLExpr p (L _ e) = pprParendExpr p e - -pprParendExpr :: (OutputableBndrId p) - => PprPrec -> HsExpr (GhcPass p) -> SDoc -pprParendExpr p expr - | hsExprNeedsParens p expr = parens (pprExpr expr) - | otherwise = pprExpr expr - -- Using pprLExpr makes sure that we go 'deeper' - -- I think that is usually (always?) right - --- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs --- parentheses under precedence @p@. -hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool -hsExprNeedsParens p = go - where - go (HsVar{}) = False - go (HsUnboundVar{}) = False - go (HsConLikeOut{}) = False - go (HsIPVar{}) = False - go (HsOverLabel{}) = False - go (HsLit _ l) = hsLitNeedsParens p l - go (HsOverLit _ ol) = hsOverLitNeedsParens p ol - go (HsPar{}) = False - go (HsCoreAnn _ _ _ (L _ e)) = go e - go (HsApp{}) = p >= appPrec - go (HsAppType {}) = p >= appPrec - go (OpApp{}) = p >= opPrec - go (NegApp{}) = p > topPrec - go (SectionL{}) = True - go (SectionR{}) = True - go (ExplicitTuple{}) = False - go (ExplicitSum{}) = False - go (HsLam{}) = p > topPrec - go (HsLamCase{}) = p > topPrec - go (HsCase{}) = p > topPrec - go (HsIf{}) = p > topPrec - go (HsMultiIf{}) = p > topPrec - go (HsLet{}) = p > topPrec - go (HsDo _ sc _) - | isComprehensionContext sc = False - | otherwise = p > topPrec - go (ExplicitList{}) = False - go (RecordUpd{}) = False - go (ExprWithTySig{}) = p >= sigPrec - go (ArithSeq{}) = False - go (HsSCC{}) = p >= appPrec - go (HsWrap _ _ e) = go e - go (HsSpliceE{}) = False - go (HsBracket{}) = False - go (HsRnBracketOut{}) = False - go (HsTcBracketOut{}) = False - go (HsProc{}) = p > topPrec - go (HsStatic{}) = p >= appPrec - go (HsTick _ _ (L _ e)) = go e - go (HsBinTick _ _ _ (L _ e)) = go e - go (HsTickPragma _ _ _ _ (L _ e)) = go e - go (RecordCon{}) = False - go (HsRecFld{}) = False - go (XExpr{}) = True - --- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, --- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. -parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -parenthesizeHsExpr p le@(L loc e) - | hsExprNeedsParens p e = L loc (HsPar noExtField le) - | otherwise = le - -isAtomicHsExpr :: HsExpr id -> Bool --- True of a single token -isAtomicHsExpr (HsVar {}) = True -isAtomicHsExpr (HsConLikeOut {}) = True -isAtomicHsExpr (HsLit {}) = True -isAtomicHsExpr (HsOverLit {}) = True -isAtomicHsExpr (HsIPVar {}) = True -isAtomicHsExpr (HsOverLabel {}) = True -isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e -isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) -isAtomicHsExpr (HsRecFld{}) = True -isAtomicHsExpr _ = False - -{- -************************************************************************ -* * -\subsection{Commands (in arrow abstractions)} -* * -************************************************************************ - -We re-use HsExpr to represent these. --} - --- | Located Haskell Command (for arrow syntax) -type LHsCmd id = Located (HsCmd id) - --- | Haskell Command (e.g. a "statement" in an Arrow proc block) -data HsCmd id - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', - -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', - -- 'ApiAnnotation.AnnRarrowtail' - - -- For details on above see note [Api annotations] in ApiAnnotation - = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) - (XCmdArrApp id) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t - (LHsExpr id) -- arrow expression, f - (LHsExpr id) -- input expression, arg - HsArrAppType -- higher-order (-<<) or first-order (-<) - Bool -- True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, - -- 'ApiAnnotation.AnnCloseB' @'|)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) - (XCmdArrForm id) - (LHsExpr id) -- The operator. - -- After type-checking, a type abstraction to be - -- applied to the type of the local environment tuple - LexicalFixity -- Whether the operator appeared prefix or infix when - -- parsed. - (Maybe Fixity) -- fixity (filled in by the renamer), for forms that - -- were converted from OpApp's by the renamer - [LHsCmdTop id] -- argument commands - - | HsCmdApp (XCmdApp id) - (LHsCmd id) - (LHsExpr id) - - | HsCmdLam (XCmdLam id) - (MatchGroup id (LHsCmd id)) -- kappa - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdPar (XCmdPar id) - (LHsCmd id) -- parenthesised command - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdCase (XCmdCase id) - (LHsExpr id) - (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', - -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdIf (XCmdIf id) - (Maybe (SyntaxExpr id)) -- cond function - (LHsExpr id) -- predicate - (LHsCmd id) -- then part - (LHsCmd id) -- else part - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', - -- 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnElse', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdLet (XCmdLet id) - (LHsLocalBinds id) -- let(rec) - (LHsCmd id) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', - -- 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdDo (XCmdDo id) -- Type of the whole expression - (Located [CmdLStmt id]) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', - -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdWrap (XCmdWrap id) - HsWrapper - (HsCmd id) -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (HsCmdWrap wrap cmd) :: arg2 --> res - | XCmd (XXCmd id) -- Note [Trees that Grow] extension point - -type instance XCmdArrApp GhcPs = NoExtField -type instance XCmdArrApp GhcRn = NoExtField -type instance XCmdArrApp GhcTc = Type - -type instance XCmdArrForm (GhcPass _) = NoExtField -type instance XCmdApp (GhcPass _) = NoExtField -type instance XCmdLam (GhcPass _) = NoExtField -type instance XCmdPar (GhcPass _) = NoExtField -type instance XCmdCase (GhcPass _) = NoExtField -type instance XCmdIf (GhcPass _) = NoExtField -type instance XCmdLet (GhcPass _) = NoExtField - -type instance XCmdDo GhcPs = NoExtField -type instance XCmdDo GhcRn = NoExtField -type instance XCmdDo GhcTc = Type - -type instance XCmdWrap (GhcPass _) = NoExtField -type instance XXCmd (GhcPass _) = NoExtCon - --- | Haskell Array Application Type -data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp - deriving Data - - -{- | Top-level command, introducing a new arrow. -This may occur inside a proc (where the stack is empty) or as an -argument of a command-forming operator. --} - --- | Located Haskell Top-level Command -type LHsCmdTop p = Located (HsCmdTop p) - --- | Haskell Top-level Command -data HsCmdTop p - = HsCmdTop (XCmdTop p) - (LHsCmd p) - | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point - -data CmdTopTc - = CmdTopTc Type -- Nested tuple of inputs on the command's stack - Type -- return type of the command - (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] - -type instance XCmdTop GhcPs = NoExtField -type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] -type instance XCmdTop GhcTc = CmdTopTc - -type instance XXCmdTop (GhcPass _) = NoExtCon - -instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where - ppr cmd = pprCmd cmd - ------------------------ --- pprCmd and pprLCmd call pprDeeper; --- the underscore versions do not -pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc -pprLCmd (L _ c) = pprCmd c - -pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc -pprCmd c | isQuietHsCmd c = ppr_cmd c - | otherwise = pprDeeper (ppr_cmd c) - -isQuietHsCmd :: HsCmd id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsCmd (HsCmdPar {}) = True --- applications don't display anything themselves -isQuietHsCmd (HsCmdApp {}) = True -isQuietHsCmd _ = False - ------------------------ -ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc -ppr_lcmd c = ppr_cmd (unLoc c) - -ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc -ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) - -ppr_cmd (HsCmdApp _ c e) - = let (fun, args) = collect_args c [e] in - hang (ppr_lcmd fun) 2 (sep (map ppr args)) - where - collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) - -ppr_cmd (HsCmdLam _ matches) - = pprMatches matches - -ppr_cmd (HsCmdCase _ expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], - nest 2 (pprMatches matches) ] - -ppr_cmd (HsCmdIf _ _ e ct ce) - = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], - nest 4 (ppr ct), - text "else", - nest 4 (ppr ce)] - --- special case: let ... in let ... -ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), - ppr_lcmd cmd] - -ppr_cmd (HsCmdLet _ (L _ binds) cmd) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr cmd)] - -ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts - -ppr_cmd (HsCmdWrap _ w cmd) - = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) -ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) - = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) - = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) - = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) - = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] - -ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ op _ _ args) - = hang (text "(|" <+> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_cmd (XCmd x) = ppr x - -pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc -pprCmdArg (HsCmdTop _ cmd) - = ppr_lcmd cmd -pprCmdArg (XCmdTop x) = ppr x - -instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where - ppr = pprCmdArg - -{- -************************************************************************ -* * -\subsection{Record binds} -* * -************************************************************************ --} - --- | Haskell Record Bindings -type HsRecordBinds p = HsRecFields p (LHsExpr p) - -{- -************************************************************************ -* * -\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} -* * -************************************************************************ - -@Match@es are sets of pattern bindings and right hand sides for -functions, patterns or case branches. For example, if a function @g@ -is defined as: -\begin{verbatim} -g (x,y) = y -g ((x:ys),y) = y+1, -\end{verbatim} -then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. - -It is always the case that each element of an @[Match]@ list has the -same number of @pats@s inside it. This corresponds to saying that -a function defined by pattern matching must have the same number of -patterns in each equation. --} - -data MatchGroup p body - = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result - , mg_alts :: Located [LMatch p body] -- The alternatives - , mg_origin :: Origin } - -- The type is the type of the entire group - -- t1 -> ... -> tn -> tr - -- where there are n patterns - | XMatchGroup (XXMatchGroup p body) - -data MatchGroupTc - = MatchGroupTc - { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn - , mg_res_ty :: Type -- Type of the result, tr - } deriving Data - -type instance XMG GhcPs b = NoExtField -type instance XMG GhcRn b = NoExtField -type instance XMG GhcTc b = MatchGroupTc - -type instance XXMatchGroup (GhcPass _) b = NoExtCon - --- | Located Match -type LMatch id body = Located (Match id body) --- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a --- list - --- For details on above see note [Api annotations] in ApiAnnotation -data Match p body - = Match { - m_ext :: XCMatch p body, - m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), - -- See note [m_ctxt in Match] - m_pats :: [LPat p], -- The patterns - m_grhss :: (GRHSs p body) - } - | XMatch (XXMatch p body) - -type instance XCMatch (GhcPass _) b = NoExtField -type instance XXMatch (GhcPass _) b = NoExtCon - -instance (OutputableBndrId pr, Outputable body) - => Outputable (Match (GhcPass pr) body) where - ppr = pprMatch - -{- -Note [m_ctxt in Match] -~~~~~~~~~~~~~~~~~~~~~~ - -A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and -so on. - -In order to simplify tooling processing and pretty print output, the provenance -is captured in an HsMatchContext. - -This is particularly important for the API Annotations for a multi-equation -FunBind. - -The parser initially creates a FunBind with a single Match in it for -every function definition it sees. - -These are then grouped together by getMonoBind into a single FunBind, -where all the Matches are combined. - -In the process, all the original FunBind fun_id's bar one are -discarded, including the locations. - -This causes a problem for source to source conversions via API -Annotations, so the original fun_ids and infix flags are preserved in -the Match, when it originates from a FunBind. - -Example infix function definition requiring individual API Annotations - - (&&& ) [] [] = [] - xs &&& [] = xs - ( &&& ) [] ys = ys - - - --} - - -isInfixMatch :: Match id body -> Bool -isInfixMatch match = case m_ctxt match of - FunRhs {mc_fixity = Infix} -> True - _ -> False - -isEmptyMatchGroup :: MatchGroup id body -> Bool -isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms -isEmptyMatchGroup (XMatchGroup {}) = False - --- | Is there only one RHS in this list of matches? -isSingletonMatchGroup :: [LMatch id body] -> Bool -isSingletonMatchGroup matches - | [L _ match] <- matches - , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match - = True - | otherwise - = False - -matchGroupArity :: MatchGroup (GhcPass id) body -> Arity --- Precondition: MatchGroup is non-empty --- This is called before type checking, when mg_arg_tys is not set -matchGroupArity (MG { mg_alts = alts }) - | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) - | otherwise = panic "matchGroupArity" -matchGroupArity (XMatchGroup nec) = noExtCon nec - -hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] -hsLMatchPats (L _ (Match { m_pats = pats })) = pats -hsLMatchPats (L _ (XMatch nec)) = noExtCon nec - --- | Guarded Right-Hand Sides --- --- GRHSs are used both for pattern bindings and for Matches --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', --- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' --- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' - --- For details on above see note [Api annotations] in ApiAnnotation -data GRHSs p body - = GRHSs { - grhssExt :: XCGRHSs p body, - grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs - grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause - } - | XGRHSs (XXGRHSs p body) - -type instance XCGRHSs (GhcPass _) b = NoExtField -type instance XXGRHSs (GhcPass _) b = NoExtCon - --- | Located Guarded Right-Hand Side -type LGRHS id body = Located (GRHS id body) - --- | Guarded Right Hand Side. -data GRHS p body = GRHS (XCGRHS p body) - [GuardLStmt p] -- Guards - body -- Right hand side - | XGRHS (XXGRHS p body) - -type instance XCGRHS (GhcPass _) b = NoExtField -type instance XXGRHS (GhcPass _) b = NoExtCon - --- We know the list must have at least one @Match@ in it. - -pprMatches :: (OutputableBndrId idR, Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc -pprMatches MG { mg_alts = matches } - = vcat (map pprMatch (map unLoc (unLoc matches))) - -- Don't print the type; it's only a place-holder before typechecking -pprMatches (XMatchGroup x) = ppr x - --- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId idR, Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc -pprFunBind matches = pprMatches matches - --- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p body. (OutputableBndrId bndr, - OutputableBndrId p, - Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc -pprPatBind pat (grhss) - = sep [ppr pat, - nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] - -pprMatch :: (OutputableBndrId idR, Outputable body) - => Match (GhcPass idR) body -> SDoc -pprMatch match - = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) - , nest 2 (pprGRHSs ctxt (m_grhss match)) ] - where - ctxt = m_ctxt match - (herald, other_pats) - = case ctxt of - FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} - | strictness == SrcStrict -> ASSERT(null $ m_pats match) - (char '!'<>pprPrefixOcc fun, m_pats match) - -- a strict variable binding - | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) - -- f x y z = e - -- Not pprBndr; the AbsBinds will - -- have printed the signature - - | null pats2 -> (pp_infix, []) - -- x &&& y = e - - | otherwise -> (parens pp_infix, pats2) - -- (x &&& y) z = e - where - pp_infix = pprParendLPat opPrec pat1 - <+> pprInfixOcc fun - <+> pprParendLPat opPrec pat2 - - LambdaExpr -> (char '\\', m_pats match) - - _ -> if null (m_pats match) - then (empty, []) - else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) - (ppr pat1, []) -- No parens around the single pat - - (pat1:pats1) = m_pats match - (pat2:pats2) = pats1 - -pprGRHSs :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc -pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) - = vcat (map (pprGRHS ctxt . unLoc) grhss) - -- Print the "where" even if the contents of the binds is empty. Only - -- EmptyLocalBinds means no "where" keyword - $$ ppUnless (eqEmptyLocalBinds binds) - (text "where" $$ nest 4 (pprBinds binds)) -pprGRHSs _ (XGRHSs x) = ppr x - -pprGRHS :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc -pprGRHS ctxt (GRHS _ [] body) - = pp_rhs ctxt body - -pprGRHS ctxt (GRHS _ guards body) - = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] - -pprGRHS _ (XGRHS x) = ppr x - -pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc -pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) - -{- -************************************************************************ -* * -\subsection{Do stmts and list comprehensions} -* * -************************************************************************ --} - --- | Located @do@ block Statement -type LStmt id body = Located (StmtLR id id body) - --- | Located Statement with separate Left and Right id's -type LStmtLR idL idR body = Located (StmtLR idL idR body) - --- | @do@ block Statement -type Stmt id body = StmtLR id id body - --- | Command Located Statement -type CmdLStmt id = LStmt id (LHsCmd id) - --- | Command Statement -type CmdStmt id = Stmt id (LHsCmd id) - --- | Expression Located Statement -type ExprLStmt id = LStmt id (LHsExpr id) - --- | Expression Statement -type ExprStmt id = Stmt id (LHsExpr id) - --- | Guard Located Statement -type GuardLStmt id = LStmt id (LHsExpr id) - --- | Guard Statement -type GuardStmt id = Stmt id (LHsExpr id) - --- | Ghci Located Statement -type GhciLStmt id = LStmt id (LHsExpr id) - --- | Ghci Statement -type GhciStmt id = Stmt id (LHsExpr id) - --- The SyntaxExprs in here are used *only* for do-notation and monad --- comprehensions, which have rebindable syntax. Otherwise they are unused. --- | API Annotations when in qualifier lists or guards --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen', --- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy', --- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing' - --- For details on above see note [Api annotations] in ApiAnnotation -data StmtLR idL idR body -- body should always be (LHs**** idR) - = LastStmt -- Always the last Stmt in ListComp, MonadComp, - -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr - -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff - (XLastStmt idL idR body) - body - Bool -- True <=> return was stripped by ApplicativeDo - (SyntaxExpr idR) -- The return operator - -- The return operator is used only for MonadComp - -- For ListComp we use the baked-in 'return' - -- For DoExpr, MDoExpr, we don't apply a 'return' at all - -- See Note [Monad Comprehensions] - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | BindStmt (XBindStmt idL idR body) -- Post typechecking, - -- result type of the function passed to bind; - -- that is, S in (>>=) :: Q -> (R -> S) -> T - (LPat idL) - body - (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts] - (SyntaxExpr idR) -- The fail operator - -- The fail operator is noSyntaxExpr - -- if the pattern match can't fail - - -- | 'ApplicativeStmt' represents an applicative expression built with - -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the - -- appropriate applicative expression by the desugarer, but it is intended - -- to be invisible in error messages. - -- - -- For full details, see Note [ApplicativeDo] in RnExpr - -- - | ApplicativeStmt - (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body - [ ( SyntaxExpr idR - , ApplicativeArg idL) ] - -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] - (Maybe (SyntaxExpr idR)) -- 'join', if necessary - - | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type - -- of the RHS (used for arrows) - body -- See Note [BodyStmt] - (SyntaxExpr idR) -- The (>>) operator - (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp - -- See notes [Monad Comprehensions] - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' - -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, - - -- For details on above see note [Api annotations] in ApiAnnotation - | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) - - -- ParStmts only occur in a list/monad comprehension - | ParStmt (XParStmt idL idR body) -- Post typecheck, - -- S in (>>=) :: Q -> (R -> S) -> T - [ParStmtBlock idL idR] - (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions - (SyntaxExpr idR) -- The `>>=` operator - -- See notes [Monad Comprehensions] - -- After renaming, the ids are the binders - -- bound by the stmts and used after themp - - | TransStmt { - trS_ext :: XTransStmt idL idR body, -- Post typecheck, - -- R in (>>=) :: Q -> (R -> S) -> T - trS_form :: TransForm, - trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' - -- which generates the tuples to be grouped - - trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] - - trS_using :: LHsExpr idR, - trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) - -- Invariant: if trS_form = GroupBy, then grp_by = Just e - - trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for - -- the inner monad comprehensions - trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator - trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring - -- Only for 'group' forms - -- Just a simple HsExpr, because it's - -- too polymorphic for tcSyntaxOp - } -- See Note [Monad Comprehensions] - - -- Recursive statement (see Note [How RecStmt works] below) - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec' - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecStmt - { recS_ext :: XRecStmt idL idR body - , recS_stmts :: [LStmtLR idL idR body] - - -- The next two fields are only valid after renaming - , recS_later_ids :: [IdP idR] - -- The ids are a subset of the variables bound by the - -- stmts that are used in stmts that follow the RecStmt - - , recS_rec_ids :: [IdP idR] - -- Ditto, but these variables are the "recursive" ones, - -- that are used before they are bound in the stmts of - -- the RecStmt. - -- An Id can be in both groups - -- Both sets of Ids are (now) treated monomorphically - -- See Note [How RecStmt works] for why they are separate - - -- Rebindable syntax - , recS_bind_fn :: SyntaxExpr idR -- The bind function - , recS_ret_fn :: SyntaxExpr idR -- The return function - , recS_mfix_fn :: SyntaxExpr idR -- The mfix function - } - | XStmtLR (XXStmtLR idL idR body) - --- Extra fields available post typechecking for RecStmt. -data RecStmtTc = - RecStmtTc - { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T - , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) - , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 - -- with recS_later_ids and recS_rec_ids, - -- and are the expressions that should be - -- returned by the recursion. - -- They may not quite be the Ids themselves, - -- because the Id may be *polymorphic*, but - -- the returned thing has to be *monomorphic*, - -- so they may be type applications - - , recS_ret_ty :: Type -- The type of - -- do { stmts; return (a,b,c) } - -- With rebindable syntax the type might not - -- be quite as simple as (m (tya, tyb, tyc)). - } - - -type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField - -type instance XBindStmt (GhcPass _) GhcPs b = NoExtField -type instance XBindStmt (GhcPass _) GhcRn b = NoExtField -type instance XBindStmt (GhcPass _) GhcTc b = Type - -type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField -type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField -type instance XApplicativeStmt (GhcPass _) GhcTc b = Type - -type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField -type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField -type instance XBodyStmt (GhcPass _) GhcTc b = Type - -type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField - -type instance XParStmt (GhcPass _) GhcPs b = NoExtField -type instance XParStmt (GhcPass _) GhcRn b = NoExtField -type instance XParStmt (GhcPass _) GhcTc b = Type - -type instance XTransStmt (GhcPass _) GhcPs b = NoExtField -type instance XTransStmt (GhcPass _) GhcRn b = NoExtField -type instance XTransStmt (GhcPass _) GhcTc b = Type - -type instance XRecStmt (GhcPass _) GhcPs b = NoExtField -type instance XRecStmt (GhcPass _) GhcRn b = NoExtField -type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc - -type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon - -data TransForm -- The 'f' below is the 'using' function, 'e' is the by function - = ThenForm -- then f or then f by e (depending on trS_by) - | GroupForm -- then group using f or then group by e using f (depending on trS_by) - deriving Data - --- | Parenthesised Statement Block -data ParStmtBlock idL idR - = ParStmtBlock - (XParStmtBlock idL idR) - [ExprLStmt idL] - [IdP idR] -- The variables to be returned - (SyntaxExpr idR) -- The return operator - | XParStmtBlock (XXParStmtBlock idL idR) - -type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField -type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon - --- | Applicative Argument -data ApplicativeArg idL - = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) - { xarg_app_arg_one :: (XApplicativeArgOne idL) - , app_arg_pattern :: (LPat idL) -- WildPat if it was a BodyStmt (see below) - , arg_expr :: (LHsExpr idL) - , is_body_stmt :: Bool -- True <=> was a BodyStmt - -- False <=> was a BindStmt - -- See Note [Applicative BodyStmt] - , fail_operator :: (SyntaxExpr idL) -- The fail operator - -- The fail operator is needed if this is a BindStmt - -- where the pattern can fail. E.g.: - -- (Just a) <- stmt - -- The fail operator will be invoked if the pattern - -- match fails. - -- The fail operator is noSyntaxExpr - -- if the pattern match can't fail - } - | ApplicativeArgMany -- do { stmts; return vars } - { xarg_app_arg_many :: (XApplicativeArgMany idL) - , app_stmts :: [ExprLStmt idL] -- stmts - , final_expr :: (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) - , bv_pattern :: (LPat idL) -- (v1,...,vn) - } - | XApplicativeArg (XXApplicativeArg idL) - -type instance XApplicativeArgOne (GhcPass _) = NoExtField -type instance XApplicativeArgMany (GhcPass _) = NoExtField -type instance XXApplicativeArg (GhcPass _) = NoExtCon - -{- -Note [The type of bind in Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some Stmts, notably BindStmt, keep the (>>=) bind operator. -We do NOT assume that it has type - (>>=) :: m a -> (a -> m b) -> m b -In some cases (see #303, #1537) it might have a more -exotic type, such as - (>>=) :: m i j a -> (a -> m j k b) -> m i k b -So we must be careful not to make assumptions about the type. -In particular, the monad may not be uniform throughout. - -Note [TransStmt binder map] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The [(idR,idR)] in a TransStmt behaves as follows: - - * Before renaming: [] - - * After renaming: - [ (x27,x27), ..., (z35,z35) ] - These are the variables - bound by the stmts to the left of the 'group' - and used either in the 'by' clause, - or in the stmts following the 'group' - Each item is a pair of identical variables. - - * After typechecking: - [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] - Each pair has the same unique, but different *types*. - -Note [BodyStmt] -~~~~~~~~~~~~~~~ -BodyStmts are a bit tricky, because what they mean -depends on the context. Consider the following contexts: - - A do expression of type (m res_ty) - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E any_ty: do { ....; E; ... } - E :: m any_ty - Translation: E >> ... - - A list comprehensions of type [elt_ty] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E Bool: [ .. | .... E ] - [ .. | ..., E, ... ] - [ .. | .... | ..., E | ... ] - E :: Bool - Translation: if E then fail else ... - - A guard list, guarding a RHS of type rhs_ty - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... - E :: Bool - Translation: if E then fail else ... - - A monad comprehension of type (m res_ty) - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E Bool: [ .. | .... E ] - E :: Bool - Translation: guard E >> ... - -Array comprehensions are handled like list comprehensions. - -Note [How RecStmt works] -~~~~~~~~~~~~~~~~~~~~~~~~ -Example: - HsDo [ BindStmt x ex - - , RecStmt { recS_rec_ids = [a, c] - , recS_stmts = [ BindStmt b (return (a,c)) - , LetStmt a = ...b... - , BindStmt c ec ] - , recS_later_ids = [a, b] - - , return (a b) ] - -Here, the RecStmt binds a,b,c; but - - Only a,b are used in the stmts *following* the RecStmt, - - Only a,c are used in the stmts *inside* the RecStmt - *before* their bindings - -Why do we need *both* rec_ids and later_ids? For monads they could be -combined into a single set of variables, but not for arrows. That -follows from the types of the respective feedback operators: - - mfix :: MonadFix m => (a -> m a) -> m a - loop :: ArrowLoop a => a (b,d) (c,d) -> a b c - -* For mfix, the 'a' covers the union of the later_ids and the rec_ids -* For 'loop', 'c' is the later_ids and 'd' is the rec_ids - -Note [Typing a RecStmt] -~~~~~~~~~~~~~~~~~~~~~~~ -A (RecStmt stmts) types as if you had written - - (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> - do { stmts - ; return (v1,..vn, r1, ..., rm) }) - -where v1..vn are the later_ids - r1..rm are the rec_ids - -Note [Monad Comprehensions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Monad comprehensions require separate functions like 'return' and -'>>=' for desugaring. These functions are stored in the statements -used in monad comprehensions. For example, the 'return' of the 'LastStmt' -expression is used to lift the body of the monad comprehension: - - [ body | stmts ] - => - stmts >>= \bndrs -> return body - -In transform and grouping statements ('then ..' and 'then group ..') the -'return' function is required for nested monad comprehensions, for example: - - [ body | stmts, then f, rest ] - => - f [ env | stmts ] >>= \bndrs -> [ body | rest ] - -BodyStmts require the 'Control.Monad.guard' function for boolean -expressions: - - [ body | exp, stmts ] - => - guard exp >> [ body | stmts ] - -Parallel statements require the 'Control.Monad.Zip.mzip' function: - - [ body | stmts1 | stmts2 | .. ] - => - mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body - -In any other context than 'MonadComp', the fields for most of these -'SyntaxExpr's stay bottom. - - -Note [Applicative BodyStmt] - -(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt -as if it was a BindStmt with a wildcard pattern. For example, - - do - x <- A - B - return x - -is transformed as if it were - - do - x <- A - _ <- B - return x - -so it transforms to - - (\(x,_) -> x) <$> A <*> B - -But we have to remember when we treat a BodyStmt like a BindStmt, -because in error messages we want to emit the original syntax the user -wrote, not our internal representation. So ApplicativeArgOne has a -Bool flag that is True when the original statement was a BodyStmt, so -that we can pretty-print it correctly. --} - -instance (Outputable (StmtLR idL idL (LHsExpr idL)), - Outputable (XXParStmtBlock idL idR)) - => Outputable (ParStmtBlock idL idR) where - ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts - ppr (XParStmtBlock x) = ppr x - -instance (OutputableBndrId pl, OutputableBndrId pr, - Outputable body) - => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where - ppr stmt = pprStmt stmt - -pprStmt :: forall idL idR body . (OutputableBndrId idL, - OutputableBndrId idR, - Outputable body) - => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc -pprStmt (LastStmt _ expr ret_stripped _) - = whenPprDebug (text "[last]") <+> - (if ret_stripped then text "return" else empty) <+> - ppr expr -pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] -pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] -pprStmt (BodyStmt _ expr _ _) = ppr expr -pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) - -pprStmt (TransStmt { trS_stmts = stmts, trS_by = by - , trS_using = using, trS_form = form }) - = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) - -pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids - , recS_later_ids = later_ids }) - = text "rec" <+> - vcat [ ppr_do_stmts segment - , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids - , text "later_ids=" <> ppr later_ids])] - -pprStmt (ApplicativeStmt _ args mb_join) - = getPprStyle $ \style -> - if userStyle style - then pp_for_user - else pp_debug - where - -- make all the Applicative stuff invisible in error messages by - -- flattening the whole ApplicativeStmt nest back to a sequence - -- of statements. - pp_for_user = vcat $ concatMap flattenArg args - - -- ppr directly rather than transforming here, because we need to - -- inject a "return" which is hard when we're polymorphic in the id - -- type. - flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] - flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args - flattenStmt stmt = [ppr stmt] - - flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] - flattenArg (_, ApplicativeArgOne _ pat expr isBody _) - | isBody = -- See Note [Applicative BodyStmt] - [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL))] - | otherwise = - [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL))] - flattenArg (_, ApplicativeArgMany _ stmts _ _) = - concatMap flattenStmt stmts - flattenArg (_, XApplicativeArg nec) = noExtCon nec - - pp_debug = - let - ap_expr = sep (punctuate (text " |") (map pp_arg args)) - in - if isNothing mb_join - then ap_expr - else text "join" <+> parens ap_expr - - pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc - pp_arg (_, applicativeArg) = ppr applicativeArg - -pprStmt (XStmtLR x) = ppr x - - -instance (OutputableBndrId idL) - => Outputable (ApplicativeArg (GhcPass idL)) where - ppr = pprArg - -pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc -pprArg (ApplicativeArgOne _ pat expr isBody _) - | isBody = -- See Note [Applicative BodyStmt] - ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL)) - | otherwise = - ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL)) -pprArg (ApplicativeArgMany _ stmts return pat) = - ppr pat <+> - text "<-" <+> - ppr (HsDo (panic "pprStmt") DoExpr (noLoc - (stmts ++ - [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)]))) -pprArg (XApplicativeArg x) = ppr x - -pprTransformStmt :: (OutputableBndrId p) - => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) - -> Maybe (LHsExpr (GhcPass p)) -> SDoc -pprTransformStmt bndrs using by - = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) - , nest 2 (ppr using) - , nest 2 (pprBy by)] - -pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc -pprTransStmt by using ThenForm - = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] -pprTransStmt by using GroupForm - = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] - -pprBy :: Outputable body => Maybe body -> SDoc -pprBy Nothing = empty -pprBy (Just e) = text "by" <+> ppr e - -pprDo :: (OutputableBndrId p, Outputable body) - => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc -pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts -pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts -pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts -pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts -pprDo ListComp stmts = brackets $ pprComp stmts -pprDo MonadComp stmts = brackets $ pprComp stmts -pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - -ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, - Outputable body) - => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc --- Print a bunch of do stmts -ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) - -pprComp :: (OutputableBndrId p, Outputable body) - => [LStmt (GhcPass p) body] -> SDoc -pprComp quals -- Prints: body | qual1, ..., qualn - | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals - = if null initStmts - -- If there are no statements in a list comprehension besides the last - -- one, we simply treat it like a normal list. This does arise - -- occasionally in code that GHC generates, e.g., in implementations of - -- 'range' for derived 'Ix' instances for product datatypes with exactly - -- one constructor (e.g., see #12583). - then ppr body - else hang (ppr body <+> vbar) 2 (pprQuals initStmts) - | otherwise - = pprPanic "pprComp" (pprQuals quals) - -pprQuals :: (OutputableBndrId p, Outputable body) - => [LStmt (GhcPass p) body] -> SDoc --- Show list comprehension qualifiers separated by commas -pprQuals quals = interpp'SP quals - -{- -************************************************************************ -* * - Template Haskell quotation brackets -* * -************************************************************************ --} - --- | Haskell Splice -data HsSplice id - = HsTypedSplice -- $$z or $$(f 4) - (XTypedSplice id) - SpliceDecoration -- Whether $$( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsUntypedSplice -- $z or $(f 4) - (XUntypedSplice id) - SpliceDecoration -- Whether $( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice - (XQuasiQuote id) - (IdP id) -- Splice point - (IdP id) -- Quoter - SrcSpan -- The span of the enclosed string - FastString -- The enclosed string - - -- AZ:TODO: use XSplice instead of HsSpliced - | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in - -- RnSplice. - -- This is the result of splicing a splice. It is produced by - -- the renamer and consumed by the typechecker. It lives only - -- between the two. - (XSpliced id) - ThModFinalizers -- TH finalizers produced by the splice. - (HsSplicedThing id) -- The result of splicing - | HsSplicedT - DelayedSplice - | XSplice (XXSplice id) -- Note [Trees that Grow] extension point - -type instance XTypedSplice (GhcPass _) = NoExtField -type instance XUntypedSplice (GhcPass _) = NoExtField -type instance XQuasiQuote (GhcPass _) = NoExtField -type instance XSpliced (GhcPass _) = NoExtField -type instance XXSplice (GhcPass _) = NoExtCon - --- | A splice can appear with various decorations wrapped around it. This data --- type captures explicitly how it was originally written, for use in the pretty --- printer. -data SpliceDecoration - = HasParens -- ^ $( splice ) or $$( splice ) - | HasDollar -- ^ $splice or $$splice - | NoParens -- ^ bare splice - deriving (Data, Eq, Show) - -instance Outputable SpliceDecoration where - ppr x = text $ show x - - -isTypedSplice :: HsSplice id -> Bool -isTypedSplice (HsTypedSplice {}) = True -isTypedSplice _ = False -- Quasi-quotes are untyped splices - --- | Finalizers produced by a splice with --- 'Language.Haskell.TH.Syntax.addModFinalizer' --- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how --- this is used. --- -newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] - --- A Data instance which ignores the argument of 'ThModFinalizers'. -instance Data ThModFinalizers where - gunfold _ z _ = z $ ThModFinalizers [] - toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] - --- See Note [Running typed splices in the zonker] --- These are the arguments that are passed to `TcSplice.runTopSplice` -data DelayedSplice = - DelayedSplice - TcLclEnv -- The local environment to run the splice in - (LHsExpr GhcRn) -- The original renamed expression - TcType -- The result type of running the splice, unzonked - (LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result - --- A Data instance which ignores the argument of 'DelayedSplice'. -instance Data DelayedSplice where - gunfold _ _ _ = panic "DelayedSplice" - toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] - --- | Haskell Spliced Thing --- --- Values that can result from running a splice. -data HsSplicedThing id - = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression - | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type - | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern - - --- See Note [Pending Splices] -type SplicePointName = Name - --- | Pending Renamer Splice -data PendingRnSplice - = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) - -data UntypedSpliceFlavour - = UntypedExpSplice - | UntypedPatSplice - | UntypedTypeSplice - | UntypedDeclSplice - deriving Data - --- | Pending Type-checker Splice -data PendingTcSplice - = PendingTcSplice SplicePointName (LHsExpr GhcTc) - -{- -Note [Pending Splices] -~~~~~~~~~~~~~~~~~~~~~~ -When we rename an untyped bracket, we name and lift out all the nested -splices, so that when the typechecker hits the bracket, it can -typecheck those nested splices without having to walk over the untyped -bracket code. So for example - [| f $(g x) |] -looks like - - HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) - -which the renamer rewrites to - - HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) - [PendingRnSplice UntypedExpSplice sn (g x)] - -* The 'sn' is the Name of the splice point, the SplicePointName - -* The PendingRnExpSplice gives the splice that splice-point name maps to; - and the typechecker can now conveniently find these sub-expressions - -* The other copy of the splice, in the second argument of HsSpliceE - in the renamed first arg of HsRnBracketOut - is used only for pretty printing - -There are four varieties of pending splices generated by the renamer, -distinguished by their UntypedSpliceFlavour - - * Pending expression splices (UntypedExpSplice), e.g., - [|$(f x) + 2|] - - UntypedExpSplice is also used for - * quasi-quotes, where the pending expression expands to - $(quoter "...blah...") - (see RnSplice.makePending, HsQuasiQuote case) - - * cross-stage lifting, where the pending expression expands to - $(lift x) - (see RnSplice.checkCrossStageLifting) - - * Pending pattern splices (UntypedPatSplice), e.g., - [| \$(f x) -> x |] - - * Pending type splices (UntypedTypeSplice), e.g., - [| f :: $(g x) |] - - * Pending declaration (UntypedDeclSplice), e.g., - [| let $(f x) in ... |] - -There is a fifth variety of pending splice, which is generated by the type -checker: - - * Pending *typed* expression splices, (PendingTcSplice), e.g., - [||1 + $$(f 2)||] - -It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the -output of the renamer. However, when pretty printing the output of the renamer, -e.g., in a type error message, we *do not* want to print out the pending -splices. In contrast, when pretty printing the output of the type checker, we -*do* want to print the pending splices. So splitting them up seems to make -sense, although I hate to add another constructor to HsExpr. --} - -instance OutputableBndrId p - => Outputable (HsSplicedThing (GhcPass p)) where - ppr (HsSplicedExpr e) = ppr_expr e - ppr (HsSplicedTy t) = ppr t - ppr (HsSplicedPat p) = ppr p - -instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where - ppr s = pprSplice s - -pprPendingSplice :: (OutputableBndrId p) - => SplicePointName -> LHsExpr (GhcPass p) -> SDoc -pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) - -pprSpliceDecl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e -pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" -pprSpliceDecl e ImplicitSplice = ppr_splice_decl e - -ppr_splice_decl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SDoc -ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty -ppr_splice_decl e = pprSplice e - -pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc -pprSplice (HsTypedSplice _ HasParens n e) - = ppr_splice (text "$$(") n e (text ")") -pprSplice (HsTypedSplice _ HasDollar n e) - = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice _ NoParens n e) - = ppr_splice empty n e empty -pprSplice (HsUntypedSplice _ HasParens n e) - = ppr_splice (text "$(") n e (text ")") -pprSplice (HsUntypedSplice _ HasDollar n e) - = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice _ NoParens n e) - = ppr_splice empty n e empty -pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ _ thing) = ppr thing -pprSplice (HsSplicedT {}) = text "Unevaluated typed splice" -pprSplice (XSplice x) = ppr x - -ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc -ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> - char '[' <> ppr quoter <> vbar <> - ppr quote <> text "|]" - -ppr_splice :: (OutputableBndrId p) - => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc -ppr_splice herald n e trail - = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail - --- | Haskell Bracket -data HsBracket p - = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] - | PatBr (XPatBr p) (LPat p) -- [p| pat |] - | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser - | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer - | TypBr (XTypBr p) (LHsType p) -- [t| type |] - | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T - -- (The Bool flag is used only in pprHsBracket) - | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] - | XBracket (XXBracket p) -- Note [Trees that Grow] extension point - -type instance XExpBr (GhcPass _) = NoExtField -type instance XPatBr (GhcPass _) = NoExtField -type instance XDecBrL (GhcPass _) = NoExtField -type instance XDecBrG (GhcPass _) = NoExtField -type instance XTypBr (GhcPass _) = NoExtField -type instance XVarBr (GhcPass _) = NoExtField -type instance XTExpBr (GhcPass _) = NoExtField -type instance XXBracket (GhcPass _) = NoExtCon - -isTypedBracket :: HsBracket id -> Bool -isTypedBracket (TExpBr {}) = True -isTypedBracket _ = False - -instance OutputableBndrId p - => Outputable (HsBracket (GhcPass p)) where - ppr = pprHsBracket - - -pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc -pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) -pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) -pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) -pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr _ True n) - = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr _ False n) - = text "''" <> pprPrefixOcc n -pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) -pprHsBracket (XBracket e) = ppr e - -thBrackets :: SDoc -> SDoc -> SDoc -thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> - pp_body <+> text "|]" - -thTyBrackets :: SDoc -> SDoc -thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") - -instance Outputable PendingRnSplice where - ppr (PendingRnSplice _ n e) = pprPendingSplice n e - -instance Outputable PendingTcSplice where - ppr (PendingTcSplice n e) = pprPendingSplice n e - -{- -************************************************************************ -* * -\subsection{Enumerations and list comprehensions} -* * -************************************************************************ --} - --- | Arithmetic Sequence Information -data ArithSeqInfo id - = From (LHsExpr id) - | FromThen (LHsExpr id) - (LHsExpr id) - | FromTo (LHsExpr id) - (LHsExpr id) - | FromThenTo (LHsExpr id) - (LHsExpr id) - (LHsExpr id) --- AZ: Sould ArithSeqInfo have a TTG extension? - -instance OutputableBndrId p - => Outputable (ArithSeqInfo (GhcPass p)) where - ppr (From e1) = hcat [ppr e1, pp_dotdot] - ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] - ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] - ppr (FromThenTo e1 e2 e3) - = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] - -pp_dotdot :: SDoc -pp_dotdot = text " .. " - -{- -************************************************************************ -* * -\subsection{HsMatchCtxt} -* * -************************************************************************ --} - --- | Haskell Match Context --- --- Context of a pattern match. This is more subtle than it would seem. See Note --- [Varieties of pattern matches]. -data HsMatchContext id -- Not an extensible tag - = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ - , mc_fixity :: LexicalFixity -- ^ fixing of @f@ - , mc_strictness :: SrcStrictness -- ^ was @f@ banged? - -- See Note [FunBind vs PatBind] - } - -- ^A pattern matching on an argument of a - -- function binding - | LambdaExpr -- ^Patterns of a lambda - | CaseAlt -- ^Patterns and guards on a case alternative - | IfAlt -- ^Guards of a multi-way if alternative - | ProcExpr -- ^Patterns of a proc - | PatBindRhs -- ^A pattern binding eg [y] <- e = e - | PatBindGuards -- ^Guards of pattern bindings, e.g., - -- (Just b) | Just _ <- x = e - -- | otherwise = e' - - | RecUpd -- ^Record update [used only in DsExpr to - -- tell matchWrapper what sort of - -- runtime error message to generate] - - | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, - -- pattern guard, etc - - | ThPatSplice -- ^A Template Haskell pattern splice - | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] - | PatSyn -- ^A pattern synonym declaration - deriving Functor -deriving instance (Data id) => Data (HsMatchContext id) - -instance OutputableBndr id => Outputable (HsMatchContext id) where - ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) - ppr LambdaExpr = text "LambdaExpr" - ppr CaseAlt = text "CaseAlt" - ppr IfAlt = text "IfAlt" - ppr ProcExpr = text "ProcExpr" - ppr PatBindRhs = text "PatBindRhs" - ppr PatBindGuards = text "PatBindGuards" - ppr RecUpd = text "RecUpd" - ppr (StmtCtxt _) = text "StmtCtxt _" - ppr ThPatSplice = text "ThPatSplice" - ppr ThPatQuote = text "ThPatQuote" - ppr PatSyn = text "PatSyn" - -isPatSynCtxt :: HsMatchContext id -> Bool -isPatSynCtxt ctxt = - case ctxt of - PatSyn -> True - _ -> False - --- | Haskell Statement Context. It expects to be parameterised with one of --- 'RdrName', 'Name' or 'Id' -data HsStmtContext id - = ListComp - | MonadComp - - | DoExpr -- ^do { ... } - | MDoExpr -- ^mdo { ... } ie recursive do-expression - | ArrowExpr -- ^do-notation in an arrow-command context - - | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs - | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt - deriving Functor -deriving instance (Data id) => Data (HsStmtContext id) - -isComprehensionContext :: HsStmtContext id -> Bool --- Uses comprehension syntax [ e | quals ] -isComprehensionContext ListComp = True -isComprehensionContext MonadComp = True -isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c -isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c -isComprehensionContext _ = False - --- | Should pattern match failure in a 'HsStmtContext' be desugared using --- 'MonadFail'? -isMonadFailStmtContext :: HsStmtContext id -> Bool -isMonadFailStmtContext MonadComp = True -isMonadFailStmtContext DoExpr = True -isMonadFailStmtContext MDoExpr = True -isMonadFailStmtContext GhciStmtCtxt = True -isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt -isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt -isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr - -isMonadCompContext :: HsStmtContext id -> Bool -isMonadCompContext MonadComp = True -isMonadCompContext _ = False - -matchSeparator :: HsMatchContext id -> SDoc -matchSeparator (FunRhs {}) = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator IfAlt = text "->" -matchSeparator LambdaExpr = text "->" -matchSeparator ProcExpr = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator PatBindGuards = text "=" -matchSeparator (StmtCtxt _) = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern - -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" -matchSeparator PatSyn = panic "unused" - -pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc -pprMatchContext ctxt - | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt - | otherwise = text "a" <+> pprMatchContextNoun ctxt - where - want_an (FunRhs {}) = True -- Use "an" in front - want_an ProcExpr = True - want_an _ = False - -pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc -pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) - = text "equation for" - <+> quotes (ppr fun) -pprMatchContextNoun CaseAlt = text "case alternative" -pprMatchContextNoun IfAlt = text "multi-way if alternative" -pprMatchContextNoun RecUpd = text "record-update construct" -pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" -pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" -pprMatchContextNoun PatBindRhs = text "pattern binding" -pprMatchContextNoun PatBindGuards = text "pattern binding guards" -pprMatchContextNoun LambdaExpr = text "lambda abstraction" -pprMatchContextNoun ProcExpr = text "arrow abstraction" -pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" - $$ pprAStmtContext ctxt -pprMatchContextNoun PatSyn = text "pattern synonym declaration" - ------------------ -pprAStmtContext, pprStmtContext :: (Outputable id, - Outputable (NameOrRdrName id)) - => HsStmtContext id -> SDoc -pprAStmtContext ctxt = article <+> pprStmtContext ctxt - where - pp_an = text "an" - pp_a = text "a" - article = case ctxt of - MDoExpr -> pp_an - GhciStmtCtxt -> pp_an - _ -> pp_a - - ------------------ -pprStmtContext GhciStmtCtxt = text "interactive GHCi command" -pprStmtContext DoExpr = text "'do' block" -pprStmtContext MDoExpr = text "'mdo' block" -pprStmtContext ArrowExpr = text "'do' block in an arrow command" -pprStmtContext ListComp = text "list comprehension" -pprStmtContext MonadComp = text "monad comprehension" -pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt - --- Drop the inner contexts when reporting errors, else we get --- Unexpected transform statement --- in a transformed branch of --- transformed branch of --- transformed branch of monad comprehension -pprStmtContext (ParStmtCtxt c) = - ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) - (pprStmtContext c) -pprStmtContext (TransStmtCtxt c) = - ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) - (pprStmtContext c) - -instance (Outputable (GhcPass p), Outputable (NameOrRdrName (GhcPass p))) - => Outputable (HsStmtContext (GhcPass p)) where - ppr = pprStmtContext - --- Used to generate the string for a *runtime* error message -matchContextErrString :: Outputable id - => HsMatchContext id -> SDoc -matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun -matchContextErrString CaseAlt = text "case" -matchContextErrString IfAlt = text "multi-way if" -matchContextErrString PatBindRhs = text "pattern binding" -matchContextErrString PatBindGuards = text "pattern binding guards" -matchContextErrString RecUpd = text "record update" -matchContextErrString LambdaExpr = text "lambda" -matchContextErrString ProcExpr = text "proc" -matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime -matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime -matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime -matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" -matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" -matchContextErrString (StmtCtxt DoExpr) = text "'do' block" -matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" -matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" -matchContextErrString (StmtCtxt ListComp) = text "list comprehension" -matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" - -pprMatchInCtxt :: (OutputableBndrId idR, - -- TODO:AZ these constraints do not make sense - Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), - Outputable body) - => Match (GhcPass idR) body -> SDoc -pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) - <> colon) - 4 (pprMatch match) - -pprStmtInCtxt :: (OutputableBndrId idL, - OutputableBndrId idR, - Outputable body) - => HsStmtContext (IdP (GhcPass idL)) +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Abstract Haskell syntax for expressions. +module GHC.Hs.Expr where + +#include "HsVersions.h" + +-- friends: +import GHC.Prelude + +import GHC.Hs.Decls +import GHC.Hs.Pat +import GHC.Hs.Lit +import GHC.Hs.Extension +import GHC.Hs.Type +import GHC.Hs.Binds + +-- others: +import GHC.Tc.Types.Evidence +import GHC.Core +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Basic +import GHC.Core.ConLike +import GHC.Types.SrcLoc +import GHC.Unit.Module (ModuleName) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Core.Type +import GHC.Builtin.Types (mkTupleStr) +import GHC.Tc.Utils.TcType (TcType) +import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv) + +-- libraries: +import Data.Data hiding (Fixity(..)) +import qualified Data.Data as Data (Fixity(..)) +import qualified Data.Kind +import Data.Maybe (isJust) + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) + +{- +************************************************************************ +* * +\subsection{Expressions proper} +* * +************************************************************************ +-} + +-- * Expressions proper + +-- | Located Haskell Expression +type LHsExpr p = Located (HsExpr p) + -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + +------------------------- +-- | Post-Type checking Expression +-- +-- PostTcExpr is an evidence expression attached to the syntax tree by the +-- type checker (c.f. postTcType). +type PostTcExpr = HsExpr GhcTc + +-- | Post-Type checking Table +-- +-- We use a PostTcTable where there are a bunch of pieces of evidence, more +-- than is convenient to keep individually. +type PostTcTable = [(Name, PostTcExpr)] + +------------------------- +{- Note [NoSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~ +Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc) +for several reasons: + + 1. As described in Note [Rebindable if] + + 2. In order to suppress "not in scope: xyz" messages when a bit of + rebindable syntax does not apply. For example, when using an irrefutable + pattern in a BindStmt, we don't need a `fail` operator. + + 3. Rebindable syntax might just not make sense. For example, a BodyStmt + contains the syntax for `guard`, but that's used only in monad comprehensions. + If we had more of a whiz-bang type system, we might be able to rule this + case out statically. +-} + +-- | Syntax Expression +-- +-- SyntaxExpr is represents the function used in interpreting rebindable +-- syntax. In the parser, we have no information to supply; in the renamer, +-- we have the name of the function (but see +-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle) +-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'. +-- +-- In some contexts, rebindable syntax is not implemented, and so we have +-- constructors to represent that possibility in both the renamer and +-- typechecker instantiations. +-- +-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for +-- @(>>=)@, and then instantiated by the type checker with its type args +-- etc +type family SyntaxExpr p + +-- Defining SyntaxExpr in two stages allows for better type inference, because +-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity, +-- noSyntaxExpr would be ambiguous. +type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p + +type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where + SyntaxExprGhc 'Parsed = NoExtField + SyntaxExprGhc 'Renamed = SyntaxExprRn + SyntaxExprGhc 'Typechecked = SyntaxExprTc + +-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr]. +data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn) + -- Why is the payload not just a Name? + -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" + | NoSyntaxExprRn + +-- | An expression with wrappers, used for rebindable syntax +-- +-- This should desugar to +-- +-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) +-- > (syn_arg_wraps[1] arg1) ... +-- +-- where the actual arguments come from elsewhere in the AST. +data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + | NoSyntaxExprTc -- See Note [NoSyntaxExpr] + +-- | This is used for rebindable-syntax pieces that are too polymorphic +-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) +noExpr :: HsExpr (GhcPass p) +noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) + +noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) + -- Before renaming, and sometimes after + -- See Note [NoSyntaxExpr] +noSyntaxExpr = case ghcPass @p of + GhcPs -> noExtField + GhcRn -> NoSyntaxExprRn + GhcTc -> NoSyntaxExprTc + +-- | Make a 'SyntaxExpr GhcRn' from an expression +-- Used only in getMonadFailOp. +-- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" +mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn +mkSyntaxExpr = SyntaxExprRn + +-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the +-- renamer). +mkRnSyntaxExpr :: Name -> SyntaxExprRn +mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLoc name + +instance Outputable SyntaxExprRn where + ppr (SyntaxExprRn expr) = ppr expr + ppr NoSyntaxExprRn = text "" + +instance Outputable SyntaxExprTc where + ppr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = sdocOption sdocPrintExplicitCoercions $ \print_co -> + getPprDebug $ \debug -> + if debug || print_co + then ppr expr <> braces (pprWithCommas ppr arg_wraps) + <> braces (ppr res_wrap) + else ppr expr + + ppr NoSyntaxExprTc = text "" + +-- | Command Syntax Table (for Arrow syntax) +type CmdSyntaxTable p = [(Name, HsExpr p)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxTable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, )] + where is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious GHC.Rename.Expr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + +-- | A Haskell expression. +data HsExpr p + = HsVar (XVar p) + (Located (IdP p)) -- ^ Variable + + -- See Note [Located RdrNames] + + | HsUnboundVar (XUnboundVar p) + OccName -- ^ Unbound variable; also used for "holes" + -- (_ or _x). + -- Turned from HsVar to HsUnboundVar by the + -- renamer, when it finds an out-of-scope + -- variable or hole. + -- Turned into HsVar by type checker, to support + -- deferred type errors. + + | HsConLikeOut (XConLikeOut p) + ConLike -- ^ After typechecker only; must be different + -- HsVar for pretty printing + + | HsRecFld (XRecFld p) + (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector + -- Not in use after typechecking + + | HsOverLabel (XOverLabel p) + (Maybe (IdP p)) FastString + -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) + -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the + -- in-scope 'fromLabel'. + -- NB: Not in use after typechecking + + | HsIPVar (XIPVar p) + HsIPName -- ^ Implicit parameter (not in use after typechecking) + | HsOverLit (XOverLitE p) + (HsOverLit p) -- ^ Overloaded literals + + | HsLit (XLitE p) + (HsLit p) -- ^ Simple (non-overloaded) literals + + | HsLam (XLam p) + (MatchGroup p (LHsExpr p)) + -- ^ Lambda abstraction. Currently always a single match + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', + -- 'GHC.Parser.Annotation.AnnRarrow', + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', + -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application + + | HsAppType (XAppTypeE p) -- After typechecking: the type argument + (LHsExpr p) + (LHsWcType (NoGhcTc p)) -- ^ Visible type application + -- + -- Explicit type argument; e.g f @Int x y + -- NB: Has wildcards, but no implicit quantification + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt', + + -- | Operator applications: + -- NB Bracketed ops such as (+) come out as Vars. + + -- NB We need an expr for the operator in an OpApp/Section since + -- the typechecker may need to apply the operator to a few types. + + | OpApp (XOpApp p) + (LHsExpr p) -- left operand + (LHsExpr p) -- operator + (LHsExpr p) -- right operand + + -- | Negation operator. Contains the negated expression and the name + -- of 'negate' + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | NegApp (XNegApp p) + (LHsExpr p) + (SyntaxExpr p) + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, + -- 'GHC.Parser.Annotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsPar (XPar p) + (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + + | SectionL (XSectionL p) + (LHsExpr p) -- operand; see Note [Sections in HsSyn] + (LHsExpr p) -- operator + | SectionR (XSectionR p) + (LHsExpr p) -- operator; see Note [Sections in HsSyn] + (LHsExpr p) -- operand + + -- | Used for explicit tuples and sections thereof + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + -- Note [ExplicitTuple] + | ExplicitTuple + (XExplicitTuple p) + [LHsTupArg p] + Boxity + + -- | Used for unboxed sum types + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@, + -- 'GHC.Parser.Annotation.AnnVbar', 'GHC.Parser.Annotation.AnnClose' @'#)'@, + -- + -- There will be multiple 'GHC.Parser.Annotation.AnnVbar', (1 - alternative) before + -- the expression, (arity - alternative) after it + | ExplicitSum + (XExplicitSum p) + ConTag -- Alternative (one-based) + Arity -- Sum arity + (LHsExpr p) + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', + -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsCase (XCase p) + (LHsExpr p) + (MatchGroup p (LHsExpr p)) + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf', + -- 'GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnElse', + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use + -- rebindable syntax + (LHsExpr p) -- predicate + (LHsExpr p) -- then part + (LHsExpr p) -- else part + + -- | Multi-way if + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf' + -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] + + -- | let(rec) + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', + -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsLet (XLet p) + (LHsLocalBinds p) + (LHsExpr p) + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', + -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnVbar', + -- 'GHC.Parser.Annotation.AnnClose' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsDo (XDo p) -- Type of the whole expression + (HsStmtContext GhcRn) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + (Located [ExprLStmt p]) -- "do":one or more stmts + + -- | Syntactic list: [a,b,c,...] + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, + -- 'GHC.Parser.Annotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + -- See Note [Empty lists] + | ExplicitList + (XExplicitList p) -- Gives type of components of list + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromListN witness + [LHsExpr p] + + -- | Record construction + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | RecordCon + { rcon_ext :: XRecordCon p + , rcon_con_name :: Located (IdP p) -- The constructor name; + -- not used after type checking + , rcon_flds :: HsRecordBinds p } -- The fields + + -- | Record update + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | RecordUpd + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p + , rupd_flds :: [LHsRecUpdField p] + } + -- For a type family, the arg types are of the *instance* tycon, + -- not the family tycon + + -- | Expression with an explicit type signature. @e :: type@ + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | ExprWithTySig + (XExprWithTySig p) + + (LHsExpr p) + (LHsSigWcType (NoGhcTc p)) + + -- | Arithmetic sequence + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, + -- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot', + -- 'GHC.Parser.Annotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | ArithSeq + (XArithSeq p) + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromList witness + (ArithSeqInfo p) + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + ----------------------------------------------------------- + -- MetaHaskell Extensions + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ', + -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsBracket (XBracket p) (HsBracket p) + + -- See Note [Pending Splices] + | HsRnBracketOut + (XRnBracketOut p) + (HsBracket GhcRn) -- Output of the renamer is the *original* renamed + -- expression, plus + [PendingRnSplice] -- _renamed_ splices to be type checked + + | HsTcBracketOut + (XTcBracketOut p) + (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument + -- to the quote. + (HsBracket GhcRn) -- Output of the type checker is the *original* + -- renamed expression, plus + [PendingTcSplice] -- _typechecked_ splices to be + -- pasted back in by the desugarer + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsSpliceE (XSpliceE p) (HsSplice p) + + ----------------------------------------------------------- + -- Arrow notation extension + + -- | @proc@ notation for Arrows + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc', + -- 'GHC.Parser.Annotation.AnnRarrow' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsProc (XProc p) + (LPat p) -- arrow abstraction, proc + (LHsCmdTop p) -- body of the abstraction + -- always has an empty stack + + --------------------------------------- + -- static pointers extension + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic', + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsStatic (XStatic p) -- Free variables of the body + (LHsExpr p) -- Body + + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + (XTick p) + (Tickish (IdP p)) + (LHsExpr p) -- sub-expression + + | HsBinTick + (XBinTick p) + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr p) -- sub-expression + + --------------------------------------- + -- Expressions annotated with pragmas, written as {-# ... #-} + | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) + + | XExpr !(XXExpr p) + -- Note [Trees that Grow] extension constructor for the + -- general idea, and Note [Rebindable syntax and HsExpansion] + -- for an example of how we use it. + +-- | Extra data fields for a 'RecordCon', added by the type checker +data RecordConTc = RecordConTc + { rcon_con_like :: ConLike -- The data constructor or pattern synonym + , rcon_con_expr :: PostTcExpr -- Instantiated constructor function + } + +-- | Extra data fields for a 'RecordUpd', added by the type checker +data RecordUpdTc = RecordUpdTc + { rupd_cons :: [ConLike] + -- Filled in by the type checker to the + -- _non-empty_ list of DataCons that have + -- all the upd'd fields + + , rupd_in_tys :: [Type] -- Argument types of *input* record type + , rupd_out_tys :: [Type] -- and *output* record type + -- For a data family, these are the type args of the + -- /representation/ type constructor + + , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] + } + +-- | HsWrap appears only in typechecker output +-- Invariant: The contained Expr is *NOT* itself an HsWrap. +-- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr". +-- This invariant is maintained by 'GHC.Hs.Utils.mkHsWrap'. +-- hs_syn is something like HsExpr or HsCmd +data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper + (hs_syn GhcTc) -- the thing that is wrapped + +deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) + +-- --------------------------------------------------------------------- + +type instance XVar (GhcPass _) = NoExtField +type instance XUnboundVar (GhcPass _) = NoExtField +type instance XConLikeOut (GhcPass _) = NoExtField +type instance XRecFld (GhcPass _) = NoExtField +type instance XOverLabel (GhcPass _) = NoExtField +type instance XIPVar (GhcPass _) = NoExtField +type instance XOverLitE (GhcPass _) = NoExtField +type instance XLitE (GhcPass _) = NoExtField +type instance XLam (GhcPass _) = NoExtField +type instance XLamCase (GhcPass _) = NoExtField +type instance XApp (GhcPass _) = NoExtField + +type instance XAppTypeE GhcPs = NoExtField +type instance XAppTypeE GhcRn = NoExtField +type instance XAppTypeE GhcTc = Type + +type instance XOpApp GhcPs = NoExtField +type instance XOpApp GhcRn = Fixity +type instance XOpApp GhcTc = Fixity + +type instance XNegApp (GhcPass _) = NoExtField +type instance XPar (GhcPass _) = NoExtField +type instance XSectionL (GhcPass _) = NoExtField +type instance XSectionR (GhcPass _) = NoExtField +type instance XExplicitTuple (GhcPass _) = NoExtField + +type instance XExplicitSum GhcPs = NoExtField +type instance XExplicitSum GhcRn = NoExtField +type instance XExplicitSum GhcTc = [Type] + +type instance XCase (GhcPass _) = NoExtField + +type instance XIf (GhcPass _) = NoExtField + +type instance XMultiIf GhcPs = NoExtField +type instance XMultiIf GhcRn = NoExtField +type instance XMultiIf GhcTc = Type + +type instance XLet (GhcPass _) = NoExtField + +type instance XDo GhcPs = NoExtField +type instance XDo GhcRn = NoExtField +type instance XDo GhcTc = Type + +type instance XExplicitList GhcPs = NoExtField +type instance XExplicitList GhcRn = NoExtField +type instance XExplicitList GhcTc = Type + +type instance XRecordCon GhcPs = NoExtField +type instance XRecordCon GhcRn = NoExtField +type instance XRecordCon GhcTc = RecordConTc + +type instance XRecordUpd GhcPs = NoExtField +type instance XRecordUpd GhcRn = NoExtField +type instance XRecordUpd GhcTc = RecordUpdTc + +type instance XExprWithTySig (GhcPass _) = NoExtField + +type instance XArithSeq GhcPs = NoExtField +type instance XArithSeq GhcRn = NoExtField +type instance XArithSeq GhcTc = PostTcExpr + +type instance XBracket (GhcPass _) = NoExtField + +type instance XRnBracketOut (GhcPass _) = NoExtField +type instance XTcBracketOut (GhcPass _) = NoExtField + +type instance XSpliceE (GhcPass _) = NoExtField +type instance XProc (GhcPass _) = NoExtField + +type instance XStatic GhcPs = NoExtField +type instance XStatic GhcRn = NameSet +type instance XStatic GhcTc = NameSet + +type instance XTick (GhcPass _) = NoExtField +type instance XBinTick (GhcPass _) = NoExtField + +type instance XPragE (GhcPass _) = NoExtField + +type instance XXExpr GhcPs = NoExtCon + +-- See Note [Rebindable syntax and HsExpansion] below +type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) + (HsExpr GhcRn) +type instance XXExpr GhcTc = XXExprGhcTc + +data XXExprGhcTc + = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr) + | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)) + + +{- +Note [Rebindable syntax and HsExpansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We implement rebindable syntax (RS) support by performing a desugaring +in the renamer. We transform GhcPs expressions affected by RS into the +appropriate desugared form, but **annotated with the original expression**. + +Let us consider a piece of code like: + + {-# LANGUAGE RebindableSyntax #-} + ifThenElse :: Char -> () -> () -> () + ifThenElse _ _ _ = () + x = if 'a' then () else True + +The parsed AST for the RHS of x would look something like (slightly simplified): + + L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True)) + +Upon seeing such an AST with RS on, we could transform it into a +mere function call, as per the RS rules, equivalent to the +following function application: + + ifThenElse 'a' () True + +which doesn't typecheck. But GHC would report an error about +not being able to match the third argument's type (Bool) with the +expected type: (), in the expression _as desugared_, i.e in +the aforementioned function application. But the user never +wrote a function application! This would be pretty bad. + +To remedy this, instead of transforming the original HsIf +node into mere applications of 'ifThenElse', we keep the +original 'if' expression around too, using the TTG +XExpr extension point to allow GHC to construct an +'HsExpansion' value that will keep track of the original +expression in its first field, and the desugared one in the +second field. The resulting renamed AST would look like: + + L locif (XExpr + (HsExpanded + (HsIf (L loca 'a') + (L loctrue ()) + (L locfalse True) + ) + (App (L generatedSrcSpan + (App (L generatedSrcSpan + (App (L generatedSrcSpan (Var ifThenElse)) + (L loca 'a') + ) + ) + (L loctrue ()) + ) + ) + (L locfalse True) + ) + ) + ) + +When comes the time to typecheck the program, we end up calling +tcMonoExpr on the AST above. If this expression gives rise to +a type error, then it will appear in a context line and GHC +will pretty-print it using the 'Outputable (HsExpansion a b)' +instance defined below, which *only prints the original +expression*. This is the gist of the idea, but is not quite +enough to recover the error messages that we had with the +SyntaxExpr-based, typechecking/desugaring-to-core time +implementation of rebindable syntax. The key idea is to decorate +some elements of the desugared expression so as to be able to +give them a special treatment when typechecking the desugared +expression, to print a different context line or skip one +altogether. + +Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in +TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we +entered generated code, i.e code fabricated by the compiler when rebinding some +syntax. If someone tries to push some error context line while that field is set +to True, the pushing won't actually happen and the context line is just dropped. +Once we 'setSrcSpan' a real span (for an expression that was in the original +source code), we set 'tcl_in_gen_code' back to False, indicating that we +"emerged from the generated code tunnel", and that the expressions we will be +processing are relevant to report in context lines again. + +You might wonder why we store a RealSrcSpan in addition to a Bool in +the TcLclEnv: could we not store a Maybe RealSrcSpan? The problem is +that we still generate constraints when processing generated code, +and a CtLoc must contain a RealSrcSpan -- otherwise, error messages +might appear without source locations. So we keep the RealSrcSpan of +the last location spotted that wasn't generated; it's as good as +we're going to get in generated code. Once we get to sub-trees that +are not generated, then we update the RealSrcSpan appropriately, and +set the tcl_in_gen_code Bool to False. + +--- + +A general recipe to follow this approach for new constructs could go as follows: + +- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your + construct, in HsExpr or related syntax data types. +- At renaming-time: + - take your original node of interest (HsIf above) + - rename its subexpressions (condition, true branch, false branch above) + - construct the suitable "rebound"-and-renamed result (ifThenElse call + above), where the 'SrcSpan' attached to any _fabricated node_ (the + HsVar/HsApp nodes, above) is set to 'generatedSrcSpan' + - take both the original node and that rebound-and-renamed result and wrap + them in an XExpr: XExpr (HsExpanded ) + - At typechecking-time: + - remove any logic that was previously dealing with your rebindable + construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends. + - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we + typecheck the desugared expression while reporting the original one in + errors + +-} + +-- See Note [Rebindable syntax and HsExpansion] just above. +data HsExpansion a b + = HsExpanded a b + deriving Data + +-- | Build a "wrapped" 'HsExpansion' out of an extension constructor, +-- and the two components of the expansion: original and desugared +-- expressions. +-- +-- See Note [Rebindable Syntax and HsExpansion] above for more details. +mkExpanded + :: (HsExpansion a b -> b) -- ^ XExpr, XCmd, ... + -> a -- ^ source expression ('GhcPs') + -> b -- ^ "desugared" expression + -- ('GhcRn') + -> b -- ^ suitably wrapped + -- 'HsExpansion' +mkExpanded xwrap a b = xwrap (HsExpanded a b) + +-- | Just print the original expression (the @a@). +instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where + ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a) + +-- --------------------------------------------------------------------- + +-- | A pragma, written as {-# ... #-}, that may appear within an expression. +data HsPragE p + = HsPragSCC (XSCC p) + SourceText -- Note [Pragma source text] in GHC.Types.Basic + StringLiteral -- "set cost centre" SCC pragma + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# GENERATED'@, + -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnVal', + -- 'GHC.Parser.Annotation.AnnColon','GHC.Parser.Annotation.AnnVal', + -- 'GHC.Parser.Annotation.AnnMinus', + -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnColon', + -- 'GHC.Parser.Annotation.AnnVal', + -- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsPragTick -- A pragma introduced tick + (XTickPragma p) + SourceText -- Note [Pragma source text] in GHC.Types.Basic + (StringLiteral,(Int,Int),(Int,Int)) + -- external span for this tick + ((SourceText,SourceText),(SourceText,SourceText)) + -- Source text for the four integers used in the span. + -- See note [Pragma source text] in GHC.Types.Basic + + | XHsPragE !(XXPragE p) + +type instance XSCC (GhcPass _) = NoExtField +type instance XCoreAnn (GhcPass _) = NoExtField +type instance XTickPragma (GhcPass _) = NoExtField +type instance XXPragE (GhcPass _) = NoExtCon + +-- | Located Haskell Tuple Argument +-- +-- 'HsTupArg' is used for tuple sections +-- @(,a,)@ is represented by +-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ +-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ +type LHsTupArg id = Located (HsTupArg id) +-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' + +-- For details on above see note [Api annotations] in GHC.Parser.Annotation + +-- | Haskell Tuple Argument +data HsTupArg id + = Present (XPresent id) (LHsExpr id) -- ^ The argument + | Missing (XMissing id) -- ^ The argument is missing, but this is its type + | XTupArg !(XXTupArg id) -- ^ Note [Trees that Grow] extension point + +type instance XPresent (GhcPass _) = NoExtField + +type instance XMissing GhcPs = NoExtField +type instance XMissing GhcRn = NoExtField +type instance XMissing GhcTc = Scaled Type + +type instance XXTupArg (GhcPass _) = NoExtCon + +tupArgPresent :: LHsTupArg id -> Bool +tupArgPresent (L _ (Present {})) = True +tupArgPresent (L _ (Missing {})) = False +tupArgPresent (L _ (XTupArg {})) = False + +{- +Note [Parens in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~ +HsPar (and ParPat in patterns, HsParTy in types) is used as follows + + * HsPar is required; the pretty printer does not add parens. + + * HsPars are respected when rearranging operator fixities. + So a * (b + c) means what it says (where the parens are an HsPar) + + * For ParPat and HsParTy the pretty printer does add parens but this should be + a no-op for ParsedSource, based on the pretty printer round trip feature + introduced in + https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c + + * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or + not they are strictly necessary. This should be addressed when #13238 is + completed, to be treated the same as HsPar. + + +Note [Sections in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~ +Sections should always appear wrapped in an HsPar, thus + HsPar (SectionR ...) +The parser parses sections in a wider variety of situations +(See Note [Parsing sections]), but the renamer checks for those +parens. This invariant makes pretty-printing easier; we don't need +a special case for adding the parens round sections. + +Note [Rebindable if] +~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' is a bit special, because when +rebindable syntax is *off* we do not want to treat + (if c then t else e) +as if it was an application (ifThenElse c t e). Why not? +Because we allow an 'if' to return *unboxed* results, thus + if blah then 3# else 4# +whereas that would not be possible using a all to a polymorphic function +(because you can't call a polymorphic function at an unboxed type). + +So we use NoSyntaxExpr to mean "use the old built-in typing rule". + +A further complication is that, in the `deriving` code, we never want +to use rebindable syntax. So, even in GhcPs, we want to denote whether +to use rebindable syntax or not. This is done via the type instance +for XIf GhcPs. + +Note [Record Update HsWrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a wrapper in RecordUpd which is used for the *required* +constraints for pattern synonyms. This wrapper is created in the +typechecking and is then directly used in the desugaring without +modification. + +For example, if we have the record pattern synonym P, + pattern P :: (Show a) => a -> Maybe a + pattern P{x} = Just x + + foo = (Just True) { x = False } +then `foo` desugars to something like + foo = case Just True of + P x -> P False +hence we need to provide the correct dictionaries to P's matcher on +the RHS so that we can build the expression. + +Note [Located RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~ +A number of syntax elements have seemingly redundant locations attached to them. +This is deliberate, to allow transformations making use of the API Annotations +to easily correlate a Located Name in the RenamedSource with a Located RdrName +in the ParsedSource. + +There are unfortunately enough differences between the ParsedSource and the +RenamedSource that the API Annotations cannot be used directly with +RenamedSource, so this allows a simple mapping to be used based on the location. + +Note [ExplicitTuple] +~~~~~~~~~~~~~~~~~~~~ +An ExplicitTuple is never just a data constructor like (,,,). +That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least +one `Present` member (and is thus never empty). + +A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an +`ExplicitTuple`, and stays that way. This is important for two reasons: + + 1. We don't need -XTupleSections for (,,,) + 2. The type variables in (,,,) can be instantiated with visible type application. + That is, + + (,,) :: forall a b c. a -> b -> c -> (a,b,c) + (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c) + + Note that the tuple section has *inferred* arguments, while the data + constructor has *specified* ones. + (See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + for background.) + +Sadly, the grammar for this is actually ambiguous, and it's only thanks to the +preference of a shift in a shift/reduce conflict that the parser works as this +Note details. Search for a reference to this Note in GHC.Parser for further +explanation. + +Note [Empty lists] +~~~~~~~~~~~~~~~~~~ +An empty list could be considered either a data constructor (stored with +HsVar) or an ExplicitList. This Note describes how empty lists flow through the +various phases and why. + +Parsing +------- +An empty list is parsed by the sysdcon nonterminal. It thus comes to life via +HsVar nilDataCon (defined in GHC.Builtin.Types). A freshly-parsed (HsExpr GhcPs) empty list +is never a ExplicitList. + +Renaming +-------- +If -XOverloadedLists is enabled, we must type-check the empty list as if it +were a call to fromListN. (This is true regardless of the setting of +-XRebindableSyntax.) This is very easy if the empty list is an ExplicitList, +but an annoying special case if it's an HsVar. So the renamer changes a +HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on. +(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr. + +Type-checking +------------- +We want to accept an expression like [] @Int. To do this, we must infer that +[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside. +However, the type-checking for explicit lists works differently: [x,y,z] is never +polymorphic. Instead, we unify the types of x, y, and z together, and use the +unified type as the argument to the cons and nil constructors. Thus, treating +[] as an empty ExplicitList in the type-checker would prevent [] @Int from working. + +However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed: +it's just like fromListN 0 [] @Int. Since + fromListN :: forall list. IsList list => Int -> [Item list] -> list +that expression really should be rejected. Thus, the renamer's behaviour is +exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as +an empty ExplicitList when -XOverloadedLists. + +See also #13680, which requested [] @Int to work. +-} + +instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where + ppr expr = pprExpr expr + +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc +pprLExpr (L _ e) = pprExpr e + +pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc +pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e + | otherwise = pprDeeper (ppr_expr e) + +isQuietHsExpr :: HsExpr id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsExpr (HsPar {}) = True +-- applications don't display anything themselves +isQuietHsExpr (HsApp {}) = True +isQuietHsExpr (HsAppType {}) = True +isQuietHsExpr (OpApp {}) = True +isQuietHsExpr _ = False + +pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprBinds b = pprDeeper (ppr b) + +----------------------- +ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + +ppr_expr :: forall p. (OutputableBndrId p) + => HsExpr (GhcPass p) -> SDoc +ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v +ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc uv +ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c +ppr_expr (HsIPVar _ v) = ppr v +ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l +ppr_expr (HsLit _ lit) = ppr lit +ppr_expr (HsOverLit _ lit) = ppr lit +ppr_expr (HsPar _ e) = parens (ppr_lexpr e) + +ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] + +ppr_expr e@(HsApp {}) = ppr_apps e [] +ppr_expr e@(HsAppType {}) = ppr_apps e [] + +ppr_expr (OpApp _ e1 op e2) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + + where + pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens + pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear + + pp_prefixly + = hang (ppr op) 2 (sep [pp_e1, pp_e2]) + + pp_infixly pp_op + = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) + +ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e + +ppr_expr (SectionL _ expr op) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, text "x_ )"]) + + pp_infixly v = (sep [pp_expr, v]) + +ppr_expr (SectionR _ op expr) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) + 4 (pp_expr <> rparen) + + pp_infixly v = sep [v, pp_expr] + +ppr_expr (ExplicitTuple _ exprs boxity) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Solo x`, not `(x)` + | [L _ (Present _ expr)] <- exprs + , Boxed <- boxity + = hsep [text (mkTupleStr Boxed 1), ppr expr] + | otherwise + = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) + where + ppr_tup_args [] = [] + ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + + punc (Present {} : _) = comma <> space + punc (Missing {} : _) = comma + punc (XTupArg {} : _) = comma <> space + punc [] = empty + +ppr_expr (ExplicitSum _ alt arity expr) + = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" + where + ppr_bars n = hsep (replicate n (char '|')) + +ppr_expr (HsLam _ matches) + = pprMatches matches + +ppr_expr (HsLamCase _ matches) + = sep [ sep [text "\\case"], + nest 2 (pprMatches matches) ] + +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], + nest 2 (pprMatches matches) <+> char '}'] +ppr_expr (HsCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] + +ppr_expr (HsIf _ e1 e2 e3) + = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], + nest 4 (ppr e2), + text "else", + nest 4 (ppr e3)] + +ppr_expr (HsMultiIf _ alts) + = hang (text "if") 3 (vcat (map ppr_alt alts)) + where ppr_alt (L _ (GRHS _ guards expr)) = + hang vbar 2 (ppr_one one_alt) + where + ppr_one [] = panic "ppr_exp HsMultiIf" + ppr_one (h:t) = hang h 2 (sep t) + one_alt = [ interpp'SP guards + , text "->" <+> pprDeeper (ppr expr) ] + ppr_alt (L _ (XGRHS x)) = ppr x + +-- special case: let ... in let ... +ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lexpr expr] + +ppr_expr (HsLet _ (L _ binds) expr) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr expr)] + +ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts + +ppr_expr (ExplicitList _ _ exprs) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) + = hang (ppr con_id) 2 (ppr rbinds) + +ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) + = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + +ppr_expr (ExprWithTySig _ expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) + +ppr_expr (HsSpliceE _ s) = pprSplice s +ppr_expr (HsBracket _ b) = pprHsBracket b +ppr_expr (HsRnBracketOut _ e []) = ppr e +ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps +ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e +ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps) + +ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] + +ppr_expr (HsStatic _ e) + = hsep [text "static", ppr e] + +ppr_expr (HsTick _ tickish exp) + = pprTicks (ppr exp) $ + ppr tickish <+> ppr_lexpr exp +ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) + = pprTicks (ppr exp) $ + hcat [text "bintick<", + ppr tickIdTrue, + text ",", + ppr tickIdFalse, + text ">(", + ppr exp, text ")"] + +ppr_expr (HsRecFld _ f) = ppr f +ppr_expr (XExpr x) = case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> ppr x +#endif + GhcRn -> ppr x + GhcTc -> case x of + WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn + (\parens -> if parens then pprExpr e else pprExpr e) + ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original + -- expression (LHsExpr GhcPs), not the + -- desugared one (LHsExpr GhcT). + +ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) +ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) +ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) +ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ) +ppr_infix_expr (XExpr x) = case (ghcPass @p, x) of + (GhcPs, _) -> Nothing + (GhcRn, HsExpanded a _) -> ppr_infix_expr a + (GhcTc, WrapExpr (HsWrap _ e)) -> ppr_infix_expr e + (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a +ppr_infix_expr _ = Nothing + +ppr_apps :: (OutputableBndrId p) + => HsExpr (GhcPass p) + -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] + -> SDoc +ppr_apps (HsApp _ (L _ fun) arg) args + = ppr_apps fun (Left arg : args) +ppr_apps (HsAppType _ (L _ fun) arg) args + = ppr_apps fun (Right arg : args) +ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) + where + pp (Left arg) = ppr arg + -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) + -- = char '@' <> pprHsType arg + pp (Right arg) + = text "@" <> ppr arg + +pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc +pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) + = ppr (src,(n1,n2),(n3,n4)) + +{- +HsSyn records exactly where the user put parens, with HsPar. +So generally speaking we print without adding any parens. +However, some code is internally generated, and in some places +parens are absolutely required; so for these places we use +pprParendLExpr (but don't print double parens of course). + +For operator applications we don't add parens, because the operator +fixities should do the job, except in debug mode (-dppr-debug) so we +can see the structure of the parse tree. +-} + +pprDebugParendExpr :: (OutputableBndrId p) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprDebugParendExpr p expr + = getPprDebug $ \case + True -> pprParendLExpr p expr + False -> pprLExpr expr + +pprParendLExpr :: (OutputableBndrId p) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprParendLExpr p (L _ e) = pprParendExpr p e + +pprParendExpr :: (OutputableBndrId p) + => PprPrec -> HsExpr (GhcPass p) -> SDoc +pprParendExpr p expr + | hsExprNeedsParens p expr = parens (pprExpr expr) + | otherwise = pprExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + +-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs +-- parentheses under precedence @p@. +hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool +hsExprNeedsParens p = go + where + go (HsVar{}) = False + go (HsUnboundVar{}) = False + go (HsConLikeOut{}) = False + go (HsIPVar{}) = False + go (HsOverLabel{}) = False + go (HsLit _ l) = hsLitNeedsParens p l + go (HsOverLit _ ol) = hsOverLitNeedsParens p ol + go (HsPar{}) = False + go (HsApp{}) = p >= appPrec + go (HsAppType {}) = p >= appPrec + go (OpApp{}) = p >= opPrec + go (NegApp{}) = p > topPrec + go (SectionL{}) = True + go (SectionR{}) = True + go (ExplicitTuple{}) = False + go (ExplicitSum{}) = False + go (HsLam{}) = p > topPrec + go (HsLamCase{}) = p > topPrec + go (HsCase{}) = p > topPrec + go (HsIf{}) = p > topPrec + go (HsMultiIf{}) = p > topPrec + go (HsLet{}) = p > topPrec + go (HsDo _ sc _) + | isComprehensionContext sc = False + | otherwise = p > topPrec + go (ExplicitList{}) = False + go (RecordUpd{}) = False + go (ExprWithTySig{}) = p >= sigPrec + go (ArithSeq{}) = False + go (HsPragE{}) = p >= appPrec + go (HsSpliceE{}) = False + go (HsBracket{}) = False + go (HsRnBracketOut{}) = False + go (HsTcBracketOut{}) = False + go (HsProc{}) = p > topPrec + go (HsStatic{}) = p >= appPrec + go (HsTick _ _ (L _ e)) = go e + go (HsBinTick _ _ _ (L _ e)) = go e + go (RecordCon{}) = False + go (HsRecFld{}) = False + go (XExpr x) + | GhcTc <- ghcPass @p + = case x of + WrapExpr (HsWrap _ e) -> go e + ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a + | GhcRn <- ghcPass @p + = case x of HsExpanded a _ -> hsExprNeedsParens p a + | otherwise + = True + + +-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, +-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. +parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +parenthesizeHsExpr p le@(L loc e) + | hsExprNeedsParens p e = L loc (HsPar noExtField le) + | otherwise = le + +stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e +stripParensLHsExpr e = e + +stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p) +stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e +stripParensHsExpr e = e + +isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool +-- True of a single token +isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsConLikeOut {}) = True +isAtomicHsExpr (HsLit {}) = True +isAtomicHsExpr (HsOverLit {}) = True +isAtomicHsExpr (HsIPVar {}) = True +isAtomicHsExpr (HsOverLabel {}) = True +isAtomicHsExpr (HsUnboundVar {}) = True +isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr (HsRecFld{}) = True +isAtomicHsExpr (XExpr x) + | GhcTc <- ghcPass @p = case x of + WrapExpr (HsWrap _ e) -> isAtomicHsExpr e + ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a + | GhcRn <- ghcPass @p = case x of + HsExpanded a _ -> isAtomicHsExpr a +isAtomicHsExpr _ = False + +instance Outputable (HsPragE (GhcPass p)) where + ppr (HsPragSCC _ st (StringLiteral stl lbl)) = + pprWithSourceText st (text "{-# SCC") + -- no doublequotes if stl empty, for the case where the SCC was written + -- without quotes. + <+> pprWithSourceText stl (ftext lbl) <+> text "#-}" + ppr (HsPragTick _ st (StringLiteral sta s, (v1,v2), (v3,v4)) ((s1,s2),(s3,s4))) = + pprWithSourceText st (text "{-# GENERATED") + <+> pprWithSourceText sta (doubleQuotes $ ftext s) + <+> pprWithSourceText s1 (ppr v1) <+> char ':' <+> pprWithSourceText s2 (ppr v2) + <+> char '-' + <+> pprWithSourceText s3 (ppr v3) <+> char ':' <+> pprWithSourceText s4 (ppr v4) + <+> text "#-}" + +{- +************************************************************************ +* * +\subsection{Commands (in arrow abstractions)} +* * +************************************************************************ + +We re-use HsExpr to represent these. +-} + +-- | Located Haskell Command (for arrow syntax) +type LHsCmd id = Located (HsCmd id) + +-- | Haskell Command (e.g. a "statement" in an Arrow proc block) +data HsCmd id + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.Annlarrowtail', + -- 'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail', + -- 'GHC.Parser.Annotation.AnnRarrowtail' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (XCmdArrApp id) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@, + -- 'GHC.Parser.Annotation.AnnCloseB' @'|)'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XCmdArrForm id) + (LHsExpr id) -- The operator. + -- After type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + LexicalFixity -- Whether the operator appeared prefix or infix when + -- parsed. + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands + + | HsCmdApp (XCmdApp id) + (LHsCmd id) + (LHsExpr id) + + | HsCmdLam (XCmdLam id) + (MatchGroup id (LHsCmd id)) -- kappa + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', + -- 'GHC.Parser.Annotation.AnnRarrow', + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsCmdPar (XCmdPar id) + (LHsCmd id) -- parenthesised command + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, + -- 'GHC.Parser.Annotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsCmdCase (XCmdCase id) + (LHsExpr id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', + -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsCmdLamCase (XCmdLamCase id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', + -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsCmdIf (XCmdIf id) + (SyntaxExpr id) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf', + -- 'GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnElse', + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsCmdLet (XCmdLet id) + (LHsLocalBinds id) -- let(rec) + (LHsCmd id) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', + -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsCmdDo (XCmdDo id) -- Type of the whole expression + (Located [CmdLStmt id]) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', + -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi', + -- 'GHC.Parser.Annotation.AnnVbar', + -- 'GHC.Parser.Annotation.AnnClose' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | XCmd !(XXCmd id) -- Note [Trees that Grow] extension point + +type instance XCmdArrApp GhcPs = NoExtField +type instance XCmdArrApp GhcRn = NoExtField +type instance XCmdArrApp GhcTc = Type + +type instance XCmdArrForm (GhcPass _) = NoExtField +type instance XCmdApp (GhcPass _) = NoExtField +type instance XCmdLam (GhcPass _) = NoExtField +type instance XCmdPar (GhcPass _) = NoExtField +type instance XCmdCase (GhcPass _) = NoExtField +type instance XCmdLamCase (GhcPass _) = NoExtField +type instance XCmdIf (GhcPass _) = NoExtField +type instance XCmdLet (GhcPass _) = NoExtField + +type instance XCmdDo GhcPs = NoExtField +type instance XCmdDo GhcRn = NoExtField +type instance XCmdDo GhcTc = Type + +type instance XCmdWrap (GhcPass _) = NoExtField + +type instance XXCmd GhcPs = NoExtCon +type instance XXCmd GhcRn = NoExtCon +type instance XXCmd GhcTc = HsWrap HsCmd + -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res + +-- | Haskell Array Application Type +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving Data + + +{- | Top-level command, introducing a new arrow. +This may occur inside a proc (where the stack is empty) or as an +argument of a command-forming operator. +-} + +-- | Located Haskell Top-level Command +type LHsCmdTop p = Located (HsCmdTop p) + +-- | Haskell Top-level Command +data HsCmdTop p + = HsCmdTop (XCmdTop p) + (LHsCmd p) + | XCmdTop !(XXCmdTop p) -- Note [Trees that Grow] extension point + +data CmdTopTc + = CmdTopTc Type -- Nested tuple of inputs on the command's stack + Type -- return type of the command + (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + +type instance XCmdTop GhcPs = NoExtField +type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] +type instance XCmdTop GhcTc = CmdTopTc + +type instance XXCmdTop (GhcPass _) = NoExtCon + +instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar {}) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp {}) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc +ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp _ c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map ppr args)) + where + collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_cmd (HsCmdLam _ matches) + = pprMatches matches + +ppr_cmd (HsCmdCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdLamCase _ matches) + = sep [ text "\\case", nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdIf _ _ e ct ce) + = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], + nest 4 (ppr ct), + text "else", + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet _ (L _ binds) cmd) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr cmd)] + +ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts + +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ op _ _ args) + = hang (text "(|" <+> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") +ppr_cmd (XCmd x) = case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> ppr x + GhcRn -> ppr x +#endif + GhcTc -> case x of + HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) + +pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg (HsCmdTop _ cmd) + = ppr_lcmd cmd + +instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where + ppr = pprCmdArg + +{- +************************************************************************ +* * +\subsection{Record binds} +* * +************************************************************************ +-} + +-- | Haskell Record Bindings +type HsRecordBinds p = HsRecFields p (LHsExpr p) + +{- +************************************************************************ +* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +* * +************************************************************************ + +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. +-} + +data MatchGroup p body + = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result + , mg_alts :: Located [LMatch p body] -- The alternatives + , mg_origin :: Origin } + -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + | XMatchGroup !(XXMatchGroup p body) + +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + } deriving Data + +type instance XMG GhcPs b = NoExtField +type instance XMG GhcRn b = NoExtField +type instance XMG GhcTc b = MatchGroupTc + +type instance XXMatchGroup (GhcPass _) b = NoExtCon + +-- | Located Match +type LMatch id body = Located (Match id body) +-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in GHC.Parser.Annotation +data Match p body + = Match { + m_ext :: XCMatch p body, + m_ctxt :: HsMatchContext (NoGhcTc p), + -- See note [m_ctxt in Match] + m_pats :: [LPat p], -- The patterns + m_grhss :: (GRHSs p body) + } + | XMatch !(XXMatch p body) + +type instance XCMatch (GhcPass _) b = NoExtField +type instance XXMatch (GhcPass _) b = NoExtCon + +instance (OutputableBndrId pr, Outputable body) + => Outputable (Match (GhcPass pr) body) where + ppr = pprMatch + +{- +Note [m_ctxt in Match] +~~~~~~~~~~~~~~~~~~~~~~ + +A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and +so on. + +In order to simplify tooling processing and pretty print output, the provenance +is captured in an HsMatchContext. + +This is particularly important for the API Annotations for a multi-equation +FunBind. + +The parser initially creates a FunBind with a single Match in it for +every function definition it sees. + +These are then grouped together by getMonoBind into a single FunBind, +where all the Matches are combined. + +In the process, all the original FunBind fun_id's bar one are +discarded, including the locations. + +This causes a problem for source to source conversions via API +Annotations, so the original fun_ids and infix flags are preserved in +the Match, when it originates from a FunBind. + +Example infix function definition requiring individual API Annotations + + (&&& ) [] [] = [] + xs &&& [] = xs + ( &&& ) [] ys = ys + + + +-} + + +isInfixMatch :: Match id body -> Bool +isInfixMatch match = case m_ctxt match of + FunRhs {mc_fixity = Infix} -> True + _ -> False + +isEmptyMatchGroup :: MatchGroup id body -> Bool +isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms +isEmptyMatchGroup (XMatchGroup {}) = False + +-- | Is there only one RHS in this list of matches? +isSingletonMatchGroup :: [LMatch id body] -> Bool +isSingletonMatchGroup matches + | [L _ match] <- matches + , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match + = True + | otherwise + = False + +matchGroupArity :: MatchGroup (GhcPass id) body -> Arity +-- Precondition: MatchGroup is non-empty +-- This is called before type checking, when mg_arg_tys is not set +matchGroupArity (MG { mg_alts = alts }) + | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) + | otherwise = panic "matchGroupArity" + +hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] +hsLMatchPats (L _ (Match { m_pats = pats })) = pats + +-- | Guarded Right-Hand Sides +-- +-- GRHSs are used both for pattern bindings and for Matches +-- +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar', +-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', +-- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' +-- 'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi' + +-- For details on above see note [Api annotations] in GHC.Parser.Annotation +data GRHSs p body + = GRHSs { + grhssExt :: XCGRHSs p body, + grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs + grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause + } + | XGRHSs !(XXGRHSs p body) + +type instance XCGRHSs (GhcPass _) b = NoExtField +type instance XXGRHSs (GhcPass _) b = NoExtCon + +-- | Located Guarded Right-Hand Side +type LGRHS id body = Located (GRHS id body) + +-- | Guarded Right Hand Side. +data GRHS p body = GRHS (XCGRHS p body) + [GuardLStmt p] -- Guards + body -- Right hand side + | XGRHS !(XXGRHS p body) + +type instance XCGRHS (GhcPass _) b = NoExtField +type instance XXGRHS (GhcPass _) b = NoExtCon + +-- We know the list must have at least one @Match@ in it. + +pprMatches :: (OutputableBndrId idR, Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprMatches MG { mg_alts = matches } + = vcat (map pprMatch (map unLoc (unLoc matches))) + -- Don't print the type; it's only a place-holder before typechecking + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprFunBind :: (OutputableBndrId idR, Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind matches = pprMatches matches + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprPatBind :: forall bndr p body. (OutputableBndrId bndr, + OutputableBndrId p, + Outputable body) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc +pprPatBind pat (grhss) + = sep [ppr pat, + nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)] + +pprMatch :: (OutputableBndrId idR, Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss }) + = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) + , nest 2 (pprGRHSs ctxt grhss) ] + where + (herald, other_pats) + = case ctxt of + FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} + | SrcStrict <- strictness + -> ASSERT(null pats) -- A strict variable binding + (char '!'<>pprPrefixOcc fun, pats) + + | Prefix <- fixity + -> (pprPrefixOcc fun, pats) -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + | otherwise + -> case pats of + (p1:p2:rest) + | null rest -> (pp_infix, []) -- x &&& y = e + | otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e + where + pp_infix = pprParendLPat opPrec p1 + <+> pprInfixOcc fun + <+> pprParendLPat opPrec p2 + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) + + LambdaExpr -> (char '\\', pats) + + _ -> case pats of + [] -> (empty, []) + [pat] -> (ppr pat, []) -- No parens around the single pat in a case + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) + +pprGRHSs :: (OutputableBndrId idR, Outputable body) + => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc +pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) + = vcat (map (pprGRHS ctxt . unLoc) grhss) + -- Print the "where" even if the contents of the binds is empty. Only + -- EmptyLocalBinds means no "where" keyword + $$ ppUnless (eqEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) + +pprGRHS :: (OutputableBndrId idR, Outputable body) + => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc +pprGRHS ctxt (GRHS _ [] body) + = pp_rhs ctxt body + +pprGRHS ctxt (GRHS _ guards body) + = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] + +pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) + +{- +************************************************************************ +* * +\subsection{Do stmts and list comprehensions} +* * +************************************************************************ +-} + +-- | Located @do@ block Statement +type LStmt id body = Located (StmtLR id id body) + +-- | Located Statement with separate Left and Right id's +type LStmtLR idL idR body = Located (StmtLR idL idR body) + +-- | @do@ block Statement +type Stmt id body = StmtLR id id body + +-- | Command Located Statement +type CmdLStmt id = LStmt id (LHsCmd id) + +-- | Command Statement +type CmdStmt id = Stmt id (LHsCmd id) + +-- | Expression Located Statement +type ExprLStmt id = LStmt id (LHsExpr id) + +-- | Expression Statement +type ExprStmt id = Stmt id (LHsExpr id) + +-- | Guard Located Statement +type GuardLStmt id = LStmt id (LHsExpr id) + +-- | Guard Statement +type GuardStmt id = Stmt id (LHsExpr id) + +-- | Ghci Located Statement +type GhciLStmt id = LStmt id (LHsExpr id) + +-- | Ghci Statement +type GhciStmt id = Stmt id (LHsExpr id) + +-- The SyntaxExprs in here are used *only* for do-notation and monad +-- comprehensions, which have rebindable syntax. Otherwise they are unused. +-- | API Annotations when in qualifier lists or guards +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar', +-- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnThen', +-- 'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy', +-- 'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing' + +-- For details on above see note [Api annotations] in GHC.Parser.Annotation +data StmtLR idL idR body -- body should always be (LHs**** idR) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, + -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr + -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + (XLastStmt idL idR body) + body + (Maybe Bool) -- Whether return was stripped + -- Just True <=> return with a dollar was stripped by ApplicativeDo + -- Just False <=> return without a dollar was stripped by ApplicativeDo + -- Nothing <=> Nothing was stripped + (SyntaxExpr idR) -- The return operator + -- The return operator is used only for MonadComp + -- For ListComp we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't apply a 'return' at all + -- See Note [Monad Comprehensions] + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | BindStmt (XBindStmt idL idR body) + -- ^ Post renaming has optional fail and bind / (>>=) operator. + -- Post typechecking, also has multiplicity of the argument + -- and the result type of the function passed to bind; + -- that is, (P, S) in (>>=) :: Q -> (R # P -> S) -> T + -- See Note [The type of bind in Stmts] + (LPat idL) + body + + -- | 'ApplicativeStmt' represents an applicative expression built with + -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the + -- appropriate applicative expression by the desugarer, but it is intended + -- to be invisible in error messages. + -- + -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr" + -- + | ApplicativeStmt + (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body + [ ( SyntaxExpr idR + , ApplicativeArg idL) ] + -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] + (Maybe (SyntaxExpr idR)) -- 'join', if necessary + + | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type + -- of the RHS (used for arrows) + body -- See Note [BodyStmt] + (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] + + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet' + -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@, + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) + + -- ParStmts only occur in a list/monad comprehension + | ParStmt (XParStmt idL idR body) -- Post typecheck, + -- S in (>>=) :: Q -> (R -> S) -> T + [ParStmtBlock idL idR] + (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after themp + + | TransStmt { + trS_ext :: XTransStmt idL idR body, -- Post typecheck, + -- R in (>>=) :: Q -> (R -> S) -> T + trS_form :: TransForm, + trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] + + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e + + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + -- Just a simple HsExpr, because it's + -- too polymorphic for tcSyntaxOp + } -- See Note [Monad Comprehensions] + + -- Recursive statement (see Note [How RecStmt works] below) + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | RecStmt + { recS_ext :: XRecStmt idL idR body + , recS_stmts :: [LStmtLR idL idR body] + + -- The next two fields are only valid after renaming + , recS_later_ids :: [IdP idR] + -- The ids are a subset of the variables bound by the + -- stmts that are used in stmts that follow the RecStmt + + , recS_rec_ids :: [IdP idR] + -- Ditto, but these variables are the "recursive" ones, + -- that are used before they are bound in the stmts of + -- the RecStmt. + -- An Id can be in both groups + -- Both sets of Ids are (now) treated monomorphically + -- See Note [How RecStmt works] for why they are separate + + -- Rebindable syntax + , recS_bind_fn :: SyntaxExpr idR -- The bind function + , recS_ret_fn :: SyntaxExpr idR -- The return function + , recS_mfix_fn :: SyntaxExpr idR -- The mfix function + } + | XStmtLR !(XXStmtLR idL idR body) + +-- Extra fields available post typechecking for RecStmt. +data RecStmtTc = + RecStmtTc + { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. + -- They may not quite be the Ids themselves, + -- because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*, + -- so they may be type applications + + , recS_ret_ty :: Type -- The type of + -- do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). + } + + +type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField + +type instance XBindStmt (GhcPass _) GhcPs b = NoExtField +type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn +type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc + +data XBindStmtRn = XBindStmtRn + { xbsrn_bindOp :: SyntaxExpr GhcRn + , xbsrn_failOp :: FailOperator GhcRn + } + +data XBindStmtTc = XBindStmtTc + { xbstc_bindOp :: SyntaxExpr GhcTc + , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S + , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S + , xbstc_failOp :: FailOperator GhcTc + } + +type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcTc b = Type + +type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField +type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField +type instance XBodyStmt (GhcPass _) GhcTc b = Type + +type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField + +type instance XParStmt (GhcPass _) GhcPs b = NoExtField +type instance XParStmt (GhcPass _) GhcRn b = NoExtField +type instance XParStmt (GhcPass _) GhcTc b = Type + +type instance XTransStmt (GhcPass _) GhcPs b = NoExtField +type instance XTransStmt (GhcPass _) GhcRn b = NoExtField +type instance XTransStmt (GhcPass _) GhcTc b = Type + +type instance XRecStmt (GhcPass _) GhcPs b = NoExtField +type instance XRecStmt (GhcPass _) GhcRn b = NoExtField +type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc + +type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e (depending on trS_by) + | GroupForm -- then group using f or then group by e using f (depending on trS_by) + deriving Data + +-- | Parenthesised Statement Block +data ParStmtBlock idL idR + = ParStmtBlock + (XParStmtBlock idL idR) + [ExprLStmt idL] + [IdP idR] -- The variables to be returned + (SyntaxExpr idR) -- The return operator + | XParStmtBlock !(XXParStmtBlock idL idR) + +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon + +-- | The fail operator +-- +-- This is used for `.. <-` "bind statments" in do notation, including +-- non-monadic "binds" in applicative. +-- +-- The fail operator is 'Just expr' if it potentially fail monadically. if the +-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete +-- pattern exception), it is 'Nothing'. +-- +-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of +-- expression in the 'Just' case, and why it is so. +-- +-- See Note [Failing pattern matches in Stmts] for which contexts for +-- '@BindStmt@'s should use the monadic fail and which shouldn't. +type FailOperator id = Maybe (SyntaxExpr id) + +-- | Applicative Argument +data ApplicativeArg idL + = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) + { xarg_app_arg_one :: XApplicativeArgOne idL + -- ^ The fail operator, after renaming + -- + -- The fail operator is needed if this is a BindStmt + -- where the pattern can fail. E.g.: + -- (Just a) <- stmt + -- The fail operator will be invoked if the pattern + -- match fails. + -- It is also used for guards in MonadComprehensions. + -- The fail operator is Nothing + -- if the pattern match can't fail + , app_arg_pattern :: LPat idL -- WildPat if it was a BodyStmt (see below) + , arg_expr :: LHsExpr idL + , is_body_stmt :: Bool + -- ^ True <=> was a BodyStmt, + -- False <=> was a BindStmt. + -- See Note [Applicative BodyStmt] + } + | ApplicativeArgMany -- do { stmts; return vars } + { xarg_app_arg_many :: XApplicativeArgMany idL + , app_stmts :: [ExprLStmt idL] -- stmts + , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn) + , bv_pattern :: LPat idL -- (v1,...,vn) + , stmt_context :: HsStmtContext GhcRn -- context of the do expression + -- used in pprArg + } + | XApplicativeArg !(XXApplicativeArg idL) + +type instance XApplicativeArgOne GhcPs = NoExtField +type instance XApplicativeArgOne GhcRn = FailOperator GhcRn +type instance XApplicativeArgOne GhcTc = FailOperator GhcTc + +type instance XApplicativeArgMany (GhcPass _) = NoExtField +type instance XXApplicativeArg (GhcPass _) = NoExtCon + +{- +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + +Note [TransStmt binder map] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The [(idR,idR)] in a TransStmt behaves as follows: + + * Before renaming: [] + + * After renaming: + [ (x27,x27), ..., (z35,z35) ] + These are the variables + bound by the stmts to the left of the 'group' + and used either in the 'by' clause, + or in the stmts following the 'group' + Each item is a pair of identical variables. + + * After typechecking: + [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] + Each pair has the same unique, but different *types*. + +Note [BodyStmt] +~~~~~~~~~~~~~~~ +BodyStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E any_ty: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] + E :: Bool + Translation: if E then fail else ... + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + +Array comprehensions are handled like list comprehensions. + +Note [How RecStmt works] +~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + HsDo [ BindStmt x ex + + , RecStmt { recS_rec_ids = [a, c] + , recS_stmts = [ BindStmt b (return (a,c)) + , LetStmt a = ...b... + , BindStmt c ec ] + , recS_later_ids = [a, b] + + , return (a b) ] + +Here, the RecStmt binds a,b,c; but + - Only a,b are used in the stmts *following* the RecStmt, + - Only a,c are used in the stmts *inside* the RecStmt + *before* their bindings + +Why do we need *both* rec_ids and later_ids? For monads they could be +combined into a single set of variables, but not for arrows. That +follows from the types of the respective feedback operators: + + mfix :: MonadFix m => (a -> m a) -> m a + loop :: ArrowLoop a => a (b,d) (c,d) -> a b c + +* For mfix, the 'a' covers the union of the later_ids and the rec_ids +* For 'loop', 'c' is the later_ids and 'd' is the rec_ids + +Note [Typing a RecStmt] +~~~~~~~~~~~~~~~~~~~~~~~ +A (RecStmt stmts) types as if you had written + + (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> + do { stmts + ; return (v1,..vn, r1, ..., rm) }) + +where v1..vn are the later_ids + r1..rm are the rec_ids + +Note [Monad Comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Monad comprehensions require separate functions like 'return' and +'>>=' for desugaring. These functions are stored in the statements +used in monad comprehensions. For example, the 'return' of the 'LastStmt' +expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + +In transform and grouping statements ('then ..' and 'then group ..') the +'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + +BodyStmts require the 'Control.Monad.guard' function for boolean +expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + +Parallel statements require the 'Control.Monad.Zip.mzip' function: + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + +In any other context than 'MonadComp', the fields for most of these +'SyntaxExpr's stay bottom. + + +Note [Applicative BodyStmt] + +(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt +as if it was a BindStmt with a wildcard pattern. For example, + + do + x <- A + B + return x + +is transformed as if it were + + do + x <- A + _ <- B + return x + +so it transforms to + + (\(x,_) -> x) <$> A <*> B + +But we have to remember when we treat a BodyStmt like a BindStmt, +because in error messages we want to emit the original syntax the user +wrote, not our internal representation. So ApplicativeArgOne has a +Bool flag that is True when the original statement was a BodyStmt, so +that we can pretty-print it correctly. +-} + +instance (Outputable (StmtLR idL idL (LHsExpr idL)), + Outputable (XXParStmtBlock idL idR)) + => Outputable (ParStmtBlock idL idR) where + ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts + ppr (XParStmtBlock x) = ppr x + +instance (OutputableBndrId pl, OutputableBndrId pr, + Outputable body) + => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where + ppr stmt = pprStmt stmt + +pprStmt :: forall idL idR body . (OutputableBndrId idL, + OutputableBndrId idR, + Outputable body) + => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc +pprStmt (LastStmt _ expr m_dollar_stripped _) + = whenPprDebug (text "[last]") <+> + (case m_dollar_stripped of + Just True -> text "return $" + Just False -> text "return" + Nothing -> empty) <+> + ppr expr +pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr] +pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] +pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) + +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by + , trS_using = using, trS_form = form }) + = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + +pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids + , recS_later_ids = later_ids }) + = text "rec" <+> + vcat [ ppr_do_stmts segment + , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids + , text "later_ids=" <> ppr later_ids])] + +pprStmt (ApplicativeStmt _ args mb_join) + = getPprStyle $ \style -> + if userStyle style + then pp_for_user + else pp_debug + where + -- make all the Applicative stuff invisible in error messages by + -- flattening the whole ApplicativeStmt nest back to a sequence + -- of statements. + pp_for_user = vcat $ concatMap flattenArg args + + -- ppr directly rather than transforming here, because we need to + -- inject a "return" which is hard when we're polymorphic in the id + -- type. + flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] + flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args + flattenStmt stmt = [ppr stmt] + + flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] + flattenArg (_, ApplicativeArgOne _ pat expr isBody) + | isBody = -- See Note [Applicative BodyStmt] + [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL))] + | otherwise = + [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))] + flattenArg (_, ApplicativeArgMany _ stmts _ _ _) = + concatMap flattenStmt stmts + + pp_debug = + let + ap_expr = sep (punctuate (text " |") (map pp_arg args)) + in + whenPprDebug (if isJust mb_join then text "[join]" else empty) <+> + (if lengthAtLeast args 2 then parens else id) ap_expr + + pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc + pp_arg (_, applicativeArg) = ppr applicativeArg + + +instance (OutputableBndrId idL) + => Outputable (ApplicativeArg (GhcPass idL)) where + ppr = pprArg + +pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc +pprArg (ApplicativeArgOne _ pat expr isBody) + | isBody = -- See Note [Applicative BodyStmt] + ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL)) + | otherwise = + ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL)) +pprArg (ApplicativeArgMany _ stmts return pat ctxt) = + ppr pat <+> + text "<-" <+> + ppr (HsDo (panic "pprStmt") ctxt (noLoc + (stmts ++ + [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]))) + +pprTransformStmt :: (OutputableBndrId p) + => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) + -> Maybe (LHsExpr (GhcPass p)) -> SDoc +pprTransformStmt bndrs using by + = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) + , nest 2 (ppr using) + , nest 2 (pprBy by)] + +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc +pprTransStmt by using ThenForm + = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by using GroupForm + = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] + +pprBy :: Outputable body => Maybe body -> SDoc +pprBy Nothing = empty +pprBy (Just e) = text "by" <+> ppr e + +pprDo :: (OutputableBndrId p, Outputable body) + => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc +pprDo (DoExpr m) stmts = + ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts +pprDo (MDoExpr m) stmts = + ppr_module_name_prefix m <> text "mdo" <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +ppr_module_name_prefix :: Maybe ModuleName -> SDoc +ppr_module_name_prefix = \case + Nothing -> empty + Just module_name -> ppr module_name <> char '.' + +ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, + Outputable body) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc +-- Print a bunch of do stmts +ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) + +pprComp :: (OutputableBndrId p, Outputable body) + => [LStmt (GhcPass p) body] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals + = if null initStmts + -- If there are no statements in a list comprehension besides the last + -- one, we simply treat it like a normal list. This does arise + -- occasionally in code that GHC generates, e.g., in implementations of + -- 'range' for derived 'Ix' instances for product datatypes with exactly + -- one constructor (e.g., see #12583). + then ppr body + else hang (ppr body <+> vbar) 2 (pprQuals initStmts) + | otherwise + = pprPanic "pprComp" (pprQuals quals) + +pprQuals :: (OutputableBndrId p, Outputable body) + => [LStmt (GhcPass p) body] -> SDoc +-- Show list comprehension qualifiers separated by commas +pprQuals quals = interpp'SP quals + +{- +************************************************************************ +* * + Template Haskell quotation brackets +* * +************************************************************************ +-} + +-- | Haskell Splice +data HsSplice id + = HsTypedSplice -- $$z or $$(f 4) + (XTypedSplice id) + SpliceDecoration -- Whether $$( ) variant found, for pretty printing + (IdP id) -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + + | HsUntypedSplice -- $z or $(f 4) + (XUntypedSplice id) + SpliceDecoration -- Whether $( ) variant found, for pretty printing + (IdP id) -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + + | HsQuasiQuote -- See Note [Quasi-quote overview] in GHC.Tc.Gen.Splice + (XQuasiQuote id) + (IdP id) -- Splice point + (IdP id) -- Quoter + SrcSpan -- The span of the enclosed string + FastString -- The enclosed string + + -- AZ:TODO: use XSplice instead of HsSpliced + | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in + -- GHC.Rename.Splice. + -- This is the result of splicing a splice. It is produced by + -- the renamer and consumed by the typechecker. It lives only + -- between the two. + (XSpliced id) + ThModFinalizers -- TH finalizers produced by the splice. + (HsSplicedThing id) -- The result of splicing + | XSplice !(XXSplice id) -- Note [Trees that Grow] extension point + +newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data) + +type instance XTypedSplice (GhcPass _) = NoExtField +type instance XUntypedSplice (GhcPass _) = NoExtField +type instance XQuasiQuote (GhcPass _) = NoExtField +type instance XSpliced (GhcPass _) = NoExtField +type instance XXSplice GhcPs = NoExtCon +type instance XXSplice GhcRn = NoExtCon +type instance XXSplice GhcTc = HsSplicedT + +-- | A splice can appear with various decorations wrapped around it. This data +-- type captures explicitly how it was originally written, for use in the pretty +-- printer. +data SpliceDecoration + = DollarSplice -- ^ $splice or $$splice + | BareSplice -- ^ bare splice + deriving (Data, Eq, Show) + +instance Outputable SpliceDecoration where + ppr x = text $ show x + + +isTypedSplice :: HsSplice id -> Bool +isTypedSplice (HsTypedSplice {}) = True +isTypedSplice _ = False -- Quasi-quotes are untyped splices + +-- | Finalizers produced by a splice with +-- 'Language.Haskell.TH.Syntax.addModFinalizer' +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how +-- this is used. +-- +newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] + +-- A Data instance which ignores the argument of 'ThModFinalizers'. +instance Data ThModFinalizers where + gunfold _ z _ = z $ ThModFinalizers [] + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] + +-- See Note [Running typed splices in the zonker] +-- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice` +data DelayedSplice = + DelayedSplice + TcLclEnv -- The local environment to run the splice in + (LHsExpr GhcRn) -- The original renamed expression + TcType -- The result type of running the splice, unzonked + (LHsExpr GhcTc) -- The typechecked expression to run and splice in the result + +-- A Data instance which ignores the argument of 'DelayedSplice'. +instance Data DelayedSplice where + gunfold _ _ _ = panic "DelayedSplice" + toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] + +-- | Haskell Spliced Thing +-- +-- Values that can result from running a splice. +data HsSplicedThing id + = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression + | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type + | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern + + +-- See Note [Pending Splices] +type SplicePointName = Name + +-- | Pending Renamer Splice +data PendingRnSplice + = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) + +data UntypedSpliceFlavour + = UntypedExpSplice + | UntypedPatSplice + | UntypedTypeSplice + | UntypedDeclSplice + deriving Data + +-- | Pending Type-checker Splice +data PendingTcSplice + = PendingTcSplice SplicePointName (LHsExpr GhcTc) + +{- +Note [Pending Splices] +~~~~~~~~~~~~~~~~~~~~~~ +When we rename an untyped bracket, we name and lift out all the nested +splices, so that when the typechecker hits the bracket, it can +typecheck those nested splices without having to walk over the untyped +bracket code. So for example + [| f $(g x) |] +looks like + + HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) + +which the renamer rewrites to + + HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) + [PendingRnSplice UntypedExpSplice sn (g x)] + +* The 'sn' is the Name of the splice point, the SplicePointName + +* The PendingRnExpSplice gives the splice that splice-point name maps to; + and the typechecker can now conveniently find these sub-expressions + +* The other copy of the splice, in the second argument of HsSpliceE + in the renamed first arg of HsRnBracketOut + is used only for pretty printing + +There are four varieties of pending splices generated by the renamer, +distinguished by their UntypedSpliceFlavour + + * Pending expression splices (UntypedExpSplice), e.g., + [|$(f x) + 2|] + + UntypedExpSplice is also used for + * quasi-quotes, where the pending expression expands to + $(quoter "...blah...") + (see GHC.Rename.Splice.makePending, HsQuasiQuote case) + + * cross-stage lifting, where the pending expression expands to + $(lift x) + (see GHC.Rename.Splice.checkCrossStageLifting) + + * Pending pattern splices (UntypedPatSplice), e.g., + [| \$(f x) -> x |] + + * Pending type splices (UntypedTypeSplice), e.g., + [| f :: $(g x) |] + + * Pending declaration (UntypedDeclSplice), e.g., + [| let $(f x) in ... |] + +There is a fifth variety of pending splice, which is generated by the type +checker: + + * Pending *typed* expression splices, (PendingTcSplice), e.g., + [||1 + $$(f 2)||] + +It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the +output of the renamer. However, when pretty printing the output of the renamer, +e.g., in a type error message, we *do not* want to print out the pending +splices. In contrast, when pretty printing the output of the type checker, we +*do* want to print the pending splices. So splitting them up seems to make +sense, although I hate to add another constructor to HsExpr. +-} + +instance OutputableBndrId p + => Outputable (HsSplicedThing (GhcPass p)) where + ppr (HsSplicedExpr e) = ppr_expr e + ppr (HsSplicedTy t) = ppr t + ppr (HsSplicedPat p) = ppr p + +instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where + ppr s = pprSplice s + +pprPendingSplice :: (OutputableBndrId p) + => SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e)) + +pprSpliceDecl :: (OutputableBndrId p) + => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e +pprSpliceDecl e ExplicitSplice = text "$" <> ppr_splice_decl e +pprSpliceDecl e ImplicitSplice = ppr_splice_decl e + +ppr_splice_decl :: (OutputableBndrId p) + => HsSplice (GhcPass p) -> SDoc +ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty +ppr_splice_decl e = pprSplice e + +pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc +pprSplice (HsTypedSplice _ DollarSplice n e) + = ppr_splice (text "$$") n e empty +pprSplice (HsTypedSplice _ BareSplice _ _ ) + = panic "Bare typed splice" -- impossible +pprSplice (HsUntypedSplice _ DollarSplice n e) + = ppr_splice (text "$") n e empty +pprSplice (HsUntypedSplice _ BareSplice n e) + = ppr_splice empty n e empty +pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ _ thing) = ppr thing +pprSplice (XSplice x) = case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon x + GhcRn -> noExtCon x +#endif + GhcTc -> case x of + HsSplicedT _ -> text "Unevaluated typed splice" + +ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc +ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> + char '[' <> ppr quoter <> vbar <> + ppr quote <> text "|]" + +ppr_splice :: (OutputableBndrId p) + => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc +ppr_splice herald n e trail + = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail + +-- | Haskell Bracket +data HsBracket p + = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] + | PatBr (XPatBr p) (LPat p) -- [p| pat |] + | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser + | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer + | TypBr (XTypBr p) (LHsType p) -- [t| type |] + | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) + | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] + | XBracket !(XXBracket p) -- Note [Trees that Grow] extension point + +type instance XExpBr (GhcPass _) = NoExtField +type instance XPatBr (GhcPass _) = NoExtField +type instance XDecBrL (GhcPass _) = NoExtField +type instance XDecBrG (GhcPass _) = NoExtField +type instance XTypBr (GhcPass _) = NoExtField +type instance XVarBr (GhcPass _) = NoExtField +type instance XTExpBr (GhcPass _) = NoExtField +type instance XXBracket (GhcPass _) = NoExtCon + +isTypedBracket :: HsBracket id -> Bool +isTypedBracket (TExpBr {}) = True +isTypedBracket _ = False + +instance OutputableBndrId p + => Outputable (HsBracket (GhcPass p)) where + ppr = pprHsBracket + + +pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc +pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) +pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr _ True n) + = char '\'' <> pprPrefixOcc n +pprHsBracket (VarBr _ False n) + = text "''" <> pprPrefixOcc n +pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) + +thBrackets :: SDoc -> SDoc -> SDoc +thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> + pp_body <+> text "|]" + +thTyBrackets :: SDoc -> SDoc +thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") + +instance Outputable PendingRnSplice where + ppr (PendingRnSplice _ n e) = pprPendingSplice n e + +instance Outputable PendingTcSplice where + ppr (PendingTcSplice n e) = pprPendingSplice n e + +{- +************************************************************************ +* * +\subsection{Enumerations and list comprehensions} +* * +************************************************************************ +-} + +-- | Arithmetic Sequence Information +data ArithSeqInfo id + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) +-- AZ: Should ArithSeqInfo have a TTG extension? + +instance OutputableBndrId p + => Outputable (ArithSeqInfo (GhcPass p)) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot :: SDoc +pp_dotdot = text " .. " + +{- +************************************************************************ +* * +\subsection{HsMatchCtxt} +* * +************************************************************************ +-} + +-- | Haskell Match Context +-- +-- Context of a pattern match. This is more subtle than it would seem. See Note +-- [Varieties of pattern matches]. +data HsMatchContext p + = FunRhs { mc_fun :: LIdP p -- ^ function binder of @f@ + , mc_fixity :: LexicalFixity -- ^ fixing of @f@ + , mc_strictness :: SrcStrictness -- ^ was @f@ banged? + -- See Note [FunBind vs PatBind] + } + -- ^A pattern matching on an argument of a + -- function binding + | LambdaExpr -- ^Patterns of a lambda + | CaseAlt -- ^Patterns and guards on a case alternative + | IfAlt -- ^Guards of a multi-way if alternative + | ProcExpr -- ^Patterns of a proc + | PatBindRhs -- ^A pattern binding eg [y] <- e = e + | PatBindGuards -- ^Guards of pattern bindings, e.g., + -- (Just b) | Just _ <- x = e + -- | otherwise = e' + + | RecUpd -- ^Record update [used only in GHC.HsToCore.Expr to + -- tell matchWrapper what sort of + -- runtime error message to generate] + + | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + + | ThPatSplice -- ^A Template Haskell pattern splice + | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] + | PatSyn -- ^A pattern synonym declaration + +instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where + ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) + ppr LambdaExpr = text "LambdaExpr" + ppr CaseAlt = text "CaseAlt" + ppr IfAlt = text "IfAlt" + ppr ProcExpr = text "ProcExpr" + ppr PatBindRhs = text "PatBindRhs" + ppr PatBindGuards = text "PatBindGuards" + ppr RecUpd = text "RecUpd" + ppr (StmtCtxt _) = text "StmtCtxt _" + ppr ThPatSplice = text "ThPatSplice" + ppr ThPatQuote = text "ThPatQuote" + ppr PatSyn = text "PatSyn" + +isPatSynCtxt :: HsMatchContext p -> Bool +isPatSynCtxt ctxt = + case ctxt of + PatSyn -> True + _ -> False + +-- | Haskell Statement Context. +data HsStmtContext p + = ListComp + | MonadComp + + | DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... } + | MDoExpr (Maybe ModuleName) -- ^[ModuleName.]mdo { ... } ie recursive do-expression + | ArrowExpr -- ^do-notation in an arrow-command context + + | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs + | PatGuard (HsMatchContext p) -- ^Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext p) -- ^A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt + +qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName +qualifiedDoModuleName_maybe ctxt = case ctxt of + DoExpr m -> m + MDoExpr m -> m + _ -> Nothing + +isComprehensionContext :: HsStmtContext id -> Bool +-- Uses comprehension syntax [ e | quals ] +isComprehensionContext ListComp = True +isComprehensionContext MonadComp = True +isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c +isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c +isComprehensionContext _ = False + +-- | Is this a monadic context? +isMonadStmtContext :: HsStmtContext id -> Bool +isMonadStmtContext MonadComp = True +isMonadStmtContext DoExpr{} = True +isMonadStmtContext MDoExpr{} = True +isMonadStmtContext GhciStmtCtxt = True +isMonadStmtContext (ParStmtCtxt ctxt) = isMonadStmtContext ctxt +isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt +isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr + +isMonadCompContext :: HsStmtContext id -> Bool +isMonadCompContext MonadComp = True +isMonadCompContext _ = False + +matchSeparator :: HsMatchContext p -> SDoc +matchSeparator (FunRhs {}) = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator IfAlt = text "->" +matchSeparator LambdaExpr = text "->" +matchSeparator ProcExpr = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator (StmtCtxt _) = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern + -- match checker trace +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" +matchSeparator PatSyn = panic "unused" + +pprMatchContext :: Outputable (IdP p) + => HsMatchContext p -> SDoc +pprMatchContext ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an ProcExpr = True + want_an _ = False + +pprMatchContextNoun :: Outputable (IdP id) + => HsMatchContext id -> SDoc +pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) + = text "equation for" + <+> quotes (ppr fun) +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record-update construct" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun PatBindGuards = text "pattern binding guards" +pprMatchContextNoun LambdaExpr = text "lambda abstraction" +pprMatchContextNoun ProcExpr = text "arrow abstraction" +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" + $$ pprAStmtContext ctxt +pprMatchContextNoun PatSyn = text "pattern synonym declaration" + +----------------- +pprAStmtContext, pprStmtContext :: Outputable (IdP id) + => HsStmtContext id -> SDoc +pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + pp_an = text "an" + pp_a = text "a" + article = case ctxt of + MDoExpr Nothing -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a + + +----------------- +pprStmtContext GhciStmtCtxt = text "interactive GHCi command" +pprStmtContext (DoExpr m) = prependQualified m (text "'do' block") +pprStmtContext (MDoExpr m) = prependQualified m (text "'mdo' block") +pprStmtContext ArrowExpr = text "'do' block in an arrow command" +pprStmtContext ListComp = text "list comprehension" +pprStmtContext MonadComp = text "monad comprehension" +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) = + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) +pprStmtContext (TransStmtCtxt c) = + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) + +prependQualified :: Maybe ModuleName -> SDoc -> SDoc +prependQualified Nothing t = t +prependQualified (Just _) t = text "qualified" <+> t + +instance OutputableBndrId p + => Outputable (HsStmtContext (GhcPass p)) where + ppr = pprStmtContext + +-- Used to generate the string for a *runtime* error message +matchContextErrString :: OutputableBndrId p + => HsMatchContext (GhcPass p) -> SDoc +matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun +matchContextErrString CaseAlt = text "case" +matchContextErrString IfAlt = text "multi-way if" +matchContextErrString PatBindRhs = text "pattern binding" +matchContextErrString PatBindGuards = text "pattern binding guards" +matchContextErrString RecUpd = text "record update" +matchContextErrString LambdaExpr = text "lambda" +matchContextErrString ProcExpr = text "proc" +matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime +matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" +matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" +matchContextErrString (StmtCtxt (DoExpr m)) = prependQualified m (text "'do' block") +matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" +matchContextErrString (StmtCtxt (MDoExpr m)) = prependQualified m (text "'mdo' block") +matchContextErrString (StmtCtxt ListComp) = text "list comprehension" +matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" + +pprMatchInCtxt :: (OutputableBndrId idR, Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) + <> colon) + 4 (pprMatch match) + +pprStmtInCtxt :: (OutputableBndrId idL, + OutputableBndrId idR, + Outputable body) + => HsStmtContext (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc pprStmtInCtxt ctxt (LastStmt _ e _ _) diff --git a/GHC/Hs/Expr.hs-boot b/GHC/Hs/Expr.hs-boot --- a/GHC/Hs/Expr.hs-boot +++ b/GHC/Hs/Expr.hs-boot @@ -1,8 +1,8 @@ {-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} @@ -10,24 +10,24 @@ module GHC.Hs.Expr where -import SrcLoc ( Located ) -import Outputable ( SDoc, Outputable ) +import GHC.Types.SrcLoc ( Located ) +import GHC.Utils.Outputable ( SDoc, Outputable ) import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) -import BasicTypes ( SpliceExplicitFlag(..)) +import GHC.Types.Basic ( SpliceExplicitFlag(..)) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) +import Data.Kind ( Type ) type role HsExpr nominal type role HsCmd nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal type role HsSplice nominal -type role SyntaxExpr nominal -data HsExpr (i :: *) -data HsCmd (i :: *) -data HsSplice (i :: *) -data MatchGroup (a :: *) (body :: *) -data GRHSs (a :: *) (body :: *) -data SyntaxExpr (i :: *) +data HsExpr (i :: Type) +data HsCmd (i :: Type) +data HsSplice (i :: Type) +data MatchGroup (a :: Type) (body :: Type) +data GRHSs (a :: Type) (body :: Type) +type family SyntaxExpr (i :: Type) instance OutputableBndrId p => Outputable (HsExpr (GhcPass p)) instance OutputableBndrId p => Outputable (HsCmd (GhcPass p)) diff --git a/GHC/Hs/Extension.hs b/GHC/Hs/Extension.hs --- a/GHC/Hs/Extension.hs +++ b/GHC/Hs/Extension.hs @@ -11,23 +11,28 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension +{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- for pprIfTc, etc. module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -import GhcPrelude +import GHC.Prelude import Data.Data hiding ( Fixity ) -import GHC.Hs.PlaceHolder -import Name -import RdrName -import Var -import Outputable -import SrcLoc (Located) +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Var +import GHC.Utils.Outputable +import GHC.Types.SrcLoc (Located) import Data.Kind @@ -54,6 +59,74 @@ A further goal is to provide a means to harmonise the Template Haskell and haskell-src-exts ASTs as well. +Wrinkle: In order to print out the AST, we need to know it is Outputable. +We also sometimes need to branch on the particular pass that we're in +(e.g. to print out type information once we know it). In order to allow +both of these actions, we define OutputableBndrId, which gathers the necessary +OutputableBndr and IsPass constraints. The use of this constraint in instances +generally requires UndecidableInstances. + +See also Note [IsPass] and Note [NoGhcTc]. + +Note [IsPass] +~~~~~~~~~~~~~ +One challenge with the Trees That Grow approach +is that we sometimes have different information in different passes. +For example, we have + + type instance XViaStrategy GhcPs = LHsSigType GhcPs + type instance XViaStrategy GhcRn = LHsSigType GhcRn + type instance XViaStrategy GhcTc = Type + +This means that printing a DerivStrategy (which contains an XViaStrategy) +might need to print a LHsSigType, or it might need to print a type. Yet we +want one Outputable instance for a DerivStrategy, instead of one per pass. We +could have a large constraint, including e.g. (Outputable (XViaStrategy p), +Outputable (XViaStrategy GhcTc)), and pass that around in every context where +we might output a DerivStrategy. But a simpler alternative is to pass a +witness to whichever pass we're in. When we pattern-match on that (GADT) +witness, we learn the pass identity and can then print away. To wit, we get +the definition of GhcPass and the functions isPass. These allow us to do away +with big constraints, passing around all manner of dictionaries we might or +might not use. It does mean that we have to manually use isPass when printing, +but these places are few. + +See Note [NoGhcTc] about the superclass constraint to IsPass. + +Note [NoGhcTc] +~~~~~~~~~~~~~~ +An expression is parsed into HsExpr GhcPs, renamed into HsExpr GhcRn, and +then type-checked into HsExpr GhcTc. Not so for types! These get parsed +into HsType GhcPs, renamed into HsType GhcRn, and then type-checked into +Type. We never build an HsType GhcTc. Why do this? Because we need to be +able to compare type-checked types for equality, and we don't want to do +this with HsType. + +This causes wrinkles within the AST, where we normally thing that the whole +AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we +have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that +user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc. + +For example, this is used in ExprWithTySig: + | ExprWithTySig + (XExprWithTySig p) + + (LHsExpr p) + (LHsSigWcType (NoGhcTc p)) + +If we have (e :: ty), we still want to be able to print that (with the :: ty) +after type-checking. So we retain the LHsSigWcType GhcRn, even in an +HsExpr GhcTc. That's what NoGhcTc does. + +When we're printing the type annotation, we need to know +(Outputable (LHsSigWcType GhcRn)), even though we've assumed only that +(OutputableBndrId GhcTc). We thus must be able to prove OutputableBndrId (NoGhcTc p) +from OutputableBndrId p. The extra constraints in OutputableBndrId and +the superclass constraints of IsPass allow this. Note that the superclass +constraint of IsPass is *recursive*: it asserts that IsPass (NoGhcTcPass p) holds. +For this to make sense, we need -XUndecidableSuperClasses and the other constraint, +saying that NoGhcTcPass is idempotent. + -} -- | A placeholder type for TTG extension points that are not currently @@ -93,6 +166,12 @@ noExtCon :: NoExtCon -> a noExtCon x = case x of {} +-- | GHC's L prefixed variants wrap their vanilla variant in this type family, +-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not +-- interested in location information can define this instance as @f p@. +type family XRec p (f :: Type -> Type) = r | r -> p f +type instance XRec (GhcPass p) f = Located (f (GhcPass p)) + {- Note [NoExtCon and strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -102,65 +181,88 @@ type instance XXHsDecl (GhcPass _) = NoExtCon data HsDecl p = ... - | XHsDecl (XXHsDecl p) + | XHsDecl !(XXHsDecl p) -This means that any function that wishes to consume an HsDecl will need to -have a case for XHsDecl. This might look like this: +The field of type `XXHsDecl p` is strict for a good reason: it allows the +pattern-match coverage checker to conclude that any matches against XHsDecl +are unreachable whenever `p ~ GhcPass _`. To see why this is the case, consider +the following function which consumes an HsDecl: ex :: HsDecl GhcPs -> HsDecl GhcRn ... ex (XHsDecl nec) = noExtCon nec -Ideally, we wouldn't need a case for XHsDecl at all (it /is/ supposed to be -an unused extension constructor, after all). There is a way to achieve this -on GHC 8.8 or later: make the field of XHsDecl strict: - - data HsDecl p - = ... - | XHsDecl !(XXHsDecl p) - -If this is done, GHC's pattern-match coverage checker is clever enough to -figure out that the XHsDecl case of `ex` is unreachable, so it can simply be -omitted. (See Note [Extensions to GADTs Meet Their Match] in Check for more on -how this works.) +Because `p` equals GhcPs (i.e., GhcPass 'Parsed), XHsDecl's field has the type +NoExtCon. But since (1) the field is strict and (2) NoExtCon is an empty data +type, there is no possible way to reach the right-hand side of the XHsDecl +case. As a result, the coverage checker concludes that the XHsDecl case is +inaccessible, so it can be removed. +(See Note [Strict argument type constraints] in GHC.HsToCore.PmCheck.Oracle for +more on how this works.) -When GHC drops support for bootstrapping with GHC 8.6 and earlier, we can make -the strict field changes described above and delete gobs of code involving -`noExtCon`. Until then, it is necessary to use, so be aware of it when writing -code that consumes unused extension constructors. +Bottom line: if you add a TTG extension constructor that uses NoExtCon, make +sure that any uses of it as a field are strict. -} --- | Used as a data type index for the hsSyn AST -data GhcPass (c :: Pass) -deriving instance Eq (GhcPass c) -deriving instance Typeable c => Data (GhcPass c) +-- | Used as a data type index for the hsSyn AST; also serves +-- as a singleton type for Pass +data GhcPass (c :: Pass) where + GhcPs :: GhcPs + GhcRn :: GhcRn + GhcTc :: GhcTc +-- This really should never be entered, but the data-deriving machinery +-- needs the instance to exist. +instance Typeable p => Data (GhcPass p) where + gunfold _ _ _ = panic "instance Data GhcPass" + toConstr _ = panic "instance Data GhcPass" + dataTypeOf _ = panic "instance Data GhcPass" + data Pass = Parsed | Renamed | Typechecked deriving (Data) -- Type synonyms as a shorthand for tagging -type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param -type GhcRn = GhcPass 'Renamed -- Old 'Name' type param -type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, -type GhcTcId = GhcTc -- Old 'TcId' type param +type GhcPs = GhcPass 'Parsed -- Output of parser +type GhcRn = GhcPass 'Renamed -- Output of renamer +type GhcTc = GhcPass 'Typechecked -- Output of typechecker --- | GHC's L prefixed variants wrap their vanilla variant in this type family, --- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not --- interested in location information can define this instance as @f p@. -type family XRec p (f :: * -> *) = r | r -> p f -type instance XRec (GhcPass p) f = Located (f (GhcPass p)) +-- | Allows us to check what phase we're in at GHC's runtime. +-- For example, this class allows us to write +-- > f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah +-- > f e = case ghcPass @p of +-- > GhcPs -> ... in this RHS we have HsExpr GhcPs... +-- > GhcRn -> ... in this RHS we have HsExpr GhcRn... +-- > GhcTc -> ... in this RHS we have HsExpr GhcTc... +-- which is very useful, for example, when pretty-printing. +-- See Note [IsPass]. +class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p + , IsPass (NoGhcTcPass p) + ) => IsPass p where + ghcPass :: GhcPass p +instance IsPass 'Parsed where + ghcPass = GhcPs +instance IsPass 'Renamed where + ghcPass = GhcRn +instance IsPass 'Typechecked where + ghcPass = GhcTc + -- | Maps the "normal" id type for a given pass type family IdP p -type instance IdP GhcPs = RdrName -type instance IdP GhcRn = Name -type instance IdP GhcTc = Id +type instance IdP (GhcPass p) = IdGhcP p +-- | Maps the "normal" id type for a given GHC pass +type family IdGhcP pass where + IdGhcP 'Parsed = RdrName + IdGhcP 'Renamed = Name + IdGhcP 'Typechecked = Id + type LIdP p = Located (IdP p) -- | Marks that a field uses the GhcRn variant even when the pass -- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because -- HsType GhcTc should never occur. +-- See Note [NoGhcTc] type family NoGhcTc (p :: Type) where -- this way, GHC can figure out that the result is a GhcPass NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) @@ -179,23 +281,10 @@ type family XEmptyLocalBinds x x' type family XXHsLocalBindsLR x x' -type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XHsValBinds x x') - , c (XHsIPBinds x x') - , c (XEmptyLocalBinds x x') - , c (XXHsLocalBindsLR x x') - ) - -- ValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' -type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XValBinds x x') - , c (XXValBindsLR x x') - ) - - -- HsBindsLR type families type family XFunBind x x' type family XPatBind x x' @@ -204,51 +293,22 @@ type family XPatSynBind x x' type family XXHsBindsLR x x' -type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XFunBind x x') - , c (XPatBind x x') - , c (XVarBind x x') - , c (XAbsBinds x x') - , c (XPatSynBind x x') - , c (XXHsBindsLR x x') - ) - -- ABExport type families type family XABE x type family XXABExport x -type ForallXABExport (c :: * -> Constraint) (x :: *) = - ( c (XABE x) - , c (XXABExport x) - ) - -- PatSynBind type families type family XPSB x x' type family XXPatSynBind x x' -type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XPSB x x') - , c (XXPatSynBind x x') - ) - -- HsIPBinds type families type family XIPBinds x type family XXHsIPBinds x -type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = - ( c (XIPBinds x) - , c (XXHsIPBinds x) - ) - -- IPBind type families type family XCIPBind x type family XXIPBind x -type ForallXIPBind (c :: * -> Constraint) (x :: *) = - ( c (XCIPBind x) - , c (XXIPBind x) - ) - -- Sig type families type family XTypeSig x type family XPatSynSig x @@ -263,30 +323,10 @@ type family XCompleteMatchSig x type family XXSig x -type ForallXSig (c :: * -> Constraint) (x :: *) = - ( c (XTypeSig x) - , c (XPatSynSig x) - , c (XClassOpSig x) - , c (XIdSig x) - , c (XFixSig x) - , c (XInlineSig x) - , c (XSpecSig x) - , c (XSpecInstSig x) - , c (XMinimalSig x) - , c (XSCCFunSig x) - , c (XCompleteMatchSig x) - , c (XXSig x) - ) - -- FixitySig type families type family XFixitySig x type family XXFixitySig x -type ForallXFixitySig (c :: * -> Constraint) (x :: *) = - ( c (XFixitySig x) - , c (XXFixitySig x) - ) - -- StandaloneKindSig type families type family XStandaloneKindSig x type family XXStandaloneKindSig x @@ -311,44 +351,16 @@ type family XRoleAnnotD x type family XXHsDecl x -type ForallXHsDecl (c :: * -> Constraint) (x :: *) = - ( c (XTyClD x) - , c (XInstD x) - , c (XDerivD x) - , c (XValD x) - , c (XSigD x) - , c (XKindSigD x) - , c (XDefD x) - , c (XForD x) - , c (XWarningD x) - , c (XAnnD x) - , c (XRuleD x) - , c (XSpliceD x) - , c (XDocD x) - , c (XRoleAnnotD x) - , c (XXHsDecl x) - ) - -- ------------------------------------- -- HsGroup type families type family XCHsGroup x type family XXHsGroup x -type ForallXHsGroup (c :: * -> Constraint) (x :: *) = - ( c (XCHsGroup x) - , c (XXHsGroup x) - ) - -- ------------------------------------- -- SpliceDecl type families type family XSpliceDecl x type family XXSpliceDecl x -type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) = - ( c (XSpliceDecl x) - , c (XXSpliceDecl x) - ) - -- ------------------------------------- -- TyClDecl type families type family XFamDecl x @@ -357,24 +369,11 @@ type family XClassDecl x type family XXTyClDecl x -type ForallXTyClDecl (c :: * -> Constraint) (x :: *) = - ( c (XFamDecl x) - , c (XSynDecl x) - , c (XDataDecl x) - , c (XClassDecl x) - , c (XXTyClDecl x) - ) - -- ------------------------------------- -- TyClGroup type families type family XCTyClGroup x type family XXTyClGroup x -type ForallXTyClGroup (c :: * -> Constraint) (x :: *) = - ( c (XCTyClGroup x) - , c (XXTyClGroup x) - ) - -- ------------------------------------- -- FamilyResultSig type families type family XNoSig x @@ -382,75 +381,37 @@ type family XTyVarSig x type family XXFamilyResultSig x -type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) = - ( c (XNoSig x) - , c (XCKindSig x) - , c (XTyVarSig x) - , c (XXFamilyResultSig x) - ) - -- ------------------------------------- -- FamilyDecl type families type family XCFamilyDecl x type family XXFamilyDecl x -type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) = - ( c (XCFamilyDecl x) - , c (XXFamilyDecl x) - ) - -- ------------------------------------- -- HsDataDefn type families type family XCHsDataDefn x type family XXHsDataDefn x -type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) = - ( c (XCHsDataDefn x) - , c (XXHsDataDefn x) - ) - -- ------------------------------------- -- HsDerivingClause type families type family XCHsDerivingClause x type family XXHsDerivingClause x -type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) = - ( c (XCHsDerivingClause x) - , c (XXHsDerivingClause x) - ) - -- ------------------------------------- -- ConDecl type families type family XConDeclGADT x type family XConDeclH98 x type family XXConDecl x -type ForallXConDecl (c :: * -> Constraint) (x :: *) = - ( c (XConDeclGADT x) - , c (XConDeclH98 x) - , c (XXConDecl x) - ) - -- ------------------------------------- -- FamEqn type families type family XCFamEqn x r type family XXFamEqn x r -type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) = - ( c (XCFamEqn x r) - , c (XXFamEqn x r) - ) - -- ------------------------------------- -- ClsInstDecl type families type family XCClsInstDecl x type family XXClsInstDecl x -type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) = - ( c (XCClsInstDecl x) - , c (XXClsInstDecl x) - ) - -- ------------------------------------- -- ClsInstDecl type families type family XClsInstD x @@ -458,23 +419,11 @@ type family XTyFamInstD x type family XXInstDecl x -type ForallXInstDecl (c :: * -> Constraint) (x :: *) = - ( c (XClsInstD x) - , c (XDataFamInstD x) - , c (XTyFamInstD x) - , c (XXInstDecl x) - ) - -- ------------------------------------- -- DerivDecl type families type family XCDerivDecl x type family XXDerivDecl x -type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = - ( c (XCDerivDecl x) - , c (XXDerivDecl x) - ) - -- ------------------------------------- -- DerivStrategy type family type family XViaStrategy x @@ -484,96 +433,48 @@ type family XCDefaultDecl x type family XXDefaultDecl x -type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) = - ( c (XCDefaultDecl x) - , c (XXDefaultDecl x) - ) - -- ------------------------------------- -- DefaultDecl type families type family XForeignImport x type family XForeignExport x type family XXForeignDecl x -type ForallXForeignDecl (c :: * -> Constraint) (x :: *) = - ( c (XForeignImport x) - , c (XForeignExport x) - , c (XXForeignDecl x) - ) - -- ------------------------------------- -- RuleDecls type families type family XCRuleDecls x type family XXRuleDecls x -type ForallXRuleDecls (c :: * -> Constraint) (x :: *) = - ( c (XCRuleDecls x) - , c (XXRuleDecls x) - ) - - -- ------------------------------------- -- RuleDecl type families type family XHsRule x type family XXRuleDecl x -type ForallXRuleDecl (c :: * -> Constraint) (x :: *) = - ( c (XHsRule x) - , c (XXRuleDecl x) - ) - -- ------------------------------------- -- RuleBndr type families type family XCRuleBndr x type family XRuleBndrSig x type family XXRuleBndr x -type ForallXRuleBndr (c :: * -> Constraint) (x :: *) = - ( c (XCRuleBndr x) - , c (XRuleBndrSig x) - , c (XXRuleBndr x) - ) - -- ------------------------------------- -- WarnDecls type families type family XWarnings x type family XXWarnDecls x -type ForallXWarnDecls (c :: * -> Constraint) (x :: *) = - ( c (XWarnings x) - , c (XXWarnDecls x) - ) - -- ------------------------------------- -- AnnDecl type families type family XWarning x type family XXWarnDecl x -type ForallXWarnDecl (c :: * -> Constraint) (x :: *) = - ( c (XWarning x) - , c (XXWarnDecl x) - ) - -- ------------------------------------- -- AnnDecl type families type family XHsAnnotation x type family XXAnnDecl x -type ForallXAnnDecl (c :: * -> Constraint) (x :: *) = - ( c (XHsAnnotation x) - , c (XXAnnDecl x) - ) - -- ------------------------------------- -- RoleAnnotDecl type families type family XCRoleAnnotDecl x type family XXRoleAnnotDecl x -type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) = - ( c (XCRoleAnnotDecl x) - , c (XXRoleAnnotDecl x) - ) - -- ===================================================================== -- Type families for the HsExpr extension points @@ -606,8 +507,6 @@ type family XRecordUpd x type family XExprWithTySig x type family XArithSeq x -type family XSCC x -type family XCoreAnn x type family XBracket x type family XRnBracketOut x type family XTcBracketOut x @@ -616,78 +515,25 @@ type family XStatic x type family XTick x type family XBinTick x -type family XTickPragma x -type family XWrap x +type family XPragE x type family XXExpr x -type ForallXExpr (c :: * -> Constraint) (x :: *) = - ( c (XVar x) - , c (XUnboundVar x) - , c (XConLikeOut x) - , c (XRecFld x) - , c (XOverLabel x) - , c (XIPVar x) - , c (XOverLitE x) - , c (XLitE x) - , c (XLam x) - , c (XLamCase x) - , c (XApp x) - , c (XAppTypeE x) - , c (XOpApp x) - , c (XNegApp x) - , c (XPar x) - , c (XSectionL x) - , c (XSectionR x) - , c (XExplicitTuple x) - , c (XExplicitSum x) - , c (XCase x) - , c (XIf x) - , c (XMultiIf x) - , c (XLet x) - , c (XDo x) - , c (XExplicitList x) - , c (XRecordCon x) - , c (XRecordUpd x) - , c (XExprWithTySig x) - , c (XArithSeq x) - , c (XSCC x) - , c (XCoreAnn x) - , c (XBracket x) - , c (XRnBracketOut x) - , c (XTcBracketOut x) - , c (XSpliceE x) - , c (XProc x) - , c (XStatic x) - , c (XTick x) - , c (XBinTick x) - , c (XTickPragma x) - , c (XWrap x) - , c (XXExpr x) - ) +type family XSCC x +type family XCoreAnn x +type family XTickPragma x +type family XXPragE x -- --------------------------------------------------------------------- type family XUnambiguous x type family XAmbiguous x type family XXAmbiguousFieldOcc x -type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XUnambiguous x) - , c (XAmbiguous x) - , c (XXAmbiguousFieldOcc x) - ) - -- ---------------------------------------------------------------------- type family XPresent x type family XMissing x type family XXTupArg x -type ForallXTupArg (c :: * -> Constraint) (x :: *) = - ( c (XPresent x) - , c (XMissing x) - , c (XXTupArg x) - ) - -- --------------------------------------------------------------------- type family XTypedSplice x @@ -696,14 +542,6 @@ type family XSpliced x type family XXSplice x -type ForallXSplice (c :: * -> Constraint) (x :: *) = - ( c (XTypedSplice x) - , c (XUntypedSplice x) - , c (XQuasiQuote x) - , c (XSpliced x) - , c (XXSplice x) - ) - -- --------------------------------------------------------------------- type family XExpBr x @@ -715,67 +553,31 @@ type family XTExpBr x type family XXBracket x -type ForallXBracket (c :: * -> Constraint) (x :: *) = - ( c (XExpBr x) - , c (XPatBr x) - , c (XDecBrL x) - , c (XDecBrG x) - , c (XTypBr x) - , c (XVarBr x) - , c (XTExpBr x) - , c (XXBracket x) - ) - -- --------------------------------------------------------------------- type family XCmdTop x type family XXCmdTop x -type ForallXCmdTop (c :: * -> Constraint) (x :: *) = - ( c (XCmdTop x) - , c (XXCmdTop x) - ) - -- ------------------------------------- type family XMG x b type family XXMatchGroup x b -type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XMG x b) - , c (XXMatchGroup x b) - ) - -- ------------------------------------- type family XCMatch x b type family XXMatch x b -type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCMatch x b) - , c (XXMatch x b) - ) - -- ------------------------------------- type family XCGRHSs x b type family XXGRHSs x b -type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCGRHSs x b) - , c (XXGRHSs x b) - ) - -- ------------------------------------- type family XCGRHS x b type family XXGRHS x b -type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCGRHS x b) - , c (XXGRHS x b) - ) - -- ------------------------------------- type family XLastStmt x x' b @@ -788,18 +590,6 @@ type family XRecStmt x x' b type family XXStmtLR x x' b -type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) = - ( c (XLastStmt x x' b) - , c (XBindStmt x x' b) - , c (XApplicativeStmt x x' b) - , c (XBodyStmt x x' b) - , c (XLetStmt x x' b) - , c (XParStmt x x' b) - , c (XTransStmt x x' b) - , c (XRecStmt x x' b) - , c (XXStmtLR x x' b) - ) - -- --------------------------------------------------------------------- type family XCmdArrApp x @@ -808,48 +598,24 @@ type family XCmdLam x type family XCmdPar x type family XCmdCase x +type family XCmdLamCase x type family XCmdIf x type family XCmdLet x type family XCmdDo x type family XCmdWrap x type family XXCmd x -type ForallXCmd (c :: * -> Constraint) (x :: *) = - ( c (XCmdArrApp x) - , c (XCmdArrForm x) - , c (XCmdApp x) - , c (XCmdLam x) - , c (XCmdPar x) - , c (XCmdCase x) - , c (XCmdIf x) - , c (XCmdLet x) - , c (XCmdDo x) - , c (XCmdWrap x) - , c (XXCmd x) - ) - -- --------------------------------------------------------------------- type family XParStmtBlock x x' type family XXParStmtBlock x x' -type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XParStmtBlock x x') - , c (XXParStmtBlock x x') - ) - -- --------------------------------------------------------------------- type family XApplicativeArgOne x type family XApplicativeArgMany x type family XXApplicativeArg x -type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) = - ( c (XApplicativeArgOne x) - , c (XApplicativeArgMany x) - , c (XXApplicativeArg x) - ) - -- ===================================================================== -- Type families for the HsImpExp extension points @@ -875,33 +641,9 @@ type family XHsDoublePrim x type family XXLit x --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXHsLit (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsDoublePrim x) - , c (XHsFloatPrim x) - , c (XHsInt x) - , c (XHsInt64Prim x) - , c (XHsIntPrim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsString x) - , c (XHsStringPrim x) - , c (XHsWord64Prim x) - , c (XHsWordPrim x) - , c (XXLit x) - ) - type family XOverLit x type family XXOverLit x -type ForallXOverLit (c :: * -> Constraint) (x :: *) = - ( c (XOverLit x) - , c (XXOverLit x) - ) - -- ===================================================================== -- Type families for the HsPat extension points @@ -924,58 +666,27 @@ type family XCoPat x type family XXPat x - -type ForallXPat (c :: * -> Constraint) (x :: *) = - ( c (XWildPat x) - , c (XVarPat x) - , c (XLazyPat x) - , c (XAsPat x) - , c (XParPat x) - , c (XBangPat x) - , c (XListPat x) - , c (XTuplePat x) - , c (XSumPat x) - , c (XViewPat x) - , c (XSplicePat x) - , c (XLitPat x) - , c (XNPat x) - , c (XNPlusKPat x) - , c (XSigPat x) - , c (XCoPat x) - , c (XXPat x) - ) - -- ===================================================================== -- Type families for the HsTypes type families type family XHsQTvs x type family XXLHsQTyVars x -type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) = - ( c (XHsQTvs x) - , c (XXLHsQTyVars x) - ) - -- ------------------------------------- type family XHsIB x b type family XXHsImplicitBndrs x b -type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XHsIB x b) - , c (XXHsImplicitBndrs x b) - ) - -- ------------------------------------- type family XHsWC x b type family XXHsWildCardBndrs x b -type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XHsWC x b) - , c (XXHsWildCardBndrs x b) - ) +-- ------------------------------------- +type family XHsPS x +type family XXHsPatSigType x + -- ------------------------------------- type family XForAllTy x @@ -1002,78 +713,34 @@ type family XWildCardTy x type family XXType x --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXType (c :: * -> Constraint) (x :: *) = - ( c (XForAllTy x) - , c (XQualTy x) - , c (XTyVar x) - , c (XAppTy x) - , c (XAppKindTy x) - , c (XFunTy x) - , c (XListTy x) - , c (XTupleTy x) - , c (XSumTy x) - , c (XOpTy x) - , c (XParTy x) - , c (XIParamTy x) - , c (XStarTy x) - , c (XKindSig x) - , c (XSpliceTy x) - , c (XDocTy x) - , c (XBangTy x) - , c (XRecTy x) - , c (XExplicitListTy x) - , c (XExplicitTupleTy x) - , c (XTyLit x) - , c (XWildCardTy x) - , c (XXType x) - ) +-- --------------------------------------------------------------------- +type family XHsForAllVis x +type family XHsForAllInvis x +type family XXHsForAllTelescope x + -- --------------------------------------------------------------------- type family XUserTyVar x type family XKindedTyVar x type family XXTyVarBndr x -type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = - ( c (XUserTyVar x) - , c (XKindedTyVar x) - , c (XXTyVarBndr x) - ) - -- --------------------------------------------------------------------- type family XConDeclField x type family XXConDeclField x -type ForallXConDeclField (c :: * -> Constraint) (x :: *) = - ( c (XConDeclField x) - , c (XXConDeclField x) - ) - -- --------------------------------------------------------------------- type family XCFieldOcc x type family XXFieldOcc x -type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XCFieldOcc x) - , c (XXFieldOcc x) - ) - - -- ===================================================================== -- Type families for the HsImpExp type families type family XCImportDecl x type family XXImportDecl x -type ForallXImportDecl (c :: * -> Constraint) (x :: *) = - ( c (XCImportDecl x) - , c (XXImportDecl x) - ) - -- ------------------------------------- type family XIEVar x @@ -1086,18 +753,6 @@ type family XIEDocNamed x type family XXIE x -type ForallXIE (c :: * -> Constraint) (x :: *) = - ( c (XIEVar x) - , c (XIEThingAbs x) - , c (XIEThingAll x) - , c (XIEThingWith x) - , c (XIEModuleContents x) - , c (XIEGroup x) - , c (XIEDoc x) - , c (XIEDocNamed x) - , c (XXIE x) - ) - -- ------------------------------------- @@ -1105,77 +760,23 @@ -- End of Type family definitions -- ===================================================================== --- ---------------------------------------------------------------------- --- | Conversion of annotations from one type index to another. This is required --- where the AST is converted from one pass to another, and the extension values --- need to be brought along if possible. So for example a 'SourceText' is --- converted via 'id', but needs a type signature to keep the type checker --- happy. -class Convertable a b | a -> b where - convert :: a -> b - -instance Convertable a a where - convert = id - --- | A constraint capturing all the extension points that can be converted via --- @instance Convertable a a@ -type ConvertIdX a b = - (XHsDoublePrim a ~ XHsDoublePrim b, - XHsFloatPrim a ~ XHsFloatPrim b, - XHsRat a ~ XHsRat b, - XHsInteger a ~ XHsInteger b, - XHsWord64Prim a ~ XHsWord64Prim b, - XHsInt64Prim a ~ XHsInt64Prim b, - XHsWordPrim a ~ XHsWordPrim b, - XHsIntPrim a ~ XHsIntPrim b, - XHsInt a ~ XHsInt b, - XHsStringPrim a ~ XHsStringPrim b, - XHsString a ~ XHsString b, - XHsCharPrim a ~ XHsCharPrim b, - XHsChar a ~ XHsChar b, - XXLit a ~ XXLit b) - --- ---------------------------------------------------------------------- - --- Note [OutputableX] --- ~~~~~~~~~~~~~~~~~~ --- --- is required because the type family resolution --- process cannot determine that all cases are handled for a `GhcPass p` --- case where the cases are listed separately. --- --- So --- --- type instance XXHsIPBinds (GhcPass p) = NoExtCon --- --- will correctly deduce Outputable for (GhcPass p), but --- --- type instance XIPBinds GhcPs = NoExt --- type instance XIPBinds GhcRn = NoExt --- type instance XIPBinds GhcTc = TcEvBinds --- --- will not. - - --- | Provide a summary constraint that gives all am Outputable constraint to --- extension points needing one -type OutputableX p = -- See Note [OutputableX] - ( Outputable (XIPBinds p) - , Outputable (XViaStrategy p) - , Outputable (XViaStrategy GhcRn) - ) --- TODO: Should OutputableX be included in OutputableBndrId? - --- ---------------------------------------------------------------------- - -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both --- the @p@ and the 'NameOrRdrName' type for it +-- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. type OutputableBndrId pass = - ( OutputableBndr (NameOrRdrName (IdP (GhcPass pass))) - , OutputableBndr (IdP (GhcPass pass)) - , OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass)))) - , OutputableBndr (IdP (NoGhcTc (GhcPass pass))) - , NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass)) - , OutputableX (GhcPass pass) - , OutputableX (NoGhcTc (GhcPass pass)) + ( OutputableBndr (IdGhcP pass) + , OutputableBndr (IdGhcP (NoGhcTcPass pass)) + , IsPass pass ) + +-- useful helper functions: +pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc +pprIfPs pp = case ghcPass @p of GhcPs -> pp + _ -> empty + +pprIfRn :: forall p. IsPass p => (p ~ 'Renamed => SDoc) -> SDoc +pprIfRn pp = case ghcPass @p of GhcRn -> pp + _ -> empty + +pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc +pprIfTc pp = case ghcPass @p of GhcTc -> pp + _ -> empty diff --git a/GHC/Hs/ImpExp.hs b/GHC/Hs/ImpExp.hs --- a/GHC/Hs/ImpExp.hs +++ b/GHC/Hs/ImpExp.hs @@ -11,22 +11,22 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension module GHC.Hs.ImpExp where -import GhcPrelude +import GHC.Prelude -import Module ( ModuleName ) -import GHC.Hs.Doc ( HsDocString ) -import OccName ( HasOccName(..), isTcOcc, isSymOcc ) -import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) -import FieldLabel ( FieldLbl(..) ) +import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) +import GHC.Hs.Doc ( HsDocString ) +import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc ) +import GHC.Types.Basic ( SourceText(..), StringLiteral(..), pprWithSourceText ) +import GHC.Types.FieldLabel ( FieldLbl(..) ) -import Outputable -import FastString -import SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.SrcLoc import GHC.Hs.Extension import Data.Data @@ -46,9 +46,9 @@ type LImportDecl pass = Located (ImportDecl pass) -- ^ When in a list this may have -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | If/how an import is 'qualified'. data ImportDeclQualifiedStyle @@ -59,7 +59,7 @@ -- | Given two possible located 'qualified' tokens, compute a style -- (in a conforming Haskell program only one of the two can be not --- 'Nothing'). This is called from 'Parser.y'. +-- 'Nothing'). This is called from "GHC.Parser". importDeclQualifiedStyle :: Maybe (Located a) -> Maybe (Located a) -> ImportDeclQualifiedStyle @@ -80,10 +80,10 @@ = ImportDecl { ideclExt :: XCImportDecl pass, ideclSourceSrc :: SourceText, - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. - ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import + ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import ideclSafe :: Bool, -- ^ True => safe import ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) @@ -91,23 +91,23 @@ ideclHiding :: Maybe (Bool, Located [LIE pass]) -- ^ (True => hiding, names) } - | XImportDecl (XXImportDecl pass) + | XImportDecl !(XXImportDecl pass) -- ^ - -- 'ApiAnnotation.AnnKeywordId's + -- 'GHC.Parser.Annotation.AnnKeywordId's -- - -- - 'ApiAnnotation.AnnImport' + -- - 'GHC.Parser.Annotation.AnnImport' -- - -- - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource + -- - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource -- - -- - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified', - -- 'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs', - -- 'ApiAnnotation.AnnVal' + -- - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified', + -- 'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs', + -- 'GHC.Parser.Annotation.AnnVal' -- - -- - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' attached + -- - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose' attached -- to location in ideclHiding - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation type instance XCImportDecl (GhcPass _) = NoExtField type instance XXImportDecl (GhcPass _) = NoExtCon @@ -118,7 +118,7 @@ ideclSourceSrc = NoSourceText, ideclName = noLoc mn, ideclPkgQual = Nothing, - ideclSource = False, + ideclSource = NotBoot, ideclSafe = False, ideclImplicit = False, ideclQualified = NotQualified, @@ -156,10 +156,10 @@ pp_as Nothing = empty pp_as (Just a) = text "as" <+> ppr a - ppr_imp True = case mSrcText of + ppr_imp IsBoot = case mSrcText of NoSourceText -> text "{-# SOURCE #-}" SourceText src -> text src <+> text "#-}" - ppr_imp False = empty + ppr_imp NotBoot = empty pp_spec Nothing = empty pp_spec (Just (False, (L _ ies))) = ppr_ies ies @@ -167,7 +167,6 @@ ppr_ies [] = text "()" ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' - ppr (XImportDecl x) = ppr x {- ************************************************************************ @@ -187,19 +186,19 @@ deriving (Eq,Data) -- | Located name with possible adornment --- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType', --- 'ApiAnnotation.AnnPattern' +-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', +-- 'GHC.Parser.Annotation.AnnPattern' type LIEWrappedName name = Located (IEWrappedName name) --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | Located Import or Export type LIE pass = Located (IE pass) -- ^ When in a list this may have -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation -- | Imported or exported entity. data IE pass @@ -210,21 +209,21 @@ -- ^ Imported or exported Thing with Absent list -- -- The thing is a Class/Type (can't tell) - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern', + -- 'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation -- See Note [Located RdrNames] in GHC.Hs.Expr | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass)) -- ^ Imported or exported Thing with All imported or exported -- -- The thing is a Class/Type and the All refers to methods/constructors -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnType' + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose', + -- 'GHC.Parser.Annotation.AnnType' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation -- See Note [Located RdrNames] in GHC.Hs.Expr | IEThingWith (XIEThingWith pass) @@ -236,24 +235,24 @@ -- -- The thing is a Class/Type and the imported or exported things are -- methods/constructors and record fields; see Note [IEThingWith] - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnType' + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnClose', + -- 'GHC.Parser.Annotation.AnnComma', + -- 'GHC.Parser.Annotation.AnnType' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | IEModuleContents (XIEModuleContents pass) (Located ModuleName) -- ^ Imported or exported module contents -- -- (Export Only) -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' + -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc - | XIE (XXIE pass) + | XIE !(XXIE pass) type instance XIEVar (GhcPass _) = NoExtField type instance XIEThingAbs (GhcPass _) = NoExtField @@ -282,7 +281,7 @@ IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) -See Note [Representing fields in AvailInfo] in Avail for more details. +See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. -} ieName :: IE (GhcPass p) -> IdP (GhcPass p) @@ -302,7 +301,6 @@ ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] -ieNames (XIE nec) = noExtCon nec ieWrappedName :: IEWrappedName name -> name ieWrappedName (IEName (L _ n)) = n @@ -344,7 +342,6 @@ ppr (IEGroup _ n _) = text ("") ppr (IEDoc _ doc) = ppr doc ppr (IEDocNamed _ string) = text ("") - ppr (XIE x) = ppr x instance (HasOccName name) => HasOccName (IEWrappedName name) where occName w = occName (ieWrappedName w) diff --git a/GHC/Hs/Instances.hs b/GHC/Hs/Instances.hs --- a/GHC/Hs/Instances.hs +++ b/GHC/Hs/Instances.hs @@ -5,6 +5,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +-- This module contains exclusively Data instances, which are going to be slow +-- no matter what we do. Furthermore, they are incredibly slow to compile with +-- optimisation (see #9557). Consequently we compile this with -O0. +-- See #18254. +{-# OPTIONS_GHC -O0 #-} + module GHC.Hs.Instances where -- This module defines the Data instances for the hsSyn AST. @@ -16,13 +23,13 @@ import Data.Data hiding ( Fixity ) -import GhcPrelude +import GHC.Prelude import GHC.Hs.Extension import GHC.Hs.Binds import GHC.Hs.Decls import GHC.Hs.Expr import GHC.Hs.Lit -import GHC.Hs.Types +import GHC.Hs.Type import GHC.Hs.Pat import GHC.Hs.ImpExp @@ -242,10 +249,10 @@ -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Expr ----------------------------------- --- deriving instance (DataIdLR p p) => Data (SyntaxExpr p) -deriving instance Data (SyntaxExpr GhcPs) -deriving instance Data (SyntaxExpr GhcRn) -deriving instance Data (SyntaxExpr GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsPragE p) +deriving instance Data (HsPragE GhcPs) +deriving instance Data (HsPragE GhcRn) +deriving instance Data (HsPragE GhcTc) -- deriving instance (DataIdLR p p) => Data (HsExpr p) deriving instance Data (HsExpr GhcPs) @@ -306,6 +313,14 @@ deriving instance Data (ApplicativeArg GhcRn) deriving instance Data (ApplicativeArg GhcTc) +deriving instance Data (HsStmtContext GhcPs) +deriving instance Data (HsStmtContext GhcRn) +deriving instance Data (HsStmtContext GhcTc) + +deriving instance Data (HsMatchContext GhcPs) +deriving instance Data (HsMatchContext GhcRn) +deriving instance Data (HsMatchContext GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsSplice p) deriving instance Data (HsSplice GhcPs) deriving instance Data (HsSplice GhcRn) @@ -326,11 +341,17 @@ deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordConTc -deriving instance Data CmdTopTc -deriving instance Data PendingRnSplice -deriving instance Data PendingTcSplice +deriving instance Data RecordConTc +deriving instance Data RecordUpdTc +deriving instance Data CmdTopTc +deriving instance Data PendingRnSplice +deriving instance Data PendingTcSplice +deriving instance Data SyntaxExprRn +deriving instance Data SyntaxExprTc +deriving instance Data XBindStmtRn +deriving instance Data XBindStmtTc + -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Lit ------------------------------------ @@ -352,6 +373,9 @@ deriving instance Data (Pat GhcRn) deriving instance Data (Pat GhcTc) +deriving instance Data CoPat +deriving instance Data ConPatTc + deriving instance Data ListPatTc -- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) @@ -360,7 +384,7 @@ deriving instance (Data body) => Data (HsRecFields GhcTc body) -- --------------------------------------------------------------------- --- Data derivations from GHC.Hs.Types ---------------------------------- +-- Data derivations from GHC.Hs.Type ---------------------------------- -- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) deriving instance Data (LHsQTyVars GhcPs) @@ -377,16 +401,36 @@ deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) +-- deriving instance (DataIdLR p p) => Data (HsPatSigType p) +deriving instance Data (HsPatSigType GhcPs) +deriving instance Data (HsPatSigType GhcRn) +deriving instance Data (HsPatSigType GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p) +deriving instance Data (HsForAllTelescope GhcPs) +deriving instance Data (HsForAllTelescope GhcRn) +deriving instance Data (HsForAllTelescope GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) -deriving instance Data (HsTyVarBndr GhcPs) -deriving instance Data (HsTyVarBndr GhcRn) -deriving instance Data (HsTyVarBndr GhcTc) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcTc) -- deriving instance (DataIdLR p p) => Data (HsType p) deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsArrow p) +deriving instance Data (HsArrow GhcPs) +deriving instance Data (HsArrow GhcRn) +deriving instance Data (HsArrow GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsScaled p a) +deriving instance Data thing => Data (HsScaled GhcPs thing) +deriving instance Data thing => Data (HsScaled GhcRn thing) +deriving instance Data thing => Data (HsScaled GhcTc thing) + deriving instance Data (LHsTypeArg GhcPs) deriving instance Data (LHsTypeArg GhcRn) deriving instance Data (LHsTypeArg GhcTc) @@ -422,4 +466,7 @@ deriving instance Eq (IE GhcRn) deriving instance Eq (IE GhcTc) + -- --------------------------------------------------------------------- + +deriving instance Data XXExprGhcTc diff --git a/GHC/Hs/Lit.hs b/GHC/Hs/Lit.hs --- a/GHC/Hs/Lit.hs +++ b/GHC/Hs/Lit.hs @@ -10,8 +10,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -19,15 +19,16 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) -import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, - negateFractionalLit,SourceText(..),pprWithSourceText, - PprPrec(..), topPrec ) -import Type -import Outputable -import FastString +import GHC.Types.Basic + ( IntegralLit(..), FractionalLit(..), negateIntegralLit + , negateFractionalLit, SourceText(..), pprWithSourceText + , PprPrec(..), topPrec ) +import GHC.Core.Type +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Hs.Extension import Data.ByteString (ByteString) @@ -41,7 +42,7 @@ ************************************************************************ -} --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following -- | Haskell Literal @@ -52,11 +53,11 @@ -- ^ Unboxed character | HsString (XHsString x) {- SourceText -} FastString -- ^ String - | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString + | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString -- ^ Packed bytes | HsInt (XHsInt x) IntegralLit -- ^ Genuinely an Int; arises from - -- @TcGenDeriv@, and from TRANSLATION + -- "GHC.Tc.Deriv.Generate", and from TRANSLATION | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer -- ^ literal @Int#@ | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer @@ -78,7 +79,7 @@ | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double - | XLit (XXLit x) + | XLit !(XXLit x) type instance XHsChar (GhcPass _) = SourceText type instance XHsCharPrim (GhcPass _) = SourceText @@ -119,7 +120,7 @@ ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] | XOverLit - (XXOverLit p) + !(XXOverLit p) data OverLitTc = OverLitTc { @@ -133,7 +134,7 @@ type instance XXOverLit (GhcPass _) = NoExtCon --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- | Overloaded Literal Value data OverLitVal @@ -149,25 +150,22 @@ overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit (OverLitTc _ ty) _ _) = ty -overLitType (XOverLit nec) = noExtCon nec --- | Convert a literal from one index type to another, updating the annotations --- according to the relevant 'Convertable' instance -convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b -convertLit (HsChar a x) = (HsChar (convert a) x) -convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) -convertLit (HsString a x) = (HsString (convert a) x) -convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x) -convertLit (HsInt a x) = (HsInt (convert a) x) -convertLit (HsIntPrim a x) = (HsIntPrim (convert a) x) -convertLit (HsWordPrim a x) = (HsWordPrim (convert a) x) -convertLit (HsInt64Prim a x) = (HsInt64Prim (convert a) x) -convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x) -convertLit (HsInteger a x b) = (HsInteger (convert a) x b) -convertLit (HsRat a x b) = (HsRat (convert a) x b) -convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) -convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) -convertLit (XLit a) = (XLit (convert a)) +-- | Convert a literal from one index type to another +convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2) +convertLit (HsChar a x) = HsChar a x +convertLit (HsCharPrim a x) = HsCharPrim a x +convertLit (HsString a x) = HsString a x +convertLit (HsStringPrim a x) = HsStringPrim a x +convertLit (HsInt a x) = HsInt a x +convertLit (HsIntPrim a x) = HsIntPrim a x +convertLit (HsWordPrim a x) = HsWordPrim a x +convertLit (HsInt64Prim a x) = HsInt64Prim a x +convertLit (HsWord64Prim a x) = HsWord64Prim a x +convertLit (HsInteger a x b) = HsInteger a x b +convertLit (HsRat a x b) = HsRat a x b +convertLit (HsFloatPrim a x) = HsFloatPrim a x +convertLit (HsDoublePrim a x) = HsDoublePrim a x {- Note [ol_rebindable] @@ -200,7 +198,7 @@ -} -- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module MatchLit) +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 (XOverLit val1) == (XOverLit val2) = val1 == val2 @@ -244,7 +242,6 @@ ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) - ppr (XLit x) = ppr x pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc pp_st_suffix NoSourceText _ doc = doc @@ -255,7 +252,6 @@ => Outputable (HsOverLit (GhcPass p)) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (whenPprDebug (parens (pprExpr witness))) - ppr (XOverLit x) = ppr x instance Outputable OverLitVal where ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) @@ -282,7 +278,6 @@ pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d -pmPprHsLit (XLit x) = ppr x -- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs -- to be parenthesized under precedence @p@. diff --git a/GHC/Hs/Pat.hs b/GHC/Hs/Pat.hs --- a/GHC/Hs/Pat.hs +++ b/GHC/Hs/Pat.hs @@ -1,3 +1,4 @@ + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -9,18 +10,25 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} module GHC.Hs.Pat ( - Pat(..), InPat, OutPat, LPat, + Pat(..), LPat, + ConPatTc (..), + CoPat (..), ListPatTc(..), + ConLikeP, HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', @@ -31,6 +39,7 @@ mkPrefixConPat, mkCharLitPat, mkNilPat, + isSimplePat, looksLazyPatBind, isBangedLPat, patNeedsParens, parenthesizePat, @@ -41,7 +50,7 @@ pprParendLPat, pprConArgs ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) @@ -49,36 +58,35 @@ import GHC.Hs.Binds import GHC.Hs.Lit import GHC.Hs.Extension -import GHC.Hs.Types -import TcEvidence -import BasicTypes +import GHC.Hs.Type +import GHC.Tc.Types.Evidence +import GHC.Types.Basic -- others: -import PprCore ( {- instance OutputableBndr TyVar -} ) -import TysWiredIn -import Var -import RdrName ( RdrName ) -import ConLike -import DataCon -import TyCon -import Outputable -import Type -import SrcLoc -import Bag -- collect ev vars from pats -import DynFlags( gopt, GeneralFlag(..) ) -import Maybes +import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) +import GHC.Builtin.Types +import GHC.Types.Var +import GHC.Types.Name.Reader ( RdrName ) +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Utils.Outputable +import GHC.Core.Type +import GHC.Types.SrcLoc +import GHC.Data.Bag -- collect ev vars from pats +import GHC.Data.Maybe +import GHC.Types.Name (Name) +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt -- libraries: import Data.Data hiding (TyCon,Fixity) -type InPat p = LPat p -- No 'Out' constructors -type OutPat p = LPat p -- No 'In' constructors - type LPat p = XRec p Pat -- | Pattern -- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation data Pat p = ------------ Simple patterns --------------- WildPat (XWildPat p) -- ^ Wildcard Pattern @@ -92,28 +100,28 @@ -- See Note [Located RdrNames] in GHC.Hs.Expr | LazyPat (XLazyPat p) (LPat p) -- ^ Lazy Pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnTilde' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | AsPat (XAsPat p) (Located (IdP p)) (LPat p) -- ^ As pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | ParPat (XParPat p) (LPat p) -- ^ Parenthesised pattern -- See Note [Parens in HsSyn] in GHC.Hs.Expr - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, + -- 'GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | BangPat (XBangPat p) (LPat p) -- ^ Bang pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation ------------ Lists, tuples, arrays --------------- | ListPat (XListPat p) @@ -124,10 +132,10 @@ -- ^ Syntactic List -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, + -- 'GHC.Parser.Annotation.AnnClose' @']'@ - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | TuplePat (XTuplePat p) -- after typechecking, holds the types of the tuple components @@ -151,54 +159,34 @@ -- will be wrapped in CoPats, no?) -- ^ Tuple sub-patterns -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, - -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ + -- - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@, + -- 'GHC.Parser.Annotation.AnnClose' @')'@ or @'#)'@ - | SumPat (XSumPat p) -- GHC.Hs.PlaceHolder before typechecker, filled in - -- afterwards with the types of the - -- alternative + | SumPat (XSumPat p) -- after typechecker, types of the alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) Arity -- Arity (INVARIANT: ≥ 2) -- ^ Anonymous sum pattern -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnClose' @'#)'@ + -- - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnOpen' @'(#'@, + -- 'GHC.Parser.Annotation.AnnClose' @'#)'@ - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation ------------ Constructor patterns --------------- - | ConPatIn (Located (IdP p)) - (HsConPatDetails p) - -- ^ Constructor Pattern In - - | ConPatOut { - pat_con :: Located ConLike, - pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal - -- tyvars of the constructor/pattern synonym - -- Use (conLikeResTy pat_con pat_arg_tys) to get - -- the type of the pattern - - pat_tvs :: [TyVar], -- Existentially bound type variables - -- in correctly-scoped order e.g. [k:*, x:k] - pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* - -- One reason for putting coercion variable here, I think, - -- is to ensure their kinds are zonked - - pat_binds :: TcEvBinds, -- Bindings involving those dictionaries - pat_args :: HsConPatDetails p, - pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher - -- Only relevant for pattern-synonyms; - -- ignored for data cons + | ConPat { + pat_con_ext :: XConPat p, + pat_con :: Located (ConLikeP p), + pat_args :: HsConPatDetails p } - -- ^ Constructor Pattern Out + -- ^ Constructor Pattern ------------ View patterns --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | ViewPat (XViewPat p) -- The overall type of the pattern -- (= the argument type of the view function) -- for hsPatType. @@ -207,10 +195,10 @@ -- ^ View Pattern ------------ Pattern splices --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ - -- 'ApiAnnotation.AnnClose' @')'@ + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@ + -- 'GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | SplicePat (XSplicePat p) (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) @@ -234,46 +222,36 @@ -- ^ Natural Pattern -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVal' @'+'@ - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | NPlusKPat (XNPlusKPat p) -- Type of overall pattern (Located (IdP p)) -- n+k pattern (Located (HsOverLit p)) -- It'll always be an HsIntegral - (HsOverLit p) -- See Note [NPlusK patterns] in TcPat + (HsOverLit p) -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat -- NB: This could be (PostTc ...), but that induced a -- a new hs-boot file. Not worth it. (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool - (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) + (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntax) -- ^ n+k pattern ------------ Pattern type signatures --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' - -- For details on above see note [Api annotations] in ApiAnnotation + -- For details on above see note [Api annotations] in GHC.Parser.Annotation | SigPat (XSigPat p) -- After typechecker: Type (LPat p) -- Pattern with a type signature - (LHsSigWcType (NoGhcTc p)) -- Signature can bind both + (HsPatSigType (NoGhcTc p)) -- Signature can bind both -- kind and type vars -- ^ Pattern with a type signature - ------------ Pattern coercions (translation only) --------------- - | CoPat (XCoPat p) - HsWrapper -- Coercion Pattern - -- If co :: t1 ~ t2, p :: t2, - -- then (CoPat co p) :: t1 - (Pat p) -- Why not LPat? Ans: existing locn will do - Type -- Type of whole pattern, t1 - -- During desugaring a (CoPat co pat) turns into a cast with 'co' on - -- the scrutinee, followed by a match on 'pat' - -- ^ Coercion Pattern - -- | Trees that Grow extension point for new constructors | XPat - (XXPat p) + !(XXPat p) + -- --------------------------------------------------------------------- data ListPatTc @@ -302,6 +280,10 @@ type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] +type instance XConPat GhcPs = NoExtField +type instance XConPat GhcRn = NoExtField +type instance XConPat GhcTc = ConPatTc + type instance XSumPat GhcPs = NoExtField type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] @@ -325,10 +307,17 @@ type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type -type instance XCoPat (GhcPass _) = NoExtField +type instance XXPat GhcPs = NoExtCon +type instance XXPat GhcRn = NoExtCon +type instance XXPat GhcTc = CoPat + -- After typechecking, we add one extra constructor: CoPat -type instance XXPat (GhcPass _) = NoExtCon +type family ConLikeP x +type instance ConLikeP GhcPs = RdrName -- IdP GhcPs +type instance ConLikeP GhcRn = Name -- IdP GhcRn +type instance ConLikeP GhcTc = ConLike + -- --------------------------------------------------------------------- @@ -340,6 +329,52 @@ hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] +-- | This is the extension field for ConPat, added after typechecking +-- It adds quite a few extra fields, to support elaboration of pattern matching. +data ConPatTc + = ConPatTc + { -- | The universal arg types 1-1 with the universal + -- tyvars of the constructor/pattern synonym + -- Use (conLikeResTy pat_con cpt_arg_tys) to get + -- the type of the pattern + cpt_arg_tys :: [Type] + + , -- | Existentially bound type variables + -- in correctly-scoped order e.g. [k:* x:k] + cpt_tvs :: [TyVar] + + , -- | Ditto *coercion variables* and *dictionaries* + -- One reason for putting coercion variable here I think + -- is to ensure their kinds are zonked + cpt_dicts :: [EvVar] + + , -- | Bindings involving those dictionaries + cpt_binds :: TcEvBinds + + , -- ^ Extra wrapper to pass to the matcher + -- Only relevant for pattern-synonyms; + -- ignored for data cons + cpt_wrap :: HsWrapper + } + +-- | Coercion Pattern (translation only) +-- +-- During desugaring a (CoPat co pat) turns into a cast with 'co' on the +-- scrutinee, followed by a match on 'pat'. +data CoPat + = CoPat + { -- | Coercion Pattern + -- If co :: t1 ~ t2, p :: t2, + -- then (CoPat co p) :: t1 + co_cpt_wrap :: HsWrapper + + , -- | Why not LPat? Ans: existing locn will do + co_pat_inner :: Pat GhcTc + + , -- | Type of whole pattern, t1 + co_pat_ty :: Type + } + -- | Haskell Record Fields -- -- HsRecFields is used only for patterns and expressions (not data type @@ -383,9 +418,9 @@ -- | Haskell Record Field -- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual', -- --- For details on above see note [Api annotations] in ApiAnnotation +-- For details on above see note [Api annotations] in GHC.Parser.Annotation data HsRecField' id arg = HsRecField { hsRecFieldLbl :: Located id, hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning @@ -423,7 +458,7 @@ -- -- The renamer produces an Unambiguous result if it can, rather than -- just doing the lookup in the typechecker, so that completely --- unambiguous updates can be represented by 'DsMeta.repUpdFields'. +-- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'. -- -- For example, suppose we have: -- @@ -445,7 +480,7 @@ -- -- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id -- --- See also Note [Disambiguating record fields] in TcExpr. +-- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Expr. hsRecFields :: HsRecFields p arg -> [XCFieldOcc p] hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) @@ -481,35 +516,41 @@ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat +-- | Print with type info if -dppr-debug is on pprPatBndr :: OutputableBndr name => name -> SDoc -pprPatBndr var -- Print with type info if -dppr-debug is on - = getPprStyle $ \ sty -> - if debugStyle sty then - parens (pprBndr LambdaBind var) -- Could pass the site to pprPat - -- but is it worth it? - else - pprPrefixOcc var +pprPatBndr var + = getPprDebug $ \case + True -> parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + False -> pprPrefixOcc var pprParendLPat :: (OutputableBndrId p) => PprPrec -> LPat (GhcPass p) -> SDoc pprParendLPat p = pprParendPat p . unLoc -pprParendPat :: (OutputableBndrId p) - => PprPrec -> Pat (GhcPass p) -> SDoc -pprParendPat p pat = sdocWithDynFlags $ \ dflags -> - if need_parens dflags pat - then parens (pprPat pat) - else pprPat pat +pprParendPat :: forall p. OutputableBndrId p + => PprPrec + -> Pat (GhcPass p) + -> SDoc +pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab -> + if need_parens print_tc_elab pat + then parens (pprPat pat) + else pprPat pat where - need_parens dflags pat - | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags - | otherwise = patNeedsParens p pat + need_parens print_tc_elab pat + | GhcTc <- ghcPass @p + , XPat ext <- pat + , CoPat {} <- ext + = print_tc_elab + + | otherwise + = patNeedsParens p pat -- For a CoPat we need parens if we are going to show it, which -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc +pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat @@ -523,39 +564,52 @@ pprPat (NPat _ l (Just _) _) = char '-' <> ppr l pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] pprPat (SplicePat _ splice) = pprSplice splice -pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens - -> if parens - then pprParendPat appPrec pat - else pprPat pat -pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty + where ppr_ty = case ghcPass @p of + GhcPs -> ppr ty + GhcRn -> ppr ty + GhcTc -> ppr ty pprPat (ListPat _ pats) = brackets (interpp'SP pats) pprPat (TuplePat _ pats bx) -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Unit x`, not `(x)` + -- `Solo x`, not `(x)` | [pat] <- pats , Boxed <- bx = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat] | otherwise = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) -pprPat (ConPatIn con details) = pprUserCon (unLoc con) details -pprPat (ConPatOut { pat_con = con - , pat_tvs = tvs - , pat_dicts = dicts - , pat_binds = binds - , pat_args = details }) - = sdocWithDynFlags $ \dflags -> - -- Tiresome; in TcBinds.tcRhs we print out a - -- typechecked Pat in an error message, - -- and we want to make sure it prints nicely - if gopt Opt_PrintTypecheckerElaboration dflags then - ppr con - <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) - , ppr binds]) - <+> pprConArgs details - else pprUserCon (unLoc con) details -pprPat (XPat n) = noExtCon n - +pprPat (ConPat { pat_con = con + , pat_args = details + , pat_con_ext = ext + } + ) + = case ghcPass @p of + GhcPs -> pprUserCon (unLoc con) details + GhcRn -> pprUserCon (unLoc con) details + GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case + False -> pprUserCon (unLoc con) details + True -> + -- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an + -- error message, and we want to make sure it prints nicely + ppr con + <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) + , ppr binds ]) + <+> pprConArgs details + where ConPatTc { cpt_tvs = tvs + , cpt_dicts = dicts + , cpt_binds = binds + } = ext +pprPat (XPat ext) = case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon ext + GhcRn -> noExtCon ext +#endif + GhcTc -> pprHsWrapper co $ \parens -> + if parens + then pprParendPat appPrec pat + else pprPat pat + where CoPat co pat _ = ext pprUserCon :: (OutputableBndr con, OutputableBndrId p) => con -> HsConPatDetails (GhcPass p) -> SDoc @@ -594,21 +648,24 @@ -} mkPrefixConPat :: DataCon -> - [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p) + [LPat GhcTc] -> [Type] -> LPat GhcTc -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys - = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc) - , pat_tvs = [] - , pat_dicts = [] - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon pats - , pat_arg_tys = tys - , pat_wrap = idHsWrapper } + = noLoc $ ConPat { pat_con = noLoc (RealDataCon dc) + , pat_args = PrefixCon pats + , pat_con_ext = ConPatTc + { cpt_tvs = [] + , cpt_dicts = [] + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = tys + , cpt_wrap = idHsWrapper + } + } -mkNilPat :: Type -> OutPat (GhcPass p) +mkNilPat :: Type -> LPat GhcTc mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] -mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) +mkCharLitPat :: SourceText -> Char -> LPat GhcTc mkCharLitPat src c = mkPrefixConPat charDataCon [noLoc $ LitPat noExtField (HsCharPrim src c)] [] @@ -676,7 +733,8 @@ looksLazyPat (WildPat {}) = False looksLazyPat _ = True -isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool +isIrrefutableHsPat :: forall p. (OutputableBndrId p) + => DynFlags -> LPat (GhcPass p) -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn @@ -686,19 +744,55 @@ -- Specifically on a ConPatIn, which is what it sees for a -- (LPat Name) in the renamer, it doesn't know the size of the -- constructor family, so it returns False. Result: only --- tuple patterns are considered irrefuable at the renamer stage. +-- tuple patterns are considered irrefutable at the renamer stage. -- -- But if it returns True, the pattern is definitely irrefutable -isIrrefutableHsPat - = goL +isIrrefutableHsPat dflags = + isIrrefutableHsPat' (xopt LangExt.Strict dflags) + +{- +Note [-XStrict and irrefutability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -XStrict is enabled the rules for irrefutability are slightly modified. +Specifically, the pattern in a program like + + do ~(Just hi) <- expr + +cannot be considered irrefutable. The ~ here merely disables the bang that +-XStrict would usually apply, rendering the program equivalent to the following +without -XStrict + + do Just hi <- expr + +To achieve make this pattern irrefutable with -XStrict the user would rather +need to write + + do ~(~(Just hi)) <- expr + +Failing to account for this resulted in #19027. To fix this isIrrefutableHsPat +takes care to check for two the irrefutability of the inner pattern when it +encounters a LazyPat and -XStrict is enabled. + +See also Note [decideBangHood] in GHC.HsToCore.Utils. +-} + +isIrrefutableHsPat' :: forall p. (OutputableBndrId p) + => Bool -- ^ Are we in a @-XStrict@ context? + -- See Note [-XStrict and irrefutability] + -> LPat (GhcPass p) -> Bool +isIrrefutableHsPat' is_strict = goL where + goL :: LPat (GhcPass p) -> Bool goL = go . unLoc + go :: Pat (GhcPass p) -> Bool go (WildPat {}) = True go (VarPat {}) = True - go (LazyPat {}) = True + go (LazyPat _ p') + | is_strict + = isIrrefutableHsPat' False p' + | otherwise = True go (BangPat _ pat) = goL pat - go (CoPat _ _ pat _) = go pat go (ParPat _ pat) = goL pat go (AsPat _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat @@ -708,19 +802,19 @@ -- See Note [Unboxed sum patterns aren't irrefutable] go (ListPat {}) = False - go (ConPatIn {}) = False -- Conservative - go (ConPatOut - { pat_con = (dL->L _ (RealDataCon con)) + go (ConPat + { pat_con = con , pat_args = details }) - = - isJust (tyConSingleDataCon_maybe (dataConTyCon con)) - -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because - -- the latter is false of existentials. See #4439 - && all goL (hsConPatArgs details) - go (ConPatOut - { pat_con = (dL->L _ (PatSynCon _pat)) }) - = False -- Conservative - go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 + = case ghcPass @p of + GhcPs -> False -- Conservative + GhcRn -> False -- Conservative + GhcTc -> case con of + L _ (PatSynCon _pat) -> False -- Conservative + L _ (RealDataCon con) -> + isJust (tyConSingleDataCon_maybe (dataConTyCon con)) + -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because + -- the latter is false of existentials. See #4439 + && all goL (hsConPatArgs details) go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False @@ -729,8 +823,31 @@ -- since we cannot know until the splice is evaluated. go (SplicePat {}) = False - go (XPat {}) = False + go (XPat ext) = case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon ext + GhcRn -> noExtCon ext +#endif + GhcTc -> go pat + where CoPat _ pat _ = ext +-- | Is the pattern any of combination of: +-- +-- - (pat) +-- - pat :: Type +-- - ~pat +-- - !pat +-- - x (variable) +isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) +isSimplePat p = case unLoc p of + ParPat _ x -> isSimplePat x + SigPat _ x _ -> isSimplePat x + LazyPat _ x -> isSimplePat x + BangPat _ x -> isSimplePat x + VarPat _ x -> Just (unLoc x) + _ -> Nothing + + {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as @@ -755,16 +872,21 @@ -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs -- parentheses under precedence @p@. -patNeedsParens :: PprPrec -> Pat p -> Bool +patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool patNeedsParens p = go where + go :: Pat (GhcPass p) -> Bool go (NPlusKPat {}) = p > opPrec go (SplicePat {}) = False - go (ConPatIn _ ds) = conPatNeedsParens p ds - go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp) + go (ConPat { pat_args = ds}) + = conPatNeedsParens p ds go (SigPat {}) = p >= sigPrec go (ViewPat {}) = True - go (CoPat _ _ p _) = go p + go (XPat ext) = case ghcPass @p of + GhcPs -> noExtCon ext + GhcRn -> noExtCon ext + GhcTc -> go inner + where CoPat _ inner _ = ext go (WildPat {}) = False go (VarPat {}) = False go (LazyPat {}) = False @@ -776,7 +898,6 @@ go (ListPat {}) = False go (LitPat _ l) = hsLitNeedsParens p l go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) - go (XPat {}) = True -- conservative default -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@. @@ -789,9 +910,12 @@ -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. -parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) -parenthesizePat p lpat@(dL->L loc pat) - | patNeedsParens p pat = cL loc (ParPat noExtField lpat) +parenthesizePat :: IsPass p + => PprPrec + -> LPat (GhcPass p) + -> LPat (GhcPass p) +parenthesizePat p lpat@(L loc pat) + | patNeedsParens p pat = L loc (ParPat noExtField lpat) | otherwise = lpat {- @@ -815,12 +939,16 @@ ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps SumPat _ p _ _ -> collectEvVarsLPat p - ConPatOut {pat_dicts = dicts, pat_args = args} + ConPat + { pat_args = args + , pat_con_ext = ConPatTc + { cpt_dicts = dicts + } + } -> unionBags (listToBag dicts) $ unionManyBags $ map collectEvVarsLPat $ hsConPatArgs args SigPat _ p _ -> collectEvVarsLPat p - CoPat _ _ p _ -> collectEvVarsPat p - ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" + XPat (CoPat _ p _) -> collectEvVarsPat p _other_pat -> emptyBag diff --git a/GHC/Hs/Pat.hs-boot b/GHC/Hs/Pat.hs-boot --- a/GHC/Hs/Pat.hs-boot +++ b/GHC/Hs/Pat.hs-boot @@ -1,19 +1,20 @@ {-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} module GHC.Hs.Pat where -import Outputable +import GHC.Utils.Outputable import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec ) +import Data.Kind type role Pat nominal -data Pat (i :: *) +data Pat (i :: Type) type LPat i = XRec i Pat instance OutputableBndrId p => Outputable (Pat (GhcPass p)) diff --git a/GHC/Hs/PlaceHolder.hs b/GHC/Hs/PlaceHolder.hs deleted file mode 100644 --- a/GHC/Hs/PlaceHolder.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - -module GHC.Hs.PlaceHolder where - -import Name -import NameSet -import RdrName -import Var - - - -{- -%************************************************************************ -%* * -\subsection{Annotating the syntax} -%* * -%************************************************************************ --} - --- NB: These are intentionally open, allowing API consumers (like Haddock) --- to declare new instances - -placeHolderNamesTc :: NameSet -placeHolderNamesTc = emptyNameSet - -{- -TODO:AZ: remove this, and check if we still need all the UndecidableInstances - -Note [Pass sensitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the same AST types are re-used through parsing,renaming and type -checking there are naturally some places in the AST that do not have -any meaningful value prior to the pass they are assigned a value. - -Historically these have been filled in with place holder values of the form - - panic "error message" - -This has meant the AST is difficult to traverse using standard generic -programming techniques. The problem is addressed by introducing -pass-specific data types, implemented as a pair of open type families, -one for PostTc and one for PostRn. These are then explicitly populated -with a PlaceHolder value when they do not yet have meaning. - -In terms of actual usage, we have the following - - PostTc id Kind - PostTc id Type - - PostRn id Fixity - PostRn id NameSet - -TcId and Var are synonyms for Id - -Unfortunately the type checker termination checking conditions fail for the -DataId constraint type based on this, so even though it is safe the -UndecidableInstances pragma is required where this is used. --} - - --- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', --- for printing messages related to a 'Match' -type family NameOrRdrName id where - NameOrRdrName Id = Name - NameOrRdrName Name = Name - NameOrRdrName RdrName = RdrName diff --git a/GHC/Hs/Stats.hs b/GHC/Hs/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Stats.hs @@ -0,0 +1,187 @@ +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Hs.Stats ( ppSourceStats ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Hs +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located HsModule -> SDoc +ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls })) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("ClassOpSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("PatSynBinds ", patsyn_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD _ d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD _ d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD _ d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD _ d <- decls] + + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True + ; _ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds, patsyn_ds) + = sum3 (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = sum7 (map import_info imports) + (data_constrs, data_derivs) + = sum2 (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = sum2 (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = sum5 (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) + count_bind (PatBind {}) = (0,1,0) + count_bind (FunBind {}) = (0,1,0) + count_bind (PatSynBind {}) = (0,0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = sum5 (map sig_info sigs) + + sig_info (FixSig {}) = (1,0,0,0,0) + sig_info (TypeSig {}) = (0,1,0,0,0) + sig_info (SpecSig {}) = (0,0,1,0,0) + sig_info (InlineSig {}) = (0,0,0,1,0) + sig_info (ClassOpSig {}) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int) + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + + safe_info False = 0 + safe_info True = 1 + qual_info NotQualified = 0 + qual_info _ = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + + data_info (DataDecl { tcdDataDefn = HsDataDefn + { dd_cons = cs + , dd_derivs = L _ derivs}}) + = ( length cs + , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) + 0 derivs ) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = (classops, addpr (sum3 (map count_bind methods))) + where + methods = map unLoc $ bagToList (tcdMeths decl) + (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) + class_info _ = (0,0) + + inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int) + inst_info (TyFamInstD {}) = (0,0,0,1,0) + inst_info (DataFamInstD {}) = (0,0,0,0,1) + inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths + , cid_sigs = inst_sigs + , cid_tyfam_insts = ats + , cid_datafam_insts = adts } }) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + (addpr (sum3 (map count_bind methods)), + ss, is, length ats, length adts) + where + methods = map unLoc $ bagToList inst_meths + + -- TODO: use Sum monoid + addpr :: (Int,Int,Int) -> Int + sum2 :: [(Int, Int)] -> (Int, Int) + sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) + sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) + sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) + add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) + -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y,z) = x+y+z + sum2 = foldr add2 (0,0) + where + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + sum3 = foldr add3 (0,0,0) + where + add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) + sum5 = foldr add5 (0,0,0,0,0) + where + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + sum7 = foldr add7 (0,0,0,0,0,0,0) + + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) diff --git a/GHC/Hs/Type.hs b/GHC/Hs/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Type.hs @@ -0,0 +1,2084 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +GHC.Hs.Type: Abstract syntax: user-defined types +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Hs.Type ( + Mult, HsScaled(..), + hsMult, hsScaledThing, + HsArrow(..), arrowToHsType, + hsLinear, hsUnrestricted, isUnrestricted, + + HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, + HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, + LHsQTyVars(..), + HsImplicitBndrs(..), + HsWildCardBndrs(..), + HsPatSigType(..), HsPSRn(..), + LHsSigType, LHsSigWcType, LHsWcType, + HsTupleSort(..), + HsContext, LHsContext, noLHsContext, + HsTyLit(..), + HsIPName(..), hsIPNameFS, + HsArg(..), numVisibleArgs, + LHsTypeArg, lhsTypeArgSrcSpan, + OutputableBndrFlag, + + LBangType, BangType, + HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..), + getBangType, getBangStrictness, + + ConDeclField(..), LConDeclField, pprConDeclFields, + + HsConDetails(..), + + FieldOcc(..), LFieldOcc, mkFieldOcc, + AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, + rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, + unambiguousFieldOcc, ambiguousFieldOcc, + + mkAnonWildCardTy, pprAnonWildCard, + + mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody, + mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, + mkHsForAllVisTele, mkHsForAllInvisTele, + mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, + isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, + hsScopedTvs, hsWcScopedTvs, dropWildCards, + hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, + splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, + splitLHsPatSynTy, + splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy, + splitLHsSigmaTyInvis, splitLHsGadtTy, + splitHsFunType, hsTyGetAppHead_maybe, + mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, + ignoreParens, hsSigType, hsSigWcType, hsPatSigType, + hsTyKindSig, + hsConDetailsArgs, + setHsTyVarBndrFlag, hsTyVarBndrFlag, + + -- Printing + pprHsType, pprHsForAll, pprHsExplicitForAll, + pprLHsContext, + hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) + +import GHC.Hs.Extension + +import GHC.Types.Id ( Id ) +import GHC.Types.Name( Name, NamedThing(getName) ) +import GHC.Types.Name.Reader ( RdrName ) +import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..) ) +import GHC.Core.TyCo.Rep ( Type(..) ) +import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) +import GHC.Core.Type +import GHC.Hs.Doc +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc ( count ) + +import Data.Data hiding ( Fixity, Prefix, Infix ) +import Data.Maybe +import GHC.Parser.Annotation + +{- +************************************************************************ +* * +\subsection{Bang annotations} +* * +************************************************************************ +-} + +-- | Located Bang Type +type LBangType pass = Located (BangType pass) + +-- | Bang Type +-- +-- In the parser, strictness and packedness annotations bind more tightly +-- than docstrings. This means that when consuming a 'BangType' (and looking +-- for 'HsBangTy') we must be ready to peer behind a potential layer of +-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example. +type BangType pass = HsType pass -- Bangs are in the HsType data type + +getBangType :: LHsType a -> LHsType a +getBangType (L _ (HsBangTy _ _ lty)) = lty +getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) = + addCLoc lty lds (HsDocTy x lty lds) +getBangType lty = lty + +getBangStrictness :: LHsType a -> HsSrcBang +getBangStrictness (L _ (HsBangTy _ s _)) = s +getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s +getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) + +{- +************************************************************************ +* * +\subsection{Data types} +* * +************************************************************************ + +This is the syntax for types as seen in type signatures. + +Note [HsBSig binder lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a binder (or pattern) decorated with a type or kind, + \ (x :: a -> a). blah + forall (a :: k -> *) (b :: k). blah +Then we use a LHsBndrSig on the binder, so that the +renamer can decorate it with the variables bound +by the pattern ('a' in the first example, 'k' in the second), +assuming that neither of them is in scope already +See also Note [Kind and type-variable binders] in GHC.Rename.HsType + +Note [HsType binders] +~~~~~~~~~~~~~~~~~~~~~ +The system for recording type and kind-variable binders in HsTypes +is a bit complicated. Here's how it works. + +* In a HsType, + HsForAllTy represents an /explicit, user-written/ 'forall' + e.g. forall a b. {...} or + forall a b -> {...} + HsQualTy represents an /explicit, user-written/ context + e.g. (Eq a, Show a) => ... + The context can be empty if that's what the user wrote + These constructors represent what the user wrote, no more + and no less. + +* The ForAllTelescope field of HsForAllTy represents whether a forall is + invisible (e.g., forall a b. {...}, with a dot) or visible + (e.g., forall a b -> {...}, with an arrow). + +* HsTyVarBndr describes a quantified type variable written by the + user. For example + f :: forall a (b :: *). blah + here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has + a list of LHsTyVarBndrs. + +* HsImplicitBndrs is a wrapper that gives the implicitly-quantified + kind and type variables of the wrapped thing. It is filled in by + the renamer. For example, if the user writes + f :: a -> a + the HsImplicitBinders binds the 'a' (not a HsForAllTy!). + NB: this implicit quantification is purely lexical: we bind any + type or kind variables that are not in scope. The type checker + may subsequently quantify over further kind variables. + +* HsWildCardBndrs is a wrapper that binds the wildcard variables + of the wrapped thing. It is filled in by the renamer + f :: _a -> _ + The enclosing HsWildCardBndrs binds the wildcards _a and _. + +* HsSigPatType describes types that appear in pattern signatures and + the signatures of term-level binders in RULES. Like + HsWildCardBndrs/HsImplicitBndrs, they track the names of wildcard + variables and implicitly bound type variables. Unlike + HsImplicitBndrs, however, HsSigPatTypes do not obey the + forall-or-nothing rule. See Note [Pattern signature binders and scoping]. + +* The explicit presence of these wrappers specifies, in the HsSyn, + exactly where implicit quantification is allowed, and where + wildcards are allowed. + +* LHsQTyVars is used in data/class declarations, where the user gives + explicit *type* variable bindings, but we need to implicitly bind + *kind* variables. For example + class C (a :: k -> *) where ... + The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars + +Note [The wildcard story for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types can have wildcards in them, to support partial type signatures, +like f :: Int -> (_ , _a) -> _a + +A wildcard in a type can be + + * An anonymous wildcard, + written '_' + In HsType this is represented by HsWildCardTy. + The renamer leaves it untouched, and it is later given a fresh + meta tyvar in the typechecker. + + * A named wildcard, + written '_a', '_foo', etc + In HsType this is represented by (HsTyVar "_a") + i.e. a perfectly ordinary type variable that happens + to start with an underscore + +Note carefully: + +* When NamedWildCards is off, type variables that start with an + underscore really /are/ ordinary type variables. And indeed, even + when NamedWildCards is on you can bind _a explicitly as an ordinary + type variable: + data T _a _b = MkT _b _a + Or even: + f :: forall _a. _a -> _b + Here _a is an ordinary forall'd binder, but (With NamedWildCards) + _b is a named wildcard. (See the comments in #10982) + +* Named wildcards are bound by the HsWildCardBndrs (for types that obey the + forall-or-nothing rule) and HsPatSigType (for type signatures in patterns + and term-level binders in RULES), which wrap types that are allowed to have + wildcards. Unnamed wildcards, however are left unchanged until typechecking, + where we give them fresh wild tyvars and determine whether or not to emit + hole constraints on each wildcard (we don't if it's a visible type/kind + argument or a type family pattern). See related notes + Note [Wildcards in visible kind application] and + Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType. + +* After type checking is done, we report what types the wildcards + got unified with. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does a *stable topological sort* on the variables. +By "stable", we mean that any two variables who do not depend on each other +preserve their existing left-to-right ordering. + +Implicitly bound variables are collected by the extract- family of functions +(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in GHC.Rename.HsType. +These functions thus promise to keep left-to-right ordering. +Look for pointers to this note to see the places where the action happens. + +Note that we also maintain this ordering in kind signatures. Even though +there's no visible kind application (yet), having implicit variables be +quantified in left-to-right order in kind signatures is nice since: + +* It's consistent with the treatment for type signatures. +* It can affect how types are displayed with -fprint-explicit-kinds (see + #15568 for an example), which is a situation where knowing the order in + which implicit variables are quantified can be useful. +* In the event that visible kind application is implemented, the order in + which we would expect implicit variables to be ordered in kinds will have + already been established. +-} + +-- | Located Haskell Context +type LHsContext pass = Located (HsContext pass) + -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit' + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + +noLHsContext :: LHsContext pass +-- Use this when there is no context in the original program +-- It would really be more kosher to use a Maybe, to distinguish +-- class () => C a where ... +-- from +-- class C a where ... +noLHsContext = noLoc [] + +-- | Haskell Context +type HsContext pass = [LHsType pass] + +-- | Located Haskell Type +type LHsType pass = Located (HsType pass) + -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + +-- | Haskell Kind +type HsKind pass = HsType pass + +-- | Located Haskell Kind +type LHsKind pass = Located (HsKind pass) + -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + +-------------------------------------------------- +-- LHsQTyVars +-- The explicitly-quantified binders in a data/type declaration + +-- | The type variable binders in an 'HsForAllTy'. +-- See also @Note [Variable Specificity and Forall Visibility]@ in +-- "GHC.Tc.Gen.HsType". +data HsForAllTelescope pass + = HsForAllVis -- ^ A visible @forall@ (e.g., @forall a -> {...}@). + -- These do not have any notion of specificity, so we use + -- '()' as a placeholder value. + { hsf_xvis :: XHsForAllVis pass + , hsf_vis_bndrs :: [LHsTyVarBndr () pass] + } + | HsForAllInvis -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), + -- where each binder has a 'Specificity'. + { hsf_xinvis :: XHsForAllInvis pass + , hsf_invis_bndrs :: [LHsTyVarBndr Specificity pass] + } + | XHsForAllTelescope !(XXHsForAllTelescope pass) + +type instance XHsForAllVis (GhcPass _) = NoExtField +type instance XHsForAllInvis (GhcPass _) = NoExtField + +type instance XXHsForAllTelescope (GhcPass _) = NoExtCon + +-- | Located Haskell Type Variable Binder +type LHsTyVarBndr flag pass = Located (HsTyVarBndr flag pass) + -- See Note [HsType binders] + +-- | Located Haskell Quantified Type Variables +data LHsQTyVars pass -- See Note [HsType binders] + = HsQTvs { hsq_ext :: XHsQTvs pass + + , hsq_explicit :: [LHsTyVarBndr () pass] + -- Explicit variables, written by the user + } + | XLHsQTyVars !(XXLHsQTyVars pass) + +type HsQTvsRn = [Name] -- Implicit variables + -- For example, in data T (a :: k1 -> k2) = ... + -- the 'a' is explicit while 'k1', 'k2' are implicit + +type instance XHsQTvs GhcPs = NoExtField +type instance XHsQTvs GhcRn = HsQTvsRn +type instance XHsQTvs GhcTc = HsQTvsRn + +type instance XXLHsQTyVars (GhcPass _) = NoExtCon + +mkHsForAllVisTele :: + [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p) +mkHsForAllVisTele vis_bndrs = + HsForAllVis { hsf_xvis = noExtField, hsf_vis_bndrs = vis_bndrs } + +mkHsForAllInvisTele :: + [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p) +mkHsForAllInvisTele invis_bndrs = + HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } + +mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs +mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } + +hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr () pass] +hsQTvExplicit = hsq_explicit + +emptyLHsQTvs :: LHsQTyVars GhcRn +emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } + +------------------------------------------------ +-- HsImplicitBndrs +-- Used to quantify the implicit binders of a type +-- * Implicit binders of a type signature (LHsSigType/LHsSigWcType) +-- * Patterns in a type/data family instance (HsTyPats) + +-- | Haskell Implicit Binders +data HsImplicitBndrs pass thing -- See Note [HsType binders] + = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name] + -- Implicitly-bound kind & type vars + -- Order is important; see + -- Note [Ordering of implicit variables] + -- in GHC.Rename.HsType + + , hsib_body :: thing -- Main payload (type or list of types) + } + | XHsImplicitBndrs !(XXHsImplicitBndrs pass thing) + +type instance XHsIB GhcPs _ = NoExtField +type instance XHsIB GhcRn _ = [Name] +type instance XHsIB GhcTc _ = [Name] + +type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon + +-- | Haskell Wildcard Binders +data HsWildCardBndrs pass thing + -- See Note [HsType binders] + -- See Note [The wildcard story for types] + = HsWC { hswc_ext :: XHsWC pass thing + -- after the renamer + -- Wild cards, only named + -- See Note [Wildcards in visible kind application] + + , hswc_body :: thing + -- Main payload (type or list of types) + -- If there is an extra-constraints wildcard, + -- it's still there in the hsc_body. + } + | XHsWildCardBndrs !(XXHsWildCardBndrs pass thing) + +type instance XHsWC GhcPs b = NoExtField +type instance XHsWC GhcRn b = [Name] +type instance XHsWC GhcTc b = [Name] + +type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon + +-- | Types that can appear in pattern signatures, as well as the signatures for +-- term-level binders in RULES. +-- See @Note [Pattern signature binders and scoping]@. +-- +-- This is very similar to 'HsSigWcType', but with +-- slightly different semantics: see @Note [HsType binders]@. +-- See also @Note [The wildcard story for types]@. +data HsPatSigType pass + = HsPS { hsps_ext :: XHsPS pass -- ^ After renamer: 'HsPSRn' + , hsps_body :: LHsType pass -- ^ Main payload (the type itself) + } + | XHsPatSigType !(XXHsPatSigType pass) + +-- | The extension field for 'HsPatSigType', which is only used in the +-- renamer onwards. See @Note [Pattern signature binders and scoping]@. +data HsPSRn = HsPSRn + { hsps_nwcs :: [Name] -- ^ Wildcard names + , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names + } + deriving Data + +type instance XHsPS GhcPs = NoExtField +type instance XHsPS GhcRn = HsPSRn +type instance XHsPS GhcTc = HsPSRn + +type instance XXHsPatSigType (GhcPass _) = NoExtCon + +-- | Located Haskell Signature Type +type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only + +-- | Located Haskell Wildcard Type +type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only + +-- | Located Haskell Signature Wildcard Type +type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both + +-- See Note [Representing type signatures] + +hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing +hsImplicitBody (HsIB { hsib_body = body }) = body + +hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) +hsSigType = hsImplicitBody + +hsSigWcType :: LHsSigWcType pass -> LHsType pass +hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) + +hsPatSigType :: HsPatSigType pass -> LHsType pass +hsPatSigType = hsps_body + +dropWildCards :: LHsSigWcType pass -> LHsSigType pass +-- Drop the wildcard part of a LHsSigWcType +dropWildCards sig_ty = hswc_body sig_ty + +{- Note [Representing type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsSigType is used to represent an explicit user type signature +such as f :: a -> a + or g (x :: a -> a) = x + +A HsSigType is just a HsImplicitBndrs wrapping a LHsType. + * The HsImplicitBndrs binds the /implicitly/ quantified tyvars + * The LHsType binds the /explicitly/ quantified tyvars + +E.g. For a signature like + f :: forall (a::k). blah +we get + HsIB { hsib_vars = [k] + , hsib_body = HsForAllTy { hst_tele = HsForAllInvis [(a::*)] + , hst_body = blah } +The implicit kind variable 'k' is bound by the HsIB; +the explicitly forall'd tyvar 'a' is bound by the HsForAllTy + +Note [Pattern signature binders and scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the pattern signatures like those on `t` and `g` in: + + f = let h = \(t :: (b, b) -> + \(g :: forall a. a -> b) -> + ...(t :: (Int,Int))... + in woggle + +* The `b` in t's pattern signature is implicitly bound and scopes over + the signature and the body of the lambda. It stands for a type (any type); + indeed we subsequently discover that b=Int. + (See Note [TyVarTv] in GHC.Tc.Utils.TcMType for more on this point.) +* The `b` in g's pattern signature is an /occurrence/ of the `b` bound by + t's pattern signature. +* The `a` in `forall a` scopes only over the type `a -> b`, not over the body + of the lambda. +* There is no forall-or-nothing rule for pattern signatures, which is why the + type `forall a. a -> b` is permitted in `g`'s pattern signature, even though + `b` is not explicitly bound. + See Note [forall-or-nothing rule] in GHC.Rename.HsType. + +Similar scoping rules apply to term variable binders in RULES, like in the +following example: + + {-# RULES "h" forall (t :: (b, b)) (g :: forall a. a -> b). h t g = ... #-} + +Just like in pattern signatures, the `b` in t's signature is implicitly bound +and scopes over the remainder of the RULE. As a result, the `b` in g's +signature is an occurrence. Moreover, the `a` in `forall a` scopes only over +the type `a -> b`, and the forall-or-nothing rule does not apply. + +While quite similar, RULE term binder signatures behave slightly differently +from pattern signatures in two ways: + +1. Unlike in pattern signatures, where type variables can stand for any type, + type variables in RULE term binder signatures are skolems. + See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType for + more on this point. + + In this sense, type variables in pattern signatures are quite similar to + named wildcards, as both can refer to arbitrary types. The main difference + lies in error reporting: if a named wildcard `_a` in a pattern signature + stands for Int, then by default GHC will emit a warning stating as much. + Changing `_a` to `a`, on the other hand, will cause it not to be reported. +2. In the `h` RULE above, only term variables are explicitly bound, so any free + type variables in the term variables' signatures are implicitly bound. + This is just like how the free type variables in pattern signatures are + implicitly bound. If a RULE explicitly binds both term and type variables, + however, then free type variables in term signatures are /not/ implicitly + bound. For example, this RULE would be ill scoped: + + {-# RULES "h2" forall b. forall (t :: (b, c)) (g :: forall a. a -> b). + h2 t g = ... #-} + + This is because `b` and `c` occur free in the signature for `t`, but only + `b` was explicitly bound, leaving `c` out of scope. If the RULE had started + with `forall b c.`, then it would have been accepted. + +The types in pattern signatures and RULE term binder signatures are represented +in the AST by HsSigPatType. From the renamer onward, the hsps_ext field (of +type HsPSRn) tracks the names of named wildcards and implicitly bound type +variables so that they can be brought into scope during renaming and +typechecking. +-} + +mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing +mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField + , hsib_body = x } + +mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing +mkHsWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = noExtField } + +mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs +mkHsPatSigType x = HsPS { hsps_ext = noExtField + , hsps_body = x } + +-- Add empty binders. This is a bit suspicious; what if +-- the wrapped thing had free type variables? +mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing +mkEmptyImplicitBndrs x = HsIB { hsib_ext = [] + , hsib_body = x } + +mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing +mkEmptyWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = [] } + + +-------------------------------------------------- +-- | These names are used early on to store the names of implicit +-- parameters. They completely disappear after type-checking. +newtype HsIPName = HsIPName FastString + deriving( Eq, Data ) + +hsIPNameFS :: HsIPName -> FastString +hsIPNameFS (HsIPName n) = n + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + +-------------------------------------------------- + +-- | Haskell Type Variable Binder +-- The flag annotates the binder. It is 'Specificity' in places where +-- explicit specificity is allowed (e.g. x :: forall {a} b. ...) or +-- '()' in other places. +data HsTyVarBndr flag pass + = UserTyVar -- no explicit kinding + (XUserTyVar pass) + flag + (Located (IdP pass)) + -- See Note [Located RdrNames] in GHC.Hs.Expr + + | KindedTyVar + (XKindedTyVar pass) + flag + (Located (IdP pass)) + (LHsKind pass) -- The user-supplied kind signature + -- ^ + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnClose' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | XTyVarBndr + !(XXTyVarBndr pass) + +type instance XUserTyVar (GhcPass _) = NoExtField +type instance XKindedTyVar (GhcPass _) = NoExtField + +type instance XXTyVarBndr (GhcPass _) = NoExtCon + +-- | Return the attached flag +hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag +hsTyVarBndrFlag (UserTyVar _ fl _) = fl +hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl + +-- | Set the attached flag +setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass) + -> HsTyVarBndr flag (GhcPass pass) +setHsTyVarBndrFlag f (UserTyVar x _ l) = UserTyVar x f l +setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k + +-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? +isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool +isHsKindedTyVar (UserTyVar {}) = False +isHsKindedTyVar (KindedTyVar {}) = True +isHsKindedTyVar (XTyVarBndr {}) = False + +-- | Do all type variables in this 'LHsQTyVars' come with kind annotations? +hsTvbAllKinded :: LHsQTyVars pass -> Bool +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit + +instance NamedThing (HsTyVarBndr flag GhcRn) where + getName (UserTyVar _ _ v) = unLoc v + getName (KindedTyVar _ _ v _) = unLoc v + +-- | Haskell Type +data HsType pass + = HsForAllTy -- See Note [HsType binders] + { hst_xforall :: XForAllTy pass + , hst_tele :: HsForAllTelescope pass + -- Explicit, user-supplied 'forall a {b} c' + , hst_body :: LHsType pass -- body type + } + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForall', + -- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow' + -- For details on above see note [Api annotations] in "GHC.Parser.Annotation" + + | HsQualTy -- See Note [HsType binders] + { hst_xqual :: XQualTy pass + , hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } + + | HsTyVar (XTyVar pass) + PromotionFlag -- Whether explicitly promoted, + -- for the pretty printer + (Located (IdP pass)) + -- Type variable, type constructor, or data constructor + -- see Note [Promotions (HsTyVar)] + -- See Note [Located RdrNames] in GHC.Hs.Expr + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsAppTy (XAppTy pass) + (LHsType pass) + (LHsType pass) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsAppKindTy (XAppKindTy pass) -- type level type app + (LHsType pass) + (LHsKind pass) + + | HsFunTy (XFunTy pass) + (HsArrow pass) + (LHsType pass) -- function type + (LHsType pass) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow', + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsListTy (XListTy pass) + (LHsType pass) -- Element type + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, + -- 'GHC.Parser.Annotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsTupleTy (XTupleTy pass) + HsTupleSort + [LHsType pass] -- Element types (length gives arity) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(' or '(#'@, + -- 'GHC.Parser.Annotation.AnnClose' @')' or '#)'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsSumTy (XSumTy pass) + [LHsType pass] -- Element types (length gives arity) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@, + -- 'GHC.Parser.Annotation.AnnClose' '#)'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsOpTy (XOpTy pass) + (LHsType pass) (Located (IdP pass)) (LHsType pass) + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsParTy (XParTy pass) + (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr + -- Parenthesis preserved for the precedence re-arrangement in + -- GHC.Rename.HsType + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, + -- 'GHC.Parser.Annotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsIParamTy (XIParamTy pass) + (Located HsIPName) -- (?x :: ty) + (LHsType pass) -- Implicit parameters as they occur in + -- contexts + -- ^ + -- > (?x :: ty) + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsStarTy (XStarTy pass) + Bool -- Is this the Unicode variant? + -- Note [HsStarTy] + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + | HsKindSig (XKindSig pass) + (LHsType pass) -- (ty :: kind) + (LHsKind pass) -- A type with a kind signature + -- ^ + -- > (ty :: kind) + -- + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, + -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsSpliceTy (XSpliceTy pass) + (HsSplice pass) -- Includes quasi-quotes + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@, + -- 'GHC.Parser.Annotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsDocTy (XDocTy pass) + (LHsType pass) LHsDocString -- A documented type + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsBangTy (XBangTy pass) + HsSrcBang (LHsType pass) -- Bang-style type annotations + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : + -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, + -- 'GHC.Parser.Annotation.AnnClose' @'#-}'@ + -- 'GHC.Parser.Annotation.AnnBang' @\'!\'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsRecTy (XRecTy pass) + [LConDeclField pass] -- Only in data type declarations + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, + -- 'GHC.Parser.Annotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* + -- -- Core Type through HsSyn. + -- -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsExplicitListTy -- A promoted explicit list + (XExplicitListTy pass) + PromotionFlag -- whether explicitly promoted, for pretty printer + [LHsType pass] + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'["@, + -- 'GHC.Parser.Annotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsExplicitTupleTy -- A promoted explicit tuple + (XExplicitTupleTy pass) + [LHsType pass] + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'("@, + -- 'GHC.Parser.Annotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + | HsWildCardTy (XWildCardTy pass) -- A type wildcard + -- See Note [The wildcard story for types] + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + + -- For adding new constructors via Trees that Grow + | XHsType + (XXType pass) + +data NewHsTypeX + = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. + -- See also Note [Typechecking NHsCoreTys] in + -- GHC.Tc.Gen.HsType. + deriving Data + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None + +instance Outputable NewHsTypeX where + ppr (NHsCoreTy ty) = ppr ty + +type instance XForAllTy (GhcPass _) = NoExtField +type instance XQualTy (GhcPass _) = NoExtField +type instance XTyVar (GhcPass _) = NoExtField +type instance XAppTy (GhcPass _) = NoExtField +type instance XFunTy (GhcPass _) = NoExtField +type instance XListTy (GhcPass _) = NoExtField +type instance XTupleTy (GhcPass _) = NoExtField +type instance XSumTy (GhcPass _) = NoExtField +type instance XOpTy (GhcPass _) = NoExtField +type instance XParTy (GhcPass _) = NoExtField +type instance XIParamTy (GhcPass _) = NoExtField +type instance XStarTy (GhcPass _) = NoExtField +type instance XKindSig (GhcPass _) = NoExtField + +type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives + +type instance XSpliceTy GhcPs = NoExtField +type instance XSpliceTy GhcRn = NoExtField +type instance XSpliceTy GhcTc = Kind + +type instance XDocTy (GhcPass _) = NoExtField +type instance XBangTy (GhcPass _) = NoExtField +type instance XRecTy (GhcPass _) = NoExtField + +type instance XExplicitListTy GhcPs = NoExtField +type instance XExplicitListTy GhcRn = NoExtField +type instance XExplicitListTy GhcTc = Kind + +type instance XExplicitTupleTy GhcPs = NoExtField +type instance XExplicitTupleTy GhcRn = NoExtField +type instance XExplicitTupleTy GhcTc = [Kind] + +type instance XTyLit (GhcPass _) = NoExtField + +type instance XWildCardTy (GhcPass _) = NoExtField + +type instance XXType (GhcPass _) = NewHsTypeX + + +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in +-- the following +-- | Haskell Type Literal +data HsTyLit + = HsNumTy SourceText Integer + | HsStrTy SourceText FastString + deriving Data + +oneDataConHsTy :: HsType GhcRn +oneDataConHsTy = HsTyVar noExtField NotPromoted (noLoc oneDataConName) + +manyDataConHsTy :: HsType GhcRn +manyDataConHsTy = HsTyVar noExtField NotPromoted (noLoc manyDataConName) + +isUnrestricted :: HsArrow GhcRn -> Bool +isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName +isUnrestricted _ = False + +-- | Denotes the type of arrows in the surface language +data HsArrow pass + = HsUnrestrictedArrow IsUnicodeSyntax + -- ^ a -> b or a → b + | HsLinearArrow IsUnicodeSyntax + -- ^ a %1 -> b or a %1 → b, or a ⊸ b + | HsExplicitMult IsUnicodeSyntax (LHsType pass) + -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! + -- This is how the programmer wrote it). It is stored as an + -- `HsType` so as to preserve the syntax as written in the + -- program. + +-- | Convert an arrow into its corresponding multiplicity. In essence this +-- erases the information of whether the programmer wrote an explicit +-- multiplicity or a shorthand. +arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn +arrowToHsType (HsUnrestrictedArrow _) = noLoc manyDataConHsTy +arrowToHsType (HsLinearArrow _) = noLoc oneDataConHsTy +arrowToHsType (HsExplicitMult _ p) = p + +-- | This is used in the syntax. In constructor declaration. It must keep the +-- arrow representation. +data HsScaled pass a = HsScaled (HsArrow pass) a + +hsMult :: HsScaled pass a -> HsArrow pass +hsMult (HsScaled m _) = m + +hsScaledThing :: HsScaled pass a -> a +hsScaledThing (HsScaled _ t) = t + +-- | When creating syntax we use the shorthands. It's better for printing, also, +-- the shorthands work trivially at each pass. +hsUnrestricted, hsLinear :: a -> HsScaled pass a +hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax) +hsLinear = HsScaled (HsLinearArrow NormalSyntax) + +instance Outputable a => Outputable (HsScaled pass a) where + ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t + ppr t + +instance + (OutputableBndrId pass) => + Outputable (HsArrow (GhcPass pass)) where + ppr arr = parens (pprHsArrow arr) + +-- See #18846 +pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc +pprHsArrow (HsUnrestrictedArrow _) = arrow +pprHsArrow (HsLinearArrow _) = lollipop +pprHsArrow (HsExplicitMult _ p) = (mulArrow (ppr p)) + +{- +Note [Unit tuples] +~~~~~~~~~~~~~~~~~~ +Consider the type + type instance F Int = () +We want to parse that "()" + as HsTupleTy HsBoxedOrConstraintTuple [], +NOT as HsTyVar unitTyCon + +Why? Because F might have kind (* -> Constraint), so we when parsing we +don't know if that tuple is going to be a constraint tuple or an ordinary +unit tuple. The HsTupleSort flag is specifically designed to deal with +that, but it has to work for unit tuples too. + +Note [Promotions (HsTyVar)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsTyVar: A name in a type or kind. + Here are the allowed namespaces for the name. + In a type: + Var: not allowed + Data: promoted data constructor + Tv: type variable + TcCls before renamer: type constructor, class constructor, or promoted data constructor + TcCls after renamer: type constructor or class constructor + In a kind: + Var, Data: not allowed + Tv: kind variable + TcCls: kind constructor or promoted type constructor + + The 'Promoted' field in an HsTyVar captures whether the type was promoted in + the source code by prefixing an apostrophe. + +Note [HsStarTy] +~~~~~~~~~~~~~~~ +When the StarIsType extension is enabled, we want to treat '*' and its Unicode +variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser +would mean that when we pretty-print it back, we don't know whether the user +wrote '*' or 'Type', and lose the parse/ppr roundtrip property. + +As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') +and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). +When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not +involved. + + +Note [Promoted lists and tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice the difference between + HsListTy HsExplicitListTy + HsTupleTy HsExplicitListTupleTy + +E.g. f :: [Int] HsListTy + + g3 :: T '[] All these use + g2 :: T '[True] HsExplicitListTy + g1 :: T '[True,False] + g1a :: T [True,False] (can omit ' where unambiguous) + + kind of T :: [Bool] -> * This kind uses HsListTy! + +E.g. h :: (Int,Bool) HsTupleTy; f is a pair + k :: S '(True,False) HsExplicitTypleTy; S is indexed by + a type-level pair of booleans + kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy + +Note [Distinguishing tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Apart from promotion, tuples can have one of three different kinds: + + x :: (Int, Bool) -- Regular boxed tuples + f :: Int# -> (# Int#, Int# #) -- Unboxed tuples + g :: (Eq a, Ord a) => a -- Constraint tuples + +For convenience, internally we use a single constructor for all of these, +namely HsTupleTy, but keep track of the tuple kind (in the first argument to +HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, +because of the #. However, with -XConstraintKinds we can only distinguish +between constraint and boxed tuples during type checking, in general. Hence the +four constructors of HsTupleSort: + + HsUnboxedTuple -> Produced by the parser + HsBoxedTuple -> Certainly a boxed tuple + HsConstraintTuple -> Certainly a constraint tuple + HsBoxedOrConstraintTuple -> Could be a boxed or a constraint + tuple. Produced by the parser only, + disappears after type checking +-} + +-- | Haskell Tuple Sort +data HsTupleSort = HsUnboxedTuple + | HsBoxedTuple + | HsConstraintTuple + | HsBoxedOrConstraintTuple + deriving Data + +-- | Located Constructor Declaration Field +type LConDeclField pass = Located (ConDeclField pass) + -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + +-- | Constructor Declaration Field +data ConDeclField pass -- Record fields have Haddock docs on them + = ConDeclField { cd_fld_ext :: XConDeclField pass, + cd_fld_names :: [LFieldOcc pass], + -- ^ See Note [ConDeclField passs] + cd_fld_type :: LBangType pass, + cd_fld_doc :: Maybe LHsDocString } + -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' + + -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XConDeclField !(XXConDeclField pass) + +type instance XConDeclField (GhcPass _) = NoExtField +type instance XXConDeclField (GhcPass _) = NoExtCon + +instance OutputableBndrId p + => Outputable (ConDeclField (GhcPass p)) where + ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty + +-- HsConDetails is used for patterns/expressions *and* for data type +-- declarations +-- | Haskell Constructor Details +data HsConDetails arg rec + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon rec -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + deriving Data + +instance (Outputable arg, Outputable rec) + => Outputable (HsConDetails arg rec) where + ppr (PrefixCon args) = text "PrefixCon" <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + +hsConDetailsArgs :: + HsConDetails (LHsType a) (Located [LConDeclField a]) + -> [LHsType a] +hsConDetailsArgs details = case details of + InfixCon a b -> [a,b] + PrefixCon xs -> xs + RecCon r -> map (cd_fld_type . unLoc) (unLoc r) + +{- +Note [ConDeclField passs] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +A ConDeclField contains a list of field occurrences: these always +include the field label as the user wrote it. After the renamer, it +will additionally contain the identity of the selector function in the +second component. + +Due to DuplicateRecordFields, the OccName of the selector function +may have been mangled, which is why we keep the original field label +separately. For example, when DuplicateRecordFields is enabled + + data T = MkT { x :: Int } + +gives + + ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. +-} + +----------------------- +-- A valid type must have a for-all at the top of the type, or of the fn arg +-- types + +--------------------- +hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] +-- Get the lexically-scoped type variables of a HsSigType +-- - the explicitly-given forall'd type variables +-- - the named wildcards; see Note [Scoping of named wildcards] +-- because they scope in the same way +hsWcScopedTvs sig_ty + | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty + , HsIB { hsib_ext = vars + , hsib_body = sig_ty2 } <- sig_ty1 + = case sig_ty2 of + L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}) -> + -- See Note [hsScopedTvs vis_flag] + vars ++ nwcs ++ hsLTyVarNames tvs + _ -> nwcs + +hsScopedTvs :: LHsSigType GhcRn -> [Name] +-- Same as hsWcScopedTvs, but for a LHsSigType +hsScopedTvs sig_ty + | HsIB { hsib_ext = vars + , hsib_body = sig_ty2 } <- sig_ty + , L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}) + <- sig_ty2 -- See Note [hsScopedTvs vis_flag] + = vars ++ hsLTyVarNames tvs + | otherwise + = [] + +{- Note [Scoping of named wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: _a -> _a + f x = let g :: _a -> _a + g = ... + in ... + +Currently, for better or worse, the "_a" variables are all the same. So +although there is no explicit forall, the "_a" scopes over the definition. +I don't know if this is a good idea, but there it is. +-} + +{- Note [hsScopedTvs vis_flag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-XScopedTypeVariables can be defined in terms of a desugaring to +-XTypeAbstractions (GHC Proposal #50): + + fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) + fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) + +That is, for every type variable of the leading 'forall' in the type signature, +we add an invisible binder at term level. + +This model does not extend to visible forall, as discussed here: + +* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412 +* https://github.com/ghc-proposals/ghc-proposals/pull/238 + +The conclusion of these discussions can be summarized as follows: + + > Assuming support for visible 'forall' in terms, consider this example: + > + > vfn :: forall x y -> tau(x,y) + > vfn = \a b -> ... + > + > The user has written their own binders 'a' and 'b' to stand for 'x' and + > 'y', and we definitely should not desugar this into: + > + > vfn :: forall x y -> tau(x,y) + > vfn x y = \a b -> ... -- bad! + +We cement this design by pattern-matching on HsForAllInvis in hsScopedTvs: + + hsScopedTvs (HsForAllTy { hst_tele = HsForAllInvis { hst_bndrs = ... } + , ... }) = ... + +At the moment, GHC does not support visible 'forall' in terms. Nevertheless, +it is still possible to write erroneous programs that use visible 'forall's in +terms, such as this example: + + x :: forall a -> a -> a + x = x + +If we do not pattern-match on HsForAllInvis in hsScopedTvs, then `a` would +erroneously be brought into scope over the body of `x` when renaming it. +Although the typechecker would later reject this (see `GHC.Tc.Validity.vdqAllowed`), +it is still possible for this to wreak havoc in the renamer before it gets to +that point (see #17687 for an example of this). +Bottom line: nip problems in the bud by matching on HsForAllInvis from the start. +-} + +--------------------- +hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) +hsTyVarName (UserTyVar _ _ (L _ n)) = n +hsTyVarName (KindedTyVar _ _ (L _ n) _) = n + +hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) +hsLTyVarName = hsTyVarName . unLoc + +hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] +hsLTyVarNames = map hsLTyVarName + +hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] +-- Explicit variables only +hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) + +hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] +-- All variables +hsAllLTyVarNames (HsQTvs { hsq_ext = kvs + , hsq_explicit = tvs }) + = kvs ++ hsLTyVarNames tvs + +hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p)) +hsLTyVarLocName = mapLoc hsTyVarName + +hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) + +-- | Get the kind signature of a type, ignoring parentheses: +-- +-- hsTyKindSig `Maybe ` = Nothing +-- hsTyKindSig `Maybe :: Type -> Type ` = Just `Type -> Type` +-- hsTyKindSig `Maybe :: ((Type -> Type))` = Just `Type -> Type` +-- +-- This is used to extract the result kind of type synonyms with a CUSK: +-- +-- type S = (F :: res_kind) +-- ^^^^^^^^ +-- +hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass) +hsTyKindSig lty = + case unLoc lty of + HsParTy _ lty' -> hsTyKindSig lty' + HsKindSig _ _ k -> Just k + _ -> Nothing + +--------------------- +ignoreParens :: LHsType pass -> LHsType pass +ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty +ignoreParens ty = ty + +isLHsForAllTy :: LHsType p -> Bool +isLHsForAllTy (L _ (HsForAllTy {})) = True +isLHsForAllTy _ = False + +{- +************************************************************************ +* * + Building types +* * +************************************************************************ +-} + +mkAnonWildCardTy :: HsType GhcPs +mkAnonWildCardTy = HsWildCardTy noExtField + +mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) + -> LHsType (GhcPass p) -> HsType (GhcPass p) +mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 + +mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppTy t1 t2 + = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) + +mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] + -> LHsType (GhcPass p) +mkHsAppTys = foldl' mkHsAppTy + +mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) + -> LHsType (GhcPass p) +mkHsAppKindTy ext ty k + = addCLoc ty k (HsAppKindTy ext ty k) + +{- +************************************************************************ +* * + Decomposing HsTypes +* * +************************************************************************ +-} + +--------------------------------- +-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) +-- Breaks up any parens in the result type: +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) +-- It returns API Annotations for any parens removed +splitHsFunType :: + LHsType (GhcPass p) + -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn]) +splitHsFunType ty = go ty [] + where + go (L l (HsParTy _ ty)) anns + = go ty (anns ++ mkParensApiAnn l) + + go (L _ (HsFunTy _ mult x y)) anns + | (args, res, anns') <- go y anns + = (HsScaled mult x:args, res, anns') + + go other anns = ([], other, anns) + +-- | Retrieve the name of the \"head\" of a nested type application. +-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more +-- thorough. The purpose of this function is to examine instance heads, so it +-- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.). +hsTyGetAppHead_maybe :: LHsType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p))) +hsTyGetAppHead_maybe = go + where + go (L _ (HsTyVar _ _ ln)) = Just ln + go (L _ (HsAppTy _ l _)) = go l + go (L _ (HsAppKindTy _ t _)) = go t + go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) + go (L _ (HsParTy _ t)) = go t + go (L _ (HsKindSig _ t _)) = go t + go _ = Nothing + +------------------------------------------------------------ +-- Arguments in an expression/type after splitting +data HsArg tm ty + = HsValArg tm -- Argument is an ordinary expression (f arg) + | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) + -- SrcSpan is location of the `@` + | HsArgPar SrcSpan -- See Note [HsArgPar] + +numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _) = True + is_vis _ = False + +-- type level equivalent +type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) + +-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'. +lhsTypeArgSrcSpan :: LHsTypeArg pass -> SrcSpan +lhsTypeArgSrcSpan arg = case arg of + HsValArg tm -> getLoc tm + HsTypeArg at ty -> at `combineSrcSpans` getLoc ty + HsArgPar sp -> sp + +instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where + ppr (HsValArg tm) = ppr tm + ppr (HsTypeArg _ ty) = char '@' <> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp +{- +Note [HsArgPar] +A HsArgPar indicates that everything to the left of this in the argument list is +enclosed in parentheses together with the function itself. It is necessary so +that we can recreate the parenthesis structure in the original source after +typechecking the arguments. + +The SrcSpan is the span of the original HsPar + +((f arg1) arg2 arg3) results in an input argument list of +[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] + +-} + +-------------------------------- + +-- | Decompose a pattern synonym type signature into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsPatSynTy :: LHsType pass + -> ( [LHsTyVarBndr Specificity pass] -- universals + , LHsContext pass -- required constraints + , [LHsTyVarBndr Specificity pass] -- existentials + , LHsContext pass -- provided constraints + , LHsType pass) -- body type +splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) + where + (univs, ty1) = splitLHsForAllTyInvis ty + (reqs, ty2) = splitLHsQualTy ty1 + (exis, ty3) = splitLHsForAllTyInvis ty2 + (provs, ty4) = splitLHsQualTy ty3 + +-- | Decompose a sigma type (of the form @forall . context => body@) +-- into its constituent parts. +-- Only splits type variable binders that were +-- quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsSigmaTyInvis :: LHsType pass + -> ([LHsTyVarBndr Specificity pass], LHsContext pass, LHsType pass) +splitLHsSigmaTyInvis ty + | (tvs, ty1) <- splitLHsForAllTyInvis ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +-- | Decompose a sigma type (of the form @forall . context => body@) +-- into its constituent parts. +-- Only splits type variable binders that were +-- quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Unlike 'splitLHsSigmaTyInvis', this function does not look through +-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). +splitLHsSigmaTyInvis_KP :: + LHsType pass + -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass) +splitLHsSigmaTyInvis_KP ty + | (mb_tvbs, ty1) <- splitLHsForAllTyInvis_KP ty + , (mb_ctxt, ty2) <- splitLHsQualTy_KP ty1 + = (mb_tvbs, mb_ctxt, ty2) + +-- | Decompose a GADT type into its constituent parts. +-- Returns @(mb_tvbs, mb_ctxt, body)@, where: +-- +-- * @mb_tvbs@ are @Just@ the leading @forall@s, if they are provided. +-- Otherwise, they are @Nothing@. +-- +-- * @mb_ctxt@ is @Just@ the context, if it is provided. +-- Otherwise, it is @Nothing@. +-- +-- * @body@ is the body of the type after the optional @forall@s and context. +-- +-- This function is careful not to look through parentheses. +-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@ +-- "GHC.Hs.Decls" for why this is important. +splitLHsGadtTy :: + LHsType pass + -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass) +splitLHsGadtTy = splitLHsSigmaTyInvis_KP + +-- | Decompose a type of the form @forall . body@ into its constituent +-- parts. Only splits type variable binders that +-- were quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +-- Unlike 'splitLHsSigmaTyInvis', this function does not look through +-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). +splitLHsForAllTyInvis :: + LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsType pass) +splitLHsForAllTyInvis ty + | (mb_tvbs, body) <- splitLHsForAllTyInvis_KP (ignoreParens ty) + = (fromMaybe [] mb_tvbs, body) + +-- | Decompose a type of the form @forall . body@ into its constituent +-- parts. Only splits type variable binders that +-- were quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Unlike 'splitLHsForAllTyInvis', this function does not look through +-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). +splitLHsForAllTyInvis_KP :: + LHsType pass -> (Maybe [LHsTyVarBndr Specificity pass], LHsType pass) +splitLHsForAllTyInvis_KP lty@(L _ ty) = + case ty of + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs } + , hst_body = body } + -> (Just tvs, body) + _ -> (Nothing, lty) + +-- | Decompose a type of the form @context => body@ into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(context => <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) +splitLHsQualTy ty + | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty) + = (fromMaybe noLHsContext mb_ctxt, body) + +-- | Decompose a type of the form @context => body@ into its constituent parts. +-- +-- Unlike 'splitLHsQualTy', this function does not look through +-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). +splitLHsQualTy_KP :: LHsType pass -> (Maybe (LHsContext pass), LHsType pass) +splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) + = (Just ctxt, body) +splitLHsQualTy_KP body = (Nothing, body) + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into its constituent parts. +-- Note that the @[Name]@s returned correspond to either: +-- +-- * The implicitly bound type variables (if the type lacks an outermost +-- @forall@), or +-- +-- * The explicitly bound type variables (if the type has an outermost +-- @forall@). +-- +-- This function is careful not to look through parentheses. +-- See @Note [No nested foralls or contexts in instance types]@ +-- for why this is important. +splitLHsInstDeclTy :: LHsSigType GhcRn + -> ([Name], LHsContext GhcRn, LHsType GhcRn) +splitLHsInstDeclTy (HsIB { hsib_ext = itkvs + , hsib_body = inst_ty }) + | (mb_tvs, mb_cxt, body_ty) <- splitLHsSigmaTyInvis_KP inst_ty + = (itkvs ++ maybe [] hsLTyVarNames mb_tvs, fromMaybe noLHsContext mb_cxt, body_ty) + -- Because of the forall-or-nothing rule (see Note [forall-or-nothing rule] + -- in GHC.Rename.HsType), at least one of itkvs (the implicitly bound type + -- variables) or mb_tvs (the explicitly bound type variables) will be + -- empty. Still, if ScopedTypeVariables is enabled, we must bring one or + -- the other into scope over the bodies of the instance methods, so we + -- simply combine them into a single list. + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into the @instance_head@. +getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) +getLHsInstDeclHead (HsIB { hsib_body = inst_ty }) + | (_mb_tvs, _mb_cxt, body_ty) <- splitLHsSigmaTyInvis_KP inst_ty + = body_ty + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into the @instance_head@ and +-- retrieve the underlying class type constructor (if it exists). +getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p))) +-- Works on (LHsSigType GhcPs) +getLHsInstDeclClass_maybe inst_ty + = do { let head_ty = getLHsInstDeclHead inst_ty + ; cls <- hsTyGetAppHead_maybe head_ty + ; return cls } + +{- +Note [No nested foralls or contexts in instance types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type at the top of an instance declaration is one of the few places in GHC +where nested `forall`s or contexts are not permitted, even with RankNTypes +enabled. For example, the following will be rejected: + + instance forall a. forall b. Show (Either a b) where ... + instance Eq a => Eq b => Show (Either a b) where ... + instance (forall a. Show (Maybe a)) where ... + instance (Eq a => Show (Maybe a)) where ... + +This restriction is partly motivated by an unusual quirk of instance +declarations. Namely, if ScopedTypeVariables is enabled, then the type +variables from the top of an instance will scope over the bodies of the +instance methods, /even if the type variables are implicitly quantified/. +For example, GHC will accept the following: + + instance Monoid a => Monoid (Identity a) where + mempty = Identity (mempty @a) + +Moreover, the type in the top of an instance declaration must obey the +forall-or-nothing rule (see Note [forall-or-nothing rule] in +GHC.Rename.HsType). If instance types allowed nested `forall`s, this could +result in some strange interactions. For example, consider the following: + + class C a where + m :: Proxy a + instance (forall a. C (Either a b)) where + m = Proxy @(Either a b) + +Somewhat surprisingly, old versions of GHC would accept the instance above. +Even though the `forall` only quantifies `a`, the outermost parentheses mean +that the `forall` is nested, and per the forall-or-nothing rule, this means +that implicit quantification would occur. Therefore, the `a` is explicitly +bound and the `b` is implicitly bound. Moreover, ScopedTypeVariables would +bring /both/ sorts of type variables into scope over the body of `m`. +How utterly confusing! + +To avoid this sort of confusion, we simply disallow nested `forall`s in +instance types, which makes things like the instance above become illegal. +For the sake of consistency, we also disallow nested contexts, even though they +don't have the same strange interaction with ScopedTypeVariables. + +Just as we forbid nested `forall`s and contexts in normal instance +declarations, we also forbid them in SPECIALISE instance pragmas (#18455). +Unlike normal instance declarations, ScopedTypeVariables don't have any impact +on SPECIALISE instance pragmas, but we use the same validity checks for +SPECIALISE instance pragmas anyway to be consistent. + +----- +-- Wrinkle: Derived instances +----- + +`deriving` clauses and standalone `deriving` declarations also permit bringing +type variables into scope, either through explicit or implicit quantification. +Unlike in the tops of instance declarations, however, one does not need to +enable ScopedTypeVariables for this to take effect. + +Just as GHC forbids nested `forall`s in the top of instance declarations, it +also forbids them in types involved with `deriving`: + +1. In the `via` types in DerivingVia. For example, this is rejected: + + deriving via (forall x. V x) instance C (S x) + + Just like the types in instance declarations, `via` types can also bring + both implicitly and explicitly bound type variables into scope. As a result, + we adopt the same no-nested-`forall`s rule in `via` types to avoid confusing + behavior like in the example below: + + deriving via (forall x. T x y) instance W x y (Foo a b) + -- Both x and y are brought into scope??? +2. In the classes in `deriving` clauses. For example, this is rejected: + + data T = MkT deriving (C1, (forall x. C2 x y)) + + This is because the generated instance would look like: + + instance forall x y. C2 x y T where ... + + So really, the same concerns as instance declarations apply here as well. +-} + +{- +************************************************************************ +* * + FieldOcc +* * +************************************************************************ +-} + +-- | Located Field Occurrence +type LFieldOcc pass = Located (FieldOcc pass) + +-- | Field Occurrence +-- +-- Represents an *occurrence* of an unambiguous field. We store +-- both the 'RdrName' the user originally wrote, and after the +-- renamer, the selector function. +data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass + , rdrNameFieldOcc :: Located RdrName + -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr" + } + + | XFieldOcc + !(XXFieldOcc pass) +deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p)) + +type instance XCFieldOcc GhcPs = NoExtField +type instance XCFieldOcc GhcRn = Name +type instance XCFieldOcc GhcTc = Id + +type instance XXFieldOcc (GhcPass _) = NoExtCon + +instance Outputable (FieldOcc pass) where + ppr = ppr . rdrNameFieldOcc + +mkFieldOcc :: Located RdrName -> FieldOcc GhcPs +mkFieldOcc rdr = FieldOcc noExtField rdr + + +-- | Ambiguous Field Occurrence +-- +-- Represents an *occurrence* of a field that is potentially +-- ambiguous after the renamer, with the ambiguity resolved by the +-- typechecker. We always store the 'RdrName' that the user +-- originally wrote, and store the selector function after the renamer +-- (for unambiguous occurrences) or the typechecker (for ambiguous +-- occurrences). +-- +-- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat" and +-- Note [Disambiguating record fields] in "GHC.Tc.Gen.Expr". +-- See Note [Located RdrNames] in "GHC.Hs.Expr" +data AmbiguousFieldOcc pass + = Unambiguous (XUnambiguous pass) (Located RdrName) + | Ambiguous (XAmbiguous pass) (Located RdrName) + | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass) + +type instance XUnambiguous GhcPs = NoExtField +type instance XUnambiguous GhcRn = Name +type instance XUnambiguous GhcTc = Id + +type instance XAmbiguous GhcPs = NoExtField +type instance XAmbiguous GhcRn = NoExtField +type instance XAmbiguous GhcTc = Id + +type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon + +instance Outputable (AmbiguousFieldOcc (GhcPass p)) where + ppr = ppr . rdrNameAmbiguousFieldOcc + +instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where + pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc + pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc + +mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs +mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr + +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName +rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr +rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr + +selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id +selectorAmbiguousFieldOcc (Unambiguous sel _) = sel +selectorAmbiguousFieldOcc (Ambiguous sel _) = sel + +unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc +unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel +unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel + +ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc +ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +class OutputableBndrFlag flag where + pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc + +instance OutputableBndrFlag () where + pprTyVarBndr (UserTyVar _ _ n) = ppr n + pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k] + +instance OutputableBndrFlag Specificity where + pprTyVarBndr (UserTyVar _ SpecifiedSpec n) = ppr n + pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr n + pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k] + pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k] + +instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where + ppr ty = pprHsType ty + +instance Outputable HsTyLit where + ppr = ppr_tylit + +instance OutputableBndrId p + => Outputable (LHsQTyVars (GhcPass p)) where + ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs + +instance OutputableBndrId p + => Outputable (HsForAllTelescope (GhcPass p)) where + ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) = + text "HsForAllVis:" <+> ppr bndrs + ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) = + text "HsForAllInvis:" <+> ppr bndrs + +instance (OutputableBndrId p, OutputableBndrFlag flag) + => Outputable (HsTyVarBndr flag (GhcPass p)) where + ppr = pprTyVarBndr + +instance Outputable thing + => Outputable (HsImplicitBndrs (GhcPass p) thing) where + ppr (HsIB { hsib_body = ty }) = ppr ty + +instance Outputable thing + => Outputable (HsWildCardBndrs (GhcPass p) thing) where + ppr (HsWC { hswc_body = ty }) = ppr ty + +instance OutputableBndrId p + => Outputable (HsPatSigType (GhcPass p)) where + ppr (HsPS { hsps_body = ty }) = ppr ty + +pprAnonWildCard :: SDoc +pprAnonWildCard = char '_' + +-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ +-- only when @-dppr-debug@ is enabled. +pprHsForAll :: forall p. OutputableBndrId p + => HsForAllTelescope (GhcPass p) + -> LHsContext (GhcPass p) -> SDoc +pprHsForAll tele cxt + = pp_tele tele <+> pprLHsContext cxt + where + pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc + pp_tele tele = case tele of + HsForAllVis { hsf_vis_bndrs = qtvs } -> pp_forall (space <> arrow) qtvs + HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs + + pp_forall :: forall flag. OutputableBndrFlag flag => + SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc + pp_forall separator qtvs + | null qtvs = whenPprDebug (forAllLit <> separator) + | otherwise = forAllLit <+> interppSP qtvs <> separator + +-- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print +-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' +pprHsExplicitForAll :: (OutputableBndrId p) + => Maybe [LHsTyVarBndr () (GhcPass p)] -> SDoc +pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot +pprHsExplicitForAll Nothing = empty + +pprLHsContext :: (OutputableBndrId p) + => LHsContext (GhcPass p) -> SDoc +pprLHsContext lctxt + | null (unLoc lctxt) = empty + | otherwise = pprLHsContextAlways lctxt + +-- For use in a HsQualTy, which always gets printed if it exists. +pprLHsContextAlways :: (OutputableBndrId p) + => LHsContext (GhcPass p) -> SDoc +pprLHsContextAlways (L _ ctxt) + = case ctxt of + [] -> parens empty <+> darrow + [L _ ty] -> ppr_mono_ty ty <+> darrow + _ -> parens (interpp'SP ctxt) <+> darrow + +pprConDeclFields :: (OutputableBndrId p) + => [LConDeclField (GhcPass p)] -> SDoc +pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) + where + ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, + cd_fld_doc = doc })) + = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + ppr_fld (L _ (XConDeclField x)) = ppr x + ppr_names [n] = ppr n + ppr_names ns = sep (punctuate comma (map ppr ns)) + +{- +Note [Printing KindedTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#3830 reminded me that we should really only print the kind +signature on a KindedTyVar if the kind signature was put there by the +programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, +rather than converting to KindedTyVars as before. + +(As it happens, the message in #3830 comes out a different way now, +and the problem doesn't show up; but having the flag on a KindedTyVar +seems like the Right Thing anyway.) +-} + +-- Printing works more-or-less as for Types + +pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +pprHsType ty = ppr_mono_ty ty + +ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc +ppr_mono_lty ty = ppr_mono_ty (unLoc ty) + +ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty }) + = sep [pprHsForAll tele noLHsContext, ppr_mono_lty ty] + +ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) + = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] + +ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty +ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds +ppr_mono_ty (HsTyVar _ prom (L _ name)) + | isPromoted prom = quote (pprPrefixOcc name) + | otherwise = pprPrefixOcc name +ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2 +ppr_mono_ty (HsTupleTy _ con tys) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Solo x`, not `(x)` + | [ty] <- tys + , BoxedTuple <- std_con + = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] + | otherwise + = tupleParens std_con (pprWithCommas ppr tys) + where std_con = case con of + HsUnboxedTuple -> UnboxedTuple + _ -> BoxedTuple +ppr_mono_ty (HsSumTy _ tys) + = tupleParens UnboxedTuple (pprWithBars ppr tys) +ppr_mono_ty (HsKindSig _ ty kind) + = ppr_mono_lty ty <+> dcolon <+> ppr kind +ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) +ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) +ppr_mono_ty (HsSpliceTy _ s) = pprSplice s +ppr_mono_ty (HsExplicitListTy _ prom tys) + | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) + | otherwise = brackets (interpp'SP tys) +ppr_mono_ty (HsExplicitTupleTy _ tys) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `'Solo x`, not `'(x)` + | [ty] <- tys + = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] + | otherwise + = quote $ parens (maybeAddSpace tys $ interpp'SP tys) +ppr_mono_ty (HsTyLit _ t) = ppr_tylit t +ppr_mono_ty (HsWildCardTy {}) = char '_' + +ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) + = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] +ppr_mono_ty (HsAppKindTy _ ty k) + = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k +ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) + = sep [ ppr_mono_lty ty1 + , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] + +ppr_mono_ty (HsParTy _ ty) + = parens (ppr_mono_lty ty) + -- Put the parens in where the user did + -- But we still use the precedence stuff to add parens because + -- toHsType doesn't put in any HsParTys, so we may still need them + +ppr_mono_ty (HsDocTy _ ty doc) + -- AZ: Should we add parens? Should we introduce "-- ^"? + = ppr_mono_lty ty <+> ppr (unLoc doc) + -- we pretty print Haddock comments on types as if they were + -- postfix operators + +ppr_mono_ty (XHsType t) = ppr t + +-------------------------- +ppr_fun_ty :: (OutputableBndrId p) + => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc +ppr_fun_ty mult ty1 ty2 + = let p1 = ppr_mono_lty ty1 + p2 = ppr_mono_lty ty2 + arr = pprHsArrow mult + in + sep [p1, arr <+> p2] + +-------------------------- +ppr_tylit :: HsTyLit -> SDoc +ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) +ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) + + +-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses +-- under precedence @p@. +hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool +hsTypeNeedsParens p = go_hs_ty + where + go_hs_ty (HsForAllTy{}) = p >= funPrec + go_hs_ty (HsQualTy{}) = p >= funPrec + go_hs_ty (HsBangTy{}) = p > topPrec + go_hs_ty (HsRecTy{}) = False + go_hs_ty (HsTyVar{}) = False + go_hs_ty (HsFunTy{}) = p >= funPrec + go_hs_ty (HsTupleTy{}) = False + go_hs_ty (HsSumTy{}) = False + go_hs_ty (HsKindSig{}) = p >= sigPrec + go_hs_ty (HsListTy{}) = False + go_hs_ty (HsIParamTy{}) = p > topPrec + go_hs_ty (HsSpliceTy{}) = False + go_hs_ty (HsExplicitListTy{}) = False + go_hs_ty (HsExplicitTupleTy{}) = False + go_hs_ty (HsTyLit{}) = False + go_hs_ty (HsWildCardTy{}) = False + go_hs_ty (HsStarTy{}) = p >= starPrec + go_hs_ty (HsAppTy{}) = p >= appPrec + go_hs_ty (HsAppKindTy{}) = p >= appPrec + go_hs_ty (HsOpTy{}) = p >= opPrec + go_hs_ty (HsParTy{}) = False + go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t + go_hs_ty (XHsType (NHsCoreTy ty)) = go_core_ty ty + + go_core_ty (TyVarTy{}) = False + go_core_ty (AppTy{}) = p >= appPrec + go_core_ty (TyConApp _ args) + | null args = False + | otherwise = p >= appPrec + go_core_ty (ForAllTy{}) = p >= funPrec + go_core_ty (FunTy{}) = p >= funPrec + go_core_ty (LitTy{}) = False + go_core_ty (CastTy t _) = go_core_ty t + go_core_ty (CoercionTy{}) = False + +maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc +-- See Note [Printing promoted type constructors] +-- in GHC.Iface.Type. This code implements the same +-- logic for printing HsType +maybeAddSpace tys doc + | (ty : _) <- tys + , lhsTypeHasLeadingPromotionQuote ty = space <> doc + | otherwise = doc + +lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool +lhsTypeHasLeadingPromotionQuote ty + = goL ty + where + goL (L _ ty) = go ty + + go (HsForAllTy{}) = False + go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) + | L _ (c:_) <- ctxt = goL c + | otherwise = goL body + go (HsBangTy{}) = False + go (HsRecTy{}) = False + go (HsTyVar _ p _) = isPromoted p + go (HsFunTy _ _ arg _) = goL arg + go (HsListTy{}) = False + go (HsTupleTy{}) = False + go (HsSumTy{}) = False + go (HsOpTy _ t1 _ _) = goL t1 + go (HsKindSig _ t _) = goL t + go (HsIParamTy{}) = False + go (HsSpliceTy{}) = False + go (HsExplicitListTy _ p _) = isPromoted p + go (HsExplicitTupleTy{}) = True + go (HsTyLit{}) = False + go (HsWildCardTy{}) = False + go (HsStarTy{}) = False + go (HsAppTy _ t _) = goL t + go (HsAppKindTy _ t _) = goL t + go (HsParTy{}) = False + go (HsDocTy _ t _) = goL t + go (XHsType{}) = False + +-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is +-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply +-- returns @ty@. +parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) +parenthesizeHsType p lty@(L loc ty) + | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty) + | otherwise = lty + +-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint +-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ +-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply +-- returns @ctxt@ unchanged. +parenthesizeHsContext :: PprPrec + -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) +parenthesizeHsContext p lctxt@(L loc ctxt) = + case ctxt of + [c] -> L loc [parenthesizeHsType p c] + _ -> lctxt -- Other contexts are already "parenthesized" by virtue of + -- being tuples. diff --git a/GHC/Hs/Types.hs b/GHC/Hs/Types.hs deleted file mode 100644 --- a/GHC/Hs/Types.hs +++ /dev/null @@ -1,1739 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -GHC.Hs.Types: Abstract syntax: user-defined types --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module GHC.Hs.Types ( - HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, - HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..), - LHsQTyVars(..), - HsImplicitBndrs(..), - HsWildCardBndrs(..), - LHsSigType, LHsSigWcType, LHsWcType, - HsTupleSort(..), - HsContext, LHsContext, noLHsContext, - HsTyLit(..), - HsIPName(..), hsIPNameFS, - HsArg(..), numVisibleArgs, - LHsTypeArg, - - LBangType, BangType, - HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..), - getBangType, getBangStrictness, - - ConDeclField(..), LConDeclField, pprConDeclFields, - - HsConDetails(..), - - FieldOcc(..), LFieldOcc, mkFieldOcc, - AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, - rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, - unambiguousFieldOcc, ambiguousFieldOcc, - - mkAnonWildCardTy, pprAnonWildCard, - - mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, - mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, - mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, - isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, - hsScopedTvs, hsWcScopedTvs, dropWildCards, - hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, - splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, - splitLHsPatSynTy, - splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis, - splitHsFunType, hsTyGetAppHead_maybe, - mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, - ignoreParens, hsSigType, hsSigWcType, - hsLTyVarBndrToType, hsLTyVarBndrsToTypes, - hsTyKindSig, - hsConDetailsArgs, - - -- Printing - pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll, - pprLHsContext, - hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) - -import GHC.Hs.Extension - -import Id ( Id ) -import Name( Name, NamedThing(getName) ) -import RdrName ( RdrName ) -import DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) -import TysPrim( funTyConName ) -import TysWiredIn( mkTupleStr ) -import Type -import GHC.Hs.Doc -import BasicTypes -import SrcLoc -import Outputable -import FastString -import Maybes( isJust ) -import Util ( count, debugIsOn ) - -import Data.Data hiding ( Fixity, Prefix, Infix ) - -{- -************************************************************************ -* * -\subsection{Bang annotations} -* * -************************************************************************ --} - --- | Located Bang Type -type LBangType pass = Located (BangType pass) - --- | Bang Type --- --- In the parser, strictness and packedness annotations bind more tightly --- than docstrings. This means that when consuming a 'BangType' (and looking --- for 'HsBangTy') we must be ready to peer behind a potential layer of --- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example. -type BangType pass = HsType pass -- Bangs are in the HsType data type - -getBangType :: LHsType a -> LHsType a -getBangType (L _ (HsBangTy _ _ lty)) = lty -getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) = - addCLoc lty lds (HsDocTy x lty lds) -getBangType lty = lty - -getBangStrictness :: LHsType a -> HsSrcBang -getBangStrictness (L _ (HsBangTy _ s _)) = s -getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s -getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) - -{- -************************************************************************ -* * -\subsection{Data types} -* * -************************************************************************ - -This is the syntax for types as seen in type signatures. - -Note [HsBSig binder lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a binder (or pattern) decorated with a type or kind, - \ (x :: a -> a). blah - forall (a :: k -> *) (b :: k). blah -Then we use a LHsBndrSig on the binder, so that the -renamer can decorate it with the variables bound -by the pattern ('a' in the first example, 'k' in the second), -assuming that neither of them is in scope already -See also Note [Kind and type-variable binders] in RnTypes - -Note [HsType binders] -~~~~~~~~~~~~~~~~~~~~~ -The system for recording type and kind-variable binders in HsTypes -is a bit complicated. Here's how it works. - -* In a HsType, - HsForAllTy represents an /explicit, user-written/ 'forall' - e.g. forall a b. {...} or - forall a b -> {...} - HsQualTy represents an /explicit, user-written/ context - e.g. (Eq a, Show a) => ... - The context can be empty if that's what the user wrote - These constructors represent what the user wrote, no more - and no less. - -* The ForallVisFlag field of HsForAllTy represents whether a forall is - invisible (e.g., forall a b. {...}, with a dot) or visible - (e.g., forall a b -> {...}, with an arrow). - -* HsTyVarBndr describes a quantified type variable written by the - user. For example - f :: forall a (b :: *). blah - here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has - a list of LHsTyVarBndrs. - -* HsImplicitBndrs is a wrapper that gives the implicitly-quantified - kind and type variables of the wrapped thing. It is filled in by - the renamer. For example, if the user writes - f :: a -> a - the HsImplicitBinders binds the 'a' (not a HsForAllTy!). - NB: this implicit quantification is purely lexical: we bind any - type or kind variables that are not in scope. The type checker - may subsequently quantify over further kind variables. - -* HsWildCardBndrs is a wrapper that binds the wildcard variables - of the wrapped thing. It is filled in by the renamer - f :: _a -> _ - The enclosing HsWildCardBndrs binds the wildcards _a and _. - -* The explicit presence of these wrappers specifies, in the HsSyn, - exactly where implicit quantification is allowed, and where - wildcards are allowed. - -* LHsQTyVars is used in data/class declarations, where the user gives - explicit *type* variable bindings, but we need to implicitly bind - *kind* variables. For example - class C (a :: k -> *) where ... - The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars - -Note [The wildcard story for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Types can have wildcards in them, to support partial type signatures, -like f :: Int -> (_ , _a) -> _a - -A wildcard in a type can be - - * An anonymous wildcard, - written '_' - In HsType this is represented by HsWildCardTy. - The renamer leaves it untouched, and it is later given fresh meta tyvars in - the typechecker. - - * A named wildcard, - written '_a', '_foo', etc - In HsType this is represented by (HsTyVar "_a") - i.e. a perfectly ordinary type variable that happens - to start with an underscore - -Note carefully: - -* When NamedWildCards is off, type variables that start with an - underscore really /are/ ordinary type variables. And indeed, even - when NamedWildCards is on you can bind _a explicitly as an ordinary - type variable: - data T _a _b = MkT _b _a - Or even: - f :: forall _a. _a -> _b - Here _a is an ordinary forall'd binder, but (With NamedWildCards) - _b is a named wildcard. (See the comments in #10982) - -* Named wildcards are bound by the HsWildCardBndrs construct, which wraps - types that are allowed to have wildcards. Unnamed wildcards however are left - unchanged until typechecking, where we give them fresh wild tyavrs and - determine whether or not to emit hole constraints on each wildcard - (we don't if it's a visible type/kind argument or a type family pattern). - See related notes Note [Wildcards in visible kind application] - and Note [Wildcards in visible type application] in TcHsType.hs - -* After type checking is done, we report what types the wildcards - got unified with. - -Note [Ordering of implicit variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the advent of -XTypeApplications, GHC makes promises about the ordering -of implicit variable quantification. Specifically, we offer that implicitly -quantified variables (such as those in const :: a -> b -> a, without a `forall`) -will occur in left-to-right order of first occurrence. Here are a few examples: - - const :: a -> b -> a -- forall a b. ... - f :: Eq a => b -> a -> a -- forall a b. ... contexts are included - - type a <-< b = b -> a - g :: a <-< b -- forall a b. ... type synonyms matter - - class Functor f where - fmap :: (a -> b) -> f a -> f b -- forall f a b. ... - -- The f is quantified by the class, so only a and b are considered in fmap - -This simple story is complicated by the possibility of dependency: all variables -must come after any variables mentioned in their kinds. - - typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... - -The k comes first because a depends on k, even though the k appears later than -the a in the code. Thus, GHC does a *stable topological sort* on the variables. -By "stable", we mean that any two variables who do not depend on each other -preserve their existing left-to-right ordering. - -Implicitly bound variables are collected by the extract- family of functions -(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes. -These functions thus promise to keep left-to-right ordering. -Look for pointers to this note to see the places where the action happens. - -Note that we also maintain this ordering in kind signatures. Even though -there's no visible kind application (yet), having implicit variables be -quantified in left-to-right order in kind signatures is nice since: - -* It's consistent with the treatment for type signatures. -* It can affect how types are displayed with -fprint-explicit-kinds (see - #15568 for an example), which is a situation where knowing the order in - which implicit variables are quantified can be useful. -* In the event that visible kind application is implemented, the order in - which we would expect implicit variables to be ordered in kinds will have - already been established. --} - --- | Located Haskell Context -type LHsContext pass = Located (HsContext pass) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' - -- For details on above see note [Api annotations] in ApiAnnotation - -noLHsContext :: LHsContext pass --- Use this when there is no context in the original program --- It would really be more kosher to use a Maybe, to distinguish --- class () => C a where ... --- from --- class C a where ... -noLHsContext = noLoc [] - --- | Haskell Context -type HsContext pass = [LHsType pass] - --- | Located Haskell Type -type LHsType pass = Located (HsType pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Kind -type HsKind pass = HsType pass - --- | Located Haskell Kind -type LHsKind pass = Located (HsKind pass) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - --------------------------------------------------- --- LHsQTyVars --- The explicitly-quantified binders in a data/type declaration - --- | Located Haskell Type Variable Binder -type LHsTyVarBndr pass = Located (HsTyVarBndr pass) - -- See Note [HsType binders] - --- | Located Haskell Quantified Type Variables -data LHsQTyVars pass -- See Note [HsType binders] - = HsQTvs { hsq_ext :: XHsQTvs pass - - , hsq_explicit :: [LHsTyVarBndr pass] - -- Explicit variables, written by the user - -- See Note [HsForAllTy tyvar binders] - } - | XLHsQTyVars (XXLHsQTyVars pass) - -type HsQTvsRn = [Name] -- Implicit variables - -- For example, in data T (a :: k1 -> k2) = ... - -- the 'a' is explicit while 'k1', 'k2' are implicit - -type instance XHsQTvs GhcPs = NoExtField -type instance XHsQTvs GhcRn = HsQTvsRn -type instance XHsQTvs GhcTc = HsQTvsRn - -type instance XXLHsQTyVars (GhcPass _) = NoExtCon - -mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs -mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } - -hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] -hsQTvExplicit = hsq_explicit - -emptyLHsQTvs :: LHsQTyVars GhcRn -emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } - -isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool -isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp }) - = null imp && null exp -isEmptyLHsQTvs _ = False - ------------------------------------------------- --- HsImplicitBndrs --- Used to quantify the implicit binders of a type --- * Implicit binders of a type signature (LHsSigType/LHsSigWcType) --- * Patterns in a type/data family instance (HsTyPats) - --- | Haskell Implicit Binders -data HsImplicitBndrs pass thing -- See Note [HsType binders] - = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name] - -- Implicitly-bound kind & type vars - -- Order is important; see - -- Note [Ordering of implicit variables] - -- in RnTypes - - , hsib_body :: thing -- Main payload (type or list of types) - } - | XHsImplicitBndrs (XXHsImplicitBndrs pass thing) - -type instance XHsIB GhcPs _ = NoExtField -type instance XHsIB GhcRn _ = [Name] -type instance XHsIB GhcTc _ = [Name] - -type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon - --- | Haskell Wildcard Binders -data HsWildCardBndrs pass thing - -- See Note [HsType binders] - -- See Note [The wildcard story for types] - = HsWC { hswc_ext :: XHsWC pass thing - -- after the renamer - -- Wild cards, only named - -- See Note [Wildcards in visible kind application] - - , hswc_body :: thing - -- Main payload (type or list of types) - -- If there is an extra-constraints wildcard, - -- it's still there in the hsc_body. - } - | XHsWildCardBndrs (XXHsWildCardBndrs pass thing) - -type instance XHsWC GhcPs b = NoExtField -type instance XHsWC GhcRn b = [Name] -type instance XHsWC GhcTc b = [Name] - -type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon - --- | Located Haskell Signature Type -type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only - --- | Located Haskell Wildcard Type -type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only - --- | Located Haskell Signature Wildcard Type -type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both - --- See Note [Representing type signatures] - -hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing -hsImplicitBody (HsIB { hsib_body = body }) = body -hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec - -hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) -hsSigType = hsImplicitBody - -hsSigWcType :: LHsSigWcType pass -> LHsType pass -hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) - -dropWildCards :: LHsSigWcType pass -> LHsSigType pass --- Drop the wildcard part of a LHsSigWcType -dropWildCards sig_ty = hswc_body sig_ty - -{- Note [Representing type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsSigType is used to represent an explicit user type signature -such as f :: a -> a - or g (x :: a -> a) = x - -A HsSigType is just a HsImplicitBndrs wrapping a LHsType. - * The HsImplicitBndrs binds the /implicitly/ quantified tyvars - * The LHsType binds the /explicitly/ quantified tyvars - -E.g. For a signature like - f :: forall (a::k). blah -we get - HsIB { hsib_vars = [k] - , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] - , hst_body = blah } -The implicit kind variable 'k' is bound by the HsIB; -the explicitly forall'd tyvar 'a' is bound by the HsForAllTy --} - -mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing -mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField - , hsib_body = x } - -mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing -mkHsWildCardBndrs x = HsWC { hswc_body = x - , hswc_ext = noExtField } - --- Add empty binders. This is a bit suspicious; what if --- the wrapped thing had free type variables? -mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing -mkEmptyImplicitBndrs x = HsIB { hsib_ext = [] - , hsib_body = x } - -mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing -mkEmptyWildCardBndrs x = HsWC { hswc_body = x - , hswc_ext = [] } - - --------------------------------------------------- --- | These names are used early on to store the names of implicit --- parameters. They completely disappear after type-checking. -newtype HsIPName = HsIPName FastString - deriving( Eq, Data ) - -hsIPNameFS :: HsIPName -> FastString -hsIPNameFS (HsIPName n) = n - -instance Outputable HsIPName where - ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters - -instance OutputableBndr HsIPName where - pprBndr _ n = ppr n -- Simple for now - pprInfixOcc n = ppr n - pprPrefixOcc n = ppr n - --------------------------------------------------- - --- | Haskell Type Variable Binder -data HsTyVarBndr pass - = UserTyVar -- no explicit kinding - (XUserTyVar pass) - (Located (IdP pass)) - -- See Note [Located RdrNames] in GHC.Hs.Expr - | KindedTyVar - (XKindedTyVar pass) - (Located (IdP pass)) - (LHsKind pass) -- The user-supplied kind signature - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | XTyVarBndr - (XXTyVarBndr pass) - -type instance XUserTyVar (GhcPass _) = NoExtField -type instance XKindedTyVar (GhcPass _) = NoExtField - -type instance XXTyVarBndr (GhcPass _) = NoExtCon - --- | Does this 'HsTyVarBndr' come with an explicit kind annotation? -isHsKindedTyVar :: HsTyVarBndr pass -> Bool -isHsKindedTyVar (UserTyVar {}) = False -isHsKindedTyVar (KindedTyVar {}) = True -isHsKindedTyVar (XTyVarBndr {}) = False - --- | Do all type variables in this 'LHsQTyVars' come with kind annotations? -hsTvbAllKinded :: LHsQTyVars pass -> Bool -hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit - -instance NamedThing (HsTyVarBndr GhcRn) where - getName (UserTyVar _ v) = unLoc v - getName (KindedTyVar _ v _) = unLoc v - getName (XTyVarBndr nec) = noExtCon nec - --- | Haskell Type -data HsType pass - = HsForAllTy -- See Note [HsType binders] - { hst_xforall :: XForAllTy pass - , hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or - -- `forall a. {...}`? - , hst_bndrs :: [LHsTyVarBndr pass] - -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType pass -- body type - } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', - -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsQualTy -- See Note [HsType binders] - { hst_xqual :: XQualTy pass - , hst_ctxt :: LHsContext pass -- Context C => blah - , hst_body :: LHsType pass } - - | HsTyVar (XTyVar pass) - PromotionFlag -- Whether explicitly promoted, - -- for the pretty printer - (Located (IdP pass)) - -- Type variable, type constructor, or data constructor - -- see Note [Promotions (HsTyVar)] - -- See Note [Located RdrNames] in GHC.Hs.Expr - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsAppTy (XAppTy pass) - (LHsType pass) - (LHsType pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsAppKindTy (XAppKindTy pass) -- type level type app - (LHsType pass) - (LHsKind pass) - - | HsFunTy (XFunTy pass) - (LHsType pass) -- function type - (LHsType pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsListTy (XListTy pass) - (LHsType pass) -- Element type - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsTupleTy (XTupleTy pass) - HsTupleSort - [LHsType pass] -- Element types (length gives arity) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, - -- 'ApiAnnotation.AnnClose' @')' or '#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsSumTy (XSumTy pass) - [LHsType pass] -- Element types (length gives arity) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnClose' '#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsOpTy (XOpTy pass) - (LHsType pass) (Located (IdP pass)) (LHsType pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsParTy (XParTy pass) - (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr - -- Parenthesis preserved for the precedence re-arrangement in RnTypes - -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsIParamTy (XIParamTy pass) - (Located HsIPName) -- (?x :: ty) - (LHsType pass) -- Implicit parameters as they occur in - -- contexts - -- ^ - -- > (?x :: ty) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsStarTy (XStarTy pass) - Bool -- Is this the Unicode variant? - -- Note [HsStarTy] - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - | HsKindSig (XKindSig pass) - (LHsType pass) -- (ty :: kind) - (LHsKind pass) -- A type with a kind signature - -- ^ - -- > (ty :: kind) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsSpliceTy (XSpliceTy pass) - (HsSplice pass) -- Includes quasi-quotes - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsDocTy (XDocTy pass) - (LHsType pass) LHsDocString -- A documented type - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsBangTy (XBangTy pass) - HsSrcBang (LHsType pass) -- Bang-style type annotations - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, - -- 'ApiAnnotation.AnnClose' @'#-}'@ - -- 'ApiAnnotation.AnnBang' @\'!\'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsRecTy (XRecTy pass) - [LConDeclField pass] -- Only in data type declarations - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* - -- -- Core Type through HsSyn. - -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsExplicitListTy -- A promoted explicit list - (XExplicitListTy pass) - PromotionFlag -- whether explcitly promoted, for pretty printer - [LHsType pass] - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsExplicitTupleTy -- A promoted explicit tuple - (XExplicitTupleTy pass) - [LHsType pass] - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsWildCardTy (XWildCardTy pass) -- A type wildcard - -- See Note [The wildcard story for types] - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - -- For adding new constructors via Trees that Grow - | XHsType - (XXType pass) - -data NewHsTypeX - = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* - -- Core Type through HsSyn. - deriving Data - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - -instance Outputable NewHsTypeX where - ppr (NHsCoreTy ty) = ppr ty - -type instance XForAllTy (GhcPass _) = NoExtField -type instance XQualTy (GhcPass _) = NoExtField -type instance XTyVar (GhcPass _) = NoExtField -type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = NoExtField -type instance XListTy (GhcPass _) = NoExtField -type instance XTupleTy (GhcPass _) = NoExtField -type instance XSumTy (GhcPass _) = NoExtField -type instance XOpTy (GhcPass _) = NoExtField -type instance XParTy (GhcPass _) = NoExtField -type instance XIParamTy (GhcPass _) = NoExtField -type instance XStarTy (GhcPass _) = NoExtField -type instance XKindSig (GhcPass _) = NoExtField - -type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives - -type instance XSpliceTy GhcPs = NoExtField -type instance XSpliceTy GhcRn = NoExtField -type instance XSpliceTy GhcTc = Kind - -type instance XDocTy (GhcPass _) = NoExtField -type instance XBangTy (GhcPass _) = NoExtField -type instance XRecTy (GhcPass _) = NoExtField - -type instance XExplicitListTy GhcPs = NoExtField -type instance XExplicitListTy GhcRn = NoExtField -type instance XExplicitListTy GhcTc = Kind - -type instance XExplicitTupleTy GhcPs = NoExtField -type instance XExplicitTupleTy GhcRn = NoExtField -type instance XExplicitTupleTy GhcTc = [Kind] - -type instance XTyLit (GhcPass _) = NoExtField - -type instance XWildCardTy (GhcPass _) = NoExtField - -type instance XXType (GhcPass _) = NewHsTypeX - - --- Note [Literal source text] in BasicTypes for SourceText fields in --- the following --- | Haskell Type Literal -data HsTyLit - = HsNumTy SourceText Integer - | HsStrTy SourceText FastString - deriving Data - - -{- -Note [HsForAllTy tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After parsing: - * Implicit => empty - Explicit => the variables the user wrote - -After renaming - * Implicit => the *type* variables free in the type - Explicit => the variables the user wrote (renamed) - -Qualified currently behaves exactly as Implicit, -but it is deprecated to use it for implicit quantification. -In this case, GHC 7.10 gives a warning; see -Note [Context quantification] in RnTypes, and #4426. -In GHC 8.0, Qualified will no longer bind variables -and this will become an error. - -The kind variables bound in the hsq_implicit field come both - a) from the kind signatures on the kind vars (eg k1) - b) from the scope of the forall (eg k2) -Example: f :: forall (a::k1) b. T a (b::k2) - - -Note [Unit tuples] -~~~~~~~~~~~~~~~~~~ -Consider the type - type instance F Int = () -We want to parse that "()" - as HsTupleTy HsBoxedOrConstraintTuple [], -NOT as HsTyVar unitTyCon - -Why? Because F might have kind (* -> Constraint), so we when parsing we -don't know if that tuple is going to be a constraint tuple or an ordinary -unit tuple. The HsTupleSort flag is specifically designed to deal with -that, but it has to work for unit tuples too. - -Note [Promotions (HsTyVar)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsTyVar: A name in a type or kind. - Here are the allowed namespaces for the name. - In a type: - Var: not allowed - Data: promoted data constructor - Tv: type variable - TcCls before renamer: type constructor, class constructor, or promoted data constructor - TcCls after renamer: type constructor or class constructor - In a kind: - Var, Data: not allowed - Tv: kind variable - TcCls: kind constructor or promoted type constructor - - The 'Promoted' field in an HsTyVar captures whether the type was promoted in - the source code by prefixing an apostrophe. - -Note [HsStarTy] -~~~~~~~~~~~~~~~ -When the StarIsType extension is enabled, we want to treat '*' and its Unicode -variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser -would mean that when we pretty-print it back, we don't know whether the user -wrote '*' or 'Type', and lose the parse/ppr roundtrip property. - -As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') -and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). -When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not -involved. - - -Note [Promoted lists and tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice the difference between - HsListTy HsExplicitListTy - HsTupleTy HsExplicitListTupleTy - -E.g. f :: [Int] HsListTy - - g3 :: T '[] All these use - g2 :: T '[True] HsExplicitListTy - g1 :: T '[True,False] - g1a :: T [True,False] (can omit ' where unambiguous) - - kind of T :: [Bool] -> * This kind uses HsListTy! - -E.g. h :: (Int,Bool) HsTupleTy; f is a pair - k :: S '(True,False) HsExplicitTypleTy; S is indexed by - a type-level pair of booleans - kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy - -Note [Distinguishing tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Apart from promotion, tuples can have one of three different kinds: - - x :: (Int, Bool) -- Regular boxed tuples - f :: Int# -> (# Int#, Int# #) -- Unboxed tuples - g :: (Eq a, Ord a) => a -- Constraint tuples - -For convenience, internally we use a single constructor for all of these, -namely HsTupleTy, but keep track of the tuple kind (in the first argument to -HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, -because of the #. However, with -XConstraintKinds we can only distinguish -between constraint and boxed tuples during type checking, in general. Hence the -four constructors of HsTupleSort: - - HsUnboxedTuple -> Produced by the parser - HsBoxedTuple -> Certainly a boxed tuple - HsConstraintTuple -> Certainly a constraint tuple - HsBoxedOrConstraintTuple -> Could be a boxed or a constraint - tuple. Produced by the parser only, - disappears after type checking --} - --- | Haskell Tuple Sort -data HsTupleSort = HsUnboxedTuple - | HsBoxedTuple - | HsConstraintTuple - | HsBoxedOrConstraintTuple - deriving Data - --- | Located Constructor Declaration Field -type LConDeclField pass = Located (ConDeclField pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Constructor Declaration Field -data ConDeclField pass -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_ext :: XConDeclField pass, - cd_fld_names :: [LFieldOcc pass], - -- ^ See Note [ConDeclField passs] - cd_fld_type :: LBangType pass, - cd_fld_doc :: Maybe LHsDocString } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | XConDeclField (XXConDeclField pass) - -type instance XConDeclField (GhcPass _) = NoExtField -type instance XXConDeclField (GhcPass _) = NoExtCon - -instance OutputableBndrId p - => Outputable (ConDeclField (GhcPass p)) where - ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty - ppr (XConDeclField x) = ppr x - --- HsConDetails is used for patterns/expressions *and* for data type --- declarations --- | Haskell Constructor Details -data HsConDetails arg rec - = PrefixCon [arg] -- C p1 p2 p3 - | RecCon rec -- C { x = p1, y = p2 } - | InfixCon arg arg -- p1 `C` p2 - deriving Data - -instance (Outputable arg, Outputable rec) - => Outputable (HsConDetails arg rec) where - ppr (PrefixCon args) = text "PrefixCon" <+> ppr args - ppr (RecCon rec) = text "RecCon:" <+> ppr rec - ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] - -hsConDetailsArgs :: - HsConDetails (LHsType a) (Located [LConDeclField a]) - -> [LHsType a] -hsConDetailsArgs details = case details of - InfixCon a b -> [a,b] - PrefixCon xs -> xs - RecCon r -> map (cd_fld_type . unLoc) (unLoc r) - -{- -Note [ConDeclField passs] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -A ConDeclField contains a list of field occurrences: these always -include the field label as the user wrote it. After the renamer, it -will additionally contain the identity of the selector function in the -second component. - -Due to DuplicateRecordFields, the OccName of the selector function -may have been mangled, which is why we keep the original field label -separately. For example, when DuplicateRecordFields is enabled - - data T = MkT { x :: Int } - -gives - - ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. --} - ------------------------ --- A valid type must have a for-all at the top of the type, or of the fn arg --- types - ---------------------- -hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] --- Get the lexically-scoped type variables of a HsSigType --- - the explicitly-given forall'd type variables --- - the named wildcars; see Note [Scoping of named wildcards] --- because they scope in the same way -hsWcScopedTvs sig_ty - | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty - , HsIB { hsib_ext = vars - , hsib_body = sig_ty2 } <- sig_ty1 - = case sig_ty2 of - L _ (HsForAllTy { hst_fvf = vis_flag - , hst_bndrs = tvs }) -> - ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] - vars ++ nwcs ++ hsLTyVarNames tvs - _ -> nwcs -hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec - -hsScopedTvs :: LHsSigType GhcRn -> [Name] --- Same as hsWcScopedTvs, but for a LHsSigType -hsScopedTvs sig_ty - | HsIB { hsib_ext = vars - , hsib_body = sig_ty2 } <- sig_ty - , L _ (HsForAllTy { hst_fvf = vis_flag - , hst_bndrs = tvs }) <- sig_ty2 - = ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] - vars ++ hsLTyVarNames tvs - | otherwise - = [] - -{- Note [Scoping of named wildcards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: _a -> _a - f x = let g :: _a -> _a - g = ... - in ... - -Currently, for better or worse, the "_a" variables are all the same. So -although there is no explicit forall, the "_a" scopes over the definition. -I don't know if this is a good idea, but there it is. --} - -{- Note [hsScopedTvs vis_flag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --XScopedTypeVariables can be defined in terms of a desugaring to --XTypeAbstractions (GHC Proposal #50): - - fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) - fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) - -That is, for every type variable of the leading 'forall' in the type signature, -we add an invisible binder at term level. - -This model does not extend to visible forall, as discussed here: - -* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412 -* https://github.com/ghc-proposals/ghc-proposals/pull/238 - -The conclusion of these discussions can be summarized as follows: - - > Assuming support for visible 'forall' in terms, consider this example: - > - > vfn :: forall x y -> tau(x,y) - > vfn = \a b -> ... - > - > The user has written their own binders 'a' and 'b' to stand for 'x' and - > 'y', and we definitely should not desugar this into: - > - > vfn :: forall x y -> tau(x,y) - > vfn x y = \a b -> ... -- bad! - -At the moment, GHC does not support visible 'forall' in terms, so we simply cement -our assumptions with an assert: - - hsScopedTvs (HsForAllTy { hst_fvf = vis_flag, ... }) = - ASSERT( vis_flag == ForallInvis ) - ... - -In the future, this assert can be safely turned into a pattern match to support -visible forall in terms: - - hsScopedTvs (HsForAllTy { hst_fvf = ForallInvis, ... }) = ... --} - ---------------------- -hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p) -hsTyVarName (UserTyVar _ (L _ n)) = n -hsTyVarName (KindedTyVar _ (L _ n) _) = n -hsTyVarName (XTyVarBndr nec) = noExtCon nec - -hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p) -hsLTyVarName = hsTyVarName . unLoc - -hsLTyVarNames :: [LHsTyVarBndr (GhcPass p)] -> [IdP (GhcPass p)] -hsLTyVarNames = map hsLTyVarName - -hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] --- Explicit variables only -hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) - -hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] --- All variables -hsAllLTyVarNames (HsQTvs { hsq_ext = kvs - , hsq_explicit = tvs }) - = kvs ++ hsLTyVarNames tvs -hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec - -hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) -hsLTyVarLocName = onHasSrcSpan hsTyVarName - -hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] -hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) - --- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) -hsLTyVarBndrToType = onHasSrcSpan cvt - where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - cvt (KindedTyVar _ (L name_loc n) kind) - = HsKindSig noExtField - (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind - cvt (XTyVarBndr nec) = noExtCon nec - --- | Convert a LHsTyVarBndrs to a list of types. --- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] -hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs -hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec - --- | Get the kind signature of a type, ignoring parentheses: --- --- hsTyKindSig `Maybe ` = Nothing --- hsTyKindSig `Maybe :: Type -> Type ` = Just `Type -> Type` --- hsTyKindSig `Maybe :: ((Type -> Type))` = Just `Type -> Type` --- --- This is used to extract the result kind of type synonyms with a CUSK: --- --- type S = (F :: res_kind) --- ^^^^^^^^ --- -hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass) -hsTyKindSig lty = - case unLoc lty of - HsParTy _ lty' -> hsTyKindSig lty' - HsKindSig _ _ k -> Just k - _ -> Nothing - ---------------------- -ignoreParens :: LHsType pass -> LHsType pass -ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty -ignoreParens ty = ty - -isLHsForAllTy :: LHsType p -> Bool -isLHsForAllTy (L _ (HsForAllTy {})) = True -isLHsForAllTy _ = False - -{- -************************************************************************ -* * - Building types -* * -************************************************************************ --} - -mkAnonWildCardTy :: HsType GhcPs -mkAnonWildCardTy = HsWildCardTy noExtField - -mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) - -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 - -mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppTy t1 t2 - = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) - -mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] - -> LHsType (GhcPass p) -mkHsAppTys = foldl' mkHsAppTy - -mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) - -> LHsType (GhcPass p) -mkHsAppKindTy ext ty k - = addCLoc ty k (HsAppKindTy ext ty k) - -{- -************************************************************************ -* * - Decomposing HsTypes -* * -************************************************************************ --} - ---------------------------------- --- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) --- Breaks up any parens in the result type: --- splitHsFunType (a -> (b -> c)) = ([a,b], c) --- Also deals with (->) t1 t2; that is why it only works on LHsType Name --- (see #9096) -splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) -splitHsFunType (L _ (HsParTy _ ty)) - = splitHsFunType ty - -splitHsFunType (L _ (HsFunTy _ x y)) - | (args, res) <- splitHsFunType y - = (x:args, res) -{- This is not so correct, because it won't work with visible kind app, in case - someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing - ConDeclGADT abstract syntax -} -splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) - = go t1 [t2] - where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName - , [t1,t2] <- tys - , (args, res) <- splitHsFunType t2 - = (t1:args, res) - go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) - go (L _ (HsParTy _ ty)) tys = go ty tys - go _ _ = ([], orig_ty) -- Failure to match - -splitHsFunType other = ([], other) - --- retrieve the name of the "head" of a nested type application --- somewhat like splitHsAppTys, but a little more thorough --- used to examine the result of a GADT-like datacon, so it doesn't handle --- *all* cases (like lists, tuples, (~), etc.) -hsTyGetAppHead_maybe :: LHsType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) -hsTyGetAppHead_maybe = go - where - go (L _ (HsTyVar _ _ ln)) = Just ln - go (L _ (HsAppTy _ l _)) = go l - go (L _ (HsAppKindTy _ t _)) = go t - go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) - go (L _ (HsParTy _ t)) = go t - go (L _ (HsKindSig _ t _)) = go t - go _ = Nothing - ------------------------------------------------------------- --- Arguments in an expression/type after splitting -data HsArg tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) - -- SrcSpan is location of the `@` - | HsArgPar SrcSpan -- See Note [HsArgPar] - -numVisibleArgs :: [HsArg tm ty] -> Arity -numVisibleArgs = count is_vis - where is_vis (HsValArg _) = True - is_vis _ = False - --- type level equivalent -type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) - -instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where - ppr (HsValArg tm) = ppr tm - ppr (HsTypeArg _ ty) = char '@' <> ppr ty - ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp -{- -Note [HsArgPar] -A HsArgPar indicates that everything to the left of this in the argument list is -enclosed in parentheses together with the function itself. It is necessary so -that we can recreate the parenthesis structure in the original source after -typechecking the arguments. - -The SrcSpan is the span of the original HsPar - -((f arg1) arg2 arg3) results in an input argument list of -[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] - --} - --------------------------------- - --- | Decompose a pattern synonym type signature into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsPatSynTy :: LHsType pass - -> ( [LHsTyVarBndr pass] -- universals - , LHsContext pass -- required constraints - , [LHsTyVarBndr pass] -- existentials - , LHsContext pass -- provided constraints - , LHsType pass) -- body type -splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) - where - (univs, ty1) = splitLHsForAllTyInvis ty - (reqs, ty2) = splitLHsQualTy ty1 - (exis, ty3) = splitLHsForAllTyInvis ty2 - (provs, ty4) = splitLHsQualTy ty3 - --- | Decompose a sigma type (of the form @forall . context => body@) --- into its constituent parts. Note that only /invisible/ @forall@s --- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s --- (i.e., @forall a ->@, with an arrow) are left untouched. --- --- This function is used to split apart certain types, such as instance --- declaration types, which disallow visible @forall@s. For instance, if GHC --- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that --- declaration would mistakenly be accepted! --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsSigmaTyInvis :: LHsType pass - -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) -splitLHsSigmaTyInvis ty - | (tvs, ty1) <- splitLHsForAllTyInvis ty - , (ctxt, ty2) <- splitLHsQualTy ty1 - = (tvs, ctxt, ty2) - --- | Decompose a type of the form @forall . body@ into its constituent --- parts. Note that only /invisible/ @forall@s --- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s --- (i.e., @forall a ->@, with an arrow) are left untouched. --- --- This function is used to split apart certain types, such as instance --- declaration types, which disallow visible @forall@s. For instance, if GHC --- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that --- declaration would mistakenly be accepted! --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) -splitLHsForAllTyInvis lty@(L _ ty) = - case ty of - HsParTy _ ty' -> splitLHsForAllTyInvis ty' - HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' } - | fvf' == ForallInvis - -> (tvs', body') - _ -> ([], lty) - --- | Decompose a type of the form @context => body@ into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(context => <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) -splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty -splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) -splitLHsQualTy body = (noLHsContext, body) - --- | Decompose a type class instance type (of the form --- @forall . context => instance_head@) into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall . <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsInstDeclTy :: LHsSigType GhcRn - -> ([Name], LHsContext GhcRn, LHsType GhcRn) --- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy (HsIB { hsib_ext = itkvs - , hsib_body = inst_ty }) - | (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty - = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty) - -- Return implicitly bound type and kind vars - -- For an instance decl, all of them are in scope -splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec - -getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) -getLHsInstDeclHead inst_ty - | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty) - = body_ty - -getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) --- Works on (HsSigType RdrName) -getLHsInstDeclClass_maybe inst_ty - = do { let head_ty = getLHsInstDeclHead inst_ty - ; cls <- hsTyGetAppHead_maybe head_ty - ; return cls } - -{- -************************************************************************ -* * - FieldOcc -* * -************************************************************************ --} - --- | Located Field Occurrence -type LFieldOcc pass = Located (FieldOcc pass) - --- | Field Occurrence --- --- Represents an *occurrence* of an unambiguous field. We store --- both the 'RdrName' the user originally wrote, and after the --- renamer, the selector function. -data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass - , rdrNameFieldOcc :: Located RdrName - -- ^ See Note [Located RdrNames] in GHC.Hs.Expr - } - - | XFieldOcc - (XXFieldOcc pass) -deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p)) -deriving instance Ord (XCFieldOcc (GhcPass p)) => Ord (FieldOcc (GhcPass p)) - -type instance XCFieldOcc GhcPs = NoExtField -type instance XCFieldOcc GhcRn = Name -type instance XCFieldOcc GhcTc = Id - -type instance XXFieldOcc (GhcPass _) = NoExtCon - -instance Outputable (FieldOcc pass) where - ppr = ppr . rdrNameFieldOcc - -mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc noExtField rdr - - --- | Ambiguous Field Occurrence --- --- Represents an *occurrence* of a field that is potentially --- ambiguous after the renamer, with the ambiguity resolved by the --- typechecker. We always store the 'RdrName' that the user --- originally wrote, and store the selector function after the renamer --- (for unambiguous occurrences) or the typechecker (for ambiguous --- occurrences). --- --- See Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat and --- Note [Disambiguating record fields] in TcExpr. --- See Note [Located RdrNames] in GHC.Hs.Expr -data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (Located RdrName) - | Ambiguous (XAmbiguous pass) (Located RdrName) - | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) - -type instance XUnambiguous GhcPs = NoExtField -type instance XUnambiguous GhcRn = Name -type instance XUnambiguous GhcTc = Id - -type instance XAmbiguous GhcPs = NoExtField -type instance XAmbiguous GhcRn = NoExtField -type instance XAmbiguous GhcTc = Id - -type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon - -instance Outputable (AmbiguousFieldOcc (GhcPass p)) where - ppr = ppr . rdrNameAmbiguousFieldOcc - -instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where - pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc - pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc - -mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs -mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr - -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec) - = noExtCon nec - -selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id -selectorAmbiguousFieldOcc (Unambiguous sel _) = sel -selectorAmbiguousFieldOcc (Ambiguous sel _) = sel -selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec) - = noExtCon nec - -unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc -unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec - -ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc -ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr -ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection{Pretty printing} -* * -************************************************************************ --} - -instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where - ppr ty = pprHsType ty - -instance Outputable HsTyLit where - ppr = ppr_tylit - -instance OutputableBndrId p - => Outputable (LHsQTyVars (GhcPass p)) where - ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs - ppr (XLHsQTyVars x) = ppr x - -instance OutputableBndrId p - => Outputable (HsTyVarBndr (GhcPass p)) where - ppr (UserTyVar _ n) = ppr n - ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] - ppr (XTyVarBndr nec) = noExtCon nec - -instance Outputable thing - => Outputable (HsImplicitBndrs (GhcPass p) thing) where - ppr (HsIB { hsib_body = ty }) = ppr ty - ppr (XHsImplicitBndrs x) = ppr x - -instance Outputable thing - => Outputable (HsWildCardBndrs (GhcPass p) thing) where - ppr (HsWC { hswc_body = ty }) = ppr ty - ppr (XHsWildCardBndrs x) = ppr x - -pprAnonWildCard :: SDoc -pprAnonWildCard = char '_' - --- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ --- only when @-dppr-debug@ is enabled. -pprHsForAll :: (OutputableBndrId p) - => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] - -> LHsContext (GhcPass p) -> SDoc -pprHsForAll = pprHsForAllExtra Nothing - --- | Version of 'pprHsForAll' that can also print an extra-constraints --- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This --- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just' --- containing the location of the extra-constraints wildcard. A special --- function for this is needed, as the extra-constraints wildcard is removed --- from the actual context and type, and stored in a separate field, thus just --- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (OutputableBndrId p) - => Maybe SrcSpan -> ForallVisFlag - -> [LHsTyVarBndr (GhcPass p)] - -> LHsContext (GhcPass p) -> SDoc -pprHsForAllExtra extra fvf qtvs cxt - = pp_forall <+> pprLHsContextExtra (isJust extra) cxt - where - pp_forall | null qtvs = whenPprDebug (forAllLit <> separator) - | otherwise = forAllLit <+> interppSP qtvs <> separator - - separator = ppr_forall_separator fvf - --- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print --- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' -pprHsExplicitForAll :: (OutputableBndrId p) - => ForallVisFlag - -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc -pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs - <> ppr_forall_separator fvf -pprHsExplicitForAll _ Nothing = empty - --- | Prints an arrow for visible @forall@s (e.g., @forall a ->@) and a dot for --- invisible @forall@s (e.g., @forall a.@). -ppr_forall_separator :: ForallVisFlag -> SDoc -ppr_forall_separator ForallVis = space <> arrow -ppr_forall_separator ForallInvis = dot - -pprLHsContext :: (OutputableBndrId p) - => LHsContext (GhcPass p) -> SDoc -pprLHsContext lctxt - | null (unLoc lctxt) = empty - | otherwise = pprLHsContextAlways lctxt - --- For use in a HsQualTy, which always gets printed if it exists. -pprLHsContextAlways :: (OutputableBndrId p) - => LHsContext (GhcPass p) -> SDoc -pprLHsContextAlways (L _ ctxt) - = case ctxt of - [] -> parens empty <+> darrow - [L _ ty] -> ppr_mono_ty ty <+> darrow - _ -> parens (interpp'SP ctxt) <+> darrow - --- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprLHsContextExtra :: (OutputableBndrId p) - => Bool -> LHsContext (GhcPass p) -> SDoc -pprLHsContextExtra show_extra lctxt@(L _ ctxt) - | not show_extra = pprLHsContext lctxt - | null ctxt = char '_' <+> darrow - | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow - where - ctxt' = map ppr ctxt ++ [char '_'] - -pprConDeclFields :: (OutputableBndrId p) - => [LConDeclField (GhcPass p)] -> SDoc -pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) - where - ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, - cd_fld_doc = doc })) - = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc - ppr_fld (L _ (XConDeclField x)) = ppr x - ppr_names [n] = ppr n - ppr_names ns = sep (punctuate comma (map ppr ns)) - -{- -Note [Printing KindedTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#3830 reminded me that we should really only print the kind -signature on a KindedTyVar if the kind signature was put there by the -programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, -rather than converting to KindedTyVars as before. - -(As it happens, the message in #3830 comes out a different way now, -and the problem doesn't show up; but having the flag on a KindedTyVar -seems like the Right Thing anyway.) --} - --- Printing works more-or-less as for Types - -pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc -pprHsType ty = ppr_mono_ty ty - -ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc -ppr_mono_lty ty = ppr_mono_ty (unLoc ty) - -ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc -ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }) - = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty] - -ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) - = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] - -ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty -ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds -ppr_mono_ty (HsTyVar _ prom (L _ name)) - | isPromoted prom = quote (pprPrefixOcc name) - | otherwise = pprPrefixOcc name -ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 -ppr_mono_ty (HsTupleTy _ con tys) - -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Unit x`, not `(x)` - | [ty] <- tys - , BoxedTuple <- std_con - = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] - | otherwise - = tupleParens std_con (pprWithCommas ppr tys) - where std_con = case con of - HsUnboxedTuple -> UnboxedTuple - _ -> BoxedTuple -ppr_mono_ty (HsSumTy _ tys) - = tupleParens UnboxedTuple (pprWithBars ppr tys) -ppr_mono_ty (HsKindSig _ ty kind) - = ppr_mono_lty ty <+> dcolon <+> ppr kind -ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) -ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) -ppr_mono_ty (HsSpliceTy _ s) = pprSplice s -ppr_mono_ty (HsExplicitListTy _ prom tys) - | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) - | otherwise = brackets (interpp'SP tys) -ppr_mono_ty (HsExplicitTupleTy _ tys) - -- Special-case unary boxed tuples so that they are pretty-printed as - -- `'Unit x`, not `'(x)` - | [ty] <- tys - = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] - | otherwise - = quote $ parens (maybeAddSpace tys $ interpp'SP tys) -ppr_mono_ty (HsTyLit _ t) = ppr_tylit t -ppr_mono_ty (HsWildCardTy {}) = char '_' - -ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') - -ppr_mono_ty (HsAppTy _ fun_ty arg_ty) - = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] -ppr_mono_ty (HsAppKindTy _ ty k) - = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k -ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) - = sep [ ppr_mono_lty ty1 - , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] - -ppr_mono_ty (HsParTy _ ty) - = parens (ppr_mono_lty ty) - -- Put the parens in where the user did - -- But we still use the precedence stuff to add parens because - -- toHsType doesn't put in any HsParTys, so we may still need them - -ppr_mono_ty (HsDocTy _ ty doc) - -- AZ: Should we add parens? Should we introduce "-- ^"? - = ppr_mono_lty ty <+> ppr (unLoc doc) - -- we pretty print Haddock comments on types as if they were - -- postfix operators - -ppr_mono_ty (XHsType t) = ppr t - --------------------------- -ppr_fun_ty :: (OutputableBndrId p) - => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc -ppr_fun_ty ty1 ty2 - = let p1 = ppr_mono_lty ty1 - p2 = ppr_mono_lty ty2 - in - sep [p1, arrow <+> p2] - --------------------------- -ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy _ i) = integer i -ppr_tylit (HsStrTy _ s) = text (show s) - - --- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses --- under precedence @p@. -hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool -hsTypeNeedsParens p = go - where - go (HsForAllTy{}) = p >= funPrec - go (HsQualTy{}) = p >= funPrec - go (HsBangTy{}) = p > topPrec - go (HsRecTy{}) = False - go (HsTyVar{}) = False - go (HsFunTy{}) = p >= funPrec - go (HsTupleTy{}) = False - go (HsSumTy{}) = False - go (HsKindSig{}) = p >= sigPrec - go (HsListTy{}) = False - go (HsIParamTy{}) = p > topPrec - go (HsSpliceTy{}) = False - go (HsExplicitListTy{}) = False - go (HsExplicitTupleTy{}) = False - go (HsTyLit{}) = False - go (HsWildCardTy{}) = False - go (HsStarTy{}) = False - go (HsAppTy{}) = p >= appPrec - go (HsAppKindTy{}) = p >= appPrec - go (HsOpTy{}) = p >= opPrec - go (HsParTy{}) = False - go (HsDocTy _ (L _ t) _) = go t - go (XHsType{}) = False - -maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc --- See Note [Printing promoted type constructors] --- in IfaceType. This code implements the same --- logic for printing HsType -maybeAddSpace tys doc - | (ty : _) <- tys - , lhsTypeHasLeadingPromotionQuote ty = space <> doc - | otherwise = doc - -lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool -lhsTypeHasLeadingPromotionQuote ty - = goL ty - where - goL (L _ ty) = go ty - - go (HsForAllTy{}) = False - go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) - | L _ (c:_) <- ctxt = goL c - | otherwise = goL body - go (HsBangTy{}) = False - go (HsRecTy{}) = False - go (HsTyVar _ p _) = isPromoted p - go (HsFunTy _ arg _) = goL arg - go (HsListTy{}) = False - go (HsTupleTy{}) = False - go (HsSumTy{}) = False - go (HsOpTy _ t1 _ _) = goL t1 - go (HsKindSig _ t _) = goL t - go (HsIParamTy{}) = False - go (HsSpliceTy{}) = False - go (HsExplicitListTy _ p _) = isPromoted p - go (HsExplicitTupleTy{}) = True - go (HsTyLit{}) = False - go (HsWildCardTy{}) = False - go (HsStarTy{}) = False - go (HsAppTy _ t _) = goL t - go (HsAppKindTy _ t _) = goL t - go (HsParTy{}) = False - go (HsDocTy _ t _) = goL t - go (XHsType{}) = False - --- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is --- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply --- returns @ty@. -parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) -parenthesizeHsType p lty@(L loc ty) - | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty) - | otherwise = lty - --- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint --- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ --- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply --- returns @ctxt@ unchanged. -parenthesizeHsContext :: PprPrec - -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) -parenthesizeHsContext p lctxt@(L loc ctxt) = - case ctxt of - [c] -> L loc [parenthesizeHsType p c] - _ -> lctxt -- Other contexts are already "parenthesized" by virtue of - -- being tuples. diff --git a/GHC/Hs/Utils.hs b/GHC/Hs/Utils.hs --- a/GHC/Hs/Utils.hs +++ b/GHC/Hs/Utils.hs @@ -9,9 +9,9 @@ Parameterised by Module ---------------- ------------- - GhcPs/RdrName parser/RdrHsSyn - GhcRn/Name rename/RnHsSyn - GhcTc/Id typecheck/TcHsSyn + GhcPs/RdrName GHC.Parser.PostProcess + GhcRn/Name GHC.Rename.* + GhcTc/Id GHC.Tc.Utils.Zonk The @mk*@ functions attempt to construct a not-completely-useless SrcSpan from their components, compared with the @nl*@ functions which @@ -23,11 +23,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + module GHC.Hs.Utils( -- * Terms - mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, + mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, + mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, @@ -36,12 +43,11 @@ mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, mkHsCmdIf, - nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, + nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - typeToLHsType, -- * Constructing general big tuples -- $big_tuples @@ -67,7 +73,8 @@ nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, -- * Stmts - mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, + mkTransformStmt, mkTransformByStmt, mkBodyStmt, + mkPsBindStmt, mkRnBindStmt, mkTcBindStmt, mkLastStmt, emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, @@ -75,7 +82,7 @@ -- * Template Haskell mkUntypedSplice, mkTypedSplice, - mkHsQuasiQuote, unqualQuasiQuote, + mkHsQuasiQuote, -- * Collecting binders isUnliftedHsBind, isBangedHsBind, @@ -86,6 +93,7 @@ collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, + CollectPass(..), hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, @@ -97,41 +105,42 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Hs.Pat -import GHC.Hs.Types +import GHC.Hs.Type import GHC.Hs.Lit -import GHC.Hs.PlaceHolder import GHC.Hs.Extension -import TcEvidence -import RdrName -import Var -import TyCoRep -import Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) -import TysWiredIn ( unitTy ) -import TcType -import DataCon -import ConLike -import Id -import Name -import NameSet hiding ( unitFV ) -import NameEnv -import BasicTypes -import SrcLoc -import FastString -import Util -import Bag -import Outputable -import Constants +import GHC.Tc.Types.Evidence +import GHC.Types.Name.Reader +import GHC.Types.Var +import GHC.Core.TyCo.Rep +import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Builtin.Types ( unitTy ) +import GHC.Tc.Utils.TcType +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Set hiding ( unitFV ) +import GHC.Types.Name.Env +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Settings.Constants +import GHC.Parser.Annotation import Data.Either import Data.Function import Data.List +import Data.Proxy {- ************************************************************************ @@ -145,15 +154,15 @@ just attach 'noSrcSpan' to everything. -} --- | e => (e) +-- | @e => (e)@ mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = cL (getLoc e) (HsPar noExtField e) +mkHsPar e = L (getLoc e) (HsPar noExtField e) -mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) +mkSimpleMatch :: HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs - = cL loc $ + = L loc $ Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats , m_grhss = unguardedGRHSs rhs } where @@ -163,12 +172,12 @@ unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p))) -unguardedGRHSs rhs@(dL->L loc _) +unguardedGRHSs rhs@(L loc _) = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] -unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)] +unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)] mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField) => Origin -> [LMatch name (Located (body name))] @@ -179,13 +188,30 @@ mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] -mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms +mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) +mkHsApp = mkHsAppWith addCLoc -mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn) - => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id) +mkHsAppWith + :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) + -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) +mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2) + +mkHsApps + :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +mkHsApps = mkHsAppsWith addCLoc + +mkHsAppsWith + :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) + -> LHsExpr (GhcPass id) + -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) +mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) + +mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) where t_body = hswc_body t @@ -194,9 +220,12 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => - [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) +mkHsLam :: IsPass p + => (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) + => [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) + -> LHsExpr (GhcPass p) +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats' body] @@ -213,25 +242,24 @@ mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr -nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) +nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) -nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) +nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- --- | Wrap in parens if (hsExprNeedsParens appPrec) says it needs them --- So 'f x' becomes '(f x)', but '3' stays as '3' -mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsPar le@(dL->L loc e) - | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le) +-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them +-- So @f x@ becomes @(f x)@, but @3@ stays as @3@. +mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsPar le@(L loc e) + | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le) | otherwise = le -mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(dL->L loc p) - | patNeedsParens appPrec p = cL loc (ParPat noExtField lp) +mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) +mkParPat lp@(L loc p) + | patNeedsParens appPrec p = L loc (ParPat noExtField lp) | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) @@ -239,27 +267,29 @@ ------------------------------- -- These are the bits of syntax that contain rebindable names --- See RnEnv.lookupSyntaxName +-- See GHC.Rename.Env.lookupSyntax mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs -mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkHsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsComp :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs -mkLastStmt :: Located (bodyR (GhcPass idR)) +-- NB: The following functions all use noSyntaxExpr: the generated expressions +-- will not work with rebindable syntax if used after the renamer +mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) -mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) - (Located (bodyR (GhcPass idR))) ~ NoExtField) - => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) - -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) +mkPsBindStmt :: LPat GhcPs -> Located (bodyR GhcPs) + -> StmtLR GhcPs GhcPs (Located (bodyR GhcPs)) +mkRnBindStmt :: LPat GhcRn -> Located (bodyR GhcRn) + -> StmtLR GhcRn GhcRn (Located (bodyR GhcRn)) mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) @@ -277,15 +307,15 @@ mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where - last_stmt = cL (getLoc expr) $ mkLastStmt expr + last_stmt = L (getLoc expr) $ mkLastStmt expr -mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) - -> HsExpr (GhcPass p) -mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b +-- restricted to GhcPs because other phases might need a SyntaxExpr +mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsIf c a b = HsIf noExtField c a b -mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) - -> HsCmd (GhcPass p) -mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b +-- restricted to GhcPs because other phases might need a SyntaxExpr +mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs +mkHsCmdIf c a b = HsCmdIf noExtField noSyntaxExpr c a b mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr mkNPlusKPat id lit @@ -313,16 +343,19 @@ mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkLastStmt body = LastStmt noExtField body False noSyntaxExpr +mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr mkBodyStmt body = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr -mkBindStmt pat body - = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr -mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr +mkPsBindStmt pat body = BindStmt noExtField pat body +mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body +mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, + xbstc_boundResultType = unitTy, + xbstc_boundResultMult = Many, + xbstc_failOp = Nothing }) pat body -- don't use placeHolderTypeTc above, because that panics during zonking -emptyRecStmt' :: forall idL idR body. - XRecStmt (GhcPass idL) (GhcPass idR) body +emptyRecStmt' :: forall idL idR body. IsPass idR + => XRecStmt (GhcPass idL) (GhcPass idR) body -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal = RecStmt @@ -364,11 +397,6 @@ mkHsQuasiQuote quoter span quote = HsQuasiQuote noExtField unqualSplice quoter span quote -unqualQuasiQuote :: RdrName -unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) - -- A name (uniquified later) to - -- identify the quasi-quote - mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) @@ -387,7 +415,10 @@ nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) nlHsVar n = noLoc (HsVar noExtField (noLoc n)) --- | NB: Only for LHsExpr **Id** +nl_HsVar :: IdP (GhcPass id) -> HsExpr (GhcPass id) +nl_HsVar n = HsVar noExtField (noLoc n) + +-- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) @@ -403,23 +434,21 @@ nlLitPat :: HsLit GhcPs -> LPat GhcPs nlLitPat l = noLoc (LitPat noExtField l) -nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x)) -nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) -nlHsSyntaxApps (SyntaxExpr { syn_expr = fun - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) args - | [] <- arg_wraps -- in the noSyntaxExpr case - = ASSERT( isIdHsWrapper res_wrap ) - foldl' nlHsApp (noLoc fun) args - - | otherwise +nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc] + -> LHsExpr GhcTc +nlHsSyntaxApps (SyntaxExprTc { syn_expr = fun + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) args = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) +nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args) + -- this function should never be called in scenarios where there is no + -- syntax expr -nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsApps :: IsPass id => IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) @@ -435,25 +464,42 @@ nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs -nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) - (InfixCon (parenthesizePat opPrec l) - (parenthesizePat opPrec r))) +nlInfixConPat con l r = noLoc $ ConPat + { pat_con = noLoc con + , pat_args = InfixCon (parenthesizePat opPrec l) + (parenthesizePat opPrec r) + , pat_con_ext = noExtField + } nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs -nlConPat con pats = - noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) +nlConPat con pats = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc con + , pat_args = PrefixCon (map (parenthesizePat appPrec) pats) + } nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn -nlConPatName con pats = - noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) +nlConPatName con pats = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc con + , pat_args = PrefixCon (map (parenthesizePat appPrec) pats) + } -nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p) -nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) +nlNullaryConPat :: RdrName -> LPat GhcPs +nlNullaryConPat con = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc con + , pat_args = PrefixCon [] + } nlWildConPat :: DataCon -> LPat GhcPs -nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (PrefixCon (replicate (dataConSourceArity con) - nlWildPat))) +nlWildConPat con = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc $ getRdrName con + , pat_args = PrefixCon $ + replicate (dataConSourceArity con) + nlWildPat + } -- | Wildcard pattern - after parsing nlWildPat :: LPat GhcPs @@ -463,7 +509,7 @@ nlWildPatName :: LPat GhcRn nlWildPatName = noLoc (WildPat noExtField ) -nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] +nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) @@ -472,8 +518,6 @@ nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) - -> LHsExpr (GhcPass id) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs @@ -481,10 +525,10 @@ nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match])) nlHsPar e = noLoc (HsPar noExtField e) --- | Note [Rebindable nlHsIf] -- nlHsIf should generate if-expressions which are NOT subject to --- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false) +-- RebindableSyntax, so the first field of HsIf is False. (#12080) +nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsIf cond true false = noLoc (HsIf noExtField cond true false) nlHsCase expr matches = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) @@ -497,11 +541,24 @@ nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t)) nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b) +nlHsFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b) nlHsParTy t = noLoc (HsParTy noExtField t) -nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) -nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys +nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p) + -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) +nlHsTyConApp fixity tycon tys + | Infix <- fixity + , HsValArg ty1 : HsValArg ty2 : rest <- tys + = foldl' mk_app (noLoc $ HsOpTy noExtField ty1 (noLoc tycon) ty2) rest + | otherwise + = foldl' mk_app (nlHsTyVar tycon) tys + where + mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) + mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLoc $ HsParTy noExtField fun) arg + -- parenthesize things like `(A + B) C` + mk_app fun (HsValArg ty) = noLoc (HsAppTy noExtField fun (parenthesizeHsType appPrec ty)) + mk_app fun (HsTypeArg _ ki) = noLoc (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki)) + mk_app fun (HsArgPar _) = noLoc (HsParTy noExtField fun) nlHsAppKindTy :: LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) @@ -531,7 +588,7 @@ mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed +mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed -- | The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) @@ -551,7 +608,7 @@ -- #big_tuples# -- -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but --- we might concievably want to build such a massive tuple as part of the +-- we might conceivably want to build such a massive tuple as part of the -- output of a desugaring stage (notably that for list comprehensions). -- -- We call tuples above this size \"big tuples\", and emulate them by @@ -566,7 +623,7 @@ -- and 'mkTupleCase' functions to do all your work with tuples you should be -- fine, and not have to worry about the arity limitation at all. --- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' -> [a] -- ^ Possible \"big\" list of things to construct from -> a -- ^ Constructed thing made possible by recursive decomposition @@ -620,173 +677,66 @@ -- of which use this function where (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs - is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True - is_gen_dm_sig _ = False + is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False mk_pairs :: [LSig GhcRn] -> [(Name, a)] mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs - , (dL->L _ n) <- ns ] + , L _ n <- ns ] mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] --- ^ Convert TypeSig to ClassOpSig +-- ^ Convert 'TypeSig' to 'ClassOpSig'. -- The former is what is parsed, but the latter is -- what we need in class/instance declarations mkClassOpSigs sigs = map fiddle sigs where - fiddle (dL->L loc (TypeSig _ nms ty)) - = cL loc (ClassOpSig noExtField False nms (dropWildCards ty)) + fiddle (L loc (TypeSig _ nms ty)) + = L loc (ClassOpSig noExtField False nms (dropWildCards ty)) fiddle sig = sig -typeToLHsType :: Type -> LHsType GhcPs --- ^ Converting a Type to an HsType RdrName --- This is needed to implement GeneralizedNewtypeDeriving. --- --- Note that we use 'getRdrName' extensively, which --- generates Exact RdrNames rather than strings. -typeToLHsType ty - = go ty - where - go :: Type -> LHsType GhcPs - go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - = case af of - VisArg -> nlHsFunTy (go arg) (go res) - InvisArg | (theta, tau) <- tcSplitPhiTy ty - -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) - , hst_xqual = noExtField - , hst_body = go tau }) - - go ty@(ForAllTy (Bndr _ argf) _) - | (tvs, tau) <- tcSplitForAllTysSameVis argf ty - = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf - , hst_bndrs = map go_tv tvs - , hst_xforall = noExtField - , hst_body = go tau }) - go (TyVarTy tv) = nlHsTyVar (getRdrName tv) - go (LitTy (NumTyLit n)) - = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n) - go (LitTy (StrTyLit s)) - = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s) - go ty@(TyConApp tc args) - | tyConAppNeedsKindSig True tc (length args) - -- We must produce an explicit kind signature here to make certain - -- programs kind-check. See Note [Kind signatures in typeToLHsType]. - = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty)) - | otherwise = ty' - where - ty' :: LHsType GhcPs - ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args) - go ty@(AppTy {}) = go_app (go head) args (appTyArgFlags head args) - where - head :: Type - args :: [Type] - (head, args) = splitAppTys ty - go (CastTy ty _) = go ty - go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) - - -- Source-language types have _invisible_ kind arguments, - -- so we must remove them here (#8563) - - go_app :: LHsType GhcPs -- The type being applied - -> [Type] -- The argument types - -> [ArgFlag] -- The argument types' visibilities - -> LHsType GhcPs - go_app head args arg_flags = - foldl' (\f (arg, flag) -> - let arg' = go arg in - case flag of - Inferred -> f - Specified -> f `nlHsAppKindTy` arg' - Required -> f `nlHsAppTy` arg') - head (zip args arg_flags) - - go_tv :: TyVar -> LHsTyVarBndr GhcPs - go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv)) - (go (tyVarKind tv)) - -{- -Note [Kind signatures in typeToLHsType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are types that typeToLHsType can produce which require explicit kind -signatures in order to kind-check. Here is an example from #14579: - - -- type P :: forall {k} {t :: k}. Proxy t - type P = 'Proxy - - -- type Wat :: forall a. Proxy a -> * - newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) - deriving Eq - - -- type Wat2 :: forall {a}. Proxy a -> * - type Wat2 = Wat - - -- type Glurp :: * -> * - newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a)) - deriving Eq - -The derived Eq instance for Glurp (without any kind signatures) would be: - - instance Eq a => Eq (Glurp a) where - (==) = coerce @(Wat2 P -> Wat2 P -> Bool) - @(Glurp a -> Glurp a -> Bool) - (==) :: Glurp a -> Glurp a -> Bool - -(Where the visible type applications use types produced by typeToLHsType.) - -The type P (in Wat2 P) has an underspecified kind, so we must ensure that -typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish -this, whenever we see an application of a tycon to some arguments, we use -the tyConAppNeedsKindSig function to determine if it requires an explicit kind -signature to resolve some ambiguity. (See Note -Note [When does a tycon application need an explicit kind signature?] for a -more detailed explanation of how this works.) - -Note that we pass True to tyConAppNeedsKindSig since we are generated code with -visible kind applications, so even specified arguments count towards injective -positions in the kind of the tycon. --} - {- ********************************************************************* * * --------- HsWrappers: type args, dict args, casts --------- * * ********************************************************************* -} -mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) +mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) --- | Avoid (HsWrap co (HsWrap co' _)). --- See Note [Detecting forced eta expansion] in DsExpr -mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) -mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn e = HsWrap noExtField co_fn e +-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@ +-- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr" +mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc +mkHsWrap co_fn e | isIdHsWrapper co_fn = e +mkHsWrap co_fn (XExpr (WrapExpr (HsWrap co_fn' e))) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn (HsPar x (L l e)) = HsPar x (L l (mkHsWrap co_fn e)) +mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e) mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) + -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) + -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e -mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) +mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc +mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) -mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) +mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap noExtField w cmd + | otherwise = XCmd (HsWrap w cmd) -mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) +mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc +mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) -mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat noExtField co_fn p ty + | otherwise = XPat $ CoPat co_fn p ty -mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat noExtField (mkWpCastN co) pat ty + | otherwise = XPat $ CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -806,7 +756,6 @@ mkFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms - , fun_co_fn = idHsWrapper , fun_ext = noExtField , fun_tick = [] } @@ -815,7 +764,6 @@ -- ^ In Name-land, with empty bind_fvs mkTopFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms - , fun_co_fn = idHsWrapper , fun_ext = emptyNameSet -- NB: closed -- binding , fun_tick = [] } @@ -824,9 +772,9 @@ mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) -mkVarBind var rhs = cL (getLoc rhs) $ +mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_ext = noExtField, - var_id = var, var_rhs = rhs, var_inline = False } + var_id = var, var_rhs = rhs } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs @@ -841,7 +789,7 @@ -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. isInfixFunBind :: HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind _ _ (MG _ matches _) _ _) +isInfixFunBind (FunBind { fun_matches = MG _ matches _ }) = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False @@ -852,19 +800,21 @@ mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr - = cL loc $ mkFunBind Generated (cL loc fun) - [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr + = L loc $ mkFunBind Generated (L loc fun) + [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr (noLoc emptyLocalBinds)] -- | Make a prefix, non-strict function 'HsMatchContext' -mkPrefixFunRhs :: Located id -> HsMatchContext id +mkPrefixFunRhs :: LIdP p -> HsMatchContext p mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_fixity = Prefix , mc_strictness = NoSrcStrict } ------------ -mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) - -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) +mkMatch :: forall p. IsPass p + => HsMatchContext (NoGhcTc (GhcPass p)) + -> [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) -> Located (HsLocalBinds (GhcPass p)) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr lbinds @@ -873,8 +823,9 @@ , m_pats = map paren pats , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) where - paren lp@(dL->L l p) - | patNeedsParens appPrec p = cL l (ParPat noExtField lp) + paren :: Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p)) + paren lp@(L l p) + | patNeedsParens appPrec p = L l (ParPat noExtField lp) | otherwise = lp {- @@ -933,7 +884,7 @@ -- | Should we treat this as an unlifted bind? This will be true for any -- bind that binds an unlifted variable, but we must be careful around -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage --- information, see Note [Strict binds check] is DsBinds. +-- information, see Note [Strict binds check] is "GHC.HsToCore.Binds". isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds isUnliftedHsBind bind | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind @@ -954,7 +905,7 @@ isBangedHsBind (AbsBinds { abs_binds = binds }) = anyBag (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches}) - | [dL->L _ match] <- unLoc $ mg_alts matches + | [L _ match] <- unLoc $ mg_alts matches , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match = True isBangedHsBind (PatBind {pat_lhs = pat}) @@ -962,64 +913,85 @@ isBangedHsBind _ = False -collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) +collectLocalBinders :: CollectPass (GhcPass idL) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds -- No pattern synonyms here collectLocalBinders (HsIPBinds {}) = [] collectLocalBinders (EmptyLocalBinds _) = [] -collectLocalBinders (XHsLocalBindsLR _) = [] -collectHsIdBinders, collectHsValBinders - :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] --- ^ Collect Id binders only, or Ids + pattern synonyms, respectively +collectHsIdBinders :: CollectPass (GhcPass idL) + => HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively collectHsIdBinders = collect_hs_val_binders True + +collectHsValBinders :: CollectPass (GhcPass idL) + => HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] collectHsValBinders = collect_hs_val_binders False -collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> - HsBindLR p idR -> [IdP p] --- ^ Collect both Ids and pattern-synonym binders +collectHsBindBinders :: CollectPass p + => HsBindLR p idR + -> [IdP p] +-- ^ Collect both 'Id's and pattern-synonym binders collectHsBindBinders b = collect_bind False b [] -collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] +collectHsBindsBinders :: CollectPass p + => LHsBindsLR p idR + -> [IdP p] collectHsBindsBinders binds = collect_binds False binds [] -collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] --- ^ Same as collectHsBindsBinders, but works over a list of bindings +collectHsBindListBinders :: CollectPass p + => [LHsBindLR p idR] + -> [IdP p] +-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] -collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) +collect_hs_val_binders :: CollectPass (GhcPass idL) + => Bool + -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) = collect_out_binds ps binds -collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] -> - [IdP (GhcPass p)] +collect_out_binds :: CollectPass p + => Bool + -> [(RecFlag, LHsBinds p)] + -> [IdP p] collect_out_binds ps = foldr (collect_binds ps . snd) [] -collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> - [IdP (GhcPass p)] -> [IdP (GhcPass p)] --- ^ Collect Ids, or Ids + pattern synonyms, depending on boolean flag +collect_binds :: CollectPass p + => Bool + -> LHsBindsLR p idR + -> [IdP p] + -> [IdP p] +-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds -collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] +collect_bind :: CollectPass p + => Bool + -> HsBindLR p idR + -> [IdP p] + -> [IdP p] collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc +collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds - -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc + -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk +collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc | otherwise = ps : acc collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc collect_bind _ (XHsBindsLR _) acc = acc collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] --- ^ Used exclusively for the bindings of an instance decl which are all FunBinds +-- ^ Used exclusively for the bindings of an instance decl which are all +-- 'FunBinds' collectMethodBinders binds = foldr (get . unLoc) [] binds where get (FunBind { fun_id = f }) fs = f : fs @@ -1027,22 +999,26 @@ -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] +collectLStmtsBinders :: (CollectPass (GhcPass idL)) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] +collectStmtsBinders :: (CollectPass (GhcPass idL)) + => [StmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body +collectLStmtBinders :: (CollectPass (GhcPass idL)) + => LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body +collectStmtBinders :: (CollectPass (GhcPass idL)) + => StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat +collectStmtBinders (BindStmt _ pat _) = collectPatBinders pat collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] @@ -1054,62 +1030,78 @@ where collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat - collectArgBinders _ = [] -collectStmtBinders (XStmtLR nec) = noExtCon nec + collectArgBinders (_, XApplicativeArg {}) = [] ----------------- Patterns -------------------------- -collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)] +collectPatBinders :: CollectPass p => LPat p -> [IdP p] collectPatBinders pat = collect_lpat pat [] -collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] +collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p] collectPatsBinders pats = foldr collect_lpat [] pats ------------- -collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - LPat p -> [IdP p] -> [IdP p] -collect_lpat p bndrs - = go (unLoc p) - where - go (VarPat _ var) = unLoc var : bndrs - go (WildPat _) = bndrs - go (LazyPat _ pat) = collect_lpat pat bndrs - go (BangPat _ pat) = collect_lpat pat bndrs - go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs - go (ViewPat _ _ pat) = collect_lpat pat bndrs - go (ParPat _ pat) = collect_lpat pat bndrs +collect_lpat :: forall pass. (CollectPass pass) + => LPat pass -> [IdP pass] -> [IdP pass] +collect_lpat p bndrs = collect_pat (unLoc p) bndrs - go (ListPat _ pats) = foldr collect_lpat bndrs pats - go (TuplePat _ pats _) = foldr collect_lpat bndrs pats - go (SumPat _ pat _ _) = collect_lpat pat bndrs +collect_pat :: forall p. CollectPass p + => Pat p + -> [IdP p] + -> [IdP p] +collect_pat pat bndrs = case pat of + (VarPat _ var) -> unLoc var : bndrs + (WildPat _) -> bndrs + (LazyPat _ pat) -> collect_lpat pat bndrs + (BangPat _ pat) -> collect_lpat pat bndrs + (AsPat _ a pat) -> unLoc a : collect_lpat pat bndrs + (ViewPat _ _ pat) -> collect_lpat pat bndrs + (ParPat _ pat) -> collect_lpat pat bndrs + (ListPat _ pats) -> foldr collect_lpat bndrs pats + (TuplePat _ pats _) -> foldr collect_lpat bndrs pats + (SumPat _ pat _ _) -> collect_lpat pat bndrs + (ConPat {pat_args=ps}) -> foldr collect_lpat bndrs (hsConPatArgs ps) + -- See Note [Dictionary binders in ConPatOut] + (LitPat _ _) -> bndrs + (NPat {}) -> bndrs + (NPlusKPat _ n _ _ _ _) -> unLoc n : bndrs + (SigPat _ pat _) -> collect_lpat pat bndrs + (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) + -> collect_pat pat bndrs + (SplicePat _ _) -> bndrs + (XPat ext) -> collectXXPat (Proxy @p) ext bndrs - go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) - -- See Note [Dictionary binders in ConPatOut] - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs +-- | This class specifies how to collect variable identifiers from extension patterns in the given pass. +-- Consumers of the GHC API that define their own passes should feel free to implement instances in order +-- to make use of functions which depend on it. +-- +-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that +-- it can reuse the code in GHC for collecting binders. +class (XRec p Pat ~ Located (Pat p)) => CollectPass p where + collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p] - go (SigPat _ pat _) = collect_lpat pat bndrs +instance CollectPass (GhcPass 'Parsed) where + collectXXPat _ ext = noExtCon ext - go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) - = go pat - go (SplicePat _ _) = bndrs - go (CoPat _ _ pat _) = go pat - go (XPat {}) = bndrs +instance CollectPass (GhcPass 'Renamed) where + collectXXPat _ ext = noExtCon ext +instance CollectPass (GhcPass 'Typechecked) where + collectXXPat _ (CoPat _ pat _) = collect_pat pat + + {- -Note [Dictionary binders in ConPatOut] See also same Note in DsArrows +Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do *not* gather (a) dictionary and (b) dictionary bindings as binders of a ConPatOut pattern. For most calls it doesn't matter, because it's pre-typechecker and there are no ConPatOuts. But it does matter -more in the desugarer; for example, DsUtils.mkSelectorBinds uses +more in the desugarer; for example, GHC.HsToCore.Utils.mkSelectorBinds uses collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings for x,y but not for dictionaries bound by C. (The type checker ensures they would not be used.) -Desugaring of arrow case expressions needs these bindings (see DsArrows +Desugaring of arrow case expressions needs these bindings (see GHC.HsToCore.Arrows and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its own pat-binder-collector: @@ -1123,7 +1115,7 @@ Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), and *also* uses that dictionary to match the (n+1) pattern. Yet, the variables bound by the lazy pattern are n,m, *not* the dictionary d. -So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. +So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the variables bound. -} hsGroupBinders :: HsGroup GhcRn -> [Name] @@ -1131,7 +1123,6 @@ hs_fords = foreign_decls }) = collectHsValBinders val_decls ++ hsTyClForeignBinders tycl_decls foreign_decls -hsGroupBinders (XHsGroup nec) = noExtCon nec hsTyClForeignBinders :: [TyClGroup GhcRn] -> [LForeignDecl GhcRn] @@ -1149,7 +1140,8 @@ getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- -hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) +hsLTyClDeclBinders :: IsPass p + => Located (TyClDecl (GhcPass p)) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component @@ -1160,46 +1152,41 @@ -- Each returned (Located name) has a SrcSpan for the /whole/ declaration. -- See Note [SrcSpan for binders] -hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl - { fdLName = (dL->L _ name) } })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) - = noExtCon nec -hsLTyClDeclBinders (dL->L loc (SynDecl - { tcdLName = (dL->L _ name) })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L loc (ClassDecl - { tcdLName = (dL->L _ cls_name) +hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl + { fdLName = (L _ name) } })) + = ([L loc name], []) +hsLTyClDeclBinders (L loc (SynDecl + { tcdLName = (L _ name) })) + = ([L loc name], []) +hsLTyClDeclBinders (L loc (ClassDecl + { tcdLName = (L _ cls_name) , tcdSigs = sigs , tcdATs = ats })) - = (cL loc cls_name : - [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl + = (L loc cls_name : + [ L fam_loc fam_name | (L fam_loc (FamilyDecl { fdLName = L _ fam_name })) <- ats ] ++ - [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs - , (dL->L _ mem_name) <- ns ] + [ L mem_loc mem_name | (L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (L _ mem_name) <- ns ] , []) -hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) - , tcdDataDefn = defn })) - = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn -hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec -hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" - -- due to #15884 +hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) + , tcdDataDefn = defn })) + = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn ------------------- hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] -- ^ See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls - = [ cL decl_loc n - | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) + = [ L decl_loc n + | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] ------------------- hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym --- names are collected by collectHsValBinders. +-- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _)) = foldr addPatSynSelector [] . unionManyBags $ map snd binds @@ -1213,53 +1200,45 @@ getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds = [ psb | (_, lbinds) <- binds - , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] + , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- -hsLInstDeclBinders :: LInstDecl (GhcPass p) +hsLInstDeclBinders :: IsPass p + => LInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -hsLInstDeclBinders (dL->L _ (ClsInstD +hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis }})) = foldMap (hsDataFamInstBinders . unLoc) dfis -hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) +hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi -hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty -hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) - = noExtCon nec -hsLInstDeclBinders (dL->L _ (XInstDecl nec)) - = noExtCon nec -hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" - -- due to #15884 +hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty ------------------- --- | the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl (GhcPass p) +-- | the 'SrcLoc' returned are for the whole declarations, not just the names +hsDataFamInstBinders :: IsPass p + => DataFamInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders -hsDataFamInstBinders (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = XFamEqn nec}}) - = noExtCon nec -hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec ------------------- --- | the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn (GhcPass p) +-- | the 'SrcLoc' returned are for the whole declarations, not just the names +hsDataDefnBinders :: IsPass p + => HsDataDefn (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] -hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec ------------------- type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] -- Filters out ones that have already been seen -hsConDeclsBinders :: [LConDecl (GhcPass p)] +hsConDeclsBinders :: forall p. IsPass p + => [LConDecl (GhcPass p)] -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records @@ -1278,19 +1257,17 @@ -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_args = args } - -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) + -> (map (L loc . unLoc) names ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs ConDeclH98 { con_name = name, con_args = args } - -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) + -> ([L loc (unLoc name)] ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs - XConDecl nec -> noExtCon nec - get_flds :: Seen p -> HsConDeclDetails (GhcPass p) -> (Seen p, [LFieldOcc (GhcPass p)]) get_flds remSeen (RecCon flds) @@ -1354,11 +1331,10 @@ hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) -> [(SrcSpan, [Name])] - hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat + hs_stmt (BindStmt _ pat _) = lPatImplicits pat hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts - do_arg (_, XApplicativeArg nec) = noExtCon nec hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = [] hs_stmt (LastStmt {}) = [] @@ -1366,12 +1342,10 @@ , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss - hs_stmt (XStmtLR nec) = noExtCon nec hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds {}) = [] hs_local_binds (EmptyLocalBinds _) = [] - hs_local_binds (XHsLocalBindsLR _) = [] hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])] hsValBindsImplicits (XValBindsLR (NValBinds binds _)) @@ -1401,10 +1375,8 @@ hs_pat (TuplePat _ pats _) = hs_lpats pats hs_pat (SigPat _ pat _) = hs_lpat pat - hs_pat (CoPat _ _ pat _) = hs_pat pat - hs_pat (ConPatIn n ps) = details n ps - hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps + hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps hs_pat _ = [] diff --git a/GHC/HsToCore.hs b/GHC/HsToCore.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore.hs @@ -0,0 +1,744 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The Desugarer: turning HsSyn into Core. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore ( + -- * Desugaring operations + deSugar, deSugarExpr + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.HsToCore.Usage +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) +import GHC.Tc.Module ( runTcInteractive ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Core.Type +import GHC.Core.TyCon ( tyConDataCons ) +import GHC.Types.Avail +import GHC.Core +import GHC.Core.FVs ( exprsSomeFreeVarsList ) +import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) +import GHC.Core.Utils +import GHC.Core.Unfold +import GHC.Core.Ppr +import GHC.HsToCore.Monad +import GHC.HsToCore.Expr +import GHC.HsToCore.Binds +import GHC.HsToCore.Foreign.Decl +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Core.Coercion +import GHC.Builtin.Types +import GHC.Core.DataCon ( dataConWrapId ) +import GHC.Core.Make +import GHC.Unit.Module +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Core.Rules +import GHC.Types.Basic +import GHC.Core.Opt.Monad ( CoreToDo(..) ) +import GHC.Core.Lint ( endPassIO ) +import GHC.Types.Var.Set +import GHC.Data.FastString +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.HsToCore.Coverage +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Data.OrdList +import GHC.HsToCore.Docs + +import Data.List +import Data.IORef +import Control.Monad( when ) +import GHC.Driver.Plugins ( LoadedPlugin(..) ) + +{- +************************************************************************ +* * +* The main function: deSugar +* * +************************************************************************ +-} + +-- | Main entry point to the desugarer. +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) +-- Can modify PCS by faulting in more declarations + +deSugar hsc_env + mod_loc + tcg_env@(TcGblEnv { tcg_mod = id_mod, + tcg_semantic_mod = mod, + tcg_src = hsc_src, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_keep = keep_var, + tcg_th_splice_used = tc_splice_used, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_inst_env = inst_env, + tcg_fam_inst_env = fam_inst_env, + tcg_merged = merged, + tcg_warns = warns, + tcg_anns = anns, + tcg_binds = binds, + tcg_imp_specs = imp_specs, + tcg_dependent_files = dependent_files, + tcg_ev_binds = ev_binds, + tcg_th_foreign_files = th_foreign_files_var, + tcg_fords = fords, + tcg_rules = rules, + tcg_patsyns = patsyns, + tcg_tcs = tcs, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_hpc = other_hpc_info, + tcg_complete_matches = complete_matches + }) + + = do { let dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env + ; withTiming dflags + (text "Desugar"<+>brackets (ppr mod)) + (const ()) $ + do { -- Desugar the program + ; let export_set = availsToNameSet exports + target = hscTarget dflags + hpcInfo = emptyHpcInfo other_hpc_info + + ; (binds_cvr, ds_hpc_info, modBreaks) + <- if not (isHsBootOrSig hsc_src) + then addTicksToBinds hsc_env mod mod_loc + export_set (typeEnvTyCons type_env) binds + else return (binds, hpcInfo, Nothing) + ; (msgs, mb_res) <- initDs hsc_env tcg_env $ + do { ds_ev_binds <- dsEvBinds ev_binds + ; core_prs <- dsTopLHsBinds binds_cvr + ; core_prs <- patchMagicDefns core_prs + ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; ds_rules <- mapMaybeM dsRule rules + ; let hpc_init + | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info + | otherwise = empty + ; return ( ds_ev_binds + , foreign_prs `appOL` core_prs `appOL` spec_prs + , spec_rules ++ ds_rules + , ds_fords `appendStubC` hpc_init) } + + ; case mb_res of { + Nothing -> return (msgs, Nothing) ; + Just (ds_ev_binds, all_prs, all_rules, ds_fords) -> + + do { -- Add export flags to bindings + keep_alive <- readIORef keep_var + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules + final_prs = addExportFlagsAndRules target export_set keep_alive + rules_for_locals (fromOL all_prs) + + final_pgm = combineEvBinds ds_ev_binds final_prs + -- Notice that we put the whole lot in a big Rec, even the foreign binds + -- When compiling PrelFloat, which defines data Float = F# Float# + -- we want F# to be in scope in the foreign marshalling code! + -- You might think it doesn't matter, but the simplifier brings all top-level + -- things into the in-scope set before simplifying; so we get no unfolding for F#! + + ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps + ; (ds_binds, ds_rules_for_imps) + <- simpleOptPgm dflags mod final_pgm rules_for_imps + -- The simpleOptPgm gets rid of type + -- bindings plus any stupid dead code + + ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps + + ; let used_names = mkUsedNames tcg_env + pluginModules = + map lpModule (cachedPlugins (hsc_dflags hsc_env)) + ; deps <- mkDependencies (homeUnitId (hsc_dflags hsc_env)) + (map mi_module pluginModules) tcg_env + + ; used_th <- readIORef tc_splice_used + ; dep_files <- readIORef dependent_files + ; safe_mode <- finalSafeMode dflags tcg_env + ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names + dep_files merged pluginModules + -- id_mod /= mod when we are processing an hsig, but hsigs + -- never desugared and compiled (there's no code!) + -- Consequently, this should hold for any ModGuts that make + -- past desugaring. See Note [Identity versus semantic module]. + ; MASSERT( id_mod == mod ) + + ; foreign_files <- readIORef th_foreign_files_var + + ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env + + ; let mod_guts = ModGuts { + mg_module = mod, + mg_hsc_src = hsc_src, + mg_loc = mkFileSrcSpan mod_loc, + mg_exports = exports, + mg_usages = usages, + mg_deps = deps, + mg_used_th = used_th, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_anns = anns, + mg_tcs = tcs, + mg_insts = fixSafeInstances safe_mode insts, + mg_fam_insts = fam_insts, + mg_inst_env = inst_env, + mg_fam_inst_env = fam_inst_env, + mg_patsyns = patsyns, + mg_rules = ds_rules_for_imps, + mg_binds = ds_binds, + mg_foreign = ds_fords, + mg_foreign_files = foreign_files, + mg_hpc_info = ds_hpc_info, + mg_modBreaks = modBreaks, + mg_safe_haskell = safe_mode, + mg_trust_pkg = imp_trust_own_pkg imports, + mg_complete_sigs = complete_matches, + mg_doc_hdr = doc_hdr, + mg_decl_docs = decl_docs, + mg_arg_docs = arg_docs + } + ; return (msgs, Just mod_guts) + }}}} + +mkFileSrcSpan :: ModLocation -> SrcSpan +mkFileSrcSpan mod_loc + = case ml_hs_file mod_loc of + Just file_path -> mkGeneralSrcSpan (mkFastString file_path) + Nothing -> interactiveSrcSpan -- Presumably + +dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) +dsImpSpecs imp_specs + = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs + ; let (spec_binds, spec_rules) = unzip spec_prs + ; return (concatOL spec_binds, spec_rules) } + +combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] +-- Top-level bindings can include coercion bindings, but not via superclasses +-- See Note [Top-level evidence] +combineEvBinds [] val_prs + = [Rec val_prs] +combineEvBinds (NonRec b r : bs) val_prs + | isId b = combineEvBinds bs ((b,r):val_prs) + | otherwise = NonRec b r : combineEvBinds bs val_prs +combineEvBinds (Rec prs : bs) val_prs + = combineEvBinds bs (prs ++ val_prs) + +{- +Note [Top-level evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level evidence bindings may be mutually recursive with the top-level value +bindings, so we must put those in a Rec. But we can't put them *all* in a Rec +because the occurrence analyser doesn't take account of type/coercion variables +when computing dependencies. + +So we pull out the type/coercion variables (which are in dependency order), +and Rec the rest. +-} + +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr) + +deSugarExpr hsc_env tc_expr = do { + let dflags = hsc_dflags hsc_env + + ; showPass dflags "Desugar" + + -- Do desugaring + ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ + dsLExpr tc_expr + + ; case mb_core_expr of + Nothing -> return () + Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" + FormatCore (pprCoreExpr expr) + + ; return (msgs, mb_core_expr) } + +{- +************************************************************************ +* * +* Add rules and export flags to binders +* * +************************************************************************ +-} + +addExportFlagsAndRules + :: HscTarget -> NameSet -> NameSet -> [CoreRule] + -> [(Id, t)] -> [(Id, t)] +addExportFlagsAndRules target exports keep_alive rules prs + = mapFst add_one prs + where + add_one bndr = add_rules name (add_export name bndr) + where + name = idName bndr + + ---------- Rules -------- + -- See Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas + add_rules name bndr + | Just rules <- lookupNameEnv rule_base name + = bndr `addIdSpecialisations` rules + | otherwise + = bndr + rule_base = extendRuleBaseList emptyRuleBase rules + + ---------- Export flag -------- + -- See Note [Adding export flags] + add_export name bndr + | dont_discard name = setIdExported bndr + | otherwise = bndr + + dont_discard :: Name -> Bool + dont_discard name = is_exported name + || name `elemNameSet` keep_alive + + -- In interactive mode, we don't want to discard any top-level + -- entities at all (eg. do not inline them away during + -- simplification), and retain them all in the TypeEnv so they are + -- available from the command line. + -- + -- isExternalName separates the user-defined top-level names from those + -- introduced by the type checker. + is_exported :: Name -> Bool + is_exported | targetRetainsAllBindings target = isExternalName + | otherwise = (`elemNameSet` exports) + +{- +Note [Adding export flags] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Set the no-discard flag if either + a) the Id is exported + b) it's mentioned in the RHS of an orphan rule + c) it's in the keep-alive set + +It means that the binding won't be discarded EVEN if the binding +ends up being trivial (v = w) -- the simplifier would usually just +substitute w for v throughout, but we don't apply the substitution to +the rules (maybe we should?), so this substitution would make the rule +bogus. + +You might wonder why exported Ids aren't already marked as such; +it's just because the type checker is rather busy already and +I didn't want to pass in yet another mapping. + +Note [Attach rules to local ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Find the rules for locally-defined Ids; then we can attach them +to the binders in the top-level bindings + +Reason + - It makes the rules easier to look up + - It means that rewrite rules and specialisations for + locally defined Ids are handled uniformly + - It keeps alive things that are referred to only from a rule + (the occurrence analyser knows about rules attached to Ids) + - It makes sure that, when we apply a rule, the free vars + of the RHS are more likely to be in scope + - The imported rules are carried in the in-scope set + which is extended on each iteration by the new wave of + local binders; any rules which aren't on the binding will + thereby get dropped + + +************************************************************************ +* * +* Desugaring rewrite rules +* * +************************************************************************ +-} + +dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) +dsRule (L loc (HsRule { rd_name = name + , rd_act = rule_act + , rd_tmvs = vars + , rd_lhs = lhs + , rd_rhs = rhs })) + = putSrcSpanDs loc $ + do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] + + ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ + dsLExpr lhs -- Note [Desugaring RULE left hand sides] + + ; rhs' <- dsLExpr rhs + ; this_mod <- getModule + + ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs' + + -- Substitute the dict bindings eagerly, + -- and take the body apart into a (f args) form + ; dflags <- getDynFlags + ; case decomposeRuleLhs dflags bndrs'' lhs'' of { + Left msg -> do { warnDs NoReason msg; return Nothing } ; + Right (final_bndrs, fn_id, args) -> do + + { let is_local = isLocalId fn_id + -- NB: isLocalId is False of implicit Ids. This is good because + -- we don't want to attach rules to the bindings of implicit Ids, + -- because they don't show up in the bindings until just before code gen + fn_name = idName fn_id + final_rhs = simpleOptExpr dflags rhs'' -- De-crap it + rule_name = snd (unLoc name) + final_bndrs_set = mkVarSet final_bndrs + arg_ids = filterOut (`elemVarSet` final_bndrs_set) $ + exprsSomeFreeVarsList isId args + + ; rule <- dsMkUserRule this_mod is_local + rule_name rule_act fn_name final_bndrs args + final_rhs + ; when (wopt Opt_WarnInlineRuleShadowing dflags) $ + warnRuleShadowing rule_name rule_act fn_id arg_ids + + ; return (Just rule) + } } } + +warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () +-- See Note [Rules and inlining/other rules] +warnRuleShadowing rule_name rule_act fn_id arg_ids + = do { check False fn_id -- We often have multiple rules for the same Id in a + -- module. Maybe we should check that they don't overlap + -- but currently we don't + ; mapM_ (check True) arg_ids } + where + check check_rules_too lhs_id + | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) + -- If imported with no unfolding, no worries + , idInlineActivation lhs_id `competesWith` rule_act + = warnDs (Reason Opt_WarnInlineRuleShadowing) + (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because" <+> quotes (ppr lhs_id) + <+> text "might inline first") + , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" + <+> quotes (ppr lhs_id) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) + + | check_rules_too + , bad_rule : _ <- get_bad_rules lhs_id + = warnDs (Reason Opt_WarnInlineRuleShadowing) + (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) + <+> text "for"<+> quotes (ppr lhs_id) + <+> text "might fire first") + , text "Probable fix: add phase [n] or [~n] to the competing rule" + , whenPprDebug (ppr bad_rule) ]) + + | otherwise + = return () + + get_bad_rules lhs_id + = [ rule | rule <- idCoreRules lhs_id + , ruleActivation rule `competesWith` rule_act ] + +-- See Note [Desugaring coerce as cast] +unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) +unfold_coerce bndrs lhs rhs = do + (bndrs', wrap) <- go bndrs + return (bndrs', wrap lhs, wrap rhs) + where + go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) + go [] = return ([], id) + go (v:vs) + | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v) + , tc `hasKey` coercibleTyConKey = do + u <- newUnique + + let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2] + v' = mkLocalCoVar + (mkDerivedInternalName mkRepEqOcc u (getName v)) ty' + box = Var (dataConWrapId coercibleDataCon) `mkTyApps` + [k, t1, t2] `App` + Coercion (mkCoVarCo v') + + (bndrs, wrap) <- go vs + return (v':bndrs, mkCoreLet (NonRec v box) . wrap) + | otherwise = do + (bndrs,wrap) <- go vs + return (v:bndrs, wrap) + +{- Note [Desugaring RULE left hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the LHS of a RULE we do *not* want to desugar + [x] to build (\cn. x `c` n) +We want to leave explicit lists simply as chains +of cons's. We can achieve that slightly indirectly by +switching off EnableRewriteRules. See GHC.HsToCore.Expr.dsExplicitList. + +That keeps the desugaring of list comprehensions simple too. + +Nor do we want to warn of conversion identities on the LHS; +the rule is precisely to optimise them: + {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} + +Note [Desugaring coerce as cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want the user to express a rule saying roughly “mapping a coercion over a +list can be replaced by a coercion”. But the cast operator of Core (▷) cannot +be written in Haskell. So we use `coerce` for that (#2110). The user writes + map coerce = coerce +as a RULE, and this optimizes any kind of mapped' casts away, including `map +MkNewtype`. + +For that we replace any forall'ed `c :: Coercible a b` value in a RULE by +corresponding `co :: a ~#R b` and wrap the LHS and the RHS in +`let c = MkCoercible co in ...`. This is later simplified to the desired form +by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). +See also Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt. + +Note [Rules and inlining/other rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have + f x = ... + g x = ... + {-# RULES "rule-for-f" forall x. f (g x) = ... #-} +then there's a good chance that in a potential rule redex + ...f (g e)... +then 'f' or 'g' will inline before the rule can fire. Solution: add an +INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'. + +Note that this applies to all the free variables on the LHS, both the +main function and things in its arguments. + +We also check if there are Ids on the LHS that have competing RULES. +In the above example, suppose we had + {-# RULES "rule-for-g" forally. g [y] = ... #-} +Then "rule-for-f" and "rule-for-g" would compete. Better to add phase +control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes +active; or perhaps after "rule-for-g" has become inactive. This is checked +by 'competesWith' + +Class methods have a built-in RULE to select the method from the dictionary, +so you can't change the phase on this. That makes id very dubious to +match on class methods in RULE lhs's. See #10595. I'm not happy +about this. For example in Control.Arrow we have + +{-# RULES "compose/arr" forall f g . + (arr f) . (arr g) = arr (f . g) #-} + +and similar, which will elicit exactly these warnings, and risk never +firing. But it's not clear what to do instead. We could make the +class method rules inactive in phase 2, but that would delay when +subsequent transformations could fire. +-} + +{- +************************************************************************ +* * +* Magic definitions +* * +************************************************************************ + +Note [Patching magic definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to have access to defined Ids in pure contexts. Usually, we +simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids +in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make. + +However, it is sometimes *much* easier to define entities in Haskell, +even if we need pure access; note that wiring-in an Id requires all +entities used in its definition *also* to be wired in, transitively +and recursively. This can be a huge pain. The little trick +documented here allows us to have the best of both worlds. + +Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the +details. + +The trick is to + +* Define the known-key Id in a library module, with a stub definition, + unsafeCoerce# :: ..a suitable type signature.. + unsafeCoerce# = error "urk" + +* Magically over-write its RHS here in the desugarer, in + patchMagicDefns. This update can be done with full access to the + DsM monad, and hence, dsLookupGlobal. We thus do not have to wire in + all the entities used internally, a potentially big win. + + This step should not change the Name or type of the Id. + +Because an Id stores its unfolding directly (as opposed to in the second +component of a (Id, CoreExpr) pair), the patchMagicDefns function returns +a new Id to use. + +Here are the moving parts: + +- patchMagicDefns checks whether we're in a module with magic definitions; + if so, patch the magic definitions. If not, skip. + +- patchMagicDefn just looks up in an environment to find a magic defn and + patches it in. + +- magicDefns holds the magic definitions. + +- magicDefnsEnv allows for quick access to magicDefns. + +- magicDefnModules, built also from magicDefns, contains the modules that + need careful attention. + +Note [Wiring in unsafeCoerce#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want (Haskell) + + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b + unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of + UnsafeRefl -> case unsafeEqualityProof @a @b of + UnsafeRefl -> x + +or (Core) + + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b + unsafeCoerce# = \ @r1 @r2 @a @b (x :: a). + case unsafeEqualityProof @RuntimeRep @r1 @r2 of + UnsafeRefl (co1 :: r1 ~# r2) -> + case unsafeEqualityProof @(TYPE r2) @(a |> TYPE co1) @b of + UnsafeRefl (co2 :: (a |> TYPE co1) ~# b) -> + (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2) + +It looks like we can write this in Haskell directly, but we can't: +the levity polymorphism checks defeat us. Note that `x` is a levity- +polymorphic variable. So we must wire it in with a compulsory +unfolding, like other levity-polymorphic primops. + +The challenge is that UnsafeEquality is a GADT, and wiring in a GADT +is *hard*: it has a worker separate from its wrapper, with all manner +of complications. (Simon and Richard tried to do this. We nearly wept.) + +The solution is documented in Note [Patching magic definitions]. We now +simply look up the UnsafeEquality GADT in the environment, leaving us +only to wire in unsafeCoerce# directly. + +Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy +-} + + +-- Postcondition: the returned Ids are in one-to-one correspondence as the +-- input Ids; each returned Id has the same type as the passed-in Id. +-- See Note [Patching magic definitions] +patchMagicDefns :: OrdList (Id,CoreExpr) + -> DsM (OrdList (Id,CoreExpr)) +patchMagicDefns pairs + -- optimization: check whether we're in a magic module before looking + -- at all the ids + = do { this_mod <- getModule + ; if this_mod `elemModuleSet` magicDefnModules + then traverse patchMagicDefn pairs + else return pairs } + +patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr) +patchMagicDefn orig_pair@(orig_id, orig_rhs) + | Just mk_magic_pair <- lookupNameEnv magicDefnsEnv (getName orig_id) + = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs + + -- Patching should not change the Name or the type of the Id + ; MASSERT( getUnique magic_id == getUnique orig_id ) + ; MASSERT( varType magic_id `eqType` varType orig_id ) + + ; return magic_pair } + | otherwise + = return orig_pair + +magicDefns :: [(Name, Id -> CoreExpr -- old Id and RHS + -> DsM (Id, CoreExpr) -- new Id and RHS + )] +magicDefns = [ (unsafeCoercePrimName, mkUnsafeCoercePrimPair) ] + +magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr)) +magicDefnsEnv = mkNameEnv magicDefns + +magicDefnModules :: ModuleSet +magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns + +mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr) +-- See Note [Wiring in unsafeCoerce#] for the defn we are creating here +mkUnsafeCoercePrimPair _old_id old_expr + = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName + ; unsafe_equality_tc <- dsLookupTyCon unsafeEqualityTyConName + + ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc + + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar + , x ] $ + mkSingleAltCase scrut1 + (mkWildValBinder Many scrut1_ty) + (DataAlt unsafe_refl_data_con) + [rr_cv] $ + mkSingleAltCase scrut2 + (mkWildValBinder Many scrut2_ty) + (DataAlt unsafe_refl_data_con) + [ab_cv] $ + Var x `mkCast` x_co + + [x, rr_cv, ab_cv] = mkTemplateLocals + [ openAlphaTy -- x :: a + , rr_cv_ty -- rr_cv :: r1 ~# r2 + , ab_cv_ty -- ab_cv :: (alpha |> alpha_co ~# beta) + ] + + -- Returns (scrutinee, scrutinee type, type of covar in AltCon) + unsafe_equality k a b + = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a] + , mkTyConApp unsafe_equality_tc [k,b,a] + , mkHeteroPrimEqPred k k a b + ) + -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to + -- carefully swap the arguments above + + (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy + runtimeRep1Ty + runtimeRep2Ty + (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeRep2Ty) + (openAlphaTy `mkCastTy` alpha_co) + openBetaTy + + -- alpha_co :: TYPE r1 ~# TYPE r2 + -- alpha_co = TYPE rr_cv + alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv] + + -- x_co :: alpha ~R# beta + x_co = mkGReflCo Representational openAlphaTy (MCo alpha_co) `mkTransCo` + mkSubCo (mkCoVarCo ab_cv) + + + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar ] $ + mkVisFunTyMany openAlphaTy openBetaTy + + id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info + ; return (id, old_expr) } + + where diff --git a/GHC/HsToCore/Arrows.hs b/GHC/HsToCore/Arrows.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Arrows.hs @@ -0,0 +1,1284 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring arrow commands +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Arrows ( dsProcExpr ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.HsToCore.Match +import GHC.HsToCore.Utils +import GHC.HsToCore.Monad + +import GHC.Hs hiding (collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectLStmtBinders, + collectStmtBinders ) +import GHC.Tc.Utils.Zonk +import qualified GHC.Hs.Utils as HsUtils + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types (newtypes etc), and sometimes not +-- So WATCH OUT; check each use of split*Ty functions. +-- Sigh. This is a pain. + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, + dsSyntaxExpr ) + +import GHC.Tc.Utils.TcType +import GHC.Core.Type( splitPiTy ) +import GHC.Core.Multiplicity +import GHC.Tc.Types.Evidence +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Make +import GHC.HsToCore.Binds (dsHsWrapper) + +import GHC.Types.Id +import GHC.Core.ConLike +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Builtin.Names +import GHC.Utils.Outputable +import GHC.Types.Var.Set +import GHC.Types.SrcLoc +import GHC.Data.List.SetOps( assocMaybe ) +import Data.List +import GHC.Utils.Misc +import GHC.Types.Unique.DSet + +data DsCmdEnv = DsCmdEnv { + arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr + } + +mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) +-- See Note [CmdSyntaxTable] in GHC.Hs.Expr +mkCmdEnv tc_meths + = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + + -- NB: Some of these lookups might fail, but that's OK if the + -- symbol is never used. That's why we use Maybe first and then + -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 + ; let the_arr_id = assocMaybe prs arrAName + the_compose_id = assocMaybe prs composeAName + the_first_id = assocMaybe prs firstAName + the_app_id = assocMaybe prs appAName + the_choice_id = assocMaybe prs choiceAName + the_loop_id = assocMaybe prs loopAName + + -- used as an argument in, e.g., do_premap + ; check_lev_poly 3 the_arr_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 5 the_compose_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 4 the_first_id + + -- the result of the_app_id is used as an argument in, e.g., + -- dsCmd/HsCmdArrApp/HsHigherOrderApp + ; check_lev_poly 2 the_app_id + + -- used as an argument in, e.g., HsCmdIf + ; check_lev_poly 5 the_choice_id + + -- used as an argument in, e.g., RecStmt + ; check_lev_poly 4 the_loop_id + + ; return (meth_binds, DsCmdEnv { + arr_id = Var (unmaybe the_arr_id arrAName), + compose_id = Var (unmaybe the_compose_id composeAName), + first_id = Var (unmaybe the_first_id firstAName), + app_id = Var (unmaybe the_app_id appAName), + choice_id = Var (unmaybe the_choice_id choiceAName), + loop_id = Var (unmaybe the_loop_id loopAName) + }) } + where + mk_bind (std_name, expr) + = do { rhs <- dsExpr expr + ; id <- newSysLocalDs Many (exprType rhs) + -- no check needed; these are functions + ; return (NonRec id rhs, (std_name, id)) } + + unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) + unmaybe (Just id) _ = id + + -- returns the result type of a pi-type (that is, a forall or a function) + -- Note that this result type may be ill-scoped. + res_type :: Type -> Type + res_type ty = res_ty + where + (_, res_ty) = splitPiTy ty + + check_lev_poly :: Int -- arity + -> Maybe Id -> DsM () + check_lev_poly _ Nothing = return () + check_lev_poly arity (Just id) + = dsNoLevPoly (nTimes arity res_type (idType id)) + (text "In the result of the function" <+> quotes (ppr id)) + + +-- arr :: forall b c. (b -> c) -> a b c +do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr +do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] + +-- (>>>) :: forall b c d. a b c -> a c d -> a b d +do_compose :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_compose ids b_ty c_ty d_ty f g + = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g] + +-- first :: forall b c d. a b c -> a (b,d) (c,d) +do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_first ids b_ty c_ty d_ty f + = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f] + +-- app :: forall b c. a (a b c, b) c +do_app :: DsCmdEnv -> Type -> Type -> CoreExpr +do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty] + +-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d +-- note the swapping of d and c +do_choice :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_choice ids b_ty c_ty d_ty f g + = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g] + +-- loop :: forall b d c. a (b,d) (c,d) -> a b c +-- note the swapping of d and c +do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_loop ids b_ty c_ty d_ty f + = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f] + +-- premap :: forall b c d. (b -> c) -> a c d -> a b d +-- premap f g = arr f >>> g +do_premap :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_premap ids b_ty c_ty d_ty f g + = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g + +mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr +mkFailExpr ctxt ty + = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a +mkFstExpr :: Type -> Type -> DsM CoreExpr +mkFstExpr a_ty b_ty = do + a_var <- newSysLocalDs Many a_ty + b_var <- newSysLocalDs Many b_ty + pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var a_var))) + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b +mkSndExpr :: Type -> Type -> DsM CoreExpr +mkSndExpr a_ty b_ty = do + a_var <- newSysLocalDs Many a_ty + b_var <- newSysLocalDs Many b_ty + pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var b_var))) + +{- +Build case analysis of a tuple. This cannot be done in the DsM monad, +because the list of variables is typically not yet defined. +-} + +-- coreCaseTuple [u1..] v [x1..xn] body +-- = case v of v { (x1, .., xn) -> body } +-- But the matching may be nested if the tuple is very big + +coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr +coreCaseTuple uniqs scrut_var vars body + = mkTupleCase uniqs vars body scrut_var (Var scrut_var) + +coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr +coreCasePair scrut_var var1 var2 body + = Case (Var scrut_var) scrut_var (exprType body) + [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] + +mkCorePairTy :: Type -> Type -> Type +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] + +mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr +mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] + +mkCoreUnitExpr :: CoreExpr +mkCoreUnitExpr = mkCoreTup [] + +{- +The input is divided into a local environment, which is a flat tuple +(unless it's too big), and a stack, which is a right-nested pair. +In general, the input has the form + + ((x1,...,xn), (s1,...(sk,())...)) + +where xi are the environment values, and si the ones on the stack, +with s1 being the "top", the first one to be matched with a lambda. +-} + +envStackType :: [Id] -> Type -> Type +envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty + +-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) +splitTypeAt :: Int -> Type -> ([Type], Type) +splitTypeAt n ty + | n == 0 = ([], ty) + | otherwise = case tcTyConAppArgs ty of + [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) + _ -> pprPanic "splitTypeAt" (ppr ty) + +---------------------------------------------- +-- buildEnvStack +-- +-- ((x1,...,xn),stk) + +buildEnvStack :: [Id] -> Id -> CoreExpr +buildEnvStack env_ids stack_id + = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) + +---------------------------------------------- +-- matchEnvStack +-- +-- \ ((x1,...,xn),stk) -> body +-- => +-- \ pair -> +-- case pair of (tup,stk) -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnvStack :: [Id] -- x1..xn + -> Id -- stk + -> CoreExpr -- e + -> DsM CoreExpr +matchEnvStack env_ids stack_id body = do + uniqs <- newUniqueSupply + tup_var <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) + let match_env = coreCaseTuple uniqs tup_var env_ids body + pair_id <- newSysLocalDs Many (mkCorePairTy (idType tup_var) (idType stack_id)) + return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) + +---------------------------------------------- +-- matchEnv +-- +-- \ (x1,...,xn) -> body +-- => +-- \ tup -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnv :: [Id] -- x1..xn + -> CoreExpr -- e + -> DsM CoreExpr +matchEnv env_ids body = do + uniqs <- newUniqueSupply + tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) + return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) + +---------------------------------------------- +-- matchVarStack +-- +-- case (x1, ...(xn, s)...) -> e +-- => +-- case z0 of (x1,z1) -> +-- case zn-1 of (xn,s) -> +-- e +matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) +matchVarStack [] stack_id body = return (stack_id, body) +matchVarStack (param_id:param_ids) stack_id body = do + (tail_id, tail_code) <- matchVarStack param_ids stack_id body + pair_id <- newSysLocalDs Many (mkCorePairTy (idType param_id) (idType tail_id)) + return (pair_id, coreCasePair pair_id param_id tail_id tail_code) + +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc +mkHsEnvStackExpr env_ids stack_id + = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] + +-- Translation of arrow abstraction + +-- D; xs |-a c : () --> t' ---> c' +-- -------------------------- +-- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' +-- +-- where (xs) is the tuple of variables bound by p + +dsProcExpr + :: LPat GhcTc + -> LHsCmdTop GhcTc + -> DsM CoreExpr +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + let locals = mkVarSet (collectPatBinders pat) + (core_cmd, _free_vars, env_ids) + <- dsfixCmd meth_ids locals unitTy cmd_ty cmd + let env_ty = mkBigCoreVarTupTy env_ids + let env_stk_ty = mkCorePairTy env_ty unitTy + let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr + fail_expr <- mkFailExpr ProcExpr env_stk_ty + var <- selectSimpleMatchVarL Many pat + match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr + let pat_ty = hsLPatType pat + let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty + (Lam var match_code) + core_cmd + return (mkLets meth_binds proc_code) + +{- +Translation of a command judgement of the form + + D; xs |-a c : stk --> t + +to an expression e such that + + D |- e :: a (xs, stk) t +-} + +dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id] + -> DsM (CoreExpr, DIdSet) +dsLCmd ids local_vars stk_ty res_ty cmd env_ids + = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids + +dsCmd :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> HsCmd GhcTc -- command to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +-- D |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ----------------------------- +-- D; xs |-a fun -< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> arg) fun + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + core_arrow <- dsLExprNoLP arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalDs Many stack_ty + core_make_arg <- matchEnvStack env_ids stack_id core_arg + return (do_premap ids + (envStackType env_ids stack_ty) + arg_ty + res_ty + core_make_arg + core_arrow, + exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars) + +-- D, xs |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ------------------------------ +-- D; xs |-a fun -<< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + + core_arrow <- dsLExpr arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalDs Many stack_ty + core_make_pair <- matchEnvStack env_ids stack_id + (mkCorePairExpr core_arrow core_arg) + + return (do_premap ids + (envStackType env_ids stack_ty) + (mkCorePairTy arrow_ty arg_ty) + res_ty + core_make_pair + (do_app ids arg_ty res_ty), + (exprsFreeIdsDSet [core_arrow, core_arg]) + `uniqDSetIntersectUniqSet` local_vars) + +-- D; ys |-a cmd : (t,stk) --> t' +-- D, xs |- exp :: t +-- ------------------------ +-- D; xs |-a cmd exp : stk --> t' +-- +-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd + +dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do + core_arg <- dsLExpr arg + let + arg_ty = exprType core_arg + stack_ty' = mkCorePairTy arg_ty stack_ty + (core_cmd, free_vars, env_ids') + <- dsfixCmd ids local_vars stack_ty' res_ty cmd + stack_id <- newSysLocalDs Many stack_ty + arg_id <- newSysLocalDsNoLP Many arg_ty + -- push the argument expression onto the stack + let + stack' = mkCorePairExpr (Var arg_id) (Var stack_id) + core_body = bindNonRec arg_id core_arg + (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') + + -- match the environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_body + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty') + res_ty + core_map + core_cmd, + free_vars `unionDVarSet` + (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) + +dsCmd ids local_vars stack_ty res_ty + (HsCmdLam _ (MG { mg_alts + = (L _ [L _ (Match { m_pats = pats + , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) + env_ids + = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids + +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids + = dsLCmd ids local_vars stack_ty res_ty cmd env_ids + +-- D, xs |- e :: Bool +-- D; xs1 |-a c1 : stk --> t +-- D; xs2 |-a c2 : stk --> t +-- ---------------------------------------- +-- D; xs |-a if e then c1 else c2 : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> +-- if e then Left ((xs1),stk) else Right ((xs2),stk)) +-- (c1 ||| c2) + +dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) + env_ids = do + core_cond <- dsLExpr cond + (core_then, fvs_then, then_ids) + <- dsfixCmd ids local_vars stack_ty res_ty then_cmd + (core_else, fvs_else, else_ids) + <- dsfixCmd ids local_vars stack_ty res_ty else_cmd + stack_id <- newSysLocalDs Many stack_ty + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + + let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1,Type ty2, e] + mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e] + + in_ty = envStackType env_ids stack_ty + then_ty = envStackType then_ids stack_ty + else_ty = envStackType else_ids stack_ty + sum_ty = mkTyConApp either_con [then_ty, else_ty] + fvs_cond = exprFreeIdsDSet core_cond + `uniqDSetIntersectUniqSet` local_vars + + core_left = mk_left_expr then_ty else_ty + (buildEnvStack then_ids stack_id) + core_right = mk_right_expr then_ty else_ty + (buildEnvStack else_ids stack_id) + + core_if <- case mb_fun of + NoSyntaxExprTc -> matchEnvStack env_ids stack_id $ + mkIfThenElse core_cond core_left core_right + _ -> do { fun_apps <- dsSyntaxExpr mb_fun + [core_cond, core_left, core_right] + ; matchEnvStack env_ids stack_id fun_apps } + + return (do_premap ids in_ty sum_ty res_ty + core_if + (do_choice ids then_ty else_ty res_ty core_then core_else), + fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else) + +{- +Case commands are treated in much the same way as if commands +(see above) except that there are more alternatives. For example + + case e of { p1 -> c1; p2 -> c2; p3 -> c3 } + +is translated to + + premap (\ ((xs)*ts) -> case e of + p1 -> (Left (Left (xs1)*ts)) + p2 -> Left ((Right (xs2)*ts)) + p3 -> Right ((xs3)*ts)) + ((c1 ||| c2) ||| c3) + +The idea is to extract the commands from the case, build a balanced tree +of choices, and replace the commands with expressions that build tagged +tuples, obtaining a case expression that can be desugared normally. +To build all this, we use triples describing segments of the list of +case bodies, containing the following fields: + * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put + into the case replacing the commands + * a sum type that is the common type of these expressions, and also the + input type of the arrow + * a CoreExpr for an arrow built by combining the translated command + bodies with |||. +-} + +dsCmd ids local_vars stack_ty res_ty + (HsCmdCase _ exp (MG { mg_alts = L l matches + , mg_ext = MatchGroupTc arg_tys _ + , mg_origin = origin })) + env_ids = do + stack_id <- newSysLocalDs Many stack_ty + + -- Extract and desugar the leaf commands in the case, building tuple + -- expressions that will (after tagging) replace these leaves + + let + leaves = concatMap leavesMatch matches + make_branch (leaf, bound_vars) = do + (core_leaf, _fvs, leaf_ids) + <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty + res_ty leaf + return ([mkHsEnvStackExpr leaf_ids stack_id], + envStackType leaf_ids stack_ty, + core_leaf) + + branches <- mapM make_branch leaves + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + let + left_id = HsConLikeOut noExtField (RealDataCon left_con) + right_id = HsConLikeOut noExtField (RealDataCon right_con) + left_expr ty1 ty2 e = noLoc $ HsApp noExtField + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp noExtField + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e + + -- Prefix each tuple with a distinct series of Left's and Right's, + -- in a balanced way, keeping track of the types. + + merge_branches (builds1, in_ty1, core_exp1) + (builds2, in_ty2, core_exp2) + = (map (left_expr in_ty1 in_ty2) builds1 ++ + map (right_expr in_ty1 in_ty2) builds2, + mkTyConApp either_con [in_ty1, in_ty2], + do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) + (leaves', sum_ty, core_choices) = foldb merge_branches branches + + -- Replace the commands in the case with these tagged tuples, + -- yielding a HsExpr Id we can feed to dsExpr. + + (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches + in_ty = envStackType env_ids stack_ty + + core_body <- dsExpr (HsCase noExtField exp + (MG { mg_alts = L l matches' + , mg_ext = MatchGroupTc arg_tys sum_ty + , mg_origin = origin })) + -- Note that we replace the HsCase result type by sum_ty, + -- which is the type of matches' + + core_matches <- matchEnvStack env_ids stack_id core_body + return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, + exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars) + +dsCmd ids local_vars stack_ty res_ty + (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do + arg_id <- newSysLocalDs arg_mult arg_ty + let case_cmd = noLoc $ HsCmdCase noExtField (nlHsVar arg_id) mg + dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids + +-- D; ys |-a cmd : stk --> t +-- ---------------------------------- +-- D; xs |-a let binds in cmd : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c + +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) + env_ids = do + let + defined_vars = mkVarSet (collectLocalBinders binds) + local_vars' = defined_vars `unionVarSet` local_vars + + (core_body, _free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty res_ty body + stack_id <- newSysLocalDs Many stack_ty + -- build a new environment, plus the stack, using the let bindings + core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) + -- match the old environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_binds + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty) + res_ty + core_map + core_body, + exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) + +-- D; xs |-a ss : t +-- ---------------------------------- +-- D; xs |-a do { ss } : () --> t +-- +-- ---> premap (\ (env,stk) -> env) c + +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty + (L loc stmts)) + env_ids = do + putSrcSpanDs loc $ + dsNoLevPoly stmts_ty + (text "In the do-command:" <+> ppr do_block) + (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids + let env_ty = mkBigCoreVarTupTy env_ids + core_fst <- mkFstExpr env_ty stack_ty + return (do_premap ids + (mkCorePairTy env_ty stack_ty) + env_ty + res_ty + core_fst + core_stmts, + env_ids') + +-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t +-- D; xs |-a ci :: stki --> ti +-- ----------------------------------- +-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn + +dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do + let env_ty = mkBigCoreVarTupTy env_ids + core_op <- dsLExpr op + (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args + return (mkApps (App core_op (Type env_ty)) core_args, + unionDVarSets fv_sets) + +dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do + (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids + core_wrap <- dsHsWrapper wrap + return (core_wrap core_cmd, env_ids') + +dsCmd _ _ _ _ c _ = pprPanic "dsCmd" (ppr c) + +-- D; ys |-a c : stk --> t (ys <= xs) +-- --------------------- +-- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c + +dsTrimCmdArg + :: IdSet -- set of local vars available to this command + -> [Id] -- list of vars in the input to this command + -> LHsCmdTop GhcTc -- command argument to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free +dsTrimCmdArg local_vars env_ids + (L _ (HsCmdTop + (CmdTopTc stack_ty cmd_ty ids) cmd )) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + (core_cmd, free_vars, env_ids') + <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd + stack_id <- newSysLocalDs Many stack_ty + trim_code + <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) + let + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty + arg_code = if env_ids' == env_ids then core_cmd else + do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd + return (mkLets meth_binds arg_code, free_vars) + +-- Given D; xs |-a c : stk --> t, builds c with xs fed back. +-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) + +dsfixCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> LHsCmd GhcTc -- command to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- the same local vars as a list, fed back +dsfixCmd ids local_vars stk_ty cmd_ty cmd + = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty + (text "When desugaring the command:" <+> ppr cmd) + ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } + +-- Feed back the list of local variables actually used a command, +-- for use as the input tuple of the generated arrow. + +trimInput + :: ([Id] -> DsM (CoreExpr, DIdSet)) + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list, fed back to + -- the inner function to form the tuple of + -- inputs to the arrow. +trimInput build_arrow + = fixDs (\ ~(_,_,env_ids) -> do + (core_cmd, free_vars) <- build_arrow env_ids + return (core_cmd, free_vars, dVarSetElems free_vars)) + +-- Desugaring for both HsCmdLam and HsCmdLamCase. +-- +-- D; ys |-a cmd : stk t' +-- ----------------------------------------------- +-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' +-- +-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd +dsCmdLam :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> [LPat GhcTc] -- argument patterns to desugar + -> LHsCmd GhcTc -- body to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free +dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do + let pat_vars = mkVarSet (collectPatsBinders pats) + let local_vars' = pat_vars `unionVarSet` local_vars + (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty + (core_body, free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty' res_ty body + param_ids <- mapM (newSysLocalDsNoLP Many) pat_tys + stack_id' <- newSysLocalDs Many stack_ty' + + -- the expression is built from the inside out, so the actions + -- are presented in reverse order + + let -- build a new environment, plus what's left of the stack + core_expr = buildEnvStack env_ids' stack_id' + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty' + + fail_expr <- mkFailExpr LambdaExpr in_ty' + -- match the patterns against the parameters + match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr + fail_expr + -- match the parameters against the top of the old stack + (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code + -- match the old environment and stack against the input + select_code <- matchEnvStack env_ids stack_id param_code + return (do_premap ids in_ty in_ty' res_ty select_code core_body, + free_vars `uniqDSetMinusUniqSet` pat_vars) + +{- +Translation of command judgements of the form + + D |-a do { ss } : t +-} + +dsCmdDo :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> Type -- return type of the statement + -> [CmdLStmt GhcTc] -- statements to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +dsCmdDo _ _ _ [] _ = panic "dsCmdDo" + +-- D; xs |-a c : () --> t +-- -------------------------- +-- D; xs |-a do { c } : t +-- +-- ---> premap (\ (xs) -> ((xs), ())) c + +dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do + putSrcSpanDs loc $ dsNoLevPoly res_ty + (text "In the command:" <+> ppr body) + (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids + let env_ty = mkBigCoreVarTupTy env_ids + env_var <- newSysLocalDs Many env_ty + let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) + return (do_premap ids + env_ty + (mkCorePairTy env_ty unitTy) + res_ty + core_map + core_body, + env_ids') + +dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do + let bound_vars = mkVarSet (collectLStmtBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + res_ty + core_stmt + core_stmts, + fv_stmt) + +{- +A statement maps one local environment to another, and is represented +as an arrow from one tuple type to another. A statement sequence is +translated to a composition of such arrows. +-} + +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id] + -> DsM (CoreExpr, DIdSet) +dsCmdLStmt ids local_vars out_ids cmd env_ids + = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids + +dsCmdStmt + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- list of vars in the output of this statement + -> CmdStmt GhcTc -- statement to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' +-- ------------------------------ +-- D; xs |-a do { c; ss } : t' +-- +-- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) +-- (first c >>> arr snd) >>> ss + +dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup out_ids)) + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + out_ty = mkBigCoreVarTupTy out_ids + before_c_ty = mkCorePairTy in_ty1 out_ty + after_c_ty = mkCorePairTy c_ty out_ty + dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here + snd_fn <- mkSndExpr c_ty out_ty + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 c_ty out_ty core_cmd) $ + do_arr ids after_c_ty out_ty snd_fn, + extendDVarSetList fv_cmd out_ids) + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) +-- ----------------------------------- +-- D; xs |-a do { p <- c; ss } : t' +-- +-- ---> premap (\ (xs) -> (((xs1),()),(xs2))) +-- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss +-- +-- It would be simpler and more consistent to do this using second, +-- but that's likely to be defined in terms of first. + +dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do + let pat_ty = hsLPatType pat + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd + let pat_vars = mkVarSet (collectPatBinders pat) + let + env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids + env_ty2 = mkBigCoreVarTupTy env_ids2 + + -- multiplexing function + -- \ (xs) -> (((xs1),()),(xs2)) + + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup env_ids2)) + + -- projection function + -- \ (p, (xs2)) -> (zs) + + env_id <- newSysLocalDs Many env_ty2 + uniqs <- newUniqueSupply + let + after_c_ty = mkCorePairTy pat_ty env_ty2 + out_ty = mkBigCoreVarTupTy out_ids + body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) + + fail_expr <- mkFailExpr (StmtCtxt (DoExpr Nothing)) out_ty + pat_id <- selectSimpleMatchVarL Many pat + match_code + <- matchSimply (Var pat_id) (StmtCtxt (DoExpr Nothing)) pat body_expr fail_expr + pair_id <- newSysLocalDs Many after_c_ty + let + proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) + + -- put it all together + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + in_ty2 = mkBigCoreVarTupTy env_ids2 + before_c_ty = mkCorePairTy in_ty1 in_ty2 + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ + do_arr ids after_c_ty out_ty proj_expr, + fv_cmd `unionDVarSet` (mkDVarSet out_ids + `uniqDSetMinusUniqSet` pat_vars)) + +-- D; xs' |-a do { ss } : t +-- -------------------------------------- +-- D; xs |-a do { let binds; ss } : t +-- +-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss + +dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do + -- build a new environment using the let bindings + core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) + -- match the old environment against the input + core_map <- matchEnv env_ids core_binds + return (do_arr ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy out_ids) + core_map, + exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) + +-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... +-- D; xs' |-a do { ss' } : t +-- ------------------------------------ +-- D; xs |-a do { rec ss; ss' } : t +-- +-- xs1 = xs' /\ defs(ss) +-- xs2 = xs' - defs(ss) +-- ys1 = ys - defs(ss) +-- ys2 = ys /\ defs(ss) +-- +-- ---> arr (\(xs) -> ((ys1),(xs2))) >>> +-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> +-- arr (\((xs1),(xs2)) -> (xs')) >>> ss' + +dsCmdStmt ids local_vars out_ids + (RecStmt { recS_stmts = stmts + , recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_ext = RecStmtTc { recS_later_rets = later_rets + , recS_rec_rets = rec_rets } }) + env_ids = do + let + later_ids_set = mkVarSet later_ids + env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids + env2_id_set = mkDVarSet env2_ids + env2_ty = mkBigCoreVarTupTy env2_ids + + -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) + + uniqs <- newUniqueSupply + env2_id <- newSysLocalDs Many env2_ty + let + later_ty = mkBigCoreVarTupTy later_ids + post_pair_ty = mkCorePairTy later_ty env2_ty + post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) + + post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body + + --- loop (...) + + (core_loop, env1_id_set, env1_ids) + <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets + + -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) + + let + env1_ty = mkBigCoreVarTupTy env1_ids + pre_pair_ty = mkCorePairTy env1_ty env2_ty + pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) + (mkBigCoreVarTup env2_ids) + + pre_loop_fn <- matchEnv env_ids pre_loop_body + + -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn + + let + env_ty = mkBigCoreVarTupTy env_ids + out_ty = mkBigCoreVarTupTy out_ids + core_body = do_premap ids env_ty pre_pair_ty out_ty + pre_loop_fn + (do_compose ids pre_pair_ty post_pair_ty out_ty + (do_first ids env1_ty later_ty env2_ty + core_loop) + (do_arr ids post_pair_ty out_ty + post_loop_fn)) + + return (core_body, env1_id_set `unionDVarSet` env2_id_set) + +dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) + +-- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) +-- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>> + +dsRecCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd + -> [Id] -- list of vars defined here and used later + -> [HsExpr GhcTc] -- expressions corresponding to later_ids + -> [Id] -- list of vars fed back through the loop + -> [HsExpr GhcTc] -- expressions corresponding to rec_ids + -> DsM (CoreExpr, -- desugared statement + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do + let + later_id_set = mkVarSet later_ids + rec_id_set = mkVarSet rec_ids + local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars + + -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) + + core_later_rets <- mapM dsExpr later_rets + core_rec_rets <- mapM dsExpr rec_rets + let + -- possibly polymorphic version of vars of later_ids and rec_ids + out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets) + out_ty = mkBigCoreVarTupTy out_ids + + later_tuple = mkBigCoreTup core_later_rets + later_ty = mkBigCoreVarTupTy later_ids + + rec_tuple = mkBigCoreTup core_rec_rets + rec_ty = mkBigCoreVarTupTy rec_ids + + out_pair = mkCorePairExpr later_tuple rec_tuple + out_pair_ty = mkCorePairTy later_ty rec_ty + + mk_pair_fn <- matchEnv out_ids out_pair + + -- ss + + (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts + + -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) + + rec_id <- newSysLocalDs Many rec_ty + let + env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set + env1_ids = dVarSetElems env1_id_set + env1_ty = mkBigCoreVarTupTy env1_ids + in_pair_ty = mkCorePairTy env1_ty rec_ty + core_body = mkBigCoreTup (map selectVar env_ids) + where + selectVar v + | v `elemVarSet` rec_id_set + = mkTupleSelector rec_ids v rec_id (Var rec_id) + | otherwise = Var v + + squash_pair_fn <- matchEnvStack env1_ids rec_id core_body + + -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) + + let + env_ty = mkBigCoreVarTupTy env_ids + core_loop = do_loop ids env1_ty later_ty rec_ty + (do_premap ids in_pair_ty env_ty out_pair_ty + squash_pair_fn + (do_compose ids env_ty out_ty out_pair_ty + core_stmts + (do_arr ids out_ty out_pair_ty mk_pair_fn))) + + return (core_loop, env1_id_set, env1_ids) + +{- +A sequence of statements (as in a rec) is desugared to an arrow between +two environments (no stack) +-} + +dsfixCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt GhcTc] -- statements to desugar + -> DsM (CoreExpr, -- desugared expression + DIdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsfixCmdStmts ids local_vars out_ids stmts + = trimInput (dsCmdStmts ids local_vars out_ids stmts) + -- TODO: Add levity polymorphism check for the resulting expression. + -- But I (Richard E.) don't know enough about arrows to do so. + +dsCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt GhcTc] -- statements to desugar + -> [Id] -- list of vars in the input to these statements + -> DsM (CoreExpr, -- desugared expression + DIdSet) -- subset of local vars that occur free + +dsCmdStmts ids local_vars out_ids [stmt] env_ids + = dsCmdLStmt ids local_vars out_ids stmt env_ids + +dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do + let bound_vars = mkVarSet (collectLStmtBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + (mkBigCoreVarTupTy out_ids) + core_stmt + core_stmts, + fv_stmt) + +dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" + +-- Match a list of expressions against a list of patterns, left-to-right. + +matchSimplys :: [CoreExpr] -- Scrutinees + -> HsMatchContext GhcRn -- Match kind + -> [LPat GhcTc] -- Patterns they should match + -> CoreExpr -- Return this if they all match + -> CoreExpr -- Return this if they don't + -> DsM CoreExpr +matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr +matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do + match_code <- matchSimplys exps ctxt pats result_expr fail_expr + matchSimply exp ctxt pat match_code fail_expr +matchSimplys _ _ _ _ _ = panic "matchSimplys" + +-- List of leaf expressions, with set of variables bound in each + +leavesMatch :: LMatch GhcTc (Located (body GhcTc)) + -> [(Located (body GhcTc), IdSet)] +leavesMatch (L _ (Match { m_pats = pats + , m_grhss = GRHSs _ grhss (L _ binds) })) + = let + defined_vars = mkVarSet (collectPatsBinders pats) + `unionVarSet` + mkVarSet (collectLocalBinders binds) + in + [(body, + mkVarSet (collectLStmtsBinders stmts) + `unionVarSet` defined_vars) + | L _ (GRHS _ stmts body) <- grhss] + +-- Replace the leaf commands in a match + +replaceLeavesMatch + :: Type -- new result type + -> [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LMatch GhcTc (Located (body' GhcTc))) -- updated match +replaceLeavesMatch _res_ty leaves + (L loc + match@(Match { m_grhss = GRHSs x grhss binds })) + = let + (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss + in + (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) + +replaceLeavesGRHS + :: [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) + = (leaves, L loc (GRHS x stmts leaf)) +replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" + +-- Balanced fold of a non-empty list. + +foldb :: (a -> a -> a) -> [a] -> a +foldb _ [] = error "foldb of empty list" +foldb _ [x] = x +foldb f xs = foldb f (fold_pairs xs) + where + fold_pairs [] = [] + fold_pairs [x] = [x] + fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs + +{- +Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following functions to collect value variables from patterns are +copied from GHC.Hs.Utils, with one change: we also collect the dictionary +bindings (cpt_binds) from ConPatOut. We need them for cases like + +h :: Arrow a => Int -> a (Int,Int) Int +h x = proc (y,z) -> case compare x y of + GT -> returnA -< z+x + +The type checker turns the case into + + case compare x y of + GT { p77 = plusInt } -> returnA -< p77 z x + +Here p77 is a local binding for the (+) operation. + +See comments in GHC.Hs.Utils for why the other version does not include +these bindings. +-} + +collectPatBinders :: LPat GhcTc -> [Id] +collectPatBinders pat = collectl pat [] + +collectPatsBinders :: [LPat GhcTc] -> [Id] +collectPatsBinders pats = foldr collectl [] pats + +--------------------- +collectl :: LPat GhcTc -> [Id] -> [Id] +-- See Note [Dictionary binders in ConPatOut] +collectl (L _ pat) bndrs + = go pat + where + go (VarPat _ (L _ var)) = var : bndrs + go (WildPat _) = bndrs + go (LazyPat _ pat) = collectl pat bndrs + go (BangPat _ pat) = collectl pat bndrs + go (AsPat _ (L _ a) pat) = a : collectl pat bndrs + go (ParPat _ pat) = collectl pat bndrs + + go (ListPat _ pats) = foldr collectl bndrs pats + go (TuplePat _ pats _) = foldr collectl bndrs pats + go (SumPat _ pat _ _) = collectl pat bndrs + + go (ConPat { pat_args = ps + , pat_con_ext = ConPatTc { cpt_binds = ds }}) = + collectEvBinders ds + ++ foldr collectl bndrs (hsConPatArgs ps) + go (LitPat _ _) = bndrs + go (NPat {}) = bndrs + go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs + + go (SigPat _ pat _) = collectl pat bndrs + go (XPat (CoPat _ pat _)) = collectl (noLoc pat) bndrs + go (ViewPat _ _ pat) = collectl pat bndrs + go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) + +collectEvBinders :: TcEvBinds -> [Id] +collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs +collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" + +add_ev_bndr :: EvBind -> [Id] -> [Id] +add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs + | otherwise = bs + -- A worry: what about coercion variable binders?? + +collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectLStmtBinders :: LStmt GhcTc body -> [Id] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt GhcTc body -> [Id] +collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids +collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/GHC/HsToCore/Binds.hs b/GHC/HsToCore/Binds.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Binds.hs @@ -0,0 +1,1331 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching bindings (HsBinds and MonoBinds) + +Handles @HsBinds@; those at the top level require different handling, +in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at +lower levels it is preserved with @let@/@letrec@s). +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Binds + ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec + , dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) +import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) + +import GHC.HsToCore.Monad +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.Utils +import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches ) + +import GHC.Hs -- lots of things +import GHC.Core -- lots of things +import GHC.Core.SimpleOpt ( simpleOptExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( etaExpand ) +import GHC.Core.Unfold +import GHC.Core.FVs +import GHC.Data.Graph.Directed +import GHC.Core.Predicate + +import GHC.Builtin.Names +import GHC.Core.TyCon +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Multiplicity +import GHC.Builtin.Types ( typeNatKind, typeSymbolKind ) +import GHC.Types.Id +import GHC.Types.Id.Make(proxyHashId) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Core.Rules +import GHC.Types.Var.Env +import GHC.Types.Var( EvVar ) +import GHC.Utils.Outputable +import GHC.Unit.Module +import GHC.Types.SrcLoc +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) +import GHC.Utils.Monad +import qualified GHC.LanguageExtensions as LangExt +import Control.Monad +import Data.List.NonEmpty ( nonEmpty ) + +{-********************************************************************** +* * + Desugaring a MonoBinds +* * +**********************************************************************-} + +-- | Desugar top level binds, strict binds are treated like normal +-- binds since there is no good time to force before first usage. +dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds binds + -- see Note [Strict binds checks] + | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) + = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds + ; mapBagM_ (top_level_err "strict bindings") bang_binds + ; return nilOL } + + | otherwise + = do { (force_vars, prs) <- dsLHsBinds binds + ; when debugIsOn $ + do { xstrict <- xoptM LangExt.Strict + ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) } + -- with -XStrict, even top-level vars are listed as force vars. + + ; return (toOL prs) } + + where + unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds + bang_binds = filterBag (isBangedHsBind . unLoc) binds + + top_level_err desc (L loc bind) + = putSrcSpanDs loc $ + errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") + 2 (ppr bind)) + + +-- | Desugar all other kind of bindings, Ids of strict binds are returned to +-- later be forced in the binding group body, see Note [Desugar Strict binds] +dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds binds + = do { ds_bs <- mapBagM dsLHsBind binds + ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) + id ([], []) ds_bs) } + +------------------------ +dsLHsBind :: LHsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBind (L loc bind) = do dflags <- getDynFlags + putSrcSpanDs loc $ dsHsBind dflags bind + +-- | Desugar a single binding (or group of recursive binds). +dsHsBind :: DynFlags + -> HsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) + -- ^ The Ids of strict binds, to be forced in the body of the + -- binding group see Note [Desugar Strict binds] and all + -- bindings and their desugared right hand sides. + +dsHsBind dflags (VarBind { var_id = var + , var_rhs = expr }) + = do { core_expr <- dsLExpr expr + -- Dictionary bindings are always VarBinds, + -- so we only need do this here + ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr + force_var = if xopt LangExt.Strict dflags + then [id] + else [] + ; return (force_var, [core_bind]) } + +dsHsBind dflags b@(FunBind { fun_id = L loc fun + , fun_matches = matches + , fun_ext = co_fn + , fun_tick = tick }) + = do { (args, body) <- addTyCsDs FromSource (hsWrapDictBinders co_fn) $ + -- FromSource might not be accurate (we don't have any + -- origin annotations for things in this module), but at + -- worst we do superfluous calls to the pattern match + -- oracle. + -- addTyCsDs: Add type evidence to the refinement type + -- predicate of the coverage checker + -- See Note [Type and Term Equality Propagation] in "GHC.HsToCore.PmCheck" + matchWrapper + (mkPrefixFunRhs (L loc (idName fun))) + Nothing matches + + ; core_wrap <- dsHsWrapper co_fn + ; let body' = mkOptTickBox tick body + rhs = core_wrap (mkLams args body') + core_binds@(id,_) = makeCorePair dflags fun False 0 rhs + force_var + -- Bindings are strict when -XStrict is enabled + | xopt LangExt.Strict dflags + , matchGroupArity matches == 0 -- no need to force lambdas + = [id] + | isBangedHsBind b + = [id] + | otherwise + = [] + ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) + -- , ppr (mg_alts matches) + -- , ppr args, ppr core_binds, ppr body']) $ + return (force_var, [core_binds]) } + +dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc _ ty + , pat_ticks = (rhs_tick, var_ticks) }) + = do { rhss_deltas <- checkGuardMatches PatBindGuards grhss + ; body_expr <- dsGuarded grhss ty (nonEmpty rhss_deltas) + ; let body' = mkOptTickBox rhs_tick body_expr + pat' = decideBangHood dflags pat + ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' + -- We silently ignore inline pragmas; no makeCorePair + -- Not so cool, but really doesn't matter + ; let force_var' = if isBangedLPat pat' + then [force_var] + else [] + ; return (force_var', sel_binds) } + +dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds, abs_sig = has_sig }) + = do { ds_binds <- addTyCsDs FromSource (listToBag dicts) $ + dsLHsBinds binds + -- addTyCsDs: push type constraints deeper + -- for inner pattern match check + -- See Check, Note [Type and Term Equality Propagation] + + ; ds_ev_binds <- dsTcEvBinds_s ev_binds + + -- dsAbsBinds does the hard work + ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } + +dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" + +----------------------- +dsAbsBinds :: DynFlags + -> [TyVar] -> [EvVar] -> [ABExport GhcTc] + -> [CoreBind] -- Desugared evidence bindings + -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings + -> Bool -- Single binding with signature + -> DsM ([Id], [(Id,CoreExpr)]) + +dsAbsBinds dflags tyvars dicts exports + ds_ev_binds (force_vars, bind_prs) has_sig + + -- A very important common case: one exported variable + -- Non-recursive bindings come through this way + -- So do self-recursive bindings + | [export] <- exports + , ABE { abe_poly = global_id, abe_mono = local_id + , abe_wrap = wrap, abe_prags = prags } <- export + , Just force_vars' <- case force_vars of + [] -> Just [] + [v] | v == local_id -> Just [global_id] + _ -> Nothing + -- If there is a variable to force, it's just the + -- single variable we are binding here + = do { core_wrap <- dsHsWrapper wrap -- Usually the identity + + ; let rhs = core_wrap $ + mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + body + + body | has_sig + , [(_, lrhs)] <- bind_prs + = lrhs + | otherwise + = mkLetRec bind_prs (Var local_id) + + ; (spec_binds, rules) <- dsSpecs rhs prags + + ; let global_id' = addIdSpecialisations global_id rules + main_bind = makeCorePair dflags global_id' + (isDefaultMethod prags) + (dictArity dicts) rhs + + ; return (force_vars', main_bind : fromOL spec_binds) } + + -- Another common case: no tyvars, no dicts + -- In this case we can have a much simpler desugaring + | null tyvars, null dicts + + = do { let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local + , abe_prags = prags }) + = do { core_wrap <- dsHsWrapper wrap + ; return (makeCorePair dflags global + (isDefaultMethod prags) + 0 (core_wrap (Var local))) } + ; main_binds <- mapM mk_bind exports + + ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } + + -- The general case + -- See Note [Desugaring AbsBinds] + | otherwise + = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs + | (lcl_id, rhs) <- bind_prs ] + -- Monomorphic recursion possible, hence Rec + new_force_vars = get_new_force_vars force_vars + locals = map abe_mono exports + all_locals = locals ++ new_force_vars + tup_expr = mkBigCoreVarTup all_locals + tup_ty = exprType tup_expr + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + mkLet core_bind $ + tup_expr + + ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs) + + -- Find corresponding global or make up a new one: sometimes + -- we need to make new export to desugar strict binds, see + -- Note [Desugar Strict binds] + ; (exported_force_vars, extra_exports) <- get_exports force_vars + + ; let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local, abe_prags = spec_prags }) + -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds" + = do { tup_id <- newSysLocalDs Many tup_ty + ; core_wrap <- dsHsWrapper wrap + ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ + mkTupleSelector all_locals local tup_id $ + mkVarApps (Var poly_tup_id) (tyvars ++ dicts) + rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. + ; return ((global', rhs) : fromOL spec_binds) } + + ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) + + ; return ( exported_force_vars + , (poly_tup_id, poly_tup_rhs) : + concat export_binds_s) } + where + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env + = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + add_inline :: Id -> Id -- tran + add_inline lcl_id = lookupVarEnv inline_env lcl_id + `orElse` lcl_id + + global_env :: IdEnv Id -- Maps local Id to its global exported Id + global_env = + mkVarEnv [ (local, global) + | ABE { abe_mono = local, abe_poly = global } <- exports + ] + + -- find variables that are not exported + get_new_force_vars lcls = + foldr (\lcl acc -> case lookupVarEnv global_env lcl of + Just _ -> acc + Nothing -> lcl:acc) + [] lcls + + -- find exports or make up new exports for force variables + get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc]) + get_exports lcls = + foldM (\(glbls, exports) lcl -> + case lookupVarEnv global_env lcl of + Just glbl -> return (glbl:glbls, exports) + Nothing -> do export <- mk_export lcl + let glbl = abe_poly export + return (glbl:glbls, export:exports)) + ([],[]) lcls + + mk_export local = + do global <- newSysLocalDs Many + (exprType (mkLams tyvars (mkLams dicts (Var local)))) + return (ABE { abe_ext = noExtField + , abe_poly = global + , abe_mono = local + , abe_wrap = WpHole + , abe_prags = SpecPrags [] }) + +-- | This is where we apply INLINE and INLINABLE pragmas. All we need to +-- do is to attach the unfolding information to the Id. +-- +-- Other decisions about whether to inline are made in +-- `calcUnfoldingGuidance` but the decision about whether to then expose +-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` +-- using this information. +------------------------ +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr + -> (Id, CoreExpr) +makeCorePair dflags gbl_id is_default_method dict_arity rhs + | is_default_method -- Default methods are *always* inlined + -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance + = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) + + | otherwise + = case inlinePragmaSpec inline_prag of + NoUserInline -> (gbl_id, rhs) + NoInline -> (gbl_id, rhs) + Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline -> inline_pair + + where + inline_prag = idInlinePragma gbl_id + inlinable_unf = mkInlinableUnfolding dflags rhs + inline_pair + | Just arity <- inlinePragmaSat inline_prag + -- Add an Unfolding for an INLINE (but not for NOINLINE) + -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] + , let real_arity = dict_arity + arity + -- NB: The arity in the InlineRule takes account of the dictionaries + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs + , etaExpand real_arity rhs) + + | otherwise + = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ + (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs) + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + +{- +Note [Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + +Note [Rules and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Common special case: no type or dictionary abstraction +This is a bit less trivial than you might suppose +The naive way would be to desugar to something like + f_lcl = ...f_lcl... -- The "binds" from AbsBinds + M.f = f_lcl -- Generated from "exports" +But we don't want that, because if M.f isn't exported, +it'll be inlined unconditionally at every call site (its rhs is +trivial). That would be ok unless it has RULES, which would +thereby be completely lost. Bad, bad, bad. + +Instead we want to generate + M.f = ...f_lcl... + f_lcl = M.f +Now all is cool. The RULES are attached to M.f (by SimplCore), +and f_lcl is rapidly inlined away. + +This does not happen in the same way to polymorphic binds, +because they desugar to + M.f = /\a. let f_lcl = ...f_lcl... in f_lcl +Although I'm a bit worried about whether full laziness might +float the f_lcl binding out and then inline M.f at its call site + +Note [Specialising in no-dict case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even if there are no tyvars or dicts, we may have specialisation pragmas. +Class methods can generate + AbsBinds [] [] [( ... spec-prag] + { AbsBinds [tvs] [dicts] ...blah } +So the overloading is in the nested AbsBinds. A good example is in GHC.Float: + + class (Real a, Fractional a) => RealFrac a where + round :: (Integral b) => a -> b + + instance RealFrac Float where + {-# SPECIALIZE round :: Float -> Int #-} + +The top-level AbsBinds for $cround has no tyvars or dicts (because the +instance does not). But the method is locally overloaded! + +Note [Abstracting over tyvars only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When abstracting over type variable only (not dictionaries), we don't really need to +built a tuple and select from it, as we do in the general case. Instead we can take + + AbsBinds [a,b] [ ([a,b], fg, fl, _), + ([b], gg, gl, _) ] + { fl = e1 + gl = e2 + h = e3 } + +and desugar it to + + fg = /\ab. let B in e1 + gg = /\b. let a = () in let B in S(e2) + h = /\ab. let B in e3 + +where B is the *non-recursive* binding + fl = fg a b + gl = gg b + h = h a b -- See (b); note shadowing! + +Notice (a) g has a different number of type variables to f, so we must + use the mkArbitraryType thing to fill in the gaps. + We use a type-let to do that. + + (b) The local variable h isn't in the exports, and rather than + clone a fresh copy we simply replace h by (h a b), where + the two h's have different types! Shadowing happens here, + which looks confusing but works fine. + + (c) The result is *still* quadratic-sized if there are a lot of + small bindings. So if there are more than some small + number (10), we filter the binding set B by the free + variables of the particular RHS. Tiresome. + +Why got to this trouble? It's a common case, and it removes the +quadratic-sized tuple desugaring. Less clutter, hopefully faster +compilation, especially in a case where there are a *lot* of +bindings. + + +Note [Eta-expanding INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo :: Eq a => a -> a + {-# INLINE foo #-} + foo x = ... + +If (foo d) ever gets floated out as a common sub-expression (which can +happen as a result of method sharing), there's a danger that we never +get to do the inlining, which is a Terribly Bad thing given that the +user said "inline"! + +To avoid this we pre-emptively eta-expand the definition, so that foo +has the arity with which it is declared in the source code. In this +example it has arity 2 (one for the Eq and one for x). Doing this +should mean that (foo d) is a PAP and we don't share it. + +Note [Nested arities] +~~~~~~~~~~~~~~~~~~~~~ +For reasons that are not entirely clear, method bindings come out looking like +this: + + AbsBinds [] [] [$cfromT <= [] fromT] + $cfromT [InlPrag=INLINE] :: T Bool -> Bool + { AbsBinds [] [] [fromT <= [] fromT_1] + fromT :: T Bool -> Bool + { fromT_1 ((TBool b)) = not b } } } + +Note the nested AbsBind. The arity for the InlineRule on $cfromT should be +gotten from the binding for fromT_1. + +It might be better to have just one level of AbsBinds, but that requires more +thought! + + +Note [Desugar Strict binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma + +Desugaring strict variable bindings looks as follows (core below ==>) + + let !x = rhs + in body +==> + let x = rhs + in x `seq` body -- seq the variable + +and if it is a pattern binding the desugaring looks like + + let !pat = rhs + in body +==> + let x = rhs -- bind the rhs to a new variable + pat = x + in x `seq` body -- seq the new variable + +if there is no variable in the pattern desugaring looks like + + let False = rhs + in body +==> + let x = case rhs of {False -> (); _ -> error "Match failed"} + in x `seq` body + +In order to force the Ids in the binding group they are passed around +in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind. + +Consider a recursive group like this + + letrec + f : g = rhs[f,g] + in + +Without `Strict`, we get a translation like this: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (fm,gm) + + in let f = /\a. case t a of (fm,_) -> fm + in let g = /\a. case t a of (_,gm) -> gm + in + +Here `tm` is the monomorphic binding for `rhs`. + +With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. +Alas, `tm` isn't in scope in the `in ` part. + +The simplest thing is to return it in the polymorphic +tuple `t`, thus: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (tm, fm, gm) + + in let f = /\a. case t a of (_,fm,_) -> fm + in let g = /\a. case t a of (_,_,gm) -> gm + in let tm = /\a. case t a of (tm,_,_) -> tm + in tm `seq` + + +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more +detailed explanation of the desugaring of strict bindings. + +Note [Strict binds checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several checks around properly formed strict bindings. They +all link to this Note. These checks must be here in the desugarer because +we cannot know whether or not a type is unlifted until after zonking, due +to levity polymorphism. These checks all used to be handled in the typechecker +in checkStrictBinds (before Jan '17). + +We define an "unlifted bind" to be any bind that binds an unlifted id. Note that + + x :: Char + (# True, x #) = blah + +is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. + +Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. +Define a "strict bind" to be either an unlifted bind or a banged bind. + +The restrictions are: + 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. + + 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged + unlifted bind, but an unbanged bind looks lazy, and we don't want users to be + surprised by the strictness of an unlifted bind.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type + variables or constraints.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. + +-} + +------------------------ +dsSpecs :: CoreExpr -- Its rhs + -> TcSpecPrags + -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids + , [CoreRule] ) -- Rules for the Global Ids +-- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind +dsSpecs _ IsDefaultMethod = return (nilOL, []) +dsSpecs poly_rhs (SpecPrags sps) + = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps + ; let (spec_binds_s, rules) = unzip pairs + ; return (concatOL spec_binds_s, rules) } + +dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding + -- Nothing => RULE is for an imported Id + -- rhs is in the Id's unfolding + -> Located TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) + | isJust (isClassOpId_maybe poly_id) + = putSrcSpanDs loc $ + do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" + <+> quotes (ppr poly_id)) + ; return Nothing } -- There is no point in trying to specialise a class op + -- Moreover, classops don't (currently) have an inl_sat arity set + -- (it would be Just 0) and that in turn makes makeCorePair bleat + + | no_act_spec && isNeverActive rule_act + = putSrcSpanDs loc $ + do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" + <+> quotes (ppr poly_id)) + ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that + -- See Note [Activation pragmas for SPECIALISE] + + | otherwise + = putSrcSpanDs loc $ + do { uniq <- newUnique + ; let poly_name = idName poly_id + spec_occ = mkSpecOcc (getOccName poly_name) + spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) + (spec_bndrs, spec_app) = collectHsWrapBinders spec_co + -- spec_co looks like + -- \spec_bndrs. [] spec_args + -- perhaps with the body of the lambda wrapped in some WpLets + -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 + + ; core_app <- dsHsWrapper spec_app + + ; let ds_lhs = core_app (Var poly_id) + spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs) + ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id + -- , text "spec_co:" <+> ppr spec_co + -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ + dflags <- getDynFlags + ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { + Left msg -> do { warnDs NoReason msg; return Nothing } ; + Right (rule_bndrs, _fn, rule_lhs_args) -> do + + { this_mod <- getModule + ; let fn_unf = realIdUnfolding poly_id + spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf + spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many. + `setInlinePragma` inl_prag + `setIdUnfolding` spec_unf + + ; rule <- dsMkUserRule this_mod is_local_id + (mkFastString ("SPEC " ++ showPpr dflags poly_name)) + rule_act poly_name + rule_bndrs rule_lhs_args + (mkVarApps (Var spec_id) spec_bndrs) + + ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs) + +-- Commented out: see Note [SPECIALISE on INLINE functions] +-- ; when (isInlinePragma id_inl) +-- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" +-- <+> quotes (ppr poly_name)) + + ; return (Just (unitOL (spec_id, spec_rhs), rule)) + -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because + -- makeCorePair overwrites the unfolding, which we have + -- just created using specUnfolding + } } } + where + is_local_id = isJust mb_poly_rhs + poly_rhs | Just rhs <- mb_poly_rhs + = rhs -- Local Id; this is its rhs + | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) + = unfolding -- Imported Id; this is its unfolding + -- Use realIdUnfolding so we get the unfolding + -- even when it is a loop breaker. + -- We want to specialise recursive functions! + | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) + -- The type checker has checked that it *has* an unfolding + + id_inl = idInlinePragma poly_id + + -- See Note [Activation pragmas for SPECIALISE] + inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl + | not is_local_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = id_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + spec_prag_act = inlinePragmaActivation spec_inl + + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit + | otherwise = spec_prag_act -- Specified by user + + +dsMkUserRule :: Module -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule +dsMkUserRule this_mod is_local name act fn bndrs args rhs = do + let rule = mkRule this_mod False is_local name act fn bndrs args rhs + dflags <- getDynFlags + when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $ + warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule) + return rule + +ruleOrphWarn :: CoreRule -> SDoc +ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule + +{- Note [SPECIALISE on INLINE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to warn that using SPECIALISE for a function marked INLINE +would be a no-op; but it isn't! Especially with worker/wrapper split +we might have + {-# INLINE f #-} + f :: Ord a => Int -> a -> ... + f d x y = case x of I# x' -> $wf d x' y + +We might want to specialise 'f' so that we in turn specialise '$wf'. +We can't even /name/ '$wf' in the source code, so we can't specialise +it even if we wanted to. #10721 is a case in point. + +Note [Activation pragmas for SPECIALISE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From a user SPECIALISE pragma for f, we generate + a) A top-level binding spec_fn = rhs + b) A RULE f dOrd = spec_fn + +We need two pragma-like things: + +* spec_fn's inline pragma: inherited from f's inline pragma (ignoring + activation on SPEC), unless overridden by SPEC INLINE + +* Activation of RULE: from SPECIALISE pragma (if activation given) + otherwise from f's inline pragma + +This is not obvious (see #5237)! + +Examples Rule activation Inline prag on spec'd fn +--------------------------------------------------------------------- +SPEC [n] f :: ty [n] Always, or NOINLINE [n] + copy f's prag + +NOINLINE f +SPEC [n] f :: ty [n] NOINLINE + copy f's prag + +NOINLINE [k] f +SPEC [n] f :: ty [n] NOINLINE [k] + copy f's prag + +INLINE [k] f +SPEC [n] f :: ty [n] INLINE [k] + copy f's prag + +SPEC INLINE [n] f :: ty [n] INLINE [n] + (ignore INLINE prag on f, + same activation for rule and spec'd fn) + +NOINLINE [k] f +SPEC f :: ty [n] INLINE [k] + + +************************************************************************ +* * +\subsection{Adding inline pragmas} +* * +************************************************************************ +-} + +decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr + -> Either SDoc ([Var], Id, [CoreExpr]) +-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, +-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs +-- may add some extra dictionary binders (see Note [Free dictionaries]) +-- +-- Returns an error message if the LHS isn't of the expected shape +-- Note [Decomposing the left-hand side of a RULE] +decomposeRuleLhs dflags orig_bndrs orig_lhs + | not (null unbound) -- Check for things unbound on LHS + -- See Note [Unused spec binders] + = Left (vcat (map dead_msg unbound)) + | Var funId <- fun2 + , Just con <- isDataConId_maybe funId + = Left (constructor_msg con) -- See Note [No RULES on datacons] + | Just (fn_id, args) <- decompose fun2 args2 + , let extra_bndrs = mk_extra_bndrs fn_id args + = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs + -- , text "fn_id:" <+> ppr fn_id + -- , text "args:" <+> ppr args]) $ + Right (orig_bndrs ++ extra_bndrs, fn_id, args) + + | otherwise + = Left bad_shape_msg + where + lhs1 = drop_dicts orig_lhs + lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS] + (fun2,args2) = collectArgs lhs2 + + lhs_fvs = exprFreeVars lhs2 + unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs + + orig_bndr_set = mkVarSet orig_bndrs + + -- Add extra tyvar binders: Note [Free tyvars in rule LHS] + -- and extra dict binders: Note [Free dictionaries in rule LHS] + mk_extra_bndrs fn_id args + = scopedSort unbound_tvs ++ unbound_dicts + where + unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] + unbound_dicts = [ mkLocalId (localiseName (idName d)) Many (idType d) + | d <- unbound_vars, isDictId d ] + unbound_vars = [ v | v <- exprsFreeVarsList args + , not (v `elemVarSet` orig_bndr_set) + , not (v == fn_id) ] + -- fn_id: do not quantify over the function itself, which may + -- itself be a dictionary (in pathological cases, #10251) + + decompose (Var fn_id) args + | not (fn_id `elemVarSet` orig_bndr_set) + = Just (fn_id, args) + + decompose _ _ = Nothing + + bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") + 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 + , text "Orig lhs:" <+> ppr orig_lhs]) + dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr + , text "is not bound in RULE lhs"]) + 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs + , text "Orig lhs:" <+> ppr orig_lhs + , text "optimised lhs:" <+> ppr lhs2 ]) + pp_bndr bndr + | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) + | isEvVar bndr = text "constraint" <+> quotes (ppr (varType bndr)) + | otherwise = text "variable" <+> quotes (ppr bndr) + + constructor_msg con = vcat + [ text "A constructor," <+> ppr con <> + text ", appears as outermost match in RULE lhs." + , text "This rule will be ignored." ] + + drop_dicts :: CoreExpr -> CoreExpr + drop_dicts e + = wrap_lets needed bnds body + where + needed = orig_bndr_set `minusVarSet` exprFreeVars body + (bnds, body) = split_lets (occurAnalyseExpr e) + -- The occurAnalyseExpr drops dead bindings which is + -- crucial to ensure that every binding is used later; + -- which in turn makes wrap_lets work right + + split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) + split_lets (Let (NonRec d r) body) + | isDictId d + = ((d,r):bs, body') + where (bs, body') = split_lets body + + -- handle "unlifted lets" too, needed for "map/coerce" + split_lets (Case r d _ [(DEFAULT, _, body)]) + | isCoVar d + = ((d,r):bs, body') + where (bs, body') = split_lets body + + split_lets e = ([], e) + + wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr + wrap_lets _ [] body = body + wrap_lets needed ((d, r) : bs) body + | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) + | otherwise = wrap_lets needed bs body + where + rhs_fvs = exprFreeVars r + needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d + +{- +Note [Decomposing the left-hand side of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several things going on here. +* drop_dicts: see Note [Drop dictionary bindings on rule LHS] +* simpleOptExpr: see Note [Simplify rule LHS] +* extra_dict_bndrs: see Note [Free dictionaries] + +Note [Free tyvars on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo alpha (C alpha)), where alpha +is an unbound meta-tyvar. The zonker in GHC.Tc.Utils.Zonk is careful not to +turn the free alpha into Any (as it usually does). Instead it turns it +into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in "GHC.Tc.Utils.Zonk". + +Now we must quantify over that 'a'. It's /really/ inconvenient to do that +in the zonker, because the HsExpr data type is very large. But it's /easy/ +to do it here in the desugarer. + +Moreover, we have to do something rather similar for dictionaries; +see Note [Free dictionaries on rule LHS]. So that's why we look for +type variables free on the LHS, and quantify over them. + +Note [Free dictionaries on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, +which is presumably in scope at the function definition site, we can quantify +over it too. *Any* dict with that type will do. + +So for example when you have + f :: Eq a => a -> a + f = + ... SPECIALISE f :: Int -> Int ... + +Then we get the SpecPrag + SpecPrag (f Int dInt) + +And from that we want the rule + + RULE forall dInt. f Int dInt = f_spec + f_spec = let f = in f Int dInt + +But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External +Name, and you can't bind them in a lambda or forall without getting things +confused. Likewise it might have an InlineRule or something, which would be +utterly bogus. So we really make a fresh Id, with the same unique and type +as the old one, but with an Internal name and no IdInfo. + +Note [Drop dictionary bindings on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +drop_dicts drops dictionary bindings on the LHS where possible. + E.g. let d:Eq [Int] = $fEqList $fEqInt in f d + --> f d + Reasoning here is that there is only one d:Eq [Int], and so we can + quantify over it. That makes 'd' free in the LHS, but that is later + picked up by extra_dict_bndrs (Note [Dead spec binders]). + + NB 1: We can only drop the binding if the RHS doesn't bind + one of the orig_bndrs, which we assume occur on RHS. + Example + f :: (Eq a) => b -> a -> a + {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} + Here we want to end up with + RULE forall d:Eq a. f ($dfEqList d) = f_spec d + Of course, the ($dfEqlist d) in the pattern makes it less likely + to match, but there is no other way to get d:Eq a + + NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all + the evidence bindings to be wrapped around the outside of the + LHS. (After simplOptExpr they'll usually have been inlined.) + dsHsWrapper does dependency analysis, so that civilised ones + will be simple NonRec bindings. We don't handle recursive + dictionaries! + + NB3: In the common case of a non-overloaded, but perhaps-polymorphic + specialisation, we don't need to bind *any* dictionaries for use + in the RHS. For example (#8331) + {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} + useAbstractMonad :: MonadAbstractIOST m => m Int + Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code + but the RHS uses no dictionaries, so we want to end up with + RULE forall s (d :: MonadAbstractIOST (ReaderT s)). + useAbstractMonad (ReaderT s) d = $suseAbstractMonad s + + #8848 is a good example of where there are some interesting + dictionary bindings to discard. + +The drop_dicts algorithm is based on these observations: + + * Given (let d = rhs in e) where d is a DictId, + matching 'e' will bind e's free variables. + + * So we want to keep the binding if one of the needed variables (for + which we need a binding) is in fv(rhs) but not already in fv(e). + + * The "needed variables" are simply the orig_bndrs. Consider + f :: (Eq a, Show b) => a -> b -> String + ... SPECIALISE f :: (Show b) => Int -> b -> String ... + Then orig_bndrs includes the *quantified* dictionaries of the type + namely (dsb::Show b), but not the one for Eq Int + +So we work inside out, applying the above criterion at each step. + + +Note [Simplify rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~ +simplOptExpr occurrence-analyses and simplifies the LHS: + + (a) Inline any remaining dictionary bindings (which hopefully + occur just once) + + (b) Substitute trivial lets, so that they don't get in the way. + Note that we substitute the function too; we might + have this as a LHS: let f71 = M.f Int in f71 + + (c) Do eta reduction. To see why, consider the fold/build rule, + which without simplification looked like: + fold k z (build (/\a. g a)) ==> ... + This doesn't match unless you do eta reduction on the build argument. + Similarly for a LHS like + augment g (build h) + we do not want to get + augment (\a. g a) (build h) + otherwise we don't match when given an argument like + augment (\a. h a a) (build h) + +Note [Unused spec binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: a -> a + ... SPECIALISE f :: Eq a => a -> a ... +It's true that this *is* a more specialised type, but the rule +we get is something like this: + f_spec d = f + RULE: f = f_spec d +Note that the rule is bogus, because it mentions a 'd' that is +not bound on the LHS! But it's a silly specialisation anyway, because +the constraint is unused. We could bind 'd' to (error "unused") +but it seems better to reject the program because it's almost certainly +a mistake. That's what the isDeadBinder call detects. + +Note [No RULES on datacons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Previously, `RULES` like + + "JustNothing" forall x . Just x = Nothing + +were allowed. Simon Peyton Jones says this seems to have been a +mistake, that such rules have never been supported intentionally, +and that he doesn't know if they can break in horrible ways. +Furthermore, Ben Gamari and Reid Barton are considering trying to +detect the presence of "static data" that the simplifier doesn't +need to traverse at all. Such rules do not play well with that. +So for now, we ban them altogether as requested by #13290. See also #7398. + + +************************************************************************ +* * + Desugaring evidence +* * +************************************************************************ + +-} + +dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) +dsHsWrapper WpHole = return $ \e -> e +dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) +dsHsWrapper (WpEvLam ev) = return $ Lam ev +dsHsWrapper (WpTyLam tv) = return $ Lam tv +dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds + ; return (mkCoreLets bs) } +dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 + ; w2 <- dsHsWrapper c2 + ; return (w1 . w2) } + -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what + -- the specification of this clause is +dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc) + = do { x <- newSysLocalDsNoLP w t1 + ; w1 <- dsHsWrapper c1 + ; w2 <- dsHsWrapper c2 + ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a + arg = w1 (Var x) + ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc + ; if ok + then return (\e -> (Lam x (w2 (app e arg)))) + else return id } -- this return is irrelevant +dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) + return $ \e -> mkCastDs e co +dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm + ; return (\e -> App e core_tm) } + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. +dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $ + errDs (text "Multiplicity coercions are currently not supported") + ; return $ \e -> e } +-------------------------------------- +dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] +dsTcEvBinds_s [] = return [] +dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null + dsTcEvBinds b + +dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] +dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this +dsTcEvBinds (EvBinds bs) = dsEvBinds bs + +dsEvBinds :: Bag EvBind -> DsM [CoreBind] +dsEvBinds bs + = do { ds_bs <- mapBagM dsEvBind bs + ; return (mk_ev_binds ds_bs) } + +mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] +-- We do SCC analysis of the evidence bindings, /after/ desugaring +-- them. This is convenient: it means we can use the GHC.Core +-- free-variable functions rather than having to do accurate free vars +-- for EvTerm. +mk_ev_binds ds_binds + = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) + where + edges :: [ Node EvVar (EvVar,CoreExpr) ] + edges = foldr ((:) . mk_node) [] ds_binds + + mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) + mk_node b@(var, rhs) + = DigraphNode { node_payload = b + , node_key = var + , node_dependencies = nonDetEltsUniqSet $ + exprFreeVars rhs `unionVarSet` + coVarsOfType (varType var) } + -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + + ds_scc (AcyclicSCC (v,r)) = NonRec v r + ds_scc (CyclicSCC prs) = Rec prs + +dsEvBind :: EvBind -> DsM (Id, CoreExpr) +dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) + + +{-********************************************************************** +* * + Desugaring EvTerms +* * +**********************************************************************-} + +dsEvTerm :: EvTerm -> DsM CoreExpr +dsEvTerm (EvExpr e) = return e +dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev +dsEvTerm (EvFun { et_tvs = tvs, et_given = given + , et_binds = ev_binds, et_body = wanted_id }) + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; return $ (mkLams (tvs ++ given) $ + mkCoreLets ds_ev_binds $ + Var wanted_id) } + + +{-********************************************************************** +* * + Desugaring Typeable dictionaries +* * +**********************************************************************-} + +dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr +-- Return a CoreExpr :: Typeable ty +-- This code is tightly coupled to the representation +-- of TypeRep, in base library Data.Typeable.Internals +dsEvTypeable ty ev + = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable + ; let kind = typeKind ty + Just typeable_data_con + = tyConSingleDataCon_maybe tyCl -- "Data constructor" + -- for Typeable + + ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a + + -- Package up the method as `Typeable` dictionary + ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } + +type TypeRepExpr = CoreExpr + +-- | Returns a @CoreExpr :: TypeRep ty@ +ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr +ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) + = do { mkTrCon <- dsLookupGlobalId mkTrConName + -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a + ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName + ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName + -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep + + ; tc_rep <- tyConRep tc -- :: TyCon + ; let ks = tyConAppArgs ty + -- Construct a SomeTypeRep + toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr + toSomeTypeRep t ev = do + rep <- getRep ev t + return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] + ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t + ; let -- :: [SomeTypeRep] + kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps + + -- Note that we use the kind of the type, not the TyCon from which it + -- is constructed since the latter may be kind polymorphic whereas the + -- former we know is not (we checked in the solver). + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) + | Just (t1,t2) <- splitAppTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; mkTrApp <- dsLookupGlobalId mkTrAppName + -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + -- TypeRep a -> TypeRep b -> TypeRep (a b) + ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, + -- since it's a kind + ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) + | Just (m,t1,t2) <- splitFunTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; em <- getRep evm m + ; mkTrFun <- dsLookupGlobalId mkTrFunName + -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2). + -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a # m -> b) + ; let r1 = getRuntimeRep t1 + r2 = getRuntimeRep t2 + ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2]) + [ em, e1, e2 ] + } + +ds_ev_typeable ty (EvTypeableTyLit ev) + = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact + do { fun <- dsLookupGlobalId tr_fun + ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol + ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] + ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } + where + ty_kind = typeKind ty + + -- tr_fun is the Name of + -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a + -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a + tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName + | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName + | otherwise = panic "dsEvTypeable: unknown type lit kind" + +ds_ev_typeable ty ev + = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) + +getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ + -> Type -- ^ The type @ty@ + -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ + -- namely @typeRep# dict@ +-- Remember that +-- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a +getRep ev ty + = do { typeable_expr <- dsEvTerm ev + ; typeRepId <- dsLookupGlobalId typeRepIdName + ; let ty_args = [typeKind ty, ty] + ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } + +tyConRep :: TyCon -> DsM CoreExpr +-- Returns CoreExpr :: TyCon +tyConRep tc + | Just tc_rep_nm <- tyConRepName_maybe tc + = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm + ; return (Var tc_rep_id) } + | otherwise + = pprPanic "tyConRep" (ppr tc) diff --git a/GHC/HsToCore/Binds.hs-boot b/GHC/HsToCore/Binds.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Binds.hs-boot @@ -0,0 +1,6 @@ +module GHC.HsToCore.Binds where +import GHC.HsToCore.Monad ( DsM ) +import GHC.Core ( CoreExpr ) +import GHC.Tc.Types.Evidence (HsWrapper) + +dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) diff --git a/GHC/HsToCore/Coverage.hs b/GHC/HsToCore/Coverage.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Coverage.hs @@ -0,0 +1,1347 @@ +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +-} + +{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where + +import GHC.Prelude as Prelude + +import qualified GHC.Runtime.Interpreter as GHCi +import GHCi.RemoteTypes +import Data.Array +import GHC.ByteCode.Types +import GHC.Stack.CCS +import GHC.Core.Type +import GHC.Hs +import GHC.Unit +import GHC.Utils.Outputable as Outputable +import GHC.Driver.Session +import GHC.Core.ConLike +import Control.Monad +import GHC.Types.SrcLoc +import GHC.Utils.Error +import GHC.Types.Name.Set hiding (FreeVars) +import GHC.Types.Name +import GHC.Data.Bag +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Core +import GHC.Types.Id +import GHC.Types.Var.Set +import Data.List +import GHC.Data.FastString +import GHC.Driver.Types +import GHC.Core.TyCon +import GHC.Types.Basic +import GHC.Utils.Monad +import GHC.Data.Maybe +import GHC.Cmm.CLabel +import GHC.Utils.Misc + +import Data.Time +import System.Directory + +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import qualified Data.ByteString as BS +import Data.Set (Set) +import qualified Data.Set as Set + +{- +************************************************************************ +* * +* The main function: addTicksToBinds +* * +************************************************************************ +-} + +addTicksToBinds + :: HscEnv + -> Module + -> ModLocation -- ... off the current module + -> NameSet -- Exported Ids. When we call addTicksToBinds, + -- isExportedId doesn't work yet (the desugarer + -- hasn't set it), so we have to work from this set. + -> [TyCon] -- Type constructor in this module + -> LHsBinds GhcTc + -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) + +addTicksToBinds hsc_env mod mod_loc exports tyCons binds + | let dflags = hsc_dflags hsc_env + passes = coveragePasses dflags, not (null passes), + Just orig_file <- ml_hs_file mod_loc = do + + let orig_file2 = guessSourceFile binds orig_file + + tickPass tickish (binds,st) = + let env = TTE + { fileName = mkFastString orig_file2 + , declPath = [] + , tte_dflags = dflags + , exports = exports + , inlines = emptyVarSet + , inScope = emptyVarSet + , blackList = Set.fromList $ + mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of + RealSrcSpan l _ -> Just l + UnhelpfulSpan _ -> Nothing) + tyCons + , density = mkDensity tickish dflags + , this_mod = mod + , tickishType = tickish + } + (binds',_,st') = unTM (addTickLHsBinds binds) env st + in (binds', st') + + initState = TT { tickBoxCount = 0 + , mixEntries = [] + , ccIndices = newCostCentreState + } + + (binds1,st) = foldr tickPass (binds, initState) passes + + let tickCount = tickBoxCount st + entries = reverse $ mixEntries st + hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 + modBreaks <- mkModBreaks hsc_env mod tickCount entries + + dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell + (pprLHsBinds binds1) + + return (binds1, HpcInfo tickCount hashNo, modBreaks) + + | otherwise = return (binds, emptyHpcInfo False, Nothing) + +guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath +guessSourceFile binds orig_file = + -- Try look for a file generated from a .hsc file to a + -- .hs file, by peeking ahead. + let top_pos = catMaybes $ foldr (\ (L pos _) rest -> + srcSpanFileName_maybe pos : rest) [] binds + in + case top_pos of + (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name + -> unpackFS file_name + _ -> orig_file + + +mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks) +mkModBreaks hsc_env mod count entries + | breakpointsEnabled (hsc_dflags hsc_env) = do + breakArray <- GHCi.newBreakArray hsc_env (length entries) + ccs <- mkCCSArray hsc_env mod count entries + let + locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] + varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] + declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] + return $ Just $ emptyModBreaks + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs + } + | otherwise = return Nothing + +mkCCSArray + :: HscEnv -> Module -> Int -> [MixEntry_] + -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) +mkCCSArray hsc_env modul count entries = do + case hsc_interp hsc_env of + Just interp | GHCi.interpreterProfiled interp -> do + let module_str = moduleNameString (moduleName modul) + costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries) + return (listArray (0,count-1) costcentres) + + _ -> return (listArray (0,-1) []) + where + dflags = hsc_dflags hsc_env + mk_one (srcspan, decl_path, _, _) = (name, src) + where name = concat (intersperse "." decl_path) + src = showSDoc dflags (ppr srcspan) + + +writeMixEntries + :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int +writeMixEntries dflags mod count entries filename + | not (gopt Opt_Hpc dflags) = return 0 + | otherwise = do + let + hpc_dir = hpcDir dflags + mod_name = moduleNameString (moduleName mod) + + hpc_mod_dir + | moduleUnit mod == mainUnit = hpc_dir + | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod) + + tabStop = 8 -- counts as a normal char in GHC's + -- location ranges. + + createDirectoryIfMissing True hpc_mod_dir + modTime <- getModificationUTCTime filename + let entries' = [ (hpcPos, box) + | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] + when (entries' `lengthIsNot` count) $ do + panic "the number of .mix entries are inconsistent" + let hashNo = mixHash filename modTime tabStop entries' + mixCreate hpc_mod_dir mod_name + $ Mix filename modTime (toHash hashNo) tabStop entries' + return hashNo + + +-- ----------------------------------------------------------------------------- +-- TickDensity: where to insert ticks + +data TickDensity + = TickForCoverage -- for Hpc + | TickForBreakPoints -- for GHCi + | TickAllFunctions -- for -prof-auto-all + | TickTopFunctions -- for -prof-auto-top + | TickExportedFunctions -- for -prof-auto-exported + | TickCallSites -- for stack tracing + deriving Eq + +mkDensity :: TickishType -> DynFlags -> TickDensity +mkDensity tickish dflags = case tickish of + HpcTicks -> TickForCoverage + SourceNotes -> TickForCoverage + Breakpoints -> TickForBreakPoints + ProfNotes -> + case profAuto dflags of + ProfAutoAll -> TickAllFunctions + ProfAutoTop -> TickTopFunctions + ProfAutoExports -> TickExportedFunctions + ProfAutoCalls -> TickCallSites + _other -> panic "mkDensity" + +-- | Decide whether to add a tick to a binding or not. +shouldTickBind :: TickDensity + -> Bool -- top level? + -> Bool -- exported? + -> Bool -- simple pat bind? + -> Bool -- INLINE pragma? + -> Bool + +shouldTickBind density top_lev exported _simple_pat inline + = case density of + TickForBreakPoints -> False + -- we never add breakpoints to simple pattern bindings + -- (there's always a tick on the rhs anyway). + TickAllFunctions -> not inline + TickTopFunctions -> top_lev && not inline + TickExportedFunctions -> exported && not inline + TickForCoverage -> True + TickCallSites -> False + +shouldTickPatBind :: TickDensity -> Bool -> Bool +shouldTickPatBind density top_lev + = case density of + TickForBreakPoints -> False + TickAllFunctions -> True + TickTopFunctions -> top_lev + TickExportedFunctions -> False + TickForCoverage -> False + TickCallSites -> False + +-- ----------------------------------------------------------------------------- +-- Adding ticks to bindings + +addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) +addTickLHsBinds = mapBagM addTickLHsBind + +addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) +addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, + abs_exports = abs_exports })) = do + withEnv add_exports $ do + withEnv add_inlines $ do + binds' <- addTickLHsBinds binds + return $ L pos $ bind { abs_binds = binds' } + where + -- in AbsBinds, the Id on each binding is not the actual top-level + -- Id that we are defining, they are related by the abs_exports + -- field of AbsBinds. So if we're doing TickExportedFunctions we need + -- to add the local Ids to the set of exported Names so that we know to + -- tick the right bindings. + add_exports env = + env{ exports = exports env `extendNameSetList` + [ idName mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , idName pid `elemNameSet` (exports env) ] } + + -- See Note [inline sccs] + add_inlines env = + env{ inlines = inlines env `extendVarSetList` + [ mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , isInlinePragma (idInlinePragma pid) ] } + +addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do + let name = getOccString id + decl_path <- getPathEntry + density <- getDensity + + inline_ids <- liftM inlines getEnv + -- See Note [inline sccs] + let inline = isInlinePragma (idInlinePragma id) + || id `elemVarSet` inline_ids + + -- See Note [inline sccs] + tickish <- tickishType `liftM` getEnv + if inline && tickish == ProfNotes then return (L pos funBind) else do + + (fvs, mg) <- + getFreeVars $ + addPathEntry name $ + addTickMatchGroup False (fun_matches funBind) + + blackListed <- isBlackListed pos + exported_names <- liftM exports getEnv + + -- We don't want to generate code for blacklisted positions + -- We don't want redundant ticks on simple pattern bindings + -- We don't want to tick non-exported bindings in TickExportedFunctions + let simple = isSimplePatBind funBind + toplev = null decl_path + exported = idName id `elemNameSet` exported_names + + tick <- if not blackListed && + shouldTickBind density toplev exported simple inline + then + bindTick density name pos fvs + else + return Nothing + + let mbCons = maybe Prelude.id (:) + return $ L pos $ funBind { fun_matches = mg + , fun_tick = tick `mbCons` fun_tick funBind } + + where + -- a binding is a simple pattern binding if it is a funbind with + -- zero patterns + isSimplePatBind :: HsBind GhcTc -> Bool + isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 + +-- TODO: Revisit this +addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs + , pat_rhs = rhs }))) = do + + let simplePatId = isSimplePat lhs + + -- TODO: better name for rhs's for non-simple patterns? + let name = maybe "(...)" getOccString simplePatId + + (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs + let pat' = pat { pat_rhs = rhs'} + + -- Should create ticks here? + density <- getDensity + decl_path <- getPathEntry + let top_lev = null decl_path + if not (shouldTickPatBind density top_lev) + then return (L pos pat') + else do + + let mbCons = maybe id (:) + + let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat' + + -- Allocate the ticks + + rhs_tick <- bindTick density name pos fvs + let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks + + patvar_tickss <- case simplePatId of + Just{} -> return initial_patvar_tickss + Nothing -> do + let patvars = map getOccString (collectPatBinders lhs) + patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars + return + (zipWith mbCons patvar_ticks + (initial_patvar_tickss ++ repeat [])) + + return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } + +-- Only internal stuff, not from source, uses VarBind, so we ignore it. +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind + +bindTick + :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) +bindTick density name pos fvs = do + decl_path <- getPathEntry + let + toplev = null decl_path + count_entries = toplev || density == TickAllFunctions + top_only = density /= TickAllFunctions + box_label = if toplev then TopLevelBox [name] + else LocalBox (decl_path ++ [name]) + -- + allocATickBox box_label count_entries top_only pos fvs + + +-- Note [inline sccs] +-- +-- The reason not to add ticks to INLINE functions is that this is +-- sometimes handy for avoiding adding a tick to a particular function +-- (see #6131) +-- +-- So for now we do not add any ticks to INLINE functions at all. +-- +-- We used to use isAnyInlinePragma to figure out whether to avoid adding +-- ticks for this purpose. However, #12962 indicates that this contradicts +-- the documentation on profiling (which only mentions INLINE pragmas). +-- So now we're more careful about what we avoid adding ticks to. + +-- ----------------------------------------------------------------------------- +-- Decorate an LHsExpr with ticks + +-- selectively add ticks to interesting expressions +addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExpr e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | isGoodBreakExpr e0 -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- Add a tick to an expression which is the RHS of an equation or a binding. +-- We always consider these to be breakpoints, unless the expression is a 'let' +-- (because the body will definitely have a tick somewhere). ToDo: perhaps +-- we should treat 'case' and 'if' the same way? +addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprRHS e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- The inner expression of an evaluation context: +-- let binds in [], ( [] ) +-- we never tick these if we're doing HPC, but otherwise +-- we treat it like an ordinary expression. +addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprEvalInner e = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprNever e + _otherwise -> addTickLHsExpr e + +-- | A let body is treated differently from addTickLHsExprEvalInner +-- above with TickForBreakPoints, because for breakpoints we always +-- want to tick the body, even if it is not a redex. See test +-- break012. This gives the user the opportunity to inspect the +-- values of the let-bound variables. +addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprLetBody e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + _other -> addTickLHsExprEvalInner e + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- version of addTick that does not actually add a tick, +-- because the scope of this tick is completely subsumed by +-- another. +addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprNever (L pos e0) = do + e1 <- addTickHsExpr e0 + return $ L pos e1 + +-- general heuristic: expressions which do not denote values are good +-- break points +isGoodBreakExpr :: HsExpr GhcTc -> Bool +isGoodBreakExpr (HsApp {}) = True +isGoodBreakExpr (HsAppType {}) = True +isGoodBreakExpr (OpApp {}) = True +isGoodBreakExpr _other = False + +isCallSite :: HsExpr GhcTc -> Bool +isCallSite HsApp{} = True +isCallSite HsAppType{} = True +isCallSite OpApp{} = True +isCallSite _ = False + +addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprOptAlt oneOfMany (L pos e0) + = ifDensity TickForCoverage + (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + +addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addBinTickLHsExpr boxLabel (L pos e0) + = ifDensity TickForCoverage + (allocBinTickBox boxLabel pos $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + + +-- ----------------------------------------------------------------------------- +-- Decorate the body of an HsExpr with ticks. +-- (Whether to put a tick around the whole expression was already decided, +-- in the addTickLHsExpr family of functions.) + +addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e +addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" +addTickHsExpr e@(HsConLikeOut _ con) + | Just id <- conLikeWrapId_maybe con = do freeVar id; return e +addTickHsExpr e@(HsIPVar {}) = return e +addTickHsExpr e@(HsOverLit {}) = return e +addTickHsExpr e@(HsOverLabel{}) = return e +addTickHsExpr e@(HsLit {}) = return e +addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x) + (addTickMatchGroup True matchgroup) +addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) + (addTickMatchGroup True mgs) +addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x) + (addTickLHsExprNever e) + (return ty) + +addTickHsExpr (OpApp fix e1 e2 e3) = + liftM4 OpApp + (return fix) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) + (addTickLHsExpr e3) +addTickHsExpr (NegApp x e neg) = + liftM2 (NegApp x) + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan neg) +addTickHsExpr (HsPar x e) = + liftM (HsPar x) (addTickLHsExprEvalInner e) +addTickHsExpr (SectionL x e1 e2) = + liftM2 (SectionL x) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) +addTickHsExpr (SectionR x e1 e2) = + liftM2 (SectionR x) + (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (ExplicitTuple x es boxity) = + liftM2 (ExplicitTuple x) + (mapM addTickTupArg es) + (return boxity) +addTickHsExpr (ExplicitSum ty tag arity e) = do + e' <- addTickLHsExpr e + return (ExplicitSum ty tag arity e') +addTickHsExpr (HsCase x e mgs) = + liftM2 (HsCase x) + (addTickLHsExpr e) -- not an EvalInner; e might not necessarily + -- be evaluated. + (addTickMatchGroup False mgs) +addTickHsExpr (HsIf x e1 e2 e3) = + liftM3 (HsIf x) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsExprOptAlt True e2) + (addTickLHsExprOptAlt True e3) +addTickHsExpr (HsMultiIf ty alts) + = do { let isOneOfMany = case alts of [_] -> False; _ -> True + ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts + ; return $ HsMultiIf ty alts' } +addTickHsExpr (HsLet x (L l binds) e) = + bindLocals (collectLocalBinders binds) $ + liftM2 (HsLet x . L l) + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsExprLetBody e) +addTickHsExpr (HsDo srcloc cxt (L l stmts)) + = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) + ; return (HsDo srcloc cxt (L l stmts')) } + where + forQual = case cxt of + ListComp -> Just $ BinBox QualBinBox + _ -> Nothing +addTickHsExpr (ExplicitList ty wit es) = + liftM3 ExplicitList + (return ty) + (addTickWit wit) + (mapM (addTickLHsExpr) es) + where addTickWit Nothing = return Nothing + addTickWit (Just fln) + = do fln' <- addTickSyntaxExpr hpcSrcSpan fln + return (Just fln') + +addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e + +addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) + = do { rec_binds' <- addTickHsRecordBinds rec_binds + ; return (expr { rcon_flds = rec_binds' }) } + +addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) + = do { e' <- addTickLHsExpr e + ; flds' <- mapM addTickHsRecField flds + ; return (expr { rupd_expr = e', rupd_flds = flds' }) } + +addTickHsExpr (ExprWithTySig x e ty) = + liftM3 ExprWithTySig + (return x) + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures + (return ty) +addTickHsExpr (ArithSeq ty wit arith_seq) = + liftM3 ArithSeq + (return ty) + (addTickWit wit) + (addTickArithSeqInfo arith_seq) + where addTickWit Nothing = return Nothing + addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl + return (Just fl') + +-- We might encounter existing ticks (multiple Coverage passes) +addTickHsExpr (HsTick x t e) = + liftM (HsTick x t) (addTickLHsExprNever e) +addTickHsExpr (HsBinTick x t0 t1 e) = + liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) + +addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do + e2 <- allocTickBox (ExpBox False) False False pos $ + addTickHsExpr e0 + return $ unLoc e2 +addTickHsExpr (HsPragE x p e) = + liftM (HsPragE x p) (addTickLHsExpr e) +addTickHsExpr e@(HsBracket {}) = return e +addTickHsExpr e@(HsTcBracketOut {}) = return e +addTickHsExpr e@(HsRnBracketOut {}) = return e +addTickHsExpr e@(HsSpliceE {}) = return e +addTickHsExpr (HsProc x pat cmdtop) = + liftM2 (HsProc x) + (addTickLPat pat) + (liftL (addTickHsCmdTop) cmdtop) +addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) = + liftM (XExpr . WrapExpr . HsWrap w) $ + (addTickHsExpr e) -- Explicitly no tick on inside +addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) = + liftM (XExpr . ExpansionExpr . HsExpanded a) $ + (addTickHsExpr b) + +-- Others should never happen in expression content. +addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) + +addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) +addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present x e')) } +addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) + + +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) + -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do + let isOneOfMany = matchesOneOfMany matches + matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches + return $ mg { mg_alts = L l matches' } + +addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) + -> TM (Match GhcTc (LHsExpr GhcTc)) +addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats + , m_grhss = gRHSs }) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs + return $ match { m_grhss = gRHSs' } + +addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) + -> TM (GRHSs GhcTc (LHsExpr GhcTc)) +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded + return $ GRHSs x guarded' (L l local_binds') + where + binders = collectLocalBinders local_binds + +addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) + -> TM (GRHS GhcTc (LHsExpr GhcTc)) +addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do + (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts + (addTickGRHSBody isOneOfMany isLambda expr) + return $ GRHS x stmts' expr' + +addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr + TickAllFunctions | isLambda -> + addPathEntry "\\" $ + allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ + addTickHsExpr e0 + _otherwise -> + addTickLHsExprRHS expr + +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] + -> TM [ExprLStmt GhcTc] +addTickLStmts isGuard stmts = do + (stmts, _) <- addTickLStmts' isGuard stmts (return ()) + return stmts + +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a + -> TM ([ExprLStmt GhcTc], a) +addTickLStmts' isGuard lstmts res + = bindLocals (collectLStmtsBinders lstmts) $ + do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts + ; a <- res + ; return (lstmts', a) } + +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) + -> TM (Stmt GhcTc (LHsExpr GhcTc)) +addTickStmt _isGuard (LastStmt x e noret ret) = do + liftM3 (LastStmt x) + (addTickLHsExpr e) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickStmt _isGuard (BindStmt xbs pat e) = do + liftM4 (\b f -> BindStmt $ XBindStmtTc + { xbstc_bindOp = b + , xbstc_boundResultType = xbstc_boundResultType xbs + , xbstc_boundResultMult = xbstc_boundResultMult xbs + , xbstc_failOp = f + }) + (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs)) + (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs)) + (addTickLPat pat) + (addTickLHsExprRHS e) +addTickStmt isGuard (BodyStmt x e bind' guard') = do + liftM3 (BodyStmt x) + (addTick isGuard e) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickStmt _isGuard (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) + (addTickHsLocalBinds binds) +addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do + liftM3 (ParStmt x) + (mapM (addTickStmtAndBinders isGuard) pairs) + (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) + (addTickSyntaxExpr hpcSrcSpan bindExpr) +addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do + args' <- mapM (addTickApplicativeArg isGuard) args + return (ApplicativeStmt body_ty args' mb_join) + +addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts + , trS_by = by, trS_using = using + , trS_ret = returnExpr, trS_bind = bindExpr + , trS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- fmapMaybeM addTickLHsExprRHS by + t_u <- addTickLHsExprRHS using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr)) + return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u + , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } + +addTickStmt isGuard stmt@(RecStmt {}) + = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } + +addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e + | otherwise = addTickLHsExprRHS e + +addTickApplicativeArg + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) +addTickApplicativeArg isGuard (op, arg) = + liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) + where + addTickArg (ApplicativeArgOne m_fail pat expr isBody) = + ApplicativeArgOne + <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail + <*> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody + addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = + (ApplicativeArgMany x) + <$> addTickLStmts isGuard stmts + <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) + <*> addTickLPat pat + <*> pure ctxt + +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc + -> TM (ParStmtBlock GhcTc GhcTc) +addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = + liftM3 (ParStmtBlock x) + (addTickLStmts isGuard stmts) + (return ids) + (addTickSyntaxExpr hpcSrcSpan returnExpr) + +addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) +addTickHsLocalBinds (HsValBinds x binds) = + liftM (HsValBinds x) + (addTickHsValBinds binds) +addTickHsLocalBinds (HsIPBinds x binds) = + liftM (HsIPBinds x) + (addTickHsIPBinds binds) +addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) + +addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) + -> TM (HsValBindsLR GhcTc (GhcPass b)) +addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do + b <- liftM2 NValBinds + (mapM (\ (rec,binds') -> + liftM2 (,) + (return rec) + (addTickLHsBinds binds')) + binds) + (return sigs) + return $ XValBindsLR b +addTickHsValBinds _ = panic "addTickHsValBinds" + +addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) +addTickHsIPBinds (IPBinds dictbinds ipbinds) = + liftM2 IPBinds + (return dictbinds) + (mapM (liftL (addTickIPBind)) ipbinds) + +addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) +addTickIPBind (IPBind x nm e) = + liftM2 (IPBind x) + (return nm) + (addTickLHsExpr e) + +-- There is no location here, so we might need to use a context location?? +addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) +addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do + x' <- fmap unLoc (addTickLHsExpr (L pos x)) + return $ syn { syn_expr = x' } +addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc + +-- we do not walk into patterns. +addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) +addTickLPat pat = return pat + +addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) +addTickHsCmdTop (HsCmdTop x cmd) = + liftM2 HsCmdTop + (return x) + (addTickLHsCmd cmd) + +addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) +addTickLHsCmd (L pos c0) = do + c1 <- addTickHsCmd c0 + return $ L pos c1 + +addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) +addTickHsCmd (HsCmdLam x matchgroup) = + liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp x c e) = + liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) +{- +addTickHsCmd (OpApp e1 c2 fix c3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsCmd c2) + (return fix) + (addTickLHsCmd c3) +-} +addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) +addTickHsCmd (HsCmdCase x e mgs) = + liftM2 (HsCmdCase x) + (addTickLHsExpr e) + (addTickCmdMatchGroup mgs) +addTickHsCmd (HsCmdLamCase x mgs) = + liftM (HsCmdLamCase x) (addTickCmdMatchGroup mgs) +addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = + liftM3 (HsCmdIf x cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsCmd c2) + (addTickLHsCmd c3) +addTickHsCmd (HsCmdLet x (L l binds) c) = + bindLocals (collectLocalBinders binds) $ + liftM2 (HsCmdLet x . L l) + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsCmd c) +addTickHsCmd (HsCmdDo srcloc (L l stmts)) + = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) + ; return (HsCmdDo srcloc (L l stmts')) } + +addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = + liftM5 HsCmdArrApp + (return arr_ty) + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return lr) +addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = + liftM4 (HsCmdArrForm x) + (addTickLHsExpr e) + (return f) + (return fix) + (mapM (liftL (addTickHsCmdTop)) cmdtop) + +addTickHsCmd (XCmd (HsWrap w cmd)) = + liftM XCmd $ + liftM (HsWrap w) (addTickHsCmd cmd) + +-- Others should never happen in a command context. +--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) + +addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) + -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) +addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do + matches' <- mapM (liftL addTickCmdMatch) matches + return $ mg { mg_alts = L l matches' } + +addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) +addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickCmdGRHSs gRHSs + return $ match { m_grhss = gRHSs' } + +addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) +addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (liftL addTickCmdGRHS) guarded + return $ GRHSs x guarded' (L l local_binds') + where + binders = collectLocalBinders local_binds + +addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) +-- The *guards* are *not* Cmds, although the body is +-- C.f. addTickGRHS for the BinBox stuff +addTickCmdGRHS (GRHS x stmts cmd) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + stmts (addTickLHsCmd cmd) + ; return $ GRHS x stmts' expr' } + +addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] + -> TM [LStmt GhcTc (LHsCmd GhcTc)] +addTickLCmdStmts stmts = do + (stmts, _) <- addTickLCmdStmts' stmts (return ()) + return stmts + +addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a + -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) +addTickLCmdStmts' lstmts res + = bindLocals binders $ do + lstmts' <- mapM (liftL addTickCmdStmt) lstmts + a <- res + return (lstmts', a) + where + binders = collectLStmtsBinders lstmts + +addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) +addTickCmdStmt (BindStmt x pat c) = do + liftM2 (BindStmt x) + (addTickLPat pat) + (addTickLHsCmd c) +addTickCmdStmt (LastStmt x c noret ret) = do + liftM3 (LastStmt x) + (addTickLHsCmd c) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickCmdStmt (BodyStmt x c bind' guard') = do + liftM3 (BodyStmt x) + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickCmdStmt (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) + (addTickHsLocalBinds binds) +addTickCmdStmt stmt@(RecStmt {}) + = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } +addTickCmdStmt ApplicativeStmt{} = + panic "ToDo: addTickCmdStmt ApplicativeLastStmt" + +-- Others should never happen in a command context. +addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) + +addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc) +addTickHsRecordBinds (HsRecFields fields dd) + = do { fields' <- mapM addTickHsRecField fields + ; return (HsRecFields fields' dd) } + +addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) + -> TM (LHsRecField' id (LHsExpr GhcTc)) +addTickHsRecField (L l (HsRecField id expr pun)) + = do { expr' <- addTickLHsExpr expr + ; return (L l (HsRecField id expr' pun)) } + + +addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) +addTickArithSeqInfo (From e1) = + liftM From + (addTickLHsExpr e1) +addTickArithSeqInfo (FromThen e1 e2) = + liftM2 FromThen + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromTo e1 e2) = + liftM2 FromTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromThenTo e1 e2 e3) = + liftM3 FromThenTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (addTickLHsExpr e3) + +data TickTransState = TT { tickBoxCount:: !Int + , mixEntries :: [MixEntry_] + , ccIndices :: !CostCentreState + } + +addMixEntry :: MixEntry_ -> TM Int +addMixEntry ent = do + c <- tickBoxCount <$> getState + setState $ \st -> + st { tickBoxCount = c + 1 + , mixEntries = ent : mixEntries st + } + return c + +data TickTransEnv = TTE { fileName :: FastString + , density :: TickDensity + , tte_dflags :: DynFlags + , exports :: NameSet + , inlines :: VarSet + , declPath :: [String] + , inScope :: VarSet + , blackList :: Set RealSrcSpan + , this_mod :: Module + , tickishType :: TickishType + } + +-- deriving Show + +data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes + deriving (Eq) + +coveragePasses :: DynFlags -> [TickishType] +coveragePasses dflags = + ifa (breakpointsEnabled dflags) Breakpoints $ + ifa (gopt Opt_Hpc dflags) HpcTicks $ + ifa (sccProfilingEnabled dflags && + profAuto dflags /= NoProfAuto) ProfNotes $ + ifa (debugLevel dflags > 0) SourceNotes [] + where ifa f x xs | f = x:xs + | otherwise = xs + +-- | Should we produce 'Breakpoint' ticks? +breakpointsEnabled :: DynFlags -> Bool +breakpointsEnabled dflags = hscTarget dflags == HscInterpreted + +-- | Tickishs that only make sense when their source code location +-- refers to the current file. This might not always be true due to +-- LINE pragmas in the code - which would confuse at least HPC. +tickSameFileOnly :: TickishType -> Bool +tickSameFileOnly HpcTicks = True +tickSameFileOnly _other = False + +type FreeVars = OccEnv Id +noFVs :: FreeVars +noFVs = emptyOccEnv + +-- Note [freevars] +-- For breakpoints we want to collect the free variables of an +-- expression for pinning on the HsTick. We don't want to collect +-- *all* free variables though: in particular there's no point pinning +-- on free variables that are will otherwise be in scope at the GHCi +-- prompt, which means all top-level bindings. Unfortunately detecting +-- top-level bindings isn't easy (collectHsBindsBinders on the top-level +-- bindings doesn't do it), so we keep track of a set of "in-scope" +-- variables in addition to the free variables, and the former is used +-- to filter additions to the latter. This gives us complete control +-- over what free variables we track. + +newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } + deriving (Functor) + -- a combination of a state monad (TickTransState) and a writer + -- monad (FreeVars). + +instance Applicative TM where + pure a = TM $ \ _env st -> (a,noFVs,st) + (<*>) = ap + +instance Monad TM where + (TM m) >>= k = TM $ \ env st -> + case m env st of + (r1,fv1,st1) -> + case unTM (k r1) env st1 of + (r2,fv2,st2) -> + (r2, fv1 `plusOccEnv` fv2, st2) + +instance HasDynFlags TM where + getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) + +-- | Get the next HPC cost centre index for a given centre name +getCCIndexM :: FastString -> TM CostCentreIndex +getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ + ccIndices st + in (idx, noFVs, st { ccIndices = is' }) + +getState :: TM TickTransState +getState = TM $ \ _ st -> (st, noFVs, st) + +setState :: (TickTransState -> TickTransState) -> TM () +setState f = TM $ \ _ st -> ((), noFVs, f st) + +getEnv :: TM TickTransEnv +getEnv = TM $ \ env st -> (env, noFVs, st) + +withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a +withEnv f (TM m) = TM $ \ env st -> + case m (f env) st of + (a, fvs, st') -> (a, fvs, st') + +getDensity :: TM TickDensity +getDensity = TM $ \env st -> (density env, noFVs, st) + +ifDensity :: TickDensity -> TM a -> TM a -> TM a +ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el + +getFreeVars :: TM a -> TM (FreeVars, a) +getFreeVars (TM m) + = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') + +freeVar :: Id -> TM () +freeVar id = TM $ \ env st -> + if id `elemVarSet` inScope env + then ((), unitOccEnv (nameOccName (idName id)) id, st) + else ((), noFVs, st) + +addPathEntry :: String -> TM a -> TM a +addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) + +getPathEntry :: TM [String] +getPathEntry = declPath `liftM` getEnv + +getFileName :: TM FastString +getFileName = fileName `liftM` getEnv + +isGoodSrcSpan' :: SrcSpan -> Bool +isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' (UnhelpfulSpan _) = False + +isGoodTickSrcSpan :: SrcSpan -> TM Bool +isGoodTickSrcSpan pos = do + file_name <- getFileName + tickish <- tickishType `liftM` getEnv + let need_same_file = tickSameFileOnly tickish + same_file = Just file_name == srcSpanFileName_maybe pos + return (isGoodSrcSpan' pos && (not need_same_file || same_file)) + +ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a +ifGoodTickSrcSpan pos then_code else_code = do + good <- isGoodTickSrcSpan pos + if good then then_code else else_code + +bindLocals :: [Id] -> TM a -> TM a +bindLocals new_ids (TM m) + = TM $ \ env st -> + case m env{ inScope = inScope env `extendVarSetList` new_ids } st of + (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') + where occs = [ nameOccName (idName id) | id <- new_ids ] + +isBlackListed :: SrcSpan -> TM Bool +isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) +isBlackListed (UnhelpfulSpan _) = return False + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocTickBox boxLabel countEntries topOnly pos m = + ifGoodTickSrcSpan pos (do + (fvs, e) <- getFreeVars m + env <- getEnv + tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) + return (L pos (HsTick noExtField tickish (L pos e))) + ) (do + e <- m + return (L pos e) + ) + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars + -> TM (Maybe (Tickish Id)) +allocATickBox boxLabel countEntries topOnly pos fvs = + ifGoodTickSrcSpan pos (do + let + mydecl_path = case boxLabel of + TopLevelBox x -> x + LocalBox xs -> xs + _ -> panic "allocATickBox" + tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path + return (Just tickish) + ) (return Nothing) + + +mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] + -> TM (Tickish Id) +mkTickish boxLabel countEntries topOnly pos fvs decl_path = do + + let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs + -- unlifted types cause two problems here: + -- * we can't bind them at the GHCi prompt + -- (bindLocalsAtBreakpoint already filters them out), + -- * the simplifier might try to substitute a literal for + -- the Id, and we can't handle that. + + me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) + + cc_name | topOnly = head decl_path + | otherwise = concat (intersperse "." decl_path) + + dflags <- getDynFlags + env <- getEnv + case tickishType env of + HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me + + ProfNotes -> do + let nm = mkFastString cc_name + flavour <- HpcCC <$> getCCIndexM nm + let cc = mkUserCC nm (this_mod env) pos flavour + count = countEntries && gopt Opt_ProfCountEntries dflags + return $ ProfNote cc count True{-scopes-} + + Breakpoints -> Breakpoint <$> addMixEntry me <*> pure ids + + SourceNotes | RealSrcSpan pos' _ <- pos -> + return $ SourceNote pos' cc_name + + _otherwise -> panic "mkTickish: bad source span!" + + +allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocBinTickBox boxLabel pos m = do + env <- getEnv + case tickishType env of + HpcTicks -> do e <- liftM (L pos) m + ifGoodTickSrcSpan pos + (mkBinTickBoxHpc boxLabel pos e) + (return e) + _other -> allocTickBox (ExpBox False) False False pos m + +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc + -> TM (LHsExpr GhcTc) +mkBinTickBoxHpc boxLabel pos e = do + env <- getEnv + binTick <- HsBinTick noExtField + <$> addMixEntry (pos,declPath env, [],boxLabel True) + <*> addMixEntry (pos,declPath env, [],boxLabel False) + <*> pure e + tick <- HpcTick (this_mod env) + <$> addMixEntry (pos,declPath env, [],ExpBox False) + return $ L pos $ HsTick noExtField tick (L pos binTick) + +mkHpcPos :: SrcSpan -> HpcPos +mkHpcPos pos@(RealSrcSpan s _) + | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, + srcSpanStartCol s, + srcSpanEndLine s, + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. +mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" + +hpcSrcSpan :: SrcSpan +hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") + +matchesOneOfMany :: [LMatch GhcTc body] -> Bool +matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 + where + matchCount :: LMatch GhcTc body -> Int + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) + = length grhss + +type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) + +-- For the hash value, we hash everything: the file name, +-- the timestamp of the original source file, the tab stop, +-- and the mix entries. We cheat, and hash the show'd string. +-- This hash only has to be hashed at Mix creation time, +-- and is for sanity checking only. + +mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int +mixHash file tm tabstop entries = fromIntegral $ hashString + (show $ Mix file tm 0 tabstop entries) + +{- +************************************************************************ +* * +* initialisation +* * +************************************************************************ + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +static void hpc_init_Main(void) __attribute__((constructor)); +static void hpc_init_Main(void) +{extern StgWord64 _hpc_tickboxes_Main_hpc[]; + hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} +-} + +hpcInitCode :: Module -> HpcInfo -> SDoc +hpcInitCode _ (NoHpcInfo {}) = Outputable.empty +hpcInitCode this_mod (HpcInfo tickCount hashNo) + = vcat + [ text "static void hpc_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hpc_init_" <> ppr this_mod <> text "(void)" + , braces (vcat [ + text "extern StgWord64 " <> tickboxes <> + text "[]" <> semi, + text "hs_hpc_module" <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + ]) + ] + where + tickboxes = ppr (mkHpcTicksLabel $ this_mod) + + module_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (moduleNameFS (moduleName this_mod))) + package_name = hcat (map (text.charToC) $ BS.unpack $ + bytesFS (unitFS (moduleUnit this_mod))) + full_name_str + | moduleUnit this_mod == mainUnit + = module_name + | otherwise + = package_name <> char '/' <> module_name diff --git a/GHC/HsToCore/Docs.hs b/GHC/HsToCore/Docs.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Docs.hs @@ -0,0 +1,357 @@ +-- | Extract docs from the renamer output so they can be serialized. +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Docs where + +import GHC.Prelude +import GHC.Data.Bag +import GHC.Hs.Binds +import GHC.Hs.Doc +import GHC.Hs.Decls +import GHC.Hs.Extension +import GHC.Hs.Type +import GHC.Hs.Utils +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Tc.Types + +import Control.Applicative +import Data.Bifunctor (first) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Semigroup + +-- | Extract docs from renamer output. +extractDocs :: TcGblEnv + -> (Maybe HsDocString, DeclDocMap, ArgDocMap) + -- ^ + -- 1. Module header + -- 2. Docs on top level declarations + -- 3. Docs on arguments +extractDocs TcGblEnv { tcg_semantic_mod = mod + , tcg_rn_decls = mb_rn_decls + , tcg_insts = insts + , tcg_fam_insts = fam_insts + , tcg_doc_hdr = mb_doc_hdr + } = + (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map) + where + (doc_map, arg_map) = maybe (M.empty, M.empty) + (mkMaps local_insts) + mb_decls_with_docs + mb_decls_with_docs = topDecls <$> mb_rn_decls + local_insts = filter (nameIsLocalOrFrom mod) + $ map getName insts ++ map getName fam_insts + +-- | Create decl and arg doc-maps by looping through the declarations. +-- For each declaration, find its names, its subordinates, and its doc strings. +mkMaps :: [Name] + -> [(LHsDecl GhcRn, [HsDocString])] + -> (Map Name (HsDocString), Map Name (Map Int (HsDocString))) +mkMaps instances decls = + ( f' (map (nubByName fst) decls') + , f (filterMapping (not . M.null) args) + ) + where + (decls', args) = unzip (map mappings decls) + + f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString + f' = M.fromListWith appendDocs . concat + + filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] + filterMapping p = map (filter (p . snd)) + + mappings :: (LHsDecl GhcRn, [HsDocString]) + -> ( [(Name, HsDocString)] + , [(Name, Map Int (HsDocString))] + ) + mappings (L (RealSrcSpan l _) decl, docStrs) = + (dm, am) + where + doc = concatDocs docStrs + args = declTypeDocs decl + + subs :: [(Name, [(HsDocString)], Map Int (HsDocString))] + subs = subordinates instanceMap decl + + (subDocs, subArgs) = + unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) + + ns = names l decl + subNs = [ n | (n, _, _) <- subs ] + dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] + am = [(n, args) | n <- ns] ++ zip subNs subArgs + mappings (L (UnhelpfulSpan _) _, _) = ([], []) + + instanceMap :: Map RealSrcSpan Name + instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] + + names :: RealSrcSpan -> HsDecl GhcRn -> [Name] + names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. + names _ decl = getMainDeclBinder decl + +{- +Note [1]: +--------- +We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +inside them. That should work for normal user-written instances (from +looking at GHC sources). We can assume that commented instances are +user-written. This lets us relate Names (from ClsInsts) to comments +(associated with InstDecls and DerivDecls). +-} + +getMainDeclBinder :: (CollectPass (GhcPass p)) + => HsDecl (GhcPass p) + -> [IdP (GhcPass p)] +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ = [] + +sigNameNoLoc :: Sig pass -> [IdP pass] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] + +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +getInstLoc :: InstDecl (GhcPass p) -> SrcSpan +getInstLoc = \case + ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) + -- The Names of data and type family instances have their SrcSpan's attached + -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have + -- its SrcSpan attached here: + -- type family Foo a + -- type instance Foo Int = Bool + -- ^^^ + DataFamInstD _ (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l + -- Since CoAxioms' Names refer to the whole line for type family instances + -- in particular, we need to dig a bit deeper to pull out the entire + -- equation. This does not happen for data family instances, for some reason. + TyFamInstD _ (TyFamInstDecl + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l + +-- | Get all subordinate declarations inside a declaration, and their docs. +-- A subordinate declaration is something like the associate type or data +-- family of a type class. +subordinates :: Map RealSrcSpan Name + -> HsDecl GhcRn + -> [(Name, [(HsDocString)], Map Int (HsDocString))] +subordinates instMap decl = case decl of + InstD _ (ClsInstD _ d) -> do + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn + + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, declTypeDocs d) + | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + dataSubs :: HsDataDefn GhcRn + -> [(Name, [HsDocString], Map Int (HsDocString))] + dataSubs dd = constrs ++ fields ++ derivs + where + cons = map unLoc $ (dd_cons dd) + constrs = [ ( unLoc cname + , maybeToList $ fmap unLoc $ con_doc c + , conArgDocs c) + | c <- cons, cname <- getConNames c ] + fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) + | RecCon flds <- map getConArgs cons + , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) + , (L _ n) <- ns ] + derivs = [ (instName, [unLoc doc], M.empty) + | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ + concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd + , Just instName <- [lookupSrcSpan l instMap] ] + + extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) + extract_deriv_ty (L l ty) = + case ty of + -- deriving (forall a. C a {- ^ Doc comment -}) + HsForAllTy{ hst_tele = HsForAllInvis{} + , hst_body = L _ (HsDocTy _ _ doc) } + -> Just (l, doc) + -- deriving (C a {- ^ Doc comment -}) + HsDocTy _ _ doc -> Just (l, doc) + _ -> Nothing + +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) +conArgDocs con = case getConArgs con of + PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1), + unLoc (hsScaledThing arg2)] ++ ret) + RecCon _ -> go 1 ret + where + go n = M.fromList . catMaybes . zipWith f [n..] + where + f n (HsDocTy _ _ lds) = Just (n, unLoc lds) + f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds) + f _ _ = Nothing + + ret = case con of + ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] + _ -> [] + +isValD :: HsDecl a -> Bool +isValD (ValD _ _) = True +isValD _ = False + +-- | All the sub declarations of a class (that we handle), ordered by +-- source location, with documentation attached if it exists. +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +classDecls class_ = filterDecls . collectDocs . sortLocated $ decls + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs (DocD noExtField) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ + sigs = mkDecls tcdSigs (SigD noExtField) class_ + ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) +declTypeDocs = \case + SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty)) + SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty)) + TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) + _ -> M.empty + +nubByName :: (a -> Name) -> [a] -> [a] +nubByName f ns = go emptyNameSet ns + where + go _ [] = [] + go s (x:xs) + | y `elemNameSet` s = go s xs + | otherwise = let !s' = extendNameSet s y + in x : go s' xs + where + y = f x + +-- | Extract function argument docs from inside types. +typeDocs :: HsType GhcRn -> Map Int (HsDocString) +typeDocs = go 0 + where + go n = \case + HsForAllTy { hst_body = ty } -> go n (unLoc ty) + HsQualTy { hst_body = ty } -> go n (unLoc ty) + HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) + HsFunTy _ _ _ ty -> go (n+1) (unLoc ty) + HsDocTy _ _ doc -> M.singleton n (unLoc doc) + _ -> M.empty + +-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists. +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls = filterClasses . filterDecls . collectDocs . sortLocated . ungroup + +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] +ungroup group_ = + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ + mkDecls hs_derivds (DerivD noExtField) group_ ++ + mkDecls hs_defds (DefD noExtField) group_ ++ + mkDecls hs_fords (ForD noExtField) group_ ++ + mkDecls hs_docs (DocD noExtField) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExtField) group_ + where + typesigs :: HsValBinds GhcRn -> [LSig GhcRn] + typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig + typesigs ValBinds{} = error "expected XValBindsLR" + + valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn] + valbinds (XValBindsLR (NValBinds binds _)) = + concatMap bagToList . snd . unzip $ binds + valbinds ValBinds{} = error "expected XValBindsLR" + +-- | Collect docs and attach them to the right declarations. +-- +-- A declaration may have multiple doc strings attached to it. +collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] +-- ^ This is an example. +collectDocs = go [] Nothing + where + go docs mprev decls = case (decls, mprev) of + ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds + ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds + ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds + (d : ds, Nothing) -> go docs (Just d) ds + (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds + ([] , Nothing) -> [] + ([] , Just prev) -> finished prev docs [] + + finished decl docs rest = (decl, reverse docs) : rest + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterDecls = filter (isHandled . unLoc . fst) + where + isHandled (ForD _ (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (DerivD {}) = True + isHandled (SigD _ d) = isUserSig d + isHandled (ValD {}) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD {}) = True + isHandled _ = False + + +-- | Go through all class declarations and filter their sub-declarations +filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterClasses = map (first (mapLoc filterClass)) + where + filterClass (TyClD x c@(ClassDecl {})) = + TyClD x $ c { tcdSigs = + filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } + filterClass d = d + +-- | Was this signature given by the user? +isUserSig :: Sig name -> Bool +isUserSig TypeSig {} = True +isUserSig ClassOpSig {} = True +isUserSig PatSynSig {} = True +isUserSig _ = False + +-- | Take a field of declarations from a data structure and create HsDecls +-- using the given constructor +mkDecls :: (struct -> [Located decl]) + -> (decl -> hsDecl) + -> struct + -> [Located hsDecl] +mkDecls field con = map (mapLoc con) . field diff --git a/GHC/HsToCore/Expr.hs b/GHC/HsToCore/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Expr.hs @@ -0,0 +1,1330 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring expressions. +-} + +{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Expr + ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds + , dsValBinds, dsLit, dsSyntaxExpr + , dsHandleMonadicFailure + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.HsToCore.Match +import GHC.HsToCore.Match.Literal +import GHC.HsToCore.Binds +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.ListComp +import GHC.HsToCore.Utils +import GHC.HsToCore.Arrows +import GHC.HsToCore.Monad +import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Core.FamInstEnv( topNormaliseType ) +import GHC.HsToCore.Quote +import GHC.Hs + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.Coercion( Coercion ) +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make + +import GHC.Driver.Session +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Var.Env +import GHC.Unit.Module +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCo.Ppr( pprWithTYPE ) +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Types.Basic +import GHC.Data.Maybe +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Outputable as Outputable +import GHC.Core.PatSyn +import Control.Monad +import Data.List.NonEmpty ( nonEmpty ) + +import qualified GHC.LanguageExtensions as LangExt + +{- +************************************************************************ +* * + dsLocalBinds, dsValBinds +* * +************************************************************************ +-} + +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body +dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body + +------------------------- +-- caller sets location +dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsValBinds (XValBindsLR (NValBinds binds _)) body + = foldrM ds_val_bind body binds +dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" + +------------------------- +dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsIPBinds (IPBinds ev_binds ip_binds) body + = do { ds_binds <- dsTcEvBinds ev_binds + ; let inner = mkCoreLets ds_binds body + -- The dict bindings may not be in + -- dependency order; hence Rec + ; foldrM ds_ip_bind inner ip_binds } + where + ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body + = do e' <- dsLExpr e + return (Let (NonRec n e') body) + +------------------------- +-- caller sets location +ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr +-- Special case for bindings which bind unlifted variables +-- We need to do a case right away, rather than building +-- a tuple and doing selections. +-- Silently ignore INLINE and SPECIALISE pragmas... +ds_val_bind (NonRecursive, hsbinds) body + | [L loc bind] <- bagToList hsbinds + -- Non-recursive, non-overloaded bindings only come in ones + -- ToDo: in some bizarre case it's conceivable that there + -- could be dict binds in the 'binds'. (See the notes + -- below. Then pattern-match would fail. Urk.) + , isUnliftedHsBind bind + = putSrcSpanDs loc $ + -- see Note [Strict binds checks] in GHC.HsToCore.Binds + if is_polymorphic bind + then errDsCoreExpr (poly_bind_err bind) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. #6078. + + else do { when (looksLazyPatBind bind) $ + warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) + -- Complain about a binding that looks lazy + -- e.g. let I# y = x in ... + -- Remember, in checkStrictBinds we are going to do strict + -- matching, so (for software engineering reasons) we insist + -- that the strictness is manifest on each binding + -- However, lone (unboxed) variables are ok + + + ; dsUnliftedBind bind body } + where + is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) + = not (null tvs && null evs) + is_polymorphic _ = False + + unlifted_must_be_bang bind + = hang (text "Pattern bindings containing unlifted types should use" $$ + text "an outermost bang pattern:") + 2 (ppr bind) + + poly_bind_err bind + = hang (text "You can't mix polymorphic and unlifted bindings:") + 2 (ppr bind) $$ + text "Probable fix: add a type signature" + +ds_val_bind (is_rec, binds) _body + | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds + = ASSERT( isRec is_rec ) + errDsCoreExpr $ + hang (text "Recursive bindings for unlifted types aren't allowed:") + 2 (vcat (map ppr (bagToList binds))) + +-- Ordinary case for bindings; none should be unlifted +ds_val_bind (is_rec, binds) body + = do { MASSERT( isRec is_rec || isSingletonBag binds ) + -- we should never produce a non-recursive list of multiple binds + + ; (force_vars,prs) <- dsLHsBinds binds + ; let body' = foldr seqVar body force_vars + ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) + case prs of + [] -> return body + _ -> return (Let (Rec prs) body') } + -- Use a Rec regardless of is_rec. + -- Why? Because it allows the binds to be all + -- mixed up, which is what happens in one rare case + -- Namely, for an AbsBind with no tyvars and no dicts, + -- but which does have dictionary bindings. + -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS] + -- It turned out that wrapping a Rec here was the easiest solution + -- + -- NB The previous case dealt with unlifted bindings, so we + -- only have to deal with lifted ones now; so Rec is ok + +------------------ +dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr +dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = lbinds }) body + = do { let body1 = foldr bind_export body exports + bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b + ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) + body1 lbinds + ; ds_binds <- dsTcEvBinds_s ev_binds + ; return (mkCoreLets ds_binds body2) } + +dsUnliftedBind (FunBind { fun_id = L l fun + , fun_matches = matches + , fun_ext = co_fn + , fun_tick = tick }) body + -- Can't be a bang pattern (that looks like a PatBind) + -- so must be simply unboxed + = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) + Nothing matches + ; MASSERT( null args ) -- Functions aren't lifted + ; MASSERT( isIdHsWrapper co_fn ) + ; let rhs' = mkOptTickBox tick rhs + ; return (bindNonRec fun rhs' body) } + +dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc _ ty }) body + = -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + do { rhs_deltas <- checkGuardMatches PatBindGuards grhss + ; rhs <- dsGuarded grhss ty (nonEmpty rhs_deltas) + ; let upat = unLoc pat + eqn = EqnInfo { eqn_pats = [upat], + eqn_orig = FromSource, + eqn_rhs = cantFailMatchResult body } + ; var <- selectMatchVar Many upat + -- `var` will end up in a let binder, so the multiplicity + -- doesn't matter. + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (bindNonRec var rhs result) } + +dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + +{- +************************************************************************ +* * +* Variables, constructors, literals * +* * +************************************************************************ +-} + +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr + +dsLExpr (L loc e) + = putSrcSpanDs loc $ + do { core_expr <- dsExpr e + -- uncomment this check to test the hsExprType function in GHC.Tc.Utils.Zonk + -- ; MASSERT2( exprType core_expr `eqType` hsExprType e + -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ + -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) + ; return core_expr } + +-- | Variant of 'dsLExpr' that ensures that the result is not levity +-- polymorphic. This should be used when the resulting expression will +-- be an argument to some other function. +-- See Note [Levity polymorphism checking] in "GHC.HsToCore.Monad" +-- See Note [Levity polymorphism invariants] in "GHC.Core" +dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsLExprNoLP (L loc e) + = putSrcSpanDs loc $ + do { e' <- dsExpr e + ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) + ; return e' } + +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsExpr (HsPar _ e) = dsLExpr e +dsExpr (ExprWithTySig _ e _) = dsLExpr e +dsExpr (HsVar _ (L _ var)) = dsHsVar var +dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them +dsExpr (HsConLikeOut _ con) = dsConLike con +dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" +dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel" + +dsExpr (HsLit _ lit) + = do { warnAboutOverflowedLit lit + ; dsLit (convertLit lit) } + +dsExpr (HsOverLit _ lit) + = do { warnAboutOverflowedOverLit lit + ; dsOverLit lit } + +dsExpr e@(XExpr expansion) + = case expansion of + ExpansionExpr (HsExpanded _ b) -> dsExpr b + WrapExpr {} -> dsHsWrapped e + +dsExpr (NegApp _ (L loc + (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) + neg_expr) + = do { expr' <- putSrcSpanDs loc $ do + { warnAboutOverflowedOverLit + (lit { ol_val = HsIntegral (negateIntegralLit i) }) + ; dsOverLit lit } + ; dsSyntaxExpr neg_expr [expr'] } + +dsExpr (NegApp _ expr neg_expr) + = do { expr' <- dsLExpr expr + ; dsSyntaxExpr neg_expr [expr'] } + +dsExpr (HsLam _ a_Match) + = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match + +dsExpr (HsLamCase _ matches) + = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches + ; return $ Lam discrim_var matching_code } + +dsExpr e@(HsApp _ fun arg) + = do { fun' <- dsLExpr fun + ; dsWhenNoErrs (dsLExprNoLP arg) + (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } + +dsExpr e@(HsAppType {}) = dsHsWrapped e + +{- +Note [Desugaring vars] +~~~~~~~~~~~~~~~~~~~~~~ +In one situation we can get a *coercion* variable in a HsVar, namely +the support method for an equality superclass: + class (a~b) => C a b where ... + instance (blah) => C (T a) (T b) where .. +Then we get + $dfCT :: forall ab. blah => C (T a) (T b) + $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) + + $c$p1C :: forall ab. blah => (T a ~ T b) + $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g + +That 'g' in the 'in' part is an evidence variable, and when +converting to core it must become a CO. + + +Note [Desugaring operator sections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Desugaring left sections with -XPostfixOperators is straightforward: convert +(expr `op`) to (op expr). + +Without -XPostfixOperators it's a bit more tricky. At first it looks as if we +can convert + + (expr `op`) + +naively to + + \x -> op expr x + +But no! expr might be a redex, and we can lose laziness badly this +way. Consider + + map (expr `op`) xs + +for example. If expr were a redex then eta-expanding naively would +result in multiple evaluations where the user might only have expected one. + +So we convert instead to + + let y = expr in \x -> op y x + +Also, note that we must do this for both right and (perhaps surprisingly) left +sections. Why are left sections necessary? Consider the program (found in #18151), + + seq (True `undefined`) () + +according to the Haskell Report this should reduce to () (as it specifies +desugaring via eta expansion). However, if we fail to eta expand we will rather +bottom. Consequently, we must eta expand even in the case of a left section. + +If `expr` is actually just a variable, say, then the simplifier +will inline `y`, eliminating the redundant `let`. + +Note that this works even in the case that `expr` is unlifted. In this case +bindNonRec will automatically do the right thing, giving us: + + case expr of y -> (\x -> op y x) + +See #18151. +-} + +dsExpr e@(OpApp _ e1 op e2) + = -- for the type of y, we need the type of op's 2nd argument + do { op' <- dsLExpr op + ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) + (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } + +-- dsExpr (SectionL op expr) === (expr `op`) ~> \y -> op expr y +-- +-- See Note [Desugaring operator sections]. +-- N.B. this also must handle postfix operator sections due to -XPostfixOperators. +dsExpr e@(SectionL _ expr op) = do + postfix_operators <- xoptM LangExt.PostfixOperators + if postfix_operators then + -- Desugar (e !) to ((!) e) + do { op' <- dsLExpr op + ; dsWhenNoErrs (dsLExprNoLP expr) $ \expr' -> + mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr' } + else do + core_op <- dsLExpr op + x_core <- dsLExpr expr + case splitFunTys (exprType core_op) of + -- Binary operator section + (x_ty:y_ty:_, _) -> do + dsWhenNoErrs + (newSysLocalsDsNoLP [x_ty, y_ty]) + (\[x_id, y_id] -> + bindNonRec x_id x_core + $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e) + core_op [Var x_id, Var y_id])) + + -- Postfix operator section + (_:_, _) -> do + return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core + + _ -> pprPanic "dsExpr(SectionL)" (ppr e) + +-- dsExpr (SectionR op expr) === (`op` expr) ~> \x -> op x expr +-- +-- See Note [Desugaring operator sections]. +dsExpr e@(SectionR _ op expr) = do + core_op <- dsLExpr op + let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) + y_core <- dsLExpr expr + dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty]) + (\[x_id, y_id] -> bindNonRec y_id y_core $ + Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) + core_op [Var x_id, Var y_id])) + +dsExpr (ExplicitTuple _ tup_args boxity) + = do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty))) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDsNoLP mult ty + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (L _ (Present _ expr)) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExprNoLP expr + ; return (lam_vars, core_expr : args) } + + ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) + -- The reverse is because foldM goes left-to-right + (\(lam_vars, args) -> + mkCoreLams lam_vars $ + mkCoreTupBoxity boxity args) } + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + +dsExpr (ExplicitSum types alt arity expr) + = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types) + +dsExpr (HsPragE _ prag expr) = + ds_prag_expr prag expr + +dsExpr (HsCase _ discrim matches) + = do { core_discrim <- dsLExpr discrim + ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches + ; return (bindNonRec discrim_var core_discrim matching_code) } + +-- Pepe: The binds are in scope in the body but NOT in the binding group +-- This is to avoid silliness in breakpoints +dsExpr (HsLet _ binds body) = do + body' <- dsLExpr body + dsLocalBinds binds body' + +-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) +-- because the interpretation of `stmts' depends on what sort of thing it is. +-- +dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty +dsExpr (HsDo _ ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts +dsExpr (HsDo _ ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts +dsExpr (HsDo _ ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts +dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts + +dsExpr (HsIf _ guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; return $ mkIfThenElse pred b1 b2 } + +dsExpr (HsMultiIf res_ty alts) + | null alts + = mkErrorExpr + + | otherwise + = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds) + ; rhss_deltas <- checkGuardMatches IfAlt grhss + ; match_result <- dsGRHSs IfAlt grhss res_ty (nonEmpty rhss_deltas) + ; error_expr <- mkErrorExpr + ; extractMatchResult match_result error_expr } + where + mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty + (text "multi-way if") + +{- +\noindent +\underline{\bf Various data construction things} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} + +dsExpr (ExplicitList elt_ty wit xs) + = dsExplicitList elt_ty wit xs + +dsExpr (ArithSeq expr witness seq) + = case witness of + Nothing -> dsArithSeq expr seq + Just fl -> do { newArithSeq <- dsArithSeq expr seq + ; dsSyntaxExpr fl [newArithSeq] } + +{- +Static Pointers +~~~~~~~~~~~~~~~ + +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. + + g = ... static f ... +==> + g = ... makeStatic loc f ... +-} + +dsExpr (HsStatic _ expr@(L loc _)) = do + expr_ds <- dsLExprNoLP expr + let ty = exprType expr_ds + makeStaticId <- dsLookupGlobalId makeStaticName + + dflags <- getDynFlags + let platform = targetPlatform dflags + let (line, col) = case loc of + RealSrcSpan r _ -> + ( srcLocLine $ realSrcSpanStart r + , srcLocCol $ realSrcSpanStart r + ) + _ -> (0, 0) + srcLoc = mkCoreConApps (tupleDataCon Boxed 2) + [ Type intTy , Type intTy + , mkIntExprInt platform line, mkIntExprInt platform col + ] + + putSrcSpanDs loc $ return $ + mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] + +{- +\noindent +\underline{\bf Record construction and update} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record construction we do this (assuming T has three arguments) +\begin{verbatim} + T { op2 = e } +==> + let err = /\a -> recConErr a + T (recConErr t1 "M.hs/230/op1") + e + (recConErr t1 "M.hs/230/op3") +\end{verbatim} +@recConErr@ then converts its argument string into a proper message +before printing it as +\begin{verbatim} + M.hs, line 230: missing field op1 was evaluated +\end{verbatim} + +We also handle @C{}@ as valid construction syntax for an unlabelled +constructor @C@, setting all of @C@'s fields to bottom. +-} + +dsExpr (RecordCon { rcon_flds = rbinds + , rcon_ext = RecordConTc { rcon_con_expr = con_expr + , rcon_con_like = con_like }}) + = do { con_expr' <- dsExpr con_expr + ; let + (arg_tys, _) = tcSplitFunTys (exprType con_expr') + -- A newtype in the corner should be opaque; + -- hence TcType.tcSplitFunTys + + mk_arg (arg_ty, fl) + = case findField (rec_flds rbinds) (flSelector fl) of + (rhs:rhss) -> ASSERT( null rhss ) + dsLExprNoLP rhs + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) + unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty + + labels = conLikeFieldLabels con_like + + ; con_args <- if null labels + then mapM unlabelled_bottom (map scaledThing arg_tys) + else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels) + + ; return (mkCoreApps con_expr' con_args) } + +{- +Record update is a little harder. Suppose we have the decl: +\begin{verbatim} + data T = T1 {op1, op2, op3 :: Int} + | T2 {op4, op2 :: Int} + | T3 +\end{verbatim} +Then we translate as follows: +\begin{verbatim} + r { op2 = e } +===> + let op2 = e in + case r of + T1 op1 _ op3 -> T1 op1 op2 op3 + T2 op4 _ -> T2 op4 op2 + other -> recUpdError "M.hs/230" +\end{verbatim} +It's important that we use the constructor Ids for @T1@, @T2@ etc on the +RHSs, and do not generate a Core constructor application directly, because the constructor +might do some argument-evaluation first; and may have to throw away some +dictionaries. + +Note [Update for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b where + MkT :: { foo :: a } -> T a Int + + upd :: T s t -> s -> T s t + upd z y = z { foo = y} + +We need to get this: + $WMkT :: a -> T a Int + MkT :: (b ~# Int) => a -> T a b + + upd = /\s t. \(z::T s t) (y::s) -> + case z of + MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co) + +Note the final cast + T (Refl s) (Sym co) :: T s Int ~ T s t +which uses co, bound by the GADT match. This is the wrap_co coercion +in wrapped_rhs. How do we produce it? + +* Start with raw materials + tc, the tycon: T + univ_tvs, the universally quantified tyvars of MkT: a,b + NB: these are in 1-1 correspondence with the tyvars of tc + +* Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co) + We replaced + a by (Refl s) since 's' instantiates 'a' + b by (Sym co) since 'b' is in the data-con's EqSpec + +* Then form the coercion T (Refl s) (Sym co) + +It gets more complicated when data families are involved (#18809). +Consider + data family F x + data instance F (a,b) where + MkF :: { foo :: Int } -> F (Int,b) + + bar :: F (s,t) -> Int -> F (s,t) + bar z y = z { foo = y} + +We have + data R:FPair a b where + MkF :: { foo :: Int } -> R:FPair Int b + + $WMkF :: Int -> F (Int,b) + MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b + + bar :: F (s,t) -> Int -> F (s,t) + bar = /\s t. \(z::F (s,t)) \(y::Int) -> + case z |> co1 of + MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3 + +(Side note: here (z |> co1) is built by typechecking the scrutinee, so +we ignore it here. In general the scrutinee is an aribtrary expression.) + +The question is: what is co3, the cast for the RHS? + co3 :: F (Int,t) ~ F (s,t) +Again, we can construct it using co2, bound by the GADT match. +We do /exactly/ the same as the non-family case up to building +univ_cos. But that gives us + rep_tc: R:FPair + univ_cos: (Sym co2) (Refl t) +But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion +we want, namely + F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t) + +-} + +dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields + , rupd_ext = RecordUpdTc + { rupd_cons = cons_to_upd + , rupd_in_tys = in_inst_tys + , rupd_out_tys = out_inst_tys + , rupd_wrap = dict_req_wrap }} ) + | null fields + = dsLExpr record_expr + | otherwise + = ASSERT2( notNull cons_to_upd, ppr expr ) + + do { record_expr' <- dsLExpr record_expr + ; field_binds' <- mapM ds_field fields + ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding + upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] + + -- It's important to generate the match with matchWrapper, + -- and the right hand sides with applications of the wrapper Id + -- so that everything works when we are doing fancy unboxing on the + -- constructor arguments. + ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd + ; ([discrim_var], matching_code) + <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] + (MG { mg_alts = noLoc alts + , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty + , mg_origin = FromSource + }) + -- FromSource is not strictly right, but we + -- want incomplete pattern-match warnings + + ; return (add_field_binds field_binds' $ + bindNonRec discrim_var record_expr' matching_code) } + where + ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) + -- Clone the Id in the HsRecField, because its Name is that + -- of the record selector, and we must not make that a local binder + -- else we shadow other uses of the record selector + -- Hence 'lcl_id'. Cf #2735 + ds_field (L _ rec_field) + = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecUpdFieldId rec_field) + ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } + + add_field_binds [] expr = expr + add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) + + -- Awkwardly, for families, the match goes + -- from instance type to family type + (in_ty, out_ty) = + case (head cons_to_upd) of + RealDataCon data_con -> + let tycon = dataConTyCon data_con in + (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) + PatSynCon pat_syn -> + ( patSynInstResTy pat_syn in_inst_tys + , patSynInstResTy pat_syn out_inst_tys) + mk_alt upd_fld_env con + = do { let (univ_tvs, ex_tvs, eq_spec, + prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con + arg_tys' = map (scaleScaled Many) arg_tys + -- Record updates consume the source record with multiplicity + -- Many. Therefore all the fields need to be scaled thus. + user_tvs = binderVars $ conLikeUserTyVarBinders con + in_subst = zipTvSubst univ_tvs in_inst_tys + out_subst = zipTvSubst univ_tvs out_inst_tys + + -- I'm not bothering to clone the ex_tvs + ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) + ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) + ; arg_ids <- newSysLocalsDs (substScaledTysUnchecked in_subst arg_tys') + ; let field_labels = conLikeFieldLabels con + val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + field_labels arg_ids + mk_val_arg fl pat_arg_id + = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) + + inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) + -- Reconstruct with the WrapId so that unpacking happens + wrap = mkWpEvVarApps theta_vars <.> + dict_req_wrap <.> + mkWpTyApps [ lookupTyVar out_subst tv + `orElse` mkTyVarTy tv + | tv <- user_tvs ] + -- Be sure to use user_tvs (which may be ordered + -- differently than `univ_tvs ++ ex_tvs) above. + -- See Note [DataCon user type variable binders] + -- in GHC.Core.DataCon. + rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args + + -- Tediously wrap the application in a cast + -- Note [Update for GADTs] + wrapped_rhs = + case con of + RealDataCon data_con + | null eq_spec -> rhs + | otherwise -> mkLHsWrap (mkWpCastN wrap_co) rhs + -- This wrap is the punchline: Note [Update for GADTs] + where + rep_tc = dataConTyCon data_con + wrap_co = mkTcFamilyTyConAppCo rep_tc univ_cos + univ_cos = zipWithEqual "dsExpr:upd" mk_univ_co univ_tvs out_inst_tys + + mk_univ_co :: TyVar -- Universal tyvar from the DataCon + -> Type -- Corresponding instantiating type + -> Coercion + mk_univ_co univ_tv inst_ty + = case lookupVarEnv eq_spec_env univ_tv of + Just co -> co + Nothing -> mkTcNomReflCo inst_ty + + eq_spec_env :: VarEnv Coercion + eq_spec_env = mkVarEnv [ (eqSpecTyVar spec, mkTcSymCo (mkTcCoVarCo eqs_var)) + | (spec,eqs_var) <- zipEqual "dsExpr:upd2" eq_spec eqs_vars ] + + -- eq_spec is always null for a PatSynCon + PatSynCon _ -> rhs + + + req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys + + pat = noLoc $ ConPat { pat_con = noLoc con + , pat_args = PrefixCon $ map nlVarPat arg_ids + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs + , cpt_dicts = eqs_vars ++ theta_vars + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = in_inst_tys + , cpt_wrap = req_wrap + } + } + ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } + +{- Note [Scrutinee in Record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider #17783: + + data PartialRec = No + | Yes { a :: Int, b :: Bool } + update No = No + update r@(Yes {}) = r { b = False } + +In the context of pattern-match checking, the occurrence of @r@ in +@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by +the following desugaring: + + r { b = False } ==> case r of Yes a b -> Yes a False + +Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above. +-} + +-- Here is where we desugar the Template Haskell brackets and escapes + +-- Template Haskell stuff + +dsExpr (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" +dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps +dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) + +-- Arrow notation extension +dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd + +-- Hpc Support + +dsExpr (HsTick _ tickish e) = do + e' <- dsLExpr e + return (Tick tickish e') + +-- There is a problem here. The then and else branches +-- have no free variables, so they are open to lifting. +-- We need someway of stopping this. +-- This will make no difference to binary coverage +-- (did you go here: YES or NO), but will effect accurate +-- tick counting. + +dsExpr (HsBinTick _ ixT ixF e) = do + e2 <- dsLExpr e + do { ASSERT(exprType e2 `eqType` boolTy) + mkBinaryTickBox ixT ixF e2 + } + +-- HsSyn constructs that just shouldn't be here: +dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" +dsExpr (HsDo {}) = panic "dsExpr:HsDo" +dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" + +ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr +ds_prag_expr (HsPragSCC _ _ cc) expr = do + dflags <- getDynFlags + if sccProfilingEnabled dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + let nm = sl_fs cc + flavour <- ExprCC <$> getCCIndexM nm + Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) + <$> dsLExpr expr + else dsLExpr expr +ds_prag_expr (HsPragTick _ _ _ _) expr = do + dflags <- getDynFlags + if gopt Opt_Hpc dflags + then panic "dsExpr:HsPragTick" + else dsLExpr expr + +------------------------------ +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsSyntaxExpr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + arg_exprs + = do { fun <- dsExpr expr + ; core_arg_wraps <- mapM dsHsWrapper arg_wraps + ; core_res_wrap <- dsHsWrapper res_wrap + ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs + ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) + (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) } + -- Use mkCoreApps instead of mkApps: + -- unboxed types are possible with RebindableSyntax (#19883) + where + mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) +dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" + +findField :: [LHsRecField GhcTc arg] -> Name -> [arg] +findField rbinds sel + = [hsRecFieldArg fld | L _ fld <- rbinds + , sel == idName (unLoc $ hsRecFieldId fld) ] + +{- +%-------------------------------------------------------------------- + +Note [Desugaring explicit lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Explicit lists are desugared in a cleverer way to prevent some +fruitless allocations. Essentially, whenever we see a list literal +[x_1, ..., x_n] we generate the corresponding expression in terms of +build: + +Explicit lists (literals) are desugared to allow build/foldr fusion when +beneficial. This is a bit of a trade-off, + + * build/foldr fusion can generate far larger code than the corresponding + cons-chain (e.g. see #11707) + + * even when it doesn't produce more code, build can still fail to fuse, + requiring that the simplifier do more work to bring the expression + back into cons-chain form; this costs compile time + + * when it works, fusion can be a significant win. Allocations are reduced + by up to 25% in some nofib programs. Specifically, + + Program Size Allocs Runtime CompTime + rewrite +0.0% -26.3% 0.02 -1.8% + ansi -0.3% -13.8% 0.00 +0.0% + lift +0.0% -8.7% 0.00 -2.3% + +At the moment we use a simple heuristic to determine whether build will be +fruitful: for small lists we assume the benefits of fusion will be worthwhile; +for long lists we assume that the benefits will be outweighted by the cost of +code duplication. This magic length threshold is @maxBuildLength@. Also, fusion +won't work at all if rewrite rules are disabled, so we don't use the build-based +desugaring in this case. + +We used to have a more complex heuristic which would try to break the list into +"static" and "dynamic" parts and only build-desugar the dynamic part. +Unfortunately, determining "static-ness" reliably is a bit tricky and the +heuristic at times produced surprising behavior (see #11710) so it was dropped. +-} + +{- | The longest list length which we will desugar using @build@. + +This is essentially a magic number and its setting is unfortunate rather +arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], +is to avoid deforesting large static data into large(r) code. Ideally we'd +want a smaller threshold with larger consumers and vice-versa, but we have no +way of knowing what will be consuming our list in the desugaring impossible to +set generally correctly. + +The effect of reducing this number will be that 'build' fusion is applied +less often. From a runtime performance perspective, applying 'build' more +liberally on "moderately" sized lists should rarely hurt and will often it can +only expose further optimization opportunities; if no fusion is possible it will +eventually get rule-rewritten back to a list). We do, however, pay in compile +time. +-} +maxBuildLength :: Int +maxBuildLength = 32 + +dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] + -> DsM CoreExpr +-- See Note [Desugaring explicit lists] +dsExplicitList elt_ty Nothing xs + = do { dflags <- getDynFlags + ; xs' <- mapM dsLExprNoLP xs + ; if xs' `lengthExceeds` maxBuildLength + -- Don't generate builds if the list is very long. + || null xs' + -- Don't generate builds when the [] constructor will do + || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore + then return $ mkListExpr elt_ty xs' + else mkBuildExpr elt_ty (mk_build_list xs') } + where + mk_build_list xs' (cons, _) (nil, _) + = return (foldr (App . App (Var cons)) (Var nil) xs') + +dsExplicitList elt_ty (Just fln) xs + = do { list <- dsExplicitList elt_ty Nothing xs + ; dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; dsSyntaxExpr fln [mkIntExprInt platform (length xs), list] } + +dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr +dsArithSeq expr (From from) + = App <$> dsExpr expr <*> dsLExprNoLP from +dsArithSeq expr (FromTo from to) + = do fam_envs <- dsGetFamInstEnvs + dflags <- getDynFlags + warnAboutEmptyEnumerations fam_envs dflags from Nothing to + expr' <- dsExpr expr + from' <- dsLExprNoLP from + to' <- dsLExprNoLP to + return $ mkApps expr' [from', to'] +dsArithSeq expr (FromThen from thn) + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] +dsArithSeq expr (FromThenTo from thn to) + = do fam_envs <- dsGetFamInstEnvs + dflags <- getDynFlags + warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to + expr' <- dsExpr expr + from' <- dsLExprNoLP from + thn' <- dsLExprNoLP thn + to' <- dsLExprNoLP to + return $ mkApps expr' [from', thn', to'] + +{- +Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're +handled in GHC.HsToCore.ListComp). Basically does the translation given in the +Haskell 98 report: +-} + +dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr +dsDo ctx stmts + = goL stmts + where + goL [] = panic "dsDo" + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + + go _ (LastStmt _ body _ _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (BodyStmt _ rhs then_expr _) stmts + = do { rhs2 <- dsLExpr rhs + ; warnDiscardedDoBindings rhs (exprType rhs2) + ; rest <- goL stmts + ; dsSyntaxExpr then_expr [rhs2, rest] } + + go _ (LetStmt _ binds) stmts + = do { rest <- goL stmts + ; dsLocalBinds binds rest } + + go _ (BindStmt xbs pat rhs) stmts + = do { body <- goL stmts + ; rhs' <- dsLExpr rhs + ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat + ; match <- matchSinglePatVar var (StmtCtxt ctx) pat + (xbstc_boundResultType xbs) (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs) + ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } + + go _ (ApplicativeStmt body_ty args mb_join) stmts + = do { + let + (pats, rhss) = unzip (map (do_arg . snd) args) + + do_arg (ApplicativeArgOne fail_op pat expr _) = + ((pat, fail_op), dsLExpr expr) + do_arg (ApplicativeArgMany _ stmts ret pat _) = + ((pat, Nothing), dsDo ctx (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + + ; rhss' <- sequence rhss + + ; body' <- dsLExpr $ noLoc $ HsDo body_ty ctx (noLoc stmts) + + ; let match_args (pat, fail_op) (vs,body) + = do { var <- selectSimpleMatchVarL Many pat + ; match <- matchSinglePatVar var (StmtCtxt ctx) pat + body_ty (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure pat match fail_op + ; return (var:vs, match_code) + } + + ; (vars, body) <- foldrM match_args ([],body') pats + ; let fun' = mkLams vars body + ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] + ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') + ; case mb_join of + Nothing -> return expr + Just join_op -> dsSyntaxExpr join_op [expr] } + + go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = return_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_ext = RecStmtTc + { recS_bind_ty = bind_ty + , recS_rec_rets = rec_rets + , recS_ret_ty = body_ty} }) stmts + = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } + where + new_bind_stmt = L loc $ BindStmt + XBindStmtTc + { xbstc_bindOp = bind_op + , xbstc_boundResultType = bind_ty + , xbstc_boundResultMult = Many + , xbstc_failOp = Nothing -- Tuple cannot fail + } + (mkBigLHsPatTupId later_pats) + mfix_app + + tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case + rec_tup_pats = map nlVarPat tup_ids + later_pats = rec_tup_pats + rets = map noLoc rec_rets + mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] + mfix_arg = noLoc $ HsLam noExtField + (MG { mg_alts = noLoc [mkSimpleMatch + LambdaExpr + [mfix_pat] body] + , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty + , mg_origin = Generated }) + mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats + body = noLoc $ HsDo body_ty + ctx (noLoc (rec_stmts ++ [ret_stmt])) + ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly + + go _ (ParStmt {}) _ = panic "dsDo ParStmt" + go _ (TransStmt {}) _ = panic "dsDo TransStmt" + +dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr + -- In a do expression, pattern-match failure just calls + -- the monadic 'fail' rather than throwing an exception +dsHandleMonadicFailure pat match m_fail_op = + case shareFailureHandler match of + MR_Infallible body -> body + MR_Fallible body -> do + fail_op <- case m_fail_op of + -- Note that (non-monadic) list comprehension, pattern guards, etc could + -- have fallible bindings without an explicit failure op, but this is + -- handled elsewhere. See Note [Failing pattern matches in Stmts] the + -- breakdown of regular and special binds. + Nothing -> pprPanic "missing fail op" $ + text "Pattern match:" <+> ppr pat <+> + text "is failable, and fail_expr was left unset" + Just fail_op -> pure fail_op + dflags <- getDynFlags + fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + fail_expr <- dsSyntaxExpr fail_op [fail_msg] + body fail_expr + +mk_fail_msg :: DynFlags -> Located e -> String +mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ + showPpr dflags (getLoc pat) + +{- +************************************************************************ +* * + Desugaring Variables +* * +************************************************************************ +-} + +dsHsVar :: Id -> DsM CoreExpr +dsHsVar var + = do { checkLevPolyFunction (ppr var) var (idType var) + ; return (varToCoreExpr var) } -- See Note [Desugaring vars] + +dsConLike :: ConLike -> DsM CoreExpr +dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc) +dsConLike (PatSynCon ps) = return $ case patSynBuilder ps of + Just (id, add_void) + | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) + | otherwise -> Var id + _ -> pprPanic "dsConLike" (ppr ps) + +{- +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +-- Warn about certain types of values discarded in monadic bindings (#3263) +warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { warn_unused <- woptM Opt_WarnUnusedDoBind + ; warn_wrong <- woptM Opt_WarnWrongDoBind + ; when (warn_unused || warn_wrong) $ + do { fam_inst_envs <- dsGetFamInstEnvs + ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty + + -- Warn about discarding non-() things in 'monadic' binding + ; if warn_unused && not (isUnitTy norm_elt_ty) + then warnDs (Reason Opt_WarnUnusedDoBind) + (badMonadBind rhs elt_ty) + else + + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + when warn_wrong $ + do { case tcSplitAppTy_maybe norm_elt_ty of + Just (elt_m_ty, _) + | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty + -> warnDs (Reason Opt_WarnWrongDoBind) + (badMonadBind rhs elt_ty) + _ -> return () } } } + + | otherwise -- RHS does have type of form (m ty), which is weird + = return () -- but at least this warning is irrelevant + +badMonadBind :: LHsExpr GhcTc -> Type -> SDoc +badMonadBind rhs elt_ty + = vcat [ hang (text "A do-notation statement discarded a result of type") + 2 (quotes (ppr elt_ty)) + , hang (text "Suppress this warning by saying") + 2 (quotes $ text "_ <-" <+> ppr rhs) + ] + +{- +************************************************************************ +* * + Levity polymorphism checks +* * +************************************************************************ + +Note [Checking for levity-polymorphic functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We cannot have levity polymorphic function arguments. See +Note [Levity polymorphism invariants] in GHC.Core. That is +checked by dsLExprNoLP. + +But what about + const True (unsafeCoerce# :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b) + +Since `unsafeCoerce#` has no binding, it has a compulsory unfolding. +But that compulsory unfolding is a levity-polymorphic lambda, which +is no good. So we want to reject this. On the other hand + const True (unsafeCoerce# @LiftedRep @UnliftedRep) +is absolutely fine. + +We have to collect all the type-instantiation and *then* check. That +is what dsHsWrapped does. Because we might have an HsVar without a +wrapper, we check in dsHsVar as well. typecheck/should_fail/T17021 +triggers this case. + +Note that if `f :: forall r (a :: Type r). blah`, then + const True f +is absolutely fine. Here `f` is a function, represented by a +pointer, and we can pass it to `const` (or anything else). (See +#12708 for an example.) It's only the Id.hasNoBinding functions +that are a problem. + +Interestingly, this approach does not look to see whether the Id in +question will be eta expanded. The logic is this: + * Either the Id in question is saturated or not. + * If it is, then it surely can't have levity polymorphic arguments. + If its wrapped type contains levity polymorphic arguments, reject. + * If it's not, then it can't be eta expanded with levity polymorphic + argument. If its wrapped type contains levity polymorphic arguments, reject. +So, either way, we're good to reject. + +-} + +------------------------------ +dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr +-- Looks for a function 'f' wrapped in type applications (HsAppType) +-- or wrappers (HsWrap), and checks that any hasNoBinding function +-- is not levity polymorphic, *after* instantiation with those wrappers +dsHsWrapped orig_hs_expr + = go id orig_hs_expr + where + go wrap (XExpr (WrapExpr (HsWrap co_fn hs_e))) + = do { wrap' <- dsHsWrapper co_fn + ; addTyCsDs FromSource (hsWrapDictBinders co_fn) $ + go (wrap . wrap') hs_e } + go wrap (HsConLikeOut _ (RealDataCon dc)) + = go_head wrap (dataConWrapId dc) + go wrap (HsAppType ty hs_e _) = go_l (wrap . (\e -> App e (Type ty))) hs_e + go wrap (HsPar _ hs_e) = go_l wrap hs_e + go wrap (HsVar _ (L _ var)) = go_head wrap var + go wrap hs_e = do { e <- dsExpr hs_e; return (wrap e) } + + go_l wrap (L _ hs_e) = go wrap hs_e + + go_head wrap var + = do { let wrapped_e = wrap (Var var) + wrapped_ty = exprType wrapped_e + + ; checkLevPolyFunction (ppr orig_hs_expr) var wrapped_ty + -- See Note [Checking for levity-polymorphic functions] + -- Pass orig_hs_expr, so that the user can see entire + -- expression with -fprint-typechecker-elaboration + + ; dflags <- getDynFlags + ; warnAboutIdentities dflags var wrapped_ty + + ; return wrapped_e } + + +-- | Takes a (pretty-printed) expression, a function, and its +-- instantiated type. If the function is a hasNoBinding op, and the +-- type has levity-polymorphic arguments, issue an error. +-- Note [Checking for levity-polymorphic functions] +checkLevPolyFunction :: SDoc -> Id -> Type -> DsM () +checkLevPolyFunction pp_hs_expr var ty + | let bad_tys = isBadLevPolyFunction var ty + , not (null bad_tys) + = errDs $ vcat + [ hang (text "Cannot use function with levity-polymorphic arguments:") + 2 (pp_hs_expr <+> dcolon <+> pprWithTYPE ty) + , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat + [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples" + , text "are eta-expanded internally because they must occur fully saturated." + , text "Use -fprint-typechecker-elaboration to display the full expression.)" + ] + , hang (text "Levity-polymorphic arguments:") + 2 $ vcat $ map + (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) + bad_tys + ] + +checkLevPolyFunction _ _ _ = return () + +-- | Is this a hasNoBinding Id with a levity-polymorphic type? +-- Returns the arguments that are levity polymorphic if they are bad; +-- or an empty list otherwise +-- Note [Checking for levity-polymorphic functions] +isBadLevPolyFunction :: Id -> Type -> [Type] +isBadLevPolyFunction id ty + | hasNoBinding id + = filter isTypeLevPoly arg_tys + | otherwise + = [] + where + (binders, _) = splitPiTys ty + arg_tys = mapMaybe binderRelevantType_maybe binders diff --git a/GHC/HsToCore/Expr.hs-boot b/GHC/HsToCore/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Expr.hs-boot @@ -0,0 +1,12 @@ +module GHC.HsToCore.Expr where +import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator ) +import GHC.HsToCore.Monad ( DsM, MatchResult ) +import GHC.Core ( CoreExpr ) +import GHC.Hs.Extension ( GhcTc) + +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr + +dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr diff --git a/GHC/HsToCore/Foreign/Call.hs b/GHC/HsToCore/Foreign/Call.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Call.hs @@ -0,0 +1,388 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Desugaring foreign calls +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Foreign.Call + ( dsCCall + , mkFCall + , unboxArg + , boxResult + , resultWrapper + ) +where + +#include "HsVersions.h" + + +import GHC.Prelude +import GHC.Platform + +import GHC.Core + +import GHC.HsToCore.Monad +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Types.Id.Make +import GHC.Types.ForeignCall +import GHC.Core.DataCon +import GHC.HsToCore.Utils + +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Types.Id ( Id ) +import GHC.Core.Coercion +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Types.Literal +import GHC.Builtin.Names +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Data.Maybe + +{- +Desugaring of @ccall@s consists of adding some state manipulation, +unboxing any boxed primitive arguments and boxing the result if +desired. + +The state stuff just consists of adding in +@PrimIO (\ s -> case s of { State# s# -> ... })@ in an appropriate place. + +The unboxing is straightforward, as all information needed to unbox is +available from the type. For each boxed-primitive argument, we +transform: +\begin{verbatim} + _ccall_ foo [ r, t1, ... tm ] e1 ... em + | + | + V + case e1 of { T1# x1# -> + ... + case em of { Tm# xm# -> xm# + ccall# foo [ r, t1#, ... tm# ] x1# ... xm# + } ... } +\end{verbatim} + +The reboxing of a @_ccall_@ result is a bit tricker: the types don't +contain information about the state-pairing functions so we have to +keep a list of \tr{(type, s-p-function)} pairs. We transform as +follows: +\begin{verbatim} + ccall# foo [ r, t1#, ... tm# ] e1# ... em# + | + | + V + \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of + (StateAnd# result# state#) -> (R# result#, realWorld#) +\end{verbatim} +-} + +dsCCall :: CLabelString -- C routine to invoke + -> [CoreExpr] -- Arguments (desugared) + -- Precondition: none have levity-polymorphic types + -> Safety -- Safety of the call + -> Type -- Type of the result: IO t + -> DsM CoreExpr -- Result, of type ??? + +dsCCall lbl args may_gc result_ty + = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args + (ccall_result_ty, res_wrapper) <- boxResult result_ty + uniq <- newUnique + dflags <- getDynFlags + let + target = StaticTarget NoSourceText lbl Nothing True + the_fcall = CCall (CCallSpec target CCallConv may_gc) + the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty + return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) + +mkFCall :: DynFlags -> Unique -> ForeignCall + -> [CoreExpr] -- Args + -> Type -- Result type + -> CoreExpr +-- Construct the ccall. The only tricky bit is that the ccall Id should have +-- no free vars, so if any of the arg tys do we must give it a polymorphic type. +-- [I forget *why* it should have no free vars!] +-- For example: +-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] +-- +-- Here we build a ccall thus +-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) +-- a b s x c +mkFCall dflags uniq the_fcall val_args res_ty + = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level + mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args + where + arg_tys = map exprType val_args + body_ty = (mkVisFunTysMany arg_tys res_ty) + tyvars = tyCoVarsOfTypeWellScoped body_ty + ty = mkInfForAllTys tyvars body_ty + the_fcall_id = mkFCallId dflags uniq the_fcall ty + +unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +-- Example: if the arg is e::Int, unboxArg will return +-- (x#::Int#, \W. case x of I# x# -> W) +-- where W is a CoreExpr that probably mentions x# + +-- always returns a non-levity-polymorphic expression + +unboxArg arg + -- Primitive types: nothing to unbox + | isPrimitiveType arg_ty + = return (arg, \body -> body) + + -- Recursive newtypes + | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxArg (mkCastDs arg co) + + -- Booleans + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = do dflags <- getDynFlags + let platform = targetPlatform dflags + prim_arg <- newSysLocalDs Many intPrimTy + return (Var prim_arg, + \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) + prim_arg + (exprType body) + [(DEFAULT,[],body)]) + + -- Data types with a single constructor, which has a single, primitive-typed arg + -- This deals with Int, Float etc; also Ptr, ForeignPtr + | is_product_type && data_con_arity == 1 + = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty) + -- Typechecker ensures this + do case_bndr <- newSysLocalDs Many arg_ty + prim_arg <- newSysLocalDs Many data_con_arg_ty1 + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + | is_product_type && + data_con_arity == 3 && + isJust maybe_arg3_tycon && + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalDs Many arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type + data_con_arg_tys = map scaledThing scaled_data_con_arg_tys + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys + maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 + Just arg3_tycon = maybe_arg3_tycon + +boxResult :: Type + -> DsM (Type, CoreExpr -> CoreExpr) + +-- Takes the result of the user-level ccall: +-- either (IO t), +-- or maybe just t for a side-effect-free call +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) + +boxResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- resultWrapper io_res_ty + ; let extra_result_tys + = case res of + (Just ty,_) + | isUnboxedTupleType ty + -> let Just ls = tyConAppArgs_maybe ty in tail ls + _ -> [] + + return_result state anss + = mkCoreUbxTup + (realWorldStatePrimTy : io_res_ty : extra_result_tys) + (state : anss) + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalDs Many realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } + +boxResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- resultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + where + return_result _ [ans] = ans + return_result _ _ = panic "return_result: expected single result" + + +mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, (AltCon, [Id], Expr Var)) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalDs Many realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + [wrap_result (panic "boxResult")] + + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) + + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + = -- The ccall returns a non-() value + ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty ) + -- True because resultWrapper ensures it is so + do { result_id <- newSysLocalDs Many prim_res_ty + ; state_id <- newSysLocalDs Many realWorldStatePrimTy + ; let the_rhs = return_result (Var state_id) + [wrap_result (Var result_id)] + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) + ; return (ccall_res_ty, the_alt) } + + +resultWrapper :: Type + -> DsM (Maybe Type, -- Type of the expected result, if any + CoreExpr -> CoreExpr) -- Wrapper for the result +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part +-- So if resultWrapper ty = (Just ty_rep, marshal) +-- then marshal (e :: ty_rep) :: ty +-- That is, 'marshal' wrape the result returned by the foreign call, +-- of type ty_rep, into the value Haskell expected, of type 'ty' +-- +-- Invariant: ty_rep is always a primitive type +-- i.e. (isPrimitiveType ty_rep) is True + +resultWrapper result_ty + -- Base case 1: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app + , tc `hasKey` unitTyConKey + = return (Nothing, \_ -> unitExpr) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app + , tc `hasKey` boolTyConKey + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; let marshal_bool e + = mkWildCase e (unrestricted intPrimTy) boolTy + [ (DEFAULT ,[],Var trueDataConId ) + , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)] + ; return (Just intPrimTy, marshal_bool) } + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do { (maybe_ty, wrapper) <- resultWrapper rep_ty + ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) } + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTy_maybe result_ty + = do { (maybe_ty, wrapper) <- resultWrapper rest + ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) } + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (tycon, tycon_arg_tys) <- maybe_tc_app + , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials + , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty + ; let narrow_wrapper = maybeNarrow platform tycon + marshal_con e = Var (dataConWrapId data_con) + `mkTyApps` tycon_arg_tys + `App` wrapper (narrow_wrapper e) + ; return (maybe_ty, marshal_con) } + + | otherwise + = pprPanic "resultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty + +-- When the result of a foreign call is smaller than the word size, we +-- need to sign- or zero-extend the result up to the word size. The C +-- standard appears to say that this is the responsibility of the +-- caller, not the callee. + +maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr) +maybeNarrow platform tycon + | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e + | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e + | tycon `hasKey` int32TyConKey + , platformWordSizeInBytes platform > 4 + = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e + + | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e + | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e + | tycon `hasKey` word32TyConKey + , platformWordSizeInBytes platform > 4 + = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e + | otherwise = id diff --git a/GHC/HsToCore/Foreign/Decl.hs b/GHC/HsToCore/Foreign/Decl.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Decl.hs @@ -0,0 +1,858 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where + +#include "HsVersions.h" +import GHC.Prelude + +import GHC.Tc.Utils.Monad -- temp + +import GHC.Core + +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Monad + +import GHC.Hs +import GHC.Core.DataCon +import GHC.Core.Unfold +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType + +import GHC.Cmm.Expr +import GHC.Cmm.Utils +import GHC.Driver.Types +import GHC.Types.ForeignCall +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Driver.Session +import GHC.Platform +import GHC.Data.OrdList +import GHC.Utils.Misc +import GHC.Driver.Hooks +import GHC.Utils.Encoding + +import Data.Maybe +import Data.List + +{- +Desugaring of @foreign@ declarations is naturally split up into +parts, an @import@ and an @export@ part. A @foreign import@ +declaration +\begin{verbatim} + foreign import cc nm f :: prim_args -> IO prim_res +\end{verbatim} +is the same as +\begin{verbatim} + f :: prim_args -> IO prim_res + f a1 ... an = _ccall_ nm cc a1 ... an +\end{verbatim} +so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these. +-} + +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out + +dsForeigns :: [LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList Binding) +dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) + +dsForeigns' :: [LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList Binding) +dsForeigns' [] + = return (NoStubs, nilOL) +dsForeigns' fos = do + mod <- getModule + fives <- mapM do_ldecl fos + let + (hs, cs, idss, bindss) = unzip4 fives + fe_ids = concat idss + fe_init_code = foreignExportsInitialiser mod fe_ids + -- + return (ForeignStubs + (vcat hs) + (vcat cs $$ fe_init_code), + foldr (appOL . toOL) nilOL bindss) + where + do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) + + do_decl :: ForeignDecl GhcTc -> DsM (SDoc, SDoc, [Id], [Binding]) + do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do + traceIf (text "fi start" <+> ppr id) + let id' = unLoc id + (bs, h, c) <- dsFImport id' co spec + traceIf (text "fi end" <+> ppr id) + return (h, c, [], bs) + + do_decl (ForeignExport { fd_name = L _ id + , fd_e_ext = co + , fd_fe = CExport + (L _ (CExportStatic _ ext_nm cconv)) _ }) = do + (h, c, _, _) <- dsFExport id co ext_nm cconv False + return (h, c, [id], []) + +{- +************************************************************************ +* * +\subsection{Foreign import} +* * +************************************************************************ + +Desugaring foreign imports is just the matter of creating a binding +that on its RHS unboxes its arguments, performs the external call +(using the @CCallOp@ primop), before boxing the result up and returning it. + +However, we create a worker/wrapper pair, thus: + + foreign import f :: Int -> IO Int +==> + f x = IO ( \s -> case x of { I# x# -> + case fw s x# of { (# s1, y# #) -> + (# s1, I# y# #)}}) + + fw s x# = ccall f s x# + +The strictness/CPR analyser won't do this automatically because it doesn't look +inside returned tuples; but inlining this wrapper is a Really Good Idea +because it exposes the boxing to the call site. +-} + +dsFImport :: Id + -> Coercion + -> ForeignImport + -> DsM ([Binding], SDoc, SDoc) +dsFImport id co (CImport cconv safety mHeader spec _) = + dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader + +dsCImport :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], SDoc, SDoc) +dsCImport id co (CLabel cid) cconv _ _ = do + dflags <- getDynFlags + let ty = coercionLKind co + platform = targetPlatform dflags + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (resTy, foRhs) <- resultWrapper ty + ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this + let + rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) + rhs' = Cast rhs co + stdcall_info = fun_type_arg_stdcall_info platform cconv ty + in + return ([(id, rhs')], empty, empty) + +dsCImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsCImport id co (CFunction target) cconv safety mHeader + = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsCImport id co CWrapper cconv _ _ + = dsFExportDynamic id co cconv + +-- For stdcall labels, if the type was a FunPtr or newtype thereof, +-- then we need to calculate the size of the arguments in order to add +-- the @n suffix to the label. +fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int +fun_type_arg_stdcall_info platform StdCallConv ty + | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, + tyConUnique tc == funPtrTyConKey + = let + (bndrs, _) = tcSplitPiTys arg_ty + fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs + in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys) +fun_type_arg_stdcall_info _ _other_conv _ + = Nothing + +{- +************************************************************************ +* * +\subsection{Foreign calls} +* * +************************************************************************ +-} + +dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) +dsFCall fn_id co fcall mDeclHeader = do + let + ty = coercionLKind co + (tv_bndrs, rho) = tcSplitForAllVarBndrs ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + dflags <- getDynFlags + (fcall', cDoc) <- + case fcall of + CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) + CApiConv safety) -> + do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) + let fcall' = CCall (CCallSpec + (StaticTarget NoSourceText + wrapperName mUnitId + True) + CApiConv safety) + c = includes + $$ fun_proto <+> braces (cRet <> semi) + includes = vcat [ text "#include \"" <> ftext h + <> text "\"" + | Header _ h <- nub headers ] + fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes + cRet + | isVoidRes = cCall + | otherwise = text "return" <+> cCall + cCall = if isFun + then ppr cName <> parens argVals + else if null arg_tys + then ppr cName + else panic "dsFCall: Unexpected arguments to FFI value import" + raw_res_ty = case tcSplitIOType_maybe io_res_ty of + Just (_ioTyCon, res_ty) -> res_ty + Nothing -> io_res_ty + isVoidRes = raw_res_ty `eqType` unitTy + (mHeader, cResType) + | isVoidRes = (Nothing, text "void") + | otherwise = toCType raw_res_ty + pprCconv = ccallConvAttribute CApiConv + mHeadersArgTypeList + = [ (header, cType <+> char 'a' <> int n) + | (t, n) <- zip arg_tys [1..] + , let (header, cType) = toCType (scaledThing t) ] + (mHeaders, argTypeList) = unzip mHeadersArgTypeList + argTypes = if null argTypeList + then text "void" + else hsep $ punctuate comma argTypeList + mHeaders' = mDeclHeader : mHeader : mHeaders + headers = catMaybes mHeaders' + argVals = hsep $ punctuate comma + [ char 'a' <> int n + | (_, n) <- zip arg_tys [1..] ] + return (fcall', c) + _ -> + return (fcall, empty) + let + -- Build the worker + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity + (length args) wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) + +{- +************************************************************************ +* * +\subsection{Primitive calls} +* * +************************************************************************ + +This is for `@foreign import prim@' declarations. + +Currently, at the core level we pretend that these primitive calls are +foreign calls. It may make more sense in future to have them as a distinct +kind of Id, or perhaps to bundle them with PrimOps since semantically and +for calling convention they are really prim ops. +-} + +dsPrimCall :: Id -> Coercion -> ForeignCall + -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) +dsPrimCall fn_id co fcall = do + let + ty = coercionLKind co + (tvs, fun_ty) = tcSplitForAllTys ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + + ccall_uniq <- newUnique + dflags <- getDynFlags + let + call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty + rhs = mkLams tvs (mkLams args call_app) + rhs' = Cast rhs co + return ([(fn_id, rhs')], empty, empty) + +{- +************************************************************************ +* * +\subsection{Foreign export} +* * +************************************************************************ + +The function that does most of the work for `@foreign export@' declarations. +(see below for the boilerplate code a `@foreign export@' declaration expands + into.) + +For each `@foreign export foo@' in a module M we generate: +\begin{itemize} +\item a C function `@foo@', which calls +\item a Haskell stub `@M.\$ffoo@', which calls +\end{itemize} +the user-written Haskell function `@M.foo@'. +-} + +dsFExport :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( SDoc -- contents of Module_stub.h + , SDoc -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + , Int -- size of args to stub function + ) + +dsFExport fn_id co ext_name cconv isDyn = do + let + ty = coercionRKind co + (bndrs, orig_res_ty) = tcSplitPiTys ty + fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + + dflags <- getDynFlags + return $ + mkFExportCBits dflags ext_name + (if isDyn then Nothing else Just fn_id) + fe_arg_tys res_ty is_IO_res_ty cconv + +{- +@foreign import "wrapper"@ (previously "foreign export dynamic") lets +you dress up Haskell IO actions of some fixed type behind an +externally callable interface (i.e., as a C function pointer). Useful +for callbacks and stuff. + +\begin{verbatim} +type Fun = Bool -> Int -> IO Int +foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) + +-- Haskell-visible constructor, which is generated from the above: +-- SUP: No check for NULL from createAdjustor anymore??? + +f :: Fun -> IO (FunPtr Fun) +f cback = + bindIO (newStablePtr cback) + (\StablePtr sp# -> IO (\s1# -> + case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of + (# s2#, a# #) -> (# s2#, A# a# #))) + +foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) + +-- and the helper in C: (approximately; see `mkFExportCBits` below) + +f_helper(StablePtr s, HsBool b, HsInt i) +{ + Capability *cap; + cap = rts_lock(); + rts_evalIO(&cap, + rts_apply(rts_apply(deRefStablePtr(s), + rts_mkBool(b)), rts_mkInt(i))); + rts_unlock(cap); +} +\end{verbatim} +-} + +dsFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], SDoc, SDoc) +dsFExportDynamic id co0 cconv = do + mod <- getModule + dflags <- getDynFlags + let platform = targetPlatform dflags + let fe_nm = mkFastString $ zEncodeString + (moduleStableString mod ++ "$" ++ toCName dflags id) + -- Construct the label based on the passed id, don't use names + -- depending on Unique. See #13807 and Note [Unique Determinism]. + cback <- newSysLocalDs arg_mult arg_ty + newStablePtrId <- dsLookupGlobalId newStablePtrName + stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + let + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkVisFunTyMany stable_ptr_ty arg_ty + bindIOId <- dsLookupGlobalId bindIOName + stbl_value <- newSysLocalDs Many stable_ptr_ty + (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True + let + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (stdcall, ccall). + -} + adj_args = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv)) + , Var stbl_value + , Lit (LitLabel fe_nm mb_sz_args IsFunction) + , Lit (mkLitString typestring) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = fsLit "createAdjustor" + + -- Determine the number of bytes of arguments to the stub function, + -- so that we can attach the '@N' suffix to its label if it is a + -- stdcall on Windows. + mb_sz_args = case cconv of + StdCallConv -> Just args_size + _ -> Nothing + + ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + + where + ty = coercionLKind co0 + (tvs,sans_foralls) = tcSplitForAllTys ty + ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty + -- Must have an IO type; hence Just + + +toCName :: DynFlags -> Id -> String +toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) + +{- +* + +\subsection{Generating @foreign export@ stubs} + +* + +For each @foreign export@ function, a C stub function is generated. +The C stub constructs the application of the exported Haskell function +using the hugs/ghc rts invocation API. +-} + +mkFExportCBits :: DynFlags + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (SDoc, + SDoc, + String, -- the argument reps + Int -- total size of arguments + ) +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc + = (header_bits, c_bits, type_string, + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM + ) + where + platform = targetPlatform dflags + + -- list the arguments to the C function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty + cmm_type = typeCmmType platform (getPrimTyOf ty) + stack_type + = if int_promote (typeTyCon ty) + then text "HsWord" + else stg_type + in + (arg_cname n stg_type stack_type, + stg_type, + ty, + cmm_type) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + int_promote ty_con + | ty_con `hasKey` int8TyConKey = True + | ty_con `hasKey` int16TyConKey = True + | ty_con `hasKey` int32TyConKey + , platformWordSizeInBytes platform > 4 + = True + | ty_con `hasKey` word8TyConKey = True + | ty_con `hasKey` word16TyConKey = True + | ty_con `hasKey` word32TyConKey + , platformWordSizeInBytes platform > 4 + = True + | otherwise = False + + + arg_cname n stg_ty stack_ty + | libffi = parens (stg_ty) <> char '*' <> + parens (stack_ty <> char '*') <> + text "args" <> brackets (int (n-1)) + | otherwise = text ('a':show n) + + -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled + libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target + + type_string + -- libffi needs to know the result type too: + | libffi = primTyDescChar platform res_hty : arg_type_string + | otherwise = arg_type_string + + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] + -- just the real args + + -- add some auxiliary args; the stable ptr in the wrapper case, and + -- a slot for the dummy return address in the wrapper + ccall case + aug_arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info + | otherwise = arg_info + + stable_ptr_arg = + (text "the_stableptr", text "StgStablePtr", undefined, + typeCmmType platform (mkStablePtrPrimTy alphaTy)) + + -- stuff to do with the return type of the C function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + cResType | res_hty_is_unit = text "void" + | otherwise = showStgType res_hty + + -- when the return type is integral and word-sized or smaller, it + -- must be assigned as type ffi_arg (#3516). To see what type + -- libffi is expecting here, take a look in its own testsuite, e.g. + -- libffi/testsuite/libffi.call/cls_align_ulonglong.c + ffi_cResType + | is_ffi_arg_type = text "ffi_arg" + | otherwise = cResType + where + res_ty_key = getUnique (getName (typeTyCon res_hty)) + is_ffi_arg_type = res_ty_key `notElem` + [floatTyConKey, doubleTyConKey, + int64TyConKey, word64TyConKey] + + -- Now we can cook up the prototype for the exported function. + pprCconv = ccallConvAttribute cc + + header_bits = text "extern" <+> fun_proto <> semi + + fun_args + | null aug_arg_info = text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info + + fun_proto + | libffi + = text "void" <+> ftext c_nm <> + parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") + | otherwise + = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" + Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" + + cap = text "cap" <> comma + + -- the expression we give to rts_evalIO + expr_to_run + = foldl' appArg the_cfun arg_info -- NOT aug_arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "rts_apply" + <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) + + -- various other bits for inside the fn + declareResult = text "HaskellObj ret;" + declareCResult | res_hty_is_unit = empty + | otherwise = cResType <+> text "cret;" + + assignCResult | res_hty_is_unit = empty + | otherwise = + text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi + + -- an extern decl for the fn being called + extern_decl + = case maybe_target of + Nothing -> empty + Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi + + + -- finally, the whole darn thing + c_bits = + space $$ + extern_decl $$ + fun_proto $$ + vcat + [ lbrace + , text "Capability *cap;" + , declareResult + , declareCResult + , text "cap = rts_lock();" + -- create the application + perform it. + , text "rts_evalIO" <> parens ( + char '&' <> cap <> + text "rts_apply" <> parens ( + cap <> + text "(HaskellObj)" + <> ptext (if is_IO_res_ty + then (sLit "runIO_closure") + else (sLit "runNonIO_closure")) + <> comma + <> expr_to_run + ) <+> comma + <> text "&ret" + ) <> semi + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) + <> comma <> text "cap") <> semi + , assignCResult + , text "rts_unlock(cap);" + , ppUnless res_hty_is_unit $ + if libffi + then char '*' <> parens (ffi_cResType <> char '*') <> + text "resp = cret;" + else text "return cret;" + , rbrace + ] + + +foreignExportsInitialiser :: Module -> [Id] -> SDoc +foreignExportsInitialiser mod hs_fns = + -- Initialise foreign exports by registering a stable pointer from an + -- __attribute__((constructor)) function. + -- The alternative is to do this from stginit functions generated in + -- codeGen/CodeGen.hs; however, stginit functions have a negative impact + -- on binary sizes and link times because the static linker will think that + -- all modules that are imported directly or indirectly are actually used by + -- the program. + -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) + -- + -- See Note [Tracking foreign exports] in rts/ForeignExports.c + vcat + [ text "static struct ForeignExportsList" <+> list_symbol <+> equals + <+> braces ( + text ".exports = " <+> export_list <> comma <+> + text ".n_entries = " <+> ppr (length hs_fns)) + <> semi + , text "static void " <> ctor_symbol <> text "(void)" + <+> text " __attribute__((constructor));" + , text "static void " <> ctor_symbol <> text "()" + , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi) + ] + where + mod_str = pprModuleName (moduleName mod) + ctor_symbol = text "stginit_export_" <> mod_str + list_symbol = text "stg_exports_" <> mod_str + export_list = braces $ pprWithCommas closure_ptr hs_fns + + closure_ptr :: Id -> SDoc + closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" + + +mkHObj :: Type -> SDoc +mkHObj t = text "rts_mk" <> text (showFFIType t) + +unpackHObj :: Type -> SDoc +unpackHObj t = text "rts_get" <> text (showFFIType t) + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> text (showFFIType t) + +showFFIType :: Type -> String +showFFIType t = getOccString (getName (typeTyCon t)) + +toCType :: Type -> (Maybe Header, SDoc) +toCType = f False + where f voidOK t + -- First, if we have (Ptr t) of (FunPtr t), then we need to + -- convert t to a C type and put a * after it. If we don't + -- know a type for t, then "void" is fine, though. + | Just (ptr, [t']) <- splitTyConApp_maybe t + , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] + = case f True t' of + (mh, cType') -> + (mh, cType' <> char '*') + -- Otherwise, if we have a type constructor application, then + -- see if there is a C type associated with that constructor. + -- Note that we aren't looking through type synonyms or + -- anything, as it may be the synonym that is annotated. + | Just tycon <- tyConAppTyConPicky_maybe t + , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon + = (mHeader, ftext cType) + -- If we don't know a C type for this type, then try looking + -- through one layer of type synonym etc. + | Just t' <- coreView t + = f voidOK t' + -- This may be an 'UnliftedFFITypes'-style ByteArray# argument + -- (which is marshalled like a Ptr) + | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t + = (Nothing, text "const void*") + | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t + = (Nothing, text "void*") + -- Otherwise we don't know the C type. If we are allowing + -- void then return that; otherwise something has gone wrong. + | voidOK = (Nothing, text "void") + | otherwise + = pprPanic "toCType" (ppr t) + +typeTyCon :: Type -> TyCon +typeTyCon ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) + = tc + | otherwise + = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty) + +insertRetAddr :: Platform -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr platform CCallConv args + = case platformArch platform of + ArchX86_64 + | platformOS platform == OSMinGW32 -> + -- On other Windows x86_64 we insert the return address + -- after the 4th argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 4 args = ret_addr_arg platform : args + go n (arg:args) = arg : go (n+1) args + go _ [] = [] + in go 0 args + | otherwise -> + -- On other x86_64 platforms we insert the return address + -- after the 6th integer argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg platform : args + go n (arg@(_,_,_,rep):args) + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg platform : args +insertRetAddr _ _ args = args + +ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType) +ret_addr_arg platform = (text "original_return_addr", text "void*", undefined, + typeCmmType platform addrPrimTy) + +-- This function returns the primitive type associated with the boxed +-- type argument to a foreign export (eg. Int ==> Int#). +getPrimTyOf :: Type -> UnaryType +getPrimTyOf ty + | isBoolTy rep_ty = intPrimTy + -- Except for Bool, the types we are interested in have a single constructor + -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). + | otherwise = + case splitDataProductType_maybe rep_ty of + Just (_, _, data_con, [Scaled _ prim_ty]) -> + ASSERT(dataConSourceArity data_con == 1) + ASSERT2(isUnliftedType prim_ty, ppr prim_ty) + prim_ty + _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty) + where + rep_ty = unwrapType ty + +-- represent a primitive type as a Char, for building a string that +-- described the foreign function type. The types are size-dependent, +-- e.g. 'W' is a signed 32-bit integer. +primTyDescChar :: Platform -> Type -> Char +primTyDescChar platform ty + | ty `eqType` unitTy = 'v' + | otherwise + = case typePrimRep1 (getPrimTyOf ty) of + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> 'L' + Word64Rep -> 'l' + AddrRep -> 'p' + FloatRep -> 'f' + DoubleRep -> 'd' + _ -> pprPanic "primTyDescChar" (ppr ty) + where + (signed_word, unsigned_word) = case platformWordSize platform of + PW4 -> ('W','w') + PW8 -> ('L','l') diff --git a/GHC/HsToCore/GuardedRHSs.hs b/GHC/HsToCore/GuardedRHSs.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/GuardedRHSs.hs @@ -0,0 +1,152 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Matching guarded right-hand-sides (GRHSs) +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar ) + +import GHC.Hs +import GHC.Core.Make +import GHC.Core +import GHC.Core.Utils (bindNonRec) + +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils +import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas ) +import GHC.Core.Type ( Type ) +import GHC.Utils.Misc +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Core.Multiplicity +import Control.Monad ( zipWithM ) +import Data.List.NonEmpty ( NonEmpty, toList ) + +{- +@dsGuarded@ is used for pattern bindings. +It desugars: +\begin{verbatim} + | g1 -> e1 + ... + | gn -> en + where binds +\end{verbatim} +producing an expression with a runtime error in the corner if +necessary. The type argument gives the type of the @ei@. +-} + +dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> Maybe (NonEmpty Deltas) -> DsM CoreExpr +dsGuarded grhss rhs_ty mb_rhss_deltas = do + match_result <- dsGRHSs PatBindRhs grhss rhs_ty mb_rhss_deltas + error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty + extractMatchResult match_result error_expr + +-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. + +dsGRHSs :: HsMatchContext GhcRn + -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs + -> Type -- ^ Type of RHS + -> Maybe (NonEmpty Deltas) -- ^ Refined pattern match checking + -- models, one for each GRHS. Defaults + -- to 'initDeltas' if 'Nothing'. + -> DsM (MatchResult CoreExpr) +dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas + = ASSERT( notNull grhss ) + do { match_results <- case toList <$> mb_rhss_deltas of + Nothing -> mapM (dsGRHS hs_ctx rhs_ty initDeltas) grhss + Just rhss_deltas -> ASSERT( length grhss == length rhss_deltas ) + zipWithM (dsGRHS hs_ctx rhs_ty) rhss_deltas grhss + ; let match_result1 = foldr1 combineMatchResults match_results + match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 + -- NB: nested dsLet inside matchResult + ; return match_result2 } + +dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc) + -> DsM (MatchResult CoreExpr) +dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs)) + = updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty) + +{- +************************************************************************ +* * +* matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS * +* * +************************************************************************ +-} + +matchGuards :: [GuardStmt GhcTc] -- Guard + -> HsStmtContext GhcRn -- Context + -> LHsExpr GhcTc -- RHS + -> Type -- Type of RHS of guard + -> DsM (MatchResult CoreExpr) + +-- See comments with HsExpr.Stmt re what a BodyStmt means +-- Here we must be in a guard context (not do-expression, nor list-comp) + +matchGuards [] _ rhs _ + = do { core_rhs <- dsLExpr rhs + ; return (cantFailMatchResult core_rhs) } + + -- BodyStmts must be guards + -- Turn an "otherwise" guard is a no-op. This ensures that + -- you don't get a "non-exhaustive eqns" message when the guards + -- finish in "otherwise". + -- NB: The success of this clause depends on the typechecker not + -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors + -- If it does, you'll get bogus overlap warnings +matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty + | Just addTicks <- isTrueLHsExpr e = do + match_result <- matchGuards stmts ctx rhs rhs_ty + return (adjustMatchResultDs addTicks match_result) +matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + pred_expr <- dsLExpr expr + return (mkGuardedMatchResult pred_expr match_result) + +matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + return (adjustMatchResultDs (dsLocalBinds binds) match_result) + -- NB the dsLet occurs inside the match_result + -- Reason: dsLet takes the body expression as its argument + -- so we can't desugar the bindings without the + -- body expression in hand + +matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do + let upat = unLoc pat + match_var <- selectMatchVar Many upat + -- We only allow unrestricted patterns in guard, hence the `Many` + -- above. It isn't clear what linear patterns would mean, maybe we will + -- figure it out in the future. + + match_result <- matchGuards stmts ctx rhs rhs_ty + core_rhs <- dsLExpr bind_rhs + match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty + match_result + pure $ bindNonRec match_var core_rhs <$> match_result' + +matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" +matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" +matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" +matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" +matchGuards (ApplicativeStmt {} : _) _ _ _ = + panic "matchGuards ApplicativeLastStmt" + +{- +Should {\em fail} if @e@ returns @D@ +\begin{verbatim} +f x | p <- e', let C y# = e, f y# = r1 + | otherwise = r2 +\end{verbatim} +-} diff --git a/GHC/HsToCore/ListComp.hs b/GHC/HsToCore/ListComp.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/ListComp.hs @@ -0,0 +1,670 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring list comprehensions, monad comprehensions and array comprehensions +-} + +{-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) + +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Core +import GHC.Core.Make + +import GHC.HsToCore.Monad -- the monadery used in the desugarer +import GHC.HsToCore.Utils + +import GHC.Driver.Session +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Core.Type +import GHC.Builtin.Types +import GHC.HsToCore.Match +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Tc.Utils.TcType +import GHC.Data.List.SetOps( getNth ) +import GHC.Utils.Misc + +{- +List comprehensions may be desugared in one of two ways: ``ordinary'' +(as you would expect if you read SLPJ's book) and ``with foldr/build +turned on'' (if you read Gill {\em et al.}'s paper on the subject). + +There will be at least one ``qualifier'' in the input. +-} + +dsListComp :: [ExprLStmt GhcTc] + -> Type -- Type of entire list + -> DsM CoreExpr +dsListComp lquals res_ty = do + dflags <- getDynFlags + let quals = map unLoc lquals + elt_ty = case tcTyConAppArgs res_ty of + [elt_ty] -> elt_ty + _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) + + if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags + -- Either rules are switched off, or we are ignoring what there are; + -- Either way foldr/build won't happen, so use the more efficient + -- Wadler-style desugaring + || isParallelComp quals + -- Foldr-style desugaring can't handle parallel list comprehensions + then deListComp quals (mkNilExpr elt_ty) + else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) + -- Foldr/build should be enabled, so desugar + -- into foldrs and builds + + where + -- We must test for ParStmt anywhere, not just at the head, because an extension + -- to list comprehensions would be to add brackets to specify the associativity + -- of qualifier lists. This is really easy to do by adding extra ParStmts into the + -- mix of possibly a single element in length, so we do this to leave the possibility open + isParallelComp = any isParallelStmt + + isParallelStmt (ParStmt {}) = True + isParallelStmt _ = False + + +-- This function lets you desugar a inner list comprehension and a list of the binders +-- of that comprehension that we need in the outer comprehension into such an expression +-- and the type of the elements that it outputs (tuples of binders) +dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) +dsInnerListComp (ParStmtBlock _ stmts bndrs _) + = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs + list_ty = mkListTy bndrs_tuple_type + + -- really use original bndrs below! + ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty + + ; return (expr, bndrs_tuple_type) } + +-- This function factors out commonality between the desugaring strategies for GroupStmt. +-- Given such a statement it gives you back an expression representing how to compute the transformed +-- list and the tuple that you need to bind from that list in order to proceed with your desugaring +dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc) +dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_using = using }) = do + let (from_bndrs, to_bndrs) = unzip binderMap + + let from_bndrs_tys = map idType from_bndrs + to_bndrs_tys = map idType to_bndrs + + to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts + from_bndrs noSyntaxExpr) + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + usingExpr' <- dsLExpr using + usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } + + -- Create an unzip function for the appropriate arity and element types and find "map" + unzip_stuff' <- mkUnzipBind form from_bndrs_tys + map_id <- dsLookupGlobalId mapName + + -- Generate the expressions to build the grouped list + let -- First we apply the grouping function to the inner list + inner_list_expr' = mkApps usingExpr' usingArgs' + -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists + -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and + -- the "b" to be a tuple of "to" lists! + -- Then finally we bind the unzip function around that expression + bound_unzipped_inner_list_expr' + = case unzip_stuff' of + Nothing -> inner_list_expr' + Just (unzip_fn', unzip_rhs') -> + Let (Rec [(unzip_fn', unzip_rhs')]) $ + mkApps (Var map_id) $ + [ Type (mkListTy from_tup_ty) + , Type to_bndrs_tup_ty + , Var unzip_fn' + , inner_list_expr' ] + + dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) + (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) + + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold lists rather than single values + let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! + return (bound_unzipped_inner_list_expr', pat) + +dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" + +{- +************************************************************************ +* * +* Ordinary desugaring of list comprehensions * +* * +************************************************************************ + +Just as in Phil's chapter~7 in SLPJ, using the rules for +optimally-compiled list comprehensions. This is what Kevin followed +as well, and I quite happily do the same. The TQ translation scheme +transforms a list of qualifiers (either boolean expressions or +generators) into a single expression which implements the list +comprehension. Because we are generating 2nd-order polymorphic +lambda-calculus, calls to NIL and CONS must be applied to a type +argument, as well as their usual value arguments. +\begin{verbatim} +TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> + +(Rule C) +TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> + +(Rule B) +TQ << [ e | b , qs ] ++ L >> = + if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> + +(Rule A') +TQ << [ e | p <- L1, qs ] ++ L2 >> = + letrec + h = \ u1 -> + case u1 of + [] -> TE << L2 >> + (u2 : u3) -> + (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) + [] (h u3) + in + h ( TE << L1 >> ) + +"h", "u1", "u2", and "u3" are new variables. +\end{verbatim} + +@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ +is the TE translation scheme. Note that we carry around the @L@ list +already desugared. @dsListComp@ does the top TE rule mentioned above. + +To the above, we add an additional rule to deal with parallel list +comprehensions. The translation goes roughly as follows: + [ e | p1 <- e11, let v1 = e12, p2 <- e13 + | q1 <- e21, let v2 = e22, q2 <- e23] + => + [ e | ((x1, .., xn), (y1, ..., ym)) <- + zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] + [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] +where (x1, .., xn) are the variables bound in p1, v1, p2 + (y1, .., ym) are the variables bound in q1, v2, q2 + +In the translation below, the ParStmt branch translates each parallel branch +into a sub-comprehension, and desugars each independently. The resulting lists +are fed to a zip function, we create a binding for all the variables bound in all +the comprehensions, and then we hand things off the desugarer for bindings. +The zip function is generated here a) because it's small, and b) because then we +don't have to deal with arbitrary limits on the number of zip functions in the +prelude, nor which library the zip function came from. +The introduced tuples are Boxed, but only because I couldn't get it to work +with the Unboxed variety. +-} + +deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr + +deListComp [] _ = panic "deListComp" + +deListComp (LastStmt _ body _ _ : quals) list + = -- Figure 7.4, SLPJ, p 135, rule C above + ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkConsExpr (exprType core_body) core_body list) } + + -- Non-last: must be a guard +deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above + core_guard <- dsLExpr guard + core_rest <- deListComp quals list + return (mkIfThenElse core_guard core_rest list) + +-- [e | let B, qs] = let B in [e | qs] +deListComp (LetStmt _ binds : quals) list = do + core_rest <- deListComp quals list + dsLocalBinds binds core_rest + +deListComp (stmt@(TransStmt {}) : quals) list = do + (inner_list_expr, pat) <- dsTransStmt stmt + deBindComp pat inner_list_expr quals list + +deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above + core_list1 <- dsLExprNoLP list1 + deBindComp pat core_list1 quals core_list2 + +deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list + = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs + ; let (exps, qual_tys) = unzip exps_and_qual_tys + + ; (zip_fn, zip_rhs) <- mkZipBind qual_tys + + -- Deal with [e | pat <- zip l1 .. ln] in example above + ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) + quals list } + where + bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] + + -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above + pat = mkBigLHsPatTupId pats + pats = map mkBigLHsVarPatTupId bndrs_s + +deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" + +deListComp (ApplicativeStmt {} : _) _ = + panic "deListComp ApplicativeStmt" + +deBindComp :: LPat GhcTc + -> CoreExpr + -> [ExprStmt GhcTc] + -> CoreExpr + -> DsM (Expr Id) +deBindComp pat core_list1 quals core_list2 = do + let u3_ty@u1_ty = exprType core_list1 -- two names, same thing + + -- u1_ty is a [alpha] type, and u2_ty = alpha + let u2_ty = hsLPatType pat + + let res_ty = exprType core_list2 + h_ty = u1_ty `mkVisFunTyMany` res_ty + + -- no levity polymorphism here, as list comprehensions don't work + -- with RebindableSyntax. NB: These are *not* monad comps. + [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty] + + -- the "fail" value ... + let + core_fail = App (Var h) (Var u3) + letrec_body = App (Var h) core_list1 + + rest_expr <- deListComp quals core_fail + core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail + + let + rhs = Lam u1 $ + Case (Var u1) u1 res_ty + [(DataAlt nilDataCon, [], core_list2), + (DataAlt consDataCon, [u2, u3], core_match)] + -- Increasing order of tag + + return (Let (Rec [(h, rhs)]) letrec_body) + +{- +************************************************************************ +* * +* Foldr/Build desugaring of list comprehensions * +* * +************************************************************************ + +@dfListComp@ are the rules used with foldr/build turned on: + +\begin{verbatim} +TE[ e | ] c n = c e n +TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n +TE[ e | p <- l , q ] c n = let + f = \ x b -> case x of + p -> TE[ e | q ] c b + _ -> b + in + foldr f n l +\end{verbatim} +-} + +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt GhcTc] -- the rest of the qual's + -> DsM CoreExpr + +dfListComp _ _ [] = panic "dfListComp" + +dfListComp c_id n_id (LastStmt _ body _ _ : quals) + = ASSERT( null quals ) + do { core_body <- dsLExprNoLP body + ; return (mkApps (Var c_id) [core_body, Var n_id]) } + + -- Non-last: must be a guard +dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do + core_guard <- dsLExpr guard + core_rest <- dfListComp c_id n_id quals + return (mkIfThenElse core_guard core_rest (Var n_id)) + +dfListComp c_id n_id (LetStmt _ binds : quals) = do + -- new in 1.3, local bindings + core_rest <- dfListComp c_id n_id quals + dsLocalBinds binds core_rest + +dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do + (inner_list_expr, pat) <- dsTransStmt stmt + -- Anyway, we bind the newly grouped list via the generic binding function + dfBindComp c_id n_id (pat, inner_list_expr) quals + +dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do + -- evaluate the two lists + core_list1 <- dsLExpr list1 + + -- Do the rest of the work in the generic binding builder + dfBindComp c_id n_id (pat, core_list1) quals + +dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" +dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" +dfListComp _ _ (ApplicativeStmt {} : _) = + panic "dfListComp ApplicativeStmt" + +dfBindComp :: Id -> Id -- 'c' and 'n' + -> (LPat GhcTc, CoreExpr) + -> [ExprStmt GhcTc] -- the rest of the qual's + -> DsM CoreExpr +dfBindComp c_id n_id (pat, core_list1) quals = do + -- find the required type + let x_ty = hsLPatType pat + let b_ty = idType n_id + + -- create some new local id's + b <- newSysLocalDs Many b_ty + x <- newSysLocalDs Many x_ty + + -- build rest of the comprehension + core_rest <- dfListComp c_id b quals + + -- build the pattern match + core_expr <- matchSimply (Var x) (StmtCtxt ListComp) + pat core_rest (Var b) + + -- now build the outermost foldr, and return + mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 + +{- +************************************************************************ +* * +\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} +* * +************************************************************************ +-} + +mkZipBind :: [Type] -> DsM (Id, CoreExpr) +-- mkZipBind [t1, t2] +-- = (zip, \as1:[t1] as2:[t2] +-- -> case as1 of +-- [] -> [] +-- (a1:as'1) -> case as2 of +-- [] -> [] +-- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] + +mkZipBind elt_tys = do + ass <- mapM (newSysLocalDs Many) elt_list_tys + as' <- mapM (newSysLocalDs Many) elt_tys + as's <- mapM (newSysLocalDs Many) elt_list_tys + + zip_fn <- newSysLocalDs Many zip_fn_ty + + let inner_rhs = mkConsExpr elt_tuple_ty + (mkBigCoreVarTup as') + (mkVarApps (Var zip_fn) as's) + zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) + + return (zip_fn, mkLams ass zip_body) + where + elt_list_tys = map mkListTy elt_tys + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + + zip_fn_ty = mkVisFunTysMany elt_list_tys elt_tuple_list_ty + + mk_case (as, a', as') rest + = Case (Var as) as elt_tuple_list_ty + [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), + (DataAlt consDataCon, [a', as'], rest)] + -- Increasing order of tag + + +mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) +-- mkUnzipBind [t1, t2] +-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) +-- -> case ax of +-- (x1, x2) -> case axs of +-- (xs1, xs2) -> (x1 : xs1, x2 : xs2)) +-- ([], []) +-- ys) +-- +-- We use foldr here in all cases, even if rules are turned off, because we may as well! +mkUnzipBind ThenForm _ + = return Nothing -- No unzipping for ThenForm +mkUnzipBind _ elt_tys + = do { ax <- newSysLocalDs Many elt_tuple_ty + ; axs <- newSysLocalDs Many elt_list_tuple_ty + ; ys <- newSysLocalDs Many elt_tuple_list_ty + ; xs <- mapM (newSysLocalDs Many) elt_tys + ; xss <- mapM (newSysLocalDs Many) elt_list_tys + + ; unzip_fn <- newSysLocalDs Many unzip_fn_ty + + ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] + + ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) + concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) + tupled_concat_expression = mkBigCoreTup concat_expressions + + folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) + folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) + folder_body = mkLams [ax, axs] folder_body_outer_case + + ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) + ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } + where + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + elt_list_tys = map mkListTy elt_tys + elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys + + unzip_fn_ty = elt_tuple_list_ty `mkVisFunTyMany` elt_list_tuple_ty + + mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail + +-- Translation for monad comprehensions + +-- Entry point for monad comprehension desugaring +dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsMonadComp stmts = dsMcStmts stmts + +dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) + +--------------- +dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr + +dsMcStmt (LastStmt _ body _ ret_op) stmts + = ASSERT( null stmts ) + do { body' <- dsLExpr body + ; dsSyntaxExpr ret_op [body'] } + +-- [ .. | let binds, stmts ] +dsMcStmt (LetStmt _ binds) stmts + = do { rest <- dsMcStmts stmts + ; dsLocalBinds binds rest } + +-- [ .. | a <- m, stmts ] +dsMcStmt (BindStmt xbs pat rhs) stmts + = do { rhs' <- dsLExpr rhs + ; dsMcBindStmt pat rhs' (xbstc_bindOp xbs) (xbstc_failOp xbs) (xbstc_boundResultType xbs) stmts } + +-- Apply `guard` to the `exp` expression +-- +-- [ .. | exp, stmts ] +-- +dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts + = do { exp' <- dsLExpr exp + ; rest <- dsMcStmts stmts + ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] + ; dsSyntaxExpr then_exp [guard_exp', rest] } + +-- Group statements desugar like this: +-- +-- [| (q, then group by e using f); rest |] +-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> +-- case unzip n_tup of qv' -> [| rest |] +-- +-- where variables (v1:t1, ..., vk:tk) are bound by q +-- qv = (v1, ..., vk) +-- qt = (t1, ..., tk) +-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b +-- f :: forall a. (a -> t) -> m1 a -> m2 (n a) +-- n_tup :: n qt +-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) + +dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs + , trS_by = by, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_ext = n_tup_ty' -- n (a,b,c) + , trS_fmap = fmap_op, trS_form = form }) stmts_rest + = do { let (from_bndrs, to_bndrs) = unzip bndrs + + ; let from_bndr_tys = map idType from_bndrs -- Types ty + + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + ; expr' <- dsInnerMonadComp stmts from_bndrs return_op + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + ; usingExpr' <- dsLExpr using + ; usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } + + -- Generate the expressions to build the grouped list + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold monads rather than single values + ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs + + ; body <- dsMcStmts stmts_rest + ; n_tup_var' <- newSysLocalDsNoLP Many n_tup_ty' + ; tup_n_var' <- newSysLocalDs Many tup_n_ty' + ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys + ; us <- newUniqueSupply + ; let rhs' = mkApps usingExpr' usingArgs' + body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' + + ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } + +-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel +-- statements, for example: +-- +-- [ body | qs1 | qs2 | qs3 ] +-- -> [ body | (bndrs1, (bndrs2, bndrs3)) +-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] +-- +-- where `mzip` has type +-- mzip :: forall a b. m a -> m b -> m (a,b) +-- NB: we need a polymorphic mzip because we call it several times + +dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest + = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) + ; mzip_op' <- dsExpr mzip_op + + ; let -- The pattern variables + pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] + -- Pattern with tuples of variables + -- [v1,v2,v3] => (v1, (v2, v3)) + pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats + (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> + (mkApps mzip_op' [Type t1, Type t2, e1, e2], + mkBoxedTupleTy [t1,t2])) + exps_w_tys + + ; dsMcBindStmt pat rhs bind_op Nothing bind_ty stmts_rest } + where + ds_inner :: ParStmtBlock GhcTc GhcTc -> DsM (CoreExpr, Type) + ds_inner (ParStmtBlock _ stmts bndrs return_op) + = do { exp <- dsInnerMonadComp stmts bndrs return_op + ; return (exp, mkBigCoreVarTupTy bndrs) } + +dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) + + +matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr +-- (matchTuple [a,b,c] body) +-- returns the Core term +-- \x. case x of (a,b,c) -> body +matchTuple ids body + = do { us <- newUniqueSupply + ; tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy ids) + ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } + +-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a +-- desugared `CoreExpr` +dsMcBindStmt :: LPat GhcTc + -> CoreExpr -- ^ the desugared rhs of the bind statement + -> SyntaxExpr GhcTc + -> Maybe (SyntaxExpr GhcTc) + -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T + -> [ExprLStmt GhcTc] + -> DsM CoreExpr +dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts + = do { body <- dsMcStmts stmts + ; var <- selectSimpleMatchVarL Many pat + ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat + res1_ty (cantFailMatchResult body) + ; match_code <- dsHandleMonadicFailure pat match fail_op + ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } + +-- Desugar nested monad comprehensions, for example in `then..` constructs +-- dsInnerMonadComp quals [a,b,c] ret_op +-- returns the desugaring of +-- [ (a,b,c) | quals ] + +dsInnerMonadComp :: [ExprLStmt GhcTc] + -> [Id] -- Return a tuple of these variables + -> SyntaxExpr GhcTc -- The monomorphic "return" operator + -> DsM CoreExpr +dsInnerMonadComp stmts bndrs ret_op + = dsMcStmts (stmts ++ + [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)]) + + +-- The `unzip` function for `GroupStmt` in a monad comprehensions +-- +-- unzip :: m (a,b,..) -> (m a,m b,..) +-- unzip m_tuple = ( liftM selN1 m_tuple +-- , liftM selN2 m_tuple +-- , .. ) +-- +-- mkMcUnzipM fmap ys [t1, t2] +-- = ( fmap (selN1 :: (t1, t2) -> t1) ys +-- , fmap (selN2 :: (t1, t2) -> t2) ys ) + +mkMcUnzipM :: TransForm + -> HsExpr GhcTc -- fmap + -> Id -- Of type n (a,b,c) + -> [Type] -- [a,b,c] (not levity-polymorphic) + -> DsM CoreExpr -- Of type (n a, n b, n c) +mkMcUnzipM ThenForm _ ys _ + = return (Var ys) -- No unzipping to do + +mkMcUnzipM _ fmap_op ys elt_tys + = do { fmap_op' <- dsExpr fmap_op + ; xs <- mapM (newSysLocalDs Many) elt_tys + ; let tup_ty = mkBigCoreTupTy elt_tys + ; tup_xs <- newSysLocalDs Many tup_ty + + ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b + [ Type tup_ty, Type (getNth elt_tys i) + , mk_sel i, Var ys] + + mk_sel n = Lam tup_xs $ + mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) + + ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/GHC/HsToCore/Match.hs b/GHC/HsToCore/Match.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match.hs @@ -0,0 +1,1194 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @match@ function +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.HsToCore.Match + ( match, matchEquations, matchWrapper, matchSimply + , matchSinglePat, matchSinglePatVar + ) +where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) + +import GHC.Types.Basic ( Origin(..) ) +import GHC.Driver.Session +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad +import GHC.HsToCore.PmCheck +import GHC.Core +import GHC.Types.Literal +import GHC.Core.Utils +import GHC.Core.Make +import GHC.HsToCore.Monad +import GHC.HsToCore.Binds +import GHC.HsToCore.GuardedRHSs +import GHC.HsToCore.Utils +import GHC.Types.Id +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.HsToCore.Match.Constructor +import GHC.HsToCore.Match.Literal +import GHC.Core.Type +import GHC.Core.Coercion ( eqCoercion ) +import GHC.Core.TyCon ( isNewTyCon ) +import GHC.Core.Multiplicity +import GHC.Builtin.Types +import GHC.Types.SrcLoc +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Types.Basic ( isGenerated, il_value, fl_value, Boxity(..) ) +import GHC.Data.FastString +import GHC.Types.Unique +import GHC.Types.Unique.DFM + +import Control.Monad( unless ) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map + +{- +************************************************************************ +* * + The main matching function +* * +************************************************************************ + +The function @match@ is basically the same as in the Wadler chapter +from "The Implementation of Functional Programming Languages", +except it is monadised, to carry around the name supply, info about +annotations, etc. + +Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: +\begin{enumerate} +\item +A list of $n$ variable names, those variables presumably bound to the +$n$ expressions being matched against the $n$ patterns. Using the +list of $n$ expressions as the first argument showed no benefit and +some inelegance. + +\item +The second argument, a list giving the ``equation info'' for each of +the $m$ equations: +\begin{itemize} +\item +the $n$ patterns for that equation, and +\item +a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on +the front'' of the matching code, as in: +\begin{verbatim} +let +in +\end{verbatim} +\item +and finally: (ToDo: fill in) + +The right way to think about the ``after-match function'' is that it +is an embryonic @CoreExpr@ with a ``hole'' at the end for the +final ``else expression''. +\end{itemize} + +There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@. + +An experiment with re-ordering this information about equations (in +particular, having the patterns available in column-major order) +showed no benefit. + +\item +A default expression---what to evaluate if the overall pattern-match +fails. This expression will (almost?) always be +a measly expression @Var@, unless we know it will only be used once +(as we do in @glue_success_exprs@). + +Leaving out this third argument to @match@ (and slamming in lots of +@Var "fail"@s) is a positively {\em bad} idea, because it makes it +impossible to share the default expressions. (Also, it stands no +chance of working in our post-upheaval world of @Locals@.) +\end{enumerate} + +Note: @match@ is often called via @matchWrapper@ (end of this module), +a function that does much of the house-keeping that goes with a call +to @match@. + +It is also worth mentioning the {\em typical} way a block of equations +is desugared with @match@. At each stage, it is the first column of +patterns that is examined. The steps carried out are roughly: +\begin{enumerate} +\item +Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add +bindings to the second component of the equation-info): +\item +Now {\em unmix} the equations into {\em blocks} [w\/ local function +@match_groups@], in which the equations in a block all have the same + match group. +(see ``the mixture rule'' in SLPJ). +\item +Call the right match variant on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern. +\end{enumerate} + +We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) +than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). +And gluing the ``success expressions'' together isn't quite so pretty. + +This @match@ uses @tidyEqnInfo@ +to get `as'- and `twiddle'-patterns out of the way (tidying), before +applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em +un}mixes the equations], producing a list of equation-info +blocks, each block having as its first column patterns compatible with each other. + +Note [Match Ids] +~~~~~~~~~~~~~~~~ +Most of the matching functions take an Id or [Id] as argument. This Id +is the scrutinee(s) of the match. The desugared expression may +sometimes use that Id in a local binding or as a case binder. So it +should not have an External name; Lint rejects non-top-level binders +with External names (#13043). + +See also Note [Localise pattern binders] in GHC.HsToCore.Utils +-} + +type MatchId = Id -- See Note [Match Ids] + +match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with + -- ^ See Note [Match Ids] + -- + -- ^ Note that the Match Ids carry not only a name, but + -- ^ also the multiplicity at which each column has been + -- ^ type checked. + -> Type -- ^ Type of the case expression + -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) + -> DsM (MatchResult CoreExpr) -- ^ Desugared result! + +match [] ty eqns + = ASSERT2( not (null eqns), ppr ty ) + return (foldr1 combineMatchResults match_results) + where + match_results = [ ASSERT( null (eqn_pats eqn) ) + eqn_rhs eqn + | eqn <- eqns ] + +match (v:vs) ty eqns -- Eqns *can* be empty + = ASSERT2( all (isInternalName . idName) vars, ppr vars ) + do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + -- Tidy the first pattern, generating + -- auxiliary bindings if necessary + ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + -- Group the equations and match each group in turn + ; let grouped = groupEquations platform tidy_eqns + + -- print the view patterns that are commoned up to help debug + ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) + + ; match_results <- match_groups grouped + ; return $ foldr (.) id aux_binds <$> + foldr1 combineMatchResults match_results + } + where + vars = v :| vs + + dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo + dropGroup = fmap snd + + match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr)) + -- Result list of [MatchResult CoreExpr] is always non-empty + match_groups [] = matchEmpty v ty + match_groups (g:gs) = mapM match_group $ g :| gs + + match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) + match_group eqns@((group,_) :| _) + = case group of + PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) + PgSyn {} -> matchPatSyn vars ty (dropGroup eqns) + PgLit {} -> matchLiterals vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns']) + PgAny -> matchVariables vars ty (dropGroup eqns) + PgN {} -> matchNPats vars ty (dropGroup eqns) + PgOverS {}-> matchNPats vars ty (dropGroup eqns) + PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns) + PgBang -> matchBangs vars ty (dropGroup eqns) + PgCo {} -> matchCoercion vars ty (dropGroup eqns) + PgView {} -> matchView vars ty (dropGroup eqns) + PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) + where eqns' = NEL.toList eqns + ne l = case NEL.nonEmpty l of + Just nel -> nel + Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty" + + -- FIXME: we should also warn about view patterns that should be + -- commoned up but are not + + -- print some stuff to see what's getting grouped + -- use -dppr-debug to see the resolution of overloaded literals + debug eqns = + let gs = map (\group -> foldr (\ (p,_) -> \acc -> + case p of PgView e _ -> e:acc + _ -> acc) [] group) eqns + maybeWarn [] = return () + maybeWarn l = warnDs NoReason (vcat l) + in + maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) + (filter (not . null) gs)) + +matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr)) +-- See Note [Empty case expressions] +matchEmpty var res_ty + = return [MR_Fallible mk_seq] + where + mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty + [(DEFAULT, [], fail)] + +matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +-- Real true variables, just like in matchVar, SLPJ p 94 +-- No binding to do: they'll all be wildcards by now (done in tidy) +matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns + +matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +matchBangs (var :| vars) ty eqns + = do { match_result <- match (var:vars) ty $ NEL.toList $ + decomposeFirstPat getBangPat <$> eqns + ; return (mkEvalMatchResult var ty match_result) } + +matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +-- Apply the coercion to the match variable and then match that +matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) + = do { let XPat (CoPat co pat _) = firstPat eqn1 + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var (idMult var) pat_ty' + ; match_result <- match (var':vars) ty $ NEL.toList $ + decomposeFirstPat getCoPat <$> eqns + ; core_wrap <- dsHsWrapper co + ; let bind = NonRec var' (core_wrap (Var var)) + ; return (mkCoLetMatchResult bind match_result) } + +matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +-- Apply the view function to the match variable and then match that +matchView (var :| vars) ty (eqns@(eqn1 :| _)) + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway + -- to figure out the type of the fresh variable + let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 + -- do the rest of the compilation + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var (idMult var) pat_ty' + ; match_result <- match (var':vars) ty $ NEL.toList $ + decomposeFirstPat getViewPat <$> eqns + -- compile the view expressions + ; viewExpr' <- dsLExpr viewExpr + ; return (mkViewMatchResult var' + (mkCoreAppDs (text "matchView") viewExpr' (Var var)) + match_result) } + +matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) +-- Since overloaded list patterns are treated as view patterns, +-- the code is roughly the same as for matchView + = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 + ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty) -- we construct the overall type by hand + ; match_result <- match (var':vars) ty $ NEL.toList $ + decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern + ; e' <- dsSyntaxExpr e [Var var] + ; return (mkViewMatchResult var' e' match_result) + } + +-- decompose the first pattern and leave the rest alone +decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo +decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) + = eqn { eqn_pats = extractpat pat : pats} +decomposeFirstPat _ _ = panic "decomposeFirstPat" + +getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc +getCoPat (XPat (CoPat _ pat _)) = pat +getCoPat _ = panic "getCoPat" +getBangPat (BangPat _ pat ) = unLoc pat +getBangPat _ = panic "getBangPat" +getViewPat (ViewPat _ _ pat) = unLoc pat +getViewPat _ = panic "getViewPat" +getOLPat (ListPat (ListPatTc ty (Just _)) pats) + = ListPat (ListPatTc ty Nothing) pats +getOLPat _ = panic "getOLPat" + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The list of EquationInfo can be empty, arising from + case x of {} or \case {} +In that situation we desugar to + case x of { _ -> error "pattern match failure" } +The *desugarer* isn't certain whether there really should be no +alternatives, so it adds a default case, as it always does. A later +pass may remove it if it's inaccessible. (See also Note [Empty case +alternatives] in GHC.Core.) + +We do *not* desugar simply to + error "empty case" +or some such, because 'x' might be bound to (error "hello"), in which +case we want to see that "hello" exception, not (error "empty case"). +See also Note [Case elimination: lifted case] in GHC.Core.Opt.Simplify. + + +************************************************************************ +* * + Tidying patterns +* * +************************************************************************ + +Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ +which will be scrutinised. + +This makes desugaring the pattern match simpler by transforming some of +the patterns to simpler forms. (Tuples to Constructor Patterns) + +Among other things in the resulting Pattern: +* Variables and irrefutable(lazy) patterns are replaced by Wildcards +* As patterns are replaced by the patterns they wrap. + +The bindings created by the above patterns are put into the returned wrapper +instead. + +This means a definition of the form: + f x = rhs +when called with v get's desugared to the equivalent of: + let x = v + in + f _ = rhs + +The same principle holds for as patterns (@) and +irrefutable/lazy patterns (~). +In the case of irrefutable patterns the irrefutable pattern is pushed into +the binding. + +Pattern Constructors which only represent syntactic sugar are converted into +their desugared representation. +This usually means converting them to Constructor patterns but for some +depends on enabled extensions. (Eg OverloadedLists) + +GHC also tries to convert overloaded Literals into regular ones. + +The result of this tidying is that the column of patterns will include +only these which can be assigned a PatternGroup (see patGroup). + +-} + +tidyEqnInfo :: Id -> EquationInfo + -> DsM (DsWrapper, EquationInfo) + -- DsM'd because of internal call to dsLHsBinds + -- and mkSelectorBinds. + -- "tidy1" does the interesting stuff, looking at + -- one pattern and fiddling the list of bindings. + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- one of these for which patGroup is defined. + +tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) + = panic "tidyEqnInfo" + +tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) + = do { (wrap, pat') <- tidy1 v orig pat + ; return (wrap, eqn { eqn_pats = do pat' : pats }) } + +tidy1 :: Id -- The Id being scrutinised + -> Origin -- Was this a pattern the user wrote? + -> Pat GhcTc -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings to do before the match + Pat GhcTc) -- Equivalent pattern + +------------------------------------------------------- +-- (pat', mr') = tidy1 v pat mr +-- tidies the *outer level only* of pat, giving pat' +-- It eliminates many pattern forms (as-patterns, variable patterns, +-- list patterns, etc) and returns any created bindings in the wrapper. + +tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) +tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) +tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p + + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } +tidy1 v _ (VarPat _ (L _ var)) + = return (wrapBind var v, WildPat (idType var)) + + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } +tidy1 v o (AsPat _ (L _ var) pat) + = do { (wrap, pat') <- tidy1 v o (unLoc pat) + ; return (wrapBind var v . wrap, pat') } + +{- now, here we handle lazy patterns: + tidy1 v ~p bs = (v, v1 = case v of p -> v1 : + v2 = case v of p -> v2 : ... : bs ) + + where the v_i's are the binders in the pattern. + + ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? + + The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr +-} + +tidy1 v _ (LazyPat _ pat) + -- This is a convenient place to check for unlifted types under a lazy pattern. + -- Doing this check during type-checking is unsatisfactory because we may + -- not fully know the zonked types yet. We sure do here. + = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) + ; unless (null unlifted_bndrs) $ + putSrcSpanDs (getLoc pat) $ + errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ + text "Unlifted variables:") + 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) + unlifted_bndrs))) + + ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; return (mkCoreLets sel_binds, WildPat (idType v)) } + +tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats ) + = return (idDsWrapper, unLoc list_ConPat) + where + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) + (mkNilPat ty) + pats + +tidy1 _ _ (TuplePat tys pats boxity) + = return (idDsWrapper, unLoc tuple_ConPat) + where + arity = length pats + tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys' + tys' = case boxity of + Unboxed -> map getRuntimeRep tys ++ tys + Boxed -> tys + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + +tidy1 _ _ (SumPat tys pat alt arity) + = return (idDsWrapper, unLoc sum_ConPat) + where + sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys) + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + +-- LitPats: we *might* be able to replace these w/ a simpler form +tidy1 _ o (LitPat _ lit) + = do { unless (isGenerated o) $ + warnAboutOverflowedLit lit + ; return (idDsWrapper, tidyLitPat lit) } + +-- NPats: we *might* be able to replace these w/ a simpler form +tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) + = do { unless (isGenerated o) $ + let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } + | otherwise = lit + in warnAboutOverflowedOverLit lit' + ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } + +-- NPlusKPat: we may want to warn about the literals +tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) + = do { unless (isGenerated o) $ do + warnAboutOverflowedOverLit lit1 + warnAboutOverflowedOverLit lit2 + ; return (idDsWrapper, n) } + +-- Everything else goes through unchanged... +tidy1 _ _ non_interesting_pat + = return (idDsWrapper, non_interesting_pat) + +-------------------- +tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc + -> DsM (DsWrapper, Pat GhcTc) + +-- Discard par/sig under a bang +tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p +tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p + +-- Push the bang-pattern inwards, in the hope that +-- it may disappear next time +tidy_bang_pat v o l (AsPat x v' p) + = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) +tidy_bang_pat v o l (XPat (CoPat w p t)) + = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t) + +-- Discard bang around strict pattern +tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p +tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p +tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p +tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p + +-- Data/newtype constructors +tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc) + , pat_args = args + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + } + }) + -- Newtypes: push bang inwards (#9844) + = + if isNewTyCon (dataConTyCon dc) + then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) + else tidy1 v o p -- Data types: discard the bang + where + (ty:_) = dataConInstArgTys dc arg_tys + +------------------- +-- Default case, leave the bang there: +-- VarPat, +-- LazyPat, +-- WildPat, +-- ViewPat, +-- pattern synonyms (ConPatOut with PatSynCon) +-- NPat, +-- NPlusKPat +-- +-- For LazyPat, remember that it's semantically like a VarPat +-- i.e. !(~p) is not like ~p, or p! (#8952) +-- +-- NB: SigPatIn, ConPatIn should not happen + +tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) + +------------------- +push_bang_into_newtype_arg :: SrcSpan + -> Type -- The type of the argument we are pushing + -- onto + -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc +-- See Note [Bang patterns and newtypes] +-- We are transforming !(N p) into (N !p) +push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) + = ASSERT( null args) + PrefixCon [L l (BangPat noExtField arg)] +push_bang_into_newtype_arg l _ty (RecCon rf) + | HsRecFields { rec_flds = L lf fld : flds } <- rf + , HsRecField { hsRecFieldArg = arg } <- fld + = ASSERT( null flds) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + = L l (BangPat noExtField arg) })] }) +push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) + | HsRecFields { rec_flds = [] } <- rf + = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))] +push_bang_into_newtype_arg _ _ cd + = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) + +{- +Note [Bang patterns and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the pattern !(Just pat) we can discard the bang, because +the pattern is strict anyway. But for !(N pat), where + newtype NT = N Int +we definitely can't discard the bang. #9844. + +So what we do is to push the bang inwards, in the hope that it will +get discarded there. So we transform + !(N pat) into (N !pat) + +But what if there is nothing to push the bang onto? In at least one instance +a user has written !(N {}) which we translate into (N !_). See #13215 + + +\noindent +{\bf Previous @matchTwiddled@ stuff:} + +Now we get to the only interesting part; note: there are choices for +translation [from Simon's notes]; translation~1: +\begin{verbatim} +deTwiddle [s,t] e +\end{verbatim} +returns +\begin{verbatim} +[ w = e, + s = case w of [s,t] -> s + t = case w of [s,t] -> t +] +\end{verbatim} + +Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple +evaluation of \tr{e}. An alternative translation (No.~2): +\begin{verbatim} +[ w = case e of [s,t] -> (s,t) + s = case w of (s,t) -> s + t = case w of (s,t) -> t +] +\end{verbatim} + +************************************************************************ +* * +\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} +* * +************************************************************************ + +We might be able to optimise unmixing when confronted by +only-one-constructor-possible, of which tuples are the most notable +examples. Consider: +\begin{verbatim} +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +f j ... = ... +\end{verbatim} +This definition would normally be unmixed into four equation blocks, +one per equation. But it could be unmixed into just one equation +block, because if the one equation matches (on the first column), +the others certainly will. + +You have to be careful, though; the example +\begin{verbatim} +f j ... = ... +------------------- +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +\end{verbatim} +{\em must} be broken into two blocks at the line shown; otherwise, you +are forcing unnecessary evaluation. In any case, the top-left pattern +always gives the cue. You could then unmix blocks into groups of... +\begin{description} +\item[all variables:] +As it is now. +\item[constructors or variables (mixed):] +Need to make sure the right names get bound for the variable patterns. +\item[literals or variables (mixed):] +Presumably just a variant on the constructor case (as it is now). +\end{description} + +************************************************************************ +* * +* matchWrapper: a convenient way to call @match@ * +* * +************************************************************************ +\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} + +Calls to @match@ often involve similar (non-trivial) work; that work +is collected here, in @matchWrapper@. This function takes as +arguments: +\begin{itemize} +\item +Typechecked @Matches@ (of a function definition, or a case or lambda +expression)---the main input; +\item +An error message to be inserted into any (runtime) pattern-matching +failure messages. +\end{itemize} + +As results, @matchWrapper@ produces: +\begin{itemize} +\item +A list of variables (@Locals@) that the caller must ``promise'' to +bind to appropriate values; and +\item +a @CoreExpr@, the desugared output (main result). +\end{itemize} + +The main actions of @matchWrapper@ include: +\begin{enumerate} +\item +Flatten the @[TypecheckedMatch]@ into a suitable list of +@EquationInfo@s. +\item +Create as many new variables as there are patterns in a pattern-list +(in any one of the @EquationInfo@s). +\item +Create a suitable ``if it fails'' expression---a call to @error@ using +the error-string input; the {\em type} of this fail value can be found +by examining one of the RHS expressions in one of the @EquationInfo@s. +\item +Call @match@ with all of this information! +\end{enumerate} +-} + +matchWrapper + :: HsMatchContext GhcRn -- ^ For shadowing warning messages + -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr + -- case scrut of { p1 -> e1 ... } + -- (and in this case the MatchGroup will + -- have all singleton patterns) + -- Nothing for a function definition + -- f p1 q1 = ... -- No "scrutinee" + -- f p2 q2 = ... -- in this case + -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared + -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match') + +{- + There is one small problem with the Lambda Patterns, when somebody + writes something similar to: +\begin{verbatim} + (\ (x:xs) -> ...) +\end{verbatim} + he/she don't want a warning about incomplete patterns, that is done with + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @GHC.HsToCore.Expr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than +one pattern, and match simply only accepts one pattern. + +JJQC 30-Nov-1997 +-} + +matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches + , mg_ext = MatchGroupTc arg_tys rhs_ty + , mg_origin = origin }) + = do { dflags <- getDynFlags + ; locn <- getSrcSpanDs + + ; new_vars <- case matches of + [] -> newSysLocalsDsNoLP arg_tys + (m:_) -> + selectMatchVars (zipWithEqual "matchWrapper" + (\a b -> (scaledMult a, unLoc b)) + arg_tys + (hsLMatchPats m)) + + -- Pattern match check warnings for /this match-group/. + -- @rhss_deltas@ is a flat list of covered Deltas for each RHS. + -- Each Match will split off one Deltas for its RHSs from this. + ; rhss_deltas <- if isMatchContextPmChecked dflags origin ctxt + then addScrutTmCs mb_scr new_vars $ + -- See Note [Type and Term Equality Propagation] + checkMatches (DsMatchContext ctxt locn) new_vars matches + else pure [] -- Ultimately this will result in passing Nothing + -- to dsGRHSs as match_deltas + + ; eqns_info <- mk_eqn_infos matches rhss_deltas + + ; result_expr <- handleWarnings $ + matchEquations ctxt new_vars eqns_info rhs_ty + ; return (new_vars, result_expr) } + where + -- rhss_deltas is a flat list, whereas there are multiple GRHSs per match. + -- mk_eqn_infos will thread rhss_deltas as state through calls to + -- mk_eqn_info, distributing each rhss_deltas to a GRHS. + mk_eqn_infos (L _ match : matches) rhss_deltas + = do { (info, rhss_deltas') <- mk_eqn_info match rhss_deltas + ; infos <- mk_eqn_infos matches rhss_deltas' + ; return (info:infos) } + mk_eqn_infos [] _ = return [] + -- Called once per equation in the match, or alternative in the case + mk_eqn_info (Match { m_pats = pats, m_grhss = grhss }) rhss_deltas + | GRHSs _ grhss' _ <- grhss, let n_grhss = length grhss' + = do { dflags <- getDynFlags + ; let upats = map (unLoc . decideBangHood dflags) pats + -- Split off one Deltas for each GRHS of the current Match from the + -- flat list of GRHS Deltas *for all matches* (see the call to + -- checkMatches above). + ; let (match_deltas, rhss_deltas') = splitAt n_grhss rhss_deltas + -- The list of Deltas is empty iff we don't perform any coverage + -- checking, in which case nonEmpty does the right thing by passing + -- Nothing. + ; match_result <- dsGRHSs ctxt grhss rhs_ty (NEL.nonEmpty match_deltas) + ; return ( EqnInfo { eqn_pats = upats + , eqn_orig = FromSource + , eqn_rhs = match_result } + , rhss_deltas' ) } + + handleWarnings = if isGenerated origin + then discardWarningsDs + else id + +matchEquations :: HsMatchContext GhcRn + -> [MatchId] -> [EquationInfo] -> Type + -> DsM CoreExpr +matchEquations ctxt vars eqns_info rhs_ty + = do { let error_doc = matchContextErrString ctxt + + ; match_result <- match vars rhs_ty eqns_info + + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc + ; extractMatchResult match_result fail_expr } + +{- +************************************************************************ +* * +\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} +* * +************************************************************************ + +@mkSimpleMatch@ is a wrapper for @match@ which deals with the +situation where we want to match a single expression against a single +pattern. It returns an expression. +-} + +matchSimply :: CoreExpr -- ^ Scrutinee + -> HsMatchContext GhcRn -- ^ Match kind + -> LPat GhcTc -- ^ Pattern it should match + -> CoreExpr -- ^ Return this if it matches + -> CoreExpr -- ^ Return this if it doesn't + -> DsM CoreExpr +-- Do not warn about incomplete patterns; see matchSinglePat comments +matchSimply scrut hs_ctx pat result_expr fail_expr = do + let + match_result = cantFailMatchResult result_expr + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result + extractMatchResult match_result' fail_expr + +matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) +-- matchSinglePat ensures that the scrutinee is a variable +-- and then calls matchSinglePatVar +-- +-- matchSinglePat does not warn about incomplete patterns +-- Used for things like [ e | pat <- stuff ], where +-- incomplete patterns are just fine + +matchSinglePat (Var var) ctx pat ty match_result + | not (isExternalName (idName var)) + = matchSinglePatVar var ctx pat ty match_result + +matchSinglePat scrut hs_ctx pat ty match_result + = do { var <- selectSimpleMatchVarL Many pat + -- matchSinglePat is only used in matchSimply, which + -- is used in list comprehension, arrow notation, + -- and to create field selectors. All of which only + -- bind unrestricted variables, hence the 'Many' + -- above. + ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result + ; return $ bindNonRec var scrut <$> match_result' + } + +matchSinglePatVar :: Id -- See Note [Match Ids] + -> HsMatchContext GhcRn -> LPat GhcTc + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) +matchSinglePatVar var ctx pat ty match_result + = ASSERT2( isInternalName (idName var), ppr var ) + do { dflags <- getDynFlags + ; locn <- getSrcSpanDs + + -- Pattern match check warnings + ; if isMatchContextPmChecked dflags FromSource ctx + then checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) + else pure () + + ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] + , eqn_orig = FromSource + , eqn_rhs = match_result } + ; match [var] ty [eqn_info] } + + +{- +************************************************************************ +* * + Pattern classification +* * +************************************************************************ +-} + +data PatGroup + = PgAny -- Immediate match: variables, wildcards, + -- lazy patterns + | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups] + | PgLit Literal -- Literal patterns + | PgN Rational -- Overloaded numeric literals; + -- see Note [Don't use Literal for PgN] + | PgOverS FastString -- Overloaded string literals + | PgNpK Integer -- n+k patterns + | PgBang -- Bang patterns + | PgCo Type -- Coercion patterns; the type is the type + -- of the pattern *inside* + | PgView (LHsExpr GhcTc) -- view pattern (e -> p): + -- the LHsExpr is the expression e + Type -- the Type is the type of p (equivalently, the result type of e) + | PgOverloadedList + +{- Note [Don't use Literal for PgN] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously we had, as PatGroup constructors + + | ... + | PgN Literal -- Overloaded literals + | PgNpK Literal -- n+k patterns + | ... + +But Literal is really supposed to represent an *unboxed* literal, like Int#. +We were sticking the literal from, say, an overloaded numeric literal pattern +into a LitInt constructor. This didn't really make sense; and we now have +the invariant that value in a LitInt must be in the range of the target +machine's Int# type, and an overloaded literal could meaningfully be larger. + +Solution: For pattern grouping purposes, just store the literal directly in +the PgN constructor as a Rational if numeric, and add a PgOverStr constructor +for overloaded strings. +-} + +groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] +-- If the result is of form [g1, g2, g3], +-- (a) all the (pg,eq) pairs in g1 have the same pg +-- (b) none of the gi are empty +-- The ordering of equations is unchanged +groupEquations platform eqns + = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns] + -- comprehension on NonEmpty + where + same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool + (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 + +-- TODO Make subGroup1 using a NonEmptyMap +subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems + -> m -- Map.empty + -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup + -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert + -> [(a, EquationInfo)] -> [NonEmpty EquationInfo] +-- Input is a particular group. The result sub-groups the +-- equations by with particular constructor, literal etc they match. +-- Each sub-list in the result has the same PatGroup +-- See Note [Take care with pattern order] +-- Parameterized by map operations to allow different implementations +-- and constraints, eg. types without Ord instance. +subGroup elems empty lookup insert group + = fmap NEL.reverse $ elems $ foldl' accumulate empty group + where + accumulate pg_map (pg, eqn) + = case lookup pg pg_map of + Just eqns -> insert pg (NEL.cons eqn eqns) pg_map + Nothing -> insert pg [eqn] pg_map + -- pg_map :: Map a [EquationInfo] + -- Equations seen so far in reverse order of appearance + +subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] +subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert + +subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] +subGroupUniq = + subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v) + +{- Note [Pattern synonym groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f (P a) = e1 + f (P b) = e2 + ... +where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the +same group? We can if P is a constructor, but /not/ if P is a pattern synonym. +Consider (#11224) + -- readMaybe :: Read a => String -> Maybe a + pattern PRead :: Read a => () => a -> String + pattern PRead a <- (readMaybe -> Just a) + + f (PRead (x::Int)) = e1 + f (PRead (y::Bool)) = e2 +This is all fine: we match the string by trying to read an Int; if that +fails we try to read a Bool. But clearly we can't combine the two into a single +match. + +Conclusion: we can combine when we invoke PRead /at the same type/. Hence +in PgSyn we record the instantiating types, and use them in sameGroup. + +Note [Take care with pattern order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the subGroup function we must be very careful about pattern re-ordering, +Consider the patterns [ (True, Nothing), (False, x), (True, y) ] +Then in bringing together the patterns for True, we must not +swap the Nothing and y! +-} + +sameGroup :: PatGroup -> PatGroup -> Bool +-- Same group means that a single case expression +-- or test will suffice to match both, *and* the order +-- of testing within the group is insignificant. +sameGroup PgAny PgAny = True +sameGroup PgBang PgBang = True +sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2 + -- eqTypes: See Note [Pattern synonym groups] +sameGroup (PgLit _) (PgLit _) = True -- One case expression +sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant +sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] +sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 + -- CoPats are in the same goup only if the type of the + -- enclosed pattern is the same. The patterns outside the CoPat + -- always have the same type, so this boils down to saying that + -- the two coercions are identical. +sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) + -- ViewPats are in the same group iff the expressions + -- are "equal"---conservatively, we use syntactic equality +sameGroup _ _ = False + +-- An approximation of syntactic equality used for determining when view +-- exprs are in the same group. +-- This function can always safely return false; +-- but doing so will result in the application of the view function being repeated. +-- +-- Currently: compare applications of literals and variables +-- and anything else that we can do without involving other +-- HsSyn types in the recursion +-- +-- NB we can't assume that the two view expressions have the same type. Consider +-- f (e1 -> True) = ... +-- f (e2 -> "hi") = ... +viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool +viewLExprEq (e1,_) (e2,_) = lexp e1 e2 + where + lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool + lexp e e' = exp (unLoc e) (unLoc e') + + --------- + exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool + -- real comparison is on HsExpr's + -- strip parens + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' + -- because the expressions do not necessarily have the same type, + -- we have to compare the wrappers + exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) = + wrap h h' && exp e e' + exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) = + exp b b' + exp (HsVar _ i) (HsVar _ i') = i == i' + exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' + -- the instance for IPName derives using the id, so this works if the + -- above does + exp (HsIPVar _ i) (HsIPVar _ i') = i == i' + exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' + exp (HsOverLit _ l) (HsOverLit _ l') = + -- Overloaded lits are equal if they have the same type + -- and the data is the same. + -- this is coarser than comparing the SyntaxExpr's in l and l', + -- which resolve the overloading (e.g., fromInteger 1), + -- because these expressions get written as a bunch of different variables + -- (presumably to improve sharing) + eqType (overLitType l) (overLitType l') && l == l' + exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' + -- the fixities have been straightened out by now, so it's safe + -- to ignore them? + exp (OpApp _ l o ri) (OpApp _ l' o' ri') = + lexp l l' && lexp o o' && lexp ri ri' + exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' + exp (SectionL _ e1 e2) (SectionL _ e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (SectionR _ e1 e2) (SectionR _ e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = + eq_list tup_arg es1 es2 + exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' + exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + + -- Enhancement: could implement equality for more expressions + -- if it seems useful + -- But no need for HsLit, ExplicitList, ExplicitTuple, + -- because they cannot be functions + exp _ _ = False + + --------- + syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool + syn_exp (SyntaxExprTc { syn_expr = expr1 + , syn_arg_wraps = arg_wraps1 + , syn_res_wrap = res_wrap1 }) + (SyntaxExprTc { syn_expr = expr2 + , syn_arg_wraps = arg_wraps2 + , syn_res_wrap = res_wrap2 }) + = exp expr1 expr2 && + and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && + wrap res_wrap1 res_wrap2 + syn_exp NoSyntaxExprTc NoSyntaxExprTc = True + syn_exp _ _ = False + + --------- + tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing (Scaled _ t1))) (L _ (Missing (Scaled _ t2))) = eqType t1 t2 + tup_arg _ _ = False + + --------- + wrap :: HsWrapper -> HsWrapper -> Bool + -- Conservative, in that it demands that wrappers be + -- syntactically identical and doesn't look under binders + -- + -- Coarser notions of equality are possible + -- (e.g., reassociating compositions, + -- equating different ways of writing a coercion) + wrap WpHole WpHole = True + wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' + wrap (WpCast co) (WpCast co') = co `eqCoercion` co' + wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 + wrap (WpTyApp t) (WpTyApp t') = eqType t t' + -- Enhancement: could implement equality for more wrappers + -- if it seems useful (lams and lets) + wrap _ _ = False + + --------- + ev_term :: EvTerm -> EvTerm -> Bool + ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b + ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b + ev_term _ _ = False + + --------- + eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool + eq_list _ [] [] = True + eq_list _ [] (_:_) = False + eq_list _ (_:_) [] = False + eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys + +patGroup :: Platform -> Pat GhcTc -> PatGroup +patGroup _ (ConPat { pat_con = L _ con + , pat_con_ext = ConPatTc { cpt_arg_tys = tys } + }) + | RealDataCon dcon <- con = PgCon dcon + | PatSynCon psyn <- con = PgSyn psyn tys +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = + case (oval, isJust mb_neg) of + (HsIntegral i, False) -> PgN (fromInteger (il_value i)) + (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) + (HsFractional r, False) -> PgN (fl_value r) + (HsFractional r, True ) -> PgN (-fl_value r) + (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) + PgOverS s +patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = + case oval of + HsIntegral i -> PgNpK (il_value i) + _ -> pprPanic "patGroup NPlusKPat" (ppr oval) +patGroup _ (XPat (CoPat _ p _)) = PgCo (hsPatType p) + -- Type of innelexp pattern +patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList +patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit) +patGroup _ pat = pprPanic "patGroup" (ppr pat) + +{- +Note [Grouping overloaded literal patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +WATCH OUT! Consider + + f (n+1) = ... + f (n+2) = ... + f (n+1) = ... + +We can't group the first and third together, because the second may match +the same thing as the first. Same goes for *overloaded* literal patterns + f 1 True = ... + f 2 False = ... + f 1 False = ... +If the first arg matches '1' but the second does not match 'True', we +cannot jump to the third equation! Because the same argument might +match '2'! +Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. +-} diff --git a/GHC/HsToCore/Match.hs-boot b/GHC/HsToCore/Match.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match.hs-boot @@ -0,0 +1,36 @@ +module GHC.HsToCore.Match where + +import GHC.Prelude +import GHC.Types.Var ( Id ) +import GHC.Tc.Utils.TcType ( Type ) +import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) +import GHC.Core ( CoreExpr ) +import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) + +match :: [Id] + -> Type + -> [EquationInfo] + -> DsM (MatchResult CoreExpr) + +matchWrapper + :: HsMatchContext GhcRn + -> Maybe (LHsExpr GhcTc) + -> MatchGroup GhcTc (LHsExpr GhcTc) + -> DsM ([Id], CoreExpr) + +matchSimply + :: CoreExpr + -> HsMatchContext GhcRn + -> LPat GhcTc + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr + +matchSinglePatVar + :: Id + -> HsMatchContext GhcRn + -> LPat GhcTc + -> Type + -> MatchResult CoreExpr + -> DsM (MatchResult CoreExpr) diff --git a/GHC/HsToCore/Match/Constructor.hs b/GHC/HsToCore/Match/Constructor.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match/Constructor.hs @@ -0,0 +1,297 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching constructors +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Match ( match ) + +import GHC.Hs +import GHC.HsToCore.Binds +import GHC.Core.ConLike +import GHC.Types.Basic ( Origin(..) ) +import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils +import GHC.Core ( CoreExpr ) +import GHC.Core.Make ( mkCoreLets ) +import GHC.Utils.Misc +import GHC.Types.Id +import GHC.Types.Name.Env +import GHC.Types.FieldLabel ( flSelector ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import Control.Monad(liftM) +import Data.List (groupBy) +import Data.List.NonEmpty (NonEmpty(..)) + +{- +We are confronted with the first column of patterns in a set of +equations, all beginning with constructors from one ``family'' (e.g., +@[]@ and @:@ make up the @List@ ``family''). We want to generate the +alternatives for a @Case@ expression. There are several choices: +\begin{enumerate} +\item +Generate an alternative for every constructor in the family, whether +they are used in this set of equations or not; this is what the Wadler +chapter does. +\begin{description} +\item[Advantages:] +(a)~Simple. (b)~It may also be that large sparsely-used constructor +families are mainly handled by the code for literals. +\item[Disadvantages:] +(a)~Not practical for large sparsely-used constructor families, e.g., +the ASCII character set. (b)~Have to look up a list of what +constructors make up the whole family. +\end{description} + +\item +Generate an alternative for each constructor used, then add a default +alternative in case some constructors in the family weren't used. +\begin{description} +\item[Advantages:] +(a)~Alternatives aren't generated for unused constructors. (b)~The +STG is quite happy with defaults. (c)~No lookup in an environment needed. +\item[Disadvantages:] +(a)~A spurious default alternative may be generated. +\end{description} + +\item +``Do it right:'' generate an alternative for each constructor used, +and add a default alternative if all constructors in the family +weren't used. +\begin{description} +\item[Advantages:] +(a)~You will get cases with only one alternative (and no default), +which should be amenable to optimisation. Tuples are a common example. +\item[Disadvantages:] +(b)~Have to look up constructor families in TDE (as above). +\end{description} +\end{enumerate} + +We are implementing the ``do-it-right'' option for now. The arguments +to @matchConFamily@ are the same as to @match@; the extra @Int@ +returned is the number of constructors in the family. + +The function @matchConFamily@ is concerned with this +have-we-used-all-the-constructors? question; the local function +@match_cons_used@ does all the real work. +-} + +matchConFamily :: NonEmpty Id + -> Type + -> NonEmpty (NonEmpty EquationInfo) + -> DsM (MatchResult CoreExpr) +-- Each group of eqns is for a single constructor +matchConFamily (var :| vars) ty groups + = do let mult = idMult var + -- Each variable in the argument list correspond to one column in the + -- pattern matching equations. Its multiplicity is the context + -- multiplicity of the pattern. We extract that multiplicity, so that + -- 'matchOneconLike' knows the context multiplicity, in case it needs + -- to come up with new variables. + alts <- mapM (fmap toRealAlt . matchOneConLike vars ty mult) groups + return (mkCoAlgCaseMatchResult var ty alts) + where + toRealAlt alt = case alt_pat alt of + RealDataCon dcon -> alt{ alt_pat = dcon } + _ -> panic "matchConFamily: not RealDataCon" + +matchPatSyn :: NonEmpty Id + -> Type + -> NonEmpty EquationInfo + -> DsM (MatchResult CoreExpr) +matchPatSyn (var :| vars) ty eqns + = do let mult = idMult var + alt <- fmap toSynAlt $ matchOneConLike vars ty mult eqns + return (mkCoSynCaseMatchResult var ty alt) + where + toSynAlt alt = case alt_pat alt of + PatSynCon psyn -> alt{ alt_pat = psyn } + _ -> panic "matchPatSyn: not PatSynCon" + +type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) + +matchOneConLike :: [Id] + -> Type + -> Mult + -> NonEmpty EquationInfo + -> DsM (CaseAlt ConLike) +matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor + = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018). + ASSERT( tvs1 `equalLength` ex_tvs ) + arg_tys ++ mkTyVarTys tvs1 + + val_arg_tys = conLikeInstOrigArgTys con1 inst_tys + -- dataConInstOrigArgTys takes the univ and existential tyvars + -- and returns the types of the *value* args, which is what we want + + match_group :: [Id] + -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr) + -- All members of the group have compatible ConArgPats + match_group arg_vars arg_eqn_prs + = ASSERT( notNull arg_eqn_prs ) + do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) + ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs + ; match_result <- match (group_arg_vars ++ vars) ty eqns' + ; return $ foldr1 (.) wraps <$> match_result + } + + shift (_, eqn@(EqnInfo + { eqn_pats = ConPat + { pat_args = args + , pat_con_ext = ConPatTc + { cpt_tvs = tvs + , cpt_dicts = ds + , cpt_binds = bind + } + } : pats + })) + = do ds_bind <- dsTcEvBinds bind + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , eqn { eqn_orig = Generated + , eqn_pats = conArgPats val_arg_tys args ++ pats } + ) + shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) + ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys + -- The 'val_arg_tys' are taken from the data type definition, they + -- do not take into account the context multiplicity, therefore we + -- need to scale them back to get the correct context multiplicity + -- to desugar the sub-pattern in each field. We need to know these + -- multiplicity because of the invariant that, in Core, binders in a + -- constructor pattern must be scaled by the multiplicity of the + -- case. See Note [Case expression invariants]. + ; arg_vars <- selectConMatchVars scaled_arg_tys args1 + -- Use the first equation as a source of + -- suggestions for the new variables + + -- Divide into sub-groups; see Note [Record patterns] + ; let groups :: [[(ConArgPats, EquationInfo)]] + groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn) + | eqn <- eqn1:eqns ] + + ; match_results <- mapM (match_group arg_vars) groups + + ; return $ MkCaseAlt{ alt_pat = con1, + alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, + alt_wrapper = wrapper1, + alt_result = foldr1 combineMatchResults match_results } } + where + ConPat { pat_con = L _ con1 + , pat_args = args1 + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + , cpt_wrap = wrapper1 + , cpt_tvs = tvs1 + , cpt_dicts = dicts1 + } + } = firstPat eqn1 + fields1 = map flSelector (conLikeFieldLabels con1) + + ex_tvs = conLikeExTyCoVars con1 + + -- Choose the right arg_vars in the right order for this group + -- Note [Record patterns] + select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id] + select_arg_vars arg_vars ((arg_pats, _) : _) + | RecCon flds <- arg_pats + , let rpats = rec_flds flds + , not (null rpats) -- Treated specially; cf conArgPats + = ASSERT2( fields1 `equalLength` arg_vars, + ppr con1 $$ ppr fields1 $$ ppr arg_vars ) + map lookup_fld rpats + | otherwise + = arg_vars + where + fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars + lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env + (idName (unLoc (hsRecFieldId rpat))) + select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" + +----------------- +compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool +-- Two constructors have compatible argument patterns if the number +-- and order of sub-matches is the same in both cases +compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2 +compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) +compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) +compatible_pats _ _ = True -- Prefix or infix con + +same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) + -> Bool +same_fields flds1 flds2 + = all2 (\(L _ f1) (L _ f2) + -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) + (rec_flds flds1) (rec_flds flds2) + + +----------------- +selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] +selectConMatchVars arg_tys con = case con of + (RecCon {}) -> newSysLocalsDsNoLP arg_tys + (PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps) + (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2]) + where + zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) + +conArgPats :: [Scaled Type]-- Instantiated argument types + -- Used only to fill in the types of WildPats, which + -- are probably never looked at anyway + -> ConArgPats + -> [Pat GhcTc] +conArgPats _arg_tys (PrefixCon ps) = map unLoc ps +conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] +conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) + | null rpats = map WildPat (map scaledThing arg_tys) + -- Important special case for C {}, which can be used for a + -- datacon that isn't declared to have fields at all + | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats + +{- +Note [Record patterns] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = T { x,y,z :: Bool } + + f (T { y=True, x=False }) = ... + +We must match the patterns IN THE ORDER GIVEN, thus for the first +one we match y=True before x=False. See #246; or imagine +matching against (T { y=False, x=undefined }): should fail without +touching the undefined. + +Now consider: + + f (T { y=True, x=False }) = ... + f (T { x=True, y= False}) = ... + +In the first we must test y first; in the second we must test x +first. So we must divide even the equations for a single constructor +T into sub-groups, based on whether they match the same field in the +same order. That's what the (groupBy compatible_pats) grouping. + +All non-record patterns are "compatible" in this sense, because the +positional patterns (T a b) and (a `T` b) all match the arguments +in order. Also T {} is special because it's equivalent to (T _ _). +Hence the (null rpats) checks here and there. + +-} diff --git a/GHC/HsToCore/Match/Literal.hs b/GHC/HsToCore/Match/Literal.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Match/Literal.hs @@ -0,0 +1,580 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching literal patterns +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Match.Literal + ( dsLit, dsOverLit, hsLitKey + , tidyLitPat, tidyNPat + , matchLiterals, matchNPlusKPats, matchNPats + , warnAboutIdentities + , warnAboutOverflowedOverLit, warnAboutOverflowedLit + , warnAboutEmptyEnumerations + ) +where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import {-# SOURCE #-} GHC.HsToCore.Match ( match ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr ) + +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils + +import GHC.Hs + +import GHC.Types.Id +import GHC.Core +import GHC.Core.Make +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Tc.Utils.Zonk ( shortCutLit ) +import GHC.Tc.Utils.TcType +import GHC.Types.Name +import GHC.Core.Type +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Types.Literal +import GHC.Types.SrcLoc +import Data.Ratio +import GHC.Utils.Outputable as Outputable +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt +import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) + +import Control.Monad +import Data.Int +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import Data.Word +import Data.Proxy + +{- +************************************************************************ +* * + Desugaring literals + [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it, + and it's nice to avoid a loop] +* * +************************************************************************ + +We give int/float literals type @Integer@ and @Rational@, respectively. +The typechecker will (presumably) have put \tr{from{Integer,Rational}s} +around them. + +ToDo: put in range checks for when converting ``@i@'' +(or should that be in the typechecker?) + +For numeric literals, we try to detect there use at a standard type +(@Int@, @Float@, etc.) are directly put in the right constructor. +[NB: down with the @App@ conversion.] + +See also below where we look for @DictApps@ for \tr{plusInt}, etc. +-} + +dsLit :: HsLit GhcRn -> DsM CoreExpr +dsLit l = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case l of + HsStringPrim _ s -> return (Lit (LitString s)) + HsCharPrim _ c -> return (Lit (LitChar c)) + HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i)) + HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) + HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap platform i)) + HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap platform w)) + HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) + HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) + HsChar _ c -> return (mkCharExpr c) + HsString _ str -> mkStringExprFS str + HsInteger _ i _ -> return (mkIntegerExpr i) + HsInt _ i -> return (mkIntExpr platform (il_value i)) + HsRat _ (FL _ _ val) ty -> do + return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) + where + num = mkIntegerExpr (numerator val) + denom = mkIntegerExpr (denominator val) + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) + x -> pprPanic "dsLit" (ppr x) + +dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr +-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains +-- (an expression for) the literal value itself. +dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty + , ol_witness = witness }) = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case shortCutLit platform val ty of + Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] + _ -> dsExpr witness +{- +Note [Literal short cut] +~~~~~~~~~~~~~~~~~~~~~~~~ +The type checker tries to do this short-cutting as early as possible, but +because of unification etc, more information is available to the desugarer. +And where it's possible to generate the correct literal right away, it's +much better to do so. + + +************************************************************************ +* * + Warnings about overflowed literals +* * +************************************************************************ + +Warn about functions like toInteger, fromIntegral, that convert +between one type and another when the to- and from- types are the +same. Then it's probably (albeit not definitely) the identity +-} + +warnAboutIdentities :: DynFlags -> Id -> Type -> DsM () +warnAboutIdentities dflags conv_fn type_of_conv + | wopt Opt_WarnIdentities dflags + , idName conv_fn `elem` conversionNames + , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv + , arg_ty `eqType` res_ty -- So we are converting ty -> ty + = warnDs (Reason Opt_WarnIdentities) + (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv + , nest 2 $ text "can probably be omitted" + ]) +warnAboutIdentities _ _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- because they are generated by literals + + +-- | Emit warnings on overloaded integral literals which overflow the bounds +-- implied by their type. +warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () +warnAboutOverflowedOverLit hsOverLit = do + dflags <- getDynFlags + fam_envs <- dsGetFamInstEnvs + warnAboutOverflowedLiterals dflags $ + getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs + +-- | Emit warnings on integral literals which overflow the bounds implied by +-- their type. +warnAboutOverflowedLit :: HsLit GhcTc -> DsM () +warnAboutOverflowedLit hsLit = do + dflags <- getDynFlags + warnAboutOverflowedLiterals dflags $ + getSimpleIntegralLit hsLit >>= getTyconName + +-- | Emit warnings on integral literals which overflow the bounds implied by +-- their type. +warnAboutOverflowedLiterals + :: DynFlags + -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon + -> DsM () +warnAboutOverflowedLiterals dflags lit + | wopt Opt_WarnOverflowedLiterals dflags + , Just (i, tc) <- lit + = if tc == intTyConName then check i tc (Proxy :: Proxy Int) + + -- These only show up via the 'HsOverLit' route + else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) + else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) + else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) + else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) + else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) + else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) + else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) + else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) + else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) + else if tc == naturalTyConName then checkPositive i tc + + -- These only show up via the 'HsLit' route + else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int) + else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8) + else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32) + else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64) + else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word) + else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8) + else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32) + else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64) + + else return () + + | otherwise = return () + where + + checkPositive :: Integer -> Name -> DsM () + checkPositive i tc + = when (i < 0) $ do + warnDs (Reason Opt_WarnOverflowedLiterals) + (vcat [ text "Literal" <+> integer i + <+> text "is negative but" <+> ppr tc + <+> ptext (sLit "only supports positive numbers") + ]) + + check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () + check i tc _proxy + = when (i < minB || i > maxB) $ do + warnDs (Reason Opt_WarnOverflowedLiterals) + (vcat [ text "Literal" <+> integer i + <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") + <+> integer minB <> text ".." <> integer maxB + , sug ]) + where + minB = toInteger (minBound :: a) + maxB = toInteger (maxBound :: a) + sug | minB == -i -- Note [Suggest NegativeLiterals] + , i > 0 + , not (xopt LangExt.NegativeLiterals dflags) + = text "If you are trying to write a large negative literal, use NegativeLiterals" + | otherwise = Outputable.empty + +{- +Note [Suggest NegativeLiterals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you write + x :: Int8 + x = -128 +it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. +We get an erroneous suggestion for + x = 128 +but perhaps that does not matter too much. +-} + +warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc + -> Maybe (LHsExpr GhcTc) + -> LHsExpr GhcTc -> DsM () +-- ^ Warns about @[2,3 .. 1]@ or @['b' .. 'a']@ which return the empty list. +-- For numeric literals, only works for integral types, not floating point. +warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr + | not $ wopt Opt_WarnEmptyEnumerations dflags + = return () + -- Numeric Literals + | Just from_ty@(from,_) <- getLHsIntegralLit fromExpr + , Just (_, tc) <- getNormalisedTyconName fam_envs from_ty + , Just mThn <- traverse getLHsIntegralLit mThnExpr + , Just (to,_) <- getLHsIntegralLit toExpr + , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () + check _proxy + = when (null enumeration) raiseWarning + where + enumeration :: [a] + enumeration = case mThn of + Nothing -> [fromInteger from .. fromInteger to] + Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] + + = if tc == intTyConName then check (Proxy :: Proxy Int) + else if tc == int8TyConName then check (Proxy :: Proxy Int8) + else if tc == int16TyConName then check (Proxy :: Proxy Int16) + else if tc == int32TyConName then check (Proxy :: Proxy Int32) + else if tc == int64TyConName then check (Proxy :: Proxy Int64) + else if tc == wordTyConName then check (Proxy :: Proxy Word) + else if tc == word8TyConName then check (Proxy :: Proxy Word8) + else if tc == word16TyConName then check (Proxy :: Proxy Word16) + else if tc == word32TyConName then check (Proxy :: Proxy Word32) + else if tc == word64TyConName then check (Proxy :: Proxy Word64) + else if tc == integerTyConName then check (Proxy :: Proxy Integer) + else if tc == naturalTyConName then check (Proxy :: Proxy Integer) + -- We use 'Integer' because otherwise a negative 'Natural' literal + -- could cause a compile time crash (instead of a runtime one). + -- See the T10930b test case for an example of where this matters. + else return () + + -- Char literals (#18402) + | Just fromChar <- getLHsCharLit fromExpr + , Just mThnChar <- traverse getLHsCharLit mThnExpr + , Just toChar <- getLHsCharLit toExpr + , let enumeration = case mThnChar of + Nothing -> [fromChar .. toChar] + Just thnChar -> [fromChar, thnChar .. toChar] + = when (null enumeration) raiseWarning + + | otherwise = return () + where + raiseWarning = warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") + +getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) +-- ^ See if the expression is an 'Integral' literal. +-- Remember to look through automatically-added tick-boxes! (#8384) +getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit +getLHsIntegralLit _ = Nothing + +-- | If 'Integral', extract the value and type of the overloaded literal. +-- See Note [Literals and the OverloadedLists extension] +getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) + = Just (il_value i, ty) +getIntegralLit _ = Nothing + +-- | If 'Integral', extract the value and type of the non-overloaded literal. +getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type) +getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy) +getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy) +getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy) +getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy) +getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) +getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty) +getSimpleIntegralLit _ = Nothing + +-- | Extract the Char if the expression is a Char literal. +getLHsCharLit :: LHsExpr GhcTc -> Maybe Char +getLHsCharLit (L _ (HsPar _ e)) = getLHsCharLit e +getLHsCharLit (L _ (HsTick _ _ e)) = getLHsCharLit e +getLHsCharLit (L _ (HsBinTick _ _ _ e)) = getLHsCharLit e +getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c +getLHsCharLit _ = Nothing + +-- | Convert a pair (Integer, Type) to (Integer, Name) after eventually +-- normalising the type +getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name) +getNormalisedTyconName fam_envs (i,ty) + | Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty) + = Just (i, tyConName tc) + | otherwise = Nothing + where + normaliseNominal :: FamInstEnvs -> Type -> Type + normaliseNominal fam_envs ty = snd $ normaliseType fam_envs Nominal ty + +-- | Convert a pair (Integer, Type) to (Integer, Name) without normalising +-- the type +getTyconName :: (Integer, Type) -> Maybe (Integer, Name) +getTyconName (i,ty) + | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc) + | otherwise = Nothing + +{- +Note [Literals and the OverloadedLists extension] +~~~~ +Consider the Literal `[256] :: [Data.Word.Word8]` + +When the `OverloadedLists` extension is not active, then the `ol_ext` field +in the `OverLitTc` record that is passed to the function `getIntegralLit` +contains the type `Word8`. This is a simple type, and we can use its +type constructor immediately for the `warnAboutOverflowedLiterals` function. + +When the `OverloadedLists` extension is active, then the `ol_ext` field +contains the type family `Item [Word8]`. The function `nomaliseType` is used +to convert it to the needed type `Word8`. +-} + +{- +************************************************************************ +* * + Tidying lit pats +* * +************************************************************************ +-} + +tidyLitPat :: HsLit GhcTc -> Pat GhcTc +-- Result has only the following HsLits: +-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim +-- HsDoublePrim, HsStringPrim, HsString +-- * HsInteger, HsRat, HsInt can't show up in LitPats +-- * We get rid of HsChar right here +tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) +tidyLitPat (HsString src s) + | lengthFS s <= 1 -- Short string literals only + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon + [mkCharLitPat src c, pat] [charTy]) + (mkNilPat charTy) (unpackFS s) + -- The stringTy is the type of the whole pattern, not + -- the type to instantiate (:) or [] with! +tidyLitPat lit = LitPat noExtField lit + +---------------- +tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc + -> Type + -> Pat GhcTc +tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty + -- False: Take short cuts only if the literal is not using rebindable syntax + -- + -- Once that is settled, look for cases where the type of the + -- entire overloaded literal matches the type of the underlying literal, + -- and in that case take the short cut + -- NB: Watch out for weird cases like #3382 + -- f :: Int -> Int + -- f "blah" = 4 + -- which might be ok if we have 'instance IsString Int' + -- + | not type_change, isIntTy ty, Just int_lit <- mb_int_lit + = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) + | not type_change, isWordTy ty, Just int_lit <- mb_int_lit + = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) + | not type_change, isStringTy ty, Just str_lit <- mb_str_lit + = tidyLitPat (HsString NoSourceText str_lit) + -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 + -- If we do convert to the constructor form, we'll generate a case + -- expression on a Float# or Double# and that's not allowed in Core; see + -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold + where + -- Sometimes (like in test case + -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include + -- type-changing wrappers (for example, from Id Int to Int, for the identity + -- type family Id). In these cases, we can't do the short-cut. + type_change = not (outer_ty `eqType` ty) + + mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc + mk_con_pat con lit + = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] []) + + mb_int_lit :: Maybe Integer + mb_int_lit = case (mb_neg, val) of + (Nothing, HsIntegral i) -> Just (il_value i) + (Just _, HsIntegral i) -> Just (-(il_value i)) + _ -> Nothing + + mb_str_lit :: Maybe FastString + mb_str_lit = case (mb_neg, val) of + (Nothing, HsIsString _ s) -> Just s + _ -> Nothing + +tidyNPat over_lit mb_neg eq outer_ty + = NPat outer_ty (noLoc over_lit) mb_neg eq + +{- +************************************************************************ +* * + Pattern matching on LitPat +* * +************************************************************************ +-} + +matchLiterals :: NonEmpty Id + -> Type -- ^ Type of the whole case expression + -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits + -> DsM (MatchResult CoreExpr) + +matchLiterals (var :| vars) ty sub_groups + = do { -- Deal with each group + ; alts <- mapM match_group sub_groups + + -- Combine results. For everything except String + -- we can use a case expression; for String we need + -- a chain of if-then-else + ; if isStringTy (idType var) then + do { eq_str <- dsLookupGlobalId eqStringName + ; mrs <- mapM (wrap_str_guard eq_str) alts + ; return (foldr1 combineMatchResults mrs) } + else + return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts) + } + where + match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr) + match_group eqns@(firstEqn :| _) + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; let LitPat _ hs_lit = firstPat firstEqn + ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) + ; return (hsLitKey platform hs_lit, match_result) } + + wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr) + -- Equality check for string literals + wrap_str_guard eq_str (LitString s, mr) + = do { -- We now have to convert back to FastString. Perhaps there + -- should be separate LitBytes and LitString constructors? + let s' = mkFastStringByteString s + ; lit <- mkStringExprFS s' + ; let pred = mkApps (Var eq_str) [Var var, lit] + ; return (mkGuardedMatchResult pred mr) } + wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) + + +--------------------------- +hsLitKey :: Platform -> HsLit GhcTc -> Literal +-- Get the Core literal corresponding to a HsLit. +-- It only works for primitive types and strings; +-- others have been removed by tidy +-- For HsString, it produces a LitString, which really represents an _unboxed_ +-- string literal; and we deal with it in matchLiterals above. Otherwise, it +-- produces a primitive Literal of type matching the original HsLit. +-- In the case of the fixed-width numeric types, we need to wrap here +-- because Literal has an invariant that the literal is in range, while +-- HsLit does not. +hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i +hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w +hsLitKey platform (HsInt64Prim _ i) = mkLitInt64Wrap platform i +hsLitKey platform (HsWord64Prim _ w) = mkLitWord64Wrap platform w +hsLitKey _ (HsCharPrim _ c) = mkLitChar c +hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) +hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) +hsLitKey _ (HsString _ s) = LitString (bytesFS s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) + +{- +************************************************************************ +* * + Pattern matching on NPat +* * +************************************************************************ +-} + +matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal + = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 + ; lit_expr <- dsOverLit lit + ; neg_lit <- case mb_neg of + Nothing -> return lit_expr + Just neg -> dsSyntaxExpr neg [lit_expr] + ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] + ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) + ; return (mkGuardedMatchResult pred_expr match_result) } + +{- +************************************************************************ +* * + Pattern matching on n+k patterns +* * +************************************************************************ + +For an n+k pattern, we use the various magic expressions we've been given. +We generate: +\begin{verbatim} + if ge var lit then + let n = sub var lit + in + else + +\end{verbatim} +-} + +matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +-- All NPlusKPats, for the *same* literal k +matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) + = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus + = firstPat eqn1 + ; lit1_expr <- dsOverLit lit1 + ; lit2_expr <- dsOverLit lit2 + ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] + ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] + ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) + ; match_result <- match vars ty eqns' + ; return (mkGuardedMatchResult pred_expr $ + mkCoLetMatchResult (NonRec n1 minusk_expr) $ + fmap (foldr1 (.) wraps) $ + match_result) } + where + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) + = (wrapBind n n1, eqn { eqn_pats = pats }) + -- The wrapBind is a no-op for the first equation + shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/GHC/HsToCore/Monad.hs b/GHC/HsToCore/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Monad.hs @@ -0,0 +1,618 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Monadery used in desugaring +-} + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan + +module GHC.HsToCore.Monad ( + DsM, mapM, mapAndUnzipM, + initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs, + foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, + Applicative(..),(<$>), + + duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, + newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, + newFailLocalDs, newPredVarDs, + getSrcSpanDs, putSrcSpanDs, + mkPrintUnqualifiedDs, + newUnique, + UniqSupply, newUniqueSupply, + getGhcModeDs, dsGetFamInstEnvs, + dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, + dsLookupDataCon, dsLookupConLike, + + DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, + + -- Getting and setting pattern match oracle states + getPmDeltas, updPmDeltas, + + -- Get COMPLETE sets of a TyCon + dsGetCompleteMatches, + + -- Warnings and errors + DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, + failWithDs, failDs, discardWarningsDs, + askNoErrsDs, + + -- Data types + DsMatchContext(..), + EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, + + -- Levity polymorphism + dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, + + -- Trace injection + pprRuntimeTrace + ) where + +import GHC.Prelude + +import GHC.Tc.Utils.Monad +import GHC.Core.FamInstEnv +import GHC.Core +import GHC.Core.Make ( unitExpr ) +import GHC.Core.Utils ( exprType, isExprLevPoly ) +import GHC.Hs +import GHC.IfaceToCore +import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr ) +import GHC.Builtin.Names +import GHC.Types.Name.Reader +import GHC.Driver.Types +import GHC.Data.Bag +import GHC.Types.Basic ( Origin ) +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.HsToCore.PmCheck.Types +import GHC.Types.Id +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Types.Unique.Supply +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Data.FastString +import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly ) +import GHC.Types.Literal ( mkLitString ) +import GHC.Types.CostCentre.State + +import Data.IORef + +{- +************************************************************************ +* * + Data types for the desugarer +* * +************************************************************************ +-} + +data DsMatchContext + = DsMatchContext (HsMatchContext GhcRn) SrcSpan + deriving () + +instance Outputable DsMatchContext where + ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match + +data EquationInfo + = EqnInfo { eqn_pats :: [Pat GhcTc] + -- ^ The patterns for an equation + -- + -- NB: We have /already/ applied 'decideBangHood' to + -- these patterns. See Note [decideBangHood] in "GHC.HsToCore.Utils" + + , eqn_orig :: Origin + -- ^ Was this equation present in the user source? + -- + -- This helps us avoid warnings on patterns that GHC elaborated. + -- + -- For instance, the pattern @-1 :: Word@ gets desugared into + -- @W# -1## :: Word@, but we shouldn't warn about an overflowed + -- literal for /both/ of these cases. + + , eqn_rhs :: MatchResult CoreExpr + -- ^ What to do after match + } + +instance Outputable EquationInfo where + ppr (EqnInfo pats _ _) = ppr pats + +type DsWrapper = CoreExpr -> CoreExpr +idDsWrapper :: DsWrapper +idDsWrapper e = e + +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr +-- \fail. wrap (case vs of { pats -> rhs fail }) +-- where vs are not bound by wrap + +-- | This is a value of type a with potentially a CoreExpr-shaped hole in it. +-- This is used to deal with cases where we are potentially handling pattern +-- match failure, and want to later specify how failure is handled. +data MatchResult a + -- | We represent the case where there is no hole without a function from + -- 'CoreExpr', like this, because sometimes we have nothing to put in the + -- hole and so want to be sure there is in fact no hole. + = MR_Infallible (DsM a) + | MR_Fallible (CoreExpr -> DsM a) + deriving (Functor) + +-- | Product is an "or" on falliblity---the combined match result is infallible +-- only if the left and right argument match results both were. +-- +-- This is useful for combining a bunch of alternatives together and then +-- getting the overall falliblity of the entire group. See 'mkDataConCase' for +-- an example. +instance Applicative MatchResult where + pure v = MR_Infallible (pure v) + MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x) + f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x + +-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether +-- the MatchResult CoreExpr was failable or not. +runMatchResult :: CoreExpr -> MatchResult a -> DsM a +runMatchResult fail = \case + MR_Infallible body -> body + MR_Fallible body_fn -> body_fn fail + +{- +************************************************************************ +* * + Monad functions +* * +************************************************************************ +-} + +-- Compatibility functions +fixDs :: (a -> DsM a) -> DsM a +fixDs = fixM + +type DsWarning = (SrcSpan, SDoc) + -- Not quite the same as a WarnMsg, we have an SDoc here + -- and we'll do the print_unqual stuff later on to turn it + -- into a Doc. + +-- | Run a 'DsM' action inside the 'TcM' monad. +initDsTc :: DsM a -> TcM a +initDsTc thing_inside + = do { tcg_env <- getGblEnv + ; msg_var <- getErrsVar + ; hsc_env <- getTopEnv + ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + ; setEnvs envs thing_inside + } + +-- | Run a 'DsM' action inside the 'IO' monad. +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a) +initDs hsc_env tcg_env thing_inside + = do { msg_var <- newIORef emptyMessages + ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + ; runDs hsc_env envs thing_inside + } + +-- | Build a set of desugarer environments derived from a 'TcGblEnv'. +mkDsEnvsFromTcGbl :: MonadIO m + => HscEnv -> IORef Messages -> TcGblEnv + -> m (DsGblEnv, DsLclEnv) +mkDsEnvsFromTcGbl hsc_env msg_var tcg_env + = do { cc_st_var <- liftIO $ newIORef newCostCentreState + ; let dflags = hsc_dflags hsc_env + this_mod = tcg_mod tcg_env + type_env = tcg_type_env tcg_env + rdr_env = tcg_rdr_env tcg_env + fam_inst_env = tcg_fam_inst_env tcg_env + complete_matches = hptCompleteSigs hsc_env + ++ tcg_complete_matches tcg_env + ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env + msg_var cc_st_var complete_matches + } + +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) +runDs hsc_env (ds_gbl, ds_lcl) thing_inside + = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl + (tryM thing_inside) + ; msgs <- readIORef (ds_msgs ds_gbl) + ; let final_res + | errorsFound dflags msgs = Nothing + | Right r <- res = Just r + | otherwise = panic "initDs" + ; return (msgs, final_res) + } + where dflags = hsc_dflags hsc_env + +-- | Run a 'DsM' action in the context of an existing 'ModGuts' +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) +initDsWithModGuts hsc_env guts thing_inside + = do { cc_st_var <- newIORef newCostCentreState + ; msg_var <- newIORef emptyMessages + ; let dflags = hsc_dflags hsc_env + type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) + rdr_env = mg_rdr_env guts + fam_inst_env = mg_fam_inst_env guts + this_mod = mg_module guts + complete_matches = hptCompleteSigs hsc_env + ++ mg_complete_sigs guts + + bindsToIds (NonRec v _) = [v] + bindsToIds (Rec binds) = map fst binds + ids = concatMap bindsToIds (mg_binds guts) + + envs = mkDsEnvs dflags this_mod rdr_env type_env + fam_inst_env msg_var cc_st_var + complete_matches + ; runDs hsc_env envs thing_inside + } + +initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a) +-- Spin up a TcM context so that we can run the constraint solver +-- Returns any error messages generated by the constraint solver +-- and (Just res) if no error happened; Nothing if an error happened +-- +-- Simon says: I'm not very happy about this. We spin up a complete TcM monad +-- only to immediately refine it to a TcS monad. +-- Better perhaps to make TcS into its own monad, rather than building on TcS +-- But that may in turn interact with plugins + +initTcDsForSolver thing_inside + = do { (gbl, lcl) <- getEnvs + ; hsc_env <- getTopEnv + + ; let DsGblEnv { ds_mod = mod + , ds_fam_inst_env = fam_inst_env } = gbl + + DsLclEnv { dsl_loc = loc } = lcl + + ; liftIO $ initTc hsc_env HsSrcFile False mod loc $ + updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $ + thing_inside } + +mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> IORef Messages -> IORef CostCentreState -> [CompleteMatch] + -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var + complete_matches + = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", + if_rec_types = Just (mod, return type_env) } + if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) + NotBoot + real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) + completeMatchMap = mkCompleteMatchMap complete_matches + gbl_env = DsGblEnv { ds_mod = mod + , ds_fam_inst_env = fam_inst_env + , ds_if_env = (if_genv, if_lenv) + , ds_unqual = mkPrintUnqualified dflags rdr_env + , ds_msgs = msg_var + , ds_complete_matches = completeMatchMap + , ds_cc_st = cc_st_var + } + lcl_env = DsLclEnv { dsl_meta = emptyNameEnv + , dsl_loc = real_span + , dsl_deltas = initDeltas + } + in (gbl_env, lcl_env) + + +{- +************************************************************************ +* * + Operations in the monad +* * +************************************************************************ + +And all this mysterious stuff is so we can occasionally reach out and +grab one or more names. @newLocalDs@ isn't exported---exported +functions are defined with it. The difference in name-strings makes +it easier to read debugging output. + +Note [Levity polymorphism checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the "Levity Polymorphism" paper (PLDI '17), levity +polymorphism is forbidden in precisely two places: in the type of a bound +term-level argument and in the type of an argument to a function. The paper +explains it more fully, but briefly: expressions in these contexts need to be +stored in registers, and it's hard (read, impossible) to store something +that's levity polymorphic. + +We cannot check for bad levity polymorphism conveniently in the type checker, +because we can't tell, a priori, which levity metavariables will be solved. +At one point, I (Richard) thought we could check in the zonker, but it's hard +to know where precisely are the abstracted variables and the arguments. So +we check in the desugarer, the only place where we can see the Core code and +still report respectable syntax to the user. This covers the vast majority +of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends. + +Levity polymorphism is also prohibited in the types of binders, and the +desugarer checks for this in GHC-generated Ids. (The zonker handles +the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. +The newSysLocalDs variant is used in the vast majority of cases where +the binder is obviously not levity polymorphic, omitting the check. +It would be nice to ASSERT that there is no levity polymorphism here, +but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though: +Core Lint will catch an error here. + +However, the desugarer is the wrong place for certain checks. In particular, +the desugarer can't report a sensible error message if an HsWrapper is malformed. +After all, GHC itself produced the HsWrapper. So we store some message text +in the appropriate HsWrappers (e.g. WpFun) that we can print out in the +desugarer. + +There are a few more checks in places where Core is generated outside the +desugarer. For example, in datatype and class declarations, where levity +polymorphism is checked for during validity checking. It would be nice to +have one central place for all this, but that doesn't seem possible while +still reporting nice error messages. + +-} + +-- Make a new Id with the same print name, but different type, and new unique +newUniqueId :: Id -> Mult -> Type -> DsM Id +newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) + +duplicateLocalDs :: Id -> DsM Id +duplicateLocalDs old_local + = do { uniq <- newUnique + ; return (setIdUnique old_local uniq) } + +newPredVarDs :: PredType -> DsM Var +newPredVarDs + = mkSysLocalOrCoVarM (fsLit "ds") Many -- like newSysLocalDs, but we allow covars + +newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id +newSysLocalDsNoLP = mk_local (fsLit "ds") + +-- this variant should be used when the caller can be sure that the variable type +-- is not levity-polymorphic. It is necessary when the type is knot-tied because +-- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking] +newSysLocalDs = mkSysLocalM (fsLit "ds") +newFailLocalDs = mkSysLocalM (fsLit "fail") + -- the fail variable is used only in a situation where we can tell that + -- levity-polymorphism is impossible. + +newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id] +newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t) +newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) + +mk_local :: FastString -> Mult -> Type -> DsM Id +mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> + ppr ty) -- could improve the msg with another + -- parameter indicating context + ; mkSysLocalOrCoVarM fs w ty } + +{- +We can also reach out and either set/grab location information from +the @SrcSpan@ being carried around. +-} + +getGhcModeDs :: DsM GhcMode +getGhcModeDs = getDynFlags >>= return . ghcMode + +-- | Get the current pattern match oracle state. See 'dsl_deltas'. +getPmDeltas :: DsM Deltas +getPmDeltas = do { env <- getLclEnv; return (dsl_deltas env) } + +-- | Set the pattern match oracle state within the scope of the given action. +-- See 'dsl_deltas'. +updPmDeltas :: Deltas -> DsM a -> DsM a +updPmDeltas delta = updLclEnv (\env -> env { dsl_deltas = delta }) + +getSrcSpanDs :: DsM SrcSpan +getSrcSpanDs = do { env <- getLclEnv + ; return (RealSrcSpan (dsl_loc env) Nothing) } + +putSrcSpanDs :: SrcSpan -> DsM a -> DsM a +putSrcSpanDs (UnhelpfulSpan {}) thing_inside + = thing_inside +putSrcSpanDs (RealSrcSpan real_span _) thing_inside + = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside + +-- | Emit a warning for the current source location +-- NB: Warns whether or not -Wxyz is set +warnDs :: WarnReason -> SDoc -> DsM () +warnDs reason warn + = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; dflags <- getDynFlags + ; let msg = makeIntoWarning reason $ + mkWarnMsg dflags loc (ds_unqual env) warn + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } + +-- | Emit a warning only if the correct WarnReason is set in the DynFlags +warnIfSetDs :: WarningFlag -> SDoc -> DsM () +warnIfSetDs flag warn + = whenWOptM flag $ + warnDs (Reason flag) warn + +errDs :: SDoc -> DsM () +errDs err + = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; dflags <- getDynFlags + ; let msg = mkErrMsg dflags loc (ds_unqual env) err + ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } + +-- | Issue an error, but return the expression for (), so that we can continue +-- reporting errors. +errDsCoreExpr :: SDoc -> DsM CoreExpr +errDsCoreExpr err + = do { errDs err + ; return unitExpr } + +failWithDs :: SDoc -> DsM a +failWithDs err + = do { errDs err + ; failM } + +failDs :: DsM a +failDs = failM + +-- (askNoErrsDs m) runs m +-- If m fails, +-- then (askNoErrsDs m) fails +-- If m succeeds with result r, +-- then (askNoErrsDs m) succeeds with result (r, b), +-- where b is True iff m generated no errors +-- Regardless of success or failure, +-- propagate any errors/warnings generated by m +-- +-- c.f. GHC.Tc.Utils.Monad.askNoErrs +askNoErrsDs :: DsM a -> DsM (a, Bool) +askNoErrsDs thing_inside + = do { errs_var <- newMutVar emptyMessages + ; env <- getGblEnv + ; mb_res <- tryM $ -- Be careful to catch exceptions + -- so that we propagate errors correctly + -- (#13642) + setGblEnv (env { ds_msgs = errs_var }) $ + thing_inside + + -- Propagate errors + ; msgs@(warns, errs) <- readMutVar errs_var + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) + + -- And return + ; case mb_res of + Left _ -> failM + Right res -> do { dflags <- getDynFlags + ; let errs_found = errorsFound dflags msgs + ; return (res, not errs_found) } } + +mkPrintUnqualifiedDs :: DsM PrintUnqualified +mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv + +instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where + lookupThing = dsLookupGlobal + +dsLookupGlobal :: Name -> DsM TyThing +-- Very like GHC.Tc.Utils.Env.tcLookupGlobal +dsLookupGlobal name + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (tcIfaceGlobal name) } + +dsLookupGlobalId :: Name -> DsM Id +dsLookupGlobalId name + = tyThingId <$> dsLookupGlobal name + +dsLookupTyCon :: Name -> DsM TyCon +dsLookupTyCon name + = tyThingTyCon <$> dsLookupGlobal name + +dsLookupDataCon :: Name -> DsM DataCon +dsLookupDataCon name + = tyThingDataCon <$> dsLookupGlobal name + +dsLookupConLike :: Name -> DsM ConLike +dsLookupConLike name + = tyThingConLike <$> dsLookupGlobal name + + +dsGetFamInstEnvs :: DsM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +dsGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, ds_fam_inst_env env) } + +dsGetMetaEnv :: DsM (NameEnv DsMetaVal) +dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } + +-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`. +dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch] +dsGetCompleteMatches tc = do + eps <- getEps + env <- getGblEnv + -- We index into a UniqFM from Name -> elt, for tyCon it holds that + -- getUnique (tyConName tc) == getUnique tc. So we lookup using the + -- unique directly instead. + let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc) + eps_matches_list = lookup_completes $ eps_complete_matches eps + env_matches_list = lookup_completes $ ds_complete_matches env + return $ eps_matches_list ++ env_matches_list + +dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) +dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } + +dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a +dsExtendMetaEnv menv thing_inside + = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside + +discardWarningsDs :: DsM a -> DsM a +-- Ignore warnings inside the thing inside; +-- used to ignore inaccessible cases etc. inside generated code +discardWarningsDs thing_inside + = do { env <- getGblEnv + ; old_msgs <- readTcRef (ds_msgs env) + + ; result <- thing_inside + + -- Revert messages to old_msgs + ; writeTcRef (ds_msgs env) old_msgs + + ; return result } + +-- | Fail with an error message if the type is levity polymorphic. +dsNoLevPoly :: Type -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty + +-- | Check an expression for levity polymorphism, failing if it is +-- levity polymorphic. +dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPolyExpr e doc + | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) + | otherwise = return () + +-- | Runs the thing_inside. If there are no errors, then returns the expr +-- given. Otherwise, returns unitExpr. This is useful for doing a bunch +-- of levity polymorphism checks and then avoiding making a core App. +-- (If we make a core App on a levity polymorphic argument, detecting how +-- to handle the let/app invariant might call isUnliftedType, which panics +-- on a levity polymorphic type.) +-- See #12709 for an example of why this machinery is necessary. +dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr +dsWhenNoErrs thing_inside mk_expr + = do { (result, no_errs) <- askNoErrsDs thing_inside + ; return $ if no_errs + then mk_expr result + else unitExpr } + +-- | Inject a trace message into the compiled program. Whereas +-- pprTrace prints out information *while compiling*, pprRuntimeTrace +-- captures that information and causes it to be printed *at runtime* +-- using Debug.Trace.trace. +-- +-- pprRuntimeTrace hdr doc expr +-- +-- will produce an expression that looks like +-- +-- trace (hdr + doc) expr +-- +-- When using this to debug a module that Debug.Trace depends on, +-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that +-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace, +-- but that doesn't seem worth the effort and maintenance cost. +pprRuntimeTrace :: String -- ^ header + -> SDoc -- ^ information to output + -> CoreExpr -- ^ expression + -> DsM CoreExpr +pprRuntimeTrace str doc expr = do + traceId <- dsLookupGlobalId traceName + unpackCStringId <- dsLookupGlobalId unpackCStringName + dflags <- getDynFlags + let message :: CoreExpr + message = App (Var unpackCStringId) $ + Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) + return $ mkApps (Var traceId) [Type (exprType expr), message, expr] diff --git a/GHC/HsToCore/PmCheck.hs b/GHC/HsToCore/PmCheck.hs --- a/GHC/HsToCore/PmCheck.hs +++ b/GHC/HsToCore/PmCheck.hs @@ -14,49 +14,53 @@ module GHC.HsToCore.PmCheck ( -- Checking and printing checkSingle, checkMatches, checkGuardMatches, - needToRunPmCheck, isMatchContextPmChecked, + isMatchContextPmChecked, -- See Note [Type and Term Equality Propagation] - addTyCsDs, addScrutTmCs, addPatTmCs + addTyCsDs, addScrutTmCs ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.PmCheck.Types import GHC.HsToCore.PmCheck.Oracle import GHC.HsToCore.PmCheck.Ppr -import BasicTypes (Origin, isGenerated) -import CoreSyn (CoreExpr, Expr(Var,App)) -import FastString (unpackFS, lengthFS) -import DynFlags +import GHC.Types.Basic (Origin(..), isGenerated) +import GHC.Core (CoreExpr, Expr(Var,App)) +import GHC.Data.FastString (unpackFS, lengthFS) +import GHC.Driver.Session import GHC.Hs -import TcHsSyn -import Id -import ConLike -import Name -import FamInst -import TysWiredIn -import SrcLoc -import Util -import Outputable -import DataCon -import TyCon -import Var (EvVar) -import Coercion -import TcEvidence -import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr) -import {-# SOURCE #-} DsBinds (dsHsWrapper) -import DsUtils (selectMatchVar) -import MatchLit (dsLit, dsOverLit) -import DsMonad -import Bag -import TyCoRep -import Type -import DsUtils (isTrueLHsExpr) -import Maybes +import GHC.Tc.Utils.Zonk (shortCutLit) +import GHC.Types.Id +import GHC.Core.ConLike +import GHC.Types.Name +import GHC.Tc.Instance.Family +import GHC.Builtin.Types +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Types.Var (EvVar) +import GHC.Core.Coercion +import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper) +import GHC.Tc.Utils.TcType (evVarPred) +import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) +import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) +import GHC.HsToCore.Utils (selectMatchVar) +import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) +import GHC.HsToCore.Monad +import GHC.Data.Bag +import GHC.Data.IOEnv (unsafeInterleaveM) +import GHC.Data.OrdList +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.HsToCore.Utils (isTrueLHsExpr) +import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.Monad (concatMapM) import Control.Monad (when, forM_, zipWithM) import Data.List (elemIndex) @@ -75,7 +79,7 @@ "GADTs Meet Their Match: Pattern-matching Warnings That Account for GADTs, Guards, and Laziness" - http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf + https://www.microsoft.com/en-us/research/wp-content/uploads/2016/08/gadtpm-acm.pdf %************************************************************************ %* * @@ -87,9 +91,8 @@ -- | A very simple language for pattern guards. Let bindings, bang patterns, -- and matching variables against flat constructor patterns. data PmGrd - = -- | @PmCon x K tvs dicts args@ corresponds to a - -- @K tvs dicts args <- x@ guard. The @tvs@ and @args@ are bound in this - -- construct, the @x@ is just a use. + = -- | @PmCon x K dicts args@ corresponds to a @K dicts args <- x@ guard. + -- The @args@ are bound in this construct, the @x@ is just a use. -- For the arguments' meaning see 'GHC.Hs.Pat.ConPatOut'. PmCon { pm_id :: !Id, @@ -107,68 +110,19 @@ -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually -- /binds/ @x@. | PmLet { - pm_id :: !Id, - pm_let_expr :: !CoreExpr + pm_id :: !Id, + _pm_let_expr :: !CoreExpr } -- | Should not be user-facing. instance Outputable PmGrd where - ppr (PmCon x alt _con_tvs _con_dicts con_args) + ppr (PmCon x alt _tvs _con_dicts con_args) = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x] ppr (PmBang x) = char '!' <> ppr x ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr] type GrdVec = [PmGrd] --- | Each 'Delta' is proof (i.e., a model of the fact) that some values are not --- covered by a pattern match. E.g. @f Nothing = @ might be given an --- uncovered set @[x :-> Just y]@ or @[x /= Nothing]@, where @x@ is the variable --- matching against @f@'s first argument. -type Uncovered = [Delta] - --- Instead of keeping the whole sets in memory, we keep a boolean for both the --- covered and the divergent set (we store the uncovered set though, since we --- want to print it). For both the covered and the divergent we have: --- --- True <=> The set is non-empty --- --- hence: --- C = True ==> Useful clause (no warning) --- C = False, D = True ==> Clause with inaccessible RHS --- C = False, D = False ==> Redundant clause - -data Covered = Covered | NotCovered - deriving Show - -instance Outputable Covered where - ppr = text . show - --- Like the or monoid for booleans --- Covered = True, Uncovered = False -instance Semi.Semigroup Covered where - Covered <> _ = Covered - _ <> Covered = Covered - NotCovered <> NotCovered = NotCovered - -instance Monoid Covered where - mempty = NotCovered - mappend = (Semi.<>) - -data Diverged = Diverged | NotDiverged - deriving Show - -instance Outputable Diverged where - ppr = text . show - -instance Semi.Semigroup Diverged where - Diverged <> _ = Diverged - _ <> Diverged = Diverged - NotDiverged <> NotDiverged = NotDiverged - -instance Monoid Diverged where - mempty = NotDiverged - mappend = (Semi.<>) - data Precision = Approximate | Precise deriving (Eq, Show) @@ -176,79 +130,121 @@ ppr = text . show instance Semi.Semigroup Precision where - Approximate <> _ = Approximate - _ <> Approximate = Approximate Precise <> Precise = Precise + _ <> _ = Approximate instance Monoid Precision where mempty = Precise mappend = (Semi.<>) --- | A triple of covered, uncovered, and divergent sets. --- --- Also stores a flag 'presultApprox' denoting whether we ran into the --- 'maxPmCheckModels' limit for the purpose of hints in warning messages to --- maybe increase the limit. -data PartialResult = PartialResult { - presultCovered :: Covered - , presultUncovered :: Uncovered - , presultDivergent :: Diverged - , presultApprox :: Precision } +-- | Means by which we identify a RHS for later pretty-printing in a warning +-- message. 'SDoc' for the equation to show, 'Located' for the location. +type RhsInfo = Located SDoc -emptyPartialResult :: PartialResult -emptyPartialResult = PartialResult { presultUncovered = mempty - , presultCovered = mempty - , presultDivergent = mempty - , presultApprox = mempty } +-- | A representation of the desugaring to 'PmGrd's of all clauses of a +-- function definition/pattern match/etc. +data GrdTree + = Rhs !RhsInfo + | Guard !PmGrd !GrdTree + -- ^ @Guard grd t@ will try to match @grd@ and on success continue to match + -- @t@. Falls through if either match fails. Models left-to-right semantics + -- of pattern matching. + | Sequence !GrdTree !GrdTree + -- ^ @Sequence l r@ first matches against @l@, and then matches all + -- fallen-through values against @r@. Models top-to-bottom semantics of + -- pattern matching. + | Empty + -- ^ A @GrdTree@ that always fails. Most useful for + -- Note [Checking EmptyCase]. A neutral element to 'Sequence'. -combinePartialResults :: PartialResult -> PartialResult -> PartialResult -combinePartialResults (PartialResult cs1 vsa1 ds1 ap1) (PartialResult cs2 vsa2 ds2 ap2) - = PartialResult (cs1 Semi.<> cs2) - (vsa1 Semi.<> vsa2) - (ds1 Semi.<> ds2) - (ap1 Semi.<> ap2) -- the result is approximate if either is +-- | The digest of 'checkGrdTree', representing the annotated pattern-match +-- tree. 'redundantAndInaccessibleRhss' can figure out redundant and proper +-- inaccessible RHSs from this. +data AnnotatedTree + = AccessibleRhs !Deltas !RhsInfo + -- ^ A RHS deemed accessible. The 'Deltas' is the (non-empty) set of covered + -- values. + | InaccessibleRhs !RhsInfo + -- ^ A RHS deemed inaccessible; it covers no value. + | MayDiverge !AnnotatedTree + -- ^ Asserts that the tree may force diverging values, so not all of its + -- clauses can be redundant. + | SequenceAnn !AnnotatedTree !AnnotatedTree + -- ^ Mirrors 'Sequence' for preserving the skeleton of a 'GrdTree's. + | EmptyAnn + -- ^ Mirrors 'Empty' for preserving the skeleton of a 'GrdTree's. -instance Outputable PartialResult where - ppr (PartialResult c unc d pc) - = hang (text "PartialResult" <+> ppr c <+> ppr d <+> ppr pc) 2 (ppr_unc unc) +pprRhsInfo :: RhsInfo -> SDoc +pprRhsInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss) +pprRhsInfo (L s _) = ppr s + +instance Outputable GrdTree where + ppr (Rhs info) = text "->" <+> pprRhsInfo info + -- Format guards as "| True <- x, let x = 42, !z" + ppr g@Guard{} = fsep (prefix (map ppr grds)) <+> ppr t where - ppr_unc = braces . fsep . punctuate comma . map ppr + (t, grds) = collect_grds g + collect_grds (Guard grd t) = (grd :) <$> collect_grds t + collect_grds t = (t, []) + prefix [] = [] + prefix (s:sdocs) = char '|' <+> s : map (comma <+>) sdocs + -- Format nested Sequences in blocks "{ grds1; grds2; ... }" + ppr t@Sequence{} = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space) + where + collect_seqs (Sequence l r) = collect_seqs l ++ collect_seqs r + collect_seqs t = [ppr t] + ppr Empty = text "" -instance Semi.Semigroup PartialResult where - (<>) = combinePartialResults +instance Outputable AnnotatedTree where + ppr (AccessibleRhs _ info) = pprRhsInfo info + ppr (InaccessibleRhs info) = text "inaccessible" <+> pprRhsInfo info + ppr (MayDiverge t) = text "div" <+> ppr t + -- Format nested Sequences in blocks "{ grds1; grds2; ... }" + ppr t@SequenceAnn{} = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space) + where + collect_seqs (SequenceAnn l r) = collect_seqs l ++ collect_seqs r + collect_seqs t = [ppr t] + ppr EmptyAnn = text "" -instance Monoid PartialResult where - mempty = emptyPartialResult - mappend = (Semi.<>) +-- | Lift 'addPmCts' over 'Deltas'. +addPmCtsDeltas :: Deltas -> PmCts -> DsM Deltas +addPmCtsDeltas deltas cts = liftDeltasM (\d -> addPmCts d cts) deltas --- | Pattern check result --- --- * Redundant clauses --- * Not-covered clauses (or their type, if no pattern is available) --- * Clauses with inaccessible RHS --- * A flag saying whether we ran into the 'maxPmCheckModels' limit for the --- purpose of suggesting to crank it up in the warning message --- --- More details about the classification of clauses into useful, redundant --- and with inaccessible right hand side can be found here: --- --- https://gitlab.haskell.org/ghc/ghc/wikis/pattern-match-check --- -data PmResult = - PmResult { - pmresultRedundant :: [Located [LPat GhcTc]] - , pmresultUncovered :: [Delta] - , pmresultInaccessible :: [Located [LPat GhcTc]] - , pmresultApproximate :: Precision } +-- | 'addPmCtsDeltas' a single 'PmCt'. +addPmCtDeltas :: Deltas -> PmCt -> DsM Deltas +addPmCtDeltas deltas ct = addPmCtsDeltas deltas (unitBag ct) -instance Outputable PmResult where - ppr pmr = hang (text "PmResult") 2 $ vcat - [ text "pmresultRedundant" <+> ppr (pmresultRedundant pmr) - , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr) - , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr) - , text "pmresultApproximate" <+> ppr (pmresultApproximate pmr) - ] +-- | Test if any of the 'Delta's is inhabited. Currently this is pure, because +-- we preserve the invariant that there are no uninhabited 'Delta's. But that +-- could change in the future, for example by implementing this function in +-- terms of @notNull <$> provideEvidence 1 ds@. +isInhabited :: Deltas -> DsM Bool +isInhabited (MkDeltas ds) = pure (not (null ds)) +-- | Pattern-match check result +data CheckResult + = CheckResult + { cr_clauses :: !AnnotatedTree + -- ^ Captures redundancy info for each clause in the original program. + -- (for -Woverlapping-patterns) + , cr_uncov :: !Deltas + -- ^ The set of uncovered values falling out at the bottom. + -- (for -Wincomplete-patterns) + , cr_approx :: !Precision + -- ^ A flag saying whether we ran into the 'maxPmCheckModels' limit for the + -- purpose of suggesting to crank it up in the warning message + } + +instance Outputable CheckResult where + ppr (CheckResult c unc pc) + = text "CheckResult" <+> ppr_precision pc <+> braces (fsep + [ field "clauses" c <> comma + , field "uncov" unc]) + where + ppr_precision Precise = empty + ppr_precision Approximate = text "(Approximate)" + field name value = text name <+> equals <+> ppr value + {- %************************************************************************ %* * @@ -257,119 +253,93 @@ %************************************************************************ -} --- | Check a single pattern binding (let) +-- | Check a single pattern binding (let) for exhaustiveness. checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM () -checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do +checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p]) - res <- checkSingle' locn var p - dsPmWarn dflags ctxt [var] res - --- | Check a single pattern binding (let) -checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> DsM PmResult -checkSingle' locn var p = do - fam_insts <- dsGetFamInstEnvs - grds <- translatePat fam_insts var p - missing <- getPmDelta - tracePm "checkSingle': missing" (ppr missing) - PartialResult cs us ds pc <- pmCheck grds [] 1 missing - dflags <- getDynFlags - us' <- getNFirstUncovered [var] (maxUncoveredPatterns dflags + 1) us - let plain = PmResult { pmresultRedundant = [] - , pmresultUncovered = us' - , pmresultInaccessible = [] - , pmresultApproximate = pc } - return $ case (cs,ds) of - (Covered , _ ) -> plain -- useful - (NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant - (NotCovered, Diverged ) -> plain { pmresultInaccessible = m } -- inaccessible rhs - where m = [cL locn [cL locn p]] + -- We only ever need to run this in a context where we need exhaustivity + -- warnings (so not in pattern guards or comprehensions, for example, because + -- they are perfectly fine to fail). + -- Omitting checking this flag emits redundancy warnings twice in obscure + -- cases like #17646. + when (exhaustive dflags kind) $ do + -- TODO: This could probably call checkMatches, like checkGuardMatches. + missing <- getPmDeltas + tracePm "checkSingle: missing" (ppr missing) + fam_insts <- dsGetFamInstEnvs + grd_tree <- mkGrdTreeRhs (L locn $ ppr p) <$> translatePat fam_insts var p + res <- checkGrdTree grd_tree missing + dsPmWarn dflags ctxt [var] res -- | Exhaustive for guard matches, is used for guards in pattern bindings and --- in @MultiIf@ expressions. -checkGuardMatches :: HsMatchContext Name -- Match context - -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs - -> DsM () +-- in @MultiIf@ expressions. Returns the 'Deltas' covered by the RHSs. +checkGuardMatches + :: HsMatchContext GhcRn -- ^ Match context, for warning messages + -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check + -> DsM [Deltas] -- ^ Covered 'Deltas' for each RHS, for long + -- distance info checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do - dflags <- getDynFlags let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc - match = cL combinedLoc $ + match = L combinedLoc $ Match { m_ext = noExtField , m_ctxt = hs_ctx , m_pats = [] , m_grhss = guards } - checkMatches dflags dsMatchContext [] [match] -checkGuardMatches _ (XGRHSs nec) = noExtCon nec + checkMatches dsMatchContext [] [match] --- | Check a matchgroup (case, functions, etc.) -checkMatches :: DynFlags -> DsMatchContext - -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM () -checkMatches dflags ctxt vars matches = do +-- | Check a list of syntactic /match/es (part of case, functions, etc.), each +-- with a /pat/ and one or more /grhss/: +-- +-- @ +-- f x y | x == y = 1 -- match on x and y with two guarded RHSs +-- | otherwise = 2 +-- f _ _ = 3 -- clause with a single, un-guarded RHS +-- @ +-- +-- Returns one 'Deltas' for each GRHS, representing its covered values, or the +-- incoming uncovered 'Deltas' (from 'getPmDeltas') if the GRHS is inaccessible. +-- Since there is at least one /grhs/ per /match/, the list of 'Deltas' is at +-- least as long as the list of matches. +checkMatches + :: DsMatchContext -- ^ Match context, for warnings messages + -> [Id] -- ^ Match variables, i.e. x and y above + -> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches + -> DsM [Deltas] -- ^ One covered 'Deltas' per RHS, for long + -- distance info. +checkMatches ctxt vars matches = do + dflags <- getDynFlags tracePm "checkMatches" (hang (vcat [ppr ctxt , ppr vars , text "Matches:"]) 2 (vcat (map ppr matches))) - res <- checkMatches' vars matches - dsPmWarn dflags ctxt vars res --- | Check a matchgroup (case, functions, etc.). -checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM PmResult -checkMatches' vars matches = do - init_delta <- getPmDelta + init_deltas <- getPmDeltas missing <- case matches of -- This must be an -XEmptyCase. See Note [Checking EmptyCase] - [] | [var] <- vars -> maybeToList <$> addTmCt init_delta (TmVarNonVoid var) - _ -> pure [init_delta] - tracePm "checkMatches': missing" (ppr missing) - (rs,us,ds,pc) <- go matches missing - dflags <- getDynFlags - us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us - return $ PmResult { - pmresultRedundant = map hsLMatchToLPats rs - , pmresultUncovered = us' - , pmresultInaccessible = map hsLMatchToLPats ds - , pmresultApproximate = pc } - where - go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered - -> DsM ( [LMatch GhcTc (LHsExpr GhcTc)] - , Uncovered - , [LMatch GhcTc (LHsExpr GhcTc)] - , Precision) - go [] missing = return ([], missing, [], Precise) - go (m:ms) missing = do - tracePm "checkMatches': go" (ppr m) - dflags <- getDynFlags - fam_insts <- dsGetFamInstEnvs - (clause, guards) <- translateMatch fam_insts vars m - let limit = maxPmCheckModels dflags - n_siblings = length missing - throttled_check delta = - snd <$> throttle limit (pmCheck clause guards) n_siblings delta - - r@(PartialResult cs missing' ds pc1) <- runMany throttled_check missing + [] | [var] <- vars -> addPmCtDeltas init_deltas (PmNotBotCt var) + _ -> pure init_deltas + fam_insts <- dsGetFamInstEnvs + grd_tree <- mkGrdTreeMany [] <$> mapM (translateMatch fam_insts vars) matches + res <- checkGrdTree grd_tree missing - tracePm "checkMatches': go: res" (ppr r) - (rs, final_u, is, pc2) <- go ms missing' - return $ case (cs, ds) of - -- useful - (Covered, _ ) -> (rs, final_u, is, pc1 Semi.<> pc2) - -- redundant - (NotCovered, NotDiverged) -> (m:rs, final_u, is, pc1 Semi.<> pc2) - -- inaccessible - (NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2) + dsPmWarn dflags ctxt vars res - hsLMatchToLPats :: LMatch id body -> Located [LPat id] - hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats - hsLMatchToLPats _ = panic "checkMatches'" + return (extractRhsDeltas init_deltas (cr_clauses res)) -getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta] -getNFirstUncovered _ 0 _ = pure [] -getNFirstUncovered _ _ [] = pure [] -getNFirstUncovered vars n (delta:deltas) = do - front <- provideEvidence vars n delta - back <- getNFirstUncovered vars (n - length front) deltas - pure (front ++ back) +-- | Extract the 'Deltas' reaching the RHSs of the 'AnnotatedTree'. +-- For 'AccessibleRhs's, this is stored in the tree node, whereas +-- 'InaccessibleRhs's fall back to the supplied original 'Deltas'. +-- See @Note [Recovering from unsatisfiable pattern-matching constraints]@. +extractRhsDeltas :: Deltas -> AnnotatedTree -> [Deltas] +extractRhsDeltas orig_deltas = fromOL . go + where + go (AccessibleRhs deltas _) = unitOL deltas + go (InaccessibleRhs _) = unitOL orig_deltas + go (MayDiverge t) = go t + go (SequenceAnn l r) = go l Semi.<> go r + go EmptyAnn = nilOL {- Note [Checking EmptyCase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -417,7 +387,8 @@ -- @mkListGrds "a" "[(x, True <- x),(y, !y)]"@ -- to -- @"[(x:b) <- a, True <- x, (y:c) <- b, seq y True, [] <- c]"@ --- where b,c are freshly allocated in @mkListGrds@ and a is the match variable. +-- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match +-- variable. mkListGrds :: Id -> [(Id, GrdVec)] -> DsM GrdVec -- See Note [Order of guards matter] for why we need to intertwine guards -- on list elements. @@ -432,9 +403,10 @@ mkPmLitGrds x (PmLit _ (PmLitString s)) = do -- We translate String literals to list literals for better overlap reasoning. -- It's a little unfortunate we do this here rather than in - -- 'GHC.HsToCore.PmCheck.Oracle.trySolve' and 'GHC.HsToCore.PmCheck.Oracle.addRefutableAltCon', but it's so much - -- simpler here. - -- See Note [Representation of Strings in TmState] in GHC.HsToCore.PmCheck.Oracle + -- 'GHC.HsToCore.PmCheck.Oracle.trySolve' and + -- 'GHC.HsToCore.PmCheck.Oracle.addRefutableAltCon', but it's so much simpler + -- here. See Note [Representation of Strings in TmState] in + -- GHC.HsToCore.PmCheck.Oracle vars <- traverse mkPmId (take (lengthFS s) (repeat charTy)) let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c)) char_grdss <- zipWithM mk_char_lit vars (unpackFS s) @@ -465,14 +437,14 @@ -- (x@pat) ==> Translate pat with x as match var and handle impedance -- mismatch with incoming match var - AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p + AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p SigPat _ p _ty -> translateLPat fam_insts x p -- See Note [Translate CoPats] -- Generally the translation is -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat - CoPat _ wrapper p _ty + XPat (CoPat wrapper p _ty) | isIdHsWrapper wrapper -> translatePat fam_insts x p | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts x p | otherwise -> do @@ -481,7 +453,7 @@ pure (PmLet y (wrap_rhs_y (Var x)) : grds) -- (n + k) ===> let b = x >= k, True <- b, let n = x-k - NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do + NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do b <- mkPmId boolTy let grd_b = vanillaConGrd b trueDataCon [] [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2] @@ -527,25 +499,29 @@ -- -- See #14547, especially comment#9 and comment#10. - ConPatOut { pat_con = (dL->L _ con) - , pat_arg_tys = arg_tys - , pat_tvs = ex_tvs - , pat_dicts = dicts - , pat_args = ps } -> do + ConPat { pat_con = L _ con + , pat_args = ps + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + , cpt_tvs = ex_tvs + , cpt_dicts = dicts + } + } -> do translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps - NPat ty (dL->L _ olit) mb_neg _ -> do - -- See Note [Literal short cut] in MatchLit.hs + NPat ty (L _ olit) mb_neg _ -> do + -- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal" -- We inline the Literal short cut for @ty@ here, because @ty@ is more -- precise than the field of OverLitTc, which is all that dsOverLit (which -- normally does the literal short cut) can look at. Also @ty@ matches the -- type of the scrutinee, so info on both pattern and scrutinee (for which -- short cutting in dsOverLit works properly) is overloaded iff either is. dflags <- getDynFlags + let platform = targetPlatform dflags core_expr <- case olit of OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ } | not rebindable - , Just expr <- shortCutLit dflags val ty + , Just expr <- shortCutLit platform val ty -> dsExpr expr _ -> dsOverLit olit let lit = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr) @@ -567,19 +543,17 @@ SumPat _ty p alt arity -> do (y, grds) <- translateLPatV fam_insts p let sum_con = sumDataCon alt arity - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon pure $ vanillaConGrd x sum_con [y] : grds -- -------------------------------------------------------------------------- -- Not supposed to happen - ConPatIn {} -> panic "Check.translatePat: ConPatIn" SplicePat {} -> panic "Check.translatePat: SplicePat" - XPat n -> noExtCon n -- | 'translatePat', but also select and return a new match var. translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec) translatePatV fam_insts pat = do - x <- selectMatchVar pat + x <- selectMatchVar Many pat grds <- translatePat fam_insts x pat pure (x, grds) @@ -607,7 +581,7 @@ RecCon (HsRecFields fs _) -> go_field_pats (rec_field_ps fs) where -- The actual argument types (instantiated) - arg_tys = conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs) + arg_tys = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs) -- Extract record field patterns tagged by field index from a list of -- LHsRecField @@ -654,43 +628,47 @@ -- 1. 2. 3. pure (con_grd : bang_grds ++ arg_grds) +mkGrdTreeRhs :: Located SDoc -> GrdVec -> GrdTree +mkGrdTreeRhs sdoc = foldr Guard (Rhs sdoc) + +mkGrdTreeMany :: GrdVec -> [GrdTree] -> GrdTree +mkGrdTreeMany _ [] = Empty +mkGrdTreeMany grds trees = foldr Guard (foldr1 Sequence trees) grds + -- Translate a single match translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc) - -> DsM (GrdVec, [GrdVec]) -translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) - = do - pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats - guards' <- mapM (translateGuards fam_insts) guards - -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr guards, ppr guards']) - return (pats', guards') - where - extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] - extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs - extractGuards _ = panic "translateMatch" - - guards = map extractGuards (grhssGRHSs grhss) -translateMatch _ _ _ = panic "translateMatch" + -> DsM GrdTree +translateMatch fam_insts vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do + pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats + grhss' <- mapM (translateLGRHS fam_insts match_loc pats) (grhssGRHSs grhss) + -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss, ppr grhss']) + return (mkGrdTreeMany pats' grhss') -- ----------------------------------------------------------------------- -- * Transform source guards (GuardStmt Id) to simpler PmGrds --- | Translate a list of guard statements to a 'GrdVec' -translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM GrdVec -translateGuards fam_insts guards = - concat <$> mapM (translateGuard fam_insts) guards +-- | Translate a guarded right-hand side to a single 'GrdTree' +translateLGRHS :: FamInstEnvs -> SrcSpan -> [LPat GhcTc] -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM GrdTree +translateLGRHS fam_insts match_loc pats (L _loc (GRHS _ gs _)) = + -- _loc apparently points to the match separator that comes after the guards.. + mkGrdTreeRhs loc_sdoc <$> concatMapM (translateGuard fam_insts . unLoc) gs + where + loc_sdoc + | null gs = L match_loc (sep (map ppr pats)) + | otherwise = L grd_loc (sep (map ppr pats) <+> vbar <+> interpp'SP gs) + L grd_loc _ = head gs -- | Translate a guard statement to a 'GrdVec' translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec translateGuard fam_insts guard = case guard of BodyStmt _ e _ _ -> translateBoolGuard e LetStmt _ binds -> translateLet (unLoc binds) - BindStmt _ p e _ _ -> translateBind fam_insts p e + BindStmt _ p e -> translateBind fam_insts p e LastStmt {} -> panic "translateGuard LastStmt" ParStmt {} -> panic "translateGuard ParStmt" TransStmt {} -> panic "translateGuard TransStmt" RecStmt {} -> panic "translateGuard RecStmt" ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt" - XStmtLR nec -> noExtCon nec -- | Translate let-bindings translateLet :: HsLocalBinds GhcTc -> DsM GrdVec @@ -802,24 +780,12 @@ and report @f _ _@ as missing, which is a superset of the actual missing matches. But soundness means we will never fail to report a missing match. -This mechanism is implemented in the higher-order function 'throttle'. - -Note [Combinatorial explosion in guards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Function with many clauses and deeply nested guards like in #11195 tend to -overwhelm the checker because they lead to exponential splitting behavior. -See the comments on #11195 on refinement trees. Every guard refines the -disjunction of Deltas by another split. This no different than the ConVar case, -but in stark contrast we mostly don't get any useful information out of that -split! Hence splitting k-fold just means having k-fold more work. The problem -exacerbates for larger k, because it gets even more unlikely that we can handle -all of the arising Deltas better than just continue working on the original -Delta. +This mechanism is implemented in 'throttle'. -We simply apply the same mechanism as in Note [Countering exponential blowup]. -But we don't want to forget about actually useful info from pattern match -clauses just because we had one clause with many guards. So we set the limit for -guards much lower. +Guards are an extreme example in this regard, with #11195 being a particularly +dreadful example: Since their RHS are often pretty much unique, we split on a +variable (the one representing the RHS) that doesn't occur anywhere else in the +program, so we don't actually get useful information out of that split! Note [Translate CoPats] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -938,191 +904,112 @@ {- %************************************************************************ %* * - Heart of the algorithm: Function pmCheck + Heart of the algorithm: checkGrdTree %* * %************************************************************************ - -Main functions are: - -* pmCheck :: PatVec -> [PatVec] -> ValVec -> Delta -> DsM PartialResult +-} - This function implements functions `covered`, `uncovered` and - `divergent` from the paper at once. Calls out to the auxilary function - `pmCheckGuards` for handling (possibly multiple) guarded RHSs when the whole - clause is checked. Slightly different from the paper because it does not even - produce the covered and uncovered sets. Since we only care about whether a - clause covers SOMETHING or if it may forces ANY argument, we only store a - boolean in both cases, for efficiency. +-- | @throttle limit old new@ returns @old@ if the number of 'Delta's in @new@ +-- is exceeding the given @limit@ and the @old@ number of 'Delta's. +-- See Note [Countering exponential blowup]. +throttle :: Int -> Deltas -> Deltas -> (Precision, Deltas) +throttle limit old@(MkDeltas old_ds) new@(MkDeltas new_ds) + --- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined + | length new_ds > max limit (length old_ds) = (Approximate, old) + | otherwise = (Precise, new) -* pmCheckGuards :: [PatVec] -> ValVec -> Delta -> DsM PartialResult +-- | Matching on a newtype doesn't force anything. +-- See Note [Divergence of Newtype matches] in "GHC.HsToCore.PmCheck.Oracle". +conMatchForces :: PmAltCon -> Bool +conMatchForces (PmAltConLike (RealDataCon dc)) + | isNewTyCon (dataConTyCon dc) = False +conMatchForces _ = True - Processes the guards. --} +-- | Makes sure that we only wrap a single 'MayDiverge' around an +-- 'AnnotatedTree', purely for esthetic reasons. +mayDiverge :: AnnotatedTree -> AnnotatedTree +mayDiverge a@(MayDiverge _) = a +mayDiverge a = MayDiverge a --- | @throttle limit f n delta@ executes the pattern match action @f@ but --- replaces the 'Uncovered' set by @[delta]@ if not doing so would lead to --- too many Deltas to check. --- --- See Note [Countering exponential blowup] and --- Note [Combinatorial explosion in guards] +-- | Computes two things: -- --- How many is "too many"? @throttle@ assumes that the pattern match action --- will be executed against @n@ similar other Deltas, its "siblings". Now, by --- observing the branching factor (i.e. the number of children) of executing --- the action, we can estimate how many Deltas there would be in the next --- generation. If we find that this number exceeds @limit@, we do --- "birth control": We simply don't allow a branching factor of more than 1. --- Otherwise we just return the singleton set of the original @delta@. --- This amounts to forgetting about the refined facts we got from running the --- action. -throttle :: Int -> (Int -> Delta -> DsM PartialResult) -> Int -> Delta -> DsM (Int, PartialResult) -throttle limit f n_siblings delta = do - res <- f n_siblings delta - let n_own_children = length (presultUncovered res) - let n_next_gen = n_siblings * n_own_children - -- Birth control! - if n_next_gen <= limit || n_own_children <= 1 - then pure (n_next_gen, res) - else pure (n_siblings, res { presultUncovered = [delta], presultApprox = Approximate }) - --- | Map a pattern matching action processing a single 'Delta' over a --- 'Uncovered' set and return the combined 'PartialResult's. -runMany :: (Delta -> DsM PartialResult) -> Uncovered -> DsM PartialResult -runMany f unc = mconcat <$> traverse f unc +-- * The set of uncovered values not matched by any of the clauses of the +-- 'GrdTree'. Note that 'PmCon' guards are the only way in which values +-- fall through from one 'Many' branch to the next. +-- * An 'AnnotatedTree' that contains divergence and inaccessibility info +-- for all clauses. Will be fed to 'redundantAndInaccessibleRhss' for +-- presenting redundant and proper innaccessible RHSs to the user. +checkGrdTree' :: GrdTree -> Deltas -> DsM CheckResult +-- RHS: Check that it covers something and wrap Inaccessible if not +checkGrdTree' (Rhs sdoc) deltas = do + is_covered <- isInhabited deltas + let clauses + | is_covered = AccessibleRhs deltas sdoc + | otherwise = InaccessibleRhs sdoc + pure CheckResult + { cr_clauses = clauses + , cr_uncov = MkDeltas emptyBag + , cr_approx = Precise } +-- let x = e: Refine with x ~ e +checkGrdTree' (Guard (PmLet x e) tree) deltas = do + deltas' <- addPmCtDeltas deltas (PmCoreCt x e) + checkGrdTree' tree deltas' +-- Bang x: Diverge on x ~ ⊥, refine with x /~ ⊥ +checkGrdTree' (Guard (PmBang x) tree) deltas = do + has_diverged <- addPmCtDeltas deltas (PmBotCt x) >>= isInhabited + deltas' <- addPmCtDeltas deltas (PmNotBotCt x) + res <- checkGrdTree' tree deltas' + pure res{ cr_clauses = applyWhen has_diverged mayDiverge (cr_clauses res) } +-- Con: Diverge on x ~ ⊥, fall through on x /~ K and refine with x ~ K ys +-- and type info +checkGrdTree' (Guard (PmCon x con tvs dicts args) tree) deltas = do + has_diverged <- + if conMatchForces con + then addPmCtDeltas deltas (PmBotCt x) >>= isInhabited + else pure False + unc_this <- addPmCtDeltas deltas (PmNotConCt x con) + deltas' <- addPmCtsDeltas deltas $ + listToBag (PmTyCt . evVarPred <$> dicts) `snocBag` PmConCt x con tvs args + CheckResult tree' unc_inner prec <- checkGrdTree' tree deltas' + limit <- maxPmCheckModels <$> getDynFlags + let (prec', unc') = throttle limit deltas (unc_this Semi.<> unc_inner) + pure CheckResult + { cr_clauses = applyWhen has_diverged mayDiverge tree' + , cr_uncov = unc' + , cr_approx = prec Semi.<> prec' } +-- Sequence: Thread residual uncovered sets from equation to equation +checkGrdTree' (Sequence l r) unc_0 = do + CheckResult l' unc_1 prec_l <- checkGrdTree' l unc_0 + CheckResult r' unc_2 prec_r <- checkGrdTree' r unc_1 + pure CheckResult + { cr_clauses = SequenceAnn l' r' + , cr_uncov = unc_2 + , cr_approx = prec_l Semi.<> prec_r } +-- Empty: Fall through for all values +checkGrdTree' Empty unc = do + pure CheckResult + { cr_clauses = EmptyAnn + , cr_uncov = unc + , cr_approx = Precise } --- | Print diagnostic info and actually call 'pmCheck''. -pmCheck :: GrdVec -> [GrdVec] -> Int -> Delta -> DsM PartialResult -pmCheck ps guards n delta = do - tracePm "pmCheck {" $ vcat [ ppr n <> colon - , hang (text "patterns:") 2 (ppr ps) - , hang (text "guards:") 2 (ppr guards) - , ppr delta ] - res <- pmCheck' ps guards n delta - tracePm "}:" (ppr res) -- braces are easier to match by tooling +-- | Print diagnostic info and actually call 'checkGrdTree''. +checkGrdTree :: GrdTree -> Deltas -> DsM CheckResult +checkGrdTree guards deltas = do + tracePm "checkGrdTree {" $ vcat [ ppr guards + , ppr deltas ] + res <- checkGrdTree' guards deltas + tracePm "checkGrdTree }:" (ppr res) -- braces are easier to match by tooling return res --- | Lifts 'pmCheck' over a 'DsM (Maybe Delta)'. -pmCheckM :: GrdVec -> [GrdVec] -> Int -> DsM (Maybe Delta) -> DsM PartialResult -pmCheckM ps guards n m_mb_delta = m_mb_delta >>= \case - Nothing -> pure mempty - Just delta -> pmCheck ps guards n delta - --- | Check the list of mutually exclusive guards -pmCheckGuards :: [GrdVec] -> Int -> Delta -> DsM PartialResult -pmCheckGuards [] _ delta = return (usimple delta) -pmCheckGuards (gv:gvs) n delta = do - dflags <- getDynFlags - let limit = maxPmCheckModels dflags `div` 5 - (n', PartialResult cs unc ds pc) <- throttle limit (pmCheck gv []) n delta - (PartialResult css uncs dss pcs) <- runMany (pmCheckGuards gvs n') unc - return $ PartialResult (cs `mappend` css) - uncs - (ds `mappend` dss) - (pc `mappend` pcs) - --- | Matching function: Check simultaneously a clause (takes separately the --- patterns and the list of guards) for exhaustiveness, redundancy and --- inaccessibility. -pmCheck' - :: GrdVec -- ^ Patterns of the clause - -> [GrdVec] -- ^ (Possibly multiple) guards of the clause - -> Int -- ^ Estimate on the number of similar 'Delta's to handle. - -- See 6. in Note [Countering exponential blowup] - -> Delta -- ^ Oracle state giving meaning to the identifiers in the ValVec - -> DsM PartialResult -pmCheck' [] guards n delta - | null guards = return $ mempty { presultCovered = Covered } - | otherwise = pmCheckGuards guards n delta - --- let x = e: Add x ~ e to the oracle -pmCheck' (PmLet { pm_id = x, pm_let_expr = e } : ps) guards n delta = do - tracePm "PmLet" (vcat [ppr x, ppr e]) - -- x is fresh because it's bound by the let - delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e - pmCheck ps guards n delta' - --- Bang x: Add x /~ _|_ to the oracle -pmCheck' (PmBang x : ps) guards n delta = do - tracePm "PmBang" (ppr x) - pr <- pmCheckM ps guards n (addTmCt delta (TmVarNonVoid x)) - pure (forceIfCanDiverge delta x pr) - --- Con: Add x ~ K ys to the Covered set and x /~ K to the Uncovered set -pmCheck' (p : ps) guards n delta - | PmCon{ pm_id = x, pm_con_con = con, pm_con_args = args - , pm_con_dicts = dicts } <- p = do - -- E.g f (K p q) = - -- - -- Split delta into two refinements: - -- * one for , binding x to (K p q) - -- * one for , recording that x is /not/ (K _ _) - - -- Stuff for - pr_pos <- pmCheckM ps guards n (addPmConCts delta x con dicts args) - - -- The var is forced regardless of whether @con@ was satisfiable - -- See Note [Divergence of Newtype matches] - let pr_pos' = addConMatchStrictness delta x con pr_pos - - -- Stuff for - pr_neg <- addRefutableAltCon delta x con >>= \case - Nothing -> pure mempty - Just delta' -> pure (usimple delta') - - tracePm "PmCon" (vcat [ppr p, ppr x, ppr pr_pos', ppr pr_neg]) - - -- Combine both into a single PartialResult - let pr = mkUnion pr_pos' pr_neg - pure pr - -addPmConCts :: Delta -> Id -> PmAltCon -> [EvVar] -> [Id] -> DsM (Maybe Delta) -addPmConCts delta x con dicts fields = runMaybeT $ do - delta_ty <- MaybeT $ addTypeEvidence delta (listToBag dicts) - delta_tm_ty <- MaybeT $ addTmCt delta_ty (TmVarCon x con fields) - pure delta_tm_ty - -- ---------------------------------------------------------------------------- --- * Utilities for main checking - --- | Initialise with default values for covering and divergent information and --- a singleton uncovered set. -usimple :: Delta -> PartialResult -usimple delta = mempty { presultUncovered = [delta] } - --- | Get the union of two covered, uncovered and divergent value set --- abstractions. Since the covered and divergent sets are represented by a --- boolean, union means computing the logical or (at least one of the two is --- non-empty). - -mkUnion :: PartialResult -> PartialResult -> PartialResult -mkUnion = mappend - --- | Set the divergent set to not empty -forces :: PartialResult -> PartialResult -forces pres = pres { presultDivergent = Diverged } - --- | Set the divergent set to non-empty if the variable has not been forced yet -forceIfCanDiverge :: Delta -> Id -> PartialResult -> PartialResult -forceIfCanDiverge delta x - | canDiverge delta x = forces - | otherwise = id - --- | 'forceIfCanDiverge' if the 'PmAltCon' was not a Newtype. --- See Note [Divergence of Newtype matches]. -addConMatchStrictness :: Delta -> Id -> PmAltCon -> PartialResult -> PartialResult -addConMatchStrictness _ _ (PmAltConLike (RealDataCon dc)) res - | isNewTyCon (dataConTyCon dc) = res -addConMatchStrictness delta x _ res = forceIfCanDiverge delta x res - --- ---------------------------------------------------------------------------- -- * Propagation of term constraints inwards when checking nested matches {- Note [Type and Term Equality Propagation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When checking a match it would be great to have all type and term information available so we can get more precise results. For this reason we have functions -`addDictsDs' and `addTmVarCsDs' in DsMonad that store in the environment type and -term constraints (respectively) as we go deeper. +`addDictsDs' and `addTmVarCsDs' in GHC.HsToCore.Monad that store in the +environment type and term constraints (respectively) as we go deeper. The type constraints we propagate inwards are collected by `collectEvVarsPats' in GHC.Hs.Pat. This handles bug #4139 ( see example @@ -1143,22 +1030,34 @@ (_:_) -> True [] -> False -- can't happen -Functions `addScrutTmCs' and `addPatTmCs' are responsible for generating +Functions `addScrutTmCs' is responsible for generating these constraints. -} -locallyExtendPmDelta :: (Delta -> DsM (Maybe Delta)) -> DsM a -> DsM a -locallyExtendPmDelta ext k = getPmDelta >>= ext >>= \case - -- If adding a constraint would lead to a contradiction, don't add it. - -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@ - -- for why this is done. - Nothing -> k - Just delta' -> updPmDelta delta' k +-- | Locally update 'dsl_deltas' with the given action, but defer evaluation +-- with 'unsafeInterleaveM' in order not to do unnecessary work. +locallyExtendPmDelta :: (Deltas -> DsM Deltas) -> DsM a -> DsM a +locallyExtendPmDelta ext k = do + deltas <- getPmDeltas + deltas' <- unsafeInterleaveM $ do + deltas' <- ext deltas + inh <- isInhabited deltas' + -- If adding a constraint would lead to a contradiction, don't add it. + -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@ + -- for why this is done. + if inh + then pure deltas' + else pure deltas + updPmDeltas deltas' k --- | Add in-scope type constraints -addTyCsDs :: Bag EvVar -> DsM a -> DsM a -addTyCsDs ev_vars = - locallyExtendPmDelta (\delta -> addTypeEvidence delta ev_vars) +-- | Add in-scope type constraints if the coverage checker might run and then +-- run the given action. +addTyCsDs :: Origin -> Bag EvVar -> DsM a -> DsM a +addTyCsDs origin ev_vars m = do + dflags <- getDynFlags + applyWhen (needToRunPmCheck dflags origin) + (locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars))) + m -- | Add equalities for the scrutinee to the local 'DsM' environment when -- checking a case expression: @@ -1169,45 +1068,9 @@ addScrutTmCs Nothing _ k = k addScrutTmCs (Just scr) [x] k = do scr_e <- dsLExpr scr - locallyExtendPmDelta (\delta -> addVarCoreCt delta x scr_e) k + locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (unitBag (PmCoreCt x scr_e))) k addScrutTmCs _ _ _ = panic "addScrutTmCs: HsCase with more than one case binder" --- | Add equalities to the local 'DsM' environment when checking the RHS of a --- case expression: --- case e of x { p1 -> e1; ... pn -> en } --- When we go deeper to check e.g. e1 we record (x ~ p1). -addPatTmCs :: [Pat GhcTc] -- LHS (should have length 1) - -> [Id] -- MatchVars (should have length 1) - -> DsM a - -> DsM a --- Computes an approximation of the Covered set for p1 (which pmCheck currently --- discards). -addPatTmCs ps xs k = do - fam_insts <- dsGetFamInstEnvs - grds <- concat <$> zipWithM (translatePat fam_insts) xs ps - locallyExtendPmDelta (\delta -> computeCovered grds delta) k - --- | A dead simple version of 'pmCheck' that only computes the Covered set. --- So it only cares about collecting positive info. --- We use it to collect info from a pattern when we check its RHS. --- See 'addPatTmCs'. -computeCovered :: GrdVec -> Delta -> DsM (Maybe Delta) --- The duplication with 'pmCheck' is really unfortunate, but it's simpler than --- separating out the common cases with 'pmCheck', because that would make the --- ConVar case harder to understand. -computeCovered [] delta = pure (Just delta) -computeCovered (PmLet { pm_id = x, pm_let_expr = e } : ps) delta = do - delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e - computeCovered ps delta' -computeCovered (PmBang{} : ps) delta = do - computeCovered ps delta -computeCovered (p : ps) delta - | PmCon{ pm_id = x, pm_con_con = con, pm_con_args = args - , pm_con_dicts = dicts } <- p - = addPmConCts delta x con dicts args >>= \case - Nothing -> pure Nothing - Just delta' -> computeCovered ps delta' - {- %************************************************************************ %* * @@ -1235,45 +1098,95 @@ | otherwise = notNull (filter (`wopt` dflags) allPmCheckWarnings) +redundantAndInaccessibleRhss :: AnnotatedTree -> ([RhsInfo], [RhsInfo]) +redundantAndInaccessibleRhss tree = (fromOL ol_red, fromOL ol_inacc) + where + (_ol_acc, ol_inacc, ol_red) = go tree + -- | Collects RHSs which are + -- 1. accessible + -- 2. proper inaccessible (so we can't delete them) + -- 3. hypothetically redundant (so not only inaccessible RHS, but we can + -- even safely delete the equation without altering semantics) + -- See Note [Determining inaccessible clauses] + go :: AnnotatedTree -> (OrdList RhsInfo, OrdList RhsInfo, OrdList RhsInfo) + go (AccessibleRhs _ info) = (unitOL info, nilOL, nilOL) + go (InaccessibleRhs info) = (nilOL, nilOL, unitOL info) -- presumably redundant + go (MayDiverge t) = case go t of + -- See Note [Determining inaccessible clauses] + (acc, inacc, red) + | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL) + res -> res + go (SequenceAnn l r) = go l Semi.<> go r + go EmptyAnn = (nilOL, nilOL, nilOL) + +{- Note [Determining inaccessible clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f _ True = () + f () True = () + f _ _ = () +Is f's second clause redundant? The perhaps surprising answer is, no, it isn't! +@f (error "boom") False@ will force the error with clause 2, but will return +() if it was deleted, so clearly not redundant. Yet for now combination of +arguments we can ever reach clause 2's RHS, so we say it has inaccessible RHS +(as opposed to being completely redundant). + +We detect an inaccessible RHS simply by pretending it's redundant, until we see +that it's part of a sub-tree in the pattern match that forces some argument +(which corresponds to wrapping the 'AnnotatedTree' in 'MayDiverge'). Then we +turn all supposedly redundant RHSs into inaccessible ones. + +But as it turns out (@g@ from #17465) this is too conservative: + g () | False = () + | otherwise = () +g's first clause has an inaccessible RHS, but it's also safe to delete. So it's +redundant, really! But by just turning all redundant child clauses into +inaccessible ones, we report the first clause as inaccessible. + +Clearly, it is enough if we say that we only degrade if *not all* of the child +clauses are redundant. As long as there is at least one clause which we announce +not to be redundant, the guard prefix responsible for the 'MayDiverge' will +survive. Hence we check for that in 'redundantAndInaccessibleRhss'. +-} + -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility) -dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> PmResult -> DsM () -dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result +dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> CheckResult -> DsM () +dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result = when (flag_i || flag_u) $ do + unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered let exists_r = flag_i && notNull redundant - exists_i = flag_i && notNull inaccessible && not is_rec_upd - exists_u = flag_u && notNull uncovered + exists_i = flag_i && notNull inaccessible + exists_u = flag_u && notNull unc_examples approx = precision == Approximate when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_r $ forM_ redundant $ \(dL->L l q) -> do + when exists_r $ forM_ redundant $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant")) - when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do + when exists_i $ forM_ inaccessible $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) + when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $ - pprEqns vars uncovered + pprEqns vars unc_examples where - PmResult - { pmresultRedundant = redundant - , pmresultUncovered = uncovered - , pmresultInaccessible = inaccessible - , pmresultApproximate = precision } = pm_result + CheckResult + { cr_clauses = clauses + , cr_uncov = uncovered + , cr_approx = precision } = result + (redundant, inaccessible) = redundantAndInaccessibleRhss clauses - flag_i = wopt Opt_WarnOverlappingPatterns dflags + flag_i = overlapping dflags kind flag_u = exhaustive dflags kind flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind) - is_rec_upd = case kind of { RecUpd -> True; _ -> False } - -- See Note [Inaccessible warnings for record updates] - maxPatterns = maxUncoveredPatterns dflags -- Print a single clause (for redundant/with-inaccessible-rhs) pprEqn q txt = pprContext True ctx (text txt) $ \f -> - f (pprPats kind (map unLoc q)) + f (q <+> matchSeparator kind <+> text "...") -- Print several clauses (for uncovered clauses) pprEqns vars deltas = pprContext False ctx (text "are non-exhaustive") $ \_ -> @@ -1294,6 +1207,16 @@ $$ bullet <+> text "Patterns reported as unmatched might actually be matched") , text "Increase the limit or resolve the warnings to suppress this message." ] +getNFirstUncovered :: [Id] -> Int -> Deltas -> DsM [Delta] +getNFirstUncovered vars n (MkDeltas deltas) = go n (bagToList deltas) + where + go 0 _ = pure [] + go _ [] = pure [] + go n (delta:deltas) = do + front <- provideEvidence vars n delta + back <- go (n - length front) deltas + pure (front ++ back) + {- Note [Inaccessible warnings for record updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#12957) @@ -1314,6 +1237,17 @@ We don't want to warn about the inaccessible branch because the programmer didn't put it there! So we filter out the warning here. + +The same can happen for long distance term constraints instead of type +constraints (#17783): + + data T = A { x :: Int } | B { x :: Int } + f r@A{} = r { x = 3 } + f _ = B 0 + +Here, the long distance info from the FunRhs match (@r ~ A x@) will make the +clause matching on @B@ of the desugaring to @case@ redundant. It's generated +code that we don't want to warn about. -} dots :: Int -> [a] -> SDoc @@ -1330,6 +1264,12 @@ , Opt_WarnOverlappingPatterns ] +-- | Check whether the redundancy checker should run (redundancy only) +overlapping :: DynFlags -> HsMatchContext id -> Bool +-- See Note [Inaccessible warnings for record updates] +overlapping _ RecUpd = False +overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags + -- | Check whether the exhaustiveness checker should run (exhaustiveness only) exhaustive :: DynFlags -> HsMatchContext id -> Bool exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag @@ -1366,10 +1306,6 @@ (ppr_match, pref) = case kind of - FunRhs { mc_fun = (dL->L _ fun) } + FunRhs { mc_fun = L _ fun } -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) - -pprPats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc -pprPats kind pats - = sep [sep (map ppr pats), matchSeparator kind, text "..."] diff --git a/GHC/HsToCore/PmCheck/Oracle.hs b/GHC/HsToCore/PmCheck/Oracle.hs --- a/GHC/HsToCore/PmCheck/Oracle.hs +++ b/GHC/HsToCore/PmCheck/Oracle.hs @@ -7,97 +7,96 @@ {-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns, MultiWayIf #-} -- | The pattern match oracle. The main export of the module are the functions --- 'addTmCt', 'addVarCoreCt', 'addRefutableAltCon' and 'addTypeEvidence' for --- adding facts to the oracle, and 'provideEvidence' to turn a +-- 'addPmCts' for adding facts to the oracle, and 'provideEvidence' to turn a -- 'Delta' into a concrete evidence for an equation. module GHC.HsToCore.PmCheck.Oracle ( DsM, tracePm, mkPmId, - Delta, initDelta, lookupRefuts, lookupSolution, + Delta, initDeltas, lookupRefuts, lookupSolution, - TmCt(..), - addTypeEvidence, -- Add type equalities - addRefutableAltCon, -- Add a negative term equality - addTmCt, -- Add a positive term equality x ~ e - addVarCoreCt, -- Add a positive term equality x ~ core_expr + PmCt(PmTyCt), PmCts, pattern PmVarCt, pattern PmCoreCt, + pattern PmConCt, pattern PmNotConCt, pattern PmBotCt, + pattern PmNotBotCt, + + addPmCts, -- Add a constraint to the oracle. canDiverge, -- Try to add the term equality x ~ ⊥ - provideEvidence, + provideEvidence ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.PmCheck.Types -import DynFlags -import Outputable -import ErrUtils -import Util -import Bag -import UniqSet -import UniqDSet -import Unique -import Id -import VarEnv -import UniqDFM -import Var (EvVar) -import Name -import CoreSyn -import CoreFVs ( exprFreeVars ) -import CoreMap -import CoreOpt (simpleOptExpr, exprIsConApp_maybe) -import CoreUtils (exprType) -import MkCore (mkListExpr, mkCharExpr) -import UniqSupply -import FastString -import SrcLoc -import ListSetOps (unionLists) -import Maybes -import ConLike -import DataCon -import PatSyn -import TyCon -import TysWiredIn -import TysPrim (tYPETyCon) -import TyCoRep -import Type -import TcSimplify (tcNormalise, tcCheckSatisfiability) -import TcType (evVarPred) -import Unify (tcMatchTy) -import TcRnTypes (completeMatchConLikes) -import Coercion -import MonadUtils hiding (foldlM) -import DsMonad hiding (foldlM) -import FamInst -import FamInstEnv +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.DFM +import GHC.Types.Var (EvVar) +import GHC.Types.Name +import GHC.Core +import GHC.Core.FVs (exprFreeVars) +import GHC.Core.Map +import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) +import GHC.Core.Utils (exprType) +import GHC.Core.Make (mkListExpr, mkCharExpr) +import GHC.Types.Unique.Supply +import GHC.Data.FastString +import GHC.Types.SrcLoc +import GHC.Data.Maybe +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim (tYPETyCon) +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Tc.Solver (tcNormalise, tcCheckSatisfiability) +import GHC.Core.Unify (tcMatchTy) +import GHC.Tc.Types (completeMatchConLikes) +import GHC.Core.Coercion +import GHC.Utils.Monad hiding (foldlM) +import GHC.HsToCore.Monad hiding (foldlM) +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv -import Control.Monad (guard, mzero) +import Control.Monad (guard, mzero, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Data.Bifunctor (second) -import Data.Foldable (foldlM, minimumBy) +import Data.Either (partitionEithers) +import Data.Foldable (foldlM, minimumBy, toList) import Data.List (find) import qualified Data.List.NonEmpty as NonEmpty import Data.Ord (comparing) import qualified Data.Semigroup as Semigroup import Data.Tuple (swap) --- Debugging Infrastructre +-- Debugging Infrastructure tracePm :: String -> SDoc -> DsM () tracePm herald doc = do dflags <- getDynFlags printer <- mkPrintUnqualifiedDs liftIO $ dumpIfSet_dyn_printer printer dflags - Opt_D_dump_ec_trace (text herald $$ (nest 2 doc)) + Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) +{-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] -- | Generate a fresh `Id` of a given type mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" name = mkInternalName unique occname noSrcSpan - in return (mkLocalId name ty) + in return (mkLocalIdOrCoVar name Many ty) ----------------------------------------------- -- * Caching possible matches of a COMPLETE set @@ -113,9 +112,9 @@ -- | Instantiate a 'ConLike' given its universal type arguments. Instantiates -- existential and term binders with fresh variables of appropriate type. --- Returns instantiated term variables from the match, type evidence and the --- types of strict constructor fields. -mkOneConFull :: [Type] -> ConLike -> DsM ([Id], Bag TyCt, [Type]) +-- Returns instantiated type and term variables from the match, type evidence +-- and the types of strict constructor fields. +mkOneConFull :: [Type] -> ConLike -> DsM ([TyVar], [Id], Bag TyCt, [Type]) -- * 'con' K is a ConLike -- - In the case of DataCons and most PatSynCons, these -- are associated with a particular TyCon T @@ -133,24 +132,25 @@ -- be a concrete TyCon. -- -- Suppose y1 is a strict field. Then we get --- Results: [y1,..,yn] +-- Results: bs +-- [y1,..,yn] -- Q -- [s1] mkOneConFull arg_tys con = do - let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , field_tys, _con_res_ty) + let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta, field_tys, _con_res_ty) = conLikeFullSig con -- pprTrace "mkOneConFull" (ppr con $$ ppr arg_tys $$ ppr univ_tvs $$ ppr _con_res_ty) (return ()) -- Substitute universals for type arguments let subst_univ = zipTvSubst univ_tvs arg_tys - -- Instantiate fresh existentials as arguments to the contructor. This is + -- Instantiate fresh existentials as arguments to the constructor. This is -- important for instantiating the Thetas and field types. (subst, _) <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM - let field_tys' = substTys subst field_tys + let field_tys' = substTys subst $ map scaledThing field_tys -- Instantiate fresh term variables (VAs) as arguments to the constructor vars <- mapM mkPmId field_tys' -- All constraints bound by the constructor (alpha-renamed), these are added -- to the type oracle - let ty_cs = map TyCt (substTheta subst (eqSpecPreds eq_spec ++ thetas)) + let ty_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas) -- Figure out the types of strict constructor fields let arg_is_strict | RealDataCon dc <- con @@ -159,7 +159,7 @@ | otherwise = map isBanged $ conLikeImplBangs con strict_arg_tys = filterByList arg_is_strict field_tys' - return (vars, listToBag ty_cs, strict_arg_tys) + return (ex_tvs, vars, listToBag ty_cs, strict_arg_tys) ------------------------- -- * Pattern match oracle @@ -175,7 +175,7 @@ We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC used not to do this; in fact, it would warn that the match was /redundant/! This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the -coverage checker deems any matches with unsatifiable constraint sets to be +coverage checker deems any matches with unsatisfiable constraint sets to be unreachable. We decide to better than this. When beginning coverage checking, we first @@ -199,7 +199,7 @@ -- together as they see fit. newtype SatisfiabilityCheck = SC (Delta -> DsM (Maybe Delta)) --- | Check the given 'Delta' for satisfiability by the the given +-- | Check the given 'Delta' for satisfiability by the given -- 'SatisfiabilityCheck'. Return 'Just' a new, potentially extended, 'Delta' if -- successful, and 'Nothing' otherwise. runSatisfiabilityCheck :: Delta -> SatisfiabilityCheck -> DsM (Maybe Delta) @@ -233,14 +233,14 @@ pmIsSatisfiable :: Delta -- ^ The ambient term and type constraints -- (known to be satisfiable). - -> Bag TmCt -- ^ The new term constraints. -> Bag TyCt -- ^ The new type constraints. + -> Bag TmCt -- ^ The new term constraints. -> [Type] -- ^ The strict argument types. -> DsM (Maybe Delta) -- ^ @'Just' delta@ if the constraints (@delta@) are -- satisfiable, and each strict argument type is inhabitable. -- 'Nothing' otherwise. -pmIsSatisfiable amb_cs new_tm_cs new_ty_cs strict_arg_tys = +pmIsSatisfiable amb_cs new_ty_cs new_tm_cs strict_arg_tys = -- The order is important here! Check the new type constraints before we check -- whether strict argument types are inhabited given those constraints. runSatisfiabilityCheck amb_cs $ mconcat @@ -372,16 +372,9 @@ tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a) tyFamStepper env rec_nts tc tys -- Try to step a type/data family - = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in - -- NB: It's OK to use normaliseTcArgs here instead of - -- normalise_tc_args (which takes the LiftingContext described - -- in Note [Normalising types]) because the reduceTyFamApp below - -- works only at top level. We'll never recur in this function - -- after reducing the kind of a bound tyvar. - - case reduceTyFamApp_maybe env Representational tc ntys of - Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id) - _ -> NS_Done + = case topReduceTyFamApp_maybe env tc tys of + Just (_, rhs, _) -> NS_Step rec_nts rhs ((rhs:), id) + _ -> NS_Done -- | Returns 'True' if the argument 'Type' is a fully saturated application of -- a closed type constructor. @@ -439,7 +432,7 @@ newtypes. (b) dcs is the list of newtype constructors "skipped", every time we normalise a newtype to its core representation, we keep track of the source data - constructor. For convenienve, we also track the type we unwrap and the + constructor. For convenience, we also track the type we unwrap and the type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)] (c) core_ty is the rewritten type. That is, pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty) @@ -495,32 +488,23 @@ ---------------- -- * Type oracle --- | Wraps a 'PredType', which is a constraint type. -newtype TyCt = TyCt PredType - -instance Outputable TyCt where - ppr (TyCt pred_ty) = ppr pred_ty - --- | Allocates a fresh 'EvVar' name for 'PredTyCt's, or simply returns the --- wrapped 'EvVar' for 'EvVarTyCt's. -nameTyCt :: TyCt -> DsM EvVar -nameTyCt (TyCt pred_ty) = do +-- | Allocates a fresh 'EvVar' name for 'PredTy's. +nameTyCt :: PredType -> DsM EvVar +nameTyCt pred_ty = do unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) idname = mkInternalName unique occname noSrcSpan - return (mkLocalId idname pred_ty) + return (mkLocalIdOrCoVar idname Many pred_ty) -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we -- find a contradiction (e.g. @Int ~ Bool@). -tyOracle :: TyState -> Bag TyCt -> DsM (Maybe TyState) +tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState) tyOracle (TySt inert) cts = do { evs <- traverse nameTyCt cts ; let new_inert = inert `unionBags` evs ; tracePm "tyOracle" (ppr cts) ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability new_inert ; case res of - -- Note how this implicitly gives all former PredTyCts a name, so - -- that we don't needlessly re-allocate them every time! Just True -> return (Just (TySt new_inert)) Just False -> return Nothing Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) } @@ -530,7 +514,7 @@ -- ones. Doesn't bother calling out to the type oracle if the bag of new type -- constraints was empty. Will only recheck 'PossibleMatches' in the term oracle -- for emptiness if the first argument is 'True'. -tyIsSatisfiable :: Bool -> Bag TyCt -> SatisfiabilityCheck +tyIsSatisfiable :: Bool -> Bag PredType -> SatisfiabilityCheck tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \delta -> if isEmptyBag new_ty_cs then pure (Just delta) @@ -562,7 +546,7 @@ Invariant applying to each VarInfo: Whenever we have @(C, [y,z])@ in 'vi_pos', any entry in 'vi_neg' must be incomparable to C (return Nothing) according to 'eqPmAltCons'. Those entries that are comparable either lead to a refutation -or are redudant. Examples: +or are redundant. Examples: * @x ~ Just y@, @x /~ [Just]@. 'eqPmAltCon' returns @Equal@, so refute. * @x ~ Nothing@, @x /~ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative info is redundant and should be discarded. @@ -608,29 +592,26 @@ detect this, but we could just compare whole COMPLETE sets to vi_neg every time, if it weren't for performance. -Maintaining these invariants in 'addVarVarCt' (the core of the term oracle) and -'addRefutableAltCon' is subtle. +Maintaining these invariants in 'addVarCt' (the core of the term oracle) and +'addNotConCt' is subtle. * Merging VarInfos. Example: Add the fact @x ~ y@ (see 'equate'). - (COMPLETE) If we had @x /~ True@ and @y /~ False@, then we get @x /~ [True,False]@. This is vacuous by matter of comparing to the built-in COMPLETE set, so should refute. - (Pos/Neg) If we had @x /~ True@ and @y ~ True@, we have to refute. -* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addVarConCt') +* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addConCt') - (Neg) If we had @x /~ K@, refute. - (Pos) If we had @x ~ K2@, and that contradicts the new solution according to 'eqPmAltCon' (ex. K2 is [] and K is (:)), then refute. - (Refine) If we had @x /~ K zs@, unify each y with each z in turn. -* Adding negative information. Example: Add the fact @x /~ Nothing@ (see 'addRefutableAltCon') +* Adding negative information. Example: Add the fact @x /~ Nothing@ (see 'addNotConCt') - (Refut) If we have @x ~ K ys@, refute. - - (Redundant) If we have @x ~ K2@ and @eqPmAltCon K K2 == Disjoint@ - (ex. Just and Nothing), the info is redundant and can be - discarded. - (COMPLETE) If K=Nothing and we had @x /~ Just@, then we get @x /~ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in COMPLETE set, so should refute. -Note that merging VarInfo in equate can be done by calling out to 'addVarConCt' and -'addRefutableAltCon' for each of the facts individually. +Note that merging VarInfo in equate can be done by calling out to 'addConCt' and +'addNotConCt' for each of the facts individually. Note [Representation of Strings in TmState] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -658,15 +639,13 @@ -- Returns a new 'Delta' if the new constraints are compatible with existing -- ones. tmIsSatisfiable :: Bag TmCt -> SatisfiabilityCheck -tmIsSatisfiable new_tm_cs = SC $ \delta -> runMaybeT $ foldlM go delta new_tm_cs - where - go delta ct = MaybeT (addTmCt delta ct) +tmIsSatisfiable new_tm_cs = SC $ \delta -> runMaybeT $ foldlM addTmCt delta new_tm_cs ----------------------- -- * Looking up VarInfo emptyVarInfo :: Id -> VarInfo -emptyVarInfo x = VI (idType x) [] [] NoPM +emptyVarInfo x = VI (idType x) [] emptyPmAltConSet NoPM lookupVarInfo :: TmState -> Id -> VarInfo -- (lookupVarInfo tms x) tells what we know about 'x' @@ -742,7 +721,7 @@ inefficient. So in fact, we just *drop* the coercion arising from the CoPat when handling -handling the constraint @y ~ x |> co@ in addVarCoreCt, just equating @y ~ x@. +handling the constraint @y ~ x |> co@ in addCoreCt, just equating @y ~ x@. We then handle the fallout in initPossibleMatches, which has to get a hand at both the representation TyCon tc_rep and the parent data family TyCon tc_fam. It considers three cases after having established that the Type is a TyConApp: @@ -765,9 +744,9 @@ canDiverge :: Delta -> Id -> Bool canDiverge delta@MkDelta{ delta_tm_st = ts } x | VI _ pos neg _ <- lookupVarInfo ts x - = null neg && all pos_can_diverge pos + = isEmptyPmAltConSet neg && all pos_can_diverge pos where - pos_can_diverge (PmAltConLike (RealDataCon dc), [y]) + pos_can_diverge (PmAltConLike (RealDataCon dc), _, [y]) -- See Note [Divergence of Newtype matches] | isNewTyCon (dataConTyCon dc) = canDiverge delta y pos_can_diverge _ = False @@ -789,8 +768,8 @@ If we treat Newtypes like we treat regular DataCons, we would mark the third clause as redundant, which clearly is unsound. The solution: -1. When checking the PmCon in 'pmCheck', never mark the result as Divergent if - it's a Newtype match. +1. When compiling the PmCon guard in 'pmCompileTree', don't add a @DivergeIf@, + because the match will never diverge. 2. Regard @T2 x@ as 'canDiverge' iff @x@ 'canDiverge'. E.g. @T2 x ~ _|_@ <=> @x ~ _|_@. This way, the third clause will still be marked as inaccessible RHS instead of redundant. @@ -802,18 +781,18 @@ -- Unfortunately we need the extra bit of polymorphism and the unfortunate -- duplication of lookupVarInfo here. lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k = - case lookupUDFM env k of + case lookupUDFM_Directly env (getUnique k) of Nothing -> [] - Just (Indirect y) -> vi_neg (lookupVarInfo ts y) - Just (Entry vi) -> vi_neg vi + Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y)) + Just (Entry vi) -> pmAltConSetElems (vi_neg vi) -isDataConSolution :: (PmAltCon, [Id]) -> Bool -isDataConSolution (PmAltConLike (RealDataCon _), _) = True -isDataConSolution _ = False +isDataConSolution :: (PmAltCon, [TyVar], [Id]) -> Bool +isDataConSolution (PmAltConLike (RealDataCon _), _, _) = True +isDataConSolution _ = False -- @lookupSolution delta x@ picks a single solution ('vi_pos') of @x@ from -- possibly many, preferring 'RealDataCon' solutions whenever possible. -lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [Id]) +lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [TyVar], [Id]) lookupSolution delta x = case vi_pos (lookupVarInfo (delta_tm_st delta) x) of [] -> Nothing pos @@ -823,48 +802,132 @@ ------------------------------- -- * Adding facts to the oracle --- | A term constraint. Either equates two variables or a variable with a --- 'PmAltCon' application. +-- | A term constraint. data TmCt - = TmVarVar !Id !Id - | TmVarCon !Id !PmAltCon ![Id] - | TmVarNonVoid !Id + = TmVarCt !Id !Id + -- ^ @TmVarCt x y@ encodes "x ~ y", equating @x@ and @y@. + | TmCoreCt !Id !CoreExpr + -- ^ @TmCoreCt x e@ encodes "x ~ e", equating @x@ with the 'CoreExpr' @e@. + | TmConCt !Id !PmAltCon ![TyVar] ![Id] + -- ^ @TmConCt x K tvs ys@ encodes "x ~ K @tvs ys", equating @x@ with the 'PmAltCon' + -- application @K @tvs ys@. + | TmNotConCt !Id !PmAltCon + -- ^ @TmNotConCt x K@ encodes "x /~ K", asserting that @x@ can't be headed + -- by @K@. + | TmBotCt !Id + -- ^ @TmBotCt x@ encodes "x ~ ⊥", equating @x@ to ⊥. + -- by @K@. + | TmNotBotCt !Id + -- ^ @TmNotBotCt x y@ encodes "x /~ ⊥", asserting that @x@ can't be ⊥. instance Outputable TmCt where - ppr (TmVarVar x y) = ppr x <+> char '~' <+> ppr y - ppr (TmVarCon x con args) = ppr x <+> char '~' <+> hsep (ppr con : map ppr args) - ppr (TmVarNonVoid x) = ppr x <+> text "/~ ⊥" + ppr (TmVarCt x y) = ppr x <+> char '~' <+> ppr y + ppr (TmCoreCt x e) = ppr x <+> char '~' <+> ppr e + ppr (TmConCt x con tvs args) = ppr x <+> char '~' <+> hsep (ppr con : pp_tvs ++ pp_args) + where + pp_tvs = map ((<> char '@') . ppr) tvs + pp_args = map ppr args + ppr (TmNotConCt x con) = ppr x <+> text "/~" <+> ppr con + ppr (TmBotCt x) = ppr x <+> text "~ ⊥" + ppr (TmNotBotCt x) = ppr x <+> text "/~ ⊥" --- | Add type equalities to 'Delta'. -addTypeEvidence :: Delta -> Bag EvVar -> DsM (Maybe Delta) -addTypeEvidence delta dicts - = runSatisfiabilityCheck delta (tyIsSatisfiable True (TyCt . evVarPred <$> dicts)) +type TyCt = PredType --- | Tries to equate two representatives in 'Delta'. +-- | An oracle constraint. +data PmCt + = PmTyCt !TyCt + -- ^ @PmTy pred_ty@ carries 'PredType's, for example equality constraints. + | PmTmCt !TmCt + -- ^ A term constraint. + +type PmCts = Bag PmCt + +pattern PmVarCt :: Id -> Id -> PmCt +pattern PmVarCt x y = PmTmCt (TmVarCt x y) +pattern PmCoreCt :: Id -> CoreExpr -> PmCt +pattern PmCoreCt x e = PmTmCt (TmCoreCt x e) +pattern PmConCt :: Id -> PmAltCon -> [TyVar] -> [Id] -> PmCt +pattern PmConCt x con tvs args = PmTmCt (TmConCt x con tvs args) +pattern PmNotConCt :: Id -> PmAltCon -> PmCt +pattern PmNotConCt x con = PmTmCt (TmNotConCt x con) +pattern PmBotCt :: Id -> PmCt +pattern PmBotCt x = PmTmCt (TmBotCt x) +pattern PmNotBotCt :: Id -> PmCt +pattern PmNotBotCt x = PmTmCt (TmNotBotCt x) +{-# COMPLETE PmTyCt, PmVarCt, PmCoreCt, PmConCt, PmNotConCt, PmBotCt, PmNotBotCt #-} + +instance Outputable PmCt where + ppr (PmTyCt pred_ty) = ppr pred_ty + ppr (PmTmCt tm_ct) = ppr tm_ct + +-- | Adds new constraints to 'Delta' and returns 'Nothing' if that leads to a +-- contradiction. +addPmCts :: Delta -> PmCts -> DsM (Maybe Delta) -- See Note [TmState invariants]. -addTmCt :: Delta -> TmCt -> DsM (Maybe Delta) -addTmCt delta ct = runMaybeT $ case ct of - TmVarVar x y -> addVarVarCt delta (x, y) - TmVarCon x con args -> addVarConCt delta x con args - TmVarNonVoid x -> addVarNonVoidCt delta x +addPmCts delta cts = do + let (ty_cts, tm_cts) = partitionTyTmCts cts + runSatisfiabilityCheck delta $ mconcat + [ tyIsSatisfiable True (listToBag ty_cts) + , tmIsSatisfiable (listToBag tm_cts) + ] --- | Record that a particular 'Id' can't take the shape of a 'PmAltCon' in the --- 'Delta' and return @Nothing@ if that leads to a contradiction. +partitionTyTmCts :: PmCts -> ([TyCt], [TmCt]) +partitionTyTmCts = partitionEithers . map to_either . toList + where + to_either (PmTyCt pred_ty) = Left pred_ty + to_either (PmTmCt tm_ct) = Right tm_ct + +-- | Adds a single term constraint by dispatching to the various term oracle +-- functions. +addTmCt :: Delta -> TmCt -> MaybeT DsM Delta +addTmCt delta (TmVarCt x y) = addVarCt delta x y +addTmCt delta (TmCoreCt x e) = addCoreCt delta x e +addTmCt delta (TmConCt x con tvs args) = addConCt delta x con tvs args +addTmCt delta (TmNotConCt x con) = addNotConCt delta x con +addTmCt delta (TmBotCt x) = addBotCt delta x +addTmCt delta (TmNotBotCt x) = addNotBotCt delta x + +-- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ +-- surely diverges. +-- +-- Only that's a lie, because we don't currently preserve the fact in 'Delta' +-- after we checked compatibility. See Note [Preserving TmBotCt] +addBotCt :: Delta -> Id -> MaybeT DsM Delta +addBotCt delta x + | canDiverge delta x = pure delta + | otherwise = mzero + +{- Note [Preserving TmBotCt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whenever we add a new constraint to 'Delta' via 'addTmCt', we want to check it +for compatibility with existing constraints in the modeled indert set and then +add it the constraint itself to the inert set. +For a 'TmBotCt' @x ~ ⊥@ we don't actually add it to the inert set after checking +it for compatibility with 'Delta'. +And that is fine in the context of the patter-match checking algorithm! +Whenever we add a 'TmBotCt' (we only do so for checking divergence of bang +patterns and strict constructor matches), we don't add any more constraints to +the inert set afterwards, so we don't need to preserve it. +-} + +-- | Record a @x ~/ K@ constraint, e.g. that a particular 'Id' @x@ can't +-- take the shape of a 'PmAltCon' @K@ in the 'Delta' and return @Nothing@ if +-- that leads to a contradiction. -- See Note [TmState invariants]. -addRefutableAltCon :: Delta -> Id -> PmAltCon -> DsM (Maybe Delta) -addRefutableAltCon delta@MkDelta{ delta_tm_st = TmSt env reps } x nalt = runMaybeT $ do +addNotConCt :: Delta -> Id -> PmAltCon -> MaybeT DsM Delta +addNotConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x nalt = do vi@(VI _ pos neg pm) <- lift (initLookupVarInfo delta x) -- 1. Bail out quickly when nalt contradicts a solution - let contradicts nalt (cl, _args) = eqPmAltCon cl nalt == Equal + let contradicts nalt (cl, _tvs, _args) = eqPmAltCon cl nalt == Equal guard (not (any (contradicts nalt) pos)) -- 2. Only record the new fact when it's not already implied by one of the -- solutions - let implies nalt (cl, _args) = eqPmAltCon cl nalt == Disjoint + let implies nalt (cl, _tvs, _args) = eqPmAltCon cl nalt == Disjoint let neg' | any (implies nalt) pos = neg -- See Note [Completeness checking with required Thetas] | hasRequiredTheta nalt = neg - | otherwise = unionLists neg [nalt] + | otherwise = extendPmAltConSet neg nalt let vi_ext = vi{ vi_neg = neg' } -- 3. Make sure there's at least one other possible constructor vi' <- case nalt of @@ -896,7 +959,7 @@ hidden parameter which must be supplied at the pattern match site, so PRead is much more like a view pattern (where behavior depends on the particular value passed in). -The simple solution here is to forget in 'addRefutableAltCon' that we matched +The simple solution here is to forget in 'addNotConCt' that we matched on synonyms with a required Theta like @PRead@, so that subsequent matches on the same constructor are never flagged as redundant. The consequence is that we no longer detect the actually redundant match in @@ -912,7 +975,7 @@ -- | Guess the universal argument types of a ConLike from an instantiation of -- its result type. Rather easy for DataCons, but not so much for PatSynCons. --- See Note [Pattern synonym result type] in PatSyn.hs. +-- See Note [Pattern synonym result type] in "GHC.Core.PatSyn". guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type] guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do (tc, tc_args) <- splitTyConApp_maybe res_ty @@ -924,7 +987,7 @@ guessConLikeUnivTyArgsFromResTy _ res_ty (PatSynCon ps) = do -- We are successful if we managed to instantiate *every* univ_tv of con. -- This is difficult and bound to fail in some cases, see - -- Note [Pattern synonym result type] in PatSyn.hs. So we just try our best + -- Note [Pattern synonym result type] in GHC.Core.PatSyn. So we just try our best -- here and be sure to return an instantiation when we can substitute every -- universally quantified type variable. -- We *could* instantiate all the other univ_tvs just to fresh variables, I @@ -934,11 +997,13 @@ subst <- tcMatchTy con_res_ty res_ty traverse (lookupTyVar subst) univ_tvs --- | Kind of tries to add a non-void contraint to 'Delta', but doesn't really --- commit to upholding that constraint in the future. This will be rectified --- in a follow-up patch. The status quo should work good enough for now. -addVarNonVoidCt :: Delta -> Id -> MaybeT DsM Delta -addVarNonVoidCt delta@MkDelta{ delta_tm_st = TmSt env reps } x = do +-- | Adds the constraint @x ~/ ⊥@ to 'Delta'. +-- +-- But doesn't really commit to upholding that constraint in the future. This +-- will be rectified in a follow-up patch. The status quo should work good +-- enough for now. +addNotBotCt :: Delta -> Id -> MaybeT DsM Delta +addNotBotCt delta@MkDelta{ delta_tm_st = TmSt env reps } x = do vi <- lift $ initLookupVarInfo delta x vi' <- MaybeT $ ensureInhabited delta vi -- vi' has probably constructed and then thinned out some PossibleMatches. @@ -984,7 +1049,7 @@ case guessConLikeUnivTyArgsFromResTy env (vi_ty vi) con of Nothing -> pure True -- be conservative about this Just arg_tys -> do - (_vars, ty_cs, strict_arg_tys) <- mkOneConFull arg_tys con + (_tvs, _vars, ty_cs, strict_arg_tys) <- mkOneConFull arg_tys con tracePm "inh_test" (ppr con $$ ppr ty_cs) -- No need to run the term oracle compared to pmIsSatisfiable fmap isJust <$> runSatisfiabilityCheck delta $ mconcat @@ -1009,15 +1074,16 @@ -------------------------------------- -- * Term oracle unification procedure --- | Try to unify two 'Id's and record the gained knowledge in 'Delta'. +-- | Adds a @x ~ y@ constraint by trying to unify two 'Id's and record the +-- gained knowledge in 'Delta'. -- -- Returns @Nothing@ when there's a contradiction. Returns @Just delta@ -- when the constraint was compatible with prior facts, in which case @delta@ -- has integrated the knowledge from the equality constraint. -- -- See Note [TmState invariants]. -addVarVarCt :: Delta -> (Id, Id) -> MaybeT DsM Delta -addVarVarCt delta@MkDelta{ delta_tm_st = TmSt env _ } (x, y) +addVarCt :: Delta -> Id -> Id -> MaybeT DsM Delta +addVarCt delta@MkDelta{ delta_tm_st = TmSt env _ } x y -- It's important that we never @equate@ two variables of the same equivalence -- class, otherwise we might get cyclic substitutions. -- Cf. 'extendSubstAndSolve' and @@ -1049,41 +1115,53 @@ let env_refs = setEntrySDIE env_ind y vi_y let delta_refs = delta{ delta_tm_st = TmSt env_refs reps } -- and then gradually merge every positive fact we have on x into y - let add_fact delta (cl, args) = addVarConCt delta y cl args + let add_fact delta (cl, tvs, args) = addConCt delta y cl tvs args delta_pos <- foldlM add_fact delta_refs (vi_pos vi_x) -- Do the same for negative info - let add_refut delta nalt = MaybeT (addRefutableAltCon delta y nalt) - delta_neg <- foldlM add_refut delta_pos (vi_neg vi_x) - -- vi_cache will be updated in addRefutableAltCon, so we are good to + let add_refut delta nalt = addNotConCt delta y nalt + delta_neg <- foldlM add_refut delta_pos (pmAltConSetElems (vi_neg vi_x)) + -- vi_cache will be updated in addNotConCt, so we are good to -- go! pure delta_neg --- | @addVarConCt x alt args ts@ extends the substitution with a solution --- @x :-> (alt, args)@ if compatible with refutable shapes of @x@ and its --- other solutions, reject (@Nothing@) otherwise. +-- | Add a @x ~ K tvs args ts@ constraint. +-- @addConCt x K tvs args ts@ extends the substitution with a solution +-- @x :-> (K, tvs, args)@ if compatible with the negative and positive info we +-- have on @x@, reject (@Nothing@) otherwise. -- -- See Note [TmState invariants]. -addVarConCt :: Delta -> Id -> PmAltCon -> [Id] -> MaybeT DsM Delta -addVarConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt args = do +addConCt :: Delta -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Delta +addConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt tvs args = do VI ty pos neg cache <- lift (initLookupVarInfo delta x) -- First try to refute with a negative fact - guard (all ((/= Equal) . eqPmAltCon alt) neg) + guard (not (elemPmAltConSet alt neg)) -- Then see if any of the other solutions (remember: each of them is an -- additional refinement of the possible values x could take) indicate a -- contradiction - guard (all ((/= Disjoint) . eqPmAltCon alt . fst) pos) - -- Now we should be good! Add (alt, args) as a possible solution, or refine an - -- existing one - case find ((== Equal) . eqPmAltCon alt . fst) pos of - Just (_, other_args) -> do - foldlM addVarVarCt delta (zip args other_args) + guard (all ((/= Disjoint) . eqPmAltCon alt . fstOf3) pos) + -- Now we should be good! Add (alt, tvs, args) as a possible solution, or + -- refine an existing one + case find ((== Equal) . eqPmAltCon alt . fstOf3) pos of + Just (_con, other_tvs, other_args) -> do + -- We must unify existentially bound ty vars and arguments! + let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs) + when (length args /= length other_args) $ + lift $ tracePm "error" (ppr x <+> ppr alt <+> ppr args <+> ppr other_args) + let tm_cts = zipWithEqual "addConCt" PmVarCt args other_args + MaybeT $ addPmCts delta (listToBag ty_cts `unionBags` listToBag tm_cts) Nothing -> do - -- Filter out redundant negative facts (those that compare Just False to - -- the new solution) - let neg' = filter ((== PossiblyOverlap) . eqPmAltCon alt) neg - let pos' = (alt,args):pos - pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg' cache)) reps} + let pos' = (alt, tvs, args):pos + pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg cache)) reps} +equateTys :: [Type] -> [Type] -> [PmCt] +equateTys ts us = + [ PmTyCt (mkPrimEqPred t u) + | (t, u) <- zipEqual "equateTys" ts us + -- The following line filters out trivial Refl constraints, so that we don't + -- need to initialise the type oracle that often + , not (eqType t u) + ] + ---------------------------------------- -- * Enumerating inhabitation candidates @@ -1095,16 +1173,14 @@ -- See @Note [Strict argument type constraints]@. data InhabitationCandidate = InhabitationCandidate - { ic_tm_cs :: Bag TmCt - , ic_ty_cs :: Bag TyCt + { ic_cs :: PmCts , ic_strict_arg_tys :: [Type] } instance Outputable InhabitationCandidate where - ppr (InhabitationCandidate tm_cs ty_cs strict_arg_tys) = + ppr (InhabitationCandidate cs strict_arg_tys) = text "InhabitationCandidate" <+> - vcat [ text "ic_tm_cs =" <+> ppr tm_cs - , text "ic_ty_cs =" <+> ppr ty_cs + vcat [ text "ic_cs =" <+> ppr cs , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ] mkInhabitationCandidate :: Id -> DataCon -> DsM InhabitationCandidate @@ -1112,10 +1188,9 @@ mkInhabitationCandidate x dc = do let cl = RealDataCon dc let tc_args = tyConAppArgs (idType x) - (arg_vars, ty_cs, strict_arg_tys) <- mkOneConFull tc_args cl + (ty_vars, arg_vars, ty_cs, strict_arg_tys) <- mkOneConFull tc_args cl pure InhabitationCandidate - { ic_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars) - , ic_ty_cs = ty_cs + { ic_cs = PmTyCt <$> ty_cs `snocBag` PmConCt x (PmAltConLike cl) ty_vars arg_vars , ic_strict_arg_tys = strict_arg_tys } @@ -1133,13 +1208,15 @@ NormalisedByConstraints ty' -> alts_to_check ty' ty' [] HadRedexes src_ty dcs core_ty -> alts_to_check src_ty core_ty dcs where - build_newtype :: (Type, DataCon, Type) -> Id -> DsM (Id, TmCt) + build_newtype :: (Type, DataCon, Type) -> Id -> DsM (Id, PmCt) build_newtype (ty, dc, _arg_ty) x = do -- ty is the type of @dc x@. It's a @dataConTyCon dc@ application. y <- mkPmId ty - pure (y, TmVarCon y (PmAltConLike (RealDataCon dc)) [x]) + -- Newtypes don't have existentials (yet?!), so passing an empty list as + -- ex_tvs. + pure (y, PmConCt y (PmAltConLike (RealDataCon dc)) [] [x]) - build_newtypes :: Id -> [(Type, DataCon, Type)] -> DsM (Id, [TmCt]) + build_newtypes :: Id -> [(Type, DataCon, Type)] -> DsM (Id, [PmCt]) build_newtypes x = foldrM (\dc (x, cts) -> go dc x cts) (x, []) where go dc x cts = second (:cts) <$> build_newtype dc x @@ -1155,8 +1232,8 @@ (_:_) -> do inner <- mkPmId core_ty (outer, new_tm_cts) <- build_newtypes inner dcs return $ Right (tc, outer, [InhabitationCandidate - { ic_tm_cs = listToBag new_tm_cts - , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }]) + { ic_cs = listToBag new_tm_cts + , ic_strict_arg_tys = [] }]) | pmIsClosedType core_ty && not (isAbstractTyCon tc) -- Don't consider abstract tycons since we don't know what their @@ -1165,8 +1242,8 @@ -> do inner <- mkPmId core_ty -- it would be wrong to unify inner alts <- mapM (mkInhabitationCandidate inner) (tyConDataCons tc) - (outer, new_tm_cts) <- build_newtypes inner dcs - let wrap_dcs alt = alt{ ic_tm_cs = listToBag new_tm_cts `unionBags` ic_tm_cs alt} + (outer, new_cts) <- build_newtypes inner dcs + let wrap_dcs alt = alt{ ic_cs = listToBag new_cts `unionBags` ic_cs alt} return $ Right (tc, outer, map wrap_dcs alts) -- For other types conservatively assume that they are inhabited. _other -> return (Left src_ty) @@ -1192,7 +1269,7 @@ we do the following: 1. We normalise the outermost type family redex, data family redex or newtype, - using pmTopNormaliseType (in types/FamInstEnv.hs). This computes 3 + using pmTopNormaliseType (in "GHC.Core.FamInstEnv"). This computes 3 things: (a) A normalised type src_ty, which is equal to the type of the scrutinee in source Haskell (does not normalise newtypes or data families) @@ -1207,7 +1284,7 @@ newtype rewrite performed in (b). For an example see also Note [Type normalisation] - in types/FamInstEnv.hs. + in "GHC.Core.FamInstEnv". 2. Function Check.checkEmptyCase' performs the check: - If core_ty is not an algebraic type, then we cannot check for @@ -1280,12 +1357,12 @@ cand_is_inhabitable :: RecTcChecker -> Delta -> InhabitationCandidate -> DsM Bool cand_is_inhabitable rec_ts amb_cs - (InhabitationCandidate{ ic_tm_cs = new_tm_cs - , ic_ty_cs = new_ty_cs - , ic_strict_arg_tys = new_strict_arg_tys }) = + (InhabitationCandidate{ ic_cs = new_cs + , ic_strict_arg_tys = new_strict_arg_tys }) = do + let (new_ty_cs, new_tm_cs) = partitionTyTmCts new_cs fmap isJust $ runSatisfiabilityCheck amb_cs $ mconcat - [ tyIsSatisfiable False new_ty_cs - , tmIsSatisfiable new_tm_cs + [ tyIsSatisfiable False (listToBag new_ty_cs) + , tmIsSatisfiable (listToBag new_tm_cs) , tysAreNonVoid rec_ts new_strict_arg_tys ] @@ -1343,7 +1420,7 @@ `nonVoid ty` returns True when either: 1. `ty` has at least one InhabitationCandidate for which both its term and type - constraints are satifiable, and `nonVoid` returns `True` for all of the + constraints are satisfiable, and `nonVoid` returns `True` for all of the strict argument types in that InhabitationCandidate. 2. We're unsure if it's inhabited by a terminating value. @@ -1482,12 +1559,12 @@ -- where @x@ will have two possibly compatible solutions, @Just y@ for -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@ -- and @z@ that is valid at the same time. These constitute arg_vas below. - let arg_vas = concatMap (\(_cl, args) -> args) pos + let arg_vas = concatMap (\(_cl, _tvs, args) -> args) pos go (arg_vas ++ xs) n delta [] -- When there are literals involved, just print negative info -- instead of listing missed constructors - | notNull [ l | PmAltLit l <- neg ] + | notNull [ l | PmAltLit l <- pmAltConSetElems neg ] -> go xs n delta [] -> try_instantiate x xs n delta @@ -1500,7 +1577,9 @@ (_src_ty, dcs, core_ty) <- tntrGuts <$> pmTopNormaliseType (delta_ty_st delta) (idType x) let build_newtype (x, delta) (_ty, dc, arg_ty) = do y <- lift $ mkPmId arg_ty - delta' <- addVarConCt delta x (PmAltConLike (RealDataCon dc)) [y] + -- Newtypes don't have existentials (yet?!), so passing an empty + -- list as ex_tvs. + delta' <- addConCt delta x (PmAltConLike (RealDataCon dc)) [] [y] pure (y, delta') runMaybeT (foldlM build_newtype (x, delta) dcs) >>= \case Nothing -> pure [] @@ -1525,12 +1604,12 @@ instantiate_cons x ty xs n delta (cl:cls) = do env <- dsGetFamInstEnvs case guessConLikeUnivTyArgsFromResTy env ty cl of - Nothing -> pure [delta] -- No idea idea how to refine this one, so just finish off with a wildcard + Nothing -> pure [delta] -- No idea how to refine this one, so just finish off with a wildcard Just arg_tys -> do - (arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl - let new_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars) + (tvs, arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl + let new_tm_cs = unitBag (TmConCt x (PmAltConLike cl) tvs arg_vars) -- Now check satifiability - mb_delta <- pmIsSatisfiable delta new_tm_cs new_ty_cs strict_arg_tys + mb_delta <- pmIsSatisfiable delta new_ty_cs new_tm_cs strict_arg_tys tracePm "instantiate_cons" (vcat [ ppr x , ppr (idType x) , ppr ty @@ -1559,27 +1638,37 @@ tracePm "pickMinimalCompleteSet" (ppr $ NonEmpty.toList clss) pure (Just (minimumBy (comparing sizeUniqDSet) clss)) --- | See if we already encountered a semantically equivalent expression and --- return its representative. +-- | Finds a representant of the semantic equality class of the given @e@. +-- Which is the @x@ of a @let x = e'@ constraint (with @e@ semantically +-- equivalent to @e'@) we encountered earlier, or a fresh identifier if +-- there weren't any such constraints. representCoreExpr :: Delta -> CoreExpr -> DsM (Delta, Id) -representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e = do - dflags <- getDynFlags - let e' = simpleOptExpr dflags e - case lookupCoreMap reps e' of - Just rep -> pure (delta, rep) - Nothing -> do - rep <- mkPmId (exprType e') - let reps' = extendCoreMap reps e' rep +representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e + | Just rep <- lookupCoreMap reps e = pure (delta, rep) + | otherwise = do + rep <- mkPmId (exprType e) + let reps' = extendCoreMap reps e rep let delta' = delta{ delta_tm_st = ts{ ts_reps = reps' } } pure (delta', rep) --- Most of our actions thread around a delta from one computation to the next, --- thereby potentially failing. This is expressed in the following Monad: --- type PmM a = StateT Delta (MaybeT DsM) a - --- | Records that a variable @x@ is equal to a 'CoreExpr' @e@. -addVarCoreCt :: Delta -> Id -> CoreExpr -> DsM (Maybe Delta) -addVarCoreCt delta x e = runMaybeT (execStateT (core_expr x e) delta) +-- | Inspects a 'PmCoreCt' @let x = e@ by recording constraints for @x@ based +-- on the shape of the 'CoreExpr' @e@. Examples: +-- +-- * For @let x = Just (42, 'z')@ we want to record the +-- constraints @x ~ Just a, a ~ (b, c), b ~ 42, c ~ 'z'@. +-- See 'data_con_app'. +-- * For @let x = unpackCString# "tmp"@ we want to record the literal +-- constraint @x ~ "tmp"@. +-- * For @let x = I# 42@ we want the literal constraint @x ~ 42@. Similar +-- for other literals. See 'coreExprAsPmLit'. +-- * Finally, if we have @let x = e@ and we already have seen @let y = e@, we +-- want to record @x ~ y@. +addCoreCt :: Delta -> Id -> CoreExpr -> MaybeT DsM Delta +addCoreCt delta x e = do + dflags <- getDynFlags + let e' = simpleOptExpr dflags e + lift $ tracePm "addCoreCt" (ppr x $$ ppr e $$ ppr e') + execStateT (core_expr x e') delta where -- | Takes apart a 'CoreExpr' and tries to extract as much information about -- literals and constructor applications as possible. @@ -1598,23 +1687,21 @@ = case unpackFS s of -- We need this special case to break a loop with coreExprAsPmLit -- Otherwise we alternate endlessly between [] and "" - [] -> data_con_app x nilDataCon [] + [] -> data_con_app x emptyInScopeSet nilDataCon [] s' -> core_expr x (mkListExpr charTy (map mkCharExpr s')) | Just lit <- coreExprAsPmLit e = pm_lit x lit - | Just (_in_scope, _empty_floats@[], dc, _arg_tys, args) + | Just (in_scope, _empty_floats@[], dc, _arg_tys, args) <- exprIsConApp_maybe in_scope_env e - = do { arg_ids <- traverse bind_expr args - ; data_con_app x dc arg_ids } + = data_con_app x in_scope dc args -- See Note [Detecting pattern synonym applications in expressions] | Var y <- e, Nothing <- isDataConId_maybe x -- We don't consider DataCons flexible variables - = modifyT (\delta -> addVarVarCt delta (x, y)) + = modifyT (\delta -> addVarCt delta x y) | otherwise -- Any other expression. Try to find other uses of a semantically -- equivalent expression and represent them by the same variable! - = do { rep <- represent_expr e - ; modifyT (\delta -> addVarVarCt delta (x, rep)) } + = equate_with_similar_expr x e where expr_ty = exprType e expr_in_scope = mkInScopeSet (exprFreeVars e) @@ -1624,27 +1711,51 @@ -- up substituting inside a forall or lambda (i.e. seldom) -- so using exprFreeVars seems fine. See MR !1647. - bind_expr :: CoreExpr -> StateT Delta (MaybeT DsM) Id - bind_expr e = do - x <- lift (lift (mkPmId (exprType e))) - core_expr x e - pure x + -- | The @e@ in @let x = e@ had no familiar form. But we can still see if + -- see if we already encountered a constraint @let y = e'@ with @e'@ + -- semantically equivalent to @e@, in which case we may add the constraint + -- @x ~ y@. + equate_with_similar_expr :: Id -> CoreExpr -> StateT Delta (MaybeT DsM) () + equate_with_similar_expr x e = do + rep <- StateT $ \delta -> swap <$> lift (representCoreExpr delta e) + -- Note that @rep == x@ if we encountered @e@ for the first time. + modifyT (\delta -> addVarCt delta x rep) - -- See if we already encountered a semantically equivalent expression - -- and return its representative - represent_expr :: CoreExpr -> StateT Delta (MaybeT DsM) Id - represent_expr e = StateT $ \delta -> - swap <$> lift (representCoreExpr delta e) + bind_expr :: CoreExpr -> StateT Delta (MaybeT DsM) Id + bind_expr e = do + x <- lift (lift (mkPmId (exprType e))) + core_expr x e + pure x - data_con_app :: Id -> DataCon -> [Id] -> StateT Delta (MaybeT DsM) () - data_con_app x dc args = pm_alt_con_app x (PmAltConLike (RealDataCon dc)) args + -- | Look at @let x = K taus theta es@ and generate the following + -- constraints (assuming universals were dropped from @taus@ before): + -- 1. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@ + -- 2. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@ + -- 3. @x ~ K as ys@ + data_con_app :: Id -> InScopeSet -> DataCon -> [CoreExpr] -> StateT Delta (MaybeT DsM) () + data_con_app x in_scope dc args = do + let dc_ex_tvs = dataConExTyCoVars dc + arty = dataConSourceArity dc + (ex_ty_args, val_args) = splitAtList dc_ex_tvs args + ex_tys = map exprToType ex_ty_args + vis_args = reverse $ take arty $ reverse val_args + uniq_supply <- lift $ lift $ getUniqueSupplyM + let (_, ex_tvs) = cloneTyVarBndrs (mkEmptyTCvSubst in_scope) dc_ex_tvs uniq_supply + ty_cts = equateTys (map mkTyVarTy ex_tvs) ex_tys + -- 1. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@. See also #17703 + modifyT $ \delta -> MaybeT $ addPmCts delta (listToBag ty_cts) + -- 2. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@ + arg_ids <- traverse bind_expr vis_args + -- 3. @x ~ K as ys@ + pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids + -- | Adds a literal constraint, i.e. @x ~ 42@. pm_lit :: Id -> PmLit -> StateT Delta (MaybeT DsM) () - pm_lit x lit = pm_alt_con_app x (PmAltLit lit) [] + pm_lit x lit = pm_alt_con_app x (PmAltLit lit) [] [] -- | Adds the given constructor application as a solution for @x@. - pm_alt_con_app :: Id -> PmAltCon -> [Id] -> StateT Delta (MaybeT DsM) () - pm_alt_con_app x con args = modifyT $ \delta -> addVarConCt delta x con args + pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Delta (MaybeT DsM) () + pm_alt_con_app x con tvs args = modifyT $ \delta -> addConCt delta x con tvs args -- | Like 'modify', but with an effectful modifier action modifyT :: Monad m => (s -> m s) -> StateT s m () @@ -1663,12 +1774,11 @@ P 15 -> Compared to the situation where P and Q are DataCons, the lack of generativity -means we could never flag Q as redundant. -(also see Note [Undecidable Equality for PmAltCons] in PmTypes.) -On the other hand, if we fail to recognise the pattern synonym, we flag the -pattern match as inexhaustive. That wouldn't happen if we had knowledge about -the scrutinee, in which case the oracle basically knows "If it's a P, then its -field is 15". +means we could never flag Q as redundant. (also see Note [Undecidable Equality +for PmAltCons] in PmTypes.) On the other hand, if we fail to recognise the +pattern synonym, we flag the pattern match as inexhaustive. That wouldn't happen +if we had knowledge about the scrutinee, in which case the oracle basically +knows "If it's a P, then its field is 15". This is a pretty narrow use case and I don't think we should to try to fix it until a user complains energetically. diff --git a/GHC/HsToCore/PmCheck/Ppr.hs b/GHC/HsToCore/PmCheck/Ppr.hs --- a/GHC/HsToCore/PmCheck/Ppr.hs +++ b/GHC/HsToCore/PmCheck/Ppr.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP, ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- | Provides factilities for pretty-printing 'Delta's in a way appropriate for -- user facing pattern match warnings. module GHC.HsToCore.PmCheck.Ppr ( @@ -8,19 +10,19 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import BasicTypes -import Id -import VarEnv -import UniqDFM -import ConLike -import DataCon -import TysWiredIn -import Outputable +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.DFM +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Builtin.Types +import GHC.Utils.Outputable import Control.Monad.Trans.RWS.CPS -import Util -import Maybes +import GHC.Utils.Misc +import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import GHC.HsToCore.PmCheck.Types @@ -29,7 +31,7 @@ -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its -- components and refutable shapes associated to any mentioned variables. -- --- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]]): +-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@: -- -- @ -- (Just p) q @@ -90,13 +92,13 @@ (it does not even substitute in HsExpr so they are even printed as wildcards). Additionally, the oracle returns a substitution if it succeeds so we apply this substitution to the vectors before printing them out (see function `pprOne' in -Check.hs) to be more precise. +"GHC.HsToCore.PmCheck") to be more precise. -} -- | Extract and assigns pretty names to constraint variables with refutable -- shapes. prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon]) -prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList +prettifyRefuts delta = listToUDFM_Directly . map attach_refuts . udfmToList where attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u)) @@ -143,7 +145,7 @@ pprPmVar prec x = do delta <- ask case lookupSolution delta x of - Just (alt, args) -> pprPmAltCon prec alt args + Just (alt, _tvs, args) -> pprPmAltCon prec alt args Nothing -> fromMaybe typed_wildcard <$> checkRefuts x where -- if we have no info about the parameter and would just print a @@ -203,7 +205,7 @@ pmExprAsList delta = go_con [] where go_var rev_pref x - | Just (alt, args) <- lookupSolution delta x + | Just (alt, _tvs, args) <- lookupSolution delta x = go_con rev_pref alt args go_var rev_pref x | Just pref <- nonEmpty (reverse rev_pref) diff --git a/GHC/HsToCore/PmCheck/Types.hs b/GHC/HsToCore/PmCheck/Types.hs --- a/GHC/HsToCore/PmCheck/Types.hs +++ b/GHC/HsToCore/PmCheck/Types.hs @@ -6,9 +6,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ApplicativeDo #-} -- | Types used through-out pattern match checking. This module is mostly there --- to be imported from "TcRnTypes". The exposed API is that of +-- to be imported from "GHC.Tc.Types". The exposed API is that of -- "GHC.HsToCore.PmCheck.Oracle" and "GHC.HsToCore.PmCheck". module GHC.HsToCore.PmCheck.Types ( -- * Representations for Literals and AltCons @@ -24,46 +26,53 @@ -- * Caching partially matched COMPLETE sets ConLikeSet, PossibleMatches(..), + -- * PmAltConSet + PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet, + extendPmAltConSet, pmAltConSetElems, + -- * A 'DIdEnv' where entries may be shared Shared(..), SharedDIdEnv(..), emptySDIE, lookupSDIE, sameRepresentativeSDIE, setIndirectSDIE, setEntrySDIE, traverseSDIE, -- * The pattern match oracle - VarInfo(..), TmState(..), TyState(..), Delta(..), initDelta + VarInfo(..), TmState(..), TyState(..), Delta(..), + Deltas(..), initDeltas, liftDeltasM ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Util -import Bag -import FastString -import Var (EvVar) -import Id -import VarEnv -import UniqDSet -import UniqDFM -import Name -import DataCon -import ConLike -import Outputable -import Maybes -import Type -import TyCon -import Literal -import CoreSyn -import CoreMap -import CoreUtils (exprType) -import PrelNames -import TysWiredIn -import TysPrim -import TcType (evVarPred) +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Types.Var (EvVar) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.DSet +import GHC.Types.Unique.DFM +import GHC.Types.Name +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Utils.Outputable +import GHC.Data.List.SetOps (unionLists) +import GHC.Data.Maybe +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Types.Literal +import GHC.Core +import GHC.Core.Map +import GHC.Core.Utils (exprType) +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Tc.Utils.TcType (evVarPred) import Numeric (fromRat) import Data.Foldable (find) import qualified Data.List.NonEmpty as NonEmpty import Data.Ratio +import qualified Data.Semigroup as Semi -- | Literals (simple and overloaded ones) for pattern match checking. -- @@ -146,10 +155,37 @@ eqConLike _ _ = PossiblyOverlap -- | Represents the head of a match against a 'ConLike' or literal. --- Really similar to 'CoreSyn.AltCon'. +-- Really similar to 'GHC.Core.AltCon'. data PmAltCon = PmAltConLike ConLike | PmAltLit PmLit +data PmAltConSet = PACS !ConLikeSet ![PmLit] + +emptyPmAltConSet :: PmAltConSet +emptyPmAltConSet = PACS emptyUniqDSet [] + +isEmptyPmAltConSet :: PmAltConSet -> Bool +isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits + +-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to +-- the given 'PmAltCon' according to 'eqPmAltCon'. +elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool +elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls +elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits + +extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet +extendPmAltConSet (PACS cls lits) (PmAltConLike cl) + = PACS (addOneToUniqDSet cls cl) lits +extendPmAltConSet (PACS cls lits) (PmAltLit lit) + = PACS cls (unionLists lits [lit]) + +pmAltConSetElems :: PmAltConSet -> [PmAltCon] +pmAltConSetElems (PACS cls lits) + = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits + +instance Outputable PmAltConSet where + ppr = ppr . pmAltConSetElems + -- | We can't in general decide whether two 'PmAltCon's match the same set of -- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a -- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'. @@ -237,7 +273,7 @@ * We have instant equality check for overloaded literals (we do not rely on the term oracle which is rather expensive, both in terms of performance and memory). This significantly improves the performance of functions `covered` - `uncovered` and `divergent` in deSugar/Check.hs and effectively addresses + `uncovered` and `divergent` in "GHC.HsToCore.PmCheck" and effectively addresses #11161. * The warnings issued are simpler. @@ -254,7 +290,7 @@ go (LitFloat r) = Just (PmLitRat r) go (LitDouble r) = Just (PmLitRat r) go (LitString s) = Just (PmLitString (mkFastStringByteString s)) - go (LitNumber _ i _) = Just (PmLitInt i) + go (LitNumber _ i) = Just (PmLitInt i) go _ = Nothing negatePmLit :: PmLit -> Maybe PmLit @@ -424,11 +460,14 @@ setEntrySDIE sdie@(SDIE env) x a = SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Entry a) -traverseSDIE :: Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b) -traverseSDIE f = fmap (SDIE . listToUDFM) . traverse g . udfmToList . unSDIE +traverseSDIE :: forall a b f. Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b) +traverseSDIE f = fmap (SDIE . listToUDFM_Directly) . traverse g . udfmToList . unSDIE where + g :: (Unique, Shared a) -> f (Unique, Shared b) g (u, Indirect y) = pure (u,Indirect y) - g (u, Entry a) = (u,) . Entry <$> f a + g (u, Entry a) = do + a' <- f a + pure (u,Entry a') instance Outputable a => Outputable (Shared a) where ppr (Indirect x) = ppr x @@ -441,7 +480,7 @@ -- entries are possibly shared when we figure out that two variables must be -- equal, thus represent the same set of values. -- --- See Note [TmState invariants] in Oracle. +-- See Note [TmState invariants] in "GHC.HsToCore.PmCheck.Oracle". data TmState = TmSt { ts_facts :: !(SharedDIdEnv VarInfo) @@ -458,14 +497,14 @@ -- Also caches the type ('vi_ty'), the 'PossibleMatches' of a COMPLETE set -- ('vi_cache'). -- --- Subject to Note [The Pos/Neg invariant] in PmOracle. +-- Subject to Note [The Pos/Neg invariant] in "GHC.HsToCore.PmCheck.Oracle". data VarInfo = VI { vi_ty :: !Type -- ^ The type of the variable. Important for rejecting possible GADT -- constructors or incompatible pattern synonyms (@Just42 :: Maybe Int@). - , vi_pos :: ![(PmAltCon, [Id])] + , vi_pos :: ![(PmAltCon, [TyVar], [Id])] -- ^ Positive info: 'PmAltCon' apps it is (i.e. @x ~ [Just y, PatSyn z]@), all -- at the same time (i.e. conjunctive). We need a list because of nested -- pattern matches involving pattern synonym @@ -473,7 +512,7 @@ -- However, no more than one RealDataCon in the list, otherwise contradiction -- because of generativity. - , vi_neg :: ![PmAltCon] + , vi_neg :: !PmAltConSet -- ^ Negative info: A list of 'PmAltCon's that it cannot match. -- Example, assuming -- @@ -487,6 +526,9 @@ -- between 'vi_pos' and 'vi_neg'. -- See Note [Why record both positive and negative info?] + -- It's worth having an actual set rather than a simple association list, + -- because files like Cabal's `LicenseId` define relatively huge enums + -- that lead to quadratic or worse behavior. , vi_cache :: !PossibleMatches -- ^ A cache of the associated COMPLETE sets. At any time a superset of @@ -508,7 +550,7 @@ initTmState :: TmState initTmState = TmSt emptySDIE emptyCoreMap --- | The type oracle state. A poor man's 'TcSMonad.InsertSet': The invariant is +-- | The type oracle state. A poor man's 'GHC.Tc.Solver.Monad.InsertSet': The invariant is -- that all constraints in there are mutually compatible. newtype TyState = TySt (Bag EvVar) @@ -520,8 +562,7 @@ initTyState :: TyState initTyState = TySt emptyBag --- | Term and type constraints to accompany each value vector abstraction. --- For efficiency, we store the term oracle state instead of the term +-- | An inert set of canonical (i.e. mutually compatible) term and type -- constraints. data Delta = MkDelta { delta_ty_st :: TyState -- Type oracle; things like a~Int , delta_tm_st :: TmState } -- Term oracle; things like x~Nothing @@ -531,9 +572,24 @@ initDelta = MkDelta initTyState initTmState instance Outputable Delta where - ppr delta = vcat [ + ppr delta = hang (text "Delta") 2 $ vcat [ -- intentionally formatted this way enable the dev to comment in only -- the info she needs ppr (delta_tm_st delta), ppr (delta_ty_st delta) ] + +-- | A disjunctive bag of 'Delta's, representing a refinement type. +newtype Deltas = MkDeltas (Bag Delta) + +initDeltas :: Deltas +initDeltas = MkDeltas (unitBag initDelta) + +instance Outputable Deltas where + ppr (MkDeltas deltas) = ppr deltas + +instance Semigroup Deltas where + MkDeltas l <> MkDeltas r = MkDeltas (l `unionBags` r) + +liftDeltasM :: Monad m => (Delta -> m (Maybe Delta)) -> Deltas -> m Deltas +liftDeltasM f (MkDeltas ds) = MkDeltas . catBagMaybes <$> (traverse f ds) diff --git a/GHC/HsToCore/PmCheck/Types.hs-boot b/GHC/HsToCore/PmCheck/Types.hs-boot --- a/GHC/HsToCore/PmCheck/Types.hs-boot +++ b/GHC/HsToCore/PmCheck/Types.hs-boot @@ -1,7 +1,9 @@ module GHC.HsToCore.PmCheck.Types where -import GhcPrelude () +import GHC.Data.Bag data Delta -initDelta :: Delta +newtype Deltas = MkDeltas (Bag Delta) + +initDeltas :: Deltas diff --git a/GHC/HsToCore/Quote.hs b/GHC/HsToCore/Quote.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Quote.hs @@ -0,0 +1,2962 @@ +{-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- The purpose of this module is to transform an HsExpr into a CoreExpr which +-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the +-- input HsExpr. We do this in the DsM monad, which supplies access to +-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. +-- +-- It also defines a bunch of knownKeyNames, in the same way as is done +-- in prelude/GHC.Builtin.Names. It's much more convenient to do it here, because +-- otherwise we have to recompile GHC.Builtin.Names whenever we add a Name, which is +-- a Royal Pain (triggers other recompilation). +----------------------------------------------------------------------------- + +module GHC.HsToCore.Quote( dsBracket ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) + +import GHC.HsToCore.Match.Literal +import GHC.HsToCore.Monad + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH + +import GHC.Hs +import GHC.Builtin.Names + +import GHC.Unit.Module +import GHC.Types.Id +import GHC.Types.Name hiding( varName, tcName ) +import GHC.Builtin.Names.TH +import GHC.Types.Name.Env +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Core +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Data.Bag +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Types.ForeignCall +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Monad +import GHC.Tc.Types.Evidence +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class +import GHC.Core.Class +import GHC.Driver.Types ( MonadThings ) +import GHC.Core.DataCon +import GHC.Types.Var +import GHC.HsToCore.Binds + +import GHC.TypeLits +import Data.Kind (Constraint) + +import Data.ByteString ( unpack ) +import Control.Monad +import Data.List +import Data.Function + +data MetaWrappers = MetaWrappers { + -- Applies its argument to a type argument `m` and dictionary `Quote m` + quoteWrapper :: CoreExpr -> CoreExpr + -- Apply its argument to a type argument `m` and a dictionary `Monad m` + , monadWrapper :: CoreExpr -> CoreExpr + -- Apply the container typed variable `m` to the argument type `T` to get `m T`. + , metaTy :: Type -> Type + -- Information about the wrappers which be printed to be inspected + , _debugWrappers :: (HsWrapper, HsWrapper, Type) + } + +-- | Construct the functions which will apply the relevant part of the +-- QuoteWrapper to identifiers during desugaring. +mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers +mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do + let quote_var = Var quote_var_raw + -- Get the superclass selector to select the Monad dictionary, going + -- to be used to construct the monadWrapper. + quote_tc <- dsLookupTyCon quoteClassName + monad_tc <- dsLookupTyCon monadClassName + let Just cls = tyConClass_maybe quote_tc + Just monad_cls = tyConClass_maybe monad_tc + -- Quote m -> Monad m + monad_sel = classSCSelId cls 0 + + -- Only used for the defensive assertion that the selector has + -- the expected type + tyvars = dataConUserTyVarBinders (classDataCon cls) + expected_ty = mkInvisForAllTys tyvars $ + mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars))) + (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) + + MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty) + + let m_ty = Type m_var + -- Construct the contents of MetaWrappers + quoteWrapper = applyQuoteWrapper q + monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.> + mkWpTyApps [m_var] + tyWrapper t = mkAppTy m_var t + debug = (quoteWrapper, monadWrapper, m_var) + q_f <- dsHsWrapper quoteWrapper + m_f <- dsHsWrapper monadWrapper + return (MetaWrappers q_f m_f tyWrapper debug) + +-- Turn A into m A +wrapName :: Name -> MetaM Type +wrapName n = do + t <- lookupType n + wrap_fn <- asks metaTy + return (wrap_fn t) + +-- The local state is always the same, calculated from the passed in +-- wrapper +type MetaM a = ReaderT MetaWrappers DsM a + +getPlatform :: MetaM Platform +getPlatform = targetPlatform <$> getDynFlags + +----------------------------------------------------------------------------- +dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr + -> HsBracket GhcRn + -> [PendingTcSplice] + -> DsM CoreExpr +-- See Note [Desugaring Brackets] +-- Returns a CoreExpr of type (M TH.Exp) +-- The quoted thing is parameterised over Name, even though it has +-- been type checked. We don't want all those type decorations! + +dsBracket wrap brack splices + = do_brack brack + + where + runOverloaded act = do + -- In the overloaded case we have to get given a wrapper, it is just + -- for variable quotations that there is no wrapper, because they + -- have a simple type. + mw <- mkMetaWrappers (expectJust "runOverloaded" wrap) + runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw + + + new_bit = mkNameEnv [(n, DsSplice (unLoc e)) + | PendingTcSplice n e <- splices] + + do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM n ; return e1 } + do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" + do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } + +{- +Note [Desugaring Brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie +an expression bracket was of type Q Exp. This made the desugaring process simple +as there were no complicated type variables to keep consistent throughout the +whole AST. Due to the overloaded quotations proposal a quotation bracket is now +of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been +generalised to work with any monad implementing a minimal interface. + +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst + +Users can rejoice at the flexibility but now there is some additional complexity in +how brackets are desugared as all these polymorphic combinators need their arguments +instantiated. + +> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD +> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR. + +What the arguments should be instantiated to is supplied by the `QuoteWrapper` +datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable +for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring +need to be applied to these two type variables. + +There are three important functions which do the application. + +1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument. +2. `rep2M` takes a function name of type `Monad m => T` as an argument +3. `rep2_nw` takes a function name without any constraints as an argument. + +These functions then use the information in QuoteWrapper to apply the correct +arguments to the functions as the representation is constructed. + +The `MetaM` monad carries around an environment of three functions which are +used in order to wrap the polymorphic combinators and instantiate the arguments +to the correct things. + +1. quoteWrapper wraps functions of type `forall m . Quote m => T` +2. monadWrapper wraps functions of type `forall m . Monad m => T` +3. metaTy wraps a type in the polymorphic `m` variable of the whole representation. + +Historical note about the implementation: At the first attempt, I attempted to +lie that the type of any quotation was `Quote m => m Exp` and then specialise it +by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was +simpler to implement but didn't work because of nested splices. For example, +you might have a nested splice of a more specific type which fixes the type of +the overall quote and so all the combinators used must also be instantiated to +that specific type. Therefore you really have to use the contents of the quote +wrapper to directly apply the right type to the combinators rather than +first generate a polymorphic definition and then just apply the wrapper at the end. + +-} + +{- -------------- Examples -------------------- + + [| \x -> x |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (var x1) + + + [| \x -> $(f [| x |]) |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (f (var x1)) +-} + + +------------------------------------------------------- +-- Declarations +------------------------------------------------------- + +-- Proxy for the phantom type of `Core`. All the generated fragments have +-- type something like `Quote m => m Exp` so to keep things simple we represent fragments +-- of that type as `M Exp`. +data M a + +repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) + ; pat' <- addBinds ss (repLP pat) + ; wrapGenSyms ss pat' } + +repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec])) +repTopDs group@(HsGroup { hs_valds = valds + , hs_splcds = splcds + , hs_tyclds = tyclds + , hs_derivds = derivds + , hs_fixds = fixds + , hs_defds = defds + , hs_fords = fords + , hs_warnds = warnds + , hs_annds = annds + , hs_ruleds = ruleds + , hs_docs = docs }) + = do { let { bndrs = hsScopedTvBinders valds + ++ hsGroupBinders group + ++ hsPatSynSelectors valds + ; instds = tyclds >>= group_instds } ; + ss <- mkGenSyms bndrs ; + + -- Bind all the names mainly to avoid repeated use of explicit strings. + -- Thus we get + -- do { t :: String <- genSym "T" ; + -- return (Data t [] ...more t's... } + -- The other important reason is that the output must mention + -- only "T", not "Foo:T" where Foo is the current module + + decls <- addBinds ss ( + do { val_ds <- rep_val_binds valds + ; _ <- mapM no_splice splcds + ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) + ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) + ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds) + ; inst_ds <- mapM repInstD instds + ; deriv_ds <- mapM repStandaloneDerivD derivds + ; fix_ds <- mapM repLFixD fixds + ; _ <- mapM no_default_decl defds + ; for_ds <- mapM repForD fords + ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) + warnds) + ; ann_ds <- mapM repAnnD annds + ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) + ruleds) + ; _ <- mapM no_doc docs + + -- more needed + ; return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds ++ role_ds + ++ kisig_ds + ++ (concat fix_ds) + ++ inst_ds ++ rule_ds ++ for_ds + ++ ann_ds ++ deriv_ds) }) ; + + core_list <- repListM decTyConName return decls ; + + dec_ty <- lookupType decTyConName ; + q_decs <- repSequenceM dec_ty core_list ; + + wrapGenSyms ss q_decs + } + where + no_splice (L loc _) + = notHandledL loc "Splices within declaration brackets" empty + no_default_decl (L loc decl) + = notHandledL loc "Default declarations" (ppr decl) + no_warn :: LWarnDecl GhcRn -> MetaM a + no_warn (L loc (Warning _ thing _)) + = notHandledL loc "WARNING and DEPRECATION pragmas" $ + text "Pragma for declaration of" <+> ppr thing + no_doc (L loc _) + = notHandledL loc "Haddock documentation" empty + +hsScopedTvBinders :: HsValBinds GhcRn -> [Name] +-- See Note [Scoped type variables in quotes] +hsScopedTvBinders binds + = concatMap get_scoped_tvs sigs + where + sigs = case binds of + ValBinds _ _ sigs -> sigs + XValBindsLR (NValBinds _ sigs) -> sigs + +get_scoped_tvs :: LSig GhcRn -> [Name] +get_scoped_tvs (L _ signature) + | TypeSig _ _ sig <- signature + = get_scoped_tvs_from_sig (hswc_body sig) + | ClassOpSig _ _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | PatSynSig _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | otherwise + = [] + +get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name] +get_scoped_tvs_from_sig sig + -- Collect both implicit and explicit quantified variables, since + -- the types in instance heads, as well as `via` types in DerivingVia, can + -- bring implicitly quantified type variables into scope, e.g., + -- + -- instance Foo [a] where + -- m = n @a + -- + -- See also Note [Scoped type variables in quotes] + | HsIB { hsib_ext = implicit_vars + , hsib_body = hs_ty } <- sig + , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty + = implicit_vars ++ hsLTyVarNames explicit_vars + +{- Notes + +Note [Scoped type variables in quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Quoting declarations with scoped type variables requires some care. Consider: + + $([d| f :: forall a. a -> a + f x = x::a + |]) + +Here, the `forall a` brings `a` into scope over the binding group. This has +ramifications when desugaring the quote, as we must ensure that that the +desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the +bound `a` type variable in the type signature and in the body of `f`. As a +result, the call to `newName` must occur before any part of the declaration for +`f` is processed. To achieve this, we: + + (a) Gensym a binding for `a` at the same time as we do one for `f`, + collecting the relevant binders with the hsScopedTvBinders family of + functions. + + (b) Use `addBinds` to bring these gensymmed bindings into scope over any + part of the code where the type variables scope. In the `f` example, + above, that means the type signature and the body of `f`. + + (c) When processing the `forall`, /don't/ gensym the type variables. We have + already brought the type variables into scope in part (b), after all, so + gensymming them again would lead to shadowing. We use the rep_ty_sig + family of functions for processing types without gensymming the type + variables again. + + (d) Finally, we use wrapGenSyms to generate the Core for these scoped type + variables: + + newName "a" >>= \a -> + ... -- process the type signature and body of `f` + +The relevant places are signposted with references to this Note. + +Note [Binders and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we desugar [d| data T = MkT |] +we want to get + Data "T" [] [Con "MkT" []] [] +and *not* + Data "Foo:T" [] [Con "Foo:MkT" []] [] +That is, the new data decl should fit into whatever new module it is +asked to fit in. We do *not* clone, though; no need for this: + Data "T79" .... + +But if we see this: + data T = MkT + foo = reifyDecl T + +then we must desugar to + foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] + +So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. +And we use lookupOcc, rather than lookupBinder +in repTyClD and repC. + +Note [Don't quantify implicit type variables in quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you're not careful, it's surprisingly easy to take this quoted declaration: + + [d| id :: a -> a + id x = x + |] + +and have Template Haskell turn it into this: + + id :: forall a. a -> a + id x = x + +Notice that we explicitly quantified the variable `a`! The latter declaration +isn't what the user wrote in the first place. + +Usually, the culprit behind these bugs is taking implicitly quantified type +variables (often from the hsib_vars field of HsImplicitBinders) and putting +them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. +-} + +-- represent associated family instances +-- +repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec))) + +repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ + repFamilyDecl (L loc fam) + +repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + repSynDecl tc1 bndrs rhs + ; return (Just (loc, dec)) } + +repTyClD (L loc (DataDecl { tcdLName = tc + , tcdTyVars = tvs + , tcdDataDefn = defn })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + repDataDefn tc1 (Left bndrs) defn + ; return (Just (loc, dec)) } + +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, + tcdTyVars = tvs, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = meth_binds, + tcdATs = ats, tcdATDefs = atds })) + = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] + ; dec <- addQTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + -- See Note [Scoped type variables in quotes] + ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds + ; fds1 <- repLFunDeps fds + ; ats1 <- repFamilyDecls ats + ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds + ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds) + ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 + ; wrapGenSyms ss decls2 } + ; return $ Just (loc, dec) + } + +------------------------- +repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repRoleD (L loc (RoleAnnotDecl _ tycon roles)) + = do { tycon1 <- lookupLOcc tycon + ; roles1 <- mapM repRole roles + ; roles2 <- coreList roleTyConName roles1 + ; dec <- repRoleAnnotD tycon1 roles2 + ; return (loc, dec) } + +------------------------- +repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repKiSigD (L loc kisig) = + case kisig of + StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v + +------------------------- +repDataDefn :: Core TH.Name + -> Either (Core [(M (TH.TyVarBndr ()))]) + -- the repTyClD case + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) + -- the repDataFamInstD case + -> HsDataDefn GhcRn + -> MetaM (Core (M TH.Dec)) +repDataDefn tc opts + (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig + , dd_cons = cons, dd_derivs = mb_derivs }) + = do { cxt1 <- repLContext cxt + ; derivs1 <- repDerivs mb_derivs + ; case (new_or_data, cons) of + (NewType, [con]) -> do { con' <- repC con + ; ksig' <- repMaybeLTy ksig + ; repNewtype cxt1 tc opts ksig' con' + derivs1 } + (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:" + <+> pprQuotedList + (getConNames $ unLoc $ head cons)) + (DataType, _) -> do { ksig' <- repMaybeLTy ksig + ; consL <- mapM repC cons + ; cons1 <- coreListM conTyConName consL + ; repData cxt1 tc opts ksig' cons1 + derivs1 } + } + +repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] + -> LHsType GhcRn + -> MetaM (Core (M TH.Dec)) +repSynDecl tc bndrs ty + = do { ty1 <- repLTy ty + ; repTySyn tc bndrs ty1 } + +repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info + , fdLName = tc + , fdTyVars = tvs + , fdResultSig = L _ resultSig + , fdInjectivityAnn = injectivity })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn + mkHsQTvs tvs = HsQTvs { hsq_ext = [] + , hsq_explicit = tvs } + resTyVar = case resultSig of + TyVarSig _ bndr -> mkHsQTvs [bndr] + _ -> mkHsQTvs [] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + addTyClTyVarBinds resTyVar $ \_ -> + case info of + ClosedTypeFamily Nothing -> + notHandled "abstract closed type family" (ppr decl) + ClosedTypeFamily (Just eqns) -> + do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns + ; eqns2 <- coreListM tySynEqnTyConName eqns1 + ; result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repClosedFamilyD tc1 bndrs result inj eqns2 } + OpenTypeFamily -> + do { result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repOpenFamilyD tc1 bndrs result inj } + DataFamily -> + do { kind <- repFamilyResultSigToMaybeKind resultSig + ; repDataFamilyD tc1 bndrs kind } + ; return (loc, dec) + } + +-- | Represent result signature of a type family +repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig)) +repFamilyResultSig (NoSig _) = repNoSig +repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki + ; repKindSig ki' } +repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr + ; repTyVarSig bndr' } + +-- | Represent result signature using a Maybe Kind. Used with data families, +-- where the result signature can be either missing or a kind but never a named +-- result variable. +repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn + -> MetaM (Core (Maybe (M TH.Kind))) +repFamilyResultSigToMaybeKind (NoSig _) = + do { coreNothingM kindTyConName } +repFamilyResultSigToMaybeKind (KindSig _ ki) = + do { coreJustM kindTyConName =<< repLTy ki } +repFamilyResultSigToMaybeKind TyVarSig{} = + panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" + +-- | Represent injectivity annotation of a type family +repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) + -> MetaM (Core (Maybe TH.InjectivityAnn)) +repInjectivityAnn Nothing = + do { coreNothing injAnnTyConName } +repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = + do { lhs' <- lookupBinder (unLoc lhs) + ; rhs1 <- mapM (lookupBinder . unLoc) rhs + ; rhs2 <- coreList nameTyConName rhs1 + ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2] + ; coreJust injAnnTyConName injAnn } + +repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)] +repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) + +repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec)) +repAssocTyFamDefaultD = repTyFamInstD + +------------------------- +-- represent fundeps +-- +repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep]) +repLFunDeps fds = repList funDepTyConName repLFunDep fds + +repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep) +repLFunDep (L _ (xs, ys)) + = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs + ys' <- repList nameTyConName (lookupBinder . unLoc) ys + repFunDep xs' ys' + +-- Represent instance declarations +-- +repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) + = do { dec <- repTyFamInstD fi_decl + ; return (loc, dec) } +repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) + = do { dec <- repDataFamInstD fi_decl + ; return (loc, dec) } +repInstD (L loc (ClsInstD { cid_inst = cls_decl })) + = do { dec <- repClsInstD cls_decl + ; return (loc, dec) } + +repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_datafam_insts = adts + , cid_overlap_mode = overlap + }) + = addSimpleTyVarBinds tvs $ + -- We must bring the type variables into scope, so their + -- occurrences don't fail, even though the binders don't + -- appear in the resulting data structure + -- + -- But we do NOT bring the binders of 'binds' into scope + -- because they are properly regarded as occurrences + -- For example, the method names should be bound to + -- the selector Ids, not to fresh names (#5410) + -- + do { cxt1 <- repLContext cxt + ; inst_ty1 <- repLTy inst_ty + -- See Note [Scoped type variables in quotes] + ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds + ; ats1 <- mapM (repTyFamInstD . unLoc) ats + ; adts1 <- mapM (repDataFamInstD . unLoc) adts + ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds) + ; rOver <- repOverlap (fmap unLoc overlap) + ; decls2 <- repInst rOver cxt1 inst_ty1 decls1 + ; wrapGenSyms ss decls2 } + where + (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty + +repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat + , deriv_type = ty })) + = do { dec <- repDerivStrategy strat $ \strat' -> + addSimpleTyVarBinds tvs $ + do { cxt' <- repLContext cxt + ; inst_ty' <- repLTy inst_ty + ; repDeriv strat' cxt' inst_ty' } + ; return (loc, dec) } + where + (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) + +repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) + = do { eqn1 <- repTyFamEqn eqn + ; repTySynInst eqn1 } + +repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn)) +repTyFamEqn (HsIB { hsib_ext = var_names + , hsib_body = FamEqn { feqn_tycon = tc_name + , feqn_bndrs = mb_bndrs + , feqn_pats = tys + , feqn_fixity = fixity + , feqn_rhs = rhs }}) + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let hs_tvs = HsQTvs { hsq_ext = var_names + , hsq_explicit = fromMaybe [] mb_bndrs } + ; addTyClTyVarBinds hs_tvs $ \ _ -> + do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName + repTyVarBndr + mb_bndrs + ; tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } + ; rhs1 <- repLTy rhs + ; repTySynEqn mb_bndrs1 tys1 rhs1 } } + where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _:HsValArg _:_) = return tys + checkTys _ = panic "repTyFamEqn:checkTys" + +repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type)) +repTyArgs f [] = f +repTyArgs f (HsValArg ty : as) = do { f' <- f + ; ty' <- repLTy ty + ; repTyArgs (repTapp f' ty') as } +repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f + ; ki' <- repLTy ki + ; repTyArgs (repTappKind f' ki') as } +repTyArgs f (HsArgPar _ : as) = repTyArgs f as + +repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) +repDataFamInstD (DataFamInstDecl { dfid_eqn = + (HsIB { hsib_ext = var_names + , hsib_body = FamEqn { feqn_tycon = tc_name + , feqn_bndrs = mb_bndrs + , feqn_pats = tys + , feqn_fixity = fixity + , feqn_rhs = defn }})}) + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let hs_tvs = HsQTvs { hsq_ext = var_names + , hsq_explicit = fromMaybe [] mb_bndrs } + ; addTyClTyVarBinds hs_tvs $ \ _ -> + do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName + repTyVarBndr + mb_bndrs + ; tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } + ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } } + + where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _: HsValArg _: _) = return tys + checkTys _ = panic "repDataFamInstD:checkTys" + +repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec)) +repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ + , fd_fi = CImport (L _ cc) + (L _ s) mch cis _ })) + = do MkC name' <- lookupLOcc name + MkC typ' <- repHsSigType typ + MkC cc' <- repCCallConv cc + MkC s' <- repSafety s + cis' <- conv_cimportspec cis + MkC str <- coreStringLit (static ++ chStr ++ cis') + dec <- rep2 forImpDName [cc', s', str, name', typ'] + return (loc, dec) + where + conv_cimportspec (CLabel cls) + = notHandled "Foreign label" (doubleQuotes (ppr cls)) + conv_cimportspec (CFunction DynamicTarget) = return "dynamic" + conv_cimportspec (CFunction (StaticTarget _ fs _ True)) + = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget _ _ _ False)) + = panic "conv_cimportspec: values not supported yet" + conv_cimportspec CWrapper = return "wrapper" + -- these calling conventions do not support headers and the static keyword + raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv + static = case cis of + CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " + _ -> "" + chStr = case mch of + Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " + _ -> "" +repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl) + +repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) +repCCallConv CCallConv = rep2_nw cCallName [] +repCCallConv StdCallConv = rep2_nw stdCallName [] +repCCallConv CApiConv = rep2_nw cApiCallName [] +repCCallConv PrimCallConv = rep2_nw primCallName [] +repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName [] + +repSafety :: Safety -> MetaM (Core TH.Safety) +repSafety PlayRisky = rep2_nw unsafeName [] +repSafety PlayInterruptible = rep2_nw interruptibleName [] +repSafety PlaySafe = rep2_nw safeName [] + +repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig + +rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_fix_d loc (FixitySig _ names (Fixity _ prec dir)) + = do { MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLDName + InfixR -> infixRDName + InfixN -> infixNDName + ; let do_one name + = do { MkC name' <- lookupLOcc name + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc,dec) } + ; mapM do_one names } + +repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repRuleD (L loc (HsRule { rd_name = n + , rd_act = act + , rd_tyvs = ty_bndrs + , rd_tmvs = tm_bndrs + , rd_lhs = lhs + , rd_rhs = rhs })) + = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> + do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs + ; ss <- mkGenSyms tm_bndr_names + ; rule <- addBinds ss $ + do { elt_ty <- wrapName tyVarBndrUnitTyConName + ; ty_bndrs' <- return $ case ty_bndrs of + Nothing -> coreNothing' (mkListTy elt_ty) + Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs + ; tm_bndrs' <- repListM ruleBndrTyConName + repRuleBndr + tm_bndrs + ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n + ; act' <- repPhases act + ; lhs' <- repLE lhs + ; rhs' <- repLE rhs + ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } + ; wrapGenSyms ss rule } + ; return (loc, rule) } + +ruleBndrNames :: LRuleBndr GhcRn -> [Name] +ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig _ n sig)) + | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig + = unLoc n : vars + +repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) +repRuleBndr (L _ (RuleBndr _ n)) + = do { MkC n' <- lookupLBinder n + ; rep2 ruleVarName [n'] } +repRuleBndr (L _ (RuleBndrSig _ n sig)) + = do { MkC n' <- lookupLBinder n + ; MkC ty' <- repLTy (hsPatSigType sig) + ; rep2 typedRuleVarName [n', ty'] } + +repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) + = do { target <- repAnnProv ann_prov + ; exp' <- repE exp + ; dec <- repPragAnn target exp' + ; return (loc, dec) } + +repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget) +repAnnProv (ValueAnnProvenance (L _ n)) + = do { MkC n' <- lift $ globalVar n -- ANNs are allowed only at top-level + ; rep2_nw valueAnnotationName [ n' ] } +repAnnProv (TypeAnnProvenance (L _ n)) + = do { MkC n' <- lift $ globalVar n + ; rep2_nw typeAnnotationName [ n' ] } +repAnnProv ModuleAnnProvenance + = rep2_nw moduleAnnotationName [] + +------------------------------------------------------- +-- Constructors +------------------------------------------------------- + +repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con)) +repC (L _ (ConDeclH98 { con_name = con + , con_forall = (L _ False) + , con_mb_cxt = Nothing + , con_args = args })) + = repDataCon con args + +repC (L _ (ConDeclH98 { con_name = con + , con_forall = L _ is_existential + , con_ex_tvs = con_tvs + , con_mb_cxt = mcxt + , con_args = args })) + = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> + do { c' <- repDataCon con args + ; ctxt' <- repMbContext mcxt + ; if not is_existential && isNothing mcxt + then return c' + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) + } + } + +repC (L _ (ConDeclGADT { con_g_ext = imp_tvs + , con_names = cons + , con_qvars = exp_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty })) + | null imp_tvs && null exp_tvs -- No implicit or explicit variables + , Nothing <- mcxt -- No context + -- ==> no need for a forall + = repGadtDataCons cons args res_ty + + | otherwise + = addTyVarBinds exp_tvs imp_tvs $ \ ex_bndrs -> + -- See Note [Don't quantify implicit type variables in quotes] + do { c' <- repGadtDataCons cons args res_ty + ; ctxt' <- repMbContext mcxt + ; if null exp_tvs && isNothing mcxt + then return c' + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } + + +repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) +repMbContext Nothing = repContext [] +repMbContext (Just (L _ cxt)) = repContext cxt + +repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness)) +repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] +repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] +repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] + +repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness)) +repSrcStrictness SrcLazy = rep2 sourceLazyName [] +repSrcStrictness SrcStrict = rep2 sourceStrictName [] +repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] + +repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType)) +repBangTy ty = do + MkC u <- repSrcUnpackedness su' + MkC s <- repSrcStrictness ss' + MkC b <- rep2 bangName [u, s] + MkC t <- repLTy ty' + rep2 bangTypeName [b, t] + where + (su', ss', ty') = case unLoc ty of + HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty) + _ -> (NoSrcUnpack, NoSrcStrict, ty) + +------------------------------------------------------- +-- Deriving clauses +------------------------------------------------------- + +repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause]) +repDerivs (L _ clauses) + = repListM derivClauseTyConName repDerivClause clauses + +repDerivClause :: LHsDerivingClause GhcRn + -> MetaM (Core (M TH.DerivClause)) +repDerivClause (L _ (HsDerivingClause + { deriv_clause_strategy = dcs + , deriv_clause_tys = L _ dct })) + = repDerivStrategy dcs $ \(MkC dcs') -> + do MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct + rep2 derivClauseName [dcs',dct'] + where + rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type)) + rep_deriv_ty ty = repLTy ty + +rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn + -> MetaM ([GenSymBind], [Core (M TH.Dec)]) +-- Represent signatures and methods in class/instance declarations. +-- See Note [Scoped type variables in quotes] +-- +-- Why not use 'repBinds': we have already created symbols for methods in +-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate +-- these fun_id via 'collectHsValBinders decs', which would lead to the +-- instance declarations failing in TH. +rep_meth_sigs_binds sigs binds + = do { let tvs = concatMap get_scoped_tvs sigs + ; ss <- mkGenSyms tvs + ; sigs1 <- addBinds ss $ rep_sigs sigs + ; binds1 <- addBinds ss $ rep_binds binds + ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) } + +------------------------------------------------------- +-- Signatures in a class decl, or a group of bindings +------------------------------------------------------- + +rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))] + -- We silently ignore ones we don't recognise +rep_sigs = concatMapM rep_sig + +rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_sig (L loc (TypeSig _ nms ty)) + = mapM (rep_wc_ty_sig sigDName loc ty) nms +rep_sig (L loc (PatSynSig _ nms ty)) + = mapM (rep_patsyn_ty_sig loc ty) nms +rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) + | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms + | otherwise = mapM (rep_ty_sig sigDName loc ty) nms +rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) +rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d loc fix_sig +rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (L loc (SpecSig _ nm tys ispec)) + = concatMapM (\t -> rep_specialise nm t ispec loc) tys +rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc +rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty +rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (L loc (CompleteMatchSig _ _st cls mty)) + = rep_complete_sig cls mty loc + +-- Desugar the explicit type variable binders in an 'LHsSigType', making +-- sure not to gensym them. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn] + -> MetaM (Core [M TH.TyVarBndrSpec]) +rep_ty_sig_tvs explicit_tvs + = let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } in + repListM tyVarBndrSpecTyConName rep_in_scope_tv + explicit_tvs + -- NB: Don't pass any implicit type variables to repList above + -- See Note [Don't quantify implicit type variables in quotes] + +-- Desugar a top-level type signature. Unlike 'repHsSigType', this +-- deliberately avoids gensymming the type variables. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_ty_sig mk_sig loc sig_ty nm + = do { nm1 <- lookupLOcc nm + ; ty1 <- rep_ty_sig' sig_ty + ; sig <- repProto mk_sig nm1 ty1 + ; return (loc, sig) } + +-- Desugar an 'LHsSigType', making sure not to gensym the type variables at +-- the front of the type signature. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig' :: LHsSigType GhcRn + -> MetaM (Core (M TH.Type)) +rep_ty_sig' sig_ty + | HsIB { hsib_body = hs_ty } <- sig_ty + , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty + = do { th_explicit_tvs <- rep_ty_sig_tvs explicit_tvs + ; th_ctxt <- repLContext ctxt + ; th_ty <- repLTy ty + ; if null explicit_tvs && null (unLoc ctxt) + then return th_ty + else repTForall th_explicit_tvs th_ctxt th_ty } + +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +-- represents a pattern synonym type signature; +-- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs" +-- +-- Don't create the implicit and explicit variables when desugaring signatures, +-- see Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_patsyn_ty_sig loc sig_ty nm + | HsIB { hsib_body = hs_ty } <- sig_ty + , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty + = do { nm1 <- lookupLOcc nm + ; th_univs <- rep_ty_sig_tvs univs + ; th_exis <- rep_ty_sig_tvs exis + + ; th_reqs <- repLContext reqs + ; th_provs <- repLContext provs + ; th_ty <- repLTy ty + ; ty1 <- repTForall th_univs th_reqs =<< + repTForall th_exis th_provs th_ty + ; sig <- repProto patSynSigDName nm1 ty1 + ; return (loc, sig) } + +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name + -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_wc_ty_sig mk_sig loc sig_ty nm + = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm + +rep_inline :: Located Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_inline nm ispec loc + = do { nm1 <- lookupLOcc nm + ; inline <- repInline $ inl_inline ispec + ; rm <- repRuleMatch $ inl_rule ispec + ; phases <- repPhases $ inl_act ispec + ; pragma <- repPragInl nm1 inline rm phases + ; return [(loc, pragma)] + } + +rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_specialise nm ty ispec loc + = do { nm1 <- lookupLOcc nm + ; ty1 <- repHsSigType ty + ; phases <- repPhases $ inl_act ispec + ; let inline = inl_inline ispec + ; pragma <- if noUserInlineSpec inline + then -- SPECIALISE + repPragSpec nm1 ty1 phases + else -- SPECIALISE INLINE + do { inline1 <- repInline inline + ; repPragSpecInl nm1 ty1 inline1 phases } + ; return [(loc, pragma)] + } + +rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_specialiseInst ty loc + = do { ty1 <- repHsSigType ty + ; pragma <- repPragSpecInst ty1 + ; return [(loc, pragma)] } + +repInline :: InlineSpec -> MetaM (Core TH.Inline) +repInline NoInline = dataCon noInlineDataConName +repInline Inline = dataCon inlineDataConName +repInline Inlinable = dataCon inlinableDataConName +repInline NoUserInline = notHandled "NOUSERINLINE" empty + +repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) +repRuleMatch ConLike = dataCon conLikeDataConName +repRuleMatch FunLike = dataCon funLikeDataConName + +repPhases :: Activation -> MetaM (Core TH.Phases) +repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i + ; dataCon' beforePhaseDataConName [arg] } +repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i + ; dataCon' fromPhaseDataConName [arg] } +repPhases _ = dataCon allPhasesDataConName + +rep_complete_sig :: Located [Located Name] + -> Maybe (Located Name) + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_complete_sig (L _ cls) mty loc + = do { mty' <- repMaybe nameTyConName lookupLOcc mty + ; cls' <- repList nameTyConName lookupLOcc cls + ; sig <- repPragComplete cls' mty' + ; return [(loc, sig)] } + +------------------------------------------------------- +-- Types +------------------------------------------------------- + +class RepTV flag flag' | flag -> flag' where + tyVarBndrName :: Name + repPlainTV :: Core TH.Name -> flag -> MetaM (Core (M (TH.TyVarBndr flag'))) + repKindedTV :: Core TH.Name -> flag -> Core (M TH.Kind) + -> MetaM (Core (M (TH.TyVarBndr flag'))) + +instance RepTV () () where + tyVarBndrName = tyVarBndrUnitTyConName + repPlainTV (MkC nm) () = rep2 plainTVName [nm] + repKindedTV (MkC nm) () (MkC ki) = rep2 kindedTVName [nm, ki] + +instance RepTV Specificity TH.Specificity where + tyVarBndrName = tyVarBndrSpecTyConName + repPlainTV (MkC nm) spec = do { (MkC spec') <- rep_flag spec + ; rep2 plainInvisTVName [nm, spec'] } + repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag spec + ; rep2 kindedInvisTVName [nm, spec', ki] } + +rep_flag :: Specificity -> MetaM (Core TH.Specificity) +rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] +rep_flag InferredSpec = rep2_nw inferredSpecName [] + +addSimpleTyVarBinds :: [Name] -- the binders to be added + -> MetaM (Core (M a)) -- action in the ext env + -> MetaM (Core (M a)) +addSimpleTyVarBinds names thing_inside + = do { fresh_names <- mkGenSyms names + ; term <- addBinds fresh_names thing_inside + ; wrapGenSyms fresh_names term } + +addHsTyVarBinds :: forall flag flag' a. RepTV flag flag' + => [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +addHsTyVarBinds exp_tvs thing_inside + = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) + ; term <- addBinds fresh_exp_names $ + do { kbs <- repListM (tyVarBndrName @flag @flag') mk_tv_bndr + (exp_tvs `zip` fresh_exp_names) + ; thing_inside kbs } + ; wrapGenSyms fresh_exp_names term } + where + mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) + +addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added + -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs + , hsq_explicit = exp_tvs }) + thing_inside + = addTyVarBinds exp_tvs imp_tvs thing_inside + +addTyVarBinds :: RepTV flag flag' + => [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> [Name] + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +-- gensym a list of type variables and enter them into the meta environment; +-- the computations passed as the second argument is executed in that extended +-- meta environment and gets the *new* names on Core-level as an argument +addTyVarBinds exp_tvs imp_tvs thing_inside + = addSimpleTyVarBinds imp_tvs $ + addHsTyVarBinds exp_tvs $ + thing_inside + +addTyClTyVarBinds :: LHsQTyVars GhcRn + -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +-- Used for data/newtype declarations, and family instances, +-- so that the nested type variables work right +-- instance C (T a) where +-- type W (T a) = blah +-- The 'a' in the type instance is the one bound by the instance decl +addTyClTyVarBinds tvs m + = do { let tv_names = hsAllLTyVarNames tvs + ; env <- lift $ dsGetMetaEnv + ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) + -- Make fresh names for the ones that are not already in scope + -- This makes things work for family declarations + + ; term <- addBinds freshNames $ + do { kbs <- repListM tyVarBndrUnitTyConName mk_tv_bndr + (hsQTvExplicit tvs) + ; m kbs } + + ; wrapGenSyms freshNames term } + where + mk_tv_bndr :: LHsTyVarBndr () GhcRn -> MetaM (Core (M (TH.TyVarBndr ()))) + mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv v } + +-- Produce kinded binder constructors from the Haskell tyvar binders +-- +repTyVarBndrWithKind :: RepTV flag flag' => LHsTyVarBndr flag GhcRn + -> Core TH.Name -> MetaM (Core (M (TH.TyVarBndr flag'))) +repTyVarBndrWithKind (L _ (UserTyVar _ fl _)) nm + = repPlainTV nm fl +repTyVarBndrWithKind (L _ (KindedTyVar _ fl _ ki)) nm + = do { ki' <- repLTy ki + ; repKindedTV nm fl ki' } + +-- | Represent a type variable binder +repTyVarBndr :: RepTV flag flag' + => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag'))) +repTyVarBndr (L _ (UserTyVar _ fl (L _ nm)) ) + = do { nm' <- lookupBinder nm + ; repPlainTV nm' fl } +repTyVarBndr (L _ (KindedTyVar _ fl (L _ nm) ki)) + = do { nm' <- lookupBinder nm + ; ki' <- repLTy ki + ; repKindedTV nm' fl ki' } + +-- represent a type context +-- +repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt)) +repLContext ctxt = repContext (unLoc ctxt) + +repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt)) +repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt + repCtxt preds + +repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) +repHsSigType (HsIB { hsib_ext = implicit_tvs + , hsib_body = body }) + | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body + = addSimpleTyVarBinds implicit_tvs $ + -- See Note [Don't quantify implicit type variables in quotes] + addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> + do { th_ctxt <- repLContext ctxt + ; th_ty <- repLTy ty + ; if null explicit_tvs && null (unLoc ctxt) + then return th_ty + else repTForall th_explicit_tvs th_ctxt th_ty } + +-- yield the representation of a list of types +repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)] +repLTys tys = mapM repLTy tys + +-- represent a type +repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type)) +repLTy ty = repTy (unLoc ty) + +-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or +-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. +-- In other words, the argument to this function is always an +-- @HsForAllTy HsForAllInvis{}@ or @HsQualTy@. +-- Types headed by visible foralls (which are desugared to ForallVisT) are +-- handled separately in repTy. +repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) +repForallT ty + | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty) + = addHsTyVarBinds tvs $ \bndrs -> + do { ctxt1 <- repLContext ctxt + ; tau1 <- repLTy tau + ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} + } + +repTy :: HsType GhcRn -> MetaM (Core (M TH.Type)) +repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) = + case tele of + HsForAllInvis{} -> repForallT ty + HsForAllVis { hsf_vis_bndrs = tvs } -> + addHsTyVarBinds tvs $ \bndrs -> + do body1 <- repLTy body + repTForallVis bndrs body1 +repTy ty@(HsQualTy {}) = repForallT ty + +repTy (HsTyVar _ _ (L _ n)) + | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` constraintKindTyConKey = repTConstraint + | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon + | n `hasKey` funTyConKey = repMulArrowTyCon + | isTvOcc occ = do tv1 <- lookupOcc n + repTvar tv1 + | isDataOcc occ = do tc1 <- lookupOcc n + repPromotedDataCon tc1 + | n == eqTyConName = repTequality + | otherwise = do tc1 <- lookupOcc n + repNamedTyCon tc1 + where + occ = nameOccName n + +repTy (HsAppTy _ f a) = do + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 +repTy (HsAppKindTy _ ty ki) = do + ty1 <- repLTy ty + ki1 <- repLTy ki + repTappKind ty1 ki1 +repTy (HsFunTy _ w f a) | isUnrestricted w = do + f1 <- repLTy f + a1 <- repLTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsFunTy _ w f a) = do w1 <- repLTy (arrowToHsType w) + f1 <- repLTy f + a1 <- repLTy a + tcon <- repMulArrowTyCon + repTapps tcon [w1, f1, a1] +repTy (HsListTy _ t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsTupleTy _ HsUnboxedTuple tys) = do + tys1 <- repLTys tys + tcon <- repUnboxedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsSumTy _ tys) = do tys1 <- repLTys tys + tcon <- repUnboxedSumTyCon (length tys) + repTapps tcon tys1 +repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy _ t) = repLTy t +repTy (HsStarTy _ _) = repTStar +repTy (HsKindSig _ t k) = do + t1 <- repLTy t + k1 <- repLTy k + repTSig t1 k1 +repTy (HsSpliceTy _ splice) = repSplice splice +repTy (HsExplicitListTy _ _ tys) = do + tys1 <- repLTys tys + repTPromotedList tys1 +repTy (HsExplicitTupleTy _ tys) = do + tys1 <- repLTys tys + tcon <- repPromotedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTyLit _ lit) = do + lit' <- repTyLit lit + repTLit lit' +repTy (HsWildCardTy _) = repTWildCard +repTy (HsIParamTy _ n t) = do + n' <- rep_implicit_param_name (unLoc n) + t' <- repLTy t + repTImplicitParam n' t' + +repTy ty = notHandled "Exotic form of type" (ppr ty) + +repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit)) +repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i] +repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s + ; rep2 strTyLitName [s'] + } + +-- | Represent a type wrapped in a Maybe +repMaybeLTy :: Maybe (LHsKind GhcRn) + -> MetaM (Core (Maybe (M TH.Type))) +repMaybeLTy m = do + k_ty <- wrapName kindTyConName + repMaybeT k_ty repLTy m + +repRole :: Located (Maybe Role) -> MetaM (Core TH.Role) +repRole (L _ (Just Nominal)) = rep2_nw nominalRName [] +repRole (L _ (Just Representational)) = rep2_nw representationalRName [] +repRole (L _ (Just Phantom)) = rep2_nw phantomRName [] +repRole (L _ Nothing) = rep2_nw inferRName [] + +----------------------------------------------------------------------------- +-- Splices +----------------------------------------------------------------------------- + +repSplice :: HsSplice GhcRn -> MetaM (Core a) +-- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice +-- We return a CoreExpr of any old type; the context should know +repSplice (HsTypedSplice _ _ n _) = rep_splice n +repSplice (HsUntypedSplice _ _ n _) = rep_splice n +repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n +repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) + +rep_splice :: Name -> MetaM (Core a) +rep_splice splice_name + = do { mb_val <- lift $ dsLookupMetaEnv splice_name + ; case mb_val of + Just (DsSplice e) -> do { e' <- lift $ dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr splice_name) } + -- Should not happen; statically checked + +----------------------------------------------------------------------------- +-- Expressions +----------------------------------------------------------------------------- + +repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)]) +repLEs es = repListM expTyConName repLE es + +-- FIXME: some of these panics should be converted into proper error messages +-- unless we can make sure that constructs, which are plainly not +-- supported in TH already lead to error messages at an earlier stage +repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp)) +repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e) + +repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp)) +repE (HsVar _ (L _ x)) = + do { mb_val <- lift $ dsLookupMetaEnv x + ; case mb_val of + Nothing -> do { str <- lift $ globalVar x + ; repVarOrCon x str } + Just (DsBound y) -> repVarOrCon x (coreVar y) + Just (DsSplice e) -> do { e' <- lift $ dsExpr e + ; return (MkC e') } } +repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar +repE (HsOverLabel _ _ s) = repOverLabel s + +repE e@(HsRecFld _ f) = case f of + Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) + Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) + + -- Remember, we're desugaring renamer output here, so + -- HsOverlit can definitely occur +repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } +repE (HsLit _ l) = do { a <- repLiteral l; repLit a } +repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = (L _ ms) })) + = do { ms' <- mapM repMatchTup ms + ; core_ms <- coreListM matchTyConName ms' + ; repLamCase core_ms } +repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} +repE (HsAppType _ e t) = do { a <- repLE e + ; s <- repLTy (hswc_body t) + ; repAppType a s } + +repE (OpApp _ e1 op e2) = + do { arg1 <- repLE e1; + arg2 <- repLE e2; + the_op <- repLE op ; + repInfixApp arg1 the_op arg2 } +repE (NegApp _ x _) = do + a <- repLE x + negateVar <- lookupOcc negateName >>= repVar + negateVar `repApp` a +repE (HsPar _ x) = repLE x +repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase _ e (MG { mg_alts = (L _ ms) })) + = do { arg <- repLE e + ; ms2 <- mapM repMatchTup ms + ; core_ms2 <- coreListM matchTyConName ms2 + ; repCaseE arg core_ms2 } +repE (HsIf _ x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z + repCond a b c +repE (HsMultiIf _ alts) + = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts + ; expr' <- repMultiIf (nonEmptyCoreList alts') + ; wrapGenSyms (concat binds) expr' } +repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } + +-- FIXME: I haven't got the types here right yet +repE e@(HsDo _ ctxt (L _ sts)) + | Just maybeModuleName <- case ctxt of + { DoExpr m -> Just m; GhciStmtCtxt -> Just Nothing; _ -> Nothing } + = do { (ss,zs) <- repLSts sts; + e' <- repDoE maybeModuleName (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | ListComp <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repComp (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | MDoExpr maybeModuleName <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repMDoE maybeModuleName (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | otherwise + = notHandled "monad comprehension and [: :]" (ppr e) + +repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } +repE (ExplicitTuple _ es boxity) = + let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) + tupArgToCoreExp (L _ a) + | (Present _ e) <- a = do { e' <- repLE e + ; coreJustM expTyConName e' } + | otherwise = coreNothingM expTyConName + + in do { args <- mapM tupArgToCoreExp es + ; expTy <- wrapName expTyConName + ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy] + listArg = coreList' maybeExpQTy args + ; if isBoxed boxity + then repTup listArg + else repUnboxedTup listArg } + +repE (ExplicitSum _ alt arity e) + = do { e1 <- repLE e + ; repUnboxedSum e1 alt arity } + +repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) + = do { x <- lookupLOcc c; + fs <- repFields flds; + repRecCon x fs } +repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) + = do { x <- repLE e; + fs <- repUpdFields flds; + repRecUpd x fs } + +repE (ExprWithTySig _ e wc_ty) + = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $ + do { e1 <- repLE e + ; t1 <- rep_ty_sig' sig_ty + ; repSigExp e1 t1 } + where + sig_ty = dropWildCards wc_ty + +repE (ArithSeq _ _ aseq) = + case aseq of + From e -> do { ds1 <- repLE e; repFrom ds1 } + FromThen e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromThen ds1 ds2 + FromTo e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromTo ds1 ds2 + FromThenTo e1 e2 e3 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + ds3 <- repLE e3 + repFromThenTo ds1 ds2 ds3 + +repE (HsSpliceE _ splice) = repSplice splice +repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC +repE (HsUnboundVar _ uv) = do + occ <- occNameLit uv + sname <- repNameS occ + repUnboundVar sname +repE (XExpr (HsExpanded _ b)) = repE b +repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) +repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) +repE e = notHandled "Expression form" (ppr e) + +----------------------------------------------------------------------------- +-- Building representations of auxiliary structures like Match, Clause, Stmt, + +repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) +repMatchTup (L _ (Match { m_pats = [p] + , m_grhss = GRHSs _ guards (L _ wheres) })) = + do { ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + ; gs <- repGuards guards + ; match <- repMatch p1 gs ds + ; wrapGenSyms (ss1++ss2) match }}} +repMatchTup _ = panic "repMatchTup: case alt with more than one arg" + +repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) +repClauseTup (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ guards (L _ wheres) })) = + do { ss1 <- mkGenSyms (collectPatsBinders ps) + ; addBinds ss1 $ do { + ps1 <- repLPs ps + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + gs <- repGuards guards + ; clause <- repClause ps1 gs ds + ; wrapGenSyms (ss1++ss2) clause }}} + +repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body)) +repGuards [L _ (GRHS _ [] e)] + = do {a <- repLE e; repNormal a } +repGuards other + = do { zs <- mapM repLGRHS other + ; let (xs, ys) = unzip zs + ; gd <- repGuarded (nonEmptyCoreList ys) + ; wrapGenSyms (concat xs) gd } + +repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) + -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp)))) +repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) + = do { guarded <- repLNormalGE e1 e2 + ; return ([], guarded) } +repLGRHS (L _ (GRHS _ ss rhs)) + = do { (gs, ss') <- repLSts ss + ; rhs' <- addBinds gs $ repLE rhs + ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' + ; return (gs, guarded) } + +repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp]) +repFields (HsRecFields { rec_flds = flds }) + = repListM fieldExpTyConName rep_fld flds + where + rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) + -> MetaM (Core (M TH.FieldExp)) + rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } + +repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) +repUpdFields = repListM fieldExpTyConName rep_fld + where + rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp)) + rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of + Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } + Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld) + + + +----------------------------------------------------------------------------- +-- Representing Stmt's is tricky, especially if bound variables +-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] +-- First gensym new names for every variable in any of the patterns. +-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) +-- if variables didn't shadow, the static gensym wouldn't be necessary +-- and we could reuse the original names (x and x). +-- +-- do { x'1 <- gensym "x" +-- ; x'2 <- gensym "x" +-- ; doE Nothing +-- [ BindSt (pvar x'1) [| f 1 |] +-- , BindSt (pvar x'2) [| f x |] +-- , NoBindSt [| g x |] +-- ] +-- } + +-- The strategy is to translate a whole list of do-bindings by building a +-- bigger environment, and a bigger set of meta bindings +-- (like: x'1 <- gensym "x" ) and then combining these with the translations +-- of the expressions within the Do + +----------------------------------------------------------------------------- +-- The helper function repSts computes the translation of each sub expression +-- and a bunch of prefix bindings denoting the dynamic renaming. + +repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) +repLSts stmts = repSts (map unLoc stmts) + +repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) +repSts (BindStmt _ p e : ss) = + do { e2 <- repLE e + ; ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p; + ; (ss2,zs) <- repSts ss + ; z <- repBindSt p1 e2 + ; return (ss1++ss2, z : zs) }} +repSts (LetStmt _ (L _ bs) : ss) = + do { (ss1,ds) <- repBinds bs + ; z <- repLetSt ds + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts (BodyStmt _ e _ _ : ss) = + do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; (ss2,zs) <- repSts ss + ; return (ss2, z : zs) } +repSts (ParStmt _ stmt_blocks _ _ : ss) = + do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks + ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 + ss1 = concat ss_s + ; z <- repParSt stmt_blocks2 + ; (ss2, zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } + where + rep_stmt_block :: ParStmtBlock GhcRn GhcRn + -> MetaM ([GenSymBind], Core [(M TH.Stmt)]) + rep_stmt_block (ParStmtBlock _ stmts _ _) = + do { (ss1, zs) <- repSts (map unLoc stmts) + ; zs1 <- coreListM stmtTyConName zs + ; return (ss1, zs1) } +repSts [LastStmt _ e _ _] + = do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; return ([], [z]) } +repSts (stmt@RecStmt{} : ss) + = do { let binders = collectLStmtsBinders (recS_stmts stmt) + ; ss1 <- mkGenSyms binders + -- Bring all of binders in the recursive group into scope for the + -- whole group. + ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt)) + ; MASSERT(sort ss1 == sort ss1_other) + ; z <- repRecSt (nonEmptyCoreList rss) + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts [] = return ([],[]) +repSts other = notHandled "Exotic statement" (ppr other) + + +----------------------------------------------------------- +-- Bindings +----------------------------------------------------------- + +repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)]) +repBinds (EmptyLocalBinds _) + = do { core_list <- coreListM decTyConName [] + ; return ([], core_list) } + +repBinds (HsIPBinds _ (IPBinds _ decs)) + = do { ips <- mapM rep_implicit_param_bind decs + ; core_list <- coreListM decTyConName + (de_loc (sort_by_loc ips)) + ; return ([], core_list) + } + +repBinds (HsValBinds _ decs) + = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } + -- No need to worry about detailed scopes within + -- the binding group, because we are talking Names + -- here, so we can safely treat it as a mutually + -- recursive group + -- For hsScopedTvBinders see Note [Scoped type variables in quotes] + ; ss <- mkGenSyms bndrs + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreListM decTyConName + (de_loc (sort_by_loc prs)) + ; return (ss, core_list) } + +rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) + = do { name <- case ename of + Left (L _ n) -> rep_implicit_param_name n + Right _ -> + panic "rep_implicit_param_bind: post typechecking" + ; rhs' <- repE rhs + ; ipb <- repImplicitParamBind name rhs' + ; return (loc, ipb) } + +rep_implicit_param_name :: HsIPName -> MetaM (Core String) +rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) + +rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +-- Assumes: all the binders of the binding are already in the meta-env +rep_val_binds (XValBindsLR (NValBinds binds sigs)) + = do { core1 <- rep_binds (unionManyBags (map snd binds)) + ; core2 <- rep_sigs sigs + ; return (core1 ++ core2) } +rep_val_binds (ValBinds _ _ _) + = panic "rep_val_binds: ValBinds" + +rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_binds = mapM rep_bind . bagToList + +rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) +-- Assumes: all the binders of the binding are already in the meta-env + +-- Note GHC treats declarations of a variable (not a pattern) +-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match +-- with an empty list of patterns +rep_bind (L loc (FunBind + { fun_id = fn, + fun_matches = MG { mg_alts + = (L _ [L _ (Match + { m_pats = [] + , m_grhss = GRHSs _ guards (L _ wheres) } + )]) } })) + = do { (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; fn' <- lookupLBinder fn + ; p <- repPvar fn' + ; ans <- repVal p guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (loc, ans') } + +rep_bind (L loc (FunBind { fun_id = fn + , fun_matches = MG { mg_alts = L _ ms } })) + = do { ms1 <- mapM repClauseTup ms + ; fn' <- lookupLBinder fn + ; ans <- repFun fn' (nonEmptyCoreList ms1) + ; return (loc, ans) } + +rep_bind (L loc (PatBind { pat_lhs = pat + , pat_rhs = GRHSs _ guards (L _ wheres) })) + = do { patcore <- repLP pat + ; (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; ans <- repVal patcore guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (loc, ans') } + +rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) + = do { v' <- lookupBinder v + ; e2 <- repLE e + ; x <- repNormal e2 + ; patcore <- repPvar v' + ; empty_decls <- coreListM decTyConName [] + ; ans <- repVal patcore x empty_decls + ; return (srcLocSpan (getSrcLoc v), ans) } + +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn + , psb_args = args + , psb_def = pat + , psb_dir = dir }))) + = do { syn' <- lookupLBinder syn + ; dir' <- repPatSynDir dir + ; ss <- mkGenArgSyms args + ; patSynD' <- addBinds ss ( + do { args' <- repPatSynArgs args + ; pat' <- repLP pat + ; repPatSynD syn' args' dir' pat' }) + ; patSynD'' <- wrapGenArgSyms args ss patSynD' + ; return (loc, patSynD'') } + where + mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind] + -- for Record Pattern Synonyms we want to conflate the selector + -- and the pattern-only names in order to provide a nicer TH + -- API. Whereas inside GHC, record pattern synonym selectors and + -- their pattern-only bound right hand sides have different names, + -- we want to treat them the same in TH. This is the reason why we + -- need an adjusted mkGenArgSyms in the `RecCon` case below. + mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) + mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] + mkGenArgSyms (RecCon fields) + = do { let pats = map (unLoc . recordPatSynPatVar) fields + sels = map (unLoc . recordPatSynSelectorId) fields + ; ss <- mkGenSyms sels + ; return $ replaceNames (zip sels pats) ss } + + replaceNames selsPats genSyms + = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats + , sel == sel' ] + + wrapGenArgSyms :: HsPatSynDetails (Located Name) + -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec)) + wrapGenArgSyms (RecCon _) _ dec = return dec + wrapGenArgSyms _ ss dec = wrapGenSyms ss dec + +repPatSynD :: Core TH.Name + -> Core (M TH.PatSynArgs) + -> Core (M TH.PatSynDir) + -> Core (M TH.Pat) + -> MetaM (Core (M TH.Dec)) +repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) + = rep2 patSynDName [syn, args, dir, pat] + +repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs)) +repPatSynArgs (PrefixCon args) + = do { args' <- repList nameTyConName lookupLOcc args + ; repPrefixPatSynArgs args' } +repPatSynArgs (InfixCon arg1 arg2) + = do { arg1' <- lookupLOcc arg1 + ; arg2' <- lookupLOcc arg2 + ; repInfixPatSynArgs arg1' arg2' } +repPatSynArgs (RecCon fields) + = do { sels' <- repList nameTyConName lookupLOcc sels + ; repRecordPatSynArgs sels' } + where sels = map recordPatSynSelectorId fields + +repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs)) +repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] + +repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs)) +repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2] + +repRecordPatSynArgs :: Core [TH.Name] + -> MetaM (Core (M TH.PatSynArgs)) +repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] + +repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir)) +repPatSynDir Unidirectional = rep2 unidirPatSynName [] +repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] +repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) + = do { clauses' <- mapM repClauseTup clauses + ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } + +repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir)) +repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] + + +----------------------------------------------------------------------------- +-- Since everything in a Bind is mutually recursive we need rename all +-- all the variables simultaneously. For example: +-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to +-- do { f'1 <- gensym "f" +-- ; g'2 <- gensym "g" +-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, +-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} +-- ]} +-- This requires collecting the bindings (f'1 <- gensym "f"), and the +-- environment ( f |-> f'1 ) from each binding, and then unioning them +-- together. As we do this we collect GenSymBinds's which represent the renamed +-- variables bound by the Bindings. In order not to lose track of these +-- representations we build a shadow datatype MB with the same structure as +-- MonoBinds, but which has slots for the representations + + +----------------------------------------------------------------------------- +-- GHC allows a more general form of lambda abstraction than specified +-- by Haskell 98. In particular it allows guarded lambda's like : +-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in +-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like +-- (\ p1 .. pn -> exp) by causing an error. + +repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) +repLambda (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] + (L _ (EmptyLocalBinds _)) } )) + = do { let bndrs = collectPatsBinders ps ; + ; ss <- mkGenSyms bndrs + ; lam <- addBinds ss ( + do { xs <- repLPs ps; body <- repLE e; repLam xs body }) + ; wrapGenSyms ss lam } + +repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) + + +----------------------------------------------------------------------------- +-- Patterns +-- repP deals with patterns. It assumes that we have already +-- walked over the pattern(s) once to collect the binders, and +-- have extended the environment. So every pattern-bound +-- variable should already appear in the environment. + +-- Process a list of patterns +repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)]) +repLPs ps = repListM patTyConName repLP ps + +repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) +repLP p = repP (unLoc p) + +repP :: Pat GhcRn -> MetaM (Core (M TH.Pat)) +repP (WildPat _) = repPwild +repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } +repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } +repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } +repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p + ; repPaspat x' p1 } +repP (ParPat _ p) = repLP p +repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps) + ; e' <- repE e + ; repPview e' p} +repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps) +repP (TuplePat _ ps boxed) + | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } + | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } +repP (SumPat _ p alt arity) = do { p1 <- repLP p + ; repPunboxedSum p1 alt arity } +repP (ConPat NoExtField dc details) + = do { con_str <- lookupLOcc dc + ; case details of + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec) + ; repPrec con_str fps } + InfixCon p1 p2 -> do { p1' <- repLP p1; + p2' <- repLP p2; + repPinfix p1' con_str p2' } + } + where + rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat))) + rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } + +repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l + ; repPlit a } +repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } +repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) +repP (SigPat _ p t) = do { p' <- repLP p + ; t' <- repLTy (hsPatSigType t) + ; repPsig p' t' } +repP (SplicePat _ splice) = repSplice splice +repP other = notHandled "Exotic pattern" (ppr other) + +---------------------------------------------------------- +-- Declaration ordering helpers + +sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] +sort_by_loc = sortBy (SrcLoc.leftmost_smallest `on` fst) + +de_loc :: [(a, b)] -> [b] +de_loc = map snd + +---------------------------------------------------------- +-- The meta-environment + +-- A name/identifier association for fresh names of locally bound entities +type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id + -- I.e. (x, x_id) means + -- let x_id = gensym "x" in ... + +-- Generate a fresh name for a locally bound entity + +mkGenSyms :: [Name] -> MetaM [GenSymBind] +-- We can use the existing name. For example: +-- [| \x_77 -> x_77 + x_77 |] +-- desugars to +-- do { x_77 <- genSym "x"; .... } +-- We use the same x_77 in the desugared program, but with the type Bndr +-- instead of Int +-- +-- We do make it an Internal name, though (hence localiseName) +-- +-- Nevertheless, it's monadic because we have to generate nameTy +mkGenSyms ns = do { var_ty <- lookupType nameTyConName + ; return [(nm, mkLocalId (localiseName nm) Many var_ty) | nm <- ns] } + + +addBinds :: [GenSymBind] -> MetaM a -> MetaM a +-- Add a list of fresh names for locally bound entities to the +-- meta environment (which is part of the state carried around +-- by the desugarer monad) +addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m + +-- Look up a locally bound name +-- +lookupLBinder :: Located Name -> MetaM (Core TH.Name) +lookupLBinder n = lookupBinder (unLoc n) + +lookupBinder :: Name -> MetaM (Core TH.Name) +lookupBinder = lookupOcc + -- Binders are brought into scope before the pattern or what-not is + -- desugared. Moreover, in instance declaration the binder of a method + -- will be the selector Id and hence a global; so we need the + -- globalVar case of lookupOcc + +-- Look up a name that is either locally bound or a global name +-- +-- * If it is a global name, generate the "original name" representation (ie, +-- the : form) for the associated entity +-- +lookupLOcc :: Located Name -> MetaM (Core TH.Name) +-- Lookup an occurrence; it can't be a splice. +-- Use the in-scope bindings if they exist +lookupLOcc n = lookupOcc (unLoc n) + +lookupOcc :: Name -> MetaM (Core TH.Name) +lookupOcc = lift . lookupOccDsM + +lookupOccDsM :: Name -> DsM (Core TH.Name) +lookupOccDsM n + = do { mb_val <- dsLookupMetaEnv n ; + case mb_val of + Nothing -> globalVar n + Just (DsBound x) -> return (coreVar x) + Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) + } + +globalVar :: Name -> DsM (Core TH.Name) +-- Not bound by the meta-env +-- Could be top-level; or could be local +-- f x = $(g [| x |]) +-- Here the x will be local +globalVar name + | isExternalName name + = do { MkC mod <- coreStringLit name_mod + ; MkC pkg <- coreStringLit name_pkg + ; MkC occ <- nameLit name + ; rep2_nwDsM mk_varg [pkg,mod,occ] } + | otherwise + = do { MkC occ <- nameLit name + ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name)) + ; rep2_nwDsM mkNameLName [occ,uni] } + where + mod = ASSERT( isExternalName name) nameModule name + name_mod = moduleNameString (moduleName mod) + name_pkg = unitString (moduleUnit mod) + name_occ = nameOccName name + mk_varg | isDataOcc name_occ = mkNameG_dName + | isVarOcc name_occ = mkNameG_vName + | isTcOcc name_occ = mkNameG_tcName + | otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name) + +lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) + -> MetaM Type -- The type +lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ; + return (mkTyConApp tc []) } + +wrapGenSyms :: [GenSymBind] + -> Core (M a) -> MetaM (Core (M a)) +-- wrapGenSyms [(nm1,id1), (nm2,id2)] y +-- --> bindQ (gensym nm1) (\ id1 -> +-- bindQ (gensym nm2 (\ id2 -> +-- y)) + +wrapGenSyms binds body@(MkC b) + = do { var_ty <- lookupType nameTyConName + ; go var_ty binds } + where + (_, elt_ty) = tcSplitAppTy (exprType b) + -- b :: m a, so we can get the type 'a' by looking at the + -- argument type. Need to use `tcSplitAppTy` here as since + -- the overloaded quotations patch the type of the expression can + -- be something more complicated than just `Q a`. + -- See #17839 for when this went wrong with the type `WriterT () m a` + + go _ [] = return body + go var_ty ((name,id) : binds) + = do { MkC body' <- go var_ty binds + ; lit_str <- lift $ nameLit name + ; gensym_app <- repGensym lit_str + ; repBindM var_ty elt_ty + gensym_app (MkC (Lam id body')) } + +nameLit :: Name -> DsM (Core String) +nameLit n = coreStringLit (occNameString (nameOccName n)) + +occNameLit :: OccName -> MetaM (Core String) +occNameLit name = coreStringLit (occNameString name) + + +-- %********************************************************************* +-- %* * +-- Constructing code +-- %* * +-- %********************************************************************* + +----------------------------------------------------------------------------- +-- PHANTOM TYPES for consistency. In order to make sure we do this correct +-- we invent a new datatype which uses phantom types. + +newtype Core a = MkC CoreExpr +unC :: Core a -> CoreExpr +unC (MkC x) = x + +type family NotM a where + NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type")) + NotM _other = (() :: Constraint) + +rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a)) +rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a)) +rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a) +rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a) +rep2 = rep2X lift (asks quoteWrapper) +rep2M = rep2X lift (asks monadWrapper) +rep2_nw n xs = lift (rep2_nwDsM n xs) +rep2_nwDsM = rep2X id (return id) + +rep2X :: Monad m => (forall z . DsM z -> m z) + -> m (CoreExpr -> CoreExpr) + -> Name + -> [ CoreExpr ] + -> m (Core a) +rep2X lift_dsm get_wrap n xs = do + { rep_id <- lift_dsm $ dsLookupGlobalId n + ; wrap <- get_wrap + ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) } + + +dataCon' :: Name -> [CoreExpr] -> MetaM (Core a) +dataCon' n args = do { id <- lift $ dsLookupDataCon n + ; return $ MkC $ mkCoreConApps id args } + +dataCon :: Name -> MetaM (Core a) +dataCon n = dataCon' n [] + + +-- %********************************************************************* +-- %* * +-- The 'smart constructors' +-- %* * +-- %********************************************************************* + +--------------- Patterns ----------------- +repPlit :: Core TH.Lit -> MetaM (Core (M TH.Pat)) +repPlit (MkC l) = rep2 litPName [l] + +repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat)) +repPvar (MkC s) = rep2 varPName [s] + +repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPtup (MkC ps) = rep2 tupPName [ps] + +repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] + +repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat)) +-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here +repPunboxedSum (MkC p) alt arity + = do { platform <- getPlatform + ; rep2 unboxedSumPName [ p + , mkIntExprInt platform alt + , mkIntExprInt platform arity ] } + +repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] + +repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] + +repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] + +repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPtilde (MkC p) = rep2 tildePName [p] + +repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPbang (MkC p) = rep2 bangPName [p] + +repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] + +repPwild :: MetaM (Core (M TH.Pat)) +repPwild = rep2 wildPName [] + +repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) +repPlist (MkC ps) = rep2 listPName [ps] + +repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) +repPview (MkC e) (MkC p) = rep2 viewPName [e,p] + +repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat)) +repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] + +--------------- Expressions ----------------- +repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp)) +repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str + | otherwise = repVar str + +repVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repVar (MkC s) = rep2 varEName [s] + +repCon :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repCon (MkC s) = rep2 conEName [s] + +repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp)) +repLit (MkC c) = rep2 litEName [c] + +repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repApp (MkC x) (MkC y) = rep2 appEName [x,y] + +repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) +repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] + +repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] + +repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) +repLamCase (MkC ms) = rep2 lamCaseEName [ms] + +repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repTup (MkC es) = rep2 tupEName [es] + +repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] + +repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp)) +-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here +repUnboxedSum (MkC e) alt arity + = do { platform <- getPlatform + ; rep2 unboxedSumEName [ e + , mkIntExprInt platform alt + , mkIntExprInt platform arity ] } + +repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] + +repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp)) +repMultiIf (MkC alts) = rep2 multiIfEName [alts] + +repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] + +repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) +repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] + +repDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repDoE = repDoBlock doEName + +repMDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repMDoE = repDoBlock mdoEName + +repDoBlock :: Name -> Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repDoBlock doName maybeModName (MkC ss) = do + MkC coreModName <- coreModNameM + rep2 doName [coreModName, ss] + where + coreModNameM :: MetaM (Core (Maybe TH.ModName)) + coreModNameM = case maybeModName of + Just m -> do + MkC s <- coreStringLit (moduleNameString m) + mName <- rep2_nw mkModNameName [s] + coreJust modNameTyConName mName + _ -> coreNothing modNameTyConName + +repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) +repComp (MkC ss) = rep2 compEName [ss] + +repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp)) +repListExp (MkC es) = rep2 listEName [es] + +repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) +repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] + +repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp)) +repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] + +repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp)) +repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] + +repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp)) +repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] + +repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] + +repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] + +repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] + +repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp)) +repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x] + +------------ Right hand sides (guarded expressions) ---- +repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body)) +repGuarded (MkC pairs) = rep2 guardedBName [pairs] + +repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body)) +repNormal (MkC e) = rep2 normalBName [e] + +------------ Guards ---- +repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn + -> MetaM (Core (M (TH.Guard, TH.Exp))) +repLNormalGE g e = do g' <- repLE g + e' <- repLE e + repNormalGE g' e' + +repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) +repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] + +repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp))) +repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] + +------------- Stmts ------------------- +repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) +repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] + +repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt)) +repLetSt (MkC ds) = rep2 letSName [ds] + +repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt)) +repNoBindSt (MkC e) = rep2 noBindSName [e] + +repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt)) +repParSt (MkC sss) = rep2 parSName [sss] + +repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt)) +repRecSt (MkC ss) = rep2 recSName [ss] + +-------------- Range (Arithmetic sequences) ----------- +repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFrom (MkC x) = rep2 fromEName [x] + +repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] + +repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] + +repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] + +------------ Match and Clause Tuples ----------- +repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match)) +repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] + +repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause)) +repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] + +-------------- Dec ----------------------------- +repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) +repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] + +repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec)) +repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] + +repData :: Core (M TH.Cxt) -> Core TH.Name + -> Either (Core [(M (TH.TyVarBndr ()))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) + -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] + -> MetaM (Core (M TH.Dec)) +repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) + = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] +repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) + (MkC derivs) + = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] + +repNewtype :: Core (M TH.Cxt) -> Core TH.Name + -> Either (Core [(M (TH.TyVarBndr ()))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) + -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause] + -> MetaM (Core (M TH.Dec)) +repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] +repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] + +repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] + -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repTySyn (MkC nm) (MkC tvs) (MkC rhs) + = rep2 tySynDName [nm, tvs, rhs] + +repInst :: Core (Maybe TH.Overlap) -> + Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) +repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName + [o, cxt, ty, ds] + +repDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +repDerivStrategy mds thing_inside = + case mds of + Nothing -> thing_inside =<< nothing + Just ds -> + case unLoc ds of + StockStrategy -> thing_inside =<< just =<< repStockStrategy + AnyclassStrategy -> thing_inside =<< just =<< repAnyclassStrategy + NewtypeStrategy -> thing_inside =<< just =<< repNewtypeStrategy + ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $ + do ty' <- rep_ty_sig' ty + via_strat <- repViaStrategy ty' + m_via_strat <- just via_strat + thing_inside m_via_strat + where + nothing = coreNothingM derivStrategyTyConName + just = coreJustM derivStrategyTyConName + +repStockStrategy :: MetaM (Core (M TH.DerivStrategy)) +repStockStrategy = rep2 stockStrategyName [] + +repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy)) +repAnyclassStrategy = rep2 anyclassStrategyName [] + +repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy)) +repNewtypeStrategy = rep2 newtypeStrategyName [] + +repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy)) +repViaStrategy (MkC t) = rep2 viaStrategyName [t] + +repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap)) +repOverlap mb = + case mb of + Nothing -> nothing + Just o -> + case o of + NoOverlap _ -> nothing + Overlappable _ -> just =<< dataCon overlappableDataConName + Overlapping _ -> just =<< dataCon overlappingDataConName + Overlaps _ -> just =<< dataCon overlapsDataConName + Incoherent _ -> just =<< dataCon incoherentDataConName + where + nothing = coreNothing overlapTyConName + just = coreJust overlapTyConName + + +repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr ()))] + -> Core [TH.FunDep] -> Core [(M TH.Dec)] + -> MetaM (Core (M TH.Dec)) +repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) + = rep2 classDName [cxt, cls, tvs, fds, ds] + +repDeriv :: Core (Maybe (M TH.DerivStrategy)) + -> Core (M TH.Cxt) -> Core (M TH.Type) + -> MetaM (Core (M TH.Dec)) +repDeriv (MkC ds) (MkC cxt) (MkC ty) + = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty] + +repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) + = rep2 pragInlDName [nm, inline, rm, phases] + +repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases + -> MetaM (Core (M TH.Dec)) +repPragSpec (MkC nm) (MkC ty) (MkC phases) + = rep2 pragSpecDName [nm, ty, phases] + +repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) + = rep2 pragSpecInlDName [nm, ty, inline, phases] + +repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] + +repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec)) +repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] + +repPragRule :: Core String -> Core (Maybe [(M (TH.TyVarBndr ()))]) + -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp) + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) +repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) + = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases] + +repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) +repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] + +repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec)) +repTySynInst (MkC eqn) + = rep2 tySynInstDName [eqn] + +repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] + -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec)) +repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) + = rep2 dataFamilyDName [nm, tvs, kind] + +repOpenFamilyD :: Core TH.Name + -> Core [(M (TH.TyVarBndr ()))] + -> Core (M TH.FamilyResultSig) + -> Core (Maybe TH.InjectivityAnn) + -> MetaM (Core (M TH.Dec)) +repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) + = rep2 openTypeFamilyDName [nm, tvs, result, inj] + +repClosedFamilyD :: Core TH.Name + -> Core [(M (TH.TyVarBndr ()))] + -> Core (M TH.FamilyResultSig) + -> Core (Maybe TH.InjectivityAnn) + -> Core [(M TH.TySynEqn)] + -> MetaM (Core (M TH.Dec)) +repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) + = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] + +repTySynEqn :: Core (Maybe [(M (TH.TyVarBndr ()))]) -> + Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn)) +repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) + = rep2 tySynEqnName [mb_bndrs, lhs, rhs] + +repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec)) +repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] + +repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep) +repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys] + +repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) +repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] + +repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) +repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] + +repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) +repCtxt (MkC tys) = rep2 cxtName [tys] + +repDataCon :: Located Name + -> HsConDeclDetails GhcRn + -> MetaM (Core (M TH.Con)) +repDataCon con details + = do con' <- lookupLOcc con -- See Note [Binders and occurrences] + repConstr details Nothing [con'] + +repGadtDataCons :: [Located Name] + -> HsConDeclDetails GhcRn + -> LHsType GhcRn + -> MetaM (Core (M TH.Con)) +repGadtDataCons cons details res_ty + = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + repConstr details (Just res_ty) cons' + +-- Invariant: +-- * for plain H98 data constructors second argument is Nothing and third +-- argument is a singleton list +-- * for GADTs data constructors second argument is (Just return_type) and +-- third argument is a non-empty list +repConstr :: HsConDeclDetails GhcRn + -> Maybe (LHsType GhcRn) + -> [Core TH.Name] + -> MetaM (Core (M TH.Con)) +repConstr (PrefixCon ps) Nothing [con] + = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) + rep2 normalCName [unC con, unC arg_tys] + +repConstr (PrefixCon ps) (Just res_ty) cons + = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) + res_ty' <- repLTy res_ty + rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] + +repConstr (RecCon ips) resTy cons + = do args <- concatMapM rep_ip (unLoc ips) + arg_vtys <- coreListM varBangTypeTyConName args + case resTy of + Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] + Just res_ty -> do + res_ty' <- repLTy res_ty + rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, + unC res_ty'] + + where + rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) + + rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType)) + rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) + ; MkC ty <- repBangTy t + ; rep2 varBangTypeName [v,ty] } + +repConstr (InfixCon st1 st2) Nothing [con] + = do arg1 <- repBangTy (hsScaledThing st1) + arg2 <- repBangTy (hsScaledThing st2) + rep2 infixCName [unC arg1, unC con, unC arg2] + +repConstr (InfixCon {}) (Just _) _ = + panic "repConstr: infix GADT constructor should be in a PrefixCon" +repConstr _ _ _ = + panic "repConstr: invariant violated" + +------------ Types ------------------- + +repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTForall (MkC tvars) (MkC ctxt) (MkC ty) + = rep2 forallTName [tvars, ctxt, ty] + +repTForallVis :: Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] + +repTvar :: Core TH.Name -> MetaM (Core (M TH.Type)) +repTvar (MkC s) = rep2 varTName [s] + +repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) +repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] + +repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) +repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki] + +repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) +repTapps f [] = return f +repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } + +repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type)) +repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] + +repTequality :: MetaM (Core (M TH.Type)) +repTequality = rep2 equalityTName [] + +repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type)) +repTPromotedList [] = repPromotedNilTyCon +repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon + ; f <- repTapp tcon t + ; t' <- repTPromotedList ts + ; repTapp f t' + } + +repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type)) +repTLit (MkC lit) = rep2 litTName [lit] + +repTWildCard :: MetaM (Core (M TH.Type)) +repTWildCard = rep2 wildCardTName [] + +repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) +repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e] + +repTStar :: MetaM (Core (M TH.Type)) +repTStar = rep2 starKName [] + +repTConstraint :: MetaM (Core (M TH.Type)) +repTConstraint = rep2 constraintKName [] + +--------- Type constructors -------------- + +repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type)) +repNamedTyCon (MkC s) = rep2 conTName [s] + +repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type) + -> MetaM (Core (M TH.Type)) +repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] + +repTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +-- Note: not Core Int; it's easier to be direct here +repTupleTyCon i = do platform <- getPlatform + rep2 tupleTName [mkIntExprInt platform i] + +repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +-- Note: not Core Int; it's easier to be direct here +repUnboxedTupleTyCon i = do platform <- getPlatform + rep2 unboxedTupleTName [mkIntExprInt platform i] + +repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type)) +-- Note: not Core TH.SumArity; it's easier to be direct here +repUnboxedSumTyCon arity = do platform <- getPlatform + rep2 unboxedSumTName [mkIntExprInt platform arity] + +repArrowTyCon :: MetaM (Core (M TH.Type)) +repArrowTyCon = rep2 arrowTName [] + +repMulArrowTyCon :: MetaM (Core (M TH.Type)) +repMulArrowTyCon = rep2 mulArrowTName [] + +repListTyCon :: MetaM (Core (M TH.Type)) +repListTyCon = rep2 listTName [] + +repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type)) +repPromotedDataCon (MkC s) = rep2 promotedTName [s] + +repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) +repPromotedTupleTyCon i = do platform <- getPlatform + rep2 promotedTupleTName [mkIntExprInt platform i] + +repPromotedNilTyCon :: MetaM (Core (M TH.Type)) +repPromotedNilTyCon = rep2 promotedNilTName [] + +repPromotedConsTyCon :: MetaM (Core (M TH.Type)) +repPromotedConsTyCon = rep2 promotedConsTName [] + +---------------------------------------------------------- +-- Type family result signature + +repNoSig :: MetaM (Core (M TH.FamilyResultSig)) +repNoSig = rep2 noSigName [] + +repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig)) +repKindSig (MkC ki) = rep2 kindSigName [ki] + +repTyVarSig :: Core (M (TH.TyVarBndr ())) -> MetaM (Core (M TH.FamilyResultSig)) +repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] + +---------------------------------------------------------- +-- Literals + +repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) +repLiteral (HsStringPrim _ bs) + = do platform <- getPlatform + word8_ty <- lookupType word8TyConName + let w8s = unpack bs + w8s_expr = map (\w8 -> mkCoreConApps word8DataCon + [mkWordLit platform (toInteger w8)]) w8s + rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] +repLiteral lit + = do lit' <- case lit of + HsIntPrim _ i -> mk_integer i + HsWordPrim _ w -> mk_integer w + HsInt _ i -> mk_integer (il_value i) + HsFloatPrim _ r -> mk_rational r + HsDoublePrim _ r -> mk_rational r + HsCharPrim _ c -> mk_char c + _ -> return lit + lit_expr <- lift $ dsLit lit' + case mb_lit_name of + Just lit_name -> rep2_nw lit_name [lit_expr] + Nothing -> notHandled "Exotic literal" (ppr lit) + where + mb_lit_name = case lit of + HsInteger _ _ _ -> Just integerLName + HsInt _ _ -> Just integerLName + HsIntPrim _ _ -> Just intPrimLName + HsWordPrim _ _ -> Just wordPrimLName + HsFloatPrim _ _ -> Just floatPrimLName + HsDoublePrim _ _ -> Just doublePrimLName + HsChar _ _ -> Just charLName + HsCharPrim _ _ -> Just charPrimLName + HsString _ _ -> Just stringLName + HsRat _ _ _ -> Just rationalLName + _ -> Nothing + +mk_integer :: Integer -> MetaM (HsLit GhcRn) +mk_integer i = return $ HsInteger NoSourceText i integerTy + +mk_rational :: FractionalLit -> MetaM (HsLit GhcRn) +mk_rational r = do rat_ty <- lookupType rationalTyConName + return $ HsRat noExtField r rat_ty +mk_string :: FastString -> MetaM (HsLit GhcRn) +mk_string s = return $ HsString NoSourceText s + +mk_char :: Char -> MetaM (HsLit GhcRn) +mk_char c = return $ HsChar NoSourceText c + +repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit) +repOverloadedLiteral (OverLit { ol_val = val}) + = do { lit <- mk_lit val; repLiteral lit } + -- The type Rational will be in the environment, because + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, + -- and rationalL is sucked in when any TH stuff is used + +mk_lit :: OverLitVal -> MetaM (HsLit GhcRn) +mk_lit (HsIntegral i) = mk_integer (il_value i) +mk_lit (HsFractional f) = mk_rational f +mk_lit (HsIsString _ s) = mk_string s + +repNameS :: Core String -> MetaM (Core TH.Name) +repNameS (MkC name) = rep2_nw mkNameSName [name] + +--------------- Miscellaneous ------------------- + +repGensym :: Core String -> MetaM (Core (M TH.Name)) +repGensym (MkC lit_str) = rep2 newNameName [lit_str] + +repBindM :: Type -> Type -- a and b + -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b)) +repBindM ty_a ty_b (MkC x) (MkC y) + = rep2M bindMName [Type ty_a, Type ty_b, x, y] + +repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a])) +repSequenceM ty_a (MkC list) + = rep2M sequenceQName [Type ty_a, list] + +repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) +repUnboundVar (MkC name) = rep2 unboundVarEName [name] + +repOverLabel :: FastString -> MetaM (Core (M TH.Exp)) +repOverLabel fs = do + (MkC s) <- coreStringLit $ unpackFS fs + rep2 labelEName [s] + + +------------ Lists ------------------- +-- turn a list of patterns into a single pattern matching a list + +repList :: Name -> (a -> MetaM (Core b)) + -> [a] -> MetaM (Core [b]) +repList tc_name f args + = do { args1 <- mapM f args + ; coreList tc_name args1 } + +-- Create a list of m a values +repListM :: Name -> (a -> MetaM (Core b)) + -> [a] -> MetaM (Core [b]) +repListM tc_name f args + = do { ty <- wrapName tc_name + ; args1 <- mapM f args + ; return $ coreList' ty args1 } + +coreListM :: Name -> [Core a] -> MetaM (Core [a]) +coreListM tc as = repListM tc return as + +coreList :: Name -- Of the TyCon of the element type + -> [Core a] -> MetaM (Core [a]) +coreList tc_name es + = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } + +coreList' :: Type -- The element type + -> [Core a] -> Core [a] +coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) + +nonEmptyCoreList :: [Core a] -> Core [a] + -- The list must be non-empty so we can get the element type + -- Otherwise use coreList +nonEmptyCoreList [] = panic "coreList: empty argument" +nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) + + +coreStringLit :: MonadThings m => String -> m (Core String) +coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } + +------------------- Maybe ------------------ + +repMaybe :: Name -> (a -> MetaM (Core b)) + -> Maybe a -> MetaM (Core (Maybe b)) +repMaybe tc_name f m = do + t <- lookupType tc_name + repMaybeT t f m + +repMaybeT :: Type -> (a -> MetaM (Core b)) + -> Maybe a -> MetaM (Core (Maybe b)) +repMaybeT ty _ Nothing = return $ coreNothing' ty +repMaybeT ty f (Just es) = coreJust' ty <$> f es + +-- | Construct Core expression for Nothing of a given type name +coreNothing :: Name -- ^ Name of the TyCon of the element type + -> MetaM (Core (Maybe a)) +coreNothing tc_name = + do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } + +coreNothingM :: Name -> MetaM (Core (Maybe a)) +coreNothingM tc_name = + do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) } + +-- | Construct Core expression for Nothing of a given type +coreNothing' :: Type -- ^ The element type + -> Core (Maybe a) +coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) + +-- | Store given Core expression in a Just of a given type name +coreJust :: Name -- ^ Name of the TyCon of the element type + -> Core a -> MetaM (Core (Maybe a)) +coreJust tc_name es + = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } + +coreJustM :: Name -> Core a -> MetaM (Core (Maybe a)) +coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) } + +-- | Store given Core expression in a Just of a given type +coreJust' :: Type -- ^ The element type + -> Core a -> Core (Maybe a) +coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) + +------------------- Maybe Lists ------------------ + +-- Lookup the name and wrap it with the m variable +repMaybeListM :: Name -> (a -> MetaM (Core b)) + -> Maybe [a] -> MetaM (Core (Maybe [b])) +repMaybeListM tc_name f xs = do + elt_ty <- wrapName tc_name + repMaybeListT elt_ty f xs + + +repMaybeListT :: Type -> (a -> MetaM (Core b)) + -> Maybe [a] -> MetaM (Core (Maybe [b])) +repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty +repMaybeListT elt_ty f (Just args) + = do { args1 <- mapM f args + ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) } + +coreNothingList :: Type -> MetaM (Core (Maybe [a])) +coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty) + +------------ Literals & Variables ------------------- + +coreIntLit :: Int -> MetaM (Core Int) +coreIntLit i = do platform <- getPlatform + return (MkC (mkIntExprInt platform i)) + +coreIntegerLit :: MonadThings m => Integer -> m (Core Integer) +coreIntegerLit i = pure (MkC (mkIntegerExpr i)) + +coreVar :: Id -> Core TH.Name -- The Id has type Name +coreVar id = MkC (Var id) + +----------------- Failure ----------------------- +notHandledL :: SrcSpan -> String -> SDoc -> MetaM a +notHandledL loc what doc + | isGoodSrcSpan loc + = mapReaderT (putSrcSpanDs loc) $ notHandled what doc + | otherwise + = notHandled what doc + +notHandled :: String -> SDoc -> MetaM a +notHandled what doc = lift $ failWithDs msg + where + msg = hang (text what <+> text "not (yet) handled by Template Haskell") + 2 doc diff --git a/GHC/HsToCore/Usage.hs b/GHC/HsToCore/Usage.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Usage.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Usage ( + -- * Dependency/fingerprinting code (used by GHC.Iface.Make) + mkUsageInfo, mkUsedNames, mkDependencies + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Driver.Ways +import GHC.Driver.Types +import GHC.Tc.Types +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Unit +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Utils.Fingerprint +import GHC.Data.Maybe +import GHC.Driver.Finder + +import Control.Monad (filterM) +import Data.List +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.Directory +import System.FilePath + +{- Note [Module self-dependency] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in +its own dep_orphs or dep_finsts. However, if we aren't careful this can occur +in the presence of hs-boot files: Consider that we have two modules, A and B, +both with hs-boot files, + + A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A + A.hs-boot declares an orphan instance A.hs defines the orphan instance + +In this case, B's dep_orphs will contain A due to its SOURCE import of A. +Consequently, A will contain itself in its imp_orphs due to its import of B. +This fact would end up being recorded in A's interface file. This would then +break the invariant asserted by calculateAvails that a module does not itself in +its dep_orphs. This was the cause of #14128. + +-} + +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. +-- +-- The first argument is additional dependencies from plugins +mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies +mkDependencies iuid pluginModules + (TcGblEnv{ tcg_mod = mod, + tcg_imports = imports, + tcg_th_used = th_var + }) + = do + -- Template Haskell used? + let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] + plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms) + th_used <- readIORef th_var + let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports) + (moduleName mod)) + -- M.hi-boot can be in the imp_dep_mods, but we must remove + -- it before recording the modules on which this one depends! + -- (We want to retain M.hi-boot in imp_dep_mods so that + -- loadHiBootInterface can see if M's direct imports depend + -- on M.hi-boot, and hence that we should do the hi-boot consistency + -- check.) + + dep_orphs = filter (/= mod) (imp_orphs imports) + -- We must also remove self-references from imp_orphs. See + -- Note [Module self-dependency] + + raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs + + pkgs | th_used = Set.insert thUnitId raw_pkgs + | otherwise = raw_pkgs + + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [Tracking Trust Transitively] in GHC.Rename.Names + sorted_pkgs = sort (Set.toList pkgs) + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs + + return Deps { dep_mods = dep_mods, + dep_pkgs = dep_pkgs', + dep_orphs = dep_orphs, + dep_plgins = dep_plgins, + dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering + +mkUsedNames :: TcGblEnv -> NameSet +mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus + +mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] + -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage] +mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged + pluginModules + = do + eps <- hscEPS hsc_env + hashes <- mapM getFileHash dependent_files + plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules + let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod + dir_imp_mods used_names + usages = mod_usages ++ [ UsageFile { usg_file_path = f + , usg_file_hash = hash } + | (f, hash) <- zip dependent_files hashes ] + ++ [ UsageMergedRequirement + { usg_mod = mod, + usg_mod_hash = hash + } + | (mod, hash) <- merged ] + ++ concat plugin_usages + usages `seqList` return usages + -- seq the list of Usages returned: occasionally these + -- don't get evaluated for a while and we can end up hanging on to + -- the entire collection of Ifaces. + +{- Note [Plugin dependencies] + ~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Modules for which plugins were used in the compilation process, should be +recompiled whenever one of those plugins changes. But how do we know if a +plugin changed from the previous time a module was compiled? + +We could try storing the fingerprints of the interface files of plugins in +the interface file of the module. And see if there are changes between +compilation runs. However, this is pretty much a non-option because interface +fingerprints of plugin modules are fairly stable, unless you compile plugins +with optimisations turned on, and give basically all binders an INLINE pragma. + +So instead: + + * For plugins that were built locally: we store the filepath and hash of the + object files of the module with the `plugin` binder, and the object files of + modules that are dependencies of the plugin module and belong to the same + `UnitId` as the plugin + * For plugins in an external package: we store the filepath and hash of + the dynamic library containing the plugin module. + +During recompilation we then compare the hashes of those files again to see +if anything has changed. + +One issue with this approach is that object files are currently (GHC 8.6.1) +not created fully deterministically, which could sometimes induce accidental +recompilation of a module for which plugins were used in the compile process. + +One way to improve this is to either: + + * Have deterministic object file creation + * Create and store implementation hashes, which would be based on the Core + of the module and the implementation hashes of its dependencies, and then + compare implementation hashes for recompilation. Creation of implementation + hashes is however potentially expensive. +-} +mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] +mkPluginUsage hsc_env pluginModule + = case lookupPluginModuleWithSuggestions pkgs pNm Nothing of + LookupFound _ (pkg, _) -> do + -- The plugin is from an external package: + -- search for the library files containing the plugin. + let searchPaths = collectLibraryPaths dflags [pkg] + useDyn = WayDyn `elem` ways dflags + suffix = if useDyn then soExt platform else "a" + libLocs = [ searchPath "lib" ++ libLoc <.> suffix + | searchPath <- searchPaths + , libLoc <- packageHsLibs dflags pkg + ] + -- we also try to find plugin library files by adding WayDyn way, + -- if it isn't already present (see trac #15492) + paths = + if useDyn + then libLocs + else + let dflags' = addWay' WayDyn dflags + dlibLocs = [ searchPath mkHsSOName platform dlibLoc + | searchPath <- searchPaths + , dlibLoc <- packageHsLibs dflags' pkg + ] + in libLocs ++ dlibLocs + files <- filterM doesFileExist paths + case files of + [] -> + pprPanic + ( "mkPluginUsage: missing plugin library, tried:\n" + ++ unlines paths + ) + (ppr pNm) + _ -> mapM hashFile (nub files) + _ -> do + foundM <- findPluginModule hsc_env pNm + case foundM of + -- The plugin was built locally: look up the object file containing + -- the `plugin` binder, and all object files belong to modules that are + -- transitive dependencies of the plugin that belong to the same package. + Found ml _ -> do + pluginObject <- hashFile (ml_obj_file ml) + depObjects <- catMaybes <$> mapM lookupObjectFile deps + return (nub (pluginObject : depObjects)) + _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm) + where + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + pkgs = unitState dflags + pNm = moduleName $ mi_module pluginModule + pPkg = moduleUnit $ mi_module pluginModule + deps = map gwib_mod $ + dep_mods $ mi_deps pluginModule + + -- Lookup object file for a plugin dependency, + -- from the same package as the plugin. + lookupObjectFile nm = do + foundM <- findImportedModule hsc_env nm Nothing + case foundM of + Found ml m + | moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml) + | otherwise -> return Nothing + _ -> pprPanic "mkPluginUsage: no object for dependency" + (ppr pNm <+> ppr nm) + + hashFile f = do + fExist <- doesFileExist f + if fExist + then do + h <- getFileHash f + return (UsageFile f h) + else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f) + +mk_mod_usage_info :: PackageIfaceTable + -> HscEnv + -> Module + -> ImportedMods + -> NameSet + -> [Usage] +mk_mod_usage_info pit hsc_env this_mod direct_imports used_names + = mapMaybe mkUsage usage_mods + where + hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + this_pkg = homeUnit dflags + + used_mods = moduleEnvKeys ent_map + dir_imp_mods = moduleEnvKeys direct_imports + all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods + usage_mods = sortBy stableModuleCmp all_mods + -- canonical order is imported, to avoid interface-file + -- wobblage. + + -- ent_map groups together all the things imported and used + -- from a particular module + ent_map :: ModuleEnv [OccName] + ent_map = nonDetStrictFoldUniqSet add_mv emptyModuleEnv used_names + -- nonDetStrictFoldUniqSet is OK here. If you follow the logic, we sort by + -- OccName in ent_hashs + where + add_mv name mv_map + | isWiredInName name = mv_map -- ignore wired-in names + | otherwise + = case nameModule_maybe name of + Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map + -- See Note [Internal used_names] + + Just mod -> + -- See Note [Identity versus semantic module] + let mod' = if isHoleModule mod + then mkModule this_pkg (moduleName mod) + else mod + -- This lambda function is really just a + -- specialised (++); originally came about to + -- avoid quadratic behaviour (trac #2680) + in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] + where occ = nameOccName name + + -- We want to create a Usage for a home module if + -- a) we used something from it; has something in used_names + -- b) we imported it, even if we used nothing from it + -- (need to recompile if its export list changes: export_fprint) + mkUsage :: Module -> Maybe Usage + mkUsage mod + | isNothing maybe_iface -- We can't depend on it if we didn't + -- load its interface. + || mod == this_mod -- We don't care about usages of + -- things in *this* module + = Nothing + + | moduleUnit mod /= this_pkg + = Just UsagePackageModule{ usg_mod = mod, + usg_mod_hash = mod_hash, + usg_safe = imp_safe } + -- for package modules, we record the module hash only + + | (null used_occs + && isNothing export_hash + && not is_direct_import + && not finsts_mod) + = Nothing -- Record no usage info + -- for directly-imported modules, we always want to record a usage + -- on the orphan hash. This is what triggers a recompilation if + -- an orphan is added or removed somewhere below us in the future. + + | otherwise + = Just UsageHomeModule { + usg_mod_name = moduleName mod, + usg_mod_hash = mod_hash, + usg_exports = export_hash, + usg_entities = Map.toList ent_hashs, + usg_safe = imp_safe } + where + maybe_iface = lookupIfaceByModule hpt pit mod + -- In one-shot mode, the interfaces for home-package + -- modules accumulate in the PIT not HPT. Sigh. + + Just iface = maybe_iface + finsts_mod = mi_finsts (mi_final_exts iface) + hash_env = mi_hash_fn (mi_final_exts iface) + mod_hash = mi_mod_hash (mi_final_exts iface) + export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface)) + | otherwise = Nothing + + by_is_safe (ImportedByUser imv) = imv_is_safe imv + by_is_safe _ = False + (is_direct_import, imp_safe) + = case lookupModuleEnv direct_imports mod of + -- ezyang: I'm not sure if any is the correct + -- metric here. If safety was guaranteed to be uniform + -- across all imports, why did the old code only look + -- at the first import? + Just bys -> (True, any by_is_safe bys) + Nothing -> (False, safeImplicitImpsReq dflags) + -- Nothing case is for references to entities which were + -- not directly imported (NB: the "implicit" Prelude import + -- counts as directly imported! An entity is not directly + -- imported if, e.g., we got a reference to it from a + -- reexport of another module.) + + used_occs = lookupModuleEnv ent_map mod `orElse` [] + + -- Making a Map here ensures that (a) we remove duplicates + -- when we have usages on several subordinates of a single parent, + -- and (b) that the usages emerge in a canonical order, which + -- is why we use Map rather than OccEnv: Map works + -- using Ord on the OccNames, which is a lexicographic ordering. + ent_hashs :: Map OccName Fingerprint + ent_hashs = Map.fromList (map lookup_occ used_occs) + + lookup_occ occ = + case hash_env occ of + Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) + Just r -> r + + depend_on_exports = is_direct_import + {- True + Even if we used 'import M ()', we have to register a + usage on the export list because we are sensitive to + changes in orphan instances/rules. + False + In GHC 6.8.x we always returned true, and in + fact it recorded a dependency on *all* the + modules underneath in the dependency tree. This + happens to make orphans work right, but is too + expensive: it'll read too many interface files. + The 'isNothing maybe_iface' check above saved us + from generating many of these usages (at least in + one-shot mode), but that's even more bogus! + -} + +{- +Note [Internal used_names] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the used_names are External Names, but we can have System +Names too. Two examples: + +* Names arising from Language.Haskell.TH.newName. + See Note [Binders in Template Haskell] in GHC.ThToHs (and #5362). +* The names of auxiliary bindings in derived instances. + See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. + +Such Names are always for locally-defined things, for which we don't gather +usage info, so we can just ignore them in ent_map. Moreover, they are always +System Names, hence the assert, just as a double check. +-} diff --git a/GHC/HsToCore/Utils.hs b/GHC/HsToCore/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Utils.hs @@ -0,0 +1,1006 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utilities for desugaring + +This module exports some utility functions of no great interest. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Utility functions for constructing Core syntax, principally for desugaring +module GHC.HsToCore.Utils ( + EquationInfo(..), + firstPat, shiftEqns, + + MatchResult (..), CaseAlt(..), + cantFailMatchResult, alwaysFailMatchResult, + extractMatchResult, combineMatchResults, + adjustMatchResultDs, + shareFailureHandler, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, + matchCanFail, mkEvalMatchResult, + mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, + wrapBind, wrapBinds, + + mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, + + seqVar, + + -- LHs tuples + mkLHsPatTup, mkVanillaTuplePat, + mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, + + mkSelectorBinds, + + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkOptTickBox, mkBinaryTickBox, decideBangHood, + isTrueLHsExpr + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) + +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.TcType( tcSplitTyConApp ) +import GHC.Core +import GHC.HsToCore.Monad + +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Types.Id.Make +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Core.ConLike +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply +import GHC.Unit.Module +import GHC.Builtin.Names +import GHC.Types.Name( isInternalName ) +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Driver.Session +import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Tc.Types.Evidence + +import Control.Monad ( zipWithM ) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (maybeToList) +import qualified Data.List.NonEmpty as NEL + +{- +************************************************************************ +* * +\subsection{ Selecting match variables} +* * +************************************************************************ + +We're about to match against some patterns. We want to make some +@Ids@ to use as match variables. If a pattern has an @Id@ readily at +hand, which should indeed be bound to the pattern as a whole, then use it; +otherwise, make one up. The multiplicity argument is chosen as the multiplicity +of the variable if it is made up. +-} + +selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name +selectSimpleMatchVarL w pat = selectMatchVar w (unLoc pat) + +-- (selectMatchVars ps tys) chooses variables of type tys +-- to use for matching ps against. If the pattern is a variable, +-- we try to use that, to save inventing lots of fresh variables. +-- +-- OLD, but interesting note: +-- But even if it is a variable, its type might not match. Consider +-- data T a where +-- T1 :: Int -> T Int +-- T2 :: a -> T a +-- +-- f :: T a -> a -> Int +-- f (T1 i) (x::Int) = x +-- f (T2 i) (y::a) = 0 +-- Then we must not choose (x::Int) as the matching variable! +-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat + +selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id] +-- Postcondition: the returned Ids have Internal Names +selectMatchVars ps = mapM (uncurry selectMatchVar) ps + +selectMatchVar :: Mult -> Pat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name +selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (ParPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) + -- Note [Localise pattern binders] + -- + -- Remark: when the pattern is a variable (or + -- an @-pattern), then w is the same as the + -- multiplicity stored within the variable + -- itself. It's easier to pull it from the + -- variable, so we ignore the multiplicity. +selectMatchVar _w (AsPat _ var _) = ASSERT( isManyDataConTy _w ) (return (unLoc var)) +selectMatchVar w other_pat = newSysLocalDsNoLP w (hsPatType other_pat) + +{- Note [Localise pattern binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider module M where + [Just a] = e +After renaming it looks like + module M where + [Just M.a] = e + +We don't generalise, since it's a pattern binding, monomorphic, etc, +so after desugaring we may get something like + M.a = case e of (v:_) -> + case v of Just M.a -> M.a +Notice the "M.a" in the pattern; after all, it was in the original +pattern. However, after optimisation those pattern binders can become +let-binders, and then end up floated to top level. They have a +different *unique* by then (the simplifier is good about maintaining +proper scoping), but it's BAD to have two top-level bindings with the +External Name M.a, because that turns into two linker symbols for M.a. +It's quite rare for this to actually *happen* -- the only case I know +of is tc003 compiled with the 'hpc' way -- but that only makes it +all the more annoying. + +To avoid this, we craftily call 'localiseId' in the desugarer, which +simply turns the External Name for the Id into an Internal one, but +doesn't change the unique. So the desugarer produces this: + M.a{r8} = case e of (v:_) -> + case v of Just a{r8} -> M.a{r8} +The unique is still 'r8', but the binding site in the pattern +is now an Internal Name. Now the simplifier's usual mechanisms +will propagate that Name to all the occurrence sites, as well as +un-shadowing it, so we'll get + M.a{r8} = case e of (v:_) -> + case v of Just a{s77} -> a{s77} +In fact, even GHC.Core.Subst.simplOptExpr will do this, and simpleOptExpr +runs on the output of the desugarer, so all is well by the end of +the desugaring pass. + +See also Note [MatchIds] in GHC.HsToCore.Match + +************************************************************************ +* * +* type synonym EquationInfo and access functions for its pieces * +* * +************************************************************************ +\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} + +The ``equation info'' used by @match@ is relatively complicated and +worthy of a type synonym and a few handy functions. +-} + +firstPat :: EquationInfo -> Pat GhcTc +firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) + +shiftEqns :: Functor f => f EquationInfo -> f EquationInfo +-- Drop the first pattern in each equation +shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } + +-- Functions on MatchResult CoreExprs + +matchCanFail :: MatchResult a -> Bool +matchCanFail (MR_Fallible {}) = True +matchCanFail (MR_Infallible {}) = False + +alwaysFailMatchResult :: MatchResult CoreExpr +alwaysFailMatchResult = MR_Fallible $ \fail -> return fail + +cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr +cantFailMatchResult expr = MR_Infallible $ return expr + +extractMatchResult :: MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr +extractMatchResult match_result failure_expr = + runMatchResult + failure_expr + (shareFailureHandler match_result) + +combineMatchResults :: MatchResult CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +combineMatchResults match_result1@(MR_Infallible _) _ + = match_result1 +combineMatchResults match_result1 match_result2 = + -- if the first pattern needs a failure handler (i.e. if it is fallible), + -- make it let-bind it bind it with `shareFailureHandler`. + case shareFailureHandler match_result1 of + MR_Infallible _ -> match_result1 + MR_Fallible body_fn1 -> MR_Fallible $ \fail_expr -> + -- Before actually failing, try the next match arm. + body_fn1 =<< runMatchResult fail_expr match_result2 + +adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b +adjustMatchResultDs encl_fn = \case + MR_Infallible body_fn -> MR_Infallible $ + encl_fn =<< body_fn + MR_Fallible body_fn -> MR_Fallible $ \fail -> + encl_fn =<< body_fn fail + +wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr +wrapBinds [] e = e +wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) + +wrapBind :: Var -> Var -> CoreExpr -> CoreExpr +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body + +seqVar :: Var -> CoreExpr -> CoreExpr +seqVar var body = mkDefaultCase (Var var) var body + +mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr +mkCoLetMatchResult bind = fmap (mkCoreLet bind) + +-- (mkViewMatchResult var' viewExpr mr) makes the expression +-- let var' = viewExpr in mr +mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr + +mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr +mkEvalMatchResult var ty = fmap $ \e -> + Case (Var var) var ty [(DEFAULT, [], e)] + +mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do + body <- runMatchResult fail mr + return (mkIfThenElse pred_expr body fail) + +mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of the case + -> [(Literal, MatchResult CoreExpr)] -- Alternatives + -> MatchResult CoreExpr -- Literals are all unlifted +mkCoPrimCaseMatchResult var ty match_alts + = MR_Fallible mk_case + where + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + + sorted_alts = sortWith fst match_alts -- Right order for a Case + mk_alt fail (lit, mr) + = ASSERT( not (litIsLifted lit) ) + do body <- runMatchResult fail mr + return (LitAlt lit, [], body) + +data CaseAlt a = MkCaseAlt{ alt_pat :: a, + alt_bndrs :: [Var], + alt_wrapper :: HsWrapper, + alt_result :: MatchResult CoreExpr } + +mkCoAlgCaseMatchResult + :: Id -- ^ Scrutinee + -> Type -- ^ Type of exp + -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult CoreExpr +mkCoAlgCaseMatchResult var ty match_alts + | isNewtype -- Newtype case; use a let + = ASSERT( null match_alts_tail && null (tail arg_ids1) ) + mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 + + | otherwise + = mkDataConCase var ty match_alts + where + isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) + + -- [Interesting: because of GADTs, we can't rely on the type of + -- the scrutinised Id to be sufficiently refined to have a TyCon in it] + + alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail + = match_alts + -- Stuff for newtype + arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 + var_ty = idType var + (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) + +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr +mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt + +mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr +mkPatSynCase var ty alt fail = do + matcher <- dsLExpr $ mkLHsWrap wrapper $ + nlHsTyApp matcher [getRuntimeRep ty, ty] + cont <- mkCoreLams bndrs <$> runMatchResult fail match_result + return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] + where + MkCaseAlt{ alt_pat = psyn, + alt_bndrs = bndrs, + alt_wrapper = wrapper, + alt_result = match_result} = alt + (matcher, needs_void_lam) = patSynMatcher psyn + + -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn + -- on these extra Void# arguments + ensure_unstrict cont | needs_void_lam = Lam voidArgId cont + | otherwise = cont + +mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr +mkDataConCase var ty alts@(alt1 :| _) + = liftA2 mk_case mk_default mk_alts + -- The liftA2 combines the failability of all the alternatives and the default + where + con1 = alt_pat alt1 + tycon = dataConTyCon con1 + data_cons = tyConDataCons tycon + + sorted_alts :: [ CaseAlt DataCon ] + sorted_alts = sortWith (dataConTag . alt_pat) $ NEL.toList alts + + var_ty = idType var + (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + + mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr + mk_case def alts = mkWildCase (Var var) (idScaledType var) ty $ + maybeToList def ++ alts + + mk_alts :: MatchResult [CoreAlt] + mk_alts = traverse mk_alt sorted_alts + + mk_alt :: CaseAlt DataCon -> MatchResult CoreAlt + mk_alt MkCaseAlt { alt_pat = con + , alt_bndrs = args + , alt_result = match_result } = + flip adjustMatchResultDs match_result $ \body -> do + case dataConBoxer con of + Nothing -> return (DataAlt con, args, body) + Just (DCB boxer) -> do + us <- newUniqueSupply + let (rep_ids, binds) = initUs_ us (boxer ty_args args) + let rep_ids' = map (scaleVarBy (idMult var)) rep_ids + -- Upholds the invariant that the binders of a case expression + -- must be scaled by the case multiplicity. See Note [Case + -- expression invariants] in CoreSyn. + return (DataAlt con, rep_ids', mkLets binds body) + + mk_default :: MatchResult (Maybe CoreAlt) + mk_default + | exhaustive_case = MR_Infallible $ return Nothing + | otherwise = MR_Fallible $ \fail -> return $ Just (DEFAULT, [], fail) + + mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts + un_mentioned_constructors + = mkUniqSet data_cons `minusUniqSet` mentioned_constructors + exhaustive_case = isEmptyUniqSet un_mentioned_constructors + +{- +************************************************************************ +* * +\subsection{Desugarer's versions of some Core functions} +* * +************************************************************************ +-} + +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> SDoc -- The error message string to pass + -> DsM CoreExpr + +mkErrorAppDs err_id ty msg = do + src_loc <- getSrcSpanDs + dflags <- getDynFlags + let + full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) + core_msg = Lit (mkLitString full_msg) + -- mkLitString returns a result of type String# + return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) + +{- +'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. + +Note [Desugaring seq] +~~~~~~~~~~~~~~~~~~~~~ + +There are a few subtleties in the desugaring of `seq`: + + 1. (as described in #1031) + + Consider, + f x y = x `seq` (y `seq` (# x,y #)) + + The [Core let/app invariant] means that, other things being equal, because + the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + + But that is bad for two reasons: + (a) we now evaluate y before x, and + (b) we can't bind v to an unboxed pair + + Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + + 2. (as described in #2273) + + Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... + Here the seq is designed to plug the space leak of retaining (snd x) + for too long. + + If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + + But since chp is cheap, and the case is an alluring contet, we'll + inline chp into the case scrutinee. Now there is only one use of chp, + so we'll inline a second copy. Alas, we've now ruined the purpose of + the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + + We can try to avoid doing this by ensuring that the binder-swap in the + case happens, so we get his at an early stage: + case chp of chp2 { I# -> ...chp2... } + But this is fragile. The real culprit is the source program. Perhaps we + should have said explicitly + let !chp2 = chp in ...chp2... + + But that's painful. So the code here does a little hack to make seq + more robust: a saturated application of 'seq' is turned *directly* into + the case expression, thus: + x `seq` e2 ==> case x of x -> e2 -- Note shadowing! + e1 `seq` e2 ==> case x of _ -> e2 + + So we desugar our example to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } + And now all is well. + + The reason it's a hack is because if you define mySeq=seq, the hack + won't work on mySeq. + + 3. (as described in #2409) + + The isLocalId ensures that we don't turn + True `seq` e + into + case True of True { ... } + which stupidly tries to bind the datacon 'True'. +-} + +-- NB: Make sure the argument is not levity polymorphic +mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 + | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) + = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] + where + case_bndr = case arg1 of + Var v1 | isInternalName (idName v1) + -> v1 -- Note [Desugaring seq], points (2) and (3) + _ -> mkWildValBinder Many ty1 + +mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make + +-- NB: No argument can be levity polymorphic +mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args + +mkCastDs :: CoreExpr -> Coercion -> CoreExpr +-- We define a desugarer-specific version of GHC.Core.Utils.mkCast, +-- because in the immediate output of the desugarer, we can have +-- apparently-mis-matched coercions: E.g. +-- let a = b +-- in (x :: a) |> (co :: b ~ Int) +-- Lint know about type-bindings for let and does not complain +-- So here we do not make the assertion checks that we make in +-- GHC.Core.Utils.mkCast; and we do less peephole optimisation too +mkCastDs e co | isReflCo co = e + | otherwise = Cast e co + +{- +************************************************************************ +* * + Tuples and selector bindings +* * +************************************************************************ + +This is used in various places to do with lazy patterns. +For each binder $b$ in the pattern, we create a binding: +\begin{verbatim} + b = case v of pat' -> b' +\end{verbatim} +where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. + +ToDo: making these bindings should really depend on whether there's +much work to be done per binding. If the pattern is complex, it +should be de-mangled once, into a tuple (and then selected from). +Otherwise the demangling can be in-line in the bindings (as here). + +Boring! Boring! One error message per binder. The above ToDo is +even more helpful. Something very similar happens for pattern-bound +expressions. + +Note [mkSelectorBinds] +~~~~~~~~~~~~~~~~~~~~~~ +mkSelectorBinds is used to desugar a pattern binding {p = e}, +in a binding group: + let { ...; p = e; ... } in body +where p binds x,y (this list of binders can be empty). +There are two cases. + +------ Special case (A) ------- + For a pattern that is just a variable, + let !x = e in body + ==> + let x = e in x `seq` body + So we return the binding, with 'x' as the variable to seq. + +------ Special case (B) ------- + For a pattern that is essentially just a tuple: + * A product type, so cannot fail + * Only one level, so that + - generating multiple matches is fine + - seq'ing it evaluates the same as matching it + Then instead we generate + { v = e + ; x = case v of p -> x + ; y = case v of p -> y } + with 'v' as the variable to force + +------ General case (C) ------- + In the general case we generate these bindings: + let { ...; p = e; ... } in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + in t `seq` body + + Note that we return 't' as the variable to force if the pattern + is strict (i.e. with -XStrict or an outermost-bang-pattern) + + Note that (A) /includes/ the situation where + + * The pattern binds exactly one variable + let !(Just (Just x) = e in body + ==> + let { t = case e of Just (Just v) -> Solo v + ; v = case t of Solo v -> v } + in t `seq` body + The 'Solo' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types + Note that forcing 't' makes the pattern match happen, + but does not force 'v'. + + * The pattern binds no variables + let !(True,False) = e in body + ==> + let t = case e of (True,False) -> () + in t `seq` body + + +------ Examples ---------- + * !(_, (_, a)) = e + ==> + t = case e of (_, (_, a)) -> Solo a + a = case t of Solo a -> a + + Note that + - Forcing 't' will force the pattern to match fully; + e.g. will diverge if (snd e) is bottom + - But 'a' itself is not forced; it is wrapped in a one-tuple + (see Note [One-tuples] in GHC.Builtin.Types) + + * !(Just x) = e + ==> + t = case e of Just x -> Solo x + x = case t of Solo x -> x + + Again, forcing 't' will fail if 'e' yields Nothing. + +Note that even though this is rather general, the special cases +work out well: + +* One binder, not -XStrict: + + let Just (Just v) = e in body + ==> + let t = case e of Just (Just v) -> Solo v + v = case t of Solo v -> v + in body + ==> + let v = case (case e of Just (Just v) -> Solo v) of + Solo v -> v + in body + ==> + let v = case e of Just (Just v) -> v + in body + +* Non-recursive, -XStrict + let p = e in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> x } + in t `seq` body + ==> {inline seq, float x,y bindings inwards} + let t = case e of p -> (x,y) in + case t of t' -> + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {inline t, do case of case} + case e of p -> + let t = (x,y) in + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {case-cancellation, drop dead code} + case e of p -> body + +* Special case (B) is there to avoid fruitlessly taking the tuple + apart and rebuilding it. For example, consider + { K x y = e } + where K is a product constructor. Then general case (A) does: + { t = case e of K x y -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + In the lazy case we can't optimise out this fruitless taking apart + and rebuilding. Instead (B) builds + { v = e + ; x = case v of K x y -> x + ; y = case v of K x y -> y } + which is better. +-} +-- Remark: pattern selectors only occur in unrestricted patterns so we are free +-- to select Many as the multiplicity of every let-expression introduced. +mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> CoreExpr -- ^ Expression to which the pattern is bound + -> DsM (Id,[(Id,CoreExpr)]) + -- ^ Id the rhs is bound to, for desugaring strict + -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds") + -- and all the desugared binds + +mkSelectorBinds ticks pat val_expr + | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) + = return (v, [(v, val_expr)]) + + | is_flat_prod_lpat pat' -- Special case (B) + = do { let pat_ty = hsLPatType pat' + ; val_var <- newSysLocalDsNoLP Many pat_ty + + ; let mk_bind tick bndr_var + -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } + -- Remember, 'pat' binds 'bv' + = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + (Var bndr_var) + (Var bndr_var) -- Neat hack + -- Neat hack: since 'pat' can't fail, the + -- "fail-expr" passed to matchSimply is not + -- used. But it /is/ used for its type, and for + -- that bndr_var is just the ticket. + ; return (bndr_var, mkOptTickBox tick rhs_expr) } + + ; binds <- zipWithM mk_bind ticks' binders + ; return ( val_var, (val_var, val_expr) : binds) } + + | otherwise -- General case (C) + = do { tuple_var <- newSysLocalDs Many tuple_ty + ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') + ; tuple_expr <- matchSimply val_expr PatBindRhs pat + local_tuple error_expr + ; let mk_tup_bind tick binder + = (binder, mkOptTickBox tick $ + mkTupleSelector1 local_binders binder + tuple_var (Var tuple_var)) + tup_binds = zipWith mk_tup_bind ticks' binders + ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } + where + pat' = strip_bangs pat + -- Strip the bangs before looking for case (A) or (B) + -- The incoming pattern may well have a bang on it + + binders = collectPatBinders pat' + ticks' = ticks ++ repeat [] + + local_binders = map localiseId binders -- See Note [Localise pattern binders] + local_tuple = mkBigCoreVarTup1 binders + tuple_ty = exprType local_tuple + +strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) +-- Remove outermost bangs and parens +strip_bangs (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp + +is_flat_prod_lpat :: LPat GhcTc -> Bool +is_flat_prod_lpat = is_flat_prod_pat . unLoc + +is_flat_prod_pat :: Pat GhcTc -> Bool +is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p +is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps +is_flat_prod_pat (ConPat { pat_con = L _ pcon + , pat_args = ps}) + | RealDataCon con <- pcon + , isProductTyCon (dataConTyCon con) + = all is_triv_lpat (hsConPatArgs ps) +is_flat_prod_pat _ = False + +is_triv_lpat :: LPat (GhcPass p) -> Bool +is_triv_lpat = is_triv_pat . unLoc + +is_triv_pat :: Pat (GhcPass p) -> Bool +is_triv_pat (VarPat {}) = True +is_triv_pat (WildPat{}) = True +is_triv_pat (ParPat _ p) = is_triv_lpat p +is_triv_pat _ = False + + +{- ********************************************************************* +* * + Creating big tuples and their types for full Haskell expressions. + They work over *Ids*, and create tuples replete with their types, + which is whey they are not in GHC.Hs.Utils. +* * +********************************************************************* -} + +mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc +mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats = L (getLoc (head lpats)) $ + mkVanillaTuplePat lpats Boxed + +mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box + +-- The Big equivalents for the source tuple expressions +mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc +mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) + +mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc +mkBigLHsTupId = mkChunkified mkLHsTupleExpr + +-- The Big equivalents for the source tuple patterns +mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc +mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) + +mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc +mkBigLHsPatTupId = mkChunkified mkLHsPatTup + +{- +************************************************************************ +* * + Code for pattern-matching and other failures +* * +************************************************************************ + +Generally, we handle pattern matching failure like this: let-bind a +fail-variable, and use that variable if the thing fails: +\begin{verbatim} + let fail.33 = error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 + p3 -> fail.33 + p4 -> ... +\end{verbatim} +Then +\begin{itemize} +\item +If the case can't fail, then there'll be no mention of @fail.33@, and the +simplifier will later discard it. + +\item +If it can fail in only one way, then the simplifier will inline it. + +\item +Only if it is used more than once will the let-binding remain. +\end{itemize} + +There's a problem when the result of the case expression is of +unboxed type. Then the type of @fail.33@ is unboxed too, and +there is every chance that someone will change the let into a case: +\begin{verbatim} + case error "Help" of + fail.33 -> case .... +\end{verbatim} + +which is of course utterly wrong. Rather than drop the condition that +only boxed types can be let-bound, we just turn the fail into a function +for the primitive case: +\begin{verbatim} + let fail.33 :: Void -> Int# + fail.33 = \_ -> error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 void + p3 -> fail.33 void + p4 -> ... +\end{verbatim} + +Now @fail.33@ is a function, so it can be let-bound. + +We would *like* to use join points here; in fact, these "fail variables" are +paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as +CPS functions - i.e. they take "join points" as parameters. It's not impossible +to imagine extending our type system to allow passing join points around (very +carefully), but we certainly don't support it now. + +99.99% of the time, the fail variables wind up as join points in short order +anyway, and the Void# doesn't do much harm. +-} + +mkFailurePair :: CoreExpr -- Result type of the whole case expression + -> DsM (CoreBind, -- Binds the newly-created fail variable + -- to \ _ -> expression + CoreExpr) -- Fail variable applied to realWorld# +-- See Note [Failure thunks and CPR] +mkFailurePair expr + = do { fail_fun_var <- newFailLocalDs Many (voidPrimTy `mkVisFunTyMany` ty) + ; fail_fun_arg <- newSysLocalDs Many voidPrimTy + ; let real_arg = setOneShotLambda fail_fun_arg + ; return (NonRec fail_fun_var (Lam real_arg expr), + App (Var fail_fun_var) (Var voidPrimId)) } + where + ty = exprType expr + +-- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have +-- neither a failure arg or failure "hole", so nothing is let-bound, and no +-- extraneous Core is produced. +shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr +shareFailureHandler = \case + mr@(MR_Infallible _) -> mr + MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do + (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr + body <- match_fn shared_failure_handler + -- Never unboxed, per the above, so always OK for `let` not `case`. + return $ Let fail_bind body + +{- +Note [Failure thunks and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This note predates join points as formal entities (hence the quotation marks). +We can't use actual join points here (see above); if we did, this would also +solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR +join points] in GHC.Core.Opt.WorkWrap.) + +When we make a failure point we ensure that it +does not look like a thunk. Example: + + let fail = \rw -> error "urk" + in case x of + [] -> fail realWorld# + (y:ys) -> case ys of + [] -> fail realWorld# + (z:zs) -> (y,z) + +Reason: we know that a failure point is always a "join point" and is +entered at most once. Adding a dummy 'realWorld' token argument makes +it clear that sharing is not an issue. And that in turn makes it more +CPR-friendly. This matters a lot: if you don't get it right, you lose +the tail call property. For example, see #3403. + + +************************************************************************ +* * + Ticks +* * +********************************************************************* -} + +mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr +mkOptTickBox = flip (foldr Tick) + +mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr +mkBinaryTickBox ixT ixF e = do + uq <- newUnique + this_mod <- getModule + let bndr1 = mkSysLocal (fsLit "t1") uq One boolTy + -- It's always sufficient to pattern-match on a boolean with + -- multiplicity 'One'. + let + falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) + trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) + -- + return $ Case e bndr1 boolTy + [ (DataAlt falseDataCon, [], falseBox) + , (DataAlt trueDataCon, [], trueBox) + ] + + + +-- ******************************************************************* + +{- Note [decideBangHood] +~~~~~~~~~~~~~~~~~~~~~~~~ +With -XStrict we may make /outermost/ patterns more strict. +E.g. + let (Just x) = e in ... + ==> + let !(Just x) = e in ... +and + f x = e + ==> + f !x = e + +This adjustment is done by decideBangHood, + + * Just before constructing an EqnInfo, in GHC.HsToCore.Match + (matchWrapper and matchSinglePat) + + * When desugaring a pattern-binding in GHC.HsToCore.Binds.dsHsBind + +Note that it is /not/ done recursively. See the -XStrict +spec in the user manual. + +Specifically: + ~pat => pat -- when -XStrict (even if pat = ~pat') + !pat => !pat -- always + pat => !pat -- when -XStrict + pat => pat -- otherwise +-} + + +-- | Use -XStrict to add a ! or remove a ~ +-- See Note [decideBangHood] +decideBangHood :: DynFlags + -> LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- Pattern with bang if necessary +decideBangHood dflags lpat + | not (xopt LangExt.Strict dflags) + = lpat + | otherwise -- -XStrict + = go lpat + where + go lp@(L l p) + = case p of + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> lp' + BangPat _ _ -> lp + _ -> L l (BangPat noExtField lp) + +isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) + +-- Returns Just {..} if we're sure that the expression is True +-- I.e. * 'True' datacon +-- * 'otherwise' Id +-- * Trivial wappings of these +-- The arguments to Just are any HsTicks that we have found, +-- because we still want to tick then, even it they are always evaluated. +isTrueLHsExpr (L _ (HsVar _ (L _ v))) + | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId + = Just return + -- trueDataConId doesn't have the same unique as trueDataCon +isTrueLHsExpr (L _ (HsConLikeOut _ con)) + | con `hasKey` getUnique trueDataCon = Just return +isTrueLHsExpr (L _ (HsTick _ tickish e)) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> do wrapped <- ticks x + return (Tick tickish wrapped)) + -- This encodes that the result is constant True for Hpc tick purposes; + -- which is specifically what isTrueLHsExpr is trying to find out. +isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> do e <- ticks x + this_mod <- getModule + return (Tick (HpcTick this_mod ixT) e)) + +isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing diff --git a/GHC/Iface/Binary.hs b/GHC/Iface/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Binary.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | Binary interface file support. +module GHC.Iface.Binary ( + -- * Public API for interface file serialisation + writeBinIface, + readBinIface, + readBinIface_, + getSymtabName, + getDictFastString, + CheckHiWay(..), + TraceBinIFaceReading(..), + getWithUserData, + putWithUserData, + + -- * Internal serialisation functions + getSymbolTable, + putName, + putDictionary, + putFastString, + putSymbolTable, + BinSymbolTable(..), + BinDictionary(..) + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Monad +import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName ) +import GHC.Iface.Env +import GHC.Driver.Types +import GHC.Unit +import GHC.Types.Name +import GHC.Driver.Session +import GHC.Driver.Ways +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Utils.Panic +import GHC.Utils.Binary as Binary +import GHC.Types.SrcLoc +import GHC.Utils.Error +import GHC.Data.FastMutInt +import GHC.Types.Unique +import GHC.Utils.Outputable +import GHC.Types.Name.Cache +import GHC.Platform +import GHC.Data.FastString +import GHC.Settings.Constants +import GHC.Utils.Misc + +import Data.Set (Set) +import Data.Array +import Data.Array.ST +import Data.Array.Unsafe +import Data.Bits +import Data.Char +import Data.Word +import Data.IORef +import Data.Foldable +import Control.Monad +import Control.Monad.ST +import Control.Monad.Trans.Class +import qualified Control.Monad.Trans.State.Strict as State + +-- --------------------------------------------------------------------------- +-- Reading and writing binary interface files +-- + +data CheckHiWay = CheckHiWay | IgnoreHiWay + deriving Eq + +data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading + deriving Eq + +-- | Read an interface file +readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath + -> TcRnIf a b ModIface +readBinIface checkHiWay traceBinIFaceReading hi_path = do + ncu <- mkNameCacheUpdater + dflags <- getDynFlags + liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu + +-- | Read an interface file in 'IO'. +readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath + -> NameCacheUpdater + -> IO ModIface +readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do + let platform = targetPlatform dflags + + printer :: SDoc -> IO () + printer = case traceBinIFaceReading of + TraceBinIFaceReading -> \sd -> + putLogMsg dflags + NoReason + SevOutput + noSrcSpan + $ withPprStyle defaultDumpStyle sd + QuietBinIFaceReading -> \_ -> return () + + wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () + wantedGot what wanted got ppr' = + printer (text what <> text ": " <> + vcat [text "Wanted " <> ppr' wanted <> text ",", + text "got " <> ppr' got]) + + errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () + errorOnMismatch what wanted got = + -- This will be caught by readIface which will emit an error + -- msg containing the iface module name. + when (wanted /= got) $ throwGhcExceptionIO $ ProgramError + (what ++ " (wanted " ++ show wanted + ++ ", got " ++ show got ++ ")") + bh <- Binary.readBinMem hi_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get bh + wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength) + errorOnMismatch "magic number mismatch: old/corrupt interface file?" + (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic) + + -- Check the interface file version and ways. + check_ver <- get bh + let our_ver = show hiVersion + wantedGot "Version" our_ver check_ver text + errorOnMismatch "mismatched interface file versions" our_ver check_ver + + check_way <- get bh + let way_descr = getWayDescr platform (ways dflags) + wantedGot "Way" way_descr check_way ppr + when (checkHiWay == CheckHiWay) $ + errorOnMismatch "mismatched interface file ways" way_descr check_way + + extFields_p <- get bh + + mod_iface <- getWithUserData ncu bh + + seekBin bh extFields_p + extFields <- get bh + + return mod_iface{mi_ext_fields = extFields} + + +-- | This performs a get action after reading the dictionary and symbol +-- table. It is necessary to run this before trying to deserialise any +-- Names or FastStrings. +getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a +getWithUserData ncu bh = do + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Binary.get bh + data_p <- tellBin bh -- Remember where we are now + seekBin bh dict_p + dict <- getDictionary bh + seekBin bh data_p -- Back to where we were before + + -- Initialise the user-data field of bh + bh <- do + bh <- return $ setUserData bh $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab_p <- Binary.get bh -- Get the symtab ptr + data_p <- tellBin bh -- Remember where we are now + seekBin bh symtab_p + symtab <- getSymbolTable bh ncu + seekBin bh data_p -- Back to where we were before + + -- It is only now that we know how to get a Name + return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab) + (getDictFastString dict) + + -- Read the interface file + get bh + +-- | Write an interface file +writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () +writeBinIface dflags hi_path mod_iface = do + bh <- openBinMem initBinMemSize + let platform = targetPlatform dflags + put_ bh (binaryInterfaceMagic platform) + + -- The version and way descriptor go next + put_ bh (show hiVersion) + let way_descr = getWayDescr platform (ways dflags) + put_ bh way_descr + + extFields_p_p <- tellBin bh + put_ bh extFields_p_p + + putWithUserData (debugTraceMsg dflags 3) bh mod_iface + + extFields_p <- tellBin bh + putAt bh extFields_p_p extFields_p + seekBin bh extFields_p + put_ bh (mi_ext_fields mod_iface) + + -- And send the result to the file + writeBinMem bh hi_path + +-- | Put a piece of data with an initialised `UserData` field. This +-- is necessary if you want to serialise Names or FastStrings. +-- It also writes a symbol table and the dictionary. +-- This segment should be read using `getWithUserData`. +putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO () +putWithUserData log_action bh payload = do + -- Remember where the dictionary pointer will go + dict_p_p <- tellBin bh + -- Placeholder for ptr to dictionary + put_ bh dict_p_p + + -- Remember where the symbol table pointer will go + symtab_p_p <- tellBin bh + put_ bh symtab_p_p + -- Make some initial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let bin_symtab = BinSymbolTable { + bin_symtab_next = symtab_next, + bin_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = BinDictionary { + bin_dict_next = dict_next_ref, + bin_dict_map = dict_map_ref } + + -- Put the main thing, + bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) + (putName bin_dict bin_symtab) + (putFastString bin_dict) + put_ bh payload + + -- Write the symtab pointer at the front of the file + symtab_p <- tellBin bh -- This is where the symtab will start + putAt bh symtab_p_p symtab_p -- Fill in the placeholder + seekBin bh symtab_p -- Seek back to the end of the file + + -- Write the symbol table itself + symtab_next <- readFastMutInt symtab_next + symtab_map <- readIORef symtab_map + putSymbolTable bh symtab_next symtab_map + log_action (text "writeBinIface:" <+> int symtab_next + <+> text "Names") + + -- NB. write the dictionary after the symbol table, because + -- writing the symbol table may create more dictionary entries. + + -- Write the dictionary pointer at the front of the file + dict_p <- tellBin bh -- This is where the dictionary will start + putAt bh dict_p_p dict_p -- Fill in the placeholder + seekBin bh dict_p -- Seek back to the end of the file + + -- Write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + log_action (text "writeBinIface:" <+> int dict_next + <+> text "dict entries") + + + +-- | Initial ram buffer to allocate for writing interface files +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 + +binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32 +binaryInterfaceMagic platform + | target32Bit platform = FixedLengthEncoding 0x1face + | otherwise = FixedLengthEncoding 0x1face64 + + +-- ----------------------------------------------------------------------------- +-- The symbol table +-- + +putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) + -- It's OK to use nonDetEltsUFM here because the elements have + -- indices that array uses to create order + mapM_ (\n -> serialiseName bh n symtab) names + +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do + sz <- get bh + od_names <- sequence (replicate sz (get bh)) + updateNameCache ncu $ \namecache -> + runST $ flip State.evalStateT namecache $ do + mut_arr <- lift $ newSTArray_ (0, sz-1) + for_ (zip [0..] od_names) $ \(i, odn) -> do + (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn + lift $ writeArray mut_arr i n + State.put nc + arr <- lift $ unsafeFreeze mut_arr + namecache' <- State.get + return (namecache', arr) + where + -- This binding is required because the type of newArray_ cannot be inferred + newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name) + newSTArray_ = newArray_ + +type OnDiskName = (Unit, ModuleName, OccName) + +fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name) +fromOnDiskName nc (pid, mod_name, occ) = + let mod = mkModule pid mod_name + cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name -> (nc, name) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) + +serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO () +serialiseName bh name _ = do + let mod = ASSERT2( isExternalName name, ppr name ) nameModule name + put_ bh (moduleUnit mod, moduleName mod, nameOccName name) + + +-- Note [Symbol table representation of names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- An occurrence of a name in an interface file is serialized as a single 32-bit +-- word. The format of this word is: +-- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx +-- A normal name. x is an index into the symbol table +-- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy +-- A known-key name. x is the Unique's Char, y is the int part. We assume that +-- all known-key uniques fit in this space. This is asserted by +-- GHC.Builtin.Utils.knownKeyNamesOkay. +-- +-- During serialization we check for known-key things using isKnownKeyName. +-- During deserialization we use lookupKnownKeyName to get from the unique back +-- to its corresponding Name. + + +-- See Note [Symbol table representation of names] +putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () +putName _dict BinSymbolTable{ + bin_symtab_map = symtab_map_ref, + bin_symtab_next = symtab_next } + bh name + | isKnownKeyName name + , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + = -- ASSERT(u < 2^(22 :: Int)) + put_ bh (0x80000000 + .|. (fromIntegral (ord c) `shiftL` 22) + .|. (fromIntegral u :: Word32)) + + | otherwise + = do symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + -- MASSERT(off < 2^(30 :: Int)) + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh (fromIntegral off :: Word32) + +-- See Note [Symbol table representation of names] +getSymtabName :: NameCacheUpdater + -> Dictionary -> SymbolTable + -> BinHandle -> IO Name +getSymtabName _ncu _dict symtab bh = do + i :: Word32 <- get bh + case i .&. 0xC0000000 of + 0x00000000 -> return $! symtab ! fromIntegral i + + 0x80000000 -> + let + tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) + ix = fromIntegral i .&. 0x003FFFFF + u = mkUnique tag ix + in + return $! case lookupKnownKeyName u of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" + (ppr i $$ ppr (unpkUnique u)) + Just n -> n + + _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) + +data BinSymbolTable = BinSymbolTable { + bin_symtab_next :: !FastMutInt, -- The next index to use + bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) + -- indexed by Name + } + +putFastString :: BinDictionary -> BinHandle -> FastString -> IO () +putFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: BinDictionary -> FastString -> IO Word32 +allocateFastString BinDictionary { bin_dict_next = j_r, + bin_dict_map = out_r} f = do + out <- readIORef out_r + let !uniq = getUnique f + case lookupUFM_Directly out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out uniq (j, f) + return (fromIntegral j :: Word32) + +getDictFastString :: Dictionary -> BinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + +data BinDictionary = BinDictionary { + bin_dict_next :: !FastMutInt, -- The next index to use + bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) + -- indexed by FastString + } + +getWayDescr :: Platform -> Set Way -> String +getWayDescr platform ws + | platformUnregisterised platform = 'u':tag + | otherwise = tag + where tag = waysBuildTag ws + -- if this is an unregisterised build, make sure our interfaces + -- can't be used by a registerised build. diff --git a/GHC/Iface/Env.hs b/GHC/Iface/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Env.hs @@ -0,0 +1,298 @@ +-- (c) The University of Glasgow 2002-2006 + +{-# LANGUAGE CPP, RankNTypes, BangPatterns #-} + +module GHC.Iface.Env ( + newGlobalBinder, newInteractiveBinder, + externaliseName, + lookupIfaceTop, + lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache, + newIfaceName, newIfaceNames, + extendIfaceIdEnv, extendIfaceTyVarEnv, + tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, + lookupIfaceTyVar, extendIfaceEnvs, + setNameModule, + + ifaceExportNames, + + -- Name-cache stuff + allocateGlobalBinder, updNameCacheTc, + mkNameCacheUpdater, NameCacheUpdater(..), + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Monad +import GHC.Driver.Types +import GHC.Core.Type +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Iface.Type +import GHC.Types.Name.Cache +import GHC.Types.Unique.Supply +import GHC.Types.SrcLoc + +import GHC.Utils.Outputable +import Data.List ( partition ) + +{- +********************************************************* +* * + Allocating new Names in the Name Cache +* * +********************************************************* + +See Also: Note [The Name Cache] in GHC.Types.Name.Cache +-} + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name +-- Used for source code and interface files, to make the +-- Name for a thing, given its Module and OccName +-- See Note [The Name Cache] in GHC.Types.Name.Cache +-- +-- The cache may already have a binding for this thing, +-- because we may have seen an occurrence before, but now is the +-- moment when we know its Module and SrcLoc in their full glory + +newGlobalBinder mod occ loc + = do { name <- updNameCacheTc mod occ $ \name_cache -> + allocateGlobalBinder name_cache mod occ loc + ; traceIf (text "newGlobalBinder" <+> + (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name])) + ; return name } + +newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name +-- Works in the IO monad, and gets the Module +-- from the interactive context +newInteractiveBinder hsc_env occ loc + = do { let mod = icInteractiveModule (hsc_IC hsc_env) + ; updNameCacheIO hsc_env mod occ $ \name_cache -> + allocateGlobalBinder name_cache mod occ loc } + +allocateGlobalBinder + :: NameCache + -> Module -> OccName -> SrcSpan + -> (NameCache, Name) +-- See Note [The Name Cache] in GHC.Types.Name.Cache +allocateGlobalBinder name_supply mod occ loc + = case lookupOrigNameCache (nsNames name_supply) mod occ of + -- A hit in the cache! We are at the binding site of the name. + -- This is the moment when we know the SrcLoc + -- of the Name, so we set this field in the Name we return. + -- + -- Then (bogus) multiple bindings of the same Name + -- get different SrcLocs can be reported as such. + -- + -- Possible other reason: it might be in the cache because we + -- encountered an occurrence before the binding site for an + -- implicitly-imported Name. Perhaps the current SrcLoc is + -- better... but not really: it'll still just say 'imported' + -- + -- IMPORTANT: Don't mess with wired-in names. + -- Their wired-in-ness is in their NameSort + -- and their Module is correct. + + Just name | isWiredInName name + -> (name_supply, name) + | otherwise + -> (new_name_supply, name') + where + uniq = nameUnique name + name' = mkExternalName uniq mod occ loc + -- name' is like name, but with the right SrcSpan + new_cache = extendNameCache (nsNames name_supply) mod occ name' + new_name_supply = name_supply {nsNames = new_cache} + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + _ -> (new_name_supply, name) + where + (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) + name = mkExternalName uniq mod occ loc + new_cache = extendNameCache (nsNames name_supply) mod occ name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} + +ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] +ifaceExportNames exports = return exports + +-- | A function that atomically updates the name cache given a modifier +-- function. The second result of the modifier function will be the result +-- of the IO action. +newtype NameCacheUpdater + = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } + +mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater +mkNameCacheUpdater = do { hsc_env <- getTopEnv + ; let !ncRef = hsc_NC hsc_env + ; return (NCU (updNameCache ncRef)) } + +updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c)) + -> TcRnIf a b c +updNameCacheTc mod occ upd_fn = do { + hsc_env <- getTopEnv + ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn } + + +updNameCacheIO :: HscEnv -> Module -> OccName + -> (NameCache -> (NameCache, c)) + -> IO c +updNameCacheIO hsc_env mod occ upd_fn = do { + + -- First ensure that mod and occ are evaluated + -- If not, chaos can ensue: + -- we read the name-cache + -- then pull on mod (say) + -- which does some stuff that modifies the name cache + -- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..) + + mod `seq` occ `seq` return () + ; updNameCache (hsc_NC hsc_env) upd_fn } + + +{- +************************************************************************ +* * + Name cache access +* * +************************************************************************ +-} + +-- | Look up the 'Name' for a given 'Module' and 'OccName'. +-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad +-- and 'Module' is simply that of the 'ModIface' you are typechecking. +lookupOrig :: Module -> OccName -> TcRnIf a b Name +lookupOrig mod occ + = do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) + + ; updNameCacheTc mod occ $ lookupNameCache mod occ } + +lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name +lookupOrigIO hsc_env mod occ + = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ + +lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) +-- Lookup up the (Module,OccName) in the NameCache +-- If you find it, return it; if not, allocate a fresh original name and extend +-- the NameCache. +-- Reason: this may the first occurrence of (say) Foo.bar we have encountered. +-- If we need to explore its value we will load Foo.hi; but meanwhile all we +-- need is a Name for it. +lookupNameCache mod occ name_cache = + case lookupOrigNameCache (nsNames name_cache) mod occ of { + Just name -> (name_cache, name); + Nothing -> + case takeUniqFromSupply (nsUniqs name_cache) of { + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache (nsNames name_cache) mod occ name + in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} + +externaliseName :: Module -> Name -> TcRnIf m n Name +-- Take an Internal Name and make it an External one, +-- with the same unique +externaliseName mod name + = do { let occ = nameOccName name + loc = nameSrcSpan name + uniq = nameUnique name + ; occ `seq` return () -- c.f. seq in newGlobalBinder + ; updNameCacheTc mod occ $ \ ns -> + let name' = mkExternalName uniq mod occ loc + ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' } + in (ns', name') } + +-- | Set the 'Module' of a 'Name'. +setNameModule :: Maybe Module -> Name -> TcRnIf m n Name +setNameModule Nothing n = return n +setNameModule (Just m) n = + newGlobalBinder m (nameOccName n) (nameSrcSpan n) + +{- +************************************************************************ +* * + Type variables and local Ids +* * +************************************************************************ +-} + +tcIfaceLclId :: FastString -> IfL Id +tcIfaceLclId occ + = do { lcl <- getLclEnv + ; case (lookupFsEnv (if_id_env lcl) occ) of + Just ty_var -> return ty_var + Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) + } + +extendIfaceIdEnv :: [Id] -> IfL a -> IfL a +extendIfaceIdEnv ids thing_inside + = do { env <- getLclEnv + ; let { id_env' = extendFsEnvList (if_id_env env) pairs + ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } + ; setLclEnv (env { if_id_env = id_env' }) thing_inside } + + +tcIfaceTyVar :: FastString -> IfL TyVar +tcIfaceTyVar occ + = do { lcl <- getLclEnv + ; case (lookupFsEnv (if_tv_env lcl) occ) of + Just ty_var -> return ty_var + Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) + } + +lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) +lookupIfaceTyVar (occ, _) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_tv_env lcl) occ) } + +lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) +lookupIfaceVar (IfaceIdBndr (_, occ, _)) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_id_env lcl) occ) } +lookupIfaceVar (IfaceTvBndr (occ, _)) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_tv_env lcl) occ) } + +extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a +extendIfaceTyVarEnv tyvars thing_inside + = do { env <- getLclEnv + ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs + ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } + ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } + +extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a +extendIfaceEnvs tcvs thing_inside + = extendIfaceTyVarEnv tvs $ + extendIfaceIdEnv cvs $ + thing_inside + where + (tvs, cvs) = partition isTyVar tcvs + +{- +************************************************************************ +* * + Getting from RdrNames to Names +* * +************************************************************************ +-} + +-- | Look up a top-level name from the current Iface module +lookupIfaceTop :: OccName -> IfL Name +lookupIfaceTop occ + = do { env <- getLclEnv; lookupOrig (if_mod env) occ } + +newIfaceName :: OccName -> IfL Name +newIfaceName occ + = do { uniq <- newUnique + ; return $! mkInternalName uniq occ noSrcSpan } + +newIfaceNames :: [OccName] -> IfL [Name] +newIfaceNames occs + = do { uniqs <- newUniqueSupply + ; return [ mkInternalName uniq occ noSrcSpan + | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } diff --git a/GHC/Iface/Env.hs-boot b/GHC/Iface/Env.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Iface/Env.hs-boot @@ -0,0 +1,9 @@ +module GHC.Iface.Env where + +import GHC.Unit.Module +import GHC.Types.Name.Occurrence +import GHC.Tc.Utils.Monad +import GHC.Types.Name +import GHC.Types.SrcLoc + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/GHC/Iface/Ext/Ast.hs b/GHC/Iface/Ext/Ast.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Ast.hs @@ -0,0 +1,2028 @@ +{- +Main functions for .hie file generation +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where + +import GHC.Utils.Outputable(ppr) + +import GHC.Prelude + +import GHC.Types.Avail ( Avails ) +import GHC.Data.Bag ( Bag, bagToList ) +import GHC.Types.Basic +import GHC.Data.BooleanFormula +import GHC.Core.Class ( FunDep, className, classSCSelIds ) +import GHC.Core.Utils ( exprType ) +import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) +import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) +import GHC.Core.FVs +import GHC.Core.DataCon ( dataConNonlinearType ) +import GHC.HsToCore ( deSugarExpr ) +import GHC.Types.FieldLabel +import GHC.Hs +import GHC.Driver.Types +import GHC.Unit.Module ( ModuleName, ml_hs_file ) +import GHC.Utils.Monad ( concatMapM, liftIO ) +import GHC.Types.Id ( isDataConId_maybe ) +import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import GHC.Types.SrcLoc +import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) +import GHC.Core.Type ( mkVisFunTys, Type ) +import GHC.Core.Predicate +import GHC.Core.InstEnv +import GHC.Builtin.Types ( mkListTy, mkSumTy ) +import GHC.Tc.Types +import GHC.Tc.Types.Evidence +import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) +import GHC.Types.Var.Env +import GHC.Types.Unique +import GHC.Iface.Make ( mkIfaceExports ) +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.List ( foldl1' ) +import Control.Monad ( forM_ ) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) + +{- Note [Updating HieAst for changes in the GHC AST] + +When updating the code in this file for changes in the GHC AST, you +need to pay attention to the following things: + +1) Symbols (Names/Vars/Modules) in the following categories: + + a) Symbols that appear in the source file that directly correspond to + something the user typed + b) Symbols that don't appear in the source, but should be in some sense + "visible" to a user, particularly via IDE tooling or the like. This + includes things like the names introduced by RecordWildcards (We record + all the names introduced by a (..) in HIE files), and will include implicit + parameters and evidence variables after one of my pending MRs lands. + +2) Subtrees that may contain such symbols, or correspond to a SrcSpan in + the file. This includes all `Located` things + +For 1), you need to call `toHie` for one of the following instances + +instance ToHie (Context (Located Name)) where ... +instance ToHie (Context (Located Var)) where ... +instance ToHie (IEContext (Located ModuleName)) where ... + +`Context` is a data type that looks like: + +data Context a = C ContextInfo a -- Used for names and bindings + +`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like + +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + ... + +It is used to annotate symbols in the .hie files with some extra information on +the context in which they occur and should be fairly self explanatory. You need +to select one that looks appropriate for the symbol usage. In very rare cases, +you might need to extend this sum type if none of the cases seem appropriate. + +So, given a `Located Name` that is just being "used", and not defined at a +particular location, you would do the following: + + toHie $ C Use located_name + +If you select one that corresponds to a binding site, you will need to +provide a `Scope` and a `Span` for your binding. Both of these are basically +`SrcSpans`. + +The `SrcSpan` in the `Scope` is supposed to span over the part of the source +where the symbol can be legally allowed to occur. For more details on how to +calculate this, see Note [Capturing Scopes and other non local information] +in GHC.Iface.Ext.Ast. + +The binding `Span` is supposed to be the span of the entire binding for +the name. + +For a function definition `foo`: + +foo x = x + y + where y = x^2 + +The binding `Span` is the span of the entire function definition from `foo x` +to `x^2`. For a class definition, this is the span of the entire class, and +so on. If this isn't well defined for your bit of syntax (like a variable +bound by a lambda), then you can just supply a `Nothing` + +There is a test that checks that all symbols in the resulting HIE file +occur inside their stated `Scope`. This can be turned on by passing the +-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the +.hie file. + +You may also want to provide a test in testsuite/test/hiefile that includes +a file containing your new construction, and tests that the calculated scope +is valid (by using -fvalidate-ide-info) + +For subtrees in the AST that may contain symbols, the procedure is fairly +straightforward. If you are extending the GHC AST, you will need to provide a +`ToHie` instance for any new types you may have introduced in the AST. + +Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): + + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + ... + HsApp _ a b -> + [ toHie a + , toHie b + ] + +If your subtree is `Located` or has a `SrcSpan` available, the output list +should contain a HieAst `Node` corresponding to the subtree. You can use +either `makeNode` or `getTypeNode` for this purpose, depending on whether it +makes sense to assign a `Type` to the subtree. After this, you just need +to concatenate the result of calling `toHie` on all subexpressions and +appropriately annotated symbols contained in the subtree. + +The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed +to work for both the renamed and typechecked source. `getTypeNode` is from +the `HasType` class defined in this file, and it has different instances +for `GhcTc` and `GhcRn` that allow it to access the type of the expression +when given a typechecked AST: + +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = ... -- Actually get the type for this expression +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type + +If your subtree doesn't have a span available, you can omit the `makeNode` +call and just recurse directly in to the subexpressions. + +-} + +-- These synonyms match those defined in compiler/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe LHsDocString ) +type TypecheckedSource = LHsBinds GhcTc + + +{- Note [Name Remapping] +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +type VarMap a = DVarEnv (Var,a) +data HieState = HieState + { name_remapping :: NameEnv Id + , unlocated_ev_binds :: VarMap (S.Set ContextInfo) + -- These contain evidence bindings that we don't have a location for + -- These are placed at the top level Node in the HieAST after everything + -- else has been generated + -- This includes things like top level evidence bindings. + } + +addUnlocatedEvBind :: Var -> ContextInfo -> HieM () +addUnlocatedEvBind var ci = do + let go (a,b) (_,c) = (a,S.union b c) + lift $ modify' $ \s -> + s { unlocated_ev_binds = + extendDVarEnv_C go (unlocated_ev_binds s) + var (var,S.singleton ci) + } + +getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type]) +getUnlocatedEvBinds file = do + binds <- lift $ gets unlocated_ev_binds + org <- ask + let elts = dVarEnvElts binds + + mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) + + go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of + RealSrcSpan spn _ + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) + _ -> (mkNodeInfo e : xs,ys) + + (nis,asts) = foldr go ([],[]) elts + + pure $ (M.fromList nis, asts) + +initState :: HieState +initState = HieState emptyNameEnv emptyDVarEnv + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} + +modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f + = addSubstitution mono poly . f + go _ f = f + +type HieM = ReaderT NodeOrigin (StateT HieState Hsc) + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: ModSummary + -> TcGblEnv + -> RenamedSource -> Hsc HieFile +mkHieFile ms ts rs = do + let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms) + src <- liftIO $ BS.readFile src_file + mkHieFileWithSource src_file src ms ts rs + +-- | Construct an 'HieFile' from the outputs of the typechecker but don't +-- read the source file again from disk. +mkHieFileWithSource :: FilePath + -> BS.ByteString + -> ModSummary + -> TcGblEnv + -> RenamedSource -> Hsc HieFile +mkHieFileWithSource src_file src ms ts rs = do + let tc_binds = tcg_binds ts + top_ev_binds = tcg_ev_binds ts + insts = tcg_insts ts + tcs = tcg_tcs ts + (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] + -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs top_ev_binds insts tcs = do + asts <- enrichHie ts rs top_ev_binds insts tcs + return $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] + -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = + flip evalStateT initState $ flip runReaderT SourceInfo $ do + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + -- Add Instance bindings + forM_ insts $ \i -> + addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) + -- Add class parent bindings + forM_ tcs $ \tc -> + case tyConClass_maybe tc of + Nothing -> pure () + Just c -> forM_ (classSCSelIds c) $ \v -> + addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) + let spanFile file children = case children of + [] -> realSrcLocSpan (mkRealSrcLoc file 1 1) + _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) + (realSrcSpanEnd $ nodeSpan $ last children) + + flat_asts = concat + [ tasts + , rasts + , imps + , exps + ] + + modulify file xs' = do + + top_ev_asts <- + toHie $ EvBindContext ModuleScope Nothing + $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) + $ EvBinds ev_bs + + (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file + + let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts + span = spanFile file xs + + moduleInfo = SourcedNodeInfo + $ M.singleton SourceInfo + $ (simpleNodeInfo "Module" "Module") + {nodeIdentifiers = uloc_evs} + + moduleNode = Node moduleInfo span [] + + case mergeSortAsts $ moduleNode : xs of + [x] -> return x + xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs) + + asts' <- sequence + $ M.mapWithKey modulify + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + let asts = HieASTs $ resolveTyVarScopes asts' + return asts + where + processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + ] + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan _ = Nothing + +grhss_span :: GRHSs p body -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span (XGRHSs _) = panic "XGRHS has no span" + +bindingsOnly :: [Context Name] -> HieM [HieAST a] +bindingsOnly [] = pure [] +bindingsOnly (C c n : xs) = do + org <- ask + rest <- bindingsOnly xs + pure $ case nameSrcSpan n of + RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> rest + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] +toHie is a local transformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data EvBindContext a = EvBindContext Scope (Maybe Span) a + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Typeable, Data) -- Pattern Scope + +{- Note [TyVar Scopes] +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes _ [] = [] +listScopes rhsScope [pat] = [RS rhsScope pat] +listScopes rhsScope (pat : pats) = RS sc pat : pats' + where + pats'@((RS scope p):_) = listScopes rhsScope pats + sc = combineScopes scope $ mkScope $ getLoc p + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Maybe Span + -> Scope + -> Scope + -> [LPat (GhcPass p)] + -> [PScoped (LPat (GhcPass p))] +patScopes rsp useScope patScope xs = + map (\(RS sc a) -> PS rsp useScope sc a) $ + listScopes patScope xs + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr flag a] + -> [TVScoped (LHsTyVarBndr flag a)] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here + +This case in handled in the instance for HsPatSigType +-} + +class HasLoc a where + -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can + -- know what their implicit bindings are scoping over + loc :: a -> SrcSpan + +instance HasLoc thing => HasLoc (TScoped thing) where + loc (TS _ a) = loc a + +instance HasLoc thing => HasLoc (PScoped thing) where + loc (PS _ _ _ a) = loc a + +instance HasLoc (LHsQTyVars GhcRn) where + loc (HsQTvs _ vs) = loc vs + +instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where + loc (HsIB _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where + loc (HsWC _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc (Located a) where + loc (L l _) = l + +instance HasLoc a => HasLoc [a] where + loc [] = noSrcSpan + loc xs = foldl1' combineSrcSpans $ map loc xs + +instance HasLoc a => HasLoc (FamEqn s a) where + loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] + loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans + [loc a, loc tvs, loc b, loc c] + loc _ = noSrcSpan +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg _ ty) = loc ty + loc (HsArgPar sp) = sp + +instance HasLoc (HsDataDefn GhcRn) where + loc def@(HsDataDefn{}) = loc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + +{- Note [Real DataCon Name] +The typechecker substitutes the conLikeWrapId for the name, but we don't want +this showing up in the hieFile, so we replace the name in the Id with the +original datacon name +See also Note [Data Constructor Naming] +-} +class HasRealDataConName p where + getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) + +instance HasRealDataConName GhcRn where + getRealDataCon _ n = n +instance HasRealDataConName GhcTc where + getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = + L sp (setVarName var (conLikeName con)) + +-- | The main worker class +-- See Note [Updating HieAst for changes in the GHC AST] for more information +-- on how to add/modify instances for this. +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (IEContext (Located ModuleName)) where + toHie (IEC c (L (RealSrcSpan span _) mname)) = do + org <- ask + pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | varUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of + Nothing -> varType name' + Just dc -> dataConNonlinearType dc + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just ty) + (S.singleton context))) + span + []] + C (EvidenceVarBind i _ sp) (L _ name) -> do + addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) + pure [] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | nameUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m name' of + Just var -> varName var + Nothing -> name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +evVarsOfTermList :: EvTerm -> [EvId] +evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e +evVarsOfTermList (EvTypeable _ ev) = + case ev of + EvTypeableTyCon _ e -> concatMap evVarsOfTermList e + EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] + EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] + EvTypeableTyLit e -> evVarsOfTermList e +evVarsOfTermList (EvFun{}) = [] + +instance ToHie (EvBindContext (Located TcEvBinds)) where + toHie (EvBindContext sc sp (L span (EvBinds bs))) + = concatMapM go $ bagToList bs + where + go evbind = do + let evDeps = evVarsOfTermList $ eb_rhs evbind + depNames = EvBindDeps $ map varName evDeps + concatM $ + [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) + (L span $ eb_lhs evbind)) + , toHie $ map (C EvidenceVarUse . L span) $ evDeps + ] + toHie _ = pure [] + +instance ToHie (Located HsWrapper) where + toHie (L osp wrap) + = case wrap of + (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs) + (WpCompose a b) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpFun a b _ _) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpEvLam a) -> + toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp)) + $ L osp a + (WpEvApp a) -> + concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a + _ -> pure [] + +instance HiePass p => HasType (LHsBind (GhcPass p)) where + getTypeNode (L spn bind) = + case hiePass @p of + HieRn -> makeNode bind spn + HieTc -> case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn + +instance HiePass p => HasType (Located (Pat (GhcPass p))) where + getTypeNode (L spn pat) = + case hiePass @p of + HieRn -> makeNode pat spn + HieTc -> makeTypeNode pat spn (hsPatType pat) + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +instance HiePass p => HasType (LHsExpr (GhcPass p)) where + getTypeNode e@(L spn e') = + case hiePass @p of + HieRn -> makeNode e' spn + HieTc -> + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) + + HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con) + + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty + + _ -> Nothing + + in + case tyOpt of + Just t -> makeTypeNode e' spn t + Nothing + | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn + + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkVisFunTys args res + + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr GhcTc -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + XExpr (WrapExpr {}) -> False + _ -> True + +data HiePassEv p where + HieRn :: HiePassEv 'Renamed + HieTc :: HiePassEv 'Typechecked + +class ( IsPass p + , HiePass (NoGhcTcPass p) + , ModifyState (IdGhcP p) + , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p)))) + , Data (HsExpr (GhcPass p)) + , Data (HsCmd (GhcPass p)) + , Data (AmbiguousFieldOcc (GhcPass p)) + , Data (HsCmdTop (GhcPass p)) + , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p)))) + , Data (HsSplice (GhcPass p)) + , Data (HsLocalBinds (GhcPass p)) + , Data (FieldOcc (GhcPass p)) + , Data (HsTupArg (GhcPass p)) + , Data (IPBind (GhcPass p)) + , ToHie (Context (Located (IdGhcP p))) + , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) + , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) + , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) + , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) + , HasRealDataConName (GhcPass p) + ) + => HiePass p where + hiePass :: HiePassEv p + +instance HiePass 'Renamed where + hiePass = HieRn +instance HiePass 'Typechecked where + hiePass = HieTc + +instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> + [ toHie $ C (ValBind context scope $ getRealSpan span) name + , toHie matches + , case hiePass @p of + HieTc -> toHie $ L span wrap + _ -> pure [] + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan span) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + AbsBinds{ abs_exports = xs, abs_binds = binds + , abs_ev_binds = ev_binds + , abs_ev_vars = ev_vars } -> + [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] + (toHie $ fmap (BC context scope) binds) + , toHie $ map (L span . abe_wrap) xs + , toHie $ + map (EvBindContext (mkScope span) (getRealSpan span) + . L span) ev_binds + , toHie $ + map (C (EvidenceVarBind EvSigBind + (mkScope span) + (getRealSpan span)) + . L span) ev_vars + ] + PatSynBind _ psb -> + [ toHie $ L span psb -- PatSynBinds only occur at the top level + ] + +instance ( HiePass p + , ToHie (Located body) + , Data body + ) => ToHie (MatchGroup (GhcPass p) (Located body)) where + toHie mg = case mg of + MG{ mg_alts = (L span alts) , mg_origin = origin} -> + local (setOrigin origin) $ concatM + [ locOnly span + , toHie alts + ] + +setOrigin :: Origin -> NodeOrigin -> NodeOrigin +setOrigin FromSource _ = SourceInfo +setOrigin Generated _ = GeneratedInfo + +instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope patScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkLScope var + patScope = mkScope $ getLoc pat + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args + (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField a b) c = combineScopes c + $ combineScopes (mkLScope a) (mkLScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + +instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( HiePass p + , Data body + , ToHie (Located body) + ) => ToHie (LMatch (GhcPass p) (Located body)) where + toHie (L span m ) = concatM $ node : case m of + Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> + [ toHie mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + where + node = case hiePass @p of + HieTc -> makeNode m span + HieRn -> makeNode m span + +instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where + toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name + toHie (StmtCtxt a) = toHie a + toHie _ = pure [] + +instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where + toHie (PatGuard a) = toHie a + toHie (ParStmtCtxt a) = toHie a + toHie (TransStmtCtxt a) = toHie a + toHie _ = pure [] + +instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where + toHie (PS rsp scope pscope lpat@(L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkLScope pat) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} -> + case hiePass @p of + HieTc -> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + , let ev_binds = cpt_binds ext + ev_vars = cpt_dicts ext + wrap = cpt_wrap ext + evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope + in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds + , toHie $ L ospan wrap + , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) + . L ospan) ev_vars + ] + ] + HieRn -> + [ toHie $ C Use con + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ _ _ _ -> + [] + NPlusKPat _ n _ _ _ _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + ] + SigPat _ pat sig -> + [ toHie $ PS rsp scope pscope pat + , case hiePass @p of + HieTc -> + let cscope = mkLScope pat in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + sig + HieRn -> pure [] + ] + XPat e -> + case hiePass @p of + HieTc -> + let CoPat wrap pat _ = e + in [ toHie $ L ospan wrap + , toHie $ PS rsp scope pscope $ (L ospan pat) + ] +#if __GLASGOW_HASKELL__ < 811 + HieRn -> [] +#endif + where + contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) + -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) + contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args + contextify (InfixCon a b) = InfixCon a' b' + where [a', b'] = patScopes rsp scope pscope [a,b] + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a + where + go (RS fscope (L spn (HsRecField lbl pat pun))) = + L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + + +instance ToHie (TScoped (HsPatSigType GhcRn)) where + toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) + , toHie body + ] + -- See Note [Scoping Rules for SigPat] + +instance ( ToHie (Located body) + , HiePass p + , Data body + ) => ToHie (GRHSs (GhcPass p) (Located body)) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + +instance ( ToHie (Located body) + , HiePass a + , Data body + ) => ToHie (LGRHS (GhcPass a) (Located body)) where + toHie (L span g) = concatM $ node : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkLScope body) guards + , toHie body + ] + where + node = case hiePass @a of + HieRn -> makeNode g span + HieTc -> makeNode g span + +instance HiePass p => ToHie (LHsExpr (GhcPass p)) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsUnboundVar _ _ -> + [] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + HsRecFld _ fld -> + [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HsOverLabel _ _ _ -> [] + HsIPVar _ _ -> [] + HsOverLit _ _ -> [] + HsLit _ _ -> [] + HsLam _ mg -> + [ toHie mg + ] + HsLamCase _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkLScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ _ exprs -> + [ toHie exprs + ] + RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> + [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) + -- See Note [Real DataCon Name] + , toHie $ RC RecFieldAssign $ binds + ] + RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + [ toHie expr + , toHie $ map (RC RecFieldAssign) upds + ] + ExprWithTySig _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + ] + ArithSeq _ _ info -> + [ toHie info + ] + HsPragE _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsTick _ _ expr -> + [ toHie expr + ] + HsBinTick _ _ _ expr -> + [ toHie expr + ] + HsBracket _ b -> + [ toHie b + ] + HsRnBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsTcBracketOut _ _wrap b p -> + [ toHie b + , toHie p + ] + HsSpliceE _ x -> + [ toHie $ L mspan x + ] + XExpr x + | GhcTc <- ghcPass @p + , WrapExpr (HsWrap w a) <- x + -> [ toHie $ L mspan a + , toHie (L mspan w) + ] + | GhcTc <- ghcPass @p + , ExpansionExpr (HsExpanded _ b) <- x + -> [ toHie (L mspan b) + ] + | otherwise -> [] + +instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where + toHie (L span arg) = concatM $ makeNode arg span : case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + +instance ( ToHie (Located body) + , Data body + , HiePass p + ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where + toHie (RS scope (L span stmt)) = concatM $ node : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt _ pat body -> + [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + , toHie body + ] + ApplicativeStmt _ stmts _ -> + [ concatMapM (toHie . RS scope . snd) stmts + ] + BodyStmt _ body _ _ -> + [ toHie body + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + ] + where + node = case hiePass @p of + HieTc -> makeNode stmt span + HieRn -> makeNode stmt span + +instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where + toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ ipbinds -> case ipbinds of + IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in + [ case hiePass @p of + HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds + HieRn -> pure [] + , toHie $ map (RS sc) xs + ] + HsValBinds _ valBinds -> + [ toHie $ RS (combineScopes scope $ mkScope sp) + valBinds + ] + +instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where + toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of + IPBind _ (Left _) expr -> [toHie expr] + IPBind _ (Right v) expr -> + [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp)) + $ L sp v + , toHie expr + ] + +instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie arg , HasLoc arg , Data arg + , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where + toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext (Located label)) + , ToHie arg , HasLoc arg , Data arg + , Data label + ) => ToHie (RContext (LHsRecField' label arg)) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of + HsRecField label expr _ -> + [ toHie $ RFC c (getRealSpan $ loc expr) label + , toHie expr + ] + +instance ToHie (RFContext (LFieldOcc GhcRn)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc name _ -> + [ toHie $ C (RecField c rhs) (L nspan name) + ] + +instance ToHie (RFContext (LFieldOcc GhcTc)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous name _ -> + [ toHie $ C (RecField c rhs) $ L nspan name + ] + Ambiguous _name _ -> + [ ] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + Ambiguous var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + +instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where + toHie (L span top) = concatM $ makeNode top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + +instance HiePass p => ToHie (LHsCmd (GhcPass p)) where + toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdLam _ mg -> + [ toHie mg + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdLamCase _ alts -> + [ toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkLScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie TyClGroup{ group_tyclds = classes + , group_roles = roles + , group_kisigs = sigs + , group_instds = instances } = + concatM + [ toHie classes + , toHie sigs + , toHie roles + , toHie instances + ] + +instance ToHie (LTyClDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie (L span fdecl) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkLScope $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkLScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn + deriv_sc = mkLScope $ dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpan span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (locOnly . getLoc) deftyps + , toHie deftyps + ] + where + context_scope = mkLScope context + rhs_scope = foldl1' combineScopes $ map mkScope + [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + +instance ToHie (LFamilyDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamilyDecl _ info name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLoc sig + injSpan = maybe NoScope (mkScope . getLoc) inj + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (locOnly . getLoc) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LFamilyResultSig GhcRn)) where + toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + +instance ToHie (Located (FunDep (Located Name))) where + toHie (L span fd@(lhs, rhs)) = concatM $ + [ makeNode fd span + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + +instance (ToHie rhs, HasLoc rhs) + => ToHie (TScoped (FamEqn GhcRn rhs)) where + toHie (TS _ f) = toHie f + +instance (ToHie rhs, HasLoc rhs) + => ToHie (FamEqn GhcRn rhs) where + toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie pats + , toHie rhs + ] + where scope = combineScopes patsScope rhsScope + patsScope = mkScope (loc pats) + rhsScope = mkScope (loc rhs) + +instance ToHie (LInjectivityAnn GhcRn) where + toHie (L span ann) = concatM $ makeNode ann span : case ann of + InjectivityAnn lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + +instance ToHie (HsDeriving GhcRn) where + toHie (L span clauses) = concatM + [ locOnly span + , toHie clauses + ] + +instance ToHie (LHsDerivingClause GhcRn) where + toHie (L span cl) = concatM $ makeNode cl span : case cl of + HsDerivingClause _ strat (L ispan tys) -> + [ toHie strat + , locOnly ispan + , toHie $ map (TS (ResolvedScopes [])) tys + ] + +instance ToHie (Located (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNode strat span : case strat of + StockStrategy -> [] + AnyclassStrategy -> [] + NewtypeStrategy -> [] + ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] + +instance ToHie (Located OverlapMode) where + toHie (L span _) = locOnly span + +instance ToHie a => ToHie (HsScaled GhcRn a) where + toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] + +instance ToHie (LConDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars + , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + , concatM $ [ bindingsOnly bindings + , toHie $ tvScopes resScope NoScope exp_vars ] + , toHie ctx + , toHie args + , toHie typ + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope args + tyScope = mkLScope typ + resScope = ResolvedScopes [ctxScope, rhsScope] + bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets } -> + [ toHie $ C (Decl ConDec $ getRealSpan span) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope dets + where condecl_scope :: HsConDeclDetails p -> Scope + condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs + InfixCon a b -> combineScopes (mkLScope (hsScaledThing a)) + (mkLScope (hsScaledThing b)) + RecCon x -> mkLScope x + +instance ToHie (Located [LConDeclField GhcRn]) where + toHie (L span decls) = concatM $ + [ locOnly span + , toHie decls + ] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where + toHie (TS sc (HsIB ibrn a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn + , toHie $ TS sc a + ] + where span = loc a + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where + toHie (TS sc (HsWC names a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + +instance ToHie (LStandaloneKindSig GhcRn) where + toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] + +instance ToHie (StandaloneKindSig GhcRn) where + toHie sig = concatM $ case sig of + StandaloneKindSig _ name typ -> + [ toHie $ C TyDecl name + , toHie $ TS (ResolvedScopes []) typ + ] + +instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where + toHie (SC (SI styp msp) (L sp sig)) = + case hiePass @p of + HieTc -> pure [] + HieRn -> concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , maybe (pure []) (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + +instance ToHie (LHsType GhcRn) where + toHie x = toHie $ TS (ResolvedScopes []) x + +instance ToHie (TScoped (LHsType GhcRn)) where + toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of + HsForAllTy _ tele body -> + let scope = mkScope $ getLoc body in + [ case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + toHie $ tvScopes tsc scope bndrs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + toHie $ tvScopes tsc scope bndrs + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie $ TS (ResolvedScopes []) ki + ] + HsFunTy _ w a b -> + [ toHie (arrowToHsType w) + , toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a _ -> + [ toHie a + ] + HsBangTy _ _ ty -> + [ toHie ty + ] + HsRecTy _ fields -> + [ toHie fields + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = locOnly sp + +instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + UserTyVar _ _ var -> + [ toHie $ C (TyVarBind sc tsc) var + ] + KindedTyVar _ _ var kind -> + [ toHie $ C (TyVarBind sc tsc) var + , toHie kind + ] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs implicits vars)) = concatM $ + [ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = loc vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + +instance ToHie (LHsContext GhcRn) where + toHie (L span tys) = concatM $ + [ locOnly span + , toHie tys + ] + +instance ToHie (LConDeclField GhcRn) where + toHie (L span field) = concatM $ makeNode field span : case field of + ConDeclField _ fields typ _ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + , toHie typ + ] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LSpliceDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + +instance ToHie (HsBracket a) where + toHie _ = pure [] + +instance ToHie PendingRnSplice where + toHie _ = pure [] + +instance ToHie PendingTcSplice where + toHie _ = pure [] + +instance ToHie (LBooleanFormula (Located Name)) where + toHie (L span form) = concatM $ makeNode form span : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (Located HsIPName) where + toHie (L span e) = makeNode e span + +instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where + toHie (L span sp) = concatM $ makeNode sp span : case sp of + HsTypedSplice _ _ _ expr -> + [ toHie expr + ] + HsUntypedSplice _ _ _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ _ ispan _ -> + [ locOnly ispan + ] + HsSpliced _ _ _ -> + [] + XSplice x -> case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon x + GhcRn -> noExtCon x +#endif + GhcTc -> case x of + HsSplicedT _ -> [] + +instance ToHie (LRoleAnnotDecl GhcRn) where + toHie (L span annot) = concatM $ makeNode annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (locOnly . getLoc) roles + ] + +instance ToHie (LInstDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + +instance ToHie (LClsInstDecl GhcRn) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl + , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LDataFamInstDecl GhcRn) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LTyFamInstDecl GhcRn) where + toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (Context a) + => ToHie (PatSynFieldContext (RecordPatSynField a)) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LDerivDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie strat + , toHie overlap + ] + +instance ToHie (LFixitySig GhcRn) where + toHie (L span sig) = concatM $ makeNode sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LDefaultDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DefaultDecl _ typs -> + [ toHie typs + ] + +instance ToHie (LForeignDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + +instance ToHie ForeignImport where + toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $ + [ locOnly a + , locOnly b + , locOnly c + ] + +instance ToHie ForeignExport where + toHie (CExport (L a _) (L b _)) = concatM $ + [ locOnly a + , locOnly b + ] + +instance ToHie (LWarnDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warnings _ _ warnings -> + [ toHie warnings + ] + +instance ToHie (LWarnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LAnnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsAnnotation _ _ prov expr -> + [ toHie prov + , toHie expr + ] + +instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LRuleDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsRules _ _ rules -> + [ toHie rules + ] + +instance ToHie (LRuleDecl GhcRn) where + toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM + [ makeNode r span + , locOnly $ getLoc rname + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie $ map (RS $ mkScope span) bndrs + , toHie exprA + , toHie exprB + ] + where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc + bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) + exprA_sc = mkLScope exprA + exprB_sc = mkLScope exprB + +instance ToHie (RScoped (LRuleBndr GhcRn)) where + toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + +instance ToHie (LImportDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + where + goIE (hiding, (L sp liens)) = concatM $ + [ locOnly sp + , toHie $ map (IEC c) liens + ] + where + c = if hiding then ImportHiding else Import + +instance ToHie (IEContext (LIE GhcRn)) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of + IEVar _ n -> + [ toHie $ IEC c n + ] + IEThingAbs _ n -> + [ toHie $ IEC c n + ] + IEThingAll _ n -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns flds -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + , toHie $ map (IEC c) flds + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ _ -> [] + IEDoc _ _ -> [] + IEDocNamed _ _ -> [] + +instance ToHie (IEContext (LIEWrappedName Name)) where + toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + IEName n -> + [ toHie $ C (IEThing c) n + ] + IEPattern p -> + [ toHie $ C (IEThing c) p + ] + IEType n -> + [ toHie $ C (IEThing c) n + ] + +instance ToHie (IEContext (Located (FieldLbl Name))) where + toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of + FieldLabel _ _ n -> + [ toHie $ C (IEThing c) $ L span n + ] diff --git a/GHC/Iface/Ext/Binary.hs b/GHC/Iface/Ext/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Binary.hs @@ -0,0 +1,364 @@ +{- +Binary serialization for .hie files. +-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +module GHC.Iface.Ext.Binary + ( readHieFile + , readHieFileWithVersion + , HieHeader + , writeHieFile + , HieName(..) + , toHieName + , HieFileResult(..) + , hieMagic + , hieNameOcc + , NameCacheUpdater(..) + ) +where + +import GHC.Settings.Utils ( maybeRead ) +import GHC.Settings.Config ( cProjectVersion ) +import GHC.Prelude +import GHC.Utils.Binary +import GHC.Iface.Binary ( getDictFastString ) +import GHC.Data.FastMutInt +import GHC.Data.FastString ( FastString ) +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Utils.Outputable +import GHC.Builtin.Utils +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.Supply ( takeUniqFromSupply ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Iface.Env (NameCacheUpdater(..)) + +import qualified Data.Array as A +import Data.IORef +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.List ( mapAccumR ) +import Data.Word ( Word8, Word32 ) +import Control.Monad ( replicateM, when ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( takeDirectory ) + +import GHC.Iface.Ext.Types + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName))) + } + +data HieDictionary = HieDictionary + { hie_dict_next :: !FastMutInt -- The next index to use + , hie_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString + } + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + +-- | The header for HIE files - Capital ASCII letters \"HIE\". +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = length hieMagic + +ghcVersion :: ByteString +ghcVersion = BSC.pack cProjectVersion + +putBinLine :: BinHandle -> ByteString -> IO () +putBinLine bh xs = do + mapM_ (putByte bh) $ BS.unpack xs + putByte bh 10 -- newline char + +-- | Write a `HieFile` to the given `FilePath`, with a proper header and +-- symbol tables for `Name`s and `FastString`s +writeHieFile :: FilePath -> HieFile -> IO () +writeHieFile hie_file_path hiefile = do + bh0 <- openBinMem initBinMemSize + + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ (putByte bh0) hieMagic + putBinLine bh0 $ BSC.pack $ show hieVersion + putBinLine bh0 $ ghcVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellBin bh0 + put_ bh0 dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellBin bh0 + put_ bh0 symtab_p_p + + -- Make some initial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName))) + let hie_symtab = HieSymbolTable { + hie_symtab_next = symtab_next, + hie_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let hie_dict = HieDictionary { + hie_dict_next = dict_next_ref, + hie_dict_map = dict_map_ref } + + -- put the main thing + let bh = setUserData bh0 $ newWriteState (putName hie_symtab) + (putName hie_symtab) + (putFastString hie_dict) + put_ bh hiefile + + -- write the symtab pointer at the front of the file + symtab_p <- tellBin bh + putAt bh symtab_p_p symtab_p + seekBin bh symtab_p + + -- write the symbol table itself + symtab_next' <- readFastMutInt symtab_next + symtab_map' <- readIORef symtab_map + putSymbolTable bh symtab_next' symtab_map' + + -- write the dictionary pointer at the front of the file + dict_p <- tellBin bh + putAt bh dict_p_p dict_p + seekBin bh dict_p + + -- write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + + -- and send the result to the file + createDirectoryIfMissing True (takeDirectory hie_file_path) + writeBinMem bh hie_file_path + return () + +data HieFileResult + = HieFileResult + { hie_file_result_version :: Integer + , hie_file_result_ghc_version :: ByteString + , hie_file_result :: HieFile + } + +type HieHeader = (Integer, ByteString) + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. Allows you to specify +-- which versions of hieFile to attempt to read. +-- `Left` case returns the failing header versions. +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult) +readHieFileWithVersion readVersion ncu file = do + bh0 <- readBinMem file + + (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + + if readVersion (hieVersion, ghcVersion) + then do + hieFile <- readHieFileContents bh0 ncu + return $ Right (HieFileResult hieVersion ghcVersion hieFile) + else return $ Left (hieVersion, ghcVersion) + + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. +readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult +readHieFile ncu file = do + + bh0 <- readBinMem file + + (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + hieFile <- readHieFileContents bh0 ncu + return $ HieFileResult hieVersion ghcVersion hieFile + +readBinLine :: BinHandle -> IO ByteString +readBinLine bh = BS.pack . reverse <$> loop [] + where + loop acc = do + char <- get bh :: IO Word8 + if char == 10 -- ASCII newline '\n' + then return acc + else loop (char : acc) + +readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + -- Read the header + magic <- replicateM hieMagicLen (get bh0) + version <- BSC.unpack <$> readBinLine bh0 + case maybeRead version of + Nothing -> + panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" + , show version + ] + Just readHieVersion -> do + ghcVersion <- readBinLine bh0 + + -- Check if the header is valid + when (magic /= hieMagic) $ + panic $ unwords ["readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (readHieVersion, ghcVersion) + +readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile +readHieFileContents bh0 ncu = do + + dict <- get_dictionary bh0 + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- get_symbol_table bh1 + let bh1' = setUserData bh1 + $ newReadState (getSymTabName symtab) + (getDictFastString dict) + return bh1' + + -- load the actual data + hiefile <- get bh1 + return hiefile + where + get_dictionary bin_handle = do + dict_p <- get bin_handle + data_p <- tellBin bin_handle + seekBin bin_handle dict_p + dict <- getDictionary bin_handle + seekBin bin_handle data_p + return dict + + get_symbol_table bh1 = do + symtab_p <- get bh1 + data_p' <- tellBin bh1 + seekBin bh1 symtab_p + symtab <- getSymbolTable bh1 ncu + seekBin bh1 data_p' + return symtab + +putFastString :: HieDictionary -> BinHandle -> FastString -> IO () +putFastString HieDictionary { hie_dict_next = j_r, + hie_dict_map = out_r} bh f + = do + out <- readIORef out_r + let !unique = getUnique f + case lookupUFM_Directly out unique of + Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out unique (j, f) + +putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) + mapM_ (putHieName bh) names + +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do + sz <- get bh + od_names <- replicateM sz (getHieName bh) + updateNameCache ncu $ \nc -> + let arr = A.listArray (0,sz-1) names + (nc', names) = mapAccumR fromHieName nc od_names + in (nc',arr) + +getSymTabName :: SymbolTable -> BinHandle -> IO Name +getSymTabName st bh = do + i :: Word32 <- get bh + return $ st A.! (fromIntegral i) + +putName :: HieSymbolTable -> BinHandle -> Name -> IO () +putName (HieSymbolTable next ref) bh name = do + symmap <- readIORef ref + case lookupUFM symmap name of + Just (off, ExternalName mod occ (UnhelpfulSpan _)) + | isGoodSrcSpan (nameSrcSpan name) -> do + let hieName = ExternalName mod occ (nameSrcSpan name) + writeIORef ref $! addToUFM symmap name (off, hieName) + put_ bh (fromIntegral off :: Word32) + Just (off, LocalName _occ span) + | notLocal (toHieName name) || nameSrcSpan name /= span -> do + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + Just (off, _) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt next + writeFastMutInt next (off+1) + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + + where + notLocal :: HieName -> Bool + notLocal LocalName{} = False + notLocal _ = True + + +-- ** Converting to and from `HieName`'s + +fromHieName :: NameCache -> HieName -> (NameCache, Name) +fromHieName nc (ExternalName mod occ span) = + let cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name -> (nc, name) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ span + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) +fromHieName nc (LocalName occ span) = + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkInternalName uniq occ span + in ( nc{ nsUniqs = us }, name ) +fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of + Nothing -> pprPanic "fromHieName:unknown known-key unique" + (ppr (unpkUnique u)) + Just n -> (nc, n) + +-- ** Reading and writing `HieName`'s + +putHieName :: BinHandle -> HieName -> IO () +putHieName bh (ExternalName mod occ span) = do + putByte bh 0 + put_ bh (mod, occ, span) +putHieName bh (LocalName occName span) = do + putByte bh 1 + put_ bh (occName, span) +putHieName bh (KnownKeyName uniq) = do + putByte bh 2 + put_ bh $ unpkUnique uniq + +getHieName :: BinHandle -> IO HieName +getHieName bh = do + t <- getByte bh + case t of + 0 -> do + (modu, occ, span) <- get bh + return $ ExternalName modu occ span + 1 -> do + (occ, span) <- get bh + return $ LocalName occ span + 2 -> do + (c,i) <- get bh + return $ KnownKeyName $ mkUnique c i + _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag" diff --git a/GHC/Iface/Ext/Debug.hs b/GHC/Iface/Ext/Debug.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Debug.hs @@ -0,0 +1,159 @@ +{- +Functions to validate and check .hie file ASTs generated by GHC. +-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Iface.Ext.Debug where + +import GHC.Prelude + +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Utils.Outputable + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils +import GHC.Types.Name + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Function ( on ) +import Data.List ( sortOn ) + +type Diff a = a -> a -> [SDoc] + +diffFile :: Diff HieFile +diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) + +diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a)) +diffAsts f = diffList (diffAst f) `on` M.elems + +diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) +diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = + infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 + where + spanDiff + | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] + | otherwise = [] + infoDiff' i1 i2 + = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2 + ++ (diffList diffType `on` nodeType) i1 i2 + ++ (diffIdents `on` nodeIdentifiers) i1 i2 + sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo) + infoDiff = case sinfoDiff info1 info2 of + [] -> [] + xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1) + , "and", ppr (sourcedNodeIdents info2,span2) + , "While comparing" + , ppr (normalizeIdents $ sourcedNodeIdents info1), "and" + , ppr (normalizeIdents $ sourcedNodeIdents info2) + ] + ] + + diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b + diffIdent (a,b) (c,d) = diffName a c + ++ eqDiff b d + diffName (Right a) (Right b) = case (a,b) of + (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o') + (LocalName o _, ExternalName _ o' _) -> eqDiff o o' + _ -> eqDiff a b + diffName a b = eqDiff a b + +type DiffIdent = Either ModuleName HieName + +normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] +normalizeIdents = sortOn go . map (first toHieName) . M.toList + where + first f (a,b) = (fmap f a, b) + go (a,b) = (hieNameOcc <$> a,identInfo b,identType b) + +diffList :: Diff a -> Diff [a] +diffList f xs ys + | length xs == length ys = concat $ zipWith f xs ys + | otherwise = ["length of lists doesn't match"] + +eqDiff :: (Outputable a, Eq a) => Diff a +eqDiff a b + | a == b = [] + | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]] + +validAst :: HieAST a -> Either SDoc () +validAst (Node _ span children) = do + checkContainment children + checkSorted children + mapM_ validAst children + where + checkSorted [] = return () + checkSorted [_] = return () + checkSorted (x:y:xs) + | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs) + | otherwise = Left $ hsep + [ ppr $ nodeSpan x + , "is not to the left of" + , ppr $ nodeSpan y + ] + checkContainment [] = return () + checkContainment (x:xs) + | span `containsSpan` (nodeSpan x) = checkContainment xs + | otherwise = Left $ hsep + [ ppr $ span + , "does not contain" + , ppr $ nodeSpan x + ] + +-- | Look for any identifiers which occur outside of their supposed scopes. +-- Returns a list of error messages. +validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc] +validateScopes mod asts = validScopes ++ validEvs + where + refMap = generateReferencesMap asts + -- We use a refmap for most of the computation + + evs = M.keys + $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap + + validEvs = do + i@(Right ev) <- evs + case M.lookup i refMap of + Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ] + Just refs + | nameIsLocalOrFrom mod ev + , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs) + -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"] + | otherwise -> [] + + -- Check if all the names occur in their calculated scopes + validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap + valid (Left _) _ = [] + valid (Right n) refs = concatMap inScope refs + where + mapRef = foldMap getScopeFromContext . identInfo . snd + scopes = case foldMap mapRef refs of + Just xs -> xs + Nothing -> [] + inScope (sp, dets) + | (definedInAsts asts n || (any isEvidenceContext (identInfo dets))) + && any isOccurrence (identInfo dets) + -- We validate scopes for names which are defined locally, and occur + -- in this span, or are evidence variables + = case scopes of + [] | nameIsLocalOrFrom mod n + , ( not (isDerivedOccName $ nameOccName n) + || any isEvidenceContext (identInfo dets)) + -- If we don't get any scopes for a local name or + -- an evidence variable, then its an error. + -- We can ignore other kinds of derived names as + -- long as we take evidence vars into account + -> return $ hsep $ + [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp + , "Doesn't have a calculated scope: ", ppr scopes] + | otherwise -> [] + _ -> if any (`scopeContainsSpan` sp) scopes + then [] + else return $ hsep $ + [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp + , "doesn't occur in calculated scope", ppr scopes] + | otherwise = [] diff --git a/GHC/Iface/Ext/Types.hs b/GHC/Iface/Ext/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Types.hs @@ -0,0 +1,750 @@ +{- +Types for the .hie file format are defined here. + +For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files +-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module GHC.Iface.Ext.Types where + +import GHC.Prelude + +import GHC.Settings.Config +import GHC.Utils.Binary +import GHC.Data.FastString ( FastString ) +import GHC.Builtin.Utils +import GHC.Iface.Type +import GHC.Unit.Module ( ModuleName, Module ) +import GHC.Types.Name +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Types.SrcLoc +import GHC.Types.Avail +import GHC.Types.Unique +import qualified GHC.Utils.Outputable as O ( (<>) ) +import GHC.Utils.Misc + +import qualified Data.Array as A +import qualified Data.Map as M +import qualified Data.Set as S +import Data.ByteString ( ByteString ) +import Data.Data ( Typeable, Data ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Word ( Word8 ) +import Control.Applicative ( (<|>) ) +import Data.Coerce ( coerce ) +import Data.Function ( on ) + +type Span = RealSrcSpan + +-- | Current version of @.hie@ files +hieVersion :: Integer +hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +{- | +GHC builds up a wealth of information about Haskell source as it compiles it. +@.hie@ files are a way of persisting some of this information to disk so that +external tools that need to work with haskell source don't need to parse, +typecheck, and rename all over again. These files contain: + + * a simplified AST + + * nodes are annotated with source positions and types + * identifiers are annotated with scope information + + * the raw bytes of the initial Haskell source + +Besides saving compilation cycles, @.hie@ files also offer a more stable +interface than the GHC API. +-} +data HieFile = HieFile + { hie_hs_file :: FilePath + -- ^ Initial Haskell source file path + + , hie_module :: Module + -- ^ The module this HIE file is for + + , hie_types :: A.Array TypeIndex HieTypeFlat + -- ^ Types referenced in the 'hie_asts'. + -- + -- See Note [Efficient serialization of redundant type info] + + , hie_asts :: HieASTs TypeIndex + -- ^ Type-annotated abstract syntax trees + + , hie_exports :: [AvailInfo] + -- ^ The names that this module exports + + , hie_hs_src :: ByteString + -- ^ Raw bytes of the initial Haskell source + } +instance Binary HieFile where + put_ bh hf = do + put_ bh $ hie_hs_file hf + put_ bh $ hie_module hf + put_ bh $ hie_types hf + put_ bh $ hie_asts hf + put_ bh $ hie_exports hf + put_ bh $ hie_hs_src hf + + get bh = HieFile + <$> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + + +{- +Note [Efficient serialization of redundant type info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The type information in .hie files is highly repetitive and redundant. For +example, consider the expression + + const True 'a' + +There is a lot of shared structure between the types of subterms: + + * const True 'a' :: Bool + * const True :: Char -> Bool + * const :: Bool -> Char -> Bool + +Since all 3 of these types need to be stored in the .hie file, it is worth +making an effort to deduplicate this shared structure. The trick is to define +a new data type that is a flattened version of 'Type': + + data HieType a = HAppTy a a -- data Type = AppTy Type Type + | HFunTy a a -- | FunTy Type Type + | ... + + type TypeIndex = Int + +Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)', +where the 'TypeIndex's in the 'HieType' are references to other elements of the +array. Types recovered from GHC are deduplicated and stored in this compressed +form with sharing of subtrees. +-} + +type TypeIndex = Int + +-- | A flattened version of 'Type'. +-- +-- See Note [Efficient serialization of redundant type info] +data HieType a + = HTyVarTy Name + | HAppTy a (HieArgs a) + | HTyConApp IfaceTyCon (HieArgs a) + | HForAllTy ((Name, a),ArgFlag) a + | HFunTy a a a + | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') + | HLitTy IfaceTyLit + | HCastTy a + | HCoercionTy + deriving (Functor, Foldable, Traversable, Eq) + +type HieTypeFlat = HieType TypeIndex + +-- | Roughly isomorphic to the original core 'Type'. +newtype HieTypeFix = Roll (HieType (HieTypeFix)) + +instance Binary (HieType TypeIndex) where + put_ bh (HTyVarTy n) = do + putByte bh 0 + put_ bh n + put_ bh (HAppTy a b) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh (HTyConApp n xs) = do + putByte bh 2 + put_ bh n + put_ bh xs + put_ bh (HForAllTy bndr a) = do + putByte bh 3 + put_ bh bndr + put_ bh a + put_ bh (HFunTy w a b) = do + putByte bh 4 + put_ bh w + put_ bh a + put_ bh b + put_ bh (HQualTy a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (HLitTy l) = do + putByte bh 6 + put_ bh l + put_ bh (HCastTy a) = do + putByte bh 7 + put_ bh a + put_ bh (HCoercionTy) = putByte bh 8 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> HTyVarTy <$> get bh + 1 -> HAppTy <$> get bh <*> get bh + 2 -> HTyConApp <$> get bh <*> get bh + 3 -> HForAllTy <$> get bh <*> get bh + 4 -> HFunTy <$> get bh <*> get bh <*> get bh + 5 -> HQualTy <$> get bh <*> get bh + 6 -> HLitTy <$> get bh + 7 -> HCastTy <$> get bh + 8 -> return HCoercionTy + _ -> panic "Binary (HieArgs Int): invalid tag" + + +-- | A list of type arguments along with their respective visibilities (ie. is +-- this an argument that would return 'True' for 'isVisibleArgFlag'?). +newtype HieArgs a = HieArgs [(Bool,a)] + deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (HieArgs TypeIndex) where + put_ bh (HieArgs xs) = put_ bh xs + get bh = HieArgs <$> get bh + +-- | Mapping from filepaths (represented using 'FastString') to the +-- corresponding AST +newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) } + deriving (Functor, Foldable, Traversable) + +instance Binary (HieASTs TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getAsts asts + get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) + +instance Outputable a => Outputable (HieASTs a) where + ppr (HieASTs asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "File: " O.<> ppr k + , ppr a + , rest + ] + +data HieAST a = + Node + { sourcedNodeInfo :: SourcedNodeInfo a + , nodeSpan :: Span + , nodeChildren :: [HieAST a] + } deriving (Functor, Foldable, Traversable) + +instance Binary (HieAST TypeIndex) where + put_ bh ast = do + put_ bh $ sourcedNodeInfo ast + put_ bh $ nodeSpan ast + put_ bh $ nodeChildren ast + + get bh = Node + <$> get bh + <*> get bh + <*> get bh + +instance Outputable a => Outputable (HieAST a) where + ppr (Node ni sp ch) = hang header 2 rest + where + header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni + rest = vcat (map ppr ch) + + +-- | NodeInfos grouped by source +newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) } + deriving (Functor, Foldable, Traversable) + +instance Binary (SourcedNodeInfo TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts + get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh) + +instance Outputable a => Outputable (SourcedNodeInfo a) where + ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "Source: " O.<> ppr k + , ppr a + , rest + ] + +-- | Source of node info +data NodeOrigin + = SourceInfo + | GeneratedInfo + deriving (Eq, Enum, Ord) + +instance Outputable NodeOrigin where + ppr SourceInfo = text "From source" + ppr GeneratedInfo = text "generated by ghc" + +instance Binary NodeOrigin where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +-- | The information stored in one AST node. +-- +-- The type parameter exists to provide flexibility in representation of types +-- (see Note [Efficient serialization of redundant type info]). +data NodeInfo a = NodeInfo + { nodeAnnotations :: S.Set (FastString,FastString) + -- ^ (name of the AST node constructor, name of the AST node Type) + + , nodeType :: [a] + -- ^ The Haskell types of this node, if any. + + , nodeIdentifiers :: NodeIdentifiers a + -- ^ All the identifiers and their details + } deriving (Functor, Foldable, Traversable) + +instance Binary (NodeInfo TypeIndex) where + put_ bh ni = do + put_ bh $ S.toAscList $ nodeAnnotations ni + put_ bh $ nodeType ni + put_ bh $ M.toList $ nodeIdentifiers ni + get bh = NodeInfo + <$> fmap (S.fromDistinctAscList) (get bh) + <*> get bh + <*> fmap (M.fromList) (get bh) + +instance Outputable a => Outputable (NodeInfo a) where + ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", " + [ parens (text "annotations:" <+> ppr anns) + , parens (text "types:" <+> ppr typs) + , parens (text "identifier info:" <+> pprNodeIdents idents) + ] + +pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc +pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni + where + go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id] + +pprIdentifier :: Identifier -> SDoc +pprIdentifier (Left mod) = text "module" <+> ppr mod +pprIdentifier (Right name) = text "name" <+> ppr name + +type Identifier = Either ModuleName Name + +type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a) + +-- | Information associated with every identifier +-- +-- We need to include types with identifiers because sometimes multiple +-- identifiers occur in the same span(Overloaded Record Fields and so on) +data IdentifierDetails a = IdentifierDetails + { identType :: Maybe a + , identInfo :: S.Set ContextInfo + } deriving (Eq, Functor, Foldable, Traversable) + +instance Outputable a => Outputable (IdentifierDetails a) where + ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x) + +instance Semigroup (IdentifierDetails a) where + d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2) + (S.union (identInfo d1) (identInfo d2)) + +instance Monoid (IdentifierDetails a) where + mempty = IdentifierDetails Nothing S.empty + +instance Binary (IdentifierDetails TypeIndex) where + put_ bh dets = do + put_ bh $ identType dets + put_ bh $ S.toList $ identInfo dets + get bh = IdentifierDetails + <$> get bh + <*> fmap S.fromDistinctAscList (get bh) + + +-- | Different contexts under which identifiers exist +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + + -- | Pattern binding + -- + -- This case is tricky because the bound identifier can be used in two + -- distinct scopes. Consider the following example (with @-XViewPatterns@) + -- + -- @ + -- do (b, a, (a -> True)) <- bar + -- foo a + -- @ + -- + -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and + -- in the rest of the @do@-block in @foo a@. + | PatternBind + Scope -- ^ scope /in the pattern/ (the variable bound can be used + -- further in the pattern) + Scope -- ^ rest of the scope outside the pattern + (Maybe Span) -- ^ span of entire binding + + | ClassTyDecl (Maybe Span) + + -- | Declaration + | Decl + DeclType -- ^ type of declaration + (Maybe Span) -- ^ span of entire binding + + -- | Type variable + | TyVarBind Scope TyVarScope + + -- | Record field + | RecField RecFieldContext (Maybe Span) + -- | Constraint/Dictionary evidence variable binding + | EvidenceVarBind + EvVarSource -- ^ how did this bind come into being + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of the binding site + + -- | Usage of evidence variable + | EvidenceVarUse + deriving (Eq, Ord) + +instance Outputable ContextInfo where + ppr (Use) = text "usage" + ppr (MatchBind) = text "LHS of a match group" + ppr (IEThing x) = ppr x + ppr (TyDecl) = text "bound in a type signature declaration" + ppr (ValBind t sc sp) = + ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp + ppr (PatternBind sc1 sc2 sp) = + text "bound in a pattern with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + <+> pprBindSpan sp + ppr (ClassTyDecl sp) = + text "bound in a class type declaration" <+> pprBindSpan sp + ppr (Decl d sp) = + text "declaration of" <+> ppr d <+> pprBindSpan sp + ppr (TyVarBind sc1 sc2) = + text "type variable binding with scope:" + <+> ppr sc1 <+> "," <+> ppr sc2 + ppr (RecField ctx sp) = + text "record field" <+> ppr ctx <+> pprBindSpan sp + ppr (EvidenceVarBind ctx sc sp) = + text "evidence variable" <+> ppr ctx + $$ "with scope:" <+> ppr sc + $$ pprBindSpan sp + ppr (EvidenceVarUse) = + text "usage of evidence variable" + +pprBindSpan :: Maybe Span -> SDoc +pprBindSpan Nothing = text "" +pprBindSpan (Just sp) = text "bound at:" <+> ppr sp + +instance Binary ContextInfo where + put_ bh Use = putByte bh 0 + put_ bh (IEThing t) = do + putByte bh 1 + put_ bh t + put_ bh TyDecl = putByte bh 2 + put_ bh (ValBind bt sc msp) = do + putByte bh 3 + put_ bh bt + put_ bh sc + put_ bh msp + put_ bh (PatternBind a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh c + put_ bh (ClassTyDecl sp) = do + putByte bh 5 + put_ bh sp + put_ bh (Decl a b) = do + putByte bh 6 + put_ bh a + put_ bh b + put_ bh (TyVarBind a b) = do + putByte bh 7 + put_ bh a + put_ bh b + put_ bh (RecField a b) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh MatchBind = putByte bh 9 + put_ bh (EvidenceVarBind a b c) = do + putByte bh 10 + put_ bh a + put_ bh b + put_ bh c + put_ bh EvidenceVarUse = putByte bh 11 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return Use + 1 -> IEThing <$> get bh + 2 -> return TyDecl + 3 -> ValBind <$> get bh <*> get bh <*> get bh + 4 -> PatternBind <$> get bh <*> get bh <*> get bh + 5 -> ClassTyDecl <$> get bh + 6 -> Decl <$> get bh <*> get bh + 7 -> TyVarBind <$> get bh <*> get bh + 8 -> RecField <$> get bh <*> get bh + 9 -> return MatchBind + 10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh + 11 -> return EvidenceVarUse + _ -> panic "Binary ContextInfo: invalid tag" + +data EvVarSource + = EvPatternBind -- ^ bound by a pattern match + | EvSigBind -- ^ bound by a type signature + | EvWrapperBind -- ^ bound by a hswrapper + | EvImplicitBind -- ^ bound by an implicit variable + | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class + | EvLetBind EvBindDeps -- ^ A direct let binding + deriving (Eq,Ord) + +instance Binary EvVarSource where + put_ bh EvPatternBind = putByte bh 0 + put_ bh EvSigBind = putByte bh 1 + put_ bh EvWrapperBind = putByte bh 2 + put_ bh EvImplicitBind = putByte bh 3 + put_ bh (EvInstBind b cls) = do + putByte bh 4 + put_ bh b + put_ bh cls + put_ bh (EvLetBind deps) = do + putByte bh 5 + put_ bh deps + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> pure EvPatternBind + 1 -> pure EvSigBind + 2 -> pure EvWrapperBind + 3 -> pure EvImplicitBind + 4 -> EvInstBind <$> get bh <*> get bh + 5 -> EvLetBind <$> get bh + _ -> panic "Binary EvVarSource: invalid tag" + +instance Outputable EvVarSource where + ppr EvPatternBind = text "bound by a pattern" + ppr EvSigBind = text "bound by a type signature" + ppr EvWrapperBind = text "bound by a HsWrapper" + ppr EvImplicitBind = text "bound by an implicit variable binding" + ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls + ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls + ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps + +-- | Eq/Ord instances compare on the converted HieName, +-- as non-exported names may have different uniques after +-- a roundtrip +newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] } + deriving Outputable + +instance Eq EvBindDeps where + (==) = coerce ((==) `on` map toHieName) + +instance Ord EvBindDeps where + compare = coerce (compare `on` map toHieName) + +instance Binary EvBindDeps where + put_ bh (EvBindDeps xs) = put_ bh xs + get bh = EvBindDeps <$> get bh + + +-- | Types of imports and exports +data IEType + = Import + | ImportAs + | ImportHiding + | Export + deriving (Eq, Enum, Ord) + +instance Outputable IEType where + ppr Import = text "import" + ppr ImportAs = text "import as" + ppr ImportHiding = text "import hiding" + ppr Export = text "export" + +instance Binary IEType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data RecFieldContext + = RecFieldDecl + | RecFieldAssign + | RecFieldMatch + | RecFieldOcc + deriving (Eq, Enum, Ord) + +instance Outputable RecFieldContext where + ppr RecFieldDecl = text "declaration" + ppr RecFieldAssign = text "assignment" + ppr RecFieldMatch = text "pattern match" + ppr RecFieldOcc = text "occurence" + +instance Binary RecFieldContext where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data BindType + = RegularBind + | InstanceBind + deriving (Eq, Ord, Enum) + +instance Outputable BindType where + ppr RegularBind = "regular" + ppr InstanceBind = "instance" + +instance Binary BindType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +data DeclType + = FamDec -- ^ type or data family + | SynDec -- ^ type synonym + | DataDec -- ^ data declaration + | ConDec -- ^ constructor declaration + | PatSynDec -- ^ pattern synonym + | ClassDec -- ^ class declaration + | InstDec -- ^ instance declaration + deriving (Eq, Ord, Enum) + +instance Outputable DeclType where + ppr FamDec = text "type or data family" + ppr SynDec = text "type synonym" + ppr DataDec = text "data" + ppr ConDec = text "constructor" + ppr PatSynDec = text "pattern synonym" + ppr ClassDec = text "class" + ppr InstDec = text "instance" + +instance Binary DeclType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + +data Scope + = NoScope + | LocalScope Span + | ModuleScope + deriving (Eq, Ord, Typeable, Data) + +instance Outputable Scope where + ppr NoScope = text "NoScope" + ppr (LocalScope sp) = text "LocalScope" <+> ppr sp + ppr ModuleScope = text "ModuleScope" + +instance Binary Scope where + put_ bh NoScope = putByte bh 0 + put_ bh (LocalScope span) = do + putByte bh 1 + put_ bh span + put_ bh ModuleScope = putByte bh 2 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return NoScope + 1 -> LocalScope <$> get bh + 2 -> return ModuleScope + _ -> panic "Binary Scope: invalid tag" + + +-- | Scope of a type variable. +-- +-- This warrants a data type apart from 'Scope' because of complexities +-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For +-- example, consider: +-- +-- @ +-- foo, bar, baz :: forall a. a -> a +-- @ +-- +-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we +-- need a list of scopes to keep track of this. Furthermore, this list cannot be +-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@. +-- +-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@ +-- which later gets resolved into a 'ResolvedScopes'. +data TyVarScope + = ResolvedScopes [Scope] + + -- | Unresolved scopes should never show up in the final @.hie@ file + | UnresolvedScope + [Name] -- ^ names of the definitions over which the scope spans + (Maybe Span) -- ^ the location of the instance/class declaration for + -- the case where the type variable is declared in a + -- method type signature + deriving (Eq, Ord) + +instance Outputable TyVarScope where + ppr (ResolvedScopes xs) = + text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs) + ppr (UnresolvedScope ns sp) = + text "unresolved type variable scope for name" O.<> plural ns + <+> pprBindSpan sp + +instance Binary TyVarScope where + put_ bh (ResolvedScopes xs) = do + putByte bh 0 + put_ bh xs + put_ bh (UnresolvedScope ns span) = do + putByte bh 1 + put_ bh ns + put_ bh span + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> ResolvedScopes <$> get bh + 1 -> UnresolvedScope <$> get bh <*> get bh + _ -> panic "Binary TyVarScope: invalid tag" + +-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d + -- TODO (int-index): Perhaps use RealSrcSpan in HieName? + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non deterministic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + +hieNameOcc :: HieName -> OccName +hieNameOcc (ExternalName _ occ _) = occ +hieNameOcc (LocalName occ _) = occ +hieNameOcc (KnownKeyName u) = + case lookupKnownKeyName u of + Just n -> nameOccName n + Nothing -> pprPanic "hieNameOcc:unknown known-key unique" + (ppr (unpkUnique u)) + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (nameSrcSpan name) diff --git a/GHC/Iface/Ext/Utils.hs b/GHC/Iface/Ext/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Ext/Utils.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +module GHC.Iface.Ext.Utils where + +import GHC.Prelude + +import GHC.Core.Map +import GHC.Driver.Session ( DynFlags ) +import GHC.Data.FastString ( FastString, mkFastString ) +import GHC.Iface.Type +import GHC.Core.Multiplicity +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Set +import GHC.Utils.Outputable hiding ( (<>) ) +import qualified GHC.Utils.Outputable as O +import GHC.Types.SrcLoc +import GHC.CoreToIface +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Types.Var +import GHC.Types.Var.Env + +import GHC.Iface.Ext.Types + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Array as A +import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) ) +import Data.Maybe ( maybeToList, mapMaybe) +import Data.Monoid +import Data.List (find) +import Data.Traversable ( for ) +import Data.Coerce +import Control.Monad.Trans.State.Strict hiding (get) +import Control.Monad.Trans.Reader +import qualified Data.Tree as Tree + +type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] + +generateReferencesMap + :: Foldable f + => f (HieAST a) + -> RefMap a +generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty + where + go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) + where + this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast + +renderHieType :: DynFlags -> HieTypeFix -> String +renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht) + +resolveVisibility :: Type -> [Type] -> [(Bool,Type)] +resolveVisibility kind ty_args + = go (mkEmptyTCvSubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = [] + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + | isVisibleArgFlag vis = (True , t) : ts' + | otherwise = (False, t) : ts' + where + ts' = go (extendTvSubst env tv t) res ts + + go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps + = (True,t) : (go env res ts) + + go env (TyVarTy tv) ts + | Just ki <- lookupTyVar env tv = go env ki ts + go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded + +foldType :: (HieType a -> a) -> HieTypeFix -> a +foldType f (Roll t) = f $ fmap (foldType f) t + +selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int) +selectPoint hf (sl,sc) = getFirst $ + flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $ + case selectSmallestContaining (sp fs) ast of + Nothing -> Nothing + Just ast' -> Just ast' + where + sloc fs = mkRealSrcLoc fs sl sc + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + +findEvidenceUse :: NodeIdentifiers a -> [Name] +findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)] + where + xs = M.toList ni + +data EvidenceInfo a + = EvidenceInfo + { evidenceVar :: Name + , evidenceSpan :: RealSrcSpan + , evidenceType :: a + , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span) + } deriving (Eq,Ord,Functor) + +instance (Outputable a) => Outputable (EvidenceInfo a) where + ppr (EvidenceInfo name span typ dets) = + hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $ + pdets $$ (pprDefinedAt name) + where + pdets = case dets of + Nothing -> text "is a usage of an external evidence variable" + Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn) + +getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a) +getEvidenceTreesAtPoint hf refmap point = + [t | Just ast <- pure $ selectPoint hf point + , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast) + , Just t <- pure $ getEvidenceTree refmap n + ] + +getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a)) +getEvidenceTree refmap var = go emptyNameSet var + where + go seen var + | var `elemNameSet` seen = Nothing + | otherwise = do + xs <- M.lookup (Right var) refmap + case find (any isEvidenceBind . identInfo . snd) xs of + Just (sp,dets) -> do + typ <- identType dets + (evdet,children) <- getFirst $ foldMap First $ do + det <- S.toList $ identInfo dets + case det of + EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn -> + pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs) + EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[]) + _ -> pure Nothing + pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children + -- It is externally bound + Nothing -> getFirst $ foldMap First $ do + (sp,dets) <- xs + if (any isEvidenceUse $ identInfo dets) + then do + case identType dets of + Nothing -> pure Nothing + Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) [] + else pure Nothing + +hieTypeToIface :: HieTypeFix -> IfaceType +hieTypeToIface = foldType go + where + go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n + go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) + go (HLitTy l) = IfaceLitTy l + go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) + in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t + go (HFunTy w a b) = IfaceFunTy VisArg w a b + go (HQualTy pred b) = IfaceFunTy InvisArg many_ty pred b + go (HCastTy a) = a + go HCoercionTy = IfaceTyVar "" + go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) + + -- This isn't fully faithful - we can't produce the 'Inferred' case + hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs + hieToIfaceArgs (HieArgs xs) = go' xs + where + go' [] = IA_Nil + go' ((True ,x):xs) = IA_Arg x Required $ go' xs + go' ((False,x):xs) = IA_Arg x Specified $ go' xs + +data HieTypeState + = HTS + { tyMap :: !(TypeMap TypeIndex) + , htyTable :: !(IM.IntMap HieTypeFlat) + , freshIndex :: !TypeIndex + } + +initialHTS :: HieTypeState +initialHTS = HTS emptyTypeMap IM.empty 0 + +freshTypeIndex :: State HieTypeState TypeIndex +freshTypeIndex = do + index <- gets freshIndex + modify' $ \hts -> hts { freshIndex = index+1 } + return index + +compressTypes + :: HieASTs Type + -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +compressTypes asts = (a, arr) + where + (a, (HTS _ m i)) = flip runState initialHTS $ + for asts $ \typ -> do + i <- getTypeIndex typ + return i + arr = A.array (0,i-1) (IM.toList m) + +recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix +recoverFullType i m = go i + where + go i = Roll $ fmap go (m A.! i) + +getTypeIndex :: Type -> State HieTypeState TypeIndex +getTypeIndex t + | otherwise = do + tm <- gets tyMap + case lookupTypeMap tm t of + Just i -> return i + Nothing -> do + ht <- go t + extendHTS t ht + where + extendHTS t ht = do + i <- freshTypeIndex + modify' $ \(HTS tm tt fi) -> + HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi + return i + + go (TyVarTy v) = return $ HTyVarTy $ varName v + go ty@(AppTy _ _) = do + let (head,args) = splitAppTys ty + visArgs = HieArgs $ resolveVisibility (typeKind head) args + ai <- getTypeIndex head + argsi <- mapM getTypeIndex visArgs + return $ HAppTy ai argsi + go (TyConApp f xs) = do + let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs + is <- mapM getTypeIndex visArgs + return $ HTyConApp (toIfaceTyCon f) is + go (ForAllTy (Bndr v a) t) = do + k <- getTypeIndex (varType v) + i <- getTypeIndex t + return $ HForAllTy ((varName v,k),a) i + go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do + ai <- getTypeIndex a + bi <- getTypeIndex b + wi <- getTypeIndex w + return $ case af of + InvisArg -> case w of Many -> HQualTy ai bi; _ -> error "Unexpected non-unrestricted predicate" + VisArg -> HFunTy wi ai bi + go (LitTy a) = return $ HLitTy $ toIfaceTyLit a + go (CastTy t _) = do + i <- getTypeIndex t + return $ HCastTy i + go (CoercionTy _) = return HCoercionTy + +resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a) +resolveTyVarScopes asts = M.map go asts + where + go ast = resolveTyVarScopeLocal ast asts + +resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a +resolveTyVarScopeLocal ast asts = go ast + where + resolveNameScope dets = dets{identInfo = + S.map resolveScope (identInfo dets)} + resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBinding name asts] + ] + resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBindingInClass name sp asts] + ] + resolveScope scope = scope + go (Node info span children) = Node info' span $ map go children + where + info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info) + updateNodeInfo i = i { nodeIdentifiers = idents } + where + idents = M.map resolveNameScope $ nodeIdentifiers i + +getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span +getNameBinding n asts = do + (_,msp) <- getNameScopeAndBinding n asts + msp + +getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope] +getNameScope n asts = do + (scopes,_) <- getNameScopeAndBinding n asts + return scopes + +getNameBindingInClass + :: Name + -> Span + -> M.Map FastString (HieAST a) + -> Maybe Span +getNameBindingInClass n sp asts = do + ast <- M.lookup (srcSpanFile sp) asts + getFirst $ foldMap First $ do + child <- flattenAst ast + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return (getFirst binding) + +getNameScopeAndBinding + :: Name + -> M.Map FastString (HieAST a) + -> Maybe ([Scope], Maybe Span) +getNameScopeAndBinding n asts = case nameSrcSpan n of + RealSrcSpan sp _ -> do -- @Maybe + ast <- M.lookup (srcSpanFile sp) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) + _ -> Nothing + +getScopeFromContext :: ContextInfo -> Maybe [Scope] +getScopeFromContext (ValBind _ sc _) = Just [sc] +getScopeFromContext (PatternBind a b _) = Just [a, b] +getScopeFromContext (ClassTyDecl _) = Just [ModuleScope] +getScopeFromContext (Decl _ _) = Just [ModuleScope] +getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs +getScopeFromContext (TyVarBind a _) = Just [a] +getScopeFromContext (EvidenceVarBind _ a _) = Just [a] +getScopeFromContext _ = Nothing + +getBindSiteFromContext :: ContextInfo -> Maybe Span +getBindSiteFromContext (ValBind _ _ sp) = sp +getBindSiteFromContext (PatternBind _ _ sp) = sp +getBindSiteFromContext _ = Nothing + +flattenAst :: HieAST a -> [HieAST a] +flattenAst n = + n : concatMap flattenAst (nodeChildren n) + +smallestContainingSatisfying + :: Span + -> (HieAST a -> Bool) + -> HieAST a + -> Maybe (HieAST a) +smallestContainingSatisfying sp cond node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . smallestContainingSatisfying sp cond) $ + nodeChildren node + , First $ if cond node then Just node else Nothing + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a) +selectLargestContainedBy sp node + | sp `containsSpan` nodeSpan node = Just node + | nodeSpan node `containsSpan` sp = + getFirst $ foldMap (First . selectLargestContainedBy sp) $ + nodeChildren node + | otherwise = Nothing + +selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a) +selectSmallestContaining sp node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node + , First (Just node) + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool +definedInAsts asts n = case nameSrcSpan n of + RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts + _ -> False + +getEvidenceBindDeps :: ContextInfo -> [Name] +getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) = + getEvBindDeps xs +getEvidenceBindDeps _ = [] + +isEvidenceBind :: ContextInfo -> Bool +isEvidenceBind EvidenceVarBind{} = True +isEvidenceBind _ = False + +isEvidenceContext :: ContextInfo -> Bool +isEvidenceContext EvidenceVarUse = True +isEvidenceContext EvidenceVarBind{} = True +isEvidenceContext _ = False + +isEvidenceUse :: ContextInfo -> Bool +isEvidenceUse EvidenceVarUse = True +isEvidenceUse _ = False + +isOccurrence :: ContextInfo -> Bool +isOccurrence Use = True +isOccurrence EvidenceVarUse = True +isOccurrence _ = False + +scopeContainsSpan :: Scope -> Span -> Bool +scopeContainsSpan NoScope _ = False +scopeContainsSpan ModuleScope _ = True +scopeContainsSpan (LocalScope a) b = a `containsSpan` b + +-- | One must contain the other. Leaf nodes cannot contain anything +combineAst :: HieAST Type -> HieAST Type -> HieAST Type +combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys) + | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys) + | aSpn `containsSpan` bSpn = combineAst b a +combineAst a (Node xs span children) = Node xs span (insertAst a children) + +-- | Insert an AST in a sorted list of disjoint Asts +insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type] +insertAst x = mergeAsts [x] + +nodeInfo :: HieAST Type -> NodeInfo Type +nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo + +emptyNodeInfo :: NodeInfo a +emptyNodeInfo = NodeInfo S.empty [] M.empty + +sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a +sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo + +combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type +combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo + +-- | Merge two nodes together. +-- +-- Precondition and postcondition: elements in 'nodeType' are ordered. +combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type +(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) = + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + where + mergeSorted :: [Type] -> [Type] -> [Type] + mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of + LT -> a : mergeSorted as lb + EQ -> a : mergeSorted as bs + GT -> b : mergeSorted la bs + mergeSorted as [] = as + mergeSorted [] bs = bs + + +{- | Merge two sorted, disjoint lists of ASTs, combining when necessary. + +In the absence of position-altering pragmas (ex: @# line "file.hs" 3@), +different nodes in an AST tree should either have disjoint spans (in +which case you can say for sure which one comes first) or one span +should be completely contained in the other (in which case the contained +span corresponds to some child node). + +However, since Haskell does have position-altering pragmas it /is/ +possible for spans to be overlapping. Here is an example of a source file +in which @foozball@ and @quuuuuux@ have overlapping spans: + +@ +module Baz where + +# line 3 "Baz.hs" +foozball :: Int +foozball = 0 + +# line 3 "Baz.hs" +bar, quuuuuux :: Int +bar = 1 +quuuuuux = 2 +@ + +In these cases, we just do our best to produce sensible `HieAST`'s. The blame +should be laid at the feet of whoever wrote the line pragmas in the first place +(usually the C preprocessor...). +-} +mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type] +mergeAsts xs [] = xs +mergeAsts [] ys = ys +mergeAsts xs@(a:as) ys@(b:bs) + | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs + | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs) + | span_a `rightOf` span_b = b : mergeAsts xs bs + | span_a `leftOf` span_b = a : mergeAsts as ys + + -- These cases are to work around ASTs that are not fully disjoint + | span_a `startsRightOf` span_b = b : mergeAsts as ys + | otherwise = a : mergeAsts as ys + where + span_a = nodeSpan a + span_b = nodeSpan b + +rightOf :: Span -> Span -> Bool +rightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +leftOf :: Span -> Span -> Bool +leftOf s1 s2 + = (srcSpanEndLine s1, srcSpanEndCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +startsRightOf :: Span -> Span -> Bool +startsRightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanStartLine s2, srcSpanStartCol s2) + +-- | combines and sorts ASTs using a merge sort +mergeSortAsts :: [HieAST Type] -> [HieAST Type] +mergeSortAsts = go . map pure + where + go [] = [] + go [xs] = xs + go xss = go (mergePairs xss) + mergePairs [] = [] + mergePairs [xs] = [xs] + mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss + +simpleNodeInfo :: FastString -> FastString -> NodeInfo a +simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty + +locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a] +locOnly (RealSrcSpan span _) = do + org <- ask + let e = mkSourcedNodeInfo org $ emptyNodeInfo + pure [Node e span []] +locOnly _ = pure [] + +mkScope :: SrcSpan -> Scope +mkScope (RealSrcSpan sp _) = LocalScope sp +mkScope _ = NoScope + +mkLScope :: Located a -> Scope +mkLScope = mkScope . getLoc + +combineScopes :: Scope -> Scope -> Scope +combineScopes ModuleScope _ = ModuleScope +combineScopes _ ModuleScope = ModuleScope +combineScopes NoScope x = x +combineScopes x NoScope = x +combineScopes (LocalScope a) (LocalScope b) = + mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing) + +mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a +mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni + +{-# INLINEABLE makeNode #-} +makeNode + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> ReaderT NodeOrigin m [HieAST b] +makeNode x spn = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x + +{-# INLINEABLE makeTypeNode #-} +makeTypeNode + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> ReaderT NodeOrigin m [HieAST Type] +makeTypeNode x spn etyp = do + org <- ask + pure $ case spn of + RealSrcSpan span _ -> + [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x diff --git a/GHC/Iface/Load.hs b/GHC/Iface/Load.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Load.hs @@ -0,0 +1,1311 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Loading interface files +-} + +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.Iface.Load ( + -- Importing one thing + tcLookupImported_maybe, importDecl, + checkWiredInTyCon, ifCheckWiredInThing, + + -- RnM/TcM functions + loadModuleInterface, loadModuleInterfaces, + loadSrcInterface, loadSrcInterface_maybe, + loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule, + + -- IfM functions + loadInterface, + loadSysInterface, loadUserInterface, loadPluginInterface, + findAndReadIface, readIface, writeIface, + loadDecls, -- Should move to GHC.IfaceToCore and be renamed + initExternalPackageState, + moduleFreeHolesPrecise, + needWiredInHomeIface, loadWiredInHomeIface, + + pprModIfaceSimple, + ifaceStats, pprModIface, showIface + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.IfaceToCore + ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst + , tcIfaceAnnotations, tcIfaceCompleteSigs ) + +import GHC.Driver.Session +import GHC.Driver.Hooks +import GHC.Driver.Plugins + +import GHC.Iface.Syntax +import GHC.Iface.Env +import GHC.Driver.Types + +import GHC.Types.Basic hiding (SuccessFlag(..)) +import GHC.Tc.Utils.Monad + +import GHC.Utils.Binary ( BinData(..) ) +import GHC.Settings.Constants +import GHC.Builtin.Names +import GHC.Builtin.Utils +import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc ) +import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) ) +import GHC.Core.Rules +import GHC.Core.TyCon +import GHC.Types.Annotations +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Unit.Module +import GHC.Unit.State +import GHC.Data.Maybe +import GHC.Utils.Error +import GHC.Driver.Finder +import GHC.Types.Unique.FM +import GHC.Types.SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Iface.Binary +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Fingerprint +import GHC.Types.FieldLabel +import GHC.Iface.Rename +import GHC.Types.Unique.DSet + +import Control.Monad +import Control.Exception +import Data.IORef +import Data.Map ( toList ) +import System.FilePath +import System.Directory + +{- +************************************************************************ +* * +* tcImportDecl is the key function for "faulting in" * +* imported things +* * +************************************************************************ + +The main idea is this. We are chugging along type-checking source code, and +find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find +it in the EPS type envt. So it + 1 loads GHC.Base.hi + 2 gets the decl for GHC.Base.map + 3 typechecks it via tcIfaceDecl + 4 and adds it to the type env in the EPS + +Note that DURING STEP 4, we may find that map's type mentions a type +constructor that also + +Notice that for imported things we read the current version from the EPS +mutable variable. This is important in situations like + ...$(e1)...$(e2)... +where the code that e1 expands to might import some defns that +also turn out to be needed by the code that e2 expands to. +-} + +tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +-- Returns (Failed err) if we can't find the interface file for the thing +tcLookupImported_maybe name + = do { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of + Just thing -> return (Succeeded thing) + Nothing -> tcImportDecl_maybe name } + +tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +-- Entry point for *source-code* uses of importDecl +tcImportDecl_maybe name + | Just thing <- wiredInNameTyThing_maybe name + = do { when (needWiredInHomeIface thing) + (initIfaceTcRn (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] + ; return (Succeeded thing) } + | otherwise + = initIfaceTcRn (importDecl name) + +importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) +-- Get the TyThing for this Name from an interface file +-- It's not a wired-in thing -- the caller caught that +importDecl name + = ASSERT( not (isWiredInName name) ) + do { traceIf nd_doc + + -- Load the interface, which should populate the PTE + ; mb_iface <- ASSERT2( isExternalName name, ppr name ) + loadInterface nd_doc (nameModule name) ImportBySystem + ; case mb_iface of { + Failed err_msg -> return (Failed err_msg) ; + Succeeded _ -> do + + -- Now look it up again; this time we should find it + { eps <- getEps + ; case lookupTypeEnv (eps_PTE eps) name of + Just thing -> return $ Succeeded thing + Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty) + $$ not_found_msg + in return $ Failed doc + }}} + where + nd_doc = text "Need decl for" <+> ppr name + not_found_msg = hang (text "Can't find interface-file declaration for" <+> + pprNameSpace (nameNameSpace name) <+> ppr name) + 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", + text "Use -ddump-if-trace to get an idea of which file caused the error"]) + found_things_msg eps = + hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) + 2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps)) + where + is_interesting thing = nameModule name == nameModule (getName thing) + + +{- +************************************************************************ +* * + Checks for wired-in things +* * +************************************************************************ + +Note [Loading instances for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to make sure that we have at least *read* the interface files +for any module with an instance decl or RULE that we might want. + +* If the instance decl is an orphan, we have a whole separate mechanism + (loadOrphanModules) + +* If the instance decl is not an orphan, then the act of looking at the + TyCon or Class will force in the defining module for the + TyCon/Class, and hence the instance decl + +* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; + but we must make sure we read its interface in case it has instances or + rules. That is what GHC.Iface.Load.loadWiredInHomeIface does. It's called + from GHC.IfaceToCore.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} + +* HOWEVER, only do this for TyCons. There are no wired-in Classes. There + are some wired-in Ids, but we don't want to load their interfaces. For + example, Control.Exception.Base.recSelError is wired in, but that module + is compiled late in the base library, and we don't want to force it to + load before it's been compiled! + +All of this is done by the type checker. The renamer plays no role. +(It used to, but no longer.) +-} + +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. See Note [Loading instances for wired-in things] +-- It might not be a wired-in tycon (see the calls in GHC.Tc.Utils.Unify), +-- in which case this is a no-op. +checkWiredInTyCon tc + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) + ; ASSERT( isExternalName tc_name ) + when (mod /= nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) + -- Don't look for (non-existent) Float.hi when + -- compiling Float.hs, which mentions Float of course + -- A bit yukky to call initIfaceTcRn here + } + where + tc_name = tyConName tc + +ifCheckWiredInThing :: TyThing -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances for wired-in things] +ifCheckWiredInThing thing + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; let name = getName thing + ; ASSERT2( isExternalName name, ppr name ) + when (needWiredInHomeIface thing && mod /= nameModule name) + (loadWiredInHomeIface name) } + +needWiredInHomeIface :: TyThing -> Bool +-- Only for TyCons; see Note [Loading instances for wired-in things] +needWiredInHomeIface (ATyCon {}) = True +needWiredInHomeIface _ = False + + +{- +************************************************************************ +* * + loadSrcInterface, loadOrphanModules, loadInterfaceForName + + These three are called from TcM-land +* * +************************************************************************ +-} + +-- | Load the interface corresponding to an @import@ directive in +-- source code. On a failure, fail in the monad with an error message. +loadSrcInterface :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> Maybe FastString -- "package", if any + -> RnM ModIface + +loadSrcInterface doc mod want_boot maybe_pkg + = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg + ; case res of + Failed err -> failWithTc err + Succeeded iface -> return iface } + +-- | Like 'loadSrcInterface', but returns a 'MaybeErr'. +loadSrcInterface_maybe :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> Maybe FastString -- "package", if any + -> RnM (MaybeErr MsgDoc ModIface) + +loadSrcInterface_maybe doc mod want_boot maybe_pkg + -- We must first find which Module this import refers to. This involves + -- calling the Finder, which as a side effect will search the filesystem + -- and create a ModLocation. If successful, loadIface will read the + -- interface; it will call the Finder again, but the ModLocation will be + -- cached from the first search. + = do { hsc_env <- getTopEnv + ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg + ; case res of + Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) + -- TODO: Make sure this error message is good + err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) } + +-- | Load interface directly for a fully qualified 'Module'. (This is a fairly +-- rare operation, but in particular it is used to load orphan modules +-- in order to pull their instances into the global package table and to +-- handle some operations in GHCi). +loadModuleInterface :: SDoc -> Module -> TcM ModIface +loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) + +-- | Load interfaces for a collection of modules. +loadModuleInterfaces :: SDoc -> [Module] -> TcM () +loadModuleInterfaces doc mods + | null mods = return () + | otherwise = initIfaceTcRn (mapM_ load mods) + where + load mod = loadSysInterface (doc <+> parens (ppr mod)) mod + +-- | Loads the interface for a given Name. +-- Should only be called for an imported name; +-- otherwise loadSysInterface may not find the interface +loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName doc name + = do { when debugIsOn $ -- Check pre-condition + do { this_mod <- getModule + ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) } + ; ASSERT2( isExternalName name, ppr name ) + initIfaceTcRn $ loadSysInterface doc (nameModule name) } + +-- | Only loads the interface for external non-local names. +loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface) +loadInterfaceForNameMaybe doc name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name || not (isExternalName name) + then return Nothing + else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name)) + } + +-- | Loads the interface for a given Module. +loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface +loadInterfaceForModule doc m + = do + -- Should not be called with this module + when debugIsOn $ do + this_mod <- getModule + MASSERT2( this_mod /= m, ppr m <+> parens doc ) + initIfaceTcRn $ loadSysInterface doc m + +{- +********************************************************* +* * + loadInterface + + The main function to load an interface + for an imported module, and put it in + the External Package State +* * +********************************************************* +-} + +-- | An 'IfM' function to load the home interface for a wired-in thing, +-- so that we're sure that we see its instance declarations and rules +-- See Note [Loading instances for wired-in things] +loadWiredInHomeIface :: Name -> IfM lcl () +loadWiredInHomeIface name + = ASSERT( isWiredInName name ) + do _ <- loadSysInterface doc (nameModule name); return () + where + doc = text "Need home interface for wired-in thing" <+> ppr name + +------------------ +-- | Loads a system interface and throws an exception if it fails +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem + +------------------ +-- | Loads a user interface and throws an exception if it fails. The first parameter indicates +-- whether we should import the boot variant of the module +loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface is_boot doc mod_name + = loadInterfaceWithException doc mod_name (ImportByUser is_boot) + +loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface +loadPluginInterface doc mod_name + = loadInterfaceWithException doc mod_name ImportByPlugin + +------------------ +-- | A wrapper for 'loadInterface' that throws an exception if it fails +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException doc mod_name where_from + = withException (loadInterface doc mod_name where_from) + +------------------ +loadInterface :: SDoc -> Module -> WhereFrom + -> IfM lcl (MaybeErr MsgDoc ModIface) + +-- loadInterface looks in both the HPT and PIT for the required interface +-- If not found, it loads it, and puts it in the PIT (always). + +-- If it can't find a suitable interface file, we +-- a) modify the PackageIfaceTable to have an empty entry +-- (to avoid repeated complaints) +-- b) return (Left message) +-- +-- It's not necessarily an error for there not to be an interface +-- file -- perhaps the module has changed, and that interface +-- is no longer used + +loadInterface doc_str mod from + | isHoleModule mod + -- Hole modules get special treatment + = do dflags <- getDynFlags + -- Redo search for our local hole module + loadInterface doc_str (mkHomeModule dflags (moduleName mod)) from + | otherwise + = withTimingSilentD (text "loading interface") (pure ()) $ + do { -- Read the state + (eps,hpt) <- getEpsAndHpt + ; gbl_env <- getGblEnv + + ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) + + -- Check whether we have the interface already + ; dflags <- getDynFlags + ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { + Just iface + -> return (Succeeded iface) ; -- Already loaded + -- The (src_imp == mi_boot iface) test checks that the already-loaded + -- interface isn't a boot iface. This can conceivably happen, + -- if an earlier import had a before we got to real imports. I think. + _ -> do { + + -- READ THE MODULE IN + ; read_result <- case (wantHiBootFile dflags eps mod from) of + Failed err -> return (Failed err) + Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod + ; case read_result of { + Failed err -> do + { let fake_iface = emptyFullModIface mod + + ; updateEps_ $ \eps -> + eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } + -- Not found, so add an empty iface to + -- the EPS map so that we don't look again + + ; return (Failed err) } ; + + -- Found and parsed! + -- We used to have a sanity check here that looked for: + -- * System importing .. + -- * a home package module .. + -- * that we know nothing about (mb_dep == Nothing)! + -- + -- But this is no longer valid because thNameToGhcName allows users to + -- cause the system to load arbitrary interfaces (by supplying an appropriate + -- Template Haskell original-name). + Succeeded (iface, loc) -> + let + loc_doc = text loc + in + initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do + + dontLeakTheHPT $ do + + -- Load the new ModIface into the External Package State + -- Even home-package interfaces loaded by loadInterface + -- (which only happens in OneShot mode; in Batch/Interactive + -- mode, home-package modules are loaded one by one into the HPT) + -- are put in the EPS. + -- + -- The main thing is to add the ModIface to the PIT, but + -- we also take the + -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, + -- out of the ModIface and put them into the big EPS pools + + -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined + --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). + -- If we do loadExport first the wrong info gets into the cache (unless we + -- explicitly tag each export which seems a bit of a bore) + + ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) + ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) + ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + + ; let { final_iface = iface { + mi_decls = panic "No mi_decls in PIT", + mi_insts = panic "No mi_insts in PIT", + mi_fam_insts = panic "No mi_fam_insts in PIT", + mi_rules = panic "No mi_rules in PIT", + mi_anns = panic "No mi_anns in PIT" + } + } + + ; let bad_boot = mi_boot iface == IsBoot && fmap fst (if_rec_types gbl_env) == Just mod + -- Warn against an EPS-updating import + -- of one's own boot file! (one-shot only) + -- See Note [Loading your own hi-boot file] + + ; WARN( bad_boot, ppr mod ) + updateEps_ $ \ eps -> + if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface + then eps + else if bad_boot + -- See Note [Loading your own hi-boot file] + then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls } + else + eps { + eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_rule_base = extendRuleBaseList (eps_rule_base eps) + new_eps_rules, + eps_complete_matches + = extendCompleteMatchMap + (eps_complete_matches eps) + new_eps_complete_sigs, + eps_inst_env = extendInstEnvList (eps_inst_env eps) + new_eps_insts, + eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) + new_eps_fam_insts, + eps_ann_env = extendAnnEnvList (eps_ann_env eps) + new_eps_anns, + eps_mod_fam_inst_env + = let + fam_inst_env = + extendFamInstEnvList emptyFamInstEnv + new_eps_fam_insts + in + extendModuleEnv (eps_mod_fam_inst_env eps) + mod + fam_inst_env, + eps_stats = addEpsInStats (eps_stats eps) + (length new_eps_decls) + (length new_eps_insts) + (length new_eps_rules) } + + ; -- invoke plugins with *full* interface, not final_iface, to ensure + -- that plugins have access to declarations, etc. + res <- withPlugins dflags (\p -> interfaceLoadAction p) iface + ; return (Succeeded res) + }}}} + +{- Note [Loading your own hi-boot file] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, when compiling module M, we should not +load M.hi boot into the EPS. After all, we are very shortly +going to have full information about M. Moreover, see +Note [Do not update EPS with your own hi-boot] in GHC.Iface.Recomp. + +But there is a HORRIBLE HACK here. + +* At the end of tcRnImports, we call checkFamInstConsistency to + check consistency of imported type-family instances + See Note [The type family instance consistency story] in GHC.Tc.Instance.Family + +* Alas, those instances may refer to data types defined in M, + if there is a M.hs-boot. + +* And that means we end up loading M.hi-boot, because those + data types are not yet in the type environment. + +But in this weird case, /all/ we need is the types. We don't need +instances, rules etc. And if we put the instances in the EPS +we get "duplicate instance" warnings when we compile the "real" +instance in M itself. Hence the strange business of just updateing +the eps_PTE. + +This really happens in practice. The module "GHC.Hs.Expr" gets +"duplicate instance" errors if this hack is not present. + +This is a mess. + + +Note [HPT space leak] (#15111) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In IfL, we defer some work until it is demanded using forkM, such +as building TyThings from IfaceDecls. These thunks are stored in +the ExternalPackageState, and they might never be poked. If we're +not careful, these thunks will capture the state of the loaded +program when we read an interface file, and retain all that data +for ever. + +Therefore, when loading a package interface file , we use a "clean" +version of the HscEnv with all the data about the currently loaded +program stripped out. Most of the fields can be panics because +we'll never read them, but hsc_HPT needs to be empty because this +interface will cause other interfaces to be loaded recursively, and +when looking up those interfaces we use the HPT in loadInterface. +We know that none of the interfaces below here can refer to +home-package modules however, so it's safe for the HPT to be empty. +-} + +dontLeakTheHPT :: IfL a -> IfL a +dontLeakTheHPT thing_inside = do + let + cleanTopEnv HscEnv{..} = + let + -- wrinkle: when we're typechecking in --backpack mode, the + -- instantiation of a signature might reside in the HPT, so + -- this case breaks the assumption that EPS interfaces only + -- refer to other EPS interfaces. + -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it + -- contains any hole modules. + -- Quite a few tests in testsuite/tests/backpack break without this + -- tweak. + keepFor20509 hmi + | isHoleModule (mi_semantic_module (hm_iface hmi)) = True + | otherwise = False + !hpt | anyHpt keepFor20509 hsc_HPT = hsc_HPT + | otherwise = emptyHomePackageTable + in + HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets" + , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph" + , hsc_IC = panic "cleanTopEnv: hsc_IC" + , hsc_HPT = hpt + , .. } + + updTopEnv cleanTopEnv $ do + !_ <- getTopEnv -- force the updTopEnv + thing_inside + + +-- | Returns @True@ if a 'ModIface' comes from an external package. +-- In this case, we should NOT load it into the EPS; the entities +-- should instead come from the local merged signature interface. +is_external_sig :: DynFlags -> ModIface -> Bool +is_external_sig dflags iface = + -- It's a signature iface... + mi_semantic_module iface /= mi_module iface && + -- and it's not from the local package + moduleUnit (mi_module iface) /= homeUnit dflags + +-- | This is an improved version of 'findAndReadIface' which can also +-- handle the case when a user requests @p[A=]:M@ but we only +-- have an interface for @p[A=]:M@ (the indefinite interface. +-- If we are not trying to build code, we load the interface we have, +-- *instantiating it* according to how the holes are specified. +-- (Of course, if we're actually building code, this is a hard error.) +-- +-- In the presence of holes, 'computeInterface' has an important invariant: +-- to load module M, its set of transitively reachable requirements must +-- have an up-to-date local hi file for that requirement. Note that if +-- we are loading the interface of a requirement, this does not +-- apply to the requirement itself; e.g., @p[A=]:A@ does not require +-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless +-- we are actually typechecking p.) +computeInterface :: + SDoc -> IsBootInterface -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) +computeInterface doc_str hi_boot_file mod0 = do + MASSERT( not (isHoleModule mod0) ) + dflags <- getDynFlags + case getModuleInstantiation mod0 of + (imod, Just indef) | homeUnitIsIndefinite dflags -> do + r <- findAndReadIface doc_str imod mod0 hi_boot_file + case r of + Succeeded (iface0, path) -> do + hsc_env <- getTopEnv + r <- liftIO $ + rnModIface hsc_env (instUnitInsts (moduleUnit indef)) + Nothing iface0 + case r of + Right x -> return (Succeeded (x, path)) + Left errs -> liftIO . throwIO . mkSrcErr $ errs + Failed err -> return (Failed err) + (mod, _) -> + findAndReadIface doc_str mod mod0 hi_boot_file + +-- | Compute the signatures which must be compiled in order to +-- load the interface for a 'Module'. The output of this function +-- is always a subset of 'moduleFreeHoles'; it is more precise +-- because in signature @p[A=\,B=\]:B@, although the free holes +-- are A and B, B might not depend on A at all! +-- +-- If this is invoked on a signature, this does NOT include the +-- signature itself; e.g. precise free module holes of +-- @p[A=\,B=\]:B@ never includes B. +moduleFreeHolesPrecise + :: SDoc -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) +moduleFreeHolesPrecise doc_str mod + | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) + | otherwise = + case getModuleInstantiation mod of + (imod, Just indef) -> do + let insts = instUnitInsts (moduleUnit indef) + traceIf (text "Considering whether to load" <+> ppr mod <+> + text "to compute precise free module holes") + (eps, hpt) <- getEpsAndHpt + case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of + Just r -> return (Succeeded r) + Nothing -> readAndCache imod insts + (_, Nothing) -> return (Succeeded emptyUniqDSet) + where + tryEpsAndHpt eps hpt = + fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod) + tryDepsCache eps imod insts = + case lookupInstalledModuleEnv (eps_free_holes eps) imod of + Just ifhs -> Just (renameFreeHoles ifhs insts) + _otherwise -> Nothing + readAndCache imod insts = do + mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot + case mb_iface of + Succeeded (iface, _) -> do + let ifhs = mi_free_holes iface + -- Cache it + updateEps_ (\eps -> + eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs }) + return (Succeeded (renameFreeHoles ifhs insts)) + Failed err -> return (Failed err) + +wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom + -> MaybeErr MsgDoc IsBootInterface +-- Figure out whether we want Foo.hi or Foo.hi-boot +wantHiBootFile dflags eps mod from + = case from of + ImportByUser usr_boot + | usr_boot == IsBoot && not this_package + -> Failed (badSourceImport mod) + | otherwise -> Succeeded usr_boot + + ImportByPlugin + -> Succeeded NotBoot + + ImportBySystem + | not this_package -- If the module to be imported is not from this package + -> Succeeded NotBoot -- don't look it up in eps_is_boot, because that is keyed + -- on the ModuleName of *home-package* modules only. + -- We never import boot modules from other packages! + + | otherwise + -> case lookupUFM (eps_is_boot eps) (moduleName mod) of + Just (GWIB { gwib_isBoot = is_boot }) -> + Succeeded is_boot + Nothing -> + Succeeded NotBoot + -- The boot-ness of the requested interface, + -- based on the dependencies in directly-imported modules + where + this_package = homeUnit dflags == moduleUnit mod + +badSourceImport :: Module -> SDoc +badSourceImport mod + = hang (text "You cannot {-# SOURCE #-} import a module from another package") + 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") + <+> quotes (ppr (moduleUnit mod))) + +----------------------------------------------------- +-- Loading type/class/value decls +-- We pass the full Module name here, replete with +-- its package info, so that we can build a Name for +-- each binder with the right package info in it +-- All subsequent lookups, including crucially lookups during typechecking +-- the declaration itself, will find the fully-glorious Name +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implicit things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). +----------------------------------------------------- + +addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv +addDeclsToPTE pte things = extendNameEnvList pte things + +loadDecls :: Bool + -> [(Fingerprint, IfaceDecl)] + -> IfL [(Name,TyThing)] +loadDecls ignore_prags ver_decls + = concatMapM (loadDecl ignore_prags) ver_decls + +loadDecl :: Bool -- Don't load pragmas into the decl pool + -> (Fingerprint, IfaceDecl) + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks +loadDecl ignore_prags (_version, decl) + = do { -- Populate the name cache with final versions of all + -- the names associated with the decl + let main_name = ifName decl + + -- Typecheck the thing, lazily + -- NB. Firstly, the laziness is there in case we never need the + -- declaration (in one-shot mode), and secondly it is there so that + -- we don't look up the occurrence of a name before calling mk_new_bndr + -- on the binder. This is important because we must get the right name + -- which includes its nameParent. + + ; thing <- forkM doc $ do { bumpDeclStats main_name + ; tcIfaceDecl ignore_prags decl } + + -- Populate the type environment with the implicitTyThings too. + -- + -- Note [Tricky iface loop] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- Summary: The delicate point here is that 'mini-env' must be + -- buildable from 'thing' without demanding any of the things + -- 'forkM'd by tcIfaceDecl. + -- + -- In more detail: Consider the example + -- data T a = MkT { x :: T a } + -- The implicitTyThings of T are: [ , ] + -- (plus their workers, wrappers, coercions etc etc) + -- + -- We want to return an environment + -- [ "MkT" -> , "x" -> , ... ] + -- (where the "MkT" is the *Name* associated with MkT, etc.) + -- + -- We do this by mapping the implicit_names to the associated + -- TyThings. By the invariant on ifaceDeclImplicitBndrs and + -- implicitTyThings, we can use getOccName on the implicit + -- TyThings to make this association: each Name's OccName should + -- be the OccName of exactly one implicitTyThing. So the key is + -- to define a "mini-env" + -- + -- [ 'MkT' -> , 'x' -> , ... ] + -- where the 'MkT' here is the *OccName* associated with MkT. + -- + -- However, there is a subtlety: due to how type checking needs + -- to be staged, we can't poke on the forkM'd thunks inside the + -- implicitTyThings while building this mini-env. + -- If we poke these thunks too early, two problems could happen: + -- (1) When processing mutually recursive modules across + -- hs-boot boundaries, poking too early will do the + -- type-checking before the recursive knot has been tied, + -- so things will be type-checked in the wrong + -- environment, and necessary variables won't be in + -- scope. + -- + -- (2) Looking up one OccName in the mini_env will cause + -- others to be looked up, which might cause that + -- original one to be looked up again, and hence loop. + -- + -- The code below works because of the following invariant: + -- getOccName on a TyThing does not force the suspended type + -- checks in order to extract the name. For example, we don't + -- poke on the "T a" type of on the way to + -- extracting 's OccName. Of course, there is no + -- reason in principle why getting the OccName should force the + -- thunks, but this means we need to be careful in + -- implicitTyThings and its helper functions. + -- + -- All a bit too finely-balanced for my liking. + + -- This mini-env and lookup function mediates between the + --'Name's n and the map from 'OccName's to the implicit TyThings + ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] + lookup n = case lookupOccEnv mini_env (getOccName n) of + Just thing -> thing + Nothing -> + pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) + + ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl) + +-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) + ; return $ (main_name, thing) : + -- uses the invariant that implicit_names and + -- implicitTyThings are bijective + [(n, lookup n) | n <- implicit_names] + } + where + doc = text "Declaration for" <+> ppr (ifName decl) + +bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used +bumpDeclStats name + = do { traceIf (text "Loading decl for" <+> ppr name) + ; updateEps_ (\eps -> let stats = eps_stats eps + in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) + } + +{- +********************************************************* +* * +\subsection{Reading an interface file} +* * +********************************************************* + +Note [Home module load error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the sought-for interface is in the current package (as determined +by -package-name flag) then it jolly well should already be in the HPT +because we process home-package modules in dependency order. (Except +in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Types). + +It is possible (though hard) to get this error through user behaviour. + * Suppose package P (modules P1, P2) depends on package Q (modules Q1, + Q2, with Q2 importing Q1) + * We compile both packages. + * Now we edit package Q so that it somehow depends on P + * Now recompile Q with --make (without recompiling P). + * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2 + is a home-package module which is not yet in the HPT! Disaster. + +This actually happened with P=base, Q=ghc-prim, via the AMP warnings. +See #8320. +-} + +findAndReadIface :: SDoc + -- The unique identifier of the on-disk module we're + -- looking for + -> InstalledModule + -- The *actual* module we're looking for. We use + -- this to check the consistency of the requirements + -- of the module we read out. + -> Module + -> IsBootInterface -- True <=> Look for a .hi-boot file + -- False <=> Look for .hi file + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) + -- Nothing <=> file not found, or unreadable, or illegible + -- Just x <=> successfully found and parsed + + -- It *doesn't* add an error to the monad, because + -- sometimes it's ok to fail... see notes with loadInterface +findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file + = do traceIf (sep [hsep [text "Reading", + if hi_boot_file == IsBoot + then text "[boot]" + else Outputable.empty, + text "interface for", + ppr mod <> semi], + nest 4 (text "reason:" <+> doc_str)]) + + -- Check for GHC.Prim, and return its static interface + -- TODO: make this check a function + if mod `installedModuleEq` gHC_PRIM + then do + iface <- getHooked ghcPrimIfaceHook ghcPrimIface + return (Succeeded (iface, + "")) + else do + dflags <- getDynFlags + -- Look for the file + hsc_env <- getTopEnv + mb_found <- liftIO (findExactModule hsc_env mod) + case mb_found of + InstalledFound loc mod -> do + -- Found file, so read it + let file_path = addBootSuffix_maybe hi_boot_file + (ml_hi_file loc) + + -- See Note [Home module load error] + if moduleUnit mod `unitIdEq` homeUnit dflags && + not (isOneShot (ghcMode dflags)) + then return (Failed (homeModError mod loc)) + else do r <- read_file file_path + checkBuildDynamicToo r + return r + err -> do + traceIf (text "...not found") + dflags <- getDynFlags + return (Failed (cannotFindInterface dflags + (moduleName mod) err)) + where read_file file_path = do + traceIf (text "readIFace" <+> text file_path) + -- Figure out what is recorded in mi_module. If this is + -- a fully definite interface, it'll match exactly, but + -- if it's indefinite, the inside will be uninstantiated! + dflags <- getDynFlags + let wanted_mod = + case getModuleInstantiation wanted_mod_with_insts of + (_, Nothing) -> wanted_mod_with_insts + (_, Just indef_mod) -> + instModuleToModule (unitState dflags) + (uninstantiateInstantiatedModule indef_mod) + read_result <- readIface wanted_mod file_path + case read_result of + Failed err -> return (Failed (badIfaceFile file_path err)) + Succeeded iface -> return (Succeeded (iface, file_path)) + -- Don't forget to fill in the package name... + checkBuildDynamicToo (Succeeded (iface, filePath)) = do + dflags <- getDynFlags + -- Indefinite interfaces are ALWAYS non-dynamic, and + -- that's OK. + let is_definite_iface = moduleIsDefinite (mi_module iface) + when is_definite_iface $ + whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do + let ref = canGenerateDynamicToo dflags + dynFilePath = addBootSuffix_maybe hi_boot_file + $ replaceExtension filePath (dynHiSuf dflags) + r <- read_file dynFilePath + case r of + Succeeded (dynIface, _) + | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> + return () + | otherwise -> + do traceIf (text "Dynamic hash doesn't match") + liftIO $ writeIORef ref False + Failed err -> + do traceIf (text "Failed to load dynamic interface file:" $$ err) + liftIO $ writeIORef ref False + checkBuildDynamicToo _ = return () + +-- | Write interface file +writeIface :: DynFlags -> FilePath -> ModIface -> IO () +writeIface dflags hi_file_path new_iface + = do createDirectoryIfMissing True (takeDirectory hi_file_path) + writeBinIface dflags hi_file_path new_iface + +-- @readIface@ tries just the one file. +readIface :: Module -> FilePath + -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) + -- Failed err <=> file not found, or unreadable, or illegible + -- Succeeded iface <=> successfully found and parsed + +readIface wanted_mod file_path + = do { res <- tryMostM $ + readBinIface CheckHiWay QuietBinIFaceReading file_path + ; case res of + Right iface + -- NB: This check is NOT just a sanity check, it is + -- critical for correctness of recompilation checking + -- (it lets us tell when -this-unit-id has changed.) + | wanted_mod == actual_mod + -> return (Succeeded iface) + | otherwise -> return (Failed err) + where + actual_mod = mi_module iface + err = hiModuleNameMismatchWarn wanted_mod actual_mod + + Left exn -> return (Failed (text (showException exn))) + } + +{- +********************************************************* +* * + Wired-in interface for GHC.Prim +* * +********************************************************* +-} + +initExternalPackageState :: DynFlags -> ExternalPackageState +initExternalPackageState dflags + = EPS { + eps_is_boot = emptyUFM, + eps_PIT = emptyPackageIfaceTable, + eps_free_holes = emptyInstalledModuleEnv, + eps_PTE = emptyTypeEnv, + eps_inst_env = emptyInstEnv, + eps_fam_inst_env = emptyFamInstEnv, + eps_rule_base = mkRuleBase builtinRules', + -- Initialise the EPS rule pool with the built-in rules + eps_mod_fam_inst_env + = emptyModuleEnv, + eps_complete_matches = emptyUFM, + eps_ann_env = emptyAnnEnv, + eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 + , n_insts_in = 0, n_insts_out = 0 + , n_rules_in = length builtinRules', n_rules_out = 0 } + } + where + enableBignumRules + | homeUnitId dflags == primUnitId = EnableBignumRules False + | homeUnitId dflags == bignumUnitId = EnableBignumRules False + | otherwise = EnableBignumRules True + builtinRules' = builtinRules enableBignumRules + +{- +********************************************************* +* * + Wired-in interface for GHC.Prim +* * +********************************************************* +-} + +ghcPrimIface :: ModIface +ghcPrimIface + = empty_iface { + mi_exports = ghcPrimExports, + mi_decls = [], + mi_fixities = fixities, + mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }, + mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs] + } + where + empty_iface = emptyFullModIface gHC_PRIM + + -- The fixities listed here for @`seq`@ or @->@ should match + -- those in primops.txt.pp (from which Haddock docs are generated). + fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) + : mapMaybe mkFixity allThePrimOps + mkFixity op = (,) (primOpOcc op) <$> primOpFixity op + +{- +********************************************************* +* * +\subsection{Statistics} +* * +********************************************************* +-} + +ifaceStats :: ExternalPackageState -> SDoc +ifaceStats eps + = hcat [text "Renamer stats: ", msg] + where + stats = eps_stats eps + msg = vcat + [int (n_ifaces_in stats) <+> text "interfaces read", + hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", + int (n_decls_in stats), text "read"], + hsep [ int (n_insts_out stats), text "instance decls imported, out of", + int (n_insts_in stats), text "read"], + hsep [ int (n_rules_out stats), text "rule decls imported, out of", + int (n_rules_in stats), text "read"] + ] + +{- +************************************************************************ +* * + Printing interfaces +* * +************************************************************************ + +Note [Name qualification with --show-iface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In order to disambiguate between identifiers from different modules, we qualify +all names that don't originate in the current module. In order to keep visual +noise as low as possible, we keep local names unqualified. + +For some background on this choice see trac #15269. +-} + +-- | Read binary interface, and print it out +showIface :: HscEnv -> FilePath -> IO () +showIface hsc_env filename = do + -- skip the hi way check; we don't want to worry about profiled vs. + -- non-profiled interfaces, for example. + iface <- initTcRnIf 's' hsc_env () () $ + readBinIface IgnoreHiWay TraceBinIFaceReading filename + let dflags = hsc_dflags hsc_env + -- See Note [Name qualification with --show-iface] + qualifyImportedNames mod _ + | mod == mi_module iface = NameUnqual + | otherwise = NameNotInScope1 + print_unqual = QueryQualify qualifyImportedNames + neverQualifyModules + neverQualifyPackages + putLogMsg dflags NoReason SevDump noSrcSpan + $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface) + +-- Show a ModIface but don't display details; suitable for ModIfaces stored in +-- the EPT. +pprModIfaceSimple :: ModIface -> SDoc +pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) + +pprModIface :: ModIface -> SDoc +-- Show a ModIface +pprModIface iface@ModIface{ mi_final_exts = exts } + = vcat [ text "interface" + <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) + <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty) + <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty) + <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) + <+> integer hiVersion + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts)) + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts)) + , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts)) + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts)) + , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts)) + , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) + , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) + , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) + , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) + , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) + , nest 2 (text "where") + , text "exports:" + , nest 2 (vcat (map pprExport (mi_exports iface))) + , pprDeps (mi_deps iface) + , vcat (map pprUsage (mi_usages iface)) + , vcat (map pprIfaceAnnotation (mi_anns iface)) + , pprFixities (mi_fixities iface) + , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] + , vcat (map ppr (mi_insts iface)) + , vcat (map ppr (mi_fam_insts iface)) + , vcat (map ppr (mi_rules iface)) + , ppr (mi_warns iface) + , pprTrustInfo (mi_trust iface) + , pprTrustPkg (mi_trust_pkg iface) + , vcat (map ppr (mi_complete_sigs iface)) + , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) + , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) + , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface)) + , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface)) + ] + where + pp_hsc_src HsBootFile = text "[boot]" + pp_hsc_src HsigFile = text "[hsig]" + pp_hsc_src HsSrcFile = Outputable.empty + +{- +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C +-} + +pprExport :: IfaceExport -> SDoc +pprExport (Avail n) = ppr n +pprExport (AvailTC _ [] []) = Outputable.empty +pprExport (AvailTC n ns0 fs) + = case ns0 of + (n':ns) | n==n' -> ppr n <> pp_export ns fs + _ -> ppr n <> vbar <> pp_export ns0 fs + where + pp_export [] [] = Outputable.empty + pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs)) + +pprUsage :: Usage -> SDoc +pprUsage usage@UsagePackageModule{} + = pprUsageImport usage usg_mod +pprUsage usage@UsageHomeModule{} + = pprUsageImport usage usg_mod_name $$ + nest 2 ( + maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ + vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] + ) +pprUsage usage@UsageFile{} + = hsep [text "addDependentFile", + doubleQuotes (text (usg_file_path usage)), + ppr (usg_file_hash usage)] +pprUsage usage@UsageMergedRequirement{} + = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] + +pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc +pprUsageImport usage usg_mod' + = hsep [text "import", safe, ppr (usg_mod' usage), + ppr (usg_mod_hash usage)] + where + safe | usg_safe usage = text "safe" + | otherwise = text " -/ " + +pprDeps :: Dependencies -> SDoc +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, + dep_finsts = finsts }) + = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods), + text "package dependencies:" <+> fsep (map ppr_pkg pkgs), + text "orphans:" <+> fsep (map ppr orphs), + text "family instance modules:" <+> fsep (map ppr finsts) + ] + where + ppr_mod (GWIB { gwib_mod = mod_name, gwib_isBoot = boot }) = ppr mod_name <+> ppr_boot boot + ppr_pkg (pkg,trust_req) = ppr pkg <> + (if trust_req then text "*" else Outputable.empty) + ppr_boot IsBoot = text "[boot]" + ppr_boot NotBoot = Outputable.empty + +pprFixities :: [(OccName, Fixity)] -> SDoc +pprFixities [] = Outputable.empty +pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes + where + pprFix (occ,fix) = ppr fix <+> ppr occ + +pprTrustInfo :: IfaceTrustInfo -> SDoc +pprTrustInfo trust = text "trusted:" <+> ppr trust + +pprTrustPkg :: Bool -> SDoc +pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg + +instance Outputable Warnings where + ppr = pprWarns + +pprWarns :: Warnings -> SDoc +pprWarns NoWarnings = Outputable.empty +pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt +pprWarns (WarnSome prs) = text "Warnings" + <+> vcat (map pprWarning prs) + where pprWarning (name, txt) = ppr name <+> ppr txt + +pprIfaceAnnotation :: IfaceAnnotation -> SDoc +pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) + = ppr target <+> text "annotated by" <+> ppr serialized + +pprExtensibleFields :: ExtensibleFields -> SDoc +pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs + where + pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes" + +{- +********************************************************* +* * +\subsection{Errors} +* * +********************************************************* +-} + +badIfaceFile :: String -> SDoc -> SDoc +badIfaceFile file err + = vcat [text "Bad interface file:" <+> text file, + nest 4 err] + +hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc +hiModuleNameMismatchWarn requested_mod read_mod + | moduleUnit requested_mod == moduleUnit read_mod = + sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, + text "but we were expecting module" <+> quotes (ppr requested_mod), + sep [text "Probable cause: the source code which generated interface file", + text "has an incompatible module name" + ] + ] + | otherwise = + -- ToDo: This will fail to have enough qualification when the package IDs + -- are the same + withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ + -- we want the Modules below to be qualified with package names, + -- so reset the PrintUnqualified setting. + hsep [ text "Something is amiss; requested module " + , ppr requested_mod + , text "differs from name found in the interface file" + , ppr read_mod + , parens (text "if these names look the same, try again with -dppr-debug") + ] + +homeModError :: InstalledModule -> ModLocation -> SDoc +-- See Note [Home module load error] +homeModError mod location + = text "attempting to use module " <> quotes (ppr mod) + <> (case ml_hs_file location of + Just file -> space <> parens (text file) + Nothing -> Outputable.empty) + <+> text "which is not loaded" diff --git a/GHC/Iface/Load.hs-boot b/GHC/Iface/Load.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Iface/Load.hs-boot @@ -0,0 +1,8 @@ +module GHC.Iface.Load where + +import GHC.Unit.Module (Module) +import GHC.Tc.Utils.Monad (IfM) +import GHC.Driver.Types (ModIface) +import GHC.Utils.Outputable (SDoc) + +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/GHC/Iface/Make.hs b/GHC/Iface/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Make.hs @@ -0,0 +1,730 @@ +{- +(c) The University of Glasgow 2006-2008 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Module for constructing @ModIface@ values (interface files), +-- writing them to disk and comparing two versions to see if +-- recompilation is required. +module GHC.Iface.Make + ( mkPartialIface + , mkFullIface + , mkIfaceTc + , mkIfaceExports + , coAxiomToIfaceDecl + , tyThingToIfaceDecl -- Converting things to their Iface equivalents + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Iface.Syntax +import GHC.Iface.Recomp +import GHC.Iface.Load +import GHC.CoreToIface + +import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) +import GHC.Types.Id +import GHC.Types.Annotations +import GHC.Core +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.StgToCmm.Types (CgInfos (..)) +import GHC.Tc.Utils.TcType +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Tc.Utils.Monad +import GHC.Hs +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Name.Reader +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.HsToCore.Docs + +import Data.Function +import Data.List ( findIndex, mapAccumL, sortBy ) +import Data.Ord +import Data.IORef +import GHC.Driver.Plugins (LoadedPlugin(..)) + +{- +************************************************************************ +* * +\subsection{Completing an interface} +* * +************************************************************************ +-} + +mkPartialIface :: HscEnv + -> ModDetails + -> ModGuts + -> PartialModIface +mkPartialIface hsc_env mod_details + ModGuts{ mg_module = this_mod + , mg_hsc_src = hsc_src + , mg_usages = usages + , mg_used_th = used_th + , mg_deps = deps + , mg_rdr_env = rdr_env + , mg_fix_env = fix_env + , mg_warns = warns + , mg_hpc_info = hpc_info + , mg_safe_haskell = safe_mode + , mg_trust_pkg = self_trust + , mg_doc_hdr = doc_hdr + , mg_decl_docs = decl_docs + , mg_arg_docs = arg_docs + } + = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust + safe_mode usages doc_hdr decl_docs arg_docs mod_details + +-- | Fully instantiate an interface. Adds fingerprints and potentially code +-- generator produced information. +-- +-- CgInfos is not available when not generating code (-fno-code), or when not +-- generating interface pragmas (-fomit-interface-pragmas). See also +-- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types. +mkFullIface :: HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface +mkFullIface hsc_env partial_iface mb_cg_infos = do + let decls + | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) + = mi_decls partial_iface + | otherwise + = updateDecl (mi_decls partial_iface) mb_cg_infos + + full_iface <- + {-# SCC "addFingerprints" #-} + addFingerprints hsc_env partial_iface{ mi_decls = decls } + + -- Debug printing + dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface) + + return full_iface + +updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl] +updateDecl decls Nothing = decls +updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos }) = map update_decl decls + where + update_decl (IfaceId nm ty details infos) + | let not_caffy = elemNameSet nm non_cafs + , let mb_lf_info = lookupNameEnv lf_infos nm + , WARN( isNothing mb_lf_info, text "Name without LFInfo:" <+> ppr nm ) True + -- Only allocate a new IfaceId if we're going to update the infos + , isJust mb_lf_info || not_caffy + = IfaceId nm ty details $ + (if not_caffy then (HsNoCafRefs :) else id) + (case mb_lf_info of + Nothing -> infos -- LFInfos not available when building .cmm files + Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos) + + update_decl decl + = decl + +-- | Make an interface from the results of typechecking only. Useful +-- for non-optimising compilation, or where we aren't generating any +-- object code at all ('HscNothing'). +mkIfaceTc :: HscEnv + -> SafeHaskellMode -- The safe haskell mode + -> ModDetails -- gotten from mkBootModDetails, probably + -> TcGblEnv -- Usages, deprecations, etc + -> IO ModIface +mkIfaceTc hsc_env safe_mode mod_details + tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_src = hsc_src, + tcg_imports = imports, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_merged = merged, + tcg_warns = warns, + tcg_hpc = other_hpc_info, + tcg_th_splice_used = tc_splice_used, + tcg_dependent_files = dependent_files + } + = do + let used_names = mkUsedNames tc_result + let pluginModules = + map lpModule (cachedPlugins (hsc_dflags hsc_env)) + deps <- mkDependencies + (homeUnitId (hsc_dflags hsc_env)) + (map mi_module pluginModules) tc_result + let hpc_info = emptyHpcInfo other_hpc_info + used_th <- readIORef tc_splice_used + dep_files <- (readIORef dependent_files) + -- Do NOT use semantic module here; this_mod in mkUsageInfo + -- is used solely to decide if we should record a dependency + -- or not. When we instantiate a signature, the semantic + -- module is something we want to record dependencies for, + -- but if you pass that in here, we'll decide it's the local + -- module and does not need to be recorded as a dependency. + -- See Note [Identity versus semantic module] + usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names + dep_files merged pluginModules + + let (doc_hdr', doc_map, arg_map) = extractDocs tc_result + + let partial_iface = mkIface_ hsc_env + this_mod hsc_src + used_th deps rdr_env + fix_env warns hpc_info + (imp_trust_own_pkg imports) safe_mode usages + doc_hdr' doc_map arg_map + mod_details + + mkFullIface hsc_env partial_iface Nothing + +mkIface_ :: HscEnv -> Module -> HscSource + -> Bool -> Dependencies -> GlobalRdrEnv + -> NameEnv FixItem -> Warnings -> HpcInfo + -> Bool + -> SafeHaskellMode + -> [Usage] + -> Maybe HsDocString + -> DeclDocMap + -> ArgDocMap + -> ModDetails + -> PartialModIface +mkIface_ hsc_env + this_mod hsc_src used_th deps rdr_env fix_env src_warns + hpc_info pkg_trust_req safe_mode usages + doc_hdr decl_docs arg_docs + ModDetails{ md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_anns = anns, + md_types = type_env, + md_exports = exports, + md_complete_sigs = complete_sigs } +-- NB: notice that mkIface does not look at the bindings +-- only at the TypeEnv. The previous Tidy phase has +-- put exactly the info into the TypeEnv that we want +-- to expose in the interface + + = do + let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) + entities = typeEnvElts type_env + decls = [ tyThingToIfaceDecl (hsc_dflags hsc_env) entity + | entity <- entities, + let name = getName entity, + not (isImplicitTyThing entity), + -- No implicit Ids and class tycons in the interface file + not (isWiredInName name), + -- Nor wired-in things; the compiler knows about them anyhow + nameIsLocalOrFrom semantic_mod name ] + -- Sigh: see Note [Root-main Id] in GHC.Tc.Module + -- NB: ABSOLUTELY need to check against semantic_mod, + -- because all of the names in an hsig p[H=]:H + -- are going to be for , not the former id! + -- See Note [Identity versus semantic module] + + fixities = sortBy (comparing fst) + [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] + -- The order of fixities returned from nameEnvElts is not + -- deterministic, so we sort by OccName to canonicalize it. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details. + warns = src_warns + iface_rules = map coreRuleToIfaceRule rules + iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts + iface_fam_insts = map famInstToIfaceFamInst fam_insts + trust_info = setSafeMode safe_mode + annotations = map mkIfaceAnnotation anns + icomplete_sigs = map mkIfaceCompleteSig complete_sigs + + ModIface { + mi_module = this_mod, + -- Need to record this because it depends on the -instantiated-with flag + -- which could change + mi_sig_of = if semantic_mod == this_mod + then Nothing + else Just semantic_mod, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = mkIfaceExports exports, + + -- Sort these lexicographically, so that + -- the result is stable across compilations + mi_insts = sortBy cmp_inst iface_insts, + mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, + mi_rules = sortBy cmp_rule iface_rules, + + mi_fixities = fixities, + mi_warns = warns, + mi_anns = annotations, + mi_globals = maybeGlobalRdrEnv rdr_env, + mi_used_th = used_th, + mi_decls = decls, + mi_hpc = isHpcUsed hpc_info, + mi_trust = trust_info, + mi_trust_pkg = pkg_trust_req, + mi_complete_sigs = icomplete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_final_exts = (), + mi_ext_fields = emptyExtensibleFields } + where + cmp_rule = comparing ifRuleName + -- Compare these lexicographically by OccName, *not* by unique, + -- because the latter is not stable across compilations: + cmp_inst = comparing (nameOccName . ifDFun) + cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) + + dflags = hsc_dflags hsc_env + + -- We only fill in mi_globals if the module was compiled to byte + -- code. Otherwise, the compiler may not have retained all the + -- top-level bindings and they won't be in the TypeEnv (see + -- Desugar.addExportFlagsAndRules). The mi_globals field is used + -- by GHCi to decide whether the module has its full top-level + -- scope available. (#5534) + maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv + maybeGlobalRdrEnv rdr_env + | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env + | otherwise = Nothing + + ifFamInstTcName = ifFamInstFam + + +{- +************************************************************************ +* * + COMPLETE Pragmas +* * +************************************************************************ +-} + +mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch +mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc + + +{- +************************************************************************ +* * + Keeping track of what we've slurped, and fingerprints +* * +************************************************************************ +-} + + +mkIfaceAnnotation :: Annotation -> IfaceAnnotation +mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) + = IfaceAnnotation { + ifAnnotatedTarget = fmap nameOccName target, + ifAnnotatedValue = payload + } + +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical +mkIfaceExports exports + = sortBy stableAvailCmp (map sort_subs exports) + where + sort_subs :: AvailInfo -> AvailInfo + sort_subs (Avail n) = Avail n + sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs) + sort_subs (AvailTC n (m:ms) fs) + | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs) + | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs) + -- Maintain the AvailTC Invariant + + sort_flds = sortBy (stableNameCmp `on` flSelector) + +{- +Note [Original module] +~~~~~~~~~~~~~~~~~~~~~ +Consider this: + module X where { data family T } + module Y( T(..) ) where { import X; data instance T Int = MkT Int } +The exported Avail from Y will look like + X.T{X.T, Y.MkT} +That is, in Y, + - only MkT is brought into scope by the data instance; + - but the parent (used for grouping and naming in T(..) exports) is X.T + - and in this case we export X.T too + +In the result of mkIfaceExports, the names are grouped by defining module, +so we may need to split up a single Avail into multiple ones. +-} + + +{- +************************************************************************ +* * + Converting things to their Iface equivalents +* * +************************************************************************ +-} + +tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl +tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id +tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) +tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax +tyThingToIfaceDecl dflags (AConLike cl) = case cl of + RealDataCon dc -> dataConToIfaceDecl dflags dc -- for ppr purposes only + PatSynCon ps -> patSynToIfaceDecl ps + +-------------------------- +idToIfaceDecl :: Id -> IfaceDecl +-- The Id is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- We can't tidy it here, locally, because it may have +-- free variables in its type or IdInfo +idToIfaceDecl id + = IfaceId { ifName = getName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = toIfaceIdInfo (idInfo id) } + +-------------------------- +dataConToIfaceDecl :: DynFlags -> DataCon -> IfaceDecl +dataConToIfaceDecl dflags dataCon + = IfaceId { ifName = getName dataCon, + ifType = toIfaceType (dataConDisplayType dflags dataCon), + ifIdDetails = IfVanillaId, + ifIdInfo = [] } + +-------------------------- +coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl +-- We *do* tidy Axioms, because they are not (and cannot +-- conveniently be) built in tidy form +coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches + , co_ax_role = role }) + = IfaceAxiom { ifName = getName ax + , ifTyCon = toIfaceTyCon tycon + , ifRole = role + , ifAxBranches = map (coAxBranchToIfaceBranch tycon + (map coAxBranchLHS branch_list)) + branch_list } + where + branch_list = fromBranches branches + +-- 2nd parameter is the list of branch LHSs, in case of a closed type family, +-- for conversion from incompatible branches to incompatible indices. +-- For an open type family the list should be empty. +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom +coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch tc lhs_s + (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs, cab_roles = roles + , cab_rhs = rhs, cab_incomps = incomps }) + + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs + , ifaxbCoVars = map toIfaceIdBndr cvs + , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs + , ifaxbLHS = toIfaceTcArgs tc lhs + , ifaxbRoles = roles + , ifaxbRHS = toIfaceType rhs + , ifaxbIncomps = iface_incomps } + where + iface_incomps = map (expectJust "iface_incomps" + . flip findIndex lhs_s + . eqTypes + . coAxBranchLHS) incomps + +----------------- +tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) +-- We *do* tidy TyCons, because they are not (and cannot +-- conveniently be) built in tidy form +-- The returned TidyEnv is the one after tidying the tyConTyVars +tyConToIfaceDecl env tycon + | Just clas <- tyConClass_maybe tycon + = classToIfaceDecl env clas + + | Just syn_rhs <- synTyConRhs_maybe tycon + = ( tc_env1 + , IfaceSynonym { ifName = getName tycon, + ifRoles = tyConRoles tycon, + ifSynRhs = if_syn_type syn_rhs, + ifBinders = if_binders, + ifResKind = if_res_kind + }) + + | Just fam_flav <- famTyConFlav_maybe tycon + = ( tc_env1 + , IfaceFamily { ifName = getName tycon, + ifResVar = if_res_var, + ifFamFlav = to_if_fam_flav fam_flav, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifFamInj = tyConInjectivityInfo tycon + }) + + | isAlgTyCon tycon + = ( tc_env1 + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = tyConCType tycon, + ifRoles = tyConRoles tycon, + ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifParent = parent }) + + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon + -- We only convert these TyCons to IfaceTyCons when we are + -- just about to pretty-print them, not because we are going + -- to put them into interface files + = ( env + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = Nothing, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon [], + ifGadtSyntax = False, + ifParent = IfNoParent }) + where + -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` + -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause + -- an error. + (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + tc_tyvars = binderVars tc_binders + if_binders = toIfaceTyCoVarBinders tc_binders + -- No tidying of the binders; they are already tidy + if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) + if_syn_type ty = tidyToIfaceType tc_env1 ty + if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon + + parent = case tyConFamInstSig_maybe tycon of + Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) + (toIfaceTyCon tc) + (tidyToIfaceTcArgs tc_env1 tc ty) + Nothing -> IfNoParent + + to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon + to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon + to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing + to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) + = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) + where defs = fromBranches $ coAxiomBranches ax + lhss = map coAxBranchLHS defs + ibr = map (coAxBranchToIfaceBranch tycon lhss) defs + axn = coAxiomName ax + + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con] + ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The AbstractTyCon case happens when a TyCon has been trimmed + -- during tidying. + -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module + -- for GHCi, when browsing a module, in which case the + -- AbstractTyCon and TupleTyCon cases are perfectly sensible. + -- (Tuple declarations are not serialised into interface files.) + + ifaceConDecl data_con + = IfCon { ifConName = dataConName data_con, + ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), + ifConExTCvs = map toIfaceBndr ex_tvs', + ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', + ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, + ifConCtxt = tidyToIfaceContext con_env2 theta, + ifConArgTys = + map (\(Scaled w t) -> (tidyToIfaceType con_env2 w + , (tidyToIfaceType con_env2 t))) arg_tys, + ifConFields = dataConFieldLabels data_con, + ifConStricts = map (toIfaceBang con_env2) + (dataConImplBangs data_con), + ifConSrcStricts = map toIfaceSrcBang + (dataConSrcBangs data_con)} + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + user_bndrs = dataConUserTyVarBinders data_con + + -- Tidy the univ_tvs of the data constructor to be identical + -- to the tyConTyVars of the type constructor. This means + -- (a) we don't need to redundantly put them into the interface file + -- (b) when pretty-printing an Iface data declaration in H98-style syntax, + -- we know that the type variables will line up + -- The latter (b) is important because we pretty-print type constructors + -- by converting to Iface syntax and pretty-printing that + con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) + -- A bit grimy, perhaps, but it's simple! + + (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs + user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs + to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) + + -- By this point, we have tidied every universal and existential + -- tyvar. Because of the dcUserTyCoVarBinders invariant + -- (see Note [DataCon user type variable binders]), *every* + -- user-written tyvar must be contained in the substitution that + -- tidying produced. Therefore, tidying the user-written tyvars is a + -- simple matter of looking up each variable in the substitution, + -- which tidyTyCoVarOcc accomplishes. + tidyUserTyCoVarBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder + tidyUserTyCoVarBinder env (Bndr tv vis) = + Bndr (tidyTyCoVarOcc env tv) vis + +classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) +classToIfaceDecl env clas + = ( env1 + , IfaceClass { ifName = getName tycon, + ifRoles = tyConRoles (classTyCon clas), + ifBinders = toIfaceTyCoVarBinders tc_binders, + ifBody = body, + ifFDs = map toIfaceFD clas_fds }) + where + (_, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas + tycon = classTyCon clas + + body | isAbstractTyCon tycon = IfAbstractClass + | otherwise + = IfConcreteClass { + ifClassCtxt = tidyToIfaceContext env1 sc_theta, + ifATs = map toIfaceAT clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifMinDef = fmap getOccFS (classMinimalDef clas) + } + + (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + + toIfaceAT :: ClassATItem -> IfaceAT + toIfaceAT (ATI tc def) + = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) + where + (env2, if_decl) = tyConToIfaceDecl env1 tc + + toIfaceClassOp (sel_id, def_meth) + = ASSERT( sel_tyvars == binderVars tc_binders ) + IfaceClassOp (getName sel_id) + (tidyToIfaceType env1 op_ty) + (fmap toDmSpec def_meth) + where + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) + op_ty = funResultTy rho_ty + + toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType + toDmSpec (_, VanillaDM) = VanillaDM + toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) + + toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 + ,map (tidyTyVar env1) tvs2) + +-------------------------- + +tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) +-- If the type variable "binder" is in scope, don't re-bind it +-- In a class decl, for example, the ATD binders mention +-- (amd must mention) the class tyvars +tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) + = case lookupVarEnv subst tv of + Just tv' -> (env, Bndr tv' vis) + Nothing -> tidyTyCoVarBinder env tvb + +tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) +tidyTyConBinders = mapAccumL tidyTyConBinder + +tidyTyVar :: TidyEnv -> TyVar -> FastString +tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) + +-------------------------- +instanceToIfaceInst :: ClsInst -> IfaceClsInst +instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag + , is_cls_nm = cls_name, is_cls = cls + , is_tcs = mb_tcs + , is_orphan = orph }) + = ASSERT( cls_name == className cls ) + IfaceClsInst { ifDFun = dfun_name, + ifOFlag = oflag, + ifInstCls = cls_name, + ifInstTys = map do_rough mb_tcs, + ifInstOrph = orph } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name n) + + dfun_name = idName dfun_id + + +-------------------------- +famInstToIfaceFamInst :: FamInst -> IfaceFamInst +famInstToIfaceFamInst (FamInst { fi_axiom = axiom, + fi_fam = fam, + fi_tcs = roughs }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = map do_rough roughs + , ifFamInstOrph = orph } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name n) + + fam_decl = tyConName $ coAxiomTyCon axiom + mod = ASSERT( isExternalName (coAxiomName axiom) ) + nameModule (coAxiomName axiom) + is_local name = nameIsLocalOrFrom mod name + + lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom) + + orph | is_local fam_decl + = NotOrphan (nameOccName fam_decl) + | otherwise + = chooseOrphanAnchor lhs_names + +-------------------------- +coreRuleToIfaceRule :: CoreRule -> IfaceRule +coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) + = pprTrace "toHsRule: builtin" (ppr fn) $ + bogusIfaceRule fn + +coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, + ru_orphan = orph, ru_auto = auto }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map toIfaceBndr bndrs, + ifRuleHead = fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr rhs, + ifRuleAuto = auto, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) + do_arg arg = toIfaceExpr arg + +bogusIfaceRule :: Name -> IfaceRule +bogusIfaceRule id_name + = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan, + ifRuleAuto = True } diff --git a/GHC/Iface/Recomp.hs b/GHC/Iface/Recomp.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp.hs @@ -0,0 +1,1470 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Module for detecting if recompilation is required +module GHC.Iface.Recomp + ( checkOldIface + , RecompileRequired(..) + , recompileRequired + , addFingerprints + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Iface.Syntax +import GHC.Iface.Recomp.Binary +import GHC.Iface.Load +import GHC.Iface.Recomp.Flags + +import GHC.Types.Annotations +import GHC.Core +import GHC.Tc.Utils.Monad +import GHC.Hs +import GHC.Driver.Types +import GHC.Driver.Finder +import GHC.Driver.Session +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Data.Graph.Directed +import GHC.Types.SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique +import GHC.Utils.Misc as Utils hiding ( eqListBy ) +import GHC.Data.Maybe +import GHC.Utils.Binary +import GHC.Utils.Fingerprint +import GHC.Utils.Exception +import GHC.Types.Unique.Set +import GHC.Unit.State + +import Control.Monad +import Data.Function +import Data.List (find, sortBy, sort) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Word (Word64) +import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins ) + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup + +{- + ----------------------------------------------- + Recompilation checking + ----------------------------------------------- + +A complete description of how recompilation checking works can be +found in the wiki commentary: + + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance + +Please read the above page for a top-down description of how this all +works. Notes below cover specific issues related to the implementation. + +Basic idea: + + * In the mi_usages information in an interface, we record the + fingerprint of each free variable of the module + + * In mkIface, we compute the fingerprint of each exported thing A.f. + For each external thing that A.f refers to, we include the fingerprint + of the external reference when computing the fingerprint of A.f. So + if anything that A.f depends on changes, then A.f's fingerprint will + change. + Also record any dependent files added with + * addDependentFile + * #include + * -optP-include + + * In checkOldIface we compare the mi_usages for the module with + the actual fingerprint for all each thing recorded in mi_usages +-} + +data RecompileRequired + = UpToDate + -- ^ everything is up to date, recompilation is not required + | MustCompile + -- ^ The .hs file has been touched, or the .o/.hi file does not exist + | RecompBecause String + -- ^ The .o/.hi files are up to date, but something else has changed + -- to force recompilation; the String says what (one-line summary) + deriving Eq + +instance Semigroup RecompileRequired where + UpToDate <> r = r + mc <> _ = mc + +instance Monoid RecompileRequired where + mempty = UpToDate + +recompileRequired :: RecompileRequired -> Bool +recompileRequired UpToDate = False +recompileRequired _ = True + +-- | Top level function to check if the version of an old interface file +-- is equivalent to the current source file the user asked us to compile. +-- If the same, we can avoid recompilation. We return a tuple where the +-- first element is a bool saying if we should recompile the object file +-- and the second is maybe the interface file, where Nothing means to +-- rebuild the interface file and not use the existing one. +checkOldIface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (RecompileRequired, Maybe ModIface) + +checkOldIface hsc_env mod_summary source_modified maybe_iface + = do let dflags = hsc_dflags hsc_env + showPass dflags $ + "Checking old interface for " ++ + (showPpr dflags $ ms_mod mod_summary) ++ + " (use -ddump-hi-diffs for more details)" + initIfaceCheck (text "checkOldIface") hsc_env $ + check_old_iface hsc_env mod_summary source_modified maybe_iface + +check_old_iface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> IfG (RecompileRequired, Maybe ModIface) + +check_old_iface hsc_env mod_summary src_modified maybe_iface + = let dflags = hsc_dflags hsc_env + getIface = + case maybe_iface of + Just _ -> do + traceIf (text "We already have the old interface for" <+> + ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> loadIface + + loadIface = do + let iface_path = msHiFilePath mod_summary + read_result <- readIface (ms_mod mod_summary) iface_path + case read_result of + Failed err -> do + traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) + traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err) + return Nothing + Succeeded iface -> do + traceIf (text "Read the interface file" <+> text iface_path) + return $ Just iface + + src_changed + | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True + | SourceModified <- src_modified = True + | otherwise = False + in do + when src_changed $ + traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off") + + case src_changed of + -- If the source has changed and we're in interactive mode, + -- avoid reading an interface; just return the one we might + -- have been supplied with. + True | not (isObjectTarget $ hscTarget dflags) -> + return (MustCompile, maybe_iface) + + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + True -> do + maybe_iface' <- getIface + return (MustCompile, maybe_iface') + + False -> do + maybe_iface' <- getIface + case maybe_iface' of + -- We can't retrieve the iface + Nothing -> return (MustCompile, Nothing) + + -- We have got the old iface; check its versions + -- even in the SourceUnmodifiedAndStable case we + -- should check versions because some packages + -- might have changed or gone away. + Just iface -> checkVersions hsc_env mod_summary iface + +-- | Check if a module is still the same 'version'. +-- +-- This function is called in the recompilation checker after we have +-- determined that the module M being checked hasn't had any changes +-- to its source file since we last compiled M. So at this point in general +-- two things may have changed that mean we should recompile M: +-- * The interface export by a dependency of M has changed. +-- * The compiler flags specified this time for M have changed +-- in a manner that is significant for recompilation. +-- We return not just if we should recompile the object file but also +-- if we should rebuild the interface file. +checkVersions :: HscEnv + -> ModSummary + -> ModIface -- Old interface + -> IfG (RecompileRequired, Maybe ModIface) +checkVersions hsc_env mod_summary iface + = do { traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) + + -- readIface will have verified that the UnitId matches, + -- but we ALSO must make sure the instantiation matches up. See + -- test case bkpcabal04! + ; if moduleUnit (mi_module iface) /= homeUnit (hsc_dflags hsc_env) + then return (RecompBecause "-this-unit-id changed", Nothing) else do { + ; recomp <- checkFlagHash hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkOptimHash hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkHpcHash hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkMergedSignatures mod_summary iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkHsig mod_summary iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkHie mod_summary + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkDependencies hsc_env mod_summary iface + ; if recompileRequired recomp then return (recomp, Just iface) else do { + ; recomp <- checkPlugins hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + + + -- Source code unchanged and no errors yet... carry on + -- + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + -- + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant + ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] + ; return (recomp, Just iface) + }}}}}}}}}} + where + this_pkg = homeUnit (hsc_dflags hsc_env) + -- This is a bit of a hack really + mod_deps :: ModuleNameEnv ModuleNameWithIsBoot + mod_deps = mkModDeps (dep_mods (mi_deps iface)) + +-- | Check if any plugins are requesting recompilation +checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired +checkPlugins hsc iface = liftIO $ do + new_fingerprint <- fingerprintPlugins hsc + let old_fingerprint = mi_plugin_hash (mi_final_exts iface) + pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc)) + return $ + pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr + +fingerprintPlugins :: HscEnv -> IO Fingerprint +fingerprintPlugins hsc_env = do + fingerprintPlugins' $ plugins (hsc_dflags hsc_env) + +fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint +fingerprintPlugins' plugins = do + res <- mconcat <$> mapM pluginRecompile' plugins + return $ case res of + NoForceRecompile -> fingerprintString "NoForceRecompile" + ForceRecompile -> fingerprintString "ForceRecompile" + -- is the chance of collision worth worrying about? + -- An alternative is to fingerprintFingerprints [fingerprintString + -- "maybeRecompile", fp] + (MaybeRecompile fp) -> fp + + +pluginRecompileToRecompileRequired + :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired +pluginRecompileToRecompileRequired old_fp new_fp pr + | old_fp == new_fp = + case pr of + NoForceRecompile -> UpToDate + + -- we already checked the fingerprint above so a mismatch is not possible + -- here, remember that: `fingerprint (MaybeRecomp x) == x`. + MaybeRecompile _ -> UpToDate + + -- when we have an impure plugin in the stack we have to unconditionally + -- recompile since it might integrate all sorts of crazy IO results into + -- its compilation output. + ForceRecompile -> RecompBecause "Impure plugin forced recompilation" + + | old_fp `elem` magic_fingerprints || + new_fp `elem` magic_fingerprints + -- The fingerprints do not match either the old or new one is a magic + -- fingerprint. This happens when non-pure plugins are added for the first + -- time or when we go from one recompilation strategy to another: (force -> + -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.) + -- + -- For example when we go from ForceRecomp to NoForceRecomp + -- recompilation is triggered since the old impure plugins could have + -- changed the build output which is now back to normal. + = RecompBecause "Plugins changed" + + | otherwise = + let reason = "Plugin fingerprint changed" in + case pr of + -- even though a plugin is forcing recompilation the fingerprint changed + -- which would cause recompilation anyways so we report the fingerprint + -- change instead. + ForceRecompile -> RecompBecause reason + + _ -> RecompBecause reason + + where + magic_fingerprints = + [ fingerprintString "NoForceRecompile" + , fingerprintString "ForceRecompile" + ] + + +-- | Check if an hsig file needs recompilation because its +-- implementing module has changed. +checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired +checkHsig mod_summary iface = do + dflags <- getDynFlags + let outer_mod = ms_mod mod_summary + inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) + MASSERT( moduleUnit outer_mod == homeUnit dflags ) + case inner_mod == mi_semantic_module iface of + True -> up_to_date (text "implementing module unchanged") + False -> return (RecompBecause "implementing module changed") + +-- | Check if @.hie@ file is out of date or missing. +checkHie :: ModSummary -> IfG RecompileRequired +checkHie mod_summary = do + dflags <- getDynFlags + let hie_date_opt = ms_hie_date mod_summary + hs_date = ms_hs_date mod_summary + pure $ case gopt Opt_WriteHie dflags of + False -> UpToDate + True -> case hie_date_opt of + Nothing -> RecompBecause "HIE file is missing" + Just hie_date + | hie_date < hs_date + -> RecompBecause "HIE file is out of date" + | otherwise + -> UpToDate + +-- | Check the flags haven't changed +checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired +checkFlagHash hsc_env iface = do + let old_hash = mi_flag_hash (mi_final_exts iface) + new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) + (mi_module iface) + putNameLiterally + case old_hash == new_hash of + True -> up_to_date (text "Module flags unchanged") + False -> out_of_date_hash "flags changed" + (text " Module flags have changed") + old_hash new_hash + +-- | Check the optimisation flags haven't changed +checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired +checkOptimHash hsc_env iface = do + let old_hash = mi_opt_hash (mi_final_exts iface) + new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date (text "Optimisation flags unchanged") + | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) + -> up_to_date (text "Optimisation flags changed; ignoring") + | otherwise + -> out_of_date_hash "Optimisation flags changed" + (text " Optimisation flags have changed") + old_hash new_hash + +-- | Check the HPC flags haven't changed +checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired +checkHpcHash hsc_env iface = do + let old_hash = mi_hpc_hash (mi_final_exts iface) + new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date (text "HPC flags unchanged") + | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) + -> up_to_date (text "HPC flags changed; ignoring") + | otherwise + -> out_of_date_hash "HPC flags changed" + (text " HPC flags have changed") + old_hash new_hash + +-- Check that the set of signatures we are merging in match. +-- If the -unit-id flags change, this can change too. +checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired +checkMergedSignatures mod_summary iface = do + dflags <- getDynFlags + let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] + new_merged = case Map.lookup (ms_mod_name mod_summary) + (requirementContext (unitState dflags)) of + Nothing -> [] + Just r -> sort $ map (instModuleToModule (unitState dflags)) r + if old_merged == new_merged + then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged) + else return (RecompBecause "signatures to merge in changed") + +-- If the direct imports of this module are resolved to targets that +-- are not among the dependencies of the previous interface file, +-- then we definitely need to recompile. This catches cases like +-- - an exposed package has been upgraded +-- - we are compiling with different package flags +-- - a home module that was shadowing a package module has been removed +-- - a new home module has been added that shadows a package module +-- See bug #1372. +-- +-- In addition, we also check if the union of dependencies of the imported +-- modules has any difference to the previous set of dependencies. We would need +-- to recompile in that case also since the `mi_deps` field of ModIface needs +-- to be updated to match that information. This is one of the invariants +-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants). +-- See bug #16511. +-- +-- Returns (RecompBecause ) if recompilation is required. +checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired +checkDependencies hsc_env summary iface + = do + checkList $ + [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + , do + (recomp, mnames_seen) <- runUntilRecompRequired $ map + checkForNewHomeDependency + (ms_home_imps summary) + case recomp of + UpToDate -> do + let + seen_home_deps = Set.unions $ map Set.fromList mnames_seen + checkIfAllOldHomeDependenciesAreSeen seen_home_deps + _ -> return recomp] + where + prev_dep_mods = dep_mods (mi_deps iface) + prev_dep_plgn = dep_plgins (mi_deps iface) + prev_dep_pkgs = dep_pkgs (mi_deps iface) + + this_pkg = homeUnit (hsc_dflags hsc_env) + + dep_missing (mb_pkg, L _ mod) = do + find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg) + let reason = moduleNameString mod ++ " changed" + case find_res of + Found _ mod + | pkg == this_pkg + -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " not among previous dependencies" + return (RecompBecause reason) + else + return UpToDate + | otherwise + -> if toUnitId pkg `notElem` (map fst prev_dep_pkgs) + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " is from package " <> quotes (ppr pkg) <> + text ", which is not among previous dependencies" + return (RecompBecause reason) + else + return UpToDate + where pkg = moduleUnit mod + _otherwise -> return (RecompBecause reason) + + projectNonBootNames = map gwib_mod . filter ((== NotBoot) . gwib_isBoot) + old_deps = Set.fromList + $ projectNonBootNames prev_dep_mods + isOldHomeDeps = flip Set.member old_deps + checkForNewHomeDependency (L _ mname) = do + let + mod = mkModule this_pkg mname + str_mname = moduleNameString mname + reason = str_mname ++ " changed" + -- We only want to look at home modules to check if any new home dependency + -- pops in and thus here, skip modules that are not home. Checking + -- membership in old home dependencies suffice because the `dep_missing` + -- check already verified that all imported home modules are present there. + if not (isOldHomeDeps mname) + then return (UpToDate, []) + else do + mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do + let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $ + dep_mods $ mi_deps imported_iface) + case find (not . isOldHomeDeps) mnames of + Nothing -> return (UpToDate, mnames) + Just new_dep_mname -> do + traceHiDiffs $ + text "imported home module " <> quotes (ppr mod) <> + text " has a new dependency " <> quotes (ppr new_dep_mname) + return (RecompBecause reason, []) + return $ fromMaybe (MustCompile, []) mb_result + + -- Performs all recompilation checks in the list until a check that yields + -- recompile required is encountered. Returns the list of the results of + -- all UpToDate checks. + runUntilRecompRequired [] = return (UpToDate, []) + runUntilRecompRequired (check:checks) = do + (recompile, value) <- check + if recompileRequired recompile + then return (recompile, []) + else do + (recomp, values) <- runUntilRecompRequired checks + return (recomp, value:values) + + checkIfAllOldHomeDependenciesAreSeen seen_deps = do + let unseen_old_deps = Set.difference + old_deps + seen_deps + if not (null unseen_old_deps) + then do + let missing_dep = Set.elemAt 0 unseen_old_deps + traceHiDiffs $ + text "missing old home dependency " <> quotes (ppr missing_dep) + return $ RecompBecause "missing old dependency" + else return UpToDate + +needInterface :: Module -> (ModIface -> IfG RecompileRequired) + -> IfG RecompileRequired +needInterface mod continue + = do + mb_recomp <- getFromModIface + "need version info for" + mod + continue + case mb_recomp of + Nothing -> return MustCompile + Just recomp -> return recomp + +getFromModIface :: String -> Module -> (ModIface -> IfG a) + -> IfG (Maybe a) +getFromModIface doc_msg mod getter + = do -- Load the imported interface if possible + let doc_str = sep [text doc_msg, ppr mod] + traceHiDiffs (text "Checking innterface for module" <+> ppr mod) + + mb_iface <- loadInterface doc_str mod ImportBySystem + -- Load the interface, but don't complain on failure; + -- Instead, get an Either back which we can test + + case mb_iface of + Failed _ -> do + traceHiDiffs (sep [text "Couldn't load interface for module", + ppr mod]) + return Nothing + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain: it might + -- just be that the current module doesn't need that + -- import and it's been deleted + Succeeded iface -> Just <$> getter iface + +-- | Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. +checkModUsage :: Unit -> Usage -> IfG RecompileRequired +checkModUsage _this_pkg UsagePackageModule{ + usg_mod = mod, + usg_mod_hash = old_mod_hash } + = needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + -- We only track the ABI hash of package modules, rather than + -- individual entity usages, so if the ABI hash changes we must + -- recompile. This is safe but may entail more recompilation when + -- a dependent package has changed. + +checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } + = needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed (raw)" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + +checkModUsage this_pkg UsageHomeModule{ + usg_mod_name = mod_name, + usg_mod_hash = old_mod_hash, + usg_exports = maybe_old_export_hash, + usg_entities = old_decl_hash } + = do + let mod = mkModule this_pkg mod_name + needInterface mod $ \iface -> do + + let + new_mod_hash = mi_mod_hash (mi_final_exts iface) + new_decl_hash = mi_hash_fn (mi_final_exts iface) + new_export_hash = mi_exp_hash (mi_final_exts iface) + + reason = moduleNameString mod_name ++ " changed" + + -- CHECK MODULE + recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash + if not (recompileRequired recompile) + then return UpToDate + else do + + -- CHECK EXPORT LIST + checkMaybeHash reason maybe_old_export_hash new_export_hash + (text " Export list changed") $ do + + -- CHECK ITEMS ONE BY ONE + recompile <- checkList [ checkEntityUsage reason new_decl_hash u + | u <- old_decl_hash] + if recompileRequired recompile + then return recompile -- This one failed, so just bail out now + else up_to_date (text " Great! The bits I use are up to date") + + +checkModUsage _this_pkg UsageFile{ usg_file_path = file, + usg_file_hash = old_hash } = + liftIO $ + handleIO handler $ do + new_hash <- getFileHash file + if (old_hash /= new_hash) + then return recomp + else return UpToDate + where + recomp = RecompBecause (file ++ " changed") + handler = +#if defined(DEBUG) + \e -> pprTrace "UsageFile" (text (show e)) $ return recomp +#else + \_ -> return recomp -- if we can't find the file, just recompile, don't fail +#endif + +------------------------ +checkModuleFingerprint :: String -> Fingerprint -> Fingerprint + -> IfG RecompileRequired +checkModuleFingerprint reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date (text "Module fingerprint unchanged") + + | otherwise + = out_of_date_hash reason (text " Module fingerprint has changed") + old_mod_hash new_mod_hash + +------------------------ +checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc + -> IfG RecompileRequired -> IfG RecompileRequired +checkMaybeHash reason maybe_old_hash new_hash doc continue + | Just hash <- maybe_old_hash, hash /= new_hash + = out_of_date_hash reason doc hash new_hash + | otherwise + = continue + +------------------------ +checkEntityUsage :: String + -> (OccName -> Maybe (OccName, Fingerprint)) + -> (OccName, Fingerprint) + -> IfG RecompileRequired +checkEntityUsage reason new_hash (name,old_hash) + = case new_hash name of + + Nothing -> -- We used it before, but it ain't there now + out_of_date reason (sep [text "No longer exported:", ppr name]) + + Just (_, new_hash) -- It's there, but is it up to date? + | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) + return UpToDate + | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name) + old_hash new_hash + +up_to_date :: SDoc -> IfG RecompileRequired +up_to_date msg = traceHiDiffs msg >> return UpToDate + +out_of_date :: String -> SDoc -> IfG RecompileRequired +out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) + +out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired +out_of_date_hash reason msg old_hash new_hash + = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) + +---------------------- +checkList :: [IfG RecompileRequired] -> IfG RecompileRequired +-- This helper is used in two places +checkList [] = return UpToDate +checkList (check:checks) = do recompile <- check + if recompileRequired recompile + then return recompile + else checkList checks + + +-- --------------------------------------------------------------------------- +-- Compute fingerprints for the interface + +{- +Note [Fingerprinting IfaceDecls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The general idea here is that we first examine the 'IfaceDecl's and determine +the recursive groups of them. We then walk these groups in dependency order, +serializing each contained 'IfaceDecl' to a "Binary" buffer which we then +hash using MD5 to produce a fingerprint for the group. + +However, the serialization that we use is a bit funny: we override the @putName@ +operation with our own which serializes the hash of a 'Name' instead of the +'Name' itself. This ensures that the fingerprint of a decl changes if anything +in its transitive closure changes. This trick is why we must be careful about +traversing in dependency order: we need to ensure that we have hashes for +everything referenced by the decl which we are fingerprinting. + +Moreover, we need to be careful to distinguish between serialization of binding +Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls +field of a IfaceClsInst): only in the non-binding case should we include the +fingerprint; in the binding case we shouldn't since it is merely the name of the +thing that we are currently fingerprinting. + + +Note [Fingerprinting recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The fingerprinting of a single recursive group is a rather subtle affair, as +seen in #18733. + +How not to fingerprint +---------------------- + +Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a +group in hash environment `hash_env0`: + + 1. extend hash_env0, giving each declaration in the group the fingerprint 0 + 2. use this environment to hash the declarations' ABIs, resulting in + group_fingerprint + 3. produce the final hash environment by extending hash_env0, mapping each + declaration of the group to group_fingerprint + +However, this is wrong. Consider, for instance, a program like: + + data A = ARecu B | ABase String deriving (Show) + data B = BRecu A | BBase Int deriving (Show) + + info :: B + info = BBase 1 + +A consequence of (3) is that A and B will have the same fingerprint. This means +that if the user changes `info` to: + + info :: A + info = ABase "hello" + +The program's ABI fingerprint will not change despite `info`'s type, and +therefore ABI, being clearly different. + +However, the incorrectness doesn't end there: (1) means that all recursive +occurrences of names within the group will be given the same fingerprint. This +means that the group's fingerprint won't change if we change an occurrence of A +to B. + +Surprisingly, this bug (#18733) lurked for many years before being uncovered. + +How we now fingerprint +---------------------- + +As seen above, the fingerprinting function must ensure that a groups +fingerprint captures the structure of within-group occurrences. The scheme that +we use is: + + 0. To ensure determinism, sort the declarations into a stable order by + declaration name + + 1. Extend hash_env0, giving each declaration in the group a sequential + fingerprint (e.g. 0, 1, 2, ...). + + 2. Use this environment to hash the declarations' ABIs, resulting in + group_fingerprint. + + Since we included the sequence number in step (1) programs identical up to + transposition of recursive occurrences are distinguisable, avoiding the + second issue mentioned above. + + 3. Produce the final environment by extending hash_env, mapping each + declaration of the group to the hash of (group_fingerprint, i), where + i is the position of the declaration in the stable ordering. + + Including i in the hash ensures that the first issue noted above is + avoided. + +-} + +-- | Add fingerprints for top-level declarations to a 'ModIface'. +-- +-- See Note [Fingerprinting IfaceDecls] +addFingerprints + :: HscEnv + -> PartialModIface + -> IO ModIface +addFingerprints hsc_env iface0 + = do + eps <- hscEPS hsc_env + let + decls = mi_decls iface0 + warn_fn = mkIfaceWarnCache (mi_warns iface0) + fix_fn = mkIfaceFixCache (mi_fixities iface0) + + -- The ABI of a declaration represents everything that is made + -- visible about the declaration that a client can depend on. + -- see IfaceDeclABI below. + declABI :: IfaceDecl -> IfaceDeclABI + -- TODO: I'm not sure if this should be semantic_mod or this_mod. + -- See also Note [Identity versus semantic module] + declABI decl = (this_mod, decl, extras) + where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts + non_orph_fis top_lvl_name_env decl + + -- This is used for looking up the Name of a default method + -- from its OccName. See Note [default method Name] + top_lvl_name_env = + mkOccEnv [ (nameOccName nm, nm) + | IfaceId { ifName = nm } <- decls ] + + -- Dependency edges between declarations in the current module. + -- This is computed by finding the free external names of each + -- declaration, including IfaceDeclExtras (things that a + -- declaration implicitly depends on). + edges :: [ Node Unique IfaceDeclABI ] + edges = [ DigraphNode abi (getUnique (getOccName decl)) out + | decl <- decls + , let abi = declABI decl + , let out = localOccs $ freeNamesDeclABI abi + ] + + name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n + localOccs = + map (getUnique . getParent . getOccName) + -- NB: names always use semantic module, so + -- filtering must be on the semantic module! + -- See Note [Identity versus semantic module] + . filter ((== semantic_mod) . name_module) + . nonDetEltsUniqSet + -- It's OK to use nonDetEltsUFM as localOccs is only + -- used to construct the edges and + -- stronglyConnCompFromEdgedVertices is deterministic + -- even with non-deterministic order of edges as + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where getParent :: OccName -> OccName + getParent occ = lookupOccEnv parent_map occ `orElse` occ + + -- maps OccNames to their parents in the current module. + -- e.g. a reference to a constructor must be turned into a reference + -- to the TyCon for the purposes of calculating dependencies. + parent_map :: OccEnv OccName + parent_map = foldl' extend emptyOccEnv decls + where extend env d = + extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] + where n = getOccName d + + -- Strongly-connected groups of declarations, in dependency order + groups :: [SCC IfaceDeclABI] + groups = stronglyConnCompFromEdgedVerticesUniq edges + + global_hash_fn = mkHashFun hsc_env eps + + -- How to output Names when generating the data to fingerprint. + -- Here we want to output the fingerprint for each top-level + -- Name, whether it comes from the current module or another + -- module. In this way, the fingerprint for a declaration will + -- change if the fingerprint for anything it refers to (transitively) + -- changes. + mk_put_name :: OccEnv (OccName,Fingerprint) + -> BinHandle -> Name -> IO () + mk_put_name local_env bh name + | isWiredInName name = putNameLiterally bh name + -- wired-in names don't have fingerprints + | otherwise + = ASSERT2( isExternalName name, ppr name ) + let hash | nameModule name /= semantic_mod = global_hash_fn name + -- Get it from the REAL interface!! + -- This will trigger when we compile an hsig file + -- and we know a backing impl for it. + -- See Note [Identity versus semantic module] + | semantic_mod /= this_mod + , not (isHoleModule semantic_mod) = global_hash_fn name + | otherwise = return (snd (lookupOccEnv local_env (getOccName name) + `orElse` pprPanic "urk! lookup local fingerprint" + (ppr name $$ ppr local_env))) + -- This panic indicates that we got the dependency + -- analysis wrong, because we needed a fingerprint for + -- an entity that wasn't in the environment. To debug + -- it, turn the panic into a trace, uncomment the + -- pprTraces below, run the compile again, and inspect + -- the output and the generated .hi file with + -- --show-iface. + in hash >>= put_ bh + + -- take a strongly-connected group of declarations and compute + -- its fingerprint. + + fingerprint_group :: (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + -> SCC IfaceDeclABI + -> IO (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + + fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) + = do let hash_fn = mk_put_name local_env + decl = abiDecl abi + --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do + hash <- computeFingerprint hash_fn abi + env' <- extend_hash_env local_env (hash,decl) + return (env', (hash,decl) : decls_w_hashes) + + fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) + = do let stable_abis = sortBy cmp_abiNames abis + stable_decls = map abiDecl stable_abis + local_env1 <- foldM extend_hash_env local_env + (zip (map mkRecFingerprint [0..]) stable_decls) + -- See Note [Fingerprinting recursive groups] + let hash_fn = mk_put_name local_env1 + -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do + -- put the cycle in a canonical order + hash <- computeFingerprint hash_fn stable_abis + let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls + -- See Note [Fingerprinting recursive groups] + local_env2 <- foldM extend_hash_env local_env pairs + return (local_env2, pairs ++ decls_w_hashes) + + -- Make a fingerprint from the ordinal position of a binding in its group. + mkRecFingerprint :: Word64 -> Fingerprint + mkRecFingerprint i = Fingerprint 0 i + + bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint + bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ] + + -- we have fingerprinted the whole declaration, but we now need + -- to assign fingerprints to all the OccNames that it binds, to + -- use when referencing those OccNames in later declarations. + -- + extend_hash_env :: OccEnv (OccName,Fingerprint) + -> (Fingerprint,IfaceDecl) + -> IO (OccEnv (OccName,Fingerprint)) + extend_hash_env env0 (hash,d) = do + return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 + (ifaceDeclFingerprints hash d)) + + -- + (local_env, decls_w_hashes) <- + foldM fingerprint_group (emptyOccEnv, []) groups + + -- when calculating fingerprints, we always need to use canonical + -- ordering for lists of things. In particular, the mi_deps has various + -- lists of modules and suchlike, so put these all in canonical order: + let sorted_deps = sortDependencies (mi_deps iface0) + + -- The export hash of a module depends on the orphan hashes of the + -- orphan modules below us in the dependency tree. This is the way + -- that changes in orphans get propagated all the way up the + -- dependency tree. + -- + -- Note [A bad dep_orphs optimization] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- In a previous version of this code, we filtered out orphan modules which + -- were not from the home package, justifying it by saying that "we'd + -- pick up the ABI hashes of the external module instead". This is wrong. + -- Suppose that we have: + -- + -- module External where + -- instance Show (a -> b) + -- + -- module Home1 where + -- import External + -- + -- module Home2 where + -- import Home1 + -- + -- The export hash of Home1 needs to reflect the orphan instances of + -- External. It's true that Home1 will get rebuilt if the orphans + -- of External, but we also need to make sure Home2 gets rebuilt + -- as well. See #12733 for more details. + let orph_mods + = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot] + $ dep_orphs sorted_deps + dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods + + -- Note [Do not update EPS with your own hi-boot] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- (See also #10182). When your hs-boot file includes an orphan + -- instance declaration, you may find that the dep_orphs of a module you + -- import contains reference to yourself. DO NOT actually load this module + -- or add it to the orphan hashes: you're going to provide the orphan + -- instances yourself, no need to consult hs-boot; if you do load the + -- interface into EPS, you will see a duplicate orphan instance. + + orphan_hash <- computeFingerprint (mk_put_name local_env) + (map ifDFun orph_insts, orph_rules, orph_fis) + + -- the export list hash doesn't depend on the fingerprints of + -- the Names it mentions, only the Names themselves, hence putNameLiterally. + export_hash <- computeFingerprint putNameLiterally + (mi_exports iface0, + orphan_hash, + dep_orphan_hashes, + dep_pkgs (mi_deps iface0), + -- See Note [Export hash depends on non-orphan family instances] + dep_finsts (mi_deps iface0), + -- dep_pkgs: see "Package Version Changes" on + -- wiki/commentary/compiler/recompilation-avoidance + mi_trust iface0) + -- Make sure change of Safe Haskell mode causes recomp. + + -- Note [Export hash depends on non-orphan family instances] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- + -- Suppose we have: + -- + -- module A where + -- type instance F Int = Bool + -- + -- module B where + -- import A + -- + -- module C where + -- import B + -- + -- The family instance consistency check for C depends on the dep_finsts of + -- B. If we rename module A to A2, when the dep_finsts of B changes, we need + -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of + -- the exports of B, because C always considers them when checking + -- consistency. + -- + -- A full discussion is in #12723. + -- + -- We do NOT need to hash dep_orphs, because this is implied by + -- dep_orphan_hashes, and we do not need to hash ordinary class instances, + -- because there is no eager consistency check as there is with type families + -- (also we didn't store it anywhere!) + -- + + -- put the declarations in a canonical order, sorted by OccName + let sorted_decls :: [(Fingerprint, IfaceDecl)] + sorted_decls = Map.elems $ Map.fromList $ + [(getOccName d, e) | e@(_, d) <- decls_w_hashes] + + -- the flag hash depends on: + -- - (some of) dflags + -- it returns two hashes, one that shouldn't change + -- the abi hash and one that should + flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally + + opt_hash <- fingerprintOptFlags dflags putNameLiterally + + hpc_hash <- fingerprintHpcFlags dflags putNameLiterally + + plugin_hash <- fingerprintPlugins hsc_env + + -- the ABI hash depends on: + -- - decls + -- - export list + -- - orphans + -- - deprecations + -- - flag abi hash + mod_hash <- computeFingerprint putNameLiterally + (map fst sorted_decls, + export_hash, -- includes orphan_hash + mi_warns iface0) + + -- The interface hash depends on: + -- - the ABI hash, plus + -- - the module level annotations, + -- - usages + -- - deps (home and external packages, dependent files) + -- - hpc + iface_hash <- computeFingerprint putNameLiterally + (mod_hash, + ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache + mi_usages iface0, + sorted_deps, + mi_hpc iface0) + + let + final_iface_exts = ModIfaceBackend + { mi_iface_hash = iface_hash + , mi_mod_hash = mod_hash + , mi_flag_hash = flag_hash + , mi_opt_hash = opt_hash + , mi_hpc_hash = hpc_hash + , mi_plugin_hash = plugin_hash + , mi_orphan = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis) + , mi_finsts = not (null (mi_fam_insts iface0)) + , mi_exp_hash = export_hash + , mi_orphan_hash = orphan_hash + , mi_warn_fn = warn_fn + , mi_fix_fn = fix_fn + , mi_hash_fn = lookupOccEnv local_env + } + final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts } + -- + return final_iface + + where + this_mod = mi_module iface0 + semantic_mod = mi_semantic_module iface0 + dflags = hsc_dflags hsc_env + (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) + (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) + (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) + ann_fn = mkIfaceAnnCache (mi_anns iface0) + +-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules +-- (in particular, the orphan modules which are transitively imported by the +-- current module). +-- +-- Q: Why do we need the hash at all, doesn't the list of transitively +-- imported orphan modules suffice? +-- +-- A: If one of our transitive imports adds a new orphan instance, our +-- export hash must change so that modules which import us rebuild. If we just +-- hashed the [Module], the hash would not change even when a new instance was +-- added to a module that already had an orphan instance. +-- +-- Q: Why don't we just hash the orphan hashes of our direct dependencies? +-- Why the full transitive closure? +-- +-- A: Suppose we have these modules: +-- +-- module A where +-- instance Show (a -> b) where +-- module B where +-- import A -- ** +-- module C where +-- import A +-- import B +-- +-- Whether or not we add or remove the import to A in B affects the +-- orphan hash of B. But it shouldn't really affect the orphan hash +-- of C. If we hashed only direct dependencies, there would be no +-- way to tell that the net effect was a wash, and we'd be forced +-- to recompile C and everything else. +getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] +getOrphanHashes hsc_env mods = do + eps <- hscEPS hsc_env + let + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + get_orph_hash mod = + case lookupIfaceByModule hpt pit mod of + Just iface -> return (mi_orphan_hash (mi_final_exts iface)) + Nothing -> do -- similar to 'mkHashFun' + iface <- initIfaceLoad hsc_env . withException + $ loadInterface (text "getOrphanHashes") mod ImportBySystem + return (mi_orphan_hash (mi_final_exts iface)) + + -- + mapM get_orph_hash mods + + +sortDependencies :: Dependencies -> Dependencies +sortDependencies d + = Deps { dep_mods = sortBy (compare `on` (moduleNameFS . gwib_mod)) (dep_mods d), + dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d), + dep_orphs = sortBy stableModuleCmp (dep_orphs d), + dep_finsts = sortBy stableModuleCmp (dep_finsts d), + dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) } + +{- +************************************************************************ +* * + The ABI of an IfaceDecl +* * +************************************************************************ + +Note [The ABI of an IfaceDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ABI of a declaration consists of: + + (a) the full name of the identifier (inc. module and package, + because these are used to construct the symbol name by which + the identifier is known externally). + + (b) the declaration itself, as exposed to clients. That is, the + definition of an Id is included in the fingerprint only if + it is made available as an unfolding in the interface. + + (c) the fixity of the identifier (if it exists) + (d) for Ids: rules + (e) for classes: instances, fixity & rules for methods + (f) for datatypes: instances, fixity & rules for constrs + +Items (c)-(f) are not stored in the IfaceDecl, but instead appear +elsewhere in the interface file. But they are *fingerprinted* with +the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the declaration. +-} + +type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) + +data IfaceDeclExtras + = IfaceIdExtras IfaceIdExtras + + | IfaceDataExtras + (Maybe Fixity) -- Fixity of the tycon itself (if it exists) + [IfaceInstABI] -- Local class and family instances of this tycon + -- See Note [Orphans] in GHC.Core.InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations + + | IfaceClassExtras + (Maybe Fixity) -- Fixity of the class itself (if it exists) + [IfaceInstABI] -- Local instances of this class *or* + -- of its associated data types + -- See Note [Orphans] in GHC.Core.InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each class method: fixity, RULES and annotations + [IfExtName] -- Default methods. If a module + -- mentions a class, then it can + -- instantiate the class and thereby + -- use the default methods, so we must + -- include these in the fingerprint of + -- a class. + + | IfaceSynonymExtras (Maybe Fixity) [AnnPayload] + + | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload] + + | IfaceOtherDeclExtras + +data IfaceIdExtras + = IdExtras + (Maybe Fixity) -- Fixity of the Id (if it exists) + [IfaceRule] -- Rules for the Id + [AnnPayload] -- Annotations for the Id + +-- When hashing a class or family instance, we hash only the +-- DFunId or CoAxiom, because that depends on all the +-- information about the instance. +-- +type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance + +abiDecl :: IfaceDeclABI -> IfaceDecl +abiDecl (_, decl, _) = decl + +cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering +cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` + getOccName (abiDecl abi2) + +freeNamesDeclABI :: IfaceDeclABI -> NameSet +freeNamesDeclABI (_mod, decl, extras) = + freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras + +freeNamesDeclExtras :: IfaceDeclExtras -> NameSet +freeNamesDeclExtras (IfaceIdExtras id_extras) + = freeNamesIdExtras id_extras +freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) + = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) +freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms) + = unionNameSets $ + mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs +freeNamesDeclExtras (IfaceSynonymExtras _ _) + = emptyNameSet +freeNamesDeclExtras (IfaceFamilyExtras _ insts _) + = mkNameSet insts +freeNamesDeclExtras IfaceOtherDeclExtras + = emptyNameSet + +freeNamesIdExtras :: IfaceIdExtras -> NameSet +freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules) + +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = Outputable.empty + ppr (IfaceIdExtras extras) = ppr_id_extras extras + ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] + ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] + ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff] + ppr (IfaceClassExtras fix insts anns stuff defms) = + vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff, ppr defms] + +ppr_insts :: [IfaceInstABI] -> SDoc +ppr_insts _ = text "" + +ppr_id_extras_s :: [IfaceIdExtras] -> SDoc +ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) + +ppr_id_extras :: IfaceIdExtras -> SDoc +ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) + +-- This instance is used only to compute fingerprints +instance Binary IfaceDeclExtras where + get _bh = panic "no get for IfaceDeclExtras" + put_ bh (IfaceIdExtras extras) = do + putByte bh 1; put_ bh extras + put_ bh (IfaceDataExtras fix insts anns cons) = do + putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons + put_ bh (IfaceClassExtras fix insts anns methods defms) = do + putByte bh 3 + put_ bh fix + put_ bh insts + put_ bh anns + put_ bh methods + put_ bh defms + put_ bh (IfaceSynonymExtras fix anns) = do + putByte bh 4; put_ bh fix; put_ bh anns + put_ bh (IfaceFamilyExtras fix finsts anns) = do + putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns + put_ bh IfaceOtherDeclExtras = putByte bh 6 + +instance Binary IfaceIdExtras where + get _bh = panic "no get for IfaceIdExtras" + put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns } + +declExtras :: (OccName -> Maybe Fixity) + -> (OccName -> [AnnPayload]) + -> OccEnv [IfaceRule] + -> OccEnv [IfaceClsInst] + -> OccEnv [IfaceFamInst] + -> OccEnv IfExtName -- lookup default method names + -> IfaceDecl + -> IfaceDeclExtras + +declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl + = case decl of + IfaceId{} -> IfaceIdExtras (id_extras n) + IfaceData{ifCons=cons} -> + IfaceDataExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ + map ifDFun (lookupOccEnvL inst_env n)) + (ann_fn n) + (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) + IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> + IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms + where + insts = (map ifDFun $ (concatMap at_extras ats) + ++ lookupOccEnvL inst_env n) + -- Include instances of the associated types + -- as well as instances of the class (#5147) + meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] + -- Names of all the default methods (see Note [default method Name]) + defms = [ dmName + | IfaceClassOp bndr _ (Just _) <- sigs + , let dmOcc = mkDefaultMethodOcc (nameOccName bndr) + , Just dmName <- [lookupOccEnv dm_env dmOcc] ] + IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) + (ann_fn n) + IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n)) + (ann_fn n) + _other -> IfaceOtherDeclExtras + where + n = getOccName decl + id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) + at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) + + +{- Note [default method Name] (see also #15970) + +The Names for the default methods aren't available in Iface syntax. + +* We originally start with a DefMethInfo from the class, contain a + Name for the default method + +* We turn that into Iface syntax as a DefMethSpec which lacks a Name + entirely. Why? Because the Name can be derived from the method name + (in GHC.IfaceToCore), so doesn't need to be serialised into the interface + file. + +But now we have to get the Name back, because the class declaration's +fingerprint needs to depend on it (this was the bug in #15970). This +is done in a slightly convoluted way: + +* Then, in addFingerprints we build a map that maps OccNames to Names + +* We pass that map to declExtras which laboriously looks up in the map + (using the derived occurrence name) to recover the Name we have just + thrown away. +-} + +lookupOccEnvL :: OccEnv [v] -> OccName -> [v] +lookupOccEnvL env k = lookupOccEnv env k `orElse` [] + +{- +-- for testing: use the md5sum command to generate fingerprints and +-- compare the results against our built-in version. + fp' <- oldMD5 dflags bh + if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') + else return fp + +oldMD5 dflags bh = do + tmp <- newTempName dflags CurrentModule "bin" + writeBinMem bh tmp + tmp2 <- newTempName dflags CurrentModule "md5" + let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 + r <- system cmd + case r of + ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) + ExitSuccess -> do + hash_str <- readFile tmp2 + return $! readHexFingerprint hash_str +-} + +---------------------- +-- mkOrphMap partitions instance decls or rules into +-- (a) an OccEnv for ones that are not orphans, +-- mapping the local OccName to a list of its decls +-- (b) a list of orphan decls +mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl + -> [decl] -- Sorted into canonical order + -> (OccEnv [decl], -- Non-orphan decls associated with their key; + -- each sublist in canonical order + [decl]) -- Orphan decls; in canonical order +mkOrphMap get_key decls + = foldl' go (emptyOccEnv, []) decls + where + go (non_orphs, orphs) d + | NotOrphan occ <- get_key d + = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs) + | otherwise = (non_orphs, d:orphs) + +-- ----------------------------------------------------------------------------- +-- Look up parents and versions of Names + +-- This is like a global version of the mi_hash_fn field in each ModIface. +-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get +-- the parent and version info. + +mkHashFun + :: HscEnv -- needed to look up versions + -> ExternalPackageState -- ditto + -> (Name -> IO Fingerprint) +mkHashFun hsc_env eps name + | isHoleModule orig_mod + = lookup (mkHomeModule dflags (moduleName orig_mod)) + | otherwise + = lookup orig_mod + where + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + occ = nameOccName name + orig_mod = nameModule name + lookup mod = do + MASSERT2( isExternalName name, ppr name ) + iface <- case lookupIfaceByModule hpt pit mod of + Just iface -> return iface + Nothing -> do + -- This can occur when we're writing out ifaces for + -- requirements; we didn't do any /real/ typechecking + -- so there's no guarantee everything is loaded. + -- Kind of a heinous hack. + iface <- initIfaceLoad hsc_env . withException + $ loadInterface (text "lookupVers2") mod ImportBySystem + return iface + return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) + + +-- | Creates cached lookup for the 'mi_anns' field of ModIface +-- Hackily, we use "module" as the OccName for any module-level annotations +mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload] +mkIfaceAnnCache anns + = \n -> lookupOccEnv env n `orElse` [] + where + pair (IfaceAnnotation target value) = + (case target of + NamedTarget occn -> occn + ModuleTarget _ -> mkVarOcc "module" + , [value]) + -- flipping (++), so the first argument is always short + env = mkOccEnv_C (flip (++)) (map pair anns) diff --git a/GHC/Iface/Recomp/Binary.hs b/GHC/Iface/Recomp/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp/Binary.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} + +-- | Computing fingerprints of values serializeable with GHC's \"Binary\" module. +module GHC.Iface.Recomp.Binary + ( -- * Computing fingerprints + fingerprintBinMem + , computeFingerprint + , putNameLiterally + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Fingerprint +import GHC.Utils.Binary +import GHC.Types.Name +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +fingerprintBinMem :: BinHandle -> IO Fingerprint +fingerprintBinMem bh = withBinBuffer bh f + where + f bs = + -- we need to take care that we force the result here + -- lest a reference to the ByteString may leak out of + -- withBinBuffer. + let fp = fingerprintByteString bs + in fp `seq` return fp + +computeFingerprint :: (Binary a) + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint +computeFingerprint put_nonbinding_name a = do + bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block + put_ bh a + fp <- fingerprintBinMem bh + return fp + where + set_user_data bh = + setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS + +-- | Used when we want to fingerprint a structure without depending on the +-- fingerprints of external Names that it refers to. +putNameLiterally :: BinHandle -> Name -> IO () +putNameLiterally bh name = ASSERT( isExternalName name ) do + put_ bh $! nameModule name + put_ bh $! nameOccName name diff --git a/GHC/Iface/Recomp/Flags.hs b/GHC/Iface/Recomp/Flags.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp/Flags.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | This module manages storing the various GHC option flags in a modules +-- interface file as part of the recompilation checking infrastructure. +module GHC.Iface.Recomp.Flags ( + fingerprintDynFlags + , fingerprintOptFlags + , fingerprintHpcFlags + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Utils.Fingerprint +import GHC.Iface.Recomp.Binary +-- import GHC.Utils.Outputable + +import GHC.Data.EnumSet as EnumSet +import System.FilePath (normalise) + +-- | Produce a fingerprint of a @DynFlags@ value. We only base +-- the finger print on important fields in @DynFlags@ so that +-- the recompilation checker can use this fingerprint. +-- +-- NB: The 'Module' parameter is the 'Module' recorded by the +-- *interface* file, not the actual 'Module' according to our +-- 'DynFlags'. +fingerprintDynFlags :: DynFlags -> Module + -> (BinHandle -> Name -> IO ()) + -> IO Fingerprint + +fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = + let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing + -- see #5878 + -- pkgopts = (homeUnit dflags, sort $ packageFlags dflags) + safeHs = setSafeMode safeHaskell + -- oflags = sort $ filter filterOFlags $ flags dflags + + -- *all* the extension flags and the language + lang = (fmap fromEnum language, + map fromEnum $ EnumSet.toList extensionFlags) + + -- avoid fingerprinting the absolute path to the directory of the source file + -- see note [Implicit include paths] + includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] } + + -- -I, -D and -U flags affect CPP + cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , picPOpts dflags + , opt_P_signature dflags) + -- See Note [Repeated -optP hashing] + + -- Note [path flags and recompilation] + paths = [ hcSuf ] + + -- -fprof-auto etc. + prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0 + + -- Ticky + ticky = + map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] + + flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel)) + + in -- pprTrace "flags" (ppr flags) $ + computeFingerprint nameio flags + +-- Fingerprint the optimisation info. We keep this separate from the rest of +-- the flags because GHCi users (especially) may wish to ignore changes in +-- optimisation level or optimisation flags so as to use as many pre-existing +-- object files as they can. +-- See Note [Ignoring some flag changes] +fingerprintOptFlags :: DynFlags + -> (BinHandle -> Name -> IO ()) + -> IO Fingerprint +fingerprintOptFlags DynFlags{..} nameio = + let + -- See https://gitlab.haskell.org/ghc/ghc/issues/10923 + -- We used to fingerprint the optimisation level, but as Joachim + -- Breitner pointed out in comment 9 on that ticket, it's better + -- to ignore that and just look at the individual optimisation flags. + opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags) + (EnumSet.toList generalFlags) + + in computeFingerprint nameio opt_flags + +-- Fingerprint the HPC info. We keep this separate from the rest of +-- the flags because GHCi users (especially) may wish to use an object +-- file compiled for HPC when not actually using HPC. +-- See Note [Ignoring some flag changes] +fingerprintHpcFlags :: DynFlags + -> (BinHandle -> Name -> IO ()) + -> IO Fingerprint +fingerprintHpcFlags dflags@DynFlags{..} nameio = + let + -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798 + -- hpcDir is output-only, so we should recompile if it changes + hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing + + in computeFingerprint nameio hpc + + +{- Note [path flags and recompilation] + +There are several flags that we deliberately omit from the +recompilation check; here we explain why. + +-osuf, -odir, -hisuf, -hidir + If GHC decides that it does not need to recompile, then + it must have found an up-to-date .hi file and .o file. + There is no point recording these flags - the user must + have passed the correct ones. Indeed, the user may + have compiled the source file in one-shot mode using + -o to specify the .o file, and then loaded it in GHCi + using -odir. + +-stubdir + We omit this one because it is automatically set by -outputdir, and + we don't want changes in -outputdir to automatically trigger + recompilation. This could be wrong, but only in very rare cases. + +-i (importPaths) + For the same reason as -osuf etc. above: if GHC decides not to + recompile, then it must have already checked all the .hi files on + which the current module depends, so it must have found them + successfully. It is occasionally useful to be able to cd to a + different directory and use -i flags to enable GHC to find the .hi + files; we don't want this to force recompilation. + +The only path-related flag left is -hcsuf. +-} + +{- Note [Ignoring some flag changes] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Normally, --make tries to reuse only compilation products that are +the same as those that would have been produced compiling from +scratch. Sometimes, however, users would like to be more aggressive +about recompilation avoidance. This is particularly likely when +developing using GHCi (see #13604). Currently, we allow users to +ignore optimisation changes using -fignore-optim-changes, and to +ignore HPC option changes using -fignore-hpc-changes. If there's a +demand for it, we could also allow changes to -fprof-auto-* flags +(although we can't allow -prof flags to differ). The key thing about +these options is that we can still successfully link a library or +executable when some of its components differ in these ways. + +The way we accomplish this is to leave the optimization and HPC +options out of the flag hash, hashing them separately. +-} + +{- Note [Repeated -optP hashing] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We invoke fingerprintDynFlags for each compiled module to include +the hash of relevant DynFlags in the resulting interface file. +-optP (preprocessor) flags are part of that hash. +-optP flags can come from multiple places: + + 1. -optP flags directly passed on command line. + 2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof. + 3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file. + +When compiling many modules at once with many -optP command line arguments +the work of hashing -optP flags would be repeated. This can get expensive +and as noted on #14697 it can take 7% of time and 14% of allocations on +a real codebase. + +The obvious solution is to cache the hash of -optP flags per GHC invocation. +However, one has to be careful there, as the flags that were added in 3. way +have to be accounted for. + +The current strategy is as follows: + + 1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p + is modified. This serves dual purpose. It ensures correctness for when + we add per file -optP flags and lets us save work for when we don't. + 2. When computing the fingerprint in fingerprintDynFlags use the cached + value *and* fingerprint the additional implied (see 2. above) -optP flags. + This is relatively cheap and saves the headache of fingerprinting all + the -optP flags and tracking all the places that could invalidate the + cache. +-} diff --git a/GHC/Iface/Rename.hs b/GHC/Iface/Rename.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Rename.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | This module implements interface renaming, which is +-- used to rewrite interface files on the fly when we +-- are doing indefinite typechecking and need instantiations +-- of modules which do not necessarily exist yet. + +module GHC.Iface.Rename ( + rnModIface, + rnModExports, + tcRnModIface, + tcRnModExports, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Driver.Types +import GHC.Unit +import GHC.Types.Unique.FM +import GHC.Types.Avail +import GHC.Iface.Syntax +import GHC.Types.FieldLabel +import GHC.Types.Var +import GHC.Utils.Error + +import GHC.Types.Name +import GHC.Tc.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Fingerprint +import GHC.Types.Basic + +-- a bit vexing +import {-# SOURCE #-} GHC.Iface.Load +import GHC.Driver.Session + +import qualified Data.Traversable as T + +import GHC.Data.Bag +import Data.IORef +import GHC.Types.Name.Shape +import GHC.Iface.Env + +tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a +tcRnMsgMaybe do_this = do + r <- liftIO $ do_this + case r of + Left errs -> do + addMessages (emptyBag, errs) + failM + Right x -> return x + +tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface +tcRnModIface x y z = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModIface hsc_env x y z + +tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo] +tcRnModExports x y = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModExports hsc_env x y + +failWithRn :: SDoc -> ShIfM a +failWithRn doc = do + errs_var <- fmap sh_if_errs getGblEnv + dflags <- getDynFlags + errs <- readTcRef errs_var + -- TODO: maybe associate this with a source location? + writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc) + failM + +-- | What we have is a generalized ModIface, which corresponds to +-- a module that looks like p[A=\]:B. We need a *specific* ModIface, e.g. +-- p[A=q():A]:B (or maybe even p[A=\]:B) which we load +-- up (either to merge it, or to just use during typechecking). +-- +-- Suppose we have: +-- +-- p[A=\]:M ==> p[A=q():A]:M +-- +-- Substitute all occurrences of \ with q():A (renameHoleModule). +-- Then, for any Name of form {A.T}, replace the Name with +-- the Name according to the exports of the implementing module. +-- This works even for p[A=\]:M, since we just read in the +-- exports of B.hi, which is assumed to be ready now. +-- +-- This function takes an optional 'NameShape', which can be used +-- to further refine the identities in this interface: suppose +-- we read a declaration for {H.T} but we actually know that this +-- should be Foo.T; then we'll also rename this (this is used +-- when loading an interface to merge it into a requirement.) +rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape + -> ModIface -> IO (Either ErrorMessages ModIface) +rnModIface hsc_env insts nsubst iface = do + initRnIface hsc_env iface insts nsubst $ do + mod <- rnModule (mi_module iface) + sig_of <- case mi_sig_of iface of + Nothing -> return Nothing + Just x -> fmap Just (rnModule x) + exports <- mapM rnAvailInfo (mi_exports iface) + decls <- mapM rnIfaceDecl' (mi_decls iface) + insts <- mapM rnIfaceClsInst (mi_insts iface) + fams <- mapM rnIfaceFamInst (mi_fam_insts iface) + deps <- rnDependencies (mi_deps iface) + -- TODO: + -- mi_rules + return iface { mi_module = mod + , mi_sig_of = sig_of + , mi_insts = insts + , mi_fam_insts = fams + , mi_exports = exports + , mi_decls = decls + , mi_deps = deps } + +-- | Rename just the exports of a 'ModIface'. Useful when we're doing +-- shaping prior to signature merging. +rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo]) +rnModExports hsc_env insts iface + = initRnIface hsc_env iface insts Nothing + $ mapM rnAvailInfo (mi_exports iface) + +rnDependencies :: Rename Dependencies +rnDependencies deps = do + orphs <- rnDepModules dep_orphs deps + finsts <- rnDepModules dep_finsts deps + return deps { dep_orphs = orphs, dep_finsts = finsts } + +rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module] +rnDepModules sel deps = do + hsc_env <- getTopEnv + hmap <- getHoleSubst + -- NB: It's not necessary to test if we're doing signature renaming, + -- because ModIface will never contain module reference for itself + -- in these dependencies. + fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do + dflags <- getDynFlags + -- For holes, its necessary to "see through" the instantiation + -- of the hole to get accurate family instance dependencies. + -- For example, if B imports , and is instantiated with + -- F, we must grab and include all of the dep_finsts from + -- F to have an accurate transitive dep_finsts list. + -- + -- However, we MUST NOT do this for regular modules. + -- First, for efficiency reasons, doing this + -- bloats the dep_finsts list, because we *already* had + -- those modules in the list (it wasn't a hole module, after + -- all). But there's a second, more important correctness + -- consideration: we perform module renaming when running + -- --abi-hash. In this case, GHC's contract to the user is that + -- it will NOT go and read out interfaces of any dependencies + -- (https://github.com/haskell/cabal/issues/3633); the point of + -- --abi-hash is just to get a hash of the on-disk interfaces + -- for this *specific* package. If we go off and tug on the + -- interface for /everything/ in dep_finsts, we're gonna have a + -- bad time. (It's safe to do this for hole modules, though, + -- because the hmap for --abi-hash is always trivial, so the + -- interface we request is local. Though, maybe we ought + -- not to do it in this case either...) + -- + -- This mistake was bug #15594. + let mod' = renameHoleModule (unitState dflags) hmap mod + if isHoleModule mod + then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env + $ loadSysInterface (text "rnDepModule") mod' + return (mod' : sel (mi_deps iface)) + else return [mod'] + +{- +************************************************************************ +* * + ModIface substitution +* * +************************************************************************ +-} + +-- | Run a computation in the 'ShIfM' monad. +initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape + -> ShIfM a -> IO (Either ErrorMessages a) +initRnIface hsc_env iface insts nsubst do_this = do + errs_var <- newIORef emptyBag + let dflags = hsc_dflags hsc_env + hsubst = listToUFM insts + rn_mod = renameHoleModule (unitState dflags) hsubst + env = ShIfEnv { + sh_if_module = rn_mod (mi_module iface), + sh_if_semantic_module = rn_mod (mi_semantic_module iface), + sh_if_hole_subst = listToUFM insts, + sh_if_shape = nsubst, + sh_if_errs = errs_var + } + -- Modeled off of 'initTc' + res <- initTcRnIf 'c' hsc_env env () $ tryM do_this + msgs <- readIORef errs_var + case res of + Left _ -> return (Left msgs) + Right r | not (isEmptyBag msgs) -> return (Left msgs) + | otherwise -> return (Right r) + +-- | Environment for 'ShIfM' monads. +data ShIfEnv = ShIfEnv { + -- What we are renaming the ModIface to. It assumed that + -- the original mi_module of the ModIface is + -- @generalizeModule (mi_module iface)@. + sh_if_module :: Module, + -- The semantic module that we are renaming to + sh_if_semantic_module :: Module, + -- Cached hole substitution, e.g. + -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnit . sh_if_module@ + sh_if_hole_subst :: ShHoleSubst, + -- An optional name substitution to be applied when renaming + -- the names in the interface. If this is 'Nothing', then + -- we just load the target interface and look at the export + -- list to determine the renaming. + sh_if_shape :: Maybe NameShape, + -- Mutable reference to keep track of errors (similar to 'tcl_errs') + sh_if_errs :: IORef ErrorMessages + } + +getHoleSubst :: ShIfM ShHoleSubst +getHoleSubst = fmap sh_if_hole_subst getGblEnv + +type ShIfM = TcRnIf ShIfEnv () +type Rename a = a -> ShIfM a + + +rnModule :: Rename Module +rnModule mod = do + hmap <- getHoleSubst + dflags <- getDynFlags + return (renameHoleModule (unitState dflags) hmap mod) + +rnAvailInfo :: Rename AvailInfo +rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n +rnAvailInfo (AvailTC n ns fs) = do + -- Why don't we rnIfaceGlobal the availName itself? It may not + -- actually be exported by the module it putatively is from, in + -- which case we won't be able to tell what the name actually + -- is. But for the availNames they MUST be exported, so they + -- will rename fine. + ns' <- mapM rnIfaceGlobal ns + fs' <- mapM rnFieldLabel fs + case ns' ++ map flSelector fs' of + [] -> panic "rnAvailInfoEmpty AvailInfo" + (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do + n' <- setNameModule (Just (nameModule rep)) n + return (AvailTC n' ns' fs') + +rnFieldLabel :: Rename FieldLabel +rnFieldLabel (FieldLabel l b sel) = do + sel' <- rnIfaceGlobal sel + return (FieldLabel l b sel') + + + + +-- | The key function. This gets called on every Name embedded +-- inside a ModIface. Our job is to take a Name from some +-- generalized unit ID p[A=\, B=\], and change +-- it to the correct name for a (partially) instantiated unit +-- ID, e.g. p[A=q[]:A, B=\]. +-- +-- There are two important things to do: +-- +-- If a hole is substituted with a real module implementation, +-- we need to look at that actual implementation to determine what +-- the true identity of this name should be. We'll do this by +-- loading that module's interface and looking at the mi_exports. +-- +-- However, there is one special exception: when we are loading +-- the interface of a requirement. In this case, we may not have +-- the "implementing" interface, because we are reading this +-- interface precisely to "merge it in". +-- +-- External case: +-- p[A=\]:A (and thisUnitId is something else) +-- We are loading this in order to determine B.hi! So +-- don't load B.hi to find the exports. +-- +-- Local case: +-- p[A=\]:A (and thisUnitId is p[A=\]) +-- This should not happen, because the rename is not necessary +-- in this case, but if it does we shouldn't load A.hi! +-- +-- Compare me with 'tcIfaceGlobal'! + +-- In effect, this function needs compute the name substitution on the +-- fly. What it has is the name that we would like to substitute. +-- If the name is not a hole name {M.x} (e.g. isHoleModule) then +-- no renaming can take place (although the inner hole structure must +-- be updated to account for the hole module renaming.) +rnIfaceGlobal :: Name -> ShIfM Name +rnIfaceGlobal n = do + hsc_env <- getTopEnv + let dflags = hsc_dflags hsc_env + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + mb_nsubst <- fmap sh_if_shape getGblEnv + hmap <- getHoleSubst + let m = nameModule n + m' = renameHoleModule (unitState dflags) hmap m + case () of + -- Did we encounter {A.T} while renaming p[A=]:A? If so, + -- do NOT assume B.hi is available. + -- In this case, rename {A.T} to {B.T} but don't look up exports. + _ | m' == iface_semantic_mod + , isHoleModule m' + -- NB: this could be Nothing for computeExports, we have + -- nothing to say. + -> do n' <- setNameModule (Just m') n + case mb_nsubst of + Nothing -> return n' + Just nsubst -> + case maybeSubstNameShape nsubst n' of + -- TODO: would love to have context + -- TODO: This will give an unpleasant message if n' + -- is a constructor; then we'll suggest adding T + -- but it won't work. + Nothing -> failWithRn $ vcat [ + text "The identifier" <+> ppr (occName n') <+> + text "does not exist in the local signature.", + parens (text "Try adding it to the export list of the hsig file.") + ] + Just n'' -> return n'' + -- Fastpath: we are renaming p[H=]:A.T, in which case the + -- export list is irrelevant. + | not (isHoleModule m) + -> setNameModule (Just m') n + -- The substitution was from to p[]:A. + -- But this does not mean {A.T} goes to p[]:A.T: + -- p[]:A may reexport T from somewhere else. Do the name + -- substitution. Furthermore, we need + -- to make sure we pick the accurate name NOW, + -- or we might accidentally reject a merge. + | otherwise + -> do -- Make sure we look up the local interface if substitution + -- went from to . + let m'' = if isHoleModule m' + -- Pull out the local guy!! + then mkHomeModule dflags (moduleName m') + else m' + iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env + $ loadSysInterface (text "rnIfaceGlobal") m'' + let nsubst = mkNameShape (moduleName m) (mi_exports iface) + case maybeSubstNameShape nsubst n of + Nothing -> failWithRn $ vcat [ + text "The identifier" <+> ppr (occName n) <+> + -- NB: report m' because it's more user-friendly + text "does not exist in the signature for" <+> ppr m', + parens (text "Try adding it to the export list in that hsig file.") + ] + Just n' -> return n' + +-- | Rename an implicit name, e.g., a DFun or coercion axiom. +-- Here is where we ensure that DFuns have the correct module as described in +-- Note [rnIfaceNeverExported]. +rnIfaceNeverExported :: Name -> ShIfM Name +rnIfaceNeverExported name = do + hmap <- getHoleSubst + dflags <- getDynFlags + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + let m = renameHoleModule (unitState dflags) hmap $ nameModule name + -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined. + MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) + setNameModule (Just m) name + +-- Note [rnIfaceNeverExported] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For the high-level overview, see +-- Note [Handling never-exported TyThings under Backpack] +-- +-- When we see a reference to an entity that was defined in a signature, +-- 'rnIfaceGlobal' relies on the identifier in question being part of the +-- exports of the implementing 'ModIface', so that we can use the exports to +-- decide how to rename the identifier. Unfortunately, references to 'DFun's +-- and 'CoAxiom's will run into trouble under this strategy, because they are +-- never exported. +-- +-- Let us consider first what should happen in the absence of promotion. In +-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside +-- the signature *that is defining it* (as there are no Core terms in +-- typechecked-only interface files, there's no way for a reference to occur +-- besides from the defining 'ClsInst' or closed type family). Thus, +-- it doesn't really matter what names we give the DFun/CoAxiom, as long +-- as it's consistent between the declaration site and the use site. +-- +-- We have to make sure that these bogus names don't get propagated, +-- but it is fine: see Note [Signature merging DFuns] for the fixups +-- to the names we do before writing out the merged interface. +-- (It's even easier for instantiation, since the DFuns all get +-- dropped entirely; the instances are reexported implicitly.) +-- +-- Unfortunately, this strategy is not enough in the presence of promotion +-- (see bug #13149), where modules which import the signature may make +-- reference to their coercions. It's not altogether clear how to +-- fix this case, but it is definitely a bug! + +-- PILES AND PILES OF BOILERPLATE + +-- | Rename an 'IfaceClsInst', with special handling for an associated +-- dictionary function. +rnIfaceClsInst :: Rename IfaceClsInst +rnIfaceClsInst cls_inst = do + n <- rnIfaceGlobal (ifInstCls cls_inst) + tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst) + + dfun <- rnIfaceNeverExported (ifDFun cls_inst) + return cls_inst { ifInstCls = n + , ifInstTys = tys + , ifDFun = dfun + } + +rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon) +rnMaybeIfaceTyCon Nothing = return Nothing +rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc + +rnIfaceFamInst :: Rename IfaceFamInst +rnIfaceFamInst d = do + fam <- rnIfaceGlobal (ifFamInstFam d) + tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d) + axiom <- rnIfaceGlobal (ifFamInstAxiom d) + return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } + +rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl) +rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl + +rnIfaceDecl :: Rename IfaceDecl +rnIfaceDecl d@IfaceId{} = do + name <- case ifIdDetails d of + IfDFunId -> rnIfaceNeverExported (ifName d) + _ | isDefaultMethodOcc (occName (ifName d)) + -> rnIfaceNeverExported (ifName d) + -- Typeable bindings. See Note [Grand plan for Typeable]. + _ | isTypeableBindOcc (occName (ifName d)) + -> rnIfaceNeverExported (ifName d) + | otherwise -> rnIfaceGlobal (ifName d) + ty <- rnIfaceType (ifType d) + details <- rnIfaceIdDetails (ifIdDetails d) + info <- rnIfaceIdInfo (ifIdInfo d) + return d { ifName = name + , ifType = ty + , ifIdDetails = details + , ifIdInfo = info + } +rnIfaceDecl d@IfaceData{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + ctxt <- mapM rnIfaceType (ifCtxt d) + cons <- rnIfaceConDecls (ifCons d) + res_kind <- rnIfaceType (ifResKind d) + parent <- rnIfaceTyConParent (ifParent d) + return d { ifName = name + , ifBinders = binders + , ifCtxt = ctxt + , ifCons = cons + , ifResKind = res_kind + , ifParent = parent + } +rnIfaceDecl d@IfaceSynonym{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + syn_kind <- rnIfaceType (ifResKind d) + syn_rhs <- rnIfaceType (ifSynRhs d) + return d { ifName = name + , ifBinders = binders + , ifResKind = syn_kind + , ifSynRhs = syn_rhs + } +rnIfaceDecl d@IfaceFamily{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + fam_kind <- rnIfaceType (ifResKind d) + fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) + return d { ifName = name + , ifBinders = binders + , ifResKind = fam_kind + , ifFamFlav = fam_flav + } +rnIfaceDecl d@IfaceClass{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + body <- rnIfaceClassBody (ifBody d) + return d { ifName = name + , ifBinders = binders + , ifBody = body + } +rnIfaceDecl d@IfaceAxiom{} = do + name <- rnIfaceNeverExported (ifName d) + tycon <- rnIfaceTyCon (ifTyCon d) + ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) + return d { ifName = name + , ifTyCon = tycon + , ifAxBranches = ax_branches + } +rnIfaceDecl d@IfacePatSyn{} = do + name <- rnIfaceGlobal (ifName d) + let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b + pat_matcher <- rnPat (ifPatMatcher d) + pat_builder <- T.traverse rnPat (ifPatBuilder d) + pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d) + pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d) + pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d) + pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d) + pat_args <- mapM rnIfaceType (ifPatArgs d) + pat_ty <- rnIfaceType (ifPatTy d) + return d { ifName = name + , ifPatMatcher = pat_matcher + , ifPatBuilder = pat_builder + , ifPatUnivBndrs = pat_univ_bndrs + , ifPatExBndrs = pat_ex_bndrs + , ifPatProvCtxt = pat_prov_ctxt + , ifPatReqCtxt = pat_req_ctxt + , ifPatArgs = pat_args + , ifPatTy = pat_ty + } + +rnIfaceClassBody :: Rename IfaceClassBody +rnIfaceClassBody IfAbstractClass = return IfAbstractClass +rnIfaceClassBody d@IfConcreteClass{} = do + ctxt <- mapM rnIfaceType (ifClassCtxt d) + ats <- mapM rnIfaceAT (ifATs d) + sigs <- mapM rnIfaceClassOp (ifSigs d) + return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs } + +rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav +rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) + = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n + <*> mapM rnIfaceAxBranch axs) +rnIfaceFamTyConFlav flav = pure flav + +rnIfaceAT :: Rename IfaceAT +rnIfaceAT (IfaceAT decl mb_ty) + = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty + +rnIfaceTyConParent :: Rename IfaceTyConParent +rnIfaceTyConParent (IfDataInstance n tc args) + = IfDataInstance <$> rnIfaceGlobal n + <*> rnIfaceTyCon tc + <*> rnIfaceAppArgs args +rnIfaceTyConParent IfNoParent = pure IfNoParent + +rnIfaceConDecls :: Rename IfaceConDecls +rnIfaceConDecls (IfDataTyCon ds) + = IfDataTyCon <$> mapM rnIfaceConDecl ds +rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d +rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon + +rnIfaceConDecl :: Rename IfaceConDecl +rnIfaceConDecl d = do + con_name <- rnIfaceGlobal (ifConName d) + con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d) + con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d) + let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t + con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) + con_ctxt <- mapM rnIfaceType (ifConCtxt d) + con_arg_tys <- mapM rnIfaceScaledType (ifConArgTys d) + con_fields <- mapM rnFieldLabel (ifConFields d) + let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co + rnIfaceBang bang = pure bang + con_stricts <- mapM rnIfaceBang (ifConStricts d) + return d { ifConName = con_name + , ifConExTCvs = con_ex_tvs + , ifConUserTvBinders = con_user_tvbs + , ifConEqSpec = con_eq_spec + , ifConCtxt = con_ctxt + , ifConArgTys = con_arg_tys + , ifConFields = con_fields + , ifConStricts = con_stricts + } + +rnIfaceClassOp :: Rename IfaceClassOp +rnIfaceClassOp (IfaceClassOp n ty dm) = + IfaceClassOp <$> rnIfaceGlobal n + <*> rnIfaceType ty + <*> rnMaybeDefMethSpec dm + +rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType)) +rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty +rnMaybeDefMethSpec mb = return mb + +rnIfaceAxBranch :: Rename IfaceAxBranch +rnIfaceAxBranch d = do + ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d) + lhs <- rnIfaceAppArgs (ifaxbLHS d) + rhs <- rnIfaceType (ifaxbRHS d) + return d { ifaxbTyVars = ty_vars + , ifaxbLHS = lhs + , ifaxbRHS = rhs } + +rnIfaceIdInfo :: Rename IfaceIdInfo +rnIfaceIdInfo = mapM rnIfaceInfoItem + +rnIfaceInfoItem :: Rename IfaceInfoItem +rnIfaceInfoItem (HsUnfold lb if_unf) + = HsUnfold lb <$> rnIfaceUnfolding if_unf +rnIfaceInfoItem i + = pure i + +rnIfaceUnfolding :: Rename IfaceUnfolding +rnIfaceUnfolding (IfCoreUnfold stable if_expr) + = IfCoreUnfold stable <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfCompulsory if_expr) + = IfCompulsory <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr) + = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfDFunUnfold bs ops) + = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops + +rnIfaceExpr :: Rename IfaceExpr +rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name) +rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl +rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty +rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co +rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args +rnIfaceExpr (IfaceLam lam_bndr expr) + = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr +rnIfaceExpr (IfaceApp fun arg) + = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg +rnIfaceExpr (IfaceCase scrut case_bndr alts) + = IfaceCase <$> rnIfaceExpr scrut + <*> pure case_bndr + <*> mapM rnIfaceAlt alts +rnIfaceExpr (IfaceECase scrut ty) + = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty +rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceLet (IfaceRec pairs) body) + = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) -> + (,) <$> rnIfaceLetBndr bndr + <*> rnIfaceExpr rhs) pairs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceCast expr co) + = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co +rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) +rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty +rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr + +rnIfaceBndrs :: Rename [IfaceBndr] +rnIfaceBndrs = mapM rnIfaceBndr + +rnIfaceBndr :: Rename IfaceBndr +rnIfaceBndr (IfaceIdBndr (w, fs, ty)) = IfaceIdBndr <$> ((,,) w fs <$> rnIfaceType ty) +rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr + +rnIfaceTvBndr :: Rename IfaceTvBndr +rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind + +rnIfaceTyConBinder :: Rename IfaceTyConBinder +rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis + +rnIfaceAlt :: Rename IfaceAlt +rnIfaceAlt (conalt, names, rhs) + = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs + +rnIfaceConAlt :: Rename IfaceConAlt +rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ +rnIfaceConAlt alt = pure alt + +rnIfaceLetBndr :: Rename IfaceLetBndr +rnIfaceLetBndr (IfLetBndr fs ty info jpi) + = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi + +rnIfaceLamBndr :: Rename IfaceLamBndr +rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot + +rnIfaceMCo :: Rename IfaceMCoercion +rnIfaceMCo IfaceMRefl = pure IfaceMRefl +rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co + +rnIfaceCo :: Rename IfaceCoercion +rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty +rnIfaceCo (IfaceGReflCo role ty mco) + = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco +rnIfaceCo (IfaceFunCo role w co1 co2) + = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceTyConAppCo role tc cos) + = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos +rnIfaceCo (IfaceAppCo co1 co2) + = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceForAllCo bndr co1 co2) + = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c) +rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl +rnIfaceCo (IfaceHoleCo lcl) = IfaceHoleCo <$> pure lcl +rnIfaceCo (IfaceAxiomInstCo n i cs) + = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs +rnIfaceCo (IfaceUnivCo s r t1 t2) + = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceCo (IfaceSymCo c) + = IfaceSymCo <$> rnIfaceCo c +rnIfaceCo (IfaceTransCo c1 c2) + = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceInstCo c1 c2) + = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c +rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c +rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c +rnIfaceCo (IfaceAxiomRuleCo ax cos) + = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos +rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c + +rnIfaceTyCon :: Rename IfaceTyCon +rnIfaceTyCon (IfaceTyCon n info) + = IfaceTyCon <$> rnIfaceGlobal n <*> pure info + +rnIfaceExprs :: Rename [IfaceExpr] +rnIfaceExprs = mapM rnIfaceExpr + +rnIfaceIdDetails :: Rename IfaceIdDetails +rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b +rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b +rnIfaceIdDetails details = pure details + +rnIfaceType :: Rename IfaceType +rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) +rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) +rnIfaceType (IfaceAppTy t1 t2) + = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 +rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) +rnIfaceType (IfaceFunTy af w t1 t2) + = IfaceFunTy af <$> rnIfaceType w <*> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceTupleTy s i tks) + = IfaceTupleTy s i <$> rnIfaceAppArgs tks +rnIfaceType (IfaceTyConApp tc tks) + = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks +rnIfaceType (IfaceForAllTy tv t) + = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t +rnIfaceType (IfaceCoercionTy co) + = IfaceCoercionTy <$> rnIfaceCo co +rnIfaceType (IfaceCastTy ty co) + = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co + +rnIfaceScaledType :: Rename (IfaceMult, IfaceType) +rnIfaceScaledType (m, t) = (,) <$> rnIfaceType m <*> rnIfaceType t + +rnIfaceForAllBndr :: Rename (VarBndr IfaceBndr flag) +rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis + +rnIfaceAppArgs :: Rename IfaceAppArgs +rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a + <*> rnIfaceAppArgs ts +rnIfaceAppArgs IA_Nil = pure IA_Nil diff --git a/GHC/Iface/Syntax.hs b/GHC/Iface/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Syntax.hs @@ -0,0 +1,2654 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Iface.Syntax ( + module GHC.Iface.Type, + + IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, + IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceClassBody(..), + IfaceBang(..), + IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), + IfaceAxBranch(..), + IfaceTyConParent(..), + IfaceCompleteMatch(..), + IfaceLFInfo(..), + + -- * Binding names + IfaceTopBndr, + putIfaceTopBndr, getIfaceTopBndr, + + -- Misc + ifaceDeclImplicitBndrs, visibleIfConDecls, + ifaceDeclFingerprints, + + -- Free Names + freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, + + -- Pretty printing + pprIfaceExpr, + pprIfaceDecl, + AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey ) +import GHC.Types.Unique ( hasKey ) +import GHC.Iface.Type +import GHC.Iface.Recomp.Binary +import GHC.Core( IsOrphan, isOrphan ) +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core.Class +import GHC.Types.FieldLabel +import GHC.Types.Name.Set +import GHC.Core.Coercion.Axiom ( BranchIndex ) +import GHC.Types.Name +import GHC.Types.CostCentre +import GHC.Types.Literal +import GHC.Types.ForeignCall +import GHC.Types.Annotations( AnnPayload, AnnTarget ) +import GHC.Types.Basic +import GHC.Utils.Outputable as Outputable +import GHC.Unit.Module +import GHC.Types.SrcLoc +import GHC.Utils.Fingerprint +import GHC.Utils.Binary +import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) +import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders ) +import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) +import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn, + seqList, zipWithEqual ) +import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) +import GHC.Utils.Lexeme (isLexSym) +import GHC.Builtin.Types ( constraintKindTyConName ) + +import Control.Monad +import System.IO.Unsafe +import Control.DeepSeq + +infixl 3 &&& + +{- +************************************************************************ +* * + Declarations +* * +************************************************************************ +-} + +-- | A binding top-level 'Name' in an interface file (e.g. the name of an +-- 'IfaceDecl'). +type IfaceTopBndr = Name + -- It's convenient to have a Name in the Iface syntax, although in each + -- case the namespace is implied by the context. However, having a + -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. Moreover, having the key of the binder means that + -- we can encode known-key things cleverly in the symbol table. See Note + -- [Symbol table representation of Names] + -- + -- We don't serialise the namespace onto the disk though; rather we + -- drop it when serialising and add it back in when deserialising. + +getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr +getIfaceTopBndr bh = get bh + +putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () +putIfaceTopBndr bh name = + case getUserData bh of + UserData{ ud_put_binding_name = put_binding_name } -> + --pprTrace "putIfaceTopBndr" (ppr name) $ + put_binding_name bh name + +data IfaceDecl + = IfaceId { ifName :: IfaceTopBndr, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo + } + + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceType, -- Result kind of type constructor + ifCType :: Maybe CType, -- C type for CAPI FFI + ifRoles :: [Role], -- Roles + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data/data family info + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance + } + + | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *result* + ifSynRhs :: IfaceType } + + | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor + ifResVar :: Maybe IfLclName, -- Result variable name, used + -- only for pretty-printing + -- with --show-iface + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *tycon* + ifFamFlav :: IfaceFamTyConFlav, + ifFamInj :: Injectivity } -- injectivity information + + | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifFDs :: [FunDep IfLclName], -- Functional dependencies + ifBody :: IfaceClassBody -- Methods, superclasses, ATs + } + + | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name + ifTyCon :: IfaceTyCon, -- LHS TyCon + ifRole :: Role, -- Role of axiom + ifAxBranches :: [IfaceAxBranch] -- Branches + } + + | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym + ifPatIsInfix :: Bool, + ifPatMatcher :: (IfExtName, Bool), + ifPatBuilder :: Maybe (IfExtName, Bool), + -- Everything below is redundant, + -- but needed to implement pprIfaceDecl + ifPatUnivBndrs :: [IfaceForAllSpecBndr], + ifPatExBndrs :: [IfaceForAllSpecBndr], + ifPatProvCtxt :: IfaceContext, + ifPatReqCtxt :: IfaceContext, + ifPatArgs :: [IfaceType], + ifPatTy :: IfaceType, + ifFieldLabels :: [FieldLabel] } + +-- See also 'ClassBody' +data IfaceClassBody + -- Abstract classes don't specify their body; they only occur in @hs-boot@ and + -- @hsig@ files. + = IfAbstractClass + | IfConcreteClass { + ifClassCtxt :: IfaceContext, -- Super classes + ifATs :: [IfaceAT], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition + } + +data IfaceTyConParent + = IfNoParent + | IfDataInstance + IfExtName -- Axiom name + IfaceTyCon -- Family TyCon (pretty-printing only, not used in GHC.IfaceToCore) + -- see Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing + IfaceAppArgs -- Arguments of the family TyCon + +data IfaceFamTyConFlav + = IfaceDataFamilyTyCon -- Data family + | IfaceOpenSynFamilyTyCon + | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) + -- ^ Name of associated axiom and branches for pretty printing purposes, + -- or 'Nothing' for an empty closed family without an axiom + -- See Note [Pretty printing via Iface syntax] in "GHC.Core.Ppr.TyThing" + | IfaceAbstractClosedSynFamilyTyCon + | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only + +data IfaceClassOp + = IfaceClassOp IfaceTopBndr + IfaceType -- Class op type + (Maybe (DefMethSpec IfaceType)) -- Default method + -- The types of both the class op itself, + -- and the default method, are *not* quantified + -- over the class variables + +data IfaceAT = IfaceAT -- See GHC.Core.Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any + + +-- This is just like CoAxBranch +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbEtaTyVars :: [IfaceTvBndr] + , ifaxbCoVars :: [IfaceIdBndr] + , ifaxbLHS :: IfaceAppArgs + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } + -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom + +data IfaceConDecls + = IfAbstractTyCon -- c.f TyCon.AbstractTyCon + | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfNewTyCon IfaceConDecl -- Newtype decls + +-- For IfDataTyCon and IfNewTyCon we store: +-- * the data constructor(s); +-- The field labels are stored individually in the IfaceConDecl +-- (there is some redundancy here, because a field label may occur +-- in multiple IfaceConDecls and represent the same field label) + +data IfaceConDecl + = IfCon { + ifConName :: IfaceTopBndr, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + + -- The universal type variables are precisely those + -- of the type constructor of this data constructor + -- This is *easy* to guarantee when creating the IfCon + -- but it's not so easy for the original TyCon/DataCon + -- So this guarantee holds for IfaceConDecl, but *not* for DataCon + + ifConExTCvs :: [IfaceBndr], -- Existential ty/covars + ifConUserTvBinders :: [IfaceForAllSpecBndr], + -- The tyvars, in the order the user wrote them + -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the + -- set of tyvars (*not* covars) of ifConExTCvs, unioned + -- with the set of ifBinders (from the parent IfaceDecl) + -- whose tyvars do not appear in ifConEqSpec + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + ifConEqSpec :: IfaceEqSpec, -- Equality constraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [(IfaceMult, IfaceType)],-- Arg types + ifConFields :: [FieldLabel], -- ...ditto... (field labels) + ifConStricts :: [IfaceBang], + -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts + +type IfaceEqSpec = [(IfLclName,IfaceType)] + +-- | This corresponds to an HsImplBang; that is, the final +-- implementation decision about the data constructor arg +data IfaceBang + = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion + +-- | This corresponds to HsSrcBang +data IfaceSrcBang + = IfSrcBang SrcUnpackedness SrcStrictness + +data IfaceClsInst + = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: IsOrphan } -- See Note [Orphans] in GHC.Core.InstEnv + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before + +-- The ifFamInstTys field of IfaceFamInst contains a list of the rough +-- match types +data IfaceFamInst + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name + , ifFamInstTys :: [Maybe IfaceTyCon] -- See above + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceRule + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + ifRuleOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceAnnotation + = IfaceAnnotation { + ifAnnotatedTarget :: IfaceAnnTarget, + ifAnnotatedValue :: AnnPayload + } + +type IfaceAnnTarget = AnnTarget OccName + +data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName + +instance Outputable IfaceCompleteMatch where + ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls + <+> dcolon <+> ppr ty + + + + +-- Here's a tricky case: +-- * Compile with -O module A, and B which imports A.f +-- * Change function f in A, and recompile without -O +-- * When we read in old A.hi we read in its IdInfo (as a thunk) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) +-- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) +-- and so gives a new version. + +type IfaceIdInfo = [IfaceInfoItem] + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsCpr CprSig + | HsInline InlinePragma + | HsUnfold Bool -- True <=> isStrongLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] + | HsNoCafRefs + | HsLevity -- Present <=> never levity polymorphic + | HsLFInfo IfaceLFInfo + +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +data IfaceUnfolding + = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding + -- Possibly could eliminate the Bool here, the information + -- is also in the InlinePragma. + + | IfCompulsory IfaceExpr -- default methods and unsafeCoerce# + -- for more about unsafeCoerce#, see + -- Note [Wiring in unsafeCoerce#] in "GHC.HsToCore" + + | IfInlineRule Arity -- INLINE pragmas + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr + + | IfDFunUnfold [IfaceBndr] [IfaceExpr] + + +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, because they are not put it +-- interface files + +data IfaceIdDetails + = IfVanillaId + | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool + | IfDFunId + +-- | Iface type for LambdaFormInfo. Fields not relevant for imported Ids are +-- omitted in this type. +data IfaceLFInfo + = IfLFReEntrant !RepArity + | IfLFThunk + !Bool -- True <=> updatable + !Bool -- True <=> might be a function type + | IfLFCon !Name + | IfLFUnknown !Bool + | IfLFUnlifted + +instance Outputable IfaceLFInfo where + ppr (IfLFReEntrant arity) = + text "LFReEntrant" <+> ppr arity + + ppr (IfLFThunk updatable mb_fun) = + text "LFThunk" <+> parens + (text "updatable=" <> ppr updatable <+> + text "might_be_function=" <+> ppr mb_fun) + + ppr (IfLFCon con) = + text "LFCon" <> brackets (ppr con) + + ppr IfLFUnlifted = + text "LFUnlifted" + + ppr (IfLFUnknown fun_flag) = + text "LFUnknown" <+> ppr fun_flag + +instance Binary IfaceLFInfo where + put_ bh (IfLFReEntrant arity) = do + putByte bh 0 + put_ bh arity + put_ bh (IfLFThunk updatable mb_fun) = do + putByte bh 1 + put_ bh updatable + put_ bh mb_fun + put_ bh (IfLFCon con_name) = do + putByte bh 2 + put_ bh con_name + put_ bh (IfLFUnknown fun_flag) = do + putByte bh 3 + put_ bh fun_flag + put_ bh IfLFUnlifted = + putByte bh 4 + get bh = do + tag <- getByte bh + case tag of + 0 -> IfLFReEntrant <$> get bh + 1 -> IfLFThunk <$> get bh <*> get bh + 2 -> IfLFCon <$> get bh + 3 -> IfLFUnknown <$> get bh + 4 -> pure IfLFUnlifted + _ -> panic "Invalid byte" + +{- +Note [Versioning of instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See [https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#instances] + + +************************************************************************ +* * + Functions over declarations +* * +************************************************************************ +-} + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + +ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- Deeply revolting, because it has to predict what gets bound, +-- especially the question of whether there's a wrapper for a datacon +-- See Note [Implicit TyThings] in GHC.Driver.Types + +-- N.B. the set of names returned here *must* match the set of +-- TyThings returned by GHC.Driver.Types.implicitTyThings, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in GHC.Iface.Load.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. + +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) + = case cons of + IfAbstractTyCon -> [] + IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd + IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds + +ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) + = [] + +ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name + , ifBody = IfConcreteClass { + ifClassCtxt = sc_ctxt, + ifSigs = sigs, + ifATs = ats + }}) + = -- (possibly) newtype coercion + co_occs ++ + -- data constructor (DataCon namespace) + -- data worker (Id namespace) + -- no wrapper (class dictionaries never have a wrapper) + [dc_occ, dcww_occ] ++ + -- associated types + [occName (ifName at) | IfaceAT at _ <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [occName op | IfaceClassOp op _ _ <- sigs] + where + cls_tc_occ = occName cls_tc_name + n_ctxt = length sc_ctxt + n_sigs = length sigs + co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] + | otherwise = [] + dcww_occ = mkDataConWorkerOcc dc_occ + dc_occ = mkClassDataConOcc cls_tc_occ + is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) + +ifaceDeclImplicitBndrs _ = [] + +ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] +ifaceConDeclImplicitBndrs (IfCon { + ifConWrapper = has_wrapper, ifConName = con_name }) + = [occName con_name, work_occ] ++ wrap_occs + where + con_occ = occName con_name + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- The fingerprints of an IfaceDecl + + -- We better give each name bound by the declaration a + -- different fingerprint! So we calculate the fingerprint of + -- each binder by combining the fingerprint of the whole + -- declaration with the name of the binder. (#5614, #7215) +ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] +ifaceDeclFingerprints hash decl + = (getOccName decl, hash) : + [ (occ, computeFingerprint' (hash,occ)) + | occ <- ifaceDeclImplicitBndrs decl ] + where + computeFingerprint' = + unsafeDupablePerformIO + . computeFingerprint (panic "ifaceDeclFingerprints") + +{- +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +data IfaceExpr + = IfaceLcl IfLclName + | IfaceExt IfExtName + | IfaceType IfaceType + | IfaceCo IfaceCoercion + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceLamBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] + | IfaceLet IfaceBinding IfaceExpr + | IfaceCast IfaceExpr IfaceCoercion + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + +data IfaceTickish + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + | IfaceSource RealSrcSpan String -- from SourceNote + -- no breakpoints: we never export these into interface files + +type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files + +data IfaceConAlt = IfaceDefault + | IfaceDataAlt IfExtName + | IfaceLitAlt Literal + +data IfaceBinding + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo + +data IfaceJoinInfo = IfaceNotJoinPoint + | IfaceJoinPoint JoinArity + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Iface syntax an IfaceCase does not record the types of the alternatives, +unlike Core syntax Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in GHC.Core. + +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings. The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. + +In general we retain all info that is left by GHC.Core.Tidy.tidyLetBndr, since +that is what is seen by importing module with --make + +Note [Displaying axiom incompatibilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -fprint-axiom-incomps we display which closed type family equations +are incompatible with which. This information is sometimes necessary +because GHC doesn't try equations in order: any equation can be used when +all preceding equations that are incompatible with it do not apply. + +For example, the last "a && a = a" equation in Data.Type.Bool.&& is +actually compatible with all previous equations, and can reduce at any +time. + +This is displayed as: +Prelude> :i Data.Type.Equality.== +type family (==) (a :: k) (b :: k) :: Bool + where + {- #0 -} (==) (f a) (g b) = (f == g) && (a == b) + {- #1 -} (==) a a = 'True + -- incompatible with: #0 + {- #2 -} (==) _1 _2 = 'False + -- incompatible with: #1, #0 +The comment after an equation refers to all previous equations (0-indexed) +that are incompatible with it. + +************************************************************************ +* * + Printing IfaceDecl +* * +************************************************************************ +-} + +pprAxBranch :: SDoc -> BranchIndex -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +-- +-- This function is used +-- to print interface files, +-- in debug messages +-- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon +-- For user error messages we use Coercion.pprCoAxiom and friends +pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbCoVars = _cvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = ASSERT2( null _cvs, pp_tc $$ ppr _cvs ) + hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ + nest 4 maybe_incomps + where + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + ppr_binders = maybe_index <+> + pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) + pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) + + -- See Note [Displaying axiom incompatibilities] + maybe_index + = ppWhenOption sdocPrintAxiomIncomps $ + text "{-" <+> (text "#" <> ppr idx) <+> text "-}" + maybe_incomps + = ppWhenOption sdocPrintAxiomIncomps $ + ppWhen (notNull incomps) $ + text "--" <+> text "incompatible with:" + <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps + +instance Outputable IfaceAnnotation where + ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value + +instance NamedThing IfaceClassOp where + getName (IfaceClassOp n _ _) = n + +instance HasOccName IfaceClassOp where + occName = getOccName + +instance NamedThing IfaceConDecl where + getName = ifConName + +instance HasOccName IfaceConDecl where + occName = getOccName + +instance NamedThing IfaceDecl where + getName = ifName + +instance HasOccName IfaceDecl where + occName = getOccName + +instance Outputable IfaceDecl where + ppr = pprIfaceDecl showToIface + +{- +Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The minimal complete definition should only be included if a complete +class definition is shown. Since the minimal complete definition is +anonymous we can't reuse the same mechanism that is used for the +filtering of method signatures. Instead we just check if anything at all is +filtered and hide it in that case. +-} + +data ShowSub + = ShowSub + { ss_how_much :: ShowHowMuch + , ss_forall :: ShowForAllFlag } + +-- See Note [Printing IfaceDecl binders] +-- The alternative pretty printer referred to in the note. +newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) + +data ShowHowMuch + = ShowHeader AltPpr -- ^Header information only, not rhs + | ShowSome [OccName] AltPpr + -- ^ Show only some sub-components. Specifically, + -- + -- [@\[\]@] Print all sub-components. + -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; + -- elide other sub-components to @...@ + -- May 14: the list is max 1 element long at the moment + | ShowIface + -- ^Everything including GHC-internal information (used in --show-iface) + +{- +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see GHC.Core.Ppr.TyThing), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. + +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. +-} + +instance Outputable ShowHowMuch where + ppr (ShowHeader _) = text "ShowHeader" + ppr ShowIface = text "ShowIface" + ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs + +showToHeader :: ShowSub +showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing + , ss_forall = ShowForAllWhen } + +showToIface :: ShowSub +showToIface = ShowSub { ss_how_much = ShowIface + , ss_forall = ShowForAllWhen } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = Outputable.empty + +-- show if all sub-components or the complete interface is shown +ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] +ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc +ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowAllSubs _ _ = Outputable.empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing +showSub (ShowSub { ss_how_much = _ }) _ = True + +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) + where + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, text "..." : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc +pprClassRoles ss clas binders roles = + pprRoles (== Nominal) + (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) + binders + roles + +pprClassStandaloneKindSig :: ShowSub -> IfaceTopBndr -> IfaceKind -> SDoc +pprClassStandaloneKindSig ss clas = + pprStandaloneKindSig (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) + +constraintIfaceKind :: IfaceKind +constraintIfaceKind = + IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi +-- See Note [Pretty-printing TyThings] in GHC.Core.Ppr.TyThing +pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifResKind = kind, + ifRoles = roles, ifCons = condecls, + ifParent = parent, + ifGadtSyntax = gadt, + ifBinders = binders }) + + | gadt = vcat [ pp_roles + , pp_ki_sig + , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , pp_ki_sig + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + pp_data_inst_forall :: SDoc + pp_data_inst_forall = pprUserIfaceForAll forall_bndrs + + forall_bndrs :: [IfaceForAllBndr] + forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] + + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt && not (null cons)) $ text "where" + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + pp_kind = ppUnless (if ki_sig_printable + then isIfaceTauType kind + -- Even in the presence of a standalone kind signature, a non-tau + -- result kind annotation cannot be discarded as it determines the arity. + -- See Note [Arity inference in kcCheckDeclHeader_sig] in GHC.Tc.Gen.HsType + else isIfaceLiftedTypeKind kind) + (dcolon <+> ppr kind) + + pp_lhs = case parent of + IfNoParent -> pprIfaceDeclHead suppress_bndr_sig context ss tycon binders + IfDataInstance{} + -> text "instance" <+> pp_data_inst_forall + <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) name_doc binders roles + -- Don't display roles for data family instances (yet) + -- See discussion on #8672. + + ki_sig_printable = + -- If we print a standalone kind signature for a data instance, we leak + -- the internal constructor name: + -- + -- type T15827.R:Dka :: forall k. k -> * + -- data instance forall k (a :: k). D a = MkD (Proxy a) + -- + -- This T15827.R:Dka is a compiler-generated type constructor for the + -- data instance. + not is_data_instance + + pp_ki_sig = ppWhen ki_sig_printable $ + pprStandaloneKindSig name_doc (mkIfaceTyConKind binders kind) + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig ki_sig_printable + + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) + + add_bars [] = Outputable.empty + add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc + | otherwise = Nothing + + pp_nd = case condecls of + IfAbstractTyCon{} -> text "data" + IfDataTyCon{} -> text "data" + IfNewTyCon{} -> text "newtype" + + pp_extra = vcat [pprCType ctype] + +pprIfaceDecl ss (IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfAbstractClass }) + = vcat [ pprClassRoles ss clas binders roles + , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) + , text "class" <+> pprIfaceDeclHead suppress_bndr_sig [] ss clas binders <+> pprFundeps fds ] + where + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss (IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfConcreteClass { + ifATs = ats, + ifSigs = sigs, + ifClassCtxt = context, + ifMinDef = minDef + }}) + = vcat [ pprClassRoles ss clas binders roles + , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) + , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [ vcat asocs, vcat dsigs + , ppShowAllSubs ss (pprMinDef minDef)])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + + pprMinDef :: BooleanFormula IfLclName -> SDoc + pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions + text "{-# MINIMAL" <+> + pprBooleanFormula + (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> + text "#-}" + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss (IfaceSynonym { ifName = tc + , ifBinders = binders + , ifSynRhs = mono_ty + , ifResKind = res_kind}) + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals) + 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau + , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) + ] + where + (tvs, theta, tau) = splitIfaceSigmaTy mono_ty + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) + + -- See Note [Printing type abbreviations] in GHC.Iface.Type + ppr_tau | tc `hasKey` liftedTypeKindTyConKey || + tc `hasKey` unrestrictedFunTyConKey + = updSDocContext (\ctx -> ctx { sdocPrintTypeAbbreviations = False }) $ ppr tau + | otherwise = ppr tau + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss (IfaceFamily { ifName = tycon + , ifFamFlav = rhs, ifBinders = binders + , ifResKind = res_kind + , ifResVar = res_var, ifFamInj = inj }) + | IfaceDataFamilyTyCon <- rhs + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , text "data family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders + ] + + | otherwise + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , hang (text "type family" + <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders + <+> ppShowRhs ss (pp_where rhs)) + 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) + $$ + nest 2 (ppShowRhs ss (pp_branches rhs)) + ] + where + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) + + pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" + pp_where _ = empty + + pp_inj Nothing _ = empty + pp_inj (Just res) inj + | Injective injectivity <- inj = hsep [ equals, ppr res + , pp_inj_cond res injectivity] + | otherwise = hsep [ equals, ppr res ] + + pp_inj_cond res inj = case filterByList inj binders of + [] -> empty + tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] + + pp_rhs IfaceDataFamilyTyCon + = ppShowIface ss (text "data") + pp_rhs IfaceOpenSynFamilyTyCon + = ppShowIface ss (text "open") + pp_rhs IfaceAbstractClosedSynFamilyTyCon + = ppShowIface ss (text "closed, abstract") + pp_rhs (IfaceClosedSynFamilyTyCon {}) + = empty -- see pp_branches + pp_rhs IfaceBuiltInSynFamTyCon + = ppShowIface ss (text "built-in") + + pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) + = vcat (unzipWith (pprAxBranch + (pprPrefixIfDeclBndr + (ss_how_much ss) + (occName tycon)) + ) $ zip [0..] brs) + $$ ppShowIface ss (text "axiom" <+> ppr ax) + pp_branches _ = Outputable.empty + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl _ (IfacePatSyn { ifName = name, + ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = arg_tys, + ifPatTy = pat_ty} ) + = sdocWithContext mk_msg + where + mk_msg sdocCtx + = hang (text "pattern" <+> pprPrefixOcc name) + 2 (dcolon <+> sep [univ_msg + , pprIfaceContextArr req_ctxt + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , ex_msg + , pprIfaceContextArr prov_ctxt + , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ]) + where + univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs + ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs + + insert_empty_ctxt = null req_ctxt + && not (null prov_ctxt && isEmpty sdocCtx ex_msg) + +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) + 2 (pprIfaceSigmaType (ss_forall ss) ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info) ] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (text "axiom" <+> ppr name <+> dcolon) + 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) + +pprCType :: Maybe CType -> SDoc +pprCType Nothing = Outputable.empty +pprCType (Just cType) = text "C type:" <+> ppr cType + +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] + -> [Role] -> SDoc +pprRoles suppress_if tyCon bndrs roles + = sdocOption sdocPrintExplicitKinds $ \print_kinds -> + let froles = suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs roles + in ppUnless (all suppress_if froles || null froles) $ + text "type role" <+> tyCon <+> hsep (map ppr froles) + +pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc +pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty + +pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = pprInfixVar (isSymOcc name) (ppr_bndr name) +pprInfixIfDeclBndr _ name + = pprInfixVar (isSymOcc name) (ppr name) + +pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr _ name + = parenSymOcc name (ppr name) + +instance Outputable IfaceClassOp where + ppr = pprIfaceClassOp showToIface + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n ty dm) + = pp_sig n ty $$ generic_dm + where + generic_dm | Just (GenericDM dm_ty) <- dm + = text "default" <+> pp_sig n dm_ty + | otherwise + = empty + pp_sig n ty + = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) + <+> dcolon + <+> pprIfaceSigmaType ShowForAllWhen ty + +instance Outputable IfaceAT where + ppr = pprIfaceAT showToIface + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d mb_def) + = vcat [ pprIfaceDecl ss d + , case mb_def of + Nothing -> Outputable.empty + Just rhs -> nest 2 $ + text "Default:" <+> ppr rhs ] + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = Outputable.empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = pprIfaceTypeApp topPrec tc tys + +pprIfaceDeclHead :: SuppressBndrSig + -> IfaceContext -> ShowSub -> Name + -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression + -> SDoc +pprIfaceDeclHead suppress_sig context ss tc_occ bndrs + = sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sep [ pprIfaceContextArr context + , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) + <+> pprIfaceTyConBinders suppress_sig + (suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs bndrs) ] + +pprIfaceConDecl :: ShowSub -> Bool + -> IfaceTopBndr + -> [IfaceTyConBinder] + -> IfaceTyConParent + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style tycon tc_binders parent + (IfCon { ifConName = name, ifConInfix = is_infix, + ifConUserTvBinders = user_tvbs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = stricts, ifConFields = fields }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty + | otherwise = ppr_ex_quant pp_h98_con + where + pp_h98_con + | not (null fields) = pp_prefix_con <+> pp_field_args + | is_infix + , [ty1, ty2] <- pp_args + = sep [ ty1 + , pprInfixIfDeclBndr how_much (occName name) + , ty2] + | otherwise = pp_prefix_con <+> sep pp_args + + how_much = ss_how_much ss + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts (map snd arg_tys) + pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) + + -- If we're pretty-printing a H98-style declaration with existential + -- quantification, then user_tvbs will always consist of the universal + -- tyvar binders followed by the existential tyvar binders. So to recover + -- the visibilities of the existential tyvar binders, we can simply drop + -- the universal tyvar binders from user_tvbs. + ex_tvbs = dropList tc_binders user_tvbs + ppr_ex_quant = pprIfaceForAllPartMust (ifaceForAllSpecToBndrs ex_tvbs) ctxt + pp_gadt_res_ty = mk_user_con_res_ty eq_spec + ppr_gadt_ty = pprIfaceForAllPart (ifaceForAllSpecToBndrs user_tvbs) ctxt pp_tau + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName + pp_tau | null fields + = case pp_args ++ [pp_gadt_res_ty] of + (t:ts) -> fsep (t : zipWithEqual "pprIfaceConDecl" (\(w,_) d -> ppr_arr w <+> d) arg_tys ts) + [] -> panic "pp_con_taus" + | otherwise + = sep [pp_field_args, arrow <+> pp_gadt_res_ty] + + -- Constructors are linear by default, but we don't want to show + -- linear arrows when -XLinearTypes is disabled + ppr_arr w = sdocOption sdocLinearTypes (\linearTypes -> if linearTypes + then ppr_fun_arrow w + else arrow) + + ppr_bang IfNoBang = whenPprDebug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = text "{-# UNPACK #-}" + ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> + pprParendIfaceCoercion co + + pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc + -- If using record syntax, the only reason one would need to parenthesize + -- a compound field type is if it's preceded by a bang pattern. + pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty + -- If not using record syntax, a compound field type might need to be + -- parenthesized if one of the following holds: + -- + -- 1. We're using Haskell98 syntax. + -- 2. The field type is preceded with a bang pattern. + pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty + + ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc + ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty + + -- If we're displaying the fields GADT-style, e.g., + -- + -- data Foo a where + -- MkFoo :: (Int -> Int) -> Maybe a -> Foo + -- + -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the + -- parentheses that it requires, but simple compound types like `Maybe a` + -- (which don't require parentheses in a function argument position) won't + -- get them, assuming that there are no bang patterns (see bang_prec). + -- + -- If we're displaying the fields Haskell98-style, e.g., + -- + -- data Foo a = MkFoo (Int -> Int) (Maybe a) + -- + -- Then not only must we parenthesize `Int -> Int`, we must also + -- parenthesize compound fields like (Maybe a). Therefore, we pick + -- `appPrec`, which has higher precedence than `funPrec`. + gadt_prec :: PprPrec + gadt_prec + | gadt_style = funPrec + | otherwise = appPrec + + -- The presence of bang patterns or UNPACK annotations requires + -- surrounding the type with parentheses, if needed (#13699) + bang_prec :: IfaceBang -> PprPrec + bang_prec IfNoBang = topPrec + bang_prec IfStrict = appPrec + bang_prec IfUnpack = appPrec + bang_prec IfUnpackCo{} = appPrec + + pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or + -- `!(Maybe a) -> !Int -> ...` + pp_args = map pprArgTy tys_w_strs + + pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or + -- { x :: !(Maybe a), y :: !Int } + pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ + zipWith maybe_show_label fields tys_w_strs + + maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc + maybe_show_label lbl bty + | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ + <+> dcolon <+> pprFieldArgTy bty) + | otherwise = Nothing + where + sel = flSelector lbl + occ = mkVarOccFS (flLabel lbl) + + mk_user_con_res_ty :: IfaceEqSpec -> SDoc + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys)) + | otherwise + = ppr_tc_app gadt_subst + where + gadt_subst = mkIfaceTySubst eq_spec + + -- When pretty-printing a GADT return type, we: + -- + -- 1. Take the data tycon binders, extract their variable names and + -- visibilities, and construct suitable arguments from them. (This is + -- the role of mk_tc_app_args.) + -- 2. Apply the GADT substitution constructed from the eq_spec. + -- (See Note [Result type of a data family GADT].) + -- 3. Pretty-print the data type constructor applied to its arguments. + -- This process will omit any invisible arguments, such as coercion + -- variables, if necessary. (See Note + -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) + ppr_tc_app gadt_subst = + pprPrefixIfDeclBndr how_much (occName tycon) + <+> pprParendIfaceAppArgs + (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders)) + + mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs + mk_tc_app_args [] = IA_Nil + mk_tc_app_args (Bndr bndr vis:tc_bndrs) = + IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) + (mk_tc_app_args tc_bndrs) + +instance Outputable IfaceRule where + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleOrph = orph }) + = sep [ hsep [ pprRuleName name + , if isOrphan orph then text "[orphan]" else Outputable.empty + , ppr act + , pp_foralls ] + , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + text "=" <+> ppr rhs]) ] + where + pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot + +instance Outputable IfaceClsInst where + ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = hang (text "instance" <+> ppr flag + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr dfun_id) + +instance Outputable IfaceFamInst where + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) + = hang (text "family instance" + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) + 2 (equals <+> ppr tycon_ax) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc + +{- +Note [Result type of a data family GADT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T (p,q) where + T1 :: T (Int, Maybe c) + T2 :: T (Bool, q) + +The IfaceDecl actually looks like + + data TPr p q where + T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q + T2 :: forall p q. (p~Bool) => TPr p q + +To reconstruct the result types for T1 and T2 that we +want to pretty print, we substitute the eq-spec +[p->Int, q->Maybe c] in the arg pattern (p,q) to give + T (Int, Maybe c) +Remember that in IfaceSyn, the TyCon and DataCon share the same +universal type variables. + +----------------------------- Printing IfaceExpr ------------------------------------ +-} + +instance Outputable IfaceExpr where + ppr e = pprIfaceExpr noParens e + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprParendIfaceExpr :: IfaceExpr -> SDoc +pprParendIfaceExpr = pprIfaceExpr parens + +-- | Pretty Print an IfaceExpr +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) +pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc + +pprIfaceExpr _ (IfaceLcl v) = ppr v +pprIfaceExpr _ (IfaceExt v) = ppr v +pprIfaceExpr _ (IfaceLit l) = ppr l +pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr _ (IfaceType ty) = char '@' <> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <> pprParendIfaceCoercion co + +pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) + +pprIfaceExpr add_par i@(IfaceLam _ _) + = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i + collect bs (IfaceLam b e) = collect (b:bs) e + collect bs e = (reverse bs, e) + +pprIfaceExpr add_par (IfaceECase scrut ty) + = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut + , text "ret_ty" <+> pprParendIfaceType ty + , text "of {}" ]) + +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) + +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) + +pprIfaceExpr _ (IfaceCast expr co) + = sep [pprParendIfaceExpr expr, + nest 2 (text "`cast`"), + pprParendIfaceCoercion co] + +pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) + = add_par (sep [text "let {", + nest 2 (ppr_bind (b, rhs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) + = add_par (sep [text "letrec {", + nest 2 (sep (map ppr_bind pairs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceTick tickish e) + = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) + +ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] + +ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + +ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc +ppr_bind (IfLetBndr b ty info ji, rhs) + = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), + equals <+> pprIfaceExpr noParens rhs] + +------------------ +pprIfaceTickish :: IfaceTickish -> SDoc +pprIfaceTickish (IfaceHpcTick m ix) + = braces (text "tick" <+> ppr m <+> ppr ix) +pprIfaceTickish (IfaceSCC cc tick scope) + = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) +pprIfaceTickish (IfaceSource src _names) + = braces (pprUserRealSpan True src) + +------------------ +pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ + nest 2 (pprParendIfaceExpr arg) : args +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) + +------------------ +instance Outputable IfaceConAlt where + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + +------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = Outputable.empty + ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc + <+> if b + then text "" + else Outputable.empty + ppr IfDFunId = text "DFunId" + +instance Outputable IfaceInfoItem where + ppr (HsUnfold lb unf) = text "Unfolding" + <> ppWhen lb (text "(loop-breaker)") + <> colon <+> ppr unf + ppr (HsInline prag) = text "Inline:" <+> ppr prag + ppr (HsArity arity) = text "Arity:" <+> int arity + ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str + ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr + ppr HsNoCafRefs = text "HasNoCafRefs" + ppr HsLevity = text "Never levity-polymorphic" + ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info + +instance Outputable IfaceJoinInfo where + ppr IfaceNotJoinPoint = empty + ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) + +instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = text "" <+> parens (ppr e) + ppr (IfCoreUnfold s e) = (if s + then text "" + else Outputable.empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] + ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) + 2 (sep (map pprParendIfaceExpr es)) + +{- +************************************************************************ +* * + Finding the Names in Iface syntax +* * +************************************************************************ + +This is used for dependency analysis in GHC.Iface.Make, so that we +fingerprint a declaration before the things that depend on it. It +is specific to interface-file fingerprinting in the sense that we +don't collect *all* Names: for example, the DFun of an instance is +recorded textually rather than by its fingerprint when +fingerprinting the instance, so DFuns are not dependencies. +-} + +freeNamesIfDecl :: IfaceDecl -> NameSet +freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i}) + = freeNamesIfType t &&& + freeNamesIfIdInfo i &&& + freeNamesIfIdDetails d + +freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k + , ifParent = p, ifCtxt = ctxt, ifCons = cons }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfType res_k &&& + freeNamesIfaceTyConParent p &&& + freeNamesIfContext ctxt &&& + freeNamesIfConDecls cons + +freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k + , ifSynRhs = rhs }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfType rhs + +freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k + , ifFamFlav = flav }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfFamFlav flav + +freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfClassBody cls_body + +freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) + = freeNamesIfTc tc &&& + fnList freeNamesIfAxBranch branches + +freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) + , ifPatBuilder = mb_builder + , ifPatUnivBndrs = univ_bndrs + , ifPatExBndrs = ex_bndrs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty + , ifFieldLabels = lbls }) + = unitNameSet matcher &&& + maybe emptyNameSet (unitNameSet . fst) mb_builder &&& + freeNamesIfVarBndrs univ_bndrs &&& + freeNamesIfVarBndrs ex_bndrs &&& + freeNamesIfContext prov_ctxt &&& + freeNamesIfContext req_ctxt &&& + fnList freeNamesIfType args &&& + freeNamesIfType pat_ty &&& + mkNameSet (map flSelector lbls) + +freeNamesIfClassBody :: IfaceClassBody -> NameSet +freeNamesIfClassBody IfAbstractClass + = emptyNameSet +freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }) + = freeNamesIfContext ctxt &&& + fnList freeNamesIfAT ats &&& + fnList freeNamesIfClsSig sigs + +freeNamesIfAxBranch :: IfaceAxBranch -> NameSet +freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars + , ifaxbCoVars = covars + , ifaxbLHS = lhs + , ifaxbRHS = rhs }) + = fnList freeNamesIfTvBndr tyvars &&& + fnList freeNamesIfIdBndr covars &&& + freeNamesIfAppArgs lhs &&& + freeNamesIfType rhs + +freeNamesIfIdDetails :: IfaceIdDetails -> NameSet +freeNamesIfIdDetails (IfRecSelId tc _) = + either freeNamesIfTc freeNamesIfDecl tc +freeNamesIfIdDetails _ = emptyNameSet + +-- All other changes are handled via the version info on the tycon +freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet +freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet +freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet + +freeNamesIfContext :: IfaceContext -> NameSet +freeNamesIfContext = fnList freeNamesIfType + +freeNamesIfAT :: IfaceAT -> NameSet +freeNamesIfAT (IfaceAT decl mb_def) + = freeNamesIfDecl decl &&& + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs + +freeNamesIfClsSig :: IfaceClassOp -> NameSet +freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm + +freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet +freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty +freeNamesDM _ = emptyNameSet + +freeNamesIfConDecls :: IfaceConDecls -> NameSet +freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls _ = emptyNameSet + +freeNamesIfConDecl :: IfaceConDecl -> NameSet +freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt + , ifConArgTys = arg_tys + , ifConFields = flds + , ifConEqSpec = eq_spec + , ifConStricts = bangs }) + = fnList freeNamesIfBndr ex_tvs &&& + freeNamesIfContext ctxt &&& + fnList freeNamesIfType (map fst arg_tys) &&& -- these are multiplicities, represented as types + fnList freeNamesIfType (map snd arg_tys) &&& + mkNameSet (map flSelector flds) &&& + fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints + fnList freeNamesIfBang bangs + +freeNamesIfBang :: IfaceBang -> NameSet +freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co +freeNamesIfBang _ = emptyNameSet + +freeNamesIfKind :: IfaceType -> NameSet +freeNamesIfKind = freeNamesIfType + +freeNamesIfAppArgs :: IfaceAppArgs -> NameSet +freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts +freeNamesIfAppArgs IA_Nil = emptyNameSet + +freeNamesIfType :: IfaceType -> NameSet +freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet +freeNamesIfType (IfaceTyVar _) = emptyNameSet +freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts +freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts +freeNamesIfType (IfaceLitTy _) = emptyNameSet +freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceFunTy _ w s t) = freeNamesIfType s &&& freeNamesIfType t &&& freeNamesIfType w +freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c +freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c + +freeNamesIfMCoercion :: IfaceMCoercion -> NameSet +freeNamesIfMCoercion IfaceMRefl = emptyNameSet +freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co + +freeNamesIfCoercion :: IfaceCoercion -> NameSet +freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t +freeNamesIfCoercion (IfaceGReflCo _ t mco) + = freeNamesIfType t &&& freeNamesIfMCoercion mco +freeNamesIfCoercion (IfaceFunCo _ c_mult c1 c2) + = freeNamesIfCoercion c_mult &&& freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) + = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceAppCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceForAllCo _ kind_co co) + = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co +freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet +freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet +freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet +freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) + = unitNameSet ax &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) + = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 +freeNamesIfCoercion (IfaceSymCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceTransCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceNthCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceLRCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceInstCo co co2) + = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 +freeNamesIfCoercion (IfaceKindCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceSubCo co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) + -- the axiom is just a string, so we don't count it as a name. + = fnList freeNamesIfCoercion cos + +freeNamesIfProv :: IfaceUnivCoProv -> NameSet +freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfacePluginProv _) = emptyNameSet + +freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet +freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr + +freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet +freeNamesIfVarBndrs = fnList freeNamesIfVarBndr + +freeNamesIfBndr :: IfaceBndr -> NameSet +freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b +freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b + +freeNamesIfBndrs :: [IfaceBndr] -> NameSet +freeNamesIfBndrs = fnList freeNamesIfBndr + +freeNamesIfLetBndr :: IfaceLetBndr -> NameSet +-- Remember IfaceLetBndr is used only for *nested* bindings +-- The IdInfo can contain an unfolding (in the case of +-- local INLINE pragmas), so look there too +freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty + &&& freeNamesIfIdInfo info + +freeNamesIfTvBndr :: IfaceTvBndr -> NameSet +freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k + -- kinds can have Names inside, because of promotion + +freeNamesIfIdBndr :: IfaceIdBndr -> NameSet +freeNamesIfIdBndr (_, _fs,k) = freeNamesIfKind k + +freeNamesIfIdInfo :: IfaceIdInfo -> NameSet +freeNamesIfIdInfo = fnList freeNamesItem + +freeNamesItem :: IfaceInfoItem -> NameSet +freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u +freeNamesItem (HsLFInfo (IfLFCon n)) = unitNameSet n +freeNamesItem _ = emptyNameSet + +freeNamesIfUnfold :: IfaceUnfolding -> NameSet +freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es + +freeNamesIfExpr :: IfaceExpr -> NameSet +freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co +freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as +freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body +freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a +freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co +freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e +freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts + where + fn_alt (_con,_bs,r) = freeNamesIfExpr r + + -- Depend on the data constructors. Just one will do! + -- Note [Tracking data constructors] + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet + +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body + +freeNamesIfExpr (IfaceLet (IfaceRec as) x) + = fnList fn_pair as &&& freeNamesIfExpr x + where + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs + +freeNamesIfExpr _ = emptyNameSet + +freeNamesIfTc :: IfaceTyCon -> NameSet +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) +-- ToDo: shouldn't we include IfaceIntTc & co.? + +freeNamesIfRule :: IfaceRule -> NameSet +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs + +freeNamesIfFamInst :: IfaceFamInst -> NameSet +freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName + , ifFamInstAxiom = axName }) + = unitNameSet famName &&& + unitNameSet axName + +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys + +-- helpers +(&&&) :: NameSet -> NameSet -> NameSet +(&&&) = unionNameSet + +fnList :: (a -> NameSet) -> [a] -> NameSet +fnList f = foldr (&&&) emptyNameSet . map f + +{- +Note [Tracking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case expression + case e of { C a -> ...; ... } +You might think that we don't need to include the datacon C +in the free names, because its type will probably show up in +the free names of 'e'. But in rare circumstances this may +not happen. Here's the one that bit me: + + module DynFlags where + import {-# SOURCE #-} Packages( PackageState ) + data DynFlags = DF ... PackageState ... + + module Packages where + import GHC.Driver.Session + data PackageState = PS ... + lookupModule (df :: DynFlags) + = case df of + DF ...p... -> case p of + PS ... -> ... + +Now, lookupModule depends on DynFlags, but the transitive dependency +on the *locally-defined* type PackageState is not visible. We need +to take account of the use of the data constructor PS in the pattern match. + + +************************************************************************ +* * + Binary instances +* * +************************************************************************ + +Note that there is a bit of subtlety here when we encode names. While +IfaceTopBndrs is really just a synonym for Name, we need to take care to +encode them with {get,put}IfaceTopBndr. The difference becomes important when +we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for +details. + +-} + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + putIfaceTopBndr bh name + lazyPut bh (ty, details, idinfo) + -- See Note [Lazy deserialization of IfaceId] + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 2 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do + putByte bh 3 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + + put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do + putByte bh 4 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + + -- NB: Written in a funny way to avoid an interface change + put_ bh (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8 + }}) = do + putByte bh 5 + put_ bh a1 + putIfaceTopBndr bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 6 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putByte bh 7 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + put_ bh a11 + + put_ bh (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) = do + putByte bh 8 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ~(ty, details, idinfo) <- lazyGet bh + -- See Note [Lazy deserialization of IfaceId] + return (IfaceId name ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) + 3 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceSynonym a1 a2 a3 a4 a5) + 4 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfaceFamily a1 a2 a3 a4 a5 a6) + 5 -> do a1 <- get bh + a2 <- getIfaceTopBndr bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8 + }}) + 6 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceAxiom a1 a2 a3 a4) + 7 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + a11 <- get bh + return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + 8 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) + +{- Note [Lazy deserialization of IfaceId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The use of lazyPut and lazyGet in the IfaceId Binary instance is +purely for performance reasons, to avoid deserializing details about +identifiers that will never be used. It's not involved in tying the +knot in the type checker. It saved ~1% of the total build time of GHC. + +When we read an interface file, we extend the PTE, a mapping of Names +to TyThings, with the declarations we have read. The extension of the +PTE is strict in the Names, but not in the TyThings themselves. +GHC.Iface.Load.loadDecl calculates the list of (Name, TyThing) bindings to +add to the PTE. For an IfaceId, there's just one binding to add; and +the ty, details, and idinfo fields of an IfaceId are used only in the +TyThing. So by reading those fields lazily we may be able to save the +work of ever having to deserialize them (into IfaceType, etc.). + +For IfaceData and IfaceClass, loadDecl creates extra implicit bindings +(the constructors and field selectors of the data declaration, or the +methods of the class), whose Names depend on more than just the Name +of the type constructor or class itself. So deserializing them lazily +would be more involved. Similar comments apply to the other +constructors of IfaceDecl with the additional point that they probably +represent a small proportion of all declarations. +-} + +instance Binary IfaceFamTyConFlav where + put_ bh IfaceDataFamilyTyCon = putByte bh 0 + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 + put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 + put_ _ IfaceBuiltInSynFamTyCon + = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceDataFamilyTyCon + 1 -> return IfaceOpenSynFamilyTyCon + 2 -> do { mb <- get bh + ; return (IfaceClosedSynFamilyTyCon mb) } + 3 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" + (ppr (fromIntegral h :: Int)) } + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n ty def) = do + putIfaceTopBndr bh n + put_ bh ty + put_ bh def + get bh = do + n <- getIfaceTopBndr bh + ty <- get bh + def <- get bh + return (IfaceClassOp n ty def) + +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) + +instance Binary IfaceConDecls where + put_ bh IfAbstractTyCon = putByte bh 0 + put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> return IfAbstractTyCon + 1 -> liftM IfDataTyCon (get bh) + 2 -> liftM IfNewTyCon (get bh) + _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" + +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh (length a9) + mapM_ (put_ bh) a9 + put_ bh a10 + put_ bh a11 + get bh = do + a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + n_fields <- get bh + a9 <- replicateM n_fields (get bh) + a10 <- get bh + a11 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + +instance Binary IfaceSrcBang where + put_ bh (IfSrcBang a1 a2) = + do put_ bh a1 + put_ bh a2 + + get bh = + do a1 <- get bh + a2 <- get bh + return (IfSrcBang a1 a2) + +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh IfDFunId = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> return IfDFunId + +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + put_ bh HsLevity = putByte bh 5 + put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr + put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info + + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsStrictness $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + 4 -> return HsNoCafRefs + 5 -> return HsLevity + 6 -> HsCpr <$> get bh + _ -> HsLFInfo <$> get bh + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfDFunUnfold as bs) = do + putByte bh 2 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 3 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) + + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam (ae, os) af) = do + putByte bh 4 + put_ bh ae + put_ bh os + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + os <- get bh + af <- get bh + return (IfaceLam (ae, os) af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + put_ bh (IfaceSource src name) = do + putByte bh 2 + put_ bh (srcSpanFile src) + put_ bh (srcSpanStartLine src) + put_ bh (srcSpanStartCol src) + put_ bh (srcSpanEndLine src) + put_ bh (srcSpanEndCol src) + put_ bh name + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + 2 -> do file <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + let start = mkRealSrcLoc file sl sc + end = mkRealSrcLoc file el ec + name <- get bh + return (IfaceSource (mkRealSrcSpan start end) name) + _ -> panic ("get IfaceTickish " ++ show h) + +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfLetBndr a b c d) + +instance Binary IfaceJoinInfo where + put_ bh IfaceNotJoinPoint = putByte bh 0 + put_ bh (IfaceJoinPoint ar) = do + putByte bh 1 + put_ bh ar + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceNotJoinPoint + _ -> liftM IfaceJoinPoint $ get bh + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty + +instance Binary IfaceCompleteMatch where + put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts + get bh = IfaceCompleteMatch <$> get bh <*> get bh + + +{- +************************************************************************ +* * + NFData instances + See Note [Avoiding space leaks in toIface*] in GHC.CoreToIface +* * +************************************************************************ +-} + +instance NFData IfaceDecl where + rnf = \case + IfaceId f1 f2 f3 f4 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + + IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> + f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq` + rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 + + IfaceSynonym f1 f2 f3 f4 f5 -> + rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + + IfaceFamily f1 f2 f3 f4 f5 f6 -> + rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` () + + IfaceClass f1 f2 f3 f4 f5 -> + rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + + IfaceAxiom nm tycon role ax -> + rnf nm `seq` + rnf tycon `seq` + role `seq` + rnf ax + + IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq` + rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` () + +instance NFData IfaceAxBranch where + rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 + +instance NFData IfaceClassBody where + rnf = \case + IfAbstractClass -> () + IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () + +instance NFData IfaceAT where + rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceClassOp where + rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` () + +instance NFData IfaceTyConParent where + rnf = \case + IfNoParent -> () + IfDataInstance f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + +instance NFData IfaceConDecls where + rnf = \case + IfAbstractTyCon -> () + IfDataTyCon f1 -> rnf f1 + IfNewTyCon f1 -> rnf f1 + +instance NFData IfaceConDecl where + rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` + rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 + +instance NFData IfaceSrcBang where + rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` () + +instance NFData IfaceBang where + rnf x = x `seq` () + +instance NFData IfaceIdDetails where + rnf = \case + IfVanillaId -> () + IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b + IfRecSelId (Right decl) b -> rnf decl `seq` rnf b + IfDFunId -> () + +instance NFData IfaceInfoItem where + rnf = \case + HsArity a -> rnf a + HsStrictness str -> seqStrictSig str + HsInline p -> p `seq` () -- TODO: seq further? + HsUnfold b unf -> rnf b `seq` rnf unf + HsNoCafRefs -> () + HsLevity -> () + HsCpr cpr -> cpr `seq` () + HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further? + +instance NFData IfaceUnfolding where + rnf = \case + IfCoreUnfold inlinable expr -> + rnf inlinable `seq` rnf expr + IfCompulsory expr -> + rnf expr + IfInlineRule arity b1 b2 e -> + rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e + IfDFunUnfold bndrs exprs -> + rnf bndrs `seq` rnf exprs + +instance NFData IfaceExpr where + rnf = \case + IfaceLcl nm -> rnf nm + IfaceExt nm -> rnf nm + IfaceType ty -> rnf ty + IfaceCo co -> rnf co + IfaceTuple sort exprs -> sort `seq` rnf exprs + IfaceLam bndr expr -> rnf bndr `seq` rnf expr + IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 + IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts + IfaceECase e ty -> rnf e `seq` rnf ty + IfaceLet bind e -> rnf bind `seq` rnf e + IfaceCast e co -> rnf e `seq` rnf co + IfaceLit l -> l `seq` () -- FIXME + IfaceFCall fc ty -> fc `seq` rnf ty + IfaceTick tick e -> rnf tick `seq` rnf e + +instance NFData IfaceBinding where + rnf = \case + IfaceNonRec bndr e -> rnf bndr `seq` rnf e + IfaceRec binds -> rnf binds + +instance NFData IfaceLetBndr where + rnf (IfLetBndr nm ty id_info join_info) = + rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info + +instance NFData IfaceFamTyConFlav where + rnf = \case + IfaceDataFamilyTyCon -> () + IfaceOpenSynFamilyTyCon -> () + IfaceClosedSynFamilyTyCon f1 -> rnf f1 + IfaceAbstractClosedSynFamilyTyCon -> () + IfaceBuiltInSynFamTyCon -> () + +instance NFData IfaceJoinInfo where + rnf x = x `seq` () + +instance NFData IfaceTickish where + rnf = \case + IfaceHpcTick m i -> rnf m `seq` rnf i + IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2 + IfaceSource src str -> src `seq` rnf str + +instance NFData IfaceConAlt where + rnf = \case + IfaceDefault -> () + IfaceDataAlt nm -> rnf nm + IfaceLitAlt lit -> lit `seq` () + +instance NFData IfaceCompleteMatch where + rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceRule where + rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = + rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` () + +instance NFData IfaceFamInst where + rnf (IfaceFamInst f1 f2 f3 f4) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () + +instance NFData IfaceClsInst where + rnf (IfaceClsInst f1 f2 f3 f4 f5) = + f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` () + +instance NFData IfaceAnnotation where + rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` () diff --git a/GHC/Iface/Tidy.hs b/GHC/Iface/Tidy.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Tidy.hs @@ -0,0 +1,1369 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Tidying up Core} +-} + +{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Iface.Tidy ( + mkBootModDetailsTc, tidyProgram + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Driver.Session +import GHC.Core +import GHC.Core.Unfold +import GHC.Core.FVs +import GHC.Core.Tidy +import GHC.Core.Opt.Monad +import GHC.Core.Stats (coreBindsStats, CoreStats(..)) +import GHC.Core.Seq (seqBinds) +import GHC.Core.Lint +import GHC.Core.Rules +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe ) +import GHC.Iface.Tidy.StaticPtrTable +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Make ( mkDictSelRhs ) +import GHC.Types.Id.Info +import GHC.Core.InstEnv +import GHC.Core.Type ( tidyTopType ) +import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Basic +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Set +import GHC.Types.Name.Cache +import GHC.Types.Avail +import GHC.Iface.Env +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Unit.Module +import GHC.Driver.Types +import GHC.Data.Maybe +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Utils.Misc( filterOut ) +import qualified GHC.Utils.Error as Err + +import Control.Monad +import Data.Function +import Data.List ( sortBy, mapAccumL ) +import Data.IORef ( atomicModifyIORef' ) + +{- +Constructing the TypeEnv, Instances, Rules from which the +ModIface is constructed, and which goes on to subsequent modules in +--make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +plus one for each DataCon; the interface file will contain just one +data type declaration, but it is de-serialised back into a collection +of TyThings. + +************************************************************************ +* * + Plan A: simpleTidyPgm +* * +************************************************************************ + + +Plan A: mkBootModDetails: omit pragmas, make interfaces small +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Ignore the bindings + +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* Tidy the bindings, to ensure that the Arity + information is correct for each top-level binder; the + code generator needs it. And to ensure that local names have + distinct OccNames in case of object-file splitting + +* If this an hsig file, drop the instances altogether too (they'll + get pulled in by the implicit module import. +-} + +-- This is Plan A: make a small type env when typechecking only, +-- or when compiling a hs-boot file, or simply when not using -O +-- +-- We don't look at the bindings at all -- there aren't any +-- for hs-boot files + +mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc hsc_env + TcGblEnv{ tcg_exports = exports, + tcg_type_env = type_env, -- just for the Ids + tcg_tcs = tcs, + tcg_patsyns = pat_syns, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_complete_matches = complete_sigs, + tcg_mod = this_mod + } + = -- This timing isn't terribly useful since the result isn't forced, but + -- the message is useful to locating oneself in the compilation process. + Err.withTiming dflags + (text "CoreTidy"<+>brackets (ppr this_mod)) + (const ()) $ + return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_complete_sigs = complete_sigs + }) + where + dflags = hsc_dflags hsc_env + + -- Find the LocalIds in the type env that are exported + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. + -- + -- Do make sure that we keep Ids that are already Global. + -- When typechecking an .hs-boot file, the Ids come through as + -- GlobalIds. + final_ids = [ globaliseAndTidyBootId id + | id <- typeEnvIds type_env + , keep_it id ] + + final_tcs = filterOut isWiredIn tcs + -- See Note [Drop wired-in things] + type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts + insts' = mkFinalClsInsts type_env1 insts + pat_syns' = mkFinalPatSyns type_env1 pat_syns + type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 + + -- Default methods have their export flag set (isExportedId), + -- but everything else doesn't (yet), because this is + -- pre-desugaring, so we must test against the exports too. + keep_it id | isWiredInName id_name = False + -- See Note [Drop wired-in things] + | isExportedId id = True + | id_name `elemNameSet` exp_names = True + | otherwise = False + where + id_name = idName id + + exp_names = availsToNameSet exports + +lookupFinalId :: TypeEnv -> Id -> Id +lookupFinalId type_env id + = case lookupTypeEnv type_env (idName id) of + Just (AnId id') -> id' + _ -> pprPanic "lookup_final_id" (ppr id) + +mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] +mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) + +mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn] +mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env)) + +extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv +extendTypeEnvWithPatSyns tidy_patsyns type_env + = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] + +globaliseAndTidyBootId :: Id -> Id +-- For a LocalId with an External Name, +-- makes it into a GlobalId +-- * unchanged Name (might be Internal or External) +-- * unchanged details +-- * VanillaIdInfo (makes a conservative assumption about arity) +-- * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) +globaliseAndTidyBootId id + = updateIdTypeAndMult tidyTopType (globaliseId id) + `setIdUnfolding` BootUnfolding + +{- +************************************************************************ +* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +* * +************************************************************************ + +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Step 1: Figure out which Ids are externally visible + See Note [Choosing external Ids] + +* Step 2: Gather the externally visible rules, separately from + the top-level bindings. + See Note [Finding external rules] + +* Step 3: Tidy the bindings, externalising appropriate Ids + See Note [Tidy the top-level bindings] + +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) + +Note [Choosing external Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also the section "Interface stability" in the +recompilation-avoidance commentary: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance + +First we figure out which Ids are "external" Ids. An +"external" Id is one that is visible from outside the compilation +unit. These are + a) the user exported ones + b) the ones bound to static forms + c) ones mentioned in the unfoldings, workers, or + rules of externally-visible ones + +While figuring out which Ids are external, we pick a "tidy" OccName +for each one. That is, we make its OccName distinct from the other +external OccNames in this module, so that in interface files and +object code we can refer to it unambiguously by its OccName. The +OccName for each binder is prefixed by the name of the exported Id +that references it; e.g. if "f" references "x" in its unfolding, then +"x" is renamed to "f_x". This helps distinguish the different "x"s +from each other, and means that if "f" is later removed, things that +depend on the other "x"s will not need to be recompiled. Of course, +if there are multiple "f_x"s, then we have to disambiguate somehow; we +use "f_x0", "f_x1" etc. + +As far as possible we should assign names in a deterministic fashion. +Each time this module is compiled with the same options, we should end +up with the same set of external names with the same types. That is, +the ABI hash in the interface should not change. This turns out to be +quite tricky, since the order of the bindings going into the tidy +phase is already non-deterministic, as it is based on the ordering of +Uniques, which are assigned unpredictably. + +To name things in a stable way, we do a depth-first-search of the +bindings, starting from the exports sorted by name. This way, as long +as the bindings themselves are deterministic (they sometimes aren't!), +the order in which they are presented to the tidying phase does not +affect the names we assign. + +Note [Tidy the top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Next we traverse the bindings top to bottom. For each *top-level* +binder + + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id + + 2. Give it a system-wide Unique. + [Even non-exported things need system-wide Uniques because the + byte-code generator builds a single Name->BCO symbol table.] + + We use the NameCache kept in the HscEnv as the + source of such system-wide uniques. + + For external Ids, use the original-name cache in the NameCache + to ensure that the unique assigned is the same as the Id had + in any previous compilation run. + + 3. Rename top-level Ids according to the names we chose in step 1. + If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. This is used by the code generator + to decide whether to make the label externally visible + + 4. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + +Finally, substitute these new top-level binders consistently +throughout, including in unfoldings. We also tidy binders in +RHSs, so that they print nicely in interfaces. + +Note [Always expose compulsory unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must make absolutely sure that unsafeCoerce# is inlined. You might +think that giving it a compulsory unfolding is enough. However, +unsafeCoerce# is put in an interface file just like any other definition. +So, unless we take special precuations +- If we compiled Unsafe.Coerce with -O0, we might not put the unfolding + into the interface file. +- If we compile a module M, that imports Unsafe.Coerce, with -O0 we might + not read the unfolding out of the interface file. + +So we need to take care, to ensure that Compulsory unfoldings are written +and read. That makes sense: they are compulsory, after all. There are +three places this is actioned: + +* GHC.Iface.Tidy.addExternal. Export end: expose compulsory + unfoldings, even with -O0. + +* GHC.IfaceToCore.tcIdInfo. Import end: when reading in from + interface file, even with -O0 (fignore-interface-pragmas.) we must + load a compulsory unfolding +-} + +tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +tidyProgram hsc_env (ModGuts { mg_module = mod + , mg_exports = exports + , mg_rdr_env = rdr_env + , mg_tcs = tcs + , mg_insts = cls_insts + , mg_fam_insts = fam_insts + , mg_binds = binds + , mg_patsyns = patsyns + , mg_rules = imp_rules + , mg_anns = anns + , mg_complete_sigs = complete_sigs + , mg_deps = deps + , mg_foreign = foreign_stubs + , mg_foreign_files = foreign_files + , mg_hpc_info = hpc_info + , mg_modBreaks = modBreaks + }) + + = Err.withTiming dflags + (text "CoreTidy"<+>brackets (ppr mod)) + (const ()) $ + do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags + ; expose_all = gopt Opt_ExposeAllUnfoldings dflags + ; print_unqual = mkPrintUnqualified dflags rdr_env + ; implicit_binds = concatMap getImplicitBinds tcs + } + + ; (unfold_env, tidy_occ_env) + <- chooseExternalIds hsc_env mod omit_prags expose_all + binds implicit_binds imp_rules + ; let { (trimmed_binds, trimmed_rules) + = findExternalRules omit_prags binds imp_rules unfold_env } + + ; (tidy_env, tidy_binds) + <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds + + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + ; (spt_entries, tidy_binds') <- + sptCreateStaticBinds hsc_env mod tidy_binds + ; let { spt_init_code = sptModuleInitCode mod spt_entries + ; add_spt_init_code = + case hscTarget dflags of + -- If we are compiling for the interpreter we will insert + -- any necessary SPT entries dynamically + HscInterpreted -> id + -- otherwise add a C stub to do so + _ -> (`appendStubC` spt_init_code) + + -- The completed type environment is gotten from + -- a) the types and classes defined here (plus implicit things) + -- b) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (b) we keep only those Ids with External names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- See Note [Don't attempt to trim data types] + ; final_ids = [ trimId omit_prags id + | id <- bindersOfBinds tidy_binds + , isExternalName (idName id) + , not (isWiredIn id) + ] -- See Note [Drop wired-in things] + + ; final_tcs = filterOut isWiredIn tcs + -- See Note [Drop wired-in things] + ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts + ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts + ; tidy_patsyns = mkFinalPatSyns type_env patsyns + ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env + ; tidy_rules = tidyRules tidy_env trimmed_rules + + ; -- See Note [Injecting implicit bindings] + all_tidy_binds = implicit_binds ++ tidy_binds' + + -- Get the TyCons to generate code for. Careful! We must use + -- the untidied TyCons here, because we need + -- (a) implicit TyCons arising from types and classes defined + -- in this module + -- (b) wired-in TyCons, which are normally removed from the + -- TypeEnv we put in the ModDetails + -- (c) Constructors even if they are not exported (the + -- tidied TypeEnv has trimmed these away) + ; alg_tycons = filter isAlgTyCon tcs + } + + ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is + -- on, print now + ; unless (dopt Opt_D_dump_simpl dflags) $ + Err.dumpIfSet_dyn dflags Opt_D_dump_rules + (showSDoc dflags (ppr CoreTidy <+> text "rules")) + Err.FormatText + (pprRulesForUser tidy_rules) + + -- Print one-line size info + ; let cs = coreBindsStats tidy_binds + ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" + Err.FormatText + (text "Tidy size (terms,types,coercions)" + <+> ppr (moduleName mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs) ) + + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = all_tidy_binds, + cg_foreign = add_spt_init_code foreign_stubs, + cg_foreign_files = foreign_files, + cg_dep_pkgs = map fst $ dep_pkgs deps, + cg_hpc_info = hpc_info, + cg_modBreaks = modBreaks, + cg_spt_entries = spt_entries }, + + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_cls_insts, + md_fam_insts = fam_insts, + md_exports = exports, + md_anns = anns, -- are already tidy + md_complete_sigs = complete_sigs + }) + } + where + dflags = hsc_dflags hsc_env + +-------------------------- +trimId :: Bool -> Id -> Id +-- With -O0 we now trim off the arity, one-shot-ness, strictness +-- etc which tidyTopIdInfo retains for the benefit of the code generator +-- but which we don't want in the interface file or ModIface for +-- downstream compilations +trimId omit_prags id + | omit_prags, not (isImplicitId id) + = id `setIdInfo` vanillaIdInfo + `setIdUnfolding` idUnfolding id + -- We respect the final unfolding chosen by tidyTopIdInfo. + -- We have already trimmed it if we don't want it for -O0; + -- see also Note [Always expose compulsory unfoldings] + + | otherwise -- No trimming + = id + +{- Note [Drop wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never put wired-in TyCons or Ids in an interface file. +They are wired-in, so the compiler knows about them already. + +Note [Don't attempt to trim data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some time GHC tried to avoid exporting the data constructors +of a data type if it wasn't strictly necessary to do so; see #835. +But "strictly necessary" accumulated a longer and longer list +of exceptions, and finally I gave up the battle: + + commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11 + Author: Simon Peyton Jones + Date: Thu Dec 6 16:03:16 2012 +0000 + + Stop attempting to "trim" data types in interface files + + Without -O, we previously tried to make interface files smaller + by not including the data constructors of data types. But + there are a lot of exceptions, notably when Template Haskell is + involved or, more recently, DataKinds. + + However #7445 shows that even without TemplateHaskell, using + the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ + is enough to require us to expose the data constructors. + + So I've given up on this "optimisation" -- it's probably not + important anyway. Now I'm simply not attempting to trim off + the data constructors. The gain in simplicity is worth the + modest cost in interface file growth, which is limited to the + bits reqd to describe those data constructors. + +************************************************************************ +* * + Implicit bindings +* * +************************************************************************ + +Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inject the implicit bindings right at the end, in GHC.Core.Tidy. +Some of these bindings, notably record selectors, are not +constructed in an optimised form. E.g. record selector for + data T = MkT { x :: {-# UNPACK #-} !Int } +Then the unfolding looks like + x = \t. case t of MkT x1 -> let x = I# x1 in x +This generates bad code unless it's first simplified a bit. That is +why GHC.Core.Unfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of +optimisation first. (Only matters when the selector is used curried; +eg map x ys.) See #2070. + +[Oct 09: in fact, record selectors are no longer implicit Ids at all, +because we really do want to optimise them properly. They are treated +much like any other Id. But doing "light" optimisation on an implicit +Id still makes sense.] + +At one time I tried injecting the implicit bindings *early*, at the +beginning of SimplCore. But that gave rise to real difficulty, +because GlobalIds are supposed to have *fixed* IdInfo, but the +simplifier and other core-to-core passes mess with IdInfo all the +time. The straw that broke the camels back was when a class selector +got the wrong arity -- ie the simplifier gave it arity 2, whereas +importing modules were expecting it to have arity 1 (#2844). +It's much safer just to inject them right at the end, after tidying. + +Oh: two other reasons for injecting them late: + + - If implicit Ids are already in the bindings when we start tidying, + we'd have to be careful not to treat them as external Ids (in + the sense of chooseExternalIds); else the Ids mentioned in *their* + RHSs will be treated as external and you get an interface file + saying a18 = + but nothing referring to a18 (because the implicit Id is the + one that does, and implicit Ids don't appear in interface files). + + - More seriously, the tidied type-envt will include the implicit + Id replete with a18 in its unfolding; but we won't take account + of a18 when computing a fingerprint for the class; result chaos. + +There is one sort of implicit binding that is injected still later, +namely those for data constructor workers. Reason (I think): it's +really just a code generation trick.... binding itself makes no sense. +See Note [Data constructor workers] in "GHC.CoreToStg.Prep". +-} + +getImplicitBinds :: TyCon -> [CoreBind] +getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc + where + cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) + +getTyConImplicitBinds :: TyCon -> [CoreBind] +getTyConImplicitBinds tc + | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + +getClassImplicitBinds :: Class -> [CoreBind] +getClassImplicitBinds cls + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] + +get_defn :: Id -> CoreBind +get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) + +{- +************************************************************************ +* * +\subsection{Step 1: finding externals} +* * +************************************************************************ + +See Note [Choosing external Ids]. +-} + +type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) + -- Maps each top-level Id to its new Name (the Id is tidied in step 2) + -- The Unique is unchanged. If the new Name is external, it will be + -- visible in the interface file. + -- + -- Bool => expose unfolding or not. + +chooseExternalIds :: HscEnv + -> Module + -> Bool -> Bool + -> [CoreBind] + -> [CoreBind] + -> [CoreRule] + -> IO (UnfoldEnv, TidyOccEnv) + -- Step 1 from the notes above + +chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules + = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env + ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders + ; tidy_internal internal_ids unfold_env1 occ_env1 } + where + nc_var = hsc_NC hsc_env + + -- init_ext_ids is the initial list of Ids that should be + -- externalised. It serves as the starting point for finding a + -- deterministic, tidy, renaming for all external Ids in this + -- module. + -- + -- It is sorted, so that it has a deterministic order (i.e. it's the + -- same list every time this module is compiled), in contrast to the + -- bindings, which are ordered non-deterministically. + init_work_list = zip init_ext_ids init_ext_ids + init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders + + -- An Id should be external if either (a) it is exported, + -- (b) it appears in the RHS of a local rule for an imported Id, or + -- See Note [Which rules to expose] + is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars + + rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules + + binders = map fst $ flattenBinds binds + implicit_binders = bindersOfBinds implicit_binds + binder_set = mkVarSet binders + + avoids = [getOccName name | bndr <- binders ++ implicit_binders, + let name = idName bndr, + isExternalName name ] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. + -- In particular, the set of binders doesn't include + -- implicit Ids at this stage. + + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. + init_occ_env = initTidyOccEnv avoids + + + search :: [(Id,Id)] -- The work-list: (external id, referring id) + -- Make a tidy, external Name for the external id, + -- add it to the UnfoldEnv, and do the same for the + -- transitive closure of Ids it refers to + -- The referring id is used to generate a tidy + --- name for the external id + -> UnfoldEnv -- id -> (new Name, show_unfold) + -> TidyOccEnv -- occ env for choosing new Names + -> IO (UnfoldEnv, TidyOccEnv) + + search [] unfold_env occ_env = return (unfold_env, occ_env) + + search ((idocc,referrer) : rest) unfold_env occ_env + | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env + | otherwise = do + (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc + let + (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id + + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set + refined_id = case lookupVarSet binder_set idocc of + Just id -> id + Nothing -> WARN( True, ppr idocc ) idocc + + unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) + referrer' | isExportedId refined_id = refined_id + | otherwise = referrer + -- + search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' + + tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv + -> IO (UnfoldEnv, TidyOccEnv) + tidy_internal [] unfold_env occ_env = return (unfold_env,occ_env) + tidy_internal (id:ids) unfold_env occ_env = do + (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id + let unfold_env' = extendVarEnv unfold_env id (name',False) + tidy_internal ids unfold_env' occ_env' + +addExternal :: Bool -> Bool -> Id -> ([Id], Bool) +addExternal omit_prags expose_all id + | omit_prags + , not (isCompulsoryUnfolding unfolding) + = ([], False) -- See Note [Always expose compulsory unfoldings] + -- in GHC.HsToCore + + | otherwise + = (new_needed_ids, show_unfold) + + where + new_needed_ids = bndrFvsInOrder show_unfold id + idinfo = idInfo id + unfolding = unfoldingInfo idinfo + show_unfold = show_unfolding unfolding + never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) + loop_breaker = isStrongLoopBreaker (occInfo idinfo) + bottoming_fn = isDeadEndSig (strictnessInfo idinfo) + + -- Stuff to do with the Id's unfolding + -- We leave the unfolding there even if there is a worker + -- In GHCi the unfolding is used by importers + + show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) + = expose_all -- 'expose_all' says to expose all + -- unfoldings willy-nilly + + || isStableSource src -- Always expose things whose + -- source is an inline rule + + || not (bottoming_fn -- No need to inline bottom functions + || never_active -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance guidance) + show_unfolding (DFunUnfolding {}) = True + show_unfolding _ = False + +{- +************************************************************************ +* * + Deterministic free variables +* * +************************************************************************ + +We want a deterministic free-variable list. exprFreeVars gives us +a VarSet, which is in a non-deterministic order when converted to a +list. Hence, here we define a free-variable finder that returns +the free variables in the order that they are encountered. + +See Note [Choosing external Ids] +-} + +bndrFvsInOrder :: Bool -> Id -> [Id] +bndrFvsInOrder show_unfold id + = run (dffvLetBndr show_unfold id) + +run :: DFFV () -> [Id] +run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of + ((_,ids),_) -> ids + +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope + -- we don't want to record these as free vars + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> ((VarSet,[Var]),a)) -- Output state + deriving (Functor) + +instance Applicative DFFV where + pure a = DFFV $ \_ st -> (st, a) + (<*>) = ap + +instance Monad DFFV where + (DFFV m) >>= k = DFFV $ \env st -> + case m env st of + (st',a) -> case k a of + DFFV f -> f env st' + +extendScope :: Var -> DFFV a -> DFFV a +extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) + +extendScopeList :: [Var] -> DFFV a -> DFFV a +extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) + +insert :: Var -> DFFV () +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && + not (v `elemVarSet` env) && + not (v `elemVarSet` set) + in if keep_me + then ((extendVarSet set v, v:ids), ()) + else ((set, ids), ()) + + +dffvExpr :: CoreExpr -> DFFV () +dffvExpr (Var v) = insert v +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick _other e) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) +dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ + (mapM_ dffvBind prs >> dffvExpr e) +dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) +dffvExpr _other = return () + +dffvAlt :: (t, [Var], CoreExpr) -> DFFV () +dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) + +dffvBind :: (Id, CoreExpr) -> DFFV () +dffvBind(x,r) + | not (isId x) = dffvExpr r + | otherwise = dffvLetBndr False x >> dffvExpr r + -- Pass False because we are doing the RHS right here + -- If you say True you'll get *exponential* behaviour! + +dffvLetBndr :: Bool -> Id -> DFFV () +-- Gather the free vars of the RULES and unfolding of a binder +-- We always get the free vars of a *stable* unfolding, but +-- for a *vanilla* one (InlineRhs), the flag controls what happens: +-- True <=> get fvs of even a *vanilla* unfolding +-- False <=> ignore an InlineRhs +-- For nested bindings (call from dffvBind) we always say "False" because +-- we are taking the fvs of the RHS anyway +-- For top-level bindings (call from addExternal, via bndrFvsInOrder) +-- we say "True" if we are exposing that unfolding +dffvLetBndr vanilla_unfold id + = do { go_unf (unfoldingInfo idinfo) + ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } + where + idinfo = idInfo id + + go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + = case src of + InlineRhs | vanilla_unfold -> dffvExpr rhs + | otherwise -> return () + _ -> dffvExpr rhs + + go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = extendScopeList bndrs $ mapM_ dffvExpr args + go_unf _ = return () + + go_rule (BuiltinRule {}) = return () + go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) + = extendScopeList bndrs (dffvExpr rhs) + +{- +************************************************************************ +* * + findExternalRules +* * +************************************************************************ + +Note [Finding external rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The complete rules are gotten by combining + a) local rules for imported Ids + b) rules embedded in the top-level Ids + +There are two complications: + * Note [Which rules to expose] + * Note [Trimming auto-rules] + +Note [Which rules to expose] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function 'expose_rule' filters out rules that mention, on the LHS, +Ids that aren't externally visible; these rules can't fire in a client +module. + +The externally-visible binders are computed (by chooseExternalIds) +assuming that all orphan rules are externalised (see init_ext_ids in +function 'search'). So in fact it's a bit conservative and we may +export more than we need. (It's a sort of mutual recursion.) + +Note [Trimming auto-rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Second, with auto-specialisation we may specialise local or imported +dfuns or INLINE functions, and then later inline them. That may leave +behind something like + RULE "foo" forall d. f @ Int d = f_spec +where f is either local or imported, and there is no remaining +reference to f_spec except from the RULE. + +Now that RULE *might* be useful to an importing module, but that is +purely speculative, and meanwhile the code is taking up space and +codegen time. I found that binary sizes jumped by 6-10% when I +started to specialise INLINE functions (again, Note [Inline +specialisations] in GHC.Core.Opt.Specialise). + +So it seems better to drop the binding for f_spec, and the rule +itself, if the auto-generated rule is the *only* reason that it is +being kept alive. + +(The RULE still might have been useful in the past; that is, it was +the right thing to have generated it in the first place. See Note +[Inline specialisations] in GHC.Core.Opt.Specialise. But now it has +served its purpose, and can be discarded.) + +So findExternalRules does this: + * Remove all bindings that are kept alive *only* by isAutoRule rules + (this is done in trim_binds) + * Remove all auto rules that mention bindings that have been removed + (this is done by filtering by keep_rule) + +NB: if a binding is kept alive for some *other* reason (e.g. f_spec is +called in the final code), we keep the rule too. + +This stuff is the only reason for the ru_auto field in a Rule. +-} + +findExternalRules :: Bool -- Omit pragmas + -> [CoreBind] + -> [CoreRule] -- Local rules for imported fns + -> UnfoldEnv -- Ids that are exported, so we need their rules + -> ([CoreBind], [CoreRule]) +-- See Note [Finding external rules] +findExternalRules omit_prags binds imp_id_rules unfold_env + = (trimmed_binds, filter keep_rule all_rules) + where + imp_rules = filter expose_rule imp_id_rules + imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules + + user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet + | otherwise = ruleRhsFreeVars rule + + (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds + + keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs + -- Remove rules that make no sense, because they mention a + -- local binder (on LHS or RHS) that we have now discarded. + -- (NB: ruleFreeVars only includes LocalIds) + -- + -- LHS: we have already filtered out rules that mention internal Ids + -- on LHS but that isn't enough because we might have by now + -- discarded a binding with an external Id. (How? + -- chooseExternalIds is a bit conservative.) + -- + -- RHS: the auto rules that might mention a binder that has + -- been discarded; see Note [Trimming auto-rules] + + expose_rule rule + | omit_prags = False + | otherwise = all is_external_id (ruleLhsFreeIdsList rule) + -- Don't expose a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module). NB: ruleLhsFreeIds only returns LocalIds. + -- See Note [Which rules to expose] + + is_external_id id = case lookupVarEnv unfold_env id of + Just (name, _) -> isExternalName name + Nothing -> False + + trim_binds :: [CoreBind] + -> ( [CoreBind] -- Trimmed bindings + , VarSet -- Binders of those bindings + , VarSet -- Free vars of those bindings + rhs of user rules + -- (we don't bother to delete the binders) + , [CoreRule]) -- All rules, imported + from the bindings + -- This function removes unnecessary bindings, and gathers up rules from + -- the bindings we keep. See Note [Trimming auto-rules] + trim_binds [] -- Base case, start with imp_user_rule_fvs + = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) + + trim_binds (bind:binds) + | any needed bndrs -- Keep binding + = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) + | otherwise -- Discard binding altogether + = stuff + where + stuff@(binds', bndr_set, needed_fvs, rules) + = trim_binds binds + needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs + + bndrs = bindersOf bind + rhss = rhssOfBind bind + bndr_set' = bndr_set `extendVarSetList` bndrs + + needed_fvs' = needed_fvs `unionVarSet` + mapUnionVarSet idUnfoldingVars bndrs `unionVarSet` + -- Ignore type variables in the type of bndrs + mapUnionVarSet exprFreeVars rhss `unionVarSet` + mapUnionVarSet user_rule_rhs_fvs local_rules + -- In needed_fvs', we don't bother to delete binders from the fv set + + local_rules = [ rule + | id <- bndrs + , is_external_id id -- Only collect rules for external Ids + , rule <- idCoreRules id + , expose_rule rule ] -- and ones that can fire in a client + +{- +************************************************************************ +* * + tidyTopName +* * +************************************************************************ + +This is where we set names to local/global based on whether they really are +externally visible (see comment at the top of this module). If the name +was previously local, we have to give it a unique occurrence name if +we intend to externalise it. +-} + +tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var maybe_ref occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external + ; return (occ_env', new_external_name) } + + | otherwise = panic "tidyTopName" + where + name = idName id + external = isJust maybe_ref + global = isExternalName name + local = not global + internal = not external + loc = nameSrcSpan name + + old_occ = nameOccName name + new_occ | Just ref <- maybe_ref + , ref /= id + = mkOccName (occNameSpace old_occ) $ + let + ref_str = occNameString (getOccName ref) + occ_str = occNameString old_occ + in + case occ_str of + '$':'w':_ -> occ_str + -- workers: the worker for a function already + -- includes the occname for its parent, so there's + -- no need to prepend the referrer. + _other | isSystemName name -> ref_str + | otherwise -> ref_str ++ '_' : occ_str + -- If this name was system-generated, then don't bother + -- to retain its OccName, just use the referrer. These + -- system-generated names will become "f1", "f2", etc. for + -- a referrer "f". + | otherwise = old_occ + + (occ_env', occ') = tidyOccName occ_env new_occ + + mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) + where + (uniq, us) = takeUniqFromSupply (nsUniqs nc) + + mk_new_external nc = allocateGlobalBinder nc mod occ' loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. + +{- +************************************************************************ +* * +\subsection{Step 2: top-level tidying} +* * +************************************************************************ +-} + +-- TopTidyEnv: when tidying we need to know +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file +-- +-- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- are 'used' +-- +-- * subst_env: A Var->Var mapping that substitutes the new Var for the old + +tidyTopBinds :: HscEnv + -> UnfoldEnv + -> TidyOccEnv + -> CoreProgram + -> IO (TidyEnv, CoreProgram) + +tidyTopBinds hsc_env unfold_env init_occ_env binds + = do let result = tidy init_env binds + seqBinds (snd result) `seq` return result + -- This seqBinds avoids a spike in space usage (see #13564) + where + dflags = hsc_dflags hsc_env + + init_env = (init_occ_env, emptyVarEnv) + + tidy = mapAccumL (tidyTopBind dflags unfold_env) + +------------------------ +tidyTopBind :: DynFlags + -> UnfoldEnv + -> TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyTopBind dflags unfold_env + (occ_env,subst1) (NonRec bndr rhs) + = (tidy_env2, NonRec bndr' rhs') + where + Just (name',show_unfold) = lookupVarEnv unfold_env bndr + (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 name' (bndr, rhs) + subst2 = extendVarEnv subst1 bndr bndr' + tidy_env2 = (occ_env, subst2) + +tidyTopBind dflags unfold_env (occ_env, subst1) (Rec prs) + = (tidy_env2, Rec prs') + where + prs' = [ tidyTopPair dflags show_unfold tidy_env2 name' (id,rhs) + | (id,rhs) <- prs, + let (name',show_unfold) = + expectJust "tidyTopBind" $ lookupVarEnv unfold_env id + ] + + subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + tidy_env2 = (occ_env, subst2) + + bndrs = map fst prs + +----------------------------------------------------------- +tidyTopPair :: DynFlags + -> Bool -- show unfolding + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group + +tidyTopPair dflags show_unfold rhs_tidy_env name' (bndr, rhs) + = (bndr1, rhs1) + where + bndr1 = mkGlobalId details name' ty' idinfo' + details = idDetails bndr -- Preserve the IdDetails + ty' = tidyTopType (idType bndr) + rhs1 = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) + show_unfold + +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. The delicate piece: +-- +-- * Arity. After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr + -> IdInfo -> Bool -> IdInfo +tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. GHC.Core.Tidy.tidyLetBndr + `setArityInfo` arity + `setStrictnessInfo` final_sig + `setCprInfo` final_cpr + `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] + -- in GHC.Core.Tidy + + | otherwise -- Externally-visible Ids get the whole lot + = vanillaIdInfo + `setArityInfo` arity + `setStrictnessInfo` final_sig + `setCprInfo` final_cpr + `setOccInfo` robust_occ_info + `setInlinePragInfo` (inlinePragInfo idinfo) + `setUnfoldingInfo` unfold_info + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + where + is_external = isExternalName name + + --------- OccInfo ------------ + robust_occ_info = zapFragileOcc (occInfo idinfo) + -- It's important to keep loop-breaker information + -- when we are doing -fexpose-all-unfoldings + + --------- Strictness ------------ + mb_bot_str = exprBotStrictness_maybe orig_rhs + + sig = strictnessInfo idinfo + final_sig | not $ isTopSig sig + = WARN( _bottom_hidden sig , ppr name ) sig + -- try a cheap-and-cheerful bottom analyser + | Just (_, nsig) <- mb_bot_str = nsig + | otherwise = sig + + cpr = cprInfo idinfo + final_cpr | Just _ <- mb_bot_str + = mkCprSig arity botCpr + | otherwise + = cpr + + _bottom_hidden id_sig = case mb_bot_str of + Nothing -> False + Just (arity, _) -> not (appIsDeadEnd id_sig arity) + + --------- Unfolding ------------ + unf_info = unfoldingInfo idinfo + unfold_info + | isCompulsoryUnfolding unf_info || show_unfold + = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs + | otherwise + = minimal_unfold_info + minimal_unfold_info = zapUnfolding unf_info + unf_from_rhs = mkFinalUnfolding dflags InlineRhs final_sig tidy_rhs + -- NB: do *not* expose the worker if show_unfold is off, + -- because that means this thing is a loop breaker or + -- marked NOINLINE or something like that + -- This is important: if you expose the worker for a loop-breaker + -- then you can make the simplifier go into an infinite loop, because + -- in effect the unfolding is exposed. See #1709 + -- + -- You might think that if show_unfold is False, then the thing should + -- not be w/w'd in the first place. But a legitimate reason is this: + -- the function returns bottom + -- In this case, show_unfold will be false (we don't expose unfoldings + -- for bottoming functions), but we might still have a worker/wrapper + -- split (see Note [Worker-wrapper for bottoming functions] in + -- GHC.Core.Opt.WorkWrap) + + + --------- Arity ------------ + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity orig_rhs + +{- +************************************************************************ +* * + Old, dead, type-trimming code +* * +************************************************************************ + +We used to try to "trim off" the constructors of data types that are +not exported, to reduce the size of interface files, at least without +-O. But that is not always possible: see the old Note [When we can't +trim types] below for exceptions. + +Then (#7445) I realised that the TH problem arises for any data type +that we have deriving( Data ), because we can invoke + Language.Haskell.TH.Quote.dataToExpQ +to get a TH Exp representation of a value built from that data type. +You don't even need {-# LANGUAGE TemplateHaskell #-}. + +At this point I give up. The pain of trimming constructors just +doesn't seem worth the gain. So I've dumped all the code, and am just +leaving it here at the end of the module in case something like this +is ever resurrected. + + +Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (#2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declaration of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (#5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) + = True + + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in GHC.Core.TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False + where + data_cons = tyConDataCons tc + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) +-} diff --git a/GHC/Iface/Tidy/StaticPtrTable.hs b/GHC/Iface/Tidy/StaticPtrTable.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Tidy/StaticPtrTable.hs @@ -0,0 +1,294 @@ +-- | Code generation for the Static Pointer Table +-- +-- (c) 2014 I/O Tweag +-- +-- Each module that uses 'static' keyword declares an initialization function of +-- the form hs_spt_init_\() which is emitted into the _stub.c file and +-- annotated with __attribute__((constructor)) so that it gets executed at +-- startup time. +-- +-- The function's purpose is to call hs_spt_insert to insert the static +-- pointers of this module in the hashtable of the RTS, and it looks something +-- like this: +-- +-- > static void hs_hpc_init_Main(void) __attribute__((constructor)); +-- > static void hs_hpc_init_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > extern StgPtr Main_r2wb_closure; +-- > hs_spt_insert(k0, &Main_r2wb_closure); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > extern StgPtr Main_r2wc_closure; +-- > hs_spt_insert(k1, &Main_r2wc_closure); +-- > +-- > } +-- +-- where the constants are fingerprints produced from the static forms. +-- +-- The linker must find the definitions matching the @extern StgPtr @ +-- declarations. For this to work, the identifiers of static pointers need to be +-- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'. +-- +-- There is also a finalization function for the time when the module is +-- unloaded. +-- +-- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); +-- > static void hs_hpc_fini_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > hs_spt_remove(k0); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > hs_spt_remove(k1); +-- > +-- > } +-- + +{-# LANGUAGE ViewPatterns, TupleSections #-} +module GHC.Iface.Tidy.StaticPtrTable + ( sptCreateStaticBinds + , sptModuleInitCode + ) where + +{- Note [Grand plan for static forms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Static forms go through the compilation phases as follows. +Here is a running example: + + f x = let k = map toUpper + in ...(static k)... + +* The renamer looks for out-of-scope names in the body of the static + form, as always. If all names are in scope, the free variables of the + body are stored in AST at the location of the static form. + +* The typechecker verifies that all free variables occurring in the + static form are floatable to top level (see Note [Meaning of + IdBindingInfo] in GHC.Tc.Types). In our example, 'k' is floatable. + Even though it is bound in a nested let, we are fine. + +* The desugarer replaces the static form with an application of the + function 'makeStatic' (defined in module GHC.StaticPtr.Internal of + base). So we get + + f x = let k = map toUpper + in ...fromStaticPtr (makeStatic location k)... + +* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic' + to the top level. Thus the FloatOut pass is always executed, even when + optimizations are disabled. So we get + + k = map toUpper + static_ptr = makeStatic location k + f x = ...fromStaticPtr static_ptr... + + The FloatOut pass is careful to produce an /exported/ Id for a floated + 'makeStatic' call, so the binding is not removed or inlined by the + simplifier. + E.g. the code for `f` above might look like + + static_ptr = makeStatic location k + f x = ...(case static_ptr of ...)... + + which might be simplified to + + f x = ...(case makeStatic location k of ...)... + + BUT the top-level binding for static_ptr must remain, so that it can be + collected to populate the Static Pointer Table. + + Making the binding exported also has a necessary effect during the + CoreTidy pass. + +* The CoreTidy pass replaces all bindings of the form + + b = /\ ... -> makeStatic location value + + with + + b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value + + where a distinct key is generated for each binding. + +* If we are compiling to object code we insert a C stub (generated by + sptModuleInitCode) into the final object which runs when the module is loaded, + inserting the static forms defined by the module into the RTS's static pointer + table. + +* If we are compiling for the byte-code interpreter, we instead explicitly add + the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter + process' SPT table using the addSptEntry interpreter message. This happens + in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). +-} + +import GHC.Prelude + +import GHC.Cmm.CLabel +import GHC.Core +import GHC.Core.Utils (collectMakeStaticArgs) +import GHC.Core.DataCon +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Types.Id +import GHC.Core.Make (mkStringExprFSWith) +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Utils.Outputable as Outputable +import GHC.Platform +import GHC.Builtin.Names +import GHC.Tc.Utils.Env (lookupGlobal) +import GHC.Core.Type + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State +import Data.List +import Data.Maybe +import GHC.Fingerprint +import qualified GHC.LanguageExtensions as LangExt + +-- | Replaces all bindings of the form +-- +-- > b = /\ ... -> makeStatic location value +-- +-- with +-- +-- > b = /\ ... -> +-- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value +-- +-- where a distinct key is generated for each binding. +-- +-- It also yields the C stub that inserts these bindings into the static +-- pointer table. +sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram + -> IO ([SptEntry], CoreProgram) +sptCreateStaticBinds hsc_env this_mod binds + | not (xopt LangExt.StaticPointers dflags) = + return ([], binds) + | otherwise = do + -- Make sure the required interface files are loaded. + _ <- lookupGlobal hsc_env unpackCStringName + (fps, binds') <- evalStateT (go [] [] binds) 0 + return (fps, binds') + where + go fps bs xs = case xs of + [] -> return (reverse fps, reverse bs) + bnd : xs' -> do + (fps', bnd') <- replaceStaticBind bnd + go (reverse fps' ++ fps) (bnd' : bs) xs' + + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + + -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. + -- + -- The 'Int' state is used to produce a different key for each binding. + replaceStaticBind :: CoreBind + -> StateT Int IO ([SptEntry], CoreBind) + replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e + return (maybeToList mfp, NonRec b' e') + replaceStaticBind (Rec rbs) = do + (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs + return (catMaybes mfps, Rec rbs') + + replaceStatic :: Id -> CoreExpr + -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) + replaceStatic b e@(collectTyBinders -> (tvs, e0)) = + case collectMakeStaticArgs e0 of + Nothing -> return (Nothing, (b, e)) + Just (_, t, info, arg) -> do + (fp, e') <- mkStaticBind t info arg + return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) + + mkStaticBind :: Type -> CoreExpr -> CoreExpr + -> StateT Int IO (Fingerprint, CoreExpr) + mkStaticBind t srcLoc e = do + i <- get + put (i + 1) + staticPtrInfoDataCon <- + lift $ lookupDataConHscEnv staticPtrInfoDataConName + let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i + info <- mkConApp staticPtrInfoDataCon <$> + (++[srcLoc]) <$> + mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) + [ unitFS $ moduleUnit this_mod + , moduleNameFS $ moduleName this_mod + ] + + -- The module interface of GHC.StaticPtr should be loaded at least + -- when looking up 'fromStatic' during type-checking. + staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName + return (fp, mkConApp staticPtrDataCon + [ Type t + , mkWord64LitWordRep platform w0 + , mkWord64LitWordRep platform w1 + , info + , e ]) + + mkStaticPtrFingerprint :: Int -> Fingerprint + mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" + [ unitString $ moduleUnit this_mod + , moduleNameString $ moduleName this_mod + , show n + ] + + -- Choose either 'Word64#' or 'Word#' to represent the arguments of the + -- 'Fingerprint' data constructor. + mkWord64LitWordRep platform = + case platformWordSize platform of + PW4 -> mkWord64LitWord64 + PW8 -> mkWordLit platform . toInteger + + lookupIdHscEnv :: Name -> IO Id + lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>= + maybe (getError n) (return . tyThingId) + + lookupDataConHscEnv :: Name -> IO DataCon + lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>= + maybe (getError n) (return . tyThingDataCon) + + getError n = pprPanic "sptCreateStaticBinds.get: not found" $ + text "Couldn't find" <+> ppr n + +-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries +-- of @module@ into the static pointer table. +-- +-- @fps@ is a list associating each binding corresponding to a static entry with +-- its fingerprint. +sptModuleInitCode :: Module -> [SptEntry] -> SDoc +sptModuleInitCode _ [] = Outputable.empty +sptModuleInitCode this_mod entries = vcat + [ text "static void hs_spt_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "static StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "extern StgPtr " + <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + $$ text "hs_spt_insert" <> parens + (hcat $ punctuate comma + [ char 'k' <> int i + , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) + ] + ) + <> semi + | (i, SptEntry n fp) <- zip [0..] entries + ] + , text "static void hs_spt_fini_" <> ppr this_mod + <> text "(void) __attribute__((destructor));" + , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi + | (i, (SptEntry _ fp)) <- zip [0..] entries + ] + ] + where + pprFingerprint :: Fingerprint -> SDoc + pprFingerprint (Fingerprint w1 w2) = + braces $ hcat $ punctuate comma + [ integer (fromIntegral w1) <> text "ULL" + , integer (fromIntegral w2) <> text "ULL" + ] diff --git a/GHC/Iface/Type.hs b/GHC/Iface/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Type.hs @@ -0,0 +1,2133 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +This module defines interface types and binders +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + -- FlexibleInstances for Binary (DefMethSpec IfaceType) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} + +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) +{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-incomplete-patterns #-} + -- N.B. This can be dropped once GHC 8.8 can be dropped as a + -- bootstrap compiler. +#endif + +module GHC.Iface.Type ( + IfExtName, IfLclName, + + IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), + IfaceMCoercion(..), + IfaceUnivCoProv(..), + IfaceMult, + IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), + IfaceTyLit(..), IfaceAppArgs(..), + IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, + IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, + IfaceForAllSpecBndr, + IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..), + mkIfaceForAllTvBndr, + mkIfaceTyConKind, + ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, + + ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, + ifTyConBinderVar, ifTyConBinderName, + + -- Equality testing + isIfaceLiftedTypeKind, + + -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags + appArgsIfaceTypes, appArgsIfaceTypesArgFlags, + + -- Printing + SuppressBndrSig(..), + UseBndrParens(..), + PrintExplicitKinds(..), + pprIfaceType, pprParendIfaceType, pprPrecIfaceType, + pprIfaceContext, pprIfaceContextArr, + pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, + pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, + pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, + pprIfaceSigmaType, pprIfaceTyLit, + pprIfaceCoercion, pprParendIfaceCoercion, + splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, + ppr_fun_arrow, + isIfaceTauType, + + suppressIfaceInvisibles, + stripIfaceInvisVars, + stripInvisArgs, + + mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst, + + many_ty + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Builtin.Types + ( coercibleTyCon, heqTyCon + , liftedRepDataConTyCon, tupleTyConName + , manyDataConTyCon, oneDataConTyCon ) +import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy ) + +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Var +import GHC.Builtin.Names +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc + +import Data.Maybe( isJust ) +import qualified Data.Semigroup as Semi +import Control.DeepSeq + +{- +************************************************************************ +* * + Local (nested) binders +* * +************************************************************************ +-} + +type IfLclName = FastString -- A local name in iface syntax + +type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax + -- (However Internal or System Names never should) + +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr + | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr + +type IfaceIdBndr = (IfaceType, IfLclName, IfaceType) +type IfaceTvBndr = (IfLclName, IfaceKind) + +ifaceTvBndrName :: IfaceTvBndr -> IfLclName +ifaceTvBndrName (n,_) = n + +ifaceIdBndrName :: IfaceIdBndr -> IfLclName +ifaceIdBndrName (_,n,_) = n + +ifaceBndrName :: IfaceBndr -> IfLclName +ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr +ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr + +ifaceBndrType :: IfaceBndr -> IfaceType +ifaceBndrType (IfaceIdBndr (_, _, t)) = t +ifaceBndrType (IfaceTvBndr (_, t)) = t + +type IfaceLamBndr = (IfaceBndr, IfaceOneShot) + +data IfaceOneShot -- See Note [Preserve OneShotInfo] in "GHC.Core.Tidy" + = IfaceNoOneShot -- and Note [The oneShot function] in "GHC.Types.Id.Make" + | IfaceOneShot + +instance Outputable IfaceOneShot where + ppr IfaceNoOneShot = text "NoOneShotInfo" + ppr IfaceOneShot = text "OneShot" + +{- +%************************************************************************ +%* * + IfaceType +%* * +%************************************************************************ +-} + +------------------------------- +type IfaceKind = IfaceType + +-- | A kind of universal type, used for types and kinds. +-- +-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' +-- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Core.Ppr.TyThing" +data IfaceType + = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] + | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon + | IfaceLitTy IfaceTyLit + | IfaceAppTy IfaceType IfaceAppArgs + -- See Note [Suppressing invisible arguments] for + -- an explanation of why the second field isn't + -- IfaceType, analogous to AppTy. + | IfaceFunTy AnonArgFlag IfaceMult IfaceType IfaceType + | IfaceForAllTy IfaceForAllBndr IfaceType + | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceCastTy IfaceType IfaceCoercion + | IfaceCoercionTy IfaceCoercion + + | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) + TupleSort -- What sort of tuple? + PromotionFlag -- A bit like IfaceTyCon + IfaceAppArgs -- arity = length args + -- For promoted data cons, the kind args are omitted + +type IfaceMult = IfaceType + +type IfacePredType = IfaceType +type IfaceContext = [IfacePredType] + +data IfaceTyLit + = IfaceNumTyLit Integer + | IfaceStrTyLit FastString + deriving (Eq) + +type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +type IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity + +-- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. +mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr +mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis + +-- | Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in "GHC.Core.TyCon". +mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind +mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind + mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af many_ty (ifaceBndrType tv) k + mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k + +ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr] -> [IfaceForAllBndr] +ifaceForAllSpecToBndrs = map ifaceForAllSpecToBndr + +ifaceForAllSpecToBndr :: IfaceForAllSpecBndr -> IfaceForAllBndr +ifaceForAllSpecToBndr (Bndr tv spec) = Bndr tv (Invisible spec) + +-- | Stores the arguments in a type application as a list. +-- See @Note [Suppressing invisible arguments]@. +data IfaceAppArgs + = IA_Nil + | IA_Arg IfaceType -- The type argument + + ArgFlag -- The argument's visibility. We store this here so + -- that we can: + -- + -- 1. Avoid pretty-printing invisible (i.e., specified + -- or inferred) arguments when + -- -fprint-explicit-kinds isn't enabled, or + -- 2. When -fprint-explicit-kinds *is*, enabled, print + -- specified arguments in @(...) and inferred + -- arguments in @{...}. + + IfaceAppArgs -- The rest of the arguments + +instance Semi.Semigroup IfaceAppArgs where + IA_Nil <> xs = xs + IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) + +instance Monoid IfaceAppArgs where + mempty = IA_Nil + mappend = (Semi.<>) + +-- Encodes type constructors, kind constructors, +-- coercion constructors, the lot. +-- We have to tag them in order to pretty print them +-- properly. +data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName + , ifaceTyConInfo :: IfaceTyConInfo } + deriving (Eq) + +-- | The various types of TyCons which have special, built-in syntax. +data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon + + | IfaceTupleTyCon !Arity !TupleSort + -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@. + -- The arity is the tuple width, not the tycon arity + -- (which is twice the width in the case of unboxed + -- tuples). + + | IfaceSumTyCon !Arity + -- ^ e.g. @(a | b | c)@ + + | IfaceEqualityTyCon + -- ^ A heterogeneous equality TyCon + -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon) + -- that is actually being applied to two types + -- of the same kind. This affects pretty-printing + -- only: see Note [Equality predicates in IfaceType] + deriving (Eq) + +instance Outputable IfaceTyConSort where + ppr IfaceNormalTyCon = text "normal" + ppr (IfaceTupleTyCon n sort) = ppr sort <> colon <> ppr n + ppr (IfaceSumTyCon n) = text "sum:" <> ppr n + ppr IfaceEqualityTyCon = text "equality" + +{- Note [Free tyvars in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to +an IfaceType and pretty printing that. This eliminates a lot of +pretty-print duplication, and it matches what we do with pretty- +printing TyThings. See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing. + +It works fine for closed types, but when printing debug traces (e.g. +when using -ddump-tc-trace) we print a lot of /open/ types. These +types are full of TcTyVars, and it's absolutely crucial to print them +in their full glory, with their unique, TcTyVarDetails etc. + +So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. +Note that: + +* We never expect to serialise an IfaceFreeTyVar into an interface file, nor + to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType + and then pretty-print" pipeline. + +We do the same for covars, naturally. + +Note [Equality predicates in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has several varieties of type equality (see Note [The equality types story] +in GHC.Builtin.Types.Prim for details). In an effort to avoid confusing users, we suppress +the differences during pretty printing unless certain flags are enabled. +Here is how each equality predicate* is printed in homogeneous and +heterogeneous contexts, depending on which combination of the +-fprint-explicit-kinds and -fprint-equality-relations flags is used: + +-------------------------------------------------------------------------------------------- +| Predicate | Neither flag | -fprint-explicit-kinds | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +|-------------------------------|----------------------------|-----------------------------| +| Predicate | -fprint-equality-relations | Both flags | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | +| a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +-------------------------------------------------------------------------------------------- + +(* There is no heterogeneous, representational, lifted equality counterpart +to (~~). There could be, but there seems to be no use for it.) + +This table adheres to the following rules: + +A. With -fprint-equality-relations, print the true equality relation. +B. Without -fprint-equality-relations: + i. If the equality is representational and homogeneous, use Coercible. + ii. Otherwise, if the equality is representational, use ~R#. + iii. If the equality is nominal and homogeneous, use ~. + iv. Otherwise, if the equality is nominal, use ~~. +C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator, + as above; or print the kind with Coercible. +D. Without -fprint-explicit-kinds, don't print kinds. + +A hetero-kinded equality is used homogeneously when it is applied to two +identical kinds. Unfortunately, determining this from an IfaceType isn't +possible since we can't see through type synonyms. Consequently, we need to +record whether this particular application is homogeneous in IfaceTyConSort +for the purposes of pretty-printing. + +See Note [The equality types story] in GHC.Builtin.Types.Prim. +-} + +data IfaceTyConInfo -- Used to guide pretty-printing + -- and to disambiguate D from 'D (they share a name) + = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag + , ifaceTyConSort :: IfaceTyConSort } + deriving (Eq) + +data IfaceMCoercion + = IfaceMRefl + | IfaceMCo IfaceCoercion + +data IfaceCoercion + = IfaceReflCo IfaceType + | IfaceGReflCo Role IfaceType (IfaceMCoercion) + | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion + | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] + | IfaceAppCo IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion + | IfaceCoVarCo IfLclName + | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] + | IfaceAxiomRuleCo IfLclName [IfaceCoercion] + -- There are only a fixed number of CoAxiomRules, so it suffices + -- to use an IfaceLclName to distinguish them. + -- See Note [Adding built-in type families] in GHC.Builtin.Types.Literals + | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType + | IfaceSymCo IfaceCoercion + | IfaceTransCo IfaceCoercion IfaceCoercion + | IfaceNthCo Int IfaceCoercion + | IfaceLRCo LeftOrRight IfaceCoercion + | IfaceInstCo IfaceCoercion IfaceCoercion + | IfaceKindCo IfaceCoercion + | IfaceSubCo IfaceCoercion + | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] + | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] + +data IfaceUnivCoProv + = IfacePhantomProv IfaceCoercion + | IfaceProofIrrelProv IfaceCoercion + | IfacePluginProv String + +{- Note [Holes in IfaceCoercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking fails the typechecker will produce a HoleCo to stand +in place of the unproven assertion. While we generally don't want to +let these unproven assertions leak into interface files, we still need +to be able to pretty-print them as we use IfaceType's pretty-printer +to render Types. For this reason IfaceCoercion has a IfaceHoleCo +constructor; however, we fails when asked to serialize to a +IfaceHoleCo to ensure that they don't end up in an interface file. + + +%************************************************************************ +%* * + Functions over IFaceTypes +* * +************************************************************************ +-} + +ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool +ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key + +isIfaceLiftedTypeKind :: IfaceKind -> Bool +isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) + = isLiftedTypeKindTyConName (ifaceTyConName tc) +isIfaceLiftedTypeKind (IfaceTyConApp tc + (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil) + Required IA_Nil)) + = tc `ifaceTyConHasKey` tYPETyConKey + && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey +isIfaceLiftedTypeKind _ = False + +splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) +-- Mainly for printing purposes +-- +-- Here we split nested IfaceSigmaTy properly. +-- +-- @ +-- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b) +-- @ +-- +-- If you called @splitIfaceSigmaTy@ on this type: +-- +-- @ +-- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b)) +-- @ +splitIfaceSigmaTy ty + = case (bndrs, theta) of + ([], []) -> (bndrs, theta, tau) + _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau + in (bndrs ++ bndrs', theta ++ theta', tau') + where + (bndrs, rho) = split_foralls ty + (theta, tau) = split_rho rho + + split_foralls (IfaceForAllTy bndr ty) + = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } + split_foralls rho = ([], rho) + + split_rho (IfaceFunTy InvisArg _ ty1 ty2) + = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } + split_rho tau = ([], tau) + +suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a] +suppressIfaceInvisibles (PrintExplicitKinds True) _tys xs = xs +suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs + where + suppress _ [] = [] + suppress [] a = a + suppress (k:ks) (x:xs) + | isInvisibleTyConBinder k = suppress ks xs + | otherwise = x : suppress ks xs + +stripIfaceInvisVars :: PrintExplicitKinds -> [IfaceTyConBinder] -> [IfaceTyConBinder] +stripIfaceInvisVars (PrintExplicitKinds True) tyvars = tyvars +stripIfaceInvisVars (PrintExplicitKinds False) tyvars + = filterOut isInvisibleTyConBinder tyvars + +-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. +ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr +ifForAllBndrVar = binderVar + +-- | Extract the variable name from an 'IfaceForAllBndr'. +ifForAllBndrName :: IfaceForAllBndr -> IfLclName +ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) + +-- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. +ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr +ifTyConBinderVar = binderVar + +-- | Extract the variable name from an 'IfaceTyConBinder'. +ifTyConBinderName :: IfaceTyConBinder -> IfLclName +ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) + +ifTypeIsVarFree :: IfaceType -> Bool +-- Returns True if the type definitely has no variables at all +-- Just used to control pretty printing +ifTypeIsVarFree ty = go ty + where + go (IfaceTyVar {}) = False + go (IfaceFreeTyVar {}) = False + go (IfaceAppTy fun args) = go fun && go_args args + go (IfaceFunTy _ w arg res) = go w && go arg && go res + go (IfaceForAllTy {}) = False + go (IfaceTyConApp _ args) = go_args args + go (IfaceTupleTy _ _ args) = go_args args + go (IfaceLitTy _) = True + go (IfaceCastTy {}) = False -- Safe + go (IfaceCoercionTy {}) = False -- Safe + + go_args IA_Nil = True + go_args (IA_Arg arg _ args) = go arg && go_args args + +{- Note [Substitution on IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Substitutions on IfaceType are done only during pretty-printing to +construct the result type of a GADT, and does not deal with binders +(eg IfaceForAll), so it doesn't need fancy capture stuff. -} + +type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType] + +mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst +-- See Note [Substitution on IfaceType] +mkIfaceTySubst eq_spec = mkFsEnv eq_spec + +inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool +-- See Note [Substitution on IfaceType] +inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs) + +substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +-- See Note [Substitution on IfaceType] +substIfaceType env ty + = go ty + where + go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv + go (IfaceTyVar tv) = substIfaceTyVar env tv + go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) + go (IfaceFunTy af w t1 t2) = IfaceFunTy af (go w) (go t1) (go t2) + go ty@(IfaceLitTy {}) = ty + go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys) + go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys) + go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) + go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) + + go_mco IfaceMRefl = IfaceMRefl + go_mco (IfaceMCo co) = IfaceMCo $ go_co co + + go_co (IfaceReflCo ty) = IfaceReflCo (go ty) + go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) + go_co (IfaceFunCo r w c1 c2) = IfaceFunCo r (go_co w) (go_co c1) (go_co c2) + go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) + go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) + go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) + go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv + go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv + go_co (IfaceHoleCo cv) = IfaceHoleCo cv + go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) + go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) + go_co (IfaceSymCo co) = IfaceSymCo (go_co co) + go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) + go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) + go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) + go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) + go_co (IfaceKindCo co) = IfaceKindCo (go_co co) + go_co (IfaceSubCo co) = IfaceSubCo (go_co co) + go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) + + go_cos = map go_co + + go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) + go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) + go_prov (IfacePluginProv str) = IfacePluginProv str + +substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs +substIfaceAppArgs env args + = go args + where + go IA_Nil = IA_Nil + go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) + +substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar env tv + | Just ty <- lookupFsEnv env tv = ty + | otherwise = IfaceTyVar tv + + +{- +************************************************************************ +* * + Functions over IfaceAppArgs +* * +************************************************************************ +-} + +stripInvisArgs :: PrintExplicitKinds -> IfaceAppArgs -> IfaceAppArgs +stripInvisArgs (PrintExplicitKinds True) tys = tys +stripInvisArgs (PrintExplicitKinds False) tys = suppress_invis tys + where + suppress_invis c + = case c of + IA_Nil -> IA_Nil + IA_Arg t argf ts + | isVisibleArgFlag argf + -> IA_Arg t argf $ suppress_invis ts + -- Keep recursing through the remainder of the arguments, as it's + -- possible that there are remaining invisible ones. + -- See the "In type declarations" section of Note [VarBndrs, + -- TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + | otherwise + -> suppress_invis ts + +appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] +appArgsIfaceTypes IA_Nil = [] +appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts + +appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] +appArgsIfaceTypesArgFlags IA_Nil = [] +appArgsIfaceTypesArgFlags (IA_Arg t a ts) + = (t, a) : appArgsIfaceTypesArgFlags ts + +ifaceVisAppArgsLength :: IfaceAppArgs -> Int +ifaceVisAppArgsLength = go 0 + where + go !n IA_Nil = n + go n (IA_Arg _ argf rest) + | isVisibleArgFlag argf = go (n+1) rest + | otherwise = go n rest + +{- +Note [Suppressing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceAppArgs data type to specify which of the arguments to a type +should be displayed when pretty-printing, under the control of +-fprint-explicit-kinds. +See also Type.filterOutInvisibleTypes. +For example, given + + T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism + 'Just :: forall k. k -> 'Maybe k -- Promoted + +we want + + T * Tree Int prints as T Tree Int + 'Just * prints as Just * + +For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, +since the corresponding Core constructor: + + data Type + = ... + | TyConApp TyCon [Type] + +Already puts all of its arguments into a list. So when converting a Type to an +IfaceType (see toIfaceAppArgsX in GHC.Core.ToIface), we simply use the kind of +the TyCon (which is cached) to guide the process of converting the argument +Types into an IfaceAppArgs list. + +We also want this behavior for IfaceAppTy, since given: + + data Proxy (a :: k) + f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) + +We want to print the return type as `Proxy (t True)` without the use of +-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the +tycon case, because the corresponding Core constructor for IfaceAppTy: + + data Type + = ... + | AppTy Type Type + +Only stores one argument at a time. Therefore, when converting an AppTy to an +IfaceAppTy (in toIfaceTypeX in GHC.CoreToIface), we: + +1. Flatten the chain of AppTys down as much as possible +2. Use typeKind to determine the function Type's kind +3. Use this kind to guide the process of converting the argument Types into an + IfaceAppArgs list. + +By flattening the arguments like this, we obtain two benefits: + +(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as + we do IfaceTyApp arguments, which means that we only need to implement the + logic to filter out invisible arguments once. +(b) Unlike for tycons, finding the kind of a type in general (through typeKind) + is not a constant-time operation, so by flattening the arguments first, we + decrease the number of times we have to call typeKind. + +Note [Pretty-printing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Suppressing invisible arguments] is all about how to avoid printing +invisible arguments when the -fprint-explicit-kinds flag is disables. Well, +what about when it's enabled? Then we can and should print invisible kind +arguments, and this Note explains how we do it. + +As two running examples, consider the following code: + + {-# LANGUAGE PolyKinds #-} + data T1 a + data T2 (a :: k) + +When displaying these types (with -fprint-explicit-kinds on), we could just +do the following: + + T1 k a + T2 k a + +That certainly gets the job done. But it lacks a crucial piece of information: +is the `k` argument inferred or specified? To communicate this, we use visible +kind application syntax to distinguish the two cases: + + T1 @{k} a + T2 @k a + +Here, @{k} indicates that `k` is an inferred argument, and @k indicates that +`k` is a specified argument. (See +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for +a lengthier explanation on what "inferred" and "specified" mean.) + +************************************************************************ +* * + Pretty-printing +* * +************************************************************************ +-} + +if_print_coercions :: SDoc -- ^ if printing coercions + -> SDoc -- ^ otherwise + -> SDoc +if_print_coercions yes no + = sdocOption sdocPrintExplicitCoercions $ \print_co -> + getPprStyle $ \style -> + getPprDebug $ \debug -> + if print_co || dumpStyle style || debug + then yes + else no + +pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc +pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 + = maybeParen ctxt_prec opPrec $ + sep [pp_ty1, pp_tc <+> pp_ty2] + +pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp ctxt_prec pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen ctxt_prec appPrec $ + hang pp_fun 2 (sep pp_tys) + +isIfaceTauType :: IfaceType -> Bool +isIfaceTauType (IfaceForAllTy _ _) = False +isIfaceTauType (IfaceFunTy InvisArg _ _ _) = False +isIfaceTauType _ = True + +-- ----------------------------- Printing binders ------------------------------------ + +instance Outputable IfaceBndr where + ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <> pprIfaceTvBndr bndr (SuppressBndrSig False) + (UseBndrParens False) + +pprIfaceBndrs :: [IfaceBndr] -> SDoc +pprIfaceBndrs bs = sep (map ppr bs) + +pprIfaceLamBndr :: IfaceLamBndr -> SDoc +pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b +pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" + +pprIfaceIdBndr :: IfaceIdBndr -> SDoc +pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr w) <+> dcolon <+> ppr ty) + +{- Note [Suppressing binder signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When printing the binders in a 'forall', we want to keep the kind annotations: + + forall (a :: k). blah + ^^^^ + good + +On the other hand, when we print the binders of a data declaration in :info, +the kind information would be redundant due to the standalone kind signature: + + type F :: Symbol -> Type + type F (s :: Symbol) = blah + ^^^^^^^^^ + redundant + +Here we'd like to omit the kind annotation: + + type F :: Symbol -> Type + type F s = blah + +Note [Printing type abbreviations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) and +`FUN 'Many` as `(->)`. +This way, error messages don't refer to levity polymorphism or linearity +if it is not necessary. + +However, when printing the definition of Type or (->) with :info, +this would give confusing output: `type (->) = (->)` (#18594). +Solution: detect when we are in :info and disable displaying the synonym +with the SDoc option sdocPrintTypeAbbreviations. + +If there will be a need, in the future we could expose it as a flag +-fprint-type-abbreviations or even two separate flags controlling +TYPE 'LiftedRep and FUN 'Many. +-} + +-- | Do we want to suppress kind annotations on binders? +-- See Note [Suppressing binder signatures] +newtype SuppressBndrSig = SuppressBndrSig Bool + +newtype UseBndrParens = UseBndrParens Bool +newtype PrintExplicitKinds = PrintExplicitKinds Bool + +pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc +pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) + | suppress_sig = ppr tv + | isIfaceLiftedTypeKind ki = ppr tv + | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) + where + maybe_parens | use_parens = parens + | otherwise = id + +pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinder] -> SDoc +pprIfaceTyConBinders suppress_sig = sep . map go + where + go :: IfaceTyConBinder -> SDoc + go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr + go (Bndr (IfaceTvBndr bndr) vis) = + -- See Note [Pretty-printing invisible arguments] + case vis of + AnonTCB VisArg -> ppr_bndr (UseBndrParens True) + AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) + -- Should we print these differently? + NamedTCB Required -> ppr_bndr (UseBndrParens True) + -- See Note [Explicit Case Statement for Specificity] + NamedTCB (Invisible spec) -> case spec of + SpecifiedSpec -> char '@' <> ppr_bndr (UseBndrParens True) + InferredSpec -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + where + ppr_bndr = pprIfaceTvBndr bndr suppress_sig + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) + +instance Binary IfaceOneShot where + put_ bh IfaceNoOneShot = do + putByte bh 0 + put_ bh IfaceOneShot = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return IfaceNoOneShot + _ -> do return IfaceOneShot + +-- ----------------------------- Printing IfaceType ------------------------------------ + +--------------------------------- +instance Outputable IfaceType where + ppr ty = pprIfaceType ty + +pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc +pprIfaceType = pprPrecIfaceType topPrec +pprParendIfaceType = pprPrecIfaceType appPrec + +pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc +-- We still need `hideNonStandardTypes`, since the `pprPrecIfaceType` may be +-- called from other places, besides `:type` and `:info`. +pprPrecIfaceType prec ty = + hideNonStandardTypes (ppr_ty prec) ty + +ppr_fun_arrow :: IfaceMult -> SDoc +ppr_fun_arrow w + | (IfaceTyConApp tc _) <- w + , tc `ifaceTyConHasKey` (getUnique manyDataConTyCon) = arrow + | (IfaceTyConApp tc _) <- w + , tc `ifaceTyConHasKey` (getUnique oneDataConTyCon) = lollipop + | otherwise = mulArrow (pprIfaceType w) + +ppr_sigma :: PprPrec -> IfaceType -> SDoc +ppr_sigma ctxt_prec ty + = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) + +ppr_ty :: PprPrec -> IfaceType -> SDoc +ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty +ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty + +ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! +ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType] +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys +ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys +ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n + -- Function types +ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2) -- Should be VisArg + = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + maybeParen ctxt_prec funPrec $ + sep [ppr_ty funPrec ty1, sep (ppr_fun_tail w ty2)] + where + ppr_fun_tail wthis (IfaceFunTy VisArg wnext ty1 ty2) + = (ppr_fun_arrow wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 + ppr_fun_tail wthis other_ty + = [ppr_fun_arrow wthis <+> pprIfaceType other_ty] + +ppr_ty ctxt_prec (IfaceAppTy t ts) + = if_print_coercions + ppr_app_ty + ppr_app_ty_no_casts + where + ppr_app_ty = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + let tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs + (PrintExplicitKinds print_kinds) ts + in pprIfacePrefixApp ctxt_prec + (ppr_ty funPrec t) + (map (ppr_app_arg appPrec) tys_wo_kinds) + + + -- Strip any casts from the head of the application + ppr_app_ty_no_casts = + case t of + IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) + _ -> ppr_app_ty + + mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType + mk_app_tys (IfaceTyConApp tc tys1) tys2 = + IfaceTyConApp tc (tys1 `mappend` tys2) + mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 + +ppr_ty ctxt_prec (IfaceCastTy ty co) + = if_print_coercions + (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) + (ppr_ty ctxt_prec ty) + +ppr_ty ctxt_prec (IfaceCoercionTy co) + = if_print_coercions + (ppr_co ctxt_prec co) + (text "<>") + +{- Note [Defaulting RuntimeRep variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RuntimeRep variables are considered by many (most?) users to be little +more than syntactic noise. When the notion was introduced there was a +significant and understandable push-back from those with pedagogy in +mind, which argued that RuntimeRep variables would throw a wrench into +nearly any teach approach since they appear in even the lowly ($) +function's type, + + ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b + +which is significantly less readable than its non RuntimeRep-polymorphic type of + + ($) :: (a -> b) -> a -> b + +Moreover, unboxed types don't appear all that often in run-of-the-mill +Haskell programs, so it makes little sense to make all users pay this +syntactic overhead. + +For this reason it was decided that we would hide RuntimeRep variables +for now (see #11549). We do this by defaulting all type variables of +kind RuntimeRep to LiftedRep. +Likewise, we default all Multiplicity variables to Many. + +This is done in a pass right before pretty-printing +(defaultNonStandardVars, controlled by +-fprint-explicit-runtime-reps and -XLinearTypes) + +This applies to /quantified/ variables like 'w' above. What about +variables that are /free/ in the type being printed, which certainly +happens in error messages. Suppose (#16074) we are reporting a +mismatch between two skolems + (a :: RuntimeRep) ~ (b :: RuntimeRep) +We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"! + +But if we are printing the type + (forall (a :: Type r). blah +we do want to turn that (free) r into LiftedRep, so it prints as + (forall a. blah) + +Conclusion: keep track of whether we are in the kind of a +binder; only if so, convert free RuntimeRep variables to LiftedRep. +-} + +-- | Default 'RuntimeRep' variables to 'LiftedRep', and 'Multiplicity' +-- variables to 'Many'. For example: +-- +-- @ +-- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). +-- (a -> b) -> a -> b +-- Just :: forall (k :: Multiplicity) a. a # k -> Maybe a +-- @ +-- +-- turns in to, +-- +-- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ +-- @ Just :: forall a . a -> Maybe a @ +-- +-- We do this to prevent RuntimeRep and Multiplicity variables from +-- incurring a significant syntactic overhead in otherwise simple +-- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] +-- and #11549 for further discussion. +defaultNonStandardVars :: Bool -> Bool -> IfaceType -> IfaceType +defaultNonStandardVars do_runtimereps do_multiplicities ty = go False emptyFsEnv ty + where + go :: Bool -- True <=> Inside the kind of a binder + -> FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables + -> IfaceType + -> IfaceType + go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) + | isInvisibleArgFlag argf -- Don't default *visible* quantification + -- or we get the mess in #13963 + , Just substituted_ty <- check_substitution var_kind + = let subs' = extendFsEnv subs var substituted_ty + -- Record that we should replace it with LiftedRep, + -- and recurse, discarding the forall + in go ink subs' ty + + go ink subs (IfaceForAllTy bndr ty) + = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty) + + go _ subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of + Just s -> s + Nothing -> ty + + go in_kind _ ty@(IfaceFreeTyVar tv) + -- See Note [Defaulting RuntimeRep variables], about free vars + | in_kind && do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) + = liftedRep_ty + | do_multiplicities && GHC.Core.Type.isMultiplicityTy (tyVarKind tv) + = many_ty + | otherwise + = ty + + go ink subs (IfaceTyConApp tc tc_args) + = IfaceTyConApp tc (go_args ink subs tc_args) + + go ink subs (IfaceTupleTy sort is_prom tc_args) + = IfaceTupleTy sort is_prom (go_args ink subs tc_args) + + go ink subs (IfaceFunTy af w arg res) + = IfaceFunTy af (go ink subs w) (go ink subs arg) (go ink subs res) + + go ink subs (IfaceAppTy t ts) + = IfaceAppTy (go ink subs t) (go_args ink subs ts) + + go ink subs (IfaceCastTy x co) + = IfaceCastTy (go ink subs x) co + + go _ _ ty@(IfaceLitTy {}) = ty + go _ _ ty@(IfaceCoercionTy {}) = ty + + go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr + go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf) + = Bndr (IfaceIdBndr (w, n, go True subs t)) argf + go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) + = Bndr (IfaceTvBndr (n, go True subs t)) argf + + go_args :: Bool -> FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs + go_args _ _ IA_Nil = IA_Nil + go_args ink subs (IA_Arg ty argf args) + = IA_Arg (go ink subs ty) argf (go_args ink subs args) + + check_substitution :: IfaceType -> Maybe IfaceType + check_substitution (IfaceTyConApp tc _) + | do_runtimereps, tc `ifaceTyConHasKey` runtimeRepTyConKey = Just liftedRep_ty + | do_multiplicities, tc `ifaceTyConHasKey` multiplicityTyConKey = Just many_ty + check_substitution _ = Nothing + +liftedRep_ty :: IfaceType +liftedRep_ty = + IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName liftedRepDataConTyCon + +many_ty :: IfaceType +many_ty = + IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName manyDataConTyCon + +hideNonStandardTypes :: (IfaceType -> SDoc) -> IfaceType -> SDoc +hideNonStandardTypes f ty + = sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps -> + sdocOption sdocLinearTypes $ \linearTypes -> + getPprStyle $ \sty -> + let do_runtimerep = not printExplicitRuntimeReps + do_multiplicity = not linearTypes + in if userStyle sty + then f (defaultNonStandardVars do_runtimerep do_multiplicity ty) + else f ty + +instance Outputable IfaceAppArgs where + ppr tca = pprIfaceAppArgs tca + +pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc +pprIfaceAppArgs = ppr_app_args topPrec +pprParendIfaceAppArgs = ppr_app_args appPrec + +ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc +ppr_app_args ctx_prec = go + where + go :: IfaceAppArgs -> SDoc + go IA_Nil = empty + go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts + +-- See Note [Pretty-printing invisible arguments] +ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc +ppr_app_arg ctx_prec (t, argf) = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + case argf of + Required -> ppr_ty ctx_prec t + Specified | print_kinds + -> char '@' <> ppr_ty appPrec t + Inferred | print_kinds + -> char '@' <> braces (ppr_ty topPrec t) + _ -> empty + +------------------- +pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc + +-- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. +pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPartMust tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc + +pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc +pprIfaceForAllCoPart tvs sdoc + = sep [ pprIfaceForAllCo tvs, sdoc ] + +ppr_iface_forall_part :: ShowForAllFlag + -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +ppr_iface_forall_part show_forall tvs ctxt sdoc + = sep [ case show_forall of + ShowForAllMust -> pprIfaceForAll tvs + ShowForAllWhen -> pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +pprIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll bndrs@(Bndr _ vis : _) + = sep [ add_separator (forAllLit <+> fsep docs) + , pprIfaceForAll bndrs' ] + where + (bndrs', docs) = ppr_itv_bndrs bndrs vis + + add_separator stuff = case vis of + Required -> stuff <+> arrow + _inv -> stuff <> dot + + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +ppr_itv_bndrs :: [IfaceForAllBndr] + -> ArgFlag -- ^ visibility of the first binder in the list + -> ([IfaceForAllBndr], [SDoc]) +ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 + | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + (bndrs', pprIfaceForAllBndr bndr : doc) + | otherwise = (all_bndrs, []) +ppr_itv_bndrs [] _ = ([], []) + +pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCo [] = empty +pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot + +pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs + +pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc +pprIfaceForAllBndr bndr = + case bndr of + Bndr (IfaceTvBndr tv) Inferred -> + braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) + Bndr (IfaceTvBndr tv) _ -> + pprIfaceTvBndr tv suppress_sig (UseBndrParens True) + Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv + where + -- See Note [Suppressing binder signatures] + suppress_sig = SuppressBndrSig False + +pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc +pprIfaceForAllCoBndr (tv, kind_co) + = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) + +-- | Show forall flag +-- +-- Unconditionally show the forall quantifier with ('ShowForAllMust') +-- or when ('ShowForAllWhen') the names used are free in the binder +-- or when compiling with -fprint-explicit-foralls. +data ShowForAllFlag = ShowForAllMust | ShowForAllWhen + +pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc +pprIfaceSigmaType show_forall ty + = hideNonStandardTypes ppr_fn ty + where + ppr_fn iface_ty = + let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty + in ppr_iface_forall_part show_forall tvs theta (ppr tau) + +pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprUserIfaceForAll tvs + = sdocOption sdocPrintExplicitForalls $ \print_foralls -> + -- See Note [When to print foralls] in this module. + ppWhen (any tv_has_kind_var tvs + || any tv_is_required tvs + || print_foralls) $ + pprIfaceForAll tvs + where + tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) + = not (ifTypeIsVarFree kind) + tv_has_kind_var _ = False + + tv_is_required = isVisibleArgFlag . binderArgFlag + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We opt to explicitly pretty-print `forall`s if any of the following +criteria are met: + +1. -fprint-explicit-foralls is on. + +2. A bound type variable has a polymorphic kind. E.g., + + forall k (a::k). Proxy a -> Proxy a + + Since a's kind mentions a variable k, we print the foralls. + +3. A bound type variable is a visible argument (#14238). + Suppose we are printing the kind of: + + T :: forall k -> k -> Type + + The "forall k ->" notation means that this kind argument is required. + That is, it must be supplied at uses of T. E.g., + + f :: T (Type->Type) Monad -> Int + + So we print an explicit "T :: forall k -> k -> Type", + because omitting it and printing "T :: k -> Type" would be + utterly misleading. + + See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + in GHC.Core.TyCo.Rep. + +N.B. Until now (Aug 2018) we didn't check anything for coercion variables. + +Note [Printing foralls in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the same criteria as in Note [When to print foralls] to determine +whether a type family instance should be pretty-printed with an explicit +`forall`. Example: + + type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo (a :: Type) = Int + Foo a = a + +Without -fprint-explicit-foralls enabled, this will be pretty-printed as: + +type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo a = Int + forall k (a :: k). Foo a = a + +Note that only the third equation has an explicit forall, since it has a type +variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then +the second equation would be preceded with `forall a.`.) + +There is one tricky point in the implementation: what visibility +do we give the type variables in a type family instance? Type family instances +only store type *variables*, not type variable *binders*, and only the latter +has visibility information. We opt to default the visibility of each of these +type variables to Specified because users can't ever instantiate these +variables manually, so the choice of visibility is only relevant to +pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is +printed the way it is, even though it wasn't written explicitly in the +original source code.) + +We adopt the same strategy for data family instances. Example: + + data family DF (a :: k) + data instance DF '[a, b] = DFList + +That data family instance is pretty-printed as: + + data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList + +This is despite that the representation tycon for this data instance (call it +$DF:List) actually has different visibilities for its binders. +However, the visibilities of these binders are utterly irrelevant to the +programmer, who cares only about the specificity of variables in `DF`'s type, +not $DF:List's type. Therefore, we opt to pretty-print all variables in data +family instances as Specified. + +Note [Printing promoted type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi session (#14343) + > _ :: Proxy '[ 'True ] + error: + Found hole: _ :: Proxy '['True] + +This would be bad, because the '[' looks like a character literal. +Solution: in type-level lists and tuples, add a leading space +if the first type is itself promoted. See pprSpaceIfPromotedTyCon. +-} + + +------------------- + +-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. +-- See Note [Printing promoted type constructors] +pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc +pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) + = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of + IsPromoted -> (space <>) + _ -> id +pprSpaceIfPromotedTyCon _ + = id + +-- See equivalent function in "GHC.Core.TyCo.Rep" +pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep + (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) + 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceType -> ([IfaceType], Maybe IfaceType) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tc `ifaceTyConHasKey` consDataConKey + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `ifaceTyConHasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args + +pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprTyTcApp ctxt_prec tc tys = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations -> + getPprDebug $ \debug -> + + if | ifaceTyConName tc `hasKey` ipClassKey + , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) + Required (IA_Arg ty Required IA_Nil) <- tys + -> maybeParen ctxt_prec funPrec + $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty + + | IfaceTupleTyCon arity sort <- ifaceTyConSort info + , not debug + , arity == ifaceVisAppArgsLength tys + -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys + + | IfaceSumTyCon arity <- ifaceTyConSort info + -> pprSum arity (ifaceTyConIsPromoted info) tys + + | tc `ifaceTyConHasKey` consDataConKey + , False <- print_kinds + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf + -> pprIfaceTyList ctxt_prec ty1 ty2 + + | tc `ifaceTyConHasKey` tYPETyConKey + , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys + , rep `ifaceTyConHasKey` liftedRepDataConKey + , print_type_abbreviations -- See Note [Printing type abbreviations] + -> ppr_kind_type ctxt_prec + + | tc `ifaceTyConHasKey` funTyConKey + , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys + , rep `ifaceTyConHasKey` manyDataConKey + , print_type_abbreviations -- See Note [Printing type abbreviations] + -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) $ + appArgsIfaceTypes $ stripInvisArgs (PrintExplicitKinds print_kinds) args) + + | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey + , not debug + -- Suppress detail unless you _really_ want to see + -> text "(TypeError ...)" + + | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) + -> doc + + | otherwise + -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $ + appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys + where + info = ifaceTyConInfo tc + +ppr_kind_type :: PprPrec -> SDoc +ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case + False -> text "Type" + True -> maybeParen ctxt_prec starPrec $ + unicodeSyntax (char '★') (char '*') + +-- | Pretty-print a type-level equality. +-- Returns (Just doc) if the argument is a /saturated/ application +-- of eqTyCon (~) +-- eqPrimTyCon (~#) +-- eqReprPrimTyCon (~R#) +-- heqTyCon (~~) +-- +-- See Note [Equality predicates in IfaceType] +-- and Note [The equality types story] in GHC.Builtin.Types.Prim +ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc +ppr_equality ctxt_prec tc args + | hetero_eq_tc + , [k1, k2, t1, t2] <- args + = Just $ print_equality (k1, k2, t1, t2) + + | hom_eq_tc + , [k, t1, t2] <- args + = Just $ print_equality (k, k, t1, t2) + + | otherwise + = Nothing + where + homogeneous = tc_name `hasKey` eqTyConKey -- (~) + || hetero_tc_used_homogeneously + where + hetero_tc_used_homogeneously + = case ifaceTyConSort $ ifaceTyConInfo tc of + IfaceEqualityTyCon -> True + _other -> False + -- True <=> a heterogeneous equality whose arguments + -- are (in this case) of the same kind + + tc_name = ifaceTyConName tc + pp = ppr_ty + hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) + hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) + || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) + || tc_name `hasKey` heqTyConKey -- (~~) + nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) + || tc_name `hasKey` eqPrimTyConKey -- (~#) + print_equality args = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sdocOption sdocPrintEqualityRelations $ \print_eqs -> + getPprStyle $ \style -> + getPprDebug $ \debug -> + print_equality' args print_kinds + (print_eqs || dumpStyle style || debug) + + print_equality' (ki1, ki2, ty1, ty2) print_kinds print_eqs + | -- If -fprint-equality-relations is on, just print the original TyCon + print_eqs + = ppr_infix_eq (ppr tc) + + | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) + -- or unlifted equality (ty1 ~# ty2) + nominal_eq_tc, homogeneous + = ppr_infix_eq (text "~") + + | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) + not homogeneous + = ppr_infix_eq (ppr heqTyCon) + + | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) + tc_name `hasKey` eqReprPrimTyConKey, homogeneous + = let ki | print_kinds = [pp appPrec ki1] + | otherwise = [] + in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) + (ki ++ [pp appPrec ty1, pp appPrec ty2]) + + -- The other cases work as you'd expect + | otherwise + = ppr_infix_eq (ppr tc) + where + ppr_infix_eq :: SDoc -> SDoc + ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op + (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) + where + pp_ty_ki ty ki + | print_kinds + = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) + | otherwise + = pp opPrec ty + + +pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = + ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc + (map (, Required) tys) + -- We are trying to re-use ppr_iface_tc_app here, which requires its + -- arguments to be accompanied by visibilities. But visibility is + -- irrelevant when printing coercions, so just default everything to + -- Required. + +-- | Pretty-prints an application of a type constructor to some arguments +-- (whose visibilities are known). This is polymorphic (over @a@) since we use +-- this function to pretty-print two different things: +-- +-- 1. Types (from `pprTyTcApp'`) +-- +-- 2. Coercions (from 'pprIfaceCoTcApp') +ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc +ppr_iface_tc_app pp _ tc [ty] + | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) + +ppr_iface_tc_app pp ctxt_prec tc tys + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + = ppr_kind_type ctxt_prec + + | not (isSymOcc (nameOccName (ifaceTyConName tc))) + = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + + | [ ty1@(_, Required) + , ty2@(_, Required) ] <- tys + -- Infix, two visible arguments (we know nothing of precedence though). + -- Don't apply this special case if one of the arguments is invisible, + -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). + = pprIfaceInfixApp ctxt_prec (ppr tc) + (pp opPrec ty1) (pp opPrec ty2) + + | otherwise + = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + +pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc +pprSum _arity is_promoted args + = -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + in pprPromotionQuoteI is_promoted + <> sumParens (pprWithBars (ppr_ty topPrec) args') + +pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc +pprTuple ctxt_prec sort promoted args = + case promoted of + IsPromoted + -> let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + spaceIfPromoted = case args' of + arg0:_ -> pprSpaceIfPromotedTyCon arg0 + _ -> id + in ppr_tuple_app args' $ + pprPromotionQuoteI IsPromoted <> + tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) + + NotPromoted + | ConstraintTuple <- sort + , IA_Nil <- args + -> maybeParen ctxt_prec sigPrec $ + text "() :: Constraint" + + | otherwise + -> -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + let tys = appArgsIfaceTypes args + args' = case sort of + UnboxedTuple -> drop (length tys `div` 2) tys + _ -> tys + in + ppr_tuple_app args' $ + pprPromotionQuoteI promoted <> + tupleParens sort (pprWithCommas pprIfaceType args') + where + ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc + ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Solo x`, not `(x)` + | [_] <- args_wo_runtime_reps + , BoxedTuple <- sort + = let unit_tc_info = IfaceTyConInfo promoted IfaceNormalTyCon + unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in + pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args + | otherwise + = ppr_args_w_parens + +pprIfaceTyLit :: IfaceTyLit -> SDoc +pprIfaceTyLit (IfaceNumTyLit n) = integer n +pprIfaceTyLit (IfaceStrTyLit n) = text (show n) + +pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc +pprIfaceCoercion = ppr_co topPrec +pprParendIfaceCoercion = ppr_co appPrec + +ppr_co :: PprPrec -> IfaceCoercion -> SDoc +ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal +ppr_co _ (IfaceGReflCo r ty IfaceMRefl) + = angleBrackets (ppr ty) <> ppr_role r +ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) + = ppr_special_co ctxt_prec + (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] +ppr_co ctxt_prec (IfaceFunCo r cow co1 co2) + = maybeParen ctxt_prec funPrec $ + sep (ppr_co funPrec co1 : ppr_fun_tail cow co2) + where + ppr_fun_tail cow' (IfaceFunCo r cow co1 co2) + = (coercionArrow cow' <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail cow co2 + ppr_fun_tail cow' other_co + = [coercionArrow cow' <> ppr_role r <+> pprIfaceCoercion other_co] + coercionArrow w = mulArrow (ppr_co topPrec w) + +ppr_co _ (IfaceTyConAppCo r tc cos) + = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r +ppr_co ctxt_prec (IfaceAppCo co1 co2) + = maybeParen ctxt_prec appPrec $ + ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 +ppr_co ctxt_prec co@(IfaceForAllCo {}) + = maybeParen ctxt_prec funPrec $ + pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) + where + (tvs, inner_co) = split_co co + + split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co co' = ([], co') + +-- Why these three? See Note [TcTyVars in IfaceType] +ppr_co _ (IfaceFreeCoVar covar) = ppr covar +ppr_co _ (IfaceCoVarCo covar) = ppr covar +ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) + +ppr_co _ (IfaceUnivCo prov role ty1 ty2) + = text "Univ" <> (parens $ + sep [ ppr role <+> pprIfaceUnivCoProv prov + , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) + +ppr_co ctxt_prec (IfaceInstCo co ty) + = maybeParen ctxt_prec appPrec $ + text "Inst" <+> pprParendIfaceCoercion co + <+> pprParendIfaceCoercion ty + +ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) + = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) + +ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) + = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos +ppr_co ctxt_prec (IfaceSymCo co) + = ppr_special_co ctxt_prec (text "Sym") [co] +ppr_co ctxt_prec (IfaceTransCo co1 co2) + = maybeParen ctxt_prec opPrec $ + ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2 +ppr_co ctxt_prec (IfaceNthCo d co) + = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] +ppr_co ctxt_prec (IfaceLRCo lr co) + = ppr_special_co ctxt_prec (ppr lr) [co] +ppr_co ctxt_prec (IfaceSubCo co) + = ppr_special_co ctxt_prec (text "Sub") [co] +ppr_co ctxt_prec (IfaceKindCo co) + = ppr_special_co ctxt_prec (text "Kind") [co] + +ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co ctxt_prec doc cos + = maybeParen ctxt_prec appPrec + (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +------------------ +pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc +pprIfaceUnivCoProv (IfacePhantomProv co) + = text "phantom" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfaceProofIrrelProv co) + = text "irrel" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfacePluginProv s) + = text "plugin" <+> doubleQuotes (text s) + +------------------- +instance Outputable IfaceTyCon where + ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +instance Outputable IfaceTyConInfo where + ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom + , ifaceTyConSort = sort }) + = angleBrackets $ ppr prom <> comma <+> ppr sort + +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote tc = + pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc + +pprPromotionQuoteI :: PromotionFlag -> SDoc +pprPromotionQuoteI NotPromoted = empty +pprPromotionQuoteI IsPromoted = char '\'' + +instance Outputable IfaceCoercion where + ppr = pprIfaceCoercion + +instance Binary IfaceTyCon where + put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i + + get bh = do n <- get bh + i <- get bh + return (IfaceTyCon n i) + +instance Binary IfaceTyConSort where + put_ bh IfaceNormalTyCon = putByte bh 0 + put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort + put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity + put_ bh IfaceEqualityTyCon = putByte bh 3 + + get bh = do + n <- getByte bh + case n of + 0 -> return IfaceNormalTyCon + 1 -> IfaceTupleTyCon <$> get bh <*> get bh + 2 -> IfaceSumTyCon <$> get bh + _ -> return IfaceEqualityTyCon + +instance Binary IfaceTyConInfo where + put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s + + get bh = IfaceTyConInfo <$> get bh <*> get bh + +instance Outputable IfaceTyLit where + ppr = pprIfaceTyLit + +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + +instance Binary IfaceAppArgs where + put_ bh tk = + case tk of + IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts + IA_Nil -> putByte bh 1 + + get bh = + do c <- getByte bh + case c of + 0 -> do + t <- get bh + a <- get bh + ts <- get bh + return $! IA_Arg t a ts + 1 -> return IA_Nil + _ -> panic ("get IfaceAppArgs " ++ show c) + +------------------- + +-- Some notes about printing contexts +-- +-- In the event that we are printing a singleton context (e.g. @Eq a@) we can +-- omit parentheses. However, we must take care to set the precedence correctly +-- to opPrec, since something like @a :~: b@ must be parenthesized (see +-- #9658). +-- +-- When printing a larger context we use 'fsep' instead of 'sep' so that +-- the context doesn't get displayed as a giant column. Rather than, +-- instance (Eq a, +-- Eq b, +-- Eq c, +-- Eq d, +-- Eq e, +-- Eq f, +-- Eq g, +-- Eq h, +-- Eq i, +-- Eq j, +-- Eq k, +-- Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) +-- +-- we want +-- +-- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, +-- Eq j, Eq k, Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + + + +-- | Prints "(C a, D b) =>", including the arrow. +-- Used when we want to print a context in a type, so we +-- use 'funPrec' to decide whether to parenthesise a singleton +-- predicate; e.g. Num a => a -> a +pprIfaceContextArr :: [IfacePredType] -> SDoc +pprIfaceContextArr [] = empty +pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow +pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow + +-- | Prints a context or @()@ if empty +-- You give it the context precedence +pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc +pprIfaceContext _ [] = text "()" +pprIfaceContext prec [pred] = ppr_ty prec pred +pprIfaceContext _ preds = ppr_parend_preds preds + +ppr_parend_preds :: [IfacePredType] -> SDoc +ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) + +instance Binary IfaceType where + put_ _ (IfaceFreeTyVar tv) + = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) + + put_ bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad + put_ bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af + put_ bh (IfaceFunTy af aw ag ah) = do + putByte bh 3 + put_ bh af + put_ bh aw + put_ bh ag + put_ bh ah + put_ bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } + put_ bh (IfaceCastTy a b) + = do { putByte bh 6; put_ bh a; put_ bh b } + put_ bh (IfaceCoercionTy a) + = do { putByte bh 7; put_ bh a } + put_ bh (IfaceTupleTy s i tys) + = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } + put_ bh (IfaceLitTy n) + = do { putByte bh 9; put_ bh n } + + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do af <- get bh + aw <- get bh + ag <- get bh + ah <- get bh + return (IfaceFunTy af aw ag ah) + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + 6 -> do { a <- get bh; b <- get bh + ; return (IfaceCastTy a b) } + 7 -> do { a <- get bh + ; return (IfaceCoercionTy a) } + + 8 -> do { s <- get bh; i <- get bh; tys <- get bh + ; return (IfaceTupleTy s i tys) } + _ -> do n <- get bh + return (IfaceLitTy n) + +instance Binary IfaceMCoercion where + put_ bh IfaceMRefl = do + putByte bh 1 + put_ bh (IfaceMCo co) = do + putByte bh 2 + put_ bh co + + get bh = do + tag <- getByte bh + case tag of + 1 -> return IfaceMRefl + 2 -> do a <- get bh + return $ IfaceMCo a + _ -> panic ("get IfaceMCoercion " ++ show tag) + +instance Binary IfaceCoercion where + put_ bh (IfaceReflCo a) = do + putByte bh 1 + put_ bh a + put_ bh (IfaceGReflCo a b c) = do + putByte bh 2 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceFunCo a w b c) = do + putByte bh 3 + put_ bh a + put_ bh w + put_ bh b + put_ bh c + put_ bh (IfaceTyConAppCo a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceAppCo a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (IfaceForAllCo a b c) = do + putByte bh 6 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceCoVarCo a) = do + putByte bh 7 + put_ bh a + put_ bh (IfaceAxiomInstCo a b c) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceUnivCo a b c d) = do + putByte bh 9 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfaceSymCo a) = do + putByte bh 10 + put_ bh a + put_ bh (IfaceTransCo a b) = do + putByte bh 11 + put_ bh a + put_ bh b + put_ bh (IfaceNthCo a b) = do + putByte bh 12 + put_ bh a + put_ bh b + put_ bh (IfaceLRCo a b) = do + putByte bh 13 + put_ bh a + put_ bh b + put_ bh (IfaceInstCo a b) = do + putByte bh 14 + put_ bh a + put_ bh b + put_ bh (IfaceKindCo a) = do + putByte bh 15 + put_ bh a + put_ bh (IfaceSubCo a) = do + putByte bh 16 + put_ bh a + put_ bh (IfaceAxiomRuleCo a b) = do + putByte bh 17 + put_ bh a + put_ bh b + put_ _ (IfaceFreeCoVar cv) + = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) + put_ _ (IfaceHoleCo cv) + = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) + -- See Note [Holes in IfaceCoercion] + + get bh = do + tag <- getByte bh + case tag of + 1 -> do a <- get bh + return $ IfaceReflCo a + 2 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceGReflCo a b c + 3 -> do a <- get bh + w <- get bh + b <- get bh + c <- get bh + return $ IfaceFunCo a w b c + 4 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceTyConAppCo a b c + 5 -> do a <- get bh + b <- get bh + return $ IfaceAppCo a b + 6 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceForAllCo a b c + 7 -> do a <- get bh + return $ IfaceCoVarCo a + 8 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceAxiomInstCo a b c + 9 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return $ IfaceUnivCo a b c d + 10-> do a <- get bh + return $ IfaceSymCo a + 11-> do a <- get bh + b <- get bh + return $ IfaceTransCo a b + 12-> do a <- get bh + b <- get bh + return $ IfaceNthCo a b + 13-> do a <- get bh + b <- get bh + return $ IfaceLRCo a b + 14-> do a <- get bh + b <- get bh + return $ IfaceInstCo a b + 15-> do a <- get bh + return $ IfaceKindCo a + 16-> do a <- get bh + return $ IfaceSubCo a + 17-> do a <- get bh + b <- get bh + return $ IfaceAxiomRuleCo a b + _ -> panic ("get IfaceCoercion " ++ show tag) + +instance Binary IfaceUnivCoProv where + put_ bh (IfacePhantomProv a) = do + putByte bh 1 + put_ bh a + put_ bh (IfaceProofIrrelProv a) = do + putByte bh 2 + put_ bh a + put_ bh (IfacePluginProv a) = do + putByte bh 3 + put_ bh a + + get bh = do + tag <- getByte bh + case tag of + 1 -> do a <- get bh + return $ IfacePhantomProv a + 2 -> do a <- get bh + return $ IfaceProofIrrelProv a + 3 -> do a <- get bh + return $ IfacePluginProv a + _ -> panic ("get IfaceUnivCoProv " ++ show tag) + + +instance Binary (DefMethSpec IfaceType) where + put_ bh VanillaDM = putByte bh 0 + put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t + get bh = do + h <- getByte bh + case h of + 0 -> return VanillaDM + _ -> do { t <- get bh; return (GenericDM t) } + +instance NFData IfaceType where + rnf = \case + IfaceFreeTyVar f1 -> f1 `seq` () + IfaceTyVar f1 -> rnf f1 + IfaceLitTy f1 -> rnf f1 + IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceFunTy f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + IfaceForAllTy f1 f2 -> f1 `seq` rnf f2 + IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCoercionTy f1 -> rnf f1 + IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3 + +instance NFData IfaceTyLit where + rnf = \case + IfaceNumTyLit f1 -> rnf f1 + IfaceStrTyLit f1 -> rnf f1 + +instance NFData IfaceCoercion where + rnf = \case + IfaceReflCo f1 -> rnf f1 + IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceFunCo f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceCoVarCo f1 -> rnf f1 + IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 + IfaceSymCo f1 -> rnf f1 + IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceNthCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceLRCo f1 f2 -> f1 `seq` rnf f2 + IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceKindCo f1 -> rnf f1 + IfaceSubCo f1 -> rnf f1 + IfaceFreeCoVar f1 -> f1 `seq` () + IfaceHoleCo f1 -> f1 `seq` () + +instance NFData IfaceUnivCoProv where + rnf x = seq x () + +instance NFData IfaceMCoercion where + rnf x = seq x () + +instance NFData IfaceOneShot where + rnf x = seq x () + +instance NFData IfaceTyConSort where + rnf = \case + IfaceNormalTyCon -> () + IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` () + IfaceSumTyCon arity -> rnf arity + IfaceEqualityTyCon -> () + +instance NFData IfaceTyConInfo where + rnf (IfaceTyConInfo f s) = f `seq` rnf s + +instance NFData IfaceTyCon where + rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info + +instance NFData IfaceBndr where + rnf = \case + IfaceIdBndr id_bndr -> rnf id_bndr + IfaceTvBndr tv_bndr -> rnf tv_bndr + +instance NFData IfaceAppArgs where + rnf = \case + IA_Nil -> () + IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3 diff --git a/GHC/Iface/Type.hs-boot b/GHC/Iface/Type.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Iface/Type.hs-boot @@ -0,0 +1,17 @@ +module GHC.Iface.Type + ( IfaceType, IfaceTyCon, IfaceBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs + ) +where + +-- Empty import to influence the compilation ordering. +-- See note [Depend on GHC.Integer] in GHC.Base +import GHC.Base () + +data IfaceAppArgs + +data IfaceType +data IfaceTyCon +data IfaceTyLit +data IfaceCoercion +data IfaceBndr diff --git a/GHC/IfaceToCore.hs b/GHC/IfaceToCore.hs new file mode 100644 --- /dev/null +++ b/GHC/IfaceToCore.hs @@ -0,0 +1,1882 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Type checking of type signatures in interface files +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE NondecreasingIndentation #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.IfaceToCore ( + tcLookupImported_maybe, + importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + typecheckIfacesForMerging, + typecheckIfaceForInstantiate, + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, + tcIfaceAnnotations, tcIfaceCompleteSigs, + tcIfaceExpr, -- Desired by HERMIT (#7683) + tcIfaceGlobal, + tcIfaceOneShot + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) +import GHC.Iface.Syntax +import GHC.Iface.Load +import GHC.Iface.Env +import GHC.StgToCmm.Types +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.FVs +import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot +import GHC.Core.TyCo.Subst ( substTyCoVars ) +import GHC.Driver.Types +import GHC.Types.Annotations +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Unfold +import GHC.Core.Lint +import GHC.Core.Make +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Id.Info +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Builtin.Types +import GHC.Types.Literal +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Unit.Module +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Data.Maybe +import GHC.Types.SrcLoc +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Data.List.SetOps +import GHC.Fingerprint +import qualified GHC.Data.BooleanFormula as BF + +import Control.Monad +import qualified Data.Map as Map + +{- +This module takes + + IfaceDecl -> TyThing + IfaceType -> Type + etc + +An IfaceDecl is populated with RdrNames, and these are not renamed to +Names before typechecking, because there should be no scope errors etc. + + -- For (b) consider: f = \$(...h....) + -- where h is imported, and calls f via an hi-boot file. + -- This is bad! But it is not seen as a staging error, because h + -- is indeed imported. We don't want the type-checker to black-hole + -- when simplifying and compiling the splice! + -- + -- Simple solution: discard any unfolding that mentions a variable + -- bound in this module (and hence not yet processed). + -- The discarding happens when forkM finds a type error. + + +************************************************************************ +* * + Type-checking a complete interface +* * +************************************************************************ + +Suppose we discover we don't need to recompile. Then we must type +check the old interface file. This is a bit different to the +incremental type checking we do as we suck in interface files. Instead +we do things similarly as when we are typechecking source decls: we +bring into scope the type envt for the interface all at once, using a +knot. Remember, the decls aren't necessarily in dependency order -- +and even if they were, the type decls might be mutually recursive. + +Note [Knot-tying typecheckIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are typechecking an interface A.hi, and we come across +a Name for another entity defined in A.hi. How do we get the +'TyCon', in this case? There are three cases: + + 1) tcHiBootIface in GHC.IfaceToCore: We're typechecking an + hi-boot file in preparation of checking if the hs file we're + building is compatible. In this case, we want all of the + internal TyCons to MATCH the ones that we just constructed + during typechecking: the knot is thus tied through if_rec_types. + + 2) retypecheckLoop in GHC.Driver.Make: We are retypechecking a + mutually recursive cluster of hi files, in order to ensure + that all of the references refer to each other correctly. + In this case, the knot is tied through the HPT passed in, + which contains all of the interfaces we are in the process + of typechecking. + + 3) genModDetails in GHC.Driver.Main: We are typechecking an + old interface to generate the ModDetails. In this case, + we do the same thing as (2) and pass in an HPT with + the HomeModInfo being generated to tie knots. + +The upshot is that the CLIENT of this function is responsible +for making sure that the knot is tied correctly. If you don't, +then you'll get a message saying that we couldn't load the +declaration you wanted. + +BTW, in one-shot mode we never call typecheckIface; instead, +loadInterface handles type-checking interface. In that case, +knots are tied through the EPS. No problem! +-} + +-- Clients of this function be careful, see Note [Knot-tying typecheckIface] +typecheckIface :: ModIface -- Get the decls from here + -> IfG ModDetails +typecheckIface iface + = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do + { -- Get the right set of decls and rules. If we are compiling without -O + -- we discard pragmas before typechecking, so that we don't "see" + -- information that we shouldn't. From a versioning point of view + -- It's not actually *wrong* to do so, but in fact GHCi is unable + -- to handle unboxed tuples, so it must not see unfoldings. + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + + -- Typecheck the decls. This is done lazily, so that the knot-tying + -- within this single module works out right. It's the callers + -- job to make sure the knot is tied. + ; names_w_things <- loadDecls ignore_prags (mi_decls iface) + ; let type_env = mkNameEnv names_w_things + + -- Now do those rules, instances and annotations + ; insts <- mapM tcIfaceInst (mi_insts iface) + ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) + + -- Exports + ; exports <- ifaceExportNames (mi_exports iface) + + -- Complete Sigs + ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + + -- Finished + ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), + -- Careful! If we tug on the TyThing thunks too early + -- we'll infinite loop with hs-boot. See #10083 for + -- an example where this would cause non-termination. + text "Type envt:" <+> ppr (map fst names_w_things)]) + ; return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_sigs = complete_sigs + } + } + +{- +************************************************************************ +* * + Typechecking for merging +* * +************************************************************************ +-} + +-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) +isAbstractIfaceDecl :: IfaceDecl -> Bool +isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True +isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True +isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True +isAbstractIfaceDecl _ = False + +ifMaybeRoles :: IfaceDecl -> Maybe [Role] +ifMaybeRoles IfaceData { ifRoles = rs } = Just rs +ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs +ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs +ifMaybeRoles _ = Nothing + +-- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If +-- both are non-abstract we pick one arbitrarily (and check for consistency +-- later.) +mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl +mergeIfaceDecl d1 d2 + | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1 + | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2 + | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1 + , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2 + = let ops = nameEnvElts $ + plusNameEnv_C mergeIfaceClassOp + (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ]) + (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) + in d1 { ifBody = (ifBody d1) { + ifSigs = ops, + ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2] + } + } `withRolesFrom` d2 + -- It doesn't matter; we'll check for consistency later when + -- we merge, see 'mergeSignatures' + | otherwise = d1 `withRolesFrom` d2 + +-- Note [Role merging] +-- ~~~~~~~~~~~~~~~~~~~ +-- First, why might it be necessary to do a non-trivial role +-- merge? It may rescue a merge that might otherwise fail: +-- +-- signature A where +-- type role T nominal representational +-- data T a b +-- +-- signature A where +-- type role T representational nominal +-- data T a b +-- +-- A module that defines T as representational in both arguments +-- would successfully fill both signatures, so it would be better +-- if we merged the roles of these types in some nontrivial +-- way. +-- +-- However, we have to be very careful about how we go about +-- doing this, because role subtyping is *conditional* on +-- the supertype being NOT representationally injective, e.g., +-- if we have instead: +-- +-- signature A where +-- type role T nominal representational +-- data T a b = T a b +-- +-- signature A where +-- type role T representational nominal +-- data T a b = T a b +-- +-- Should we merge the definitions of T so that the roles are R/R (or N/N)? +-- Absolutely not: neither resulting type is a subtype of the original +-- types (see Note [Role subtyping]), because data is not representationally +-- injective. +-- +-- Thus, merging only occurs when BOTH TyCons in question are +-- representationally injective. If they're not, no merge. + +withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl +d1 `withRolesFrom` d2 + | Just roles1 <- ifMaybeRoles d1 + , Just roles2 <- ifMaybeRoles d2 + , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2) + = d1 { ifRoles = mergeRoles roles1 roles2 } + | otherwise = d1 + where + mergeRoles roles1 roles2 = zipWithEqual "mergeRoles" max roles1 roles2 + +isRepInjectiveIfaceDecl :: IfaceDecl -> Bool +isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True +isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True +isRepInjectiveIfaceDecl _ = False + +mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp +mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1 +mergeIfaceClassOp _ op2 = op2 + +-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'. +mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl +mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl + +-- | This is a very interesting function. Like typecheckIface, we want +-- to type check an interface file into a ModDetails. However, the use-case +-- for these ModDetails is different: we want to compare all of the +-- ModDetails to ensure they define compatible declarations, and then +-- merge them together. So in particular, we have to take a different +-- strategy for knot-tying: we first speculatively merge the declarations +-- to get the "base" truth for what we believe the types will be +-- (this is "type computation.") Then we read everything in relative +-- to this truth and check for compatibility. +-- +-- During the merge process, we may need to nondeterministically +-- pick a particular declaration to use, if multiple signatures define +-- the declaration ('mergeIfaceDecl'). If, for all choices, there +-- are no type synonym cycles in the resulting merged graph, then +-- we can show that our choice cannot matter. Consider the +-- set of entities which the declarations depend on: by assumption +-- of acyclicity, we can assume that these have already been shown to be equal +-- to each other (otherwise merging will fail). Then it must +-- be the case that all candidate declarations here are type-equal +-- (the choice doesn't matter) or there is an inequality (in which +-- case merging will fail.) +-- +-- Unfortunately, the choice can matter if there is a cycle. Consider the +-- following merge: +-- +-- signature H where { type A = C; type B = A; data C } +-- signature H where { type A = (); data B; type C = B } +-- +-- If we pick @type A = C@ as our representative, there will be +-- a cycle and merging will fail. But if we pick @type A = ()@ as +-- our representative, no cycle occurs, and we instead conclude +-- that all of the types are unit. So it seems that we either +-- (a) need a stronger acyclicity check which considers *all* +-- possible choices from a merge, or (b) we must find a selection +-- of declarations which is acyclic, and show that this is always +-- the "best" choice we could have made (ezyang conjectures this +-- is the case but does not have a proof). For now this is +-- not implemented. +-- +-- It's worth noting that at the moment, a data constructor and a +-- type synonym are never compatible. Consider: +-- +-- signature H where { type Int=C; type B = Int; data C = Int} +-- signature H where { export Prelude.Int; data B; type C = B; } +-- +-- This will be rejected, because the reexported Int in the second +-- signature (a proper data type) is never considered equal to a +-- type synonym. Perhaps this should be relaxed, where a type synonym +-- in a signature is considered implemented by a data type declaration +-- which matches the reference of the type synonym. +typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails]) +typecheckIfacesForMerging mod ifaces tc_env_var = + -- cannot be boot (False) + initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- Build the initial environment + -- NB: Don't include dfuns here, because we don't want to + -- serialize them out. See Note [rnIfaceNeverExported] in GHC.Iface.Rename + -- NB: But coercions are OK, because they will have the right OccName. + let mk_decl_env decls + = mkOccEnv [ (getOccName decl, decl) + | decl <- decls + , case decl of + IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns + _ -> True ] + decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces + :: [OccEnv IfaceDecl] + decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs + :: OccEnv IfaceDecl + -- TODO: change loadDecls to accept w/o Fingerprint + names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x)) + (occEnvElts decl_env)) + let global_type_env = mkNameEnv names_w_things + writeMutVar tc_env_var global_type_env + + -- OK, now typecheck each ModIface using this environment + details <- forM ifaces $ \iface -> do + -- See Note [Resolving never-exported Names] in GHC.IfaceToCore + type_env <- fixM $ \type_env -> do + setImplicitEnvM type_env $ do + decls <- loadDecls ignore_prags (mi_decls iface) + return (mkNameEnv decls) + -- But note that we use this type_env to typecheck references to DFun + -- in 'IfaceInst' + setImplicitEnvM type_env $ do + insts <- mapM tcIfaceInst (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + exports <- ifaceExportNames (mi_exports iface) + complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_sigs = complete_sigs + } + return (global_type_env, details) + +-- | Typecheck a signature 'ModIface' under the assumption that we have +-- instantiated it under some implementation (recorded in 'mi_semantic_module') +-- and want to check if the implementation fills the signature. +-- +-- This needs to operate slightly differently than 'typecheckIface' +-- because (1) we have a 'NameShape', from the exports of the +-- implementing module, which we will use to give our top-level +-- declarations the correct 'Name's even when the implementor +-- provided them with a reexport, and (2) we have to deal with +-- DFun silliness (see Note [rnIfaceNeverExported]) +typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails +typecheckIfaceForInstantiate nsubst iface = + initIfaceLclWithSubst (mi_semantic_module iface) + (text "typecheckIfaceForInstantiate") + (mi_boot iface) nsubst $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- See Note [Resolving never-exported Names] in GHC.IfaceToCore + type_env <- fixM $ \type_env -> do + setImplicitEnvM type_env $ do + decls <- loadDecls ignore_prags (mi_decls iface) + return (mkNameEnv decls) + -- See Note [rnIfaceNeverExported] + setImplicitEnvM type_env $ do + insts <- mapM tcIfaceInst (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + exports <- ifaceExportNames (mi_exports iface) + complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_sigs = complete_sigs + } + +-- Note [Resolving never-exported Names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For the high-level overview, see +-- Note [Handling never-exported TyThings under Backpack] +-- +-- As described in 'typecheckIfacesForMerging', the splendid innovation +-- of signature merging is to rewrite all Names in each of the signatures +-- we are merging together to a pre-merged structure; this is the key +-- ingredient that lets us solve some problems when merging type +-- synonyms. +-- +-- However, when a 'Name' refers to a NON-exported entity, as is the +-- case with the DFun of a ClsInst, or a CoAxiom of a type family, +-- this strategy causes problems: if we pick one and rewrite all +-- references to a shared 'Name', we will accidentally fail to check +-- if the DFun or CoAxioms are compatible, as they will never be +-- checked--only exported entities are checked for compatibility, +-- and a non-exported TyThing is checked WHEN we are checking the +-- ClsInst or type family for compatibility in checkBootDeclM. +-- By virtue of the fact that everything's been pointed to the merged +-- declaration, you'll never notice there's a difference even if there +-- is one. +-- +-- Fortunately, there are only a few places in the interface declarations +-- where this can occur, so we replace those calls with 'tcIfaceImplicit', +-- which will consult a local TypeEnv that records any never-exported +-- TyThings which we should wire up with. +-- +-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a +-- type family can refer to a coercion axiom, all of which are done in one go +-- when we typecheck 'mi_decls'. An alternate strategy would be to typecheck +-- coercions first before type families, but that seemed more fragile. +-- + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ +-} + +tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo +-- Load the hi-boot iface for the module being compiled, +-- if it indeed exists in the transitive closure of imports +-- Return the ModDetails; Nothing if no hi-boot iface +tcHiBootIface hsc_src mod + | HsBootFile <- hsc_src -- Already compiling a hs-boot file + = return NoSelfBoot + | otherwise + = do { traceIf (text "loadHiBootInterface" <+> ppr mod) + + ; mode <- getGhcMode + ; if not (isOneShot mode) + -- In --make and interactive mode, if this module has an hs-boot file + -- we'll have compiled it already, and it'll be in the HPT + -- + -- We check whether the interface is a *boot* interface. + -- It can happen (when using GHC from Visual Studio) that we + -- compile a module in TypecheckOnly mode, with a stable, + -- fully-populated HPT. In that case the boot interface isn't there + -- (it's been replaced by the mother module) so we can't check it. + -- And that's fine, because if M's ModInfo is in the HPT, then + -- it's been compiled once, and we don't need to check the boot iface + then do { hpt <- getHpt + ; case lookupHpt hpt (moduleName mod) of + Just info | mi_boot (hm_iface info) == IsBoot + -> mkSelfBootInfo (hm_iface info) (hm_details info) + _ -> return NoSelfBoot } + else do + + -- OK, so we're in one-shot mode. + -- Re #9245, we always check if there is an hi-boot interface + -- to check consistency against, rather than just when we notice + -- that an hi-boot is necessary due to a circular import. + { read_result <- findAndReadIface + need (fst (getModuleInstantiation mod)) mod + IsBoot -- Hi-boot file + + ; case read_result of { + Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface + ; mkSelfBootInfo iface tc_iface } ; + Failed err -> + + -- There was no hi-boot file. But if there is circularity in + -- the module graph, there really should have been one. + -- Since we've read all the direct imports by now, + -- eps_is_boot will record if any of our imports mention the + -- current module, which either means a module loop (not + -- a SOURCE import) or that our hi-boot file has mysteriously + -- disappeared. + do { eps <- getEps + ; case lookupUFM (eps_is_boot eps) (moduleName mod) of + -- The typical case + Nothing -> return NoSelfBoot + -- error cases + Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of + IsBoot -> failWithTc (elaborate err) + -- The hi-boot file has mysteriously disappeared. + NotBoot -> failWithTc moduleLoop + -- Someone below us imported us! + -- This is a loop with no hi-boot in the way + }}}} + where + need = text "Need the hi-boot interface for" <+> ppr mod + <+> text "to compare against the Real Thing" + + moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" + + elaborate err = hang (text "Could not find hi-boot interface for" <+> + quotes (ppr mod) <> colon) 4 err + + +mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo +mkSelfBootInfo iface mds + = do -- NB: This is computed DIRECTLY from the ModIface rather + -- than from the ModDetails, so that we can query 'sb_tcs' + -- WITHOUT forcing the contents of the interface. + let tcs = map ifName + . filter isIfaceTyCon + . map snd + $ mi_decls iface + return $ SelfBoot { sb_mds = mds + , sb_tcs = mkNameSet tcs } + where + -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on + -- this 'IfaceDecl', an ATyCon would be returned. + -- NB: This code assumes that a TyCon cannot be implicit. + isIfaceTyCon IfaceId{} = False + isIfaceTyCon IfaceData{} = True + isIfaceTyCon IfaceSynonym{} = True + isIfaceTyCon IfaceFamily{} = True + isIfaceTyCon IfaceClass{} = True + isIfaceTyCon IfaceAxiom{} = False + isIfaceTyCon IfacePatSyn{} = False + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ + +When typechecking a data type decl, we *lazily* (via forkM) typecheck +the constructor argument types. This is in the hope that we may never +poke on those argument types, and hence may never need to load the +interface files for types mentioned in the arg types. + +E.g. + data Foo.S = MkS Baz.T +Maybe we can get away without even loading the interface for Baz! + +This is not just a performance thing. Suppose we have + data Foo.S = MkS Baz.T + data Baz.T = MkT Foo.S +(in different interface files, of course). +Now, first we load and typecheck Foo.S, and add it to the type envt. +If we do explore MkS's argument, we'll load and typecheck Baz.T. +If we explore MkT's argument we'll find Foo.S already in the envt. + +If we typechecked constructor args eagerly, when loading Foo.S we'd try to +typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S... +which isn't done yet. + +All very cunning. However, there is a rather subtle gotcha which bit +me when developing this stuff. When we typecheck the decl for S, we +extend the type envt with S, MkS, and all its implicit Ids. Suppose +(a bug, but it happened) that the list of implicit Ids depended in +turn on the constructor arg types. Then the following sequence of +events takes place: + * we build a thunk for the constructor arg tys + * we build a thunk for the extended type environment (depends on ) + * we write the extended type envt into the global EPS mutvar + +Now we look something up in the type envt + * that pulls on + * which reads the global type envt out of the global EPS mutvar + * but that depends in turn on + +It's subtle, because, it'd work fine if we typechecked the constructor args +eagerly -- they don't need the extended type envt. They just get the extended +type envt by accident, because they look at it later. + +What this means is that the implicitTyThings MUST NOT DEPEND on any of +the forkM stuff. +-} + +tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tcIfaceDecl = tc_iface_decl Nothing + +tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations + -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, + ifIdDetails = details, ifIdInfo = info}) + = do { ty <- tcIfaceType iface_type + ; details <- tcIdDetails ty details + ; info <- tcIdInfo ignore_prags TopLevel name ty info + ; return (AnId (mkGlobalId details name ty info)) } + +tc_iface_decl _ _ (IfaceData {ifName = tc_name, + ifCType = cType, + ifBinders = binders, + ifResKind = res_kind, + ifRoles = roles, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifParent = mb_parent }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind + + ; tycon <- fixM $ \ tycon -> do + { stupid_theta <- tcIfaceCtxt ctxt + ; parent' <- tc_parent tc_name mb_parent + ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons + ; return (mkAlgTyCon tc_name binders' res_kind' + roles cType stupid_theta + cons parent' gadt_syn) } + ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) + ; return (ATyCon tycon) } + where + tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav + tc_parent tc_name IfNoParent + = do { tc_rep_name <- newTyConRepName tc_name + ; return (VanillaAlgTyCon tc_rep_name) } + tc_parent _ (IfDataInstance ax_name _ arg_tys) + = do { ax <- tcIfaceCoAxiom ax_name + ; let fam_tc = coAxiomTyCon ax + ax_unbr = toUnbranchedAxiom ax + ; lhs_tys <- tcIfaceAppArgs arg_tys + ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) } + +tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name, + ifRoles = roles, + ifSynRhs = rhs_ty, + ifBinders = binders, + ifResKind = res_kind }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tcIfaceType rhs_ty + ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs + ; return (ATyCon tycon) } + where + mk_doc n = text "Type synonym" <+> ppr n + +tc_iface_decl parent _ (IfaceFamily {ifName = tc_name, + ifFamFlav = fam_flav, + ifBinders = binders, + ifResKind = res_kind, + ifResVar = res, ifFamInj = inj }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tc_fam_flav tc_name fam_flav + ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res + ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj + ; return (ATyCon tycon) } + where + mk_doc n = text "Type synonym" <+> ppr n + + tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav + tc_fam_flav tc_name IfaceDataFamilyTyCon + = do { tc_rep_name <- newTyConRepName tc_name + ; return (DataFamilyTyCon tc_rep_name) } + tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon + tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches) + = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches + ; return (ClosedSynFamilyTyCon ax) } + tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon + = return AbstractClosedSynFamilyTyCon + tc_fam_flav _ IfaceBuiltInSynFamTyCon + = pprPanic "tc_iface_decl" + (text "IfaceBuiltInSynFamTyCon in interface file") + +tc_iface_decl _parent _ignore_prags + (IfaceClass {ifName = tc_name, + ifRoles = roles, + ifBinders = binders, + ifFDs = rdr_fds, + ifBody = IfAbstractClass}) + = bindIfaceTyConBinders binders $ \ binders' -> do + { fds <- mapM tc_fd rdr_fds + ; cls <- buildClass tc_name binders' roles fds Nothing + ; return (ATyCon (classTyCon cls)) } + +tc_iface_decl _parent ignore_prags + (IfaceClass {ifName = tc_name, + ifRoles = roles, + ifBinders = binders, + ifFDs = rdr_fds, + ifBody = IfConcreteClass { + ifClassCtxt = rdr_ctxt, + ifATs = rdr_ats, ifSigs = rdr_sigs, + ifMinDef = mindef_occ + }}) + = bindIfaceTyConBinders binders $ \ binders' -> do + { traceIf (text "tc-iface-class1" <+> ppr tc_name) + ; ctxt <- mapM tc_sc rdr_ctxt + ; traceIf (text "tc-iface-class2" <+> ppr tc_name) + ; sigs <- mapM tc_sig rdr_sigs + ; fds <- mapM tc_fd rdr_fds + ; traceIf (text "tc-iface-class3" <+> ppr tc_name) + ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ + ; cls <- fixM $ \ cls -> do + { ats <- mapM (tc_at cls) rdr_ats + ; traceIf (text "tc-iface-class4" <+> ppr tc_name) + ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) } + ; return (ATyCon (classTyCon cls)) } + where + tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) + -- The *length* of the superclasses is used by buildClass, and hence must + -- not be inside the thunk. But the *content* maybe recursive and hence + -- must be lazy (via forkM). Example: + -- class C (T a) => D a where + -- data T a + -- Here the associated type T is knot-tied with the class, and + -- so we must not pull on T too eagerly. See #5970 + + tc_sig :: IfaceClassOp -> IfL TcMethInfo + tc_sig (IfaceClassOp op_name rdr_ty dm) + = do { let doc = mk_op_doc op_name rdr_ty + ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty + -- Must be done lazily for just the same reason as the + -- type of a data con; to avoid sucking in types that + -- it mentions unless it's necessary to do so + ; dm' <- tc_dm doc dm + ; return (op_name, op_ty, dm') } + + tc_dm :: SDoc + -> Maybe (DefMethSpec IfaceType) + -> IfL (Maybe (DefMethSpec (SrcSpan, Type))) + tc_dm _ Nothing = return Nothing + tc_dm _ (Just VanillaDM) = return (Just VanillaDM) + tc_dm doc (Just (GenericDM ty)) + = do { -- Must be done lazily to avoid sucking in types + ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty + ; return (Just (GenericDM (noSrcSpan, ty'))) } + + tc_at cls (IfaceAT tc_decl if_def) + = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl + mb_def <- case if_def of + Nothing -> return Nothing + Just def -> forkM (mk_at_doc tc) $ + extendIfaceTyVarEnv (tyConTyVars tc) $ + do { tc_def <- tcIfaceType def + ; return (Just (tc_def, NoATVI)) } + -- Must be done lazily in case the RHS of the defaults mention + -- the type constructor being defined here + -- e.g. type AT a; type AT b = AT [b] #8002 + return (ATI tc mb_def) + + mk_sc_doc pred = text "Superclass" <+> ppr pred + mk_at_doc tc = text "Associated type" <+> ppr tc + mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] + +tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc + , ifAxBranches = branches, ifRole = role }) + = do { tc_tycon <- tcIfaceTyCon tc + -- Must be done lazily, because axioms are forced when checking + -- for family instance consistency, and the RHS may mention + -- a hs-boot declared type constructor that is going to be + -- defined by this module. + -- e.g. type instance F Int = ToBeDefined + -- See #13803 + ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name) + $ tc_ax_branches branches + ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name + , co_ax_name = tc_name + , co_ax_tc = tc_tycon + , co_ax_role = role + , co_ax_branches = manyBranches tc_branches + , co_ax_implicit = False } + ; return (ACoAxiom axiom) } + +tc_iface_decl _ _ (IfacePatSyn{ ifName = name + , ifPatMatcher = if_matcher + , ifPatBuilder = if_builder + , ifPatIsInfix = is_infix + , ifPatUnivBndrs = univ_bndrs + , ifPatExBndrs = ex_bndrs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty + , ifFieldLabels = field_labels }) + = do { traceIf (text "tc_iface_decl" <+> ppr name) + ; matcher <- tc_pr if_matcher + ; builder <- fmapMaybeM tc_pr if_builder + ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do + { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do + { patsyn <- forkM (mk_doc name) $ + do { prov_theta <- tcIfaceCtxt prov_ctxt + ; req_theta <- tcIfaceCtxt req_ctxt + ; pat_ty <- tcIfaceType pat_ty + ; arg_tys <- mapM tcIfaceType args + ; return $ buildPatSyn name is_infix matcher builder + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + arg_tys pat_ty field_labels } + ; return $ AConLike . PatSynCon $ patsyn }}} + where + mk_doc n = text "Pattern synonym" <+> ppr n + tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) + tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) + ; return (id, b) } + +tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar) +tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 + ; tvs2' <- mapM tcIfaceTyVar tvs2 + ; return (tvs1', tvs2') } + +tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] +tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches + +tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] +tc_ax_branch prev_branches + (IfaceAxBranch { ifaxbTyVars = tv_bndrs + , ifaxbEtaTyVars = eta_tv_bndrs + , ifaxbCoVars = cv_bndrs + , ifaxbLHS = lhs, ifaxbRHS = rhs + , ifaxbRoles = roles, ifaxbIncomps = incomps }) + = bindIfaceTyConBinders_AT + (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> + -- The _AT variant is needed here; see Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom + bindIfaceIds cv_bndrs $ \ cvs -> do + { tc_lhs <- tcIfaceAppArgs lhs + ; tc_rhs <- tcIfaceType rhs + ; eta_tvs <- bindIfaceTyVars eta_tv_bndrs return + ; this_mod <- getIfModule + ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS` + moduleNameFS (moduleName this_mod)) + br = CoAxBranch { cab_loc = loc + , cab_tvs = binderVars tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_lhs = tc_lhs + , cab_roles = roles + , cab_rhs = tc_rhs + , cab_incomps = map (prev_branches `getNth`) incomps } + ; return (prev_branches ++ [br]) } + +tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tybinders if_cons + = case if_cons of + IfAbstractTyCon -> return AbstractTyCon + IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons + ; return (mkDataTyConRhs data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; mkNewTyConRhs tycon_name tycon data_con } + where + univ_tvs :: [TyVar] + univ_tvs = binderVars tc_tybinders + + tag_map :: NameEnv ConTag + tag_map = mkTyConTagMap tycon + + tc_con_decl (IfCon { ifConInfix = is_infix, + ifConExTCvs = ex_bndrs, + ifConUserTvBinders = user_bndrs, + ifConName = dc_name, + ifConCtxt = ctxt, ifConEqSpec = spec, + ifConArgTys = args, ifConFields = lbl_names, + ifConStricts = if_stricts, + ifConSrcStricts = if_src_stricts}) + = -- Universally-quantified tyvars are shared with + -- parent TyCon, and are already in scope + bindIfaceBndrs ex_bndrs $ \ ex_tvs -> do + { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name) + + -- By this point, we have bound every universal and existential + -- tyvar. Because of the dcUserTyVarBinders invariant + -- (see Note [DataCon user type variable binders]), *every* tyvar in + -- ifConUserTvBinders has a matching counterpart somewhere in the + -- bound universals/existentials. As a result, calling tcIfaceTyVar + -- below is always guaranteed to succeed. + ; user_tv_bndrs <- mapM (\(Bndr bd vis) -> + case bd of + IfaceIdBndr (_, name, _) -> + Bndr <$> tcIfaceLclId name <*> pure vis + IfaceTvBndr (name, _) -> + Bndr <$> tcIfaceTyVar name <*> pure vis) + user_bndrs + + -- Read the context and argument types, but lazily for two reasons + -- (a) to avoid looking tugging on a recursive use of + -- the type itself, which is knot-tied + -- (b) to avoid faulting in the component types unless + -- they are really needed + ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $ + do { eq_spec <- tcIfaceEqSpec spec + ; theta <- tcIfaceCtxt ctxt + -- This fixes #13710. The enclosing lazy thunk gets + -- forced when typechecking record wildcard pattern + -- matching (it's not completely clear why this + -- tuple is needed), which causes trouble if one of + -- the argument types was recursively defined. + -- See also Note [Tying the knot] + ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys") + $ mapM (\(w, ty) -> mkScaled <$> tcIfaceType w <*> tcIfaceType ty) args + ; stricts <- mapM tc_strict if_stricts + -- The IfBang field can mention + -- the type itself; hence inside forkM + ; return (eq_spec, theta, arg_tys, stricts) } + + -- Remember, tycon is the representation tycon + ; let orig_res_ty = mkFamilyTyConApp tycon + (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec)) + (binderVars tc_tybinders)) + + ; prom_rep_name <- newTyConRepName dc_name + + ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) + dc_name is_infix prom_rep_name + (map src_strict if_src_stricts) + (Just stricts) + -- Pass the HsImplBangs (i.e. final + -- decisions) to buildDataCon; it'll use + -- these to guide the construction of a + -- worker. + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + lbl_names + univ_tvs ex_tvs user_tv_bndrs + eq_spec theta + arg_tys orig_res_ty tycon tag_map + ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) + ; return con } + mk_doc con_name = text "Constructor" <+> ppr con_name + + tc_strict :: IfaceBang -> IfL HsImplBang + tc_strict IfNoBang = return (HsLazy) + tc_strict IfStrict = return (HsStrict) + tc_strict IfUnpack = return (HsUnpack Nothing) + tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co + ; return (HsUnpack (Just co)) } + + src_strict :: IfaceSrcBang -> HsSrcBang + src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang + +tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] +tcIfaceEqSpec spec + = mapM do_item spec + where + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ + ; ty <- tcIfaceType if_ty + ; return (mkEqSpec tv ty) } + +{- +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (#2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. + +************************************************************************ +* * + Instances +* * +************************************************************************ +-} + +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ + fmap tyThingId (tcIfaceImplicit dfun_name) + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } + +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = axiom_name } ) + = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $ + tcIfaceCoAxiom axiom_name + -- will panic if branched, but that's OK + ; let axiom'' = toUnbranchedAxiom axiom' + mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' axiom'') } + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ + +We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars +are in the type environment. However, remember that typechecking a Rule may +(as a side effect) augment the type envt, and so we may need to iterate the process. +-} + +tcIfaceRules :: Bool -- True <=> ignore rules + -> [IfaceRule] + -> IfL [CoreRule] +tcIfaceRules ignore_prags if_rules + | ignore_prags = return [] + | otherwise = mapM tcIfaceRule if_rules + +tcIfaceRule :: IfaceRule -> IfL CoreRule +tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleAuto = auto, ifRuleOrph = orph }) + = do { ~(bndrs', args', rhs') <- + -- Typecheck the payload lazily, in the hope it'll never be looked at + forkM (text "Rule" <+> pprRuleName name) $ + bindIfaceBndrs bndrs $ \ bndrs' -> + do { args' <- mapM tcIfaceExpr args + ; rhs' <- tcIfaceExpr rhs + ; whenGOptM Opt_DoCoreLinting $ do + { dflags <- getDynFlags + ; (_, lcl_env) <- getEnvs + ; let in_scope :: [Var] + in_scope = ((nonDetEltsUFM $ if_tv_env lcl_env) ++ + (nonDetEltsUFM $ if_id_env lcl_env) ++ + bndrs' ++ + exprsFreeIdsList args') + ; case lintExpr dflags in_scope rhs' of + Nothing -> return () + Just fail_msg -> do { mod <- getIfModule + ; pprPanic "Iface Lint failure" + (vcat [ text "In interface for" <+> ppr mod + , hang doc 2 fail_msg + , ppr name <+> equals <+> ppr rhs' + , text "Iface expr =" <+> ppr rhs ]) } } + ; return (bndrs', args', rhs') } + ; let mb_tcs = map ifTopFreeName args + ; this_mod <- getIfModule + ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs', ru_args = args', + ru_rhs = occurAnalyseExpr rhs', + ru_rough = mb_tcs, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = auto, + ru_local = False }) } -- An imported RULE is never for a local Id + -- or, even if it is (module loop, perhaps) + -- we'll just leave it in the non-local set + where + -- This function *must* mirror exactly what Rules.roughTopNames does + -- We could have stored the ru_rough field in the iface file + -- but that would be redundant, I think. + -- The only wrinkle is that we must not be deceived by + -- type synonyms at the top of a type arg. Since + -- we can't tell at this point, we are careful not + -- to write them out in coreRuleToIfaceRule + ifTopFreeName :: IfaceExpr -> Maybe Name + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts))) + ifTopFreeName (IfaceApp f _) = ifTopFreeName f + ifTopFreeName (IfaceExt n) = Just n + ifTopFreeName _ = Nothing + + doc = text "Unfolding of" <+> ppr name + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceAnnotations = mapM tcIfaceAnnotation + +tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation +tcIfaceAnnotation (IfaceAnnotation target serialized) = do + target' <- tcIfaceAnnTarget target + return $ Annotation { + ann_target = target', + ann_value = serialized + } + +tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) +tcIfaceAnnTarget (NamedTarget occ) = do + name <- lookupIfaceTop occ + return $ NamedTarget name +tcIfaceAnnTarget (ModuleTarget mod) = do + return $ ModuleTarget mod + +{- +************************************************************************ +* * + Complete Match Pragmas +* * +************************************************************************ +-} + +tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] +tcIfaceCompleteSigs = mapM tcIfaceCompleteSig + +tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch +tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +tcIfaceType :: IfaceType -> IfL Type +tcIfaceType = go + where + go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n + go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n) + go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l + go (IfaceFunTy flag w t1 t2) = FunTy flag <$> tcIfaceType w <*> go t1 <*> go t2 + go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks + go (IfaceAppTy t ts) + = do { t' <- go t + ; ts' <- traverse go (appArgsIfaceTypes ts) + ; pure (foldl' AppTy t' ts') } + go (IfaceTyConApp tc tks) + = do { tc' <- tcIfaceTyCon tc + ; tks' <- mapM go (appArgsIfaceTypes tks) + ; return (mkTyConApp tc' tks') } + go (IfaceForAllTy bndr t) + = bindIfaceForAllBndr bndr $ \ tv' vis -> + ForAllTy (Bndr tv' vis) <$> go t + go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co + go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co + +tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type +tcIfaceTupleTy sort is_promoted args + = do { args' <- tcIfaceAppArgs args + ; let arity = length args' + ; base_tc <- tcTupleTyCon True sort arity + ; case is_promoted of + NotPromoted + -> return (mkTyConApp base_tc args') + + IsPromoted + -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) + kind_args = map typeKind args' + ; return (mkTyConApp tc (kind_args ++ args')) } } + +-- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon +tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) + -> TupleSort + -> Arity -- the number of args. *not* the tuple arity. + -> IfL TyCon +tcTupleTyCon in_type sort arity + = case sort of + ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity) + ; return (tyThingTyCon thing) } + BoxedTuple -> return (tupleTyCon Boxed arity) + UnboxedTuple -> return (tupleTyCon Unboxed arity') + where arity' | in_type = arity `div` 2 + | otherwise = arity + -- in expressions, we only have term args + +tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type] +tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes + +----------------------------------------- +tcIfaceCtxt :: IfaceContext -> IfL ThetaType +tcIfaceCtxt sts = mapM tcIfaceType sts + +----------------------------------------- +tcIfaceTyLit :: IfaceTyLit -> IfL TyLit +tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) +tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) + +{- +%************************************************************************ +%* * + Coercions +* * +************************************************************************ +-} + +tcIfaceCo :: IfaceCoercion -> IfL Coercion +tcIfaceCo = go + where + go_mco IfaceMRefl = pure MRefl + go_mco (IfaceMCo co) = MCo <$> (go co) + + go (IfaceReflCo t) = Refl <$> tcIfaceType t + go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco + go (IfaceFunCo r w c1 c2) = mkFunCo r <$> go w <*> go c1 <*> go c2 + go (IfaceTyConAppCo r tc cs) + = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs + go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 + go (IfaceForAllCo tv k c) = do { k' <- go k + ; bindIfaceBndr tv $ \ tv' -> + ForAllCo tv' k' <$> go c } + go (IfaceCoVarCo n) = CoVarCo <$> go_var n + go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs + go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r + <*> tcIfaceType t1 <*> tcIfaceType t2 + go (IfaceSymCo c) = SymCo <$> go c + go (IfaceTransCo c1 c2) = TransCo <$> go c1 + <*> go c2 + go (IfaceInstCo c1 t2) = InstCo <$> go c1 + <*> go t2 + go (IfaceNthCo d c) = do { c' <- go c + ; return $ mkNthCo (nthCoRole d c') d c' } + go (IfaceLRCo lr c) = LRCo lr <$> go c + go (IfaceKindCo c) = KindCo <$> go c + go (IfaceSubCo c) = SubCo <$> go c + go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax + <*> mapM go cos + go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c) + go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c) + + go_var :: FastString -> IfL CoVar + go_var = tcIfaceLclId + +tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance +tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str + +{- +************************************************************************ +* * + Core +* * +************************************************************************ +-} + +tcIfaceExpr :: IfaceExpr -> IfL CoreExpr +tcIfaceExpr (IfaceType ty) + = Type <$> tcIfaceType ty + +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + +tcIfaceExpr (IfaceLcl name) + = Var <$> tcIfaceLclId name + +tcIfaceExpr (IfaceExt gbl) + = Var <$> tcIfaceExtId gbl + +tcIfaceExpr (IfaceLit lit) + = do lit' <- tcIfaceLit lit + return (Lit lit') + +tcIfaceExpr (IfaceFCall cc ty) = do + ty' <- tcIfaceType ty + u <- newUnique + dflags <- getDynFlags + return (Var (mkFCallId dflags u cc ty')) + +tcIfaceExpr (IfaceTuple sort args) + = do { args' <- mapM tcIfaceExpr args + ; tc <- tcTupleTyCon False sort arity + ; let con_tys = map exprType args' + some_con_args = map Type con_tys ++ args' + con_args = case sort of + UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args + _ -> some_con_args + -- Put the missing type arguments back in + con_id = dataConWorkId (tyConSingleDataCon tc) + ; return (mkApps (Var con_id) con_args) } + where + arity = length args + +tcIfaceExpr (IfaceLam (bndr, os) body) + = bindIfaceBndr bndr $ \bndr' -> + Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body + where + tcIfaceOneShot IfaceOneShot b = setOneShotLambda b + tcIfaceOneShot _ b = b + +tcIfaceExpr (IfaceApp fun arg) + = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg + +tcIfaceExpr (IfaceECase scrut ty) + = do { scrut' <- tcIfaceExpr scrut + ; ty' <- tcIfaceType ty + ; return (castBottomExpr scrut' ty') } + +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do + scrut' <- tcIfaceExpr scrut + case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) + let + scrut_ty = exprType scrut' + case_mult = Many + case_bndr' = mkLocalIdOrCoVar case_bndr_name case_mult scrut_ty + -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors + -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. + tc_app = splitTyConApp scrut_ty + -- NB: Won't always succeed (polymorphic case) + -- but won't be demanded in those cases + -- NB: not tcSplitTyConApp; we are looking at Core here + -- look through non-rec newtypes to find the tycon that + -- corresponds to the datacon in this case alternative + + extendIfaceIdEnv [case_bndr'] $ do + alts' <- mapM (tcIfaceAlt scrut' case_mult tc_app) alts + return (Case scrut' case_bndr' (coreAltsType alts') alts') + +tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + NotTopLevel name ty' info + ; let id = mkLocalIdWithInfo name Many ty' id_info + `asJoinId_maybe` tcJoinInfo ji + ; rhs' <- tcIfaceExpr rhs + ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + ; return (Let (NonRec id rhs') body') } + +tcIfaceExpr (IfaceLet (IfaceRec pairs) body) + = do { ids <- mapM tc_rec_bndr (map fst pairs) + ; extendIfaceIdEnv ids $ do + { pairs' <- zipWithM tc_pair pairs ids + ; body' <- tcIfaceExpr body + ; return (Let (Rec pairs') body') } } + where + tc_rec_bndr (IfLetBndr fs ty _ ji) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; return (mkLocalId name Many ty' `asJoinId_maybe` tcJoinInfo ji) } + tc_pair (IfLetBndr _ _ info _, rhs) id + = do { rhs' <- tcIfaceExpr rhs + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + NotTopLevel (idName id) (idType id) info + ; return (setIdInfo id id_info, rhs') } + +tcIfaceExpr (IfaceTick tickish expr) = do + expr' <- tcIfaceExpr expr + -- If debug flag is not set: Ignore source notes + dbgLvl <- fmap debugLevel getDynFlags + case tickish of + IfaceSource{} | dbgLvl == 0 + -> return expr' + _otherwise -> do + tickish' <- tcIfaceTickish tickish + return (Tick tickish' expr') + +------------------------- +tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) +tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) +tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) +tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) + +------------------------- +tcIfaceLit :: Literal -> IfL Literal +tcIfaceLit lit = return lit + +------------------------- +tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type]) + -> (IfaceConAlt, [FastString], IfaceExpr) + -> IfL (AltCon, [TyVar], CoreExpr) +tcIfaceAlt _ _ _ (IfaceDefault, names, rhs) + = ASSERT( null names ) do + rhs' <- tcIfaceExpr rhs + return (DEFAULT, [], rhs') + +tcIfaceAlt _ _ _ (IfaceLitAlt lit, names, rhs) + = ASSERT( null names ) do + lit' <- tcIfaceLit lit + rhs' <- tcIfaceExpr rhs + return (LitAlt lit', [], rhs') + +-- A case alternative is made quite a bit more complicated +-- by the fact that we omit type annotations because we can +-- work them out. True enough, but its not that easy! +tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) + = do { con <- tcIfaceDataCon data_occ + ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) + ; tcIfaceDataAlt mult con inst_tys arg_strs rhs } + +tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr + -> IfL (AltCon, [TyVar], CoreExpr) +tcIfaceDataAlt mult con inst_tys arg_strs rhs + = do { us <- newUniqueSupply + ; let uniqs = uniqsFromSupply us + ; let (ex_tvs, arg_ids) + = dataConRepFSInstPat arg_strs uniqs mult con inst_tys + + ; rhs' <- extendIfaceEnvs ex_tvs $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } + +{- +************************************************************************ +* * + IdInfo +* * +************************************************************************ +-} + +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails ty IfDFunId + = return (DFunId (isNewTyCon (classTyCon cls))) + where + (_, _, cls, _) = tcSplitDFunTy ty + +tcIdDetails _ (IfRecSelId tc naughty) + = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) + (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) + tc + ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } + where + tyThingPatSyn (AConLike (PatSynCon ps)) = ps + tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" + +tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo +tcIdInfo ignore_prags toplvl name ty info = do + lcl_env <- getLclEnv + -- Set the CgInfo to something sensible but uninformative before + -- we start; default assumption is that it has CAFs + let init_info = if if_boot lcl_env == IsBoot + then vanillaIdInfo `setUnfoldingInfo` BootUnfolding + else vanillaIdInfo + + foldlM tcPrag init_info (needed_prags info) + where + needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem] + needed_prags items + | not ignore_prags = items + | otherwise = filter need_prag items + + need_prag :: IfaceInfoItem -> Bool + -- Always read in compulsory unfoldings + -- See Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy + need_prag (HsUnfold _ (IfCompulsory {})) = True + need_prag _ = False + + tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) + tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) + tcPrag info HsLevity = return (info `setNeverLevPoly` ty) + tcPrag info (HsLFInfo lf_info) = do + lf_info <- tcLFInfo lf_info + return (info `setLFInfo` lf_info) + + -- The next two are lazy, so they don't transitively suck stuff in + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding toplvl name ty info if_unf + ; let info1 | lb = info `setOccInfo` strongLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfo` unf) } + +tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity +tcJoinInfo (IfaceJoinPoint ar) = Just ar +tcJoinInfo IfaceNotJoinPoint = Nothing + +tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo +tcLFInfo lfi = case lfi of + IfLFReEntrant rep_arity -> + -- LFReEntrant closures in interface files are guaranteed to + -- + -- - Be top-level, as only top-level closures are exported. + -- - Have no free variables, as only non-top-level closures have free + -- variables + -- - Don't have ArgDescrs, as ArgDescr is used when generating code for + -- the closure + -- + -- These invariants are checked when generating LFInfos in toIfaceLFInfo. + return (LFReEntrant TopLevel rep_arity True ArgUnknown) + + IfLFThunk updatable mb_fun -> + -- LFThunk closure in interface files are guaranteed to + -- + -- - Be top-level + -- - No have free variables + -- + -- These invariants are checked when generating LFInfos in toIfaceLFInfo. + return (LFThunk TopLevel True updatable NonStandardThunk mb_fun) + + IfLFUnlifted -> + return LFUnlifted + + IfLFCon con_name -> + LFCon <$!> tcIfaceDataCon con_name + + IfLFUnknown fun_flag -> + return (LFUnknown fun_flag) + +tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) + = do { dflags <- getDynFlags + ; mb_expr <- tcPragExpr False toplvl name if_expr + ; let unf_src | stable = InlineStable + | otherwise = InlineRhs + ; return $ case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr + } + where + -- Strictness should occur before unfolding! + strict_sig = strictnessInfo info + +tcUnfolding toplvl name _ _ (IfCompulsory if_expr) + = do { mb_expr <- tcPragExpr True toplvl name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCompulsoryUnfolding expr) } + +tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) + = do { mb_expr <- tcPragExpr False toplvl name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCoreUnfolding InlineStable True expr guidance )} + where + guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + +tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops) + = bindIfaceBndrs bs $ \ bs' -> + do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + ; return (case mb_ops1 of + Nothing -> noUnfolding + Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) } + where + doc = text "Class ops for dfun" <+> ppr name + (_, _, cls, _) = tcSplitDFunTy dfun_ty + +{- +For unfoldings we try to do the job lazily, so that we never type check +an unfolding that isn't going to be looked at. +-} + +tcPragExpr :: Bool -- Is this unfolding compulsory? + -- See Note [Checking for levity polymorphism] in GHC.Core.Lint + -> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr) +tcPragExpr is_compulsory toplvl name expr + = forkM_maybe doc $ do + core_expr' <- tcIfaceExpr expr + + -- Check for type consistency in the unfolding + -- See Note [Linting Unfoldings from Interfaces] + when (isTopLevel toplvl) $ + whenGOptM Opt_DoCoreLinting $ do + in_scope <- get_in_scope + dflags <- getDynFlags + case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of + Nothing -> return () + Just fail_msg -> do { mod <- getIfModule + ; pprPanic "Iface Lint failure" + (vcat [ text "In interface for" <+> ppr mod + , hang doc 2 fail_msg + , ppr name <+> equals <+> ppr core_expr' + , text "Iface expr =" <+> ppr expr ]) } + return core_expr' + where + doc = ppWhen is_compulsory (text "Compulsory") <+> + text "Unfolding of" <+> ppr name + + get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting + get_in_scope + = do { (gbl_env, lcl_env) <- getEnvs + ; rec_ids <- case if_rec_types gbl_env of + Nothing -> return [] + Just (_, get_env) -> do + { type_env <- setLclEnv () get_env + ; return (typeEnvIds type_env) } + ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet` + bindingsVars (if_id_env lcl_env) `unionVarSet` + mkVarSet rec_ids) } + + bindingsVars :: FastStringEnv Var -> VarSet + bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm + -- It's OK to use nonDetEltsUFM here because we immediately forget + -- the ordering by creating a set + +tcIfaceOneShot :: IfaceOneShot -> OneShotInfo +tcIfaceOneShot IfaceNoOneShot = NoOneShotInfo +tcIfaceOneShot IfaceOneShot = OneShotLam + +{- +************************************************************************ +* * + Getting from Names to TyThings +* * +************************************************************************ +-} + +tcIfaceGlobal :: Name -> IfL TyThing +tcIfaceGlobal name + | Just thing <- wiredInNameTyThing_maybe name + -- Wired-in things include TyCons, DataCons, and Ids + -- Even though we are in an interface file, we want to make + -- sure the instances and RULES of this thing (particularly TyCon) are loaded + -- Imagine: f :: Double -> Double + = do { ifCheckWiredInThing thing; return thing } + + | otherwise + = do { env <- getGblEnv + ; case if_rec_types env of { -- Note [Tying the knot] + Just (mod, get_type_env) + | nameIsLocalOrFrom mod name + -> do -- It's defined in the module being compiled + { type_env <- setLclEnv () get_type_env -- yuk + ; case lookupNameEnv type_env name of + Just thing -> return thing + -- See Note [Knot-tying fallback on boot] + Nothing -> via_external + } + + ; _ -> via_external }} + where + via_external = do + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { + Just thing -> return thing ; + Nothing -> do + + { mb_thing <- importDecl name -- It's imported; go get it + ; case mb_thing of + Failed err -> failIfM err + Succeeded thing -> return thing + }}} + +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used when we are compiling M.hs, which indirectly +-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type +-- environment, which is splatted into if_rec_types after we've built M's type +-- envt. +-- +-- This is a dark and complicated part of GHC type checking, with a lot +-- of moving parts. Interested readers should also look at: +-- +-- * Note [Knot-tying typecheckIface] +-- * Note [DFun knot-tying] +-- * Note [hsc_type_env_var hack] +-- * Note [Knot-tying fallback on boot] +-- +-- There is also a wiki page on the subject, see: +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot + +-- Note [Knot-tying fallback on boot] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Suppose that you are typechecking A.hs, which transitively imports, +-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it +-- has a reference to a type T from A, what TyThing should we wire +-- it up with? Clearly, if we have already typechecked T and +-- added it into the type environment, we should go ahead and use that +-- type. But what if we haven't typechecked it yet? +-- +-- For the longest time, GHC adopted the policy that this was +-- *an error condition*; that you MUST NEVER poke on B.hs's reference +-- to a T defined in A.hs until A.hs has gotten around to kind-checking +-- T and adding it to the env. However, actually ensuring this is the +-- case has proven to be a bug farm, because it's really difficult to +-- actually ensure this never happens. The problem was especially poignant +-- with type family consistency checks, which eagerly happen before any +-- typechecking takes place. +-- +-- Today, we take a different strategy: if we ever try to access +-- an entity from A which doesn't exist, we just fall back on the +-- definition of A from the hs-boot file. This is complicated in +-- its own way: it means that you may end up with a mix of A.hs and +-- A.hs-boot TyThings during the course of typechecking. We don't +-- think (and have not observed) any cases where this would cause +-- problems, but the hypothetical situation one might worry about +-- is something along these lines in Core: +-- +-- case x of +-- A -> e1 +-- B -> e2 +-- +-- If, when typechecking this, we find x :: T, and the T we are hooked +-- up with is the abstract one from the hs-boot file, rather than the +-- one defined in this module with constructors A and B. But it's hard +-- to see how this could happen, especially because the reference to +-- the constructor (A and B) means that GHC will always typecheck +-- this expression *after* typechecking T. + +tcIfaceTyCon :: IfaceTyCon -> IfL TyCon +tcIfaceTyCon (IfaceTyCon name info) + = do { thing <- tcIfaceGlobal name + ; return $ case ifaceTyConIsPromoted info of + NotPromoted -> tyThingTyCon thing + IsPromoted -> promoteDataCon $ tyThingDataCon thing } + +tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) +tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name + ; return (tyThingCoAxiom thing) } + + +tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule +-- Unlike CoAxioms, which arise form user 'type instance' declarations, +-- there are a fixed set of CoAxiomRules, +-- currently enumerated in typeNatCoAxiomRules +tcIfaceCoAxiomRule n + = case Map.lookup n typeNatCoAxiomRules of + Just ax -> return ax + _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) + +tcIfaceDataCon :: Name -> IfL DataCon +tcIfaceDataCon name = do { thing <- tcIfaceGlobal name + ; case thing of + AConLike (RealDataCon dc) -> return dc + _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } + +tcIfaceExtId :: Name -> IfL Id +tcIfaceExtId name = do { thing <- tcIfaceGlobal name + ; case thing of + AnId id -> return id + _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } + +-- See Note [Resolving never-exported Names] in GHC.IfaceToCore +tcIfaceImplicit :: Name -> IfL TyThing +tcIfaceImplicit n = do + lcl_env <- getLclEnv + case if_implicits_env lcl_env of + Nothing -> tcIfaceGlobal n + Just tenv -> + case lookupTypeEnv tenv n of + Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv) + Just tything -> return tything + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ +-} + +bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a +bindIfaceId (w, fs, ty) thing_inside + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; w' <- tcIfaceType w + ; let id = mkLocalIdOrCoVar name w' ty' + -- We should not have "OrCoVar" here, this is a bug (#17545) + ; extendIfaceIdEnv [id] (thing_inside id) } + +bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds [] thing_inside = thing_inside [] +bindIfaceIds (b:bs) thing_inside + = bindIfaceId b $ \b' -> + bindIfaceIds bs $ \bs' -> + thing_inside (b':bs') + +bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a +bindIfaceBndr (IfaceIdBndr bndr) thing_inside + = bindIfaceId bndr thing_inside +bindIfaceBndr (IfaceTvBndr bndr) thing_inside + = bindIfaceTyVar bndr thing_inside + +bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a +bindIfaceBndrs [] thing_inside = thing_inside [] +bindIfaceBndrs (b:bs) thing_inside + = bindIfaceBndr b $ \ b' -> + bindIfaceBndrs bs $ \ bs' -> + thing_inside (b':bs') + +----------------------- +bindIfaceForAllBndrs :: [VarBndr IfaceBndr vis] -> ([VarBndr TyCoVar vis] -> IfL a) -> IfL a +bindIfaceForAllBndrs [] thing_inside = thing_inside [] +bindIfaceForAllBndrs (bndr:bndrs) thing_inside + = bindIfaceForAllBndr bndr $ \tv vis -> + bindIfaceForAllBndrs bndrs $ \bndrs' -> + thing_inside (Bndr tv vis : bndrs') + +bindIfaceForAllBndr :: (VarBndr IfaceBndr vis) -> (TyCoVar -> vis -> IfL a) -> IfL a +bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside + = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis +bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside + = bindIfaceId tv $ \tv' -> thing_inside tv' vis + +bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a +bindIfaceTyVar (occ,kind) thing_inside + = do { name <- newIfaceName (mkTyVarOccFS occ) + ; tyvar <- mk_iface_tyvar name kind + ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } + +bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTyVars [] thing_inside = thing_inside [] +bindIfaceTyVars (bndr:bndrs) thing_inside + = bindIfaceTyVar bndr $ \tv -> + bindIfaceTyVars bndrs $ \tvs -> + thing_inside (tv : tvs) + +mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar +mk_iface_tyvar name ifKind + = do { kind <- tcIfaceType ifKind + ; return (Var.mkTyVar name kind) } + +bindIfaceTyConBinders :: [IfaceTyConBinder] + -> ([TyConBinder] -> IfL a) -> IfL a +bindIfaceTyConBinders [] thing_inside = thing_inside [] +bindIfaceTyConBinders (b:bs) thing_inside + = bindIfaceTyConBinderX bindIfaceBndr b $ \ b' -> + bindIfaceTyConBinders bs $ \ bs' -> + thing_inside (b':bs') + +bindIfaceTyConBinders_AT :: [IfaceTyConBinder] + -> ([TyConBinder] -> IfL a) -> IfL a +-- Used for type variable in nested associated data/type declarations +-- where some of the type variables are already in scope +-- class C a where { data T a b } +-- Here 'a' is in scope when we look at the 'data T' +bindIfaceTyConBinders_AT [] thing_inside + = thing_inside [] +bindIfaceTyConBinders_AT (b : bs) thing_inside + = bindIfaceTyConBinderX bind_tv b $ \b' -> + bindIfaceTyConBinders_AT bs $ \bs' -> + thing_inside (b':bs') + where + bind_tv tv thing + = do { mb_tv <- lookupIfaceVar tv + ; case mb_tv of + Just b' -> thing b' + Nothing -> bindIfaceBndr tv thing } + +bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a) + -> IfaceTyConBinder + -> (TyConBinder -> IfL a) -> IfL a +bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside + = bind_tv tv $ \tv' -> + thing_inside (Bndr tv' vis) diff --git a/GHC/IfaceToCore.hs-boot b/GHC/IfaceToCore.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/IfaceToCore.hs-boot @@ -0,0 +1,19 @@ +module GHC.IfaceToCore where + +import GHC.Prelude +import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule + , IfaceAnnotation, IfaceCompleteMatch ) +import GHC.Core.TyCo.Rep ( TyThing ) +import GHC.Tc.Types ( IfL ) +import GHC.Core.InstEnv ( ClsInst ) +import GHC.Core.FamInstEnv ( FamInst ) +import GHC.Core ( CoreRule ) +import GHC.Driver.Types ( CompleteMatch ) +import GHC.Types.Annotations ( Annotation ) + +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] diff --git a/GHC/Llvm.hs b/GHC/Llvm.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm.hs @@ -0,0 +1,66 @@ +-- ---------------------------------------------------------------------------- +-- | This module supplies bindings to generate Llvm IR from Haskell +-- (). +-- +-- Note: this module is developed in a demand driven way. It is no complete +-- LLVM binding library in Haskell, but enough to generate code for GHC. +-- +-- This code is derived from code taken from the Essential Haskell Compiler +-- (EHC) project. +-- + +module GHC.Llvm ( + LlvmOpts (..), + initLlvmOpts, + + -- * Modules, Functions and Blocks + LlvmModule(..), + + LlvmFunction(..), LlvmFunctionDecl(..), + LlvmFunctions, LlvmFunctionDecls, + LlvmStatement(..), LlvmExpression(..), + LlvmBlocks, LlvmBlock(..), LlvmBlockId, + LlvmParamAttr(..), LlvmParameter, + + -- * Atomic operations + LlvmAtomicOp(..), + + -- * Fence synchronization + LlvmSyncOrdering(..), + + -- * Call Handling + LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), + LlvmLinkageType(..), LlvmFuncAttr(..), + + -- * Operations and Comparisons + LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..), + + -- * Variables and Type System + LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), + LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign, + LMConst(..), + + -- ** Some basic types + i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + + -- ** Metadata types + MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..), + + -- ** Operations on the type system. + isGlobal, getLitType, getVarType, + getLink, getStatType, pVarLift, pVarLower, + pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, + + -- * Pretty Printing + ppVar, ppLit, ppTypeLit, ppName, ppPlainName, + ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, + ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + + ) where + +import GHC.Llvm.Syntax +import GHC.Llvm.MetaData +import GHC.Llvm.Ppr +import GHC.Llvm.Types + diff --git a/GHC/Llvm/MetaData.hs b/GHC/Llvm/MetaData.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/MetaData.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Llvm.MetaData where + +import GHC.Prelude + +import GHC.Llvm.Types +import GHC.Utils.Outputable + +-- The LLVM Metadata System. +-- +-- The LLVM metadata feature is poorly documented but roughly follows the +-- following design: +-- - Metadata can be constructed in a few different ways (See below). +-- - After which it can either be attached to LLVM statements to pass along +-- extra information to the optimizer and code generator OR specifically named +-- metadata has an affect on the whole module (i.e., linking behaviour). +-- +-- +-- # Constructing metadata +-- Metadata comes largely in three forms: +-- +-- - Metadata expressions -- these are the raw metadata values that encode +-- information. They consist of metadata strings, metadata nodes, regular +-- LLVM values (both literals and references to global variables) and +-- metadata expressions (i.e., recursive data type). Some examples: +-- !{ !"hello", !0, i32 0 } +-- !{ !1, !{ i32 0 } } +-- +-- - Metadata nodes -- global metadata variables that attach a metadata +-- expression to a number. For example: +-- !0 = !{ [] !} +-- +-- - Named metadata -- global metadata variables that attach a metadata nodes +-- to a name. Used ONLY to communicated module level information to LLVM +-- through a meaningful name. For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- +-- +-- # Using Metadata +-- Using metadata depends on the form it is in: +-- +-- - Attach to instructions -- metadata can be attached to LLVM instructions +-- using a specific reference as follows: +-- %l = load i32* @glob, !nontemporal !10 +-- %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } } +-- Only metadata nodes or expressions can be attached, named metadata cannot. +-- Refer to LLVM documentation for which instructions take metadata and its +-- meaning. +-- +-- - As arguments -- llvm functions can take metadata as arguments, for +-- example: +-- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1) +-- As with instructions, only metadata nodes or expressions can be attached. +-- +-- - As a named metadata -- Here the metadata is simply declared in global +-- scope using a specific name to communicate module level information to LLVM. +-- For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- + +-- | A reference to an un-named metadata node. +newtype MetaId = MetaId Int + deriving (Eq, Ord, Enum) + +instance Outputable MetaId where + ppr (MetaId n) = char '!' <> int n + +-- | LLVM metadata expressions +data MetaExpr = MetaStr !LMString + | MetaNode !MetaId + | MetaVar !LlvmVar + | MetaStruct [MetaExpr] + deriving (Eq) + +-- | Associates some metadata with a specific label for attaching to an +-- instruction. +data MetaAnnot = MetaAnnot LMString MetaExpr + deriving (Eq) + +-- | Metadata declarations. Metadata can only be declared in global scope. +data MetaDecl + -- | Named metadata. Only used for communicating module information to + -- LLVM. ('!name = !{ [!\] }' form). + = MetaNamed !LMString [MetaId] + -- | Metadata node declaration. + -- ('!0 = metadata !{ \ }' form). + | MetaUnnamed !MetaId !MetaExpr diff --git a/GHC/Llvm/Ppr.hs b/GHC/Llvm/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/Ppr.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +-------------------------------------------------------------------------------- +-- | Pretty print LLVM IR Code. +-- + +module GHC.Llvm.Ppr ( + + -- * Top level LLVM objects. + ppLlvmModule, + ppLlvmComments, + ppLlvmComment, + ppLlvmGlobals, + ppLlvmGlobal, + ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, + ppLlvmFunctionDecls, + ppLlvmFunctionDecl, + ppLlvmFunctions, + ppLlvmFunction, + + ppVar, + ppLit, + ppTypeLit, + ppName, + ppPlainName + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Llvm.Syntax +import GHC.Llvm.MetaData +import GHC.Llvm.Types + +import Data.Int +import Data.List ( intersperse ) +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Data.FastString + +-------------------------------------------------------------------------------- +-- * Top Level Print functions +-------------------------------------------------------------------------------- + +-- | Print out a whole LLVM module. +ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc +ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs) + = ppLlvmComments comments $+$ newLine + $+$ ppLlvmAliases aliases $+$ newLine + $+$ ppLlvmMetas opts meta $+$ newLine + $+$ ppLlvmGlobals opts globals $+$ newLine + $+$ ppLlvmFunctionDecls decls $+$ newLine + $+$ ppLlvmFunctions opts funcs + +-- | Print out a multi-line comment, can be inside a function or on its own +ppLlvmComments :: [LMString] -> SDoc +ppLlvmComments comments = vcat $ map ppLlvmComment comments + +-- | Print out a comment, can be inside a function or on its own +ppLlvmComment :: LMString -> SDoc +ppLlvmComment com = semi <+> ftext com + + +-- | Print out a list of global mutable variable definitions +ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc +ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls + +-- | Print out a global mutable variable definition +ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc +ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = + let sect = case x of + Just x' -> text ", section" <+> doubleQuotes (ftext x') + Nothing -> empty + + align = case a of + Just a' -> text ", align" <+> int a' + Nothing -> empty + + rhs = case dat of + Just stat -> pprSpecialStatic opts stat + Nothing -> ppr (pLower $ getVarType var) + + -- Position of linkage is different for aliases. + const = case c of + Global -> "global" + Constant -> "constant" + Alias -> "alias" + + in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align + $+$ newLine + +ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $ + text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val) + + +-- | Print out a list of LLVM type aliases. +ppLlvmAliases :: [LlvmAlias] -> SDoc +ppLlvmAliases tys = vcat $ map ppLlvmAlias tys + +-- | Print out an LLVM type alias. +ppLlvmAlias :: LlvmAlias -> SDoc +ppLlvmAlias (name, ty) + = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc +ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc +ppLlvmMeta opts (MetaUnnamed n m) + = ppr n <+> equals <+> ppMetaExpr opts m + +ppLlvmMeta _opts (MetaNamed n m) + = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes + where + nodes = hcat $ intersperse comma $ map ppr m + + +-- | Print out a list of function definitions. +ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc +ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs + +-- | Print out a function definition. +ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc +ppLlvmFunction opts fun = + let attrDoc = ppSpaceJoin (funcAttrs fun) + secDoc = case funcSect fun of + Just s' -> text "section" <+> (doubleQuotes $ ftext s') + Nothing -> empty + prefixDoc = case funcPrefix fun of + Just v -> text "prefix" <+> ppStatic opts v + Nothing -> empty + in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) + <+> attrDoc <+> secDoc <+> prefixDoc + $+$ lbrace + $+$ ppLlvmBlocks opts (funcBody fun) + $+$ rbrace + $+$ newLine + $+$ newLine + +-- | Print out a function definition header. +ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc +ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args + = let varg' = case varg of + VarArgs | null p -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" + align = case a of + Just a' -> text " align " <> ppr a' + Nothing -> empty + args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%' + <> ftext n) + (zip p args) + in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> + (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align + +-- | Print out a list of function declaration. +ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc +ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs + +-- | Print out a function declaration. +-- Declarations define the function type but don't define the actual body of +-- the function. +ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc +ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) + = let varg' = case varg of + VarArgs | null p -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" + align = case a of + Just a' -> text " align" <+> ppr a' + Nothing -> empty + args = hcat $ intersperse (comma <> space) $ + map (\(t,a) -> ppr t <+> ppSpaceJoin a) p + in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> + ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine + + +-- | Print out a list of LLVM blocks. +ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc +ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks + +-- | Print out an LLVM block. +-- It must be part of a function definition. +ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc +ppLlvmBlock opts (LlvmBlock blockId stmts) = + let isLabel (MkLabel _) = True + isLabel _ = False + (block, rest) = break isLabel stmts + ppRest = case rest of + MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs) + _ -> empty + in ppLlvmBlockLabel blockId + $+$ (vcat $ map (ppLlvmStatement opts) block) + $+$ newLine + $+$ ppRest + +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: LlvmBlockId -> SDoc +ppLlvmBlockLabel id = pprUniqueAlways id <> colon + + +-- | Print out an LLVM statement. +ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc +ppLlvmStatement opts stmt = + let ind = (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr) + Fence st ord -> ind $ ppFence st ord + Branch target -> ind $ ppBranch opts target + BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF + Comment comments -> ind $ ppLlvmComments comments + MkLabel label -> ppLlvmBlockLabel label + Store value ptr -> ind $ ppStore opts value ptr + Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs + Return result -> ind $ ppReturn opts result + Expr expr -> ind $ ppLlvmExpression opts expr + Unreachable -> ind $ text "unreachable" + Nop -> empty + MetaStmt meta s -> ppMetaStatement opts meta s + + +-- | Print out an LLVM expression. +ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc +ppLlvmExpression opts expr + = case expr of + Alloca tp amount -> ppAlloca opts tp amount + LlvmOp op left right -> ppMachOp opts op left right + Call tp fp args attrs -> ppCall opts tp fp (map MetaVar args) attrs + CallM tp fp args attrs -> ppCall opts tp fp args attrs + Cast op from to -> ppCast opts op from to + Compare op left right -> ppCmpOp opts op left right + Extract vec idx -> ppExtract opts vec idx + ExtractV struct idx -> ppExtractV opts struct idx + Insert vec elt idx -> ppInsert opts vec elt idx + GetElemPtr inb ptr indexes -> ppGetElementPtr opts inb ptr indexes + Load ptr -> ppLoad opts ptr + ALoad ord st ptr -> ppALoad opts ord st ptr + Malloc tp amount -> ppMalloc opts tp amount + AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering + CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord + Phi tp predecessors -> ppPhi opts tp predecessors + Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk + MExpr meta expr -> ppMetaAnnotExpr opts meta expr + +ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc +ppMetaExpr opts = \case + MetaVar (LMLitVar (LMNullLit _)) -> text "null" + MetaStr s -> char '!' <> doubleQuotes (ftext s) + MetaNode n -> ppr n + MetaVar v -> ppVar opts v + MetaStruct es -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es)) + + +-------------------------------------------------------------------------------- +-- * Individual print functions +-------------------------------------------------------------------------------- + +-- | Should always be a function pointer. So a global var of function type +-- (since globals are always pointers) or a local var of pointer function type. +ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc +ppCall opts ct fptr args attrs = case fptr of + -- + -- if local var function pointer, unwrap + LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d + + -- should be function type otherwise + LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d + + -- not pointer or function, so error + _other -> error $ "ppCall called with non LMFunction type!\nMust be " + ++ " called with either global var of function type or " + ++ "local var of pointer function type." + + where + ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = + let tc = if ct == TailCall then text "tail " else empty + ppValues = ppCallParams opts (map snd params) args + ppArgTy = (ppCommaJoin $ map (ppr . fst) params) <> + (case argTy of + VarArgs -> text ", ..." + FixedArgs -> empty) + fnty = space <> lparen <> ppArgTy <> rparen + attrDoc = ppSpaceJoin attrs + in tc <> text "call" <+> ppr cc <+> ppr ret + <> fnty <+> ppName opts fptr <> lparen <+> ppValues + <+> rparen <+> attrDoc + + ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc + ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args + where + -- Metadata needs to be marked as having the `metadata` type when used + -- in a call argument + ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v + ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v + + +ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc +ppMachOp opts op left right = + (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left + <> comma <+> ppName opts right + + +ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc +ppCmpOp opts op left right = + let cmpOp + | isInt (getVarType left) && isInt (getVarType right) = text "icmp" + | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" + | otherwise = text "icmp" -- Just continue as its much easier to debug + {- + | otherwise = error ("can't compare different types, left = " + ++ (show $ getVarType left) ++ ", right = " + ++ (show $ getVarType right)) + -} + in cmpOp <+> ppr op <+> ppr (getVarType left) + <+> ppName opts left <> comma <+> ppName opts right + + +ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc +ppAssignment opts var expr = ppName opts var <+> equals <+> expr + +ppFence :: Bool -> LlvmSyncOrdering -> SDoc +ppFence st ord = + let singleThread = case st of True -> text "singlethread" + False -> empty + in text "fence" <+> singleThread <+> ppSyncOrdering ord + +ppSyncOrdering :: LlvmSyncOrdering -> SDoc +ppSyncOrdering SyncUnord = text "unordered" +ppSyncOrdering SyncMonotonic = text "monotonic" +ppSyncOrdering SyncAcquire = text "acquire" +ppSyncOrdering SyncRelease = text "release" +ppSyncOrdering SyncAcqRel = text "acq_rel" +ppSyncOrdering SyncSeqCst = text "seq_cst" + +ppAtomicOp :: LlvmAtomicOp -> SDoc +ppAtomicOp LAO_Xchg = text "xchg" +ppAtomicOp LAO_Add = text "add" +ppAtomicOp LAO_Sub = text "sub" +ppAtomicOp LAO_And = text "and" +ppAtomicOp LAO_Nand = text "nand" +ppAtomicOp LAO_Or = text "or" +ppAtomicOp LAO_Xor = text "xor" +ppAtomicOp LAO_Max = text "max" +ppAtomicOp LAO_Min = text "min" +ppAtomicOp LAO_Umax = text "umax" +ppAtomicOp LAO_Umin = text "umin" + +ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc +ppAtomicRMW opts aop tgt src ordering = + text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma + <+> ppVar opts src <+> ppSyncOrdering ordering + +ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar + -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc +ppCmpXChg opts addr old new s_ord f_ord = + text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new + <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord + +-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but +-- we have no way of guaranteeing that this is true with GHC (we would need to +-- modify the layout of the stack and closures, change the storage manager, +-- etc.). So, we blindly tell LLVM that *any* vector store or load could be +-- unaligned. In the future we may be able to guarantee that certain vector +-- access patterns are aligned, in which case we will need a more granular way +-- of specifying alignment. + +ppLoad :: LlvmOpts -> LlvmVar -> SDoc +ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align + where + derefType = pLower $ getVarType var + align | isVector . pLower . getVarType $ var = text ", align 1" + | otherwise = empty + +ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc +ppALoad opts ord st var = + let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8 + align = text ", align" <+> ppr alignment + sThreaded | st = text " singlethread" + | otherwise = empty + derefType = pLower $ getVarType var + in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded + <+> ppSyncOrdering ord <> align + +ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc +ppStore opts val dst + | isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> + comma <+> text "align 1" + | otherwise = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst + where + isVecPtrVar :: LlvmVar -> Bool + isVecPtrVar = isVector . pLower . getVarType + + +ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc +ppCast opts op from to + = ppr op + <+> ppr (getVarType from) <+> ppName opts from + <+> text "to" + <+> ppr to + + +ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc +ppMalloc opts tp amount = + let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 + in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount' + + +ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc +ppAlloca opts tp amount = + let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 + in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount' + + +ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc +ppGetElementPtr opts inb ptr idx = + let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx) + inbound = if inb then text "inbounds" else empty + derefType = pLower $ getVarType ptr + in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr + <> indexes + + +ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc +ppReturn opts (Just var) = text "ret" <+> ppVar opts var +ppReturn _ Nothing = text "ret" <+> ppr LMVoid + + +ppBranch :: LlvmOpts -> LlvmVar -> SDoc +ppBranch opts var = text "br" <+> ppVar opts var + + +ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppBranchIf opts cond trueT falseT + = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT + + +ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc +ppPhi opts tp preds = + let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label + in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) + + +ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc +ppSwitch opts scrut dflt targets = + let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab + ppTargets xs = brackets $ vcat (map ppTarget xs) + in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt + <+> ppTargets targets + + +ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc +ppAsm opts asm constraints rty vars sideeffect alignstack = + let asm' = doubleQuotes $ ftext asm + cons = doubleQuotes $ ftext constraints + rty' = ppr rty + vars' = lparen <+> ppCommaJoin (map (ppVar opts) vars) <+> rparen + side = if sideeffect then text "sideeffect" else empty + align = if alignstack then text "alignstack" else empty + in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma + <+> cons <> vars' + +ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc +ppExtract opts vec idx = + text "extractelement" + <+> ppr (getVarType vec) <+> ppName opts vec <> comma + <+> ppVar opts idx + +ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc +ppExtractV opts struct idx = + text "extractvalue" + <+> ppr (getVarType struct) <+> ppName opts struct <> comma + <+> ppr idx + +ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppInsert opts vec elt idx = + text "insertelement" + <+> ppr (getVarType vec) <+> ppName opts vec <> comma + <+> ppr (getVarType elt) <+> ppName opts elt <> comma + <+> ppVar opts idx + + +ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc +ppMetaStatement opts meta stmt = + ppLlvmStatement opts stmt <> ppMetaAnnots opts meta + +ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc +ppMetaAnnotExpr opts meta expr = + ppLlvmExpression opts expr <> ppMetaAnnots opts meta + +ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc +ppMetaAnnots opts meta = hcat $ map ppMeta meta + where + ppMeta (MetaAnnot name e) + = comma <+> exclamation <> ftext name <+> + case e of + MetaNode n -> ppr n + MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms)) + other -> exclamation <> braces (ppMetaExpr opts other) -- possible? + +-- | Return the variable name or value of the 'LlvmVar' +-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). +ppName :: LlvmOpts -> LlvmVar -> SDoc +ppName opts v = case v of + LMGlobalVar {} -> char '@' <> ppPlainName opts v + LMLocalVar {} -> char '%' <> ppPlainName opts v + LMNLocalVar {} -> char '%' <> ppPlainName opts v + LMLitVar {} -> ppPlainName opts v + +-- | Return the variable name or value of the 'LlvmVar' +-- in a plain textual representation (e.g. @x@, @y@ or @42@). +ppPlainName :: LlvmOpts -> LlvmVar -> SDoc +ppPlainName opts v = case v of + (LMGlobalVar x _ _ _ _ _) -> ftext x + (LMLocalVar x LMLabel ) -> text (show x) + (LMLocalVar x _ ) -> text ('l' : show x) + (LMNLocalVar x _ ) -> ftext x + (LMLitVar x ) -> ppLit opts x + +-- | Print a literal value. No type. +ppLit :: LlvmOpts -> LlvmLit -> SDoc +ppLit opts l = case l of + (LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32) + (LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64) + (LMIntLit i _ ) -> ppr ((fromInteger i)::Int) + (LMFloatLit r LMFloat ) -> ppFloat (llvmOptsPlatform opts) $ narrowFp r + (LMFloatLit r LMDouble) -> ppDouble (llvmOptsPlatform opts) r + f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f) + (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>' + (LMNullLit _ ) -> text "null" + -- #11487 was an issue where we passed undef for some arguments + -- that were actually live. By chance the registers holding those + -- arguments usually happened to have the right values anyways, but + -- that was not guaranteed. To find such bugs reliably, we set the + -- flag below when validating, which replaces undef literals (at + -- common types) with values that are likely to cause a crash or test + -- failure. + (LMUndefLit t ) + | llvmOptsFillUndefWithGarbage opts + , Just lit <- garbageLit t -> ppLit opts lit + | otherwise -> text "undef" + +ppVar :: LlvmOpts -> LlvmVar -> SDoc +ppVar = ppVar' [] + +ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc +ppVar' attrs opts v = case v of + LMLitVar x -> ppTypeLit' attrs opts x + x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x + +ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc +ppTypeLit = ppTypeLit' [] + +ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc +ppTypeLit' attrs opts l = case l of + LMVectorLit {} -> ppLit opts l + _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l + +ppStatic :: LlvmOpts -> LlvmStatic -> SDoc +ppStatic opts st = case st of + LMComment s -> text "; " <> ftext s + LMStaticLit l -> ppTypeLit opts l + LMUninitType t -> ppr t <> text " undef" + LMStaticStr s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\"" + LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']' + LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>" + LMStaticPointer v -> ppVar opts v + LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' + LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' + LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' + LMAdd s1 s2 -> pprStaticArith opts s1 s2 (sLit "add") (sLit "fadd") "LMAdd" + LMSub s1 s2 -> pprStaticArith opts s1 s2 (sLit "sub") (sLit "fsub") "LMSub" + + +pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc +pprSpecialStatic opts stat = case stat of + LMBitc v t -> ppr (pLower t) + <> text ", bitcast (" + <> ppStatic opts v <> text " to " <> ppr t + <> char ')' + LMStaticPointer x -> ppr (pLower $ getVarType x) + <> comma <+> ppStatic opts stat + _ -> ppStatic opts stat + + +pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString + -> String -> SDoc +pprStaticArith opts s1 s2 int_op float_op op_name = + let ty1 = getStatType s1 + op = if isFloat ty1 then float_op else int_op + in if ty1 == getStatType s2 + then ppr ty1 <+> ptext op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen + else pprPanic "pprStaticArith" $ + text op_name <> text " with different types! s1: " <> ppStatic opts s1 + <> text", s2: " <> ppStatic opts s2 + + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- + +-- | Blank line. +newLine :: SDoc +newLine = empty + +-- | Exclamation point. +exclamation :: SDoc +exclamation = char '!' diff --git a/GHC/Llvm/Syntax.hs b/GHC/Llvm/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/Syntax.hs @@ -0,0 +1,352 @@ +-------------------------------------------------------------------------------- +-- | The LLVM abstract syntax. +-- + +module GHC.Llvm.Syntax where + +import GHC.Prelude + +import GHC.Llvm.MetaData +import GHC.Llvm.Types + +import GHC.Types.Unique + +-- | Block labels +type LlvmBlockId = Unique + +-- | A block of LLVM code. +data LlvmBlock = LlvmBlock { + -- | The code label for this block + blockLabel :: LlvmBlockId, + + -- | A list of LlvmStatement's representing the code for this block. + -- This list must end with a control flow statement. + blockStmts :: [LlvmStatement] + } + +type LlvmBlocks = [LlvmBlock] + +-- | An LLVM Module. This is a top level container in LLVM. +data LlvmModule = LlvmModule { + -- | Comments to include at the start of the module. + modComments :: [LMString], + + -- | LLVM Alias type definitions. + modAliases :: [LlvmAlias], + + -- | LLVM meta data. + modMeta :: [MetaDecl], + + -- | Global variables to include in the module. + modGlobals :: [LMGlobal], + + -- | LLVM Functions used in this module but defined in other modules. + modFwdDecls :: LlvmFunctionDecls, + + -- | LLVM Functions defined in this module. + modFuncs :: LlvmFunctions + } + +-- | An LLVM Function +data LlvmFunction = LlvmFunction { + -- | The signature of this declared function. + funcDecl :: LlvmFunctionDecl, + + -- | The functions arguments + funcArgs :: [LMString], + + -- | The function attributes. + funcAttrs :: [LlvmFuncAttr], + + -- | The section to put the function into, + funcSect :: LMSection, + + -- | Prefix data + funcPrefix :: Maybe LlvmStatic, + + -- | The body of the functions. + funcBody :: LlvmBlocks + } + +type LlvmFunctions = [LlvmFunction] + +type SingleThreaded = Bool + +-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM +-- 3.0). Please see the LLVM documentation for a better description. +data LlvmSyncOrdering + -- | Some partial order of operations exists. + = SyncUnord + -- | A single total order for operations at a single address exists. + | SyncMonotonic + -- | Acquire synchronization operation. + | SyncAcquire + -- | Release synchronization operation. + | SyncRelease + -- | Acquire + Release synchronization operation. + | SyncAcqRel + -- | Full sequential Consistency operation. + | SyncSeqCst + deriving (Show, Eq) + +-- | LLVM atomic operations. Please see the @atomicrmw@ instruction in +-- the LLVM documentation for a complete description. +data LlvmAtomicOp + = LAO_Xchg + | LAO_Add + | LAO_Sub + | LAO_And + | LAO_Nand + | LAO_Or + | LAO_Xor + | LAO_Max + | LAO_Min + | LAO_Umax + | LAO_Umin + deriving (Show, Eq) + +-- | Llvm Statements +data LlvmStatement + {- | + Assign an expression to a variable: + * dest: Variable to assign to + * source: Source expression + -} + = Assignment LlvmVar LlvmExpression + + {- | + Memory fence operation + -} + | Fence Bool LlvmSyncOrdering + + {- | + Always branch to the target label + -} + | Branch LlvmVar + + {- | + Branch to label targetTrue if cond is true otherwise to label targetFalse + * cond: condition that will be tested, must be of type i1 + * targetTrue: label to branch to if cond is true + * targetFalse: label to branch to if cond is false + -} + | BranchIf LlvmVar LlvmVar LlvmVar + + {- | + Comment + Plain comment. + -} + | Comment [LMString] + + {- | + Set a label on this position. + * name: Identifier of this label, unique for this module + -} + | MkLabel LlvmBlockId + + {- | + Store variable value in pointer ptr. If value is of type t then ptr must + be of type t*. + * value: Variable/Constant to store. + * ptr: Location to store the value in + -} + | Store LlvmVar LlvmVar + + {- | + Multiway branch + * scrutinee: Variable or constant which must be of integer type that is + determines which arm is chosen. + * def: The default label if there is no match in target. + * target: A list of (value,label) where the value is an integer + constant and label the corresponding label to jump to if the + scrutinee matches the value. + -} + | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)] + + {- | + Return a result. + * result: The variable or constant to return + -} + | Return (Maybe LlvmVar) + + {- | + An instruction for the optimizer that the code following is not reachable + -} + | Unreachable + + {- | + Raise an expression to a statement (if don't want result or want to use + Llvm unnamed values. + -} + | Expr LlvmExpression + + {- | + A nop LLVM statement. Useful as its often more efficient to use this + then to wrap LLvmStatement in a Just or []. + -} + | Nop + + {- | + A LLVM statement with metadata attached to it. + -} + | MetaStmt [MetaAnnot] LlvmStatement + + deriving (Eq) + + +-- | Llvm Expressions +data LlvmExpression + {- | + Allocate amount * sizeof(tp) bytes on the stack + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + = Alloca LlvmType Int + + {- | + Perform the machine operator op on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | LlvmOp LlvmMachOp LlvmVar LlvmVar + + {- | + Perform a compare operation on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | Compare LlvmCmpOp LlvmVar LlvmVar + + {- | + Extract a scalar element from a vector + * val: The vector + * idx: The index of the scalar within the vector + -} + | Extract LlvmVar LlvmVar + + {- | + Extract a scalar element from a structure + * val: The structure + * idx: The index of the scalar within the structure + Corresponds to "extractvalue" instruction. + -} + | ExtractV LlvmVar Int + + {- | + Insert a scalar element into a vector + * val: The source vector + * elt: The scalar to insert + * index: The index at which to insert the scalar + -} + | Insert LlvmVar LlvmVar LlvmVar + + {- | + Allocate amount * sizeof(tp) bytes on the heap + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + | Malloc LlvmType Int + + {- | + Load the value at location ptr + -} + | Load LlvmVar + + {- | + Atomic load of the value at location ptr + -} + | ALoad LlvmSyncOrdering SingleThreaded LlvmVar + + {- | + Navigate in a structure, selecting elements + * inbound: Is the pointer inbounds? (computed pointer doesn't overflow) + * ptr: Location of the structure + * indexes: A list of indexes to select the correct value. + -} + | GetElemPtr Bool LlvmVar [LlvmVar] + + {- | + Cast the variable from to the to type. This is an abstraction of three + cast operators in Llvm, inttoptr, ptrtoint and bitcast. + * cast: Cast type + * from: Variable to cast + * to: type to cast to + -} + | Cast LlvmCastOp LlvmVar LlvmType + + {- | + Atomic read-modify-write operation + * op: Atomic operation + * addr: Address to modify + * operand: Operand to operation + * ordering: Ordering requirement + -} + | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering + + {- | + Compare-and-exchange operation + * addr: Address to modify + * old: Expected value + * new: New value + * suc_ord: Ordering required in success case + * fail_ord: Ordering required in failure case, can be no stronger than + suc_ord + + Result is an @i1@, true if store was successful. + -} + | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering + + {- | + Call a function. The result is the value of the expression. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Concrete arguments for the parameters + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr] + + {- | + Call a function as above but potentially taking metadata as arguments. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Arguments that may include metadata. + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr] + + {- | + Merge variables from different basic blocks which are predecessors of this + basic block in a new variable of type tp. + * tp: type of the merged variable, must match the types of the + predecessor variables. + * predecessors: A list of variables and the basic block that they originate + from. + -} + | Phi LlvmType [(LlvmVar,LlvmVar)] + + {- | + Inline assembly expression. Syntax is very similar to the style used by GCC. + * assembly: Actual inline assembly code. + * constraints: Operand constraints. + * return ty: Return type of function. + * vars: Any variables involved in the assembly code. + * sideeffect: Does the expression have side effects not visible from the + constraints list. + * alignstack: Should the stack be conservatively aligned before this + expression is executed. + -} + | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + + {- | + A LLVM expression with metadata attached to it. + -} + | MExpr [MetaAnnot] LlvmExpression + + deriving (Eq) + diff --git a/GHC/Llvm/Types.hs b/GHC/Llvm/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Llvm/Types.hs @@ -0,0 +1,817 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +-------------------------------------------------------------------------------- +-- | The LLVM Type System. +-- + +module GHC.Llvm.Types where + +#include "HsVersions.h" + +import GHC.Prelude + +import Data.Char +import Numeric + +import GHC.Platform +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.Unique + +-- from NCG +import GHC.CmmToAsm.Ppr + +import GHC.Float + +-- ----------------------------------------------------------------------------- +-- * LLVM Basic Types and Variables +-- + +-- | A global mutable variable. Maybe defined or external +data LMGlobal = LMGlobal { + getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal' + getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal' + } + +-- | A String in LLVM +type LMString = FastString + +-- | A type alias +type LlvmAlias = (LMString, LlvmType) + +-- | Llvm Types +data LlvmType + = LMInt Int -- ^ An integer with a given width in bits. + | LMFloat -- ^ 32 bit floating point + | LMDouble -- ^ 64 bit floating point + | LMFloat80 -- ^ 80 bit (x86 only) floating point + | LMFloat128 -- ^ 128 bit floating point + | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' + | LMArray Int LlvmType -- ^ An array of 'LlvmType' + | LMVector Int LlvmType -- ^ A vector of 'LlvmType' + | LMLabel -- ^ A 'LlvmVar' can represent a label (address) + | LMVoid -- ^ Void type + | LMStruct [LlvmType] -- ^ Packed structure type + | LMStructU [LlvmType] -- ^ Unpacked structure type + | LMAlias LlvmAlias -- ^ A type alias + | LMMetadata -- ^ LLVM Metadata + + -- | Function type, used to create pointers to functions + | LMFunction LlvmFunctionDecl + deriving (Eq) + +instance Outputable LlvmType where + ppr = ppType + +ppType :: LlvmType -> SDoc +ppType t = case t of + LMInt size -> char 'i' <> ppr size + LMFloat -> text "float" + LMDouble -> text "double" + LMFloat80 -> text "x86_fp80" + LMFloat128 -> text "fp128" + LMPointer x -> ppr x <> char '*' + LMArray nr tp -> char '[' <> ppr nr <> text " x " <> ppr tp <> char ']' + LMVector nr tp -> char '<' <> ppr nr <> text " x " <> ppr tp <> char '>' + LMLabel -> text "label" + LMVoid -> text "void" + LMStruct tys -> text "<{" <> ppCommaJoin tys <> text "}>" + LMStructU tys -> text "{" <> ppCommaJoin tys <> text "}" + LMMetadata -> text "metadata" + LMAlias (s,_) -> char '%' <> ftext s + LMFunction (LlvmFunctionDecl _ _ _ r varg p _) + -> ppr r <+> lparen <> ppParams varg p <> rparen + +ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc +ppParams varg p + = let varg' = case varg of + VarArgs | null args -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" + -- by default we don't print param attributes + args = map fst p + in ppCommaJoin args <> ptext varg' + +-- | An LLVM section definition. If Nothing then let LLVM decide the section +type LMSection = Maybe LMString +type LMAlign = Maybe Int + +data LMConst = Global -- ^ Mutable global variable + | Constant -- ^ Constant global variable + | Alias -- ^ Alias of another variable + deriving (Eq) + +-- | LLVM Variables +data LlvmVar + -- | Variables with a global scope. + = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst + -- | Variables local to a function or parameters. + | LMLocalVar Unique LlvmType + -- | Named local variables. Sometimes we need to be able to explicitly name + -- variables (e.g for function arguments). + | LMNLocalVar LMString LlvmType + -- | A constant variable + | LMLitVar LlvmLit + deriving (Eq) + +-- | Llvm Literal Data. +-- +-- These can be used inline in expressions. +data LlvmLit + -- | Refers to an integer constant (i64 42). + = LMIntLit Integer LlvmType + -- | Floating point literal + | LMFloatLit Double LlvmType + -- | Literal NULL, only applicable to pointer types + | LMNullLit LlvmType + -- | Vector literal + | LMVectorLit [LlvmLit] + -- | Undefined value, random bit pattern. Useful for optimisations. + | LMUndefLit LlvmType + deriving (Eq) + +-- | Llvm Static Data. +-- +-- These represent the possible global level variables and constants. +data LlvmStatic + = LMComment LMString -- ^ A comment in a static section + | LMStaticLit LlvmLit -- ^ A static variant of a literal value + | LMUninitType LlvmType -- ^ For uninitialised data + | LMStaticStr LMString LlvmType -- ^ Defines a static 'LMString' + | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array + | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type + | LMStaticPointer LlvmVar -- ^ A pointer to other data + + -- static expressions, could split out but leave + -- for moment for ease of use. Not many of them. + + | LMTrunc LlvmStatic LlvmType -- ^ Truncate + | LMBitc LlvmStatic LlvmType -- ^ Pointer to Pointer conversion + | LMPtoI LlvmStatic LlvmType -- ^ Pointer to Integer conversion + | LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation + | LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation + +-- ----------------------------------------------------------------------------- +-- ** Operations on LLVM Basic Types and Variables +-- + +-- | LLVM code generator options +data LlvmOpts = LlvmOpts + { llvmOptsPlatform :: !Platform -- ^ Target platform + , llvmOptsFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values + , llvmOptsSplitSections :: !Bool -- ^ Split sections + } + +-- | Get LlvmOptions from DynFlags +initLlvmOpts :: DynFlags -> LlvmOpts +initLlvmOpts dflags = LlvmOpts + { llvmOptsPlatform = targetPlatform dflags + , llvmOptsFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags + , llvmOptsSplitSections = gopt Opt_SplitSections dflags + } + +garbageLit :: LlvmType -> Maybe LlvmLit +garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t) + -- Use a value that looks like an untagged pointer, so we are more + -- likely to try to enter it +garbageLit t + | isFloat t = Just (LMFloatLit 12345678.9 t) +garbageLit t@(LMPointer _) = Just (LMNullLit t) + -- Using null isn't totally ideal, since some functions may check for null. + -- But producing another value is inconvenient since it needs a cast, + -- and the knowledge for how to format casts is in PpLlvm. +garbageLit _ = Nothing + -- More cases could be added, but this should do for now. + +-- | Return the 'LlvmType' of the 'LlvmVar' +getVarType :: LlvmVar -> LlvmType +getVarType (LMGlobalVar _ y _ _ _ _) = y +getVarType (LMLocalVar _ y ) = y +getVarType (LMNLocalVar _ y ) = y +getVarType (LMLitVar l ) = getLitType l + +-- | Return the 'LlvmType' of a 'LlvmLit' +getLitType :: LlvmLit -> LlvmType +getLitType (LMIntLit _ t) = t +getLitType (LMFloatLit _ t) = t +getLitType (LMVectorLit []) = panic "getLitType" +getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls)) +getLitType (LMNullLit t) = t +getLitType (LMUndefLit t) = t + +-- | Return the 'LlvmType' of the 'LlvmStatic' +getStatType :: LlvmStatic -> LlvmType +getStatType (LMStaticLit l ) = getLitType l +getStatType (LMUninitType t) = t +getStatType (LMStaticStr _ t) = t +getStatType (LMStaticArray _ t) = t +getStatType (LMStaticStruc _ t) = t +getStatType (LMStaticPointer v) = getVarType v +getStatType (LMTrunc _ t) = t +getStatType (LMBitc _ t) = t +getStatType (LMPtoI _ t) = t +getStatType (LMAdd t _) = getStatType t +getStatType (LMSub t _) = getStatType t +getStatType (LMComment _) = error "Can't call getStatType on LMComment!" + +-- | Return the 'LlvmLinkageType' for a 'LlvmVar' +getLink :: LlvmVar -> LlvmLinkageType +getLink (LMGlobalVar _ _ l _ _ _) = l +getLink _ = Internal + +-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' +-- cannot be lifted. +pLift :: LlvmType -> LlvmType +pLift LMLabel = error "Labels are unliftable" +pLift LMVoid = error "Voids are unliftable" +pLift LMMetadata = error "Metadatas are unliftable" +pLift x = LMPointer x + +-- | Lift a variable to 'LMPointer' type. +pVarLift :: LlvmVar -> LlvmVar +pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c +pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) +pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) +pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" + +-- | Remove the pointer indirection of the supplied type. Only 'LMPointer' +-- constructors can be lowered. +pLower :: LlvmType -> LlvmType +pLower (LMPointer x) = x +pLower x = pprPanic "llvmGen(pLower)" + $ ppr x <+> text " is a unlowerable type, need a pointer" + +-- | Lower a variable of 'LMPointer' type. +pVarLower :: LlvmVar -> LlvmVar +pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c +pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t) +pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t) +pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!" + +-- | Test if the given 'LlvmType' is an integer +isInt :: LlvmType -> Bool +isInt (LMInt _) = True +isInt _ = False + +-- | Test if the given 'LlvmType' is a floating point type +isFloat :: LlvmType -> Bool +isFloat LMFloat = True +isFloat LMDouble = True +isFloat LMFloat80 = True +isFloat LMFloat128 = True +isFloat _ = False + +-- | Test if the given 'LlvmType' is an 'LMPointer' construct +isPointer :: LlvmType -> Bool +isPointer (LMPointer _) = True +isPointer _ = False + +-- | Test if the given 'LlvmType' is an 'LMVector' construct +isVector :: LlvmType -> Bool +isVector (LMVector {}) = True +isVector _ = False + +-- | Test if a 'LlvmVar' is global. +isGlobal :: LlvmVar -> Bool +isGlobal (LMGlobalVar _ _ _ _ _ _) = True +isGlobal _ = False + +-- | Width in bits of an 'LlvmType', returns 0 if not applicable +llvmWidthInBits :: Platform -> LlvmType -> Int +llvmWidthInBits platform = \case + (LMInt n) -> n + (LMFloat) -> 32 + (LMDouble) -> 64 + (LMFloat80) -> 80 + (LMFloat128) -> 128 + -- Could return either a pointer width here or the width of what + -- it points to. We will go with the former for now. + -- PMW: At least judging by the way LLVM outputs constants, pointers + -- should use the former, but arrays the latter. + (LMPointer _) -> llvmWidthInBits platform (llvmWord platform) + (LMArray n t) -> n * llvmWidthInBits platform t + (LMVector n ty) -> n * llvmWidthInBits platform ty + LMLabel -> 0 + LMVoid -> 0 + (LMStruct tys) -> sum $ map (llvmWidthInBits platform) tys + (LMStructU _) -> + -- It's not trivial to calculate the bit width of the unpacked structs, + -- since they will be aligned depending on the specified datalayout ( + -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support + -- this could be to make the GHC.CmmToLlvm.Ppr.moduleLayout be a data type + -- that exposes the alignment information. However, currently the only place + -- we use unpacked structs is LLVM intrinsics that return them (e.g., + -- llvm.sadd.with.overflow.*), so we don't actually need to compute their + -- bit width. + panic "llvmWidthInBits: not implemented for LMStructU" + (LMFunction _) -> 0 + (LMAlias (_,t)) -> llvmWidthInBits platform t + LMMetadata -> panic "llvmWidthInBits: Meta-data has no runtime representation!" + + +-- ----------------------------------------------------------------------------- +-- ** Shortcut for Common Types +-- + +i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType +i128 = LMInt 128 +i64 = LMInt 64 +i32 = LMInt 32 +i16 = LMInt 16 +i8 = LMInt 8 +i1 = LMInt 1 +i8Ptr = pLift i8 + +-- | The target architectures word size +llvmWord, llvmWordPtr :: Platform -> LlvmType +llvmWord platform = LMInt (platformWordSizeInBytes platform * 8) +llvmWordPtr platform = pLift (llvmWord platform) + +-- ----------------------------------------------------------------------------- +-- * LLVM Function Types +-- + +-- | An LLVM Function +data LlvmFunctionDecl = LlvmFunctionDecl { + -- | Unique identifier of the function + decName :: LMString, + -- | LinkageType of the function + funcLinkage :: LlvmLinkageType, + -- | The calling convention of the function + funcCc :: LlvmCallConvention, + -- | Type of the returned value + decReturnType :: LlvmType, + -- | Indicates if this function uses varargs + decVarargs :: LlvmParameterListType, + -- | Parameter types and attributes + decParams :: [LlvmParameter], + -- | Function align value, must be power of 2 + funcAlign :: LMAlign + } + deriving (Eq) + +instance Outputable LlvmFunctionDecl where + ppr (LlvmFunctionDecl n l c r varg p a) + = let align = case a of + Just a' -> text " align " <> ppr a' + Nothing -> empty + in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> + lparen <> ppParams varg p <> rparen <> align + +type LlvmFunctionDecls = [LlvmFunctionDecl] + +type LlvmParameter = (LlvmType, [LlvmParamAttr]) + +-- | LLVM Parameter Attributes. +-- +-- Parameter attributes are used to communicate additional information about +-- the result or parameters of a function +data LlvmParamAttr + -- | This indicates to the code generator that the parameter or return value + -- should be zero-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + = ZeroExt + -- | This indicates to the code generator that the parameter or return value + -- should be sign-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + | SignExt + -- | This indicates that this parameter or return value should be treated in + -- a special target-dependent fashion during while emitting code for a + -- function call or return (usually, by putting it in a register as opposed + -- to memory). + | InReg + -- | This indicates that the pointer parameter should really be passed by + -- value to the function. + | ByVal + -- | This indicates that the pointer parameter specifies the address of a + -- structure that is the return value of the function in the source program. + | SRet + -- | This indicates that the pointer does not alias any global or any other + -- parameter. + | NoAlias + -- | This indicates that the callee does not make any copies of the pointer + -- that outlive the callee itself + | NoCapture + -- | This indicates that the pointer parameter can be excised using the + -- trampoline intrinsics. + | Nest + deriving (Eq) + +instance Outputable LlvmParamAttr where + ppr ZeroExt = text "zeroext" + ppr SignExt = text "signext" + ppr InReg = text "inreg" + ppr ByVal = text "byval" + ppr SRet = text "sret" + ppr NoAlias = text "noalias" + ppr NoCapture = text "nocapture" + ppr Nest = text "nest" + +-- | Llvm Function Attributes. +-- +-- Function attributes are set to communicate additional information about a +-- function. Function attributes are considered to be part of the function, +-- not of the function type, so functions with different parameter attributes +-- can have the same function type. Functions can have multiple attributes. +-- +-- Descriptions taken from +data LlvmFuncAttr + -- | This attribute indicates that the inliner should attempt to inline this + -- function into callers whenever possible, ignoring any active inlining + -- size threshold for this caller. + = AlwaysInline + -- | This attribute indicates that the source code contained a hint that + -- inlining this function is desirable (such as the \"inline\" keyword in + -- C/C++). It is just a hint; it imposes no requirements on the inliner. + | InlineHint + -- | This attribute indicates that the inliner should never inline this + -- function in any situation. This attribute may not be used together + -- with the alwaysinline attribute. + | NoInline + -- | This attribute suggests that optimization passes and code generator + -- passes make choices that keep the code size of this function low, and + -- otherwise do optimizations specifically to reduce code size. + | OptSize + -- | This function attribute indicates that the function never returns + -- normally. This produces undefined behavior at runtime if the function + -- ever does dynamically return. + | NoReturn + -- | This function attribute indicates that the function never returns with + -- an unwind or exceptional control flow. If the function does unwind, its + -- runtime behavior is undefined. + | NoUnwind + -- | This attribute indicates that the function computes its result (or + -- decides to unwind an exception) based strictly on its arguments, without + -- dereferencing any pointer arguments or otherwise accessing any mutable + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It does not write through any pointer arguments (including byval + -- arguments) and never changes any state visible to callers. This means + -- that it cannot unwind exceptions by calling the C++ exception throwing + -- methods, but could use the unwind instruction. + | ReadNone + -- | This attribute indicates that the function does not write through any + -- pointer arguments (including byval arguments) or otherwise modify any + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It may dereference pointer arguments and read state that may be set in + -- the caller. A readonly function always returns the same value (or unwinds + -- an exception identically) when called with the same set of arguments and + -- global state. It cannot unwind an exception by calling the C++ exception + -- throwing methods, but may use the unwind instruction. + | ReadOnly + -- | This attribute indicates that the function should emit a stack smashing + -- protector. It is in the form of a \"canary\"—a random value placed on the + -- stack before the local variables that's checked upon return from the + -- function to see if it has been overwritten. A heuristic is used to + -- determine if a function needs stack protectors or not. + -- + -- If a function that has an ssp attribute is inlined into a function that + -- doesn't have an ssp attribute, then the resulting function will have an + -- ssp attribute. + | Ssp + -- | This attribute indicates that the function should always emit a stack + -- smashing protector. This overrides the ssp function attribute. + -- + -- If a function that has an sspreq attribute is inlined into a function + -- that doesn't have an sspreq attribute or which has an ssp attribute, + -- then the resulting function will have an sspreq attribute. + | SspReq + -- | This attribute indicates that the code generator should not use a red + -- zone, even if the target-specific ABI normally permits it. + | NoRedZone + -- | This attributes disables implicit floating point instructions. + | NoImplicitFloat + -- | This attribute disables prologue / epilogue emission for the function. + -- This can have very system-specific consequences. + | Naked + deriving (Eq) + +instance Outputable LlvmFuncAttr where + ppr AlwaysInline = text "alwaysinline" + ppr InlineHint = text "inlinehint" + ppr NoInline = text "noinline" + ppr OptSize = text "optsize" + ppr NoReturn = text "noreturn" + ppr NoUnwind = text "nounwind" + ppr ReadNone = text "readnone" + ppr ReadOnly = text "readonly" + ppr Ssp = text "ssp" + ppr SspReq = text "ssqreq" + ppr NoRedZone = text "noredzone" + ppr NoImplicitFloat = text "noimplicitfloat" + ppr Naked = text "naked" + + +-- | Different types to call a function. +data LlvmCallType + -- | Normal call, allocate a new stack frame. + = StdCall + -- | Tail call, perform the call in the current stack frame. + | TailCall + deriving (Eq,Show) + +-- | Different calling conventions a function can use. +data LlvmCallConvention + -- | The C calling convention. + -- This calling convention (the default if no other calling convention is + -- specified) matches the target C calling conventions. This calling + -- convention supports varargs function calls and tolerates some mismatch in + -- the declared prototype and implemented declaration of the function (as + -- does normal C). + = CC_Ccc + -- | This calling convention attempts to make calls as fast as possible + -- (e.g. by passing things in registers). This calling convention allows + -- the target to use whatever tricks it wants to produce fast code for the + -- target, without having to conform to an externally specified ABI + -- (Application Binary Interface). Implementations of this convention should + -- allow arbitrary tail call optimization to be supported. This calling + -- convention does not support varargs and requires the prototype of al + -- callees to exactly match the prototype of the function definition. + | CC_Fastcc + -- | This calling convention attempts to make code in the caller as efficient + -- as possible under the assumption that the call is not commonly executed. + -- As such, these calls often preserve all registers so that the call does + -- not break any live ranges in the caller side. This calling convention + -- does not support varargs and requires the prototype of all callees to + -- exactly match the prototype of the function definition. + | CC_Coldcc + -- | The GHC-specific 'registerised' calling convention. + | CC_Ghc + -- | Any calling convention may be specified by number, allowing + -- target-specific calling conventions to be used. Target specific calling + -- conventions start at 64. + | CC_Ncc Int + -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it + -- rather than just using CC_Ncc. + | CC_X86_Stdcc + deriving (Eq) + +instance Outputable LlvmCallConvention where + ppr CC_Ccc = text "ccc" + ppr CC_Fastcc = text "fastcc" + ppr CC_Coldcc = text "coldcc" + ppr CC_Ghc = text "ghccc" + ppr (CC_Ncc i) = text "cc " <> ppr i + ppr CC_X86_Stdcc = text "x86_stdcallcc" + + +-- | Functions can have a fixed amount of parameters, or a variable amount. +data LlvmParameterListType + -- Fixed amount of arguments. + = FixedArgs + -- Variable amount of arguments. + | VarArgs + deriving (Eq,Show) + + +-- | Linkage type of a symbol. +-- +-- The description of the constructors is copied from the Llvm Assembly Language +-- Reference Manual , because +-- they correspond to the Llvm linkage types. +data LlvmLinkageType + -- | Global values with internal linkage are only directly accessible by + -- objects in the current module. In particular, linking code into a module + -- with an internal global value may cause the internal to be renamed as + -- necessary to avoid collisions. Because the symbol is internal to the + -- module, all references can be updated. This corresponds to the notion + -- of the @static@ keyword in C. + = Internal + -- | Globals with @linkonce@ linkage are merged with other globals of the + -- same name when linkage occurs. This is typically used to implement + -- inline functions, templates, or other code which must be generated + -- in each translation unit that uses it. Unreferenced linkonce globals are + -- allowed to be discarded. + | LinkOnce + -- | @weak@ linkage is exactly the same as linkonce linkage, except that + -- unreferenced weak globals may not be discarded. This is used for globals + -- that may be emitted in multiple translation units, but that are not + -- guaranteed to be emitted into every translation unit that uses them. One + -- example of this are common globals in C, such as @int X;@ at global + -- scope. + | Weak + -- | @appending@ linkage may only be applied to global variables of pointer + -- to array type. When two global variables with appending linkage are + -- linked together, the two global arrays are appended together. This is + -- the Llvm, typesafe, equivalent of having the system linker append + -- together @sections@ with identical names when .o files are linked. + | Appending + -- | The semantics of this linkage follow the ELF model: the symbol is weak + -- until linked, if not linked, the symbol becomes null instead of being an + -- undefined reference. + | ExternWeak + -- | The symbol participates in linkage and can be used to resolve external + -- symbol references. + | ExternallyVisible + -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM + -- assembly. + | External + -- | Symbol is private to the module and should not appear in the symbol table + | Private + deriving (Eq) + +instance Outputable LlvmLinkageType where + ppr Internal = text "internal" + ppr LinkOnce = text "linkonce" + ppr Weak = text "weak" + ppr Appending = text "appending" + ppr ExternWeak = text "extern_weak" + -- ExternallyVisible does not have a textual representation, it is + -- the linkage type a function resolves to if no other is specified + -- in Llvm. + ppr ExternallyVisible = empty + ppr External = text "external" + ppr Private = text "private" + +-- ----------------------------------------------------------------------------- +-- * LLVM Operations +-- + +-- | Llvm binary operators machine operations. +data LlvmMachOp + = LM_MO_Add -- ^ add two integer, floating point or vector values. + | LM_MO_Sub -- ^ subtract two ... + | LM_MO_Mul -- ^ multiply .. + | LM_MO_UDiv -- ^ unsigned integer or vector division. + | LM_MO_SDiv -- ^ signed integer .. + | LM_MO_URem -- ^ unsigned integer or vector remainder (mod) + | LM_MO_SRem -- ^ signed ... + + | LM_MO_FAdd -- ^ add two floating point or vector values. + | LM_MO_FSub -- ^ subtract two ... + | LM_MO_FMul -- ^ multiply ... + | LM_MO_FDiv -- ^ divide ... + | LM_MO_FRem -- ^ remainder ... + + -- | Left shift + | LM_MO_Shl + -- | Logical shift right + -- Shift right, filling with zero + | LM_MO_LShr + -- | Arithmetic shift right + -- The most significant bits of the result will be equal to the sign bit of + -- the left operand. + | LM_MO_AShr + + | LM_MO_And -- ^ AND bitwise logical operation. + | LM_MO_Or -- ^ OR bitwise logical operation. + | LM_MO_Xor -- ^ XOR bitwise logical operation. + deriving (Eq) + +instance Outputable LlvmMachOp where + ppr LM_MO_Add = text "add" + ppr LM_MO_Sub = text "sub" + ppr LM_MO_Mul = text "mul" + ppr LM_MO_UDiv = text "udiv" + ppr LM_MO_SDiv = text "sdiv" + ppr LM_MO_URem = text "urem" + ppr LM_MO_SRem = text "srem" + ppr LM_MO_FAdd = text "fadd" + ppr LM_MO_FSub = text "fsub" + ppr LM_MO_FMul = text "fmul" + ppr LM_MO_FDiv = text "fdiv" + ppr LM_MO_FRem = text "frem" + ppr LM_MO_Shl = text "shl" + ppr LM_MO_LShr = text "lshr" + ppr LM_MO_AShr = text "ashr" + ppr LM_MO_And = text "and" + ppr LM_MO_Or = text "or" + ppr LM_MO_Xor = text "xor" + + +-- | Llvm compare operations. +data LlvmCmpOp + = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) + | LM_CMP_Ne -- ^ Not equal (Signed and Unsigned) + | LM_CMP_Ugt -- ^ Unsigned greater than + | LM_CMP_Uge -- ^ Unsigned greater than or equal + | LM_CMP_Ult -- ^ Unsigned less than + | LM_CMP_Ule -- ^ Unsigned less than or equal + | LM_CMP_Sgt -- ^ Signed greater than + | LM_CMP_Sge -- ^ Signed greater than or equal + | LM_CMP_Slt -- ^ Signed less than + | LM_CMP_Sle -- ^ Signed less than or equal + + -- Float comparisons. GHC uses a mix of ordered and unordered float + -- comparisons. + | LM_CMP_Feq -- ^ Float equal + | LM_CMP_Fne -- ^ Float not equal + | LM_CMP_Fgt -- ^ Float greater than + | LM_CMP_Fge -- ^ Float greater than or equal + | LM_CMP_Flt -- ^ Float less than + | LM_CMP_Fle -- ^ Float less than or equal + deriving (Eq) + +instance Outputable LlvmCmpOp where + ppr LM_CMP_Eq = text "eq" + ppr LM_CMP_Ne = text "ne" + ppr LM_CMP_Ugt = text "ugt" + ppr LM_CMP_Uge = text "uge" + ppr LM_CMP_Ult = text "ult" + ppr LM_CMP_Ule = text "ule" + ppr LM_CMP_Sgt = text "sgt" + ppr LM_CMP_Sge = text "sge" + ppr LM_CMP_Slt = text "slt" + ppr LM_CMP_Sle = text "sle" + ppr LM_CMP_Feq = text "oeq" + ppr LM_CMP_Fne = text "une" + ppr LM_CMP_Fgt = text "ogt" + ppr LM_CMP_Fge = text "oge" + ppr LM_CMP_Flt = text "olt" + ppr LM_CMP_Fle = text "ole" + + +-- | Llvm cast operations. +data LlvmCastOp + = LM_Trunc -- ^ Integer truncate + | LM_Zext -- ^ Integer extend (zero fill) + | LM_Sext -- ^ Integer extend (sign fill) + | LM_Fptrunc -- ^ Float truncate + | LM_Fpext -- ^ Float extend + | LM_Fptoui -- ^ Float to unsigned Integer + | LM_Fptosi -- ^ Float to signed Integer + | LM_Uitofp -- ^ Unsigned Integer to Float + | LM_Sitofp -- ^ Signed Int to Float + | LM_Ptrtoint -- ^ Pointer to Integer + | LM_Inttoptr -- ^ Integer to Pointer + | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed + deriving (Eq) + +instance Outputable LlvmCastOp where + ppr LM_Trunc = text "trunc" + ppr LM_Zext = text "zext" + ppr LM_Sext = text "sext" + ppr LM_Fptrunc = text "fptrunc" + ppr LM_Fpext = text "fpext" + ppr LM_Fptoui = text "fptoui" + ppr LM_Fptosi = text "fptosi" + ppr LM_Uitofp = text "uitofp" + ppr LM_Sitofp = text "sitofp" + ppr LM_Ptrtoint = text "ptrtoint" + ppr LM_Inttoptr = text "inttoptr" + ppr LM_Bitcast = text "bitcast" + + +-- ----------------------------------------------------------------------------- +-- * Floating point conversion +-- + +-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In +-- Llvm float literals can be printed in a big-endian hexadecimal format, +-- regardless of underlying architecture. +-- +-- See Note [LLVM Float Types]. +ppDouble :: Platform -> Double -> SDoc +ppDouble platform d + = let bs = doubleToBytes d + hex d' = case showHex d' "" of + [] -> error "ppDouble: too few hex digits for float" + [x] -> ['0',x] + [x,y] -> [x,y] + _ -> error "ppDouble: too many hex digits for float" + + fixEndian = case platformByteOrder platform of + BigEndian -> id + LittleEndian -> reverse + str = map toUpper $ concat $ fixEndian $ map hex bs + in text "0x" <> text str + +-- Note [LLVM Float Types] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- We use 'ppDouble' for both printing Float and Double floating point types. This is +-- as LLVM expects all floating point constants (single & double) to be in IEEE +-- 754 Double precision format. However, for single precision numbers (Float) +-- they should be *representable* in IEEE 754 Single precision format. So the +-- easiest way to do this is to narrow and widen again. +-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC +-- doesn't optimize that away. + +-- Note [narrowFp & widenFp] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NOTE: we use float2Double & co directly as GHC likes to optimize away +-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600). +-- 'realToFrac' has inconsistent behaviour with optimisation as well that can +-- also cause issues, these methods don't. + +narrowFp :: Double -> Float +{-# NOINLINE narrowFp #-} +narrowFp = double2Float + +widenFp :: Float -> Double +{-# NOINLINE widenFp #-} +widenFp = float2Double + +ppFloat :: Platform -> Float -> SDoc +ppFloat platform = ppDouble platform . widenFp + + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- + +ppCommaJoin :: (Outputable a) => [a] -> SDoc +ppCommaJoin strs = hsep $ punctuate comma (map ppr strs) + +ppSpaceJoin :: (Outputable a) => [a] -> SDoc +ppSpaceJoin strs = hsep (map ppr strs) diff --git a/GHC/Parser.y b/GHC/Parser.y new file mode 100644 --- /dev/null +++ b/GHC/Parser.y @@ -0,0 +1,4024 @@ +-- -*-haskell-*- +-- --------------------------------------------------------------------------- +-- (c) The University of Glasgow 1997-2003 +--- +-- The GHC grammar. +-- +-- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 +-- --------------------------------------------------------------------------- + +{ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: DynFlags -> String -> P a -> ParseResult a +-- runParser flags str parser = unP parser parseState +-- where +-- filename = "\" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = mkPState flags buffer location +-- @ +module GHC.Parser + ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack + , parseDeclaration, parseExpression, parsePattern + , parseTypeSignature + , parseStmt, parseIdentifier + , parseType, parseHeader + , parseModuleNoHaddock + ) +where + +-- base +import Control.Monad ( unless, liftM, when, (<=<) ) +import GHC.Exts +import Data.Char +import Data.Maybe ( maybeToList ) +import Control.Monad ( mplus ) +import Control.Applicative ((<$)) +import qualified Prelude -- for happy-generated code + +-- compiler +import GHC.Hs + +import GHC.Driver.Phases ( HscSource(..) ) +import GHC.Driver.Types ( IsBootInterface(..), WarningTxt(..) ) +import GHC.Driver.Session +import GHC.Driver.Backpack.Syntax +import GHC.Unit.Info + +-- compiler/utils +import GHC.Data.OrdList +import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) +import GHC.Data.FastString +import GHC.Data.Maybe ( isJust, orElse ) +import GHC.Utils.Outputable +import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) +import GHC.Prelude + +-- compiler/basicTypes +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) +import GHC.Core.DataCon ( DataCon, dataConName ) +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Hs.Doc + +import GHC.Core.Type ( unrestrictedFunTyCon, Mult(..), Specificity(..) ) +import GHC.Core.Class ( FunDep ) + +-- compiler/parser +import GHC.Parser.PostProcess +import GHC.Parser.PostProcess.Haddock +import GHC.Parser.Lexer +import GHC.Parser.Annotation + +import GHC.Tc.Types.Evidence ( emptyTcEvBinds ) + +-- compiler/prelude +import GHC.Builtin.Types.Prim ( eqPrimTyCon ) +import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR, + manyDataConTyCon) +} + +%expect 232 -- shift/reduce conflicts + +{- Last updated: 08 June 2020 + +If you modify this parser and add a conflict, please update this comment. +You can learn more about the conflicts by passing 'happy' the -i flag: + + happy -agc --strict compiler/GHC/Parser.y -idetailed-info + +How is this section formatted? Look up the state the conflict is +reported at, and copy the list of applicable rules (at the top, without the +rule numbers). Mark *** for the rule that is the conflicting reduction (that +is, the interpretation which is NOT taken). NB: Happy doesn't print a rule +in a state if it is empty, but you should include it in the list (you can +look these up in the Grammar section of the info file). + +Obviously the state numbers are not stable across modifications to the parser, +the idea is to reproduce enough information on each conflict so you can figure +out what happened if the states were renumbered. Try not to gratuitously move +productions around in this file. + +------------------------------------------------------------------------------- + +state 60 contains 1 shift/reduce conflict. + + context -> btype . + *** type -> btype . + type -> btype . '->' ctype + + Conflicts: '->' + +------------------------------------------------------------------------------- + +state 61 contains 46 shift/reduce conflicts. + + *** btype -> tyapps . + tyapps -> tyapps . tyapp + + Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '(' '(#' '`' TYPEAPP + SIMPLEQUOTE VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM + STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE + and all the special ids. + +Example ambiguity: + 'if x then y else z :: F a' + +Shift parses as (per longest-parse rule): + 'if x then y else z :: (F a)' + +------------------------------------------------------------------------------- + +state 143 contains 14 shift/reduce conflicts. + + exp -> infixexp . '::' sigtype + exp -> infixexp . '-<' exp + exp -> infixexp . '>-' exp + exp -> infixexp . '-<<' exp + exp -> infixexp . '>>-' exp + *** exp -> infixexp . + infixexp -> infixexp . qop exp10 + + Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-' + '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM + +Examples of ambiguity: + 'if x then y else z -< e' + 'if x then y else z :: T' + 'if x then y else z + 1' (NB: '+' is in VARSYM) + +Shift parses as (per longest-parse rule): + 'if x then y else (z -< T)' + 'if x then y else (z :: T)' + 'if x then y else (z + 1)' + +------------------------------------------------------------------------------- + +state 146 contains 66 shift/reduce conflicts. + + *** exp10 -> fexp . + fexp -> fexp . aexp + fexp -> fexp . TYPEAPP atype + + Conflicts: TYPEAPP and all the tokens that can start an aexp + +Examples of ambiguity: + 'if x then y else f z' + 'if x then y else f @ z' + +Shift parses as (per longest-parse rule): + 'if x then y else (f z)' + 'if x then y else (f @ z)' + +------------------------------------------------------------------------------- + +state 200 contains 27 shift/reduce conflicts. + + aexp2 -> TH_TY_QUOTE . tyvar + aexp2 -> TH_TY_QUOTE . gtycon + *** aexp2 -> TH_TY_QUOTE . + + Conflicts: two single quotes is error syntax with specific error message. + +Example of ambiguity: + 'x = ''' + 'x = ''a' + 'x = ''T' + +Shift parses as (per longest-parse rule): + 'x = ''a' + 'x = ''T' + +------------------------------------------------------------------------------- + +state 294 contains 1 shift/reduce conflicts. + + rule -> STRING . rule_activation rule_forall infixexp '=' exp + + Conflict: '[' (empty rule_activation reduces) + +We don't know whether the '[' starts the activation or not: it +might be the start of the declaration with the activation being +empty. --SDM 1/4/2002 + +Example ambiguity: + '{-# RULE [0] f = ... #-}' + +We parse this as having a [0] rule activation for rewriting 'f', rather +a rule instructing how to rewrite the expression '[0] f'. + +------------------------------------------------------------------------------- + +state 305 contains 1 shift/reduce conflict. + + *** type -> btype . + type -> btype . '->' ctype + + Conflict: '->' + +Same as state 61 but without contexts. + +------------------------------------------------------------------------------- + +state 349 contains 1 shift/reduce conflicts. + + tup_exprs -> commas . tup_tail + sysdcon_nolist -> '(' commas . ')' + commas -> commas . ',' + + Conflict: ')' (empty tup_tail reduces) + +A tuple section with NO free variables '(,,)' is indistinguishable +from the Haskell98 data constructor for a tuple. Shift resolves in +favor of sysdcon, which is good because a tuple section will get rejected +if -XTupleSections is not specified. + +See also Note [ExplicitTuple] in GHC.Hs.Expr. + +------------------------------------------------------------------------------- + +state 407 contains 1 shift/reduce conflicts. + + tup_exprs -> commas . tup_tail + sysdcon_nolist -> '(#' commas . '#)' + commas -> commas . ',' + + Conflict: '#)' (empty tup_tail reduces) + +Same as State 354 for unboxed tuples. + +------------------------------------------------------------------------------- + +state 416 contains 66 shift/reduce conflicts. + + *** exp10 -> '-' fexp . + fexp -> fexp . aexp + fexp -> fexp . TYPEAPP atype + +Same as 146 but with a unary minus. + +------------------------------------------------------------------------------- + +state 472 contains 1 shift/reduce conflict. + + oqtycon -> '(' qtyconsym . ')' + *** qtyconop -> qtyconsym . + + Conflict: ')' + +Example ambiguity: 'foo :: (:%)' + +Shift means '(:%)' gets parsed as a type constructor, rather than than a +parenthesized infix type expression of length 1. + +------------------------------------------------------------------------------- + +state 665 contains 1 shift/reduce conflicts. + + *** aexp2 -> ipvar . + dbind -> ipvar . '=' exp + + Conflict: '=' + +Example ambiguity: 'let ?x ...' + +The parser can't tell whether the ?x is the lhs of a normal binding or +an implicit binding. Fortunately, resolving as shift gives it the only +sensible meaning, namely the lhs of an implicit binding. + +------------------------------------------------------------------------------- + +state 750 contains 1 shift/reduce conflicts. + + rule -> STRING rule_activation . rule_forall infixexp '=' exp + + Conflict: 'forall' (empty rule_forall reduces) + +Example ambiguity: '{-# RULES "name" forall = ... #-}' + +'forall' is a valid variable name---we don't know whether +to treat a forall on the input as the beginning of a quantifier +or the beginning of the rule itself. Resolving to shift means +it's always treated as a quantifier, hence the above is disallowed. +This saves explicitly defining a grammar for the rule lhs that +doesn't include 'forall'. + +------------------------------------------------------------------------------- + +state 986 contains 1 shift/reduce conflicts. + + transformqual -> 'then' 'group' . 'using' exp + transformqual -> 'then' 'group' . 'by' exp 'using' exp + *** special_id -> 'group' . + + Conflict: 'by' + +------------------------------------------------------------------------------- + +state 1084 contains 1 shift/reduce conflicts. + + rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.' + *** rule_foralls -> 'forall' rule_vars '.' . + + Conflict: 'forall' + +Example ambiguity: '{-# RULES "name" forall a. forall ... #-}' + +Here the parser cannot tell whether the second 'forall' is the beginning of +a term-level quantifier, for example: + +'{-# RULES "name" forall a. forall x. id @a x = x #-}' + +or a valid variable named 'forall', for example a function @:: Int -> Int@ + +'{-# RULES "name" forall a. forall 0 = 0 #-}' + +Shift means the parser only allows the former. Also see conflict 753 above. + +------------------------------------------------------------------------------- + +state 1285 contains 1 shift/reduce conflict. + + constrs1 -> constrs1 maybe_docnext '|' . maybe_docprev constr + + Conflict: DOCPREV + +------------------------------------------------------------------------------- + +state 1375 contains 1 shift/reduce conflict. + + *** atype -> tyvar . + tv_bndr -> '(' tyvar . '::' kind ')' + + Conflict: '::' + +Example ambiguity: 'class C a where type D a = ( a :: * ...' + +Here the parser cannot tell whether this is specifying a default for the +associated type like: + +'class C a where type D a = ( a :: * ); type D a' + +or it is an injectivity signature like: + +'class C a where type D a = ( r :: * ) | r -> a' + +Shift means the parser only allows the latter. + +------------------------------------------------------------------------------- +-- API Annotations +-- + +A lot of the productions are now cluttered with calls to +aa,am,ams,amms etc. + +These are helper functions to make sure that the locations of the +various keywords such as do / let / in are captured for use by tools +that want to do source to source conversions, such as refactorers or +structured editors. + +The helper functions are defined at the bottom of this file. + +See + https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and + https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations +for some background. + +If you modify the parser and want to ensure that the API annotations are processed +correctly, see the README in (REPO)/utils/check-api-annotations for details on +how to set up a test using the check-api-annotations utility, and interpret the +output it generates. + +Note [Parsing lists] +--------------------- +You might be wondering why we spend so much effort encoding our lists this +way: + +importdecls + : importdecls ';' importdecl + | importdecls ';' + | importdecl + | {- empty -} + +This might seem like an awfully roundabout way to declare a list; plus, to add +insult to injury you have to reverse the results at the end. The answer is that +left recursion prevents us from running out of stack space when parsing long +sequences. See: https://www.haskell.org/happy/doc/html/sec-sequences.html for +more guidance. + +By adding/removing branches, you can affect what lists are accepted. Here +are the most common patterns, rewritten as regular expressions for clarity: + + -- Equivalent to: ';'* (x ';'+)* x? (can be empty, permits leading/trailing semis) + xs : xs ';' x + | xs ';' + | x + | {- empty -} + + -- Equivalent to x (';' x)* ';'* (non-empty, permits trailing semis) + xs : xs ';' x + | xs ';' + | x + + -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis) + alts : alts1 + | ';' alts + alts1 : alts1 ';' alt + | alts1 ';' + | alt + + -- Equivalent to x (',' x)+ (non-empty, no trailing semis) + xs : x + | x ',' xs + +-- ----------------------------------------------------------------------------- + +-} + +%token + '_' { L _ ITunderscore } -- Haskell keywords + 'as' { L _ ITas } + 'case' { L _ ITcase } + 'class' { L _ ITclass } + 'data' { L _ ITdata } + 'default' { L _ ITdefault } + 'deriving' { L _ ITderiving } + 'else' { L _ ITelse } + 'hiding' { L _ IThiding } + 'if' { L _ ITif } + 'import' { L _ ITimport } + 'in' { L _ ITin } + 'infix' { L _ ITinfix } + 'infixl' { L _ ITinfixl } + 'infixr' { L _ ITinfixr } + 'instance' { L _ ITinstance } + 'let' { L _ ITlet } + 'module' { L _ ITmodule } + 'newtype' { L _ ITnewtype } + 'of' { L _ ITof } + 'qualified' { L _ ITqualified } + 'then' { L _ ITthen } + 'type' { L _ ITtype } + 'where' { L _ ITwhere } + + 'forall' { L _ (ITforall _) } -- GHC extension keywords + 'foreign' { L _ ITforeign } + 'export' { L _ ITexport } + 'label' { L _ ITlabel } + 'dynamic' { L _ ITdynamic } + 'safe' { L _ ITsafe } + 'interruptible' { L _ ITinterruptible } + 'unsafe' { L _ ITunsafe } + 'family' { L _ ITfamily } + 'role' { L _ ITrole } + 'stdcall' { L _ ITstdcallconv } + 'ccall' { L _ ITccallconv } + 'capi' { L _ ITcapiconv } + 'prim' { L _ ITprimcallconv } + 'javascript' { L _ ITjavascriptcallconv } + 'proc' { L _ ITproc } -- for arrow notation extension + 'rec' { L _ ITrec } -- for arrow notation extension + 'group' { L _ ITgroup } -- for list transform extension + 'by' { L _ ITby } -- for list transform extension + 'using' { L _ ITusing } -- for list transform extension + 'pattern' { L _ ITpattern } -- for pattern synonyms + 'static' { L _ ITstatic } -- for static pointers extension + 'stock' { L _ ITstock } -- for DerivingStrategies extension + 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension + 'via' { L _ ITvia } -- for DerivingStrategies extension + + 'unit' { L _ ITunit } + 'signature' { L _ ITsignature } + 'dependency' { L _ ITdependency } + + '{-# INLINE' { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE + '{-# SPECIALISE' { L _ (ITspec_prag _) } + '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) } + '{-# SOURCE' { L _ (ITsource_prag _) } + '{-# RULES' { L _ (ITrules_prag _) } + '{-# SCC' { L _ (ITscc_prag _)} + '{-# GENERATED' { L _ (ITgenerated_prag _) } + '{-# DEPRECATED' { L _ (ITdeprecated_prag _) } + '{-# WARNING' { L _ (ITwarning_prag _) } + '{-# UNPACK' { L _ (ITunpack_prag _) } + '{-# NOUNPACK' { L _ (ITnounpack_prag _) } + '{-# ANN' { L _ (ITann_prag _) } + '{-# MINIMAL' { L _ (ITminimal_prag _) } + '{-# CTYPE' { L _ (ITctype _) } + '{-# OVERLAPPING' { L _ (IToverlapping_prag _) } + '{-# OVERLAPPABLE' { L _ (IToverlappable_prag _) } + '{-# OVERLAPS' { L _ (IToverlaps_prag _) } + '{-# INCOHERENT' { L _ (ITincoherent_prag _) } + '{-# COMPLETE' { L _ (ITcomplete_prag _) } + '#-}' { L _ ITclose_prag } + + '..' { L _ ITdotdot } -- reserved symbols + ':' { L _ ITcolon } + '::' { L _ (ITdcolon _) } + '=' { L _ ITequal } + '\\' { L _ ITlam } + 'lcase' { L _ ITlcase } + '|' { L _ ITvbar } + '<-' { L _ (ITlarrow _) } + '->' { L _ (ITrarrow _) } + '->.' { L _ ITlolly } + TIGHT_INFIX_AT { L _ ITat } + '=>' { L _ (ITdarrow _) } + '-' { L _ ITminus } + PREFIX_TILDE { L _ ITtilde } + PREFIX_BANG { L _ ITbang } + PREFIX_MINUS { L _ ITprefixminus } + '*' { L _ (ITstar _) } + '-<' { L _ (ITlarrowtail _) } -- for arrow notation + '>-' { L _ (ITrarrowtail _) } -- for arrow notation + '-<<' { L _ (ITLarrowtail _) } -- for arrow notation + '>>-' { L _ (ITRarrowtail _) } -- for arrow notation + '.' { L _ ITdot } + PREFIX_AT { L _ ITtypeApp } + PREFIX_PERCENT { L _ ITpercent } -- for linear types + + '{' { L _ ITocurly } -- special symbols + '}' { L _ ITccurly } + vocurly { L _ ITvocurly } -- virtual open curly (from layout) + vccurly { L _ ITvccurly } -- virtual close curly (from layout) + '[' { L _ ITobrack } + ']' { L _ ITcbrack } + '(' { L _ IToparen } + ')' { L _ ITcparen } + '(#' { L _ IToubxparen } + '#)' { L _ ITcubxparen } + '(|' { L _ (IToparenbar _) } + '|)' { L _ (ITcparenbar _) } + ';' { L _ ITsemi } + ',' { L _ ITcomma } + '`' { L _ ITbackquote } + SIMPLEQUOTE { L _ ITsimpleQuote } -- 'x + + VARID { L _ (ITvarid _) } -- identifiers + CONID { L _ (ITconid _) } + VARSYM { L _ (ITvarsym _) } + CONSYM { L _ (ITconsym _) } + QVARID { L _ (ITqvarid _) } + QCONID { L _ (ITqconid _) } + QVARSYM { L _ (ITqvarsym _) } + QCONSYM { L _ (ITqconsym _) } + + + -- QualifiedDo + DO { L _ (ITdo _) } + MDO { L _ (ITmdo _) } + + IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension + LABELVARID { L _ (ITlabelvarid _) } + + CHAR { L _ (ITchar _ _) } + STRING { L _ (ITstring _ _) } + INTEGER { L _ (ITinteger _) } + RATIONAL { L _ (ITrational _) } + + PRIMCHAR { L _ (ITprimchar _ _) } + PRIMSTRING { L _ (ITprimstring _ _) } + PRIMINTEGER { L _ (ITprimint _ _) } + PRIMWORD { L _ (ITprimword _ _) } + PRIMFLOAT { L _ (ITprimfloat _) } + PRIMDOUBLE { L _ (ITprimdouble _) } + +-- Template Haskell +'[|' { L _ (ITopenExpQuote _ _) } +'[p|' { L _ ITopenPatQuote } +'[t|' { L _ ITopenTypQuote } +'[d|' { L _ ITopenDecQuote } +'|]' { L _ (ITcloseQuote _) } +'[||' { L _ (ITopenTExpQuote _) } +'||]' { L _ ITcloseTExpQuote } +PREFIX_DOLLAR { L _ ITdollar } +PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar } +TH_TY_QUOTE { L _ ITtyQuote } -- ''T +TH_QUASIQUOTE { L _ (ITquasiQuote _) } +TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } + +%monad { P } { >>= } { return } +%lexer { (lexer True) } { L _ ITeof } + -- Replace 'lexer' above with 'lexerDbg' + -- to dump the tokens fed to the parser. +%tokentype { (Located Token) } + +-- Exported parsers +%name parseModuleNoHaddock module +%name parseSignature signature +%name parseImport importdecl +%name parseStatement e_stmt +%name parseDeclaration topdecl +%name parseExpression exp +%name parsePattern pat +%name parseTypeSignature sigdecl +%name parseStmt maybe_stmt +%name parseIdentifier identifier +%name parseType ktype +%name parseBackpack backpack +%partial parseHeader header +%% + +----------------------------------------------------------------------------- +-- Identifiers; one of the entry points +identifier :: { Located RdrName } + : qvar { $1 } + | qcon { $1 } + | qvarop { $1 } + | qconop { $1 } + | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + [mop $1,mu AnnRarrow $2,mcp $3] } + | '->' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + [mu AnnRarrow $1] } + +----------------------------------------------------------------------------- +-- Backpack stuff + +backpack :: { [LHsUnit PackageName] } + : implicit_top units close { fromOL $2 } + | '{' units '}' { fromOL $2 } + +units :: { OrdList (LHsUnit PackageName) } + : units ';' unit { $1 `appOL` unitOL $3 } + | units ';' { $1 } + | unit { unitOL $1 } + +unit :: { LHsUnit PackageName } + : 'unit' pkgname 'where' unitbody + { sL1 $1 $ HsUnit { hsunitName = $2 + , hsunitBody = fromOL $4 } } + +unitid :: { LHsUnitId PackageName } + : pkgname { sL1 $1 $ HsUnitId $1 [] } + | pkgname '[' msubsts ']' { sLL $1 $> $ HsUnitId $1 (fromOL $3) } + +msubsts :: { OrdList (LHsModuleSubst PackageName) } + : msubsts ',' msubst { $1 `appOL` unitOL $3 } + | msubsts ',' { $1 } + | msubst { unitOL $1 } + +msubst :: { LHsModuleSubst PackageName } + : modid '=' moduleid { sLL $1 $> $ ($1, $3) } + | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) } + +moduleid :: { LHsModuleId PackageName } + : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 } + | unitid ':' modid { sLL $1 $> $ HsModuleId $1 $3 } + +pkgname :: { Located PackageName } + : STRING { sL1 $1 $ PackageName (getSTRING $1) } + | litpkgname { sL1 $1 $ PackageName (unLoc $1) } + +litpkgname_segment :: { Located FastString } + : VARID { sL1 $1 $ getVARID $1 } + | CONID { sL1 $1 $ getCONID $1 } + | special_id { $1 } + +-- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off. +-- See Note [Minus tokens] in GHC.Parser.Lexer +HYPHEN :: { [AddAnn] } + : '-' { [mj AnnMinus $1 ] } + | PREFIX_MINUS { [mj AnnMinus $1 ] } + | VARSYM {% if (getVARSYM $1 == fsLit "-") + then return [mj AnnMinus $1] + else do { addError (getLoc $1) $ text "Expected a hyphen" + ; return [] } } + + +litpkgname :: { Located FastString } + : litpkgname_segment { $1 } + -- a bit of a hack, means p - b is parsed same as p-b, enough for now. + | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) } + +mayberns :: { Maybe [LRenaming] } + : {- empty -} { Nothing } + | '(' rns ')' { Just (fromOL $2) } + +rns :: { OrdList LRenaming } + : rns ',' rn { $1 `appOL` unitOL $3 } + | rns ',' { $1 } + | rn { unitOL $1 } + +rn :: { LRenaming } + : modid 'as' modid { sLL $1 $> $ Renaming $1 (Just $3) } + | modid { sL1 $1 $ Renaming $1 Nothing } + +unitbody :: { OrdList (LHsUnitDecl PackageName) } + : '{' unitdecls '}' { $2 } + | vocurly unitdecls close { $2 } + +unitdecls :: { OrdList (LHsUnitDecl PackageName) } + : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 } + | unitdecls ';' { $1 } + | unitdecl { unitOL $1 } + +unitdecl :: { LHsUnitDecl PackageName } + : 'module' maybe_src modid maybemodwarning maybeexports 'where' body + -- XXX not accurate + { sL1 $1 $ DeclD + (case snd $2 of + NotBoot -> HsSrcFile + IsBoot -> HsBootFile) + $3 + (Just $ sL1 $1 (HsModule (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) } + | 'signature' modid maybemodwarning maybeexports 'where' body + { sL1 $1 $ DeclD + HsigFile + $2 + (Just $ sL1 $1 (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) } + | 'module' maybe_src modid + { sL1 $1 $ DeclD (case snd $2 of + NotBoot -> HsSrcFile + IsBoot -> HsBootFile) $3 Nothing } + | 'signature' modid + { sL1 $1 $ DeclD HsigFile $2 Nothing } + | 'dependency' unitid mayberns + { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 + , idModRenaming = $3 + , idSignatureInclude = False }) } + | 'dependency' 'signature' unitid + { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3 + , idModRenaming = Nothing + , idSignatureInclude = True }) } + +----------------------------------------------------------------------------- +-- Module Header + +-- The place for module deprecation is really too restrictive, but if it +-- was allowed at its natural place just before 'module', we get an ugly +-- s/r conflict with the second alternative. Another solution would be the +-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, +-- either, and DEPRECATED is only expected to be used by people who really +-- know what they are doing. :-) + +signature :: { Located HsModule } + : 'signature' modid maybemodwarning maybeexports 'where' body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) + (snd $ sndOf3 $6) $3 Nothing) + ) + ([mj AnnSignature $1, mj AnnWhere $5] ++ fstOf3 $6) } + +module :: { Located HsModule } + : 'module' modid maybemodwarning maybeexports 'where' body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) + (snd $ sndOf3 $6) $3 Nothing) + ) + ([mj AnnModule $1, mj AnnWhere $5] ++ fstOf3 $6) } + | body2 + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (thdOf3 $1) Nothing Nothing + (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing)) + (fstOf3 $1) } + +missing_module_keyword :: { () } + : {- empty -} {% pushModuleContext } + +implicit_top :: { () } + : {- empty -} {% pushModuleContext } + +maybemodwarning :: { Maybe (Located WarningTxt) } + : '{-# DEPRECATED' strings '#-}' + {% ajs (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2)) + (mo $1:mc $3: (fst $ unLoc $2)) } + | '{-# WARNING' strings '#-}' + {% ajs (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2)) + (mo $1:mc $3 : (fst $ unLoc $2)) } + | {- empty -} { Nothing } + +body :: { ([AddAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,LayoutInfo) } + : '{' top '}' { (moc $1:mcc $3:(fst $2) + , snd $2, ExplicitBraces) } + | vocurly top close { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) } + +body2 :: { ([AddAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,LayoutInfo) } + : '{' top '}' { (moc $1:mcc $3 + :(fst $2), snd $2, ExplicitBraces) } + | missing_module_keyword top close { ([],snd $2, VirtualBraces leftmostColumn) } + + +top :: { ([AddAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } + : semis top1 { ($1, $2) } + +top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } + : importdecls_semi topdecls_semi { (reverse $1, cvTopDecls $2) } + | importdecls_semi topdecls { (reverse $1, cvTopDecls $2) } + | importdecls { (reverse $1, []) } + +----------------------------------------------------------------------------- +-- Module declaration & imports only + +header :: { Located HsModule } + : 'module' modid maybemodwarning maybeexports 'where' header_body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + )) [mj AnnModule $1,mj AnnWhere $5] } + | 'signature' modid maybemodwarning maybeexports 'where' header_body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + )) [mj AnnModule $1,mj AnnWhere $5] } + | header_body2 + {% fileSrcSpan >>= \ loc -> + return (L loc (HsModule NoLayoutInfo Nothing Nothing $1 [] Nothing + Nothing)) } + +header_body :: { [LImportDecl GhcPs] } + : '{' header_top { $2 } + | vocurly header_top { $2 } + +header_body2 :: { [LImportDecl GhcPs] } + : '{' header_top { $2 } + | missing_module_keyword header_top { $2 } + +header_top :: { [LImportDecl GhcPs] } + : semis header_top_importdecls { $2 } + +header_top_importdecls :: { [LImportDecl GhcPs] } + : importdecls_semi { $1 } + | importdecls { $1 } + +----------------------------------------------------------------------------- +-- The Export List + +maybeexports :: { (Maybe (Located [LIE GhcPs])) } + : '(' exportlist ')' {% amsL (comb2 $1 $>) ([mop $1,mcp $3] ++ (fst $2)) >> + return (Just (sLL $1 $> (fromOL $ snd $2))) } + | {- empty -} { Nothing } + +exportlist :: { ([AddAnn], OrdList (LIE GhcPs)) } + : exportlist1 { ([], $1) } + | {- empty -} { ([], nilOL) } + + -- trailing comma: + | exportlist1 ',' { ([mj AnnComma $2], $1) } + | ',' { ([mj AnnComma $1], nilOL) } + +exportlist1 :: { OrdList (LIE GhcPs) } + : exportlist1 ',' export + {% (addAnnotation (oll $1) AnnComma (gl $2) ) >> + return ($1 `appOL` $3) } + | export { $1 } + + + -- No longer allow things like [] and (,,,) to be exported + -- They are built in syntax, always available +export :: { OrdList (LIE GhcPs) } + : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) + >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } + | 'module' modid {% amsu (sLL $1 $> (IEModuleContents noExtField $2)) + [mj AnnModule $1] } + | 'pattern' qcon {% amsu (sLL $1 $> (IEVar noExtField (sLL $1 $> (IEPattern $2)))) + [mj AnnPattern $1] } + +export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } + : {- empty -} { sL0 ([],ImpExpAbs) } + | '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2)) + >>= \(as,ie) -> return $ sLL $1 $> + (as ++ [mop $1,mcp $3] ++ fst $2, ie) } + + +qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } + : {- empty -} { ([],[]) } + | qcnames1 { $1 } + +qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list + : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of + l@(L _ ImpExpQcWildcard) -> + return ([mj AnnComma $2, mj AnnDotdot l] + ,(snd (unLoc $3) : snd $1)) + l -> (ams (head (snd $1)) [mj AnnComma $2] >> + return (fst $1 ++ fst (unLoc $3), + snd (unLoc $3) : snd $1)) } + + + -- Annotations re-added in mkImpExpSubSpec + | qcname_ext_w_wildcard { (fst (unLoc $1),[snd (unLoc $1)]) } + +-- Variable, data constructor or wildcard +-- or tagged type constructor +qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) } + : qcname_ext { sL1 $1 ([],$1) } + | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) } + +qcname_ext :: { Located ImpExpQcSpec } + : qcname { sL1 $1 (ImpExpQcName $1) } + | 'type' oqtycon {% do { n <- mkTypeImpExp $2 + ; ams (sLL $1 $> (ImpExpQcType n)) + [mj AnnType $1] } } + +qcname :: { Located RdrName } -- Variable or type constructor + : qvar { $1 } -- Things which look like functions + -- Note: This includes record selectors but + -- also (-.->), see #11432 + | oqtycon_no_varcon { $1 } -- see Note [Type constructors in export list] + +----------------------------------------------------------------------------- +-- Import Declarations + +-- importdecls and topdecls must contain at least one declaration; +-- top handles the fact that these may be optional. + +-- One or more semicolons +semis1 :: { [AddAnn] } +semis1 : semis1 ';' { mj AnnSemi $2 : $1 } + | ';' { [mj AnnSemi $1] } + +-- Zero or more semicolons +semis :: { [AddAnn] } +semis : semis ';' { mj AnnSemi $2 : $1 } + | {- empty -} { [] } + +-- No trailing semicolons, non-empty +importdecls :: { [LImportDecl GhcPs] } +importdecls + : importdecls_semi importdecl + { $2 : $1 } + +-- May have trailing semicolons, can be empty +importdecls_semi :: { [LImportDecl GhcPs] } +importdecls_semi + : importdecls_semi importdecl semis1 + {% ams $2 $3 >> return ($2 : $1) } + | {- empty -} { [] } + +importdecl :: { LImportDecl GhcPs } + : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec + {% do { + ; let { ; mPreQual = unLoc $4 + ; mPostQual = unLoc $7 } + ; checkImportDecl mPreQual mPostQual + ; ams (L (comb5 $1 $6 $7 (snd $8) $9) $ + ImportDecl { ideclExt = noExtField + , ideclSourceSrc = snd $ fst $2 + , ideclName = $6, ideclPkgQual = snd $5 + , ideclSource = snd $2, ideclSafe = snd $3 + , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual + , ideclImplicit = False + , ideclAs = unLoc (snd $8) + , ideclHiding = unLoc $9 }) + (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList mPreQual) + ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst $8) + } + } + + +maybe_src :: { (([AddAnn],SourceText),IsBootInterface) } + : '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1) + , IsBoot) } + | {- empty -} { (([],NoSourceText),NotBoot) } + +maybe_safe :: { ([AddAnn],Bool) } + : 'safe' { ([mj AnnSafe $1],True) } + | {- empty -} { ([],False) } + +maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } + : STRING {% do { let { pkgFS = getSTRING $1 } + ; unless (looksLikePackageName (unpackFS pkgFS)) $ + addError (getLoc $1) $ vcat [ + text "Parse error" <> colon <+> quotes (ppr pkgFS), + text "Version number or non-alphanumeric" <+> + text "character in package name"] + ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } } + | {- empty -} { ([],Nothing) } + +optqualified :: { Located (Maybe (Located Token)) } + : 'qualified' { sL1 $1 (Just $1) } + | {- empty -} { noLoc Nothing } + +maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) } + : 'as' modid { ([mj AnnAs $1] + ,sLL $1 $> (Just $2)) } + | {- empty -} { ([],noLoc Nothing) } + +maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } + : impspec {% let (b, ie) = unLoc $1 in + checkImportSpec ie + >>= \checkedIe -> + return (L (gl $1) (Just (b, checkedIe))) } + | {- empty -} { noLoc Nothing } + +impspec :: { Located (Bool, Located [LIE GhcPs]) } + : '(' exportlist ')' {% ams (sLL $1 $> (False, + sLL $1 $> $ fromOL (snd $2))) + ([mop $1,mcp $3] ++ (fst $2)) } + | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True, + sLL $1 $> $ fromOL (snd $3))) + ([mj AnnHiding $1,mop $2,mcp $4] ++ (fst $3)) } + +----------------------------------------------------------------------------- +-- Fixity Declarations + +prec :: { Located (SourceText,Int) } + : {- empty -} { noLoc (NoSourceText,9) } + | INTEGER + { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) } + +infix :: { Located FixityDirection } + : 'infix' { sL1 $1 InfixN } + | 'infixl' { sL1 $1 InfixL } + | 'infixr' { sL1 $1 InfixR } + +ops :: { Located (OrdList (Located RdrName)) } + : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))} + | op { sL1 $1 (unitOL $1) } + +----------------------------------------------------------------------------- +-- Top-Level Declarations + +-- No trailing semicolons, non-empty +topdecls :: { OrdList (LHsDecl GhcPs) } + : topdecls_semi topdecl { $1 `snocOL` $2 } + +-- May have trailing semicolons, can be empty +topdecls_semi :: { OrdList (LHsDecl GhcPs) } + : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) } + | {- empty -} { nilOL } + +topdecl :: { LHsDecl GhcPs } + : cl_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } + | ty_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } + | standalone_kind_sig { sL1 $1 (KindSigD noExtField (unLoc $1)) } + | inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) } + | stand_alone_deriving { sLL $1 $> (DerivD noExtField (unLoc $1)) } + | role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) } + | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD noExtField (DefaultDecl noExtField $3))) + [mj AnnDefault $1 + ,mop $2,mcp $4] } + | 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2)) + (mj AnnForeign $1:(fst $ unLoc $2)) } + | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getDEPRECATED_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getWARNING_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD noExtField (HsRules noExtField (getRULES_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | annotation { $1 } + | decl_no_th { $1 } + + -- Template Haskell Extension + -- The $(..) form is one possible form of infixexp + -- but we treat an arbitrary expression just as if + -- it had a $(..) wrapped around it + | infixexp {% runECP_P $1 >>= \ $1 -> + return $ sLL $1 $> $ mkSpliceDecl $1 } + +-- Type classes +-- +cl_decl :: { LTyClDecl GhcPs } + : 'class' tycl_hdr fds where_cls + {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4)) + (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) } + +-- Type declarations (toplevel) +-- +ty_decl :: { LTyClDecl GhcPs } + -- ordinary type synonyms + : 'type' type '=' ktype + -- Note ktype, not sigtype, on the right of '=' + -- We allow an explicit for-all but we don't insert one + -- in type Foo a = (b,b) + -- Instead we just say b is out of scope + -- + -- Note the use of type for the head; this allows + -- infix type constructors to be declared + {% amms (mkTySynonym (comb2 $1 $4) $2 $4) + [mj AnnType $1,mj AnnEqual $3] } + + -- type family declarations + | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info + where_type_family + -- Note the use of type for the head; this allows + -- infix type constructors to be declared + {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3 + (snd $ unLoc $4) (snd $ unLoc $5)) + (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4) + ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } + + -- ordinary data type or newtype declaration + | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings + {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 + Nothing (reverse (snd $ unLoc $4)) + (fmap reverse $5)) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc $1):(fst $ unLoc $4)) } + + -- ordinary GADT declaration + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + gadt_constrlist + maybe_derivings + {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 + (snd $ unLoc $4) (snd $ unLoc $5) + (fmap reverse $6) ) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } + + -- data/newtype family + | 'data' 'family' type opt_datafam_kind_sig + {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 + (snd $ unLoc $4) Nothing) + (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } + +-- standalone kind signature +standalone_kind_sig :: { LStandaloneKindSig GhcPs } + : 'type' sks_vars '::' ktype + {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4) + [mj AnnType $1,mu AnnDcolon $3] } + +-- See also: sig_vars +sks_vars :: { Located [Located RdrName] } -- Returned in reverse order + : sks_vars ',' oqtycon + {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> ($3 : unLoc $1)) } + | oqtycon { sL1 $1 [$1] } + +inst_decl :: { LInstDecl GhcPs } + : 'instance' overlap_pragma inst_type where_inst + {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) + ; let cid = ClsInstDecl { cid_ext = noExtField + , cid_poly_ty = $3, cid_binds = binds + , cid_sigs = mkClassOpSigs sigs + , cid_tyfam_insts = ats + , cid_overlap_mode = $2 + , cid_datafam_insts = adts } + ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) + (mj AnnInstance $1 : (fst $ unLoc $4)) } } + + -- type instance declarations + | 'type' 'instance' ty_fam_inst_eqn + {% ams $3 (fst $ unLoc $3) + >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) + (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } + + -- data/newtype instance declaration + | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs + maybe_derivings + {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4) + Nothing (reverse (snd $ unLoc $5)) + (fmap reverse $6)) + ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) } + + -- GADT instance declaration + | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig + gadt_constrlist + maybe_derivings + {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4) + (snd $ unLoc $5) (snd $ unLoc $6) + (fmap reverse $7)) + ((fst $ unLoc $1):mj AnnInstance $2 + :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) } + +overlap_pragma :: { Maybe (Located OverlapMode) } + : '{-# OVERLAPPABLE' '#-}' {% ajs (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) + [mo $1,mc $2] } + | '{-# OVERLAPPING' '#-}' {% ajs (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) + [mo $1,mc $2] } + | '{-# OVERLAPS' '#-}' {% ajs (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) + [mo $1,mc $2] } + | '{-# INCOHERENT' '#-}' {% ajs (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) + [mo $1,mc $2] } + | {- empty -} { Nothing } + +deriv_strategy_no_via :: { LDerivStrategy GhcPs } + : 'stock' {% ams (sL1 $1 StockStrategy) + [mj AnnStock $1] } + | 'anyclass' {% ams (sL1 $1 AnyclassStrategy) + [mj AnnAnyclass $1] } + | 'newtype' {% ams (sL1 $1 NewtypeStrategy) + [mj AnnNewtype $1] } + +deriv_strategy_via :: { LDerivStrategy GhcPs } + : 'via' ktype {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2))) + [mj AnnVia $1] } + +deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } + : 'stock' {% ajs (sL1 $1 StockStrategy) + [mj AnnStock $1] } + | 'anyclass' {% ajs (sL1 $1 AnyclassStrategy) + [mj AnnAnyclass $1] } + | 'newtype' {% ajs (sL1 $1 NewtypeStrategy) + [mj AnnNewtype $1] } + | deriv_strategy_via { Just $1 } + | {- empty -} { Nothing } + +-- Injective type families + +opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn GhcPs)) } + : {- empty -} { noLoc ([], Nothing) } + | '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1] + , Just ($2)) } + +injectivity_cond :: { LInjectivityAnn GhcPs } + : tyvarid '->' inj_varids + {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3)))) + [mu AnnRarrow $2] } + +inj_varids :: { Located [Located RdrName] } + : inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) } + | tyvarid { sLL $1 $> [$1] } + +-- Closed type families + +where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) } + : {- empty -} { noLoc ([],OpenTypeFamily) } + | 'where' ty_fam_inst_eqn_list + { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) + ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) } + +ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } + : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] + ,Just (unLoc $2)) } + | vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in + L loc ([],Just (unLoc $2)) } + | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 + ,mcc $3],Nothing) } + | vocurly '..' close { let (L loc _) = $2 in + L loc ([mj AnnDotdot $2],Nothing) } + +ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } + : ty_fam_inst_eqns ';' ty_fam_inst_eqn + {% let (L loc (anns, eqn)) = $3 in + asl (unLoc $1) $2 (L loc eqn) + >> ams $3 anns + >> return (sLL $1 $> (L loc eqn : unLoc $1)) } + | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) + >> return (sLL $1 $> (unLoc $1)) } + | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in + ams $1 anns + >> return (sLL $1 $> [L loc eqn]) } + | {- empty -} { noLoc [] } + +ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } + : 'forall' tv_bndrs '.' type '=' ktype + {% do { hintExplicitForall $1 + ; tvb <- fromSpecTyVarBndrs $2 + ; (eqn,ann) <- mkTyFamInstEqn (Just tvb) $4 $6 + ; return (sLL $1 $> + (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } } + | type '=' ktype + {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3 + ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } } + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + +-- Associated type family declarations +-- +-- * They have a different syntax than on the toplevel (no family special +-- identifier). +-- +-- * They also need to be separate from instances; otherwise, data family +-- declarations without a kind signature cause parsing conflicts with empty +-- data declarations. +-- +at_decl_cls :: { LHsDecl GhcPs } + : -- data family declarations, with optional 'family' keyword + 'data' opt_family type opt_datafam_kind_sig + {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 + (snd $ unLoc $4) Nothing)) + (mj AnnData $1:$2++(fst $ unLoc $4)) } + + -- type family declarations, with optional 'family' keyword + -- (can't use opt_instance because you get shift/reduce errors + | 'type' type opt_at_kind_inj_sig + {% amms (liftM mkTyClD + (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 + (fst . snd $ unLoc $3) + (snd . snd $ unLoc $3))) + (mj AnnType $1:(fst $ unLoc $3)) } + | 'type' 'family' type opt_at_kind_inj_sig + {% amms (liftM mkTyClD + (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 + (fst . snd $ unLoc $4) + (snd . snd $ unLoc $4))) + (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) } + + -- default type instances, with optional 'instance' keyword + | 'type' ty_fam_inst_eqn + {% ams $2 (fst $ unLoc $2) >> + amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))) + (mj AnnType $1:(fst $ unLoc $2)) } + | 'type' 'instance' ty_fam_inst_eqn + {% ams $3 (fst $ unLoc $3) >> + amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))) + (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } + +opt_family :: { [AddAnn] } + : {- empty -} { [] } + | 'family' { [mj AnnFamily $1] } + +opt_instance :: { [AddAnn] } + : {- empty -} { [] } + | 'instance' { [mj AnnInstance $1] } + +-- Associated type instances +-- +at_decl_inst :: { LInstDecl GhcPs } + -- type instance declarations, with optional 'instance' keyword + : 'type' opt_instance ty_fam_inst_eqn + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + {% ams $3 (fst $ unLoc $3) >> + amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) + (mj AnnType $1:$2++(fst $ unLoc $3)) } + + -- data/newtype instance declaration, with optional 'instance' keyword + | data_or_newtype opt_instance capi_ctype tycl_hdr_inst constrs maybe_derivings + {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4) + Nothing (reverse (snd $ unLoc $5)) + (fmap reverse $6)) + ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) } + + -- GADT instance declaration, with optional 'instance' keyword + | data_or_newtype opt_instance capi_ctype tycl_hdr_inst opt_kind_sig + gadt_constrlist + maybe_derivings + {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 + (snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6) + (fmap reverse $7)) + ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) } + +data_or_newtype :: { Located (AddAnn, NewOrData) } + : 'data' { sL1 $1 (mj AnnData $1,DataType) } + | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } + +-- Family result/return kind signatures + +opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) } + : { noLoc ([] , Nothing) } + | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) } + +opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } + : { noLoc ([] , noLoc (NoSig noExtField) )} + | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))} + +opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } + : { noLoc ([] , noLoc (NoSig noExtField) )} + | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))} + | '=' tv_bndr {% do { tvb <- fromSpecTyVarBndr $2 + ; return $ sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExtField tvb))} } + +opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs + , Maybe (LInjectivityAnn GhcPs)))} + : { noLoc ([], (noLoc (NoSig noExtField), Nothing)) } + | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] + , (sLL $2 $> (KindSig noExtField $2), Nothing)) } + | '=' tv_bndr_no_braces '|' injectivity_cond + {% do { tvb <- fromSpecTyVarBndr $2 + ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] + , (sLL $1 $2 (TyVarSig noExtField tvb), Just $4))} } + +-- tycl_hdr parses the header of a class or data type decl, +-- which takes the form +-- T a b +-- Eq a => T a +-- (Eq a, Ord b) => T a b +-- T Int [a] -- for associated types +-- Rather a lot of inlining here, else we get reduce/reduce errors +tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) } + : context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) + >> (return (sLL $1 $> (Just $1, $3))) + } + | type { sL1 $1 (Nothing, $1) } + +tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs], LHsType GhcPs)) } + : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1 + >> fromSpecTyVarBndrs $2 + >>= \tvbs -> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5) + >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] + , (Just $4, Just tvbs, $6))) + ) + } + | 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1 + ; tvbs <- fromSpecTyVarBndrs $2 + ; return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] + , (Nothing, Just tvbs, $4))) + } } + | context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) + >> (return (sLL $1 $>([], (Just $1, Nothing, $3)))) + } + | type { sL1 $1 ([], (Nothing, Nothing, $1)) } + + +capi_ctype :: { Maybe (Located CType) } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' + {% ajs (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRINGs $3,getSTRING $3))) + [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] } + + | '{-# CTYPE' STRING '#-}' + {% ajs (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))) + [mo $1,mj AnnVal $2,mc $3] } + + | { Nothing } + +----------------------------------------------------------------------------- +-- Stand-alone deriving + +-- Glasgow extension: stand-alone deriving declarations +stand_alone_deriving :: { LDerivDecl GhcPs } + : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type + {% do { let { err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr $5) } + ; ams (sLL $1 (hsSigType $>) + (DerivDecl noExtField (mkHsWildCardBndrs $5) $2 $4)) + [mj AnnDeriving $1, mj AnnInstance $3] } } + +----------------------------------------------------------------------------- +-- Role annotations + +role_annot :: { LRoleAnnotDecl GhcPs } +role_annot : 'type' 'role' oqtycon maybe_roles + {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4))) + [mj AnnType $1,mj AnnRole $2] } + +-- Reversed! +maybe_roles :: { Located [Located (Maybe FastString)] } +maybe_roles : {- empty -} { noLoc [] } + | roles { $1 } + +roles :: { Located [Located (Maybe FastString)] } +roles : role { sLL $1 $> [$1] } + | roles role { sLL $1 $> $ $2 : unLoc $1 } + +-- read it in as a varid for better error messages +role :: { Located (Maybe FastString) } +role : VARID { sL1 $1 $ Just $ getVARID $1 } + | '_' { sL1 $1 Nothing } + +-- Pattern synonyms + +-- Glasgow extension: pattern synonyms +pattern_synonym_decl :: { LHsDecl GhcPs } + : 'pattern' pattern_synonym_lhs '=' pat + {% let (name, args,as ) = $2 in + ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 + ImplicitBidirectional) + (as ++ [mj AnnPattern $1, mj AnnEqual $3]) + } + + | 'pattern' pattern_synonym_lhs '<-' pat + {% let (name, args, as) = $2 in + ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional) + (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) } + + | 'pattern' pattern_synonym_lhs '<-' pat where_decls + {% do { let (name, args, as) = $2 + ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) + ; ams (sLL $1 $> . ValD noExtField $ + mkPatSynBind name args $4 (ExplicitBidirectional mg)) + (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) ) + }} + +pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) } + : con vars0 { ($1, PrefixCon $2, []) } + | varid conop varid { ($2, InfixCon $1 $3, []) } + | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) } + +vars0 :: { [Located RdrName] } + : {- empty -} { [] } + | varid vars0 { $1 : $2 } + +cvars1 :: { [RecordPatSynField (Located RdrName)] } + : var { [RecordPatSynField $1 $1] } + | var ',' cvars1 {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >> + return ((RecordPatSynField $1 $1) : $3 )} + +where_decls :: { Located ([AddAnn] + , Located (OrdList (LHsDecl GhcPs))) } + : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 + :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } + | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) + ,sL1 $3 (snd $ unLoc $3)) } + +pattern_synonym_sig :: { LSig GhcPs } + : 'pattern' con_list '::' sigtype + {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) (mkLHsSigType $4)) + [mj AnnPattern $1, mu AnnDcolon $3] } + +----------------------------------------------------------------------------- +-- Nested declarations + +-- Declaration in class bodies +-- +decl_cls :: { LHsDecl GhcPs } +decl_cls : at_decl_cls { $1 } + | decl { $1 } + + -- A 'default' signature used with the generic-programming extension + | 'default' infixexp '::' sigtype + {% runECP_P $2 >>= \ $2 -> + do { v <- checkValSigLhs $2 + ; let err = text "in default signature" <> colon <+> + quotes (ppr $2) + ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $ mkLHsSigType $4) + [mj AnnDefault $1,mu AnnDcolon $3] } } + +decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed + : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unitOL $3)) + else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] + >> return (sLL $1 $> (fst $ unLoc $1 + ,(snd $ unLoc $1) `appOL` unitOL $3)) } + | decls_cls ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] + >> return (sLL $1 $> (unLoc $1)) } + | decl_cls { sL1 $1 ([], unitOL $1) } + | {- empty -} { noLoc ([],nilOL) } + +decllist_cls + :: { Located ([AddAnn] + , OrdList (LHsDecl GhcPs) + , LayoutInfo) } -- Reversed + : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) + ,snd $ unLoc $2, ExplicitBraces) } + | vocurly decls_cls close { let { L l (anns, decls) = $2 } + in L l (anns, decls, VirtualBraces (getVOCURLY $1)) } + +-- Class body +-- +where_cls :: { Located ([AddAnn] + ,(OrdList (LHsDecl GhcPs)) -- Reversed + ,LayoutInfo) } + -- No implicit parameters + -- May have type declarations + : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2) + ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) } + | {- empty -} { noLoc ([],nilOL,NoLayoutInfo) } + +-- Declarations in instance bodies +-- +decl_inst :: { Located (OrdList (LHsDecl GhcPs)) } +decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) } + | decl { sLL $1 $> (unitOL $1) } + +decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed + : decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unLoc $3)) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return + (sLL $1 $> (fst $ unLoc $1 + ,(snd $ unLoc $1) `appOL` unLoc $3)) } + | decls_inst ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return (sLL $1 $> (unLoc $1)) } + | decl_inst { sL1 $1 ([],unLoc $1) } + | {- empty -} { noLoc ([],nilOL) } + +decllist_inst + :: { Located ([AddAnn] + , OrdList (LHsDecl GhcPs)) } -- Reversed + : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } + | vocurly decls_inst close { L (gl $2) (unLoc $2) } + +-- Instance body +-- +where_inst :: { Located ([AddAnn] + , OrdList (LHsDecl GhcPs)) } -- Reversed + -- No implicit parameters + -- May have type declarations + : 'where' decllist_inst { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) + ,(snd $ unLoc $2)) } + | {- empty -} { noLoc ([],nilOL) } + +-- Declarations in binding groups other than classes and instances +-- +decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } + : decls ';' decl {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unitOL $3)) + else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return ( + let { this = unitOL $3; + rest = snd $ unLoc $1; + these = rest `appOL` this } + in rest `seq` this `seq` these `seq` + (sLL $1 $> (fst $ unLoc $1,these))) } + | decls ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1))) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return (sLL $1 $> (unLoc $1)) } + | decl { sL1 $1 ([], unitOL $1) } + | {- empty -} { noLoc ([],nilOL) } + +decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) } + : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) + ,sL1 $2 $ snd $ unLoc $2) } + | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } + +-- Binding groups other than those of class and instance declarations +-- +binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } + -- May have implicit parameters + -- No type declarations + : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) + ; return (sL1 $1 (fst $ unLoc $1 + ,sL1 $1 $ HsValBinds noExtField val_binds)) } } + + | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] + ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } + + | vocurly dbinds close { L (getLoc $2) ([] + ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } + + +wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } + -- May have implicit parameters + -- No type declarations + : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2) + ,snd $ unLoc $2) } + | {- empty -} { noLoc ([],noLoc emptyLocalBinds) } + + +----------------------------------------------------------------------------- +-- Transformation Rules + +rules :: { OrdList (LRuleDecl GhcPs) } + : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return ($1 `snocOL` $3) } + | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return $1 } + | rule { unitOL $1 } + | {- empty -} { nilOL } + +rule :: { LRuleDecl GhcPs } + : STRING rule_activation rule_foralls infixexp '=' exp + {%runECP_P $4 >>= \ $4 -> + runECP_P $6 >>= \ $6 -> + ams (sLL $1 $> $ HsRule { rd_ext = noExtField + , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1) + , rd_act = (snd $2) `orElse` AlwaysActive + , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 + , rd_lhs = $4, rd_rhs = $6 }) + (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) } + +-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas +rule_activation :: { ([AddAnn],Maybe Activation) } + : {- empty -} { ([],Nothing) } + | rule_explicit_activation { (fst $1,Just (snd $1)) } + +-- This production is used to parse the tilde syntax in pragmas such as +-- * {-# INLINE[~2] ... #-} +-- * {-# SPECIALISE [~ 001] ... #-} +-- * {-# RULES ... [~0] ... g #-} +-- Note that it can be written either +-- without a space [~1] (the PREFIX_TILDE case), or +-- with a space [~ 1] (the VARSYM case). +-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer +rule_activation_marker :: { [AddAnn] } + : PREFIX_TILDE { [mj AnnTilde $1] } + | VARSYM {% if (getVARSYM $1 == fsLit "~") + then return [mj AnnTilde $1] + else do { addError (getLoc $1) $ text "Invalid rule activation marker" + ; return [] } } + +rule_explicit_activation :: { ([AddAnn] + ,Activation) } -- In brackets + : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] + ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } + | '[' rule_activation_marker INTEGER ']' + { ($2++[mos $1,mj AnnVal $3,mcs $4] + ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } + | '[' rule_activation_marker ']' + { ($2++[mos $1,mcs $3] + ,NeverActive) } + +rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) } + : 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2 + in hintExplicitForall $1 + >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2) + >> return ([mu AnnForall $1,mj AnnDot $3, + mu AnnForall $4,mj AnnDot $6], + Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) } + | 'forall' rule_vars '.' { ([mu AnnForall $1,mj AnnDot $3], + Nothing, mkRuleBndrs $2) } + | {- empty -} { ([], Nothing, []) } + +rule_vars :: { [LRuleTyTmVar] } + : rule_var rule_vars { $1 : $2 } + | {- empty -} { [] } + +rule_var :: { LRuleTyTmVar } + : varid { sLL $1 $> (RuleTyTmVar $1 Nothing) } + | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleTyTmVar $2 (Just $4))) + [mop $1,mu AnnDcolon $3,mcp $5] } + +{- Note [Parsing explicit foralls in Rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We really want the above definition of rule_foralls to be: + + rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.' + | 'forall' rule_vars '.' + | {- empty -} + +where rule_vars (term variables) can be named "forall", "family", or "role", +but tv_vars (type variables) cannot be. However, such a definition results +in a reduce/reduce conflict. For example, when parsing: +> {-# RULE "name" forall a ... #-} +before the '...' it is impossible to determine whether we should be in the +first or second case of the above. + +This is resolved by using rule_vars (which is more general) for both, and +ensuring that type-level quantified variables do not have the names "forall", +"family", or "role" in the function 'checkRuleTyVarBndrNames' in +GHC.Parser.PostProcess. +Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative +to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. +-} + +----------------------------------------------------------------------------- +-- Warnings and deprecations (c.f. rules) + +warnings :: { OrdList (LWarnDecl GhcPs) } + : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return ($1 `appOL` $3) } + | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return $1 } + | warning { $1 } + | {- empty -} { nilOL } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +warning :: { OrdList (LWarnDecl GhcPs) } + : namelist strings + {% amsu (sLL $1 $> (Warning noExtField (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) + (fst $ unLoc $2) } + +deprecations :: { OrdList (LWarnDecl GhcPs) } + : deprecations ';' deprecation + {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return ($1 `appOL` $3) } + | deprecations ';' {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return $1 } + | deprecation { $1 } + | {- empty -} { nilOL } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +deprecation :: { OrdList (LWarnDecl GhcPs) } + : namelist strings + {% amsu (sLL $1 $> $ (Warning noExtField (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) + (fst $ unLoc $2) } + +strings :: { Located ([AddAnn],[Located StringLiteral]) } + : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } + | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } + +stringlist :: { Located (OrdList (Located StringLiteral)) } + : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> (unLoc $1 `snocOL` + (L (gl $3) (getStringLiteral $3)))) } + | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } + | {- empty -} { noLoc nilOL } + +----------------------------------------------------------------------------- +-- Annotations +annotation :: { LHsDecl GhcPs } + : '{-# ANN' name_var aexp '#-}' {% runECP_P $3 >>= \ $3 -> + ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField + (getANN_PRAGs $1) + (ValueAnnProvenance $2) $3)) + [mo $1,mc $4] } + + | '{-# ANN' 'type' tycon aexp '#-}' {% runECP_P $4 >>= \ $4 -> + ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField + (getANN_PRAGs $1) + (TypeAnnProvenance $3) $4)) + [mo $1,mj AnnType $2,mc $5] } + + | '{-# ANN' 'module' aexp '#-}' {% runECP_P $3 >>= \ $3 -> + ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField + (getANN_PRAGs $1) + ModuleAnnProvenance $3)) + [mo $1,mj AnnModule $2,mc $4] } + + +----------------------------------------------------------------------------- +-- Foreign import and export declarations + +fdecl :: { Located ([AddAnn],HsDecl GhcPs) } +fdecl : 'import' callconv safety fspec + {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> + return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } + | 'import' callconv fspec + {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3); + return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }} + | 'export' callconv fspec + {% mkExport $2 (snd $ unLoc $3) >>= \i -> + return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) } + +callconv :: { Located CCallConv } + : 'stdcall' { sLL $1 $> StdCallConv } + | 'ccall' { sLL $1 $> CCallConv } + | 'capi' { sLL $1 $> CApiConv } + | 'prim' { sLL $1 $> PrimCallConv} + | 'javascript' { sLL $1 $> JavaScriptCallConv } + +safety :: { Located Safety } + : 'unsafe' { sLL $1 $> PlayRisky } + | 'safe' { sLL $1 $> PlaySafe } + | 'interruptible' { sLL $1 $> PlayInterruptible } + +fspec :: { Located ([AddAnn] + ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } + : STRING var '::' sigtype { sLL $1 $> ([mu AnnDcolon $3] + ,(L (getLoc $1) + (getStringLiteral $1), $2, mkLHsSigType $4)) } + | var '::' sigtype { sLL $1 $> ([mu AnnDcolon $2] + ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } + -- if the entity string is missing, it defaults to the empty string; + -- the meaning of an empty entity string depends on the calling + -- convention + +----------------------------------------------------------------------------- +-- Type signatures + +opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) } + : {- empty -} { ([],Nothing) } + | '::' sigtype { ([mu AnnDcolon $1],Just $2) } + +opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } + : {- empty -} { ([], Nothing) } + | '::' gtycon { ([mu AnnDcolon $1], Just $2) } + +sigtype :: { LHsType GhcPs } + : ctype { $1 } + +sig_vars :: { Located [Located RdrName] } -- Returned in reversed order + : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) + AnnComma (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } + | var { sL1 $1 [$1] } + +sigtypes1 :: { (OrdList (LHsSigType GhcPs)) } + : sigtype { unitOL (mkLHsSigType $1) } + | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) + >> return (unitOL (mkLHsSigType $1) `appOL` $3) } + +----------------------------------------------------------------------------- +-- Types + +unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) } + : '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) } + | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) } + +forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) } + : 'forall' tv_bndrs '.' {% do { hintExplicitForall $1 + ; pure $ sLL $1 $> + ( [mu AnnForall $1, mu AnnDot $3] + , mkHsForAllInvisTele $2 ) }} + | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1 + ; req_tvbs <- fromSpecTyVarBndrs $2 + ; pure $ sLL $1 $> $ + ( [mu AnnForall $1, mu AnnRarrow $3] + , mkHsForAllVisTele req_tvbs ) }} + +-- A ktype is a ctype, possibly with a kind annotation +ktype :: { LHsType GhcPs } + : ctype { $1 } + | ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3) + [mu AnnDcolon $2] } + +-- A ctype is a for-all type +ctype :: { LHsType GhcPs } + : forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in + ams (sLL $1 $> $ + HsForAllTy { hst_tele = forall_tele + , hst_xforall = noExtField + , hst_body = $2 }) + forall_anns } + | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) + >> return (sLL $1 $> $ + HsQualTy { hst_ctxt = $1 + , hst_xqual = noExtField + , hst_body = $3 }) } + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3)) + [mu AnnDcolon $2] } + | type { $1 } + +---------------------- +-- Notes for 'context' +-- We parse a context as a btype so that we don't get reduce/reduce +-- errors in ctype. The basic problem is that +-- (Eq a, Ord a) +-- looks so much like a tuple type. We can't tell until we find the => + +context :: { LHsContext GhcPs } + : btype {% do { (anns,ctx) <- checkContext $1 + ; if null (unLoc ctx) + then addAnnotation (gl $1) AnnUnit (gl $1) + else return () + ; ams ctx anns + } } + +{- Note [GADT decl discards annotations] +~~~~~~~~~~~~~~~~~~~~~ +The type production for + + btype `->` ctype + +add the AnnRarrow annotation twice, in different places. + +This is because if the type is processed as usual, it belongs on the annotations +for the type as a whole. + +But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and +the top-level annotation will be disconnected. Hence for this specific case it +is connected to the first type too. +-} + +type :: { LHsType GhcPs } + : btype { $1 } + | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See Note [GADT decl discards annotations] + >> ams (sLL $1 $> $ HsFunTy noExtField (HsUnrestrictedArrow (toUnicode $2)) $1 $3) + [mu AnnRarrow $2] } + + | btype mult '->' ctype {% hintLinear (getLoc $2) + >> let (arr, ann) = (unLoc $2) (toUnicode $3) + in (ams $1 [ann,mu AnnRarrow $3] -- See Note [GADT decl discards annotations] + >> ams (sLL $1 $> $ HsFunTy noExtField arr $1 $4) + [ann,mu AnnRarrow $3]) } + + | btype '->.' ctype {% hintLinear (getLoc $2) + >> ams $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations] + >> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3) + [mu AnnLollyU $2] } + +mult :: { Located (IsUnicodeSyntax -> (HsArrow GhcPs, AddAnn)) } + : PREFIX_PERCENT atype { sLL $1 $> (\u -> mkMultTy u $1 $2) } + +btype :: { LHsType GhcPs } + : tyapps {% mergeOps (unLoc $1) } + +tyapps :: { Located [Located TyEl] } -- NB: This list is reversed + : tyapp { sL1 $1 [$1] } + | tyapps tyapp { sLL $1 $> $ $2 : unLoc $1 } + +tyapp :: { Located TyEl } + : atype { sL1 $1 $ TyElOpd (unLoc $1) } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | PREFIX_AT atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) } + + | qtyconop { sL1 $1 $ TyElOpr (unLoc $1) } + | tyvarop { sL1 $1 $ TyElOpr (unLoc $1) } + | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) + [mj AnnSimpleQuote $1,mj AnnVal $2] } + | SIMPLEQUOTE varop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) + [mj AnnSimpleQuote $1,mj AnnVal $2] } + | unpackedness { sL1 $1 $ TyElUnpackedness (unLoc $1) } + +atype :: { LHsType GhcPs } + : ntgtycon { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- Not including unit tuples + | tyvar { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- (See Note [Unit tuples]) + | '*' {% do { warnStarIsType (getLoc $1) + ; return $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | PREFIX_TILDE atype {% ams (sLL $1 $> (mkBangTy SrcLazy $2)) [mj AnnTilde $1] } + | PREFIX_BANG atype {% ams (sLL $1 $> (mkBangTy SrcStrict $2)) [mj AnnBang $1] } + + | '{' fielddecls '}' {% amms (checkRecordSyntax + (sLL $1 $> $ HsRecTy noExtField $2)) + -- Constructor sigs only + [moc $1,mcc $3] } + | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExtField + HsBoxedOrConstraintTuple []) + [mop $1,mcp $2] } + | '(' ktype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma + (gl $3) >> + ams (sLL $1 $> $ HsTupleTy noExtField + + HsBoxedOrConstraintTuple ($2 : $4)) + [mop $1,mcp $5] } + | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple []) + [mo $1,mc $2] } + | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple $2) + [mo $1,mc $3] } + | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExtField $2) + [mo $1,mc $3] } + | '[' ktype ']' {% ams (sLL $1 $> $ HsListTy noExtField $2) [mos $1,mcs $3] } + | '(' ktype ')' {% ams (sLL $1 $> $ HsParTy noExtField $2) [mop $1,mcp $3] } + | quasiquote { mapLoc (HsSpliceTy noExtField) $1 } + | splice_untyped { mapLoc (HsSpliceTy noExtField) $1 } + -- see Note [Promotion] for the followings + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE '(' ktype ',' comma_types1 ')' + {% addAnnotation (gl $3) AnnComma (gl $4) >> + ams (sLL $1 $> $ HsExplicitTupleTy noExtField ($3 : $5)) + [mj AnnSimpleQuote $1,mop $2,mcp $6] } + | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExtField IsPromoted $3) + [mj AnnSimpleQuote $1,mos $2,mcs $4] } + | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) + [mj AnnSimpleQuote $1,mj AnnName $2] } + + -- Two or more [ty, ty, ty] must be a promoted list type, just as + -- if you had written '[ty, ty, ty] + -- (One means a list type, zero means the list type constructor, + -- so you have to quote those.) + | '[' ktype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma + (gl $3) >> + ams (sLL $1 $> $ HsExplicitListTy noExtField NotPromoted ($2 : $4)) + [mos $1,mcs $5] } + | INTEGER { sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1) + (il_value (getINTEGER $1)) } + | STRING { sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1) + (getSTRING $1) } + | '_' { sL1 $1 $ mkAnonWildCardTy } + +-- An inst_type is what occurs in the head of an instance decl +-- e.g. (Foo a, Gaz b) => Wibble a b +-- It's kept as a single type for convenience. +inst_type :: { LHsSigType GhcPs } + : sigtype { mkLHsSigType $1 } + +deriv_types :: { [LHsSigType GhcPs] } + : ktype { [mkLHsSigType $1] } + + | ktype ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) + >> return (mkLHsSigType $1 : $3) } + +comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty + : comma_types1 { $1 } + | {- empty -} { [] } + +comma_types1 :: { [LHsType GhcPs] } -- One or more: ty,ty,ty + : ktype { [$1] } + | ktype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2) + >> return ($1 : $3) } + +bar_types2 :: { [LHsType GhcPs] } -- Two or more: ty|ty|ty + : ktype '|' ktype {% addAnnotation (gl $1) AnnVbar (gl $2) + >> return [$1,$3] } + | ktype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2) + >> return ($1 : $3) } + +tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] } + : tv_bndr tv_bndrs { $1 : $2 } + | {- empty -} { [] } + +tv_bndr :: { LHsTyVarBndr Specificity GhcPs } + : tv_bndr_no_braces { $1 } + | '{' tyvar '}' {% ams (sLL $1 $> (UserTyVar noExtField InferredSpec $2)) + [moc $1, mcc $3] } + | '{' tyvar '::' kind '}' {% ams (sLL $1 $> (KindedTyVar noExtField InferredSpec $2 $4)) + [moc $1,mu AnnDcolon $3 + ,mcc $5] } + +tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs } + : tyvar { sL1 $1 (UserTyVar noExtField SpecifiedSpec $1) } + | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExtField SpecifiedSpec $2 $4)) + [mop $1,mu AnnDcolon $3 + ,mcp $5] } + +fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) } + : {- empty -} { noLoc ([],[]) } + | '|' fds1 { (sLL $1 $> ([mj AnnVbar $1] + ,reverse (unLoc $2))) } + +fds1 :: { Located [Located (FunDep (Located RdrName))] } + : fds1 ',' fd {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } + | fd { sL1 $1 [$1] } + +fd :: { Located (FunDep (Located RdrName)) } + : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) + (reverse (unLoc $1), reverse (unLoc $3))) + [mu AnnRarrow $2] } + +varids0 :: { Located [Located RdrName] } + : {- empty -} { noLoc [] } + | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) } + +----------------------------------------------------------------------------- +-- Kinds + +kind :: { LHsKind GhcPs } + : ctype { $1 } + +{- Note [Promotion] + ~~~~~~~~~~~~~~~~ + +- Syntax of promoted qualified names +We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified +names. Moreover ticks are only allowed in types, not in kinds, for a +few reasons: + 1. we don't need quotes since we cannot define names in kinds + 2. if one day we merge types and kinds, tick would mean look in DataName + 3. we don't have a kind namespace anyway + +- Name resolution +When the user write Zero instead of 'Zero in types, we parse it a +HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We +deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not +bounded in the type level, then we look for it in the term level (we +change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName). +And both become a HsTyVar ("Zero", DataName) after the renamer. + +-} + + +----------------------------------------------------------------------------- +-- Datatype declarations + +gadt_constrlist :: { Located ([AddAnn] + ,[LConDecl GhcPs]) } -- Returned in order + + : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ + L (comb2 $1 $3) + ([mj AnnWhere $1 + ,moc $2 + ,mcc $4] + , unLoc $3) } + | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $ + L (comb2 $1 $3) + ([mj AnnWhere $1] + , unLoc $3) } + | {- empty -} { noLoc ([],[]) } + +gadt_constrs :: { Located [LConDecl GhcPs] } + : gadt_constr ';' gadt_constrs + {% addAnnotation (gl $1) AnnSemi (gl $2) + >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } + | gadt_constr { L (gl $1) [$1] } + | {- empty -} { noLoc [] } + +-- We allow the following forms: +-- C :: Eq a => a -> T a +-- C :: forall a. Eq a => !a -> T a +-- D { x,y :: a } :: T a +-- forall a. Eq a => D { x,y :: a } :: T a + +gadt_constr :: { LConDecl GhcPs } + -- see Note [Difference in parsing GADT and data constructors] + -- Returns a list because of: C,D :: ty + : optSemi con_list '::' sigtype + {% do { (decl, anns) <- mkGadtDecl (unLoc $2) $4 + ; ams (sLL $2 $> decl) + (mu AnnDcolon $3:anns) } } + +{- Note [Difference in parsing GADT and data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GADT constructors have simpler syntax than usual data constructors: +in GADTs, types cannot occur to the left of '::', so they cannot be mixed +with constructor names (see Note [Parsing data constructors is hard]). + +Due to simplified syntax, GADT constructor names (left-hand side of '::') +use simpler grammar production than usual data constructor names. As a +consequence, GADT constructor names are restricted (names like '(*)' are +allowed in usual data constructors, but not in GADTs). +-} + +constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } + : '=' constrs1 { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)} + +constrs1 :: { Located [LConDecl GhcPs] } + : constrs1 '|' constr + {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } + | constr { sL1 $1 [$1] } + +constr :: { LConDecl GhcPs } + : forall context '=>' constr_stuff + {% ams (let (con,details) = unLoc $4 in + (L (comb4 $1 $2 $3 $4) (mkConDeclH98 con + (snd $ unLoc $1) + (Just $2) + details))) + (mu AnnDarrow $3:(fst $ unLoc $1)) } + | forall constr_stuff + {% ams (let (con,details) = unLoc $2 in + (L (comb2 $1 $2) (mkConDeclH98 con + (snd $ unLoc $1) + Nothing -- No context + details))) + (fst $ unLoc $1) } + +forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) } + : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } + | {- empty -} { noLoc ([], Nothing) } + +constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) } + : tyapps {% do { c <- mergeDataCon (unLoc $1) + ; return $ sL1 $1 c } } + +fielddecls :: { [LConDeclField GhcPs] } + : {- empty -} { [] } + | fielddecls1 { $1 } + +fielddecls1 :: { [LConDeclField GhcPs] } + : fielddecl ',' fielddecls1 + {% addAnnotation (gl $1) AnnComma (gl $2) >> + return ($1 : $3) } + | fielddecl { [$1] } + +fielddecl :: { LConDeclField GhcPs } + -- A list because of f,g :: Int + : sig_vars '::' ctype + {% ams (L (comb2 $1 $3) + (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing)) + [mu AnnDcolon $2] } + +-- Reversed! +maybe_derivings :: { HsDeriving GhcPs } + : {- empty -} { noLoc [] } + | derivings { $1 } + +-- A list of one or more deriving clauses at the end of a datatype +derivings :: { HsDeriving GhcPs } + : derivings deriving { sLL $1 $> $ $2 : unLoc $1 } + | deriving { sLL $1 $> [$1] } + +-- The outer Located is just to allow the caller to +-- know the rightmost extremity of the 'deriving' clause +deriving :: { LHsDerivingClause GhcPs } + : 'deriving' deriv_clause_types + {% let { full_loc = comb2 $1 $> } + in ams (L full_loc $ HsDerivingClause noExtField Nothing $2) + [mj AnnDeriving $1] } + + | 'deriving' deriv_strategy_no_via deriv_clause_types + {% let { full_loc = comb2 $1 $> } + in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3) + [mj AnnDeriving $1] } + + | 'deriving' deriv_clause_types deriv_strategy_via + {% let { full_loc = comb2 $1 $> } + in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2) + [mj AnnDeriving $1] } + +deriv_clause_types :: { Located [LHsSigType GhcPs] } + : qtycon { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in + sL1 $1 [mkLHsSigType tc] } + | '(' ')' {% ams (sLL $1 $> []) + [mop $1,mcp $2] } + | '(' deriv_types ')' {% ams (sLL $1 $> $2) + [mop $1,mcp $3] } + -- Glasgow extension: allow partial + -- applications in derivings + +----------------------------------------------------------------------------- +-- Value definitions + +{- Note [Declaration/signature overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's an awkward overlap with a type signature. Consider + f :: Int -> Int = ...rhs... + Then we can't tell whether it's a type signature or a value + definition with a result signature until we see the '='. + So we have to inline enough to postpone reductions until we know. +-} + +{- + ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var + instead of qvar, we get another shift/reduce-conflict. Consider the + following programs: + + { (^^) :: Int->Int ; } Type signature; only var allowed + + { (^^) :: Int->Int = ... ; } Value defn with result signature; + qvar allowed (because of instance decls) + + We can't tell whether to reduce var to qvar until after we've read the signatures. +-} + +decl_no_th :: { LHsDecl GhcPs } + : sigdecl { $1 } + + | infixexp opt_sig rhs {% runECP_P $1 >>= \ $1 -> + do { (ann,r) <- checkValDef $1 (snd $2) $3; + let { l = comb2 $1 $> }; + -- Depending upon what the pattern looks like we might get either + -- a FunBind or PatBind back from checkValDef. See Note + -- [FunBind vs PatBind] + case r of { + (FunBind _ n _ _) -> + amsL l (mj AnnFunId n:(fst $2)) >> return () ; + (PatBind _ (L lh _lhs) _rhs _) -> + amsL lh (fst $2) >> return () } ; + _ <- amsL l (ann ++ (fst $ unLoc $3)); + return $! (sL l $ ValD noExtField r) } } + | pattern_synonym_decl { $1 } + +decl :: { LHsDecl GhcPs } + : decl_no_th { $1 } + + -- Why do we only allow naked declaration splices in top-level + -- declarations and not here? Short answer: because readFail009 + -- fails terribly with a panic in cvBindsAndSigs otherwise. + | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } + +rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } + : '=' exp wherebinds {% runECP_P $2 >>= \ $2 -> return $ + sL (comb3 $1 $2 $3) + ((mj AnnEqual $1 : (fst $ unLoc $3)) + ,GRHSs noExtField (unguardedRHS (comb3 $1 $2 $3) $2) + (snd $ unLoc $3)) } + | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 + ,GRHSs noExtField (reverse (unLoc $1)) + (snd $ unLoc $2)) } + +gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } + : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } + | gdrh { sL1 $1 [$1] } + +gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } + : '|' guardquals '=' exp {% runECP_P $4 >>= \ $4 -> + ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4) + [mj AnnVbar $1,mj AnnEqual $3] } + +sigdecl :: { LHsDecl GhcPs } + : + -- See Note [Declaration/signature overlap] for why we need infixexp here + infixexp '::' sigtype + {% do { $1 <- runECP_P $1 + ; v <- checkValSigLhs $1 + ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] + ; return (sLL $1 $> $ SigD noExtField $ + TypeSig noExtField [v] (mkLHsSigWcType $3))} } + + | var ',' sig_vars '::' sigtype + {% do { let sig = TypeSig noExtField ($1 : reverse (unLoc $3)) + (mkLHsSigWcType $5) + ; addAnnotation (gl $1) AnnComma (gl $2) + ; ams ( sLL $1 $> $ SigD noExtField sig ) + [mu AnnDcolon $4] } } + + | infix prec ops + {% checkPrecP $2 $3 >> + ams (sLL $1 $> $ SigD noExtField + (FixSig noExtField (FixitySig noExtField (fromOL $ unLoc $3) + (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) + [mj AnnInfix $1,mj AnnVal $2] } + + | pattern_synonym_sig { sLL $1 $> . SigD noExtField . unLoc $ $1 } + + | '{-# COMPLETE' con_list opt_tyconsig '#-}' + {% let (dcolon, tc) = $3 + in ams + (sLL $1 $> + (SigD noExtField (CompleteMatchSig noExtField (getCOMPLETE_PRAGs $1) $2 tc))) + ([ mo $1 ] ++ dcolon ++ [mc $4]) } + + -- This rule is for both INLINE and INLINABLE pragmas + | '{-# INLINE' activation qvar '#-}' + {% ams ((sLL $1 $> $ SigD noExtField (InlineSig noExtField $3 + (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) + (snd $2))))) + ((mo $1:fst $2) ++ [mc $4]) } + + | '{-# SCC' qvar '#-}' + {% ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 Nothing))) + [mo $1, mc $3] } + + | '{-# SCC' qvar STRING '#-}' + {% do { scc <- getSCC $3 + ; let str_lit = StringLiteral (getSTRINGs $3) scc + ; ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) + [mo $1, mc $4] } } + + | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' + {% ams ( + let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) + (NoUserInline, FunLike) (snd $2) + in sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) inl_prag)) + (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } + + | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' + {% ams (sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) + (mkInlinePragma (getSPEC_INLINE_PRAGs $1) + (getSPEC_INLINE $1) (snd $2)))) + (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } + + | '{-# SPECIALISE' 'instance' inst_type '#-}' + {% ams (sLL $1 $> + $ SigD noExtField (SpecInstSig noExtField (getSPEC_PRAGs $1) $3)) + [mo $1,mj AnnInstance $2,mc $4] } + + -- A minimal complete definition + | '{-# MINIMAL' name_boolformula_opt '#-}' + {% ams (sLL $1 $> $ SigD noExtField (MinimalSig noExtField (getMINIMAL_PRAGs $1) $2)) + [mo $1,mc $3] } + +activation :: { ([AddAnn],Maybe Activation) } + : {- empty -} { ([],Nothing) } + | explicit_activation { (fst $1,Just (snd $1)) } + +explicit_activation :: { ([AddAnn],Activation) } -- In brackets + : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] + ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } + | '[' rule_activation_marker INTEGER ']' + { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4] + ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } + +----------------------------------------------------------------------------- +-- Expressions + +quasiquote :: { Located (HsSplice GhcPs) } + : TH_QUASIQUOTE { let { loc = getLoc $1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkUnqual varName quoter } + in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } + | TH_QQUASIQUOTE { let { loc = getLoc $1 + ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkQual varName (qual, quoter) } + in sL (getLoc $1) (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } + +exp :: { ECP } + : infixexp '::' sigtype + { ECP $ + runECP_PV $1 >>= \ $1 -> + rejectPragmaPV $1 >> + amms (mkHsTySigPV (comb2 $1 $>) $1 $3) + [mu AnnDcolon $2] } + | infixexp '-<' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ + ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3 + HsFirstOrderApp True) + [mu Annlarrowtail $2] } + | infixexp '>-' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ + ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1 + HsFirstOrderApp False) + [mu Annrarrowtail $2] } + | infixexp '-<<' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ + ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3 + HsHigherOrderApp True) + [mu AnnLarrowtail $2] } + | infixexp '>>-' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ + ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1 + HsHigherOrderApp False) + [mu AnnRarrowtail $2] } + | infixexp { $1 } + | exp_prag(exp) { $1 } -- See Note [Pragmas and operator fixity] + +infixexp :: { ECP } + : exp10 { $1 } + | infixexp qop exp10p -- See Note [Pragmas and operator fixity] + { ECP $ + superInfixOp $ + $2 >>= \ $2 -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + rejectPragmaPV $1 >> + amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) + [mj AnnVal $2] } + -- AnnVal annotation for NPlusKPat, which discards the operator + +exp10p :: { ECP } + : exp10 { $1 } + | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity] + +exp_prag(e) :: { ECP } + : prag_e e -- See Note [Pragmas and operator fixity] + {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2) + (fst $ unLoc $1) } + +exp10 :: { ECP } + : '-' fexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsNegAppPV (comb2 $1 $>) $2) + [mj AnnMinus $1] } + | fexp { $1 } + +optSemi :: { ([Located Token],Bool) } + : ';' { ([$1],True) } + | {- empty -} { ([],False) } + +{- Note [Pragmas and operator fixity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'prag_e' is an expression pragma, such as {-# SCC ... #-} or +{-# GENERATED ... #-}. + +It must be used with care, or else #15730 happens. Consider this infix +expression: + + 1 / 2 / 2 + +There are two ways to parse it: + + 1. (1 / 2) / 2 = 0.25 + 2. 1 / (2 / 2) = 1.0 + +Due to the fixity of the (/) operator (assuming it comes from Prelude), +option 1 is the correct parse. However, in the past GHC's parser used to get +confused by the SCC annotation when it occurred in the middle of an infix +expression: + + 1 / {-# SCC ann #-} 2 / 2 -- used to get parsed as option 2 + +There are several ways to address this issue, see GHC Proposal #176 for a +detailed exposition: + + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst + +The accepted fix is to disallow pragmas that occur within infix expressions. +Infix expressions are assembled out of 'exp10', so 'exp10' must not accept +pragmas. Instead, we accept them in exactly two places: + +* at the start of an expression or a parenthesized subexpression: + + f = {-# SCC ann #-} 1 / 2 / 2 -- at the start of the expression + g = 5 + ({-# SCC ann #-} 1 / 2 / 2) -- at the start of a parenthesized subexpression + +* immediately after the last operator: + + f = 1 / 2 / {-# SCC ann #-} 2 + +In both cases, the parse does not depend on operator fixity. The second case +may sound unnecessary, but it's actually needed to support a common idiom: + + f $ {-# SCC ann $-} ... + +-} +prag_e :: { Located ([AddAnn], HsPragE GhcPs) } + : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 + ; return $ sLL $1 $> + ([mo $1,mj AnnValStr $2,mc $3], + HsPragSCC noExtField + (getSCC_PRAGs $1) + (StringLiteral (getSTRINGs $2) scc)) } + | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3], + HsPragSCC noExtField + (getSCC_PRAGs $1) + (StringLiteral NoSourceText (getVARID $2))) } + | '{-# GENERATED' STRING INTEGER ':' INTEGER HYPHEN INTEGER ':' INTEGER '#-}' + { let getINT = fromInteger . il_value . getINTEGER in + sLL $1 $> $ ([mo $1,mj AnnVal $2 + ,mj AnnVal $3,mj AnnColon $4 + ,mj AnnVal $5] ++ $6 ++ + [mj AnnVal $7,mj AnnColon $8 + ,mj AnnVal $9,mc $10], + HsPragTick noExtField + (getGENERATED_PRAGs $1) + (getStringLiteral $2, + (getINT $3, getINT $5), + (getINT $7, getINT $9)) + ((getINTEGERs $3, getINTEGERs $5), + (getINTEGERs $7, getINTEGERs $9) )) } +fexp :: { ECP } + : fexp aexp { ECP $ + superFunArg $ + runECP_PV $1 >>= \ $1 -> + runECP_PV $2 >>= \ $2 -> + mkHsAppPV (comb2 $1 $>) $1 $2 } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | fexp PREFIX_AT atype { ECP $ + runECP_PV $1 >>= \ $1 -> + amms (mkHsAppTypePV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } + + | 'static' aexp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsStatic noExtField $2) + [mj AnnStatic $1] } + | aexp { $1 } + +aexp :: { ECP } + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + : qvar TIGHT_INFIX_AT aexp + { ECP $ + runECP_PV $3 >>= \ $3 -> + amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } + + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + | PREFIX_TILDE aexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] } + | PREFIX_BANG aexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] } + | PREFIX_MINUS aexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] } + + | '\\' apat apats '->' exp + { ECP $ + runECP_PV $5 >>= \ $5 -> + amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource + [sLL $1 $> $ Match { m_ext = noExtField + , m_ctxt = LambdaExpr + , m_pats = $2:$3 + , m_grhss = unguardedGRHSs $5 }])) + [mj AnnLam $1, mu AnnRarrow $4] } + | 'let' binds 'in' exp { ECP $ + runECP_PV $4 >>= \ $4 -> + amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4) + (mj AnnLet $1:mj AnnIn $3 + :(fst $ unLoc $2)) } + | '\\' 'lcase' altslist + { ECP $ $3 >>= \ $3 -> + amms (mkHsLamCasePV (comb2 $1 $>) + (mkMatchGroup FromSource (snd $ unLoc $3))) + (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } + | 'if' exp optSemi 'then' exp optSemi 'else' exp + {% runECP_P $2 >>= \ $2 -> + return $ ECP $ + runECP_PV $5 >>= \ $5 -> + runECP_PV $8 >>= \ $8 -> + amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8) + (mj AnnIf $1:mj AnnThen $4 + :mj AnnElse $7 + :(map (\l -> mj AnnSemi l) (fst $3)) + ++(map (\l -> mj AnnSemi l) (fst $6))) } + | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsMultiIf noExtField + (reverse $ snd $ unLoc $2)) + (mj AnnIf $1:(fst $ unLoc $2)) } + | 'case' exp 'of' altslist {% runECP_P $2 >>= \ $2 -> + return $ ECP $ + $4 >>= \ $4 -> + amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup + FromSource (snd $ unLoc $4))) + (mj AnnCase $1:mj AnnOf $3 + :(fst $ unLoc $4)) } + -- QualifiedDo. + | DO stmtlist {% do + hintQualifiedDo $1 + return $ ECP $ + $2 >>= \ $2 -> + amms (mkHsDoPV (comb2 $1 $2) + (fmap mkModuleNameFS (getDO $1)) + (mapLoc snd $2)) + (mj AnnDo $1:(fst $ unLoc $2)) } + | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> + fmap ecpFromExp $ + ams (L (comb2 $1 $2) + (mkHsDo (MDoExpr $ + fmap mkModuleNameFS (getMDO $1)) + (snd $ unLoc $2))) + (mj AnnMdo $1:(fst $ unLoc $2)) } + | 'proc' aexp '->' exp + {% (checkPattern <=< runECP_P) $2 >>= \ p -> + runECP_P $4 >>= \ $4@cmd -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsProc noExtField p (sLL $1 $> $ HsCmdTop noExtField cmd)) + -- TODO: is LL right here? + [mj AnnProc $1,mu AnnRarrow $3] } + + | aexp1 { $1 } + +aexp1 :: { ECP } + : aexp1 '{' fbinds '}' { ECP $ + runECP_PV $1 >>= \ $1 -> + $3 >>= \ $3 -> + amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) + (moc $2:mcc $4:(fst $3)) } + | aexp2 { $1 } + +aexp2 :: { ECP } + : qvar { ECP $ mkHsVarPV $! $1 } + | qcon { ECP $ mkHsVarPV $! $1 } + | ipvar { ecpFromExp $ sL1 $1 (HsIPVar noExtField $! unLoc $1) } + | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExtField Nothing $! unLoc $1) } + | literal { ECP $ mkHsLitPV $! $1 } +-- This will enable overloaded strings permanently. Normally the renamer turns HsString +-- into HsOverLit when -foverloaded-strings is on. +-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) +-- (getSTRING $1) noExtField) } + | INTEGER { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) } + | RATIONAL { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) } + + -- N.B.: sections get parsed by these next two productions. + -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't + -- correct Haskell (you'd have to write '((+ 3), (4 -))') + -- but the less cluttered version fell out of having texps. + | '(' texp ')' { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] } + | '(' tup_exprs ')' { ECP $ + $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2)) + ((mop $1:fst $2) ++ [mcp $3]) } + + | '(#' texp '#)' { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)])) + [mo $1,mc $3] } + | '(#' tup_exprs '#)' { ECP $ + $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (snd $2)) + ((mo $1:fst $2) ++ [mc $3]) } + + | '[' list ']' { ECP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] } + | '_' { ECP $ mkHsWildCardPV (getLoc $1) } + + -- Template Haskell Extension + | splice_untyped { ECP $ mkHsSplicePV $1 } + | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noExtField) $1 } + + | SIMPLEQUOTE qvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) } + | '[|' exp '|]' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsBracket noExtField (ExpBr noExtField $2)) + (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] + else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } + | '[||' exp '||]' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsBracket noExtField (TExpBr noExtField $2)) + (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } + | '[t|' ktype '|]' {% fmap ecpFromExp $ + ams (sLL $1 $> $ HsBracket noExtField (TypBr noExtField $2)) [mo $1,mu AnnCloseQ $3] } + | '[p|' infixexp '|]' {% (checkPattern <=< runECP_P) $2 >>= \p -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsBracket noExtField (PatBr noExtField p)) + [mo $1,mu AnnCloseQ $3] } + | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ + ams (sLL $1 $> $ HsBracket noExtField (DecBrL noExtField (snd $2))) + (mo $1:mu AnnCloseQ $3:fst $2) } + | quasiquote { ECP $ mkHsSplicePV $1 } + + -- arrow notation extension + | '(|' aexp cmdargs '|)' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromCmd $ + ams (sLL $1 $> $ HsCmdArrForm noExtField $2 Prefix + Nothing (reverse $3)) + [mu AnnOpenB $1,mu AnnCloseB $4] } + +splice_exp :: { LHsExpr GhcPs } + : splice_untyped { mapLoc (HsSpliceE noExtField) $1 } + | splice_typed { mapLoc (HsSpliceE noExtField) $1 } + +splice_untyped :: { Located (HsSplice GhcPs) } + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + : PREFIX_DOLLAR aexp2 {% runECP_P $2 >>= \ $2 -> + ams (sLL $1 $> $ mkUntypedSplice DollarSplice $2) + [mj AnnDollar $1] } + +splice_typed :: { Located (HsSplice GhcPs) } + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + : PREFIX_DOLLAR_DOLLAR aexp2 + {% runECP_P $2 >>= \ $2 -> + ams (sLL $1 $> $ mkTypedSplice DollarSplice $2) + [mj AnnDollarDollar $1] } + +cmdargs :: { [LHsCmdTop GhcPs] } + : cmdargs acmd { $2 : $1 } + | {- empty -} { [] } + +acmd :: { LHsCmdTop GhcPs } + : aexp {% runECP_P $1 >>= \ cmd -> + runPV (checkCmdBlockArguments cmd) >>= \ _ -> + return (sL1 cmd $ HsCmdTop noExtField cmd) } + +cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } + : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 + ,mj AnnCloseC $3],$2) } + | vocurly cvtopdecls0 close { ([],$2) } + +cvtopdecls0 :: { [LHsDecl GhcPs] } + : topdecls_semi { cvTopDecls $1 } + | topdecls { cvTopDecls $1 } + +----------------------------------------------------------------------------- +-- Tuple expressions + +-- "texp" is short for tuple expressions: +-- things that can appear unparenthesized as long as they're +-- inside parens or delimitted by commas +texp :: { ECP } + : exp { $1 } + + -- Note [Parsing sections] + -- ~~~~~~~~~~~~~~~~~~~~~~~ + -- We include left and right sections here, which isn't + -- technically right according to the Haskell standard. + -- For example (3 +, True) isn't legal. + -- However, we want to parse bang patterns like + -- (!x, !y) + -- and it's convenient to do so here as a section + -- Then when converting expr to pattern we unravel it again + -- Meanwhile, the renamer checks that real sections appear + -- inside parens. + | infixexp qop + {% runECP_P $1 >>= \ $1 -> + runPV (rejectPragmaPV $1) >> + runPV $2 >>= \ $2 -> + return $ ecpFromExp $ + sLL $1 $> $ SectionL noExtField $1 $2 } + | qopm infixexp { ECP $ + superInfixOp $ + runECP_PV $2 >>= \ $2 -> + $1 >>= \ $1 -> + mkHsSectionR_PV (comb2 $1 $>) $1 $2 } + + -- View patterns get parenthesized above + | exp '->' texp { ECP $ + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] } + +-- Always at least one comma or bar. +-- Though this can parse just commas (without any expressions), it won't +-- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple] +-- in GHC.Hs.Expr. +tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) } + : texp commas_tup_tail + { runECP_PV $1 >>= \ $1 -> + $2 >>= \ $2 -> + do { addAnnotation (gl $1) AnnComma (fst $2) + ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } } + + | texp bars { runECP_PV $1 >>= \ $1 -> return $ + (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } + + | commas tup_tail + { $2 >>= \ $2 -> + do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) + ; return + ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } } + + | bars texp bars0 + { runECP_PV $2 >>= \ $2 -> return $ + (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } + +-- Always starts with commas; always follows an expr +commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))]) } +commas_tup_tail : commas tup_tail + { $2 >>= \ $2 -> + do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) + ; return ( + (head $ fst $1 + ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } } + +-- Always follows a comma +tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } + : texp commas_tup_tail { runECP_PV $1 >>= \ $1 -> + $2 >>= \ $2 -> + addAnnotation (gl $1) AnnComma (fst $2) >> + return ((L (gl $1) (Just $1)) : snd $2) } + | texp { runECP_PV $1 >>= \ $1 -> + return [L (gl $1) (Just $1)] } + | {- empty -} { return [noLoc Nothing] } + +----------------------------------------------------------------------------- +-- List expressions + +-- The rules below are little bit contorted to keep lexps left-recursive while +-- avoiding another shift/reduce-conflict. +-- Never empty. +list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) } + : texp { \loc -> runECP_PV $1 >>= \ $1 -> + mkHsExplicitListPV loc [$1] } + | lexps { \loc -> $1 >>= \ $1 -> + mkHsExplicitListPV loc (reverse $1) } + | texp '..' { \loc -> runECP_PV $1 >>= \ $1 -> + ams (L loc $ ArithSeq noExtField Nothing (From $1)) + [mj AnnDotdot $2] + >>= ecpFromExp' } + | texp ',' exp '..' { \loc -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3)) + [mj AnnComma $2,mj AnnDotdot $4] + >>= ecpFromExp' } + | texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3)) + [mj AnnDotdot $2] + >>= ecpFromExp' } + | texp ',' exp '..' exp { \loc -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + runECP_PV $5 >>= \ $5 -> + ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5)) + [mj AnnComma $2,mj AnnDotdot $4] + >>= ecpFromExp' } + | texp '|' flattenedpquals + { \loc -> + checkMonadComp >>= \ ctxt -> + runECP_PV $1 >>= \ $1 -> + ams (L loc $ mkHsComp ctxt (unLoc $3) $1) + [mj AnnVbar $2] + >>= ecpFromExp' } + +lexps :: { forall b. DisambECP b => PV [Located b] } + : lexps ',' texp { $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + addAnnotation (gl $ head $ $1) + AnnComma (gl $2) >> + return (((:) $! $3) $! $1) } + | texp ',' texp { runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + addAnnotation (gl $1) AnnComma (gl $2) >> + return [$3,$1] } + +----------------------------------------------------------------------------- +-- List Comprehensions + +flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } + : pquals { case (unLoc $1) of + [qs] -> sL1 $1 qs + -- We just had one thing in our "parallel" list so + -- we simply return that thing directly + + qss -> sL1 $1 [sL1 $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | + qs <- qss] + noExpr noSyntaxExpr] + -- We actually found some actual parallel lists so + -- we wrap them into as a ParStmt + } + +pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] } + : squals '|' pquals + {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> + return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } + | squals { L (getLoc $1) [reverse (unLoc $1)] } + +squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last + -- one can "grab" the earlier ones + : squals ',' transformqual + {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> + amsL (comb2 $1 $>) (fst $ unLoc $3) >> + return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) } + | squals ',' qual + {% runPV $3 >>= \ $3 -> + addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> ($3 : unLoc $1)) } + | transformqual {% ams $1 (fst $ unLoc $1) >> + return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } + | qual {% runPV $1 >>= \ $1 -> + return $ sL1 $1 [$1] } +-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } +-- | '{|' pquals '|}' { sL1 $1 [$2] } + +-- It is possible to enable bracketing (associating) qualifier lists +-- by uncommenting the lines with {| |} above. Due to a lack of +-- consensus on the syntax, this feature is not being used until we +-- get user demand. + +transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } + -- Function is applied to a list of stmts *in order* + : 'then' exp {% runECP_P $2 >>= \ $2 -> return $ + sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } + | 'then' exp 'by' exp {% runECP_P $2 >>= \ $2 -> + runECP_P $4 >>= \ $4 -> + return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy $3], + \ss -> (mkTransformByStmt ss $2 $4)) } + | 'then' 'group' 'using' exp + {% runECP_P $4 >>= \ $4 -> + return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], + \ss -> (mkGroupUsingStmt ss $4)) } + + | 'then' 'group' 'by' exp 'using' exp + {% runECP_P $4 >>= \ $4 -> + runECP_P $6 >>= \ $6 -> + return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], + \ss -> (mkGroupByUsingStmt ss $4 $6)) } + +-- Note that 'group' is a special_id, which means that you can enable +-- TransformListComp while still using Data.List.group. However, this +-- introduces a shift/reduce conflict. Happy chooses to resolve the conflict +-- in by choosing the "group by" variant, which is what we want. + +----------------------------------------------------------------------------- +-- Guards + +guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } + : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } + +guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } + : guardquals1 ',' qual {% runPV $3 >>= \ $3 -> + addAnnotation (gl $ head $ unLoc $1) AnnComma + (gl $2) >> + return (sLL $1 $> ($3 : unLoc $1)) } + | qual {% runPV $1 >>= \ $1 -> + return $ sL1 $1 [$1] } + +----------------------------------------------------------------------------- +-- Case alternatives + +altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } + : '{' alts '}' { $2 >>= \ $2 -> return $ + sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) + ,(reverse (snd $ unLoc $2))) } + | vocurly alts close { $2 >>= \ $2 -> return $ + L (getLoc $2) (fst $ unLoc $2 + ,(reverse (snd $ unLoc $2))) } + | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) } + | vocurly close { return $ noLoc ([],[]) } + +alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } + : alts1 { $1 >>= \ $1 -> return $ + sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> return $ + sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) + ,snd $ unLoc $2) } + +alts1 :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } + : alts1 ';' alt { $1 >>= \ $1 -> + $3 >>= \ $3 -> + if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,[$3])) + else (ams (head $ snd $ unLoc $1) + (mj AnnSemi $2:(fst $ unLoc $1)) + >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) } + | alts1 ';' { $1 >>= \ $1 -> + if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else (ams (head $ snd $ unLoc $1) + (mj AnnSemi $2:(fst $ unLoc $1)) + >> return (sLL $1 $> ([],snd $ unLoc $1))) } + | alt { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) } + +alt :: { forall b. DisambECP b => PV (LMatch GhcPs (Located b)) } + : pat alt_rhs { $2 >>= \ $2 -> + ams (sLL $1 $> (Match { m_ext = noExtField + , m_ctxt = CaseAlt + , m_pats = [$1] + , m_grhss = snd $ unLoc $2 })) + (fst $ unLoc $2)} + +alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b))) } + : ralt wherebinds { $1 >>= \alt -> + return $ sLL alt $> (fst $ unLoc $2, GRHSs noExtField (unLoc alt) (snd $ unLoc $2)) } + +ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } + : '->' exp { runECP_PV $2 >>= \ $2 -> + ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) + [mu AnnRarrow $1] } + | gdpats { $1 >>= \gdpats -> + return $ sL1 gdpats (reverse (unLoc gdpats)) } + +gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } + : gdpats gdpat { $1 >>= \gdpats -> + $2 >>= \gdpat -> + return $ sLL gdpats gdpat (gdpat : unLoc gdpats) } + | gdpat { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] } + +-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to +-- generate the open brace in addition to the vertical bar in the lexer, and +-- we don't need it. +ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } + : '{' gdpats '}' {% runPV $2 >>= \ $2 -> + return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) } + | gdpats close {% runPV $1 >>= \ $1 -> + return $ sL1 $1 ([],unLoc $1) } + +gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) } + : '|' guardquals '->' exp + { runECP_PV $4 >>= \ $4 -> + ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4) + [mj AnnVbar $1,mu AnnRarrow $3] } + +-- 'pat' recognises a pattern, including one with a bang at the top +-- e.g. "!x" or "!(x,y)" or "C a b" etc +-- Bangs inside are parsed as infix operator applications, so that +-- we parse them right when bang-patterns are off +pat :: { LPat GhcPs } +pat : exp {% (checkPattern <=< runECP_P) $1 } + +bindpat :: { LPat GhcPs } +bindpat : exp {% -- See Note [Parser-Validator ReaderT SDoc] in GHC.Parser.PostProcess + checkPattern_msg (text "Possibly caused by a missing 'do'?") + (runECP_PV $1) } + +apat :: { LPat GhcPs } +apat : aexp {% (checkPattern <=< runECP_P) $1 } + +apats :: { [LPat GhcPs] } + : apat apats { $1 : $2 } + | {- empty -} { [] } + +----------------------------------------------------------------------------- +-- Statement sequences + +stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } + : '{' stmts '}' { $2 >>= \ $2 -> return $ + sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) + ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? + | vocurly stmts close { $2 >>= \ $2 -> return $ + L (gl $2) (fst $ unLoc $2 + ,reverse $ snd $ unLoc $2) } + +-- do { ;; s ; s ; ; s ;; } +-- The last Stmt should be an expression, but that's hard to enforce +-- here, because we need too much lookahead if we see do { e ; } +-- So we use BodyStmts throughout, and switch the last one over +-- in ParseUtils.checkDo instead + +stmts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } + : stmts ';' stmt { $1 >>= \ $1 -> + $3 >>= \ $3 -> + if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,$3 : (snd $ unLoc $1))) + else do + { ams (head $ snd $ unLoc $1) [mj AnnSemi $2] + ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }} + + | stmts ';' { $1 >>= \ $1 -> + if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1)) + else do + { ams (head $ snd $ unLoc $1) + [mj AnnSemi $2] + ; return $1 } + } + | stmt { $1 >>= \ $1 -> + return $ sL1 $1 ([],[$1]) } + | {- empty -} { return $ noLoc ([],[]) } + + +-- For typing stmts at the GHCi prompt, where +-- the input may consist of just comments. +maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) } + : stmt {% fmap Just (runPV $1) } + | {- nothing -} { Nothing } + +-- For GHC API. +e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } + : stmt {% runPV $1 } + +stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } + : qual { $1 } + | 'rec' stmtlist { $2 >>= \ $2 -> + ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) + (mj AnnRec $1:(fst $ unLoc $2)) } + +qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } + : bindpat '<-' exp { runECP_PV $3 >>= \ $3 -> + ams (sLL $1 $> $ mkPsBindStmt $1 $3) + [mu AnnLarrow $2] } + | exp { runECP_PV $1 >>= \ $1 -> + return $ sL1 $1 $ mkBodyStmt $1 } + | 'let' binds { ams (sLL $1 $> $ LetStmt noExtField (snd $ unLoc $2)) + (mj AnnLet $1:(fst $ unLoc $2)) } + +----------------------------------------------------------------------------- +-- Record Field Update/Construction + +fbinds :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } + : fbinds1 { $1 } + | {- empty -} { return ([],([], Nothing)) } + +fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } + : fbind ',' fbinds1 + { $1 >>= \ $1 -> + $3 >>= \ $3 -> + addAnnotation (gl $1) AnnComma (gl $2) >> + return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } + | fbind { $1 >>= \ $1 -> + return ([],([$1], Nothing)) } + | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) } + +fbind :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) } + : qvar '=' texp { runECP_PV $3 >>= \ $3 -> + ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) + [mj AnnEqual $2] } + -- RHS is a 'texp', allowing view patterns (#6038) + -- and, incidentally, sections. Eg + -- f (R { x = show -> s }) = ... + + | qvar { placeHolderPunRhs >>= \rhs -> + return $ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True } + -- In the punning case, use a place-holder + -- The renamer fills in the final value + +----------------------------------------------------------------------------- +-- Implicit Parameter Bindings + +dbinds :: { Located [LIPBind GhcPs] } + : dbinds ';' dbind + {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> + return (let { this = $3; rest = unLoc $1 } + in rest `seq` this `seq` sLL $1 $> (this : rest)) } + | dbinds ';' {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> + return (sLL $1 $> (unLoc $1)) } + | dbind { let this = $1 in this `seq` sL1 $1 [this] } +-- | {- empty -} { [] } + +dbind :: { LIPBind GhcPs } +dbind : ipvar '=' exp {% runECP_P $3 >>= \ $3 -> + ams (sLL $1 $> (IPBind noExtField (Left $1) $3)) + [mj AnnEqual $2] } + +ipvar :: { Located HsIPName } + : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } + +----------------------------------------------------------------------------- +-- Overloaded labels + +overloaded_label :: { Located FastString } + : LABELVARID { sL1 $1 (getLABELVARID $1) } + +----------------------------------------------------------------------------- +-- Warnings and deprecations + +name_boolformula_opt :: { LBooleanFormula (Located RdrName) } + : name_boolformula { $1 } + | {- empty -} { noLoc mkTrue } + +name_boolformula :: { LBooleanFormula (Located RdrName) } + : name_boolformula_and { $1 } + | name_boolformula_and '|' name_boolformula + {% aa $1 (AnnVbar, $2) + >> return (sLL $1 $> (Or [$1,$3])) } + +name_boolformula_and :: { LBooleanFormula (Located RdrName) } + : name_boolformula_and_list + { sLL (head $1) (last $1) (And ($1)) } + +name_boolformula_and_list :: { [LBooleanFormula (Located RdrName)] } + : name_boolformula_atom { [$1] } + | name_boolformula_atom ',' name_boolformula_and_list + {% aa $1 (AnnComma, $2) >> return ($1 : $3) } + +name_boolformula_atom :: { LBooleanFormula (Located RdrName) } + : '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] } + | name_var { sL1 $1 (Var $1) } + +namelist :: { Located [Located RdrName] } +namelist : name_var { sL1 $1 [$1] } + | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (sLL $1 $> ($1 : unLoc $3)) } + +name_var :: { Located RdrName } +name_var : var { $1 } + | con { $1 } + +----------------------------------------- +-- Data constructors +-- There are two different productions here as lifted list constructors +-- are parsed differently. + +qcon_nowiredlist :: { Located RdrName } + : gen_qcon { $1 } + | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + +qcon :: { Located RdrName } + : gen_qcon { $1} + | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + +gen_qcon :: { Located RdrName } + : qconid { $1 } + | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + +con :: { Located RdrName } + : conid { $1 } + | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + +con_list :: { Located [Located RdrName] } +con_list : con { sL1 $1 [$1] } + | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (sLL $1 $> ($1 : unLoc $3)) } + +-- See Note [ExplicitTuple] in GHC.Hs.Expr +sysdcon_nolist :: { Located DataCon } -- Wired in data constructors + : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] } + | '(' commas ')' {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) + (mop $1:mcp $3:(mcommas (fst $2))) } + | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } + | '(#' commas '#)' {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) + (mo $1:mc $3:(mcommas (fst $2))) } + +-- See Note [Empty lists] in GHC.Hs.Expr +sysdcon :: { Located DataCon } + : sysdcon_nolist { $1 } + | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] } + +conop :: { Located RdrName } + : consym { $1 } + | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qconop :: { Located RdrName } + : qconsym { $1 } + | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +---------------------------------------------------------------------------- +-- Type constructors + + +-- See Note [Unit tuples] in GHC.Hs.Type for the distinction +-- between gtycon and ntgtycon +gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples + : ntgtycon { $1 } + | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) + [mop $1,mcp $2] } + | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) + [mo $1,mc $2] } + +ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples + : oqtycon { $1 } + | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed + (snd $2 + 1))) + (mop $1:mcp $3:(mcommas (fst $2))) } + | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed + (snd $2 + 1))) + (mo $1:mc $3:(mcommas (fst $2))) } + | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + [mop $1,mu AnnRarrow $2,mcp $3] } + | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } + +oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; + -- These can appear in export lists + : qtycon { $1 } + | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + +oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mistaken + -- for variable constructor in export lists + -- see Note [Type constructors in export list] + : qtycon { $1 } + | '(' QCONSYM ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) } + in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + | '(' CONSYM ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) } + in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + | '(' ':' ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! consDataCon_RDR } + in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + +{- Note [Type constructors in export list] +~~~~~~~~~~~~~~~~~~~~~ +Mixing type constructors and data constructors in export lists introduces +ambiguity in grammar: e.g. (*) may be both a type constructor and a function. + +-XExplicitNamespaces allows to disambiguate by explicitly prefixing type +constructors with 'type' keyword. + +This ambiguity causes reduce/reduce conflicts in parser, which are always +resolved in favour of data constructors. To get rid of conflicts we demand +that ambiguous type constructors (those, which are formed by the same +productions as variable constructors) are always prefixed with 'type' keyword. +Unambiguous type constructors may occur both with or without 'type' keyword. + +Note that in the parser we still parse data constructors as type +constructors. As such, they still end up in the type constructor namespace +until after renaming when we resolve the proper namespace for each exported +child. +-} + +qtyconop :: { Located RdrName } -- Qualified or unqualified + : qtyconsym { $1 } + | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qtycon :: { Located RdrName } -- Qualified or unqualified + : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } + | tycon { $1 } + +tycon :: { Located RdrName } -- Unqualified + : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } + +qtyconsym :: { Located RdrName } + : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) } + | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) } + | tyconsym { $1 } + +tyconsym :: { Located RdrName } + : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } + | VARSYM { sL1 $1 $! + -- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types + if getVARSYM $1 == fsLit "~" + then eqTyCon_RDR + else mkUnqual tcClsName (getVARSYM $1) } + | ':' { sL1 $1 $! consDataCon_RDR } + | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } + | '.' { sL1 $1 $! mkUnqual tcClsName (fsLit ".") } + + +----------------------------------------------------------------------------- +-- Operators + +op :: { Located RdrName } -- used in infix decls + : varop { $1 } + | conop { $1 } + | '->' { sL1 $1 $ getRdrName unrestrictedFunTyCon } + +varop :: { Located RdrName } + : varsym { $1 } + | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qop :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections + : qvarop { mkHsVarOpPV $1 } + | qconop { mkHsConOpPV $1 } + | hole_op { $1 } + +qopm :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections + : qvaropm { mkHsVarOpPV $1 } + | qconop { mkHsConOpPV $1 } + | hole_op { $1 } + +hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections +hole_op : '`' '_' '`' { amms (mkHsInfixHolePV (comb2 $1 $>)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qvarop :: { Located RdrName } + : qvarsym { $1 } + | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qvaropm :: { Located RdrName } + : qvarsym_no_minus { $1 } + | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +----------------------------------------------------------------------------- +-- Type variables + +tyvar :: { Located RdrName } +tyvar : tyvarid { $1 } + +tyvarop :: { Located RdrName } +tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +tyvarid :: { Located RdrName } + : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) } + | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) } + | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") } + | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") } + | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") } + -- If this changes relative to varid, update 'checkRuleTyVarBndrNames' + -- in GHC.Parser.PostProcess + -- See Note [Parsing explicit foralls in Rules] + +----------------------------------------------------------------------------- +-- Variables + +var :: { Located RdrName } + : varid { $1 } + | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + +qvar :: { Located RdrName } + : qvarid { $1 } + | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } +-- We've inlined qvarsym here so that the decision about +-- whether it's a qvar or a var can be postponed until +-- *after* we see the close paren. + +qvarid :: { Located RdrName } + : varid { $1 } + | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } + +-- Note that 'role' and 'family' get lexed separately regardless of +-- the use of extensions. However, because they are listed here, +-- this is OK and they can be used as normal varids. +-- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer +varid :: { Located RdrName } + : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) } + | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) } + | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") } + | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") } + | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible")} + | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") } + | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") } + | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") } + -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames' + -- in GHC.Parser.PostProcess + -- See Note [Parsing explicit foralls in Rules] + +qvarsym :: { Located RdrName } + : varsym { $1 } + | qvarsym1 { $1 } + +qvarsym_no_minus :: { Located RdrName } + : varsym_no_minus { $1 } + | qvarsym1 { $1 } + +qvarsym1 :: { Located RdrName } +qvarsym1 : QVARSYM { sL1 $1 $ mkQual varName (getQVARSYM $1) } + +varsym :: { Located RdrName } + : varsym_no_minus { $1 } + | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") } + +varsym_no_minus :: { Located RdrName } -- varsym not including '-' + : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) } + | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) } + + +-- These special_ids are treated as keywords in various places, +-- but as ordinary ids elsewhere. 'special_id' collects all these +-- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and +-- 'anyclass', whose treatment differs depending on context +special_id :: { Located FastString } +special_id + : 'as' { sL1 $1 (fsLit "as") } + | 'qualified' { sL1 $1 (fsLit "qualified") } + | 'hiding' { sL1 $1 (fsLit "hiding") } + | 'export' { sL1 $1 (fsLit "export") } + | 'label' { sL1 $1 (fsLit "label") } + | 'dynamic' { sL1 $1 (fsLit "dynamic") } + | 'stdcall' { sL1 $1 (fsLit "stdcall") } + | 'ccall' { sL1 $1 (fsLit "ccall") } + | 'capi' { sL1 $1 (fsLit "capi") } + | 'prim' { sL1 $1 (fsLit "prim") } + | 'javascript' { sL1 $1 (fsLit "javascript") } + | 'group' { sL1 $1 (fsLit "group") } + | 'stock' { sL1 $1 (fsLit "stock") } + | 'anyclass' { sL1 $1 (fsLit "anyclass") } + | 'via' { sL1 $1 (fsLit "via") } + | 'unit' { sL1 $1 (fsLit "unit") } + | 'dependency' { sL1 $1 (fsLit "dependency") } + | 'signature' { sL1 $1 (fsLit "signature") } + +special_sym :: { Located FastString } +special_sym : '.' { sL1 $1 (fsLit ".") } + | '*' { sL1 $1 (fsLit (starSym (isUnicode $1))) } + +----------------------------------------------------------------------------- +-- Data constructors + +qconid :: { Located RdrName } -- Qualified or unqualified + : conid { $1 } + | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) } + +conid :: { Located RdrName } + : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) } + +qconsym :: { Located RdrName } -- Qualified or unqualified + : consym { $1 } + | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) } + +consym :: { Located RdrName } + : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) } + + -- ':' means only list cons + | ':' { sL1 $1 $ consDataCon_RDR } + + +----------------------------------------------------------------------------- +-- Literals + +literal :: { Located (HsLit GhcPs) } + : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 } + | STRING { sL1 $1 $ HsString (getSTRINGs $1) + $ getSTRING $1 } + | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1) + $ getPRIMINTEGER $1 } + | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1) + $ getPRIMWORD $1 } + | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1) + $ getPRIMCHAR $1 } + | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1) + $ getPRIMSTRING $1 } + | PRIMFLOAT { sL1 $1 $ HsFloatPrim noExtField $ getPRIMFLOAT $1 } + | PRIMDOUBLE { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 } + +----------------------------------------------------------------------------- +-- Layout + +close :: { () } + : vccurly { () } -- context popped in lexer. + | error {% popContext } + +----------------------------------------------------------------------------- +-- Miscellaneous (mostly renamings) + +modid :: { Located ModuleName } + : CONID { sL1 $1 $ mkModuleNameFS (getCONID $1) } + | QCONID { sL1 $1 $ let (mod,c) = getQCONID $1 in + mkModuleNameFS + (mkFastString + (unpackFS mod ++ '.':unpackFS c)) + } + +commas :: { ([SrcSpan],Int) } -- One or more commas + : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) } + | ',' { ([gl $1],1) } + +bars0 :: { ([SrcSpan],Int) } -- Zero or more bars + : bars { $1 } + | { ([], 0) } + +bars :: { ([SrcSpan],Int) } -- One or more bars + : bars '|' { ((fst $1)++[gl $2],snd $1 + 1) } + | '|' { ([gl $1],1) } + +{ +happyError :: P a +happyError = srcParseFail + +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getDO (L _ (ITdo x)) = x +getMDO (L _ (ITmdo x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getLABELVARID (L _ (ITlabelvarid x)) = x +getCHAR (L _ (ITchar _ x)) = x +getSTRING (L _ (ITstring _ x)) = x +getINTEGER (L _ (ITinteger x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar _ x)) = x +getPRIMSTRING (L _ (ITprimstring _ x)) = x +getPRIMINTEGER (L _ (ITprimint _ x)) = x +getPRIMWORD (L _ (ITprimword _ x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) +getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x +getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l + +getINTEGERs (L _ (ITinteger (IL src _ _))) = src +getCHARs (L _ (ITchar src _)) = src +getSTRINGs (L _ (ITstring src _)) = src +getPRIMCHARs (L _ (ITprimchar src _)) = src +getPRIMSTRINGs (L _ (ITprimstring src _)) = src +getPRIMINTEGERs (L _ (ITprimint src _)) = src +getPRIMWORDs (L _ (ITprimword src _)) = src + +-- See Note [Pragma source text] in "GHC.Types.Basic" for the following +getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (L _ (ITsource_prag src)) = src +getRULES_PRAGs (L _ (ITrules_prag src)) = src +getWARNING_PRAGs (L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src +getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src +getANN_PRAGs (L _ (ITann_prag src)) = src +getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src +getCTYPEs (L _ (ITctype src)) = src + +getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) + +isUnicode :: Located Token -> Bool +isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax +isUnicode (L _ ITlolly) = True +isUnicode _ = False + +hasE :: Located Token -> Bool +hasE (L _ (ITopenExpQuote HasE _)) = True +hasE (L _ (ITopenTExpQuote HasE)) = True +hasE _ = False + +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + err = "Spaces are not allowed in SCCs" + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then addFatalError (getLoc lt) (text err) + else return s + +-- Utilities for combining source spans +comb2 :: Located a -> Located b -> SrcSpan +comb2 a b = a `seq` b `seq` combineLocs a b + +comb3 :: Located a -> Located b -> Located c -> SrcSpan +comb3 a b c = a `seq` b `seq` c `seq` + combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) + +comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan +comb4 a b c d = a `seq` b `seq` c `seq` d `seq` + (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) (getLoc d)) + +comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan +comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq` + (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e)) + +-- strict constructor version: +{-# INLINE sL #-} +sL :: SrcSpan -> a -> Located a +sL span a = span `seq` a `seq` L span a + +-- See Note [Adding location info] for how these utility functions are used + +-- replaced last 3 CPP macros in this file +{-# INLINE sL0 #-} +sL0 :: a -> Located a +sL0 = L noSrcSpan -- #define L0 L noSrcSpan + +{-# INLINE sL1 #-} +sL1 :: Located a -> b -> Located b +sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sLL #-} +sLL :: Located a -> Located b -> c -> Located c +sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) + +{- Note [Adding location info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This is done using the three functions below, sL0, sL1 +and sLL. Note that these functions were mechanically +converted from the three macros that used to exist before, +namely L0, L1 and LL. + +They each add a SrcSpan to their argument. + + sL0 adds 'noSrcSpan', used for empty productions + -- This doesn't seem to work anymore -=chak + + sL1 for a production with a single token on the lhs. Grabs the SrcSpan + from that token. + + sLL for a production with >1 token on the lhs. Makes up a SrcSpan from + the first and last tokens. + +These suffice for the majority of cases. However, we must be +especially careful with empty productions: sLL won't work if the first +or last token on the lhs can represent an empty span. In these cases, +we have to calculate the span using more of the tokens from the lhs, eg. + + | 'newtype' tycl_hdr '=' newconstr deriving + { L (comb3 $1 $4 $5) + (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } + +We provide comb3 and comb4 functions which are useful in such cases. + +Be careful: there's no checking that you actually got this right, the +only symptom will be that the SrcSpans of your syntax will be +incorrect. + +-} + +-- Make a source location for the file. We're a bit lazy here and just +-- make a point SrcSpan at line 1, column 0. Strictly speaking we should +-- try to find the span of the whole file (ToDo). +fileSrcSpan :: P SrcSpan +fileSrcSpan = do + l <- getRealSrcLoc; + let loc = mkSrcLoc (srcLocFile l) 1 1; + return (mkSrcSpan loc loc) + +-- Hint about linear types +hintLinear :: SrcSpan -> P () +hintLinear span = do + linearEnabled <- getBit LinearTypesBit + unless linearEnabled $ addError span $ + text "Enable LinearTypes to allow linear functions" + +-- Hint about the MultiWayIf extension +hintMultiWayIf :: SrcSpan -> P () +hintMultiWayIf span = do + mwiEnabled <- getBit MultiWayIfBit + unless mwiEnabled $ addError span $ + text "Multi-way if-expressions need MultiWayIf turned on" + +-- Hint about explicit-forall +hintExplicitForall :: Located Token -> P () +hintExplicitForall tok = do + forall <- getBit ExplicitForallBit + rulePrag <- getBit InRulePragBit + unless (forall || rulePrag) $ addError (getLoc tok) $ vcat + [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type" + , text "Perhaps you intended to use RankNTypes or a similar language" + , text "extension to enable explicit-forall syntax:" <+> + forallSymDoc <+> text ". " + ] + where + forallSymDoc = text (forallSym (isUnicode tok)) + +-- Hint about qualified-do +hintQualifiedDo :: Located Token -> P () +hintQualifiedDo tok = do + qualifiedDo <- getBit QualifiedDoBit + case maybeQDoDoc of + Just qdoDoc | not qualifiedDo -> + addError (getLoc tok) $ vcat + [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block" + , text "Perhaps you intended to use QualifiedDo" + ] + _ -> return () + where + maybeQDoDoc = case unLoc tok of + ITdo (Just m) -> Just $ ftext m <> text ".do" + ITmdo (Just m) -> Just $ ftext m <> text ".mdo" + t -> Nothing + +-- When two single quotes don't followed by tyvar or gtycon, we report the +-- error as empty character literal, or TH quote that missing proper type +-- variable or constructor. See #13450. +reportEmptyDoubleQuotes :: SrcSpan -> P a +reportEmptyDoubleQuotes span = do + thQuotes <- getBit ThQuotesBit + if thQuotes + then addFatalError span $ vcat + [ text "Parser error on `''`" + , text "Character literals may not be empty" + , text "Or perhaps you intended to use quotation syntax of TemplateHaskell," + , text "but the type variable or constructor is missing" + ] + else addFatalError span $ vcat + [ text "Parser error on `''`" + , text "Character literals may not be empty" + ] + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ + +For the general principles of the following routines, see Note [Api annotations] +in GHC.Parser.Annotation + +-} + +-- |Construct an AddAnn from the annotation keyword and the location +-- of the keyword itself +mj :: AnnKeywordId -> Located e -> AddAnn +mj a l = AddAnn a (gl l) + + +-- |Construct an AddAnn from the annotation keyword and the Located Token. If +-- the token has a unicode equivalent and this has been used, provide the +-- unicode variant of the annotation. +mu :: AnnKeywordId -> Located Token -> AddAnn +mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l + +-- | If the 'Token' is using its unicode variant return the unicode variant of +-- the annotation +toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId +toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a + +toUnicode :: Located Token -> IsUnicodeSyntax +toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax + +gl :: Located a -> SrcSpan +gl = getLoc + +-- |Add an annotation to the located element, and return the located +-- element as a pass through +aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a) +aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a + +-- |Add an annotation to a located element resulting from a monadic action +am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) +am a (b,s) = do + av@(L l _) <- a + addAnnotation l b (gl s) + return av + +-- | Add a list of AddAnns to the given AST element. For example, +-- the parsing rule for @let@ looks like: +-- +-- @ +-- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) +-- (mj AnnLet $1:mj AnnIn $3 +-- :(fst $ unLoc $2)) } +-- @ +-- +-- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well +-- as any annotations that may arise in the binds. This will include open +-- and closing braces if they are used to delimit the let expressions. +-- +ams :: MonadP m => Located a -> [AddAnn] -> m (Located a) +ams a@(L l _) bs = addAnnsAt l bs >> return a + +amsL :: SrcSpan -> [AddAnn] -> P () +amsL sp bs = addAnnsAt sp bs >> return () + +-- |Add all [AddAnn] to an AST element, and wrap it in a 'Just' +ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a)) +ajs a bs = Just <$> ams a bs + +-- |Add a list of AddAnns to the given AST element, where the AST element is the +-- result of a monadic action +amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a) +amms a bs = do { av@(L l _) <- a + ; addAnnsAt l bs + ; return av } + +-- |Add a list of AddAnns to the AST element, and return the element as a +-- OrdList +amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) +amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) + +-- |Synonyms for AddAnn versions of AnnOpen and AnnClose +mo,mc :: Located Token -> AddAnn +mo ll = mj AnnOpen ll +mc ll = mj AnnClose ll + +moc,mcc :: Located Token -> AddAnn +moc ll = mj AnnOpenC ll +mcc ll = mj AnnCloseC ll + +mop,mcp :: Located Token -> AddAnn +mop ll = mj AnnOpenP ll +mcp ll = mj AnnCloseP ll + +mos,mcs :: Located Token -> AddAnn +mos ll = mj AnnOpenS ll +mcs ll = mj AnnCloseS ll + +-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma +-- entry for each SrcSpan +mcommas :: [SrcSpan] -> [AddAnn] +mcommas = map (AddAnn AnnCommaTuple) + +-- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar +-- entry for each SrcSpan +mvbars :: [SrcSpan] -> [AddAnn] +mvbars = map (AddAnn AnnVbar) + +-- |Get the location of the last element of a OrdList, or noSrcSpan +oll :: OrdList (Located a) -> SrcSpan +oll l = + if isNilOL l then noSrcSpan + else getLoc (lastOL l) + +-- |Add a semicolon annotation in the right place in a list. If the +-- leading list is empty, add it to the tail +asl :: [Located a] -> Located b -> Located a -> P () +asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls +asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls + +-- | Parse a Haskell module with Haddock comments. +-- This is done in two steps: +-- +-- * 'parseModuleNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This is the only parser entry point that deals with Haddock comments. +-- The other entry points ('parseDeclaration', 'parseExpression', etc) do +-- not insert them into the AST. +parseModule :: P (Located HsModule) +parseModule = parseModuleNoHaddock >>= addHaddockToModule +} diff --git a/GHC/Parser/Annotation.hs b/GHC/Parser/Annotation.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Annotation.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Parser.Annotation ( + getAnnotation, getAndRemoveAnnotation, + getAnnotationComments,getAndRemoveAnnotationComments, + ApiAnns(..), + ApiAnnKey, + AnnKeywordId(..), + AddAnn(..),mkParensApiAnn, + AnnotationComment(..), + IsUnicodeSyntax(..), + unicodeAnn, + HasE(..), + LRdrName -- Exists for haddocks only + ) where + +import GHC.Prelude + +import GHC.Types.Name.Reader +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import qualified Data.Map as Map +import Data.Data + + +{- +Note [Api annotations] +~~~~~~~~~~~~~~~~~~~~~~ +Given a parse tree of a Haskell module, how can we reconstruct +the original Haskell source code, retaining all whitespace and +source code comments? We need to track the locations of all +elements from the original source: this includes keywords such as +'let' / 'in' / 'do' etc as well as punctuation such as commas and +braces, and also comments. We collectively refer to this +metadata as the "API annotations". + +Rather than annotate the resulting parse tree with these locations +directly (this would be a major change to some fairly core data +structures in GHC), we instead capture locations for these elements in a +structure separate from the parse tree, and returned in the +pm_annotations field of the ParsedModule type. + +The full ApiAnns type is + +> data ApiAnns = +> ApiAnns +> { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan], +> apiAnnEofPos :: Maybe RealSrcSpan, +> apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment], +> apiAnnRogueComments :: [RealLocated AnnotationComment] +> } + +NON-COMMENT ELEMENTS + +Intuitively, every AST element directly contains a bag of keywords +(keywords can show up more than once in a node: a semicolon i.e. newline +can show up multiple times before the next AST element), each of which +needs to be associated with its location in the original source code. + +Consequently, the structure that records non-comment elements is logically +a two level map, from the RealSrcSpan of the AST element containing it, to +a map from keywords ('AnnKeyWord') to all locations of the keyword directly +in the AST element: + +> type ApiAnnKey = (RealSrcSpan,AnnKeywordId) +> +> Map.Map ApiAnnKey [RealSrcSpan] + +So + +> let x = 1 in 2 *x + +would result in the AST element + + L span (HsLet (binds for x = 1) (2 * x)) + +and the annotations + + (span,AnnLet) having the location of the 'let' keyword + (span,AnnEqual) having the location of the '=' sign + (span,AnnIn) having the location of the 'in' keyword + +For any given element in the AST, there is only a set number of +keywords that are applicable for it (e.g., you'll never see an +'import' keyword associated with a let-binding.) The set of allowed +keywords is documented in a comment associated with the constructor +of a given AST element, although the ground truth is in GHC.Parser +and GHC.Parser.PostProcess (which actually add the annotations; see #13012). + +COMMENT ELEMENTS + +Every comment is associated with a *located* AnnotationComment. +We associate comments with the lowest (most specific) AST element +enclosing them: + +> Map.Map RealSrcSpan [RealLocated AnnotationComment] + +PARSER STATE + +There are three fields in PState (the parser state) which play a role +with annotations. + +> annotations :: [(ApiAnnKey,[RealSrcSpan])], +> comment_q :: [RealLocated AnnotationComment], +> annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])] + +The 'annotations' and 'annotations_comments' fields are simple: they simply +accumulate annotations that will end up in 'ApiAnns' at the end +(after they are passed to Map.fromList). + +The 'comment_q' field captures comments as they are seen in the token stream, +so that when they are ready to be allocated via the parser they are +available (at the time we lex a comment, we don't know what the enclosing +AST node of it is, so we can't associate it with a RealSrcSpan in +annotations_comments). + +PARSER EMISSION OF ANNOTATIONS + +The parser interacts with the lexer using the function + +> addAnnotation :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P () + +which takes the AST element RealSrcSpan, the annotation keyword and the +target RealSrcSpan. + +This adds the annotation to the `annotations` field of `PState` and +transfers any comments in `comment_q` WHICH ARE ENCLOSED by +the RealSrcSpan of this element to the `annotations_comments` +field. (Comments which are outside of this annotation are deferred +until later. 'allocateComments' in 'Lexer' is responsible for +making sure we only attach comments that actually fit in the 'SrcSpan'.) + +The wiki page describing this feature is +https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations + +-} +-- --------------------------------------------------------------------- + +-- If you update this, update the Note [Api annotations] above +data ApiAnns = + ApiAnns + { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan], + apiAnnEofPos :: Maybe RealSrcSpan, + apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment], + apiAnnRogueComments :: [RealLocated AnnotationComment] + } + +-- If you update this, update the Note [Api annotations] above +type ApiAnnKey = (RealSrcSpan,AnnKeywordId) + + +-- --------------------------------------------------------------------- + +-- | Encapsulated call to addAnnotation, requiring only the SrcSpan of +-- the AST construct the annotation belongs to; together with the +-- AnnKeywordId, this is the key of the annotation map. +-- +-- This type is useful for places in the parser where it is not yet +-- known what SrcSpan an annotation should be added to. The most +-- common situation is when we are parsing a list: the annotations +-- need to be associated with the AST element that *contains* the +-- list, not the list itself. 'AddAnn' lets us defer adding the +-- annotations until we finish parsing the list and are now parsing +-- the enclosing element; we then apply the 'AddAnn' to associate +-- the annotations. Another common situation is where a common fragment of +-- the AST has been factored out but there is no separate AST node for +-- this fragment (this occurs in class and data declarations). In this +-- case, the annotation belongs to the parent data declaration. +-- +-- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") +-- function, and then it can be discharged using the 'ams' function. +data AddAnn = AddAnn AnnKeywordId SrcSpan + +-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'AddAnn' values for the opening and closing bordering on the start +-- and end of the span +mkParensApiAnn :: SrcSpan -> [AddAnn] +mkParensApiAnn (UnhelpfulSpan _) = [] +mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc] + where + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing + lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing + +-- --------------------------------------------------------------------- +-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' +-- of the annotated AST element, and the known type of the annotation. +getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan] +getAnnotation anns span ann = + case Map.lookup ann_key ann_items of + Nothing -> [] + Just ss -> ss + where ann_items = apiAnnItems anns + ann_key = (span,ann) + +-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' +-- of the annotated AST element, and the known type of the annotation. +-- The list is removed from the annotations. +getAndRemoveAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId + -> ([RealSrcSpan],ApiAnns) +getAndRemoveAnnotation anns span ann = + case Map.lookup ann_key ann_items of + Nothing -> ([],anns) + Just ss -> (ss,anns{ apiAnnItems = Map.delete ann_key ann_items }) + where ann_items = apiAnnItems anns + ann_key = (span,ann) + +-- |Retrieve the comments allocated to the current 'SrcSpan' +-- +-- Note: A given 'SrcSpan' may appear in multiple AST elements, +-- beware of duplicates +getAnnotationComments :: ApiAnns -> RealSrcSpan -> [RealLocated AnnotationComment] +getAnnotationComments anns span = + case Map.lookup span (apiAnnComments anns) of + Just cs -> cs + Nothing -> [] + +-- |Retrieve the comments allocated to the current 'SrcSpan', and +-- remove them from the annotations +getAndRemoveAnnotationComments :: ApiAnns -> RealSrcSpan + -> ([RealLocated AnnotationComment],ApiAnns) +getAndRemoveAnnotationComments anns span = + case Map.lookup span ann_comments of + Just cs -> (cs, anns{ apiAnnComments = Map.delete span ann_comments }) + Nothing -> ([], anns) + where ann_comments = apiAnnComments anns + +-- -------------------------------------------------------------------- + +-- | API Annotations exist so that tools can perform source to source +-- conversions of Haskell code. They are used to keep track of the +-- various syntactic keywords that are not captured in the existing +-- AST. +-- +-- The annotations, together with original source comments are made +-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@. +-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in +-- @'GHC.Driver.Session.DynFlags'@ before parsing. +-- +-- The wiki page describing this feature is +-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations +-- +-- Note: in general the names of these are taken from the +-- corresponding token, unless otherwise noted +-- See note [Api annotations] above for details of the usage +data AnnKeywordId + = AnnAnyclass + | AnnAs + | AnnAt + | AnnBang -- ^ '!' + | AnnBackquote -- ^ '`' + | AnnBy + | AnnCase -- ^ case or lambda case + | AnnClass + | AnnClose -- ^ '\#)' or '\#-}' etc + | AnnCloseB -- ^ '|)' + | AnnCloseBU -- ^ '|)', unicode variant + | AnnCloseC -- ^ '}' + | AnnCloseQ -- ^ '|]' + | AnnCloseQU -- ^ '|]', unicode variant + | AnnCloseP -- ^ ')' + | AnnCloseS -- ^ ']' + | AnnColon + | AnnComma -- ^ as a list separator + | AnnCommaTuple -- ^ in a RdrName for a tuple + | AnnDarrow -- ^ '=>' + | AnnDarrowU -- ^ '=>', unicode variant + | AnnData + | AnnDcolon -- ^ '::' + | AnnDcolonU -- ^ '::', unicode variant + | AnnDefault + | AnnDeriving + | AnnDo + | AnnDot -- ^ '.' + | AnnDotdot -- ^ '..' + | AnnElse + | AnnEqual + | AnnExport + | AnnFamily + | AnnForall + | AnnForallU -- ^ Unicode variant + | AnnForeign + | AnnFunId -- ^ for function name in matches where there are + -- multiple equations for the function. + | AnnGroup + | AnnHeader -- ^ for CType + | AnnHiding + | AnnIf + | AnnImport + | AnnIn + | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' + | AnnInstance + | AnnLam + | AnnLarrow -- ^ '<-' + | AnnLarrowU -- ^ '<-', unicode variant + | AnnLet + | AnnLollyU -- ^ The '⊸' unicode arrow + | AnnMdo + | AnnMinus -- ^ '-' + | AnnModule + | AnnPercentOne -- ^ '%1' -- for HsLinearArrow + | AnnNewtype + | AnnName -- ^ where a name loses its location in the AST, this carries it + | AnnOf + | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc + | AnnOpenB -- ^ '(|' + | AnnOpenBU -- ^ '(|', unicode variant + | AnnOpenC -- ^ '{' + | AnnOpenE -- ^ '[e|' or '[e||' + | AnnOpenEQ -- ^ '[|' + | AnnOpenEQU -- ^ '[|', unicode variant + | AnnOpenP -- ^ '(' + | AnnOpenS -- ^ '[' + | AnnDollar -- ^ prefix '$' -- TemplateHaskell + | AnnDollarDollar -- ^ prefix '$$' -- TemplateHaskell + | AnnPackageName + | AnnPattern + | AnnPercent -- ^ '%' -- for HsExplicitMult + | AnnProc + | AnnQualified + | AnnRarrow -- ^ '->' + | AnnRarrowU -- ^ '->', unicode variant + | AnnRec + | AnnRole + | AnnSafe + | AnnSemi -- ^ ';' + | AnnSimpleQuote -- ^ ''' + | AnnSignature + | AnnStatic -- ^ 'static' + | AnnStock + | AnnThen + | AnnThTyQuote -- ^ double ''' + | AnnTilde -- ^ '~' + | AnnType + | AnnUnit -- ^ '()' for types + | AnnUsing + | AnnVal -- ^ e.g. INTEGER + | AnnValStr -- ^ String value, will need quotes when output + | AnnVbar -- ^ '|' + | AnnVia -- ^ 'via' + | AnnWhere + | Annlarrowtail -- ^ '-<' + | AnnlarrowtailU -- ^ '-<', unicode variant + | Annrarrowtail -- ^ '->' + | AnnrarrowtailU -- ^ '->', unicode variant + | AnnLarrowtail -- ^ '-<<' + | AnnLarrowtailU -- ^ '-<<', unicode variant + | AnnRarrowtail -- ^ '>>-' + | AnnRarrowtailU -- ^ '>>-', unicode variant + deriving (Eq, Ord, Data, Show) + +instance Outputable AnnKeywordId where + ppr x = text (show x) + +-- --------------------------------------------------------------------- + +data AnnotationComment = + -- Documentation annotations + AnnDocCommentNext String -- ^ something beginning '-- |' + | AnnDocCommentPrev String -- ^ something beginning '-- ^' + | AnnDocCommentNamed String -- ^ something beginning '-- $' + | AnnDocSection Int String -- ^ a section heading + | AnnDocOptions String -- ^ doc options (prune, ignore-exports, etc) + | AnnLineComment String -- ^ comment starting by "--" + | AnnBlockComment String -- ^ comment in {- -} + deriving (Eq, Ord, Data, Show) +-- Note: these are based on the Token versions, but the Token type is +-- defined in GHC.Parser.Lexer and bringing it in here would create a loop + +instance Outputable AnnotationComment where + ppr x = text (show x) + +-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', +-- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma', +-- 'GHC.Parser.Annotation.AnnRarrow' +-- 'GHC.Parser.Annotation.AnnTilde' +-- - May have 'GHC.Parser.Annotation.AnnComma' when in a list +type LRdrName = Located RdrName + + +-- | Certain tokens can have alternate representations when unicode syntax is +-- enabled. This flag is attached to those tokens in the lexer so that the +-- original source representation can be reproduced in the corresponding +-- 'ApiAnnotation' +data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax + deriving (Eq, Ord, Data, Show) + +-- | Convert a normal annotation into its unicode equivalent one +unicodeAnn :: AnnKeywordId -> AnnKeywordId +unicodeAnn AnnForall = AnnForallU +unicodeAnn AnnDcolon = AnnDcolonU +unicodeAnn AnnLarrow = AnnLarrowU +unicodeAnn AnnRarrow = AnnRarrowU +unicodeAnn AnnDarrow = AnnDarrowU +unicodeAnn Annlarrowtail = AnnlarrowtailU +unicodeAnn Annrarrowtail = AnnrarrowtailU +unicodeAnn AnnLarrowtail = AnnLarrowtailU +unicodeAnn AnnRarrowtail = AnnRarrowtailU +unicodeAnn AnnOpenB = AnnOpenBU +unicodeAnn AnnCloseB = AnnCloseBU +unicodeAnn AnnOpenEQ = AnnOpenEQU +unicodeAnn AnnCloseQ = AnnCloseQU +unicodeAnn ann = ann + + +-- | Some template haskell tokens have two variants, one with an `e` the other +-- not: +-- +-- > [| or [e| +-- > [|| or [e|| +-- +-- This type indicates whether the 'e' is present or not. +data HasE = HasE | NoE + deriving (Eq, Ord, Data, Show) diff --git a/GHC/Parser/CharClass.hs b/GHC/Parser/CharClass.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/CharClass.hs @@ -0,0 +1,215 @@ +-- Character classification +{-# LANGUAGE CPP #-} +module GHC.Parser.CharClass + ( is_ident -- Char# -> Bool + , is_symbol -- Char# -> Bool + , is_any -- Char# -> Bool + , is_space -- Char# -> Bool + , is_lower -- Char# -> Bool + , is_upper -- Char# -> Bool + , is_digit -- Char# -> Bool + , is_alphanum -- Char# -> Bool + + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit + , hexDigit, octDecDigit + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import Data.Bits ( Bits((.&.),(.|.)) ) +import Data.Char ( ord, chr ) +import Data.Word +import GHC.Utils.Panic + +-- Bit masks + +cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Word8 +cIdent = 1 +cSymbol = 2 +cAny = 4 +cSpace = 8 +cLower = 16 +cUpper = 32 +cDigit = 64 + +-- | The predicates below look costly, but aren't, GHC+GCC do a great job +-- at the big case below. + +{-# INLINABLE is_ctype #-} +is_ctype :: Word8 -> Char -> Bool +is_ctype mask c = (charType c .&. mask) /= 0 + +is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, + is_alphanum :: Char -> Bool +is_ident = is_ctype cIdent +is_symbol = is_ctype cSymbol +is_any = is_ctype cAny +is_space = is_ctype cSpace +is_lower = is_ctype cLower +is_upper = is_ctype cUpper +is_digit = is_ctype cDigit +is_alphanum = is_ctype (cLower+cUpper+cDigit) + +-- Utils + +hexDigit :: Char -> Int +hexDigit c | is_decdigit c = ord c - ord '0' + | otherwise = ord (to_lower c) - ord 'a' + 10 + +octDecDigit :: Char -> Int +octDecDigit c = ord c - ord '0' + +is_decdigit :: Char -> Bool +is_decdigit c + = c >= '0' && c <= '9' + +is_hexdigit :: Char -> Bool +is_hexdigit c + = is_decdigit c + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + +is_octdigit :: Char -> Bool +is_octdigit c = c >= '0' && c <= '7' + +is_bindigit :: Char -> Bool +is_bindigit c = c == '0' || c == '1' + +to_lower :: Char -> Char +to_lower c + | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) + | otherwise = c + +charType :: Char -> Word8 +charType c = case c of + '\0' -> 0 -- \000 + '\1' -> 0 -- \001 + '\2' -> 0 -- \002 + '\3' -> 0 -- \003 + '\4' -> 0 -- \004 + '\5' -> 0 -- \005 + '\6' -> 0 -- \006 + '\7' -> 0 -- \007 + '\8' -> 0 -- \010 + '\9' -> cSpace -- \t (not allowed in strings, so !cAny) + '\10' -> cSpace -- \n (ditto) + '\11' -> cSpace -- \v (ditto) + '\12' -> cSpace -- \f (ditto) + '\13' -> cSpace -- ^M (ditto) + '\14' -> 0 -- \016 + '\15' -> 0 -- \017 + '\16' -> 0 -- \020 + '\17' -> 0 -- \021 + '\18' -> 0 -- \022 + '\19' -> 0 -- \023 + '\20' -> 0 -- \024 + '\21' -> 0 -- \025 + '\22' -> 0 -- \026 + '\23' -> 0 -- \027 + '\24' -> 0 -- \030 + '\25' -> 0 -- \031 + '\26' -> 0 -- \032 + '\27' -> 0 -- \033 + '\28' -> 0 -- \034 + '\29' -> 0 -- \035 + '\30' -> 0 -- \036 + '\31' -> 0 -- \037 + '\32' -> cAny .|. cSpace -- + '\33' -> cAny .|. cSymbol -- ! + '\34' -> cAny -- " + '\35' -> cAny .|. cSymbol -- # + '\36' -> cAny .|. cSymbol -- $ + '\37' -> cAny .|. cSymbol -- % + '\38' -> cAny .|. cSymbol -- & + '\39' -> cAny .|. cIdent -- ' + '\40' -> cAny -- ( + '\41' -> cAny -- ) + '\42' -> cAny .|. cSymbol -- * + '\43' -> cAny .|. cSymbol -- + + '\44' -> cAny -- , + '\45' -> cAny .|. cSymbol -- - + '\46' -> cAny .|. cSymbol -- . + '\47' -> cAny .|. cSymbol -- / + '\48' -> cAny .|. cIdent .|. cDigit -- 0 + '\49' -> cAny .|. cIdent .|. cDigit -- 1 + '\50' -> cAny .|. cIdent .|. cDigit -- 2 + '\51' -> cAny .|. cIdent .|. cDigit -- 3 + '\52' -> cAny .|. cIdent .|. cDigit -- 4 + '\53' -> cAny .|. cIdent .|. cDigit -- 5 + '\54' -> cAny .|. cIdent .|. cDigit -- 6 + '\55' -> cAny .|. cIdent .|. cDigit -- 7 + '\56' -> cAny .|. cIdent .|. cDigit -- 8 + '\57' -> cAny .|. cIdent .|. cDigit -- 9 + '\58' -> cAny .|. cSymbol -- : + '\59' -> cAny -- ; + '\60' -> cAny .|. cSymbol -- < + '\61' -> cAny .|. cSymbol -- = + '\62' -> cAny .|. cSymbol -- > + '\63' -> cAny .|. cSymbol -- ? + '\64' -> cAny .|. cSymbol -- @ + '\65' -> cAny .|. cIdent .|. cUpper -- A + '\66' -> cAny .|. cIdent .|. cUpper -- B + '\67' -> cAny .|. cIdent .|. cUpper -- C + '\68' -> cAny .|. cIdent .|. cUpper -- D + '\69' -> cAny .|. cIdent .|. cUpper -- E + '\70' -> cAny .|. cIdent .|. cUpper -- F + '\71' -> cAny .|. cIdent .|. cUpper -- G + '\72' -> cAny .|. cIdent .|. cUpper -- H + '\73' -> cAny .|. cIdent .|. cUpper -- I + '\74' -> cAny .|. cIdent .|. cUpper -- J + '\75' -> cAny .|. cIdent .|. cUpper -- K + '\76' -> cAny .|. cIdent .|. cUpper -- L + '\77' -> cAny .|. cIdent .|. cUpper -- M + '\78' -> cAny .|. cIdent .|. cUpper -- N + '\79' -> cAny .|. cIdent .|. cUpper -- O + '\80' -> cAny .|. cIdent .|. cUpper -- P + '\81' -> cAny .|. cIdent .|. cUpper -- Q + '\82' -> cAny .|. cIdent .|. cUpper -- R + '\83' -> cAny .|. cIdent .|. cUpper -- S + '\84' -> cAny .|. cIdent .|. cUpper -- T + '\85' -> cAny .|. cIdent .|. cUpper -- U + '\86' -> cAny .|. cIdent .|. cUpper -- V + '\87' -> cAny .|. cIdent .|. cUpper -- W + '\88' -> cAny .|. cIdent .|. cUpper -- X + '\89' -> cAny .|. cIdent .|. cUpper -- Y + '\90' -> cAny .|. cIdent .|. cUpper -- Z + '\91' -> cAny -- [ + '\92' -> cAny .|. cSymbol -- backslash + '\93' -> cAny -- ] + '\94' -> cAny .|. cSymbol -- ^ + '\95' -> cAny .|. cIdent .|. cLower -- _ + '\96' -> cAny -- ` + '\97' -> cAny .|. cIdent .|. cLower -- a + '\98' -> cAny .|. cIdent .|. cLower -- b + '\99' -> cAny .|. cIdent .|. cLower -- c + '\100' -> cAny .|. cIdent .|. cLower -- d + '\101' -> cAny .|. cIdent .|. cLower -- e + '\102' -> cAny .|. cIdent .|. cLower -- f + '\103' -> cAny .|. cIdent .|. cLower -- g + '\104' -> cAny .|. cIdent .|. cLower -- h + '\105' -> cAny .|. cIdent .|. cLower -- i + '\106' -> cAny .|. cIdent .|. cLower -- j + '\107' -> cAny .|. cIdent .|. cLower -- k + '\108' -> cAny .|. cIdent .|. cLower -- l + '\109' -> cAny .|. cIdent .|. cLower -- m + '\110' -> cAny .|. cIdent .|. cLower -- n + '\111' -> cAny .|. cIdent .|. cLower -- o + '\112' -> cAny .|. cIdent .|. cLower -- p + '\113' -> cAny .|. cIdent .|. cLower -- q + '\114' -> cAny .|. cIdent .|. cLower -- r + '\115' -> cAny .|. cIdent .|. cLower -- s + '\116' -> cAny .|. cIdent .|. cLower -- t + '\117' -> cAny .|. cIdent .|. cLower -- u + '\118' -> cAny .|. cIdent .|. cLower -- v + '\119' -> cAny .|. cIdent .|. cLower -- w + '\120' -> cAny .|. cIdent .|. cLower -- x + '\121' -> cAny .|. cIdent .|. cLower -- y + '\122' -> cAny .|. cIdent .|. cLower -- z + '\123' -> cAny -- { + '\124' -> cAny .|. cSymbol -- | + '\125' -> cAny -- } + '\126' -> cAny .|. cSymbol -- ~ + '\127' -> 0 -- \177 + _ -> panic ("charType: " ++ show c) diff --git a/GHC/Parser/Header.hs b/GHC/Parser/Header.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Header.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- | Parsing the top of a Haskell source file to get its module name, +-- imports and options. +-- +-- (c) Simon Marlow 2005 +-- (c) Lemmih 2006 +-- +----------------------------------------------------------------------------- + +module GHC.Parser.Header + ( getImports + , mkPrelImports -- used by the renamer too + , getOptionsFromFile + , getOptions + , optionsErrorMsgs + , checkProcessArgsResult + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.Driver.Types +import GHC.Parser ( parseHeader ) +import GHC.Parser.Lexer +import GHC.Data.FastString +import GHC.Hs +import GHC.Unit.Module +import GHC.Builtin.Names +import GHC.Data.StringBuffer +import GHC.Types.SrcLoc +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe +import GHC.Data.Bag ( emptyBag, listToBag, unitBag ) +import GHC.Utils.Monad +import GHC.Utils.Exception as Exception +import GHC.Types.Basic +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import System.IO +import System.IO.Unsafe +import Data.List + +------------------------------------------------------------------------------ + +-- | Parse the imports of a source file. +-- +-- Throws a 'SourceError' if parsing fails. +getImports :: DynFlags + -> StringBuffer -- ^ Parse this. + -> FilePath -- ^ Filename the buffer came from. Used for + -- reporting parse error locations. + -> FilePath -- ^ The original source filename (used for locations + -- in the function result) + -> IO (Either + ErrorMessages + ([(Maybe FastString, Located ModuleName)], + [(Maybe FastString, Located ModuleName)], + Located ModuleName)) + -- ^ The source imports and normal imports (with optional package + -- names from -XPackageImports), and the module name. +getImports dflags buf filename source_filename = do + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP parseHeader (mkPState dflags buf loc) of + PFailed pst -> + -- assuming we're not logging warnings here as per below + return $ Left $ getErrorMessages pst dflags + POk pst rdr_module -> fmap Right $ do + let _ms@(_warns, errs) = getMessages pst dflags + -- don't log warnings: they'll be reported when we parse the file + -- for real. See #2500. + ms = (emptyBag, errs) + -- logWarnings warns + if errorsFound dflags ms + then throwIO $ mkSrcErr errs + else + let hsmod = unLoc rdr_module + mb_mod = hsmodName hsmod + imps = hsmodImports hsmod + main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) + 1 1) + mod = mb_mod `orElse` L main_loc mAIN_NAME + (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc + . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports (unLoc mod) main_loc + implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) + in + return (map convImport src_idecls, + map convImport (implicit_imports ++ ordinary_imps), + mod) + +mkPrelImports :: ModuleName + -> SrcSpan -- Attribute the "import Prelude" to this location + -> Bool -> [LImportDecl GhcPs] + -> [LImportDecl GhcPs] +-- Construct the implicit declaration "import Prelude" (or not) +-- +-- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); +-- because the former doesn't even look at Prelude.hi for instance +-- declarations, whereas the latter does. +mkPrelImports this_mod loc implicit_prelude import_decls + | this_mod == pRELUDE_NAME + || explicit_prelude_import + || not implicit_prelude + = [] + | otherwise = [preludeImportDecl] + where + explicit_prelude_import + = notNull [ () | L _ (ImportDecl { ideclName = mod + , ideclPkgQual = Nothing }) + <- import_decls + , unLoc mod == pRELUDE_NAME ] + + preludeImportDecl :: LImportDecl GhcPs + preludeImportDecl + = L loc $ ImportDecl { ideclExt = noExtField, + ideclSourceSrc = NoSourceText, + ideclName = L loc pRELUDE_NAME, + ideclPkgQual = Nothing, + ideclSource = NotBoot, + ideclSafe = False, -- Not a safe import + ideclQualified = NotQualified, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } + +-------------------------------------------------------------- +-- Get options +-------------------------------------------------------------- + +-- | Parse OPTIONS and LANGUAGE pragmas of the source file. +-- +-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) +getOptionsFromFile :: DynFlags + -> FilePath -- ^ Input file + -> IO [Located String] -- ^ Parsed options, if any. +getOptionsFromFile dflags filename + = Exception.bracket + (openBinaryFile filename ReadMode) + (hClose) + (\handle -> do + opts <- fmap (getOptions' dflags) + (lazyGetToks dflags' filename handle) + seqList opts $ return opts) + where -- We don't need to get haddock doc tokens when we're just + -- getting the options from pragmas, and lazily lexing them + -- correctly is a little tricky: If there is "\n" or "\n-" + -- left at the end of a buffer then the haddock doc may + -- continue past the end of the buffer, despite the fact that + -- we already have an apparently-complete token. + -- We therefore just turn Opt_Haddock off when doing the lazy + -- lex. + dflags' = gopt_unset dflags Opt_Haddock + +blockSize :: Int +-- blockSize = 17 -- for testing :-) +blockSize = 1024 + +lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] +lazyGetToks dflags filename handle = do + buf <- hGetStringBufferBlock handle blockSize + unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize + where + loc = mkRealSrcLoc (mkFastString filename) 1 1 + + lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] + lazyLexBuf handle state eof size = do + case unP (lexer False return) state of + POk state' t -> do + -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) + if atEnd (buffer state') && not eof + -- if this token reached the end of the buffer, and we haven't + -- necessarily read up to the end of the file, then the token might + -- be truncated, so read some more of the file and lex it again. + then getMore handle state size + else case unLoc t of + ITeof -> return [t] + _other -> do rest <- lazyLexBuf handle state' eof size + return (t : rest) + _ | not eof -> getMore handle state size + | otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof] + -- parser assumes an ITeof sentinel at the end + + getMore :: Handle -> PState -> Int -> IO [Located Token] + getMore handle state size = do + -- pprTrace "getMore" (text (show (buffer state))) (return ()) + let new_size = size * 2 + -- double the buffer size each time we read a new block. This + -- counteracts the quadratic slowdown we otherwise get for very + -- large module names (#5981) + nextbuf <- hGetStringBufferBlock handle new_size + if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do + newbuf <- appendStringBuffers (buffer state) nextbuf + unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size + + +getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] +getToks dflags filename buf = lexAll (pragState dflags buf loc) + where + loc = mkRealSrcLoc (mkFastString filename) 1 1 + + lexAll state = case unP (lexer False return) state of + POk _ t@(L _ ITeof) -> [t] + POk state' t -> t : lexAll state' + _ -> [L (mkSrcSpanPs (last_loc state)) ITeof] + + +-- | Parse OPTIONS and LANGUAGE pragmas of the source file. +-- +-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) +getOptions :: DynFlags + -> StringBuffer -- ^ Input Buffer + -> FilePath -- ^ Source filename. Used for location info. + -> [Located String] -- ^ Parsed options. +getOptions dflags buf filename + = getOptions' dflags (getToks dflags filename buf) + +-- The token parser is written manually because Happy can't +-- return a partial result when it encounters a lexer error. +-- We want to extract options before the buffer is passed through +-- CPP, so we can't use the same trick as 'getImports'. +getOptions' :: DynFlags + -> [Located Token] -- Input buffer + -> [Located String] -- Options. +getOptions' dflags toks + = parseToks toks + where + parseToks (open:close:xs) + | IToptions_prag str <- unLoc open + , ITclose_prag <- unLoc close + = case toArgs str of + Left _err -> optionsParseError str dflags $ -- #15053 + combineSrcSpans (getLoc open) (getLoc close) + Right args -> map (L (getLoc open)) args ++ parseToks xs + parseToks (open:close:xs) + | ITinclude_prag str <- unLoc open + , ITclose_prag <- unLoc close + = map (L (getLoc open)) ["-#include",removeSpaces str] ++ + parseToks xs + parseToks (open:close:xs) + | ITdocOptions str <- unLoc open + , ITclose_prag <- unLoc close + = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] + ++ parseToks xs + parseToks (open:xs) + | ITlanguage_prag <- unLoc open + = parseLanguage xs + parseToks (comment:xs) -- Skip over comments + | isComment (unLoc comment) + = parseToks xs + parseToks _ = [] + parseLanguage ((L loc (ITconid fs)):rest) + = checkExtension dflags (L loc fs) : + case rest of + (L _loc ITcomma):more -> parseLanguage more + (L _loc ITclose_prag):more -> parseToks more + (L loc _):_ -> languagePragParseError dflags loc + [] -> panic "getOptions'.parseLanguage(1) went past eof token" + parseLanguage (tok:_) + = languagePragParseError dflags (getLoc tok) + parseLanguage [] + = panic "getOptions'.parseLanguage(2) went past eof token" + + isComment :: Token -> Bool + isComment c = + case c of + (ITlineComment {}) -> True + (ITblockComment {}) -> True + (ITdocCommentNext {}) -> True + (ITdocCommentPrev {}) -> True + (ITdocCommentNamed {}) -> True + (ITdocSection {}) -> True + _ -> False + +----------------------------------------------------------------------------- + +-- | Complain about non-dynamic flags in OPTIONS pragmas. +-- +-- Throws a 'SourceError' if the input list is non-empty claiming that the +-- input flags are unknown. +checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () +checkProcessArgsResult dflags flags + = when (notNull flags) $ + liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags + where mkMsg (L loc flag) + = mkPlainErrMsg dflags loc $ + (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> + text flag) + +----------------------------------------------------------------------------- + +checkExtension :: DynFlags -> Located FastString -> Located String +checkExtension dflags (L l ext) +-- Checks if a given extension is valid, and if so returns +-- its corresponding flag. Otherwise it throws an exception. + = if ext' `elem` supported + then L l ("-X"++ext') + else unsupportedExtnError dflags l ext' + where + ext' = unpackFS ext + supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags + +languagePragParseError :: DynFlags -> SrcSpan -> a +languagePragParseError dflags loc = + throwErr dflags loc $ + vcat [ text "Cannot parse LANGUAGE pragma" + , text "Expecting comma-separated list of language options," + , text "each starting with a capital letter" + , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ] + +unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a +unsupportedExtnError dflags loc unsup = + throwErr dflags loc $ + text "Unsupported extension: " <> text unsup $$ + if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) + where + supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags + suggestions = fuzzyMatch unsup supported + + +optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs dflags unhandled_flags flags_lines _filename + = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) + where unhandled_flags_lines :: [Located String] + unhandled_flags_lines = [ L l f + | f <- unhandled_flags + , L l f' <- flags_lines + , f == f' ] + mkMsg (L flagSpan flag) = + GHC.Utils.Error.mkPlainErrMsg dflags flagSpan $ + text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag + +optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 +optionsParseError str dflags loc = + throwErr dflags loc $ + vcat [ text "Error while parsing OPTIONS_GHC pragma." + , text "Expecting whitespace-separated list of GHC options." + , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" + , text ("Input was: " ++ show str) ] + +throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053 +throwErr dflags loc doc = + throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc diff --git a/GHC/Parser/Lexer.x b/GHC/Parser/Lexer.x new file mode 100644 --- /dev/null +++ b/GHC/Parser/Lexer.x @@ -0,0 +1,3411 @@ +----------------------------------------------------------------------------- +-- (c) The University of Glasgow, 2006 +-- +-- GHC's lexer for Haskell 2010 [1]. +-- +-- This is a combination of an Alex-generated lexer [2] from a regex +-- definition, with some hand-coded bits. [3] +-- +-- Completely accurate information about token-spans within the source +-- file is maintained. Every token has a start and end RealSrcLoc +-- attached to it. +-- +-- References: +-- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html +-- [2] http://www.haskell.org/alex/ +-- [3] https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/parser +-- +----------------------------------------------------------------------------- + +-- ToDo / known bugs: +-- - parsing integers is a bit slow +-- - readRational is a bit slow +-- +-- Known bugs, that were also in the previous version: +-- - M... should be 3 tokens, not 1. +-- - pragma-end should be only valid in a pragma + +-- qualified operator NOTES. +-- +-- - If M.(+) is a single lexeme, then.. +-- - Probably (+) should be a single lexeme too, for consistency. +-- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. +-- - But we have to rule out reserved operators, otherwise (..) becomes +-- a different lexeme. +-- - Should we therefore also rule out reserved operators in the qualified +-- form? This is quite difficult to achieve. We don't do it for +-- qualified varids. + + +-- ----------------------------------------------------------------------------- +-- Alex "Haskell code fragment top" + +{ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Parser.Lexer ( + Token(..), lexer, lexerDbg, pragState, mkPState, mkPStatePure, PState(..), + P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..), + appendWarning, + appendError, + allocateComments, + MonadP(..), + getRealSrcLoc, getPState, withHomeUnitId, + failMsgP, failLocMsgP, srcParseFail, + getErrorMessages, getMessages, + popContext, pushModuleContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, + getLexState, popLexState, pushLexState, + ExtBits(..), + xtest, + lexTokenStream, + addAnnsAt, + commentToAnnotation, + HdkComment(..), + ) where + +import GHC.Prelude + +-- base +import Control.Monad +import Data.Bits +import Data.Char +import Data.List +import Data.Maybe +import Data.Word + +import GHC.Data.EnumSet as EnumSet + +-- ghc-boot +import qualified GHC.LanguageExtensions as LangExt + +-- bytestring +import Data.ByteString (ByteString) + +-- containers +import Data.Map (Map) +import qualified Data.Map as Map + +-- compiler/utils +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Types.Unique.FM +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Utils.Misc ( readRational, readHexRational ) + +-- compiler/main +import GHC.Utils.Error +import GHC.Driver.Session as DynFlags + +-- compiler/basicTypes +import GHC.Types.SrcLoc +import GHC.Unit +import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..), + IntegralLit(..), FractionalLit(..), + SourceText(..) ) +import GHC.Hs.Doc + +-- compiler/parser +import GHC.Parser.CharClass + +import GHC.Parser.Annotation +} + +-- ----------------------------------------------------------------------------- +-- Alex "Character set macros" + +-- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme" +-- Any changes here should likely be reflected there. +$unispace = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$nl = [\n\r\f] +$whitechar = [$nl\v\ $unispace] +$white_no_nl = $whitechar # \n -- TODO #8424 +$tab = \t + +$ascdigit = 0-9 +$unidigit = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$decdigit = $ascdigit -- for now, should really be $digit (ToDo) +$digit = [$ascdigit $unidigit] + +$special = [\(\)\,\;\[\]\`\{\}] +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] +$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] + +$unilarge = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$asclarge = [A-Z] +$large = [$asclarge $unilarge] + +$unismall = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$ascsmall = [a-z] +$small = [$ascsmall $unismall \_] + +$unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$graphic = [$small $large $symbol $digit $special $unigraphic \"\'] + +$binit = 0-1 +$octit = 0-7 +$hexit = [$decdigit A-F a-f] + +$uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$idchar = [$small $large $digit $uniidchar \'] + +$pragmachar = [$small $large $digit] + +$docsym = [\| \^ \* \$] + + +-- ----------------------------------------------------------------------------- +-- Alex "Regular expression macros" + +@varid = $small $idchar* -- variable identifiers +@conid = $large $idchar* -- constructor identifiers + +@varsym = ($symbol # \:) $symbol* -- variable (operator) symbol +@consym = \: $symbol* -- constructor (operator) symbol + +-- See Note [Lexing NumericUnderscores extension] and #14473 +@numspc = _* -- numeric spacer (#14473) +@decimal = $decdigit(@numspc $decdigit)* +@binary = $binit(@numspc $binit)* +@octal = $octit(@numspc $octit)* +@hexadecimal = $hexit(@numspc $hexit)* +@exponent = @numspc [eE] [\-\+]? @decimal +@bin_exponent = @numspc [pP] [\-\+]? @decimal + +@qual = (@conid \.)+ +@qvarid = @qual @varid +@qconid = @qual @conid +@qvarsym = @qual @varsym +@qconsym = @qual @consym + +-- QualifiedDo needs to parse "M.do" not as a variable, so as to keep the +-- layout rules. +@qdo = @qual "do" +@qmdo = @qual "mdo" + +@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent +@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent + +-- normal signed numerical literals can only be explicitly negative, +-- not explicitly positive (contrast @exponent) +@negative = \- + + +-- ----------------------------------------------------------------------------- +-- Alex "Identifier" + +haskell :- + + +-- ----------------------------------------------------------------------------- +-- Alex "Rules" + +-- everywhere: skip whitespace +$white_no_nl+ ; +$tab { warnTab } + +-- Everywhere: deal with nested comments. We explicitly rule out +-- pragmas, "{-#", so that we don't accidentally treat them as comments. +-- (this can happen even though pragmas will normally take precedence due to +-- longest-match, because pragmas aren't valid in every state, but comments +-- are). We also rule out nested Haddock comments, if the -haddock flag is +-- set. + +"{-" / { isNormalComment } { nested_comment lexToken } + +-- Single-line comments are a bit tricky. Haskell 98 says that two or +-- more dashes followed by a symbol should be parsed as a varsym, so we +-- have to exclude those. + +-- Since Haddock comments aren't valid in every state, we need to rule them +-- out here. + +-- The following two rules match comments that begin with two dashes, but +-- continue with a different character. The rules test that this character +-- is not a symbol (in which case we'd have a varsym), and that it's not a +-- space followed by a Haddock comment symbol (docsym) (in which case we'd +-- have a Haddock comment). The rules then munch the rest of the line. + +"-- " ~$docsym .* { lineCommentToken } +"--" [^$symbol \ ] .* { lineCommentToken } + +-- Next, match Haddock comments if no -haddock flag + +"-- " $docsym .* / { alexNotPred (ifExtension HaddockBit) } { lineCommentToken } + +-- Now, when we've matched comments that begin with 2 dashes and continue +-- with a different character, we need to match comments that begin with three +-- or more dashes (which clearly can't be Haddock comments). We only need to +-- make sure that the first non-dash character isn't a symbol, and munch the +-- rest of the line. + +"---"\-* ~$symbol .* { lineCommentToken } + +-- Since the previous rules all match dashes followed by at least one +-- character, we also need to match a whole line filled with just dashes. + +"--"\-* / { atEOL } { lineCommentToken } + +-- We need this rule since none of the other single line comment rules +-- actually match this case. + +"-- " / { atEOL } { lineCommentToken } + +-- 'bol' state: beginning of a line. Slurp up all the whitespace (including +-- blank lines) until we find a non-whitespace character, then do layout +-- processing. +-- +-- One slight wibble here: what if the line begins with {-#? In +-- theory, we have to lex the pragma to see if it's one we recognise, +-- and if it is, then we backtrack and do_bol, otherwise we treat it +-- as a nested comment. We don't bother with this: if the line begins +-- with {-#, then we'll assume it's a pragma we know about and go for do_bol. + { + \n ; + ^\# line { begin line_prag1 } + ^\# / { followedByDigit } { begin line_prag1 } + ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently + ^\# \! .* \n ; -- #!, for scripts + () { do_bol } +} + +-- after a layout keyword (let, where, do, of), we begin a new layout +-- context if the curly brace is missing. +-- Careful! This stuff is quite delicate. + { + \{ / { notFollowedBy '-' } { hopefully_open_brace } + -- we might encounter {-# here, but {- has been handled already + \n ; + ^\# (line)? { begin line_prag1 } +} + +-- after an 'if', a vertical bar starts a layout context for MultiWayIf + { + \| / { notFollowedBySymbol } { new_layout_context True dontGenerateSemic ITvbar } + () { pop } +} + +-- do is treated in a subtly different way, see new_layout_context + () { new_layout_context True generateSemic ITvocurly } + () { new_layout_context False generateSemic ITvocurly } + +-- after a new layout context which was found to be to the left of the +-- previous context, we have generated a '{' token, and we now need to +-- generate a matching '}' token. + () { do_layout_left } + +<0,option_prags> \n { begin bol } + +"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags } + { dispatch_pragmas linePrags } + +-- single-line line pragmas, of the form +-- # "" \n + { + @decimal $white_no_nl+ \" [$graphic \ ]* \" { setLineAndFile line_prag1a } + () { failLinePrag1 } +} + .* { popLinePrag1 } + +-- Haskell-style line pragmas, of the form +-- {-# LINE "" #-} + { + @decimal $white_no_nl+ \" [$graphic \ ]* \" { setLineAndFile line_prag2a } +} + "#-}"|"-}" { pop } + -- NOTE: accept -} at the end of a LINE pragma, for compatibility + -- with older versions of GHC which generated these. + +-- Haskell-style column pragmas, of the form +-- {-# COLUMN #-} + @decimal $whitechar* "#-}" { setColumn } + +<0,option_prags> { + "{-#" $whitechar* $pragmachar+ + $whitechar+ $pragmachar+ / { known_pragma twoWordPrags } + { dispatch_pragmas twoWordPrags } + + "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags } + { dispatch_pragmas oneWordPrags } + + -- We ignore all these pragmas, but don't generate a warning for them + "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags } + { dispatch_pragmas ignoredPrags } + + -- ToDo: should only be valid inside a pragma: + "#-}" { endPrag } +} + + { + "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } + { dispatch_pragmas fileHeaderPrags } +} + +<0> { + -- In the "0" mode we ignore these pragmas + "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } + { nested_comment lexToken } +} + +<0,option_prags> { + "{-#" { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") + (nested_comment lexToken) } +} + +-- '0' state: ordinary lexemes + +-- Haddock comments + +"-- " $docsym / { ifExtension HaddockBit } { multiline_doc_comment } +"{-" \ ? $docsym / { ifExtension HaddockBit } { nested_doc_comment } + +-- "special" symbols + +<0> { + + -- Don't check ThQuotesBit here as the renamer can produce a better + -- error message than the lexer (see the thQuotesEnabled check in rnBracket). + "[|" { token (ITopenExpQuote NoE NormalSyntax) } + "[||" { token (ITopenTExpQuote NoE) } + "|]" { token (ITcloseQuote NormalSyntax) } + "||]" { token ITcloseTExpQuote } + + -- Check ThQuotesBit here as to not steal syntax. + "[e|" / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) } + "[e||" / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) } + "[p|" / { ifExtension ThQuotesBit } { token ITopenPatQuote } + "[d|" / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote } + "[t|" / { ifExtension ThQuotesBit } { token ITopenTypQuote } + + "[" @varid "|" / { ifExtension QqBit } { lex_quasiquote_tok } + + -- qualified quasi-quote (#5555) + "[" @qvarid "|" / { ifExtension QqBit } { lex_qquasiquote_tok } + + $unigraphic -- ⟦ + / { ifCurrentChar '⟦' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit } + { token (ITopenExpQuote NoE UnicodeSyntax) } + $unigraphic -- ⟧ + / { ifCurrentChar '⟧' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit } + { token (ITcloseQuote UnicodeSyntax) } +} + +<0> { + "(|" + / { ifExtension ArrowsBit `alexAndPred` + notFollowedBySymbol } + { special (IToparenbar NormalSyntax) } + "|)" + / { ifExtension ArrowsBit } + { special (ITcparenbar NormalSyntax) } + + $unigraphic -- ⦇ + / { ifCurrentChar '⦇' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit } + { special (IToparenbar UnicodeSyntax) } + $unigraphic -- ⦈ + / { ifCurrentChar '⦈' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit } + { special (ITcparenbar UnicodeSyntax) } +} + +<0> { + \? @varid / { ifExtension IpBit } { skip_one_varid ITdupipvarid } +} + +<0> { + "#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid } +} + +<0> { + "(#" / { ifExtension UnboxedTuplesBit `alexOrPred` + ifExtension UnboxedSumsBit } + { token IToubxparen } + "#)" / { ifExtension UnboxedTuplesBit `alexOrPred` + ifExtension UnboxedSumsBit } + { token ITcubxparen } +} + +<0,option_prags> { + \( { special IToparen } + \) { special ITcparen } + \[ { special ITobrack } + \] { special ITcbrack } + \, { special ITcomma } + \; { special ITsemi } + \` { special ITbackquote } + + \{ { open_brace } + \} { close_brace } +} + +<0,option_prags> { + @qdo { qdo_token ITdo } + @qmdo / { ifExtension RecursiveDoBit } { qdo_token ITmdo } + @qvarid { idtoken qvarid } + @qconid { idtoken qconid } + @varid { varid } + @conid { idtoken conid } +} + +<0> { + @qvarid "#"+ / { ifExtension MagicHashBit } { idtoken qvarid } + @qconid "#"+ / { ifExtension MagicHashBit } { idtoken qconid } + @varid "#"+ / { ifExtension MagicHashBit } { varid } + @conid "#"+ / { ifExtension MagicHashBit } { idtoken conid } +} + +-- Operators classified into prefix, suffix, tight infix, and loose infix. +-- See Note [Whitespace-sensitive operator parsing] +<0> { + @varsym / { precededByClosingToken `alexAndPred` followedByOpeningToken } { varsym_tight_infix } + @varsym / { followedByOpeningToken } { varsym_prefix } + @varsym / { precededByClosingToken } { varsym_suffix } + @varsym { varsym_loose_infix } +} + +-- ToDo: - move `var` and (sym) into lexical syntax? +-- - remove backquote from $special? +<0> { + @qvarsym { idtoken qvarsym } + @qconsym { idtoken qconsym } + @consym { consym } +} + +-- For the normal boxed literals we need to be careful +-- when trying to be close to Haskell98 + +-- Note [Lexing NumericUnderscores extension] (#14473) +-- +-- NumericUnderscores extension allows underscores in numeric literals. +-- Multiple underscores are represented with @numspc macro. +-- To be simpler, we have only the definitions with underscores. +-- And then we have a separate function (tok_integral and tok_frac) +-- that validates the literals. +-- If extensions are not enabled, check that there are no underscores. +-- +<0> { + -- Normal integral literals (:: Num a => a, from Integer) + @decimal { tok_num positive 0 0 decimal } + 0[bB] @numspc @binary / { ifExtension BinaryLiteralsBit } { tok_num positive 2 2 binary } + 0[oO] @numspc @octal { tok_num positive 2 2 octal } + 0[xX] @numspc @hexadecimal { tok_num positive 2 2 hexadecimal } + @negative @decimal / { negLitPred } { tok_num negative 1 1 decimal } + @negative 0[bB] @numspc @binary / { negLitPred `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_num negative 3 3 binary } + @negative 0[oO] @numspc @octal / { negLitPred } { tok_num negative 3 3 octal } + @negative 0[xX] @numspc @hexadecimal / { negLitPred } { tok_num negative 3 3 hexadecimal } + + -- Normal rational literals (:: Fractional a => a, from Rational) + @floating_point { tok_frac 0 tok_float } + @negative @floating_point / { negLitPred } { tok_frac 0 tok_float } + 0[xX] @numspc @hex_floating_point / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float } + @negative 0[xX] @numspc @hex_floating_point + / { ifExtension HexFloatLiteralsBit `alexAndPred` + negLitPred } { tok_frac 0 tok_hex_float } +} + +<0> { + -- Unboxed ints (:: Int#) and words (:: Word#) + -- It's simpler (and faster?) to give separate cases to the negatives, + -- especially considering octal/hexadecimal prefixes. + @decimal \# / { ifExtension MagicHashBit } { tok_primint positive 0 1 decimal } + 0[bB] @numspc @binary \# / { ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint positive 2 3 binary } + 0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 octal } + 0[xX] @numspc @hexadecimal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 hexadecimal } + @negative @decimal \# / { negHashLitPred } { tok_primint negative 1 2 decimal } + @negative 0[bB] @numspc @binary \# / { negHashLitPred `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint negative 3 4 binary } + @negative 0[oO] @numspc @octal \# / { negHashLitPred } { tok_primint negative 3 4 octal } + @negative 0[xX] @numspc @hexadecimal \# + / { negHashLitPred } { tok_primint negative 3 4 hexadecimal } + + @decimal \# \# / { ifExtension MagicHashBit } { tok_primword 0 2 decimal } + 0[bB] @numspc @binary \# \# / { ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primword 2 4 binary } + 0[oO] @numspc @octal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 octal } + 0[xX] @numspc @hexadecimal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 hexadecimal } + + -- Unboxed floats and doubles (:: Float#, :: Double#) + -- prim_{float,double} work with signed literals + @floating_point \# / { ifExtension MagicHashBit } { tok_frac 1 tok_primfloat } + @floating_point \# \# / { ifExtension MagicHashBit } { tok_frac 2 tok_primdouble } + + @negative @floating_point \# / { negHashLitPred } { tok_frac 1 tok_primfloat } + @negative @floating_point \# \# / { negHashLitPred } { tok_frac 2 tok_primdouble } +} + +-- Strings and chars are lexed by hand-written code. The reason is +-- that even if we recognise the string or char here in the regex +-- lexer, we would still have to parse the string afterward in order +-- to convert it to a String. +<0> { + \' { lex_char_tok } + \" { lex_string_tok } +} + +-- Note [Whitespace-sensitive operator parsing] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In accord with GHC Proposal #229 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst +-- we classify operator occurrences into four categories: +-- +-- a ! b -- a loose infix occurrence +-- a!b -- a tight infix occurrence +-- a !b -- a prefix occurrence +-- a! b -- a suffix occurrence +-- +-- The rules are a bit more elaborate than simply checking for whitespace, in +-- order to accommodate the following use cases: +-- +-- f (!a) = ... -- prefix occurrence +-- g (a !) -- loose infix occurrence +-- g (! a) -- loose infix occurrence +-- +-- The precise rules are as follows: +-- +-- * Identifiers, literals, and opening brackets (, (#, (|, [, [|, [||, [p|, +-- [e|, [t|, {, ⟦, ⦇, are considered "opening tokens". The function +-- followedByOpeningToken tests whether the next token is an opening token. +-- +-- * Identifiers, literals, and closing brackets ), #), |), ], |], }, ⟧, ⦈, +-- are considered "closing tokens". The function precededByClosingToken tests +-- whether the previous token is a closing token. +-- +-- * Whitespace, comments, separators, and other tokens, are considered +-- neither opening nor closing. +-- +-- * Any unqualified operator occurrence is classified as prefix, suffix, or +-- tight/loose infix, based on preceding and following tokens: +-- +-- precededByClosingToken | followedByOpeningToken | Occurrence +-- ------------------------+------------------------+------------ +-- False | True | prefix +-- True | False | suffix +-- True | True | tight infix +-- False | False | loose infix +-- ------------------------+------------------------+------------ +-- +-- A loose infix occurrence is always considered an operator. Other types of +-- occurrences may be assigned a special per-operator meaning override: +-- +-- Operator | Occurrence | Token returned +-- ----------+---------------+------------------------------------------ +-- ! | prefix | ITbang +-- | | strictness annotation or bang pattern, +-- | | e.g. f !x = rhs, data T = MkT !a +-- | not prefix | ITvarsym "!" +-- | | ordinary operator or type operator, +-- | | e.g. xs ! 3, (! x), Int ! Bool +-- ----------+---------------+------------------------------------------ +-- ~ | prefix | ITtilde +-- | | laziness annotation or lazy pattern, +-- | | e.g. f ~x = rhs, data T = MkT ~a +-- | not prefix | ITvarsym "~" +-- | | ordinary operator or type operator, +-- | | e.g. xs ~ 3, (~ x), Int ~ Bool +-- ----------+---------------+------------------------------------------ +-- $ $$ | prefix | ITdollar, ITdollardollar +-- | | untyped or typed Template Haskell splice, +-- | | e.g. $(f x), $$(f x), $$"str" +-- | not prefix | ITvarsym "$", ITvarsym "$$" +-- | | ordinary operator or type operator, +-- | | e.g. f $ g x, a $$ b +-- ----------+---------------+------------------------------------------ +-- @ | prefix | ITtypeApp +-- | | type application, e.g. fmap @Maybe +-- | tight infix | ITat +-- | | as-pattern, e.g. f p@(a,b) = rhs +-- | suffix | parse error +-- | | e.g. f p@ x = rhs +-- | loose infix | ITvarsym "@" +-- | | ordinary operator or type operator, +-- | | e.g. f @ g, (f @) +-- ----------+---------------+------------------------------------------ +-- +-- Also, some of these overrides are guarded behind language extensions. +-- According to the specification, we must determine the occurrence based on +-- surrounding *tokens* (see the proposal for the exact rules). However, in +-- the implementation we cheat a little and do the classification based on +-- characters, for reasons of both simplicity and efficiency (see +-- 'followedByOpeningToken' and 'precededByClosingToken') +-- +-- When an operator is subject to a meaning override, it is mapped to special +-- token: ITbang, ITtilde, ITat, ITdollar, ITdollardollar. Otherwise, it is +-- returned as ITvarsym. +-- +-- For example, this is how we process the (!): +-- +-- precededByClosingToken | followedByOpeningToken | Token +-- ------------------------+------------------------+------------- +-- False | True | ITbang +-- True | False | ITvarsym "!" +-- True | True | ITvarsym "!" +-- False | False | ITvarsym "!" +-- ------------------------+------------------------+------------- +-- +-- And this is how we process the (@): +-- +-- precededByClosingToken | followedByOpeningToken | Token +-- ------------------------+------------------------+------------- +-- False | True | ITtypeApp +-- True | False | parse error +-- True | True | ITat +-- False | False | ITvarsym "@" +-- ------------------------+------------------------+------------- + +-- ----------------------------------------------------------------------------- +-- Alex "Haskell code fragment bottom" + +{ + +-- ----------------------------------------------------------------------------- +-- The token type + +data Token + = ITas -- Haskell keywords + | ITcase + | ITclass + | ITdata + | ITdefault + | ITderiving + | ITdo (Maybe FastString) + | ITelse + | IThiding + | ITforeign + | ITif + | ITimport + | ITin + | ITinfix + | ITinfixl + | ITinfixr + | ITinstance + | ITlet + | ITmodule + | ITnewtype + | ITof + | ITqualified + | ITthen + | ITtype + | ITwhere + + | ITforall IsUnicodeSyntax -- GHC extension keywords + | ITexport + | ITlabel + | ITdynamic + | ITsafe + | ITinterruptible + | ITunsafe + | ITstdcallconv + | ITccallconv + | ITcapiconv + | ITprimcallconv + | ITjavascriptcallconv + | ITmdo (Maybe FastString) + | ITfamily + | ITrole + | ITgroup + | ITby + | ITusing + | ITpattern + | ITstatic + | ITstock + | ITanyclass + | ITvia + + -- Backpack tokens + | ITunit + | ITsignature + | ITdependency + | ITrequires + + -- Pragmas, see note [Pragma source text] in "GHC.Types.Basic" + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText + | ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITscc_prag SourceText + | ITgenerated_prag SourceText + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText + | ITcomplete_prag SourceText + | ITclose_prag + | IToptions_prag String + | ITinclude_prag String + | ITlanguage_prag + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText + | ITcomment_line_prag -- See Note [Nested comment line pragmas] + + | ITdotdot -- reserved symbols + | ITcolon + | ITdcolon IsUnicodeSyntax + | ITequal + | ITlam + | ITlcase + | ITvbar + | ITlarrow IsUnicodeSyntax + | ITrarrow IsUnicodeSyntax + | ITdarrow IsUnicodeSyntax + | ITlolly -- The (⊸) arrow (for LinearTypes) + | ITminus -- See Note [Minus tokens] + | ITprefixminus -- See Note [Minus tokens] + | ITbang -- Prefix (!) only, e.g. f !x = rhs + | ITtilde -- Prefix (~) only, e.g. f ~x = rhs + | ITat -- Tight infix (@) only, e.g. f x@pat = rhs + | ITtypeApp -- Prefix (@) only, e.g. f @t + | ITpercent -- Prefix (%) only, e.g. a %1 -> b + | ITstar IsUnicodeSyntax + | ITdot + + | ITbiglam -- GHC-extension symbols + + | ITocurly -- special symbols + | ITccurly + | ITvocurly + | ITvccurly + | ITobrack + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITcbrack + | IToparen + | ITcparen + | IToubxparen + | ITcubxparen + | ITsemi + | ITcomma + | ITunderscore + | ITbackquote + | ITsimpleQuote -- ' + + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) + + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITlabelvarid FastString -- Overloaded label: #x + + | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.Basic" + | ITstring SourceText FastString -- Note [Literal source text] in "GHC.Types.Basic" + | ITinteger IntegralLit -- Note [Literal source text] in "GHC.Types.Basic" + | ITrational FractionalLit + + | ITprimchar SourceText Char -- Note [Literal source text] in "GHC.Types.Basic" + | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.Basic" + | ITprimint SourceText Integer -- Note [Literal source text] in "GHC.Types.Basic" + | ITprimword SourceText Integer -- Note [Literal source text] in "GHC.Types.Basic" + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit + + -- Template Haskell extension tokens + | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote IsUnicodeSyntax -- |] + | ITopenTExpQuote HasE -- [|| or [e|| + | ITcloseTExpQuote -- ||] + | ITdollar -- prefix $ + | ITdollardollar -- prefix $$ + | ITtyQuote -- '' + | ITquasiQuote (FastString,FastString,PsSpan) + -- ITquasiQuote(quoter, quote, loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,FastString,PsSpan) + -- ITqQuasiQuote(Qual, quoter, quote, loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] + + -- Arrow notation extension + | ITproc + | ITrec + | IToparenbar IsUnicodeSyntax -- ^ @(|@ + | ITcparenbar IsUnicodeSyntax -- ^ @|)@ + | ITlarrowtail IsUnicodeSyntax -- ^ @-<@ + | ITrarrowtail IsUnicodeSyntax -- ^ @>-@ + | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ + | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ + + | ITunknown String -- ^ Used when the lexer can't make sense of it + | ITeof -- ^ end of file token + + -- Documentation annotations + | ITdocCommentNext String -- ^ something beginning @-- |@ + | ITdocCommentPrev String -- ^ something beginning @-- ^@ + | ITdocCommentNamed String -- ^ something beginning @-- $@ + | ITdocSection Int String -- ^ a section heading + | ITdocOptions String -- ^ doc options (prune, ignore-exports, etc) + | ITlineComment String -- ^ comment starting by "--" + | ITblockComment String -- ^ comment in {- -} + + deriving Show + +instance Outputable Token where + ppr x = text (show x) + + +{- Note [Minus tokens] +~~~~~~~~~~~~~~~~~~~~~~ +A minus sign can be used in prefix form (-x) and infix form (a - b). + +When LexicalNegation is on: + * ITprefixminus represents the prefix form + * ITvarsym "-" represents the infix form + * ITminus is not used + +When LexicalNegation is off: + * ITminus represents all forms + * ITprefixminus is not used + * ITvarsym "-" is not used +-} + +{- Note [Why not LexicalNegationBit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One might wonder why we define NoLexicalNegationBit instead of +LexicalNegationBit. The problem lies in the following line in reservedSymsFM: + + ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) + +We want to generate ITminus only when LexicalNegation is off. How would one +do it if we had LexicalNegationBit? I (int-index) tried to use bitwise +complement: + + ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit)) + +This did not work, so I opted for NoLexicalNegationBit instead. +-} + + +-- the bitmap provided as the third component indicates whether the +-- corresponding extension keyword is valid under the extension options +-- provided to the compiler; if the extension corresponding to *any* of the +-- bits set in the bitmap is enabled, the keyword is valid (this setup +-- facilitates using a keyword in two different extensions that can be +-- activated independently) +-- +reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap) +reservedWordsFM = listToUFM $ + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo Nothing, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + + ( "forall", ITforall NormalSyntax, 0), + ( "mdo", ITmdo Nothing, xbit RecursiveDoBit), + -- See Note [Lexing type pseudo-keywords] + ( "family", ITfamily, 0 ), + ( "role", ITrole, 0 ), + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "static", ITstatic, xbit StaticPointersBit ), + ( "stock", ITstock, 0 ), + ( "anyclass", ITanyclass, 0 ), + ( "via", ITvia, 0 ), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "unit", ITunit, 0 ), + ( "dependency", ITdependency, 0 ), + ( "signature", ITsignature, 0 ), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit) + ] + +{----------------------------------- +Note [Lexing type pseudo-keywords] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One might think that we wish to treat 'family' and 'role' as regular old +varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. +But, there is no need to do so. These pseudo-keywords are not stolen syntax: +they are only used after the keyword 'type' at the top-level, where varids are +not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that +type families and role annotations are never declared without their extensions +on. In fact, by unconditionally lexing these pseudo-keywords as special, we +can get better error messages. + +Also, note that these are included in the `varid` production in the parser -- +a key detail to make all this work. +-------------------------------------} + +reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap) +reservedSymsFM = listToUFM $ + map (\ (x,w,y,z) -> (mkFastString x,(w,y,z))) + [ ("..", ITdotdot, NormalSyntax, 0 ) + -- (:) is a reserved op, meaning only list cons + ,(":", ITcolon, NormalSyntax, 0 ) + ,("::", ITdcolon NormalSyntax, NormalSyntax, 0 ) + ,("=", ITequal, NormalSyntax, 0 ) + ,("\\", ITlam, NormalSyntax, 0 ) + ,("|", ITvbar, NormalSyntax, 0 ) + ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) + ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) + ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) + ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) + + ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) + + -- For 'forall a . t' + ,(".", ITdot, NormalSyntax, 0 ) + + ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">>-", ITRarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + + ,("∷", ITdcolon UnicodeSyntax, UnicodeSyntax, 0 ) + ,("⇒", ITdarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("∀", ITforall UnicodeSyntax, UnicodeSyntax, 0 ) + ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) + + ,("⊸", ITlolly, UnicodeSyntax, 0) + + ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤜", ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + + ,("★", ITstar UnicodeSyntax, UnicodeSyntax, xbit StarIsTypeBit) + + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot + -- form part of a large operator. This would let us have a better + -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). + ] + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = PsSpan -> StringBuffer -> Int -> P (PsLocated Token) + +special :: Token -> Action +special tok span _buf _len = return (L span tok) + +token, layout_token :: Token -> Action +token t span _buf _len = return (L span t) +layout_token t span _buf _len = pushLexState layout >> return (L span t) + +idtoken :: (StringBuffer -> Int -> Token) -> Action +idtoken f span buf len = return (L span $! (f buf len)) + +qdo_token :: (Maybe FastString -> Token) -> Action +qdo_token con span buf len = do + maybe_layout token + return (L span $! token) + where + !token = con $! Just $! fst $! splitQualName buf len False + +skip_one_varid :: (FastString -> Token) -> Action +skip_one_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) + +skip_two_varid :: (FastString -> Token) -> Action +skip_two_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) + +strtoken :: (String -> Token) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +begin :: Int -> Action +begin code _span _str _len = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len = do _ <- popLexState + lexToken +-- See Note [Nested comment line pragmas] +failLinePrag1 :: Action +failLinePrag1 span _buf _len = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) + else lexError "lexical error in pragma" + +-- See Note [Nested comment line pragmas] +popLinePrag1 :: Action +popLinePrag1 span _buf _len = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + _ <- popLexState + lexToken + +hopefully_open_brace :: Action +hopefully_open_brace span buf len + = do relaxed <- getBit RelaxedLayoutBit + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol (psRealLoc l) + isOK = relaxed || + case ctx of + Layout prev_off _ : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len + else addFatalError (mkSrcSpanPs span) (text "Missing block") + +pop_and :: Action -> Action +pop_and act span buf len = do _ <- popLexState + act span buf len + +-- See Note [Whitespace-sensitive operator parsing] +followedByOpeningToken :: AlexAccPred ExtsBitmap +followedByOpeningToken _ _ _ (AI _ buf) + | atEnd buf = False + | otherwise = + case nextChar buf of + ('{', buf') -> nextCharIsNot buf' (== '-') + ('(', _) -> True + ('[', _) -> True + ('\"', _) -> True + ('\'', _) -> True + ('_', _) -> True + ('⟦', _) -> True + ('⦇', _) -> True + (c, _) -> isAlphaNum c + +-- See Note [Whitespace-sensitive operator parsing] +precededByClosingToken :: AlexAccPred ExtsBitmap +precededByClosingToken _ (AI _ buf) _ _ = + case prevChar buf '\n' of + '}' -> decodePrevNChars 1 buf /= "-" + ')' -> True + ']' -> True + '\"' -> True + '\'' -> True + '_' -> True + '⟧' -> True + '⦈' -> True + c -> isAlphaNum c + +{-# INLINE nextCharIs #-} +nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIs buf p = not (atEnd buf) && p (currentChar buf) + +{-# INLINE nextCharIsNot #-} +nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIsNot buf p = not (nextCharIs buf p) + +notFollowedBy :: Char -> AlexAccPred ExtsBitmap +notFollowedBy char _ _ _ (AI _ buf) + = nextCharIsNot buf (== char) + +notFollowedBySymbol :: AlexAccPred ExtsBitmap +notFollowedBySymbol _ _ _ (AI _ buf) + = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") + +followedByDigit :: AlexAccPred ExtsBitmap +followedByDigit _ _ _ (AI _ buf) + = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) + +ifCurrentChar :: Char -> AlexAccPred ExtsBitmap +ifCurrentChar char _ (AI _ buf) _ _ + = nextCharIs buf (== char) + +-- We must reject doc comments as being ordinary comments everywhere. +-- In some cases the doc comment will be selected as the lexeme due to +-- maximal munch, but not always, because the nested comment rule is +-- valid in all states, but the doc-comment rules are only valid in +-- the non-layout states. +isNormalComment :: AlexAccPred ExtsBitmap +isNormalComment bits _ _ (AI _ buf) + | HaddockBit `xtest` bits = notFollowedByDocOrPragma + | otherwise = nextCharIsNot buf (== '#') + where + notFollowedByDocOrPragma + = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) + +afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool +afterOptionalSpace buf p + = if nextCharIs buf (== ' ') + then p (snd (nextChar buf)) + else p buf + +atEOL :: AlexAccPred ExtsBitmap +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' + +-- Check if we should parse a negative literal (e.g. -123) as a single token. +negLitPred :: AlexAccPred ExtsBitmap +negLitPred = + prefix_minus `alexAndPred` + (negative_literals `alexOrPred` lexical_negation) + where + negative_literals = ifExtension NegativeLiteralsBit + + lexical_negation = + -- See Note [Why not LexicalNegationBit] + alexNotPred (ifExtension NoLexicalNegationBit) + + prefix_minus = + -- Note [prefix_minus in negLitPred and negHashLitPred] + alexNotPred precededByClosingToken + +-- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token. +negHashLitPred :: AlexAccPred ExtsBitmap +negHashLitPred = prefix_minus `alexAndPred` magic_hash + where + magic_hash = ifExtension MagicHashBit + prefix_minus = + -- Note [prefix_minus in negLitPred and negHashLitPred] + alexNotPred precededByClosingToken + +{- Note [prefix_minus in negLitPred and negHashLitPred] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to parse -1 as a single token, but x-1 as three tokens. +So in negLitPred (and negHashLitPred) we require that we have a prefix +occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing] +for a detailed definition of a prefix occurrence. + +The condition for a prefix occurrence of an operator is: + + not precededByClosingToken && followedByOpeningToken + +but we don't check followedByOpeningToken when parsing a negative literal. +It holds simply because we immediately lex a literal after the minus. +-} + +ifExtension :: ExtBits -> AlexAccPred ExtsBitmap +ifExtension extBits bits _ _ _ = extBits `xtest` bits + +alexNotPred p userState in1 len in2 + = not (p userState in1 len in2) + +alexOrPred p1 p2 userState in1 len in2 + = p1 userState in1 len in2 || p2 userState in1 len in2 + +multiline_doc_comment :: Action +multiline_doc_comment span buf _len = withLexedDocType (worker "") + where + worker commentAcc input docType checkNextLine = case alexGetChar' input of + Just ('\n', input') + | checkNextLine -> case checkIfCommentLine input' of + Just input -> worker ('\n':commentAcc) input docType checkNextLine + Nothing -> docCommentEnd input commentAcc docType buf span + | otherwise -> docCommentEnd input commentAcc docType buf span + Just (c, input) -> worker (c:commentAcc) input docType checkNextLine + Nothing -> docCommentEnd input commentAcc docType buf span + + -- Check if the next line of input belongs to this doc comment as well. + -- A doc comment continues onto the next line when the following + -- conditions are met: + -- * The line starts with "--" + -- * The line doesn't start with "---". + -- * The line doesn't start with "-- $", because that would be the + -- start of a /new/ named haddock chunk (#10398). + checkIfCommentLine :: AlexInput -> Maybe AlexInput + checkIfCommentLine input = check (dropNonNewlineSpace input) + where + check input = do + ('-', input) <- alexGetChar' input + ('-', input) <- alexGetChar' input + (c, after_c) <- alexGetChar' input + case c of + '-' -> Nothing + ' ' -> case alexGetChar' after_c of + Just ('$', _) -> Nothing + _ -> Just input + _ -> Just input + + dropNonNewlineSpace input = case alexGetChar' input of + Just (c, input') + | isSpace c && c /= '\n' -> dropNonNewlineSpace input' + | otherwise -> input + Nothing -> input + +lineCommentToken :: Action +lineCommentToken span buf len = do + b <- getBit RawTokenStreamBit + if b then strtoken ITlineComment span buf len else lexToken + +{- + nested comments require traversing by hand, they can't be parsed + using regular expressions. +-} +nested_comment :: P (PsLocated Token) -> Action +nested_comment cont span buf len = do + input <- getInput + go (reverse $ lexemeToString buf len) (1::Int) input + where + go commentAcc 0 input = do + let finalizeComment str = (Nothing, ITblockComment str) + commentEnd cont input commentAcc finalizeComment buf span + go commentAcc n input = case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' + Just (_,_) -> go ('-':commentAcc) n input + Just ('\123',input) -> case alexGetChar' input of -- '{' char + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input + Just (_,_) -> go ('\123':commentAcc) n input + -- See Note [Nested comment line pragmas] + Just ('\n',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input + go (parsedAcc ++ '\n':commentAcc) n input + Just (_,_) -> go ('\n':commentAcc) n input + Just (c,input) -> go (c:commentAcc) n input + +nested_doc_comment :: Action +nested_doc_comment span buf _len = withLexedDocType (go "") + where + go commentAcc input docType _ = case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('\125',input) -> + docCommentEnd input commentAcc docType buf span + Just (_,_) -> go ('-':commentAcc) input docType False + Just ('\123', input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> do + setInput input + let cont = do input <- getInput; go commentAcc input docType False + nested_comment cont span buf _len + Just (_,_) -> go ('\123':commentAcc) input docType False + -- See Note [Nested comment line pragmas] + Just ('\n',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input + go (parsedAcc ++ '\n':commentAcc) input docType False + Just (_,_) -> go ('\n':commentAcc) input docType False + Just (c,input) -> go (c:commentAcc) input docType False + +-- See Note [Nested comment line pragmas] +parseNestedPragma :: AlexInput -> P (String,AlexInput) +parseNestedPragma input@(AI _ buf) = do + origInput <- getInput + setInput input + setExts (.|. xbit InNestedCommentBit) + pushLexState bol + lt <- lexToken + _ <- popLexState + setExts (.&. complement (xbit InNestedCommentBit)) + postInput@(AI _ postBuf) <- getInput + setInput origInput + case unLoc lt of + ITcomment_line_prag -> do + let bytes = byteDiff buf postBuf + diff = lexemeToString buf bytes + return (reverse diff, postInput) + lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt')) + +{- +Note [Nested comment line pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to ignore cpp-preprocessor-generated #line pragmas if they were inside +nested comments. + +Now, when parsing a nested comment, if we encounter a line starting with '#' we +call parseNestedPragma, which executes the following: +1. Save the current lexer input (loc, buf) for later +2. Set the current lexer input to the beginning of the line starting with '#' +3. Turn the 'InNestedComment' extension on +4. Push the 'bol' lexer state +5. Lex a token. Due to (2), (3), and (4), this should always lex a single line + or less and return the ITcomment_line_prag token. This may set source line + and file location if a #line pragma is successfully parsed +6. Restore lexer input and state to what they were before we did all this +7. Return control to the function parsing a nested comment, informing it of + what the lexer parsed + +Regarding (5) above: +Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1) +checks if the 'InNestedComment' extension is set. If it is, that function will +return control to parseNestedPragma by returning the ITcomment_line_prag token. + +See #314 for more background on the bug this fixes. +-} + +withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) + -> P (PsLocated Token) +withLexedDocType lexDocComment = do + input@(AI _ buf) <- getInput + case prevChar buf ' ' of + -- The `Bool` argument to lexDocComment signals whether or not the next + -- line of input might also belong to this doc comment. + '|' -> lexDocComment input mkHdkCommentNext True + '^' -> lexDocComment input mkHdkCommentPrev True + '$' -> lexDocComment input mkHdkCommentNamed True + '*' -> lexDocSection 1 input + _ -> panic "withLexedDocType: Bad doc type" + where + lexDocSection n input = case alexGetChar' input of + Just ('*', input) -> lexDocSection (n+1) input + Just (_, _) -> lexDocComment input (mkHdkCommentSection n) False + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + +mkHdkCommentNext, mkHdkCommentPrev :: String -> (HdkComment, Token) +mkHdkCommentNext str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str) +mkHdkCommentPrev str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str) + +mkHdkCommentNamed :: String -> (HdkComment, Token) +mkHdkCommentNamed str = + let (name, rest) = break isSpace str + in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str) + +mkHdkCommentSection :: Int -> String -> (HdkComment, Token) +mkHdkCommentSection n str = + (HdkCommentSection n (mkHsDocString str), ITdocSection n str) + +-- RULES pragmas turn on the forall and '.' keywords, and we turn them +-- off again at the end of the pragma. +rulePrag :: Action +rulePrag span buf len = do + setExts (.|. xbit InRulePragBit) + let !src = lexemeToString buf len + return (L span (ITrules_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +linePrag :: Action +linePrag span buf len = do + usePosPrags <- getBit UsePosPragsBit + if usePosPrags + then begin line_prag2 span buf len + else let !src = lexemeToString buf len + in return (L span (ITline_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +columnPrag :: Action +columnPrag span buf len = do + usePosPrags <- getBit UsePosPragsBit + let !src = lexemeToString buf len + if usePosPrags + then begin column_prag span buf len + else let !src = lexemeToString buf len + in return (L span (ITcolumn_prag (SourceText src))) + +endPrag :: Action +endPrag span _buf _len = do + setExts (.&. complement (xbit InRulePragBit)) + return (L span ITclose_prag) + +-- docCommentEnd +------------------------------------------------------------------------------- +-- This function is quite tricky. We can't just return a new token, we also +-- need to update the state of the parser. Why? Because the token is longer +-- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- it writes the wrong token length to the parser state. This function is +-- called afterwards, so it can just update the state. + +commentEnd :: P (PsLocated Token) + -> AlexInput + -> String + -> (String -> (Maybe HdkComment, Token)) + -> StringBuffer + -> PsSpan + -> P (PsLocated Token) +commentEnd cont input commentAcc finalizeComment buf span = do + setInput input + let (AI loc nextBuf) = input + comment = reverse commentAcc + span' = mkPsSpan (psSpanStart span) loc + last_len = byteDiff buf nextBuf + span `seq` setLastToken span' last_len + let (m_hdk_comment, hdk_token) = finalizeComment comment + whenIsJust m_hdk_comment $ \hdk_comment -> + P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) () + b <- getBit RawTokenStreamBit + if b then return (L span' hdk_token) + else cont + +docCommentEnd :: AlexInput -> String -> (String -> (HdkComment, Token)) -> StringBuffer -> + PsSpan -> P (PsLocated Token) +docCommentEnd input commentAcc docType buf span = do + let finalizeComment str = + let (hdk_comment, token) = docType str + in (Just hdk_comment, token) + commentEnd lexToken input commentAcc finalizeComment buf span + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) "unterminated `{-'" + +open_brace, close_brace :: Action +open_brace span _str _len = do + ctx <- getContext + setContext (NoLayout:ctx) + return (L span ITocurly) +close_brace span _str _len = do + popContext + return (L span ITccurly) + +qvarid, qconid :: StringBuffer -> Int -> Token +qvarid buf len = ITqvarid $! splitQualName buf len False +qconid buf len = ITqconid $! splitQualName buf len False + +splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) +-- takes a StringBuffer and a length, and returns the module name +-- and identifier parts of a qualified name. Splits at the *last* dot, +-- because of hierarchical module names. +-- +-- Throws an error if the name is not qualified. +splitQualName orig_buf len parens = split orig_buf orig_buf + where + split buf dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf + where + (c,buf') = nextChar buf + + -- careful, we might get names like M.... + -- so, if the character after the dot is not upper-case, this is + -- the end of the qualifier part. + found_dot buf -- buf points after the '.' + | isUpper c = split buf' buf + | otherwise = done buf + where + (c,buf') = nextChar buf + + done dot_buf + | qual_size < 1 = error "splitQualName got an unqualified named" + | otherwise = + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) + then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) + else lexemeToFastString dot_buf (len - qual_size)) + where + qual_size = orig_buf `byteDiff` dot_buf + +varid :: Action +varid span buf len = + case lookupUFM reservedWordsFM fs of + Just (ITcase, _) -> do + lastTk <- getLastTk + keyword <- case lastTk of + Just ITlam -> do + lambdaCase <- getBit LambdaCaseBit + unless lambdaCase $ do + pState <- getPState + addError (mkSrcSpanPs (last_loc pState)) $ text + "Illegal lambda-case (use LambdaCase)" + return ITlcase + _ -> return ITcase + maybe_layout keyword + return $ L span keyword + Just (keyword, 0) -> do + maybe_layout keyword + return $ L span keyword + Just (keyword, i) -> do + exts <- getExts + if exts .&. i /= 0 + then do + maybe_layout keyword + return $ L span keyword + else + return $ L span $ ITvarid fs + Nothing -> + return $ L span $ ITvarid fs + where + !fs = lexemeToFastString buf len + +conid :: StringBuffer -> Int -> Token +conid buf len = ITconid $! lexemeToFastString buf len + +qvarsym, qconsym :: StringBuffer -> Int -> Token +qvarsym buf len = ITqvarsym $! splitQualName buf len False +qconsym buf len = ITqconsym $! splitQualName buf len False + +-- See Note [Whitespace-sensitive operator parsing] +varsym_prefix :: Action +varsym_prefix = sym $ \exts s -> + if | s == fsLit "@" -- regardless of TypeApplications for better error messages + -> return ITtypeApp + | LinearTypesBit `xtest` exts, s == fsLit "%" + -> return ITpercent + | ThQuotesBit `xtest` exts, s == fsLit "$" + -> return ITdollar + | ThQuotesBit `xtest` exts, s == fsLit "$$" + -> return ITdollardollar + | s == fsLit "-" -- Only when LexicalNegation is on, otherwise we get ITminus and + -- don't hit this code path. See Note [Minus tokens] + -> return ITprefixminus + | s == fsLit "!" -> return ITbang + | s == fsLit "~" -> return ITtilde + | otherwise -> return (ITvarsym s) + +-- See Note [Whitespace-sensitive operator parsing] +varsym_suffix :: Action +varsym_suffix = sym $ \_ s -> + if | s == fsLit "@" + -> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace." + | otherwise -> return (ITvarsym s) + +-- See Note [Whitespace-sensitive operator parsing] +varsym_tight_infix :: Action +varsym_tight_infix = sym $ \_ s -> + if | s == fsLit "@" -> return ITat + | otherwise -> return (ITvarsym s) + +-- See Note [Whitespace-sensitive operator parsing] +varsym_loose_infix :: Action +varsym_loose_infix = sym (\_ s -> return $ ITvarsym s) + +consym :: Action +consym = sym (\_exts s -> return $ ITconsym s) + +sym :: (ExtsBitmap -> FastString -> P Token) -> Action +sym con span buf len = + case lookupUFM reservedSymsFM fs of + Just (keyword, NormalSyntax, 0) -> + return $ L span keyword + Just (keyword, NormalSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 + then return $ L span keyword + else L span <$!> con exts fs + Just (keyword, UnicodeSyntax, 0) -> do + exts <- getExts + if xtest UnicodeSyntaxBit exts + then return $ L span keyword + else L span <$!> con exts fs + Just (keyword, UnicodeSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts + then return $ L span keyword + else L span <$!> con exts fs + Nothing -> do + exts <- getExts + L span <$!> con exts fs + where + !fs = lexemeToFastString buf len + +-- Variations on the integral numeric literal. +tok_integral :: (SourceText -> Integer -> Token) + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToString buf len + when ((not numericUnderscores) && ('_' `elem` src)) $ do + pState <- getPState + addError (mkSrcSpanPs (last_loc pState)) $ text + "Use NumericUnderscores to allow underscores in integer literals" + return $ L span $ itint (SourceText src) + $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + +tok_num :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_num = tok_integral $ \case + st@(SourceText ('-':_)) -> itint st (const True) + st@(SourceText _) -> itint st (const False) + st@NoSourceText -> itint st (< 0) + where + itint :: SourceText -> (Integer -> Bool) -> Integer -> Token + itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val) + +tok_primint :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primint = tok_integral ITprimint + + +tok_primword :: Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primword = tok_integral ITprimword positive +positive, negative :: (Integer -> Integer) +positive = id +negative = negate +decimal, octal, hexadecimal :: (Integer, Char -> Int) +decimal = (10,octDecDigit) +binary = (2,octDecDigit) +octal = (8,octDecDigit) +hexadecimal = (16,hexDigit) + +-- readRational can understand negative rationals, exponents, everything. +tok_frac :: Int -> (String -> Token) -> Action +tok_frac drop f span buf len = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToString buf (len-drop) + when ((not numericUnderscores) && ('_' `elem` src)) $ do + pState <- getPState + addError (mkSrcSpanPs (last_loc pState)) $ text + "Use NumericUnderscores to allow underscores in floating literals" + return (L span $! (f $! src)) + +tok_float, tok_primfloat, tok_primdouble :: String -> Token +tok_float str = ITrational $! readFractionalLit str +tok_hex_float str = ITrational $! readHexFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str + where is_neg = case str of ('-':_) -> True + _ -> False +readHexFractionalLit :: String -> FractionalLit +readHexFractionalLit str = + FL { fl_text = SourceText str + , fl_neg = case str of + '-' : _ -> True + _ -> False + , fl_value = readHexRational str + } + +-- ----------------------------------------------------------------------------- +-- Layout processing + +-- we're at the first token on a line, insert layout tokens if necessary +do_bol :: Action +do_bol span _str _len = do + -- See Note [Nested comment line pragmas] + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + (pos, gen_semic) <- getOffside + case pos of + LT -> do + --trace "layout: inserting '}'" $ do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ | gen_semic -> do + --trace "layout: inserting ';'" $ do + _ <- popLexState + return (L span ITsemi) + _ -> do + _ <- popLexState + lexToken + +-- certain keywords put us in the "layout" state, where we might +-- add an opening curly brace. +maybe_layout :: Token -> P () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- getBit AlternativeLayoutRuleBit + unless alr $ f t + where f (ITdo _) = pushLexState layout_do + f (ITmdo _) = pushLexState layout_do + f ITof = pushLexState layout + f ITlcase = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f ITif = pushLexState layout_if + f _ = return () + +-- Pushing a new implicit layout context. If the indentation of the +-- next token is not greater than the previous layout context, then +-- Haskell 98 says that the new layout context should be empty; that is +-- the lexer must generate {}. +-- +-- We are slightly more lenient than this: when the new context is started +-- by a 'do', then we allow the new context to be at the same indentation as +-- the previous context. This is what the 'strict' argument is for. +new_layout_context :: Bool -> Bool -> Token -> Action +new_layout_context strict gen_semic tok span _buf len = do + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol (psRealLoc l) - len + ctx <- getContext + nondecreasing <- getBit NondecreasingIndentationBit + let strict' = strict || not nondecreasing + case ctx of + Layout prev_off _ : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span tok) + _ -> do setContext (Layout offset gen_semic : ctx) + return (L span tok) + +do_layout_left :: Action +do_layout_left span _buf _len = do + _ <- popLexState + pushLexState bol -- we must be at the start of a line + return (L span ITvccurly) + +-- ----------------------------------------------------------------------------- +-- LINE pragmas + +setLineAndFile :: Int -> Action +setLineAndFile code (PsSpan span _) buf len = do + let src = lexemeToString buf (len - 1) -- drop trailing quotation mark + linenumLen = length $ head $ words src + linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit + file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src + -- skip everything through first quotation mark to get to the filename + where go ('\\':c:cs) = c : go cs + go (c:cs) = c : go cs + go [] = [] + -- decode escapes in the filename. e.g. on Windows + -- when our filenames have backslashes in, gcc seems to + -- escape the backslashes. One symptom of not doing this + -- is that filenames in error messages look a bit strange: + -- C:\\foo\bar.hs + -- only the first backslash is doubled, because we apply + -- System.FilePath.normalise before printing out + -- filenames and it does not remove duplicate + -- backslashes after the drive letter (should it?). + resetAlrLastLoc file + setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) + -- subtract one: the line number refers to the *following* line + addSrcFile file + _ <- popLexState + pushLexState code + lexToken + +setColumn :: Action +setColumn (PsSpan span _) buf len = do + let column = + case reads (lexemeToString buf len) of + [(column, _)] -> column + _ -> error "setColumn: expected integer" -- shouldn't happen + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) + (fromIntegral (column :: Integer))) + _ <- popLexState + lexToken + +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) + +-- ----------------------------------------------------------------------------- +-- Options, includes and language pragmas. + +lex_string_prag :: (String -> Token) -> Action +lex_string_prag mkTok span _buf _len + = do input <- getInput + start <- getParsedLoc + tok <- go [] input + end <- getParsedLoc + return (L (mkPsSpan start end) tok) + where go acc input + = if isString input "#-}" + then do setInput input + return (mkTok (reverse acc)) + else case alexGetChar input of + Just (c,i) -> go (c:acc) i + Nothing -> err input + isString _ [] = True + isString i (x:xs) + = case alexGetChar i of + Just (c,i') | c == x -> isString i' xs + _other -> False + err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) "unterminated options pragma" + + +-- ----------------------------------------------------------------------------- +-- Strings & Chars + +-- This stuff is horrible. I hates it. + +lex_string_tok :: Action +lex_string_tok span buf _len = do + tok <- lex_string "" + (AI end bufEnd) <- getInput + let + tok' = case tok of + ITprimstring _ bs -> ITprimstring (SourceText src) bs + ITstring _ s -> ITstring (SourceText src) s + _ -> panic "lex_string_tok" + src = lexemeToString buf (cur bufEnd - cur buf) + return (L (mkPsSpan (psSpanStart span) end) tok') + +lex_string :: String -> P Token +lex_string s = do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i + + Just ('"',i) -> do + setInput i + let s' = reverse s + magicHash <- getBit MagicHashBit + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + when (any (> '\xFF') s') $ do + pState <- getPState + addError (mkSrcSpanPs (last_loc pState)) $ text + "primitive string literal must contain only characters <= \'\\xFF\'" + return (ITprimstring (SourceText s') (unsafeMkByteString s')) + _other -> + return (ITstring (SourceText s') (mkFastString s')) + else + return (ITstring (SourceText s') (mkFastString s')) + + Just ('\\',i) + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + -- is_space only works for <= '\x7f' (#3751, #5425) + setInput i; lex_stringgap s + where next = alexGetChar' i + + Just (c, i1) -> do + case c of + '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) + c | isAny c -> do setInput i1; lex_string (c:s) + _other -> lit_error i + +lex_stringgap :: String -> P Token +lex_stringgap s = do + i <- getInput + c <- getCharOrFail i + case c of + '\\' -> lex_string s + c | c <= '\x7f' && is_space c -> lex_stringgap s + -- is_space only works for <= '\x7f' (#3751, #5425) + _other -> lit_error i + + +lex_char_tok :: Action +-- Here we are basically parsing character literals, such as 'x' or '\n' +-- but we additionally spot 'x and ''T, returning ITsimpleQuote and +-- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part +-- (the parser does that). +-- So we have to do two characters of lookahead: when we see 'x we need to +-- see if there's a trailing quote +lex_char_tok span buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character + let loc = psSpanStart span + case alexGetChar' i1 of + Nothing -> lit_error i1 + + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + setInput i2 + return (L (mkPsSpan loc end2) ITtyQuote) + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape + i3 <- getInput + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok buf loc lit_ch + else lit_error i3 + + Just (c, i2@(AI _end2 _)) + | not (isAny c) -> lit_error i1 + | otherwise -> + + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok buf loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- Just parse the quote only + let (AI end _) = i1 + return (L (mkPsSpan loc end) ITsimpleQuote) + +finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token) +finish_char_tok buf loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- getBit MagicHashBit + i@(AI end bufEnd) <- getInput + let src = lexemeToString buf (cur bufEnd - cur buf) + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkPsSpan loc end) + (ITprimchar (SourceText src) ch)) + _other -> + return (L (mkPsSpan loc end) + (ITchar (SourceText src) ch)) + else do + return (L (mkPsSpan loc end) (ITchar (SourceText src) ch)) + +isAny :: Char -> Bool +isAny c | c > '\x7f' = isPrint c + | otherwise = is_any c + +lex_escape :: P Char +lex_escape = do + i0 <- getInput + c <- getCharOrFail i0 + case c of + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput + c <- getCharOrFail i1 + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> + case alexGetChar' i2 of + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 + +readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char +readNum is_digit base conv = do + i <- getInput + c <- getCharOrFail i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i + +readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char +readNum2 is_digit base conv i = do + input <- getInput + read i input + where read i input = do + case alexGetChar' input of + Just (c,input') | is_digit c -> do + let i' = i*base + conv c + if i' > 0x10ffff + then setInput input >> lexError "numeric escape sequence out of range" + else read i' input' + _other -> do + setInput input; return (chr i) + + +silly_escape_chars :: [(String, Char)] +silly_escape_chars = [ + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] + +-- before calling lit_error, ensure that the current input is pointing to +-- the position of the error in the buffer. This is so that we can report +-- a correct location to the user, but also so we can detect UTF-8 decoding +-- errors if they occur. +lit_error :: AlexInput -> P a +lit_error i = do setInput i; lexError "lexical error in string/character literal" + +getCharOrFail :: AlexInput -> P Char +getCharOrFail i = do + case alexGetChar' i of + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c + +-- ----------------------------------------------------------------------------- +-- QuasiQuote + +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getParsedLoc + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + mkFastString (reverse quote), + mkPsSpan quoteStart end))) + +lex_quasiquote_tok :: Action +lex_quasiquote_tok span buf len = do + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getParsedLoc + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) + (ITquasiQuote (mkFastString quoter, + mkFastString (reverse quote), + mkPsSpan quoteStart end))) + +lex_quasiquote :: RealSrcLoc -> String -> P String +lex_quasiquote start s = do + i <- getInput + case alexGetChar' i of + Nothing -> quasiquote_error start + + -- NB: The string "|]" terminates the quasiquote, + -- with absolutely no escaping. See the extensive + -- discussion on #5348 for why there is no + -- escape handling. + Just ('|',i) + | Just (']',i) <- alexGetChar' i + -> do { setInput i; return s } + + Just (c, i) -> do + setInput i; lex_quasiquote start (c : s) + +quasiquote_error :: RealSrcLoc -> P a +quasiquote_error start = do + (AI end buf) <- getInput + reportLexError start (psRealLoc end) buf "unterminated quasiquotation" + +-- ----------------------------------------------------------------------------- +-- Warnings + +warnTab :: Action +warnTab srcspan _buf _len = do + addTabWarning (psRealSpan srcspan) + lexToken + +warnThen :: WarningFlag -> SDoc -> Action -> Action +warnThen option warning action srcspan buf len = do + addWarning option (RealSrcSpan (psRealSpan srcspan) Nothing) warning + action srcspan buf len + +-- ----------------------------------------------------------------------------- +-- The Parse Monad + +-- | Do we want to generate ';' layout tokens? In some cases we just want to +-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates +-- alternatives (unlike a `case` expression where we need ';' to as a separator +-- between alternatives). +type GenSemic = Bool + +generateSemic, dontGenerateSemic :: GenSemic +generateSemic = True +dontGenerateSemic = False + +data LayoutContext + = NoLayout + | Layout !Int !GenSemic + deriving Show + +-- | The result of running a parser. +data ParseResult a + = POk -- ^ The parser has consumed a (possibly empty) prefix + -- of the input and produced a result. Use 'getMessages' + -- to check for accumulated warnings and non-fatal errors. + PState -- ^ The resulting parsing state. Can be used to resume parsing. + a -- ^ The resulting value. + | PFailed -- ^ The parser has consumed a (possibly empty) prefix + -- of the input and failed. + PState -- ^ The parsing state right before failure, including the fatal + -- parse error. 'getMessages' and 'getErrorMessages' must return + -- a non-empty bag of errors. + +-- | Test whether a 'WarningFlag' is set +warnopt :: WarningFlag -> ParserFlags -> Bool +warnopt f options = f `EnumSet.member` pWarningFlags options + +-- | The subset of the 'DynFlags' used by the parser. +-- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this. +data ParserFlags = ParserFlags { + pWarningFlags :: EnumSet WarningFlag + , pHomeUnitId :: UnitId -- ^ unit currently being compiled + , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions + } + +-- | Haddock comment as produced by the lexer. These are accumulated in +-- 'PState' and then processed in "GHC.Parser.PostProcess.Haddock". +data HdkComment + = HdkCommentNext HsDocString + | HdkCommentPrev HsDocString + | HdkCommentNamed String HsDocString + | HdkCommentSection Int HsDocString + deriving Show + +data PState = PState { + buffer :: StringBuffer, + options :: ParserFlags, + -- This needs to take DynFlags as an argument until + -- we have a fix for #10143 + messages :: DynFlags -> Messages, + tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file + tab_count :: !Int, -- number of tab warnings in the file + last_tk :: Maybe Token, + last_loc :: PsSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: PsLoc, -- current loc (end of prev token + 1) + context :: [LayoutContext], + lex_state :: [Int], + srcfiles :: [FastString], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [PsLocated Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (PsLocated Token), + -- This is what we consider to be the location of the last token + -- emitted: + alr_last_loc :: PsSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout, + -- Have we just had the '}' for a let block? If so, than an 'in' + -- token doesn't need to close anything: + alr_justClosedExplicitLetBlock :: Bool, + + -- The next three are used to implement Annotations giving the + -- locations of 'noise' tokens in the source, so that users of + -- the GHC API can do source to source conversions. + -- See note [Api annotations] in GHC.Parser.Annotation + annotations :: [(ApiAnnKey,[RealSrcSpan])], + eof_pos :: Maybe RealSrcSpan, + comment_q :: [RealLocated AnnotationComment], + annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])], + + -- Haddock comments accumulated in ascending order of their location + -- (BufPos). We use OrdList to get O(1) snoc. + -- + -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock + hdk_comments :: OrdList (PsLocated HdkComment) + } + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). + +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + +-- | The parsing monad, isomorphic to @StateT PState Maybe@. +newtype P a = P { unP :: PState -> ParseResult a } + +instance Functor P where + fmap = liftM + +instance Applicative P where + pure = returnP + (<*>) = ap + +instance Monad P where + (>>=) = thenP + +returnP :: a -> P a +returnP a = a `seq` (P $ \s -> POk s a) + +thenP :: P a -> (a -> P b) -> P b +(P m) `thenP` k = P $ \ s -> + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed s1 -> PFailed s1 + +failMsgP :: String -> P a +failMsgP msg = do + pState <- getPState + addFatalError (mkSrcSpanPs (last_loc pState)) (text msg) + +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a +failLocMsgP loc1 loc2 str = + addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing) (text str) + +getPState :: P PState +getPState = P $ \s -> POk s s + +withHomeUnitId :: (UnitId -> a) -> P a +withHomeUnitId f = P $ \s@(PState{options = o}) -> POk s (f (pHomeUnitId o)) + +getExts :: P ExtsBitmap +getExts = P $ \s -> POk s (pExtsBitmap . options $ s) + +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () +setExts f = P $ \s -> POk s { + options = + let p = options s + in p { pExtsBitmap = f (pExtsBitmap p) } + } () + +setSrcLoc :: RealSrcLoc -> P () +setSrcLoc new_loc = + P $ \s@(PState{ loc = PsLoc _ buf_loc }) -> + POk s{ loc = PsLoc new_loc buf_loc } () + +getRealSrcLoc :: P RealSrcLoc +getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc) + +getParsedLoc :: P PsLoc +getParsedLoc = P $ \s@(PState{ loc=loc }) -> POk s loc + +addSrcFile :: FastString -> P () +addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () + +setEofPos :: RealSrcSpan -> P () +setEofPos span = P $ \s -> POk s{ eof_pos = Just span } () + +setLastToken :: PsSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, + last_len=len + } () + +setLastTk :: Token -> P () +setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () + +getLastTk :: P (Maybe Token) +getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk + +data AlexInput = AI PsLoc StringBuffer + +{- +Note [Unicode in Alex] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although newer versions of Alex support unicode, this grammar is processed with +the old style '--latin1' behaviour. This means that when implementing the +functions + + alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) + alexInputPrevChar :: AlexInput -> Char + +which Alex uses to take apart our 'AlexInput', we must + + * return a latin1 character in the 'Word8' that 'alexGetByte' expects + * return a latin1 character in 'alexInputPrevChar'. + +We handle this in 'adjustChar' by squishing entire classes of unicode +characters into single bytes. +-} + +{-# INLINE adjustChar #-} +adjustChar :: Char -> Word8 +adjustChar c = fromIntegral $ ord adj_c + where non_graphic = '\x00' + upper = '\x01' + lower = '\x02' + digit = '\x03' + symbol = '\x04' + space = '\x05' + other_graphic = '\x06' + uniidchar = '\x07' + + adj_c + | c <= '\x07' = non_graphic + | c <= '\x7f' = c + -- Alex doesn't handle Unicode, so when Unicode + -- character is encountered we output these values + -- with the actual character value hidden in the state. + | otherwise = + -- NB: The logic behind these definitions is also reflected + -- in "GHC.Utils.Lexeme" + -- Any changes here should likely be reflected there. + + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> uniidchar -- see #10196 + OtherLetter -> lower -- see #1103 + NonSpacingMark -> uniidchar -- see #7650 + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic + +-- Getting the previous 'Char' isn't enough here - we need to convert it into +-- the same format that 'alexGetByte' would have produced. +-- +-- See Note [Unicode in Alex] and #13986. +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc)) + where pc = prevChar buf '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +-- See Note [Unicode in Alex] +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (AI loc s) + | atEnd s = Nothing + | otherwise = byte `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (byte, (AI loc' s')) + where (c,s') = nextChar s + loc' = advancePsLoc loc c + byte = adjustChar c + +-- This version does not squash unicode characters, it is used when +-- lexing strings. +alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar' (AI loc s) + | atEnd s = Nothing + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) + where (c,s') = nextChar s + loc' = advancePsLoc loc c + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) + +setInput :: AlexInput -> P () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () + +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + +pushLexState :: Int -> P () +pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () + +popLexState :: P Int +popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls + +getLexState :: P Int +getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls + +popNextToken :: P (Maybe (PsLocated Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +resetAlrLastLoc :: FastString -> P () +resetAlrLastLoc file = + P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) -> + POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } () + +setAlrLastLoc :: PsSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P PsSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + +setNextToken :: PsLocated Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (PsLocated Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [PsLocated Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + +-- | For reasons of efficiency, boolean parsing flags (eg, language extensions +-- or whether we are currently in a @RULE@ pragma) are represented by a bitmap +-- stored in a @Word64@. +type ExtsBitmap = Word64 + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +-- | Various boolean flags, mostly language extensions, that impact lexing and +-- parsing. Note that a handful of these can change during lexing/parsing. +data ExtBits + -- Flags that are constant once parsing starts + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ArrowsBit + | ThBit + | ThQuotesBit + | IpBit + | OverloadedLabelsBit -- #x overloaded labels + | ExplicitForallBit -- the 'forall' keyword + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | RecursiveDoBit -- mdo + | QualifiedDoBit -- .do and .mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedTuplesBit -- (# and #) + | UnboxedSumsBit -- (# and #) + | DatatypeContextsBit + | MonadComprehensionsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | RawTokenStreamBit -- producing a token stream with all comments included + | AlternativeLayoutRuleBit + | ALRTransitionalBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + | HexFloatLiteralsBit + | StaticPointersBit + | NumericUnderscoresBit + | StarIsTypeBit + | BlockArgumentsBit + | NPlusKPatternsBit + | DoAndIfThenElseBit + | MultiWayIfBit + | GadtSyntaxBit + | ImportQualifiedPostBit + | LinearTypesBit + | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit] + + -- Flags that are updated once parsing starts + | InRulePragBit + | InNestedCommentBit -- See Note [Nested comment line pragmas] + | UsePosPragsBit + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' + -- update the internal position. Otherwise, those pragmas are lexed as + -- tokens of their own. + deriving Enum + + + + + +-- PState for parsing options pragmas +-- +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +pragState dynflags buf loc = (mkPState dynflags buf loc) { + lex_state = [bol, option_prags, 0] + } + +{-# INLINE mkParserFlags' #-} +mkParserFlags' + :: EnumSet WarningFlag -- ^ warnings flags enabled + -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled + -> UnitId -- ^ id of the unit currently being compiled + -> Bool -- ^ are safe imports on? + -> Bool -- ^ keeping Haddock comment tokens + -> Bool -- ^ keep regular comment tokens + + -> Bool + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update + -- the internal position kept by the parser. Otherwise, those pragmas are + -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. + + -> ParserFlags +-- ^ Given exactly the information needed, set up the 'ParserFlags' +mkParserFlags' warningFlags extensionFlags homeUnitId + safeImports isHaddock rawTokStream usePosPrags = + ParserFlags { + pWarningFlags = warningFlags + , pHomeUnitId = homeUnitId + , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + } + where + safeHaskellBit = SafeHaskellBit `setBitIf` safeImports + langExtBits = + FfiBit `xoptBit` LangExt.ForeignFunctionInterface + .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI + .|. CApiFfiBit `xoptBit` LangExt.CApiFFI + .|. ArrowsBit `xoptBit` LangExt.Arrows + .|. ThBit `xoptBit` LangExt.TemplateHaskell + .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes + .|. QqBit `xoptBit` LangExt.QuasiQuotes + .|. IpBit `xoptBit` LangExt.ImplicitParams + .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels + .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll + .|. BangPatBit `xoptBit` LangExt.BangPatterns + .|. MagicHashBit `xoptBit` LangExt.MagicHash + .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo + .|. QualifiedDoBit `xoptBit` LangExt.QualifiedDo + .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax + .|. UnboxedTuplesBit `xoptBit` LangExt.UnboxedTuples + .|. UnboxedSumsBit `xoptBit` LangExt.UnboxedSums + .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts + .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp + .|. MonadComprehensionsBit `xoptBit` LangExt.MonadComprehensions + .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule + .|. ALRTransitionalBit `xoptBit` LangExt.AlternativeLayoutRuleTransitional + .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout + .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation + .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax + .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces + .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase + .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals + .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals + .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals + .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms + .|. StaticPointersBit `xoptBit` LangExt.StaticPointers + .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores + .|. StarIsTypeBit `xoptBit` LangExt.StarIsType + .|. BlockArgumentsBit `xoptBit` LangExt.BlockArguments + .|. NPlusKPatternsBit `xoptBit` LangExt.NPlusKPatterns + .|. DoAndIfThenElseBit `xoptBit` LangExt.DoAndIfThenElse + .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf + .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax + .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost + .|. LinearTypesBit `xoptBit` LangExt.LinearTypes + .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] + optBits = + HaddockBit `setBitIf` isHaddock + .|. RawTokenStreamBit `setBitIf` rawTokStream + .|. UsePosPragsBit `setBitIf` usePosPrags + + xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags + xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags) + + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b + | otherwise = 0 + +-- | Extracts the flag information needed for parsing +mkParserFlags :: DynFlags -> ParserFlags +mkParserFlags = + mkParserFlags' + <$> DynFlags.warningFlags + <*> DynFlags.extensionFlags + <*> DynFlags.homeUnitId + <*> safeImportsOn + <*> gopt Opt_Haddock + <*> gopt Opt_KeepRawTokenStream + <*> const True + +-- | Creates a parse state from a 'DynFlags' value +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +mkPState flags = mkPStatePure (mkParserFlags flags) + +-- | Creates a parse state from a 'ParserFlags' value +mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState +mkPStatePure options buf loc = + PState { + buffer = buf, + options = options, + messages = const emptyMessages, + tab_first = Nothing, + tab_count = 0, + last_tk = Nothing, + last_loc = mkPsSpan init_loc init_loc, + last_len = 0, + loc = init_loc, + context = [], + lex_state = [bol, 0], + srcfiles = [], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = PsSpan (alrInitialLoc (fsLit "")) (BufSpan (BufPos 0) (BufPos 0)), + alr_context = [], + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False, + annotations = [], + eof_pos = Nothing, + comment_q = [], + annotations_comments = [], + hdk_comments = nilOL + } + where init_loc = PsLoc loc (BufPos 0) + +-- | An mtl-style class for monads that support parsing-related operations. +-- For example, sometimes we make a second pass over the parsing results to validate, +-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume +-- input but can report parsing errors, check for extension bits, and accumulate +-- parsing annotations. Both P and PV are instances of MonadP. +-- +-- MonadP grants us convenient overloading. The other option is to have separate operations +-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on. +-- +class Monad m => MonadP m where + -- | Add a non-fatal error. Use this when the parser can produce a result + -- despite the error. + -- + -- For example, when GHC encounters a @forall@ in a type, + -- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ + -- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to + -- the accumulator. + -- + -- Control flow wise, non-fatal errors act like warnings: they are added + -- to the accumulator and parsing continues. This allows GHC to report + -- more than one parse error per file. + -- + addError :: SrcSpan -> SDoc -> m () + -- | Add a warning to the accumulator. + -- Use 'getMessages' to get the accumulated warnings. + addWarning :: WarningFlag -> SrcSpan -> SDoc -> m () + -- | Add a fatal error. This will be the last error reported by the parser, and + -- the parser will not produce any result, ending in a 'PFailed' state. + addFatalError :: SrcSpan -> SDoc -> m a + -- | Check if a given flag is currently set in the bitmap. + getBit :: ExtBits -> m Bool + -- | Given a location and a list of AddAnn, apply them all to the location. + addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct + -> AnnKeywordId -- The first two parameters are the key + -> SrcSpan -- The location of the keyword itself + -> m () + +appendError + :: SrcSpan + -> SDoc + -> (DynFlags -> Messages) + -> (DynFlags -> Messages) +appendError srcspan msg m = + \d -> + let (ws, es) = m d + errormsg = mkErrMsg d srcspan alwaysQualify msg + es' = es `snocBag` errormsg + in (ws, es') + +appendWarning + :: ParserFlags + -> WarningFlag + -> SrcSpan + -> SDoc + -> (DynFlags -> Messages) + -> (DynFlags -> Messages) +appendWarning o option srcspan warning m = + \d -> + let (ws, es) = m d + warning' = makeIntoWarning (Reason option) $ + mkWarnMsg d srcspan alwaysQualify warning + ws' = if warnopt option o then ws `snocBag` warning' else ws + in (ws', es) + +instance MonadP P where + addError srcspan msg + = P $ \s@PState{messages=m} -> + POk s{messages=appendError srcspan msg m} () + addWarning option srcspan warning + = P $ \s@PState{messages=m, options=o} -> + POk s{messages=appendWarning o option srcspan warning m} () + addFatalError span msg = + addError span msg >> P PFailed + getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) + in b `seq` POk s b + addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do + addAnnotationOnly l a v + allocateCommentsP l + addAnnotation _ _ _ = return () + +addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m () +addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v) + +addTabWarning :: RealSrcSpan -> P () +addTabWarning srcspan + = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> + let tf' = if isJust tf then tf else Just srcspan + tc' = tc + 1 + s' = if warnopt Opt_WarnTabs o + then s{tab_first = tf', tab_count = tc'} + else s + in POk s' () + +mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg +mkTabWarning PState{tab_first=tf, tab_count=tc} d = + let middle = if tc == 1 + then text "" + else text ", and in" <+> speakNOf (tc - 1) (text "further location") + message = text "Tab character found here" + <> middle + <> text "." + $+$ text "Please use spaces instead." + in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ + mkWarnMsg d (RealSrcSpan s Nothing) alwaysQualify message) tf + +-- | Get a bag of the errors that have been accumulated so far. +-- Does not take -Werror into account. +getErrorMessages :: PState -> DynFlags -> ErrorMessages +getErrorMessages PState{messages=m} d = + let (_, es) = m d in es + +-- | Get the warnings and errors accumulated so far. +-- Does not take -Werror into account. +getMessages :: PState -> DynFlags -> Messages +getMessages p@PState{messages=m} d = + let (ws, es) = m d + tabwarning = mkTabWarning p d + ws' = maybe ws (`consBag` ws) tabwarning + in (ws', es) + +getContext :: P [LayoutContext] +getContext = P $ \s@PState{context=ctx} -> POk s ctx + +setContext :: [LayoutContext] -> P () +setContext ctx = P $ \s -> POk s{context=ctx} () + +popContext :: P () +popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, + last_len = len, last_loc = last_loc }) -> + case ctx of + (_:tl) -> + POk s{ context = tl } () + [] -> + unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s + +-- Push a new layout context at the indentation of the last token read. +pushCurrentContext :: GenSemic -> P () +pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} () + +-- This is only used at the outer level of a module when the 'module' keyword is +-- missing. +pushModuleContext :: P () +pushModuleContext = pushCurrentContext generateSemic + +getOffside :: P (Ordering, Bool) +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol (psRealSpan loc) in + let ord = case stk of + Layout n gen_semic : _ -> + --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + (compare offs n, gen_semic) + _ -> + (GT, dontGenerateSemic) + in POk s ord + +-- --------------------------------------------------------------------------- +-- Construct a parse error + +srcParseErr + :: ParserFlags + -> StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token + -> MsgDoc +srcParseErr options buf len + = if null token + then text "parse error (possibly incorrect indentation or mismatched brackets)" + else text "parse error on input" <+> quotes (text token) + $$ ppWhen (not th_enabled && token == "$") -- #7396 + (text "Perhaps you intended to use TemplateHaskell") + $$ ppWhen (token == "<-") + (if mdoInLast100 + then text "Perhaps you intended to use RecursiveDo" + else text "Perhaps this statement should be within a 'do' block?") + $$ ppWhen (token == "=" && doInLast100) -- #15849 + (text "Perhaps you need a 'let' in a 'do' block?" + $$ text "e.g. 'let x = 5' instead of 'x = 5'") + $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429 + (text "Perhaps you intended to use PatternSynonyms") + where token = lexemeToString (offsetBytes (-len) buf) len + pattern = decodePrevNChars 8 buf + last100 = decodePrevNChars 100 buf + doInLast100 = "do" `isInfixOf` last100 + mdoInLast100 = "mdo" `isInfixOf` last100 + th_enabled = ThQuotesBit `xtest` pExtsBitmap options + ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options + +-- Report a parse failure, giving the span of the previous token as +-- the location of the error. This is the entry point for errors +-- detected during parsing. +srcParseFail :: P a +srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, + last_loc = last_loc } -> + unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s + +-- A lexical error is reported at a particular position in the source file, +-- not over a token range. +lexError :: String -> P a +lexError str = do + loc <- getRealSrcLoc + (AI end buf) <- getInput + reportLexError loc (psRealLoc end) buf str + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a + +lexer queueComments cont = do + alr <- getBit AlternativeLayoutRuleBit + let lexTokenFun = if alr then lexTokenAlr else lexToken + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + + if (queueComments && isComment tok) + then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont + else cont (L (mkSrcSpanPs span) tok) + +-- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging. +lexerDbg queueComments cont = lexer queueComments contDbg + where + contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok) + +lexTokenAlr :: P (PsLocated Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getLoc t) + case unLoc t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITmdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + transitional <- getBit ALRTransitionalBit + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + let thisLoc = getLoc t + thisCol = srcSpanStartCol (psRealSpan thisLoc) + newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc) + case (unLoc t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just alrLayout) -> + do setAlrExpectingOCurly Nothing + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : _ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIndentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITvccurly] + setNextToken t + return (L lastLoc ITvocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (mkSrcSpanPs thisLoc) + (transitionalAlternativeLayoutWarning + "`where' clause at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (mkSrcSpanPs thisLoc) + (transitionalAlternativeLayoutWarning + "`|' at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + let loc = psSpanStart thisLoc + zeroWidthLoc = mkPsSpan loc loc + return (L zeroWidthLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- We need to handle close before open, as 'then' is both + -- an open and a close + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + ALRNoLayout _ isLet : ls -> + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' + when isLet $ setJustClosedExplicitLetBlock True + return t + [] -> + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else [] + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +transitionalAlternativeLayoutWarning :: String -> SDoc +transitionalAlternativeLayoutWarning msg + = text "transitional layout will not be accepted in the future:" + $$ text msg + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen ITthen = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITelse = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIndentation :: ALRLayout -> Bool +isNonDecreasingIndentation ALRLayoutDo = True +isNonDecreasingIndentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b + +lexToken :: P (PsLocated Token) +lexToken = do + inp@(AI loc1 buf) <- getInput + sc <- getLexState + exts <- getExts + case alexScanUser exts inp sc of + AlexEOF -> do + let span = mkPsSpan loc1 loc1 + setEofPos (psRealSpan span) + setLastToken span 0 + return (L span ITeof) + AlexError (AI loc2 buf) -> + reportLexError (psRealLoc loc1) (psRealLoc loc2) buf "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(AI end buf2) _ t -> do + setInput inp2 + let span = mkPsSpan loc1 end + let bytes = byteDiff buf buf2 + span `seq` setLastToken span bytes + lt <- t span buf bytes + let lt' = unLoc lt + unless (isComment lt') (setLastTk lt') + return lt + +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a +reportLexError loc1 loc2 buf str + | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") + | otherwise = + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + +lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream buf loc dflags = unP go initState{ options = opts' } + where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream + initState@PState{ options = opts } = mkPState dflags' buf loc + opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts } + go = do + ltok <- lexer False return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go + +linePrags = Map.singleton "line" linePrag + +fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), + ("options_ghc", lex_string_prag IToptions_prag), + ("options_haddock", lex_string_prag ITdocOptions), + ("language", token ITlanguage_prag), + ("include", lex_string_prag ITinclude_prag)]) + +ignoredPrags = Map.fromList (map ignored pragmas) + where ignored opt = (opt, nested_comment lexToken) + impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] + options_pragmas = map ("options_" ++) impls + -- CFILES is a hugs-only thing. + pragmas = options_pragmas ++ ["cfiles", "contract"] + +oneWordPrags = Map.fromList [ + ("rules", rulePrag), + ("inline", + strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), + ("inlinable", + strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + ("inlineable", + strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + -- Spelling variant + ("notinline", + strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), + ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), + ("source", strtoken (\s -> ITsource_prag (SourceText s))), + ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), + ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), + ("scc", strtoken (\s -> ITscc_prag (SourceText s))), + ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))), + ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), + ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), + ("ann", strtoken (\s -> ITann_prag (SourceText s))), + ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), + ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), + ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), + ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), + ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), + ("ctype", strtoken (\s -> ITctype (SourceText s))), + ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))), + ("column", columnPrag) + ] + +twoWordPrags = Map.fromList [ + ("inline conlike", + strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), + ("notinline conlike", + strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), + ("specialize inline", + strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), + ("specialize notinline", + strtoken (\s -> (ITspec_inline_prag (SourceText s) False))) + ] + +dispatch_pragmas :: Map String Action -> Action +dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of + Just found -> found span buf len + Nothing -> lexError "unknown pragma" + +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' + +clean_pragma :: String -> String +clean_pragma prag = canon_ws (map toLower (unprefix prag)) + where unprefix prag' = case stripPrefix "{-#" prag' of + Just rest -> rest + Nothing -> prag' + canonical prag' = case prag' of + "noinline" -> "notinline" + "specialise" -> "specialize" + "constructorlike" -> "conlike" + _ -> prag' + canon_ws s = unwords (map canonical (words s)) + + + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ +-} + + +addAnnotationOnly :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P () +addAnnotationOnly l a v = P $ \s -> POk s { + annotations = ((l,a), [v]) : annotations s + } () + + +queueComment :: RealLocated Token -> P() +queueComment c = P $ \s -> POk s { + comment_q = commentToAnnotation c : comment_q s + } () + +-- | Go through the @comment_q@ in @PState@ and remove all comments +-- that belong within the given span +allocateCommentsP :: RealSrcSpan -> P () +allocateCommentsP ss = P $ \s -> + let (comment_q', newAnns) = allocateComments ss (comment_q s) in + POk s { + comment_q = comment_q' + , annotations_comments = newAnns ++ (annotations_comments s) + } () + +allocateComments + :: RealSrcSpan + -> [RealLocated AnnotationComment] + -> ([RealLocated AnnotationComment], [(RealSrcSpan,[RealLocated AnnotationComment])]) +allocateComments ss comment_q = + let + (before,rest) = break (\(L l _) -> isRealSubspanOf l ss) comment_q + (middle,after) = break (\(L l _) -> not (isRealSubspanOf l ss)) rest + comment_q' = before ++ after + newAnns = if null middle then [] + else [(ss,middle)] + in + (comment_q', newAnns) + + +commentToAnnotation :: RealLocated Token -> RealLocated AnnotationComment +commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) +commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) +commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) +commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) +commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) +commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) +commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) +commentToAnnotation _ = panic "commentToAnnotation" + +-- --------------------------------------------------------------------- + +isComment :: Token -> Bool +isComment (ITlineComment _) = True +isComment (ITblockComment _) = True +isComment (ITdocCommentNext _) = True +isComment (ITdocCommentPrev _) = True +isComment (ITdocCommentNamed _) = True +isComment (ITdocSection _ _) = True +isComment (ITdocOptions _) = True +isComment _ = False +} diff --git a/GHC/Parser/PostProcess.hs b/GHC/Parser/PostProcess.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/PostProcess.hs @@ -0,0 +1,3089 @@ +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- Functions over HsSyn specialised to RdrName. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Parser.PostProcess ( + mkHsOpApp, + mkHsIntegral, mkHsFractional, mkHsIsString, + mkHsDo, mkSpliceDecl, + mkRoleAnnotDecl, + mkClassDecl, + mkTyData, mkDataFamInst, + mkTySynonym, mkTyFamInstEqn, + mkStandaloneKindSig, + mkTyFamInst, + mkFamDecl, mkLHsSigType, + mkInlinePragma, + mkPatSynMatchGroup, + mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkTyClD, mkInstD, + mkRdrRecordCon, mkRdrRecordUpd, + setRdrNameSpace, + filterCTuple, + fromSpecTyVarBndr, fromSpecTyVarBndrs, + + cvBindGroup, + cvBindsAndSigs, + cvTopDecls, + placeHolderPunRhs, + + -- Stuff to do with Foreign declarations + mkImport, + parseCImport, + mkExport, + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkConDeclH98, + + -- Bunch of functions in the parser monad for + -- checking and constructing values + checkImportDecl, + checkExpBlockArguments, checkCmdBlockArguments, + checkPrecP, -- Int -> P Int + checkContext, -- HsType -> P HsContext + checkPattern, -- HsExp -> P HsPat + checkPattern_msg, + checkMonadComp, -- P (HsStmtContext GhcPs) + checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkValSigLhs, + LRuleTyTmVar, RuleTyTmVar(..), + mkRuleBndrs, mkRuleTyVarBndrs, + checkRuleTyVarBndrNames, + checkRecordSyntax, + checkEmptyGADTs, + addFatalError, hintBangPat, + TyEl(..), mergeOps, mergeDataCon, + mkBangTy, + mkMultTy, + + -- Help with processing exports + ImpExpSubSpec(..), + ImpExpQcSpec(..), + mkModuleImpExp, + mkTypeImpExp, + mkImpExpSubSpec, + checkImportSpec, + + -- Token symbols + forallSym, + starSym, + + -- Warnings and errors + warnStarIsType, + warnPrepositiveQualifiedModule, + failOpFewArgs, + failOpNotEnabledImportQualifiedPost, + failOpImportQualifiedTwice, + + SumOrTuple (..), + + -- Expression/command/pattern ambiguity resolution + PV, + runPV, + ECP(ECP, runECP_PV), + runECP_P, + DisambInfixOp(..), + DisambECP(..), + ecpFromExp, + ecpFromCmd, + PatBuilder + ) where + +import GHC.Prelude +import GHC.Hs -- Lots of it +import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) +import GHC.Core.DataCon ( DataCon, dataConTyCon ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Unit.Module (ModuleName) +import GHC.Types.Basic +import GHC.Parser.Lexer +import GHC.Utils.Lexeme ( isLexCon ) +import GHC.Core.Type ( TyThing(..), unrestrictedFunTyCon, Specificity(..) ) +import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, + nilDataConName, nilDataConKey, + listTyConName, listTyConKey, eqTyCon_RDR, + tupleTyConName, cTupleTyConNameArity_maybe ) +import GHC.Types.ForeignCall +import GHC.Builtin.Names ( allNameStrings ) +import GHC.Types.SrcLoc +import GHC.Types.Unique ( hasKey ) +import GHC.Data.OrdList ( OrdList, fromOL ) +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Parser.Annotation +import Data.List +import GHC.Driver.Session ( WarningFlag(..), DynFlags ) +import GHC.Utils.Error ( Messages ) + +import Control.Monad +import Text.ParserCombinators.ReadP as ReadP +import Data.Char +import qualified Data.Monoid as Monoid +import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) +import Data.Kind ( Type ) + +#include "HsVersions.h" + + +{- ********************************************************************** + + Construction functions for Rdr stuff + + ********************************************************************* -} + +-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and +-- datacon by deriving them from the name of the class. We fill in the names +-- for the tycon and datacon corresponding to the class, by deriving them +-- from the name of the class itself. This saves recording the names in the +-- interface file (which would be equally good). + +-- Similarly for mkConDecl, mkClassOpSig and default-method names. + +-- *** See Note [The Naming story] in GHC.Hs.Decls **** + +mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkTyClD (L loc d) = L loc (TyClD noExtField d) + +mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkInstD (L loc d) = L loc (InstD noExtField d) + +mkClassDecl :: SrcSpan + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Located (a,[LHsFunDep GhcPs]) + -> OrdList (LHsDecl GhcPs) + -> LayoutInfo + -> P (LTyClDecl GhcPs) + +mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo + = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls + ; let cxt = fromMaybe (noLoc []) mcxt + ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams + ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan + ; return (L loc (ClassDecl { tcdCExt = layoutInfo + , tcdCtxt = cxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } + +mkTyData :: SrcSpan + -> NewOrData + -> Maybe (Located CType) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (LTyClDecl GhcPs) +mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) + ksig data_cons maybe_deriv + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (DataDecl { tcdDExt = noExtField, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } + +mkDataDefn :: NewOrData + -> Maybe (Located CType) + -> Maybe (LHsContext GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (HsDataDefn GhcPs) +mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + = do { checkDatatypeContext mcxt + ; let cxt = fromMaybe (noLoc []) mcxt + ; return (HsDataDefn { dd_ext = noExtField + , dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = cxt + , dd_cons = data_cons + , dd_kindSig = ksig + , dd_derivs = maybe_deriv }) } + + +mkTySynonym :: SrcSpan + -> LHsType GhcPs -- LHS + -> LHsType GhcPs -- RHS + -> P (LTyClDecl GhcPs) +mkTySynonym loc lhs rhs + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; return (L loc (SynDecl { tcdSExt = noExtField + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } + +mkStandaloneKindSig + :: SrcSpan + -> Located [Located RdrName] -- LHS + -> LHsKind GhcPs -- RHS + -> P (LStandaloneKindSig GhcPs) +mkStandaloneKindSig loc lhs rhs = + do { vs <- mapM check_lhs_name (unLoc lhs) + ; v <- check_singular_lhs (reverse vs) + ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } + where + check_lhs_name v@(unLoc->name) = + if isUnqual name && isTcOcc (rdrNameOcc name) + then return v + else addFatalError (getLoc v) $ + hang (text "Expected an unqualified type constructor:") 2 (ppr v) + check_singular_lhs vs = + case vs of + [] -> panic "mkStandaloneKindSig: empty left-hand side" + [v] -> return v + _ -> addFatalError (getLoc lhs) $ + vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") + 2 (pprWithCommas ppr vs) + , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] + +mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs] + -> LHsType GhcPs + -> LHsType GhcPs + -> P (TyFamInstEqn GhcPs,[AddAnn]) +mkTyFamInstEqn bndrs lhs rhs + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs + ; return (mkHsImplicitBndrs + (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = rhs }), + ann) } + +mkDataFamInst :: SrcSpan + -> NewOrData + -> Maybe (Located CType) + -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs] + , LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (LInstDecl GhcPs) +mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) + ksig data_cons maybe_deriv + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs + (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = defn }))))) } + +mkTyFamInst :: SrcSpan + -> TyFamInstEqn GhcPs + -> P (LInstDecl GhcPs) +mkTyFamInst loc eqn + = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn))) + +mkFamDecl :: SrcSpan + -> FamilyInfo GhcPs + -> LHsType GhcPs -- LHS + -> Located (FamilyResultSig GhcPs) -- Optional result signature + -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> P (LTyClDecl GhcPs) +mkFamDecl loc info lhs ksig injAnn + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; return (L loc (FamDecl noExtField (FamilyDecl + { fdExt = noExtField + , fdInfo = info, fdLName = tc + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = ksig + , fdInjectivityAnn = injAnn }))) } + where + equals_or_where = case info of + DataFamily -> empty + OpenTypeFamily -> empty + ClosedTypeFamily {} -> whereDots + +mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs +-- If the user wrote +-- [pads| ... ] then return a QuasiQuoteD +-- $(e) then return a SpliceD +-- but if she wrote, say, +-- f x then behave as if she'd written $(f x) +-- ie a SpliceD +-- +-- Typed splices are not allowed at the top level, thus we do not represent them +-- as spliced declaration. See #10945 +mkSpliceDecl lexpr@(L loc expr) + | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr + = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + + | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr + = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + + | otherwise + = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr)) + ImplicitSplice) + +mkRoleAnnotDecl :: SrcSpan + -> Located RdrName -- type being annotated + -> [Located (Maybe FastString)] -- roles + -> P (LRoleAnnotDecl GhcPs) +mkRoleAnnotDecl loc tycon roles + = do { roles' <- mapM parse_role roles + ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' } + where + role_data_type = dataTypeOf (undefined :: Role) + all_roles = map fromConstr $ dataTypeConstrs role_data_type + possible_roles = [(fsFromRole role, role) | role <- all_roles] + + parse_role (L loc_role Nothing) = return $ L loc_role Nothing + parse_role (L loc_role (Just role)) + = case lookup role possible_roles of + Just found_role -> return $ L loc_role $ Just found_role + Nothing -> + let nearby = fuzzyLookup (unpackFS role) + (mapFst unpackFS possible_roles) + in + addFatalError loc_role + (text "Illegal role name" <+> quotes (ppr role) $$ + suggestions nearby) + + suggestions [] = empty + suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) + -- will this last case ever happen?? + suggestions list = hang (text "Perhaps you meant one of these:") + 2 (pprWithCommas (quotes . ppr) list) + +-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to +-- binders without annotations. Only accepts specified variables, and errors if +-- any of the provided binders has an 'InferredSpec' annotation. +fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs] +fromSpecTyVarBndrs = mapM fromSpecTyVarBndr + +-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without +-- annotations. Only accepts specified variables, and errors if the provided +-- binder has an 'InferredSpec' annotation. +fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs) +fromSpecTyVarBndr bndr = case bndr of + (L loc (UserTyVar xtv flag idp)) -> (check_spec flag loc) + >> return (L loc $ UserTyVar xtv () idp) + (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc) + >> return (L loc $ KindedTyVar xtv () idp k) + where + check_spec :: Specificity -> SrcSpan -> P () + check_spec SpecifiedSpec _ = return () + check_spec InferredSpec loc = addFatalError loc + (text "Inferred type variables are not allowed here") + +{- ********************************************************************** + + #cvBinds-etc# Converting to @HsBinds@, etc. + + ********************************************************************* -} + +-- | Function definitions are restructured here. Each is assumed to be recursive +-- initially, and non recursive definitions are discovered by the dependency +-- analyser. + + +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] +cvTopDecls decls = getMonoBindAll (fromOL decls) + +-- Declaration list may only contain value bindings and signatures. +cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) +cvBindGroup binding + = do { (mbs, sigs, fam_ds, tfam_insts + , dfam_insts, _) <- cvBindsAndSigs binding + ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) + return $ ValBinds noExtField mbs sigs } + +cvBindsAndSigs :: OrdList (LHsDecl GhcPs) + -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigs fb = do + fb' <- drop_bad_decls (fromOL fb) + return (partitionBindsAndSigs (getMonoBindAll fb')) + where + -- cvBindsAndSigs is called in several places in the parser, + -- and its items can be produced by various productions: + -- + -- * decl (when parsing a where clause or a let-expression) + -- * decl_inst (when parsing an instance declaration) + -- * decl_cls (when parsing a class declaration) + -- + -- partitionBindsAndSigs can handle almost all declaration forms produced + -- by the aforementioned productions, except for SpliceD, which we filter + -- out here (in drop_bad_decls). + -- + -- We're not concerned with every declaration form possible, such as those + -- produced by the topdecl parser production, because cvBindsAndSigs is not + -- called on top-level declarations. + drop_bad_decls [] = return [] + drop_bad_decls (L l (SpliceD _ d) : ds) = do + addError l $ + hang (text "Declaration splices are allowed only" <+> + text "at the top level:") + 2 (ppr d) + drop_bad_decls ds + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds + +----------------------------------------------------------------------------- +-- Group function bindings into equation groups + +getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] + -> (LHsBind GhcPs, [LHsDecl GhcPs]) +-- Suppose (b',ds') = getMonoBind b ds +-- ds is a list of parsed bindings +-- b is a MonoBinds that has just been read off the front + +-- Then b' is the result of grouping more equations from ds that +-- belong with b into a single MonoBinds, and ds' is the depleted +-- list of parsed bindings. +-- +-- All Haddock comments between equations inside the group are +-- discarded. +-- +-- No AndMonoBinds or EmptyMonoBinds here; just single equations + +getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) + , fun_matches = + MG { mg_alts = (L _ mtchs1) } })) + binds + | has_args mtchs1 + = go mtchs1 loc1 binds [] + where + go mtchs loc + ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) + , fun_matches = + MG { mg_alts = (L _ mtchs2) } }))) + : binds) _ + | f1 == f2 = go (mtchs2 ++ mtchs) + (combineSrcSpans loc loc2) binds [] + go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls + = let doc_decls' = doc_decl : doc_decls + in go mtchs (combineSrcSpans loc loc2) binds doc_decls' + go mtchs loc binds doc_decls + = ( L loc (makeFunBind fun_id1 (reverse mtchs)) + , (reverse doc_decls) ++ binds) + -- Reverse the final matches, to get it back in the right order + -- Do the same thing with the trailing doc comments + +getMonoBind bind binds = (bind, binds) + +-- Group together adjacent FunBinds for every function. +getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] +getMonoBindAll [] = [] +getMonoBindAll (L l (ValD _ b) : ds) = + let (L l' b', ds') = getMonoBind (L l b) ds + in L l' (ValD noExtField b') : getMonoBindAll ds' +getMonoBindAll (d : ds) = d : getMonoBindAll ds + +has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool +has_args [] = panic "GHC.Parser.PostProcess.has_args" +has_args (L _ (Match { m_pats = args }) : _) = not (null args) + -- Don't group together FunBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). + +{- ********************************************************************** + + #PrefixToHS-utils# Utilities for conversion + + ********************************************************************* -} + +{- Note [Parsing data constructors is hard] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The problem with parsing data constructors is that they look a lot like types. +Compare: + + (s1) data T = C t1 t2 + (s2) type T = C t1 t2 + +Syntactically, there's little difference between these declarations, except in +(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. + +This similarity would pose no problem if we knew ahead of time if we are +parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple +(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing +data constructors, and in other contexts (e.g. 'type' declarations) assume we +are parsing type constructors. + +This simple rule does not work because of two problematic cases: + + (p1) data T = C t1 t2 :+ t3 + (p2) data T = C t1 t2 => t3 + +In (p1) we encounter (:+) and it turns out we are parsing an infix data +declaration, so (C t1 t2) is a type and 'C' is a type constructor. +In (p2) we encounter (=>) and it turns out we are parsing an existential +context, so (C t1 t2) is a constraint and 'C' is a type constructor. + +As the result, in order to determine whether (C t1 t2) declares a data +constructor, a type, or a context, we would need unlimited lookahead which +'happy' is not so happy with. + +To further complicate matters, the interpretation of (!) and (~) is different +in constructors and types: + + (b1) type T = C ! D + (b2) data T = C ! D + (b3) data T = C ! D => E + +In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At +the same time, in (b2) it is a strictness annotation: 'C' is a data constructor +with a single strict argument 'D'. For the programmer, these cases are usually +easy to tell apart due to whitespace conventions: + + (b2) data T = C !D -- no space after the bang hints that + -- it is a strictness annotation + +For the parser, on the other hand, this whitespace does not matter. We cannot +tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited +lookahead. + +The solution that accounts for all of these issues is to initially parse data +declarations and types as a reversed list of TyEl: + + data TyEl = TyElOpr RdrName + | TyElOpd (HsType GhcPs) + | ... + +For example, both occurrences of (C ! D) in the following example are parsed +into equal lists of TyEl: + + data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D") + , TyElOpr "!" + , TyElOpd (HsTyVar "C") ] + +Note that elements are in reverse order. Also, 'C' is parsed as a type +constructor (HsTyVar) even when it is a data constructor. We fix this in +`tyConToDataCon`. + +By the time the list of TyEl is assembled, we have looked ahead enough to +decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for +data constructors). These functions are where the actual job of parsing is +done. + +-} + +-- | Reinterpret a type constructor, including type operators, as a data +-- constructor. +-- See Note [Parsing data constructors is hard] +tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) +tyConToDataCon loc tc + | isTcOcc occ || isDataOcc occ + , isLexCon (occNameFS occ) + = return (L loc (setRdrNameSpace tc srcDataName)) + + | otherwise + = Left (loc, msg) + where + occ = rdrNameOcc tc + msg = text "Not a data constructor:" <+> quotes (ppr tc) + +mkPatSynMatchGroup :: Located RdrName + -> Located (OrdList (LHsDecl GhcPs)) + -> P (MatchGroup GhcPs (LHsExpr GhcPs)) +mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = + do { matches <- mapM fromDecl (fromOL decls) + ; when (null matches) (wrongNumberErr loc) + ; return $ mkMatchGroup FromSource matches } + where + fromDecl (L loc decl@(ValD _ (PatBind _ + pat@(L _ (ConPat NoExtField ln@(L _ name) details)) + rhs _))) = + do { unless (name == patsyn_name) $ + wrongNameBindingErr loc decl + ; match <- case details of + PrefixCon pats -> return $ Match { m_ext = noExtField + , m_ctxt = ctxt, m_pats = pats + , m_grhss = rhs } + where + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict } + + InfixCon p1 p2 -> return $ Match { m_ext = noExtField + , m_ctxt = ctxt + , m_pats = [p1, p2] + , m_grhss = rhs } + where + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Infix + , mc_strictness = NoSrcStrict } + + RecCon{} -> recordPatSynErr loc pat + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr loc decl + + extraDeclErr loc decl = + addFatalError loc $ + text "pattern synonym 'where' clause must contain a single binding:" $$ + ppr decl + + wrongNameBindingErr loc decl = + addFatalError loc $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" + <+> quotes (ppr patsyn_name) $$ ppr decl + + wrongNumberErr loc = + addFatalError loc $ + text "pattern synonym 'where' clause cannot be empty" $$ + text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) + +recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a +recordPatSynErr loc pat = + addFatalError loc $ + text "record syntax not supported for pattern synonym declarations:" $$ + ppr pat + +mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] + -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs + -> ConDecl GhcPs + +mkConDeclH98 name mb_forall mb_cxt args + = ConDeclH98 { con_ext = noExtField + , con_name = name + , con_forall = noLoc $ isJust mb_forall + , con_ex_tvs = mb_forall `orElse` [] + , con_mb_cxt = mb_cxt + , con_args = args + , con_doc = Nothing } + +-- | Construct a GADT-style data constructor from the constructor names and +-- their type. Some interesting aspects of this function: +-- +-- * This splits up the constructor type into its quantified type variables (if +-- provided), context (if provided), argument types, and result type, and +-- records whether this is a prefix or record GADT constructor. See +-- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. +mkGadtDecl :: [Located RdrName] + -> LHsType GhcPs + -> P (ConDecl GhcPs, [AddAnn]) +mkGadtDecl names ty = do + let (args, res_ty, anns) + | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty + = (RecCon (L loc rf), res_ty, []) + | otherwise + = let (arg_types, res_type, anns) = splitHsFunType body_ty + in (PrefixCon arg_types, res_type, anns) + + pure ( ConDeclGADT { con_g_ext = noExtField + , con_names = names + , con_forall = L (getLoc ty) $ isJust mtvs + , con_qvars = fromMaybe [] mtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty + , con_doc = Nothing } + , anns ) + where + (mtvs, mcxt, body_ty) = splitLHsGadtTy ty + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- ^ This rather gruesome function is used mainly by the parser. +-- When parsing: +-- +-- > data T a = T | T1 Int +-- +-- we parse the data constructors as /types/ because of parser ambiguities, +-- so then we need to change the /type constr/ to a /data constr/ +-- +-- The exact-name case /can/ occur when parsing: +-- +-- > data [] a = [] | a : [a] +-- +-- For the exact-name case we return an original name. +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns + | Just thing <- wiredInNameTyThing_maybe n + = setWiredInNameSpace thing ns + -- Preserve Exact Names for wired-in things, + -- notably tuples and lists + + | isExternalName n + = Orig (nameModule n) occ + + | otherwise -- This can happen when quoting and then + -- splicing a fixity declaration for a type + = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) + where + occ = setOccNameSpace ns (nameOccName n) + +setWiredInNameSpace :: TyThing -> NameSpace -> RdrName +setWiredInNameSpace (ATyCon tc) ns + | isDataConNameSpace ns + = ty_con_data_con tc + | isTcClsNameSpace ns + = Exact (getName tc) -- No-op + +setWiredInNameSpace (AConLike (RealDataCon dc)) ns + | isTcClsNameSpace ns + = data_con_ty_con dc + | isDataConNameSpace ns + = Exact (getName dc) -- No-op + +setWiredInNameSpace thing ns + = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) + +ty_con_data_con :: TyCon -> RdrName +ty_con_data_con tc + | isTupleTyCon tc + , Just dc <- tyConSingleDataCon_maybe tc + = Exact (getName dc) + + | tc `hasKey` listTyConKey + = Exact nilDataConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace srcDataName (getOccName tc)) + +data_con_ty_con :: DataCon -> RdrName +data_con_ty_con dc + | let tc = dataConTyCon dc + , isTupleTyCon tc + = Exact (getName tc) + + | dc `hasKey` nilDataConKey + = Exact listTyConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace tcClsName (getOccName dc)) + +-- | Replaces constraint tuple names with corresponding boxed ones. +filterCTuple :: RdrName -> RdrName +filterCTuple (Exact n) + | Just arity <- cTupleTyConNameArity_maybe n + = Exact $ tupleTyConName BoxedTuple arity +filterCTuple rdr = rdr + + +{- Note [setRdrNameSpace for wired-in names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Types, which declares (:), we have + infixr 5 : +The ambiguity about which ":" is meant is resolved by parsing it as a +data constructor, but then using dataTcOccs to try the type constructor too; +and that in turn calls setRdrNameSpace to change the name-space of ":" to +tcClsName. There isn't a corresponding ":" type constructor, but it's painful +to make setRdrNameSpace partial, so we just make an Unqual name instead. It +really doesn't matter! +-} + +eitherToP :: Either (SrcSpan, SDoc) a -> P a +-- Adapts the Either monad to the P monad +eitherToP (Left (loc, doc)) = addFatalError loc doc +eitherToP (Right thing) = return thing + +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] + -> P ( LHsQTyVars GhcPs -- the synthesized type variables + , [AddAnn] ) -- action which adds annotations +-- ^ Check whether the given list of type parameters are all type variables +-- (possibly with a kind signature). +checkTyVars pp_what equals_or_where tc tparms + = do { (tvs, anns) <- fmap unzip $ mapM check tparms + ; return (mkHsQTvs tvs, concat anns) } + where + check (HsTypeArg _ ki@(L loc _)) + = addFatalError loc $ + vcat [ text "Unexpected type application" <+> + text "@" <> ppr ki + , text "In the" <+> pp_what <+> + ptext (sLit "declaration for") <+> quotes (ppr tc)] + check (HsValArg ty) = chkParens [] ty + check (HsArgPar sp) = addFatalError sp $ + vcat [text "Malformed" <+> pp_what + <+> text "declaration for" <+> quotes (ppr tc)] + -- Keep around an action for adjusting the annotations of extra parens + chkParens :: [AddAnn] -> LHsType GhcPs + -> P (LHsTyVarBndr () GhcPs, [AddAnn]) + chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty + chkParens acc ty = do + tv <- chk ty + return (tv, reverse acc) + + -- Check that the name space is correct! + chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) + chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) + | isRdrTyVar tv = return (L l (KindedTyVar noExtField () (L lv tv) k)) + chk (L l (HsTyVar _ _ (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar noExtField () (L ltv tv))) + chk t@(L loc _) + = addFatalError loc $ + vcat [ text "Unexpected type" <+> quotes (ppr t) + , text "In the" <+> pp_what + <+> ptext (sLit "declaration for") <+> quotes tc' + , vcat[ (text "A" <+> pp_what + <+> ptext (sLit "declaration should have form")) + , nest 2 + (pp_what + <+> tc' + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ] + + -- Avoid printing a constraint tuple in the error message. Print + -- a plain old tuple instead (since that's what the user probably + -- wrote). See #14907 + tc' = ppr $ fmap filterCTuple tc + + + +whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars +whereDots = text "where ..." +equalsDots = text "= ..." + +checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just c) + = do allowed <- getBit DatatypeContextsBit + unless allowed $ + addError (getLoc c) + (text "Illegal datatype context (use DatatypeContexts):" + <+> pprLHsContext c) + +type LRuleTyTmVar = Located RuleTyTmVar +data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) +-- ^ Essentially a wrapper for a @RuleBndr GhcPs@ + +-- turns RuleTyTmVars into RuleBnrs - this is straightforward +mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] +mkRuleBndrs = fmap (fmap cvt_one) + where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v + cvt_one (RuleTyTmVar v (Just sig)) = + RuleBndrSig noExtField v (mkHsPatSigType sig) + +-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting +mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] +mkRuleTyVarBndrs = fmap (fmap cvt_one) + where cvt_one (RuleTyTmVar v Nothing) + = UserTyVar noExtField () (fmap tm_to_ty v) + cvt_one (RuleTyTmVar v (Just sig)) + = KindedTyVar noExtField () (fmap tm_to_ty v) sig + -- takes something in namespace 'varName' to something in namespace 'tvName' + tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) + tm_to_ty _ = panic "mkRuleTyVarBndrs" + +-- See note [Parsing explicit foralls in Rules] in Parser.y +checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () +checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) + where check (L loc (Unqual occ)) = do + when ((occNameString occ ==) `any` ["forall","family","role"]) + (addFatalError loc (text $ "parse error on input " + ++ occNameString occ)) + check _ = panic "checkRuleTyVarBndrNames" + +checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) +checkRecordSyntax lr@(L loc r) + = do allowed <- getBit TraditionalRecordSyntaxBit + unless allowed $ addError loc $ + text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r + return lr + +-- | Check if the gadt_constrlist is empty. Only raise parse error for +-- `data T where` to avoid affecting existing error message, see #8258. +checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) + -> P (Located ([AddAnn], [LConDecl GhcPs])) +checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. + = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax + unless gadtSyntax $ addError span $ vcat + [ text "Illegal keyword 'where' in data declaration" + , text "Perhaps you intended to use GADTs or a similar language" + , text "extension to enable syntax: data T where" + ] + return gadts +checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. + +checkTyClHdr :: Bool -- True <=> class header + -- False <=> type header + -> LHsType GhcPs + -> P (Located RdrName, -- the head symbol (type or class name) + [LHsTypeArg GhcPs], -- parameters of head symbol + LexicalFixity, -- the declaration is in infix format + [AddAnn]) -- API Annotation for HsParTy when stripping parens +-- Well-formedness check and decomposition of type and class heads. +-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) +-- Int :*: Bool into (:*:, [Int, Bool]) +-- returning the pieces +checkTyClHdr is_cls ty + = goL ty [] [] Prefix + where + goL (L l ty) acc ann fix = go l ty acc ann fix + + -- workaround to define '*' despite StarIsType + go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix + = do { warnStarBndr l + ; let name = mkOccName tcClsName (starSym isUni) + ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } + + go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix + | isRdrTc tc = return (ltc, acc, fix, ann) + go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix + | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann) + go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix + go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix + go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix + go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix + = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann) + where + arity = length ts + tup_name | is_cls = cTupleTyConName arity + | otherwise = getName (tupleTyCon Boxed arity) + -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) + go l _ _ _ _ + = addFatalError l (text "Malformed head of type or class declaration:" + <+> ppr ty) + +-- | Yield a parse error if we have a function applied directly to a do block +-- etc. and BlockArguments is not enabled. +checkExpBlockArguments :: LHsExpr GhcPs -> PV () +checkCmdBlockArguments :: LHsCmd GhcPs -> PV () +(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) + where + checkExpr :: LHsExpr GhcPs -> PV () + checkExpr expr = do + case unLoc expr of + HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr + HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr + HsLam {} -> check (text "lambda expression") expr + HsCase {} -> check (text "case expression") expr + HsLamCase {} -> check (text "lambda-case expression") expr + HsLet {} -> check (text "let expression") expr + HsIf {} -> check (text "if expression") expr + HsProc {} -> check (text "proc expression") expr + _ -> return () + + checkCmd :: LHsCmd GhcPs -> PV () + checkCmd cmd = case unLoc cmd of + HsCmdLam {} -> check (text "lambda command") cmd + HsCmdCase {} -> check (text "case command") cmd + HsCmdIf {} -> check (text "if command") cmd + HsCmdLet {} -> check (text "let command") cmd + HsCmdDo {} -> check (text "do command") cmd + _ -> return () + + check :: Outputable a => SDoc -> Located a -> PV () + check element a = do + blockArguments <- getBit BlockArgumentsBit + unless blockArguments $ + addError (getLoc a) $ + text "Unexpected " <> element <> text " in function application:" + $$ nest 4 (ppr a) + $$ text "You could write it with parentheses" + $$ text "Or perhaps you meant to enable BlockArguments?" + +-- | Validate the context constraints and break up a context into a list +-- of predicates. +-- +-- @ +-- (Eq a, Ord b) --> [Eq a, Ord b] +-- Eq a --> [Eq a] +-- (Eq a) --> [Eq a] +-- (((Eq a))) --> [Eq a] +-- @ +checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) +checkContext (L l orig_t) + = check [] (L l orig_t) + where + check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can + -- be used as context constraints. + = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () + + check anns (L lp1 (HsParTy _ ty)) + -- to be sure HsParTy doesn't get into the way + = check anns' ty + where anns' = if l == lp1 then anns + else (anns ++ mkParensApiAnn lp1) + + -- no need for anns, returning original + check _anns _t = return ([],L l [L l orig_t]) + +checkImportDecl :: Maybe (Located Token) + -> Maybe (Located Token) + -> P () +checkImportDecl mPre mPost = do + let whenJust mg f = maybe (pure ()) f mg + + importQualifiedPostEnabled <- getBit ImportQualifiedPostBit + + -- Error if 'qualified' found in postpositive position and + -- 'ImportQualifiedPost' is not in effect. + whenJust mPost $ \post -> + when (not importQualifiedPostEnabled) $ + failOpNotEnabledImportQualifiedPost (getLoc post) + + -- Error if 'qualified' occurs in both pre and postpositive + -- positions. + whenJust mPost $ \post -> + when (isJust mPre) $ + failOpImportQualifiedTwice (getLoc post) + + -- Warn if 'qualified' found in prepositive position and + -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. + whenJust mPre $ \pre -> + warnPrepositiveQualifiedModule (getLoc pre) + +-- ------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) +checkPattern = runPV . checkLPat + +checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) + +checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) +checkLPat e@(L l _) = checkPat l e [] + +checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] + -> PV (LPat GhcPs) +checkPat loc (L l e@(PatBuilderVar (L _ c))) args + | isRdrDataCon c = return . L loc $ ConPat + { pat_con_ext = noExtField + , pat_con = L l c + , pat_args = PrefixCon args + } + | not (null args) && patIsRec c = + localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ + patFail l (ppr e) +checkPat loc (L _ (PatBuilderApp f e)) args + = do p <- checkLPat e + checkPat loc f (p : args) +checkPat loc (L _ e) [] + = do p <- checkAPat loc e + return (L loc p) +checkPat loc e _ + = patFail loc (ppr e) + +checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) +checkAPat loc e0 = do + nPlusKPatterns <- getBit NPlusKPatternsBit + case e0 of + PatBuilderPat p -> return p + PatBuilderVar x -> return (VarPat noExtField x) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by the lexer + PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) + + -- n+k patterns + PatBuilderOpApp + (L nloc (PatBuilderVar (L _ n))) + (L _ plus) + (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + | nPlusKPatterns && (plus == plus_RDR) + -> return (mkNPlusKPat (L nloc n) (L lloc lit)) + + -- Improve error messages for the @-operator when the user meant an @-pattern + PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do + addError (getLoc op) $ + text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$ + perhaps_as_pat + return (WildPat noExtField) + + PatBuilderOpApp l (L cl c) r + | isRdrDataCon c -> do + l <- checkLPat l + r <- checkLPat r + return $ ConPat + { pat_con_ext = noExtField + , pat_con = L cl c + , pat_args = InfixCon l r + } + + PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) + _ -> patFail loc (ppr e0) + +placeHolderPunRhs :: DisambECP b => PV (Located b) +-- The RHS of a punned record field will be filled in by the renamer +-- It's better not to make it an error, in case we want to print it when +-- debugging +placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) + +plus_RDR, pun_RDR :: RdrName +plus_RDR = mkUnqual varName (fsLit "+") -- Hack +pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") + +checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) + -> PV (LHsRecField GhcPs (LPat GhcPs)) +checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld) + return (L l (fld { hsRecFieldArg = p })) + +patFail :: SrcSpan -> SDoc -> PV a +patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e + +patIsRec :: RdrName -> Bool +patIsRec e = e == mkUnqual varName (fsLit "rec") + +opIsAt :: RdrName -> Bool +opIsAt e = e == mkUnqual varName (fsLit "@") + +--------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef :: Located (PatBuilder GhcPs) + -> Maybe (LHsType GhcPs) + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) + +checkValDef lhs (Just sig) grhss + -- x :: ty = rhs parses as a *pattern* binding + = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat + checkPatBind lhs' grhss + +checkValDef lhs Nothing g@(L l (_,grhss)) + = do { mb_fun <- isFunLhs lhs + ; case mb_fun of + Just (fun, is_infix, pats, ann) -> + checkFunBind NoSrcStrict ann (getLoc lhs) + fun is_infix pats (L l grhss) + Nothing -> do + lhs' <- checkPattern lhs + checkPatBind lhs' g } + +checkFunBind :: SrcStrictness + -> [AddAnn] + -> SrcSpan + -> Located RdrName + -> LexicalFixity + -> [Located (PatBuilder GhcPs)] + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) +checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) + = do ps <- runPV_msg param_hint (mapM checkLPat pats) + let match_span = combineSrcSpans lhs_loc rhs_span + -- Add back the annotations stripped from any HsPar values in the lhs + -- mapM_ (\a -> a match_span) ann + return (ann, makeFunBind fun + [L match_span (Match { m_ext = noExtField + , m_ctxt = FunRhs + { mc_fun = fun + , mc_fixity = is_infix + , mc_strictness = strictness } + , m_pats = ps + , m_grhss = grhss })]) + -- The span of the match covers the entire equation. + -- That isn't quite right, but it'll do for now. + where + param_hint + | Infix <- is_infix + = text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$ + if opIsAt (unLoc fun) then perhaps_as_pat else empty + | otherwise = empty + +perhaps_as_pat :: SDoc +perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" + +makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs +-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too +makeFunBind fn ms + = FunBind { fun_ext = noExtField, + fun_id = fn, + fun_matches = mkMatchGroup FromSource ms, + fun_tick = [] } + +-- See Note [FunBind vs PatBind] +checkPatBind :: LPat GhcPs + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) +checkPatBind lhs (L rhs_span (_,grhss)) + | BangPat _ p <- unLoc lhs + , VarPat _ v <- unLoc p + = return ([], makeFunBind v [L match_span (m v)]) + where + match_span = combineSrcSpans (getLoc lhs) rhs_span + m v = Match { m_ext = noExtField + , m_ctxt = FunRhs { mc_fun = v + , mc_fixity = Prefix + , mc_strictness = SrcStrict } + , m_pats = [] + , m_grhss = grhss } + +checkPatBind lhs (L _ (_,grhss)) + = return ([],PatBind noExtField lhs grhss ([],[])) + +checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) +checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) + | isUnqual v + , not (isDataOcc (rdrNameOcc v)) + = return lrdr + +checkValSigLhs lhs@(L l _) + = addFatalError l ((text "Invalid type signature:" <+> + ppr lhs <+> text ":: ...") + $$ text hint) + where + hint | foreign_RDR `looks_like` lhs + = "Perhaps you meant to use ForeignFunctionInterface?" + | default_RDR `looks_like` lhs + = "Perhaps you meant to use DefaultSignatures?" + | pattern_RDR `looks_like` lhs + = "Perhaps you meant to use PatternSynonyms?" + | otherwise + = "Should be of form :: " + + -- A common error is to forget the ForeignFunctionInterface flag + -- so check for that, and suggest. cf #3805 + -- Sadly 'foreign import' still barfs 'parse error' because + -- 'import' is a keyword + looks_like s (L _ (HsVar _ (L _ v))) = v == s + looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs + looks_like _ _ = False + + foreign_RDR = mkUnqual varName (fsLit "foreign") + default_RDR = mkUnqual varName (fsLit "default") + pattern_RDR = mkUnqual varName (fsLit "pattern") + +checkDoAndIfThenElse + :: (Outputable a, Outputable b, Outputable c) + => Located a -> Bool -> b -> Bool -> Located c -> PV () +checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr + | semiThen || semiElse + = do doAndIfThenElse <- getBit DoAndIfThenElseBit + unless doAndIfThenElse $ do + addError (combineLocs guardExpr elseExpr) + (text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + $$ text "Perhaps you meant to use DoAndIfThenElse?") + | otherwise = return () + where pprOptSemi True = semi + pprOptSemi False = empty + expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> + text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> + text "else" <+> ppr elseExpr + +isFunLhs :: Located (PatBuilder GhcPs) + -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) +-- A variable binding is parsed as a FunBind. +-- Just (fun, is_infix, arg_pats) if e is a function LHS +isFunLhs e = go e [] [] + where + go (L loc (PatBuilderVar (L _ f))) es ann + | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) + go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann + go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann + | not (isRdrDataCon op) -- We have found the function! + = return (Just (L loc' op, Infix, (l:r:es), ann)) + | otherwise -- Infix data con; keep going + = do { mb_l <- go l es ann + ; case mb_l of + Just (op', Infix, j : k : es', ann') + -> return (Just (op', Infix, j : op_app : es', ann')) + where + op_app = L loc (PatBuilderOpApp k + (L loc' op) r) + _ -> return Nothing } + go _ _ _ = return Nothing + +-- | Either an operator or an operand. +data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) + | TyElKindApp SrcSpan (LHsType GhcPs) + -- See Note [TyElKindApp SrcSpan interpretation] + | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) + + +{- Note [TyElKindApp SrcSpan interpretation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A TyElKindApp captures type application written in haskell as + + @ Foo + +where Foo is some type. + +The SrcSpan reflects both elements, and there are AnnAt and AnnVal API +Annotations attached to this SrcSpan for the specific locations of +each within it. +-} + +instance Outputable TyEl where + ppr (TyElOpr name) = ppr name + ppr (TyElOpd ty) = ppr ty + ppr (TyElKindApp _ ki) = text "@" <> ppr ki + ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk + +-- | Extract a strictness/unpackedness annotation from the front of a reversed +-- 'TyEl' list. +pUnpackedness + :: [Located TyEl] -- reversed TyEl + -> Maybe ( SrcSpan + , [AddAnn] + , SourceText + , SrcUnpackedness + , [Located TyEl] {- remaining TyEl -}) +pUnpackedness (L l x1 : xs) + | TyElUnpackedness (anns, prag, unpk) <- x1 + = Just (l, anns, prag, unpk, xs) +pUnpackedness _ = Nothing + +pBangTy + :: LHsType GhcPs -- a type to be wrapped inside HsBangTy + -> [Located TyEl] -- reversed TyEl + -> ( Bool {- has a strict mark been consumed? -} + , LHsType GhcPs {- the resulting BangTy -} + , P () {- add annotations -} + , [Located TyEl] {- remaining TyEl -}) +pBangTy lt@(L l1 _) xs = + case pUnpackedness xs of + Nothing -> (False, lt, pure (), xs) + Just (l2, anns, prag, unpk, xs') -> + let bl = combineSrcSpans l1 l2 + (anns2, bt) = addUnpackedness (prag, unpk) lt + in (True, L bl bt, addAnnsAt bl (anns ++ anns2), xs') + +mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy strictness = + HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness) + +addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsType GhcPs) +addUnpackedness (prag, unpk) (L l (HsBangTy x bang t)) + | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang + = let + anns = case strictness of + SrcLazy -> [AddAnn AnnTilde (srcSpanFirstCharacter l)] + SrcStrict -> [AddAnn AnnBang (srcSpanFirstCharacter l)] + NoSrcStrict -> [] + in (anns, HsBangTy x (HsSrcBang prag unpk strictness) t) +addUnpackedness (prag, unpk) t + = ([], HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t) + +-- | Merge a /reversed/ and /non-empty/ soup of operators and operands +-- into a type. +-- +-- User input: @F x y + G a b * X@ +-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F] +-- Output corresponds to what the user wrote assuming all operators are of the +-- same fixity and right-associative. +-- +-- It's a bit silly that we're doing it at all, as the renamer will have to +-- rearrange this, and it'd be easier to keep things separate. +-- +-- See Note [Parsing data constructors is hard] +mergeOps :: [Located TyEl] -> P (LHsType GhcPs) +mergeOps ((L l1 (TyElOpd t)) : xs) + | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs + , null xs' -- We accept a BangTy only when there are no preceding TyEl. + = addAnns >> return t' +mergeOps all_xs = go (0 :: Int) [] id all_xs + where + -- NB. When modifying clauses in 'go', make sure that the reasoning in + -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct. + + -- clause [unpk]: + -- handle (NO)UNPACK pragmas + go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = + if not (null acc) && null xs + then do { acc' <- eitherToP $ mergeOpsAcc acc + ; let a = ops_acc acc' + strictMark = HsSrcBang unpkSrc unpk NoSrcStrict + bl = combineSrcSpans l (getLoc a) + bt = HsBangTy noExtField strictMark a + ; addAnnsAt bl anns + ; return (L bl bt) } + else addFatalError l unpkError + where + unpkSDoc = case unpkSrc of + NoSourceText -> ppr unpk + SourceText str -> text str <> text " #-}" + unpkError + | not (null xs) = unpkSDoc <+> text "cannot appear inside a type." + | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type." + | otherwise = + -- See Note [Impossible case in mergeOps clause [unpk]] + panic "mergeOps.UNPACK: impossible position" + + -- clause [opr]: + -- when we encounter an operator, we must have accumulated + -- something for its rhs, and there must be something left + -- to build its lhs. + go k acc ops_acc ((L l (TyElOpr op)):xs) = + if null acc || null (filter isTyElOpd xs) + then failOpFewArgs (L l op) + else do { acc' <- eitherToP (mergeOpsAcc acc) + ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs } + where + isTyElOpd (L _ (TyElOpd _)) = True + isTyElOpd _ = False + + -- clause [opd]: + -- whenever an operand is encountered, it is added to the accumulator + go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs + + -- clause [tyapp]: + -- whenever a type application is encountered, it is added to the accumulator + go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs + + -- clause [end] + -- See Note [Non-empty 'acc' in mergeOps clause [end]] + go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc) + ; return (ops_acc acc') } + +mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] + -> Either (SrcSpan, SDoc) (LHsType GhcPs) +mergeOpsAcc [] = panic "mergeOpsAcc: empty input" +mergeOpsAcc (HsTypeArg _ (L loc ki):_) + = Left (loc, text "Unexpected type application:" <+> ppr ki) +mergeOpsAcc (HsValArg ty : xs) = go1 ty xs + where + go1 :: LHsType GhcPs + -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)] + -> Either (SrcSpan, SDoc) (LHsType GhcPs) + go1 lhs [] = Right lhs + go1 lhs (x:xs) = case x of + HsValArg ty -> go1 (mkHsAppTy lhs ty) xs + HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki + in go1 ty xs + HsArgPar _ -> go1 lhs xs +mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs + +{- Note [Impossible case in mergeOps clause [unpk]] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This case should never occur. Let us consider all possible +variations of 'acc', 'xs', and 'k': + + acc xs k +============================== + null | null 0 -- "must be applied to a type" + null | not null 0 -- "must be applied to a type" +not null | null 0 -- successful parse +not null | not null 0 -- "cannot appear inside a type" + null | null >0 -- handled in clause [opr] + null | not null >0 -- "cannot appear inside a type" +not null | null >0 -- successful parse +not null | not null >0 -- "cannot appear inside a type" + +The (null acc && null xs && k>0) case is handled in clause [opr] +by the following check: + + if ... || null (filter isTyElOpd xs) + then failOpFewArgs (L l op) + +We know that this check has been performed because k>0, and by +the time we reach the end of the list (null xs), the only way +for (null acc) to hold is that there was not a single TyElOpd +between the operator and the end of the list. But this case is +caught by the check and reported as 'failOpFewArgs'. +-} + +{- Note [Non-empty 'acc' in mergeOps clause [end]] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc' +without a check. + +Running 'mergeOps' with an empty input list is forbidden, so we do not consider +this possibility. This means we'll hit at least one other clause before we +reach clause [end]. + +* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit + clause [end] from there. +* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc' + will be non-empty. +* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going + to hit clause [opd] at least once before we reach clause [end], making 'acc' + non-empty. +* There are no other clauses. + +Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause +[end]. + +-} + +pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) +pInfixSide ((L l (TyElOpd t)):xs) + | (True, t', addAnns, xs') <- pBangTy (L l t) xs + = Just (t', addAnns, xs') +pInfixSide (el:xs1) + | Just t1 <- pLHsTypeArg el + = go [t1] xs1 + where + go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] + -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) + go acc (el:xs) + | Just t <- pLHsTypeArg el + = go (t:acc) xs + go acc xs = case mergeOpsAcc acc of + Left _ -> Nothing + Right acc' -> Just (acc', pure (), xs) +pInfixSide _ = Nothing + +pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) +pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a)) +pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a) +pLHsTypeArg _ = Nothing + +orErr :: Maybe a -> b -> Either b a +orErr (Just a) _ = Right a +orErr Nothing b = Left b + +-- | Merge a /reversed/ and /non-empty/ soup of operators and operands +-- into a data constructor. +-- +-- User input: @C !A B -- ^ doc@ +-- Input to 'mergeDataCon': ["doc", B, !A, C] +-- Output: (C, PrefixCon [!A, B], "doc") +-- +-- See Note [Parsing data constructors is hard] +mergeDataCon + :: [Located TyEl] + -> P ( Located RdrName -- constructor name + , HsConDeclDetails GhcPs -- constructor field information + ) +mergeDataCon all_xs = + do { (addAnns, a) <- eitherToP res + ; addAnns + ; return a } + where + -- The result of merging the list of reversed TyEl into a + -- data constructor, along with [AddAnn]. + res = goFirst all_xs + + goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] + = do { data_con <- tyConToDataCon l tc + ; return (pure (), (data_con, PrefixCon [])) } + goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs) + | [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs + = do { data_con <- tyConToDataCon l' tc + ; return (pure (), (data_con, RecCon (L l fields))) } + goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] + = return ( pure () + , ( L l (getRdrName (tupleDataCon Boxed (length ts))) + , PrefixCon (map hsLinear ts) ) ) + goFirst ((L l (TyElOpd t)):xs) + | (_, t', addAnns, xs') <- pBangTy (L l t) xs + = go addAnns [t'] xs' + goFirst (L l (TyElKindApp _ _):_) + = goInfix Monoid.<> Left (l, kindAppErr) + goFirst xs + = go (pure ()) [] xs + + go addAnns ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] + = do { data_con <- tyConToDataCon l tc + ; return (addAnns, (data_con, PrefixCon (map hsLinear ts))) } + go addAnns ts ((L l (TyElOpd t)):xs) + | (_, t', addAnns', xs') <- pBangTy (L l t) xs + = go (addAnns >> addAnns') (t':ts) xs' + go _ _ ((L _ (TyElOpr _)):_) = + -- Encountered an operator: backtrack to the beginning and attempt + -- to parse as an infix definition. + goInfix + go _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) + go _ _ _ = Left malformedErr + where + malformedErr = + ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs) + , text "Cannot parse data constructor" <+> + text "in a data/newtype declaration:" $$ + nest 2 (hsep . reverse $ map ppr all_xs)) + + goInfix = + do { let xs0 = all_xs + ; (rhs, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr + ; (op, xs3) <- case xs1 of + (L l (TyElOpr op)) : xs3 -> + do { data_con <- tyConToDataCon l op + ; return (data_con, xs3) } + _ -> Left malformedErr + ; (lhs, lhs_addAnns, xs5) <- pInfixSide xs3 `orErr` malformedErr + ; unless (null xs5) (Left malformedErr) + ; let addAnns = lhs_addAnns >> rhs_addAnns + ; return (addAnns, (op, InfixCon (hsLinear lhs) (hsLinear rhs))) } + where + malformedErr = + ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs) + , text "Cannot parse an infix data constructor" <+> + text "in a data/newtype declaration:" $$ + nest 2 (hsep . reverse $ map ppr all_xs)) + + kindAppErr = + text "Unexpected kind application" <+> + text "in a data/newtype declaration:" $$ + nest 2 (hsep . reverse $ map ppr all_xs) + +--------------------------------------------------------------------------- +-- | Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a 'MonadComp' context, +-- otherwise use the usual 'ListComp' context + +checkMonadComp :: PV (HsStmtContext GhcRn) +checkMonadComp = do + monadComprehensions <- getBit MonadComprehensionsBit + return $ if monadComprehensions + then MonadComp + else ListComp + +-- ------------------------------------------------------------------------- +-- Expression/command/pattern ambiguity. +-- See Note [Ambiguous syntactic categories] +-- + +-- See Note [Parser-Validator] +-- See Note [Ambiguous syntactic categories] +-- +-- This newtype is required to avoid impredicative types in monadic +-- productions. That is, in a production that looks like +-- +-- | ... {% return (ECP ...) } +-- +-- we are dealing with +-- P ECP +-- whereas without a newtype we would be dealing with +-- P (forall b. DisambECP b => PV (Located b)) +-- +newtype ECP = + ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) } + +runECP_P :: DisambECP b => ECP -> P (Located b) +runECP_P p = runPV (runECP_PV p) + +ecpFromExp :: LHsExpr GhcPs -> ECP +ecpFromExp a = ECP (ecpFromExp' a) + +ecpFromCmd :: LHsCmd GhcPs -> ECP +ecpFromCmd a = ECP (ecpFromCmd' a) + +-- | Disambiguate infix operators. +-- See Note [Ambiguous syntactic categories] +class DisambInfixOp b where + mkHsVarOpPV :: Located RdrName -> PV (Located b) + mkHsConOpPV :: Located RdrName -> PV (Located b) + mkHsInfixHolePV :: SrcSpan -> PV (Located b) + +instance DisambInfixOp (HsExpr GhcPs) where + mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsInfixHolePV l = return $ L l hsHoleExpr + +instance DisambInfixOp RdrName where + mkHsConOpPV (L l v) = return $ L l v + mkHsVarOpPV (L l v) = return $ L l v + mkHsInfixHolePV l = + addFatalError l $ text "Invalid infix hole, expected an infix operator" + +-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are +-- parsing an expression, a command, or a pattern. +-- See Note [Ambiguous syntactic categories] +class b ~ (Body b) GhcPs => DisambECP b where + -- | See Note [Body in DisambECP] + type Body b :: Type -> Type + -- | Return a command without ambiguity, or fail in a non-command context. + ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) + -- | Return an expression without ambiguity, or fail in a non-expression context. + ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) + -- | Disambiguate "\... -> ..." (lambda) + mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) + -- | Disambiguate "let ... in ..." + mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) + -- | Infix operator representation + type InfixOp b + -- | Bring superclass constraints on InfixOp into scope. + -- See Note [UndecidableSuperClasses for associated types] + superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) + -- | Disambiguate "f # x" (infix operator) + mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) + -- | Disambiguate "case ... of ..." + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) + -- | Disambiguate @\\case ...@ (lambda case) + mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) + -- | Function argument representation + type FunArg b + -- | Bring superclass constraints on FunArg into scope. + -- See Note [UndecidableSuperClasses for associated types] + superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) + -- | Disambiguate "f x" (function application) + mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) + -- | Disambiguate "f @t" (visible type application) + mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + -- | Disambiguate "if ... then ... else ..." + mkHsIfPV :: SrcSpan + -> LHsExpr GhcPs + -> Bool -- semicolon? + -> Located b + -> Bool -- semicolon? + -> Located b + -> PV (Located b) + -- | Disambiguate "do { ... }" (do notation) + mkHsDoPV :: + SrcSpan -> + Maybe ModuleName -> + Located [LStmt GhcPs (Located b)] -> + PV (Located b) + -- | Disambiguate "( ... )" (parentheses) + mkHsParPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate a variable "f" or a data constructor "MkF". + mkHsVarPV :: Located RdrName -> PV (Located b) + -- | Disambiguate a monomorphic literal + mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) + -- | Disambiguate an overloaded literal + mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b) + -- | Disambiguate a wildcard + mkHsWildCardPV :: SrcSpan -> PV (Located b) + -- | Disambiguate "a :: t" (type annotation) + mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + -- | Disambiguate "[a,b,c]" (list syntax) + mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) + -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) + mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) + -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) + mkHsRecordPV :: + SrcSpan -> + SrcSpan -> + Located b -> + ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> + PV (Located b) + -- | Disambiguate "-a" (negation) + mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate "(# a)" (right operator section) + mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) + -- | Disambiguate "(a -> b)" (view pattern) + mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) + -- | Disambiguate "a@b" (as-pattern) + mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) + -- | Disambiguate "~a" (lazy pattern) + mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate "!a" (bang pattern) + mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate tuple sections and unboxed sums + mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) + -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas + rejectPragmaPV :: Located b -> PV () + + +{- Note [UndecidableSuperClasses for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This Note is about the code in GHC, not about the user code that we are parsing) + +Assume we have a class C with an associated type T: + + class C a where + type T a + ... + +If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: + + {-# LANGUAGE UndecidableSuperClasses #-} + class C (T a) => C a where + type T a + ... + +Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes +making GHC loop. The workaround is to bring this constraint into scope +manually with a helper method: + + class C a where + type T a + superT :: (C (T a) => r) -> r + +In order to avoid ambiguous types, 'r' must mention 'a'. + +For consistency, we use this approach for all constraints on associated types, +even when -XUndecidableSuperClasses are not required. +-} + +{- Note [Body in DisambECP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that +require their argument to take a form of (body GhcPs) for some (body :: Type -> +*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the +superclass constraints of DisambECP. + +The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop +this requirement. It is possible and would allow removing the type index of +PatBuilder, but leads to worse type inference, breaking some code in the +typechecker. +-} + +instance DisambECP (HsCmd GhcPs) where + type Body (HsCmd GhcPs) = HsCmd + ecpFromCmd' = return + ecpFromExp' (L l e) = cmdFail l (ppr e) + mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg) + mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e) + type InfixOp (HsCmd GhcPs) = HsExpr GhcPs + superInfixOp m = m + mkHsOpAppPV l c1 op c2 = do + let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c + return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg) + mkHsLamCasePV l mg = return $ L l (HsCmdLamCase noExtField mg) + type FunArg (HsCmd GhcPs) = HsExpr GhcPs + superFunArg m = m + mkHsAppPV l c e = do + checkCmdBlockArguments c + checkExpBlockArguments e + return $ L l (HsCmdApp noExtField c e) + mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t) + mkHsIfPV l c semi1 a semi2 b = do + checkDoAndIfThenElse c semi1 a semi2 b + return $ L l (mkHsCmdIf c a b) + mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts) + mkHsDoPV l (Just m) _ = + cmdFail l $ + text "Found a qualified" <+> ppr m <> text ".do block in a command, but" + $$ text "qualified 'do' is not supported in commands." + mkHsParPV l c = return $ L l (HsCmdPar noExtField c) + mkHsVarPV (L l v) = cmdFail l (ppr v) + mkHsLitPV (L l a) = cmdFail l (ppr a) + mkHsOverLitPV (L l a) = cmdFail l (ppr a) + mkHsWildCardPV l = cmdFail l (text "_") + mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) + mkHsExplicitListPV l xs = cmdFail l $ + brackets (fsep (punctuate comma (map ppr xs))) + mkHsSplicePV (L l sp) = cmdFail l (ppr sp) + mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ + ppr a <+> ppr (mk_rec_fields fbinds ddLoc) + mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) + mkHsSectionR_PV l op c = cmdFail l $ + let pp_op = fromMaybe (panic "cannot print infix operator") + (ppr_infix_expr (unLoc op)) + in pp_op <> ppr c + mkHsViewPatPV l a b = cmdFail l $ + ppr a <+> text "->" <+> ppr b + mkHsAsPatPV l v c = cmdFail l $ + pprPrefixOcc (unLoc v) <> text "@" <> ppr c + mkHsLazyPatPV l c = cmdFail l $ + text "~" <> ppr c + mkHsBangPatPV l c = cmdFail l $ + text "!" <> ppr c + mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) + rejectPragmaPV _ = return () + +cmdFail :: SrcSpan -> SDoc -> PV a +cmdFail loc e = addFatalError loc $ + hang (text "Parse error in command:") 2 (ppr e) + +instance DisambECP (HsExpr GhcPs) where + type Body (HsExpr GhcPs) = HsExpr + ecpFromCmd' (L l c) = do + addError l $ vcat + [ text "Arrow command found where an expression was expected:", + nest 2 (ppr c) ] + return (L l hsHoleExpr) + ecpFromExp' = return + mkHsLamPV l mg = return $ L l (HsLam noExtField mg) + mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) + type InfixOp (HsExpr GhcPs) = HsExpr GhcPs + superInfixOp m = m + mkHsOpAppPV l e1 op e2 = do + return $ L l $ OpApp noExtField e1 op e2 + mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg) + mkHsLamCasePV l mg = return $ L l (HsLamCase noExtField mg) + type FunArg (HsExpr GhcPs) = HsExpr GhcPs + superFunArg m = m + mkHsAppPV l e1 e2 = do + checkExpBlockArguments e1 + checkExpBlockArguments e2 + return $ L l (HsApp noExtField e1 e2) + mkHsAppTypePV l e t = do + checkExpBlockArguments e + return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t)) + mkHsIfPV l c semi1 a semi2 b = do + checkDoAndIfThenElse c semi1 a semi2 b + return $ L l (mkHsIf c a b) + mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts) + mkHsParPV l e = return $ L l (HsPar noExtField e) + mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v) + mkHsLitPV (L l a) = return $ L l (HsLit noExtField a) + mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a) + mkHsWildCardPV l = return $ L l hsHoleExpr + mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) + mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs) + mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp + mkHsRecordPV l lrec a (fbinds, ddLoc) = do + r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) + checkRecordSyntax (L l r) + mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) + mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e) + mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty + mkHsAsPatPV l v e = + patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $ + text "Type application syntax requires a space before '@'" + mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $ + text "Did you mean to add a space after the '~'?" + mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $ + text "Did you mean to add a space after the '!'?" + mkSumOrTuplePV = mkSumOrTupleExpr + rejectPragmaPV (L _ (OpApp _ _ _ e)) = + -- assuming left-associative parsing of operators + rejectPragmaPV e + rejectPragmaPV (L l (HsPragE _ prag _)) = + addError l $ + hang (text "A pragma is not allowed in this position:") 2 (ppr prag) + rejectPragmaPV _ = return () + +patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) +patSynErr item l e explanation = + do { addError l $ + sep [text item <+> text "in expression context:", + nest 4 (ppr e)] $$ + explanation + ; return (L l hsHoleExpr) } + +hsHoleExpr :: HsExpr (GhcPass id) +hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") + +-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] +data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderPar (Located (PatBuilder p)) + | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) + | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + | PatBuilderVar (Located RdrName) + | PatBuilderOverLit (HsOverLit GhcPs) + +instance Outputable (PatBuilder GhcPs) where + ppr (PatBuilderPat p) = ppr p + ppr (PatBuilderPar (L _ p)) = parens (ppr p) + ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 + ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 + ppr (PatBuilderVar v) = ppr v + ppr (PatBuilderOverLit l) = ppr l + +instance DisambECP (PatBuilder GhcPs) where + type Body (PatBuilder GhcPs) = PatBuilder + ecpFromCmd' (L l c) = + addFatalError l $ + text "Command syntax in pattern:" <+> ppr c + ecpFromExp' (L l e) = + addFatalError l $ + text "Expression syntax in pattern:" <+> ppr e + mkHsLamPV l _ = addFatalError l $ + text "Lambda-syntax in pattern." $$ + text "Pattern matching on functions is not possible." + mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" + type InfixOp (PatBuilder GhcPs) = RdrName + superInfixOp m = m + mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 + mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" + mkHsLamCasePV l _ = addFatalError l $ text "(\\case ...)-syntax in pattern" + type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs + superFunArg m = m + mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) + mkHsAppTypePV l _ _ = addFatalError l $ + text "Type applications in patterns are not yet supported" + mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" + mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern" + mkHsParPV l p = return $ L l (PatBuilderPar p) + mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) + mkHsLitPV lit@(L l a) = do + checkUnboxedStringLitPat lit + return $ L l (PatBuilderPat (LitPat noExtField a)) + mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) + mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) + mkHsTySigPV l b sig = do + p <- checkLPat b + return $ L l (PatBuilderPat (SigPat noExtField p (mkHsPatSigType sig))) + mkHsExplicitListPV l xs = do + ps <- traverse checkLPat xs + return (L l (PatBuilderPat (ListPat noExtField ps))) + mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) + mkHsRecordPV l _ a (fbinds, ddLoc) = do + r <- mkPatRec a (mk_rec_fields fbinds ddLoc) + checkRecordSyntax (L l r) + mkHsNegAppPV l (L lp p) = do + lit <- case p of + PatBuilderOverLit pos_lit -> return (L lp pos_lit) + _ -> patFail l (text "-" <> ppr p) + return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) + mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p) + mkHsViewPatPV l a b = do + p <- checkLPat b + return $ L l (PatBuilderPat (ViewPat noExtField a p)) + mkHsAsPatPV l v e = do + p <- checkLPat e + return $ L l (PatBuilderPat (AsPat noExtField v p)) + mkHsLazyPatPV l e = do + p <- checkLPat e + return $ L l (PatBuilderPat (LazyPat noExtField p)) + mkHsBangPatPV l e = do + p <- checkLPat e + let pb = BangPat noExtField p + hintBangPat l pb + return $ L l (PatBuilderPat pb) + mkSumOrTuplePV = mkSumOrTuplePat + rejectPragmaPV _ = return () + +checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () +checkUnboxedStringLitPat (L loc lit) = + case lit of + HsStringPrim _ _ -- Trac #13260 + -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) + _ -> return () + +mkPatRec :: + Located (PatBuilder GhcPs) -> + HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> + PV (PatBuilder GhcPs) +mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) + | isRdrDataCon (unLoc c) + = do fs <- mapM checkPatField fs + return $ PatBuilderPat $ ConPat + { pat_con_ext = noExtField + , pat_con = c + , pat_args = RecCon (HsRecFields fs dd) + } +mkPatRec p _ = + addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p + +{- Note [Ambiguous syntactic categories] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are places in the grammar where we do not know whether we are parsing an +expression or a pattern without unlimited lookahead (which we do not have in +'happy'): + +View patterns: + + f (Con a b ) = ... -- 'Con a b' is a pattern + f (Con a b -> x) = ... -- 'Con a b' is an expression + +do-notation: + + do { Con a b <- x } -- 'Con a b' is a pattern + do { Con a b } -- 'Con a b' is an expression + +Guards: + + x | True <- p && q = ... -- 'True' is a pattern + x | True = ... -- 'True' is an expression + +Top-level value/function declarations (FunBind/PatBind): + + f ! a -- TH splice + f ! a = ... -- function declaration + + Until we encounter the = sign, we don't know if it's a top-level + TemplateHaskell splice where ! is used, or if it's a function declaration + where ! is bound. + +There are also places in the grammar where we do not know whether we are +parsing an expression or a command: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) } -- 'stuff' is a command + + Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' + as an expression or a command. + +In fact, do-notation is subject to both ambiguities: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern + proc x -> do { (stuff) } -- 'stuff' is a command + +There are many possible solutions to this problem. For an overview of the ones +we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] + +The solution that keeps basic definitions (such as HsExpr) clean, keeps the +concerns local to the parser, and does not require duplication of hsSyn types, +or an extra pass over the entire AST, is to parse into an overloaded +parser-validator (a so-called tagless final encoding): + + class DisambECP b where ... + instance DisambECP (HsCmd GhcPs) where ... + instance DisambECP (HsExp GhcPs) where ... + instance DisambECP (PatBuilder GhcPs) where ... + +The 'DisambECP' class contains functions to build and validate 'b'. For example, +to add parentheses we have: + + mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) + +'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for +expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, +see Note [PatBuilder]). + +Consider the 'alts' production used to parse case-of alternatives: + + alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +We abstract over LHsExpr GhcPs, and it becomes: + + alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } + : alts1 { $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Compared to the initial definition, the added bits are: + + forall b. DisambECP b => PV ( ... ) -- in the type signature + $1 >>= \ $1 -> return $ -- in one reduction rule + $2 >>= \ $2 -> return $ -- in another reduction rule + +The overhead is constant relative to the size of the rest of the reduction +rule, so this approach scales well to large parser productions. + +Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding +position and shadows the previous $1. We can do this because internally +'happy' desugars $n to happy_var_n, and the rationale behind this idiom +is to be able to write (sLL $1 $>) later on. The alternative would be to +write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer +to the last fresh name as $>. +-} + + +{- Note [Resolving parsing ambiguities: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I, extra constructors in GHC.Hs.Expr +------------------------------------------------ +We could add extra constructors to HsExpr to represent command-specific and +pattern-specific syntactic constructs. Under this scheme, we parse patterns +and commands as expressions and rejig later. This is what GHC used to do, and +it polluted 'HsExpr' with irrelevant constructors: + + * for commands: 'HsArrForm', 'HsArrApp' + * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' + +(As of now, we still do that for patterns, but we plan to fix it). + +There are several issues with this: + + * The implementation details of parsing are leaking into hsSyn definitions. + + * Code that uses HsExpr has to panic on these impossible-after-parsing cases. + + * HsExpr is arbitrarily selected as the extension basis. Why not extend + HsCmd or HsPat with extra constructors instead? + +Alternative II, extra constructors in GHC.Hs.Expr for GhcPs +----------------------------------------------------------- +We could address some of the problems with Alternative I by using Trees That +Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to +the output of parsing, not to its intermediate results, so we wouldn't want +them there either. + +Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs +--------------------------------------------------------------- +We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. +Unfortunately, creating a new pass would significantly bloat conversion code +and slow down the compiler by adding another linear-time pass over the entire +AST. For example, in order to build HsExpr GhcPrePs, we would need to build +HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds +GhcPrePs. + + +Alternative IV, sum type and bottom-up data flow +------------------------------------------------ +Expressions and commands are disjoint. There are no user inputs that could be +interpreted as either an expression or a command depending on outer context: + + 5 -- definitely an expression + x -< y -- definitely a command + +Even though we have both 'HsLam' and 'HsCmdLam', we can look at +the body to disambiguate: + + \p -> 5 -- definitely an expression + \p -> x -< y -- definitely a command + +This means we could use a bottom-up flow of information to determine +whether we are parsing an expression or a command, using a sum type +for intermediate results: + + Either (LHsExpr GhcPs) (LHsCmd GhcPs) + +There are two problems with this: + + * We cannot handle the ambiguity between expressions and + patterns, which are not disjoint. + + * Bottom-up flow of information leads to poor error messages. Consider + + if ... then 5 else (x -< y) + + Do we report that '5' is not a valid command or that (x -< y) is not a + valid expression? It depends on whether we want the entire node to be + 'HsIf' or 'HsCmdIf', and this information flows top-down, from the + surrounding parsing context (are we in 'proc'?) + +Alternative V, backtracking with parser combinators +--------------------------------------------------- +One might think we could sidestep the issue entirely by using a backtracking +parser and doing something along the lines of (try pExpr <|> pPat). + +Turns out, this wouldn't work very well, as there can be patterns inside +expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns +(e.g. view patterns). To handle this, we would need to backtrack while +backtracking, and unbound levels of backtracking lead to very fragile +performance. + +Alternative VI, an intermediate data type +----------------------------------------- +There are common syntactic elements of expressions, commands, and patterns +(e.g. all of them must have balanced parentheses), and we can capture this +common structure in an intermediate data type, Frame: + +data Frame + = FrameVar RdrName + -- ^ Identifier: Just, map, BS.length + | FrameTuple [LTupArgFrame] Boxity + -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) + | FrameTySig LFrame (LHsSigWcType GhcPs) + -- ^ Type signature: x :: ty + | FramePar (SrcSpan, SrcSpan) LFrame + -- ^ Parentheses + | FrameIf LFrame LFrame LFrame + -- ^ If-expression: if p then x else y + | FrameCase LFrame [LFrameMatch] + -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } + | FrameDo (HsStmtContext GhcRn) [LFrameStmt] + -- ^ Do-expression: do { s1; a <- s2; s3 } + ... + | FrameExpr (HsExpr GhcPs) -- unambiguously an expression + | FramePat (HsPat GhcPs) -- unambiguously a pattern + | FrameCommand (HsCmd GhcPs) -- unambiguously a command + +To determine which constructors 'Frame' needs to have, we take the union of +intersections between HsExpr, HsCmd, and HsPat. + +The intersection between HsPat and HsExpr: + + HsPat = VarPat | TuplePat | SigPat | ParPat | ... + HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... + ------------------------------------------------------------------- + Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... + +The intersection between HsCmd and HsExpr: + + HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar + HsExpr = HsIf | HsCase | HsDo | HsPar + ------------------------------------------------ + Frame = FrameIf | FrameCase | FrameDo | FramePar + +The intersection between HsCmd and HsPat: + + HsPat = ParPat | ... + HsCmd = HsCmdPar | ... + ----------------------- + Frame = FramePar | ... + +Take the union of each intersection and this yields the final 'Frame' data +type. The problem with this approach is that we end up duplicating a good +portion of hsSyn: + + Frame for HsExpr, HsPat, HsCmd + TupArgFrame for HsTupArg + FrameMatch for Match + FrameStmt for StmtLR + FrameGRHS for GRHS + FrameGRHSs for GRHSs + ... + +Alternative VII, a product type +------------------------------- +We could avoid the intermediate representation of Alternative VI by parsing +into a product of interpretations directly: + + -- See Note [Parser-Validator] + type ExpCmdPat = ( PV (LHsExpr GhcPs) + , PV (LHsCmd GhcPs) + , PV (LHsPat GhcPs) ) + +This means that in positions where we do not know whether to produce +expression, a pattern, or a command, we instead produce a parser-validator for +each possible option. + +Then, as soon as we have parsed far enough to resolve the ambiguity, we pick +the appropriate component of the product, discarding the rest: + + checkExpOf3 (e, _, _) = e -- interpret as an expression + checkCmdOf3 (_, c, _) = c -- interpret as a command + checkPatOf3 (_, _, p) = p -- interpret as a pattern + +We can easily define ambiguities between arbitrary subsets of interpretations. +For example, when we know ahead of type that only an expression or a command is +possible, but not a pattern, we can use a smaller type: + + -- See Note [Parser-Validator] + type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) + + checkExpOf2 (e, _) = e -- interpret as an expression + checkCmdOf2 (_, c) = c -- interpret as a command + +However, there is a slight problem with this approach, namely code duplication +in parser productions. Consider the 'alts' production used to parse case-of +alternatives: + + alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Under the new scheme, we have to completely duplicate its type signature and +each reduction rule: + + alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression + , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command + ) } + : alts1 + { ( checkExpOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + , checkCmdOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + ) } + | ';' alts + { ( checkExpOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + , checkCmdOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + ) } + +And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', +'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! + +Alternative VIII, a function from a GADT +---------------------------------------- +We could avoid code duplication of the Alternative VII by representing the product +as a function from a GADT: + + data ExpCmdG b where + ExpG :: ExpCmdG HsExpr + CmdG :: ExpCmdG HsCmd + + type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) + + checkExp :: ExpCmd -> PV (LHsExpr GhcPs) + checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) + checkExp f = f ExpG -- interpret as an expression + checkCmd f = f CmdG -- interpret as a command + +Consider the 'alts' production used to parse case-of alternatives: + + alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +We abstract over LHsExpr, and it becomes: + + alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 + { \tag -> $1 tag >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts + { \tag -> $2 tag >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Note that 'ExpCmdG' is a singleton type, the value is completely +determined by the type: + + when (b~HsExpr), tag = ExpG + when (b~HsCmd), tag = CmdG + +This is a clear indication that we can use a class to pass this value behind +the scenes: + + class ExpCmdI b where expCmdG :: ExpCmdG b + instance ExpCmdI HsExpr where expCmdG = ExpG + instance ExpCmdI HsCmd where expCmdG = CmdG + +And now the 'alts' production is simplified, as we no longer need to +thread 'tag' explicitly: + + alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 { $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +This encoding works well enough, but introduces an extra GADT unlike the +tagless final encoding, and there's no need for this complexity. + +-} + +{- Note [PatBuilder] +~~~~~~~~~~~~~~~~~~~~ +Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms, +so we introduce the notion of a PatBuilder. + +Consider a pattern like this: + + Con a b c + +We parse arguments to "Con" one at a time in the fexp aexp parser production, +building the result with mkHsAppPV, so the intermediate forms are: + + 1. Con + 2. Con a + 3. Con a b + 4. Con a b c + +In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like +this (pseudocode): + + 1. "Con" + 2. HsApp "Con" "a" + 3. HsApp (HsApp "Con" "a") "b" + 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" + +Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have +instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for +the intermediate forms. + +We also need an intermediate representation to postpone disambiguation between +FunBind and PatBind. Consider: + + a `Con` b = ... + a `fun` b = ... + +How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We +learn this by inspecting an intermediate representation in 'isFunLhs' and +seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate +representation capable of representing both a FunBind and a PatBind, so Pat is +insufficient. + +PatBuilder is an extension of Pat that is capable of representing intermediate +parsing results for patterns and function bindings: + + data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) + | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + ... + +It can represent any pattern via 'PatBuilderPat', but it also has a variety of +other constructors which were added by following a simple principle: we never +pattern match on the pattern stored inside 'PatBuilderPat'. +-} + +--------------------------------------------------------------------------- +-- Miscellaneous utilities + +-- | Check if a fixity is valid. We support bypassing the usual bound checks +-- for some special operators. +checkPrecP + :: Located (SourceText,Int) -- ^ precedence + -> Located (OrdList (Located RdrName)) -- ^ operators + -> P () +checkPrecP (L l (_,i)) (L _ ol) + | 0 <= i, i <= maxPrecedence = pure () + | all specialOp ol = pure () + | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) + where + -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs + specialOp op = unLoc op `elem` [ eqTyCon_RDR + , getRdrName unrestrictedFunTyCon ] + +mkRecConstrOrUpdate + :: LHsExpr GhcPs + -> SrcSpan + -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) + -> PV (HsExpr GhcPs) + +mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) + | isRdrDataCon c + = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp _ (fs,dd) + | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") + | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) + +mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs +mkRdrRecordUpd exp flds + = RecordUpd { rupd_ext = noExtField + , rupd_expr = exp + , rupd_flds = flds } + +mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs +mkRdrRecordCon con flds + = RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds } + +mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg +mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs + , rec_dotdot = Just (L s (length fs)) } + +mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs +mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) + = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun + +mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation + -> InlinePragma +-- The (Maybe Activation) is because the user can omit +-- the activation spec (and usually does) +mkInlinePragma src (inl, match_info) mb_act + = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.Basic + , inl_inline = inl + , inl_sat = Nothing + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing -> -- No phase specified + case inl of + NoInline -> NeverActive + _other -> AlwaysActive + +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- construct a foreign import declaration +-- +mkImport :: Located CCallConv + -> Located Safety + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) +mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = + case unLoc cconv of + CCallConv -> mkCImport + CApiConv -> mkCImport + StdCallConv -> mkCImport + PrimCallConv -> mkOtherImport + JavaScriptCallConv -> mkOtherImport + where + -- Parse a C-like entity string of the following form: + -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" + -- If 'cid' is missing, the function name 'v' is used instead as symbol + -- name (cf section 8.5.1 in Haskell 2010 report). + mkCImport = do + let e = unpackFS entity + case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of + Nothing -> addFatalError loc (text "Malformed entity string") + Just importSpec -> returnSpec importSpec + + -- currently, all the other import conventions only support a symbol name in + -- the entity string. If it is missing, we use the function name instead. + mkOtherImport = returnSpec importSpec + where + entity' = if nullFS entity + then mkExtName (unLoc v) + else entity + funcTarget = CFunction (StaticTarget esrc entity' Nothing True) + importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) + + returnSpec spec = return $ ForD noExtField $ ForeignImport + { fd_i_ext = noExtField + , fd_name = v + , fd_sig_ty = ty + , fd_fi = spec + } + + + +-- the string "foo" is ambiguous: either a header or a C identifier. The +-- C identifier case comes first in the alternatives below, so we pick +-- that one. +parseCImport :: Located CCallConv -> Located Safety -> FastString -> String + -> Located SourceText + -> Maybe ForeignImport +parseCImport cconv safety nm str sourceText = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str + where + parse = do + skipSpaces + r <- choice [ + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + mk (Just (Header (SourceText h) (mkFastString h))) + <$> cimp nm)) + ] + skipSpaces + return r + + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + + mk h n = CImport cconv safety h n sourceText + + hdr_char c = not (isSpace c) + -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' + + cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) + +++ (do isFun <- case unLoc cconv of + CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget NoSourceText cid' + Nothing isFun))) + where + cid = return nm +++ + (do c <- satisfy id_first_char + cs <- many (satisfy id_char) + return (mkFastString (c:cs))) + + +-- construct a foreign export declaration +-- +mkExport :: Located CCallConv + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) +mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) + = return $ ForD noExtField $ + ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty + , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) + (L le esrc) } + where + entity' | nullFS entity = mkExtName (unLoc v) + | otherwise = entity + +-- Supplying the ext_name in a foreign decl is optional; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- of the Haskell name is then performed, so if you foreign export (++), +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) + +-------------------------------------------------------------------------------- +-- Help with module system imports/exports + +data ImpExpSubSpec = ImpExpAbs + | ImpExpAll + | ImpExpList [Located ImpExpQcSpec] + | ImpExpAllWith [Located ImpExpQcSpec] + +data ImpExpQcSpec = ImpExpQcName (Located RdrName) + | ImpExpQcType (Located RdrName) + | ImpExpQcWildcard + +mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) +mkModuleImpExp (L l specname) subs = + case subs of + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) + -> return $ IEVar noExtField (L l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExtField . L l <$> nameT + ImpExpAll -> IEThingAll noExtField . L l <$> nameT + ImpExpList xs -> + (\newName -> IEThingWith noExtField (L l newName) + NoIEWildcard (wrapped xs) []) <$> nameT + ImpExpAllWith xs -> + do allowed <- getBit PatternSynonymsBit + if allowed + then + let withs = map unLoc xs + pos = maybe NoIEWildcard IEWildcard + (findIndex isImpExpQcWildcard withs) + ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs + in (\newName + -> IEThingWith noExtField (L l newName) pos ies []) + <$> nameT + else addFatalError l + (text "Illegal export form (use PatternSynonyms to enable)") + where + name = ieNameVal specname + nameT = + if isVarNameSpace (rdrNameSpace name) + then addFatalError l + (text "Expecting a type constructor but found a variable," + <+> quotes (ppr name) <> text "." + $$ if isSymOcc $ rdrNameOcc name + then text "If" <+> quotes (ppr name) + <+> text "is a type constructor" + <+> text "then enable ExplicitNamespaces and use the 'type' keyword." + else empty) + else return $ ieNameFromSpec specname + + ieNameVal (ImpExpQcName ln) = unLoc ln + ieNameVal (ImpExpQcType ln) = unLoc ln + ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" + + ieNameFromSpec (ImpExpQcName ln) = IEName ln + ieNameFromSpec (ImpExpQcType ln) = IEType ln + ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" + + wrapped = map (mapLoc ieNameFromSpec) + +mkTypeImpExp :: Located RdrName -- TcCls or Var name space + -> P (Located RdrName) +mkTypeImpExp name = + do allowed <- getBit ExplicitNamespacesBit + unless allowed $ addError (getLoc name) $ + text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" + return (fmap (`setRdrNameSpace` tcClsName) name) + +checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) +checkImportSpec ie@(L _ specs) = + case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of + [] -> return ie + (l:_) -> importSpecError l + where + importSpecError l = + addFatalError l + (text "Illegal import form, this syntax can only be used to bundle" + $+$ text "pattern synonyms with types in module exports.") + +-- In the correct order +mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) +mkImpExpSubSpec [] = return ([], ImpExpList []) +mkImpExpSubSpec [L _ ImpExpQcWildcard] = + return ([], ImpExpAll) +mkImpExpSubSpec xs = + if (any (isImpExpQcWildcard . unLoc) xs) + then return $ ([], ImpExpAllWith xs) + else return $ ([], ImpExpList xs) + +isImpExpQcWildcard :: ImpExpQcSpec -> Bool +isImpExpQcWildcard ImpExpQcWildcard = True +isImpExpQcWildcard _ = False + +----------------------------------------------------------------------------- +-- Warnings and failures + +warnPrepositiveQualifiedModule :: SrcSpan -> P () +warnPrepositiveQualifiedModule span = + addWarning Opt_WarnPrepositiveQualifiedModule span msg + where + msg = text "Found" <+> quotes (text "qualified") + <+> text "in prepositive position" + $$ text "Suggested fix: place " <+> quotes (text "qualified") + <+> text "after the module name instead." + +failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () +failOpNotEnabledImportQualifiedPost loc = addError loc msg + where + msg = text "Found" <+> quotes (text "qualified") + <+> text "in postpositive position. " + $$ text "To allow this, enable language extension 'ImportQualifiedPost'" + +failOpImportQualifiedTwice :: SrcSpan -> P () +failOpImportQualifiedTwice loc = addError loc msg + where + msg = text "Multiple occurrences of 'qualified'" + +warnStarIsType :: SrcSpan -> P () +warnStarIsType span = addWarning Opt_WarnStarIsType span msg + where + msg = text "Using" <+> quotes (text "*") + <+> text "(or its Unicode variant) to mean" + <+> quotes (text "Data.Kind.Type") + $$ text "relies on the StarIsType extension, which will become" + $$ text "deprecated in the future." + $$ text "Suggested fix: use" <+> quotes (text "Type") + <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." + +warnStarBndr :: SrcSpan -> P () +warnStarBndr span = addWarning Opt_WarnStarBinder span msg + where + msg = text "Found binding occurrence of" <+> quotes (text "*") + <+> text "yet StarIsType is enabled." + $$ text "NB. To use (or export) this operator in" + <+> text "modules with StarIsType," + $$ text " including the definition module, you must qualify it." + +failOpFewArgs :: Located RdrName -> P a +failOpFewArgs (L loc op) = + do { star_is_type <- getBit StarIsTypeBit + ; let msg = too_few $$ starInfo star_is_type op + ; addFatalError loc msg } + where + too_few = text "Operator applied to too few arguments:" <+> ppr op + +----------------------------------------------------------------------------- +-- Misc utils + +data PV_Context = + PV_Context + { pv_options :: ParserFlags + , pv_hint :: SDoc -- See Note [Parser-Validator Hint] + } + +data PV_Accum = + PV_Accum + { pv_messages :: DynFlags -> Messages + , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])] + , pv_comment_q :: [RealLocated AnnotationComment] + , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])] + } + +data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum + +-- See Note [Parser-Validator] +newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } + +instance Functor PV where + fmap = liftM + +instance Applicative PV where + pure a = a `seq` PV (\_ acc -> PV_Ok acc a) + (<*>) = ap + +instance Monad PV where + m >>= f = PV $ \ctx acc -> + case unPV m ctx acc of + PV_Ok acc' a -> unPV (f a) ctx acc' + PV_Failed acc' -> PV_Failed acc' + +runPV :: PV a -> P a +runPV = runPV_msg empty + +runPV_msg :: SDoc -> PV a -> P a +runPV_msg msg m = + P $ \s -> + let + pv_ctx = PV_Context + { pv_options = options s + , pv_hint = msg } + pv_acc = PV_Accum + { pv_messages = messages s + , pv_annotations = annotations s + , pv_comment_q = comment_q s + , pv_annotations_comments = annotations_comments s } + mkPState acc' = + s { messages = pv_messages acc' + , annotations = pv_annotations acc' + , comment_q = pv_comment_q acc' + , annotations_comments = pv_annotations_comments acc' } + in + case unPV m pv_ctx pv_acc of + PV_Ok acc' a -> POk (mkPState acc') a + PV_Failed acc' -> PFailed (mkPState acc') + +localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a +localPV_msg f m = + let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in + PV (\ctx acc -> unPV m (modifyHint ctx) acc) + +instance MonadP PV where + addError srcspan msg = + PV $ \ctx acc@PV_Accum{pv_messages=m} -> + let msg' = msg $$ pv_hint ctx in + PV_Ok acc{pv_messages=appendError srcspan msg' m} () + addWarning option srcspan warning = + PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} -> + PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} () + addFatalError srcspan msg = + addError srcspan msg >> PV (const PV_Failed) + getBit ext = + PV $ \ctx acc -> + let b = ext `xtest` pExtsBitmap (pv_options ctx) in + PV_Ok acc $! b + addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = + PV $ \_ acc -> + let + (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc) + annotations_comments' = new_ann_comments ++ pv_annotations_comments acc + annotations' = ((l,a), [v]) : pv_annotations acc + acc' = acc + { pv_annotations = annotations' + , pv_comment_q = comment_q' + , pv_annotations_comments = annotations_comments' } + in + PV_Ok acc' () + addAnnotation _ _ _ = return () + +{- Note [Parser-Validator] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When resolving ambiguities, we need to postpone failure to make a choice later. +For example, if we have ambiguity between some A and B, our parser could be + + abParser :: P (Maybe A, Maybe B) + +This way we can represent four possible outcomes of parsing: + + (Just a, Nothing) -- definitely A + (Nothing, Just b) -- definitely B + (Just a, Just b) -- either A or B + (Nothing, Nothing) -- neither A nor B + +However, if we want to report informative parse errors, accumulate warnings, +and add API annotations, we are better off using 'P' instead of 'Maybe': + + abParser :: P (P A, P B) + +So we have an outer layer of P that consumes the input and builds the inner +layer, which validates the input. + +For clarity, we introduce the notion of a parser-validator: a parser that does +not consume any input, but may fail or use other effects. Thus we have: + + abParser :: P (PV A, PV B) + +-} + +{- Note [Parser-Validator Hint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A PV computation is parametrized by a hint for error messages, which can be set +depending on validation context. We use this in checkPattern to fix #984. + +Consider this example, where the user has forgotten a 'do': + + f _ = do + x <- computation + case () of + _ -> + result <- computation + case () of () -> undefined + +GHC parses it as follows: + + f _ = do + x <- computation + (case () of + _ -> + result) <- computation + case () of () -> undefined + +Note that this fragment is parsed as a pattern: + + case () of + _ -> + result + +We attempt to detect such cases and add a hint to the error messages: + + T984.hs:6:9: + Parse error in pattern: case () of { _ -> result } + Possibly caused by a missing 'do'? + +The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed +as the 'pv_hint' field 'PV_Context'. When validating in a context other than +'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has +no effect on the error messages. + +-} + +-- | Hint about bang patterns, assuming @BangPatterns@ is off. +hintBangPat :: SrcSpan -> Pat GhcPs -> PV () +hintBangPat span e = do + bang_on <- getBit BangPatBit + unless bang_on $ + addError span + (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) + +data SumOrTuple b + = Sum ConTag Arity (Located b) + | Tuple [Located (Maybe (Located b))] + +pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc +pprSumOrTuple boxity = \case + Sum alt arity e -> + parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) + <+> parClose + Tuple xs -> + parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs) + <> parClose + where + ppr_bars n = hsep (replicate n (Outputable.char '|')) + (parOpen, parClose) = + case boxity of + Boxed -> (text "(", text ")") + Unboxed -> (text "(#", text "#)") + +mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) + +-- Tuple +mkSumOrTupleExpr l boxity (Tuple es) = + return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity) + where + toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs + toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) + +-- Sum +mkSumOrTupleExpr l Unboxed (Sum alt arity e) = + return $ L l (ExplicitSum noExtField alt arity e) +mkSumOrTupleExpr l Boxed a@Sum{} = + addFatalError l (hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed a)) + +mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) + +-- Tuple +mkSumOrTuplePat l boxity (Tuple ps) = do + ps' <- traverse toTupPat ps + return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity)) + where + toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) + -- Ignore the element location so that the error message refers to the + -- entire tuple. See #19504 (and the discussion) for details. + toTupPat (L _ p) = case p of + Nothing -> addFatalError l (text "Tuple section in pattern context") + Just p' -> checkLPat p' + +-- Sum +mkSumOrTuplePat l Unboxed (Sum alt arity p) = do + p' <- checkLPat p + return $ L l (PatBuilderPat (SumPat noExtField p' alt arity)) +mkSumOrTuplePat l Boxed a@Sum{} = + addFatalError l (hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed a)) + +mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy x op y = + let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y + in L loc (mkHsOpTy x op y) + +mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn) +mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) + -- See #18888 for the use of (SourceText "1") above + = (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t)) +mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok)) + +----------------------------------------------------------------------------- +-- Token symbols + +starSym :: Bool -> String +starSym True = "★" +starSym False = "*" + +forallSym :: Bool -> String +forallSym True = "∀" +forallSym False = "forall" diff --git a/GHC/Parser/PostProcess/Haddock.hs b/GHC/Parser/PostProcess/Haddock.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/PostProcess/Haddock.hs @@ -0,0 +1,1545 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingVia #-} + +{- | This module implements 'addHaddockToModule', which inserts Haddock + comments accumulated during parsing into the AST (#17544). + +We process Haddock comments in two phases: + +1. Parse the program (via the Happy parser in `Parser.y`), generating + an AST, and (quite separately) a list of all the Haddock comments + found in the file. More precisely, the Haddock comments are + accumulated in the `hdk_comments` field of the `PState`, the parser + state (see Lexer.x): + + data PState = PState { ... + , hdk_comments :: [PsLocated HdkComment] } + + Each of these Haddock comments has a `PsSpan`, which gives the `BufPos` of + the beginning and end of the Haddock comment. + +2. Walk over the AST, attaching the Haddock comments to the correct + parts of the tree. This step is called `addHaddockToModule`, and is + implemented in this module. + + See Note [Adding Haddock comments to the syntax tree]. + +This approach codifies an important principle: + + The presence or absence of a Haddock comment should never change the parsing + of a program. + +Alternative approaches that did not work properly: + +1. Using 'RealSrcLoc' instead of 'BufPos'. This led to failures in presence + of {-# LANGUAGE CPP #-} and other sources of line pragmas. See documentation + on 'BufPos' (in GHC.Types.SrcLoc) for the details. + +2. In earlier versions of GHC, the Haddock comments were incorporated into the + Parser.y grammar. The parser constructed the AST and attached comments to it in + a single pass. See Note [Old solution: Haddock in the grammar] for the details. +-} +module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where + +import GHC.Prelude hiding (mod) + +import GHC.Hs +import GHC.Types.SrcLoc +import GHC.Driver.Session ( WarningFlag(..) ) +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Data.Bag + +import Data.Semigroup +import Data.Foldable +import Data.Traversable +import Data.Maybe +import Control.Monad +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import Data.Functor.Identity +import Data.Coerce +import qualified Data.Monoid + +import GHC.Parser.Lexer +import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) + +{- Note [Adding Haddock comments to the syntax tree] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'addHaddock' traverses the AST in concrete syntax order, building a computation +(represented by HdkA) that reconstructs the AST but with Haddock comments +inserted in appropriate positions: + + addHaddock :: HasHaddock a => a -> HdkA a + +Consider this code example: + + f :: Int -- ^ comment on argument + -> Bool -- ^ comment on result + +In the AST, the "Int" part of this snippet is represented like this +(pseudo-code): + + L (BufSpan 6 8) (HsTyVar "Int") :: LHsType GhcPs + +And the comments are represented like this (pseudo-code): + + L (BufSpan 11 35) (HdkCommentPrev "comment on argument") + L (BufSpan 46 69) (HdkCommentPrev "comment on result") + +So when we are traversing the AST and 'addHaddock' is applied to HsTyVar "Int", +how does it know to associate it with "comment on argument" but not with +"comment on result"? + +The trick is to look in the space between syntactic elements. In the example above, +the location range in which we search for HdkCommentPrev is as follows: + + f :: Int████████████████████████ + ████Bool -- ^ comment on result + +We search for comments after HsTyVar "Int" and until the next syntactic +element, in this case HsTyVar "Bool". + +Ignoring the "->" allows us to accomodate alternative coding styles: + + f :: Int -> -- ^ comment on argument + Bool -- ^ comment on result + +Sometimes we also need to take indentation information into account. +Compare the following examples: + + class C a where + f :: a -> Int + -- ^ comment on f + + class C a where + f :: a -> Int + -- ^ comment on C + +Notice how "comment on f" and "comment on C" differ only by indentation level. + +Therefore, in order to know the location range in which the comments are applicable +to a syntactic elements, we need three nuggets of information: + 1. lower bound on the BufPos of a comment + 2. upper bound on the BufPos of a comment + 3. minimum indentation level of a comment + +This information is represented by the 'LocRange' type. + +In order to propagate this information, we have the 'HdkA' applicative. +'HdkA' is defined as follows: + + data HdkA a = HdkA (Maybe BufSpan) (HdkM a) + +The first field contains a 'BufSpan', which represents the location +span taken by a syntactic element: + + addHaddock (L bufSpan ...) = HdkA (Just bufSpan) ... + +The second field, 'HdkM', is a stateful computation that looks up Haddock +comments in the specified location range: + + HdkM a ≈ + LocRange -- The allowed location range + -> [PsLocated HdkComment] -- Unallocated comments + -> (a, -- AST with comments inserted into it + [PsLocated HdkComment]) -- Leftover comments + +The 'Applicative' instance for 'HdkA' is defined in such a way that the +location range of every computation is defined by its neighbours: + + addHaddock aaa <*> addHaddock bbb <*> addHaddock ccc + +Here, the 'LocRange' passed to the 'HdkM' computation of addHaddock bbb +is determined by the BufSpan recorded in addHaddock aaa and addHaddock ccc. + +This is why it's important to traverse the AST in the order of the concrete +syntax. In the example above we assume that aaa, bbb, ccc are ordered by location: + + * getBufSpan (getLoc aaa) < getBufSpan (getLoc bbb) + * getBufSpan (getLoc bbb) < getBufSpan (getLoc ccc) + +Violation of this assumption would lead to bugs, and care must be taken to +traverse the AST correctly. For example, when dealing with class declarations, +we have to use 'flattenBindsAndSigs' to traverse it in the correct order. +-} + +-- | Add Haddock documentation accumulated in the parser state +-- to a parsed HsModule. +-- +-- Reports badly positioned comments when -Winvalid-haddock is enabled. +addHaddockToModule :: Located HsModule -> P (Located HsModule) +addHaddockToModule lmod = do + pState <- getPState + let all_comments = toList (hdk_comments pState) + initial_hdk_st = HdkSt all_comments [] + (lmod', final_hdk_st) = runHdkA (addHaddock lmod) initial_hdk_st + hdk_warnings = collectHdkWarnings final_hdk_st + -- lmod': module with Haddock comments inserted into the AST + -- hdk_warnings: warnings accumulated during AST/comment processing + mapM_ reportHdkWarning hdk_warnings + return lmod' + +reportHdkWarning :: HdkWarn -> P () +reportHdkWarning (HdkWarnInvalidComment (L l _)) = + addWarning Opt_WarnInvalidHaddock (mkSrcSpanPs l) $ + text "A Haddock comment cannot appear in this position and will be ignored." +reportHdkWarning (HdkWarnExtraComment (L l _)) = + addWarning Opt_WarnInvalidHaddock l $ + text "Multiple Haddock comments for a single entity are not allowed." $$ + text "The extraneous comment will be ignored." + +collectHdkWarnings :: HdkSt -> [HdkWarn] +collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } = + map HdkWarnInvalidComment hdk_st_pending -- leftover Haddock comments not inserted into the AST + ++ hdk_st_warnings + +{- ********************************************************************* +* * +* addHaddock: a family of functions that processes the AST * +* in concrete syntax order, adding documentation comments to it * +* * +********************************************************************* -} + +-- HasHaddock is a convenience class for overloading the addHaddock operation. +-- Alternatively, we could define a family of monomorphic functions: +-- +-- addHaddockSomeTypeX :: SomeTypeX -> HdkA SomeTypeX +-- addHaddockAnotherTypeY :: AnotherTypeY -> HdkA AnotherTypeY +-- addHaddockOneMoreTypeZ :: OneMoreTypeZ -> HdkA OneMoreTypeZ +-- +-- But having a single name for all of them is just easier to read, and makes it clear +-- that they all are of the form t -> HdkA t for some t. +-- +-- If you need to handle a more complicated scenario that doesn't fit this +-- pattern, it's always possible to define separate functions outside of this +-- class, as is done in case of e.g. addHaddockConDeclField. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +class HasHaddock a where + addHaddock :: a -> HdkA a + +instance HasHaddock a => HasHaddock [a] where + addHaddock = traverse addHaddock + +-- -- | Module header comment +-- module M ( +-- -- * Export list comment +-- Item1, +-- Item2, +-- -- * Export list comment +-- item3, +-- item4 +-- ) where +-- +instance HasHaddock (Located HsModule) where + addHaddock (L l_mod mod) = do + -- Step 1, get the module header documentation comment: + -- + -- -- | Module header comment + -- module M where + -- + -- Only do this when the module header exists. + headerDocs <- + for @Maybe (hsmodName mod) $ \(L l_name _) -> + extendHdkA l_name $ liftHdkA $ do + -- todo: register keyword location of 'module', see Note [Register keyword location] + docs <- + inLocRange (locRangeTo (getBufPos (srcSpanStart l_name))) $ + takeHdkComments mkDocNext + selectDocString docs + + -- Step 2, process documentation comments in the export list: + -- + -- module M ( + -- -- * Export list comment + -- Item1, + -- Item2, + -- -- * Export list comment + -- item3, + -- item4 + -- ) where + -- + -- Only do this when the export list exists. + hsmodExports' <- traverse @Maybe addHaddock (hsmodExports mod) + + -- Step 3, register the import section to reject invalid comments: + -- + -- import Data.Maybe + -- -- | rejected comment (cannot appear here) + -- import Data.Bool + -- + traverse_ registerHdkA (hsmodImports mod) + + -- Step 4, process declarations: + -- + -- module M where + -- -- | Comment on D + -- data D = MkD -- ^ Comment on MkD + -- data C = MkC -- ^ Comment on MkC + -- -- ^ Comment on C + -- + let layout_info = hsmodLayout mod + hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod) + + pure $ L l_mod $ + mod { hsmodExports = hsmodExports' + , hsmodDecls = hsmodDecls' + , hsmodHaddockModHeader = join @Maybe headerDocs } + +-- Only for module exports, not module imports. +-- +-- module M (a, b, c) where -- use on this [LIE GhcPs] +-- import I (a, b, c) -- do not use here! +-- +-- Imports cannot have documentation comments anyway. +instance HasHaddock (Located [LIE GhcPs]) where + addHaddock (L l_exports exports) = + extendHdkA l_exports $ do + exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports + registerLocHdkA (srcLocSpan (srcSpanEnd l_exports)) -- Do not consume comments after the closing parenthesis + pure $ L l_exports exports' + +-- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. +instance HasHaddock (LIE GhcPs) where + addHaddock a = a <$ registerHdkA a + +{- Add Haddock items to a list of non-Haddock items. +Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl). + +For example: + + module M where + -- | Comment on D + data D = MkD -- ^ Comment on MkD + data C = MkC -- ^ Comment on MkC + -- ^ Comment on C + +In this case, we should produce four HsDecl items (pseudo-code): + + 1. DocD (DocCommentNext "Comment on D") + 2. TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")]) + 3. TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")]) + 4. DocD (DocCommentPrev "Comment on C") + +The inputs to addHaddockInterleaveItems are: + + * layout_info :: LayoutInfo + + In the example above, note that the indentation level inside the module is + 2 spaces. It would be represented as layout_info = VirtualBraces 2. + + It is used to delimit the search space for comments when processing + declarations. Here, we restrict indentation levels to >=(2+1), so that when + we look up comment on MkC, we get "Comment on MkC" but not "Comment on C". + + * get_doc_item :: PsLocated HdkComment -> Maybe a + + This is the function used to look up documentation comments. + In the above example, get_doc_item = mkDocHsDecl layout_info, + and it will produce the following parts of the output: + + DocD (DocCommentNext "Comment on D") + DocD (DocCommentPrev "Comment on C") + + * The list of items. These are the declarations that will be annotated with + documentation comments. + + Before processing: + TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... Nothing]) + TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... Nothing]) + + After processing: + TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")]) + TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")]) +-} +addHaddockInterleaveItems + :: forall a. + HasHaddock a + => LayoutInfo + -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item + -> [a] -- Unprocessed (non-documentation) items + -> HdkA [a] -- Documentation items & processed non-documentation items +addHaddockInterleaveItems layout_info get_doc_item = go + where + go :: [a] -> HdkA [a] + go [] = liftHdkA (takeHdkComments get_doc_item) + go (item : items) = do + docItems <- liftHdkA (takeHdkComments get_doc_item) + item' <- with_layout_info (addHaddock item) + other_items <- go items + pure $ docItems ++ item':other_items + + with_layout_info :: HdkA a -> HdkA a + with_layout_info = case layout_info of + NoLayoutInfo -> id + ExplicitBraces -> id + VirtualBraces n -> + let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } + in hoistHdkA (inLocRange loc_range) + +instance HasHaddock (LHsDecl GhcPs) where + addHaddock ldecl = + extendHdkA (getLoc ldecl) $ + traverse @Located addHaddock ldecl + +-- Process documentation comments *inside* a declaration, for example: +-- +-- data T = MkT -- ^ Comment on MkT (inside DataDecl) +-- f, g +-- :: Int -- ^ Comment on Int (inside TypeSig) +-- -> Bool -- ^ Comment on Bool (inside TypeSig) +-- +-- Comments that relate to the entire declaration are processed elsewhere: +-- +-- -- | Comment on T (not processed in this instance) +-- data T = MkT +-- +-- -- | Comment on f, g (not processed in this instance) +-- f, g :: Int -> Bool +-- f = ... +-- g = ... +-- +-- Such comments are inserted into the syntax tree as DocD declarations +-- by addHaddockInterleaveItems, and then associated with other declarations +-- in GHC.HsToCore.Docs (see DeclDocMap). +-- +-- In this instance, we only process comments that relate to parts of the +-- declaration, not to the declaration itself. +instance HasHaddock (HsDecl GhcPs) where + + -- Type signatures: + -- + -- f, g + -- :: Int -- ^ Comment on Int + -- -> Bool -- ^ Comment on Bool + -- + addHaddock (SigD _ (TypeSig _ names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (TypeSig noExtField names t')) + + -- Pattern synonym type signatures: + -- + -- pattern MyPat + -- :: Bool -- ^ Comment on Bool + -- -> Maybe Bool -- ^ Comment on Maybe Bool + -- + addHaddock (SigD _ (PatSynSig _ names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (PatSynSig noExtField names t')) + + -- Class method signatures and default signatures: + -- + -- class C x where + -- method_of_c + -- :: Maybe x -- ^ Comment on Maybe x + -- -> IO () -- ^ Comment on IO () + -- default method_of_c + -- :: Eq x + -- => Maybe x -- ^ Comment on Maybe x + -- -> IO () -- ^ Comment on IO () + -- + addHaddock (SigD _ (ClassOpSig _ is_dflt names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (ClassOpSig noExtField is_dflt names t')) + + -- Data/newtype declarations: + -- + -- data T = MkT -- ^ Comment on MkT + -- A -- ^ Comment on A + -- B -- ^ Comment on B + -- + -- data G where + -- -- | Comment on MkG + -- MkG :: A -- ^ Comment on A + -- -> B -- ^ Comment on B + -- -> G + -- + -- newtype N = MkN { getN :: Natural } -- ^ Comment on N + -- deriving newtype (Eq {- ^ Comment on Eq N -}) + -- deriving newtype (Ord {- ^ Comment on Ord N -}) + -- + addHaddock (TyClD _ decl) + | DataDecl { tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl + = do + registerHdkA tcdLName + defn' <- addHaddock defn + pure $ + TyClD noExtField (DataDecl { + tcdDExt = noExtField, + tcdLName, tcdTyVars, tcdFixity, + tcdDataDefn = defn' }) + + -- Class declarations: + -- + -- class C a where + -- -- | Comment on the first method + -- first_method :: a -> Bool + -- second_method :: a -> String + -- -- ^ Comment on the second method + -- + addHaddock (TyClD _ decl) + | ClassDecl { tcdCExt = tcdLayout, + tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, + tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl + = do + registerHdkA tcdLName + -- todo: register keyword location of 'where', see Note [Register keyword location] + where_cls' <- + addHaddockInterleaveItems tcdLayout (mkDocHsDecl tcdLayout) $ + flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], []) + pure $ + let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls' + decl' = ClassDecl { tcdCExt = tcdLayout + , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs + , tcdSigs = tcdSigs' + , tcdMeths = tcdMeths' + , tcdATs = tcdATs' + , tcdATDefs = tcdATDefs' + , tcdDocs } + in TyClD noExtField decl' + + -- Data family instances: + -- + -- data instance D Bool where ... (same as data/newtype declarations) + -- data instance D Bool = ... (same as data/newtype declarations) + -- + addHaddock (InstD _ decl) + | DataFamInstD { dfid_inst } <- decl + , DataFamInstDecl { dfid_eqn } <- dfid_inst + = do + dfid_eqn' <- case dfid_eqn of + HsIB _ (FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs }) + -> do + registerHdkA feqn_tycon + feqn_rhs' <- addHaddock feqn_rhs + pure $ + HsIB noExtField (FamEqn { + feqn_ext = noExtField, + feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, + feqn_rhs = feqn_rhs' }) + pure $ InstD noExtField (DataFamInstD { + dfid_ext = noExtField, + dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } }) + + -- Type synonyms: + -- + -- type T = Int -- ^ Comment on Int + -- + addHaddock (TyClD _ decl) + | SynDecl { tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl + = do + registerHdkA tcdLName + -- todo: register keyword location of '=', see Note [Register keyword location] + tcdRhs' <- addHaddock tcdRhs + pure $ + TyClD noExtField (SynDecl { + tcdSExt = noExtField, + tcdLName, tcdTyVars, tcdFixity, + tcdRhs = tcdRhs' }) + + -- Foreign imports: + -- + -- foreign import ccall unsafe + -- o :: Float -- ^ The input float + -- -> IO Float -- ^ The output float + -- + addHaddock (ForD _ decl) = do + registerHdkA (fd_name decl) + fd_sig_ty' <- addHaddock (fd_sig_ty decl) + pure $ ForD noExtField (decl{ fd_sig_ty = fd_sig_ty' }) + + -- Other declarations + addHaddock d = pure d + +-- The right-hand side of a data/newtype declaration or data family instance. +instance HasHaddock (HsDataDefn GhcPs) where + addHaddock defn@HsDataDefn{} = do + + -- Register the kind signature: + -- data D :: Type -> Type where ... + -- data instance D Bool :: Type where ... + traverse_ @Maybe registerHdkA (dd_kindSig defn) + -- todo: register keyword location of '=' or 'where', see Note [Register keyword location] + + -- Process the data constructors: + -- + -- data T + -- = MkT1 Int Bool -- ^ Comment on MkT1 + -- | MkT2 Char Int -- ^ Comment on MkT2 + -- + dd_cons' <- addHaddock (dd_cons defn) + + -- Process the deriving clauses: + -- + -- newtype N = MkN Natural + -- deriving (Eq {- ^ Comment on Eq N -}) + -- deriving (Ord {- ^ Comment on Ord N -}) + -- + dd_derivs' <- addHaddock (dd_derivs defn) + + pure $ defn { dd_cons = dd_cons', + dd_derivs = dd_derivs' } + +-- Process the deriving clauses of a data/newtype declaration. +-- Not used for standalone deriving. +instance HasHaddock (HsDeriving GhcPs) where + addHaddock lderivs = + extendHdkA (getLoc lderivs) $ + traverse @Located addHaddock lderivs + +-- Process a single deriving clause of a data/newtype declaration: +-- +-- newtype N = MkN Natural +-- deriving newtype (Eq {- ^ Comment on Eq N -}) +-- deriving (Ord {- ^ Comment on Ord N -}) via Down N +-- +-- Not used for standalone deriving. +instance HasHaddock (LHsDerivingClause GhcPs) where + addHaddock lderiv = + extendHdkA (getLoc lderiv) $ + for @Located lderiv $ \deriv -> + case deriv of + HsDerivingClause { deriv_clause_strategy, deriv_clause_tys } -> do + let + -- 'stock', 'anyclass', and 'newtype' strategies come + -- before the clause types. + -- + -- 'via' comes after. + -- + -- See tests/.../T11768.hs + (register_strategy_before, register_strategy_after) = + case deriv_clause_strategy of + Nothing -> (pure (), pure ()) + Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l) + Just (L l _) -> (registerLocHdkA l, pure ()) + register_strategy_before + deriv_clause_tys' <- + extendHdkA (getLoc deriv_clause_tys) $ + traverse @Located addHaddock deriv_clause_tys + register_strategy_after + pure HsDerivingClause + { deriv_clause_ext = noExtField, + deriv_clause_strategy, + deriv_clause_tys = deriv_clause_tys' } + +-- Process a single data constructor declaration, which may come in one of the +-- following forms: +-- +-- 1. H98-syntax PrefixCon: +-- data T = +-- MkT -- ^ Comment on MkT +-- Int -- ^ Comment on Int +-- Bool -- ^ Comment on Bool +-- +-- 2. H98-syntax InfixCon: +-- data T = +-- Int -- ^ Comment on Int +-- :+ -- ^ Comment on (:+) +-- Bool -- ^ Comment on Bool +-- +-- 3. H98-syntax RecCon: +-- data T = +-- MkT { int_field :: Int, -- ^ Comment on int_field +-- bool_field :: Bool } -- ^ Comment on bool_field +-- +-- 4. GADT-syntax PrefixCon: +-- data T where +-- -- | Comment on MkT +-- MkT :: Int -- ^ Comment on Int +-- -> Bool -- ^ Comment on Bool +-- -> T +-- +-- 5. GADT-syntax RecCon: +-- data T where +-- -- | Comment on MkT +-- MkT :: { int_field :: Int, -- ^ Comment on int_field +-- bool_field :: Bool } -- ^ Comment on bool_field +-- -> T +-- +instance HasHaddock (LConDecl GhcPs) where + addHaddock (L l_con_decl con_decl) = + extendHdkA l_con_decl $ + case con_decl of + ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do + -- discardHasInnerDocs is ok because we don't need this info for GADTs. + con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names)) + con_args' <- + case con_args of + PrefixCon ts -> PrefixCon <$> addHaddock ts + RecCon (L l_rec flds) -> do + -- discardHasInnerDocs is ok because we don't need this info for GADTs. + flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds + pure $ RecCon (L l_rec flds') + InfixCon _ _ -> panic "ConDeclGADT InfixCon" + con_res_ty' <- addHaddock con_res_ty + pure $ L l_con_decl $ + ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, + con_doc = con_doc', + con_args = con_args', + con_res_ty = con_res_ty' } + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> + addConTrailingDoc (srcSpanEnd l_con_decl) $ + case con_args of + PrefixCon ts -> do + con_doc' <- getConDoc (getLoc con_name) + ts' <- traverse addHaddockConDeclFieldTy ts + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = con_doc', + con_args = PrefixCon ts' } + InfixCon t1 t2 -> do + t1' <- addHaddockConDeclFieldTy t1 + con_doc' <- getConDoc (getLoc con_name) + t2' <- addHaddockConDeclFieldTy t2 + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = con_doc', + con_args = InfixCon t1' t2' } + RecCon (L l_rec flds) -> do + con_doc' <- getConDoc (getLoc con_name) + flds' <- traverse addHaddockConDeclField flds + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = con_doc', + con_args = RecCon (L l_rec flds') } + +-- Keep track of documentation comments on the data constructor or any of its +-- fields. +-- +-- See Note [Trailing comment on constructor declaration] +type ConHdkA = WriterT HasInnerDocs HdkA + +-- Does the data constructor declaration have any inner (non-trailing) +-- documentation comments? +-- +-- Example when HasInnerDocs is True: +-- +-- data X = +-- MkX -- ^ inner comment +-- Field1 -- ^ inner comment +-- Field2 -- ^ inner comment +-- Field3 -- ^ trailing comment +-- +-- Example when HasInnerDocs is False: +-- +-- data Y = MkY Field1 Field2 Field3 -- ^ trailing comment +-- +-- See Note [Trailing comment on constructor declaration] +newtype HasInnerDocs = HasInnerDocs Bool + deriving (Semigroup, Monoid) via Data.Monoid.Any + +-- Run ConHdkA by discarding the HasInnerDocs info when we have no use for it. +-- +-- We only do this when processing data declarations that use GADT syntax, +-- because only the H98 syntax declarations have special treatment for the +-- trailing documentation comment. +-- +-- See Note [Trailing comment on constructor declaration] +discardHasInnerDocs :: ConHdkA a -> HdkA a +discardHasInnerDocs = fmap fst . runWriterT + +-- Get the documentation comment associated with the data constructor in a +-- data/newtype declaration. +getConDoc + :: SrcSpan -- Location of the data constructor + -> ConHdkA (Maybe LHsDocString) +getConDoc l = + WriterT $ extendHdkA l $ liftHdkA $ do + mDoc <- getPrevNextDoc l + return (mDoc, HasInnerDocs (isJust mDoc)) + +-- Add documentation comment to a data constructor field. +-- Used for PrefixCon and InfixCon. +addHaddockConDeclFieldTy + :: HsScaled GhcPs (LHsType GhcPs) + -> ConHdkA (HsScaled GhcPs (LHsType GhcPs)) +addHaddockConDeclFieldTy (HsScaled mult (L l t)) = + WriterT $ extendHdkA l $ liftHdkA $ do + mDoc <- getPrevNextDoc l + return (HsScaled mult (mkLHsDocTy (L l t) mDoc), + HasInnerDocs (isJust mDoc)) + +-- Add documentation comment to a data constructor field. +-- Used for RecCon. +addHaddockConDeclField + :: LConDeclField GhcPs + -> ConHdkA (LConDeclField GhcPs) +addHaddockConDeclField (L l_fld fld) = + WriterT $ extendHdkA l_fld $ liftHdkA $ do + cd_fld_doc <- getPrevNextDoc l_fld + return (L l_fld (fld { cd_fld_doc }), + HasInnerDocs (isJust cd_fld_doc)) + +-- 1. Process a H98-syntax data constructor declaration in a context with no +-- access to the trailing documentation comment (by running the provided +-- ConHdkA computation). +-- +-- 2. Then grab the trailing comment (if it exists) and attach it where +-- appropriate: either to the data constructor itself or to its last field, +-- depending on HasInnerDocs. +-- +-- See Note [Trailing comment on constructor declaration] +addConTrailingDoc + :: SrcLoc -- The end of a data constructor declaration. + -- Any docprev comment past this point is considered trailing. + -> ConHdkA (LConDecl GhcPs) + -> HdkA (LConDecl GhcPs) +addConTrailingDoc l_sep = + hoistHdkA add_trailing_doc . runWriterT + where + add_trailing_doc + :: HdkM (LConDecl GhcPs, HasInnerDocs) + -> HdkM (LConDecl GhcPs) + add_trailing_doc m = do + (L l con_decl, HasInnerDocs has_inner_docs) <- + inLocRange (locRangeTo (getBufPos l_sep)) m + -- inLocRange delimits the context so that the inner computation + -- will not consume the trailing documentation comment. + case con_decl of + ConDeclH98{} -> do + trailingDocs <- + inLocRange (locRangeFrom (getBufPos l_sep)) $ + takeHdkComments mkDocPrev + if null trailingDocs + then return (L l con_decl) + else do + if has_inner_docs then do + let mk_doc_ty :: HsScaled GhcPs (LHsType GhcPs) + -> HdkM (HsScaled GhcPs (LHsType GhcPs)) + mk_doc_ty x@(HsScaled _ (L _ HsDocTy{})) = + -- Happens in the following case: + -- + -- data T = + -- MkT + -- -- | Comment on SomeField + -- SomeField + -- -- ^ Another comment on SomeField? (rejected) + -- + -- See tests/.../haddockExtraDocs.hs + x <$ reportExtraDocs trailingDocs + mk_doc_ty (HsScaled mult (L l' t)) = do + doc <- selectDocString trailingDocs + return $ HsScaled mult (mkLHsDocTy (L l' t) doc) + let mk_doc_fld :: LConDeclField GhcPs + -> HdkM (LConDeclField GhcPs) + mk_doc_fld x@(L _ (ConDeclField { cd_fld_doc = Just _ })) = + -- Happens in the following case: + -- + -- data T = + -- MkT { + -- -- | Comment on SomeField + -- someField :: SomeField + -- } -- ^ Another comment on SomeField? (rejected) + -- + -- See tests/.../haddockExtraDocs.hs + x <$ reportExtraDocs trailingDocs + mk_doc_fld (L l' con_fld) = do + doc <- selectDocString trailingDocs + return $ L l' (con_fld { cd_fld_doc = doc }) + con_args' <- case con_args con_decl of + x@(PrefixCon []) -> x <$ reportExtraDocs trailingDocs + x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs + PrefixCon ts -> PrefixCon <$> mapLastM mk_doc_ty ts + InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2 + RecCon (L l_rec flds) -> do + flds' <- mapLastM mk_doc_fld flds + return (RecCon (L l_rec flds')) + return $ L l (con_decl{ con_args = con_args' }) + else do + con_doc' <- selectDocString (con_doc con_decl `mcons` trailingDocs) + return $ L l (con_decl{ con_doc = con_doc' }) + _ -> panic "addConTrailingDoc: non-H98 ConDecl" + +{- Note [Trailing comment on constructor declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The trailing comment after a constructor declaration is associated with the +constructor itself when there are no other comments inside the declaration: + + data T = MkT A B -- ^ Comment on MkT + data T = MkT { x :: A } -- ^ Comment on MkT + +When there are other comments, the trailing comment applies to the last field: + + data T = MkT -- ^ Comment on MkT + A -- ^ Comment on A + B -- ^ Comment on B + + data T = + MkT { a :: A -- ^ Comment on a + , b :: B -- ^ Comment on b + , c :: C } -- ^ Comment on c + +This makes the trailing comment context-sensitive. Example: + data T = + -- | comment 1 + MkT Int Bool -- ^ comment 2 + + Here, "comment 2" applies to the Bool field. + But if we removed "comment 1", then "comment 2" would be apply to the data + constructor rather than its field. + +All of this applies to H98-style data declarations only. +GADTSyntax data constructors don't have any special treatment for the trailing comment. + +We implement this in two steps: + + 1. Process the data constructor declaration in a delimited context where the + trailing documentation comment is not visible. Delimiting the context is done + in addConTrailingDoc. + + When processing the declaration, track whether the constructor or any of + its fields have a documentation comment associated with them. + This is done using WriterT HasInnerDocs, see ConHdkA. + + 2. Depending on whether HasInnerDocs is True or False, attach the + trailing documentation comment to the data constructor itself + or to its last field. +-} + +instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where + addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a + +instance HasHaddock (LHsSigWcType GhcPs) where + addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t + +instance HasHaddock (LHsSigType GhcPs) where + addHaddock (HsIB _ t) = HsIB noExtField <$> addHaddock t + +-- Process a type, adding documentation comments to function arguments +-- and the result. Many formatting styles are supported. +-- +-- my_function :: +-- forall a. +-- Eq a => +-- Maybe a -> -- ^ Comment on Maybe a (function argument) +-- Bool -> -- ^ Comment on Bool (function argument) +-- String -- ^ Comment on String (the result) +-- +-- my_function +-- :: forall a. Eq a +-- => Maybe a -- ^ Comment on Maybe a (function argument) +-- -> Bool -- ^ Comment on Bool (function argument) +-- -> String -- ^ Comment on String (the result) +-- +-- my_function :: +-- forall a. Eq a => +-- -- | Comment on Maybe a (function argument) +-- Maybe a -> +-- -- | Comment on Bool (function argument) +-- Bool -> +-- -- | Comment on String (the result) +-- String +-- +-- This is achieved by simply ignoring (not registering the location of) the +-- function arrow (->). +instance HasHaddock (LHsType GhcPs) where + addHaddock (L l t) = + extendHdkA l $ + case t of + + -- forall a b c. t + HsForAllTy _ tele body -> do + registerLocHdkA (getForAllTeleLoc tele) + body' <- addHaddock body + pure $ L l (HsForAllTy noExtField tele body') + + -- (Eq a, Num a) => t + HsQualTy _ lhs rhs -> do + registerHdkA lhs + rhs' <- addHaddock rhs + pure $ L l (HsQualTy noExtField lhs rhs') + + -- arg -> res + HsFunTy u mult lhs rhs -> do + lhs' <- addHaddock lhs + rhs' <- addHaddock rhs + pure $ L l (HsFunTy u mult lhs' rhs') + + -- other types + _ -> liftHdkA $ do + mDoc <- getPrevNextDoc l + return (mkLHsDocTy (L l t) mDoc) + +{- ********************************************************************* +* * +* HdkA: a layer over HdkM that propagates location information * +* * +********************************************************************* -} + +-- See Note [Adding Haddock comments to the syntax tree]. +-- +-- 'HdkA' provides a way to propagate location information from surrounding +-- computations: +-- +-- left_neighbour <*> HdkA inner_span inner_m <*> right_neighbour +-- +-- Here, the following holds: +-- +-- * the 'left_neighbour' will only see Haddock comments until 'bufSpanStart' of 'inner_span' +-- * the 'right_neighbour' will only see Haddock comments after 'bufSpanEnd' of 'inner_span' +-- * the 'inner_m' will only see Haddock comments between its 'left_neighbour' and its 'right_neighbour' +-- +-- In other words, every computation: +-- +-- * delimits the surrounding computations +-- * is delimited by the surrounding computations +-- +-- Therefore, a 'HdkA' computation must be always considered in the context in +-- which it is used. +data HdkA a = + HdkA + !(Maybe BufSpan) -- Just b <=> BufSpan occupied by the processed AST element. + -- The surrounding computations will not look inside. + -- + -- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA'). + -- The surrounding computations are not delimited. + + !(HdkM a) -- The stateful computation that looks up Haddock comments and + -- adds them to the resulting AST node. + + deriving (Functor) + +instance Applicative HdkA where + HdkA l1 m1 <*> HdkA l2 m2 = + HdkA + (l1 <> l2) -- The combined BufSpan that covers both subcomputations. + -- + -- The Semigroup instance for Maybe quite conveniently does the right thing: + -- Nothing <> b = b + -- a <> Nothing = a + -- Just a <> Just b = Just (a <> b) + + (delim1 m1 <*> delim2 m2) -- Stateful computations are run in left-to-right order, + -- without any smart reordering strategy. So users of this + -- operation must take care to traverse the AST + -- in concrete syntax order. + -- See Note [Smart reordering in HdkA (or lack of thereof)] + -- + -- Each computation is delimited ("sandboxed") + -- in a way that it doesn't see any Haddock + -- comments past the neighbouring AST node. + -- These delim1/delim2 are key to how HdkA operates. + where + -- Delimit the LHS by the location information from the RHS + delim1 = inLocRange (locRangeTo (fmap @Maybe bufSpanStart l2)) + -- Delimit the RHS by the location information from the LHS + delim2 = inLocRange (locRangeFrom (fmap @Maybe bufSpanEnd l1)) + + pure a = + -- Return a value without performing any stateful computation, and without + -- any delimiting effect on the surrounding computations. + liftHdkA (pure a) + +{- Note [Smart reordering in HdkA (or lack of thereof)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When traversing the AST, the user must take care to traverse it in concrete +syntax order. + +For example, when processing HsFunTy, it's important to get it right and write +it like so: + + HsFunTy _ mult lhs rhs -> do + lhs' <- addHaddock lhs + rhs' <- addHaddock rhs + pure $ L l (HsFunTy noExtField mult lhs' rhs') + +Rather than like so: + + HsFunTy _ mult lhs rhs -> do + rhs' <- addHaddock rhs -- bad! wrong order + lhs' <- addHaddock lhs -- bad! wrong order + pure $ L l (HsFunTy noExtField mult lhs' rhs') + +This is somewhat bug-prone, so we could try to fix this with some Applicative +magic. When we define (<*>) for HdkA, why not reorder the computations as +necessary? In pseudo-code: + + a1 <*> a2 | a1 `before` a2 = ... normal processing ... + | otherwise = a1 <**> a2 + +While this trick could work for any two *adjacent* AST elements out of order +(as in HsFunTy example above), it would fail in more elaborate scenarios (e.g. +processing a list of declarations out of order). + +If it's not obvious why this trick doesn't work, ponder this: it's a bit like trying to get +a sorted list by defining a 'smart' concatenation operator in the following manner: + + a ?++ b | a <= b = a ++ b + | otherwise = b ++ a + +At first glance it seems to work: + + ghci> [1] ?++ [2] ?++ [3] + [1,2,3] + + ghci> [2] ?++ [1] ?++ [3] + [1,2,3] -- wow, sorted! + +But it actually doesn't: + + ghci> [3] ?++ [1] ?++ [2] + [1,3,2] -- not sorted... +-} + +-- Run a HdkA computation in an unrestricted LocRange. This is only used at the +-- top level to run the final computation for the entire module. +runHdkA :: HdkA a -> HdkSt -> (a, HdkSt) +runHdkA (HdkA _ m) = unHdkM m mempty + +-- Let the neighbours know about an item at this location. +-- +-- Consider this example: +-- +-- class -- | peculiarly placed comment +-- MyClass a where +-- my_method :: a -> a +-- +-- How do we know to reject the "peculiarly placed comment" instead of +-- associating it with my_method? Its indentation level matches. +-- +-- But clearly, there's "MyClass a where" separating the comment and my_method. +-- To take it into account, we must register its location using registerLocHdkA +-- or registerHdkA. +-- +-- See Note [Register keyword location]. +-- See Note [Adding Haddock comments to the syntax tree]. +registerLocHdkA :: SrcSpan -> HdkA () +registerLocHdkA l = HdkA (getBufSpan l) (pure ()) + +-- Let the neighbours know about an item at this location. +-- A small wrapper over registerLocHdkA. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +registerHdkA :: Located a -> HdkA () +registerHdkA a = registerLocHdkA (getLoc a) + +-- Modify the action of a HdkA computation. +hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b +hoistHdkA f (HdkA l m) = HdkA l (f m) + +-- Lift a HdkM computation to HdkA. +liftHdkA :: HdkM a -> HdkA a +liftHdkA = HdkA mempty + +-- Extend the declared location span of a 'HdkA' computation: +-- +-- left_neighbour <*> extendHdkA l x <*> right_neighbour +-- +-- The declared location of 'x' now includes 'l', so that the surrounding +-- computations 'left_neighbour' and 'right_neighbour' will not look for +-- Haddock comments inside the 'l' location span. +extendHdkA :: SrcSpan -> HdkA a -> HdkA a +extendHdkA l' (HdkA l m) = HdkA (getBufSpan l' <> l) m + + +{- ********************************************************************* +* * +* HdkM: a stateful computation to associate * +* accumulated documentation comments with AST nodes * +* * +********************************************************************* -} + +-- The state of 'HdkM' contains a list of pending Haddock comments. We go +-- over the AST, looking up these comments using 'takeHdkComments' and removing +-- them from the state. The remaining, un-removed ones are ignored with a +-- warning (-Winvalid-haddock). Also, using a state means we never use the same +-- Haddock twice. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +newtype HdkM a = HdkM (ReaderT LocRange (State HdkSt) a) + deriving (Functor, Applicative, Monad) + +-- | The state of HdkM. +data HdkSt = + HdkSt + { hdk_st_pending :: [PsLocated HdkComment] + -- a list of pending (unassociated with an AST node) + -- Haddock comments, sorted by location: in ascending order of the starting 'BufPos' + , hdk_st_warnings :: [HdkWarn] + -- accumulated warnings (order doesn't matter) + } + +-- | Warnings accumulated in HdkM. +data HdkWarn + = HdkWarnInvalidComment (PsLocated HdkComment) + | HdkWarnExtraComment LHsDocString + +-- 'HdkM' without newtype wrapping/unwrapping. +type InlineHdkM a = LocRange -> HdkSt -> (a, HdkSt) + +mkHdkM :: InlineHdkM a -> HdkM a +unHdkM :: HdkM a -> InlineHdkM a +mkHdkM = coerce +unHdkM = coerce + +-- Restrict the range in which a HdkM computation will look up comments: +-- +-- inLocRange r1 $ +-- inLocRange r2 $ +-- takeHdkComments ... -- Only takes comments in the (r1 <> r2) location range. +-- +-- Note that it does not blindly override the range but tightens it using (<>). +-- At many use sites, you will see something along the lines of: +-- +-- inLocRange (locRangeTo end_pos) $ ... +-- +-- And 'locRangeTo' defines a location range from the start of the file to +-- 'end_pos'. This does not mean that we now search for every comment from the +-- start of the file, as this restriction will be combined with other +-- restrictions. Somewhere up the callstack we might have: +-- +-- inLocRange (locRangeFrom start_pos) $ ... +-- +-- The net result is that the location range is delimited by 'start_pos' on +-- one side and by 'end_pos' on the other side. +-- +-- In 'HdkA', every (<*>) may restrict the location range of its +-- subcomputations. +inLocRange :: LocRange -> HdkM a -> HdkM a +inLocRange r (HdkM m) = HdkM (local (mappend r) m) + +-- Take the Haddock comments that satisfy the matching function, +-- leaving the rest pending. +takeHdkComments :: forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a] +takeHdkComments f = + mkHdkM $ + \(LocRange hdk_from hdk_to hdk_col) -> + \hdk_st -> + let + comments = hdk_st_pending hdk_st + (comments_before_range, comments') = break (is_after hdk_from) comments + (comments_in_range, comments_after_range) = span (is_before hdk_to <&&> is_indented hdk_col) comments' + (items, other_comments) = foldr add_comment ([], []) comments_in_range + remaining_comments = comments_before_range ++ other_comments ++ comments_after_range + hdk_st' = hdk_st{ hdk_st_pending = remaining_comments } + in + (items, hdk_st') + where + is_after StartOfFile _ = True + is_after (StartLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l + is_before EndOfFile _ = True + is_before (EndLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) <= l + is_indented (ColumnFrom n) (L l_comment _) = srcSpanStartCol (psRealSpan l_comment) >= n + + add_comment + :: PsLocated HdkComment + -> ([a], [PsLocated HdkComment]) + -> ([a], [PsLocated HdkComment]) + add_comment hdk_comment (items, other_hdk_comments) = + case f hdk_comment of + Just item -> (item : items, other_hdk_comments) + Nothing -> (items, hdk_comment : other_hdk_comments) + +-- Get the docnext or docprev comment for an AST node at the given source span. +getPrevNextDoc :: SrcSpan -> HdkM (Maybe LHsDocString) +getPrevNextDoc l = do + let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l) + before_t = locRangeTo (getBufPos l_start) + after_t = locRangeFrom (getBufPos l_end) + nextDocs <- inLocRange before_t $ takeHdkComments mkDocNext + prevDocs <- inLocRange after_t $ takeHdkComments mkDocPrev + selectDocString (nextDocs ++ prevDocs) + +appendHdkWarning :: HdkWarn -> HdkM () +appendHdkWarning e = HdkM (ReaderT (\_ -> modify append_warn)) + where + append_warn hdk_st = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st } + +selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString) +selectDocString = select . filterOut (isEmptyDocString . unLoc) + where + select [] = return Nothing + select [doc] = return (Just doc) + select (doc : extra_docs) = do + reportExtraDocs extra_docs + return (Just doc) + +reportExtraDocs :: [LHsDocString] -> HdkM () +reportExtraDocs = + traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) + +{- ********************************************************************* +* * +* Matching functions for extracting documentation comments * +* * +********************************************************************* -} + +mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) +mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a + +mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl +mkDocDecl layout_info (L l_comment hdk_comment) + | indent_mismatch = Nothing + | otherwise = + Just $ L (mkSrcSpanPs l_comment) $ + case hdk_comment of + HdkCommentNext doc -> DocCommentNext doc + HdkCommentPrev doc -> DocCommentPrev doc + HdkCommentNamed s doc -> DocCommentNamed s doc + HdkCommentSection n doc -> DocGroup n doc + where + -- 'indent_mismatch' checks if the documentation comment has the exact + -- indentation level expected by the parent node. + -- + -- For example, when extracting documentation comments between class + -- method declarations, there are three cases to consider: + -- + -- 1. Indent matches (indent_mismatch=False): + -- class C a where + -- f :: a -> a + -- -- ^ doc on f + -- + -- 2. Indented too much (indent_mismatch=True): + -- class C a where + -- f :: a -> a + -- -- ^ indent mismatch + -- + -- 3. Indented too little (indent_mismatch=True): + -- class C a where + -- f :: a -> a + -- -- ^ indent mismatch + indent_mismatch = case layout_info of + NoLayoutInfo -> False + ExplicitBraces -> False + VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) + +mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) +mkDocIE (L l_comment hdk_comment) = + case hdk_comment of + HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n doc) + HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) + HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc) + _ -> Nothing + where l = mkSrcSpanPs l_comment + +mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString +mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocNext _ = Nothing + +mkDocPrev :: PsLocated HdkComment -> Maybe LHsDocString +mkDocPrev (L l (HdkCommentPrev doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocPrev _ = Nothing + + +{- ********************************************************************* +* * +* LocRange: a location range * +* * +********************************************************************* -} + +-- A location range for extracting documentation comments. +data LocRange = + LocRange + { loc_range_from :: !LowerLocBound, + loc_range_to :: !UpperLocBound, + loc_range_col :: !ColumnBound } + +instance Semigroup LocRange where + LocRange from1 to1 col1 <> LocRange from2 to2 col2 = + LocRange (from1 <> from2) (to1 <> to2) (col1 <> col2) + +instance Monoid LocRange where + mempty = LocRange mempty mempty mempty + +-- The location range from the specified position to the end of the file. +locRangeFrom :: Maybe BufPos -> LocRange +locRangeFrom (Just l) = mempty { loc_range_from = StartLoc l } +locRangeFrom Nothing = mempty + +-- The location range from the start of the file to the specified position. +locRangeTo :: Maybe BufPos -> LocRange +locRangeTo (Just l) = mempty { loc_range_to = EndLoc l } +locRangeTo Nothing = mempty + +-- Represents a predicate on BufPos: +-- +-- LowerLocBound | BufPos -> Bool +-- --------------+----------------- +-- StartOfFile | const True +-- StartLoc p | (>= p) +-- +-- The semigroup instance corresponds to (&&). +-- +-- We don't use the BufPos -> Bool representation +-- as it would lead to redundant checks. +-- +-- That is, instead of +-- +-- (pos >= 20) && (pos >= 30) && (pos >= 40) +-- +-- We'd rather only do the (>=40) check. So we reify the predicate to make +-- sure we only check for the most restrictive bound. +data LowerLocBound = StartOfFile | StartLoc !BufPos + +instance Semigroup LowerLocBound where + StartOfFile <> l = l + l <> StartOfFile = l + StartLoc l1 <> StartLoc l2 = StartLoc (max l1 l2) + +instance Monoid LowerLocBound where + mempty = StartOfFile + +-- Represents a predicate on BufPos: +-- +-- UpperLocBound | BufPos -> Bool +-- --------------+----------------- +-- EndOfFile | const True +-- EndLoc p | (<= p) +-- +-- The semigroup instance corresponds to (&&). +-- +-- We don't use the BufPos -> Bool representation +-- as it would lead to redundant checks. +-- +-- That is, instead of +-- +-- (pos <= 40) && (pos <= 30) && (pos <= 20) +-- +-- We'd rather only do the (<=20) check. So we reify the predicate to make +-- sure we only check for the most restrictive bound. +data UpperLocBound = EndOfFile | EndLoc !BufPos + +instance Semigroup UpperLocBound where + EndOfFile <> l = l + l <> EndOfFile = l + EndLoc l1 <> EndLoc l2 = EndLoc (min l1 l2) + +instance Monoid UpperLocBound where + mempty = EndOfFile + +-- | Represents a predicate on the column number. +-- +-- ColumnBound | Int -> Bool +-- --------------+----------------- +-- ColumnFrom n | (>=n) +-- +-- The semigroup instance corresponds to (&&). +-- +newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn + +instance Semigroup ColumnBound where + ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m) + +instance Monoid ColumnBound where + mempty = ColumnFrom leftmostColumn + + +{- ********************************************************************* +* * +* AST manipulation utilities * +* * +********************************************************************* -} + +mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs +mkLHsDocTy t Nothing = t +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t doc) + +getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan +getForAllTeleLoc tele = + foldr combineSrcSpans noSrcSpan $ + case tele of + HsForAllVis{ hsf_vis_bndrs } -> map getLoc hsf_vis_bndrs + HsForAllInvis { hsf_invis_bndrs } -> map getLoc hsf_invis_bndrs + +-- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back +-- into a flat list. Elements are put back into the order in which they +-- appeared in the original program before partitioning, using BufPos to order +-- them. +-- +-- Precondition (unchecked): the input lists are already sorted. +flattenBindsAndSigs + :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) + -> [LHsDecl GhcPs] +flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) = + -- 'cmpBufSpan' is safe here with the following assumptions: + -- + -- * 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan' + -- * 'partitionBindsAndSigs' does not discard this 'BufSpan' + mergeListsBy cmpBufSpan [ + mapLL (\b -> ValD noExtField b) (bagToList all_bs), + mapLL (\s -> SigD noExtField s) all_ss, + mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts, + mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis, + mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis, + mapLL (\d -> DocD noExtField d) all_docs + ] + +{- ********************************************************************* +* * +* General purpose utilities * +* * +********************************************************************* -} + +-- Cons an element to a list, if exists. +mcons :: Maybe a -> [a] -> [a] +mcons = maybe id (:) + +-- Map a function over a list of located items. +mapLL :: (a -> b) -> [Located a] -> [Located b] +mapLL f = map (mapLoc f) + +{- Note [Old solution: Haddock in the grammar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the past, Haddock comments were incorporated into the grammar (Parser.y). +This led to excessive complexity and duplication. + +For example, here's the grammar production for types without documentation: + + type : btype + | btype '->' ctype + +To support Haddock, we had to also maintain an additional grammar production +for types with documentation on function arguments and function result: + + typedoc : btype + | btype docprev + | docnext btype + | btype '->' ctypedoc + | btype docprev '->' ctypedoc + | docnext btype '->' ctypedoc + +Sometimes handling documentation comments during parsing led to bugs (#17561), +and sometimes it simply made it hard to modify and extend the grammar. + +Another issue was that sometimes Haddock would fail to parse code +that GHC could parse succesfully: + + class BadIndent where + f :: a -> Int + -- ^ comment + g :: a -> Int + +This declaration was accepted by ghc but rejected by ghc -haddock. +-} + +{- Note [Register keyword location] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment, 'addHaddock' erroneously associates some comments with +constructs that are separated by a keyword. For example: + + data Foo -- | Comment for MkFoo + where MkFoo :: Foo + +The issue stems from the lack of location information for keywords. We could +utilize API Annotations for this purpose, but not without modification. For +example, API Annotations operate on RealSrcSpan, whereas we need BufSpan. + +Also, there's work towards making API Annotations available in-tree (not in +a separate Map), see #17638. This change should make the fix very easy (it +is not as easy with the current design). + +See also testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs +-} diff --git a/GHC/Platform/AArch64.hs b/GHC/Platform/AArch64.hs --- a/GHC/Platform/AArch64.hs +++ b/GHC/Platform/AArch64.hs @@ -2,7 +2,7 @@ module GHC.Platform.AArch64 where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_aarch64 1 diff --git a/GHC/Platform/ARM.hs b/GHC/Platform/ARM.hs --- a/GHC/Platform/ARM.hs +++ b/GHC/Platform/ARM.hs @@ -2,7 +2,7 @@ module GHC.Platform.ARM where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_arm 1 diff --git a/GHC/Platform/NoRegs.hs b/GHC/Platform/NoRegs.hs --- a/GHC/Platform/NoRegs.hs +++ b/GHC/Platform/NoRegs.hs @@ -2,7 +2,7 @@ module GHC.Platform.NoRegs where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 1 #include "../../../includes/CodeGen.Platform.hs" diff --git a/GHC/Platform/PPC.hs b/GHC/Platform/PPC.hs --- a/GHC/Platform/PPC.hs +++ b/GHC/Platform/PPC.hs @@ -2,7 +2,7 @@ module GHC.Platform.PPC where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_powerpc 1 diff --git a/GHC/Platform/Reg.hs b/GHC/Platform/Reg.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg.hs @@ -0,0 +1,245 @@ +-- | An architecture independent description of a register. +-- This needs to stay architecture independent because it is used +-- by NCGMonad and the register allocators, which are shared +-- by all architectures. +-- +module GHC.Platform.Reg ( + RegNo, + Reg(..), + regPair, + regSingle, + realRegSingle, + isRealReg, takeRealReg, + isVirtualReg, takeVirtualReg, + + VirtualReg(..), + renameVirtualReg, + classOfVirtualReg, + getHiVirtualRegFromLo, + getHiVRegFromLo, + + RealReg(..), + regNosOfRealReg, + realRegsAlias, + + liftPatchFnToRegReg +) + +where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Platform.Reg.Class +import Data.List (intersect) + +-- | An identifier for a primitive real machine register. +type RegNo + = Int + +-- VirtualRegs are virtual registers. The register allocator will +-- eventually have to map them into RealRegs, or into spill slots. +-- +-- VirtualRegs are allocated on the fly, usually to represent a single +-- value in the abstract assembly code (i.e. dynamic registers are +-- usually single assignment). +-- +-- The single assignment restriction isn't necessary to get correct code, +-- although a better register allocation will result if single +-- assignment is used -- because the allocator maps a VirtualReg into +-- a single RealReg, even if the VirtualReg has multiple live ranges. +-- +-- Virtual regs can be of either class, so that info is attached. +-- +data VirtualReg + = VirtualRegI {-# UNPACK #-} !Unique + | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register + | VirtualRegF {-# UNPACK #-} !Unique + | VirtualRegD {-# UNPACK #-} !Unique + + deriving (Eq, Show) + +-- This is laborious, but necessary. We can't derive Ord because +-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the +-- implementation. See Note [No Ord for Unique] +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +instance Ord VirtualReg where + compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b + compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b + compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b + compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b + + compare VirtualRegI{} _ = LT + compare _ VirtualRegI{} = GT + compare VirtualRegHi{} _ = LT + compare _ VirtualRegHi{} = GT + compare VirtualRegF{} _ = LT + compare _ VirtualRegF{} = GT + + + +instance Uniquable VirtualReg where + getUnique reg + = case reg of + VirtualRegI u -> u + VirtualRegHi u -> u + VirtualRegF u -> u + VirtualRegD u -> u + +instance Outputable VirtualReg where + ppr reg + = case reg of + VirtualRegI u -> text "%vI_" <> pprUniqueAlways u + VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u + -- this code is kinda wrong on x86 + -- because float and double occupy the same register set + -- namely SSE2 register xmm0 .. xmm15 + VirtualRegF u -> text "%vFloat_" <> pprUniqueAlways u + VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u + + + +renameVirtualReg :: Unique -> VirtualReg -> VirtualReg +renameVirtualReg u r + = case r of + VirtualRegI _ -> VirtualRegI u + VirtualRegHi _ -> VirtualRegHi u + VirtualRegF _ -> VirtualRegF u + VirtualRegD _ -> VirtualRegD u + + +classOfVirtualReg :: VirtualReg -> RegClass +classOfVirtualReg vr + = case vr of + VirtualRegI{} -> RcInteger + VirtualRegHi{} -> RcInteger + VirtualRegF{} -> RcFloat + VirtualRegD{} -> RcDouble + + + +-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform +-- when supplied with the vreg for the lower-half of the quantity. +-- (NB. Not reversible). +getHiVirtualRegFromLo :: VirtualReg -> VirtualReg +getHiVirtualRegFromLo reg + = case reg of + -- makes a pseudo-unique with tag 'H' + VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + _ -> panic "Reg.getHiVirtualRegFromLo" + +getHiVRegFromLo :: Reg -> Reg +getHiVRegFromLo reg + = case reg of + RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) + RegReal _ -> panic "Reg.getHiVRegFromLo" + + +------------------------------------------------------------------------------------ +-- | RealRegs are machine regs which are available for allocation, in +-- the usual way. We know what class they are, because that's part of +-- the processor's architecture. +-- +-- RealRegPairs are pairs of real registers that are allocated together +-- to hold a larger value, such as with Double regs on SPARC. +-- +data RealReg + = RealRegSingle {-# UNPACK #-} !RegNo + | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo + deriving (Eq, Show, Ord) + +instance Uniquable RealReg where + getUnique reg + = case reg of + RealRegSingle i -> mkRegSingleUnique i + RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) + +instance Outputable RealReg where + ppr reg + = case reg of + RealRegSingle i -> text "%r" <> int i + RealRegPair r1 r2 -> text "%r(" <> int r1 + <> vbar <> int r2 <> text ")" + +regNosOfRealReg :: RealReg -> [RegNo] +regNosOfRealReg rr + = case rr of + RealRegSingle r1 -> [r1] + RealRegPair r1 r2 -> [r1, r2] + + +realRegsAlias :: RealReg -> RealReg -> Bool +realRegsAlias rr1 rr2 + = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) + +-------------------------------------------------------------------------------- +-- | A register, either virtual or real +data Reg + = RegVirtual !VirtualReg + | RegReal !RealReg + deriving (Eq, Ord) + +regSingle :: RegNo -> Reg +regSingle regNo = RegReal (realRegSingle regNo) + +realRegSingle :: RegNo -> RealReg +realRegSingle regNo = RealRegSingle regNo + +regPair :: RegNo -> RegNo -> Reg +regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 + + +-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets +-- in the register allocator. +instance Uniquable Reg where + getUnique reg + = case reg of + RegVirtual vr -> getUnique vr + RegReal rr -> getUnique rr + +-- | Print a reg in a generic manner +-- If you want the architecture specific names, then use the pprReg +-- function from the appropriate Ppr module. +instance Outputable Reg where + ppr reg + = case reg of + RegVirtual vr -> ppr vr + RegReal rr -> ppr rr + + +isRealReg :: Reg -> Bool +isRealReg reg + = case reg of + RegReal _ -> True + RegVirtual _ -> False + +takeRealReg :: Reg -> Maybe RealReg +takeRealReg reg + = case reg of + RegReal rr -> Just rr + _ -> Nothing + + +isVirtualReg :: Reg -> Bool +isVirtualReg reg + = case reg of + RegReal _ -> False + RegVirtual _ -> True + +takeVirtualReg :: Reg -> Maybe VirtualReg +takeVirtualReg reg + = case reg of + RegReal _ -> Nothing + RegVirtual vr -> Just vr + + +-- | The patch function supplied by the allocator maps VirtualReg to RealReg +-- regs, but sometimes we want to apply it to plain old Reg. +-- +liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) +liftPatchFnToRegReg patchF reg + = case reg of + RegVirtual vr -> RegReal (patchF vr) + RegReal _ -> reg diff --git a/GHC/Platform/Reg/Class.hs b/GHC/Platform/Reg/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class.hs @@ -0,0 +1,32 @@ +-- | An architecture independent description of a register's class. +module GHC.Platform.Reg.Class + ( RegClass (..) ) + +where + +import GHC.Prelude + +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique + + +-- | The class of a register. +-- Used in the register allocator. +-- We treat all registers in a class as being interchangeable. +-- +data RegClass + = RcInteger + | RcFloat + | RcDouble + deriving Eq + + +instance Uniquable RegClass where + getUnique RcInteger = mkRegClassUnique 0 + getUnique RcFloat = mkRegClassUnique 1 + getUnique RcDouble = mkRegClassUnique 2 + +instance Outputable RegClass where + ppr RcInteger = Outputable.text "I" + ppr RcFloat = Outputable.text "F" + ppr RcDouble = Outputable.text "D" diff --git a/GHC/Platform/Regs.hs b/GHC/Platform/Regs.hs --- a/GHC/Platform/Regs.hs +++ b/GHC/Platform/Regs.hs @@ -2,11 +2,11 @@ (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg) where -import GhcPrelude +import GHC.Prelude -import CmmExpr +import GHC.Cmm.Expr import GHC.Platform -import Reg +import GHC.Platform.Reg import qualified GHC.Platform.ARM as ARM import qualified GHC.Platform.AArch64 as AArch64 @@ -41,7 +41,7 @@ -- The order matters (for the llvm backend anyway)! We must make sure to -- maintain the order here with the order used in the LLVM calling conventions. -- Note that also, this isn't all registers, just the ones that are currently --- possbily mapped to real registers. +-- possibly mapped to real registers. activeStgRegs :: Platform -> [GlobalReg] activeStgRegs platform | platformUnregisterised platform = NoRegs.activeStgRegs diff --git a/GHC/Platform/S390X.hs b/GHC/Platform/S390X.hs --- a/GHC/Platform/S390X.hs +++ b/GHC/Platform/S390X.hs @@ -2,7 +2,7 @@ module GHC.Platform.S390X where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_s390x 1 diff --git a/GHC/Platform/SPARC.hs b/GHC/Platform/SPARC.hs --- a/GHC/Platform/SPARC.hs +++ b/GHC/Platform/SPARC.hs @@ -2,7 +2,7 @@ module GHC.Platform.SPARC where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_sparc 1 diff --git a/GHC/Platform/X86.hs b/GHC/Platform/X86.hs --- a/GHC/Platform/X86.hs +++ b/GHC/Platform/X86.hs @@ -2,7 +2,7 @@ module GHC.Platform.X86 where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_i386 1 diff --git a/GHC/Platform/X86_64.hs b/GHC/Platform/X86_64.hs --- a/GHC/Platform/X86_64.hs +++ b/GHC/Platform/X86_64.hs @@ -2,7 +2,7 @@ module GHC.Platform.X86_64 where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_x86_64 1 diff --git a/GHC/Plugins.hs b/GHC/Plugins.hs new file mode 100644 --- /dev/null +++ b/GHC/Plugins.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-} + +-- | This module is not used by GHC itself. Rather, it exports all of +-- the functions and types you are likely to need when writing a +-- plugin for GHC. So authors of plugins can probably get away simply +-- with saying "import GHC.Plugins". +-- +-- Particularly interesting modules for plugin writers include +-- "GHC.Core" and "GHC.Core.Opt.Monad". +module GHC.Plugins + ( module GHC.Driver.Plugins + , module GHC.Types.Name.Reader + , module GHC.Types.Name.Occurrence + , module GHC.Types.Name + , module GHC.Types.Var + , module GHC.Types.Id + , module GHC.Types.Id.Info + , module GHC.Core.Opt.Monad + , module GHC.Core + , module GHC.Types.Literal + , module GHC.Core.DataCon + , module GHC.Core.Utils + , module GHC.Core.Make + , module GHC.Core.FVs + , module GHC.Core.Subst + , module GHC.Core.Rules + , module GHC.Types.Annotations + , module GHC.Driver.Session + , module GHC.Unit.State + , module GHC.Unit.Module + , module GHC.Core.Type + , module GHC.Core.TyCon + , module GHC.Core.Coercion + , module GHC.Builtin.Types + , module GHC.Driver.Types + , module GHC.Types.Basic + , module GHC.Types.Var.Set + , module GHC.Types.Var.Env + , module GHC.Types.Name.Set + , module GHC.Types.Name.Env + , module GHC.Types.Unique + , module GHC.Types.Unique.Set + , module GHC.Types.Unique.FM + , module GHC.Data.FiniteMap + , module GHC.Utils.Misc + , module GHC.Serialized + , module GHC.Types.SrcLoc + , module GHC.Utils.Outputable + , module GHC.Types.Unique.Supply + , module GHC.Data.FastString + , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins + , -- * Getting 'Name's + thNameToGhcName + ) +where + +-- Plugin stuff itself +import GHC.Driver.Plugins + +-- Variable naming +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence hiding ( varName {- conflicts with Var.varName -} ) +import GHC.Types.Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) +import GHC.Types.Var +import GHC.Types.Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) +import GHC.Types.Id.Info + +-- Core +import GHC.Core.Opt.Monad +import GHC.Core +import GHC.Types.Literal +import GHC.Core.DataCon +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.FVs +import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) + -- These names are also exported by Type + +-- Core "extras" +import GHC.Core.Rules +import GHC.Types.Annotations + +-- Pipeline-related stuff +import GHC.Driver.Session +import GHC.Unit.State + +-- Important GHC types +import GHC.Unit.Module +import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -} + ( substTy, extendTvSubst, extendTvSubstList, isInScope ) +import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} + ( substCo ) +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Driver.Types +import GHC.Types.Basic + +-- Collections and maps +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +-- Conflicts with UniqFM: +--import LazyUniqFM +import GHC.Data.FiniteMap + +-- Common utilities +import GHC.Utils.Misc +import GHC.Serialized +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Types.Unique.Supply +import GHC.Types.Unique ( Unique, Uniquable(..) ) +import GHC.Data.FastString +import Data.Maybe + +import GHC.Iface.Env ( lookupOrigIO ) +import GHC.Prelude +import GHC.Utils.Monad ( mapMaybeM ) +import GHC.ThToHs ( thRdrNameGuesses ) +import GHC.Tc.Utils.Env ( lookupGlobal ) + +import GHC.Tc.Errors.Hole.FitTypes + +import qualified Language.Haskell.TH as TH + +{- This instance is defined outside GHC.Core.Opt.Monad so that + GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -} +instance MonadThings CoreM where + lookupThing name = do { hsc_env <- getHscEnv + ; liftIO $ lookupGlobal hsc_env name } + +{- +************************************************************************ +* * + Template Haskell interoperability +* * +************************************************************************ +-} + +-- | Attempt to convert a Template Haskell name to one that GHC can +-- understand. Original TH names such as those you get when you use +-- the @'foo@ syntax will be translated to their equivalent GHC name +-- exactly. Qualified or unqualified TH names will be dynamically bound +-- to names in the module being compiled, if possible. Exact TH names +-- will be bound to the name they represent, exactly. +thNameToGhcName :: TH.Name -> CoreM (Maybe Name) +thNameToGhcName th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference + -- to the data constructor A + ; return (listToMaybe names) } + where + lookup rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = return $ if isExternalName n then Just n else Nothing + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { hsc_env <- getHscEnv + ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) } + | otherwise = return Nothing diff --git a/GHC/Prelude.hs b/GHC/Prelude.hs new file mode 100644 --- /dev/null +++ b/GHC/Prelude.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +-- | Custom GHC "Prelude" +-- +-- This module serves as a replacement for the "Prelude" module +-- and abstracts over differences between the bootstrapping +-- GHC version, and may also provide a common default vocabulary. + +-- Every module in GHC +-- * Is compiled with -XNoImplicitPrelude +-- * Explicitly imports GHC.Prelude + +module GHC.Prelude (module X) where + +-- We export the 'Semigroup' class but w/o the (<>) operator to avoid +-- clashing with the (Outputable.<>) operator which is heavily used +-- through GHC's code-base. + +import Prelude as X hiding ((<>)) +import Data.Foldable as X (foldl') + +{- +Note [Why do we import Prelude here?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and +ghc-heap.cabal contain the directive default-extensions: +NoImplicitPrelude. There are two motivations for this: + - Consistency with the compiler directory, which enables + NoImplicitPrelude; + - Allows loading the above dependent packages with ghc-in-ghci, + giving a smoother development experience when adding new + extensions. +-} diff --git a/GHC/Rename/Bind.hs b/GHC/Rename/Bind.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Bind.hs @@ -0,0 +1,1326 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming and dependency analysis of bindings + +This module does renaming and dependency analysis on value bindings in +the abstract syntax. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). +-} + +module GHC.Rename.Bind ( + -- Renaming top-level bindings + rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS, + + -- Renaming local bindings + rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + + -- Other bindings + rnMethodBinds, renameSigs, + rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, + makeMiniFixityEnv, MiniFixityEnv, + HsSigCtxt(..) + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts ) + +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Rename.HsType +import GHC.Rename.Pat +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn + , checkDupRdrNames, warnUnusedLocalBinds + , checkUnusedRecordWildcard + , checkDupAndShadowedNames, bindLocalNamesFV + , addNoNestedForallsContextsErr, checkInferredVars ) +import GHC.Driver.Session +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader ( RdrName, rdrNameOcc ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Data.List.SetOps ( findDupsEq ) +import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) +import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Unique.Set +import GHC.Data.Maybe ( orElse ) +import GHC.Data.OrdList +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Foldable ( toList ) +import Data.List ( partition, sortBy ) +import Data.List.NonEmpty ( NonEmpty(..) ) + +{- +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + + +************************************************************************ +* * +* naming conventions * +* * +************************************************************************ + +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (HsBinds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +************************************************************************ +* * +* analysing polymorphic bindings (HsBindGroup, HsBind) +* * +************************************************************************ + +\subsubsection[dep-HsBinds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBinds@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the ``vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +************************************************************************ +* * +\subsubsection{ Top-level bindings} +* * +************************************************************************ +-} + +-- for top-level bindings, we need to make top-level names, +-- so we have a different entry point than for local bindings +rnTopBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnTopBindsLHS fix_env binds + = rnValBindsLHS (topRecNameMaker fix_env) binds + +rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +-- A hs-boot file has no bindings. +-- Return a single HsBindGroup with empty binds and renamed signatures +rnTopBindsBoot bound_names (ValBinds _ mbinds sigs) + = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) + ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs + ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } +rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) + +{- +********************************************************* +* * + HsLocalBinds +* * +********************************************************* +-} + +rnLocalBindsAndThen :: HsLocalBinds GhcPs + -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are *not* already in scope +-- (b) removes the binders from the free vars of the thing inside +-- The parser doesn't produce ThenBinds +rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside = + thing_inside (EmptyLocalBinds x) emptyNameSet + +rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> + thing_inside (HsValBinds x val_binds') + +rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do + (binds',fv_binds) <- rnIPBinds binds + (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds + return (thing, fvs_thing `plusFV` fv_binds) + +rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) +rnIPBinds (IPBinds _ ip_binds ) = do + (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds + return (IPBinds noExtField ip_binds', plusFVs fvs_s) + +rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) +rnIPBind (IPBind _ ~(Left n) expr) = do + (expr',fvExpr) <- rnLExpr expr + return (IPBind noExtField (Left n) expr', fvExpr) + +{- +************************************************************************ +* * + ValBinds +* * +************************************************************************ +-} + +-- Renaming local binding groups +-- Does duplicate/shadow check +rnLocalValBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM ([Name], HsValBindsLR GhcRn GhcPs) +rnLocalValBindsLHS fix_env binds + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + + -- Check for duplicates and shadowing + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + + -- We need to check for dups here because we + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + -- Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. + ; let bound_names = collectHsValBinders binds' + -- There should be only Ids, but if there are any bogus + -- pattern synonyms, we'll collect them anyway, so that + -- we don't generate subsequent out-of-scope messages + ; envs <- getRdrEnvs + ; checkDupAndShadowedNames envs bound_names + + ; return (bound_names, binds') } + +-- renames the left-hand sides +-- generic version used both at the top level and for local binds +-- does some error checking, but not what gets done elsewhere at the top level +rnValBindsLHS :: NameMaker + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnValBindsLHS topP (ValBinds x mbinds sigs) + = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds + ; return $ ValBinds x mbinds' sigs } + where + bndrs = collectHsBindsBinders mbinds + doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs + +rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) + +-- General version used both from the top-level and for local things +-- Assumes the LHS vars are in scope +-- +-- Does not bind the local fixity declarations +rnValBindsRHS :: HsSigCtxt + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) + +rnValBindsRHS ctxt (ValBinds _ mbinds sigs) + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs + ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds + ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus + + ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ + getPatSynBinds anal_binds + -- The uses in binds_w_dus for PatSynBinds do not include + -- variables used in the patsyn builders; see + -- Note [Pattern synonym builders don't yield dependencies] + -- But psb_fvs /does/ include those builder fvs. So we + -- add them back in here to avoid bogus warnings about + -- unused variables (#12548) + + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs + `plusDU` usesOnly patsyn_fvs + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs + + ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } + +rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) + +-- Wrapper for local binds +-- +-- The *client* of this function is responsible for checking for unused binders; +-- it doesn't (and can't: we don't have the thing inside the binds) happen here +-- +-- The client is also responsible for bringing the fixities into scope +rnLocalValBindsRHS :: NameSet -- names bound by the LHSes + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +rnLocalValBindsRHS bound_names binds + = rnValBindsRHS (LocalBindCtxt bound_names) binds + +-- for local binds +-- wrapper that does both the left- and right-hand sides +-- +-- here there are no local fixity decls passed in; +-- the local fixity decls come from the ValBinds sigs +rnLocalValBindsAndThen + :: HsValBinds GhcPs + -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside + = do { -- (A) Create the local fixity environment + new_fixities <- makeMiniFixityEnv [ L loc sig + | L loc (FixSig _ sig) <- sigs] + + -- (B) Rename the LHSes + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + + -- ...and bring them (and their fixities) into scope + ; bindLocalNamesFV bound_names $ + addLocalFixities new_fixities bound_names $ do + + { -- (C) Do the RHS and thing inside + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + ; (result, result_fvs) <- thing_inside binds' (allUses dus) + + -- Report unused bindings based on the (accurate) + -- findUses. E.g. + -- let x = x in 3 + -- should report 'x' unused + ; let real_uses = findUses dus result_fvs + -- Insert fake uses for variables introduced implicitly by + -- wildcards (#4404) + rec_uses = hsValBindsImplicits binds' + implicit_uses = mkNameSet $ concatMap snd + $ rec_uses + ; mapM_ (\(loc, ns) -> + checkUnusedRecordWildcard loc real_uses (Just ns)) + rec_uses + ; warnUnusedLocalBinds bound_names + (real_uses `unionNameSet` implicit_uses) + + ; let + -- The variables "used" in the val binds are: + -- (1) the uses of the binds (allUses) + -- (2) the FVs of the thing-inside + all_uses = allUses dus `plusFV` result_fvs + -- Note [Unused binding hack] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Note that *in contrast* to the above reporting of + -- unused bindings, (1) above uses duUses to return *all* + -- the uses, even if the binding is unused. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used + -- If we don't "see" the dependency of 'y' on 'x', we may put the + -- bindings in the wrong order, and the type checker will complain + -- that x isn't in scope + -- + -- But note that this means we won't report 'x' as unused, + -- whereas we would if we had { x = 3; p = x; y = 'x' } + + ; return (result, all_uses) }} + -- The bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above + +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) + + +--------------------- + +-- renaming a single bind + +rnBindLHS :: NameMaker + -> SDoc + -> HsBind GhcPs + -- returns the renamed left-hand side, + -- and the FreeVars *of the LHS* + -- (i.e., any free variables of the pattern) + -> RnM (HsBindLR GhcRn GhcPs) + +rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) + = do + -- we don't actually use the FV processing of rnPatsAndThen here + (pat',pat'_fvs) <- rnBindPat name_maker pat + return (bind { pat_lhs = pat', pat_ext = pat'_fvs }) + -- We temporarily store the pat's FVs in bind_fvs; + -- gets updated to the FVs of the whole bind + -- when doing the RHS below + +rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) + = do { name <- applyNameMaker name_maker rdr_name + ; return (bind { fun_id = name + , fun_ext = noExtField }) } + +rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) + | isTopRecNameMaker name_maker + = do { addLocM checkConName rdrname + ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already + ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + + | otherwise -- Pattern synonym, not at top level + = do { addErr localPatternSynonymErr -- Complain, but make up a fake + -- name so that we can carry on + ; name <- applyNameMaker name_maker rdrname + ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + where + localPatternSynonymErr :: SDoc + localPatternSynonymErr + = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + 2 (text "Pattern synonym declarations are only valid at top level") + +rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) + +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> LHsBindLR GhcRn GhcPs + -> RnM (LHsBind GhcRn, [Name], Uses) +rnLBind sig_fn (L loc bind) + = setSrcSpan loc $ + do { (bind', bndrs, dus) <- rnBind sig_fn bind + ; return (L loc bind', bndrs, dus) } + +-- assumes the left-hands-side vars are in scope +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> HsBindLR GhcRn GhcPs + -> RnM (HsBind GhcRn, [Name], Uses) +rnBind _ bind@(PatBind { pat_lhs = pat + , pat_rhs = grhss + -- pat fvs were stored in bind_fvs + -- after processing the LHS + , pat_ext = pat_fvs }) + = do { mod <- getModule + ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss + + -- No scoped type variables for pattern bindings + ; let all_fvs = pat_fvs `plusFV` rhs_fvs + fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + bndrs = collectPatBinders pat + bind' = bind { pat_rhs = grhss' + , pat_ext = fvs' } + + ok_nobind_pat + = -- See Note [Pattern bindings that bind no variables] + case unLoc pat of + WildPat {} -> True + BangPat {} -> True -- #9127, #13646 + SplicePat {} -> True + _ -> False + + -- Warn if the pattern binds no variables + -- See Note [Pattern bindings that bind no variables] + ; whenWOptM Opt_WarnUnusedPatternBinds $ + when (null bndrs && not ok_nobind_pat) $ + addWarn (Reason Opt_WarnUnusedPatternBinds) $ + unusedPatBindWarn bind' + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', bndrs, all_fvs) } + +rnBind sig_fn bind@(FunBind { fun_id = name + , fun_matches = matches }) + -- invariant: no free vars here when it's a FunBind + = do { let plain_name = unLoc name + + ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for LangExt.ScopedTyVars + rnMatchGroup (mkPrefixFunRhs name) + rnLExpr matches + ; let is_infix = isInfixFunBind bind + ; when is_infix $ checkPrecMatch plain_name matches' + + ; mod <- getModule + ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind { fun_matches = matches' + , fun_ext = fvs' }, + [plain_name], rhs_fvs) + } + +rnBind sig_fn (PatSynBind x bind) + = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind + ; return (PatSynBind x bind', name, fvs) } + +rnBind _ b = pprPanic "rnBind" (ppr b) + +{- Note [Pattern bindings that bind no variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally, we want to warn about pattern bindings like + Just _ = e +because they don't do anything! But we have three exceptions: + +* A wildcard pattern + _ = rhs + which (a) is not that different from _v = rhs + (b) is sometimes used to give a type sig for, + or an occurrence of, a variable on the RHS + +* A strict pattern binding; that is, one with an outermost bang + !Just _ = e + This can fail, so unlike the lazy variant, it is not a no-op. + Moreover, #13646 argues that even for single constructor + types, you might want to write the constructor. See also #9127. + +* A splice pattern + $(th-lhs) = rhs + It is impossible to determine whether or not th-lhs really + binds any variable. We should disable the warning for any pattern + which contain splices, but that is a more expensive check. + +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + +{- ********************************************************************* +* * + Dependency analysis and other support functions +* * +********************************************************************* -} + +depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses) + -> ([(RecFlag, LHsBinds GhcRn)], DefUses) +-- Dependency analysis; this is important so that +-- unused-binding reporting is accurate +depAnalBinds binds_w_dus + = (map get_binds sccs, toOL $ map get_du sccs) + where + sccs = depAnal (\(_, defs, _) -> defs) + (\(_, _, uses) -> nonDetEltsUniqSet uses) + -- It's OK to use nonDetEltsUniqSet here as explained in + -- Note [depAnal determinism] in GHC.Types.Name.Env. + (bagToList binds_w_dus) + + get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) + get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) + + get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) + get_du (CyclicSCC binds_w_dus) = (Just defs, uses) + where + defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] + uses = unionNameSets [u | (_,_,u) <- binds_w_dus] + +--------------------- +-- Bind the top-level forall'd type variables in the sigs. +-- E.g f :: forall a. a -> a +-- f = rhs +-- The 'a' scopes over the rhs +-- +-- NB: there'll usually be just one (for a function binding) +-- but if there are many, one may shadow the rest; too bad! +-- e.g x :: forall a. [a] -> [a] +-- y :: forall a. [(a,a)] -> a +-- (x,y) = e +-- In e, 'a' will be in scope, and it'll be the one from 'y'! + +mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name]) +-- Return a lookup function that maps an Id Name to the names +-- of the type variables that should scope over its body. +mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` [] + where + env = mkHsSigEnv get_scoped_tvs sigs + + get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) + -- Returns (binders, scoped tvs for those binders) + get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs (L _ (TypeSig _ names sig_ty)) + = Just (names, hsWcScopedTvs sig_ty) + get_scoped_tvs (L _ (PatSynSig _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs _ = Nothing + +-- Process the fixity declarations, making a FastString -> (Located Fixity) map +-- (We keep the location around for reporting duplicate fixity declarations.) +-- +-- Checks for duplicates, but not that only locally defined things are fixed. +-- Note: for local fixity declarations, duplicates would also be checked in +-- check_sigs below. But we also use this function at the top level. + +makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv + +makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls + where + add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv + add_one_sig env (L loc (FixitySig _ names fixity)) = + foldlM add_one env [ (loc,name_loc,name,fixity) + | L name_loc name <- names ] + + add_one env (loc, name_loc, name,fixity) = do + { -- this fixity decl is a duplicate iff + -- the ReaderName's OccName's FastString is already in the env + -- (we only need to check the local fix_env because + -- definitions of non-local will be caught elsewhere) + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; + + case lookupFsEnv env fs of + Nothing -> return $ extendFsEnv env fs fix_item + Just (L loc' _) -> do + { setSrcSpan loc $ + addErrAt name_loc (dupFixityDecl loc' name) + ; return env} + } + +dupFixityDecl :: SrcSpan -> RdrName -> SDoc +dupFixityDecl loc rdr_name + = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr loc] + + +{- ********************************************************************* +* * + Pattern synonym bindings +* * +********************************************************************* -} + +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind GhcRn GhcPs + -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) +rnPatSynBind sig_fn bind@(PSB { psb_id = L l name + , psb_args = details + , psb_def = pat + , psb_dir = dir }) + -- invariant: no free vars here when it's a FunBind + = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms + ; unless pattern_synonym_ok (addErr patternSynonymErr) + ; let scoped_tvs = sig_fn name + + ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ + rnPat PatSyn pat $ \pat' -> + -- We check the 'RdrName's instead of the 'Name's + -- so that the binding locations are reported + -- from the left-hand side + case details of + PrefixCon vars -> + do { checkDupRdrNames vars + ; names <- mapM lookupPatSynBndr vars + ; return ( (pat', PrefixCon names) + , mkFVs (map unLoc names)) } + InfixCon var1 var2 -> + do { checkDupRdrNames [var1, var2] + ; name1 <- lookupPatSynBndr var1 + ; name2 <- lookupPatSynBndr var2 + -- ; checkPrecMatch -- TODO + ; return ( (pat', InfixCon name1 name2) + , mkFVs (map unLoc [name1, name2])) } + RecCon vars -> + do { checkDupRdrNames (map recordPatSynSelectorId vars) + ; let rnRecordPatSynField + (RecordPatSynField { recordPatSynSelectorId = visible + , recordPatSynPatVar = hidden }) + = do { visible' <- lookupLocatedTopBndrRn visible + ; hidden' <- lookupPatSynBndr hidden + ; return $ RecordPatSynField { recordPatSynSelectorId = visible' + , recordPatSynPatVar = hidden' } } + ; names <- mapM rnRecordPatSynField vars + ; return ( (pat', RecCon names) + , mkFVs (map (unLoc . recordPatSynPatVar) names)) } + + ; (dir', fvs2) <- case dir of + Unidirectional -> return (Unidirectional, emptyFVs) + ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) + ExplicitBidirectional mg -> + do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $ + rnMatchGroup (mkPrefixFunRhs (L l name)) + rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } + + ; mod <- getModule + ; let fvs = fvs1 `plusFV` fvs2 + fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan + + bind' = bind{ psb_args = details' + , psb_def = pat' + , psb_dir = dir' + , psb_ext = fvs' } + selector_names = case details' of + RecCon names -> + map (unLoc . recordPatSynSelectorId) names + _ -> [] + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', name : selector_names , fvs1) + -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] + } + where + -- See Note [Renaming pattern synonym variables] + lookupPatSynBndr = wrapLocM lookupLocalOccRn + + patternSynonymErr :: SDoc + patternSynonymErr + = hang (text "Illegal pattern synonym declaration") + 2 (text "Use -XPatternSynonyms to enable this extension") + +{- +Note [Renaming pattern synonym variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We rename pattern synonym declaractions backwards to normal to reuse +the logic already implemented for renaming patterns. + +We first rename the RHS of a declaration which brings into +scope the variables bound by the pattern (as they would be +in normal function definitions). We then lookup the variables +which we want to bind in this local environment. + +It is crucial that we then only lookup in the *local* environment which +only contains the variables brought into scope by the pattern and nothing +else. Amazingly no-one encountered this bug for 3 GHC versions but +it was possible to define a pattern synonym which referenced global +identifiers and worked correctly. + +``` +x = 5 + +pattern P :: Int -> () +pattern P x <- _ + +f (P x) = x + +> f () = 5 +``` + +See #13470 for the original report. + +Note [Pattern synonym builders don't yield dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a pattern synonym that has an explicit builder, +references in the builder definition should not be used when +calculating dependencies. For example, consider the following pattern +synonym definition: + +pattern P x <- C1 x where + P x = f (C1 x) + +f (P x) = C2 x + +In this case, 'P' needs to be typechecked in two passes: + +1. Typecheck the pattern definition of 'P', which fully determines the + type of 'P'. This step doesn't require knowing anything about 'f', + since the builder definition is not looked at. + +2. Typecheck the builder definition, which needs the typechecked + definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind + in GHC.Tc.Gen.Bind.tcValBinds. + +This behaviour is implemented in 'tcValBinds', but it crucially +depends on 'P' not being put in a recursive group with 'f' (which +would make it look like a recursive pattern synonym a la 'pattern P = +P' which is unsound and rejected). + +So: + * We do not include builder fvs in the Uses returned by rnPatSynBind + (which is then used for dependency analysis) + * But we /do/ include them in the psb_fvs for the PatSynBind + * In rnValBinds we record these builder uses, to avoid bogus + unused-variable warnings (#12548) +-} + +{- ********************************************************************* +* * + Class/instance method bindings +* * +********************************************************************* -} + +{- @rnMethodBinds@ is used for the method bindings of a class and an instance +declaration. Like @rnBinds@ but without dependency analysis. + +NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. +That's crucial when dealing with an instance decl: +\begin{verbatim} + instance Foo (T a) where + op x = ... +\end{verbatim} +This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, +and unless @op@ occurs we won't treat the type signature of @op@ in the class +decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, +in many ways the @op@ in an instance decl is just like an occurrence, not +a binder. +-} + +rnMethodBinds :: Bool -- True <=> is a class declaration + -> Name -- Class name + -> [Name] -- Type variables from the class/instance header + -> LHsBinds GhcPs -- Binds + -> [LSig GhcPs] -- and signatures/pragmas + -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) +-- Used for +-- * the default method bindings in a class decl +-- * the method bindings in an instance decl +rnMethodBinds is_cls_decl cls ktv_names binds sigs + = do { checkDupRdrNames (collectMethodBinders binds) + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + -- Rename the bindings LHSs + ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds + + -- Rename the pragmas and signatures + -- Annoyingly the type variables /are/ in scope for signatures, but + -- /are not/ in scope in the SPECIALISE instance pramas; e.g. + -- instance Eq a => Eq (T a) where + -- (==) :: a -> a -> a + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs + bound_nms = mkNameSet (collectHsBindsBinders binds') + sig_ctxt | is_cls_decl = ClsDeclCtxt cls + | otherwise = InstDeclCtxt bound_nms + ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags + ; (other_sigs', sig_fvs) <- extendTyVarEnvFVRn ktv_names $ + renameSigs sig_ctxt other_sigs + + -- Rename the bindings RHSs. Again there's an issue about whether the + -- type variables from the class/instance head are in scope. + -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables + ; (binds'', bind_fvs) <- bindSigTyVarsFV ktv_names $ + do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds' + ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) + emptyFVs binds_w_dus + ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } + + ; return ( binds'', spec_inst_prags' ++ other_sigs' + , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } + +rnMethodBindLHS :: Bool -> Name + -> LHsBindLR GhcPs GhcPs + -> LHsBindsLR GhcRn GhcPs + -> RnM (LHsBindsLR GhcRn GhcPs) +rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest + = setSrcSpan loc $ do + do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name + -- We use the selector name as the binder + ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } + ; return (L loc bind' `consBag` rest ) } + +-- Report error for all other forms of bindings +-- This is why we use a fold rather than map +rnMethodBindLHS is_cls_decl _ (L loc bind) rest + = do { addErrAt loc $ + vcat [ what <+> text "not allowed in" <+> decl_sort + , nest 2 (ppr bind) ] + ; return rest } + where + decl_sort | is_cls_decl = text "class declaration:" + | otherwise = text "instance declaration:" + what = case bind of + PatBind {} -> text "Pattern bindings (except simple variables)" + PatSynBind {} -> text "Pattern synonyms" + -- Associated pattern synonyms are not implemented yet + _ -> pprPanic "rnMethodBind" (ppr bind) + +{- +************************************************************************ +* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +* * +************************************************************************ + +@renameSigs@ checks for: +\begin{enumerate} +\item more than one sig for one thing; +\item signatures given for things not bound here; +\end{enumerate} + +At the moment we don't gather free-var info from the types in +signatures. We'd only need this if we wanted to report unused tyvars. +-} + +renameSigs :: HsSigCtxt + -> [LSig GhcPs] + -> RnM ([LSig GhcRn], FreeVars) +-- Renames the signatures and performs error checks +renameSigs ctxt sigs + = do { mapM_ dupSigDeclErr (findDupSigs sigs) + + ; checkDupMinimalSigs sigs + + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs + + ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced + + ; return (good_sigs, sig_fvs) } + +---------------------- +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory +-- because this won't work for: +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... +-- We'll just rename the INLINE prag to refer to whatever other 'op' +-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) +-- Doesn't seem worth much trouble to sort this. + +renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) +renameSig _ (IdSig _ x) + = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs + +renameSig ctxt sig@(TypeSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; let doc = TypeSigCtx (ppr_sig_bndrs vs) + ; (new_ty, fvs) <- rnHsSigWcType doc ty + ; return (TypeSig noExtField new_vs new_ty, fvs) } + +renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) + = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures + ; when (is_deflt && not defaultSigs_on) $ + addErr (defaultSigErr sig) + ; new_v <- mapM (lookupSigOccRn ctxt sig) vs + ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } + where + (v1:_) = vs + ty_ctxt = GenericCtx (text "a class method signature for" + <+> quotes (ppr v1)) + +renameSig _ (SpecInstSig _ src ty) + = do { checkInferredVars doc inf_msg ty + ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty + -- Check if there are any nested `forall`s or contexts, which are + -- illegal in the type of an instance declaration (see + -- Note [No nested foralls or contexts in instance types] in + -- GHC.Hs.Type). + ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type") + (getLHsInstDeclHead new_ty) + ; return (SpecInstSig noExtField src new_ty,fvs) } + where + doc = SpecInstSigCtx + inf_msg = Just (text "Inferred type variables are not allowed") + +-- {-# SPECIALISE #-} pragmas can refer to imported Ids +-- so, in the top-level case (when mb_names is Nothing) +-- we use lookupOccRn. If there's both an imported and a local 'f' +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures +renameSig ctxt sig@(SpecSig _ v tys inl) + = do { new_v <- case ctxt of + TopSigCtxt {} -> lookupLocatedOccRn v + _ -> lookupSigOccRn ctxt sig v + ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys + ; return (SpecSig noExtField new_v new_ty inl, fvs) } + where + ty_ctxt = GenericCtx (text "a SPECIALISE signature for" + <+> quotes (ppr v)) + do_one (tys,fvs) ty + = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty + ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } + +renameSig ctxt sig@(InlineSig _ v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (InlineSig noExtField new_v s, emptyFVs) } + +renameSig ctxt (FixSig _ fsig) + = do { new_fsig <- rnSrcFixityDecl ctxt fsig + ; return (FixSig noExtField new_fsig, emptyFVs) } + +renameSig ctxt sig@(MinimalSig _ s (L l bf)) + = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf + return (MinimalSig noExtField s (L l new_bf), emptyFVs) + +renameSig ctxt sig@(PatSynSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (PatSynSig noExtField new_vs ty', fvs) } + where + ty_ctxt = GenericCtx (text "a pattern synonym signature for" + <+> ppr_sig_bndrs vs) + +renameSig ctxt sig@(SCCFunSig _ st v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (SCCFunSig noExtField st new_v s, emptyFVs) } + +-- COMPLETE Sigs can refer to imported IDs which is why we use +-- lookupLocatedOccRn rather than lookupSigOccRn +renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) + = do new_bf <- traverse lookupLocatedOccRn bf + new_mty <- traverse lookupLocatedOccRn mty + + this_mod <- fmap tcg_mod getGblEnv + unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do + -- Why 'any'? See Note [Orphan COMPLETE pragmas] + addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError + + return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs) + where + orphanError :: SDoc + orphanError = + text "Orphan COMPLETE pragmas not supported" $$ + text "A COMPLETE pragma must mention at least one data constructor" $$ + text "or pattern synonym defined in the same module." + +{- +Note [Orphan COMPLETE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a COMPLETE pragma to be a non-orphan if it includes at least +one conlike defined in the current module. Why is this sufficient? +Well if you have a pattern match + + case expr of + P1 -> ... + P2 -> ... + P3 -> ... + +any COMPLETE pragma which mentions a conlike other than P1, P2 or P3 +will not be of any use in verifying that the pattern match is +exhaustive. So as we have certainly read the interface files that +define P1, P2 and P3, we will have loaded all non-orphan COMPLETE +pragmas that could be relevant to this pattern match. + +For now we simply disallow orphan COMPLETE pragmas, as the added +complexity of supporting them properly doesn't seem worthwhile. +-} + +ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) + +okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool +okHsSig ctxt (L _ sig) + = case (sig, ctxt) of + (ClassOpSig {}, ClsDeclCtxt {}) -> True + (ClassOpSig {}, InstDeclCtxt {}) -> True + (ClassOpSig {}, _) -> False + + (TypeSig {}, ClsDeclCtxt {}) -> False + (TypeSig {}, InstDeclCtxt {}) -> False + (TypeSig {}, _) -> True + + (PatSynSig {}, TopSigCtxt{}) -> True + (PatSynSig {}, _) -> False + + (FixSig {}, InstDeclCtxt {}) -> False + (FixSig {}, _) -> True + + (IdSig {}, TopSigCtxt {}) -> True + (IdSig {}, InstDeclCtxt {}) -> True + (IdSig {}, _) -> False + + (InlineSig {}, HsBootCtxt {}) -> False + (InlineSig {}, _) -> True + + (SpecSig {}, TopSigCtxt {}) -> True + (SpecSig {}, LocalBindCtxt {}) -> True + (SpecSig {}, InstDeclCtxt {}) -> True + (SpecSig {}, _) -> False + + (SpecInstSig {}, InstDeclCtxt {}) -> True + (SpecInstSig {}, _) -> False + + (MinimalSig {}, ClsDeclCtxt {}) -> True + (MinimalSig {}, _) -> False + + (SCCFunSig {}, HsBootCtxt {}) -> False + (SCCFunSig {}, _) -> True + + (CompleteMatchSig {}, TopSigCtxt {} ) -> True + (CompleteMatchSig {}, _) -> False + +------------------- +findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] +-- Check for duplicates on RdrName version, +-- because renamed version has unboundName for +-- not-in-scope binders, which gives bogus dup-sig errors +-- NB: in a class decl, a 'generic' sig is not considered +-- equal to an ordinary sig, so we allow, say +-- class C a where +-- op :: a -> a +-- default op :: Eq a => a -> a +findDupSigs sigs + = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) + where + expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) + expand_sig sig@(InlineSig _ n _) = [(n,sig)] + expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] + expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] + expand_sig _ = [] + + matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 + mtch (FixSig {}) (FixSig {}) = True + mtch (InlineSig {}) (InlineSig {}) = True + mtch (TypeSig {}) (TypeSig {}) = True + mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2 + mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True + mtch (SCCFunSig{}) (SCCFunSig{}) = True + mtch _ _ = False + +-- Warn about multiple MINIMAL signatures +checkDupMinimalSigs :: [LSig GhcPs] -> RnM () +checkDupMinimalSigs sigs + = case filter isMinimalLSig sigs of + minSigs@(_:_:_) -> dupMinimalSigErr minSigs + _ -> return () + +{- +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ +-} + +rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> MatchGroup GhcPs (Located (body GhcPs)) + -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) +rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) + = do { empty_case_ok <- xoptM LangExt.EmptyCase + ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) + ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms + ; return (mkMatchGroup origin new_ms, ms_fvs) } + +rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LMatch GhcPs (Located (body GhcPs)) + -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) + +rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> Match GhcPs (Located (body GhcPs)) + -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) +rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) + = do { -- Note that there are no local fixity decls for matches + ; rnPats ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss + ; let mf' = case (ctxt, mf) of + (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) + -> mf { mc_fun = L lf funid } + _ -> ctxt + ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' + , m_grhss = grhss'}, grhss_fvs ) }} + +emptyCaseErr :: HsMatchContext GhcRn -> SDoc +emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) + 2 (text "Use EmptyCase to allow this") + where + pp_ctxt = case ctxt of + CaseAlt -> text "case expression" + LambdaExpr -> text "\\case expression" + _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt + +{- +************************************************************************ +* * +\subsubsection{Guarded right-hand sides (GRHSs)} +* * +************************************************************************ +-} + +rnGRHSs :: HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHSs GhcPs (Located (body GhcPs)) + -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) + = rnLocalBindsAndThen binds $ \ binds' _ -> do + (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss + return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) + +rnGRHS :: HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LGRHS GhcPs (Located (body GhcPs)) + -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) +rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) + +rnGRHS' :: HsMatchContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHS GhcPs (Located (body GhcPs)) + -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) +rnGRHS' ctxt rnBody (GRHS _ guards rhs) + = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> + rnBody rhs + + ; unless (pattern_guards_allowed || is_standard_guard guards') + (addWarn NoReason (nonStdGuardErr guards')) + + ; return (GRHS noExtField guards' rhs', fvs) } + where + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension + is_standard_guard [] = True + is_standard_guard [L _ (BodyStmt {})] = True + is_standard_guard _ = False + +{- +********************************************************* +* * + Source-code fixity declarations +* * +********************************************************* +-} + +rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn) +-- Rename a fixity decl, so we can put +-- the renamed decl in the renamed syntax tree +-- Errors if the thing being fixed is not defined locally. +rnSrcFixityDecl sig_ctxt = rn_decl + where + rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn) + -- GHC extension: look up both the tycon and data con + -- for con-like things; hence returning a list + -- If neither are in scope, report an error; otherwise + -- return a fixity sig for each (slightly odd) + rn_decl (FixitySig _ fnames fixity) + = do names <- concatMapM lookup_one fnames + return (FixitySig noExtField names fixity) + + lookup_one :: Located RdrName -> RnM [Located Name] + lookup_one (L name_loc rdr_name) + = setSrcSpan name_loc $ + -- This lookup will fail if the name is not defined in the + -- same binding group as this fixity declaration. + do names <- lookupLocalTcNames sig_ctxt what rdr_name + return [ L name_loc name | (_, name) <- names ] + what = text "fixity signature" + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM () +dupSigDeclErr pairs@((L loc name, sig) :| _) + = addErrAt loc $ + vcat [ text "Duplicate" <+> what_it_is + <> text "s for" <+> quotes (ppr name) + , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest + $ map (getLoc . fst) + $ toList pairs) + ] + where + what_it_is = hsSigDoc sig + +misplacedSigErr :: LSig GhcRn -> RnM () +misplacedSigErr (L loc sig) + = addErrAt loc $ + sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] + +defaultSigErr :: Sig GhcPs -> SDoc +defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") + 2 (ppr sig) + , text "Use DefaultSignatures to enable default signatures" ] + +bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc +bindsInHsBootFile mbinds + = hang (text "Bindings in hs-boot files are not allowed") + 2 (ppr mbinds) + +nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc +nonStdGuardErr guards + = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") + 4 (interpp'SP guards) + +unusedPatBindWarn :: HsBind GhcRn -> SDoc +unusedPatBindWarn bind + = hang (text "This pattern-binding binds no variables:") + 2 (ppr bind) + +dupMinimalSigErr :: [LSig GhcPs] -> RnM () +dupMinimalSigErr sigs@(L loc _ : _) + = addErrAt loc $ + vcat [ text "Multiple minimal complete definitions" + , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs) + , text "Combine alternative minimal complete definitions with `|'" ] +dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/GHC/Rename/Doc.hs b/GHC/Rename/Doc.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Doc.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ViewPatterns #-} + +module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Hs +import GHC.Types.SrcLoc + + +rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) +rnMbLHsDoc mb_doc = case mb_doc of + Just doc -> do + doc' <- rnLHsDoc doc + return (Just doc') + Nothing -> return Nothing + +rnLHsDoc :: LHsDocString -> RnM LHsDocString +rnLHsDoc (L pos doc) = do + doc' <- rnHsDoc doc + return (L pos doc') + +rnHsDoc :: HsDocString -> RnM HsDocString +rnHsDoc = pure diff --git a/GHC/Rename/Env.hs b/GHC/Rename/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Env.hs @@ -0,0 +1,1824 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 + +GHC.Rename.Env contains functions which convert RdrNames into Names. + +-} + +{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-} + +module GHC.Rename.Env ( + newTopSrcBinder, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, + lookupLocalOccRn_maybe, lookupInfoOccRn, + lookupLocalOccThLvl_maybe, lookupLocalOccRn, + lookupTypeOccRn, + lookupGlobalOccRn, lookupGlobalOccRn_maybe, + lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, + + ChildLookupResult(..), + lookupSubBndrOcc_helper, + combineChildLookupResult, -- Called by lookupChildrenExport + + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, + lookupSigCtxtOccRn, + + lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, + lookupConstructorFields, + + lookupGreAvailRn, + + -- Rebindable Syntax + lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames, + lookupIfThenElse, lookupReboundIf, + + -- QualifiedDo + lookupQualifiedDoExpr, lookupQualifiedDo, + lookupQualifiedDoName, lookupNameWithQualifier, + + -- Constructing usage information + addUsedGRE, addUsedGREs, addUsedDataCons, + + + + dataTcOccs, --TODO: Move this somewhere, into utils? + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) +import GHC.Iface.Env +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Driver.Types +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace ) +import GHC.Builtin.RebindableNames +import GHC.Builtin.Types +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Unit.Module +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Utils.Error ( MsgDoc ) +import GHC.Builtin.Names( rOOT_MAIN ) +import GHC.Types.Basic ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique.Set ( uniqSetAny ) +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Driver.Session +import GHC.Data.FastString +import Control.Monad +import GHC.Data.List.SetOps ( minusList ) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Unbound +import GHC.Rename.Utils +import qualified Data.Semigroup as Semi +import Data.Either ( partitionEithers ) +import Data.List ( find, sortBy ) +import Control.Arrow ( first ) +import Data.Function + +{- +********************************************************* +* * + Source-code binders +* * +********************************************************* + +Note [Signature lazy interface loading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC's lazy interface loading can be a bit confusing, so this Note is an +empirical description of what happens in one interesting case. When +compiling a signature module against an its implementation, we do NOT +load interface files associated with its names until after the type +checking phase. For example: + + module ASig where + data T + f :: T -> T + +Suppose we compile this with -sig-of "A is ASig": + + module B where + data T = T + f T = T + + module A(module B) where + import B + +During type checking, we'll load A.hi because we need to know what the +RdrEnv for the module is, but we DO NOT load the interface for B.hi! +It's wholly unnecessary: our local definition 'data T' in ASig is all +the information we need to finish type checking. This is contrast to +type checking of ordinary Haskell files, in which we would not have the +local definition "data T" and would need to consult B.hi immediately. +(Also, this situation never occurs for hs-boot files, since you're not +allowed to reexport from another module.) + +After type checking, we then check that the types we provided are +consistent with the backing implementation (in checkHiBootOrHsigIface). +At this point, B.hi is loaded, because we need something to compare +against. + +I discovered this behavior when trying to figure out why type class +instances for Data.Map weren't in the EPS when I was type checking a +test very much like ASig (sigof02dm): the associated interface hadn't +been loaded yet! (The larger issue is a moot point, since an instance +declared in a signature can never be a duplicate.) + +This behavior might change in the future. Consider this +alternate module B: + + module B where + {-# DEPRECATED T, f "Don't use" #-} + data T = T + f T = T + +One might conceivably want to report deprecation warnings when compiling +ASig with -sig-of B, in which case we need to look at B.hi to find the +deprecation warnings during renaming. At the moment, you don't get any +warning until you use the identifier further downstream. This would +require adjusting addUsedGRE so that during signature compilation, +we do not report deprecation warnings for LocalDef. See also +Note [Handling of deprecations] +-} + +newTopSrcBinder :: Located RdrName -> RnM Name +newTopSrcBinder (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt loc (badOrigBinding rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + do { this_mod <- getModule + ; externaliseName this_mod name } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { this_mod <- getModule + ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt loc (badOrigBinding rdr_name)) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the badOrigBinding error message. + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- the RdrName, not from the environment. In principle, it'd be fine to + -- have an arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + ; newGlobalBinder rdr_mod rdr_occ loc } + + | otherwise + = do { when (isQual rdr_name) + (addErrAt loc (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we get a confusing "M.T is not in scope" error later + + ; stage <- getStage + ; if isBrackStage stage then + -- We are inside a TH bracket, so make an *Internal* name + -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + do { uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + else + do { this_mod <- getModule + ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc) + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } + } + +{- +********************************************************* +* * + Source code occurrences +* * +********************************************************* + +Looking up a name in the GHC.Rename.Env. + +Note [Type and class operator definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to reject all of these unless we have -XTypeOperators (#3265) + data a :*: b = ... + class a :*: b where ... + data (:*:) a b = .... + class (:*:) a b where ... +The latter two mean that we are not just looking for a +*syntactically-infix* declaration, but one that uses an operator +OccName. We use OccName.isSymOcc to detect that case, which isn't +terribly efficient, but there seems to be no better way. +-} + +-- Can be made to not be exposed +-- Only used unwrapped in rnAnnProvenance +lookupTopBndrRn :: RdrName -> RnM Name +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course +-- So we have to filter out the non-local ones. +-- +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. +lookupTopBndrRn rdr_name = + lookupExactOrOrig rdr_name id $ + do { -- Check for operators in type or class declarations + -- See Note [Type and class operator definitions] + let occ = rdrNameOcc rdr_name + ; when (isTcOcc occ && isSymOcc occ) + (do { op_ok <- xoptM LangExt.TypeOperators + ; unless op_ok (addErr (opDeclErr rdr_name)) }) + + ; env <- getGlobalRdrEnv + ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of + [gre] -> return (gre_name gre) + _ -> do -- Ambiguous (can't happen) or unbound + traceRn "lookupTopBndrRN fail" (ppr rdr_name) + unboundName WL_LocalTop rdr_name + } + +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one, see +-- Note [Errors in lookup functions] +lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +lookupExactOcc_either name + | Just thing <- wiredInNameTyThing_maybe name + , Just tycon <- case thing of + ATyCon tc -> Just tc + AConLike (RealDataCon dc) -> Just (dataConTyCon dc) + _ -> Nothing + , Just tupleSort <- tyConTuple_maybe tycon + = do { let tupArity = case tupleSort of + -- Unboxed tuples have twice as many arguments because of the + -- 'RuntimeRep's (#17837) + UnboxedTuple -> tyConArity tycon `div` 2 + _ -> tyConArity tycon + ; checkTupSize tupArity + ; return (Right name) } + + | isExternalName name + = return (Right name) + + | otherwise + = do { env <- getGlobalRdrEnv + ; let -- See Note [Splicing Exact names] + main_occ = nameOccName name + demoted_occs = case demoteOccName main_occ of + Just occ -> [occ] + Nothing -> [] + gres = [ gre | occ <- main_occ : demoted_occs + , gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] + ; case gres of + [gre] -> return (Right (gre_name gre)) + + [] -> -- See Note [Splicing Exact names] + do { lcl_env <- getLocalRdrEnv + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right name) + else + do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; th_topnames <- readTcRef th_topnames_var + ; if name `elemNameSet` th_topnames + then return (Right name) + else return (Left (exactNameErr name)) + } + } + gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] + } + +sameNameErr :: [GlobalRdrElt] -> MsgDoc +sameNameErr [] = panic "addSameNameErr: empty list" +sameNameErr gres@(_ : _) + = hang (text "Same exact name in multiple name-spaces:") + 2 (vcat (map pp_one sorted_names) $$ th_hint) + where + sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map gre_name gres) + pp_one name + = hang (pprNameSpace (occNameSpace (getOccName name)) + <+> quotes (ppr name) <> comma) + 2 (text "declared at:" <+> ppr (nameSrcLoc name)) + + th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU)," + , text "perhaps via newName, in different name-spaces." + , text "If that's it, then -ddump-splices might be useful" ] + + +----------------------------------------------- +lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +-- +-- The "what" parameter says "method" or "associated type", +-- depending on what we are looking up +lookupInstDeclBndr cls what rdr + = do { when (isQual rdr) + (addErr (badQualBndrErr rdr)) + -- In an instance decl you aren't allowed + -- to use a qualified name for the method + -- (Although it'd make perfect sense.) + ; mb_name <- lookupSubBndrOcc + False -- False => we don't give deprecated + -- warnings when a deprecated class + -- method is defined. We only warn + -- when it's used + cls doc rdr + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundNameRdr rdr) } + Right nm -> return nm } + where + doc = what <+> text "of class" <+> quotes (ppr cls) + +----------------------------------------------- +lookupFamInstName :: Maybe Name -> Located RdrName + -> RnM (Located Name) +-- Used for TyData and TySynonym family instances only, +-- See Note [Family instance binders] +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind + = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn tc_rdr + +----------------------------------------------- +lookupConstructorFields :: Name -> RnM [FieldLabel] +-- Look up the fields of a given constructor +-- * For constructors from this module, use the record field env, +-- which is itself gathered from the (as yet un-typechecked) +-- data type decls +-- +-- * For constructors from imported modules, use the *type* environment +-- since imported modules are already compiled, the info is conveniently +-- right there + +lookupConstructorFields con_name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod con_name then + do { field_env <- getRecFieldEnv + ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) + ; return (lookupNameEnv field_env con_name `orElse` []) } + else + do { con <- tcLookupConLike con_name + ; traceTc "lookupCF 2" (ppr con) + ; return (conLikeFieldLabels con) } } + + +-- In CPS style as `RnM r` is monadic +-- Reports an error if the name is an Exact or Orig and it can't find the name +-- Otherwise if it is not an Exact or Orig, returns k +lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r +lookupExactOrOrig rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig n -> return (res n) + ExactOrOrigError e -> + do { addErr e + ; return (res (mkUnboundNameRdr rdr_name)) } + NotExactOrOrig -> k } + +-- Variant of 'lookupExactOrOrig' that does not report an error +-- See Note [Errors in lookup functions] +-- Calls k if the name is neither an Exact nor Orig +lookupExactOrOrig_maybe :: RdrName -> (Maybe Name -> r) -> RnM r -> RnM r +lookupExactOrOrig_maybe rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig n -> return (res (Just n)) + ExactOrOrigError _ -> return (res Nothing) + NotExactOrOrig -> k } + +data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name + | ExactOrOrigError MsgDoc -- ^ The RdrName was an Exact + -- or Orig, but there was an + -- error looking up the Name + | NotExactOrOrig -- ^ The RdrName is neither an Exact nor + -- Orig + +-- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' +lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult +lookupExactOrOrig_base rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = cvtEither <$> lookupExactOcc_either n + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = FoundExactOrOrig <$> lookupOrig rdr_mod rdr_occ + | otherwise = return NotExactOrOrig + where + cvtEither (Left e) = ExactOrOrigError e + cvtEither (Right n) = FoundExactOrOrig n + + +{- Note [Errors in lookup functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many of these lookup functions will attach an error if it can't find the Name it +is trying to lookup. However there are also _maybe and _either variants for many +of these functions. + +These variants should *not* attach any errors, as there are +places where we want to attempt looking up a name, but it's not the end of the +world if we don't find it. + +For example, see lookupThName_maybe: It calls lookupGlobalOccRn_maybe multiple +times for varying names in different namespaces. lookupGlobalOccRn_maybe should +therefore never attach an error, instead just return a Nothing. + +For these _maybe/_either variant functions then, avoid calling further lookup +functions that can attach errors and instead call their _maybe/_either +counterparts. +-} + +----------------------------------------------- +-- | Look up an occurrence of a field in record construction or pattern +-- matching (but not update). When the -XDisambiguateRecordFields +-- flag is on, take account of the data constructor name to +-- disambiguate which field to use. +-- +-- See Note [DisambiguateRecordFields]. +lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual + -- Just con => use data con to disambiguate + -> RdrName + -> RnM Name +lookupRecFieldOcc mb_con rdr_name + | Just con <- mb_con + , isUnboundName con -- Avoid error cascade + = return (mkUnboundNameRdr rdr_name) + | Just con <- mb_con + = do { flds <- lookupConstructorFields con + ; env <- getGlobalRdrEnv + ; let lbl = occNameFS (rdrNameOcc rdr_name) + mb_field = do fl <- find ((== lbl) . flLabel) flds + -- We have the label, now check it is in + -- scope (with the correct qualifier if + -- there is one, hence calling pickGREs). + gre <- lookupGRE_FieldLabel env fl + guard (not (isQual rdr_name + && null (pickGREs rdr_name [gre]))) + return (fl, gre) + ; case mb_field of + Just (fl, gre) -> do { addUsedGRE True gre + ; return (flSelector fl) } + Nothing -> lookupGlobalOccRn rdr_name } + -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] + | otherwise + -- This use of Global is right as we are looking up a selector which + -- can only be defined at the top level. + = lookupGlobalOccRn rdr_name + +{- Note [DisambiguateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record construction or pattern +matching, we can take advantage of the data constructor name to +resolve fields that would otherwise be ambiguous (provided the +-XDisambiguateRecordFields flag is on). + +For example, consider: + + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + e = MkS { x = 3 } + +When we are renaming the occurrence of `x` in `e`, instead of looking +`x` up directly (and finding both fields), lookupRecFieldOcc will +search the fields of `MkS` to find the only possible `x` the user can +mean. + +Of course, we still have to check the field is in scope, using +lookupGRE_FieldLabel. The handling of qualified imports is slightly +subtle: the occurrence may be unqualified even if the field is +imported only qualified (but if the occurrence is qualified, the +qualifier must be correct). For example: + + module A where + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + module B where + import qualified A (S(..)) + import A (T(MkT)) + + e1 = MkT { x = 3 } -- x not in scope, so fail + e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail + e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) + +In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, +lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard +will fail because the field RdrName `B.x` is qualified and pickGREs +rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the +GRE for `A.x` and the guard will succeed because the field RdrName `x` +is unqualified. + + +Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whenever we fail to find the field or it is not in scope, mb_field +will be False, and we fall back on looking it up normally using +lookupGlobalOccRn. We don't report an error immediately because the +actual problem might be located elsewhere. For example (#9975): + + data Test = Test { x :: Int } + pattern Test wat = Test { x = wat } + +Here there are multiple declarations of Test (as a data constructor +and as a pattern synonym), which will be reported as an error. We +shouldn't also report an error about the occurrence of `x` in the +pattern synonym RHS. However, if the pattern synonym gets added to +the environment first, we will try and fail to find `x` amongst the +(nonexistent) fields of the pattern synonym. + +Alternatively, the scope check can fail due to Template Haskell. +Consider (#12130): + + module Foo where + import M + b = $(funny) + + module M(funny) where + data T = MkT { x :: Int } + funny :: Q Exp + funny = [| MkT { x = 3 } |] + +When we splice, `MkT` is not lexically in scope, so +lookupGRE_FieldLabel will fail. But there is no need for +disambiguation anyway, because `x` is an original name, and +lookupGlobalOccRn will find it. +-} + + + +-- | Used in export lists to lookup the children. +lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName + -> RnM ChildLookupResult +lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name + | isUnboundName parent + -- Avoid an error cascade + = return (FoundName NoParent (mkUnboundNameRdr rdr_name)) + + | otherwise = do + gre_env <- getGlobalRdrEnv + + let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) + -- Disambiguate the lookup based on the parent information. + -- The remaining GREs are things that we *could* export here, note that + -- this includes things which have `NoParent`. Those are sorted in + -- `checkPatSynParent`. + traceRn "parent" (ppr parent) + traceRn "lookupExportChild original_gres:" (ppr original_gres) + traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent) + case picked_gres original_gres of + NoOccurrence -> + noMatchingParentErr original_gres + UniqueOccurrence g -> + if must_have_parent then noMatchingParentErr original_gres + else checkFld g + DisambiguatedOccurrence g -> + checkFld g + AmbiguousOccurrence gres -> + mkNameClashErr gres + where + -- Convert into FieldLabel if necessary + checkFld :: GlobalRdrElt -> RnM ChildLookupResult + checkFld g@GRE{gre_name, gre_par} = do + addUsedGRE warn_if_deprec g + return $ case gre_par of + FldParent _ mfs -> + FoundFL (fldParentToFieldLabel gre_name mfs) + _ -> FoundName gre_par gre_name + + fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel + fldParentToFieldLabel name mfs = + case mfs of + Nothing -> + let fs = occNameFS (nameOccName name) + in FieldLabel fs False name + Just fs -> FieldLabel fs True name + + -- Called when we find no matching GREs after disambiguation but + -- there are three situations where this happens. + -- 1. There were none to begin with. + -- 2. None of the matching ones were the parent but + -- a. They were from an overloaded record field so we can report + -- a better error + -- b. The original lookup was actually ambiguous. + -- For example, the case where overloading is off and two + -- record fields are in scope from different record + -- constructors, neither of which is the parent. + noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult + noMatchingParentErr original_gres = do + traceRn "npe" (ppr original_gres) + overload_ok <- xoptM LangExt.DuplicateRecordFields + case original_gres of + [] -> return NameNotFound + [g] -> return $ IncorrectParent parent + (gre_name g) (ppr $ gre_name g) + [p | Just p <- [getParent g]] + gss@(g:_:_) -> + if all isRecFldGRE gss && overload_ok + then return $ + IncorrectParent parent + (gre_name g) + (ppr $ expectJust "noMatchingParentErr" (greLabel g)) + [p | x <- gss, Just p <- [getParent x]] + else mkNameClashErr gss + + mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult + mkNameClashErr gres = do + addNameClashErrRn rdr_name gres + return (FoundName (gre_par (head gres)) (gre_name (head gres))) + + getParent :: GlobalRdrElt -> Maybe Name + getParent (GRE { gre_par = p } ) = + case p of + ParentIs cur_parent -> Just cur_parent + FldParent { par_is = cur_parent } -> Just cur_parent + NoParent -> Nothing + + picked_gres :: [GlobalRdrElt] -> DisambigInfo + -- For Unqual, find GREs that are in scope qualified or unqualified + -- For Qual, find GREs that are in scope with that qualification + picked_gres gres + | isUnqual rdr_name + = mconcat (map right_parent gres) + | otherwise + = mconcat (map right_parent (pickGREs rdr_name gres)) + + right_parent :: GlobalRdrElt -> DisambigInfo + right_parent p + = case getParent p of + Just cur_parent + | parent == cur_parent -> DisambiguatedOccurrence p + | otherwise -> NoOccurrence + Nothing -> UniqueOccurrence p + + +-- This domain specific datatype is used to record why we decided it was +-- possible that a GRE could be exported with a parent. +data DisambigInfo + = NoOccurrence + -- The GRE could never be exported. It has the wrong parent. + | UniqueOccurrence GlobalRdrElt + -- The GRE has no parent. It could be a pattern synonym. + | DisambiguatedOccurrence GlobalRdrElt + -- The parent of the GRE is the correct parent + | AmbiguousOccurrence [GlobalRdrElt] + -- For example, two normal identifiers with the same name are in + -- scope. They will both be resolved to "UniqueOccurrence" and the + -- monoid will combine them to this failing case. + +instance Outputable DisambigInfo where + ppr NoOccurrence = text "NoOccurence" + ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre + ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre + ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres + +instance Semi.Semigroup DisambigInfo where + -- This is the key line: We prefer disambiguated occurrences to other + -- names. + _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' + DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' + + NoOccurrence <> m = m + m <> NoOccurrence = m + UniqueOccurrence g <> UniqueOccurrence g' + = AmbiguousOccurrence [g, g'] + UniqueOccurrence g <> AmbiguousOccurrence gs + = AmbiguousOccurrence (g:gs) + AmbiguousOccurrence gs <> UniqueOccurrence g' + = AmbiguousOccurrence (g':gs) + AmbiguousOccurrence gs <> AmbiguousOccurrence gs' + = AmbiguousOccurrence (gs ++ gs') + +instance Monoid DisambigInfo where + mempty = NoOccurrence + mappend = (Semi.<>) + +-- Lookup SubBndrOcc can never be ambiguous +-- +-- Records the result of looking up a child. +data ChildLookupResult + = NameNotFound -- We couldn't find a suitable name + | IncorrectParent Name -- Parent + Name -- Name of thing we were looking for + SDoc -- How to print the name + [Name] -- List of possible parents + | FoundName Parent Name -- We resolved to a normal name + | FoundFL FieldLabel -- We resolved to a FL + +-- | Specialised version of msum for RnM ChildLookupResult +combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult +combineChildLookupResult [] = return NameNotFound +combineChildLookupResult (x:xs) = do + res <- x + case res of + NameNotFound -> combineChildLookupResult xs + _ -> return res + +instance Outputable ChildLookupResult where + ppr NameNotFound = text "NameNotFound" + ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n + ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls + ppr (IncorrectParent p n td ns) = text "IncorrectParent" + <+> hsep [ppr p, ppr n, td, ppr ns] + +lookupSubBndrOcc :: Bool + -> Name -- Parent + -> SDoc + -> RdrName + -> RnM (Either MsgDoc Name) +-- Find all the things the rdr-name maps to +-- and pick the one with the right parent namep +lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do + res <- + lookupExactOrOrig rdr_name (FoundName NoParent) $ + -- This happens for built-in classes, see mod052 for example + lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name + case res of + NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) + FoundName _p n -> return (Right n) + FoundFL fl -> return (Right (flSelector fl)) + IncorrectParent {} + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + -> return $ Left (unknownSubordinateErr doc rdr_name) + +{- +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurrence +of 'G' in the 'instance C S' decl is unambiguous, because C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the encloseing instance decl, if any. + +Note [Looking up Exact RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames are generated by: + +* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs) +* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate) + +For data types and classes have Exact system Names in the binding +positions for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +These System names are generated by GHC.ThToHs.thRdrName + +But, constructors and the like need External Names, not System Names! +So we do the following + + * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a + non-External Name, and make an External name for it. This is + the name that goes in the GlobalRdrEnv + + * When looking up an occurrence of an Exact name, done in + GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the + GlobalRdrEnv, and use the one from the envt -- it will be an + External Name in the case of the data type/constructor above. + + * Exact names are also use for purely local binders generated + by TH, such as \x_33. x_33 + Both binder and occurrence are Exact RdrNames. The occurrence + gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and + misses, because lookupLocalRdrEnv always returns Nothing for + an Exact Name. Now we fall through to lookupExactOcc, which + will find the Name is not in the GlobalRdrEnv, so we just use + the Exact supplied Name. + +Note [Splicing Exact names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the splice $(do { x <- newName "x"; return (VarE x) }) +This will generate a (HsExpr RdrName) term that mentions the +Exact RdrName "x_56" (or whatever), but does not bind it. So +when looking such Exact names we want to check that it's in scope, +otherwise the type checker will get confused. To do this we need to +keep track of all the Names in scope, and the LocalRdrEnv does just that; +we consult it with RdrName.inLocalRdrEnvScope. + +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +The occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) + +Note [Template Haskell ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GlobalRdrEnv invariant says that if + occ -> [gre1, ..., gren] +then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). +This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). + +So how can we get multiple gres in lookupExactOcc_maybe? Because in +TH we might use the same TH NameU in two different name spaces. +eg (#7241): + $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) +Here we generate a type constructor and data constructor with the same +unique, but different name spaces. + +It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would +mean looking up the OccName in every name-space, just in case, and that +seems a bit brutal. So it's just done here on lookup. But we might +need to revisit that choice. + +Note [Usage for sub-bndrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have this + import qualified M( C( f ) ) + instance M.C T where + f x = x +then is the qualified import M.f used? Obviously yes. +But the RdrName used in the instance decl is unqualified. In effect, +we fill in the qualification by looking for f's whose class is M.C +But when adding to the UsedRdrNames we must make that qualification +explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". + +So we make up a suitable (fake) RdrName. But be careful + import qualified M + import M( C(f) ) + instance C T where + f x = x +Here we want to record a use of 'f', not of 'M.f', otherwise +we'll miss the fact that the qualified import is redundant. + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- +-} + + +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn + +lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Just look in the local environment +lookupLocalOccRn_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; return (lookupLocalRdrEnv local_env rdr_name) } + +lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) +-- Just look in the local environment +lookupLocalOccThLvl_maybe name + = do { lcl_env <- getLclEnv + ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } + +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnM Name +lookupOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> reportUnboundName rdr_name } + +-- Only used in one place, to rename pattern synonym binders. +-- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind +lookupLocalOccRn :: RdrName -> RnM Name +lookupLocalOccRn rdr_name + = do { mb_name <- lookupLocalOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> unboundName WL_LocalOnly rdr_name } + +-- lookupTypeOccRn looks up an optionally promoted RdrName. +lookupTypeOccRn :: RdrName -> RnM Name +-- see Note [Demotion] +lookupTypeOccRn rdr_name + | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] + = badVarInType rdr_name + | otherwise + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> lookup_demoted rdr_name } + +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name + | Just demoted_rdr <- demoteRdrName rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM LangExt.DataKinds + ; star_is_type <- xoptM LangExt.StarIsType + ; let star_info = starInfo star_is_type rdr_name + ; if data_kinds + then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr + ; case mb_demoted_name of + Nothing -> unboundNameX WL_Any rdr_name star_info + Just demoted_name -> + do { whenWOptM Opt_WarnUntickedPromotedConstructors $ + addWarn + (Reason Opt_WarnUntickedPromotedConstructors) + (untickedPromConstrWarn demoted_name) + ; return demoted_name } } + else do { -- We need to check if a data constructor of this name is + -- in scope to give good error messages. However, we do + -- not want to give an additional error if the data + -- constructor happens to be out of scope! See #13947. + mb_demoted_name <- discardErrs $ + lookupOccRn_maybe demoted_rdr + ; let suggestion | isJust mb_demoted_name = suggest_dk + | otherwise = star_info + ; unboundNameX WL_Any rdr_name suggestion } } + + | otherwise + = reportUnboundName rdr_name + + where + suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?" + untickedPromConstrWarn name = + text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot + $$ + hsep [ text "Use" + , quotes (char '\'' <> ppr name) + , text "instead of" + , quotes (ppr name) <> dot ] + +badVarInType :: RdrName -> RnM Name +badVarInType rdr_name + = do { addErr (text "Illegal promoted term variable in a type:" + <+> ppr rdr_name) + ; return (mkUnboundNameRdr rdr_name) } + +{- Note [Promoted variables in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#12686): + x = True + data Bad = Bad 'x + +The parser treats the quote in 'x as saying "use the term +namespace", so we'll get (Bad x{v}), with 'x' in the +VarName namespace. If we don't test for this, the renamer +will happily rename it to the x bound at top level, and then +the typecheck falls over because it doesn't have 'x' in scope +when kind-checking. + +Note [Demotion] +~~~~~~~~~~~~~~~ +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurrence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. + +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) +-} + +lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName + -> RnM (Maybe r) +lookupOccRnX_maybe globalLookup wrapper rdr_name + = runMaybeT . msum . map MaybeT $ + [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name + , globalLookup rdr_name ] + +lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) +lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id + +lookupOccRn_overloaded :: Bool -> RdrName + -> RnM (Maybe (Either Name [Name])) +lookupOccRn_overloaded overload_ok + = lookupOccRnX_maybe global_lookup Left + where + global_lookup :: RdrName -> RnM (Maybe (Either Name [Name])) + global_lookup n = + runMaybeT . msum . map MaybeT $ + [ lookupGlobalOccRn_overloaded overload_ok n + , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ] + + + +lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Looks up a RdrName occurrence in the top-level +-- environment, including using lookupQualifiedNameGHCi +-- for the GHCi case, but first tries to find an Exact or Orig name. +-- No filter function; does not report an error on failure +-- See Note [Errors in lookup functions] +-- Uses addUsedRdrName to record use and deprecations +lookupGlobalOccRn_maybe rdr_name = + lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base rdr_name) + +lookupGlobalOccRn :: RdrName -> RnM Name +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. Adds an error message if the RdrName is not in scope. +-- You usually want to use "lookupOccRn" which also looks in the local +-- environment. +lookupGlobalOccRn rdr_name = + lookupExactOrOrig rdr_name id $ do + mn <- lookupGlobalOccRn_base rdr_name + case mn of + Just n -> return n + Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) + ; unboundName WL_Global rdr_name } + +-- Looks up a RdrName occurence in the GlobalRdrEnv and with +-- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. +-- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like +-- 'Data.Map.elems' is typed, even if you didn't import Data.Map +lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name) +lookupGlobalOccRn_base rdr_name = + runMaybeT . msum . map MaybeT $ + [ fmap gre_name <$> lookupGreRn_maybe rdr_name + , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ] + -- This test is not expensive, + -- and only happens for failed lookups + +lookupInfoOccRn :: RdrName -> RnM [Name] +-- lookupInfoOccRn is intended for use in GHCi's ":info" command +-- It finds all the GREs that RdrName could mean, not complaining +-- about ambiguity, but rather returning them all +-- C.f. #9881 +-- lookupInfoOccRn is also used in situations where we check for +-- at least one definition of the RdrName, not complaining about +-- multiple definitions. (See #17832) +lookupInfoOccRn rdr_name = + lookupExactOrOrig rdr_name (:[]) $ + do { rdr_env <- getGlobalRdrEnv + ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) + ; qual_ns <- lookupQualifiedNameGHCi rdr_name + ; return (ns ++ (qual_ns `minusList` ns)) } + +-- | Like 'lookupOccRn_maybe', but with a more informative result if +-- the 'RdrName' happens to be a record selector: +-- +-- * Nothing -> name not in scope (no error reported) +-- * Just (Left x) -> name uniquely refers to x, +-- or there is a name clash (reported) +-- * Just (Right xs) -> name refers to one or more record selectors; +-- if overload_ok was False, this list will be +-- a singleton. + +lookupGlobalOccRn_overloaded :: Bool -> RdrName + -> RnM (Maybe (Either Name [Name])) +lookupGlobalOccRn_overloaded overload_ok rdr_name = + lookupExactOrOrig_maybe rdr_name (fmap Left) $ + do { res <- lookupGreRn_helper rdr_name + ; case res of + GreNotFound -> return Nothing + OneNameMatch gre -> do + let wrapper = if isRecFldGRE gre then Right . (:[]) else Left + return $ Just (wrapper (gre_name gre)) + MultipleNames gres | all isRecFldGRE gres && overload_ok -> + -- Don't record usage for ambiguous selectors + -- until we know which is meant + return $ Just (Right (map gre_name gres)) + MultipleNames gres -> do + addNameClashErrRn rdr_name gres + return (Just (Left (gre_name (head gres)))) } + + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +data GreLookupResult = GreNotFound + | OneNameMatch GlobalRdrElt + | MultipleNames [GlobalRdrElt] + +lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Look up the RdrName in the GlobalRdrEnv +-- Exactly one binding: records it as "used", return (Just gre) +-- No bindings: return Nothing +-- Many bindings: report "ambiguous", return an arbitrary (Just gre) +-- Uses addUsedRdrName to record use and deprecations +lookupGreRn_maybe rdr_name + = do + res <- lookupGreRn_helper rdr_name + case res of + OneNameMatch gre -> return $ Just gre + MultipleNames gres -> do + traceRn "lookupGreRn_maybe:NameClash" (ppr gres) + addNameClashErrRn rdr_name gres + return $ Just (head gres) + GreNotFound -> return Nothing + +{- + +Note [ Unbound vs Ambiguous Names ] + +lookupGreRn_maybe deals with failures in two different ways. If a name +is unbound then we return a `Nothing` but if the name is ambiguous +then we raise an error and return a dummy name. + +The reason for this is that when we call `lookupGreRn_maybe` we are +speculatively looking for whatever we are looking up. If we don't find it, +then we might have been looking for the wrong thing and can keep trying. +On the other hand, if we find a clash then there is no way to recover as +we found the thing we were looking for but can no longer resolve which +the correct one is. + +One example of this is in `lookupTypeOccRn` which first looks in the type +constructor namespace before looking in the data constructor namespace to +deal with `DataKinds`. + +There is however, as always, one exception to this scheme. If we find +an ambiguous occurrence of a record selector and DuplicateRecordFields +is enabled then we defer the selection until the typechecker. + +-} + + + + +-- Internal Function +lookupGreRn_helper :: RdrName -> RnM GreLookupResult +lookupGreRn_helper rdr_name + = do { env <- getGlobalRdrEnv + ; case lookupGRE_RdrName rdr_name env of + [] -> return GreNotFound + [gre] -> do { addUsedGRE True gre + ; return (OneNameMatch gre) } + gres -> return (MultipleNames gres) } + +lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) +-- Used in export lists +-- If not found or ambiguous, add error message, and fake with UnboundName +-- Uses addUsedRdrName to record use and deprecations +lookupGreAvailRn rdr_name + = do + mb_gre <- lookupGreRn_helper rdr_name + case mb_gre of + GreNotFound -> + do + traceRn "lookupGreAvailRn" (ppr rdr_name) + name <- unboundName WL_Global rdr_name + return (name, avail name) + MultipleNames gres -> + do + addNameClashErrRn rdr_name gres + let unbound_name = mkUnboundNameRdr rdr_name + return (unbound_name, avail unbound_name) + -- Returning an unbound name here prevents an error + -- cascade + OneNameMatch gre -> + return (gre_name gre, availFromGRE gre) + + +{- +********************************************************* +* * + Deprecations +* * +********************************************************* + +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see #5867) + +* We do not report deprecations for locally-defined names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* addUsedGREs: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' +-} + +addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () +-- Remember use of in-scope data constructors (#7969) +addUsedDataCons rdr_env tycon + = addUsedGREs [ gre + | dc <- tyConDataCons tycon + , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] + +addUsedGRE :: Bool -> GlobalRdrElt -> RnM () +-- Called for both local and imported things +-- Add usage *and* warn if deprecated +addUsedGRE warn_if_deprec gre + = do { when warn_if_deprec (warnIfDeprecated gre) + ; unless (isLocalGRE gre) $ + do { env <- getGblEnv + ; traceRn "addUsedGRE" (ppr gre) + ; updMutVar (tcg_used_gres env) (gre :) } } + +addUsedGREs :: [GlobalRdrElt] -> RnM () +-- Record uses of any *imported* GREs +-- Used for recording used sub-bndrs +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] +addUsedGREs gres + | null imp_gres = return () + | otherwise = do { env <- getGblEnv + ; traceRn "addUsedGREs" (ppr imp_gres) + ; updMutVar (tcg_used_gres env) (imp_gres ++) } + where + imp_gres = filterOut isLocalGRE gres + +warnIfDeprecated :: GlobalRdrElt -> RnM () +warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) + | (imp_spec : _) <- iss + = do { dflags <- getDynFlags + ; this_mod <- getModule + ; when (wopt Opt_WarnWarningsDeprecations dflags && + not (nameIsLocalOrFrom this_mod name)) $ + -- See Note [Handling of deprecations] + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeprec iface gre of + Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations) + (mk_msg imp_spec txt) + Nothing -> return () } } + | otherwise + = return () + where + occ = greOccName gre + name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") + + mk_msg imp_spec txt + = sep [ sep [ text "In the use of" + <+> pprNonVarNameSpace (occNameSpace occ) + <+> quotes (ppr occ) + , parens imp_msg <> colon ] + , pprWarningTxtForMsg txt ] + where + imp_mod = importSpecModule imp_spec + imp_msg = text "imported from" <+> ppr imp_mod <> extra + extra | imp_mod == moduleName name_mod = Outputable.empty + | otherwise = text ", but defined in" <+> ppr name_mod + +lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec iface gre + = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, + case gre_par gre of -- or its parent, is warn'd + ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) + FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p) + NoParent -> Nothing + +{- +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + + +********************************************************* +* * + GHCi support +* * +********************************************************* + +A qualified name on the command line can refer to any module at +all: we try to load the interface if we don't already have it, just +as if there was an "import qualified M" declaration for every +module. + +For example, writing `Data.List.sort` will load the interface file for +`Data.List` as if the user had written `import qualified Data.List`. + +If we fail we just return Nothing, rather than bleating +about "attempting to use module ‘D’ (./D.hs) which is not loaded" +which is what loadSrcInterface does. + +It is enabled by default and disabled by the flag +`-fno-implicit-import-qualified`. + +Note [Safe Haskell and GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We DON'T do this Safe Haskell as we need to check imports. We can +and should instead check the qualified import but at the moment +this requires some refactoring so leave as a TODO +-} + + + +lookupQualifiedNameGHCi :: RdrName -> RnM [Name] +lookupQualifiedNameGHCi rdr_name + = -- We want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + do { dflags <- getDynFlags + ; is_ghci <- getIsGHCi + ; go_for_it dflags is_ghci } + + where + go_for_it dflags is_ghci + | Just (mod,occ) <- isQual_maybe rdr_name + , is_ghci + , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour + , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] + = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing + ; case res of + Succeeded iface + -> return [ name + | avail <- mi_exports iface + , name <- availNames avail + , nameOccName name == occ ] + + _ -> -- Either we couldn't load the interface, or + -- we could but we didn't find the name in it + do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) + ; return [] } } + + | otherwise + = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) + ; return [] } + + doc = text "Need to find" <+> ppr rdr_name + +{- +Note [Looking up signature names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupSigOccRn is used for type signatures and pragmas +Is this valid? + module A + import M( f ) + f :: Int -> Int + f x = x +It's clear that the 'f' in the signature must refer to A.f +The Haskell98 report does not stipulate this, but it will! +So we must treat the 'f' in the signature in the same way +as the binding occurrence of 'f', using lookupBndrRn + +However, consider this case: + import M( f ) + f :: Int -> Int + g x = x +We don't want to say 'f' is out of scope; instead, we want to +return the imported 'f', so that later on the renamer will +correctly report "misplaced type sig". + +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* For type signatures the NameSet should be the names bound by the + value bindings; for fixity declarations, the NameSet should also + include class sigs and record selectors + + infix 3 `f` -- Yes, ok + f :: C a => a -> a -- No, not ok + class C a where + f :: a -> a +-} + +data HsSigCtxt + = TopSigCtxt NameSet -- At top level, binding these names + -- See Note [Signatures for top level things] + | LocalBindCtxt NameSet -- In a local binding, binding these names + | ClsDeclCtxt Name -- Class decl for this class + | InstDeclCtxt NameSet -- Instance decl whose user-written method + -- bindings are for these methods + | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names + | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types + -- in the group + +instance Outputable HsSigCtxt where + ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns + ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns + ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n + ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns + ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns + ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns + +lookupSigOccRn :: HsSigCtxt + -> Sig GhcPs + -> Located RdrName -> RnM (Located Name) +lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) + +-- | Lookup a name in relation to the names in a 'HsSigCtxt' +lookupSigCtxtOccRn :: HsSigCtxt + -> SDoc -- ^ description of thing we're looking up, + -- like "type family" + -> Located RdrName -> RnM (Located Name) +lookupSigCtxtOccRn ctxt what + = wrapLocM $ \ rdr_name -> + do { mb_name <- lookupBindGroupOcc ctxt what rdr_name + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } + Right name -> return name } + +lookupBindGroupOcc :: HsSigCtxt + -> SDoc + -> RdrName -> RnM (Either MsgDoc Name) +-- Looks up the RdrName, expecting it to resolve to one of the +-- bound names passed in. If not, return an appropriate error message +-- +-- See Note [Looking up signature names] +lookupBindGroupOcc ctxt what rdr_name + | Just n <- isExact_maybe rdr_name + = lookupExactOcc_either n -- allow for the possibility of missing Exacts; + -- see Note [dataTcOccs and Exact Names] + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n' <- lookupOrig rdr_mod rdr_occ + ; return (Right n') } + + | otherwise + = case ctxt of + HsBootCtxt ns -> lookup_top (`elemNameSet` ns) + TopSigCtxt ns -> lookup_top (`elemNameSet` ns) + RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) + LocalBindCtxt ns -> lookup_group ns + ClsDeclCtxt cls -> lookup_cls_op cls + InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 + then return (Right $ mkUnboundNameRdr rdr_name) + else lookup_top (`elemNameSet` ns) + where + lookup_cls_op cls + = lookupSubBndrOcc True cls doc rdr_name + where + doc = text "method of class" <+> quotes (ppr cls) + + lookup_top keep_me + = do { env <- getGlobalRdrEnv + ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + names_in_scope = -- If rdr_name lacks a binding, only + -- recommend alternatives from related + -- namespaces. See #17593. + filter (\n -> nameSpacesRelated + (rdrNameSpace rdr_name) + (nameNameSpace n)) + $ map gre_name + $ filter isLocalGRE + $ globalRdrEnvElts env + candidates_msg = candidates names_in_scope + ; case filter (keep_me . gre_name) all_gres of + [] | null all_gres -> bale_out_with candidates_msg + | otherwise -> bale_out_with local_msg + (gre:_) -> return (Right (gre_name gre)) } + + lookup_group bound_names -- Look in the local envt (not top level) + = do { mname <- lookupLocalOccRn_maybe rdr_name + ; env <- getLocalRdrEnv + ; let candidates_msg = candidates $ localRdrEnvElts env + ; case mname of + Just n + | n `elemNameSet` bound_names -> return (Right n) + | otherwise -> bale_out_with local_msg + Nothing -> bale_out_with candidates_msg } + + bale_out_with msg + = return (Left (sep [ text "The" <+> what + <+> text "for" <+> quotes (ppr rdr_name) + , nest 2 $ text "lacks an accompanying binding"] + $$ nest 2 msg)) + + local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where") + <+> quotes (ppr rdr_name) <+> text "is declared" + + -- Identify all similar names and produce a message listing them + candidates :: [Name] -> MsgDoc + candidates names_in_scope + = case similar_names of + [] -> Outputable.empty + [n] -> text "Perhaps you meant" <+> pp_item n + _ -> sep [ text "Perhaps you meant one of these:" + , nest 2 (pprWithCommas pp_item similar_names) ] + where + similar_names + = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) + $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) + names_in_scope + + pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) + + +--------------- +lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] +-- GHC extension: look up both the tycon and data con or variable. +-- Used for top-level fixity signatures and deprecations. +-- Complain if neither is in scope. +-- See Note [Fixity signature lookup] +lookupLocalTcNames ctxt what rdr_name + = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) + ; let (errs, names) = partitionEithers mb_gres + ; when (null names) $ addErr (head errs) -- Bleat about one only + ; return names } + where + lookup rdr = do { this_mod <- getModule + ; nameEither <- lookupBindGroupOcc ctxt what rdr + ; return (guard_builtin_syntax this_mod rdr nameEither) } + + -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 + guard_builtin_syntax this_mod rdr (Right name) + | Just _ <- isBuiltInOcc_maybe (occName rdr) + , this_mod /= nameModule name + = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr]) + | otherwise + = Right (rdr, name) + guard_builtin_syntax _ _ (Left err) = Left err + +dataTcOccs :: RdrName -> [RdrName] +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] +dataTcOccs rdr_name + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = + case rdr_name of + -- The (~) type operator is always in scope, so we need a special case + -- for it here, or else :info (~) fails in GHCi. + -- See Note [eqTyCon (~) is built-in syntax] + Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR + _ -> setRdrNameSpace rdr_name tcName + +{- +Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. +-} + + + +{- +************************************************************************ +* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_RebindableSyntax dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + +* * +************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional/HsIsString + * NegApp + * NPlusKPat + * HsDo +respectively. Initially, we just store the "standard" name (GHC.Builtin.Names.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does. + +We treat the original (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. +-} + +lookupIfThenElse :: Bool -- False <=> don't use rebindable syntax under any conditions + -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Different to lookupSyntax because in the non-rebindable +-- case we desugar directly rather than calling an existing function +-- Hence the (Maybe (SyntaxExpr GhcRn)) return type +lookupIfThenElse maybe_use_rs + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not (rebindable_on && maybe_use_rs) + then return (NoSyntaxExprRn, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return ( mkRnSyntaxExpr ite + , unitFV ite ) } } + +lookupSyntaxName :: Name -- ^ The standard name + -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name +lookupSyntaxName std_name + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return (std_name, emptyFVs) + else + -- Get the similarly named thing from the local environment + do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) + ; return (usr_name, unitFV usr_name) } } + +lookupSyntaxExpr :: Name -- ^ The standard name + -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name +lookupSyntaxExpr std_name + = fmap (first nl_HsVar) $ lookupSyntaxName std_name + +lookupSyntax :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name +lookupSyntax std_name + = fmap (first mkSyntaxExpr) $ lookupSyntaxExpr std_name + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames + -- this works with CmdTop, which wants HsExprs, not SyntaxExprs +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return (map (HsVar noExtField . noLoc) std_names, emptyFVs) + else + do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names + ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } } + +{- +Note [QualifiedDo] +~~~~~~~~~~~~~~~~~~ +QualifiedDo is implemented using the same placeholders for operation names in +the AST that were devised for RebindableSyntax. Whenever the renamer checks +which names to use for do syntax, it first checks if the do block is qualified +(e.g. M.do { stmts }), in which case it searches for qualified names. If the +qualified names are not in scope, an error is produced. If the do block is not +qualified, the renamer does the usual search of the names which considers +whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven +by the Opt_QualifiedDo dynamic flag. +-} + +-- Lookup operations for a qualified do. If the context is not a qualified +-- do, then use lookupSyntaxExpr. See Note [QualifiedDo]. +lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars) +lookupQualifiedDoExpr ctxt std_name + = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name + +-- Like lookupQualifiedDoExpr but for producing SyntaxExpr. +-- See Note [QualifiedDo]. +lookupQualifiedDo + :: HsStmtContext p + -> Name + -> RnM (SyntaxExpr GhcRn, FreeVars) +lookupQualifiedDo ctxt std_name + = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name + +lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) +lookupNameWithQualifier std_name modName + = do { qname <- lookupOccRn (mkRdrQual modName (nameOccName std_name)) + ; return (qname, unitFV qname) } + +-- See Note [QualifiedDo]. +lookupQualifiedDoName + :: HsStmtContext p + -> Name + -> RnM (Name, FreeVars) +lookupQualifiedDoName ctxt std_name + = case qualifiedDoModuleName_maybe ctxt of + Nothing -> lookupSyntaxName std_name + Just modName -> lookupNameWithQualifier std_name modName + + +-- Lookup a locally-rebound name for Rebindable Syntax (RS). +-- +-- - When RS is off, 'lookupRebound' just returns 'Nothing', whatever +-- name it is given. +-- +-- - When RS is on, we always try to return a 'Just', and GHC errors out +-- if no suitable name is found in the environment. +-- +-- 'Nothing' really is "reserved" and means that rebindable syntax is off. +lookupRebound :: FastString -> RnM (Maybe (Located Name)) +lookupRebound nameStr = do + rebind <- xoptM LangExt.RebindableSyntax + if rebind + -- If repetitive lookups ever become a problem perormance-wise, + -- we could lookup all the names we will ever care about just once + -- at the beginning and stick them in the environment, possibly + -- populating that "cache" lazily too. + then (\nm -> Just (L (nameSrcSpan nm) nm)) <$> + lookupOccRn (mkVarUnqual nameStr) + else pure Nothing + +-- | Lookup an @ifThenElse@ binding (see 'lookupRebound'). +lookupReboundIf :: RnM (Maybe (Located Name)) +lookupReboundIf = lookupRebound reboundIfSymbol + +-- Error messages + + +opDeclErr :: RdrName -> SDoc +opDeclErr n + = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) + 2 (text "Use TypeOperators to declare operators in type and declarations") + +badOrigBinding :: RdrName -> SDoc +badOrigBinding name + | Just _ <- isBuiltInOcc_maybe occ + = text "Illegal binding of built-in syntax:" <+> ppr occ + -- Use an OccName here because we don't want to print Prelude.(,) + | otherwise + = text "Cannot redefine a Name retrieved by a Template Haskell quote:" + <+> ppr name + -- This can happen when one tries to use a Template Haskell splice to + -- define a top-level identifier with an already existing name, e.g., + -- + -- $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) + -- + -- (See #13968.) + where + occ = rdrNameOcc $ filterCTuple name diff --git a/GHC/Rename/Expr.hs b/GHC/Rename/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Expr.hs @@ -0,0 +1,2261 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming of expressions + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Rename.Expr ( + rnLExpr, rnExpr, rnStmts + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS + , rnMatchGroup, rnGRHS, makeMiniFixityEnv) +import GHC.Hs +import GHC.Tc.Utils.Env ( isBrackStage ) +import GHC.Tc.Utils.Monad +import GHC.Unit.Module ( getModule ) +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames + , bindLocalNames + , mapMaybeFvRn, mapFvRn + , warnUnusedLocalBinds, typeAppErr + , checkUnusedRecordWildcard ) +import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName ) +import GHC.Rename.HsType +import GHC.Rename.Pat +import GHC.Driver.Session +import GHC.Builtin.Names + +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Unique.Set +import Data.List +import Data.Maybe (isJust, isNothing) +import GHC.Utils.Misc +import GHC.Data.List.SetOps ( removeDups ) +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Types.SrcLoc +import GHC.Data.FastString +import Control.Monad +import GHC.Builtin.Types ( nilDataConName ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Arrow (first) +import Data.Ord +import Data.Array +import qualified Data.List.NonEmpty as NE + +{- +************************************************************************ +* * +\subsubsection{Expressions} +* * +************************************************************************ +-} + +rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) +rnExprs ls = rnExprs' ls emptyUniqSet + where + rnExprs' [] acc = return ([], acc) + rnExprs' (expr:exprs) acc = + do { (expr', fvExpr) <- rnLExpr expr + -- Now we do a "seq" on the free vars because typically it's small + -- or empty, especially in very long lists of constants + ; let acc' = acc `plusFV` fvExpr + ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' + ; return (expr':exprs', fvExprs) } + +-- Variables. We look up the variable and return the resulting name. + +rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) +rnLExpr = wrapLocFstM rnExpr + +rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) + +finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) +-- Separated from rnExpr because it's also used +-- when renaming infix expressions +finishHsVar (L l name) + = do { this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod name) $ + checkThLocalName name + ; return (HsVar noExtField (L l name), unitFV name) } + +rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) +rnUnboundVar v + = do { if isUnqual v + then -- Treat this as a "hole" + -- Do not fail right now; instead, return HsUnboundVar + -- and let the type checker report the error + return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) + + else -- Fail immediately (qualified name) + do { n <- reportUnboundName v + ; return (HsVar noExtField (noLoc n), emptyFVs) } } + +rnExpr (HsVar _ (L l v)) + = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields + ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v + ; dflags <- getDynFlags + ; case mb_name of { + Nothing -> rnUnboundVar v ; + Just (Left name) + | name == nilDataConName -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -- Note [Empty lists] in GHC.Hs.Expr + , xopt LangExt.OverloadedLists dflags + -> rnExpr (ExplicitList noExtField Nothing []) + + | otherwise + -> finishHsVar (L l name) ; + Just (Right [s]) -> + return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ; + Just (Right fs@(_:_:_)) -> + return ( HsRecFld noExtField (Ambiguous noExtField (L l v)) + , mkFVs fs); + Just (Right []) -> panic "runExpr/HsVar" } } + +rnExpr (HsIPVar x v) + = return (HsIPVar x v, emptyFVs) + +rnExpr (HsUnboundVar x v) + = return (HsUnboundVar x v, emptyFVs) + +rnExpr (HsOverLabel x _ v) + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if rebindable_on + then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) + ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } + else return (HsOverLabel x Nothing v, emptyFVs) } + +rnExpr (HsLit x lit@(HsString src s)) + = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings + ; if opt_OverloadedStrings then + rnExpr (HsOverLit x (mkHsIsString src s)) + else do { + ; rnLit lit + ; return (HsLit x (convertLit lit), emptyFVs) } } + +rnExpr (HsLit x lit) + = do { rnLit lit + ; return (HsLit x(convertLit lit), emptyFVs) } + +rnExpr (HsOverLit x lit) + = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] + ; case mb_neg of + Nothing -> return (HsOverLit x lit', fvs) + Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) + , fvs ) } + +rnExpr (HsApp x fun arg) + = do { (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } + +rnExpr (HsAppType x fun arg) + = do { type_app <- xoptM LangExt.TypeApplications + ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg + ; (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg + ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) } + +rnExpr (OpApp _ e1 op e2) + = do { (e1', fv_e1) <- rnLExpr e1 + ; (e2', fv_e2) <- rnLExpr e2 + ; (op', fv_op) <- rnLExpr op + + -- Deal with fixity + -- When renaming code synthesised from "deriving" declarations + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in GHC.Tc.Deriv.Generate + -- should prevent bad things happening. + ; fixity <- case op' of + L _ (HsVar _ (L _ n)) -> lookupFixityRn n + L _ (HsRecFld _ f) -> lookupFieldFixityRn f + _ -> return (Fixity NoSourceText minPrecedence InfixL) + -- c.f. lookupFixity for unbound + + ; lexical_negation <- xoptM LangExt.LexicalNegation + ; let negation_handling | lexical_negation = KeepNegationIntact + | otherwise = ReassociateNegation + ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2' + ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } + +rnExpr (NegApp _ e _) + = do { (e', fv_e) <- rnLExpr e + ; (neg_name, fv_neg) <- lookupSyntax negateName + ; final_e <- mkNegAppRn e' neg_name + ; return (final_e, fv_e `plusFV` fv_neg) } + +------------------------------------------ +-- Template Haskell extensions +rnExpr e@(HsBracket _ br_body) = rnBracket e br_body + +rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice + +--------------------------------------------- +-- Sections +-- See Note [Parsing sections] in GHC.Parser +rnExpr (HsPar x (L loc (section@(SectionL {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar x (L loc section'), fvs) } + +rnExpr (HsPar x (L loc (section@(SectionR {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar x (L loc section'), fvs) } + +rnExpr (HsPar x e) + = do { (e', fvs_e) <- rnLExpr e + ; return (HsPar x e', fvs_e) } + +rnExpr expr@(SectionL {}) + = do { addErr (sectionErr expr); rnSection expr } +rnExpr expr@(SectionR {}) + = do { addErr (sectionErr expr); rnSection expr } + +--------------------------------------------- +rnExpr (HsPragE x prag expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } + where + rn_prag :: HsPragE GhcPs -> HsPragE GhcRn + rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + +rnExpr (HsLam x matches) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches + ; return (HsLam x matches', fvMatch) } + +rnExpr (HsLamCase x matches) + = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsLamCase x matches', fvs_ms) } + +rnExpr (HsCase x expr matches) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + +rnExpr (HsLet x (L l binds) expr) + = rnLocalBindsAndThen binds $ \binds' _ -> do + { (expr',fvExpr) <- rnLExpr expr + ; return (HsLet x (L l binds') expr', fvExpr) } + +rnExpr (HsDo x do_or_lc (L l stmts)) + = do { ((stmts', _), fvs) <- + rnStmtsWithPostProcessing do_or_lc rnLExpr + postProcessStmtsForApplicativeDo stmts + (\ _ -> return ((), emptyFVs)) + ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } + +rnExpr (ExplicitList x _ exps) + = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists + ; (exps', fvs) <- rnExprs exps + ; if opt_OverloadedLists + then do { + ; (from_list_n_name, fvs') <- lookupSyntax fromListNName + ; return (ExplicitList x (Just from_list_n_name) exps' + , fvs `plusFV` fvs') } + else + return (ExplicitList x Nothing exps', fvs) } + +rnExpr (ExplicitTuple x tup_args boxity) + = do { checkTupleSection tup_args + ; checkTupSize (length tup_args) + ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args + ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } + where + rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e + ; return (L l (Present x e'), fvs) } + rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) + , emptyFVs) + +rnExpr (ExplicitSum x alt arity expr) + = do { (expr', fvs) <- rnLExpr expr + ; return (ExplicitSum x alt arity expr', fvs) } + +rnExpr (RecordCon { rcon_con_name = con_id + , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) + = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id + ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds + ; (flds', fvss) <- mapAndUnzipM rn_field flds + ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } + ; return (RecordCon { rcon_ext = noExtField + , rcon_con_name = con_lname, rcon_flds = rec_binds' } + , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } + where + mk_hs_var l n = HsVar noExtField (L l n) + rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } + +rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds + ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr' + , rupd_flds = rbinds' } + , fvExpr `plusFV` fvRbinds) } + +rnExpr (ExprWithTySig _ expr pty) + = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } +rnExpr (HsIf _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; mifteName <- lookupReboundIf + ; let subFVs = plusFVs [fvP, fvB1, fvB2] + ; return $ case mifteName of + -- RS is off, we keep an 'HsIf' node around + Nothing -> + (HsIf noExtField p' b1' b2', subFVs) + -- See Note [Rebindable syntax and HsExpansion]. + Just ifteName -> + let ifteExpr = rebindIf ifteName p' b1' b2' + in (ifteExpr, plusFVs [unitFV (unLoc ifteName), subFVs]) + } +rnExpr (HsMultiIf x alts) + = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts + -- ; return (HsMultiIf ty alts', fvs) } + ; return (HsMultiIf x alts', fvs) } + +rnExpr (ArithSeq x _ seq) + = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists + ; (new_seq, fvs) <- rnArithSeq seq + ; if opt_OverloadedLists + then do { + ; (from_list_name, fvs') <- lookupSyntax fromListName + ; return (ArithSeq x (Just from_list_name) new_seq + , fvs `plusFV` fvs') } + else + return (ArithSeq x Nothing new_seq, fvs) } + +{- +************************************************************************ +* * + Static values +* * +************************************************************************ + +For the static form we check that it is not used in splices. +We also collect the free variables of the term which come from +this module. See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. +-} + +rnExpr e@(HsStatic _ expr) = do + -- Normally, you wouldn't be able to construct a static expression without + -- first enabling -XStaticPointers in the first place, since that extension + -- is what makes the parser treat `static` as a keyword. But this is not a + -- sufficient safeguard, as one can construct static expressions by another + -- mechanism: Template Haskell (see #14204). To ensure that GHC is + -- absolutely prepared to cope with static forms, we check for + -- -XStaticPointers here as well. + unlessXOptM LangExt.StaticPointers $ + addErr $ hang (text "Illegal static expression:" <+> ppr e) + 2 (text "Use StaticPointers to enable this extension") + (expr',fvExpr) <- rnLExpr expr + stage <- getStage + case stage of + Splice _ -> addErr $ sep + [ text "static forms cannot be used in splices:" + , nest 2 $ ppr e + ] + _ -> return () + mod <- getModule + let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr + return (HsStatic fvExpr' expr', fvExpr) + +{- +************************************************************************ +* * + Arrow notation +* * +************************************************************************ +-} + +rnExpr (HsProc x pat body) + = newArrowScope $ + rnPat ProcExpr pat $ \ pat' -> do + { (body',fvBody) <- rnCmdTop body + ; return (HsProc x pat' body', fvBody) } + +rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) + -- HsWrap + +---------------------- +-- See Note [Parsing sections] in GHC.Parser +rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnSection section@(SectionR x op expr) + = do { (op', fvs_op) <- rnLExpr op + ; (expr', fvs_expr) <- rnLExpr expr + ; checkSectionPrec InfixR section op' expr' + ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } + +rnSection section@(SectionL x expr op) + = do { (expr', fvs_expr) <- rnLExpr expr + ; (op', fvs_op) <- rnLExpr op + ; checkSectionPrec InfixL section op' expr' + ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } + +rnSection other = pprPanic "rnSection" (ppr other) + +{- +************************************************************************ +* * + Arrow commands +* * +************************************************************************ +-} + +rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars) +rnCmdArgs [] = return ([], emptyFVs) +rnCmdArgs (arg:args) + = do { (arg',fvArg) <- rnCmdTop arg + ; (args',fvArgs) <- rnCmdArgs args + ; return (arg':args', fvArg `plusFV` fvArgs) } + +rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) +rnCmdTop = wrapLocFstM rnCmdTop' + where + rnCmdTop' (HsCmdTop _ cmd) + = do { (cmd', fvCmd) <- rnLCmd cmd + ; let cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetElemsStable (methodNamesCmd (unLoc cmd')) + -- Generate the rebindable syntax for the monad + ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names + + ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', + fvCmd `plusFV` cmd_fvs) } + +rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) +rnLCmd = wrapLocFstM rnCmd + +rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) + +rnCmd (HsCmdArrApp x arrow arg ho rtl) + = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdArrApp x arrow' arg' ho rtl, + fvArrow `plusFV` fvArg) } + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + -- See Note [Escaping the arrow scope] in GHC.Tc.Types + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. + +-- infix form +rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) + = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) + ; let L _ (HsVar _ (L _ op_name)) = op' + ; (arg1',fv_arg1) <- rnCmdTop arg1 + ; (arg2',fv_arg2) <- rnCmdTop arg2 + -- Deal with fixity + ; fixity <- lookupFixityRn op_name + ; final_e <- mkOpFormRn arg1' op' fixity arg2' + ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } + +rnCmd (HsCmdArrForm x op f fixity cmds) + = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) + ; (cmds',fvCmds) <- rnCmdArgs cmds + ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } + +rnCmd (HsCmdApp x fun arg) + = do { (fun',fvFun) <- rnLCmd fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } + +rnCmd (HsCmdLam x matches) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches + ; return (HsCmdLam x matches', fvMatch) } + +rnCmd (HsCmdPar x e) + = do { (e', fvs_e) <- rnLCmd e + ; return (HsCmdPar x e', fvs_e) } + +rnCmd (HsCmdCase x expr matches) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + +rnCmd (HsCmdLamCase x matches) + = do { (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; return (HsCmdLamCase x new_matches, ms_fvs) } + +rnCmd (HsCmdIf x _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLCmd b1 + ; (b2', fvB2) <- rnLCmd b2 + ; (mb_ite, fvITE) <- lookupIfThenElse True + ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + +rnCmd (HsCmdLet x (L l binds) cmd) + = rnLocalBindsAndThen binds $ \ binds' _ -> do + { (cmd',fvExpr) <- rnLCmd cmd + ; return (HsCmdLet x (L l binds') cmd', fvExpr) } + +rnCmd (HsCmdDo x (L l stmts)) + = do { ((stmts', _), fvs) <- + rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo x (L l stmts'), fvs ) } + +--------------------------------------------------- +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName + +-- find what methods the Cmd needs (loop, choice, apply) +methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds +methodNamesLCmd = methodNamesCmd . unLoc + +methodNamesCmd :: HsCmd GhcRn -> CmdNeeds + +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) + = emptyFVs +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) + = unitFV appAName +methodNamesCmd (HsCmdArrForm {}) = emptyFVs + +methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c + +methodNamesCmd (HsCmdIf _ _ _ c1 c2) + = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName + +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match + +methodNamesCmd (HsCmdCase _ _ matches) + = methodNamesMatch matches `addOneFV` choiceAName +methodNamesCmd (HsCmdLamCase _ matches) + = methodNamesMatch matches `addOneFV` choiceAName + +--methodNamesCmd _ = emptyFVs + -- Other forms can't occur in commands, but it's not convenient + -- to error here so we just do what's convenient. + -- The type checker will complain later + +--------------------------------------------------- +methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesMatch (MG { mg_alts = L _ ms }) + = plusFVs (map do_one ms) + where + do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss + +------------------------------------------------- +-- gaw 2004 +methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) + +------------------------------------------------- + +methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds +methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs + +--------------------------------------------------- +methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars +methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) + +--------------------------------------------------- +methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars +methodNamesLStmt = methodNamesStmt . unLoc + +methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd +methodNamesStmt (RecStmt { recS_stmts = stmts }) = + methodNamesStmts stmts `addOneFV` loopAName +methodNamesStmt (LetStmt {}) = emptyFVs +methodNamesStmt (ParStmt {}) = emptyFVs +methodNamesStmt (TransStmt {}) = emptyFVs +methodNamesStmt ApplicativeStmt{} = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not + -- convenient to error here so we just do what's convenient + +{- +************************************************************************ +* * + Arithmetic sequences +* * +************************************************************************ +-} + +rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) +rnArithSeq (From expr) + = do { (expr', fvExpr) <- rnLExpr expr + ; return (From expr', fvExpr) } + +rnArithSeq (FromThen expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromTo expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromThenTo expr1 expr2 expr3) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; (expr3', fvExpr3) <- rnLExpr expr3 + ; return (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) } + +{- +************************************************************************ +* * +\subsubsection{@Stmt@s: in @do@ expressions} +* * +************************************************************************ +-} + +{- +Note [Deterministic ApplicativeDo and RecursiveDo desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both ApplicativeDo and RecursiveDo need to create tuples not +present in the source text. + +For ApplicativeDo we create: + + (a,b,c) <- (\c b a -> (a,b,c)) <$> + +For RecursiveDo we create: + + mfix (\ ~(a,b,c) -> do ...; return (a',b',c')) + +The order of the components in those tuples needs to be stable +across recompilations, otherwise they can get optimized differently +and we end up with incompatible binaries. +To get a stable order we use nameSetElemsStable. +See Note [Deterministic UniqFM] to learn more about nondeterminism. +-} + +-- | Rename some Stmts +rnStmts :: Outputable (body GhcPs) + => HsStmtContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -- ^ How to rename the body of each statement (e.g. rnLExpr) + -> [LStmt GhcPs (Located (body GhcPs))] + -- ^ Statements + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ if these statements scope over something, this renames it + -- and returns the result. + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) +rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts + +-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts +rnStmtsWithPostProcessing + :: Outputable (body GhcPs) + => HsStmtContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -- ^ How to rename the body of each statement (e.g. rnLExpr) + -> (HsStmtContext GhcRn + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) + -- ^ postprocess the statements + -> [LStmt GhcPs (Located (body GhcPs))] + -- ^ Statements + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ if these statements scope over something, this renames it + -- and returns the result. + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) +rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside + = do { ((stmts', thing), fvs) <- + rnStmtsWithFreeVars ctxt rnBody stmts thing_inside + ; (pp_stmts, fvs') <- ppStmts ctxt stmts' + ; return ((pp_stmts, thing), fvs `plusFV` fvs') + } + +-- | maybe rearrange statements according to the ApplicativeDo transformation +postProcessStmtsForApplicativeDo + :: HsStmtContext GhcRn + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) +postProcessStmtsForApplicativeDo ctxt stmts + = do { + -- rearrange the statements using ApplicativeStmt if + -- -XApplicativeDo is on. Also strip out the FreeVars attached + -- to each Stmt body. + ado_is_on <- xoptM LangExt.ApplicativeDo + ; let is_do_expr | DoExpr{} <- ctxt = True + | otherwise = False + -- don't apply the transformation inside TH brackets, because + -- GHC.HsToCore.Quote does not handle ApplicativeDo. + ; in_th_bracket <- isBrackStage <$> getStage + ; if ado_is_on && is_do_expr && not in_th_bracket + then do { traceRn "ppsfa" (ppr stmts) + ; rearrangeForApplicativeDo ctxt stmts } + else noPostProcessStmts ctxt stmts } + +-- | strip the FreeVars annotations from statements +noPostProcessStmts + :: HsStmtContext GhcRn + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) +noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) + + +rnStmtsWithFreeVars :: Outputable (body GhcPs) + => HsStmtContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + , FreeVars) +-- Each Stmt body is annotated with its FreeVars, so that +-- we can rearrange statements for ApplicativeDo. +-- +-- Variables bound by the Stmts, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmtsWithFreeVars ctxt _ [] thing_inside + = do { checkEmptyStmts ctxt + ; (thing, fvs) <- thing_inside [] + ; return (([], thing), fvs) } + +rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with mdo + = -- Behave like do { rec { ...all but last... }; last } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt mDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt mDoExpr last_stmt + ; rnStmt mDoExpr rnBody last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + where + Just (all_but_last, last_stmt) = snocView stmts + +rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpan loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt' thing_inside } + + | otherwise + = do { ((stmts1, (stmts2, thing)), fvs) + <- setSrcSpan loc $ + do { checkStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> + rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> + thing_inside (bndrs1 ++ bndrs2) } + ; return (((stmts1 ++ stmts2), thing), fvs) } + +---------------------- + +{- +Note [Failing pattern matches in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Many things desugar to HsStmts including monadic things like `do` and `mdo` +statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an +exhaustive list). How we deal with pattern match failure is context-dependent. + + * In the case of list comprehensions and pattern guards we don't need any + 'fail' function; the desugarer ignores the fail function of 'BindStmt' + entirely. So, for list comprehensions, the fail function is set to 'Nothing' + for clarity. + + * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo + expressions) we want pattern match failure to be desugared to the appropriate + 'fail' function (either that of Monad or MonadFail, depending on whether + -XMonadFailDesugaring is enabled.) + +At one point we failed to make this distinction, leading to #11216. +-} + +rnStmt :: Outputable (body GhcPs) + => HsStmtContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -- ^ How to rename the body of the statement + -> LStmt GhcPs (Located (body GhcPs)) + -- ^ The statement + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ Rename the stuff that this statement scopes over + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + , FreeVars) +-- Variables bound by the Stmt, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- if isMonadCompContext ctxt + then lookupStmtName ctxt returnMName + else return (noSyntaxExpr, emptyFVs) + -- The 'return' in a LastStmt is used only + -- for MonadComp; and we don't want to report + -- "non in scope: return" in other cases + -- #15607 + + ; (thing, fvs3) <- thing_inside [] + ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName + + ; (guard_op, fvs2) <- if isComprehensionContext ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + + ; (thing, fvs3) <- thing_inside [] + ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside + = do { (body', fv_expr) <- rnBody body + -- The binders do not scope over the expression + ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName + + ; (fail_op, fvs2) <- monadFailOp pat ctxt + + ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do + { (thing, fvs3) <- thing_inside (collectPatBinders pat') + ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } + ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )] + , thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + -- fv_expr shouldn't really be filtered by the rnPatsAndThen + -- but it does not matter because the names are unique + +rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do + { (thing, fvs) <- thing_inside (collectLocalBinders binds') + ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) + , fvs) } } + +rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside + = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName + ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } + + -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) + ; rnRecStmtsAndThen ctxt rnBody rec_stmts $ \ segs -> do + { let bndrs = nameSetElemsStable $ + foldr (unionNameSet . (\(ds,_,_,_) -> ds)) + emptyNameSet + segs + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + ; (thing, fvs_later) <- thing_inside bndrs + ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + -- We aren't going to try to group RecStmts with + -- ApplicativeDo, so attaching empty FVs is fine. + ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) + , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } + +rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside + ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing) + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } + +rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + (using', fvs1) <- rnLExpr using + + -- Rename the stmts and the 'by' expression + -- Keep track of the variables mentioned in the 'by' expression + ; ((stmts', (by', used_bndrs, thing)), fvs2) + <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> + do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by + ; (thing, fvs_thing) <- thing_inside bndrs + ; let fvs = fvs_by `plusFV` fvs_thing + used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free variable + -- of the "thing inside", **or of the by-expression**, as used + ; return ((by', used_bndrs, thing), fvs) } + + -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noExpr, emptyFVs) + _ -> lookupStmtNamePoly ctxt fmapName + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + `plusFV` fvs4 `plusFV` fvs5 + bndr_map = used_bndrs `zip` used_bndrs + -- See Note [TransStmt binder map] in GHC.Hs.Expr + + ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) + ; return (([(L loc (TransStmt { trS_ext = noExtField + , trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } + +rnStmt _ _ (L _ ApplicativeStmt{}) _ = + panic "rnStmt: ApplicativeStmt" + +rnParallelStmts :: forall thing. HsStmtContext GhcRn + -> SyntaxExpr GhcRn + -> [ParStmtBlock GhcPs GhcPs] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) +-- Note [Renaming parallel Stmts] +rnParallelStmts ctxt return_op segs thing_inside + = do { orig_lcl_env <- getLocalRdrEnv + ; rn_segs orig_lcl_env [] segs } + where + rn_segs :: LocalRdrEnv + -> [Name] -> [ParStmtBlock GhcPs GhcPs] + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) + rn_segs _ bndrs_so_far [] + = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far + ; mapM_ dupErr dups + ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') + ; return (([], thing), fvs) } + + rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) + = do { ((stmts', (used_bndrs, segs', thing)), fvs) + <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> + setLocalRdrEnv env $ do + { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs + ; let used_bndrs = filter (`elemNameSet` fvs) bndrs + ; return ((used_bndrs, segs', thing), fvs) } + + ; let seg' = ParStmtBlock x stmts' used_bndrs return_op + ; return ((seg':segs', thing), fvs) } + + cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" + <+> quotes (ppr (NE.head vs))) + +lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Like lookupStmtName, but respects QualifiedDo +lookupQualifiedDoStmtName ctxt n + = case qualifiedDoModuleName_maybe ctxt of + Nothing -> lookupStmtName ctxt n + Just modName -> + first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName + +lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Like lookupSyntax, but respects contexts +lookupStmtName ctxt n + | rebindableContext ctxt + = lookupSyntax n + | otherwise + = return (mkRnSyntaxExpr n, emptyFVs) + +lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars) +lookupStmtNamePoly ctxt name + | rebindableContext ctxt + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if rebindable_on + then do { fm <- lookupOccRn (nameRdrName name) + ; return (HsVar noExtField (noLoc fm), unitFV fm) } + else not_rebindable } + | otherwise + = not_rebindable + where + not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs) + +-- | Is this a context where we respect RebindableSyntax? +-- but ListComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows +rebindableContext :: HsStmtContext GhcRn -> Bool +rebindableContext ctxt = case ctxt of + ListComp -> False + ArrowExpr -> False + PatGuard {} -> False + + DoExpr m -> isNothing m + MDoExpr m -> isNothing m + MonadComp -> True + GhciStmtCtxt -> True -- I suppose? + + ParStmtCtxt c -> rebindableContext c -- Look inside to + TransStmtCtxt c -> rebindableContext c -- the parent context + +{- +Note [Renaming parallel Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Renaming parallel statements is painful. Given, say + [ a+c | a <- as, bs <- bss + | c <- bs, a <- ds ] +Note that + (a) In order to report "Defined but not used" about 'bs', we must + rename each group of Stmts with a thing_inside whose FreeVars + include at least {a,c} + + (b) We want to report that 'a' is illegally bound in both branches + + (c) The 'bs' in the second group must obviously not be captured by + the binding in the first group + +To satisfy (a) we nest the segements. +To satisfy (b) we check for duplicates just before thing_inside. +To satisfy (c) we reset the LocalRdrEnv each time. + +************************************************************************ +* * +\subsubsection{mdo expressions} +* * +************************************************************************ +-} + +type FwdRefs = NameSet +type Segment stmts = (Defs, + Uses, -- May include defs + FwdRefs, -- A subset of uses that are + -- (a) used before they are bound in this segment, or + -- (b) used here, and bound in subsequent segments + stmts) -- Either Stmt or [Stmt] + + +-- wrapper that does both the left- and right-hand sides +rnRecStmtsAndThen :: Outputable (body GhcPs) => + HsStmtContext GhcRn + -> (Located (body GhcPs) + -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] + -- assumes that the FreeVars returned includes + -- the FreeVars of the Segments + -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] + -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnRecStmtsAndThen ctxt rnBody s cont + = do { -- (A) Make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + + -- (B) Do the LHSes + ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + + -- ...bring them and their fixities into scope + ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) + implicit_uses = mkNameSet $ concatMap snd $ rec_uses + ; bindLocalNamesFV bound_names $ + addLocalFixities fix_env bound_names $ do + + -- (C) do the right-hand-sides and thing-inside + { segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv + ; (res, fvs) <- cont segs + ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns)) + rec_uses + ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses) + ; return (res, fvs) }} + +-- get all the fixity decls in any Let stmt +collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig _ s)) -> (L loc s) : acc + _ -> acc) acc sigs + _ -> acc) [] l + +-- left-hand sides + +rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv + -> LStmt GhcPs body + -- rename LHS, and return its FVs + -- Warning: we will only need the FreeVars below in the case of a BindStmt, + -- so we don't bother to compute it accurately in the other cases + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] + +rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) + = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] + +rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a)) + = return [(L loc (LastStmt noExtField body noret a), emptyFVs)] + +rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body)) + = do + -- should the ctxt be MDo instead? + (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat + return [(L loc (BindStmt noExtField pat' body), fv_pat)] + +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) + = failWith (badIpBinds (text "an mdo expression") binds) + +rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) + = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds + return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))), + -- Warning: this is bogus; see function invariant + emptyFVs + )] + +-- XXX Do we need to do something with the return and mfix names? +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec + = rn_rec_stmts_lhs fix_env stmts + +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) + = panic "rn_rec_stmt LetStmt EmptyLocalBinds" + +rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv + -> [LStmt GhcPs body] + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] +rn_rec_stmts_lhs fix_env stmts + = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts + ; let boundNames = collectLStmtsBinders (map fst ls) + -- First do error checking: we need to check for dups here because we + -- don't bind all of the variables from the Stmt at once + -- with bindLocatedLocals. + ; checkDupNames boundNames + ; return ls } + + +-- right-hand-sides + +rn_rec_stmt :: (Outputable (body GhcPs)) => + HsStmtContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [Name] + -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] + -- Rename a Stmt that is inside a RecStmt (or mdo) + -- Assumes all binders are already in scope + -- Turns each stmt into a singleton Stmt +rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ body noret _), _) + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt noExtField body' noret ret_op))] } + +rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ body _ _), _) + = do { (body', fvs) <- rnBody body + ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName + ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, + L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } + +rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) + = do { (body', fv_expr) <- rnBody body + ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName + + ; (fail_op, fvs2) <- getMonadFailOp ctxt + + ; let bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } + ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, + L loc (BindStmt xbsrn pat' body'))] } + +rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) + = failWith (badIpBinds (text "an mdo expression") binds) + +rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) + = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' + -- fixities and unused are handled above in rnRecStmtsAndThen + ; let fvs = allUses du_binds + ; return [(duDefs du_binds, fvs, emptyNameSet, + L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } + +-- no RecStmt case because they get flattened above when doing the LHSes +rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _) + = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) + +rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) + +rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) + +rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) + = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" + +rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _) + = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) + +rn_rec_stmts :: Outputable (body GhcPs) => + HsStmtContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [Name] + -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] +rn_rec_stmts ctxt rnBody bndrs stmts + = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts + ; return (concat segs_s) } + +--------------------------------------------- +segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn + -> Stmt GhcRn body + -> [Segment (LStmt GhcRn body)] -> FreeVars + -> ([LStmt GhcRn body], FreeVars) + +segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + | null segs + = ([], fvs_later) + + | MDoExpr _ <- ctxt + = segsToStmts empty_rec_stmt grouped_segs fvs_later + -- Step 4: Turn the segments into Stmts + -- Use RecStmt when and only when there are fwd refs + -- Also gather up the uses from the end towards the + -- start, so we can tell the RecStmt which things are + -- used 'after' the RecStmt + + | otherwise + = ([ L loc $ + empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetElemsStable + (defs `intersectNameSet` fvs_later) + , recS_rec_ids = nameSetElemsStable + (defs `intersectNameSet` uses) }] + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + , uses `plusFV` fvs_later) + + where + (defs_s, uses_s, _, ss) = unzip4 segs + defs = plusFVs defs_s + uses = plusFVs uses_s + + -- Step 2: Fill in the fwd refs. + -- The segments are all singletons, but their fwd-ref + -- field mentions all the things used by the segment + -- that are bound after their use + segs_w_fwd_refs = addFwdRefs segs + + -- Step 3: Group together the segments to make bigger segments + -- Invariant: in the result, no segment uses a variable + -- bound in a later segment + grouped_segs = glomSegments ctxt segs_w_fwd_refs + +---------------------------- +addFwdRefs :: [Segment a] -> [Segment a] +-- So far the segments only have forward refs *within* the Stmt +-- (which happens for bind: x <- ...x...) +-- This function adds the cross-seg fwd ref info + +addFwdRefs segs + = fst (foldr mk_seg ([], emptyNameSet) segs) + where + mk_seg (defs, uses, fwds, stmts) (segs, later_defs) + = (new_seg : segs, all_defs) + where + new_seg = (defs, uses, new_fwds, stmts) + all_defs = later_defs `unionNameSet` defs + new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs) + -- Add the downstream fwd refs here + +{- +Note [Segmenting mdo] +~~~~~~~~~~~~~~~~~~~~~ +NB. June 7 2012: We only glom segments that appear in an explicit mdo; +and leave those found in "do rec"'s intact. See +https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion +leading to this design choice. Hence the test in segmentRecStmts. + +Note [Glomming segments] +~~~~~~~~~~~~~~~~~~~~~~~~ +Glomming the singleton segments of an mdo into minimal recursive groups. + +At first I thought this was just strongly connected components, but +there's an important constraint: the order of the stmts must not change. + +Consider + mdo { x <- ...y... + p <- z + y <- ...x... + q <- x + z <- y + r <- x } + +Here, the first stmt mention 'y', which is bound in the third. +But that means that the innocent second stmt (p <- z) gets caught +up in the recursion. And that in turn means that the binding for +'z' has to be included... and so on. + +Start at the tail { r <- x } +Now add the next one { z <- y ; r <- x } +Now add one more { q <- x ; z <- y ; r <- x } +Now one more... but this time we have to group a bunch into rec + { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } +Now one more, which we can add on without a rec + { p <- z ; + rec { y <- ...x... ; q <- x ; z <- y } ; + r <- x } +Finally we add the last one; since it mentions y we have to +glom it together with the first two groups + { rec { x <- ...y...; p <- z ; y <- ...x... ; + q <- x ; z <- y } ; + r <- x } +-} + +glomSegments :: HsStmtContext GhcRn + -> [Segment (LStmt GhcRn body)] + -> [Segment [LStmt GhcRn body]] + -- Each segment has a non-empty list of Stmts +-- See Note [Glomming segments] + +glomSegments _ [] = [] +glomSegments ctxt ((defs,uses,fwds,stmt) : segs) + -- Actually stmts will always be a singleton + = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others + where + segs' = glomSegments ctxt segs + (extras, others) = grab uses segs' + (ds, us, fs, ss) = unzip4 extras + + seg_defs = plusFVs ds `plusFV` defs + seg_uses = plusFVs us `plusFV` uses + seg_fwds = plusFVs fs `plusFV` fwds + seg_stmts = stmt : concat ss + + grab :: NameSet -- The client + -> [Segment a] + -> ([Segment a], -- Needed by the 'client' + [Segment a]) -- Not needed by the client + -- The result is simply a split of the input + grab uses dus + = (reverse yeses, reverse noes) + where + (noes, yeses) = span not_needed (reverse dus) + not_needed (defs,_,_,_) = disjointNameSet defs uses + +---------------------------------------------------- +segsToStmts :: Stmt GhcRn body + -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt GhcRn body]] + -- Each Segment has a non-empty list of Stmts + -> FreeVars -- Free vars used 'later' + -> ([LStmt GhcRn body], FreeVars) + +segsToStmts _ [] fvs_later = ([], fvs_later) +segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later + = ASSERT( not (null ss) ) + (new_stmt : later_stmts, later_uses `plusFV` uses) + where + (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later + new_stmt | non_rec = head ss + | otherwise = L (getLoc (head ss)) rec_stmt + rec_stmt = empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetElemsStable used_later + , recS_rec_ids = nameSetElemsStable fwds } + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + non_rec = isSingleton ss && isEmptyNameSet fwds + used_later = defs `intersectNameSet` later_uses + -- The ones needed after the RecStmt + +{- +************************************************************************ +* * +ApplicativeDo +* * +************************************************************************ + +Note [ApplicativeDo] + += Example = + +For a sequence of statements + + do + x <- A + y <- B x + z <- C + return (f x y z) + +We want to transform this to + + (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C + +It would be easy to notice that "y <- B x" and "z <- C" are +independent and do something like this: + + do + x <- A + (y,z) <- (,) <$> B x <*> C + return (f x y z) + +But this isn't enough! A and C were also independent, and this +transformation loses the ability to do A and C in parallel. + +The algorithm works by first splitting the sequence of statements into +independent "segments", and a separate "tail" (the final statement). In +our example above, the segements would be + + [ x <- A + , y <- B x ] + + [ z <- C ] + +and the tail is: + + return (f x y z) + +Then we take these segments and make an Applicative expression from them: + + (\(x,y) z -> return (f x y z)) + <$> do { x <- A; y <- B x; return (x,y) } + <*> C + +Finally, we recursively apply the transformation to each segment, to +discover any nested parallelism. + += Syntax & spec = + + expr ::= ... | do {stmt_1; ..; stmt_n} expr | ... + + stmt ::= pat <- expr + | (arg_1 | ... | arg_n) -- applicative composition, n>=1 + | ... -- other kinds of statement (e.g. let) + + arg ::= pat <- expr + | {stmt_1; ..; stmt_n} {var_1..var_n} + +(note that in the actual implementation,the expr in a do statement is +represented by a LastStmt as the final stmt, this is just a +representational issue and may change later.) + +== Transformation to introduce applicative stmts == + +ado {} tail = tail +ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr' +ado {one} tail = one : tail +ado stmts tail + | n == 1 = ado before (ado after tail) + where (before,after) = split(stmts_1) + | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail + where + {stmts_1 .. stmts_n} = segments(stmts) + +segments(stmts) = + -- divide stmts into segments with no interdependencies + +mkArg({pat <- expr}) = (pat <- expr) +mkArg({stmt_1; ...; stmt_n}) = + {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)} + +split({stmt_1; ..; stmt_n) = + ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n}) + -- 1 <= i <= n + -- i is a good place to insert a bind + +== Desugaring for do == + +dsDo {} expr = expr + +dsDo {pat <- rhs; stmts} expr = + rhs >>= \pat -> dsDo stmts expr + +dsDo {(arg_1 | ... | arg_n)} (return expr) = + (\argpat (arg_1) .. argpat(arg_n) -> expr) + <$> argexpr(arg_1) + <*> ... + <*> argexpr(arg_n) + +dsDo {(arg_1 | ... | arg_n); stmts} expr = + join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr) + <$> argexpr(arg_1) + <*> ... + <*> argexpr(arg_n) + += Relevant modules in the rest of the compiler = + +ApplicativeDo touches a few phases in the compiler: + +* Renamer: The journey begins here in the renamer, where do-blocks are + scheduled as outlined above and transformed into applicative + combinators. However, the code is still represented as a do-block + with special forms of applicative statements. This allows us to + recover the original do-block when e.g. printing type errors, where + we don't want to show any of the applicative combinators since they + don't exist in the source code. + See ApplicativeStmt and ApplicativeArg in HsExpr. + +* Typechecker: ApplicativeDo passes through the typechecker much like any + other form of expression. The only crux is that the typechecker has to + be aware of the special ApplicativeDo statements in the do-notation, and + typecheck them appropriately. + Relevant module: GHC.Tc.Gen.Match + +* Desugarer: Any do-block which contains applicative statements is desugared + as outlined above, to use the Applicative combinators. + Relevant module: GHC.HsToCore.Expr + +-} + +-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and +-- 'pureName' due to @QualifiedDo@ or @RebindableSyntax@. +data MonadNames = MonadNames { return_name, pure_name :: Name } + +instance Outputable MonadNames where + ppr (MonadNames {return_name=return_name,pure_name=pure_name}) = + hcat + [text "MonadNames { return_name = " + ,ppr return_name + ,text ", pure_name = " + ,ppr pure_name + ,text "}" + ] + +-- | rearrange a list of statements using ApplicativeDoStmt. See +-- Note [ApplicativeDo]. +rearrangeForApplicativeDo + :: HsStmtContext GhcRn + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) + +rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) +rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) +rearrangeForApplicativeDo ctxt stmts0 = do + optimal_ado <- goptM Opt_OptimalApplicativeDo + let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts + | otherwise = mkStmtTreeHeuristic stmts + traceRn "rearrangeForADo" (ppr stmt_tree) + (return_name, _) <- lookupQualifiedDoName ctxt returnMName + (pure_name, _) <- lookupQualifiedDoName ctxt pureAName + let monad_names = MonadNames { return_name = return_name + , pure_name = pure_name } + stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs + where + (stmts,(last,last_fvs)) = findLast stmts0 + findLast [] = error "findLast" + findLast [last] = ([],last) + findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs + +-- | A tree of statements using a mixture of applicative and bind constructs. +data StmtTree a + = StmtTreeOne a + | StmtTreeBind (StmtTree a) (StmtTree a) + | StmtTreeApplicative [StmtTree a] + +instance Outputable a => Outputable (StmtTree a) where + ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x) + ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind") + 2 (sep [ppr x, ppr y])) + ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative") + 2 (vcat (map ppr xs))) + +flattenStmtTree :: StmtTree a -> [a] +flattenStmtTree t = go t [] + where + go (StmtTreeOne a) as = a : as + go (StmtTreeBind l r) as = go l (go r as) + go (StmtTreeApplicative ts) as = foldr go as ts + +type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) +type Cost = Int + +-- | Turn a sequence of statements into an ExprStmtTree using a +-- heuristic algorithm. /O(n^2)/ +mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree +mkStmtTreeHeuristic [one] = StmtTreeOne one +mkStmtTreeHeuristic stmts = + case segments stmts of + [one] -> split one + segs -> StmtTreeApplicative (map split segs) + where + split [one] = StmtTreeOne one + split stmts = + StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after) + where (before, after) = splitSegment stmts + +-- | Turn a sequence of statements into an ExprStmtTree optimally, +-- using dynamic programming. /O(n^3)/ +mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree +mkStmtTreeOptimal stmts = + ASSERT(not (null stmts)) -- the empty case is handled by the caller; + -- we don't support empty StmtTrees. + fst (arr ! (0,n)) + where + n = length stmts - 1 + stmt_arr = listArray (0,n) stmts + + -- lazy cache of optimal trees for subsequences of the input + arr :: Array (Int,Int) (ExprStmtTree, Cost) + arr = array ((0,0),(n,n)) + [ ((lo,hi), tree lo hi) + | lo <- [0..n] + , hi <- [lo..n] ] + + -- compute the optimal tree for the sequence [lo..hi] + tree lo hi + | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) + | otherwise = + case segments [ stmt_arr ! i | i <- [lo..hi] ] of + [] -> panic "mkStmtTree" + [_one] -> split lo hi + segs -> (StmtTreeApplicative trees, maximum costs) + where + bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs + (trees,costs) = unzip (map (uncurry split) (tail bounds)) + + -- find the best place to split the segment [lo..hi] + split :: Int -> Int -> (ExprStmtTree, Cost) + split lo hi + | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) + | otherwise = (StmtTreeBind before after, c1+c2) + where + -- As per the paper, for a sequence s1...sn, we want to find + -- the split with the minimum cost, where the cost is the + -- sum of the cost of the left and right subsequences. + -- + -- As an optimisation (also in the paper) if the cost of + -- s1..s(n-1) is different from the cost of s2..sn, we know + -- that the optimal solution is the lower of the two. Only + -- in the case that these two have the same cost do we need + -- to do the exhaustive search. + -- + ((before,c1),(after,c2)) + | hi - lo == 1 + = ((StmtTreeOne (stmt_arr ! lo), 1), + (StmtTreeOne (stmt_arr ! hi), 1)) + | left_cost < right_cost + = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) + | left_cost > right_cost + = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) + | otherwise = minimumBy (comparing cost) alternatives + where + (left, left_cost) = arr ! (lo,hi-1) + (right, right_cost) = arr ! (lo+1,hi) + cost ((_,c1),(_,c2)) = c1 + c2 + alternatives = [ (arr ! (lo,k), arr ! (k+1,hi)) + | k <- [lo .. hi-1] ] + + +-- | Turn the ExprStmtTree back into a sequence of statements, using +-- ApplicativeStmt where necessary. +stmtTreeToStmts + :: MonadNames + -> HsStmtContext GhcRn + -> ExprStmtTree + -> [ExprLStmt GhcRn] -- ^ the "tail" + -> FreeVars -- ^ free variables of the tail + -> RnM ( [ExprLStmt GhcRn] -- ( output statements, + , FreeVars ) -- , things we needed + +-- If we have a single bind, and we can do it without a join, transform +-- to an ApplicativeStmt. This corresponds to the rule +-- dsBlock [pat <- rhs] (return expr) = expr <$> rhs +-- In the spec, but we do it here rather than in the desugarer, +-- because we need the typechecker to typecheck the <$> form rather than +-- the bind form, which would give rise to a Monad constraint. +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _)) + tail _tail_fvs + | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail + -- See Note [ApplicativeDo and strict patterns] + = mkApplicativeStmt ctxt [ApplicativeArgOne + { xarg_app_arg_one = xbsrn_failOp xbs + , app_arg_pattern = pat + , arg_expr = rhs + , is_body_stmt = False + }] + False tail' +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) + tail _tail_fvs + | (False,tail') <- needJoin monad_names tail + = mkApplicativeStmt ctxt + [ApplicativeArgOne + { xarg_app_arg_one = Nothing + , app_arg_pattern = nlWildPatName + , arg_expr = rhs + , is_body_stmt = True + }] False tail' + +stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = + return (s : tail, emptyNameSet) + +stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do + (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs + let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after)) + (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs + return (stmts2, fvs1 `plusFV` fvs2) + +stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do + pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees + dflags <- getDynFlags + let (stmts', fvss) = unzip pairs + let (need_join, tail') = + -- See Note [ApplicativeDo and refutable patterns] + if any (hasRefutablePattern dflags) stmts' + then (True, tail) + else needJoin monad_names tail + + (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' + return (stmts, unionNameSets (fvs:fvss)) + where + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _)) + = return (ApplicativeArgOne + { xarg_app_arg_one = xbsrn_failOp xbs + , app_arg_pattern = pat + , arg_expr = exp + , is_body_stmt = False + }, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = + return (ApplicativeArgOne + { xarg_app_arg_one = Nothing + , app_arg_pattern = nlWildPatName + , arg_expr = exp + , is_body_stmt = True + }, emptyFVs) + stmtTreeArg ctxt tail_fvs tree = do + let stmts = flattenStmtTree tree + pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + `intersectNameSet` tail_fvs + pvars = nameSetElemsStable pvarset + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + pat = mkBigLHsVarPatTup pvars + tup = mkBigLHsVarTup pvars + (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset + (mb_ret, fvs1) <- + if | L _ ApplicativeStmt{} <- last stmts' -> + return (unLoc tup, emptyNameSet) + | otherwise -> do + (ret, _) <- lookupQualifiedDoExpr ctxt returnMName + let expr = HsApp noExtField (noLoc ret) tup + return (expr, emptyFVs) + return ( ApplicativeArgMany + { xarg_app_arg_many = noExtField + , app_stmts = stmts' + , final_expr = mb_ret + , bv_pattern = pat + , stmt_context = ctxt + } + , fvs1 `plusFV` fvs2) + + +-- | Divide a sequence of statements into segments, where no segment +-- depends on any variables defined by a statement in another segment. +segments + :: [(ExprLStmt GhcRn, FreeVars)] + -> [[(ExprLStmt GhcRn, FreeVars)]] +segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) + where + allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + + -- We would rather not have a segment that just has LetStmts in + -- it, so combine those with an adjacent segment where possible. + merge [] = [] + merge (seg : segs) + = case rest of + [] -> [(seg,all_lets)] + ((s,s_lets):ss) | all_lets || s_lets + -> (seg ++ s, all_lets && s_lets) : ss + _otherwise -> (seg,all_lets) : rest + where + rest = merge segs + all_lets = all (isLetStmt . fst) seg + + -- walk splits the statement sequence into segments, traversing + -- the sequence from the back to the front, and keeping track of + -- the set of free variables of the current segment. Whenever + -- this set of free variables is empty, we have a complete segment. + walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] + walk [] = [] + walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest + where (seg,rest) = chunter fvs' stmts + (_, fvs') = stmtRefs stmt fvs + + chunter _ [] = ([], []) + chunter vars ((stmt,fvs) : rest) + | not (isEmptyNameSet vars) + || isStrictPatternBind stmt + -- See Note [ApplicativeDo and strict patterns] + = ((stmt,fvs) : chunk, rest') + where (chunk,rest') = chunter vars' rest + (pvars, evars) = stmtRefs stmt fvs + vars' = (vars `minusNameSet` pvars) `unionNameSet` evars + chunter _ rest = ([], rest) + + stmtRefs stmt fvs + | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) + | otherwise = (pvars, fvs') + where fvs' = fvs `intersectNameSet` allvars + pvars = mkNameSet (collectStmtBinders (unLoc stmt)) + + isStrictPatternBind :: ExprLStmt GhcRn -> Bool + isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat + isStrictPatternBind _ = False + +{- +Note [ApplicativeDo and strict patterns] + +A strict pattern match is really a dependency. For example, + +do + (x,y) <- A + z <- B + return C + +The pattern (_,_) must be matched strictly before we do B. If we +allowed this to be transformed into + + (\(x,y) -> \z -> C) <$> A <*> B + +then it could be lazier than the standard desuraging using >>=. See #13875 +for more examples. + +Thus, whenever we have a strict pattern match, we treat it as a +dependency between that statement and the following one. The +dependency prevents those two statements from being performed "in +parallel" in an ApplicativeStmt, but doesn't otherwise affect what we +can do with the rest of the statements in the same "do" expression. +-} + +isStrictPattern :: LPat (GhcPass p) -> Bool +isStrictPattern lpat = + case unLoc lpat of + WildPat{} -> False + VarPat{} -> False + LazyPat{} -> False + AsPat _ _ p -> isStrictPattern p + ParPat _ p -> isStrictPattern p + ViewPat _ _ p -> isStrictPattern p + SigPat _ p _ -> isStrictPattern p + BangPat{} -> True + ListPat{} -> True + TuplePat{} -> True + SumPat{} -> True + ConPat{} -> True + LitPat{} -> True + NPat{} -> True + NPlusKPat{} -> True + SplicePat{} -> True + XPat{} -> panic "isStrictPattern: XPat" + +{- +Note [ApplicativeDo and refutable patterns] + +Refutable patterns in do blocks are desugared to use the monadic 'fail' operation. +This means that sometimes an applicative block needs to be wrapped in 'join' simply because +of a refutable pattern, in order for the types to work out. + +-} + +hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool +hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat + , is_body_stmt = False}) = + not (isIrrefutableHsPat dflags pat) +hasRefutablePattern _ _ = False + +isLetStmt :: LStmt a b -> Bool +isLetStmt (L _ LetStmt{}) = True +isLetStmt _ = False + +-- | Find a "good" place to insert a bind in an indivisible segment. +-- This is the only place where we use heuristics. The current +-- heuristic is to peel off the first group of independent statements +-- and put the bind after those. +splitSegment + :: [(ExprLStmt GhcRn, FreeVars)] + -> ( [(ExprLStmt GhcRn, FreeVars)] + , [(ExprLStmt GhcRn, FreeVars)] ) +splitSegment [one,two] = ([one],[two]) + -- there is no choice when there are only two statements; this just saves + -- some work in a common case. +splitSegment stmts + | Just (lets,binds,rest) <- slurpIndependentStmts stmts + = if not (null lets) + then (lets, binds++rest) + else (lets++binds, rest) + | otherwise + = case stmts of + (x:xs) -> ([x],xs) + _other -> (stmts,[]) + +slurpIndependentStmts + :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) +slurpIndependentStmts stmts = go [] [] emptyNameSet stmts + where + -- If we encounter a BindStmt that doesn't depend on a previous BindStmt + -- in this group, then add it to the group. We have to be careful about + -- strict patterns though; splitSegments expects that if we return Just + -- then we have actually done some splitting. Otherwise it will go into + -- an infinite loop (#14163). + go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest) + | disjointNameSet bndrs fvs && not (isStrictPattern pat) + = go lets ((L loc (BindStmt xbs pat body), fvs) : indep) + bndrs' rest + where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) + -- If we encounter a LetStmt that doesn't depend on a BindStmt in this + -- group, then move it to the beginning, so that it doesn't interfere with + -- grouping more BindStmts. + -- TODO: perhaps we shouldn't do this if there are any strict bindings, + -- because we might be moving evaluation earlier. + go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest) + | disjointNameSet bndrs fvs + = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest + go _ [] _ _ = Nothing + go _ [_] _ _ = Nothing + go lets indep _ stmts = Just (reverse lets, reverse indep, stmts) + +-- | Build an ApplicativeStmt, and strip the "return" from the tail +-- if necessary. +-- +-- For example, if we start with +-- do x <- E1; y <- E2; return (f x y) +-- then we get +-- do (E1[x] | E2[y]); f x y +-- +-- the LastStmt in this case has the return removed, but we set the +-- flag on the LastStmt to indicate this, so that we can print out the +-- original statement correctly in error messages. It is easier to do +-- it this way rather than try to ignore the return later in both the +-- typechecker and the desugarer (I tried it that way first!). +mkApplicativeStmt + :: HsStmtContext GhcRn + -> [ApplicativeArg GhcRn] -- ^ The args + -> Bool -- ^ True <=> need a join + -> [ExprLStmt GhcRn] -- ^ The body statements + -> RnM ([ExprLStmt GhcRn], FreeVars) +mkApplicativeStmt ctxt args need_join body_stmts + = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName ctxt fmapName + ; (ap_op, fvs2) <- lookupQualifiedDoStmtName ctxt apAName + ; (mb_join, fvs3) <- + if need_join then + do { (join_op, fvs) <- lookupQualifiedDoStmtName ctxt joinMName + ; return (Just join_op, fvs) } + else + return (Nothing, emptyNameSet) + ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField + (zip (fmap_op : repeat ap_op) args) + mb_join + ; return ( applicative_stmt : body_stmts + , fvs1 `plusFV` fvs2 `plusFV` fvs3) } + +-- | Given the statements following an ApplicativeStmt, determine whether +-- we need a @join@ or not, and remove the @return@ if necessary. +needJoin :: MonadNames + -> [ExprLStmt GhcRn] + -> (Bool, [ExprLStmt GhcRn]) +needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg +needJoin monad_names [L loc (LastStmt _ e _ t)] + | Just (arg, wasDollar) <- isReturnApp monad_names e = + (False, [L loc (LastStmt noExtField arg (Just wasDollar) t)]) +needJoin _monad_names stmts = (True, stmts) + +-- | @(Just e, False)@, if the expression is @return e@ +-- @(Just e, True)@ if the expression is @return $ e@, +-- otherwise @Nothing@. +isReturnApp :: MonadNames + -> LHsExpr GhcRn + -> Maybe (LHsExpr GhcRn, Bool) +isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr +isReturnApp monad_names (L _ e) = case e of + OpApp _ l op r | is_return l, is_dollar op -> Just (r, True) + HsApp _ f arg | is_return f -> Just (arg, False) + _otherwise -> Nothing + where + is_var f (L _ (HsPar _ e)) = is_var f e + is_var f (L _ (HsAppType _ e _)) = is_var f e + is_var f (L _ (HsVar _ (L _ r))) = f r + -- TODO: I don't know how to get this right for rebindable syntax + is_var _ _ = False + + is_return = is_var (\n -> n == return_name monad_names + || n == pure_name monad_names) + is_dollar = is_var (`hasKey` dollarIdKey) + +{- +************************************************************************ +* * +\subsubsection{Errors} +* * +************************************************************************ +-} + +checkEmptyStmts :: HsStmtContext GhcRn -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) + +okEmpty :: HsStmtContext a -> Bool +okEmpty (PatGuard {}) = True +okEmpty _ = False + +emptyErr :: HsStmtContext GhcRn -> SDoc +emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" +emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" +emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt + +---------------------- +checkLastStmt :: Outputable (body GhcPs) => HsStmtContext GhcRn + -> LStmt GhcPs (Located (body GhcPs)) + -> RnM (LStmt GhcPs (Located (body GhcPs))) +checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + ListComp -> check_comp + MonadComp -> check_comp + ArrowExpr -> check_do + DoExpr{} -> check_do + MDoExpr{} -> check_do + _ -> check_other + where + check_do -- Expect BodyStmt, and change it to LastStmt + = case stmt of + BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + last_error = (text "The last statement in" <+> pprAStmtContext ctxt + <+> text "must be an expression") + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) + + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } + +-- Checking when a particular Stmt is ok +checkStmt :: HsStmtContext GhcRn + -> LStmt GhcPs (Located (body GhcPs)) + -> RnM () +checkStmt ctxt (L _ stmt) + = do { dflags <- getDynFlags + ; case okStmt dflags ctxt stmt of + IsValid -> return () + NotValid extra -> addErr (msg $$ extra) } + where + msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") + , text "in" <+> pprAStmtContext ctxt ] + +pprStmtCat :: Stmt (GhcPass a) body -> SDoc +pprStmtCat (TransStmt {}) = text "transform" +pprStmtCat (LastStmt {}) = text "return expression" +pprStmtCat (BodyStmt {}) = text "body" +pprStmtCat (BindStmt {}) = text "binding" +pprStmtCat (LetStmt {}) = text "let" +pprStmtCat (RecStmt {}) = text "rec" +pprStmtCat (ParStmt {}) = text "parallel" +pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" + +------------ +emptyInvalid :: Validity -- Payload is the empty document +emptyInvalid = NotValid Outputable.empty + +okStmt, okDoStmt, okCompStmt, okParStmt + :: DynFlags -> HsStmtContext GhcRn + -> Stmt GhcPs (Located (body GhcPs)) -> Validity +-- Return Nothing if OK, (Just extra) if not ok +-- The "extra" is an SDoc that is appended to a generic error message + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr{} -> okDoStmt dflags ctxt stmt + MDoExpr{} -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmtCtxt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + +------------- +okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity +okPatGuardStmt stmt + = case stmt of + BodyStmt {} -> IsValid + BindStmt {} -> IsValid + LetStmt {} -> IsValid + _ -> emptyInvalid + +------------- +okParStmt dflags ctxt stmt + = case stmt of + LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid + _ -> okStmt dflags ctxt stmt + +---------------- +okDoStmt dflags ctxt stmt + = case stmt of + RecStmt {} + | LangExt.RecursiveDo `xopt` dflags -> IsValid + | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' + | otherwise -> NotValid (text "Use RecursiveDo") + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + _ -> emptyInvalid + +---------------- +okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + ParStmt {} + | LangExt.ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (text "Use ParallelListComp") + TransStmt {} + | LangExt.TransformListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (text "Use TransformListComp") + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) + ApplicativeStmt {} -> emptyInvalid + +--------- +checkTupleSection :: [LHsTupArg GhcPs] -> RnM () +checkTupleSection args + = do { tuple_section <- xoptM LangExt.TupleSections + ; checkErr (all tupArgPresent args || tuple_section) msg } + where + msg = text "Illegal tuple section: use TupleSections" + +--------- +sectionErr :: HsExpr GhcPs -> SDoc +sectionErr expr + = hang (text "A section must be enclosed in parentheses") + 2 (text "thus:" <+> (parens (ppr expr))) + +badIpBinds :: Outputable a => SDoc -> a -> SDoc +badIpBinds what binds + = hang (text "Implicit-parameter bindings illegal in" <+> what) + 2 (ppr binds) + +--------- + +monadFailOp :: LPat GhcPs + -> HsStmtContext GhcRn + -> RnM (FailOperator GhcRn, FreeVars) +monadFailOp pat ctxt = do + dflags <- getDynFlags + -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) + -- we should not need to fail. + if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs) + + -- For non-monadic contexts (e.g. guard patterns, list + -- comprehensions, etc.) we should not need to fail, or failure is handled in + -- a different way. See Note [Failing pattern matches in Stmts]. + | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs) + + | otherwise -> getMonadFailOp ctxt + +{- +Note [Monad fail : Rebindable syntax, overloaded strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given the code + foo x = do { Just y <- x; return y } + +we expect it to desugar as + foo x = x >>= \r -> case r of + Just y -> return y + Nothing -> fail "Pattern match error" + +But with RebindableSyntax and OverloadedStrings, we really want +it to desugar thus: + foo x = x >>= \r -> case r of + Just y -> return y + Nothing -> fail (fromString "Patterm match error") + +So, in this case, we synthesize the function + \x -> fail (fromString x) + +(rather than plain 'fail') for the 'fail' operation. This is done in +'getMonadFailOp'. + +Similarly with QualifiedDo and OverloadedStrings, we also want to desugar +using fromString: + + foo x = M.do { Just y <- x; return y } + + ===> + + foo x = x M.>>= \r -> case r of + Just y -> return y + Nothing -> M.fail (fromString "Pattern match error") + +-} +getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op +getMonadFailOp ctxt + = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags + ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags + ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings + ; return (Just fail, fvs) + } + where + isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt) + + reallyGetMonadFailOp rebindableSyntax overloadedStrings + | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do + (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName + (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName + let arg_lit = mkVarOcc "arg" + arg_name <- newSysName arg_lit + let arg_syn_expr = nlHsVar arg_name + body :: LHsExpr GhcRn = + nlHsApp (noLoc failExpr) + (nlHsApp (noLoc $ fromStringExpr) arg_syn_expr) + let failAfterFromStringExpr :: HsExpr GhcRn = + unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body + let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = + mkSyntaxExpr failAfterFromStringExpr + return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) + | otherwise = lookupQualifiedDo ctxt failMName + +-- Rebinding 'if's to 'ifThenElse' applications. +-- +-- See Note [Rebindable syntax and HsExpansion] +rebindIf + :: Located Name -- 'Name' for the 'ifThenElse' function we will rebind to + -> LHsExpr GhcRn -- renamed condition + -> LHsExpr GhcRn -- renamed true branch + -> LHsExpr GhcRn -- renamed false branch + -> HsExpr GhcRn -- rebound if expression +rebindIf ifteName p b1 b2 = + let ifteOrig = HsIf noExtField p b1 b2 + ifteFun = L generatedSrcSpan (HsVar noExtField ifteName) + -- ifThenElse var + ifteApp = mkHsAppsWith (\_ _ e -> L generatedSrcSpan e) + ifteFun + [p, b1, b2] + -- desugared_if_expr = + -- ifThenElse desugared_predicate + -- desugared_true_branch + -- desugared_false_branch + in mkExpanded XExpr ifteOrig (unLoc ifteApp) + -- (source_if_expr, desugared_if_expr) diff --git a/GHC/Rename/Expr.hs-boot b/GHC/Rename/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Rename/Expr.hs-boot @@ -0,0 +1,17 @@ +module GHC.Rename.Expr where +import GHC.Types.Name +import GHC.Hs +import GHC.Types.Name.Set ( FreeVars ) +import GHC.Tc.Types +import GHC.Types.SrcLoc ( Located ) +import GHC.Utils.Outputable ( Outputable ) + +rnLExpr :: LHsExpr GhcPs + -> RnM (LHsExpr GhcRn, FreeVars) + +rnStmts :: --forall thing body. + Outputable (body GhcPs) => HsStmtContext GhcRn + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) diff --git a/GHC/Rename/Fixity.hs b/GHC/Rename/Fixity.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Fixity.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE ViewPatterns #-} + +{- + +This module contains code which maintains and manipulates the +fixity environment during renaming. + +-} +module GHC.Rename.Fixity + ( MiniFixityEnv + , addLocalFixities + , lookupFixityRn + , lookupFixityRn_help + , lookupFieldFixityRn + , lookupTyFixityRn + ) +where + +import GHC.Prelude + +import GHC.Iface.Load +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Driver.Types +import GHC.Tc.Utils.Monad +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Unit.Module +import GHC.Types.Basic ( Fixity(..), FixityDirection(..), minPrecedence, + defaultFixity, SourceText(..) ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.Maybe +import Data.List +import Data.Function ( on ) +import GHC.Rename.Unbound + +{- +********************************************************* +* * + Fixities +* * +********************************************************* + +Note [Fixity signature lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fixity declaration like + + infixr 2 ? + +can refer to a value-level operator, e.g.: + + (?) :: String -> String -> String + +or a type-level operator, like: + + data (?) a b = A a | B b + +so we extend the lookup of the reader name '?' to the TcClsName namespace, as +well as the original namespace. + +The extended lookup is also used in other places, like resolution of +deprecation declarations, and lookup of names in GHCi. +-} + +-------------------------------- +type MiniFixityEnv = FastStringEnv (Located Fixity) + -- Mini fixity env for the names we're about + -- to bind, in a single binding group + -- + -- It is keyed by the *FastString*, not the *OccName*, because + -- the single fixity decl infix 3 T + -- affects both the data constructor T and the type constructor T + -- + -- We keep the location so that if we find + -- a duplicate, we can report it sensibly + +-------------------------------- +-- Used for nested fixity decls to bind names along with their fixities. +-- the fixities are given as a UFM from an OccName's FastString to a fixity decl + +addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a +addLocalFixities mini_fix_env names thing_inside + = extendFixityEnv (mapMaybe find_fixity names) thing_inside + where + find_fixity name + = case lookupFsEnv mini_fix_env (occNameFS occ) of + Just lfix -> Just (name, FixItem occ (unLoc lfix)) + Nothing -> Nothing + where + occ = nameOccName name + +{- +-------------------------------- +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with GHC.Rename.Names.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment +-} + +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name = lookupFixityRn' name (nameOccName name) + +lookupFixityRn' :: Name -> OccName -> RnM Fixity +lookupFixityRn' name = fmap snd . lookupFixityRn_help' name + +-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' +-- in a local environment or from an interface file. Otherwise, it returns +-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without +-- user-supplied fixity declarations). +lookupFixityRn_help :: Name + -> RnM (Bool, Fixity) +lookupFixityRn_help name = + lookupFixityRn_help' name (nameOccName name) + +lookupFixityRn_help' :: Name + -> OccName + -> RnM (Bool, Fixity) +lookupFixityRn_help' name occ + | isUnboundName name + = return (False, Fixity NoSourceText minPrecedence InfixL) + -- Minimise errors from ubound names; eg + -- a>0 `foo` b>0 + -- where 'foo' is not in scope, should not give an error (#7937) + + | otherwise + = do { local_fix_env <- getFixityEnv + ; case lookupNameEnv local_fix_env name of { + Just (FixItem _ fix) -> return (True, fix) ; + Nothing -> + + do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + -- Local (and interactive) names are all in the + -- fixity env, and don't have entries in the HPT + then return (False, defaultFixity) + else lookup_imported } } } + where + lookup_imported + -- For imported names, we have to get their fixities by doing a + -- loadInterfaceForName, and consulting the Ifaces that comes back + -- from that, because the interface file for the Name might not + -- have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- nothing from B will be used). When we come across a use of + -- 'f', we need to know its fixity, and it's then, and only + -- then, that we load B.hi. That is what's happening here. + -- + -- loadInterfaceForName will find B.hi even if B is a hidden module, + -- and that's what we want. + = do { iface <- loadInterfaceForName doc name + ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ + ; let msg = case mb_fix of + Nothing -> + text "looking up name" <+> ppr name + <+> text "in iface, but found no fixity for it." + <+> text "Using default fixity instead." + Just f -> + text "looking up name in iface and found:" + <+> vcat [ppr name, ppr f] + ; traceRn "lookupFixityRn_either:" msg + ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } + + doc = text "Checking fixity for" <+> ppr name + +--------------- +lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn = lookupFixityRn . unLoc + +-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field +-- selector. We use 'lookupFixityRn'' so that we can specify the 'OccName' as +-- the field label, which might be different to the 'OccName' of the selector +-- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are +-- multiple possible selectors with different fixities, generate an error. +lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity +lookupFieldFixityRn (Unambiguous n lrdr) + = lookupFixityRn' n (rdrNameOcc (unLoc lrdr)) +lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr) + where + get_ambiguous_fixity :: RdrName -> RnM Fixity + get_ambiguous_fixity rdr_name = do + traceRn "get_ambiguous_fixity" (ppr rdr_name) + rdr_env <- getGlobalRdrEnv + let elts = lookupGRE_RdrName rdr_name rdr_env + + fixities <- groupBy ((==) `on` snd) . zip elts + <$> mapM lookup_gre_fixity elts + + case fixities of + -- There should always be at least one fixity. + -- Something's very wrong if there are no fixity candidates, so panic + [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" + [ (_, fix):_ ] -> return fix + ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) + >> return (Fixity NoSourceText minPrecedence InfixL) + + lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) + + ambiguous_fixity_err rn ambigs + = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) + , hang (text "Conflicts: ") 2 . vcat . + map format_ambig $ concat ambigs ] + + format_ambig (elt, fix) = hang (ppr fix) + 2 (pprNameProvenance elt) diff --git a/GHC/Rename/HsType.hs b/GHC/Rename/HsType.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/HsType.hs @@ -0,0 +1,1926 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Rename.HsType ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsKind, rnLHsKind, rnLHsTypeArgs, + rnHsSigType, rnHsWcType, + HsSigWcTypeScoping(..), rnHsSigWcType, rnHsPatSigType, + newTyVarNameRn, + rnConDeclFields, + rnLTyVar, + + rnScaledLHsType, + + -- Precence related stuff + NegationHandling(..), + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, + + -- Binding related stuff + bindHsForAllTelescope, + bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), + rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars, + FreeKiTyVars, + extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, + extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars, + extractHsTvBndrs, extractHsTyArgRdrKiTyVars, + extractHsScaledTysRdrTyVars, + forAllOrNothing, nubL + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) + +import GHC.Driver.Session +import GHC.Hs +import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext + , mapFvRn, pprHsDocContext, bindLocalNamesFV + , typeAppErr, newLocalBndrRn, checkDupRdrNames + , checkShadowedRdrNames ) +import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn + , lookupTyFixityRn ) +import GHC.Tc.Utils.Monad +import GHC.Types.Name.Reader +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim ( funTyConName ) +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Name.Set +import GHC.Types.FieldLabel + +import GHC.Utils.Misc +import GHC.Types.Basic ( compareFixity, funTyFixity, negateFixity + , Fixity(..), FixityDirection(..), LexicalFixity(..) + , TypeOrKind(..) ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ( nubBy, partition ) +import Control.Monad ( unless, when ) + +#include "HsVersions.h" + +{- +These type renamers are in a separate module, rather than in (say) GHC.Rename.Module, +to break several loops. + +********************************************************* +* * + HsSigWcType and HsPatSigType (i.e with wildcards) +* * +********************************************************* +-} + +data HsSigWcTypeScoping + = AlwaysBind + -- ^ Always bind any free tyvars of the given type, regardless of whether we + -- have a forall at the top. + -- + -- For pattern type sigs, we /do/ want to bring those type + -- variables into scope, even if there's a forall at the top which usually + -- stops that happening, e.g: + -- + -- > \ (x :: forall a. a -> b) -> e + -- + -- Here we do bring 'b' into scope. + -- + -- RULES can also use 'AlwaysBind', such as in the following example: + -- + -- > {-# RULES \"f\" forall (x :: forall a. a -> b). f x = ... b ... #-} + -- + -- This only applies to RULES that do not explicitly bind their type + -- variables. If a RULE explicitly quantifies its type variables, then + -- 'NeverBind' is used instead. See also + -- @Note [Pattern signature binders and scoping]@ in "GHC.Hs.Type". + | BindUnlessForall + -- ^ Unless there's forall at the top, do the same thing as 'AlwaysBind'. + -- This is only ever used in places where the \"@forall@-or-nothing\" rule + -- is in effect. See @Note [forall-or-nothing rule]@. + | NeverBind + -- ^ Never bind any free tyvars. This is used for RULES that have both + -- explicit type and term variable binders, e.g.: + -- + -- > {-# RULES \"const\" forall a. forall (x :: a) y. const x y = x #-} + -- + -- The presence of the type variable binder @forall a.@ implies that the + -- free variables in the types of the term variable binders @x@ and @y@ + -- are /not/ bound. In the example above, there are no such free variables, + -- but if the user had written @(y :: b)@ instead of @y@ in the term + -- variable binders, then @b@ would be rejected for being out of scope. + -- See also @Note [Pattern signature binders and scoping]@ in + -- "GHC.Hs.Type". + +rnHsSigWcType :: HsDocContext + -> LHsSigWcType GhcPs + -> RnM (LHsSigWcType GhcRn, FreeVars) +rnHsSigWcType doc (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) + = rn_hs_sig_wc_type BindUnlessForall doc hs_ty $ \nwcs imp_tvs body -> + let ib_ty = HsIB { hsib_ext = imp_tvs, hsib_body = body } + wc_ty = HsWC { hswc_ext = nwcs, hswc_body = ib_ty } in + pure (wc_ty, emptyFVs) + +rnHsPatSigType :: HsSigWcTypeScoping + -> HsDocContext + -> HsPatSigType GhcPs + -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Used for +-- - Pattern type signatures, which are only allowed with ScopedTypeVariables +-- - Signatures on binders in a RULE, which are allowed even if +-- ScopedTypeVariables isn't enabled +-- Wildcards are allowed +-- +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +rnHsPatSigType scoping ctx sig_ty thing_inside + = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables + ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty) + ; rn_hs_sig_wc_type scoping ctx (hsPatSigType sig_ty) $ + \nwcs imp_tvs body -> + do { let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs } + sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = body } + ; thing_inside sig_ty' + } } + +-- The workhorse for rnHsSigWcType and rnHsPatSigType. +rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext + -> LHsType GhcPs + -> ([Name] -- Wildcard names + -> [Name] -- Implicitly bound type variable names + -> LHsType GhcRn + -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rn_hs_sig_wc_type scoping ctxt hs_ty thing_inside + = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty) + ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars + ; let nwc_rdrs = nubL nwc_rdrs' + ; implicit_bndrs <- case scoping of + AlwaysBind -> pure tv_rdrs + BindUnlessForall -> forAllOrNothing (isLHsForAllTy hs_ty) tv_rdrs + NeverBind -> pure [] + ; rnImplicitBndrs Nothing implicit_bndrs $ \ vars -> + do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty + ; (res, fvs2) <- thing_inside wcs vars hs_ty' + ; return (res, fvs1 `plusFV` fvs2) } } + +rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) +rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) + = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty) + ; (nwc_rdrs', _) <- partition_nwcs free_vars + ; let nwc_rdrs = nubL nwc_rdrs' + ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } + ; return (sig_ty', fvs) } + +rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) +rnWcBody ctxt nwc_rdrs hs_ty + = do { nwcs <- mapM newLocalBndrRn nwc_rdrs + ; let env = RTKE { rtke_level = TypeLevel + , rtke_what = RnTypeBody + , rtke_nwcs = mkNameSet nwcs + , rtke_ctxt = ctxt } + ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ + rn_lty env hs_ty + ; return (nwcs, hs_ty', fvs) } + where + rn_lty env (L loc hs_ty) + = setSrcSpan loc $ + do { (hs_ty', fvs) <- rn_ty env hs_ty + ; return (L loc hs_ty', fvs) } + + rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + -- A lot of faff just to allow the extra-constraints wildcard to appear + rn_ty env (HsForAllTy { hst_tele = tele, hst_body = hs_body }) + = bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> + do { (hs_body', fvs) <- rn_lty env hs_body + ; return (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele', hst_body = hs_body' } + , fvs) } + + rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt + , hst_body = hs_ty }) + | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 + ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + | otherwise + = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt' + , hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + rn_ty env hs_ty = rnHsTyKi env hs_ty + + rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) + + +checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM () +-- Rename the extra-constraint spot in a type signature +-- (blah, _) => type +-- Check that extra-constraints are allowed at all, and +-- if so that it's an anonymous wildcard +checkExtraConstraintWildCard env hs_ctxt + = checkWildCard env mb_bad + where + mb_bad | not (extraConstraintWildCardsAllowed env) + = Just base_msg + -- Currently, we do not allow wildcards in their full glory in + -- standalone deriving declarations. We only allow a single + -- extra-constraints wildcard à la: + -- + -- deriving instance _ => Eq (Foo a) + -- + -- i.e., we don't support things like + -- + -- deriving instance (Eq a, _) => Eq (Foo a) + | DerivDeclCtx {} <- rtke_ctxt env + , not (null hs_ctxt) + = Just deriv_decl_msg + | otherwise + = Nothing + + base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard + <+> text "not allowed" + + deriv_decl_msg + = hang base_msg + 2 (vcat [ text "except as the sole constraint" + , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]) + +extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool +extraConstraintWildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + ExprWithTySigCtx {} -> True + DerivDeclCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls" + _ -> False + +-- | When the NamedWildCards extension is enabled, partition_nwcs +-- removes type variables that start with an underscore from the +-- FreeKiTyVars in the argument and returns them in a separate list. +-- When the extension is disabled, the function returns the argument +-- and empty list. See Note [Renaming named wild cards] +partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars) +partition_nwcs free_vars + = do { wildcards_enabled <- xoptM LangExt.NamedWildCards + ; return $ + if wildcards_enabled + then partition is_wildcard free_vars + else ([], free_vars) } + where + is_wildcard :: Located RdrName -> Bool + is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) + +{- Note [Renaming named wild cards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Identifiers starting with an underscore are always parsed as type variables. +It is only here in the renamer that we give the special treatment. +See Note [The wildcard story for types] in GHC.Hs.Type. + +It's easy! When we collect the implicitly bound type variables, ready +to bring them into scope, and NamedWildCards is on, we partition the +variables into the ones that start with an underscore (the named +wildcards) and the rest. Then we just add them to the hswc_wcs field +of the HsWildCardBndrs structure, and we are done. + + +********************************************************* +* * + HsSigtype (i.e. no wildcards) +* * +****************************************************** -} + +rnHsSigType :: HsDocContext + -> TypeOrKind + -> LHsSigType GhcPs + -> RnM (LHsSigType GhcRn, FreeVars) +-- Used for source-language type signatures +-- that cannot have wildcards +rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) + = do { traceRn "rnHsSigType" (ppr hs_ty) + ; rdr_env <- getLocalRdrEnv + ; vars0 <- forAllOrNothing (isLHsForAllTy hs_ty) + $ filterInScope rdr_env + $ extractHsTyRdrTyVars hs_ty + ; rnImplicitBndrs Nothing vars0 $ \ vars -> + do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty + + ; return ( HsIB { hsib_ext = vars + , hsib_body = body' } + , fvs ) } } + +-- Note [forall-or-nothing rule] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Free variables in signatures are usually bound in an implicit +-- 'forall' at the beginning of user-written signatures. However, if the +-- signature has an explicit forall at the beginning, this is disabled. +-- +-- The idea is nested foralls express something which is only +-- expressible explicitly, while a top level forall could (usually) be +-- replaced with an implicit binding. Top-level foralls alone ("forall.") are +-- therefore an indication that the user is trying to be fastidious, so +-- we don't implicitly bind any variables. + +-- | See @Note [forall-or-nothing rule]@. This tiny little function is used +-- (rather than its small body inlined) to indicate that we are implementing +-- that rule. +forAllOrNothing :: Bool + -- ^ True <=> explicit forall + -- E.g. f :: forall a. a->b + -- we do not want to bring 'b' into scope, hence True + -- But f :: a -> b + -- we want to bring both 'a' and 'b' into scope, hence False + -> FreeKiTyVars + -- ^ Free vars of the type + -> RnM FreeKiTyVars +forAllOrNothing has_outer_forall fvs = case has_outer_forall of + True -> do + traceRn "forAllOrNothing" $ text "has explicit outer forall" + pure [] + False -> do + traceRn "forAllOrNothing" $ text "no explicit forall. implicit binders:" <+> ppr fvs + pure fvs + +rnImplicitBndrs :: Maybe assoc + -- ^ @'Just' _@ => an associated type decl + -> FreeKiTyVars + -- ^ Surface-syntax free vars that we will implicitly bind. + -- May have duplicates, which are removed here. + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnImplicitBndrs mb_assoc implicit_vs_with_dups thing_inside + = do { let implicit_vs = nubL implicit_vs_with_dups + + ; traceRn "rnImplicitBndrs" $ + vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ] + + -- Use the currently set SrcSpan as the new source location for each Name. + -- See Note [Source locations for implicitly bound type variables]. + ; loc <- getSrcSpanM + ; vars <- mapM (newTyVarNameRn mb_assoc . L loc . unLoc) implicit_vs + + ; bindLocalNamesFV vars $ + thing_inside vars } + +{- +Note [Source locations for implicitly bound type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When bringing implicitly bound type variables into scope (in rnImplicitBndrs), +we do something peculiar: we drop the original SrcSpan attached to each +variable and replace it with the currently set SrcSpan. Moreover, this new +SrcSpan is usually /less/ precise than the original one, and that's OK. To see +why this is done, consider the following example: + + f :: a -> b -> a + +Suppose that a warning or error message needs to point to the SrcSpans of the +binding sites for `a` and `b`. But where /are/ they bound, anyway? Technically, +they're bound by an unwritten `forall` at the front of the type signature, but +there is no SrcSpan for that. We could point to the first occurrence of `a` as +the binding site for `a`, but that would make the first occurrence of `a` +special. Moreover, we don't want IDEs to confuse binding sites and occurrences. + +As a result, we make the `SrcSpan`s for `a` and `b` span the entirety of the +type signature, since the type signature implicitly carries their binding +sites. This is less precise, but more accurate. +-} + +{- ****************************************************** +* * + LHsType and HsType +* * +****************************************************** -} + +{- +rnHsType is here because we call it from loadInstDecl, and I didn't +want a gratuitous knot. + +Note [QualTy in kinds] +~~~~~~~~~~~~~~~~~~~~~~ +I was wondering whether QualTy could occur only at TypeLevel. But no, +we can have a qualified type in a kind too. Here is an example: + + type family F a where + F Bool = Nat + F Nat = Type + + type family G a where + G Type = Type -> Type + G () = Nat + + data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where + MkX :: X 'True '() + +See that k1 becomes Bool and k2 becomes (), so the equality is +satisfied. If I write MkX :: X 'True 'False, compilation fails with a +suitable message: + + MkX :: X 'True '() + • Couldn't match kind ‘G Bool’ with ‘Nat’ + Expected kind: G Bool + Actual kind: F Bool + +However: in a kind, the constraints in the QualTy must all be +equalities; or at least, any kinds with a class constraint are +uninhabited. +-} + +data RnTyKiEnv + = RTKE { rtke_ctxt :: HsDocContext + , rtke_level :: TypeOrKind -- Am I renaming a type or a kind? + , rtke_what :: RnTyKiWhat -- And within that what am I renaming? + , rtke_nwcs :: NameSet -- These are the in-scope named wildcards + } + +data RnTyKiWhat = RnTypeBody + | RnTopConstraint -- Top-level context of HsSigWcTypes + | RnConstraint -- All other constraints + +instance Outputable RnTyKiEnv where + ppr (RTKE { rtke_level = lev, rtke_what = what + , rtke_nwcs = wcs, rtke_ctxt = ctxt }) + = text "RTKE" + <+> braces (sep [ ppr lev, ppr what, ppr wcs + , pprHsDocContext ctxt ]) + +instance Outputable RnTyKiWhat where + ppr RnTypeBody = text "RnTypeBody" + ppr RnTopConstraint = text "RnTopConstraint" + ppr RnConstraint = text "RnConstraint" + +mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv +mkTyKiEnv cxt level what + = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet + , rtke_what = what, rtke_ctxt = cxt } + +isRnKindLevel :: RnTyKiEnv -> Bool +isRnKindLevel (RTKE { rtke_level = KindLevel }) = True +isRnKindLevel _ = False + +-------------- +rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys + +rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs) + -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars) +rnScaledLHsType doc (HsScaled w ty) = do + (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w + (ty', fvs) <- rnLHsType doc ty + return (HsScaled w' ty', fvs `plusFV` fvs_w) + + +rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) +rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) +rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind + +rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) +rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind + +-- renaming a type only, not a kind +rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs + -> RnM (LHsTypeArg GhcRn, FreeVars) +rnLHsTypeArg ctxt (HsValArg ty) + = do { (tys_rn, fvs) <- rnLHsType ctxt ty + ; return (HsValArg tys_rn, fvs) } +rnLHsTypeArg ctxt (HsTypeArg l ki) + = do { (kis_rn, fvs) <- rnLHsKind ctxt ki + ; return (HsTypeArg l kis_rn, fvs) } +rnLHsTypeArg _ (HsArgPar sp) + = return (HsArgPar sp, emptyFVs) + +rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs] + -> RnM ([LHsTypeArg GhcRn], FreeVars) +rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args + +-------------- +rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnTyKiContext env (L loc cxt) + = do { traceRn "rncontext" (ppr cxt) + ; let env' = env { rtke_what = RnConstraint } + ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt + ; return (L loc cxt', fvs) } + +rnContext :: HsDocContext -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta + +-------------- +rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsTyKi env (L loc ty) + = setSrcSpan loc $ + do { (ty', fvs) <- rnHsTyKi env ty + ; return (L loc ty', fvs) } + +rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + +rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau }) + = do { checkPolyKinds env ty + ; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> + do { (tau', fvs) <- rnLHsTyKi env tau + ; return ( HsForAllTy { hst_xforall = noExtField + , hst_tele = tele' , hst_body = tau' } + , fvs) } } + +rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) + = do { checkPolyKinds env ty -- See Note [QualTy in kinds] + ; (ctxt', fvs1) <- rnTyKiContext env lctxt + ; (tau', fvs2) <- rnLHsTyKi env tau + ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' + , hst_body = tau' } + , fvs1 `plusFV` fvs2) } + +rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) + = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ + unlessXOptM LangExt.PolyKinds $ addErr $ + withHsDocContext (rtke_ctxt env) $ + vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) + , text "Perhaps you intended to use PolyKinds" ] + -- Any type variable at the kind level is illegal without the use + -- of PolyKinds (see #14710) + ; name <- rnTyVar env rdr_name + ; return (HsTyVar noExtField ip (L loc name), unitFV name) } + +rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) + = setSrcSpan (getLoc l_op) $ + do { (l_op', fvs1) <- rnHsTyOp env ty l_op + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs2) <- rnLHsTyKi env ty1 + ; (ty2', fvs3) <- rnLHsTyKi env ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2) + (unLoc l_op') fix ty1' ty2' + ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } + +rnHsTyKi env (HsParTy _ ty) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; return (HsParTy noExtField ty', fvs) } + +rnHsTyKi env (HsBangTy _ b ty) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; return (HsBangTy noExtField b ty', fvs) } + +rnHsTyKi env ty@(HsRecTy _ flds) + = do { let ctxt = rtke_ctxt env + ; fls <- get_fields ctxt + ; (flds', fvs) <- rnConDeclFields ctxt fls flds + ; return (HsRecTy noExtField flds', fvs) } + where + get_fields (ConDeclCtx names) + = concatMapM (lookupConstructorFields . unLoc) names + get_fields _ + = do { addErr (hang (text "Record syntax is illegal here:") + 2 (ppr ty)) + ; return [] } + +rnHsTyKi env (HsFunTy u mult ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi env ty1 + -- Might find a for-all as the arg of a function type + ; (ty2', fvs2) <- rnLHsTyKi env ty2 + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a + + -- Check for fixity rearrangements + ; (mult', w_fvs) <- rnHsArrow env mult + ; res_ty <- mkHsOpTyRn (hs_fun_ty mult') funTyConName funTyFixity ty1' ty2' + ; return (res_ty, fvs1 `plusFV` fvs2 `plusFV` w_fvs) } + where + hs_fun_ty w a b = HsFunTy u w a b + +rnHsTyKi env listTy@(HsListTy _ ty) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env listTy)) + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsListTy noExtField ty', fvs) } + +rnHsTyKi env t@(HsKindSig _ ty k) + = do { checkPolyKinds env t + ; kind_sigs_ok <- xoptM LangExt.KindSignatures + ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) + ; (ty', lhs_fvs) <- rnLHsTyKi env ty + ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k + ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) } + +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsTupleTy noExtField tup_con tys', fvs) } + +rnHsTyKi env sumTy@(HsSumTy _ tys) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env sumTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsSumTy noExtField tys', fvs) } + +-- Ensure that a type-level integer is nonnegative (#8306, #8412) +rnHsTyKi env tyLit@(HsTyLit _ t) + = do { data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env tyLit)) + ; when (negLit t) (addErr negLitErr) + ; checkPolyKinds env tyLit + ; return (HsTyLit noExtField t, emptyFVs) } + where + negLit (HsStrTy _ _) = False + negLit (HsNumTy _ i) = i < 0 + negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit + +rnHsTyKi env (HsAppTy _ ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi env ty1 + ; (ty2', fvs2) <- rnLHsTyKi env ty2 + ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi env (HsAppKindTy l ty k) + = do { kind_app <- xoptM LangExt.TypeApplications + ; unless kind_app (addErr (typeAppErr "kind" k)) + ; (ty', fvs1) <- rnLHsTyKi env ty + ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k + ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } + +rnHsTyKi env t@(HsIParamTy _ n ty) + = do { notInKinds env t + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsIParamTy noExtField n ty', fvs) } + +rnHsTyKi _ (HsStarTy _ isUni) + = return (HsStarTy noExtField isUni, emptyFVs) + +rnHsTyKi _ (HsSpliceTy _ sp) + = rnSpliceType sp + +rnHsTyKi env (HsDocTy _ ty haddock_doc) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy noExtField ty' haddock_doc', fvs) } + +rnHsTyKi _ (XHsType (NHsCoreTy ty)) + = return (XHsType (NHsCoreTy ty), emptyFVs) + -- The emptyFVs probably isn't quite right + -- but I don't think it matters + +rnHsTyKi env ty@(HsExplicitListTy _ ip tys) + = do { checkPolyKinds env ty + ; data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env ty)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsExplicitListTy noExtField ip tys', fvs) } + +rnHsTyKi env ty@(HsExplicitTupleTy _ tys) + = do { checkPolyKinds env ty + ; data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env ty)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsExplicitTupleTy noExtField tys', fvs) } + +rnHsTyKi env (HsWildCardTy _) + = do { checkAnonWildCard env + ; return (HsWildCardTy noExtField, emptyFVs) } + +rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) +rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs) +rnHsArrow _env (HsLinearArrow u) = return (HsLinearArrow u, emptyFVs) +rnHsArrow env (HsExplicitMult u p) + = (\(mult, fvs) -> (HsExplicitMult u mult, fvs)) <$> rnLHsTyKi env p + +-------------- +rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name +rnTyVar env rdr_name + = do { name <- lookupTypeOccRn rdr_name + ; checkNamedWildCard env name + ; return name } + +rnLTyVar :: Located RdrName -> RnM (Located Name) +-- Called externally; does not deal with wildcards +rnLTyVar (L loc rdr_name) + = do { tyvar <- lookupTypeOccRn rdr_name + ; return (L loc tyvar) } + +-------------- +rnHsTyOp :: Outputable a + => RnTyKiEnv -> a -> Located RdrName + -> RnM (Located Name, FreeVars) +rnHsTyOp env overall_ty (L loc op) + = do { ops_ok <- xoptM LangExt.TypeOperators + ; op' <- rnTyVar env op + ; unless (ops_ok || op' `hasKey` eqTyConKey) $ + addErr (opTyErr op overall_ty) + ; let l_op' = L loc op' + ; return (l_op', unitFV op') } + +-------------- +notAllowed :: SDoc -> SDoc +notAllowed doc + = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") + +checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () +checkWildCard env (Just doc) + = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] +checkWildCard _ Nothing + = return () + +checkAnonWildCard :: RnTyKiEnv -> RnM () +-- Report an error if an anonymous wildcard is illegal here +checkAnonWildCard env + = checkWildCard env mb_bad + where + mb_bad :: Maybe SDoc + mb_bad | not (wildCardsAllowed env) + = Just (notAllowed pprAnonWildCard) + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing + RnTopConstraint -> Just constraint_msg + RnConstraint -> Just constraint_msg + + constraint_msg = hang + (notAllowed pprAnonWildCard <+> text "in a constraint") + 2 hint_msg + hint_msg = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + +checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () +-- Report an error if a named wildcard is illegal here +checkNamedWildCard env name + = checkWildCard env mb_bad + where + mb_bad | not (name `elemNameSet` rtke_nwcs env) + = Nothing -- Not a wildcard + | not (wildCardsAllowed env) + = Just (notAllowed (ppr name)) + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing -- Allowed + RnTopConstraint -> Nothing -- Allowed; e.g. + -- f :: (Eq _a) => _a -> Int + -- g :: (_a, _b) => T _a _b -> Int + -- The named tyvars get filled in from elsewhere + RnConstraint -> Just constraint_msg + constraint_msg = notAllowed (ppr name) <+> text "in a constraint" + +wildCardsAllowed :: RnTyKiEnv -> Bool +-- ^ In what contexts are wildcards permitted +wildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + TypBrCtx {} -> True -- Template Haskell quoted type + SpliceTypeCtx {} -> True -- Result of a Template Haskell splice + ExprWithTySigCtx {} -> True + PatCtx {} -> True + RuleCtx {} -> True + FamPatCtx {} -> True -- Not named wildcards though + GHCiCtx {} -> True + HsTypeCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls" + _ -> False + + + +--------------- +-- | Ensures either that we're in a type or that -XPolyKinds is set +checkPolyKinds :: Outputable ty + => RnTyKiEnv + -> ty -- ^ type + -> RnM () +checkPolyKinds env ty + | isRnKindLevel env + = do { polykinds <- xoptM LangExt.PolyKinds + ; unless polykinds $ + addErr (text "Illegal kind:" <+> ppr ty $$ + text "Did you mean to enable PolyKinds?") } +checkPolyKinds _ _ = return () + +notInKinds :: Outputable ty + => RnTyKiEnv + -> ty + -> RnM () +notInKinds env ty + | isRnKindLevel env + = addErr (text "Illegal kind:" <+> ppr ty) +notInKinds _ _ = return () + +{- ***************************************************** +* * + Binding type variables +* * +***************************************************** -} + +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +--------------- +bindHsQTyVars :: forall a b. + HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> FreeKiTyVars -- Kind variables from scope + -> LHsQTyVars GhcPs + -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)) + -- The Bool is True <=> all kind variables used in the + -- kind signature are bound on the left. Reason: + -- the last clause of Note [CUSKs: Complete user-supplied + -- kind signatures] in GHC.Hs.Decls + -> RnM (b, FreeVars) + +-- See Note [bindHsQTyVars examples] +-- (a) Bring kind variables into scope +-- both (i) passed in body_kv_occs +-- and (ii) mentioned in the kinds of hsq_bndrs +-- (b) Bring type variables into scope +-- +bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside + = do { let bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs + + ; let -- See Note [bindHsQTyVars examples] for what + -- all these various things are doing + bndrs, implicit_kvs :: [Located RdrName] + bndrs = map hsLTyVarLocName hs_tv_bndrs + implicit_kvs = filterFreeVarsToBind bndrs $ + bndr_kv_occs ++ body_kv_occs + body_remaining = filterFreeVarsToBind bndr_kv_occs $ + filterFreeVarsToBind bndrs body_kv_occs + all_bound_on_lhs = null body_remaining + + ; traceRn "checkMixedVars3" $ + vcat [ text "bndrs" <+> ppr hs_tv_bndrs + , text "bndr_kv_occs" <+> ppr bndr_kv_occs + , text "body_kv_occs" <+> ppr body_kv_occs + , text "implicit_kvs" <+> ppr implicit_kvs + , text "body_remaining" <+> ppr body_remaining + ] + + ; rnImplicitBndrs mb_assoc implicit_kvs $ \ implicit_kv_nms' -> + bindLHsTyVarBndrs doc NoWarnUnusedForalls mb_assoc hs_tv_bndrs $ \ rn_bndrs -> + -- This is the only call site for bindLHsTyVarBndrs where we pass + -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings. + -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars]. + do { let -- The SrcSpan that rnImplicitBndrs will attach to each Name will + -- span the entire declaration to which the LHsQTyVars belongs, + -- which will be reflected in warning and error messages. We can + -- be a little more precise than that by pointing to the location + -- of the LHsQTyVars instead, which is what bndrs_loc + -- corresponds to. + implicit_kv_nms = map (`setNameLoc` bndrs_loc) implicit_kv_nms' + + ; traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) + ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms + , hsq_explicit = rn_bndrs }) + all_bound_on_lhs } } + where + hs_tv_bndrs = hsQTvExplicit hsq_bndrs + + -- The SrcSpan of the LHsQTyVars. For example, bndrs_loc would be the + -- highlighted part in the class below: + -- + -- class C (a :: j) (b :: k) where + -- ^^^^^^^^^^^^^^^ + bndrs_loc = case map getLoc hs_tv_bndrs ++ map getLoc body_kv_occs of + [] -> panic "bindHsQTyVars.bndrs_loc" + [loc] -> loc + (loc:locs) -> loc `combineSrcSpans` last locs + +{- Note [bindHsQTyVars examples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data T k (a::k1) (b::k) :: k2 -> k1 -> * + +Then: + hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables + bndrs = [k,a,b] + + bndr_kv_occs = [k,k1], kind variables free in kind signatures + of hs_tv_bndrs + + body_kv_occs = [k2,k1], kind variables free in the + result kind signature + + implicit_kvs = [k1,k2,k1], kind variables free in kind signatures + of hs_tv_bndrs, and not bound by bndrs + +* We want to quantify add implicit bindings for implicit_kvs + +* If body_kv_occs is non-empty, then there is a kind variable + mentioned in the kind signature that is not bound "on the left". + That's one of the rules for a CUSK, so we pass that info on + as the second argument to thing_inside. + +* Order is not important in these lists. All we are doing is + bring Names into scope. + +* bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All + duplicate occurrences are removed when we bind them with rnImplicitBndrs. + +Finally, you may wonder why filterFreeVarsToBind removes in-scope variables +from bndr/body_kv_occs. How can anything be in scope? Answer: +HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax +ConDecls + data T a = forall (b::k). MkT a b +The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire +ConDecl. Hence the local RdrEnv may be non-empty and we must filter +out 'a' from the free vars. (Mind you, in this situation all the +implicit kind variables are bound at the data type level, so there +are none to bind in the ConDecl, so there are no implicitly bound +variables at all. + +Note [Kind variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + data T (a :: k) k = ... +we report "k is out of scope" for (a::k). Reason: k is not brought +into scope until the explicit k-binding that follows. It would be +terribly confusing to bring into scope an /implicit/ k for a's kind +and a distinct, shadowing explicit k that follows, something like + data T {k1} (a :: k1) k = ... + +So the rule is: + + the implicit binders never include any + of the explicit binders in the group + +Note that in the denerate case + data T (a :: a) = blah +we get a complaint the second 'a' is not in scope. + +That applies to foralls too: e.g. + forall (a :: k) k . blah + +But if the foralls are split, we treat the two groups separately: + forall (a :: k). forall k. blah +Here we bring into scope an implicit k, which is later shadowed +by the explicit k. + +In implementation terms + +* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete + the binders {a,k}, and so end with no implicit binders. Then we + rename the binders left-to-right, and hence see that 'k' is out of + scope in the kind of 'a'. + +* Similarly in extract_hs_tv_bndrs + +Note [Variables used as both types and kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We bind the type variables tvs, and kvs is the set of free variables of the +kinds in the scope of the binding. Here is one typical example: + + forall a b. a -> (b::k) -> (c::a) + +Here, tvs will be {a,b}, and kvs {k,a}. + +We must make sure that kvs includes all of variables in the kinds of type +variable bindings. For instance: + + forall k (a :: k). Proxy a + +If we only look in the body of the `forall` type, we will mistakenly conclude +that kvs is {}. But in fact, the type variable `k` is also used as a kind +variable in (a :: k), later in the binding. (This mistake lead to #14710.) +So tvs is {k,a} and kvs is {k}. + +NB: we do this only at the binding site of 'tvs'. + +Note [Suppress -Wunused-foralls when binding LHsQTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The WarnUnusedForalls flag controls whether bindLHsTyVarBndrs should warn about +explicit type variable binders that go unused (e.g., the `a` in +`forall a. Int`). We almost always want to warn about these, since unused type +variables can usually be deleted without any repercussions. There is one +exception to this rule, however: binding LHsQTyVars. Consider this example: + + data Proxy a = Proxy + +The `a` in `Proxy a` is bound by an LHsQTyVars, and the code which brings it +into scope, bindHsQTyVars, will invoke bindLHsTyVarBndrs in turn. As such, it +has a choice to make about whether to emit -Wunused-foralls warnings or not. +If it /did/ emit warnings, then the `a` would be flagged as unused. However, +this is not what we want! Removing the `a` in `Proxy a` would change its kind +entirely, which is a huge price to pay for fixing a warning. + +Unlike other forms of type variable binders, dropping "unused" variables in +an LHsQTyVars can be semantically significant. As a result, we suppress +-Wunused-foralls warnings in exactly one place: in bindHsQTyVars. +-} + +bindHsForAllTelescope :: HsDocContext + -> HsForAllTelescope GhcPs + -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsForAllTelescope doc tele thing_inside = + case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> + thing_inside $ mkHsForAllVisTele bndrs' + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> + thing_inside $ mkHsForAllInvisTele bndrs' + +-- | Should GHC warn if a quantified type variable goes unused? Usually, the +-- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we +-- avoid emitting warnings. +-- See @Note [Suppress -Wunused-foralls when binding LHsQTyVars]@. +data WarnUnusedForalls + = WarnUnusedForalls + | NoWarnUnusedForalls + +instance Outputable WarnUnusedForalls where + ppr wuf = text $ case wuf of + WarnUnusedForalls -> "WarnUnusedForalls" + NoWarnUnusedForalls -> "NoWarnUnusedForalls" + +bindLHsTyVarBndrs :: (OutputableBndrFlag flag) + => HsDocContext + -> WarnUnusedForalls + -> Maybe a -- Just _ => an associated type decl + -> [LHsTyVarBndr flag GhcPs] -- User-written tyvars + -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside + = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + ; checkDupRdrNames tv_names_w_loc + ; go tv_bndrs thing_inside } + where + tv_names_w_loc = map hsLTyVarLocName tv_bndrs + + go [] thing_inside = thing_inside [] + go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' -> + do { (res, fvs) <- go bs $ \ bs' -> + thing_inside (b' : bs') + ; warn_unused b' fvs + ; return (res, fvs) } + + warn_unused tv_bndr fvs = case wuf of + WarnUnusedForalls -> warnUnusedForAll doc tv_bndr fvs + NoWarnUnusedForalls -> return () + +bindLHsTyVarBndr :: HsDocContext + -> Maybe a -- associated class + -> LHsTyVarBndr flag GhcPs + -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndr _doc mb_assoc (L loc + (UserTyVar x fl + lrdr@(L lv _))) thing_inside + = do { nm <- newTyVarNameRn mb_assoc lrdr + ; bindLocalNamesFV [nm] $ + thing_inside (L loc (UserTyVar x fl (L lv nm))) } + +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind)) + thing_inside + = do { sig_ok <- xoptM LangExt.KindSignatures + ; unless sig_ok (badKindSigErr doc kind) + ; (kind', fvs1) <- rnLHsKind doc kind + ; tv_nm <- newTyVarNameRn mb_assoc lrdr + ; (b, fvs2) <- bindLocalNamesFV [tv_nm] + $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind')) + ; return (b, fvs1 `plusFV` fvs2) } + +newTyVarNameRn :: Maybe a -- associated class + -> Located RdrName -> RnM Name +newTyVarNameRn mb_assoc lrdr@(L _ rdr) + = do { rdr_env <- getLocalRdrEnv + ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of + (Just _, Just n) -> return n + -- Use the same Name as the parent class decl + + _ -> newLocalBndrRn lrdr } +{- +********************************************************* +* * + ConDeclField +* * +********************************************************* + +When renaming a ConDeclField, we have to find the FieldLabel +associated with each field. But we already have all the FieldLabels +available (since they were brought into scope by +GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an +argument, build a map and look them up. +-} + +rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] + -> RnM ([LConDeclField GhcRn], FreeVars) +-- Also called from GHC.Rename.Module +-- No wildcards can appear in record fields +rnConDeclFields ctxt fls fields + = mapFvRn (rnField fl_env env) fields + where + env = mkTyKiEnv ctxt TypeLevel RnTypeBody + fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] + +rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs + -> RnM (LConDeclField GhcRn, FreeVars) +rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) + = do { let new_names = map (fmap lookupField) names + ; (new_ty, fvs) <- rnLHsTyKi env ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) + , fvs) } + where + lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn + lookupField (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) + where + lbl = occNameFS $ rdrNameOcc rdr + fl = expectJust "rnField" $ lookupFsEnv fl_env lbl + +{- +************************************************************************ +* * + Fixities and precedence parsing +* * +************************************************************************ + +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator applications left-associatively, EXCEPT negation, which +we need to handle specially. +Infix types are read in a *right-associative* way, so that + a `op` b `op` c +is always read in as + a `op` (b `op` c) + +mkHsOpTyRn rearranges where necessary. The two arguments +have already been renamed and rearranged. It's made rather tiresome +by the presence of ->, which is a separate syntactic construct. +-} + +--------------- +-- Building (ty1 `op1` (ty21 `op2` ty22)) +mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn + -> RnM (HsType GhcRn) + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) + = do { fix2 <- lookupTyFixityRn op2 + ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (\t1 t2 -> HsOpTy noExtField t1 op2 t2) + (unLoc op2) fix2 ty21 ty22 loc2 } + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ mult ty21 ty22)) + = mk_hs_op_ty mk1 pp_op1 fix1 ty1 + hs_fun_ty funTyConName funTyFixity ty21 ty22 loc2 + where + hs_fun_ty a b = HsFunTy noExtField mult a b + +mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment + = return (mk1 ty1 ty2) + +--------------- +mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn + -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan + -> RnM (HsType GhcRn) +mk_hs_op_ty mk1 op1 fix1 ty1 + mk2 op2 fix2 ty21 ty22 loc2 + | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) + | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) + new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 + ; return (mk2 (noLoc new_ty) ty22) } + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + + +--------------------------- +mkOpAppRn :: NegationHandling + -> LHsExpr GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsExpr GhcRn -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr GhcRn) + +-- (e11 `op1` e12) `op2` e2 +mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right = do + new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2 + return (OpApp fix1 e11 op1 (L loc' new_e)) + where + loc'= combineLocs e12 e2 + (nofix_error, associate_right) = compareFixity fix1 fix2 + +--------------------------- +-- (- neg_arg) `op` e2 +mkOpAppRn ReassociateNegation e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 + | nofix_error + = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right + = do new_e <- mkOpAppRn ReassociateNegation neg_arg op2 fix2 e2 + return (NegApp noExtField (L loc' new_e) neg_name) + where + loc' = combineLocs neg_arg e2 + (nofix_error, associate_right) = compareFixity negateFixity fix2 + +--------------------------- +-- e1 `op` - neg_arg +mkOpAppRn ReassociateNegation e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right + | not associate_right -- We *want* right association + = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) + return (OpApp fix1 e1 op1 e2) + where + (_, associate_right) = compareFixity fix1 negateFixity + +--------------------------- +-- Default case +mkOpAppRn _ e1 op fix e2 -- Default case, no rearrangment + = ASSERT2(right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) + return (OpApp fix e1 op e2) + +data NegationHandling = ReassociateNegation | KeepNegationIntact + +---------------------------- + +-- | Name of an operator in an operator application or section +data OpName = NormalOp Name -- ^ A normal identifier + | NegateOp -- ^ Prefix negation + | UnboundOp OccName -- ^ An unbound indentifier + | RecFldOp (AmbiguousFieldOcc GhcRn) + -- ^ A (possibly ambiguous) record field occurrence + +instance Outputable OpName where + ppr (NormalOp n) = ppr n + ppr NegateOp = ppr negateName + ppr (UnboundOp uv) = ppr uv + ppr (RecFldOp fld) = ppr fld + +get_op :: LHsExpr GhcRn -> OpName +-- An unbound name could be either HsVar or HsUnboundVar +-- See GHC.Rename.Expr.rnUnboundVar +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operand. So we just check that the right operand is OK +right_op_ok :: Fixity -> HsExpr GhcRn -> Bool +right_op_ok fix1 (OpApp fix2 _ _ _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok _ _ + = True + +-- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) + -> RnM (HsExpr (GhcPass id)) +mkNegAppRn neg_arg neg_name + = ASSERT( not_op_app (unLoc neg_arg) ) + return (NegApp noExtField neg_arg neg_name) + +not_op_app :: HsExpr id -> Bool +not_op_app (OpApp {}) = False +not_op_app _ = True + +--------------------------- +mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsCmdTop GhcRn -- Right operand (not an infix) + -> RnM (HsCmd GhcRn) + +-- (e11 `op1` e12) `op2` e2 +mkOpFormRn a1@(L loc + (HsCmdTop _ + (L _ (HsCmdArrForm x op1 f (Just fix1) + [a11,a12])))) + op2 fix2 a2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (HsCmdArrForm x op2 f (Just fix2) [a1, a2]) + + | associate_right + = do new_c <- mkOpFormRn a12 op2 fix2 a2 + return (HsCmdArrForm noExtField op1 f (Just fix1) + [a11, L loc (HsCmdTop [] (L loc new_c))]) + -- TODO: locs are wrong + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment + = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2]) + + +-------------------------------------- +mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn + -> RnM (Pat GhcRn) + +mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2 + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + + ; if nofix_error then do + { precParseErr (NormalOp (unLoc op1),fix1) + (NormalOp (unLoc op2),fix2) + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op2 + , pat_args = InfixCon p1 p2 + } + } + + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op1 + , pat_args = InfixCon p11 (L loc new_p) + } + } + -- XXX loc right? + else return $ ConPat + { pat_con_ext = noExtField + , pat_con = op2 + , pat_args = InfixCon p1 p2 + } + } + +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment + = ASSERT( not_op_pat (unLoc p2) ) + return $ ConPat + { pat_con_ext = noExtField + , pat_con = op + , pat_args = InfixCon p1 p2 + } + +not_op_pat :: Pat GhcRn -> Bool +not_op_pat (ConPat NoExtField _ (InfixCon _ _)) = False +not_op_pat _ = True + +-------------------------------------- +checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () + -- Check precedence of a function binding written infix + -- eg a `op` b `C` c = ... + -- See comments with rnExpr (OpApp ...) about "deriving" + +checkPrecMatch op (MG { mg_alts = (L _ ms) }) + = mapM_ check ms + where + check (L _ (Match { m_pats = (L l1 p1) + : (L l2 p2) + : _ })) + = setSrcSpan (combineSrcSpans l1 l2) $ + do checkPrec op p1 False + checkPrec op p2 True + + check _ = return () + -- This can happen. Consider + -- a `op` True = ... + -- op = ... + -- The infix flag comes from the first binding of the group + -- but the second eqn has no args (an error, but not discovered + -- until the type checker). So we don't want to crash on the + -- second eqn. + +checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () +checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do + op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) + let + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (NormalOp op, op_fix) + info1 = (NormalOp (unLoc op1), op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) + unless inf_ok (precParseErr infol infor) + +checkPrec _ _ _ + = return () + +-- Check precedence of (arg op) or (op arg) respectively +-- If arg is itself an operator application, then either +-- (a) its precedence must be higher than that of op +-- (b) its precedency & associativity must be the same as that of op +checkSectionPrec :: FixityDirection -> HsExpr GhcPs + -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () +checkSectionPrec direction section op arg + = case unLoc arg of + OpApp fix _ op' _ -> go_for_it (get_op op') fix + NegApp _ _ _ -> go_for_it NegateOp negateFixity + _ -> return () + where + op_name = get_op op + go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do + op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (sectionPrecErr (get_op op, op_fix) + (arg_op, arg_fix) section) + +-- | Look up the fixity for an operator name. Be careful to use +-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields +-- (see #13132). +lookupFixityOp :: OpName -> RnM Fixity +lookupFixityOp (NormalOp n) = lookupFixityRn n +lookupFixityOp NegateOp = lookupFixityRn negateName +lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u) +lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f + + +-- Precedence-related error messages + +precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () +precParseErr op1@(n1,_) op2@(n2,_) + | is_unbound n1 || is_unbound n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ hang (text "Precedence parsing error") + 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), + ppr_opfix op2, + text "in the same infix expression"]) + +sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () +sectionPrecErr op@(n1,_) arg_op@(n2,_) section + | is_unbound n1 || is_unbound n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"), + nest 4 (sep [text "must have lower precedence than that of the operand,", + nest 2 (text "namely" <+> ppr_opfix arg_op)]), + nest 4 (text "in the section:" <+> quotes (ppr section))] + +is_unbound :: OpName -> Bool +is_unbound (NormalOp n) = isUnboundName n +is_unbound UnboundOp{} = True +is_unbound _ = False + +ppr_opfix :: (OpName, Fixity) -> SDoc +ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) + where + pp_op | NegateOp <- op = text "prefix `-'" + | otherwise = quotes (ppr op) + + +{- ***************************************************** +* * + Errors +* * +***************************************************** -} + +unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc +unexpectedPatSigTypeErr ty + = hang (text "Illegal type signature:" <+> quotes (ppr ty)) + 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") + +badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () +badKindSigErr doc (L loc ty) + = setSrcSpan loc $ addErr $ + withHsDocContext doc $ + hang (text "Illegal kind signature:" <+> quotes (ppr ty)) + 2 (text "Perhaps you intended to use KindSignatures") + +dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc +dataKindsErr env thing + = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) + 2 (text "Perhaps you intended to use DataKinds") + where + pp_what | isRnKindLevel env = text "kind" + | otherwise = text "type" + +warnUnusedForAll :: OutputableBndrFlag flag + => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () +warnUnusedForAll doc (L loc tv) used_names + = whenWOptM Opt_WarnUnusedForalls $ + unless (hsTyVarName tv `elemNameSet` used_names) $ + addWarnAt (Reason Opt_WarnUnusedForalls) loc $ + vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) + , inHsDocContext doc ] + +opTyErr :: Outputable a => RdrName -> a -> SDoc +opTyErr op overall_ty + = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) + 2 (text "Use TypeOperators to allow operators in types") + +{- +************************************************************************ +* * + Finding the free type variables of a (HsType RdrName) +* * +************************************************************************ + + +Note [Kind and type-variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type signature we may implicitly bind type/kind variables. For example: + * f :: a -> a + f = ... + Here we need to find the free type variables of (a -> a), + so that we know what to quantify + + * class C (a :: k) where ... + This binds 'k' in ..., as well as 'a' + + * f (x :: a -> [a]) = .... + Here we bind 'a' in .... + + * f (x :: T a -> T (b :: k)) = ... + Here we bind both 'a' and the kind variable 'k' + + * type instance F (T (a :: Maybe k)) = ...a...k... + Here we want to constrain the kind of 'a', and bind 'k'. + +To do that, we need to walk over a type and find its free type/kind variables. +We preserve the left-to-right order of each variable occurrence. +See Note [Ordering of implicit variables]. + +It is common for lists of free type variables to contain duplicates. For +example, in `f :: a -> a`, the free type variable list is [a, a]. When these +implicitly bound variables are brought into scope (with rnImplicitBndrs), +duplicates are removed with nubL. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does ScopedSort on the variables. +See Note [ScopedSort] in GHC.Core.Type. + +Implicitly bound variables are collected by any function which returns a +FreeKiTyVars, which notably includes the `extract-` family of functions +(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.). +These functions thus promise to keep left-to-right ordering. + +Note [Implicit quantification in type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We typically bind type/kind variables implicitly when they are in a kind +annotation on the LHS, for example: + + data Proxy (a :: k) = Proxy + type KindOf (a :: k) = k + +Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and +we want to implicitly quantify over it. This is easy: just extract all free +variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs + +By contrast, on the RHS we can't simply collect *all* free variables. Which of +the following are allowed? + + type TySyn1 = a :: Type + type TySyn2 = 'Nothing :: Maybe a + type TySyn3 = 'Just ('Nothing :: Maybe a) + type TySyn4 = 'Left a :: Either Type a + +After some design deliberations (see non-taken alternatives below), the answer +is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now. +We implicitly quantify over free variables of the outermost kind signature, if +one exists: + + * In TySyn1, the outermost kind signature is (:: Type), and it does not have + any free variables. + * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a + free variable 'a', which we implicitly quantify over. + * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature + is hidden inside 'Just. + * In TySyn4, the outermost kind signature is (:: Either Type a), it contains + a free variable 'a', which we implicitly quantify over. That is why we can + also use it to the left of the double colon: 'Left a + +The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type +synonyms and type family instances. + +This is something of a stopgap solution until we can explicitly bind invisible +type/kind variables: + + type TySyn3 :: forall a. Maybe a + type TySyn3 @a = 'Just ('Nothing :: Maybe a) + +Note [Implicit quantification in type synonyms: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I: No quantification +-------------------------------- +We could offer no implicit quantification on the RHS, accepting none of the +TySyn examples. The user would have to bind the variables explicitly: + + type TySyn1 a = a :: Type + type TySyn2 a = 'Nothing :: Maybe a + type TySyn3 a = 'Just ('Nothing :: Maybe a) + type TySyn4 a = 'Left a :: Either Type a + +However, this would mean that one would have to specify 'a' at call sites every +time, which could be undesired. + +Alternative II: Indiscriminate quantification +--------------------------------------------- +We could implicitly quantify over all free variables on the RHS just like we do +on the LHS. Then we would infer the following kinds: + + TySyn1 :: forall {a}. Type + TySyn2 :: forall {a}. Maybe a + TySyn3 :: forall {a}. Maybe (Maybe a) + TySyn4 :: forall {a}. Either Type a + +This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable +is free-floating, not fixed by anything. + +Alternative III: reportFloatingKvs +---------------------------------- +We could augment Alternative II by hunting down free-floating variables during +type checking. While viable, this would mean we'd end up accepting this: + + data Prox k (a :: k) + type T = Prox k + +-} + +-- A list of free type/kind variables, which can contain duplicates. +-- See Note [Kind and type-variable binders] +-- These lists are guaranteed to preserve left-to-right ordering of +-- the types the variables were extracted from. See also +-- Note [Ordering of implicit variables]. +type FreeKiTyVars = [Located RdrName] + +-- | Filter out any type and kind variables that are already in scope in the +-- the supplied LocalRdrEnv. Note that this includes named wildcards, which +-- look like perfectly ordinary type variables at this point. +filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars +filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) + +-- | Filter out any type and kind variables that are already in scope in the +-- the environment's LocalRdrEnv. Note that this includes named wildcards, +-- which look like perfectly ordinary type variables at this point. +filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars +filterInScopeM vars + = do { rdr_env <- getLocalRdrEnv + ; return (filterInScope rdr_env vars) } + +inScope :: LocalRdrEnv -> RdrName -> Bool +inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env + +extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_tyarg (HsValArg ty) acc = extract_lty ty acc +extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc +extract_tyarg (HsArgPar _) acc = acc + +extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars +extract_tyargs args acc = foldr extract_tyarg acc args + +extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars +extractHsTyArgRdrKiTyVars args + = extract_tyargs args [] + +-- | 'extractHsTyRdrTyVars' finds the type/kind variables +-- of a HsType/HsKind. +-- It's used when making the @forall@s explicit. +-- See Note [Kind and type-variable binders] +extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars +extractHsTyRdrTyVars ty = extract_lty ty [] + +extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars +extractHsScaledTysRdrTyVars args acc = foldr (\(HsScaled m ty) -> extract_lty ty . extract_hs_arrow m) acc args + +-- | Extracts the free type/kind variables from the kind signature of a HsType. +-- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. +-- The left-to-right order of variables is preserved. +-- See Note [Kind and type-variable binders] and +-- Note [Ordering of implicit variables] and +-- Note [Implicit quantification in type synonyms]. +extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars +extractHsTyRdrTyVarsKindVars (L _ ty) = + case ty of + HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty + HsKindSig _ _ ki -> extractHsTyRdrTyVars ki + _ -> [] + +-- | Extracts free type and kind variables from types in a list. +-- When the same name occurs multiple times in the types, all occurrences +-- are returned. +extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars +extractHsTysRdrTyVars tys = extract_ltys tys + +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars +extractHsTyVarBndrsKVs tv_bndrs = extract_hs_tv_bndrs_kvs tv_bndrs + +-- Returns the free kind variables in a type family result signature, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars +extractRdrKindSigVars (L _ resultSig) = case resultSig of + KindSig _ k -> extractHsTyRdrTyVars k + TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k + _ -> [] + +-- | Get type/kind variables mentioned in the kind signature, preserving +-- left-to-right order: +-- +-- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1] +-- * data T a (b :: k1) -- result: [] +-- +-- See Note [Ordering of implicit variables]. +extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVars +extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) + = maybe [] extractHsTyRdrTyVars ksig + +extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_lctxt ctxt = extract_ltys (unLoc ctxt) + +extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars +extract_ltys tys acc = foldr extract_lty acc tys + +extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_lty (L _ ty) acc + = case ty of + HsTyVar _ _ ltv -> extract_tv ltv acc + HsBangTy _ _ ty -> extract_lty ty acc + HsRecTy _ flds -> foldr (extract_lty + . cd_fld_type . unLoc) acc + flds + HsAppTy _ ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 acc + HsAppKindTy _ ty k -> extract_lty ty $ + extract_lty k acc + HsListTy _ ty -> extract_lty ty acc + HsTupleTy _ _ tys -> extract_ltys tys acc + HsSumTy _ tys -> extract_ltys tys acc + HsFunTy _ w ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 $ + extract_hs_arrow w acc + HsIParamTy _ _ ty -> extract_lty ty acc + HsOpTy _ ty1 tv ty2 -> extract_tv tv $ + extract_lty ty1 $ + extract_lty ty2 acc + HsParTy _ ty -> extract_lty ty acc + HsSpliceTy {} -> acc -- Type splices mention no tvs + HsDocTy _ ty _ -> extract_lty ty acc + HsExplicitListTy _ _ tys -> extract_ltys tys acc + HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsTyLit _ _ -> acc + HsStarTy _ _ -> acc + HsKindSig _ ty ki -> extract_lty ty $ + extract_lty ki acc + HsForAllTy { hst_tele = tele, hst_body = ty } + -> extract_hs_for_all_telescope tele acc $ + extract_lty ty [] + HsQualTy { hst_ctxt = ctxt, hst_body = ty } + -> extract_lctxt ctxt $ + extract_lty ty acc + XHsType {} -> acc + -- We deal with these separately in rnLHsTypeWithWildCards + HsWildCardTy {} -> acc + +extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> + FreeKiTyVars +extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc +extract_hs_arrow _ acc = acc + +extract_hs_for_all_telescope :: HsForAllTelescope GhcPs + -> FreeKiTyVars -- Accumulator + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars +extract_hs_for_all_telescope tele acc_vars body_fvs = + case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + extract_hs_tv_bndrs bndrs acc_vars body_fvs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + extract_hs_tv_bndrs bndrs acc_vars body_fvs + +extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs] + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars -- Free in result +extractHsTvBndrs tv_bndrs body_fvs + = extract_hs_tv_bndrs tv_bndrs [] body_fvs + +extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] + -> FreeKiTyVars -- Accumulator + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars +-- In (forall (a :: Maybe e). a -> b) we have +-- 'a' is bound by the forall +-- 'b' is a free type variable +-- 'e' is a free kind variable +extract_hs_tv_bndrs tv_bndrs acc_vars body_vars = new_vars ++ acc_vars + where + new_vars + | null tv_bndrs = body_vars + | otherwise = filterFreeVarsToBind tv_bndr_rdrs $ bndr_vars ++ body_vars + -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars. + -- See Note [Kind variable scoping] + bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs + tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs + +extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extract_hs_tv_bndrs_kvs tv_bndrs = + foldr extract_lty [] + [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs] + +extract_tv :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_tv tv acc = + if isRdrTyVar (unLoc tv) then tv:acc else acc + +-- Deletes duplicates in a list of Located things. This is used to: +-- +-- * Delete duplicate occurrences of implicitly bound type/kind variables when +-- bringing them into scope (in rnImplicitBndrs). +-- +-- * Delete duplicate occurrences of named wildcards (in rn_hs_sig_wc_type and +-- rnHsWcType). +-- +-- Importantly, this function is stable with respect to the original ordering +-- of things in the list. This is important, as it is a property that GHC +-- relies on to maintain the left-to-right ordering of implicitly quantified +-- type variables. +-- See Note [Ordering of implicit variables]. +nubL :: Eq a => [Located a] -> [Located a] +nubL = nubBy eqLocated + +-- | Filter out any potential implicit binders that are either +-- already in scope, or are explicitly bound in the binder. +filterFreeVarsToBind :: FreeKiTyVars + -- ^ Explicitly bound here + -> FreeKiTyVars + -- ^ Potential implicit binders + -> FreeKiTyVars + -- ^ Final implicit binders +filterFreeVarsToBind bndrs = filterOut is_in_scope + -- Make sure to list the binder kvs before the body kvs, as mandated by + -- Note [Ordering of implicit variables] + where + is_in_scope locc = any (eqLocated locc) bndrs diff --git a/GHC/Rename/Module.hs b/GHC/Rename/Module.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Module.hs @@ -0,0 +1,2511 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Main pass of renamer +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Rename.Module ( + rnSrcDecls, addTcgDUs, findSplice + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) + +import GHC.Hs +import GHC.Types.FieldLabel +import GHC.Types.Name.Reader +import GHC.Rename.HsType +import GHC.Rename.Bind +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames + , checkDupRdrNames, bindLocalNamesFV + , checkShadowedRdrNames, warnUnusedTypePatterns + , extendTyVarEnvFVRn, newLocalBndrsRn + , withHsDocContext, noNestedForallsContextsErr + , addNoNestedForallsContextsErr, checkInferredVars ) +import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr ) +import GHC.Rename.Names +import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc ) +import GHC.Tc.Gen.Annotation ( annCtxt ) +import GHC.Tc.Utils.Monad + +import GHC.Types.ForeignCall ( CCallTarget(..) ) +import GHC.Unit.Module +import GHC.Driver.Types ( Warnings(..), plusWarns ) +import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName + , monadClassName, returnMName, thenMName + , semigroupClassName, sappendName + , monoidClassName, mappendName + ) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Utils.Outputable +import GHC.Data.Bag +import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) ) +import GHC.Data.FastString +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Session +import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith ) +import GHC.Driver.Types ( HscEnv, hsc_dflags ) +import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) +import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) + , stronglyConnCompFromEdgedVerticesUniq ) +import GHC.Types.Unique.Set +import GHC.Data.OrdList +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Control.Arrow ( first ) +import Data.List ( mapAccumL ) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( isNothing, isJust, fromMaybe, mapMaybe ) +import qualified Data.Set as Set ( difference, fromList, toList, null ) +import Data.Function ( on ) + +{- | @rnSourceDecl@ "renames" declarations. +It simultaneously performs dependency analysis and precedence parsing. +It also does the following error checks: + +* Checks that tyvars are used properly. This includes checking + for undefined tyvars, and tyvars in contexts that are ambiguous. + (Some of this checking has now been moved to module @TcMonoType@, + since we don't have functional dependency information at this point.) + +* Checks that all variable occurrences are defined. + +* Checks the @(..)@ etc constraints in the export list. + +Brings the binders of the group into scope in the appropriate places; +does NOT assume that anything is in scope already +-} +rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) +-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) + = do { + -- (A) Process the top-level fixity declarations, creating a mapping from + -- FastStrings to FixItems. Also checks for duplicates. + -- See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls + local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ; + + -- (B) Bring top level binders (and their fixities) into scope, + -- *except* for the value bindings, which get done in step (D) + -- with collectHsIdBinders. However *do* include + -- + -- * Class ops, data constructors, and record fields, + -- because they do not have value declarations. + -- + -- * For hs-boot files, include the value signatures + -- Again, they have no value declarations + -- + (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + + + setEnvs tc_envs $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (D1) Bring pattern synonyms into scope. + -- Need to do this before (D2) because rnTopBindsLHS + -- looks up those pattern synonyms (#9889) + + extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { + + -- (D2) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope. + -- It uses the fixity env from (A) to bind fixities for view patterns. + new_lhs <- rnTopBindsLHS local_fix_env val_decls ; + + -- Bind the LHSes (and their fixities) in the global rdr environment + let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders + -- They are already in scope + traceRn "rnSrcDecls" (ppr id_bndrs) ; + tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; + setEnvs tc_envs $ do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn "Start rnTyClDecls" (ppr tycl_decls) ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; + + -- (F) Rename Value declarations right-hand sides + traceRn "Start rnmono" empty ; + let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; + is_boot <- tcIsHsBootOrSig ; + (rn_val_decls, bind_dus) <- if is_boot + -- For an hs-boot, use tc_bndrs (which collects how we're renamed + -- signatures), since val_bndr_set is empty (there are no x = ... + -- bindings in an hs-boot.) + then rnTopBindsBoot tc_bndrs new_lhs + else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; + traceRn "finish rnmono" (ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- Rename fixity declarations and error if we try to + -- fix something from another module (duplicates were checked in (A)) + let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; + rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) + fix_decls ; + + -- Rename deprec decls; + -- check for duplicates and ensure that deprecated things are defined locally + -- at the moment, we don't keep these around past renaming + rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; + + -- (H) Rename Everything else + + (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ + rnList rnHsRuleDecls rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; + -- Haddock docs; no free vars + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; + + last_tcg_env <- getGblEnv ; + -- (I) Compute the results and return + let {rn_group = HsGroup { hs_ext = noExtField, + hs_valds = rn_val_decls, + hs_splcds = rn_splice_decls, + hs_tyclds = rn_tycl_decls, + hs_derivds = rn_deriv_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; + + tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; + other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; + } ; + traceRn "finish rnSrc" (ppr rn_group) ; + traceRn "finish Dus" (ppr src_dus ) ; + return (final_tcg_env, rn_group) + }}}} + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, +-- but there doesn't seem anywhere very logical to put it. +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } + +rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstM f) xs + +{- +********************************************************* +* * + HsDoc stuff +* * +********************************************************* +-} + +rnDocDecl :: DocDecl -> RnM DocDecl +rnDocDecl (DocCommentNext doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNext rn_doc) +rnDocDecl (DocCommentPrev doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentPrev rn_doc) +rnDocDecl (DocCommentNamed str doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNamed str rn_doc) +rnDocDecl (DocGroup lev doc) = do + rn_doc <- rnHsDoc doc + return (DocGroup lev rn_doc) + +{- +********************************************************* +* * + Source-code deprecations declarations +* * +********************************************************* + +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. +-} + +-- checks that the deprecations are defined locally, and that there are no duplicates +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings +rnSrcWarnDecls _ [] + = return NoWarnings + +rnSrcWarnDecls bndr_set decls' + = do { -- check for duplicates + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups + in addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } + where + decls = concatMap (wd_warnings . unLoc) decls' + + sig_ctxt = TopSigCtxt bndr_set + + rn_deprec (Warning _ rdr_names txt) + -- ensures that the names are defined locally + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) + rdr_names + ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } + + what = text "deprecation" + + warn_rdr_dups = findDupRdrNames + $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls + +findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] +findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + +-- look for duplicates among the OccNames; +-- we check that the names are defined above +-- invt: the lists returned by findDupsEq always have at least two elements + +dupWarnDecl :: Located RdrName -> RdrName -> SDoc +-- Located RdrName -> DeprecDecl RdrName -> SDoc +dupWarnDecl d rdr_name + = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr (getLoc d)] + +{- +********************************************************* +* * +\subsection{Annotation declarations} +* * +********************************************************* +-} + +rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) +rnAnnDecl ann@(HsAnnotation _ s provenance expr) + = addErrCtxt (annCtxt ann) $ + do { (provenance', provenance_fvs) <- rnAnnProvenance provenance + ; (expr', expr_fvs) <- setStage (Splice Untyped) $ + rnLExpr expr + ; return (HsAnnotation noExtField s provenance' expr', + provenance_fvs `plusFV` expr_fvs) } + +rnAnnProvenance :: AnnProvenance RdrName + -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance provenance = do + provenance' <- traverse lookupTopBndrRn provenance + return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) + +{- +********************************************************* +* * +\subsection{Default declarations} +* * +********************************************************* +-} + +rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) +rnDefaultDecl (DefaultDecl _ tys) + = do { (tys', fvs) <- rnLHsTypes doc_str tys + ; return (DefaultDecl noExtField tys', fvs) } + where + doc_str = DefaultDeclCtx + +{- +********************************************************* +* * +\subsection{Foreign declarations} +* * +********************************************************* +-} + +rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) +rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) + = do { topEnv :: HscEnv <- getTopEnv + ; name' <- lookupLocatedTopBndrRn name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + + -- Mark any PackageTarget style imports as coming from the current package + ; let unitId = homeUnit $ hsc_dflags topEnv + spec' = patchForeignImport unitId spec + + ; return (ForeignImport { fd_i_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fi = spec' }, fvs) } + +rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) + = do { name' <- lookupLocatedOccRn name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; return (ForeignExport { fd_e_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fe = spec } + , fvs `addOneFV` unLoc name') } + -- NB: a foreign export is an *occurrence site* for name, so + -- we add it to the free-variable list. It might, for example, + -- be imported from another module + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundary we'll still +-- know where they're from. +-- +patchForeignImport :: Unit -> ForeignImport -> ForeignImport +patchForeignImport unit (CImport cconv safety fs spec src) + = CImport cconv safety fs (patchCImportSpec unit spec) src + +patchCImportSpec :: Unit -> CImportSpec -> CImportSpec +patchCImportSpec unit spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget + _ -> spec + +patchCCallTarget :: Unit -> CCallTarget -> CCallTarget +patchCCallTarget unit callTarget = + case callTarget of + StaticTarget src label Nothing isFun + -> StaticTarget src label (Just unit) isFun + _ -> callTarget + +{- +********************************************************* +* * +\subsection{Instance declarations} +* * +********************************************************* +-} + +rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) +rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) + = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi + ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } + +rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) + = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi + ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } + +rnSrcInstDecl (ClsInstD { cid_inst = cid }) + = do { traceRn "rnSrcIstDecl {" (ppr cid) + ; (cid', fvs) <- rnClsInstDecl cid + ; traceRn "rnSrcIstDecl end }" empty + ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } + +-- | Warn about non-canonical typeclass instance declarations +-- +-- A "non-canonical" instance definition can occur for instances of a +-- class which redundantly defines an operation its superclass +-- provides as well (c.f. `return`/`pure`). In such cases, a canonical +-- instance is one where the subclass inherits its method +-- implementation from its superclass instance (usually the subclass +-- has a default method implementation to that effect). Consequently, +-- a non-canonical instance occurs when this is not the case. +-- +-- See also descriptions of 'checkCanonicalMonadInstances' and +-- 'checkCanonicalMonoidInstances' +checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () +checkCanonicalInstances cls poly_ty mbinds = do + whenWOptM Opt_WarnNonCanonicalMonadInstances + checkCanonicalMonadInstances + + whenWOptM Opt_WarnNonCanonicalMonoidInstances + checkCanonicalMonoidInstances + + where + -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance + -- declarations. Specifically, the following conditions are verified: + -- + -- In 'Monad' instances declarations: + -- + -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) + -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) + -- + -- In 'Applicative' instance declarations: + -- + -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). + -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). + -- + checkCanonicalMonadInstances + | cls == applicativeClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == pureAName, isAliasMG mg == Just returnMName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "pure" "return" + + | name == thenAName, isAliasMG mg == Just thenMName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" + + _ -> return () + + | cls == monadClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == returnMName, isAliasMG mg /= Just pureAName + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "return" "pure" + + | name == thenMName, isAliasMG mg /= Just thenAName + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" + + _ -> return () + + | otherwise = return () + + -- | Check whether Monoid(mappend) is defined in terms of + -- Semigroup((<>)) (and not the other way round). Specifically, + -- the following conditions are verified: + -- + -- In 'Monoid' instances declarations: + -- + -- * If 'mappend' is overridden it must be canonical + -- (i.e. @mappend = (<>)@) + -- + -- In 'Semigroup' instance declarations: + -- + -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). + -- + checkCanonicalMonoidInstances + | cls == semigroupClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == sappendName, isAliasMG mg == Just mappendName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" + + _ -> return () + + | cls == monoidClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == mappendName, isAliasMG mg /= Just sappendName + -> addWarnNonCanonicalMethod2NoDefault + Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" + + _ -> return () + + | otherwise = return () + + -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" + -- binding, and return @Just rhsName@ if this is the case + isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name + isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] + , m_grhss = grhss })])} + | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss + , EmptyLocalBinds _ <- unLoc lbinds + , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) + isAliasMG _ = Nothing + + -- got "lhs = rhs" but expected something different + addWarnNonCanonicalMethod1 flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text (lhs ++ " = " ++ rhs)) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Move definition from" <+> + quotes (text rhs) <+> + text "to" <+> quotes (text lhs) + ] + + -- expected "lhs = rhs" but got something else + addWarnNonCanonicalMethod2 flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Either remove definition for" <+> + quotes (text lhs) <+> text "or define as" <+> + quotes (text (lhs ++ " = " ++ rhs)) + ] + + -- like above, but method has no default impl + addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Define as" <+> + quotes (text (lhs ++ " = " ++ rhs)) + ] + + -- stolen from GHC.Tc.TyCl.Instance + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc + instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + + inst_decl_ctxt :: SDoc -> SDoc + inst_decl_ctxt doc = hang (text "in the instance declaration for") + 2 (quotes doc <> text ".") + + +rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) +rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = oflag + , cid_datafam_insts = adts }) + = do { checkInferredVars ctxt inf_err inst_ty + ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty + ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' + -- Check if there are any nested `forall`s or contexts, which are + -- illegal in the type of an instance declaration (see + -- Note [No nested foralls or contexts in instance types] in + -- GHC.Hs.Type)... + mb_nested_msg = noNestedForallsContextsErr + (text "Instance head") head_ty' + -- ...then check if the instance head is actually headed by a + -- class type constructor... + eith_cls = case hsTyGetAppHead_maybe head_ty' of + Just (L _ cls) -> Right cls + Nothing -> Left + ( getLoc head_ty' + , hang (text "Illegal head of an instance declaration:" + <+> quotes (ppr head_ty')) + 2 (vcat [ text "Instance heads must be of the form" + , nest 2 $ text "C ty_1 ... ty_n" + , text "where" <+> quotes (char 'C') + <+> text "is a class" + ]) + ) + -- ...finally, attempt to retrieve the class type constructor, failing + -- with an error message if there isn't one. To avoid excessive + -- amounts of error messages, we will only report one of the errors + -- from mb_nested_msg or eith_cls at a time. + ; cls <- case (mb_nested_msg, eith_cls) of + (Nothing, Right cls) -> pure cls + (Just err1, _) -> bail_out err1 + (_, Left err2) -> bail_out err2 + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the + -- forall-d tyvars scope over the method bindings too + ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags + + ; checkCanonicalInstances cls inst_ty' mbinds' + + -- Rename the associated types, and type signatures + -- Both need to have the instance type variables in scope + ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) + ; ((ats', adts'), more_fvs) + <- extendTyVarEnvFVRn ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats + ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts + ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } + + ; let all_fvs = meth_fvs `plusFV` more_fvs + `plusFV` inst_fvs + ; return (ClsInstDecl { cid_ext = noExtField + , cid_poly_ty = inst_ty', cid_binds = mbinds' + , cid_sigs = uprags', cid_tyfam_insts = ats' + , cid_overlap_mode = oflag + , cid_datafam_insts = adts' }, + all_fvs) } + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). + where + ctxt = GenericCtx $ text "an instance declaration" + inf_err = Just (text "Inferred type variables are not allowed") + + -- The instance is malformed. We'd still like to make *some* progress + -- (rather than failing outright), so we report an error and continue for + -- as long as we can. Importantly, this error should be thrown before we + -- reach the typechecker, lest we encounter different errors that are + -- hopelessly confusing (such as the one in #16114). + bail_out (l, err_msg) = do + addErrAt l $ withHsDocContext ctxt err_msg + pure $ mkUnboundName (mkTcOccFS (fsLit "")) + +rnFamInstEqn :: HsDocContext + -> AssocTyFamInfo + -> FreeKiTyVars + -- ^ Kind variables from the equation's RHS to be implicitly bound + -- if no explicit forall. + -> FamInstEqn GhcPs rhs + -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) + -> RnM (FamInstEqn GhcRn rhs', FreeVars) +rnFamInstEqn doc atfi rhs_kvars + (HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_bndrs = mb_bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = payload }}) rn_payload + = do { tycon' <- lookupFamInstName mb_cls tycon + + -- all_imp_vars represent the implicitly bound type variables. This is + -- empty if we have an explicit `forall` (see + -- Note [forall-or-nothing rule] in GHC.Rename.HsType), which means + -- ignoring: + -- + -- - pat_kity_vars_with_dups, the variables mentioned in the LHS of + -- the equation, and + -- - rhs_kvars, the kind variables mentioned in an outermost kind + -- signature on the RHS of the equation. (See + -- Note [Implicit quantification in type synonyms] in + -- GHC.Rename.HsType for why these are implicitly quantified in the + -- absence of an explicit forall). + -- + -- For example: + -- + -- @ + -- type family F a b + -- type instance forall a b c. F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [] + -- type instance F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [a, b, c] + -- @ + ; all_imp_vars <- forAllOrNothing (isJust mb_bndrs) $ + -- No need to filter out explicit binders (the 'mb_bndrs = Just + -- explicit_bndrs' case) because there must be none if we're going + -- to implicitly bind anything, per the previous comment. + pat_kity_vars_with_dups ++ rhs_kvars + + ; rnImplicitBndrs mb_cls all_imp_vars $ \all_imp_var_names' -> + bindLHsTyVarBndrs doc WarnUnusedForalls + Nothing (fromMaybe [] mb_bndrs) $ \bndrs' -> + -- Note: If we pass mb_cls instead of Nothing here, + -- bindLHsTyVarBndrs will use class variables for any names + -- the user meant to bring in scope here. This is an explicit + -- forall, so we want fresh names, not class variables. + -- Thus: always pass Nothing + do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats + ; (payload', rhs_fvs) <- rn_payload doc payload + + -- Report unused binders on the LHS + -- See Note [Unused type variables in family instances] + ; let -- The SrcSpan that rnImplicitBndrs will attach to each Name will + -- span the entire type family instance, which will be reflected in + -- -Wunused-type-patterns warnings. We can be a little more precise + -- than that by pointing to the LHS of the instance instead, which + -- is what lhs_loc corresponds to. + all_imp_var_names = map (`setNameLoc` lhs_loc) all_imp_var_names' + + groups :: [NonEmpty (Located RdrName)] + groups = equivClasses cmpLocated $ + pat_kity_vars_with_dups + ; nms_dups <- mapM (lookupOccRn . unLoc) $ + [ tv | (tv :| (_:_)) <- groups ] + -- Add to the used variables + -- a) any variables that appear *more than once* on the LHS + -- e.g. F a Int a = Bool + -- b) for associated instances, the variables + -- of the instance decl. See + -- Note [Unused type variables in family instances] + ; let nms_used = extendNameSetList rhs_fvs $ + inst_tvs ++ nms_dups + all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' + ; warnUnusedTypePatterns all_nms nms_used + + ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs + -- See Note [Type family equations and occurrences] + all_fvs = case atfi of + NonAssocTyFamEqn ClosedTyFam + -> eqn_fvs + _ -> eqn_fvs `addOneFV` unLoc tycon' + + ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] + , hsib_body + = FamEqn { feqn_ext = noExtField + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' <$ mb_bndrs + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = payload' } }, + all_fvs) } } + where + -- The parent class, if we are dealing with an associated type family + -- instance. + mb_cls = case atfi of + NonAssocTyFamEqn _ -> Nothing + AssocTyFamDeflt cls -> Just cls + AssocTyFamInst cls _ -> Just cls + + -- The type variables from the instance head, if we are dealing with an + -- associated type family instance. + inst_tvs = case atfi of + NonAssocTyFamEqn _ -> [] + AssocTyFamDeflt _ -> [] + AssocTyFamInst _ inst_tvs -> inst_tvs + + pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVars pats + -- It is crucial that extractHsTyArgRdrKiTyVars return + -- duplicate occurrences, since they're needed to help + -- determine unused binders on the LHS. + + -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be + -- the highlighted part in the example below: + -- + -- type instance F a b c = Either a b + -- ^^^^^ + lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLoc rhs_kvars of + [] -> panic "rnFamInstEqn.lhs_loc" + [loc] -> loc + (loc:locs) -> loc `combineSrcSpans` last locs + +rnTyFamInstDecl :: AssocTyFamInfo + -> TyFamInstDecl GhcPs + -> RnM (TyFamInstDecl GhcRn, FreeVars) +rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } + +-- | Tracks whether we are renaming: +-- +-- 1. A type family equation that is not associated +-- with a parent type class ('NonAssocTyFamEqn'). Examples: +-- +-- @ +-- type family F a +-- type instance F Int = Bool -- NonAssocTyFamEqn NotClosed +-- +-- type family G a where +-- G Int = Bool -- NonAssocTyFamEqn Closed +-- @ +-- +-- 2. An associated type family default declaration ('AssocTyFamDeflt'). +-- Example: +-- +-- @ +-- class C a where +-- type A a +-- type instance A a = a -> a -- AssocTyFamDeflt C +-- @ +-- +-- 3. An associated type family instance declaration ('AssocTyFamInst'). +-- Example: +-- +-- @ +-- instance C a => C [a] where +-- type A [a] = Bool -- AssocTyFamInst C [a] +-- @ +data AssocTyFamInfo + = NonAssocTyFamEqn + ClosedTyFamInfo -- Is this a closed type family? + | AssocTyFamDeflt + Name -- Name of the parent class + | AssocTyFamInst + Name -- Name of the parent class + [Name] -- Names of the tyvars of the parent instance decl + +-- | Tracks whether we are renaming an equation in a closed type family +-- equation ('ClosedTyFam') or not ('NotClosedTyFam'). +data ClosedTyFamInfo + = NotClosedTyFam + | ClosedTyFam + +rnTyFamInstEqn :: AssocTyFamInfo + -> TyFamInstEqn GhcPs + -> RnM (TyFamInstEqn GhcRn, FreeVars) +rnTyFamInstEqn atfi + eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_rhs = rhs }}) + = rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn + where + rhs_kvs = extractHsTyRdrTyVarsKindVars rhs + +rnTyFamDefltDecl :: Name + -> TyFamDefltDecl GhcPs + -> RnM (TyFamDefltDecl GhcRn, FreeVars) +rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) + +rnDataFamInstDecl :: AssocTyFamInfo + -> DataFamInstDecl GhcPs + -> RnM (DataFamInstDecl GhcRn, FreeVars) +rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = + FamEqn { feqn_tycon = tycon + , feqn_rhs = rhs }})}) + = do { let rhs_kvs = extractDataDefnKindVars rhs + ; (eqn', fvs) <- + rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn + ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } + +-- Renaming of the associated types in instances. + +-- Rename associated type family decl in class +rnATDecls :: Name -- Class + -> [LFamilyDecl GhcPs] + -> RnM ([LFamilyDecl GhcRn], FreeVars) +rnATDecls cls at_decls + = rnList (rnFamDecl (Just cls)) at_decls + +rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames + decl GhcPs -> -- an instance. rnTyFamInstDecl + RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl + -> Name -- Class + -> [Name] + -> [Located (decl GhcPs)] + -> RnM ([Located (decl GhcRn)], FreeVars) +-- Used for data and type family defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in GHC.Tc.TyCl.Instance +rnATInstDecls rnFun cls tv_ns at_insts + = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts + -- See Note [Renaming associated types] + +{- Note [Wildcards in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wild cards can be used in type/data family instance declarations to indicate +that the name of a type variable doesn't matter. Each wild card will be +replaced with a new unique type variable. For instance: + + type family F a b :: * + type instance F Int _ = Int + +is the same as + + type family F a b :: * + type instance F Int b = Int + +This is implemented as follows: Unnamed wildcards remain unchanged after +the renamer, and then given fresh meta-variables during typechecking, and +it is handled pretty much the same way as the ones in partial type signatures. +We however don't want to emit hole constraints on wildcards in family +instances, so we turn on PartialTypeSignatures and turn off warning flag to +let typechecker know this. +See related Note [Wildcards in visible kind application] in GHC.Tc.Gen.HsType + +Note [Unused type variables in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the flag -fwarn-unused-type-patterns is on, the compiler reports +warnings about unused type variables in type-family instances. A +tpye variable is considered used (i.e. cannot be turned into a wildcard) +when + + * it occurs on the RHS of the family instance + e.g. type instance F a b = a -- a is used on the RHS + + * it occurs multiple times in the patterns on the LHS + e.g. type instance F a a = Int -- a appears more than once on LHS + + * it is one of the instance-decl variables, for associated types + e.g. instance C (a,b) where + type T (a,b) = a + Here the type pattern in the type instance must be the same as that + for the class instance, so + type T (a,_) = a + would be rejected. So we should not complain about an unused variable b + +As usual, the warnings are not reported for type variables with names +beginning with an underscore. + +Extra-constraints wild cards are not supported in type/data family +instance declarations. + +Relevant tickets: #3699, #10586, #10982 and #11451. + +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check that the RHS of the decl mentions only type variables that are explicitly +bound on the LHS. For example, this is not ok + class C a b where + type F a x :: * + instance C (p,q) r where + type F (p,q) x = (x, r) -- BAD: mentions 'r' +c.f. #5515 + +Kind variables, on the other hand, are allowed to be implicitly or explicitly +bound. As examples, this (#9574) is acceptable: + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + -- o is implicitly bound by the kind signature + -- of the LHS type pattern ('KProxy) + type Codomain 'KProxy = NatTr (Proxy :: o -> *) +And this (#14131) is also acceptable: + data family Nat :: k -> k -> * + -- k is implicitly bound by an invisible kind pattern + newtype instance Nat :: (k -> *) -> (k -> *) -> * where + Nat :: (forall xx. f xx -> g xx) -> Nat f g +We could choose to disallow this, but then associated type families would not +be able to be as expressive as top-level type synonyms. For example, this type +synonym definition is allowed: + type T = (Nothing :: Maybe a) +So for parity with type synonyms, we also allow: + type family T :: Maybe a + type instance T = (Nothing :: Maybe a) + +All this applies only for *instance* declarations. In *class* +declarations there is no RHS to worry about, and the class variables +can all be in scope (#5862): + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature, just like 'x'. + +Although type family equations can bind type variables with explicit foralls, +it need not be the case that all variables that appear on the RHS must be bound +by a forall. For instance, the following is acceptable: + + class C a where + type T a b + instance C (Maybe a) where + type forall b. T (Maybe a) b = Either a b + +Even though `a` is not bound by the forall, this is still accepted because `a` +was previously bound by the `instance C (Maybe a)` part. (see #16116). + +In each case, the function which detects improperly bound variables on the RHS +is GHC.Tc.Validity.checkValidFamPats. + +Note [Type family equations and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most data/type family equations, the type family name used in the equation +is treated as an occurrence. For example: + + module A where + type family F a + + module B () where + import B (F) + type instance F Int = Bool + +We do not want to warn about `F` being unused in the module `B`, as the +instance constitutes a use site for `F`. The exception to this rule is closed +type families, whose equations constitute a definition, not occurrences. For +example: + + module C () where + type family CF a where + CF Char = Float + +Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is +defined but not used (#18470). + +GHC accomplishes this in rnFamInstEqn when determining the set of free +variables to return at the end. If renaming a data family or open type family +equation, we add the name of the type family constructor to the set of returned +free variables to ensure that the name is marked as an occurrence. If renaming +a closed type family equation, we avoid adding the type family constructor name +to the free variables. This is quite simple, but it is not a perfect solution. +Consider this example: + + module X () where + type family F a where + F Int = Bool + F Double = F Int + +At present, GHC will treat any use of a type family constructor on the RHS of a +type family equation as an occurrence. Since `F` is used on the RHS of the +second equation of `F`, it is treated as an occurrence, causing `F` not to be +warned about. This is not ideal, since `F` isn't exported—it really /should/ +cause a warning to be emitted. There is some discussion in #10089/#12920 about +how this limitation might be overcome, but until then, we stick to the +simplistic solution above, as it fixes the egregious bug in #18470. +-} + + +{- +********************************************************* +* * +\subsection{Stand-alone deriving declarations} +* * +********************************************************* +-} + +rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) +rnSrcDerivDecl (DerivDecl _ ty mds overlap) + = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving + ; unless standalone_deriv_ok (addErr standaloneDerivErr) + ; checkInferredVars ctxt inf_err nowc_ty + ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty + -- Check if there are any nested `forall`s or contexts, which are + -- illegal in the type of an instance declaration (see + -- Note [No nested foralls or contexts in instance types] in + -- GHC.Hs.Type). + ; addNoNestedForallsContextsErr ctxt + (text "Standalone-derived instance head") + (getLHsInstDeclHead $ dropWildCards ty') + ; warnNoDerivStrat mds' loc + ; return (DerivDecl noExtField ty' mds' overlap, fvs) } + where + ctxt = DerivDeclCtx + inf_err = Just (text "Inferred type variables are not allowed") + loc = getLoc $ hsib_body nowc_ty + nowc_ty = dropWildCards ty + +standaloneDerivErr :: SDoc +standaloneDerivErr + = hang (text "Illegal standalone deriving declaration") + 2 (text "Use StandaloneDeriving to enable this extension") + +{- +********************************************************* +* * +\subsection{Rules} +* * +********************************************************* +-} + +rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) +rnHsRuleDecls (HsRules { rds_src = src + , rds_rules = rules }) + = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules + ; return (HsRules { rds_ext = noExtField + , rds_src = src + , rds_rules = rn_rules }, fvs) } + +rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) +rnHsRuleDecl (HsRule { rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs + , rd_tmvs = tmvs + , rd_lhs = lhs + , rd_rhs = rhs }) + = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; let doc = RuleCtx (snd $ unLoc rule_name) + ; bindRuleTyVars doc tyvs $ \ tyvs' -> + bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' + ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs' + , rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs' + , rd_tmvs = tmvs' + , rd_lhs = lhs' + , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } + where + get_var :: RuleBndr GhcPs -> Located RdrName + get_var (RuleBndrSig _ v _) = v + get_var (RuleBndr _ v) = v + +bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs + -> [LRuleBndr GhcPs] -> [Name] + -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindRuleTmVars doc tyvs vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') + + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) + (n : ns) thing_inside + = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) + + bind_free_tvs = case tyvs of Nothing -> AlwaysBind + Just _ -> NeverBind + +bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs] + -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindRuleTyVars doc (Just bndrs) thing_inside + = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just) +bindRuleTyVars _ _ thing_inside = thing_inside Nothing + +{- +Note [Rule LHS validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check the shape of a rewrite rule LHS. Currently we only allow +LHSs of the form @(f e1 .. en)@, where @f@ is not one of the +@forall@'d variables. + +We used restrict the form of the 'ei' to prevent you writing rules +with LHSs with a complicated desugaring (and hence unlikely to match); +(e.g. a case expression is not allowed: too elaborate.) + +But there are legitimate non-trivial args ei, like sections and +lambdas. So it seems simmpler not to check at all, and that is why +check_e is commented out. +-} + +checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () +checkValidRule rule_name ids lhs' fv_lhs' + = do { -- Check for the form of the LHS + case (validRuleLhs ids lhs') of + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + + -- Check that LHS vars are all bound + ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + ; mapM_ (addErr . badRuleVar rule_name) bad_vars } + +validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) +-- Nothing => OK +-- Just e => Not ok, and e is the offending sub-expression +validRuleLhs foralls lhs + = checkl lhs + where + checkl = check . unLoc + + check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 + `mplus` checkl_e e2 + check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 + check (HsAppType _ e _) = checkl e + check (HsVar _ lv) + | (unLoc lv) `notElem` foralls = Nothing + check other = Just other -- Failure + + -- Check an argument + checkl_e _ = Nothing + -- Was (check_e e); see Note [Rule LHS validity checking] + +{- Commented out; see Note [Rule LHS validity checking] above + check_e (HsVar v) = Nothing + check_e (HsPar e) = checkl_e e + check_e (HsLit e) = Nothing + check_e (HsOverLit e) = Nothing + + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e other = Just other -- Fails + + checkl_es es = foldr (mplus . checkl_e) Nothing es +-} + +badRuleVar :: FastString -> Name -> SDoc +badRuleVar name var + = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, + text "Forall'd variable" <+> quotes (ppr var) <+> + text "does not appear on left hand side"] + +badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc +badRuleLhsErr name lhs bad_e + = sep [text "Rule" <+> pprRuleName name <> colon, + nest 2 (vcat [err, + text "in left-hand side:" <+> ppr lhs])] + $$ + text "LHS must be of form (f e1 .. en) where f is not forall'd" + where + err = case bad_e of + HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv) + _ -> text "Illegal expression:" <+> ppr bad_e + +{- ************************************************************** + * * + Renaming type, class, instance and role declarations +* * +***************************************************************** + +@rnTyDecl@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. + +Note [Dependency analysis of type, class, and instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected components of +type/class/instance decls, together with the role annotations for the +type/class declarations. The renamer uses strongly connected +comoponent analysis to build these groups. We do this for a number of +reasons: + +* Improve kind error messages. Consider + + data T f a = MkT f a + data S f a = MkS f (T f a) + + This has a kind error, but the error message is better if you + check T first, (fixing its kind) and *then* S. If you do kind + inference together, you might get an error reported in S, which + is jolly confusing. See #4875 + + +* Increase kind polymorphism. See GHC.Tc.TyCl + Note [Grouping of type and class declarations] + +Why do the instance declarations participate? At least two reasons + +* Consider (#11348) + + type family F a + type instance F Int = Bool + + data R = MkR (F Int) + + type Foo = 'MkR 'True + + For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't + know that unless we've looked at the type instance declaration for F + before kind-checking Foo. + +* Another example is this (#3990). + + data family Complex a + data instance Complex Double = CD {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + + data T = T {-# UNPACK #-} !(Complex Double) + + Here, to generate the right kind of unpacked implementation for T, + we must have access to the 'data instance' declaration. + +* Things become more complicated when we introduce transitive + dependencies through imported definitions, like in this scenario: + + A.hs + type family Closed (t :: Type) :: Type where + Closed t = Open t + + type family Open (t :: Type) :: Type + + B.hs + data Q where + Q :: Closed Bool -> Q + + type instance Open Int = Bool + + type S = 'Q 'True + + Somehow, we must ensure that the instance Open Int = Bool is checked before + the type synonym S. While we know that S depends upon 'Q depends upon Closed, + we have no idea that Closed depends upon Open! + + To accommodate for these situations, we ensure that an instance is checked + before every @TyClDecl@ on which it does not depend. That's to say, instances + are checked as early as possible in @tcTyAndClassDecls@. + +------------------------------------ +So much for WHY. What about HOW? It's pretty easy: + +(1) Rename the type/class, instance, and role declarations + individually + +(2) Do strongly-connected component analysis of the type/class decls, + We'll make a TyClGroup for each SCC + + In this step we treat a reference to a (promoted) data constructor + K as a dependency on its parent type. Thus + data T = K1 | K2 + data S = MkS (Proxy 'K1) + Here S depends on 'K1 and hence on its parent T. + + In this step we ignore instances; see + Note [No dependencies on data instances] + +(3) Attach roles to the appropriate SCC + +(4) Attach instances to the appropriate SCC. + We add an instance decl to SCC when: + all its free types/classes are bound in this SCC or earlier ones + +(5) We make an initial TyClGroup, with empty group_tyclds, for any + (orphan) instances that affect only imported types/classes + +Steps (3) and (4) are done by the (mapAccumL mk_group) call. + +Note [No dependencies on data instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family D a + data instance D Int = D1 + data S = MkS (Proxy 'D1) + +Here the declaration of S depends on the /data instance/ declaration +for 'D Int'. That makes things a lot more complicated, especially +if the data instance is an associated type of an enclosing class instance. +(And the class instance might have several associated type instances +with different dependency structure!) + +Ugh. For now we simply don't allow promotion of data constructors for +data instances. See Note [AFamDataCon: not promoting data family +constructors] in GHC.Tc.Utils.Env +-} + + +rnTyClDecls :: [TyClGroup GhcPs] + -> RnM ([TyClGroup GhcRn], FreeVars) +-- Rename the declarations and do dependency analysis on them +rnTyClDecls tycl_ds + = do { -- Rename the type/class, instance, and role declaraations + ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds) + ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) + ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) + ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) + ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) + + -- Do SCC analysis on the type/class decls + ; rdr_env <- getGlobalRdrEnv + ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs + role_annot_env = mkRoleAnnotEnv role_annots + (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs + + inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs + (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map + + first_group + | null init_inst_ds = [] + | otherwise = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = init_inst_ds }] + + (final_inst_ds, groups) + = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs + + all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs kisigs_w_fvs + + all_groups = first_group ++ groups + + ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map + $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds ) + + ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) + ; return (all_groups, all_fvs) } + where + mk_group :: RoleAnnotEnv + -> KindSigEnv + -> InstDeclFreeVarsMap + -> SCC (LTyClDecl GhcRn) + -> (InstDeclFreeVarsMap, TyClGroup GhcRn) + mk_group role_env kisig_env inst_map scc + = (inst_map', group) + where + tycl_ds = flattenSCC scc + bndrs = map (tcdName . unLoc) tycl_ds + roles = getRoleAnnots bndrs role_env + kisigs = getKindSigs bndrs kisig_env + (inst_ds, inst_map') = getInsts bndrs inst_map + group = TyClGroup { group_ext = noExtField + , group_tyclds = tycl_ds + , group_kisigs = kisigs + , group_roles = roles + , group_instds = inst_ds } + +-- | Free variables of standalone kind signatures. +newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) + +lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars +lookupKindSig_FV_Env (KindSig_FV_Env e) name + = fromMaybe emptyFVs (lookupNameEnv e name) + +-- | Standalone kind signatures. +type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) + +mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) +mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) + where + kisig_env = mapNameEnv fst compound_env + kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) + compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) + = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs + +getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] +getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs + +rnStandaloneKindSignatures + :: NameSet -- names of types and classes in the current TyClGroup + -> [LStandaloneKindSig GhcPs] + -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] +rnStandaloneKindSignatures tc_names kisigs + = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs + get_name = standaloneKindSigName . unLoc + ; mapM_ dupKindSig_Err dup_kisigs + ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups + } + +rnStandaloneKindSignature + :: NameSet -- names of types and classes in the current TyClGroup + -> StandaloneKindSig GhcPs + -> RnM (StandaloneKindSig GhcRn, FreeVars) +rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) + = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures + ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr + ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v + ; let doc = StandaloneKindSigCtx (ppr v) + ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki + ; return (StandaloneKindSig noExtField new_v new_ki, fvs) + } + where + standaloneKiSigErr :: SDoc + standaloneKiSigErr = + hang (text "Illegal standalone kind signature") + 2 (text "Did you mean to enable StandaloneKindSignatures?") + +depAnalTyClDecls :: GlobalRdrEnv + -> KindSig_FV_Env + -> [(LTyClDecl GhcRn, FreeVars)] + -> [SCC (LTyClDecl GhcRn)] +-- See Note [Dependency analysis of type, class, and instance decls] +depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs + = stronglyConnCompFromEdgedVerticesUniq edges + where + edges :: [ Node Name (LTyClDecl GhcRn) ] + edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) + | (d, fvs) <- ds_w_fvs, + let { name = tcdName (unLoc d) + ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name + ; deps = fvs `plusFV` kisig_fvs + } + ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic + -- even if the edges are in nondeterministic order as explained + -- in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + +toParents :: GlobalRdrEnv -> NameSet -> NameSet +toParents rdr_env ns + = nonDetStrictFoldUniqSet add emptyNameSet ns + -- It's OK to use a non-deterministic fold because we immediately forget the + -- ordering by creating a set + where + add n s = extendNameSet s (getParent rdr_env n) + +getParent :: GlobalRdrEnv -> Name -> Name +getParent rdr_env n + = case lookupGRE_Name rdr_env n of + Just gre -> case gre_par gre of + ParentIs { par_is = p } -> p + FldParent { par_is = p } -> p + _ -> n + Nothing -> n + + +{- ****************************************************** +* * + Role annotations +* * +****************************************************** -} + +-- | Renames role annotations, returning them as the values in a NameEnv +-- and checks for duplicate role annotations. +-- It is quite convenient to do both of these in the same place. +-- See also Note [Role annotations in the renamer] +rnRoleAnnots :: NameSet + -> [LRoleAnnotDecl GhcPs] + -> RnM [LRoleAnnotDecl GhcRn] +rnRoleAnnots tc_names role_annots + = do { -- Check for duplicates *before* renaming, to avoid + -- lumping together all the unboundNames + let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots + get_name = roleAnnotDeclName . unLoc + ; mapM_ dupRoleAnnotErr dup_annots + ; mapM (wrapLocM rn_role_annot1) no_dups } + where + rn_role_annot1 (RoleAnnotDecl _ tycon roles) + = do { -- the name is an *occurrence*, but look it up only in the + -- decls defined in this group (see #10263) + tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) + (text "role annotation") + tycon + ; return $ RoleAnnotDecl noExtField tycon' roles } + +dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () +dupRoleAnnotErr list + = addErrAt loc $ + hang (text "Duplicate role annotations for" <+> + quotes (ppr $ roleAnnotDeclName first_decl) <> colon) + 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L loc first_decl) :| _) = sorted_list + + pp_role_annot (L loc decl) = hang (ppr decl) + 4 (text "-- written at" <+> ppr loc) + + cmp_loc = SrcLoc.leftmost_smallest `on` getLoc + +dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () +dupKindSig_Err list + = addErrAt loc $ + hang (text "Duplicate standalone kind signatures for" <+> + quotes (ppr $ standaloneKindSigName first_decl) <> colon) + 2 (vcat $ map pp_kisig $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L loc first_decl) :| _) = sorted_list + + pp_kisig (L loc decl) = + hang (ppr decl) 4 (text "-- written at" <+> ppr loc) + + cmp_loc = SrcLoc.leftmost_smallest `on` getLoc + +{- Note [Role annotations in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must ensure that a type's role annotation is put in the same group as the +proper type declaration. This is because role annotations are needed during +type-checking when creating the type's TyCon. So, rnRoleAnnots builds a +NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that +type, if any. Then, this map can be used to add the role annotations to the +groups after dependency analysis. + +This process checks for duplicate role annotations, where we must be careful +to do the check *before* renaming to avoid calling all unbound names duplicates +of one another. + +The renaming process, as usual, might identify and report errors for unbound +names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using +lookupGlobalOccRn led to #8485). +-} + + +{- ****************************************************** +* * + Dependency info for instances +* * +****************************************************** -} + +---------------------------------------------------------- +-- | 'InstDeclFreeVarsMap is an association of an +-- @InstDecl@ with @FreeVars@. The @FreeVars@ are +-- the tycon names that are both +-- a) free in the instance declaration +-- b) bound by this group of type/class/instance decls +type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] + +-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the +-- @FreeVars@ which are *not* the binders of a @TyClDecl@. +mkInstDeclFreeVarsMap :: GlobalRdrEnv + -> NameSet + -> [(LInstDecl GhcRn, FreeVars)] + -> InstDeclFreeVarsMap +mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs + = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) + | (inst_decl, fvs) <- inst_ds_fvs ] + +-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the +-- @InstDeclFreeVarsMap@ with these entries removed. +-- We call (getInsts tcs instd_map) when we've completed the declarations +-- for 'tcs'. The call returns (inst_decls, instd_map'), where +-- inst_decls are the instance declarations all of +-- whose free vars are now defined +-- instd_map' is the inst-decl map with 'tcs' removed from +-- the free-var set +getInsts :: [Name] -> InstDeclFreeVarsMap + -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) +getInsts bndrs inst_decl_map + = partitionWith pick_me inst_decl_map + where + pick_me :: (LInstDecl GhcRn, FreeVars) + -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) + pick_me (decl, fvs) + | isEmptyNameSet depleted_fvs = Left decl + | otherwise = Right (decl, depleted_fvs) + where + depleted_fvs = delFVs bndrs fvs + +{- ****************************************************** +* * + Renaming a type or class declaration +* * +****************************************************** -} + +rnTyClDecl :: TyClDecl GhcPs + -> RnM (TyClDecl GhcRn, FreeVars) + +-- All flavours of top-level type family declarations ("type family", "newtype +-- family", and "data family") +rnTyClDecl (FamDecl { tcdFam = fam }) + = do { (fam', fvs) <- rnFamDecl Nothing fam + ; return (FamDecl noExtField fam', fvs) } + +rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, tcdRhs = rhs }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractHsTyRdrTyVarsKindVars rhs + doc = TySynCtx tycon + ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' _ -> + do { (rhs', fvs) <- rnTySyn doc rhs + ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } + +-- "data", "newtype" declarations +rnTyClDecl (DataDecl + { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data + , dd_kindSig = kind_sig} }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractDataDefnKindVars defn + doc = TyDataCtx tycon + ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> + do { (defn', fvs) <- rnDataDefn doc defn + ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig + ; let rn_info = DataDeclRn { tcdDataCusk = cusk + , tcdFVs = fvs } + ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) + ; return (DataDecl { tcdLName = tycon' + , tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdDataDefn = defn' + , tcdDExt = rn_info }, fvs) } } + +rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFixity = fixity, + tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) + = do { lcls' <- lookupLocatedTopBndrRn lcls + ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars + + -- Tyvars scope over superclass context and method signatures + ; ((tyvars', context', fds', ats'), stuff_fvs) + <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do + -- Checks for distinct tyvars + { (context', cxt_fvs) <- rnContext cls_doc context + ; fds' <- rnFds fds + -- The fundeps have no free variables + ; (ats', fv_ats) <- rnATDecls cls' ats + ; let fvs = cxt_fvs `plusFV` + fv_ats + ; return ((tyvars', context', fds', ats'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs + + -- No need to check for duplicate associated type decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + ; let sig_rdr_names_w_locs = + [op | L _ (ClassOpSig _ False ops _) <- sigs + , op <- ops] + ; checkDupRdrNames sig_rdr_names_w_locs + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + ; (mbinds', sigs', meth_fvs) + <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs + -- No need to check for duplicate method signatures + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + -- and the methods are already in scope + + -- Haddock docs + ; docs' <- mapM (wrapLocM rnDocDecl) docs + + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + tcdTyVars = tyvars', tcdFixity = fixity, + tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = docs', tcdCExt = all_fvs }, + all_fvs ) } + where + cls_doc = ClassDeclCtx lcls + +-- Does the data type declaration include a CUSK? +data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool +data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do + { -- See Note [Unlifted Newtypes and CUSKs], and for a broader + -- picture, see Note [Implementation of UnliftedNewtypes]. + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let non_cusk_newtype + | NewType <- new_or_data = + unlifted_newtypes && isNothing kind_sig + | otherwise = False + -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls + ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype + } + +{- Note [Unlifted Newtypes and CUSKs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unlifted newtypes are enabled, a newtype must have a kind signature +in order to be considered have a CUSK. This is because the flow of +kind inference works differently. Consider: + + newtype Foo = FooC Int + +When UnliftedNewtypes is disabled, we decide that Foo has kind +`TYPE 'LiftedRep` without looking inside the data constructor. So, we +can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, +we fill in the kind of Foo as a metavar that gets solved by unification +with the kind of the field inside FooC (that is, Int, whose kind is +`TYPE 'LiftedRep`). But since we have to look inside the data constructors +to figure out the kind signature of Foo, it does not have a CUSK. + +See Note [Implementation of UnliftedNewtypes] for where this fits in to +the broader picture of UnliftedNewtypes. +-} + +-- "type" and "type instance" declarations +rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnTySyn doc rhs = rnLHsType doc rhs + +rnDataDefn :: HsDocContext -> HsDataDefn GhcPs + -> RnM (HsDataDefn GhcRn, FreeVars) +rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context, dd_cons = condecls + , dd_kindSig = m_sig, dd_derivs = derivs }) + = do { checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta doc) + + ; (m_sig', sig_fvs) <- case m_sig of + Just sig -> first Just <$> rnLHsKind doc sig + Nothing -> return (Nothing, emptyFVs) + ; (context', fvs1) <- rnContext doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs + ; return ( HsDataDefn { dd_ext = noExtField + , dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context', dd_kindSig = m_sig' + , dd_cons = condecls' + , dd_derivs = derivs' } + , all_fvs ) + } + where + h98_style = case condecls of -- Note [Stupid theta] + (L _ (ConDeclGADT {})) : _ -> False + _ -> True + + rn_derivs (L loc ds) + = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies + ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) + multipleDerivClausesErr + ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds + ; return (L loc ds', fvs) } + +warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) + -> SrcSpan + -> RnM () +warnNoDerivStrat mds loc + = do { dyn_flags <- getDynFlags + ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ + case mds of + Nothing -> addWarnAt + (Reason Opt_WarnMissingDerivingStrategies) + loc + (if xopt LangExt.DerivingStrategies dyn_flags + then no_strat_warning + else no_strat_warning $+$ deriv_strat_nenabled + ) + _ -> pure () + } + where + no_strat_warning :: SDoc + no_strat_warning = text "No deriving strategy specified. Did you want stock" + <> text ", newtype, or anyclass?" + deriv_strat_nenabled :: SDoc + deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy." + +rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs + -> RnM (LHsDerivingClause GhcRn, FreeVars) +rnLHsDerivingClause doc + (L loc (HsDerivingClause + { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs + , deriv_clause_tys = L loc' dct })) + = do { (dcs', dct', fvs) + <- rnLDerivStrategy doc dcs $ mapFvRn rn_clause_pred dct + ; warnNoDerivStrat dcs' loc + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = L loc' dct' }) + , fvs ) } + where + rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) + rn_clause_pred pred_ty = do + let inf_err = Just (text "Inferred type variables are not allowed") + checkInferredVars doc inf_err pred_ty + ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty + -- Check if there are any nested `forall`s, which are illegal in a + -- `deriving` clause. + -- See Note [No nested foralls or contexts in instance types] + -- (Wrinkle: Derived instances) in GHC.Hs.Type. + addNoNestedForallsContextsErr doc (text "Derived class type") + (getLHsInstDeclHead pred_ty') + pure ret + +rnLDerivStrategy :: forall a. + HsDocContext + -> Maybe (LDerivStrategy GhcPs) + -> RnM (a, FreeVars) + -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) +rnLDerivStrategy doc mds thing_inside + = case mds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpan loc $ do + (ds', thing, fvs) <- rn_deriv_strat ds + pure (Just (L loc ds'), thing, fvs) + where + rn_deriv_strat :: DerivStrategy GhcPs + -> RnM (DerivStrategy GhcRn, a, FreeVars) + rn_deriv_strat ds = do + let extNeeded :: LangExt.Extension + extNeeded + | ViaStrategy{} <- ds + = LangExt.DerivingVia + | otherwise + = LangExt.DerivingStrategies + + unlessXOptM extNeeded $ + failWith $ illegalDerivStrategyErr ds + + case ds of + StockStrategy -> boring_case StockStrategy + AnyclassStrategy -> boring_case AnyclassStrategy + NewtypeStrategy -> boring_case NewtypeStrategy + ViaStrategy via_ty -> + do checkInferredVars doc inf_err via_ty + (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty + let HsIB { hsib_ext = via_imp_tvs + , hsib_body = via_body } = via_ty' + (via_exp_tv_bndrs, via_rho) = splitLHsForAllTyInvis_KP via_body + via_exp_tvs = maybe [] hsLTyVarNames via_exp_tv_bndrs + via_tvs = via_imp_tvs ++ via_exp_tvs + -- Check if there are any nested `forall`s, which are illegal in a + -- `via` type. + -- See Note [No nested foralls or contexts in instance types] + -- (Wrinkle: Derived instances) in GHC.Hs.Type. + addNoNestedForallsContextsErr doc + (quotes (text "via") <+> text "type") via_rho + (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside + pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) + + inf_err = Just (text "Inferred type variables are not allowed") + + boring_case :: ds -> RnM (ds, a, FreeVars) + boring_case ds = do + (thing, fvs) <- thing_inside + pure (ds, thing, fvs) + +badGadtStupidTheta :: HsDocContext -> SDoc +badGadtStupidTheta _ + = vcat [text "No context is allowed on a GADT-style data declaration", + text "(You can put a context on each constructor, though.)"] + +illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc +illegalDerivStrategyErr ds + = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds + , text enableStrategy ] + + where + enableStrategy :: String + enableStrategy + | ViaStrategy{} <- ds + = "Use DerivingVia to enable this extension" + | otherwise + = "Use DerivingStrategies to enable this extension" + +multipleDerivClausesErr :: SDoc +multipleDerivClausesErr + = vcat [ text "Illegal use of multiple, consecutive deriving clauses" + , text "Use DerivingStrategies to allow this" ] + +rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested + -- inside an *class decl* for cls + -- used for associated types + -> FamilyDecl GhcPs + -> RnM (FamilyDecl GhcRn, FreeVars) +rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdFixity = fixity + , fdInfo = info, fdResultSig = res_sig + , fdInjectivityAnn = injectivity }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; ((tyvars', res_sig', injectivity'), fv1) <- + bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ -> + do { let rn_sig = rnFamResultSig doc + ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig + ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') + injectivity + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } + ; (info', fv2) <- rn_info info + ; return (FamilyDecl { fdExt = noExtField + , fdLName = tycon', fdTyVars = tyvars' + , fdFixity = fixity + , fdInfo = info', fdResultSig = res_sig' + , fdInjectivityAnn = injectivity' } + , fv1 `plusFV` fv2) } + where + doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars res_sig + + ---------------------- + rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) + rn_info (ClosedTypeFamily (Just eqns)) + = do { (eqns', fvs) + <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns + -- no class context + ; return (ClosedTypeFamily (Just eqns'), fvs) } + rn_info (ClosedTypeFamily Nothing) + = return (ClosedTypeFamily Nothing, emptyFVs) + rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info DataFamily = return (DataFamily, emptyFVs) + +rnFamResultSig :: HsDocContext + -> FamilyResultSig GhcPs + -> RnM (FamilyResultSig GhcRn, FreeVars) +rnFamResultSig _ (NoSig _) + = return (NoSig noExtField, emptyFVs) +rnFamResultSig doc (KindSig _ kind) + = do { (rndKind, ftvs) <- rnLHsKind doc kind + ; return (KindSig noExtField rndKind, ftvs) } +rnFamResultSig doc (TyVarSig _ tvbndr) + = do { -- `TyVarSig` tells us that user named the result of a type family by + -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to + -- be sure that the supplied result name is not identical to an + -- already in-scope type variable from an enclosing class. + -- + -- Example of disallowed declaration: + -- class C a b where + -- type F b = a | a -> b + rdr_env <- getLocalRdrEnv + ; let resName = hsLTyVarName tvbndr + ; when (resName `elemLocalRdrEnv` rdr_env) $ + addErrAt (getLoc tvbndr) $ + (hsep [ text "Type variable", quotes (ppr resName) <> comma + , text "naming a type family result," + ] $$ + text "shadows an already bound type variable") + + ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for + -- scoping checks that are irrelevant here + tvbndr $ \ tvbndr' -> + return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) } + +-- Note [Renaming injectivity annotation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During renaming of injectivity annotation we have to make several checks to +-- make sure that it is well-formed. At the moment injectivity annotation +-- consists of a single injectivity condition, so the terms "injectivity +-- annotation" and "injectivity condition" might be used interchangeably. See +-- Note [Injectivity annotation] for a detailed discussion of currently allowed +-- injectivity annotations. +-- +-- Checking LHS is simple because the only type variable allowed on the LHS of +-- injectivity condition is the variable naming the result in type family head. +-- Example of disallowed annotation: +-- +-- type family Foo a b = r | b -> a +-- +-- Verifying RHS of injectivity consists of checking that: +-- +-- 1. only variables defined in type family head appear on the RHS (kind +-- variables are also allowed). Example of disallowed annotation: +-- +-- type family Foo a = r | r -> b +-- +-- 2. for associated types the result variable does not shadow any of type +-- class variables. Example of disallowed annotation: +-- +-- class Foo a b where +-- type F a = b | b -> a +-- +-- Breaking any of these assumptions results in an error. + +-- | Rename injectivity annotation. Note that injectivity annotation is just the +-- part after the "|". Everything that appears before it is renamed in +-- rnFamDecl. +rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in + -- type family head + -> LFamilyResultSig GhcRn -- ^ Result signature + -> LInjectivityAnn GhcPs -- ^ Injectivity annotation + -> RnM (LInjectivityAnn GhcRn) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn injFrom injTo)) + = do + { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + <- askNoErrs $ + bindLocalNames [hsLTyVarName resTv] $ + -- The return type variable scopes over the injectivity annotation + -- e.g. type family F a = (r::*) | r -> a + do { injFrom' <- rnLTyVar injFrom + ; injTo' <- mapM rnLTyVar injTo + ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } + + ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs + resName = hsLTyVarName resTv + -- See Note [Renaming injectivity annotation] + lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) + rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames + + -- if renaming of type variables ended with errors (eg. there were + -- not-in-scope variables) don't check the validity of injectivity + -- annotation. This gives better error messages. + ; when (noRnErrors && not lhsValid) $ + addErrAt (getLoc injFrom) + ( vcat [ text $ "Incorrect type variable on the LHS of " + ++ "injectivity condition" + , nest 5 + ( vcat [ text "Expected :" <+> ppr resName + , text "Actual :" <+> ppr injFrom ])]) + + ; when (noRnErrors && not (Set.null rhsValid)) $ + do { let errorVars = Set.toList rhsValid + ; addErrAt srcSpan $ ( hsep + [ text "Unknown type variable" <> plural errorVars + , text "on the RHS of injectivity condition:" + , interpp'SP errorVars ] ) } + + ; return injDecl' } + +-- We can only hit this case when the user writes injectivity annotation without +-- naming the result: +-- +-- type family F a | result -> a +-- type family F a :: * | result -> a +-- +-- So we rename injectivity annotation like we normally would except that +-- this time we expect "result" to be reported not in scope by rnLTyVar. +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = + setSrcSpan srcSpan $ do + (injDecl', _) <- askNoErrs $ do + injFrom' <- rnLTyVar injFrom + injTo' <- mapM rnLTyVar injTo + return $ L srcSpan (InjectivityAnn injFrom' injTo') + return $ injDecl' + +{- +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +#3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True +-} + + +{- ***************************************************** +* * + Support code for type/data declarations +* * +***************************************************** -} + +----------------- +rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) +rnConDecls = mapFvRn (wrapLocFstM rnConDecl) + +rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) +rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt, con_args = args + , con_doc = mb_doc }) + = do { _ <- addLocM checkConName name + ; new_name <- lookupLocatedTopBndrRn name + ; mb_doc' <- rnMbLHsDoc mb_doc + + -- We bind no implicit binders here; this is just like + -- a nested HsForAllTy. E.g. consider + -- data T a = forall (b::k). MkT (...) + -- The 'k' will already be in scope from the bindHsQTyVars + -- for the data decl itself. So we'll get + -- data T {k} a = ... + -- And indeed we may later discover (a::k). But that's the + -- scoping we get. So no implicit binders at the existential forall + + ; let ctxt = ConDeclCtx [new_name] + ; bindLHsTyVarBndrs ctxt WarnUnusedForalls + Nothing ex_tvs $ \ new_ex_tvs -> + do { (new_context, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args + ; let all_fvs = fvs1 `plusFV` fvs2 + ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat + [ text "ex_tvs:" <+> ppr ex_tvs + , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + + ; return (decl { con_ext = noExtField + , con_name = new_name, con_ex_tvs = new_ex_tvs + , con_mb_cxt = new_context, con_args = new_args + , con_doc = mb_doc' }, + all_fvs) }} + +rnConDecl decl@(ConDeclGADT { con_names = names + , con_forall = L _ explicit_forall + , con_qvars = explicit_tkvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty + , con_doc = mb_doc }) + = do { mapM_ (addLocM checkConName) names + ; new_names <- mapM lookupLocatedTopBndrRn names + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; let theta = hsConDeclTheta mcxt + arg_tys = hsConDeclArgTys args + + -- We must ensure that we extract the free tkvs in left-to-right + -- order of their appearance in the constructor type. + -- That order governs the order the implicitly-quantified type + -- variable, and hence the order needed for visible type application + -- See #14808. + ; implicit_bndrs <- forAllOrNothing explicit_forall + $ extractHsTvBndrs explicit_tkvs + $ extractHsTysRdrTyVars theta + $ extractHsScaledTysRdrTyVars arg_tys + $ extractHsTysRdrTyVars [res_ty] [] + + ; let ctxt = ConDeclCtx new_names + + ; rnImplicitBndrs Nothing implicit_bndrs $ \ implicit_tkvs -> + bindLHsTyVarBndrs ctxt WarnUnusedForalls + Nothing explicit_tkvs $ \ explicit_tkvs -> + do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args + ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty + + -- Ensure that there are no nested `forall`s or contexts, per + -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) + -- in GHC.Hs.Type. + ; addNoNestedForallsContextsErr ctxt + (text "GADT constructor type signature") new_res_ty + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + + ; traceRn "rnConDecl (ConDeclGADT)" + (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) + ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names + , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt + , con_args = new_args, con_res_ty = new_res_ty + , con_doc = mb_doc' }, + all_fvs) } } + +rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) + -> RnM (Maybe (LHsContext GhcRn), FreeVars) +rnMbContext _ Nothing = return (Nothing, emptyFVs) +rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt + ; return (Just ctx',fvs) } + +rnConDeclDetails + :: Name + -> HsDocContext + -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs]) + -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]), + FreeVars) +rnConDeclDetails _ doc (PrefixCon tys) + = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys + ; return (PrefixCon new_tys, fvs) } + +rnConDeclDetails _ doc (InfixCon ty1 ty2) + = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1 + ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } + +rnConDeclDetails con doc (RecCon (L l fields)) + = do { fls <- lookupConstructorFields con + ; (new_fields, fvs) <- rnConDeclFields doc fls fields + -- No need to check for duplicate fields + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + ; return (RecCon (L l new_fields), fvs) } + +------------------------------------------------- + +-- | Brings pattern synonym names and also pattern synonym selectors +-- from record pattern synonyms into scope. +extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv + -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a +extendPatSynEnv val_decls local_fix_env thing = do { + names_with_fls <- new_ps val_decls + ; let pat_syn_bndrs = concat [ name: map flSelector fields + | (name, fields) <- names_with_fls ] + ; let avails = map avail pat_syn_bndrs + ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env + + ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls + final_gbl_env = gbl_env { tcg_field_env = field_env' } + ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } + where + new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] + new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps _ = panic "new_ps" + + new_ps' :: LHsBindLR GhcPs GhcPs + -> [(Name, [FieldLabel])] + -> TcM [(Name, [FieldLabel])] + new_ps' bind names + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + let rnames = map recordPatSynSelectorId as + mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs + mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) + field_occs = map mkFieldOcc rnames + flds <- mapM (newRecordSelector False [bnd_name]) field_occs + return ((bnd_name, flds): names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + return ((bnd_name, []): names) + | otherwise + = return names + +{- +********************************************************* +* * +\subsection{Support code to rename types} +* * +********************************************************* +-} + +rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] +rnFds fds + = mapM (wrapLocM rn_fds) fds + where + rn_fds (tys1, tys2) + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 + ; return (tys1', tys2') } + +rnHsTyVars :: [Located RdrName] -> RnM [Located Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs + +rnHsTyVar :: Located RdrName -> RnM (Located Name) +rnHsTyVar (L l tyvar) = do + tyvar' <- lookupOccRn tyvar + return (L l tyvar') + +{- +********************************************************* +* * + findSplice +* * +********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes +-} + +findSplice :: [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) + +-- #10047: Declaration QuasiQuoters are expanded immediately, without +-- causing a group split +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds + = do { (ds', _) <- rnTopSpliceDecls qq + ; addl gp (ds' ++ ds) + } + +add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one + -- (i.e. a naked top level expression) + case flag of + ExplicitSplice -> return () + ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell + ; unless th_on $ setSrcSpan loc $ + failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice = text "Parse error: module header, import declaration" + $$ text "or top-level declaration expected." + -- The compiler should suggest the above, and not using + -- TemplateHaskell since the former suggestion is more + -- relevant to the larger base of users. + -- See #12146 for discussion. + +-- Class declarations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds + +-- Standalone kind signatures: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds + +add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- Role annotations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds + +-- NB instance declarations go into TyClGroups. We throw them into the first +-- group, just as we do for the TyClD case. The renamer will go on to group +-- and order them later. +add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD _ d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_tycld d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [d] + , group_kisigs = [] + , group_roles = [] + , group_instds = [] + } + ] +add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) + = ds { group_tyclds = d : tyclds } : dss + +add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_instd d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = [d] + } + ] +add_instd d (ds@(TyClGroup { group_instds = instds }):dss) + = ds { group_instds = d : instds } : dss + +add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_role_annot d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [d] + , group_instds = [] + } + ] +add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) + = tycls { group_roles = d : roles } : rest + +add_kisig :: LStandaloneKindSig (GhcPass p) + -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] +add_kisig d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [d] + , group_roles = [] + , group_instds = [] + } + ] +add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) + = tycls { group_kisigs = d : kisigs } : rest + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs +add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind" + +add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) +add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig" diff --git a/GHC/Rename/Names.hs b/GHC/Rename/Names.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Names.hs @@ -0,0 +1,1839 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Extracting imported and top-level names in scope +-} + +{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Rename.Names ( + rnImports, getLocalNonValBinders, newRecordSelector, + extendGlobalRdrEnvRn, + gresFromAvails, + calculateAvails, + reportUnusedNames, + checkConName, + mkChildEnv, + findChildren, + dodgyMsg, + dodgyMsgInsert, + findImportUsage, + getMinimalImports, + printMinimalImports, + ImportDeclUsage + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core.TyCo.Ppr +import GHC.Hs +import GHC.Tc.Utils.Env +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) +import GHC.Iface.Load ( loadSrcInterface ) +import GHC.Tc.Utils.Monad +import GHC.Builtin.Names +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.FieldLabel +import GHC.Driver.Types +import GHC.Types.Name.Reader +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) ) +import GHC.Utils.Misc as Utils +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Types.Id +import GHC.Core.Type +import GHC.Core.PatSyn +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Either ( partitionEithers, isRight, rights ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Ord ( comparing ) +import Data.List ( partition, (\\), find, sortBy ) +import Data.Function ( on ) +import qualified Data.Set as S +import System.FilePath (()) + +import System.IO + +{- +************************************************************************ +* * +\subsection{rnImports} +* * +************************************************************************ + +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependcy +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompilation being triggered: package trust. So we must check that all +packages a module transitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +GHC.Driver.Main.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but saying yes also makes sense. The difference is, if a +module M that doesn't use Safe Haskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. +-} + +-- | Process Import Decls. See 'rnImportDecl' for a description of what +-- the return types represent. +-- Note: Do the non SOURCE ones first, so that we get a helpful warning +-- for SOURCE ones that are unnecessary +rnImports :: [LImportDecl GhcPs] + -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImports imports = do + tcg_env <- getGblEnv + -- NB: want an identity module here, because it's OK for a signature + -- module to import from its implementor + let this_mod = tcg_mod tcg_env + let (source, ordinary) = partition is_source_import imports + is_source_import d = ideclSource (unLoc d) == IsBoot + stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary + stuff2 <- mapAndReportM (rnImportDecl this_mod) source + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) + return (decls, rdr_env, imp_avails, hpc_usage) + + where + -- See Note [Combining ImportAvails] + combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine ss = + let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr + plus + ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) + ss + in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, + hpc_usage) + + plus (decl, gbl_env1, imp_avails1, hpc_usage1) + (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set) + = ( decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1' `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2, + extendModuleSetList finsts_set new_finsts ) + where + imp_avails1' = imp_avails1 { imp_finsts = [] } + new_finsts = imp_finsts imp_avails1 + +{- +Note [Combining ImportAvails] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +imp_finsts in ImportAvails is a list of family instance modules +transitively depended on by an import. imp_finsts for a currently +compiled module is a union of all the imp_finsts of imports. +Computing the union of two lists of size N is O(N^2) and if we +do it to M imports we end up with O(M*N^2). That can get very +expensive for bigger module hierarchies. + +Union can be optimized to O(N log N) if we use a Set. +imp_finsts is converted back and forth between dep_finsts, so +changing a type of imp_finsts means either paying for the conversions +or changing the type of dep_finsts as well. + +I've measured that the conversions would cost 20% of allocations on my +test case, so that can be ruled out. + +Changing the type of dep_finsts forces checkFamInsts to +get the module lists in non-deterministic order. If we wanted to restore +the deterministic order, we'd have to sort there, which is an additional +cost. As far as I can tell, using a non-deterministic order is fine there, +but that's a brittle nonlocal property which I'd like to avoid. + +Additionally, dep_finsts is read from an interface file, so its "natural" +type is a list. Which makes it a natural type for imp_finsts. + +Since rnImports.combine is really the only place that would benefit from +it being a Set, it makes sense to optimize the hot loop in rnImports.combine +without changing the representation. + +So here's what we do: instead of naively merging ImportAvails with +plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts +and compute the union on the side using Sets. When we're done, we can +convert it back to a list. One nice side effect of this approach is that +if there's a lot of overlap in the imp_finsts of imports, the +Set doesn't really need to grow and we don't need to allocate. + +Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in +23s before, and 11s after. +-} + + + +-- | Given a located import declaration @decl@ from @this_mod@, +-- calculate the following pieces of information: +-- +-- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in +-- the entity lists have been resolved into 'Name's, +-- +-- 2. A 'GlobalRdrEnv' representing the new identifiers that were +-- brought into scope (taking into account module qualification +-- and hiding), +-- +-- 3. 'ImportAvails' summarizing the identifiers that were imported +-- by this declaration, and +-- +-- 4. A boolean 'AnyHpcUsage' which is true if the imported module +-- used HPC. +rnImportDecl :: Module -> LImportDecl GhcPs + -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImportDecl this_mod + (L loc decl@(ImportDecl { ideclExt = noExtField + , ideclName = loc_imp_mod_name + , ideclPkgQual = mb_pkg + , ideclSource = want_boot, ideclSafe = mod_safe + , ideclQualified = qual_style, ideclImplicit = implicit + , ideclAs = as_mod, ideclHiding = imp_details })) + = setSrcSpan loc $ do + + when (isJust mb_pkg) $ do + pkg_imports <- xoptM LangExt.PackageImports + when (not pkg_imports) $ addErr packageImportErr + + let qual_only = isImportDeclQualified qual_style + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + let imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> text "is directly imported" + + -- Check for self-import, which confuses the typechecker (#9032) + -- ghc --make rejects self-import cycles already, but batch-mode may not + -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid + -- typechecker crashes. (Indirect self imports are not caught until + -- GHC.IfaceToCore, see #10337 tracking how to make this error better.) + -- + -- Originally, we also allowed 'import {-# SOURCE #-} M', but this + -- caused bug #10182: in one-shot mode, we should never load an hs-boot + -- file for the module we are compiling into the EPS. In principle, + -- it should be possible to support this mode of use, but we would have to + -- extend Provenance to support a local definition in a qualified location. + -- For now, we don't support it, but see #10336 + when (imp_mod_name == moduleName this_mod && + (case mb_pkg of -- If we have import "" M, then we should + -- check that "" is "this" (which is magic) + -- or the name of this_mod's package. Yurgh! + -- c.f. GHC.findModule, and #9997 + Nothing -> True + Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || + fsToUnit pkg_fs == moduleUnit this_mod)) + (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) + + -- Check for a missing import list (Opt_WarnMissingImportList also + -- checks for T(..) items but that is done in checkDodgyImport below) + case imp_details of + Just (False, _) -> return () -- Explicit import list + _ | implicit -> return () -- Do not bleat for implicit imports + | qual_only -> return () + | otherwise -> whenWOptM Opt_WarnMissingImportList $ + addWarn (Reason Opt_WarnMissingImportList) + (missingImportListWarn imp_mod_name) + + iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) + + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + WARN( (want_boot == NotBoot) && (mi_boot iface == IsBoot), ppr imp_mod_name ) do + + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports. + -- + -- in --make and GHCi, the compilation manager checks for this, + -- and indeed we shouldn't do it here because the existence of + -- the non-boot module depends on the compilation order, which + -- is not deterministic. The hs-boot test can show this up. + dflags <- getDynFlags + warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) + (warnRedundantSourceImport imp_mod_name) + when (mod_safe && not (safeImportsOn dflags)) $ + addErr (text "safe import can't be used as Safe Haskell isn't on!" + $+$ ptext (sLit $ "please enable Safe Haskell through either " + ++ "Safe, Trustworthy or Unsafe")) + + let + qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + + -- filter the imports according to the import declaration + (new_imp_details, gres) <- filterImports iface imp_spec imp_details + + -- for certain error messages, we’d like to know what could be imported + -- here, if everything were imported + potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing + + let gbl_env = mkGlobalRdrEnv gres + + is_hiding | Just (True,_) <- imp_details = True + | otherwise = False + + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit && safeDirectImpsReq dflags) + || (implicit && safeImplicitImpsReq dflags) + + let imv = ImportedModsVal + { imv_name = qual_mod_name + , imv_span = loc + , imv_is_safe = mod_safe' + , imv_is_hiding = is_hiding + , imv_all_exports = potential_gres + , imv_qualified = qual_only + } + imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv) + + -- Complain if we import a deprecated module + whenWOptM Opt_WarnWarningsDeprecations ( + case (mi_warns iface) of + WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations) + (moduleWarn imp_mod_name txt) + _ -> return () + ) + + -- Complain about -Wcompat-unqualified-imports violations. + warnUnqualifiedImport decl iface + + let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe' + , ideclHiding = new_imp_details }) + + return (new_imp_decl, gbl_env, imports, mi_hpc iface) + +-- | Calculate the 'ImportAvails' induced by an import of a particular +-- interface, but without 'imp_mods'. +calculateAvails :: DynFlags + -> ModIface + -> IsSafeImport + -> IsBootInterface + -> ImportedBy + -> ImportAvails +calculateAvails dflags iface mod_safe' want_boot imported_by = + let imp_mod = mi_module iface + imp_sem_mod= mi_semantic_module iface + orph_iface = mi_orphan (mi_final_exts iface) + has_finsts = mi_finsts (mi_final_exts iface) + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this involves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. + + + -- Compute new transitive dependencies + -- + -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module + -- itself, but we DO need to include this module in 'imp_orphs' and + -- 'imp_finsts' if it defines an orphan or instance family; thus the + -- orph_iface/has_iface tests. + + orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) + imp_sem_mod : dep_orphs deps + | otherwise = dep_orphs deps + + finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) + imp_sem_mod : dep_finsts deps + | otherwise = dep_finsts deps + + pkg = moduleUnit (mi_module iface) + ipkg = toUnitId pkg + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + + (dependent_mods, dependent_pkgs, pkg_trust_req) + | pkg == homeUnit dflags = + -- Imported module is from the home package + -- Take its dependent modules and add imp_mod itself + -- Take its dependent packages unchanged + -- + -- NB: (dep_mods deps) might include a hi-boot file + -- for the module being compiled, CM. Do *not* filter + -- this out (as we used to), because when we've + -- finished dealing with the direct imports we want to + -- know if any of them depended on CM.hi-boot, in + -- which case we should do the hi-boot consistency + -- check. See GHC.Iface.Load.loadHiBootInterface + ( GWIB { gwib_mod = moduleName imp_mod, gwib_isBoot = want_boot } : dep_mods deps + , dep_pkgs deps + , ptrust + ) + + | otherwise = + -- Imported module is from another package + -- Dump the dependent modules + -- Add the package imp_mod comes from to the dependent packages + ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps)) + , ppr ipkg <+> ppr (dep_pkgs deps) ) + ([], (ipkg, False) : dep_pkgs deps, False) + + in ImportAvails { + imp_mods = unitModuleEnv (mi_module iface) [imported_by], + imp_orphs = orphans, + imp_finsts = finsts, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = S.fromList . map fst $ dependent_pkgs, + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = if mod_safe' + then S.fromList . map fst $ filter snd dependent_pkgs + else S.empty, + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req + } + + +-- | Issue a warning if the user imports Data.List without either an import +-- list or `qualified`. This is part of the migration plan for the +-- `Data.List.singleton` proposal. See #17244. +warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () +warnUnqualifiedImport decl iface = + whenWOptM Opt_WarnCompatUnqualifiedImports + $ when bad_import + $ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning + where + mod = mi_module iface + loc = getLoc $ ideclName decl + + is_qual = isImportDeclQualified (ideclQualified decl) + has_import_list = + -- We treat a `hiding` clause as not having an import list although + -- it's not entirely clear this is the right choice. + case ideclHiding decl of + Just (False, _) -> True + _ -> False + bad_import = + mod `elemModuleSet` qualifiedMods + && not is_qual + && not has_import_list + + warning = vcat + [ text "To ensure compatibility with future core libraries changes" + , text "imports to" <+> ppr (ideclName decl) <+> text "should be" + , text "either qualified or have an explicit import list." + ] + + -- Modules for which we warn if we see unqualified imports + qualifiedMods = mkModuleSet [ dATA_LIST ] + + +warnRedundantSourceImport :: ModuleName -> SDoc +warnRedundantSourceImport mod_name + = text "Unnecessary {-# SOURCE #-} in the import of module" + <+> quotes (ppr mod_name) + +{- +************************************************************************ +* * +\subsection{importsFromLocalDecls} +* * +************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Note [Top-level Names in Template Haskell decl quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types + Note [Looking up Exact RdrNames] in GHC.Rename.Env + +Consider a Template Haskell declaration quotation like this: + module M where + f x = h [d| f = 3 |] +When renaming the declarations inside [d| ...|], we treat the +top level binders specially in two ways + +1. We give them an Internal Name, not (as usual) an External one. + This is done by GHC.Rename.Env.newTopSrcBinder. + +2. We make them *shadow* the outer bindings. + See Note [GlobalRdrEnv shadowing] + +3. We find out whether we are inside a [d| ... |] by testing the TH + stage. This is a slight hack, because the stage field was really + meant for the type checker, and here we are not interested in the + fields of Brack, hence the error thunks in thRnBrack. +-} + +extendGlobalRdrEnvRn :: [AvailInfo] + -> MiniFixityEnv + -> RnM (TcGblEnv, TcLclEnv) +-- Updates both the GlobalRdrEnv and the FixityEnv +-- We return a new TcLclEnv only because we might have to +-- delete some bindings from it; +-- see Note [Top-level Names in Template Haskell decl quotes] + +extendGlobalRdrEnvRn avails new_fixities + = do { (gbl_env, lcl_env) <- getEnvs + ; stage <- getStage + ; isGHCi <- getIsGHCi + ; let rdr_env = tcg_rdr_env gbl_env + fix_env = tcg_fix_env gbl_env + th_bndrs = tcl_th_bndrs lcl_env + th_lvl = thLevel stage + + -- Delete new_occs from global and local envs + -- If we are in a TemplateHaskell decl bracket, + -- we are going to shadow them + -- See Note [GlobalRdrEnv shadowing] + inBracket = isBrackStage stage + + lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs } + -- See Note [GlobalRdrEnv shadowing] + + lcl_env2 | inBracket = lcl_env_TH + | otherwise = lcl_env + + -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] + want_shadowing = isGHCi || inBracket + rdr_env1 | want_shadowing = shadowNames rdr_env new_names + | otherwise = rdr_env + + lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs + [ (n, (TopLevel, th_lvl)) + | n <- new_names ] } + + ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres + + ; let fix_env' = foldl' extend_fix_env fix_env new_gres + gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } + + ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) + ; return (gbl_env', lcl_env3) } + where + new_names = concatMap availNames avails + new_occs = map nameOccName new_names + + -- If there is a fixity decl for the gre, add it to the fixity env + extend_fix_env fix_env gre + | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) + = extendNameEnv fix_env name (FixItem occ fi) + | otherwise + = fix_env + where + name = gre_name gre + occ = greOccName gre + + new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails + new_gres = concatMap localGREsFromAvail avails + + add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv + -- Extend the GlobalRdrEnv with a LocalDef GRE + -- If there is already a LocalDef GRE with the same OccName, + -- report an error and discard the new GRE + -- This establishes INVARIANT 1 of GlobalRdrEnvs + add_gre env gre + | not (null dups) -- Same OccName defined twice + = do { addDupDeclErr (gre : dups); return env } + + | otherwise + = return (extendGlobalRdrEnv env gre) + where + occ = greOccName gre + dups = filter isDupGRE (lookupGlobalRdrEnv env occ) + -- Duplicate GREs are those defined locally with the same OccName, + -- except cases where *both* GREs are DuplicateRecordFields (#17965). + isDupGRE gre' = isLocalGRE gre' + && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') + + +{- ********************************************************************* +* * + getLocalDeclBindersd@ returns the names for an HsDecl + It's used for source code. + + *** See Note [The Naming story] in GHC.Hs.Decls **** +* * +********************************************************************* -} + +getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs + -> RnM ((TcGblEnv, TcLclEnv), NameSet) +-- Get all the top-level binders bound the group *except* +-- for value bindings, which are treated separately +-- Specifically we return AvailInfo for +-- * type decls (incl constructors and record selectors) +-- * class decls (including class ops) +-- * associated types +-- * foreign imports +-- * value signatures (in hs-boot files only) + +getLocalNonValBinders fixity_env + (HsGroup { hs_valds = binds, + hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = do { -- Process all type/class decls *except* family instances + ; let inst_decls = tycl_decls >>= group_instds + ; overload_ok <- xoptM LangExt.DuplicateRecordFields + ; (tc_avails, tc_fldss) + <- fmap unzip $ mapM (new_tc overload_ok) + (tyClGroupTyClDecls tycl_decls) + ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) + ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env + ; setEnvs envs $ do { + -- Bring these things into scope first + -- See Note [Looking up family names in family instances] + + -- Process all family instances + -- to bring new data constructors into scope + ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok) + inst_decls + + -- Finish off with value binders: + -- foreign decls and pattern synonyms for an ordinary module + -- type sigs in case of a hs-boot file only + ; is_boot <- tcIsHsBootOrSig + ; let val_bndrs | is_boot = hs_boot_sig_bndrs + | otherwise = for_hs_bndrs + ; val_avails <- mapM new_simple val_bndrs + + ; let avails = concat nti_availss ++ val_avails + new_bndrs = availsToNameSetWithSelectors avails `unionNameSet` + availsToNameSetWithSelectors tc_avails + flds = concat nti_fldss ++ concat tc_fldss + ; traceRn "getLocalNonValBinders 2" (ppr avails) + ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env + + -- Force the field access so that tcg_env is not retained. The + -- selector thunk optimisation doesn't kick-in, see #20139 + ; let !old_field_env = tcg_field_env tcg_env + -- Extend tcg_field_env with new fields (this used to be the + -- work of extendRecordFieldEnv) + field_env = extendNameEnvList old_field_env flds + envs = (tcg_env { tcg_field_env = field_env }, tcl_env) + + ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) + ; return (envs, new_bndrs) } } + where + ValBinds _ _val_binds val_sigs = binds + + for_hs_bndrs :: [Located RdrName] + for_hs_bndrs = hsForeignDeclsBinders foreign_decls + + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + hs_boot_sig_bndrs = [ L decl_loc (unLoc n) + | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] + + -- the SrcSpan attached to the input should be the span of the + -- declaration, not just the name + new_simple :: Located RdrName -> RnM AvailInfo + new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name + ; return (avail nm) } + + new_tc :: Bool -> LTyClDecl GhcPs + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_tc overload_ok tc_decl -- NOT for type/data instances + = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl + ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs + ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds + ; let fld_env = case unLoc tc_decl of + DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' + _ -> [] + ; return (AvailTC main_name names flds', fld_env) } + + + -- Calculate the mapping from constructor names to fields, which + -- will go in tcg_field_env. It's convenient to do this here where + -- we are working with a single datatype definition. + mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] + -> [(Name, [FieldLabel])] + mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) + where + find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr + , con_args = RecCon cdflds })) + = [( find_con_name rdr + , concatMap find_con_decl_flds (unLoc cdflds) )] + find_con_flds (L _ (ConDeclGADT { con_names = rdrs + , con_args = RecCon flds })) + = [ ( find_con_name rdr + , concatMap find_con_decl_flds (unLoc flds)) + | L _ rdr <- rdrs ] + + find_con_flds _ = [] + + find_con_name rdr + = expectJust "getLocalNonValBinders/find_con_name" $ + find (\ n -> nameOccName n == rdrNameOcc rdr) names + find_con_decl_flds (L _ x) + = map find_con_decl_fld (cd_fld_names x) + + find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) + = expectJust "getLocalNonValBinders/find_con_decl_fld" $ + find (\ fl -> flLabel fl == lbl) flds + where lbl = occNameFS (rdrNameOcc rdr) + + new_assoc :: Bool -> LInstDecl GhcPs + -> RnM ([AvailInfo], [(Name, [FieldLabel])]) + new_assoc _ (L _ (TyFamInstD {})) = return ([], []) + -- type instances don't bind new names + + new_assoc overload_ok (L _ (DataFamInstD _ d)) + = do { (avail, flds) <- new_di overload_ok Nothing d + ; return ([avail], flds) } + new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty + , cid_datafam_insts = adts }))) + = do -- First, attempt to grab the name of the class from the instance. + -- This step could fail if the instance is not headed by a class, + -- such as in the following examples: + -- + -- (1) The class is headed by a bang pattern, such as in + -- `instance !Show Int` (#3811c) + -- (2) The class is headed by a type variable, such as in + -- `instance c` (#16385) + -- + -- If looking up the class name fails, then mb_cls_nm will + -- be Nothing. + mb_cls_nm <- runMaybeT $ do + -- See (1) above + L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty + -- See (2) above + MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr + -- Assuming the previous step succeeded, process any associated data + -- family instances. If the previous step failed, bail out. + case mb_cls_nm of + Nothing -> pure ([], []) + Just cls_nm -> do + (avails, fldss) + <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts + pure (avails, concat fldss) + + new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn = + HsIB { hsib_body = ti_decl }}) + = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) + ; let (bndrs, flds) = hsDataFamInstBinders dfid + ; sub_names <- mapM newTopSrcBinder bndrs + ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds + ; let avail = AvailTC (unLoc main_name) sub_names flds' + -- main_name is not bound here! + fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' + ; return (avail, fld_env) } + + new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d + +newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel +newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" +newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) + = do { selName <- newTopSrcBinder $ L loc $ field + ; return $ qualFieldLbl { flSelector = selName } } + where + fieldOccName = occNameFS $ rdrNameOcc fld + qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok + field | isExact fld = fld + -- use an Exact RdrName as is to preserve the bindings + -- of an already renamer-resolved field and its use + -- sites. This is needed to correctly support record + -- selectors in Template Haskell. See Note [Binders in + -- Template Haskell] in "GHC.ThToHs" and Note [Looking up + -- Exact RdrNames] in "GHC.Rename.Env". + | otherwise = mkRdrUnqual (flSelector qualFieldLbl) + +{- +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +Solution is simple: process the type family declarations first, extend +the environment, and then process the type instances. + + +************************************************************************ +* * +\subsection{Filtering imports} +* * +************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +Note [Dealing with imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For import M( ies ), we take the mi_exports of M, and make + imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) +One entry for each Name that M exports; the AvailInfo is the +AvailInfo exported from M that exports that Name. + +The situation is made more complicated by associated types. E.g. + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } +Then M's export_avails are (recall the AvailTC invariant from Avails.hs) + C(C,T), T(T,T1,T2,T3) +Notice that T appears *twice*, once as a child and once as a parent. From +this list we construct a raw list including + T -> (T, T( T1, T2, T3 ), Nothing) + T -> (C, C( C, T ), Nothing) +and we combine these (in function 'combine' in 'imp_occ_env' in +'filterImports') to get + T -> (T, T(T,T1,T2,T3), Just C) + +So the overall imp_occ_env is + C -> (C, C(C,T), Nothing) + T -> (T, T(T,T1,T2,T3), Just C) + T1 -> (T1, T(T,T1,T2,T3), Nothing) -- similarly T2,T3 + +If we say + import M( T(T1,T2) ) +then we get *two* Avails: C(T), T(T1,T2) + +Note that the imp_occ_env will have entries for data constructors too, +although we never look up data constructors. +-} + +filterImports + :: ModIface + -> ImpDeclSpec -- The span for the entire import decl + -> Maybe (Bool, Located [LIE GhcPs]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names + [GlobalRdrElt]) -- Same again, but in GRE form +filterImports iface decl_spec Nothing + = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) + where + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + +filterImports iface decl_spec (Just (want_hiding, L l import_items)) + = do -- check for errors, convert RdrNames to Names + items1 <- mapM lookup_lie import_items + + let items2 :: [(LIE GhcRn, AvailInfo)] + items2 = concat items1 + -- NB the AvailInfo may have duplicates, and several items + -- for the same parent; e.g N(x) and N(y) + + names = availsToNameSetWithSelectors (map snd items2) + keep n = not (n `elemNameSet` names) + pruned_avails = filterAvails keep all_avails + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails + | otherwise = concatMap (gresFromIE decl_spec) items2 + + return (Just (want_hiding, L l (map fst items2)), gres) + where + all_avails = mi_exports iface + + -- See Note [Dealing with imports] + imp_occ_env :: OccEnv (Name, -- the name + AvailInfo, -- the export item providing the name + Maybe Name) -- the parent of associated types + imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing)) + | a <- all_avails + , (n, occ) <- availNamesWithOccs a] + where + -- See Note [Dealing with imports] + -- 'combine' is only called for associated data types which appear + -- twice in the all_avails. In the example, we combine + -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) + -- NB: the AvailTC can have fields as well as data constructors (#12127) + combine (name1, a1@(AvailTC p1 _ _), mp1) + (name2, a2@(AvailTC p2 _ _), mp2) + = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 + , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) + if p1 == name1 then (name1, a1, Just p2) + else (name1, a2, Just p1) + combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) + + lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) + lookup_name ie rdr + | isQual rdr = failLookupWith (QualImportError rdr) + | Just succ <- mb_success = return succ + | otherwise = failLookupWith (BadImport ie) + where + mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] + lookup_lie (L loc ieRdr) + = do (stuff, warns) <- setSrcSpan loc $ + liftM (fromMaybe ([],[])) $ + run_lookup (lookup_ie ieRdr) + mapM_ emit_warning warns + return [ (L loc ie, avail) | (ie,avail) <- stuff ] + where + -- Warn when importing T(..) if T was exported abstractly + emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ + addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n) + emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ + addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr) + emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ + addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) + + run_lookup :: IELookupM a -> TcRn (Maybe a) + run_lookup m = case m of + Failed err -> addErr (lookup_err_msg err) >> return Nothing + Succeeded a -> return (Just a) + + lookup_err_msg err = case err of + BadImport ie -> badImportItemErr iface decl_spec ie all_avails + IllegalImport -> illegalImportItemErr + QualImportError rdr -> qualImportItemErr rdr + + -- For each import item, we convert its RdrNames to Names, + -- and at the same time construct an AvailInfo corresponding + -- to what is actually imported by this item. + -- Returns Nothing on error. + -- We return a list here, because in the case of an import + -- item like C, if we are hiding, then C refers to *both* a + -- type/class and a data constructor. Moreover, when we import + -- data constructors of an associated family, we need separate + -- AvailInfos for the data constructors and the family (as they have + -- different parents). See Note [Dealing with imports] + lookup_ie :: IE GhcPs + -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ do + case ie of + IEVar _ (L l n) -> do + (name, avail, _) <- lookup_name ie $ ieWrappedName n + return ([(IEVar noExtField (L l (replaceWrappedName n name)), + trimAvail avail name)], []) + + IEThingAll _ (L l tc) -> do + (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc + let warns = case avail of + Avail {} -- e.g. f(..) + -> [DodgyImport $ ieWrappedName tc] + + AvailTC _ subs fs + | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym + -> [DodgyImport $ ieWrappedName tc] + + | not (is_qual decl_spec) -- e.g. import M( T(..) ) + -> [MissingImportList] + + | otherwise + -> [] + + renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name)) + sub_avails = case avail of + Avail {} -> [] + AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)] + case mb_parent of + Nothing -> return ([(renamed_ie, avail)], warns) + -- non-associated ty/cls + Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns) + -- associated type + + IEThingAbs _ (L l tc') + | want_hiding -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc = ieWrappedName tc' + tc_name = lookup_name ie tc + dc_name = lookup_name ie (setRdrNameSpace tc srcDataName) + in + case catIELookupM [ tc_name, dc_name ] of + [] -> failLookupWith (BadImport ie) + names -> return ([mkIEThingAbs tc' l name | name <- names], []) + | otherwise + -> do nameAvail <- lookup_name ie (ieWrappedName tc') + return ([mkIEThingAbs tc' l nameAvail] + , []) + + IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs -> + ASSERT2(null rdr_fs, ppr rdr_fs) do + (name, avail, mb_parent) + <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc) + + let (ns,subflds) = case avail of + AvailTC _ ns' subflds' -> (ns',subflds') + Avail _ -> panic "filterImports" + + -- Look up the children in the sub-names of the parent + let subnames = case ns of -- The tc is first in ns, + [] -> [] -- if it is there at all + -- See the AvailTC Invariant in + -- GHC.Types.Avail + (n1:ns1) | n1 == name -> ns1 + | otherwise -> ns + case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of + + Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs [])) + -- We are trying to import T( a,b,c,d ), and failed + -- to find 'b' and 'd'. So we make up an import item + -- to report as failing, namely T( b, d ). + -- c.f. #15412 + + Succeeded (childnames, childflds) -> + case mb_parent of + -- non-associated ty/cls + Nothing + -> return ([(IEThingWith noExtField (L l name') wc childnames' + childflds, + AvailTC name (name:map unLoc childnames) (map unLoc childflds))], + []) + where name' = replaceWrappedName rdr_tc name + childnames' = map to_ie_post_rn childnames + -- childnames' = postrn_ies childnames + -- associated ty + Just parent + -> return ([(IEThingWith noExtField (L l name') wc childnames' + childflds, + AvailTC name (map unLoc childnames) (map unLoc childflds)), + (IEThingWith noExtField (L l name') wc childnames' + childflds, + AvailTC parent [name] [])], + []) + where name' = replaceWrappedName rdr_tc name + childnames' = map to_ie_post_rn childnames + + _other -> failLookupWith IllegalImport + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed + -- all errors. + + where + mkIEThingAbs tc l (n, av, Nothing ) + = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n) + mkIEThingAbs tc l (n, _, Just parent) + = (IEThingAbs noExtField (L l (replaceWrappedName tc n)) + , AvailTC parent [n] []) + + handle_bad_import m = catchIELookup m $ \err -> case err of + BadImport ie | want_hiding -> return ([], [BadImportW ie]) + _ -> failLookupWith err + +type IELookupM = MaybeErr IELookupError + +data IELookupWarning + = BadImportW (IE GhcPs) + | MissingImportList + | DodgyImport RdrName + -- NB. use the RdrName for reporting a "dodgy" import + +data IELookupError + = QualImportError RdrName + | BadImport (IE GhcPs) + | IllegalImport + +failLookupWith :: IELookupError -> IELookupM a +failLookupWith err = Failed err + +catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a +catchIELookup m h = case m of + Succeeded r -> return r + Failed err -> h err + +catIELookupM :: [IELookupM a] -> [a] +catIELookupM ms = [ a | Succeeded a <- ms ] + +{- +************************************************************************ +* * +\subsection{Import/Export Utils} +* * +************************************************************************ +-} + +-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] +gresFromIE decl_spec (L loc ie, avail) + = gresFromAvail prov_fn avail + where + is_explicit = case ie of + IEThingAll _ name -> \n -> n == lieWrappedName name + _ -> \_ -> True + prov_fn name + = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) + where + item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } + + +{- +Note [Children for duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the module + + {-# LANGUAGE DuplicateRecordFields #-} + module M (F(foo, MkFInt, MkFBool)) where + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool } + +The `foo` in the export list refers to *both* selectors! For this +reason, lookupChildren builds an environment that maps the FastString +to a list of items, rather than a single item. +-} + +mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] +mkChildEnv gres = foldr add emptyNameEnv gres + where + add gre env = case gre_par gre of + FldParent p _ -> extendNameEnv_Acc (:) Utils.singleton env p gre + ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre + NoParent -> env + +findChildren :: NameEnv [a] -> Name -> [a] +findChildren env n = lookupNameEnv env n `orElse` [] + +lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName] + -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed + ([Located Name], [Located FieldLabel]) +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- corresponding Name all_kids, if the former exists +-- The matching is done by FastString, not OccName, so that +-- Cls( meth, AssocTy ) +-- will correctly find AssocTy among the all_kids of Cls, even though +-- the RdrName for AssocTy may have a (bogus) DataName namespace +-- (Really the rdr_items should be FastStrings in the first place.) +lookupChildren all_kids rdr_items + | null fails + = Succeeded (fmap concat (partitionEithers oks)) + -- This 'fmap concat' trickily applies concat to the /second/ component + -- of the pair, whose type is ([Located Name], [[Located FieldLabel]]) + | otherwise + = Failed fails + where + mb_xs = map doOne rdr_items + fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] + oks = [ ok | Succeeded ok <- mb_xs ] + oks :: [Either (Located Name) [Located FieldLabel]] + + doOne item@(L l r) + = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of + Just [Left n] -> Succeeded (Left (L l n)) + Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs))) + _ -> Failed item + + -- See Note [Children for duplicate record fields] + kid_env = extendFsEnvList_C (++) emptyFsEnv + [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] + + + +------------------------------- + +{- +********************************************************* +* * +\subsection{Unused names} +* * +********************************************************* +-} + +reportUnusedNames :: TcGblEnv -> HscSource -> RnM () +reportUnusedNames gbl_env hsc_src + = do { keep <- readTcRef (tcg_keep gbl_env) + ; traceRn "RUN" (ppr (tcg_dus gbl_env)) + ; warnUnusedImportDecls gbl_env hsc_src + ; warnUnusedTopBinds $ unused_locals keep + ; warnMissingSignatures gbl_env } + where + used_names :: NameSet -> NameSet + used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses + + -- Collect the defined names from the in-scope environment + defined_names :: [GlobalRdrElt] + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) + + kids_env = mkChildEnv defined_names + -- This is done in mkExports too; duplicated work + + gre_is_used :: NameSet -> GlobalRdrElt -> Bool + gre_is_used used_names (GRE {gre_name = name}) + = name `elemNameSet` used_names + || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + + -- Filter out the ones that are + -- (a) defined in this module, and + -- (b) not defined by a 'deriving' clause + -- The latter have an Internal Name, so we can filter them out easily + unused_locals :: NameSet -> [GlobalRdrElt] + unused_locals keep = + let -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just used_names + _defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (_defined_and_used, defined_but_not_used) + = partition (gre_is_used (used_names keep)) defined_names + + in filter is_unused_local defined_but_not_used + is_unused_local :: GlobalRdrElt -> Bool + is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) + +{- ********************************************************************* +* * + Missing signatures +* * +********************************************************************* -} + +-- | Warn the user about top level binders that lack type signatures. +-- Called /after/ type inference, so that we can report the +-- inferred type of the function +warnMissingSignatures :: TcGblEnv -> RnM () +warnMissingSignatures gbl_env + = do { let exports = availsToNameSet (tcg_exports gbl_env) + sig_ns = tcg_sigs gbl_env + -- We use sig_ns to exclude top-level bindings that are generated by GHC + binds = collectHsBindsBinders $ tcg_binds gbl_env + pat_syns = tcg_patsyns gbl_env + + -- Warn about missing signatures + -- Do this only when we have a type to offer + ; warn_missing_sigs <- woptM Opt_WarnMissingSignatures + ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures + ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures + + ; let add_sig_warns + | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures + | warn_missing_sigs = add_warns Opt_WarnMissingSignatures + | warn_pat_syns = add_warns Opt_WarnMissingPatternSynonymSignatures + | otherwise = return () + + add_warns flag + = when warn_pat_syns + (mapM_ add_pat_syn_warn pat_syns) >> + when (warn_missing_sigs || warn_only_exported) + (mapM_ add_bind_warn binds) + where + add_pat_syn_warn p + = add_warn name $ + hang (text "Pattern synonym with no type signature:") + 2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty) + where + name = patSynName p + pp_ty = pprPatSynType p + + add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) () + add_bind_warn id + = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? + ; let name = idName id + (_, ty) = tidyOpenType env (idType id) + ty_msg = pprSigmaType ty + ; add_warn name $ + hang (text "Top-level binding with no type signature:") + 2 (pprPrefixName name <+> dcolon <+> ty_msg) } + + add_warn name msg + = when (name `elemNameSet` sig_ns && export_check name) + (addWarnAt (Reason flag) (getSrcSpan name) msg) + + export_check name + = not warn_only_exported || name `elemNameSet` exports + + ; add_sig_warns } + + +{- +********************************************************* +* * +\subsection{Unused imports} +* * +********************************************************* + +This code finds which import declarations are unused. The +specification and implementation notes are here: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports + +See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader +-} + +type ImportDeclUsage + = ( LImportDecl GhcRn -- The import declaration + , [GlobalRdrElt] -- What *is* used (normalised) + , [Name] ) -- What is imported but *not* used + +warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM () +warnUnusedImportDecls gbl_env hsc_src + = do { uses <- readMutVar (tcg_used_gres gbl_env) + ; let user_imports = filterOut + (ideclImplicit . unLoc) + (tcg_rn_imports gbl_env) + -- This whole function deals only with *user* imports + -- both for warning about unnecessary ones, and for + -- deciding the minimal ones + rdr_env = tcg_rdr_env gbl_env + fld_env = mkFieldEnv rdr_env + + ; let usage :: [ImportDeclUsage] + usage = findImportUsage user_imports uses + + ; traceRn "warnUnusedImportDecls" $ + (vcat [ text "Uses:" <+> ppr uses + , text "Import usage" <+> ppr usage]) + + ; whenWOptM Opt_WarnUnusedImports $ + mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage + + ; whenGOptM Opt_D_dump_minimal_imports $ + printMinimalImports hsc_src usage } + +findImportUsage :: [LImportDecl GhcRn] + -> [GlobalRdrElt] + -> [ImportDeclUsage] + +findImportUsage imports used_gres + = map unused_decl imports + where + import_usage :: ImportMap + import_usage = mkImportMap used_gres + + unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) + = (decl, used_gres, nameSetElemsStable unused_imps) + where + used_gres = lookupSrcLoc (srcSpanEnd loc) import_usage + -- srcSpanEnd: see Note [The ImportMap] + `orElse` [] + + used_names = mkNameSet (map gre_name used_gres) + used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) + + unused_imps -- Not trivial; see eg #7454 + = case imps of + Just (False, L _ imp_ies) -> + foldr (add_unused . unLoc) emptyNameSet imp_ies + _other -> emptyNameSet -- No explicit import list => no unused-name list + + add_unused :: IE GhcRn -> NameSet -> NameSet + add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc + add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc + add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc + add_unused (IEThingWith _ p wc ns fs) acc = + add_wc_all (add_unused_with pn xs acc) + where pn = lieWrappedName p + xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs + add_wc_all = case wc of + NoIEWildcard -> id + IEWildcard _ -> add_unused_all pn + add_unused _ acc = acc + + add_unused_name n acc + | n `elemNameSet` used_names = acc + | otherwise = acc `extendNameSet` n + add_unused_all n acc + | n `elemNameSet` used_names = acc + | n `elemNameSet` used_parents = acc + | otherwise = acc `extendNameSet` n + add_unused_with p ns acc + | all (`elemNameSet` acc1) ns = add_unused_name p acc1 + | otherwise = acc1 + where + acc1 = foldr add_unused_name acc ns + -- If you use 'signum' from Num, then the user may well have + -- imported Num(signum). We don't want to complain that + -- Num is not itself mentioned. Hence the two cases in add_unused_with. + + +{- Note [The ImportMap] +~~~~~~~~~~~~~~~~~~~~~~~ +The ImportMap is a short-lived intermediate data structure records, for +each import declaration, what stuff brought into scope by that +declaration is actually used in the module. + +The SrcLoc is the location of the END of a particular 'import' +declaration. Why *END*? Because we don't want to get confused +by the implicit Prelude import. Consider (#7476) the module + import Foo( foo ) + main = print foo +There is an implicit 'import Prelude(print)', and it gets a SrcSpan +of line 1:1 (just the point, not a span). If we use the *START* of +the SrcSpan to identify the import decl, we'll confuse the implicit +import Prelude with the explicit 'import Foo'. So we use the END. +It's just a cheap hack; we could equally well use the Span too. + +The [GlobalRdrElt] are the things imported from that decl. +-} + +type ImportMap = Map RealSrcLoc [GlobalRdrElt] -- See [The ImportMap] + -- If loc :-> gres, then + -- 'loc' = the end loc of the bestImport of each GRE in 'gres' + +mkImportMap :: [GlobalRdrElt] -> ImportMap +-- For each of a list of used GREs, find all the import decls that brought +-- it into scope; choose one of them (bestImport), and record +-- the RdrName in that import decl's entry in the ImportMap +mkImportMap gres + = foldr add_one Map.empty gres + where + add_one gre@(GRE { gre_imp = imp_specs }) imp_map = + case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of + -- For srcSpanEnd see Note [The ImportMap] + RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map + UnhelpfulLoc _ -> imp_map + where + best_imp_spec = bestImport imp_specs + add _ gres = gre : gres + +warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) + -> ImportDeclUsage -> RnM () +warnUnusedImport flag fld_env (L loc decl, used, unused) + + -- Do not warn for 'import M()' + | Just (False,L _ []) <- ideclHiding decl + = return () + + -- Note [Do not warn about Prelude hiding] + | Just (True, L _ hides) <- ideclHiding decl + , not (null hides) + , pRELUDE_NAME == unLoc (ideclName decl) + = return () + + -- Nothing used; drop entire declaration + | null used + = addWarnAt (Reason flag) loc msg1 + + -- Everything imported is used; nop + | null unused + = return () + + -- Only one import is unused, with `SrcSpan` covering only the unused item instead of + -- the whole import statement + | Just (_, L _ imports) <- ideclHiding decl + , length unused == 1 + , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports + = addWarnAt (Reason flag) loc msg2 + + -- Some imports are unused + | otherwise + = addWarnAt (Reason flag) loc msg2 + + where + msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant + , nest 2 (text "except perhaps to import instances from" + <+> quotes pp_mod) + , text "To import instances alone, use:" + <+> text "import" <+> pp_mod <> parens Outputable.empty ] + msg2 = sep [ pp_herald <+> quotes sort_unused + , text "from module" <+> quotes pp_mod <+> is_redundant] + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | isImportDeclQualified (ideclQualified decl)= text "qualified" + | otherwise = Outputable.empty + pp_mod = ppr (unLoc (ideclName decl)) + is_redundant = text "is redundant" + + -- In warning message, pretty-print identifiers unqualified unconditionally + -- to improve the consistent for ambiguous/unambiguous identifiers. + -- See trac#14881. + ppr_possible_field n = case lookupNameEnv fld_env n of + Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld) + Nothing -> pprNameUnqualified n + + -- Print unused names in a deterministic (lexicographic) order + sort_unused :: SDoc + sort_unused = pprWithCommas ppr_possible_field $ + sortBy (comparing nameOccName) unused + +{- +Note [Do not warn about Prelude hiding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not warn about + import Prelude hiding( x, y ) +because even if nothing else from Prelude is used, it may be essential to hide +x,y to avoid name-shadowing warnings. Example (#9061) + import Prelude hiding( log ) + f x = log where log = () + + + +Note [Printing minimal imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To print the minimal imports we walk over the user-supplied import +decls, and simply trim their import lists. NB that + + * We do *not* change the 'qualified' or 'as' parts! + + * We do not discard a decl altogether; we might need instances + from it. Instead we just trim to an empty import list +-} + +getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] +getMinimalImports = mapM mk_minimal + where + mk_minimal (L l decl, used_gres, unused) + | null unused + , Just (False, _) <- ideclHiding decl + = return (L l decl) + | otherwise + = do { let ImportDecl { ideclName = L _ mod_name + , ideclSource = is_boot + , ideclPkgQual = mb_pkg } = decl + ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg) + ; let used_avails = gresToAvailInfo used_gres + lies = map (L l) (concatMap (to_ie iface) used_avails) + ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } + where + doc = text "Compute minimal imports for" <+> ppr decl + + to_ie :: ModIface -> AvailInfo -> [IE GhcRn] + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. + to_ie _ (Avail n) + = [IEVar noExtField (to_ie_post_rn $ noLoc n)] + to_ie _ (AvailTC n [m] []) + | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] + to_ie iface (AvailTC n ns fs) + = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface + , x == n + , x `elem` xs -- Note [Partial export] + ] of + [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)] + | otherwise -> + [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) + (map noLoc fs)] + -- Note [Overloaded field import] + _other | all_non_overloaded fs + -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns + ++ map flSelector fs + | otherwise -> + [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) + (map noLoc fs)] + where + + fld_lbls = map flLabel fs + + all_used (avail_occs, avail_flds) + = all (`elem` ns) avail_occs + && all (`elem` fld_lbls) (map flLabel avail_flds) + + all_non_overloaded = all (not . flIsOverloaded) + +printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () +-- See Note [Printing minimal imports] +printMinimalImports hsc_src imports_w_usage + = do { imports' <- getMinimalImports imports_w_usage + ; this_mod <- getModule + ; dflags <- getDynFlags + ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> + printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports')) + -- The neverQualify is important. We are printing Names + -- but they are in the context of an 'import' decl, and + -- we never qualify things inside there + -- E.g. import Blag( f, b ) + -- not import Blag( Blag.f, Blag.g )! + } + where + mkFilename dflags this_mod + | Just d <- dumpDir dflags = d basefn + | otherwise = basefn + where + suffix = case hsc_src of + HsBootFile -> ".imports-boot" + HsSrcFile -> ".imports" + HsigFile -> ".imports" + basefn = moduleNameString (moduleName this_mod) ++ suffix + + +to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name +to_ie_post_rn_var (L l n) + | isDataOcc $ occName n = L l (IEPattern (L l n)) + | otherwise = L l (IEName (L l n)) + + +to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name +to_ie_post_rn (L l n) + | isTcOcc occ && isSymOcc occ = L l (IEType (L l n)) + | otherwise = L l (IEName (L l n)) + where occ = occName n + +{- +Note [Partial export] +~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + module A( op ) where + class C a where + op :: a -> a + + module B where + import A + f = ..op... + +Then the minimal import for module B is + import A( op ) +not + import A( C( op ) ) +which we would usually generate if C was exported from B. Hence +the (x `elem` xs) test when deciding what to generate. + + +Note [Overloaded field import] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On the other hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + data T = MkT { foo :: Int } + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( T(foo) ) +because when DuplicateRecordFields is enabled, field selectors are +not in scope without their enclosing datatype. + + +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +qualImportItemErr :: RdrName -> SDoc +qualImportItemErr rdr + = hang (text "Illegal qualified name in import item:") + 2 (ppr rdr) + +pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc +pprImpDeclSpec iface decl_spec = + quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of + IsBoot -> text "(hi-boot interface)" + NotBoot -> Outputable.empty + +badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc +badImportItemErrStd iface decl_spec ie + = sep [text "Module", pprImpDeclSpec iface decl_spec, + text "does not export", quotes (ppr ie)] + +badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs + -> SDoc +badImportItemErrDataCon dataType_occ iface decl_spec ie + = vcat [ text "In module" + <+> pprImpDeclSpec iface decl_spec + <> colon + , nest 2 $ quotes datacon + <+> text "is a data constructor of" + <+> quotes dataType + , text "To import it use" + , nest 2 $ text "import" + <+> ppr (is_mod decl_spec) + <> parens_sp (dataType <> parens_sp datacon) + , text "or" + , nest 2 $ text "import" + <+> ppr (is_mod decl_spec) + <> parens_sp (dataType <> text "(..)") + ] + where + datacon_occ = rdrNameOcc $ ieName ie + datacon = parenSymOcc datacon_occ (ppr datacon_occ) + dataType = parenSymOcc dataType_occ (ppr dataType_occ) + parens_sp d = parens (space <> d <> space) -- T( f,g ) + +badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc +badImportItemErr iface decl_spec ie avails + = case find checkIfDataCon avails of + Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie + Nothing -> badImportItemErrStd iface decl_spec ie + where + checkIfDataCon (AvailTC _ ns _) = + case find (\n -> importedFS == nameOccNameFS n) ns of + Just n -> isDataConName n + Nothing -> False + checkIfDataCon _ = False + availOccName = nameOccName . availName + nameOccNameFS = occNameFS . nameOccName + importedFS = occNameFS . rdrNameOcc $ ieName ie + +illegalImportItemErr :: SDoc +illegalImportItemErr = text "Illegal import item" + +dodgyImportWarn :: RdrName -> SDoc +dodgyImportWarn item + = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs) + +dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc +dodgyMsg kind tc ie + = sep [ text "The" <+> kind <+> ptext (sLit "item") + -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) + <+> quotes (ppr ie) + <+> text "suggests that", + quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", + text "but it has none" ] + +dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) +dodgyMsgInsert tc = IEThingAll noExtField ii + where + ii :: LIEWrappedName (IdP (GhcPass p)) + ii = noLoc (IEName $ noLoc tc) + + +addDupDeclErr :: [GlobalRdrElt] -> TcRn () +addDupDeclErr [] = panic "addDupDeclErr: empty list" +addDupDeclErr gres@(gre : _) + = addErrAt (getSrcSpan (last sorted_names)) $ + -- Report the error at the later location + vcat [text "Multiple declarations of" <+> + quotes (ppr (greOccName gre)), + -- NB. print the OccName, not the Name, because the + -- latter might not be in scope in the RdrEnv and so will + -- be printed qualified. + text "Declared at:" <+> + vcat (map (ppr . nameSrcLoc) sorted_names)] + where + sorted_names = + sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) + (map gre_name gres) + + + +missingImportListWarn :: ModuleName -> SDoc +missingImportListWarn mod + = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") + +missingImportListItem :: IE GhcPs -> SDoc +missingImportListItem ie + = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") + +moduleWarn :: ModuleName -> WarningTxt -> SDoc +moduleWarn mod (WarningTxt _ txt) + = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"), + nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] +moduleWarn mod (DeprecatedTxt _ txt) + = sep [ text "Module" <+> quotes (ppr mod) + <+> text "is deprecated:", + nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] + +packageImportErr :: SDoc +packageImportErr + = text "Package-qualified imports are not enabled; use PackageImports" + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form + +checkConName :: RdrName -> TcRn () +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon :: RdrName -> SDoc +badDataCon name + = hsep [text "Illegal data constructor name", quotes (ppr name)] diff --git a/GHC/Rename/Pat.hs b/GHC/Rename/Pat.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Pat.hs @@ -0,0 +1,901 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming of patterns + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Rename.Pat (-- main entry points + rnPat, rnPats, rnBindPat, rnPatAndThen, + + NameMaker, applyNameMaker, -- a utility for making names: + localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, + -- sometimes we want to make top (qualified) names. + isTopRecNameMaker, + + rnHsRecFields, HsRecFieldContext(..), + rnHsRecUpdFields, + + -- CpsRn monad + CpsRn, liftCps, + + -- Literals + rnLit, rnOverLit, + + -- Pattern Error messages that are also used elsewhere + checkTupSize, patSigErr + ) where + +-- ENH: thin imports to only what is necessary for patterns + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) + +#include "HsVersions.h" + +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Zonk ( hsOverLitName ) +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames + , warnUnusedMatches, newLocalBndrRn + , checkUnusedRecordWildcard + , checkDupNames, checkDupAndShadowedNames + , checkTupSize , unknownSubordinateErr ) +import GHC.Rename.HsType +import GHC.Builtin.Names +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Data.List.SetOps( removeDups ) +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Types.Literal ( inCharRange ) +import GHC.Builtin.Types ( nilDataCon ) +import GHC.Core.DataCon +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad ( when, ap, guard ) +import qualified Data.List.NonEmpty as NE +import Data.Ratio + +{- +********************************************************* +* * + The CpsRn Monad +* * +********************************************************* + +Note [CpsRn monad] +~~~~~~~~~~~~~~~~~~ +The CpsRn monad uses continuation-passing style to support this +style of programming: + + do { ... + ; ns <- bindNames rs + ; ...blah... } + + where rs::[RdrName], ns::[Name] + +The idea is that '...blah...' + a) sees the bindings of ns + b) returns the free variables it mentions + so that bindNames can report unused ones + +In particular, + mapM rnPatAndThen [p1, p2, p3] +has a *left-to-right* scoping: it makes the binders in +p1 scope over p2,p3. +-} + +newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) + -> RnM (r, FreeVars) } + deriving (Functor) + -- See Note [CpsRn monad] + +instance Applicative CpsRn where + pure x = CpsRn (\k -> k x) + (<*>) = ap + +instance Monad CpsRn where + (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k)) + +runCps :: CpsRn a -> RnM (a, FreeVars) +runCps (CpsRn m) = m (\r -> return (r, emptyFVs)) + +liftCps :: RnM a -> CpsRn a +liftCps rn_thing = CpsRn (\k -> rn_thing >>= k) + +liftCpsFV :: RnM (a, FreeVars) -> CpsRn a +liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing + ; (r,fvs2) <- k v + ; return (r, fvs1 `plusFV` fvs2) }) + +wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) +-- Set the location, and also wrap it around the value returned +wrapSrcSpanCps fn (L loc a) + = CpsRn (\k -> setSrcSpan loc $ + unCpsRn (fn a) $ \v -> + k (L loc v)) + +lookupConCps :: Located RdrName -> CpsRn (Located Name) +lookupConCps con_rdr + = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr + ; (r, fvs) <- k con_name + ; return (r, addOneFV fvs (unLoc con_name)) }) + -- We add the constructor name to the free vars + -- See Note [Patterns are uses] + +{- +Note [Patterns are uses] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + module Foo( f, g ) where + data T = T1 | T2 + + f T1 = True + f T2 = False + + g _ = T1 + +Arguably we should report T2 as unused, even though it appears in a +pattern, because it never occurs in a constructed position. See +#7336. +However, implementing this in the face of pattern synonyms would be +less straightforward, since given two pattern synonyms + + pattern P1 <- P2 + pattern P2 <- () + +we need to observe the dependency between P1 and P2 so that type +checking can be done in the correct order (just like for value +bindings). Dependencies between bindings is analyzed in the renamer, +where we don't know yet whether P2 is a constructor or a pattern +synonym. So for now, we do report conid occurrences in patterns as +uses. + +********************************************************* +* * + Name makers +* * +********************************************************* + +Externally abstract type of name makers, +which is how you go from a RdrName to a Name +-} + +data NameMaker + = LamMk -- Lambdas + Bool -- True <=> report unused bindings + -- (even if True, the warning only comes out + -- if -Wunused-matches is on) + + | LetMk -- Let bindings, incl top level + -- Do *not* check for unused bindings + TopLevelFlag + MiniFixityEnv + +topRecNameMaker :: MiniFixityEnv -> NameMaker +topRecNameMaker fix_env = LetMk TopLevel fix_env + +isTopRecNameMaker :: NameMaker -> Bool +isTopRecNameMaker (LetMk TopLevel _) = True +isTopRecNameMaker _ = False + +localRecNameMaker :: MiniFixityEnv -> NameMaker +localRecNameMaker fix_env = LetMk NotTopLevel fix_env + +matchNameMaker :: HsMatchContext a -> NameMaker +matchNameMaker ctxt = LamMk report_unused + where + -- Do not report unused names in interactive contexts + -- i.e. when you type 'x <- e' at the GHCi prompt + report_unused = case ctxt of + StmtCtxt GhciStmtCtxt -> False + -- also, don't warn in pattern quotes, as there + -- is no RHS where the variables can be used! + ThPatQuote -> False + _ -> True + +newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) +newPatLName name_maker rdr_name@(L loc _) + = do { name <- newPatName name_maker rdr_name + ; return (L loc name) } + +newPatName :: NameMaker -> Located RdrName -> CpsRn Name +newPatName (LamMk report_unused) rdr_name + = CpsRn (\ thing_inside -> + do { name <- newLocalBndrRn rdr_name + ; (res, fvs) <- bindLocalNames [name] (thing_inside name) + ; when report_unused $ warnUnusedMatches [name] fvs + ; return (res, name `delFV` fvs) }) + +newPatName (LetMk is_top fix_env) rdr_name + = CpsRn (\ thing_inside -> + do { name <- case is_top of + NotTopLevel -> newLocalBndrRn rdr_name + TopLevel -> newTopSrcBinder rdr_name + ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here + -- See Note [View pattern usage] + addLocalFixities fix_env [name] $ + thing_inside name }) + + -- Note: the bindLocalNames is somewhat suspicious + -- because it binds a top-level name as a local name. + -- however, this binding seems to work, and it only exists for + -- the duration of the patterns and the continuation; + -- then the top-level name is added to the global env + -- before going on to the RHSes (see GHC.Rename.Module). + +{- +Note [View pattern usage] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let (r, (r -> x)) = x in ... +Here the pattern binds 'r', and then uses it *only* in the view pattern. +We want to "see" this use, and in let-bindings we collect all uses and +report unused variables at the binding level. So we must use bindLocalNames +here, *not* bindLocalNameFV. #3943. + + +Note [Don't report shadowing for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is one special context where a pattern doesn't introduce any new binders - +pattern synonym declarations. Therefore we don't check to see if pattern +variables shadow existing identifiers as they are never bound to anything +and have no scope. + +Without this check, there would be quite a cryptic warning that the `x` +in the RHS of the pattern synonym declaration shadowed the top level `x`. + +``` +x :: () +x = () + +pattern P x = Just x +``` + +See #12615 for some more examples. + +********************************************************* +* * + External entry points +* * +********************************************************* + +There are various entry points to renaming patterns, depending on + (1) whether the names created should be top-level names or local names + (2) whether the scope of the names is entirely given in a continuation + (e.g., in a case or lambda, but not in a let or at the top-level, + because of the way mutually recursive bindings are handled) + (3) whether the a type signature in the pattern can bind + lexically-scoped type variables (for unpacking existential + type vars in data constructors) + (4) whether we do duplicate and unused variable checking + (5) whether there are fixity declarations associated with the names + bound by the patterns that need to be brought into scope with them. + + Rather than burdening the clients of this module with all of these choices, + we export the three points in this design space that we actually need: +-} + +-- ----------- Entry point 1: rnPats ------------------- +-- Binds local names; the scope of the bindings is entirely in the thing_inside +-- * allows type sigs to bind type vars +-- * local namemaker +-- * unused and duplicate checking +-- * no fixities +rnPats :: HsMatchContext GhcRn -- for error messages + -> [LPat GhcPs] + -> ([LPat GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnPats ctxt pats thing_inside + = do { envs_before <- getRdrEnvs + + -- (1) rename the patterns, bringing into scope all of the term variables + -- (2) then do the thing inside. + ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do + { -- Check for duplicated and shadowed names + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + -- + -- See note [Don't report shadowing for pattern synonyms] + ; let bndrs = collectPatsBinders pats' + ; addErrCtxt doc_pat $ + if isPatSynCtxt ctxt + then checkDupNames bndrs + else checkDupAndShadowedNames envs_before bndrs + ; thing_inside pats' } } + where + doc_pat = text "In" <+> pprMatchContext ctxt + +rnPat :: HsMatchContext GhcRn -- for error messages + -> LPat GhcPs + -> (LPat GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) -- Variables bound by pattern do not + -- appear in the result FreeVars +rnPat ctxt pat thing_inside + = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') + +applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name) +applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) + ; return n } + +-- ----------- Entry point 2: rnBindPat ------------------- +-- Binds local names; in a recursive scope that involves other bound vars +-- e.g let { (x, Just y) = e1; ... } in ... +-- * does NOT allows type sig to bind type vars +-- * local namemaker +-- * no unused and duplicate checking +-- * fixities might be coming in +rnBindPat :: NameMaker + -> LPat GhcPs + -> RnM (LPat GhcRn, FreeVars) + -- Returned FreeVars are the free variables of the pattern, + -- of course excluding variables bound by this pattern + +rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) + +{- +********************************************************* +* * + The main event +* * +********************************************************* +-} + +-- ----------- Entry point 3: rnLPatAndThen ------------------- +-- General version: parametrized by how you make new names + +rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] +rnLPatsAndThen mk = mapM (rnLPatAndThen mk) + -- Despite the map, the monad ensures that each pattern binds + -- variables that may be mentioned in subsequent patterns in the list + +-------------------- +-- The workhorse +rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) +rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat + +rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) +rnPatAndThen _ (WildPat _) = return (WildPat noExtField) +rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (ParPat x pat') } +rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (LazyPat x pat') } +rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (BangPat x pat') } +rnPatAndThen mk (VarPat x (L l rdr)) + = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (L loc rdr) + ; return (VarPat x (L l name)) } + -- we need to bind pattern variables for view pattern expressions + -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) + +rnPatAndThen mk (SigPat x pat sig) + -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is + -- important to rename its type signature _before_ renaming the rest of the + -- pattern, so that type variables are first bound by the _outermost_ pattern + -- type signature they occur in. This keeps the type checker happy when + -- pattern type signatures happen to be nested (#7827) + -- + -- f ((Just (x :: a) :: Maybe a) + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here + -- ~~~~~~~~~~~~~~~^ the same `a' then used here + = do { sig' <- rnHsPatSigTypeAndThen sig + ; pat' <- rnLPatAndThen mk pat + ; return (SigPat x pat' sig' ) } + where + rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn) + rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx sig) + +rnPatAndThen mk (LitPat x lit) + | HsString src s <- lit + = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) + ; if ovlStr + then rnPatAndThen mk + (mkNPat (noLoc (mkHsIsString src s)) + Nothing) + else normal_lit } + | otherwise = normal_lit + where + normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } + +rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) + = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit + ; mb_neg' -- See Note [Negative zero] + <- let negative = do { (neg, fvs) <- lookupSyntax negateName + ; return (Just neg, fvs) } + positive = return (Nothing, emptyFVs) + in liftCpsFV $ case (mb_neg , mb_neg') of + (Nothing, Just _ ) -> negative + (Just _ , Nothing) -> negative + (Nothing, Nothing) -> positive + (Just _ , Just _ ) -> positive + ; eq' <- liftCpsFV $ lookupSyntax eqName + ; return (NPat x (L l lit') mb_neg' eq') } + +rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) + = do { new_name <- newPatName mk rdr + ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] + -- We skip negateName as + -- negative zero doesn't make + -- sense in n + k patterns + ; minus <- liftCpsFV $ lookupSyntax minusName + ; ge <- liftCpsFV $ lookupSyntax geName + ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } + -- The Report says that n+k patterns must be in Integral + +rnPatAndThen mk (AsPat x rdr pat) + = do { new_name <- newPatLName mk rdr + ; pat' <- rnLPatAndThen mk pat + ; return (AsPat x new_name pat') } + +rnPatAndThen mk p@(ViewPat x expr pat) + = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns + ; checkErr vp_flag (badViewPat p) } + -- Because of the way we're arranging the recursive calls, + -- this will be in the right context + ; expr' <- liftCpsFV $ rnLExpr expr + ; pat' <- rnLPatAndThen mk pat + -- Note: at this point the PreTcType in ty can only be a placeHolder + -- ; return (ViewPat expr' pat' ty) } + ; return (ViewPat x expr' pat') } + +rnPatAndThen mk (ConPat NoExtField con args) + -- rnConPatAndThen takes care of reconstructing the pattern + -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. + = case unLoc con == nameRdrName (dataConName nilDataCon) of + True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists + ; if ol_flag then rnPatAndThen mk (ListPat noExtField []) + else rnConPatAndThen mk con args} + False -> rnConPatAndThen mk con args + +rnPatAndThen mk (ListPat _ pats) + = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists + ; pats' <- rnLPatsAndThen mk pats + ; case opt_OverloadedLists of + True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName + ; return (ListPat (Just to_list_name) pats')} + False -> return (ListPat Nothing pats') } + +rnPatAndThen mk (TuplePat x pats boxed) + = do { liftCps $ checkTupSize (length pats) + ; pats' <- rnLPatsAndThen mk pats + ; return (TuplePat x pats' boxed) } + +rnPatAndThen mk (SumPat x pat alt arity) + = do { pat <- rnLPatAndThen mk pat + ; return (SumPat x pat alt arity) + } + +-- If a splice has been run already, just rename the result. +rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat))) + = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat + +rnPatAndThen mk (SplicePat _ splice) + = do { eith <- liftCpsFV $ rnSplicePat splice + ; case eith of -- See Note [rnSplicePat] in GHC.Rename.Splice + Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed + Right already_renamed -> return already_renamed } + +-------------------- +rnConPatAndThen :: NameMaker + -> Located RdrName -- the constructor + -> HsConPatDetails GhcPs + -> CpsRn (Pat GhcRn) + +rnConPatAndThen mk con (PrefixCon pats) + = do { con' <- lookupConCps con + ; pats' <- rnLPatsAndThen mk pats + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = con' + , pat_args = PrefixCon pats' + } + } + +rnConPatAndThen mk con (InfixCon pat1 pat2) + = do { con' <- lookupConCps con + ; pat1' <- rnLPatAndThen mk pat1 + ; pat2' <- rnLPatAndThen mk pat2 + ; fixity <- liftCps $ lookupFixityRn (unLoc con') + ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } + +rnConPatAndThen mk con (RecCon rpats) + = do { con' <- lookupConCps con + ; rpats' <- rnHsRecPatsAndThen mk con' rpats + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = con' + , pat_args = RecCon rpats' + } + } + +checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn () +checkUnusedRecordWildcardCps loc dotdot_names = + CpsRn (\thing -> do + (r, fvs) <- thing () + checkUnusedRecordWildcard loc fvs dotdot_names + return (r, fvs) ) +-------------------- +rnHsRecPatsAndThen :: NameMaker + -> Located Name -- Constructor + -> HsRecFields GhcPs (LPat GhcPs) + -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) +rnHsRecPatsAndThen mk (L _ con) + hs_rec_fields@(HsRecFields { rec_dotdot = dd }) + = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat + hs_rec_fields + ; flds' <- mapM rn_field (flds `zip` [1..]) + ; check_unused_wildcard (implicit_binders flds' <$> dd) + ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } + where + mkVarPat l n = VarPat noExtField (L l n) + rn_field (L l fld, n') = + do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' })) } + + loc = maybe noSrcSpan getLoc dd + + -- Get the arguments of the implicit binders + implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats + where + implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs) + + -- Don't warn for let P{..} = ... in ... + check_unused_wildcard = case mk of + LetMk{} -> const (return ()) + LamMk{} -> checkUnusedRecordWildcardCps loc + + -- Suppress unused-match reporting for fields introduced by ".." + nested_mk Nothing mk _ = mk + nested_mk (Just _) mk@(LetMk {}) _ = mk + nested_mk (Just (unLoc -> n)) (LamMk report_unused) n' + = LamMk (report_unused && (n' <= n)) + +{- +************************************************************************ +* * + Record fields +* * +************************************************************************ +-} + +data HsRecFieldContext + = HsRecFieldCon Name + | HsRecFieldPat Name + | HsRecFieldUpd + +rnHsRecFields + :: forall arg. + HsRecFieldContext + -> (SrcSpan -> RdrName -> arg) + -- When punning, use this to build a new field + -> HsRecFields GhcPs (Located arg) + -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) + +-- This surprisingly complicated pass +-- a) looks up the field name (possibly using disambiguation) +-- b) fills in puns and dot-dot stuff +-- When we've finished, we've renamed the LHS, but not the RHS, +-- of each x=e binding +-- +-- This is used for record construction and pattern-matching, but not updates. + +rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) + = do { pun_ok <- xoptM LangExt.RecordPuns + ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields + ; let parent = guard disambig_ok >> mb_con + ; flds1 <- mapM (rn_fld pun_ok parent) flds + ; mapM_ (addErr . dupFieldErr ctxt) dup_flds + ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 + ; let all_flds | null dotdot_flds = flds1 + | otherwise = flds1 ++ dotdot_flds + ; return (all_flds, mkFVs (getFieldIds all_flds)) } + where + mb_con = case ctxt of + HsRecFieldCon con -> Just con + HsRecFieldPat con -> Just con + _ {- update -} -> Nothing + + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) + -> RnM (LHsRecField GhcRn (Located arg)) + rn_fld pun_ok parent (L l + (HsRecField + { hsRecFieldLbl = + (L loc (FieldOcc _ (L ll lbl))) + , hsRecFieldArg = arg + , hsRecPun = pun })) + = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl + ; arg' <- if pun + then do { checkErr pun_ok (badPun (L loc lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) + ; return (L loc (mk_arg loc arg_rdr)) } + else return arg + ; return (L l (HsRecField + { hsRecFieldLbl = (L loc (FieldOcc + sel (L ll lbl))) + , hsRecFieldArg = arg' + , hsRecPun = pun })) } + + + rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat + -> Maybe Name -- The constructor (Nothing for an + -- out of scope constructor) + -> [LHsRecField GhcRn (Located arg)] -- Explicit fields + -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in + rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match + | not (isUnboundName con) -- This test is because if the constructor + -- isn't in scope the constructor lookup will add + -- an error but still return an unbound name. We + -- don't want that to screw up the dot-dot fill-in stuff. + = ASSERT( flds `lengthIs` n ) + do { dd_flag <- xoptM LangExt.RecordWildCards + ; checkErr dd_flag (needFlagDotDot ctxt) + ; (rdr_env, lcl_env) <- getRdrEnvs + ; con_fields <- lookupConstructorFields con + ; when (null con_fields) (addErr (badDotDotCon con)) + ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds) + + -- For constructor uses (but not patterns) + -- the arg should be in scope locally; + -- i.e. not top level or imported + -- Eg. data R = R { x,y :: Int } + -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} + arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env + + (dot_dot_fields, dot_dot_gres) + = unzip [ (fl, gre) + | fl <- con_fields + , let lbl = mkVarOccFS (flLabel fl) + , not (lbl `elemOccSet` present_flds) + , Just gre <- [lookupGRE_FieldLabel rdr_env fl] + -- Check selector is in scope + , case ctxt of + HsRecFieldCon {} -> arg_in_scope lbl + _other -> True ] + + ; addUsedGREs dot_dot_gres + ; return [ L loc (HsRecField + { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) + , hsRecFieldArg = L loc (mk_arg loc arg_rdr) + , hsRecPun = False }) + | fl <- dot_dot_fields + , let sel = flSelector fl + , let arg_rdr = mkVarUnqual (flLabel fl) ] } + + rn_dotdot _dotdot _mb_con _flds + = return [] + -- _dotdot = Nothing => No ".." at all + -- _mb_con = Nothing => Record update + -- _mb_con = Just unbound => Out of scope data constructor + + dup_flds :: [NE.NonEmpty RdrName] + -- Each list represents a RdrName that occurred more than once + -- (the list contains all occurrences) + -- Each list in dup_fields is non-empty + (_, dup_flds) = removeDups compare (getFieldLbls flds) + + +-- NB: Consider this: +-- module Foo where { data R = R { fld :: Int } } +-- module Odd where { import Foo; fld x = x { fld = 3 } } +-- Arguably this should work, because the reference to 'fld' is +-- unambiguous because there is only one field id 'fld' in scope. +-- But currently it's rejected. + +rnHsRecUpdFields + :: [LHsRecUpdField GhcPs] + -> RnM ([LHsRecUpdField GhcRn], FreeVars) +rnHsRecUpdFields flds + = do { pun_ok <- xoptM LangExt.RecordPuns + ; overload_ok <- xoptM LangExt.DuplicateRecordFields + ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds + ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds + + -- Check for an empty record update e {} + -- NB: don't complain about e { .. }, because rn_dotdot has done that already + ; when (null flds) $ addErr emptyUpdateErr + + ; return (flds1, plusFVs fvss) } + where + doc = text "constructor field name" + + rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs + -> RnM (LHsRecUpdField GhcRn, FreeVars) + rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f + , hsRecFieldArg = arg + , hsRecPun = pun })) + = do { let lbl = rdrNameAmbiguousFieldOcc f + ; sel <- setSrcSpan loc $ + -- Defer renaming of overloaded fields to the typechecker + -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Expr + if overload_ok + then do { mb <- lookupGlobalOccRn_overloaded + overload_ok lbl + ; case mb of + Nothing -> + do { addErr + (unknownSubordinateErr doc lbl) + ; return (Right []) } + Just r -> return r } + else fmap Left $ lookupGlobalOccRn lbl + ; arg' <- if pun + then do { checkErr pun_ok (badPun (L loc lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) + ; return (L loc (HsVar noExtField (L loc arg_rdr))) } + else return arg + ; (arg'', fvs) <- rnLExpr arg' + + ; let fvs' = case sel of + Left sel_name -> fvs `addOneFV` sel_name + Right [sel_name] -> fvs `addOneFV` sel_name + Right _ -> fvs + lbl' = case sel of + Left sel_name -> + L loc (Unambiguous sel_name (L loc lbl)) + Right [sel_name] -> + L loc (Unambiguous sel_name (L loc lbl)) + Right _ -> L loc (Ambiguous noExtField (L loc lbl)) + + ; return (L l (HsRecField { hsRecFieldLbl = lbl' + , hsRecFieldArg = arg'' + , hsRecPun = pun }), fvs') } + + dup_flds :: [NE.NonEmpty RdrName] + -- Each list represents a RdrName that occurred more than once + -- (the list contains all occurrences) + -- Each list in dup_fields is non-empty + (_, dup_flds) = removeDups compare (getFieldUpdLbls flds) + + + +getFieldIds :: [LHsRecField GhcRn arg] -> [Name] +getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds + +getFieldLbls :: [LHsRecField id arg] -> [RdrName] +getFieldLbls flds + = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds + +getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] +getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds + +needFlagDotDot :: HsRecFieldContext -> SDoc +needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, + text "Use RecordWildCards to permit this"] + +badDotDotCon :: Name -> SDoc +badDotDotCon con + = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) + , nest 2 (text "The constructor has no labelled fields") ] + +emptyUpdateErr :: SDoc +emptyUpdateErr = text "Empty record update" + +badPun :: Located RdrName -> SDoc +badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld), + text "Use NamedFieldPuns to permit this"] + +dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc +dupFieldErr ctxt dups + = hsep [text "duplicate field name", + quotes (ppr (NE.head dups)), + text "in record", pprRFC ctxt] + +pprRFC :: HsRecFieldContext -> SDoc +pprRFC (HsRecFieldCon {}) = text "construction" +pprRFC (HsRecFieldPat {}) = text "pattern" +pprRFC (HsRecFieldUpd {}) = text "update" + +{- +************************************************************************ +* * +\subsubsection{Literals} +* * +************************************************************************ + +When literals occur we have to make sure +that the types and classes they involve +are made available. +-} + +rnLit :: HsLit p -> RnM () +rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) +rnLit _ = return () + +-- Turn a Fractional-looking literal which happens to be an integer into an +-- Integer-looking literal. +generalizeOverLitVal :: OverLitVal -> OverLitVal +generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val})) + | denominator val == 1 = HsIntegral (IL { il_text=src + , il_neg=neg + , il_value=numerator val}) +generalizeOverLitVal lit = lit + +isNegativeZeroOverLit :: HsOverLit t -> Bool +isNegativeZeroOverLit lit + = case ol_val lit of + HsIntegral i -> 0 == il_value i && il_neg i + HsFractional f -> 0 == fl_value f && fl_neg f + _ -> False + +{- +Note [Negative zero] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There were problems with negative zero in conjunction with Negative Literals +extension. Numeric literal value is contained in Integer and Rational types +inside IntegralLit and FractionalLit. These types cannot represent negative +zero value. So we had to add explicit field 'neg' which would hold information +about literal sign. Here in rnOverLit we use it to detect negative zeroes and +in this case return not only literal itself but also negateName so that users +can apply it explicitly. In this case it stays negative zero. #13211 +-} + +rnOverLit :: HsOverLit t -> + RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) +rnOverLit origLit + = do { opt_NumDecimals <- xoptM LangExt.NumDecimals + ; let { lit@(OverLit {ol_val=val}) + | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)} + | otherwise = origLit + } + ; let std_name = hsOverLitName val + ; (from_thing_name, fvs1) <- lookupSyntaxName std_name + ; let rebindable = from_thing_name /= std_name + lit' = lit { ol_witness = nl_HsVar from_thing_name + , ol_ext = rebindable } + ; if isNegativeZeroOverLit lit' + then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName + ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name) + , fvs1 `plusFV` fvs2) } + else return ((lit', Nothing), fvs1) } + +{- +************************************************************************ +* * +\subsubsection{Errors} +* * +************************************************************************ +-} + +patSigErr :: Outputable a => a -> SDoc +patSigErr ty + = (text "Illegal signature in pattern:" <+> ppr ty) + $$ nest 4 (text "Use ScopedTypeVariables to permit it") + +bogusCharError :: Char -> SDoc +bogusCharError c + = text "character literal out of range: '\\" <> char c <> char '\'' + +badViewPat :: Pat GhcPs -> SDoc +badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, + text "Use ViewPatterns to enable view patterns"] diff --git a/GHC/Rename/Splice.hs b/GHC/Rename/Splice.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Splice.hs @@ -0,0 +1,972 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Rename.Splice ( + rnTopSpliceDecls, + rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, + rnBracket, + checkThLocalName + , traceSplice, SpliceInfo(..) + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Monad + +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) +import GHC.Rename.Unbound ( isUnboundName ) +import GHC.Rename.Module ( rnSrcDecls, findSplice ) +import GHC.Rename.Pat ( rnPat ) +import GHC.Types.Basic ( TopLevelFlag, isTopLevel, SourceText(..) ) +import GHC.Utils.Outputable +import GHC.Unit.Module +import GHC.Types.SrcLoc +import GHC.Rename.HsType ( rnLHsType ) + +import Control.Monad ( unless, when ) + +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) + +import GHC.Tc.Utils.Env ( checkWellStaged ) +import GHC.Builtin.Names.TH ( liftName ) + +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) +import GHC.Tc.Utils.Env ( tcMetaTy ) +import GHC.Driver.Hooks +import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName + , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) + +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr ) +import {-# SOURCE #-} GHC.Tc.Gen.Splice + ( runMetaD + , runMetaE + , runMetaP + , runMetaT + , tcTopSpliceExpr + ) + +import GHC.Tc.Utils.Zonk + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) + +import qualified GHC.LanguageExtensions as LangExt + +{- +************************************************************************ +* * + Template Haskell brackets +* * +************************************************************************ +-} + +rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnBracket e br_body + = addErrCtxt (quotationCtxtDoc br_body) $ + do { -- Check that -XTemplateHaskellQuotes is enabled and available + thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes + ; unless thQuotesEnabled $ + failWith ( vcat + [ text "Syntax error on" <+> ppr e + , text ("Perhaps you intended to use TemplateHaskell" + ++ " or TemplateHaskellQuotes") ] ) + + -- Check for nested brackets + ; cur_stage <- getStage + ; case cur_stage of + { Splice Typed -> checkTc (isTypedBracket br_body) + illegalUntypedBracket + ; Splice Untyped -> checkTc (not (isTypedBracket br_body)) + illegalTypedBracket + ; RunSplice _ -> + -- See Note [RunSplice ThLevel] in GHC.Tc.Types. + pprPanic "rnBracket: Renaming bracket when running a splice" + (ppr e) + ; Comp -> return () + ; Brack {} -> failWithTc illegalBracket + } + + -- Brackets are desugared to code that mentions the TH package + ; recordThUse + + ; case isTypedBracket br_body of + True -> do { traceRn "Renaming typed TH bracket" empty + ; (body', fvs_e) <- + setStage (Brack cur_stage RnPendingTyped) $ + rn_bracket cur_stage br_body + ; return (HsBracket noExtField body', fvs_e) } + + False -> do { traceRn "Renaming untyped TH bracket" empty + ; ps_var <- newMutVar [] + ; (body', fvs_e) <- + -- See Note [Rebindable syntax and Template Haskell] + unsetXOptM LangExt.RebindableSyntax $ + setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ + rn_bracket cur_stage br_body + ; pendings <- readMutVar ps_var + ; return (HsRnBracketOut noExtField body' pendings, fvs_e) } + } + +rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) +rn_bracket outer_stage br@(VarBr x flg rdr_name) + = do { name <- lookupOccRn rdr_name + ; this_mod <- getModule + + ; when (flg && nameIsLocalOrFrom this_mod name) $ + -- Type variables can be quoted in TH. See #5721. + do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name + ; case mb_bind_lvl of + { Nothing -> return () -- Can happen for data constructors, + -- but nothing needs to be done for them + + ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] + | isTopLevel top_lvl + -> when (isExternalName name) (keepAlive name) + | otherwise + -> do { traceRn "rn_bracket VarBr" + (ppr name <+> ppr bind_lvl + <+> ppr outer_stage) + ; checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr br) } + } + } + ; return (VarBr x flg name, unitFV name) } + +rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr x e', fvs) } + +rn_bracket _ (PatBr x p) + = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) + +rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr x t', fvs) } + +rn_bracket _ (DecBrL x decls) + = do { group <- groupDecls decls + ; gbl_env <- getGblEnv + ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } + -- The emptyDUs is so that we just collect uses for this + -- group alone in the call to rnSrcDecls below + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + rnSrcDecls group + + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env))) + ; return (DecBrG x group', duUses (tcg_dus tcg_env)) } + where + groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) + groupDecls decls + = do { (group, mb_splice) <- findSplice decls + ; case mb_splice of + { Nothing -> return group + ; Just (splice, rest) -> + do { group' <- groupDecls rest + ; let group'' = appendGroups group group' + ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } + } + }} + +rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" + +rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr x e', fvs) } + +quotationCtxtDoc :: HsBracket GhcPs -> SDoc +quotationCtxtDoc br_body + = hang (text "In the Template Haskell quotation") + 2 (ppr br_body) + +illegalBracket :: SDoc +illegalBracket = + text "Template Haskell brackets cannot be nested" <+> + text "(without intervening splices)" + +illegalTypedBracket :: SDoc +illegalTypedBracket = + text "Typed brackets may only appear in typed splices." + +illegalUntypedBracket :: SDoc +illegalUntypedBracket = + text "Untyped brackets may only appear in untyped splices." + +quotedNameStageErr :: HsBracket GhcPs -> SDoc +quotedNameStageErr br + = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br + , text "must be used at the same stage at which it is bound" ] + + +{- +********************************************************* +* * + Splices +* * +********************************************************* + +Note [Free variables of typed splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider renaming this: + f = ... + h = ...$(thing "f")... + +where the splice is a *typed* splice. The splice can expand into +literally anything, so when we do dependency analysis we must assume +that it might mention 'f'. So we simply treat all locally-defined +names as mentioned by any splice. This is terribly brutal, but I +don't see what else to do. For example, it'll mean that every +locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' +before 'f', and that will crash the type checker because 'f' isn't in +scope. + +Currently, I'm not treating a splice as also mentioning every import, +which is a bit inconsistent -- but there are a lot of them. We might +thereby get some bogus unused-import warnings, but we won't crash the +type checker. Not very satisfactory really. + +Note [Renamer errors] +~~~~~~~~~~~~~~~~~~~~~ +It's important to wrap renamer calls in checkNoErrs, because the +renamer does not fail for out of scope variables etc. Instead it +returns a bogus term/type, so that it can report more than one error. +We don't want the type checker to see these bogus unbound variables. +-} + +rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars)) + -- Outside brackets, run splice + -> (HsSplice GhcRn -> (PendingRnSplice, a)) + -- Inside brackets, make it pending + -> HsSplice GhcPs + -> RnM (a, FreeVars) +rnSpliceGen run_splice pend_splice splice + = addErrCtxt (spliceCtxt splice) $ do + { stage <- getStage + ; case stage of + Brack pop_stage RnPendingTyped + -> do { checkTc is_typed_splice illegalUntypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (_pending_splice, result) = pend_splice splice' + ; return (result, fvs) } + + Brack pop_stage (RnPendingUntyped ps_var) + -> do { checkTc (not is_typed_splice) illegalTypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (pending_splice, result) = pend_splice splice' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (pending_splice : ps) + ; return (result, fvs) } + + _ -> do { checkTopSpliceAllowed splice + ; (splice', fvs1) <- checkNoErrs $ + setStage (Splice splice_type) $ + rnSplice splice + -- checkNoErrs: don't attempt to run the splice if + -- renaming it failed; otherwise we get a cascade of + -- errors from e.g. unbound variables + ; (result, fvs2) <- run_splice splice' + ; return (result, fvs1 `plusFV` fvs2) } } + where + is_typed_splice = isTypedSplice splice + splice_type = if is_typed_splice + then Typed + else Untyped + + +-- Nested splices are fine without TemplateHaskell because they +-- are not executed until the top-level splice is run. +checkTopSpliceAllowed :: HsSplice GhcPs -> RnM () +checkTopSpliceAllowed splice = do + let (herald, ext) = spliceExtension splice + extEnabled <- xoptM ext + unless extEnabled + (failWith $ text herald <+> text "are not permitted without" <+> ppr ext) + where + spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension) + spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes) + spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) + spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) + spliceExtension s@(HsSpliced {}) = pprPanic "spliceExtension" (ppr s) + +------------------ + +-- | Returns the result of running a splice and the modFinalizers collected +-- during the execution. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +runRnSplice :: UntypedSpliceFlavour + -> (LHsExpr GhcTc -> TcRn res) + -> (res -> SDoc) -- How to pretty-print res + -- Usually just ppr, but not for [Decl] + -> HsSplice GhcRn -- Always untyped + -> TcRn (res, [ForeignRef (TH.Q ())]) +runRnSplice flavour run_meta ppr_res splice + = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) + + ; let the_expr = case splice' of + HsUntypedSplice _ _ _ e -> e + HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str + HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) + HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + + -- Typecheck the expression + ; meta_exp_ty <- tcMetaTy meta_ty_name + ; zonked_q_expr <- zonkTopLExpr =<< + tcTopSpliceExpr Untyped + (tcCheckPolyExpr the_expr meta_exp_ty) + + -- Run the expression + ; mod_finalizers_ref <- newTcRef [] + ; result <- setStage (RunSplice mod_finalizers_ref) $ + run_meta zonked_q_expr + ; mod_finalizers <- readTcRef mod_finalizers_ref + ; traceSplice (SpliceInfo { spliceDescription = what + , spliceIsDecl = is_decl + , spliceSource = Just the_expr + , spliceGenerated = ppr_res result }) + + ; return (result, mod_finalizers) } + + where + meta_ty_name = case flavour of + UntypedExpSplice -> expQTyConName + UntypedPatSplice -> patQTyConName + UntypedTypeSplice -> typeQTyConName + UntypedDeclSplice -> decsQTyConName + what = case flavour of + UntypedExpSplice -> "expression" + UntypedPatSplice -> "pattern" + UntypedTypeSplice -> "type" + UntypedDeclSplice -> "declarations" + is_decl = case flavour of + UntypedDeclSplice -> True + _ -> False + +------------------ +makePending :: UntypedSpliceFlavour + -> HsSplice GhcRn + -> PendingRnSplice +makePending flavour (HsUntypedSplice _ _ n e) + = PendingRnSplice flavour n e +makePending flavour (HsQuasiQuote _ n quoter q_span quote) + = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) +makePending _ splice@(HsTypedSplice {}) + = pprPanic "makePending" (ppr splice) +makePending _ splice@(HsSpliced {}) + = pprPanic "makePending" (ppr splice) + +------------------ +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString + -> LHsExpr GhcRn +-- Return the expression (quoter "...quote...") +-- which is what we must run in a quasi-quote +mkQuasiQuoteExpr flavour quoter q_span quote + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector))) + quoterExpr) + quoteExpr + where + quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter) + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote + quote_selector = case flavour of + UntypedExpSplice -> quoteExpName + UntypedPatSplice -> quotePatName + UntypedTypeSplice -> quoteTypeName + UntypedDeclSplice -> quoteDecName + +--------------------- +rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) +-- Not exported...used for all +rnSplice (HsTypedSplice x hasParen splice_name expr) + = do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc splice_name) + ; (expr', fvs) <- rnLExpr expr + ; return (HsTypedSplice x hasParen n' expr', fvs) } + +rnSplice (HsUntypedSplice x hasParen splice_name expr) + = do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc splice_name) + ; (expr', fvs) <- rnLExpr expr + ; return (HsUntypedSplice x hasParen n' expr', fvs) } + +rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) + = do { loc <- getSrcSpanM + ; splice_name' <- newLocalBndrRn (L loc splice_name) + + -- Rename the quoter; akin to the HsVar case of rnExpr + ; quoter' <- lookupOccRn quoter + ; this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod quoter') $ + checkThLocalName quoter' + + ; return (HsQuasiQuote x splice_name' quoter' q_loc quote + , unitFV quoter') } + +rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) + +--------------------- +rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnSpliceExpr splice + = rnSpliceGen run_expr_splice pend_expr_splice splice + where + pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) + pend_expr_splice rn_splice + = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice) + + run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) + run_expr_splice rn_splice + | isTypedSplice rn_splice -- Run it later, in the type checker + = do { -- Ugh! See Note [Splices] above + traceRn "rnSpliceExpr: typed expression splice" empty + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + + ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) } + + | otherwise -- Run it here, see Note [Running splices in the Renamer] + = do { traceRn "rnSpliceExpr: untyped expression splice" empty + ; (rn_expr, mod_finalizers) <- + runRnSplice UntypedExpSplice runMetaE ppr rn_splice + ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsPar noExtField $ HsSpliceE noExtField + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedExpr <$> + lexpr3 + , fvs) + } + +{- Note [Running splices in the Renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Splices used to be run in the typechecker, which led to (#4364). Since the +renamer must decide which expressions depend on which others, and it cannot +reliably do this for arbitrary splices, we used to conservatively say that +splices depend on all other expressions in scope. Unfortunately, this led to +the problem of cyclic type declarations seen in (#4364). Instead, by +running splices in the renamer, we side-step the problem of determining +dependencies: by the time the dependency analysis happens, any splices have +already been run, and expression dependencies can be determined as usual. + +However, see (#9813), for an example where we would like to run splices +*after* performing dependency analysis (that is, after renaming). It would be +desirable to typecheck "non-splicy" expressions (those expressions that do not +contain splices directly or via dependence on an expression that does) before +"splicy" expressions, such that types/expressions within the same declaration +group would be available to `reify` calls, for example consider the following: + +> module M where +> data D = C +> f = 1 +> g = $(mapM reify ['f, 'D, ''C] ...) + +Compilation of this example fails since D/C/f are not in the type environment +and thus cannot be reified as they have not been typechecked by the time the +splice is renamed and thus run. + +These requirements are at odds: we do not want to run splices in the renamer as +we wish to first determine dependencies and typecheck certain expressions, +making them available to reify, but cannot accurately determine dependencies +without running splices in the renamer! + +Indeed, the conclusion of (#9813) was that it is not worth the complexity +to try and + a) implement and maintain the code for renaming/typechecking non-splicy + expressions before splicy expressions, + b) explain to TH users which expressions are/not available to reify at any + given point. + +-} + +{- Note [Rebindable syntax and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When processing Template Haskell quotes with Rebindable Syntax (RS) enabled, +there are two possibilities: apply the RS rules to the quotes or don't. + +One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a +module, any 'if' expression would end up being turned into a call to whatever +'ifThenElse' function is in scope, regardless of whether the said if expression +appears in "normal" Haskell code or in a TH quote. This however comes with its +problems. Consider the following code: + + {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} + + module X where + + import Prelude ( Monad(..), Bool(..), print, ($) ) + import Language.Haskell.TH.Syntax + + $( do stuff <- [| if True then 10 else 15 |] + runIO $ print stuff + return [] ) + +If we apply the RS rules, then GHC would complain about not having suitable +fromInteger/ifThenElse functions in scope. But this quote is just a bit of +Haskell syntax that has yet to be used, or, to put it differently, placed +(spliced) in some context where the said functions might be available. More +generally, untyped TH quotes are meant to work with yet-unbound identifiers. +This tends to show that untyped TH and Rebindable Syntax overall don't play +well together. Users still have the option to splice "normal" if expressions +into modules where RS is enabled, to turn them into applications of +an 'ifThenElse' function of their choice. + +Typed TH (TTH) quotes, on the other hand, come with different constraints. They +don't quite have this "delayed" nature: we typecheck them while processing +them, and TTH users expect RS to Just Work in their quotes, exactly like it does +outside of the quotes. There, we do not have to accept unbound identifiers and +we can apply the RS rules both in the typechecking and desugaring of the quotes +without triggering surprising/bad behaviour for users. For instance, the +following code is expected to be rejected (because of the lack of suitable +'fromInteger'/'ifThenElse' functions in scope): + + {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} + + module X where + + import Prelude ( Monad(..), Bool(..), print, ($) ) + import Language.Haskell.TH.Syntax + + $$( do stuff <- [|| if True then 10 else 15 ||] + runIO $ print stuff + return [] ) + +The conclusion is that even if RS is enabled for a given module, GHC disables it +when processing untyped TH quotes from that module, to avoid the aforementioned +problems, but keeps it on while processing typed TH quotes. + +This note and approach originated in #18102. + +-} + +{- Note [Delaying modFinalizers in untyped splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When splices run in the renamer, 'reify' does not have access to the local +type environment (#11832, [1]). + +For instance, in + +> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |]) + +'reify' cannot find @x@, because the local type environment is not yet +populated. To address this, we allow 'reify' execution to be deferred with +'addModFinalizer'. + +> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print) + [| return () |] + ) + +The finalizer is run with the local type environment when type checking is +complete. + +Since the local type environment is not available in the renamer, we annotate +the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where +@e@ is the result of splicing and @finalizers@ are the finalizers that have been +collected during evaluation of the splice [3]. In our example, + +> HsLet +> (x = e) +> (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print] +> (HsSplicedExpr $ return ()) +> ) + +When the typechecker finds the annotation, it inserts the finalizers in the +global environment and exposes the current local environment to them [4, 5, 6]. + +> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print] + +References: + +[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify +[2] 'rnSpliceExpr' +[3] 'GHC.Tc.Gen.Splice.qAddModFinalizer' +[4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) +[5] 'GHC.Tc.Gen.HsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) +[6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...)) + +-} + +---------------------- +rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSpliceType splice + = rnSpliceGen run_type_splice pend_type_splice splice + where + pend_type_splice rn_splice + = ( makePending UntypedTypeSplice rn_splice + , HsSpliceTy noExtField rn_splice) + + run_type_splice rn_splice + = do { traceRn "rnSpliceType: untyped type splice" empty + ; (hs_ty2, mod_finalizers) <- + runRnSplice UntypedTypeSplice runMetaT ppr rn_splice + ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 + ; checkNoErrs $ rnLHsType doc hs_ty2 } + -- checkNoErrs: see Note [Renamer errors] + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsParTy noExtField + $ HsSpliceTy noExtField + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedTy <$> + hs_ty3 + , fvs + ) } + -- Wrap the result of the splice in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + +{- Note [Partial Type Splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Partial Type Signatures are partially supported in TH type splices: only +anonymous wild cards are allowed. + + -- ToDo: SLPJ says: I don't understand all this + +Normally, named wild cards are collected before renaming a (partial) type +signature. However, TH type splices are run during renaming, i.e. after the +initial traversal, leading to out of scope errors for named wild cards. We +can't just extend the initial traversal to collect the named wild cards in TH +type splices, as we'd need to expand them, which is supposed to happen only +once, during renaming. + +Similarly, the extra-constraints wild card is handled right before renaming +too, and is therefore also not supported in a TH type splice. Another reason +to forbid extra-constraints wild cards in TH type splices is that a single +signature can contain many TH type splices, whereas it mustn't contain more +than one extra-constraints wild card. Enforcing would this be hard the way +things are currently organised. + +Anonymous wild cards pose no problem, because they start out without names and +are given names during renaming. These names are collected right after +renaming. The names generated for anonymous wild cards in TH type splices will +thus be collected as well. + +For more details about renaming wild cards, see GHC.Rename.HsType.rnHsSigWcType + +Note that partial type signatures are fully supported in TH declaration +splices, e.g.: + + [d| foo :: _ => _ + foo x y = x == y |] + +This is because in this case, the partial type signature can be treated as a +whole signature, instead of as an arbitrary type. + +-} + + +---------------------- +-- | Rename a splice pattern. See Note [rnSplicePat] +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) + , FreeVars) +rnSplicePat splice + = rnSpliceGen run_pat_splice pend_pat_splice splice + where + pend_pat_splice :: HsSplice GhcRn -> + (PendingRnSplice, Either b (Pat GhcRn)) + pend_pat_splice rn_splice + = (makePending UntypedPatSplice rn_splice + , Right (SplicePat noExtField rn_splice)) + + run_pat_splice :: HsSplice GhcRn -> + RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars) + run_pat_splice rn_splice + = do { traceRn "rnSplicePat: untyped pattern splice" empty + ; (pat, mod_finalizers) <- + runRnSplice UntypedPatSplice runMetaP ppr rn_splice + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedPat) `mapLoc` + pat + , emptyFVs + ) } + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + +---------------------- +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) +rnSpliceDecl (SpliceDecl _ (L loc splice) flg) + = rnSpliceGen run_decl_splice pend_decl_splice splice + where + pend_decl_splice rn_splice + = ( makePending UntypedDeclSplice rn_splice + , SpliceDecl noExtField (L loc rn_splice) flg) + + run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) + +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) +-- Declaration splice at the very top level of the module +rnTopSpliceDecls splice + = do { checkTopSpliceAllowed splice + ; (rn_splice, fvs) <- checkNoErrs $ + setStage (Splice Untyped) $ + rnSplice splice + -- As always, be sure to checkNoErrs above lest we end up with + -- holes making it to typechecking, hence #12584. + -- + -- Note that we cannot call checkNoErrs for the whole duration + -- of rnTopSpliceDecls. The reason is that checkNoErrs changes + -- the local environment to temporarily contain a new + -- reference to store errors, and add_mod_finalizers would + -- cause this reference to be stored after checkNoErrs finishes. + -- This is checked by test TH_finalizer. + ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty + ; (decls, mod_finalizers) <- checkNoErrs $ + runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice + ; add_mod_finalizers_now mod_finalizers + ; return (decls,fvs) } + where + ppr_decls :: [LHsDecl GhcPs] -> SDoc + ppr_decls ds = vcat (map ppr ds) + + -- Adds finalizers to the global environment instead of delaying them + -- to the type checker. + -- + -- Declaration splices do not have an interesting local environment so + -- there is no point in delaying them. + -- + -- See Note [Delaying modFinalizers in untyped splices]. + add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn () + add_mod_finalizers_now [] = return () + add_mod_finalizers_now mod_finalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + env <- getLclEnv + updTcRef th_modfinalizers_var $ \fins -> + (env, ThModFinalizers mod_finalizers) : fins + + +{- +Note [rnSplicePat] +~~~~~~~~~~~~~~~~~~ +Renaming a pattern splice is a bit tricky, because we need the variables +bound in the pattern to be in scope in the RHS of the pattern. This scope +management is effectively done by using continuation-passing style in +GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here +(it would create import cycles and generally conflict with renaming other +splices), so we really want to return a (Pat RdrName) -- the result of +running the splice -- which can then be further renamed in GHC.Rename.Pat, in +the CpsRn monad. + +The problem is that if we're renaming a splice within a bracket, we +*don't* want to run the splice now. We really do just want to rename +it to an HsSplice Name. Of course, then we can't know what variables +are bound within the splice. So we accept any unbound variables and +rename them again when the bracket is spliced in. If a variable is brought +into scope by a pattern splice all is fine. If it is not then an error is +reported. + +In any case, when we're done in rnSplicePat, we'll either have a +Pat RdrName (the result of running a top-level splice) or a Pat Name +(the renamed nested splice). Thus, the awkward return type of +rnSplicePat. +-} + +spliceCtxt :: HsSplice GhcPs -> SDoc +spliceCtxt splice + = hang (text "In the" <+> what) 2 (ppr splice) + where + what = case splice of + HsUntypedSplice {} -> text "untyped splice:" + HsTypedSplice {} -> text "typed splice:" + HsQuasiQuote {} -> text "quasi-quotation:" + HsSpliced {} -> text "spliced expression:" + +-- | The splice data to be logged +data SpliceInfo + = SpliceInfo + { spliceDescription :: String + , spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls + -- added by addTopDecls + , spliceIsDecl :: Bool -- True <=> put the generate code in a file + -- when -dth-dec-file is on + , spliceGenerated :: SDoc + } + -- Note that 'spliceSource' is *renamed* but not *typechecked* + -- Reason (a) less typechecking crap + -- (b) data constructors after type checking have been + -- changed to their *wrappers*, and that makes them + -- print always fully qualified + +-- | outputs splice information for 2 flags which have different output formats: +-- `-ddump-splices` and `-dth-dec-file` +traceSplice :: SpliceInfo -> TcM () +traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src + , spliceGenerated = gen, spliceIsDecl = is_decl }) + = do { loc <- case mb_src of + Nothing -> getSrcSpanM + Just (L loc _) -> return loc + ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) + + ; when is_decl $ -- Raw material for -dth-dec-file + do { dflags <- getDynFlags + ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file + "" FormatHaskell (spliceCodeDoc loc) } } + where + -- `-ddump-splices` + spliceDebugDoc :: SrcSpan -> SDoc + spliceDebugDoc loc + = let code = case mb_src of + Nothing -> ending + Just e -> nest 2 (ppr (stripParensLHsExpr e)) : ending + ending = [ text "======>", nest 2 gen ] + in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) + 2 (sep code) + + -- `-dth-dec-file` + spliceCodeDoc :: SrcSpan -> SDoc + spliceCodeDoc loc + = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd + , gen ] + +illegalTypedSplice :: SDoc +illegalTypedSplice = text "Typed splices may not appear in untyped brackets" + +illegalUntypedSplice :: SDoc +illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" + +checkThLocalName :: Name -> RnM () +checkThLocalName name + | isUnboundName name -- Do not report two errors for + = return () -- $(not_in_scope args) + + | otherwise + = do { traceRn "checkThLocalName" (ppr name) + ; mb_local_use <- getStageAndBindLevel name + ; case mb_local_use of { + Nothing -> return () ; -- Not a locally-bound thing + Just (top_lvl, bind_lvl, use_stage) -> + do { let use_lvl = thLevel use_stage + ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl + ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl + <+> ppr use_stage + <+> ppr use_lvl) + ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } } + +-------------------------------------- +checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel + -> Name -> TcM () +-- We are inside brackets, and (use_lvl > bind_lvl) +-- Now we must check whether there's a cross-stage lift to do +-- Examples \x -> [| x |] +-- [| map |] +-- +-- This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but +-- this is only run on *untyped* brackets. + +checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name + | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets + , use_lvl > bind_lvl -- Cross-stage condition + = check_cross_stage_lifting top_lvl name ps_var + | otherwise + = return () + +check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () +check_cross_stage_lifting top_lvl name ps_var + | isTopLevel top_lvl + -- Top-level identifiers in this module, + -- (which have External Names) + -- are just like the imported case: + -- no need for the 'lifting' treatment + -- E.g. this is fine: + -- f x = x + -- g y = [| f 3 |] + = when (isExternalName name) (keepAlive name) + -- See Note [Keeping things alive for Template Haskell] + + | otherwise + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the SplicePointName, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same SplicePointName, but that doesn't + -- matter, although it's a mite untidy. + do { traceRn "checkCrossStageLifting" (ppr name) + + -- Construct the (lift x) expression + ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) + pend_splice = PendingRnSplice UntypedExpSplice name lift_expr + + -- Update the pending splices + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (pend_splice : ps) } + +{- +Note [Keeping things alive for Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = x+1 + g y = [| f 3 |] + +Here 'f' is referred to from inside the bracket, which turns into data +and mentions only f's *name*, not 'f' itself. So we need some other +way to keep 'f' alive, lest it get dropped as dead code. That's what +keepAlive does. It puts it in the keep-alive set, which subsequently +ensures that 'f' stays as a top level binding. + +This must be done by the renamer, not the type checker (as of old), +because the type checker doesn't typecheck the body of untyped +brackets (#8540). + +A thing can have a bind_lvl of outerLevel, but have an internal name: + foo = [d| op = 3 + bop = op + 1 |] +Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is +bound inside a bracket. That is because we don't even record +binding levels for top-level things; the binding levels are in the +LocalRdrEnv. + +So the occurrence of 'op' in the rhs of 'bop' looks a bit like a +cross-stage thing, but it isn't really. And in fact we never need +to do anything here for top-level bound things, so all is fine, if +a bit hacky. + +For these chaps (which have Internal Names) we don't want to put +them in the keep-alive set. + +Note [Quoting names] +~~~~~~~~~~~~~~~~~~~~ +A quoted name 'n is a bit like a quoted expression [| n |], except that we +have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing +the use-level to account for the brackets, the cases are: + + bind > use Error + bind = use+1 OK + bind < use + Imported things OK + Top-level things OK + Non-top-level Error + +where 'use' is the binding level of the 'n quote. (So inside the implied +bracket the level would be use+1.) + +Examples: + + f 'map -- OK; also for top-level defns of this module + + \x. f 'x -- Not ok (bind = 1, use = 1) + -- (whereas \x. f [| x |] might have been ok, by + -- cross-stage lifting + + \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) + + [| \x. $(f 'x) |] -- OK (bind = 2, use = 1) +-} diff --git a/GHC/Rename/Splice.hs-boot b/GHC/Rename/Splice.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Rename/Splice.hs-boot @@ -0,0 +1,14 @@ +module GHC.Rename.Splice where + +import GHC.Prelude +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Types.Name.Set + + +rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) + , FreeVars ) +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) + +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) diff --git a/GHC/Rename/Unbound.hs b/GHC/Rename/Unbound.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Unbound.hs @@ -0,0 +1,397 @@ +{- + +This module contains helper functions for reporting and creating +unbound variables. + +-} +module GHC.Rename.Unbound + ( mkUnboundName + , mkUnboundNameRdr + , isUnboundName + , reportUnboundName + , unknownNameSuggestions + , WhereLooking(..) + , unboundName + , unboundNameX + , notInScopeErr + , exactNameErr + ) +where + +import GHC.Prelude + +import GHC.Types.Name.Reader +import GHC.Driver.Types +import GHC.Tc.Utils.Monad +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.SrcLoc as SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Driver.Session +import GHC.Data.FastString +import Data.List +import Data.Function ( on ) +import GHC.Types.Unique.DFM (udfmToList) + +{- +************************************************************************ +* * + What to do when a lookup fails +* * +************************************************************************ +-} + +data WhereLooking = WL_Any -- Any binding + | WL_Global -- Any top-level binding (local or imported) + | WL_LocalTop -- Any top-level binding in this module + | WL_LocalOnly + -- Only local bindings + -- (pattern synonyms declaractions, + -- see Note [Renaming pattern synonym variables]) + +mkUnboundNameRdr :: RdrName -> Name +mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) + +reportUnboundName :: RdrName -> RnM Name +reportUnboundName rdr = unboundName WL_Any rdr + +unboundName :: WhereLooking -> RdrName -> RnM Name +unboundName wl rdr = unboundNameX wl rdr Outputable.empty + +unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name +unboundNameX where_look rdr_name extra + = do { dflags <- getDynFlags + ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags + err = notInScopeErr rdr_name $$ extra + ; if not show_helpful_errors + then addErr err + else do { local_env <- getLocalRdrEnv + ; global_env <- getGlobalRdrEnv + ; impInfo <- getImports + ; currmod <- getModule + ; hpt <- getHpt + ; let suggestions = unknownNameSuggestions_ where_look + dflags hpt currmod global_env local_env impInfo + rdr_name + ; addErr (err $$ suggestions) } + ; return (mkUnboundNameRdr rdr_name) } + +notInScopeErr :: RdrName -> SDoc +notInScopeErr rdr_name + = case isExact_maybe rdr_name of + Just name -> exactNameErr name + Nothing -> hang (text "Not in scope:") + 2 (what <+> quotes (ppr rdr_name)) + where + what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + +type HowInScope = Either SrcSpan ImpDeclSpec + -- Left loc => locally bound at loc + -- Right ispec => imported as specified by ispec + + +-- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable +unknownNameSuggestions :: DynFlags + -> HomePackageTable -> Module + -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails + -> RdrName -> SDoc +unknownNameSuggestions = unknownNameSuggestions_ WL_Any + +unknownNameSuggestions_ :: WhereLooking -> DynFlags + -> HomePackageTable -> Module + -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails + -> RdrName -> SDoc +unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env + imports tried_rdr_name = + similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$ + importSuggestions where_look global_env hpt + curr_mod imports tried_rdr_name $$ + extensionSuggestions tried_rdr_name + + +similarNameSuggestions :: WhereLooking -> DynFlags + -> GlobalRdrEnv -> LocalRdrEnv + -> RdrName -> SDoc +similarNameSuggestions where_look dflags global_env + local_env tried_rdr_name + = case suggest of + [] -> Outputable.empty + [p] -> perhaps <+> pp_item p + ps -> sep [ perhaps <+> text "one of these:" + , nest 2 (pprWithCommas pp_item ps) ] + where + all_possibilities :: [(String, (RdrName, HowInScope))] + all_possibilities + = [ (showPpr dflags r, (r, Left loc)) + | (r,loc) <- local_possibilities local_env ] + ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] + + suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities + perhaps = text "Perhaps you meant" + + pp_item :: (RdrName, HowInScope) -> SDoc + pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined + where loc' = case loc of + UnhelpfulSpan l -> parens (ppr l) + RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) + pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported + parens (text "imported from" <+> ppr (is_mod is)) + + pp_ns :: RdrName -> SDoc + pp_ns rdr | ns /= tried_ns = pprNameSpace ns + | otherwise = Outputable.empty + where ns = rdrNameSpace rdr + + tried_occ = rdrNameOcc tried_rdr_name + tried_is_sym = isSymOcc tried_occ + tried_ns = occNameSpace tried_occ + tried_is_qual = isQual tried_rdr_name + + correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns + && isSymOcc occ == tried_is_sym + -- Treat operator and non-operators as non-matching + -- This heuristic avoids things like + -- Not in scope 'f'; perhaps you meant '+' (from Prelude) + + local_ok = case where_look of { WL_Any -> True + ; WL_LocalOnly -> True + ; _ -> False } + local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] + local_possibilities env + | tried_is_qual = [] + | not local_ok = [] + | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) + | name <- localRdrEnvElts env + , let occ = nameOccName name + , correct_name_space occ] + + global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] + global_possibilities global_env + | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) + | gre <- globalRdrEnvElts global_env + , isGreOk where_look gre + , let name = gre_name gre + occ = nameOccName name + , correct_name_space occ + , (mod, how) <- qualsInScope gre + , let rdr_qual = mkRdrQual mod occ ] + + | otherwise = [ (rdr_unqual, pair) + | gre <- globalRdrEnvElts global_env + , isGreOk where_look gre + , let name = gre_name gre + occ = nameOccName name + rdr_unqual = mkRdrUnqual occ + , correct_name_space occ + , pair <- case (unquals_in_scope gre, quals_only gre) of + (how:_, _) -> [ (rdr_unqual, how) ] + ([], pr:_) -> [ pr ] -- See Note [Only-quals] + ([], []) -> [] ] + + -- Note [Only-quals] + -- The second alternative returns those names with the same + -- OccName as the one we tried, but live in *qualified* imports + -- e.g. if you have: + -- + -- > import qualified Data.Map as Map + -- > foo :: Map + -- + -- then we suggest @Map.Map@. + + -------------------- + unquals_in_scope :: GlobalRdrElt -> [HowInScope] + unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) + | lcl = [ Left (nameSrcSpan n) ] + | otherwise = [ Right ispec + | i <- is, let ispec = is_decl i + , not (is_qual ispec) ] + + + -------------------- + quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] + -- Ones for which *only* the qualified version is in scope + quals_only (GRE { gre_name = n, gre_imp = is }) + = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) + | i <- is, let ispec = is_decl i, is_qual ispec ] + +-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. +importSuggestions :: WhereLooking + -> GlobalRdrEnv + -> HomePackageTable -> Module + -> ImportAvails -> RdrName -> SDoc +importSuggestions where_look global_env hpt currMod imports rdr_name + | WL_LocalOnly <- where_look = Outputable.empty + | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty + | null interesting_imports + , Just name <- mod_name + , show_not_imported_line name + = hsep + [ text "No module named" + , quotes (ppr name) + , text "is imported." + ] + | is_qualified + , null helpful_imports + , [(mod,_)] <- interesting_imports + = hsep + [ text "Module" + , quotes (ppr mod) + , text "does not export" + , quotes (ppr occ_name) <> dot + ] + | is_qualified + , null helpful_imports + , not (null interesting_imports) + , mods <- map fst interesting_imports + = hsep + [ text "Neither" + , quotedListWithNor (map ppr mods) + , text "exports" + , quotes (ppr occ_name) <> dot + ] + | [(mod,imv)] <- helpful_imports_non_hiding + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to the import list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | not (null helpful_imports_non_hiding) + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to one of these import lists:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- helpful_imports_non_hiding + ]) + | [(mod,imv)] <- helpful_imports_hiding + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the explicit hiding list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | not (null helpful_imports_hiding) + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the hiding clauses" + , text "in one of these imports:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- helpful_imports_hiding + ]) + | otherwise + = Outputable.empty + where + is_qualified = isQual rdr_name + (mod_name, occ_name) = case rdr_name of + Unqual occ_name -> (Nothing, occ_name) + Qual mod_name occ_name -> (Just mod_name, occ_name) + _ -> error "importSuggestions: dead code" + + + -- What import statements provide "Mod" at all + -- or, if this is an unqualified name, are not qualified imports + interesting_imports = [ (mod, imp) + | (mod, mod_imports) <- moduleEnvToList (imp_mods imports) + , Just imp <- return $ pick (importedByUser mod_imports) + ] + + -- We want to keep only one for each original module; preferably one with an + -- explicit import list (for no particularly good reason) + pick :: [ImportedModsVal] -> Maybe ImportedModsVal + pick = listToMaybe . sortBy cmp . filter select + where select imv = case mod_name of Just name -> imv_name imv == name + Nothing -> not (imv_qualified imv) + cmp a b = + (compare `on` imv_is_hiding) a b + `thenCmp` + (SrcLoc.leftmost_smallest `on` imv_span) a b + + -- Which of these would export a 'foo' + -- (all of these are restricted imports, because if they were not, we + -- wouldn't have an out-of-scope error in the first place) + helpful_imports = filter helpful interesting_imports + where helpful (_,imv) + = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name + + -- Which of these do that because of an explicit hiding list resp. an + -- explicit import list + (helpful_imports_hiding, helpful_imports_non_hiding) + = partition (imv_is_hiding . snd) helpful_imports + + -- See note [When to show/hide the module-not-imported line] + show_not_imported_line :: ModuleName -> Bool -- #15611 + show_not_imported_line modnam + | modnam `elem` globMods = False -- #14225 -- 1 + | moduleName currMod == modnam = False -- 2.1 + | is_last_loaded_mod modnam hpt_uniques = False -- 2.2 + | otherwise = True + where + hpt_uniques = map fst (udfmToList hpt) + is_last_loaded_mod _ [] = False + is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam + globMods = nub [ mod + | gre <- globalRdrEnvElts global_env + , isGreOk where_look gre + , (mod, _) <- qualsInScope gre + ] + +extensionSuggestions :: RdrName -> SDoc +extensionSuggestions rdrName + | rdrName == mkUnqual varName (fsLit "mdo") || + rdrName == mkUnqual varName (fsLit "rec") + = text "Perhaps you meant to use RecursiveDo" + | otherwise = Outputable.empty + +qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] +-- Ones for which the qualified version is in scope +qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is } + | lcl = case nameModule_maybe n of + Nothing -> [] + Just m -> [(moduleName m, Left (nameSrcSpan n))] + | otherwise = [ (is_as ispec, Right ispec) + | i <- is, let ispec = is_decl i ] + +isGreOk :: WhereLooking -> GlobalRdrElt -> Bool +isGreOk where_look = case where_look of + WL_LocalTop -> isLocalGRE + WL_LocalOnly -> const False + _ -> const True + +{- Note [When to show/hide the module-not-imported line] -- #15611 +For the error message: + Not in scope X.Y + Module X does not export Y + No module named ‘X’ is imported: +there are 2 cases, where we hide the last "no module is imported" line: +1. If the module X has been imported. +2. If the module X is the current module. There are 2 subcases: + 2.1 If the unknown module name is in a input source file, + then we can use the getModule function to get the current module name. + (See test T15611a) + 2.2 If the unknown module name has been entered by the user in GHCi, + then the getModule function returns something like "interactive:Ghci1", + and we have to check the current module in the last added entry of + the HomePackageTable. (See test T15611b) +-} + +exactNameErr :: Name -> SDoc +exactNameErr name = + hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) + 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " + , text "perhaps via newName, but did not bind it" + , text "If that's it, then -ddump-splices might be useful" ]) diff --git a/GHC/Rename/Utils.hs b/GHC/Rename/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Rename/Utils.hs @@ -0,0 +1,650 @@ +{- + +This module contains miscellaneous functions related to renaming. + +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Rename.Utils ( + checkDupRdrNames, checkShadowedRdrNames, + checkDupNames, checkDupAndShadowedNames, dupNamesErr, + checkTupSize, + addFvRn, mapFvRn, mapMaybeFvRn, + warnUnusedMatches, warnUnusedTypePatterns, + warnUnusedTopBinds, warnUnusedLocalBinds, + checkUnusedRecordWildcard, + mkFieldEnv, + unknownSubordinateErr, badQualBndrErr, typeAppErr, + HsDocContext(..), pprHsDocContext, + inHsDocContext, withHsDocContext, + + newLocalBndrRn, newLocalBndrsRn, + + bindLocalNames, bindLocalNamesFV, + + addNameClashErrRn, extendTyVarEnvFVRn, + + checkInferredVars, + noNestedForallsContextsErr, addNoNestedForallsContextsErr +) + +where + + +import GHC.Prelude + +import GHC.Core.Type +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Driver.Types +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Core.DataCon +import GHC.Types.SrcLoc as SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Basic ( TopLevelFlag(..) ) +import GHC.Data.List.SetOps ( removeDups ) +import GHC.Data.Maybe ( whenIsJust ) +import GHC.Driver.Session +import GHC.Data.FastString +import Control.Monad +import Data.List +import GHC.Settings.Constants ( mAX_TUPLE_SIZE ) +import qualified Data.List.NonEmpty as NE +import qualified GHC.LanguageExtensions as LangExt + +{- +********************************************************* +* * +\subsection{Binding} +* * +********************************************************* +-} + +newLocalBndrRn :: Located RdrName -> RnM Name +-- Used for non-top-level binders. These should +-- never be qualified. +newLocalBndrRn (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = return name -- This happens in code generated by Template Haskell + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + | otherwise + = do { unless (isUnqual rdr_name) + (addErrAt loc (badQualBndrErr rdr_name)) + ; uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + +newLocalBndrsRn :: [Located RdrName] -> RnM [Name] +newLocalBndrsRn = mapM newLocalBndrRn + +bindLocalNames :: [Name] -> RnM a -> RnM a +bindLocalNames names enclosed_scope + = do { lcl_env <- getLclEnv + ; let th_level = thLevel (tcl_th_ctxt lcl_env) + th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) + [ (n, (NotTopLevel, th_level)) | n <- names ] + rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names + ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' }) + enclosed_scope } + +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV names enclosed_scope + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; return (result, delFVs names fvs) } + +------------------------------------- + +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside + +------------------------------------- +checkDupRdrNames :: [Located RdrName] -> RnM () +-- Check for duplicated names in a binding group +checkDupRdrNames rdr_names_w_loc + = mapM_ (dupNamesErr getLoc) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + +checkDupNames :: [Name] -> RnM () +-- Check for duplicated names in a binding group +checkDupNames names = check_dup_names (filterOut isSystemName names) + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + +check_dup_names :: [Name] -> RnM () +check_dup_names names + = mapM_ (dupNamesErr nameSrcSpan) dups + where + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + +--------------------- +checkShadowedRdrNames :: [Located RdrName] -> RnM () +checkShadowedRdrNames loc_rdr_names + = do { envs <- getRdrEnvs + ; checkShadowedOccs envs get_loc_occ filtered_rdrs } + where + filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) + +checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () +checkDupAndShadowedNames envs names + = do { check_dup_names filtered_names + ; checkShadowedOccs envs get_loc_occ filtered_names } + where + filtered_names = filterOut isSystemName names + -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + get_loc_occ name = (nameSrcSpan name, nameOccName name) + +------------------------------------- +checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) + -> (a -> (SrcSpan, OccName)) + -> [a] -> RnM () +checkShadowedOccs (global_env,local_env) get_loc_occ ns + = whenWOptM Opt_WarnNameShadowing $ + do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) + ; mapM_ check_shadow ns } + where + check_shadow n + | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" + -- See #3262 + | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] + | otherwise = do { gres' <- filterM is_shadowed_gre gres + ; complain (map pprNameProvenance gres') } + where + (loc,occ) = get_loc_occ n + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + -- Make an Unqualified RdrName and look that up, so that + -- we don't find any GREs that are in scope qualified-only + + complain [] = return () + complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) + loc + (shadowedNameWarn occ pp_locs) + + is_shadowed_gre :: GlobalRdrElt -> RnM Bool + -- Returns False for record selectors that are shadowed, when + -- punning or wild-cards are on (cf #2723) + is_shadowed_gre gre | isRecFldGRE gre + = do { dflags <- getDynFlags + ; return $ not (xopt LangExt.RecordPuns dflags + || xopt LangExt.RecordWildCards dflags) } + is_shadowed_gre _other = return True + +------------------------------------- +-- | Throw an error message if a user attempts to quantify an inferred type +-- variable in a place where specificity cannot be observed. For example, +-- @forall {a}. [a] -> [a]@ would be rejected to the inferred type variable +-- @{a}@, but @forall a. [a] -> [a]@ would be accepted. +-- See @Note [Unobservably inferred type variables]@. +checkInferredVars :: HsDocContext + -> Maybe SDoc + -- ^ The error msg if the signature is not allowed to contain + -- manually written inferred variables. + -> LHsSigType GhcPs + -> RnM () +checkInferredVars _ Nothing _ = return () +checkInferredVars ctxt (Just msg) ty = + let bndrs = forallty_bndrs (hsSigType ty) + in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of + Nothing -> return () + Just _ -> addErr $ withHsDocContext ctxt msg + where + forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs] + forallty_bndrs (L _ ty) = case ty of + HsParTy _ ty' -> forallty_bndrs ty' + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }} + -> map unLoc tvs + _ -> [] + +{- +Note [Unobservably inferred type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While GHC's parser allows the use of inferred type variables +(e.g., `forall {a}. <...>`) just about anywhere that type variable binders can +appear, there are some situations where the distinction between inferred and +specified type variables cannot be observed. For example, consider this +instance declaration: + + instance forall {a}. Eq (T a) where ... + +Making {a} inferred is pointless, as there is no way for user code to +"apply" an instance declaration in a way where the inferred/specified +distinction would make a difference. (Notably, there is no opportunity +for visible type application of an instance declaration.) Anyone who +writes such code is likely confused, so in an attempt to be helpful, +we emit an error message if a user writes code like this. The +checkInferredVars function is responsible for implementing this +restriction. + +It turns out to be somewhat cumbersome to enforce this restriction in +certain cases. Specifically: + +* Quantified constraints. In the type `f :: (forall {a}. C a) => Proxy Int`, + there is no way to observe that {a} is inferred. Nevertheless, actually + rejecting this code would be tricky, as we would need to reject + `forall {a}. <...>` as a constraint but *accept* other uses of + `forall {a}. <...>` as a type (e.g., `g :: (forall {a}. a -> a) -> b -> b`). + This is quite tedious to do in practice, so we don't bother. + +* Default method type signatures (#18432). These are tricky because inferred + type variables can appear nested, e.g., + + class C a where + m :: forall b. a -> b -> forall c. c -> c + default m :: forall b. a -> b -> forall {c}. c -> c + m _ _ = id + + Robustly checking for nested, inferred type variables ends up being a pain, + so we don't try to do this. + +For now, we simply allow inferred quantifiers to be specified here, +even though doing so is pointless. All we lose is a warning. + +Aside from the places where we already use checkInferredVars, most of +the other places where inferred vars don't make sense are in any case +already prohibited from having foralls /at all/. For example: + + instance forall a. forall {b}. Eq (Either a b) where ... + +Here the nested `forall {b}` is already prohibited. (See +Note [No nested foralls or contexts in instance types] in GHC.Hs.Type). +-} + +-- | Examines a non-outermost type for @forall@s or contexts, which are assumed +-- to be nested. For example, in the following declaration: +-- +-- @ +-- instance forall a. forall b. C (Either a b) +-- @ +-- +-- The outermost @forall a@ is fine, but the nested @forall b@ is not. We +-- invoke 'noNestedForallsContextsErr' on the type @forall b. C (Either a b)@ +-- to catch the nested @forall@ and create a suitable error message. +-- 'noNestedForallsContextsErr' returns @'Just' err_msg@ if such a @forall@ or +-- context is found, and returns @Nothing@ otherwise. +-- +-- This is currently used in the following places: +-- +-- * In GADT constructor types (in 'rnConDecl'). +-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@ +-- in "GHC.Hs.Type". +-- +-- * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl' in +-- "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind"). +-- See @Note [No nested foralls or contexts in instance types]@ in +-- "GHC.Hs.Type". +noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc) +noNestedForallsContextsErr what lty = + case ignoreParens lty of + L l (HsForAllTy { hst_tele = tele }) + | HsForAllVis{} <- tele + -- The only two places where this function is called correspond to + -- types of terms, so we give a slightly more descriptive error + -- message in the event that they contain visible dependent + -- quantification (currently only allowed in kinds). + -> Just (l, vcat [ text "Illegal visible, dependent quantification" <+> + text "in the type of a term" + , text "(GHC does not yet support this)" ]) + | HsForAllInvis{} <- tele + -> Just (l, nested_foralls_contexts_err) + L l (HsQualTy {}) + -> Just (l, nested_foralls_contexts_err) + _ -> Nothing + where + nested_foralls_contexts_err = + what <+> text "cannot contain nested" + <+> quotes forAllLit <> text "s or contexts" + +-- | A common way to invoke 'noNestedForallsContextsErr'. +addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () +addNoNestedForallsContextsErr ctxt what lty = + whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) -> + addErrAt l $ withHsDocContext ctxt err_msg + +{- +************************************************************************ +* * +\subsection{Free variable manipulation} +* * +************************************************************************ +-} + +-- A useful utility +addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) +addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside + ; return (res, fvs1 `plusFV` fvs2) } + +mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) +mapFvRn f xs = do stuff <- mapM f xs + case unzip stuff of + (ys, fvs_s) -> return (ys, plusFVs fvs_s) + +mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) +mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) +mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } + +{- +************************************************************************ +* * +\subsection{Envt utility functions} +* * +************************************************************************ +-} + +warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedTopBinds gres + = whenWOptM Opt_WarnUnusedTopBinds + $ do env <- getGblEnv + let isBoot = tcg_src env == HsBootFile + let noParent gre = case gre_par gre of + NoParent -> True + _ -> False + -- Don't warn about unused bindings with parents in + -- .hs-boot files, as you are sometimes required to give + -- unused bindings (trac #3449). + -- HOWEVER, in a signature file, you are never obligated to put a + -- definition in the main text. Thus, if you define something + -- and forget to export it, we really DO want to warn. + gres' = if isBoot then filter noParent gres + else gres + warnUnusedGREs gres' + + +-- | Checks to see if we need to warn for -Wunused-record-wildcards or +-- -Wredundant-record-wildcards +checkUnusedRecordWildcard :: SrcSpan + -> FreeVars + -> Maybe [Name] + -> RnM () +checkUnusedRecordWildcard _ _ Nothing = return () +checkUnusedRecordWildcard loc _ (Just []) = do + -- Add a new warning if the .. pattern binds no variables + setSrcSpan loc $ warnRedundantRecordWildcard +checkUnusedRecordWildcard loc fvs (Just dotdot_names) = + setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs + + +-- | Produce a warning when the `..` pattern binds no new +-- variables. +-- +-- @ +-- data P = P { x :: Int } +-- +-- foo (P{x, ..}) = x +-- @ +-- +-- The `..` here doesn't bind any variables as `x` is already bound. +warnRedundantRecordWildcard :: RnM () +warnRedundantRecordWildcard = + whenWOptM Opt_WarnRedundantRecordWildcards + (addWarn (Reason Opt_WarnRedundantRecordWildcards) + redundantWildcardWarning) + + +-- | Produce a warning when no variables bound by a `..` pattern are used. +-- +-- @ +-- data P = P { x :: Int } +-- +-- foo (P{..}) = () +-- @ +-- +-- The `..` pattern binds `x` but it is not used in the RHS so we issue +-- a warning. +warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM () +warnUnusedRecordWildcard ns used_names = do + let used = filter (`elemNameSet` used_names) ns + traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) + warnIfFlag Opt_WarnUnusedRecordWildcards (null used) + unusedRecordWildcardWarning + + + +warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns + :: [Name] -> FreeVars -> RnM () +warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds +warnUnusedMatches = check_unused Opt_WarnUnusedMatches +warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns + +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () +check_unused flag bound_names used_names + = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) + bound_names)) + +------------------------- +-- Helpers +warnUnusedGREs :: [GlobalRdrElt] -> RnM () +warnUnusedGREs gres = mapM_ warnUnusedGRE gres + +warnUnused :: WarningFlag -> [Name] -> RnM () +warnUnused flag names = do + fld_env <- mkFieldEnv <$> getGlobalRdrEnv + mapM_ (warnUnused1 flag fld_env) names + +warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () +warnUnused1 flag fld_env name + = when (reportable name occ) $ + addUnusedWarning flag + occ (nameSrcSpan name) + (text $ "Defined but not used" ++ opt_str) + where + occ = case lookupNameEnv fld_env name of + Just (fl, _) -> mkVarOccFS fl + Nothing -> nameOccName name + opt_str = case flag of + Opt_WarnUnusedTypePatterns -> " on the right hand side" + _ -> "" + +warnUnusedGRE :: GlobalRdrElt -> RnM () +warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) + | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv + warnUnused1 Opt_WarnUnusedTopBinds fld_env name + | otherwise = when (reportable name occ) (mapM_ warn is) + where + occ = greOccName gre + warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg + where + span = importSpecLoc spec + pp_mod = quotes (ppr (importSpecModule spec)) + msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") + +-- | Make a map from selector names to field labels and parent tycon +-- names, to be used when reporting unused record fields. +mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) +mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) + | gres <- occEnvElts rdr_env + , gre <- gres + , Just lbl <- [greLabel gre] + ] + +-- | Should we report the fact that this 'Name' is unused? The +-- 'OccName' may differ from 'nameOccName' due to +-- DuplicateRecordFields. +reportable :: Name -> OccName -> Bool +reportable name occ + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = not (startsWithUnderscore occ) + +addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () +addUnusedWarning flag occ span msg + = addWarnAt (Reason flag) span $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace occ) + <+> quotes (ppr occ)] + +unusedRecordWildcardWarning :: SDoc +unusedRecordWildcardWarning = + wildcardDoc $ text "No variables bound in the record wildcard match are used" + +redundantWildcardWarning :: SDoc +redundantWildcardWarning = + wildcardDoc $ text "Record wildcard does not bind any new variables" + +wildcardDoc :: SDoc -> SDoc +wildcardDoc herald = + herald + $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" + <+> quotes (text "..")) + +addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () +addNameClashErrRn rdr_name gres + | all isLocalGRE gres && not (all isRecFldGRE gres) + -- If there are two or more *local* defns, we'll have reported + = return () -- that already, and we don't want an error cascade + | otherwise + = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) + , text "It could refer to" + , nest 3 (vcat (msg1 : msgs)) ]) + where + (np1:nps) = gres + msg1 = text "either" <+> ppr_gre np1 + msgs = [text " or" <+> ppr_gre np | np <- nps] + ppr_gre gre = sep [ pp_gre_name gre <> comma + , pprNameProvenance gre] + + -- When printing the name, take care to qualify it in the same + -- way as the provenance reported by pprNameProvenance, namely + -- the head of 'gre_imp'. Otherwise we get confusing reports like + -- Ambiguous occurrence ‘null’ + -- It could refer to either ‘T15487a.null’, + -- imported from ‘Prelude’ at T15487.hs:1:8-13 + -- or ... + -- See #15487 + pp_gre_name gre@(GRE { gre_name = name, gre_par = parent + , gre_lcl = lcl, gre_imp = iss }) + | FldParent { par_lbl = Just lbl } <- parent + = text "the field" <+> quotes (ppr lbl) + | otherwise + = quotes (pp_qual <> dot <> ppr (nameOccName name)) + where + pp_qual | lcl + = ppr (nameModule name) + | imp : _ <- iss -- This 'imp' is the one that + -- pprNameProvenance chooses + , ImpDeclSpec { is_as = mod } <- is_decl imp + = ppr mod + | otherwise + = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) + -- Invariant: either 'lcl' is True or 'iss' is non-empty + +shadowedNameWarn :: OccName -> [SDoc] -> SDoc +shadowedNameWarn occ shadowed_locs + = sep [text "This binding for" <+> quotes (ppr occ) + <+> text "shadows the existing binding" <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] + + +unknownSubordinateErr :: SDoc -> RdrName -> SDoc +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> text "is not a (visible)" <+> doc + + +dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () +dupNamesErr get_loc names + = addErrAt big_loc $ + vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), + locations] + where + locs = map get_loc (NE.toList names) + big_loc = foldr1 combineSrcSpans locs + locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs)) + +badQualBndrErr :: RdrName -> SDoc +badQualBndrErr rdr_name + = text "Qualified name in binding position:" <+> ppr rdr_name + +typeAppErr :: String -> LHsType GhcPs -> SDoc +typeAppErr what (L _ k) + = hang (text "Illegal visible" <+> text what <+> text "application" + <+> quotes (char '@' <> ppr k)) + 2 (text "Perhaps you intended to use TypeApplications") + +checkTupSize :: Int -> RnM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = return () + | otherwise + = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), + nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), + nest 2 (text "Workaround: use nested tuples or define a data type")]) + + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +-- AZ:TODO: Change these all to be Name instead of RdrName. +-- Merge TcType.UserTypeContext in to it. +data HsDocContext + = TypeSigCtx SDoc + | StandaloneKindSigCtx SDoc + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (Located RdrName) + | DerivDeclCtx + | RuleCtx FastString + | TyDataCtx (Located RdrName) + | TySynCtx (Located RdrName) + | TyFamilyCtx (Located RdrName) + | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance + | ConDeclCtx [Located Name] + | ClassDeclCtx (Located RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | GHCiCtx + | SpliceTypeCtx (LHsType GhcPs) + | ClassInstanceCtx + | GenericCtx SDoc -- Maybe we want to use this more! + +withHsDocContext :: HsDocContext -> SDoc -> SDoc +withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc +pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc +pprHsDocContext PatCtx = text "a pattern type-signature" +pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" +pprHsDocContext DefaultDeclCtx = text "a `default' declaration" +pprHsDocContext DerivDeclCtx = text "a deriving declaration" +pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) +pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) +pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) +pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) +pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) +pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) +pprHsDocContext ExprWithTySigCtx = text "an expression type signature" +pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" +pprHsDocContext HsTypeCtx = text "a type argument" +pprHsDocContext GHCiCtx = text "GHCi input" +pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) +pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances" + +pprHsDocContext (ForeignDeclCtx name) + = text "the foreign declaration for" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx [name]) + = text "the definition of data constructor" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx names) + = text "the definition of data constructors" <+> interpp'SP names diff --git a/GHC/Runtime/Debugger.hs b/GHC/Runtime/Debugger.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Debugger.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- GHCi Interactive debugging commands +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +-- ToDo: lots of violation of layering here. This module should +-- decide whether it is above the GHC API (import GHC and nothing +-- else) or below it. +-- +----------------------------------------------------------------------------- + +module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where + +import GHC.Prelude + +import GHC.Runtime.Linker +import GHC.Runtime.Heap.Inspect + +import GHC.Runtime.Interpreter +import GHCi.RemoteTypes +import GHC.Driver.Monad +import GHC.Driver.Types +import GHC.Types.Id +import GHC.Iface.Syntax ( showToHeader ) +import GHC.Iface.Env ( newInteractiveBinder ) +import GHC.Types.Name +import GHC.Types.Var hiding ( varName ) +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Core.Type +import GHC +import GHC.Utils.Outputable +import GHC.Core.Ppr.TyThing +import GHC.Utils.Error +import GHC.Utils.Monad +import GHC.Driver.Session +import GHC.Utils.Exception + +import Control.Monad +import Control.Monad.Catch as MC +import Data.List ( (\\) ) +import Data.Maybe +import Data.IORef + +------------------------------------- +-- | The :print & friends commands +------------------------------------- +pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () +pprintClosureCommand bindThings force str = do + tythings <- (catMaybes . concat) `liftM` + mapM (\w -> GHC.parseName w >>= + mapM GHC.lookupName) + (words str) + let ids = [id | AnId id <- tythings] + + -- Obtain the terms and the recovered type information + (subst, terms) <- mapAccumLM go emptyTCvSubst ids + + -- Apply the substitutions obtained after recovering the types + modifySession $ \hsc_env -> + hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} + + -- Finally, print the Terms + unqual <- GHC.getPrintUnqual + docterms <- mapM showTerm terms + dflags <- getDynFlags + liftIO $ (printOutputForUser dflags unqual . vcat) + (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) + ids + docterms) + where + -- Do the obtainTerm--bindSuspensions-computeSubstitution dance + go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) + go subst id = do + let id' = updateIdTypeAndMult (substTy subst) id + id_ty' = idType id' + term_ <- GHC.obtainTermFromId maxBound force id' + term <- tidyTermTyVars term_ + term' <- if bindThings + then bindSuspensions term + else return term + -- Before leaving, we compare the type obtained to see if it's more specific + -- Then, we extract a substitution, + -- mapping the old tyvars to the reconstructed types. + let reconstructed_type = termType term + hsc_env <- getSession + case (improveRTTIType hsc_env id_ty' reconstructed_type) of + Nothing -> return (subst, term') + Just subst' -> do { dflags <- GHC.getSessionDynFlags + ; liftIO $ + dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + FormatText + (fsep $ [text "RTTI Improvement for", ppr id, + text "old substitution:" , ppr subst, + text "new substitution:" , ppr subst']) + ; return (subst `unionTCvSubst` subst', term')} + + tidyTermTyVars :: GhcMonad m => Term -> m Term + tidyTermTyVars t = + withSession $ \hsc_env -> do + let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env + my_tvs = termTyCoVars t + tvs = env_tvs `minusVarSet` my_tvs + tyvarOccName = nameOccName . tyVarName + tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs)) + -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv + -- forgets the ordering immediately by creating an env + , getUniqSet $ env_tvs `intersectVarSet` my_tvs) + return $ mapTermType (snd . tidyOpenType tidyEnv) t + +-- | Give names, and bind in the interactive environment, to all the suspensions +-- included (inductively) in a term +bindSuspensions :: GhcMonad m => Term -> m Term +bindSuspensions t = do + hsc_env <- getSession + inScope <- GHC.getBindings + let ictxt = hsc_IC hsc_env + prefix = "_t" + alreadyUsedNames = map (occNameString . nameOccName . getName) inScope + availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames + availNames_var <- liftIO $ newIORef availNames + (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t + let (names, tys, fhvs) = unzip3 stuff + let ids = [ mkVanillaGlobal name ty + | (name,ty) <- zip names tys] + new_ic = extendInteractiveContextWithIds ictxt ids + dl = hsc_dynLinker hsc_env + liftIO $ extendLinkEnv dl (zip names fhvs) + setSession hsc_env {hsc_IC = new_ic } + return t' + where + +-- Processing suspensions. Give names and recopilate info + nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] + -> TermFold (IO (Term, [(Name,Type,ForeignHValue)])) + nameSuspensionsAndGetInfos hsc_env freeNames = TermFold + { + fSuspension = doSuspension hsc_env freeNames + , fTerm = \ty dc v tt -> do + tt' <- sequence tt + let (terms,names) = unzip tt' + return (Term ty dc v terms, concat names) + , fPrim = \ty n ->return (Prim ty n,[]) + , fNewtypeWrap = + \ty dc t -> do + (term, names) <- t + return (NewtypeWrap ty dc term, names) + , fRefWrap = \ty t -> do + (term, names) <- t + return (RefWrap ty term, names) + } + doSuspension hsc_env freeNames ct ty hval _name = do + name <- atomicModifyIORef' freeNames (\x->(tail x, head x)) + n <- newGrimName hsc_env name + return (Suspension ct ty hval (Just n), [(n,ty,hval)]) + + +-- A custom Term printer to enable the use of Show instances +showTerm :: GhcMonad m => Term -> m SDoc +showTerm term = do + dflags <- GHC.getSessionDynFlags + if gopt Opt_PrintEvldWithShow dflags + then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term + else cPprTerm cPprTermBase term + where + cPprShowable prec t@Term{ty=ty, val=fhv} = + if not (isFullyEvaluatedTerm t) + then return Nothing + else do + hsc_env <- getSession + dflags <- GHC.getSessionDynFlags + do + (new_env, bname) <- bindToFreshName hsc_env ty "showme" + setSession new_env + -- XXX: this tries to disable logging of errors + -- does this still do what it is intended to do + -- with the changed error handling and logging? + let noop_log _ _ _ _ _ = return () + expr = "Prelude.return (Prelude.show " ++ + showPpr dflags bname ++ + ") :: Prelude.IO Prelude.String" + dl = hsc_dynLinker hsc_env + GHC.setSessionDynFlags dflags{log_action=noop_log} + txt_ <- withExtendedLinkEnv dl + [(bname, fhv)] + (GHC.compileExprRemote expr) + let myprec = 10 -- application precedence. TODO Infix constructors + txt <- liftIO $ evalString hsc_env txt_ + if not (null txt) then + return $ Just $ cparen (prec >= myprec && needsParens txt) + (text txt) + else return Nothing + `MC.finally` do + setSession hsc_env + GHC.setSessionDynFlags dflags + cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = + cPprShowable prec t{ty=new_ty} + cPprShowable _ _ = return Nothing + + needsParens ('"':_) = False -- some simple heuristics to see whether parens + -- are redundant in an arbitrary Show output + needsParens ('(':_) = False + needsParens txt = ' ' `elem` txt + + + bindToFreshName hsc_env ty userName = do + name <- newGrimName hsc_env userName + let id = mkVanillaGlobal name ty + new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] + return (hsc_env {hsc_IC = new_ic }, name) + +-- Create new uniques and give them sequentially numbered names +newGrimName :: MonadIO m => HscEnv -> String -> m Name +newGrimName hsc_env userName + = liftIO (newInteractiveBinder hsc_env occ noSrcSpan) + where + occ = mkOccName varName userName + +pprTypeAndContents :: GhcMonad m => Id -> m SDoc +pprTypeAndContents id = do + dflags <- GHC.getSessionDynFlags + let pcontents = gopt Opt_PrintBindContents dflags + pprdId = (pprTyThing showToHeader . AnId) id + if pcontents + then do + let depthBound = 100 + -- If the value is an exception, make sure we catch it and + -- show the exception, rather than propagating the exception out. + e_term <- MC.try $ GHC.obtainTermFromId depthBound False id + docs_term <- case e_term of + Right term -> showTerm term + Left exn -> return (text "*** Exception:" <+> + text (show (exn :: SomeException))) + return $ pprdId <+> equals <+> docs_term + else return pprdId diff --git a/GHC/Runtime/Eval.hs b/GHC/Runtime/Eval.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Eval.hs @@ -0,0 +1,1333 @@ +{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module GHC.Runtime.Eval ( + Resume(..), History(..), + execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec, + runDecls, runDeclsWithLocation, runParsedDecls, + isStmt, hasImport, isImport, isDecl, + parseImportDecl, SingleStep(..), + abandon, abandonAll, + getResumeContext, + getHistorySpan, + getModBreaks, + getHistoryModule, + back, forward, + setContext, getContext, + availsToGlobalRdrEnv, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + parseInstanceHead, + getInstancesForType, + getDocs, + GetDocsFailure(..), + showModule, + moduleIsBootOrNotObjectLinkable, + parseExpr, compileParsedExpr, + compileExpr, dynCompileExpr, + compileExprRemote, compileParsedExprRemote, + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Runtime.Eval.Types + +import GHC.Runtime.Interpreter as GHCi +import GHC.Runtime.Interpreter.Types +import GHCi.Message +import GHCi.RemoteTypes +import GHC.Driver.Monad +import GHC.Driver.Main +import GHC.Hs +import GHC.Driver.Types +import GHC.Core.InstEnv +import GHC.Iface.Env ( newInteractiveBinder ) +import GHC.Core.FamInstEnv ( FamInst ) +import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Core.TyCon +import GHC.Core.Type hiding( typeKind ) +import qualified GHC.Core.Type as Type +import GHC.Types.RepType +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Types.Var +import GHC.Types.Id as Id +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Name.Reader +import GHC.Types.Var.Env +import GHC.ByteCode.Types +import GHC.Runtime.Linker as Linker +import GHC.Driver.Session +import GHC.LanguageExtensions +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import GHC.Utils.Monad +import GHC.Unit.Module +import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) +import GHC.Builtin.Types ( isCTupleTyConName ) +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Utils.Error +import GHC.Types.SrcLoc +import GHC.Runtime.Heap.Inspect +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Utils.Misc +import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPStatePure) +import GHC.Parser.Lexer (ParserFlags) +import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport) + +import System.Directory +import Data.Dynamic +import Data.Either +import qualified Data.IntMap as IntMap +import Data.List (find,intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import GHC.Data.StringBuffer (stringToStringBuffer) +import Control.Monad +import Control.Monad.Catch as MC +import Data.Array +import GHC.Utils.Exception +import Unsafe.Coerce ( unsafeCoerce ) + +import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) +import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) ) +import GHC.Tc.Utils.Env (tcGetInstEnvs) +import GHC.Tc.Utils.Instantiate (instDFunType) +import GHC.Tc.Solver (simplifyWantedsTcM) +import GHC.Tc.Utils.Monad +import GHC.Core.Class (classTyCon) + +-- ----------------------------------------------------------------------------- +-- running a statement interactively + +getResumeContext :: GhcMonad m => m [Resume] +getResumeContext = withSession (return . ic_resume . hsc_IC) + +mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History +mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) + +getHistoryModule :: History -> Module +getHistoryModule = breakInfo_module . historyBreakInfo + +getHistorySpan :: HscEnv -> History -> SrcSpan +getHistorySpan hsc_env History{..} = + let BreakInfo{..} = historyBreakInfo in + case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of + Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number + _ -> panic "getHistorySpan" + +{- | Finds the enclosing top level function name -} +-- ToDo: a better way to do this would be to keep hold of the decl_path computed +-- by the coverage pass, which gives the list of lexically-enclosing bindings +-- for each tick. +findEnclosingDecls :: HscEnv -> BreakInfo -> [String] +findEnclosingDecls hsc_env (BreakInfo modl ix) = + let hmi = expectJust "findEnclosingDecls" $ + lookupHpt (hsc_HPT hsc_env) (moduleName modl) + mb = getModBreaks hmi + in modBreaks_decls mb ! ix + +-- | Update fixity environment in the current interactive context. +updateFixityEnv :: GhcMonad m => FixityEnv -> m () +updateFixityEnv fix_env = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } + +-- ----------------------------------------------------------------------------- +-- execStmt + +-- | default ExecOptions +execOptions :: ExecOptions +execOptions = ExecOptions + { execSingleStep = RunToCompletion + , execSourceFile = "" + , execLineNumber = 1 + , execWrap = EvalThis -- just run the statement, don't wrap it in anything + } + +-- | Run a statement in the current interactive context. +execStmt + :: GhcMonad m + => String -- ^ a statement (bind or expression) + -> ExecOptions + -> m ExecResult +execStmt input exec_opts@ExecOptions{..} = do + hsc_env <- getSession + + mb_stmt <- + liftIO $ + runInteractiveHsc hsc_env $ + hscParseStmtWithLocation execSourceFile execLineNumber input + + case mb_stmt of + -- empty statement / comment + Nothing -> return (ExecComplete (Right []) 0) + Just stmt -> execStmt' stmt input exec_opts + +-- | Like `execStmt`, but takes a parsed statement as argument. Useful when +-- doing preprocessing on the AST before execution, e.g. in GHCi (see +-- GHCi.UI.runStmt). +execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult +execStmt' stmt stmt_text ExecOptions{..} = do + hsc_env <- getSession + + -- Turn off -fwarn-unused-local-binds when running a statement, to hide + -- warnings about the implicit bindings we introduce. + -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset + -- -wwarn-unused-local-binds) + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds + hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }) + + r <- liftIO $ hscParsedStmt hsc_env' stmt + + case r of + Nothing -> + -- empty statement / comment + return (ExecComplete (Right []) 0) + Just (ids, hval, fix_env) -> do + updateFixityEnv fix_env + + status <- + withVirtualCWD $ + liftIO $ + evalStmt hsc_env' (isStep execSingleStep) (execWrap hval) + + let ic = hsc_IC hsc_env + bindings = (ic_tythings ic, ic_rn_gbl_env ic) + + size = ghciHistSize idflags' + + handleRunStatus execSingleStep stmt_text bindings ids + status (emptyHistory size) + +runDecls :: GhcMonad m => String -> m [Name] +runDecls = runDeclsWithLocation "" 1 + +-- | Run some declarations and return any user-visible names that were brought +-- into scope. +runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation source line_num input = do + hsc_env <- getSession + decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input) + runParsedDecls decls + +-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument. +-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi +-- (see GHCi.UI.runStmt). +runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name] +runParsedDecls decls = do + hsc_env <- getSession + (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls) + + setSession $ hsc_env { hsc_IC = ic } + hsc_env <- getSession + hsc_env' <- liftIO $ rttiEnvironment hsc_env + setSession hsc_env' + return $ filter (not . isDerivedOccName . nameOccName) + -- For this filter, see Note [What to show to users] + $ map getName tyThings + +{- Note [What to show to users] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to display internally-generated bindings to users. +Things like the coercion axiom for newtypes. These bindings all get +OccNames that users can't write, to avoid the possibility of name +clashes (in linker symbols). That gives a convenient way to suppress +them. The relevant predicate is OccName.isDerivedOccName. +See #11051 for more background and examples. +-} + +withVirtualCWD :: GhcMonad m => m a -> m a +withVirtualCWD m = do + hsc_env <- getSession + + -- a virtual CWD is only necessary when we're running interpreted code in + -- the same process as the compiler. + case hsc_interp hsc_env of + Just (ExternalInterp {}) -> m + _ -> do + let ic = hsc_IC hsc_env + let set_cwd = do + dir <- liftIO $ getCurrentDirectory + case ic_cwd ic of + Just dir -> liftIO $ setCurrentDirectory dir + Nothing -> return () + return dir + + reset_cwd orig_dir = do + virt_dir <- liftIO $ getCurrentDirectory + hsc_env <- getSession + let old_IC = hsc_IC hsc_env + setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } + liftIO $ setCurrentDirectory orig_dir + + MC.bracket set_cwd reset_cwd $ \_ -> m + +parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) +parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr + +emptyHistory :: Int -> BoundedList History +emptyHistory size = nilBL size + +handleRunStatus :: GhcMonad m + => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] + -> EvalStatus_ [ForeignHValue] [HValueRef] + -> BoundedList History + -> m ExecResult + +handleRunStatus step expr bindings final_ids status history + | RunAndLogSteps <- step = tracing + | otherwise = not_tracing + where + tracing + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status + , not is_exception + = do + hsc_env <- getSession + let hmi = expectJust "handleRunStatus" $ + lookupHptDirectly (hsc_HPT hsc_env) + (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + breaks = getModBreaks hmi + + b <- liftIO $ + breakpointStatus hsc_env (modBreaks_flags breaks) ix + if b + then not_tracing + -- This breakpoint is explicitly enabled; we want to stop + -- instead of just logging it. + else do + apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref + let bi = BreakInfo modl ix + !history' = mkHistory hsc_env apStack_fhv bi `consBL` history + -- history is strict, otherwise our BoundedList is pointless. + fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt + status <- liftIO $ GHCi.resumeStmt hsc_env True fhv + handleRunStatus RunAndLogSteps expr bindings final_ids + status history' + | otherwise + = not_tracing + + not_tracing + -- Hit a breakpoint + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status + = do + hsc_env <- getSession + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt + apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref + let hmi = expectJust "handleRunStatus" $ + lookupHptDirectly (hsc_HPT hsc_env) + (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + bp | is_exception = Nothing + | otherwise = Just (BreakInfo modl ix) + (hsc_env1, names, span, decl) <- liftIO $ + bindLocalsAtBreakpoint hsc_env apStack_fhv bp + let + resume = Resume + { resumeStmt = expr, resumeContext = resume_ctxt_fhv + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack_fhv + , resumeBreakInfo = bp + , resumeSpan = span, resumeHistory = toListBL history + , resumeDecl = decl + , resumeCCS = ccs + , resumeHistoryIx = 0 } + hsc_env2 = pushResume hsc_env1 resume + + setSession hsc_env2 + return (ExecBreak names bp) + + -- Completed successfully + | EvalComplete allocs (EvalSuccess hvals) <- status + = do hsc_env <- getSession + let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids + final_names = map getName final_ids + dl = hsc_dynLinker hsc_env + liftIO $ Linker.extendLinkEnv dl (zip final_names hvals) + hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + setSession hsc_env' + return (ExecComplete (Right final_names) allocs) + + -- Completed with an exception + | EvalComplete alloc (EvalException e) <- status + = return (ExecComplete (Left (fromSerializableException e)) alloc) + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise + = panic "not_tracing" -- actually exhaustive, but GHC can't tell +#endif + + +resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult +resumeExec canLogSpan step + = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + + case resume of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + -- unbind the temporary locals by restoring the TypeEnv from + -- before the breakpoint, and drop this Resume from the + -- InteractiveContext. + let (resume_tmp_te,resume_rdr_env) = resumeBindings r + ic' = ic { ic_tythings = resume_tmp_te, + ic_rn_gbl_env = resume_rdr_env, + ic_resume = rs } + setSession hsc_env{ hsc_IC = ic' } + + -- remove any bindings created since the breakpoint from the + -- linker's environment + let old_names = map getName resume_tmp_te + new_names = [ n | thing <- ic_tythings ic + , let n = getName thing + , not (n `elem` old_names) ] + dl = hsc_dynLinker hsc_env + liftIO $ Linker.deleteFromLinkEnv dl new_names + + case r of + Resume { resumeStmt = expr, resumeContext = fhv + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack, resumeBreakInfo = mb_brkpt + , resumeSpan = span + , resumeHistory = hist } -> do + withVirtualCWD $ do + status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv + let prevHistoryLst = fromListBL 50 hist + hist' = case mb_brkpt of + Nothing -> prevHistoryLst + Just bi + | not $canLogSpan span -> prevHistoryLst + | otherwise -> mkHistory hsc_env apStack bi `consBL` + fromListBL 50 hist + handleRunStatus step expr bindings final_ids status hist' + +back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) +back n = moveHist (+n) + +forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) +forward n = moveHist (subtract n) + +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) +moveHist fn = do + hsc_env <- getSession + case ic_resume (hsc_IC hsc_env) of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + let ix = resumeHistoryIx r + history = resumeHistory r + new_ix = fn ix + -- + when (history `lengthLessThan` new_ix) $ liftIO $ + throwGhcExceptionIO (ProgramError "no more logged breakpoints") + when (new_ix < 0) $ liftIO $ + throwGhcExceptionIO (ProgramError "already at the beginning of the history") + + let + update_ic apStack mb_info = do + (hsc_env1, names, span, decl) <- + liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info + let ic = hsc_IC hsc_env1 + r' = r { resumeHistoryIx = new_ix } + ic' = ic { ic_resume = r':rs } + + setSession hsc_env1{ hsc_IC = ic' } + + return (names, new_ix, span, decl) + + -- careful: we want apStack to be the AP_STACK itself, not a thunk + -- around it, hence the cases are carefully constructed below to + -- make this the case. ToDo: this is v. fragile, do something better. + if new_ix == 0 + then case r of + Resume { resumeApStack = apStack, + resumeBreakInfo = mb_brkpt } -> + update_ic apStack mb_brkpt + else case history !! (new_ix - 1) of + History{..} -> + update_ic historyApStack (Just historyBreakInfo) + + +-- ----------------------------------------------------------------------------- +-- After stopping at a breakpoint, add free variables to the environment + +result_fs :: FastString +result_fs = fsLit "_result" + +bindLocalsAtBreakpoint + :: HscEnv + -> ForeignHValue + -> Maybe BreakInfo + -> IO (HscEnv, [Name], SrcSpan, String) + +-- Nothing case: we stopped when an exception was raised, not at a +-- breakpoint. We have no location information or local variables to +-- bind, all we can do is bind a local variable to the exception +-- value. +bindLocalsAtBreakpoint hsc_env apStack Nothing = do + let exn_occ = mkVarOccFS (fsLit "_exception") + span = mkGeneralSrcSpan (fsLit "") + exn_name <- newInteractiveBinder hsc_env exn_occ span + + let e_fs = fsLit "e" + e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span + e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) + + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] + dl = hsc_dynLinker hsc_env + -- + Linker.extendLinkEnv dl [(exn_name, apStack)] + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "") + +-- Just case: we stopped at a breakpoint, we have information about the location +-- of the breakpoint and the free variables of the expression. +bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do + let + hmi = expectJust "bindLocalsAtBreakpoint" $ + lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) + breaks = getModBreaks hmi + info = expectJust "bindLocalsAtBreakpoint2" $ + IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) + mbVars = cgb_vars info + result_ty = cgb_resty info + occs = modBreaks_vars breaks ! breakInfo_number + span = modBreaks_locs breaks ! breakInfo_number + decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number + + -- Filter out any unboxed ids by changing them to Nothings; + -- we can't bind these at the prompt + mbPointers = nullUnboxed <$> mbVars + + (ids, offsets, occs') = syncOccs mbPointers occs + + free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids) + + -- It might be that getIdValFromApStack fails, because the AP_STACK + -- has been accidentally evaluated, or something else has gone wrong. + -- So that we don't fall over in a heap when this happens, just don't + -- bind any free variables instead, and we emit a warning. + mb_hValues <- + mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets + when (any isNothing mb_hValues) $ + debugTraceMsg (hsc_dflags hsc_env) 1 $ + text "Warning: _result has been evaluated, some bindings have been lost" + + us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time + let tv_subst = newTyVars us free_tvs + (filtered_ids, occs'') = unzip -- again, sync the occ-names + [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ] + (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $ + map (substTy tv_subst . idType) filtered_ids + + new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids + result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span + + let result_id = Id.mkVanillaGlobal result_name + (substTy tv_subst result_ty) + result_ok = isPointer result_id + + final_ids | result_ok = result_id : new_ids + | otherwise = new_ids + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids + names = map idName new_ids + dl = hsc_dynLinker hsc_env + + let fhvs = catMaybes mb_hValues + Linker.extendLinkEnv dl (zip names fhvs) + when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)] + hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } + return (hsc_env1, if result_ok then result_name:names else names, span, decl) + where + -- We need a fresh Unique for each Id we bind, because the linker + -- state is single-threaded and otherwise we'd spam old bindings + -- whenever we stop at a breakpoint. The InteractveContext is properly + -- saved/restored, but not the linker state. See #1743, test break026. + mkNewId :: OccName -> Type -> Id -> IO Id + mkNewId occ ty old_id + = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) + ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } + + newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst + -- Similarly, clone the type variables mentioned in the types + -- we have here, *and* make them all RuntimeUnk tyvars + newTyVars us tvs + = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) + | (tv, uniq) <- tvs `zip` uniqsFromSupply us + , let name = setNameUnique (tyVarName tv) uniq ] + + isPointer id | [rep] <- typePrimRep (idType id) + , isGcPtrRep rep = True + | otherwise = False + + -- Convert unboxed Id's to Nothings + nullUnboxed (Just (fv@(id, _))) + | isPointer id = Just fv + | otherwise = Nothing + nullUnboxed Nothing = Nothing + + -- See Note [Syncing breakpoint info] + syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c]) + syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs + where + joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)] + joinOccs = zipWithEqual "bindLocalsAtBreakpoint" joinOcc + joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc + +rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + incompletelyTypedIds = + [id | id <- tmp_ids + , not $ noSkolems id + , (occNameFS.nameOccName.idName) id /= result_fs] + hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) + return hsc_env' + where + noSkolems = noFreeVarsOfType . idType + improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + Just id = find (\i -> idName i == name) tmp_ids + if noSkolems id + then return hsc_env + else do + mb_new_ty <- reconstructType hsc_env 10 id + let old_ty = idType id + case mb_new_ty of + Nothing -> return hsc_env + Just new_ty -> do + case improveRTTIType hsc_env old_ty new_ty of + Nothing -> return $ + WARN(True, text (":print failed to calculate the " + ++ "improvement for a type")) hsc_env + Just subst -> do + let dflags = hsc_dflags hsc_env + dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + FormatText + (fsep [text "RTTI Improvement for", ppr id, equals, + ppr subst]) + + let ic' = substInteractiveContext ic subst + return hsc_env{hsc_IC=ic'} + +pushResume :: HscEnv -> Resume -> HscEnv +pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } + where + ictxt0 = hsc_IC hsc_env + ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } + + + {- + Note [Syncing breakpoint info] + + To display the values of the free variables for a single breakpoint, the + function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls + out the information from the fields `modBreaks_breakInfo` and + `modBreaks_vars` of the `ModBreaks` data structure. + For a specific breakpoint this gives 2 lists of type `Id` (or `Var`) + and `OccName`. + They are used to create the Id's for the free variables and must be kept + in sync! + + There are 3 situations where items are removed from the Id list + (or replaced with `Nothing`): + 1.) If function `GHC.CoreToByteCode.schemeER_wrk` (which creates + the Id list) doesn't find an Id in the ByteCode environement. + 2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` + filters out unboxed elements from the Id list, because GHCi cannot + yet handle them. + 3.) If the GHCi interpreter doesn't find the reference to a free variable + of our breakpoint. This also happens in the function + bindLocalsAtBreakpoint. + + If an element is removed from the Id list, then the corresponding element + must also be removed from the Occ list. Otherwise GHCi will confuse + variable names as in #8487. + -} + +-- ----------------------------------------------------------------------------- +-- Abandoning a resume context + +abandon :: GhcMonad m => m Bool +abandon = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + r:rs -> do + setSession hsc_env{ hsc_IC = ic { ic_resume = rs } } + liftIO $ abandonStmt hsc_env (resumeContext r) + return True + +abandonAll :: GhcMonad m => m Bool +abandonAll = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + rs -> do + setSession hsc_env{ hsc_IC = ic { ic_resume = [] } } + liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs + return True + +-- ----------------------------------------------------------------------------- +-- Bounded list, optimised for repeated cons + +data BoundedList a = BL + {-# UNPACK #-} !Int -- length + {-# UNPACK #-} !Int -- bound + [a] -- left + [a] -- right, list is (left ++ reverse right) + +nilBL :: Int -> BoundedList a +nilBL bound = BL 0 bound [] [] + +consBL :: a -> BoundedList a -> BoundedList a +consBL a (BL len bound left right) + | len < bound = BL (len+1) bound (a:left) right + | null right = BL len bound [a] $! tail (reverse left) + | otherwise = BL len bound (a:left) $! tail right + +toListBL :: BoundedList a -> [a] +toListBL (BL _ _ left right) = left ++ reverse right + +fromListBL :: Int -> [a] -> BoundedList a +fromListBL bound l = BL (length l) bound l [] + +-- lenBL (BL len _ _ _) = len + +-- ----------------------------------------------------------------------------- +-- | Set the interactive evaluation context. +-- +-- (setContext imports) sets the ic_imports field (which in turn +-- determines what is in scope at the prompt) to 'imports', and +-- constructs the ic_rn_glb_env environment to reflect it. +-- +-- We retain in scope all the things defined at the prompt, and kept +-- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) + +setContext :: GhcMonad m => [InteractiveImport] -> m () +setContext imports + = do { hsc_env <- getSession + ; let dflags = hsc_dflags hsc_env + ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports + ; case all_env_err of + Left (mod, err) -> + liftIO $ throwGhcExceptionIO (formatError dflags mod err) + Right all_env -> do { + ; let old_ic = hsc_IC hsc_env + !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic + ; setSession + hsc_env{ hsc_IC = old_ic { ic_imports = imports + , ic_rn_gbl_env = final_rdr_env }}}} + where + formatError dflags mod err = ProgramError . showSDoc dflags $ + text "Cannot add module" <+> ppr mod <+> + text "to context:" <+> text err + +findGlobalRdrEnv :: HscEnv -> [InteractiveImport] + -> IO (Either (ModuleName, String) GlobalRdrEnv) +-- Compute the GlobalRdrEnv for the interactive context +findGlobalRdrEnv hsc_env imports + = do { idecls_env <- hscRnImportDecls hsc_env idecls + -- This call also loads any orphan modules + ; return $ case partitionEithers (map mkEnv imods) of + ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) + (err : _, _) -> Left err } + where + idecls :: [LImportDecl GhcPs] + idecls = [noLoc d | IIDecl d <- imports] + + imods :: [ModuleName] + imods = [m | IIModule m <- imports] + + mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of + Left err -> Left (mod, err) + Right env -> Right env + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) + where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } + +mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv +mkTopLevEnv hpt modl + = case lookupHpt hpt modl of + Nothing -> Left "not a home module" + Just details -> + case mi_globals (hm_iface details) of + Nothing -> Left "not interpreted" + Just env -> Right env + +-- | Get the interactive evaluation context, consisting of a pair of the +-- set of modules from which we take the full top-level scope, and the set +-- of modules from which we take just the exports respectively. +getContext :: GhcMonad m => m [InteractiveImport] +getContext = withSession $ \HscEnv{ hsc_IC=ic } -> + return (ic_imports ic) + +-- | Returns @True@ if the specified module is interpreted, and hence has +-- its full top-level scope available. +moduleIsInterpreted :: GhcMonad m => Module -> m Bool +moduleIsInterpreted modl = withSession $ \h -> + if not (isHomeModule (hsc_dflags h) modl) + then return False + else case lookupHpt (hsc_HPT h) (moduleName modl) of + Just details -> return (isJust (mi_globals (hm_iface details))) + _not_a_home_module -> return False + +-- | Looks up an identifier in the current interactive context (for :info) +-- Filter the instances by the ones whose tycons (or clases resp) +-- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! +-- The exact choice of which ones to show, and which to hide, is a judgement call. +-- (see #1581) +getInfo :: GhcMonad m => Bool -> Name + -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc)) +getInfo allInfo name + = withSession $ \hsc_env -> + do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name + case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, cls_insts, fam_insts, docs) -> do + let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + + -- Filter the instances based on whether the constituent names of their + -- instance heads are all in scope. + let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts + fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts + return (Just (thing, fixity, cls_insts', fam_insts', docs)) + where + plausible rdr_env names + -- Dfun involving only names that are in ic_rn_glb_env + = allInfo + || nameSetAll ok names + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True + -- The one we looked for in the first place! + | pretendNameIsInScope n = True + | isBuiltInSyntax n = True + | isCTupleTyConName n = True + | isExternalName n = isJust (lookupGRE_Name rdr_env n) + | otherwise = True + +-- | Returns all names in scope in the current interactive context +getNamesInScope :: GhcMonad m => m [Name] +getNamesInScope = withSession $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + +-- | Returns all 'RdrName's in scope in the current interactive +-- context, excluding any that are internally-generated. +getRdrNamesInScope :: GhcMonad m => m [RdrName] +getRdrNamesInScope = withSession $ \hsc_env -> do + let + ic = hsc_IC hsc_env + gbl_rdrenv = ic_rn_gbl_env ic + gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv + -- Exclude internally generated names; see e.g. #11328 + return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names) + + +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: GhcMonad m => String -> m [Name] +parseName str = withSession $ \hsc_env -> liftIO $ + do { lrdr_name <- hscParseIdentifier hsc_env str + ; hscTcRnLookupRdrName hsc_env lrdr_name } + +-- | Returns @True@ if passed string is a statement. +isStmt :: ParserFlags -> String -> Bool +isStmt pflags stmt = + case parseThing Parser.parseStmt pflags stmt of + Lexer.POk _ _ -> True + Lexer.PFailed _ -> False + +-- | Returns @True@ if passed string has an import declaration. +hasImport :: ParserFlags -> String -> Bool +hasImport pflags stmt = + case parseThing Parser.parseModule pflags stmt of + Lexer.POk _ thing -> hasImports thing + Lexer.PFailed _ -> False + where + hasImports = not . null . hsmodImports . unLoc + +-- | Returns @True@ if passed string is an import declaration. +isImport :: ParserFlags -> String -> Bool +isImport pflags stmt = + case parseThing Parser.parseImport pflags stmt of + Lexer.POk _ _ -> True + Lexer.PFailed _ -> False + +-- | Returns @True@ if passed string is a declaration but __/not a splice/__. +isDecl :: ParserFlags -> String -> Bool +isDecl pflags stmt = do + case parseThing Parser.parseDeclaration pflags stmt of + Lexer.POk _ thing -> + case unLoc thing of + SpliceD _ _ -> False + _ -> True + Lexer.PFailed _ -> False + +parseThing :: Lexer.P thing -> ParserFlags -> String -> Lexer.ParseResult thing +parseThing parser pflags stmt = do + let buf = stringToStringBuffer stmt + loc = mkRealSrcLoc (fsLit "") 1 1 + + Lexer.unP parser (Lexer.mkPStatePure pflags buf loc) + +getDocs :: GhcMonad m + => Name + -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)) + -- TODO: What about docs for constructors etc.? +getDocs name = + withSession $ \hsc_env -> do + case nameModule_maybe name of + Nothing -> pure (Left (NameHasNoModule name)) + Just mod -> do + if isInteractiveModule mod + then pure (Left InteractiveName) + else do + ModIface { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } <- liftIO $ hscGetModuleInterface hsc_env mod + if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + then pure (Left (NoDocsInIface mod compiled)) + else pure (Right ( Map.lookup name dmap + , Map.findWithDefault Map.empty name amap)) + where + compiled = + -- TODO: Find a more direct indicator. + case nameSrcLoc name of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + +-- | Failure modes for 'getDocs'. + +-- TODO: Find a way to differentiate between modules loaded without '-haddock' +-- and modules that contain no docs. +data GetDocsFailure + + -- | 'nameModule_maybe' returned 'Nothing'. + = NameHasNoModule Name + + -- | This is probably because the module was loaded without @-haddock@, + -- but it's also possible that the entire module contains no documentation. + | NoDocsInIface + Module + Bool -- ^ 'True': The module was compiled. + -- 'False': The module was :loaded. + + -- | The 'Name' was defined interactively. + | InteractiveName + +instance Outputable GetDocsFailure where + ppr (NameHasNoModule name) = + quotes (ppr name) <+> text "has no module where we could look for docs." + ppr (NoDocsInIface mod compiled) = vcat + [ text "Can't find any documentation for" <+> ppr mod <> char '.' + , text "This is probably because the module was" + <+> text (if compiled then "compiled" else "loaded") + <+> text "without '-haddock'," + , text "but it's also possible that the module contains no documentation." + , text "" + , if compiled + then text "Try re-compiling with '-haddock'." + else text "Try running ':set -haddock' and :load the file again." + -- TODO: Figure out why :reload doesn't load the docs and maybe fix it. + ] + ppr InteractiveName = + text "Docs are unavailable for interactive declarations." + +-- ----------------------------------------------------------------------------- +-- Getting the type of an expression + +-- | Get the type of an expression +-- Returns the type as described by 'TcRnExprMode' +exprType :: GhcMonad m => TcRnExprMode -> String -> m Type +exprType mode expr = withSession $ \hsc_env -> do + ty <- liftIO $ hscTcExpr hsc_env mode expr + return $ tidyType emptyTidyEnv ty + +-- ----------------------------------------------------------------------------- +-- Getting the kind of a type + +-- | Get the kind of a type +typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) +typeKind normalise str = withSession $ \hsc_env -> do + liftIO $ hscKcType hsc_env normalise str + +-- ---------------------------------------------------------------------------- +-- Getting the class instances for a type + +{- + Note [Querying instances for a type] + + Here is the implementation of GHC proposal 41. + (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst) + + The objective is to take a query string representing a (partial) type, and + report all the class single-parameter class instances available to that type. + Extending this feature to multi-parameter typeclasses is left as future work. + + The general outline of how we solve this is: + + 1. Parse the type, leaving skolems in the place of type-holes. + 2. For every class, get a list of all instances that match with the query type. + 3. For every matching instance, ask GHC for the context the instance dictionary needs. + 4. Format and present the results, substituting our query into the instance + and simplifying the context. + + For example, given the query "Maybe Int", we want to return: + + instance Show (Maybe Int) + instance Read (Maybe Int) + instance Eq (Maybe Int) + .... + + [Holes in queries] + + Often times we want to know what instances are available for a polymorphic type, + like `Maybe a`, and we'd like to return instances such as: + + instance Show a => Show (Maybe a) + .... + + These queries are expressed using type holes, so instead of `Maybe a` the user writes + `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes + with (un-named) type variables. + + When zonking the type holes we have two real choices: replace them with Any or replace + them with skolem typevars. Using skolem type variables ensures that the output is more + intuitive to end users, and there is no difference in the results between Any and skolems. + +-} + +-- Find all instances that match a provided type +getInstancesForType :: GhcMonad m => Type -> m [ClsInst] +getInstancesForType ty = withSession $ \hsc_env -> do + liftIO $ runInteractiveHsc hsc_env $ do + ioMsgMaybe $ runTcInteractive hsc_env $ do + -- Bring class and instances from unqualified modules into scope, this fixes #16793. + loadUnqualIfaces hsc_env (hsc_IC hsc_env) + matches <- findMatchingInstances ty + + fmap catMaybes . forM matches $ uncurry checkForExistence + +-- Parse a type string and turn any holes into skolems +parseInstanceHead :: GhcMonad m => String -> m Type +parseInstanceHead str = withSession $ \hsc_env0 -> do + (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty + + return ty + +-- Get all the constraints required of a dictionary binding +getDictionaryBindings :: PredType -> TcM CtEvidence +getDictionaryBindings theta = do + dictName <- newName (mkDictOcc (mkVarOcc "magic")) + let dict_var = mkVanillaGlobal dictName theta + loc <- getCtLocM (GivenOrigin UnkSkol) Nothing + + -- Generate a wanted here because at the end of constraint + -- solving, most derived constraints get thrown away, which in certain + -- cases, notably with quantified constraints makes it impossible to rule + -- out instances as invalid. (See #18071) + return CtWanted { + ctev_pred = varType dict_var, + ctev_dest = EvVarDest dict_var, + ctev_nosh = WDeriv, + ctev_loc = loc + } + +-- Find instances where the head unifies with the provided type +findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] +findMatchingInstances ty = do + ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs + let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local + return $ concatMap (try_cls ies) allClasses + where + {- Check that a class instance is well-kinded. + Since `:instances` only works for unary classes, we're looking for instances of kind + k -> Constraint where k is the type of the queried type. + -} + try_cls ies cls + | Just (_, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) + , tcIsConstraintKind res_kind + , Type.typeKind ty `eqType` arg_kind + , (matches, _, _) <- lookupInstEnv True ies cls [ty] + = matches + | otherwise + = [] + + +{- + When we've found an instance that a query matches against, we still need to + check that all the instance's constraints are satisfiable. checkForExistence + creates an instance dictionary and verifies that any unsolved constraints + mention a type-hole, meaning it is blocked on an unknown. + + If the instance satisfies this condition, then we return it with the query + substituted into the instance and all constraints simplified, for example given: + + instance D a => C (MyType a b) where + + and the query `MyType _ String` + + the unsolved constraints will be [D _] so we apply the substitution: + + { a -> _; b -> String} + + and return the instance: + + instance D _ => C (MyType _ String) + +-} + +checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst) +checkForExistence clsInst mb_inst_tys = do + -- We want to force the solver to attempt to solve the constraints for clsInst. + -- Usually, this isn't a problem since there should only be a single instance + -- for a type. However, when we have overlapping instances, the solver will give up + -- since it can't decide which instance to use. To get around this restriction, instead + -- of asking the solver to solve a constraint for clsInst, we ask it to solve the + -- thetas of clsInst. + (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys + wanteds <- mapM getDictionaryBindings thetas + -- It's important to zonk constraints after solving in order to expose things like TypeErrors + -- which otherwise appear as opaque type variables. (See #18262). + WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds + + if allBag allowedSimple simples && solvedImplics impls + then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst + else return Nothing + + where + allowedSimple :: Ct -> Bool + allowedSimple ct = isSatisfiablePred (ctPred ct) + + solvedImplics :: Bag Implication -> Bool + solvedImplics impls = allBag (isSolvedStatus . ic_status) impls + + -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least + -- one argument or for the head to be a TyVar. The reason is that we want to ensure + -- that all residual constraints mention a type-hole somewhere in the constraint, + -- meaning that with the correct choice of a concrete type it could be possible for + -- the constraint to be discharged. + isSatisfiablePred :: PredType -> Bool + isSatisfiablePred ty = case getClassPredTys_maybe ty of + Just (_, tys@(_:_)) -> all isTyVarTy tys + _ -> isTyVarTy ty + + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst))) + + {- Create a ClsInst with instantiated arguments and constraints. + + The thetas are the list of constraints that couldn't be solved because + they mention a type-hole. + -} + substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst + substInstArgs tys thetas inst = let + subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys) + -- Build instance head with arguments substituted in + tau = mkClassPred cls (substTheta subst args) + -- Constrain the instance with any residual constraints + phi = mkPhiTy thetas tau + sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi + + in inst { is_dfun = (is_dfun inst) { varType = sigma }} + where + (dfun_tvs, _, cls, args) = instanceSig inst + +----------------------------------------------------------------------------- +-- Compile an expression, run it, and deliver the result + +-- | Parse an expression, the parsed expression can be further processed and +-- passed to compileParsedExpr. +parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) +parseExpr expr = withSession $ \hsc_env -> do + liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr + +-- | Compile an expression, run it, and deliver the resulting HValue. +compileExpr :: GhcMonad m => String -> m HValue +compileExpr expr = do + parsed_expr <- parseExpr expr + compileParsedExpr parsed_expr + +-- | Compile an expression, run it, and deliver the resulting HValue. +compileExprRemote :: GhcMonad m => String -> m ForeignHValue +compileExprRemote expr = do + parsed_expr <- parseExpr expr + compileParsedExprRemote parsed_expr + +-- | Compile a parsed expression (before renaming), run it, and deliver +-- the resulting HValue. +compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue +compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do + -- > let _compileParsedExpr = expr + -- Create let stmt from expr to make hscParsedStmt happy. + -- We will ignore the returned [Id], namely [expr_id], and not really + -- create a new binding. + let expr_fs = fsLit "_compileParsedExpr" + expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc + let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $ + ValBinds noExtField + (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] + + pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt + let (hvals_io, fix_env) = case pstmt of + Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env') + _ -> panic "compileParsedExprRemote" + + updateFixityEnv fix_env + status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io) + case status of + EvalComplete _ (EvalSuccess [hval]) -> return hval + EvalComplete _ (EvalException e) -> + liftIO $ throwIO (fromSerializableException e) + _ -> panic "compileParsedExpr" + +compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue +compileParsedExpr expr = do + fhv <- compileParsedExprRemote expr + hsc_env <- getSession + liftIO $ withInterp hsc_env $ \interp -> + wormhole interp fhv + +-- | Compile an expression, run it and return the result as a Dynamic. +dynCompileExpr :: GhcMonad m => String -> m Dynamic +dynCompileExpr expr = do + parsed_expr <- parseExpr expr + -- > Data.Dynamic.toDyn expr + let loc = getLoc parsed_expr + to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName) + parsed_expr + hval <- compileParsedExpr to_dyn_expr + return (unsafeCoerce hval :: Dynamic) + +----------------------------------------------------------------------------- +-- show a module and it's source/object filenames + +showModule :: GhcMonad m => ModSummary -> m String +showModule mod_summary = + withSession $ \hsc_env -> do + interpreted <- moduleIsBootOrNotObjectLinkable mod_summary + let dflags = hsc_dflags hsc_env + return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) + +moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool +moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> + case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of + Nothing -> panic "missing linkable" + Just mod_info -> return $ case hm_linkable mod_info of + Nothing -> True + Just linkable -> not (isObjectLinkable linkable) + +---------------------------------------------------------------------------- +-- RTTI primitives + +obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term +#if defined(HAVE_INTERNAL_INTERPRETER) +obtainTermFromVal hsc_env bound force ty x = withInterp hsc_env $ \case + InternalInterp -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x) +#else +obtainTermFromVal hsc_env _bound _force _ty _x = withInterp hsc_env $ \case +#endif + ExternalInterp {} -> throwIO (InstallationError + "this operation requires -fno-external-interpreter") + +obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term +obtainTermFromId hsc_env bound force id = do + hv <- Linker.getHValue hsc_env (varName id) + cvObtainTerm (updEnv hsc_env) bound force (idType id) hv + where updEnv env = env {hsc_dflags = -- #14828 + xopt_set (hsc_dflags env) ImpredicativeTypes} + -- See Note [Setting ImpredicativeTypes for :print command] + +-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic +reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) +reconstructType hsc_env bound id = do + hv <- Linker.getHValue hsc_env (varName id) + cvReconstructType hsc_env bound (idType id) hv + +mkRuntimeUnkTyVar :: Name -> Kind -> TyVar +mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk + + +{- +Note [Setting ImpredicativeTypes for :print command] + +If ImpredicativeTypes is not enabled, then `:print ` will fail if the +type of has nested `forall`s or `=>`s. +This is because the GHCi debugger's internals will attempt to unify a +metavariable with the type of and then display the result, but if the +type has nested `forall`s or `=>`s, then unification will fail. +As a result, `:print` will bail out and the unhelpful result will be +` = (_t1::t1)` (where `t1` is a metavariable). + +Beware: can have nested `forall`s even if its definition doesn't use +RankNTypes! Here is an example from #14828: + + class Functor f where + fmap :: (a -> b) -> f a -> f b + +Somewhat surprisingly, `:print fmap` considers the type of fmap to have +nested foralls. This is because the GHCi debugger sees the type +`fmap :: forall f. Functor f => forall a b. (a -> b) -> f a -> f b`. +We could envision deeply instantiating this type to get the type +`forall f a b. Functor f => (a -> b) -> f a -> f b`, +but this trick wouldn't work for higher-rank types. + +Instead, we adopt a simpler fix: enable `ImpredicativeTypes` when using +`:print` and friends in the GHCi debugger. This allows metavariables +to unify with types that have nested (or higher-rank) `forall`s/`=>`s, +which makes `:print fmap` display as +`fmap = (_t1::forall a b. Functor f => (a -> b) -> f a -> f b)`, as expected. + +Although ImpredicativeTypes is a somewhat unpredictable from a type inference +perspective, there is no danger in using it in the GHCi debugger, since all +of the terms that the GHCi debugger deals with have already been typechecked. +-} diff --git a/GHC/Runtime/Eval/Types.hs b/GHC/Runtime/Eval/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Eval/Types.hs @@ -0,0 +1,89 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module GHC.Runtime.Eval.Types ( + Resume(..), History(..), ExecResult(..), + SingleStep(..), isStep, ExecOptions(..), + BreakInfo(..) + ) where + +import GHC.Prelude + +import GHCi.RemoteTypes +import GHCi.Message (EvalExpr, ResumeContext) +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.Name.Reader +import GHC.Core.Type +import GHC.Types.SrcLoc +import GHC.Utils.Exception + +import Data.Word +import GHC.Stack.CCS + +data ExecOptions + = ExecOptions + { execSingleStep :: SingleStep -- ^ stepping mode + , execSourceFile :: String -- ^ filename (for errors) + , execLineNumber :: Int -- ^ line number (for errors) + , execWrap :: ForeignHValue -> EvalExpr ForeignHValue + } + +data SingleStep + = RunToCompletion + | SingleStep + | RunAndLogSteps + +isStep :: SingleStep -> Bool +isStep RunToCompletion = False +isStep _ = True + +data ExecResult + = ExecComplete + { execResult :: Either SomeException [Name] + , execAllocation :: Word64 + } + | ExecBreak + { breakNames :: [Name] + , breakInfo :: Maybe BreakInfo + } + +data BreakInfo = BreakInfo + { breakInfo_module :: Module + , breakInfo_number :: Int + } + +data Resume = Resume + { resumeStmt :: String -- the original statement + , resumeContext :: ForeignRef (ResumeContext [HValueRef]) + , resumeBindings :: ([TyThing], GlobalRdrEnv) + , resumeFinalIds :: [Id] -- [Id] to bind on completion + , resumeApStack :: ForeignHValue -- The object from which we can get + -- value of the free variables. + , resumeBreakInfo :: Maybe BreakInfo + -- the breakpoint we stopped at + -- (module, index) + -- (Nothing <=> exception) + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan + -- from the ModBreaks, + -- otherwise it's a pain to + -- fetch the ModDetails & + -- ModBreaks to get this. + , resumeDecl :: String -- ditto + , resumeCCS :: RemotePtr CostCentreStack + , resumeHistory :: [History] + , resumeHistoryIx :: Int -- 0 <==> at the top of the history + } + +data History + = History { + historyApStack :: ForeignHValue, + historyBreakInfo :: BreakInfo, + historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint + } diff --git a/GHC/Runtime/Heap/Inspect.hs b/GHC/Runtime/Heap/Inspect.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Heap/Inspect.hs @@ -0,0 +1,1344 @@ +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- GHC Interactive support for inspecting arbitrary closures at runtime +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +----------------------------------------------------------------------------- +module GHC.Runtime.Heap.Inspect( + -- * Entry points and types + cvObtainTerm, + cvReconstructType, + improveRTTIType, + Term(..), + + -- * Utils + isFullyEvaluatedTerm, + termType, mapTermType, termTyCoVars, + foldTerm, TermFold(..), + cPprTerm, cPprTermBase, + + constrClosToName -- exported to use in test T4891 + ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Runtime.Interpreter as GHCi +import GHCi.RemoteTypes +import GHC.Driver.Types +import GHCi.Message ( fromSerializableException ) + +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Core.Multiplicity +import qualified GHC.Core.Unify as U +import GHC.Types.Var +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Zonk ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) ) +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Env + +import GHC.Core.TyCon +import GHC.Types.Name +import GHC.Types.Name.Occurrence as OccName +import GHC.Unit.Module +import GHC.Iface.Env +import GHC.Utils.Misc +import GHC.Types.Var.Set +import GHC.Types.Basic ( Boxity(..) ) +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Driver.Session +import GHC.Utils.Outputable as Ppr +import GHC.Char +import GHC.Exts.Heap +import GHC.Runtime.Heap.Layout ( roundUpTo ) +import GHC.IO (throwIO) + +import Control.Monad +import Data.Maybe +import Data.List +import GHC.Exts +import qualified Data.Sequence as Seq +import Data.Sequence (viewl, ViewL(..)) +import Foreign +import System.IO.Unsafe + +--------------------------------------------- +-- * A representation of semi evaluated Terms +--------------------------------------------- + +data Term = Term { ty :: RttiType + , dc :: Either String DataCon + -- Carries a text representation if the datacon is + -- not exported by the .hi file, which is the case + -- for private constructors in -O0 compiled libraries + , val :: ForeignHValue + , subTerms :: [Term] } + + | Prim { ty :: RttiType + , valRaw :: [Word] } + + | Suspension { ctype :: ClosureType + , ty :: RttiType + , val :: ForeignHValue + , bound_to :: Maybe Name -- Useful for printing + } + | NewtypeWrap{ -- At runtime there are no newtypes, and hence no + -- newtype constructors. A NewtypeWrap is just a + -- made-up tag saying "heads up, there used to be + -- a newtype constructor here". + ty :: RttiType + , dc :: Either String DataCon + , wrapped_term :: Term } + | RefWrap { -- The contents of a reference + ty :: RttiType + , wrapped_term :: Term } + +termType :: Term -> RttiType +termType t = ty t + +isFullyEvaluatedTerm :: Term -> Bool +isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt +isFullyEvaluatedTerm Prim {} = True +isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm _ = False + +instance Outputable (Term) where + ppr t | Just doc <- cPprTerm cPprTermBase t = doc + | otherwise = panic "Outputable Term instance" + +---------------------------------------- +-- Runtime Closure information functions +---------------------------------------- + +isThunk :: GenClosure a -> Bool +isThunk ThunkClosure{} = True +isThunk APClosure{} = True +isThunk APStackClosure{} = True +isThunk _ = False + +-- Lookup the name in a constructor closure +constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name) +constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do + let occName = mkOccName OccName.dataName occ + modName = mkModule (stringToUnit pkg) (mkModuleName mod) + Right `fmap` lookupOrigIO hsc_env modName occName +constrClosToName _hsc_env clos = + return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) + +----------------------------------- +-- * Traversals for Terms +----------------------------------- +type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b + +data TermFold a = TermFold { fTerm :: TermProcessor a a + , fPrim :: RttiType -> [Word] -> a + , fSuspension :: ClosureType -> RttiType -> ForeignHValue + -> Maybe Name -> a + , fNewtypeWrap :: RttiType -> Either String DataCon + -> a -> a + , fRefWrap :: RttiType -> a -> a + } + + +data TermFoldM m a = + TermFoldM {fTermM :: TermProcessor a (m a) + , fPrimM :: RttiType -> [Word] -> m a + , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue + -> Maybe Name -> m a + , fNewtypeWrapM :: RttiType -> Either String DataCon + -> a -> m a + , fRefWrapM :: RttiType -> a -> m a + } + +foldTerm :: TermFold a -> Term -> a +foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) +foldTerm tf (Prim ty v ) = fPrim tf ty v +foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b +foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) +foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) + + +foldTermM :: Monad m => TermFoldM m a -> Term -> m a +foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v +foldTermM tf (Prim ty v ) = fPrimM tf ty v +foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b +foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc +foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty + +idTermFold :: TermFold Term +idTermFold = TermFold { + fTerm = Term, + fPrim = Prim, + fSuspension = Suspension, + fNewtypeWrap = NewtypeWrap, + fRefWrap = RefWrap + } + +mapTermType :: (RttiType -> Type) -> Term -> Term +mapTermType f = foldTerm idTermFold { + fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, + fSuspension = \ct ty hval n -> + Suspension ct (f ty) hval n, + fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, + fRefWrap = \ty t -> RefWrap (f ty) t} + +mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term +mapTermTypeM f = foldTermM TermFoldM { + fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, + fPrimM = (return.) . Prim, + fSuspensionM = \ct ty hval n -> + f ty >>= \ty' -> return $ Suspension ct ty' hval n, + fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, + fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} + +termTyCoVars :: Term -> TyCoVarSet +termTyCoVars = foldTerm TermFold { + fTerm = \ty _ _ tt -> + tyCoVarsOfType ty `unionVarSet` concatVarEnv tt, + fSuspension = \_ ty _ _ -> tyCoVarsOfType ty, + fPrim = \ _ _ -> emptyVarSet, + fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t, + fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t} + where concatVarEnv = foldr unionVarSet emptyVarSet + +---------------------------------- +-- Pretty printing of terms +---------------------------------- + +type Precedence = Int +type TermPrinterM m = Precedence -> Term -> m SDoc + +app_prec,cons_prec, max_prec ::Int +max_prec = 10 +app_prec = max_prec +cons_prec = 5 -- TODO Extract this info from GHC itself + +pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m +pprTermM y p t = pprDeeper `liftM` ppr_termM y p t + +ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do + tt_docs <- mapM (y app_prec) tt + return $ cparen (not (null tt) && p >= app_prec) + (text dc_tag <+> pprDeeperList fsep tt_docs) + +ppr_termM y p Term{dc=Right dc, subTerms=tt} +{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity + = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) + <+> hsep (map (ppr_term1 True) tt) +-} -- TODO Printing infix constructors properly + = do { tt_docs' <- mapM (y app_prec) tt + ; return $ ifPprDebug (show_tm tt_docs') + (show_tm (dropList (dataConTheta dc) tt_docs')) + -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on + } + where + show_tm tt_docs + | null tt_docs = ppr dc + | otherwise = cparen (p >= app_prec) $ + sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] + +ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t +ppr_termM y p RefWrap{wrapped_term=t} = do + contents <- y app_prec t + return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents) + -- The constructor name is wired in here ^^^ for the sake of simplicity. + -- I don't think mutvars are going to change in a near future. + -- In any case this is solely a presentation matter: MutVar# is + -- a datatype with no constructors, implemented by the RTS + -- (hence there is no way to obtain a datacon and print it). +ppr_termM _ _ t = ppr_termM1 t + + +ppr_termM1 :: Monad m => Term -> m SDoc +ppr_termM1 Prim{valRaw=words, ty=ty} = + return $ repPrim (tyConAppTyCon ty) words +ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = + return (char '_' <+> whenPprDebug (text "::" <> ppr ty)) +ppr_termM1 Suspension{ty=ty, bound_to=Just n} +-- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("") + | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty +ppr_termM1 Term{} = panic "ppr_termM1 - Term" +ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" +ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" + +pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} + | Just (tc,_) <- tcSplitTyConApp_maybe ty + , ASSERT(isNewTyCon tc) True + , Just new_dc <- tyConSingleDataCon_maybe tc = do + real_term <- y max_prec t + return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) +pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" + +------------------------------------------------------- +-- Custom Term Pretty Printers +------------------------------------------------------- + +-- We can want to customize the representation of a +-- term depending on its type. +-- However, note that custom printers have to work with +-- type representations, instead of directly with types. +-- We cannot use type classes here, unless we employ some +-- typerep trickery (e.g. Weirich's RepLib tricks), +-- which I didn't. Therefore, this code replicates a lot +-- of what type classes provide for free. + +type CustomTermPrinter m = TermPrinterM m + -> [Precedence -> Term -> (m (Maybe SDoc))] + +-- | Takes a list of custom printers with a explicit recursion knot and a term, +-- and returns the output of the first successful printer, or the default printer +cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc +cPprTerm printers_ = go 0 where + printers = printers_ go + go prec t = do + let default_ = Just `liftM` pprTermM go prec t + mb_customDocs = [pp prec t | pp <- printers] ++ [default_] + mdoc <- firstJustM mb_customDocs + case mdoc of + Nothing -> panic "cPprTerm" + Just doc -> return $ cparen (prec>app_prec+1) doc + + firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) + firstJustM [] = return Nothing + +-- Default set of custom printers. Note that the recursion knot is explicit +cPprTermBase :: forall m. Monad m => CustomTermPrinter m +cPprTermBase y = + [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) + . mapM (y (-1)) + . subTerms) + , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) + ppr_list + , ifTerm' (isTyCon intTyCon . ty) ppr_int + , ifTerm' (isTyCon charTyCon . ty) ppr_char + , ifTerm' (isTyCon floatTyCon . ty) ppr_float + , ifTerm' (isTyCon doubleTyCon . ty) ppr_double + , ifTerm' (isTyCon integerTyCon . ty) ppr_integer + , ifTerm' (isTyCon naturalTyCon . ty) ppr_natural + ] + where + ifTerm :: (Term -> Bool) + -> (Precedence -> Term -> m SDoc) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t) + + ifTerm' :: (Term -> Bool) + -> (Precedence -> Term -> m (Maybe SDoc)) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm' pred f prec t@Term{} + | pred t = f prec t + ifTerm' _ _ _ _ = return Nothing + + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (isBoxedTupleTyCon tc) + + isTyCon a_tc ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (a_tc == tc) + + ppr_int, ppr_char, ppr_float, ppr_double + :: Precedence -> Term -> m (Maybe SDoc) + ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} = + return (Just (Ppr.int (fromIntegral w))) + ppr_int _ _ = return Nothing + + ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} = + return (Just (Ppr.pprHsChar (chr (fromIntegral w)))) + ppr_char _ _ = return Nothing + + ppr_float _ Term{subTerms=[Prim{valRaw=[w]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> poke p w >> peek (castPtr p) + return (Just (Ppr.float f)) + ppr_float _ _ = return Nothing + + ppr_double _ Term{subTerms=[Prim{valRaw=[w]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> poke p w >> peek (castPtr p) + return (Just (Ppr.double f)) + -- let's assume that if we get two words, we're on a 32-bit + -- machine. There's no good way to get a Platform to check the word + -- size here. + ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> do + poke p (fromIntegral w1 :: Word32) + poke (p `plusPtr` 4) (fromIntegral w2 :: Word32) + peek (castPtr p) + return (Just (Ppr.double f)) + ppr_double _ _ = return Nothing + + ppr_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc) + ppr_bignat sign _ ws = do + let + wordSize = finiteBitSize (0 :: Word) -- does the word size depend on the target? + makeInteger n _ [] = n + makeInteger n s (x:xs) = makeInteger (n + (fromIntegral x `shiftL` s)) (s + wordSize) xs + signf = case sign of + False -> 1 + True -> -1 + return $ Just $ Ppr.integer $ signf * (makeInteger 0 0 ws) + + -- Reconstructing Bignums is a bit of a pain. This depends deeply on their + -- representation, so it'll break if that changes (but there are several + -- tests in tests/ghci.debugger/scripts that will tell us if this is wrong). + -- + -- data Integer + -- = IS !Int# + -- | IP !BigNat + -- | IN !BigNat + -- + -- data Natural + -- = NS !Word# + -- | NB !BigNat + -- + -- type BigNat = ByteArray# + + ppr_integer :: Precedence -> Term -> m (Maybe SDoc) + ppr_integer _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]} + | con == integerISDataCon + , [W# w] <- ws + = return (Just (Ppr.integer (fromIntegral (I# (word2Int# w))))) + ppr_integer p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} + | con == integerIPDataCon = ppr_bignat False p ws + | con == integerINDataCon = ppr_bignat True p ws + | otherwise = panic "Unexpected Integer constructor" + ppr_integer _ _ = return Nothing + + ppr_natural :: Precedence -> Term -> m (Maybe SDoc) + ppr_natural _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]} + | con == naturalNSDataCon + , [w] <- ws + = return (Just (Ppr.integer (fromIntegral w))) + ppr_natural p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} + | con == naturalNBDataCon = ppr_bignat False p ws + | otherwise = panic "Unexpected Natural constructor" + ppr_natural _ _ = return Nothing + + --Note pprinting of list terms is not lazy + ppr_list :: Precedence -> Term -> m SDoc + ppr_list p (Term{subTerms=[h,t]}) = do + let elems = h : getListTerms t + isConsLast = not (termType (last elems) `eqType` termType h) + is_string = all (isCharTy . ty) elems + chars = [ chr (fromIntegral w) + | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ] + + print_elems <- mapM (y cons_prec) elems + if is_string + then return (Ppr.doubleQuotes (Ppr.text chars)) + else if isConsLast + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep + $ punctuate (space<>colon) print_elems + else return $ brackets + $ pprDeeperList fcat + $ punctuate comma print_elems + + where getListTerms Term{subTerms=[h,t]} = h : getListTerms t + getListTerms Term{subTerms=[]} = [] + getListTerms t@Suspension{} = [t] + getListTerms t = pprPanic "getListTerms" (ppr t) + ppr_list _ _ = panic "doList" + + +repPrim :: TyCon -> [Word] -> SDoc +repPrim t = rep where + rep x + -- Char# uses native machine words, whereas Char's Storable instance uses + -- Int32, so we have to read it as an Int. + | t == charPrimTyCon = text $ show (chr (build x :: Int)) + | t == intPrimTyCon = text $ show (build x :: Int) + | t == wordPrimTyCon = text $ show (build x :: Word) + | t == floatPrimTyCon = text $ show (build x :: Float) + | t == doublePrimTyCon = text $ show (build x :: Double) + | t == int32PrimTyCon = text $ show (build x :: Int32) + | t == word32PrimTyCon = text $ show (build x :: Word32) + | t == int64PrimTyCon = text $ show (build x :: Int64) + | t == word64PrimTyCon = text $ show (build x :: Word64) + | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) + | t == stablePtrPrimTyCon = text "" + | t == stableNamePrimTyCon = text "" + | t == statePrimTyCon = text "" + | t == proxyPrimTyCon = text "" + | t == realWorldTyCon = text "" + | t == threadIdPrimTyCon = text "" + | t == weakPrimTyCon = text "" + | t == arrayPrimTyCon = text "" + | t == smallArrayPrimTyCon = text "" + | t == byteArrayPrimTyCon = text "" + | t == mutableArrayPrimTyCon = text "" + | t == smallMutableArrayPrimTyCon = text "" + | t == mutableByteArrayPrimTyCon = text "" + | t == mutVarPrimTyCon = text "" + | t == mVarPrimTyCon = text "" + | t == tVarPrimTyCon = text "" + | otherwise = char '<' <> ppr t <> char '>' + where build ww = unsafePerformIO $ withArray ww (peek . castPtr) +-- This ^^^ relies on the representation of Haskell heap values being +-- the same as in a C array. + +----------------------------------- +-- Type Reconstruction +----------------------------------- +{- +Type Reconstruction is type inference done on heap closures. +The algorithm walks the heap generating a set of equations, which +are solved with syntactic unification. +A type reconstruction equation looks like: + + = + +The full equation set is generated by traversing all the subterms, starting +from a given term. + +The only difficult part is that newtypes are only found in the lhs of equations. +Right hand sides are missing them. We can either (a) drop them from the lhs, or +(b) reconstruct them in the rhs when possible. + +The function congruenceNewtypes takes a shot at (b) +-} + + +-- A (non-mutable) tau type containing +-- existentially quantified tyvars. +-- (since GHC type language currently does not support +-- existentials, we leave these variables unquantified) +type RttiType = Type + +-- An incomplete type as stored in GHCi: +-- no polymorphism: no quantifiers & all tyvars are skolem. +type GhciType = Type + + +-- The Type Reconstruction monad +-------------------------------- +type TR a = TcM a + +runTR :: HscEnv -> TR a -> IO a +runTR hsc_env thing = do + mb_val <- runTR_maybe hsc_env thing + case mb_val of + Nothing -> error "unable to :print the term" + Just x -> return x + +runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) +runTR_maybe hsc_env thing_inside + = do { (_errs, res) <- initTcInteractive hsc_env thing_inside + ; return res } + +-- | Term Reconstruction trace +traceTR :: SDoc -> TR () +traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti + + +-- Semantically different to recoverM in GHC.Tc.Utils.Monad +-- recoverM retains the errors in the first action, +-- whereas recoverTc here does not +recoverTR :: TR a -> TR a -> TR a +recoverTR = tryTcDiscardingErrs + +trIO :: IO a -> TR a +trIO = liftTcM . liftIO + +liftTcM :: TcM a -> TR a +liftTcM = id + +newVar :: Kind -> TR TcType +newVar = liftTcM . newFlexiTyVarTy + +newOpenVar :: TR TcType +newOpenVar = liftTcM newOpenFlexiTyVarTy + +instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) +-- Instantiate fresh mutable type variables from some TyVars +-- This function preserves the print-name, which helps error messages +instTyVars tvs + = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs) + +type RttiInstantiation = [(TcTyVar, TyVar)] + -- Associates the typechecker-world meta type variables + -- (which are mutable and may be refined), to their + -- debugger-world RuntimeUnk counterparts. + -- If the TcTyVar has not been refined by the runtime type + -- elaboration, then we want to turn it back into the + -- original RuntimeUnk + +-- | Returns the instantiated type scheme ty', and the +-- mapping from new (instantiated) -to- old (skolem) type variables +instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) +instScheme (tvs, ty) + = do { (subst, tvs') <- instTyVars tvs + ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] + ; return (substTy subst ty, rtti_inst) } + +applyRevSubst :: RttiInstantiation -> TR () +-- Apply the *reverse* substitution in-place to any un-filled-in +-- meta tyvars. This recovers the original debugger-world variable +-- unless it has been refined by new information from the heap +applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) + where + do_pair (tc_tv, rtti_tv) + = do { tc_ty <- zonkTcTyVar tc_tv + ; case tcGetTyVar_maybe tc_ty of + Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) + _ -> return () } + +-- Adds a constraint of the form t1 == t2 +-- t1 is expected to come from walking the heap +-- t2 is expected to come from a datacon signature +-- Before unification, congruenceNewtypes needs to +-- do its magic. +addConstraint :: TcType -> TcType -> TR () +addConstraint actual expected = do + traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) + recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, + text "with", ppr expected]) $ + discardResult $ + captureConstraints $ + do { (ty1, ty2) <- congruenceNewtypes actual expected + ; unifyType Nothing ty1 ty2 } + -- TOMDO: what about the coercion? + -- we should consider family instances + + +-- | Term reconstruction +-- +-- Given a pointer to a heap object (`HValue`) and its type, build a `Term` +-- representation of the object. Subterms (objects in the payload) are also +-- built up to the given `max_depth`. After `max_depth` any subterms will appear +-- as `Suspension`s. Any thunks found while traversing the object will be forced +-- based on `force` parameter. +-- +-- Types of terms will be refined based on constructors we find during term +-- reconstruction. See `cvReconstructType` for an overview of how type +-- reconstruction works. +-- +cvObtainTerm + :: HscEnv + -> Int -- ^ How many times to recurse for subterms + -> Bool -- ^ Force thunks + -> RttiType -- ^ Type of the object to reconstruct + -> ForeignHValue -- ^ Object to reconstruct + -> IO Term +cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do + -- we quantify existential tyvars as universal, + -- as this is needed to be able to manipulate + -- them properly + let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty + sigma_old_ty = mkInfForAllTys old_tvs old_tau + traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) + term <- + if null old_tvs + then do + term <- go max_depth sigma_old_ty sigma_old_ty hval + term' <- zonkTerm term + return $ fixFunDictionaries $ expandNewtypes term' + else do + (old_ty', rev_subst) <- instScheme quant_old_ty + my_ty <- newOpenVar + when (check1 quant_old_ty) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + term <- go max_depth my_ty sigma_old_ty hval + new_ty <- zonkTcType (termType term) + if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty + then do + traceTR (text "check2 passed") + addConstraint new_ty old_ty' + applyRevSubst rev_subst + zterm' <- zonkTerm term + return ((fixFunDictionaries . expandNewtypes) zterm') + else do + traceTR (text "check2 failed" <+> parens + (ppr term <+> text "::" <+> ppr new_ty)) + -- we have unsound types. Replace constructor types in + -- subterms with tyvars + zterm' <- mapTermTypeM + (\ty -> case tcSplitTyConApp_maybe ty of + Just (tc, _:_) | tc /= funTyCon + -> newOpenVar + _ -> return ty) + term + zonkTerm zterm' + traceTR (text "Term reconstruction completed." $$ + text "Term obtained: " <> ppr term $$ + text "Type obtained: " <> ppr (termType term)) + return term + where + go :: Int -> Type -> Type -> ForeignHValue -> TcM Term + -- I believe that my_ty should not have any enclosing + -- foralls, nor any free RuntimeUnk skolems; + -- that is partly what the quantifyType stuff achieved + -- + -- [SPJ May 11] I don't understand the difference between my_ty and old_ty + + go 0 my_ty _old_ty a = do + traceTR (text "Gave up reconstructing a term after" <> + int max_depth <> text " steps") + clos <- trIO $ GHCi.getClosure hsc_env a + return (Suspension (tipe (info clos)) my_ty a Nothing) + go !max_depth my_ty old_ty a = do + let monomorphic = not(isTyVarTy my_ty) + -- This ^^^ is a convention. The ancestor tests for + -- monomorphism and passes a type instead of a tv + clos <- trIO $ GHCi.getClosure hsc_env a + case clos of +-- Thunks we may want to force + t | isThunk t && force -> do + traceTR (text "Forcing a " <> text (show (fmap (const ()) t))) + evalRslt <- liftIO $ GHCi.seqHValue hsc_env a + case evalRslt of -- #2950 + EvalSuccess _ -> go (pred max_depth) my_ty old_ty a + EvalException ex -> do + -- Report the exception to the UI + traceTR $ text "Exception occured:" <+> text (show ex) + liftIO $ throwIO $ fromSerializableException ex +-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If +-- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as +-- the suspension so that entering it in GHCi will enter the BLACKHOLE instead +-- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic). + BlackholeClosure{indirectee=ind} -> do + traceTR (text "Following a BLACKHOLE") + ind_clos <- trIO (GHCi.getClosure hsc_env ind) + let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing) + case ind_clos of + -- TSO and BLOCKING_QUEUE cases + BlockingQueueClosure{} -> return_bh_value + OtherClosure info _ _ + | tipe info == TSO -> return_bh_value + UnsupportedClosure info + | tipe info == TSO -> return_bh_value + -- Otherwise follow the indirectee + -- (NOTE: This code will break if we support TSO in ghc-heap one day) + _ -> go max_depth my_ty old_ty ind +-- We always follow indirections + IndClosure{indirectee=ind} -> do + traceTR (text "Following an indirection" ) + go max_depth my_ty old_ty ind +-- We also follow references + MutVarClosure{var=contents} + | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + -> do + -- Deal with the MutVar# primitive + -- It does not have a constructor at all, + -- so we simulate the following one + -- MutVar# :: contents_ty -> MutVar# s contents_ty + traceTR (text "Following a MutVar") + contents_tv <- newVar liftedTypeKind + MASSERT(isUnliftedType my_ty) + (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany + contents_ty (mkTyConApp tycon [world,contents_ty]) + addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty + x <- go (pred max_depth) contents_tv contents_ty contents + return (RefWrap my_ty x) + + -- The interesting case + ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do + traceTR (text "entering a constructor " <> ppr dArgs <+> + if monomorphic + then parens (text "already monomorphic: " <> ppr my_ty) + else Ppr.empty) + Right dcname <- liftIO $ constrClosToName hsc_env clos + (mb_dc, _) <- tryTc (tcLookupDataCon dcname) + case mb_dc of + Nothing -> do -- This can happen for private constructors compiled -O0 + -- where the .hi descriptor does not export them + -- In such case, we return a best approximation: + -- ignore the unpointed args, and recover the pointeds + -- This preserves laziness, and should be safe. + traceTR (text "Not constructor" <+> ppr dcname) + let dflags = hsc_dflags hsc_env + tag = showPpr dflags dcname + vars <- replicateM (length pArgs) + (newVar liftedTypeKind) + subTerms <- sequence $ zipWith (\x tv -> + go (pred max_depth) tv tv x) pArgs vars + return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) + Just dc -> do + traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) + subTtypes <- getDataConArgTys dc my_ty + subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes + return (Term my_ty (Right dc) a subTerms) + + -- This is to support printing of Integers. It's not a general + -- mechanism by any means; in particular we lose the size in + -- bytes of the array. + ArrWordsClosure{bytes=b, arrWords=ws} -> do + traceTR (text "ByteArray# closure, size " <> ppr b) + return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws]) + +-- The otherwise case: can be a Thunk,AP,PAP,etc. + _ -> do + traceTR (text "Unknown closure:" <+> + text (show (fmap (const ()) clos))) + return (Suspension (tipe (info clos)) my_ty a Nothing) + + -- insert NewtypeWraps around newtypes + expandNewtypes = foldTerm idTermFold { fTerm = worker } where + worker ty dc hval tt + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , isNewTyCon tc + , wrapped_type <- newTyConInstRhs tc args + , Just dc' <- tyConSingleDataCon_maybe tc + , t' <- worker wrapped_type dc hval tt + = NewtypeWrap ty (Right dc') t' + | otherwise = Term ty dc hval tt + + + -- Avoid returning types where predicates have been expanded to dictionaries. + fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where + worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n + | otherwise = Suspension ct ty hval n + +extractSubTerms :: (Type -> ForeignHValue -> TcM Term) + -> GenClosure ForeignHValue -> [Type] -> TcM [Term] +extractSubTerms recurse clos = liftM thdOf3 . go 0 0 + where + array = dataArgs clos + + go ptr_i arr_i [] = return (ptr_i, arr_i, []) + go ptr_i arr_i (ty:tys) + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + = do (ptr_i, arr_i, terms0) <- + go ptr_i arr_i (dropRuntimeRepArgs elem_tys) + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) + | otherwise + = case typePrimRepArgs ty of + [rep_ty] -> do + (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, term0 : terms1) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) + + go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, []) + go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do + tv <- newVar liftedTypeKind + (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i tv rep_ty + (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys + return (ptr_i, arr_i, term0 : terms1) + + go_rep ptr_i arr_i ty rep + | isGcPtrRep rep = do + t <- recurse ty $ (ptrArgs clos)!!ptr_i + return (ptr_i + 1, arr_i, t) + | otherwise = do + -- This is a bit involved since we allow packing multiple fields + -- within a single word. See also + -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding + platform <- getPlatform + let word_size = platformWordSizeInBytes platform + endian = platformByteOrder platform + size_b = primRepSizeB platform rep + -- Align the start offset (eg, 2-byte value should be 2-byte + -- aligned). But not more than to a word. The offset calculation + -- should be the same with the offset calculation in + -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding. + !aligned_idx = roundUpTo arr_i (min word_size size_b) + !new_arr_i = aligned_idx + size_b + ws | size_b < word_size = + [index size_b aligned_idx word_size endian] + | otherwise = + let (q, r) = size_b `quotRem` word_size + in ASSERT( r == 0 ) + [ array!!i + | o <- [0.. q - 1] + , let i = (aligned_idx `quot` word_size) + o + ] + return (ptr_i, new_arr_i, Prim ty ws) + + unboxedTupleTerm ty terms + = Term ty (Right (tupleDataCon Unboxed (length terms))) + (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + + -- Extract a sub-word sized field from a word + -- A sub word is aligned to the left-most part of a word on big-endian + -- platforms, and to the right-most part of a word on little-endian + -- platforms. This allows to write and read it back from memory + -- independent of endianness. Bits not belonging to a sub word are zeroed + -- out, although, this is strictly speaking not necessary since a sub word + -- is read back from memory by appropriately casted pointers (see e.g. + -- ppr_float of cPprTermBase). + index size_b aligned_idx word_size endian = case endian of + BigEndian -> (word `shiftL` moveBits) `shiftR` zeroOutBits `shiftL` zeroOutBits + LittleEndian -> (word `shiftR` moveBits) `shiftL` zeroOutBits `shiftR` zeroOutBits + where + (q, r) = aligned_idx `quotRem` word_size + word = array!!q + moveBits = r * 8 + zeroOutBits = (word_size - size_b) * 8 + + +-- | Fast, breadth-first Type reconstruction +-- +-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually +-- obtained in GHCi), try to reconstruct a more monomorphic type of the object. +-- This is used for improving type information in debugger. For example, if we +-- have a polymorphic function: +-- +-- sumNumList :: Num a => [a] -> a +-- sumNumList [] = 0 +-- sumNumList (x : xs) = x + sumList xs +-- +-- and add a breakpoint to it: +-- +-- ghci> break sumNumList +-- ghci> sumNumList ([0 .. 9] :: [Int]) +-- +-- ghci shows us more precise types than just `a`s: +-- +-- Stopped in Main.sumNumList, debugger.hs:3:23-39 +-- _result :: Int = _ +-- x :: Int = 0 +-- xs :: [Int] = _ +-- +cvReconstructType + :: HscEnv + -> Int -- ^ How many times to recurse for subterms + -> GhciType -- ^ Type to refine + -> ForeignHValue -- ^ Refine the type using this value + -> IO (Maybe Type) +cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do + traceTR (text "RTTI started with initial type " <> ppr old_ty) + let sigma_old_ty@(old_tvs, _) = quantifyType old_ty + new_ty <- + if null old_tvs + then return old_ty + else do + (old_ty', rev_subst) <- instScheme sigma_old_ty + my_ty <- newOpenVar + when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + search (isMonomorphic `fmap` zonkTcType my_ty) + (\(ty,a) -> go ty a) + (Seq.singleton (my_ty, hval)) + max_depth + new_ty <- zonkTcType my_ty + if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty + then do + traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) + addConstraint my_ty old_ty' + applyRevSubst rev_subst + zonkRttiType new_ty + else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >> + return old_ty + traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) + return new_ty + where +-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () + search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> + int max_depth <> text " steps") + search stop expand l d = + case viewl l of + EmptyL -> return () + x :< xx -> unlessM stop $ do + new <- expand x + search stop expand (xx `mappend` Seq.fromList new) $! (pred d) + + -- returns unification tasks,since we are going to want a breadth-first search + go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)] + go my_ty a = do + traceTR (text "go" <+> ppr my_ty) + clos <- trIO $ GHCi.getClosure hsc_env a + case clos of + BlackholeClosure{indirectee=ind} -> go my_ty ind + IndClosure{indirectee=ind} -> go my_ty ind + MutVarClosure{var=contents} -> do + tv' <- newVar liftedTypeKind + world <- newVar liftedTypeKind + addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) + return [(tv', contents)] + ConstrClosure{ptrArgs=pArgs} -> do + Right dcname <- liftIO $ constrClosToName hsc_env clos + traceTR (text "Constr1" <+> ppr dcname) + (mb_dc, _) <- tryTc (tcLookupDataCon dcname) + case mb_dc of + Nothing-> do + forM pArgs $ \x -> do + tv <- newVar liftedTypeKind + return (tv, x) + + Just dc -> do + arg_tys <- getDataConArgTys dc my_ty + (_, itys) <- findPtrTyss 0 arg_tys + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs + _ -> return [] + +findPtrTys :: Int -- Current pointer index + -> Type -- Type + -> TR (Int, [(Int, Type)]) +findPtrTys i ty + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = findPtrTyss i elem_tys + + | otherwise + = case typePrimRep ty of + [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)]) + | otherwise -> return (i, []) + prim_reps -> + foldM (\(i, extras) prim_rep -> + if isGcPtrRep prim_rep + then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) + else return (i, extras)) + (i, []) prim_reps + +findPtrTyss :: Int + -> [Type] + -> TR (Int, [(Int, Type)]) +findPtrTyss i tys = foldM step (i, []) tys + where step (i, discovered) elem_ty = do + (i, extras) <- findPtrTys i elem_ty + return (i, discovered ++ extras) + + +-- Compute the difference between a base type and the type found by RTTI +-- improveType +-- The types can contain skolem type variables, which need to be treated as normal vars. +-- In particular, we want them to unify with things. +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst +improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty + +getDataConArgTys :: DataCon -> Type -> TR [Type] +-- Given the result type ty of a constructor application (D a b c :: ty) +-- return the types of the arguments. This is RTTI-land, so 'ty' might +-- not be fully known. Moreover, the arg types might involve existentials; +-- if so, make up fresh RTTI type variables for them +-- +-- I believe that con_app_ty should not have any enclosing foralls +getDataConArgTys dc con_app_ty + = do { let rep_con_app_ty = unwrapType con_app_ty + ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty + $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) + ; ASSERT( all isTyVar ex_tvs ) return () + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018) + ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) + ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) + -- See Note [Constructor arg types] + ; let con_arg_tys = substTys subst (map scaledThing $ dataConRepArgTys dc) + ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) + ; return con_arg_tys } + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + +{- Note [Constructor arg types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a GADT (cf #7386) + data family D a b + data instance D [a] a where + MkT :: a -> D [a] (Maybe a) + ... + +In getDataConArgTys +* con_app_ty is the known type (from outside) of the constructor application, + say D [Int] Int + +* The data constructor MkT has a (representation) dataConTyCon = DList, + say where + data DList a where + MkT :: a -> DList a (Maybe a) + ... + +So the dataConTyCon of the data constructor, DList, differs from +the "outside" type, D. So we can't straightforwardly decompose the +"outside" type, and we end up in the "_" branch of the case. + +Then we match the dataConOrigResTy of the data constructor against the +outside type, hoping to get a substitution that tells how to instantiate +the *representation* type constructor. This looks a bit delicate to +me, but it seems to work. +-} + +-- Soundness checks +-------------------- +{- +This is not formalized anywhere, so hold to your seats! +RTTI in the presence of newtypes can be a tricky and unsound business. + +Example: +~~~~~~~~~ +Suppose we are doing RTTI for a partially evaluated +closure t, the real type of which is t :: MkT Int, for + + newtype MkT a = MkT [Maybe a] + +The table below shows the results of RTTI and the improvement +calculated for different combinations of evaluatedness and :type t. +Regard the two first columns as input and the next two as output. + + # | t | :type t | rtti(t) | improv. | result + ------------------------------------------------------------ + 1 | _ | t b | a | none | OK + 2 | _ | MkT b | a | none | OK + 3 | _ | t Int | a | none | OK + + If t is not evaluated at *all*, we are safe. + + 4 | (_ : _) | t b | [a] | t = [] | UNSOUND + 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype) + 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND + + If a is a minimal whnf, we run into trouble. Note that + row 5 above does newtype enrichment on the ty_rtty parameter. + + 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND + | | | b = Maybe a| + + 8 | (Just _:_)| MkT b | MkT a | none | OK + 9 | (Just _:_)| t Int | FAIL | none | OK + + And if t is any more evaluated than whnf, we are still in trouble. + Because constraints are solved in top-down order, when we reach the + Maybe subterm what we got is already unsound. This explains why the + row 9 fails to complete. + + 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK + 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK + + We can undo the failure in row 9 by leaving out the constraint + coming from the type signature of t (i.e., the 2nd column). + Note that this type information is still used + to calculate the improvement. But we fail + when trying to calculate the improvement, as there is no unifier for + t Int = [Maybe a] or t Int = [Maybe Int]. + + + Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]] + + # | t | :type t | rtti(t) | improvement | result + --------------------------------------------------------------------- + 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] | + | | | | b = Maybe a | + +The checks: +~~~~~~~~~~~ +Consider a function obtainType that takes a value and a type and produces +the Term representation and a substitution (the improvement). +Assume an auxiliar rtti' function which does the actual job if recovering +the type, but which may produce a false type. + +In pseudocode: + + rtti' :: a -> IO Type -- Does not use the static type information + + obtainType :: a -> Type -> IO (Maybe (Term, Improvement)) + obtainType v old_ty = do + rtti_ty <- rtti' v + if monomorphic rtti_ty || (check rtti_ty old_ty) + then ... + else return Nothing + where check rtti_ty old_ty = check1 rtti_ty && + check2 rtti_ty old_ty + + check1 :: Type -> Bool + check2 :: Type -> Type -> Bool + +Now, if rtti' returns a monomorphic type, we are safe. +If that is not the case, then we consider two conditions. + + +1. To prevent the class of unsoundness displayed by + rows 4 and 7 in the example: no higher kind tyvars + accepted. + + check1 (t a) = NO + check1 (t Int) = NO + check1 ([] a) = YES + +2. To prevent the class of unsoundness shown by row 6, + the rtti type should be structurally more + defined than the old type we are comparing it to. + check2 :: NewType -> OldType -> Bool + check2 a _ = True + check2 [a] a = True + check2 [a] (t Int) = False + check2 [a] (t a) = False -- By check1 we never reach this equation + check2 [Int] a = True + check2 [Int] (t Int) = True + check2 [Maybe a] (t Int) = False + check2 [Maybe Int] (t Int) = True + check2 (Maybe [a]) (m [Int]) = False + check2 (Maybe [Int]) (m [Int]) = True + +-} + +check1 :: QuantifiedType -> Bool +check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) + where + isHigherKind = not . null . fst . splitPiTys + +check2 :: QuantifiedType -> QuantifiedType -> Bool +check2 (_, rtti_ty) (_, old_ty) + | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty + = case () of + _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty + -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds) + _ | Just _ <- splitAppTy_maybe old_ty + -> isMonomorphicOnNonPhantomArgs rtti_ty + _ -> True + | otherwise = True + +-- Dealing with newtypes +-------------------------- +{- + congruenceNewtypes does a parallel fold over two Type values, + compensating for missing newtypes on both sides. + This is necessary because newtypes are not present + in runtime, but sometimes there is evidence available. + Evidence can come from DataCon signatures or + from compile-time type inference. + What we are doing here is an approximation + of unification modulo a set of equations derived + from newtype definitions. These equations should be the + same as the equality coercions generated for newtypes + in System Fc. The idea is to perform a sort of rewriting, + taking those equations as rules, before launching unification. + + The caller must ensure the following. + The 1st type (lhs) comes from the heap structure of ptrs,nptrs. + The 2nd type (rhs) comes from a DataCon type signature. + Rewriting (i.e. adding/removing a newtype wrapper) can happen + in both types, but in the rhs it is restricted to the result type. + + Note that it is very tricky to make this 'rewriting' + work with the unification implemented by TcM, where + substitutions are operationally inlined. The order in which + constraints are unified is vital as we cannot modify + anything that has been touched by a previous unification step. +Therefore, congruenceNewtypes is sound only if the types +recovered by the RTTI mechanism are unified Top-Down. +-} +congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType) +congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') + where + go l r + -- TyVar lhs inductive case + | Just tv <- getTyVar_maybe l + , isTcTyVar tv + , isMetaTyVar tv + = recoverTR (return r) $ do + Indirect ty_v <- readMetaTyVar tv + traceTR $ fsep [text "(congruence) Following indirect tyvar:", + ppr tv, equals, ppr ty_v] + go ty_v r +-- FunTy inductive case + | Just (w1,l1,l2) <- splitFunTy_maybe l + , Just (w2,r1,r2) <- splitFunTy_maybe r + , w1 `eqType` w2 + = do r2' <- go l2 r2 + r1' <- go l1 r1 + return (mkVisFunTy w1 r1' r2') +-- TyconApp Inductive case; this is the interesting bit. + | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs + , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs + , tycon_l /= tycon_r + = upgrade tycon_l r + + | otherwise = return r + + where upgrade :: TyCon -> Type -> TR Type + upgrade new_tycon ty + | not (isNewTyCon new_tycon) = do + traceTR (text "(Upgrade) Not matching newtype evidence: " <> + ppr new_tycon <> text " for " <> ppr ty) + return ty + | otherwise = do + traceTR (text "(Upgrade) upgraded " <> ppr ty <> + text " in presence of newtype evidence " <> ppr new_tycon) + (_, vars) <- instTyVars (tyConTyVars new_tycon) + let ty' = mkTyConApp new_tycon (mkTyVarTys vars) + rep_ty = unwrapType ty' + _ <- liftTcM (unifyType Nothing ty rep_ty) + -- assumes that reptype doesn't ^^^^ touch tyconApp args + return ty' + + +zonkTerm :: Term -> TcM Term +zonkTerm = foldTermM (TermFoldM + { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> + return (Term ty' dc v tt) + , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty -> + return (Suspension ct ty v b) + , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> + return$ NewtypeWrap ty' dc t + , fRefWrapM = \ty t -> return RefWrap `ap` + zonkRttiType ty `ap` return t + , fPrimM = (return.) . Prim }) + +zonkRttiType :: TcType -> TcM Type +-- Zonk the type, replacing any unbound Meta tyvars +-- by RuntimeUnk skolems, safely out of Meta-tyvar-land +zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi + ; zonkTcTypeToTypeX ze ty } + +-------------------------------------------------------------------------------- +-- Restore Class predicates out of a representation type +dictsView :: Type -> Type +dictsView ty = ty + + +-- Use only for RTTI types +isMonomorphic :: RttiType -> Bool +isMonomorphic ty = noExistentials && noUniversals + where (tvs, _, ty') = tcSplitSigmaTy ty + noExistentials = noFreeVarsOfType ty' + noUniversals = null tvs + +-- Use only for RTTI types +isMonomorphicOnNonPhantomArgs :: RttiType -> Bool +isMonomorphicOnNonPhantomArgs ty + | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty) + , phantom_vars <- tyConPhantomTyVars tc + , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args + , tyv `notElem` phantom_vars] + = all isMonomorphicOnNonPhantomArgs concrete_args + | Just (_, ty1, ty2) <- splitFunTy_maybe ty + = all isMonomorphicOnNonPhantomArgs [ty1,ty2] + | otherwise = isMonomorphic ty + +tyConPhantomTyVars :: TyCon -> [TyVar] +tyConPhantomTyVars tc + | isAlgTyCon tc + , Just dcs <- tyConDataCons_maybe tc + , dc_vars <- concatMap dataConUnivTyVars dcs + = tyConTyVars tc \\ dc_vars +tyConPhantomTyVars _ = [] + +type QuantifiedType = ([TyVar], Type) + -- Make the free type variables explicit + -- The returned Type should have no top-level foralls (I believe) + +quantifyType :: Type -> QuantifiedType +-- Generalize the type: find all free and forall'd tyvars +-- and return them, together with the type inside, which +-- should not be a forall type. +-- +-- Thus (quantifyType (forall a. a->[b])) +-- returns ([a,b], a -> [b]) + +quantifyType ty = ( filter isTyVar $ + tyCoVarsOfTypeWellScoped rho + , rho) + where + (_tvs, rho) = tcSplitForAllTys ty diff --git a/GHC/Runtime/Heap/Layout.hs b/GHC/Runtime/Heap/Layout.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Heap/Layout.hs @@ -0,0 +1,539 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- Storage manager representation of closures + +{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} + +module GHC.Runtime.Heap.Layout ( + -- * Words and bytes + WordOff, ByteOff, + wordsToBytes, bytesToWordsRoundUp, + roundUpToWords, roundUpTo, + + StgWord, fromStgWord, toStgWord, + StgHalfWord, fromStgHalfWord, toStgHalfWord, + halfWordSize, halfWordSizeInBits, + + -- * Closure representation + SMRep(..), -- CmmInfo sees the rep; no one else does + IsStatic, + ClosureTypeInfo(..), ArgDescr(..), Liveness, + ConstrDescription, + + -- ** Construction + mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, + smallArrPtrsRep, arrWordsRep, + + -- ** Predicates + isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, + isStackRep, + + -- ** Size-related things + heapClosureSizeW, + fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, + arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, + smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW, + fixedHdrSize, + + -- ** RTS closure types + rtsClosureType, rET_SMALL, rET_BIG, + aRG_GEN, aRG_GEN_BIG, + + -- ** Arrays + card, cardRoundUp, cardTableSizeB, cardTableSizeW + ) where + +import GHC.Prelude + +import GHC.Types.Basic( ConTagZ ) +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Data.FastString +import GHC.StgToCmm.Types + +import Data.Word +import Data.Bits +import Data.ByteString (ByteString) + +{- +************************************************************************ +* * + Words and bytes +* * +************************************************************************ +-} + +-- | Byte offset, or byte count +type ByteOff = Int + +-- | Round up the given byte count to the next byte count that's a +-- multiple of the machine's word size. +roundUpToWords :: Platform -> ByteOff -> ByteOff +roundUpToWords platform n = roundUpTo n (platformWordSizeInBytes platform) + +-- | Round up @base@ to a multiple of @size@. +roundUpTo :: ByteOff -> ByteOff -> ByteOff +roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1)) + +-- | Convert the given number of words to a number of bytes. +-- +-- This function morally has type @WordOff -> ByteOff@, but uses @Num +-- a@ to allow for overloading. +wordsToBytes :: Num a => Platform -> a -> a +wordsToBytes platform n = fromIntegral (platformWordSizeInBytes platform) * n +{-# SPECIALIZE wordsToBytes :: Platform -> Int -> Int #-} +{-# SPECIALIZE wordsToBytes :: Platform -> Word -> Word #-} +{-# SPECIALIZE wordsToBytes :: Platform -> Integer -> Integer #-} + +-- | First round the given byte count up to a multiple of the +-- machine's word size and then convert the result to words. +bytesToWordsRoundUp :: Platform -> ByteOff -> WordOff +bytesToWordsRoundUp platform n = (n + word_size - 1) `quot` word_size + where word_size = platformWordSizeInBytes platform +-- StgWord is a type representing an StgWord on the target platform. +-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform +newtype StgWord = StgWord Word64 + deriving (Eq, Bits) + +fromStgWord :: StgWord -> Integer +fromStgWord (StgWord i) = toInteger i + +toStgWord :: Platform -> Integer -> StgWord +toStgWord platform i + = case platformWordSize platform of + -- These conversions mean that things like toStgWord (-1) + -- do the right thing + PW4 -> StgWord (fromIntegral (fromInteger i :: Word32)) + PW8 -> StgWord (fromInteger i) + +instance Outputable StgWord where + ppr (StgWord i) = integer (toInteger i) + +-- + +-- A Word32 is large enough to hold half a Word for either a 32bit or +-- 64bit platform +newtype StgHalfWord = StgHalfWord Word32 + deriving Eq + +fromStgHalfWord :: StgHalfWord -> Integer +fromStgHalfWord (StgHalfWord w) = toInteger w + +toStgHalfWord :: Platform -> Integer -> StgHalfWord +toStgHalfWord platform i + = case platformWordSize platform of + -- These conversions mean that things like toStgHalfWord (-1) + -- do the right thing + PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) + PW8 -> StgHalfWord (fromInteger i :: Word32) + +instance Outputable StgHalfWord where + ppr (StgHalfWord w) = integer (toInteger w) + +-- | Half word size in bytes +halfWordSize :: Platform -> ByteOff +halfWordSize platform = platformWordSizeInBytes platform `div` 2 + +halfWordSizeInBits :: Platform -> Int +halfWordSizeInBits platform = platformWordSizeInBits platform `div` 2 + +{- +************************************************************************ +* * +\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} +* * +************************************************************************ +-} + +-- | A description of the layout of a closure. Corresponds directly +-- to the closure types in includes\/rts\/storage\/ClosureTypes.h. +data SMRep + = HeapRep -- GC routines consult sizes in info tbl + IsStatic + !WordOff -- # ptr words + !WordOff -- # non-ptr words INCLUDING SLOP (see mkHeapRep below) + ClosureTypeInfo -- type-specific info + + | ArrayPtrsRep + !WordOff -- # ptr words + !WordOff -- # card table words + + | SmallArrayPtrsRep + !WordOff -- # ptr words + + | ArrayWordsRep + !WordOff -- # bytes expressed in words, rounded up + + | StackRep -- Stack frame (RET_SMALL or RET_BIG) + Liveness + + | RTSRep -- The RTS needs to declare info tables with specific + Int -- type tags, so this form lets us override the default + SMRep -- tag for an SMRep. + +-- | True \<=> This is a static closure. Affects how we garbage-collect it. +-- Static closure have an extra static link field at the end. +-- Constructors do not have a static variant; see Note [static constructors] +type IsStatic = Bool + +-- From an SMRep you can get to the closure type defined in +-- includes/rts/storage/ClosureTypes.h. Described by the function +-- rtsClosureType below. + +data ClosureTypeInfo + = Constr ConTagZ ConstrDescription + | Fun FunArity ArgDescr + | Thunk + | ThunkSelector SelectorOffset + | BlackHole + | IndStatic + +type ConstrDescription = ByteString -- result of dataConIdentity +type FunArity = Int +type SelectorOffset = Int + +----------------------------------------------------------------------------- +-- Construction + +mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo + -> SMRep +mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info + = HeapRep is_static + ptr_wds + (nonptr_wds + slop_wds) + cl_type_info + where + slop_wds + | is_static = 0 + | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) + + hdr_size = closureTypeHdrSize dflags cl_type_info + payload_size = ptr_wds + nonptr_wds + +mkRTSRep :: Int -> SMRep -> SMRep +mkRTSRep = RTSRep + +mkStackRep :: [Bool] -> SMRep +mkStackRep liveness = StackRep liveness + +blackHoleRep :: SMRep +blackHoleRep = HeapRep False 0 0 BlackHole + +indStaticRep :: SMRep +indStaticRep = HeapRep True 1 0 IndStatic + +arrPtrsRep :: DynFlags -> WordOff -> SMRep +arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) + +smallArrPtrsRep :: WordOff -> SMRep +smallArrPtrsRep elems = SmallArrayPtrsRep elems + +arrWordsRep :: Platform -> ByteOff -> SMRep +arrWordsRep platform bytes = ArrayWordsRep (bytesToWordsRoundUp platform bytes) + +----------------------------------------------------------------------------- +-- Predicates + +isStaticRep :: SMRep -> IsStatic +isStaticRep (HeapRep is_static _ _ _) = is_static +isStaticRep (RTSRep _ rep) = isStaticRep rep +isStaticRep _ = False + +isStackRep :: SMRep -> Bool +isStackRep StackRep{} = True +isStackRep (RTSRep _ rep) = isStackRep rep +isStackRep _ = False + +isConRep :: SMRep -> Bool +isConRep (HeapRep _ _ _ Constr{}) = True +isConRep _ = False + +isThunkRep :: SMRep -> Bool +isThunkRep (HeapRep _ _ _ Thunk) = True +isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True +isThunkRep (HeapRep _ _ _ BlackHole) = True +isThunkRep (HeapRep _ _ _ IndStatic) = True +isThunkRep _ = False + +isFunRep :: SMRep -> Bool +isFunRep (HeapRep _ _ _ Fun{}) = True +isFunRep _ = False + +isStaticNoCafCon :: SMRep -> Bool +-- This should line up exactly with CONSTR_NOCAF below +-- See Note [Static NoCaf constructors] +isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True +isStaticNoCafCon _ = False + + +----------------------------------------------------------------------------- +-- Size-related things + +fixedHdrSize :: DynFlags -> ByteOff +fixedHdrSize dflags = wordsToBytes (targetPlatform dflags) (fixedHdrSizeW dflags) + +-- | Size of a closure header (StgHeader in includes\/rts\/storage\/Closures.h) +fixedHdrSizeW :: DynFlags -> WordOff +fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags + +-- | Size of the profiling part of a closure header +-- (StgProfHeader in includes\/rts\/storage\/Closures.h) +profHdrSize :: DynFlags -> WordOff +profHdrSize dflags + | sccProfilingEnabled dflags = pROF_HDR_SIZE dflags + | otherwise = 0 + +-- | The garbage collector requires that every closure is at least as +-- big as this. +minClosureSize :: DynFlags -> WordOff +minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags + +arrWordsHdrSize :: DynFlags -> ByteOff +arrWordsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags + +arrWordsHdrSizeW :: DynFlags -> WordOff +arrWordsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgArrBytes_NoHdr dflags `quot` + platformWordSizeInBytes (targetPlatform dflags)) + +arrPtrsHdrSize :: DynFlags -> ByteOff +arrPtrsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags + +arrPtrsHdrSizeW :: DynFlags -> WordOff +arrPtrsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` + platformWordSizeInBytes (targetPlatform dflags)) + +smallArrPtrsHdrSize :: DynFlags -> ByteOff +smallArrPtrsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags + +smallArrPtrsHdrSizeW :: DynFlags -> WordOff +smallArrPtrsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` + platformWordSizeInBytes (targetPlatform dflags)) + +-- Thunks have an extra header word on SMP, so the update doesn't +-- splat the payload. +thunkHdrSize :: DynFlags -> WordOff +thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr + where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` + platformWordSizeInBytes (targetPlatform dflags) + +hdrSize :: DynFlags -> SMRep -> ByteOff +hdrSize dflags rep = wordsToBytes (targetPlatform dflags) (hdrSizeW dflags rep) + +hdrSizeW :: DynFlags -> SMRep -> WordOff +hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty +hdrSizeW dflags (ArrayPtrsRep _ _) = arrPtrsHdrSizeW dflags +hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags +hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags +hdrSizeW _ _ = panic "SMRep.hdrSizeW" + +nonHdrSize :: Platform -> SMRep -> ByteOff +nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep) + +nonHdrSizeW :: SMRep -> WordOff +nonHdrSizeW (HeapRep _ p np _) = p + np +nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct +nonHdrSizeW (SmallArrayPtrsRep elems) = elems +nonHdrSizeW (ArrayWordsRep words) = words +nonHdrSizeW (StackRep bs) = length bs +nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep + +-- | The total size of the closure, in words. +heapClosureSizeW :: DynFlags -> SMRep -> WordOff +heapClosureSizeW dflags (HeapRep _ p np ty) + = closureTypeHdrSize dflags ty + p + np +heapClosureSizeW dflags (ArrayPtrsRep elems ct) + = arrPtrsHdrSizeW dflags + elems + ct +heapClosureSizeW dflags (SmallArrayPtrsRep elems) + = smallArrPtrsHdrSizeW dflags + elems +heapClosureSizeW dflags (ArrayWordsRep words) + = arrWordsHdrSizeW dflags + words +heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" + +closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff +closureTypeHdrSize dflags ty = case ty of + Thunk -> thunkHdrSize dflags + ThunkSelector{} -> thunkHdrSize dflags + BlackHole -> thunkHdrSize dflags + IndStatic -> thunkHdrSize dflags + _ -> fixedHdrSizeW dflags + -- All thunks use thunkHdrSize, even if they are non-updatable. + -- this is because we don't have separate closure types for + -- updatable vs. non-updatable thunks, so the GC can't tell the + -- difference. If we ever have significant numbers of non- + -- updatable thunks, it might be worth fixing this. + +-- --------------------------------------------------------------------------- +-- Arrays + +-- | The byte offset into the card table of the card for a given element +card :: DynFlags -> Int -> Int +card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags + +-- | Convert a number of elements to a number of cards, rounding up +cardRoundUp :: DynFlags -> Int -> Int +cardRoundUp dflags i = + card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)) + +-- | The size of a card table, in bytes +cardTableSizeB :: DynFlags -> Int -> ByteOff +cardTableSizeB dflags elems = cardRoundUp dflags elems + +-- | The size of a card table, in words +cardTableSizeW :: DynFlags -> Int -> WordOff +cardTableSizeW dflags elems = + bytesToWordsRoundUp (targetPlatform dflags) + (cardTableSizeB dflags elems) + +----------------------------------------------------------------------------- +-- deriving the RTS closure type from an SMRep + +#include "../includes/rts/storage/ClosureTypes.h" +#include "../includes/rts/storage/FunTypes.h" +-- Defines CONSTR, CONSTR_1_0 etc + +-- | Derives the RTS closure type from an 'SMRep' +rtsClosureType :: SMRep -> Int +rtsClosureType rep + = case rep of + RTSRep ty _ -> ty + + -- See Note [static constructors] + HeapRep _ 1 0 Constr{} -> CONSTR_1_0 + HeapRep _ 0 1 Constr{} -> CONSTR_0_1 + HeapRep _ 2 0 Constr{} -> CONSTR_2_0 + HeapRep _ 1 1 Constr{} -> CONSTR_1_1 + HeapRep _ 0 2 Constr{} -> CONSTR_0_2 + HeapRep _ 0 _ Constr{} -> CONSTR_NOCAF + -- See Note [Static NoCaf constructors] + HeapRep _ _ _ Constr{} -> CONSTR + + HeapRep False 1 0 Fun{} -> FUN_1_0 + HeapRep False 0 1 Fun{} -> FUN_0_1 + HeapRep False 2 0 Fun{} -> FUN_2_0 + HeapRep False 1 1 Fun{} -> FUN_1_1 + HeapRep False 0 2 Fun{} -> FUN_0_2 + HeapRep False _ _ Fun{} -> FUN + + HeapRep False 1 0 Thunk -> THUNK_1_0 + HeapRep False 0 1 Thunk -> THUNK_0_1 + HeapRep False 2 0 Thunk -> THUNK_2_0 + HeapRep False 1 1 Thunk -> THUNK_1_1 + HeapRep False 0 2 Thunk -> THUNK_0_2 + HeapRep False _ _ Thunk -> THUNK + + HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR + + HeapRep True _ _ Fun{} -> FUN_STATIC + HeapRep True _ _ Thunk -> THUNK_STATIC + HeapRep False _ _ BlackHole -> BLACKHOLE + HeapRep False _ _ IndStatic -> IND_STATIC + + _ -> panic "rtsClosureType" + +-- We export these ones +rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int +rET_SMALL = RET_SMALL +rET_BIG = RET_BIG +aRG_GEN = ARG_GEN +aRG_GEN_BIG = ARG_GEN_BIG + +{- +Note [static constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to have a CONSTR_STATIC closure type, and each constructor had +two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with +CONSTR_STATIC. + +This distinction was removed, because when copying a data structure +into a compact region, we must copy static constructors into the +compact region too. If we didn't do this, we would need to track the +references from the compact region out to the static constructors, +because they might (indirectly) refer to CAFs. + +Since static constructors will be copied to the heap, if we wanted to +use different info tables for static and dynamic constructors, we +would have to switch the info pointer when copying the constructor +into the compact region, which means we would need an extra field of +the static info table to point to the dynamic one. + +However, since the distinction between static and dynamic closure +types is never actually needed (other than for assertions), we can +just drop the distinction and use the same info table for both. + +The GC *does* need to distinguish between static and dynamic closures, +but it does this using the HEAP_ALLOCED() macro which checks whether +the address of the closure resides within the dynamic heap. +HEAP_ALLOCED() doesn't read the closure's info table. + +Note [Static NoCaf constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we know that a top-level binding 'x' is not Caffy (ie no CAFs are +reachable from 'x'), then a statically allocated constructor (Just x) +is also not Caffy, and the garbage collector need not follow its +argument fields. Exploiting this would require two static info tables +for Just, for the two cases where the argument was Caffy or non-Caffy. + +Currently we don't do this; instead we treat nullary constructors +as non-Caffy, and the others as potentially Caffy. + + +************************************************************************ +* * + Pretty printing of SMRep and friends +* * +************************************************************************ +-} + +instance Outputable ClosureTypeInfo where + ppr = pprTypeInfo + +instance Outputable SMRep where + ppr (HeapRep static ps nps tyinfo) + = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) + where + header = text "HeapRep" + <+> if static then text "static" else empty + <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps + pp_n :: String -> Int -> SDoc + pp_n _ 0 = empty + pp_n s n = int n <+> text s + + ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size + + ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size + + ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words + + ppr (StackRep bs) = text "StackRep" <+> ppr bs + + ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep + +pprTypeInfo :: ClosureTypeInfo -> SDoc +pprTypeInfo (Constr tag descr) + = text "Con" <+> + braces (sep [ text "tag:" <+> ppr tag + , text "descr:" <> text (show descr) ]) + +pprTypeInfo (Fun arity args) + = text "Fun" <+> + braces (sep [ text "arity:" <+> ppr arity + , ptext (sLit ("fun_type:")) <+> ppr args ]) + +pprTypeInfo (ThunkSelector offset) + = text "ThunkSel" <+> ppr offset + +pprTypeInfo Thunk = text "Thunk" +pprTypeInfo BlackHole = text "BlackHole" +pprTypeInfo IndStatic = text "IndStatic" diff --git a/GHC/Runtime/Interpreter.hs b/GHC/Runtime/Interpreter.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter.hs @@ -0,0 +1,752 @@ +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +-- | Interacting with the iserv interpreter, whether it is running on an +-- external process or in the current process. +-- +module GHC.Runtime.Interpreter + ( -- * High-level interface to the interpreter + evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) + , resumeStmt + , abandonStmt + , evalIO + , evalString + , evalStringToIOString + , mallocData + , createBCOs + , addSptEntry + , mkCostCentres + , costCentreStackInfo + , newBreakArray + , enableBreakpoint + , breakpointStatus + , getBreakpointVar + , getClosure + , getModBreaks + , seqHValue + , interpreterDynamic + , interpreterProfiled + + -- * The object-code linker + , initObjLinker + , lookupSymbol + , lookupClosure + , loadDLL + , loadArchive + , loadObj + , unloadObj + , addLibrarySearchPath + , removeLibrarySearchPath + , resolveObjs + , findSystemLibrary + + -- * Lower-level API using messages + , iservCmd, Message(..), withIServ, withIServ_ + , withInterp, hscInterp, stopInterp + , iservCall, readIServ, writeIServ + , purgeLookupSymbolCache + , freeHValueRefs + , mkFinalizedHValue + , wormhole, wormholeRef + , mkEvalOpts + , fromEvalResult + ) where + +import GHC.Prelude + +import GHC.Runtime.Interpreter.Types +import GHCi.Message +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.BreakArray (BreakArray) +import GHC.Utils.Fingerprint +import GHC.Driver.Types +import GHC.Types.Unique.FM +import GHC.Utils.Panic +import GHC.Driver.Session +import GHC.Utils.Exception as Ex +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Runtime.Eval.Types(BreakInfo(..)) +import GHC.Utils.Outputable(brackets, ppr, showSDocUnqual) +import GHC.Types.SrcLoc +import GHC.Data.Maybe +import GHC.Unit.Module +import GHC.ByteCode.Types +import GHC.Types.Unique + +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHCi.Run +import GHC.Driver.Ways +#endif + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch as MC (mask, onException) +import Data.Binary +import Data.Binary.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Array ((!)) +import Data.IORef +import Foreign hiding (void) +import GHC.Exts.Heap +import GHC.Stack.CCS (CostCentre,CostCentreStack) +import System.Exit +import GHC.IO.Handle.Types (Handle) +#if defined(mingw32_HOST_OS) +import Foreign.C +import GHC.IO.Handle.FD (fdToHandle) +#else +import System.Posix as Posix +#endif +import System.Directory +import System.Process +import GHC.Conc (getNumProcessors, pseq, par) + +{- Note [Remote GHCi] + +When the flag -fexternal-interpreter is given to GHC, interpreted code +is run in a separate process called iserv, and we communicate with the +external process over a pipe using Binary-encoded messages. + +Motivation +~~~~~~~~~~ + +When the interpreted code is running in a separate process, it can +use a different "way", e.g. profiled or dynamic. This means + +- compiling Template Haskell code with -prof does not require + building the code without -prof first + +- when GHC itself is profiled, it can interpret unprofiled code, + and the same applies to dynamic linking. + +- An unprofiled GHCi can load and run profiled code, which means it + can use the stack-trace functionality provided by profiling without + taking the performance hit on the compiler that profiling would + entail. + +For other reasons see remote-GHCi on the wiki. + +Implementation Overview +~~~~~~~~~~~~~~~~~~~~~~~ + +The main pieces are: + +- libraries/ghci, containing: + - types for talking about remote values (GHCi.RemoteTypes) + - the message protocol (GHCi.Message), + - implementation of the messages (GHCi.Run) + - implementation of Template Haskell (GHCi.TH) + - a few other things needed to run interpreted code + +- top-level iserv directory, containing the codefor the external + server. This is a fairly simple wrapper, most of the functionality + is provided by modules in libraries/ghci. + +- This module which provides the interface to the server used + by the rest of GHC. + +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, +interpreted code is run in the same process as GHC. + +Things that do not work with -fexternal-interpreter +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +dynCompileExpr cannot work, because we have no way to run code of an +unknown type in the remote process. This API fails with an error +message if it is used with -fexternal-interpreter. + +Other Notes on Remote GHCi +~~~~~~~~~~~~~~~~~~~~~~~~~~ + * This wiki page has an implementation overview: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter + * Note [External GHCi pointers] in "GHC.Runtime.Interpreter" + * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs +-} + + +-- | Run a command in the interpreter's context. With +-- @-fexternal-interpreter@, the command is serialized and sent to an +-- external iserv process, and the response is deserialized (hence the +-- @Binary@ constraint). With @-fno-external-interpreter@ we execute +-- the command directly here. +iservCmd :: Binary a => HscEnv -> Message a -> IO a +iservCmd hsc_env msg = withInterp hsc_env $ \case +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> run msg -- Just run it directly +#endif + (ExternalInterp c i) -> withIServ_ c i $ \iserv -> + uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] + iservCall iserv msg + + +-- | Execute an action with the interpreter +-- +-- Fails if no target code interpreter is available +withInterp :: HscEnv -> (Interp -> IO a) -> IO a +withInterp hsc_env action = action (hscInterp hsc_env) + +-- | Retreive the targe code interpreter +-- +-- Fails if no target code interpreter is available +hscInterp :: HscEnv -> Interp +hscInterp hsc_env = case hsc_interp hsc_env of + Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter") + Just i -> i + +-- Note [uninterruptibleMask_ and iservCmd] +-- +-- If we receive an async exception, such as ^C, while communicating +-- with the iserv process then we will be out-of-sync and not be able +-- to recover. Thus we use uninterruptibleMask_ during +-- communication. A ^C will be delivered to the iserv process (because +-- signals get sent to the whole process group) which will interrupt +-- the running computation and return an EvalException result. + +-- | Grab a lock on the 'IServ' and do something with it. +-- Overloaded because this is used from TcM as well as IO. +withIServ + :: (ExceptionMonad m) + => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a +withIServ conf (IServ mIServState) action = do + MC.mask $ \restore -> do + state <- liftIO $ takeMVar mIServState + + iserv <- case state of + -- start the external iserv process if we haven't done so yet + IServPending -> + liftIO (spawnIServ conf) + `MC.onException` (liftIO $ putMVar mIServState state) + + IServRunning inst -> return inst + + + let iserv' = iserv{ iservPendingFrees = [] } + + (iserv'',a) <- (do + -- free any ForeignHValues that have been garbage collected. + liftIO $ when (not (null (iservPendingFrees iserv))) $ + iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) + -- run the inner action + restore $ action iserv') + `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv')) + liftIO $ putMVar mIServState (IServRunning iserv'') + return a + +withIServ_ + :: (MonadIO m, ExceptionMonad m) + => IServConfig -> IServ -> (IServInstance -> m a) -> m a +withIServ_ conf iserv action = withIServ conf iserv $ \inst -> + (inst,) <$> action inst + +-- ----------------------------------------------------------------------------- +-- Wrappers around messages + +-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for +-- each of the results. +evalStmt + :: HscEnv -> Bool -> EvalExpr ForeignHValue + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +evalStmt hsc_env step foreign_expr = do + let dflags = hsc_dflags hsc_env + status <- withExpr foreign_expr $ \expr -> + iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr) + handleEvalStatus hsc_env status + where + withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a + withExpr (EvalThis fhv) cont = + withForeignRef fhv $ \hvref -> cont (EvalThis hvref) + withExpr (EvalApp fl fr) cont = + withExpr fl $ \fl' -> + withExpr fr $ \fr' -> + cont (EvalApp fl' fr') + +resumeStmt + :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +resumeStmt hsc_env step resume_ctxt = do + let dflags = hsc_dflags hsc_env + status <- withForeignRef resume_ctxt $ \rhv -> + iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) + handleEvalStatus hsc_env status + +abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () +abandonStmt hsc_env resume_ctxt = do + withForeignRef resume_ctxt $ \rhv -> + iservCmd hsc_env (AbandonStmt rhv) + +handleEvalStatus + :: HscEnv -> EvalStatus [HValueRef] + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +handleEvalStatus hsc_env status = + case status of + EvalBreak a b c d e f -> return (EvalBreak a b c d e f) + EvalComplete alloc res -> + EvalComplete alloc <$> addFinalizer res + where + addFinalizer (EvalException e) = return (EvalException e) + addFinalizer (EvalSuccess rs) = do + EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs + +-- | Execute an action of type @IO ()@ +evalIO :: HscEnv -> ForeignHValue -> IO () +evalIO hsc_env fhv = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult + +-- | Execute an action of type @IO String@ +evalString :: HscEnv -> ForeignHValue -> IO String +evalString hsc_env fhv = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalString fhv) >>= fromEvalResult + +-- | Execute an action of type @String -> IO String@ +evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String +evalStringToIOString hsc_env fhv str = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult + + +-- | Allocate and store the given bytes in memory, returning a pointer +-- to the memory in the remote process. +mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) +mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) + +mkCostCentres + :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre] +mkCostCentres hsc_env mod ccs = + iservCmd hsc_env (MkCostCentres mod ccs) + +-- | Create a set of BCOs that may be mutually recursive. +createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef] +createBCOs hsc_env rbcos = do + n_jobs <- case parMakeCount (hsc_dflags hsc_env) of + Nothing -> liftIO getNumProcessors + Just n -> return n + -- Serializing ResolvedBCO is expensive, so if we're in parallel mode + -- (-j) parallelise the serialization. + if (n_jobs == 1) + then + iservCmd hsc_env (CreateBCOs [runPut (put rbcos)]) + + else do + old_caps <- getNumCapabilities + if old_caps == n_jobs + then void $ evaluate puts + else bracket_ (setNumCapabilities n_jobs) + (setNumCapabilities old_caps) + (void $ evaluate puts) + iservCmd hsc_env (CreateBCOs puts) + where + puts = parMap doChunk (chunkList 100 rbcos) + + -- make sure we force the whole lazy ByteString + doChunk c = pseq (LB.length bs) bs + where bs = runPut (put c) + + -- We don't have the parallel package, so roll our own simple parMap + parMap _ [] = [] + parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) + where fx = f x; fxs = parMap f xs + +addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO () +addSptEntry hsc_env fpr ref = + withForeignRef ref $ \val -> + iservCmd hsc_env (AddSptEntry fpr val) + +costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] +costCentreStackInfo hsc_env ccs = + iservCmd hsc_env (CostCentreStackInfo ccs) + +newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray) +newBreakArray hsc_env size = do + breakArray <- iservCmd hsc_env (NewBreakArray size) + mkFinalizedHValue hsc_env breakArray + +enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () +enableBreakpoint hsc_env ref ix b = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (EnableBreakpoint breakarray ix b) + +breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool +breakpointStatus hsc_env ref ix = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (BreakpointStatus breakarray ix) + +getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue) +getBreakpointVar hsc_env ref ix = + withForeignRef ref $ \apStack -> do + mb <- iservCmd hsc_env (GetBreakpointVar apStack ix) + mapM (mkFinalizedHValue hsc_env) mb + +getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue) +getClosure hsc_env ref = + withForeignRef ref $ \hval -> do + mb <- iservCmd hsc_env (GetClosure hval) + mapM (mkFinalizedHValue hsc_env) mb + +-- | Send a Seq message to the iserv process to force a value #2950 +seqHValue :: HscEnv -> ForeignHValue -> IO (EvalResult ()) +seqHValue hsc_env ref = + withForeignRef ref $ \hval -> + iservCmd hsc_env (Seq hval) >>= handleSeqHValueStatus hsc_env + +-- | Process the result of a Seq or ResumeSeq message. #2950 +handleSeqHValueStatus :: HscEnv -> EvalStatus () -> IO (EvalResult ()) +handleSeqHValueStatus hsc_env eval_status = do + case eval_status of + (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do + -- A breakpoint was hit, inform the user and tell him + -- which breakpoint was hit. + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt + let hmi = expectJust "handleRunStatus" $ + lookupHptDirectly (hsc_HPT hsc_env) + (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + bp | is_exception = Nothing + | otherwise = Just (BreakInfo modl ix) + sdocBpLoc = brackets . ppr . getSeqBpSpan + putStrLn ("*** Ignoring breakpoint " ++ + (showSDocUnqual (hsc_dflags hsc_env) $ sdocBpLoc bp)) + -- resume the seq (:force) processing in the iserv process + withForeignRef resume_ctxt_fhv $ \hval -> + iservCmd hsc_env (ResumeSeq hval) >>= handleSeqHValueStatus hsc_env + (EvalComplete _ r) -> return r + where + getSeqBpSpan :: Maybe BreakInfo -> SrcSpan + -- Just case: Stopped at a breakpoint, extract SrcSpan information + -- from the breakpoint. + getSeqBpSpan (Just BreakInfo{..}) = + (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number + -- Nothing case - should not occur! + -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq + getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "") + breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $ + lookupHpt (hsc_HPT hsc_env) (moduleName mod) + + +-- ----------------------------------------------------------------------------- +-- Interface to the object-code linker + +initObjLinker :: HscEnv -> IO () +initObjLinker hsc_env = iservCmd hsc_env InitLinker + +lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ())) +lookupSymbol hsc_env str = withInterp hsc_env $ \case +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) +#endif + + ExternalInterp c i -> withIServ c i $ \iserv -> do + -- Profiling of GHCi showed a lot of time and allocation spent + -- making cross-process LookupSymbol calls, so I added a GHC-side + -- cache which sped things up quite a lot. We have to be careful + -- to purge this cache when unloading code though. + let cache = iservLookupSymbolCache iserv + case lookupUFM cache str of + Just p -> return (iserv, Just p) + Nothing -> do + m <- uninterruptibleMask_ $ + iservCall iserv (LookupSymbol (unpackFS str)) + case m of + Nothing -> return (iserv, Nothing) + Just r -> do + let p = fromRemotePtr r + cache' = addToUFM cache str p + iserv' = iserv {iservLookupSymbolCache = cache'} + return (iserv', Just p) + +lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) +lookupClosure hsc_env str = + iservCmd hsc_env (LookupClosure str) + +purgeLookupSymbolCache :: HscEnv -> IO () +purgeLookupSymbolCache hsc_env = case hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp _ (IServ mstate)) -> + modifyMVar_ mstate $ \state -> pure $ case state of + IServPending -> state + IServRunning iserv -> IServRunning + (iserv { iservLookupSymbolCache = emptyUFM }) + + +-- | loadDLL loads a dynamic library using the OS's native linker +-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either +-- an absolute pathname to the file, or a relative filename +-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL +-- searches the standard locations for the appropriate library. +-- +-- Returns: +-- +-- Nothing => success +-- Just err_msg => failure +loadDLL :: HscEnv -> String -> IO (Maybe String) +loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str) + +loadArchive :: HscEnv -> String -> IO () +loadArchive hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (LoadArchive path') + +loadObj :: HscEnv -> String -> IO () +loadObj hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (LoadObj path') + +unloadObj :: HscEnv -> String -> IO () +unloadObj hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (UnloadObj path') + +-- Note [loadObj and relative paths] +-- the iserv process might have a different current directory from the +-- GHC process, so we must make paths absolute before sending them +-- over. + +addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ()) +addLibrarySearchPath hsc_env str = + fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str) + +removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool +removeLibrarySearchPath hsc_env p = + iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p)) + +resolveObjs :: HscEnv -> IO SuccessFlag +resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs + +findSystemLibrary :: HscEnv -> String -> IO (Maybe String) +findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str) + + +-- ----------------------------------------------------------------------------- +-- Raw calls and messages + +-- | Send a 'Message' and receive the response from the iserv process +iservCall :: Binary a => IServInstance -> Message a -> IO a +iservCall iserv msg = + remoteCall (iservPipe iserv) msg + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +-- | Read a value from the iserv process +readIServ :: IServInstance -> Get a -> IO a +readIServ iserv get = + readPipe (iservPipe iserv) get + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +-- | Send a value to the iserv process +writeIServ :: IServInstance -> Put -> IO () +writeIServ iserv put = + writePipe (iservPipe iserv) put + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +handleIServFailure :: IServInstance -> SomeException -> IO a +handleIServFailure iserv e = do + let proc = iservProcess iserv + ex <- getProcessExitCode proc + case ex of + Just (ExitFailure n) -> + throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) + _ -> do + terminateProcess proc + _ <- waitForProcess proc + throw e + +-- | Spawn an external interpreter +spawnIServ :: IServConfig -> IO IServInstance +spawnIServ conf = do + iservConfTrace conf + let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp + ; return ph }) + (iservConfHook conf) + (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf) + (iservConfOpts conf) + lo_ref <- newIORef Nothing + return $ IServInstance + { iservPipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref } + , iservProcess = ph + , iservLookupSymbolCache = emptyUFM + , iservPendingFrees = [] + } + +-- | Stop the interpreter +stopInterp :: HscEnv -> IO () +stopInterp hsc_env = case hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp _ (IServ mstate)) -> + MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do + case state of + IServPending -> pure state -- already stopped + IServRunning i -> do + ex <- getProcessExitCode (iservProcess i) + if isJust ex + then pure () + else iservCall i Shutdown + pure IServPending + +runWithPipes :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) +#if defined(mingw32_HOST_OS) +foreign import ccall "io.h _close" + c__close :: CInt -> IO CInt + +foreign import ccall unsafe "io.h _get_osfhandle" + _get_osfhandle :: CInt -> IO CInt + +runWithPipes createProc prog opts = do + (rfd1, wfd1) <- createPipeFd -- we read on rfd1 + (rfd2, wfd2) <- createPipeFd -- we write on wfd2 + wh_client <- _get_osfhandle wfd1 + rh_client <- _get_osfhandle rfd2 + let args = show wh_client : show rh_client : opts + ph <- createProc (proc prog args) + rh <- mkHandle rfd1 + wh <- mkHandle wfd2 + return (ph, rh, wh) + where mkHandle :: CInt -> IO Handle + mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd) + +#else +runWithPipes createProc prog opts = do + (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 + (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 + setFdOption rfd1 CloseOnExec True + setFdOption wfd2 CloseOnExec True + let args = show wfd1 : show rfd2 : opts + ph <- createProc (proc prog args) + closeFd wfd1 + closeFd rfd2 + rh <- fdToHandle rfd1 + wh <- fdToHandle wfd2 + return (ph, rh, wh) +#endif + +-- ----------------------------------------------------------------------------- +{- Note [External GHCi pointers] + +We have the following ways to reference things in GHCi: + +HValue +------ + +HValue is a direct reference to a value in the local heap. Obviously +we cannot use this to refer to things in the external process. + + +RemoteRef +--------- + +RemoteRef is a StablePtr to a heap-resident value. When +-fexternal-interpreter is used, this value resides in the external +process's heap. RemoteRefs are mostly used to send pointers in +messages between GHC and iserv. + +A RemoteRef must be explicitly freed when no longer required, using +freeHValueRefs, or by attaching a finalizer with mkForeignHValue. + +To get from a RemoteRef to an HValue you can use 'wormholeRef', which +fails with an error message if -fexternal-interpreter is in use. + +ForeignRef +---------- + +A ForeignRef is a RemoteRef with a finalizer that will free the +'RemoteRef' when it is garbage collected. We mostly use ForeignHValue +on the GHC side. + +The finalizer adds the RemoteRef to the iservPendingFrees list in the +IServ record. The next call to iservCmd will free any RemoteRefs in +the list. It was done this way rather than calling iservCmd directly, +because I didn't want to have arbitrary threads calling iservCmd. In +principle it would probably be ok, but it seems less hairy this way. +-} + +-- | Creates a 'ForeignRef' that will automatically release the +-- 'RemoteRef' when it is no longer referenced. +mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a) +mkFinalizedHValue hsc_env rref = do + let hvref = toHValueRef rref + + free <- case hsc_interp hsc_env of + Nothing -> return (pure ()) +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> return (freeRemoteRef hvref) +#endif + Just (ExternalInterp _ (IServ i)) -> return $ modifyMVar_ i $ \state -> + case state of + IServPending {} -> pure state -- already shut down + IServRunning inst -> do + let !inst' = inst {iservPendingFrees = hvref:iservPendingFrees inst} + pure (IServRunning inst') + + mkForeignRef rref free + + +freeHValueRefs :: HscEnv -> [HValueRef] -> IO () +freeHValueRefs _ [] = return () +freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) + +-- | Convert a 'ForeignRef' to the value it references directly. This +-- only works when the interpreter is running in the same process as +-- the compiler, so it fails when @-fexternal-interpreter@ is on. +wormhole :: Interp -> ForeignRef a -> IO a +wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r) + +-- | Convert an 'RemoteRef' to the value it references directly. This +-- only works when the interpreter is running in the same process as +-- the compiler, so it fails when @-fexternal-interpreter@ is on. +wormholeRef :: Interp -> RemoteRef a -> IO a +#if defined(HAVE_INTERNAL_INTERPRETER) +wormholeRef InternalInterp _r = localRef _r +#endif +wormholeRef (ExternalInterp {}) _r + = throwIO (InstallationError + "this operation requires -fno-external-interpreter") + +-- ----------------------------------------------------------------------------- +-- Misc utils + +mkEvalOpts :: DynFlags -> Bool -> EvalOpts +mkEvalOpts dflags step = + EvalOpts + { useSandboxThread = gopt Opt_GhciSandbox dflags + , singleStep = step + , breakOnException = gopt Opt_BreakOnException dflags + , breakOnError = gopt Opt_BreakOnError dflags } + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a + +getModBreaks :: HomeModInfo -> ModBreaks +getModBreaks hmi + | Just linkable <- hm_linkable hmi, + [BCOs cbc _] <- linkableUnlinked linkable + = fromMaybe emptyModBreaks (bc_breaks cbc) + | otherwise + = emptyModBreaks -- probably object code + +-- | Interpreter uses Profiling way +interpreterProfiled :: Interp -> Bool +#if defined(HAVE_INTERNAL_INTERPRETER) +interpreterProfiled InternalInterp = hostIsProfiled +#endif +interpreterProfiled (ExternalInterp c _) = iservConfProfiled c + +-- | Interpreter uses Dynamic way +interpreterDynamic :: Interp -> Bool +#if defined(HAVE_INTERNAL_INTERPRETER) +interpreterDynamic InternalInterp = hostIsDynamic +#endif +interpreterDynamic (ExternalInterp c _) = iservConfDynamic c diff --git a/GHC/Runtime/Interpreter/Types.hs b/GHC/Runtime/Interpreter/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Types.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} + +-- | Types used by the runtime interpreter +module GHC.Runtime.Interpreter.Types + ( Interp(..) + , IServ(..) + , IServInstance(..) + , IServConfig(..) + , IServState(..) + ) +where + +import GHC.Prelude + +import GHCi.RemoteTypes +import GHCi.Message ( Pipe ) +import GHC.Types.Unique.FM +import GHC.Data.FastString ( FastString ) +import Foreign + +import Control.Concurrent +import System.Process ( ProcessHandle, CreateProcess ) + +-- | Runtime interpreter +data Interp + = ExternalInterp !IServConfig !IServ -- ^ External interpreter +#if defined(HAVE_INTERNAL_INTERPRETER) + | InternalInterp -- ^ Internal interpreter +#endif + +-- | External interpreter +-- +-- The external interpreter is spawned lazily (on first use) to avoid slowing +-- down sessions that don't require it. The contents of the MVar reflects the +-- state of the interpreter (running or not). +newtype IServ = IServ (MVar IServState) + +-- | State of an external interpreter +data IServState + = IServPending -- ^ Not spawned yet + | IServRunning !IServInstance -- ^ Running + +-- | Configuration needed to spawn an external interpreter +data IServConfig = IServConfig + { iservConfProgram :: !String -- ^ External program to run + , iservConfOpts :: ![String] -- ^ Command-line options + , iservConfProfiled :: !Bool -- ^ Use Profiling way + , iservConfDynamic :: !Bool -- ^ Use Dynamic way + , iservConfHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) -- ^ Hook + , iservConfTrace :: IO () -- ^ Trace action executed after spawn + } + +-- | External interpreter instance +data IServInstance = IServInstance + { iservPipe :: !Pipe + , iservProcess :: !ProcessHandle + , iservLookupSymbolCache :: !(UniqFM FastString (Ptr ())) + , iservPendingFrees :: ![HValueRef] + -- ^ Values that need to be freed before the next command is sent. + -- Threads can append values to this list asynchronously (by modifying the + -- IServ state MVar). + } + diff --git a/GHC/Runtime/Linker.hs b/GHC/Runtime/Linker.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Linker.hs @@ -0,0 +1,1780 @@ +{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- | The dynamic linker for GHCi. +-- +-- This module deals with the top-level issues of dynamic linking, +-- calling the object-code linker and the byte-code linker where +-- necessary. +module GHC.Runtime.Linker + ( getHValue + , showLinkerState + , linkExpr + , linkDecls + , unload + , withExtendedLinkEnv + , extendLinkEnv + , deleteFromLinkEnv + , extendLoadedPkgs + , linkPackages + , initDynLinker + , linkModule + , linkCmdLineLibs + , uninitializedLinker + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types +import GHCi.RemoteTypes +import GHC.Iface.Load +import GHC.ByteCode.Linker +import GHC.ByteCode.Asm +import GHC.ByteCode.Types +import GHC.Tc.Utils.Monad +import GHC.Unit.State as Packages +import GHC.Driver.Phases +import GHC.Driver.Finder +import GHC.Driver.Types +import GHC.Driver.Ways +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Unit.Module +import GHC.Data.List.SetOps +import GHC.Runtime.Linker.Types (DynLinker(..), PersistentLinkerState(..)) +import GHC.Driver.Session +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Types.SrcLoc +import qualified GHC.Data.Maybe as Maybes +import GHC.Types.Unique.DSet +import GHC.Data.FastString +import GHC.Platform +import GHC.SysTools +import GHC.SysTools.FileCleanup + +-- Standard libraries +import Control.Monad + +import qualified Data.Set as Set +import Data.Char (isSpace) +import Data.Function ((&)) +import Data.IORef +import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) +import Data.Maybe +import Control.Concurrent.MVar +import qualified Control.Monad.Catch as MC + +import System.FilePath +import System.Directory +import System.IO.Unsafe +import System.Environment (lookupEnv) + +#if defined(mingw32_HOST_OS) +import System.Win32.Info (getSystemDirectory) +#endif + +import GHC.Utils.Exception + +{- ********************************************************************** + + The Linker's state + + ********************************************************************* -} + +{- +The persistent linker state *must* match the actual state of the +C dynamic linker at all times. + +The MVar used to hold the PersistentLinkerState contains a Maybe +PersistentLinkerState. The MVar serves to ensure mutual exclusion between +multiple loaded copies of the GHC library. The Maybe may be Nothing to +indicate that the linker has not yet been initialised. + +The PersistentLinkerState maps Names to actual closures (for +interpreted code only), for use during linking. +-} + +uninitializedLinker :: IO DynLinker +uninitializedLinker = + newMVar Nothing >>= (pure . DynLinker) + +uninitialised :: a +uninitialised = panic "Dynamic linker not initialised" + +modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO () +modifyPLS_ dl f = + modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised) + +modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a +modifyPLS dl f = + modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised) + where fmapFst f = fmap (\(x, y) -> (f x, y)) + +readPLS :: DynLinker -> IO PersistentLinkerState +readPLS dl = + (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl) + +modifyMbPLS_ + :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () +modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f + +emptyPLS :: PersistentLinkerState +emptyPLS = PersistentLinkerState + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , pkgs_loaded = init_pkgs + , bcos_loaded = [] + , objs_loaded = [] + , temp_sos = [] + } + -- Packages that don't need loading, because the compiler + -- shares them with the interpreted program. + -- + -- The linker's symbol table is populated with RTS symbols using an + -- explicit list. See rts/Linker.c for details. + where init_pkgs = [rtsUnitId] + +extendLoadedPkgs :: DynLinker -> [UnitId] -> IO () +extendLoadedPkgs dl pkgs = + modifyPLS_ dl $ \s -> + return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } + +extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO () +extendLinkEnv dl new_bindings = + modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do + let new_ce = extendClosureEnv closure_env new_bindings + return $! pls{ closure_env = new_ce } + -- strictness is important for not retaining old copies of the pls + +deleteFromLinkEnv :: DynLinker -> [Name] -> IO () +deleteFromLinkEnv dl to_remove = + modifyPLS_ dl $ \pls -> do + let ce = closure_env pls + let new_ce = delListFromNameEnv ce to_remove + return pls{ closure_env = new_ce } + +-- | Get the 'HValue' associated with the given name. +-- +-- May cause loading the module that contains the name. +-- +-- Throws a 'ProgramError' if loading fails or the name cannot be found. +getHValue :: HscEnv -> Name -> IO ForeignHValue +getHValue hsc_env name = do + let dl = hsc_dynLinker hsc_env + initDynLinker hsc_env + pls <- modifyPLS dl $ \pls -> do + if (isExternalName name) then do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan + [nameModule name] + if (failed ok) then throwGhcExceptionIO (ProgramError "") + else return (pls', pls') + else + return (pls, pls) + case lookupNameEnv (closure_env pls) name of + Just (_,aa) -> return aa + Nothing + -> ASSERT2(isExternalName name, ppr name) + do let sym_to_find = nameToCLabel name "closure" + m <- lookupClosure hsc_env (unpackFS sym_to_find) + case m of + Just hvref -> mkFinalizedHValue hsc_env hvref + Nothing -> linkFail "GHC.Runtime.Linker.getHValue" + (unpackFS sym_to_find) + +linkDependencies :: HscEnv -> PersistentLinkerState + -> SrcSpan -> [Module] + -> IO (PersistentLinkerState, SuccessFlag) +linkDependencies hsc_env pls span needed_mods = do +-- initDynLinker (hsc_dflags hsc_env) dl + let hpt = hsc_HPT hsc_env + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay hsc_env span + + -- Find what packages and linkables are required + (lnks, pkgs) <- getLinkDeps hsc_env hpt pls + maybe_normal_osuf span needed_mods + + -- Link the packages and modules required + pls1 <- linkPackages' hsc_env pkgs pls + linkModules hsc_env pls1 lnks + + +-- | Temporarily extend the linker state. + +withExtendedLinkEnv :: (ExceptionMonad m) => + DynLinker -> [(Name,ForeignHValue)] -> m a -> m a +withExtendedLinkEnv dl new_env action + = MC.bracket (liftIO $ extendLinkEnv dl new_env) + (\_ -> reset_old_env) + (\_ -> action) + where + -- Remember that the linker state might be side-effected + -- during the execution of the IO action, and we don't want to + -- lose those changes (we might have linked a new module or + -- package), so the reset action only removes the names we + -- added earlier. + reset_old_env = liftIO $ do + modifyPLS_ dl $ \pls -> + let cur = closure_env pls + new = delListFromNameEnv cur (map fst new_env) + in return pls{ closure_env = new } + + +-- | Display the persistent linker state. +showLinkerState :: DynLinker -> IO SDoc +showLinkerState dl + = do pls <- readPLS dl + return $ withPprStyle defaultDumpStyle + (vcat [text "----- Linker state -----", + text "Pkgs:" <+> ppr (pkgs_loaded pls), + text "Objs:" <+> ppr (objs_loaded pls), + text "BCOs:" <+> ppr (bcos_loaded pls)]) + + +{- ********************************************************************** + + Initialisation + + ********************************************************************* -} + +-- | Initialise the dynamic linker. This entails +-- +-- a) Calling the C initialisation procedure, +-- +-- b) Loading any packages specified on the command line, +-- +-- c) Loading any packages specified on the command line, now held in the +-- @-l@ options in @v_Opt_l@, +-- +-- d) Loading any @.o\/.dll@ files specified on the command line, now held +-- in @ldInputs@, +-- +-- e) Loading any MacOS frameworks. +-- +-- NOTE: This function is idempotent; if called more than once, it does +-- nothing. This is useful in Template Haskell, where we call it before +-- trying to link. +-- +initDynLinker :: HscEnv -> IO () +initDynLinker hsc_env = do + let dl = hsc_dynLinker hsc_env + modifyMbPLS_ dl $ \pls -> do + case pls of + Just _ -> return pls + Nothing -> Just <$> reallyInitDynLinker hsc_env + +reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState +reallyInitDynLinker hsc_env = do + -- Initialise the linker state + let dflags = hsc_dflags hsc_env + pls0 = emptyPLS + + -- (a) initialise the C dynamic linker + initObjLinker hsc_env + + -- (b) Load packages from the command-line (Note [preload packages]) + pls <- linkPackages' hsc_env (preloadUnits (unitState dflags)) pls0 + + -- steps (c), (d) and (e) + linkCmdLineLibs' hsc_env pls + + +linkCmdLineLibs :: HscEnv -> IO () +linkCmdLineLibs hsc_env = do + let dl = hsc_dynLinker hsc_env + initDynLinker hsc_env + modifyPLS_ dl $ \pls -> do + linkCmdLineLibs' hsc_env pls + +linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState +linkCmdLineLibs' hsc_env pls = + do + let dflags@(DynFlags { ldInputs = cmdline_ld_inputs + , libraryPaths = lib_paths_base}) + = hsc_dflags hsc_env + + -- (c) Link libraries from the command-line + let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] + + -- On Windows we want to add libpthread by default just as GCC would. + -- However because we don't know the actual name of pthread's dll we + -- need to defer this to the locateLib call so we can't initialize it + -- inside of the rts. Instead we do it here to be able to find the + -- import library for pthreads. See #13210. + let platform = targetPlatform dflags + os = platformOS platform + minus_ls = case os of + OSMinGW32 -> "pthread" : minus_ls_1 + _ -> minus_ls_1 + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags os + + lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base + + maybePutStrLn dflags "Search directories (user):" + maybePutStr dflags (unlines $ map (" "++) lib_paths_env) + maybePutStrLn dflags "Search directories (gcc):" + maybePutStr dflags (unlines $ map (" "++) gcc_paths) + + libspecs + <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls + + -- (d) Link .o files from the command-line + classified_ld_inputs <- mapM (classifyLdInput dflags) + [ f | FileOption _ f <- cmdline_ld_inputs ] + + -- (e) Link any MacOS frameworks + let platform = targetPlatform dflags + let (framework_paths, frameworks) = + if platformUsesFrameworks platform + then (frameworkPaths dflags, cmdlineFrameworks dflags) + else ([],[]) + + -- Finally do (c),(d),(e) + let cmdline_lib_specs = catMaybes classified_ld_inputs + ++ libspecs + ++ map Framework frameworks + if null cmdline_lib_specs then return pls + else do + + -- Add directories to library search paths, this only has an effect + -- on Windows. On Unix OSes this function is a NOP. + let all_paths = let paths = takeDirectory (pgm_c dflags) + : framework_paths + ++ lib_paths_base + ++ [ takeDirectory dll | DLLPath dll <- libspecs ] + in nub $ map normalise paths + let lib_paths = nub $ lib_paths_base ++ gcc_paths + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env + + let merged_specs = mergeStaticObjects cmdline_lib_specs + pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls + merged_specs + + maybePutStr dflags "final link ... " + ok <- resolveObjs hsc_env + + -- DLLs are loaded, reset the search paths + mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache + + if succeeded ok then maybePutStrLn dflags "done" + else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") + + return pls1 + +-- | Merge runs of consecutive of 'Objects'. This allows for resolution of +-- cyclic symbol references when dynamically linking. Specifically, we link +-- together all of the static objects into a single shared object, avoiding +-- the issue we saw in #13786. +mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] +mergeStaticObjects specs = go [] specs + where + go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] + go accum (Objects objs : rest) = go (objs ++ accum) rest + go accum@(_:_) rest = Objects (reverse accum) : go [] rest + go [] (spec:rest) = spec : go [] rest + go [] [] = [] + +{- Note [preload packages] + +Why do we need to preload packages from the command line? This is an +explanation copied from #2437: + +I tried to implement the suggestion from #3560, thinking it would be +easy, but there are two reasons we link in packages eagerly when they +are mentioned on the command line: + + * So that you can link in extra object files or libraries that + depend on the packages. e.g. ghc -package foo -lbar where bar is a + C library that depends on something in foo. So we could link in + foo eagerly if and only if there are extra C libs or objects to + link in, but.... + + * Haskell code can depend on a C function exported by a package, and + the normal dependency tracking that TH uses can't know about these + dependencies. The test ghcilink004 relies on this, for example. + +I conclude that we need two -package flags: one that says "this is a +package I want to make available", and one that says "this is a +package I want to link in eagerly". Would that be too complicated for +users? +-} + +classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput dflags f + | isObjectFilename platform f = return (Just (Objects [f])) + | isDynLibFilename platform f = return (Just (DLLPath f)) + | otherwise = do + putLogMsg dflags NoReason SevInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) + return Nothing + where platform = targetPlatform dflags + +preloadLib + :: HscEnv -> [String] -> [String] -> PersistentLinkerState + -> LibrarySpec -> IO PersistentLinkerState +preloadLib hsc_env lib_paths framework_paths pls lib_spec = do + maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + case lib_spec of + Objects static_ishs -> do + (b, pls1) <- preload_statics lib_paths static_ishs + maybePutStrLn dflags (if b then "done" else "not found") + return pls1 + + Archive static_ish -> do + b <- preload_static_archive lib_paths static_ish + maybePutStrLn dflags (if b then "done" else "not found") + return pls + + DLL dll_unadorned -> do + maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned) + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm | platformOS platform /= OSDarwin -> + preloadFailed mm lib_paths lib_spec + Just mm | otherwise -> do + -- As a backup, on Darwin, try to also load a .so file + -- since (apparently) some things install that way - see + -- ticket #8770. + let libfile = ("lib" ++ dll_unadorned) <.> "so" + err2 <- loadDLL hsc_env libfile + case err2 of + Nothing -> maybePutStrLn dflags "done" + Just _ -> preloadFailed mm lib_paths lib_spec + return pls + + DLLPath dll_path -> do + do maybe_errstr <- loadDLL hsc_env dll_path + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm lib_paths lib_spec + return pls + + Framework framework -> + if platformUsesFrameworks (targetPlatform dflags) + then do maybe_errstr <- loadFramework hsc_env framework_paths framework + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm framework_paths lib_spec + return pls + else throwGhcExceptionIO (ProgramError "preloadLib Framework") + + where + dflags = hsc_dflags hsc_env + + platform = targetPlatform dflags + + preloadFailed :: String -> [String] -> LibrarySpec -> IO () + preloadFailed sys_errmsg paths spec + = do maybePutStr dflags "failed.\n" + throwGhcExceptionIO $ + CmdLineError ( + "user specified .o/.so/.DLL could not be loaded (" + ++ sys_errmsg ++ ")\nWhilst trying to load: " + ++ showLS spec ++ "\nAdditional directories searched:" + ++ (if null paths then " (none)" else + intercalate "\n" (map (" "++) paths))) + + -- Not interested in the paths in the static case. + preload_statics _paths names + = do b <- or <$> mapM doesFileExist names + if not b then return (False, pls) + else if hostIsDynamic + then do pls1 <- dynLoadObjs hsc_env pls names + return (True, pls1) + else do mapM_ (loadObj hsc_env) names + return (True, pls) + + preload_static_archive _paths name + = do b <- doesFileExist name + if not b then return False + else do if hostIsDynamic + then throwGhcExceptionIO $ + CmdLineError dynamic_msg + else loadArchive hsc_env name + return True + where + dynamic_msg = unlines + [ "User-specified static library could not be loaded (" + ++ name ++ ")" + , "Loading static libraries is not supported in this configuration." + , "Try using a dynamic library instead." + ] + + +{- ********************************************************************** + + Link a byte-code expression + + ********************************************************************* -} + +-- | Link a single expression, /including/ first linking packages and +-- modules that this expression depends on. +-- +-- Raises an IO exception ('ProgramError') if it can't find a compiled +-- version of the dependents to link. +-- +linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue +linkExpr hsc_env span root_ul_bco + = do { + -- Initialise the linker (if it's not been done already) + ; initDynLinker hsc_env + + -- Extract the DynLinker value for passing into required places + ; let dl = hsc_dynLinker hsc_env + + -- Take lock for the actual work. + ; modifyPLS dl $ \pls0 -> do { + + -- Link the packages and modules required + ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods + ; if failed ok then + throwGhcExceptionIO (ProgramError "") + else do { + + -- Link the expression itself + let ie = itbl_env pls + ce = closure_env pls + + -- Link the necessary packages and linkables + + ; let nobreakarray = error "no break array" + bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] + ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco + ; [root_hvref] <- createBCOs hsc_env [resolved] + ; fhv <- mkFinalizedHValue hsc_env root_hvref + ; return (pls, fhv) + }}} + where + free_names = uniqDSetToList (bcoFreeNames root_ul_bco) + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + +dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) + + +checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay hsc_env srcspan + | Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing + -- with -fexternal-interpreter we load the .o files, whatever way + -- they were built. If they were built for a non-std way, then + -- we will use the appropriate variant of the iserv binary to load them. + + | hostFullWays == targetFullWays = return Nothing + -- Only if we are compiling with the same ways as GHC is built + -- with, can we dynamically load those object files. (see #3604) + + | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null targetFullWays) + = failNonStd (hsc_dflags hsc_env) srcspan + + | otherwise = return (Just (hostWayTag ++ "o")) + where + targetFullWays = Set.filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env)) + hostWayTag = case waysTag hostFullWays of + "" -> "" + tag -> tag ++ "_" + +normalObjectSuffix :: String +normalObjectSuffix = phaseInputExt StopLn + +failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) +failNonStd dflags srcspan = dieWith dflags srcspan $ + text "Cannot load" <+> compWay <+> + text "objects when GHC is built" <+> ghciWay $$ + text "To fix this, either:" $$ + text " (1) Use -fexternal-interpreter, or" $$ + text " (2) Build the program twice: once" <+> + ghciWay <> text ", and then" $$ + text " with" <+> compWay <+> + text "using -osuf to set a different object file suffix." + where compWay + | WayDyn `elem` ways dflags = text "-dynamic" + | WayProf `elem` ways dflags = text "-prof" + | otherwise = text "normal" + ghciWay + | hostIsDynamic = text "with -dynamic" + | hostIsProfiled = text "with -prof" + | otherwise = text "the normal way" + +getLinkDeps :: HscEnv -> HomePackageTable + -> PersistentLinkerState + -> Maybe FilePath -- replace object suffices? + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO ([Linkable], [UnitId]) -- ... then link these first +-- Fails with an IO exception if it can't find enough files + +getLinkDeps hsc_env hpt pls replace_osuf span mods +-- Find all the packages and linkables that a set of modules depends on + = do { + -- 1. Find the dependent home-pkg-modules/packages from each iface + -- (omitting modules from the interactive package, which is already linked) + ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) + emptyUniqDSet emptyUniqDSet; + + ; let { + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + + linked_mods = map (moduleName.linkableModule) + (objs_loaded pls ++ bcos_loaded pls) } + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot + -- compilation) we may need to use maybe_getFileLinkable + ; let { osuf = objectSuf dflags } + ; lnks_needed <- mapM (get_linkable osuf) mods_needed + + ; return (lnks_needed, pkgs_needed) } + where + dflags = hsc_dflags hsc_env + this_pkg = homeUnit dflags + + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqDSet ModuleName -- accum. module dependencies + -> UniqDSet UnitId -- accum. package dependencies + -> IO ([ModuleName], [UnitId]) -- result + follow_deps [] acc_mods acc_pkgs + = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) + follow_deps (mod:mods) acc_mods acc_pkgs + = do + mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ + loadInterface msg mod (ImportByUser NotBoot) + iface <- case mb_iface of + Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Maybes.Succeeded iface -> return iface + + when (mi_boot iface == IsBoot) $ link_boot_mod_error mod + + let + pkg = moduleUnit mod + deps = mi_deps iface + + pkg_deps = dep_pkgs deps + (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $ + \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) -> + m & case is_boot of + IsBoot -> Left + NotBoot -> Right + + boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps + acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps + -- + if pkg /= this_pkg + then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) + else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) + acc_mods' acc_pkgs' + where + msg = text "need to link module" <+> ppr mod <+> + text "due to use of Template Haskell" + + + link_boot_mod_error mod = + throwGhcExceptionIO (ProgramError (showSDoc dflags ( + text "module" <+> ppr mod <+> + text "cannot be linked; it is only available as a boot module"))) + + no_obj :: Outputable a => a -> IO b + no_obj mod = dieWith dflags span $ + text "cannot find object file for module " <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = text "while linking an interpreted expression" + + -- This one is a build-system bug + + get_linkable osuf mod_name -- A home-package module + | Just mod_info <- lookupHpt hpt mod_name + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + | otherwise + = do -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod + _ -> no_obj mod_name + where + found loc mod = do { + -- ...and then find the linkable for it + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk + }} + + adjust_linkable lnk + | Just new_osuf <- replace_osuf = do + new_uls <- mapM (adjust_ul new_osuf) + (linkableUnlinked lnk) + return lnk{ linkableUnlinked=new_uls } + | otherwise = + return lnk + + adjust_ul new_osuf (DotO file) = do + MASSERT(osuf `isSuffixOf` file) + let file_base = fromJust (stripExtension osuf file) + new_file = file_base <.> new_osuf + ok <- doesFileExist new_file + if (not ok) + then dieWith dflags span $ + text "cannot find object file " + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) + adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) + adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) + adjust_ul _ l@(BCOs {}) = return l + + + +{- ********************************************************************** + + Loading a Decls statement + + ********************************************************************* -} + +linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () +linkDecls hsc_env span cbc@CompiledByteCode{..} = do + -- Initialise the linker (if it's not been done already) + initDynLinker hsc_env + + -- Extract the DynLinker for passing into required places + let dl = hsc_dynLinker hsc_env + + -- Take lock for the actual work. + modifyPLS dl $ \pls0 -> do + + -- Link the packages and modules required + (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods + if failed ok + then throwGhcExceptionIO (ProgramError "") + else do + + -- Link the expression itself + let ie = plusNameEnv (itbl_env pls) bc_itbls + ce = closure_env pls + + -- Link the necessary packages and linkables + new_bindings <- linkSomeBCOs hsc_env ie ce [cbc] + nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings + let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs + , itbl_env = ie } + return (pls2, ()) + where + free_names = uniqDSetToList $ + foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + +{- ********************************************************************** + + Loading a single module + + ********************************************************************* -} + +linkModule :: HscEnv -> Module -> IO () +linkModule hsc_env mod = do + initDynLinker hsc_env + let dl = hsc_dynLinker hsc_env + modifyPLS_ dl $ \pls -> do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] + if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") + else return pls' + +{- ********************************************************************** + + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules + + ********************************************************************* -} + +linkModules :: HscEnv -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +linkModules hsc_env pls linkables + = mask_ $ do -- don't want to be interrupted by ^C in here + + let (objs, bcos) = partition isObjectLinkable + (concatMap partitionLinkable linkables) + + -- Load objects first; they can't depend on BCOs + (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs + + if failed ok_flag then + return (pls1, Failed) + else do + pls2 <- dynLinkBCOs hsc_env pls1 bcos + return (pls2, Succeeded) + + +-- HACK to support f-x-dynamic in the interpreter; no other purpose +partitionLinkable :: Linkable -> [Linkable] +partitionLinkable li + = let li_uls = linkableUnlinked li + li_uls_obj = filter isObject li_uls + li_uls_bco = filter isInterpretable li_uls + in + case (li_uls_obj, li_uls_bco) of + (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, + li {linkableUnlinked=li_uls_bco}] + _ -> [li] + +findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable +findModuleLinkable_maybe lis mod + = case [LM time nm us | LM time nm us <- lis, nm == mod] of + [] -> Nothing + [li] -> Just li + _ -> pprPanic "findModuleLinkable" (ppr mod) + +linkableInSet :: Linkable -> [Linkable] -> Bool +linkableInSet l objs_loaded = + case findModuleLinkable_maybe objs_loaded (linkableModule l) of + Nothing -> False + Just m -> linkableTime l == linkableTime m + + +{- ********************************************************************** + + The object-code linker + + ********************************************************************* -} + +dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +dynLinkObjs hsc_env pls objs = do + -- Load the object files and link them + let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + pls1 = pls { objs_loaded = objs_loaded' } + unlinkeds = concatMap linkableUnlinked new_objs + wanted_objs = map nameOfObject unlinkeds + + if interpreterDynamic (hscInterp hsc_env) + then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs + return (pls2, Succeeded) + else do mapM_ (loadObj hsc_env) wanted_objs + + -- Link them all together + ok <- resolveObjs hsc_env + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then do + return (pls1, Succeeded) + else do + pls2 <- unload_wkr hsc_env [] pls1 + return (pls2, Failed) + + +dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath] + -> IO PersistentLinkerState +dynLoadObjs _ pls [] = return pls +dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do + let dflags = hsc_dflags hsc_env + let platform = targetPlatform dflags + let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] + let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] + (soFile, libPath , libName) <- + newTempLibName dflags TFL_CurrentModule (soExt platform) + let + dflags2 = dflags { + -- We don't want the original ldInputs in + -- (they're already linked in), but we do want + -- to link against previous dynLoadObjs + -- libraries if there were any, so that the linker + -- can resolve dependencies when it loads this + -- library. + ldInputs = + concatMap (\l -> [ Option ("-l" ++ l) ]) + (nub $ snd <$> temp_sos) + ++ concatMap (\lp -> Option ("-L" ++ lp) + : if useXLinkerRPath dflags (platformOS platform) + then [ Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ] + else []) + (nub $ fst <$> temp_sos) + ++ concatMap + (\lp -> Option ("-L" ++ lp) + : if useXLinkerRPath dflags (platformOS platform) + then [ Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ] + else []) + minus_big_ls + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + ++ map (\l -> Option ("-l" ++ l)) minus_ls, + -- Add -l options and -L options from dflags. + -- + -- When running TH for a non-dynamic way, we still + -- need to make -l flags to link against the dynamic + -- libraries, so we need to add WayDyn to ways. + -- + -- Even if we're e.g. profiling, we still want + -- the vanilla dynamic libraries, so we set the + -- ways / build tag to be just WayDyn. + ways = Set.singleton WayDyn, + outputFile = Just soFile + } + -- link all "loaded packages" so symbols in those can be resolved + -- Note: We are loading packages with local scope, so to see the + -- symbols in this link we must link all loaded packages again. + linkDynLib dflags2 objs pkgs_loaded + + -- if we got this far, extend the lifetime of the library file + changeTempFilesLifetime dflags TFL_GhcSession [soFile] + m <- loadDLL hsc_env soFile + case m of + Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } + Just err -> linkFail msg err + where + msg = "GHC.Runtime.Linker.dynLoadObjs: Loading temp shared object failed" + +rmDupLinkables :: [Linkable] -- Already loaded + -> [Linkable] -- New linkables + -> ([Linkable], -- New loaded set (including new ones) + [Linkable]) -- New linkables (excluding dups) +rmDupLinkables already ls + = go already [] ls + where + go already extras [] = (already, extras) + go already extras (l:ls) + | linkableInSet l already = go already extras ls + | otherwise = go (l:already) (l:extras) ls + +{- ********************************************************************** + + The byte-code linker + + ********************************************************************* -} + + +dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable] + -> IO PersistentLinkerState +dynLinkBCOs hsc_env pls bcos = do + + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + pls1 = pls { bcos_loaded = bcos_loaded' } + unlinkeds :: [Unlinked] + unlinkeds = concatMap linkableUnlinked new_bcos + + cbcs :: [CompiledByteCode] + cbcs = map byteCodeOfObject unlinkeds + + + ies = map bc_itbls cbcs + gce = closure_env pls + final_ie = foldr plusNameEnv (itbl_env pls) ies + + names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs + + -- We only want to add the external ones to the ClosureEnv + let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs + + -- Immediately release any HValueRefs we're not going to add + freeHValueRefs hsc_env (map snd to_drop) + -- Wrap finalizers on the ones we want to keep + new_binds <- makeForeignNamedHValueRefs hsc_env to_add + + return pls1 { closure_env = extendClosureEnv gce new_binds, + itbl_env = final_ie } + +-- Link a bunch of BCOs and return references to their values +linkSomeBCOs :: HscEnv + -> ItblEnv + -> ClosureEnv + -> [CompiledByteCode] + -> IO [(Name,HValueRef)] + -- The returned HValueRefs are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + +linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods [] + where + fun CompiledByteCode{..} inner accum = + case bc_breaks of + Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) + Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> + inner ((breakarray, bc_bcos) : accum) + + do_link [] = return [] + do_link mods = do + let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] + names = map (unlinkedBCOName . snd) flat + bco_ix = mkNameEnv (zip names [0..]) + resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco + | (breakarray, bco) <- flat ] + hvrefs <- createBCOs hsc_env resolved + return (zip names hvrefs) + +-- | Useful to apply to the result of 'linkSomeBCOs' +makeForeignNamedHValueRefs + :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] +makeForeignNamedHValueRefs hsc_env bindings = + mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings + +{- ********************************************************************** + + Unload some object modules + + ********************************************************************* -} + +-- --------------------------------------------------------------------------- +-- | Unloading old objects ready for a new compilation sweep. +-- +-- The compilation manager provides us with a list of linkables that it +-- considers \"stable\", i.e. won't be recompiled this time around. For +-- each of the modules current linked in memory, +-- +-- * if the linkable is stable (and it's the same one -- the user may have +-- recompiled the module on the side), we keep it, +-- +-- * otherwise, we unload it. +-- +-- * we also implicitly unload all temporary bindings at this point. +-- +unload :: HscEnv + -> [Linkable] -- ^ The linkables to *keep*. + -> IO () +unload hsc_env linkables + = mask_ $ do -- mask, so we're safe from Ctrl-C in here + + -- Initialise the linker (if it's not been done already) + initDynLinker hsc_env + + -- Extract DynLinker for passing into required places + let dl = hsc_dynLinker hsc_env + + new_pls + <- modifyPLS dl $ \pls -> do + pls1 <- unload_wkr hsc_env linkables pls + return (pls1, pls1) + + let dflags = hsc_dflags hsc_env + debugTraceMsg dflags 3 $ + text "unload: retaining objs" <+> ppr (objs_loaded new_pls) + debugTraceMsg dflags 3 $ + text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) + return () + +unload_wkr :: HscEnv + -> [Linkable] -- stable linkables + -> PersistentLinkerState + -> IO PersistentLinkerState +-- Does the core unload business +-- (the wrapper blocks exceptions and deals with the PLS get and put) + +unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do + -- NB. careful strictness here to avoid keeping the old PLS when + -- we're unloading some code. -fghci-leak-check with the tests in + -- testsuite/ghci can detect space leaks here. + + let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables + + discard keep l = not (linkableInSet l keep) + + (objs_to_unload, remaining_objs_loaded) = + partition (discard objs_to_keep) objs_loaded + (bcos_to_unload, remaining_bcos_loaded) = + partition (discard bcos_to_keep) bcos_loaded + + mapM_ unloadObjs objs_to_unload + mapM_ unloadObjs bcos_to_unload + + -- If we unloaded any object files at all, we need to purge the cache + -- of lookupSymbol results. + when (not (null (objs_to_unload ++ + filter (not . null . linkableObjs) bcos_to_unload))) $ + purgeLookupSymbolCache hsc_env + + let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded + + -- Note that we want to remove all *local* + -- (i.e. non-isExternal) names too (these are the + -- temporary bindings from the command line). + keep_name (n,_) = isExternalName n && + nameModule n `elemModuleSet` bcos_retained + + itbl_env' = filterNameEnv keep_name itbl_env + closure_env' = filterNameEnv keep_name closure_env + + !new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = remaining_bcos_loaded, + objs_loaded = remaining_objs_loaded } + + return new_pls + where + unloadObjs :: Linkable -> IO () + unloadObjs lnk + -- The RTS's PEi386 linker currently doesn't support unloading. + | isWindowsHost = return () + + | hostIsDynamic = return () + -- We don't do any cleanup when linking objects with the + -- dynamic linker. Doing so introduces extra complexity for + -- not much benefit. + + | otherwise + = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] + -- The components of a BCO linkable may contain + -- dot-o files. Which is very confusing. + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + +{- ********************************************************************** + + Loading packages + + ********************************************************************* -} + +data LibrarySpec + = Objects [FilePath] -- Full path names of set of .o files, including trailing .o + -- We allow batched loading to ensure that cyclic symbol + -- references can be resolved (see #13786). + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. + + | Archive FilePath -- Full path name of a .a file, including trailing .a + + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" + -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- suffixes platform-dependently + + | DLLPath FilePath -- Absolute or relative pathname to a dynamic library + -- (ends with .dll or .so). + + | Framework String -- Only used for darwin, but does no harm + +instance Outputable LibrarySpec where + ppr (Objects objs) = text "Objects" <+> ppr objs + ppr (Archive a) = text "Archive" <+> text a + ppr (DLL s) = text "DLL" <+> text s + ppr (DLLPath f) = text "DLLPath" <+> text f + ppr (Framework s) = text "Framework" <+> text s + +-- If this package is already part of the GHCi binary, we'll already +-- have the right DLLs for this package loaded, so don't try to +-- load them again. +-- +-- But on Win32 we must load them 'again'; doing so is a harmless no-op +-- as far as the loader is concerned, but it does initialise the list +-- of DLL handles that rts/Linker.c maintains, and that in turn is +-- used by lookupSymbol. So we must call addDLL for each library +-- just to get the DLL handle into the list. +partOfGHCi :: [PackageName] +partOfGHCi + | isWindowsHost || isDarwinHost = [] + | otherwise = map (PackageName . mkFastString) + ["base", "template-haskell", "editline"] + +showLS :: LibrarySpec -> String +showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" +showLS (Archive nm) = "(static archive) " ++ nm +showLS (DLL nm) = "(dynamic) " ++ nm +showLS (DLLPath nm) = "(dynamic) " ++ nm +showLS (Framework nm) = "(framework) " ++ nm + +-- | Link exactly the specified packages, and their dependents (unless of +-- course they are already linked). The dependents are linked +-- automatically, and it doesn't matter what order you specify the input +-- packages. +-- +linkPackages :: HscEnv -> [UnitId] -> IO () +-- NOTE: in fact, since each module tracks all the packages it depends on, +-- we don't really need to use the package-config dependencies. +-- +-- However we do need the package-config stuff (to find aux libs etc), +-- and following them lets us load libraries in the right order, which +-- perhaps makes the error message a bit more localised if we get a link +-- failure. So the dependency walking code is still here. + +linkPackages hsc_env new_pkgs = do + -- It's probably not safe to try to load packages concurrently, so we take + -- a lock. + initDynLinker hsc_env + let dl = hsc_dynLinker hsc_env + modifyPLS_ dl $ \pls -> do + linkPackages' hsc_env new_pkgs pls + +linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState + -> IO PersistentLinkerState +linkPackages' hsc_env new_pks pls = do + pkgs' <- link (pkgs_loaded pls) new_pks + return $! pls { pkgs_loaded = pkgs' } + where + dflags = hsc_dflags hsc_env + pkgstate = unitState dflags + + link :: [UnitId] -> [UnitId] -> IO [UnitId] + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs + + link_one pkgs new_pkg + | new_pkg `elem` pkgs -- Already linked + = return pkgs + + | Just pkg_cfg <- lookupUnitId pkgstate new_pkg + = do { -- Link dependents first + pkgs' <- link pkgs (unitDepends pkg_cfg) + -- Now link the package itself + ; linkPackage hsc_env pkg_cfg + ; return (new_pkg : pkgs') } + + | otherwise + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) + + +linkPackage :: HscEnv -> UnitInfo -> IO () +linkPackage hsc_env pkg + = do + let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + is_dyn = interpreterDynamic (hscInterp hsc_env) + dirs | is_dyn = Packages.unitLibraryDynDirs pkg + | otherwise = Packages.unitLibraryDirs pkg + + let hs_libs = Packages.unitLibraries pkg + -- The FFI GHCi import lib isn't needed as + -- GHC.Runtime.Linker + rts/Linker.c link the + -- interpreted references to FFI to the compiled FFI. + -- We therefore filter it out so that we don't get + -- duplicate symbol errors. + hs_libs' = filter ("HSffi" /=) hs_libs + + -- Because of slight differences between the GHC dynamic linker and + -- the native system linker some packages have to link with a + -- different list of libraries when using GHCi. Examples include: libs + -- that are actually gnu ld scripts, and the possibility that the .a + -- libs do not exactly match the .so/.dll equivalents. So if the + -- package file provides an "extra-ghci-libraries" field then we use + -- that instead of the "extra-libraries" field. + extra_libs = + (if null (Packages.unitExtDepLibsGhc pkg) + then Packages.unitExtDepLibsSys pkg + else Packages.unitExtDepLibsGhc pkg) + ++ [ lib | '-':'l':lib <- Packages.unitLinkerOptions pkg ] + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags (platformOS platform) + dirs_env <- addEnvPaths "LIBRARY_PATH" dirs + + hs_classifieds + <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs' + extra_classifieds + <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs + let classifieds = hs_classifieds ++ extra_classifieds + + -- Complication: all the .so's must be loaded before any of the .o's. + let known_dlls = [ dll | DLLPath dll <- classifieds ] + dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Objects objs <- classifieds + , obj <- objs ] + archs = [ arch | Archive arch <- classifieds ] + + -- Add directories to library search paths + let dll_paths = map takeDirectory known_dlls + all_paths = nub $ map normalise $ dll_paths ++ dirs + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env + + maybePutStr dflags + ("Loading package " ++ unitPackageIdString pkg ++ " ... ") + + -- See comments with partOfGHCi +#if defined(CAN_LOAD_DLL) + when (unitPackageName pkg `notElem` partOfGHCi) $ do + loadFrameworks hsc_env platform pkg + -- See Note [Crash early load_dyn and locateLib] + -- Crash early if can't load any of `known_dlls` + mapM_ (load_dyn hsc_env True) known_dlls + -- For remaining `dlls` crash early only when there is surely + -- no package's DLL around ... (not is_dyn) + mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) dlls +#endif + -- After loading all the DLLs, we can load the static objects. + -- Ordering isn't important here, because we do one final link + -- step to resolve everything. + mapM_ (loadObj hsc_env) objs + mapM_ (loadArchive hsc_env) archs + + maybePutStr dflags "linking ... " + ok <- resolveObjs hsc_env + + -- DLLs are loaded, reset the search paths + -- Import libraries will be loaded via loadArchive so only + -- reset the DLL search path after all archives are loaded + -- as well. + mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache + + if succeeded ok + then maybePutStrLn dflags "done." + else let errmsg = "unable to load package `" + ++ unitPackageIdString pkg ++ "'" + in throwGhcExceptionIO (InstallationError errmsg) + +{- +Note [Crash early load_dyn and locateLib] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a package is "normal" (exposes it's code from more than zero Haskell +modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then +it has it's code compiled and linked into the DLL, which GHCi linker picks +when loading the package's code (see the big comment in the beginning of +`locateLib`). + +When loading DLLs, GHCi linker simply calls the system's `dlopen` or +`LoadLibrary` APIs. This is quite different from the case when GHCi linker +loads an object file or static library. When loading an object file or static +library GHCi linker parses them and resolves all symbols "manually". +These object file or static library may reference some external symbols +defined in some external DLLs. And GHCi should know which these +external DLLs are. + +But when GHCi loads a DLL, it's the *system* linker who manages all +the necessary dependencies, and it is able to load this DLL not having +any extra info. Thus we don't *have to* crash in this case even if we +are unable to load any supposed dependencies explicitly. + +Suppose during GHCi session a client of the package wants to +`foreign import` a symbol which isn't exposed by the package DLL, but +is exposed by such an external (dependency) DLL. +If the DLL isn't *explicitly* loaded because `load_dyn` failed to do +this, then the client code eventually crashes because the GHCi linker +isn't able to locate this symbol (GHCi linker maintains a list of +explicitly loaded DLLs it looks into when trying to find a symbol). + +This is why we still should try to load all the dependency DLLs +even though we know that the system linker loads them implicitly when +loading the package DLL. + +Why we still keep the `crash_early` opportunity then not allowing such +a permissive behaviour for any DLLs? Well, we, perhaps, improve a user +experience in some cases slightly. + +But if it happens there exist other corner cases where our current +usage of `crash_early` flag is overly restrictive, we may lift the +restriction very easily. +-} + +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +load_dyn :: HscEnv -> Bool -> FilePath -> IO () +load_dyn hsc_env crash_early dll = do + r <- loadDLL hsc_env dll + case r of + Nothing -> return () + Just err -> + if crash_early + then cmdLineErrorIO err + else let dflags = hsc_dflags hsc_env in + when (wopt Opt_WarnMissedExtraSharedLib dflags) + $ putLogMsg dflags + (Reason Opt_WarnMissedExtraSharedLib) SevWarning + noSrcSpan $ withPprStyle defaultUserStyle (note err) + where + note err = vcat $ map text + [ err + , "It's OK if you don't want to use symbols from it directly." + , "(the package DLL is loaded by the system linker" + , " which manages dependencies by itself)." ] + +loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO () +loadFrameworks hsc_env platform pkg + = when (platformUsesFrameworks platform) $ mapM_ load frameworks + where + fw_dirs = Packages.unitExtDepFrameworkDirs pkg + frameworks = Packages.unitExtDepFrameworks pkg + + load fw = do r <- loadFramework hsc_env fw_dirs fw + case r of + Nothing -> return () + Just err -> cmdLineErrorIO ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" ) + +-- Try to find an object file for a given library in the given paths. +-- If it isn't present, we assume that addDLL in the RTS can find it, +-- which generally means that it should be a dynamic library in the +-- standard system search path. +-- For GHCi we tend to prefer dynamic libraries over static ones as +-- they are easier to load and manage, have less overhead. +locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String + -> IO LibrarySpec +locateLib hsc_env is_hs lib_dirs gcc_dirs lib + | not is_hs + -- For non-Haskell libraries (e.g. gmp, iconv): + -- first look in library-dirs for a dynamic library (on User paths only) + -- (libfoo.so) + -- then try looking for import libraries on Windows (on User paths only) + -- (.dll.a, .lib) + -- first look in library-dirs for a dynamic library (on GCC paths only) + -- (libfoo.so) + -- then check for system dynamic libraries (e.g. kernel32.dll on windows) + -- then try looking for import libraries on Windows (on GCC paths only) + -- (.dll.a, .lib) + -- then look in library-dirs for a static library (libfoo.a) + -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) + -- then try looking for import libraries on Windows (.dll.a, .lib) + -- then look in library-dirs and inplace GCC for a static library (libfoo.a) + -- then try "gcc --print-file-name" to search gcc's search path + -- for a dynamic library (#5289) + -- otherwise, assume loadDLL can find it + -- + -- The logic is a bit complicated, but the rationale behind it is that + -- loading a shared library for us is O(1) while loading an archive is + -- O(n). Loading an import library is also O(n) so in general we prefer + -- shared libraries because they are simpler and faster. + -- + = +#if defined(CAN_LOAD_DLL) + findDll user `orElse` +#endif + tryImpLib user `orElse` +#if defined(CAN_LOAD_DLL) + findDll gcc `orElse` + findSysDll `orElse` +#endif + tryImpLib gcc `orElse` + findArchive `orElse` + tryGcc `orElse` + assumeDll + + | loading_dynamic_hs_libs -- search for .so libraries first. + = findHSDll `orElse` + findDynObject `orElse` + assumeDll + + | otherwise + -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a + = findObject `orElse` + findArchive `orElse` + assumeDll + + where + dflags = hsc_dflags hsc_env + interp = hscInterp hsc_env + dirs = lib_dirs ++ gcc_dirs + gcc = False + user = True + + obj_file + | is_hs && loading_profiled_hs_libs = lib <.> "p_o" + | otherwise = lib <.> "o" + dyn_obj_file = lib <.> "dyn_o" + arch_files = [ "lib" ++ lib ++ lib_tag <.> "a" + , lib <.> "a" -- native code has no lib_tag + , "lib" ++ lib, lib + ] + lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" + + loading_profiled_hs_libs = interpreterProfiled interp + loading_dynamic_hs_libs = interpreterDynamic interp + + import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib" + , "lib" ++ lib <.> "dll.a", lib <.> "dll.a" + ] + + hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags + hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name + + so_name = mkSOName platform lib + lib_so_name = "lib" ++ so_name + dyn_lib_file = case (arch, os) of + (ArchX86_64, OSSolaris2) -> "64" so_name + _ -> so_name + + findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file + findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file + findArchive = let local name = liftM (fmap Archive) $ findFile dirs name + in apply (map local arch_files) + findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file + findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs + in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file + findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ + findSystemLibrary hsc_env so_name + tryGcc = let search = searchForLibUsingGcc dflags + dllpath = liftM (fmap DLLPath) + short = dllpath $ search so_name lib_dirs + full = dllpath $ search lib_so_name lib_dirs + gcc name = liftM (fmap Archive) $ search name lib_dirs + files = import_libs ++ arch_files + dlls = [short, full] + archives = map gcc files + in apply $ +#if defined(CAN_LOAD_DLL) + dlls ++ +#endif + archives + tryImpLib re = case os of + OSMinGW32 -> + let dirs' = if re == user then lib_dirs else gcc_dirs + implib name = liftM (fmap Archive) $ + findFile dirs' name + in apply (map implib import_libs) + _ -> return Nothing + + -- TH Makes use of the interpreter so this failure is not obvious. + -- So we are nice and warn/inform users why we fail before we do. + -- But only for haskell libraries, as C libraries don't have a + -- profiling/non-profiling distinction to begin with. + assumeDll + | is_hs + , not loading_dynamic_hs_libs + , interpreterProfiled interp + = do + warningMsg dflags + (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ + text " \tTrying dynamic library instead. If this fails try to rebuild" <+> + text "libraries with profiling support.") + return (DLL lib) + | otherwise = return (DLL lib) + infixr `orElse` + f `orElse` g = f >>= maybe g return + + apply :: [IO (Maybe a)] -> IO (Maybe a) + apply [] = return Nothing + apply (x:xs) = do x' <- x + if isJust x' + then return x' + else apply xs + + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + +searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc dflags so dirs = do + -- GCC does not seem to extend the library search path (using -L) when using + -- --print-file-name. So instead pass it a new base location. + str <- askLd dflags (map (FileOption "-B") dirs + ++ [Option "--print-file-name", Option so]) + let file = case lines str of + [] -> "" + l:_ -> l + if (file == so) + then return Nothing + else do b <- doesFileExist file -- file could be a folder (see #16063) + return (if b then Just file else Nothing) + +-- | Retrieve the list of search directory GCC and the System use to find +-- libraries and components. See Note [Fork/Exec Windows]. +getGCCPaths :: DynFlags -> OS -> IO [FilePath] +getGCCPaths dflags os + = case os of + OSMinGW32 -> + do gcc_dirs <- getGccSearchDirectory dflags "libraries" + sys_dirs <- getSystemDirectories + return $ nub $ gcc_dirs ++ sys_dirs + _ -> return [] + +-- | Cache for the GCC search directories as this can't easily change +-- during an invocation of GHC. (Maybe with some env. variable but we'll) +-- deal with that highly unlikely scenario then. +{-# NOINLINE gccSearchDirCache #-} +gccSearchDirCache :: IORef [(String, [String])] +gccSearchDirCache = unsafePerformIO $ newIORef [] + +-- Note [Fork/Exec Windows] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- fork/exec is expensive on Windows, for each time we ask GCC for a library we +-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. +-- So instead get a list of location that GCC would search and use findDirs +-- which hopefully is written in an optimized mannor to take advantage of +-- caching. At the very least we remove the overhead of the fork/exec and waits +-- which dominate a large percentage of startup time on Windows. +getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] +getGccSearchDirectory dflags key = do + cache <- readIORef gccSearchDirCache + case lookup key cache of + Just x -> return x + Nothing -> do + str <- askLd dflags [Option "--print-search-dirs"] + let line = dropWhile isSpace str + name = key ++ ": =" + if null line + then return [] + else do let val = split $ find name line + dirs <- filterM doesDirectoryExist val + modifyIORef' gccSearchDirCache ((key, dirs):) + return val + where split :: FilePath -> [FilePath] + split r = case break (==';') r of + (s, [] ) -> [s] + (s, (_:xs)) -> s : split xs + + find :: String -> String -> String + find r x = let lst = lines x + val = filter (r `isPrefixOf`) lst + in if null val + then [] + else case break (=='=') (head val) of + (_ , []) -> [] + (_, (_:xs)) -> xs + +-- | Get a list of system search directories, this to alleviate pressure on +-- the findSysDll function. +getSystemDirectories :: IO [FilePath] +#if defined(mingw32_HOST_OS) +getSystemDirectories = fmap (:[]) getSystemDirectory +#else +getSystemDirectories = return [] +#endif + +-- | Merge the given list of paths with those in the environment variable +-- given. If the variable does not exist then just return the identity. +addEnvPaths :: String -> [String] -> IO [String] +addEnvPaths name list + = do -- According to POSIX (chapter 8.3) a zero-length prefix means current + -- working directory. Replace empty strings in the env variable with + -- `working_dir` (see also #14695). + working_dir <- getCurrentDirectory + values <- lookupEnv name + case values of + Nothing -> return list + Just arr -> return $ list ++ splitEnv working_dir arr + where + splitEnv :: FilePath -> String -> [String] + splitEnv working_dir value = + case break (== envListSep) value of + (x, [] ) -> + [if null x then working_dir else x] + (x, (_:xs)) -> + (if null x then working_dir else x) : splitEnv working_dir xs +#if defined(mingw32_HOST_OS) + envListSep = ';' +#else + envListSep = ':' +#endif + +-- ---------------------------------------------------------------------------- +-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) + +{- +Note [macOS Big Sur dynamic libraries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +macOS Big Sur makes the following change to how frameworks are shipped +with the OS: + +> New in macOS Big Sur 11 beta, the system ships with a built-in +> dynamic linker cache of all system-provided libraries. As part of +> this change, copies of dynamic libraries are no longer present on +> the filesystem. Code that attempts to check for dynamic library +> presence by looking for a file at a path or enumerating a directory +> will fail. Instead, check for library presence by attempting to +> dlopen() the path, which will correctly check for the library in the +> cache. (62986286) + +(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/) + +Therefore, the previous method of checking whether a library exists +before attempting to load it makes GHC.Runtime.Linker.loadFramework +fail to find frameworks installed at /System/Library/Frameworks. +Instead, any attempt to load a framework at runtime, such as by +passing -framework OpenGL to runghc or running code loading such a +framework with GHCi, fails with a 'not found' message. + +GHC.Runtime.Linker.loadFramework now opportunistically loads the +framework libraries without checking for their existence first, +failing only if all attempts to load a given framework from any of the +various possible locations fail. See also #18446, which this change +addresses. +-} + +-- Darwin / MacOS X only: load a framework +-- a framework is a dynamic library packaged inside a directory of the same +-- name. They are searched for in different paths than normal libraries. +loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String) +loadFramework hsc_env extraPaths rootname + = do { either_dir <- tryIO getHomeDirectory + ; let homeFrameworkPath = case either_dir of + Left _ -> [] + Right dir -> [dir "Library/Frameworks"] + ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths + ; errs <- findLoadDLL ps [] + ; return $ fmap (intercalate ", ") errs + } + where + fwk_file = rootname <.> "framework" rootname + + -- sorry for the hardcoded paths, I hope they won't change anytime soon: + defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] + + -- Try to call loadDLL for each candidate path. + -- + -- See Note [macOS Big Sur dynamic libraries] + findLoadDLL [] errs = + -- Tried all our known library paths, but dlopen() + -- has no built-in paths for frameworks: give up + return $ Just errs + findLoadDLL (p:ps) errs = + do { dll <- loadDLL hsc_env (p fwk_file) + ; case dll of + Nothing -> return Nothing + Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs) + } + +{- ********************************************************************** + + Helper functions + + ********************************************************************* -} + +maybePutStr :: DynFlags -> String -> IO () +maybePutStr dflags s + = when (verbosity dflags > 1) $ + putLogMsg dflags + NoReason + SevInteractive + noSrcSpan + $ withPprStyle defaultUserStyle (text s) + +maybePutStrLn :: DynFlags -> String -> IO () +maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/GHC/Runtime/Linker/Types.hs b/GHC/Runtime/Linker/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Linker/Types.hs @@ -0,0 +1,108 @@ +----------------------------------------------------------------------------- +-- +-- Types for the Dynamic Linker +-- +-- (c) The University of Glasgow 2019 +-- +----------------------------------------------------------------------------- + +module GHC.Runtime.Linker.Types ( + DynLinker(..), + PersistentLinkerState(..), + Linkable(..), + Unlinked(..), + SptEntry(..) + ) where + +import GHC.Prelude ( FilePath, String, show ) +import Data.Time ( UTCTime ) +import Data.Maybe ( Maybe ) +import Control.Concurrent.MVar ( MVar ) +import GHC.Unit ( UnitId, Module ) +import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) +import GHC.Utils.Outputable +import GHC.Types.Var ( Id ) +import GHC.Fingerprint.Type ( Fingerprint ) +import GHC.Types.Name.Env ( NameEnv ) +import GHC.Types.Name ( Name ) +import GHCi.RemoteTypes ( ForeignHValue ) + +type ClosureEnv = NameEnv (Name, ForeignHValue) + +newtype DynLinker = + DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) } + +data PersistentLinkerState + = PersistentLinkerState { + + -- Current global mapping from Names to their true values + closure_env :: ClosureEnv, + + -- The current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new Unlinked is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. + itbl_env :: !ItblEnv, + + -- The currently loaded interpreted modules (home package) + bcos_loaded :: ![Linkable], + + -- And the currently-loaded compiled modules (home package) + objs_loaded :: ![Linkable], + + -- The currently-loaded packages; always object code + -- Held, as usual, in dependency order; though I am not sure if + -- that is really important + pkgs_loaded :: ![UnitId], + + -- we need to remember the name of previous temporary DLL/.so + -- libraries so we can link them (see #10322) + temp_sos :: ![(FilePath, String)] } + +-- | Information we can use to dynamically link modules into the compiler +data Linkable = LM { + linkableTime :: UTCTime, -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModule :: Module, -- ^ The linkable module itself + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated in HscNothing mode to avoid recompiling modules. + -- + -- ToDo: Do items get removed from this list when they get linked? + } + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +-- | Objects which have yet to be linked by the compiler +data Unlinked + = DotO FilePath -- ^ An object file (.o) + | DotA FilePath -- ^ Static archive file (.a) + | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | BCOs CompiledByteCode + [SptEntry] -- ^ A byte-code object, lives only in memory. Also + -- carries some static pointer table entries which + -- should be loaded along with the BCOs. + -- See Note [Grant plan for static forms] in + -- "GHC.Iface.Tidy.StaticPtrTable". + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt + +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + diff --git a/GHC/Runtime/Loader.hs b/GHC/Runtime/Loader.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Loader.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE CPP, MagicHash #-} + +-- | Dynamically lookup up values from modules and loading them. +module GHC.Runtime.Loader ( + initializePlugins, + -- * Loading plugins + loadFrontendPlugin, + + -- * Force loading information + forceLoadModuleInterfaces, + forceLoadNameModuleInterface, + forceLoadTyCon, + + -- * Finding names + lookupRdrNameInModuleForPlugins, + + -- * Loading values + getValueSafely, + getHValueSafely, + lessUnsafeCoerce + ) where + +import GHC.Prelude +import GHC.Driver.Session + +import GHC.Runtime.Linker ( linkModule, getHValue ) +import GHC.Runtime.Interpreter ( wormhole, withInterp ) +import GHC.Runtime.Interpreter.Types +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Driver.Finder ( findPluginModule, cannotFindModule ) +import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) +import GHC.Iface.Load ( loadPluginInterface ) +import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) + , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName + , gre_name, mkRdrQual ) +import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) +import GHC.Rename.Names ( gresFromAvails ) +import GHC.Driver.Plugins +import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) + +import GHC.Driver.Types +import GHCi.RemoteTypes ( HValue ) +import GHC.Core.Type ( Type, eqType, mkTyConTy ) +import GHC.Core.TyCo.Ppr ( pprTyThingCategory ) +import GHC.Core.TyCon ( TyCon ) +import GHC.Types.Name ( Name, nameModule_maybe ) +import GHC.Types.Id ( idType ) +import GHC.Unit.Module ( Module, ModuleName ) +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Exception +import GHC.Driver.Hooks + +import Control.Monad ( unless ) +import Data.Maybe ( mapMaybe ) +import Unsafe.Coerce ( unsafeCoerce ) + +-- | Loads the plugins specified in the pluginModNames field of the dynamic +-- flags. Should be called after command line arguments are parsed, but before +-- actual compilation starts. Idempotent operation. Should be re-called if +-- pluginModNames or pluginModNameOpts changes. +initializePlugins :: HscEnv -> DynFlags -> IO DynFlags +initializePlugins hsc_env df + | map lpModuleName (cachedPlugins df) + == pluginModNames df -- plugins not changed + && all (\p -> paArguments (lpPlugin p) + == argumentsForPlugin p (pluginModNameOpts df)) + (cachedPlugins df) -- arguments not changed + = return df -- no need to reload plugins + | otherwise + = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) + let df' = df { cachedPlugins = loadedPlugins } + df'' <- withPlugins df' runDflagsPlugin df' + return df'' + + where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) + runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags + +loadPlugins :: HscEnv -> IO [LoadedPlugin] +loadPlugins hsc_env + = do { unless (null to_load) $ + checkExternalInterpreter hsc_env + ; plugins <- mapM loadPlugin to_load + ; return $ zipWith attachOptions to_load plugins } + where + dflags = hsc_dflags hsc_env + to_load = pluginModNames dflags + + attachOptions mod_nm (plug, mod) = + LoadedPlugin (PluginWithArgs plug (reverse options)) mod + where + options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags + , opt_mod_nm == mod_nm ] + loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env + + +loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin +loadFrontendPlugin hsc_env mod_name = do + checkExternalInterpreter hsc_env + fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName + hsc_env mod_name + +-- #14335 +checkExternalInterpreter :: HscEnv -> IO () +checkExternalInterpreter hsc_env + | Just (ExternalInterp {}) <- hsc_interp hsc_env + = throwIO (InstallationError "Plugins require -fno-external-interpreter") + | otherwise + = pure () + +loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) +loadPlugin' occ_name plugin_name hsc_env mod_name + = do { let plugin_rdr_name = mkRdrQual mod_name occ_name + dflags = hsc_dflags hsc_env + ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name + plugin_rdr_name + ; case mb_name of { + Nothing -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The module", ppr mod_name + , text "did not export the plugin name" + , ppr plugin_rdr_name ]) ; + Just (name, mod_iface) -> + + do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name + ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case mb_plugin of + Nothing -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The value", ppr name + , text "did not have the type" + , ppr pluginTyConName, text "as required"]) + Just plugin -> return (plugin, mod_iface) } } } + + +-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () +forceLoadModuleInterfaces hsc_env doc modules + = (initTcInteractive hsc_env $ + initIfaceTcRn $ + mapM_ (loadPluginInterface doc) modules) + >> return () + +-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () +forceLoadNameModuleInterface hsc_env reason name = do + let name_modules = mapMaybe nameModule_maybe [name] + forceLoadModuleInterfaces hsc_env reason name_modules + +-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: +-- +-- * The interface could not be loaded +-- * The name is not that of a 'TyCon' +-- * The name did not exist in the loaded module +forceLoadTyCon :: HscEnv -> Name -> IO TyCon +forceLoadTyCon hsc_env con_name = do + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name + + mb_con_thing <- lookupTypeHscEnv hsc_env con_name + case mb_con_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name + Just (ATyCon tycon) -> return tycon + Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing + where dflags = hsc_dflags hsc_env + +-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety +-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! +-- +-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: +-- +-- * If we could not load the names module +-- * If the thing being loaded is not a value +-- * If the Name does not exist in the module +-- * If the link failed + +getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) +getValueSafely hsc_env val_name expected_type = do + mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type + case mb_hval of + Nothing -> return Nothing + Just hval -> do + value <- lessUnsafeCoerce dflags "getValueSafely" hval + return (Just value) + where + dflags = hsc_dflags hsc_env + +getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) +getHValueSafely hsc_env val_name expected_type = do + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name + -- Now look up the names for the value and type constructor in the type environment + mb_val_thing <- lookupTypeHscEnv hsc_env val_name + case mb_val_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name + Just (AnId id) -> do + -- Check the value type in the interface against the type recovered from the type constructor + -- before finally casting the value to the type we assume corresponds to that constructor + if expected_type `eqType` idType id + then do + -- Link in the module that contains the value, if it has such a module + case nameModule_maybe val_name of + Just mod -> do linkModule hsc_env mod + return () + Nothing -> return () + -- Find the value that we just linked in and cast it given that we have proved it's type + hval <- withInterp hsc_env $ \interp -> getHValue hsc_env val_name >>= wormhole interp + return (Just hval) + else return Nothing + Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + where dflags = hsc_dflags hsc_env + +-- | Coerce a value as usual, but: +-- +-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong +-- +-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened +-- if it /does/ segfault +lessUnsafeCoerce :: DynFlags -> String -> a -> IO b +lessUnsafeCoerce dflags context what = do + debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> + (text "...") + output <- evaluate (unsafeCoerce what) + debugTraceMsg dflags 3 (text "Successfully evaluated coercion") + return output + + +-- | Finds the 'Name' corresponding to the given 'RdrName' in the +-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' +-- could be found. Any other condition results in an exception: +-- +-- * If the module could not be found +-- * If we could not determine the imports of the module +-- +-- Can only be used for looking up names while loading plugins (and is +-- *not* suitable for use within plugins). The interface file is +-- loaded very partially: just enough that it can be used, without its +-- rules and instances affecting (and being linked from!) the module +-- being compiled. This was introduced by 57d6798. +-- +-- Need the module as well to record information in the interface file +lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName + -> IO (Maybe (Name, ModIface)) +lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do + -- First find the unit the module resides in by searching exposed units and home modules + found_module <- findPluginModule hsc_env mod_name + case found_module of + Found _ mod -> do + -- Find the exports of the module + (_, mb_iface) <- initTcInteractive hsc_env $ + initIfaceTcRn $ + loadPluginInterface doc mod + case mb_iface of + Just iface -> do + -- Try and find the required name in the exports + let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name + , is_qual = False, is_dloc = noSrcSpan } + imp_spec = ImpSpec decl_spec ImpAll + env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) + case lookupGRE_RdrName rdr_name env of + [gre] -> return (Just (gre_name gre, iface)) + [] -> return Nothing + _ -> panic "lookupRdrNameInModule" + + Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where + dflags = hsc_dflags hsc_env + doc = text "contains a name used in an invocation of lookupRdrNameInModule" + +wrongTyThingError :: Name -> TyThing -> SDoc +wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] + +missingTyThingError :: Name -> SDoc +missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] + +throwCmdLineErrorS :: DynFlags -> SDoc -> IO a +throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags + +throwCmdLineError :: String -> IO a +throwCmdLineError = throwGhcExceptionIO . CmdLineError diff --git a/GHC/Settings.hs b/GHC/Settings.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE CPP #-} + +-- | Run-time settings +module GHC.Settings + ( Settings (..) + , ToolSettings (..) + , FileSettings (..) + , GhcNameVersion (..) + , PlatformConstants (..) + , Platform (..) + , PlatformMisc (..) + , PlatformMini (..) + -- * Accessors + , sProgramName + , sProjectVersion + , sGhcUsagePath + , sGhciUsagePath + , sToolDir + , sTopDir + , sTmpDir + , sGlobalPackageDatabasePath + , sLdSupportsCompactUnwind + , sLdSupportsBuildId + , sLdSupportsFilelist + , sLdIsGnuLd + , sGccSupportsNoPie + , sPgm_L + , sPgm_P + , sPgm_F + , sPgm_c + , sPgm_a + , sPgm_l + , sPgm_lm + , sPgm_dll + , sPgm_T + , sPgm_windres + , sPgm_libtool + , sPgm_ar + , sPgm_otool + , sPgm_install_name_tool + , sPgm_ranlib + , sPgm_lo + , sPgm_lc + , sPgm_lcc + , sPgm_i + , sOpt_L + , sOpt_P + , sOpt_P_fingerprint + , sOpt_F + , sOpt_c + , sOpt_cxx + , sOpt_a + , sOpt_l + , sOpt_lm + , sOpt_windres + , sOpt_lo + , sOpt_lc + , sOpt_lcc + , sOpt_i + , sExtraGccViaCFlags + , sTargetPlatformString + , sGhcWithInterpreter + , sGhcWithSMP + , sGhcRTSWays + , sLibFFI + , sGhcThreaded + , sGhcDebugged + , sGhcRtsWithLibdw + ) where + +import GHC.Prelude + +import GHC.Utils.CliOption +import GHC.Utils.Fingerprint +import GHC.Platform + +data Settings = Settings + { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion + , sFileSettings :: {-# UNPACK #-} !FileSettings + , sTargetPlatform :: Platform -- Filled in by SysTools + , sToolSettings :: {-# UNPACK #-} !ToolSettings + , sPlatformMisc :: {-# UNPACK #-} !PlatformMisc + , sPlatformConstants :: PlatformConstants + + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + , sRawSettings :: [(String, String)] + } + +-- | Settings for other executables GHC calls. +-- +-- Probably should further split down by phase, or split between +-- platform-specific and platform-agnostic. +data ToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind :: Bool + , toolSettings_ldSupportsBuildId :: Bool + , toolSettings_ldSupportsFilelist :: Bool + , toolSettings_ldIsGnuLd :: Bool + , toolSettings_ccSupportsNoPie :: Bool + + -- commands for particular phases + , toolSettings_pgm_L :: String + , toolSettings_pgm_P :: (String, [Option]) + , toolSettings_pgm_F :: String + , toolSettings_pgm_c :: String + , toolSettings_pgm_a :: (String, [Option]) + , toolSettings_pgm_l :: (String, [Option]) + , toolSettings_pgm_lm :: (String, [Option]) + , toolSettings_pgm_dll :: (String, [Option]) + , toolSettings_pgm_T :: String + , toolSettings_pgm_windres :: String + , toolSettings_pgm_libtool :: String + , toolSettings_pgm_ar :: String + , toolSettings_pgm_otool :: String + , toolSettings_pgm_install_name_tool :: String + , toolSettings_pgm_ranlib :: String + , -- | LLVM: opt llvm optimiser + toolSettings_pgm_lo :: (String, [Option]) + , -- | LLVM: llc static compiler + toolSettings_pgm_lc :: (String, [Option]) + , -- | LLVM: c compiler + toolSettings_pgm_lcc :: (String, [Option]) + , toolSettings_pgm_i :: String + + -- options for particular phases + , toolSettings_opt_L :: [String] + , toolSettings_opt_P :: [String] + , -- | cached Fingerprint of sOpt_P + -- See Note [Repeated -optP hashing] + toolSettings_opt_P_fingerprint :: Fingerprint + , toolSettings_opt_F :: [String] + , toolSettings_opt_c :: [String] + , toolSettings_opt_cxx :: [String] + , toolSettings_opt_a :: [String] + , toolSettings_opt_l :: [String] + , toolSettings_opt_lm :: [String] + , toolSettings_opt_windres :: [String] + , -- | LLVM: llvm optimiser + toolSettings_opt_lo :: [String] + , -- | LLVM: llc static compiler + toolSettings_opt_lc :: [String] + , -- | LLVM: c compiler + toolSettings_opt_lcc :: [String] + , -- | iserv options + toolSettings_opt_i :: [String] + + , toolSettings_extraGccViaCFlags :: [String] + } + + +-- | Paths to various files and directories used by GHC, including those that +-- provide more settings. +data FileSettings = FileSettings + { fileSettings_ghcUsagePath :: FilePath -- ditto + , fileSettings_ghciUsagePath :: FilePath -- ditto + , fileSettings_toolDir :: Maybe FilePath -- ditto + , fileSettings_topDir :: FilePath -- ditto + , fileSettings_tmpDir :: String -- no trailing '/' + , fileSettings_globalPackageDatabase :: FilePath + } + + +-- | Settings for what GHC this is. +data GhcNameVersion = GhcNameVersion + { ghcNameVersion_programName :: String + , ghcNameVersion_projectVersion :: String + } + +-- Produced by deriveConstants +-- Provides PlatformConstants datatype +#include "GHCConstantsHaskellType.hs" + +----------------------------------------------------------------------------- +-- Accessessors from 'Settings' + +sProgramName :: Settings -> String +sProgramName = ghcNameVersion_programName . sGhcNameVersion +sProjectVersion :: Settings -> String +sProjectVersion = ghcNameVersion_projectVersion . sGhcNameVersion + +sGhcUsagePath :: Settings -> FilePath +sGhcUsagePath = fileSettings_ghcUsagePath . sFileSettings +sGhciUsagePath :: Settings -> FilePath +sGhciUsagePath = fileSettings_ghciUsagePath . sFileSettings +sToolDir :: Settings -> Maybe FilePath +sToolDir = fileSettings_toolDir . sFileSettings +sTopDir :: Settings -> FilePath +sTopDir = fileSettings_topDir . sFileSettings +sTmpDir :: Settings -> String +sTmpDir = fileSettings_tmpDir . sFileSettings +sGlobalPackageDatabasePath :: Settings -> FilePath +sGlobalPackageDatabasePath = fileSettings_globalPackageDatabase . sFileSettings + +sLdSupportsCompactUnwind :: Settings -> Bool +sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings +sLdSupportsBuildId :: Settings -> Bool +sLdSupportsBuildId = toolSettings_ldSupportsBuildId . sToolSettings +sLdSupportsFilelist :: Settings -> Bool +sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings +sLdIsGnuLd :: Settings -> Bool +sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings +sGccSupportsNoPie :: Settings -> Bool +sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings + +sPgm_L :: Settings -> String +sPgm_L = toolSettings_pgm_L . sToolSettings +sPgm_P :: Settings -> (String, [Option]) +sPgm_P = toolSettings_pgm_P . sToolSettings +sPgm_F :: Settings -> String +sPgm_F = toolSettings_pgm_F . sToolSettings +sPgm_c :: Settings -> String +sPgm_c = toolSettings_pgm_c . sToolSettings +sPgm_a :: Settings -> (String, [Option]) +sPgm_a = toolSettings_pgm_a . sToolSettings +sPgm_l :: Settings -> (String, [Option]) +sPgm_l = toolSettings_pgm_l . sToolSettings +sPgm_lm :: Settings -> (String, [Option]) +sPgm_lm = toolSettings_pgm_lm . sToolSettings +sPgm_dll :: Settings -> (String, [Option]) +sPgm_dll = toolSettings_pgm_dll . sToolSettings +sPgm_T :: Settings -> String +sPgm_T = toolSettings_pgm_T . sToolSettings +sPgm_windres :: Settings -> String +sPgm_windres = toolSettings_pgm_windres . sToolSettings +sPgm_libtool :: Settings -> String +sPgm_libtool = toolSettings_pgm_libtool . sToolSettings +sPgm_ar :: Settings -> String +sPgm_ar = toolSettings_pgm_ar . sToolSettings +sPgm_otool :: Settings -> String +sPgm_otool = toolSettings_pgm_otool . sToolSettings +sPgm_install_name_tool :: Settings -> String +sPgm_install_name_tool = toolSettings_pgm_install_name_tool . sToolSettings +sPgm_ranlib :: Settings -> String +sPgm_ranlib = toolSettings_pgm_ranlib . sToolSettings +sPgm_lo :: Settings -> (String, [Option]) +sPgm_lo = toolSettings_pgm_lo . sToolSettings +sPgm_lc :: Settings -> (String, [Option]) +sPgm_lc = toolSettings_pgm_lc . sToolSettings +sPgm_lcc :: Settings -> (String, [Option]) +sPgm_lcc = toolSettings_pgm_lcc . sToolSettings +sPgm_i :: Settings -> String +sPgm_i = toolSettings_pgm_i . sToolSettings +sOpt_L :: Settings -> [String] +sOpt_L = toolSettings_opt_L . sToolSettings +sOpt_P :: Settings -> [String] +sOpt_P = toolSettings_opt_P . sToolSettings +sOpt_P_fingerprint :: Settings -> Fingerprint +sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings +sOpt_F :: Settings -> [String] +sOpt_F = toolSettings_opt_F . sToolSettings +sOpt_c :: Settings -> [String] +sOpt_c = toolSettings_opt_c . sToolSettings +sOpt_cxx :: Settings -> [String] +sOpt_cxx = toolSettings_opt_cxx . sToolSettings +sOpt_a :: Settings -> [String] +sOpt_a = toolSettings_opt_a . sToolSettings +sOpt_l :: Settings -> [String] +sOpt_l = toolSettings_opt_l . sToolSettings +sOpt_lm :: Settings -> [String] +sOpt_lm = toolSettings_opt_lm . sToolSettings +sOpt_windres :: Settings -> [String] +sOpt_windres = toolSettings_opt_windres . sToolSettings +sOpt_lo :: Settings -> [String] +sOpt_lo = toolSettings_opt_lo . sToolSettings +sOpt_lc :: Settings -> [String] +sOpt_lc = toolSettings_opt_lc . sToolSettings +sOpt_lcc :: Settings -> [String] +sOpt_lcc = toolSettings_opt_lcc . sToolSettings +sOpt_i :: Settings -> [String] +sOpt_i = toolSettings_opt_i . sToolSettings + +sExtraGccViaCFlags :: Settings -> [String] +sExtraGccViaCFlags = toolSettings_extraGccViaCFlags . sToolSettings + +sTargetPlatformString :: Settings -> String +sTargetPlatformString = platformMisc_targetPlatformString . sPlatformMisc +sGhcWithInterpreter :: Settings -> Bool +sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc +sGhcWithSMP :: Settings -> Bool +sGhcWithSMP = platformMisc_ghcWithSMP . sPlatformMisc +sGhcRTSWays :: Settings -> String +sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc +sLibFFI :: Settings -> Bool +sLibFFI = platformMisc_libFFI . sPlatformMisc +sGhcThreaded :: Settings -> Bool +sGhcThreaded = platformMisc_ghcThreaded . sPlatformMisc +sGhcDebugged :: Settings -> Bool +sGhcDebugged = platformMisc_ghcDebugged . sPlatformMisc +sGhcRtsWithLibdw :: Settings -> Bool +sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc diff --git a/GHC/Settings/Constants.hs b/GHC/Settings/Constants.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings/Constants.hs @@ -0,0 +1,45 @@ +-- | Compile-time settings +module GHC.Settings.Constants where + +import GHC.Prelude + +import GHC.Settings.Config + +hiVersion :: Integer +hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +-- All pretty arbitrary: + +mAX_TUPLE_SIZE :: Int +mAX_TUPLE_SIZE = 62 -- Should really match the number + -- of decls in Data.Tuple + +mAX_CTUPLE_SIZE :: Int -- Constraint tuples +mAX_CTUPLE_SIZE = 62 -- Should match the number of decls in GHC.Classes + +mAX_SUM_SIZE :: Int +mAX_SUM_SIZE = 62 + +-- | Default maximum depth for both class instance search and type family +-- reduction. See also #5395. +mAX_REDUCTION_DEPTH :: Int +mAX_REDUCTION_DEPTH = 200 + +-- | Default maximum constraint-solver iterations +-- Typically there should be very few +mAX_SOLVER_ITERATIONS :: Int +mAX_SOLVER_ITERATIONS = 4 + +wORD64_SIZE :: Int +wORD64_SIZE = 8 + +-- Size of float in bytes. +fLOAT_SIZE :: Int +fLOAT_SIZE = 4 + +-- Size of double in bytes. +dOUBLE_SIZE :: Int +dOUBLE_SIZE = 8 + +tARGET_MAX_CHAR :: Int +tARGET_MAX_CHAR = 0x10ffff diff --git a/GHC/Settings/IO.hs b/GHC/Settings/IO.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings/IO.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Settings.IO + ( SettingsError (..) + , initSettings + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Settings.Platform +import GHC.Settings.Utils + +import GHC.Settings.Config +import GHC.Utils.CliOption +import GHC.Utils.Fingerprint +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Settings +import GHC.SysTools.BaseDir + +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import qualified Data.Map as Map +import System.FilePath +import System.Directory + +data SettingsError + = SettingsError_MissingData String + | SettingsError_BadData String + +initSettings + :: forall m + . MonadIO m + => String -- ^ TopDir path + -> ExceptT SettingsError m Settings +initSettings top_dir = do + -- see Note [topdir: How GHC finds its files] + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + mtool_dir <- liftIO $ findToolDir top_dir + -- see Note [tooldir: How GHC finds mingw on Windows] + + let installed :: FilePath -> FilePath + installed file = top_dir file + libexec :: FilePath -> FilePath + libexec file = top_dir "bin" file + settingsFile = installed "settings" + platformConstantsFile = installed "platformConstants" + + readFileSafe :: FilePath -> ExceptT SettingsError m String + readFileSafe path = liftIO (doesFileExist path) >>= \case + True -> liftIO $ readFile path + False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path + + settingsStr <- readFileSafe settingsFile + platformConstantsStr <- readFileSafe platformConstantsFile + settingsList <- case maybeReadFuzzy settingsStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse " ++ show settingsFile + let mySettings = Map.fromList settingsList + platformConstants <- case maybeReadFuzzy platformConstantsStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse " ++ show platformConstantsFile + -- See Note [Settings file] for a little more about this file. We're + -- just partially applying those functions and throwing 'Left's; they're + -- written in a very portable style to keep ghc-boot light. + let getSetting key = either pgmError pure $ + getFilePathSetting0 top_dir settingsFile mySettings key + getToolSetting :: String -> ExceptT SettingsError m String + getToolSetting key = expandToolDir mtool_dir <$> getSetting key + getBooleanSetting :: String -> ExceptT SettingsError m Bool + getBooleanSetting key = either pgmError pure $ + getBooleanSetting0 settingsFile mySettings key + targetPlatformString <- getSetting "target platform string" + myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin, + -- as well as TopDir/../../mingw/bin for hadrian. + -- It would perhaps be nice to be able to override this + -- with the settings file, but it would be a little fiddly + -- to make that possible, so for now you can't. + cc_prog <- getToolSetting "C compiler command" + cc_args_str <- getSetting "C compiler flags" + cxx_args_str <- getSetting "C++ compiler flags" + gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" + cpp_prog <- getToolSetting "Haskell CPP command" + cpp_args_str <- getSetting "Haskell CPP flags" + + platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings + + let unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cpp_args = map Option (words cpp_args_str) + cc_args = words cc_args_str ++ unreg_cc_args + cxx_args = words cxx_args_str + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" + ldSupportsBuildId <- getBooleanSetting "ld supports build-id" + ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldIsGnuLd <- getBooleanSetting "ld is GNU ld" + + let globalpkgdb_path = installed "package.conf.d" + ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path <- getToolSetting "unlit command" + + windres_path <- getToolSetting "windres command" + libtool_path <- getToolSetting "libtool command" + ar_path <- getToolSetting "ar command" + otool_path <- getToolSetting "otool command" + install_name_tool_path <- getToolSetting "install_name_tool command" + ranlib_path <- getToolSetting "ranlib command" + + -- TODO this side-effect doesn't belong here. Reading and parsing the settings + -- should be idempotent and accumulate no resources. + tmpdir <- liftIO $ getTemporaryDirectory + + touch_path <- getToolSetting "touch command" + + mkdll_prog <- getToolSetting "dllwrap command" + let mkdll_args = [] + + -- cpp is derived from gcc on all platforms + -- HACK, see setPgmP below. We keep 'words' here to remember to fix + -- Config.hs one day. + + + -- Other things being equal, as and ld are simply gcc + cc_link_args_str <- getSetting "C compiler link flags" + let as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_prog + ld_args = map Option (cc_args ++ words cc_link_args_str) + ld_r_prog <- getToolSetting "Merge objects command" + ld_r_args <- getSetting "Merge objects flags" + + llvmTarget <- getSetting "LLVM target" + + -- We just assume on command line + lc_prog <- getSetting "LLVM llc command" + lo_prog <- getSetting "LLVM opt command" + lcc_prog <- getSetting "LLVM clang command" + + let iserv_prog = libexec "ghc-iserv" + + ghcWithInterpreter <- getBooleanSetting "Use interpreter" + ghcWithSMP <- getBooleanSetting "Support SMP" + ghcRTSWays <- getSetting "RTS ways" + useLibFFI <- getBooleanSetting "Use LibFFI" + ghcThreaded <- getBooleanSetting "Use Threads" + ghcDebugged <- getBooleanSetting "Use Debugging" + ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" + + return $ Settings + { sGhcNameVersion = GhcNameVersion + { ghcNameVersion_programName = "ghc" + , ghcNameVersion_projectVersion = cProjectVersion + } + + , sFileSettings = FileSettings + { fileSettings_tmpDir = normalise tmpdir + , fileSettings_ghcUsagePath = ghc_usage_msg_path + , fileSettings_ghciUsagePath = ghci_usage_msg_path + , fileSettings_toolDir = mtool_dir + , fileSettings_topDir = top_dir + , fileSettings_globalPackageDatabase = globalpkgdb_path + } + + , sToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind + , toolSettings_ldSupportsBuildId = ldSupportsBuildId + , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldIsGnuLd = ldIsGnuLd + , toolSettings_ccSupportsNoPie = gccSupportsNoPie + + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (cpp_prog, cpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = cc_prog + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_lm = (ld_r_prog, map Option $ words ld_r_args) + , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) + , toolSettings_pgm_T = touch_path + , toolSettings_pgm_windres = windres_path + , toolSettings_pgm_libtool = libtool_path + , toolSettings_pgm_ar = ar_path + , toolSettings_pgm_otool = otool_path + , toolSettings_pgm_install_name_tool = install_name_tool_path + , toolSettings_pgm_ranlib = ranlib_path + , toolSettings_pgm_lo = (lo_prog,[]) + , toolSettings_pgm_lc = (lc_prog,[]) + , toolSettings_pgm_lcc = (lcc_prog,[]) + , toolSettings_pgm_i = iserv_prog + , toolSettings_opt_L = [] + , toolSettings_opt_P = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_F = [] + , toolSettings_opt_c = cc_args + , toolSettings_opt_cxx = cxx_args + , toolSettings_opt_a = [] + , toolSettings_opt_l = [] + , toolSettings_opt_lm = [] + , toolSettings_opt_windres = [] + , toolSettings_opt_lcc = [] + , toolSettings_opt_lo = [] + , toolSettings_opt_lc = [] + , toolSettings_opt_i = [] + + , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags + } + + , sTargetPlatform = platform + , sPlatformMisc = PlatformMisc + { platformMisc_targetPlatformString = targetPlatformString + , platformMisc_ghcWithInterpreter = ghcWithInterpreter + , platformMisc_ghcWithSMP = ghcWithSMP + , platformMisc_ghcRTSWays = ghcRTSWays + , platformMisc_libFFI = useLibFFI + , platformMisc_ghcThreaded = ghcThreaded + , platformMisc_ghcDebugged = ghcDebugged + , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw + , platformMisc_llvmTarget = llvmTarget + } + + , sPlatformConstants = platformConstants + + , sRawSettings = settingsList + } diff --git a/GHC/Stg/CSE.hs b/GHC/Stg/CSE.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/CSE.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE TypeFamilies #-} + +{-| +Note [CSE for Stg] +~~~~~~~~~~~~~~~~~~ + +This module implements a simple common subexpression elimination pass for STG. +This is useful because there are expressions that we want to common up (because +they are operationally equivalent), but that we cannot common up in Core, because +their types differ. +This was originally reported as #9291. + +There are two types of common code occurrences that we aim for, see +note [Case 1: CSEing allocated closures] and +note [Case 2: CSEing case binders] below. + + +Note [Case 1: CSEing allocated closures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The first kind of CSE opportunity we aim for is generated by this Haskell code: + + bar :: a -> (Either Int a, Either Bool a) + bar x = (Right x, Right x) + +which produces this Core: + + bar :: forall a. a -> (Either Int a, Either Bool a) + bar @a x = (Right @Int @a x, Right @Bool @a x) + +where the two components of the tuple are different terms, and cannot be +commoned up (easily). On the STG level we have + + bar [x] = let c1 = Right [x] + c2 = Right [x] + in (c1,c2) + +and now it is obvious that we can write + + bar [x] = let c1 = Right [x] + in (c1,c1) + +instead. + + +Note [Case 2: CSEing case binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The second kind of CSE opportunity we aim for is more interesting, and +came up in #9291 and #5344: The Haskell code + + foo :: Either Int a -> Either Bool a + foo (Right x) = Right x + foo _ = Left False + +produces this Core + + foo :: forall a. Either Int a -> Either Bool a + foo @a e = case e of b { Left n -> … + , Right x -> Right @Bool @a x } + +where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have +different types. But in STG we have + + foo [e] = case e of b { Left [n] -> … + , Right [x] -> Right [x] } + +and nothing stops us from transforming that to + + foo [e] = case e of b { Left [n] -> … + , Right [x] -> b} + + +Note [StgCse after unarisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider two unboxed sum terms: + + (# 1 | #) :: (# Int | Int# #) + (# 1 | #) :: (# Int | Int #) + +These two terms are not equal as they unarise to different unboxed +tuples. However if we run StgCse before Unarise, it'll think the two +terms (# 1 | #) are equal, and replace one of these with a binder to +the other. That's bad -- #15300. + +Solution: do unarise first. + +-} + +module GHC.Stg.CSE (stgCse) where + +import GHC.Prelude + +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Stg.Syntax +import GHC.Utils.Outputable +import GHC.Types.Basic (isWeakLoopBreaker) +import GHC.Types.Var.Env +import GHC.Core (AltCon(..)) +import Data.List (mapAccumL) +import Data.Maybe (fromMaybe) +import GHC.Core.Map +import GHC.Types.Name.Env +import Control.Monad( (>=>) ) + +-------------- +-- The Trie -- +-------------- + +-- A lookup trie for data constructor applications, i.e. +-- keys of type `(DataCon, [StgArg])`, following the patterns in GHC.Data.TrieMap. + +data StgArgMap a = SAM + { sam_var :: DVarEnv a + , sam_lit :: LiteralMap a + } + +instance TrieMap StgArgMap where + type Key StgArgMap = StgArg + emptyTM = SAM { sam_var = emptyTM + , sam_lit = emptyTM } + lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var + lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit + alterTM (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f } + alterTM (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f } + foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m) + mapTM f (SAM {sam_var = varm, sam_lit = litm}) = + SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm } + +newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } + +instance TrieMap ConAppMap where + type Key ConAppMap = (DataCon, [StgArg]) + emptyTM = CAM emptyTM + lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args + alterTM (dataCon, args) f m = + m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } + foldTM k = un_cam >.> foldTM (foldTM k) + mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM + +----------------- +-- The CSE Env -- +----------------- + +-- | The CSE environment. See note [CseEnv Example] +data CseEnv = CseEnv + { ce_conAppMap :: ConAppMap OutId + -- ^ The main component of the environment is the trie that maps + -- data constructor applications (with their `OutId` arguments) + -- to an in-scope name that can be used instead. + -- This name is always either a let-bound variable or a case binder. + , ce_subst :: IdEnv OutId + -- ^ This substitution is applied to the code as we traverse it. + -- Entries have one of two reasons: + -- + -- * The input might have shadowing (see Note [Shadowing]), so we have + -- to rename some binders as we traverse the tree. + -- * If we remove `let x = Con z` because `let y = Con z` is in scope, + -- we note this here as x ↦ y. + , ce_bndrMap :: IdEnv OutId + -- ^ If we come across a case expression case x as b of … with a trivial + -- binder, we add b ↦ x to this. + -- This map is *only* used when looking something up in the ce_conAppMap. + -- See Note [Trivial case scrutinee] + , ce_in_scope :: InScopeSet + -- ^ The third component is an in-scope set, to rename away any + -- shadowing binders + } + +{-| +Note [CseEnv Example] +~~~~~~~~~~~~~~~~~~~~~ +The following tables shows how the CseEnvironment changes as code is traversed, +as well as the changes to that code. + + InExpr OutExpr + conAppMap subst in_scope + ─────────────────────────────────────────────────────────── + -- empty {} {} + case … as a of {Con x y -> case … as a of {Con x y -> + -- Con x y ↦ a {} {a,x,y} + let b = Con x y (removed) + -- Con x y ↦ a b↦a {a,x,y,b} + let c = Bar a let c = Bar a + -- Con x y ↦ a, Bar a ↦ c b↦a {a,x,y,b,c} + let c = some expression let c' = some expression + -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', {a,x,y,b,c,c'} + let d = Bar b (removed) + -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', d↦c {a,x,y,b,c,c',d} + (a, b, c d) (a, a, c' c) +-} + +initEnv :: InScopeSet -> CseEnv +initEnv in_scope = CseEnv + { ce_conAppMap = emptyTM + , ce_subst = emptyVarEnv + , ce_bndrMap = emptyVarEnv + , ce_in_scope = in_scope + } + +envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId +envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env) + where args' = map go args -- See Note [Trivial case scrutinee] + go (StgVarArg v ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v) + go (StgLitArg lit) = StgLitArg lit + +addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv +-- do not bother with nullary data constructors, they are static anyways +addDataCon _ _ [] env = env +addDataCon bndr dataCon args env = env { ce_conAppMap = new_env } + where + new_env = insertTM (dataCon, args) bndr (ce_conAppMap env) + +forgetCse :: CseEnv -> CseEnv +forgetCse env = env { ce_conAppMap = emptyTM } + -- See note [Free variables of an StgClosure] + +addSubst :: OutId -> OutId -> CseEnv -> CseEnv +addSubst from to env + = env { ce_subst = extendVarEnv (ce_subst env) from to } + +addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv +addTrivCaseBndr from to env + = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to } + +substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] +substArgs env = map (substArg env) + +substArg :: CseEnv -> InStgArg -> OutStgArg +substArg env (StgVarArg from) = StgVarArg (substVar env from) +substArg _ (StgLitArg lit) = StgLitArg lit + +substVar :: CseEnv -> InId -> OutId +substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id + +-- Functions to enter binders + +-- This is much simpler than the equivalent code in GHC.Core.Subst: +-- * We do not substitute type variables, and +-- * There is nothing relevant in GHC.Types.Id.Info at this stage +-- that needs substitutions. +-- Therefore, no special treatment for a recursive group is required. + +substBndr :: CseEnv -> InId -> (CseEnv, OutId) +substBndr env old_id + = (new_env, new_id) + where + new_id = uniqAway (ce_in_scope env) old_id + no_change = new_id == old_id + env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id } + new_env | no_change = env' + | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id } + +substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar]) +substBndrs env bndrs = mapAccumL substBndr env bndrs + +substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)]) +substPairs env bndrs = mapAccumL go env bndrs + where go env (id, x) = let (env', id') = substBndr env id + in (env', (id', x)) + +-- Main entry point + +stgCse :: [InStgTopBinding] -> [OutStgTopBinding] +stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds + +-- Top level bindings. +-- +-- We do not CSE these, as top-level closures are allocated statically anyways. +-- Also, they might be exported. +-- But we still have to collect the set of in-scope variables, otherwise +-- uniqAway might shadow a top-level closure. + +stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding) +stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t) +stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs)) + = (in_scope' + , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs))) + where in_scope' = in_scope `extendInScopeSet` bndr + +stgCseTopLvl in_scope (StgTopLifted (StgRec eqs)) + = ( in_scope' + , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ])) + where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] + +stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs +stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body) + = let body' = stgCseExpr (initEnv in_scope) body + in StgRhsClosure ext ccs upd args body' +stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args) + = StgRhsCon ccs dataCon args + +------------------------------ +-- The actual AST traversal -- +------------------------------ + +-- Trivial cases +stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr +stgCseExpr env (StgApp fun args) + = StgApp fun' args' + where fun' = substVar env fun + args' = substArgs env args +stgCseExpr _ (StgLit lit) + = StgLit lit +stgCseExpr env (StgOpApp op args tys) + = StgOpApp op args' tys + where args' = substArgs env args +stgCseExpr _ (StgLam _ _) + = pprPanic "stgCseExp" (text "StgLam") +stgCseExpr env (StgTick tick body) + = let body' = stgCseExpr env body + in StgTick tick body' +stgCseExpr env (StgCase scrut bndr ty alts) + = mkStgCase scrut' bndr' ty alts' + where + scrut' = stgCseExpr env scrut + (env1, bndr') = substBndr env bndr + env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1 + -- See Note [Trivial case scrutinee] + | otherwise = env1 + alts' = map (stgCseAlt env2 ty bndr') alts + + +-- A constructor application. +-- To be removed by a variable use when found in the CSE environment +stgCseExpr env (StgConApp dataCon args tys) + | Just bndr' <- envLookup dataCon args' env + = StgApp bndr' [] + | otherwise + = StgConApp dataCon args' tys + where args' = substArgs env args + +-- Let bindings +-- The binding might be removed due to CSE (we do not want trivial bindings on +-- the STG level), so use the smart constructor `mkStgLet` to remove the binding +-- if empty. +stgCseExpr env (StgLet ext binds body) + = let (binds', env') = stgCseBind env binds + body' = stgCseExpr env' body + in mkStgLet (StgLet ext) binds' body' +stgCseExpr env (StgLetNoEscape ext binds body) + = let (binds', env') = stgCseBind env binds + body' = stgCseExpr env' body + in mkStgLet (StgLetNoEscape ext) binds' body' + +-- Case alternatives +-- Extend the CSE environment +stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt +stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs) + = let (env1, args') = substBndrs env args + env2 + -- To avoid dealing with unboxed sums StgCse runs after unarise and + -- should maintain invariants listed in Note [Post-unarisation + -- invariants]. One of the invariants is that some binders are not + -- used (unboxed tuple case binders) which is what we check with + -- `stgCaseBndrInScope` here. If the case binder is not in scope we + -- don't add it to the CSE env. See also #15300. + | stgCaseBndrInScope ty True -- CSE runs after unarise + = addDataCon case_bndr dataCon (map StgVarArg args') env1 + | otherwise + = env1 + -- see note [Case 2: CSEing case binders] + rhs' = stgCseExpr env2 rhs + in (DataAlt dataCon, args', rhs') +stgCseAlt env _ _ (altCon, args, rhs) + = let (env1, args') = substBndrs env args + rhs' = stgCseExpr env1 rhs + in (altCon, args', rhs') + +-- Bindings +stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv) +stgCseBind env (StgNonRec b e) + = let (env1, b') = substBndr env b + in case stgCseRhs env1 b' e of + (Nothing, env2) -> (Nothing, env2) + (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2) +stgCseBind env (StgRec pairs) + = let (env1, pairs1) = substPairs env pairs + in case stgCsePairs env1 pairs1 of + ([], env2) -> (Nothing, env2) + (pairs2, env2) -> (Just (StgRec pairs2), env2) + +stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv) +stgCsePairs env [] = ([], env) +stgCsePairs env0 ((b,e):pairs) + = let (pairMB, env1) = stgCseRhs env0 b e + (pairs', env2) = stgCsePairs env1 pairs + in (pairMB `mbCons` pairs', env2) + where + mbCons = maybe id (:) + +-- The RHS of a binding. +-- If it is a constructor application, either short-cut it or extend the environment +stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) +stgCseRhs env bndr (StgRhsCon ccs dataCon args) + | Just other_bndr <- envLookup dataCon args' env + , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] + = let env' = addSubst bndr other_bndr env + in (Nothing, env') + | otherwise + = let env' = addDataCon bndr dataCon args' env + -- see note [Case 1: CSEing allocated closures] + pair = (bndr, StgRhsCon ccs dataCon args') + in (Just pair, env') + where args' = substArgs env args + +stgCseRhs env bndr (StgRhsClosure ext ccs upd args body) + = let (env1, args') = substBndrs env args + env2 = forgetCse env1 -- See note [Free variables of an StgClosure] + body' = stgCseExpr env2 body + in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env) + + +mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr +mkStgCase scrut bndr ty alts | all isBndr alts = scrut + | otherwise = StgCase scrut bndr ty alts + + where + -- see Note [All alternatives are the binder] + isBndr (_, _, StgApp f []) = f == bndr + isBndr _ = False + + +{- Note [Care with loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing CSE on a letrec we must be careful about loop +breakers. Consider + rec { y = K z + ; z = K z } +Now if, somehow (and wrongly)), y and z are both marked as +loop-breakers, we do *not* want to drop the (z = K z) binding +in favour of a substitution (z :-> y). + +I think this bug will only show up if the loop-breaker-ness is done +wrongly (itself a bug), but it still seems better to do the right +thing regardless. +-} + +-- Utilities + +-- | This function short-cuts let-bindings that are now obsolete +mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b +mkStgLet _ Nothing body = body +mkStgLet stgLet (Just binds) body = stgLet binds body + + +{- +Note [All alternatives are the binder] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When all alternatives simply refer to the case binder, then we do not have +to bother with the case expression at all (#13588). CoreSTG does this as well, +but sometimes, types get into the way: + + newtype T = MkT Int + f :: (Int, Int) -> (T, Int) + f (x, y) = (MkT x, y) + +Core cannot just turn this into + + f p = p + +as this would not be well-typed. But to STG, where MkT is no longer in the way, +we can. + +Note [Trivial case scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to be able to handle nested reconstruction of constructors as in + + nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) + nested (Right (Right v)) = Right (Right v) + nested _ = Left True + +So if we come across + + case x of r1 + Right a -> case a of r2 + Right b -> let v = Right b + in Right v + +we first replace v with r2. Next we want to replace Right r2 with r1. But the +ce_conAppMap contains Right a! + +Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use +this substitution before looking Right r2 up in ce_conAppMap, and everything +works out. + +Note [Free variables of an StgClosure] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +StgClosures (function and thunks) have an explicit list of free variables: + +foo [x] = + let not_a_free_var = Left [x] + let a_free_var = Right [x] + let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var + in closure + +If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`, +then the list of free variables would be wrong, so for now, we do not CSE +across such a closure, simply because I (Joachim) was not sure about possible +knock-on effects. If deemed safe and worth the slight code complication of +re-calculating this list during or after this pass, this can surely be done. +-} diff --git a/GHC/Stg/DepAnal.hs b/GHC/Stg/DepAnal.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/DepAnal.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE CPP #-} + +module GHC.Stg.DepAnal (depSortStgPgm) where + +import GHC.Prelude + +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Name (Name, nameIsLocalOrFrom) +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Types.Unique.Set (nonDetEltsUniqSet) +import GHC.Types.Var.Set +import GHC.Unit.Module (Module) + +import Data.Graph (SCC (..)) +import Data.Bifunctor (first) + +-------------------------------------------------------------------------------- +-- * Dependency analysis + +-- | Set of bound variables +type BVs = VarSet + +-- | Set of free variables +type FVs = VarSet + +-- | Dependency analysis on STG terms. +-- +-- Dependencies of a binding are just free variables in the binding. This +-- includes imported ids and ids in the current module. For recursive groups we +-- just return one set of free variables which is just the union of dependencies +-- of all bindings in the group. +-- +-- Implementation: pass bound variables (BVs) to recursive calls, get free +-- variables (FVs) back. We ignore imported FVs as they do not change the +-- ordering but it improves performance. +-- +annTopBindingsDeps :: Module -> [StgTopBinding] -> [(StgTopBinding, FVs)] +annTopBindingsDeps this_mod bs = zip bs (map top_bind bs) + where + top_bind :: StgTopBinding -> FVs + top_bind StgTopStringLit{} = + emptyVarSet + + top_bind (StgTopLifted bs) = + binding emptyVarSet bs + + binding :: BVs -> StgBinding -> FVs + binding bounds (StgNonRec _ r) = + rhs bounds r + binding bounds (StgRec bndrs) = + unionVarSets $ + map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs + + bind_non_rec :: BVs -> (Id, StgRhs) -> FVs + bind_non_rec bounds (_, r) = + rhs bounds r + + rhs :: BVs -> StgRhs -> FVs + rhs bounds (StgRhsClosure _ _ _ as e) = + expr (extendVarSetList bounds as) e + + rhs bounds (StgRhsCon _ _ as) = + args bounds as + + var :: BVs -> Var -> FVs + var bounds v + | not (elemVarSet v bounds) + , nameIsLocalOrFrom this_mod (idName v) + = unitVarSet v + | otherwise + = emptyVarSet + + arg :: BVs -> StgArg -> FVs + arg bounds (StgVarArg v) = var bounds v + arg _ StgLitArg{} = emptyVarSet + + args :: BVs -> [StgArg] -> FVs + args bounds as = unionVarSets (map (arg bounds) as) + + expr :: BVs -> StgExpr -> FVs + expr bounds (StgApp f as) = + var bounds f `unionVarSet` args bounds as + + expr _ StgLit{} = + emptyVarSet + + expr bounds (StgConApp _ as _) = + args bounds as + expr bounds (StgOpApp _ as _) = + args bounds as + expr _ lam@StgLam{} = + pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ pprStgExpr panicStgPprOpts lam) + expr bounds (StgCase scrut scrut_bndr _ as) = + expr bounds scrut `unionVarSet` + alts (extendVarSet bounds scrut_bndr) as + expr bounds (StgLet _ bs e) = + binding bounds bs `unionVarSet` + expr (extendVarSetList bounds (bindersOf bs)) e + expr bounds (StgLetNoEscape _ bs e) = + binding bounds bs `unionVarSet` + expr (extendVarSetList bounds (bindersOf bs)) e + + expr bounds (StgTick _ e) = + expr bounds e + + alts :: BVs -> [StgAlt] -> FVs + alts bounds = unionVarSets . map (alt bounds) + + alt :: BVs -> StgAlt -> FVs + alt bounds (_, bndrs, e) = + expr (extendVarSetList bounds bndrs) e + +-------------------------------------------------------------------------------- +-- * Dependency sorting + +-- | Dependency sort a STG program so that dependencies come before uses. +depSortStgPgm :: Module -> [StgTopBinding] -> [StgTopBinding] +depSortStgPgm this_mod = + {-# SCC "STG.depSort" #-} + map fst . depSort . annTopBindingsDeps this_mod + +-- | Sort free-variable-annotated STG bindings so that dependencies come before +-- uses. +depSort :: [(StgTopBinding, FVs)] -> [(StgTopBinding, FVs)] +depSort = concatMap get_binds . depAnal defs uses + where + uses, defs :: (StgTopBinding, FVs) -> [Name] + + -- TODO (osa): I'm unhappy about two things in this code: + -- + -- * Why do we need Name instead of Id for uses and dependencies? + -- * Why do we need a [Name] instead of `Set Name`? Surely depAnal + -- doesn't need any ordering. + + uses (StgTopStringLit{}, _) = [] + uses (StgTopLifted{}, fvs) = map idName (nonDetEltsUniqSet fvs) + + defs (bind, _) = map idName (bindersOfTop bind) + + get_binds (AcyclicSCC bind) = + [bind] + get_binds (CyclicSCC binds) = + pprPanic "depSortStgBinds" + (text "Found cyclic SCC:" + $$ ppr (map (first (pprStgTopBinding panicStgPprOpts)) binds)) diff --git a/GHC/Stg/FVs.hs b/GHC/Stg/FVs.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/FVs.hs @@ -0,0 +1,168 @@ +{- | +Non-global free variable analysis on STG terms. This pass annotates +non-top-level closure bindings with captured variables. Global variables are not +captured. For example, in a top-level binding like (pseudo-STG) + + f = \[x,y] . + let g = \[p] . reverse (x ++ p) + in g y + +In g, `reverse` and `(++)` are global variables so they're not considered free. +`p` is an argument, so `x` is the only actual free variable here. The annotated +version is thus: + + f = \[x,y] . + let g = [x] \[p] . reverse (x ++ p) + in g y + +Note that non-top-level recursive bindings are also considered free within the +group: + + map = {} \r [f xs0] + let { + Rec { + go = {f, go} \r [xs1] + case xs1 of { + [] -> [] []; + : x xs2 -> + let { xs' = {go, xs2} \u [] go xs2; } in + let { x' = {f, x} \u [] f x; } in + : [x' xs']; + }; + end Rec } + } in go xs0; + +Here go is free in its RHS. + +Top-level closure bindings never capture variables as all of their free +variables are global. +-} +module GHC.Stg.FVs ( + annTopBindingsFreeVars, + annBindingFreeVars + ) where + +import GHC.Prelude + +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Core ( Tickish(Breakpoint) ) +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Data.Maybe ( mapMaybe ) + +newtype Env + = Env + { locals :: IdSet + } + +emptyEnv :: Env +emptyEnv = Env emptyVarSet + +addLocals :: [Id] -> Env -> Env +addLocals bndrs env + = env { locals = extendVarSetList (locals env) bndrs } + +-- | Annotates a top-level STG binding group with its free variables. +annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding] +annTopBindingsFreeVars = map go + where + go (StgTopStringLit id bs) = StgTopStringLit id bs + go (StgTopLifted bind) + = StgTopLifted (annBindingFreeVars bind) + +-- | Annotates an STG binding with its free variables. +annBindingFreeVars :: StgBinding -> CgStgBinding +annBindingFreeVars = fst . binding emptyEnv emptyDVarSet + +boundIds :: StgBinding -> [Id] +boundIds (StgNonRec b _) = [b] +boundIds (StgRec pairs) = map fst pairs + +-- Note [Tracking local binders] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- 'locals' contains non-toplevel, non-imported binders. +-- We maintain the set in 'expr', 'alt' and 'rhs', which are the only +-- places where new local binders are introduced. +-- Why do it there rather than in 'binding'? Two reasons: +-- +-- 1. We call 'binding' from 'annTopBindingsFreeVars', which would +-- add top-level bindings to the 'locals' set. +-- 2. In the let(-no-escape) case, we need to extend the environment +-- prior to analysing the body, but we also need the fvs from the +-- body to analyse the RHSs. No way to do this without some +-- knot-tying. + +-- | This makes sure that only local, non-global free vars make it into the set. +mkFreeVarSet :: Env -> [Id] -> DIdSet +mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env) + +args :: Env -> [StgArg] -> DIdSet +args env = mkFreeVarSet env . mapMaybe f + where + f (StgVarArg occ) = Just occ + f _ = Nothing + +binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet) +binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs) + where + -- See Note [Tracking local binders] + (r', rhs_fvs) = rhs env r + fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs +binding env body_fv (StgRec pairs) = (StgRec pairs', fvs) + where + -- See Note [Tracking local binders] + bndrs = map fst pairs + (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs + pairs' = zip bndrs rhss + fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs + +expr :: Env -> StgExpr -> (CgStgExpr, DIdSet) +expr env = go + where + go (StgApp occ as) + = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ])) + go (StgLit lit) = (StgLit lit, emptyDVarSet) + go (StgConApp dc as tys) = (StgConApp dc as tys, args env as) + go (StgOpApp op as ty) = (StgOpApp op as ty, args env as) + go StgLam{} = pprPanic "StgFVs: StgLam" empty + go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) + where + (scrut', scrut_fvs) = go scrut + -- See Note [Tracking local binders] + (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts + alt_fvs = unionDVarSets alt_fvss + fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr + go (StgLet ext bind body) = go_bind (StgLet ext) bind body + go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body + go (StgTick tick e) = (StgTick tick e', fvs') + where + (e', fvs) = go e + fvs' = unionDVarSet (tickish tick) fvs + tickish (Breakpoint _ ids) = mkDVarSet ids + tickish _ = emptyDVarSet + + go_bind dc bind body = (dc bind' body', fvs) + where + -- See Note [Tracking local binders] + env' = addLocals (boundIds bind) env + (body', body_fvs) = expr env' body + (bind', fvs) = binding env' body_fvs bind + +rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet) +rhs env (StgRhsClosure _ ccs uf bndrs body) + = (StgRhsClosure fvs ccs uf bndrs body', fvs) + where + -- See Note [Tracking local binders] + (body', body_fvs) = expr (addLocals bndrs env) body + fvs = delDVarSetList body_fvs bndrs +rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as) + +alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) +alt env (con, bndrs, e) = ((con, bndrs, e'), fvs) + where + -- See Note [Tracking local binders] + (e', rhs_fvs) = expr (addLocals bndrs env) e + fvs = delDVarSetList rhs_fvs bndrs diff --git a/GHC/Stg/Lift.hs b/GHC/Stg/Lift.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} + +-- | Implements a selective lambda lifter, running late in the optimisation +-- pipeline. +-- +-- If you are interested in the cost model that is employed to decide whether +-- to lift a binding or not, look at "GHC.Stg.Lift.Analysis". +-- "GHC.Stg.Lift.Monad" contains the transformation monad that hides away some +-- plumbing of the transformation. +module GHC.Stg.Lift + ( + -- * Late lambda lifting in STG + -- $note + stgLiftLams + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Types.Id +import GHC.Stg.FVs ( annBindingFreeVars ) +import GHC.Stg.Lift.Analysis +import GHC.Stg.Lift.Monad +import GHC.Stg.Syntax +import GHC.Utils.Outputable +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Types.Var.Set +import Control.Monad ( when ) +import Data.Maybe ( isNothing ) + +-- Note [Late lambda lifting in STG] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- $note +-- See also the +-- and #9476. +-- +-- The basic idea behind lambda lifting is to turn locally defined functions +-- into top-level functions. Free variables are then passed as additional +-- arguments at *call sites* instead of having a closure allocated for them at +-- *definition site*. Example: +-- +-- @ +-- let x = ...; y = ... in +-- let f = {x y} \a -> a + x + y in +-- let g = {f x} \b -> f b + x in +-- g 5 +-- @ +-- +-- Lambda lifting @f@ would +-- +-- 1. Turn @f@'s free variables into formal parameters +-- 2. Update @f@'s call site within @g@ to @f x y b@ +-- 3. Update @g@'s closure: Add @y@ as an additional free variable, while +-- removing @f@, because @f@ no longer allocates and can be floated to +-- top-level. +-- 4. Actually float the binding of @f@ to top-level, eliminating the @let@ +-- in the process. +-- +-- This results in the following program (with free var annotations): +-- +-- @ +-- f x y a = a + x + y; +-- let x = ...; y = ... in +-- let g = {x y} \b -> f x y b + x in +-- g 5 +-- @ +-- +-- This optimisation is all about lifting only when it is beneficial to do so. +-- The above seems like a worthwhile lift, judging from heap allocation: +-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while +-- not changing the size of @g@'s closure. +-- +-- You can probably sense that there's some kind of cost model at play here. +-- And you are right! But we also employ a couple of other heuristics for the +-- lifting decision which are outlined in "GHC.Stg.Lift.Analysis#when". +-- +-- The transformation is done in "GHC.Stg.Lift", which calls out to +-- 'GHC.Stg.Lift.Analysis.goodToLift' for its lifting decision. It relies on +-- "GHC.Stg.Lift.Monad", which abstracts some subtle STG invariants into a +-- monadic substrate. +-- +-- Suffice to say: We trade heap allocation for stack allocation. +-- The additional arguments have to passed on the stack (or in registers, +-- depending on architecture) every time we call the function to save a single +-- heap allocation when entering the let binding. Nofib suggests a mean +-- improvement of about 1% for this pass, so it seems like a worthwhile thing to +-- do. Compile-times went up by 0.6%, so all in all a very modest change. +-- +-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith' +-- that is ultimately compiled to something like this +-- (module desugaring/lowering to actual STG): +-- +-- @ +-- propagate dt = ...; +-- runExperiment ... = +-- let xs = ... in +-- let ys = ... in +-- let go = {dt go} \xs ys -> case (xs, ys) of +-- ([], []) -> [] +-- (x:xs', y:ys') -> propagate dt x y : go xs' ys' +-- in go xs ys +-- @ +-- +-- This will lambda lift @go@ to top-level, speeding up the resulting program +-- by roughly one percent: +-- +-- @ +-- propagate dt = ...; +-- go dt xs ys = case (xs, ys) of +-- ([], []) -> [] +-- (x:xs', y:ys') -> propagate dt x y : go dt xs' ys' +-- runExperiment ... = +-- let xs = ... in +-- let ys = ... in +-- in go dt xs ys +-- @ + + + +-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift'). +-- +-- (Mostly) textbook instance of the lambda lifting transformation, selecting +-- which bindings to lambda lift by consulting 'goodToLift'. +stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding] +stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ()) + +liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM () +liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do + addTopStringLit bndr' lit + rest +liftTopLvl (StgTopLifted bind) rest = do + let is_rec = isRec $ fst $ decomposeStgBinding bind + when is_rec startBindingGroup + let bind_w_fvs = annBindingFreeVars bind + withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do + -- We signal lifting of a binding through returning Nothing. + -- Should never happen for a top-level binding, though, since we are already + -- at top-level. + case mb_bind' of + Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding") + Just bind' -> addLiftedBinding bind' + when is_rec endBindingGroup + rest + +withLiftedBind + :: TopLevelFlag + -> LlStgBinding + -> Skeleton + -> (Maybe OutStgBinding -> LiftM a) + -> LiftM a +withLiftedBind top_lvl bind scope k + = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec)) + where + (rec, pairs) = decomposeStgBinding bind + +withLiftedBindPairs + :: TopLevelFlag + -> RecFlag + -> [(BinderInfo, LlStgRhs)] + -> Skeleton + -> (Maybe [(Id, OutStgRhs)] -> LiftM a) + -> LiftM a +withLiftedBindPairs top rec pairs scope k = do + let (infos, rhss) = unzip pairs + let bndrs = map binderInfoBndr infos + expander <- liftedIdsExpander + dflags <- getDynFlags + case goodToLift dflags top rec expander pairs scope of + -- @abs_ids@ is the set of all variables that need to become parameters. + Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do + -- Within this block, all binders in @bndrs@ will be noted as lifted, so + -- that the return value of @liftedIdsExpander@ in this context will also + -- expand the bindings in @bndrs@ to their free variables. + -- Now we can recurse into the RHSs and see if we can lift any further + -- bindings. We pass the set of expanded free variables (thus OutIds) on + -- to @liftRhs@ so that it can add them as parameter binders. + when (isRec rec) startBindingGroup + rhss' <- traverse (liftRhs (Just abs_ids)) rhss + let pairs' = zip bndrs' rhss' + addLiftedBinding (mkStgBinding rec pairs') + when (isRec rec) endBindingGroup + k Nothing + Nothing -> withSubstBndrs bndrs $ \bndrs' -> do + -- Don't lift the current binding, but possibly some bindings in their + -- RHSs. + rhss' <- traverse (liftRhs Nothing) rhss + let pairs' = zip bndrs' rhss' + k (Just pairs') + +liftRhs + :: Maybe (DIdSet) + -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@ + -- as lambda binders, discarding all free vars. + -> LlStgRhs + -> LiftM OutStgRhs +liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args) + = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs) + StgRhsCon ccs con <$> traverse liftArgs args +liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do + -- This RHS wasn't lifted. + withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> + StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body +liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do + -- This RHS was lifted. Insert extra binders for @former_fvs@. + withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do + let bndrs'' = dVarSetElems former_fvs ++ bndrs' + StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body + +liftArgs :: InStgArg -> LiftM OutStgArg +liftArgs a@(StgLitArg _) = pure a +liftArgs (StgVarArg occ) = do + ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ ) + StgVarArg <$> substOcc occ + +liftExpr :: LlStgExpr -> LiftM OutStgExpr +liftExpr (StgLit lit) = pure (StgLit lit) +liftExpr (StgTick t e) = StgTick t <$> liftExpr e +liftExpr (StgApp f args) = do + f' <- substOcc f + args' <- traverse liftArgs args + fvs' <- formerFreeVars f + let top_lvl_args = map StgVarArg fvs' ++ args' + pure (StgApp f' top_lvl_args) +liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys +liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty +liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") +liftExpr (StgCase scrut info ty alts) = do + scrut' <- liftExpr scrut + withSubstBndr (binderInfoBndr info) $ \bndr' -> do + alts' <- traverse liftAlt alts + pure (StgCase scrut' bndr' ty alts') +liftExpr (StgLet scope bind body) + = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do + body' <- liftExpr body + case mb_bind' of + Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats + Just bind' -> pure (StgLet noExtFieldSilent bind' body') +liftExpr (StgLetNoEscape scope bind body) + = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do + body' <- liftExpr body + case mb_bind' of + Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs") + Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body') + +liftAlt :: LlStgAlt -> LiftM OutStgAlt +liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> + (,,) con bndrs' <$> liftExpr rhs diff --git a/GHC/Stg/Lift/Analysis.hs b/GHC/Stg/Lift/Analysis.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift/Analysis.hs @@ -0,0 +1,568 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +-- | Provides the heuristics for when it's beneficial to lambda lift bindings. +-- Most significantly, this employs a cost model to estimate impact on heap +-- allocations, by looking at an STG expression's 'Skeleton'. +module GHC.Stg.Lift.Analysis ( + -- * #when# When to lift + -- $when + + -- * #clogro# Estimating closure growth + -- $clogro + + -- * AST annotation + Skeleton(..), BinderInfo(..), binderInfoBndr, + LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind, + -- * Lifting decision + goodToLift, + closureGrowth -- Exported just for the docs + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Types.Basic +import GHC.Types.Demand +import GHC.Driver.Session +import GHC.Types.Id +import GHC.Runtime.Heap.Layout ( WordOff ) +import GHC.Stg.Syntax +import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep +import qualified GHC.StgToCmm.Closure as StgToCmm.Closure +import qualified GHC.StgToCmm.Layout as StgToCmm.Layout +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Var.Set + +import Data.Maybe ( mapMaybe ) + +-- Note [When to lift] +-- ~~~~~~~~~~~~~~~~~~~ +-- $when +-- The analysis proceeds in two steps: +-- +-- 1. It tags the syntax tree with analysis information in the form of +-- 'BinderInfo' at each binder and 'Skeleton's at each let-binding +-- by 'tagSkeletonTopBind' and friends. +-- 2. The resulting syntax tree is treated by the "GHC.Stg.Lift" +-- module, calling out to 'goodToLift' to decide if a binding is worthwhile +-- to lift. +-- 'goodToLift' consults argument occurrence information in 'BinderInfo' +-- and estimates 'closureGrowth', for which it needs the 'Skeleton'. +-- +-- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift', +-- which employs a number of heuristics to identify and exclude lambda lifting +-- opportunities deemed non-beneficial: +-- +-- [Top-level bindings] can't be lifted. +-- [Thunks] and data constructors shouldn't be lifted in order not to destroy +-- sharing. +-- [Argument occurrences] #arg_occs# of binders prohibit them to be lifted. +-- Doing the lift would re-introduce the very allocation at call sites that +-- we tried to get rid off in the first place. We capture analysis +-- information in 'BinderInfo'. Note that we also consider a nullary +-- application as argument occurrence, because it would turn into an n-ary +-- partial application created by a generic apply function. This occurs in +-- CPS-heavy code like the CS benchmark. +-- [Join points] should not be lifted, simply because there's no reduction in +-- allocation to be had. +-- [Abstracting over join points] destroys join points, because they end up as +-- arguments to the lifted function. +-- [Abstracting over known local functions] turns a known call into an unknown +-- call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off +-- with @-fstg-lift-lams-known@. +-- [Calling convention] Don't lift when the resulting function would have a +-- higher arity than available argument registers for the calling convention. +-- Can be influenced with @-fstg-lift-(non)rec-args(-any)@. +-- [Closure growth] introduced when former free variables have to be available +-- at call sites may actually lead to an increase in overall allocations +-- resulting from a lift. Estimating closure growth is described in +-- "GHC.Stg.Lift.Analysis#clogro" and is what most of this module is ultimately +-- concerned with. +-- +-- There's a with +-- some more background and history. + +-- Note [Estimating closure growth] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- $clogro +-- We estimate closure growth by abstracting the syntax tree into a 'Skeleton', +-- capturing only syntactic details relevant to 'closureGrowth', such as +-- +-- * 'ClosureSk', representing closure allocation. +-- * 'RhsSk', representing a RHS of a binding and how many times it's called +-- by an appropriate 'DmdShell'. +-- * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element. +-- +-- This abstraction is mostly so that the main analysis function 'closureGrowth' +-- can stay simple and focused. Also, skeletons tend to be much smaller than +-- the syntax tree they abstract, so it makes sense to construct them once and +-- and operate on them instead of the actual syntax tree. +-- +-- A more detailed treatment of computing closure growth, including examples, +-- can be found in the paper referenced from the +-- . + +llTrace :: String -> SDoc -> a -> a +llTrace _ _ c = c +-- llTrace a b c = pprTrace a b c + +type instance BinderP 'LiftLams = BinderInfo +type instance XRhsClosure 'LiftLams = DIdSet +type instance XLet 'LiftLams = Skeleton +type instance XLetNoEscape 'LiftLams = Skeleton + +freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet +freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] +freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs + +-- | Captures details of the syntax tree relevant to the cost model, such as +-- closures, multi-shot lambdas and case expressions. +data Skeleton + = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton + | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton + | AltSk !Skeleton !Skeleton + | BothSk !Skeleton !Skeleton + | NilSk + +bothSk :: Skeleton -> Skeleton -> Skeleton +bothSk NilSk b = b +bothSk a NilSk = a +bothSk a b = BothSk a b + +altSk :: Skeleton -> Skeleton -> Skeleton +altSk NilSk b = b +altSk a NilSk = a +altSk a b = AltSk a b + +rhsSk :: DmdShell -> Skeleton -> Skeleton +rhsSk _ NilSk = NilSk +rhsSk body_dmd skel = RhsSk body_dmd skel + +-- | The type used in binder positions in 'GenStgExpr's. +data BinderInfo + = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag + -- indicating whether it occurs as an argument + -- or in a nullary application + -- (see "GHC.Stg.Lift.Analysis#arg_occs"). + | BoringBinder !Id -- ^ Every other kind of binder + +-- | Gets the bound 'Id' out a 'BinderInfo'. +binderInfoBndr :: BinderInfo -> Id +binderInfoBndr (BoringBinder bndr) = bndr +binderInfoBndr (BindsClosure bndr _) = bndr + +-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating +-- occurrences as argument or in a nullary applications otherwise. +binderInfoOccursAsArg :: BinderInfo -> Maybe Bool +binderInfoOccursAsArg BoringBinder{} = Nothing +binderInfoOccursAsArg (BindsClosure _ b) = Just b + +instance Outputable Skeleton where + ppr NilSk = text "" + ppr (AltSk l r) = vcat + [ text "{ " <+> ppr l + , text "ALT" + , text " " <+> ppr r + , text "}" + ] + ppr (BothSk l r) = ppr l $$ ppr r + ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body) + ppr (RhsSk body_dmd body) = hcat + [ text "λ[" + , ppr str + , text ", " + , ppr use + , text "]. " + , ppr body + ] + where + str + | isStrictDmd body_dmd = '1' + | otherwise = '0' + use + | isAbsDmd body_dmd = '0' + | isUsedOnce body_dmd = '1' + | otherwise = 'ω' + +instance Outputable BinderInfo where + ppr = ppr . binderInfoBndr + +instance OutputableBndr BinderInfo where + pprBndr b = pprBndr b . binderInfoBndr + pprPrefixOcc = pprPrefixOcc . binderInfoBndr + pprInfixOcc = pprInfixOcc . binderInfoBndr + bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr + +mkArgOccs :: [StgArg] -> IdSet +mkArgOccs = mkVarSet . mapMaybe stg_arg_var + where + stg_arg_var (StgVarArg occ) = Just occ + stg_arg_var _ = Nothing + +-- | Tags every binder with its 'BinderInfo' and let bindings with their +-- 'Skeleton's. +tagSkeletonTopBind :: CgStgBinding -> LlStgBinding +-- NilSk is OK when tagging top-level bindings. Also, top-level things are never +-- lambda-lifted, so no need to track their argument occurrences. They can also +-- never be let-no-escapes (thus we pass False). +tagSkeletonTopBind bind = bind' + where + (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind + +-- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with +-- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder +-- occurrences in argument and nullary application position +-- (cf. "GHC.Stg.Lift.Analysis#arg_occs"). +tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr) +tagSkeletonExpr (StgLit lit) + = (NilSk, emptyVarSet, StgLit lit) +tagSkeletonExpr (StgConApp con args tys) + = (NilSk, mkArgOccs args, StgConApp con args tys) +tagSkeletonExpr (StgOpApp op args ty) + = (NilSk, mkArgOccs args, StgOpApp op args ty) +tagSkeletonExpr (StgApp f args) + = (NilSk, arg_occs, StgApp f args) + where + arg_occs + -- This checks for nullary applications, which we treat the same as + -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs". + | null args = unitVarSet f + | otherwise = mkArgOccs args +tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") +tagSkeletonExpr (StgCase scrut bndr ty alts) + = (skel, arg_occs, StgCase scrut' bndr' ty alts') + where + (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut + (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts + skel = bothSk scrut_skel (foldr altSk NilSk alt_skels) + arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr + bndr' = BoringBinder bndr +tagSkeletonExpr (StgTick t e) + = (skel, arg_occs, StgTick t e') + where + (skel, arg_occs, e') = tagSkeletonExpr e +tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind +tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind + +mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr +mkLet True = StgLetNoEscape +mkLet _ = StgLet + +tagSkeletonLet + :: Bool + -- ^ Is the binding a let-no-escape? + -> CgStgExpr + -- ^ Let body + -> CgStgBinding + -- ^ Binding group + -> (Skeleton, IdSet, LlStgExpr) + -- ^ RHS skeletons, argument occurrences and annotated binding +tagSkeletonLet is_lne body bind + = (let_skel, arg_occs, mkLet is_lne scope bind' body') + where + (body_skel, body_arg_occs, body') = tagSkeletonExpr body + (let_skel, arg_occs, scope, bind') + = tagSkeletonBinding is_lne body_skel body_arg_occs bind + +tagSkeletonBinding + :: Bool + -- ^ Is the binding a let-no-escape? + -> Skeleton + -- ^ Let body skeleton + -> IdSet + -- ^ Argument occurrences in the body + -> CgStgBinding + -- ^ Binding group + -> (Skeleton, IdSet, Skeleton, LlStgBinding) + -- ^ Let skeleton, argument occurrences, scope skeleton of binding and + -- the annotated binding +tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs) + = (let_skel, arg_occs, scope, bind') + where + (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs + arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr + bind_skel + | is_lne = rhs_skel -- no closure is allocated for let-no-escapes + | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel + let_skel = bothSk body_skel bind_skel + occurs_as_arg = bndr `elemVarSet` body_arg_occs + -- Compared to the recursive case, this exploits the fact that @bndr@ is + -- never free in @rhs@. + scope = body_skel + bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs' +tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs) + = (let_skel, arg_occs, scope, StgRec pairs') + where + (bndrs, _) = unzip pairs + -- Local recursive STG bindings also regard the defined binders as free + -- vars. We want to delete those for our cost model, as these are known + -- calls anyway when we add them to the same top-level recursive group as + -- the top-level binding currently being analysed. + skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs + rhss_arg_occs = map sndOf3 skel_occs_rhss' + scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs) + arg_occs = scope_occs `delVarSetList` bndrs + -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment, + -- but we also need the un-wrapped skeletons for calculating the @scope@ + -- of the group, as the outer closures don't contribute to closure growth + -- when we lift this specific binding. + scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss' + -- Now we can build the actual Skeleton for the expression just by + -- iterating over each bind pair. + (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss') + let_skel = foldr bothSk body_skel bind_skels + single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs')) + where + -- Here, we finally add the closure around each @skel_rhs@. + bind_skel + | is_lne = skel_rhs -- no closure is allocated for let-no-escapes + | otherwise = ClosureSk bndr fvs skel_rhs + fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs + bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs) + +tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs) +tagSkeletonRhs _ (StgRhsCon ccs dc args) + = (NilSk, mkArgOccs args, StgRhsCon ccs dc args) +tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body) + = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body') + where + bndrs' = map BoringBinder bndrs + (body_skel, body_arg_occs, body') = tagSkeletonExpr body + rhs_skel = rhsSk (rhsDmdShell bndr) body_skel + +-- | How many times will the lambda body of the RHS bound to the given +-- identifier be evaluated, relative to its defining context? This function +-- computes the answer in form of a 'DmdShell'. +rhsDmdShell :: Id -> DmdShell +rhsDmdShell bndr + | is_thunk = oneifyDmd ds + | otherwise = peelManyCalls (idArity bndr) cd + where + is_thunk = idArity bndr == 0 + -- Let's pray idDemandInfo is still OK after unarise... + (ds, cd) = toCleanDmd (idDemandInfo bndr) + +tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt) +tagSkeletonAlt (con, bndrs, rhs) + = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs')) + where + (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs + arg_occs = alt_arg_occs `delVarSetList` bndrs + +-- | Combines several heuristics to decide whether to lambda-lift a given +-- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details. +goodToLift + :: DynFlags + -> TopLevelFlag + -> RecFlag + -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into + -- 'OutId's. See 'GHC.Stg.Lift.Monad.liftedIdsExpander'. + -> [(BinderInfo, LlStgRhs)] + -> Skeleton + -> Maybe DIdSet -- ^ @Just abs_ids@ <=> This binding is beneficial to + -- lift and @abs_ids@ are the variables it would + -- abstract over +goodToLift dflags top_lvl rec_flag expander pairs scope = decide + [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift] + , ("memoized", any_memoized) + , ("argument occurrences", arg_occs) + , ("join point", is_join_point) + , ("abstracts join points", abstracts_join_ids) + , ("abstracts known local function", abstracts_known_local_fun) + , ("args spill on stack", args_spill_on_stack) + , ("increases allocation", inc_allocs) + ] where + platform = targetPlatform dflags + decide deciders + | not (fancy_or deciders) + = llTrace "stgLiftLams:lifting" + (ppr bndrs <+> ppr abs_ids $$ + ppr allocs $$ + ppr scope) $ + Just abs_ids + | otherwise + = Nothing + ppr_deciders = vcat . map (text . fst) . filter snd + fancy_or deciders + = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $ + any snd deciders + + bndrs = map (binderInfoBndr . fst) pairs + bndrs_set = mkVarSet bndrs + rhss = map snd pairs + + -- First objective: Calculate @abs_ids@, e.g. the former free variables + -- the lifted binding would abstract over. We have to merge the free + -- variables of all RHS to get the set of variables that will have to be + -- passed through parameters. + fvs = unionDVarSets (map freeVarsOfRhs rhss) + -- To lift the binding to top-level, we want to delete the lifted binders + -- themselves from the free var set. Local let bindings track recursive + -- occurrences in their free variable set. We neither want to apply our + -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters + -- when lifted, as these are known calls. We call the resulting set the + -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's. + -- We will save the set in 'LiftM.e_expansions' for each of the variables + -- if we perform the lift. + abs_ids = expander (delDVarSetList fvs bndrs) + + -- We don't lift updatable thunks or constructors + any_memoized = any is_memoized_rhs rhss + is_memoized_rhs StgRhsCon{} = True + is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd + + -- Don't lift binders occurring as arguments. This would result in complex + -- argument expressions which would have to be given a name, reintroducing + -- the very allocation at each call site that we wanted to get rid off in + -- the first place. + arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs) + + -- These don't allocate anyway. + is_join_point = any isJoinId bndrs + + -- Abstracting over join points/let-no-escapes spoils them. + abstracts_join_ids = any isJoinId (dVarSetElems abs_ids) + + -- Abstracting over known local functions that aren't floated themselves + -- turns a known, fast call into an unknown, slow call: + -- + -- let f x = ... + -- g y = ... f x ... -- this was a known call + -- in g 4 + -- + -- After lifting @g@, but not @f@: + -- + -- l_g f y = ... f y ... -- this is now an unknown call + -- let f x = ... + -- in l_g f 4 + -- + -- We can abuse the results of arity analysis for this: + -- idArity f > 0 ==> known + known_fun id = idArity id > 0 + abstracts_known_local_fun + = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids) + + -- Number of arguments of a RHS in the current binding group if we decide + -- to lift it + n_args + = length + . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm + . (dVarSetElems abs_ids ++) + . rhsLambdaBndrs + max_n_args + | isRec rec_flag = liftLamsRecArgs dflags + | otherwise = liftLamsNonRecArgs dflags + -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess + -- args are passed on the stack, which means slow memory accesses + args_spill_on_stack + | Just n <- max_n_args = maximum (map n_args rhss) > n + | otherwise = False + + -- We only perform the lift if allocations didn't increase. + -- Note that @clo_growth@ will be 'infinity' if there was positive growth + -- under a multi-shot lambda. + -- Also, abstracting over LNEs is unacceptable. LNEs might return + -- unlifted tuples, which idClosureFootprint can't cope with. + inc_allocs = abstracts_join_ids || allocs > 0 + allocs = clo_growth + mkIntWithInf (negate closuresSize) + -- We calculate and then add up the size of each binding's closure. + -- GHC does not currently share closure environments, and we either lift + -- the entire recursive binding group or none of it. + closuresSize = sum $ flip map rhss $ \rhs -> + closureSize dflags + . dVarSetElems + . expander + . flip dVarSetMinusVarSet bndrs_set + $ freeVarsOfRhs rhs + clo_growth = closureGrowth expander (idClosureFootprint platform) bndrs_set abs_ids scope + +rhsLambdaBndrs :: LlStgRhs -> [Id] +rhsLambdaBndrs StgRhsCon{} = [] +rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs + +-- | The size in words of a function closure closing over the given 'Id's, +-- including the header. +closureSize :: DynFlags -> [Id] -> WordOff +closureSize dflags ids = words + sTD_HDR_SIZE dflags + -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't + -- optimise differently when profiling is enabled. + where + (words, _, _) + -- Functions have a StdHeader (as opposed to ThunkHeader). + = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader + . StgToCmm.Closure.addIdReps + . StgToCmm.Closure.nonVoidIds + $ ids + +-- | The number of words a single 'Id' adds to a closure's size. +-- Note that this can't handle unboxed tuples (which may still be present in +-- let-no-escapes, even after Unarise), in which case +-- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. +idClosureFootprint:: Platform -> Id -> WordOff +idClosureFootprint platform + = StgToCmm.ArgRep.argRepSizeW platform + . StgToCmm.ArgRep.idArgRep + +-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words +-- as a result of lifting @f@ to top-level. If there was any growing closure +-- under a multi-shot lambda, the result will be 'infinity'. +-- Also see "GHC.Stg.Lift.Analysis#clogro". +closureGrowth + :: (DIdSet -> DIdSet) + -- ^ Expands outer free ids that were lifted to their free vars + -> (Id -> Int) + -- ^ Computes the closure footprint of an identifier + -> IdSet + -- ^ Binding group for which lifting is to be decided + -> DIdSet + -- ^ Free vars of the whole binding group prior to lifting it. These must be + -- available at call sites if we decide to lift the binding group. + -> Skeleton + -- ^ Abstraction of the scope of the function + -> IntWithInf + -- ^ Closure growth. 'infinity' indicates there was growth under a + -- (multi-shot) lambda. +closureGrowth expander sizer group abs_ids = go + where + go NilSk = 0 + go (BothSk a b) = go a + go b + go (AltSk a b) = max (go a) (go b) + go (ClosureSk _ clo_fvs rhs) + -- If no binder of the @group@ occurs free in the closure, the lifting + -- won't have any effect on it and we can omit the recursive call. + | n_occs == 0 = 0 + -- Otherwise, we account the cost of allocating the closure and add it to + -- the closure growth of its RHS. + | otherwise = mkIntWithInf cost + go rhs + where + n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group) + -- What we close over considering prior lifting decisions + clo_fvs' = expander clo_fvs + -- Variables that would additionally occur free in the closure body if + -- we lift @f@ + newbies = abs_ids `minusDVarSet` clo_fvs' + -- Lifting @f@ removes @f@ from the closure but adds all @newbies@ + cost = nonDetStrictFoldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs + -- Using a non-deterministic fold is OK here because addition is commutative. + go (RhsSk body_dmd body) + -- The conservative assumption would be that + -- 1. Every RHS with positive growth would be called multiple times, + -- modulo thunks. + -- 2. Every RHS with negative growth wouldn't be called at all. + -- + -- In the first case, we'd have to return 'infinity', while in the + -- second case, we'd have to return 0. But we can do far better + -- considering information from the demand analyser, which provides us + -- with conservative estimates on minimum and maximum evaluation + -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of + -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body + -- relative to its defining context. + | isAbsDmd body_dmd = 0 + | cg <= 0 = if isStrictDmd body_dmd then cg else 0 + | isUsedOnce body_dmd = cg + | otherwise = infinity + where + cg = go body diff --git a/GHC/Stg/Lift/Monad.hs b/GHC/Stg/Lift/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift/Monad.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM' +-- monad. +module GHC.Stg.Lift.Monad ( + decomposeStgBinding, mkStgBinding, + Env (..), + -- * #floats# Handling floats + -- $floats + FloatLang (..), collectFloats, -- Exported just for the docs + -- * Transformation monad + LiftM, runLiftM, + -- ** Adding bindings + startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding, + -- ** Substitution and binders + withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs, + -- ** Occurrences + substOcc, isLifted, formerFreeVars, liftedIdsExpander + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS ) +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Data.OrdList +import GHC.Stg.Subst +import GHC.Stg.Syntax +import GHC.Core.Utils +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.Multiplicity + +import Control.Arrow ( second ) +import Control.Monad.Trans.Class +import Control.Monad.Trans.RWS.Strict ( RWST, runRWST ) +import qualified Control.Monad.Trans.RWS.Strict as RWS +import Control.Monad.Trans.Cont ( ContT (..) ) +import Data.ByteString ( ByteString ) + +-- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@ +decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)]) +decomposeStgBinding (StgRec pairs) = (Recursive, pairs) +decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)]) + +mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass +mkStgBinding Recursive = StgRec +mkStgBinding NonRecursive = uncurry StgNonRec . head + +-- | Environment threaded around in a scoped, @Reader@-like fashion. +data Env + = Env + { e_dflags :: !DynFlags + -- ^ Read-only. + , e_subst :: !Subst + -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId', + -- because shadowing might make a closure's free variables unavailable at its + -- call sites. Consider: + -- @ + -- let f y = x + y in let x = 4 in f x + -- @ + -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't + -- available at its call site. + , e_expansions :: !(IdEnv DIdSet) + -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because + -- they are bound at the top-level. Every occurrence must supply the formerly + -- free variables of the lifted 'Id', so they in turn become free variables of + -- the call sites. This environment tracks this expansion from lifted 'Id's to + -- their free variables. + -- + -- 'InId's to 'OutId's. + -- + -- Invariant: 'Id's not present in this map won't be substituted. + } + +emptyEnv :: DynFlags -> Env +emptyEnv dflags = Env dflags emptySubst emptyVarEnv + + +-- Note [Handling floats] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- $floats +-- Consider the following expression: +-- +-- @ +-- f x = +-- let g y = ... f y ... +-- in g x +-- @ +-- +-- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@ +-- binding above the binding for @f@: +-- +-- @ +-- g f y = ... f y ... +-- f x = g f x +-- @ +-- +-- But this very unnecessarily turns a known call to @f@ into an unknown one, in +-- addition to complicating matters for the analysis. +-- Instead, we'd really like to put both functions in the same recursive group, +-- thereby preserving the known call: +-- +-- @ +-- Rec { +-- g y = ... f y ... +-- f x = g x +-- } +-- @ +-- +-- But we don't want this to happen for just /any/ binding. That would create +-- possibly huge recursive groups in the process, calling for an occurrence +-- analyser on STG. +-- So, we need to track when we lift a binding out of a recursive RHS and add +-- the binding to the same recursive group as the enclosing recursive binding +-- (which must have either already been at the top-level or decided to be +-- lifted itself in order to preserve the known call). +-- +-- This is done by expressing this kind of nesting structure as a 'Writer' over +-- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to +-- 'collectFloats'. +-- API-wise, the analysis will not need to know about the whole 'FloatLang' +-- business and will just manipulate it indirectly through actions in 'LiftM'. + +-- | We need to detect when we are lifting something out of the RHS of a +-- recursive binding (c.f. "GHC.Stg.Lift.Monad#floats"), in which case that +-- binding needs to be added to the same top-level recursive group. This +-- requires we detect a certain nesting structure, which is encoded by +-- 'StartBindingGroup' and 'EndBindingGroup'. +-- +-- Although 'collectFloats' will only ever care if the current binding to be +-- lifted (through 'LiftedBinding') will occur inside such a binding group or +-- not, e.g. doesn't care about the nesting level as long as its greater than 0. +data FloatLang + = StartBindingGroup + | EndBindingGroup + | PlainTopBinding OutStgTopBinding + | LiftedBinding OutStgBinding + +instance Outputable FloatLang where + ppr StartBindingGroup = char '(' + ppr EndBindingGroup = char ')' + ppr (PlainTopBinding StgTopStringLit{}) = text "" + ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b) + ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs) + where + (rec, pairs) = decomposeStgBinding bind + +-- | Flattens an expression in @['FloatLang']@ into an STG program, see "GHC.Stg.Lift.Monad#floats". +-- Important pre-conditions: The nesting of opening 'StartBindinGroup's and +-- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding +-- group has at least one recursive binding inside. Otherwise there's no point +-- in announcing the binding group in the first place and an @ASSERT@ will +-- trigger. +collectFloats :: [FloatLang] -> [OutStgTopBinding] +collectFloats = go (0 :: Int) [] + where + go 0 [] [] = [] + go _ _ [] = pprPanic "collectFloats" (text "unterminated group") + go n binds (f:rest) = case f of + StartBindingGroup -> go (n+1) binds rest + EndBindingGroup + | n == 0 -> pprPanic "collectFloats" (text "no group to end") + | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest + | otherwise -> go (n-1) binds rest + PlainTopBinding top_bind + | n == 0 -> top_bind : go n binds rest + | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group") + LiftedBinding bind + | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest + | otherwise -> go n (bind:binds) rest + + map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding + rm_cccs = map_rhss removeRhsCCCS + merge_binds binds = ASSERT( any is_rec binds ) + StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds) + is_rec StgRec{} = True + is_rec _ = False + +-- | Omitting this makes for strange closure allocation schemes that crash the +-- GC. +removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass +removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body) + | isCurrentCCS ccs + = StgRhsClosure ext dontCareCCS upd bndrs body +removeRhsCCCS (StgRhsCon ccs con args) + | isCurrentCCS ccs + = StgRhsCon dontCareCCS con args +removeRhsCCCS rhs = rhs + +-- | The analysis monad consists of the following 'RWST' components: +-- +-- * 'Env': Reader-like context. Contains a substitution, info about how +-- how lifted identifiers are to be expanded into applications and details +-- such as 'DynFlags'. +-- +-- * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program. +-- +-- * No pure state component +-- +-- * But wrapping around 'UniqSM' for generating fresh lifted binders. +-- (The @uniqAway@ approach could give the same name to two different +-- lifted binders, so this is necessary.) +newtype LiftM a + = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a } + deriving (Functor, Applicative, Monad) + +instance HasDynFlags LiftM where + getDynFlags = LiftM (RWS.asks e_dflags) + +instance MonadUnique LiftM where + getUniqueSupplyM = LiftM (lift getUniqueSupplyM) + getUniqueM = LiftM (lift getUniqueM) + getUniquesM = LiftM (lift getUniquesM) + +runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding] +runLiftM dflags us (LiftM m) = collectFloats (fromOL floats) + where + (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ()) + +-- | Writes a plain 'StgTopStringLit' to the output. +addTopStringLit :: OutId -> ByteString -> LiftM () +addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id + +-- | Starts a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'. +startBindingGroup :: LiftM () +startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup + +-- | Ends a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'. +endBindingGroup :: LiftM () +endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup + +-- | Lifts a binding to top-level. Depending on whether it's declared inside +-- a recursive RHS (see "GHC.Stg.Lift.Monad#floats" and 'collectFloats'), this might be added to +-- an existing recursive top-level binding group. +addLiftedBinding :: OutStgBinding -> LiftM () +addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding + +-- | Takes a binder and a continuation which is called with the substituted +-- binder. The continuation will be evaluated in a 'LiftM' context in which that +-- binder is deemed in scope. Think of it as a 'RWS.local' computation: After +-- the continuation finishes, the new binding won't be in scope anymore. +withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a +withSubstBndr bndr inner = LiftM $ do + subst <- RWS.asks e_subst + let (bndr', subst') = substBndr bndr subst + RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr')) + +-- | See 'withSubstBndr'. +withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a +withSubstBndrs = runContT . traverse (ContT . withSubstBndr) + +-- | Similarly to 'withSubstBndr', this function takes a set of variables to +-- abstract over, the binder to lift (and generate a fresh, substituted name +-- for) and a continuation in which that fresh, lifted binder is in scope. +-- +-- It takes care of all the details involved with copying and adjusting the +-- binder and fresh name generation. +withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a +withLiftedBndr abs_ids bndr inner = do + uniq <- getUniqueM + let str = "$l" ++ occNameString (getOccName bndr) + let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) + let bndr' + -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least + -- for arity information. + = transferPolyIdInfo bndr (dVarSetElems abs_ids) + . mkSysLocal (mkFastString str) uniq Many + $ ty + LiftM $ RWS.local + (\e -> e + { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e + , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids + }) + (unwrapLiftM (inner bndr')) + +-- | See 'withLiftedBndr'. +withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a +withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids) + +-- | Substitutes a binder /occurrence/, which was brought in scope earlier by +-- 'withSubstBndr' \/ 'withLiftedBndr'. +substOcc :: Id -> LiftM Id +substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst)) + +-- | Whether the given binding was decided to be lambda lifted. +isLifted :: InId -> LiftM Bool +isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions)) + +-- | Returns an empty list for a binding that was not lifted and the list of all +-- local variables the binding abstracts over (so, exactly the additional +-- arguments at adjusted call sites) otherwise. +formerFreeVars :: InId -> LiftM [OutId] +formerFreeVars f = LiftM $ do + expansions <- RWS.asks e_expansions + pure $ case lookupVarEnv expansions f of + Nothing -> [] + Just fvs -> dVarSetElems fvs + +-- | Creates an /expander function/ for the current set of lifted binders. +-- This expander function will replace any 'InId' by their corresponding 'OutId' +-- and, in addition, will expand any lifted binders by the former free variables +-- it abstracts over. +liftedIdsExpander :: LiftM (DIdSet -> DIdSet) +liftedIdsExpander = LiftM $ do + expansions <- RWS.asks e_expansions + subst <- RWS.asks e_subst + -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope" + -- warnings generated by 'lookupIdSubst' due to local bindings within RHS. + -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in + -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much + -- trouble. + let go set fv = case lookupVarEnv expansions fv of + Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted + Just fvs' -> unionDVarSet set fvs' + let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs) + pure expander diff --git a/GHC/Stg/Lint.hs b/GHC/Stg/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lint.hs @@ -0,0 +1,389 @@ +{- | +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +A lint pass to check basic STG invariants: + +- Variables should be defined before used. + +- Let bindings should not have unboxed types (unboxed bindings should only + appear in case), except when they're join points (see Note [Core let/app + invariant] and #14117). + +- If linting after unarisation, invariants listed in Note [Post-unarisation + invariants]. + +Because we don't have types and coercions in STG we can't really check types +here. + +Some history: + +StgLint used to check types, but it never worked and so it was disabled in 2000 +with this note: + + WARNING: + ~~~~~~~~ + + This module has suffered bit-rot; it is likely to yield lint errors + for Stg code that is currently perfectly acceptable for code + generation. Solution: don't use it! (KSW 2000-05). + +Since then there were some attempts at enabling it again, as summarised in +#14787. It's finally decided that we remove all type checking and only look for +basic properties listed above. +-} + +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, + DeriveFunctor #-} + +module GHC.Stg.Lint ( lintStgTopBindings ) where + +import GHC.Prelude + +import GHC.Stg.Syntax + +import GHC.Driver.Session +import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) +import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel ) +import GHC.Types.CostCentre ( isCurrentCCS ) +import GHC.Types.Id ( Id, idType, isJoinId, idName ) +import GHC.Types.Var.Set +import GHC.Core.DataCon +import GHC.Core ( AltCon(..) ) +import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) +import GHC.Utils.Error ( MsgDoc, Severity(..), mkLocMessage ) +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Unit.Module ( Module ) +import qualified GHC.Utils.Error as Err +import Control.Applicative ((<|>)) +import Control.Monad + +lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) + => DynFlags + -> Module -- ^ module being compiled + -> Bool -- ^ have we run Unarise yet? + -> String -- ^ who produced the STG? + -> [GenStgTopBinding a] + -> IO () + +lintStgTopBindings dflags this_mod unarised whodunnit binds + = {-# SCC "StgLint" #-} + case initL this_mod unarised opts top_level_binds (lint_binds binds) of + Nothing -> + return () + Just msg -> do + putLogMsg dflags NoReason Err.SevDump noSrcSpan + $ withPprStyle defaultDumpStyle + (vcat [ text "*** Stg Lint ErrMsgs: in" <+> + text whodunnit <+> text "***", + msg, + text "*** Offending Program ***", + pprGenStgTopBindings opts binds, + text "*** End of Offense ***"]) + Err.ghcExit dflags 1 + where + opts = initStgPprOpts dflags + -- Bring all top-level binds into scope because CoreToStg does not generate + -- bindings in dependency order (so we may see a use before its definition). + top_level_binds = mkVarSet (bindersOfTopBinds binds) + + lint_binds :: [GenStgTopBinding a] -> LintM () + + lint_binds [] = return () + lint_binds (bind:binds) = do + binders <- lint_bind bind + addInScopeVars binders $ + lint_binds binds + + lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind + lint_bind (StgTopStringLit v _) = return [v] + +lintStgArg :: StgArg -> LintM () +lintStgArg (StgLitArg _) = return () +lintStgArg (StgVarArg v) = lintStgVar v + +lintStgVar :: Id -> LintM () +lintStgVar id = checkInScope id + +lintStgBinds + :: (OutputablePass a, BinderP a ~ Id) + => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders +lintStgBinds top_lvl (StgNonRec binder rhs) = do + lint_binds_help top_lvl (binder,rhs) + return [binder] + +lintStgBinds top_lvl (StgRec pairs) + = addInScopeVars binders $ do + mapM_ (lint_binds_help top_lvl) pairs + return binders + where + binders = [b | (b,_) <- pairs] + +lint_binds_help + :: (OutputablePass a, BinderP a ~ Id) + => TopLevelFlag + -> (Id, GenStgRhs a) + -> LintM () +lint_binds_help top_lvl (binder, rhs) + = addLoc (RhsOf binder) $ do + when (isTopLevel top_lvl) (checkNoCurrentCCS rhs) + lintStgRhs rhs + opts <- getStgPprOpts + -- Check binder doesn't have unlifted type or it's a join point + checkL (isJoinId binder || not (isUnliftedType (idType binder))) + (mkUnliftedTyMsg opts binder rhs) + +-- | Top-level bindings can't inherit the cost centre stack from their +-- (static) allocation site. +checkNoCurrentCCS + :: (OutputablePass a, BinderP a ~ Id) + => GenStgRhs a + -> LintM () +checkNoCurrentCCS rhs = do + opts <- getStgPprOpts + let rhs' = pprStgRhs opts rhs + case rhs of + StgRhsClosure _ ccs _ _ _ + | isCurrentCCS ccs + -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs') + StgRhsCon ccs _ _ + | isCurrentCCS ccs + -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs') + _ -> return () + +lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () + +lintStgRhs (StgRhsClosure _ _ _ [] expr) + = lintStgExpr expr + +lintStgRhs (StgRhsClosure _ _ _ binders expr) + = addLoc (LambdaBodyOf binders) $ + addInScopeVars binders $ + lintStgExpr expr + +lintStgRhs rhs@(StgRhsCon _ con args) = do + when (isUnboxedTupleCon con || isUnboxedSumCon con) $ do + opts <- getStgPprOpts + addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ + pprStgRhs opts rhs) + mapM_ lintStgArg args + mapM_ checkPostUnariseConArg args + +lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM () + +lintStgExpr (StgLit _) = return () + +lintStgExpr (StgApp fun args) = do + lintStgVar fun + mapM_ lintStgArg args + +lintStgExpr app@(StgConApp con args _arg_tys) = do + -- unboxed sums should vanish during unarise + lf <- getLintFlags + when (lf_unarised lf && isUnboxedSumCon con) $ do + opts <- getStgPprOpts + addErrL (text "Unboxed sum after unarise:" $$ + pprStgExpr opts app) + mapM_ lintStgArg args + mapM_ checkPostUnariseConArg args + +lintStgExpr (StgOpApp _ args _) = + mapM_ lintStgArg args + +lintStgExpr lam@(StgLam _ _) = do + opts <- getStgPprOpts + addErrL (text "Unexpected StgLam" <+> pprStgExpr opts lam) + +lintStgExpr (StgLet _ binds body) = do + binders <- lintStgBinds NotTopLevel binds + addLoc (BodyOfLetRec binders) $ + addInScopeVars binders $ + lintStgExpr body + +lintStgExpr (StgLetNoEscape _ binds body) = do + binders <- lintStgBinds NotTopLevel binds + addLoc (BodyOfLetRec binders) $ + addInScopeVars binders $ + lintStgExpr body + +lintStgExpr (StgTick _ expr) = lintStgExpr expr + +lintStgExpr (StgCase scrut bndr alts_type alts) = do + lintStgExpr scrut + + lf <- getLintFlags + let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf) + + addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts) + +lintAlt + :: (OutputablePass a, BinderP a ~ Id) + => (AltCon, [Id], GenStgExpr a) -> LintM () + +lintAlt (DEFAULT, _, rhs) = + lintStgExpr rhs + +lintAlt (LitAlt _, _, rhs) = + lintStgExpr rhs + +lintAlt (DataAlt _, bndrs, rhs) = do + mapM_ checkPostUnariseBndr bndrs + addInScopeVars bndrs (lintStgExpr rhs) + +{- +************************************************************************ +* * +The Lint monad +* * +************************************************************************ +-} + +newtype LintM a = LintM + { unLintM :: Module + -> LintFlags + -> StgPprOpts -- Pretty-printing options + -> [LintLocInfo] -- Locations + -> IdSet -- Local vars in scope + -> Bag MsgDoc -- Error messages so far + -> (a, Bag MsgDoc) -- Result and error messages (if any) + } + deriving (Functor) + +data LintFlags = LintFlags { lf_unarised :: !Bool + -- ^ have we run the unariser yet? + } + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf [Id] -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + +dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) +dumpLoc (RhsOf v) = + (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' ) +dumpLoc (LambdaBodyOf bs) = + (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) + +dumpLoc (BodyOfLetRec bs) = + (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' ) + + +pp_binders :: [Id] -> SDoc +pp_binders bs + = sep (punctuate comma (map pp_binder bs)) + where + pp_binder b + = hsep [ppr b, dcolon, ppr (idType b)] + +initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe MsgDoc +initL this_mod unarised opts locals (LintM m) = do + let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag + if isEmptyBag errs then + Nothing + else + Just (vcat (punctuate blankLine (bagToList errs))) + +instance Applicative LintM where + pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs) + (<*>) = ap + (*>) = thenL_ + +instance Monad LintM where + (>>=) = thenL + (>>) = (*>) + +thenL :: LintM a -> (a -> LintM b) -> LintM b +thenL m k = LintM $ \mod lf opts loc scope errs + -> case unLintM m mod lf opts loc scope errs of + (r, errs') -> unLintM (k r) mod lf opts loc scope errs' + +thenL_ :: LintM a -> LintM b -> LintM b +thenL_ m k = LintM $ \mod lf opts loc scope errs + -> case unLintM m mod lf opts loc scope errs of + (_, errs') -> unLintM k mod lf opts loc scope errs' + +checkL :: Bool -> MsgDoc -> LintM () +checkL True _ = return () +checkL False msg = addErrL msg + +-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders. +checkPostUnariseBndr :: Id -> LintM () +checkPostUnariseBndr bndr = do + lf <- getLintFlags + when (lf_unarised lf) $ + forM_ (checkPostUnariseId bndr) $ \unexpected -> + addErrL $ + text "After unarisation, binder " <> + ppr bndr <> text " has " <> text unexpected <> text " type " <> + ppr (idType bndr) + +-- Arguments shouldn't have sum, tuple, or void types. +checkPostUnariseConArg :: StgArg -> LintM () +checkPostUnariseConArg arg = case arg of + StgLitArg _ -> + return () + StgVarArg id -> do + lf <- getLintFlags + when (lf_unarised lf) $ + forM_ (checkPostUnariseId id) $ \unexpected -> + addErrL $ + text "After unarisation, arg " <> + ppr id <> text " has " <> text unexpected <> text " type " <> + ppr (idType id) + +-- Post-unarisation args and case alt binders should not have unboxed tuple, +-- unboxed sum, or void types. Return what the binder is if it is one of these. +checkPostUnariseId :: Id -> Maybe String +checkPostUnariseId id = + let + id_ty = idType id + is_sum, is_tuple, is_void :: Maybe String + is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum" + is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple" + is_void = guard (isVoidTy id_ty) >> return "void" + in + is_sum <|> is_tuple <|> is_void + +addErrL :: MsgDoc -> LintM () +addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc) + +addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc +addErr errs_so_far msg locs + = errs_so_far `snocBag` mk_msg locs + where + mk_msg (loc:_) = let (l,hdr) = dumpLoc loc + in mkLocMessage SevWarning l (hdr $$ msg) + mk_msg [] = msg + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m = LintM $ \mod lf opts loc scope errs + -> unLintM m mod lf opts (extra_loc:loc) scope errs + +addInScopeVars :: [Id] -> LintM a -> LintM a +addInScopeVars ids m = LintM $ \mod lf opts loc scope errs + -> let + new_set = mkVarSet ids + in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs) + +getStgPprOpts :: LintM StgPprOpts +getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs) + +checkInScope :: Id -> LintM () +checkInScope id = LintM $ \mod _lf _opts loc scope errs + -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then + ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id), + text "is out of scope"]) loc) + else + ((), errs) + +mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc +mkUnliftedTyMsg opts binder rhs + = (text "Let(rec) binder" <+> quotes (ppr binder) <+> + text "has unlifted type" <+> quotes (ppr (idType binder))) + $$ + (text "RHS:" <+> pprStgRhs opts rhs) diff --git a/GHC/Stg/Pipeline.hs b/GHC/Stg/Pipeline.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Pipeline.hs @@ -0,0 +1,150 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[SimplStg]{Driver for simplifying @STG@ programs} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Stg.Pipeline ( stg2stg ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Stg.Syntax + +import GHC.Stg.Lint ( lintStgTopBindings ) +import GHC.Stg.Stats ( showStgStats ) +import GHC.Stg.DepAnal ( depSortStgPgm ) +import GHC.Stg.Unarise ( unarise ) +import GHC.Stg.CSE ( stgCse ) +import GHC.Stg.Lift ( stgLiftLams ) +import GHC.Unit.Module ( Module ) + +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.State.Strict + +newtype StgM a = StgM { _unStgM :: StateT Char IO a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance MonadUnique StgM where + getUniqueSupplyM = StgM $ do { mask <- get + ; liftIO $! mkSplitUniqSupply mask} + getUniqueM = StgM $ do { mask <- get + ; liftIO $! uniqFromMask mask} + +runStgM :: Char -> StgM a -> IO a +runStgM mask (StgM m) = evalStateT m mask + +stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do + -> Module -- module being compiled + -> [StgTopBinding] -- input program + -> IO [StgTopBinding] -- output program + +stg2stg dflags this_mod binds + = do { dump_when Opt_D_dump_stg "STG:" binds + ; showPass dflags "Stg2Stg" + -- Do the main business! + ; binds' <- runStgM 'g' $ + foldM do_stg_pass binds (getStgToDo dflags) + + -- Dependency sort the program as last thing. The program needs to be + -- in dependency order for the SRT algorithm to work (see + -- CmmBuildInfoTables, which also includes a detailed description of + -- the algorithm), and we don't guarantee that the program is already + -- sorted at this point. #16192 is for simplifier not preserving + -- dependency order. We also don't guarantee that StgLiftLams will + -- preserve the order or only create minimal recursive groups, so a + -- sorting pass is necessary. + ; let binds_sorted = depSortStgPgm this_mod binds' + ; return binds_sorted + } + + where + stg_linter unarised + | gopt Opt_DoStgLinting dflags + = lintStgTopBindings dflags this_mod unarised + | otherwise + = \ _whodunnit _binds -> return () + + ------------------------------------------- + do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding] + do_stg_pass binds to_do + = case to_do of + StgDoNothing -> + return binds + + StgStats -> + trace (showStgStats binds) (return binds) + + StgCSE -> do + let binds' = {-# SCC "StgCse" #-} stgCse binds + end_pass "StgCse" binds' + + StgLiftLams -> do + us <- getUniqueSupplyM + let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds + end_pass "StgLiftLams" binds' + + StgUnarise -> do + us <- getUniqueSupplyM + liftIO (stg_linter False "Pre-unarise" binds) + let binds' = unarise us binds + liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds') + liftIO (stg_linter True "Unarise" binds') + return binds' + + opts = initStgPprOpts dflags + dump_when flag header binds + = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings opts binds) + + end_pass what binds2 + = liftIO $ do -- report verbosely, if required + dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what + FormatSTG (vcat (map (pprStgTopBinding opts) binds2)) + stg_linter False what binds2 + return binds2 + +-- ----------------------------------------------------------------------------- +-- StgToDo: abstraction of stg-to-stg passes to run. + +-- | Optional Stg-to-Stg passes. +data StgToDo + = StgCSE + -- ^ Common subexpression elimination + | StgLiftLams + -- ^ Lambda lifting closure variables, trading stack/register allocation for + -- heap allocation + | StgStats + | StgUnarise + -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders + | StgDoNothing + -- ^ Useful for building up 'getStgToDo' + deriving Eq + +-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc. +getStgToDo :: DynFlags -> [StgToDo] +getStgToDo dflags = + filter (/= StgDoNothing) + [ mandatory StgUnarise + -- Important that unarisation comes first + -- See Note [StgCse after unarisation] in GHC.Stg.CSE + , optional Opt_StgCSE StgCSE + , optional Opt_StgLiftLams StgLiftLams + , optional Opt_StgStats StgStats + ] where + optional opt = runWhen (gopt opt dflags) + mandatory = id + +runWhen :: Bool -> StgToDo -> StgToDo +runWhen True todo = todo +runWhen _ _ = StgDoNothing diff --git a/GHC/Stg/Stats.hs b/GHC/Stg/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Stats.hs @@ -0,0 +1,173 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[StgStats]{Gathers statistical information about programs} + + +The program gather statistics about +\begin{enumerate} +\item number of boxed cases +\item number of unboxed cases +\item number of let-no-escapes +\item number of non-updatable lets +\item number of updatable lets +\item number of applications +\item number of primitive applications +\item number of closures (does not include lets bound to constructors) +\item number of free variables in closures +%\item number of top-level functions +%\item number of top-level CAFs +\item number of constructors +\end{enumerate} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Stg.Stats ( showStgStats ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Stg.Syntax + +import GHC.Types.Id (Id) +import GHC.Utils.Panic + +import Data.Map (Map) +import qualified Data.Map as Map + +data CounterType + = Literals + | Applications + | ConstructorApps + | PrimitiveApps + | LetNoEscapes + | StgCases + | FreeVariables + | ConstructorBinds Bool{-True<=>top-level-} + | ReEntrantBinds Bool{-ditto-} + | SingleEntryBinds Bool{-ditto-} + | UpdatableBinds Bool{-ditto-} + deriving (Eq, Ord) + +type Count = Int +type StatEnv = Map CounterType Count + +emptySE :: StatEnv +emptySE = Map.empty + +combineSE :: StatEnv -> StatEnv -> StatEnv +combineSE = Map.unionWith (+) + +combineSEs :: [StatEnv] -> StatEnv +combineSEs = foldr combineSE emptySE + +countOne :: CounterType -> StatEnv +countOne c = Map.singleton c 1 + +{- +************************************************************************ +* * +\subsection{Top-level list of bindings (a ``program'')} +* * +************************************************************************ +-} + +showStgStats :: [StgTopBinding] -> String + +showStgStats prog + = "STG Statistics:\n\n" + ++ concatMap showc (Map.toList (gatherStgStats prog)) + where + showc (x,n) = (showString (s x) . shows n) "\n" + + s Literals = "Literals " + s Applications = "Applications " + s ConstructorApps = "ConstructorApps " + s PrimitiveApps = "PrimitiveApps " + s LetNoEscapes = "LetNoEscapes " + s StgCases = "StgCases " + s FreeVariables = "FreeVariables " + s (ConstructorBinds True) = "ConstructorBinds_Top " + s (ReEntrantBinds True) = "ReEntrantBinds_Top " + s (SingleEntryBinds True) = "SingleEntryBinds_Top " + s (UpdatableBinds True) = "UpdatableBinds_Top " + s (ConstructorBinds _) = "ConstructorBinds_Nested " + s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested " + s (SingleEntryBinds _) = "SingleEntryBinds_Nested " + s (UpdatableBinds _) = "UpdatableBinds_Nested " + +gatherStgStats :: [StgTopBinding] -> StatEnv +gatherStgStats binds = combineSEs (map statTopBinding binds) + +{- +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +statTopBinding :: StgTopBinding -> StatEnv +statTopBinding (StgTopStringLit _ _) = countOne Literals +statTopBinding (StgTopLifted bind) = statBinding True bind + +statBinding :: Bool -- True <=> top-level; False <=> nested + -> StgBinding + -> StatEnv + +statBinding top (StgNonRec b rhs) + = statRhs top (b, rhs) + +statBinding top (StgRec pairs) + = combineSEs (map (statRhs top) pairs) + +statRhs :: Bool -> (Id, StgRhs) -> StatEnv + +statRhs top (_, StgRhsCon _ _ _) + = countOne (ConstructorBinds top) + +statRhs top (_, StgRhsClosure _ _ u _ body) + = statExpr body `combineSE` + countOne ( + case u of + ReEntrant -> ReEntrantBinds top + Updatable -> UpdatableBinds top + SingleEntry -> SingleEntryBinds top + ) + +{- +************************************************************************ +* * +\subsection{Expressions} +* * +************************************************************************ +-} + +statExpr :: StgExpr -> StatEnv + +statExpr (StgApp _ _) = countOne Applications +statExpr (StgLit _) = countOne Literals +statExpr (StgConApp _ _ _)= countOne ConstructorApps +statExpr (StgOpApp _ _ _) = countOne PrimitiveApps +statExpr (StgTick _ e) = statExpr e + +statExpr (StgLetNoEscape _ binds body) + = statBinding False{-not top-level-} binds `combineSE` + statExpr body `combineSE` + countOne LetNoEscapes + +statExpr (StgLet _ binds body) + = statBinding False{-not top-level-} binds `combineSE` + statExpr body + +statExpr (StgCase expr _ _ alts) + = statExpr expr `combineSE` + stat_alts alts `combineSE` + countOne StgCases + where + stat_alts alts + = combineSEs (map statExpr [ e | (_,_,e) <- alts ]) + +statExpr (StgLam {}) = panic "statExpr StgLam" diff --git a/GHC/Stg/Subst.hs b/GHC/Stg/Subst.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Subst.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} + +module GHC.Stg.Subst where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Var.Env +import Control.Monad.Trans.State.Strict +import GHC.Utils.Outputable +import GHC.Utils.Misc + +-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not +-- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but +-- with the domain being 'Id's instead of entire 'CoreExpr'. +data Subst = Subst InScopeSet IdSubstEnv + +type IdSubstEnv = IdEnv Id + +-- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@ +emptySubst :: Subst +emptySubst = mkEmptySubst emptyInScopeSet + +-- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet' +-- are in scope. +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv + +-- | Substitutes an 'Id' for another one according to the 'Subst' given in a way +-- that avoids shadowing the 'InScopeSet', returning the result and an updated +-- 'Subst' that should be used by subsequent substitutions. +substBndr :: Id -> Subst -> (Id, Subst) +substBndr id (Subst in_scope env) + = (new_id, Subst new_in_scope new_env) + where + new_id = uniqAway in_scope id + no_change = new_id == id -- in case nothing shadowed + new_in_scope = in_scope `extendInScopeSet` new_id + new_env + | no_change = delVarEnv env id + | otherwise = extendVarEnv env id new_id + +-- | @substBndrs = runState . traverse (state . substBndr)@ +substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst) +substBndrs = runState . traverse (state . substBndr) + +-- | Substitutes an occurrence of an identifier for its counterpart recorded +-- in the 'Subst'. +lookupIdSubst :: HasCallStack => Id -> Subst -> Id +lookupIdSubst id (Subst in_scope env) + | not (isLocalId id) = id + | Just id' <- lookupVarEnv env id = id' + | Just id' <- lookupInScope in_scope id = id' + | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope) + id + +-- | Substitutes an occurrence of an identifier for its counterpart recorded +-- in the 'Subst'. Does not generate a debug warning if the identifier to +-- to substitute wasn't in scope. +noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id +noWarnLookupIdSubst id (Subst in_scope env) + | not (isLocalId id) = id + | Just id' <- lookupVarEnv env id = id' + | Just id' <- lookupInScope in_scope id = id' + | otherwise = id + +-- | Add the 'Id' to the in-scope set and remove any existing substitutions for +-- it. +extendInScope :: Id -> Subst -> Subst +extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env + +-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the +-- in-scope set is such that TyCoSubst Note [The substitution invariant] +-- holds after extending the substitution like this. +extendSubst :: Id -> Id -> Subst -> Subst +extendSubst id new_id (Subst in_scope env) + = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope ) + Subst in_scope (extendVarEnv env id new_id) diff --git a/GHC/Stg/Syntax.hs b/GHC/Stg/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Syntax.hs @@ -0,0 +1,819 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Shared term graph (STG) syntax for spineless-tagless code generation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This data type represents programs just before code generation (conversion to +@Cmm@): basically, what we have is a stylised form of Core syntax, the style +being one that happens to be ideally suited to spineless tagless code +generation. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Stg.Syntax ( + StgArg(..), + + GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), + GenStgAlt, AltType(..), + + StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, + NoExtFieldSilent, noExtFieldSilent, + OutputablePass, + + UpdateFlag(..), isUpdatable, + + -- a set of synonyms for the vanilla parameterisation + StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, + + -- a set of synonyms for the code gen parameterisation + CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt, + + -- a set of synonyms for the lambda lifting parameterisation + LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, + + -- a set of synonyms to distinguish in- and out variants + InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt, + OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, + + -- StgOp + StgOp(..), + + -- utils + stgRhsArity, + isDllConApp, + stgArgType, + stripStgTicksTop, stripStgTicksTopE, + stgCaseBndrInScope, + bindersOf, bindersOfTop, bindersOfTopBinds, + + -- ppr + StgPprOpts(..), initStgPprOpts, panicStgPprOpts, + pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, + pprGenStgTopBinding, pprStgTopBinding, + pprGenStgTopBindings, pprStgTopBindings + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core ( AltCon, Tickish ) +import GHC.Types.CostCentre ( CostCentreStack ) +import Data.ByteString ( ByteString ) +import Data.Data ( Data ) +import Data.List ( intersperse ) +import GHC.Core.DataCon +import GHC.Driver.Session +import GHC.Types.ForeignCall ( ForeignCall ) +import GHC.Types.Id +import GHC.Types.Name ( isDynLinkName ) +import GHC.Types.Var.Set +import GHC.Types.Literal ( Literal, literalType ) +import GHC.Unit.Module ( Module ) +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Core.Ppr( {- instances -} ) +import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) +import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.Type ( Type ) +import GHC.Types.RepType ( typePrimRep1 ) +import GHC.Utils.Misc + +import Data.List.NonEmpty ( NonEmpty, toList ) + +{- +************************************************************************ +* * +GenStgBinding +* * +************************************************************************ + +As usual, expressions are interesting; other things are boring. Here are the +boring things (except note the @GenStgRhs@), parameterised with respect to +binder and occurrence information (just as in @GHC.Core@): +-} + +-- | A top-level binding. +data GenStgTopBinding pass +-- See Note [Core top-level string literals] + = StgTopLifted (GenStgBinding pass) + | StgTopStringLit Id ByteString + +data GenStgBinding pass + = StgNonRec (BinderP pass) (GenStgRhs pass) + | StgRec [(BinderP pass, GenStgRhs pass)] + +{- +************************************************************************ +* * +StgArg +* * +************************************************************************ +-} + +data StgArg + = StgVarArg Id + | StgLitArg Literal + +-- | Does this constructor application refer to anything in a different +-- *Windows* DLL? +-- If so, we can't allocate it statically +isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool +isDllConApp dflags this_mod con args + | not (gopt Opt_ExternalDynamicRefs dflags) = False + | platformOS platform == OSMinGW32 + = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args + | otherwise = False + where + platform = targetPlatform dflags + -- NB: typePrimRep1 is legit because any free variables won't have + -- unlifted type (there are no unlifted things at top level) + is_dll_arg :: StgArg -> Bool + is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v)) + && isDynLinkName platform this_mod (idName v) + is_dll_arg _ = False + +-- True of machine addresses; these are the things that don't work across DLLs. +-- The key point here is that VoidRep comes out False, so that a top level +-- nullary GADT constructor is False for isDllConApp +-- +-- data T a where +-- T1 :: T Int +-- +-- gives +-- +-- T1 :: forall a. (a~Int) -> T a +-- +-- and hence the top-level binding +-- +-- $WT1 :: T Int +-- $WT1 = T1 Int (Coercion (Refl Int)) +-- +-- The coercion argument here gets VoidRep +isAddrRep :: PrimRep -> Bool +isAddrRep AddrRep = True +isAddrRep LiftedRep = True +isAddrRep UnliftedRep = True +isAddrRep _ = False + +-- | Type of an @StgArg@ +-- +-- Very half baked because we have lost the type arguments. +stgArgType :: StgArg -> Type +stgArgType (StgVarArg v) = idType v +stgArgType (StgLitArg lit) = literalType lit + + +-- | Strip ticks of a given type from an STG expression. +stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) +stripStgTicksTop p = go [] + where go ts (StgTick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + +-- | Strip ticks of a given type from an STG expression returning only the expression. +stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p +stripStgTicksTopE p = go + where go (StgTick t e) | p t = go e + go other = other + +-- | Given an alt type and whether the program is unarised, return whether the +-- case binder is in scope. +-- +-- Case binders of unboxed tuple or unboxed sum type always dead after the +-- unariser has run. See Note [Post-unarisation invariants]. +stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool +stgCaseBndrInScope alt_ty unarised = + case alt_ty of + AlgAlt _ -> True + PrimAlt _ -> True + MultiValAlt _ -> not unarised + PolyAlt -> True + +{- +************************************************************************ +* * +STG expressions +* * +************************************************************************ + +The @GenStgExpr@ data type is parameterised on binder and occurrence info, as +before. + +************************************************************************ +* * +GenStgExpr +* * +************************************************************************ + +An application is of a function to a list of atoms (not expressions). +Operationally, we want to push the arguments on the stack and call the function. +(If the arguments were expressions, we would have to build their closures +first.) + +There is no constructor for a lone variable; it would appear as @StgApp var []@. +-} + +data GenStgExpr pass + = StgApp + Id -- function + [StgArg] -- arguments; may be empty + +{- +************************************************************************ +* * +StgConApp and StgPrimApp --- saturated applications +* * +************************************************************************ + +There are specialised forms of application, for constructors, primitives, and +literals. +-} + + | StgLit Literal + + -- StgConApp is vital for returning unboxed tuples or sums + -- which can't be let-bound + | StgConApp DataCon + [StgArg] -- Saturated + [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise + + | StgOpApp StgOp -- Primitive op or foreign call + [StgArg] -- Saturated. + Type -- Result type + -- We need to know this so that we can + -- assign result registers + +{- +************************************************************************ +* * +StgLam +* * +************************************************************************ + +StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it +encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension +to GenStgExpr à la TTG. +-} + + | StgLam + (NonEmpty (BinderP pass)) + StgExpr -- Body of lambda + +{- +************************************************************************ +* * +GenStgExpr: case-expressions +* * +************************************************************************ + +This has the same boxed/unboxed business as Core case expressions. +-} + + | StgCase + (GenStgExpr pass) -- the thing to examine + (BinderP pass) -- binds the result of evaluating the scrutinee + AltType + [GenStgAlt pass] + -- The DEFAULT case is always *first* + -- if it is there at all + +{- +************************************************************************ +* * +GenStgExpr: let(rec)-expressions +* * +************************************************************************ + +The various forms of let(rec)-expression encode most of the interesting things +we want to do. + +- let-closure x = [free-vars] [args] expr in e + + is equivalent to + + let x = (\free-vars -> \args -> expr) free-vars + + @args@ may be empty (and is for most closures). It isn't under circumstances + like this: + + let x = (\y -> y+z) + + This gets mangled to + + let-closure x = [z] [y] (y+z) + + The idea is that we compile code for @(y+z)@ in an environment in which @z@ is + bound to an offset from Node, and `y` is bound to an offset from the stack + pointer. + + (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) + +- let-constructor x = Constructor [args] in e + + (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) + +- Letrec-expressions are essentially the same deal as let-closure/ + let-constructor, so we use a common structure and distinguish between them + with an @is_recursive@ boolean flag. + +- let-unboxed u = in e + + All the stuff on the RHS must be fully evaluated. No function calls either! + + (We've backed away from this toward case-expressions with suitably-magical + alts ...) + +- Advanced stuff here! Not to start with, but makes pattern matching generate + more efficient code. + + let-escapes-not fail = expr + in e' + + Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, + or pass it to another function. All @e'@ will ever do is tail-call @fail@. + Rather than build a closure for @fail@, all we need do is to record the stack + level at the moment of the @let-escapes-not@; then entering @fail@ is just a + matter of adjusting the stack pointer back down to that point and entering the + code for it. + + Another example: + + f x y = let z = huge-expression in + if y==1 then z else + if y==2 then z else + 1 + + (A let-escapes-not is an @StgLetNoEscape@.) + +- We may eventually want: + + let-literal x = Literal in e + +And so the code for let(rec)-things: +-} + + | StgLet + (XLet pass) + (GenStgBinding pass) -- right hand sides (see below) + (GenStgExpr pass) -- body + + | StgLetNoEscape + (XLetNoEscape pass) + (GenStgBinding pass) -- right hand sides (see below) + (GenStgExpr pass) -- body + +{- +************************************************************************* +* * +GenStgExpr: hpc, scc and other debug annotations +* * +************************************************************************* + +Finally for @hpc@ expressions we introduce a new STG construct. +-} + + | StgTick + (Tickish Id) + (GenStgExpr pass) -- sub expression + +-- END of GenStgExpr + +{- +************************************************************************ +* * +STG right-hand sides +* * +************************************************************************ + +Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for +closures: +-} + +data GenStgRhs pass + = StgRhsClosure + (XRhsClosure pass) -- ^ Extension point for non-global free var + -- list just before 'CodeGen'. + CostCentreStack -- ^ CCS to be attached (default is CurrentCCS) + !UpdateFlag -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry' + [BinderP pass] -- ^ arguments; if empty, then not a function; + -- as above, order is important. + (GenStgExpr pass) -- ^ body + +{- +An example may be in order. Consider: + + let t = \x -> \y -> ... x ... y ... p ... q in e + +Pulling out the free vars and stylising somewhat, we get the equivalent: + + let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q + +Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from +@Node@ into the closure, and the code ptr for the closure will be exactly that +in parentheses above. + +The second flavour of right-hand-side is for constructors (simple but +important): +-} + + | StgRhsCon + CostCentreStack -- CCS to be attached (default is CurrentCCS). + -- Top-level (static) ones will end up with + -- DontCareCCS, because we don't count static + -- data in heap profiles, and we don't set CCCS + -- from static closure. + DataCon -- Constructor. Never an unboxed tuple or sum, as those + -- are not allocated. + [StgArg] -- Args + +-- | Used as a data type index for the stgSyn AST +data StgPass + = Vanilla + | LiftLams + | CodeGen + +-- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that +-- returns 'empty'. +data NoExtFieldSilent = NoExtFieldSilent + deriving (Data, Eq, Ord) + +instance Outputable NoExtFieldSilent where + ppr _ = empty + +-- | Used when constructing a term with an unused extension point that should +-- not appear in pretty-printed output at all. +noExtFieldSilent :: NoExtFieldSilent +noExtFieldSilent = NoExtFieldSilent +-- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the +-- implications on build time... + +-- TODO: Do we really want to the extension point type families to have a closed +-- domain? +type family BinderP (pass :: StgPass) +type instance BinderP 'Vanilla = Id +type instance BinderP 'CodeGen = Id + +type family XRhsClosure (pass :: StgPass) +type instance XRhsClosure 'Vanilla = NoExtFieldSilent +-- | Code gen needs to track non-global free vars +type instance XRhsClosure 'CodeGen = DIdSet + +type family XLet (pass :: StgPass) +type instance XLet 'Vanilla = NoExtFieldSilent +type instance XLet 'CodeGen = NoExtFieldSilent + +type family XLetNoEscape (pass :: StgPass) +type instance XLetNoEscape 'Vanilla = NoExtFieldSilent +type instance XLetNoEscape 'CodeGen = NoExtFieldSilent + +stgRhsArity :: StgRhs -> Int +stgRhsArity (StgRhsClosure _ _ _ bndrs _) + = ASSERT( all isId bndrs ) length bndrs + -- The arity never includes type parameters, but they should have gone by now +stgRhsArity (StgRhsCon _ _ _) = 0 + +{- +************************************************************************ +* * +STG case alternatives +* * +************************************************************************ + +Very like in Core syntax (except no type-world stuff). + +The type constructor is guaranteed not to be abstract; that is, we can see its +representation. This is important because the code generator uses it to +determine return conventions etc. But it's not trivial where there's a module +loop involved, because some versions of a type constructor might not have all +the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets +the TyCon from the constructors or literals (which are guaranteed to have the +Real McCoy) rather than from the scrutinee type. +-} + +type GenStgAlt pass + = (AltCon, -- alts: data constructor, + [BinderP pass], -- constructor's parameters, + GenStgExpr pass) -- ...right-hand side. + +data AltType + = PolyAlt -- Polymorphic (a lifted type variable) + | MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum) + -- the arity could indeed be 1 for unary unboxed tuple + -- or enum-like unboxed sums + | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts + | PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts + +{- +************************************************************************ +* * +The Plain STG parameterisation +* * +************************************************************************ + +This happens to be the only one we use at the moment. +-} + +type StgTopBinding = GenStgTopBinding 'Vanilla +type StgBinding = GenStgBinding 'Vanilla +type StgExpr = GenStgExpr 'Vanilla +type StgRhs = GenStgRhs 'Vanilla +type StgAlt = GenStgAlt 'Vanilla + +type LlStgTopBinding = GenStgTopBinding 'LiftLams +type LlStgBinding = GenStgBinding 'LiftLams +type LlStgExpr = GenStgExpr 'LiftLams +type LlStgRhs = GenStgRhs 'LiftLams +type LlStgAlt = GenStgAlt 'LiftLams + +type CgStgTopBinding = GenStgTopBinding 'CodeGen +type CgStgBinding = GenStgBinding 'CodeGen +type CgStgExpr = GenStgExpr 'CodeGen +type CgStgRhs = GenStgRhs 'CodeGen +type CgStgAlt = GenStgAlt 'CodeGen + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied. + See GHC.Core for precedence in Core land +-} + +type InStgTopBinding = StgTopBinding +type InStgBinding = StgBinding +type InStgArg = StgArg +type InStgExpr = StgExpr +type InStgRhs = StgRhs +type InStgAlt = StgAlt +type OutStgTopBinding = StgTopBinding +type OutStgBinding = StgBinding +type OutStgArg = StgArg +type OutStgExpr = StgExpr +type OutStgRhs = StgRhs +type OutStgAlt = StgAlt + +{- + +************************************************************************ +* * +UpdateFlag +* * +************************************************************************ + +This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. + +A @ReEntrant@ closure may be entered multiple times, but should not be updated +or blackholed. An @Updatable@ closure should be updated after evaluation (and +may be blackholed during evaluation). A @SingleEntry@ closure will only be +entered once, and so need not be updated but may safely be blackholed. +-} + +data UpdateFlag = ReEntrant | Updatable | SingleEntry + +instance Outputable UpdateFlag where + ppr u = char $ case u of + ReEntrant -> 'r' + Updatable -> 'u' + SingleEntry -> 's' + +isUpdatable :: UpdateFlag -> Bool +isUpdatable ReEntrant = False +isUpdatable SingleEntry = False +isUpdatable Updatable = True + +{- +************************************************************************ +* * +StgOp +* * +************************************************************************ + +An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful +to move these around together, notably in StgOpApp and COpStmt. +-} + +data StgOp + = StgPrimOp PrimOp + + | StgPrimCallOp PrimCall + + | StgFCallOp ForeignCall Type + -- The Type, which is obtained from the foreign import declaration + -- itself, is needed by the stg-to-cmm pass to determine the offset to + -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note + -- [Unlifted boxed arguments to foreign calls] + +{- +************************************************************************ +* * +Utilities +* * +************************************************************************ +-} + +bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] +bindersOf (StgNonRec binder _) = [binder] +bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] + +bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] +bindersOfTop (StgTopLifted bind) = bindersOf bind +bindersOfTop (StgTopStringLit binder _) = [binder] + +bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] +bindersOfTopBinds = foldr ((++) . bindersOfTop) [] + +{- +************************************************************************ +* * +Pretty-printing +* * +************************************************************************ + +Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he +likes terminators instead... Ditto for case alternatives. +-} + +type OutputablePass pass = + ( Outputable (XLet pass) + , Outputable (XLetNoEscape pass) + , Outputable (XRhsClosure pass) + , OutputableBndr (BinderP pass) + ) + +-- | STG pretty-printing options +data StgPprOpts = StgPprOpts + { stgSccEnabled :: !Bool -- ^ Enable cost-centres + } + +-- | Initialize STG pretty-printing options from DynFlags +initStgPprOpts :: DynFlags -> StgPprOpts +initStgPprOpts dflags = StgPprOpts + { stgSccEnabled = sccProfilingEnabled dflags + } + +-- | STG pretty-printing options used for panic messages +panicStgPprOpts :: StgPprOpts +panicStgPprOpts = StgPprOpts + { stgSccEnabled = True + } + +pprGenStgTopBinding + :: OutputablePass pass => StgPprOpts -> GenStgTopBinding pass -> SDoc +pprGenStgTopBinding opts b = case b of + StgTopStringLit bndr str -> hang (hsep [pprBndr LetBind bndr, equals]) 4 (pprHsBytes str <> semi) + StgTopLifted bind -> pprGenStgBinding opts bind + +pprGenStgBinding :: OutputablePass pass => StgPprOpts -> GenStgBinding pass -> SDoc +pprGenStgBinding opts b = case b of + StgNonRec bndr rhs -> hang (hsep [pprBndr LetBind bndr, equals]) 4 (pprStgRhs opts rhs <> semi) + StgRec pairs -> vcat [ text "Rec {" + , vcat (intersperse blankLine (map ppr_bind pairs)) + , text "end Rec }" ] + where + ppr_bind (bndr, expr) + = hang (hsep [pprBndr LetBind bndr, equals]) + 4 (pprStgRhs opts expr <> semi) + +pprGenStgTopBindings :: (OutputablePass pass) => StgPprOpts -> [GenStgTopBinding pass] -> SDoc +pprGenStgTopBindings opts binds + = vcat $ intersperse blankLine (map (pprGenStgTopBinding opts) binds) + +pprStgBinding :: StgPprOpts -> StgBinding -> SDoc +pprStgBinding = pprGenStgBinding + +pprStgTopBinding :: StgPprOpts -> StgTopBinding -> SDoc +pprStgTopBinding = pprGenStgTopBinding + +pprStgTopBindings :: StgPprOpts -> [StgTopBinding] -> SDoc +pprStgTopBindings = pprGenStgTopBindings + +instance Outputable StgArg where + ppr = pprStgArg + +pprStgArg :: StgArg -> SDoc +pprStgArg (StgVarArg var) = ppr var +pprStgArg (StgLitArg con) = ppr con + +pprStgExpr :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc +pprStgExpr opts e = case e of + -- special case + StgLit lit -> ppr lit + -- general case + StgApp func args -> hang (ppr func) 4 (interppSP args) + StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ] + StgOpApp op args _ -> hsep [ pprStgOp op, brackets (interppSP args)] + StgLam bndrs body -> let ppr_list = brackets . fsep . punctuate comma + in sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs)) + <+> text "->" + , pprStgExpr opts body + ] + +-- special case: let v = +-- in +-- let ... +-- in +-- ... +-- +-- Very special! Suspicious! (SLPJ) + +{- + StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) + expr@(StgLet _ _)) + -> ($$) + (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "), + ppr cc, + pp_binder_info bi, + text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"), + ppr upd_flag, text " [", + interppSP args, char ']']) + 8 (sep [hsep [ppr rhs, text "} in"]])) + (ppr expr) +-} + + -- special case: let ... in let ... + StgLet ext bind expr@StgLet{} -> ($$) + (sep [hang (text "let" <+> ppr ext <+> text "{") + 2 (hsep [pprGenStgBinding opts bind, text "} in"])]) + (pprStgExpr opts expr) + + -- general case + StgLet ext bind expr + -> sep [ hang (text "let" <+> ppr ext <+> text "{") + 2 (pprGenStgBinding opts bind) + , hang (text "} in ") 2 (pprStgExpr opts expr) + ] + + StgLetNoEscape ext bind expr + -> sep [ hang (text "let-no-escape" <+> ppr ext <+> text "{") + 2 (pprGenStgBinding opts bind) + , hang (text "} in ") 2 (pprStgExpr opts expr) + ] + + StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case + True -> pprStgExpr opts expr + False -> sep [ ppr tickish, pprStgExpr opts expr ] + + -- Don't indent for a single case alternative. + StgCase expr bndr alt_type [alt] + -> sep [ sep [ text "case" + , nest 4 (hsep [ pprStgExpr opts expr + , whenPprDebug (dcolon <+> ppr alt_type) + ]) + , text "of" + , pprBndr CaseBind bndr + , char '{' + ] + , pprStgAlt opts False alt + , char '}' + ] + + StgCase expr bndr alt_type alts + -> sep [ sep [ text "case" + , nest 4 (hsep [ pprStgExpr opts expr + , whenPprDebug (dcolon <+> ppr alt_type) + ]) + , text "of" + , pprBndr CaseBind bndr, char '{' + ] + , nest 2 (vcat (map (pprStgAlt opts True) alts)) + , char '}' + ] + + +pprStgAlt :: OutputablePass pass => StgPprOpts -> Bool -> GenStgAlt pass -> SDoc +pprStgAlt opts indent (con, params, expr) + | indent = hang altPattern 4 (pprStgExpr opts expr <> semi) + | otherwise = sep [altPattern, pprStgExpr opts expr <> semi] + where + altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"]) + + +pprStgOp :: StgOp -> SDoc +pprStgOp (StgPrimOp op) = ppr op +pprStgOp (StgPrimCallOp op)= ppr op +pprStgOp (StgFCallOp op _) = ppr op + +instance Outputable AltType where + ppr PolyAlt = text "Polymorphic" + ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n + ppr (AlgAlt tc) = text "Alg" <+> ppr tc + ppr (PrimAlt tc) = text "Prim" <+> ppr tc + +pprStgRhs :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc +pprStgRhs opts rhs = case rhs of + StgRhsClosure ext cc upd_flag args body + -> hang (hsep [ if stgSccEnabled opts then ppr cc else empty + , ppUnlessOption sdocSuppressStgExts (ppr ext) + , char '\\' <> ppr upd_flag, brackets (interppSP args) + ]) + 4 (pprStgExpr opts body) + + StgRhsCon cc con args + -> hcat [ ppr cc, space, ppr con, text "! ", brackets (sep (map pprStgArg args))] diff --git a/GHC/Stg/Unarise.hs b/GHC/Stg/Unarise.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Unarise.hs @@ -0,0 +1,826 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2012 + +Note [Unarisation] +~~~~~~~~~~~~~~~~~~ +The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum +binders. So for example: + + f (x :: (# Int, Bool #)) = f x + f (# 1, True #) + + ==> + + f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True + +It is important that we do this at the STG level and NOT at the Core level +because it would be very hard to make this pass Core-type-preserving. In this +example the type of 'f' changes, for example. + +STG fed to the code generators *must* be unarised because the code generators do +not support unboxed tuple and unboxed sum binders natively. + +In more detail: (see next note for unboxed sums) + +Suppose that a variable x : (# t1, t2 #). + + * At the binding site for x, make up fresh vars x1:t1, x2:t2 + + * Extend the UnariseEnv x :-> MultiVal [x1,x2] + + * Replace the binding with a curried binding for x1,x2 + + Lambda: \x.e ==> \x1 x2. e + Case alt: MkT a b x c d -> e ==> MkT a b x1 x2 c d -> e + + * Replace argument occurrences with a sequence of args via a lookup in + UnariseEnv + + f a b x c d ==> f a b x1 x2 c d + + * Replace tail-call occurrences with an unboxed tuple via a lookup in + UnariseEnv + + x ==> (# x1, x2 #) + + So, for example + + f x = x ==> f x1 x2 = (# x1, x2 #) + + * We /always/ eliminate a case expression when + + - It scrutinises an unboxed tuple or unboxed sum + + - The scrutinee is a variable (or when it is an explicit tuple, but the + simplifier eliminates those) + + The case alternative (there can be only one) can be one of these two + things: + + - An unboxed tuple pattern. e.g. + + case v of x { (# x1, x2, x3 #) -> ... } + + Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the + environment with + + x :-> MultiVal [t1,t2,t3] + x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3 + + - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3 + +By the end of this pass, we only have unboxed tuples in return positions. +Unboxed sums are completely eliminated, see next note. + +Note [Translating unboxed sums to unboxed tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unarise also eliminates unboxed sum binders, and translates unboxed sums in +return positions to unboxed tuples. We want to overlap fields of a sum when +translating it to a tuple to have efficient memory layout. When translating a +sum pattern to a tuple pattern, we need to translate it so that binders of sum +alternatives will be mapped to right arguments after the term translation. So +translation of sum DataCon applications to tuple DataCon applications and +translation of sum patterns to tuple patterns need to be in sync. + +These translations work like this. Suppose we have + + (# x1 | | ... #) :: (# t1 | t2 | ... #) + +remember that t1, t2 ... can be sums and tuples too. So we first generate +layouts of those. Then we "merge" layouts of each alternative, which gives us a +sum layout with best overlapping possible. + +Layout of a flat type 'ty1' is just [ty1]. +Layout of a tuple is just concatenation of layouts of its fields. + +For layout of a sum type, + + - We first get layouts of all alternatives. + - We sort these layouts based on their "slot types". + - We merge all the alternatives. + +For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #) + + - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ] + - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ] + - Merge all alternatives together: [ LiftedPtr, Word, Word ] + +We add a slot for the tag to the first position. So our tuple type is + + (# Tag#, Any, Word#, Word# #) + (we use Any for pointer slots) + +Now, any term of this sum type needs to generate a tuple of this type instead. +The translation works by simply putting arguments to first slots that they fit +in. Suppose we had + + (# (# 42#, 'c' #) | | #) + +42# fits in Word#, 'c' fits in Any, so we generate this application: + + (# 1#, 'c', 42#, rubbish #) + +Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#, +3# fits in Word #, so we get: + + (# 2#, rubbish, 2#, 3# #). + + +Note [Don't merge lifted and unlifted slots] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When merging slots, one might be tempted to collapse lifted and unlifted +pointers. However, as seen in #19645, this is wrong. Imagine that you have +the program: + + test :: (# Char | ByteArray# #) -> ByteArray# + test (# c | #) = doSomething c + test (# | ba #) = ba + +Collapsing the Char and ByteArray# slots would produce STG like: + + test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray# + = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ] + case tag of tag' + 1# -> doSomething slot0 + 2# -> slot0; + +Note how `slot0` has a lifted type, despite being bound to an unlifted +ByteArray# in the 2# alternative. This liftedness would cause the code generator to +attempt to enter it upon returning. As unlifted objects do not have entry code, +this causes a runtime crash. + +For this reason, Unarise treats unlifted and lifted things as distinct slot +types, despite both being GC pointers. This approach is a slight pessimisation +(since we need to pass more arguments) but appears to be the simplest way to +avoid #19645. Other alternatives considered include: + + a. Giving unlifted objects "trivial" entry code. However, we ultimately + concluded that the value of the "unlifted things are never entered" invariant + outweighed the simplicity of this approach. + + b. Annotating occurrences with calling convention information instead of + relying on the binder's type. This seemed like a very complicated + way to fix what is ultimately a corner-case. + + +Note [Types in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this unboxed sum term: + + (# 123 | #) + +What will be the unboxed tuple representation? We can't tell without knowing the +type of this term. For example, these are all valid tuples for this: + + (# 1#, 123 #) -- when type is (# Int | String #) + (# 1#, 123, rubbish #) -- when type is (# Int | Float# #) + (# 1#, 123, rubbish, rubbish #) + -- when type is (# Int | (# Int, Int, Int #) #) + +So we pass type arguments of the DataCon's TyCon in StgConApp to decide what +layout to use. Note that unlifted values can't be let-bound, so we don't need +types in StgRhsCon. + +Note [UnariseEnv can map to literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To avoid redundant case expressions when unarising unboxed sums, UnariseEnv +needs to map variables to literals too. Suppose we have this Core: + + f (# x | #) + + ==> (CorePrep) + + case (# x | #) of y { + _ -> f y + } + + ==> (MultiVal) + + case (# 1#, x #) of [x1, x2] { + _ -> f x1 x2 + } + +To eliminate this case expression we need to map x1 to 1# in UnariseEnv: + + x1 :-> UnaryVal 1#, x2 :-> UnaryVal x + +so that `f x1 x2` becomes `f 1# x`. + +Note [Unarisation and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of unarisation, the arity that will be recorded in the generated info +table for an Id may be larger than the idArity. Instead we record what we call +the RepArity, which is the Arity taking into account any expanded arguments, and +corresponds to the number of (possibly-void) *registers* arguments will arrive +in. + +Note [Post-unarisation invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +STG programs after unarisation have these invariants: + + * No unboxed sums at all. + + * No unboxed tuple binders. Tuples only appear in return position. + + * DataCon applications (StgRhsCon and StgConApp) don't have void arguments. + This means that it's safe to wrap `StgArg`s of DataCon applications with + `GHC.StgToCmm.Env.NonVoid`, for example. + + * Alt binders (binders in patterns) are always non-void. + + * Binders always have zero (for void arguments) or one PrimRep. +-} + +{-# LANGUAGE CPP, TupleSections, PatternSynonyms #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Stg.Unarise (unarise) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Core +import GHC.Core.DataCon +import GHC.Data.FastString (FastString, mkFastString) +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) +import GHC.Types.Id.Make (voidPrimId, voidArgId) +import GHC.Utils.Monad (mapAccumLM) +import GHC.Utils.Outputable +import GHC.Types.RepType +import GHC.Stg.Syntax +import GHC.Core.Type +import GHC.Builtin.Types.Prim (intPrimTy) +import GHC.Builtin.Types +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Types.Var.Env + +import Data.Bifunctor (second) +import Data.Maybe (mapMaybe) +import qualified Data.IntMap as IM + +-------------------------------------------------------------------------------- + +-- | A mapping from binders to the Ids they were expanded/renamed to. +-- +-- x :-> MultiVal [a,b,c] in rho +-- +-- iff x's typePrimRep is not a singleton, or equivalently +-- x's type is an unboxed tuple, sum or void. +-- +-- x :-> UnaryVal x' +-- +-- iff x's RepType is UnaryRep or equivalently +-- x's type is not unboxed tuple, sum or void. +-- +-- So +-- x :-> MultiVal [a] in rho +-- means x is represented by singleton tuple. +-- +-- x :-> MultiVal [] in rho +-- means x is void. +-- +-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes +-- (i.e. no unboxed tuples, sums or voids) +-- +type UnariseEnv = VarEnv UnariseVal + +data UnariseVal + = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). + | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation]. + +instance Outputable UnariseVal where + ppr (MultiVal args) = text "MultiVal" <+> ppr args + ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg + +-- | Extend the environment, checking the UnariseEnv invariant. +extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv +extendRho rho x (MultiVal args) + = ASSERT(all (isNvUnaryType . stgArgType) args) + extendVarEnv rho x (MultiVal args) +extendRho rho x (UnaryVal val) + = ASSERT(isNvUnaryType (stgArgType val)) + extendVarEnv rho x (UnaryVal val) + +-------------------------------------------------------------------------------- + +unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding] +unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds) + +unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding +unariseTopBinding rho (StgTopLifted bind) + = StgTopLifted <$> unariseBinding rho bind +unariseTopBinding _ bind@StgTopStringLit{} = return bind + +unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding +unariseBinding rho (StgNonRec x rhs) + = StgNonRec x <$> unariseRhs rho rhs +unariseBinding rho (StgRec xrhss) + = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss + +unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs +unariseRhs rho (StgRhsClosure ext ccs update_flag args expr) + = do (rho', args1) <- unariseFunArgBinders rho args + expr' <- unariseExpr rho' expr + return (StgRhsClosure ext ccs update_flag args1 expr') + +unariseRhs rho (StgRhsCon ccs con args) + = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con)) + return (StgRhsCon ccs con (unariseConArgs rho args)) + +-------------------------------------------------------------------------------- + +unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr + +unariseExpr rho e@(StgApp f []) + = case lookupVarEnv rho f of + Just (MultiVal args) -- Including empty tuples + -> return (mkTuple args) + Just (UnaryVal (StgVarArg f')) + -> return (StgApp f' []) + Just (UnaryVal (StgLitArg f')) + -> return (StgLit f') + Nothing + -> return e + +unariseExpr rho e@(StgApp f args) + = return (StgApp f' (unariseFunArgs rho args)) + where + f' = case lookupVarEnv rho f of + Just (UnaryVal (StgVarArg f')) -> f' + Nothing -> f + err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err) + -- Can't happen because 'args' is non-empty, and + -- a tuple or sum cannot be applied to anything + +unariseExpr _ (StgLit l) + = return (StgLit l) + +unariseExpr rho (StgConApp dc args ty_args) + | Just args' <- unariseMulti_maybe rho dc args ty_args + = return (mkTuple args') + + | otherwise + , let args' = unariseConArgs rho args + = return (StgConApp dc args' (map stgArgType args')) + +unariseExpr rho (StgOpApp op args ty) + = return (StgOpApp op (unariseFunArgs rho args) ty) + +unariseExpr _ e@StgLam{} + = pprPanic "unariseExpr: found lambda" (pprStgExpr panicStgPprOpts e) + +unariseExpr rho (StgCase scrut bndr alt_ty alts) + -- tuple/sum binders in the scrutinee can always be eliminated + | StgApp v [] <- scrut + , Just (MultiVal xs) <- lookupVarEnv rho v + = elimCase rho xs bndr alt_ty alts + + -- Handle strict lets for tuples and sums: + -- case (# a,b #) of r -> rhs + -- and analogously for sums + | StgConApp dc args ty_args <- scrut + , Just args' <- unariseMulti_maybe rho dc args ty_args + = elimCase rho args' bndr alt_ty alts + + -- general case + | otherwise + = do scrut' <- unariseExpr rho scrut + alts' <- unariseAlts rho alt_ty bndr alts + return (StgCase scrut' bndr alt_ty alts') + -- bndr may have a unboxed sum/tuple type but it will be + -- dead after unarise (checked in GHC.Stg.Lint) + +unariseExpr rho (StgLet ext bind e) + = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e + +unariseExpr rho (StgLetNoEscape ext bind e) + = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e + +unariseExpr rho (StgTick tick e) + = StgTick tick <$> unariseExpr rho e + +-- Doesn't return void args. +unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] +unariseMulti_maybe rho dc args ty_args + | isUnboxedTupleCon dc + = Just (unariseConArgs rho args) + + | isUnboxedSumCon dc + , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args) + = Just (mkUbxSum dc ty_args args1) + + | otherwise + = Nothing + +-------------------------------------------------------------------------------- + +elimCase :: UnariseEnv + -> [OutStgArg] -- non-void args + -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr + +elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)] + = do let rho1 = extendRho rho bndr (MultiVal args) + rho2 + | isUnboxedTupleBndr bndr + = mapTupleIdBinders bndrs args rho1 + | otherwise + = ASSERT(isUnboxedSumBndr bndr) + if null bndrs then rho1 + else mapSumIdBinders bndrs args rho1 + + unariseExpr rho2 rhs + +elimCase rho args bndr (MultiValAlt _) alts + | isUnboxedSumBndr bndr + = do let (tag_arg : real_args) = args + tag_bndr <- mkId (mkFastString "tag") tagTy + -- this won't be used but we need a binder anyway + let rho1 = extendRho rho bndr (MultiVal args) + scrut' = case tag_arg of + StgVarArg v -> StgApp v [] + StgLitArg l -> StgLit l + + alts' <- unariseSumAlts rho1 real_args alts + return (StgCase scrut' tag_bndr tagAltTy alts') + +elimCase _ args bndr alt_ty alts + = pprPanic "elimCase - unhandled case" + (ppr args <+> ppr bndr <+> ppr alt_ty $$ pprPanicAlts alts) + +-------------------------------------------------------------------------------- + +unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt] +unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)] + | isUnboxedTupleBndr bndr + = do (rho', ys) <- unariseConArgBinder rho bndr + e' <- unariseExpr rho' e + return [(DataAlt (tupleDataCon Unboxed n), ys, e')] + +unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)] + | isUnboxedTupleBndr bndr + = do (rho', ys1) <- unariseConArgBinders rho ys + MASSERT(ys1 `lengthIs` n) + let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1)) + e' <- unariseExpr rho'' e + return [(DataAlt (tupleDataCon Unboxed n), ys1, e')] + +unariseAlts _ (MultiValAlt _) bndr alts + | isUnboxedTupleBndr bndr + = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts) + +-- In this case we don't need to scrutinize the tag bit +unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)] + | isUnboxedSumBndr bndr + = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr + rhs' <- unariseExpr rho_sum_bndrs rhs + return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')] + +unariseAlts rho (MultiValAlt _) bndr alts + | isUnboxedSumBndr bndr + = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr + alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts + let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts' + return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)), + scrt_bndrs, + inner_case) ] + +unariseAlts rho _ _ alts + = mapM (\alt -> unariseAlt rho alt) alts + +unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt +unariseAlt rho (con, xs, e) + = do (rho', xs') <- unariseConArgBinders rho xs + (con, xs',) <$> unariseExpr rho' e + +-------------------------------------------------------------------------------- + +-- | Make alternatives that match on the tag of a sum +-- (i.e. generate LitAlts for the tag) +unariseSumAlts :: UnariseEnv + -> [StgArg] -- sum components _excluding_ the tag bit. + -> [StgAlt] -- original alternative with sum LHS + -> UniqSM [StgAlt] +unariseSumAlts env args alts + = do alts' <- mapM (unariseSumAlt env args) alts + return (mkDefaultLitAlt alts') + +unariseSumAlt :: UnariseEnv + -> [StgArg] -- sum components _excluding_ the tag bit. + -> StgAlt -- original alternative with sum LHS + -> UniqSM StgAlt +unariseSumAlt rho _ (DEFAULT, _, e) + = ( DEFAULT, [], ) <$> unariseExpr rho e + +unariseSumAlt rho args (DataAlt sumCon, bs, e) + = do let rho' = mapSumIdBinders bs args rho + e' <- unariseExpr rho' e + return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' ) + +unariseSumAlt _ scrt alt + = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt) + +-------------------------------------------------------------------------------- + +mapTupleIdBinders + :: [InId] -- Un-processed binders of a tuple alternative. + -- Can have void binders. + -> [OutStgArg] -- Arguments that form the tuple (after unarisation). + -- Can't have void args. + -> UnariseEnv + -> UnariseEnv +mapTupleIdBinders ids args0 rho0 + = ASSERT(not (any (isVoidTy . stgArgType) args0)) + let + ids_unarised :: [(Id, [PrimRep])] + ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids + + map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv + map_ids rho [] _ = rho + map_ids rho ((x, x_reps) : xs) args = + let + x_arity = length x_reps + (x_args, args') = + ASSERT(args `lengthAtLeast` x_arity) + splitAt x_arity args + + rho' + | x_arity == 1 + = ASSERT(x_args `lengthIs` 1) + extendRho rho x (UnaryVal (head x_args)) + | otherwise + = extendRho rho x (MultiVal x_args) + in + map_ids rho' xs args' + in + map_ids rho0 ids_unarised args0 + +mapSumIdBinders + :: [InId] -- Binder of a sum alternative (remember that sum patterns + -- only have one binder, so this list should be a singleton) + -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). + -- Can't have void args. + -> UnariseEnv + -> UnariseEnv + +mapSumIdBinders [id] args rho0 + = ASSERT(not (any (isVoidTy . stgArgType) args)) + let + arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args + id_slots = map primRepSlot $ typePrimRep (idType id) + layout1 = layoutUbxSum arg_slots id_slots + in + if isMultiValBndr id + then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) + else ASSERT(layout1 `lengthIs` 1) + extendRho rho0 id (UnaryVal (args !! head layout1)) + +mapSumIdBinders ids sum_args _ + = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args) + +-- | Build a unboxed sum term from arguments of an alternative. +-- +-- Example, for (# x | #) :: (# (# #) | Int #) we call +-- +-- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] +-- +-- which returns +-- +-- [ 1#, rubbish ] +-- +mkUbxSum + :: DataCon -- Sum data con + -> [Type] -- Type arguments of the sum data con + -> [OutStgArg] -- Actual arguments of the alternative. + -> [OutStgArg] -- Final tuple arguments +mkUbxSum dc ty_args args0 + = let + (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) + -- drop tag slot + + tag = dataConTag dc + + layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) + tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) + arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) + + mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] + mkTupArgs _ [] _ + = [] + mkTupArgs arg_idx (slot : slots_left) arg_map + | Just stg_arg <- IM.lookup arg_idx arg_map + = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map + | otherwise + = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map + in + tag_arg : mkTupArgs 0 sum_slots arg_idxs + + +-- | Return a rubbish value for the given slot type. +-- +-- We use the following rubbish values: +-- * Literals: 0 or 0.0 +-- * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError` +-- +-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make" +-- +ubxSumRubbishArg :: SlotTy -> StgArg +ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) +ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) +ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) +ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) + +-------------------------------------------------------------------------------- + +{- +For arguments (StgArg) and binders (Id) we have two kind of unarisation: + + - When unarising function arg binders and arguments, we don't want to remove + void binders and arguments. For example, + + f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ... + f x y z = + + Here after unarise we should still get a function with arity 3. Similarly + in the call site we shouldn't remove void arguments: + + f (# (# #), (# #) #) voidId rw + + When unarising , we extend the environment with these binders: + + x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal [] + + Because their rep types are `MultiRep []` (aka. void). This means that when + we see `x` in a function argument position, we actually replace it with a + void argument. When we see it in a DataCon argument position, we just get + rid of it, because DataCon applications in STG are always saturated. + + - When unarising case alternative binders we remove void binders, but we + still update the environment the same way, because those binders may be + used in the RHS. Example: + + case x of y { + (# x1, x2, x3 #) -> + } + + We know that y can't be void, because we don't scrutinize voids, so x will + be unarised to some number of arguments, and those arguments will have at + least one non-void thing. So in the rho we will have something like: + + x :-> MultiVal [xu1, xu2] + + Now, after we eliminate void binders in the pattern, we get exactly the same + number of binders, and extend rho again with these: + + x1 :-> UnaryVal xu1 + x2 :-> MultiVal [] -- x2 is void + x3 :-> UnaryVal xu2 + + Now when we see x2 in a function argument position or in return position, we + generate void#. In constructor argument position, we just remove it. + +So in short, when we have a void id, + + - We keep it if it's a lambda argument binder or + in argument position of an application. + + - We remove it if it's a DataCon field binder or + in argument position of a DataCon application. +-} + +unariseArgBinder + :: Bool -- data con arg? + -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +unariseArgBinder is_con_arg rho x = + case typePrimRep (idType x) of + [] + | is_con_arg + -> return (extendRho rho x (MultiVal []), []) + | otherwise -- fun arg, do not remove void binders + -> return (extendRho rho x (MultiVal []), [voidArgId]) + + [rep] + -- Arg represented as single variable, but original type may still be an + -- unboxed sum/tuple, e.g. (# Void# | Void# #). + -- + -- While not unarising the binder in this case does not break any programs + -- (because it unarises to a single variable), it triggers StgLint as we + -- break the post-unarisation invariant that says unboxed tuple/sum + -- binders should vanish. See Note [Post-unarisation invariants]. + | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x) + -> do x' <- mkId (mkFastString "us") (primRepToType rep) + return (extendRho rho x (MultiVal [StgVarArg x']), [x']) + | otherwise + -> return (rho, [x]) + + reps -> do + xs <- mkIds (mkFastString "us") (map primRepToType reps) + return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) + +-------------------------------------------------------------------------------- + +-- | MultiVal a function argument. Never returns an empty list. +unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] +unariseFunArg rho (StgVarArg x) = + case lookupVarEnv rho x of + Just (MultiVal []) -> [voidArg] -- NB: do not remove void args + Just (MultiVal as) -> as + Just (UnaryVal arg) -> [arg] + Nothing -> [StgVarArg x] +unariseFunArg _ arg = [arg] + +unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg] +unariseFunArgs = concatMap . unariseFunArg + +unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) +unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs + +-- Result list of binders is never empty +unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +unariseFunArgBinder = unariseArgBinder False + +-------------------------------------------------------------------------------- + +-- | MultiVal a DataCon argument. Returns an empty list when argument is void. +unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] +unariseConArg rho (StgVarArg x) = + case lookupVarEnv rho x of + Just (UnaryVal arg) -> [arg] + Just (MultiVal as) -> as -- 'as' can be empty + Nothing + | isVoidTy (idType x) -> [] -- e.g. C realWorld# + -- Here realWorld# is not in the envt, but + -- is a void, and so should be eliminated + | otherwise -> [StgVarArg x] +unariseConArg _ arg@(StgLitArg lit) = + ASSERT(not (isVoidTy (literalType lit))) -- We have no void literals + [arg] + +unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg] +unariseConArgs = concatMap . unariseConArg + +unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) +unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs + +-- Different from `unariseFunArgBinder`: result list of binders may be empty. +-- See DataCon applications case in Note [Post-unarisation invariants]. +unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +unariseConArgBinder = unariseArgBinder True + +-------------------------------------------------------------------------------- + +mkIds :: FastString -> [UnaryType] -> UniqSM [Id] +mkIds fs tys = mapM (mkId fs) tys + +mkId :: FastString -> UnaryType -> UniqSM Id +mkId s t = mkSysLocalM s Many t + +isMultiValBndr :: Id -> Bool +isMultiValBndr id + | [_] <- typePrimRep (idType id) + = False + | otherwise + = True + +isUnboxedSumBndr :: Id -> Bool +isUnboxedSumBndr = isUnboxedSumType . idType + +isUnboxedTupleBndr :: Id -> Bool +isUnboxedTupleBndr = isUnboxedTupleType . idType + +mkTuple :: [StgArg] -> StgExpr +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args) + +tagAltTy :: AltType +tagAltTy = PrimAlt IntRep + +tagTy :: Type +tagTy = intPrimTy + +voidArg :: StgArg +voidArg = StgVarArg voidPrimId + +mkDefaultLitAlt :: [StgAlt] -> [StgAlt] +-- We have an exhauseive list of literal alternatives +-- 1# -> e1 +-- 2# -> e2 +-- Since they are exhaustive, we can replace one with DEFAULT, to avoid +-- generating a final test. Remember, the DEFAULT comes first if it exists. +mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts") +mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts +mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts +mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts) + +pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc +pprPanicAlts alts = ppr (map pprPanicAlt alts) + +pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc +pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e) diff --git a/GHC/StgToCmm.hs b/GHC/StgToCmm.hs --- a/GHC/StgToCmm.hs +++ b/GHC/StgToCmm.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- @@ -13,7 +14,7 @@ #include "HsVersions.h" -import GhcPrelude as Prelude +import GHC.Prelude as Prelude import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad @@ -25,34 +26,41 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Types (ModuleLFInfos) -import Cmm -import CmmUtils -import CLabel +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel -import StgSyn -import DynFlags -import ErrUtils +import GHC.Stg.Syntax +import GHC.Driver.Session +import GHC.Utils.Error -import HscTypes -import CostCentre -import Id -import IdInfo -import RepType -import DataCon -import TyCon -import Module -import Outputable -import Stream -import BasicTypes -import VarSet ( isEmptyDVarSet ) +import GHC.Driver.Types +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.RepType +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Multiplicity +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Data.Stream +import GHC.Types.Basic +import GHC.Types.Var.Set ( isEmptyDVarSet ) +import GHC.SysTools.FileCleanup +import GHC.Types.Unique.FM +import GHC.Types.Name.Env -import OrdList -import MkGraph +import GHC.Data.OrdList +import GHC.Cmm.Graph import Data.IORef import Control.Monad (when,void) -import Util +import GHC.Utils.Misc +import System.IO.Unsafe +import qualified Data.ByteString as BS codeGen :: DynFlags -> Module @@ -60,7 +68,8 @@ -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [CgStgTopBinding] -- Bindings to convert -> HpcInfo - -> Stream IO CmmGroup () -- Output as a stream, so codegen can + -> Stream IO CmmGroup ModuleLFInfos + -- Output as a stream, so codegen can -- be interleaved with output codeGen dflags this_mod data_tycons @@ -102,6 +111,23 @@ mapM_ (cg . cgDataCon) (tyConDataCons tycon) ; mapM_ do_tycon data_tycons + + ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref) + + -- See Note [Conveying CAF-info and LFInfo between modules] in + -- GHC.StgToCmm.Types + ; let extractInfo info = (name, lf) + where + !name = idName (cg_id info) + !lf = cg_lf info + + !generatedInfo + | gopt Opt_OmitInterfacePragmas dflags + = emptyNameEnv + | otherwise + = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos)) + + ; return generatedInfo } --------------------------------------------------------------- @@ -134,20 +160,32 @@ ; sequence_ fcodes } -cgTopBinding dflags (StgTopStringLit id str) - = do { let label = mkBytesLabel (idName id) - ; let (lit, decl) = mkByteStringCLit label str - ; emitDecl decl - ; addBindC (litIdInfo dflags id mkLFStringLit lit) - } +cgTopBinding dflags (StgTopStringLit id str) = do + let label = mkBytesLabel (idName id) + -- emit either a CmmString literal or dump the string in a file and emit a + -- CmmFileEmbed literal. + -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr + let isNCG = hscTarget dflags == HscAsm + isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags + asString = binBlobThreshold dflags == 0 || isSmall + (lit,decl) = if not isNCG || asString + then mkByteStringCLit label str + else mkFileEmbedLit label $ unsafePerformIO $ do + bFile <- newTempName dflags TFL_CurrentModule ".dat" + BS.writeFile bFile str + return bFile + emitDecl decl + addBindC (litIdInfo dflags id mkLFStringLit lit) + + cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args) -- con args are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body) = ASSERT(isEmptyDVarSet fvs) -- There should be no free variables @@ -189,6 +227,7 @@ -- the static closure, for a constructor. cgDataCon data_con = do { dflags <- getDynFlags + ; platform <- getPlatform ; let (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds) -- #ptr_wds @@ -204,7 +243,7 @@ arg_reps :: [NonVoid PrimRep] arg_reps = [ NonVoid rep_ty | ty <- dataConRepArgTys data_con - , rep_ty <- typePrimRep ty + , rep_ty <- typePrimRep (scaledThing ty) , not (isVoidRep rep_ty) ] ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $ @@ -217,7 +256,7 @@ do { tickyEnterDynCon ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)] + ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon dflags data_con)] } -- The case continuation code expects a tagged pointer } diff --git a/GHC/StgToCmm/ArgRep.hs b/GHC/StgToCmm/ArgRep.hs --- a/GHC/StgToCmm/ArgRep.hs +++ b/GHC/StgToCmm/ArgRep.hs @@ -6,6 +6,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-} + module GHC.StgToCmm.ArgRep ( ArgRep(..), toArgRep, argRepSizeW, @@ -15,19 +17,18 @@ ) where -import GhcPrelude - -import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.Prelude +import GHC.Platform -import SMRep ( WordOff ) -import Id ( Id ) -import TyCon ( PrimRep(..), primElemRepSizeB ) -import BasicTypes ( RepArity ) -import Constants ( wORD64_SIZE ) -import DynFlags +import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.Runtime.Heap.Layout ( WordOff ) +import GHC.Types.Id ( Id ) +import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Types.Basic ( RepArity ) +import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString -- I extricated this code as this new module in order to avoid a -- cyclic dependency between GHC.StgToCmm.Layout and GHC.StgToCmm.Ticky. @@ -91,16 +92,19 @@ isNonV V = False isNonV _ = True -argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words -argRepSizeW _ N = 1 -argRepSizeW _ P = 1 -argRepSizeW _ F = 1 -argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags -argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags -argRepSizeW _ V = 0 -argRepSizeW dflags V16 = 16 `quot` wORD_SIZE dflags -argRepSizeW dflags V32 = 32 `quot` wORD_SIZE dflags -argRepSizeW dflags V64 = 64 `quot` wORD_SIZE dflags +argRepSizeW :: Platform -> ArgRep -> WordOff -- Size in words +argRepSizeW platform = \case + N -> 1 + P -> 1 + F -> 1 + L -> wORD64_SIZE `quot` ws + D -> dOUBLE_SIZE `quot` ws + V -> 0 + V16 -> 16 `quot` ws + V32 -> 32 `quot` ws + V64 -> 64 `quot` ws + where + ws = platformWordSizeInBytes platform idArgRep :: Id -> ArgRep idArgRep = toArgRep . idPrimRep diff --git a/GHC/StgToCmm/Bind.hs b/GHC/StgToCmm/Bind.hs --- a/GHC/StgToCmm/Bind.hs +++ b/GHC/StgToCmm/Bind.hs @@ -13,7 +13,8 @@ pushUpdateFrame, emitUpdateFrame ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) +import GHC.Platform import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad @@ -28,32 +29,30 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Foreign (emitPrimCall) -import MkGraph -import CoreSyn ( AltCon(..), tickishIsCode ) -import BlockId -import SMRep -import Cmm -import CmmInfo -import CmmUtils -import CLabel -import StgSyn -import CostCentre -import Id -import IdInfo -import Name -import Module -import ListSetOps -import Util -import VarSet -import BasicTypes -import Outputable -import FastString -import DynFlags +import GHC.Cmm.Graph +import GHC.Core ( AltCon(..), tickishIsCode ) +import GHC.Cmm.BlockId +import GHC.Runtime.Heap.Layout +import GHC.Cmm +import GHC.Cmm.Info +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Stg.Syntax +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Data.List.SetOps +import GHC.Utils.Misc +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Driver.Session import Control.Monad -import TyCon (PrimRep (..)) - ------------------------------------------------------------------------ -- Top-level bindings ------------------------------------------------------------------------ @@ -71,9 +70,10 @@ -> (CgIdInfo, FCode ()) cgTopRhsClosure dflags rec id ccs upd_flag args body = - let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + let platform = targetPlatform dflags + closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) - lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args + lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args in (cg_id_info, gen_code dflags lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC @@ -82,22 +82,18 @@ -- shortcutting the whole process, and generating a lot less code -- (#7308). Eventually the IND_STATIC closure will be eliminated -- by assembly '.equiv' directives, where possible (#15155). - -- See note [emit-time elimination of static indirections] in CLabel. + -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -- -- Note: we omit the optimisation when this binding is part of a -- recursive group, because the optimisation would inhibit the black -- hole detection from working in that case. Test -- concurrent/should_run/4030 fails, for instance. -- - gen_code dflags _ closure_label + gen_code _ _ closure_label | StgApp f [] <- body, null args, isNonRec rec = do cg_info <- getCgIdInfo f - let closure_rep = mkStaticClosureFields dflags - indStaticInfoTable ccs MayHaveCafRefs - [unLit (idInfoToAmode cg_info)] - emitDataLits closure_label closure_rep - return () + emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] gen_code dflags lf_info _closure_label = do { let name = idName id @@ -107,7 +103,7 @@ -- We don't generate the static closure here, because we might -- want to add references to static closures to it later. The - -- static closure is generated by CmmBuildInfoTables.updInfoSRTs, + -- static closure is generated by GHC.Cmm.Info.Build.updInfoSRTs, -- See Note [SRTs], specifically the [FUN] optimisation. ; let fv_details :: [(NonVoid Id, ByteOff)] @@ -115,7 +111,7 @@ (_, _, fv_details) = mkVirtHeapOffsets dflags header [] -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs - (nonVoidIds args) (length args) body fv_details) + args body fv_details) ; return () } @@ -182,7 +178,7 @@ 3. emit all the inits, and then all the bodies We'd rather not have separate functions to do steps 1 and 2 for - each binding, since in pratice they share a lot of code. So we + each binding, since in practice they share a lot of code. So we have just one function, cgRhs, that returns a pair of the CgIdInfo for step 1, and a monadic computation to generate the code in step 2. @@ -200,17 +196,17 @@ CgIdInfo -- The info for this binding , FCode CmmAGraph -- A computation which will generate the -- code for the binding, and return an - -- assignent of the form "x = Hp - n" + -- assignment of the form "x = Hp - n" -- (see above) ) cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterCon (idName id) $ + = withNewTickyCounterCon (idName id) con $ buildDynCon id True cc con (assertNonVoidStgArgs args) -- con args are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -{- See Note [GC recovery] in compiler/GHC.StgToCmm/Closure.hs -} +{- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body) = do dflags <- getDynFlags mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body @@ -277,10 +273,10 @@ , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params)) -- pattern binders are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) - , let offset_into_int = bytesToWordsRoundUp dflags the_offset + , let offset_into_int = bytesToWordsRoundUp (targetPlatform dflags) the_offset - fixedHdrSizeW dflags , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) @@ -311,7 +307,7 @@ , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= mAX_SPEC_AP_SIZE dflags - , not (gopt Opt_SccProfilingOn dflags) + , not (sccProfilingEnabled dflags) -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949) @@ -329,10 +325,11 @@ ---------- Default case ------------------ mkRhsClosure dflags bndr cc fvs upd_flag args body - = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args + = do { let lf_info = mkClosureLFInfo platform bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where + platform = targetPlatform dflags gen_code lf_info reg = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store @@ -346,7 +343,6 @@ -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName - ; dflags <- getDynFlags ; let name = idName bndr descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, ByteOff)] @@ -362,8 +358,8 @@ -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere -- (b) ignore Sequel from context; use empty Sequel -- And compile the body - closureCodeBody False bndr closure_info cc (nonVoidIds args) - (length args) body fv_details + closureCodeBody False bndr closure_info cc args + body fv_details -- BUILD THE OBJECT -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body @@ -418,18 +414,18 @@ ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -mkClosureLFInfo :: DynFlags +mkClosureLFInfo :: Platform -> Id -- The binder -> TopLevelFlag -- True of top level -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args -> LambdaFormInfo -mkClosureLFInfo dflags bndr top fvs upd_flag args +mkClosureLFInfo platform bndr top fvs upd_flag args | null args = mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag | otherwise = - mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args) + mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr platform args) ------------------------------------------------------------------------ @@ -440,8 +436,7 @@ -> Id -- the closure's name -> ClosureInfo -- Lots of information about this closure -> CostCentreStack -- Optional cost centre attached to closure - -> [NonVoid Id] -- incoming args to the closure - -> Int -- arity, including void args + -> [Id] -- incoming args to the closure -> CgStgExpr -> [(NonVoid Id, ByteOff)] -- the closure's free vars -> FCode () @@ -456,35 +451,37 @@ normal form, so there is no need to set up an update frame. -} -closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details - | arity == 0 -- No args i.e. thunk +-- No args i.e. thunk +closureCodeBody top_lvl bndr cl_info cc [] body fv_details = withNewTickyCounterThunk (isStaticClosure cl_info) (closureUpdReqd cl_info) (closureName cl_info) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ - \(_, node, _) -> thunkCode cl_info fv_details cc node arity body + \(_, node, _) -> thunkCode cl_info fv_details cc node body where lf_info = closureLFInfo cl_info info_tbl = mkCmmInfo cl_info bndr cc -closureCodeBody top_lvl bndr cl_info cc args arity body fv_details - = -- Note: args may be [], if all args are Void - withNewTickyCounterFun - (closureSingleEntry cl_info) - (closureName cl_info) - args $ do { +closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details + = let nv_args = nonVoidIds args + arity = length args + in + -- See Note [OneShotInfo overview] in GHC.Types.Basic. + withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) + nv_args $ do { ; let lf_info = closureLFInfo cl_info info_tbl = mkCmmInfo cl_info bndr cc -- Emit the main entry code - ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $ + ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $ \(_offset, node, arg_regs) -> do -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode bndr cl_info arg_regs ; dflags <- getDynFlags + ; platform <- getPlatform ; let node_points = nodeMustPointToIt dflags lf_info node' = if node_points then Just node else Nothing ; loop_header_id <- newBlockId @@ -500,9 +497,9 @@ -- ticky after heap check to avoid double counting ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp (mo_wordSub dflags) + (CmmMachOp (mo_wordSub platform) [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr dflags (funTag dflags cl_info) ]) + , mkIntExpr platform (funTag dflags cl_info) ]) ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check @@ -532,8 +529,9 @@ load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) -> do dflags <- getDynFlags + platform <- getPlatform let tag = lfDynTag dflags lf_info - emit $ mkTaggedObjectLoad dflags reg node off tag) + emit $ mkTaggedObjectLoad platform reg node off tag) ----------------------------------------- -- The "slow entry" code for a function. This entry point takes its @@ -551,14 +549,15 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info = do dflags <- getDynFlags - let node = idToReg dflags (NonVoid bndr) + platform <- getPlatform + let node = idToReg platform (NonVoid bndr) slow_lbl = closureSlowEntryLabel cl_info - fast_lbl = closureLocalEntryLabel dflags cl_info + fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkJump dflags NativeNodeCall (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) (node : arg_regs)) - (initUpdFrameOff dflags) + (initUpdFrameOff platform) tscope <- getTickScope emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) (jump, tscope) @@ -566,15 +565,15 @@ ----------------------------------------- thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack - -> LocalReg -> Int -> CgStgExpr -> FCode () -thunkCode cl_info fv_details _cc node arity body + -> LocalReg -> CgStgExpr -> FCode () +thunkCode cl_info fv_details _cc node body = do { dflags <- getDynFlags ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling -- Heap overflow check - ; entryHeapCheck cl_info node' arity [] $ do + ; entryHeapCheck cl_info node' 0 [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check ; tickyEnterThunk cl_info @@ -607,6 +606,7 @@ emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do dflags <- getDynFlags + let platform = targetPlatform dflags -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer @@ -624,17 +624,17 @@ -- unconditionally disabled. -- krc 1/2007 -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, - -- because emitBlackHoleCode is called from CmmParse. + -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (gopt Opt_SccProfilingOn dflags) + let eager_blackholing = not (sccProfilingEnabled dflags) && gopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't -- work with profiling. when eager_blackholing $ do - whenUpdRemSetEnabled dflags $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr + whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node + emitStore (cmmOffsetW platform node (fixedHdrSizeW dflags)) currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. emitPrimCall [] MO_WriteBarrier [] emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -655,7 +655,7 @@ dflags <- getDynFlags let bh = blackHoleOnEntry closure_info && - not (gopt Opt_SccProfilingOn dflags) && + not (sccProfilingEnabled dflags) && gopt Opt_EagerBlackHoling dflags lbl | bh = mkBHUpdInfoLabel @@ -697,9 +697,10 @@ let hdr = fixedHdrSize dflags off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags + platform = targetPlatform dflags -- emitStore frame (mkLblExpr lbl) - emitStore (cmmOffset dflags frame off_updatee) updatee + emitStore (cmmOffset platform frame off_updatee) updatee initUpdFrameProf frame ----------------------------------------------------------------------------- @@ -717,17 +718,18 @@ -- blackhole indirection closure ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction - ; bh <- newTemp (bWord dflags) - ; emitRtsCallGen [(bh, AddrRep, AddrHint)] newCAF_lbl - [ (baseExpr, AddrRep, AddrHint), - (CmmReg (CmmLocal node), AddrRep, AddrHint) ] + ; let platform = targetPlatform dflags + ; bh <- newTemp (bWord platform) + ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl + [ (baseExpr, AddrHint), + (CmmReg (CmmLocal node), AddrHint) ] False -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff - ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) + ; let target = entryCode platform (closureInfoPtr dflags (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen - (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags)) + (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF (mkJump dflags NativeNodeCall target [] updfr) diff --git a/GHC/StgToCmm/Bind.hs-boot b/GHC/StgToCmm/Bind.hs-boot --- a/GHC/StgToCmm/Bind.hs-boot +++ b/GHC/StgToCmm/Bind.hs-boot @@ -1,6 +1,6 @@ module GHC.StgToCmm.Bind where import GHC.StgToCmm.Monad( FCode ) -import StgSyn( CgStgBinding ) +import GHC.Stg.Syntax( CgStgBinding ) cgBind :: CgStgBinding -> FCode () diff --git a/GHC/StgToCmm/CgUtils.hs b/GHC/StgToCmm/CgUtils.hs --- a/GHC/StgToCmm/CgUtils.hs +++ b/GHC/StgToCmm/CgUtils.hs @@ -16,16 +16,16 @@ get_GlobalReg_addr, ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform.Regs -import Cmm -import Hoopl.Block -import Hoopl.Graph -import CmmUtils -import CLabel -import DynFlags -import Outputable +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Driver.Session +import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Information about global registers @@ -121,7 +121,7 @@ get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr get_Regtable_addr_from_offset dflags offset = if haveRegBase (targetPlatform dflags) - then CmmRegOff baseReg offset + then cmmRegOff baseReg offset else regTableOffset dflags offset -- | Fixup global registers so that they assign to locations within the @@ -149,7 +149,7 @@ | reg == MachSp -> stmt | otherwise -> let baseAddr = get_GlobalReg_addr dflags reg - in case reg `elem` activeStgRegs (targetPlatform dflags) of + in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src False -> CmmStore baseAddr src other_stmt -> other_stmt @@ -170,7 +170,7 @@ let baseAddr = get_GlobalReg_addr dflags reg in case reg of BaseReg -> baseAddr - _other -> CmmLoad baseAddr (globalRegType dflags reg) + _other -> CmmLoad baseAddr (globalRegType platform reg) CmmRegOff (CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps @@ -178,9 +178,9 @@ -- expand it and defer to the above code. case reg `elem` activeStgRegs platform of True -> expr - False -> CmmMachOp (MO_Add (wordWidth dflags)) [ + False -> CmmMachOp (MO_Add (wordWidth platform)) [ fixExpr (CmmReg (CmmGlobal reg)), CmmLit (CmmInt (fromIntegral offset) - (wordWidth dflags))] + (wordWidth platform))] other_expr -> other_expr diff --git a/GHC/StgToCmm/Closure.hs b/GHC/StgToCmm/Closure.hs --- a/GHC/StgToCmm/Closure.hs +++ b/GHC/StgToCmm/Closure.hs @@ -48,7 +48,7 @@ -- ** Predicates -- These are really just functions on LambdaFormInfo - closureUpdReqd, closureSingleEntry, + closureUpdReqd, closureReEntrant, closureFunInfo, isToplevClosure, @@ -64,29 +64,31 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude +import GHC.Platform -import StgSyn -import SMRep -import Cmm -import PprCmmExpr() -- For Outputable instances +import GHC.Stg.Syntax +import GHC.Runtime.Heap.Layout +import GHC.Cmm +import GHC.Cmm.Ppr.Expr() -- For Outputable instances +import GHC.StgToCmm.Types -import CostCentre -import BlockId -import CLabel -import Id -import IdInfo -import DataCon -import Name -import Type -import TyCoRep -import TcType -import TyCon -import RepType -import BasicTypes -import Outputable -import DynFlags -import Util +import GHC.Types.CostCentre +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.DataCon +import GHC.Types.Name +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Types.RepType +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Utils.Misc import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 @@ -142,7 +144,7 @@ -- | Used in places where some invariant ensures that all these Ids are -- non-void; e.g. constructor field binders in case expressions. --- See Note [Post-unarisation invariants] in UnariseStg. +-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidIds :: [Id] -> [NonVoid Id] assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids)) coerce ids @@ -152,7 +154,7 @@ -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments. --- See Note [Post-unarisation invariants] in UnariseStg. +-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args)) coerce args @@ -169,7 +171,7 @@ -- See Note [Post-unarisation invariants] idPrimRep :: Id -> PrimRep idPrimRep id = typePrimRep1 (idType id) - -- See also Note [VoidRep] in RepType + -- See also Note [VoidRep] in GHC.Types.RepType -- | Assumes that Ids have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] @@ -188,77 +190,6 @@ argPrimRep :: StgArg -> PrimRep argPrimRep arg = typePrimRep1 (stgArgType arg) - ------------------------------------------------------------------------------ --- LambdaFormInfo ------------------------------------------------------------------------------ - --- Information about an identifier, from the code generator's point of --- view. Every identifier is bound to a LambdaFormInfo in the --- environment, which gives the code generator enough info to be able to --- tail call or return that identifier. - -data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - OneShotInfo - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs - ArgDescr -- Argument descriptor (should really be in ClosureInfo) - - | LFThunk -- Thunk (zero arity) - TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) - StandardFormInfo - !Bool -- True <=> *might* be a function type - - | LFCon -- A saturated constructor application - DataCon -- The constructor - - | LFUnknown -- Used for function arguments and imported things. - -- We know nothing about this closure. - -- Treat like updatable "LFThunk"... - -- Imported things which we *do* know something about use - -- one of the other LF constructors (eg LFReEntrant for - -- known functions) - !Bool -- True <=> *might* be a function type - -- The False case is good when we want to enter it, - -- because then we know the entry code will do - -- For a function, the entry code is the fast entry point - - | LFUnlifted -- A value of unboxed type; - -- always a value, needs evaluation - - | LFLetNoEscape -- See LetNoEscape module for precise description - - -------------------------- --- StandardFormInfo tells whether this thunk has one of --- a small number of standard forms - -data StandardFormInfo - = NonStandardThunk - -- The usual case: not of the standard forms - - | SelectorThunk - -- A SelectorThunk is of form - -- case x of - -- con a1,..,an -> ak - -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) - - | ApThunk - -- An ApThunk is of form - -- x1 ... xn - -- The code for the thunk just pushes x2..xn on the stack and enters x1. - -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - -- in the RTS to save space. - RepArity -- Arity, n - - ------------------------------------------------------ -- Building LambdaFormInfo ------------------------------------------------------ @@ -285,8 +216,7 @@ mkLFReEntrant _ _ [] _ = pprPanic "mkLFReEntrant" empty mkLFReEntrant top fvs args arg_descr - = LFReEntrant top os_info (length args) (null fvs) arg_descr - where os_info = idOneShotInfo (head args) + = LFReEntrant top (length args) (null fvs) arg_descr ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo @@ -327,18 +257,27 @@ ------------- mkLFImported :: Id -> LambdaFormInfo -mkLFImported id - | Just con <- isDataConWorkId_maybe id - , isNullaryRepDataCon con - = LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor +mkLFImported id = + -- See Note [Conveying CAF-info and LFInfo between modules] in + -- GHC.StgToCmm.Types + case idLFInfo_maybe id of + Just lf_info -> + -- Use the LambdaFormInfo from the interface + lf_info + Nothing + -- Interface doesn't have a LambdaFormInfo, make a conservative one from + -- the type. + | Just con <- isDataConWorkId_maybe id + , isNullaryRepDataCon con + -> LFCon con -- An imported nullary constructor + -- We assume that the constructor is evaluated so that + -- the id really does point directly to the constructor - | arity > 0 - = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr") + | arity > 0 + -> LFReEntrant TopLevel arity True ArgUnknown - | otherwise - = mkLFArgument id -- Not sure of exact arity + | otherwise + -> mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id @@ -384,9 +323,9 @@ lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag -- Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag dflags (LFCon con) = tagForCon dflags con -lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity -lfDynTag _ _other = 0 +lfDynTag dflags (LFCon con) = tagForCon dflags con +lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity +lfDynTag _ _other = 0 ----------------------------------------------------------------------------- @@ -407,11 +346,11 @@ ----------------------------------------------------------------------------- lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd -lfClosureType (LFCon con) = Constr (dataConTagZ con) - (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" +lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd +lfClosureType (LFCon con) = Constr (dataConTagZ con) + (dataConIdentity con) +lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel +lfClosureType _ = panic "lfClosureType" thunkClosureType :: StandardFormInfo -> ClosureTypeInfo thunkClosureType (SelectorThunk off) = ThunkSelector off @@ -431,7 +370,7 @@ -- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument -nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _) +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) = not no_fvs -- Certainly if it has fvs we need to point to it || isNotTopLevel top -- See Note [GC recovery] -- For lex_profiling we also access the cost centre for a @@ -442,7 +381,7 @@ = not no_fvs -- Self parameter || isNotTopLevel top -- Note [GC recovery] || updatable -- Need to push update frame - || gopt Opt_SccProfilingOn dflags + || sccProfilingEnabled dflags -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -487,7 +426,7 @@ really does happen occasionally) let-floating may make a function f smaller so it can be inlined, so now (f True) may generate a local no-fv closure. This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind -in TcGenDeriv.) -} +in GHC.Tc.Deriv.Generate.) -} ----------------------------------------------------------------------------- -- getCallMethod @@ -566,14 +505,14 @@ -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details = JumpToIt block_id args -getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc +getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all - && not (gopt Opt_SccProfilingOn dflags) + && not (sccProfilingEnabled dflags) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = ASSERT( arity /= 0 ) ReturnIt | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity + | otherwise = DirectEntry (enterIdLabel (targetPlatform dflags) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt @@ -699,7 +638,7 @@ prof = mkProfilingInfo dflags id val_descr nonptr_wds = tot_wds - ptr_wds - info_lbl = mkClosureInfoTableLabel id lf_info + info_lbl = mkClosureInfoTableLabel dflags id lf_info -------------------------------------- -- Other functions over ClosureInfo @@ -811,11 +750,6 @@ lfUpdatable (LFThunk _ _ upd _ _) = upd lfUpdatable _ = False -closureSingleEntry :: ClosureInfo -> Bool -closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd -closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True -closureSingleEntry _ = False - closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True closureReEntrant _ = False @@ -824,8 +758,8 @@ closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) -lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc) -lfFunInfo _ = Nothing +lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) +lfFunInfo _ = Nothing funTag :: DynFlags -> ClosureInfo -> DynTag funTag dflags (ClosureInfo { closureLFInfo = lf_info }) @@ -834,9 +768,9 @@ isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of - LFReEntrant TopLevel _ _ _ _ -> True - LFThunk TopLevel _ _ _ _ -> True - _other -> False + LFReEntrant TopLevel _ _ _ -> True + LFThunk TopLevel _ _ _ _ -> True + _other -> False -------------------------------------- -- Label generation @@ -848,19 +782,19 @@ closureSlowEntryLabel :: ClosureInfo -> CLabel closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel -closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel -closureLocalEntryLabel dflags - | tablesNextToCode dflags = toInfoLbl . closureInfoLabel - | otherwise = toEntryLbl . closureInfoLabel +closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel +closureLocalEntryLabel platform + | platformTablesNextToCode platform = toInfoLbl . closureInfoLabel + | otherwise = toEntryLbl . closureInfoLabel -mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel -mkClosureInfoTableLabel id lf_info +mkClosureInfoTableLabel :: DynFlags -> Id -> LambdaFormInfo -> CLabel +mkClosureInfoTableLabel dflags id lf_info = case lf_info of LFThunk _ _ upd_flag (SelectorThunk offset) _ - -> mkSelectorInfoLabel upd_flag offset + -> mkSelectorInfoLabel dflags upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ - -> mkApInfoTableLabel upd_flag arity + -> mkApInfoTableLabel dflags upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs @@ -877,7 +811,7 @@ -- Make the _info pointer for the implicit datacon worker -- binding local. The reason we can do this is that importing -- code always either uses the _closure or _con_info. By the - -- invariants in CorePrep anything else gets eta expanded. + -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded. thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel @@ -888,22 +822,26 @@ thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag = enterSelectorLabel dflags upd_flag offset thunkEntryLabel dflags thunk_id c _ _ - = enterIdLabel dflags thunk_id c + = enterIdLabel (targetPlatform dflags) thunk_id c enterApLabel :: DynFlags -> Bool -> Arity -> CLabel enterApLabel dflags is_updatable arity - | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity - | otherwise = mkApEntryLabel is_updatable arity + | platformTablesNextToCode platform = mkApInfoTableLabel dflags is_updatable arity + | otherwise = mkApEntryLabel dflags is_updatable arity + where + platform = targetPlatform dflags enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel enterSelectorLabel dflags upd_flag offset - | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset - | otherwise = mkSelectorEntryLabel upd_flag offset + | platformTablesNextToCode platform = mkSelectorInfoLabel dflags upd_flag offset + | otherwise = mkSelectorEntryLabel dflags upd_flag offset + where + platform = targetPlatform dflags -enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel -enterIdLabel dflags id c - | tablesNextToCode dflags = mkInfoTableLabel id c - | otherwise = mkEntryLabel id c +enterIdLabel :: Platform -> Name -> CafInfo -> CLabel +enterIdLabel platform id c + | platformTablesNextToCode platform = mkInfoTableLabel id c + | otherwise = mkEntryLabel id c -------------------------------------- @@ -921,7 +859,7 @@ mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo mkProfilingInfo dflags id val_descr - | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo + | not (sccProfilingEnabled dflags) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) where ty_descr_w8 = BS8.pack (getTyDescription (idType id)) @@ -968,8 +906,8 @@ -- We keep the *zero-indexed* tag in the srt_len field -- of the info table of a data constructor. - prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr val_descr + prof | not (sccProfilingEnabled dflags) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr val_descr ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con val_descr = BS8.pack $ occNameString $ getOccName data_con diff --git a/GHC/StgToCmm/DataCon.hs b/GHC/StgToCmm/DataCon.hs --- a/GHC/StgToCmm/DataCon.hs +++ b/GHC/StgToCmm/DataCon.hs @@ -4,7 +4,7 @@ -- -- Stg to C--: code generation for constructors -- --- This module provides the support code for StgToCmm to deal with with +-- This module provides the support code for StgToCmm to deal with -- constructors on the RHSs of let(rec)s. -- -- (c) The University of Glasgow 2004-2006 @@ -17,10 +17,10 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import StgSyn -import CoreSyn ( AltCon(..) ) +import GHC.Stg.Syntax +import GHC.Core ( AltCon(..) ) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env @@ -29,30 +29,30 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure -import CmmExpr -import CmmUtils -import CLabel -import MkGraph -import SMRep -import CostCentre -import Module -import DataCon -import DynFlags -import FastString -import Id -import RepType (countConRepArgs) -import Literal -import PrelInfo -import Outputable +import GHC.Cmm.Expr +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Cmm.Graph +import GHC.Runtime.Heap.Layout +import GHC.Types.CostCentre +import GHC.Unit +import GHC.Core.DataCon +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Types.Id.Info( CafInfo( NoCafRefs ) ) +import GHC.Types.Name (isInternalName) +import GHC.Types.RepType (countConRepArgs) +import GHC.Types.Literal +import GHC.Builtin.Utils +import GHC.Utils.Outputable import GHC.Platform -import Util -import MonadUtils (mapMaybeM) +import GHC.Utils.Misc +import GHC.Utils.Monad (mapMaybeM) import Control.Monad import Data.Char - - --------------------------------------------------------------- -- Top-level constructors --------------------------------------------------------------- @@ -62,10 +62,24 @@ -> DataCon -- Id -> [NonVoid StgArg] -- Args -> (CgIdInfo, FCode ()) -cgTopRhsCon dflags id con args = - let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) - in (id_info, gen_code) +cgTopRhsCon dflags id con args + | Just static_info <- precomputedStaticConInfo_maybe dflags id con args + , let static_code | isInternalName name = pure () + | otherwise = gen_code + = -- There is a pre-allocated static closure available; use it + -- See Note [Precomputed static closures]. + -- For External bindings we must keep the binding, + -- since importing modules will refer to it by name; + -- but for Internal ones we can drop it altogether + -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External + (static_info, static_code) + + -- Otherwise generate a closure for the constructor. + | otherwise + = (id_Info, gen_code) + where + id_Info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy @@ -84,21 +98,6 @@ nv_args_w_offsets) = mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args) - ; let - -- Decompose padding into units of length 8, 4, 2, or 1 bytes to - -- allow the implementation of mk_payload to use widthFromBytes, - -- which only handles these cases. - fix_padding (x@(Padding n off) : rest) - | n == 0 = fix_padding rest - | n `elem` [1,2,4,8] = x : fix_padding rest - | n > 8 = add_pad 8 - | n > 4 = add_pad 4 - | n > 2 = add_pad 2 - | otherwise = add_pad 1 - where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest) - fix_padding (x : rest) = x : fix_padding rest - fix_padding [] = [] - mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len)) mk_payload (FieldOff arg _) = do amode <- getArgAmode arg @@ -114,22 +113,13 @@ info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds - ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets) + ; payload <- mapM mk_payload nv_args_w_offsets -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs -- NB2: all the amodes should be Lits! -- TODO (osa): Why? - ; let closure_rep = mkStaticClosureFields - dflags - info_tbl - dontCareCCS -- Because it's static data - caffy -- Has CAF refs - payload - -- BUILD THE OBJECT - ; emitDataLits closure_label closure_rep - - ; return () } + ; emitDataCon closure_label info_tbl dontCareCCS payload } --------------------------------------------------------------- @@ -148,11 +138,10 @@ -- Return details about how to find it and initialization code buildDynCon binder actually_bound cc con args = do dflags <- getDynFlags - buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args + buildDynCon' dflags binder actually_bound cc con args buildDynCon' :: DynFlags - -> Platform -> Id -> Bool -> CostCentreStack -> DataCon @@ -170,78 +159,13 @@ premature looking at the args will cause the compiler to black-hole! -} - --------- buildDynCon': Nullary constructors -------------- --- First we deal with the case of zero-arity constructors. They --- will probably be unfolded, so we don't expect to see this case much, --- if at all, but it does no harm, and sets the scene for characters. --- --- In the case of zero-arity constructors, or, more accurately, those --- which have exclusively size-zero (VoidRep) args, we generate no code --- at all. - -buildDynCon' dflags _ binder _ _cc con [] - | isNullaryRepDataCon con - = return (litIdInfo dflags binder (mkConLFInfo con) - (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), - return mkNop) - --------- buildDynCon': Charlike and Intlike constructors ----------- -{- The following three paragraphs about @Char@-like and @Int@-like -closures are obsolete, but I don't understand the details well enough -to properly word them, sorry. I've changed the treatment of @Char@s to -be analogous to @Int@s: only a subset is preallocated, because @Char@ -has now 31 bits. Only literals are handled here. -- Qrczak - -Now for @Char@-like closures. We generate an assignment of the -address of the closure to a temporary. It would be possible simply to -generate no code, and record the addressing mode in the environment, -but we'd have to be careful if the argument wasn't a constant --- so -for simplicity we just always assign to a temporary. - -Last special case: @Int@-like closures. We only special-case the -situation in which the argument is a literal in the range -@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can -work with any old argument, but for @Int@-like ones the argument has -to be a literal. Reason: @Char@ like closures have an argument type -which is guaranteed in range. - -Because of this, we use can safely return an addressing mode. - -We don't support this optimisation when compiling into Windows DLLs yet -because they don't support cross package data references well. --} - -buildDynCon' dflags platform binder _ _cc con [arg] - | maybeIntLikeCon con - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) - , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg - , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! - , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... - = do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE") - val_int = fromIntegral val :: Int - offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1) - -- INTLIKE closures consist of a header and one word payload - intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW - ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode - , return mkNop) } - -buildDynCon' dflags platform binder _ _cc con [arg] - | maybeCharLikeCon con - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) - , NonVoid (StgLitArg (LitChar val)) <- arg - , let val_int = ord val :: Int - , val_int <= mAX_CHARLIKE dflags - , val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE") - offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1) - -- CHARLIKE closures consist of a header and one word payload - charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW - ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode - , return mkNop) } +buildDynCon' dflags binder _ _cc con args + | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args + -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True + = return (cgInfo, return mkNop) -------- buildDynCon': the general case ----------- -buildDynCon' dflags _ binder actually_bound ccs con args +buildDynCon' dflags binder actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -267,7 +191,150 @@ blame_cc = use_cc -- cost-centre on which to blame the alloc (same) +{- Note [Precomputed static closures] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Char/Int closures there are some value closures +built into the RTS. This is the case for all values in +the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE). +See Note [CHARLIKE and INTLIKE closures.] in the RTS code. + +Similarly zero-arity constructors have a closure +in their defining Module we can use. + +If possible we prefer to refer to those existing +closure instead of building new ones. + +This is true at compile time where we do this replacement +in this module. +But also at runtime where the GC does the same (but only for +INT/CHAR closures). + +`precomputedStaticConInfo_maybe` checks if a given constructor application +can be replaced with a reference to a existing static closure. + +If so the code will reference the existing closure when accessing +the binding. +Unless the binding is visible to other modules we also generate +no code for the binding itself. We can do this since then we can +always reference the existing closure. + +See Note [About the NameSorts] for the definition of external names. +For external bindings we must still generate a closure, +but won't use it inside this module. +This can sometimes reduce cache pressure. Since: +* If somebody uses the exported binding: + + This module will reference the existing closure. + + GC will reference the existing closure. + + The importing module will reference the built closure. +* If nobody uses the exported binding: + + This module will reference the RTS closures. + + GC references the RTS closures + +In the later case we avoided loading the built closure into the cache which +is what we optimize for here. + +Consider this example using Ints. + + module M(externalInt, foo, bar) where + + externalInt = 1 :: Int + internalInt = 1 :: Int + { -# NOINLINE foo #- } + foo = Just internalInt :: Maybe Int + bar = Just externalInt + + ==================== STG: ==================== + externalInt = I#! [1#]; + + bar = Just! [externalInt]; + + internalInt_rc = I#! [2#]; + + foo = Just! [internalInt_rc]; + +For externally visible bindings we must generate closures +since those may be referenced by their symbol `_closure` +when imported. + +`externalInt` is visible to other modules so we generate a closure: + + [section ""data" . M.externalInt_closure" { + M.externalInt_closure: + const GHC.Types.I#_con_info; + const 1; + }] + +It will be referenced inside this module via `M.externalInt_closure+1` + +`internalInt` is however a internal name. As such we generate no code for +it. References to it are replaced with references to the static closure as +we can see in the closure built for `foo`: + + [section ""data" . M.foo_closure" { + M.foo_closure: + const GHC.Maybe.Just_con_info; + const stg_INTLIKE_closure+289; // == I# 2 + const 3; + }] + +This holds for both local and top level bindings. + +We don't support this optimization when compiling into Windows DLLs yet +because they don't support cross package data references well. +-} + +-- (precomputedStaticConInfo_maybe dflags id con args) +-- returns (Just cg_id_info) +-- if there is a precomputed static closure for (con args). +-- In that case, cg_id_info addresses it. +-- See Note [Precomputed static closures] +precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo +precomputedStaticConInfo_maybe dflags binder con [] +-- Nullary constructors + | isNullaryRepDataCon con + = Just $ litIdInfo dflags binder (mkConLFInfo con) + (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) +precomputedStaticConInfo_maybe dflags binder con [arg] + -- Int/Char values with existing closures in the RTS + | intClosure || charClosure + , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) + , Just val <- getClosurePayload arg + , inRange val + = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) + val_int = fromIntegral val :: Int + offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW dflags + 1) + -- INTLIKE/CHARLIKE closures consist of a header and one word payload + static_amode = cmmLabelOffW platform intlike_lbl offsetW + in Just $ litIdInfo dflags binder (mkConLFInfo con) static_amode + where + platform = targetPlatform dflags + intClosure = maybeIntLikeCon con + charClosure = maybeCharLikeCon con + getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val + getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val) + getClosurePayload _ = Nothing + -- Avoid over/underflow by comparisons at type Integer! + inRange :: Integer -> Bool + inRange val + = val >= min_static_range && val <= max_static_range + + min_static_range :: Integer + min_static_range + | intClosure = fromIntegral (mIN_INTLIKE dflags) + | charClosure = fromIntegral (mIN_CHARLIKE dflags) + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + max_static_range + | intClosure = fromIntegral (mAX_INTLIKE dflags) + | charClosure = fromIntegral (mAX_CHARLIKE dflags) + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + label + | intClosure = "stg_INTLIKE" + | charClosure = "stg_CHARLIKE" + | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" + +precomputedStaticConInfo_maybe _ _ _ _ = Nothing + --------------------------------------------------------------- -- Binding constructor arguments --------------------------------------------------------------- @@ -280,6 +347,7 @@ bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con)) do dflags <- getDynFlags + platform <- getPlatform let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) tag = tagForCon dflags con @@ -290,7 +358,7 @@ | isDeadBinder b -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr = return Nothing | otherwise - = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) + = do { emit $ mkTaggedObjectLoad platform (idToReg platform arg) base offset tag ; Just <$> bindArgToReg arg } diff --git a/GHC/StgToCmm/Env.hs b/GHC/StgToCmm/Env.hs --- a/GHC/StgToCmm/Env.hs +++ b/GHC/StgToCmm/Env.hs @@ -24,29 +24,30 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import TyCon +import GHC.Core.TyCon +import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure -import CLabel +import GHC.Cmm.CLabel -import BlockId -import CmmExpr -import CmmUtils -import DynFlags -import Id -import MkGraph -import Name -import Outputable -import StgSyn -import Type -import TysPrim -import UniqFM -import Util -import VarEnv +import GHC.Cmm.BlockId +import GHC.Cmm.Expr +import GHC.Cmm.Utils +import GHC.Driver.Session +import GHC.Types.Id +import GHC.Cmm.Graph +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Stg.Syntax +import GHC.Core.Type +import GHC.Builtin.Types.Prim +import GHC.Types.Unique.FM +import GHC.Utils.Misc +import GHC.Types.Var.Env ------------------------------------- -- Manipulating CgIdInfo @@ -60,14 +61,15 @@ litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo litIdInfo dflags id lf lit = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) } + , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) } where tag = lfDynTag dflags lf + platform = targetPlatform dflags -lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo -lneIdInfo dflags id regs +lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo +lneIdInfo platform id regs = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) } + , cg_loc = LneLoc blk_id (map (idToReg platform) regs) } where lf = mkLFLetNoEscape blk_id = mkBlockId (idUnique id) @@ -75,13 +77,14 @@ rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) rhsIdInfo id lf_info - = do dflags <- getDynFlags - reg <- newTemp (gcWord dflags) + = do platform <- getPlatform + reg <- newTemp (gcWord platform) return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph mkRhsInit dflags reg lf_info expr - = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info)) + = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info)) + where platform = targetPlatform dflags idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer @@ -89,9 +92,9 @@ idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc -addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr --- A tag adds a byte offset to the pointer -addDynTag dflags expr tag = cmmOffsetB dflags expr tag +-- | A tag adds a byte offset to the pointer +addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr +addDynTag platform expr tag = cmmOffsetB platform expr tag maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) @@ -133,7 +136,7 @@ let ext_lbl | isUnliftedType (idType id) = -- An unlifted external Id must refer to a top-level - -- string literal. See Note [Bytes label] in CLabel. + -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel". ASSERT( idType id `eqType` addrPrimTy ) mkBytesLabel name | otherwise = mkClosureLabel name $ idCafInfo id @@ -177,8 +180,8 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg -- Bind an Id to a fresh LocalReg bindToReg nvid@(NonVoid id) lf_info - = do dflags <- getDynFlags - let reg = idToReg dflags nvid + = do platform <- getPlatform + let reg = idToReg platform nvid addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) return reg @@ -195,7 +198,7 @@ bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] bindArgsToRegs args = mapM bindArgToReg args -idToReg :: DynFlags -> NonVoid Id -> LocalReg +idToReg :: Platform -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder -- @@ -203,6 +206,6 @@ -- -- By now the Ids should be uniquely named; else one would worry -- about accidental collision -idToReg dflags (NonVoid id) +idToReg platform (NonVoid id) = LocalReg (idUnique id) - (primRepCmmType dflags (idPrimRep id)) + (primRepCmmType platform (idPrimRep id)) diff --git a/GHC/StgToCmm/Expr.hs b/GHC/StgToCmm/Expr.hs --- a/GHC/StgToCmm/Expr.hs +++ b/GHC/StgToCmm/Expr.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: expressions @@ -12,7 +14,7 @@ #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind ) @@ -28,26 +30,26 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure -import StgSyn +import GHC.Stg.Syntax -import MkGraph -import BlockId -import Cmm hiding ( succ ) -import CmmInfo -import CoreSyn -import DataCon -import DynFlags ( mAX_PTR_TAG ) -import ForeignCall -import Id -import PrimOp -import TyCon -import Type ( isUnliftedType ) -import RepType ( isVoidTy, countConRepArgs ) -import CostCentre ( CostCentreStack, currentCCS ) -import Maybes -import Util -import FastString -import Outputable +import GHC.Cmm.Graph +import GHC.Cmm.BlockId +import GHC.Cmm hiding ( succ ) +import GHC.Cmm.Info +import GHC.Core +import GHC.Core.DataCon +import GHC.Driver.Session ( mAX_PTR_TAG ) +import GHC.Types.ForeignCall +import GHC.Types.Id +import GHC.Builtin.PrimOps +import GHC.Core.TyCon +import GHC.Core.Type ( isUnliftedType ) +import GHC.Types.RepType ( isVoidTy, countConRepArgs ) +import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable import Control.Monad ( unless, void ) import Control.Arrow ( first ) @@ -62,7 +64,7 @@ cgExpr (StgApp fun args) = cgIdApp fun args -- seq# a s ==> a --- See Note [seq# magic] in PrelRules +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] @@ -70,8 +72,9 @@ -- See Note [dataToTag#] in primops.txt.pp cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do dflags <- getDynFlags + platform <- getPlatform emitComment (mkFastString "dataToTag#") - tmp <- newTemp (bWord dflags) + tmp <- newTemp (bWord platform) _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) -- TODO: For small types look at the tag bits instead of reading info table emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))] @@ -173,8 +176,8 @@ -> FCode (CgIdInfo, FCode ()) cgLetNoEscapeClosure bndr cc_slot _unused_cc args body - = do dflags <- getDynFlags - return ( lneIdInfo dflags bndr args + = do platform <- getPlatform + return ( lneIdInfo platform bndr args , code ) where code = forkLneBody $ do { @@ -301,75 +304,7 @@ ------------------------------------- cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind -cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts - | isEnumerationTyCon tycon -- Note [case on bool] - = do { tag_expr <- do_enum_primop op args - - -- If the binder is not dead, convert the tag to a constructor - -- and assign it. See Note [Dead-binder optimisation] - ; unless (isDeadBinder bndr) $ do - { dflags <- getDynFlags - ; tmp_reg <- bindArgToReg (NonVoid bndr) - ; emitAssign (CmmLocal tmp_reg) - (tagToClosure dflags tycon tag_expr) } - - ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly) - (NonVoid bndr) alts - -- See Note [GC for conditionals] - ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1) - ; return AssignedDirectly - } - where - do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr - do_enum_primop TagToEnumOp [arg] -- No code! - = getArgAmode (NonVoid arg) - do_enum_primop primop args - = do dflags <- getDynFlags - tmp <- newTemp (bWord dflags) - cgPrimOp [tmp] primop args - return (CmmReg (CmmLocal tmp)) - {- -Note [case on bool] -~~~~~~~~~~~~~~~~~~~ -This special case handles code like - - case a <# b of - True -> - False -> - ---> case tagToEnum# (a <$# b) of - True -> .. ; False -> ... - ---> case (a <$# b) of r -> - case tagToEnum# r of - True -> .. ; False -> ... - -If we let the ordinary case code handle it, we'll get something like - - tmp1 = a < b - tmp2 = Bool_closure_tbl[tmp1] - if (tmp2 & 7 != 0) then ... // normal tagged case - -but this junk won't optimise away. What we really want is just an -inline comparison: - - if (a < b) then ... - -So we add a special case to generate - - tmp1 = a < b - if (tmp1 == 0) then ... - -and later optimisations will further improve this. - -Now that #6135 has been resolved it should be possible to remove that -special case. The idea behind this special case and pre-6135 implementation -of Bool-returning primops was that tagToEnum# was added implicitly in the -codegen and then optimized away. Now the call to tagToEnum# is explicit -in the source code, which allows to optimize it away at the earlier stages -of compilation (i.e. at the Core level). - Note [Scrutinising VoidRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this STG code: @@ -390,8 +325,8 @@ Note [Dead-binder optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A case-binder, or data-constructor argument, may be marked as dead, -because we preserve occurrence-info on binders in CoreTidy (see -CoreTidy.tidyIdBndr). +because we preserve occurrence-info on binders in GHC.Core.Tidy (see +GHC.Core.Tidy.tidyIdBndr). If the binder is dead, we can sometimes eliminate a load. While CmmSink will eliminate that load, it's very easy to kill it at source @@ -402,7 +337,7 @@ This probably also was the reason for occurrence hack in Phab:D5339 to exist, perhaps because the occurrence information preserved by -'CoreTidy.tidyIdBndr' was insufficient. But now that CmmSink does the +'GHC.Core.Tidy.tidyIdBndr' was insufficient. But now that CmmSink does the job we deleted the hacks. -} @@ -420,7 +355,7 @@ y := x We want to allow this assignment to be generated in the case when the types are compatible, because this allows some slightly-dodgy but -occasionally-useful casts to be used, such as in RtClosureInspect +occasionally-useful casts to be used, such as in GHC.Runtime.Heap.Inspect where we cast an HValue to a MutVar# so we can print out the contents of the MutVar#. If instead we generate code that enters the HValue, then we'll get a runtime panic, because the HValue really is a @@ -430,18 +365,18 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts | isUnliftedType (idType v) -- Note [Dodgy unsafeCoerce 1] = -- assignment suffices for unlifted types - do { dflags <- getDynFlags - ; unless (reps_compatible dflags) $ + do { platform <- getPlatform + ; unless (reps_compatible platform) $ pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" (pp_bndr v $$ pp_bndr bndr) ; v_info <- getCgIdInfo v - ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) + ; emitAssign (CmmLocal (idToReg platform (NonVoid bndr))) (idInfoToAmode v_info) -- Add bndr to the environment ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible dflags = primRepCompatible dflags (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) @@ -456,10 +391,10 @@ it would be better to invoke some kind of panic function here. -} cgCase scrut@(StgApp v []) _ (PrimAlt _) _ - = do { dflags <- getDynFlags + = do { platform <- getPlatform ; mb_cc <- maybeSaveCostCentre True ; _ <- withSequel - (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) + (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut) ; restoreCurrentCostCentre mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newBlockId @@ -470,7 +405,7 @@ {- Note [Handle seq#] ~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in PrelRules. +See Note [seq# magic] in GHC.Core.Opt.ConstantFold. The special case for seq# in cgCase does this: case seq# a s of v @@ -485,16 +420,16 @@ cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts = -- Note [Handle seq#] - -- And see Note [seq# magic] in PrelRules + -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold -- Use the same return convention as vanilla 'a'. cgCase (StgApp a []) bndr alt_type alts cgCase scrut bndr alt_type alts = -- the general case - do { dflags <- getDynFlags + do { platform <- getPlatform ; up_hp_usg <- getVirtHp -- Upstream heap usage ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts - alt_regs = map (idToReg dflags) ret_bndrs + alt_regs = map (idToReg platform) ret_bndrs ; simple_scrut <- isSimpleScrut scrut alt_type ; let do_gc | is_cmp_op scrut = False -- See Note [GC for conditionals] | not simple_scrut = True @@ -529,7 +464,7 @@ tagToEnum# (#13397) we will have: case (a>b) of ... Rather than make it behave quite differently, I am testing for a -comparison operator here in in the general case as well. +comparison operator here in the general case as well. ToDo: figure out what the Right Rule should be. @@ -571,8 +506,8 @@ isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate -isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe _ _)) _) _ = return $! not (playSafe safe) --- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp +isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) +-- dataToTag# evaluates its argument, see Note [dataToTag#] in primops.txt.pp isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args @@ -585,7 +520,7 @@ chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id] -- These are the binders of a case that are assigned by the evaluation of the -- scrutinee. --- They're non-void, see Note [Post-unarisation invariants] in UnariseStg. +-- They're non-void, see Note [Post-unarisation invariants] in GHC.Stg.Unarise. chooseReturnBndrs bndr (PrimAlt _) _alts = assertNonVoidIds [bndr] @@ -614,11 +549,11 @@ -- Here bndrs are *already* in scope, so don't rebind them cgAlts gc_plan bndr (PrimAlt _) alts - = do { dflags <- getDynFlags + = do { platform <- getPlatform ; tagged_cmms <- cgAltRhss gc_plan bndr alts - ; let bndr_reg = CmmLocal (idToReg dflags bndr) + ; let bndr_reg = CmmLocal (idToReg platform bndr) (DEFAULT,deflt) = head tagged_cmms -- PrimAlts always have a DEFAULT case -- and it always comes first @@ -630,11 +565,12 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts = do { dflags <- getDynFlags + ; platform <- getPlatform ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts ; let !fam_sz = tyConFamilySize tycon - !bndr_reg = CmmLocal (idToReg dflags bndr) + !bndr_reg = CmmLocal (idToReg platform bndr) !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) !branches' = first succ <$> branches !maxpt = mAX_PTR_TAG dflags @@ -873,16 +809,16 @@ cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt] -> FCode [(AltCon, CmmAGraphScoped)] cgAltRhss gc_plan bndr alts = do - dflags <- getDynFlags + platform <- getPlatform let - base_reg = idToReg dflags bndr + base_reg = idToReg platform bndr cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped) cg_alt (con, bndrs, rhs) = getCodeScoped $ maybeAltHeapCheck gc_plan $ do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs) -- alt binders are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise ; _ <- cgExpr rhs ; return con } forkAlts (map cg_alt alts) @@ -910,7 +846,7 @@ do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False currentCCS con (assertNonVoidStgArgs stg_args) -- con args are always non-void, - -- see Note [Post-unarisation invariants] in UnariseStg + -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -- The first "con" says that the name bound to this -- closure is "con", which is a bit of a fudge, but -- it only affects profiling (hence the False) @@ -966,7 +902,7 @@ -- -- Self-recursive tail calls can be optimized into a local jump in the same -- way as let-no-escape bindings (see Note [What is a non-escaping let] in --- stgSyn/CoreToStg.hs). Consider this: +-- "GHC.CoreToStg"). Consider this: -- -- foo.info: -- a = R1 // calling convention @@ -1071,6 +1007,7 @@ emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do { dflags <- getDynFlags + ; platform <- getPlatform ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff @@ -1084,7 +1021,7 @@ -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do - { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg + { let entry = entryCode platform $ closureInfoPtr dflags $ CmmReg nodeReg ; emit $ mkJump dflags NativeNodeCall entry [cmmUntag dflags fun] updfr_off ; return AssignedDirectly @@ -1126,7 +1063,7 @@ -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) + ; let entry = entryCode platform (closureInfoPtr dflags (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ @@ -1149,10 +1086,10 @@ -- simply pass on the annotation as a @CmmTickish@. cgTick :: Tickish Id -> FCode () cgTick tick - = do { dflags <- getDynFlags + = do { platform <- getPlatform ; case tick of ProfNote cc t p -> emitSetCCC cc t p - HpcTick m n -> emit (mkTickBox dflags m n) + HpcTick m n -> emit (mkTickBox platform m n) SourceNote s n -> emitTick $ SourceNote s n _other -> return () -- ignore } diff --git a/GHC/StgToCmm/ExtCode.hs b/GHC/StgToCmm/ExtCode.hs --- a/GHC/StgToCmm/ExtCode.hs +++ b/GHC/StgToCmm/ExtCode.hs @@ -37,22 +37,22 @@ where -import GhcPrelude +import GHC.Prelude import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique) -import Cmm -import CLabel -import MkGraph +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Cmm.Graph -import BlockId -import DynFlags -import FastString -import Module -import UniqFM -import Unique -import UniqSupply +import GHC.Cmm.BlockId +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Unit.Module +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Types.Unique.Supply import Control.Monad (ap) @@ -61,11 +61,11 @@ = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - | FunN UnitId -- ^ A function name from this package - | LabelN BlockId -- ^ A blockid of some code or data. + | FunN UnitId -- ^ A function name from this unit + | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things. -type Env = UniqFM Named +type Env = UniqFM FastString Named -- | Local declarations that are in scope during code generation. type Decls = [(FastString,Named)] @@ -102,7 +102,7 @@ return (d, dflags)) --- | Takes the variable decarations and imports from the monad +-- | Takes the variable declarations and imports from the monad -- and makes an environment, which is looped back into the computation. -- In this way, we can have embedded declarations that scope over the whole -- procedure, and imports that scope over the entire module. @@ -162,10 +162,10 @@ addLabel name (mkBlockId u) return (mkBlockId u) --- | Add add a local function to the environment. +-- | Add a local function to the environment. newFunctionName :: FastString -- ^ name of the function - -> UnitId -- ^ package of the current module + -> UnitId -- ^ package of the current module -> ExtCode newFunctionName name pkg = addDecl name (FunN pkg) @@ -204,7 +204,7 @@ return $ case lookupUFM env name of Just (VarN e) -> e - Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) + Just (FunN uid) -> CmmLit (CmmLabel (mkCmmCodeLabel uid name)) _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name)) diff --git a/GHC/StgToCmm/Foreign.hs b/GHC/StgToCmm/Foreign.hs --- a/GHC/StgToCmm/Foreign.hs +++ b/GHC/StgToCmm/Foreign.hs @@ -9,7 +9,7 @@ module GHC.StgToCmm.Foreign ( cgForeignCall, emitPrimCall, emitCCall, - emitForeignCall, -- For CmmParse + emitForeignCall, emitSaveThreadState, saveThreadState, emitLoadThreadState, @@ -20,9 +20,9 @@ emitCloseNursery, ) where -import GhcPrelude hiding( succ, (<*>) ) +import GHC.Prelude hiding( succ, (<*>) ) -import StgSyn +import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) import GHC.StgToCmm.Env import GHC.StgToCmm.Monad @@ -30,25 +30,26 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Layout -import BlockId (newBlockId) -import Cmm -import CmmUtils -import CmmCallConv -import MkGraph -import Type -import RepType -import CLabel -import SMRep -import ForeignCall -import DynFlags -import Maybes -import Outputable -import UniqSupply -import BasicTypes +import GHC.Cmm.BlockId (newBlockId) +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Graph +import GHC.Cmm.CallConv +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Cmm.CLabel +import GHC.Runtime.Heap.Layout +import GHC.Types.ForeignCall +import GHC.Driver.Session +import GHC.Platform +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Types.Unique.Supply +import GHC.Types.Basic -import TyCoRep -import TysPrim -import Util (zipEqual) +import GHC.Core.TyCo.Rep +import GHC.Builtin.Types.Prim +import GHC.Utils.Misc (zipEqual) import Control.Monad @@ -65,8 +66,8 @@ -> Type -- result type -> FCode ReturnKind -cgForeignCall (CCall (CCallSpec target cconv safety ret_rep arg_reps)) typ stg_args res_ty - = do { dflags <- getDynFlags +cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty + = do { platform <- getPlatform ; let -- in the stdcall calling convention, the symbol needs @size appended -- to it, where size is the total number of bytes of arguments. We -- attach this info to the CLabel here, and the CLabel pretty printer @@ -76,8 +77,9 @@ | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API - arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) - (wORD_SIZE dflags) + -- This is correct for the PowerPC ELF ABI version 1 and 2. + arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg) + (platformWordSizeInBytes platform) ; cmm_args <- getFCallArgs stg_args typ ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) @@ -97,7 +99,7 @@ DynamicTarget -> case cmm_args of (fn,_):rest -> (unzip rest, fn) [] -> panic "cgForeignCall []" - fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn ret_rep arg_reps + fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn call_target = ForeignTarget cmm_target fc -- we want to emit code for the call, and then emitReturn. @@ -188,29 +190,24 @@ -} -emitCCall :: [(CmmFormal, PrimRep, ForeignHint)] +emitCCall :: [(CmmFormal,ForeignHint)] -> CmmExpr - -> [(CmmActual, PrimRep, ForeignHint)] + -> [(CmmActual,ForeignHint)] -> FCode () emitCCall hinted_results fn hinted_args = void $ emitForeignCall PlayRisky results target args where - (args, arg_reps, arg_hints) = unzip3 hinted_args - (results, result_reps, result_hints) = unzip3 hinted_results - -- extract result, we can only deal with 0 or 1 result types. - res_rep = case result_reps of - [] -> VoidRep - [r] -> r - _ -> error "can not deal with multiple return values in emitCCall" + (args, arg_hints) = unzip hinted_args + (results, result_hints) = unzip hinted_results target = ForeignTarget fn fc - fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn res_rep arg_reps + fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args = void $ emitForeignCall PlayRisky res (PrimTarget op) args --- alternative entry point, used by CmmParse +-- alternative entry point, used by GHC.Cmm.Parser emitForeignCall :: Safety -> [CmmFormal] -- where to put the results @@ -230,6 +227,7 @@ | otherwise = do dflags <- getDynFlags + platform <- getPlatform updfr_off <- getUpdFrameOff target' <- load_target_into_temp target args' <- mapM maybe_assign_temp args @@ -238,7 +236,7 @@ -- see Note [safe foreign call convention] tscope <- getTickScope emit $ - ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) + ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth platform))) (CmmLit (CmmBlock k)) <*> mkLast (CmmForeignCall { tgt = target' , res = results @@ -262,18 +260,18 @@ -- What we want to do here is create a new temporary for the foreign -- call argument if it is not safe to use the expression directly, -- because the expression mentions caller-saves GlobalRegs (see --- Note [Register Parameter Passing]). +-- Note [Register parameter passing]). -- -- However, we can't pattern-match on the expression here, because --- this is used in a loop by CmmParse, and testing the expression +-- this is used in a loop by GHC.Cmm.Parser, and testing the expression -- results in a black hole. So we always create a temporary, and rely --- on CmmSink to clean it up later. (Yuck, ToDo). The generated code +-- on GHC.Cmm.Sink to clean it up later. (Yuck, ToDo). The generated code -- ends up being the same, at least for the RTS .cmm code. -- maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e = do - dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) + platform <- getPlatform + reg <- newTemp (cmmExprType platform e) emitAssign (CmmLocal reg) e return (CmmReg (CmmLocal reg)) @@ -292,23 +290,24 @@ -- | Produce code to save the current thread state to @CurrentTSO@ saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph saveThreadState dflags = do - tso <- newTemp (gcWord dflags) + let platform = targetPlatform dflags + tso <- newTemp (gcWord platform) close_nursery <- closeNursery dflags tso pure $ catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) currentTSOExpr, -- tso->stackobj->sp = Sp; - mkStore (cmmOffset dflags - (CmmLoad (cmmOffset dflags + mkStore (cmmOffset platform + (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) - (bWord dflags)) + (bWord platform)) (stack_SP dflags)) spExpr, close_nursery, -- and save the current cost centre stack in the TSO when profiling: - if gopt Opt_SccProfilingOn dflags then - mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr + if sccProfilingEnabled dflags then + mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr else mkNop ] @@ -341,7 +340,8 @@ emitCloseNursery :: FCode () emitCloseNursery = do dflags <- getDynFlags - tso <- newTemp (bWord dflags) + platform <- getPlatform + tso <- newTemp (bWord platform) code <- closeNursery dflags tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code @@ -369,26 +369,27 @@ closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph closeNursery df tso = do let tsoreg = CmmLocal tso - cnreg <- CmmLocal <$> newTemp (bWord df) + platform = targetPlatform df + cnreg <- CmmLocal <$> newTemp (bWord platform) pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr, -- CurrentNursery->free = Hp+1; - mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1), + mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1), let alloc = - CmmMachOp (mo_wordSub df) - [ cmmOffsetW df hpExpr 1 - , CmmLoad (nursery_bdescr_start df cnreg) (bWord df) + CmmMachOp (mo_wordSub platform) + [ cmmOffsetW platform hpExpr 1 + , CmmLoad (nursery_bdescr_start df cnreg) (bWord platform) ] - alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df) in -- tso->alloc_limit += alloc mkStore alloc_limit (CmmMachOp (MO_Sub W64) [ CmmLoad alloc_limit b64 - , CmmMachOp (mo_WordTo64 df) [alloc] ]) + , CmmMachOp (mo_WordTo64 platform) [alloc] ]) ] emitLoadThreadState :: FCode () @@ -400,29 +401,30 @@ -- | Produce code to load the current thread state from @CurrentTSO@ loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph loadThreadState dflags = do - tso <- newTemp (gcWord dflags) - stack <- newTemp (gcWord dflags) + let platform = targetPlatform dflags + tso <- newTemp (gcWord platform) + stack <- newTemp (gcWord platform) open_nursery <- openNursery dflags tso pure $ catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) currentTSOExpr, -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)), -- Sp = stack->sp; - mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), + mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) + mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags)) (rESERVED_STACK_WORDS dflags)), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - mkAssign hpAllocReg (zeroExpr dflags), + mkAssign hpAllocReg (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling: - if gopt Opt_SccProfilingOn dflags + if sccProfilingEnabled dflags then storeCurCCS - (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) - (tso_CCCS dflags)) (ccsType dflags)) + (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) + (tso_CCCS dflags)) (ccsType platform)) else mkNop ] @@ -430,7 +432,8 @@ emitOpenNursery :: FCode () emitOpenNursery = do dflags <- getDynFlags - tso <- newTemp (bWord dflags) + platform <- getPlatform + tso <- newTemp (bWord platform) code <- openNursery dflags tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code @@ -463,11 +466,12 @@ @ -} openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph -openNursery df tso = do +openNursery dflags tso = do let tsoreg = CmmLocal tso - cnreg <- CmmLocal <$> newTemp (bWord df) - bdfreereg <- CmmLocal <$> newTemp (bWord df) - bdstartreg <- CmmLocal <$> newTemp (bWord df) + platform = targetPlatform dflags + cnreg <- CmmLocal <$> newTemp (bWord platform) + bdfreereg <- CmmLocal <$> newTemp (bWord platform) + bdstartreg <- CmmLocal <$> newTemp (bWord platform) -- These assignments are carefully ordered to reduce register -- pressure and generate not completely awful code on x86. To see @@ -475,23 +479,23 @@ -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr, - mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)), + mkAssign bdfreereg (CmmLoad (nursery_bdescr_free dflags cnreg) (bWord platform)), -- Hp = CurrentNursery->free - 1; - mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)), + mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), - mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)), + mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; mkAssign hpLimReg - (cmmOffsetExpr df + (cmmOffsetExpr platform (CmmReg bdstartreg) - (cmmOffset df - (CmmMachOp (mo_wordMul df) [ - CmmMachOp (MO_SS_Conv W32 (wordWidth df)) - [CmmLoad (nursery_bdescr_blocks df cnreg) b32], - mkIntExpr df (bLOCK_SIZE df) + (cmmOffset platform + (CmmMachOp (mo_wordMul platform) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth platform)) + [CmmLoad (nursery_bdescr_blocks dflags cnreg) b32], + mkIntExpr platform (bLOCK_SIZE dflags) ]) (-1) ) @@ -499,26 +503,26 @@ -- alloc = bd->free - bd->start let alloc = - CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg] + CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg] - alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags) in -- tso->alloc_limit += alloc mkStore alloc_limit (CmmMachOp (MO_Add W64) [ CmmLoad alloc_limit b64 - , CmmMachOp (mo_WordTo64 df) [alloc] ]) + , CmmMachOp (mo_WordTo64 platform) [alloc] ]) ] nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmReg -> CmmExpr nursery_bdescr_free dflags cn = - cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags) + cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags) nursery_bdescr_start dflags cn = - cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags) + cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags) nursery_bdescr_blocks dflags cn = - cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags) + cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags) tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) @@ -617,9 +621,11 @@ add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr add_shim dflags ty expr = case ty of StgPlainType -> expr - StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags) - StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags) - StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags) + StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags) + StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags) + StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags) + where + platform = targetPlatform dflags -- From a function, extract information needed to determine -- the offset of each argument when used as a C FFI argument. diff --git a/GHC/StgToCmm/Heap.hs b/GHC/StgToCmm/Heap.hs --- a/GHC/StgToCmm/Heap.hs +++ b/GHC/StgToCmm/Heap.hs @@ -6,6 +6,8 @@ -- ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module GHC.StgToCmm.Heap ( getVirtHp, setVirtHp, setRealHp, getHpRelOffset, @@ -20,10 +22,10 @@ emitSetDynHdr ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) -import StgSyn -import CLabel +import GHC.Stg.Syntax +import GHC.Cmm.CLabel import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad @@ -32,20 +34,21 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Env -import MkGraph +import GHC.Cmm.Graph -import Hoopl.Label -import SMRep -import BlockId -import Cmm -import CmmUtils -import CostCentre -import IdInfo( CafInfo(..), mayHaveCafRefs ) -import Id ( Id ) -import Module -import DynFlags -import FastString( mkFastString, fsLit ) -import Panic( sorry ) +import GHC.Cmm.Dataflow.Label +import GHC.Runtime.Heap.Layout +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Types.CostCentre +import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs ) +import GHC.Types.Id ( Id ) +import GHC.Unit +import GHC.Driver.Session +import GHC.Platform +import GHC.Data.FastString( mkFastString, fsLit ) +import GHC.Utils.Panic( sorry ) import Control.Monad (when) import Data.Maybe (isJust) @@ -141,7 +144,8 @@ emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs = do dflags <- getDynFlags - hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..]) + let platform = targetPlatform dflags + hpStore base (zip (header dflags) [0, platformWordSizeInBytes platform ..]) where header :: DynFlags -> [CmmExpr] header dflags = [info_ptr] ++ dynProfHdr dflags ccs @@ -151,9 +155,9 @@ -- Store the item (expr,off) in base[off] hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode () hpStore base vals = do - dflags <- getDynFlags + platform <- getPlatform sequence_ $ - [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ] + [ emitStore (cmmOffsetB platform base off) val | (val,off) <- vals ] ----------------------------------------------------------- -- Layout of static closures @@ -173,6 +177,7 @@ = mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field where + platform = targetPlatform dflags info_lbl = cit_lbl info_tbl -- CAFs must have consistent layout, regardless of whether they @@ -190,25 +195,27 @@ is_caf = isThunkRep (cit_rep info_tbl) padding - | is_caf && null payload = [mkIntCLit dflags 0] + | is_caf && null payload = [mkIntCLit platform 0] | otherwise = [] static_link_field - | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl + | is_caf + = [mkIntCLit platform 0] + | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl = [static_link_value] | otherwise = [] saved_info_field - | is_caf = [mkIntCLit dflags 0] + | is_caf = [mkIntCLit platform 0] | otherwise = [] -- For a static constructor which has NoCafRefs, we set the -- static link field to a non-zero value so the garbage -- collector will ignore it. static_link_value - | mayHaveCafRefs caf_refs = mkIntCLit dflags 0 - | otherwise = mkIntCLit dflags 3 -- No CAF refs + | mayHaveCafRefs caf_refs = mkIntCLit platform 0 + | otherwise = mkIntCLit platform 3 -- No CAF refs -- See Note [STATIC_LINK fields] -- in rts/sm/Storage.h @@ -337,7 +344,7 @@ Just (_, ArgGen _) -> False _otherwise -> True --- | lower-level version for CmmParse +-- | lower-level version for "GHC.Cmm.Parser" entryHeapCheck' :: Bool -- is a known function pattern -> CmmExpr -- expression for the closure pointer -> Int -- Arity -- not same as len args b/c of voids @@ -398,7 +405,8 @@ altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a altOrNoEscapeHeapCheck checkYield regs code = do dflags <- getDynFlags - case cannedGCEntryPoint dflags regs of + platform <- getPlatform + case cannedGCEntryPoint platform regs of Nothing -> genericGC checkYield code Just gc -> do lret <- newBlockId @@ -411,8 +419,8 @@ altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a altHeapCheckReturnsTo regs lret off code - = do dflags <- getDynFlags - case cannedGCEntryPoint dflags regs of + = do platform <- getPlatform + case cannedGCEntryPoint platform regs of Nothing -> genericGC False code Just gc -> cannedGCReturnsTo False True gc regs lret off code @@ -451,8 +459,8 @@ call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] heapCheck False checkYield (call <*> mkBranch lretry) code -cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr -cannedGCEntryPoint dflags regs +cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr +cannedGCEntryPoint platform regs = case map localRegType regs of [] -> Just (mkGcLabel "stg_gc_noregs") [ty] @@ -462,9 +470,9 @@ W64 -> Just (mkGcLabel "stg_gc_d1") _ -> Nothing - | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 -> Just (mkGcLabel "stg_gc_l1") - | otherwise -> Nothing + | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 -> Just (mkGcLabel "stg_gc_l1") + | otherwise -> Nothing where width = typeWidth ty [ty1,ty2] @@ -514,6 +522,7 @@ -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole do { dflags <- getDynFlags + ; platform <- getPlatform ; let mb_alloc_bytes | hpHw > mBLOCK_SIZE = sorry $ unlines [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.", @@ -522,7 +531,7 @@ "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.", "Suggestion: read data from a file instead of having large static data", "structures in code."] - | hpHw > 0 = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags))) + | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform))) | otherwise = Nothing where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) @@ -594,26 +603,27 @@ -> FCode () do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do dflags <- getDynFlags + platform <- getPlatform gc_id <- newBlockId let Just alloc_lit = mb_alloc_lit - bump_hp = cmmOffsetExprB dflags hpExpr alloc_lit + bump_hp = cmmOffsetExprB platform hpExpr alloc_lit -- Sp overflow if ((old + 0) - CmmHighStack < SpLim) -- At the beginning of a function old + 0 = Sp -- See Note [Single stack check] sp_oflo sp_hwm = - CmmMachOp (mo_wordULt dflags) - [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) + CmmMachOp (mo_wordULt platform) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType platform spReg))) [CmmStackSlot Old 0, sp_hwm], CmmReg spLimReg] -- Hp overflow if (Hp > HpLim) -- (Hp has been incremented by now) -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr] + hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr] alloc_n = mkAssign hpAllocReg alloc_lit @@ -639,9 +649,9 @@ else do when (checkYield && not (gopt Opt_OmitYields dflags)) $ do -- Yielding if HpLim == 0 - let yielding = CmmMachOp (mo_wordEq dflags) + let yielding = CmmMachOp (mo_wordEq platform) [CmmReg hpLimReg, - CmmLit (zeroCLit dflags)] + CmmLit (zeroCLit platform)] emit =<< mkCmmIfGoto' yielding gc_id (Just False) tscope <- getTickScope diff --git a/GHC/StgToCmm/Hpc.hs b/GHC/StgToCmm/Hpc.hs --- a/GHC/StgToCmm/Hpc.hs +++ b/GHC/StgToCmm/Hpc.hs @@ -8,41 +8,42 @@ module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where -import GhcPrelude +import GHC.Prelude import GHC.StgToCmm.Monad -import MkGraph -import CmmExpr -import CLabel -import Module -import CmmUtils +import GHC.Platform +import GHC.Cmm.Graph +import GHC.Cmm.Expr +import GHC.Cmm.CLabel +import GHC.Unit.Module +import GHC.Cmm.Utils import GHC.StgToCmm.Utils -import HscTypes -import DynFlags +import GHC.Driver.Types +import GHC.Driver.Session import Control.Monad -mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph -mkTickBox dflags mod n +mkTickBox :: Platform -> Module -> Int -> CmmAGraph +mkTickBox platform mod n = mkStore tick_box (CmmMachOp (MO_Add W64) [ CmmLoad tick_box b64 , CmmLit (CmmInt 1 W64) ]) where - tick_box = cmmIndex dflags W64 + tick_box = cmmIndex platform W64 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n +-- | Emit top-level tables for HPC and return code to initialise initHpc :: Module -> HpcInfo -> FCode () --- Emit top-level tables for HPC and return code to initialise initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) = do dflags <- getDynFlags when (gopt Opt_Hpc dflags) $ - do emitDataLits (mkHpcTicksLabel this_mod) - [ (CmmInt 0 W64) - | _ <- take tickCount [0 :: Int ..] - ] + emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0 :: Int ..] + ] diff --git a/GHC/StgToCmm/Layout.hs b/GHC/StgToCmm/Layout.hs --- a/GHC/StgToCmm/Layout.hs +++ b/GHC/StgToCmm/Layout.hs @@ -32,7 +32,7 @@ #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.StgToCmm.Closure import GHC.StgToCmm.Env @@ -41,24 +41,25 @@ import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils -import MkGraph -import SMRep -import BlockId -import Cmm -import CmmUtils -import CmmInfo -import CLabel -import StgSyn -import Id -import TyCon ( PrimRep(..), primRepSizeB ) -import BasicTypes ( RepArity ) -import DynFlags -import Module +import GHC.Cmm.Graph +import GHC.Runtime.Heap.Layout +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Info +import GHC.Cmm.CLabel +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Types.Basic ( RepArity ) +import GHC.Driver.Session +import GHC.Platform +import GHC.Unit -import Util +import GHC.Utils.Misc import Data.List -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import Control.Monad ------------------------------------------------------------------------ @@ -78,13 +79,14 @@ emitReturn :: [CmmExpr] -> FCode ReturnKind emitReturn results = do { dflags <- getDynFlags + ; platform <- getPlatform ; sequel <- getSequel ; updfr_off <- getUpdFrameOff ; case sequel of Return -> do { adjustHpBackwards - ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) - ; emit (mkReturn dflags (entryCode dflags e) results updfr_off) + ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform) + ; emit (mkReturn dflags (entryCode platform e) results updfr_off) } AssignTo regs adjust -> do { when adjust adjustHpBackwards @@ -189,6 +191,7 @@ -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args = do dflags <- getDynFlags + platform <- getPlatform argsreps <- getArgRepsAmodes stg_args let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -219,7 +222,7 @@ fast_code <- getCode $ emitCall (NativeNodeCall, NativeReturn) - (entryCode dflags fun_iptr) + (entryCode platform fun_iptr) (nonVArgs ((P,Just funv):argsreps)) slow_lbl <- newBlockId @@ -227,8 +230,8 @@ is_tagged_lbl <- newBlockId end_lbl <- newBlockId - let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr) - (mkIntExpr dflags n_args) + let correct_arity = cmmEqWord platform (funInfoArity dflags fun_iptr) + (mkIntExpr platform n_args) tscope <- getTickScope emit (mkCbranch (cmmIsTagged dflags funv) @@ -364,7 +367,7 @@ slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] slowArgs _ [] = [] slowArgs dflags args -- careful: reps contains voids (V), but args does not - | gopt Opt_SccProfilingOn dflags + | sccProfilingEnabled dflags = save_cccs ++ this_pat ++ slowArgs dflags rest_args | otherwise = this_pat ++ slowArgs dflags rest_args where @@ -389,9 +392,9 @@ getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr -- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad getHpRelOffset virtual_offset - = do dflags <- getDynFlags + = do platform <- getPlatform hp_usg <- getHpUsage - return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) + return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset)) data FieldOffOrPadding a = FieldOff (NonVoid a) -- Something that needs an offset. @@ -426,15 +429,16 @@ mkVirtHeapOffsetsWithPadding dflags header things = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds - , bytesToWordsRoundUp dflags bytes_of_ptrs + , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad ) where + platform = targetPlatform dflags hdr_words = case header of NoHeader -> 0 StdHeader -> fixedHdrSizeW dflags ThunkHeader -> thunkHdrSize dflags - hdr_bytes = wordsToBytes dflags hdr_words + hdr_bytes = wordsToBytes platform hdr_words (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things @@ -443,7 +447,7 @@ (tot_bytes, non_ptrs_w_offsets) = mapAccumL computeOffset bytes_of_ptrs non_ptrs - tot_wds = bytesToWordsRoundUp dflags tot_bytes + tot_wds = bytesToWordsRoundUp platform tot_bytes final_pad_size = tot_wds * word_size - tot_bytes final_pad @@ -451,7 +455,7 @@ (hdr_bytes + tot_bytes))] | otherwise = [] - word_size = wORD_SIZE dflags + word_size = platformWordSizeInBytes platform computeOffset bytes_so_far nv_thing = (new_bytes_so_far, with_padding field_off) @@ -459,7 +463,7 @@ (rep, thing) = fromNonVoid nv_thing -- Size of the field in bytes. - !sizeB = primRepSizeB dflags rep + !sizeB = primRepSizeB platform rep -- Align the start offset (eg, 2-byte value should be 2-byte aligned). -- But not more than to a word. @@ -528,20 +532,20 @@ -- bring in ARG_P, ARG_N, etc. #include "../includes/rts/storage/FunTypes.h" -mkArgDescr :: DynFlags -> [Id] -> ArgDescr -mkArgDescr dflags args - = let arg_bits = argBits dflags arg_reps +mkArgDescr :: Platform -> [Id] -> ArgDescr +mkArgDescr platform args + = let arg_bits = argBits platform arg_reps arg_reps = filter isNonV (map idArgRep args) -- Getting rid of voids eases matching of standard patterns in case stdPattern arg_reps of Just spec_id -> ArgSpec spec_id Nothing -> ArgGen arg_bits -argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits _ [] = [] -argBits dflags (P : args) = False : argBits dflags args -argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) - ++ argBits dflags args +argBits :: Platform -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits platform (P : args) = False : argBits platform args +argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True) + ++ argBits platform args ---------------------- stdPattern :: [ArgRep] -> Maybe Int @@ -598,10 +602,11 @@ -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body = do { dflags <- getDynFlags + ; platform <- getPlatform -- Bind the binder itself, but only if it's not a top-level -- binding. We need non-top let-bindings to refer to the -- top-level binding, which this binding would incorrectly shadow. - ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr) + ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info ; let node_points = nodeMustPointToIt dflags lf_info ; arg_regs <- bindArgsToRegs args diff --git a/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs --- a/GHC/StgToCmm/Monad.hs +++ b/GHC/StgToCmm/Monad.hs @@ -22,7 +22,7 @@ emitOutOfLine, emitAssign, emitStore, emitComment, emitTick, emitUnwind, - getCmm, aGraphToGraph, + getCmm, aGraphToGraph, getPlatform, getCodeR, getCode, getCodeScoped, getHeapUsage, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, @@ -49,7 +49,7 @@ getModuleName, -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage, + getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, -- more localised access to monad state CgIdInfo(..), @@ -59,26 +59,27 @@ CgInfoDownwards(..), CgState(..) -- non-abstract ) where -import GhcPrelude hiding( sequence, succ ) +import GHC.Prelude hiding( sequence, succ ) -import Cmm +import GHC.Platform +import GHC.Cmm import GHC.StgToCmm.Closure -import DynFlags -import Hoopl.Collections -import MkGraph -import BlockId -import CLabel -import SMRep -import Module -import Id -import VarEnv -import OrdList -import BasicTypes( ConTagZ ) -import Unique -import UniqSupply -import FastString -import Outputable -import Util +import GHC.Driver.Session +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Graph as CmmGraph +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Runtime.Heap.Layout +import GHC.Unit +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Data.OrdList +import GHC.Types.Basic( ConTagZ ) +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import Control.Monad import Data.List @@ -276,7 +277,7 @@ initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags , cgd_mod = mod - , cgd_updfr_off = initUpdFrameOff dflags + , cgd_updfr_off = initUpdFrameOff (targetPlatform dflags) , cgd_ticky = mkTopTickyCtrLabel , cgd_sequel = initSequel , cgd_self_loop = Nothing @@ -285,8 +286,8 @@ initSequel :: Sequel initSequel = Return -initUpdFrameOff :: DynFlags -> UpdFrameOffset -initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA +initUpdFrameOff :: Platform -> UpdFrameOffset +initUpdFrameOff platform = platformWordSizeInBytes platform -- space for the RA -------------------------------------------------------- @@ -369,7 +370,7 @@ -- Add code blocks from the latter to the former -- (The cgs_stmts will often be empty, but not always; see codeOnly) s1 `addCodeBlocksFrom` s2 - = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2, + = s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2, cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } @@ -470,8 +471,8 @@ instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown -getThisPackage :: FCode UnitId -getThisPackage = liftM thisPackage getDynFlags +getPlatform :: FCode Platform +getPlatform = targetPlatform <$> getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state @@ -562,12 +563,12 @@ -- re-bind the free variables to a field of the closure. forkClosureBody body_code - = do { dflags <- getDynFlags + = do { platform <- getPlatform ; info <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags + , cgd_updfr_off = initUpdFrameOff platform , cgd_self_loop = Nothing } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in @@ -715,7 +716,7 @@ emit :: CmmAGraph -> FCode () emit ag = do { state <- getState - ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } } + ; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } } emitDecl :: CmmDecl -> FCode () emitDecl decl @@ -736,14 +737,14 @@ -> FCode () emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False - = do { dflags <- getDynFlags - ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False + = do { platform <- getPlatform + ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth platform)) False } emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True -- do layout = do { dflags <- getDynFlags ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args - graph' = entry MkGraph.<*> graph + graph' = entry CmmGraph.<*> graph ; emitProc mb_info lbl live (graph', tscope) offset True } emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" @@ -758,8 +759,7 @@ emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped -> Int -> Bool -> FCode () emitProc mb_info lbl live blocks offset do_layout - = do { dflags <- getDynFlags - ; l <- newBlockId + = do { l <- newBlockId ; let blks :: CmmGraph blks = labelAGraph l blocks @@ -768,7 +768,6 @@ | otherwise = mapEmpty sinfo = StackInfo { arg_space = offset - , updfr_space = Just (initUpdFrameOff dflags) , do_layout = do_layout } tinfo = TopInfo { info_tbls = infos diff --git a/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/GHC/StgToCmm/Prim.hs @@ -1,3009 +1,3065 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} - -#if __GLASGOW_HASKELL__ <= 808 --- GHC 8.10 deprecates this flag, but GHC 8.8 needs it --- emitPrimOp is quite large -{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-} -#endif - ----------------------------------------------------------------------------- --- --- Stg to C--: primitive operations --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module GHC.StgToCmm.Prim ( - cgOpApp, - cgPrimOp, -- internal(ish), used by cgCase to get code for a - -- comparison without also turning it into a Bool. - shouldInlinePrimOp - ) where - -#include "HsVersions.h" - -import GhcPrelude hiding ((<*>)) - -import GHC.StgToCmm.Layout -import GHC.StgToCmm.Foreign -import GHC.StgToCmm.Env -import GHC.StgToCmm.Monad -import GHC.StgToCmm.Utils -import GHC.StgToCmm.Ticky -import GHC.StgToCmm.Heap -import GHC.StgToCmm.Prof ( costCentreFrom ) - -import DynFlags -import GHC.Platform -import BasicTypes -import BlockId -import MkGraph -import StgSyn -import Cmm -import Module ( rtsUnitId ) -import Type ( Type, tyConAppTyCon ) -import TyCon -import CLabel -import CmmUtils -import PrimOp -import SMRep -import FastString -import Outputable -import Util -import Data.Maybe - -import Data.Bits ((.&.), bit) -import Control.Monad (liftM, when, unless) - ------------------------------------------------------------------------- --- Primitive operations and foreign calls ------------------------------------------------------------------------- - -{- Note [Foreign call results] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A foreign call always returns an unboxed tuple of results, one -of which is the state token. This seems to happen even for pure -calls. - -Even if we returned a single result for pure calls, it'd still be -right to wrap it in a singleton unboxed tuple, because the result -might be a Haskell closure pointer, we don't want to evaluate it. -} - ----------------------------------- -cgOpApp :: StgOp -- The op - -> [StgArg] -- Arguments - -> Type -- Result type (always an unboxed tuple) - -> FCode ReturnKind - --- Foreign calls -cgOpApp (StgFCallOp fcall ty) stg_args res_ty - = cgForeignCall fcall ty stg_args res_ty - -- Note [Foreign call results] - -cgOpApp (StgPrimOp primop) args res_ty = do - dflags <- getDynFlags - cmm_args <- getNonVoidArgAmodes args - case emitPrimOp dflags primop cmm_args of - PrimopCmmEmit_External -> do -- out-of-line - let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - emitCall (NativeNodeCall, NativeReturn) fun cmm_args - - PrimopCmmEmit_Raw f -> do - exprs <- f res_ty - emitReturn exprs - - PrimopCmmEmit_IntoRegs f -- inline - | ReturnsPrim VoidRep <- result_info - -> do f [] - emitReturn [] - - | ReturnsPrim rep <- result_info - -> do dflags <- getDynFlags - res <- newTemp (primRepCmmType dflags rep) - f [res] - emitReturn [CmmReg (CmmLocal res)] - - | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon - -> do (regs, _hints) <- newUnboxedTupleRegs res_ty - f regs - emitReturn (map (CmmReg . CmmLocal) regs) - - | otherwise -> panic "cgPrimop" - where - result_info = getPrimOpResultInfo primop - -cgOpApp (StgPrimCallOp primcall) args _res_ty - = do { cmm_args <- getNonVoidArgAmodes args - ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) - ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } - --- | Interpret the argument as an unsigned value, assuming the value --- is given in two-complement form in the given width. --- --- Example: @asUnsigned W64 (-1)@ is 18446744073709551615. --- --- This function is used to work around the fact that many array --- primops take Int# arguments, but we interpret them as unsigned --- quantities in the code gen. This means that we have to be careful --- every time we work on e.g. a CmmInt literal that corresponds to the --- array size, as it might contain a negative Integer value if the --- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int# --- literal. -asUnsigned :: Width -> Integer -> Integer -asUnsigned w n = n .&. (bit (widthInBits w) - 1) - ---------------------------------------------------- -cgPrimOp :: [LocalReg] -- where to put the results - -> PrimOp -- the op - -> [StgArg] -- arguments - -> FCode () - -cgPrimOp results op args = do - dflags <- getDynFlags - arg_exprs <- getNonVoidArgAmodes args - case emitPrimOp dflags op arg_exprs of - PrimopCmmEmit_External -> panic "External prim op" - PrimopCmmEmit_Raw _ -> panic "caller should handle TagToEnum themselves" - PrimopCmmEmit_IntoRegs f -> f results - - ------------------------------------------------------------------------- --- Emitting code for a primop ------------------------------------------------------------------------- - -shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool -shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of - PrimopCmmEmit_External -> False - PrimopCmmEmit_IntoRegs _ -> True - PrimopCmmEmit_Raw _ -> True - --- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use --- ByteOff (or some other fixed width signed type) to represent --- array sizes or indices. This means that these will overflow for --- large enough sizes. - --- TODO: Several primops, such as 'copyArray#', only have an inline --- implementation (below) but could possibly have both an inline --- implementation and an out-of-line implementation, just like --- 'newArray#'. This would lower the amount of code generated, --- hopefully without a performance impact (needs to be measured). - --- | The big function handling all the primops. --- --- In the simple case, there is just one implementation, and we emit that. --- --- In more complex cases, there is a foreign call (out of line) fallback. This --- might happen e.g. if there's enough static information, such as statically --- know arguments. -emitPrimOp - :: DynFlags - -> PrimOp -- ^ The primop - -> [CmmExpr] -- ^ The primop arguments - -> PrimopCmmEmit -emitPrimOp dflags = \case - NewByteArrayOp_Char -> \case - [(CmmLit (CmmInt n w))] - | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> doNewByteArrayOp res (fromInteger n) - _ -> PrimopCmmEmit_External - - NewArrayOp -> \case - [(CmmLit (CmmInt n w)), init] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel - [ (mkIntExpr dflags (fromInteger n), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) - , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags) - ] - (fromInteger n) init - _ -> PrimopCmmEmit_External - - CopyArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CopyMutableArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CopyArrayArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CopyMutableArrayArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CloneArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CloneMutableArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - FreezeArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - ThawArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - NewSmallArrayOp -> \case - [(CmmLit (CmmInt n w)), init] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> - doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel - [ (mkIntExpr dflags (fromInteger n), - fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) - ] - (fromInteger n) init - _ -> PrimopCmmEmit_External - - CopySmallArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opAllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CopySmallMutableArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opAllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CloneSmallArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CloneSmallMutableArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - FreezeSmallArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - ThawSmallArrayOp -> \case - [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) - _ -> PrimopCmmEmit_External - - -- First we handle various awkward cases specially. - -- Note: StgInt newSpark (StgRegTable *reg, StgClosure *p) - -- StgInt is Int_64 on 64bit platforms, Int_32 on others - ParOp -> \[arg] -> opAllDone $ \[res] -> do - -- for now, just implement this in a C function - -- later, we might want to inline it. - emitCCall - [(res, Int64Rep, SignedHint)] - (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(baseExpr, AddrRep, AddrHint), (arg, AddrRep, AddrHint)] - - SparkOp -> \[arg] -> opAllDone $ \[res] -> do - -- returns the value of arg in res. We're going to therefore - -- refer to arg twice (once to pass to newSpark(), and once to - -- assign to res), so put it in a temporary. - tmp <- assignTemp arg - tmp2 <- newTemp (bWord dflags) - emitCCall - [(tmp2, Int64Rep, SignedHint)] - (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(baseExpr, AddrRep, AddrHint), ((CmmReg (CmmLocal tmp)), AddrRep, AddrHint)] - emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) - - GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do - let - val - | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) - | otherwise = CmmLit (zeroCLit dflags) - emitAssign (CmmLocal res) val - - GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) cccsExpr - - MyThreadIdOp -> \[] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) currentTSOExpr - - ReadMutVarOp -> \[mutv] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags)) - - WriteMutVarOp -> \[mutv, var] -> opAllDone $ \res@[] -> do - old_val <- CmmLocal <$> newTemp (cmmExprType dflags var) - emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags)) - - -- Without this write barrier, other CPUs may see this pointer before - -- the writes for the closure it points to have occurred. - -- Note that this also must come after we read the old value to ensure - -- that the read of old_val comes before another core's write to the - -- MutVar's value. - emitPrimCall res MO_WriteBarrier [] - emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var - emitCCall - [{-no results-}] - (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - [(baseExpr, AddrRep, AddrHint), (mutv, AddrRep, AddrHint), (CmmReg old_val, AddrRep, AddrHint)] - --- #define sizzeofByteArrayzh(r,a) \ --- r = ((StgArrBytes *)(a))->bytes - SizeofByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) - --- #define sizzeofMutableByteArrayzh(r,a) \ --- r = ((StgArrBytes *)(a))->bytes - SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp - --- #define getSizzeofMutableByteArrayzh(r,a) \ --- r = ((StgArrBytes *)(a))->bytes - GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) - - --- #define touchzh(o) /* nothing */ - TouchOp -> \args@[_] -> opAllDone $ \res@[] -> do - emitPrimCall res MO_Touch args - --- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) - ByteArrayContents_Char -> \[arg] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags)) - --- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) - StableNameToIntOp -> \[arg] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) - - ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]) - --- #define addrToHValuezh(r,a) r=(P_)a - AddrToAnyOp -> \[arg] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) arg - --- #define hvalueToAddrzh(r, a) r=(W_)a - AnyToAddrOp -> \[arg] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) arg - -{- Freezing arrays-of-ptrs requires changing an info table, for the - benefit of the generational collector. It needs to scavenge mutable - objects, even if they are in old space. When they become immutable, - they can be removed from this scavenge list. -} - --- #define unsafeFreezzeArrayzh(r,a) --- { --- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info); --- r = a; --- } - UnsafeFreezeArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), - mkAssign (CmmLocal res) arg ] - UnsafeFreezeArrayArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), - mkAssign (CmmLocal res) arg ] - UnsafeFreezeSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), - mkAssign (CmmLocal res) arg ] - --- #define unsafeFreezzeByteArrayzh(r,a) r=(a) - UnsafeFreezeByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emitAssign (CmmLocal res) arg - --- Reading/writing pointer arrays - - ReadArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - IndexArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - WriteArrayOp -> \[obj, ix, v] -> opAllDone $ \[] -> do - doWritePtrArrayOp obj ix v - - IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadPtrArrayOp res obj ix - WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do - doWritePtrArrayOp obj ix v - - ReadSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadSmallPtrArrayOp res obj ix - IndexSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do - doReadSmallPtrArrayOp res obj ix - WriteSmallArrayOp -> \[obj,ix,v] -> opAllDone $ \[] -> do - doWriteSmallPtrArrayOp obj ix v - --- Getting the size of pointer arrays - - SizeofArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags)) - (bWord dflags)) - SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do - emit $ mkAssign (CmmLocal res) - (cmmLoadIndexW dflags arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags)) - (bWord dflags)) - - SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp - GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp - --- IndexXXXoffAddr - - IndexOffAddrOp_Char -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args - IndexOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args - IndexOffAddrOp_Int -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - IndexOffAddrOp_Word -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - IndexOffAddrOp_Addr -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - IndexOffAddrOp_Float -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing f32 res args - IndexOffAddrOp_Double -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing f64 res args - IndexOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - IndexOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args - IndexOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args - IndexOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args - IndexOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing b64 res args - IndexOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args - IndexOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args - IndexOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args - IndexOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing b64 res args - --- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - - ReadOffAddrOp_Char -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args - ReadOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args - ReadOffAddrOp_Int -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - ReadOffAddrOp_Word -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - ReadOffAddrOp_Addr -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - ReadOffAddrOp_Float -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing f32 res args - ReadOffAddrOp_Double -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing f64 res args - ReadOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing (bWord dflags) res args - ReadOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args - ReadOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args - ReadOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args - ReadOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing b64 res args - ReadOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args - ReadOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args - ReadOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args - ReadOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do - doIndexOffAddrOp Nothing b64 res args - --- IndexXXXArray - - IndexByteArrayOp_Char -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args - IndexByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args - IndexByteArrayOp_Int -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - IndexByteArrayOp_Word -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - IndexByteArrayOp_Addr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - IndexByteArrayOp_Float -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing f32 res args - IndexByteArrayOp_Double -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing f64 res args - IndexByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - IndexByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args - IndexByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args - IndexByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args - IndexByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing b64 res args - IndexByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args - IndexByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args - IndexByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args - IndexByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing b64 res args - --- ReadXXXArray, identical to IndexXXXArray. - - ReadByteArrayOp_Char -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args - ReadByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args - ReadByteArrayOp_Int -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - ReadByteArrayOp_Word -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - ReadByteArrayOp_Addr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - ReadByteArrayOp_Float -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing f32 res args - ReadByteArrayOp_Double -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing f64 res args - ReadByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing (bWord dflags) res args - ReadByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args - ReadByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args - ReadByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args - ReadByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing b64 res args - ReadByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args - ReadByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args - ReadByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args - ReadByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOp Nothing b64 res args - --- IndexWord8ArrayAsXXX - - IndexByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_8ToWord dflags)) b8 b8 res args - IndexByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args - IndexByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - IndexByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - IndexByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - IndexByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing f32 b8 res args - IndexByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing f64 b8 res args - IndexByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - IndexByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_s_16ToWord dflags)) b16 b8 res args - IndexByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_s_32ToWord dflags)) b32 b8 res args - IndexByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing b64 b8 res args - IndexByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_16ToWord dflags)) b16 b8 res args - IndexByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args - IndexByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing b64 b8 res args - --- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX - - ReadByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_8ToWord dflags)) b8 b8 res args - ReadByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args - ReadByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - ReadByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - ReadByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - ReadByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing f32 b8 res args - ReadByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing f64 b8 res args - ReadByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args - ReadByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_s_16ToWord dflags)) b16 b8 res args - ReadByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_s_32ToWord dflags)) b32 b8 res args - ReadByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing b64 b8 res args - ReadByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_16ToWord dflags)) b16 b8 res args - ReadByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args - ReadByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do - doIndexByteArrayOpAs Nothing b64 b8 res args - --- WriteXXXoffAddr - - WriteOffAddrOp_Char -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args - WriteOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args - WriteOffAddrOp_Int -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing (bWord dflags) res args - WriteOffAddrOp_Word -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing (bWord dflags) res args - WriteOffAddrOp_Addr -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing (bWord dflags) res args - WriteOffAddrOp_Float -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing f32 res args - WriteOffAddrOp_Double -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing f64 res args - WriteOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing (bWord dflags) res args - WriteOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args - WriteOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args - WriteOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args - WriteOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing b64 res args - WriteOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args - WriteOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args - WriteOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args - WriteOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do - doWriteOffAddrOp Nothing b64 res args - --- WriteXXXArray - - WriteByteArrayOp_Char -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args - WriteByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args - WriteByteArrayOp_Int -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing (bWord dflags) res args - WriteByteArrayOp_Word -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing (bWord dflags) res args - WriteByteArrayOp_Addr -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing (bWord dflags) res args - WriteByteArrayOp_Float -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing f32 res args - WriteByteArrayOp_Double -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing f64 res args - WriteByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing (bWord dflags) res args - WriteByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args - WriteByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args - WriteByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args - WriteByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b64 res args - WriteByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args - WriteByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args - WriteByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args - WriteByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b64 res args - --- WriteInt8ArrayAsXXX - - WriteByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args - WriteByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args - WriteByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args - WriteByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args - WriteByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args - WriteByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args - WriteByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do - doWriteByteArrayOp Nothing b8 res args - --- Copying and setting byte arrays - CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do - doCopyByteArrayOp src src_off dst dst_off n - CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do - doCopyMutableByteArrayOp src src_off dst dst_off n - CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do - doCopyByteArrayToAddrOp src src_off dst n - CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do - doCopyMutableByteArrayToAddrOp src src_off dst n - CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opAllDone $ \[] -> do - doCopyAddrToByteArrayOp src dst dst_off n - SetByteArrayOp -> \[ba,off,len,c] -> opAllDone $ \[] -> do - doSetByteArrayOp ba off len c - --- Comparing byte arrays - CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opAllDone $ \[res] -> do - doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n - - BSwap16Op -> \[w] -> opAllDone $ \[res] -> do - emitBSwapCall res w W16 - BSwap32Op -> \[w] -> opAllDone $ \[res] -> do - emitBSwapCall res w W32 - BSwap64Op -> \[w] -> opAllDone $ \[res] -> do - emitBSwapCall res w W64 - BSwapOp -> \[w] -> opAllDone $ \[res] -> do - emitBSwapCall res w (wordWidth dflags) - - BRev8Op -> \[w] -> opAllDone $ \[res] -> do - emitBRevCall res w W8 - BRev16Op -> \[w] -> opAllDone $ \[res] -> do - emitBRevCall res w W16 - BRev32Op -> \[w] -> opAllDone $ \[res] -> do - emitBRevCall res w W32 - BRev64Op -> \[w] -> opAllDone $ \[res] -> do - emitBRevCall res w W64 - BRevOp -> \[w] -> opAllDone $ \[res] -> do - emitBRevCall res w (wordWidth dflags) - --- Population count - PopCnt8Op -> \[w] -> opAllDone $ \[res] -> do - emitPopCntCall res w W8 - PopCnt16Op -> \[w] -> opAllDone $ \[res] -> do - emitPopCntCall res w W16 - PopCnt32Op -> \[w] -> opAllDone $ \[res] -> do - emitPopCntCall res w W32 - PopCnt64Op -> \[w] -> opAllDone $ \[res] -> do - emitPopCntCall res w W64 - PopCntOp -> \[w] -> opAllDone $ \[res] -> do - emitPopCntCall res w (wordWidth dflags) - --- Parallel bit deposit - Pdep8Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPdepCall res src mask W8 - Pdep16Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPdepCall res src mask W16 - Pdep32Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPdepCall res src mask W32 - Pdep64Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPdepCall res src mask W64 - PdepOp -> \[src, mask] -> opAllDone $ \[res] -> do - emitPdepCall res src mask (wordWidth dflags) - --- Parallel bit extract - Pext8Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPextCall res src mask W8 - Pext16Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPextCall res src mask W16 - Pext32Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPextCall res src mask W32 - Pext64Op -> \[src, mask] -> opAllDone $ \[res] -> do - emitPextCall res src mask W64 - PextOp -> \[src, mask] -> opAllDone $ \[res] -> do - emitPextCall res src mask (wordWidth dflags) - --- count leading zeros - Clz8Op -> \[w] -> opAllDone $ \[res] -> do - emitClzCall res w W8 - Clz16Op -> \[w] -> opAllDone $ \[res] -> do - emitClzCall res w W16 - Clz32Op -> \[w] -> opAllDone $ \[res] -> do - emitClzCall res w W32 - Clz64Op -> \[w] -> opAllDone $ \[res] -> do - emitClzCall res w W64 - ClzOp -> \[w] -> opAllDone $ \[res] -> do - emitClzCall res w (wordWidth dflags) - --- count trailing zeros - Ctz8Op -> \[w] -> opAllDone $ \[res] -> do - emitCtzCall res w W8 - Ctz16Op -> \[w] -> opAllDone $ \[res] -> do - emitCtzCall res w W16 - Ctz32Op -> \[w] -> opAllDone $ \[res] -> do - emitCtzCall res w W32 - Ctz64Op -> \[w] -> opAllDone $ \[res] -> do - emitCtzCall res w W64 - CtzOp -> \[w] -> opAllDone $ \[res] -> do - emitCtzCall res w (wordWidth dflags) - --- Unsigned int to floating point conversions - Word2FloatOp -> \[w] -> opAllDone $ \[res] -> do - emitPrimCall [res] (MO_UF_Conv W32) [w] - Word2DoubleOp -> \[w] -> opAllDone $ \[res] -> do - emitPrimCall [res] (MO_UF_Conv W64) [w] - --- SIMD primops - (VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do - checkVecCompatibility dflags vcat n w - doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res - where - zeros :: CmmExpr - zeros = CmmLit $ CmmVec (replicate n zero) - - zero :: CmmLit - zero = case vcat of - IntVec -> CmmInt 0 w - WordVec -> CmmInt 0 w - FloatVec -> CmmFloat 0 w - - ty :: CmmType - ty = vecVmmType vcat n w - - (VecPackOp vcat n w) -> \es -> opAllDone $ \[res] -> do - checkVecCompatibility dflags vcat n w - when (es `lengthIsNot` n) $ - panic "emitPrimOp: VecPackOp has wrong number of arguments" - doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res - where - zeros :: CmmExpr - zeros = CmmLit $ CmmVec (replicate n zero) - - zero :: CmmLit - zero = case vcat of - IntVec -> CmmInt 0 w - WordVec -> CmmInt 0 w - FloatVec -> CmmFloat 0 w - - ty :: CmmType - ty = vecVmmType vcat n w - - (VecUnpackOp vcat n w) -> \[arg] -> opAllDone $ \res -> do - checkVecCompatibility dflags vcat n w - when (res `lengthIsNot` n) $ - panic "emitPrimOp: VecUnpackOp has wrong number of results" - doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecInsertOp vcat n w) -> \[v,e,i] -> opAllDone $ \[res] -> do - checkVecCompatibility dflags vcat n w - doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecIndexByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOp Nothing ty res0 args - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecReadByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOp Nothing ty res0 args - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecWriteByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doWriteByteArrayOp Nothing ty res0 args - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecIndexOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOp Nothing ty res0 args - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecReadOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOp Nothing ty res0 args - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecWriteOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doWriteOffAddrOp Nothing ty res0 args - where - ty :: CmmType - ty = vecVmmType vcat n w - - (VecIndexScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOpAs Nothing vecty ty res0 args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - - (VecReadScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexByteArrayOpAs Nothing vecty ty res0 args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - - (VecWriteScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doWriteByteArrayOp Nothing ty res0 args - where - ty :: CmmType - ty = vecCmmCat vcat w - - (VecIndexScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOpAs Nothing vecty ty res0 args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - - (VecReadScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doIndexOffAddrOpAs Nothing vecty ty res0 args - where - vecty :: CmmType - vecty = vecVmmType vcat n w - - ty :: CmmType - ty = vecCmmCat vcat w - - (VecWriteScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do - checkVecCompatibility dflags vcat n w - doWriteOffAddrOp Nothing ty res0 args - where - ty :: CmmType - ty = vecCmmCat vcat w - --- Prefetch - PrefetchByteArrayOp3 -> \args -> opAllDone $ \[] -> do - doPrefetchByteArrayOp 3 args - PrefetchMutableByteArrayOp3 -> \args -> opAllDone $ \[] -> do - doPrefetchMutableByteArrayOp 3 args - PrefetchAddrOp3 -> \args -> opAllDone $ \[] -> do - doPrefetchAddrOp 3 args - PrefetchValueOp3 -> \args -> opAllDone $ \[] -> do - doPrefetchValueOp 3 args - - PrefetchByteArrayOp2 -> \args -> opAllDone $ \[] -> do - doPrefetchByteArrayOp 2 args - PrefetchMutableByteArrayOp2 -> \args -> opAllDone $ \[] -> do - doPrefetchMutableByteArrayOp 2 args - PrefetchAddrOp2 -> \args -> opAllDone $ \[] -> do - doPrefetchAddrOp 2 args - PrefetchValueOp2 -> \args -> opAllDone $ \[] -> do - doPrefetchValueOp 2 args - PrefetchByteArrayOp1 -> \args -> opAllDone $ \[] -> do - doPrefetchByteArrayOp 1 args - PrefetchMutableByteArrayOp1 -> \args -> opAllDone $ \[] -> do - doPrefetchMutableByteArrayOp 1 args - PrefetchAddrOp1 -> \args -> opAllDone $ \[] -> do - doPrefetchAddrOp 1 args - PrefetchValueOp1 -> \args -> opAllDone $ \[] -> do - doPrefetchValueOp 1 args - - PrefetchByteArrayOp0 -> \args -> opAllDone $ \[] -> do - doPrefetchByteArrayOp 0 args - PrefetchMutableByteArrayOp0 -> \args -> opAllDone $ \[] -> do - doPrefetchMutableByteArrayOp 0 args - PrefetchAddrOp0 -> \args -> opAllDone $ \[] -> do - doPrefetchAddrOp 0 args - PrefetchValueOp0 -> \args -> opAllDone $ \[] -> do - doPrefetchValueOp 0 args - --- Atomic read-modify-write - FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do - doAtomicRMW res AMO_Add mba ix (bWord dflags) n - FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do - doAtomicRMW res AMO_Sub mba ix (bWord dflags) n - FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do - doAtomicRMW res AMO_And mba ix (bWord dflags) n - FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do - doAtomicRMW res AMO_Nand mba ix (bWord dflags) n - FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do - doAtomicRMW res AMO_Or mba ix (bWord dflags) n - FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do - doAtomicRMW res AMO_Xor mba ix (bWord dflags) n - AtomicReadByteArrayOp_Int -> \[mba, ix] -> opAllDone $ \[res] -> do - doAtomicReadByteArray res mba ix (bWord dflags) - AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opAllDone $ \[] -> do - doAtomicWriteByteArray mba ix (bWord dflags) val - CasByteArrayOp_Int -> \[mba, ix, old, new] -> opAllDone $ \[res] -> do - doCasByteArray res mba ix (bWord dflags) old new - --- The rest just translate straightforwardly - - Int2WordOp -> \args -> opNop args - Word2IntOp -> \args -> opNop args - Int2AddrOp -> \args -> opNop args - Addr2IntOp -> \args -> opNop args - ChrOp -> \args -> opNop args -- Int# and Char# are rep'd the same - OrdOp -> \args -> opNop args - - Narrow8IntOp -> \args -> opNarrow dflags args (MO_SS_Conv, W8) - Narrow16IntOp -> \args -> opNarrow dflags args (MO_SS_Conv, W16) - Narrow32IntOp -> \args -> opNarrow dflags args (MO_SS_Conv, W32) - Narrow8WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W8) - Narrow16WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W16) - Narrow32WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W32) - - DoublePowerOp -> \args -> opCallish args MO_F64_Pwr - DoubleSinOp -> \args -> opCallish args MO_F64_Sin - DoubleCosOp -> \args -> opCallish args MO_F64_Cos - DoubleTanOp -> \args -> opCallish args MO_F64_Tan - DoubleSinhOp -> \args -> opCallish args MO_F64_Sinh - DoubleCoshOp -> \args -> opCallish args MO_F64_Cosh - DoubleTanhOp -> \args -> opCallish args MO_F64_Tanh - DoubleAsinOp -> \args -> opCallish args MO_F64_Asin - DoubleAcosOp -> \args -> opCallish args MO_F64_Acos - DoubleAtanOp -> \args -> opCallish args MO_F64_Atan - DoubleAsinhOp -> \args -> opCallish args MO_F64_Asinh - DoubleAcoshOp -> \args -> opCallish args MO_F64_Acosh - DoubleAtanhOp -> \args -> opCallish args MO_F64_Atanh - DoubleLogOp -> \args -> opCallish args MO_F64_Log - DoubleLog1POp -> \args -> opCallish args MO_F64_Log1P - DoubleExpOp -> \args -> opCallish args MO_F64_Exp - DoubleExpM1Op -> \args -> opCallish args MO_F64_ExpM1 - DoubleSqrtOp -> \args -> opCallish args MO_F64_Sqrt - - FloatPowerOp -> \args -> opCallish args MO_F32_Pwr - FloatSinOp -> \args -> opCallish args MO_F32_Sin - FloatCosOp -> \args -> opCallish args MO_F32_Cos - FloatTanOp -> \args -> opCallish args MO_F32_Tan - FloatSinhOp -> \args -> opCallish args MO_F32_Sinh - FloatCoshOp -> \args -> opCallish args MO_F32_Cosh - FloatTanhOp -> \args -> opCallish args MO_F32_Tanh - FloatAsinOp -> \args -> opCallish args MO_F32_Asin - FloatAcosOp -> \args -> opCallish args MO_F32_Acos - FloatAtanOp -> \args -> opCallish args MO_F32_Atan - FloatAsinhOp -> \args -> opCallish args MO_F32_Asinh - FloatAcoshOp -> \args -> opCallish args MO_F32_Acosh - FloatAtanhOp -> \args -> opCallish args MO_F32_Atanh - FloatLogOp -> \args -> opCallish args MO_F32_Log - FloatLog1POp -> \args -> opCallish args MO_F32_Log1P - FloatExpOp -> \args -> opCallish args MO_F32_Exp - FloatExpM1Op -> \args -> opCallish args MO_F32_ExpM1 - FloatSqrtOp -> \args -> opCallish args MO_F32_Sqrt - --- Native word signless ops - - IntAddOp -> \args -> opTranslate args (mo_wordAdd dflags) - IntSubOp -> \args -> opTranslate args (mo_wordSub dflags) - WordAddOp -> \args -> opTranslate args (mo_wordAdd dflags) - WordSubOp -> \args -> opTranslate args (mo_wordSub dflags) - AddrAddOp -> \args -> opTranslate args (mo_wordAdd dflags) - AddrSubOp -> \args -> opTranslate args (mo_wordSub dflags) - - IntEqOp -> \args -> opTranslate args (mo_wordEq dflags) - IntNeOp -> \args -> opTranslate args (mo_wordNe dflags) - WordEqOp -> \args -> opTranslate args (mo_wordEq dflags) - WordNeOp -> \args -> opTranslate args (mo_wordNe dflags) - AddrEqOp -> \args -> opTranslate args (mo_wordEq dflags) - AddrNeOp -> \args -> opTranslate args (mo_wordNe dflags) - - AndOp -> \args -> opTranslate args (mo_wordAnd dflags) - OrOp -> \args -> opTranslate args (mo_wordOr dflags) - XorOp -> \args -> opTranslate args (mo_wordXor dflags) - NotOp -> \args -> opTranslate args (mo_wordNot dflags) - SllOp -> \args -> opTranslate args (mo_wordShl dflags) - SrlOp -> \args -> opTranslate args (mo_wordUShr dflags) - - AddrRemOp -> \args -> opTranslate args (mo_wordURem dflags) - --- Native word signed ops - - IntMulOp -> \args -> opTranslate args (mo_wordMul dflags) - IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth dflags)) - IntQuotOp -> \args -> opTranslate args (mo_wordSQuot dflags) - IntRemOp -> \args -> opTranslate args (mo_wordSRem dflags) - IntNegOp -> \args -> opTranslate args (mo_wordSNeg dflags) - - IntGeOp -> \args -> opTranslate args (mo_wordSGe dflags) - IntLeOp -> \args -> opTranslate args (mo_wordSLe dflags) - IntGtOp -> \args -> opTranslate args (mo_wordSGt dflags) - IntLtOp -> \args -> opTranslate args (mo_wordSLt dflags) - - AndIOp -> \args -> opTranslate args (mo_wordAnd dflags) - OrIOp -> \args -> opTranslate args (mo_wordOr dflags) - XorIOp -> \args -> opTranslate args (mo_wordXor dflags) - NotIOp -> \args -> opTranslate args (mo_wordNot dflags) - ISllOp -> \args -> opTranslate args (mo_wordShl dflags) - ISraOp -> \args -> opTranslate args (mo_wordSShr dflags) - ISrlOp -> \args -> opTranslate args (mo_wordUShr dflags) - --- Native word unsigned ops - - WordGeOp -> \args -> opTranslate args (mo_wordUGe dflags) - WordLeOp -> \args -> opTranslate args (mo_wordULe dflags) - WordGtOp -> \args -> opTranslate args (mo_wordUGt dflags) - WordLtOp -> \args -> opTranslate args (mo_wordULt dflags) - - WordMulOp -> \args -> opTranslate args (mo_wordMul dflags) - WordQuotOp -> \args -> opTranslate args (mo_wordUQuot dflags) - WordRemOp -> \args -> opTranslate args (mo_wordURem dflags) - - AddrGeOp -> \args -> opTranslate args (mo_wordUGe dflags) - AddrLeOp -> \args -> opTranslate args (mo_wordULe dflags) - AddrGtOp -> \args -> opTranslate args (mo_wordUGt dflags) - AddrLtOp -> \args -> opTranslate args (mo_wordULt dflags) - --- Int8# signed ops - - Int8Extend -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth dflags)) - Int8Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W8) - Int8NegOp -> \args -> opTranslate args (MO_S_Neg W8) - Int8AddOp -> \args -> opTranslate args (MO_Add W8) - Int8SubOp -> \args -> opTranslate args (MO_Sub W8) - Int8MulOp -> \args -> opTranslate args (MO_Mul W8) - Int8QuotOp -> \args -> opTranslate args (MO_S_Quot W8) - Int8RemOp -> \args -> opTranslate args (MO_S_Rem W8) - - Int8EqOp -> \args -> opTranslate args (MO_Eq W8) - Int8GeOp -> \args -> opTranslate args (MO_S_Ge W8) - Int8GtOp -> \args -> opTranslate args (MO_S_Gt W8) - Int8LeOp -> \args -> opTranslate args (MO_S_Le W8) - Int8LtOp -> \args -> opTranslate args (MO_S_Lt W8) - Int8NeOp -> \args -> opTranslate args (MO_Ne W8) - --- Word8# unsigned ops - - Word8Extend -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth dflags)) - Word8Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W8) - Word8NotOp -> \args -> opTranslate args (MO_Not W8) - Word8AddOp -> \args -> opTranslate args (MO_Add W8) - Word8SubOp -> \args -> opTranslate args (MO_Sub W8) - Word8MulOp -> \args -> opTranslate args (MO_Mul W8) - Word8QuotOp -> \args -> opTranslate args (MO_U_Quot W8) - Word8RemOp -> \args -> opTranslate args (MO_U_Rem W8) - - Word8EqOp -> \args -> opTranslate args (MO_Eq W8) - Word8GeOp -> \args -> opTranslate args (MO_U_Ge W8) - Word8GtOp -> \args -> opTranslate args (MO_U_Gt W8) - Word8LeOp -> \args -> opTranslate args (MO_U_Le W8) - Word8LtOp -> \args -> opTranslate args (MO_U_Lt W8) - Word8NeOp -> \args -> opTranslate args (MO_Ne W8) - --- Int16# signed ops - - Int16Extend -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth dflags)) - Int16Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W16) - Int16NegOp -> \args -> opTranslate args (MO_S_Neg W16) - Int16AddOp -> \args -> opTranslate args (MO_Add W16) - Int16SubOp -> \args -> opTranslate args (MO_Sub W16) - Int16MulOp -> \args -> opTranslate args (MO_Mul W16) - Int16QuotOp -> \args -> opTranslate args (MO_S_Quot W16) - Int16RemOp -> \args -> opTranslate args (MO_S_Rem W16) - - Int16EqOp -> \args -> opTranslate args (MO_Eq W16) - Int16GeOp -> \args -> opTranslate args (MO_S_Ge W16) - Int16GtOp -> \args -> opTranslate args (MO_S_Gt W16) - Int16LeOp -> \args -> opTranslate args (MO_S_Le W16) - Int16LtOp -> \args -> opTranslate args (MO_S_Lt W16) - Int16NeOp -> \args -> opTranslate args (MO_Ne W16) - --- Word16# unsigned ops - - Word16Extend -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth dflags)) - Word16Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W16) - Word16NotOp -> \args -> opTranslate args (MO_Not W16) - Word16AddOp -> \args -> opTranslate args (MO_Add W16) - Word16SubOp -> \args -> opTranslate args (MO_Sub W16) - Word16MulOp -> \args -> opTranslate args (MO_Mul W16) - Word16QuotOp -> \args -> opTranslate args (MO_U_Quot W16) - Word16RemOp -> \args -> opTranslate args (MO_U_Rem W16) - - Word16EqOp -> \args -> opTranslate args (MO_Eq W16) - Word16GeOp -> \args -> opTranslate args (MO_U_Ge W16) - Word16GtOp -> \args -> opTranslate args (MO_U_Gt W16) - Word16LeOp -> \args -> opTranslate args (MO_U_Le W16) - Word16LtOp -> \args -> opTranslate args (MO_U_Lt W16) - Word16NeOp -> \args -> opTranslate args (MO_Ne W16) - --- Char# ops - - CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth dflags)) - CharNeOp -> \args -> opTranslate args (MO_Ne (wordWidth dflags)) - CharGeOp -> \args -> opTranslate args (MO_U_Ge (wordWidth dflags)) - CharLeOp -> \args -> opTranslate args (MO_U_Le (wordWidth dflags)) - CharGtOp -> \args -> opTranslate args (MO_U_Gt (wordWidth dflags)) - CharLtOp -> \args -> opTranslate args (MO_U_Lt (wordWidth dflags)) - --- Double ops - - DoubleEqOp -> \args -> opTranslate args (MO_F_Eq W64) - DoubleNeOp -> \args -> opTranslate args (MO_F_Ne W64) - DoubleGeOp -> \args -> opTranslate args (MO_F_Ge W64) - DoubleLeOp -> \args -> opTranslate args (MO_F_Le W64) - DoubleGtOp -> \args -> opTranslate args (MO_F_Gt W64) - DoubleLtOp -> \args -> opTranslate args (MO_F_Lt W64) - - DoubleAddOp -> \args -> opTranslate args (MO_F_Add W64) - DoubleSubOp -> \args -> opTranslate args (MO_F_Sub W64) - DoubleMulOp -> \args -> opTranslate args (MO_F_Mul W64) - DoubleDivOp -> \args -> opTranslate args (MO_F_Quot W64) - DoubleNegOp -> \args -> opTranslate args (MO_F_Neg W64) - --- Float ops - - FloatEqOp -> \args -> opTranslate args (MO_F_Eq W32) - FloatNeOp -> \args -> opTranslate args (MO_F_Ne W32) - FloatGeOp -> \args -> opTranslate args (MO_F_Ge W32) - FloatLeOp -> \args -> opTranslate args (MO_F_Le W32) - FloatGtOp -> \args -> opTranslate args (MO_F_Gt W32) - FloatLtOp -> \args -> opTranslate args (MO_F_Lt W32) - - FloatAddOp -> \args -> opTranslate args (MO_F_Add W32) - FloatSubOp -> \args -> opTranslate args (MO_F_Sub W32) - FloatMulOp -> \args -> opTranslate args (MO_F_Mul W32) - FloatDivOp -> \args -> opTranslate args (MO_F_Quot W32) - FloatNegOp -> \args -> opTranslate args (MO_F_Neg W32) - --- Vector ops - - (VecAddOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Add n w) - (VecSubOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub n w) - (VecMulOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul n w) - (VecDivOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w) - (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop" - (VecRemOp FloatVec _ _) -> \_ -> panic "unsupported primop" - (VecNegOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg n w) - - (VecAddOp IntVec n w) -> \args -> opTranslate args (MO_V_Add n w) - (VecSubOp IntVec n w) -> \args -> opTranslate args (MO_V_Sub n w) - (VecMulOp IntVec n w) -> \args -> opTranslate args (MO_V_Mul n w) - (VecDivOp IntVec _ _) -> \_ -> panic "unsupported primop" - (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w) - (VecRemOp IntVec n w) -> \args -> opTranslate args (MO_VS_Rem n w) - (VecNegOp IntVec n w) -> \args -> opTranslate args (MO_VS_Neg n w) - - (VecAddOp WordVec n w) -> \args -> opTranslate args (MO_V_Add n w) - (VecSubOp WordVec n w) -> \args -> opTranslate args (MO_V_Sub n w) - (VecMulOp WordVec n w) -> \args -> opTranslate args (MO_V_Mul n w) - (VecDivOp WordVec _ _) -> \_ -> panic "unsupported primop" - (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w) - (VecRemOp WordVec n w) -> \args -> opTranslate args (MO_VU_Rem n w) - (VecNegOp WordVec _ _) -> \_ -> panic "unsupported primop" - --- Conversions - - Int2DoubleOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W64) - Double2IntOp -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth dflags)) - - Int2FloatOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W32) - Float2IntOp -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth dflags)) - - Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64) - Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) - --- Word comparisons masquerading as more exotic things. - - SameMutVarOp -> \args -> opTranslate args (mo_wordEq dflags) - SameMVarOp -> \args -> opTranslate args (mo_wordEq dflags) - SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags) - SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq dflags) - SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq dflags) - SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags) - SameTVarOp -> \args -> opTranslate args (mo_wordEq dflags) - EqStablePtrOp -> \args -> opTranslate args (mo_wordEq dflags) --- See Note [Comparing stable names] - EqStableNameOp -> \args -> opTranslate args (mo_wordEq dflags) - - IntQuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) - then Left (MO_S_QuotRem (wordWidth dflags)) - else Right (genericIntQuotRemOp (wordWidth dflags)) - - Int8QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) - then Left (MO_S_QuotRem W8) - else Right (genericIntQuotRemOp W8) - - Int16QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) - then Left (MO_S_QuotRem W16) - else Right (genericIntQuotRemOp W16) - - WordQuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) - then Left (MO_U_QuotRem (wordWidth dflags)) - else Right (genericWordQuotRemOp (wordWidth dflags)) - - WordQuotRem2Op -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm - then Left (MO_U_QuotRem2 (wordWidth dflags)) - else Right (genericWordQuotRem2Op dflags) - - Word8QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) - then Left (MO_U_QuotRem W8) - else Right (genericWordQuotRemOp W8) - - Word16QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) - then Left (MO_U_QuotRem W16) - else Right (genericWordQuotRemOp W16) - - WordAdd2Op -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm - then Left (MO_Add2 (wordWidth dflags)) - else Right genericWordAdd2Op - - WordAddCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm - then Left (MO_AddWordC (wordWidth dflags)) - else Right genericWordAddCOp - - WordSubCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm - then Left (MO_SubWordC (wordWidth dflags)) - else Right genericWordSubCOp - - IntAddCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm - then Left (MO_AddIntC (wordWidth dflags)) - else Right genericIntAddCOp - - IntSubCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm - then Left (MO_SubIntC (wordWidth dflags)) - else Right genericIntSubCOp - - WordMul2Op -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) || llvm - then Left (MO_U_Mul2 (wordWidth dflags)) - else Right genericWordMul2Op - - FloatFabsOp -> \args -> opCallishHandledLater args $ - if (ncg && x86ish || ppc) || llvm - then Left MO_F32_Fabs - else Right $ genericFabsOp W32 - - DoubleFabsOp -> \args -> opCallishHandledLater args $ - if (ncg && x86ish || ppc) || llvm - then Left MO_F64_Fabs - else Right $ genericFabsOp W64 - - -- tagToEnum# is special: we need to pull the constructor - -- out of the table, and perform an appropriate return. - TagToEnumOp -> \[amode] -> PrimopCmmEmit_Raw $ \res_ty -> do - -- If you're reading this code in the attempt to figure - -- out why the compiler panic'ed here, it is probably because - -- you used tagToEnum# in a non-monomorphic setting, e.g., - -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# - -- That won't work. - let tycon = tyConAppTyCon res_ty - MASSERT(isEnumerationTyCon tycon) - dflags <- getDynFlags - pure [tagToClosure dflags tycon amode] - --- Out of line primops. --- TODO compiler need not know about these - - UnsafeThawArrayOp -> alwaysExternal - CasArrayOp -> alwaysExternal - UnsafeThawSmallArrayOp -> alwaysExternal - CasSmallArrayOp -> alwaysExternal - NewPinnedByteArrayOp_Char -> alwaysExternal - NewAlignedPinnedByteArrayOp_Char -> alwaysExternal - MutableByteArrayIsPinnedOp -> alwaysExternal - DoubleDecode_2IntOp -> alwaysExternal - DoubleDecode_Int64Op -> alwaysExternal - FloatDecode_IntOp -> alwaysExternal - ByteArrayIsPinnedOp -> alwaysExternal - ShrinkMutableByteArrayOp_Char -> alwaysExternal - ResizeMutableByteArrayOp_Char -> alwaysExternal - ShrinkSmallMutableArrayOp_Char -> alwaysExternal - NewArrayArrayOp -> alwaysExternal - NewMutVarOp -> alwaysExternal - AtomicModifyMutVar2Op -> alwaysExternal - AtomicModifyMutVar_Op -> alwaysExternal - CasMutVarOp -> alwaysExternal - CatchOp -> alwaysExternal - RaiseOp -> alwaysExternal - RaiseIOOp -> alwaysExternal - MaskAsyncExceptionsOp -> alwaysExternal - MaskUninterruptibleOp -> alwaysExternal - UnmaskAsyncExceptionsOp -> alwaysExternal - MaskStatus -> alwaysExternal - AtomicallyOp -> alwaysExternal - RetryOp -> alwaysExternal - CatchRetryOp -> alwaysExternal - CatchSTMOp -> alwaysExternal - NewTVarOp -> alwaysExternal - ReadTVarOp -> alwaysExternal - ReadTVarIOOp -> alwaysExternal - WriteTVarOp -> alwaysExternal - NewMVarOp -> alwaysExternal - TakeMVarOp -> alwaysExternal - TryTakeMVarOp -> alwaysExternal - PutMVarOp -> alwaysExternal - TryPutMVarOp -> alwaysExternal - ReadMVarOp -> alwaysExternal - TryReadMVarOp -> alwaysExternal - IsEmptyMVarOp -> alwaysExternal - DelayOp -> alwaysExternal - WaitReadOp -> alwaysExternal - WaitWriteOp -> alwaysExternal - ForkOp -> alwaysExternal - ForkOnOp -> alwaysExternal - KillThreadOp -> alwaysExternal - YieldOp -> alwaysExternal - LabelThreadOp -> alwaysExternal - IsCurrentThreadBoundOp -> alwaysExternal - NoDuplicateOp -> alwaysExternal - ThreadStatusOp -> alwaysExternal - MkWeakOp -> alwaysExternal - MkWeakNoFinalizerOp -> alwaysExternal - AddCFinalizerToWeakOp -> alwaysExternal - DeRefWeakOp -> alwaysExternal - FinalizeWeakOp -> alwaysExternal - MakeStablePtrOp -> alwaysExternal - DeRefStablePtrOp -> alwaysExternal - MakeStableNameOp -> alwaysExternal - CompactNewOp -> alwaysExternal - CompactResizeOp -> alwaysExternal - CompactContainsOp -> alwaysExternal - CompactContainsAnyOp -> alwaysExternal - CompactGetFirstBlockOp -> alwaysExternal - CompactGetNextBlockOp -> alwaysExternal - CompactAllocateBlockOp -> alwaysExternal - CompactFixupPointersOp -> alwaysExternal - CompactAdd -> alwaysExternal - CompactAddWithSharing -> alwaysExternal - CompactSize -> alwaysExternal - SeqOp -> alwaysExternal - GetSparkOp -> alwaysExternal - NumSparks -> alwaysExternal - DataToTagOp -> alwaysExternal - MkApUpd0_Op -> alwaysExternal - NewBCOOp -> alwaysExternal - UnpackClosureOp -> alwaysExternal - ClosureSizeOp -> alwaysExternal - GetApStackValOp -> alwaysExternal - ClearCCSOp -> alwaysExternal - TraceEventOp -> alwaysExternal - TraceEventBinaryOp -> alwaysExternal - TraceMarkerOp -> alwaysExternal - SetThreadAllocationCounter -> alwaysExternal - - where - alwaysExternal = \_ -> PrimopCmmEmit_External - -- Note [QuotRem optimization] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- - -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops - -- (shift, .&.). - -- - -- Currently we only support optimization (performed in CmmOpt) when the - -- constant is a power of 2. #9041 tracks the implementation of the general - -- optimization. - -- - -- `quotRem` can be optimized in the same way. However as it returns two values, - -- it is implemented as a "callish" primop which is harder to match and - -- to transform later on. For simplicity, the current implementation detects cases - -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem - -- primop into two CMM quot and rem primops. - quotRemCanBeOptimized = \case - [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n) - _ -> False - - ncg = case hscTarget dflags of - HscAsm -> True - _ -> False - llvm = case hscTarget dflags of - HscLlvm -> True - _ -> False - x86ish = case platformArch (targetPlatform dflags) of - ArchX86 -> True - ArchX86_64 -> True - _ -> False - ppc = case platformArch (targetPlatform dflags) of - ArchPPC -> True - ArchPPC_64 _ -> True - _ -> False - -data PrimopCmmEmit - = PrimopCmmEmit_External - | PrimopCmmEmit_IntoRegs ([LocalReg] -- where to put the results - -> FCode ()) - -- | Manual escape hatch, this is just for the '@TagToEnum@' - -- primop for now. It would be nice to remove this special case but that is - -- future work. - | PrimopCmmEmit_Raw (Type -- the return type, some primops are specialized to it - -> FCode [CmmExpr]) -- just for TagToEnum for now - -opNop :: [CmmExpr] -> PrimopCmmEmit -opNop args = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) arg - where [arg] = args - -opNarrow - :: DynFlags - -> [CmmExpr] - -> (Width -> Width -> MachOp, Width) - -> PrimopCmmEmit -opNarrow dflags args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $ - CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]] - where [arg] = args - --- | These primops are implemented by CallishMachOps, because they sometimes --- turn into foreign calls depending on the backend. -opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit -opCallish args prim = PrimopCmmEmit_IntoRegs $ \[res] -> emitPrimCall [res] prim args - -opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit -opTranslate args mop = PrimopCmmEmit_IntoRegs $ \[res] -> do - let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) - emit stmt - --- | Basically a "manual" case, rather than one of the common repetitive forms --- above. The results are a parameter to the returned function so we know the --- choice of variant never depends on them. -opCallishHandledLater - :: [CmmExpr] - -> Either CallishMachOp GenericOp - -> PrimopCmmEmit -opCallishHandledLater args callOrNot = PrimopCmmEmit_IntoRegs $ \res0 -> case callOrNot of - Left op -> emit $ mkUnsafeCall (PrimTarget op) res0 args - Right gen -> gen res0 args - -opAllDone - :: ([LocalReg] -- where to put the results - -> FCode ()) - -> PrimopCmmEmit -opAllDone f = PrimopCmmEmit_IntoRegs $ f - -type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () - -genericIntQuotRemOp :: Width -> GenericOp -genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y] - = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*> - mkAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem width) [arg_x, arg_y]) -genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" - -genericWordQuotRemOp :: Width -> GenericOp -genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y] - = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*> - mkAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem width) [arg_x, arg_y]) -genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" - -genericWordQuotRem2Op :: DynFlags -> GenericOp -genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y] - = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low - where ty = cmmExprType dflags arg_x_high - shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] - shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] - ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] - minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] - times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] - zero = lit 0 - one = lit 1 - negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) - lit i = CmmLit (CmmInt i (wordWidth dflags)) - - f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph - f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> - mkAssign (CmmLocal res_r) high) - f i acc high low = - do roverflowedBit <- newTemp ty - rhigh' <- newTemp ty - rhigh'' <- newTemp ty - rlow' <- newTemp ty - risge <- newTemp ty - racc' <- newTemp ty - let high' = CmmReg (CmmLocal rhigh') - isge = CmmReg (CmmLocal risge) - overflowedBit = CmmReg (CmmLocal roverflowedBit) - let this = catAGraphs - [mkAssign (CmmLocal roverflowedBit) - (shr high negone), - mkAssign (CmmLocal rhigh') - (or (shl high one) (shr low negone)), - mkAssign (CmmLocal rlow') - (shl low one), - mkAssign (CmmLocal risge) - (or (overflowedBit `ne` zero) - (high' `ge` arg_y)), - mkAssign (CmmLocal rhigh'') - (high' `minus` (arg_y `times` isge)), - mkAssign (CmmLocal racc') - (or (shl acc one) isge)] - rest <- f (i - 1) (CmmReg (CmmLocal racc')) - (CmmReg (CmmLocal rhigh'')) - (CmmReg (CmmLocal rlow')) - return (this <*> rest) -genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op" - -genericWordAdd2Op :: GenericOp -genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] - = do dflags <- getDynFlags - r1 <- newTemp (cmmExprType dflags arg_x) - r2 <- newTemp (cmmExprType dflags arg_x) - let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] - bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] - add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - (wordWidth dflags)) - hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) - emit $ catAGraphs - [mkAssign (CmmLocal r1) - (add (bottomHalf arg_x) (bottomHalf arg_y)), - mkAssign (CmmLocal r2) - (add (topHalf (CmmReg (CmmLocal r1))) - (add (topHalf arg_x) (topHalf arg_y))), - mkAssign (CmmLocal res_h) - (topHalf (CmmReg (CmmLocal r2))), - mkAssign (CmmLocal res_l) - (or (toTopHalf (CmmReg (CmmLocal r2))) - (bottomHalf (CmmReg (CmmLocal r1))))] -genericWordAdd2Op _ _ = panic "genericWordAdd2Op" - --- | Implements branchless recovery of the carry flag @c@ by checking the --- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@: --- --- @ --- c = a&b | (a|b)&~r --- @ --- --- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ -genericWordAddCOp :: GenericOp -genericWordAddCOp [res_r, res_c] [aa, bb] - = do dflags <- getDynFlags - emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordAnd dflags) [aa,bb], - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordOr dflags) [aa,bb], - CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)] - ] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] -genericWordAddCOp _ _ = panic "genericWordAddCOp" - --- | Implements branchless recovery of the carry flag @c@ by checking the --- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@: --- --- @ --- c = ~a&b | (~a|b)&r --- @ --- --- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ -genericWordSubCOp :: GenericOp -genericWordSubCOp [res_r, res_c] [aa, bb] - = do dflags <- getDynFlags - emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordNot dflags) [aa], - bb - ], - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordNot dflags) [aa], - bb - ], - CmmReg (CmmLocal res_r) - ] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] -genericWordSubCOp _ _ = panic "genericWordSubCOp" - -genericIntAddCOp :: GenericOp -genericIntAddCOp [res_r, res_c] [aa, bb] -{- - With some bit-twiddling, we can define int{Add,Sub}Czh portably in - C, and without needing any comparisons. This may not be the - fastest way to do it - if you have better code, please send it! --SDM - - Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. - overflow), we just convert to big integers and try again. This - could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - Wading through the mass of bracketry, it seems to reduce to: - c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) - --} - = do dflags <- getDynFlags - emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] -genericIntAddCOp _ _ = panic "genericIntAddCOp" - -genericIntSubCOp :: GenericOp -genericIntSubCOp [res_r, res_c] [aa, bb] -{- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - - c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) --} - = do dflags <- getDynFlags - emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordXor dflags) [aa,bb], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] -genericIntSubCOp _ _ = panic "genericIntSubCOp" - -genericWordMul2Op :: GenericOp -genericWordMul2Op [res_h, res_l] [arg_x, arg_y] - = do dflags <- getDynFlags - let t = cmmExprType dflags arg_x - xlyl <- liftM CmmLocal $ newTemp t - xlyh <- liftM CmmLocal $ newTemp t - xhyl <- liftM CmmLocal $ newTemp t - r <- liftM CmmLocal $ newTemp t - -- This generic implementation is very simple and slow. We might - -- well be able to do better, but for now this at least works. - let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] - bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] - add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] - sum = foldl1 add - mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - (wordWidth dflags)) - hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) - emit $ catAGraphs - [mkAssign xlyl - (mul (bottomHalf arg_x) (bottomHalf arg_y)), - mkAssign xlyh - (mul (bottomHalf arg_x) (topHalf arg_y)), - mkAssign xhyl - (mul (topHalf arg_x) (bottomHalf arg_y)), - mkAssign r - (sum [topHalf (CmmReg xlyl), - bottomHalf (CmmReg xhyl), - bottomHalf (CmmReg xlyh)]), - mkAssign (CmmLocal res_l) - (or (bottomHalf (CmmReg xlyl)) - (toTopHalf (CmmReg r))), - mkAssign (CmmLocal res_h) - (sum [mul (topHalf arg_x) (topHalf arg_y), - topHalf (CmmReg xhyl), - topHalf (CmmReg xlyh), - topHalf (CmmReg r)])] -genericWordMul2Op _ _ = panic "genericWordMul2Op" - --- This replicates what we had in libraries/base/GHC/Float.hs: --- --- abs x | x == 0 = 0 -- handles (-0.0) --- | x > 0 = x --- | otherwise = negateFloat x -genericFabsOp :: Width -> GenericOp -genericFabsOp w [res_r] [aa] - = do dflags <- getDynFlags - let zero = CmmLit (CmmFloat 0 w) - - eq x y = CmmMachOp (MO_F_Eq w) [x, y] - gt x y = CmmMachOp (MO_F_Gt w) [x, y] - - neg x = CmmMachOp (MO_F_Neg w) [x] - - g1 = catAGraphs [mkAssign (CmmLocal res_r) zero] - g2 = catAGraphs [mkAssign (CmmLocal res_r) aa] - - res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa) - let g3 = catAGraphs [mkAssign res_t aa, - mkAssign (CmmLocal res_r) (neg (CmmReg res_t))] - - g4 <- mkCmmIfThenElse (gt aa zero) g2 g3 - - emit =<< mkCmmIfThenElse (eq aa zero) g1 g4 - -genericFabsOp _ _ _ = panic "genericFabsOp" - --- Note [Comparing stable names] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- A StableName# is actually a pointer to a stable name object (SNO) --- containing an index into the stable name table (SNT). We --- used to compare StableName#s by following the pointers to the --- SNOs and checking whether they held the same SNT indices. However, --- this is not necessary: there is a one-to-one correspondence --- between SNOs and entries in the SNT, so simple pointer equality --- does the trick. - ------------------------------------------------------------------------------- --- Helpers for translating various minor variants of array indexing. - -doIndexOffAddrOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] - = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx -doIndexOffAddrOp _ _ _ _ - = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" - -doIndexOffAddrOpAs :: Maybe MachOp - -> CmmType - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] - = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx -doIndexOffAddrOpAs _ _ _ _ _ - = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" - -doIndexByteArrayOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx -doIndexByteArrayOp _ _ _ _ - = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" - -doIndexByteArrayOpAs :: Maybe MachOp - -> CmmType - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx -doIndexByteArrayOpAs _ _ _ _ _ - = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" - -doReadPtrArrayOp :: LocalReg - -> CmmExpr - -> CmmExpr - -> FCode () -doReadPtrArrayOp res addr idx - = do dflags <- getDynFlags - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx - -doWriteOffAddrOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val] - = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val -doWriteOffAddrOp _ _ _ _ - = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" - -doWriteByteArrayOp :: Maybe MachOp - -> CmmType - -> [LocalReg] - -> [CmmExpr] - -> FCode () -doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] - = do dflags <- getDynFlags - mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val -doWriteByteArrayOp _ _ _ _ - = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" - -doWritePtrArrayOp :: CmmExpr - -> CmmExpr - -> CmmExpr - -> FCode () -doWritePtrArrayOp addr idx val - = do dflags <- getDynFlags - let ty = cmmExprType dflags val - hdr_size = arrPtrsHdrSize dflags - -- Update remembered set for non-moving collector - whenUpdRemSetEnabled dflags - $ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx) - -- This write barrier is to ensure that the heap writes to the object - -- referred to by val have happened before we write val into the array. - -- See #12469 for details. - emitPrimCall [] MO_WriteBarrier [] - mkBasicIndexedWrite hdr_size Nothing addr ty idx val - emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - -- the write barrier. We must write a byte into the mark table: - -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] - emit $ mkStore ( - cmmOffsetExpr dflags - (cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size) - (loadArrPtrsSize dflags addr)) - (CmmMachOp (mo_wordUShr dflags) [idx, - mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)]) - ) (CmmLit (CmmInt 1 W8)) - -loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) - where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags - -mkBasicIndexedRead :: ByteOff -- Initial offset in bytes - -> Maybe MachOp -- Optional result cast - -> CmmType -- Type of element we are accessing - -> LocalReg -- Destination - -> CmmExpr -- Base address - -> CmmType -- Type of element by which we are indexing - -> CmmExpr -- Index - -> FCode () -mkBasicIndexedRead off Nothing ty res base idx_ty idx - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx) -mkBasicIndexedRead off (Just cast) ty res base idx_ty idx - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr dflags off ty base idx_ty idx]) - -mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes - -> Maybe MachOp -- Optional value cast - -> CmmExpr -- Base address - -> CmmType -- Type of element by which we are indexing - -> CmmExpr -- Index - -> CmmExpr -- Value to write - -> FCode () -mkBasicIndexedWrite off Nothing base idx_ty idx val - = do dflags <- getDynFlags - emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val -mkBasicIndexedWrite off (Just cast) base idx_ty idx val - = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) - --- ---------------------------------------------------------------------------- --- Misc utils - -cmmIndexOffExpr :: DynFlags - -> ByteOff -- Initial offset in bytes - -> Width -- Width of element by which we are indexing - -> CmmExpr -- Base address - -> CmmExpr -- Index - -> CmmExpr -cmmIndexOffExpr dflags off width base idx - = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx - -cmmLoadIndexOffExpr :: DynFlags - -> ByteOff -- Initial offset in bytes - -> CmmType -- Type of element we are accessing - -> CmmExpr -- Base address - -> CmmType -- Type of element by which we are indexing - -> CmmExpr -- Index - -> CmmExpr -cmmLoadIndexOffExpr dflags off ty base idx_ty idx - = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty - -setInfo :: CmmExpr -> CmmExpr -> CmmAGraph -setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr - ------------------------------------------------------------------------------- --- Helpers for translating vector primops. - -vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType -vecVmmType pocat n w = vec n (vecCmmCat pocat w) - -vecCmmCat :: PrimOpVecCat -> Width -> CmmType -vecCmmCat IntVec = cmmBits -vecCmmCat WordVec = cmmBits -vecCmmCat FloatVec = cmmFloat - -vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp -vecElemInjectCast _ FloatVec _ = Nothing -vecElemInjectCast dflags IntVec W8 = Just (mo_WordTo8 dflags) -vecElemInjectCast dflags IntVec W16 = Just (mo_WordTo16 dflags) -vecElemInjectCast dflags IntVec W32 = Just (mo_WordTo32 dflags) -vecElemInjectCast _ IntVec W64 = Nothing -vecElemInjectCast dflags WordVec W8 = Just (mo_WordTo8 dflags) -vecElemInjectCast dflags WordVec W16 = Just (mo_WordTo16 dflags) -vecElemInjectCast dflags WordVec W32 = Just (mo_WordTo32 dflags) -vecElemInjectCast _ WordVec W64 = Nothing -vecElemInjectCast _ _ _ = Nothing - -vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp -vecElemProjectCast _ FloatVec _ = Nothing -vecElemProjectCast dflags IntVec W8 = Just (mo_s_8ToWord dflags) -vecElemProjectCast dflags IntVec W16 = Just (mo_s_16ToWord dflags) -vecElemProjectCast dflags IntVec W32 = Just (mo_s_32ToWord dflags) -vecElemProjectCast _ IntVec W64 = Nothing -vecElemProjectCast dflags WordVec W8 = Just (mo_u_8ToWord dflags) -vecElemProjectCast dflags WordVec W16 = Just (mo_u_16ToWord dflags) -vecElemProjectCast dflags WordVec W32 = Just (mo_u_32ToWord dflags) -vecElemProjectCast _ WordVec W64 = Nothing -vecElemProjectCast _ _ _ = Nothing - - --- NOTE [SIMD Design for the future] --- Check to make sure that we can generate code for the specified vector type --- given the current set of dynamic flags. --- Currently these checks are specific to x86 and x86_64 architecture. --- This should be fixed! --- In particular, --- 1) Add better support for other architectures! (this may require a redesign) --- 2) Decouple design choices from LLVM's pseudo SIMD model! --- The high level LLVM naive rep makes per CPU family SIMD generation is own --- optimization problem, and hides important differences in eg ARM vs x86_64 simd --- 3) Depending on the architecture, the SIMD registers may also support general --- computations on Float/Double/Word/Int scalars, but currently on --- for example x86_64, we always put Word/Int (or sized) in GPR --- (general purpose) registers. Would relaxing that allow for --- useful optimization opportunities? --- Phrased differently, it is worth experimenting with supporting --- different register mapping strategies than we currently have, especially if --- someday we want SIMD to be a first class denizen in GHC along with scalar --- values! --- The current design with respect to register mapping of scalars could --- very well be the best,but exploring the design space and doing careful --- measurments is the only only way to validate that. --- In some next generation CPU ISAs, notably RISC V, the SIMD extension --- includes support for a sort of run time CPU dependent vectorization parameter, --- where a loop may act upon a single scalar each iteration OR some 2,4,8 ... --- element chunk! Time will tell if that direction sees wide adoption, --- but it is from that context that unifying our handling of simd and scalars --- may benefit. It is not likely to benefit current architectures, though --- it may very well be a design perspective that helps guide improving the NCG. - - -checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () -checkVecCompatibility dflags vcat l w = do - when (hscTarget dflags /= HscLlvm) $ do - sorry $ unlines ["SIMD vector instructions require the LLVM back-end." - ,"Please use -fllvm."] - check vecWidth vcat l w - where - check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () - check W128 FloatVec 4 W32 | not (isSseEnabled dflags) = - sorry $ "128-bit wide single-precision floating point " ++ - "SIMD vector instructions require at least -msse." - check W128 _ _ _ | not (isSse2Enabled dflags) = - sorry $ "128-bit wide integer and double precision " ++ - "SIMD vector instructions require at least -msse2." - check W256 FloatVec _ _ | not (isAvxEnabled dflags) = - sorry $ "256-bit wide floating point " ++ - "SIMD vector instructions require at least -mavx." - check W256 _ _ _ | not (isAvx2Enabled dflags) = - sorry $ "256-bit wide integer " ++ - "SIMD vector instructions require at least -mavx2." - check W512 _ _ _ | not (isAvx512fEnabled dflags) = - sorry $ "512-bit wide " ++ - "SIMD vector instructions require -mavx512f." - check _ _ _ _ = return () - - vecWidth = typeWidth (vecVmmType vcat l w) - ------------------------------------------------------------------------------- --- Helpers for translating vector packing and unpacking. - -doVecPackOp :: Maybe MachOp -- Cast from element to vector component - -> CmmType -- Type of vector - -> CmmExpr -- Initial vector - -> [CmmExpr] -- Elements - -> CmmFormal -- Destination for result - -> FCode () -doVecPackOp maybe_pre_write_cast ty z es res = do - dst <- newTemp ty - emitAssign (CmmLocal dst) z - vecPack dst es 0 - where - vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode () - vecPack src [] _ = - emitAssign (CmmLocal res) (CmmReg (CmmLocal src)) - - vecPack src (e : es) i = do - dst <- newTemp ty - if isFloatType (vecElemType ty) - then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) - else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) - vecPack dst es (i + 1) - where - -- vector indices are always 32-bits - iLit = CmmLit (CmmInt (toInteger i) W32) - - cast :: CmmExpr -> CmmExpr - cast val = case maybe_pre_write_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - - len :: Length - len = vecLength ty - - wid :: Width - wid = typeWidth (vecElemType ty) - -doVecUnpackOp :: Maybe MachOp -- Cast from vector component to element result - -> CmmType -- Type of vector - -> CmmExpr -- Vector - -> [CmmFormal] -- Element results - -> FCode () -doVecUnpackOp maybe_post_read_cast ty e res = - vecUnpack res 0 - where - vecUnpack :: [CmmFormal] -> Int -> FCode () - vecUnpack [] _ = - return () - - vecUnpack (r : rs) i = do - if isFloatType (vecElemType ty) - then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid) - [e, iLit])) - else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid) - [e, iLit])) - vecUnpack rs (i + 1) - where - -- vector indices are always 32-bits - iLit = CmmLit (CmmInt (toInteger i) W32) - - cast :: CmmExpr -> CmmExpr - cast val = case maybe_post_read_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - - len :: Length - len = vecLength ty - - wid :: Width - wid = typeWidth (vecElemType ty) - -doVecInsertOp :: Maybe MachOp -- Cast from element to vector component - -> CmmType -- Vector type - -> CmmExpr -- Source vector - -> CmmExpr -- Element - -> CmmExpr -- Index at which to insert element - -> CmmFormal -- Destination for result - -> FCode () -doVecInsertOp maybe_pre_write_cast ty src e idx res = do - dflags <- getDynFlags - -- vector indices are always 32-bits - let idx' :: CmmExpr - idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx] - if isFloatType (vecElemType ty) - then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx']) - else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx']) - where - cast :: CmmExpr -> CmmExpr - cast val = case maybe_pre_write_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - - len :: Length - len = vecLength ty - - wid :: Width - wid = typeWidth (vecElemType ty) - ------------------------------------------------------------------------------- --- Helpers for translating prefetching. - - --- | Translate byte array prefetch operations into proper primcalls. -doPrefetchByteArrayOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx -doPrefetchByteArrayOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" - --- | Translate mutable byte array prefetch operations into proper primcalls. -doPrefetchMutableByteArrayOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchMutableByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx -doPrefetchMutableByteArrayOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" - --- | Translate address prefetch operations into proper primcalls. -doPrefetchAddrOp ::Int - -> [CmmExpr] - -> FCode () -doPrefetchAddrOp locality [addr,idx] - = mkBasicPrefetch locality 0 addr idx -doPrefetchAddrOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp" - --- | Translate value prefetch operations into proper primcalls. -doPrefetchValueOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchValueOp locality [addr] - = do dflags <- getDynFlags - mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth dflags))) -doPrefetchValueOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchValueOp" - --- | helper to generate prefetch primcalls -mkBasicPrefetch :: Int -- Locality level 0-3 - -> ByteOff -- Initial offset in bytes - -> CmmExpr -- Base address - -> CmmExpr -- Index - -> FCode () -mkBasicPrefetch locality off base idx - = do dflags <- getDynFlags - emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx] - return () - --- ---------------------------------------------------------------------------- --- Allocating byte arrays - --- | Takes a register to return the newly allocated array in and the --- size of the new array in bytes. Allocates a new --- 'MutableByteArray#'. -doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () -doNewByteArrayOp res_r n = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr mkArrWords_infoLabel - rep = arrWordsRep dflags n - - tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - let hdr_size = fixedHdrSize dflags - - base <- allocHeapClosure rep info_ptr cccsExpr - [ (mkIntExpr dflags n, - hdr_size + oFFSET_StgArrBytes_bytes dflags) - ] - - emit $ mkAssign (CmmLocal res_r) base - --- ---------------------------------------------------------------------------- --- Comparing byte arrays - -doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do - dflags <- getDynFlags - ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off - ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off - - -- short-cut in case of equal pointers avoiding a costly - -- subroutine call to the memcmp(3) routine; the Cmm logic below - -- results in assembly code being generated for - -- - -- cmpPrefix10 :: ByteArray# -> ByteArray# -> Int# - -- cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10# - -- - -- that looks like - -- - -- leaq 16(%r14),%rax - -- leaq 16(%rsi),%rbx - -- xorl %ecx,%ecx - -- cmpq %rbx,%rax - -- je l_ptr_eq - -- - -- ; NB: the common case (unequal pointers) falls-through - -- ; the conditional jump, and therefore matches the - -- ; usual static branch prediction convention of modern cpus - -- - -- subq $8,%rsp - -- movq %rbx,%rsi - -- movq %rax,%rdi - -- movl $10,%edx - -- xorl %eax,%eax - -- call memcmp - -- addq $8,%rsp - -- movslq %eax,%rax - -- movq %rax,%rcx - -- l_ptr_eq: - -- movq %rcx,%rbx - -- jmp *(%rbp) - - l_ptr_eq <- newBlockId - l_ptr_ne <- newBlockId - - emit (mkAssign (CmmLocal res) (zeroExpr dflags)) - emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p) - l_ptr_eq l_ptr_ne (Just False)) - - emitLabel l_ptr_ne - emitMemcmpCall res ba1_p ba2_p n 1 - - emitLabel l_ptr_eq - --- ---------------------------------------------------------------------------- --- Copying byte arrays - --- | Takes a source 'ByteArray#', an offset in the source array, a --- destination 'MutableByteArray#', an offset into the destination --- array, and the number of bytes to copy. Copies the given number of --- bytes from the source array to the destination array. -doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyByteArrayOp = emitCopyByteArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes align = - emitMemcpyCall dst_p src_p bytes align - --- | Takes a source 'MutableByteArray#', an offset in the source --- array, a destination 'MutableByteArray#', an offset into the --- destination array, and the number of bytes to copy. Copies the --- given number of bytes from the source array to the destination --- array. -doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyMutableByteArrayOp = emitCopyByteArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes align = do - dflags <- getDynFlags - (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p bytes align) - (getCode $ emitMemcpyCall dst_p src_p bytes align) - emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall - -emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> Alignment -> FCode ()) - -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -emitCopyByteArray copy src src_off dst dst_off n = do - dflags <- getDynFlags - let byteArrayAlignment = wordAlignment dflags - srcOffAlignment = cmmExprAlignment src_off - dstOffAlignment = cmmExprAlignment dst_off - align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment] - dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off - copy src dst dst_p src_p n align - --- | Takes a source 'ByteArray#', an offset in the source array, a --- destination 'Addr#', and the number of bytes to copy. Copies the given --- number of bytes from the source array to the destination memory region. -doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () -doCopyByteArrayToAddrOp src src_off dst_p bytes = do - -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags - src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p bytes (mkAlignment 1) - --- | Takes a source 'MutableByteArray#', an offset in the source array, a --- destination 'Addr#', and the number of bytes to copy. Copies the given --- number of bytes from the source array to the destination memory region. -doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp - --- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into --- the destination array, and the number of bytes to copy. Copies the given --- number of bytes from the source memory region to the destination array. -doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () -doCopyAddrToByteArrayOp src_p dst dst_off bytes = do - -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags - dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off - emitMemcpyCall dst_p src_p bytes (mkAlignment 1) - - --- ---------------------------------------------------------------------------- --- Setting byte arrays - --- | Takes a 'MutableByteArray#', an offset into the array, a length, --- and a byte, and sets each of the selected bytes in the array to the --- character. -doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doSetByteArrayOp ba off len c = do - dflags <- getDynFlags - - let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap - offsetAlignment = cmmExprAlignment off - align = min byteArrayAlignment offsetAlignment - - p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len align - --- ---------------------------------------------------------------------------- --- Allocating arrays - --- | Allocate a new array. -doNewArrayOp :: CmmFormal -- ^ return register - -> SMRep -- ^ representation of the array - -> CLabel -- ^ info pointer - -> [(CmmExpr, ByteOff)] -- ^ header payload - -> WordOff -- ^ array size - -> CmmExpr -- ^ initial element - -> FCode () -doNewArrayOp res_r rep info payload n init = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr info - - tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - base <- allocHeapClosure rep info_ptr cccsExpr payload - - arr <- CmmLocal `fmap` newTemp (bWord dflags) - emit $ mkAssign arr base - - -- Initialise all elements of the array - let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off) - initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] - emit (catAGraphs initialization) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- ---------------------------------------------------------------------------- --- Copying pointer arrays - --- EZY: This code has an unusually high amount of assignTemp calls, seen --- nowhere else in the code generator. This is mostly because these --- "primitive" ops result in a surprisingly large amount of code. It --- will likely be worthwhile to optimize what is emitted here, so that --- our optimization passes don't waste time repeatedly optimizing the --- same bits of code. - --- More closely imitates 'assignTemp' from the old code generator, which --- returns a CmmExpr rather than a LocalReg. -assignTempE :: CmmExpr -> FCode CmmExpr -assignTempE e = do - t <- assignTemp e - return (CmmReg (CmmLocal t)) - --- | Takes a source 'Array#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopyArrayOp = emitCopyArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes = - do dflags <- getDynFlags - emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wordAlignment dflags) - - --- | Takes a source 'MutableArray#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopyMutableArrayOp = emitCopyArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes = do - dflags <- getDynFlags - (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes) - (wordAlignment dflags)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wordAlignment dflags)) - emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall - -emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff - -> FCode ()) -- ^ copy function - -> CmmExpr -- ^ source array - -> CmmExpr -- ^ offset in source array - -> CmmExpr -- ^ destination array - -> CmmExpr -- ^ offset in destination array - -> WordOff -- ^ number of elements to copy - -> FCode () -emitCopyArray copy src0 src_off dst0 dst_off0 n = - when (n /= 0) $ do - dflags <- getDynFlags - - -- Passed as arguments (be careful) - src <- assignTempE src0 - dst <- assignTempE dst0 - dst_off <- assignTempE dst_off0 - - -- Nonmoving collector write barrier - emitCopyUpdRemSetPush dflags (arrPtrsHdrSize dflags) dst dst_off n - - -- Set the dirty bit in the header. - emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - - dst_elems_p <- assignTempE $ cmmOffsetB dflags dst - (arrPtrsHdrSize dflags) - dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off - src_p <- assignTempE $ cmmOffsetExprW dflags - (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - let bytes = wordsToBytes dflags n - - copy src dst dst_p src_p bytes - - -- The base address of the destination card table - dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p - (loadArrPtrsSize dflags dst) - - emitSetCards dst_off dst_cards_p n - -doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopySmallArrayOp = emitCopySmallArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes = - do dflags <- getDynFlags - emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wordAlignment dflags) - - -doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopySmallMutableArrayOp = emitCopySmallArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes = do - dflags <- getDynFlags - (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes) - (wordAlignment dflags)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) - (wordAlignment dflags)) - emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall - -emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff - -> FCode ()) -- ^ copy function - -> CmmExpr -- ^ source array - -> CmmExpr -- ^ offset in source array - -> CmmExpr -- ^ destination array - -> CmmExpr -- ^ offset in destination array - -> WordOff -- ^ number of elements to copy - -> FCode () -emitCopySmallArray copy src0 src_off dst0 dst_off n = - when (n /= 0) $ do - dflags <- getDynFlags - - -- Passed as arguments (be careful) - src <- assignTempE src0 - dst <- assignTempE dst0 - - -- Nonmoving collector write barrier - emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSize dflags) dst dst_off n - - -- Set the dirty bit in the header. - emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) - - dst_p <- assignTempE $ cmmOffsetExprW dflags - (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExprW dflags - (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off - let bytes = wordsToBytes dflags n - - copy src dst dst_p src_p bytes - --- | Takes an info table label, a register to return the newly --- allocated array in, a source array, an offset in the source array, --- and the number of elements to copy. Allocates a new array and --- initializes it from the source array. -emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -emitCloneArray info_p res_r src src_off n = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr info_p - rep = arrPtrsRep dflags n - - tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - let hdr_size = fixedHdrSize dflags - - base <- allocHeapClosure rep info_ptr cccsExpr - [ (mkIntExpr dflags n, - hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags) - , (mkIntExpr dflags (nonHdrSizeW rep), - hdr_size + oFFSET_StgMutArrPtrs_size dflags) - ] - - arr <- CmmLocal `fmap` newTemp (bWord dflags) - emit $ mkAssign arr base - - dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr) - (arrPtrsHdrSize dflags) - src_p <- assignTempE $ cmmOffsetExprW dflags src - (cmmAddWord dflags - (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off) - - emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n)) - (wordAlignment dflags) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- | Takes an info table label, a register to return the newly --- allocated array in, a source array, an offset in the source array, --- and the number of elements to copy. Allocates a new array and --- initializes it from the source array. -emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -emitCloneSmallArray info_p res_r src src_off n = do - dflags <- getDynFlags - - let info_ptr = mkLblExpr info_p - rep = smallArrPtrsRep n - - tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags)) - (mkIntExpr dflags (nonHdrSize dflags rep)) - (zeroExpr dflags) - - let hdr_size = fixedHdrSize dflags - - base <- allocHeapClosure rep info_ptr cccsExpr - [ (mkIntExpr dflags n, - hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags) - ] - - arr <- CmmLocal `fmap` newTemp (bWord dflags) - emit $ mkAssign arr base - - dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr) - (smallArrPtrsHdrSize dflags) - src_p <- assignTempE $ cmmOffsetExprW dflags src - (cmmAddWord dflags - (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off) - - emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n)) - (wordAlignment dflags) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- | Takes and offset in the destination array, the base address of --- the card table, and the number of elements affected (*not* the --- number of cards). The number of elements may not be zero. --- Marks the relevant cards as dirty. -emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () -emitSetCards dst_start dst_cards_start n = do - dflags <- getDynFlags - start_card <- assignTempE $ cardCmm dflags dst_start - let end_card = cardCmm dflags - (cmmSubWord dflags - (cmmAddWord dflags dst_start (mkIntExpr dflags n)) - (mkIntExpr dflags 1)) - emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) - (mkIntExpr dflags 1) - (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1)) - (mkAlignment 1) -- no alignment (1 byte) - --- Convert an element index to a card index -cardCmm :: DynFlags -> CmmExpr -> CmmExpr -cardCmm dflags i = - cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)) - ------------------------------------------------------------------------------- --- SmallArray PrimOp implementations - -doReadSmallPtrArrayOp :: LocalReg - -> CmmExpr - -> CmmExpr - -> FCode () -doReadSmallPtrArrayOp res addr idx = do - dflags <- getDynFlags - mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr - (gcWord dflags) idx - -doWriteSmallPtrArrayOp :: CmmExpr - -> CmmExpr - -> CmmExpr - -> FCode () -doWriteSmallPtrArrayOp addr idx val = do - dflags <- getDynFlags - let ty = cmmExprType dflags val - - -- Update remembered set for non-moving collector - tmp <- newTemp ty - mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx - whenUpdRemSetEnabled dflags $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) - - emitPrimCall [] MO_WriteBarrier [] -- #12469 - mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val - emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) - ------------------------------------------------------------------------------- --- Atomic read-modify-write - --- | Emit an atomic modification to a byte array element. The result --- reg contains that previous value of the element. Implies a full --- memory barrier. -doAtomicRMW :: LocalReg -- ^ Result reg - -> AtomicMachOp -- ^ Atomic op (e.g. add) - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Op argument (e.g. amount to add) - -> FCode () -doAtomicRMW res amop mba idx idx_ty n = do - dflags <- getDynFlags - let width = typeWidth idx_ty - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ res ] - (MO_AtomicRMW width amop) - [ addr, n ] - --- | Emit an atomic read to a byte array that acts as a memory barrier. -doAtomicReadByteArray - :: LocalReg -- ^ Result reg - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> FCode () -doAtomicReadByteArray res mba idx idx_ty = do - dflags <- getDynFlags - let width = typeWidth idx_ty - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ res ] - (MO_AtomicRead width) - [ addr ] - --- | Emit an atomic write to a byte array that acts as a memory barrier. -doAtomicWriteByteArray - :: CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Value to write - -> FCode () -doAtomicWriteByteArray mba idx idx_ty val = do - dflags <- getDynFlags - let width = typeWidth idx_ty - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ {- no results -} ] - (MO_AtomicWrite width) - [ addr, val ] - -doCasByteArray - :: LocalReg -- ^ Result reg - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Old value - -> CmmExpr -- ^ New value - -> FCode () -doCasByteArray res mba idx idx_ty old new = do - dflags <- getDynFlags - let width = (typeWidth idx_ty) - addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) - width mba idx - emitPrimCall - [ res ] - (MO_Cmpxchg width) - [ addr, old, new ] - ------------------------------------------------------------------------------- --- Helpers for emitting function calls - --- | Emit a call to @memcpy@. -emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemcpyCall dst src n align = do - emitPrimCall - [ {-no results-} ] - (MO_Memcpy (alignmentBytes align)) - [ dst, src, n ] - --- | Emit a call to @memmove@. -emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemmoveCall dst src n align = do - emitPrimCall - [ {- no results -} ] - (MO_Memmove (alignmentBytes align)) - [ dst, src, n ] - --- | Emit a call to @memset@. The second argument must fit inside an --- unsigned char. -emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemsetCall dst c n align = do - emitPrimCall - [ {- no results -} ] - (MO_Memset (alignmentBytes align)) - [ dst, c, n ] - -emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () -emitMemcmpCall res ptr1 ptr2 n align = do - -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all - -- code-gens currently call out to the @memcmp(3)@ C function. - -- This was easier than moving the sign-extensions into - -- all the code-gens. - dflags <- getDynFlags - let is32Bit = typeWidth (localRegType res) == W32 - - cres <- if is32Bit - then return res - else newTemp b32 - - emitPrimCall - [ cres ] - (MO_Memcmp align) - [ ptr1, ptr2, n ] - - unless is32Bit $ do - emit $ mkAssign (CmmLocal res) - (CmmMachOp - (mo_s_32ToWord dflags) - [(CmmReg (CmmLocal cres))]) - -emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitBSwapCall res x width = do - emitPrimCall - [ res ] - (MO_BSwap width) - [ x ] - -emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitBRevCall res x width = do - emitPrimCall - [ res ] - (MO_BRev width) - [ x ] - -emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitPopCntCall res x width = do - emitPrimCall - [ res ] - (MO_PopCnt width) - [ x ] - -emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () -emitPdepCall res x y width = do - emitPrimCall - [ res ] - (MO_Pdep width) - [ x, y ] - -emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () -emitPextCall res x y width = do - emitPrimCall - [ res ] - (MO_Pext width) - [ x, y ] - -emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitClzCall res x width = do - emitPrimCall - [ res ] - (MO_Clz width) - [ x ] - -emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitCtzCall res x width = do - emitPrimCall - [ res ] - (MO_Ctz width) - [ x ] - ---------------------------------------------------------------------------- --- Pushing to the update remembered set ---------------------------------------------------------------------------- - --- | Push a range of pointer-array elements that are about to be copied over to --- the update remembered set. -emitCopyUpdRemSetPush :: DynFlags - -> ByteOff -- ^ array header size (in bytes) - -> CmmExpr -- ^ destination array - -> CmmExpr -- ^ offset in destination array (in words) - -> Int -- ^ number of elements to copy - -> FCode () -emitCopyUpdRemSetPush _dflags _hdr_size _dst _dst_off 0 = return () -emitCopyUpdRemSetPush dflags hdr_size dst dst_off n = - whenUpdRemSetEnabled dflags $ do - updfr_off <- getUpdFrameOff - graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off [] - emit graph - where - lbl = mkLblExpr $ mkPrimCallLabel - $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId - args = - [ mkIntExpr dflags hdr_size - , dst - , dst_off - , mkIntExpr dflags n +{-# LANGUAGE MultiWayIf #-} + +#if __GLASGOW_HASKELL__ <= 808 +-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it +-- emitPrimOp is quite large +{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-} +#endif + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +---------------------------------------------------------------------------- +-- +-- Stg to C--: primitive operations +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Prim ( + cgOpApp, + shouldInlinePrimOp + ) where + +#include "HsVersions.h" + +import GHC.Prelude hiding ((<*>)) + +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Foreign +import GHC.StgToCmm.Env +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Heap +import GHC.StgToCmm.Prof ( costCentreFrom ) + +import GHC.Driver.Session +import GHC.Platform +import GHC.Types.Basic +import GHC.Cmm.BlockId +import GHC.Cmm.Graph +import GHC.Stg.Syntax +import GHC.Cmm +import GHC.Unit ( rtsUnit ) +import GHC.Core.Type ( Type, tyConAppTyCon ) +import GHC.Core.TyCon +import GHC.Cmm.CLabel +import GHC.Cmm.Utils +import GHC.Builtin.PrimOps +import GHC.Runtime.Heap.Layout +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc +import Data.Maybe + +import Data.Bits ((.&.), bit) +import Control.Monad (liftM, when, unless) + +------------------------------------------------------------------------ +-- Primitive operations and foreign calls +------------------------------------------------------------------------ + +{- Note [Foreign call results] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A foreign call always returns an unboxed tuple of results, one +of which is the state token. This seems to happen even for pure +calls. + +Even if we returned a single result for pure calls, it'd still be +right to wrap it in a singleton unboxed tuple, because the result +might be a Haskell closure pointer, we don't want to evaluate it. -} + +---------------------------------- +cgOpApp :: StgOp -- The op + -> [StgArg] -- Arguments + -> Type -- Result type (always an unboxed tuple) + -> FCode ReturnKind + +-- Foreign calls +cgOpApp (StgFCallOp fcall ty) stg_args res_ty + = cgForeignCall fcall ty stg_args res_ty + -- Note [Foreign call results] + +cgOpApp (StgPrimOp primop) args res_ty = do + dflags <- getDynFlags + cmm_args <- getNonVoidArgAmodes args + cmmPrimOpApp dflags primop cmm_args (Just res_ty) + +cgOpApp (StgPrimCallOp primcall) args _res_ty + = do { cmm_args <- getNonVoidArgAmodes args + ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) + ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } + +cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind +cmmPrimOpApp dflags primop cmm_args mres_ty = + case emitPrimOp dflags primop cmm_args of + PrimopCmmEmit_Internal f -> + let + -- if the result type isn't explicitly given, we directly use the + -- result type of the primop. + res_ty = fromMaybe (primOpResultType primop) mres_ty + in emitReturn =<< f res_ty + PrimopCmmEmit_External -> do + let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) + emitCall (NativeNodeCall, NativeReturn) fun cmm_args + + +-- | Interpret the argument as an unsigned value, assuming the value +-- is given in two-complement form in the given width. +-- +-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615. +-- +-- This function is used to work around the fact that many array +-- primops take Int# arguments, but we interpret them as unsigned +-- quantities in the code gen. This means that we have to be careful +-- every time we work on e.g. a CmmInt literal that corresponds to the +-- array size, as it might contain a negative Integer value if the +-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int# +-- literal. +asUnsigned :: Width -> Integer -> Integer +asUnsigned w n = n .&. (bit (widthInBits w) - 1) + +------------------------------------------------------------------------ +-- Emitting code for a primop +------------------------------------------------------------------------ + +shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool +shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of + PrimopCmmEmit_External -> False + PrimopCmmEmit_Internal _ -> True + +-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use +-- ByteOff (or some other fixed width signed type) to represent +-- array sizes or indices. This means that these will overflow for +-- large enough sizes. + +-- TODO: Several primops, such as 'copyArray#', only have an inline +-- implementation (below) but could possibly have both an inline +-- implementation and an out-of-line implementation, just like +-- 'newArray#'. This would lower the amount of code generated, +-- hopefully without a performance impact (needs to be measured). + +-- | The big function handling all the primops. +-- +-- In the simple case, there is just one implementation, and we emit that. +-- +-- In more complex cases, there is a foreign call (out of line) fallback. This +-- might happen e.g. if there's enough static information, such as statically +-- know arguments. +emitPrimOp + :: DynFlags + -> PrimOp -- ^ The primop + -> [CmmExpr] -- ^ The primop arguments + -> PrimopCmmEmit +emitPrimOp dflags primop = case primop of + NewByteArrayOp_Char -> \case + [(CmmLit (CmmInt n w))] + | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> doNewByteArrayOp res (fromInteger n) + _ -> PrimopCmmEmit_External + + NewArrayOp -> \case + [(CmmLit (CmmInt n w)), init] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel + [ (mkIntExpr platform (fromInteger n), + fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) + , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))), + fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags) + ] + (fromInteger n) init + _ -> PrimopCmmEmit_External + + CopyArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CopyMutableArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CopyArrayArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CopyMutableArrayArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneMutableArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + FreezeArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + ThawArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + NewSmallArrayOp -> \case + [(CmmLit (CmmInt n w)), init] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> + doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel + [ (mkIntExpr platform (fromInteger n), + fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + ] + (fromInteger n) init + _ -> PrimopCmmEmit_External + + CopySmallArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CopySmallMutableArrayOp -> \case + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> + opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneSmallArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + CloneSmallMutableArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + FreezeSmallArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + + ThawSmallArrayOp -> \case + [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + _ -> PrimopCmmEmit_External + +-- First we handle various awkward cases specially. + + ParOp -> \[arg] -> opIntoRegs $ \[res] -> do + -- for now, just implement this in a C function + -- later, we might want to inline it. + emitCCall + [(res,NoHint)] + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) + [(baseExpr, AddrHint), (arg,AddrHint)] + + SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- assignTemp arg + tmp2 <- newTemp (bWord platform) + emitCCall + [(tmp2,NoHint)] + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) + [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) + + GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do + let + val + | sccProfilingEnabled dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit platform) + emitAssign (CmmLocal res) val + + GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) cccsExpr + + MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) currentTSOExpr + + ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform)) + + WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do + old_val <- CmmLocal <$> newTemp (cmmExprType platform var) + emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform)) + + -- Without this write barrier, other CPUs may see this pointer before + -- the writes for the closure it points to have occurred. + -- Note that this also must come after we read the old value to ensure + -- that the read of old_val comes before another core's write to the + -- MutVar's value. + emitPrimCall res MO_WriteBarrier [] + emitStore (cmmOffsetW platform mutv (fixedHdrSizeW dflags)) var + emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] + +-- #define sizzeofByteArrayzh(r,a) \ +-- r = ((StgArrBytes *)(a))->bytes + SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + +-- #define sizzeofMutableByteArrayzh(r,a) \ +-- r = ((StgArrBytes *)(a))->bytes + SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp + +-- #define getSizzeofMutableByteArrayzh(r,a) \ +-- r = ((StgArrBytes *)(a))->bytes + GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + + +-- #define touchzh(o) /* nothing */ + TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> do + emitPrimCall res MO_Touch args + +-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) + ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize dflags)) + +-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) + StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + + ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) + +-- #define addrToHValuezh(r,a) r=(P_)a + AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) arg + +-- #define hvalueToAddrzh(r, a) r=(W_)a + AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) arg + +{- Freezing arrays-of-ptrs requires changing an info table, for the + benefit of the generational collector. It needs to scavenge mutable + objects, even if they are in old space. When they become immutable, + they can be removed from this scavenge list. -} + +-- #define unsafeFreezzeArrayzh(r,a) +-- { +-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info); +-- r = a; +-- } + UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), + mkAssign (CmmLocal res) arg ] + UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), + mkAssign (CmmLocal res) arg ] + UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), + mkAssign (CmmLocal res) arg ] + +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) + UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emitAssign (CmmLocal res) arg + +-- Reading/writing pointer arrays + + ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> do + doWritePtrArrayOp obj ix v + + IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadPtrArrayOp res obj ix + WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + doWritePtrArrayOp obj ix v + WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + doWritePtrArrayOp obj ix v + WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + doWritePtrArrayOp obj ix v + WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + doWritePtrArrayOp obj ix v + + ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadSmallPtrArrayOp res obj ix + IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + doReadSmallPtrArrayOp res obj ix + WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + doWriteSmallPtrArrayOp obj ix v + +-- Getting the size of pointer arrays + + SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg + (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgMutArrPtrs_ptrs dflags)) + (bWord platform)) + SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp + SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp + SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp + SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + emit $ mkAssign (CmmLocal res) + (cmmLoadIndexW platform arg + (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgSmallMutArrPtrs_ptrs dflags)) + (bWord platform)) + + SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp + GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp + +-- IndexXXXoffAddr + + IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args + IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args + IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing f32 res args + IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing f64 res args + IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args + IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args + IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args + IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing b64 res args + IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args + IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args + IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args + IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing b64 res args + +-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. + + ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args + ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args + ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing f32 res args + ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing f64 res args + ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing (bWord platform) res args + ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args + ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args + ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args + ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing b64 res args + ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args + ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args + ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args + ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do + doIndexOffAddrOp Nothing b64 res args + +-- IndexXXXArray + + IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args + IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args + IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing f32 res args + IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing f64 res args + IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args + IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args + IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args + IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing b64 res args + IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args + IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args + IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args + IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing b64 res args + +-- ReadXXXArray, identical to IndexXXXArray. + + ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args + ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args + ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing f32 res args + ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing f64 res args + ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing (bWord platform) res args + ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args + ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args + ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args + ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing b64 res args + ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args + ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args + ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args + ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOp Nothing b64 res args + +-- IndexWord8ArrayAsXXX + + IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing f32 b8 res args + IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing f64 b8 res args + IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args + IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args + IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing b64 b8 res args + IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args + IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing b64 b8 res args + +-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX + + ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing f32 b8 res args + ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing f64 b8 res args + ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing (bWord platform) b8 res args + ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args + ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args + ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing b64 b8 res args + ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args + ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do + doIndexByteArrayOpAs Nothing b64 b8 res args + +-- WriteXXXoffAddr + + WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args + WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args + WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing f32 res args + WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing f64 res args + WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing (bWord platform) res args + WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args + WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args + WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args + WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing b64 res args + WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args + WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args + WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args + WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do + doWriteOffAddrOp Nothing b64 res args + +-- WriteXXXArray + + WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args + WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args + WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing f32 res args + WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing f64 res args + WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing (bWord platform) res args + WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args + WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args + WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args + WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b64 res args + WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args + WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args + WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args + WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b64 res args + +-- WriteInt8ArrayAsXXX + + WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args + WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args + WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args + WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args + WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args + WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args + WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do + doWriteByteArrayOp Nothing b8 res args + +-- Copying and setting byte arrays + CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do + doCopyByteArrayOp src src_off dst dst_off n + CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do + doCopyMutableByteArrayOp src src_off dst dst_off n + CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do + doCopyByteArrayToAddrOp src src_off dst n + CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do + doCopyMutableByteArrayToAddrOp src src_off dst n + CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> do + doCopyAddrToByteArrayOp src dst dst_off n + SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> do + doSetByteArrayOp ba off len c + +-- Comparing byte arrays + CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> do + doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n + + BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> do + emitBSwapCall res w W16 + BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> do + emitBSwapCall res w W32 + BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> do + emitBSwapCall res w W64 + BSwapOp -> \[w] -> opIntoRegs $ \[res] -> do + emitBSwapCall res w (wordWidth platform) + + BRev8Op -> \[w] -> opIntoRegs $ \[res] -> do + emitBRevCall res w W8 + BRev16Op -> \[w] -> opIntoRegs $ \[res] -> do + emitBRevCall res w W16 + BRev32Op -> \[w] -> opIntoRegs $ \[res] -> do + emitBRevCall res w W32 + BRev64Op -> \[w] -> opIntoRegs $ \[res] -> do + emitBRevCall res w W64 + BRevOp -> \[w] -> opIntoRegs $ \[res] -> do + emitBRevCall res w (wordWidth platform) + +-- Population count + PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> do + emitPopCntCall res w W8 + PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> do + emitPopCntCall res w W16 + PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> do + emitPopCntCall res w W32 + PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> do + emitPopCntCall res w W64 + PopCntOp -> \[w] -> opIntoRegs $ \[res] -> do + emitPopCntCall res w (wordWidth platform) + +-- Parallel bit deposit + Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPdepCall res src mask W8 + Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPdepCall res src mask W16 + Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPdepCall res src mask W32 + Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPdepCall res src mask W64 + PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPdepCall res src mask (wordWidth platform) + +-- Parallel bit extract + Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPextCall res src mask W8 + Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPextCall res src mask W16 + Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPextCall res src mask W32 + Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPextCall res src mask W64 + PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> do + emitPextCall res src mask (wordWidth platform) + +-- count leading zeros + Clz8Op -> \[w] -> opIntoRegs $ \[res] -> do + emitClzCall res w W8 + Clz16Op -> \[w] -> opIntoRegs $ \[res] -> do + emitClzCall res w W16 + Clz32Op -> \[w] -> opIntoRegs $ \[res] -> do + emitClzCall res w W32 + Clz64Op -> \[w] -> opIntoRegs $ \[res] -> do + emitClzCall res w W64 + ClzOp -> \[w] -> opIntoRegs $ \[res] -> do + emitClzCall res w (wordWidth platform) + +-- count trailing zeros + Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> do + emitCtzCall res w W8 + Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> do + emitCtzCall res w W16 + Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> do + emitCtzCall res w W32 + Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> do + emitCtzCall res w W64 + CtzOp -> \[w] -> opIntoRegs $ \[res] -> do + emitCtzCall res w (wordWidth platform) + +-- Unsigned int to floating point conversions + Word2FloatOp -> \[w] -> opIntoRegs $ \[res] -> do + emitPrimCall [res] (MO_UF_Conv W32) [w] + Word2DoubleOp -> \[w] -> opIntoRegs $ \[res] -> do + emitPrimCall [res] (MO_UF_Conv W64) [w] + +-- Atomic operations + InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] + InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value] + + CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new] + CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] -> + emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new] + +-- SIMD primops + (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do + checkVecCompatibility dflags vcat n w + doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res + where + zeros :: CmmExpr + zeros = CmmLit $ CmmVec (replicate n zero) + + zero :: CmmLit + zero = case vcat of + IntVec -> CmmInt 0 w + WordVec -> CmmInt 0 w + FloatVec -> CmmFloat 0 w + + ty :: CmmType + ty = vecVmmType vcat n w + + (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do + checkVecCompatibility dflags vcat n w + when (es `lengthIsNot` n) $ + panic "emitPrimOp: VecPackOp has wrong number of arguments" + doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res + where + zeros :: CmmExpr + zeros = CmmLit $ CmmVec (replicate n zero) + + zero :: CmmLit + zero = case vcat of + IntVec -> CmmInt 0 w + WordVec -> CmmInt 0 w + FloatVec -> CmmFloat 0 w + + ty :: CmmType + ty = vecVmmType vcat n w + + (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do + checkVecCompatibility dflags vcat n w + when (res `lengthIsNot` n) $ + panic "emitPrimOp: VecUnpackOp has wrong number of results" + doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do + checkVecCompatibility dflags vcat n w + doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doWriteByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doWriteOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecVmmType vcat n w + + (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doWriteByteArrayOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmCat vcat w + + (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOpAs Nothing vecty ty res0 args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + + (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do + checkVecCompatibility dflags vcat n w + doWriteOffAddrOp Nothing ty res0 args + where + ty :: CmmType + ty = vecCmmCat vcat w + +-- Prefetch + PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do + doPrefetchByteArrayOp 3 args + PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do + doPrefetchMutableByteArrayOp 3 args + PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> do + doPrefetchAddrOp 3 args + PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> do + doPrefetchValueOp 3 args + + PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do + doPrefetchByteArrayOp 2 args + PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do + doPrefetchMutableByteArrayOp 2 args + PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> do + doPrefetchAddrOp 2 args + PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> do + doPrefetchValueOp 2 args + PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do + doPrefetchByteArrayOp 1 args + PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do + doPrefetchMutableByteArrayOp 1 args + PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> do + doPrefetchAddrOp 1 args + PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> do + doPrefetchValueOp 1 args + + PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do + doPrefetchByteArrayOp 0 args + PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do + doPrefetchMutableByteArrayOp 0 args + PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> do + doPrefetchAddrOp 0 args + PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> do + doPrefetchValueOp 0 args + +-- Atomic read-modify-write + FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + doAtomicRMW res AMO_Add mba ix (bWord platform) n + FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + doAtomicRMW res AMO_Sub mba ix (bWord platform) n + FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + doAtomicRMW res AMO_And mba ix (bWord platform) n + FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + doAtomicRMW res AMO_Nand mba ix (bWord platform) n + FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + doAtomicRMW res AMO_Or mba ix (bWord platform) n + FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + doAtomicRMW res AMO_Xor mba ix (bWord platform) n + AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> do + doAtomicReadByteArray res mba ix (bWord platform) + AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> do + doAtomicWriteByteArray mba ix (bWord platform) val + CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> do + doCasByteArray res mba ix (bWord platform) old new + +-- The rest just translate straightforwardly + + Int2WordOp -> \args -> opNop args + Word2IntOp -> \args -> opNop args + Int2AddrOp -> \args -> opNop args + Addr2IntOp -> \args -> opNop args + ChrOp -> \args -> opNop args -- Int# and Char# are rep'd the same + OrdOp -> \args -> opNop args + + Narrow8IntOp -> \args -> opNarrow args (MO_SS_Conv, W8) + Narrow16IntOp -> \args -> opNarrow args (MO_SS_Conv, W16) + Narrow32IntOp -> \args -> opNarrow args (MO_SS_Conv, W32) + Narrow8WordOp -> \args -> opNarrow args (MO_UU_Conv, W8) + Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16) + Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32) + + DoublePowerOp -> \args -> opCallish args MO_F64_Pwr + DoubleSinOp -> \args -> opCallish args MO_F64_Sin + DoubleCosOp -> \args -> opCallish args MO_F64_Cos + DoubleTanOp -> \args -> opCallish args MO_F64_Tan + DoubleSinhOp -> \args -> opCallish args MO_F64_Sinh + DoubleCoshOp -> \args -> opCallish args MO_F64_Cosh + DoubleTanhOp -> \args -> opCallish args MO_F64_Tanh + DoubleAsinOp -> \args -> opCallish args MO_F64_Asin + DoubleAcosOp -> \args -> opCallish args MO_F64_Acos + DoubleAtanOp -> \args -> opCallish args MO_F64_Atan + DoubleAsinhOp -> \args -> opCallish args MO_F64_Asinh + DoubleAcoshOp -> \args -> opCallish args MO_F64_Acosh + DoubleAtanhOp -> \args -> opCallish args MO_F64_Atanh + DoubleLogOp -> \args -> opCallish args MO_F64_Log + DoubleLog1POp -> \args -> opCallish args MO_F64_Log1P + DoubleExpOp -> \args -> opCallish args MO_F64_Exp + DoubleExpM1Op -> \args -> opCallish args MO_F64_ExpM1 + DoubleSqrtOp -> \args -> opCallish args MO_F64_Sqrt + + FloatPowerOp -> \args -> opCallish args MO_F32_Pwr + FloatSinOp -> \args -> opCallish args MO_F32_Sin + FloatCosOp -> \args -> opCallish args MO_F32_Cos + FloatTanOp -> \args -> opCallish args MO_F32_Tan + FloatSinhOp -> \args -> opCallish args MO_F32_Sinh + FloatCoshOp -> \args -> opCallish args MO_F32_Cosh + FloatTanhOp -> \args -> opCallish args MO_F32_Tanh + FloatAsinOp -> \args -> opCallish args MO_F32_Asin + FloatAcosOp -> \args -> opCallish args MO_F32_Acos + FloatAtanOp -> \args -> opCallish args MO_F32_Atan + FloatAsinhOp -> \args -> opCallish args MO_F32_Asinh + FloatAcoshOp -> \args -> opCallish args MO_F32_Acosh + FloatAtanhOp -> \args -> opCallish args MO_F32_Atanh + FloatLogOp -> \args -> opCallish args MO_F32_Log + FloatLog1POp -> \args -> opCallish args MO_F32_Log1P + FloatExpOp -> \args -> opCallish args MO_F32_Exp + FloatExpM1Op -> \args -> opCallish args MO_F32_ExpM1 + FloatSqrtOp -> \args -> opCallish args MO_F32_Sqrt + +-- Native word signless ops + + IntAddOp -> \args -> opTranslate args (mo_wordAdd platform) + IntSubOp -> \args -> opTranslate args (mo_wordSub platform) + WordAddOp -> \args -> opTranslate args (mo_wordAdd platform) + WordSubOp -> \args -> opTranslate args (mo_wordSub platform) + AddrAddOp -> \args -> opTranslate args (mo_wordAdd platform) + AddrSubOp -> \args -> opTranslate args (mo_wordSub platform) + + IntEqOp -> \args -> opTranslate args (mo_wordEq platform) + IntNeOp -> \args -> opTranslate args (mo_wordNe platform) + WordEqOp -> \args -> opTranslate args (mo_wordEq platform) + WordNeOp -> \args -> opTranslate args (mo_wordNe platform) + AddrEqOp -> \args -> opTranslate args (mo_wordEq platform) + AddrNeOp -> \args -> opTranslate args (mo_wordNe platform) + + AndOp -> \args -> opTranslate args (mo_wordAnd platform) + OrOp -> \args -> opTranslate args (mo_wordOr platform) + XorOp -> \args -> opTranslate args (mo_wordXor platform) + NotOp -> \args -> opTranslate args (mo_wordNot platform) + SllOp -> \args -> opTranslate args (mo_wordShl platform) + SrlOp -> \args -> opTranslate args (mo_wordUShr platform) + + AddrRemOp -> \args -> opTranslate args (mo_wordURem platform) + +-- Native word signed ops + + IntMulOp -> \args -> opTranslate args (mo_wordMul platform) + IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth platform)) + IntQuotOp -> \args -> opTranslate args (mo_wordSQuot platform) + IntRemOp -> \args -> opTranslate args (mo_wordSRem platform) + IntNegOp -> \args -> opTranslate args (mo_wordSNeg platform) + + IntGeOp -> \args -> opTranslate args (mo_wordSGe platform) + IntLeOp -> \args -> opTranslate args (mo_wordSLe platform) + IntGtOp -> \args -> opTranslate args (mo_wordSGt platform) + IntLtOp -> \args -> opTranslate args (mo_wordSLt platform) + + AndIOp -> \args -> opTranslate args (mo_wordAnd platform) + OrIOp -> \args -> opTranslate args (mo_wordOr platform) + XorIOp -> \args -> opTranslate args (mo_wordXor platform) + NotIOp -> \args -> opTranslate args (mo_wordNot platform) + ISllOp -> \args -> opTranslate args (mo_wordShl platform) + ISraOp -> \args -> opTranslate args (mo_wordSShr platform) + ISrlOp -> \args -> opTranslate args (mo_wordUShr platform) + +-- Native word unsigned ops + + WordGeOp -> \args -> opTranslate args (mo_wordUGe platform) + WordLeOp -> \args -> opTranslate args (mo_wordULe platform) + WordGtOp -> \args -> opTranslate args (mo_wordUGt platform) + WordLtOp -> \args -> opTranslate args (mo_wordULt platform) + + WordMulOp -> \args -> opTranslate args (mo_wordMul platform) + WordQuotOp -> \args -> opTranslate args (mo_wordUQuot platform) + WordRemOp -> \args -> opTranslate args (mo_wordURem platform) + + AddrGeOp -> \args -> opTranslate args (mo_wordUGe platform) + AddrLeOp -> \args -> opTranslate args (mo_wordULe platform) + AddrGtOp -> \args -> opTranslate args (mo_wordUGt platform) + AddrLtOp -> \args -> opTranslate args (mo_wordULt platform) + +-- Int8# signed ops + + Int8Extend -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform)) + Int8Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8) + Int8NegOp -> \args -> opTranslate args (MO_S_Neg W8) + Int8AddOp -> \args -> opTranslate args (MO_Add W8) + Int8SubOp -> \args -> opTranslate args (MO_Sub W8) + Int8MulOp -> \args -> opTranslate args (MO_Mul W8) + Int8QuotOp -> \args -> opTranslate args (MO_S_Quot W8) + Int8RemOp -> \args -> opTranslate args (MO_S_Rem W8) + + Int8EqOp -> \args -> opTranslate args (MO_Eq W8) + Int8GeOp -> \args -> opTranslate args (MO_S_Ge W8) + Int8GtOp -> \args -> opTranslate args (MO_S_Gt W8) + Int8LeOp -> \args -> opTranslate args (MO_S_Le W8) + Int8LtOp -> \args -> opTranslate args (MO_S_Lt W8) + Int8NeOp -> \args -> opTranslate args (MO_Ne W8) + +-- Word8# unsigned ops + + Word8Extend -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform)) + Word8Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8) + Word8NotOp -> \args -> opTranslate args (MO_Not W8) + Word8AddOp -> \args -> opTranslate args (MO_Add W8) + Word8SubOp -> \args -> opTranslate args (MO_Sub W8) + Word8MulOp -> \args -> opTranslate args (MO_Mul W8) + Word8QuotOp -> \args -> opTranslate args (MO_U_Quot W8) + Word8RemOp -> \args -> opTranslate args (MO_U_Rem W8) + + Word8EqOp -> \args -> opTranslate args (MO_Eq W8) + Word8GeOp -> \args -> opTranslate args (MO_U_Ge W8) + Word8GtOp -> \args -> opTranslate args (MO_U_Gt W8) + Word8LeOp -> \args -> opTranslate args (MO_U_Le W8) + Word8LtOp -> \args -> opTranslate args (MO_U_Lt W8) + Word8NeOp -> \args -> opTranslate args (MO_Ne W8) + +-- Int16# signed ops + + Int16Extend -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform)) + Int16Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16) + Int16NegOp -> \args -> opTranslate args (MO_S_Neg W16) + Int16AddOp -> \args -> opTranslate args (MO_Add W16) + Int16SubOp -> \args -> opTranslate args (MO_Sub W16) + Int16MulOp -> \args -> opTranslate args (MO_Mul W16) + Int16QuotOp -> \args -> opTranslate args (MO_S_Quot W16) + Int16RemOp -> \args -> opTranslate args (MO_S_Rem W16) + + Int16EqOp -> \args -> opTranslate args (MO_Eq W16) + Int16GeOp -> \args -> opTranslate args (MO_S_Ge W16) + Int16GtOp -> \args -> opTranslate args (MO_S_Gt W16) + Int16LeOp -> \args -> opTranslate args (MO_S_Le W16) + Int16LtOp -> \args -> opTranslate args (MO_S_Lt W16) + Int16NeOp -> \args -> opTranslate args (MO_Ne W16) + +-- Word16# unsigned ops + + Word16Extend -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform)) + Word16Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16) + Word16NotOp -> \args -> opTranslate args (MO_Not W16) + Word16AddOp -> \args -> opTranslate args (MO_Add W16) + Word16SubOp -> \args -> opTranslate args (MO_Sub W16) + Word16MulOp -> \args -> opTranslate args (MO_Mul W16) + Word16QuotOp -> \args -> opTranslate args (MO_U_Quot W16) + Word16RemOp -> \args -> opTranslate args (MO_U_Rem W16) + + Word16EqOp -> \args -> opTranslate args (MO_Eq W16) + Word16GeOp -> \args -> opTranslate args (MO_U_Ge W16) + Word16GtOp -> \args -> opTranslate args (MO_U_Gt W16) + Word16LeOp -> \args -> opTranslate args (MO_U_Le W16) + Word16LtOp -> \args -> opTranslate args (MO_U_Lt W16) + Word16NeOp -> \args -> opTranslate args (MO_Ne W16) + +-- Char# ops + + CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth platform)) + CharNeOp -> \args -> opTranslate args (MO_Ne (wordWidth platform)) + CharGeOp -> \args -> opTranslate args (MO_U_Ge (wordWidth platform)) + CharLeOp -> \args -> opTranslate args (MO_U_Le (wordWidth platform)) + CharGtOp -> \args -> opTranslate args (MO_U_Gt (wordWidth platform)) + CharLtOp -> \args -> opTranslate args (MO_U_Lt (wordWidth platform)) + +-- Double ops + + DoubleEqOp -> \args -> opTranslate args (MO_F_Eq W64) + DoubleNeOp -> \args -> opTranslate args (MO_F_Ne W64) + DoubleGeOp -> \args -> opTranslate args (MO_F_Ge W64) + DoubleLeOp -> \args -> opTranslate args (MO_F_Le W64) + DoubleGtOp -> \args -> opTranslate args (MO_F_Gt W64) + DoubleLtOp -> \args -> opTranslate args (MO_F_Lt W64) + + DoubleAddOp -> \args -> opTranslate args (MO_F_Add W64) + DoubleSubOp -> \args -> opTranslate args (MO_F_Sub W64) + DoubleMulOp -> \args -> opTranslate args (MO_F_Mul W64) + DoubleDivOp -> \args -> opTranslate args (MO_F_Quot W64) + DoubleNegOp -> \args -> opTranslate args (MO_F_Neg W64) + +-- Float ops + + FloatEqOp -> \args -> opTranslate args (MO_F_Eq W32) + FloatNeOp -> \args -> opTranslate args (MO_F_Ne W32) + FloatGeOp -> \args -> opTranslate args (MO_F_Ge W32) + FloatLeOp -> \args -> opTranslate args (MO_F_Le W32) + FloatGtOp -> \args -> opTranslate args (MO_F_Gt W32) + FloatLtOp -> \args -> opTranslate args (MO_F_Lt W32) + + FloatAddOp -> \args -> opTranslate args (MO_F_Add W32) + FloatSubOp -> \args -> opTranslate args (MO_F_Sub W32) + FloatMulOp -> \args -> opTranslate args (MO_F_Mul W32) + FloatDivOp -> \args -> opTranslate args (MO_F_Quot W32) + FloatNegOp -> \args -> opTranslate args (MO_F_Neg W32) + +-- Vector ops + + (VecAddOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Add n w) + (VecSubOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub n w) + (VecMulOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul n w) + (VecDivOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w) + (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop" + (VecRemOp FloatVec _ _) -> \_ -> panic "unsupported primop" + (VecNegOp FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg n w) + + (VecAddOp IntVec n w) -> \args -> opTranslate args (MO_V_Add n w) + (VecSubOp IntVec n w) -> \args -> opTranslate args (MO_V_Sub n w) + (VecMulOp IntVec n w) -> \args -> opTranslate args (MO_V_Mul n w) + (VecDivOp IntVec _ _) -> \_ -> panic "unsupported primop" + (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w) + (VecRemOp IntVec n w) -> \args -> opTranslate args (MO_VS_Rem n w) + (VecNegOp IntVec n w) -> \args -> opTranslate args (MO_VS_Neg n w) + + (VecAddOp WordVec n w) -> \args -> opTranslate args (MO_V_Add n w) + (VecSubOp WordVec n w) -> \args -> opTranslate args (MO_V_Sub n w) + (VecMulOp WordVec n w) -> \args -> opTranslate args (MO_V_Mul n w) + (VecDivOp WordVec _ _) -> \_ -> panic "unsupported primop" + (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w) + (VecRemOp WordVec n w) -> \args -> opTranslate args (MO_VU_Rem n w) + (VecNegOp WordVec _ _) -> \_ -> panic "unsupported primop" + +-- Conversions + + Int2DoubleOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64) + Double2IntOp -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform)) + + Int2FloatOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32) + Float2IntOp -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform)) + + Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64) + Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) + +-- Word comparisons masquerading as more exotic things. + + SameMutVarOp -> \args -> opTranslate args (mo_wordEq platform) + SameMVarOp -> \args -> opTranslate args (mo_wordEq platform) + SameIOPortOp -> \args -> opTranslate args (mo_wordEq platform) + SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) + SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq platform) + SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform) + SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) + SameTVarOp -> \args -> opTranslate args (mo_wordEq platform) + EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform) +-- See Note [Comparing stable names] + EqStableNameOp -> \args -> opTranslate args (mo_wordEq platform) + + IntQuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem (wordWidth platform)) + else Right (genericIntQuotRemOp (wordWidth platform)) + + Int8QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W8) + else Right (genericIntQuotRemOp W8) + + Int16QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W16) + else Right (genericIntQuotRemOp W16) + + WordQuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem (wordWidth platform)) + else Right (genericWordQuotRemOp (wordWidth platform)) + + WordQuotRem2Op -> \args -> opCallishHandledLater args $ + if (ncg && (x86ish || ppc)) || llvm + then Left (MO_U_QuotRem2 (wordWidth platform)) + else Right (genericWordQuotRem2Op platform) + + Word8QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W8) + else Right (genericWordQuotRemOp W8) + + Word16QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W16) + else Right (genericWordQuotRemOp W16) + + WordAdd2Op -> \args -> opCallishHandledLater args $ + if (ncg && (x86ish || ppc)) || llvm + then Left (MO_Add2 (wordWidth platform)) + else Right genericWordAdd2Op + + WordAddCOp -> \args -> opCallishHandledLater args $ + if (ncg && (x86ish || ppc)) || llvm + then Left (MO_AddWordC (wordWidth platform)) + else Right genericWordAddCOp + + WordSubCOp -> \args -> opCallishHandledLater args $ + if (ncg && (x86ish || ppc)) || llvm + then Left (MO_SubWordC (wordWidth platform)) + else Right genericWordSubCOp + + IntAddCOp -> \args -> opCallishHandledLater args $ + if (ncg && (x86ish || ppc)) || llvm + then Left (MO_AddIntC (wordWidth platform)) + else Right genericIntAddCOp + + IntSubCOp -> \args -> opCallishHandledLater args $ + if (ncg && (x86ish || ppc)) || llvm + then Left (MO_SubIntC (wordWidth platform)) + else Right genericIntSubCOp + + WordMul2Op -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) || llvm + then Left (MO_U_Mul2 (wordWidth platform)) + else Right genericWordMul2Op + + IntMul2Op -> \args -> opCallishHandledLater args $ + if ncg && x86ish || llvm + then Left (MO_S_Mul2 (wordWidth platform)) + else Right genericIntMul2Op + + FloatFabsOp -> \args -> opCallishHandledLater args $ + if (ncg && x86ish || ppc) || llvm + then Left MO_F32_Fabs + else Right $ genericFabsOp W32 + + DoubleFabsOp -> \args -> opCallishHandledLater args $ + if (ncg && x86ish || ppc) || llvm + then Left MO_F64_Fabs + else Right $ genericFabsOp W64 + + -- tagToEnum# is special: we need to pull the constructor + -- out of the table, and perform an appropriate return. + TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do + -- If you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- That won't work. + let tycon = tyConAppTyCon res_ty + MASSERT(isEnumerationTyCon tycon) + platform <- getPlatform + pure [tagToClosure platform tycon amode] + +-- Out of line primops. +-- TODO compiler need not know about these + + UnsafeThawArrayOp -> alwaysExternal + CasArrayOp -> alwaysExternal + UnsafeThawSmallArrayOp -> alwaysExternal + CasSmallArrayOp -> alwaysExternal + NewPinnedByteArrayOp_Char -> alwaysExternal + NewAlignedPinnedByteArrayOp_Char -> alwaysExternal + MutableByteArrayIsPinnedOp -> alwaysExternal + DoubleDecode_2IntOp -> alwaysExternal + DoubleDecode_Int64Op -> alwaysExternal + FloatDecode_IntOp -> alwaysExternal + ByteArrayIsPinnedOp -> alwaysExternal + ShrinkMutableByteArrayOp_Char -> alwaysExternal + ResizeMutableByteArrayOp_Char -> alwaysExternal + ShrinkSmallMutableArrayOp_Char -> alwaysExternal + NewArrayArrayOp -> alwaysExternal + NewMutVarOp -> alwaysExternal + AtomicModifyMutVar2Op -> alwaysExternal + AtomicModifyMutVar_Op -> alwaysExternal + CasMutVarOp -> alwaysExternal + CatchOp -> alwaysExternal + RaiseOp -> alwaysExternal + RaiseIOOp -> alwaysExternal + MaskAsyncExceptionsOp -> alwaysExternal + MaskUninterruptibleOp -> alwaysExternal + UnmaskAsyncExceptionsOp -> alwaysExternal + MaskStatus -> alwaysExternal + AtomicallyOp -> alwaysExternal + RetryOp -> alwaysExternal + CatchRetryOp -> alwaysExternal + CatchSTMOp -> alwaysExternal + NewTVarOp -> alwaysExternal + ReadTVarOp -> alwaysExternal + ReadTVarIOOp -> alwaysExternal + WriteTVarOp -> alwaysExternal + NewMVarOp -> alwaysExternal + TakeMVarOp -> alwaysExternal + TryTakeMVarOp -> alwaysExternal + PutMVarOp -> alwaysExternal + TryPutMVarOp -> alwaysExternal + ReadMVarOp -> alwaysExternal + TryReadMVarOp -> alwaysExternal + IsEmptyMVarOp -> alwaysExternal + NewIOPortrOp -> alwaysExternal + ReadIOPortOp -> alwaysExternal + WriteIOPortOp -> alwaysExternal + DelayOp -> alwaysExternal + WaitReadOp -> alwaysExternal + WaitWriteOp -> alwaysExternal + ForkOp -> alwaysExternal + ForkOnOp -> alwaysExternal + KillThreadOp -> alwaysExternal + YieldOp -> alwaysExternal + LabelThreadOp -> alwaysExternal + IsCurrentThreadBoundOp -> alwaysExternal + NoDuplicateOp -> alwaysExternal + ThreadStatusOp -> alwaysExternal + MkWeakOp -> alwaysExternal + MkWeakNoFinalizerOp -> alwaysExternal + AddCFinalizerToWeakOp -> alwaysExternal + DeRefWeakOp -> alwaysExternal + FinalizeWeakOp -> alwaysExternal + MakeStablePtrOp -> alwaysExternal + DeRefStablePtrOp -> alwaysExternal + MakeStableNameOp -> alwaysExternal + CompactNewOp -> alwaysExternal + CompactResizeOp -> alwaysExternal + CompactContainsOp -> alwaysExternal + CompactContainsAnyOp -> alwaysExternal + CompactGetFirstBlockOp -> alwaysExternal + CompactGetNextBlockOp -> alwaysExternal + CompactAllocateBlockOp -> alwaysExternal + CompactFixupPointersOp -> alwaysExternal + CompactAdd -> alwaysExternal + CompactAddWithSharing -> alwaysExternal + CompactSize -> alwaysExternal + SeqOp -> alwaysExternal + GetSparkOp -> alwaysExternal + NumSparks -> alwaysExternal + DataToTagOp -> alwaysExternal + MkApUpd0_Op -> alwaysExternal + NewBCOOp -> alwaysExternal + UnpackClosureOp -> alwaysExternal + ClosureSizeOp -> alwaysExternal + GetApStackValOp -> alwaysExternal + ClearCCSOp -> alwaysExternal + TraceEventOp -> alwaysExternal + TraceEventBinaryOp -> alwaysExternal + TraceMarkerOp -> alwaysExternal + SetThreadAllocationCounter -> alwaysExternal + + -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep. + KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep" + + where + platform = targetPlatform dflags + result_info = getPrimOpResultInfo primop + + opNop :: [CmmExpr] -> PrimopCmmEmit + opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg + where [arg] = args + + opNarrow + :: [CmmExpr] + -> (Width -> Width -> MachOp, Width) + -> PrimopCmmEmit + opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $ + CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]] + where [arg] = args + + -- | These primops are implemented by CallishMachOps, because they sometimes + -- turn into foreign calls depending on the backend. + opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit + opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args + + opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit + opTranslate args mop = opIntoRegs $ \[res] -> do + let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) + emit stmt + + -- | Basically a "manual" case, rather than one of the common repetitive forms + -- above. The results are a parameter to the returned function so we know the + -- choice of variant never depends on them. + opCallishHandledLater + :: [CmmExpr] + -> Either CallishMachOp GenericOp + -> PrimopCmmEmit + opCallishHandledLater args callOrNot = opIntoRegs $ \res0 -> case callOrNot of + Left op -> emit $ mkUnsafeCall (PrimTarget op) res0 args + Right gen -> gen res0 args + + opIntoRegs + :: ([LocalReg] -- where to put the results + -> FCode ()) + -> PrimopCmmEmit + opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do + regs <- if + | ReturnsPrim VoidRep <- result_info + -> pure [] + + | ReturnsPrim rep <- result_info + -> do reg <- newTemp (primRepCmmType platform rep) + pure [reg] + + | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon + -> do (regs, _hints) <- newUnboxedTupleRegs res_ty + pure regs + + | otherwise -> panic "cgOpApp" + f regs + pure $ map (CmmReg . CmmLocal) regs + + alwaysExternal = \_ -> PrimopCmmEmit_External + -- Note [QuotRem optimization] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- + -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops + -- (shift, .&.). + -- + -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the + -- constant is a power of 2. #9041 tracks the implementation of the general + -- optimization. + -- + -- `quotRem` can be optimized in the same way. However as it returns two values, + -- it is implemented as a "callish" primop which is harder to match and + -- to transform later on. For simplicity, the current implementation detects cases + -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem + -- primop into two CMM quot and rem primops. + quotRemCanBeOptimized = \case + [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n) + _ -> False + + ncg = case hscTarget dflags of + HscAsm -> True + _ -> False + llvm = case hscTarget dflags of + HscLlvm -> True + _ -> False + x86ish = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + _ -> False + ppc = case platformArch platform of + ArchPPC -> True + ArchPPC_64 _ -> True + _ -> False + +data PrimopCmmEmit + -- | Out of line fake primop that's actually just a foreign call to other + -- (presumably) C--. + = PrimopCmmEmit_External + -- | Real primop turned into inline C--. + | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it + -> FCode [CmmExpr]) -- just for TagToEnum for now + +type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () + +genericIntQuotRemOp :: Width -> GenericOp +genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem width) [arg_x, arg_y]) +genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" + +genericWordQuotRemOp :: Width -> GenericOp +genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem width) [arg_x, arg_y]) +genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" + +genericWordQuotRem2Op :: Platform -> GenericOp +genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y] + = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low + where ty = cmmExprType platform arg_x_high + shl x i = CmmMachOp (MO_Shl (wordWidth platform)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth platform)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth platform)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth platform)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y] + zero = lit 0 + one = lit 1 + negone = lit (fromIntegral (platformWordSizeInBits platform) - 1) + lit i = CmmLit (CmmInt i (wordWidth platform)) + + f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph + f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> + mkAssign (CmmLocal res_r) high) + f i acc high low = + do roverflowedBit <- newTemp ty + rhigh' <- newTemp ty + rhigh'' <- newTemp ty + rlow' <- newTemp ty + risge <- newTemp ty + racc' <- newTemp ty + let high' = CmmReg (CmmLocal rhigh') + isge = CmmReg (CmmLocal risge) + overflowedBit = CmmReg (CmmLocal roverflowedBit) + let this = catAGraphs + [mkAssign (CmmLocal roverflowedBit) + (shr high negone), + mkAssign (CmmLocal rhigh') + (or (shl high one) (shr low negone)), + mkAssign (CmmLocal rlow') + (shl low one), + mkAssign (CmmLocal risge) + (or (overflowedBit `ne` zero) + (high' `ge` arg_y)), + mkAssign (CmmLocal rhigh'') + (high' `minus` (arg_y `times` isge)), + mkAssign (CmmLocal racc') + (or (shl acc one) isge)] + rest <- f (i - 1) (CmmReg (CmmLocal racc')) + (CmmReg (CmmLocal rhigh'')) + (CmmReg (CmmLocal rlow')) + return (this <*> rest) +genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op" + +genericWordAdd2Op :: GenericOp +genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] + = do platform <- getPlatform + r1 <- newTemp (cmmExprType platform arg_x) + r2 <- newTemp (cmmExprType platform arg_x) + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform))) + (wordWidth platform)) + hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform)) + emit $ catAGraphs + [mkAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + mkAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + mkAssign (CmmLocal res_l) + (or (toTopHalf (CmmReg (CmmLocal r2))) + (bottomHalf (CmmReg (CmmLocal r1))))] +genericWordAdd2Op _ _ = panic "genericWordAdd2Op" + +-- | Implements branchless recovery of the carry flag @c@ by checking the +-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@: +-- +-- @ +-- c = a&b | (a|b)&~r +-- @ +-- +-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ +genericWordAddCOp :: GenericOp +genericWordAddCOp [res_r, res_c] [aa, bb] + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordAnd platform) [aa,bb], + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordOr platform) [aa,bb], + CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)] + ] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericWordAddCOp _ _ = panic "genericWordAddCOp" + +-- | Implements branchless recovery of the carry flag @c@ by checking the +-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@: +-- +-- @ +-- c = ~a&b | (~a|b)&r +-- @ +-- +-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ +genericWordSubCOp :: GenericOp +genericWordSubCOp [res_r, res_c] [aa, bb] + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordNot platform) [aa], + bb + ], + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordNot platform) [aa], + bb + ], + CmmReg (CmmLocal res_r) + ] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericWordSubCOp _ _ = panic "genericWordSubCOp" + +genericIntAddCOp :: GenericOp +genericIntAddCOp [res_r, res_c] [aa, bb] +{- + With some bit-twiddling, we can define int{Add,Sub}Czh portably in + C, and without needing any comparisons. This may not be the + fastest way to do it - if you have better code, please send it! --SDM + + Return : r = a + b, c = 0 if no overflow, 1 on overflow. + + We currently don't make use of the r value if c is != 0 (i.e. + overflow), we just convert to big integers and try again. This + could be improved by making r and c the correct values for + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + Wading through the mass of bracketry, it seems to reduce to: + c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) + +-} + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]], + CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericIntAddCOp _ _ = panic "genericIntAddCOp" + +genericIntSubCOp :: GenericOp +genericIntSubCOp [res_r, res_c] [aa, bb] +{- Similarly: + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + + c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) +-} + = do platform <- getPlatform + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr platform) [ + CmmMachOp (mo_wordAnd platform) [ + CmmMachOp (mo_wordXor platform) [aa,bb], + CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr platform (platformWordSizeInBits platform - 1) + ] + ] +genericIntSubCOp _ _ = panic "genericIntSubCOp" + +genericWordMul2Op :: GenericOp +genericWordMul2Op [res_h, res_l] [arg_x, arg_y] + = do platform <- getPlatform + let t = cmmExprType platform arg_x + xlyl <- liftM CmmLocal $ newTemp t + xlyh <- liftM CmmLocal $ newTemp t + xhyl <- liftM CmmLocal $ newTemp t + r <- liftM CmmLocal $ newTemp t + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform))) + (wordWidth platform)) + hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform)) + emit $ catAGraphs + [mkAssign xlyl + (mul (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign xlyh + (mul (bottomHalf arg_x) (topHalf arg_y)), + mkAssign xhyl + (mul (topHalf arg_x) (bottomHalf arg_y)), + mkAssign r + (sum [topHalf (CmmReg xlyl), + bottomHalf (CmmReg xhyl), + bottomHalf (CmmReg xlyh)]), + mkAssign (CmmLocal res_l) + (or (bottomHalf (CmmReg xlyl)) + (toTopHalf (CmmReg r))), + mkAssign (CmmLocal res_h) + (sum [mul (topHalf arg_x) (topHalf arg_y), + topHalf (CmmReg xhyl), + topHalf (CmmReg xlyh), + topHalf (CmmReg r)])] +genericWordMul2Op _ _ = panic "genericWordMul2Op" + +genericIntMul2Op :: GenericOp +genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y] + = do dflags <- getDynFlags + platform <- getPlatform + -- Implement algorithm from Hacker's Delight, 2nd edition, p.174 + let t = cmmExprType platform arg_x + p <- newTemp t + -- 1) compute the multiplication as if numbers were unsigned + _ <- withSequel (AssignTo [p, res_l] False) $ + cmmPrimOpApp dflags WordMul2Op both_args Nothing + -- 2) correct the high bits of the unsigned result + let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1] + sub x y = CmmMachOp (MO_Sub ww) [x, y] + and x y = CmmMachOp (MO_And ww) [x, y] + neq x y = CmmMachOp (MO_Ne ww) [x, y] + f x y = (carryFill x) `and` y + wwm1 = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww) + rl x = CmmReg (CmmLocal x) + ww = wordWidth platform + emit $ catAGraphs + [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x) + , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l)) + ] +genericIntMul2Op _ _ = panic "genericIntMul2Op" + +-- This replicates what we had in libraries/base/GHC/Float.hs: +-- +-- abs x | x == 0 = 0 -- handles (-0.0) +-- | x > 0 = x +-- | otherwise = negateFloat x +genericFabsOp :: Width -> GenericOp +genericFabsOp w [res_r] [aa] + = do platform <- getPlatform + let zero = CmmLit (CmmFloat 0 w) + + eq x y = CmmMachOp (MO_F_Eq w) [x, y] + gt x y = CmmMachOp (MO_F_Gt w) [x, y] + + neg x = CmmMachOp (MO_F_Neg w) [x] + + g1 = catAGraphs [mkAssign (CmmLocal res_r) zero] + g2 = catAGraphs [mkAssign (CmmLocal res_r) aa] + + res_t <- CmmLocal <$> newTemp (cmmExprType platform aa) + let g3 = catAGraphs [mkAssign res_t aa, + mkAssign (CmmLocal res_r) (neg (CmmReg res_t))] + + g4 <- mkCmmIfThenElse (gt aa zero) g2 g3 + + emit =<< mkCmmIfThenElse (eq aa zero) g1 g4 + +genericFabsOp _ _ _ = panic "genericFabsOp" + +-- Note [Comparing stable names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A StableName# is actually a pointer to a stable name object (SNO) +-- containing an index into the stable name table (SNT). We +-- used to compare StableName#s by following the pointers to the +-- SNOs and checking whether they held the same SNT indices. However, +-- this is not necessary: there is a one-to-one correspondence +-- between SNOs and entries in the SNT, so simple pointer equality +-- does the trick. + +------------------------------------------------------------------------------ +-- Helpers for translating various minor variants of array indexing. + +doIndexOffAddrOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx +doIndexOffAddrOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" + +doIndexOffAddrOpAs :: Maybe MachOp + -> CmmType + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] + = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx +doIndexOffAddrOpAs _ _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" + +doIndexByteArrayOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] + = do dflags <- getDynFlags + mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx +doIndexByteArrayOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" + +doIndexByteArrayOpAs :: Maybe MachOp + -> CmmType + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] + = do dflags <- getDynFlags + mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx +doIndexByteArrayOpAs _ _ _ _ _ + = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" + +doReadPtrArrayOp :: LocalReg + -> CmmExpr + -> CmmExpr + -> FCode () +doReadPtrArrayOp res addr idx + = do dflags <- getDynFlags + platform <- getPlatform + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord platform) res addr (gcWord platform) idx + +doWriteOffAddrOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val] + = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val +doWriteOffAddrOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" + +doWriteByteArrayOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] + = do dflags <- getDynFlags + mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val +doWriteByteArrayOp _ _ _ _ + = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" + +doWritePtrArrayOp :: CmmExpr + -> CmmExpr + -> CmmExpr + -> FCode () +doWritePtrArrayOp addr idx val + = do dflags <- getDynFlags + platform <- getPlatform + let ty = cmmExprType platform val + hdr_size = arrPtrsHdrSize dflags + -- Update remembered set for non-moving collector + whenUpdRemSetEnabled + $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx) + -- This write barrier is to ensure that the heap writes to the object + -- referred to by val have happened before we write val into the array. + -- See #12469 for details. + emitPrimCall [] MO_WriteBarrier [] + mkBasicIndexedWrite hdr_size Nothing addr ty idx val + emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + -- the write barrier. We must write a byte into the mark table: + -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] + emit $ mkStore ( + cmmOffsetExpr platform + (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) + (loadArrPtrsSize dflags addr)) + (CmmMachOp (mo_wordUShr platform) [idx, + mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)]) + ) (CmmLit (CmmInt 1 W8)) + +loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform) + where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags + platform = targetPlatform dflags + +mkBasicIndexedRead :: ByteOff -- Initial offset in bytes + -> Maybe MachOp -- Optional result cast + -> CmmType -- Type of element we are accessing + -> LocalReg -- Destination + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> FCode () +mkBasicIndexedRead off Nothing ty res base idx_ty idx + = do platform <- getPlatform + emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform off ty base idx_ty idx) +mkBasicIndexedRead off (Just cast) ty res base idx_ty idx + = do platform <- getPlatform + emitAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr platform off ty base idx_ty idx]) + +mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes + -> Maybe MachOp -- Optional value cast + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> CmmExpr -- Value to write + -> FCode () +mkBasicIndexedWrite off Nothing base idx_ty idx val + = do platform <- getPlatform + emitStore (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val +mkBasicIndexedWrite off (Just cast) base idx_ty idx val + = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) + +-- ---------------------------------------------------------------------------- +-- Misc utils + +cmmIndexOffExpr :: Platform + -> ByteOff -- Initial offset in bytes + -> Width -- Width of element by which we are indexing + -> CmmExpr -- Base address + -> CmmExpr -- Index + -> CmmExpr +cmmIndexOffExpr platform off width base idx + = cmmIndexExpr platform width (cmmOffsetB platform base off) idx + +cmmLoadIndexOffExpr :: Platform + -> ByteOff -- Initial offset in bytes + -> CmmType -- Type of element we are accessing + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> CmmExpr +cmmLoadIndexOffExpr platform off ty base idx_ty idx + = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty + +setInfo :: CmmExpr -> CmmExpr -> CmmAGraph +setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr + +------------------------------------------------------------------------------ +-- Helpers for translating vector primops. + +vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType +vecVmmType pocat n w = vec n (vecCmmCat pocat w) + +vecCmmCat :: PrimOpVecCat -> Width -> CmmType +vecCmmCat IntVec = cmmBits +vecCmmCat WordVec = cmmBits +vecCmmCat FloatVec = cmmFloat + +vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp +vecElemInjectCast _ FloatVec _ = Nothing +vecElemInjectCast platform IntVec W8 = Just (mo_WordTo8 platform) +vecElemInjectCast platform IntVec W16 = Just (mo_WordTo16 platform) +vecElemInjectCast platform IntVec W32 = Just (mo_WordTo32 platform) +vecElemInjectCast _ IntVec W64 = Nothing +vecElemInjectCast platform WordVec W8 = Just (mo_WordTo8 platform) +vecElemInjectCast platform WordVec W16 = Just (mo_WordTo16 platform) +vecElemInjectCast platform WordVec W32 = Just (mo_WordTo32 platform) +vecElemInjectCast _ WordVec W64 = Nothing +vecElemInjectCast _ _ _ = Nothing + +vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp +vecElemProjectCast _ FloatVec _ = Nothing +vecElemProjectCast platform IntVec W8 = Just (mo_s_8ToWord platform) +vecElemProjectCast platform IntVec W16 = Just (mo_s_16ToWord platform) +vecElemProjectCast platform IntVec W32 = Just (mo_s_32ToWord platform) +vecElemProjectCast _ IntVec W64 = Nothing +vecElemProjectCast platform WordVec W8 = Just (mo_u_8ToWord platform) +vecElemProjectCast platform WordVec W16 = Just (mo_u_16ToWord platform) +vecElemProjectCast platform WordVec W32 = Just (mo_u_32ToWord platform) +vecElemProjectCast _ WordVec W64 = Nothing +vecElemProjectCast _ _ _ = Nothing + + +-- NOTE [SIMD Design for the future] +-- Check to make sure that we can generate code for the specified vector type +-- given the current set of dynamic flags. +-- Currently these checks are specific to x86 and x86_64 architecture. +-- This should be fixed! +-- In particular, +-- 1) Add better support for other architectures! (this may require a redesign) +-- 2) Decouple design choices from LLVM's pseudo SIMD model! +-- The high level LLVM naive rep makes per CPU family SIMD generation is own +-- optimization problem, and hides important differences in eg ARM vs x86_64 simd +-- 3) Depending on the architecture, the SIMD registers may also support general +-- computations on Float/Double/Word/Int scalars, but currently on +-- for example x86_64, we always put Word/Int (or sized) in GPR +-- (general purpose) registers. Would relaxing that allow for +-- useful optimization opportunities? +-- Phrased differently, it is worth experimenting with supporting +-- different register mapping strategies than we currently have, especially if +-- someday we want SIMD to be a first class denizen in GHC along with scalar +-- values! +-- The current design with respect to register mapping of scalars could +-- very well be the best,but exploring the design space and doing careful +-- measurements is the only way to validate that. +-- In some next generation CPU ISAs, notably RISC V, the SIMD extension +-- includes support for a sort of run time CPU dependent vectorization parameter, +-- where a loop may act upon a single scalar each iteration OR some 2,4,8 ... +-- element chunk! Time will tell if that direction sees wide adoption, +-- but it is from that context that unifying our handling of simd and scalars +-- may benefit. It is not likely to benefit current architectures, though +-- it may very well be a design perspective that helps guide improving the NCG. + + +checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () +checkVecCompatibility dflags vcat l w = do + when (hscTarget dflags /= HscLlvm) $ do + sorry $ unlines ["SIMD vector instructions require the LLVM back-end." + ,"Please use -fllvm."] + check vecWidth vcat l w + where + check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () + check W128 FloatVec 4 W32 | not (isSseEnabled dflags) = + sorry $ "128-bit wide single-precision floating point " ++ + "SIMD vector instructions require at least -msse." + check W128 _ _ _ | not (isSse2Enabled dflags) = + sorry $ "128-bit wide integer and double precision " ++ + "SIMD vector instructions require at least -msse2." + check W256 FloatVec _ _ | not (isAvxEnabled dflags) = + sorry $ "256-bit wide floating point " ++ + "SIMD vector instructions require at least -mavx." + check W256 _ _ _ | not (isAvx2Enabled dflags) = + sorry $ "256-bit wide integer " ++ + "SIMD vector instructions require at least -mavx2." + check W512 _ _ _ | not (isAvx512fEnabled dflags) = + sorry $ "512-bit wide " ++ + "SIMD vector instructions require -mavx512f." + check _ _ _ _ = return () + + vecWidth = typeWidth (vecVmmType vcat l w) + +------------------------------------------------------------------------------ +-- Helpers for translating vector packing and unpacking. + +doVecPackOp :: Maybe MachOp -- Cast from element to vector component + -> CmmType -- Type of vector + -> CmmExpr -- Initial vector + -> [CmmExpr] -- Elements + -> CmmFormal -- Destination for result + -> FCode () +doVecPackOp maybe_pre_write_cast ty z es res = do + dst <- newTemp ty + emitAssign (CmmLocal dst) z + vecPack dst es 0 + where + vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode () + vecPack src [] _ = + emitAssign (CmmLocal res) (CmmReg (CmmLocal src)) + + vecPack src (e : es) i = do + dst <- newTemp ty + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid) + [CmmReg (CmmLocal src), cast e, iLit]) + else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) + [CmmReg (CmmLocal src), cast e, iLit]) + vecPack dst es (i + 1) + where + -- vector indices are always 32-bits + iLit = CmmLit (CmmInt (toInteger i) W32) + + cast :: CmmExpr -> CmmExpr + cast val = case maybe_pre_write_cast of + Nothing -> val + Just cast -> CmmMachOp cast [val] + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +doVecUnpackOp :: Maybe MachOp -- Cast from vector component to element result + -> CmmType -- Type of vector + -> CmmExpr -- Vector + -> [CmmFormal] -- Element results + -> FCode () +doVecUnpackOp maybe_post_read_cast ty e res = + vecUnpack res 0 + where + vecUnpack :: [CmmFormal] -> Int -> FCode () + vecUnpack [] _ = + return () + + vecUnpack (r : rs) i = do + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid) + [e, iLit])) + else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid) + [e, iLit])) + vecUnpack rs (i + 1) + where + -- vector indices are always 32-bits + iLit = CmmLit (CmmInt (toInteger i) W32) + + cast :: CmmExpr -> CmmExpr + cast val = case maybe_post_read_cast of + Nothing -> val + Just cast -> CmmMachOp cast [val] + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +doVecInsertOp :: Maybe MachOp -- Cast from element to vector component + -> CmmType -- Vector type + -> CmmExpr -- Source vector + -> CmmExpr -- Element + -> CmmExpr -- Index at which to insert element + -> CmmFormal -- Destination for result + -> FCode () +doVecInsertOp maybe_pre_write_cast ty src e idx res = do + platform <- getPlatform + -- vector indices are always 32-bits + let idx' :: CmmExpr + idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx] + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx']) + else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx']) + where + cast :: CmmExpr -> CmmExpr + cast val = case maybe_pre_write_cast of + Nothing -> val + Just cast -> CmmMachOp cast [val] + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +------------------------------------------------------------------------------ +-- Helpers for translating prefetching. + + +-- | Translate byte array prefetch operations into proper primcalls. +doPrefetchByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchByteArrayOp locality [addr,idx] + = do dflags <- getDynFlags + mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx +doPrefetchByteArrayOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" + +-- | Translate mutable byte array prefetch operations into proper primcalls. +doPrefetchMutableByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchMutableByteArrayOp locality [addr,idx] + = do dflags <- getDynFlags + mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx +doPrefetchMutableByteArrayOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" + +-- | Translate address prefetch operations into proper primcalls. +doPrefetchAddrOp ::Int + -> [CmmExpr] + -> FCode () +doPrefetchAddrOp locality [addr,idx] + = mkBasicPrefetch locality 0 addr idx +doPrefetchAddrOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp" + +-- | Translate value prefetch operations into proper primcalls. +doPrefetchValueOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchValueOp locality [addr] + = do platform <- getPlatform + mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth platform))) +doPrefetchValueOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchValueOp" + +-- | helper to generate prefetch primcalls +mkBasicPrefetch :: Int -- Locality level 0-3 + -> ByteOff -- Initial offset in bytes + -> CmmExpr -- Base address + -> CmmExpr -- Index + -> FCode () +mkBasicPrefetch locality off base idx + = do platform <- getPlatform + emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx] + return () + +-- ---------------------------------------------------------------------------- +-- Allocating byte arrays + +-- | Takes a register to return the newly allocated array in and the +-- size of the new array in bytes. Allocates a new +-- 'MutableByteArray#'. +doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () +doNewByteArrayOp res_r n = do + dflags <- getDynFlags + platform <- getPlatform + + let info_ptr = mkLblExpr mkArrWords_infoLabel + rep = arrWordsRep platform n + + tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize dflags)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize dflags + + base <- allocHeapClosure rep info_ptr cccsExpr + [ (mkIntExpr platform n, + hdr_size + oFFSET_StgArrBytes_bytes dflags) + ] + + emit $ mkAssign (CmmLocal res_r) base + +-- ---------------------------------------------------------------------------- +-- Comparing byte arrays + +doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do + dflags <- getDynFlags + platform <- getPlatform + ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize dflags)) ba1_off + ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize dflags)) ba2_off + + -- short-cut in case of equal pointers avoiding a costly + -- subroutine call to the memcmp(3) routine; the Cmm logic below + -- results in assembly code being generated for + -- + -- cmpPrefix10 :: ByteArray# -> ByteArray# -> Int# + -- cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10# + -- + -- that looks like + -- + -- leaq 16(%r14),%rax + -- leaq 16(%rsi),%rbx + -- xorl %ecx,%ecx + -- cmpq %rbx,%rax + -- je l_ptr_eq + -- + -- ; NB: the common case (unequal pointers) falls-through + -- ; the conditional jump, and therefore matches the + -- ; usual static branch prediction convention of modern cpus + -- + -- subq $8,%rsp + -- movq %rbx,%rsi + -- movq %rax,%rdi + -- movl $10,%edx + -- xorl %eax,%eax + -- call memcmp + -- addq $8,%rsp + -- movslq %eax,%rax + -- movq %rax,%rcx + -- l_ptr_eq: + -- movq %rcx,%rbx + -- jmp *(%rbp) + + l_ptr_eq <- newBlockId + l_ptr_ne <- newBlockId + + emit (mkAssign (CmmLocal res) (zeroExpr platform)) + emit (mkCbranch (cmmEqWord platform ba1_p ba2_p) + l_ptr_eq l_ptr_ne (Just False)) + + emitLabel l_ptr_ne + emitMemcmpCall res ba1_p ba2_p n 1 + + emitLabel l_ptr_eq + +-- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes align = + emitMemcpyCall dst_p src_p bytes align + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes align = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p bytes align) + (getCode $ emitMemcpyCall dst_p src_p bytes align) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> Alignment -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyByteArray copy src src_off dst dst_off n = do + dflags <- getDynFlags + platform <- getPlatform + let byteArrayAlignment = wordAlignment platform + srcOffAlignment = cmmExprAlignment src_off + dstOffAlignment = cmmExprAlignment dst_off + align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment] + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off + copy src dst dst_p src_p n align + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyByteArrayToAddrOp src src_off dst_p bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + dflags <- getDynFlags + platform <- getPlatform + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off + emitMemcpyCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'MutableByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp + +-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into +-- the destination array, and the number of bytes to copy. Copies the given +-- number of bytes from the source memory region to the destination array. +doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToByteArrayOp src_p dst dst_off bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + dflags <- getDynFlags + platform <- getPlatform + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off + emitMemcpyCall dst_p src_p bytes (mkAlignment 1) + + +-- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- character. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetByteArrayOp ba off len c = do + dflags <- getDynFlags + platform <- getPlatform + + let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap + offsetAlignment = cmmExprAlignment off + align = min byteArrayAlignment offsetAlignment + + p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize dflags)) off + emitMemsetCall p c len align + +-- ---------------------------------------------------------------------------- +-- Allocating arrays + +-- | Allocate a new array. +doNewArrayOp :: CmmFormal -- ^ return register + -> SMRep -- ^ representation of the array + -> CLabel -- ^ info pointer + -> [(CmmExpr, ByteOff)] -- ^ header payload + -> WordOff -- ^ array size + -> CmmExpr -- ^ initial element + -> FCode () +doNewArrayOp res_r rep info payload n init = do + dflags <- getDynFlags + platform <- getPlatform + + let info_ptr = mkLblExpr info + + tickyAllocPrim (mkIntExpr platform (hdrSize dflags rep)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + base <- allocHeapClosure rep info_ptr cccsExpr payload + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + -- Initialise all elements of the array + let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW dflags rep + off) + initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] + emit (catAGraphs initialization) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- More closely imitates 'assignTemp' from the old code generator, which +-- returns a CmmExpr rather than a LocalReg. +assignTempE :: CmmExpr -> FCode CmmExpr +assignTempE e = do + t <- assignTemp e + return (CmmReg (CmmLocal t)) + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyArrayOp = emitCopyArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + do platform <- getPlatform + emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform) + + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyMutableArrayOp = emitCopyArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopyArray copy src0 src_off dst0 dst_off0 n = + when (n /= 0) $ do + dflags <- getDynFlags + platform <- getPlatform + + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + dst_off <- assignTempE dst_off0 + + -- Nonmoving collector write barrier + emitCopyUpdRemSetPush platform (arrPtrsHdrSize dflags) dst dst_off n + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTempE $ cmmOffsetB platform dst + (arrPtrsHdrSize dflags) + dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform src (arrPtrsHdrSize dflags)) src_off + let bytes = wordsToBytes platform n + + copy src dst dst_p src_p bytes + + -- The base address of the destination card table + dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p + (loadArrPtrsSize dflags dst) + + emitSetCards dst_off dst_cards_p n + +doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallArrayOp = emitCopySmallArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + do platform <- getPlatform + emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform) + + +doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallMutableArrayOp = emitCopySmallArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopySmallArray copy src0 src_off dst0 dst_off n = + when (n /= 0) $ do + dflags <- getDynFlags + platform <- getPlatform + + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + + -- Nonmoving collector write barrier + emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize dflags) dst dst_off n + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + + dst_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform dst (smallArrPtrsHdrSize dflags)) dst_off + src_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform src (smallArrPtrsHdrSize dflags)) src_off + let bytes = wordsToBytes platform n + + copy src dst dst_p src_p bytes + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneArray info_p res_r src src_off n = do + dflags <- getDynFlags + platform <- getPlatform + + let info_ptr = mkLblExpr info_p + rep = arrPtrsRep dflags n + + tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize dflags)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize dflags + + base <- allocHeapClosure rep info_ptr cccsExpr + [ (mkIntExpr platform n, + hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags) + , (mkIntExpr platform (nonHdrSizeW rep), + hdr_size + oFFSET_StgMutArrPtrs_size dflags) + ] + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) + (arrPtrsHdrSize dflags) + src_p <- assignTempE $ cmmOffsetExprW platform src + (cmmAddWord platform + (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + (wordAlignment platform) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneSmallArray info_p res_r src src_off n = do + dflags <- getDynFlags + platform <- getPlatform + + let info_ptr = mkLblExpr info_p + rep = smallArrPtrsRep n + + tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize dflags)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize dflags + + base <- allocHeapClosure rep info_ptr cccsExpr + [ (mkIntExpr platform n, + hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + ] + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) + (smallArrPtrsHdrSize dflags) + src_p <- assignTempE $ cmmOffsetExprW platform src + (cmmAddWord platform + (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + (wordAlignment platform) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes and offset in the destination array, the base address of +-- the card table, and the number of elements affected (*not* the +-- number of cards). The number of elements may not be zero. +-- Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () +emitSetCards dst_start dst_cards_start n = do + dflags <- getDynFlags + platform <- getPlatform + start_card <- assignTempE $ cardCmm dflags dst_start + let end_card = cardCmm dflags + (cmmSubWord platform + (cmmAddWord platform dst_start (mkIntExpr platform n)) + (mkIntExpr platform 1)) + emitMemsetCall (cmmAddWord platform dst_cards_start start_card) + (mkIntExpr platform 1) + (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1)) + (mkAlignment 1) -- no alignment (1 byte) + +-- Convert an element index to a card index +cardCmm :: DynFlags -> CmmExpr -> CmmExpr +cardCmm dflags i = + cmmUShrWord platform i (mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)) + where platform = targetPlatform dflags + +------------------------------------------------------------------------------ +-- SmallArray PrimOp implementations + +doReadSmallPtrArrayOp :: LocalReg + -> CmmExpr + -> CmmExpr + -> FCode () +doReadSmallPtrArrayOp res addr idx = do + dflags <- getDynFlags + platform <- getPlatform + mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord platform) res addr + (gcWord platform) idx + +doWriteSmallPtrArrayOp :: CmmExpr + -> CmmExpr + -> CmmExpr + -> FCode () +doWriteSmallPtrArrayOp addr idx val = do + dflags <- getDynFlags + platform <- getPlatform + let ty = cmmExprType platform val + + -- Update remembered set for non-moving collector + tmp <- newTemp ty + mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx + whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) + + emitPrimCall [] MO_WriteBarrier [] -- #12469 + mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val + emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + +------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicRMW :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicRMW res amop mba idx idx_ty n = do + dflags <- getDynFlags + platform <- getPlatform + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRMW width amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + dflags <- getDynFlags + platform <- getPlatform + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRead width) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + dflags <- getDynFlags + platform <- getPlatform + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite width) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + dflags <- getDynFlags + platform <- getPlatform + let width = (typeWidth idx_ty) + addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ +-- Helpers for emitting function calls + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemcpyCall dst src n align = do + emitPrimCall + [ {-no results-} ] + (MO_Memcpy (alignmentBytes align)) + [ dst, src, n ] + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemmoveCall dst src n align = do + emitPrimCall + [ {- no results -} ] + (MO_Memmove (alignmentBytes align)) + [ dst, src, n ] + +-- | Emit a call to @memset@. The second argument must fit inside an +-- unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemsetCall dst c n align = do + emitPrimCall + [ {- no results -} ] + (MO_Memset (alignmentBytes align)) + [ dst, c, n ] + +emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () +emitMemcmpCall res ptr1 ptr2 n align = do + -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all + -- code-gens currently call out to the @memcmp(3)@ C function. + -- This was easier than moving the sign-extensions into + -- all the code-gens. + platform <- getPlatform + let is32Bit = typeWidth (localRegType res) == W32 + + cres <- if is32Bit + then return res + else newTemp b32 + + emitPrimCall + [ cres ] + (MO_Memcmp align) + [ ptr1, ptr2, n ] + + unless is32Bit $ do + emit $ mkAssign (CmmLocal res) + (CmmMachOp + (mo_s_32ToWord platform) + [(CmmReg (CmmLocal cres))]) + +emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBSwapCall res x width = do + emitPrimCall + [ res ] + (MO_BSwap width) + [ x ] + +emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBRevCall res x width = do + emitPrimCall + [ res ] + (MO_BRev width) + [ x ] + +emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitPopCntCall res x width = do + emitPrimCall + [ res ] + (MO_PopCnt width) + [ x ] + +emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () +emitPdepCall res x y width = do + emitPrimCall + [ res ] + (MO_Pdep width) + [ x, y ] + +emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () +emitPextCall res x y width = do + emitPrimCall + [ res ] + (MO_Pext width) + [ x, y ] + +emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitClzCall res x width = do + emitPrimCall + [ res ] + (MO_Clz width) + [ x ] + +emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitCtzCall res x width = do + emitPrimCall + [ res ] + (MO_Ctz width) + [ x ] + +--------------------------------------------------------------------------- +-- Pushing to the update remembered set +--------------------------------------------------------------------------- + +-- | Push a range of pointer-array elements that are about to be copied over to +-- the update remembered set. +emitCopyUpdRemSetPush :: Platform + -> ByteOff -- ^ array header size (in bytes) + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array (in words) + -> Int -- ^ number of elements to copy + -> FCode () +emitCopyUpdRemSetPush _platform _hdr_size _dst _dst_off 0 = return () +emitCopyUpdRemSetPush platform hdr_size dst dst_off n = + whenUpdRemSetEnabled $ do + updfr_off <- getUpdFrameOff + graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off [] + emit graph + where + lbl = mkLblExpr $ mkPrimCallLabel + $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit + args = + [ mkIntExpr platform hdr_size + , dst + , dst_off + , mkIntExpr platform n ] diff --git a/GHC/StgToCmm/Prof.hs b/GHC/StgToCmm/Prof.hs --- a/GHC/StgToCmm/Prof.hs +++ b/GHC/StgToCmm/Prof.hs @@ -23,29 +23,28 @@ ldvEnter, ldvEnterClosure, ldvRecordCreate ) where -import GhcPrelude +import GHC.Prelude +import GHC.Platform import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad -import SMRep +import GHC.Runtime.Heap.Layout -import MkGraph -import Cmm -import CmmUtils -import CLabel +import GHC.Cmm.Graph +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel -import CostCentre -import DynFlags -import FastString -import Module -import Outputable +import GHC.Types.CostCentre +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Unit.Module as Module +import GHC.Utils.Outputable import Control.Monad import Data.Char (ord) -import TyCon (PrimRep (..)) - ----------------------------------------------------------------------------- -- -- Cost-centre-stack Profiling @@ -53,10 +52,10 @@ ----------------------------------------------------------------------------- -- Expression representing the current cost centre stack -ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack +ccsType :: Platform -> CmmType -- Type of a cost-centre stack ccsType = bWord -ccType :: DynFlags -> CmmType -- Type of a cost centre +ccType :: Platform -> CmmType -- Type of a cost centre ccType = bWord storeCurCCS :: CmmExpr -> CmmAGraph @@ -71,23 +70,29 @@ costCentreFrom :: DynFlags -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure -costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) +costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs dflags)) (ccsType platform) + where platform = targetPlatform dflags -- | The profiling header words in a static closure staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] staticProfHdr dflags ccs - = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags] + | sccProfilingEnabled dflags = [mkCCostCentreStack ccs, staticLdvInit platform] + | otherwise = [] + where platform = targetPlatform dflags -- | Profiling header words in a dynamic closure dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] +dynProfHdr dflags ccs + | sccProfilingEnabled dflags = [ccs, dynLdvInit dflags] + | otherwise = [] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS do dflags <- getDynFlags - emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr + platform <- getPlatform + emitStore (cmmOffset platform frame (oFFSET_StgHeader_ccs dflags)) cccsExpr -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -124,9 +129,10 @@ -- Returns Nothing if profiling is off saveCurrentCostCentre = do dflags <- getDynFlags - if not (gopt Opt_SccProfilingOn dflags) + platform <- getPlatform + if not (sccProfilingEnabled dflags) then return Nothing - else do local_cc <- newTemp (ccType dflags) + else do local_cc <- newTemp (ccType platform) emitAssign (CmmLocal local_cc) cccsExpr return (Just local_cc) @@ -147,7 +153,8 @@ profDynAlloc rep ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs + platform <- getPlatform + profAlloc (mkIntExpr platform (heapClosureSizeW dflags rep)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -156,12 +163,13 @@ profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags + platform <- getPlatform let alloc_rep = rEP_CostCentreStack_mem_alloc dflags emit (addToMemE alloc_rep - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) - (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $ - [CmmMachOp (mo_wordSub dflags) [words, - mkIntExpr dflags (profHdrSize dflags)]])) + (cmmOffsetB platform ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $ + [CmmMachOp (mo_wordSub platform) [words, + mkIntExpr platform (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. @@ -180,23 +188,17 @@ if isCurrentCCS ccs then do dflags <- getDynFlags emitRtsCall rtsUnitId (fsLit "enterFunCCS") - [(baseExpr, AddrRep, AddrHint), - (costCentreFrom dflags closure, AddrRep, AddrHint)] False + [(baseExpr, AddrHint), + (costCentreFrom dflags closure, AddrHint)] False else return () -- top-level function, nothing to do ifProfiling :: FCode () -> FCode () ifProfiling code = do dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags + if sccProfilingEnabled dflags then code else return () -ifProfilingL :: DynFlags -> [a] -> [a] -ifProfilingL dflags xs - | gopt Opt_SccProfilingOn dflags = xs - | otherwise = [] - - --------------------------------------------------------------- -- Initialising Cost Centres & CCSs --------------------------------------------------------------- @@ -205,7 +207,7 @@ -- Emit the declarations initCostCentres (local_CCs, singleton_CCSs) = do dflags <- getDynFlags - when (gopt Opt_SccProfilingOn dflags) $ + when (sccProfilingEnabled dflags) $ do mapM_ emitCostCentreDecl local_CCs mapM_ emitCostCentreStackDecl singleton_CCSs @@ -213,25 +215,26 @@ emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do { dflags <- getDynFlags - ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF - | otherwise = zero dflags + ; platform <- getPlatform + ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF + | otherwise = zero platform -- NB. bytesFS: we want the UTF-8 bytes here (#5559) ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) - ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS - $ Module.moduleName + ; modl <- newByteStringCLit (bytesFS $ moduleNameFS + $ moduleName $ cc_mod cc) ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero dflags, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, - loc, -- char *srcloc, - zero64, -- StgWord64 mem_alloc - zero dflags, -- StgWord time_ticks - is_caf, -- StgInt is_caf - zero dflags -- struct _CostCentre *link + lits = [ zero platform, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, + loc, -- char *srcloc, + zero64, -- StgWord64 mem_alloc + zero platform, -- StgWord time_ticks + is_caf, -- StgInt is_caf + zero platform -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } @@ -241,9 +244,10 @@ = case maybeSingletonCCS ccs of Just cc -> do dflags <- getDynFlags - let mk_lits cc = zero dflags : + platform <- getPlatform + let mk_lits cc = zero platform : mkCCostCentre cc : - replicate (sizeof_ccs_words dflags - 2) (zero dflags) + replicate (sizeof_ccs_words dflags - 2) (zero platform) -- Note: to avoid making any assumptions about how the -- C compiler (that compiles the RTS, in particular) does -- layouts of structs containing long-longs, simply @@ -252,8 +256,8 @@ emitDataLits (mkCCSLabel ccs) (mk_lits cc) Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) -zero :: DynFlags -> CmmLit -zero dflags = mkIntCLit dflags 0 +zero :: Platform -> CmmLit +zero platform = mkIntCLit platform 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 @@ -263,7 +267,8 @@ | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags + platform = targetPlatform dflags + (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -271,25 +276,27 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push = do dflags <- getDynFlags - if not (gopt Opt_SccProfilingOn dflags) + platform <- getPlatform + if not (sccProfilingEnabled dflags) then return () - else do tmp <- newTemp (ccsType dflags) + else do tmp <- newTemp (ccsType platform) pushCostCentre tmp cccsExpr cc when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc - = emitRtsCallWithResult result AddrRep AddrHint + = emitRtsCallWithResult result AddrHint rtsUnitId - (fsLit "pushCostCentre") [(ccs, AddrRep, AddrHint), - (CmmLit (mkCCostCentre cc), AddrRep, AddrHint)] + (fsLit "pushCostCentre") [(ccs,AddrHint), + (CmmLit (mkCCostCentre cc), AddrHint)] False bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph bumpSccCount dflags ccs = addToMem (rEP_CostCentreStack_scc_count dflags) - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 + (cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 + where platform = targetPlatform dflags ----------------------------------------------------------------------------- -- @@ -300,7 +307,7 @@ -- -- Initial value for the LDV field in a static closure -- -staticLdvInit :: DynFlags -> CmmLit +staticLdvInit :: Platform -> CmmLit staticLdvInit = zeroCLit -- @@ -308,10 +315,12 @@ -- dynLdvInit :: DynFlags -> CmmExpr dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], - CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) + CmmMachOp (mo_wordOr platform) [ + CmmMachOp (mo_wordShl platform) [loadEra dflags, mkIntExpr platform (lDV_SHIFT dflags)], + CmmLit (mkWordCLit platform (iLDV_STATE_CREATE dflags)) ] + where + platform = targetPlatform dflags -- -- Initialise the LDV word of a new closure @@ -329,34 +338,39 @@ ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () ldvEnterClosure closure_info node_reg = do dflags <- getDynFlags + platform <- getPlatform let tag = funTag dflags closure_info - -- don't forget to substract node's tag - ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag)) + -- don't forget to subtract node's tag + ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag)) ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do dflags <- getDynFlags - let -- don't forget to substract node's tag + platform <- getPlatform + let -- don't forget to subtract node's tag ldv_wd = ldvWord dflags cl_ptr - new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) - (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags)))) - (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags)))) + new_ldv_wd = cmmOrWord platform + (cmmAndWord platform (CmmLoad ldv_wd (bWord platform)) + (CmmLit (mkWordCLit platform (iLDV_CREATE_MASK dflags)))) + (cmmOrWord platform (loadEra dflags) (CmmLit (mkWordCLit platform (iLDV_STATE_USE dflags)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } - emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra dflags, CmmLit (zeroCLit platform)]) (mkStore ldv_wd new_ldv_wd) mkNop loadEra :: DynFlags -> CmmExpr -loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) +loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform)) [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era"))) (cInt dflags)] + where platform = targetPlatform dflags ldvWord :: DynFlags -> CmmExpr -> CmmExpr -- Takes the address of a closure, and returns -- the address of the LDV word in the closure ldvWord dflags closure_ptr - = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) + = cmmOffsetB platform closure_ptr (oFFSET_StgHeader_ldvw dflags) + where platform = targetPlatform dflags diff --git a/GHC/StgToCmm/Ticky.hs b/GHC/StgToCmm/Ticky.hs --- a/GHC/StgToCmm/Ticky.hs +++ b/GHC/StgToCmm/Ticky.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- @@ -23,9 +24,9 @@ * some codeGen/ modules import this one - * this module imports cmm/CLabel.hs to manage labels + * this module imports GHC.Cmm.CLabel to manage labels - * cmm/CmmParse.y expands some macros using generators defined in + * GHC.Cmm.Parser expands some macros using generators defined in this module * includes/stg/Ticky.h declares all of the global counters @@ -81,57 +82,54 @@ tickyHeapCheck, tickyStackCheck, - tickyUnknownCall, tickyDirectCall, + tickyDirectCall, tickyPushUpdateFrame, tickyUpdateFrameOmitted, tickyEnterDynCon, - tickyEnterStaticCon, - tickyEnterViaNode, tickyEnterFun, - tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value - -- thunks only + tickyEnterThunk, tickyEnterLNE, tickyUpdateBhCaf, - tickyBlackHole, tickyUnboxedTupleReturn, tickyReturnOldCon, tickyReturnNewCon, - tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, - tickySlowCall, tickySlowCallPat, + tickySlowCall ) where -import GhcPrelude +import GHC.Prelude +import GHC.Platform import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad -import StgSyn -import CmmExpr -import MkGraph -import CmmUtils -import CLabel -import SMRep +import GHC.Stg.Syntax +import GHC.Cmm.Expr +import GHC.Cmm.Graph +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Runtime.Heap.Layout -import Name -import Id -import BasicTypes -import FastString -import Outputable -import Util +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc -import DynFlags +import GHC.Driver.Session -- Turgid imports for showTypeCategory -import PrelNames -import TcType -import TyCon -import Predicate +import GHC.Builtin.Names +import GHC.Tc.Utils.TcType +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Predicate import Data.Maybe import qualified Data.Char @@ -147,6 +145,7 @@ = TickyFun Bool -- True <-> single entry | TickyCon + DataCon -- the allocated constructor | TickyThunk Bool -- True <-> updateable Bool -- True <-> standard thunk (AP or selector), has no entry counter @@ -190,13 +189,14 @@ withNewTickyCounterCon :: Name + -> DataCon -> FCode a -> FCode a -withNewTickyCounterCon name code = do +withNewTickyCounterCon name datacon code = do has_ctr <- thunkHasCounter False if not has_ctr then code - else withNewTickyCounter TickyCon name [] code + else withNewTickyCounter (TickyCon datacon) name [] code -- args does not include the void arguments withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a @@ -210,6 +210,7 @@ (>> return ctr_lbl) $ ifTicky $ do { dflags <- getDynFlags + ; platform <- getPlatform ; parent <- getTickyCtrLabel ; mod_name <- getModuleName @@ -223,7 +224,7 @@ ext = case cloType of TickyFun single_entry -> parens $ hcat $ punctuate comma $ [text "fun"] ++ [text "se"|single_entry] - TickyCon -> parens (text "con") + TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon)) TickyThunk upd std -> parens $ hcat $ punctuate comma $ [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std] TickyLNE | isInternalName name -> parens (text "LNE") @@ -245,14 +246,14 @@ -- krc: note that all the fields are I32 now; some were I16 -- before, but the code generator wasn't handling that -- properly and it led to chaos, panic and disorder. - [ mkIntCLit dflags 0, -- registered? - mkIntCLit dflags (length args), -- Arity - mkIntCLit dflags 0, -- Heap allocated for this thing + [ mkIntCLit platform 0, -- registered? + mkIntCLit platform (length args), -- Arity + mkIntCLit platform 0, -- Heap allocated for this thing fun_descr_lit, arg_descr_lit, - zeroCLit dflags, -- Entries into this thing - zeroCLit dflags, -- Heap allocated by this thing - zeroCLit dflags -- Link to next StgEntCounter + zeroCLit platform, -- Entries into this thing + zeroCLit platform, -- Heap allocated by this thing + zeroCLit platform -- Link to next StgEntCounter ] } @@ -272,10 +273,8 @@ -- bump of name-specific ticky counter into. On the other hand, we can -- still track allocation their allocation. -tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode () -tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") +tickyEnterDynCon :: FCode () +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") tickyEnterThunk :: ClosureInfo -> FCode () tickyEnterThunk cl_info @@ -287,7 +286,7 @@ registerTickyCtrAtEntryDyn ticky_ctr_lbl bumpTickyEntryCount ticky_ctr_lbl } where - updatable = closureSingleEntry cl_info + updatable = not (closureUpdReqd cl_info) static = isStaticClosure cl_info ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr" @@ -295,16 +294,6 @@ | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr" else fsLit "ENT_DYN_THK_MANY_ctr" -tickyEnterStdThunk :: ClosureInfo -> FCode () -tickyEnterStdThunk = tickyEnterThunk - -tickyBlackHole :: Bool{-updatable-} -> FCode () -tickyBlackHole updatable - = ifTicky (bumpTickyCounter ctr) - where - ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr") - | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr") - tickyUpdateBhCaf :: ClosureInfo -> FCode () tickyUpdateBhCaf cl_info = ifTicky (bumpTickyCounter ctr) @@ -352,19 +341,20 @@ -- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do dflags <- getDynFlags + platform <- getPlatform let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq (wordWidth dflags)) + test = CmmMachOp (MO_Eq (wordWidth platform)) [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), - zeroExpr dflags] + (oFFSET_StgEntCounter_registeredp dflags))) (bWord platform), + zeroExpr platform] register_stmts = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) - (CmmLoad ticky_entry_ctrs (bWord dflags)) + (CmmLoad ticky_entry_ctrs (bWord platform)) , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) , mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_registeredp dflags))) - (mkIntExpr dflags 1) ] + (mkIntExpr platform 1) ] ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) @@ -449,8 +439,10 @@ -- used to distinguish between closure types -- -- TODO what else to count while we're here? -tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> - let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep +tickyDynAlloc mb_id rep lf = ifTicky $ do + dflags <- getDynFlags + let platform = targetPlatform dflags + bytes = platformWordSizeInBytes platform * heapClosureSizeW dflags rep countGlobal tot ctr = do bumpTickyCounterBy tot bytes @@ -467,19 +459,18 @@ -- for now, since I don't currently know neither if we do nor how to -- distinguish. NSF Mar 2013 - in case () of - _ | isConRep rep -> - ifTickyDynThunk countSpecific >> - countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") - | isThunkRep rep -> - ifTickyDynThunk countSpecific >> - if lfUpdatable lf - then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr") - else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr") - | isFunRep rep -> - countSpecific >> - countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr") - | otherwise -> panic "How is this heap object not a con, thunk, or fun?" + if | isConRep rep -> + ifTickyDynThunk countSpecific >> + countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") + | isThunkRep rep -> + ifTickyDynThunk countSpecific >> + if lfUpdatable lf + then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr") + else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr") + | isFunRep rep -> + countSpecific >> + countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr") + | otherwise -> panic "How is this heap object not a con, thunk, or fun?" @@ -492,31 +483,32 @@ tickyAllocHeap genuine hp = ifTicky $ do { dflags <- getDynFlags + ; platform <- getPlatform ; ticky_ctr <- getTickyCtrLabel ; emit $ catAGraphs $ -- only test hp from within the emit so that the monadic -- computation itself is not strict in hp (cf knot in -- GHC.StgToCmm.Monad.getHeapUsage) if hp == 0 then [] - else let !bytes = wORD_SIZE dflags * hp in [ + else let !bytes = platformWordSizeInBytes platform * hp in [ -- Bump the allocation total in the closure's StgEntCounter addToMem (rEP_StgEntCounter_allocs dflags) (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags))) bytes, -- Bump the global allocation total ALLOC_HEAP_tot - addToMemLbl (bWord dflags) + addToMemLbl (bWord platform) (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot")) bytes, -- Bump the global allocation counter ALLOC_HEAP_ctr if not genuine then mkNop - else addToMemLbl (bWord dflags) + else addToMemLbl (bWord platform) (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr")) 1 ]} -------------------------------------------------------------------------------- --- these three are only called from CmmParse.y (ie ultimately from the RTS) +-- these three are only called from GHC.Cmm.Parser (ie ultimately from the RTS) -- the units are bytes @@ -606,23 +598,24 @@ bumpTickyLitBy :: CmmLit -> Int -> FCode () bumpTickyLitBy lhs n = do - dflags <- getDynFlags - emit (addToMem (bWord dflags) (CmmLit lhs) n) + platform <- getPlatform + emit (addToMem (bWord platform) (CmmLit lhs) n) bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () bumpTickyLitByE lhs e = do - dflags <- getDynFlags - emit (addToMemE (bWord dflags) (CmmLit lhs) e) + platform <- getPlatform + emit (addToMemE (bWord platform) (CmmLit lhs) e) bumpHistogram :: FastString -> Int -> FCode () bumpHistogram lbl n = do dflags <- getDynFlags + platform <- getPlatform let offset = n `min` (tICKY_BIN_COUNT dflags - 1) - emit (addToMem (bWord dflags) - (cmmIndexExpr dflags - (wordWidth dflags) + emit (addToMem (bWord platform) + (cmmIndexExpr platform + (wordWidth platform) (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl))) - (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags)))) + (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform)))) 1) ------------------------------------------------------------------ diff --git a/GHC/StgToCmm/Types.hs b/GHC/StgToCmm/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Types.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE CPP #-} + +module GHC.StgToCmm.Types + ( CgInfos (..) + , LambdaFormInfo (..) + , ModuleLFInfos + , Liveness + , ArgDescr (..) + , StandardFormInfo (..) + , WordOff + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Utils.Outputable + +{- +Note [Conveying CAF-info and LFInfo between modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some information about an Id is generated in the code generator, and is not +available earlier. Namely: + +* CAF info. Code motion in Cmm or earlier phases may move references around so + we compute information about which bits of code refer to which CAF late in the + Cmm pipeline. + +* LambdaFormInfo. This records the details of a closure representation, + including + - the final arity (for functions) + - whether it is a data constructor, and if so its tag + +Collectively we call this CgInfo (see GHC.StgToCmm.Types). + +It's very useful for importing modules to have this information. We can always +make a conservative assumption, but that is bad: e.g. + +* For CAF info, if we know nothing we have to assume it is a CAF which bloats + the SRTs of the importing module. + + Conservative assumption here is made when creating new Ids. + +* For data constructors, we really like having well-tagged pointers. See #14677, + #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging + + Conservative assumption here is made when we import an Id without a + LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.mkLFImported. + +So we arrange to always serialise this information into the interface file. The +moving parts are: + +* We record the CgInfo in the IdInfo of the Id. + +* GHC.Driver.Pipeline: the call to updateModDetailsIdInfos augments the + ModDetails constructed at the end of the Core pipeline, with CgInfo + gleaned from the back end. The hard work is done in GHC.Iface.UpdateIdInfos. + +* For ModIface we generate the final ModIface with CgInfo in + GHC.Iface.Make.mkFullIface. + +* We don't absolutely guarantee to serialise the CgInfo: we won't if you have + -fomit-interface-pragmas or -fno-code; and we won't read it in if you have + -fignore-interface-pragmas. (We could revisit this decision.) +-} + +-- | Codegen-generated Id infos, to be passed to downstream via interfaces. +-- +-- This stuff is for optimization purposes only, they're not compulsory. +-- +-- * When CafInfo of an imported Id is not known it's safe to treat it as CAFFY. +-- * When LambdaFormInfo of an imported Id is not known it's safe to treat it as +-- `LFUnknown True` (which just says "it could be anything" and we do slow +-- entry). +-- +-- See also Note [Conveying CAF-info and LFInfo between modules] above. +-- +data CgInfos = CgInfos + { cgNonCafs :: !NonCaffySet + -- ^ Exported Non-CAFFY closures in the current module. Everything else is + -- either not exported of CAFFY. + , cgLFInfos :: !ModuleLFInfos + -- ^ LambdaFormInfos of exported closures in the current module. + } + +-------------------------------------------------------------------------------- +-- LambdaFormInfo +-------------------------------------------------------------------------------- + +-- | Maps names in the current module to their LambdaFormInfos +type ModuleLFInfos = NameEnv LambdaFormInfo + +-- | Information about an identifier, from the code generator's point of view. +-- Every identifier is bound to a LambdaFormInfo in the environment, which gives +-- the code generator enough info to be able to tail call or return that +-- identifier. +data LambdaFormInfo + = LFReEntrant -- Reentrant closure (a function) + !TopLevelFlag -- True if top level + !RepArity -- Arity. Invariant: always > 0 + !Bool -- True <=> no fvs + !ArgDescr -- Argument descriptor (should really be in ClosureInfo) + + | LFThunk -- Thunk (zero arity) + !TopLevelFlag + !Bool -- True <=> no free vars + !Bool -- True <=> updatable (i.e., *not* single-entry) + !StandardFormInfo + !Bool -- True <=> *might* be a function type + + | LFCon -- A saturated constructor application + !DataCon -- The constructor + + | LFUnknown -- Used for function arguments and imported things. + -- We know nothing about this closure. + -- Treat like updatable "LFThunk"... + -- Imported things which we *do* know something about use + -- one of the other LF constructors (eg LFReEntrant for + -- known functions) + !Bool -- True <=> *might* be a function type + -- The False case is good when we want to enter it, + -- because then we know the entry code will do + -- For a function, the entry code is the fast entry point + + | LFUnlifted -- A value of unboxed type; + -- always a value, needs evaluation + + | LFLetNoEscape -- See LetNoEscape module for precise description + +instance Outputable LambdaFormInfo where + ppr (LFReEntrant top rep fvs argdesc) = + text "LFReEntrant" <> brackets + (ppr top <+> ppr rep <+> pprFvs fvs <+> ppr argdesc) + ppr (LFThunk top hasfv updateable sfi m_function) = + text "LFThunk" <> brackets + (ppr top <+> pprFvs hasfv <+> pprUpdateable updateable <+> + ppr sfi <+> pprFuncFlag m_function) + ppr (LFCon con) = + text "LFCon" <> brackets (ppr con) + ppr (LFUnknown m_func) = + text "LFUnknown" <> brackets (pprFuncFlag m_func) + ppr LFUnlifted = + text "LFUnlifted" + ppr LFLetNoEscape = + text "LFLetNoEscape" + +pprFvs :: Bool -> SDoc +pprFvs True = text "no-fvs" +pprFvs False = text "fvs" + +pprFuncFlag :: Bool -> SDoc +pprFuncFlag True = text "mFunc" +pprFuncFlag False = text "value" + +pprUpdateable :: Bool -> SDoc +pprUpdateable True = text "updateable" +pprUpdateable False = text "oneshot" + +-------------------------------------------------------------------------------- + +-- | We represent liveness bitmaps as a Bitmap (whose internal representation +-- really is a bitmap). These are pinned onto case return vectors to indicate +-- the state of the stack for the garbage collector. +-- +-- In the compiled program, liveness bitmaps that fit inside a single word +-- (StgWord) are stored as a single word, while larger bitmaps are stored as a +-- pointer to an array of words. + +type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead + -- False <=> ptr + +-------------------------------------------------------------------------------- +-- | An ArgDescr describes the argument pattern of a function + +data ArgDescr + = ArgSpec -- Fits one of the standard patterns + !Int -- RTS type identifier ARG_P, ARG_N, ... + + | ArgGen -- General case + Liveness -- Details about the arguments + + | ArgUnknown -- For imported binds. + -- Invariant: Never Unknown for binds of the module + -- we are compiling. + deriving (Eq) + +instance Outputable ArgDescr where + ppr (ArgSpec n) = text "ArgSpec" <+> ppr n + ppr (ArgGen ls) = text "ArgGen" <+> ppr ls + ppr ArgUnknown = text "ArgUnknown" + +-------------------------------------------------------------------------------- +-- | StandardFormInfo tells whether this thunk has one of a small number of +-- standard forms + +data StandardFormInfo + = NonStandardThunk + -- The usual case: not of the standard forms + + | SelectorThunk + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + !WordOff -- 0-origin offset of ak within the "goods" of + -- constructor (Recall that the a1,...,an may be laid + -- out in the heap in a non-obvious order.) + + | ApThunk + -- An ApThunk is of form + -- x1 ... xn + -- The code for the thunk just pushes x2..xn on the stack and enters x1. + -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + -- in the RTS to save space. + !RepArity -- Arity, n + deriving (Eq) + +-- | Word offset, or word count +type WordOff = Int + +instance Outputable StandardFormInfo where + ppr NonStandardThunk = text "RegThunk" + ppr (SelectorThunk w) = text "SelThunk:" <> ppr w + ppr (ApThunk n) = text "ApThunk:" <> ppr n diff --git a/GHC/StgToCmm/Utils.hs b/GHC/StgToCmm/Utils.hs --- a/GHC/StgToCmm/Utils.hs +++ b/GHC/StgToCmm/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- @@ -10,8 +11,8 @@ module GHC.StgToCmm.Utils ( cgLit, mkSimpleLit, - emitDataLits, mkDataLits, - emitRODataLits, mkRODataLits, + emitDataLits, emitRODataLits, + emitDataCon, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, assignTemp, newTemp, @@ -37,9 +38,7 @@ cmmUntag, cmmIsTagged, addToMem, addToMemE, addToMemLblE, addToMemLbl, - mkWordCLit, newStringCLit, newByteStringCLit, - blankWord, -- * Update remembered set operations whenUpdRemSetEnabled, @@ -49,34 +48,36 @@ #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude +import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure -import Cmm -import BlockId -import MkGraph +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.Graph as CmmGraph import GHC.Platform.Regs -import CLabel -import CmmUtils -import CmmSwitch +import GHC.Cmm.CLabel +import GHC.Cmm.Utils +import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils -import ForeignCall -import IdInfo -import Type -import TyCon -import SMRep -import Module -import Literal -import Digraph -import Util -import Unique -import UniqSupply (MonadUnique(..)) -import DynFlags -import FastString -import Outputable -import RepType +import GHC.Types.ForeignCall +import GHC.Types.Id.Info +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Runtime.Heap.Layout +import GHC.Unit +import GHC.Types.Literal +import GHC.Data.Graph.Directed +import GHC.Utils.Misc +import GHC.Types.Unique +import GHC.Types.Unique.Supply (MonadUnique(..)) +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.RepType +import GHC.Types.CostCentre import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 @@ -95,25 +96,26 @@ cgLit :: Literal -> FCode CmmLit cgLit (LitString s) = newByteStringCLit s -- not unpackFS; we want the UTF-8 byte stream. -cgLit other_lit = do dflags <- getDynFlags - return (mkSimpleLit dflags other_lit) +cgLit other_lit = do platform <- getPlatform + return (mkSimpleLit platform other_lit) -mkSimpleLit :: DynFlags -> Literal -> CmmLit -mkSimpleLit dflags (LitChar c) = CmmInt (fromIntegral (ord c)) - (wordWidth dflags) -mkSimpleLit dflags LitNullAddr = zeroCLit dflags -mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64 -mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64 -mkSimpleLit _ (LitFloat r) = CmmFloat r W32 -mkSimpleLit _ (LitDouble r) = CmmFloat r W64 -mkSimpleLit _ (LitLabel fs ms fod) - = let -- TODO: Literal labels might not actually be in the current package... - labelSrc = ForeignLabelInThisPackage - in CmmLabel (mkForeignLabel fs ms labelSrc fod) --- NB: LitRubbish should have been lowered in "CoreToStg" -mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) +mkSimpleLit :: Platform -> Literal -> CmmLit +mkSimpleLit platform = \case + (LitChar c) -> CmmInt (fromIntegral (ord c)) + (wordWidth platform) + LitNullAddr -> zeroCLit platform + (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumInt64 i) -> CmmInt i W64 + (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumWord64 i) -> CmmInt i W64 + (LitFloat r) -> CmmFloat r W32 + (LitDouble r) -> CmmFloat r W64 + (LitLabel fs ms fod) + -> let -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage + in CmmLabel (mkForeignLabel fs ms labelSrc fod) + -- NB: LitRubbish should have been lowered in "CoreToStg" + other -> pprPanic "mkSimpleLit" (ppr other) -------------------------------------------------------------------------- -- @@ -149,13 +151,13 @@ ------------------------------------------------------------------------- mkTaggedObjectLoad - :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph + :: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph -- (loadTaggedObjectField reg base off tag) generates assignment -- reg = bitsK[ base + off - tag ] -- where K is fixed by 'reg' -mkTaggedObjectLoad dflags reg base offset tag +mkTaggedObjectLoad platform reg base offset tag = mkAssign (CmmLocal reg) - (CmmLoad (cmmOffsetB dflags + (CmmLoad (cmmOffsetB platform (CmmReg (CmmLocal base)) (offset - tag)) (localRegType reg)) @@ -167,9 +169,9 @@ -- ------------------------------------------------------------------------- -tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr -tagToClosure dflags tycon tag - = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags) +tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr +tagToClosure platform tycon tag + = CmmLoad (cmmOffsetExprW platform closure_tbl tag) (bWord platform) where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -179,19 +181,19 @@ -- ------------------------------------------------------------------------- -emitRtsCall :: UnitId -> FastString -> [(CmmExpr, PrimRep, ForeignHint)] -> Bool -> FCode () +emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe -emitRtsCallWithResult :: LocalReg -> PrimRep -> ForeignHint -> UnitId -> FastString - -> [(CmmExpr, PrimRep, ForeignHint)] -> Bool -> FCode () -emitRtsCallWithResult res rep hint pkg fun args safe - = emitRtsCallGen [(res, rep, hint)] (mkCmmCodeLabel pkg fun) args safe +emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString + -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCallWithResult res hint pkg fun args safe + = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe -- Make a call to an RTS C procedure emitRtsCallGen - :: [(LocalReg, PrimRep, ForeignHint)] + :: [(LocalReg,ForeignHint)] -> CLabel - -> [(CmmExpr, PrimRep, ForeignHint)] + -> [(CmmExpr,ForeignHint)] -> Bool -- True <=> CmmSafe call -> FCode () emitRtsCallGen res lbl args safe @@ -206,14 +208,10 @@ if safe then emit =<< mkCmmCall fun_expr res' args' updfr_off else do - let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn res_rep arg_reps + let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' - (args', arg_reps, arg_hints) = unzip3 args - (res', res_reps, res_hints) = unzip3 res - res_rep = case res_reps of - [] -> VoidRep - [r] -> r - _ -> error "can not deal with multiple return values" + (args', arg_hints) = unzip args + (res', res_hints) = unzip res fun_expr = mkLblExpr lbl @@ -244,8 +242,8 @@ -- here, as we don't have liveness information. And really, we -- shouldn't be doing the workaround at this point in the pipeline, see -- Note [Register parameter passing] and the ToDo on CmmCall in --- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across --- unsafe foreign calls in rewriteAssignments, but this is strictly +-- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across +-- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly -- temporary. callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph) callerSaveVolatileRegs dflags = (caller_save, caller_load) @@ -268,7 +266,7 @@ callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph callerRestoreGlobalReg dflags reg = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) + (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg)) ------------------------------------------------------------------------- @@ -277,14 +275,17 @@ -- ------------------------------------------------------------------------- +-- | Emit a data-segment data block emitDataLits :: CLabel -> [CmmLit] -> FCode () --- Emit a data-segment data block emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits) +-- | Emit a read-only data block emitRODataLits :: CLabel -> [CmmLit] -> FCode () --- Emit a read-only data block emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) +emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () +emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) + newStringCLit :: String -> FCode CmmLit -- Make a global definition for the string, -- and return its label @@ -312,9 +313,9 @@ -- due to them being trashed on foreign calls--though it means -- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg -assignTemp e = do { dflags <- getDynFlags +assignTemp e = do { platform <- getPlatform ; uniq <- newUnique - ; let reg = LocalReg uniq (cmmExprType dflags e) + ; let reg = LocalReg uniq (cmmExprType platform e) ; emitAssign (CmmLocal reg) e ; return reg } @@ -329,15 +330,15 @@ -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty = ASSERT( isUnboxedTupleType res_ty ) - do { dflags <- getDynFlags + do { platform <- getPlatform ; sequel <- getSequel - ; regs <- choose_regs dflags sequel + ; regs <- choose_regs platform sequel ; ASSERT( regs `equalLength` reps ) return (regs, map primRepForeignHint reps) } where reps = typePrimRep res_ty choose_regs _ (AssignTo regs _) = return regs - choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps + choose_regs platform _ = mapM (newTemp . primRepCmmType platform) reps @@ -363,12 +364,12 @@ emitMultiAssign [] [] = return () emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs emitMultiAssign regs rhss = do - dflags <- getDynFlags + platform <- getPlatform ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss ) - unscramble dflags ([1..] `zip` (regs `zip` rhss)) + unscramble platform ([1..] `zip` (regs `zip` rhss)) -unscramble :: DynFlags -> [Vrtx] -> FCode () -unscramble dflags vertices = mapM_ do_component components +unscramble :: Platform -> [Vrtx] -> FCode () +unscramble platform vertices = mapM_ do_component components where edges :: [ Node Key Vrtx ] edges = [ DigraphNode vertex key1 (edges_from stmt1) @@ -391,25 +392,24 @@ -- Cyclic? Then go via temporaries. Pick one to -- break the loop and try again with the rest. do_component (CyclicSCC ((_,first_stmt) : rest)) = do - dflags <- getDynFlags u <- newUnique - let (to_tmp, from_tmp) = split dflags u first_stmt + let (to_tmp, from_tmp) = split u first_stmt mk_graph to_tmp - unscramble dflags rest + unscramble platform rest mk_graph from_tmp - split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt) - split dflags uniq (reg, rhs) + split :: Unique -> Stmt -> (Stmt, Stmt) + split uniq (reg, rhs) = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) where - rep = cmmExprType dflags rhs + rep = cmmExprType platform rhs tmp = LocalReg uniq rep mk_graph :: Stmt -> FCode () mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs mustFollow :: Stmt -> Stmt -> Bool - (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs + (reg, _) `mustFollow` (_, rhs) = regUsedIn platform (CmmLocal reg) rhs ------------------------------------------------------------------------- -- mkSwitch @@ -465,8 +465,8 @@ -- In that situation we can be sure the (:) case -- can't happen, so no need to test --- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans --- See Note [Cmm Switches, the general plan] in CmmSwitch +-- SOMETHING MORE COMPLICATED: defer to GHC.Cmm.Switch.Implement +-- See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch mk_discrete_switch signed tag_expr branches mb_deflt range = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches) @@ -492,17 +492,17 @@ deflt_lbl <- label_code join_lbl deflt branches_lbls <- label_branches join_lbl branches - dflags <- getDynFlags - let cmm_ty = cmmExprType dflags scrut + platform <- getPlatform + let cmm_ty = cmmExprType platform scrut rep = typeWidth cmm_ty -- We find the necessary type information in the literals in the branches let signed = case head branches of - (LitNumber nt _ _, _) -> litNumIsSigned nt + (LitNumber nt _, _) -> litNumIsSigned nt _ -> False - let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags) - | otherwise = (0, tARGET_MAX_WORD dflags) + let range | signed = (platformMinInt platform, platformMaxInt platform) + | otherwise = (0, platformMaxWord platform) if isFloatType cmm_ty then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls @@ -525,28 +525,28 @@ -> [(Literal,BlockId)] -> FCode CmmAGraph mk_float_switch rep scrut deflt _bounds [(lit,blk)] - = do dflags <- getDynFlags - return $ mkCbranch (cond dflags) deflt blk Nothing + = do platform <- getPlatform + return $ mkCbranch (cond platform) deflt blk Nothing where - cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit] + cond platform = CmmMachOp ne [scrut, CmmLit cmm_lit] where - cmm_lit = mkSimpleLit dflags lit + cmm_lit = mkSimpleLit platform lit ne = MO_F_Ne rep mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches - = do dflags <- getDynFlags + = do platform <- getPlatform lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches - mkCmmIfThenElse (cond dflags) lo_blk hi_blk + mkCmmIfThenElse (cond platform) lo_blk hi_blk where (lo_branches, mid_lit, hi_branches) = divideBranches branches bounds_lo = (lo_bound, Just mid_lit) bounds_hi = (Just mid_lit, hi_bound) - cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit] + cond platform = CmmMachOp lt [scrut, CmmLit cmm_lit] where - cmm_lit = mkSimpleLit dflags mid_lit + cmm_lit = mkSimpleLit platform mid_lit lt = MO_F_Lt rep @@ -575,7 +575,7 @@ -- and returns L label_code join_lbl (code,tsc) = do lbl <- newBlockId - emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc) + emitOutOfLine lbl (code CmmGraph.<*> mkBranch join_lbl, tsc) return lbl -------------- @@ -583,8 +583,8 @@ assignTemp' e | isTrivialCmmExpr e = return e | otherwise = do - dflags <- getDynFlags - lreg <- newTemp (cmmExprType dflags e) + platform <- getPlatform + lreg <- newTemp (cmmExprType platform e) let reg = CmmLocal lreg emitAssign reg e return (CmmReg reg) @@ -594,15 +594,16 @@ -- Pushing to the update remembered set --------------------------------------------------------------------------- -whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode () -whenUpdRemSetEnabled dflags code = do +whenUpdRemSetEnabled :: FCode a -> FCode () +whenUpdRemSetEnabled code = do + platform <- getPlatform do_it <- getCode code + let + enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord platform) + zero = zeroExpr platform + is_enabled = cmmNeWord platform enabled zero the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False) emit the_if - where - enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord dflags) - zero = zeroExpr dflags - is_enabled = cmmNeWord dflags enabled zero -- | Emit code to add an entry to a now-overwritten pointer to the update -- remembered set. @@ -612,8 +613,8 @@ emitRtsCall rtsUnitId (fsLit "updateRemembSetPushClosure_") - [(CmmReg (CmmGlobal BaseReg), AddrRep, AddrHint), - (ptr, AddrRep, AddrHint)] + [(CmmReg (CmmGlobal BaseReg), AddrHint), + (ptr, AddrHint)] False emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk @@ -622,6 +623,6 @@ emitRtsCall rtsUnitId (fsLit "updateRemembSetPushThunk_") - [(CmmReg (CmmGlobal BaseReg), AddrRep, AddrHint), - (ptr, AddrRep, AddrHint)] + [(CmmReg (CmmGlobal BaseReg), AddrHint), + (ptr, AddrHint)] False diff --git a/GHC/SysTools.hs b/GHC/SysTools.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools.hs @@ -0,0 +1,485 @@ +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2003 +-- +-- Access to system tools: gcc, cp, rm etc +-- +----------------------------------------------------------------------------- +-} + +{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-} + +module GHC.SysTools ( + -- * Initialisation + initSysTools, + lazyInitLlvmConfig, + + -- * Interface to system tools + module GHC.SysTools.Tasks, + module GHC.SysTools.Info, + + linkDynLib, + + copy, + copyWithHeader, + + -- * General utilities + Option(..), + expandTopDir, + + -- * Platform-specifics + libmLinkOpts, + + -- * Mac OS X frameworks + getUnitFrameworkOpts, + getFrameworkOpts + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Settings.Utils + +import GHC.Unit +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Platform +import GHC.Driver.Session +import GHC.Driver.Ways + +import Control.Monad.Trans.Except (runExceptT) +import System.FilePath +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) +import GHC.SysTools.ExtraObj +import GHC.SysTools.Info +import GHC.SysTools.Tasks +import GHC.SysTools.BaseDir +import GHC.Settings.IO +import qualified Data.Set as Set + +{- +Note [How GHC finds toolchain utilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC.SysTools.initSysProgs figures out exactly where all the auxiliary programs +are, and initialises mutable variables to make it easy to call them. +To do this, it makes use of definitions in Config.hs, which is a Haskell +file containing variables whose value is figured out by the build system. + +Config.hs contains two sorts of things + + cGCC, The *names* of the programs + cCPP e.g. cGCC = gcc + cUNLIT cCPP = gcc -E + etc They do *not* include paths + + + cUNLIT_DIR The *path* to the directory containing unlit, split etc + cSPLIT_DIR *relative* to the root of the build tree, + for use when running *in-place* in a build tree (only) + + +--------------------------------------------- +NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): + +Another hair-brained scheme for simplifying the current tool location +nightmare in GHC: Simon originally suggested using another +configuration file along the lines of GCC's specs file - which is fine +except that it means adding code to read yet another configuration +file. What I didn't notice is that the current package.conf is +general enough to do this: + +Package + {name = "tools", import_dirs = [], source_dirs = [], + library_dirs = [], hs_libraries = [], extra_libraries = [], + include_dirs = [], c_includes = [], package_deps = [], + extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], + extra_cc_opts = [], extra_ld_opts = []} + +Which would have the advantage that we get to collect together in one +place the path-specific package stuff with the path-specific tool +stuff. + End of NOTES +--------------------------------------------- + +************************************************************************ +* * +\subsection{Initialisation} +* * +************************************************************************ +-} + +-- Note [LLVM configuration] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain +-- information needed by the LLVM backend to invoke `llc` and `opt`. +-- Specifically: +-- +-- * llvm-targets maps autoconf host triples to the corresponding LLVM +-- `data-layout` declarations. This information is extracted from clang using +-- the script in utils/llvm-targets/gen-data-layout.sh and should be updated +-- whenever we target a new version of LLVM. +-- +-- * llvm-passes maps GHC optimization levels to sets of LLVM optimization +-- flags that GHC should pass to `opt`. +-- +-- This information is contained in files rather the GHC source to allow users +-- to add new targets to GHC without having to recompile the compiler. +-- +-- Since this information is only needed by the LLVM backend we load it lazily +-- with unsafeInterleaveIO. Consequently it is important that we lazily pattern +-- match on LlvmConfig until we actually need its contents. + +lazyInitLlvmConfig :: String + -> IO LlvmConfig +lazyInitLlvmConfig top_dir + = unsafeInterleaveIO $ do -- see Note [LLVM configuration] + targets <- readAndParse "llvm-targets" mkLlvmTarget + passes <- readAndParse "llvm-passes" id + return $ LlvmConfig { llvmTargets = targets, llvmPasses = passes } + where + readAndParse name builder = + do let llvmConfigFile = top_dir name + llvmConfigStr <- readFile llvmConfigFile + case maybeReadFuzzy llvmConfigStr of + Just s -> return (fmap builder <$> s) + Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) + + mkLlvmTarget :: (String, String, String) -> LlvmTarget + mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) + + +initSysTools :: String -- TopDir path + -> IO Settings -- Set all the mutable variables above, holding + -- (a) the system programs + -- (b) the package-config file + -- (c) the GHC usage message +initSysTools top_dir = do + res <- runExceptT $ initSettings top_dir + case res of + Right a -> pure a + Left (SettingsError_MissingData msg) -> pgmError msg + Left (SettingsError_BadData msg) -> pgmError msg + +{- Note [Windows stack usage] + +See: #8870 (and #8834 for related info) and #12186 + +On Windows, occasionally we need to grow the stack. In order to do +this, we would normally just bump the stack pointer - but there's a +catch on Windows. + +If the stack pointer is bumped by more than a single page, then the +pages between the initial pointer and the resulting location must be +properly committed by the Windows virtual memory subsystem. This is +only needed in the event we bump by more than one page (i.e 4097 bytes +or more). + +Windows compilers solve this by emitting a call to a special function +called _chkstk, which does this committing of the pages for you. + +The reason this was causing a segfault was because due to the fact the +new code generator tends to generate larger functions, we needed more +stack space in GHC itself. In the x86 codegen, we needed approximately +~12kb of stack space in one go, which caused the process to segfault, +as the intervening pages were not committed. + +GCC can emit such a check for us automatically but only when the flag +-fstack-check is used. + +See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html +for more information. + +-} + +copy :: DynFlags -> String -> FilePath -> FilePath -> IO () +copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to + +copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath + -> IO () +copyWithHeader dflags purpose maybe_header from to = do + showPass dflags purpose + + hout <- openBinaryFile to WriteMode + hin <- openBinaryFile from ReadMode + ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up + maybe (return ()) (header hout) maybe_header + hPutStr hout ls + hClose hout + hClose hin + where + -- write the header string in UTF-8. The header is something like + -- {-# LINE "foo.hs" #-} + -- and we want to make sure a Unicode filename isn't mangled. + header h str = do + hSetEncoding h utf8 + hPutStr h str + hSetBinaryMode h True + +{- +************************************************************************ +* * +\subsection{Support code} +* * +************************************************************************ +-} + +linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO () +linkDynLib dflags0 o_files dep_packages + = do + let -- This is a rather ugly hack to fix dynamically linked + -- GHC on Windows. If GHC is linked with -threaded, then + -- it links against libHSrts_thr. But if base is linked + -- against libHSrts, then both end up getting loaded, + -- and things go wrong. We therefore link the libraries + -- with the same RTS flags that we link GHC with. + dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0 + then addWay' WayThreaded dflags0 + else dflags0 + dflags = if platformMisc_ghcDebugged $ platformMisc dflags1 + then addWay' WayDebug dflags1 + else dflags1 + + verbFlags = getVerbFlags dflags + o_file = outputFile dflags + + pkgs <- getPreloadUnitsAnd dflags dep_packages + + let platform = targetPlatform dflags + os = platformOS platform + let pkg_lib_paths = collectLibraryPaths dflags pkgs + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | ( osElfTarget (platformOS (targetPlatform dflags)) || + osMachOTarget (platformOS (targetPlatform dflags)) ) && + dynLibLoader dflags == SystemDependent && + -- Only if we want dynamic libraries + WayDyn `Set.member` ways dflags && + -- Only use RPath if we explicitly asked for it + useXLinkerRPath dflags os + = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + | otherwise = ["-L" ++ l] + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + -- We don't want to link our dynamic libs against the RTS package, + -- because the RTS lib comes in several flavours and we want to be + -- able to pick the flavour when a binary is linked. + -- On Windows we need to link the RTS import lib as Windows does + -- not allow undefined symbols. + -- The RTS library path is still added to the library search path + -- above in case the RTS is being explicitly linked in (see #3807). + let pkgs_no_rts = case os of + OSMinGW32 -> + pkgs + _ | gopt Opt_LinkRts dflags -> + pkgs + | otherwise -> + filter ((/= rtsUnitId) . unitId) pkgs + let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts + in package_hs_libs ++ extra_libs ++ other_flags + + -- probably _stub.o files + -- and last temporary shared object file + let extra_ld_inputs = ldInputs dflags + + -- frameworks + pkg_framework_opts <- getUnitFrameworkOpts dflags platform + (map unitId pkgs) + let framework_opts = getFrameworkOpts dflags platform + + case os of + OSMinGW32 -> do + ------------------------------------------------------------- + -- Making a DLL + ------------------------------------------------------------- + let output_fn = case o_file of + Just s -> s + Nothing -> "HSdll.dll" + + runLink dflags ( + map Option verbFlags + ++ [ Option "-o" + , FileOption "" output_fn + , Option "-shared" + ] ++ + [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | gopt Opt_SharedImplib dflags + ] + ++ map (FileOption "") o_files + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ++ [Option "-Wl,--enable-auto-import"] + + ++ extra_ld_inputs + ++ map Option ( + lib_path_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + _ | os == OSDarwin -> do + ------------------------------------------------------------------- + -- Making a darwin dylib + ------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct + -- dependencies for each of the dylibs. Note that we could + -- (and should) do without this for all libraries except + -- the RTS; all we need to do is to pass the correct + -- HSfoo_dyn.dylib files to the link command. + -- This feature requires Mac OS X 10.3 or later; there is + -- a similar feature, -flat_namespace -undefined suppress, + -- which works on earlier versions, but it has other + -- disadvantages. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no + -- dynamic binding nonsense when referring to symbols from + -- within the library. The NCG assumes that this option is + -- specified (on i386, at least). + -- -install_name + -- Mac OS/X stores the path where a dynamic library is (to + -- be) installed in the library itself. It's called the + -- "install name" of the library. Then any library or + -- executable that links against it before it's installed + -- will search for it in its ultimate install location. + -- By default we set the install name to the absolute path + -- at build time, but it can be overridden by the + -- -dylib-install-name option passed to ghc. Cabal does + -- this. + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) + runLink dflags ( + map Option verbFlags + ++ [ Option "-dynamiclib" + , Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-undefined", + Option "dynamic_lookup", + Option "-single_module" ] + ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ] + then [ ] + else [ Option "-Wl,-read_only_relocs,suppress" ]) + ++ [ Option "-install_name", Option instName ] + ++ map Option lib_path_opts + ++ extra_ld_inputs + ++ map Option framework_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ++ map Option pkg_framework_opts + -- dead_strip_dylibs, will remove unused dylibs, and thus save + -- space in the load commands. The -headerpad is necessary so + -- that we can inject more @rpath's later for the leftover + -- libraries in the runInjectRpaths phase below. + -- + -- See Note [Dynamic linking on macOS] + ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] + ) + runInjectRPaths dflags pkg_lib_paths output_fn + _ -> do + ------------------------------------------------------------------- + -- Making a DSO + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + unregisterised = platformUnregisterised (targetPlatform dflags) + let bsymbolicFlag = -- we need symbolic linking to resolve + -- non-PIC intra-package-relocations for + -- performance (where symbolic linking works) + -- See Note [-Bsymbolic assumptions by GHC] + ["-Wl,-Bsymbolic" | not unregisterised] + + runLink dflags ( + map Option verbFlags + ++ libmLinkOpts + ++ [ Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-shared" ] + ++ map Option bsymbolicFlag + -- Set the library soname. We use -h rather than -soname as + -- Solaris 10 doesn't support the latter: + ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] + ++ extra_ld_inputs + ++ map Option lib_path_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) + +-- | Some platforms require that we explicitly link against @libm@ if any +-- math-y things are used (which we assume to include all programs). See #14022. +libmLinkOpts :: [Option] +libmLinkOpts = +#if defined(HAVE_LIBM) + [Option "-lm"] +#else + [] +#endif + +getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String] +getUnitFrameworkOpts dflags platform dep_packages + | platformUsesFrameworks platform = do + pkg_framework_path_opts <- do + pkg_framework_paths <- getUnitFrameworkPath dflags dep_packages + return $ map ("-F" ++) pkg_framework_paths + + pkg_framework_opts <- do + pkg_frameworks <- getUnitFrameworks dflags dep_packages + return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] + + return (pkg_framework_path_opts ++ pkg_framework_opts) + + | otherwise = return [] + +getFrameworkOpts :: DynFlags -> Platform -> [String] +getFrameworkOpts dflags platform + | platformUsesFrameworks platform = framework_path_opts ++ framework_opts + | otherwise = [] + where + framework_paths = frameworkPaths dflags + framework_path_opts = map ("-F" ++) framework_paths + + frameworks = cmdlineFrameworks dflags + -- reverse because they're added in reverse order from the cmd line: + framework_opts = concat [ ["-framework", fw] + | fw <- reverse frameworks ] + +{- +Note [-Bsymbolic assumptions by GHC] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC has a few assumptions about interaction of relocations in NCG and linker: + +1. -Bsymbolic resolves internal references when the shared library is linked, + which is important for performance. +2. When there is a reference to data in a shared library from the main program, + the runtime linker relocates the data object into the main program using an + R_*_COPY relocation. +3. If we used -Bsymbolic, then this results in multiple copies of the data + object, because some references have already been resolved to point to the + original instance. This is bad! + +We work around [3.] for native compiled code by avoiding the generation of +R_*_COPY relocations. + +Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable +-Bsymbolic linking there. + +See related tickets: #4210, #15338 +-} diff --git a/GHC/SysTools/Ar.hs b/GHC/SysTools/Ar.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Ar.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-} +{- Note: [The need for Ar.hs] +Building `-staticlib` required the presence of libtool, and was a such +restricted to mach-o only. As libtool on macOS and gnu libtool are very +different, there was no simple portable way to support this. + +libtool for static archives does essentially: concatinate the input archives, +add the input objects, and create a symbol index. Using `ar` for this task +fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same +features across platforms (e.g. index prefixed retrieval of objects with +the same name.) + +As Archives are rather simple structurally, we can just build the archives +with Haskell directly and use ranlib on the final result to get the symbol +index. This should allow us to work around with the differences/abailability +of libtool across different platforms. +-} +module GHC.SysTools.Ar + (ArchiveEntry(..) + ,Archive(..) + ,afilter + + ,parseAr + + ,loadAr + ,loadObj + ,writeBSDAr + ,writeGNUAr + + ,isBSDSymdef + ,isGNUSymdef + ) + where + +import GHC.Prelude + +import Data.List (mapAccumL, isPrefixOf) +import Data.Monoid ((<>)) +import Data.Binary.Get +import Data.Binary.Put +import Control.Monad +import Control.Applicative +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Files as POSIX +#endif +import System.FilePath (takeFileName) + +data ArchiveEntry = ArchiveEntry + { filename :: String -- ^ File name. + , filetime :: Int -- ^ File modification time. + , fileown :: Int -- ^ File owner. + , filegrp :: Int -- ^ File group. + , filemode :: Int -- ^ File mode. + , filesize :: Int -- ^ File size. + , filedata :: B.ByteString -- ^ File bytes. + } deriving (Eq, Show) + +newtype Archive = Archive [ArchiveEntry] + deriving (Eq, Show, Semigroup, Monoid) + +afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive +afilter f (Archive xs) = Archive (filter f xs) + +isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool +isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a) +isGNUSymdef a = "/" == (filename a) + +-- | Archives have numeric values padded with '\x20' to the right. +getPaddedInt :: B.ByteString -> Int +getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20') + +putPaddedInt :: Int -> Int -> Put +putPaddedInt padding i = putPaddedString '\x20' padding (show i) + +putPaddedString :: Char -> Int -> String -> Put +putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad) + +getBSDArchEntries :: Get [ArchiveEntry] +getBSDArchEntries = do + empty <- isEmpty + if empty then + return [] + else do + name <- getByteString 16 + when ('/' `C.elem` name && C.take 3 name /= "#1/") $ + fail "Looks like GNU Archive" + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + off1 <- liftM fromIntegral bytesRead :: Get Int + -- BSD stores extended filenames, by writing #1/ into the + -- name field, the first @length@ bytes then represent the file name + -- thus the payload size is filesize + file name length. + name <- if C.unpack (C.take 3 name) == "#1/" then + liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name) + else + return $ C.unpack $ C.takeWhile (/= ' ') name + off2 <- liftM fromIntegral bytesRead :: Get Int + file <- getByteString (st_size - (off2 - off1)) + -- data sections are two byte aligned (see #15396) + when (odd st_size) $ + void (getByteString 1) + + rest <- getBSDArchEntries + return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest + +-- | GNU Archives feature a special '//' entry that contains the +-- extended names. Those are referred to as /, where num is the +-- offset into the '//' entry. +-- In addition, filenames are terminated with '/' in the archive. +getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry] +getGNUArchEntries extInfo = do + empty <- isEmpty + if empty + then return [] + else + do + name <- getByteString 16 + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + file <- getByteString st_size + -- data sections are two byte aligned (see #15396) + when (odd st_size) $ + void (getByteString 1) + name <- return . C.unpack $ + if C.unpack (C.take 1 name) == "/" + then case C.takeWhile (/= ' ') name of + name@"/" -> name -- symbol table + name@"//" -> name -- extendedn file names table + name -> getExtName extInfo (read . C.unpack $ C.drop 1 name) + else C.takeWhile (/= '/') name + case name of + "/" -> getGNUArchEntries extInfo + "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file)) + _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo + + where + getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString + getExtName Nothing _ = error "Invalid extended filename reference." + getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info + +-- | put an Archive Entry. This assumes that the entries +-- have been preprocessed to account for the extenden file name +-- table section "//" e.g. for GNU Archives. Or that the names +-- have been move into the payload for BSD Archives. +putArchEntry :: ArchiveEntry -> PutM () +putArchEntry (ArchiveEntry name time own grp mode st_size file) = do + putPaddedString ' ' 16 name + putPaddedInt 12 time + putPaddedInt 6 own + putPaddedInt 6 grp + putPaddedInt 8 mode + putPaddedInt 10 (st_size + pad) + putByteString "\x60\x0a" + putByteString file + when (pad == 1) $ + putWord8 0x0a + where + pad = st_size `mod` 2 + +getArchMagic :: Get () +getArchMagic = do + magic <- liftM C.unpack $ getByteString 8 + if magic /= "!\n" + then fail $ "Invalid magic number " ++ show magic + else return () + +putArchMagic :: Put +putArchMagic = putByteString $ C.pack "!\n" + +getArch :: Get Archive +getArch = Archive <$> do + getArchMagic + getBSDArchEntries <|> getGNUArchEntries Nothing + +putBSDArch :: Archive -> PutM () +putBSDArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + padStr pad size str = take size $ str <> repeat pad + nameSize name = case length name `divMod` 4 of + (n, 0) -> 4 * n + (n, _) -> 4 * (n + 1) + needExt name = length name > 16 || ' ' `elem` name + processEntry :: ArchiveEntry -> ArchiveEntry + processEntry archive@(ArchiveEntry name _ _ _ _ st_size _) + | needExt name = archive { filename = "#1/" <> show sz + , filedata = C.pack (padStr '\0' sz name) <> filedata archive + , filesize = st_size + sz } + | otherwise = archive + + where sz = nameSize name + + processEntries = map processEntry + +putGNUArch :: Archive -> PutM () +putGNUArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry) + processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _) + | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2 + , filedata = filedata extInfo <> C.pack name <> "/\n" } + , archive { filename = "/" <> show (filesize extInfo) } ) + | otherwise = ( extInfo, archive { filename = name <> "/" } ) + + processEntries :: [ArchiveEntry] -> [ArchiveEntry] + processEntries = + uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty) + +parseAr :: B.ByteString -> Archive +parseAr = runGet getArch . L.fromChunks . pure + +writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO () +writeBSDAr fp = L.writeFile fp . runPut . putBSDArch +writeGNUAr fp = L.writeFile fp . runPut . putGNUArch + +loadAr :: FilePath -> IO Archive +loadAr fp = parseAr <$> B.readFile fp + +loadObj :: FilePath -> IO ArchiveEntry +loadObj fp = do + payload <- B.readFile fp + (modt, own, grp, mode) <- fileInfo fp + return $ ArchiveEntry + (takeFileName fp) modt own grp mode + (B.length payload) payload + +-- | Take a filePath and return (mod time, own, grp, mode in decimal) +fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal) +#if defined(mingw32_HOST_OS) +-- on windows mod time, owner group and mode are zero. +fileInfo _ = pure (0,0,0,0) +#else +fileInfo fp = go <$> POSIX.getFileStatus fp + where go status = ( fromEnum $ POSIX.modificationTime status + , fromIntegral $ POSIX.fileOwner status + , fromIntegral $ POSIX.fileGroup status + , oct2dec . fromIntegral $ POSIX.fileMode status + ) + +oct2dec :: Int -> Int +oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8 + where dec _ 0 = [] + dec b i = let (rest, last) = i `quotRem` b + in last:dec b rest + +#endif diff --git a/GHC/SysTools/BaseDir.hs b/GHC/SysTools/BaseDir.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/BaseDir.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2017 +-- +-- Finding the compiler's base directory. +-- +----------------------------------------------------------------------------- +-} + +module GHC.SysTools.BaseDir + ( expandTopDir, expandToolDir + , findTopDir, findToolDir + , tryFindTopDir + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +-- See note [Base Dir] for why some of this logic is shared with ghc-pkg. +import GHC.BaseDir + +import GHC.Utils.Panic + +import System.Environment (lookupEnv) +import System.FilePath + +-- Windows +#if defined(mingw32_HOST_OS) +import System.Directory (doesDirectoryExist) +#endif + +{- +Note [topdir: How GHC finds its files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC needs various support files (library packages, RTS etc), plus +various auxiliary programs (cp, gcc, etc). It starts by finding topdir, +the root of GHC's support files + +On Unix: + - ghc always has a shell wrapper that passes a -B option + +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir//.exe + where may be "ghc", "ghc-stage2", or similar + - we strip off the "/.exe" to leave $topdir. + +from topdir we can find package.conf, ghc-asm, etc. + + +Note [tooldir: How GHC finds mingw on Windows] + +GHC has some custom logic on Windows for finding the mingw +toolchain and perl. Depending on whether GHC is built +with the make build system or Hadrian, and on whether we're +running a bindist, we might find the mingw toolchain +either under $topdir/../{mingw, perl}/ or +$topdir/../../{mingw, perl}/. + +This story is long and with lots of twist and turns.. But lets talk about how +the build system finds and wires through the toolchain information. + +1) It all starts in configure.ac which has two modes it operates on: + a) The default is where `EnableDistroToolchain` is false. This indicates + that we want to use the in-tree bundled toolchains. In this mode we will + download and unpack some custom toolchains into the `inplace/mingw` folder + and everything is pointed to that folder. + b) The second path is when `EnableDistroToolchain` is true. This makes the + toolchain behave a lot like Linux, in that the environment is queried for + information on the tools we require. + + From configure.ac we export the standard variables to set the paths to the + tools for the build system to use. + +2) After we have the path to the tools we have to generate the right paths to + store in the settings file for ghc to use. This is done in aclocal.m4. + Again we have two modes of operation: + a) If not `EnableDistroToolchain` the paths are rewritten to paths using a + variable `$tooldir` as we need an absolute path. $tooldir is filled in by + the `expandToolDir` function in this module at GHC startup. + b) When `EnableDistroToolchain` then instead of filling in a absolute path + we fill in just the program name. The assumption here is that at runtime + the environment GHC is operating on will be the same as the one configure + was run in. This means we expect `gcc, ld, as` etc to be on the PATH. + + From `aclocal.m4` we export a couple of variables starting with `Settings` + which will be used to generate the settings file. + +3) The next step is to generate the settings file, this is where things diverge + based on the build system. Both Make and Hadrian handle this differently: + +make) + Make deals with this rather simply. As an output of configure.ac + `config.mk.in` is processed and `config.mk` generated which has the values we + set in `aclocal.m4`. This allows the rest of the build system to have access + to these and other values determined by configure. + + Based on this file, `includes/ghc.mk` when ran will produce the settings file + by echoing the values into a the final file. Coincidentally this is also + where `ghcplatform.h` and `ghcversion.h` generated which contains information + about the build platform and sets CPP for use by the entire build. + +hadrian) + For hadrian the file `cfg/system.config.in` is preprocessed by configure and + the output written to `system.config`. This serves the same purpose as + `config.mk` but it rewrites the values that were exported. As an example + `SettingsCCompilerCommand` is rewritten to `settings-c-compiler-command`. + + Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to + the settings `keys` in the `system.config`. As an example, + `settings-c-compiler-command` is mapped to + `SettingsFileSetting_CCompilerCommand`. + + The last part of this is the `generateSettings` in `src/Rules/Generate.hs` + which produces the desired settings file out of Hadrian. This is the + equivalent to `includes/ghc.mk`. + +-- + +So why do we have these? On Windows there's no such thing as a platform compiler +and as such we need to provide GCC and binutils. The easiest way is to bundle +these with the compiler and wire them up. This gives you a relocatable +binball. This works fine for most users. However mingw-w64 have a different +requirement. They require all packages in the repo to be compiled using the +same version of the compiler. So it means when they are rebuilding the world to +add support for GCC X, they expect all packages to have been compiled with GCC X +which is a problem since we ship an older GCC version. + +GHC is a package in mingw-w64 because there are Haskell packages in the +repository which of course requires a Haskell compiler. To help them we +provide the override which allows GHC to instead of using an inplace compiler to +play nice with the system compiler instead. +-} + +-- | Expand occurrences of the @$tooldir@ interpolation in a string +-- on Windows, leave the string untouched otherwise. +expandToolDir :: Maybe FilePath -> String -> String +#if defined(mingw32_HOST_OS) && !defined(USE_INPLACE_MINGW_TOOLCHAIN) +expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s +expandToolDir Nothing _ = panic "Could not determine $tooldir" +#else +expandToolDir _ s = s +#endif + +-- | Returns a Unix-format path pointing to TopDir. +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO String -- TopDir (in Unix format '/' separated) +findTopDir m_minusb = do + maybe_exec_dir <- tryFindTopDir m_minusb + case maybe_exec_dir of + -- "Just" on Windows, "Nothing" on unix + Nothing -> throwGhcExceptionIO $ + InstallationError "missing -B option" + Just dir -> return dir + +tryFindTopDir + :: Maybe String -- ^ Maybe TopDir path (without the '-B' prefix). + -> IO (Maybe String) -- ^ TopDir (in Unix format '/' separated) +tryFindTopDir (Just minusb) = return $ Just $ normalise minusb +tryFindTopDir Nothing + = do -- The _GHC_TOP_DIR environment variable can be used to specify + -- the top dir when the -B argument is not specified. It is not + -- intended for use by users, it was added specifically for the + -- purpose of running GHC within GHCi. + maybe_env_top_dir <- lookupEnv "_GHC_TOP_DIR" + case maybe_env_top_dir of + Just env_top_dir -> return $ Just env_top_dir + -- Try directory of executable + Nothing -> getBaseDir + + +-- See Note [tooldir: How GHC finds mingw on Windows] +-- Returns @Nothing@ when not on Windows. +-- When called on Windows, it either throws an error when the +-- tooldir can't be located, or returns @Just tooldirpath@. +-- If the distro toolchain is being used we treat Windows the same as Linux +findToolDir + :: FilePath -- ^ topdir + -> IO (Maybe FilePath) +#if defined(mingw32_HOST_OS) && !defined(USE_INPLACE_MINGW_TOOLCHAIN) +findToolDir top_dir = go 0 (top_dir "..") + where maxDepth = 3 + go :: Int -> FilePath -> IO (Maybe FilePath) + go k path + | k == maxDepth = throwGhcExceptionIO $ + InstallationError "could not detect mingw toolchain" + | otherwise = do + oneLevel <- doesDirectoryExist (path "mingw") + if oneLevel + then return (Just path) + else go (k+1) (path "..") +#else +findToolDir _ = return Nothing +#endif diff --git a/GHC/SysTools/Elf.hs b/GHC/SysTools/Elf.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Elf.hs @@ -0,0 +1,460 @@ +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2015 +-- +-- ELF format tools +-- +----------------------------------------------------------------------------- +-} + +module GHC.SysTools.Elf ( + readElfSectionByName, + readElfNoteAsString, + makeElfNote + ) where + +import GHC.Prelude + +import GHC.Utils.Asm +import GHC.Utils.Exception +import GHC.Driver.Session +import GHC.Platform +import GHC.Utils.Error +import GHC.Data.Maybe (MaybeT(..),runMaybeT) +import GHC.Utils.Misc (charToC) +import GHC.Utils.Outputable (text,hcat,SDoc) + +import Control.Monad (when) +import Data.Binary.Get +import Data.Word +import Data.Char (ord) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as B8 + +{- Note [ELF specification] + ~~~~~~~~~~~~~~~~~~~~~~~~ + + ELF (Executable and Linking Format) is described in the System V Application + Binary Interface (or ABI). The latter is composed of two parts: a generic + part and a processor specific part. The generic ABI describes the parts of + the interface that remain constant across all hardware implementations of + System V. + + The latest release of the specification of the generic ABI is the version + 4.1 from March 18, 1997: + + - http://www.sco.com/developers/devspecs/gabi41.pdf + + Since 1997, snapshots of the draft for the "next" version are published: + + - http://www.sco.com/developers/gabi/ + + Quoting the notice on the website: "There is more than one instance of these + chapters to permit references to older instances to remain valid. All + modifications to these chapters are forward-compatible, so that correct use + of an older specification will not be invalidated by a newer instance. + Approximately on a yearly basis, a new instance will be saved, as it reaches + what appears to be a stable state." + + Nevertheless we will see that since 1998 it is not true for Note sections. + + Many ELF sections + ----------------- + + ELF-4.1: the normal section number fields in ELF are limited to 16 bits, + which runs out of bits when you try to cram in more sections than that. Two + fields are concerned: the one containing the number of the sections and the + one containing the index of the section that contains section's names. (The + same thing applies to the field containing the number of segments, but we + don't care about it here). + + ELF-next: to solve this, theses fields in the ELF header have an escape + value (different for each case), and the actual section number is stashed + into unused fields in the first section header. + + We support this extension as it is forward-compatible with ELF-4.1. + Moreover, GHC may generate objects with a lot of sections with the + "function-sections" feature (one section per function). + + Note sections + ------------- + + Sections with type "note" (SHT_NOTE in the specification) are used to add + arbitrary data into an ELF file. An entry in a note section is composed of a + name, a type and a value. + + ELF-4.1: "The note information in sections and program header elements holds + any number of entries, each of which is an array of 4-byte words in the + format of the target processor." Each entry has the following format: + | namesz | Word32: size of the name string (including the ending \0) + | descsz | Word32: size of the value + | type | Word32: type of the note + | name | Name string (with \0 padding to ensure 4-byte alignment) + | ... | + | desc | Value (with \0 padding to ensure 4-byte alignment) + | ... | + + ELF-next: "The note information in sections and program header elements + holds a variable amount of entries. In 64-bit objects (files with + e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte + words in the format of the target processor. In 32-bit objects (files with + e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte + words in the format of the target processor." (from 1998-2015 snapshots) + + This is not forward-compatible with ELF-4.1. In practice, for almost all + platforms namesz, descz and type fields are 4-byte words for both 32-bit and + 64-bit objects (see elf.h and readelf source code). + + The only exception in readelf source code is for IA_64 machines with OpenVMS + OS: "This OS has so many departures from the ELF standard that we test it at + many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz, + descsz and type fields are 8-byte words and name and value fields are padded + to ensure 8-byte alignment. + + We don't support this platform in the following code. Reading a note section + could be done easily (by testing Machine and OS fields in the ELF header). + Writing a note section, however, requires that we generate a different + assembly code for GAS depending on the target platform and this is a little + bit more involved. + +-} + + +-- | ELF header +-- +-- The ELF header indicates the native word size (32-bit or 64-bit) and the +-- endianness of the target machine. We directly store getters for words of +-- different sizes as it is more convenient to use. We also store the word size +-- as it is useful to skip some uninteresting fields. +-- +-- Other information such as the target machine and OS are left out as we don't +-- use them yet. We could add them in the future if we ever need them. +data ElfHeader = ElfHeader + { gw16 :: Get Word16 -- ^ Get a Word16 with the correct endianness + , gw32 :: Get Word32 -- ^ Get a Word32 with the correct endianness + , gwN :: Get Word64 -- ^ Get a Word with the correct word size + -- and endianness + , wordSize :: Int -- ^ Word size in bytes + } + + +-- | Read the ELF header +readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader) +readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF header") + return Nothing + where + getHeader = do + magic <- getWord32be + ws <- getWord8 + endian <- getWord8 + version <- getWord8 + skip 9 -- skip OSABI, ABI version and padding + when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header" + + case (ws, endian) of + -- ELF 32, little endian + (1,1) -> return . Just $ ElfHeader + getWord16le + getWord32le + (fmap fromIntegral getWord32le) 4 + -- ELF 32, big endian + (1,2) -> return . Just $ ElfHeader + getWord16be + getWord32be + (fmap fromIntegral getWord32be) 4 + -- ELF 64, little endian + (2,1) -> return . Just $ ElfHeader + getWord16le + getWord32le + (fmap fromIntegral getWord64le) 8 + -- ELF 64, big endian + (2,2) -> return . Just $ ElfHeader + getWord16be + getWord32be + (fmap fromIntegral getWord64be) 8 + _ -> fail "Invalid ELF header" + + +------------------ +-- SECTIONS +------------------ + + +-- | Description of the section table +data SectionTable = SectionTable + { sectionTableOffset :: Word64 -- ^ offset of the table describing sections + , sectionEntrySize :: Word16 -- ^ size of an entry in the section table + , sectionEntryCount :: Word64 -- ^ number of sections + , sectionNameIndex :: Word32 -- ^ index of a special section which + -- contains section's names + } + +-- | Read the ELF section table +readElfSectionTable :: DynFlags + -> ElfHeader + -> ByteString + -> IO (Maybe SectionTable) + +readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF section table") + return Nothing + where + getSectionTable :: Get SectionTable + getSectionTable = do + skip (24 + 2*wordSize hdr) -- skip header and some other fields + secTableOffset <- gwN hdr + skip 10 + entrySize <- gw16 hdr + entryCount <- gw16 hdr + secNameIndex <- gw16 hdr + return (SectionTable secTableOffset entrySize + (fromIntegral entryCount) + (fromIntegral secNameIndex)) + + action = do + secTable <- runGetOrThrow getSectionTable bs + -- In some cases, the number of entries and the index of the section + -- containing section's names must be found in unused fields of the first + -- section entry (see Note [ELF specification]) + let + offSize0 = fromIntegral $ sectionTableOffset secTable + 8 + + 3 * fromIntegral (wordSize hdr) + offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr) + + entryCount' <- if sectionEntryCount secTable /= 0 + then return (sectionEntryCount secTable) + else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs) + entryNameIndex' <- if sectionNameIndex secTable /= 0xffff + then return (sectionNameIndex secTable) + else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs) + return (Just $ secTable + { sectionEntryCount = entryCount' + , sectionNameIndex = entryNameIndex' + }) + + +-- | A section +data Section = Section + { entryName :: ByteString -- ^ Name of the section + , entryBS :: ByteString -- ^ Content of the section + } + +-- | Read a ELF section +readElfSectionByIndex :: DynFlags + -> ElfHeader + -> SectionTable + -> Word64 + -> ByteString + -> IO (Maybe Section) + +readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF section") + return Nothing + where + -- read an entry from the section table + getEntry = do + nameIndex <- gw32 hdr + skip (4+2*wordSize hdr) + offset <- fmap fromIntegral $ gwN hdr + size <- fmap fromIntegral $ gwN hdr + let bs' = LBS.take size (LBS.drop offset bs) + return (nameIndex,bs') + + -- read the entry with the given index in the section table + getEntryByIndex x = runGetOrThrow getEntry bs' + where + bs' = LBS.drop off bs + off = fromIntegral $ sectionTableOffset secTable + + x * fromIntegral (sectionEntrySize secTable) + + -- Get the name of a section + getEntryName nameIndex = do + let idx = fromIntegral (sectionNameIndex secTable) + (_,nameTable) <- getEntryByIndex idx + let bs' = LBS.drop nameIndex nameTable + runGetOrThrow getLazyByteStringNul bs' + + action = do + (nameIndex,bs') <- getEntryByIndex (fromIntegral i) + name <- getEntryName (fromIntegral nameIndex) + return (Just $ Section name bs') + + +-- | Find a section from its name. Return the section contents. +-- +-- We do not perform any check on the section type. +findSectionFromName :: DynFlags + -> ElfHeader + -> SectionTable + -> String + -> ByteString + -> IO (Maybe ByteString) +findSectionFromName dflags hdr secTable name bs = + rec [0..sectionEntryCount secTable - 1] + where + -- convert the required section name into a ByteString to perform + -- ByteString comparison instead of String comparison + name' = B8.pack name + + -- compare recursively each section name and return the contents of + -- the matching one, if any + rec [] = return Nothing + rec (x:xs) = do + me <- readElfSectionByIndex dflags hdr secTable x bs + case me of + Just e | entryName e == name' -> return (Just (entryBS e)) + _ -> rec xs + + +-- | Given a section name, read its contents as a ByteString. +-- +-- If the section isn't found or if there is any parsing error, we return +-- Nothing +readElfSectionByName :: DynFlags + -> ByteString + -> String + -> IO (Maybe LBS.ByteString) + +readElfSectionByName dflags bs name = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF section \"" ++ name ++ "\"") + return Nothing + where + action = runMaybeT $ do + hdr <- MaybeT $ readElfHeader dflags bs + secTable <- MaybeT $ readElfSectionTable dflags hdr bs + MaybeT $ findSectionFromName dflags hdr secTable name bs + +------------------ +-- NOTE SECTIONS +------------------ + +-- | read a Note as a ByteString +-- +-- If you try to read a note from a section which does not support the Note +-- format, the parsing is likely to fail and Nothing will be returned +readElfNoteBS :: DynFlags + -> ByteString + -> String + -> String + -> IO (Maybe LBS.ByteString) + +readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF note \"" ++ noteId ++ + "\" in section \"" ++ sectionName ++ "\"") + return Nothing + where + -- align the getter on n bytes + align n = do + m <- bytesRead + if m `mod` n == 0 + then return () + else skip 1 >> align n + + -- noteId as a bytestring + noteId' = B8.pack noteId + + -- read notes recursively until the one with a valid identifier is found + findNote hdr = do + align 4 + namesz <- gw32 hdr + descsz <- gw32 hdr + _ <- gw32 hdr -- we don't use the note type + name <- if namesz == 0 + then return LBS.empty + else getLazyByteStringNul + align 4 + desc <- if descsz == 0 + then return LBS.empty + else getLazyByteString (fromIntegral descsz) + if name == noteId' + then return $ Just desc + else findNote hdr + + + action = runMaybeT $ do + hdr <- MaybeT $ readElfHeader dflags bs + sec <- MaybeT $ readElfSectionByName dflags bs sectionName + MaybeT $ runGetOrThrow (findNote hdr) sec + +-- | read a Note as a String +-- +-- If you try to read a note from a section which does not support the Note +-- format, the parsing is likely to fail and Nothing will be returned +readElfNoteAsString :: DynFlags + -> FilePath + -> String + -> String + -> IO (Maybe String) + +readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg dflags 3 $ + text ("Unable to read ELF note \"" ++ noteId ++ + "\" in section \"" ++ sectionName ++ "\"") + return Nothing + where + action = do + bs <- LBS.readFile path + note <- readElfNoteBS dflags bs sectionName noteId + return (fmap B8.unpack note) + + +-- | Generate the GAS code to create a Note section +-- +-- Header fields for notes are 32-bit long (see Note [ELF specification]). +makeElfNote :: Platform -> String -> String -> Word32 -> String -> SDoc +makeElfNote platform sectionName noteName typ contents = hcat [ + text "\t.section ", + text sectionName, + text ",\"\",", + sectionType platform "note", + text "\n", + text "\t.balign 4\n", + + -- note name length (+ 1 for ending \0) + asWord32 (length noteName + 1), + + -- note contents size + asWord32 (length contents), + + -- note type + asWord32 typ, + + -- note name (.asciz for \0 ending string) + padding + text "\t.asciz \"", + text noteName, + text "\"\n", + text "\t.balign 4\n", + + -- note contents (.ascii to avoid ending \0) + padding + text "\t.ascii \"", + text (escape contents), + text "\"\n", + text "\t.balign 4\n"] + where + escape :: String -> String + escape = concatMap (charToC.fromIntegral.ord) + + asWord32 :: Show a => a -> SDoc + asWord32 x = hcat [ + text "\t.4byte ", + text (show x), + text "\n"] + + +------------------ +-- Helpers +------------------ + +-- | runGet in IO monad that throws an IOException on failure +runGetOrThrow :: Get a -> LBS.ByteString -> IO a +runGetOrThrow g bs = case runGetOrFail g bs of + Left _ -> fail "Error while reading file" + Right (_,_,a) -> return a diff --git a/GHC/SysTools/ExtraObj.hs b/GHC/SysTools/ExtraObj.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/ExtraObj.hs @@ -0,0 +1,246 @@ +----------------------------------------------------------------------------- +-- +-- GHC Extra object linking code +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- + +module GHC.SysTools.ExtraObj ( + mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, + checkLinkInfo, getLinkInfo, getCompilerInfo, + ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts, + haveRtsOptsFlags +) where + +import GHC.Utils.Asm +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Unit.State +import GHC.Platform +import GHC.Utils.Outputable as Outputable +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Unit +import GHC.SysTools.Elf +import GHC.Utils.Misc +import GHC.Prelude + +import Control.Monad +import Data.Maybe + +import Control.Monad.IO.Class + +import GHC.SysTools.FileCleanup +import GHC.SysTools.Tasks +import GHC.SysTools.Info + +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags TFL_CurrentModule extn + oFile <- newTempName dflags TFL_GhcSession "o" + writeFile cFile xs + ccInfo <- liftIO $ getCompilerInfo dflags + runCc Nothing dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else asmOpts ccInfo) + return oFile + where + pkgs = unitState dflags + + -- Pass a different set of options to the C compiler depending one whether + -- we're compiling C or assembler. When compiling C, we pass the usual + -- set of include directories and PIC flags. + cOpts = map Option (picCCOpts dflags) + ++ map (FileOption "-I") + (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit) + + -- When compiling assembler code, we drop the usual C options, and if the + -- compiler is Clang, we add an extra argument to tell Clang to ignore + -- unused command line options. See trac #11684. + asmOpts ccInfo = + if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [Option "-Qunused-arguments"] + else [] + +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +-- +-- On Windows, when making a shared library we also may need a DllMain. +-- +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do + when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do + putLogMsg dflags NoReason SevInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + mkExtraObj dflags "c" (showSDoc dflags main) + where + main + | gopt Opt_NoHsMain dflags = Outputable.empty + | otherwise + = case ghcLink dflags of + LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 + then dllMain + else Outputable.empty + _ -> exeMain + + exeMain = vcat [ + text "#include ", + text "extern StgClosure ZCMain_main_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (rtsOptsEnabled dflags)) <> semi, + text " __conf.rts_opts_suggestions = " + <> text (if rtsOptsSuggestions dflags + then "true" + else "false") <> semi, + text "__conf.keep_cafs = " + <> text (if gopt Opt_KeepCAFs dflags + then "true" + else "false") <> semi, + case rtsOpts dflags of + Nothing -> Outputable.empty + Just opts -> text " __conf.rts_opts= " <> + text (show opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + + dllMain = vcat [ + text "#include ", + text "#include ", + text "#include ", + char '\n', + text "bool", + text "WINAPI", + text "DllMain ( HINSTANCE hInstance STG_UNUSED", + text " , DWORD reason STG_UNUSED", + text " , LPVOID reserved STG_UNUSED", + text " )", + text "{", + text " return true;", + text "}", + char '\n' -- final newline, to keep gcc happy + ] + +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS platform )) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + platform = targetPlatform dflags + link_opts info = hcat [ + -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- "GHC.CmmToAsm" for another instance + -- where we need to do this. + if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," + <> sectionType platform "progbits" <> char '\n' + else Outputable.empty + ] + +-- | Return the "link info" string +-- +-- See Note [LinkInfo section] +getLinkInfo :: DynFlags -> [UnitId] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getUnitLinkOpts dflags dep_packages + pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) + then getUnitFrameworks dflags dep_packages + else return [] + let extra_ld_inputs = ldInputs dflags + let + link_info = (package_link_opts, + pkg_frameworks, + rtsOpts dflags, + rtsOptsEnabled dflags, + gopt Opt_NoHsMain dflags, + map showOpt extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +-- See Note [LinkInfo section] +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +-- Identifier for the note (see Note [LinkInfo section]) +ghcLinkInfoNoteName :: String +ghcLinkInfoNoteName = "GHC link info" + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString dflags exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just link_info == m_exe_link_info) + debugTraceMsg dflags 3 $ case m_exe_link_info of + Nothing -> text "Exe link info: Not found" + Just s + | sameLinkInfo -> text ("Exe link info is the same") + | otherwise -> text ("Exe link info is different: " ++ s) + return (not sameLinkInfo) + +{- Note [LinkInfo section] + ~~~~~~~~~~~~~~~~~~~~~~~ + +The "link info" is a string representing the parameters of the link. We save +this information in the binary, and the next time we link, if nothing else has +changed, we use the link info stored in the existing binary to decide whether +to re-link or not. + +The "link info" string is stored in a ELF section called ".debug-ghc-link-info" +(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to +not follow the specified record-based format (see #11022). + +-} + +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True diff --git a/GHC/SysTools/FileCleanup.hs b/GHC/SysTools/FileCleanup.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/FileCleanup.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE CPP #-} +module GHC.SysTools.FileCleanup + ( TempFileLifetime(..) + , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles + , addFilesToClean, changeTempFilesLifetime + , newTempName, newTempLibName, newTempDir + , withSystemTempDirectory, withTempDirectory + ) where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Exception as Exception +import GHC.Driver.Phases + +import Control.Monad +import Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.IORef +import System.Directory +import System.FilePath +import System.IO.Error + +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Internals +#endif + +-- | Used when a temp file is created. This determines which component Set of +-- FilesToClean will get the temp file +data TempFileLifetime + = TFL_CurrentModule + -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the + -- end of upweep_mod + | TFL_GhcSession + -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of + -- runGhc(T) + deriving (Show) + +cleanTempDirs :: DynFlags -> IO () +cleanTempDirs dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = dirsToClean dflags + ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) + removeTmpDirs dflags (Map.elems ds) + +-- | Delete all files in @filesToClean dflags@. +cleanTempFiles :: DynFlags -> IO () +cleanTempFiles dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = filesToClean dflags + to_delete <- atomicModifyIORef' ref $ + \FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } -> ( emptyFilesToClean + , Set.toList cm_files ++ Set.toList gs_files) + removeTmpFiles dflags to_delete + +-- | Delete all files in @filesToClean dflags@. That have lifetime +-- TFL_CurrentModule. +-- If a file must be cleaned eventually, but must survive a +-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. +cleanCurrentModuleTempFiles :: DynFlags -> IO () +cleanCurrentModuleTempFiles dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = filesToClean dflags + to_delete <- atomicModifyIORef' ref $ + \ftc@FilesToClean{ftcCurrentModule = cm_files} -> + (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) + removeTmpFiles dflags to_delete + +-- | Ensure that new_files are cleaned on the next call of +-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. +-- If any of new_files are already tracked, they will have their lifetime +-- updated. +addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () +addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $ + \FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } -> case lifetime of + TFL_CurrentModule -> FilesToClean + { ftcCurrentModule = cm_files `Set.union` new_files_set + , ftcGhcSession = gs_files `Set.difference` new_files_set + } + TFL_GhcSession -> FilesToClean + { ftcCurrentModule = cm_files `Set.difference` new_files_set + , ftcGhcSession = gs_files `Set.union` new_files_set + } + where + new_files_set = Set.fromList new_files + +-- | Update the lifetime of files already being tracked. If any files are +-- not being tracked they will be discarded. +changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () +changeTempFilesLifetime dflags lifetime files = do + FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } <- readIORef (filesToClean dflags) + let old_set = case lifetime of + TFL_CurrentModule -> gs_files + TFL_GhcSession -> cm_files + existing_files = [f | f <- files, f `Set.member` old_set] + addFilesToClean dflags lifetime existing_files + +-- Return a unique numeric temp file suffix +newTempSuffix :: DynFlags -> IO Int +newTempSuffix dflags = + atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) + +-- Find a temporary name that doesn't already exist. +newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath +newTempName dflags lifetime extn + = do d <- getTempDir dflags + findTempName (d "ghc_") -- See Note [Deterministic base name] + where + findTempName :: FilePath -> IO FilePath + findTempName prefix + = do n <- newTempSuffix dflags + let filename = prefix ++ show n <.> extn + b <- doesFileExist filename + if b then findTempName prefix + else do -- clean it up later + addFilesToClean dflags lifetime [filename] + return filename + +newTempDir :: DynFlags -> IO FilePath +newTempDir dflags + = do d <- getTempDir dflags + findTempDir (d "ghc_") + where + findTempDir :: FilePath -> IO FilePath + findTempDir prefix + = do n <- newTempSuffix dflags + let filename = prefix ++ show n + b <- doesDirectoryExist filename + if b then findTempDir prefix + else do createDirectory filename + -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename + return filename + +newTempLibName :: DynFlags -> TempFileLifetime -> Suffix + -> IO (FilePath, FilePath, String) +newTempLibName dflags lifetime extn + = do d <- getTempDir dflags + findTempName d ("ghc_") + where + findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) + findTempName dir prefix + = do n <- newTempSuffix dflags -- See Note [Deterministic base name] + let libname = prefix ++ show n + filename = dir "lib" ++ libname <.> extn + b <- doesFileExist filename + if b then findTempName dir prefix + else do -- clean it up later + addFilesToClean dflags lifetime [filename] + return (filename, dir, libname) + + +-- Return our temporary directory within tmp_dir, creating one if we +-- don't have one yet. +getTempDir :: DynFlags -> IO FilePath +getTempDir dflags = do + mapping <- readIORef dir_ref + case Map.lookup tmp_dir mapping of + Nothing -> do + pid <- getProcessID + let prefix = tmp_dir "ghc" ++ show pid ++ "_" + mask_ $ mkTempDir prefix + Just dir -> return dir + where + tmp_dir = tmpDir dflags + dir_ref = dirsToClean dflags + + mkTempDir :: FilePath -> IO FilePath + mkTempDir prefix = do + n <- newTempSuffix dflags + let our_dir = prefix ++ show n + + -- 1. Speculatively create our new directory. + createDirectory our_dir + + -- 2. Update the dirsToClean mapping unless an entry already exists + -- (i.e. unless another thread beat us to it). + their_dir <- atomicModifyIORef' dir_ref $ \mapping -> + case Map.lookup tmp_dir mapping of + Just dir -> (mapping, Just dir) + Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) + + -- 3. If there was an existing entry, return it and delete the + -- directory we created. Otherwise return the directory we created. + case their_dir of + Nothing -> do + debugTraceMsg dflags 2 $ + text "Created temporary directory:" <+> text our_dir + return our_dir + Just dir -> do + removeDirectory our_dir + return dir + `catchIO` \e -> if isAlreadyExistsError e + then mkTempDir prefix else ioError e + +{- Note [Deterministic base name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The filename of temporary files, especially the basename of C files, can end +up in the output in some form, e.g. as part of linker debug information. In the +interest of bit-wise exactly reproducible compilation (#4012), the basename of +the temporary file no longer contains random information (it used to contain +the process id). + +This is ok, as the temporary directory used contains the pid (see getTempDir). +-} +removeTmpDirs :: DynFlags -> [FilePath] -> IO () +removeTmpDirs dflags ds + = traceCmd dflags "Deleting temp dirs" + ("Deleting: " ++ unwords ds) + (mapM_ (removeWith dflags removeDirectory) ds) + +removeTmpFiles :: DynFlags -> [FilePath] -> IO () +removeTmpFiles dflags fs + = warnNon $ + traceCmd dflags "Deleting temp files" + ("Deleting: " ++ unwords deletees) + (mapM_ (removeWith dflags removeFile) deletees) + where + -- Flat out refuse to delete files that are likely to be source input + -- files (is there a worse bug than having a compiler delete your source + -- files?) + -- + -- Deleting source files is a sign of a bug elsewhere, so prominently flag + -- the condition. + warnNon act + | null non_deletees = act + | otherwise = do + putMsg dflags (text "WARNING - NOT deleting source files:" + <+> hsep (map text non_deletees)) + act + + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + +removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith dflags remover f = remover f `catchIO` + (\e -> + let msg = if isDoesNotExistError e + then text "Warning: deleting non-existent" <+> text f + else text "Warning: exception raised when deleting" + <+> text f <> colon + $$ text (show e) + in debugTraceMsg dflags 2 msg + ) + +#if defined(mingw32_HOST_OS) +-- relies on Int == Int32 on Windows +foreign import ccall unsafe "_getpid" getProcessID :: IO Int +#else +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#endif + +-- The following three functions are from the `temporary` package. + +-- | Create and use a temporary directory in the system standard temporary +-- directory. +-- +-- Behaves exactly the same as 'withTempDirectory', except that the parent +-- temporary directory will be that returned by 'getTemporaryDirectory'. +withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withSystemTempDirectory template action = + getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action + + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory :: FilePath -- ^ Temp directory to create the directory in + -> String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withTempDirectory targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (ignoringIOErrors . removeDirectoryRecursive) + +ignoringIOErrors :: IO () -> IO () +ignoringIOErrors ioe = ioe `catchIO` const (return ()) + + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- getProcessID + findTempName pid + where findTempName x = do + let path = dir template ++ show x + createDirectory path + return path + `catchIO` \e -> if isAlreadyExistsError e + then findTempName (x+1) else ioError e diff --git a/GHC/SysTools/Info.hs b/GHC/SysTools/Info.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Info.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Compiler information functions +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Info where + +import GHC.Utils.Exception +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Data.List +import Data.IORef + +import System.IO + +import GHC.Platform +import GHC.Prelude + +import GHC.SysTools.Process + +{- Note [Run-time linker info] + +See also: #5240, #6063, #10110 + +Before 'runLink', we need to be sure to get the relevant information +about the linker we're using at runtime to see if we need any extra +options. For example, GNU ld requires '--reduce-memory-overheads' and +'--hash-size=31' in order to use reasonable amounts of memory (see +trac #5240.) But this isn't supported in GNU gold. + +Generally, the linker changing from what was detected at ./configure +time has always been possible using -pgml, but on Linux it can happen +'transparently' by installing packages like binutils-gold, which +change what /usr/bin/ld actually points to. + +Clang vs GCC notes: + +For gcc, 'gcc -Wl,--version' gives a bunch of output about how to +invoke the linker before the version information string. For 'clang', +the version information for 'ld' is all that's output. For this +reason, we typically need to slurp up all of the standard error output +and look through it. + +Other notes: + +We cache the LinkerInfo inside DynFlags, since clients may link +multiple times. The definition of LinkerInfo is there to avoid a +circular dependency. + +-} + +{- Note [ELF needed shared libs] + +Some distributions change the link editor's default handling of +ELF DT_NEEDED tags to include only those shared objects that are +needed to resolve undefined symbols. For Template Haskell we need +the last temporary shared library also if it is not needed for the +currently linked temporary shared library. We specify --no-as-needed +to override the default. This flag exists in GNU ld and GNU gold. + +The flag is only needed on ELF systems. On Windows (PE) and Mac OS X +(Mach-O) the flag is not needed. + +-} + +{- Note [Windows static libGCC] + +The GCC versions being upgraded to in #10726 are configured with +dynamic linking of libgcc supported. This results in libgcc being +linked dynamically when a shared library is created. + +This introduces thus an extra dependency on GCC dll that was not +needed before by shared libraries created with GHC. This is a particular +issue on Windows because you get a non-obvious error due to this missing +dependency. This dependent dll is also not commonly on your path. + +For this reason using the static libgcc is preferred as it preserves +the same behaviour that existed before. There are however some very good +reasons to have the shared version as well as described on page 181 of +https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : + +"There are several situations in which an application should use the + shared ‘libgcc’ instead of the static version. The most common of these + is when the application wishes to throw and catch exceptions across different + shared libraries. In that case, each of the libraries as well as the application + itself should use the shared ‘libgcc’. " + +-} + +neededLinkArgs :: LinkerInfo -> [Option] +neededLinkArgs (GnuLD o) = o +neededLinkArgs (GnuGold o) = o +neededLinkArgs (LlvmLLD o) = o +neededLinkArgs (DarwinLD o) = o +neededLinkArgs (SolarisLD o) = o +neededLinkArgs (AixLD o) = o +neededLinkArgs UnknownLD = [] + +-- Grab linker info and cache it in DynFlags. +getLinkerInfo :: DynFlags -> IO LinkerInfo +getLinkerInfo dflags = do + info <- readIORef (rtldInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getLinkerInfo' dflags + writeIORef (rtldInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getLinkerInfo' :: DynFlags -> IO LinkerInfo +getLinkerInfo' dflags = do + let platform = targetPlatform dflags + os = platformOS platform + (pgm,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 + args3 = filter notNull (map showOpt args2) + + -- Try to grab the info from the process output. + parseLinkerInfo stdo _stde _exitc + | any ("GNU ld" `isPrefixOf`) stdo = + -- GNU ld specifically needs to use less memory. This especially + -- hurts on small object files. #5240. + -- Set DT_NEEDED for all shared libraries. #10110. + -- TODO: Investigate if these help or hurt when using split sections. + return (GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads", + -- ELF specific flag + -- see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) + + | any ("GNU gold" `isPrefixOf`) stdo = + -- GNU gold only needs --no-as-needed. #10110. + -- ELF specific flag, see Note [ELF needed shared libs] + return (GnuGold [Option "-Wl,--no-as-needed"]) + + | any ("LLD" `isPrefixOf`) stdo = + return (LlvmLLD $ map Option [ + -- see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) + + -- Unknown linker. + | otherwise = fail "invalid --version output, or linker is unsupported" + + -- Process the executable call + info <- catchIO (do + case os of + OSSolaris2 -> + -- Solaris uses its own Solaris linker. Even all + -- GNU C are recommended to configure with Solaris + -- linker instead of using GNU binutils linker. Also + -- all GCC distributed with Solaris follows this rule + -- precisely so we assume here, the Solaris linker is + -- used. + return $ SolarisLD [] + OSAIX -> + -- IBM AIX uses its own non-binutils linker as well + return $ AixLD [] + OSDarwin -> + -- Darwin has neither GNU Gold or GNU LD, but a strange linker + -- that doesn't support --version. We can just assume that's + -- what we're using. + return $ DarwinLD [] + OSMinGW32 -> + -- GHC doesn't support anything but GNU ld on Windows anyway. + -- Process creation is also fairly expensive on win32, so + -- we short-circuit here. + return $ GnuLD $ map Option + [ -- Reduce ld memory usage + "-Wl,--hash-size=31" + , "-Wl,--reduce-memory-overheads" + -- Emit gcc stack checks + -- Note [Windows stack usage] + , "-fstack-check" + -- Force static linking of libGCC + -- Note [Windows static libGCC] + , "-static-libgcc" ] + _ -> do + -- In practice, we use the compiler as the linker here. Pass + -- -Wl,--version to get linker version info. + (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm + (["-Wl,--version"] ++ args3) + c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. In particular, 'clang' and 'gcc' + -- have slightly different outputs for '-Wl,--version', but + -- it's still easy to figure out. + parseLinkerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out linker information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out linker information!" $$ + text "Make sure you're using GNU ld, GNU gold" <+> + text "or the built in OS X linker, etc." + return UnknownLD) + return info + +-- Grab compiler info and cache it in DynFlags. +getCompilerInfo :: DynFlags -> IO CompilerInfo +getCompilerInfo dflags = do + info <- readIORef (rtccInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getCompilerInfo' dflags + writeIORef (rtccInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getCompilerInfo' :: DynFlags -> IO CompilerInfo +getCompilerInfo' dflags = do + let pgm = pgm_c dflags + -- Try to grab the info from the process output. + parseCompilerInfo _stdo stde _exitc + -- Regular GCC + | any ("gcc version" `isInfixOf`) stde = + return GCC + -- Regular clang + | any ("clang version" `isInfixOf`) stde = + return Clang + -- FreeBSD clang + | any ("FreeBSD clang version" `isInfixOf`) stde = + return Clang + -- Xcode 5.1 clang + | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = + return AppleClang51 + -- Xcode 5 clang + | any ("Apple LLVM version" `isPrefixOf`) stde = + return AppleClang + -- Xcode 4.1 clang + | any ("Apple clang version" `isPrefixOf`) stde = + return AppleClang + -- Unknown linker. + | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde + + -- Process the executable call + info <- catchIO (do + (exitc, stdo, stde) <- + readProcessEnvWithExitCode pgm ["-v"] c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. + parseCompilerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out C compiler information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out C compiler information!" $$ + text "Make sure you're using GNU gcc, or clang" + return UnknownCC) + return info diff --git a/GHC/SysTools/Process.hs b/GHC/SysTools/Process.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Process.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Misc process handling code for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Process where + +#include "HsVersions.h" + +import GHC.Utils.Exception +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Prelude +import GHC.Utils.Misc +import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) + +import Control.Concurrent +import Data.Char + +import System.Exit +import System.Environment +import System.FilePath +import System.IO +import System.IO.Error as IO +import System.Process + +import GHC.SysTools.FileCleanup + +-- | Enable process jobs support on Windows if it can be expected to work (e.g. +-- @process >= 1.6.9.0@). +enableProcessJobs :: CreateProcess -> CreateProcess +#if defined(MIN_VERSION_process) +#if MIN_VERSION_process(1,6,9) +enableProcessJobs opts = opts { use_process_jobs = True } +#else +enableProcessJobs opts = opts +#endif +#else +enableProcessJobs opts = opts +#endif + +-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is +-- inherited from the parent process, and output to stderr is not captured. +readCreateProcessWithExitCode' + :: CreateProcess + -> IO (ExitCode, String) -- ^ stdout +readCreateProcessWithExitCode' proc = do + (_, Just outh, _, pid) <- + createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe } + + -- fork off a thread to start consuming the output + output <- hGetContents outh + outMVar <- newEmptyMVar + _ <- forkIO $ evaluate (length output) >> putMVar outMVar () + + -- wait on the output + takeMVar outMVar + hClose outh + + -- wait on the process + ex <- waitForProcess pid + + return (ex, output) + +replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] +replaceVar (var, value) env = + (var, value) : filter (\(var',_) -> var /= var') env + +-- | Version of @System.Process.readProcessWithExitCode@ that takes a +-- key-value tuple to insert into the environment. +readProcessEnvWithExitCode + :: String -- ^ program path + -> [String] -- ^ program args + -> (String, String) -- ^ addition to the environment + -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) +readProcessEnvWithExitCode prog args env_update = do + current_env <- getEnvironment + readCreateProcessWithExitCode (proc prog args) { + env = Just (replaceVar env_update current_env) } "" + +-- Don't let gcc localize version info string, #8825 +c_locale_env :: (String, String) +c_locale_env = ("LANGUAGE", "C") + +-- If the -B option is set, add to PATH. This works around +-- a bug in gcc on Windows Vista where it can't find its auxiliary +-- binaries (see bug #1110). +getGccEnv :: [Option] -> IO (Maybe [(String,String)]) +getGccEnv opts = + if null b_dirs + then return Nothing + else do env <- getEnvironment + return (Just (mangle_paths env)) + where + (b_dirs, _) = partitionWith get_b_opt opts + + get_b_opt (Option ('-':'B':dir)) = Left dir + get_b_opt other = Right other + + -- Work around #1110 on Windows only (lest we stumble into #17266). +#if defined(mingw32_HOST_OS) + mangle_paths = map mangle_path + mangle_path (path,paths) | map toUpper path == "PATH" + = (path, '\"' : head b_dirs ++ "\";" ++ paths) + mangle_path other = other +#else + mangle_paths = id +#endif + + +----------------------------------------------------------------------------- +-- Running an external program + +runSomething :: DynFlags + -> String -- For -v message + -> String -- Command name (possibly a full path) + -- assumed already dos-ified + -> [Option] -- Arguments + -- runSomething will dos-ify them + -> IO () + +runSomething dflags phase_name pgm args = + runSomethingFiltered dflags id phase_name pgm args Nothing Nothing + +-- | Run a command, placing the arguments in an external response file. +-- +-- This command is used in order to avoid overlong command line arguments on +-- Windows. The command line arguments are first written to an external, +-- temporary response file, and then passed to the linker via @filepath. +-- response files for passing them in. See: +-- +-- https://gcc.gnu.org/wiki/Response_Files +-- https://gitlab.haskell.org/ghc/ghc/issues/10777 +runSomethingResponseFile + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe [(String,String)] -> IO () + +runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = + runSomethingWith dflags phase_name pgm args $ \real_args -> do + fp <- getResponseFile real_args + let args = ['@':fp] + r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env + return (r,()) + where + getResponseFile args = do + fp <- newTempName dflags TFL_CurrentModule "rsp" + withFile fp WriteMode $ \h -> do +#if defined(mingw32_HOST_OS) + hSetEncoding h latin1 +#else + hSetEncoding h utf8 +#endif + hPutStr h $ unlines $ map escape args + return fp + + -- Note: Response files have backslash-escaping, double quoting, and are + -- whitespace separated (some implementations use newline, others any + -- whitespace character). Therefore, escape any backslashes, newlines, and + -- double quotes in the argument, and surround the content with double + -- quotes. + -- + -- Another possibility that could be considered would be to convert + -- backslashes in the argument to forward slashes. This would generally do + -- the right thing, since backslashes in general only appear in arguments + -- as part of file paths on Windows, and the forward slash is accepted for + -- those. However, escaping is more reliable, in case somehow a backslash + -- appears in a non-file. + escape x = concat + [ "\"" + , concatMap + (\c -> + case c of + '\\' -> "\\\\" + '\n' -> "\\n" + '\"' -> "\\\"" + _ -> [c]) + x + , "\"" + ] + +runSomethingFiltered + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe FilePath -> Maybe [(String,String)] -> IO () + +runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do + runSomethingWith dflags phase_name pgm args $ \real_args -> do + r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env + return (r,()) + +runSomethingWith + :: DynFlags -> String -> String -> [Option] + -> ([String] -> IO (ExitCode, a)) + -> IO a + +runSomethingWith dflags phase_name pgm args io = do + let real_args = filter notNull (map showOpt args) + cmdLine = showCommandForUser pgm real_args + traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + +handleProc :: String -> String -> IO (ExitCode, r) -> IO r +handleProc pgm phase_name proc = do + (rc, r) <- proc `catchIO` handler + case rc of + ExitSuccess{} -> return r + ExitFailure n -> throwGhcExceptionIO ( + ProgramError ("`" ++ takeFileName pgm ++ "'" ++ + " failed in phase `" ++ phase_name ++ "'." ++ + " (Exit code: " ++ show n ++ ")")) + where + handler err = + if IO.isDoesNotExistError err + then does_not_exist + else throwGhcExceptionIO (ProgramError $ show err) + + does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) + + +builderMainLoop :: DynFlags -> (String -> String) -> FilePath + -> [String] -> Maybe FilePath -> Maybe [(String, String)] + -> IO ExitCode +builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do + chan <- newChan + + -- We use a mask here rather than a bracket because we want + -- to distinguish between cleaning up with and without an + -- exception. This is to avoid calling terminateProcess + -- unless an exception was raised. + let safely inner = mask $ \restore -> do + -- acquire + -- On Windows due to how exec is emulated the old process will exit and + -- a new process will be created. This means waiting for termination of + -- the parent process will get you in a race condition as the child may + -- not have finished yet. This caused #16450. To fix this use a + -- process job to track all child processes and wait for each one to + -- finish. + let procdata = + enableProcessJobs + $ (proc pgm real_args) { cwd = mb_cwd + , env = mb_env + , std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $ + createProcess_ "builderMainLoop" procdata + let cleanup_handles = do + hClose hStdIn + hClose hStdOut + hClose hStdErr + r <- try $ restore $ do + hSetBuffering hStdOut LineBuffering + hSetBuffering hStdErr LineBuffering + let make_reader_proc h = forkIO $ readerProc chan h filter_fn + bracketOnError (make_reader_proc hStdOut) killThread $ \_ -> + bracketOnError (make_reader_proc hStdErr) killThread $ \_ -> + inner hProcess + case r of + -- onException + Left (SomeException e) -> do + terminateProcess hProcess + cleanup_handles + throw e + -- cleanup when there was no exception + Right s -> do + cleanup_handles + return s + safely $ \h -> do + -- we don't want to finish until 2 streams have been complete + -- (stdout and stderr) + log_loop chan (2 :: Integer) + -- after that, we wait for the process to finish and return the exit code. + waitForProcess h + where + -- t starts at the number of streams we're listening to (2) decrements each + -- time a reader process sends EOF. We are safe from looping forever if a + -- reader thread dies, because they send EOF in a finally handler. + log_loop _ 0 = return () + log_loop chan t = do + msg <- readChan chan + case msg of + BuildMsg msg -> do + putLogMsg dflags NoReason SevInfo noSrcSpan + $ withPprStyle defaultUserStyle msg + log_loop chan t + BuildError loc msg -> do + putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) + $ withPprStyle defaultUserStyle msg + log_loop chan t + EOF -> + log_loop chan (t-1) + +readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () +readerProc chan hdl filter_fn = + (do str <- hGetContents hdl + loop (linesPlatform (filter_fn str)) Nothing) + `finally` + writeChan chan EOF + -- ToDo: check errors more carefully + -- ToDo: in the future, the filter should be implemented as + -- a stream transformer. + where + loop [] Nothing = return () + loop [] (Just err) = writeChan chan err + loop (l:ls) in_err = + case in_err of + Just err@(BuildError srcLoc msg) + | leading_whitespace l -> do + loop ls (Just (BuildError srcLoc (msg $$ text l))) + | otherwise -> do + writeChan chan err + checkError l ls + Nothing -> do + checkError l ls + _ -> panic "readerProc/loop" + + checkError l ls + = case parseError l of + Nothing -> do + writeChan chan (BuildMsg (text l)) + loop ls Nothing + Just (file, lineNum, colNum, msg) -> do + let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum + loop ls (Just (BuildError srcLoc (text msg))) + + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x + +parseError :: String -> Maybe (String, Int, Int, String) +parseError s0 = case breakColon s0 of + Just (filename, s1) -> + case breakIntColon s1 of + Just (lineNum, s2) -> + case breakIntColon s2 of + Just (columnNum, s3) -> + Just (filename, lineNum, columnNum, s3) + Nothing -> + Just (filename, lineNum, 0, s2) + Nothing -> Nothing + Nothing -> Nothing + +-- | Break a line of an error message into a filename and the rest of the line, +-- taking care to ignore colons in Windows drive letters (as noted in #17786). +-- For instance, +-- +-- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@ +-- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@ +breakColon :: String -> Maybe (String, String) +breakColon = go [] + where + -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@) + go accum (':':'\\':rest) = go ('\\':':':accum) rest + go accum (':':'/':rest) = go ('/':':':accum) rest + go accum (':':rest) = Just (reverse accum, rest) + go accum (c:rest) = go (c:accum) rest + go _accum [] = Nothing + +breakIntColon :: String -> Maybe (Int, String) +breakIntColon xs = case break (':' ==) xs of + (ys, _:zs) + | not (null ys) && all isAscii ys && all isDigit ys -> + Just (read ys, zs) + _ -> Nothing + +data BuildMessage + = BuildMsg !SDoc + | BuildError !SrcLoc !SDoc + | EOF + +-- Divvy up text stream into lines, taking platform dependent +-- line termination into account. +linesPlatform :: String -> [String] +#if !defined(mingw32_HOST_OS) +linesPlatform ls = lines ls +#else +linesPlatform "" = [] +linesPlatform xs = + case lineBreak xs of + (as,xs1) -> as : linesPlatform xs1 + where + lineBreak "" = ("","") + lineBreak ('\r':'\n':xs) = ([],xs) + lineBreak ('\n':xs) = ([],xs) + lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) + +#endif diff --git a/GHC/SysTools/Tasks.hs b/GHC/SysTools/Tasks.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Tasks.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Tasks running external programs for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module GHC.SysTools.Tasks where + +import GHC.Utils.Exception as Exception +import GHC.Utils.Error +import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion) +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Utils.Misc + +import Data.List +import Data.Char +import Data.Maybe + +import System.IO +import System.Process +import GHC.Prelude + +import GHC.SysTools.Process +import GHC.SysTools.Info + +import Control.Monad (join, forM, filterM, void) +import System.Directory (doesFileExist) +import System.FilePath (()) +import Text.ParserCombinators.ReadP as Parser + +{- +************************************************************************ +* * +\subsection{Running an external program} +* * +************************************************************************ +-} + +runUnlit :: DynFlags -> [Option] -> IO () +runUnlit dflags args = traceToolCommand dflags "unlit" $ do + let prog = pgm_L dflags + opts = getOpts dflags opt_L + runSomething dflags "Literate pre-processor" prog + (map Option opts ++ args) + +runCpp :: DynFlags -> [Option] -> IO () +runCpp dflags args = traceToolCommand dflags "cpp" $ do + let (p,args0) = pgm_P dflags + args1 = map Option (getOpts dflags opt_P) + args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] + ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "C pre-processor" p + (args0 ++ args1 ++ args2 ++ args) Nothing mb_env + +runPp :: DynFlags -> [Option] -> IO () +runPp dflags args = traceToolCommand dflags "pp" $ do + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething dflags "Haskell pre-processor" prog (args ++ opts) + +-- | Run compiler of C-like languages and raw objects (such as gcc or clang). +runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO () +runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do + let p = pgm_c dflags + args1 = map Option userOpts + args2 = languageOptions ++ args ++ args1 + -- We take care to pass -optc flags in args1 last to ensure that the + -- user can override flags passed by GHC. See #14452. + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env + where + -- discard some harmless warnings from gcc that we can't turn off + cc_filter = unlines . doFilter . lines + + {- + gcc gives warnings in chunks like so: + In file included from /foo/bar/baz.h:11, + from /foo/bar/baz2.h:22, + from wibble.c:33: + /foo/flibble:14: global register variable ... + /foo/flibble:15: warning: call-clobbered r... + We break it up into its chunks, remove any call-clobbered register + warnings from each chunk, and then delete any chunks that we have + emptied of warnings. + -} + doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] + -- We can't assume that the output will start with an "In file inc..." + -- line, so we start off expecting a list of warnings rather than a + -- location stack. + chunkWarnings :: [String] -- The location stack to use for the next + -- list of warnings + -> [String] -- The remaining lines to look at + -> [([String], [String])] + chunkWarnings loc_stack [] = [(loc_stack, [])] + chunkWarnings loc_stack xs + = case break loc_stack_start xs of + (warnings, lss:xs') -> + case span loc_start_continuation xs' of + (lsc, xs'') -> + (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' + _ -> [(loc_stack, xs)] + + filterWarnings :: [([String], [String])] -> [([String], [String])] + filterWarnings [] = [] + -- If the warnings are already empty then we are probably doing + -- something wrong, so don't delete anything + filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs + filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of + [] -> filterWarnings zs + ys' -> (xs, ys') : filterWarnings zs + + unChunkWarnings :: [([String], [String])] -> [String] + unChunkWarnings [] = [] + unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs + + loc_stack_start s = "In file included from " `isPrefixOf` s + loc_start_continuation s = " from " `isPrefixOf` s + wantedWarning w + | "warning: call-clobbered register used" `isContainedIn` w = False + | otherwise = True + + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + -- Also useful for plain .c files, just in case GHC saw a + -- -x c option. + (languageOptions, userOpts) = case mLanguage of + Nothing -> ([], userOpts_c) + Just language -> ([Option "-x", Option languageName], opts) + where + (languageName, opts) = case language of + LangC -> ("c", userOpts_c) + LangCxx -> ("c++", userOpts_cxx) + LangObjc -> ("objective-c", userOpts_c) + LangObjcxx -> ("objective-c++", userOpts_cxx) + LangAsm -> ("assembler", []) + RawObject -> ("c", []) -- claim C for lack of a better idea + userOpts_c = getOpts dflags opt_c + userOpts_cxx = getOpts dflags opt_cxx + +isContainedIn :: String -> String -> Bool +xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) + +-- | Run the linker with some arguments and return the output +askLd :: DynFlags -> [Option] -> IO String +askLd dflags args = traceToolCommand dflags "linker" $ do + let (p,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingWith dflags "gcc" p args2 $ \real_args -> + readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } + +runAs :: DynFlags -> [Option] -> IO () +runAs dflags args = traceToolCommand dflags "as" $ do + let (p,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env + +-- | Run the LLVM Optimiser +runLlvmOpt :: DynFlags -> [Option] -> IO () +runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do + let (p,args0) = pgm_lo dflags + args1 = map Option (getOpts dflags opt_lo) + -- We take care to pass -optlo flags (e.g. args0) last to ensure that the + -- user can override flags passed by GHC. See #14821. + runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0) + +-- | Run the LLVM Compiler +runLlvmLlc :: DynFlags -> [Option] -> IO () +runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do + let (p,args0) = pgm_lc dflags + args1 = map Option (getOpts dflags opt_lc) + runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + +-- | Run the clang compiler (used as an assembler for the LLVM +-- backend on OS X as LLVM doesn't support the OS X system +-- assembler) +runClang :: DynFlags -> [Option] -> IO () +runClang dflags args = traceToolCommand dflags "clang" $ do + let (clang,_) = pgm_lcc dflags + -- be careful what options we call clang with + -- see #5903 and #7617 for bugs caused by this. + (_,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + catch (do + runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env + ) + (\(err :: SomeException) -> do + errorMsg dflags $ + text ("Error running clang! you need clang installed to use the" ++ + " LLVM backend") $+$ + text "(or GHC tried to execute clang incorrectly)" + throwIO err + ) + +-- | Figure out which version of LLVM we are running this session +figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) +figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do + let (pgm,opts) = pgm_lc dflags + args = filter notNull (map showOpt opts) + -- we grab the args even though they should be useless just in + -- case the user is using a customised 'llc' that requires some + -- of the options they've specified. llc doesn't care what other + -- options are specified when '-version' is used. + args' = args ++ ["-version"] + catchIO (do + (pin, pout, perr, p) <- runInteractiveProcess pgm args' + Nothing Nothing + {- > llc -version + LLVM (http://llvm.org/): + LLVM version 3.5.2 + ... + -} + hSetBinaryMode pout False + _ <- hGetLine pout + vline <- hGetLine pout + let mb_ver = parseLlvmVersion vline + hClose pin + hClose pout + hClose perr + _ <- waitForProcess p + return mb_ver + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out LLVM version):" <+> + text (show err)) + errorMsg dflags $ vcat + [ text "Warning:", nest 9 $ + text "Couldn't figure out LLVM version!" $$ + text ("Make sure you have installed LLVM between [" + ++ llvmVersionStr supportedLlvmVersionLowerBound + ++ " and " + ++ llvmVersionStr supportedLlvmVersionUpperBound + ++ ")") ] + return Nothing) + + +-- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused +-- libraries from the dynamic library. We do this to reduce the number of load +-- commands that end up in the dylib, and has been limited to 32K (32768) since +-- macOS Sierra (10.14). +-- +-- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing +-- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not +-- being included in the load commands, however the @-rpath@ entries are all +-- forced to be included. This can lead to 100s of @-rpath@ entries being +-- included when only a handful of libraries end up being truely linked. +-- +-- Thus after building the library, we run a fixup phase where we inject the +-- @-rpath@ for each found library (in the given library search paths) into the +-- dynamic library through @-add_rpath@. +-- +-- See Note [Dynamic linking on macOS] +runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO () +runInjectRPaths dflags _ _ | not (gopt Opt_RPath dflags) = return () +runInjectRPaths dflags lib_paths dylib = do + info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib] + -- filter the output for only the libraries. And then drop the @rpath prefix. + let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info + -- find any pre-existing LC_PATH items + info <- lines <$> askOtool dflags Nothing [Option "-l", Option dylib] + + let paths = mapMaybe get_rpath info + lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] + -- only find those rpaths, that aren't already in the library. + rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l f)) lib_paths') + -- inject the rpaths + case rpaths of + [] -> return () + _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + +get_rpath :: String -> Maybe FilePath +get_rpath l = case readP_to_S rpath_parser l of + [(rpath, "")] -> Just rpath + _ -> Nothing + + +rpath_parser :: ReadP FilePath +rpath_parser = do + skipSpaces + void $ string "path" + void $ many1 (satisfy isSpace) + rpath <- many get + void $ many1 (satisfy isSpace) + void $ string "(offset " + void $ munch1 isDigit + void $ Parser.char ')' + skipSpaces + return rpath + +runLink :: DynFlags -> [Option] -> IO () +runLink dflags args = traceToolCommand dflags "linker" $ do + -- See Note [Run-time linker info] + -- + -- `-optl` args come at the end, so that later `-l` options + -- given there manually can fill in symbols needed by + -- Haskell libraries coming in via `args`. + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let (p,args0) = pgm_l dflags + optl_args = map Option (getOpts dflags opt_l) + args2 = args0 ++ linkargs ++ args ++ optl_args + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env + where + ld_filter = case (platformOS (targetPlatform dflags)) of + OSSolaris2 -> sunos_ld_filter + _ -> id +{- + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + sunos_ld_filter :: String -> String + sunos_ld_filter = unlines . sunos_ld_filter' . lines + sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + +-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. +runMergeObjects :: DynFlags -> [Option] -> IO () +runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do + let (p,args0) = pgm_lm dflags + optl_args = map Option (getOpts dflags opt_lm) + args2 = args0 ++ args ++ optl_args + -- N.B. Darwin's ld64 doesn't support response files. Consequently we only + -- use them on Windows where they are truly necessary. +#if defined(mingw32_HOST_OS) + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags id "Merge objects" p args2 mb_env +#else + runSomething dflags "Merge objects" p args2 +#endif + +runLibtool :: DynFlags -> [Option] -> IO () +runLibtool dflags args = traceToolCommand dflags "libtool" $ do + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let args1 = map Option (getOpts dflags opt_l) + args2 = [Option "-static"] ++ args1 ++ args ++ linkargs + libtool = pgm_libtool dflags + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Libtool" libtool args2 Nothing mb_env + +runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () +runAr dflags cwd args = traceToolCommand dflags "ar" $ do + let ar = pgm_ar dflags + runSomethingFiltered dflags id "Ar" ar args cwd Nothing + +askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String +askOtool dflags mb_cwd args = do + let otool = pgm_otool dflags + runSomethingWith dflags "otool" otool args $ \real_args -> + readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } + +runInstallNameTool :: DynFlags -> [Option] -> IO () +runInstallNameTool dflags args = do + let tool = pgm_install_name_tool dflags + runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing + +runRanlib :: DynFlags -> [Option] -> IO () +runRanlib dflags args = traceToolCommand dflags "ranlib" $ do + let ranlib = pgm_ranlib dflags + runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing + +runWindres :: DynFlags -> [Option] -> IO () +runWindres dflags args = traceToolCommand dflags "windres" $ do + let cc = pgm_c dflags + cc_args = map Option (sOpt_c (settings dflags)) + windres = pgm_windres dflags + opts = map Option (getOpts dflags opt_windres) + quote x = "\"" ++ x ++ "\"" + args' = -- If windres.exe and gcc.exe are in a directory containing + -- spaces then windres fails to run gcc. We therefore need + -- to tell it what command to use... + Option ("--preprocessor=" ++ + unwords (map quote (cc : + map showOpt opts ++ + ["-E", "-xc", "-DRC_INVOKED"]))) + -- ...but if we do that then if windres calls popen then + -- it can't understand the quoting, so we have to use + -- --use-temp-file so that it interprets it correctly. + -- See #1828. + : Option "--use-temp-file" + : args + mb_env <- getGccEnv cc_args + runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env + +touch :: DynFlags -> String -> String -> IO () +touch dflags purpose arg = traceToolCommand dflags "touch" $ + runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] + +-- * Tracing utility + +-- | Record in the eventlog when the given tool command starts +-- and finishes, prepending the given 'String' with +-- \"systool:\", to easily be able to collect and process +-- all the systool events. +-- +-- For those events to show up in the eventlog, you need +-- to run GHC with @-v2@ or @-ddump-timings@. +traceToolCommand :: DynFlags -> String -> IO a -> IO a +traceToolCommand dflags tool = withTiming + dflags (text $ "systool:" ++ tool) (const ()) diff --git a/GHC/SysTools/Terminal.hs b/GHC/SysTools/Terminal.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Terminal.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.SysTools.Terminal (stderrSupportsAnsiColors) where + +import GHC.Prelude + +#if defined(MIN_VERSION_terminfo) +import Control.Exception (catch) +import Data.Maybe (fromMaybe) +import System.Console.Terminfo (SetupTermError, Terminal, getCapability, + setupTermFromEnv, termColors) +import System.Posix (queryTerminal, stdError) +#elif defined(mingw32_HOST_OS) +import Control.Exception (catch, try) +import Data.Bits ((.|.), (.&.)) +import Foreign (Ptr, peek, with) +import qualified Graphics.Win32 as Win32 +import qualified System.Win32 as Win32 +#endif + +import System.IO.Unsafe + +#if defined(mingw32_HOST_OS) && !defined(WINAPI) +# if defined(i386_HOST_ARCH) +# define WINAPI stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINAPI ccall +# else +# error unknown architecture +# endif +#endif + +-- | Does the controlling terminal support ANSI color sequences? +-- This memoized to avoid thread-safety issues in ncurses (see #17922). +stderrSupportsAnsiColors :: Bool +stderrSupportsAnsiColors = unsafePerformIO stderrSupportsAnsiColors' +{-# NOINLINE stderrSupportsAnsiColors #-} + +-- | Check if ANSI escape sequences can be used to control color in stderr. +stderrSupportsAnsiColors' :: IO Bool +stderrSupportsAnsiColors' = do +#if defined(MIN_VERSION_terminfo) + stderr_available <- queryTerminal stdError + if stderr_available then + fmap termSupportsColors setupTermFromEnv + `catch` \ (_ :: SetupTermError) -> pure False + else + pure False + where + termSupportsColors :: Terminal -> Bool + termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 + +#elif defined(mingw32_HOST_OS) + h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE + `catch` \ (_ :: IOError) -> + pure Win32.nullHANDLE + if h == Win32.nullHANDLE + then pure False + else do + eMode <- try (getConsoleMode h) + case eMode of + Left (_ :: IOError) -> Win32.isMinTTYHandle h + -- Check if the we're in a MinTTY terminal + -- (e.g., Cygwin or MSYS2) + Right mode + | modeHasVTP mode -> pure True + | otherwise -> enableVTP h mode + + where + + enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool + enableVTP h mode = do + setConsoleMode h (modeAddVTP mode) + modeHasVTP <$> getConsoleMode h + `catch` \ (_ :: IOError) -> + pure False + + modeHasVTP :: Win32.DWORD -> Bool + modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 + + modeAddVTP :: Win32.DWORD -> Win32.DWORD + modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING + +eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD +eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 + +getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD +getConsoleMode h = with 64 $ \ mode -> do + Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode) + peek mode + +setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO () +setConsoleMode h mode = do + Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) + +foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode + :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL + +foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode + :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL + +#else + pure False +#endif diff --git a/GHC/Tc/Deriv.hs b/GHC/Tc/Deriv.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv.hs @@ -0,0 +1,2297 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handles @deriving@ clauses on @data@ declarations. +module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Driver.Session + +import GHC.Tc.Utils.Monad +import GHC.Tc.Instance.Family +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Tc.Deriv.Infer +import GHC.Tc.Deriv.Utils +import GHC.Tc.Validity( allDistinctTyVars ) +import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) +import GHC.Tc.Utils.Env +import GHC.Tc.Deriv.Generate +import GHC.Tc.Validity( checkValidInstHead ) +import GHC.Core.InstEnv +import GHC.Tc.Utils.Instantiate +import GHC.Core.FamInstEnv +import GHC.Tc.Gen.HsType +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( pprTyVars ) + +import GHC.Rename.Bind +import GHC.Rename.Env +import GHC.Rename.Module ( addTcgDUs ) +import GHC.Rename.Utils + +import GHC.Core.Unify( tcUnifyTy ) +import GHC.Core.Class +import GHC.Core.Type +import GHC.Utils.Error +import GHC.Core.DataCon +import GHC.Data.Maybe +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Set as NameSet +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.List (partition, find) + +{- +************************************************************************ +* * + Overview +* * +************************************************************************ + +Overall plan +~~~~~~~~~~~~ +1. Convert the decls (i.e. data/newtype deriving clauses, + plus standalone deriving) to [EarlyDerivSpec] + +2. Infer the missing contexts for the InferTheta's + +3. Add the derived bindings, generating InstInfos +-} + +data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin]) + | GivenTheta (DerivSpec ThetaType) + -- InferTheta ds => the context for the instance should be inferred + -- In this case ds_theta is the list of all the sets of + -- constraints needed, such as (Eq [a], Eq a), together with a + -- suitable CtLoc to get good error messages. + -- The inference process is to reduce this to a + -- simpler form (e.g. Eq a) + -- + -- GivenTheta ds => the exact context for the instance is supplied + -- by the programmer; it is ds_theta + -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer + +splitEarlyDerivSpec :: [EarlyDerivSpec] + -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType]) +splitEarlyDerivSpec [] = ([],[]) +splitEarlyDerivSpec (InferTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) +splitEarlyDerivSpec (GivenTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) + +instance Outputable EarlyDerivSpec where + ppr (InferTheta spec) = ppr spec <+> text "(Infer)" + ppr (GivenTheta spec) = ppr spec <+> text "(Given)" + +{- +Note [Data decl contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) + +We will need an instance decl like: + + instance (Read a, RealFloat a) => Read (Complex a) where + ... + +The RealFloat in the context is because the read method for Complex is bound +to construct a Complex, and doing that requires that the argument type is +in RealFloat. + +But this ain't true for Show, Eq, Ord, etc, since they don't construct +a Complex; they only take them apart. + +Our approach: identify the offending classes, and add the data type +context to the instance decl. The "offending classes" are + + Read, Enum? + +FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that +pattern matching against a constructor from a data type with a context +gives rise to the constraints for that context -- or at least the thinned +version. So now all classes are "offending". + +Note [Newtype deriving] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + class C a b + instance C [a] Char + newtype T = T Char deriving( C [a] ) + +Notice the free 'a' in the deriving. We have to fill this out to + newtype T = T Char deriving( forall a. C [a] ) + +And then translate it to: + instance C [a] Char => C [a] T where ... + +Note [Unused constructors and deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #3221. Consider + data T = T1 | T2 deriving( Show ) +Are T1 and T2 unused? Well, no: the deriving clause expands to mention +both of them. So we gather defs/uses from deriving just like anything else. + +-} + +-- | Stuff needed to process a datatype's `deriving` clauses +data DerivInfo = DerivInfo { di_rep_tc :: TyCon + -- ^ The data tycon for normal datatypes, + -- or the *representation* tycon for data families + , di_scoped_tvs :: ![(Name,TyVar)] + -- ^ Variables that scope over the deriving clause. + , di_clauses :: [LHsDerivingClause GhcRn] + , di_ctxt :: SDoc -- ^ error context + } + +{- + +************************************************************************ +* * +Top-level function for \tr{derivings} +* * +************************************************************************ +-} + +tcDeriving :: [DerivInfo] -- All `deriving` clauses + -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations + -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn) +tcDeriving deriv_infos deriv_decls + = recoverM (do { g <- getGblEnv + ; return (g, emptyBag, emptyValBindsOut)}) $ + do { -- Fish the "deriving"-related information out of the GHC.Tc.Utils.Env + -- And make the necessary "equations". + early_specs <- makeDerivSpecs deriv_infos deriv_decls + ; traceTc "tcDeriving" (ppr early_specs) + + ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs + ; insts1 <- mapM genInst given_specs + ; insts2 <- mapM genInst infer_specs + + ; dflags <- getDynFlags + + ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) + ; loc <- getSrcSpanM + ; let (binds, famInsts) = genAuxBinds dflags loc + (unionManyBags deriv_stuff) + + ; let mk_inst_infos1 = map fstOf3 insts1 + ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs + + -- We must put all the derived type family instances (from both + -- infer_specs and given_specs) in the local instance environment + -- before proceeding, or else simplifyInstanceContexts might + -- get stuck if it has to reason about any of those family instances. + -- See Note [Staging of tcDeriving] + ; tcExtendLocalFamInstEnv (bagToList famInsts) $ + -- NB: only call tcExtendLocalFamInstEnv once, as it performs + -- validity checking for all of the family instances you give it. + -- If the family instances have errors, calling it twice will result + -- in duplicate error messages! + + do { + -- the stand-alone derived instances (@inst_infos1@) are used when + -- inferring the contexts for "deriving" clauses' instances + -- (@infer_specs@) + ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $ + simplifyInstanceContexts infer_specs + + ; let mk_inst_infos2 = map fstOf3 insts2 + ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs + ; let inst_infos = inst_infos1 ++ inst_infos2 + + ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds + + ; unless (isEmptyBag inst_info) $ + liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + FormatHaskell + (ddump_deriving inst_info rn_binds famInsts)) + + ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) + getGblEnv + ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs) + ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } } + where + ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn + -> Bag FamInst -- ^ Rep type family instances + -> SDoc + ddump_deriving inst_infos extra_binds repFamInsts + = hang (text "Derived class instances:") + 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) + $$ ppr extra_binds) + $$ hangP "Derived type family instances:" + (vcat (map pprRepTy (bagToList repFamInsts))) + + hangP s x = text "" $$ hang (ptext (sLit s)) 2 x + + -- Apply the suspended computations given by genInst calls. + -- See Note [Staging of tcDeriving] + apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)] + -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs] + apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds)) + +-- Prints the representable type family instance +pprRepTy :: FamInst -> SDoc +pprRepTy fi@(FamInst { fi_tys = lhs }) + = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> + equals <+> ppr rhs + where rhs = famInstRHS fi + +renameDeriv :: [InstInfo GhcPs] + -> Bag (LHsBind GhcPs, LSig GhcPs) + -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses) +renameDeriv inst_infos bagBinds + = discardWarnings $ + -- Discard warnings about unused bindings etc + setXOptM LangExt.EmptyCase $ + -- Derived decls (for empty types) can have + -- case x of {} + setXOptM LangExt.ScopedTypeVariables $ + setXOptM LangExt.KindSignatures $ + -- Derived decls (for newtype-deriving) can use ScopedTypeVariables & + -- KindSignatures + setXOptM LangExt.TypeApplications $ + -- GND/DerivingVia uses TypeApplications in generated code + -- (See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate) + unsetXOptM LangExt.RebindableSyntax $ + -- See Note [Avoid RebindableSyntax when deriving] + setXOptM LangExt.TemplateHaskellQuotes $ + -- DeriveLift makes uses of quotes + do { + -- Bring the extra deriving stuff into scope + -- before renaming the instances themselves + ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) + ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds + ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) + -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename + -- auxiliary bindings as if they were defined locally. + -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. + ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyFsEnv aux_val_binds + ; bindLocalNames bndrs $ + do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs + ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos + ; return (listToBag rn_inst_infos, rn_aux, + dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } + + where + rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars) + rn_inst_info + inst_info@(InstInfo { iSpec = inst + , iBinds = InstBindings + { ib_binds = binds + , ib_tyvars = tyvars + , ib_pragmas = sigs + , ib_extensions = exts -- Only for type-checking + , ib_derived = sa } }) + = do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst) + tyvars binds sigs + ; let binds' = InstBindings { ib_binds = rn_binds + , ib_tyvars = tyvars + , ib_pragmas = rn_sigs + , ib_extensions = exts + , ib_derived = sa } + ; return (inst_info { iBinds = binds' }, fvs) } + +{- +Note [Staging of tcDeriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's a tricky corner case for deriving (adapted from #2721): + + class C a where + type T a + foo :: a -> T a + + instance C Int where + type T Int = Int + foo = id + + newtype N = N Int deriving C + +This will produce an instance something like this: + + instance C N where + type T N = T Int + foo = coerce (foo :: Int -> T Int) :: N -> T N + +We must be careful in order to typecheck this code. When determining the +context for the instance (in simplifyInstanceContexts), we need to determine +that T N and T Int have the same representation, but to do that, the T N +instance must be in the local family instance environment. Otherwise, GHC +would be unable to conclude that T Int is representationally equivalent to +T Int, and simplifyInstanceContexts would get stuck. + +Previously, tcDeriving would defer adding any derived type family instances to +the instance environment until the very end, which meant that +simplifyInstanceContexts would get called without all the type family instances +it needed in the environment in order to properly simplify instance like +the C N instance above. + +To avoid this scenario, we carefully structure the order of events in +tcDeriving. We first call genInst on the standalone derived instance specs and +the instance specs obtained from deriving clauses. Note that the return type of +genInst is a triple: + + TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) + +The type family instances are in the BagDerivStuff. The first field of the +triple is a suspended computation which, given an instance context, produces +the rest of the instance. The fact that it is suspended is important, because +right now, we don't have ThetaTypes for the instances that use deriving clauses +(only the standalone-derived ones). + +Now we can collect the type family instances and extend the local instance +environment. At this point, it is safe to run simplifyInstanceContexts on the +deriving-clause instance specs, which gives us the ThetaTypes for the +deriving-clause instances. Now we can feed all the ThetaTypes to the +suspended computations and obtain our InstInfos, at which point +tcDeriving is done. + +An alternative design would be to split up genInst so that the +family instances are generated separately from the InstInfos. But this would +require carving up a lot of the GHC deriving internals to accommodate the +change. On the other hand, we can keep all of the InstInfo and type family +instance logic together in genInst simply by converting genInst to +continuation-returning style, so we opt for that route. + +Note [Why we don't pass rep_tc into deriveTyData] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc +back into the rep_tc by means of a lookup. And yet we have the rep_tc right +here! Why look it up again? Answer: it's just easier this way. +We drop some number of arguments from the end of the datatype definition +in deriveTyData. The arguments are dropped from the fam_tc. +This action may drop a *different* number of arguments +passed to the rep_tc, depending on how many free variables, etc., the +dropped patterns have. + +Also, this technique carries over the kind substitution from deriveTyData +nicely. + +Note [Avoid RebindableSyntax when deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RebindableSyntax extension interacts awkwardly with the derivation of +any stock class whose methods require the use of string literals. The Show +class is a simple example (see #12688): + + {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} + newtype Text = Text String + fromString :: String -> Text + fromString = Text + + data Foo = Foo deriving Show + +This will generate code to the effect of: + + instance Show Foo where + showsPrec _ Foo = showString "Foo" + +But because RebindableSyntax and OverloadedStrings are enabled, the "Foo" +string literal is now of type Text, not String, which showString doesn't +accept! This causes the generated Show instance to fail to typecheck. + +To avoid this kind of scenario, we simply turn off RebindableSyntax entirely +in derived code. + +************************************************************************ +* * + From HsSyn to DerivSpec +* * +************************************************************************ + +@makeDerivSpecs@ fishes around to find the info about needed derived instances. +-} + +makeDerivSpecs :: [DerivInfo] + -> [LDerivDecl GhcRn] + -> TcM [EarlyDerivSpec] +makeDerivSpecs deriv_infos deriv_decls + = do { eqns1 <- sequenceA + [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt + | DerivInfo { di_rep_tc = rep_tc + , di_scoped_tvs = scoped_tvs + , di_clauses = clauses + , di_ctxt = err_ctxt } <- deriv_infos + , L _ (HsDerivingClause { deriv_clause_strategy = dcs + , deriv_clause_tys = L _ preds }) + <- clauses + ] + ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls + ; return $ concat eqns1 ++ catMaybes eqns2 } + +------------------------------------------------------------------ +-- | Process the derived classes in a single @deriving@ clause. +deriveClause :: TyCon + -> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars + -- See Note [Scoped tyvars in a TcTyCon] in "GHC.Core.TyCon" + -> Maybe (LDerivStrategy GhcRn) + -> [LHsSigType GhcRn] -> SDoc + -> TcM [EarlyDerivSpec] +deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt + = addErrCtxt err_ctxt $ do + traceTc "deriveClause" $ vcat + [ text "tvs" <+> ppr tvs + , text "scoped_tvs" <+> ppr scoped_tvs + , text "tc" <+> ppr tc + , text "tys" <+> ppr tys + , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ] + tcExtendNameTyVarEnv scoped_tvs $ do + (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat + tcExtendTyVarEnv via_tvs $ + -- Moreover, when using DerivingVia one can bind type variables in + -- the `via` type as well, so these type variables must also be + -- brought into scope. + mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds + -- After typechecking the `via` type once, we then typecheck all + -- of the classes associated with that `via` type in the + -- `deriving` clause. + -- See also Note [Don't typecheck too much in DerivingVia]. + where + tvs = tyConTyVars rep_tc + (tc, tys) = case tyConFamInstSig_maybe rep_tc of + -- data family: + Just (fam_tc, pats, _) -> (fam_tc, pats) + -- NB: deriveTyData wants the *user-specified* + -- name. See Note [Why we don't pass rep_tc into deriveTyData] + + _ -> (rep_tc, mkTyVarTys tvs) -- datatype + +-- | Process a single predicate in a @deriving@ clause. +-- +-- This returns a 'Maybe' because the user might try to derive 'Typeable', +-- which is a no-op nowadays. +derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar] + -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec) +derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = + -- We carefully set up uses of recoverM to minimize error message + -- cascades. See Note [Recovering from failures in deriving clauses]. + recoverM (pure Nothing) $ + setSrcSpan (getLoc (hsSigType deriv_pred)) $ do + traceTc "derivePred" $ vcat + [ text "tc" <+> ppr tc + , text "tys" <+> ppr tys + , text "deriv_pred" <+> ppr deriv_pred + , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat + , text "via_tvs" <+> ppr via_tvs ] + (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred + when (cls_arg_kinds `lengthIsNot` 1) $ + failWithTc (nonUnaryErr deriv_pred) + let [cls_arg_kind] = cls_arg_kinds + mb_deriv_strat = fmap unLoc mb_lderiv_strat + if (className cls == typeableClassName) + then do warnUselessTypeable + return Nothing + else let deriv_tvs = via_tvs ++ cls_tvs in + Just <$> deriveTyData tc tys mb_deriv_strat + deriv_tvs cls cls_tys cls_arg_kind + +{- +Note [Don't typecheck too much in DerivingVia] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + + data D = ... + deriving (A1 t, ..., A20 t) via T t + +GHC used to be engineered such that it would typecheck the `deriving` +clause like so: + +1. Take the first class in the clause (`A1`). +2. Typecheck the `via` type (`T t`) and bring its bound type variables + into scope (`t`). +3. Typecheck the class (`A1`). +4. Move on to the next class (`A2`) and repeat the process until all + classes have been typechecked. + +This algorithm gets the job done most of the time, but it has two notable +flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked +20 different times, once for each class in the `deriving` clause. This is +unnecessary because we only need to typecheck `T t` once in order to get +access to its bound type variable. + +The other issue with this algorithm arises when there are no classes in the +`deriving` clause, like in the following example: + + data D2 = ... + deriving () via Maybe Maybe + +Because there are no classes, the algorithm above will simply do nothing. +As a consequence, GHC will completely miss the fact that `Maybe Maybe` +is ill-kinded nonsense (#16923). + +To address both of these problems, GHC now uses this algorithm instead: + +1. Typecheck the `via` type and bring its bound type variables into scope. +2. Take the first class in the `deriving` clause. +3. Typecheck the class. +4. Move on to the next class and repeat the process until all classes have been + typechecked. + +This algorithm ensures that the `via` type is always typechecked, even if there +are no classes in the `deriving` clause. Moreover, it typecheck the `via` type +/exactly/ once and no more, even if there are multiple classes in the clause. + +Note [Recovering from failures in deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider what happens if you run this program (from #10684) without +DeriveGeneric enabled: + + data A = A deriving (Show, Generic) + data B = B A deriving (Show) + +Naturally, you'd expect GHC to give an error to the effect of: + + Can't make a derived instance of `Generic A': + You need -XDeriveGeneric to derive an instance for this class + +And *only* that error, since the other two derived Show instances appear to be +independent of this derived Generic instance. Yet GHC also used to give this +additional error on the program above: + + No instance for (Show A) + arising from the 'deriving' clause of a data type declaration + When deriving the instance for (Show B) + +This was happening because when GHC encountered any error within a single +data type's set of deriving clauses, it would call recoverM and move on +to the next data type's deriving clauses. One unfortunate consequence of +this design is that if A's derived Generic instance failed, its derived +Show instance would be skipped entirely, leading to the "No instance for +(Show A)" error cascade. + +The solution to this problem is to push through uses of recoverM to the +level of the individual derived classes in a particular data type's set of +deriving clauses. That is, if you have: + + newtype C = C D + deriving (E, F, G) + +Then instead of processing instances E through M under the scope of a single +recoverM, as in the following pseudocode: + + recoverM (pure Nothing) $ mapM derivePred [E, F, G] + +We instead use recoverM in each iteration of the loop: + + mapM (recoverM (pure Nothing) . derivePred) [E, F, G] + +And then process each class individually, under its own recoverM scope. That +way, failure to derive one class doesn't cancel out other classes in the +same set of clause-derived classes. +-} + +------------------------------------------------------------------ +deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) +-- Process a single standalone deriving declaration +-- e.g. deriving instance Show a => Show (T a) +-- Rather like tcLocalInstDecl +-- +-- This returns a Maybe because the user might try to derive Typeable, which is +-- a no-op nowadays. +deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) + = setSrcSpan loc $ + addErrCtxt (standaloneCtxt deriv_ty) $ + do { traceTc "Standalone deriving decl for" (ppr deriv_ty) + ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True + ; traceTc "Deriving strategy (standalone deriving)" $ + vcat [ppr mb_lderiv_strat, ppr deriv_ty] + ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat + ; (cls_tvs, deriv_ctxt, cls, inst_tys) + <- tcExtendTyVarEnv via_tvs $ + tcStandaloneDerivInstType ctxt deriv_ty + ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat + tvs = via_tvs ++ cls_tvs + -- See Note [Unify kinds in deriving] + ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <- + case mb_deriv_strat of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) + -- This unification must be performed on the last element of + -- inst_tys, but we have not yet checked for this property. + -- (This is done later in expectNonNullaryClsArgs). For now, + -- simply do nothing if inst_tys is empty, since + -- expectNonNullaryClsArgs will error later if this + -- is the case. + | Just inst_ty <- lastMaybe inst_tys + -> do + let via_kind = tcTypeKind via_ty + inst_ty_kind = tcTypeKind inst_ty + mb_match = tcUnifyTy inst_ty_kind via_kind + + checkTc (isJust mb_match) + (derivingViaKindErr cls inst_ty_kind + via_ty via_kind) + + let Just kind_subst = mb_match + ki_subst_range = getTCvSubstRangeFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tvs + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + (final_deriv_ctxt, final_deriv_ctxt_tys) + = case deriv_ctxt of + InferContext wc -> (InferContext wc, []) + SupplyContext theta -> + let final_theta = substTheta subst theta + in (SupplyContext final_theta, final_theta) + final_inst_tys = substTys subst inst_tys + final_via_ty = substTy subst via_ty + -- See Note [Floating `via` type variables] + final_tvs = tyCoVarsOfTypesWellScoped $ + final_deriv_ctxt_tys ++ final_inst_tys + ++ [final_via_ty] + pure ( final_tvs, final_deriv_ctxt, final_inst_tys + , Just (ViaStrategy final_via_ty) ) + + _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat) + ; traceTc "Standalone deriving;" $ vcat + [ text "tvs':" <+> ppr tvs' + , text "mb_deriv_strat':" <+> ppr mb_deriv_strat' + , text "deriv_ctxt':" <+> ppr deriv_ctxt' + , text "cls:" <+> ppr cls + , text "inst_tys':" <+> ppr inst_tys' ] + -- C.f. GHC.Tc.TyCl.Instance.tcLocalInstDecl1 + + ; if className cls == typeableClassName + then do warnUselessTypeable + return Nothing + else Just <$> mkEqnHelp (fmap unLoc overlap_mode) + tvs' cls inst_tys' + deriv_ctxt' mb_deriv_strat' } + +-- Typecheck the type in a standalone deriving declaration. +-- +-- This may appear dense, but it's mostly huffing and puffing to recognize +-- the special case of a type with an extra-constraints wildcard context, e.g., +-- +-- deriving instance _ => Eq (Foo a) +-- +-- If there is such a wildcard, we typecheck this as if we had written +-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@, +-- as the 'DerivContext', where loc is the location of the wildcard used for +-- error reporting. This indicates that we should infer the context as if we +-- were deriving Eq via a deriving clause +-- (see Note [Inferring the instance context] in GHC.Tc.Deriv.Infer). +-- +-- If there is no wildcard, then proceed as normal, and instead return +-- @'SupplyContext' theta@, where theta is the typechecked context. +-- +-- Note that this will never return @'InferContext' 'Nothing'@, as that can +-- only happen with @deriving@ clauses. +tcStandaloneDerivInstType + :: UserTypeCtxt -> LHsSigWcType GhcRn + -> TcM ([TyVar], DerivContext, Class, [Type]) +tcStandaloneDerivInstType ctxt + (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars + , hsib_body = deriv_ty_body })}) + | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body + , L _ [wc_pred] <- theta + , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred + = do dfun_ty <- tcHsClsInstType ctxt $ + HsIB { hsib_ext = vars + , hsib_body + = L (getLoc deriv_ty_body) $ + HsForAllTy { hst_tele = mkHsForAllInvisTele tvs + , hst_xforall = noExtField + , hst_body = rho }} + let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, InferContext (Just wc_span), cls, inst_tys) + | otherwise + = do dfun_ty <- tcHsClsInstType ctxt deriv_ty + let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, SupplyContext theta, cls, inst_tys) + +warnUselessTypeable :: TcM () +warnUselessTypeable + = do { warn <- woptM Opt_WarnDerivingTypeable + ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) + $ text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" } + +------------------------------------------------------------------ +deriveTyData :: TyCon -> [Type] -- LHS of data or data instance + -- Can be a data instance, hence [Type] args + -- and in that case the TyCon is the /family/ tycon + -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy + -> [TyVar] -- The type variables bound by the derived class + -> Class -- The derived class + -> [Type] -- The derived class's arguments + -> Kind -- The function argument in the derived class's kind. + -- (e.g., if `deriving Functor`, this would be + -- `Type -> Type` since + -- `Functor :: (Type -> Type) -> Constraint`) + -> TcM EarlyDerivSpec +-- The deriving clause of a data or newtype declaration +-- I.e. not standalone deriving +deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind + = do { -- Given data T a b c = ... deriving( C d ), + -- we want to drop type variables from T so that (C d (T a)) is well-kinded + let (arg_kinds, _) = splitFunTys cls_arg_kind + n_args_to_drop = length arg_kinds + n_args_to_keep = length tc_args - n_args_to_drop + -- See Note [tc_args and tycon arity] + (tc_args_to_keep, args_to_drop) + = splitAt n_args_to_keep tc_args + inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep) + + -- Match up the kinds, and apply the resulting kind substitution + -- to the types. See Note [Unify kinds in deriving] + -- We are assuming the tycon tyvars and the class tyvars are distinct + mb_match = tcUnifyTy inst_ty_kind cls_arg_kind + enough_args = n_args_to_keep >= 0 + + -- Check that the result really is well-kinded + ; checkTc (enough_args && isJust mb_match) + (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) + + ; let -- Returns a singleton-element list if using ViaStrategy and an + -- empty list otherwise. Useful for free-variable calculations. + deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type] + deriv_strat_tys = foldMap (foldDerivStrategy [] (:[])) + + propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' + = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) + where + ki_subst_range = getTCvSubstRangeFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tkvs' + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + final_tc_args = substTys subst tc_args' + final_cls_tys = substTys subst cls_tys' + final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst)) + mb_deriv_strat' + -- See Note [Floating `via` type variables] + final_tkvs = tyCoVarsOfTypesWellScoped $ + final_cls_tys ++ final_tc_args + ++ deriv_strat_tys final_mb_deriv_strat + + ; let tkvs = scopedSort $ fvVarList $ + unionFV (tyCoFVsOfTypes tc_args_to_keep) + (FV.mkFVs deriv_tvs) + Just kind_subst = mb_match + (tkvs', cls_tys', tc_args', mb_deriv_strat') + = propagate_subst kind_subst tkvs cls_tys + tc_args_to_keep mb_deriv_strat + + -- See Note [Unify kinds in deriving] + ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- + case mb_deriv_strat' of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) -> do + let via_kind = tcTypeKind via_ty + inst_ty_kind + = tcTypeKind (mkTyConApp tc tc_args') + via_match = tcUnifyTy inst_ty_kind via_kind + + checkTc (isJust via_match) + (derivingViaKindErr cls inst_ty_kind via_ty via_kind) + + let Just via_subst = via_match + pure $ propagate_subst via_subst tkvs' cls_tys' + tc_args' mb_deriv_strat' + + _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat') + + ; traceTc "deriveTyData 1" $ vcat + [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args + , pprTyVars (tyCoVarsOfTypesList tc_args) + , ppr n_args_to_keep, ppr n_args_to_drop + , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match + , ppr final_tc_args, ppr final_cls_tys ] + + ; traceTc "deriveTyData 2" $ vcat + [ ppr final_tkvs ] + + ; let final_tc_app = mkTyConApp tc final_tc_args + final_cls_args = final_cls_tys ++ [final_tc_app] + ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) + (derivingEtaErr cls final_cls_tys final_tc_app) + -- Check that + -- (a) The args to drop are all type variables; eg reject: + -- data instance T a Int = .... deriving( Monad ) + -- (b) The args to drop are all *distinct* type variables; eg reject: + -- class C (a :: * -> * -> *) where ... + -- data instance T a a = ... deriving( C ) + -- (c) The type class args, or remaining tycon args, + -- do not mention any of the dropped type variables + -- newtype T a s = ... deriving( ST s ) + -- newtype instance K a a = ... deriving( Monad ) + -- + -- It is vital that the implementation of allDistinctTyVars + -- expand any type synonyms. + -- See Note [Eta-reducing type synonyms] + + ; checkValidInstHead DerivClauseCtxt cls final_cls_args + -- Check that we aren't deriving an instance of a magical + -- type like (~) or Coercible (#14916). + + ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args + (InferContext Nothing) final_mb_deriv_strat + ; traceTc "deriveTyData 3" (ppr spec) + ; return spec } + + +{- Note [tc_args and tycon arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if we could use (tyConArity tc) at this point, rather +than (length tc_args). But for data families the two can differ! The +tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which +in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them +from DataFamInstTyCon: + +| DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + +Notice that the arg tys might not be the same as the family tycon arity +(= length tyConTyVars). + +Note [Unify kinds in deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#8534) + data T a b = MkT a deriving( Functor ) + -- where Functor :: (*->*) -> Constraint + +So T :: forall k. * -> k -> *. We want to get + instance Functor (T * (a:*)) where ... +Notice the '*' argument to T. + +Moreover, as well as instantiating T's kind arguments, we may need to instantiate +C's kind args. Consider (#8865): + newtype T a b = MkT (Either a b) deriving( Category ) +where + Category :: forall k. (k -> k -> *) -> Constraint +We need to generate the instance + instance Category * (Either a) where ... +Notice the '*' argument to Category. + +So we need to + * drop arguments from (T a b) to match the number of + arrows in the (last argument of the) class; + * and then *unify* kind of the remaining type against the + expected kind, to figure out how to instantiate C's and T's + kind arguments. + +In the two examples, + * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) + i.e. (k -> *) ~ (* -> *) to find k:=*. + yielding k:=* + + * we unify kind-of( Either ) ~ kind-of( Category ) + i.e. (* -> * -> *) ~ (k -> k -> k) + yielding k:=* + +Now we get a kind substitution. We then need to: + + 1. Remove the substituted-out kind variables from the quantified kind vars + + 2. Apply the substitution to the kinds of quantified *type* vars + (and extend the substitution to reflect this change) + + 3. Apply that extended substitution to the non-dropped args (types and + kinds) of the type and class + +Forgetting step (2) caused #8893: + data V a = V [a] deriving Functor + data P (x::k->*) (a:k) = P (x a) deriving Functor + data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor + +When deriving Functor for P, we unify k to *, but we then want +an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) +and similarly for C. Notice the modified kind of x, both at binding +and occurrence sites. + +This can lead to some surprising results when *visible* kind binder is +unified (in contrast to the above examples, in which only non-visible kind +binders were considered). Consider this example from #11732: + + data T k (a :: k) = MkT deriving Functor + +Since unification yields k:=*, this results in a generated instance of: + + instance Functor (T *) where ... + +which looks odd at first glance, since one might expect the instance head +to be of the form Functor (T k). Indeed, one could envision an alternative +generated instance of: + + instance (k ~ *) => Functor (T k) where + +But this does not typecheck by design: kind equalities are not allowed to be +bound in types, only terms. But in essence, the two instance declarations are +entirely equivalent, since even though (T k) matches any kind k, the only +possibly value for k is *, since anything else is ill-typed. As a result, we can +just as comfortably use (T *). + +Another way of thinking about is: deriving clauses often infer constraints. +For example: + + data S a = S a deriving Eq + +infers an (Eq a) constraint in the derived instance. By analogy, when we +are deriving Functor, we might infer an equality constraint (e.g., k ~ *). +The only distinction is that GHC instantiates equality constraints directly +during the deriving process. + +Another quirk of this design choice manifests when typeclasses have visible +kind parameters. Consider this code (also from #11732): + + class Cat k (cat :: k -> k -> *) where + catId :: cat a a + catComp :: cat b c -> cat a b -> cat a c + + instance Cat * (->) where + catId = id + catComp = (.) + + newtype Fun a b = Fun (a -> b) deriving (Cat k) + +Even though we requested a derived instance of the form (Cat k Fun), the +kind unification will actually generate (Cat * Fun) (i.e., the same thing as if +the user wrote deriving (Cat *)). + +What happens with DerivingVia, when you have yet another type? Consider: + + newtype Foo (a :: Type) = MkFoo (Proxy a) + deriving Functor via Proxy + +As before, we unify the kind of Foo (* -> *) with the kind of the argument to +Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind +(k -> *), which is more general than what we want. So we must additionally +unify (k -> *) with (* -> *). + +Currently, all of this unification is implemented kludgily with the pure +unifier, which is rather tiresome. #14331 lays out a plan for how this +might be made cleaner. + +Note [Unification of two kind variables in deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a special case of the Note above, it is possible to derive an instance of +a poly-kinded typeclass for a poly-kinded datatype. For example: + + class Category (cat :: k -> k -> *) where + newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category + +This case is surprisingly tricky. To see why, let's write out what instance GHC +will attempt to derive (using -fprint-explicit-kinds syntax): + + instance Category k1 (T k2 c) where ... + +GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst) +that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to +the type variable binder for c, since its kind is (k2 -> k2 -> *). + +We used to accomplish this by doing the following: + + unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs + (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs + +Where all_tkvs contains all kind variables in the class and instance types (in +this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping, +this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped +to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new]. +This is bad, because applying that substitution yields the following instance: + + instance Category k_new (T k1 c) where ... + +In other words, keeping k1 in unmapped_tvks taints the substitution, resulting +in an ill-kinded instance (this caused #11837). + +To prevent this, we need to filter out any variable from all_tkvs which either + +1. Appears in the domain of kind_subst. notElemTCvSubst checks this. +2. Appears in the range of kind_subst. To do this, we compute the free + variable set of the range of kind_subst with getTCvSubstRangeFVs, and check + if a kind variable appears in that set. + +Note [Eta-reducing type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One can instantiate a type in a data family instance with a type synonym that +mentions other type variables: + + type Const a b = a + data family Fam (f :: * -> *) (a :: *) + newtype instance Fam f (Const a f) = Fam (f a) deriving Functor + +It is also possible to define kind synonyms, and they can mention other types in +a datatype declaration. For example, + + type Const a b = a + newtype T f (a :: Const * f) = T (f a) deriving Functor + +When deriving, we need to perform eta-reduction analysis to ensure that none of +the eta-reduced type variables are mentioned elsewhere in the declaration. But +we need to be careful, because if we don't expand through the Const type +synonym, we will mistakenly believe that f is an eta-reduced type variable and +fail to derive Functor, even though the code above is correct (see #11416, +where this was first noticed). For this reason, we expand the type synonyms in +the eta-reduced types before doing any analysis. + +Note [Floating `via` type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating a derived instance, it will be of the form: + + instance forall ???. C c_args (D d_args) where ... + +To fill in ???, GHC computes the free variables of `c_args` and `d_args`. +`DerivingVia` adds an extra wrinkle to this formula, since we must also +include the variables bound by the `via` type when computing the binders +used to fill in ???. This might seem strange, since if a `via` type binds +any type variables, then in almost all scenarios it will appear free in +`c_args` or `d_args`. There are certain corner cases where this does not hold, +however, such as in the following example (adapted from #15831): + + newtype Age = MkAge Int + deriving Eq via Const Int a + +In this example, the `via` type binds the type variable `a`, but `a` appears +nowhere in `Eq Age`. Nevertheless, we include it in the generated instance: + + instance forall a. Eq Age where + (==) = coerce @(Const Int a -> Const Int a -> Bool) + @(Age -> Age -> Bool) + (==) + +The use of `forall a` is certainly required here, since the `a` in +`Const Int a` would not be in scope otherwise. This instance is somewhat +strange in that nothing in the instance head `Eq Age` ever determines what `a` +will be, so any code that uses this instance will invariably instantiate `a` +to be `Any`. We refer to this property of `a` as being a "floating" `via` +type variable. Programs with floating `via` type variables are the only known +class of program in which the `via` type quantifies type variables that aren't +mentioned in the instance head in the generated instance. + +Fortunately, the choice to instantiate floating `via` type variables to `Any` +is one that is completely transparent to the user (since the instance will +work as expected regardless of what `a` is instantiated to), so we decide to +permit them. An alternative design would make programs with floating `via` +variables illegal, by requiring that every variable mentioned in the `via` type +is also mentioned in the data header or the derived class. That restriction +would require the user to pick a particular type (the choice does not matter); +for example: + + newtype Age = MkAge Int + -- deriving Eq via Const Int a -- Floating 'a' + deriving Eq via Const Int () -- Choose a=() + deriving Eq via Const Int Any -- Choose a=Any + +No expressiveness would be lost thereby, but stylistically it seems preferable +to allow a type variable to indicate "it doesn't matter". + +Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the +work of instantiating `a` to `Any` at every use site of the instance. An +alternative approach would be to generate an instance that directly defaulted +to `Any`: + + instance Eq Age where + (==) = coerce @(Const Int Any -> Const Int Any -> Bool) + @(Age -> Age -> Bool) + (==) + +We do not implement this approach since it would require a nontrivial amount +of implementation effort to substitute `Any` for the floating `via` type +variables, and since the end result isn't distinguishable from the former +instance (at least from the user's perspective), the amount of engineering +required to obtain the latter instance just isn't worth it. +-} + +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] + -> Class -> [Type] + -> DerivContext + -- SupplyContext => context supplied (standalone deriving) + -- InferContext => context inferred (deriving on data decl, or + -- standalone deriving decl with a wildcard) + -> Maybe (DerivStrategy GhcTc) + -> TcRn EarlyDerivSpec +-- Make the EarlyDerivSpec for an instance +-- forall tvs. theta => cls (tys ++ [ty]) +-- where the 'theta' is optional (that's the Maybe part) +-- Assumes that this declaration is well-kinded + +mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do + is_boot <- tcIsHsBootOrSig + when is_boot $ + bale_out (text "Cannot derive instances in hs-boot files" + $+$ text "Write an instance declaration instead") + runReaderT mk_eqn deriv_env + where + deriv_env = DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = cls_args + , denv_ctxt = deriv_ctxt + , denv_strat = deriv_strat } + + bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg + + mk_eqn :: DerivM EarlyDerivSpec + mk_eqn = do + DerivEnv { denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + case mb_strat of + Just StockStrategy -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + dit <- expectAlgTyConApp cls_tys inst_ty + mk_eqn_stock dit + + Just AnyclassStrategy -> mk_eqn_anyclass + + Just (ViaStrategy via_ty) -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + mk_eqn_via cls_tys inst_ty via_ty + + Just NewtypeStrategy -> do + (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args + dit <- expectAlgTyConApp cls_tys inst_ty + unless (isNewTyCon (dit_rep_tc dit)) $ + derivingThingFailWith False gndNonNewtypeErr + mkNewTypeEqn True dit + + Nothing -> mk_eqn_no_strategy + +-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty. +-- If so, return @(init inst_tys, last inst_tys)@. +-- Otherwise, throw an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) +expectNonNullaryClsArgs inst_tys = + maybe (derivingThingFailWith False derivingNullaryErr) pure $ + snocView inst_tys + +-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application +-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting +-- of @cls_tys@ and the constituent pars of @inst_ty@. +-- Otherwise, throw an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectAlgTyConApp :: [Type] -- All but the last argument to the class in a + -- derived instance + -> Type -- The last argument to the class in a + -- derived instance + -> DerivM DerivInstTys +expectAlgTyConApp cls_tys inst_ty = do + fam_envs <- lift tcGetFamInstEnvs + case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of + Nothing -> derivingThingFailWith False $ + text "The last argument of the instance must be a" + <+> text "data or newtype application" + Just dit -> do expectNonDataFamTyCon dit + pure dit + +-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation +-- type constructor for a data family instance, and if not, +-- throws an error message. +-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this +-- property is important. +expectNonDataFamTyCon :: DerivInstTys -> DerivM () +expectNonDataFamTyCon (DerivInstTys { dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc }) = + -- If it's still a data family, the lookup failed; i.e no instance exists + when (isDataFamilyTyCon rep_tc) $ + derivingThingFailWith False $ + text "No family instance for" <+> quotes (pprTypeApp tc tc_args) + +mk_deriv_inst_tys_maybe :: FamInstEnvs + -> [Type] -> Type -> Maybe DerivInstTys +mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty = + fmap lookup $ tcSplitTyConApp_maybe inst_ty + where + lookup :: (TyCon, [Type]) -> DerivInstTys + lookup (tc, tc_args) = + -- Find the instance of a data family + -- Note [Looking up family instances for deriving] + let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args + in DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args } + +{- +Note [Looking up family instances for deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcLookupFamInstExact is an auxiliary lookup wrapper which requires +that looked-up family instances exist. If called with a vanilla +tycon, the old type application is simply returned. + +If we have + data instance F () = ... deriving Eq + data instance F () = ... deriving Eq +then tcLookupFamInstExact will be confused by the two matches; +but that can't happen because tcInstDecls1 doesn't call tcDeriving +if there are any overlaps. + +There are two other things that might go wrong with the lookup. +First, we might see a standalone deriving clause + deriving Eq (F ()) +when there is no data instance F () in scope. + +Note that it's OK to have + data instance F [a] = ... + deriving Eq (F [(a,b)]) +where the match is not exact; the same holds for ordinary data types +with standalone deriving declarations. + +Note [Deriving, type families, and partial applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there are no type families, it's quite easy: + + newtype S a = MkS [a] + -- :CoS :: S ~ [] -- Eta-reduced + + instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) + instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S + +When type families are involved it's trickier: + + data family T a b + newtype instance T Int a = MkT [a] deriving( Eq, Monad ) + -- :RT is the representation type for (T Int a) + -- :Co:RT :: :RT ~ [] -- Eta-reduced! + -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! + + instance Eq [a] => Eq (T Int a) -- easy by coercion + -- d1 :: Eq [a] + -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) + + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + -- d1 :: Monad [] + -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) + +Note the need for the eta-reduced rule axioms. After all, we can +write it out + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + return x = MkT [x] + ... etc ... + +See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +%************************************************************************ +%* * + Deriving data types +* * +************************************************************************ +-} + +-- Once the DerivSpecMechanism is known, we can finally produce an +-- EarlyDerivSpec from it. +mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec +mk_eqn_from_mechanism mechanism + = do DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = deriv_ctxt } <- ask + doDerivInstErrorChecks1 mechanism + loc <- lift getSrcSpanM + dfun_name <- lift $ newDFunName cls inst_tys loc + case deriv_ctxt of + InferContext wildcard -> + do { (inferred_constraints, tvs', inst_tys') + <- inferConstraints mechanism + ; return $ InferTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs' + , ds_cls = cls, ds_tys = inst_tys' + , ds_theta = inferred_constraints + , ds_overlap = overlap_mode + , ds_standalone_wildcard = wildcard + , ds_mechanism = mechanism } } + + SupplyContext theta -> + return $ GivenTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_theta = theta + , ds_overlap = overlap_mode + , ds_standalone_wildcard = Nothing + , ds_mechanism = mechanism } + +mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class + -> DerivM EarlyDerivSpec +mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_rep_tc = rep_tc }) + = do DerivEnv { denv_cls = cls + , denv_ctxt = deriv_ctxt } <- ask + dflags <- getDynFlags + case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys + tc rep_tc of + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + StockClassError msg -> derivingThingFailWith False msg + _ -> derivingThingFailWith False (nonStdErr cls) + +mk_eqn_anyclass :: DerivM EarlyDerivSpec +mk_eqn_anyclass + = do dflags <- getDynFlags + case canDeriveAnyClass dflags of + IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass + NotValid msg -> derivingThingFailWith False msg + +mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class + -> Type -- The newtype's representation type + -> DerivM EarlyDerivSpec +mk_eqn_newtype dit rep_ty = + mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit + , dsm_newtype_rep_ty = rep_ty } + +mk_eqn_via :: [Type] -- All arguments to the class besides the last + -> Type -- The last argument to the class + -> Type -- The @via@ type + -> DerivM EarlyDerivSpec +mk_eqn_via cls_tys inst_ty via_ty = + mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys + , dsm_via_inst_ty = inst_ty + , dsm_via_ty = via_ty } + +-- Derive an instance without a user-requested deriving strategy. This uses +-- heuristics to determine which deriving strategy to use. +-- See Note [Deriving strategies]. +mk_eqn_no_strategy :: DerivM EarlyDerivSpec +mk_eqn_no_strategy = do + DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args } <- ask + fam_envs <- lift tcGetFamInstEnvs + + -- First, check if the last argument is an application of a type constructor. + -- If not, fall back to DeriveAnyClass. + if | Just (cls_tys, inst_ty) <- snocView cls_args + , Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty + -> if | isNewTyCon (dit_rep_tc dit) + -- We have a dedicated code path for newtypes (see the + -- documentation for mkNewTypeEqn as to why this is the case) + -> mkNewTypeEqn False dit + + | otherwise + -> do -- Otherwise, our only other options are stock or anyclass. + -- If it is stock, we must confirm that the last argument's + -- type constructor is algebraic. + -- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils + whenIsJust (hasStockDeriving cls) $ \_ -> + expectNonDataFamTyCon dit + mk_eqn_originative dit + + | otherwise + -> mk_eqn_anyclass + where + -- Use heuristics (checkOriginativeSideConditions) to determine whether + -- stock or anyclass deriving should be used. + mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec + mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_rep_tc = rep_tc }) = do + DerivEnv { denv_cls = cls + , denv_ctxt = deriv_ctxt } <- ask + dflags <- getDynFlags + + -- See Note [Deriving instances for classes themselves] + let dac_error msg + | isClassTyCon rep_tc + = quotes (ppr tc) <+> text "is a type class," + <+> text "and can only have a derived instance" + $+$ text "if DeriveAnyClass is enabled" + | otherwise + = nonStdErr cls $$ msg + + case checkOriginativeSideConditions dflags deriv_ctxt cls + cls_tys tc rep_tc of + NonDerivableClass msg -> derivingThingFailWith False (dac_error msg) + StockClassError msg -> derivingThingFailWith False msg + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass + +{- +************************************************************************ +* * + Deriving instances for newtypes +* * +************************************************************************ +-} + +-- Derive an instance for a newtype. We put this logic into its own function +-- because +-- +-- (a) When no explicit deriving strategy is requested, we have special +-- heuristics for newtypes to determine which deriving strategy should +-- actually be used. See Note [Deriving strategies]. +-- (b) We make an effort to give error messages specifically tailored to +-- newtypes. +mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@ + -- deriving strategy? + -> DerivInstTys -> DerivM EarlyDerivSpec +mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tycon + , dit_rep_tc = rep_tycon + , dit_rep_tc_args = rep_tc_args }) +-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... + = do DerivEnv { denv_cls = cls + , denv_ctxt = deriv_ctxt } <- ask + dflags <- getDynFlags + + let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags + deriveAnyClass = xopt LangExt.DeriveAnyClass dflags + + bale_out = derivingThingFailWith newtype_deriving + + non_std = nonStdErr cls + suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's" + <+> text "newtype-deriving extension" + + -- Here is the plan for newtype derivings. We see + -- newtype T a1...an = MkT (t ak+1...an) + -- deriving (.., C s1 .. sm, ...) + -- where t is a type, + -- ak+1...an is a suffix of a1..an, and are all tyvars + -- ak+1...an do not occur free in t, nor in the s1..sm + -- (C s1 ... sm) is a *partial applications* of class C + -- with the last parameter missing + -- (T a1 .. ak) matches the kind of C's last argument + -- (and hence so does t) + -- The latter kind-check has been done by deriveTyData already, + -- and tc_args are already trimmed + -- + -- We generate the instance + -- instance forall ({a1..ak} u fvs(s1..sm)). + -- C s1 .. sm t => C s1 .. sm (T a1...ak) + -- where T a1...ap is the partial application of + -- the LHS of the correct kind and p >= k + -- + -- NB: the variables below are: + -- tc_tvs = [a1, ..., an] + -- tyvars_to_keep = [a1, ..., ak] + -- rep_ty = t ak .. an + -- deriv_tvs = fvs(s1..sm) \ tc_tvs + -- tys = [s1, ..., sm] + -- rep_fn' = t + -- + -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) + -- We generate the instance + -- instance Monad (ST s) => Monad (T s) where + + nt_eta_arity = newTyConEtadArity rep_tycon + -- For newtype T a b = MkT (S a a b), the TyCon + -- machinery already eta-reduces the representation type, so + -- we know that + -- T a ~ S a a + -- That's convenient here, because we may have to apply + -- it to fewer than its original complement of arguments + + -- Note [Newtype representation] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Need newTyConRhs (*not* a recursive representation finder) + -- to get the representation type. For example + -- newtype B = MkB Int + -- newtype A = MkA B deriving( Num ) + -- We want the Num instance of B, *not* the Num instance of Int, + -- when making the Num instance of A! + rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args + + ------------------------------------------------------------------- + -- Figuring out whether we can only do this newtype-deriving thing + + -- See Note [Determining whether newtype-deriving is appropriate] + might_be_newtype_derivable + = not (non_coercible_class cls) + && eta_ok +-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] + + -- Check that eta reduction is OK + eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity + -- The newtype can be eta-reduced to match the number + -- of type argument actually supplied + -- newtype T a b = MkT (S [a] b) deriving( Monad ) + -- Here the 'b' must be the same in the rep type (S [a] b) + -- And the [a] must not mention 'b'. That's all handled + -- by nt_eta_rity. + + cant_derive_err = ppUnless eta_ok eta_msg + eta_msg = text "cannot eta-reduce the representation type enough" + + MASSERT( cls_tys `lengthIs` (classArity cls - 1) ) + if newtype_strat + then + -- Since the user explicitly asked for GeneralizedNewtypeDeriving, + -- we don't need to perform all of the checks we normally would, + -- such as if the class being derived is known to produce ill-roled + -- coercions (e.g., Traversable), since we can just derive the + -- instance and let it error if need be. + -- See Note [Determining whether newtype-deriving is appropriate] + if eta_ok && newtype_deriving + then mk_eqn_newtype dit rep_inst_ty + else bale_out (cant_derive_err $$ + if newtype_deriving then empty else suggest_gnd) + else + if might_be_newtype_derivable + && ((newtype_deriving && not deriveAnyClass) + || std_class_via_coercible cls) + then mk_eqn_newtype dit rep_inst_ty + else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys + tycon rep_tycon of + StockClassError msg + -- There's a particular corner case where + -- + -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are + -- both enabled at the same time + -- 2. We're deriving a particular stock derivable class + -- (such as Functor) + -- + -- and the previous cases won't catch it. This fixes the bug + -- reported in #10598. + | might_be_newtype_derivable && newtype_deriving + -> mk_eqn_newtype dit rep_inst_ty + -- Otherwise, throw an error for a stock class + | might_be_newtype_derivable && not newtype_deriving + -> bale_out (msg $$ suggest_gnd) + | otherwise + -> bale_out msg + + -- Must use newtype deriving or DeriveAnyClass + NonDerivableClass _msg + -- Too hard, even with newtype deriving + | newtype_deriving -> bale_out cant_derive_err + -- Try newtype deriving! + -- Here we suggest GeneralizedNewtypeDeriving even in cases + -- where it may not be applicable. See #9600. + | otherwise -> bale_out (non_std $$ suggest_gnd) + + -- DeriveAnyClass + CanDeriveAnyClass -> do + -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are + -- enabled, we take the diplomatic approach of defaulting to + -- DeriveAnyClass, but emitting a warning about the choice. + -- See Note [Deriving strategies] + when (newtype_deriving && deriveAnyClass) $ + lift $ whenWOptM Opt_WarnDerivingDefaults $ + addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep + [ text "Both DeriveAnyClass and" + <+> text "GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy" + <+> text "for instantiating" <+> ppr cls + , text "Use DerivingStrategies to pick" + <+> text "a different strategy" + ] + mk_eqn_from_mechanism DerivSpecAnyClass + -- CanDeriveStock + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + +{- +Note [Recursive newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype deriving works fine, even if the newtype is recursive. +e.g. newtype S1 = S1 [T1 ()] + newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) +Remember, too, that type families are currently (conservatively) given +a recursive flag, so this also allows newtype deriving to work +for type famillies. + +We used to exclude recursive types, because we had a rather simple +minded way of generating the instance decl: + newtype A = MkA [A] + instance Eq [A] => Eq A -- Makes typechecker loop! +But now we require a simple context, so it's ok. + +Note [Determining whether newtype-deriving is appropriate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + newtype NT = MkNT Foo + deriving C +we have to decide how to perform the deriving. Do we do newtype deriving, +or do we do normal deriving? In general, we prefer to do newtype deriving +wherever possible. So, we try newtype deriving unless there's a glaring +reason not to. + +"Glaring reasons not to" include trying to derive a class for which a +coercion-based instance doesn't make sense. These classes are listed in +the definition of non_coercible_class. They include Show (since it must +show the name of the datatype) and Traversable (since a coercion-based +Traversable instance is ill-roled). + +However, non_coercible_class is ignored if the user explicitly requests +to derive an instance with GeneralizedNewtypeDeriving using the newtype +deriving strategy. In such a scenario, GHC will unquestioningly try to +derive the instance via coercions (even if the final generated code is +ill-roled!). See Note [Deriving strategies]. + +Note that newtype deriving might fail, even after we commit to it. This +is because the derived instance uses `coerce`, which must satisfy its +`Coercible` constraint. This is different than other deriving scenarios, +where we're sure that the resulting instance will type-check. + +Note [GND and associated type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for +classes with associated type families. A general recipe is: + + class C x y z where + type T y z x + op :: x -> [y] -> z + + newtype N a = MkN deriving( C ) + + =====> + + instance C x y => C x y (N a) where + type T y (N a) x = T y x + op = coerce (op :: x -> [y] -> ) + +However, we must watch out for three things: + +(a) The class must not contain any data families. If it did, we'd have to + generate a fresh data constructor name for the derived data family + instance, and it's not clear how to do this. + +(b) Each associated type family's type variables must mention the last type + variable of the class. As an example, you wouldn't be able to use GND to + derive an instance of this class: + + class C a b where + type T a + + But you would be able to derive an instance of this class: + + class C a b where + type T b + + The difference is that in the latter T mentions the last parameter of C + (i.e., it mentions b), but the former T does not. If you tried, e.g., + + newtype Foo x = Foo x deriving (C a) + + with the former definition of C, you'd end up with something like this: + + instance C a (Foo x) where + type T a = T ??? + + This T family instance doesn't mention the newtype (or its representation + type) at all, so we disallow such constructions with GND. + +(c) UndecidableInstances might need to be enabled. Here's a case where it is + most definitely necessary: + + class C a where + type T a + newtype Loop = Loop MkLoop deriving C + + =====> + + instance C Loop where + type T Loop = T Loop + + Obviously, T Loop would send the typechecker into a loop. Unfortunately, + you might even need UndecidableInstances even in cases where the + typechecker would be guaranteed to terminate. For example: + + instance C Int where + type C Int = Int + newtype MyInt = MyInt Int deriving C + + =====> + + instance C MyInt where + type T MyInt = T Int + + GHC's termination checker isn't sophisticated enough to conclude that the + definition of T MyInt terminates, so UndecidableInstances is required. + +(d) For the time being, we do not allow the last type variable of the class to + appear in a /kind/ of an associated type family definition. For instance: + + class C a where + type T1 a -- OK + type T2 (x :: a) -- Illegal: a appears in the kind of x + type T3 y :: a -- Illegal: a appears in the kind of (T3 y) + + The reason we disallow this is because our current approach to deriving + associated type family instances—i.e., by unwrapping the newtype's type + constructor as shown above—is ill-equipped to handle the scenario when + the last type variable appears as an implicit argument. In the worst case, + allowing the last variable to appear in a kind can result in improper Core + being generated (see #14728). + + There is hope for this feature being added some day, as one could + conceivably take a newtype axiom (which witnesses a coercion between a + newtype and its representation type) at lift that through each associated + type at the Core level. See #14728, comment:3 for a sketch of how this + might work. Until then, we disallow this featurette wholesale. + +The same criteria apply to DerivingVia. + +************************************************************************ +* * +Bindings for the various classes +* * +************************************************************************ + +After all the trouble to figure out the required context for the +derived instance declarations, all that's left is to chug along to +produce them. They will then be shoved into @tcInstDecls2@, which +will do all its usual business. + +There are lots of possibilities for code to generate. Here are +various general remarks. + +PRINCIPLES: +\begin{itemize} +\item +We want derived instances of @Eq@ and @Ord@ (both v common) to be +``you-couldn't-do-better-by-hand'' efficient. + +\item +Deriving @Show@---also pretty common--- should also be reasonable good code. + +\item +Deriving for the other classes isn't that common or that big a deal. +\end{itemize} + +PRAGMATICS: + +\begin{itemize} +\item +Deriving @Ord@ is done mostly with the 1.3 @compare@ method. + +\item +Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. + +\item +We {\em normally} generate code only for the non-defaulted methods; +there are some exceptions for @Eq@ and (especially) @Ord@... + +\item +Sometimes we use a @_con2tag_@ function, which returns a data +constructor's numeric (@Int#@) tag. These are generated by +@gen_tag_n_con_binds@, and the heuristic for deciding if one of +these is around is given by @hasCon2TagFun@. + +The examples under the different sections below will make this +clearer. + +\item +Much less often (really just for deriving @Ix@), we use a +@_tag2con_@ function. See the examples. + +\item +We use the renamer!!! Reason: we're supposed to be +producing @LHsBinds Name@ for the methods, but that means +producing correctly-uniquified code on the fly. This is entirely +possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. +So, instead, we produce @MonoBinds RdrName@ then heave 'em through +the renamer. What a great hack! +\end{itemize} +-} + +-- Generate the InstInfo for the required instance +-- plus any auxiliary bindings required +genInst :: DerivSpec theta + -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]) +-- We must use continuation-returning style here to get the order in which we +-- typecheck family instances and derived instances right. +-- See Note [Staging of tcDeriving] +genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism + , ds_tys = tys, ds_cls = clas, ds_loc = loc + , ds_standalone_wildcard = wildcard }) + = do (meth_binds, meth_sigs, deriv_stuff, unusedNames) + <- set_span_and_ctxt $ + genDerivStuff mechanism loc clas tys tvs + let mk_inst_info theta = set_span_and_ctxt $ do + inst_spec <- newDerivClsInst theta spec + doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism + traceTc "newder" (ppr inst_spec) + return $ InstInfo + { iSpec = inst_spec + , iBinds = InstBindings + { ib_binds = meth_binds + , ib_tyvars = map Var.varName tvs + , ib_pragmas = meth_sigs + , ib_extensions = extensions + , ib_derived = True } } + return (mk_inst_info, deriv_stuff, unusedNames) + where + extensions :: [LangExt.Extension] + extensions + | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism + = [ + -- Both these flags are needed for higher-rank uses of coerce... + LangExt.ImpredicativeTypes, LangExt.RankNTypes + -- ...and this flag is needed to support the instance signatures + -- that bring type variables into scope. + -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate + , LangExt.InstanceSigs + ] + | otherwise + = [] + + set_span_and_ctxt :: TcM a -> TcM a + set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys) + +-- Checks: +-- +-- * All of the data constructors for a data type are in scope for a +-- standalone-derived instance (for `stock` and `newtype` deriving). +-- +-- * All of the associated type families of a class are suitable for +-- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via` +-- deriving). +doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM () +doDerivInstErrorChecks1 mechanism = + case mechanism of + DerivSpecStock{dsm_stock_dit = dit} + -> data_cons_in_scope_check dit + DerivSpecNewtype{dsm_newtype_dit = dit} + -> do atf_coerce_based_error_checks + data_cons_in_scope_check dit + DerivSpecAnyClass{} + -> pure () + DerivSpecVia{} + -> atf_coerce_based_error_checks + where + -- When processing a standalone deriving declaration, check that all of the + -- constructors for the data type are in scope. For instance: + -- + -- import M (T) + -- deriving stock instance Eq T + -- + -- This should be rejected, as the derived Eq instance would need to refer + -- to the constructors for T, which are not in scope. + -- + -- Note that the only strategies that require this check are `stock` and + -- `newtype`. Neither `anyclass` nor `via` require it as the code that they + -- generate does not require using data constructors. + data_cons_in_scope_check :: DerivInstTys -> DerivM () + data_cons_in_scope_check (DerivInstTys { dit_tc = tc + , dit_rep_tc = rep_tc }) = do + standalone <- isStandaloneDeriv + when standalone $ do + let bale_out msg = do err <- derivingThingErrMechanism mechanism msg + lift $ failWithTc err + + rdr_env <- lift getGlobalRdrEnv + let data_con_names = map dataConName (tyConDataCons rep_tc) + hidden_data_cons = not (isWiredIn rep_tc) && + (isAbstractTyCon rep_tc || + any not_in_scope data_con_names) + not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc) + + -- Make sure to also mark the data constructors as used so that GHC won't + -- mistakenly emit -Wunused-imports warnings about them. + lift $ addUsedDataCons rdr_env rep_tc + + unless (not hidden_data_cons) $ + bale_out $ derivingHiddenErr tc + + -- Ensure that a class's associated type variables are suitable for + -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is + -- only required for the `newtype` and `via` strategies. + -- + -- See Note [GND and associated type families] + atf_coerce_based_error_checks :: DerivM () + atf_coerce_based_error_checks = do + cls <- asks denv_cls + let bale_out msg = do err <- derivingThingErrMechanism mechanism msg + lift $ failWithTc err + + cls_tyvars = classTyVars cls + + ats_look_sensible + = -- Check (a) from Note [GND and associated type families] + no_adfs + -- Check (b) from Note [GND and associated type families] + && isNothing at_without_last_cls_tv + -- Check (d) from Note [GND and associated type families] + && isNothing at_last_cls_tv_in_kinds + + (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs + no_adfs = null adf_tcs + -- We cannot newtype-derive data family instances + + at_without_last_cls_tv + = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs + at_last_cls_tv_in_kinds + = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) + (tyConTyVars tc) + || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs + at_last_cls_tv_in_kind kind + = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind + at_tcs = classATs cls + last_cls_tv = ASSERT( notNull cls_tyvars ) + last cls_tyvars + + cant_derive_err + = vcat [ ppUnless no_adfs adfs_msg + , maybe empty at_without_last_cls_tv_msg + at_without_last_cls_tv + , maybe empty at_last_cls_tv_in_kinds_msg + at_last_cls_tv_in_kinds + ] + adfs_msg = text "the class has associated data types" + at_without_last_cls_tv_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "is not parameterized over the last type variable") + 2 (text "of the class" <+> quotes (ppr cls)) + at_last_cls_tv_in_kinds_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "contains the last type variable") + 2 (text "of the class" <+> quotes (ppr cls) + <+> text "in a kind, which is not (yet) allowed") + unless ats_look_sensible $ bale_out cant_derive_err + +doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan + -> DerivSpecMechanism -> TcM () +doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism + = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst) + ; dflags <- getDynFlags + ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures + ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures + + -- Error if PartialTypeSignatures isn't enabled when a user tries + -- to write @deriving instance _ => Eq (Foo a)@. Or, if that + -- extension is enabled, give a warning if -Wpartial-type-signatures + -- is enabled. + ; case wildcard of + Nothing -> pure () + Just span -> setSrcSpan span $ do + checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) + warnTc (Reason Opt_WarnPartialTypeSignatures) + wpartial_sigs partial_sig_msg + + -- Check for Generic instances that are derived with an exotic + -- deriving strategy like DAC + -- See Note [Deriving strategies] + ; when (exotic_mechanism && className clas `elem` genericClassNames) $ + do { failIfTc (safeLanguageOn dflags) gen_inst_err + ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } + where + exotic_mechanism = not $ isDerivSpecStock mechanism + + partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + + pts_suggestion + = text "To use the inferred type, enable PartialTypeSignatures" + + gen_inst_err = text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." + +derivingThingFailWith :: Bool -- If True, add a snippet about how not even + -- GeneralizedNewtypeDeriving would make this + -- declaration work. This only kicks in when + -- an explicit deriving strategy is not given. + -> SDoc -- The error message + -> DerivM a +derivingThingFailWith newtype_deriving msg = do + err <- derivingThingErrM newtype_deriving msg + lift $ failWithTc err + +genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class + -> [Type] -> [TyVar] + -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]) +genDerivStuff mechanism loc clas inst_tys tyvars + = case mechanism of + -- See Note [Bindings for Generalised Newtype Deriving] + DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty} + -> gen_newtype_or_via rhs_ty + + -- Try a stock deriver + DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc} + , dsm_stock_gen_fn = gen_fn } + -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys + pure (binds, [], faminsts, field_names) + + -- Try DeriveAnyClass + DerivSpecAnyClass -> do + let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + dflags <- getDynFlags + tyfam_insts <- + -- canDeriveAnyClass should ensure that this code can't be reached + -- unless -XDeriveAnyClass is enabled. + ASSERT2( isValid (canDeriveAnyClass dflags) + , ppr "genDerivStuff: bad derived class" <+> ppr clas ) + mapM (tcATDefault loc mini_subst emptyNameSet) + (classATItems clas) + return ( emptyBag, [] -- No method bindings are needed... + , listToBag (map DerivFamInst (concat tyfam_insts)) + -- ...but we may need to generate binding for associated type + -- family default instances. + -- See Note [DeriveAnyClass and default family instances] + , [] ) + + -- Try DerivingVia + DerivSpecVia{dsm_via_ty = via_ty} + -> gen_newtype_or_via via_ty + where + gen_newtype_or_via ty = do + (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty + return (binds, sigs, faminsts, []) + +{- +Note [Bindings for Generalised Newtype Deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Eq a => C a where + f :: a -> a + newtype N a = MkN [a] deriving( C ) + instance Eq (N a) where ... + +The 'deriving C' clause generates, in effect + instance (C [a], Eq a) => C (N a) where + f = coerce (f :: [a] -> [a]) + +This generates a cast for each method, but allows the superclasse to +be worked out in the usual way. In this case the superclass (Eq (N +a)) will be solved by the explicit Eq (N a) instance. We do *not* +create the superclasses by casting the superclass dictionaries for the +representation type. + +See the paper "Safe zero-cost coercions for Haskell". + +Note [DeriveAnyClass and default family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When a class has a associated type family with a default instance, e.g.: + + class C a where + type T a + type T a = Char + +then there are a couple of scenarios in which a user would expect T a to +default to Char. One is when an instance declaration for C is given without +an implementation for T: + + instance C Int + +Another scenario in which this can occur is when the -XDeriveAnyClass extension +is used: + + data Example = Example deriving (C, Generic) + +In the latter case, we must take care to check if C has any associated type +families with default instances, because -XDeriveAnyClass will never provide +an implementation for them. We "fill in" the default instances using the +tcATDefault function from GHC.Tc.TyCl.Class (which is also used in GHC.Tc.TyCl.Instance to +handle the empty instance declaration case). + +Note [Deriving strategies] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has a notion of deriving strategies, which allow the user to explicitly +request which approach to use when deriving an instance (enabled with the +-XDerivingStrategies language extension). For more information, refer to the +original issue (#10598) or the associated wiki page: +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies + +A deriving strategy can be specified in a deriving clause: + + newtype Foo = MkFoo Bar + deriving newtype C + +Or in a standalone deriving declaration: + + deriving anyclass instance C Foo + +-XDerivingStrategies also allows the use of multiple deriving clauses per data +declaration so that a user can derive some instance with one deriving strategy +and other instances with another deriving strategy. For example: + + newtype Baz = Baz Quux + deriving (Eq, Ord) + deriving stock (Read, Show) + deriving newtype (Num, Floating) + deriving anyclass C + +Currently, the deriving strategies are: + +* stock: Have GHC implement a "standard" instance for a data type, if possible + (e.g., Eq, Ord, Generic, Data, Functor, etc.) + +* anyclass: Use -XDeriveAnyClass + +* newtype: Use -XGeneralizedNewtypeDeriving + +* via: Use -XDerivingVia + +The latter two strategies (newtype and via) are referred to as the +"coerce-based" strategies, since they generate code that relies on the `coerce` +function. See, for instance, GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased. + +The former two strategies (stock and anyclass), in contrast, are +referred to as the "originative" strategies, since they create "original" +instances instead of "reusing" old instances (by way of `coerce`). +See, for instance, GHC.Tc.Deriv.Utils.checkOriginativeSideConditions. + +If an explicit deriving strategy is not given, GHC has an algorithm it uses to +determine which strategy it will actually use. The algorithm is quite long, +so it lives in the Haskell wiki at +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies +("The deriving strategy resolution algorithm" section). + +Internally, GHC uses the DerivStrategy datatype to denote a user-requested +deriving strategy, and it uses the DerivSpecMechanism datatype to denote what +GHC will use to derive the instance after taking the above steps. In other +words, GHC will always settle on a DerivSpecMechnism, even if the user did not +ask for a particular DerivStrategy (using the algorithm linked to above). + +Note [Deriving instances for classes themselves] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Much of the code in GHC.Tc.Deriv assumes that deriving only works on data types. +But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly +reasonable to do something like this: + + {-# LANGUAGE DeriveAnyClass #-} + class C1 (a :: Constraint) where + class C2 where + deriving instance C1 C2 + -- This is equivalent to `instance C1 C2` + +If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock +deriving), we throw a special error message indicating that DeriveAnyClass is +the only way to go. We don't bother throwing this error if an explicit 'stock' +or 'newtype' keyword is used, since both options have their own perfectly +sensible error messages in the case of the above code (as C1 isn't a stock +derivable class, and C2 isn't a newtype). + +************************************************************************ +* * +What con2tag/tag2con functions are available? +* * +************************************************************************ +-} + +nonUnaryErr :: LHsSigType GhcRn -> SDoc +nonUnaryErr ct = quotes (ppr ct) + <+> text "is not a unary constraint, as expected by a deriving clause" + +nonStdErr :: Class -> SDoc +nonStdErr cls = + quotes (ppr cls) + <+> text "is not a stock derivable class (Eq, Show, etc.)" + +gndNonNewtypeErr :: SDoc +gndNonNewtypeErr = + text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" + +derivingNullaryErr :: MsgDoc +derivingNullaryErr = text "Cannot derive instances for nullary classes" + +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc +derivingKindErr tc cls cls_tys cls_kind enough_args + = sep [ hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys + <+> parens (ppr tc <+> text "..."))) + 2 gen1_suggestion + , nest 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind)) + ] + where + gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args + = text "(Perhaps you intended to use PolyKinds)" + | otherwise = Outputable.empty + +derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc +derivingViaKindErr cls cls_kind via_ty via_kind + = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + +derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc +derivingEtaErr cls cls_tys inst_ty + = sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" + <+> pprClassPred cls (cls_tys ++ [inst_ty]))] + +derivingThingErr :: Bool -> Class -> [Type] + -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc +derivingThingErr newtype_deriving cls cls_args mb_strat why + = derivingThingErr' newtype_deriving cls cls_args mb_strat + (maybe empty derivStrategyName mb_strat) why + +derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc +derivingThingErrM newtype_deriving why + = do DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why + +derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc +derivingThingErrMechanism mechanism why + = do DerivEnv { denv_cls = cls + , denv_inst_tys = cls_args + , denv_strat = mb_strat } <- ask + pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat + (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why + +derivingThingErr' :: Bool -> Class -> [Type] + -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc +derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why + = sep [(hang (text "Can't make a derived instance of") + 2 (quotes (ppr pred) <+> via_mechanism) + $$ nest 2 extra) <> colon, + nest 2 why] + where + strat_used = isJust mb_strat + extra | not strat_used, newtype_deriving + = text "(even with cunning GeneralizedNewtypeDeriving)" + | otherwise = empty + pred = mkClassPred cls cls_args + via_mechanism | strat_used + = text "with the" <+> strat_msg <+> text "strategy" + | otherwise + = empty + +derivingHiddenErr :: TyCon -> SDoc +derivingHiddenErr tc + = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) + 2 (text "so you cannot derive an instance for it") + +standaloneCtxt :: LHsSigWcType GhcRn -> SDoc +standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") + 2 (quotes (ppr ty)) diff --git a/GHC/Tc/Deriv/Functor.hs b/GHC/Tc/Deriv/Functor.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Functor.hs @@ -0,0 +1,1443 @@ +{- +(c) The University of Glasgow 2011 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +-- | The deriving code for the Functor, Foldable, and Traversable classes +module GHC.Tc.Deriv.Functor + ( FFoldType(..) + , functorLikeTraverse + , deepSubtypesContaining + , foldDataConArgs + + , gen_Functor_binds + , gen_Foldable_binds + , gen_Traversable_binds + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.DataCon +import GHC.Data.FastString +import GHC.Hs +import GHC.Utils.Outputable +import GHC.Builtin.Names +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Utils.Monad.State +import GHC.Tc.Deriv.Generate +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id.Make (coerceId) +import GHC.Builtin.Types (true_RDR, false_RDR) + +import Data.Maybe (catMaybes, isJust) + +{- +************************************************************************ +* * + Functor instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +For the data type: + + data T a = T1 Int a | T2 (T a) + +We generate the instance: + + instance Functor T where + fmap f (T1 b1 a) = T1 b1 (f a) + fmap f (T2 ta) = T2 (fmap f ta) + +Notice that we don't simply apply 'fmap' to the constructor arguments. +Rather + - Do nothing to an argument whose type doesn't mention 'a' + - Apply 'f' to an argument of type 'a' + - Apply 'fmap f' to other arguments +That's why we have to recurse deeply into the constructor argument types, +rather than just one level, as we typically do. + +What about types with more than one type parameter? In general, we only +derive Functor for the last position: + + data S a b = S1 [b] | S2 (a, T a b) + instance Functor (S a) where + fmap f (S1 bs) = S1 (fmap f bs) + fmap f (S2 (p,q)) = S2 (a, fmap f q) + +However, we have special cases for + - tuples + - functions + +More formally, we write the derivation of fmap code over type variable +'a for type 'b as ($fmap 'a 'b x). In this general notation the derived +instance for T is: + + instance Functor T where + fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) + fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) + + $(fmap 'a 'b x) = x -- when b does not contain a + $(fmap 'a 'a x) = f x + $(fmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2)) + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y))) + +For functions, the type parameter 'a can occur in a contravariant position, +which means we need to derive a function like: + + cofmap :: (a -> b) -> (f b -> f a) + +This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and +$(cofmap 'a '(T b1 a) x) cases: + + $(cofmap 'a 'b x) = x -- when b does not contain a + $(cofmap 'a 'a x) = error "type variable in contravariant position" + $(cofmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) + $(cofmap 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T + $(cofmap 'a '(T b1 b2) x) = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y))) + +Note that the code produced by $(fmap _ _ _) is always a higher order function, +with type `(a -> b) -> (g a -> g b)` for some g. + +Note that there are two distinct cases in $fmap (and $cofmap) that match on an +application of some type constructor T (where T is not a tuple type +constructor): + + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +While the latter case technically subsumes the former case, it is important to +give special treatment to the former case to avoid unnecessary eta expansion. +See Note [Avoid unnecessary eta expansion in derived fmap implementations]. + +We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for +an explanation of why this is important. Just like $fmap/$cofmap above, there +is a similar algorithm for generating `p <$ x` (for some constant `p`): + + $(replace 'a 'b x) = x -- when b does not contain a + $(replace 'a 'a x) = p + $(replace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2)) + $(replace 'a '(T b1 a) x) = p <$ x -- when a only occurs directly as the last argument of T + $(replace 'a '(T b1 b2) x) = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y))) + + $(coreplace 'a 'b x) = x -- when b does not contain a + $(coreplace 'a 'a x) = error "type variable in contravariant position" + $(coreplace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2)) + $(coreplace 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T + $(coreplace 'a '(T b1 b2) x) = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) +-} + +gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +-- When the argument is phantom, we can use fmap _ = coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Functor_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag fmap_bind, emptyBag) + where + fmap_name = L loc fmap_RDR + fmap_bind = mkRdrFunBind fmap_name fmap_eqns + fmap_eqns = [mkSimpleMatch fmap_match_ctxt + [nlWildPat] + coerce_Expr] + fmap_match_ctxt = mkPrefixFunRhs fmap_name + +gen_Functor_binds loc tycon + = (listToBag [fmap_bind, replace_bind], emptyBag) + where + data_cons = tyConDataCons tycon + fmap_name = L loc fmap_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns + fmap_match_ctxt = mkPrefixFunRhs fmap_name + + fmap_eqn con = flip evalState bs_RDRs $ + match_for_con fmap_match_ctxt [f_Pat] con parts + where + parts = foldDataConArgs ft_fmap con + + fmap_eqns = map fmap_eqn data_cons + + ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_fmap = FT { ft_triv = \x -> pure x + -- fmap f x = x + , ft_var = \x -> pure $ nlHsApp f_Expr x + -- fmap f x = f x + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ nlHsApp x gg + -- fmap f x = \b -> h (x (g b)) + , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) + -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + , ft_ty_app = \_ arg_ty g x -> + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can generate + -- more efficient code. + -- See Note [Avoid unnecessary eta expansion in derived fmap implementations] + if tcIsTyVarTy arg_ty + then pure $ nlHsApps fmap_RDR [f_Expr,x] + else do gg <- mkSimpleLam g + pure $ nlHsApps fmap_RDR [gg,x] + -- fmap f x = fmap g x + , ft_forall = \_ g x -> g x + , ft_bad_app = panic "in other argument in ft_fmap" + , ft_co_var = panic "contravariant in ft_fmap" } + + -- See Note [Deriving <$] + replace_name = L loc replace_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns + replace_match_ctxt = mkPrefixFunRhs replace_name + + replace_eqn con = flip evalState bs_RDRs $ + match_for_con replace_match_ctxt [z_Pat] con parts + where + parts = foldDataConArgs ft_replace con + + replace_eqns = map replace_eqn data_cons + + ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_replace = FT { ft_triv = \x -> pure x + -- p <$ x = x + , ft_var = \_ -> pure z_Expr + -- p <$ _ = p + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ nlHsApp x gg + -- p <$ x = \b -> h (x (g b)) + , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) + -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + , ft_ty_app = \_ arg_ty g x -> + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can generate + -- more efficient code. + -- See [Deriving <$] + if tcIsTyVarTy arg_ty + then pure $ nlHsApps replace_RDR [z_Expr,x] + else do gg <- mkSimpleLam g + pure $ nlHsApps fmap_RDR [gg,x] + -- p <$ x = fmap (p <$) x + , ft_forall = \_ g x -> g x + , ft_bad_app = panic "in other argument in ft_replace" + , ft_co_var = panic "contravariant in ft_replace" } + + -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... + match_for_con :: Monad m + => HsMatchContext GhcPs + -> [LPat GhcPs] -> DataCon + -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_for_con ctxt = mkSimpleConMatch ctxt $ + \con_name xsM -> do xs <- sequence xsM + pure $ nlHsApps con_name xs -- Con x1 x2 .. + +{- +Note [Avoid unnecessary eta expansion in derived fmap implementations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the sake of simplicity, the algorithm that derived implementations of +fmap used to have a single case that dealt with applications of some type +constructor T (where T is not a tuple type constructor): + + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +This generated less than optimal code in certain situations, however. Consider +this example: + + data List a = Nil | Cons a (List a) deriving Functor + +This would generate the following Functor instance: + + instance Functor List where + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs) + +The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application +of `f`. What's worse, this eta expansion actually degrades performance! To see +why, we can trace an invocation of fmap on a small List: + + fmap id $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ fmap (\y -> id y) + $ Cons 0 $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ fmap (\y' -> (\y -> id y) y') + $ Cons 0 $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'') + $ Cons 0 Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) + $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''') + $ Nil + + Cons (id 0) $ Cons ((\y -> id y) 0) + $ Cons ((\y' -> (\y -> id y) y') 0) + $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) + $ Nil + +Notice how the number of lambdas—and hence, the number of closures—one +needs to evaluate grows very quickly. In general, a List with N cons cells will +require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is +what caused the performance issues observed in #7436. + +But hold on a second: shouldn't GHC's optimizer be able to eta reduce +`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not +the case. In general, eta reduction can change the semantics of a program. For +instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so +happens that the fmap implementation above would have the same semantics +regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is +not yet smart enough to realize this (see #17881). + +To avoid this quadratic blowup, we add a special case to $fmap that applies +`fmap f` directly: + + $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T + $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 + +With this modified algorithm, the derived Functor List instance becomes: + + instance Functor List where + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap f xs) + +No lambdas in sight, just the way we like it. + +This special case does not prevent all sources quadratic closure buildup, +however. In this example: + + data PolyList a = PLNil | PLCons a (PolyList (PolyList a)) + deriving Functor + +We would derive the following code: + + instance Functor PolyList where + fmap f PLNil = PLNil + fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs) + +The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way +as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced +to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are +recursively invoking fmap with a different argument (fmap f). Since we end up +paying the price of building a closure either way, we do not extend the special +case in $fmap any further, since it wouldn't buy us anything. + +The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by +inspecting the argument type. If the argument type is a bare type variable, +then we can conclude the type variable /must/ be the same as the data type's +last type parameter. We know that this must be the case since there is an +invariant that the argument type in ft_ty_app will always contain the last +type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so +if the argument type is a bare variable, then that must be exactly the last +type parameter. + +Note that the ft_ty_app case of ft_replace (which derives implementations of +(<$)) also inspects the argument type to generate more efficient code. +See Note [Deriving <$]. + +Note [Deriving <$] +~~~~~~~~~~~~~~~~~~ + +We derive the definition of <$. Allowing this to take the default definition +can lead to memory leaks: mapping over a structure with a constant function can +fill the result structure with trivial thunks that retain the values from the +original structure. The simplifier seems to handle this all right for simple +types, but not for recursive ones. Consider + +data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor + +-- fmap _ Tip = Tip +-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) + +Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that +simplifies no further. Why is that? `fmap` is defined recursively, so GHC +cannot inline it. The static argument transformation would turn the definition +into a non-recursive one + +-- fmap f = go where +-- go Tip = Tip +-- go (Bin l v r) = Bin (go l) (f v) (go r) + +which GHC could inline, producing an efficient definion of `<$`. But there are +several problems. First, GHC does not perform the static argument transformation +by default, even with -O2. Second, even when it does perform the static argument +transformation, it does so only when there are at least two static arguments, +which is not the case for fmap. Finally, when the type in question is +non-regular, such as + +data Nesty a = Z a | S (Nesty a) (Nest (a, a)) + +the function argument is no longer (entirely) static, so the static argument +transformation will do nothing for us. + +Applying the default definition of `<$` will produce a tree full of thunks that +look like ((\_ -> x) x0), which represents unnecessary thunk allocation and +also retention of the previous value, potentially leaking memory. Instead, we +derive <$ separately. Two aspects are different from fmap: the case of the +sought type variable (ft_var) and the case of a type application (ft_ty_app). +The interesting one is ft_ty_app. We have to distinguish two cases: the +"immediate" case where the type argument *is* the sought type variable, and +the "nested" case where the type argument *contains* the sought type variable. + +The immediate case: + +Suppose we have + +data Imm a = Imm (F ... a) + +Then we want to define + +x <$ Imm q = Imm (x <$ q) + +The nested case: + +Suppose we have + +data Nes a = Nes (F ... (G a)) + +Then we want to define + +x <$ Nes q = Nes (fmap (x <$) q) + +We inspect the argument type in ft_ty_app +(see Note [FFoldType and functorLikeTraverse]) to distinguish between these +two cases. If the argument type is a bare type variable, then we know that it +must be the same variable as the data type's last type parameter. +This is very similar to a trick that derived fmap implementations +use in their own ft_ty_app case. +See Note [Avoid unnecessary eta expansion in derived fmap implementations], +which explains why checking if the argument type is a bare variable is +the right thing to do. + +We could, but do not, give tuples special treatment to improve efficiency +in some cases. Suppose we have + +data Nest a = Z a | S (Nest (a,a)) + +The optimal definition would be + +x <$ Z _ = Z x +x <$ S t = S ((x, x) <$ t) + +which produces a result with maximal internal sharing. The reason we do not +attempt to treat this case specially is that we have no way to give +user-provided tuple-like types similar treatment. If the user changed the +definition to + +data Pair a = Pair a a +data Nest a = Z a | S (Nest (Pair a)) + +they would experience a surprising degradation in performance. -} + + +{- +Utility functions related to Functor deriving. + +Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. +This function works like a fold: it makes a value of type 'a' in a bottom up way. +-} + +-- Generic traversal for Functor deriving +-- See Note [FFoldType and functorLikeTraverse] +data FFoldType a -- Describes how to fold over a Type in a functor like way + = FT { ft_triv :: a + -- ^ Does not contain variable + , ft_var :: a + -- ^ The variable itself + , ft_co_var :: a + -- ^ The variable itself, contravariantly + , ft_fun :: a -> a -> a + -- ^ Function type + , ft_tup :: TyCon -> [a] -> a + -- ^ Tuple type. The @[a]@ is the result of folding over the + -- arguments of the tuple. + , ft_ty_app :: Type -> Type -> a -> a + -- ^ Type app, variable only in last argument. The two 'Type's are + -- the function and argument parts of @fun_ty arg_ty@, + -- respectively. + , ft_bad_app :: a + -- ^ Type app, variable other than in last argument + , ft_forall :: TcTyVar -> a -> a + -- ^ Forall type + } + +functorLikeTraverse :: forall a. + TyVar -- ^ Variable to look for + -> FFoldType a -- ^ How to fold + -> Type -- ^ Type to process + -> a +functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_co_var = caseCoVar, ft_fun = caseFun + , ft_tup = caseTuple, ft_ty_app = caseTyApp + , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) + ty + = fst (go False ty) + where + go :: Bool -- Covariant or contravariant context + -> Type + -> (a, Bool) -- (result of type a, does type contain var) + + go co ty | Just ty' <- tcView ty = go co ty' + go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) + go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) + | InvisArg <- af = go co y + | xc || yc = (caseFun xr yr,True) + where (xr,xc) = go (not co) x + (yr,yc) = go co y + go co (AppTy x y) | xc = (caseWrongArg, True) + | yc = (caseTyApp x y yr, True) + where (_, xc) = go co x + (yr,yc) = go co y + go co ty@(TyConApp con args) + | not (or xcs) = (caseTrivial, False) -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | isTupleTyCon con = (caseTuple con xrs, True) + | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty + | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty -- T (..no var..) ty + = (caseTyApp fun_ty arg_ty (last xrs), True) + | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) + where + -- When folding over an unboxed tuple, we must explicitly drop the + -- runtime rep arguments, or else GHC will generate twice as many + -- variables in a unboxed tuple pattern match and expression as it + -- actually needs. See #12399 + (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) + go co (ForAllTy (Bndr v vis) x) + | isVisibleArgFlag vis = panic "unexpected visible binder" + | v /= var && xc = (caseForAll v xr,True) + where (xr,xc) = go co x + + go _ _ = (caseTrivial,False) + +-- Return all syntactic subterms of ty that contain var somewhere +-- These are the things that should appear in instance constraints +deepSubtypesContaining :: TyVar -> Type -> [TcType] +deepSubtypesContaining tv + = functorLikeTraverse tv + (FT { ft_triv = [] + , ft_var = [] + , ft_fun = (++) + , ft_tup = \_ xs -> concat xs + , ft_ty_app = \t _ ts -> t:ts + , ft_bad_app = panic "in other argument in deepSubtypesContaining" + , ft_co_var = panic "contravariant in deepSubtypesContaining" + , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) + + +foldDataConArgs :: FFoldType a -> DataCon -> [a] +-- Fold over the arguments of the datacon +foldDataConArgs ft con + = map foldArg (map scaledThing $ dataConOrigArgTys con) + where + foldArg + = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of + Just tv -> functorLikeTraverse tv ft + Nothing -> const (ft_triv ft) + -- If we are deriving Foldable for a GADT, there is a chance that the last + -- type variable in the data type isn't actually a type variable at all. + -- (for example, this can happen if the last type variable is refined to + -- be a concrete type such as Int). If the last type variable is refined + -- to be a specific type, then getTyVar_maybe will return Nothing. + -- See Note [DeriveFoldable with ExistentialQuantification] + -- + -- The kind checks have ensured the last type parameter is of kind *. + +-- Make a HsLam using a fresh variable from a State monad +mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + -> State [RdrName] (LHsExpr GhcPs) +-- (mkSimpleLam fn) returns (\x. fn(x)) +mkSimpleLam lam = + get >>= \case + n:names -> do + put names + body <- lam (nlHsVar n) + return (mkHsLam [nlVarPat n] body) + _ -> panic "mkSimpleLam" + +mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs + -> State [RdrName] (LHsExpr GhcPs)) + -> State [RdrName] (LHsExpr GhcPs) +mkSimpleLam2 lam = + get >>= \case + n1:n2:names -> do + put names + body <- lam (nlHsVar n1) (nlHsVar n2) + return (mkHsLam [nlVarPat n1,nlVarPat n2] body) + _ -> panic "mkSimpleLam2" + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +-- +-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in +-- which the LHS pattern-matches on @extra_pats@, followed by a match on the +-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ +-- and its arguments, applying an expression (from @insides@) to each of the +-- respective arguments of @con@. +mkSimpleConMatch :: Monad m => HsMatchContext GhcPs + -> (RdrName -> [a] -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] + -> DataCon + -> [LHsExpr GhcPs -> a] + -> m (LMatch GhcPs (LHsExpr GhcPs)) +mkSimpleConMatch ctxt fold extra_pats con insides = do + let con_name = getRdrName con + let vars_needed = takeList insides as_RDRs + let bare_pat = nlConVarPat con_name vars_needed + let pat = if null vars_needed + then bare_pat + else nlParPat bare_pat + rhs <- fold con_name + (zipWith (\i v -> i $ nlHsVar v) insides vars_needed) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs + (noLoc emptyLocalBinds) + +-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" +-- +-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to +-- 'mkSimpleConMatch', with two key differences: +-- +-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a +-- @[LHsExpr RdrName]@. This is because it filters out the expressions +-- corresponding to arguments whose types do not mention the last type +-- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the +-- 'Nothing' elements of @insides@). +-- +-- 2. @fold@ takes an expression as its first argument instead of a +-- constructor name. This is because it uses a specialized +-- constructor function expression that only takes as many parameters as +-- there are argument types that mention the last type variable. +-- +-- See Note [Generated code for DeriveFoldable and DeriveTraversable] +mkSimpleConMatch2 :: Monad m + => HsMatchContext GhcPs + -> (LHsExpr GhcPs -> [LHsExpr GhcPs] + -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) +mkSimpleConMatch2 ctxt fold extra_pats con insides = do + let con_name = getRdrName con + vars_needed = takeList insides as_RDRs + pat = nlConVarPat con_name vars_needed + -- Make sure to zip BEFORE invoking catMaybes. We want the variable + -- indices in each expression to match up with the argument indices + -- in con_expr (defined below). + exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i) + insides vars_needed + -- An element of argTysTyVarInfo is True if the constructor argument + -- with the same index has a type which mentions the last type + -- variable. + argTysTyVarInfo = map isJust insides + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars + + con_expr + | null asWithTyVar = nlHsApps con_name asWithoutTyVar + | otherwise = + let bs = filterByList argTysTyVarInfo bs_RDRs + vars = filterByLists argTysTyVarInfo bs_Vars as_Vars + in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) + + rhs <- fold con_expr exps + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs + (noLoc emptyLocalBinds) + +-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] + -> m (LMatch GhcPs (LHsExpr GhcPs))) + -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) +mkSimpleTupleCase match_for_con tc insides x + = do { let data_con = tyConSingleDataCon tc + ; match <- match_for_con [] data_con insides + ; return $ nlHsCase x [match] } + +{- +************************************************************************ +* * + Foldable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +Deriving Foldable instances works the same way as Functor instances, +only Foldable instances are not possible for function types at all. +Given (data T a = T a a (T a) deriving Foldable), we get: + + instance Foldable T where + foldr f z (T x1 x2 x3) = + $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) + +-XDeriveFoldable is different from -XDeriveFunctor in that it filters out +arguments to the constructor that would produce useless code in a Foldable +instance. For example, the following datatype: + + data Foo a = Foo Int a Int deriving Foldable + +would have the following generated Foldable instance: + + instance Foldable Foo where + foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 + +since neither of the two Int arguments are folded over. + +The cases are: + + $(foldr 'a 'a) = f + $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) + $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 + +Note that the arguments to the real foldr function are the wrong way around, +since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). + +One can envision a case for types that don't contain the last type variable: + + $(foldr 'a 'b) = \x z -> z -- when b does not contain a + +But this case will never materialize, since the aforementioned filtering +removes all such types from consideration. +See Note [Generated code for DeriveFoldable and DeriveTraversable]. + +Foldable instances differ from Functor and Traversable instances in that +Foldable instances can be derived for data types in which the last type +variable is existentially quantified. In particular, if the last type variable +is refined to a more specific type in a GADT: + + data GADT a where + G :: a ~ Int => a -> G Int + +then the deriving machinery does not attempt to check that the type a contains +Int, since it is not syntactically equal to a type variable. That is, the +derived Foldable instance for GADT is: + + instance Foldable GADT where + foldr _ z (GADT _) = z + +See Note [DeriveFoldable with ExistentialQuantification]. + +Note [Deriving null] +~~~~~~~~~~~~~~~~~~~~ + +In some cases, deriving the definition of 'null' can produce much better +results than the default definition. For example, with + + data SnocList a = Nil | Snoc (SnocList a) a + +the default definition of 'null' would walk the entire spine of a +nonempty snoc-list before concluding that it is not null. But looking at +the Snoc constructor, we can immediately see that it contains an 'a', and +so 'null' can return False immediately if it matches on Snoc. When we +derive 'null', we keep track of things that cannot be null. The interesting +case is type application. Given + + data Wrap a = Wrap (Foo (Bar a)) + +we use + + null (Wrap fba) = all null fba + +but if we see + + data Wrap a = Wrap (Foo a) + +we can just use + + null (Wrap fa) = null fa + +Indeed, we allow this to happen even for tuples: + + data Wrap a = Wrap (Foo (a, Int)) + +produces + + null (Wrap fa) = null fa + +As explained in Note [Deriving <$], giving tuples special performance treatment +could surprise users if they switch to other types, but Ryan Scott seems to +think it's okay to do it for now. +-} + +gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +-- When the parameter is phantom, we can use foldMap _ _ = mempty +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Foldable_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag foldMap_bind, emptyBag) + where + foldMap_name = L loc foldMap_RDR + foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns + foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt + [nlWildPat, nlWildPat] + mempty_Expr] + foldMap_match_ctxt = mkPrefixFunRhs foldMap_name + +gen_Foldable_binds loc tycon + | null data_cons -- There's no real point producing anything but + -- foldMap for a type with no constructors. + = (unitBag foldMap_bind, emptyBag) + + | otherwise + = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag) + where + data_cons = tyConDataCons tycon + + foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns + eqns = map foldr_eqn data_cons + foldr_eqn con + = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldr con + + foldMap_name = L loc foldMap_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) + foldMap_name foldMap_eqns + + foldMap_eqns = map foldMap_eqn data_cons + + foldMap_eqn con + = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldMap con + + -- Given a list of NullM results, produce Nothing if any of + -- them is NotNull, and otherwise produce a list of Maybes + -- with Justs representing unknowns and Nothings representing + -- things that are definitely null. + convert :: [NullM a] -> Maybe [Maybe a] + convert = traverse go where + go IsNull = Just Nothing + go NotNull = Nothing + go (NullM a) = Just (Just a) + + null_name = L loc null_RDR + null_match_ctxt = mkPrefixFunRhs null_name + null_bind = mkRdrFunBind null_name null_eqns + null_eqns = map null_eqn data_cons + null_eqn con + = flip evalState bs_RDRs $ do + parts <- sequence $ foldDataConArgs ft_null con + case convert parts of + Nothing -> return $ + mkMatch null_match_ctxt [nlParPat (nlWildConPat con)] + false_Expr (noLoc emptyLocalBinds) + Just cp -> match_null [] con cp + + -- Yields 'Just' an expression if we're folding over a type that mentions + -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. + -- See Note [FFoldType and functorLikeTraverse] + ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldr + = FT { ft_triv = return Nothing + -- foldr f = \x z -> z + , ft_var = return $ Just f_Expr + -- foldr f = f + , ft_tup = \t g -> do + gg <- sequence g + lam <- mkSimpleLam2 $ \x z -> + mkSimpleTupleCase (match_foldr z) t gg x + return (Just lam) + -- foldr f = (\x z -> case x of ...) + , ft_ty_app = \_ _ g -> do + gg <- g + mapM (\gg' -> mkSimpleLam2 $ \x z -> return $ + nlHsApps foldable_foldr_RDR [gg',z,x]) gg + -- foldr f = (\x z -> foldr g z x) + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_foldr" + , ft_fun = panic "function in ft_foldr" + , ft_bad_app = panic "in other argument in ft_foldr" } + + match_foldr :: Monad m + => LHsExpr GhcPs + -> [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) + where + -- g1 v1 (g2 v2 (.. z)) + mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkFoldr = foldr nlHsApp z + + -- See Note [FFoldType and functorLikeTraverse] + ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldMap + = FT { ft_triv = return Nothing + -- foldMap f = \x -> mempty + , ft_var = return (Just f_Expr) + -- foldMap f = f + , ft_tup = \t g -> do + gg <- sequence g + lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg + return (Just lam) + -- foldMap f = \x -> case x of (..,) + , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g + -- foldMap f = foldMap g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_foldMap" + , ft_fun = panic "function in ft_foldMap" + , ft_bad_app = panic "in other argument in ft_foldMap" } + + match_foldMap :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) + where + -- mappend v1 (mappend v2 ..) + mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkFoldMap [] = mempty_Expr + mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs + + -- See Note [FFoldType and functorLikeTraverse] + -- Yields NullM an expression if we're folding over an expression + -- that may or may not be null. Yields IsNull if it's certainly + -- null, and yields NotNull if it's certainly not null. + -- See Note [Deriving null] + ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) + ft_null + = FT { ft_triv = return IsNull + -- null = \_ -> True + , ft_var = return NotNull + -- null = \_ -> False + , ft_tup = \t g -> do + gg <- sequence g + case convert gg of + Nothing -> pure NotNull + Just ggg -> + NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg) + -- null = \x -> case x of (..,) + , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult -> + case nestedResult of + -- If e definitely contains the parameter, + -- then we can test if (G e) contains it by + -- simply checking if (G e) is null + NotNull -> NullM null_Expr + -- This case is unreachable--it will actually be + -- caught by ft_triv + IsNull -> IsNull + -- The general case uses (all null), + -- (all (all null)), etc. + NullM nestedTest -> NullM $ + nlHsApp all_Expr nestedTest + -- null fa = null fa, or null fa = all null fa, or null fa = True + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_null" + , ft_fun = panic "function in ft_null" + , ft_bad_app = panic "in other argument in ft_null" } + + match_null :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs) + where + -- v1 && v2 && .. + mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs + mkNull [] = true_Expr + mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs + +data NullM a = + IsNull -- Definitely null + | NotNull -- Definitely not null + | NullM a -- Unknown + +{- +************************************************************************ +* * + Traversable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html +* * +************************************************************************ + +Again, Traversable is much like Functor and Foldable. + +The cases are: + + $(traverse 'a 'a) = f + $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> + liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) + $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 + +Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types +do not mention the last type parameter. Therefore, the following datatype: + + data Foo a = Foo Int a Int + +would have the following derived Traversable instance: + + instance Traversable Foo where + traverse f (Foo x1 x2 x3) = + fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) + +since the two Int arguments do not produce any effects in a traversal. + +One can envision a case for types that do not mention the last type parameter: + + $(traverse 'a 'b) = pure -- when b does not contain a + +But this case will never materialize, since the aforementioned filtering +removes all such types from consideration. +See Note [Generated code for DeriveFoldable and DeriveTraversable]. +-} + +gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +-- When the argument is phantom, we can use traverse = pure . coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Traversable_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag traverse_bind, emptyBag) + where + traverse_name = L loc traverse_RDR + traverse_bind = mkRdrFunBind traverse_name traverse_eqns + traverse_eqns = + [mkSimpleMatch traverse_match_ctxt + [nlWildPat, z_Pat] + (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] + traverse_match_ctxt = mkPrefixFunRhs traverse_name + +gen_Traversable_binds loc tycon + = (unitBag traverse_bind, emptyBag) + where + data_cons = tyConDataCons tycon + + traverse_name = L loc traverse_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) + traverse_name traverse_eqns + traverse_eqns = map traverse_eqn data_cons + traverse_eqn con + = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_trav con + + -- Yields 'Just' an expression if we're folding over a type that mentions + -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. + -- See Note [FFoldType and functorLikeTraverse] + ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_trav + = FT { ft_triv = return Nothing + -- traverse f = pure x + , ft_var = return (Just f_Expr) + -- traverse f = f x + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + return (Just lam) + -- traverse f = \x -> case x of (a1,a2,..) -> + -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. + , ft_ty_app = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g + -- traverse f = traverse g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant in ft_trav" + , ft_fun = panic "function in ft_trav" + , ft_bad_app = panic "in other argument in ft_trav" } + + -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) + -- (g2 a2) <*> ... + match_for_con :: Monad m + => [LPat GhcPs] + -> DataCon + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) + match_for_con = mkSimpleConMatch2 CaseAlt $ + \con xs -> return (mkApCon con xs) + where + -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. + mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs + mkApCon con [] = nlHsApps pure_RDR [con] + mkApCon con [x] = nlHsApps fmap_RDR [con,x] + mkApCon con (x1:x2:xs) = + foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs + where appAp x y = nlHsApps ap_RDR [x,y] + +----------------------------------------------------------------------- + +f_Expr, z_Expr, mempty_Expr, foldMap_Expr, + traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, + all_Expr, null_Expr :: LHsExpr GhcPs +f_Expr = nlHsVar f_RDR +z_Expr = nlHsVar z_RDR +mempty_Expr = nlHsVar mempty_RDR +foldMap_Expr = nlHsVar foldMap_RDR +traverse_Expr = nlHsVar traverse_RDR +coerce_Expr = nlHsVar (getRdrName coerceId) +pure_Expr = nlHsVar pure_RDR +true_Expr = nlHsVar true_RDR +false_Expr = nlHsVar false_RDR +all_Expr = nlHsVar all_RDR +null_Expr = nlHsVar null_RDR + +f_RDR, z_RDR :: RdrName +f_RDR = mkVarUnqual (fsLit "f") +z_RDR = mkVarUnqual (fsLit "z") + +as_RDRs, bs_RDRs :: [RdrName] +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] + +as_Vars, bs_Vars :: [LHsExpr GhcPs] +as_Vars = map nlHsVar as_RDRs +bs_Vars = map nlHsVar bs_RDRs + +f_Pat, z_Pat :: LPat GhcPs +f_Pat = nlVarPat f_RDR +z_Pat = nlVarPat z_RDR + +{- +Note [DeriveFoldable with ExistentialQuantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Traversable instances can only be derived for data types whose +last type parameter is truly universally polymorphic. For example: + + data T a b where + T1 :: b -> T a b -- YES, b is unconstrained + T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) + T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) + T4 :: Int -> T a Int -- NO, this is just like T3 + T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even + -- though a is existential + T6 :: Int -> T Int b -- YES, b is unconstrained + +For Foldable instances, however, we can completely lift the constraint that +the last type parameter be truly universally polymorphic. This means that T +(as defined above) can have a derived Foldable instance: + + instance Foldable (T a) where + foldr f z (T1 b) = f b z + foldr f z (T2 b) = f b z + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + foldr f z (T5 a b) = f b z + foldr f z (T6 a) = z + + foldMap f (T1 b) = f b + foldMap f (T2 b) = f b + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + foldMap f (T5 a b) = f b + foldMap f (T6 a) = mempty + +In a Foldable instance, it is safe to fold over an occurrence of the last type +parameter that is not truly universally polymorphic. However, there is a bit +of subtlety in determining what is actually an occurrence of a type parameter. +T3 and T4, as defined above, provide one example: + + data T a b where + ... + T3 :: b ~ Int => b -> T a b + T4 :: Int -> T a Int + ... + + instance Foldable (T a) where + ... + foldr f z (T3 b) = f b z + foldr f z (T4 b) = z + ... + foldMap f (T3 b) = f b + foldMap f (T4 b) = mempty + ... + +Notice that the argument of T3 is folded over, whereas the argument of T4 is +not. This is because we only fold over constructor arguments that +syntactically mention the universally quantified type parameter of that +particular data constructor. See foldDataConArgs for how this is implemented. + +As another example, consider the following data type. The argument of each +constructor has the same type as the last type parameter: + + data E a where + E1 :: (a ~ Int) => a -> E a + E2 :: Int -> E Int + E3 :: (a ~ Int) => a -> E Int + E4 :: (a ~ Int) => Int -> E a + +Only E1's argument is an occurrence of a universally quantified type variable +that is syntactically equivalent to the last type parameter, so only E1's +argument will be folded over in a derived Foldable instance. + +See #10447 for the original discussion on this feature. Also see +https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor +for a more in-depth explanation. + +Note [FFoldType and functorLikeTraverse] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deriving Functor, Foldable, and Traversable all require generating expressions +which perform an operation on each argument of a data constructor depending +on the argument's type. In particular, a generated operation can be different +depending on whether the type mentions the last type variable of the datatype +(e.g., if you have data T a = MkT a Int, then a generated foldr expression would +fold over the first argument of MkT, but not the second). + +This pattern is abstracted with the FFoldType datatype, which provides hooks +for the user to specify how a constructor argument should be folded when it +has a type with a particular "shape". The shapes are as follows (assume that +a is the last type variable in a given datatype): + +* ft_triv: The type does not mention the last type variable at all. + Examples: Int, b + +* ft_var: The type is syntactically equal to the last type variable. + Moreover, the type appears in a covariant position (see + the Deriving Functor instances section of the user's guide + for an in-depth explanation of covariance vs. contravariance). + Example: a (covariantly) + +* ft_co_var: The type is syntactically equal to the last type variable. + Moreover, the type appears in a contravariant position. + Example: a (contravariantly) + +* ft_fun: A function type which mentions the last type variable in + the argument position, result position or both. + Examples: a -> Int, Int -> a, Maybe a -> [a] + +* ft_tup: A tuple type which mentions the last type variable in at least + one of its fields. The TyCon argument of ft_tup represents the + particular tuple's type constructor. + Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) + +* ft_ty_app: A type is being applied to the last type parameter, where the + applied type does not mention the last type parameter (if it + did, it would fall under ft_bad_app) and the argument type + mentions the last type parameter (if it did not, it would fall + under ft_triv). The first two Type arguments to + ft_ty_app represent the applied type and argument type, + respectively. + + Currently, only DeriveFunctor makes use of the argument type. + It inspects the argument type so that it can generate more + efficient implementations of fmap + (see Note [Avoid unnecessary eta expansion in derived fmap implementations]) + and (<$) (see Note [Deriving <$]) in certain cases. + + Note that functions, tuples, and foralls are distinct cases + and take precedence over ft_ty_app. (For example, (Int -> a) would + fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). + Examples: Maybe a, Either b a + +* ft_bad_app: A type application uses the last type parameter in a position + other than the last argument. This case is singled out because + Functor, Foldable, and Traversable instances cannot be derived + for datatypes containing arguments with such types. + Examples: Either a Int, Const a b + +* ft_forall: A forall'd type mentions the last type parameter on its right- + hand side (and is not quantified on the left-hand side). This + case is present mostly for plumbing purposes. + Example: forall b. Either b a + +If FFoldType describes a strategy for folding subcomponents of a Type, then +functorLikeTraverse is the function that applies that strategy to the entirety +of a Type, returning the final folded-up result. + +foldDataConArgs applies functorLikeTraverse to every argument type of a +constructor, returning a list of the fold results. This makes foldDataConArgs +a natural way to generate the subexpressions in a generated fmap, foldr, +foldMap, or traverse definition (the subexpressions must then be combined in +a method-specific fashion to form the final generated expression). + +Deriving Generic1 also does validity checking by looking for the last type +variable in certain positions of a constructor's argument types, so it also +uses foldDataConArgs. See Note [degenerate use of FFoldType] in GHC.Tc.Deriv.Generics. + +Note [Generated code for DeriveFoldable and DeriveTraversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on +that of -XDeriveFunctor. However, there an important difference between deriving +the former two typeclasses and the latter one, which is best illustrated by the +following scenario: + + data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) + +The generated code for the Functor instance is straightforward: + + instance Functor WithInt where + fmap f (WithInt a i) = WithInt (f a) i + +But if we use too similar of a strategy for deriving the Foldable and +Traversable instances, we end up with this code: + + instance Foldable WithInt where + foldMap f (WithInt a i) = f a <> mempty + + instance Traversable WithInt where + traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i + +This is unsatisfying for two reasons: + +1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure + expects an argument whose type is of kind *. This effectively prevents + Traversable from being derived for any datatype with an unlifted argument + type (#11174). + +2. The generated code contains superfluous expressions. By the Monoid laws, + we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can + reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). + +We can fix both of these issues by incorporating a slight twist to the usual +algorithm that we use for -XDeriveFunctor. The differences can be summarized +as follows: + +1. In the generated expression, we only fold over arguments whose types + mention the last type parameter. Any other argument types will simply + produce useless 'mempty's or 'pure's, so they can be safely ignored. + +2. In the case of -XDeriveTraversable, instead of applying ConName, + we apply (\b_i ... b_k -> ConName a_1 ... a_n), where + + * ConName has n arguments + * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond + to the arguments whose types mention the last type parameter. As a + consequence, taking the difference of {a_1, ..., a_n} and + {b_i, ..., b_k} yields the all the argument values of ConName whose types + do not mention the last type parameter. Note that [i, ..., k] is a + strictly increasing—but not necessarily consecutive—integer sequence. + + For example, the datatype + + data Foo a = Foo Int a Int a + + would generate the following Traversable instance: + + instance Traversable Foo where + traverse f (Foo a1 a2 a3 a4) = + fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 + +Technically, this approach would also work for -XDeriveFunctor as well, but we +decide not to do so because: + +1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) + instead of (WithInt (f a) i). + +2. There would be certain datatypes for which the above strategy would + generate Functor code that would fail to typecheck. For example: + + data Bar f a = Bar (forall f. Functor f => f a) deriving Functor + + With the conventional algorithm, it would generate something like: + + fmap f (Bar a) = Bar (fmap f a) + + which typechecks. But with the strategy mentioned above, it would generate: + + fmap f (Bar a) = (\b -> Bar b) (fmap f a) + + which does not typecheck, since GHC cannot unify the rank-2 type variables + in the types of b and (fmap f a). + +Note [Phantom types with Functor, Foldable, and Traversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given a type F :: * -> * whose type argument has a phantom role, we can always +produce lawful Functor and Traversable instances using + + fmap _ = coerce + traverse _ = pure . coerce + +Indeed, these are equivalent to any *strictly lawful* instances one could +write, except that this definition of 'traverse' may be lazier. That is, if +instances obey the laws under true equality (rather than up to some equivalence +relation), then they will be essentially equivalent to these. These definitions +are incredibly cheap, so we want to use them even if it means ignoring some +non-strictly-lawful instance in an embedded type. + +Foldable has far fewer laws to work with, which leaves us unwelcome +freedom in implementing it. At a minimum, we would like to ensure that +a derived foldMap is always at least as good as foldMapDefault with a +derived traverse. To accomplish that, we must define + + foldMap _ _ = mempty + +in these cases. + +This may have different strictness properties from a standard derivation. +Consider + + data NotAList a = Nil | Cons (NotAList a) deriving Foldable + +The usual deriving mechanism would produce + + foldMap _ Nil = mempty + foldMap f (Cons x) = foldMap f x + +which is strict in the entire spine of the NotAList. + +Final point: why do we even care about such types? Users will rarely if ever +map, fold, or traverse over such things themselves, but other derived +instances may: + + data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable + +Note [EmptyDataDecls with Functor, Foldable, and Traversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are some slightly tricky decisions to make about how to handle +Functor, Foldable, and Traversable instances for types with no constructors. +For fmap, the two basic options are + + fmap _ _ = error "Sorry, no constructors" + +or + + fmap _ z = case z of + +In most cases, the latter is more helpful: if the thunk passed to fmap +throws an exception, we're generally going to be much more interested in +that exception than in the fact that there aren't any constructors. + +In order to match the semantics for phantoms (see note above), we need to +be a bit careful about 'traverse'. The obvious definition would be + + traverse _ z = case z of + +but this is stricter than the one for phantoms. We instead use + + traverse _ z = pure $ case z of + +For foldMap, the obvious choices are + + foldMap _ _ = mempty + +or + + foldMap _ z = case z of + +We choose the first one to be consistent with what foldMapDefault does for +a derived Traversable instance. +-} diff --git a/GHC/Tc/Deriv/Generate.hs b/GHC/Tc/Deriv/Generate.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Generate.hs @@ -0,0 +1,2736 @@ +{- + % +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Generating derived instance declarations +-- +-- This module is nominally ``subordinate'' to "GHC.Tc.Deriv", which is the +-- ``official'' interface to deriving-related things. +-- +-- This is where we do all the grimy bindings' generation. +module GHC.Tc.Deriv.Generate ( + BagDerivStuff, DerivStuff(..), + + gen_Eq_binds, + gen_Ord_binds, + gen_Enum_binds, + gen_Bounded_binds, + gen_Ix_binds, + gen_Show_binds, + gen_Read_binds, + gen_Data_binds, + gen_Lift_binds, + gen_Newtype_binds, + mkCoerceClassMethEqn, + genAuxBinds, + ordOpTbl, boxConTbl, litConTbl, + mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Monad +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Types.Name + +import GHC.Driver.Session +import GHC.Builtin.Utils +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Builtin.Names +import GHC.Builtin.Names.TH +import GHC.Types.Id.Make ( coerceId ) +import GHC.Builtin.PrimOps +import GHC.Types.SrcLoc +import GHC.Core.TyCon +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Tc.Validity ( checkValidCoAxBranch ) +import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.Class +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Utils.Outputable +import GHC.Utils.Lexeme +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.Bag + +import Data.List ( find, partition, intersperse ) + +type BagDerivStuff = Bag DerivStuff + +-- | A declarative description of an auxiliary binding that should be +-- generated. See @Note [Auxiliary binders]@ for a more detailed description +-- of how these are used. +data AuxBindSpec + -- DerivCon2Tag, DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord, + -- Enum, and Ix instances. + -- All these generate ZERO-BASED tag operations + -- I.e first constructor has tag 0 + + -- | @$con2tag@: Computes the tag for a given constructor + = DerivCon2Tag + TyCon -- The type constructor of the data type to which the + -- constructors belong + RdrName -- The to-be-generated $con2tag binding's RdrName + + -- | @$tag2con@: Given a tag, computes the corresponding data constructor + | DerivTag2Con + TyCon -- The type constructor of the data type to which the + -- constructors belong + RdrName -- The to-be-generated $tag2con binding's RdrName + + -- | @$maxtag@: The maximum possible tag value among a data type's + -- constructors + | DerivMaxTag + TyCon -- The type constructor of the data type to which the + -- constructors belong + RdrName -- The to-be-generated $maxtag binding's RdrName + + -- DerivDataDataType and DerivDataConstr are only used in derived Data + -- instances + + -- | @$t@: The @DataType@ representation for a @Data@ instance + | DerivDataDataType + TyCon -- The type constructor of the data type to be represented + RdrName -- The to-be-generated $t binding's RdrName + [RdrName] -- The RdrNames of the to-be-generated $c bindings for each + -- data constructor. These are only used on the RHS of the + -- to-be-generated $t binding. + + -- | @$c@: The @Constr@ representation for a @Data@ instance + | DerivDataConstr + DataCon -- The data constructor to be represented + RdrName -- The to-be-generated $c binding's RdrName + RdrName -- The RdrName of the to-be-generated $t binding for the parent + -- data type. This is only used on the RHS of the + -- to-be-generated $c binding. + +-- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec' +-- describes. +auxBindSpecRdrName :: AuxBindSpec -> RdrName +auxBindSpecRdrName (DerivCon2Tag _ con2tag_RDR) = con2tag_RDR +auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR +auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR +auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR +auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR + +data DerivStuff -- Please add this auxiliary stuff + = DerivAuxBind AuxBindSpec + -- ^ A new, top-level auxiliary binding. Used for deriving 'Eq', 'Ord', + -- 'Enum', 'Ix', and 'Data'. See Note [Auxiliary binders]. + + -- Generics and DeriveAnyClass + | DerivFamInst FamInst -- New type family instances + -- ^ A new type family instance. Used for: + -- + -- * @DeriveGeneric@, which generates instances of @Rep(1)@ + -- + -- * @DeriveAnyClass@, which can fill in associated type family defaults + -- + -- * @GeneralizedNewtypeDeriving@, which generates instances of associated + -- type families for newtypes + + +{- +************************************************************************ +* * + Eq instances +* * +************************************************************************ + +Here are the heuristics for the code we generate for @Eq@. Let's +assume we have a data type with some (possibly zero) nullary data +constructors and some ordinary, non-nullary ones (the rest, also +possibly zero of them). Here's an example, with both \tr{N}ullary and +\tr{O}rdinary data cons. + + data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... + +* For the ordinary constructors (if any), we emit clauses to do The + Usual Thing, e.g.,: + + (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 + (==) (O2 a1) (O2 a2) = a1 == a2 + (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 + + Note: if we're comparing unlifted things, e.g., if 'a1' and + 'a2' are Float#s, then we have to generate + case (a1 `eqFloat#` a2) of r -> r + for that particular test. + +* If there are a lot of (more than ten) nullary constructors, we emit a + catch-all clause of the form: + + (==) a b = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + case (a# ==# b#) of { + r -> r }}} + + If con2tag gets inlined this leads to join point stuff, so + it's better to use regular pattern matching if there aren't too + many nullary constructors. "Ten" is arbitrary, of course + +* If there aren't any nullary constructors, we emit a simpler + catch-all: + + (==) a b = False + +* For the @(/=)@ method, we normally just use the default method. + If the type is an enumeration type, we could/may/should? generate + special code that calls @con2tag_Foo@, much like for @(==)@ shown + above. + +We thought about doing this: If we're also deriving 'Ord' for this +tycon, we generate: + instance ... Eq (Foo ...) where + (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} + (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } +However, that requires that (Ord ) was put in the context +for the instance decl, which it probably wasn't, so the decls +produced don't get through the typechecker. +-} + +gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Eq_binds loc tycon = do + -- See Note [Auxiliary binders] + con2tag_RDR <- new_con2tag_rdr_name loc tycon + + return (method_binds con2tag_RDR, aux_binds con2tag_RDR) + where + all_cons = tyConDataCons tycon + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons + + -- If there are ten or more (arbitrary number) nullary constructors, + -- use the con2tag stuff. For small types it's better to use + -- ordinary pattern matching. + (tag_match_cons, pat_match_cons) + | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) + | otherwise = ([], all_cons) + + no_tag_match_cons = null tag_match_cons + + fall_through_eqn con2tag_RDR + | no_tag_match_cons -- All constructors have arguments + = case pat_match_cons of + [] -> [] -- No constructors; no fall-though case + [_] -> [] -- One constructor; no fall-though case + _ -> -- Two or more constructors; add fall-through of + -- (==) _ _ = False + [([nlWildPat, nlWildPat], false_Expr)] + + | otherwise -- One or more tag_match cons; add fall-through of + -- extract tags compare for equality + = [([a_Pat, b_Pat], + untag_Expr con2tag_RDR [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] + + aux_binds con2tag_RDR + | no_tag_match_cons = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR + + method_binds con2tag_RDR = unitBag (eq_bind con2tag_RDR) + eq_bind con2tag_RDR + = mkFunBindEC 2 loc eq_RDR (const true_Expr) + (map pats_etc pat_match_cons + ++ fall_through_eqn con2tag_RDR) + + ------------------------------------------------------------------ + pats_etc data_con + = let + con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed + con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed + + data_con_RDR = getRdrName data_con + con_arity = length tys_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + tys_needed = dataConOrigArgTys data_con + in + ([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed) + where + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + -- Using 'foldr1' here ensures that the derived code is correctly + -- associated. See #10859. + where + nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) + +{- +************************************************************************ +* * + Ord instances +* * +************************************************************************ + +Note [Generating Ord instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose constructors are K1..Kn, and some are nullary. +The general form we generate is: + +* Do case on first argument + case a of + K1 ... -> rhs_1 + K2 ... -> rhs_2 + ... + Kn ... -> rhs_n + _ -> nullary_rhs + +* To make rhs_i + If i = 1, 2, n-1, n, generate a single case. + rhs_2 case b of + K1 {} -> LT + K2 ... -> ...eq_rhs(K2)... + _ -> GT + + Otherwise do a tag compare against the bigger range + (because this is the one most likely to succeed) + rhs_3 case tag b of tb -> + if 3 <# tg then GT + else case b of + K3 ... -> ...eq_rhs(K3).... + _ -> LT + +* To make eq_rhs(K), which knows that + a = K a1 .. av + b = K b1 .. bv + we just want to compare (a1,b1) then (a2,b2) etc. + Take care on the last field to tail-call into comparing av,bv + +* To make nullary_rhs generate this + case con2tag a of a# -> + case con2tag b of -> + a# `compare` b# + +Several special cases: + +* Two or fewer nullary constructors: don't generate nullary_rhs + +* Be careful about unlifted comparisons. When comparing unboxed + values we can't call the overloaded functions. + See function unliftedOrdOp + +Note [Game plan for deriving Ord] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a bad idea to define only 'compare', and build the other binary +comparisons on top of it; see #2130, #4019. Reason: we don't +want to laboriously make a three-way comparison, only to extract a +binary result, something like this: + (>) (I# x) (I# y) = case <# x y of + True -> False + False -> case ==# x y of + True -> False + False -> True + +This being said, we can get away with generating full code only for +'compare' and '<' thus saving us generation of other three operators. +Other operators can be cheaply expressed through '<': +a <= b = not $ b < a +a > b = b < a +a >= b = not $ a < b + +So for sufficiently small types (few constructors, or all nullary) +we generate all methods; for large ones we just use 'compare'. + +-} + +data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT + +------------ +ordMethRdr :: OrdOp -> RdrName +ordMethRdr op + = case op of + OrdCompare -> compare_RDR + OrdLT -> lt_RDR + OrdLE -> le_RDR + OrdGE -> ge_RDR + OrdGT -> gt_RDR + +------------ +ltResult :: OrdOp -> LHsExpr GhcPs +-- Knowing a LHsExpr GhcPs +-- Knowing a=b, what is the result for a `op` b? +eqResult OrdCompare = eqTag_Expr +eqResult OrdLT = false_Expr +eqResult OrdLE = true_Expr +eqResult OrdGE = true_Expr +eqResult OrdGT = false_Expr + +------------ +gtResult :: OrdOp -> LHsExpr GhcPs +-- Knowing a>b, what is the result for a `op` b? +gtResult OrdCompare = gtTag_Expr +gtResult OrdLT = false_Expr +gtResult OrdLE = false_Expr +gtResult OrdGE = true_Expr +gtResult OrdGT = true_Expr + +------------ +gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Ord_binds loc tycon = do + -- See Note [Auxiliary binders] + con2tag_RDR <- new_con2tag_rdr_name loc tycon + + return $ if null tycon_data_cons -- No data-cons => invoke bale-out case + then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] + , emptyBag) + else ( unitBag (mkOrdOp con2tag_RDR OrdCompare) + `unionBags` other_ops con2tag_RDR + , aux_binds con2tag_RDR) + where + aux_binds con2tag_RDR + | single_con_type = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR + + -- Note [Game plan for deriving Ord] + other_ops con2tag_RDR + | (last_tag - first_tag) <= 2 -- 1-3 constructors + || null non_nullary_cons -- Or it's an enumeration + = listToBag [mkOrdOp con2tag_RDR OrdLT, lE, gT, gE] + | otherwise + = emptyBag + + negate_expr = nlHsApp (nlHsVar not_RDR) + lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ + negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) + gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ + nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr + gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ + negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) + + get_tag con = dataConTag con - fIRST_TAG + -- We want *zero-based* tags, because that's what + -- con2Tag returns (generated by untag_Expr)! + + tycon_data_cons = tyConDataCons tycon + single_con_type = isSingleton tycon_data_cons + (first_con : _) = tycon_data_cons + (last_con : _) = reverse tycon_data_cons + first_tag = get_tag first_con + last_tag = get_tag last_con + + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons + + + mkOrdOp :: RdrName -> OrdOp -> LHsBind GhcPs + -- Returns a binding op a b = ... compares a and b according to op .... + mkOrdOp con2tag_RDR op + = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] + (mkOrdOpRhs con2tag_RDR op) + + mkOrdOpRhs :: RdrName -> OrdOp -> LHsExpr GhcPs + mkOrdOpRhs con2tag_RDR op -- RHS for comparing 'a' and 'b' according to op + | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases + = nlHsCase (nlHsVar a_RDR) $ + map (mkOrdOpAlt con2tag_RDR op) tycon_data_cons + -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... + -- C2 x -> case b of C2 x -> ....comopare x.... } + + | null non_nullary_cons -- All nullary, so go straight to comparing tags + = mkTagCmp con2tag_RDR op + + | otherwise -- Mixed nullary and non-nullary + = nlHsCase (nlHsVar a_RDR) $ + (map (mkOrdOpAlt con2tag_RDR op) non_nullary_cons + ++ [mkHsCaseAlt nlWildPat (mkTagCmp con2tag_RDR op)]) + + + mkOrdOpAlt :: RdrName -> OrdOp -> DataCon + -> LMatch GhcPs (LHsExpr GhcPs) + -- Make the alternative (Ki a1 a2 .. av -> + mkOrdOpAlt con2tag_RDR op data_con + = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) + (mkInnerRhs con2tag_RDR op data_con) + where + as_needed = take (dataConSourceArity data_con) as_RDRs + data_con_RDR = getRdrName data_con + + mkInnerRhs con2tag_RDR op data_con + | single_con_type + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] + + | tag == first_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + | tag == last_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + + | tag == first_tag + 1 + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) + (gtResult op) + , mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + | tag == last_tag - 1 + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) + (ltResult op) + , mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + + | tag > last_tag `div` 2 -- lower range is larger + = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) + (gtResult op) $ -- Definitely GT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (ltResult op) ] + + | otherwise -- upper range is larger + = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) + (ltResult op) $ -- Definitely LT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkHsCaseAlt nlWildPat (gtResult op) ] + where + tag = get_tag data_con + tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) + + mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) + -- First argument 'a' known to be built with K + -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) + mkInnerEqAlt op data_con + = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ + mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con) + where + data_con_RDR = getRdrName data_con + bs_needed = take (dataConSourceArity data_con) bs_RDRs + + mkTagCmp :: RdrName -> OrdOp -> LHsExpr GhcPs + -- Both constructors known to be nullary + -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# + mkTagCmp con2tag_RDR op = + untag_Expr con2tag_RDR [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ + unliftedOrdOp intPrimTy op ah_RDR bh_RDR + +mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs +-- Generates nested comparisons for (a1,a2...) against (b1,b2,...) +-- where the ai,bi have the given types +mkCompareFields op tys + = go tys as_RDRs bs_RDRs + where + go [] _ _ = eqResult op + go [ty] (a:_) (b:_) + | isUnliftedType ty = unliftedOrdOp ty op a b + | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) + go (ty:tys) (a:as) (b:bs) = mk_compare ty a b + (ltResult op) + (go tys as bs) + (gtResult op) + go _ _ _ = panic "mkCompareFields" + + -- (mk_compare ty a b) generates + -- (case (compare a b) of { LT -> ; EQ -> ; GT -> }) + -- but with suitable special cases for + mk_compare ty a b lt eq gt + | isUnliftedType ty + = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + | otherwise + = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) + [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, + mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, + mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] + where + a_expr = nlHsVar a + b_expr = nlHsVar b + (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty + +unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs +unliftedOrdOp ty op a b + = case op of + OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr + ltTag_Expr eqTag_Expr gtTag_Expr + OrdLT -> wrap lt_op + OrdLE -> wrap le_op + OrdGE -> wrap ge_op + OrdGT -> wrap gt_op + where + (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty + wrap prim_op = genPrimOpApp a_expr prim_op b_expr + a_expr = nlHsVar a + b_expr = nlHsVar b + +unliftedCompare :: RdrName -> RdrName + -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to compare + -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -- Three results + -> LHsExpr GhcPs +-- Return (if a < b then lt else if a == b then eq else gt) +unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ + -- Test (<) first, not (==), because the latter + -- is true less often, so putting it first would + -- mean more tests (dynamically) + nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt + where + ascribeBool e = nlExprWithTySig e $ nlHsTyVar boolTyCon_RDR + +nlConWildPat :: DataCon -> LPat GhcPs +-- The pattern (K {}) +nlConWildPat con = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc $ getRdrName con + , pat_args = RecCon $ HsRecFields + { rec_flds = [] + , rec_dotdot = Nothing } + } + +{- +************************************************************************ +* * + Enum instances +* * +************************************************************************ + +@Enum@ can only be derived for enumeration types. For a type +\begin{verbatim} +data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} + +we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a +@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). + +\begin{verbatim} +instance ... Enum (Foo ...) where + succ x = toEnum (1 + fromEnum x) + pred x = toEnum (fromEnum x - 1) + + toEnum i = tag2con_Foo i + + enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] + + -- or, really... + enumFrom a + = case con2tag_Foo a of + a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) + + enumFromThen a b + = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] + + -- or, really... + enumFromThen a b + = case con2tag_Foo a of { a# -> + case con2tag_Foo b of { b# -> + map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) + }} +\end{verbatim} + +For @enumFromTo@ and @enumFromThenTo@, we use the default methods. +-} + +gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Enum_binds loc tycon = do + -- See Note [Auxiliary binders] + con2tag_RDR <- new_con2tag_rdr_name loc tycon + tag2con_RDR <- new_tag2con_rdr_name loc tycon + maxtag_RDR <- new_maxtag_rdr_name loc tycon + + return ( method_binds con2tag_RDR tag2con_RDR maxtag_RDR + , aux_binds con2tag_RDR tag2con_RDR maxtag_RDR ) + where + method_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag + [ succ_enum con2tag_RDR tag2con_RDR maxtag_RDR + , pred_enum con2tag_RDR tag2con_RDR + , to_enum tag2con_RDR maxtag_RDR + , enum_from con2tag_RDR tag2con_RDR maxtag_RDR -- [0 ..] + , enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR -- [0, 1 ..] + , from_enum con2tag_RDR + ] + aux_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind + [ DerivCon2Tag tycon con2tag_RDR + , DerivTag2Con tycon tag2con_RDR + , DerivMaxTag tycon maxtag_RDR + ] + + occ_nm = getOccString tycon + + succ_enum con2tag_RDR tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ + untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR, + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") + (nlHsApp (nlHsVar tag2con_RDR) + (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsIntLit 1])) + + pred_enum con2tag_RDR tag2con_RDR + = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ + untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") + (nlHsApp (nlHsVar tag2con_RDR) + (nlHsApps plus_RDR + [ nlHsVarApps intDataCon_RDR [ah_RDR] + , nlHsLit (HsInt noExtField + (mkIntegralLit (-1 :: Int)))])) + + to_enum tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ + nlHsIf (nlHsApps and_RDR + [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], + nlHsApps le_RDR [ nlHsVar a_RDR + , nlHsVar maxtag_RDR]]) + (nlHsVarApps tag2con_RDR [a_RDR]) + (illegal_toEnum_tag occ_nm maxtag_RDR) + + enum_from con2tag_RDR tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ + untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + nlHsApps map_RDR + [nlHsVar tag2con_RDR, + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVar maxtag_RDR))] + + enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR + = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ + untag_Expr con2tag_RDR [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ + nlHsPar (enum_from_then_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR]) + (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsVarApps intDataCon_RDR [bh_RDR]]) + (nlHsIntLit 0) + (nlHsVar maxtag_RDR) + )) + + from_enum con2tag_RDR + = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ + untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + (nlHsVarApps intDataCon_RDR [ah_RDR]) + +{- +************************************************************************ +* * + Bounded instances +* * +************************************************************************ +-} + +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +gen_Bounded_binds loc tycon + | isEnumerationTyCon tycon + = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) + | otherwise + = ASSERT(isSingleton data_cons) + (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) + where + data_cons = tyConDataCons tycon + + ----- enum-flavored: --------------------------- + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + + data_con_1 = head data_cons + data_con_N = last data_cons + data_con_1_RDR = getRdrName data_con_1 + data_con_N_RDR = getRdrName data_con_N + + ----- single-constructor-flavored: ------------- + arity = dataConSourceArity data_con_1 + + min_bound_1con = mkHsVarBind loc minBound_RDR $ + nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR) + max_bound_1con = mkHsVarBind loc maxBound_RDR $ + nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR) + +{- +************************************************************************ +* * + Ix instances +* * +************************************************************************ + +Deriving @Ix@ is only possible for enumeration types and +single-constructor types. We deal with them in turn. + +For an enumeration type, e.g., +\begin{verbatim} + data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} +things go not too differently from @Enum@: +\begin{verbatim} +instance ... Ix (Foo ...) where + range (a, b) + = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] + + -- or, really... + range (a, b) + = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + map tag2con_Foo (enumFromTo (I# a#) (I# b#)) + }} + + -- Generate code for unsafeIndex, because using index leads + -- to lots of redundant range tests + unsafeIndex c@(a, b) d + = case (con2tag_Foo d -# con2tag_Foo a) of + r# -> I# r# + + inRange (a, b) c + = let + p_tag = con2tag_Foo c + in + p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b + + -- or, really... + inRange (a, b) c + = case (con2tag_Foo a) of { a_tag -> + case (con2tag_Foo b) of { b_tag -> + case (con2tag_Foo c) of { c_tag -> + if (c_tag >=# a_tag) then + c_tag <=# b_tag + else + False + }}} +\end{verbatim} +(modulo suitable case-ification to handle the unlifted tags) + +For a single-constructor type (NB: this includes all tuples), e.g., +\begin{verbatim} + data Foo ... = MkFoo a b Int Double c c +\end{verbatim} +we follow the scheme given in Figure~19 of the Haskell~1.2 report +(p.~147). +-} + +gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) + +gen_Ix_binds loc tycon = do + -- See Note [Auxiliary binders] + con2tag_RDR <- new_con2tag_rdr_name loc tycon + tag2con_RDR <- new_tag2con_rdr_name loc tycon + + return $ if isEnumerationTyCon tycon + then (enum_ixes con2tag_RDR tag2con_RDR, listToBag $ map DerivAuxBind + [ DerivCon2Tag tycon con2tag_RDR + , DerivTag2Con tycon tag2con_RDR + ]) + else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon con2tag_RDR))) + where + -------------------------------------------------------------- + enum_ixes con2tag_RDR tag2con_RDR = listToBag + [ enum_range con2tag_RDR tag2con_RDR + , enum_index con2tag_RDR + , enum_inRange con2tag_RDR + ] + + enum_range con2tag_RDR tag2con_RDR + = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ + untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $ + untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $ + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR])) + + enum_index con2tag_RDR + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR + [noLoc (AsPat noExtField (noLoc c_RDR) + (nlTuplePat [a_Pat, nlWildPat] Boxed)), + d_Pat] ( + untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] ( + untag_Expr con2tag_RDR [(d_RDR, dh_RDR)] ( + let + rhs = nlHsVarApps intDataCon_RDR [c_RDR] + in + nlHsCase + (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) + [mkHsCaseAlt (nlVarPat c_RDR) rhs] + )) + ) + + -- This produces something like `(ch >= ah) && (ch <= bh)` + enum_inRange con2tag_RDR + = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ + untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] ( + untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] ( + untag_Expr con2tag_RDR [(c_RDR, ch_RDR)] ( + -- This used to use `if`, which interacts badly with RebindableSyntax. + -- See #11396. + nlHsApps and_RDR + [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) + , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) + ] + ))) + + -------------------------------------------------------------- + single_con_ixes + = listToBag [single_con_range, single_con_index, single_con_inRange] + + data_con + = case tyConSingleDataCon_maybe tycon of -- just checking... + Nothing -> panic "get_Ix_binds" + Just dc -> dc + + con_arity = dataConSourceArity data_con + data_con_RDR = getRdrName data_con + + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + cs_needed = take con_arity cs_RDRs + + con_pat xs = nlConVarPat data_con_RDR xs + con_expr = nlHsVarApps data_con_RDR cs_needed + + -------------------------------------------------------------- + single_con_range + = mkSimpleGeneratedFunBind loc range_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ + noLoc (mkHsComp ListComp stmts con_expr) + where + stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed + + mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c) + (nlHsApp (nlHsVar range_RDR) + (mkLHsVarTuple [a,b])) + + ---------------- + single_con_index + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed] + -- We need to reverse the order we consider the components in + -- so that + -- range (l,u) !! index (l,u) i == i -- when i is in range + -- (from http://haskell.org/onlinereport/ix.html) holds. + (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) + where + -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) + mk_index [] = nlHsIntLit 0 + mk_index [(l,u,i)] = mk_one l u i + mk_index ((l,u,i) : rest) + = genOpApp ( + mk_one l u i + ) plus_RDR ( + genOpApp ( + (nlHsApp (nlHsVar unsafeRangeSize_RDR) + (mkLHsVarTuple [l,u])) + ) times_RDR (mk_index rest) + ) + mk_one l u i + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] + + ------------------ + single_con_inRange + = mkSimpleGeneratedFunBind loc inRange_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed] $ + if con_arity == 0 + -- If the product type has no fields, inRange is trivially true + -- (see #12853). + then true_Expr + else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range + as_needed bs_needed cs_needed) + where + in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] + +{- +************************************************************************ +* * + Read instances +* * +************************************************************************ + +Example + + infix 4 %% + data T = Int %% Int + | T1 { f1 :: Int } + | T2 T + +instance Read T where + readPrec = + parens + ( prec 4 ( + do x <- ReadP.step Read.readPrec + expectP (Symbol "%%") + y <- ReadP.step Read.readPrec + return (x %% y)) + +++ + prec (appPrec+1) ( + -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok + -- Record construction binds even more tightly than application + do expectP (Ident "T1") + expectP (Punc '{') + x <- Read.readField "f1" (ReadP.reset readPrec) + expectP (Punc '}') + return (T1 { f1 = x })) + +++ + prec appPrec ( + do expectP (Ident "T2") + x <- ReadP.step Read.readPrec + return (T2 x)) + ) + + readListPrec = readListPrecDefault + readList = readListDefault + + +Note [Use expectP] +~~~~~~~~~~~~~~~~~~ +Note that we use + expectP (Ident "T1") +rather than + Ident "T1" <- lexP +The latter desugares to inline code for matching the Ident and the +string, and this can be very voluminous. The former is much more +compact. Cf #7258, although that also concerned non-linearity in +the occurrence analyser, a separate issue. + +Note [Read for empty data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we get for this? (#7931) + data Emp deriving( Read ) -- No data constructors + +Here we want + read "[]" :: [Emp] to succeed, returning [] +So we do NOT want + instance Read Emp where + readPrec = error "urk" +Rather we want + instance Read Emp where + readPred = pfail -- Same as choose [] + +Because 'pfail' allows the parser to backtrack, but 'error' doesn't. +These instances are also useful for Read (Either Int Emp), where +we want to be able to parse (Left 3) just fine. +-} + +gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon + -> (LHsBinds GhcPs, BagDerivStuff) + +gen_Read_binds get_fixity loc tycon + = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) + where + ----------------------------------------------------------------------- + default_readlist + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + + default_readlistprec + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + ----------------------------------------------------------------------- + + data_cons = tyConDataCons tycon + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons + + read_prec = mkHsVarBind loc readPrec_RDR rhs + where + rhs | null data_cons -- See Note [Read for empty data types] + = nlHsVar pfail_RDR + | otherwise + = nlHsApp (nlHsVar parens_RDR) + (foldr1 mk_alt (read_nullary_cons ++ + read_non_nullary_cons)) + + read_non_nullary_cons = map read_non_nullary_con non_nullary_cons + + read_nullary_cons + = case nullary_cons of + [] -> [] + [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] + _ -> [nlHsApp (nlHsVar choose_RDR) + (nlList (map mk_pair nullary_cons))] + -- NB For operators the parens around (:=:) are matched by the + -- enclosing "parens" call, so here we must match the naked + -- data_con_str con + + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str + where + con_str = data_con_str con + -- For nullary constructors we must match Ident s for normal constrs + -- and Symbol s for operators + + mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] + + read_non_nullary_con data_con + | is_infix = mk_parser infix_prec infix_stmts body + | is_record = mk_parser record_prec record_stmts body +-- Using these two lines instead allows the derived +-- read for infix and record bindings to read the prefix form +-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) +-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) + | otherwise = prefix_parser + where + body = result_expr data_con as_needed + con_str = data_con_str data_con + + prefix_parser = mk_parser prefix_prec prefix_stmts body + + read_prefix_con + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str + + read_infix_con + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] + + prefix_stmts -- T a b c + = read_prefix_con ++ read_args + + infix_stmts -- a %% b, or a `T` b + = [read_a1] + ++ read_infix_con + ++ [read_a2] + + record_stmts -- T { f1 = a, f2 = b } + = read_prefix_con + ++ [read_punc "{"] + ++ concat (intersperse [read_punc ","] field_stmts) + ++ [read_punc "}"] + + field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed + + con_arity = dataConSourceArity data_con + labels = map flLabel $ dataConFieldLabels data_con + dc_nm = getName data_con + is_infix = dataConIsInfix data_con + is_record = labels `lengthExceeds` 0 + as_needed = take con_arity as_RDRs + read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con) + (read_a1:read_a2:_) = read_args + + prefix_prec = appPrecedence + infix_prec = getPrecedence get_fixity dc_nm + record_prec = appPrecedence + 1 -- Record construction binds even more tightly + -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) + + ------------------------------------------------------------------------ + -- Helpers + ------------------------------------------------------------------------ + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) + , nlHsDo (DoExpr Nothing) (ss ++ [noLoc $ mkLastStmt b])] + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p + -- See Note [Use expectP] + ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") + symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") + read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") + + data_con_str con = occNameString (getOccName con) + + read_arg a ty = ASSERT( not (isUnliftedType ty) ) + noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + + -- When reading field labels we might encounter + -- a = 3 + -- _a = 3 + -- or (#) = 4 + -- Note the parens! + read_field lbl a = + [noLoc + (mkPsBindStmt + (nlVarPat a) + (nlHsApp + read_field + (nlHsVarApps reset_RDR [readPrec_RDR]) + ) + ) + ] + where + lbl_str = unpackFS lbl + mk_read_field read_field_rdr lbl + = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] + read_field + | isSym lbl_str + = mk_read_field readSymField_RDR lbl_str + | Just (ss, '#') <- snocView lbl_str -- #14918 + = mk_read_field readFieldHash_RDR ss + | otherwise + = mk_read_field readField_RDR lbl_str + +{- +************************************************************************ +* * + Show instances +* * +************************************************************************ + +Example + + infixr 5 :^: + + data Tree a = Leaf a | Tree a :^: Tree a + + instance (Show a) => Show (Tree a) where + + showsPrec d (Leaf m) = showParen (d > app_prec) showStr + where + showStr = showString "Leaf " . showsPrec (app_prec+1) m + + showsPrec d (u :^: v) = showParen (d > up_prec) showStr + where + showStr = showsPrec (up_prec+1) u . + showString " :^: " . + showsPrec (up_prec+1) v + -- Note: right-associativity of :^: ignored + + up_prec = 5 -- Precedence of :^: + app_prec = 10 -- Application has precedence one more than + -- the most tightly-binding operator +-} + +gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon + -> (LHsBinds GhcPs, BagDerivStuff) + +gen_Show_binds get_fixity loc tycon + = (unitBag shows_prec, emptyBag) + where + data_cons = tyConDataCons tycon + shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) + comma_space = nlHsVar showCommaSpace_RDR + + pats_etc data_con + | nullary_con = -- skip the showParen junk... + ASSERT(null bs_needed) + ([nlWildPat, con_pat], mk_showString_app op_con_str) + | otherwise = + ([a_Pat, con_pat], + showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit + (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) + (nlHsPar (nested_compose_Expr show_thingies))) + where + data_con_RDR = getRdrName data_con + con_arity = dataConSourceArity data_con + bs_needed = take con_arity bs_RDRs + arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed + con_pat = nlConVarPat data_con_RDR bs_needed + nullary_con = con_arity == 0 + labels = map flLabel $ dataConFieldLabels data_con + lab_fields = length labels + record_syntax = lab_fields > 0 + + dc_nm = getName data_con + dc_occ_nm = getOccName data_con + con_str = occNameString dc_occ_nm + op_con_str = wrapOpParens con_str + backquote_str = wrapOpBackquotes con_str + + show_thingies + | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] + | record_syntax = mk_showString_app (op_con_str ++ " {") : + show_record_args ++ [mk_showString_app "}"] + | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args + + show_label l = mk_showString_app (nm ++ " = ") + -- Note the spaces around the "=" sign. If we + -- don't have them then we get Foo { x=-1 } and + -- the "=-" parses as a single lexeme. Only the + -- space after the '=' is necessary, but it + -- seems tidier to have them both sides. + where + nm = wrapOpParens (unpackFS l) + + show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys) + (show_arg1:show_arg2:_) = show_args + show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args + + -- Assumption for record syntax: no of fields == no of + -- labelled fields (and in same order) + show_record_args = concat $ + intersperse [comma_space] $ + [ [show_label lbl, arg] + | (lbl,arg) <- zipEqual "gen_Show_binds" + labels show_args ] + + show_arg :: RdrName -> Type -> LHsExpr GhcPs + show_arg b arg_ty + | isUnliftedType arg_ty + -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer + = with_conv $ + nlHsApps compose_RDR + [mk_shows_app boxed_arg, mk_showString_app postfixMod] + | otherwise + = mk_showsPrec_app arg_prec arg + where + arg = nlHsVar b + boxed_arg = box "Show" arg arg_ty + postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty + with_conv expr + | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty = + nested_compose_Expr + [ mk_showString_app ("(" ++ conv ++ " ") + , expr + , mk_showString_app ")" + ] + | otherwise = expr + + -- Fixity stuff + is_infix = dataConIsInfix data_con + con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm + arg_prec | record_syntax = 0 -- Record fields don't need parens + | otherwise = con_prec_plus_one + +wrapOpParens :: String -> String +wrapOpParens s | isSym s = '(' : s ++ ")" + | otherwise = s + +wrapOpBackquotes :: String -> String +wrapOpBackquotes s | isSym s = s + | otherwise = '`' : s ++ "`" + +isSym :: String -> Bool +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c + +-- | showString :: String -> ShowS +mk_showString_app :: String -> LHsExpr GhcPs +mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) + +-- | showsPrec :: Show a => Int -> a -> ShowS +mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs +mk_showsPrec_app p x + = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] + +-- | shows :: Show a => a -> ShowS +mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs +mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x + +getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer +getPrec is_infix get_fixity nm + | not is_infix = appPrecedence + | otherwise = getPrecedence get_fixity nm + +appPrecedence :: Integer +appPrecedence = fromIntegral maxPrecedence + 1 + -- One more than the precedence of the most + -- tightly-binding operator + +getPrecedence :: (Name -> Fixity) -> Name -> Integer +getPrecedence get_fixity nm + = case get_fixity nm of + Fixity _ x _assoc -> fromIntegral x + -- NB: the Report says that associativity is not taken + -- into account for either Read or Show; hence we + -- ignore associativity here + +{- +************************************************************************ +* * + Data instances +* * +************************************************************************ + +From the data type + + data T a b = T1 a b | T2 + +we generate + + $cT1 = mkDataCon $dT "T1" Prefix + $cT2 = mkDataCon $dT "T2" Prefix + $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] + -- the [] is for field labels. + + instance (Data a, Data b) => Data (T a b) where + gfoldl k z (T1 a b) = z T `k` a `k` b + gfoldl k z T2 = z T2 + -- ToDo: add gmapT,Q,M, gfoldr + + gunfold k z c = case conIndex c of + I# 1# -> k (k (z T1)) + I# 2# -> z T2 + + toConstr (T1 _ _) = $cT1 + toConstr T2 = $cT2 + + dataTypeOf _ = $dT + + dataCast1 = gcast1 -- If T :: * -> * + dataCast2 = gcast2 -- if T :: * -> * -> * +-} + +gen_Data_binds :: SrcSpan + -> TyCon -- For data families, this is the + -- *representation* TyCon + -> TcM (LHsBinds GhcPs, -- The method bindings + BagDerivStuff) -- Auxiliary bindings +gen_Data_binds loc rep_tc + = do { -- See Note [Auxiliary binders] + dataT_RDR <- new_dataT_rdr_name loc rep_tc + ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons + + ; pure ( listToBag [ gfoldl_bind, gunfold_bind + , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ] + `unionBags` gcast_binds + -- Auxiliary definitions: the data type and constructors + , listToBag $ map DerivAuxBind + ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs + : zipWith (\data_con dataC_RDR -> + DerivDataConstr data_con dataC_RDR dataT_RDR) + data_cons dataC_RDRs ) + ) } + where + data_cons = tyConDataCons rep_tc + n_cons = length data_cons + one_constr = n_cons == 1 + + ------------ gfoldl + gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) + + gfoldl_eqn con + = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], + foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed) + where + con_name :: RdrName + con_name = getRdrName con + as_needed = take (dataConSourceArity con) as_RDRs + mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) + + ------------ gunfold + gunfold_bind = mkSimpleGeneratedFunBind loc + gunfold_RDR + [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] + gunfold_rhs + + gunfold_rhs + | one_constr = mk_unfold_rhs (head data_cons) -- No need for case + | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) + (map gunfold_alt data_cons) + + gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) + mk_unfold_rhs dc = foldr nlHsApp + (z_Expr `nlHsApp` (eta_expand_data_con dc)) + (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + + eta_expand_data_con dc = + mkHsLam eta_expand_pats + (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars) + where + eta_expand_pats = map nlVarPat eta_expand_vars + eta_expand_hsvars = map nlHsVar eta_expand_vars + eta_expand_vars = take (dataConSourceArity dc) as_RDRs + + + mk_unfold_pat dc -- Last one is a wild-pat, to avoid + -- redundant test, and annoying warning + | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor + | otherwise = nlConPat intDataCon_RDR + [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] + where + tag = dataConTag dc + + ------------ toConstr + toCon_bind dataC_RDRs + = mkFunBindEC 1 loc toConstr_RDR id + (zipWith to_con_eqn data_cons dataC_RDRs) + to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) + + ------------ dataTypeOf + dataTypeOf_bind dataT_RDR + = mkSimpleGeneratedFunBind + loc + dataTypeOf_RDR + [nlWildPat] + (nlHsVar dataT_RDR) + + ------------ gcast1/2 + -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * + -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * + -- (or nothing if T has neither of these two types) + + -- But care is needed for data families: + -- If we have data family D a + -- data instance D (a,b,c) = A | B deriving( Data ) + -- and we want instance ... => Data (D [(a,b,c)]) where ... + -- then we need dataCast1 x = gcast1 x + -- because D :: * -> * + -- even though rep_tc has kind * -> * -> * -> * + -- Hence looking for the kind of fam_tc not rep_tc + -- See #4896 + tycon_kind = case tyConFamInst_maybe rep_tc of + Just (fam_tc, _) -> tyConKind fam_tc + Nothing -> tyConKind rep_tc + gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR + | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR + | otherwise = emptyBag + mk_gcast dataCast_RDR gcast_RDR + = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] + (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) + + +kind1, kind2 :: Kind +kind1 = typeToTypeKind +kind2 = liftedTypeKind `mkVisFunTyMany` kind1 + +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, + dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, + constr_RDR, dataType_RDR, + eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , + eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , + eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , + eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , + eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , + eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , + eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, + eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , + eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , + eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, + extendWord8_RDR, extendInt8_RDR, + extendWord16_RDR, extendInt16_RDR :: RdrName +gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") +toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") +dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") +gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") +gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") +mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") +mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") +dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") +conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") +infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") + +eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") +ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") +leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") +gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") +geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") + +eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") +ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) +leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") +gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) +geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") + +eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#") +ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" ) +leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") +gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) +geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") + +eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") +ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) +leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") +gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) +geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") + +eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") +ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") +leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") +gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") +geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") + +eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") +ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) +leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") +gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) +geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") + +eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") +ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) +leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") +gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) +geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") + +eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") +ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") +leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") +gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") +geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") + +eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") +ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") +leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") +gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") +geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") + +eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") +ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) +leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") +gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) +geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") + +extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#") +extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") + +extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") +extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") + + +{- +************************************************************************ +* * + Lift instances +* * +************************************************************************ + +Example: + + data Foo a = Foo a | a :^: a deriving Lift + + ==> + + instance (Lift a) => Lift (Foo a) where + lift (Foo a) = [| Foo a |] + lift ((:^:) u v) = [| (:^:) u v |] + + liftTyped (Foo a) = [|| Foo a ||] + liftTyped ((:^:) u v) = [|| (:^:) u v ||] +-} + + +gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) +gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) + where + lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) + (map (pats_etc mk_exp) data_cons) + liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr) + (map (pats_etc mk_texp) data_cons) + + mk_exp = ExpBr noExtField + mk_texp = TExpBr noExtField + data_cons = tyConDataCons tycon + + pats_etc mk_bracket data_con + = ([con_pat], lift_Expr) + where + con_pat = nlConVarPat data_con_RDR as_needed + data_con_RDR = getRdrName data_con + con_arity = dataConSourceArity data_con + as_needed = take con_arity as_RDRs + lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) + br_body = nlHsApps (Exact (dataConName data_con)) + (map nlHsVar as_needed) + +{- +************************************************************************ +* * + Newtype-deriving instances +* * +************************************************************************ + +Note [Newtype-deriving instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take every method in the original instance and `coerce` it to fit +into the derived instance. We need type applications on the argument +to `coerce` to make it obvious what instantiation of the method we're +coercing from. So from, say, + + class C a b where + op :: forall c. a -> [b] -> c -> Int + + newtype T x = MkT + + instance C a => C a (T x) where + op :: forall c. a -> [T x] -> c -> Int + op = coerce @(a -> [] -> c -> Int) + @(a -> [T x] -> c -> Int) + op + +In addition to the type applications, we also have an explicit +type signature on the entire RHS. This brings the method-bound variable +`c` into scope over the two type applications. +See Note [GND and QuantifiedConstraints] for more information on why this +is important. + +Giving 'coerce' two explicitly-visible type arguments grants us finer control +over how it should be instantiated. Recall + + coerce :: Coercible a b => a -> b + +By giving it explicit type arguments we deal with the case where +'op' has a higher rank type, and so we must instantiate 'coerce' with +a polytype. E.g. + + class C a where op :: a -> forall b. b -> b + newtype T x = MkT + instance C => C (T x) where + op :: T x -> forall b. b -> b + op = coerce @( -> forall b. b -> b) + @(T x -> forall b. b -> b) + op + +The use of type applications is crucial here. If we had tried using only +explicit type signatures, like so: + + instance C => C (T x) where + op :: T x -> forall b. b -> b + op = coerce (op :: -> forall b. b -> b) + +Then GHC will attempt to deeply skolemize the two type signatures, which will +wreak havoc with the Coercible solver. Therefore, we instead use type +applications, which do not deeply skolemize and thus avoid this issue. +The downside is that we currently require -XImpredicativeTypes to permit this +polymorphic type instantiation, so we have to switch that flag on locally in +GHC.Tc.Deriv.genInst. See #8503 for more discussion. + +Note [Newtype-deriving trickiness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12768): + class C a where { op :: D a => a -> a } + + instance C a => C [a] where { op = opList } + + opList :: (C a, D [a]) => [a] -> [a] + opList = ... + +Now suppose we try GND on this: + newtype N a = MkN [a] deriving( C ) + +The GND is expecting to get an implementation of op for N by +coercing opList, thus: + + instance C a => C (N a) where { op = opN } + + opN :: (C a, D (N a)) => N a -> N a + opN = coerce @([a] -> [a]) + @([N a] -> [N a] + opList :: D (N a) => [N a] -> [N a] + +But there is no reason to suppose that (D [a]) and (D (N a)) +are inter-coercible; these instances might completely different. +So GHC rightly rejects this code. + +Note [GND and QuantifiedConstraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example from #15290: + + class C m where + join :: m (m a) -> m a + + newtype T m a = MkT (m a) + + deriving instance + (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) + +The code that GHC used to generate for this was: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join = coerce @(forall a. m (m a) -> m a) + @(forall a. T m (T m a) -> T m a) + join + +This instantiates `coerce` at a polymorphic type, a form of impredicative +polymorphism, so we're already on thin ice. And in fact the ice breaks, +as we'll explain: + +The call to `coerce` gives rise to: + + Coercible (forall a. m (m a) -> m a) + (forall a. T m (T m a) -> T m a) + +And that simplified to the following implication constraint: + + forall a . m (T m a) ~R# m (m a) + +But because this constraint is under a `forall`, inside a type, we have to +prove it *without computing any term evidence* (hence the ). Alas, we +*must* generate a term-level evidence binding in order to instantiate the +quantified constraint! In response, GHC currently chooses not to use such +a quantified constraint. +See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Interact. + +But this isn't the death knell for combining QuantifiedConstraints with GND. +On the contrary, if we generate GND bindings in a slightly different way, then +we can avoid this situation altogether. Instead of applying `coerce` to two +polymorphic types, we instead let an instance signature do the polymorphic +instantiation, and omit the `forall`s in the type applications. +More concretely, we generate the following code instead: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join :: forall a. T m (T m a) -> T m a + join = coerce @( m (m a) -> m a) + @(T m (T m a) -> T m a) + join + +Now the visible type arguments are both monotypes, so we don't need any of this +funny quantified constraint instantiation business. While this particular +example no longer uses impredicative instantiation, we still need to enable +ImpredicativeTypes to typecheck GND-generated code for class methods with +higher-rank types. See Note [Newtype-deriving instances]. + +You might think that that second @(T m (T m a) -> T m a) argument is redundant +in the presence of the instance signature, but in fact leaving it off will +break this example (from the T15290d test case): + + class C a where + c :: Int -> forall b. b -> a + + instance C Int + + instance C Age where + c :: Int -> forall b. b -> Age + c = coerce @(Int -> forall b. b -> Int) + c + +That is because the instance signature deeply skolemizes the forall-bound +`b`, which wreaks havoc with the `Coercible` solver. An additional visible type +argument of @(Int -> forall b. b -> Age) is enough to prevent this. + +Be aware that the use of an instance signature doesn't /solve/ this +problem; it just makes it less likely to occur. For example, if a class has +a truly higher-rank type like so: + + class CProblem m where + op :: (forall b. ... (m b) ...) -> Int + +Then the same situation will arise again. But at least it won't arise for the +common case of methods with ordinary, prenex-quantified types. + +Note [GND and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~ +We make an effort to make the code generated through GND be robust w.r.t. +ambiguous type variables. As one example, consider the following example +(from #15637): + + class C a where f :: String + instance C () where f = "foo" + newtype T = T () deriving C + +A naïve attempt and generating a C T instance would be: + + instance C T where + f :: String + f = coerce @String @String f + +This isn't going to typecheck, however, since GHC doesn't know what to +instantiate the type variable `a` with in the call to `f` in the method body. +(Note that `f :: forall a. String`!) To compensate for the possibility of +ambiguity here, we explicitly instantiate `a` like so: + + instance C T where + f :: String + f = coerce @String @String (f @()) + +All better now. +-} + +gen_Newtype_binds :: SrcSpan + -> Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) +-- See Note [Newtype-deriving instances] +gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty + = do let ats = classATs cls + (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) + atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) + mapM mk_atf_inst ats + return ( listToBag binds + , sigs + , listToBag $ map DerivFamInst atf_insts ) + where + -- For each class method, generate its derived binding and instance + -- signature. Using the first example from + -- Note [Newtype-deriving instances]: + -- + -- class C a b where + -- op :: forall c. a -> [b] -> c -> Int + -- + -- newtype T x = MkT + -- + -- Then we would generate below: + -- + -- instance C a => C a (T x) where + -- + mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs) + mk_bind_and_sig meth_id + = ( -- The derived binding, e.g., + -- + -- op = coerce @(a -> [] -> c -> Int) + -- @(a -> [T x] -> c -> Int) + -- op + mkRdrFunBind loc_meth_RDR [mkSimpleMatch + (mkPrefixFunRhs loc_meth_RDR) + [] rhs_expr] + , -- The derived instance signature, e.g., + -- + -- op :: forall c. a -> [T x] -> c -> Int + L loc $ ClassOpSig noExtField False [loc_meth_RDR] + $ mkLHsSigType $ nlHsCoreTy to_ty + ) + where + Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id + (_, _, from_tau) = tcSplitSigmaTy from_ty + (_, _, to_tau) = tcSplitSigmaTy to_ty + + meth_RDR = getRdrName meth_id + loc_meth_RDR = L loc meth_RDR + + rhs_expr = nlHsVar (getRdrName coerceId) + `nlHsAppType` from_tau + `nlHsAppType` to_tau + `nlHsApp` meth_app + + -- The class method, applied to all of the class instance types + -- (including the representation type) to avoid potential ambiguity. + -- See Note [GND and ambiguity] + meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $ + filterOutInferredTypes (classTyCon cls) underlying_inst_tys + -- Filter out any inferred arguments, since they can't be + -- applied with visible type application. + + mk_atf_inst :: TyCon -> TcM FamInst + mk_atf_inst fam_tc = do + rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) + rep_lhs_tys + let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' + fam_tc rep_lhs_tys rep_rhs_ty + -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv + checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) + newFamInst SynFamilyInst axiom + where + cls_tvs = classTyVars cls + in_scope = mkInScopeSet $ mkVarSet inst_tvs + lhs_env = zipTyEnv cls_tvs inst_tys + lhs_subst = mkTvSubst in_scope lhs_env + rhs_env = zipTyEnv cls_tvs underlying_inst_tys + rhs_subst = mkTvSubst in_scope rhs_env + fam_tvs = tyConTyVars fam_tc + rep_lhs_tys = substTyVars lhs_subst fam_tvs + rep_rhs_tys = substTyVars rhs_subst fam_tvs + rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys + rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys + (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs + rep_tvs' = scopedSort rep_tvs + rep_cvs' = scopedSort rep_cvs + + -- Same as inst_tys, but with the last argument type replaced by the + -- representation type. + underlying_inst_tys :: [Type] + underlying_inst_tys = changeLast inst_tys rhs_ty + +nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs +nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) + where + hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s + +nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs +nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty + where + hs_ty = mkLHsSigWcType s + +nlHsCoreTy :: Type -> LHsType GhcPs +nlHsCoreTy = noLoc . XHsType . NHsCoreTy + +mkCoerceClassMethEqn :: Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> Id -- the method to look at + -> Pair Type +-- See Note [Newtype-deriving instances] +-- See also Note [Newtype-deriving trickiness] +-- The pair is the (from_type, to_type), where to_type is +-- the type of the method we are trying to get +mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id + = Pair (substTy rhs_subst user_meth_ty) + (substTy lhs_subst user_meth_ty) + where + cls_tvs = classTyVars cls + in_scope = mkInScopeSet $ mkVarSet inst_tvs + lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) + rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) + (_class_tvs, _class_constraint, user_meth_ty) + = tcSplitMethodTy (varType id) + +{- +************************************************************************ +* * +\subsection{Generating extra binds (@con2tag@, @tag2con@, etc.)} +* * +************************************************************************ + +\begin{verbatim} +data Foo ... = ... + +con2tag_Foo :: Foo ... -> Int# +tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# +maxtag_Foo :: Int -- ditto (NB: not unlifted) +\end{verbatim} + +The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) +fiddling around. +-} + +-- | Generate the full code for an auxiliary binding. +-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@. +genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec + -> (LHsBind GhcPs, LSig GhcPs) +genAuxBindSpecOriginal dflags loc spec + = (gen_bind spec, + L loc (TypeSig noExtField [L loc (auxBindSpecRdrName spec)] + (genAuxBindSpecSig loc spec))) + where + gen_bind :: AuxBindSpec -> LHsBind GhcPs + gen_bind (DerivCon2Tag tycon con2tag_RDR) + = mkFunBindSE 0 loc con2tag_RDR eqns + where + lots_of_constructors = tyConFamilySize tycon > 8 + -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS + -- but we don't do vectored returns any more. + + eqns | lots_of_constructors = [get_tag_eqn] + | otherwise = map mk_eqn (tyConDataCons tycon) + + get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) + + mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) + mk_eqn con = ([nlWildConPat con], + nlHsLit (HsIntPrim NoSourceText + (toInteger ((dataConTag con) - fIRST_TAG)))) + + gen_bind (DerivTag2Con _ tag2con_RDR) + = mkFunBindSE 0 loc tag2con_RDR + [([nlConVarPat intDataCon_RDR [a_RDR]], + nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)] + + gen_bind (DerivMaxTag tycon maxtag_RDR) + = mkHsVarBind loc maxtag_RDR rhs + where + rhs = nlHsApp (nlHsVar intDataCon_RDR) + (nlHsLit (HsIntPrim NoSourceText max_tag)) + max_tag = case (tyConDataCons tycon) of + data_cons -> toInteger ((length data_cons) - fIRST_TAG) + + gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs) + = mkHsVarBind loc dataT_RDR rhs + where + ctx = initDefaultSDocContext dflags + rhs = nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon))) + `nlHsApp` nlList (map nlHsVar dataC_RDRs) + + gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR) + = mkHsVarBind loc dataC_RDR rhs + where + rhs = nlHsApps mkConstr_RDR constr_args + + constr_args + = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsVar dataT_RDR -- DataType + , nlHsLit (mkHsString (occNameString dc_occ)) -- String name + , nlList labels -- Field labels + , nlHsVar fixity ] -- Fixity + + labels = map (nlHsLit . mkHsString . unpackFS . flLabel) + (dataConFieldLabels dc) + dc_occ = getOccName dc + is_infix = isDataSymOcc dc_occ + fixity | is_infix = infix_RDR + | otherwise = prefix_RDR + +-- | Generate the code for an auxiliary binding that is a duplicate of another +-- auxiliary binding. +-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@. +genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec + -> (LHsBind GhcPs, LSig GhcPs) +genAuxBindSpecDup loc original_rdr_name dup_spec + = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name), + L loc (TypeSig noExtField [L loc dup_rdr_name] + (genAuxBindSpecSig loc dup_spec))) + where + dup_rdr_name = auxBindSpecRdrName dup_spec + +-- | Generate the type signature of an auxiliary binding. +-- See @Note [Auxiliary binders]@. +genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs +genAuxBindSpecSig loc spec = case spec of + DerivCon2Tag tycon _ + -> mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ + mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ + mkParentType tycon `mkVisFunTyMany` intPrimTy + DerivTag2Con tycon _ + -> mkLHsSigWcType $ L loc $ + XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ + intTy `mkVisFunTyMany` mkParentType tycon + DerivMaxTag _ _ + -> mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) + DerivDataDataType _ _ _ + -> mkLHsSigWcType (nlHsTyVar dataType_RDR) + DerivDataConstr _ _ _ + -> mkLHsSigWcType (nlHsTyVar constr_RDR) + +type SeparateBagsDerivStuff = + -- DerivAuxBinds + ( Bag (LHsBind GhcPs, LSig GhcPs) + + -- Extra family instances (used by DeriveGeneric, DeriveAnyClass, and + -- GeneralizedNewtypeDeriving) + , Bag FamInst ) + +-- | Take a 'BagDerivStuff' and partition it into 'SeparateBagsDerivStuff'. +-- Also generate the code for auxiliary bindings based on the declarative +-- descriptions in the supplied 'AuxBindSpec's. See @Note [Auxiliary binders]@. +genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff +genAuxBinds dflags loc b = (gen_aux_bind_specs b1, b2) where + (b1,b2) = partitionBagWith splitDerivAuxBind b + splitDerivAuxBind (DerivAuxBind x) = Left x + splitDerivAuxBind (DerivFamInst t) = Right t + + gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) + + -- Perform a CSE-like pass over the generated auxiliary bindings to avoid + -- code duplication, as described in + -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication). + -- The OccEnv remembers the first occurrence of each sort of auxiliary + -- binding and maps it to the unique RdrName for that binding. + gen_aux_bind_spec :: AuxBindSpec + -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs)) + -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs)) + gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) = + case lookupOccEnv original_rdr_name_env spec_occ of + Nothing + -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name + , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag ) + Just original_rdr_name + -> ( original_rdr_name_env + , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag ) + where + spec_rdr_name = auxBindSpecRdrName spec + spec_occ = rdrNameOcc spec_rdr_name + +mkParentType :: TyCon -> Type +-- Turn the representation tycon of a family into +-- a use of its family constructor +mkParentType tc + = case tyConFamInst_maybe tc of + Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) + Just (fam_tc,tys) -> mkTyConApp fam_tc tys + +{- +************************************************************************ +* * +\subsection{Utility bits for generating bindings} +* * +************************************************************************ +-} + +-- | Make a function binding. If no equations are given, produce a function +-- with the given arity that produces a stock error. +mkFunBindSE :: Arity -> SrcSpan -> RdrName + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs +mkFunBindSE arity loc fun pats_and_exprs + = mkRdrFunBindSE arity (L loc fun) matches + where + matches = [mkMatch (mkPrefixFunRhs (L loc fun)) + (map (parenthesizePat appPrec) p) e + (noLoc emptyLocalBinds) + | (p,e) <-pats_and_exprs] + +mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs +mkRdrFunBind fun@(L loc _fun_rdr) matches + = L loc (mkFunBind Generated fun matches) + +-- | Make a function binding. If no equations are given, produce a function +-- with the given arity that uses an empty case expression for the last +-- argument that is passes to the given function to produce the right-hand +-- side. +mkFunBindEC :: Arity -> SrcSpan -> RdrName + -> (LHsExpr GhcPs -> LHsExpr GhcPs) + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs +mkFunBindEC arity loc fun catch_all pats_and_exprs + = mkRdrFunBindEC arity catch_all (L loc fun) matches + where + matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) + (map (parenthesizePat appPrec) p) e + (noLoc emptyLocalBinds) + | (p,e) <- pats_and_exprs ] + +-- | Produces a function binding. When no equations are given, it generates +-- a binding of the given arity and an empty case expression +-- for the last argument that it passes to the given function to produce +-- the right-hand side. +mkRdrFunBindEC :: Arity + -> (LHsExpr GhcPs -> LHsExpr GhcPs) + -> Located RdrName + -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs +mkRdrFunBindEC arity catch_all + fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') + where + -- Catch-all eqn looks like + -- fmap _ z = case z of {} + -- or + -- traverse _ z = pure (case z of) + -- or + -- foldMap _ z = mempty + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See #4302 + matches' = if null matches + then [mkMatch (mkPrefixFunRhs fun) + (replicate (arity - 1) nlWildPat ++ [z_Pat]) + (catch_all $ nlHsCase z_Expr []) + (noLoc emptyLocalBinds)] + else matches + +-- | Produces a function binding. When there are no equations, it generates +-- a binding with the given arity that produces an error based on the name of +-- the type of the last argument. +mkRdrFunBindSE :: Arity -> Located RdrName -> + [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs +mkRdrFunBindSE arity + fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') + where + -- Catch-all eqn looks like + -- compare _ _ = error "Void compare" + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See #4302 + matches' = if null matches + then [mkMatch (mkPrefixFunRhs fun) + (replicate arity nlWildPat) + (error_Expr str) (noLoc emptyLocalBinds)] + else matches + str = "Void " ++ occNameString (rdrNameOcc fun_rdr) + + +box :: String -- The class involved + -> LHsExpr GhcPs -- The argument + -> Type -- The argument type + -> LHsExpr GhcPs -- Boxed version of the arg +-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer +box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg + +--------------------- +primOrdOps :: String -- The class involved + -> Type -- The type + -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) +-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer +primOrdOps str ty = assoc_ty_id str ordOpTbl ty + +ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] +ordOpTbl + = [(charPrimTy , (ltChar_RDR , leChar_RDR + , eqChar_RDR , geChar_RDR , gtChar_RDR )) + ,(intPrimTy , (ltInt_RDR , leInt_RDR + , eqInt_RDR , geInt_RDR , gtInt_RDR )) + ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR + , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) + ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR + , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) + ,(wordPrimTy , (ltWord_RDR , leWord_RDR + , eqWord_RDR , geWord_RDR , gtWord_RDR )) + ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR + , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) + ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR + , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) + ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR + , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) + ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR + , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) + ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR + , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] + +-- A mapping from a primitive type to a function that constructs its boxed +-- version. +-- NOTE: Int8#/Word8# will become Int/Word. +boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] +boxConTbl = + [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon)) + , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon)) + , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) + , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) + , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) + , (int8PrimTy, + nlHsApp (nlHsVar $ getRdrName intDataCon) + . nlHsApp (nlHsVar extendInt8_RDR)) + , (word8PrimTy, + nlHsApp (nlHsVar $ getRdrName wordDataCon) + . nlHsApp (nlHsVar extendWord8_RDR)) + , (int16PrimTy, + nlHsApp (nlHsVar $ getRdrName intDataCon) + . nlHsApp (nlHsVar extendInt16_RDR)) + , (word16PrimTy, + nlHsApp (nlHsVar $ getRdrName wordDataCon) + . nlHsApp (nlHsVar extendWord16_RDR)) + ] + + +-- | A table of postfix modifiers for unboxed values. +postfixModTbl :: [(Type, String)] +postfixModTbl + = [(charPrimTy , "#" ) + ,(intPrimTy , "#" ) + ,(wordPrimTy , "##") + ,(floatPrimTy , "#" ) + ,(doublePrimTy, "##") + ,(int8PrimTy, "#") + ,(word8PrimTy, "##") + ,(int16PrimTy, "#") + ,(word16PrimTy, "##") + ] + +primConvTbl :: [(Type, String)] +primConvTbl = + [ (int8PrimTy, "narrowInt8#") + , (word8PrimTy, "narrowWord8#") + , (int16PrimTy, "narrowInt16#") + , (word16PrimTy, "narrowWord16#") + ] + +litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] +litConTbl + = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) + ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) + . nlHsApp (nlHsVar toInteger_RDR)) + ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) + . nlHsApp (nlHsVar toInteger_RDR)) + ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) + . nlHsApp (nlHsApp + (nlHsVar map_RDR) + (compose_RDR `nlHsApps` + [ nlHsVar fromIntegral_RDR + , nlHsVar fromEnum_RDR + ]))) + ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) + . nlHsApp (nlHsVar toRational_RDR)) + ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) + . nlHsApp (nlHsVar toRational_RDR)) + ] + +-- | Lookup `Type` in an association list. +assoc_ty_id :: HasCallStack => String -- The class involved + -> [(Type,a)] -- The table + -> Type -- The type + -> a -- The result of the lookup +assoc_ty_id cls_str tbl ty + | Just a <- assoc_ty_id_maybe tbl ty = a + | otherwise = + pprPanic "Error in deriving:" + (text "Can't derive" <+> text cls_str <+> + text "for primitive type" <+> ppr ty) + +-- | Lookup `Type` in an association list. +assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a +assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl + +----------------------------------------------------------------------- + +and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +and_Expr a b = genOpApp a and_RDR b + +----------------------------------------------------------------------- + +eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +eq_Expr ty a b + | not (isUnliftedType ty) = genOpApp a eq_RDR b + | otherwise = genPrimOpApp a prim_eq b + where + (_, _, prim_eq, _, _) = primOrdOps "Eq" ty + +untag_Expr :: RdrName -> [(RdrName, RdrName)] + -> LHsExpr GhcPs -> LHsExpr GhcPs +untag_Expr _ [] expr = expr +untag_Expr con2tag_RDR ((untag_this, put_tag_here) : more) expr + = nlHsCase (nlHsPar (nlHsVarApps con2tag_RDR [untag_this])) {-of-} + [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr con2tag_RDR more expr)] + +enum_from_to_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs +enum_from_then_to_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs + +enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 +enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 + +showParen_Expr + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs + +showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 + +nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs + +nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty +nested_compose_Expr [e] = parenify e +nested_compose_Expr (e:es) + = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) + +-- impossible_Expr is used in case RHSs that should never happen. +-- We generate these to keep the desugarer from complaining that they *might* happen! +error_Expr :: String -> LHsExpr GhcPs +error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) + +-- illegal_Expr is used when signalling error conditions in the RHS of a derived +-- method. It is currently only used by Enum.{succ,pred} +illegal_Expr :: String -> String -> String -> LHsExpr GhcPs +illegal_Expr meth tp msg = + nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) + +-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you +-- to include the value of a_RDR in the error string. +illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs +illegal_toEnum_tag tp maxtag = + nlHsApp (nlHsVar error_RDR) + (nlHsApp (nlHsApp (nlHsVar append_RDR) + (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar a_RDR)) + (nlHsApp (nlHsApp + (nlHsVar append_RDR) + (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar maxtag)) + (nlHsLit (mkHsString ")")))))) + +parenify :: LHsExpr GhcPs -> LHsExpr GhcPs +parenify e@(L _ (HsVar _ _)) = e +parenify e = mkHsPar e + +-- genOpApp wraps brackets round the operator application, so that the +-- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) + +genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) + +a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR + :: RdrName +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +f_RDR = mkVarUnqual (fsLit "f") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") + +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] + +a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, + true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs +a_Expr = nlHsVar a_RDR +b_Expr = nlHsVar b_RDR +c_Expr = nlHsVar c_RDR +z_Expr = nlHsVar z_RDR +ltTag_Expr = nlHsVar ltTag_RDR +eqTag_Expr = nlHsVar eqTag_RDR +gtTag_Expr = nlHsVar gtTag_RDR +false_Expr = nlHsVar false_RDR +true_Expr = nlHsVar true_RDR +pure_Expr = nlHsVar pure_RDR +unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR + +a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs +a_Pat = nlVarPat a_RDR +b_Pat = nlVarPat b_RDR +c_Pat = nlVarPat c_RDR +d_Pat = nlVarPat d_RDR +k_Pat = nlVarPat k_RDR +z_Pat = nlVarPat z_RDR + +minusInt_RDR, tagToEnum_RDR :: RdrName +minusInt_RDR = getRdrName (primOpId IntSubOp ) +tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) + +new_con2tag_rdr_name, new_tag2con_rdr_name, new_maxtag_rdr_name + :: SrcSpan -> TyCon -> TcM RdrName +-- Generates Exact RdrNames, for the binding positions +new_con2tag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkCon2TagOcc +new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc +new_maxtag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc + +new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName +new_dataT_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkDataTOcc + +new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName +new_dataC_rdr_name dflags dc = new_dc_deriv_rdr_name dflags dc mkDataCOcc + +new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName +new_tc_deriv_rdr_name loc tycon occ_fun + = newAuxBinderRdrName loc (tyConName tycon) occ_fun + +new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName +new_dc_deriv_rdr_name loc dc occ_fun + = newAuxBinderRdrName loc (dataConName dc) occ_fun + +-- | Generate the name for an auxiliary binding, giving it a fresh 'Unique'. +-- Returns an 'Exact' 'RdrName' with an underlying 'System' 'Name'. +-- See @Note [Auxiliary binders]@. +newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName +newAuxBinderRdrName loc parent occ_fun = do + uniq <- newUnique + pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc + + +{- +Note [Auxiliary binders] +~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to make top-level auxiliary bindings in derived instances. +For example, derived Eq instances sometimes generate code like this: + + data T = ... + deriving instance Eq T + + ==> + + instance Eq T where + a == b = $con2tag_T a == $con2tag_T b + + $con2tag_T :: T -> Int + $con2tag_T = ...code.... + +Note that multiple instances of the same type might need to use the same sort +of auxiliary binding. For example, $con2tag is used not only in derived Eq +instances, but also in derived Ord instances: + + deriving instance Ord T + + ==> + + instance Ord T where + compare a b = $con2tag_T a `compare` $con2tag_T b + + $con2tag_T :: T -> Int + $con2tag_T = ...code.... + +How do we ensure that the two usages of $con2tag_T do not conflict with each +other? We do so by generating a separate $con2tag_T definition for each +instance, giving each definition an Exact RdrName with a separate Unique to +avoid name clashes: + + instance Eq T where + a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b + + instance Ord T where + compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b + + -- $con2tag_T{Uniq1} and $con2tag_T{Uniq2} are Exact RdrNames with + -- underyling System Names + + $con2tag_T{Uniq1} :: T -> Int + $con2tag_T{Uniq1} = ...code.... + + $con2tag_T{Uniq2} :: T -> Int + $con2tag_T{Uniq2} = ...code.... + +Note that: + +* This is /precisely/ the same mechanism that we use for + Template Haskell–generated code. + See Note [Binders in Template Haskell] in GHC.ThToHs. + There we explain why we use a 'System' flavour of the Name we generate. + +* See "Wrinkle: Reducing code duplication" for how we can avoid generating + lots of duplicated code in common situations. + +* See "Wrinkle: Why we sometimes do generated duplicate code" for why this + de-duplication mechanism isn't perfect, so we fall back to CSE + (which is very effective within a single module). + +* Note that the "_T" part of "$con2tag_T" is just for debug-printing + purposes. We could call them all "$con2tag", or even just "aux". + The Unique is enough to keep them separate. + + This is important: we might be generating an Eq instance for two + completely-distinct imported type constructors T. + +At first glance, it might appear that this plan is infeasible, as it would +require generating multiple top-level declarations with the same OccName. But +what if auxiliary bindings /weren't/ top-level? Conceptually, we could imagine +that auxiliary bindings are /local/ to the instance declarations in which they +are used. Using some hypothetical Haskell syntax, it might look like this: + + let { + $con2tag_T{Uniq1} :: T -> Int + $con2tag_T{Uniq1} = ...code.... + + $con2tag_T{Uniq2} :: T -> Int + $con2tag_T{Uniq2} = ...code.... + } in { + instance Eq T where + a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b + + instance Ord T where + compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b + } + +Making auxiliary bindings local is key to making this work, since GHC will +not reject local bindings with duplicate names provided that: + +* Each binding has a distinct unique, and +* Each binding has an Exact RdrName with a System Name. + +Even though the hypothetical Haskell syntax above does not exist, we can +accomplish the same end result through some sleight of hand in renameDeriv: +we rename auxiliary bindings with rnLocalValBindsLHS. (If we had used +rnTopBindsLHS instead, then GHC would spuriously reject auxiliary bindings +with the same OccName as duplicates.) Luckily, no special treatment is needed +to typecheck them; we can typecheck them as normal top-level bindings +(using tcTopBinds) without danger. + +----- +-- Wrinkle: Reducing code duplication +----- + +While the approach of generating copies of each sort of auxiliary binder per +derived instance is simpler, it can lead to code bloat if done naïvely. +Consider this example: + + data T = ... + deriving instance Eq T + deriving instance Ord T + + ==> + + instance Eq T where + a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b + + instance Ord T where + compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b + + $con2tag_T{Uniq1} :: T -> Int + $con2tag_T{Uniq1} = ...code.... + + $con2tag_T{Uniq2} :: T -> Int + $con2tag_T{Uniq2} = ...code.... + +$con2tag_T{Uniq1} and $con2tag_T{Uniq2} are blatant duplicates of each other, +which is not ideal. Surely GHC can do better than that at the very least! And +indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like +pass to define duplicate auxiliary binders in terms of the original one. On +the example above, that would look like this: + + $con2tag_T{Uniq1} :: T -> Int + $con2tag_T{Uniq1} = ...code.... + + $con2tag_T{Uniq2} :: T -> Int + $con2tag_T{Uniq2} = $con2tag_T{Uniq1} + +(Note that this pass does not cover all possible forms of code duplication. +See "Wrinkle: Why we sometimes do generate duplicate code" for situations +where genAuxBinds does not deduplicate code.) + +To start, genAuxBinds is given a list of AuxBindSpecs, which describe the sort +of auxiliary bindings that must be generates along with their RdrNames. As +genAuxBinds processes this list, it marks the first occurrence of each sort of +auxiliary binding as the "original". For example, if genAuxBinds sees a +DerivCon2Tag for the first time (with the RdrName $con2tag_T{Uniq1}), then it +will generate the full code for a $con2tag binding: + + $con2tag_T{Uniq1} :: T -> Int + $con2tag_T{Uniq1} = ...code.... + +Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat +them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with +the RdrName $con2tag_T{Uniq2}, it will generate this code, which is much more +compact: + + $con2tag_T{Uniq2} :: T -> Int + $con2tag_T{Uniq2} = $con2tag_T{Uniq1} + +An alternative approach would be /not/ performing any kind of deduplication in +genAuxBinds at all and simply relying on GHC's simplifier to perform this kind +of CSE. But this is a more expensive analysis in general, while genAuxBinds can +accomplish the same result with a simple check. + +----- +-- Wrinkle: Why we sometimes do generate duplicate code +----- + +It is worth noting that deduplicating auxiliary binders is difficult in the +general case. Here are two particular examples where GHC cannot easily remove +duplicate copies of an auxiliary binding: + +1. When derived instances are contained in different modules, as in the + following example: + + module A where + data T = ... + module B where + import A + deriving instance Eq T + module C where + import B + deriving instance Enum T + + The derived Eq and Enum instances for T make use of $con2tag_T, and since + they are defined in separate modules, each module must produce its own copy + of $con2tag_T. + +2. When derived instances are separated by TH splices (#18321), as in the + following example: + + module M where + + data T = ... + deriving instance Eq T + $(pure []) + deriving instance Enum T + + Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice + in this program: once for all the declarations before the TH splice, and + once again for all the declarations after the TH splice. As a result, + $con2tag_T will be generated twice, since genAuxBinds will be unable to + recognize the presence of duplicates. + +These situations are much rarer, so we do not spend any effort to deduplicate +auxiliary bindings there. Instead, we focus on the common case of multiple +derived instances within the same module, not separated by any TH splices. +(This is the case described in "Wrinkle: Reducing code duplication".) In +situation (1), we can at least fall back on GHC's simplifier to pick up +genAuxBinds' slack. +-} diff --git a/GHC/Tc/Deriv/Generics.hs b/GHC/Tc/Deriv/Generics.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Generics.hs @@ -0,0 +1,1040 @@ +{- +(c) The University of Glasgow 2011 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | The deriving code for the Generic class +module GHC.Tc.Deriv.Generics + (canDoGenerics + , canDoGenerics1 + , GenericKind(..) + , gen_Generic_binds + , get_gen1_constrained_tys + ) +where + +import GHC.Prelude + +import GHC.Hs +import GHC.Core.Type +import GHC.Tc.Utils.TcType +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) +import GHC.Core.Multiplicity +import GHC.Tc.Instance.Family +import GHC.Unit.Module ( moduleName, moduleNameFS + , moduleUnit, unitFS, getModule ) +import GHC.Iface.Env ( newGlobalBinder ) +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Name.Reader +import GHC.Types.Basic +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Driver.Types +import GHC.Utils.Error( Validity(..), andValid ) +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Types.Var.Env +import GHC.Types.Var.Set (elemVarSet) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc + +import Control.Monad (mplus) +import Data.List (zip4, partition) +import Data.Maybe (isJust) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{Bindings for the new generic deriving mechanism} +* * +************************************************************************ + +For the generic representation we need to generate: +\begin{itemize} +\item A Generic instance +\item A Rep type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\end{itemize} +-} + +gen_Generic_binds :: GenericKind -> TyCon -> [Type] + -> TcM (LHsBinds GhcPs, FamInst) +gen_Generic_binds gk tc inst_tys = do + repTyInsts <- tc_mkRepFamInsts gk tc inst_tys + return (mkBindsRep gk tc, repTyInsts) + +{- +************************************************************************ +* * +\subsection{Generating representation types} +* * +************************************************************************ +-} + +get_gen1_constrained_tys :: TyVar -> Type -> [Type] +-- called by GHC.Tc.Deriv.Infer.inferConstraints; generates a list of +-- types, each of which must be a Functor in order for the Generic1 instance to +-- work. +get_gen1_constrained_tys argVar + = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] + , ata_par1 = [], ata_rec1 = const [] + , ata_comp = (:) } + +{- + +Note [Requirements for deriving Generic and Rep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the following, T, Tfun, and Targ are "meta-variables" ranging over type +expressions. + +(Generic T) and (Rep T) are derivable for some type expression T if the +following constraints are satisfied. + + (a) D is a type constructor *value*. In other words, D is either a type + constructor or it is equivalent to the head of a data family instance (up to + alpha-renaming). + + (b) D cannot have a "stupid context". + + (c) The right-hand side of D cannot include existential types, universally + quantified types, or "exotic" unlifted types. An exotic unlifted type + is one which is not listed in the definition of allowedUnliftedTy + (i.e., one for which we have no representation type). + See Note [Generics and unlifted types] + + (d) T :: *. + +(Generic1 T) and (Rep1 T) are derivable for some type expression T if the +following constraints are satisfied. + + (a),(b),(c) As above. + + (d) T must expect arguments, and its last parameter must have kind *. + + We use `a' to denote the parameter of D that corresponds to the last + parameter of T. + + (e) For any type-level application (Tfun Targ) in the right-hand side of D + where the head of Tfun is not a tuple constructor: + + (b1) `a' must not occur in Tfun. + + (b2) If `a' occurs in Targ, then Tfun :: * -> *. + +-} + +canDoGenerics :: TyCon -> Validity +-- canDoGenerics determines if Generic/Rep can be derived. +-- +-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken +-- care of because canDoGenerics is applied to rep tycons. +-- +-- It returns IsValid if deriving is possible. It returns (NotValid reason) +-- if not. +canDoGenerics tc + = mergeErrors ( + -- Check (b) from Note [Requirements for deriving Generic and Rep]. + (if (not (null (tyConStupidTheta tc))) + then (NotValid (tc_name <+> text "must not have a datatype context")) + else IsValid) + -- See comment below + : (map bad_con (tyConDataCons tc))) + where + -- The tc can be a representation tycon. When we want to display it to the + -- user (in an error message) we should print its parent + tc_name = ppr $ case tyConFamInst_maybe tc of + Just (ptc, _) -> ptc + _ -> tc + + -- Check (c) from Note [Requirements for deriving Generic and Rep]. + -- + -- If any of the constructors has an exotic unlifted type as argument, + -- then we can't build the embedding-projection pair, because + -- it relies on instantiating *polymorphic* sum and product types + -- at the argument types of the constructors + bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc)) + then (NotValid (ppr dc <+> text + "must not have exotic unlifted or polymorphic arguments")) + else (if (not (isVanillaDataCon dc)) + then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) + else IsValid) + + -- Nor can we do the job if it's an existential data constructor, + -- Nor if the args are polymorphic types (I don't think) + bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty)) + || not (isTauTy ty) + +-- Returns True the Type argument is an unlifted type which has a +-- corresponding generic representation type. For example, +-- (allowedUnliftedTy Int#) would return True since there is the UInt +-- representation type. +allowedUnliftedTy :: Type -> Bool +allowedUnliftedTy = isJust . unboxedRepRDRs + +mergeErrors :: [Validity] -> Validity +mergeErrors [] = IsValid +mergeErrors (NotValid s:t) = case mergeErrors t of + IsValid -> NotValid s + NotValid s' -> NotValid (s <> text ", and" $$ s') +mergeErrors (IsValid : t) = mergeErrors t + +-- A datatype used only inside of canDoGenerics1. It's the result of analysing +-- a type term. +data Check_for_CanDoGenerics1 = CCDG1 + { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in + -- this type? + , _ccdg1_errors :: Validity -- errors generated by this type + } + +{- + +Note [degenerate use of FFoldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We use foldDataConArgs here only for its ability to treat tuples +specially. foldDataConArgs also tracks covariance (though it assumes all +higher-order type parameters are covariant) and has hooks for special handling +of functions and polytypes, but we do *not* use those. + +The key issue is that Generic1 deriving currently offers no sophisticated +support for functions. For example, we cannot handle + + data F a = F ((a -> Int) -> Int) + +even though a is occurring covariantly. + +In fact, our rule is harsh: a is simply not allowed to occur within the first +argument of (->). We treat (->) the same as any other non-tuple tycon. + +Unfortunately, this means we have to track "the parameter occurs in this type" +explicitly, even though foldDataConArgs is also doing this internally. + +-} + +-- canDoGenerics1 determines if a Generic1/Rep1 can be derived. +-- +-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep] +-- are taken care of by the call to canDoGenerics. +-- +-- It returns IsValid if deriving is possible. It returns (NotValid reason) +-- if not. +canDoGenerics1 :: TyCon -> Validity +canDoGenerics1 rep_tc = + canDoGenerics rep_tc `andValid` additionalChecks + where + additionalChecks + -- check (d) from Note [Requirements for deriving Generic and Rep] + | null (tyConTyVars rep_tc) = NotValid $ + text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" + + | otherwise = mergeErrors $ concatMap check_con data_cons + + data_cons = tyConDataCons rep_tc + check_con con = case check_vanilla con of + j@(NotValid {}) -> [j] + IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con + + bad :: DataCon -> SDoc -> SDoc + bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg + + check_vanilla :: DataCon -> Validity + check_vanilla con | isVanillaDataCon con = IsValid + | otherwise = NotValid (bad con existential) + + bmzero = CCDG1 False IsValid + bmbad con s = CCDG1 True $ NotValid $ bad con s + bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) + + -- check (e) from Note [Requirements for deriving Generic and Rep] + -- See also Note [degenerate use of FFoldType] + ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 + ft_check con = FT + { ft_triv = bmzero + + , ft_var = caseVar, ft_co_var = caseVar + + -- (component_0,component_1,...,component_n) + , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) + then bmbad con wrong_arg + else foldr bmplus bmzero components + + -- (dom -> rng), where the head of ty is not a tuple tycon + , ft_fun = \dom rng -> -- cf #8516 + if _ccdg1_hasParam dom + then bmbad con wrong_arg + else bmplus dom rng + + -- (ty arg), where head of ty is neither (->) nor a tuple constructor and + -- the parameter of interest does not occur in ty + , ft_ty_app = \_ _ arg -> arg + + , ft_bad_app = bmbad con wrong_arg + , ft_forall = \_ body -> body -- polytypes are handled elsewhere + } + where + caseVar = CCDG1 True IsValid + + + existential = text "must not have existential arguments" + wrong_arg = text "applies a type to an argument involving the last parameter" + $$ text "but the applied type is not of kind * -> *" + +{- +************************************************************************ +* * +\subsection{Generating the RHS of a generic default method} +* * +************************************************************************ +-} + +type US = Int -- Local unique supply, just a plain Int +type Alt = (LPat GhcPs, LHsExpr GhcPs) + +-- GenericKind serves to mark if a datatype derives Generic (Gen0) or +-- Generic1 (Gen1). +data GenericKind = Gen0 | Gen1 + +-- as above, but with a payload of the TyCon's name for "the" parameter +data GenericKind_ = Gen0_ | Gen1_ TyVar + +-- as above, but using a single datacon's name for "the" parameter +data GenericKind_DC = Gen0_DC | Gen1_DC TyVar + +forgetArgVar :: GenericKind_DC -> GenericKind +forgetArgVar Gen0_DC = Gen0 +forgetArgVar Gen1_DC{} = Gen1 + +-- When working only within a single datacon, "the" parameter's name should +-- match that datacon's name for it. +gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC +gk2gkDC Gen0_ _ = Gen0_DC +gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d + + +-- Bindings for the Generic instance +mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs +mkBindsRep gk tycon = + unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) + `unionBags` + unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) + where + -- The topmost M1 (the datatype metadata) has the exact same type + -- across all cases of a from/to definition, and can be factored out + -- to save some allocations during typechecking. + -- See Note [Generics compilation speed tricks] + from_eqn = mkHsCaseAlt x_Pat $ mkM1_E + $ nlHsPar $ nlHsCase x_Expr from_matches + to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches + + from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + + (from01_RDR, to01_RDR) = case gk of + Gen0 -> (from_RDR, to_RDR) + Gen1 -> (from1_RDR, to1_RDR) + + -- Recurse over the sum first + from_alts, to_alts :: [Alt] + (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons + where gk_ = case gk of + Gen0 -> Gen0_ + Gen1 -> ASSERT(tyvars `lengthAtLeast` 1) + Gen1_ (last tyvars) + where tyvars = tyConTyVars tycon + +-------------------------------------------------------------------------------- +-- The type synonym instance and synonym +-- type instance Rep (D a b) = Rep_D a b +-- type Rep_D a b = ...representation type for D ... +-------------------------------------------------------------------------------- + +tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 + -> TyCon -- The type to generate representation for + -> [Type] -- The type(s) to which Generic(1) is applied + -- in the generated instance + -> TcM FamInst -- Generated representation0 coercion +tc_mkRepFamInsts gk tycon inst_tys = + -- Consider the example input tycon `D`, where data D a b = D_ a + -- Also consider `R:DInt`, where { data family D x y :: * -> * + -- ; data instance D Int a b = D_ a } + do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) + fam_tc <- case gk of + Gen0 -> tcLookupTyCon repTyConName + Gen1 -> tcLookupTyCon rep1TyConName + + ; fam_envs <- tcGetFamInstEnvs + + ; let -- If the derived instance is + -- instance Generic (Foo x) + -- then: + -- `arg_ki` = *, `inst_ty` = Foo x :: * + -- + -- If the derived instance is + -- instance Generic1 (Bar x :: k -> *) + -- then: + -- `arg_k` = k, `inst_ty` = Bar x :: k -> * + (arg_ki, inst_ty) = case (gk, inst_tys) of + (Gen0, [inst_t]) -> (liftedTypeKind, inst_t) + (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) + _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) + + ; let mbFamInst = tyConFamInst_maybe tycon + -- If we're examining a data family instance, we grab the parent + -- TyCon (ptc) and use it to determine the type arguments + -- (inst_args) for the data family *instance*'s type variables. + ptc = maybe tycon fst mbFamInst + (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd + $ tcSplitTyConApp inst_ty + + ; let -- `tyvars` = [a,b] + (tyvars, gk_) = case gk of + Gen0 -> (all_tyvars, Gen0_) + Gen1 -> ASSERT(not $ null all_tyvars) + (init all_tyvars, Gen1_ $ last all_tyvars) + where all_tyvars = tyConTyVars tycon + + -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + ; repTy <- tc_mkRepTy gk_ tycon arg_ki + + -- `rep_name` is a name we generate for the synonym + ; mod <- getModule + ; loc <- getSrcSpanM + ; let tc_occ = nameOccName (tyConName tycon) + rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ + ; rep_name <- newGlobalBinder mod rep_occ loc + + -- We make sure to substitute the tyvars with their user-supplied + -- type arguments before generating the Rep/Rep1 instance, since some + -- of the tyvars might have been instantiated when deriving. + -- See Note [Generating a correctly typed Rep instance]. + ; let (env_tyvars, env_inst_args) + = case gk_ of + Gen0_ -> (tyvars, inst_args) + Gen1_ last_tv + -- See the "wrinkle" in + -- Note [Generating a correctly typed Rep instance] + -> ( last_tv : tyvars + , anyTypeOfKind (tyVarKind last_tv) : inst_args ) + env = zipTyEnv env_tyvars env_inst_args + in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) + subst = mkTvSubst in_scope env + repTy' = substTyUnchecked subst repTy + tcv' = tyCoVarsOfTypeList inst_ty + (tv', cv') = partition isTyVar tcv' + tvs' = scopedSort tv' + cvs' = scopedSort cv' + axiom = mkSingleCoAxiom Nominal rep_name tvs' [] cvs' + fam_tc inst_tys repTy' + + ; newFamInst SynFamilyInst axiom } + +-------------------------------------------------------------------------------- +-- Type representation +-------------------------------------------------------------------------------- + +-- | See documentation of 'argTyFold'; that function uses the fields of this +-- type to interpret the structure of a type when that type is considered as an +-- argument to a constructor that is being represented with 'Rep1'. +data ArgTyAlg a = ArgTyAlg + { ata_rec0 :: (Type -> a) + , ata_par1 :: a, ata_rec1 :: (Type -> a) + , ata_comp :: (Type -> a -> a) + } + +-- | @argTyFold@ implements a generalised and safer variant of the @arg@ +-- function from Figure 3 in . @arg@ +-- is conceptually equivalent to: +-- +-- > arg t = case t of +-- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t +-- > App f [t'] | +-- > representable1 f && +-- > t' == argVar -> Rec1 f +-- > App f [t'] | +-- > representable1 f && +-- > t' has tyvars -> f :.: (arg t') +-- > _ -> Rec0 t +-- +-- where @argVar@ is the last type variable in the data type declaration we are +-- finding the representation for. +-- +-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to +-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and +-- @:.:@. +-- +-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for +-- some data types. The problematic case is when @t@ is an application of a +-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the +-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in +-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some +-- representable1 checks have been relaxed, and others were moved to +-- @canDoGenerics1@. +argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a +argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, + ata_par1 = mkPar1, ata_rec1 = mkRec1, + ata_comp = mkComp}) = + -- mkRec0 is the default; use it if there is no interesting structure + -- (e.g. occurrences of parameters or recursive occurrences) + \t -> maybe (mkRec0 t) id $ go t where + go :: Type -> -- type to fold through + Maybe a -- the result (e.g. representation type), unless it's trivial + go t = isParam `mplus` isApp where + + isParam = do -- handles parameters + t' <- getTyVar_maybe t + Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter + else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 + + isApp = do -- handles applications + (phi, beta) <- tcSplitAppTy_maybe t + + let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta + + -- Does it have no interesting structure to represent? + if not interesting then Nothing + else -- Is the argument the parameter? Special case for mkRec1. + if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi + else mkComp phi `fmap` go beta -- It must be a composition. + + +tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 + GenericKind_ + -- The type to generate representation for + -> TyCon + -- The kind of the representation type's argument + -- See Note [Handling kinds in a Rep instance] + -> Kind + -- Generated representation0 type + -> TcM Type +tc_mkRepTy gk_ tycon k = + do + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + rec0 <- tcLookupTyCon rec0TyConName + rec1 <- tcLookupTyCon rec1TyConName + par1 <- tcLookupTyCon par1TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName + times <- tcLookupTyCon prodTyConName + comp <- tcLookupTyCon compTyConName + uAddr <- tcLookupTyCon uAddrTyConName + uChar <- tcLookupTyCon uCharTyConName + uDouble <- tcLookupTyCon uDoubleTyConName + uFloat <- tcLookupTyCon uFloatTyConName + uInt <- tcLookupTyCon uIntTyConName + uWord <- tcLookupTyCon uWordTyConName + + let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon + + md <- tcLookupPromDataCon metaDataDataConName + mc <- tcLookupPromDataCon metaConsDataConName + ms <- tcLookupPromDataCon metaSelDataConName + pPrefix <- tcLookupPromDataCon prefixIDataConName + pInfix <- tcLookupPromDataCon infixIDataConName + pLA <- tcLookupPromDataCon leftAssociativeDataConName + pRA <- tcLookupPromDataCon rightAssociativeDataConName + pNA <- tcLookupPromDataCon notAssociativeDataConName + pSUpk <- tcLookupPromDataCon sourceUnpackDataConName + pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName + pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName + pSLzy <- tcLookupPromDataCon sourceLazyDataConName + pSStr <- tcLookupPromDataCon sourceStrictDataConName + pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName + pDLzy <- tcLookupPromDataCon decidedLazyDataConName + pDStr <- tcLookupPromDataCon decidedStrictDataConName + pDUpk <- tcLookupPromDataCon decidedUnpackDataConName + + fix_env <- getFixityEnv + + let mkSum' a b = mkTyConApp plus [k,a,b] + mkProd a b = mkTyConApp times [k,a,b] + mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a + mkRec1 a = mkTyConApp rec1 [k,a] + mkPar1 = mkTyConTy par1 + mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] + mkC a = mkTyConApp c1 [ k + , metaConsTy a + , prod (map scaledThing . dataConInstOrigArgTys a + . mkTyVarTys . tyConTyVars $ tycon) + (dataConSrcBangs a) + (dataConImplBangs a) + (dataConFieldLabels a)] + mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a] + + -- Sums and products are done in the same way for both Rep and Rep1 + sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l + -- The Bool is True if this constructor has labelled fields + prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type + prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k]) + [ ASSERT(null fl || lengthExceeds fl j) + arg t sb' ib' (if null fl + then Nothing + else Just (fl !! j)) + | (t,sb',ib',j) <- zip4 l sb ib [0..] ] + + arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type + arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of + -- Here we previously used Par0 if t was a type variable, but we + -- realized that we can't always guarantee that we are wrapping-up + -- all type variables in Par0. So we decided to stop using Par0 + -- altogether, and use Rec0 all the time. + Gen0_ -> mkRec0 t + Gen1_ argVar -> argPar argVar t + where + -- Builds argument representation for Rep1 (more complicated due to + -- the presence of composition). + argPar argVar = argTyFold argVar $ ArgTyAlg + {ata_rec0 = mkRec0, ata_par1 = mkPar1, + ata_rec1 = mkRec1, ata_comp = mkComp comp k} + + tyConName_user = case tyConFamInst_maybe tycon of + Just (ptycon, _) -> tyConName ptycon + Nothing -> tyConName tycon + + dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user + mdName = mkStrLitTy . moduleNameFS . moduleName + . nameModule . tyConName $ tycon + pkgName = mkStrLitTy . unitFS . moduleUnit + . nameModule . tyConName $ tycon + isNT = mkTyConTy $ if isNewTyCon tycon + then promotedTrueDataCon + else promotedFalseDataCon + + ctName = mkStrLitTy . occNameFS . nameOccName . dataConName + ctFix c + | dataConIsInfix c + = case lookupFixity fix_env (dataConName c) of + Fixity _ n InfixL -> buildFix n pLA + Fixity _ n InfixR -> buildFix n pRA + Fixity _ n InfixN -> buildFix n pNA + | otherwise = mkTyConTy pPrefix + buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc + , mkNumLitTy (fromIntegral n)] + + isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0 + then promotedTrueDataCon + else promotedFalseDataCon + + selName = mkStrLitTy . flLabel + + mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] + mbSel (Just s) = mkTyConApp promotedJustDataCon + [typeSymbolKind, selName s] + + metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] + metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] + metaSelTy mlbl su ss ib = + mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness] + where + pSUpkness = mkTyConTy $ case su of + SrcUnpack -> pSUpk + SrcNoUnpack -> pSNUpk + NoSrcUnpack -> pNSUpkness + + pSStrness = mkTyConTy $ case ss of + SrcLazy -> pSLzy + SrcStrict -> pSStr + NoSrcStrict -> pNSStrness + + pDStrness = mkTyConTy $ case ib of + HsLazy -> pDLzy + HsStrict -> pDStr + HsUnpack{} -> pDUpk + + return (mkD tycon) + +mkComp :: TyCon -> Kind -> Type -> Type -> Type +mkComp comp k f g + | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] + | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] + where + -- Which of these is the case? + -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- We want to instantiate with k1=k, and k2=* + -- Reason for k2=*: see Note [Handling kinds in a Rep instance] + -- But we need to know which way round! + k1_first = k_first == p_kind_var + [k_first,_,_,_,p] = tyConTyVars comp + Just p_kind_var = getTyVar_maybe (tyVarKind p) + +-- Given the TyCons for each URec-related type synonym, check to see if the +-- given type is an unlifted type that generics understands. If so, return +-- its representation type. Otherwise, return Rec0. +-- See Note [Generics and unlifted types] +mkBoxTy :: TyCon -- UAddr + -> TyCon -- UChar + -> TyCon -- UDouble + -> TyCon -- UFloat + -> TyCon -- UInt + -> TyCon -- UWord + -> TyCon -- Rec0 + -> Kind -- What to instantiate Rec0's kind variable with + -> Type + -> Type +mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty + | ty `eqType` addrPrimTy = mkTyConApp uAddr [k] + | ty `eqType` charPrimTy = mkTyConApp uChar [k] + | ty `eqType` doublePrimTy = mkTyConApp uDouble [k] + | ty `eqType` floatPrimTy = mkTyConApp uFloat [k] + | ty `eqType` intPrimTy = mkTyConApp uInt [k] + | ty `eqType` wordPrimTy = mkTyConApp uWord [k] + | otherwise = mkTyConApp rec0 [k,ty] + +-------------------------------------------------------------------------------- +-- Dealing with sums +-------------------------------------------------------------------------------- + +mkSum :: GenericKind_ -- Generic or Generic1? + -> US -- Base for generating unique names + -> [DataCon] -- The data constructors + -> ([Alt], -- Alternatives for the T->Trep "from" function + [Alt]) -- Alternatives for the Trep->T "to" function + +-- Datatype without any constructors +mkSum _ _ [] = ([from_alt], [to_alt]) + where + from_alt = (x_Pat, nlHsCase x_Expr []) + to_alt = (x_Pat, nlHsCase x_Expr []) + -- These M1s are meta-information for the datatype + +-- Datatype with at least one constructor +mkSum gk_ us datacons = + -- switch the payload of gk_ to be datacon-centric instead of tycon-centric + unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d + | (d,i) <- zip datacons [1..] ] + +-- Build the sum for a particular constructor +mk1Sum :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for generating unique names + -> Int -- The index of this constructor + -> Int -- Total number of constructors + -> DataCon -- The data constructor + -> (Alt, -- Alternative for the T->Trep "from" function + Alt) -- Alternative for the Trep->T "to" function +mk1Sum gk_ us i n datacon = (from_alt, to_alt) + where + gk = forgetArgVar gk_ + + -- Existentials already excluded + argTys = dataConOrigArgTys datacon + n_args = dataConSourceArity datacon + + datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) (map scaledThing argTys) + datacon_vars = map fst datacon_varTys + + datacon_rdr = getRdrName datacon + + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) + from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys) + + to_alt = ( genLR_P i n (mkProd_P gk datacon_varTys) + , to_alt_rhs + ) -- These M1s are meta-information for the datatype + to_alt_rhs = case gk_ of + Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars + Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys + where + argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where + converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = nlHsVar . unboxRepRDR, + ata_par1 = nlHsVar unPar1_RDR, + ata_rec1 = const $ nlHsVar unRec1_RDR, + ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) + `nlHsCompose` nlHsVar unComp1_RDR} + + +-- Generates the L1/R1 sum pattern +genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs +genLR_P i n p + | n == 0 = error "impossible" + | n == 1 = p + | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + where m = div n 2 + +-- Generates the L1/R1 sum expression +genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs +genLR_E i n e + | n == 0 = error "impossible" + | n == 1 = e + | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` + nlHsPar (genLR_E i (div n 2) e) + | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` + nlHsPar (genLR_E (i-m) (n-m) e) + where m = div n 2 + +-------------------------------------------------------------------------------- +-- Dealing with products +-------------------------------------------------------------------------------- + +-- Build a product expression +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> [(RdrName, Type)] + -- List of variables matched on the lhs and their types + -> LHsExpr GhcPs -- Resulting product expression +mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars) + -- These M1s are meta-information for the constructor + where + appVars = map (wrapArg_E gk_) varTys + prod a b = prodDataCon_RDR `nlHsApps` [a,b] + +wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs +wrapArg_E Gen0_DC (var, ty) = mkM1_E $ + boxRepRDR ty `nlHsVarApps` [var] + -- This M1 is meta-information for the selector +wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ + converter ty `nlHsApp` nlHsVar var + -- This M1 is meta-information for the selector + where converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = nlHsVar . boxRepRDR, + ata_par1 = nlHsVar par1DataCon_RDR, + ata_rec1 = const $ nlHsVar rec1DataCon_RDR, + ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` + (nlHsVar fmap_RDR `nlHsApp` cnv)} + +boxRepRDR :: Type -> RdrName +boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs + +unboxRepRDR :: Type -> RdrName +unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs + +-- Retrieve the RDRs associated with each URec data family instance +-- constructor. See Note [Generics and unlifted types] +unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) +unboxedRepRDRs ty + | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) + | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) + | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) + | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) + | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) + | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) + | otherwise = Nothing + +-- Build a product pattern +mkProd_P :: GenericKind -- Gen0 or Gen1 + -> [(RdrName, Type)] -- List of variables to match, + -- along with their types + -> LPat GhcPs -- Resulting product pattern +mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars) + -- These M1s are meta-information for the constructor + where + appVars = unzipWith (wrapArg_P gk) varTys + prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] + +wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs +wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) + -- This M1 is meta-information for the selector +wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] + +mkGenericLocal :: US -> RdrName +mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) + +x_RDR :: RdrName +x_RDR = mkVarUnqual (fsLit "x") + +x_Expr :: LHsExpr GhcPs +x_Expr = nlHsVar x_RDR + +x_Pat :: LPat GhcPs +x_Pat = nlVarPat x_RDR + +mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs +mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e + +mkM1_P :: LPat GhcPs -> LPat GhcPs +mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] + +nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsCompose x y = compose_RDR `nlHsApps` [x, y] + +-- | Variant of foldr for producing balanced lists +foldBal :: (a -> a -> a) -> a -> [a] -> a +foldBal _ x [] = x +foldBal _ _ [y] = y +foldBal op x l = let (a,b) = splitAt (length l `div` 2) l + in foldBal op x a `op` foldBal op x b + +{- +Note [Generics and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, all constants are marked with K1/Rec0. The exception to this rule is +when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In +that case, we must use a data family instance of URec (from GHC.Generics) to +mark it. As a result, before we can generate K1 or unK1, we must first check +to see if the type is actually one of the unlifted types for which URec has a +data family instance; if so, we generate that instead. + +See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more +details on why URec is implemented the way it is. + +Note [Generating a correctly typed Rep instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving +Generic(1). That is, it derives the ellipsis in the following: + + instance Generic Foo where + type Rep Foo = ... + +However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which +a Generic(1) instance is being derived, not the fully instantiated type. As a +result, tc_mkRepTy builds the most generalized Rep(1) instance possible using +the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This +can cause problems when the instance has instantiated type variables +(see #11732). As an example: + + data T a = MkT a + deriving instance Generic (T Int) + ==> + instance Generic (T Int) where + type Rep (T Int) = (... (Rec0 a)) -- wrong! + +-XStandaloneDeriving is one way for the type variables to become instantiated. +Another way is when Generic1 is being derived for a datatype with a visible +kind binder, e.g., + + data P k (a :: k) = MkP k deriving Generic1 + ==> + instance Generic1 (P *) where + type Rep1 (P *) = (... (Rec0 k)) -- wrong! + +See Note [Unify kinds in deriving] in GHC.Tc.Deriv. + +In any such scenario, we must prevent a discrepancy between the LHS and RHS of +a Rep(1) instance. To do so, we create a type variable substitution that maps +the tyConTyVars of the TyCon to their counterparts in the fully instantiated +type. (For example, using T above as example, you'd map a :-> Int.) We then +apply the substitution to the RHS before generating the instance. + +A wrinkle in all of this: when forming the type variable substitution for +Generic1 instances, we map the last type variable of the tycon to Any. Why? +It's because of wily data types like this one (#15012): + + data T a = MkT (FakeOut a) + type FakeOut a = Int + +If we ignore a, then we'll produce the following Rep1 instance: + + instance Generic1 T where + type Rep1 T = ... (Rec0 (FakeOut a)) + ... + +Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we +ensure that `a` is mapped to Any: + + instance Generic1 T where + type Rep1 T = ... (Rec0 (FakeOut Any)) + ... + +And now all is good. + +Alternatively, we could have avoided this problem by expanding all type +synonyms on the RHSes of Rep1 instances. But we might blow up the size of +these types even further by doing this, so we choose not to do so. + +Note [Handling kinds in a Rep instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because Generic1 is poly-kinded, the representation types were generalized to +be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply +the kind of the instance being derived to all the representation type +constructors. For instance, if you have + + data Empty (a :: k) = Empty deriving Generic1 + +Then the generated code is now approximately (with -fprint-explicit-kinds +syntax): + + instance Generic1 k (Empty k) where + type Rep1 k (Empty k) = U1 k + +Most representation types have only one kind variable, making them easy to deal +with. The only non-trivial case is (:.:), which is only used in Generic1 +instances: + + newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = + Comp1 { unComp1 :: f (g p) } + +Here, we do something a bit counter-intuitive: we make k1 be the kind of the +instance being derived, and we always make k2 be *. Why *? It's because +the code that GHC generates using (:.:) is always of the form x :.: Rec1 y +for some types x and y. In other words, the second type to which (:.:) is +applied always has kind k -> *, for some kind k, so k2 cannot possibly be +anything other than * in a generated Generic1 instance. + +Note [Generics compilation speed tricks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deriving Generic(1) is known to have a large constant factor during +compilation, which contributes to noticeable compilation slowdowns when +deriving Generic(1) for large datatypes (see #5642). + +To ease the pain, there is a trick one can play when generating definitions for +to(1) and from(1). If you have a datatype like: + + data Letter = A | B | C | D + +then a naïve Generic instance for Letter would be: + + instance Generic Letter where + type Rep Letter = D1 ('MetaData ...) ... + + to (M1 (L1 (L1 (M1 U1)))) = A + to (M1 (L1 (R1 (M1 U1)))) = B + to (M1 (R1 (L1 (M1 U1)))) = C + to (M1 (R1 (R1 (M1 U1)))) = D + + from A = M1 (L1 (L1 (M1 U1))) + from B = M1 (L1 (R1 (M1 U1))) + from C = M1 (R1 (L1 (M1 U1))) + from D = M1 (R1 (R1 (M1 U1))) + +Notice that in every LHS pattern-match of the 'to' definition, and in every RHS +expression in the 'from' definition, the topmost constructor is M1. This +corresponds to the datatype-specific metadata (the D1 in the Rep Letter +instance). But this is wasteful from a typechecking perspective, since this +definition requires GHC to typecheck an application of M1 in every single case, +leading to an O(n) increase in the number of coercions the typechecker has to +solve, which in turn increases allocations and degrades compilation speed. + +Luckily, since the topmost M1 has the exact same type across every case, we can +factor it out reduce the typechecker's burden: + + instance Generic Letter where + type Rep Letter = D1 ('MetaData ...) ... + + to (M1 x) = case x of + L1 (L1 (M1 U1)) -> A + L1 (R1 (M1 U1)) -> B + R1 (L1 (M1 U1)) -> C + R1 (R1 (M1 U1)) -> D + + from x = M1 (case x of + A -> L1 (L1 (M1 U1)) + B -> L1 (R1 (M1 U1)) + C -> R1 (L1 (M1 U1)) + D -> R1 (R1 (M1 U1))) + +A simple change, but one that pays off, since it goes turns an O(n) amount of +coercions to an O(1) amount. +-} diff --git a/GHC/Tc/Deriv/Infer.hs b/GHC/Tc/Deriv/Infer.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Infer.hs @@ -0,0 +1,1081 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Functions for inferring (and simplifying) the context for derived instances. +module GHC.Tc.Deriv.Infer + ( inferConstraints + , simplifyInstanceContexts + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Utils.Error +import GHC.Tc.Utils.Instantiate +import GHC.Utils.Outputable +import GHC.Data.Pair +import GHC.Builtin.Names +import GHC.Tc.Deriv.Utils +import GHC.Tc.Utils.Env +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr (pprTyVars) +import GHC.Core.Type +import GHC.Tc.Solver +import GHC.Tc.Validity (validDerivPred) +import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints) +import GHC.Builtin.Types (typeToTypeKind) +import GHC.Core.Unify (tcUnifyTy) +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Set + +import Control.Monad +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ask) +import Data.List (sortBy) +import Data.Maybe + +---------------------- + +inferConstraints :: DerivSpecMechanism + -> DerivM ([ThetaOrigin], [TyVar], [TcType]) +-- inferConstraints figures out the constraints needed for the +-- instance declaration generated by a 'deriving' clause on a +-- data type declaration. It also returns the new in-scope type +-- variables and instance types, in case they were changed due to +-- the presence of functor-like constraints. +-- See Note [Inferring the instance context] + +-- e.g. inferConstraints +-- C Int (T [a]) -- Class and inst_tys +-- :RTList a -- Rep tycon and its arg tys +-- where T [a] ~R :RTList a +-- +-- Generate a sufficiently large set of constraints that typechecking the +-- generated method definitions should succeed. This set will be simplified +-- before being used in the instance declaration +inferConstraints mechanism + = do { DerivEnv { denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys } <- ask + ; wildcard <- isStandaloneWildcardDeriv + ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType]) + infer_constraints = + case mechanism of + DerivSpecStock{dsm_stock_dit = dit} + -> inferConstraintsStock dit + DerivSpecAnyClass + -> infer_constraints_simple inferConstraintsAnyclass + DerivSpecNewtype { dsm_newtype_dit = + DerivInstTys{dit_cls_tys = cls_tys} + , dsm_newtype_rep_ty = rep_ty } + -> infer_constraints_simple $ + inferConstraintsCoerceBased cls_tys rep_ty + DerivSpecVia { dsm_via_cls_tys = cls_tys + , dsm_via_ty = via_ty } + -> infer_constraints_simple $ + inferConstraintsCoerceBased cls_tys via_ty + + -- Most deriving strategies do not need to do anything special to + -- the type variables and arguments to the class in the derived + -- instance, so they can pass through unchanged. The exception to + -- this rule is stock deriving. See + -- Note [Inferring the instance context]. + infer_constraints_simple + :: DerivM [ThetaOrigin] + -> DerivM ([ThetaOrigin], [TyVar], [TcType]) + infer_constraints_simple infer_thetas = do + thetas <- infer_thetas + pure (thetas, tvs, inst_tys) + + -- Constraints arising from superclasses + -- See Note [Superclasses of derived instance] + cls_tvs = classTyVars main_cls + sc_constraints = ASSERT2( equalLength cls_tvs inst_tys + , ppr main_cls <+> ppr inst_tys ) + [ mkThetaOrigin (mkDerivOrigin wildcard) + TypeLevel [] [] [] $ + substTheta cls_subst (classSCTheta main_cls) ] + cls_subst = ASSERT( equalLength cls_tvs inst_tys ) + zipTvSubst cls_tvs inst_tys + + ; (inferred_constraints, tvs', inst_tys') <- infer_constraints + ; lift $ traceTc "inferConstraints" $ vcat + [ ppr main_cls <+> ppr inst_tys' + , ppr inferred_constraints + ] + ; return ( sc_constraints ++ inferred_constraints + , tvs', inst_tys' ) } + +-- | Like 'inferConstraints', but used only in the case of the @stock@ deriving +-- strategy. The constraints are inferred by inspecting the fields of each data +-- constructor. In this example: +-- +-- > data Foo = MkFoo Int Char deriving Show +-- +-- We would infer the following constraints ('ThetaOrigin's): +-- +-- > (Show Int, Show Char) +-- +-- Note that this function also returns the type variables ('TyVar's) and +-- class arguments ('TcType's) for the resulting instance. This is because +-- when deriving 'Functor'-like classes, we must sometimes perform kind +-- substitutions to ensure the resulting instance is well kinded, which may +-- affect the type variables and class arguments. In this example: +-- +-- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) = +-- > Compose (f (g a)) deriving stock Functor +-- +-- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance +-- to be well kinded, so we return @[]@/@[Type, f, g]@ for the +-- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. +-- See Note [Inferring the instance context]. +inferConstraintsStock :: DerivInstTys + -> DerivM ([ThetaOrigin], [TyVar], [TcType]) +inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys + , dit_tc = tc + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args }) + = do DerivEnv { denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys } <- ask + wildcard <- isStandaloneWildcardDeriv + + let inst_ty = mkTyConApp tc tc_args + tc_binders = tyConBinders rep_tc + choose_level bndr + | isNamedTyConBinder bndr = KindLevel + | otherwise = TypeLevel + t_or_ks = map choose_level tc_binders ++ repeat TypeLevel + -- want to report *kind* errors when possible + + -- Constraints arising from the arguments of each constructor + con_arg_constraints + :: (CtOrigin -> TypeOrKind + -> Type + -> [([PredOrigin], Maybe TCvSubst)]) + -> ([ThetaOrigin], [TyVar], [TcType]) + con_arg_constraints get_arg_constraints + = let (predss, mbSubsts) = unzip + [ preds_and_mbSubst + | data_con <- tyConDataCons rep_tc + , (arg_n, arg_t_or_k, arg_ty) + <- zip3 [1..] t_or_ks $ + dataConInstOrigArgTys data_con all_rep_tc_args + -- No constraints for unlifted types + -- See Note [Deriving and unboxed types] + , not (isUnliftedType (irrelevantMult arg_ty)) + , let orig = DerivOriginDC data_con arg_n wildcard + , preds_and_mbSubst + <- get_arg_constraints orig arg_t_or_k (irrelevantMult arg_ty) + ] + preds = concat predss + -- If the constraints require a subtype to be of kind + -- (* -> *) (which is the case for functor-like + -- constraints), then we explicitly unify the subtype's + -- kinds with (* -> *). + -- See Note [Inferring the instance context] + subst = foldl' composeTCvSubst + emptyTCvSubst (catMaybes mbSubsts) + unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst + && not (v `isInScope` subst)) tvs + (subst', _) = substTyVarBndrs subst unmapped_tvs + preds' = map (substPredOrigin subst') preds + inst_tys' = substTys subst' inst_tys + tvs' = tyCoVarsOfTypesWellScoped inst_tys' + in ([mkThetaOriginFromPreds preds'], tvs', inst_tys') + + is_generic = main_cls `hasKey` genClassKey + is_generic1 = main_cls `hasKey` gen1ClassKey + -- is_functor_like: see Note [Inferring the instance context] + is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind + || is_generic1 + + get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type + -> [([PredOrigin], Maybe TCvSubst)] + get_gen1_constraints functor_cls orig t_or_k ty + = mk_functor_like_constraints orig t_or_k functor_cls $ + get_gen1_constrained_tys last_tv ty + + get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type + -> [([PredOrigin], Maybe TCvSubst)] + get_std_constrained_tys orig t_or_k ty + | is_functor_like + = mk_functor_like_constraints orig t_or_k main_cls $ + deepSubtypesContaining last_tv ty + | otherwise + = [( [mk_cls_pred orig t_or_k main_cls ty] + , Nothing )] + + mk_functor_like_constraints :: CtOrigin -> TypeOrKind + -> Class -> [Type] + -> [([PredOrigin], Maybe TCvSubst)] + -- 'cls' is usually main_cls (Functor or Traversable etc), but if + -- main_cls = Generic1, then 'cls' can be Functor; see + -- get_gen1_constraints + -- + -- For each type, generate two constraints, + -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results + -- from unifying kind(ty) with * -> *. If the unification is + -- successful, it will ensure that the resulting instance is well + -- kinded. If not, the second constraint will result in an error + -- message which points out the kind mismatch. + -- See Note [Inferring the instance context] + mk_functor_like_constraints orig t_or_k cls + = map $ \ty -> let ki = tcTypeKind ty in + ( [ mk_cls_pred orig t_or_k cls ty + , mkPredOrigin orig KindLevel + (mkPrimEqPred ki typeToTypeKind) ] + , tcUnifyTy ki typeToTypeKind + ) + + rep_tc_tvs = tyConTyVars rep_tc + last_tv = last rep_tc_tvs + -- When we first gather up the constraints to solve, most of them + -- contain rep_tc_tvs, i.e., the type variables from the derived + -- datatype's type constructor. We don't want these type variables + -- to appear in the final instance declaration, so we must + -- substitute each type variable with its counterpart in the derived + -- instance. rep_tc_args lists each of these counterpart types in + -- the same order as the type variables. + all_rep_tc_args + = rep_tc_args ++ map mkTyVarTy + (drop (length rep_tc_args) rep_tc_tvs) + + -- Stupid constraints + stupid_constraints + = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $ + substTheta tc_subst (tyConStupidTheta rep_tc) ] + tc_subst = -- See the comment with all_rep_tc_args for an + -- explanation of this assertion + ASSERT( equalLength rep_tc_tvs all_rep_tc_args ) + zipTvSubst rep_tc_tvs all_rep_tc_args + + -- Extra Data constraints + -- The Data class (only) requires that for + -- instance (...) => Data (T t1 t2) + -- IF t1:*, t2:* + -- THEN (Data t1, Data t2) are among the (...) constraints + -- Reason: when the IF holds, we generate a method + -- dataCast2 f = gcast2 f + -- and we need the Data constraints to typecheck the method + extra_constraints = [mkThetaOriginFromPreds constrs] + where + constrs + | main_cls `hasKey` dataClassKey + , all (isLiftedTypeKind . tcTypeKind) rep_tc_args + = [ mk_cls_pred deriv_origin t_or_k main_cls ty + | (t_or_k, ty) <- zip t_or_ks rep_tc_args] + | otherwise + = [] + + mk_cls_pred orig t_or_k cls ty + -- Don't forget to apply to cls_tys' too + = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty])) + cls_tys' | is_generic1 = [] + -- In the awkward Generic1 case, cls_tys' should be + -- empty, since we are applying the class Functor. + + | otherwise = cls_tys + + deriv_origin = mkDerivOrigin wildcard + + if -- Generic constraints are easy + | is_generic + -> return ([], tvs, inst_tys) + + -- Generic1 needs Functor + -- See Note [Getting base classes] + | is_generic1 + -> ASSERT( rep_tc_tvs `lengthExceeds` 0 ) + -- Generic1 has a single kind variable + ASSERT( cls_tys `lengthIs` 1 ) + do { functorClass <- lift $ tcLookupClass functorClassName + ; pure $ con_arg_constraints + $ get_gen1_constraints functorClass } + + -- The others are a bit more complicated + | otherwise + -> -- See the comment with all_rep_tc_args for an explanation of + -- this assertion + ASSERT2( equalLength rep_tc_tvs all_rep_tc_args + , ppr main_cls <+> ppr rep_tc + $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args ) + do { let (arg_constraints, tvs', inst_tys') + = con_arg_constraints get_std_constrained_tys + ; lift $ traceTc "inferConstraintsStock" $ vcat + [ ppr main_cls <+> ppr inst_tys' + , ppr arg_constraints + ] + ; return ( stupid_constraints ++ extra_constraints + ++ arg_constraints + , tvs', inst_tys') } + +-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, +-- which gathers its constraints based on the type signatures of the class's +-- methods instead of the types of the data constructor's field. +-- +-- See Note [Gathering and simplifying constraints for DeriveAnyClass] +-- for an explanation of how these constraints are used to determine the +-- derived instance context. +inferConstraintsAnyclass :: DerivM [ThetaOrigin] +inferConstraintsAnyclass + = do { DerivEnv { denv_cls = cls + , denv_inst_tys = inst_tys } <- ask + ; wildcard <- isStandaloneWildcardDeriv + + ; let gen_dms = [ (sel_id, dm_ty) + | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] + + cls_tvs = classTyVars cls + + do_one_meth :: (Id, Type) -> TcM ThetaOrigin + -- (Id,Type) are the selector Id and the generic default method type + -- NB: the latter is /not/ quantified over the class variables + -- See Note [Gathering and simplifying constraints for DeriveAnyClass] + do_one_meth (sel_id, gen_dm_ty) + = do { let (sel_tvs, _cls_pred, meth_ty) + = tcSplitMethodTy (varType sel_id) + meth_ty' = substTyWith sel_tvs inst_tys meth_ty + (meth_tvs, meth_theta, meth_tau) + = tcSplitNestedSigmaTys meth_ty' + + gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty + (dm_tvs, dm_theta, dm_tau) + = tcSplitNestedSigmaTys gen_dm_ty' + tau_eq = mkPrimEqPred meth_tau dm_tau + ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel + meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } + + ; theta_origins <- lift $ mapM do_one_meth gen_dms + ; return theta_origins } + +-- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and +-- @DerivingVia@. Since both strategies generate code involving 'coerce', the +-- inferred constraints set up the scaffolding needed to typecheck those uses +-- of 'coerce'. In this example: +-- +-- > newtype Age = MkAge Int deriving newtype Num +-- +-- We would infer the following constraints ('ThetaOrigin's): +-- +-- > (Num Int, Coercible Age Int) +inferConstraintsCoerceBased :: [Type] -> Type + -> DerivM [ThetaOrigin] +inferConstraintsCoerceBased cls_tys rep_ty = do + DerivEnv { denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys } <- ask + sa_wildcard <- isStandaloneWildcardDeriv + let -- The following functions are polymorphic over the representation + -- type, since we might either give it the underlying type of a + -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type + -- (for DerivingVia). + rep_tys ty = cls_tys ++ [ty] + rep_pred ty = mkClassPred cls (rep_tys ty) + rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty) + -- rep_pred is the representation dictionary, from where + -- we are going to get all the methods for the final + -- dictionary + deriv_origin = mkDerivOrigin sa_wildcard + + -- Next we collect constraints for the class methods + -- If there are no methods, we don't need any constraints + -- Otherwise we need (C rep_ty), for the representation methods, + -- and constraints to coerce each individual method + meth_preds :: Type -> [PredOrigin] + meth_preds ty + | null meths = [] -- No methods => no constraints + -- (#12814) + | otherwise = rep_pred_o ty : coercible_constraints ty + meths = classMethods cls + coercible_constraints ty + = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard) + TypeLevel (mkReprPrimEqPred t1 t2) + | meth <- meths + , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs + inst_tys ty meth ] + + all_thetas :: Type -> [ThetaOrigin] + all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty] + + pure (all_thetas rep_ty) + +{- Note [Inferring the instance context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two sorts of 'deriving', as represented by the two constructors +for DerivContext: + + * InferContext mb_wildcard: This can either be: + - The deriving clause for a data type. + (e.g, data T a = T1 a deriving( Eq )) + In this case, mb_wildcard = Nothing. + - A standalone declaration with an extra-constraints wildcard + (e.g., deriving instance _ => Eq (Foo a)) + In this case, mb_wildcard = Just loc, where loc is the location + of the extra-constraints wildcard. + + Here we must infer an instance context, + and generate instance declaration + instance Eq a => Eq (T a) where ... + + * SupplyContext theta: standalone deriving + deriving instance Eq a => Eq (T a) + Here we only need to fill in the bindings; + the instance context (theta) is user-supplied + +For the InferContext case, we must figure out the +instance context (inferConstraintsStock). Suppose we are inferring +the instance context for + C t1 .. tn (T s1 .. sm) +There are two cases + + * (T s1 .. sm) :: * (the normal case) + Then we behave like Eq and guess (C t1 .. tn t) + for each data constructor arg of type t. More + details below. + + * (T s1 .. sm) :: * -> * (the functor-like case) + Then we behave like Functor. + +In both cases we produce a bunch of un-simplified constraints +and them simplify them in simplifyInstanceContexts; see +Note [Simplifying the instance context]. + +In the functor-like case, we may need to unify some kind variables with * in +order for the generated instance to be well-kinded. An example from +#10524: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) + = Compose (f (g a)) deriving Functor + +Earlier in the deriving pipeline, GHC unifies the kind of Compose f g +(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this +alone isn't enough, since k2 wasn't unified with *: + + instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) => + Functor (Compose f g) where ... + +The two Functor constraints are ill-kinded. To ensure this doesn't happen, we: + + 1. Collect all of a datatype's subtypes which require functor-like + constraints. + 2. For each subtype, create a substitution by unifying the subtype's kind + with (* -> *). + 3. Compose all the substitutions into one, then apply that substitution to + all of the in-scope type variables and the instance types. + +Note [Getting base classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Typeable are defined in package 'base', and that is not available +when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in +ghc-prim does not use Functor or Typeable implicitly via these lookups. + +Note [Deriving and unboxed types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have some special hacks to support things like + data T = MkT Int# deriving ( Show ) + +Specifically, we use GHC.Tc.Deriv.Generate.box to box the Int# into an Int +(which we know how to show), and append a '#'. Parentheses are not required +for unboxed values (`MkT -3#` is a valid expression). + +Note [Superclasses of derived instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a derived instance decl needs the superclasses of the derived +class too. So if we have + data T a = ...deriving( Ord ) +then the initial context for Ord (T a) should include Eq (T a). Often this is +redundant; we'll also generate an Ord constraint for each constructor argument, +and that will probably generate enough constraints to make the Eq (T a) constraint +be satisfied too. But not always; consider: + + data S a = S + instance Eq (S a) + instance Ord (S a) + + data T a = MkT (S a) deriving( Ord ) + instance Num a => Eq (T a) + +The derived instance for (Ord (T a)) must have a (Num a) constraint! +Similarly consider: + data T a = MkT deriving( Data ) +Here there *is* no argument field, but we must nevertheless generate +a context for the Data instances: + instance Typeable a => Data (T a) where ... + + +************************************************************************ +* * + Finding the fixed point of deriving equations +* * +************************************************************************ + +Note [Simplifying the instance context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T a b = C1 (Foo a) (Bar b) + | C2 Int (T b a) + | C3 (T a a) + deriving (Eq) + +We want to come up with an instance declaration of the form + + instance (Ping a, Pong b, ...) => Eq (T a b) where + x == y = ... + +It is pretty easy, albeit tedious, to fill in the code "...". The +trick is to figure out what the context for the instance decl is, +namely Ping, Pong and friends. + +Let's call the context reqd for the T instance of class C at types +(a,b, ...) C (T a b). Thus: + + Eq (T a b) = (Ping a, Pong b, ...) + +Now we can get a (recursive) equation from the data decl. This part +is done by inferConstraintsStock. + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + +Foo and Bar may have explicit instances for Eq, in which case we can +just substitute for them. Alternatively, either or both may have +their Eq instances given by deriving clauses, in which case they +form part of the system of equations. + +Now all we need do is simplify and solve the equations, iterating to +find the least fixpoint. This is done by simplifyInstanceConstraints. +Notice that the order of the arguments can +switch around, as here in the recursive calls to T. + +Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. + +We start with: + + Eq (T a b) = {} -- The empty set + +Next iteration: + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b u {} u {} u {} + = Eq a u Ping b + +Next iteration: + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b + u (Eq b u Ping a) + u (Eq a u Ping a) + + = Eq a u Ping b u Eq b u Ping a + +The next iteration gives the same result, so this is the fixpoint. We +need to make a canonical form of the RHS to ensure convergence. We do +this by simplifying the RHS to a form in which + + - the classes constrain only tyvars + - the list is sorted by tyvar (major key) and then class (minor key) + - no duplicates, of course + +Note [Deterministic simplifyInstanceContexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting +with nonDetCmpType puts the returned lists in a nondeterministic order. +If we were to return them, we'd get class constraints in +nondeterministic order. + +Consider: + + data ADT a b = Z a b deriving Eq + +The generated code could be either: + + instance (Eq a, Eq b) => Eq (Z a b) where + +Or: + + instance (Eq b, Eq a) => Eq (Z a b) where + +To prevent the order from being nondeterministic we only +canonicalize when comparing and return them in the same order as +simplifyDeriv returned them. +See also Note [nonDetCmpType nondeterminism] +-} + + +simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]] + -> TcM [DerivSpec ThetaType] +-- Used only for deriving clauses or standalone deriving with an +-- extra-constraints wildcard (InferContext) +-- See Note [Simplifying the instance context] + +simplifyInstanceContexts [] = return [] + +simplifyInstanceContexts infer_specs + = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs) + ; iterate_deriv 1 initial_solutions } + where + ------------------------------------------------------------------ + -- The initial solutions for the equations claim that each + -- instance has an empty context; this solution is certainly + -- in canonical form. + initial_solutions :: [ThetaType] + initial_solutions = [ [] | _ <- infer_specs ] + + ------------------------------------------------------------------ + -- iterate_deriv calculates the next batch of solutions, + -- compares it with the current one; finishes if they are the + -- same, otherwise recurses with the new solutions. + -- It fails if any iteration fails + iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] + iterate_deriv n current_solns + | n > 20 -- Looks as if we are in an infinite loop + -- This can happen if we have -XUndecidableInstances + -- (See GHC.Tc.Solver.tcSimplifyDeriv.) + = pprPanic "solveDerivEqns: probable loop" + (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) + | otherwise + = do { -- Extend the inst info from the explicit instance decls + -- with the current set of solutions, and simplify each RHS + inst_specs <- zipWithM newDerivClsInst current_solns infer_specs + ; new_solns <- checkNoErrs $ + extendLocalInstEnv inst_specs $ + mapM gen_soln infer_specs + + ; if (current_solns `eqSolution` new_solns) then + return [ spec { ds_theta = soln } + | (spec, soln) <- zip infer_specs current_solns ] + else + iterate_deriv (n+1) new_solns } + + eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) + -- Canonicalise for comparison + -- See Note [Deterministic simplifyInstanceContexts] + canSolution = map (sortBy nonDetCmpType) + ------------------------------------------------------------------ + gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType + gen_soln (DS { ds_loc = loc, ds_tvs = tyvars + , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) + = setSrcSpan loc $ + addErrCtxt (derivInstCtxt the_pred) $ + do { theta <- simplifyDeriv the_pred tyvars deriv_rhs + -- checkValidInstance tyvars theta clas inst_tys + -- Not necessary; see Note [Exotic derived instance contexts] + + ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr theta) + -- Claim: the result instance declaration is guaranteed valid + -- Hence no need to call: + -- checkValidInstance tyvars theta clas inst_tys + ; return theta } + where + the_pred = mkClassPred clas inst_tys + +derivInstCtxt :: PredType -> MsgDoc +derivInstCtxt pred + = text "When deriving the instance for" <+> parens (ppr pred) + +{- +*********************************************************************************** +* * +* Simplify derived constraints +* * +*********************************************************************************** +-} + +-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much +-- as possible. Fail if not possible. +simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are + -- deriving. Only used for SkolemInfo. + -> [TyVar] -- ^ The tyvars bound by @inst_ty@. + -> [ThetaOrigin] -- ^ Given and wanted constraints + -> TcM ThetaType -- ^ Needed constraints (after simplification), + -- i.e. @['PredType']@. +simplifyDeriv pred tvs thetas + = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + -- The constraint solving machinery + -- expects *TcTyVars* not TyVars. + -- We use *non-overlappable* (vanilla) skolems + -- See Note [Overlap and deriving] + + ; let skol_set = mkVarSet tvs_skols + skol_info = DerivSkol pred + doc = text "deriving" <+> parens (ppr pred) + + mk_given_ev :: PredType -> TcM EvVar + mk_given_ev given = + let given_pred = substTy skol_subst given + in newEvVar given_pred + + emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM () + emit_wanted_constraints metas_to_be preds + = do { -- We instantiate metas_to_be with fresh meta type + -- variables. Currently, these can only be type variables + -- quantified in generic default type signatures. + -- See Note [Gathering and simplifying constraints for + -- DeriveAnyClass] + (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be + + -- Now make a constraint for each of the instantiated predicates + ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst + mk_wanted_ct (PredOrigin wanted orig t_or_k) + = do { ev <- newWanted orig (Just t_or_k) $ + substTyUnchecked wanted_subst wanted + ; return (mkNonCanonical ev) } + ; cts <- mapM mk_wanted_ct preds + + -- And emit them into the monad + ; emitSimples (listToCts cts) } + + -- Create the implications we need to solve. For stock and newtype + -- deriving, these implication constraints will be simple class + -- constraints like (C a, Ord b). + -- But with DeriveAnyClass, we make an implication constraint. + -- See Note [Gathering and simplifying constraints for DeriveAnyClass] + mk_wanteds :: ThetaOrigin -> TcM WantedConstraints + mk_wanteds (ThetaOrigin { to_anyclass_skols = ac_skols + , to_anyclass_metas = ac_metas + , to_anyclass_givens = ac_givens + , to_wanted_origins = preds }) + = do { ac_given_evs <- mapM mk_given_ev ac_givens + ; (_, wanteds) + <- captureConstraints $ + checkConstraints skol_info ac_skols ac_given_evs $ + -- The checkConstraints bumps the TcLevel, and + -- wraps the wanted constraints in an implication, + -- when (but only when) necessary + emit_wanted_constraints ac_metas preds + ; pure wanteds } + + -- See [STEP DAC BUILD] + -- Generate the implication constraints, one for each method, to solve + -- with the skolemized variables. Start "one level down" because + -- we are going to wrap the result in an implication with tvs_skols, + -- in step [DAC RESIDUAL] + ; (tc_lvl, wanteds) <- pushTcLevelM $ + mapM mk_wanteds thetas + + ; traceTc "simplifyDeriv inputs" $ + vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ] + + -- See [STEP DAC SOLVE] + -- Simplify the constraints, starting at the same level at which + -- they are generated (c.f. the call to runTcSWithEvBinds in + -- simplifyInfer) + ; solved_wanteds <- setTcLevel tc_lvl $ + runTcSDeriveds $ + solveWantedsAndDrop $ + unionsWC wanteds + + -- It's not yet zonked! Obviously zonk it before peering at it + ; solved_wanteds <- zonkWC solved_wanteds + + -- See [STEP DAC HOIST] + -- From the simplified constraints extract a subset 'good' that will + -- become the context 'min_theta' for the derived instance. + ; let residual_simple = approximateWC True solved_wanteds + good = mapMaybeBag get_good residual_simple + + -- Returns @Just p@ (where @p@ is the type of the Ct) if a Ct is + -- suitable to be inferred in the context of a derived instance. + -- Returns @Nothing@ if the Ct is too exotic. + -- See Note [Exotic derived instance contexts] for what + -- constitutes an exotic constraint. + get_good :: Ct -> Maybe PredType + get_good ct | validDerivPred skol_set p + , isWantedCt ct + = Just p + -- TODO: This is wrong + -- NB re 'isWantedCt': residual_wanted may contain + -- unsolved CtDerived and we stick them into the + -- bad set so that reportUnsolved may decide what + -- to do with them + | otherwise + = Nothing + where p = ctPred ct + + ; traceTc "simplifyDeriv outputs" $ + vcat [ ppr tvs_skols, ppr residual_simple, ppr good ] + + -- Return the good unsolved constraints (unskolemizing on the way out.) + ; let min_theta = mkMinimalBySCs id (bagToList good) + -- An important property of mkMinimalBySCs (used above) is that in + -- addition to removing constraints that are made redundant by + -- superclass relationships, it also removes _duplicate_ + -- constraints. + -- See Note [Gathering and simplifying constraints for + -- DeriveAnyClass] + subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs + -- The reverse substitution (sigh) + + -- See [STEP DAC RESIDUAL] + -- Ensure that min_theta is enough to solve /all/ the constraints in + -- solved_wanteds, by solving the implication constraint + -- + -- forall tvs. min_theta => solved_wanteds + ; min_theta_vars <- mapM newEvVar min_theta + ; (leftover_implic, _) + <- buildImplicationFor tc_lvl skol_info tvs_skols + min_theta_vars solved_wanteds + -- This call to simplifyTop is purely for error reporting + -- See Note [Error reporting for deriving clauses] + -- See also Note [Exotic derived instance contexts], which are caught + -- in this line of code. + ; simplifyTopImplic leftover_implic + + ; return (substTheta subst_skol min_theta) } + +{- +Note [Overlap and deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider some overlapping instances: + instance Show a => Show [a] where .. + instance Show [Char] where ... + +Now a data type with deriving: + data T a = MkT [a] deriving( Show ) + +We want to get the derived instance + instance Show [a] => Show (T a) where... +and NOT + instance Show a => Show (T a) where... +so that the (Show (T Char)) instance does the Right Thing + +It's very like the situation when we're inferring the type +of a function + f x = show [x] +and we want to infer + f :: Show [a] => a -> String + +BOTTOM LINE: use vanilla, non-overlappable skolems when inferring + the context for the derived instance. + Hence tcInstSkolTyVars not tcInstSuperSkolTyVars + +Note [Gathering and simplifying constraints for DeriveAnyClass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DeriveAnyClass works quite differently from stock and newtype deriving in +the way it gathers and simplifies constraints to be used in a derived +instance's context. Stock and newtype deriving gather constraints by looking +at the data constructors of the data type for which we are deriving an +instance. But DeriveAnyClass doesn't need to know about a data type's +definition at all! + +To see why, consider this example of DeriveAnyClass: + + class Foo a where + bar :: forall b. Ix b => a -> b -> String + default bar :: (Show a, Ix c) => a -> c -> String + bar x y = show x ++ show (range (y,y)) + + baz :: Eq a => a -> a -> Bool + default baz :: (Ord a, Show a) => a -> a -> Bool + baz x y = compare x y == EQ + +Because 'bar' and 'baz' have default signatures, this generates a top-level +definition for these generic default methods + + $gdm_bar :: forall a. Foo a + => forall c. (Show a, Ix c) + => a -> c -> String + $gdm_bar x y = show x ++ show (range (y,y)) + +(and similarly for baz). Now consider a 'deriving' clause + data Maybe s = ... deriving Foo + +This derives an instance of the form: + instance (CX) => Foo (Maybe s) where + bar = $gdm_bar + baz = $gdm_baz + +Now it is GHC's job to fill in a suitable instance context (CX). If +GHC were typechecking the binding + bar = $gdm bar +it would + * skolemise the expected type of bar + * instantiate the type of $gdm_bar with meta-type variables + * build an implication constraint + +[STEP DAC BUILD] +So that's what we do. We build the constraint (call it C1) + + forall[2] b. Ix b => (Show (Maybe s), Ix cc, + Maybe s -> b -> String + ~ Maybe s -> cc -> String) + +Here: +* The level of this forall constraint is forall[2], because we are later + going to wrap it in a forall[1] in [STEP DAC RESIDUAL] + +* The 'b' comes from the quantified type variable in the expected type + of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification + variable that comes from instantiating the quantified type variable 'c' in + $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin). + +* The (Ix b) constraint comes from the context of bar's type + (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc) + constraints come from the context of $gdm_bar's type + (i.e., 'to_anyclass_givens' in 'ThetaOrigin'). + +* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String) + comes from marrying up the instantiated type of $gdm_bar with the specified + type of bar. Notice that the type variables from the instance, 's' in this + case, are global to this constraint. + +Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new +unification variable for each iteration of simplifyDeriv. If we re-use the same +unification variable across multiple iterations, then bad things can happen, +such as #14933. + +Similarly for 'baz', giving the constraint C2 + + forall[2]. Eq (Maybe s) => (Ord a, Show a, + Maybe s -> Maybe s -> Bool + ~ Maybe s -> Maybe s -> Bool) + +In this case baz has no local quantification, so the implication +constraint has no local skolems and there are no unification +variables. + +[STEP DAC SOLVE] +We can combine these two implication constraints into a single +constraint (C1, C2), and simplify, unifying cc:=b, to get: + + forall[2] b. Ix b => Show a + /\ + forall[2]. Eq (Maybe s) => (Ord a, Show a) + +[STEP DAC HOIST] +Let's call that (C1', C2'). Now we need to hoist the unsolved +constraints out of the implications to become our candidate for +(CX). That is done by approximateWC, which will return: + + (Show a, Ord a, Show a) + +Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving + + (Show a, Ord a) + +And that's what GHC uses for CX. + +[STEP DAC RESIDUAL] +In this case we have solved all the leftover constraints, but what if +we don't? Simple! We just form the final residual constraint + + forall[1] s. CX => (C1',C2') + +and simplify that. In simple cases it'll succeed easily, because CX +literally contains the constraints in C1', C2', but if there is anything +more complicated it will be reported in a civilised way. + +Note [Error reporting for deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A surprisingly tricky aspect of deriving to get right is reporting sensible +error messages. In particular, if simplifyDeriv reaches a constraint that it +cannot solve, which might include: + +1. Insoluble constraints +2. "Exotic" constraints (See Note [Exotic derived instance contexts]) + +Then we report an error immediately in simplifyDeriv. + +Another possible choice is to punt and let another part of the typechecker +(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead +to worse error messages, so we do it directly in simplifyDeriv. + +simplifyDeriv checks for errors in a clever way. If the deriving machinery +infers the context (Foo a)--that is, if this instance is to be generated: + + instance Foo a => ... + +Then we form an implication of the form: + + forall a. Foo a => + +And pass it to the simplifier. If the context (Foo a) is enough to discharge +all the constraints in , then everything is +hunky-dory. But if contains, say, an insoluble +constraint, then (Foo a) won't be able to solve it, causing GHC to error. + +Note [Exotic derived instance contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a 'derived' instance declaration, we *infer* the context. It's a +bit unclear what rules we should apply for this; the Haskell report is +silent. Obviously, constraints like (Eq a) are fine, but what about + data T f a = MkT (f a) deriving( Eq ) +where we'd get an Eq (f a) constraint. That's probably fine too. + +One could go further: consider + data T a b c = MkT (Foo a b c) deriving( Eq ) + instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) + +Notice that this instance (just) satisfies the Paterson termination +conditions. Then we *could* derive an instance decl like this: + + instance (C Int a, Eq b, Eq c) => Eq (T a b c) +even though there is no instance for (C Int a), because there just +*might* be an instance for, say, (C Int Bool) at a site where we +need the equality instance for T's. + +However, this seems pretty exotic, and it's quite tricky to allow +this, and yet give sensible error messages in the (much more common) +case where we really want that instance decl for C. + +So for now we simply require that the derived instance context +should have only type-variable constraints. + +Here is another example: + data Fix f = In (f (Fix f)) deriving( Eq ) +Here, if we are prepared to allow -XUndecidableInstances we +could derive the instance + instance Eq (f (Fix f)) => Eq (Fix f) +but this is so delicate that I don't think it should happen inside +'deriving'. If you want this, write it yourself! + +NB: if you want to lift this condition, make sure you still meet the +termination conditions! If not, the deriving mechanism generates +larger and larger constraints. Example: + data Succ a = S a + data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + +Note the lack of a Show instance for Succ. First we'll generate + instance (Show (Succ a), Show a) => Show (Seq a) +and then + instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) +and so on. Instead we want to complain of no instance for (Show (Succ a)). + +The bottom line +~~~~~~~~~~~~~~~ +Allow constraints which consist only of type variables, with no repeats. +-} diff --git a/GHC/Tc/Deriv/Utils.hs b/GHC/Tc/Deriv/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Deriv/Utils.hs @@ -0,0 +1,1116 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE TypeFamilies #-} + +-- | Error-checking and other utilities for @deriving@ clauses or declarations. +module GHC.Tc.Deriv.Utils ( + DerivM, DerivEnv(..), + DerivSpec(..), pprDerivSpec, DerivInstTys(..), + DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, + isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, + DerivContext(..), OriginativeDerivStatus(..), + isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin, + PredOrigin(..), ThetaOrigin(..), mkPredOrigin, + mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, + checkOriginativeSideConditions, hasStockDeriving, + canDeriveAnyClass, + std_class_via_coercible, non_coercible_class, + newDerivClsInst, extendLocalInstEnv + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Driver.Types (lookupFixity, mi_fix) +import GHC.Hs +import GHC.Tc.Utils.Instantiate +import GHC.Core.InstEnv +import GHC.Iface.Load (loadInterfaceForName) +import GHC.Unit.Module (getModule) +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names.TH (liftClassKey) +import GHC.Core.TyCon +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Ppr (pprSourceTyCon) +import GHC.Core.Type +import GHC.Utils.Misc +import GHC.Types.Var.Set + +import Control.Monad.Trans.Reader +import Data.Maybe +import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.List.SetOps (assocMaybe) + +-- | To avoid having to manually plumb everything in 'DerivEnv' throughout +-- various functions in "GHC.Tc.Deriv" and "GHC.Tc.Deriv.Infer", we use 'DerivM', which +-- is a simple reader around 'TcRn'. +type DerivM = ReaderT DerivEnv TcRn + +-- | Is GHC processing a standalone deriving declaration? +isStandaloneDeriv :: DerivM Bool +isStandaloneDeriv = asks (go . denv_ctxt) + where + go :: DerivContext -> Bool + go (InferContext wildcard) = isJust wildcard + go (SupplyContext {}) = True + +-- | Is GHC processing a standalone deriving declaration with an +-- extra-constraints wildcard as the context? +-- (e.g., @deriving instance _ => Eq (Foo a)@) +isStandaloneWildcardDeriv :: DerivM Bool +isStandaloneWildcardDeriv = asks (go . denv_ctxt) + where + go :: DerivContext -> Bool + go (InferContext wildcard) = isJust wildcard + go (SupplyContext {}) = False + +-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', +-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. +mkDerivOrigin :: Bool -> CtOrigin +mkDerivOrigin standalone_wildcard + | standalone_wildcard = StandAloneDerivOrigin + | otherwise = DerivClauseOrigin + +-- | Contains all of the information known about a derived instance when +-- determining what its @EarlyDerivSpec@ should be. +-- See @Note [DerivEnv and DerivSpecMechanism]@. +data DerivEnv = DerivEnv + { denv_overlap_mode :: Maybe OverlapMode + -- ^ Is this an overlapping instance? + , denv_tvs :: [TyVar] + -- ^ Universally quantified type variables in the instance + , denv_cls :: Class + -- ^ Class for which we need to derive an instance + , denv_inst_tys :: [Type] + -- ^ All arguments to 'denv_cls' in the derived instance. + , denv_ctxt :: DerivContext + -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the + -- context of the instance). + -- 'InferContext' for @deriving@ clauses, or for standalone deriving that + -- uses a wildcard constraint. + -- See @Note [Inferring the instance context]@. + , denv_strat :: Maybe (DerivStrategy GhcTc) + -- ^ 'Just' if user requests a particular deriving strategy. + -- Otherwise, 'Nothing'. + } + +instance Outputable DerivEnv where + ppr (DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = ctxt + , denv_strat = mb_strat }) + = hang (text "DerivEnv") + 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode + , text "denv_tvs" <+> ppr tvs + , text "denv_cls" <+> ppr cls + , text "denv_inst_tys" <+> ppr inst_tys + , text "denv_ctxt" <+> ppr ctxt + , text "denv_strat" <+> ppr mb_strat ]) + +data DerivSpec theta = DS { ds_loc :: SrcSpan + , ds_name :: Name -- DFun name + , ds_tvs :: [TyVar] + , ds_theta :: theta + , ds_cls :: Class + , ds_tys :: [Type] + , ds_overlap :: Maybe OverlapMode + , ds_standalone_wildcard :: Maybe SrcSpan + -- See Note [Inferring the instance context] + -- in GHC.Tc.Deriv.Infer + , ds_mechanism :: DerivSpecMechanism } + -- This spec implies a dfun declaration of the form + -- df :: forall tvs. theta => C tys + -- The Name is the name for the DFun we'll build + -- The tyvars bind all the variables in the theta + + -- the theta is either the given and final theta, in standalone deriving, + -- or the not-yet-simplified list of constraints together with their origin + + -- ds_mechanism specifies the means by which GHC derives the instance. + -- See Note [Deriving strategies] in GHC.Tc.Deriv + +{- +Example: + + newtype instance T [a] = MkT (Tree a) deriving( C s ) +==> + axiom T [a] = :RTList a + axiom :RTList a = Tree a + + DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] + , ds_mechanism = DerivSpecNewtype (Tree a) } +-} + +pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc +pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, + ds_tys = tys, ds_theta = rhs, + ds_standalone_wildcard = wildcard, ds_mechanism = mech }) + = hang (text "DerivSpec") + 2 (vcat [ text "ds_loc =" <+> ppr l + , text "ds_name =" <+> ppr n + , text "ds_tvs =" <+> ppr tvs + , text "ds_cls =" <+> ppr c + , text "ds_tys =" <+> ppr tys + , text "ds_theta =" <+> ppr rhs + , text "ds_standalone_wildcard =" <+> ppr wildcard + , text "ds_mechanism =" <+> ppr mech ]) + +instance Outputable theta => Outputable (DerivSpec theta) where + ppr = pprDerivSpec + +-- | Information about the arguments to the class in a stock- or +-- newtype-derived instance. +-- See @Note [DerivEnv and DerivSpecMechanism]@. +data DerivInstTys = DerivInstTys + { dit_cls_tys :: [Type] + -- ^ Other arguments to the class except the last + , dit_tc :: TyCon + -- ^ Type constructor for which the instance is requested + -- (last arguments to the type class) + , dit_tc_args :: [Type] + -- ^ Arguments to the type constructor + , dit_rep_tc :: TyCon + -- ^ The representation tycon for 'dit_tc' + -- (for data family instances). Otherwise the same as 'dit_tc'. + , dit_rep_tc_args :: [Type] + -- ^ The representation types for 'dit_tc_args' + -- (for data family instances). Otherwise the same as 'dit_tc_args'. + } + +instance Outputable DerivInstTys where + ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args + , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args }) + = hang (text "DITTyConHead") + 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys + , text "dit_tc" <+> ppr tc + , text "dit_tc_args" <+> ppr tc_args + , text "dit_rep_tc" <+> ppr rep_tc + , text "dit_rep_tc_args" <+> ppr rep_tc_args ]) + +-- | What action to take in order to derive a class instance. +-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as +-- @Note [Deriving strategies]@ in "GHC.Tc.Deriv". +data DerivSpecMechanism + -- | \"Standard\" classes + = DerivSpecStock + { dsm_stock_dit :: DerivInstTys + -- ^ Information about the arguments to the class in the derived + -- instance, including what type constructor the last argument is + -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. + , dsm_stock_gen_fn :: + SrcSpan -> TyCon + -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) + -- ^ This function returns three things: + -- + -- 1. @LHsBinds GhcPs@: The derived instance's function bindings + -- (e.g., @compare (T x) (T y) = compare x y@) + -- + -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived + -- instance. As examples, derived 'Generic' instances require + -- associated type family instances, and derived 'Eq' and 'Ord' + -- instances require top-level @con2tag@ functions. + -- See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate". + -- + -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be + -- suppressed. This is used to suppress unused warnings for record + -- selectors when deriving 'Read', 'Show', or 'Generic'. + -- See @Note [Deriving and unused record selectors]@. + } + + -- | @GeneralizedNewtypeDeriving@ + | DerivSpecNewtype + { dsm_newtype_dit :: DerivInstTys + -- ^ Information about the arguments to the class in the derived + -- instance, including what type constructor the last argument is + -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. + , dsm_newtype_rep_ty :: Type + -- ^ The newtype rep type. + } + + -- | @DeriveAnyClass@ + | DerivSpecAnyClass + + -- | @DerivingVia@ + | DerivSpecVia + { dsm_via_cls_tys :: [Type] + -- ^ All arguments to the class besides the last one. + , dsm_via_inst_ty :: Type + -- ^ The last argument to the class. + , dsm_via_ty :: Type + -- ^ The @via@ type + } + +-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. +derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc +derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy +derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy +derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy +derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t + +isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia + :: DerivSpecMechanism -> Bool +isDerivSpecStock (DerivSpecStock{}) = True +isDerivSpecStock _ = False + +isDerivSpecNewtype (DerivSpecNewtype{}) = True +isDerivSpecNewtype _ = False + +isDerivSpecAnyClass DerivSpecAnyClass = True +isDerivSpecAnyClass _ = False + +isDerivSpecVia (DerivSpecVia{}) = True +isDerivSpecVia _ = False + +instance Outputable DerivSpecMechanism where + ppr (DerivSpecStock{dsm_stock_dit = dit}) + = hang (text "DerivSpecStock") + 2 (vcat [ text "dsm_stock_dit" <+> ppr dit ]) + ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty }) + = hang (text "DerivSpecNewtype") + 2 (vcat [ text "dsm_newtype_dit" <+> ppr dit + , text "dsm_newtype_rep_ty" <+> ppr rep_ty ]) + ppr DerivSpecAnyClass = text "DerivSpecAnyClass" + ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty + , dsm_via_ty = via_ty }) + = hang (text "DerivSpecVia") + 2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys + , text "dsm_via_inst_ty" <+> ppr inst_ty + , text "dsm_via_ty" <+> ppr via_ty ]) + +{- +Note [DerivEnv and DerivSpecMechanism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DerivEnv contains all of the bits and pieces that are common to every +deriving strategy. (See Note [Deriving strategies] in GHC.Tc.Deriv.) Some deriving +strategies impose stricter requirements on the types involved in the derived +instance than others, and these differences are factored out into the +DerivSpecMechanism type. Suppose that the derived instance looks like this: + + instance ... => C arg_1 ... arg_n + +Each deriving strategy imposes restrictions on arg_1 through arg_n as follows: + +* stock (DerivSpecStock): + + Stock deriving requires that: + + - n must be a positive number. This is checked by + GHC.Tc.Deriv.expectNonNullaryClsArgs + - arg_n must be an application of an algebraic type constructor. Here, + "algebraic type constructor" means: + + + An ordinary data type constructor, or + + A data family type constructor such that the arguments it is applied to + give rise to a data family instance. + + This is checked by GHC.Tc.Deriv.expectAlgTyConApp. + + This extra structure is witnessed by the DerivInstTys data type, which stores + arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor + (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type + constructor, then dit_rep_tc/dit_rep_tc_args are the same as + dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then + dit_rep_tc is the representation type constructor for the data family + instance, and dit_rep_tc_args are the arguments to the representation type + constructor in the corresponding instance. + +* newtype (DerivSpecNewtype): + + Newtype deriving imposes the same DerivInstTys requirements as stock + deriving. This is necessary because we need to know what the underlying type + that the newtype wraps is, and this information can only be learned by + knowing dit_rep_tc. + +* anyclass (DerivSpecAnyclass): + + DeriveAnyClass is the most permissive deriving strategy of all, as it + essentially imposes no requirements on the derived instance. This is because + DeriveAnyClass simply derives an empty instance, so it does not need any + particular knowledge about the types involved. It can do several things + that stock/newtype deriving cannot do (#13154): + + - n can be 0. That is, one is allowed to anyclass-derive an instance with + no arguments to the class, such as in this example: + + class C + deriving anyclass instance C + + - One can derive an instance for a type that is not headed by a type + constructor, such as in the following example: + + class C (n :: Nat) + deriving instance C 0 + deriving instance C 1 + ... + + - One can derive an instance for a data family with no data family instances, + such as in the following example: + + data family Foo a + class C a + deriving anyclass instance C (Foo a) + +* via (DerivSpecVia): + + Like newtype deriving, DerivingVia requires that n must be a positive number. + This is because when one derives something like this: + + deriving via Foo instance C Bar + + Then the generated code must specifically mention Bar. However, in + contrast with newtype deriving, DerivingVia does *not* require Bar to be + an application of an algebraic type constructor. This is because the + generated code simply defers to invoking `coerce`, which does not need to + know anything in particular about Bar (besides that it is representationally + equal to Foo). This allows DerivingVia to do some things that are not + possible with newtype deriving, such as deriving instances for data families + without data instances (#13154): + + data family Foo a + newtype ByBar a = ByBar a + class Baz a where ... + instance Baz (ByBar a) where ... + deriving via ByBar (Foo a) instance Baz (Foo a) +-} + +-- | Whether GHC is processing a @deriving@ clause or a standalone deriving +-- declaration. +data DerivContext + = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either: + -- + -- * A @deriving@ clause (in which case + -- @mb_wildcard@ is 'Nothing'). + -- + -- * A standalone deriving declaration with + -- an extra-constraints wildcard as the + -- context (in which case @mb_wildcard@ is + -- @'Just' loc@, where @loc@ is the location + -- of the wildcard. + -- + -- GHC should infer the context. + + | SupplyContext ThetaType -- ^ @'SupplyContext' theta@ is a standalone + -- deriving declaration, where @theta@ is the + -- context supplied by the user. + +instance Outputable DerivContext where + ppr (InferContext standalone) = text "InferContext" <+> ppr standalone + ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta + +-- | Records whether a particular class can be derived by way of an +-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@). +-- +-- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". +data OriginativeDerivStatus + = CanDeriveStock -- Stock class, can derive + (SrcSpan -> TyCon -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) + | StockClassError SDoc -- Stock class, but can't do it + | CanDeriveAnyClass -- See Note [Deriving any class] + | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass + +-- A stock class is one either defined in the Haskell report or for which GHC +-- otherwise knows how to generate code for (possibly requiring the use of a +-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) + +-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin', +-- and whether or the constraint deals in types or kinds. +data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind + +-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to +-- simplify when inferring a derived instance's context. These are used in all +-- deriving strategies, but in the particular case of @DeriveAnyClass@, we +-- need extra information. In particular, we need: +-- +-- * 'to_anyclass_skols', the list of type variables bound by a class method's +-- regular type signature, which should be rigid. +-- +-- * 'to_anyclass_metas', the list of type variables bound by a class method's +-- default type signature. These can be unified as necessary. +-- +-- * 'to_anyclass_givens', the list of constraints from a class method's +-- regular type signature, which can be used to help solve constraints +-- in the 'to_wanted_origins'. +-- +-- (Note that 'to_wanted_origins' will likely contain type variables from the +-- derived type class or data type, neither of which will appear in +-- 'to_anyclass_skols' or 'to_anyclass_metas'.) +-- +-- For all other deriving strategies, it is always the case that +-- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are +-- empty. +-- +-- Here is an example to illustrate this: +-- +-- @ +-- class Foo a where +-- bar :: forall b. Ix b => a -> b -> String +-- default bar :: forall y. (Show a, Ix y) => a -> y -> String +-- bar x y = show x ++ show (range (y, y)) +-- +-- baz :: Eq a => a -> a -> Bool +-- default baz :: Ord a => a -> a -> Bool +-- baz x y = compare x y == EQ +-- +-- data Quux q = Quux deriving anyclass Foo +-- @ +-- +-- Then it would generate two 'ThetaOrigin's, one for each method: +-- +-- @ +-- [ ThetaOrigin { to_anyclass_skols = [b] +-- , to_anyclass_metas = [y] +-- , to_anyclass_givens = [Ix b] +-- , to_wanted_origins = [ Show (Quux q), Ix y +-- , (Quux q -> b -> String) ~ +-- (Quux q -> y -> String) +-- ] } +-- , ThetaOrigin { to_anyclass_skols = [] +-- , to_anyclass_metas = [] +-- , to_anyclass_givens = [Eq (Quux q)] +-- , to_wanted_origins = [ Ord (Quux q) +-- , (Quux q -> Quux q -> Bool) ~ +-- (Quux q -> Quux q -> Bool) +-- ] } +-- ] +-- @ +-- +-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus +-- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.) +-- +-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@ +-- in "GHC.Tc.Deriv.Infer" for an explanation of how 'to_wanted_origins' are +-- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols', +-- 'to_anyclass_metas', and 'to_anyclass_givens' are used. +data ThetaOrigin + = ThetaOrigin { to_anyclass_skols :: [TyVar] + , to_anyclass_metas :: [TyVar] + , to_anyclass_givens :: ThetaType + , to_wanted_origins :: [PredOrigin] } + +instance Outputable PredOrigin where + ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging + +instance Outputable ThetaOrigin where + ppr (ThetaOrigin { to_anyclass_skols = ac_skols + , to_anyclass_metas = ac_metas + , to_anyclass_givens = ac_givens + , to_wanted_origins = wanted_origins }) + = hang (text "ThetaOrigin") + 2 (vcat [ text "to_anyclass_skols =" <+> ppr ac_skols + , text "to_anyclass_metas =" <+> ppr ac_metas + , text "to_anyclass_givens =" <+> ppr ac_givens + , text "to_wanted_origins =" <+> ppr wanted_origins ]) + +mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin +mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k + +mkThetaOrigin :: CtOrigin -> TypeOrKind + -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType + -> ThetaOrigin +mkThetaOrigin origin t_or_k skols metas givens + = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k) + +-- A common case where the ThetaOrigin only contains wanted constraints, with +-- no givens or locally scoped type variables. +mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin +mkThetaOriginFromPreds = ThetaOrigin [] [] [] + +substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin +substPredOrigin subst (PredOrigin pred origin t_or_k) + = PredOrigin (substTy subst pred) origin t_or_k + +{- +************************************************************************ +* * + Class deriving diagnostics +* * +************************************************************************ + +Only certain blessed classes can be used in a deriving clause (without the +assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes +are listed below in the definition of hasStockDeriving. The stockSideConditions +function determines the criteria that needs to be met in order for a particular +stock class to be able to be derived successfully. + +A class might be able to be used in a deriving clause if -XDeriveAnyClass +is willing to support it. The canDeriveAnyClass function checks if this is the +case. +-} + +hasStockDeriving + :: Class -> Maybe (SrcSpan + -> TyCon + -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) +hasStockDeriving clas + = assocMaybe gen_list (getUnique clas) + where + gen_list + :: [(Unique, SrcSpan + -> TyCon + -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))] + gen_list = [ (eqClassKey, simpleM gen_Eq_binds) + , (ordClassKey, simpleM gen_Ord_binds) + , (enumClassKey, simpleM gen_Enum_binds) + , (boundedClassKey, simple gen_Bounded_binds) + , (ixClassKey, simpleM gen_Ix_binds) + , (showClassKey, read_or_show gen_Show_binds) + , (readClassKey, read_or_show gen_Read_binds) + , (dataClassKey, simpleM gen_Data_binds) + , (functorClassKey, simple gen_Functor_binds) + , (foldableClassKey, simple gen_Foldable_binds) + , (traversableClassKey, simple gen_Traversable_binds) + , (liftClassKey, simple gen_Lift_binds) + , (genClassKey, generic (gen_Generic_binds Gen0)) + , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] + + simple gen_fn loc tc _ + = let (binds, deriv_stuff) = gen_fn loc tc + in return (binds, deriv_stuff, []) + + -- Like `simple`, but monadic. The only monadic thing that these functions + -- do is allocate new Uniques, which are used for generating the names of + -- auxiliary bindings. + -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. + simpleM gen_fn loc tc _ + = do { (binds, deriv_stuff) <- gen_fn loc tc + ; return (binds, deriv_stuff, []) } + + read_or_show gen_fn loc tc _ + = do { fix_env <- getDataConFixityFun tc + ; let (binds, deriv_stuff) = gen_fn fix_env loc tc + field_names = all_field_names tc + ; return (binds, deriv_stuff, field_names) } + + generic gen_fn _ tc inst_tys + = do { (binds, faminst) <- gen_fn tc inst_tys + ; let field_names = all_field_names tc + ; return (binds, unitBag (DerivFamInst faminst), field_names) } + + -- See Note [Deriving and unused record selectors] + all_field_names = map flSelector . concatMap dataConFieldLabels + . tyConDataCons + +{- +Note [Deriving and unused record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (see #13919): + + module Main (main) where + + data Foo = MkFoo {bar :: String} deriving Show + + main :: IO () + main = print (Foo "hello") + +Strictly speaking, the record selector `bar` is unused in this module, since +neither `main` nor the derived `Show` instance for `Foo` mention `bar`. +However, the behavior of `main` is affected by the presence of `bar`, since +it will print different output depending on whether `MkFoo` is defined using +record selectors or not. Therefore, we do not to issue a +"Defined but not used: ‘bar’" warning for this module, since removing `bar` +changes the program's behavior. This is the reason behind the [Name] part of +the return type of `hasStockDeriving`—it tracks all of the record selector +`Name`s for which -Wunused-binds should be suppressed. + +Currently, the only three stock derived classes that require this are Read, +Show, and Generic, as their derived code all depend on the record selectors +of the derived data type's constructors. + +See also Note [Newtype deriving and unused constructors] in GHC.Tc.Deriv for +another example of a similar trick. +-} + +getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) +-- If the TyCon is locally defined, we want the local fixity env; +-- but if it is imported (which happens for standalone deriving) +-- we need to get the fixity env from the interface file +-- c.f. GHC.Rename.Env.lookupFixity, and #9830 +getDataConFixityFun tc + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + then do { fix_env <- getFixityEnv + ; return (lookupFixity fix_env) } + else do { iface <- loadInterfaceForName doc name + -- Should already be loaded! + ; return (mi_fix iface . nameOccName) } } + where + name = tyConName tc + doc = text "Data con fixities for" <+> ppr name + +------------------------------------------------------------------ +-- Check side conditions that dis-allow derivability for the originative +-- deriving strategies (stock and anyclass). +-- See Note [Deriving strategies] in GHC.Tc.Deriv for an explanation of what +-- "originative" means. +-- +-- This is *apart* from the coerce-based strategies, newtype and via. +-- +-- Here we get the representation tycon in case of family instances as it has +-- the data constructors - but we need to be careful to fall back to the +-- family tycon (with indexes) in error messages. + +checkOriginativeSideConditions + :: DynFlags -> DerivContext -> Class -> [TcType] + -> TyCon -> TyCon + -> OriginativeDerivStatus +checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc + -- First, check if stock deriving is possible... + | Just cond <- stockSideConditions deriv_ctxt cls + = case (cond dflags tc rep_tc) of + NotValid err -> StockClassError err -- Class-specific error + IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) + -- All stock derivable classes are unary in the sense that + -- there should be not types in cls_tys (i.e., no type args + -- other than last). Note that cls_types can contain + -- invisible types as well (e.g., for Generic1, which is + -- poly-kinded), so make sure those are not counted. + , Just gen_fn <- hasStockDeriving cls + -> CanDeriveStock gen_fn + | otherwise -> StockClassError (classArgsErr cls cls_tys) + -- e.g. deriving( Eq s ) + + -- ...if not, try falling back on DeriveAnyClass. + | NotValid err <- canDeriveAnyClass dflags + = NonDerivableClass err -- Neither anyclass nor stock work + + | otherwise + = CanDeriveAnyClass -- DeriveAnyClass should work + +classArgsErr :: Class -> [Type] -> SDoc +classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" + +-- Side conditions (whether the datatype must have at least one constructor, +-- required language extensions, etc.) for using GHC's stock deriving +-- mechanism on certain classes (as opposed to classes that require +-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a +-- class for which stock deriving isn't possible. +stockSideConditions :: DerivContext -> Class -> Maybe Condition +stockSideConditions deriv_ctxt cls + | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) + | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` + cond_vanilla `andCond` + cond_args cls) + | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` + cond_vanilla `andCond` + cond_functorOK True False) + | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` + cond_vanilla `andCond` + cond_functorOK False True) + -- Functor/Fold/Trav works ok + -- for rank-n types + | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` + cond_vanilla `andCond` + cond_functorOK False False) + | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_RepresentableOk) + | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_Representable1Ok) + | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` + cond_vanilla `andCond` + cond_args cls) + | otherwise = Nothing + where + cls_key = getUnique cls + cond_std = cond_stdOK deriv_ctxt False + -- Vanilla data constructors, at least one, and monotype arguments + cond_vanilla = cond_stdOK deriv_ctxt True + -- Vanilla data constructors but allow no data cons or polytype arguments + +canDeriveAnyClass :: DynFlags -> Validity +-- IsValid: we can (try to) derive it via an empty instance declaration +-- NotValid s: we can't, reason s +canDeriveAnyClass dflags + | not (xopt LangExt.DeriveAnyClass dflags) + = NotValid (text "Try enabling DeriveAnyClass") + | otherwise + = IsValid -- OK! + +type Condition + = DynFlags + + -> TyCon -- ^ The data type's 'TyCon'. For data families, this is the + -- family 'TyCon'. + + -> TyCon -- ^ For data families, this is the representation 'TyCon'. + -- Otherwise, this is the same as the other 'TyCon' argument. + + -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is + -- possible. Otherwise, it's @'NotValid' err@, where @err@ + -- explains what went wrong. + +orCond :: Condition -> Condition -> Condition +orCond c1 c2 dflags tc rep_tc + = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) + -- Both fail + +andCond :: Condition -> Condition -> Condition +andCond c1 c2 dflags tc rep_tc + = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc + +-- | Some common validity checks shared among stock derivable classes. One +-- check that absolutely must hold is that if an instance @C (T a)@ is being +-- derived, then @T@ must be a tycon for a data type or a newtype. The +-- remaining checks are only performed if using a @deriving@ clause (i.e., +-- they're ignored if using @StandaloneDeriving@): +-- +-- 1. The data type must have at least one constructor (this check is ignored +-- if using @EmptyDataDeriving@). +-- +-- 2. The data type cannot have any GADT constructors. +-- +-- 3. The data type cannot have any constructors with existentially quantified +-- type variables. +-- +-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@). +-- +-- 5. The data type cannot have fields with higher-rank types. +cond_stdOK + :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a + -- user-supplied context, 'InferContext' if not. + -- If it is the former, we relax some of the validity checks + -- we would otherwise perform (i.e., "just go for it"). + + -> Bool -- ^ 'True' <=> allow higher rank arguments and empty data + -- types (with no data constructors) even in the absence of + -- the -XEmptyDataDeriving extension. + + -> Condition +cond_stdOK deriv_ctxt permissive dflags tc rep_tc + = valid_ADT `andValid` valid_misc + where + valid_ADT, valid_misc :: Validity + valid_ADT + | isAlgTyCon tc || isDataFamilyTyCon tc + = IsValid + | otherwise + -- Complain about functions, primitive types, and other tycons that + -- stock deriving can't handle. + = NotValid $ text "The last argument of the instance must be a" + <+> text "data or newtype application" + + valid_misc + = case deriv_ctxt of + SupplyContext _ -> IsValid + -- Don't check these conservative conditions for + -- standalone deriving; just generate the code + -- and let the typechecker handle the result + InferContext wildcard + | null data_cons -- 1. + , not permissive + -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid` + NotValid (no_cons_why rep_tc $$ empty_data_suggestion) + | not (null con_whys) + -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard) + | otherwise + -> IsValid + + empty_data_suggestion = + text "Use EmptyDataDeriving to enable deriving for empty data types" + possible_fix_suggestion wildcard + = case wildcard of + Just _ -> + text "Possible fix: fill in the wildcard constraint yourself" + Nothing -> + text "Possible fix: use a standalone deriving declaration instead" + data_cons = tyConDataCons rep_tc + con_whys = getInvalids (map check_con data_cons) + + check_con :: DataCon -> Validity + check_con con + | not (null eq_spec) -- 2. + = bad "is a GADT" + | not (null ex_tvs) -- 3. + = bad "has existential type variables in its type" + | not (null theta) -- 4. + = bad "has constraints in its type" + | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5. + = bad "has a higher-rank type" + | otherwise + = IsValid + where + (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con + bad msg = NotValid (badCon con (text msg)) + +no_cons_why :: TyCon -> SDoc +no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> + text "must have at least one data constructor" + +cond_RepresentableOk :: Condition +cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc + +cond_Representable1Ok :: Condition +cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc + +cond_enumOrProduct :: Class -> Condition +cond_enumOrProduct cls = cond_isEnumeration `orCond` + (cond_isProduct `andCond` cond_args cls) + +cond_args :: Class -> Condition +-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types +-- by generating specialised code. For others (eg 'Data') we don't. +-- For even others (eg 'Lift'), unlifted types aren't even a special +-- consideration! +cond_args cls _ _ rep_tc + = case bad_args of + [] -> IsValid + (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) + where + bad_args = [ arg_ty | con <- tyConDataCons rep_tc + , Scaled _ arg_ty <- dataConOrigArgTys con + , isLiftedType_maybe arg_ty /= Just True + , not (ok_ty arg_ty) ] + + cls_key = classKey cls + ok_ty arg_ty + | cls_key == eqClassKey = check_in arg_ty ordOpTbl + | cls_key == ordClassKey = check_in arg_ty ordOpTbl + | cls_key == showClassKey = check_in arg_ty boxConTbl + | cls_key == liftClassKey = True -- Lift is levity-polymorphic + | otherwise = False -- Read, Ix etc + + check_in :: Type -> [(Type,a)] -> Bool + check_in arg_ty tbl = any (eqType arg_ty . fst) tbl + + +cond_isEnumeration :: Condition +cond_isEnumeration _ _ rep_tc + | isEnumerationTyCon rep_tc = IsValid + | otherwise = NotValid why + where + why = sep [ quotes (pprSourceTyCon rep_tc) <+> + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] + -- See Note [Enumeration types] in GHC.Core.TyCon + +cond_isProduct :: Condition +cond_isProduct _ _ rep_tc + | isProductTyCon rep_tc = IsValid + | otherwise = NotValid why + where + why = quotes (pprSourceTyCon rep_tc) <+> + text "must have precisely one constructor" + +cond_functorOK :: Bool -> Bool -> Condition +-- OK for Functor/Foldable/Traversable class +-- Currently: (a) at least one argument +-- (b) don't use argument contravariantly +-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) +-- (d) optionally: don't use function types +-- (e) no "stupid context" on data type +cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc + | null tc_tvs + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters") + + | not (null bad_stupid_theta) + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + + | otherwise + = allValid (map check_con data_cons) + where + tc_tvs = tyConTyVars rep_tc + last_tv = last tc_tvs + bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) + is_bad pred = last_tv `elemVarSet` exactTyCoVarsOfType pred + -- See Note [Check that the type variable is truly universal] + + data_cons = tyConDataCons rep_tc + check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) + + check_universal :: DataCon -> Validity + check_universal con + | allowExQuantifiedLastTyVar + = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] + -- in GHC.Tc.Deriv.Functor + | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) + , tv `elem` dataConUnivTyVars con + , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) + = IsValid -- See Note [Check that the type variable is truly universal] + | otherwise + = NotValid (badCon con existential) + + ft_check :: DataCon -> FFoldType Validity + ft_check con = FT { ft_triv = IsValid, ft_var = IsValid + , ft_co_var = NotValid (badCon con covariant) + , ft_fun = \x y -> if allowFunctions then x `andValid` y + else NotValid (badCon con functions) + , ft_tup = \_ xs -> allValid xs + , ft_ty_app = \_ _ x -> x + , ft_bad_app = NotValid (badCon con wrong_arg) + , ft_forall = \_ x -> x } + + existential = text "must be truly polymorphic in the last argument of the data type" + covariant = text "must not use the type variable in a function argument" + functions = text "must not contain function types" + wrong_arg = text "must use the type variable only as the last argument of a data type" + +checkFlag :: LangExt.Extension -> Condition +checkFlag flag dflags _ _ + | xopt flag dflags = IsValid + | otherwise = NotValid why + where + why = text "You need " <> text flag_str + <+> text "to derive an instance for this class" + flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of + [s] -> s + other -> pprPanic "checkFlag" (ppr other) + +std_class_via_coercible :: Class -> Bool +-- These standard classes can be derived for a newtype +-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving +-- because giving so gives the same results as generating the boilerplate +std_class_via_coercible clas + = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] + -- Not Read/Show because they respect the type + -- Not Enum, because newtypes are never in Enum + + +non_coercible_class :: Class -> Bool +-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift +-- by Coercible, even with -XGeneralizedNewtypeDeriving +-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived +-- instance behave differently if there's a non-lawful Applicative out there. +-- Besides, with roles, Coercible-deriving Traversable is ill-roled. +non_coercible_class cls + = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey + , genClassKey, gen1ClassKey, typeableClassKey + , traversableClassKey, liftClassKey ]) + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg + +------------------------------------------------------------------ + +newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst +newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode + , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) + = newClsInst overlap_mode dfun_name tvs theta clas tys + +extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a +-- Add new locally-defined instances; don't bother to check +-- for functional dependency errors -- that'll happen in GHC.Tc.TyCl.Instance +extendLocalInstEnv dfuns thing_inside + = do { env <- getGblEnv + ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns + env' = env { tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +{- +Note [Deriving any class] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Classic uses of a deriving clause, or a standalone-deriving declaration, are +for: + * a stock class like Eq or Show, for which GHC knows how to generate + the instance code + * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving + +The DeriveAnyClass extension adds a third way to derive instances, based on +empty instance declarations. + +The canonical use case is in combination with GHC.Generics and default method +signatures. These allow us to have instance declarations being empty, but still +useful, e.g. + + data T a = ...blah..blah... deriving( Generic ) + instance C a => C (T a) -- No 'where' clause + +where C is some "random" user-defined class. + +This boilerplate code can be replaced by the more compact + + data T a = ...blah..blah... deriving( Generic, C ) + +if DeriveAnyClass is enabled. + +This is not restricted to Generics; any class can be derived, simply giving +rise to an empty instance. + +See Note [Gathering and simplifying constraints for DeriveAnyClass] in +GHC.Tc.Deriv.Infer for an explanation hof how the instance context is inferred for +DeriveAnyClass. + +Note [Check that the type variable is truly universal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Functor and Traversable instances, we must check that the *last argument* +of the type constructor is used truly universally quantified. Example + + data T a b where + T1 :: a -> b -> T a b -- Fine! Vanilla H-98 + T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' + T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic + T4 :: Ord b => b -> T a b -- No! 'b' is constrained + T5 :: b -> T b b -- No! 'b' is constrained + T6 :: T a (b,b) -- No! 'b' is constrained + +Notice that only the first of these constructors is vanilla H-98. We only +need to take care about the last argument (b in this case). See #8678. +Eg. for T1-T3 we can write + + fmap f (T1 a b) = T1 a (f b) + fmap f (T2 b c) = T2 (f b) c + fmap f (T3 x) = T3 (f x) + +We need not perform these checks for Foldable instances, however, since +functions in Foldable can only consume existentially quantified type variables, +rather than produce them (as is the case in Functor and Traversable functions.) +As a result, T can have a derived Foldable instance: + + foldr f z (T1 a b) = f b z + foldr f z (T2 b c) = f b z + foldr f z (T3 x) = f x z + foldr f z (T4 x) = f x z + foldr f z (T5 x) = f x z + foldr _ z T6 = z + +See Note [DeriveFoldable with ExistentialQuantification] in GHC.Tc.Deriv.Functor. + +For Functor and Traversable, we must take care not to let type synonyms +unfairly reject a type for not being truly universally quantified. An +example of this is: + + type C (a :: Constraint) b = a + data T a b = C (Show a) b => MkT b + +Here, the existential context (C (Show a) b) does technically mention the last +type variable b. But this is OK, because expanding the type synonym C would +give us the context (Show a), which doesn't mention b. Therefore, we must make +sure to expand type synonyms before performing this check. Not doing so led to +#13813. +-} diff --git a/GHC/Tc/Errors.hs b/GHC/Tc/Errors.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors.hs @@ -0,0 +1,3055 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Tc.Errors( + reportUnsolved, reportAllUnsolved, warnAllUnsolved, + warnDefaulting, + + solverDepthErrorTcS + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Unify( occCheckForErrors, MetaTyVarUpdateResult(..) ) +import GHC.Tc.Utils.Env( tcInitTidyEnv ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Origin +import GHC.Rename.Unbound ( unknownNameSuggestions ) +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) +import GHC.Core.Unify ( tcMatchTys ) +import GHC.Unit.Module +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv ( flattenTys ) +import GHC.Tc.Utils.Instantiate +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.EvTerm +import GHC.Hs.Binds ( PatSynBind(..) ) +import GHC.Types.Name +import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) +import GHC.Builtin.Names ( typeableClassName ) +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Set +import GHC.Data.Bag +import GHC.Utils.Error ( ErrMsg, errDoc, pprLocErrMsg ) +import GHC.Types.Basic +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import GHC.Core.ConLike ( ConLike(..)) +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Driver.Session +import GHC.Data.List.SetOps ( equivClasses ) +import GHC.Data.Maybe +import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.FV ( fvVarList, unionFV ) + +import Control.Monad ( when, unless ) +import Data.Foldable ( toList ) +import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr ) + +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) + +-- import Data.Semigroup ( Semigroup ) +import qualified Data.Semigroup as Semigroup + + +{- +************************************************************************ +* * +\section{Errors and contexts} +* * +************************************************************************ + +ToDo: for these error messages, should we note the location as coming +from the insts, or just whatever seems to be around in the monad just +now? + +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors +and does not fail if -fdefer-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. +-} + +-- | Report unsolved goals as errors or warnings. We may also turn some into +-- deferred run-time errors if `-fdefer-type-errors` is on. +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer_errors <- goptM Opt_DeferTypeErrors + ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 + ; let type_errors | not defer_errors = TypeError + | warn_errors = TypeWarn (Reason Opt_WarnDeferredTypeErrors) + | otherwise = TypeDefer + + ; defer_holes <- goptM Opt_DeferTypedHoles + ; warn_holes <- woptM Opt_WarnTypedHoles + ; let expr_holes | not defer_holes = HoleError + | warn_holes = HoleWarn + | otherwise = HoleDefer + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; let type_holes | not partial_sigs = HoleError + | warn_partial_sigs = HoleWarn + | otherwise = HoleDefer + + ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables + ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables + ; let out_of_scope_holes | not defer_out_of_scope = HoleError + | warn_out_of_scope = HoleWarn + | otherwise = HoleDefer + + ; report_unsolved type_errors expr_holes + type_holes out_of_scope_holes + binds_var wanted + + ; ev_binds <- getTcEvBindsMap binds_var + ; return (evBindMapBinds ev_binds)} + +-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on +-- However, do not make any evidence bindings, because we don't +-- have any convenient place to put them. +-- NB: Type-level holes are OK, because there are no bindings. +-- See Note [Deferring coercion errors to runtime] +-- Used by solveEqualities for kind equalities +-- (see Note [Fail fast on kind errors] in "GHC.Tc.Solver") +-- and for simplifyDefault. +reportAllUnsolved :: WantedConstraints -> TcM () +reportAllUnsolved wanted + = do { ev_binds <- newNoTcEvBinds + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; let type_holes | not partial_sigs = HoleError + | warn_partial_sigs = HoleWarn + | otherwise = HoleDefer + + ; report_unsolved TypeError HoleError type_holes HoleError + ev_binds wanted } + +-- | Report all unsolved goals as warnings (but without deferring any errors to +-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in +-- "GHC.Tc.Solver" +warnAllUnsolved :: WantedConstraints -> TcM () +warnAllUnsolved wanted + = do { ev_binds <- newTcEvBinds + ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn + ev_binds wanted } + +-- | Report unsolved goals as errors or warnings. +report_unsolved :: TypeErrorChoice -- Deferred type errors + -> HoleChoice -- Expression holes + -> HoleChoice -- Type holes + -> HoleChoice -- Out of scope holes + -> EvBindsVar -- cec_binds + -> WantedConstraints -> TcM () +report_unsolved type_errors expr_holes + type_holes out_of_scope_holes binds_var wanted + | isEmptyWC wanted + = return () + | otherwise + = do { traceTc "reportUnsolved {" $ + vcat [ text "type errors:" <+> ppr type_errors + , text "expr holes:" <+> ppr expr_holes + , text "type holes:" <+> ppr type_holes + , text "scope holes:" <+> ppr out_of_scope_holes ] + ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) + + ; wanted <- zonkWC wanted -- Zonk to reveal all information + -- If we are deferring we are going to need /all/ evidence around, + -- including the evidence produced by unflattening (zonkWC) + ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs + free_tvs = tyCoVarsOfWCList wanted + + ; traceTc "reportUnsolved (after zonking):" $ + vcat [ text "Free tyvars:" <+> pprTyVars free_tvs + , text "Tidy env:" <+> ppr tidy_env + , text "Wanted:" <+> ppr wanted ] + + ; warn_redundant <- woptM Opt_WarnRedundantConstraints + ; exp_syns <- goptM Opt_PrintExpandedSynonyms + ; let err_ctxt = CEC { cec_encl = [] + , cec_tidy = tidy_env + , cec_defer_type_errors = type_errors + , cec_expr_holes = expr_holes + , cec_type_holes = type_holes + , cec_out_of_scope_holes = out_of_scope_holes + , cec_suppress = insolubleWC wanted + -- See Note [Suppressing error messages] + -- Suppress low-priority errors if there + -- are insoluble errors anywhere; + -- See #15539 and c.f. setting ic_status + -- in GHC.Tc.Solver.setImplicationStatus + , cec_warn_redundant = warn_redundant + , cec_expand_syns = exp_syns + , cec_binds = binds_var } + + ; tc_lvl <- getTcLevel + ; reportWanteds err_ctxt tc_lvl wanted + ; traceTc "reportUnsolved }" empty } + +-------------------------------------------- +-- Internal functions +-------------------------------------------- + +-- | An error Report collects messages categorised by their importance. +-- See Note [Error report] for details. +data Report + = Report { report_important :: [SDoc] + , report_relevant_bindings :: [SDoc] + , report_valid_hole_fits :: [SDoc] + } + +instance Outputable Report where -- Debugging only + ppr (Report { report_important = imp + , report_relevant_bindings = rel + , report_valid_hole_fits = val }) + = vcat [ text "important:" <+> vcat imp + , text "relevant:" <+> vcat rel + , text "valid:" <+> vcat val ] + +{- Note [Error report] +The idea is that error msgs are divided into three parts: the main msg, the +context block (\"In the second argument of ...\"), and the relevant bindings +block, which are displayed in that order, with a mark to divide them. The +idea is that the main msg ('report_important') varies depending on the error +in question, but context and relevant bindings are always the same, which +should simplify visual parsing. + +The context is added when the Report is passed off to 'mkErrorReport'. +Unfortunately, unlike the context, the relevant bindings are added in +multiple places so they have to be in the Report. +-} + +instance Semigroup Report where + Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) + +instance Monoid Report where + mempty = Report [] [] [] + mappend = (Semigroup.<>) + +-- | Put a doc into the important msgs block. +important :: SDoc -> Report +important doc = mempty { report_important = [doc] } + +-- | Put a doc into the relevant bindings block. +mk_relevant_bindings :: SDoc -> Report +mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] } + +-- | Put a doc into the valid hole fits block. +valid_hole_fits :: SDoc -> Report +valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } + +data TypeErrorChoice -- What to do for type errors found by the type checker + = TypeError -- A type error aborts compilation with an error message + | TypeWarn WarnReason + -- A type error is deferred to runtime, plus a compile-time warning + -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors) + -- but it isn't for the Safe Haskell Overlapping Instances warnings + -- see warnAllUnsolved + | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time + +data HoleChoice + = HoleError -- A hole is a compile-time error + | HoleWarn -- Defer to runtime, emit a compile-time warning + | HoleDefer -- Defer to runtime, no warning + +instance Outputable HoleChoice where + ppr HoleError = text "HoleError" + ppr HoleWarn = text "HoleWarn" + ppr HoleDefer = text "HoleDefer" + +instance Outputable TypeErrorChoice where + ppr TypeError = text "TypeError" + ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason + ppr TypeDefer = text "TypeDefer" + +data ReportErrCtxt + = CEC { cec_encl :: [Implication] -- Enclosing implications + -- (innermost first) + -- ic_skols and givens are tidied, rest are not + , cec_tidy :: TidyEnv + + , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'cec_binds' for unsolved constraints + + , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime + + -- cec_expr_holes is a union of: + -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' + -- cec_out_of_scope_holes - a set of variables which are + -- out of scope: 'x', 'y', 'bar' + , cec_expr_holes :: HoleChoice -- Holes in expressions + , cec_type_holes :: HoleChoice -- Holes in types + , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes + + , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints + , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms + + , cec_suppress :: Bool -- True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] + } + +instance Outputable ReportErrCtxt where + ppr (CEC { cec_binds = bvar + , cec_defer_type_errors = dte + , cec_expr_holes = eh + , cec_type_holes = th + , cec_out_of_scope_holes = osh + , cec_warn_redundant = wr + , cec_expand_syns = es + , cec_suppress = sup }) + = text "CEC" <+> braces (vcat + [ text "cec_binds" <+> equals <+> ppr bvar + , text "cec_defer_type_errors" <+> equals <+> ppr dte + , text "cec_expr_holes" <+> equals <+> ppr eh + , text "cec_type_holes" <+> equals <+> ppr th + , text "cec_out_of_scope_holes" <+> equals <+> ppr osh + , text "cec_warn_redundant" <+> equals <+> ppr wr + , text "cec_expand_syns" <+> equals <+> ppr es + , text "cec_suppress" <+> equals <+> ppr sup ]) + +-- | Returns True <=> the ReportErrCtxt indicates that something is deferred +deferringAnyBindings :: ReportErrCtxt -> Bool + -- Don't check cec_type_holes, as these don't cause bindings to be deferred +deferringAnyBindings (CEC { cec_defer_type_errors = TypeError + , cec_expr_holes = HoleError + , cec_out_of_scope_holes = HoleError }) = False +deferringAnyBindings _ = True + +-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings +-- at all. +noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt +noDeferredBindings ctxt = ctxt { cec_defer_type_errors = TypeError + , cec_expr_holes = HoleError + , cec_out_of_scope_holes = HoleError } + +{- Note [Suppressing error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The cec_suppress flag says "don't report any errors". Instead, just create +evidence bindings (as usual). It's used when more important errors have occurred. + +Specifically (see reportWanteds) + * If there are insoluble Givens, then we are in unreachable code and all bets + are off. So don't report any further errors. + * If there are any insolubles (eg Int~Bool), here or in a nested implication, + then suppress errors from the simple constraints here. Sometimes the + simple-constraint errors are a knock-on effect of the insolubles. + +This suppression behaviour is controlled by the Bool flag in +ReportErrorSpec, as used in reportWanteds. + +But we need to take care: flags can turn errors into warnings, and we +don't want those warnings to suppress subsequent errors (including +suppressing the essential addTcEvBind for them: #15152). So in +tryReporter we use askNoErrs to see if any error messages were +/actually/ produced; if not, we don't switch on suppression. + +A consequence is that warnings never suppress warnings, so turning an +error into a warning may allow subsequent warnings to appear that were +previously suppressed. (e.g. partial-sigs/should_fail/T14584) +-} + +reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs + , ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_status = status, ic_info = info + , ic_tclvl = tc_lvl }) + | BracketSkol <- info + , not insoluble + = return () -- For Template Haskell brackets report only + -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints + + | otherwise + = do { traceTc "reportImplic" (ppr implic') + ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs + -- Do /not/ use the tidied tvs because then are in the + -- wrong order, so tidying will rename things wrongly + ; reportWanteds ctxt' tc_lvl wanted + ; when (cec_warn_redundant ctxt) $ + warnRedundantConstraints ctxt' tcl_env info' dead_givens } + where + tcl_env = ic_env implic + insoluble = isInsolubleStatus status + (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs + info' = tidySkolemInfo env1 info + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env1) given + , ic_info = info' } + ctxt1 | CoEvBindsVar{} <- evb = noDeferredBindings ctxt + | otherwise = ctxt + -- If we go inside an implication that has no term + -- evidence (e.g. unifying under a forall), we can't defer + -- type errors. You could imagine using the /enclosing/ + -- bindings (in cec_binds), but that may not have enough stuff + -- in scope for the bindings to be well typed. So we just + -- switch off deferred type errors altogether. See #14605. + + ctxt' = ctxt1 { cec_tidy = env1 + , cec_encl = implic' : cec_encl ctxt + + , cec_suppress = insoluble || cec_suppress ctxt + -- Suppress inessential errors if there + -- are insolubles anywhere in the + -- tree rooted here, or we've come across + -- a suppress-worthy constraint higher up (#11541) + + , cec_binds = evb } + + dead_givens = case status of + IC_Solved { ics_dead = dead } -> dead + _ -> [] + + bad_telescope = case status of + IC_BadTelescope -> True + _ -> False + +warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () +-- See Note [Tracking redundant constraints] in GHC.Tc.Solver +warnRedundantConstraints ctxt env info ev_vars + | null redundant_evs + = return () + + | SigSkol {} <- info + = setLclEnv env $ -- We want to add "In the type signature for f" + -- to the error context, which is a bit tiresome + addErrCtxt (text "In" <+> ppr info) $ + do { env <- getLclEnv + ; msg <- mkErrorReport ctxt env (important doc) + ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } + + | otherwise -- But for InstSkol there already *is* a surrounding + -- "In the instance declaration for Eq [a]" context + -- and we don't want to say it twice. Seems a bit ad-hoc + = do { msg <- mkErrorReport ctxt env (important doc) + ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } + where + doc = text "Redundant constraint" <> plural redundant_evs <> colon + <+> pprEvVarTheta redundant_evs + + redundant_evs = + filterOut is_type_error $ + case info of -- See Note [Redundant constraints in instance decls] + InstSkol -> filterOut (improving . idType) ev_vars + _ -> ev_vars + + -- See #15232 + is_type_error = isJust . userTypeError_maybe . idType + + improving pred -- (transSuperClasses p) does not include p + = any isImprovementPred (pred : transSuperClasses pred) + +reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM () +reportBadTelescope ctxt env (ForAllSkol _ telescope) skols + = do { msg <- mkErrorReport ctxt env (important doc) + ; reportError msg } + where + doc = hang (text "These kind and type variables:" <+> telescope $$ + text "are out of dependency order. Perhaps try this ordering:") + 2 (pprTyVars sorted_tvs) + + sorted_tvs = scopedSort skols + +reportBadTelescope _ _ skol_info skols + = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) + +{- Note [Redundant constraints in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For instance declarations, we don't report unused givens if +they can give rise to improvement. Example (#10100): + class Add a b ab | a b -> ab, a ab -> b + instance Add Zero b b + instance Add a b ab => Add (Succ a) b (Succ ab) +The context (Add a b ab) for the instance is clearly unused in terms +of evidence, since the dictionary has no fields. But it is still +needed! With the context, a wanted constraint + Add (Succ Zero) beta (Succ Zero) +we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. +But without the context we won't find beta := Zero. + +This only matters in instance declarations.. +-} + +reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () +reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics + , wc_holes = holes }) + = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt) + , text "tidy_cts =" <+> ppr tidy_cts + , text "tidy_holes = " <+> ppr tidy_holes ]) + + -- First, deal with any out-of-scope errors: + ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes + -- don't suppress out-of-scope errors + ctxt_for_scope_errs = ctxt { cec_suppress = False } + ; (_, no_out_of_scope) <- askNoErrs $ + reportHoles tidy_cts ctxt_for_scope_errs out_of_scope + + -- Next, deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + -- These /ones/ are not suppressed by the incoming context + -- (but will be by out-of-scope errors) + ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } + ; reportHoles tidy_cts ctxt_for_insols other_holes + -- holes never suppress + + ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts + + -- Now all the other constraints. We suppress errors here if + -- any of the first batch failed, or if the enclosing context + -- says to suppress + ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } + ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 + ; MASSERT2( null leftovers, ppr leftovers ) + + -- All the Derived ones have been filtered out of simples + -- by the constraint solver. This is ok; we don't want + -- to report unsolved Derived goals as errors + -- See Note [Do not report derived but soluble errors] + + ; mapBagM_ (reportImplic ctxt2) implics } + -- NB ctxt2: don't suppress inner insolubles if there's only a + -- wanted insoluble here; but do suppress inner insolubles + -- if there's a *given* insoluble here (= inaccessible code) + where + env = cec_tidy ctxt + tidy_cts = bagToList (mapBag (tidyCt env) simples) + tidy_holes = bagToList (mapBag (tidyHole env) holes) + + -- report1: ones that should *not* be suppressed by + -- an insoluble somewhere else in the tree + -- It's crucial that anything that is considered insoluble + -- (see GHC.Tc.Utils.insolubleCt) is caught here, otherwise + -- we might suppress its error message, and proceed on past + -- type checking to get a Lint error later + report1 = [ ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) + + , given_eq_spec + , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) + , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter) + , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter) + , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter) + + -- The only remaining equalities are alpha ~ ty, + -- where alpha is untouchable; and representational equalities + -- Prefer homogeneous equalities over hetero, because the + -- former might be holding up the latter. + -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical + , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr) + , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr) + , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)] + + -- report2: we suppress these if there are insolubles elsewhere in the tree + report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) + , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) + , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] + + -- also checks to make sure the constraint isn't BlockedCIS + -- See TcCanonical Note [Equalities with incompatible kinds], (4) + unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool + unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False + unblocked checker ct pred = checker ct pred + + -- rigid_nom_eq, rigid_nom_tv_eq, + is_dict, is_equality, is_ip, is_irred :: Ct -> Pred -> Bool + + is_given_eq ct pred + | EqPred {} <- pred = arisesFromGivens ct + | otherwise = False + -- I think all given residuals are equalities + + -- Things like (Int ~N Bool) + utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 + utterly_wrong _ _ = False + + -- Things like (a ~N Int) + very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 + very_wrong _ _ = False + + -- Things like (a ~N b) or (a ~N F Bool) + skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 + skolem_eq _ _ = False + + -- Things like (F a ~N Int) + non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) + non_tv_eq _ _ = False + + is_user_type_error ct _ = isUserTypeErrorCt ct + + is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 + is_homo_equality _ _ = False + + is_equality _ (EqPred {}) = True + is_equality _ _ = False + + is_dict _ (ClassPred {}) = True + is_dict _ _ = False + + is_ip _ (ClassPred cls _) = isIPClass cls + is_ip _ _ = False + + is_irred _ (IrredPred {}) = True + is_irred _ _ = False + + given_eq_spec -- See Note [Given errors] + | has_gadt_match (cec_encl ctxt) + = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) + | otherwise + = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) + -- False means don't suppress subsequent errors + -- Reason: we don't report all given errors + -- (see mkGivenErrorReporter), and we should only suppress + -- subsequent errors if we actually report this one! + -- #13446 is an example + + -- See Note [Given errors] + has_gadt_match [] = False + has_gadt_match (implic : implics) + | PatSkol {} <- ic_info implic + , not (ic_no_eqs implic) + , ic_warn_inaccessible implic + -- Don't bother doing this if -Winaccessible-code isn't enabled. + -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance. + = True + | otherwise + = has_gadt_match implics + +--------------- +isSkolemTy :: TcLevel -> Type -> Bool +-- The type is a skolem tyvar +isSkolemTy tc_lvl ty + | Just tv <- getTyVar_maybe ty + = isSkolemTyVar tv + || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) + -- The last case is for touchable TyVarTvs + -- we postpone untouchables to a latter test (too obscure) + + | otherwise + = False + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isTypeFamilyTyCon tc -> Just tc + _ -> Nothing + +-------------------------------------------- +-- Reporters +-------------------------------------------- + +type Reporter + = ReportErrCtxt -> [Ct] -> TcM () +type ReporterSpec + = ( String -- Name + , Ct -> Pred -> Bool -- Pick these ones + , Bool -- True <=> suppress subsequent reporters + , Reporter) -- The reporter itself + +mkSkolReporter :: Reporter +-- Suppress duplicates with either the same LHS, or same location +mkSkolReporter ctxt cts + = mapM_ (reportGroup mkEqErr ctxt) (group cts) + where + group [] = [] + group (ct:cts) = (ct : yeses) : group noes + where + (yeses, noes) = partition (group_with ct) cts + + group_with ct1 ct2 + | EQ <- cmp_loc ct1 ct2 = True + | eq_lhs_type ct1 ct2 = True + | otherwise = False + +reportHoles :: [Ct] -- other (tidied) constraints + -> ReportErrCtxt -> [Hole] -> TcM () +reportHoles tidy_cts ctxt + = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $ + do { err <- mkHoleError tidy_cts ctxt hole + ; maybeReportHoleError ctxt hole err + ; maybeAddDeferredHoleBinding ctxt err hole } + +ignoreThisHole :: ReportErrCtxt -> Hole -> Bool +-- See Note [Skip type holes rapidly] +ignoreThisHole ctxt hole + = case hole_sort hole of + ExprHole {} -> False + TypeHole -> ignore_type_hole + where + ignore_type_hole = case cec_type_holes ctxt of + HoleDefer -> True + _ -> False + +{- Note [Skip type holes rapidly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have module with a /lot/ of partial type signatures, and we +compile it while suppressing partial-type-signature warnings. Then +we don't want to spend ages constructing error messages and lists of +relevant bindings that we never display! This happened in #14766, in +which partial type signatures in a Happy-generated parser cause a huge +increase in compile time. + +The function ignoreThisHole short-circuits the error/warning generation +machinery, in cases where it is definitely going to be a no-op. +-} + +mkUserTypeErrorReporter :: Reporter +mkUserTypeErrorReporter ctxt + = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct + ; maybeReportError ctxt err + ; addDeferredBinding ctxt err ct } + +mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct + $ important + $ pprUserTypeErrorTy + $ case getUserTypeErrorMsg ct of + Just msg -> msg + Nothing -> pprPanic "mkUserTypeError" (ppr ct) + + +mkGivenErrorReporter :: Reporter +-- See Note [Given errors] +mkGivenErrorReporter ctxt cts + = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + ; dflags <- getDynFlags + ; let (implic:_) = cec_encl ctxt + -- Always non-empty when mkGivenErrorReporter is called + ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) + -- For given constraints we overwrite the env (and hence src-loc) + -- with one from the immediately-enclosing implication. + -- See Note [Inaccessible code] + + inaccessible_msg = hang (text "Inaccessible code in") + 2 (ppr (ic_info implic)) + report = important inaccessible_msg `mappend` + mk_relevant_bindings binds_msg + + ; err <- mkEqErr_help dflags ctxt report ct' ty1 ty2 + + ; traceTc "mkGivenErrorReporter" (ppr ct) + ; reportWarning (Reason Opt_WarnInaccessibleCode) err } + where + (ct : _ ) = cts -- Never empty + (ty1, ty2) = getEqPredTys (ctPred ct) + +ignoreErrorReporter :: Reporter +-- Discard Given errors that don't come from +-- a pattern match; maybe we should warn instead? +ignoreErrorReporter ctxt cts + = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) + ; return () } + + +{- Note [Given errors] +~~~~~~~~~~~~~~~~~~~~~~ +Given constraints represent things for which we have (or will have) +evidence, so they aren't errors. But if a Given constraint is +insoluble, this code is inaccessible, and we might want to at least +warn about that. A classic case is + + data T a where + T1 :: T Int + T2 :: T a + T3 :: T Bool + + f :: T Int -> Bool + f T1 = ... + f T2 = ... + f T3 = ... -- We want to report this case as inaccessible + +We'd like to point out that the T3 match is inaccessible. It +will have a Given constraint [G] Int ~ Bool. + +But we don't want to report ALL insoluble Given constraints. See Trac +#12466 for a long discussion. For example, if we aren't careful +we'll complain about + f :: ((Int ~ Bool) => a -> a) -> Int +which arguably is OK. It's more debatable for + g :: (Int ~ Bool) => Int -> Int +but it's tricky to distinguish these cases so we don't report +either. + +The bottom line is this: has_gadt_match looks for an enclosing +pattern match which binds some equality constraints. If we +find one, we report the insoluble Given. +-} + +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) + -- Make error message for a group + -> Reporter -- Deal with lots of constraints +-- Group together errors from same location, +-- and report only the first (to avoid a cascade) +mkGroupReporter mk_err ctxt cts + = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) + +-- Like mkGroupReporter, but doesn't actually print error messages +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +mkSuppressReporter mk_err ctxt cts + = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) + +eq_lhs_type :: Ct -> Ct -> Bool +eq_lhs_type ct1 ct2 + = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of + (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> + (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) + _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) + +cmp_loc :: Ct -> Ct -> Ordering +cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) + +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +reportGroup mk_err ctxt cts = + ASSERT( not (null cts)) + do { err <- mk_err ctxt cts + ; traceTc "About to maybeReportErr" $ + vcat [ text "Constraint:" <+> ppr cts + , text "cec_suppress =" <+> ppr (cec_suppress ctxt) + , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] + ; maybeReportError ctxt err + -- But see Note [Always warn with -fdefer-type-errors] + ; traceTc "reportGroup" (ppr cts) + ; mapM_ (addDeferredBinding ctxt err) cts } + -- Add deferred bindings for all + -- Redundant if we are going to abort compilation, + -- but that's hard to know for sure, and if we don't + -- abort, we need bindings for all (e.g. #12156) + +-- like reportGroup, but does not actually report messages. It still adds +-- -fdefer-type-errors bindings, though. +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter +suppressGroup mk_err ctxt cts + = do { err <- mk_err ctxt cts + ; traceTc "Suppressing errors for" (ppr cts) + ; mapM_ (addDeferredBinding ctxt err) cts } + +maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg -> TcM () +maybeReportHoleError ctxt hole err + | isOutOfScopeHole hole + -- Always report an error for out-of-scope variables + -- Unless -fdefer-out-of-scope-variables is on, + -- in which case the messages are discarded. + -- See #12170, #12406 + = -- If deferring, report a warning only if -Wout-of-scope-variables is on + case cec_out_of_scope_holes ctxt of + HoleError -> reportError err + HoleWarn -> + reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err + HoleDefer -> return () + +-- Unlike maybeReportError, these "hole" errors are +-- /not/ suppressed by cec_suppress. We want to see them! +maybeReportHoleError ctxt (Hole { hole_sort = TypeHole }) err + -- When -XPartialTypeSignatures is on, warnings (instead of errors) are + -- generated for holes in partial type signatures. + -- Unless -fwarn-partial-type-signatures is not on, + -- in which case the messages are discarded. + = -- For partial type signatures, generate warnings only, and do that + -- only if -fwarn-partial-type-signatures is on + case cec_type_holes ctxt of + HoleError -> reportError err + HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err + HoleDefer -> return () + +maybeReportHoleError ctxt hole@(Hole { hole_sort = ExprHole _ }) err + -- Otherwise this is a typed hole in an expression, + -- but not for an out-of-scope variable (because that goes through a + -- different function) + = -- If deferring, report a warning only if -Wtyped-holes is on + ASSERT( not (isOutOfScopeHole hole) ) + case cec_expr_holes ctxt of + HoleError -> reportError err + HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err + HoleDefer -> return () + +maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () +-- Report the error and/or make a deferred binding for it +maybeReportError ctxt err + | cec_suppress ctxt -- Some worse error has occurred; + = return () -- so suppress this error/warning + + | otherwise + = case cec_defer_type_errors ctxt of + TypeDefer -> return () + TypeWarn reason -> reportWarning reason err + TypeError -> reportError err + +addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +-- See Note [Deferring coercion errors to runtime] +addDeferredBinding ctxt err ct + | deferringAnyBindings ctxt + , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct + -- Only add deferred bindings for Wanted constraints + = do { dflags <- getDynFlags + ; let err_tm = mkErrorTerm dflags pred err + ev_binds_var = cec_binds ctxt + + ; case dest of + EvVarDest evar + -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm + HoleDest hole + -> do { -- See Note [Deferred errors for coercion holes] + let co_var = coHoleCoVar hole + ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm + ; fillCoercionHole hole (mkTcCoVarCo co_var) }} + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +mkErrorTerm :: DynFlags -> Type -- of the error term + -> ErrMsg -> EvTerm +mkErrorTerm dflags ty err = evDelayedError ty err_fs + where + err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc dflags $ + err_msg $$ text "(deferred type error)" +maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Hole -> TcM () +maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole ev_id }) +-- Only add bindings for holes in expressions +-- not for holes in partial type signatures +-- cf. addDeferredBinding + | deferringAnyBindings ctxt + = do { dflags <- getDynFlags + ; let err_tm = mkErrorTerm dflags (idType ev_id) err + -- NB: idType ev_id, not hole_ty. hole_ty might be rewritten. + -- See Note [Holes] in GHC.Tc.Types.Constraint + ; addTcEvBind (cec_binds ctxt) $ mkWantedEvBind ev_id err_tm } + | otherwise + = return () +maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole }) + = return () + +tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +-- Use the first reporter in the list whose predicate says True +tryReporters ctxt reporters cts + = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts + ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) + ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts + ; traceTc "tryReporters }" (ppr cts') + ; return (ctxt', cts') } + where + go ctxt [] vis_cts invis_cts + = return (ctxt, vis_cts ++ invis_cts) + + go ctxt (r : rs) vis_cts invis_cts + -- always look at *visible* Origins before invisible ones + -- this is the whole point of isVisibleOrigin + = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts + ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts + ; go ctxt'' rs vis_cts' invis_cts' } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have -fdefer-type-errors + -- But suppress their error messages + +tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +tryReporter ctxt (str, keep_me, suppress_after, reporter) cts + | null yeses + = return (ctxt, cts) + | otherwise + = do { traceTc "tryReporter{ " (text str <+> ppr yeses) + ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) + ; let suppress_now = not no_errs && suppress_after + -- See Note [Suppressing error messages] + ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } + ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) + ; return (ctxt', nos) } + where + (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts + +pprArising :: CtOrigin -> SDoc +-- Used for the main, top-level error message +-- We've done special processing for TypeEq, KindEq, Given +pprArising (TypeEqOrigin {}) = empty +pprArising (KindEqOrigin {}) = empty +pprArising (GivenOrigin {}) = empty +pprArising orig = pprCtOrigin orig + +-- Add the "arising from..." part to a message about bunch of dicts +addArising :: CtOrigin -> SDoc -> SDoc +addArising orig msg = hang msg 2 (pprArising orig) + +pprWithArising :: [Ct] -> (CtLoc, SDoc) +-- Print something like +-- (Eq a) arising from a use of x at y +-- (Show a) arising from a use of p at q +-- Also return a location for the error message +-- Works for Wanted/Derived only +pprWithArising [] + = panic "pprWithArising" +pprWithArising (ct:cts) + | null cts + = (loc, addArising (ctLocOrigin loc) + (pprTheta [ctPred ct])) + | otherwise + = (loc, vcat (map ppr_one (ct:cts))) + where + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprCtLoc (ctLoc ct')) + +mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg +mkErrorMsgFromCt ctxt ct report + = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report + +mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg +mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) + = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) + ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) + (errDoc important [context] (relevant_bindings ++ valid_subs)) + } + +type UserGiven = Implication + +getUserGivens :: ReportErrCtxt -> [UserGiven] +-- One item for each enclosing implication +getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics + +getUserGivensFromImplics :: [Implication] -> [UserGiven] +getUserGivensFromImplics implics + = reverse (filterOut (null . ic_given) implics) + +{- Note [Always warn with -fdefer-type-errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -fdefer-type-errors is on we warn about *all* type errors, even +if cec_suppress is on. This can lead to a lot more warnings than you +would get errors without -fdefer-type-errors, but if we suppress any of +them you might get a runtime error that wasn't warned about at compile +time. + +This is an easy design choice to change; just flip the order of the +first two equations for maybeReportError + +To be consistent, we should also report multiple warnings from a single +location in mkGroupReporter, when -fdefer-type-errors is on. But that +is perhaps a bit *over*-consistent! Again, an easy choice to change. + +With #10283, you can now opt out of deferred type error warnings. + +Note [Deferred errors for coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we need to defer a type error where the destination for the evidence +is a coercion hole. We can't just put the error in the hole, because we can't +make an erroneous coercion. (Remember that coercions are erased for runtime.) +Instead, we invent a new EvVar, bind it to an error and then make a coercion +from that EvVar, filling the hole with that coercion. Because coercions' +types are unlifted, the error is guaranteed to be hit before we get to the +coercion. + +Note [Do not report derived but soluble errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wc_simples include Derived constraints that have not been solved, +but are not insoluble (in that case they'd be reported by 'report1'). +We do not want to report these as errors: + +* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have + an unsolved [D] Eq a, and we do not want to report that; it's just noise. + +* Functional dependencies. For givens, consider + class C a b | a -> b + data T a where + MkT :: C a d => [d] -> T a + f :: C a b => T a -> F Int + f (MkT xs) = length xs + Then we get a [D] b~d. But there *is* a legitimate call to + f, namely f (MkT [True]) :: T Bool, in which b=d. So we should + not reject the program. + + For wanteds, something similar + data T a where + MkT :: C Int b => a -> b -> T a + g :: C Int c => c -> () + f :: T a -> () + f (MkT x y) = g x + Here we get [G] C Int b, [W] C Int a, hence [D] a~b. + But again f (MkT True True) is a legitimate call. + +(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose +derived superclasses between iterations of the solver.) + +For functional dependencies, here is a real example, +stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs + + class C a b | a -> b + g :: C a b => a -> b -> () + f :: C a b => a -> b -> () + f xa xb = + let loop = g xa + in loop xb + +We will first try to infer a type for loop, and we will succeed: + C a b' => b' -> () +Subsequently, we will type check (loop xb) and all is good. But, +recall that we have to solve a final implication constraint: + C a b => (C a b' => .... cts from body of loop .... )) +And now we have a problem as we will generate an equality b ~ b' and fail to +solve it. + + +************************************************************************ +* * + Irreducible predicate errors +* * +************************************************************************ +-} + +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIrredErr ctxt cts + = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 + ; let orig = ctOrigin ct1 + msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) + ; mkErrorMsgFromCt ctxt ct1 $ + msg `mappend` mk_relevant_bindings binds_msg } + where + (ct1:_) = cts + +---------------- +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM ErrMsg +mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ + , hole_ty = hole_ty + , hole_loc = ct_loc }) + | isOutOfScopeHole hole + = do { dflags <- getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; imp_info <- getImports + ; curr_mod <- getModule + ; hpt <- getHpt + ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $ + errDoc [out_of_scope_msg] [] + [unknownNameSuggestions dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } + where + herald | isDataOcc occ = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" + + out_of_scope_msg -- Print v :: ty only if the type has structure + | boring_type = hang herald 2 (ppr occ) + | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) + + lcl_env = ctLocEnv ct_loc + boring_type = isTyVarTy hole_ty + + -- general case: not an out-of-scope error +mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ + , hole_ty = hole_ty + , hole_sort = sort + , hole_loc = ct_loc }) + = do { (ctxt, binds_msg) + <- relevant_bindings False ctxt lcl_env (tyCoVarsOfType hole_ty) + -- The 'False' means "don't filter the bindings"; see Trac #8191 + + ; show_hole_constraints <- goptM Opt_ShowHoleConstraints + ; let constraints_msg + | ExprHole _ <- sort, show_hole_constraints + = givenConstraintsMsg ctxt + | otherwise + = empty + + ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits + ; (ctxt, sub_msg) <- if show_valid_hole_fits + then validHoleFits ctxt tidy_simples hole + else return (ctxt, empty) + + ; mkErrorReport ctxt lcl_env $ + important hole_msg `mappend` + mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` + valid_hole_fits sub_msg } + + where + lcl_env = ctLocEnv ct_loc + hole_kind = tcTypeKind hole_ty + tyvars = tyCoVarsOfTypeList hole_ty + + hole_msg = case sort of + ExprHole _ -> vcat [ hang (text "Found hole:") + 2 (pp_occ_with_type occ hole_ty) + , tyvars_msg, expr_hole_hint ] + TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) + 2 (text "standing for" <+> quotes pp_hole_type_with_kind) + , tyvars_msg, type_hole_hint ] + + pp_hole_type_with_kind + | isLiftedTypeKind hole_kind + || isCoVarType hole_ty -- Don't print the kind of unlifted + -- equalities (#15039) + = pprType hole_ty + | otherwise + = pprType hole_ty <+> dcolon <+> pprKind hole_kind + + tyvars_msg = ppUnless (null tyvars) $ + text "Where:" <+> (vcat (map loc_msg other_tvs) + $$ pprSkols ctxt skol_tvs) + where + (skol_tvs, other_tvs) = partition is_skol tyvars + is_skol tv = isTcTyVar tv && isSkolemTyVar tv + -- Coercion variables can be free in the + -- hole, via kind casts + + type_hole_hint + | HoleError <- cec_type_holes ctxt + = text "To use the inferred type, enable PartialTypeSignatures" + | otherwise + = empty + + expr_hole_hint -- Give hint for, say, f x = _x + | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" + = text "Or perhaps" <+> quotes (ppr occ) + <+> text "is mis-spelled, or not in scope" + | otherwise + = empty + + loc_msg tv + | isTyVar tv + = case tcTyVarDetails tv of + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" + _ -> empty -- Skolems dealt with already + | otherwise -- A coercion variable can be free in the hole type + = ppWhenOption sdocPrintExplicitCoercions $ + quotes (ppr tv) <+> text "is a coercion variable" + +pp_occ_with_type :: OccName -> Type -> SDoc +pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) + +-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module +-- imports +validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the + -- implications and the tidy environment + -> [Ct] -- Unsolved simple constraints + -> Hole -- The hole + -> TcM (ReportErrCtxt, SDoc) -- We return the new context + -- with a possibly updated + -- tidy environment, and + -- the message. +validHoleFits ctxt@(CEC {cec_encl = implics + , cec_tidy = lcl_env}) simps hole + = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps hole + ; return (ctxt {cec_tidy = tidy_env}, msg) } + +-- See Note [Constraints include ...] +givenConstraintsMsg :: ReportErrCtxt -> SDoc +givenConstraintsMsg ctxt = + let constraints :: [(Type, RealSrcSpan)] + constraints = + do { implic@Implic{ ic_given = given } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, tcl_loc (ic_env implic)) } + + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) + + in ppUnless (null constraints) $ + hang (text "Constraints include") + 2 (vcat $ map pprConstraint constraints) + +---------------- +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIPErr ctxt cts + = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 + ; let orig = ctOrigin ct1 + preds = map ctPred cts + givens = getUserGivens ctxt + msg | null givens + = important $ addArising orig $ + sep [ text "Unbound implicit parameter" <> plural cts + , nest 2 (pprParendTheta preds) ] + | otherwise + = couldNotDeduce givens (preds, orig) + + ; mkErrorMsgFromCt ctxt ct1 $ + msg `mappend` mk_relevant_bindings binds_msg } + where + (ct1:_) = cts + +{- +Note [Constraints include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'givenConstraintsMsg' returns the "Constraints include ..." message enabled by +-fshow-hole-constraints. For example, the following hole: + + foo :: (Eq a, Show a) => a -> String + foo x = _ + +would generate the message: + + Constraints include + Eq a (from foo.hs:1:1-36) + Show a (from foo.hs:1:1-36) + +Constraints are displayed in order from innermost (closest to the hole) to +outermost. There's currently no filtering or elimination of duplicates. + +************************************************************************ +* * + Equality errors +* * +************************************************************************ + +Note [Inaccessible code] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + T1 :: T a + T2 :: T Bool + + f :: (a ~ Int) => T a -> Int + f T1 = 3 + f T2 = 4 -- Unreachable code + +Here the second equation is unreachable. The original constraint +(a~Int) from the signature gets rewritten by the pattern-match to +(Bool~Int), so the danger is that we report the error as coming from +the *signature* (#7293). So, for Given errors we replace the +env (and hence src-loc) on its CtLoc with that from the immediately +enclosing implication. + +Note [Error messages for untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#9109) + data G a where { GBool :: G Bool } + foo x = case x of GBool -> True + +Here we can't solve (t ~ Bool), where t is the untouchable result +meta-var 't', because of the (a ~ Bool) from the pattern match. +So we infer the type + f :: forall a t. G a -> t +making the meta-var 't' into a skolem. So when we come to report +the unsolved (t ~ Bool), t won't look like an untouchable meta-var +any more. So we don't assert that it is. +-} + +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct +mkEqErr _ [] = panic "mkEqErr" + +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkEqErr1 ctxt ct -- Wanted or derived; + -- givens handled in mkGivenErrorReporter + = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + ; rdr_env <- getGlobalRdrEnv + ; fam_envs <- tcGetFamInstEnvs + ; let coercible_msg = case ctEqRel ct of + NomEq -> empty + ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + ; dflags <- getDynFlags + ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) + ; let report = mconcat [ important coercible_msg + , mk_relevant_bindings binds_msg] + ; mkEqErr_help dflags ctxt report ct ty1 ty2 } + where + (ty1, ty2) = getEqPredTys (ctPred ct) + +-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint +-- is left over. +mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs + -> TcType -> TcType -> SDoc +mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = msg + | Just (tc, tys) <- splitTyConApp_maybe ty2 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = msg + | Just (s1, _) <- tcSplitAppTy_maybe ty1 + , Just (s2, _) <- tcSplitAppTy_maybe ty2 + , s1 `eqType` s2 + , has_unknown_roles s1 + = hang (text "NB: We cannot know what roles the parameters to" <+> + quotes (ppr s1) <+> text "have;") + 2 (text "we must assume that the role is nominal") + | otherwise + = empty + where + coercible_msg_for_tycon tc + | isAbstractTyCon tc + = Just $ hsep [ text "NB: The type constructor" + , quotes (pprSourceTyCon tc) + , text "is abstract" ] + | isNewTyCon tc + , [data_con] <- tyConDataCons tc + , let dc_name = dataConName data_con + , isNothing (lookupGRE_Name rdr_env dc_name) + = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + | otherwise = Nothing + + has_unknown_roles ty + | Just (tc, tys) <- tcSplitTyConApp_maybe ty + = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon + | Just (s, _) <- tcSplitAppTy_maybe ty + = has_unknown_roles s + | isTyVarTy ty + = True + | otherwise + = False + +mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report + -> Ct + -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help dflags ctxt report ct ty1 ty2 + | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 + = mkTyVarEqErr dflags ctxt report ct tv1 ty2 + | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 + = mkTyVarEqErr dflags ctxt report ct tv2 ty1 + | otherwise + = reportEqErr ctxt report ct ty1 ty2 + +reportEqErr :: ReportErrCtxt -> Report + -> Ct + -> TcType -> TcType -> TcM ErrMsg +reportEqErr ctxt report ct ty1 ty2 + = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) + where + misMatch = misMatchOrCND False ctxt ct ty1 ty2 + eqInfo = mkEqInfoMsg ct ty1 ty2 + +mkTyVarEqErr, mkTyVarEqErr' + :: DynFlags -> ReportErrCtxt -> Report -> Ct + -> TcTyVar -> TcType -> TcM ErrMsg +-- tv1 and ty2 are already tidied +mkTyVarEqErr dflags ctxt report ct tv1 ty2 + = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) + ; mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } + +mkTyVarEqErr' dflags ctxt report ct tv1 ty2 + | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar; we would have + -- swapped in Solver.Canonical.canEqTyVarHomo + || isTyVarTyVar tv1 && not (isTyVarTy ty2) + || ctEqRel ct == ReprEq + -- The cases below don't really apply to ReprEq (except occurs check) + = mkErrorMsgFromCt ctxt ct $ mconcat + [ headline_msg + , extraTyVarEqInfo ctxt tv1 ty2 + , report + ] + + | MTVU_Occurs <- occ_check_expand + -- We report an "occurs check" even for a ~ F t a, where F is a type + -- function; it's not insoluble (because in principle F could reduce) + -- but we have certainly been unable to solve it + -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical + = do { let extra2 = mkEqInfoMsg ct ty1 ty2 + + interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ + filter isTyVar $ + fvVarList $ + tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 + extra3 = mk_relevant_bindings $ + ppWhen (not (null interesting_tyvars)) $ + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + interesting_tyvars) + + tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) + ; mkErrorMsgFromCt ctxt ct $ + mconcat [headline_msg, extra2, extra3, report] } + + | MTVU_Bad <- occ_check_expand + = do { let msg = vcat [ text "Cannot instantiate unification variable" + <+> quotes (ppr tv1) + , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] + -- Unlike the other reports, this discards the old 'report_important' + -- instead of augmenting it. This is because the details are not likely + -- to be helpful since this is just an unimplemented feature. + ; mkErrorMsgFromCt ctxt ct $ mconcat [ headline_msg, important msg, report ] } + + -- If the immediately-enclosing implication has 'tv' a skolem, and + -- we know by now its an InferSkol kind of skolem, then presumably + -- it started life as a TyVarTv, else it'd have been unified, given + -- that there's no occurs-check or forall problem + | (implic:_) <- cec_encl ctxt + , Implic { ic_skols = skols } <- implic + , tv1 `elem` skols + = mkErrorMsgFromCt ctxt ct $ mconcat + [ misMatchMsg ctxt ct ty1 ty2 + , extraTyVarEqInfo ctxt tv1 ty2 + , report + ] + + -- Check for skolem escape + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_skols = skols, ic_info = skol_info } <- implic + , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols + , not (null esc_skols) + = do { let msg = misMatchMsg ctxt ct ty1 ty2 + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + <+> pprQuotedList esc_skols + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] + tv_extra = important $ + vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") + <+> text "bound by" + , nest 2 $ ppr skol_info + , nest 2 $ text "at" <+> + ppr (tcl_loc (ic_env implic)) ] ] + ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } + + -- Nastiest case: attempt to unify an untouchable variable + -- So tv is a meta tyvar (or started that way before we + -- generalised it). So presumably it is an *untouchable* + -- meta tyvar or a TyVarTv, else it'd have been unified + -- See Note [Error messages for untouchables] + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic + = ASSERT2( not (isTouchableMetaTyVar lvl tv1) + , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables] + do { let msg = misMatchMsg ctxt ct ty1 ty2 + tclvl_extra = important $ + nest 2 $ + sep [ quotes (ppr tv1) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> + ppr (tcl_loc (ic_env implic)) ] + tv_extra = extraTyVarEqInfo ctxt tv1 ty2 + add_sig = suggestAddSig ctxt ty1 ty2 + ; mkErrorMsgFromCt ctxt ct $ mconcat + [msg, tclvl_extra, tv_extra, add_sig, report] } + + | otherwise + = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 + -- This *can* happen (#6123, and test T2627b) + -- Consider an ambiguous top-level constraint (a ~ F a) + -- Not an occurs check, because F is a type function. + where + headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 + + ty1 = mkTyVarTy tv1 + occ_check_expand = occCheckForErrors dflags tv1 ty2 + insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 + + what = text $ levelString $ + ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel + +levelString :: TypeOrKind -> String +levelString TypeLevel = "type" +levelString KindLevel = "kind" + +mkEqInfoMsg :: Ct -> TcType -> TcType -> Report +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +mkEqInfoMsg ct ty1 ty2 + = important (tyfun_msg $$ ambig_msg) + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + + ambig_msg | isJust mb_fun1 || isJust mb_fun2 + = snd (mkAmbigMsg False ct) + | otherwise = empty + + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + , not (isInjectiveTyCon tc1 Nominal) + = text "NB:" <+> quotes (ppr tc1) + <+> text "is a non-injective type family" + | otherwise = empty + +isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool +-- See Note [Reporting occurs-check errors] +isUserSkolem ctxt tv + = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) + where + is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) + = tv `elem` sks && is_user_skol_info skol_info + + is_user_skol_info (InferSkol {}) = False + is_user_skol_info _ = True + +misMatchOrCND :: Bool -> ReportErrCtxt -> Ct + -> TcType -> TcType -> Report +-- If oriented then ty1 is actual, ty2 is expected +misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 + | insoluble_occurs_check -- See Note [Insoluble occurs check] + || (isRigidTy ty1 && isRigidTy ty2) + || isGivenCt ct + || null givens + = -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + misMatchMsg ctxt ct ty1 ty2 + + | otherwise + = mconcat [ couldNotDeduce givens ([eq_pred], orig) + , important $ mk_supplementary_ea_msg ctxt level ty1 ty2 orig ] + where + ev = ctEvidence ct + eq_pred = ctEvPred ev + orig = ctEvOrigin ev + level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel + givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)] + -- Keep only UserGivens that have some equalities. + -- See Note [Suppress redundant givens during error reporting] + +couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> Report +couldNotDeduce givens (wanteds, orig) + = important $ + vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) + , vcat (pp_givens givens)] + +pp_givens :: [UserGiven] -> [SDoc] +pp_givens givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (text "from the context:") g + : map (ppr_given (text "or from:")) gs + where + ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) + = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) + -- See Note [Suppress redundant givens during error reporting] + -- for why we use mkMinimalBySCs above. + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) + +-- These are for the "blocked" equalities, as described in TcCanonical +-- Note [Equalities with incompatible kinds], wrinkle (2). There should +-- always be another unsolved wanted around, which will ordinarily suppress +-- this message. But this can still be printed out with -fdefer-type-errors +-- (sigh), so we must produce a message. +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report + where + report = important msg + msg = vcat [ hang (text "Cannot use equality for substitution:") + 2 (ppr (ctPred ct)) + , text "Doing so would be ill-kinded." ] + -- This is a terrible message. Perhaps worse, if the user + -- has -fprint-explicit-kinds on, they will see that the two + -- sides have the same kind, as there is an invisible cast. + -- I really don't know how to do better. +mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" + +{- +Note [Suppress redundant givens during error reporting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC is unable to solve a constraint and prints out an error message, it +will print out what given constraints are in scope to provide some context to +the programmer. But we shouldn't print out /every/ given, since some of them +are not terribly helpful to diagnose type errors. Consider this example: + + foo :: Int :~: Int -> a :~: b -> a :~: c + foo Refl Refl = Refl + +When reporting that GHC can't solve (a ~ c), there are two givens in scope: +(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., +redundant), so it's not terribly useful to report it in an error message. +To accomplish this, we discard any Implications that do not bind any +equalities by filtering the `givens` selected in `misMatchOrCND` (based on +the `ic_no_eqs` field of the Implication). + +But this is not enough to avoid all redundant givens! Consider this example, +from #15361: + + goo :: forall (a :: Type) (b :: Type) (c :: Type). + a :~~: b -> a :~~: c + goo HRefl = HRefl + +Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. +The (* ~ *) part arises due the kinds of (:~~:) being unified. More +importantly, (* ~ *) is redundant, so we'd like not to report it. However, +the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its +ic_no_eqs field), so the test above will keep it wholesale. + +To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) +part. This works because mkMinimalBySCs eliminates reflexive equalities in +addition to superclasses (see Note [Remove redundant provided dicts] +in GHC.Tc.TyCl.PatSyn). +-} + +extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> Report +-- Add on extra info about skolem constants +-- NB: The types themselves are already tidied +extraTyVarEqInfo ctxt tv1 ty2 + = important (extraTyVarInfo ctxt tv1 $$ ty_extra ty2) + where + ty_extra ty = case tcGetCastedTyVar_maybe ty of + Just (tv, _) -> extraTyVarInfo ctxt tv + Nothing -> empty + +extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc +extraTyVarInfo ctxt tv + = ASSERT2( isTyVar tv, ppr tv ) + case tcTyVarDetails tv of + SkolemTv {} -> pprSkols ctxt [tv] + RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" + MetaTv {} -> empty + +suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report +-- See Note [Suggest adding a type signature] +suggestAddSig ctxt ty1 ty2 + | null inferred_bndrs + = mempty + | [bndr] <- inferred_bndrs + = important $ text "Possible fix: add a type signature for" <+> quotes (ppr bndr) + | otherwise + = important $ text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) + where + inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) + get_inf ty | Just tv <- tcGetTyVar_maybe ty + , isSkolemTyVar tv + , ((InferSkol prs, _) : _) <- getSkolemInfo (cec_encl ctxt) [tv] + = map fst prs + | otherwise + = [] + +-------------------- +misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report +-- Types are already tidy +-- If oriented then ty1 is actual, ty2 is expected +misMatchMsg ctxt ct ty1 ty2 + = important $ + addArising orig $ + pprWithExplicitKindsWhenMismatch ty1 ty2 orig $ + sep [ case orig of + TypeEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig + KindEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig + _ -> headline_eq_msg False ct ty1 ty2 + , sameOccExtra ty2 ty1 ] + where + orig = ctOrigin ct + +headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc +-- Generates the main "Could't match 't1' against 't2' +-- headline message +headline_eq_msg add_ea ct ty1 ty2 + + | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || + (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) + = text "Couldn't match a lifted type with an unlifted type" + + | isAtomicTy ty1 || isAtomicTy ty2 + = -- Print with quotes + sep [ text herald1 <+> quotes (ppr ty1) + , nest padding $ + text herald2 <+> quotes (ppr ty2) ] + + | otherwise + = -- Print with vertical layout + vcat [ text herald1 <> colon <+> ppr ty1 + , nest padding $ + text herald2 <> colon <+> ppr ty2 ] + where + herald1 = conc [ "Couldn't match" + , if is_repr then "representation of" else "" + , if add_ea then "expected" else "" + , what ] + herald2 = conc [ "with" + , if is_repr then "that of" else "" + , if add_ea then ("actual " ++ what) else "" ] + + padding = length herald1 - length herald2 + + is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } + + what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) + + conc :: [String] -> String + conc = foldr1 add_space + + add_space :: String -> String -> String + add_space s1 s2 | null s1 = s2 + | null s2 = s1 + | otherwise = s1 ++ (' ' : s2) + + +tk_eq_msg :: ReportErrCtxt + -> Ct -> Type -> Type -> CtOrigin -> SDoc +tk_eq_msg ctxt ct ty1 ty2 orig@(TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_thing = mb_thing }) + -- We can use the TypeEqOrigin to + -- improve the error message quite a lot + + | isUnliftedTypeKind act, isLiftedTypeKind exp + = sep [ text "Expecting a lifted type, but" + , thing_msg mb_thing (text "an") (text "unlifted") ] + + | isLiftedTypeKind act, isUnliftedTypeKind exp + = sep [ text "Expecting an unlifted type, but" + , thing_msg mb_thing (text "a") (text "lifted") ] + + | tcIsLiftedTypeKind exp + = maybe_num_args_msg $$ + sep [ text "Expected a type, but" + , case mb_thing of + Nothing -> text "found something with kind" + Just thing -> quotes thing <+> text "has kind" + , quotes (pprWithTYPE act) ] + + | Just nargs_msg <- num_args_msg + = nargs_msg $$ + mk_ea_msg ctxt (Just ct) level orig + + | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ + ea_looks_same ty1 ty2 exp act + = mk_ea_msg ctxt (Just ct) level orig + + | otherwise -- The mismatched types are /inside/ exp and act + = vcat [ headline_eq_msg False ct ty1 ty2 + , mk_ea_msg ctxt Nothing level orig ] + + where + ct_loc = ctLoc ct + level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel + + thing_msg (Just thing) _ levity = quotes thing <+> text "is" <+> levity + thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" + + num_args_msg = case level of + KindLevel + | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) + -- if one is a meta-tyvar, then it's possible that the user + -- has asked for something impredicative, and we couldn't unify. + -- Don't bother with counting arguments. + -> let n_act = count_args act + n_exp = count_args exp in + case n_act - n_exp of + n | n > 0 -- we don't know how many args there are, so don't + -- recommend removing args that aren't + , Just thing <- mb_thing + -> Just $ text "Expecting" <+> speakN (abs n) <+> + more <+> quotes thing + where + more + | n == 1 = text "more argument to" + | otherwise = text "more arguments to" -- n > 1 + _ -> Nothing + + _ -> Nothing + + maybe_num_args_msg = num_args_msg `orElse` empty + + count_args ty = count isVisibleBinder $ fst $ splitPiTys ty + +tk_eq_msg ctxt ct ty1 ty2 + (KindEqOrigin cty1 mb_cty2 sub_o mb_sub_t_or_k) + = vcat [ headline_eq_msg False ct ty1 ty2 + , supplementary_msg ] + where + sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel + sub_whats = text (levelString sub_t_or_k) <> char 's' + -- "types" or "kinds" + + supplementary_msg + = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> + case mb_cty2 of + Just cty2 + | printExplicitCoercions + || not (cty1 `pickyEqType` cty2) + -> vcat [ hang (text "When matching" <+> sub_whats) + 2 (vcat [ ppr cty1 <+> dcolon <+> + ppr (tcTypeKind cty1) + , ppr cty2 <+> dcolon <+> + ppr (tcTypeKind cty2) ]) + , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ] + _ -> text "When matching the kind of" <+> quotes (ppr cty1) + +tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg" + +ea_looks_same :: Type -> Type -> Type -> Type -> Bool +-- True if the faulting types (ty1, ty2) look the same as +-- the expected/actual types (exp, act). +-- If so, we don't want to redundantly report the latter +ea_looks_same ty1 ty2 exp act + = (act `looks_same` ty1 && exp `looks_same` ty2) || + (exp `looks_same` ty1 && act `looks_same` ty2) + where + looks_same t1 t2 = t1 `pickyEqType` t2 + || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind + -- pickyEqType is sensitive to synonyms, so only replies True + -- when the types really look the same. However, + -- (TYPE 'LiftedRep) and Type both print the same way. + +mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind + -> Type -> Type -> CtOrigin -> SDoc +mk_supplementary_ea_msg ctxt level ty1 ty2 orig + | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig + , not (ea_looks_same ty1 ty2 exp act) + = mk_ea_msg ctxt Nothing level orig + | otherwise + = empty + +mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> SDoc +-- Constructs a "Couldn't match" message +-- The (Maybe Ct) says whether this is the main top-level message (Just) +-- or a supplementary message (Nothing) +mk_ea_msg ctxt at_top level + (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) + | Just thing <- mb_thing + , KindLevel <- level + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes thing <+> text "has kind" <+> + quotes (ppr act)) + + | otherwise + = vcat [ case at_top of + Just ct -> headline_eq_msg True ct exp act + Nothing -> supplementary_ea_msg + , ppWhen expand_syns expandedTys ] + + where + supplementary_ea_msg = vcat [ text "Expected:" <+> ppr exp + , text " Actual:" <+> ppr act ] + + kind_desc | tcIsConstraintKind exp = text "a constraint" + | Just arg <- kindRep_maybe exp -- TYPE t0 + , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case + True -> text "kind" <+> quotes (ppr exp) + False -> text "a type" + | otherwise = text "kind" <+> quotes (ppr exp) + + expand_syns = cec_expand_syns ctxt + + expandedTys = ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat + [ text "Type synonyms expanded:" + , text "Expected type:" <+> ppr expTy1 + , text " Actual type:" <+> ppr expTy2 ] + + (expTy1, expTy2) = expandSynonymsToMatch exp act + +mk_ea_msg _ _ _ _ = empty + +-- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a +-- type mismatch occurs to due invisible kind arguments. +-- +-- This function first checks to see if the 'CtOrigin' argument is a +-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to +-- check for a kind mismatch (as these types typically have more surrounding +-- types and are likelier to be able to glean information about whether a +-- mismatch occurred in an invisible argument position or not). If the +-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types +-- themselves. +pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin + -> SDoc -> SDoc +pprWithExplicitKindsWhenMismatch ty1 ty2 ct + = pprWithExplicitKindsWhen show_kinds + where + (act_ty, exp_ty) = case ct of + TypeEqOrigin { uo_actual = act + , uo_expected = exp } -> (act, exp) + _ -> (ty1, ty2) + show_kinds = tcEqTypeVis act_ty exp_ty + -- True when the visible bit of the types look the same, + -- so we want to show the kinds in the displayed type + + + +{- Note [Insoluble occurs check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble +so we don't use it for rewriting. The Wanted is also insoluble, and +we don't solve it from the Given. It's very confusing to say + Cannot solve a ~ [a] from given constraints a ~ [a] + +And indeed even thinking about the Givens is silly; [W] a ~ [a] is +just as insoluble as Int ~ Bool. + +Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck) +then report it directly, not in the "cannot deduce X from Y" form. +This is done in misMatchOrCND (via the insoluble_occurs_check arg) + +(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't +want to be as draconian with them.) + +Note [Expanding type synonyms to make types similar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In type error messages, if -fprint-expanded-types is used, we want to expand +type synonyms to make expected and found types as similar as possible, but we +shouldn't expand types too much to make type messages even more verbose and +harder to understand. The whole point here is to make the difference in expected +and found types clearer. + +`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms +only as much as necessary. Given two types t1 and t2: + + * If they're already same, it just returns the types. + + * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are + type constructors), it expands C1 and C2 if they're different type synonyms. + Then it recursively does the same thing on expanded types. If C1 and C2 are + same, then it applies the same procedure to arguments of C1 and arguments of + C2 to make them as similar as possible. + + Most important thing here is to keep number of synonym expansions at + minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, + Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and + `T (T3, T3, Bool)`. + + * Otherwise types don't have same shapes and so the difference is clearly + visible. It doesn't do any expansions and show these types. + +Note that we only expand top-layer type synonyms. Only when top-layer +constructors are the same we start expanding inner type synonyms. + +Suppose top-layer type synonyms of t1 and t2 can expand N and M times, +respectively. If their type-synonym-expanded forms will meet at some point (i.e. +will have same shapes according to `sameShapes` function), it's possible to find +where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) +comparisons. We first collect all the top-layer expansions of t1 and t2 in two +lists, then drop the prefix of the longer list so that they have same lengths. +Then we search through both lists in parallel, and return the first pair of +types that have same shapes. Inner types of these two types with same shapes +are then expanded using the same algorithm. + +In case they don't meet, we return the last pair of types in the lists, which +has top-layer type synonyms completely expanded. (in this case the inner types +are not expanded at all, as the current form already shows the type error) +-} + +-- | Expand type synonyms in given types only enough to make them as similar as +-- possible. Returned types are the same in terms of used type synonyms. +-- +-- To expand all synonyms, see 'Type.expandTypeSynonyms'. +-- +-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for +-- some examples of how this should work. +expandSynonymsToMatch :: Type -> Type -> (Type, Type) +expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) + where + (ty1_ret, ty2_ret) = go ty1 ty2 + + -- | Returns (type synonym expanded version of first type, + -- type synonym expanded version of second type) + go :: Type -> Type -> (Type, Type) + go t1 t2 + | t1 `pickyEqType` t2 = + -- Types are same, nothing to do + (t1, t2) + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 = + -- Type constructors are same. They may be synonyms, but we don't + -- expand further. The lengths of tys1 and tys2 must be equal; + -- for example, with type S a = a, we don't want + -- to zip (S Monad Int) and (S Bool). + let (tys1', tys2') = + unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) + in (TyConApp tc1 tys1', TyConApp tc2 tys2') + + go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') + + go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } + , ty2 { ft_arg = t2_1', ft_res = t2_2' }) + + go (ForAllTy b1 t1) (ForAllTy b2 t2) = + -- NOTE: We may have a bug here, but we just can't reproduce it easily. + -- See D1016 comments for details and our attempts at producing a test + -- case. Short version: We probably need RnEnv2 to really get this right. + let (t1', t2') = go t1 t2 + in (ForAllTy b1 t1', ForAllTy b2 t2') + + go (CastTy ty1 _) ty2 = go ty1 ty2 + go ty1 (CastTy ty2 _) = go ty1 ty2 + + go t1 t2 = + -- See Note [Expanding type synonyms to make types similar] for how this + -- works + let + t1_exp_tys = t1 : tyExpansions t1 + t2_exp_tys = t2 : tyExpansions t2 + t1_exps = length t1_exp_tys + t2_exps = length t2_exp_tys + dif = abs (t1_exps - t2_exps) + in + followExpansions $ + zipEqual "expandSynonymsToMatch.go" + (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) + (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) + + -- | Expand the top layer type synonyms repeatedly, collect expansions in a + -- list. The list does not include the original type. + -- + -- Example, if you have: + -- + -- type T10 = T9 + -- type T9 = T8 + -- ... + -- type T0 = Int + -- + -- `tyExpansions T10` returns [T9, T8, T7, ... Int] + -- + -- This only expands the top layer, so if you have: + -- + -- type M a = Maybe a + -- + -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) + tyExpansions :: Type -> [Type] + tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) + + -- | Drop the type pairs until types in a pair look alike (i.e. the outer + -- constructors are the same). + followExpansions :: [(Type, Type)] -> (Type, Type) + followExpansions [] = pprPanic "followExpansions" empty + followExpansions [(t1, t2)] + | sameShapes t1 t2 = go t1 t2 -- expand subtrees + | otherwise = (t1, t2) -- the difference is already visible + followExpansions ((t1, t2) : tss) + -- Traverse subtrees when the outer shapes are the same + | sameShapes t1 t2 = go t1 t2 + -- Otherwise follow the expansions until they look alike + | otherwise = followExpansions tss + + sameShapes :: Type -> Type -> Bool + sameShapes AppTy{} AppTy{} = True + sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 + sameShapes (FunTy {}) (FunTy {}) = True + sameShapes (ForAllTy {}) (ForAllTy {}) = True + sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 + sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 + sameShapes _ _ = False + +sameOccExtra :: TcType -> TcType -> SDoc +-- See Note [Disambiguating (X ~ X) errors] +sameOccExtra ty1 ty2 + | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 + , let n1 = tyConName tc1 + n2 = tyConName tc2 + same_occ = nameOccName n1 == nameOccName n2 + same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) + , n1 /= n2 -- Different Names + , same_occ -- but same OccName + = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + | otherwise + = empty + where + ppr_from same_pkg nm + | isGoodSrcSpan loc + = hang (quotes (ppr nm) <+> text "is defined at") + 2 (ppr loc) + | otherwise -- Imported things have an UnhelpfulSrcSpan + = hang (quotes (ppr nm)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) + , ppUnless (same_pkg || pkg == mainUnit) $ + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) + where + pkg = moduleUnit mod + mod = nameModule nm + loc = nameSrcSpan nm + +{- +Note [Suggest adding a type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The OutsideIn algorithm rejects GADT programs that don't have a principal +type, and indeed some that do. Example: + data T a where + MkT :: Int -> T Int + + f (MkT n) = n + +Does this have type f :: T a -> a, or f :: T a -> Int? +The error that shows up tends to be an attempt to unify an +untouchable type variable. So suggestAddSig sees if the offending +type variable is bound by an *inferred* signature, and suggests +adding a declared signature instead. + +This initially came up in #8968, concerning pattern synonyms. + +Note [Disambiguating (X ~ X) errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #8278 + +Note [Reporting occurs-check errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied +type signature, then the best thing is to report that we can't unify +a with [a], because a is a skolem variable. That avoids the confusing +"occur-check" error message. + +But nowadays when inferring the type of a function with no type signature, +even if there are errors inside, we still generalise its signature and +carry on. For example + f x = x:x +Here we will infer something like + f :: forall a. a -> [a] +with a deferred error of (a ~ [a]). So in the deferred unsolved constraint +'a' is now a skolem, but not one bound by the programmer in the context! +Here we really should report an occurs check. + +So isUserSkolem distinguishes the two. + +Note [Non-injective type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very confusing to get a message like + Couldn't match expected type `Depend s' + against inferred type `Depend s1' +so mkTyFunInfoMsg adds: + NB: `Depend' is type function, and hence may not be injective + +Warn of loopy local equalities that were dropped. + + +************************************************************************ +* * + Type-class errors +* * +************************************************************************ +-} + +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkDictErr ctxt cts + = ASSERT( not (null cts) ) + do { inst_envs <- tcGetInstEnvs + ; let (ct1:_) = cts -- ct1 just for its location + min_cts = elim_superclasses cts + lookups = map (lookup_cls_inst inst_envs) min_cts + (no_inst_cts, overlap_cts) = partition is_no_inst lookups + + -- Report definite no-instance errors, + -- or (iff there are none) overlap errors + -- But we report only one of them (hence 'head') because they all + -- have the same source-location origin, to try avoid a cascade + -- of error from one location + ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; mkErrorMsgFromCt ctxt ct1 (important err) } + where + no_givens = null (getUserGivens ctxt) + + is_no_inst (ct, (matches, unifiers, _)) + = no_givens + && null matches + && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) + + lookup_cls_inst inst_envs ct + -- Note [Flattening in error message generation] + = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) + where + (clas, tys) = getClassPredTys (ctPred ct) + + + -- When simplifying [W] Ord (Set a), we need + -- [W] Eq a, [W] Ord a + -- but we really only want to report the latter + elim_superclasses cts = mkMinimalBySCs ctPred cts + +-- [Note: mk_dict_err] +-- ~~~~~~~~~~~~~~~~~~~ +-- Different dictionary error messages are reported depending on the number of +-- matches and unifiers: +-- +-- - No matches, regardless of unifiers: report "No instance for ...". +-- - Two or more matches, regardless of unifiers: report "Overlapping instances for ...", +-- and show the matching and unifying instances. +-- - One match, one or more unifiers: report "Overlapping instances for", show the +-- matching and unifying instances, and say "The choice depends on the instantion of ..., +-- and the result of evaluating ...". +mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) + -> TcM (ReportErrCtxt, SDoc) +-- Report an overlap error if this class constraint results +-- from an overlap (returning Left clas), otherwise return (Right pred) +mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) + | null matches -- No matches but perhaps several unifiers + = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + ; candidate_insts <- get_candidate_instances + ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) } + + | null unsafe_overlapped -- Some matches => overlap errors + = return (ctxt, overlap_msg) + + | otherwise + = return (ctxt, safe_haskell_msg) + where + orig = ctOrigin ct + pred = ctPred ct + (clas, tys) = getClassPredTys pred + ispecs = [ispec | (ispec, _) <- matches] + unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + -- useful_givens are the enclosing implications with non-empty givens, + -- modulo the horrid discardProvCtxtGivens + + get_candidate_instances :: TcM [ClsInst] + -- See Note [Report candidate instances] + get_candidate_instances + | [ty] <- tys -- Only try for single-parameter classes + = do { instEnvs <- tcGetInstEnvs + ; return (filter (is_candidate_inst ty) + (classInstances instEnvs clas)) } + | otherwise = return [] + + is_candidate_inst ty inst -- See Note [Report candidate instances] + | [other_ty] <- is_tys inst + , Just (tc1, _) <- tcSplitTyConApp_maybe ty + , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty + = let n1 = tyConName tc1 + n2 = tyConName tc2 + different_names = n1 /= n2 + same_occ_names = nameOccName n1 == nameOccName n2 + in different_names && same_occ_names + | otherwise = False + + cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc + cannot_resolve_msg ct candidate_insts binds_msg + = vcat [ no_inst_msg + , nest 2 extra_note + , vcat (pp_givens useful_givens) + , mb_patsyn_prov `orElse` empty + , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) + (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) + + , ppWhen (isNothing mb_patsyn_prov) $ + -- Don't suggest fixes for the provided context of a pattern + -- synonym; the right fix is to bind more in the pattern + show_fixes (ctxtFixes has_ambig_tvs pred implics + ++ drv_fixes) + , ppWhen (not (null candidate_insts)) + (hang (text "There are instances for similar types:") + 2 (vcat (map ppr candidate_insts))) ] + -- See Note [Report candidate instances] + where + orig = ctOrigin ct + -- See Note [Highlighting ambiguous type variables] + lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) + && not (null unifiers) && null useful_givens + + (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct + ambig_tvs = uncurry (++) (getAmbigTkvs ct) + + no_inst_msg + | lead_with_ambig + = ambig_msg <+> pprArising orig + $$ text "prevents the constraint" <+> quotes (pprParendType pred) + <+> text "from being solved." + + | null useful_givens + = addArising orig $ text "No instance for" + <+> pprParendType pred + + | otherwise + = addArising orig $ text "Could not deduce" + <+> pprParendType pred + + potential_msg + = ppWhen (not (null unifiers) && want_potential orig) $ + sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers + + potential_hdr + = vcat [ ppWhen lead_with_ambig $ + text "Probable fix: use a type annotation to specify what" + <+> pprQuotedList ambig_tvs <+> text "should be." + , text "These potential instance" <> plural unifiers + <+> text "exist:"] + + mb_patsyn_prov :: Maybe SDoc + mb_patsyn_prov + | not lead_with_ambig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig + = Just (vcat [ text "In other words, a successful match on the pattern" + , nest 2 $ ppr pat + , text "does not provide the constraint" <+> pprParendType pred ]) + | otherwise = Nothing + + -- Report "potential instances" only when the constraint arises + -- directly from the user's use of an overloaded function + want_potential (TypeEqOrigin {}) = False + want_potential _ = True + + extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) + = text "(maybe you haven't applied a function to enough arguments?)" + | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) + , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) + , Just (tc,_) <- tcSplitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) + = hang (text "GHC can't yet do polykinded") + 2 (text "Typeable" <+> + parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) + | otherwise + = empty + + drv_fixes = case orig of + DerivClauseOrigin -> [drv_fix False] + StandAloneDerivOrigin -> [drv_fix True] + DerivOriginDC _ _ standalone -> [drv_fix standalone] + DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] + _ -> [] + + drv_fix standalone_wildcard + | standalone_wildcard + = text "fill in the wildcard constraint yourself" + | otherwise + = hang (text "use a standalone 'deriving instance' declaration,") + 2 (text "so you can specify the instance context yourself") + + -- Normal overlap error + overlap_msg + = ASSERT( not (null matches) ) + vcat [ addArising orig (text "Overlapping instances for" + <+> pprType (mkClassPred clas tys)) + + , ppUnless (null matching_givens) $ + sep [text "Matching givens (or their superclasses):" + , nest 2 (vcat matching_givens)] + + , sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $ + ispecs ++ unifiers + + , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ text "There exists a (perhaps superclass) match:" + , nest 2 (vcat (pp_givens useful_givens))] + + , ppWhen (isSingleton matches) $ + parens (vcat [ ppUnless (null tyCoVars) $ + text "The choice depends on the instantiation of" <+> + quotes (pprWithCommas ppr tyCoVars) + , ppUnless (null famTyCons) $ + if (null tyCoVars) + then + text "The choice depends on the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + else + text "and the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + , ppWhen (null (matching_givens)) $ + vcat [ text "To pick the first instance above, use IncoherentInstances" + , text "when compiling the other instance declarations"] + ])] + where + tyCoVars = tyCoVarsOfTypesList tys + famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys + + matching_givens = mapMaybe matchable useful_givens + + matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> + ppr (tcl_loc (ic_env implic)) ]) + where ev_vars_matching = [ pred + | ev_var <- evvars + , let pred = evVarPred ev_var + , any can_match (pred : transSuperClasses pred) ] + can_match pred + = case getClassPredTys_maybe pred of + Just (clas', tys') -> clas' == clas + && isJust (tcMatchTys tys tys') + Nothing -> False + + -- Overlap error because of Safe Haskell (first + -- match should be the most specific match) + safe_haskell_msg + = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) ) + vcat [ addArising orig (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance $ head ispecs)] + , vcat [ text "It is compiled in a Safe module and as such can only" + , text "overlap instances from the same module, however it" + , text "overlaps the following instances from different" <+> + text "modules:" + , nest 2 (vcat [pprInstances $ unsafe_ispecs]) + ] + ] + + +ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] +ctxtFixes has_ambig_tvs pred implics + | not has_ambig_tvs + , isTyVarClassPred pred + , (skol:skols) <- usefulContext implics pred + , let what | null skols + , SigSkol (PatSynCtxt {}) _ _ <- skol + = text "\"required\"" + | otherwise + = empty + = [sep [ text "add" <+> pprParendType pred + <+> text "to the" <+> what <+> text "context of" + , nest 2 $ ppr_skol skol $$ + vcat [ text "or" <+> ppr_skol skol + | skol <- skols ] ] ] + | otherwise = [] + where + ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) + ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) + ppr_skol skol_info = ppr skol_info + +discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] +discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig + = filterOut (discard name) givens + | otherwise + = givens + where + discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False + +usefulContext :: [Implication] -> PredType -> [SkolemInfo] +-- usefulContext picks out the implications whose context +-- the programmer might plausibly augment to solve 'pred' +usefulContext implics pred + = go implics + where + pred_tvs = tyCoVarsOfType pred + go [] = [] + go (ic : ics) + | implausible ic = rest + | otherwise = ic_info ic : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + + implausible ic + | null (ic_skols ic) = True + | implausible_info (ic_info ic) = True + | otherwise = False + + implausible_info (SigSkol (InfSigCtxt {}) _ _) = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature + +{- Note [Report candidate instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved (Num Int), where `Int` is not the Prelude Int, +but comes from some other module, then it may be helpful to point out +that there are some similarly named instances elsewhere. So we get +something like + No instance for (Num Int) arising from the literal ‘3’ + There are instances for similar types: + instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ +Discussion in #9611. + +Note [Highlighting ambiguous type variables] +~------------------------------------------- +When we encounter ambiguous type variables (i.e. type variables +that remain metavariables after type inference), we need a few more +conditions before we can reason that *ambiguity* prevents constraints +from being solved: + - We can't have any givens, as encountering a typeclass error + with given constraints just means we couldn't deduce + a solution satisfying those constraints and as such couldn't + bind the type variable to a known type. + - If we don't have any unifiers, we don't even have potential + instances from which an ambiguity could arise. + - Lastly, I don't want to mess with error reporting for + unknown runtime types so we just fall back to the old message there. +Once these conditions are satisfied, we can safely say that ambiguity prevents +the constraint from being solved. + +Note [discardProvCtxtGivens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most situations we call all enclosing implications "useful". There is one +exception, and that is when the constraint that causes the error is from the +"provided" context of a pattern synonym declaration: + + pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a + -- required => provided => type + pattern Pat x <- (Just x, 4) + +When checking the pattern RHS we must check that it does actually bind all +the claimed "provided" constraints; in this case, does the pattern (Just x, 4) +bind the (Show a) constraint. Answer: no! + +But the implication we generate for this will look like + forall a. (Num a, Eq a) => [W] Show a +because when checking the pattern we must make the required +constraints available, since they are needed to match the pattern (in +this case the literal '4' needs (Num a, Eq a)). + +BUT we don't want to suggest adding (Show a) to the "required" constraints +of the pattern synonym, thus: + pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a +It would then typecheck but it's silly. We want the /pattern/ to bind +the alleged "provided" constraints, Show a. + +So we suppress that Implication in discardProvCtxtGivens. It's +painfully ad-hoc but the truth is that adding it to the "required" +constraints would work. Suppressing it solves two problems. First, +we never tell the user that we could not deduce a "provided" +constraint from the "required" context. Second, we never give a +possible fix that suggests to add a "provided" constraint to the +"required" context. + +For example, without this distinction the above code gives a bad error +message (showing both problems): + + error: Could not deduce (Show a) ... from the context: (Eq a) + ... Possible fix: add (Show a) to the context of + the signature for pattern synonym `Pat' ... + +-} + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] + + +-- Avoid boolean blindness +newtype PrintPotentialInstances = PrintPotentialInstances Bool + +pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc +-- See Note [Displaying potential instances] +pprPotentials (PrintPotentialInstances show_potentials) sty herald insts + | null insts + = empty + + | null show_these + = hang herald + 2 (vcat [ not_in_scope_msg empty + , flag_hint ]) + + | otherwise + = hang herald + 2 (vcat [ pprInstances show_these + , ppWhen (n_in_scope_hidden > 0) $ + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , not_in_scope_msg (text "...plus") + , flag_hint ]) + where + n_show = 3 :: Int + + (in_scope, not_in_scope) = partition inst_in_scope insts + sorted = sortBy fuzzyClsInstCmp in_scope + show_these | show_potentials = sorted + | otherwise = take n_show sorted + n_in_scope_hidden = length sorted - length show_these + + -- "in scope" means that all the type constructors + -- are lexically in scope; these instances are likely + -- to be more useful + inst_in_scope :: ClsInst -> Bool + inst_in_scope cls_inst = nameSetAll name_in_scope $ + orphNamesOfTypes (is_tys cls_inst) + + name_in_scope name + | isBuiltInSyntax name + = True -- E.g. (->) + | Just mod <- nameModule_maybe name + = qual_in_scope (qualName sty mod (nameOccName name)) + | otherwise + = True + + qual_in_scope :: QualifyName -> Bool + qual_in_scope NameUnqual = True + qual_in_scope (NameQual {}) = True + qual_in_scope _ = False + + not_in_scope_msg herald + | null not_in_scope + = empty + | otherwise + = hang (herald <+> speakNOf (length not_in_scope) (text "instance") + <+> text "involving out-of-scope types") + 2 (ppWhen show_potentials (pprInstances not_in_scope)) + + flag_hint = ppUnless (show_potentials || equalLength show_these insts) $ + text "(use -fprint-potential-instances to see them all)" + +{- Note [Displaying potential instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When showing a list of instances for + - overlapping instances (show ones that match) + - no such instance (show ones that could match) +we want to give it a bit of structure. Here's the plan + +* Say that an instance is "in scope" if all of the + type constructors it mentions are lexically in scope. + These are the ones most likely to be useful to the programmer. + +* Show at most n_show in-scope instances, + and summarise the rest ("plus 3 others") + +* Summarise the not-in-scope instances ("plus 4 not in scope") + +* Add the flag -fshow-potential-instances which replaces the + summary with the full list +-} + +{- +Note [Flattening in error message generation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (C (Maybe (F x))), where F is a type function, and we have +instances + C (Maybe Int) and C (Maybe a) +Since (F x) might turn into Int, this is an overlap situation, and +indeed (because of flattening) the main solver will have refrained +from solving. But by the time we get to error message generation, we've +un-flattened the constraint. So we must *re*-flatten it before looking +up in the instance environment, lest we only report one matching +instance when in fact there are two. + +Re-flattening is pretty easy, because we don't need to keep track of +evidence. We don't re-use the code in GHC.Tc.Solver.Canonical because that's in +the TcS monad, and we are in TcM here. + +Note [Kind arguments in error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (#9171) + + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ + +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. + +To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag +whenever any error message arises due to a kind mismatch. This means that +the above error message would instead be displayed as: + + Couldn't match expected type + ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ + with actual type + ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ + +Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. +-} + +mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence + -> Ct -> (Bool, SDoc) +mkAmbigMsg prepend_msg ct + | null ambig_kvs && null ambig_tvs = (False, empty) + | otherwise = (True, msg) + where + (ambig_kvs, ambig_tvs) = getAmbigTkvs ct + + msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] + || any isRuntimeUnkSkol ambig_tvs + = vcat [ text "Cannot resolve unknown runtime type" + <> plural ambig_tvs <+> pprQuotedList ambig_tvs + , text "Use :print or :force to determine these types"] + + | not (null ambig_tvs) + = pp_ambig (text "type") ambig_tvs + + | otherwise + = pp_ambig (text "kind") ambig_kvs + + pp_ambig what tkvs + | prepend_msg -- "Ambiguous type variable 't0'" + = text "Ambiguous" <+> what <+> text "variable" + <> plural tkvs <+> pprQuotedList tkvs + + | otherwise -- "The type variable 't0' is ambiguous" + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" + +pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc +pprSkols ctxt tvs + = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) + where + pp_one (UnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown") + pp_one (RuntimeUnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown runtime") + pp_one (skol_info, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "rigid" <+> text "bound by") + , nest 2 (pprSkolInfo skol_info) + , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] + + is_or_are [_] article adjective = text "is" <+> text article <+> text adjective + <+> text "type variable" + is_or_are _ _ adjective = text "are" <+> text adjective + <+> text "type variables" + +getAmbigTkvs :: Ct -> ([Var],[Var]) +getAmbigTkvs ct + = partition (`elemVarSet` dep_tkv_set) ambig_tkvs + where + tkvs = tyCoVarsOfCtList ct + ambig_tkvs = filter isAmbiguousTyVar tkvs + dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) + +getSkolemInfo :: [Implication] -> [TcTyVar] + -> [(SkolemInfo, [TcTyVar])] -- #14628 +-- Get the skolem info for some type variables +-- from the implication constraints that bind them. +-- +-- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty +getSkolemInfo _ [] + = [] + +getSkolemInfo [] tvs + | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 + | otherwise = pprPanic "No skolem info:" (ppr tvs) + +getSkolemInfo (implic:implics) tvs + | null tvs_here = getSkolemInfo implics tvs + | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other + where + (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs + +----------------------- +-- relevantBindings looks at the value environment and finds values whose +-- types mention any of the offending type variables. It has to be +-- careful to zonk the Id's type first, so it has to be in the monad. +-- We must be careful to pass it a zonked type variable, too. +-- +-- We always remove closed top-level bindings, though, +-- since they are never relevant (cf #8233) + +relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering + -- See #8191 + -> ReportErrCtxt -> Ct + -> TcM (ReportErrCtxt, SDoc, Ct) +-- Also returns the zonked and tidied CtOrigin of the constraint +relevantBindings want_filtering ctxt ct + = do { traceTc "relevantBindings" (ppr ct) + ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + + -- For *kind* errors, report the relevant bindings of the + -- enclosing *type* equality, because that's more useful for the programmer + ; let extra_tvs = case tidy_orig of + KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ + t1 : maybeToList m_t2 + _ -> emptyVarSet + ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs + + -- Put a zonked, tidied CtOrigin into the Ct + loc' = setCtLocOrigin loc tidy_orig + ct' = setCtLoc ct loc' + ctxt1 = ctxt { cec_tidy = env1 } + + ; (ctxt2, doc) <- relevant_bindings want_filtering ctxt1 lcl_env ct_fvs + ; return (ctxt2, doc, ct') } + where + loc = ctLoc ct + lcl_env = ctLocEnv loc + +-- slightly more general version, to work also with holes +relevant_bindings :: Bool + -> ReportErrCtxt + -> TcLclEnv + -> TyCoVarSet + -> TcM (ReportErrCtxt, SDoc) +relevant_bindings want_filtering ctxt lcl_env ct_tvs + = do { dflags <- getDynFlags + ; traceTc "relevant_bindings" $ + vcat [ ppr ct_tvs + , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) + | TcIdBndr id _ <- tcl_bndrs lcl_env ] + , pprWithCommas id + [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] + + ; (tidy_env', docs, discards) + <- go dflags (cec_tidy ctxt) (maxRelevantBinds dflags) + emptyVarSet [] False + (removeBindingShadowing $ tcl_bndrs lcl_env) + -- tcl_bndrs has the innermost bindings first, + -- which are probably the most relevant ones + + ; let doc = ppUnless (null docs) $ + hang (text "Relevant bindings include") + 2 (vcat docs $$ ppWhen discards discardMsg) + + ctxt' = ctxt { cec_tidy = tidy_env' } + + ; return (ctxt', doc) } + where + run_out :: Maybe Int -> Bool + run_out Nothing = False + run_out (Just n) = n <= 0 + + dec_max :: Maybe Int -> Maybe Int + dec_max = fmap (\n -> n - 1) + + + go :: DynFlags -> TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc] + -> Bool -- True <=> some filtered out due to lack of fuel + -> [TcBinder] + -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out + -- because of lack of fuel + go _ tidy_env _ _ docs discards [] + = return (tidy_env, reverse docs, discards) + go dflags tidy_env n_left tvs_seen docs discards (tc_bndr : tc_bndrs) + = case tc_bndr of + TcTvBndr {} -> discard_it + TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl + TcIdBndr_ExpType name et top_lvl -> + do { mb_ty <- readExpType_maybe et + -- et really should be filled in by now. But there's a chance + -- it hasn't, if, say, we're reporting a kind error en route to + -- checking a term. See test indexed-types/should_fail/T8129 + -- Or we are reporting errors from the ambiguity check on + -- a local type signature + ; case mb_ty of + Just ty -> go2 name ty top_lvl + Nothing -> discard_it -- No info; discard + } + where + discard_it = go dflags tidy_env n_left tvs_seen docs + discards tc_bndrs + go2 id_name id_type top_lvl + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type + ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) + ; let id_tvs = tyCoVarsOfType tidy_ty + doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (text "bound at" + <+> ppr (getSrcLoc id_name)))] + new_seen = tvs_seen `unionVarSet` id_tvs + + ; if (want_filtering && not (hasPprDebug dflags) + && id_tvs `disjointVarSet` ct_tvs) + -- We want to filter out this binding anyway + -- so discard it silently + then discard_it + + else if isTopLevel top_lvl && not (isNothing n_left) + -- It's a top-level binding and we have not specified + -- -fno-max-relevant-bindings, so discard it silently + then discard_it + + else if run_out n_left && id_tvs `subVarSet` tvs_seen + -- We've run out of n_left fuel and this binding only + -- mentions already-seen type variables, so discard it + then go dflags tidy_env n_left tvs_seen docs + True -- Record that we have now discarded something + tc_bndrs + + -- Keep this binding, decrement fuel + else go dflags tidy_env' (dec_max n_left) new_seen + (doc:docs) discards tc_bndrs } + + +discardMsg :: SDoc +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + +----------------------- +warnDefaulting :: [Ct] -> Type -> TcM () +warnDefaulting wanteds default_ty + = do { warn_default <- woptM Opt_WarnTypeDefaults + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyCoVars env0 $ + tyCoVarsOfCtsList (listToBag wanteds) + tidy_wanteds = map (tidyCt tidy_env) wanteds + (loc, ppr_wanteds) = pprWithArising tidy_wanteds + warn_msg = + hang (hsep [ text "Defaulting the following" + , text "constraint" <> plural tidy_wanteds + , text "to type" + , quotes (ppr default_ty) ]) + 2 + ppr_wanteds + ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg } + +{- +Note [Runtime skolems] +~~~~~~~~~~~~~~~~~~~~~~ +We want to give a reasonably helpful error message for ambiguity +arising from *runtime* skolems in the debugger. These +are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. + +************************************************************************ +* * + Error from the canonicaliser + These ones are called *during* constraint simplification +* * +************************************************************************ +-} + +solverDepthErrorTcS :: CtLoc -> TcType -> TcM a +solverDepthErrorTcS loc ty + = setCtLocM loc $ + do { ty <- zonkTcType ty + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) + tidy_ty = tidyType tidy_env ty + msg + = vcat [ text "Reduction stack overflow; size =" <+> ppr depth + , hang (text "When simplifying the following type:") + 2 (ppr tidy_ty) + , note ] + ; failWithTcM (tidy_env, msg) } + where + depth = ctLocDepth loc + note = vcat + [ text "Use -freduction-depth=0 to disable this check" + , text "(any upper bound you could choose might fail unpredictably with" + , text " minor updates to GHC, so disabling the check is recommended if" + , text " you're sure that type checking should terminate)" ] diff --git a/GHC/Tc/Errors/Hole.hs b/GHC/Tc/Errors/Hole.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole.hs @@ -0,0 +1,984 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Tc.Errors.Hole + ( findValidHoleFits + , tcCheckHoleFit + , withoutUnification + , tcSubsumes + , isFlexiTyVar + , tcFilterHoleFits + , getLocalBindings + , pprHoleFit + , addHoleFitDocs + , getHoleFitSortingAlg + , getHoleFitDispConfig + , HoleFitDispConfig (..) + , HoleFitSortingAlg (..) + , relevantCts + , zonkSubs + + , sortHoleFitsByGraph + , sortHoleFitsBySize + + + -- Re-exported from GHC.Tc.Errors.Hole.FitTypes + , HoleFitPlugin (..), HoleFitPluginR (..) + ) +where + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.DataCon +import GHC.Types.Name +import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) +import GHC.Builtin.Names ( gHC_ERR ) +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Data.Bag +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Utils.Misc +import GHC.Tc.Utils.Env (tcLookup) +import GHC.Utils.Outputable +import GHC.Driver.Session +import GHC.Data.Maybe +import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) + +import Control.Arrow ( (&&&) ) + +import Control.Monad ( filterM, replicateM, foldM ) +import Data.List ( partition, sort, sortOn, nubBy ) +import Data.Graph ( graphFromEdges, topSort ) + + +import GHC.Tc.Solver ( simpl_top, runTcSDeriveds ) +import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) + +import GHC.HsToCore.Docs ( extractDocs ) +import qualified Data.Map as Map +import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) +import GHC.Driver.Types ( ModIface_(..) ) +import GHC.Iface.Load ( loadInterfaceForNameMaybe ) + +import GHC.Builtin.Utils (knownKeyNames) + +import GHC.Tc.Errors.Hole.FitTypes + + +{- +Note [Valid hole fits include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`findValidHoleFits` returns the "Valid hole fits include ..." message. +For example, look at the following definitions in a file called test.hs: + + import Data.List (inits) + + f :: [String] + f = _ "hello, world" + +The hole in `f` would generate the message: + + • Found hole: _ :: [Char] -> [String] + • In the expression: _ + In the expression: _ "hello, world" + In an equation for ‘f’: f = _ "hello, world" + • Relevant bindings include f :: [String] (bound at test.hs:6:1) + Valid hole fits include + lines :: String -> [String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + words :: String -> [String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + inits :: forall a. [a] -> [[a]] + with inits @Char + (imported from ‘Data.List’ at mpt.hs:4:19-23 + (and originally defined in ‘base-4.11.0.0:Data.OldList’)) + repeat :: forall a. a -> [a] + with repeat @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.List’)) + fail :: forall (m :: * -> *). Monad m => forall a. String -> m a + with fail @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + return :: forall (m :: * -> *). Monad m => forall a. a -> m a + with return @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a + with pure @[] @String + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + read :: forall a. Read a => String -> a + with read @[String] + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘Text.Read’)) + mempty :: forall a. Monoid a => a + with mempty @([Char] -> [String]) + (imported from ‘Prelude’ at mpt.hs:3:8-9 + (and originally defined in ‘GHC.Base’)) + +Valid hole fits are found by checking top level identifiers and local bindings +in scope for whether their type can be instantiated to the type of the hole. +Additionally, we also need to check whether all relevant constraints are solved +by choosing an identifier of that type as well, see Note [Relevant constraints] + +Since checking for subsumption results in the side-effect of type variables +being unified by the simplifier, we need to take care to restore them after +to being flexible type variables after we've checked for subsumption. +This is to avoid affecting the hole and later checks by prematurely having +unified one of the free unification variables. + +When outputting, we sort the hole fits by the size of the types we'd need to +apply by type application to the type of the fit to make it fit. This is done +in order to display "more relevant" suggestions first. Another option is to +sort by building a subsumption graph of fits, i.e. a graph of which fits subsume +what other fits, and then outputting those fits which are subsumed by other +fits (i.e. those more specific than other fits) first. This results in the ones +"closest" to the type of the hole to be displayed first. + +To help users understand how the suggested fit works, we also display the values +that the quantified type variables would take if that fit is used, like +`mempty @([Char] -> [String])` and `pure @[] @String` in the example above. +If -XTypeApplications is enabled, this can even be copied verbatim as a +replacement for the hole. + +Note [Checking hole fits] +~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a hole of type hole_ty, we want to know whether a variable +of type ty is a valid fit for the whole. This is a subsumption check: +we wish to know whether ty <: hole_ty. But, of course, the check +must take into account any givens and relevant constraints. +(See also Note [Relevant constraints]). + +For the simplifier to be able to use any givens present in the enclosing +implications to solve relevant constraints, we nest the wanted subsumption +constraints and relevant constraints within the enclosing implications. + +As an example, let's look at the following code: + + f :: Show a => a -> String + f x = show _ + +Suppose the hole is assigned type a0_a1pd[tau:2]. +Here the nested implications are just one level deep, namely: + + [Implic { + TcLevel = 2 + Skolems = a_a1pa[sk:2] + No-eqs = True + Status = Unsolved + Given = $dShow_a1pc :: Show a_a1pa[sk:2] + Wanted = + WC {wc_simple = + [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))} + Binds = EvBindsVar + Needed inner = [] + Needed outer = [] + the type signature for: + f :: forall a. Show a => a -> String }] + +As we can see, the givens say that the skolem +`a_a1pa[sk:2]` fulfills the Show constraint, and that we must prove +the [W] Show a0_a1pd[tau:2] constraint -- that is, whatever fills the +hole must have a Show instance. + +When we now check whether `x :: a_a1pa[sk:2]` fits the hole in +`tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type +variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints +needed by tcSubType_NC and the relevant constraints (see Note [Relevant +Constraints] for more details) in the nested implications, we can pass the +information in the givens along to the simplifier. For our example, we end up +needing to check whether the following constraints are soluble. + + WC {wc_impl = + Implic { + TcLevel = 2 + Skolems = a_a1pa[sk:2] + No-eqs = True + Status = Unsolved + Given = $dShow_a1pc :: Show a_a1pa[sk:2] + Wanted = + WC {wc_simple = + [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} + Binds = EvBindsVar + Needed inner = [] + Needed outer = [] + the type signature for: + f :: forall a. Show a => a -> String }} + +But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested +implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up +with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match. + +To avoid side-effects on the nested implications, we create a new EvBindsVar so +that any changes to the ev binds during a check remains localised to that check. +In addition, we call withoutUnification to reset any unified metavariables; this +call is actually done outside tcCheckHoleFit so that the results can be formatted +for the user before resetting variables. + +Note [Valid refinement hole fits include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the `-frefinement-level-hole-fits=N` flag is given, we additionally look +for "valid refinement hole fits"", i.e. valid hole fits with up to N +additional holes in them. + +With `-frefinement-level-hole-fits=0` (the default), GHC will find all +identifiers 'f' (top-level or nested) that will fit in the hole. + +With `-frefinement-level-hole-fits=1`, GHC will additionally find all +applications 'f _' that will fit in the hole, where 'f' is an in-scope +identifier, applied to single argument. It will also report the type of the +needed argument (a new hole). + +And similarly as the number of arguments increases + +As an example, let's look at the following code: + + f :: [Integer] -> Integer + f = _ + +with `-frefinement-level-hole-fits=1`, we'd get: + + Valid refinement hole fits include + + foldl1 (_ :: Integer -> Integer -> Integer) + with foldl1 @[] @Integer + where foldl1 :: forall (t :: * -> *). + Foldable t => + forall a. (a -> a -> a) -> t a -> a + foldr1 (_ :: Integer -> Integer -> Integer) + with foldr1 @[] @Integer + where foldr1 :: forall (t :: * -> *). + Foldable t => + forall a. (a -> a -> a) -> t a -> a + const (_ :: Integer) + with const @Integer @[Integer] + where const :: forall a b. a -> b -> a + ($) (_ :: [Integer] -> Integer) + with ($) @'GHC.Types.LiftedRep @[Integer] @Integer + where ($) :: forall a b. (a -> b) -> a -> b + fail (_ :: String) + with fail @((->) [Integer]) @Integer + where fail :: forall (m :: * -> *). + Monad m => + forall a. String -> m a + return (_ :: Integer) + with return @((->) [Integer]) @Integer + where return :: forall (m :: * -> *). Monad m => forall a. a -> m a + (Some refinement hole fits suppressed; + use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits) + +Which are hole fits with holes in them. This allows e.g. beginners to +discover the fold functions and similar, but also allows for advanced users +to figure out the valid functions in the Free monad, e.g. + + instance Functor f => Monad (Free f) where + Pure a >>= f = f a + Free f >>= g = Free (fmap _a f) + +Will output (with -frefinment-level-hole-fits=1): + Found hole: _a :: Free f a -> Free f b + Where: ‘a’, ‘b’ are rigid type variables bound by + the type signature for: + (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b + at fms.hs:25:12-14 + ‘f’ is a rigid type variable bound by + ... + Relevant bindings include + g :: a -> Free f b (bound at fms.hs:27:16) + f :: f (Free f a) (bound at fms.hs:27:10) + (>>=) :: Free f a -> (a -> Free f b) -> Free f b + (bound at fms.hs:25:12) + ... + Valid refinement hole fits include + ... + (=<<) (_ :: a -> Free f b) + with (=<<) @(Free f) @a @b + where (=<<) :: forall (m :: * -> *) a b. + Monad m => + (a -> m b) -> m a -> m b + (imported from ‘Prelude’ at fms.hs:5:18-22 + (and originally defined in ‘GHC.Base’)) + ... + +Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`). + +We find these refinement suggestions by considering hole fits that don't +fit the type of the hole, but ones that would fit if given an additional +argument. We do this by creating a new type variable with `newOpenFlexiTyVar` +(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type +`t_a1/m[tau:1] -> v` where `v` is the type of the hole. + +Since the simplifier is free to unify this new type variable with any type, we +can discover any identifiers that would fit if given another identifier of a +suitable type. This is then generalized so that we can consider any number of +additional arguments by setting the `-frefinement-level-hole-fits` flag to any +number, and then considering hole fits like e.g. `foldl _ _` with two additional +arguments. + +To make sure that the refinement hole fits are useful, we check that the types +of the additional holes have a concrete value and not just an invented type +variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`, +and limits the number of less than useful refinement hole fits. + +Additionally, to further aid the user in their implementation, we show the +types of the holes the binding would have to be applied to in order to work. +In the free monad example above, this is demonstrated with +`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to +be applied to an expression of type `a -> Free f b` in order to match. +If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim. + +Note [Relevant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As highlighted by #14273, we need to check any relevant constraints as well +as checking for subsumption. Relevant constraints are the simple constraints +whose free unification variables are mentioned in the type of the hole. + +In the simplest case, these are all non-hole constraints in the simples, such +as is the case in + + f :: String + f = show _ + +Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is: + + [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical) + +However, when there are multiple holes, we need to be more careful. As an +example, Let's take a look at the following code: + + f :: Show a => a -> String + f x = show (_b (show _a)) + +Here there are two holes, `_a` and `_b`. Suppose _a :: a0_a1pd[tau:2] and +_b :: a1_a1po[tau:2]. Then, the simple constraints passed to +findValidHoleFits are: + + [[WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), + [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] + +When we are looking for a match for the hole `_a`, we filter the simple +constraints to the "Relevant constraints", by throwing out any constraints +which do not mention a variable mentioned in the type of the hole. For hole +`_a`, we will then only require that the `$dShow_a1pe` constraint is solved, +since that is the only constraint that mentions any free type variables +mentioned in the hole constraint for `_a`, namely `a_a1pd[tau:2]`, and +similarly for the hole `_b` we only require that the `$dShow_a1pe` constraint +is solved. + +Note [Leaking errors] +~~~~~~~~~~~~~~~~~~~~~ +When considering candidates, GHC believes that we're checking for validity in +actual source. However, As evidenced by #15321, #15007 and #15202, this can +cause bewildering error messages. The solution here is simple: if a candidate +would cause the type checker to error, it is not a valid hole fit, and thus it +is discarded. + +-} + +data HoleFitDispConfig = HFDC { showWrap :: Bool + , showWrapVars :: Bool + , showType :: Bool + , showProv :: Bool + , showMatches :: Bool } + +-- We read the various -no-show-*-of-hole-fits flags +-- and set the display config accordingly. +getHoleFitDispConfig :: TcM HoleFitDispConfig +getHoleFitDispConfig + = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits + ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits + ; sType <- goptM Opt_ShowTypeOfHoleFits + ; sProv <- goptM Opt_ShowProvOfHoleFits + ; sMatc <- goptM Opt_ShowMatchesOfHoleFits + ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars + , showProv = sProv, showType = sType + , showMatches = sMatc } } + +-- Which sorting algorithm to use +data HoleFitSortingAlg = HFSNoSorting -- Do not sort the fits at all + | HFSBySize -- Sort them by the size of the match + | HFSBySubsumption -- Sort by full subsumption + deriving (Eq, Ord) + +getHoleFitSortingAlg :: TcM HoleFitSortingAlg +getHoleFitSortingAlg = + do { shouldSort <- goptM Opt_SortValidHoleFits + ; subsumSort <- goptM Opt_SortBySubsumHoleFits + ; sizeSort <- goptM Opt_SortBySizeHoleFits + -- We default to sizeSort unless it has been explicitly turned off + -- or subsumption sorting has been turned on. + ; return $ if not shouldSort + then HFSNoSorting + else if subsumSort + then HFSBySubsumption + else if sizeSort + then HFSBySize + else HFSNoSorting } + +-- If enabled, we go through the fits and add any associated documentation, +-- by looking it up in the module or the environment (for local fits) +addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] +addHoleFitDocs fits = + do { showDocs <- goptM Opt_ShowDocsOfHoleFits + ; if showDocs + then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv + ; mapM (upd lclDocs) fits } + else return fits } + where + msg = text "GHC.Tc.Errors.Hole addHoleFitDocs" + lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) + = Map.lookup name dmap + upd lclDocs fit@(HoleFit {hfCand = cand}) = + do { let name = getName cand + ; doc <- if hfIsLcl fit + then pure (Map.lookup name lclDocs) + else do { mbIface <- loadInterfaceForNameMaybe msg name + ; return $ mbIface >>= lookupInIface name } + ; return $ fit {hfDoc = doc} } + upd _ fit = return fit + +-- For pretty printing hole fits, we display the name and type of the fit, +-- with added '_' to represent any extra arguments in case of a non-zero +-- refinement level. +pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc +pprHoleFit _ (RawHoleFit sd) = sd +pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = + hang display 2 provenance + where name = getName hfCand + tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap + where pprArg b arg = case binderArgFlag b of + -- See Note [Explicit Case Statement for Specificity] + (Invisible spec) -> case spec of + SpecifiedSpec -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + InferredSpec -> empty + Required -> pprPanic "pprHoleFit: bad Required" + (ppr b <+> ppr arg) + tyAppVars = sep $ punctuate comma $ + zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> + text "~" <+> pprParendType t) + vars hfWrap + + vars = unwrapTypeVars hfType + where + -- Attempts to get all the quantified type variables in a type, + -- e.g. + -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) + -- into [m, a] + unwrapTypeVars :: Type -> [TyCoVarBinder] + unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of + Just (_, _, unfunned) -> unwrapTypeVars unfunned + _ -> [] + where (vars, unforalled) = splitForAllVarBndrs t + holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches + holeDisp = if sMs then holeVs + else sep $ replicate (length hfMatches) $ text "_" + occDisp = pprPrefixOcc name + tyDisp = ppWhen sTy $ dcolon <+> ppr hfType + has = not . null + wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) + $ text "with" <+> if sWrp || not sTy + then occDisp <+> tyApp + else tyAppVars + docs = case hfDoc of + Just d -> text "{-^" <> + (vcat . map text . lines . unpackHDS) d + <> text "-}" + _ -> empty + funcInfo = ppWhen (has hfMatches && sTy) $ + text "where" <+> occDisp <+> tyDisp + subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp + display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) + provenance = ppWhen sProv $ parens $ + case hfCand of + GreHFCand gre -> pprNameProvenance gre + _ -> text "bound at" <+> ppr (getSrcLoc name) + +getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] +getLocalBindings tidy_orig ct_loc + = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc) + ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) } + where + lcl_env = ctLocEnv ct_loc + + go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id] + go _ sofar [] = return (reverse sofar) + go env sofar (tc_bndr : tc_bndrs) = + case tc_bndr of + TcIdBndr id _ -> keep_it id + _ -> discard_it + where + discard_it = go env sofar tc_bndrs + keep_it id = go env (id:sofar) tc_bndrs + + + +-- See Note [Valid hole fits include ...] +findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking + -> [Implication] -- ^ Enclosing implications for givens + -> [Ct] + -- ^ The unsolved simple constraints in the implication for + -- the hole. + -> Hole + -> TcM (TidyEnv, SDoc) +findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ + , hole_loc = ct_loc + , hole_ty = hole_ty }) = + do { rdr_env <- getGlobalRdrEnv + ; lclBinds <- getLocalBindings tidy_env ct_loc + ; maxVSubs <- maxValidHoleFits <$> getDynFlags + ; hfdc <- getHoleFitDispConfig + ; sortingAlg <- getHoleFitSortingAlg + ; dflags <- getDynFlags + ; hfPlugs <- tcg_hf_plugins <$> getGblEnv + ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs + refLevel = refLevelHoleFits dflags + hole = TypedHole { th_relevant_cts = + listToBag (relevantCts hole_ty simples) + , th_implics = implics + , th_hole = Just h } + (candidatePlugins, fitPlugins) = + unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs + ; traceTc "findingValidHoleFitsFor { " $ ppr hole + ; traceTc "hole_lvl is:" $ ppr hole_lvl + ; traceTc "simples are: " $ ppr simples + ; traceTc "locals are: " $ ppr lclBinds + ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env) + -- We remove binding shadowings here, but only for the local level. + -- this is so we e.g. suggest the global fmap from the Functor class + -- even though there is a local definition as well, such as in the + -- Free monad example. + locals = removeBindingShadowing $ + map IdHFCand lclBinds ++ map GreHFCand lcl + globals = map GreHFCand gbl + syntax = map NameHFCand builtIns + to_check = locals ++ syntax ++ globals + ; cands <- foldM (flip ($)) to_check candidatePlugins + ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) + ; (searchDiscards, subs) <- + tcFilterHoleFits findVLimit hole (hole_ty, []) cands + ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs + ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs + ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins + ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs + vDiscards = pVDisc || searchDiscards + ; subs_with_docs <- addHoleFitDocs limited_subs + ; let vMsg = ppUnless (null subs_with_docs) $ + hang (text "Valid hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) subs_with_docs) + $$ ppWhen vDiscards subsDiscardMsg + -- Refinement hole fits. See Note [Valid refinement hole fits include ...] + ; (tidy_env, refMsg) <- if refLevel >= Just 0 then + do { maxRSubs <- maxRefHoleFits <$> getDynFlags + -- We can use from just, since we know that Nothing >= _ is False. + ; let refLvls = [1..(fromJust refLevel)] + -- We make a new refinement type for each level of refinement, where + -- the level of refinement indicates number of additional arguments + -- to allow. + ; ref_tys <- mapM mkRefTy refLvls + ; traceTc "ref_tys are" $ ppr ref_tys + ; let findRLimit = if sortingAlg > HFSNoSorting then Nothing + else maxRSubs + ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) + cands) ref_tys + ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs + ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs + -- For refinement substitutions we want matches + -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t), + -- and others in that vein to appear last, since these are + -- unlikely to be the most relevant fits. + ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty + ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap + (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs + ; plugin_handled_rsubs <- foldM (flip ($)) + (not_exact ++ exact) fitPlugins + ; let (pRDisc, exact_last_rfits) = + possiblyDiscard maxRSubs $ plugin_handled_rsubs + rDiscards = pRDisc || any fst refDs + ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits + ; return (tidy_env, + ppUnless (null rsubs_with_docs) $ + hang (text "Valid refinement hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) rsubs_with_docs) + $$ ppWhen rDiscards refSubsDiscardMsg) } + else return (tidy_env, empty) + ; traceTc "findingValidHoleFitsFor }" empty + ; return (tidy_env, vMsg $$ refMsg) } + where + -- We extract the TcLevel from the constraint. + hole_lvl = ctLocLevel ct_loc + + -- BuiltInSyntax names like (:) and [] + builtIns :: [Name] + builtIns = filter isBuiltInSyntax knownKeyNames + + -- We make a refinement type by adding a new type variable in front + -- of the type of t h hole, going from e.g. [Integer] -> Integer + -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier + -- to unify the new type variable with any type, allowing us + -- to suggest a "refinement hole fit", like `(foldl1 _)` instead + -- of only concrete hole fits like `sum`. + mkRefTy :: Int -> TcM (TcType, [TcTyVar]) + mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars + where newTyVars = replicateM refLvl $ setLvl <$> + (newOpenTypeKind >>= newFlexiTyVar) + setLvl = flip setMetaTyVarTcLevel hole_lvl + wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty + + sortFits :: HoleFitSortingAlg -- How we should sort the hole fits + -> [HoleFit] -- The subs to sort + -> TcM [HoleFit] + sortFits HFSNoSorting subs = return subs + sortFits HFSBySize subs + = (++) <$> sortHoleFitsBySize (sort lclFits) + <*> sortHoleFitsBySize (sort gblFits) + where (lclFits, gblFits) = span hfIsLcl subs + -- To sort by subsumption, we invoke the sortByGraph function, which + -- builds the subsumption graph for the fits and then sorts them using a + -- graph sort. Since we want locals to come first anyway, we can sort + -- them separately. The substitutions are already checked in local then + -- global order, so we can get away with using span here. + -- We use (<*>) to expose the parallelism, in case it becomes useful later. + sortFits HFSBySubsumption subs + = (++) <$> sortHoleFitsByGraph (sort lclFits) + <*> sortHoleFitsByGraph (sort gblFits) + where (lclFits, gblFits) = span hfIsLcl subs + + subsDiscardMsg :: SDoc + subsDiscardMsg = + text "(Some hole fits suppressed;" <+> + text "use -fmax-valid-hole-fits=N" <+> + text "or -fno-max-valid-hole-fits)" + + refSubsDiscardMsg :: SDoc + refSubsDiscardMsg = + text "(Some refinement hole fits suppressed;" <+> + text "use -fmax-refinement-hole-fits=N" <+> + text "or -fno-max-refinement-hole-fits)" + + + -- Based on the flags, we might possibly discard some or all the + -- fits we've found. + possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) + possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits) + possiblyDiscard Nothing fits = (False, fits) + + +-- We don't (as of yet) handle holes in types, only in expressions. +findValidHoleFits env _ _ _ = return (env, empty) + +-- See Note [Relevant constraints] +relevantCts :: Type -> [Ct] -> [Ct] +relevantCts hole_ty simples = if isEmptyVarSet (fvVarSet hole_fvs) then [] + else filter isRelevant simples + where ctFreeVarSet :: Ct -> VarSet + ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred + hole_fvs = tyCoFVsOfType hole_ty + hole_fv_set = fvVarSet hole_fvs + anyFVMentioned :: Ct -> Bool + anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set + -- We filter out those constraints that have no variables (since + -- they won't be solved by finding a type for the type variable + -- representing the hole) and also other holes, since we're not + -- trying to find hole fits for many holes at once. + isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct)) + && anyFVMentioned ct + +-- We zonk the hole fits so that the output aligns with the rest +-- of the typed hole error message output. +zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) +zonkSubs = zonkSubs' [] + where zonkSubs' zs env [] = return (env, reverse zs) + zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf + ; zonkSubs' (z:zs) env' hfs } + + zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit) + zonkSub env hf@RawHoleFit{} = return (env, hf) + zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp} + = do { (env, ty') <- zonkTidyTcType env ty + ; (env, m') <- zonkTidyTcTypes env m + ; (env, wrp') <- zonkTidyTcTypes env wrp + ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} + ; return (env, zFit ) } + +-- | Sort by size uses as a measure for relevance the sizes of the different +-- types needed to instantiate the fit to the type of the hole. +-- This is much quicker than sorting by subsumption, and gives reasonable +-- results in most cases. +sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] +sortHoleFitsBySize = return . sortOn sizeOfFit + where sizeOfFit :: HoleFit -> TypeSize + sizeOfFit = sizeTypes . nubBy tcEqType . hfWrap + +-- Based on a suggestion by phadej on #ghc, we can sort the found fits +-- by constructing a subsumption graph, and then do a topological sort of +-- the graph. This makes the most specific types appear first, which are +-- probably those most relevant. This takes a lot of work (but results in +-- much more useful output), and can be disabled by +-- '-fno-sort-valid-hole-fits'. +sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit] +sortHoleFitsByGraph fits = go [] fits + where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool + tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty) + where fvs = tyCoFVsOfTypes [ht,ty] + go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit] + go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar + ; return $ uncurry (++) $ partition hfIsLcl topSorted } + where toV (hf, adjs) = (hf, hfId hf, map hfId adjs) + (graph, fromV, _) = graphFromEdges $ map toV sofar + topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph + go sofar (hf:hfs) = + do { adjs <- filterM (tcSubsumesWCloning (hfType hf) . hfType) fits + ; go ((hf, adjs):sofar) hfs } + +-- | tcFilterHoleFits filters the candidates by whether, given the implications +-- and the relevant constraints, they can be made to match the type by +-- running the type checker. Stops after finding limit matches. +tcFilterHoleFits :: Maybe Int + -- ^ How many we should output, if limited + -> TypedHole -- ^ The hole to filter against + -> (TcType, [TcTyVar]) + -- ^ The type to check for fits and a list of refinement + -- variables (free type variables in the type) for emulating + -- additional holes. + -> [HoleFitCandidate] + -- ^ The candidates to check whether fit. + -> TcM (Bool, [HoleFit]) + -- ^ We return whether or not we stopped due to hitting the limit + -- and the fits we found. +tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 +tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates = + do { traceTc "checkingFitsFor {" $ ppr hole_ty + ; (discards, subs) <- go [] emptyVarSet limit ht candidates + ; traceTc "checkingFitsFor }" empty + ; return (discards, subs) } + where + hole_fvs :: FV + hole_fvs = tyCoFVsOfType hole_ty + -- Kickoff the checking of the elements. + -- We iterate over the elements, checking each one in turn for whether + -- it fits, and adding it to the results if it does. + go :: [HoleFit] -- What we've found so far. + -> VarSet -- Ids we've already checked + -> Maybe Int -- How many we're allowed to find, if limited + -> (TcType, [TcTyVar]) -- The type, and its refinement variables. + -> [HoleFitCandidate] -- The elements we've yet to check. + -> TcM (Bool, [HoleFit]) + go subs _ _ _ [] = return (False, reverse subs) + go subs _ (Just 0) _ _ = return (True, reverse subs) + go subs seen maxleft ty (el:elts) = + -- See Note [Leaking errors] + tryTcDiscardingErrs discard_it $ + do { traceTc "lookingUp" $ ppr el + ; maybeThing <- lookup el + ; case maybeThing of + Just (id, id_ty) | not_trivial id -> + do { fits <- fitsHole ty id_ty + ; case fits of + Just (wrp, matches) -> keep_it id id_ty wrp matches + _ -> discard_it } + _ -> discard_it } + where + -- We want to filter out undefined and the likes from GHC.Err + not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR + + lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type)) + lookup (IdHFCand id) = return (Just (id, idType id)) + lookup hfc = do { thing <- tcLookup name + ; return $ case thing of + ATcId {tct_id = id} -> Just (id, idType id) + AGlobal (AnId id) -> Just (id, idType id) + AGlobal (AConLike (RealDataCon con)) -> + Just (dataConWrapId con, dataConNonlinearType con) + _ -> Nothing } + where name = case hfc of + IdHFCand id -> idName id + GreHFCand gre -> gre_name gre + NameHFCand name -> name + discard_it = go subs seen maxleft ty elts + keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) + ((\n -> n - 1) <$> maxleft) ty elts + where + fit = HoleFit { hfId = eid, hfCand = el, hfType = eid_ty + , hfRefLvl = length (snd ty) + , hfWrap = wrp, hfMatches = ms + , hfDoc = Nothing } + + + + + unfoldWrapper :: HsWrapper -> [Type] + unfoldWrapper = reverse . unfWrp' + where unfWrp' (WpTyApp ty) = [ty] + unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2 + unfWrp' _ = [] + + + -- The real work happens here, where we invoke the type checker using + -- tcCheckHoleFit to see whether the given type fits the hole. + fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the + -- refinement variables created to simulate + -- additional holes (if any), and the list + -- of those variables (possibly empty). + -- As an example: If the actual type of the + -- hole (as specified by the hole + -- constraint CHoleExpr passed to + -- findValidHoleFits) is t and we want to + -- simulate N additional holes, h_ty will + -- be r_1 -> ... -> r_N -> t, and + -- ref_vars will be [r_1, ... , r_N]. + -- In the base case with no additional + -- holes, h_ty will just be t and ref_vars + -- will be []. + -> TcType -- The type we're checking to whether it can be + -- instantiated to the type h_ty. + -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we + -- return Nothing. Otherwise, + -- we Just return the list of + -- types that quantified type + -- variables in ty would take + -- if used in place of h_ty, + -- and the list types of any + -- additional holes simulated + -- with the refinement + -- variables in ref_vars. + fitsHole (h_ty, ref_vars) ty = + -- We wrap this with the withoutUnification to avoid having side-effects + -- beyond the check, but we rely on the side-effects when looking for + -- refinement hole fits, so we can't wrap the side-effects deeper than this. + withoutUnification fvs $ + do { traceTc "checkingFitOf {" $ ppr ty + ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty + ; traceTc "Did it fit?" $ ppr fits + ; traceTc "wrap is: " $ ppr wrp + ; traceTc "checkingFitOf }" empty + ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) + -- We'd like to avoid refinement suggestions like `id _ _` or + -- `head _ _`, and only suggest refinements where our all phantom + -- variables got unified during the checking. This can be disabled + -- with the `-fabstract-refinement-hole-fits` flag. + -- Here we do the additional handling when there are refinement + -- variables, i.e. zonk them to read their final value to check for + -- abstract refinements, and to report what the type of the simulated + -- holes must be for this to be a match. + ; if fits + then if null ref_vars + then return (Just (z_wrp_tys, [])) + else do { let -- To be concrete matches, matches have to + -- be more than just an invented type variable. + fvSet = fvVarSet fvs + notAbstract :: TcType -> Bool + notAbstract t = case getTyVar_maybe t of + Just tv -> tv `elemVarSet` fvSet + _ -> True + allConcrete = all notAbstract z_wrp_tys + ; z_vars <- zonkTcTyVars ref_vars + ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars + ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs + ; allowAbstract <- goptM Opt_AbstractRefHoleFits + ; if allowAbstract || (allFilled && allConcrete ) + then return $ Just (z_wrp_tys, z_vars) + else return Nothing } + else return Nothing } + where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty + hole = typed_hole { th_hole = Nothing } + + + +-- | Checks whether a MetaTyVar is flexible or not. +isFlexiTyVar :: TcTyVar -> TcM Bool +isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv +isFlexiTyVar _ = return False + +-- | Takes a list of free variables and restores any Flexi type variables in +-- free_vars after the action is run. +withoutUnification :: FV -> TcM a -> TcM a +withoutUnification free_vars action = + do { flexis <- filterM isFlexiTyVar fuvs + ; result <- action + -- Reset any mutated free variables + ; mapM_ restore flexis + ; return result } + where restore tv = do { traceTc "withoutUnification: restore flexi" (ppr tv) + ; writeTcRef (metaTyVarRef tv) Flexi } + fuvs = fvVarList free_vars + +-- | Reports whether first type (ty_a) subsumes the second type (ty_b), +-- discarding any errors. Subsumption here means that the ty_b can fit into the +-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. +tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool +tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b + where dummyHole = TypedHole { th_relevant_cts = emptyBag + , th_implics = [] + , th_hole = Nothing } + +-- | A tcSubsumes which takes into account relevant constraints, to fix trac +-- #14273. This makes sure that when checking whether a type fits the hole, +-- the type has to be subsumed by type of the hole as well as fulfill all +-- constraints on the type of the hole. +tcCheckHoleFit :: TypedHole -- ^ The hole to check against + -> TcSigmaType + -- ^ The type to check against (possibly modified, e.g. refined) + -> TcSigmaType -- ^ The type to check whether fits. + -> TcM (Bool, HsWrapper) + -- ^ Whether it was a match, and the wrapper from hole_ty to ty. +tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty + = return (True, idHsWrapper) +tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $ + do { -- We wrap the subtype constraint in the implications to pass along the + -- givens, and so we must ensure that any nested implications and skolems + -- end up with the correct level. The implications are ordered so that + -- the innermost (the one with the highest level) is first, so it + -- suffices to get the level of the first one (or the current level, if + -- there are no implications involved). + innermost_lvl <- case th_implics of + [] -> getTcLevel + -- imp is the innermost implication + (imp:_) -> return (ic_tclvl imp) + ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ + tcSubTypeSigma ExprSigCtxt ty hole_ty + ; traceTc "Checking hole fit {" empty + ; traceTc "wanteds are: " $ ppr wanted + ; if isEmptyWC wanted && isEmptyBag th_relevant_cts + then do { traceTc "}" empty + ; return (True, wrap) } + else do { fresh_binds <- newTcEvBinds + -- The relevant constraints may contain HoleDests, so we must + -- take care to clone them as well (to avoid #15370). + ; cloned_relevants <- mapBagM cloneWanted th_relevant_cts + -- We wrap the WC in the nested implications, see + -- Note [Checking hole fits] + ; let outermost_first = reverse th_implics + -- We add the cloned relevants to the wanteds generated by + -- the call to tcSubType_NC, see Note [Relevant constraints] + -- There's no need to clone the wanteds, because they are + -- freshly generated by `tcSubtype_NC`. + w_rel_cts = addSimples wanted cloned_relevants + final_wc = foldr (setWCAndBinds fresh_binds) w_rel_cts outermost_first + ; traceTc "final_wc is: " $ ppr final_wc + ; rem <- runTcSDeriveds $ simpl_top final_wc + -- We don't want any insoluble or simple constraints left, but + -- solved implications are ok (and necessary for e.g. undefined) + ; traceTc "rems was:" $ ppr rem + ; traceTc "}" empty + ; return (isSolvedWC rem, wrap) } } + where + setWCAndBinds :: EvBindsVar -- Fresh ev binds var. + -> Implication -- The implication to put WC in. + -> WantedConstraints -- The WC constraints to put implic. + -> WantedConstraints -- The new constraints. + setWCAndBinds binds imp wc + = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds } diff --git a/GHC/Tc/Errors/Hole.hs-boot b/GHC/Tc/Errors/Hole.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole.hs-boot @@ -0,0 +1,43 @@ +-- This boot file is in place to break the loop where: +-- + GHC.Tc.Solver calls 'GHC.Tc.Errors.reportUnsolved', +-- + which calls 'GHC.Tc.Errors.Hole.findValidHoleFits` +-- + which calls 'GHC.Tc.Solver.simpl_top' +module GHC.Tc.Errors.Hole where + +import GHC.Types.Var ( Id ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication ) +import GHC.Utils.Outputable ( SDoc ) +import GHC.Types.Var.Env ( TidyEnv ) +import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate ) +import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, Type, TcTyVar ) +import GHC.Tc.Types.Evidence ( HsWrapper ) +import GHC.Utils.FV ( FV ) +import Data.Bool ( Bool ) +import Data.Maybe ( Maybe ) +import Data.Int ( Int ) + +findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole + -> TcM (TidyEnv, SDoc) + +tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType + -> TcM (Bool, HsWrapper) + +withoutUnification :: FV -> TcM a -> TcM a +tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool +tcFilterHoleFits :: Maybe Int -> TypedHole -> (TcType, [TcTyVar]) + -> [HoleFitCandidate] -> TcM (Bool, [HoleFit]) +getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] +addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] + +data HoleFitDispConfig +data HoleFitSortingAlg + +pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc +getHoleFitSortingAlg :: TcM HoleFitSortingAlg +getHoleFitDispConfig :: TcM HoleFitDispConfig + +relevantCts :: Type -> [Ct] -> [Ct] +zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) +sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] +sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit] diff --git a/GHC/Tc/Errors/Hole/FitTypes.hs b/GHC/Tc/Errors/Hole/FitTypes.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole/FitTypes.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE ExistentialQuantification #-} +module GHC.Tc.Errors.Hole.FitTypes ( + TypedHole (..), HoleFit (..), HoleFitCandidate (..), + CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..), + hfIsLcl, pprHoleFitCand + ) where + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.TcType + +import GHC.Types.Name.Reader + +import GHC.Hs.Doc +import GHC.Types.Id + +import GHC.Utils.Outputable +import GHC.Types.Name + +import Data.Function ( on ) + +data TypedHole = TypedHole { th_relevant_cts :: Cts + -- ^ Any relevant Cts to the hole + , th_implics :: [Implication] + -- ^ The nested implications of the hole with the + -- innermost implication first. + , th_hole :: Maybe Hole + -- ^ The hole itself, if available. Only for debugging. + } + +instance Outputable TypedHole where + ppr (TypedHole { th_relevant_cts = rels + , th_implics = implics + , th_hole = hole }) + = hang (text "TypedHole") 2 + (ppr rels $+$ ppr implics $+$ ppr hole) + +-- | HoleFitCandidates are passed to hole fit plugins and then +-- checked whether they fit a given typed-hole. +data HoleFitCandidate = IdHFCand Id -- An id, like locals. + | NameHFCand Name -- A name, like built-in syntax. + | GreHFCand GlobalRdrElt -- A global, like imported ids. + deriving (Eq) + +instance Outputable HoleFitCandidate where + ppr = pprHoleFitCand + +pprHoleFitCand :: HoleFitCandidate -> SDoc +pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid +pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname +pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre + +instance NamedThing HoleFitCandidate where + getName hfc = case hfc of + IdHFCand cid -> idName cid + NameHFCand cname -> cname + GreHFCand cgre -> gre_name cgre + getOccName hfc = case hfc of + IdHFCand cid -> occName cid + NameHFCand cname -> occName cname + GreHFCand cgre -> occName (gre_name cgre) + +instance HasOccName HoleFitCandidate where + occName = getOccName + +instance Ord HoleFitCandidate where + compare = compare `on` getName + +-- | HoleFit is the type we use for valid hole fits. It contains the +-- element that was checked, the Id of that element as found by `tcLookup`, +-- and the refinement level of the fit, which is the number of extra argument +-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`). +data HoleFit = + HoleFit { hfId :: Id -- ^ The elements id in the TcM + , hfCand :: HoleFitCandidate -- ^ The candidate that was checked. + , hfType :: TcType -- ^ The type of the id, possibly zonked. + , hfRefLvl :: Int -- ^ The number of holes in this fit. + , hfWrap :: [TcType] -- ^ The wrapper for the match. + , hfMatches :: [TcType] + -- ^ What the refinement variables got matched with, if anything + , hfDoc :: Maybe HsDocString + -- ^ Documentation of this HoleFit, if available. + } + | RawHoleFit SDoc + -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins + -- can inject any fit they want. + +-- We define an Eq and Ord instance to be able to build a graph. +instance Eq HoleFit where + (==) = (==) `on` hfId + +instance Outputable HoleFit where + ppr (RawHoleFit sd) = sd + ppr (HoleFit _ cand ty _ _ mtchs _) = + hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty)) + where name = ppr $ getName cand + holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs + +-- We compare HoleFits by their name instead of their Id, since we don't +-- want our tests to be affected by the non-determinism of `nonDetCmpVar`, +-- which is used to compare Ids. When comparing, we want HoleFits with a lower +-- refinement level to come first. +instance Ord HoleFit where + compare (RawHoleFit _) (RawHoleFit _) = EQ + compare (RawHoleFit _) _ = LT + compare _ (RawHoleFit _) = GT + compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b + where cmp = if hfRefLvl a == hfRefLvl b + then compare `on` (getName . hfCand) + else compare `on` hfRefLvl + +hfIsLcl :: HoleFit -> Bool +hfIsLcl hf@(HoleFit {}) = case hfCand hf of + IdHFCand _ -> True + NameHFCand _ -> False + GreHFCand gre -> gre_lcl gre +hfIsLcl _ = False + + +-- | A plugin for modifying the candidate hole fits *before* they're checked. +type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate] + +-- | A plugin for modifying hole fits *after* they've been found. +type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit] + +-- | A HoleFitPlugin is a pair of candidate and fit plugins. +data HoleFitPlugin = HoleFitPlugin + { candPlugin :: CandPlugin + , fitPlugin :: FitPlugin } + +-- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can +-- track internal state. Note the existential quantification, ensuring that +-- the state cannot be modified from outside the plugin. +data HoleFitPluginR = forall s. HoleFitPluginR + { hfPluginInit :: TcM (TcRef s) + -- ^ Initializes the TcRef to be passed to the plugin + , hfPluginRun :: TcRef s -> HoleFitPlugin + -- ^ The function defining the plugin itself + , hfPluginStop :: TcRef s -> TcM () + -- ^ Cleanup of state, guaranteed to be called even on error + } diff --git a/GHC/Tc/Errors/Hole/FitTypes.hs-boot b/GHC/Tc/Errors/Hole/FitTypes.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole/FitTypes.hs-boot @@ -0,0 +1,10 @@ +-- This boot file is in place to break the loop where: +-- + GHC.Tc.Types needs 'HoleFitPlugin', +-- + which needs 'GHC.Tc.Errors.Hole.FitTypes' +-- + which needs 'GHC.Tc.Types' +module GHC.Tc.Errors.Hole.FitTypes where + +-- Build ordering +import GHC.Base() + +data HoleFitPlugin diff --git a/GHC/Tc/Gen/Annotation.hs b/GHC/Tc/Gen/Annotation.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Annotation.hs @@ -0,0 +1,70 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking annotations +module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) +import GHC.Unit.Module +import GHC.Driver.Session +import Control.Monad ( when ) + +import GHC.Hs +import GHC.Types.Name +import GHC.Types.Annotations +import GHC.Tc.Utils.Monad +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Driver.Types + +-- Some platforms don't support the interpreter, and compilation on those +-- platforms shouldn't fail just due to annotations +tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] +tcAnnotations anns = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Just _ -> mapM tcAnnotation anns + Nothing -> warnAnns anns + +warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] +--- No GHCI; emit a warning (not an error) and ignore. cf #4268 +warnAnns [] = return [] +warnAnns anns@(L loc _ : _) + = do { setSrcSpan loc $ addWarnTc NoReason $ + (text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") + ; return [] } + +tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation +tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do + -- Work out what the full target of this annotation was + mod <- getModule + let target = annProvenanceToTarget mod provenance + + -- Run that annotation and construct the full Annotation data structure + setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do + -- See #10826 -- Annotations allow one to bypass Safe Haskell. + dflags <- getDynFlags + when (safeLanguageOn dflags) $ failWithTc safeHsErr + runAnnotation target expr + where + safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + +annProvenanceToTarget :: Module -> AnnProvenance Name + -> AnnTarget Name +annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod + +annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc +annCtxt ann + = hang (text "In the annotation:") 2 (ppr ann) diff --git a/GHC/Tc/Gen/Arrow.hs b/GHC/Tc/Gen/Arrow.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Arrow.hs @@ -0,0 +1,454 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE RankNTypes, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typecheck arrow notation +module GHC.Tc.Gen.Arrow ( tcProc ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp + , tcCheckId, tcCheckPolyExpr ) + +import GHC.Hs +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Zonk( hsLPatType ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.Bind +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Core.Multiplicity +import GHC.Types.Id( mkLocalId ) +import GHC.Tc.Utils.Instantiate +import GHC.Builtin.Types +import GHC.Types.Var.Set +import GHC.Builtin.Types.Prim +import GHC.Types.Basic( Arity ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Control.Monad + +{- +Note [Arrow overview] +~~~~~~~~~~~~~~~~~~~~~ +Here's a summary of arrows and how they typecheck. First, here's +a cut-down syntax: + + expr ::= .... + | proc pat cmd + + cmd ::= cmd exp -- Arrow application + | \pat -> cmd -- Arrow abstraction + | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 + | ... -- If, case in the usual way + + cmd_type ::= carg_type --> type + + carg_type ::= () + | (type, carg_type) + +Note that + * The 'exp' in an arrow form can mention only + "arrow-local" variables + + * An "arrow-local" variable is bound by an enclosing + cmd binding form (eg arrow abstraction) + + * A cmd_type is here written with a funny arrow "-->", + The bit on the left is a carg_type (command argument type) + which itself is a nested tuple, finishing with () + + * The arrow-tail operator (e1 -< e2) means + (| e1 <<< arr snd |) e2 + + +************************************************************************ +* * + Proc +* * +************************************************************************ +-} + +tcProc :: LPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr + -> ExpRhoType -- Expected type of whole proc expression + -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion) + +tcProc pat cmd exp_ty + = newArrowScope $ + do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows + ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 + ; let cmd_env = CmdEnv { cmd_arr = arr_ty } + ; (pat', cmd') <- tcCheckPat ProcExpr pat (unrestricted arg_ty) $ + tcCmdTop cmd_env cmd (unitTy, res_ty) + ; let res_co = mkTcTransCo co + (mkTcAppCo co1 (mkTcNomReflCo res_ty)) + ; return (pat', cmd', res_co) } + +{- +************************************************************************ +* * + Commands +* * +************************************************************************ +-} + +-- See Note [Arrow overview] +type CmdType = (CmdArgType, TcTauType) -- cmd_type +type CmdArgType = TcTauType -- carg_type, a nested tuple + +data CmdEnv + = CmdEnv { + cmd_arr :: TcType -- arrow type constructor, of kind *->*->* + } + +mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType +mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] + +--------------------------------------- +tcCmdTop :: CmdEnv + -> LHsCmdTop GhcRn + -> CmdType + -> TcM (LHsCmdTop GhcTc) + +tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) + = setSrcSpan loc $ + do { cmd' <- tcCmd env cmd cmd_ty + ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names + ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } + +---------------------------------------- +tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) + -- The main recursive function +tcCmd env (L loc cmd) res_ty + = setSrcSpan loc $ do + { cmd' <- tc_cmd env cmd res_ty + ; return (L loc cmd') } + +tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTc) +tc_cmd env (HsCmdPar x cmd) res_ty + = do { cmd' <- tcCmd env cmd res_ty + ; return (HsCmdPar x cmd') } + +tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty + = do { (binds', body') <- tcLocalBinds binds $ + setSrcSpan body_loc $ + tc_cmd env body res_ty + ; return (HsCmdLet x (L l binds') (L body_loc body')) } + +tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) + = addErrCtxt (cmdCtxt in_cmd) $ do + (scrut', scrut_ty) <- tcInferRho scrut + matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty) + return (HsCmdCase x scrut' matches') + +tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty) + = addErrCtxt (cmdCtxt in_cmd) $ do + (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk + matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty) + return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches')) + +tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcCheckMonoExpr pred boolTy + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2') + } + +tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if + = do { pred_ty <- newOpenFlexiTyVarTy + -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r + -- because we're going to apply it to the environment, not + -- the return value. + ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] + ; let r_ty = mkTyVarTy r_tv + ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) + (text "Predicate type of `ifThenElse' depends on result type") + ; (pred', fun') + <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) + (mkCheckExpType r_ty) $ \ _ _ -> + tcCheckMonoExpr pred pred_ty + + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf x fun' pred' b1' b2') + } + +------------------------------------------- +-- Arrow application +-- (f -< a) or (f -<< a) +-- +-- D |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -< arg :: stk --> t2 +-- +-- D,G |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -<< arg :: stk --> t2 +-- +-- (plus -<< requires ArrowApply) + +tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { arg_ty <- newOpenFlexiTyVarTy + ; let fun_ty = mkCmdArrTy env arg_ty res_ty + ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty) + + ; arg' <- tcCheckMonoExpr arg arg_ty + + ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } + where + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside f. In the higher-order case (-<<), they are. + -- See Note [Escaping the arrow scope] in GHC.Tc.Types + select_arrow_scope tc = case ho_app of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + +------------------------------------------- +-- Command application +-- +-- D,G |- exp : t +-- D;G |-a cmd : (t,stk) --> res +-- ----------------------------- +-- D;G |-a cmd exp : stk --> res + +tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { arg_ty <- newOpenFlexiTyVarTy + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcCheckMonoExpr arg arg_ty + ; return (HsCmdApp x fun' arg') } + +------------------------------------------- +-- Lambda +-- +-- D;G,x:t |-a cmd : stk --> res +-- ------------------------------ +-- D;G |-a (\x.cmd) : (t,stk) --> res + +tc_cmd env + (HsCmdLam x (MG { mg_alts = L l [L mtch_loc + (match@(Match { m_pats = pats, m_grhss = grhss }))], + mg_origin = origin })) + (cmd_stk, res_ty) + = addErrCtxt (pprMatchInCtxt match) $ + do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + + -- Check the patterns, and the GRHSs inside + ; (pats', grhss') <- setSrcSpan mtch_loc $ + tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $ + tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) + + ; let match' = L mtch_loc (Match { m_ext = noExtField + , m_ctxt = LambdaExpr, m_pats = pats' + , m_grhss = grhss' }) + arg_tys = map (unrestricted . hsLPatType) pats' + cmd' = HsCmdLam x (MG { mg_alts = L l [match'] + , mg_ext = MatchGroupTc arg_tys res_ty + , mg_origin = origin }) + ; return (mkHsCmdWrap (mkWpCastN co) cmd') } + where + n_pats = length pats + match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr? + pg_ctxt = PatGuard match_ctxt + + tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty + = do { (binds', grhss') <- tcLocalBinds binds $ + mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss + ; return (GRHSs x grhss' (L l binds')) } + + tc_grhs stk_ty res_ty (GRHS x guards body) + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body + (stk_ty, checkingExpType "tc_grhs" res_ty) + ; return (GRHS x guards' rhs') } + +------------------------------------------- +-- Do notation + +tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) + = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } + + +----------------------------------------------------------------- +-- Arrow ``forms'' (| e c1 .. cn |) +-- +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 +-- ... +-- -> an (e, stkn) tn +-- -> a (e, stk) t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) +-- ---------------------------------------------- +-- D; G |-a (| e c1 ... cn |) : stk --> t + +tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args + -- We use alphaTyVar for 'w' + ; let e_ty = mkInfForAllTy alphaTyVar $ + mkVisFunTysMany cmd_tys $ + mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty + ; expr' <- tcCheckPolyExpr expr e_ty + ; return (HsCmdArrForm x expr' f fixity cmd_args') } + + where + tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType) + tc_cmd_arg cmd + = do { arr_ty <- newFlexiTyVarTy arrowTyConKind + ; stk_ty <- newFlexiTyVarTy liftedTypeKind + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; let env' = env { cmd_arr = arr_ty } + ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) + ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } + +----------------------------------------------------------------- +-- Base case for illegal commands +-- This is where expressions that aren't commands get rejected + +tc_cmd _ cmd _ + = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), + text "was found where an arrow command was expected"]) + +-- | Typechecking for case command alternatives. Used for both +-- 'HsCmdCase' and 'HsCmdLamCase'. +tcCmdMatches :: CmdEnv + -> TcType -- ^ type of the scrutinee + -> MatchGroup GhcRn (LHsCmd GhcRn) -- ^ case alternatives + -> CmdType + -> TcM (MatchGroup GhcTc (LHsCmd GhcTc)) +tcCmdMatches env scrut_ty matches (stk, res_ty) + = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty) + where + match_ctxt = MC { mc_what = CaseAlt, + mc_body = mc_body } + mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' + ; tcCmd env body (stk, res_ty') } + +matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) +matchExpectedCmdArgs 0 ty + = return (mkTcNomReflCo ty, [], ty) +matchExpectedCmdArgs n ty + = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty + ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 + ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } + +{- +************************************************************************ +* * + Stmts +* * +************************************************************************ +-} + +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker +tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside + = do { rhs' <- tcCmd env rhs (unitTy, res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt x rhs' noret noSyntaxExpr, thing) } + +tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + thing_inside res_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names }) res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith (\n p -> mkLocalId n Many p) tup_names tup_elt_tys -- Many because it's a recursive definition + ; tcExtendIdEnv tup_ids $ do + { (stmts', tup_rets) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) + + ; thing <- thing_inside res_ty + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in GHC.Hs.Expr) + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + + ; let rec_rets = takeList rec_names tup_rets + ; let ret_table = zip tup_ids tup_rets + ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] + + ; return (emptyRecStmtId { recS_stmts = stmts' + , recS_later_ids = later_ids + , recS_rec_ids = rec_ids + , recS_ext = unitRecStmtTc + { recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = res_ty} }, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs (unitTy, ty) + ; return (rhs', ty) } + +{- +************************************************************************ +* * + Helpers +* * +************************************************************************ +-} + +mkPairTy :: Type -> Type -> Type +mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] + +arrowTyConKind :: Kind -- *->*->* +arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind + +{- +************************************************************************ +* * + Errors +* * +************************************************************************ +-} + +cmdCtxt :: HsCmd GhcRn -> SDoc +cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/GHC/Tc/Gen/Bind.hs b/GHC/Tc/Gen/Bind.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Bind.hs @@ -0,0 +1,1776 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Tc.Gen.Bind + ( tcLocalBinds + , tcTopBinds + , tcValBinds + , tcHsBootSigs + , tcPolyCheck + , chooseInferredQuantifiers + , badBootDeclErr + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) +import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) + +import GHC.Core (Tickish (..)) +import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Hs +import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify +import GHC.Tc.Solver +import GHC.Tc.Types.Evidence +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Core.Multiplicity +import GHC.Core.FamInstEnv( normaliseType ) +import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types( mkBoxedTupleTy ) +import GHC.Types.Id +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env( TidyEnv ) +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Utils.Error +import GHC.Data.Graph.Directed +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Types.Basic +import GHC.Utils.Outputable as Outputable +import GHC.Builtin.Names( ipClassName ) +import GHC.Tc.Validity (checkValidType) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import qualified GHC.LanguageExtensions as LangExt +import GHC.Core.ConLike + +import Control.Monad +import Data.Foldable (find) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{Type-checking bindings} +* * +************************************************************************ + +@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because +it needs to know something about the {\em usage} of the things bound, +so that it can create specialisations of them. So @tcBindsAndThen@ +takes a function which, given an extended environment, E, typechecks +the scope of the bindings returning a typechecked thing and (most +important) an LIE. It is this LIE which is then used as the basis for +specialising the things bound. + +@tcBindsAndThen@ also takes a "combiner" which glues together the +bindings and the "thing" to make a new "thing". + +The real work is done by @tcBindWithSigsAndThen@. + +Recursive and non-recursive binds are handled in essentially the same +way: because of uniques there are no scoping issues left. The only +difference is that non-recursive bindings can bind primitive values. + +Even for non-recursive binding groups we add typings for each binder +to the LVE for the following reason. When each individual binding is +checked the type of its LHS is unified with that of its RHS; and +type-checking the LHS of course requires that the binder is in scope. + +At the top-level the LIE is sure to contain nothing but constant +dictionaries, which we resolve at the module level. + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. + +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity analysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm +-} + +tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] + -> TcM (TcGblEnv, TcLclEnv) +-- The TcGblEnv contains the new tcg_binds and tcg_spects +-- The TcLclEnv has an extended type envt for the new bindings +tcTopBinds binds sigs + = do { -- Pattern synonym bindings populate the global environment + (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ + do { gbl <- getGblEnv + ; lcl <- getLclEnv + ; return (gbl, lcl) } + ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids + + ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs + ; traceTc "complete_matches" (ppr binds $$ ppr sigs) + ; traceTc "complete_matches" (ppr complete_matches) + + ; let { tcg_env' = tcg_env { tcg_imp_specs + = specs ++ tcg_imp_specs tcg_env + , tcg_complete_matches + = complete_matches + ++ tcg_complete_matches tcg_env } + `addTypecheckedBinds` map snd binds' } + + ; return (tcg_env', tcl_env) } + -- The top level bindings are flattened into a giant + -- implicitly-mutually-recursive LHsBinds + + +-- Note [Typechecking Complete Matches] +-- Much like when a user bundled a pattern synonym, the result types of +-- all the constructors in the match pragma must be consistent. +-- +-- If we allowed pragmas with inconsistent types then it would be +-- impossible to ever match every constructor in the list and so +-- the pragma would be useless. + + + + + +-- This is only used in `tcCompleteSig`. We fold over all the conlikes, +-- this accumulator keeps track of the first `ConLike` with a concrete +-- return type. After fixing the return type, all other constructors with +-- a fixed return type must agree with this. +-- +-- The fields of `Fixed` cache the first conlike and its return type so +-- that we can compare all the other conlikes to it. The conlike is +-- stored for error messages. +-- +-- `Nothing` in the case that the type is fixed by a type signature +data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon + +tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] +tcCompleteSigs sigs = + let + doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) + doOne c@(CompleteMatchSig _ _ lns mtc) + = fmap Just $ do + addErrCtxt (text "In" <+> ppr c) $ + case mtc of + Nothing -> infer_complete_match + Just tc -> check_complete_match tc + where + + checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) + + infer_complete_match = do + (res, cls) <- checkCLTypes AcceptAny + case res of + AcceptAny -> failWithTc ambiguousError + Fixed _ tc -> return $ mkMatch cls tc + + check_complete_match tc_name = do + ty_con <- tcLookupLocatedTyCon tc_name + (_, cls) <- checkCLTypes (Fixed Nothing ty_con) + return $ mkMatch cls ty_con + + mkMatch :: [ConLike] -> TyCon -> CompleteMatch + mkMatch cls ty_con = CompleteMatch { + -- foldM is a left-fold and will have accumulated the ConLikes in + -- the reverse order. foldrM would accumulate in the correct order, + -- but would type-check the last ConLike first, which might also be + -- confusing from the user's perspective. Hence reverse here. + completeMatchConLikes = reverse (map conLikeName cls), + completeMatchTyCon = tyConName ty_con + } + doOne _ = return Nothing + + ambiguousError :: SDoc + ambiguousError = + text "A type signature must be provided for a set of polymorphic" + <+> text "pattern synonyms." + + + -- See note [Typechecking Complete Matches] + checkCLType :: (CompleteSigType, [ConLike]) -> Located Name + -> TcM (CompleteSigType, [ConLike]) + checkCLType (cst, cs) n = do + cl <- addLocM tcLookupConLike n + let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl + res_ty_con = fst <$> splitTyConApp_maybe res_ty + case (cst, res_ty_con) of + (AcceptAny, Nothing) -> return (AcceptAny, cl:cs) + (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs) + (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs) + (Fixed mfcl tc, Just tc') -> + if tc == tc' + then return (Fixed mfcl tc, cl:cs) + else case mfcl of + Nothing -> + addErrCtxt (text "In" <+> ppr cl) $ + failWithTc typeSigErrMsg + Just cl -> failWithTc (errMsg cl) + where + typeSigErrMsg :: SDoc + typeSigErrMsg = + text "Couldn't match expected type" + <+> quotes (ppr tc) + <+> text "with" + <+> quotes (ppr tc') + + errMsg :: ConLike -> SDoc + errMsg fcl = + text "Cannot form a group of complete patterns from patterns" + <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl) + <+> text "as they match different type constructors" + <+> parens (quotes (ppr tc) + <+> text "resp." + <+> quotes (ppr tc')) + -- For some reason I haven't investigated further, the signatures come in + -- backwards wrt. declaration order. So we reverse them here, because it makes + -- a difference for incomplete match suggestions. + in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order + +tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] +-- A hs-boot file has only one BindGroup, and it only has type +-- signatures in it. The renamer checked all this +tcHsBootSigs binds sigs + = do { checkTc (null binds) badBootDeclErr + ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + where + tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames + where + f (L _ name) + = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty + ; return (mkVanillaGlobal name sigma_ty) } + -- Notice that we make GlobalIds, not LocalIds + tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) + +badBootDeclErr :: MsgDoc +badBootDeclErr = text "Illegal declarations in an hs-boot file" + +------------------------ +tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing + -> TcM (HsLocalBinds GhcTc, thing) + +tcLocalBinds (EmptyLocalBinds x) thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds x, thing) } + +tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside + ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } +tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" + +tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside + = do { ipClass <- tcLookupClass ipClassName + ; (given_ips, ip_binds') <- + mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds + + -- If the binding binds ?x = E, we must now + -- discharge any ?x constraints in expr_lie + -- See Note [Implicit parameter untouchables] + ; (ev_binds, result) <- checkConstraints (IPSkol ips) + [] given_ips thing_inside + + ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } + where + ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] + + -- I wonder if we should do these one at a time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) + = do { ty <- newOpenFlexiTyVarTy + ; let p = mkStrLitTy $ hsIPNameFS ip + ; ip_id <- newDict ipClass [ p, ty ] + ; expr' <- tcCheckMonoExpr expr ty + ; let d = toDict ipClass p ty `fmap` expr' + ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } + tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" + + -- Coerces a `t` into a dictionary for `IP "x" t`. + -- co : t -> IP "x" t + toDict ipClass x ty = mkHsWrap $ mkWpCastR $ + wrapIP $ mkClassPred ipClass [x,ty] + +{- Note [Implicit parameter untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We add the type variables in the types of the implicit parameters +as untouchables, not so much because we really must not unify them, +but rather because we otherwise end up with constraints like this + Num alpha, Implic { wanted = alpha ~ Int } +The constraint solver solves alpha~Int by unification, but then +doesn't float that solved constraint out (it's not an unsolved +wanted). Result disaster: the (Num alpha) is again solved, this +time by defaulting. No no no. + +However [Oct 10] this is all handled automatically by the +untouchable-range idea. +-} + +tcValBinds :: TopLevelFlag + -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] + -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) + +tcValBinds top_lvl binds sigs thing_inside + = do { -- Typecheck the signatures + -- It's easier to do so now, once for all the SCCs together + -- because a single signature f,g :: + -- might relate to more than one SCC + (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $ + tcTySigs sigs + + -- Extend the envt right away with all the Ids + -- declared with complete type signatures + -- Do not extend the TcBinderStack; instead + -- we extend it on a per-rhs basis in tcExtendForRhs + -- See Note [Relevant bindings and the binder stack] + -- + -- For the moment, let bindings and top-level bindings introduce + -- only unrestricted variables. + ; tcExtendSigIds top_lvl poly_ids $ + do { (binds', (extra_binds', thing)) + <- tcBindGroups top_lvl sig_fn prag_fn binds $ + do { thing <- thing_inside + -- See Note [Pattern synonym builders don't yield dependencies] + -- in GHC.Rename.Bind + ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns + ; let extra_binds = [ (NonRecursive, builder) + | builder <- patsyn_builders ] + ; return (extra_binds, thing) } + ; return (binds' ++ extra_binds', thing) }} + where + patsyns = getPatSynBinds binds + prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) + +------------------------ +tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv + -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time +-- Here a "strongly connected component" has the straightforward +-- meaning of a group of bindings that mention each other, +-- ignoring type signatures (that part comes later) + +tcBindGroups _ _ _ [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } + +tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { -- See Note [Closed binder groups] + type_env <- getLclTypeEnv + ; let closed = isClosedBndrGroup type_env (snd group) + ; (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group closed $ + tcBindGroups top_lvl sig_fn prag_fn groups thing_inside + ; return (group' ++ groups', thing) } + +-- Note [Closed binder groups] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A mutually recursive group is "closed" if all of the free variables of +-- the bindings are closed. For example +-- +-- > h = \x -> let f = ...g... +-- > g = ....f...x... +-- > in ... +-- +-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@ +-- closed. +-- +-- So we need to compute closed-ness on each strongly connected components, +-- before we sub-divide it based on what type signatures it has. +-- + +------------------------ +tc_group :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) + +-- Typecheck one strongly-connected component of the original program. +-- We get a list of groups back, because there may +-- be specialisations etc as well + +tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside + -- A single non-recursive binding + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + = do { let bind = case bagToList binds of + [bind] -> bind + [] -> panic "tc_group: empty list of binds" + _ -> panic "tc_group: NonRecursive binds is not a singleton bag" + ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed + thing_inside + ; return ( [(NonRecursive, bind')], thing) } + +tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside + = -- To maximise polymorphism, we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- (This used to be optional, but isn't now.) + -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". + do { traceTc "tc_group rec" (pprLHsBinds binds) + ; whenIsJust mbFirstPatSyn $ \lpat_syn -> + recursivePatSynErr (getLoc lpat_syn) binds + ; (binds1, thing) <- go sccs + ; return ([(Recursive, binds1)], thing) } + -- Rec them all together + where + mbFirstPatSyn = find (isPatSyn . unLoc) binds + isPatSyn PatSynBind{} = True + isPatSyn _ = False + + sccs :: [SCC (LHsBind GhcRn)] + sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) + + go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing) + go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc + -- recursive bindings must be unrestricted + -- (the ids added to the environment here are the name of the recursive definitions). + ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn closed ids1 + (go sccs) + ; return (binds1 `unionBags` binds2, thing) } + go [] = do { thing <- thing_inside; return (emptyBag, thing) } + + tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] + tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds + + tc_sub_group rec_tc binds = + tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds + +recursivePatSynErr :: + (OutputableBndrId p, CollectPass (GhcPass p)) + => SrcSpan -- ^ The location of the first pattern synonym binding + -- (for error reporting) + -> LHsBinds (GhcPass p) + -> TcM a +recursivePatSynErr loc binds + = failAt loc $ + hang (text "Recursive pattern synonym definition with following bindings:") + 2 (vcat $ map pprLBind . bagToList $ binds) + where + pprLoc loc = parens (text "defined at" <+> ppr loc) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + <+> pprLoc loc + +tc_single :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> LHsBind GhcRn -> IsGroupClosed -> TcM thing + -> TcM (LHsBinds GhcTc, thing) +tc_single _top_lvl sig_fn _prag_fn + (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) + _ thing_inside + = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) + ; thing <- setGblEnv tcg_env thing_inside + ; return (aux_binds, thing) + } + +tc_single top_lvl sig_fn prag_fn lbind closed thing_inside + = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn + NonRecursive NonRecursive + closed + [lbind] + -- since we are defining a non-recursive binding, it is not necessary here + -- to define an unrestricted binding. But we do so until toplevel linear bindings are supported. + ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside + ; return (binds1, thing) } + +------------------------ +type BKey = Int -- Just number off the bindings + +mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] +-- See Note [Polymorphic recursion] in "GHC.Hs.Binds". +mkEdges sig_fn binds + = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ] + | (bind, key) <- keyd_binds + ] + -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + bind_fvs (FunBind { fun_ext = fvs }) = fvs + bind_fvs (PatBind { pat_ext = fvs }) = fvs + bind_fvs _ = emptyNameSet + + no_sig :: Name -> Bool + no_sig n = not (hasCompleteSig sig_fn n) + + keyd_binds = bagToList binds `zip` [0::BKey ..] + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- collectHsBindBinders bind ] + +------------------------ +tcPolyBinds :: TcSigFun -> TcPragEnv + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> IsGroupClosed -- Whether the group is closed + -> [LHsBind GhcRn] -- None are PatSynBind + -> TcM (LHsBinds GhcTc, [TcId]) + +-- Typechecks a single bunch of values bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Returns a list because the input may be a single non-recursive binding, +-- in which case the dependency order of the resulting bindings is +-- important. +-- +-- Knows nothing about the scope of the bindings +-- None of the bindings are pattern synonyms + +tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list + = setSrcSpan loc $ + recoverM (recoveryCode binder_names sig_fn) $ do + -- Set up main recover; take advantage of any type sigs + + { traceTc "------------------------------------------------" Outputable.empty + ; traceTc "Bindings for {" (ppr binder_names) + ; dflags <- getDynFlags + ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn + ; traceTc "Generalisation plan" (ppr plan) + ; result@(_, poly_ids) <- case plan of + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list + CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind + + ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group + , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] + ]) + + ; return result } + where + binder_names = collectHsBindListBinders bind_list + loc = foldr1 combineSrcSpans (map getLoc bind_list) + -- The mbinds have been dependency analysed and + -- may no longer be adjacent; so find the narrowest + -- span that includes them all + +-------------- +-- If typechecking the binds fails, then return with each +-- signature-less binder given type (forall a.a), to minimise +-- subsequent error messages +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id]) +recoveryCode binder_names sig_fn + = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) + ; let poly_ids = map mk_dummy binder_names + ; return (emptyBag, poly_ids) } + where + mk_dummy name + | Just sig <- sig_fn name + , Just poly_id <- completeSigPolyId_maybe sig + = poly_id + | otherwise + = mkLocalId name Many forall_a_a + +forall_a_a :: TcType +-- At one point I had (forall r (a :: TYPE r). a), but of course +-- that type is ill-formed: its mentions 'r' which escapes r's scope. +-- Another alternative would be (forall (a :: TYPE kappa). a), where +-- kappa is a unification variable. But I don't think we need that +-- complication here. I'm going to just use (forall (a::*). a). +-- See #15276 +forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy + +{- ********************************************************************* +* * + tcPolyNoGen +* * +********************************************************************* -} + +tcPolyNoGen -- No generalisation whatsoever + :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> TcPragEnv -> TcSigFun + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTc, [TcId]) + +tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list + = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn + (LetGblBndr prag_fn) + bind_list + ; mono_ids' <- mapM tc_mono_info mono_infos + ; return (binds', mono_ids') } + where + tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) + = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) + ; return mono_id } + -- NB: tcPrags generates error messages for + -- specialisation pragmas for non-overloaded sigs + -- Indeed that is why we call it here! + -- So we can safely ignore _specs + + +{- ********************************************************************* +* * + tcPolyCheck +* * +********************************************************************* -} + +tcPolyCheck :: TcPragEnv + -> TcIdSigInfo -- Must be a complete signature + -> LHsBind GhcRn -- Must be a FunBind + -> TcM (LHsBinds GhcTc, [TcId]) +-- There is just one binding, +-- it is a FunBind +-- it has a complete type signature, +tcPolyCheck prag_fn + (CompleteSig { sig_bndr = poly_id + , sig_ctxt = ctxt + , sig_loc = sig_loc }) + (L bind_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches })) + = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) + + ; mono_name <- newNameAt (nameOccName name) nm_loc + ; (wrap_gen, (wrap_res, matches')) + <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems + tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> + -- Unwraps multiple layers; e.g + -- f :: forall a. Eq a => forall b. Ord b => blah + -- NB: tcSkolemise makes fresh type variables + -- See Note [Instantiate sig with fresh variables] + + let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in + tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ + -- Why mono_id in the BinderStack? + -- See Note [Relevant bindings and the binder stack] + + setSrcSpan bind_loc $ + tcMatchesFun (L nm_loc mono_name) matches + (mkCheckExpType rho_ty) + + -- We make a funny AbsBinds, abstracting over nothing, + -- just so we haev somewhere to put the SpecPrags. + -- Otherwise we could just use the FunBind + -- Hence poly_id2 is just a clone of poly_id; + -- We re-use mono-name, but we could equally well use a fresh one + + ; let prag_sigs = lookupPragEnv prag_fn name + poly_id2 = mkLocalId mono_name (idMult poly_id) (idType poly_id) + ; spec_prags <- tcSpecPrags poly_id prag_sigs + ; poly_id <- addInlinePrags poly_id prag_sigs + + ; mod <- getModule + ; tick <- funBindTicks nm_loc poly_id mod prag_sigs + + ; let bind' = FunBind { fun_id = L nm_loc poly_id2 + , fun_matches = matches' + , fun_ext = wrap_gen <.> wrap_res + , fun_tick = tick } + + export = ABE { abe_ext = noExtField + , abe_wrap = idHsWrapper + , abe_poly = poly_id + , abe_mono = poly_id2 + , abe_prags = SpecPrags spec_prags } + + abs_bind = L bind_loc $ + AbsBinds { abs_ext = noExtField + , abs_tvs = [] + , abs_ev_vars = [] + , abs_ev_binds = [] + , abs_exports = [export] + , abs_binds = unitBag (L bind_loc bind') + , abs_sig = True } + + ; return (unitBag abs_bind, [poly_id]) } + +tcPolyCheck _prag_fn sig bind + = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) + +funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] + -> TcM [Tickish TcId] +funBindTicks loc fun_id mod sigs + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] + -- this can only be a singleton list, as duplicate pragmas are rejected + -- by the renamer + , let cc_str + | Just cc_str <- mb_cc_str + = sl_fs $ unLoc cc_str + | otherwise + = getOccFS (Var.varName fun_id) + cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str + = do + flavour <- DeclCC <$> getCCIndexM cc_name + let cc = mkUserCC cc_name mod loc flavour + return [ProfNote cc True True] + | otherwise + = return [] + +{- Note [Instantiate sig with fresh variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's vital to instantiate a type signature with fresh variables. +For example: + type T = forall a. [a] -> [a] + f :: T; + f = g where { g :: T; g = } + + We must not use the same 'a' from the defn of T at both places!! +(Instantiation is only necessary because of type synonyms. Otherwise, +it's all cool; each signature has distinct type variables from the renamer.) +-} + + +{- ********************************************************************* +* * + tcPolyInfer +* * +********************************************************************* -} + +tcPolyInfer + :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> TcPragEnv -> TcSigFun + -> Bool -- True <=> apply the monomorphism restriction + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTc, [TcId]) +tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list + = do { (tclvl, wanted, (binds', mono_infos)) + <- pushLevelAndCaptureConstraints $ + tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list + + ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) + | info <- mono_infos ] + sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] + infer_mode = if mono then ApplyMR else NoRestrictions + + ; mapM_ (checkOverloadedSig mono) sigs + + ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) + ; (qtvs, givens, ev_binds, residual, insoluble) + <- simplifyInfer tclvl infer_mode sigs name_taus wanted + ; emitConstraints residual + + ; let inferred_theta = map evVarPred givens + ; exports <- checkNoErrs $ + mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos + + ; loc <- getSrcSpanM + ; let poly_ids = map abe_poly exports + abs_bind = L loc $ + AbsBinds { abs_ext = noExtField + , abs_tvs = qtvs + , abs_ev_vars = givens, abs_ev_binds = [ev_binds] + , abs_exports = exports, abs_binds = binds' + , abs_sig = False } + + ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) + ; return (unitBag abs_bind, poly_ids) } + -- poly_ids are guaranteed zonked by mkExport + +-------------- +mkExport :: TcPragEnv + -> Bool -- True <=> there was an insoluble type error + -- when typechecking the bindings + -> [TyVar] -> TcThetaType -- Both already zonked + -> MonoBindInfo + -> TcM (ABExport GhcTc) +-- Only called for generalisation plan InferGen, not by CheckGen or NoGen +-- +-- mkExport generates exports with +-- zonked type variables, +-- zonked poly_ids +-- The former is just because no further unifications will change +-- the quantified type variables, so we can fix their final form +-- right now. +-- The latter is needed because the poly_ids are used to extend the +-- type environment; see the invariant on GHC.Tc.Utils.Env.tcExtendIdEnv + +-- Pre-condition: the qtvs and theta are already zonked + +mkExport prag_fn insoluble qtvs theta + mono_info@(MBI { mbi_poly_name = poly_name + , mbi_sig = mb_sig + , mbi_mono_id = mono_id }) + = do { mono_ty <- zonkTcType (idType mono_id) + ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty + + -- NB: poly_id has a zonked type + ; poly_id <- addInlinePrags poly_id prag_sigs + ; spec_prags <- tcSpecPrags poly_id prag_sigs + -- tcPrags requires a zonked poly_id + + -- See Note [Impedance matching] + -- NB: we have already done checkValidType, including an ambiguity check, + -- on the type; either when we checked the sig or in mkInferredPolyId + ; let poly_ty = idType poly_id + sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty + -- This type is just going into tcSubType, + -- so Inferred vs. Specified doesn't matter + + ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguous type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ + tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty + + ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures + ; when warn_missing_sigs $ + localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig + + ; return (ABE { abe_ext = noExtField + , abe_wrap = wrap + -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags }) } + where + prag_sigs = lookupPragEnv prag_fn poly_name + sig_ctxt = InfSigCtxt poly_name + +mkInferredPolyId :: Bool -- True <=> there was an insoluble error when + -- checking the binding group for this Id + -> [TyVar] -> TcThetaType + -> Name -> Maybe TcIdSigInst -> TcType + -> TcM TcId +mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty + | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst + , CompleteSig { sig_bndr = poly_id } <- sig + = return poly_id + + | otherwise -- Either no type sig or partial type sig + = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous + -- we don't carry on to the impedance matching, and generate + -- a duplicate ambiguity error. There is a similar + -- checkNoErrs for complete type signatures too. + do { fam_envs <- tcGetFamInstEnvs + ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty + -- Unification may not have normalised the type, + -- (see Note [Lazy flattening] in GHC.Tc.Solver.Flatten) so do it + -- here to make it as uncomplicated as possible. + -- Example: f :: [F Int] -> Bool + -- should be rewritten to f :: [Char] -> Bool, if possible + -- + -- We can discard the coercion _co, because we'll reconstruct + -- it in the call to tcSubType below + + ; (binders, theta') <- chooseInferredQuantifiers inferred_theta + (tyCoVarsOfType mono_ty') qtvs mb_sig_inst + + ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty') + + ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' + , ppr inferred_poly_ty]) + ; unless insoluble $ + addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ + checkValidType (InfSigCtxt poly_name) inferred_poly_ty + -- See Note [Validity of inferred types] + -- If we found an insoluble error in the function definition, don't + -- do this check; otherwise (#14000) we may report an ambiguity + -- error for a rather bogus type. + + ; return (mkLocalId poly_name Many inferred_poly_ty) } + + +chooseInferredQuantifiers :: TcThetaType -- inferred + -> TcTyVarSet -- tvs free in tau type + -> [TcTyVar] -- inferred quantified tvs + -> Maybe TcIdSigInst + -> TcM ([InvisTVBinder], TcThetaType) +chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing + = -- No type signature (partial or complete) for this binder, + do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) + -- Include kind variables! #7916 + my_theta = pickCapturedPreds free_tvs inferred_theta + binders = [ mkTyVarBinder InferredSpec tv + | tv <- qtvs + , tv `elemVarSet` free_tvs ] + ; return (binders, my_theta) } + +chooseInferredQuantifiers inferred_theta tau_tvs qtvs + (Just (TISI { sig_inst_sig = sig -- Always PartialSig + , sig_inst_wcx = wcx + , sig_inst_theta = annotated_theta + , sig_inst_skols = annotated_tvs })) + = -- Choose quantifiers for a partial type signature + do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs + ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs + ; let psig_qtvs = map binderVar psig_qtv_bndrs + psig_qtv_set = mkVarSet psig_qtvs + psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs + + + -- Check whether the quantified variables of the + -- partial signature have been unified together + -- See Note [Quantified variables in partial type signatures] + ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs) + + -- Check whether a quantified variable of the partial type + -- signature is not actually quantified. How can that happen? + -- See Note [Quantification and partial signatures] Wrinkle 4 + -- in GHC.Tc.Solver + ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs + , not (tv `elem` qtvs) ] + + ; annotated_theta <- zonkTcTypes annotated_theta + ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx + + ; let keep_me = free_tvs `unionVarSet` psig_qtv_set + final_qtvs = [ mkTyVarBinder vis tv + | tv <- qtvs -- Pulling from qtvs maintains original order + , tv `elemVarSet` keep_me + , let vis = case lookupVarBndr tv psig_qtv_bndrs of + Just spec -> spec + Nothing -> InferredSpec ] + + ; return (final_qtvs, my_theta) } + where + report_dup_tyvar_tv_err (n1,n2) + | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig + = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) + 2 (hang (text "both bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) + + | otherwise -- Can't happen; by now we know it's a partial sig + = pprPanic "report_tyvar_tv_err" (ppr sig) + + report_mono_sig_tv_err n + | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig + = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) + 2 (hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) + | otherwise -- Can't happen; by now we know it's a partial sig + = pprPanic "report_mono_sig_tv_err" (ppr sig) + + choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType + -> TcM (VarSet, TcThetaType) + choose_psig_context _ annotated_theta Nothing + = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta + `unionVarSet` tau_tvs) + ; return (free_tvs, annotated_theta) } + + choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) + = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) + -- growThetaVars just like the no-type-sig case + -- Omitting this caused #12844 + seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there + `unionVarSet` tau_tvs -- by the user + + ; let keep_me = psig_qtvs `unionVarSet` free_tvs + my_theta = pickCapturedPreds keep_me inferred_theta + + -- Fill in the extra-constraints wildcard hole with inferred_theta, + -- so that the Hole constraint we have already emitted + -- (in tcHsPartialSigType) can report what filled it in. + -- NB: my_theta already includes all the annotated constraints + ; let inferred_diff = [ pred + | pred <- my_theta + , all (not . (`eqType` pred)) annotated_theta ] + ; ctuple <- mk_ctuple inferred_diff + + ; case tcGetCastedTyVar_maybe wc_var_ty of + -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it + -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. So, to + -- make the kinds work out, we reverse the cast here. + Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co) + Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) + + ; traceTc "completeTheta" $ + vcat [ ppr sig + , ppr annotated_theta, ppr inferred_theta + , ppr inferred_diff ] + ; return (free_tvs, my_theta) } + + mk_ctuple preds = return (mkBoxedTupleTy preds) + -- Hack alert! See GHC.Tc.Gen.HsType: + -- Note [Extra-constraint holes in partial type signatures] + + +mk_impedance_match_msg :: MonoBindInfo + -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, SDoc) +-- This is a rare but rather awkward error messages +mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) + inf_ty sig_ty tidy_env + = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty + ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty + ; let msg = vcat [ text "When checking that the inferred type" + , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty + , text "is as general as its" <+> what <+> text "signature" + , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] + ; return (tidy_env2, msg) } + where + what = case mb_sig of + Nothing -> text "inferred" + Just sig | isPartialSig sig -> text "(partial)" + | otherwise -> empty + + +mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) +mk_inf_msg poly_name poly_ty tidy_env + = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty + ; let msg = vcat [ text "When checking the inferred type" + , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] + ; return (tidy_env1, msg) } + + +-- | Warn the user about polymorphic local binders that lack type signatures. +localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM () +localSigWarn flag id mb_sig + | Just _ <- mb_sig = return () + | not (isSigmaTy (idType id)) = return () + | otherwise = warnMissingSignatures flag msg id + where + msg = text "Polymorphic local binding with no type signature:" + +warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () +warnMissingSignatures flag msg id + = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) + ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) } + where + mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] + +checkOverloadedSig :: Bool -> TcIdSigInst -> TcM () +-- Example: +-- f :: Eq a => a -> a +-- K f = e +-- The MR applies, but the signature is overloaded, and it's +-- best to complain about this directly +-- c.f #11339 +checkOverloadedSig monomorphism_restriction_applies sig + | not (null (sig_inst_theta sig)) + , monomorphism_restriction_applies + , let orig_sig = sig_inst_sig sig + = setSrcSpan (sig_loc orig_sig) $ + failWith $ + hang (text "Overloaded signature conflicts with monomorphism restriction") + 2 (ppr orig_sig) + | otherwise + = return () + +{- Note [Partial type signatures and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If /any/ of the signatures in the group is a partial type signature + f :: _ -> Int +then we *always* use the InferGen plan, and hence tcPolyInfer. +We do this even for a local binding with -XMonoLocalBinds, when +we normally use NoGen. + +Reasons: + * The TcSigInfo for 'f' has a unification variable for the '_', + whose TcLevel is one level deeper than the current level. + (See pushTcLevelM in tcTySig.) But NoGen doesn't increase + the TcLevel like InferGen, so we lose the level invariant. + + * The signature might be f :: forall a. _ -> a + so it really is polymorphic. It's not clear what it would + mean to use NoGen on this, and indeed the ASSERT in tcLhs, + in the (Just sig) case, checks that if there is a signature + then we are using LetLclBndr, and hence a nested AbsBinds with + increased TcLevel + +It might be possible to fix these difficulties somehow, but there +doesn't seem much point. Indeed, adding a partial type signature is a +way to get per-binding inferred generalisation. + +We apply the MR if /all/ of the partial signatures lack a context. +In particular (#11016): + f2 :: (?loc :: Int) => _ + f2 = ?loc +It's stupid to apply the MR here. This test includes an extra-constraints +wildcard; that is, we don't apply the MR if you write + f3 :: _ => blah + +Note [Quantified variables in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a -> _ + f x y = g x y + g :: forall b. b -> b -> _ + g x y = [x, y] + +Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b' +together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then +unify with each other. + +But now consider: + f :: forall a b. a -> b -> _ + f x y = [x, y] + +We want to get an error from this, because 'a' and 'b' get unified. +So we make a test, one per partial signature, to check that the +explicitly-quantified type variables have not been unified together. +#14449 showed this up. + + +Note [Validity of inferred types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to check inferred type for validity, in case it uses language +extensions that are not turned on. The principle is that if the user +simply adds the inferred type to the program source, it'll compile fine. +See #8883. + +Examples that might fail: + - the type might be ambiguous + + - an inferred theta that requires type equalities e.g. (F a ~ G b) + or multi-parameter type classes + - an inferred type that includes unboxed tuples + + +Note [Impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f 0 x = x + f n x = g [] (not x) + + g [] y = f 10 y + g _ y = f 9 y + +After typechecking we'll get + f_mono_ty :: a -> Bool -> Bool + g_mono_ty :: [b] -> Bool -> Bool +with constraints + (Eq a, Num a) + +Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. +The types we really want for f and g are + f :: forall a. (Eq a, Num a) => a -> Bool -> Bool + g :: forall b. [b] -> Bool -> Bool + +We can get these by "impedance matching": + tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) + tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) + + f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f + g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g + +Suppose the shared quantified tyvars are qtvs and constraints theta. +Then we want to check that + forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype +and the proof is the impedance matcher. + +Notice that the impedance matcher may do defaulting. See #7173. + +It also cleverly does an ambiguity check; for example, rejecting + f :: F a -> F a +where F is a non-injective type function. +-} + + +{- +Note [SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point in a SPECIALISE pragma for a non-overloaded function: + reverse :: [a] -> [a] + {-# SPECIALISE reverse :: [Int] -> [Int] #-} + +But SPECIALISE INLINE *can* make sense for GADTS: + data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) + + (!:) :: Arr e -> Int -> e + {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} + {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} + (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) + (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) + +When (!:) is specialised it becomes non-recursive, and can usefully +be inlined. Scary! So we only warn for SPECIALISE *without* INLINE +for a non-overloaded function. + +************************************************************************ +* * + tcMonoBinds +* * +************************************************************************ + +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. +The signatures have been dealt with already. +-} + +data MonoBindInfo = MBI { mbi_poly_name :: Name + , mbi_sig :: Maybe TcIdSigInst + , mbi_mono_id :: TcId } + +tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes + -- i.e. the binders are mentioned in their RHSs, and + -- we are not rescued by a type signature + -> TcSigFun -> LetBndrSpec + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTc, [MonoBindInfo]) +tcMonoBinds is_rec sig_fn no_gen + [ L b_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches })] + -- Single function binding, + | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS + , Nothing <- sig_fn name -- ...with no type signature + = -- Note [Single function non-recursive binding special-case] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- In this very special case we infer the type of the + -- right hand side first (it may have a higher-rank type) + -- and *then* make the monomorphic Id for the LHS + -- e.g. f = \(x::forall a. a->a) -> + -- We want to infer a higher-rank type for f + setSrcSpan b_loc $ + do { ((co_fn, matches'), rhs_ty) + <- tcInfer $ \ exp_ty -> + tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ + -- We extend the error context even for a non-recursive + -- function so that in type error messages we show the + -- type of the thing whose rhs we are type checking + tcMatchesFun (L nm_loc name) matches exp_ty + + ; mono_id <- newLetBndr no_gen name Many rhs_ty + ; return (unitBag $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, + fun_matches = matches', + fun_ext = co_fn, fun_tick = [] }, + [MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id }]) } + +tcMonoBinds _ sig_fn no_gen binds + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds + + -- Bring the monomorphic Ids, into scope for the RHSs + ; let mono_infos = getMonoBindInfo tc_binds + rhs_id_env = [ (name, mono_id) + | MBI { mbi_poly_name = name + , mbi_sig = mb_sig + , mbi_mono_id = mono_id } <- mono_infos + , case mb_sig of + Just sig -> isPartialSig sig + Nothing -> True ] + -- A monomorphic binding for each term variable that lacks + -- a complete type sig. (Ones with a sig are already in scope.) + + ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env] + ; binds' <- tcExtendRecIds rhs_id_env $ + mapM (wrapLocM tcRhs) tc_binds + + ; return (listToBag binds', mono_infos) } + + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't + +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) + | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn)) + TcSigmaType + +tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind +-- Only called with plan InferGen (LetBndrSpec = LetLclBndr) +-- or NoGen (LetBndrSpec = LetGblBndr) +-- CheckGen is used only for functions with a complete type signature, +-- and tcPolyCheck doesn't use tcMonoBinds at all + +tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name + , fun_matches = matches }) + | Just (TcIdSig sig) <- sig_fn name + = -- There is a type signature. + -- It must be partial; if complete we'd be in tcPolyCheck! + -- e.g. f :: _ -> _ + -- f x = ...g... + -- Just g = ...f... + -- Hence always typechecked with InferGen + do { mono_info <- tcLhsSigId no_gen (name, sig) + ; return (TcFunBind mono_info nm_loc matches) } + + | otherwise -- No type signature + = do { mono_ty <- newOpenFlexiTyVarTy + ; mono_id <- newLetBndr no_gen name Many mono_ty + -- This ^ generates a binder with Many multiplicity because all + -- let/where-binders are unrestricted. When we introduce linear let + -- binders, we will need to retrieve the multiplicity information. + ; let mono_info = MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id } + ; return (TcFunBind mono_info nm_loc matches) } + +tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = -- See Note [Typechecking pattern bindings] + do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names + + ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ + [ (mbi_poly_name mbi, mbi_mono_id mbi) + | mbi <- sig_mbis ] + + -- See Note [Existentials in pattern bindings] + ; ((pat', nosig_mbis), pat_ty) + <- addErrCtxt (patMonoBindsCtxt pat grhss) $ + tcInfer $ \ exp_ty -> + tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $ + -- The above inferred type get an unrestricted multiplicity. It may be + -- worth it to try and find a finer-grained multiplicity here + -- if examples warrant it. + mapM lookup_info nosig_names + + ; let mbis = sig_mbis ++ nosig_mbis + + ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id) + | mbi <- mbis, let id = mbi_mono_id mbi ] + $$ ppr no_gen) + + ; return (TcPatBind mbis pat' grhss pat_ty) } + where + bndr_names = collectPatBinders pat + (nosig_names, sig_names) = partitionWith find_sig bndr_names + + find_sig :: Name -> Either Name (Name, TcIdSigInfo) + find_sig name = case sig_fn name of + Just (TcIdSig sig) -> Right (name, sig) + _ -> Left name + + -- After typechecking the pattern, look up the binder + -- names that lack a signature, which the pattern has brought + -- into scope. + lookup_info :: Name -> TcM MonoBindInfo + lookup_info name + = do { mono_id <- tcLookupId name + ; return (MBI { mbi_poly_name = name + , mbi_sig = Nothing + , mbi_mono_id = mono_id }) } + +tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) + -- AbsBind, VarBind impossible + +------------------- +tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo +tcLhsSigId no_gen (name, sig) + = do { inst_sig <- tcInstSig sig + ; mono_id <- newSigLetBndr no_gen name inst_sig + ; return (MBI { mbi_poly_name = name + , mbi_sig = Just inst_sig + , mbi_mono_id = mono_id }) } + +------------ +newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId +newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) + | CompleteSig { sig_bndr = poly_id } <- id_sig + = addInlinePrags poly_id (lookupPragEnv prags name) +newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) + = newLetBndr no_gen name Many tau + -- Binders with a signature are currently always of multiplicity + -- Many. Because they come either from toplevel, let, or where + -- declarations. Which are all unrestricted currently. + +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind GhcTc) +tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) + loc matches) + = tcExtendIdBinderStackForRhs [info] $ + tcExtendTyVarEnvForRhs mb_sig $ + do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) + ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) + matches (mkCheckExpType $ idType mono_id) + ; return ( FunBind { fun_id = L loc mono_id + , fun_matches = matches' + , fun_ext = co_fn + , fun_tick = [] } ) } + +tcRhs (TcPatBind infos pat' grhss pat_ty) + = -- When we are doing pattern bindings we *don't* bring any scoped + -- type variables into scope unlike function bindings + -- Wny not? They are not completely rigid. + -- That's why we have the special case for a single FunBind in tcMonoBinds + tcExtendIdBinderStackForRhs infos $ + do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) + ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcScalingUsage Many $ + -- Like in tcMatchesFun, this scaling happens because all + -- let bindings are unrestricted. A difference, here, is + -- that when this is not the case, any more, we will have to + -- make sure that the pattern is strict, otherwise this will + -- be desugar to incorrect code. + tcGRHSsPat grhss pat_ty + ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' + , pat_ext = NPatBindTc emptyNameSet pat_ty + , pat_ticks = ([],[]) } )} + +tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a +tcExtendTyVarEnvForRhs Nothing thing_inside + = thing_inside +tcExtendTyVarEnvForRhs (Just sig) thing_inside + = tcExtendTyVarEnvFromSig sig thing_inside + +tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a +tcExtendTyVarEnvFromSig sig_inst thing_inside + | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst + = tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv (mapSnd binderVar skol_prs) $ + thing_inside + +tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a +-- See Note [Relevant bindings and the binder stack] +tcExtendIdBinderStackForRhs infos thing_inside + = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel + | MBI { mbi_mono_id = mono_id } <- infos ] + thing_inside + -- NotTopLevel: it's a monomorphic binding + +--------------------- +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldr (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _) rest = info : rest + get_info (TcPatBind infos _ _ _) rest = infos ++ rest + + +{- Note [Relevant bindings and the binder stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typecking a binding we extend the TcBinderStack for the RHS of +the binding, with the /monomorphic/ Id. That way, if we have, say + f = \x -> blah +and something goes wrong in 'blah', we get a "relevant binding" +looking like f :: alpha -> beta +This applies if 'f' has a type signature too: + f :: forall a. [a] -> [a] + f x = True +We can't unify True with [a], and a relevant binding is f :: [a] -> [a] +If we had the *polymorphic* version of f in the TcBinderStack, it +would not be reported as relevant, because its type is closed. +(See TcErrors.relevantBindings.) + +Note [Typechecking pattern bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at: + - typecheck/should_compile/ExPat + - #12427, typecheck/should_compile/T12427{a,b} + + data T where + MkT :: Integral a => a -> Int -> T + +and suppose t :: T. Which of these pattern bindings are ok? + + E1. let { MkT p _ = t } in + + E2. let { MkT _ q = t } in + + E3. let { MkT (toInteger -> r) _ = t } in + +* (E1) is clearly wrong because the existential 'a' escapes. + What type could 'p' possibly have? + +* (E2) is fine, despite the existential pattern, because + q::Int, and nothing escapes. + +* Even (E3) is fine. The existential pattern binds a dictionary + for (Integral a) which the view pattern can use to convert the + a-valued field to an Integer, so r :: Integer. + +An easy way to see all three is to imagine the desugaring. +For (E2) it would look like + let q = case t of MkT _ q' -> q' + in + + +We typecheck pattern bindings as follows. First tcLhs does this: + + 1. Take each type signature q :: ty, partial or complete, and + instantiate it (with tcLhsSigId) to get a MonoBindInfo. This + gives us a fresh "mono_id" qm :: instantiate(ty), where qm has + a fresh name. + + Any fresh unification variables in instantiate(ty) born here, not + deep under implications as would happen if we allocated them when + we encountered q during tcPat. + + 2. Build a little environment mapping "q" -> "qm" for those Ids + with signatures (inst_sig_fun) + + 3. Invoke tcLetPat to typecheck the pattern. + + - We pass in the current TcLevel. This is captured by + GHC.Tc.Gen.Pat.tcLetPat, and put into the pc_lvl field of PatCtxt, in + PatEnv. + + - When tcPat finds an existential constructor, it binds fresh + type variables and dictionaries as usual, increments the TcLevel, + and emits an implication constraint. + + - When we come to a binder (GHC.Tc.Gen.Pat.tcPatBndr), it looks it up + in the little environment (the pc_sig_fn field of PatCtxt). + + Success => There was a type signature, so just use it, + checking compatibility with the expected type. + + Failure => No type signature. + Infer case: (happens only outside any constructor pattern) + use a unification variable + at the outer level pc_lvl + + Check case: use promoteTcType to promote the type + to the outer level pc_lvl. This is the + place where we emit a constraint that'll blow + up if existential capture takes place + + Result: the type of the binder is always at pc_lvl. This is + crucial. + + 4. Throughout, when we are making up an Id for the pattern-bound variables + (newLetBndr), we have two cases: + + - If we are generalising (generalisation plan is InferGen or + CheckGen), then the let_bndr_spec will be LetLclBndr. In that case + we want to bind a cloned, local version of the variable, with the + type given by the pattern context, *not* by the signature (even if + there is one; see #7268). The mkExport part of the + generalisation step will do the checking and impedance matching + against the signature. + + - If for some reason we are not generalising (plan = NoGen), the + LetBndrSpec will be LetGblBndr. In that case we must bind the + global version of the Id, and do so with precisely the type given + in the signature. (Then we unify with the type from the pattern + context type.) + + +And that's it! The implication constraints check for the skolem +escape. It's quite simple and neat, and more expressive than before +e.g. GHC 8.0 rejects (E2) and (E3). + +Example for (E1), starting at level 1. We generate + p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta) +The (a~beta) can't float (because of the 'a'), nor be solved (because +beta is untouchable.) + +Example for (E2), we generate + q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta) +The beta is untouchable, but floats out of the constraint and can +be solved absolutely fine. + + +************************************************************************ +* * + Generalisation +* * +********************************************************************* -} + +data GeneralisationPlan + = NoGen -- No generalisation, no AbsBinds + + | InferGen -- Implicit generalisation; there is an AbsBinds + Bool -- True <=> apply the MR; generalise only unconstrained type vars + + | CheckGen (LHsBind GhcRn) TcIdSigInfo + -- One FunBind with a signature + -- Explicit generalisation + +-- A consequence of the no-AbsBinds choice (NoGen) is that there is +-- no "polymorphic Id" and "monmomorphic Id"; there is just the one + +instance Outputable GeneralisationPlan where + ppr NoGen = text "NoGen" + ppr (InferGen b) = text "InferGen" <+> ppr b + ppr (CheckGen _ s) = text "CheckGen" <+> ppr s + +decideGeneralisationPlan + :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun + -> GeneralisationPlan +decideGeneralisationPlan dflags lbinds closed sig_fn + | has_partial_sigs = InferGen (and partial_sig_mrs) + | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig + | do_not_generalise closed = NoGen + | otherwise = InferGen mono_restriction + where + binds = map unLoc lbinds + + partial_sig_mrs :: [Bool] + -- One for each partial signature (so empty => no partial sigs) + -- The Bool is True if the signature has no constraint context + -- so we should apply the MR + -- See Note [Partial type signatures and generalisation] + partial_sig_mrs + = [ null theta + | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) + <- mapMaybe sig_fn (collectHsBindListBinders lbinds) + , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ] + + has_partial_sigs = not (null partial_sig_mrs) + + mono_restriction = xopt LangExt.MonomorphismRestriction dflags + && any restricted binds + + do_not_generalise (IsGroupClosed _ True) = False + -- The 'True' means that all of the group's + -- free vars have ClosedTypeId=True; so we can ignore + -- -XMonoLocalBinds, and generalise anyway + do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags + + -- With OutsideIn, all nested bindings are monomorphic + -- except a single function binding with a signature + one_funbind_with_sig + | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds + , Just (TcIdSig sig) <- sig_fn (unLoc v) + = Just (lbind, sig) + | otherwise + = Nothing + + -- The Haskell 98 monomorphism restriction + restricted (PatBind {}) = True + restricted (VarBind { var_id = v }) = no_sig v + restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m + && no_sig (unLoc v) + restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b) + + restricted_match mg = matchGroupArity mg == 0 + -- No args => like a pattern binding + -- Some args => a function binding + + no_sig n = not (hasCompleteSig sig_fn n) + +isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed +isClosedBndrGroup type_env binds + = IsGroupClosed fv_env type_closed + where + type_closed = allUFM (nameSetAll is_closed_type_id) fv_env + + fv_env :: NameEnv NameSet + fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds + + bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] + bindFvs (FunBind { fun_id = L _ f + , fun_ext = fvs }) + = let open_fvs = get_open_fvs fvs + in [(f, open_fvs)] + bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) + = let open_fvs = get_open_fvs fvs + in [(b, open_fvs) | b <- collectPatBinders pat] + bindFvs _ + = [] + + get_open_fvs fvs = filterNameSet (not . is_closed) fvs + + is_closed :: Name -> ClosedTypeId + is_closed name + | Just thing <- lookupNameEnv type_env name + = case thing of + AGlobal {} -> True + ATcId { tct_info = ClosedLet } -> True + _ -> False + + | otherwise + = True -- The free-var set for a top level binding mentions + + + is_closed_type_id :: Name -> Bool + -- We're already removed Global and ClosedLet Ids + is_closed_type_id name + | Just thing <- lookupNameEnv type_env name + = case thing of + ATcId { tct_info = NonClosedLet _ cl } -> cl + ATcId { tct_info = NotLetBound } -> False + ATyVar {} -> False + -- In-scope type variables are not closed! + _ -> pprPanic "is_closed_id" (ppr name) + + | otherwise + = True -- The free-var set for a top level binding mentions + -- imported things too, so that we can report unused imports + -- These won't be in the local type env. + -- Ditto class method etc from the current module + + +{- ********************************************************************* +* * + Error contexts and messages +* * +********************************************************************* -} + +-- This one is called on LHS, when pat and grhss are both Name +-- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) + => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc +patMonoBindsCtxt pat grhss + = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/GHC/Tc/Gen/Default.hs b/GHC/Tc/Gen/Default.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Default.hs @@ -0,0 +1,108 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking @default@ declarations +module GHC.Tc.Gen.Default ( tcDefaults ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Core.Class +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Tc.Validity +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt + +tcDefaults :: [LDefaultDecl GhcRn] + -> TcM (Maybe [Type]) -- Defaulting types to heave + -- into Tc monad for later use + -- in Disambig. + +tcDefaults [] + = getDeclaredDefaultTys -- No default declaration, so get the + -- default types from the envt; + -- i.e. use the current ones + -- (the caller will put them back there) + -- It's important not to return defaultDefaultTys here (which + -- we used to do) because in a TH program, tcDefaults [] is called + -- repeatedly, once for each group of declarations between top-level + -- splices. We don't want to carefully set the default types in + -- one group, only for the next group to ignore them and install + -- defaultDefaultTys + +tcDefaults [L _ (DefaultDecl _ [])] + = return (Just []) -- Default declaration specifying no types + +tcDefaults [L locn (DefaultDecl _ mono_tys)] + = setSrcSpan locn $ + addErrCtxt defaultDeclCtxt $ + do { ovl_str <- xoptM LangExt.OverloadedStrings + ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules + ; num_class <- tcLookupClass numClassName + ; deflt_str <- if ovl_str + then mapM tcLookupClass [isStringClassName] + else return [] + ; deflt_interactive <- if ext_deflt + then mapM tcLookupClass interactiveClassNames + else return [] + ; let deflt_clss = num_class : deflt_str ++ deflt_interactive + + ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys + + ; return (Just tau_tys) } + +tcDefaults decls@(L locn (DefaultDecl _ _) : _) + = setSrcSpan locn $ + failWithTc (dupDefaultDeclErr decls) + + +tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type +tc_default_ty deflt_clss hs_ty + = do { ty <- solveEqualities $ + tcInferLHsType hs_ty + ; ty <- zonkTcTypeToType ty -- establish Type invariants + ; checkValidType DefaultDeclCtxt ty + + -- Check that the type is an instance of at least one of the deflt_clss + ; oks <- mapM (check_instance ty) deflt_clss + ; checkTc (or oks) (badDefaultTy ty deflt_clss) + ; return ty } + +check_instance :: Type -> Class -> TcM Bool + -- Check that ty is an instance of cls + -- We only care about whether it worked or not; return a boolean +check_instance ty cls + = do { (_, success) <- discardErrs $ + askNoErrs $ + simplifyDefault [mkClassPred cls [ty]] + ; return success } + +defaultDeclCtxt :: SDoc +defaultDeclCtxt = text "When checking the types in a default declaration" + +dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc +dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) + = hang (text "Multiple default declarations") + 2 (vcat (map pp dup_things)) + where + pp :: Located (DefaultDecl GhcRn) -> SDoc + pp (L locn (DefaultDecl _ _)) + = text "here was another default declaration" <+> ppr locn +dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" + +badDefaultTy :: Type -> [Class] -> SDoc +badDefaultTy ty deflt_clss + = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/GHC/Tc/Gen/Export.hs b/GHC/Tc/Gen/Export.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Export.hs @@ -0,0 +1,856 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Builtin.Names +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Utils.Error +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Core.TyCon +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Types +import GHC.Utils.Outputable +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Data.Maybe +import GHC.Types.Unique.Set +import GHC.Utils.Misc (capitalise) +import GHC.Data.FastString (fsLit) + +import Control.Monad +import GHC.Driver.Session +import GHC.Rename.Doc ( rnHsDoc ) +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import Data.Either ( partitionEithers ) + +{- +************************************************************************ +* * +\subsection{Export list processing} +* * +************************************************************************ + +Processing the export list. + +You might think that we should record things that appear in the export +list as ``occurrences'' (using @addOccurrenceName@), but you'd be +wrong. We do check (here) that they are in scope, but there is no +need to slurp in their actual declaration (which is what +@addOccurrenceName@ forces). + +Indeed, doing so would big trouble when compiling @PrelBase@, because +it re-exports @GHC@, which includes @takeMVar#@, whose type includes +@ConcBase.StateAndSynchVar#@, and so on... + +Note [Exports of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you see (#5306) + module M where + import X( F ) + data instance F Int = FInt +What does M export? AvailTC F [FInt] + or AvailTC F [F,FInt]? +The former is strictly right because F isn't defined in this module. +But then you can never do an explicit import of M, thus + import M( F( FInt ) ) +because F isn't exported by M. Nor can you import FInt alone from here + import M( FInt ) +because we don't have syntax to support that. (It looks like an import of +the type FInt.) + +At one point I implemented a compromise: + * When constructing exports with no export list, or with module M( + module M ), we add the parent to the exports as well. + * But not when you see module M( f ), even if f is a + class method with a parent. + * Nor when you see module M( module N ), with N /= M. + +But the compromise seemed too much of a hack, so we backed it out. +You just have to use an explicit export list: + module M( F(..) ) where ... + +Note [Avails of associated data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you have (#16077) + + {-# LANGUAGE TypeFamilies #-} + module A (module A) where + + class C a where { data T a } + instance C () where { data T () = D } + +Because @A@ is exported explicitly, GHC tries to produce an export list +from the @GlobalRdrEnv@. In this case, it pulls out the following: + + [ C defined at A.hs:4:1 + , T parent:C defined at A.hs:4:23 + , D parent:T defined at A.hs:5:35 ] + +If map these directly into avails, (via 'availFromGRE'), we get +@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@. +That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is +exported, but it isn't the first entry in the avail! + +We work around this issue by expanding GREs where the parent and child +are both type constructors into two GRES. + + T parent:C defined at A.hs:4:23 + + => + + [ T parent:C defined at A.hs:4:23 + , T defined at A.hs:4:23 ] + +Then, we get @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged +into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant). +-} + +data ExportAccum -- The type of the accumulating parameter of + -- the main worker function in rnExports + = ExportAccum + ExportOccMap -- Tracks exported occurrence names + (UniqSet ModuleName) -- Tracks (re-)exported module names + +emptyExportAccum :: ExportAccum +emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet + +accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y))) + -> [x] + -> TcRn [y] +accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum + where f' acc x = do + m <- attemptM (f acc x) + pure $ case m of + Just (Just (acc', y)) -> (acc', Just y) + _ -> (acc, Nothing) + +type ExportOccMap = OccEnv (Name, IE GhcPs) + -- Tracks what a particular exported OccName + -- in an export list refers to, and which item + -- it came from. It's illegal to export two distinct things + -- that have the same occurrence name + +rnExports :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list + -> RnM TcGblEnv + + -- Complains if two distinct exports have same OccName + -- Warns about identical exports. + -- Complains about exports items not in scope + +rnExports explicit_mod exports + = checkNoErrs $ -- Fail if anything in rnExports finds + -- an error fails, to avoid error cascade + unsetWOptM Opt_WarnWarningsDeprecations $ + -- Do not report deprecations arising from the export + -- list, to avoid bleating about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + do { dflags <- getDynFlags + ; tcg_env <- getGblEnv + ; let TcGblEnv { tcg_mod = this_mod + , tcg_rdr_env = rdr_env + , tcg_imports = imports + , tcg_src = hsc_src } = tcg_env + default_main | mainModIs dflags == this_mod + , Just main_fun <- mainFunIs dflags + = mkUnqual varName (fsLit main_fun) + | otherwise + = main_RDR_Unqual + ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832 + + -- If a module has no explicit header, and it has one or more main + -- functions in scope, then add a header like + -- "module Main(main) where ..." #13839 + -- See Note [Modules without a module header] + ; let real_exports + | explicit_mod = exports + | has_main = Just (noLoc [noLoc (IEVar noExtField + (noLoc (IEName $ noLoc default_main)))]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + | otherwise = Nothing + + -- Rename the export list + ; let do_it = exports_from_avail real_exports rdr_env imports this_mod + ; (rn_exports, final_avails) + <- if hsc_src == HsigFile + then do (mb_r, msgs) <- tryTc do_it + case mb_r of + Just r -> return r + Nothing -> addMessages msgs >> failM + else checkNoErrs do_it + + -- Final processing + ; let final_ns = availsToNameSetWithSelectors final_avails + + ; traceRn "rnExports: Exports:" (ppr final_avails) + + ; return (tcg_env { tcg_exports = final_avails + , tcg_rn_exports = case tcg_rn_exports tcg_env of + Nothing -> Nothing + Just _ -> rn_exports + , tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly final_ns }) } + +exports_from_avail :: Maybe (Located [LIE GhcPs]) + -- ^ 'Nothing' means no explicit export list + -> GlobalRdrEnv + -> ImportAvails + -- ^ Imported modules; this is used to test if a + -- @module Foo@ export is valid (it's not valid + -- if we didn't import @Foo@!) + -> Module + -> RnM (Maybe [(LIE GhcRn, Avails)], Avails) + -- (Nothing, _) <=> no explicit export list + -- if explicit export list is present it contains + -- each renamed export item together with its exported + -- names. + +exports_from_avail Nothing rdr_env _imports _this_mod + -- The same as (module M) where M is the current module name, + -- so that's how we handle it, except we also export the data family + -- when a data instance is exported. + = do { + ; warnMissingExportList <- woptM Opt_WarnMissingExportList + ; warnIfFlag Opt_WarnMissingExportList + warnMissingExportList + (missingModuleExportWarn $ moduleName _this_mod) + ; let avails = + map fix_faminst . gresToAvailInfo + . filter isLocalGRE . globalRdrEnvElts $ rdr_env + ; return (Nothing, avails) } + where + -- #11164: when we define a data instance + -- but not data family, re-export the family + -- Even though we don't check whether this is actually a data family + -- only data families can locally define subordinate things (`ns` here) + -- without locally defining (and instead importing) the parent (`n`) + fix_faminst (AvailTC n ns flds) = + let new_ns = + case ns of + [] -> [n] + (p:_) -> if p == n then ns else n:ns + in AvailTC n new_ns flds + + fix_faminst avail = avail + + +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod + = do ie_avails <- accumExports do_litem rdr_items + let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families + return (Just ie_avails, final_exports) + where + do_litem :: ExportAccum -> LIE GhcPs + -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) + do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) + + -- Maps a parent to its in-scope children + kids_env :: NameEnv [GlobalRdrElt] + kids_env = mkChildEnv (globalRdrEnvElts rdr_env) + + -- See Note [Avails of associated data families] + expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] + expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p }) + | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }] + expand_tyty_gre gre = [gre] + + imported_modules = [ imv_name imv + | xs <- moduleEnvElts $ imp_mods imports + , imv <- importedByUser xs ] + + exports_from_item :: ExportAccum -> LIE GhcPs + -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) + exports_from_item (ExportAccum occs earlier_mods) + (L loc ie@(IEModuleContents _ lmod@(L _ mod))) + | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M + = do { warnIfFlag Opt_WarnDuplicateExports True + (dupModuleExport mod) ; + return Nothing } + + | otherwise + = do { let { exportValid = (mod `elem` imported_modules) + || (moduleName this_mod == mod) + ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + ; new_exports = [ availFromGRE gre' + | (gre, _) <- gre_prs + , gre' <- expand_tyty_gre gre ] + ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs + ; mods = addOneToUniqSet earlier_mods mod + } + + ; checkErr exportValid (moduleNotImported mod) + ; warnIfFlag Opt_WarnDodgyExports + (exportValid && null gre_prs) + (nullModuleExport mod) + + ; traceRn "efa" (ppr mod $$ ppr all_gres) + ; addUsedGREs all_gres + + ; occs' <- check_occs ie occs new_exports + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + ; traceRn "export_mod" + (vcat [ ppr mod + , ppr new_exports ]) + + ; return (Just ( ExportAccum occs' mods + , ( L loc (IEModuleContents noExtField lmod) + , new_exports))) } + + exports_from_item acc@(ExportAccum occs mods) (L loc ie) + | isDoc ie + = do new_ie <- lookup_doc_ie ie + return (Just (acc, (L loc new_ie, []))) + + | otherwise + = do (new_ie, avail) <- lookup_ie ie + if isUnboundName (ieName new_ie) + then return Nothing -- Avoid error cascade + else do + + occs' <- check_occs ie occs [avail] + + return (Just ( ExportAccum occs' mods + , (L loc new_ie, [avail]))) + + ------------- + lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) + lookup_ie (IEVar _ (L l rdr)) + = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr + return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) + + lookup_ie (IEThingAbs _ (L l rdr)) + = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr + return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) + , avail) + + lookup_ie ie@(IEThingAll _ n') + = do + (n, avail, flds) <- lookup_ie_all ie n' + let name = unLoc n + return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) + , AvailTC name (name:avail) flds) + + + lookup_ie ie@(IEThingWith _ l wc sub_rdrs _) + = do + (lname, subs, avails, flds) + <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs + (_, all_avail, all_flds) <- + case wc of + NoIEWildcard -> return (lname, [], []) + IEWildcard _ -> lookup_ie_all ie l + let name = unLoc lname + return (IEThingWith noExtField (replaceLWrappedName l name) wc subs + (flds ++ (map noLoc all_flds)), + AvailTC name (name : avails ++ all_avail) + (map unLoc flds ++ all_flds)) + + + lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + + + lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] + -> RnM (Located Name, [LIEWrappedName Name], [Name], + [Located FieldLabel]) + lookup_ie_with (L l rdr) sub_rdrs + = do name <- lookupGlobalOccRn $ ieWrappedName rdr + (non_flds, flds) <- lookupChildrenExport name sub_rdrs + if isUnboundName name + then return (L l name, [], [name], []) + else return (L l name, non_flds + , map (ieWrappedName . unLoc) non_flds + , flds) + + lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName + -> RnM (Located Name, [Name], [FieldLabel]) + lookup_ie_all ie (L l rdr) = + do name <- lookupGlobalOccRn $ ieWrappedName rdr + let gres = findChildren kids_env name + (non_flds, flds) = classifyGREs gres + addUsedKids (ieWrappedName rdr) gres + warnDodgyExports <- woptM Opt_WarnDodgyExports + when (null gres) $ + if isTyConName name + then when warnDodgyExports $ + addWarn (Reason Opt_WarnDodgyExports) + (dodgyExportWarn name) + else -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + addErr (exportItemErr ie) + return (L l name, non_flds, flds) + + ------------- + lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) + lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc + return (IEGroup noExtField lev rn_doc) + lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc + return (IEDoc noExtField rn_doc) + lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExtField str) + lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier + + -- In an export item M.T(A,B,C), we want to treat the uses of + -- A,B,C as if they were M.A, M.B, M.C + -- Happily pickGREs does just the right thing + addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () + addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) + +classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) +classifyGREs = partitionEithers . map classifyGRE + +classifyGRE :: GlobalRdrElt -> Either Name FieldLabel +classifyGRE gre = case gre_par gre of + FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) + FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) + _ -> Left n + where + n = gre_name gre + +isDoc :: IE GhcPs -> Bool +isDoc (IEDoc {}) = True +isDoc (IEDocNamed {}) = True +isDoc (IEGroup {}) = True +isDoc _ = False + +-- Renaming and typechecking of exports happens after everything else has +-- been typechecked. + +{- +Note [Modules without a module header] +-------------------------------------------------- + +The Haskell 2010 report says in section 5.1: + +>> An abbreviated form of module, consisting only of the module body, is +>> permitted. If this is used, the header is assumed to be +>> ‘module Main(main) where’. + +For modules without a module header, this is implemented the +following way: + +If the module has a main function in scope: + Then create a module header and export the main function, + as if a module header like ‘module Main(main) where...’ would exist. + This has the effect to mark the main function and all top level + functions called directly or indirectly via main as 'used', + and later on, unused top-level functions can be reported correctly. + There is no distinction between GHC and GHCi. +If the module has several main functions in scope: + Then generate a header as above. The ambiguity is reported later in + module `GHC.Tc.Module` function `check_main`. +If the module has NO main function: + Then export all top-level functions. This marks all top level + functions as 'used'. + In GHCi this has the effect, that we don't get any 'non-used' warnings. + In GHC, however, the 'has-main-module' check in GHC.Tc.Module.checkMain + fires, and we get the error: + The IO action ‘main’ is not defined in module ‘Main’ +-} + + +-- Renaming exports lists is a minefield. Five different things can appear in +-- children export lists ( T(A, B, C) ). +-- 1. Record selectors +-- 2. Type constructors +-- 3. Data constructors +-- 4. Pattern Synonyms +-- 5. Pattern Synonym Selectors +-- +-- However, things get put into weird name spaces. +-- 1. Some type constructors are parsed as variables (-.->) for example. +-- 2. All data constructors are parsed as type constructors +-- 3. When there is ambiguity, we default type constructors to data +-- constructors and require the explicit `type` keyword for type +-- constructors. +-- +-- This function first establishes the possible namespaces that an +-- identifier might be in (`choosePossibleNameSpaces`). +-- +-- Then for each namespace in turn, tries to find the correct identifier +-- there returning the first positive result or the first terminating +-- error. +-- + + + +lookupChildrenExport :: Name -> [LIEWrappedName RdrName] + -> RnM ([LIEWrappedName Name], [Located FieldLabel]) +lookupChildrenExport spec_parent rdr_items = + do + xs <- mapAndReportM doOne rdr_items + return $ partitionEithers xs + where + -- Pick out the possible namespaces in order of priority + -- This is a consequence of how the parser parses all + -- data constructors as type constructors. + choosePossibleNamespaces :: NameSpace -> [NameSpace] + choosePossibleNamespaces ns + | ns == varName = [varName, tcName] + | ns == tcName = [dataName, tcName] + | otherwise = [ns] + -- Process an individual child + doOne :: LIEWrappedName RdrName + -> RnM (Either (LIEWrappedName Name) (Located FieldLabel)) + doOne n = do + + let bareName = (ieWrappedName . unLoc) n + lkup v = lookupSubBndrOcc_helper False True + spec_parent (setRdrNameSpace bareName v) + + name <- combineChildLookupResult $ map lkup $ + choosePossibleNamespaces (rdrNameSpace bareName) + traceRn "lookupChildrenExport" (ppr name) + -- Default to data constructors for slightly better error + -- messages + let unboundName :: RdrName + unboundName = if rdrNameSpace bareName == varName + then bareName + else setRdrNameSpace bareName dataName + + case name of + NameNotFound -> do { ub <- reportUnboundName unboundName + ; let l = getLoc n + ; return (Left (L l (IEName (L l ub))))} + FoundFL fls -> return $ Right (L (getLoc n) fls) + FoundName par name -> do { checkPatSynParent spec_parent par name + ; return + $ Left (replaceLWrappedName n name) } + IncorrectParent p g td gs -> failWithDcErr p g td gs + + +-- Note: [Typing Pattern Synonym Exports] +-- It proved quite a challenge to precisely specify which pattern synonyms +-- should be allowed to be bundled with which type constructors. +-- In the end it was decided to be quite liberal in what we allow. Below is +-- how Simon described the implementation. +-- +-- "Personally I think we should Keep It Simple. All this talk of +-- satisfiability makes me shiver. I suggest this: allow T( P ) in all +-- situations except where `P`'s type is ''visibly incompatible'' with +-- `T`. +-- +-- What does "visibly incompatible" mean? `P` is visibly incompatible +-- with +-- `T` if +-- * `P`'s type is of form `... -> S t1 t2` +-- * `S` is a data/newtype constructor distinct from `T` +-- +-- Nothing harmful happens if we allow `P` to be exported with +-- a type it can't possibly be useful for, but specifying a tighter +-- relationship is very awkward as you have discovered." +-- +-- Note that this allows *any* pattern synonym to be bundled with any +-- datatype type constructor. For example, the following pattern `P` can be +-- bundled with any type. +-- +-- ``` +-- pattern P :: (A ~ f) => f +-- ``` +-- +-- So we provide basic type checking in order to help the user out, most +-- pattern synonyms are defined with definite type constructors, but don't +-- actually prevent a library author completely confusing their users if +-- they want to. +-- +-- So, we check for exactly four things +-- 1. The name arises from a pattern synonym definition. (Either a pattern +-- synonym constructor or a pattern synonym selector) +-- 2. The pattern synonym is only bundled with a datatype or newtype. +-- 3. Check that the head of the result type constructor is an actual type +-- constructor and not a type variable. (See above example) +-- 4. Is so, check that this type constructor is the same as the parent +-- type constructor. +-- +-- +-- Note: [Types of TyCon] +-- +-- This check appears to be overlly complicated, Richard asked why it +-- is not simply just `isAlgTyCon`. The answer for this is that +-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. +-- (It is either a newtype or data depending on the number of methods) +-- + +-- | Given a resolved name in the children export list and a parent. Decide +-- whether we are allowed to export the child with the parent. +-- Invariant: gre_par == NoParent +-- See note [Typing Pattern Synonym Exports] +checkPatSynParent :: Name -- ^ Alleged parent type constructor + -- User wrote T( P, Q ) + -> Parent -- The parent of P we discovered + -> Name -- ^ Either a + -- a) Pattern Synonym Constructor + -- b) A pattern synonym selector + -> TcM () -- Fails if wrong parent +checkPatSynParent _ (ParentIs {}) _ + = return () + +checkPatSynParent _ (FldParent {}) _ + = return () + +checkPatSynParent parent NoParent mpat_syn + | isUnboundName parent -- Avoid an error cascade + = return () + + | otherwise + = do { parent_ty_con <- tcLookupTyCon parent + ; mpat_syn_thing <- tcLookupGlobal mpat_syn + + -- 1. Check that the Id was actually from a thing associated with patsyns + ; case mpat_syn_thing of + AnId i | isId i + , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i + -> handle_pat_syn (selErr i) parent_ty_con p + + AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p + + _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] } + where + psErr = exportErrCtxt "pattern synonym" + selErr = exportErrCtxt "pattern synonym record selector" + + assocClassErr :: SDoc + assocClassErr = text "Pattern synonyms can be bundled only with datatypes." + + handle_pat_syn :: SDoc + -> TyCon -- ^ Parent TyCon + -> PatSyn -- ^ Corresponding bundled PatSyn + -- and pretty printed origin + -> TcM () + handle_pat_syn doc ty_con pat_syn + + -- 2. See note [Types of TyCon] + | not $ isTyConWithSrcDataCons ty_con + = addErrCtxt doc $ failWithTc assocClassErr + + -- 3. Is the head a type variable? + | Nothing <- mtycon + = return () + -- 4. Ok. Check they are actually the same type constructor. + + | Just p_ty_con <- mtycon, p_ty_con /= ty_con + = addErrCtxt doc $ failWithTc typeMismatchError + + -- 5. We passed! + | otherwise + = return () + + where + expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) + (_, _, _, _, _, res_ty) = patSynSig pat_syn + mtycon = fst <$> tcSplitTyConApp_maybe res_ty + typeMismatchError :: SDoc + typeMismatchError = + text "Pattern synonyms can only be bundled with matching type constructors" + $$ text "Couldn't match expected type of" + <+> quotes (ppr expected_res_ty) + <+> text "with actual type of" + <+> quotes (ppr res_ty) + + +{-===========================================================================-} +check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] + -> RnM ExportOccMap +check_occs ie occs avails + -- 'names' and 'fls' are the entities specified by 'ie' + = foldlM check occs names_with_occs + where + -- Each Name specified by 'ie', paired with the OccName used to + -- refer to it in the GlobalRdrEnv + -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail). + -- + -- We check for export clashes using the selector Name, but need + -- the field label OccName for presenting error messages. + names_with_occs = availsNamesWithOccs avails + + check occs (name, occ) + = case lookupOccEnv occs name_occ of + Nothing -> return (extendOccEnv occs name_occ (name, ie)) + + Just (name', ie') + | name == name' -- Duplicate export + -- But we don't want to warn if the same thing is exported + -- by two different module exports. See ticket #4478. + -> do { warnIfFlag Opt_WarnDuplicateExports + (not (dupExport_ok name ie ie')) + (dupExportWarn occ ie ie') + ; return occs } + + | otherwise -- Same occ name but different names: an error + -> do { global_env <- getGlobalRdrEnv ; + addErr (exportClashErr global_env occ name' name ie' ie) ; + return occs } + where + name_occ = nameOccName name + + +dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool +-- The Name is exported by both IEs. Is that ok? +-- "No" iff the name is mentioned explicitly in both IEs +-- or one of the IEs mentions the name *alone* +-- "Yes" otherwise +-- +-- Examples of "no": module M( f, f ) +-- module M( fmap, Functor(..) ) +-- module M( module Data.List, head ) +-- +-- Example of "yes" +-- module M( module A, module B ) where +-- import A( f ) +-- import B( f ) +-- +-- Example of "yes" (#2436) +-- module M( C(..), T(..) ) where +-- class C a where { data T a } +-- instance C Int where { data T Int = TInt } +-- +-- Example of "yes" (#2436) +-- module Foo ( T ) where +-- data family T a +-- module Bar ( T(..), module Foo ) where +-- import Foo +-- data instance T Int = TInt + +dupExport_ok n ie1 ie2 + = not ( single ie1 || single ie2 + || (explicit_in ie1 && explicit_in ie2) ) + where + explicit_in (IEModuleContents {}) = False -- module M + explicit_in (IEThingAll _ r) + = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) + explicit_in _ = True + + single IEVar {} = True + single IEThingAbs {} = True + single _ = False + + +dupModuleExport :: ModuleName -> SDoc +dupModuleExport mod + = hsep [text "Duplicate", + quotes (text "Module" <+> ppr mod), + text "in export list"] + +moduleNotImported :: ModuleName -> SDoc +moduleNotImported mod + = hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "is not imported"] + +nullModuleExport :: ModuleName -> SDoc +nullModuleExport mod + = hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "exports nothing"] + +missingModuleExportWarn :: ModuleName -> SDoc +missingModuleExportWarn mod + = hsep [text "The export item", + quotes (text "module" <+> ppr mod), + text "is missing an export list"] + + +dodgyExportWarn :: Name -> SDoc +dodgyExportWarn item + = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn) + +exportErrCtxt :: Outputable o => String -> o -> SDoc +exportErrCtxt herald exp = + text "In the" <+> text (herald ++ ":") <+> ppr exp + + +addExportErrCtxt :: (OutputableBndrId p) + => IE (GhcPass p) -> TcM a -> TcM a +addExportErrCtxt ie = addErrCtxt exportCtxt + where + exportCtxt = text "In the export:" <+> ppr ie + +exportItemErr :: IE GhcPs -> SDoc +exportItemErr export_item + = sep [ text "The export item" <+> quotes (ppr export_item), + text "attempts to export constructors or class methods that are not visible here" ] + + +dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc +dupExportWarn occ_name ie1 ie2 + = hsep [quotes (ppr occ_name), + text "is exported by", quotes (ppr ie1), + text "and", quotes (ppr ie2)] + +dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc +dcErrMsg ty_con what_is thing parents = + text "The type constructor" <+> quotes (ppr ty_con) + <+> text "is not the parent of the" <+> text what_is + <+> quotes thing <> char '.' + $$ text (capitalise what_is) + <> text "s can only be exported with their parent type constructor." + $$ (case parents of + [] -> empty + [_] -> text "Parent:" + _ -> text "Parents:") <+> fsep (punctuate comma parents) + +failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a +failWithDcErr parent thing thing_doc parents = do + ty_thing <- tcLookupGlobal thing + failWithTc $ dcErrMsg parent (pp_category ty_thing) + thing_doc (map ppr parents) + where + pp_category :: TyThing -> String + pp_category (AnId i) + | isRecordSelector i = "record selector" + pp_category i = tyThingCategory i + + +exportClashErr :: GlobalRdrEnv -> OccName + -> Name -> Name + -> IE GhcPs -> IE GhcPs + -> MsgDoc +exportClashErr global_env occ name1 name2 ie1 ie2 + = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + , ppr_export ie1' name1' + , ppr_export ie2' name2' ] + where + ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> + quotes (ppr_name name)) + 2 (pprNameProvenance (get_gre name))) + + -- DuplicateRecordFields means that nameOccName might be a mangled + -- $sel-prefixed thing, in which case show the correct OccName alone + ppr_name name + | nameOccName name == occ = ppr name + | otherwise = ppr occ + + -- get_gre finds a GRE for the Name, so that we can show its provenance + get_gre name + = fromMaybe (pprPanic "exportClashErr" (ppr name)) + (lookupGRE_Name_OccName global_env name occ) + get_loc name = greSrcSpan (get_gre name) + (name1', ie1', name2', ie2') = + case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of + LT -> (name1, ie1, name2, ie2) + GT -> (name2, ie2, name1, ie1) + EQ -> panic "exportClashErr: clashing exports have idential location" diff --git a/GHC/Tc/Gen/Expr.hs b/GHC/Tc/Gen/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Expr.hs @@ -0,0 +1,3080 @@ +{- +% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, DataKinds, TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Gen.Expr + ( tcCheckPolyExpr, + tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, + tcInferSigma, tcInferRho, tcInferRhoNC, + tcExpr, + tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, + tcCheckId, + addAmbiguousNameErr, + getFixedTyVars ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) +import GHC.Builtin.Names.TH( liftStringName, liftName ) + +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Types.Basic +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds ) +import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig ) +import GHC.Tc.Solver ( simplifyInfer, InferMode(..) ) +import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst, tcLookupDataFamInst_maybe ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Rename.Env ( addUsedGRE ) +import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Arrow +import GHC.Tc.Gen.Match +import GHC.Tc.Gen.HsType +import GHC.Tc.TyCl.PatSyn ( tcPatSynBuilderOcc, nonBidirectionalErr ) +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType as TcType +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst (substTyWithInScope) +import GHC.Core.Type +import GHC.Tc.Types.Evidence +import GHC.Types.Var.Set +import GHC.Builtin.Types +import GHC.Builtin.PrimOps( tagToEnumKey ) +import GHC.Builtin.Names +import GHC.Driver.Session +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import Control.Monad +import GHC.Core.Class(classTyCon) +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import qualified GHC.LanguageExtensions as LangExt + +import Data.Function +import Data.List (partition, sortBy, groupBy, intersect) +import qualified Data.Set as Set + +{- +************************************************************************ +* * +\subsection{Main wrappers} +* * +************************************************************************ +-} + + +tcCheckPolyExpr, tcCheckPolyExprNC + :: LHsExpr GhcRn -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytype) + -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type + +-- tcCheckPolyExpr is a convenient place (frequent but not too frequent) +-- place to add context information. +-- The NC version does not do so, usually because the caller wants +-- to do so himself. + +tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty) +tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty) + +-- These versions take an ExpType +tcPolyExpr, tcPolyExprNC + :: LHsExpr GhcRn -> ExpSigmaType + -> TcM (LHsExpr GhcTc) + +tcPolyExpr expr res_ty + = addExprCtxt expr $ + do { traceTc "tcPolyExpr" (ppr res_ty) + ; tcPolyExprNC expr res_ty } + +tcPolyExprNC (L loc expr) res_ty + = set_loc_and_ctxt loc expr $ + do { traceTc "tcPolyExprNC" (ppr res_ty) + ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> + tcExpr expr res_ty + ; return $ L loc (mkHsWrap wrap expr') } + + where -- See Note [Rebindable syntax and HsExpansion), which describes + -- the logic behind this location/context tweaking. + set_loc_and_ctxt l e m = do + inGenCode <- inGeneratedCode + if inGenCode && not (isGeneratedSrcSpan l) + then setSrcSpan l $ addExprCtxt (L l e) m + else setSrcSpan l m + +--------------- +tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) +-- Used by tcRnExpr to implement GHCi :type +-- It goes against the principle of eager instantiation, +-- so we expect very very few calls to this function +-- Most clients will want tcInferRho +tcInferSigma le@(L loc expr) + = addExprCtxt le $ setSrcSpan loc $ + do { (fun, args, ty) <- tcInferApp expr + ; return (L loc (applyHsArgs fun args), ty) } + +--------------- +tcCheckMonoExpr, tcCheckMonoExprNC + :: LHsExpr GhcRn -- Expression to type check + -> TcRhoType -- Expected type + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) +tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty) +tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty) + +tcMonoExpr, tcMonoExprNC + :: LHsExpr GhcRn -- Expression to type check + -> ExpRhoType -- Expected type + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) + +tcMonoExpr expr res_ty + = addExprCtxt expr $ + tcMonoExprNC expr res_ty + +tcMonoExprNC (L loc expr) res_ty + = setSrcSpan loc $ + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +--------------- +tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +-- Infer a *rho*-type. The return type is always instantiated. +tcInferRho le = addExprCtxt le (tcInferRhoNC le) + +tcInferRhoNC (L loc expr) + = setSrcSpan loc $ + do { (expr', rho) <- tcInfer (tcExpr expr) + ; return (L loc expr', rho) } + + +{- ********************************************************************* +* * + tcExpr: the main expression typechecker +* * +********************************************************************* -} + +tcLExpr, tcLExprNC + :: LHsExpr GhcRn -- Expression to type check + -> ExpRhoType -- Expected type + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) + +tcLExpr expr res_ty + = setSrcSpan (getLoc expr) $ addExprCtxt expr (tcLExprNC expr res_ty) + +tcLExprNC (L loc expr) res_ty + = setSrcSpan loc $ + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty +tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty + +tcExpr e@(HsApp {}) res_ty = tcApp e res_ty +tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty + +tcExpr e@(HsLit x lit) res_ty + = do { let lit_ty = hsLitType lit + ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } + +tcExpr (HsPar x expr) res_ty = do { expr' <- tcLExprNC expr res_ty + ; return (HsPar x expr') } + +tcExpr (HsPragE x prag expr) res_ty + = do { expr' <- tcLExpr expr res_ty + ; return (HsPragE x (tcExprPrag prag) expr') } + +tcExpr (HsOverLit x lit) res_ty + = do { lit' <- newOverloadedLit lit res_ty + ; return (HsOverLit x lit') } + +tcExpr (NegApp x expr neg_expr) res_ty + = do { (expr', neg_expr') + <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ + \[arg_ty] [arg_mult] -> + tcScalingUsage arg_mult $ tcLExpr expr (mkCheckExpType arg_ty) + ; return (NegApp x expr' neg_expr') } + +tcExpr e@(HsIPVar _ x) res_ty + = do { {- Implicit parameters must have a *tau-type* not a + type scheme. We enforce this by creating a fresh + type variable as its type. (Because res_ty may not + be a tau-type.) -} + ip_ty <- newOpenFlexiTyVarTy + ; let ip_name = mkStrLitTy (hsIPNameFS x) + ; ipClass <- tcLookupClass ipClassName + ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) + ; tcWrapResult e + (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) + ip_ty res_ty } + where + -- Coerces a dictionary for `IP "x" t` into `t`. + fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ + unwrapIP $ mkClassPred ipClass [x,ty] + origin = IPOccOrigin x + +tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty + = do { -- See Note [Type-checking overloaded labels] + loc <- getSrcSpanM + ; case mb_fromLabel of + Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty + Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName + ; alpha <- newFlexiTyVarTy liftedTypeKind + ; let pred = mkClassPred isLabelClass [lbl, alpha] + ; loc <- getSrcSpanM + ; var <- emitWantedEvVar origin pred + ; tcWrapResult e + (fromDict pred (HsVar noExtField (L loc var))) + alpha res_ty } } + where + -- Coerces a dictionary for `IsLabel "x" t` into `t`, + -- or `HasField "x" r a into `r -> a`. + fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred + origin = OverLabelOrigin l + lbl = mkStrLitTy l + + applyFromLabel loc fromLabel = + HsAppType noExtField + (L loc (HsVar noExtField (L loc fromLabel))) + (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) + +tcExpr (HsLam x match) res_ty + = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty + ; return (mkHsWrap wrap (HsLam x match')) } + where + match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } + herald = sep [ text "The lambda expression" <+> + quotes (pprSetDepth (PartWay 1) $ + pprMatches match), + -- The pprSetDepth makes the abstraction print briefly + text "has"] + +tcExpr e@(HsLamCase x matches) res_ty + = do { (wrap, matches') + <- tcMatchLambda msg match_ctxt matches res_ty + -- The laziness annotation is because we don't want to fail here + -- if there are multiple arguments + ; return (mkHsWrap wrap $ HsLamCase x matches') } + where + msg = sep [ text "The function" <+> quotes (ppr e) + , text "requires"] + match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } + +tcExpr e@(ExprWithTySig _ expr hs_ty) res_ty + = do { (expr', poly_ty) <- tcExprWithSig expr hs_ty + ; tcWrapResult e expr' poly_ty res_ty } + +{- +Note [Type-checking overloaded labels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that we have + + module GHC.OverloadedLabels where + class IsLabel (x :: Symbol) a where + fromLabel :: a + +We translate `#foo` to `fromLabel @"foo"`, where we use + + * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not + * `GHC.OverloadedLabels.fromLabel`. + +In the `RebindableSyntax` case, the renamer will have filled in the +first field of `HsOverLabel` with the `fromLabel` function to use, and +we simply apply it to the appropriate visible type argument. + +In the `OverloadedLabels` case, when we see an overloaded label like +`#foo`, we generate a fresh variable `alpha` for the type and emit an +`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a +single method, it is represented by a newtype, so we can coerce +`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). + +-} + + +{- +************************************************************************ +* * + Infix operators and sections +* * +************************************************************************ + +Note [Left sections] +~~~~~~~~~~~~~~~~~~~~ +Left sections, like (4 *), are equivalent to + \ x -> (*) 4 x, +or, if PostfixOperators is enabled, just + (*) 4 +With PostfixOperators we don't actually require the function to take +two arguments at all. For example, (x `not`) means (not x); you get +postfix operators! Not Haskell 98, but it's less work and kind of +useful. + +Note [Typing rule for ($)] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +People write + runST $ blah +so much, where + runST :: (forall s. ST s a) -> a +that I have finally given in and written a special type-checking +rule just for saturated applications of ($). + * Infer the type of the first argument + * Decompose it; should be of form (arg2_ty -> res_ty), + where arg2_ty might be a polytype + * Use arg2_ty to typecheck arg2 +-} + +tcExpr expr@(OpApp fix arg1 op arg2) res_ty + | (L loc (HsVar _ (L lv op_name))) <- op + , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] + = do { traceTc "Application rule" (ppr op) + ; (arg1', arg1_ty) <- addErrCtxt (funAppCtxt op arg1 1) $ + tcInferRhoNC arg1 + + ; let doc = text "The first argument of ($) takes" + orig1 = lexprCtOrigin arg1 + ; (wrap_arg1, [arg2_sigma], op_res_ty) <- + matchActualFunTysRho doc orig1 (Just (unLoc arg1)) 1 arg1_ty + + ; mult_wrap <- tcSubMult AppOrigin Many (scaledMult arg2_sigma) + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + -- + -- When ($) becomes multiplicity-polymorphic, then the above check will + -- need to go. But in the meantime, it would produce ill-typed + -- desugared code to accept linear functions to the left of a ($). + + -- We have (arg1 $ arg2) + -- So: arg1_ty = arg2_ty -> op_res_ty + -- where arg2_sigma maybe polymorphic; that's the point + + ; arg2' <- tcArg nl_op arg2 arg2_sigma 2 + + -- Make sure that the argument type has kind '*' + -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b + -- Eg we do not want to allow (D# $ 4.0#) #5570 + -- (which gives a seg fault) + ; _ <- unifyKind (Just (XHsType $ NHsCoreTy (scaledThing arg2_sigma))) + (tcTypeKind (scaledThing arg2_sigma)) liftedTypeKind + -- Ignore the evidence. arg2_sigma must have type * or #, + -- because we know (arg2_sigma -> op_res_ty) is well-kinded + -- (because otherwise matchActualFunTysRho would fail) + -- So this 'unifyKind' will either succeed with Refl, or will + -- produce an insoluble constraint * ~ #, which we'll report later. + + -- NB: unlike the argument type, the *result* type, op_res_ty can + -- have any kind (#8739), so we don't need to check anything for that + + ; op_id <- tcLookupId op_name + ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty + , scaledThing arg2_sigma + , op_res_ty]) + (HsVar noExtField (L lv op_id))) + -- arg1' :: arg1_ty + -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) + -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty + + expr' = OpApp fix (mkLHsWrap (wrap_arg1 <.> mult_wrap) arg1') op' arg2' + + ; tcWrapResult expr expr' op_res_ty res_ty } + + | L loc (HsRecFld _ (Ambiguous _ lbl)) <- op + , Just sig_ty <- obviousSig (unLoc arg1) + -- See Note [Disambiguating record fields] + = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty + ; sel_name <- disambiguateSelector lbl sig_tc_ty + ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) + ; tcExpr (OpApp fix arg1 op' arg2) res_ty + } + + | otherwise + = do { traceTc "Non Application rule" (ppr op) + ; (op', op_ty) <- tcInferRhoNC op + + ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) + <- matchActualFunTysRho (mk_op_msg op) fn_orig + (Just (unLoc op)) 2 op_ty + -- You might think we should use tcInferApp here, but there is + -- too much impedance-matching, because tcApp may return wrappers as + -- well as type-checked arguments. + + ; arg1' <- tcArg nl_op arg1 arg1_ty 1 + ; arg2' <- tcArg nl_op arg2 arg2_ty 2 + + ; let expr' = OpApp fix arg1' (mkLHsWrap wrap_fun op') arg2' + ; tcWrapResult expr expr' op_res_ty res_ty } + where + fn_orig = exprCtOrigin nl_op + nl_op = unLoc op + +-- Right sections, equivalent to \ x -> x `op` expr, or +-- \ x -> op x expr + +tcExpr expr@(SectionR x op arg2) res_ty + = do { (op', op_ty) <- tcInferRhoNC op + ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty) + <- matchActualFunTysRho (mk_op_msg op) fn_orig + (Just (unLoc op)) 2 op_ty + ; arg2' <- tcArg (unLoc op) arg2 arg2_ty 2 + ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2' + act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty + ; tcWrapResultMono expr expr' act_res_ty res_ty } + + where + fn_orig = lexprCtOrigin op + -- It's important to use the origin of 'op', so that call-stacks + -- come out right; they are driven by the OccurrenceOf CtOrigin + -- See #13285 + +tcExpr expr@(SectionL x arg1 op) res_ty + = do { (op', op_ty) <- tcInferRhoNC op + ; dflags <- getDynFlags -- Note [Left sections] + ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 + | otherwise = 2 + + ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) + <- matchActualFunTysRho (mk_op_msg op) fn_orig + (Just (unLoc op)) n_reqd_args op_ty + ; arg1' <- tcArg (unLoc op) arg1 arg1_ty 1 + ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op') + act_res_ty = mkVisFunTys arg_tys op_res_ty + ; tcWrapResultMono expr expr' act_res_ty res_ty } + where + fn_orig = lexprCtOrigin op + -- It's important to use the origin of 'op', so that call-stacks + -- come out right; they are driven by the OccurrenceOf CtOrigin + -- See #13285 + +tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty + | all tupArgPresent tup_args + = do { let arity = length tup_args + tup_tc = tupleTyCon boxity arity + -- NB: tupleTyCon doesn't flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty + -- Unboxed tuples have RuntimeRep vars, which we + -- don't care about here + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; tup_args1 <- tcTupArgs tup_args arg_tys' + ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } + + | otherwise + = -- The tup_args are a mixture of Present and Missing (for tuple sections) + do { let arity = length tup_args + + ; arg_tys <- case boxity of + { Boxed -> newFlexiTyVarTys arity liftedTypeKind + ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } + + -- Handle tuple sections where + ; tup_args1 <- tcTupArgs tup_args arg_tys + + ; let expr' = ExplicitTuple x tup_args1 boxity + missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys] + + -- See Note [Linear fields generalization] + act_res_ty + = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys) + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + + ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) + + ; tcWrapResultMono expr expr' act_res_ty res_ty } + +tcExpr (ExplicitSum _ alt arity expr) res_ty + = do { let sum_tc = sumTyCon arity + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty + ; -- Drop levity vars, we don't care about them here + let arg_tys' = drop arity arg_tys + ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1)) + ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } + +-- This will see the empty list only when -XOverloadedLists. +-- See Note [Empty lists] in GHC.Hs.Expr. +tcExpr (ExplicitList _ witness exprs) res_ty + = case witness of + Nothing -> do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ + mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } + + Just fln -> do { ((exprs', elt_ty), fln') + <- tcSyntaxOp ListOrigin fln + [synKnownType intTy, SynList] res_ty $ + \ [elt_ty] [_int_mul, list_mul] -> + -- We ignore _int_mul because the integer (first + -- argument of fromListN) is statically known: it + -- is desugared to a literal. Therefore there is + -- no variable of which to scale the usage in that + -- first argument, and `_int_mul` is completely + -- free in this expression. + do { exprs' <- + mapM (tcScalingUsage list_mul . tc_elt elt_ty) exprs + ; return (exprs', elt_ty) } + + ; return $ ExplicitList elt_ty (Just fln') exprs' } + where tc_elt elt_ty expr = tcCheckPolyExpr expr elt_ty + +{- +************************************************************************ +* * + Let, case, if, do +* * +************************************************************************ +-} + +tcExpr (HsLet x (L l binds) expr) res_ty + = do { (binds', expr') <- tcLocalBinds binds $ + tcLExpr expr res_ty + ; return (HsLet x (L l binds') expr') } + +tcExpr (HsCase x scrut matches) res_ty + = do { -- We used to typecheck the case alternatives first. + -- The case patterns tend to give good type info to use + -- when typechecking the scrutinee. For example + -- case (map f) of + -- (x:xs) -> ... + -- will report that map is applied to too few arguments + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + let mult = Many + -- There is not yet syntax or inference mechanism for case + -- expressions to be anything else than unrestricted. + + -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma + -- would also be possible (tcMatchesCase accepts sigma-types) + -- Interesting litmus test: do these two behave the same? + -- case id of {..} + -- case (\v -> v) of {..} + -- This design choice is discussed in #17790 + ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut + + ; traceTc "HsCase" (ppr scrut_ty) + ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty + ; return (HsCase x scrut' matches') } + where + match_ctxt = MC { mc_what = CaseAlt, + mc_body = tcBody } + +tcExpr (HsIf x pred b1 b2) res_ty + = do { pred' <- tcLExpr pred (mkCheckExpType boolTy) + ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty + ; (u2,b2') <- tcCollectingUsage $ tcLExpr b2 res_ty + ; tcEmitBindingUsage (supUE u1 u2) + ; return (HsIf x pred' b1' b2') } + +tcExpr (HsMultiIf _ alts) res_ty + = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts + ; res_ty <- readExpType res_ty + ; return (HsMultiIf res_ty alts') } + where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } + +tcExpr (HsDo _ do_or_lc stmts) res_ty + = do { expr' <- tcDoStmts do_or_lc stmts res_ty + ; return expr' } + +tcExpr (HsProc x pat cmd) res_ty + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } + +-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. +-- To type check +-- (static e) :: p a +-- we want to check (e :: a), +-- and wrap (static e) in a call to +-- fromStaticPtr :: IsStatic p => StaticPtr a -> p a + +tcExpr (HsStatic fvs expr) res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty + ; (expr', lie) <- captureConstraints $ + addErrCtxt (hang (text "In the body of a static form:") + 2 (ppr expr) + ) $ + tcCheckPolyExprNC expr expr_ty + + -- Check that the free variables of the static form are closed. + -- It's OK to use nonDetEltsUniqSet here as the only side effects of + -- checkClosedInStaticForm are error messages. + ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs + + -- Require the type of the argument to be Typeable. + -- The evidence is not used, but asking the constraint ensures that + -- the current implementation is as restrictive as future versions + -- of the StaticPointers extension. + ; typeableClass <- tcLookupClass typeableClassName + ; _ <- emitWantedEvVar StaticOrigin $ + mkTyConApp (classTyCon typeableClass) + [liftedTypeKind, expr_ty] + + -- Insert the constraints of the static form in a global list for later + -- validation. + ; emitStaticConstraints lie + + -- Wrap the static form with the 'fromStaticPtr' call. + ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName + [p_ty] + ; let wrap = mkWpTyApps [expr_ty] + ; loc <- getSrcSpanM + ; return $ mkHsWrapCo co $ HsApp noExtField + (L loc $ mkHsWrap wrap fromStaticPtr) + (L loc (HsStatic fvs expr')) + } + +{- +************************************************************************ +* * + Record construction and update +* * +************************************************************************ +-} + +tcExpr expr@(RecordCon { rcon_con_name = L loc con_name + , rcon_flds = rbinds }) res_ty + = do { con_like <- tcLookupConLike con_name + + -- Check for missing fields + ; checkMissingFields con_like rbinds + + ; (con_expr, con_sigma) <- tcInferId con_name + ; (con_wrap, con_tau) <- topInstantiate orig con_sigma + -- a shallow instantiation should really be enough for + -- a data constructor. + ; let arity = conLikeArity con_like + Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau + ; case conLikeWrapId_maybe con_like of { + Nothing -> nonBidirectionalErr (conLikeName con_like) ; + Just con_id -> + + do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds + -- It is currently not possible for a record to have + -- multiplicities. When they do, `tcRecordBinds` will take + -- scaled types instead. Meanwhile, it's safe to take + -- `scaledThing` above, as we know all the multiplicities are + -- Many. + ; let rcon_tc = RecordConTc + { rcon_con_like = con_like + , rcon_con_expr = mkHsWrap con_wrap con_expr } + expr' = RecordCon { rcon_ext = rcon_tc + , rcon_con_name = L loc con_id + , rcon_flds = rbinds' } + + ; tcWrapResultMono expr expr' actual_res_ty res_ty } } } + where + orig = OccurrenceOf con_name + +{- +Note [Type of a record update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main complication with RecordUpd is that we need to explicitly +handle the *non-updated* fields. Consider: + + data T a b c = MkT1 { fa :: a, fb :: (b,c) } + | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } + | MkT3 { fd :: a } + + upd :: T a b c -> (b',c) -> T a b' c + upd t x = t { fb = x} + +The result type should be (T a b' c) +not (T a b c), because 'b' *is not* mentioned in a non-updated field +not (T a b' c'), because 'c' *is* mentioned in a non-updated field +NB that it's not good enough to look at just one constructor; we must +look at them all; cf #3219 + +After all, upd should be equivalent to: + upd t x = case t of + MkT1 p q -> MkT1 p x + MkT2 a b -> MkT2 p b + MkT3 d -> error ... + +So we need to give a completely fresh type to the result record, +and then constrain it by the fields that are *not* updated ("p" above). +We call these the "fixed" type variables, and compute them in getFixedTyVars. + +Note that because MkT3 doesn't contain all the fields being updated, +its RHS is simply an error, so it doesn't impose any type constraints. +Hence the use of 'relevant_cont'. + +Note [Implicit type sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We also take into account any "implicit" non-update fields. For example + data T a b where { MkT { f::a } :: T a a; ... } +So the "real" type of MkT is: forall ab. (a~b) => a -> T a b + +Then consider + upd t x = t { f=x } +We infer the type + upd :: T a b -> a -> T a b + upd (t::T a b) (x::a) + = case t of { MkT (co:a~b) (_:a) -> MkT co x } +We can't give it the more general type + upd :: T a b -> c -> T c b + +Note [Criteria for update] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to allow update for existentials etc, provided the updated +field isn't part of the existential. For example, this should be ok. + data T a where { MkT { f1::a, f2::b->b } :: T a } + f :: T a -> b -> T b + f t b = t { f1=b } + +The criterion we use is this: + + The types of the updated fields + mention only the universally-quantified type variables + of the data constructor + +NB: this is not (quite) the same as being a "naughty" record selector +(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least +in the case of GADTs. Consider + data T a where { MkT :: { f :: a } :: T [a] } +Then f is not "naughty" because it has a well-typed record selector. +But we don't allow updates for 'f'. (One could consider trying to +allow this, but it makes my head hurt. Badly. And no one has asked +for it.) + +In principle one could go further, and allow + g :: T a -> T a + g t = t { f2 = \x -> x } +because the expression is polymorphic...but that seems a bridge too far. + +Note [Data family example] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + data instance T (a,b) = MkT { x::a, y::b } + ---> + data :TP a b = MkT { a::a, y::b } + coTP a b :: T (a,b) ~ :TP a b + +Suppose r :: T (t1,t2), e :: t3 +Then r { x=e } :: T (t3,t1) + ---> + case r |> co1 of + MkT x y -> MkT e y |> co2 + where co1 :: T (t1,t2) ~ :TP t1 t2 + co2 :: :TP t3 t2 ~ T (t3,t2) +The wrapping with co2 is done by the constructor wrapper for MkT + +Outgoing invariants +~~~~~~~~~~~~~~~~~~~ +In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): + + * cons are the data constructors to be updated + + * in_inst_tys, out_inst_tys have same length, and instantiate the + *representation* tycon of the data cons. In Note [Data + family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] + +Note [Mixed Record Field Updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym. + + data MyRec = MyRec { foo :: Int, qux :: String } + + pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} + +This allows updates such as the following + + updater :: MyRec -> MyRec + updater a = a {f1 = 1 } + +It would also make sense to allow the following update (which we reject). + + updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" + +This leads to confusing behaviour when the selectors in fact refer the same +field. + + updater a = a {f1 = 1, foo = 2} ==? ??? + +For this reason, we reject a mixture of pattern synonym and normal record +selectors in the same update block. Although of course we still allow the +following. + + updater a = (a {f1 = 1}) {foo = 2} + + > updater (MyRec 0 "str") + MyRec 2 "str" + +-} + +tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty + = ASSERT( notNull rbnds ) + do { -- STEP -2: typecheck the record_expr, the record to be updated + (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr + -- Record update drops some of the content of the record (namely the + -- content of the field being updated). As a consequence, unless the + -- field being updated is unrestricted in the record, or we need an + -- unrestricted record. Currently, we simply always require an + -- unrestricted record. + -- + -- Consider the following example: + -- + -- data R a = R { self :: a } + -- bad :: a ⊸ () + -- bad x = let r = R x in case r { self = () } of { R x' -> x' } + -- + -- This should definitely *not* typecheck. + + -- STEP -1 See Note [Disambiguating record fields] + -- After this we know that rbinds is unambiguous + ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty + ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds + upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds + sel_ids = map selectorAmbiguousFieldOcc upd_flds + -- STEP 0 + -- Check that the field names are really field names + -- and they are all field names for proper records or + -- all field names for pattern synonyms. + ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) + | fld <- rbinds, + -- Excludes class ops + let L loc sel_id = hsRecUpdFieldId (unLoc fld), + not (isRecordSelector sel_id), + let fld_name = idName sel_id ] + ; unless (null bad_guys) (sequence bad_guys >> failM) + -- See note [Mixed Record Selectors] + ; let (data_sels, pat_syn_sels) = + partition isDataConRecordSelector sel_ids + ; MASSERT( all isPatSynRecordSelector pat_syn_sels ) + ; checkTc ( null data_sels || null pat_syn_sels ) + ( mixedSelectors data_sels pat_syn_sels ) + + -- STEP 1 + -- Figure out the tycon and data cons from the first field name + ; let -- It's OK to use the non-tc splitters here (for a selector) + sel_id : _ = sel_ids + + mtycon :: Maybe TyCon + mtycon = case idDetails sel_id of + RecSelId (RecSelData tycon) _ -> Just tycon + _ -> Nothing + + con_likes :: [ConLike] + con_likes = case idDetails sel_id of + RecSelId (RecSelData tc) _ + -> map RealDataCon (tyConDataCons tc) + RecSelId (RecSelPatSyn ps) _ + -> [PatSynCon ps] + _ -> panic "tcRecordUpd" + -- NB: for a data type family, the tycon is the instance tycon + + relevant_cons = conLikesWithFields con_likes upd_fld_occs + -- A constructor is only relevant to this process if + -- it contains *all* the fields that are being updated + -- Other ones will cause a runtime error if they occur + + -- Step 2 + -- Check that at least one constructor has all the named fields + -- i.e. has an empty set of bad fields returned by badFields + ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) + + -- Take apart a representative constructor + ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons + (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _) + = conLikeFullSig con1 + con1_arg_tys = map scaledThing scaled_con1_arg_tys + -- We can safely drop the fields' multiplicities because + -- they are currently always 1: there is no syntax for record + -- fields with other multiplicities yet. This way we don't need + -- to handle it in the rest of the function + con1_flds = map flLabel $ conLikeFieldLabels con1 + con1_tv_tys = mkTyVarTys con1_tvs + con1_res_ty = case mtycon of + Just tc -> mkFamilyTyConApp tc con1_tv_tys + Nothing -> conLikeResTy con1 con1_tv_tys + + -- Check that we're not dealing with a unidirectional pattern + -- synonym + ; unless (isJust $ conLikeWrapId_maybe con1) + (nonBidirectionalErr (conLikeName con1)) + + -- STEP 3 Note [Criteria for update] + -- Check that each updated field is polymorphic; that is, its type + -- mentions only the universally-quantified variables of the data con + ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys + bad_upd_flds = filter bad_fld flds1_w_tys + con1_tv_set = mkVarSet con1_tvs + bad_fld (fld, ty) = fld `elem` upd_fld_occs && + not (tyCoVarsOfType ty `subVarSet` con1_tv_set) + ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) + + -- STEP 4 Note [Type of a record update] + -- Figure out types for the scrutinee and result + -- Both are of form (T a b c), with fresh type variables, but with + -- common variables where the scrutinee and result must have the same type + -- These are variables that appear in *any* arg of *any* of the + -- relevant constructors *except* in the updated fields + -- + ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons + is_fixed_tv tv = tv `elemVarSet` fixed_tvs + + mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) + -- Deals with instantiation of kind variables + -- c.f. GHC.Tc.Utils.TcMType.newMetaTyVars + mk_inst_ty subst (tv, result_inst_ty) + | is_fixed_tv tv -- Same as result type + = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) + | otherwise -- Fresh type, of correct kind + = do { (subst', new_tv) <- newMetaTyVarX subst tv + ; return (subst', mkTyVarTy new_tv) } + + ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs + ; let result_inst_tys = mkTyVarTys con1_tvs' + init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) + + ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst + (con1_tvs `zip` result_inst_tys) + + ; let rec_res_ty = TcType.substTy result_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty + con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys + + ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty + -- NB: normal unification is OK here (as opposed to subsumption), + -- because for this to work out, both record_rho and scrut_ty have + -- to be normal datatypes -- no contravariant stuff can go on + + -- STEP 5 + -- Typecheck the bindings + ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds + + -- STEP 6: Deal with the stupid theta + ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) + ; instStupidTheta RecordUpdOrigin theta' + + -- Step 7: make a cast for the scrutinee, in the + -- case that it's from a data family + ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty + fam_co | Just tycon <- mtycon + , Just co_con <- tyConFamilyCoercion_maybe tycon + = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) + | otherwise + = idHsWrapper + + -- Step 8: Check that the req constraints are satisfied + -- For normal data constructors req_theta is empty but we must do + -- this check for pattern synonyms. + ; let req_theta' = substThetaUnchecked scrut_subst req_theta + ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' + + -- Phew! + ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons + , rupd_in_tys = scrut_inst_tys + , rupd_out_tys = result_inst_tys + , rupd_wrap = req_wrap } + expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $ + mkLHsWrapCo co_scrut record_expr' + , rupd_flds = rbinds' + , rupd_ext = upd_tc } + + ; tcWrapResult expr expr' rec_res_ty res_ty } + +tcExpr e@(HsRecFld _ f) res_ty + = tcCheckRecSelId e f res_ty + +{- +************************************************************************ +* * + Arithmetic sequences e.g. [a,b..] + and their parallel-array counterparts e.g. [: a,b.. :] + +* * +************************************************************************ +-} + +tcExpr (ArithSeq _ witness seq) res_ty + = tcArithSeq witness seq res_ty + +{- +************************************************************************ +* * + Template Haskell +* * +************************************************************************ +-} + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'. +-- Here we get rid of it and add the finalizers to the global environment. +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. +tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) + res_ty + = do addModFinalizersWithLclEnv mod_finalizers + tcExpr expr res_ty +tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty +tcExpr e@(HsBracket _ brack) res_ty = tcTypedBracket e brack res_ty +tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty + +{- +************************************************************************ +* * + Rebindable syntax +* * +************************************************************************ +-} + +-- See Note [Rebindable syntax and HsExpansion]. +tcExpr (XExpr (HsExpanded a b)) t + = fmap (XExpr . ExpansionExpr . HsExpanded a) $ + setSrcSpan generatedSrcSpan (tcExpr b t) + +{- +************************************************************************ +* * + Catch-all +* * +************************************************************************ +-} + +tcExpr other _ = pprPanic "tcLExpr" (ppr other) + -- Include ArrForm, ArrApp, which shouldn't appear at all + -- Also HsTcBracketOut, HsQuasiQuoteE + + +{- ********************************************************************* +* * + Pragmas on expressions +* * +********************************************************************* -} + +tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc +tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann +tcExprPrag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + + +{- ********************************************************************* +* * + Expression with type signature e::ty +* * +********************************************************************* -} + +tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) + -> TcM (HsExpr GhcTc, TcSigmaType) +tcExprWithSig expr hs_ty + = do { sig_info <- checkNoErrs $ -- Avoid error cascade + tcUserTypeSig loc hs_ty Nothing + ; (expr', poly_ty) <- tcExprSig expr sig_info + ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } + where + loc = getLoc (hsSigWcType hs_ty) + +{- +************************************************************************ +* * + Arithmetic sequences [a..b] etc +* * +************************************************************************ +-} + +tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType + -> TcM (HsExpr GhcTc) + +tcArithSeq witness seq@(From expr) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from wit' (From expr') } + +tcArithSeq witness seq@(FromThen expr1 expr2) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_then wit' (FromThen expr1' expr2') } + +tcArithSeq witness seq@(FromTo expr1 expr2) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_to wit' (FromTo expr1' expr2') } + +tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } + +----------------- +arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType + -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc)) +arithSeqEltType Nothing res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (mkWpCastN coi, One, elt_ty, Nothing) } +arithSeqEltType (Just fl) res_ty + = do { ((elt_mult, elt_ty), fl') + <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ + \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty) + ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } + +{- +************************************************************************ +* * + Applications +* * +************************************************************************ +-} + +{- Note [Typechecking applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We typecheck application chains (f e1 @ty e2) specially: + +* So we can report errors like "in the third arument of a call of f" + +* So we can do Visible Type Application (VTA), for which we must not + eagerly instantiate the function part of the application. + +* So that we can do Quick Look impredicativity. + +The idea is: + +* Use collectHsArgs, which peels off + HsApp, HsTypeApp, HsPrag, HsPar + returning the function in the corner and the arguments + +* Use tcInferAppHead to infer the type of the fuction, + as an (uninstantiated) TcSigmaType + There are special cases for + HsVar, HsREcFld, and ExprWithTySig + Otherwise, delegate back to tcExpr, which + infers an (instantiated) TcRhoType + +Some cases that /won't/ work: + +1. Consider this (which uses visible type application): + + (let { f :: forall a. a -> a; f x = x } in f) @Int + + Since 'let' is not among the special cases for tcInferAppHead, + we'll delegate back to tcExpr, which will instantiate f's type + and the type application to @Int will fail. Too bad! + +-} + +-- HsExprArg is a very local type, used only within this module. +-- It's really a zipper for an application chain +-- It's a GHC-specific type, so using TTG only where necessary +data HsExprArg id + = HsEValArg SrcSpan -- Of the function + (LHsExpr (GhcPass id)) + | HsETypeArg SrcSpan -- Of the function + (LHsWcType (NoGhcTc (GhcPass id))) + !(XExprTypeArg id) + | HsEPrag SrcSpan + (HsPragE (GhcPass id)) + | HsEPar SrcSpan -- Of the nested expr + | HsEWrap !(XArgWrap id) -- Wrapper, after typechecking only + +-- The outer location is the location of the application itself +type LHsExprArgIn = HsExprArg 'Renamed +type LHsExprArgOut = HsExprArg 'Typechecked + +instance OutputableBndrId id => Outputable (HsExprArg id) where + ppr (HsEValArg _ tm) = ppr tm + ppr (HsEPrag _ p) = text "HsPrag" <+> ppr p + ppr (HsETypeArg _ hs_ty _) = char '@' <> ppr hs_ty + ppr (HsEPar _) = text "HsEPar" + ppr (HsEWrap w) = case ghcPass @id of + GhcTc -> text "HsEWrap" <+> ppr w + _ -> empty + +type family XExprTypeArg id where + XExprTypeArg 'Parsed = NoExtField + XExprTypeArg 'Renamed = NoExtField + XExprTypeArg 'Typechecked = Type + +type family XArgWrap id where + XArgWrap 'Parsed = NoExtCon + XArgWrap 'Renamed = NoExtCon + XArgWrap 'Typechecked = HsWrapper + +addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut] +addArgWrap wrap args + | isIdHsWrapper wrap = args + | otherwise = HsEWrap wrap : args + +collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn]) +collectHsArgs e = go e [] + where + go (HsPar _ (L l fun)) args = go fun (HsEPar l : args) + go (HsPragE _ p (L l fun)) args = go fun (HsEPrag l p : args) + go (HsApp _ (L l fun) arg) args = go fun (HsEValArg l arg : args) + go (HsAppType _ (L l fun) hs_ty) args = go fun (HsETypeArg l hs_ty noExtField : args) + go e args = (e,args) + +applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut]-> HsExpr GhcTc +applyHsArgs fun args + = go fun args + where + go fun [] = fun + go fun (HsEWrap wrap : args) = go (mkHsWrap wrap fun) args + go fun (HsEValArg l arg : args) = go (HsApp noExtField (L l fun) arg) args + go fun (HsETypeArg l hs_ty ty : args) = go (HsAppType ty (L l fun) hs_ty) args + go fun (HsEPar l : args) = go (HsPar noExtField (L l fun)) args + go fun (HsEPrag l p : args) = go (HsPragE noExtField p (L l fun)) args + +isHsValArg :: HsExprArg id -> Bool +isHsValArg (HsEValArg {}) = True +isHsValArg _ = False + +isArgPar :: HsExprArg id -> Bool +isArgPar (HsEPar {}) = True +isArgPar _ = False + +getFunLoc :: [HsExprArg 'Renamed] -> Maybe SrcSpan +getFunLoc [] = Nothing +getFunLoc (a:_) = Just $ case a of + HsEValArg l _ -> l + HsETypeArg l _ _ -> l + HsEPrag l _ -> l + HsEPar l -> l + +--------------------------- +tcApp :: HsExpr GhcRn -- either HsApp or HsAppType + -> ExpRhoType -> TcM (HsExpr GhcTc) +-- See Note [Typechecking applications] +tcApp expr res_ty + = do { (fun, args, app_res_ty) <- tcInferApp expr + ; if isTagToEnum fun + then tcTagToEnum expr fun args app_res_ty res_ty + -- Done here because we have res_ty, + -- whereas tcInferApp does not + else + + -- The wildly common case + do { let expr' = applyHsArgs fun args + ; addFunResCtxt True fun app_res_ty res_ty $ + tcWrapResult expr expr' app_res_ty res_ty } } + +--------------------------- +tcInferApp :: HsExpr GhcRn + -> TcM ( HsExpr GhcTc -- Function + , [LHsExprArgOut] -- Arguments + , TcSigmaType) -- Inferred type: a sigma-type! +-- Also used by Module.tcRnExpr to implement GHCi :type +tcInferApp expr + | -- Gruesome special case for ambiguous record selectors + HsRecFld _ fld_lbl <- fun + , Ambiguous _ lbl <- fld_lbl -- Still ambiguous + , HsEValArg _ (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first + , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates + = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty + ; sel_name <- disambiguateSelector lbl sig_tc_ty + ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) + ; tcInferApp_finish fun tc_fun fun_ty args } + + | otherwise -- The wildly common case + = do { (tc_fun, fun_ty) <- set_fun_loc (tcInferAppHead fun) + ; tcInferApp_finish fun tc_fun fun_ty args } + where + (fun, args) = collectHsArgs expr + set_fun_loc thing_inside + = case getFunLoc args of + Nothing -> thing_inside -- Don't set the location twice + Just loc -> setSrcSpan loc thing_inside + +tcInferApp_finish + :: HsExpr GhcRn -- Renamed function + -> HsExpr GhcTc -> TcSigmaType -- Function and its type + -> [LHsExprArgIn] -- Arguments + -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType) +tcInferApp_finish rn_fun tc_fun fun_sigma rn_args + = do { (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args + ; return (tc_fun, tc_args, actual_res_ty) } + +mk_op_msg :: LHsExpr GhcRn -> SDoc +mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" + +---------------- +tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +-- Infer type of the head of an application, returning a /SigmaType/ +-- i.e. the 'f' in (f e1 ... en) +-- We get back a SigmaType because we have special cases for +-- * A bare identifier (just look it up) +-- This case also covers a record selectro HsRecFld +-- * An expression with a type signature (e :: ty) +-- +-- Note that [] and (,,) are both HsVar: +-- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr +-- +-- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those +-- cases are dealt with by collectHsArgs. +-- +-- See Note [Typechecking applications] +tcInferAppHead e + = case e of + HsVar _ (L _ nm) -> tcInferId nm + HsRecFld _ f -> tcInferRecSelId f + ExprWithTySig _ e hs_ty -> add_ctxt $ tcExprWithSig e hs_ty + _ -> add_ctxt $ tcInfer (tcExpr e) + where + add_ctxt thing = addErrCtxt (exprCtxt e) thing + +---------------- +-- | Type-check the arguments to a function, possibly including visible type +-- applications +tcArgs :: HsExpr GhcRn -- ^ The function itself (for err msgs only) + -> TcSigmaType -- ^ the (uninstantiated) type of the function + -> [LHsExprArgIn] -- ^ the args + -> TcM ([LHsExprArgOut], TcSigmaType) + -- ^ (a wrapper for the function, the tc'd args, result type) +tcArgs fun orig_fun_ty orig_args + = go 1 [] orig_fun_ty orig_args + where + fun_orig = exprCtOrigin fun + herald = sep [ text "The function" <+> quotes (ppr fun) + , text "is applied to"] + + -- Count value args only when complaining about a function + -- applied to too many value args + -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. + n_val_args = count isHsValArg orig_args + + fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] + = case fun of + HsUnboundVar {} -> True + _ -> False + + go :: Int -- Which argment number this is (incl type args) + -> [Scaled TcSigmaType] -- Value args to which applied so far + -> TcSigmaType + -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcSigmaType) + go _ _ fun_ty [] = traceTc "tcArgs:ret" (ppr fun_ty) >> return ([], fun_ty) + + go n so_far fun_ty (HsEPar sp : args) + = do { (args', res_ty) <- go n so_far fun_ty args + ; return (HsEPar sp : args', res_ty) } + + go n so_far fun_ty (HsEPrag sp prag : args) + = do { (args', res_ty) <- go n so_far fun_ty args + ; return (HsEPrag sp (tcExprPrag prag) : args', res_ty) } + + go n so_far fun_ty (HsETypeArg loc hs_ty_arg _ : args) + | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] + = go (n+1) so_far fun_ty args + + | otherwise + = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty + -- wrap1 :: fun_ty "->" upsilon_ty + ; case tcSplitForAllTy_maybe upsilon_ty of + Just (tvb, inner_ty) + | binderArgFlag tvb == Specified -> + -- It really can't be Inferred, because we've justn + -- instantiated those. But, oddly, it might just be Required. + -- See Note [Required quantifiers in the type of a term] + do { let tv = binderVar tvb + kind = tyVarKind tv + ; ty_arg <- tcHsTypeApp hs_ty_arg kind + + ; inner_ty <- zonkTcType inner_ty + -- See Note [Visible type application zonk] + ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) + insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty + -- NB: tv and ty_arg have the same kind, so this + -- substitution is kind-respecting + ; traceTc "VTA" (vcat [ppr tv, debugPprType kind + , debugPprType ty_arg + , debugPprType (tcTypeKind ty_arg) + , debugPprType inner_ty + , debugPprType insted_ty ]) + + ; (args', res_ty) <- go (n+1) so_far insted_ty args + ; return ( addArgWrap wrap1 $ HsETypeArg loc hs_ty_arg ty_arg : args' + , res_ty ) } + _ -> ty_app_err upsilon_ty hs_ty_arg } + + go n so_far fun_ty (HsEValArg loc arg : args) + = do { (wrap, arg_ty, res_ty) + <- matchActualFunTySigma herald fun_orig (Just fun) + (n_val_args, so_far) fun_ty + ; arg' <- tcArg fun arg arg_ty n + ; (args', inner_res_ty) <- go (n+1) (arg_ty:so_far) res_ty args + ; return ( addArgWrap wrap $ HsEValArg loc arg' : args' + , inner_res_ty ) } + + ty_app_err ty arg + = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty + ; failWith $ + text "Cannot apply expression of type" <+> quotes (ppr ty) $$ + text "to a visible type argument" <+> quotes (ppr arg) } + +{- Note [Required quantifiers in the type of a term] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#15859) + + data A k :: k -> Type -- A :: forall k -> k -> Type + type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type + a = (undefind :: KindOf A) @Int + +With ImpredicativeTypes (thin ice, I know), we instantiate +KindOf at type (forall k -> k -> Type), so + KindOf A = forall k -> k -> Type +whose first argument is Required + +We want to reject this type application to Int, but in earlier +GHCs we had an ASSERT that Required could not occur here. + +The ice is thin; c.f. Note [No Required TyCoBinder in terms] +in GHC.Core.TyCo.Rep. + +Note [VTA for out-of-scope functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose 'wurble' is not in scope, and we have + (wurble @Int @Bool True 'x') + +Then the renamer will make (HsUnboundVar "wurble) for 'wurble', +and the typechecker will typecheck it with tcUnboundId, giving it +a type 'alpha', and emitting a deferred Hole, to be reported later. + +But then comes the visible type application. If we do nothing, we'll +generate an immediate failure (in tc_app_err), saying that a function +of type 'alpha' can't be applied to Bool. That's insane! And indeed +users complain bitterly (#13834, #17150.) + +The right error is the Hole, which has /already/ been emitted by +tcUnboundId. It later reports 'wurble' as out of scope, and tries to +give its type. + +Fortunately in tcArgs we still have access to the function, so we can +check if it is a HsUnboundVar. We use this info to simply skip over +any visible type arguments. We've already inferred the type of the +function, so we'll /already/ have emitted a Hole; +failing preserves that constraint. + +We do /not/ want to fail altogether in this case (via failM) becuase +that may abandon an entire instance decl, which (in the presence of +-fdefer-type-errors) leads to leading to #17792. + +Downside; the typechecked term has lost its visible type arguments; we +don't even kind-check them. But let's jump that bridge if we come to +it. Meanwhile, let's not crash! + +Note [Visible type application zonk] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). + +* tcHsTypeApp only guarantees that + - ty_arg is zonked + - kind(zonk(tv)) = kind(ty_arg) + (checkExpectedKind zonks as it goes). + +So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) +and inner_ty. Otherwise we can build an ill-kinded type. An example was +#14158, where we had: + id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a +and we had the visible type application + id @(->) + +* We instantiated k := kappa, yielding + forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a +* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). +* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, + Here q1 :: RuntimeRep +* Now we substitute + cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * + but we must first zonk the inner_ty to get + forall (a :: TYPE q1). cat a a + so that the result of substitution is well-kinded + Failing to do so led to #14158. +-} + +---------------- +tcArg :: HsExpr GhcRn -- The function (for error messages) + -> LHsExpr GhcRn -- Actual arguments + -> Scaled TcSigmaType -- expected arg type + -> Int -- # of argument + -> TcM (LHsExpr GhcTc) -- Resulting argument +tcArg fun arg (Scaled mult ty) arg_no + = addErrCtxt (funAppCtxt fun arg arg_no) $ + do { traceTc "tcArg" $ + vcat [ ppr arg_no <+> text "of" <+> ppr fun + , text "arg type:" <+> ppr ty + , text "arg:" <+> ppr arg ] + ; tcScalingUsage mult $ tcCheckPolyExprNC arg ty } + +---------------- +tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc] +tcTupArgs args tys + = ASSERT( equalLength args tys ) mapM go (args `zip` tys) + where + go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy + ; return (L l (Missing (Scaled mult arg_ty))) } + go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty + ; return (L l (Present x expr')) } + +--------------------------- +-- See TcType.SyntaxOpType also for commentary +tcSyntaxOp :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpRhoType -- ^ overall result type + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments, + -- takes a type per hole and a + -- multiplicity per arrow in + -- the shape. + -> TcM (a, SyntaxExprTc) +-- ^ Typecheck a syntax operator +-- The operator is a variable or a lambda at this stage (i.e. renamer +-- output) +tcSyntaxOp orig expr arg_tys res_ty + = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) + +-- | Slightly more general version of 'tcSyntaxOp' that allows the caller +-- to specify the shape of the result of the syntax operator +tcSyntaxOpGen :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaType] -> [Mult] -> TcM a) + -> TcM (a, SyntaxExprTc) +tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside + = do { (expr, sigma) <- tcInferAppHead op + ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) + ; (result, expr_wrap, arg_wraps, res_wrap) + <- tcSynArgA orig sigma arg_tys res_ty $ + thing_inside + ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) + ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) } +tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" + +{- +Note [tcSynArg] +~~~~~~~~~~~~~~~ +Because of the rich structure of SyntaxOpType, we must do the +contra-/covariant thing when working down arrows, to get the +instantiation vs. skolemisation decisions correct (and, more +obviously, the orientation of the HsWrappers). We thus have +two tcSynArgs. +-} + +-- works on "expected" types, skolemising where necessary +-- See Note [tcSynArg] +tcSynArgE :: CtOrigin + -> TcSigmaType + -> SyntaxOpType -- ^ shape it is expected to have + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper) + -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) +tcSynArgE orig sigma_ty syn_ty thing_inside + = do { (skol_wrap, (result, ty_wrapper)) + <- tcSkolemise GenSigCtxt sigma_ty $ \ rho_ty -> + go rho_ty syn_ty + ; return (result, skol_wrap <.> ty_wrapper) } + where + go rho_ty SynAny + = do { result <- thing_inside [rho_ty] [] + ; return (result, idHsWrapper) } + + go rho_ty SynRho -- same as SynAny, because we skolemise eagerly + = do { result <- thing_inside [rho_ty] [] + ; return (result, idHsWrapper) } + + go rho_ty SynList + = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty + ; result <- thing_inside [elt_ty] [] + ; return (result, mkWpCastN list_co) } + + go rho_ty (SynFun arg_shape res_shape) + = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty + , ( ( (result, arg_ty, res_ty, op_mult) + , res_wrapper ) -- :: res_ty_out "->" res_ty + , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out + <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ + \ [arg_ty] res_ty -> + do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) + ; res_tc_ty <- expTypeToType res_ty + + -- another nested arrow is too much for now, + -- but I bet we'll never need this + ; MASSERT2( case arg_shape of + SynFun {} -> False; + _ -> True + , text "Too many nested arrows in SyntaxOpType" $$ + pprCtOrigin orig ) + + ; let arg_mult = scaledMult arg_ty + ; tcSynArgA orig arg_tc_ty [] arg_shape $ + \ arg_results arg_res_mults -> + tcSynArgE orig res_tc_ty res_shape $ + \ res_results res_res_mults -> + do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) + ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} + + ; return ( result + , match_wrapper <.> + mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper + (Scaled op_mult arg_ty) res_ty doc ) } + where + herald = text "This rebindable syntax expects a function with" + doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig + + go rho_ty (SynType the_ty) + = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty + ; result <- thing_inside [] [] + ; return (result, wrap) } + +-- works on "actual" types, instantiating where necessary +-- See Note [tcSynArg] +tcSynArgA :: CtOrigin + -> TcSigmaType + -> [SyntaxOpType] -- ^ argument shapes + -> SyntaxOpType -- ^ result shape + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) + -- ^ returns a wrapper to be applied to the original function, + -- wrappers to be applied to arguments + -- and a wrapper to be applied to the overall expression +tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside + = do { (match_wrapper, arg_tys, res_ty) + <- matchActualFunTysRho herald orig Nothing + (length arg_shapes) sigma_ty + -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) + ; ((result, res_wrapper), arg_wrappers) + <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults -> + tc_syn_arg res_ty res_shape $ \ res_results -> + thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) + ; return (result, match_wrapper, arg_wrappers, res_wrapper) } + where + herald = text "This rebindable syntax expects a function with" + + tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] + -> ([TcSigmaType] -> [Mult] -> TcM a) + -> TcM (a, [HsWrapper]) + -- the wrappers are for arguments + tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside + = do { ((result, arg_wraps), arg_wrap) + <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results arg1_mults -> + tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> + thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) + ; return (result, arg_wrap : arg_wraps) } + tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] + + tc_syn_arg :: TcSigmaType -> SyntaxOpType + -> ([TcSigmaType] -> TcM a) + -> TcM (a, HsWrapper) + -- the wrapper applies to the overall result + tc_syn_arg res_ty SynAny thing_inside + = do { result <- thing_inside [res_ty] + ; return (result, idHsWrapper) } + tc_syn_arg res_ty SynRho thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; result <- thing_inside [rho_ty] + ; return (result, inst_wrap) } + tc_syn_arg res_ty SynList thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; (list_co, elt_ty) <- matchExpectedListTy rho_ty + -- list_co :: [elt_ty] ~N rho_ty + ; result <- thing_inside [elt_ty] + ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } + tc_syn_arg _ (SynFun {}) _ + = pprPanic "tcSynArgA hits a SynFun" (ppr orig) + tc_syn_arg res_ty (SynType the_ty) thing_inside + = do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty + ; result <- thing_inside [] + ; return (result, wrap) } + +{- +Note [Push result type in] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unify with expected result before type-checking the args so that the +info from res_ty percolates to args. This is when we might detect a +too-few args situation. (One can think of cases when the opposite +order would give a better error message.) +experimenting with putting this first. + +Here's an example where it actually makes a real difference + + class C t a b | t a -> b + instance C Char a Bool + + data P t a = forall b. (C t a b) => MkP b + data Q t = MkQ (forall a. P t a) + + f1, f2 :: Q Char; + f1 = MkQ (MkP True) + f2 = MkQ (MkP True :: forall a. P Char a) + +With the change, f1 will type-check, because the 'Char' info from +the signature is propagated into MkQ's argument. With the check +in the other order, the extra signature in f2 is reqd. + +************************************************************************ +* * + Expressions with a type signature + expr :: type +* * +********************************************************************* -} + +tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) +tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) + = setSrcSpan loc $ -- Sets the location for the implication constraint + do { let poly_ty = idType poly_id + ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty -> + tcCheckMonoExprNC expr rho_ty + ; return (mkLHsWrap wrap expr', poly_ty) } + +tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) + = setSrcSpan loc $ -- Sets the location for the implication constraint + do { (tclvl, wanted, (expr', sig_inst)) + <- pushLevelAndCaptureConstraints $ + do { sig_inst <- tcInstSig sig + ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ + tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ + tcCheckPolyExprNC expr (sig_inst_tau sig_inst) + ; return (expr', sig_inst) } + -- See Note [Partial expression signatures] + ; let tau = sig_inst_tau sig_inst + infer_mode | null (sig_inst_theta sig_inst) + , isNothing (sig_inst_wcx sig_inst) + = ApplyMR + | otherwise + = NoRestrictions + ; (qtvs, givens, ev_binds, residual, _) + <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted + ; emitConstraints residual + + ; tau <- zonkTcType tau + ; let inferred_theta = map evVarPred givens + tau_tvs = tyCoVarsOfType tau + ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta + tau_tvs qtvs (Just sig_inst) + ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau + my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) + ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguous type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma + + ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) + ; let poly_wrap = wrap + <.> mkWpTyLams qtvs + <.> mkWpLams givens + <.> mkWpLet ev_binds + ; return (mkLHsWrap poly_wrap expr', my_sigma) } + + +{- Note [Partial expression signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Partial type signatures on expressions are easy to get wrong. But +here is a guiding principile + e :: ty +should behave like + let x :: ty + x = e + in x + +So for partial signatures we apply the MR if no context is given. So + e :: IO _ apply the MR + e :: _ => IO _ do not apply the MR +just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan + +This makes a difference (#11670): + peek :: Ptr a -> IO CLong + peek ptr = peekElemOff undefined 0 :: _ +from (peekElemOff undefined 0) we get + type: IO w + constraints: Storable w + +We must NOT try to generalise over 'w' because the signature specifies +no constraints so we'll complain about not being able to solve +Storable w. Instead, don't generalise; then _ gets instantiated to +CLong, as it should. +-} + +{- ********************************************************************* +* * + tcInferId +* * +********************************************************************* -} + +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) +tcCheckId name res_ty + | name `hasKey` tagToEnumKey + = failWithTc (text "tagToEnum# must appear applied to one argument") + -- tcApp catches the case (tagToEnum# arg) + + | otherwise + = do { (expr, actual_res_ty) <- tcInferId name + ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) + ; addFunResCtxt False expr actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr + actual_res_ty res_ty } + +tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcCheckRecSelId rn_expr f@(Unambiguous {}) res_ty + = do { (expr, actual_res_ty) <- tcInferRecSelId f + ; tcWrapResult rn_expr expr actual_res_ty res_ty } +tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty + = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of + Nothing -> ambiguousSelector lbl + Just (arg, _) -> do { sel_name <- disambiguateSelector lbl (scaledThing arg) + ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) + res_ty } + +------------------------ +tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType) +tcInferRecSelId (Unambiguous sel (L _ lbl)) + = do { (expr', ty) <- tc_infer_id lbl sel + ; return (expr', ty) } +tcInferRecSelId (Ambiguous _ lbl) + = ambiguousSelector lbl + +------------------------ +tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType) +-- Look up an occurrence of an Id +-- Do not instantiate its type +tcInferId id_name + | id_name `hasKey` assertIdKey + = do { dflags <- getDynFlags + ; if gopt Opt_IgnoreAsserts dflags + then tc_infer_id (nameRdrName id_name) id_name + else tc_infer_assert id_name } + + | otherwise + = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name + ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) + ; return (expr, ty) } + +tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType) +-- Deal with an occurrence of 'assert' +-- See Note [Adding the implicit parameter to 'assert'] +tc_infer_assert assert_name + = do { assert_error_id <- tcLookupId assertErrorName + ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) + (idType assert_error_id) + ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) + } + +tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType) +tc_infer_id lbl id_name + = do { thing <- tcLookup id_name + ; case thing of + ATcId { tct_id = id } + -> do { check_naughty id -- Note [Local record selectors] + ; checkThLocalId id + ; tcEmitBindingUsage $ unitUE id_name One + ; return_id id } + + AGlobal (AnId id) + -> do { check_naughty id + ; return_id id } + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- hence no checkTh stuff here + + AGlobal (AConLike cl) -> case cl of + RealDataCon con -> return_data_con con + PatSynCon ps -> tcPatSynBuilderOcc ps + + _ -> failWithTc $ + ppr thing <+> text "used where a value identifier was expected" } + where + return_id id = return (HsVar noExtField (noLoc id), idType id) + + return_data_con con + = do { let tvs = dataConUserTyVarBinders con + theta = dataConOtherTheta con + args = dataConOrigArgTys con + res = dataConOrigResTy con + + -- See Note [Linear fields generalization] + ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy + ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args' + combine var (Scaled One ty) = Scaled var ty + combine _ scaled_ty = scaled_ty + -- The combine function implements the fact that, as + -- described in Note [Linear fields generalization], if a + -- field is not linear (last line) it isn't made polymorphic. + + etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys + + -- See Note [Instantiating stupid theta] + ; let shouldInstantiate = (not (null (dataConStupidTheta con)) || + isKindLevPoly (tyConResKind (dataConTyCon con))) + ; case shouldInstantiate of + True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs) + ; let tys' = mkTyVarTys tvs' + theta' = substTheta subst theta + args' = substScaledTys subst args + res' = substTy subst res + ; wrap <- instCall (OccurrenceOf id_name) tys' theta' + ; let scaled_arg_tys = scaleArgs args' + eta_wrap = etaWrapper scaled_arg_tys + ; addDataConStupidTheta con tys' + ; return ( mkHsWrap (eta_wrap <.> wrap) + (HsConLikeOut noExtField (RealDataCon con)) + , mkVisFunTys scaled_arg_tys res') + } + False -> let scaled_arg_tys = scaleArgs args + wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs) + eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys) + wrap2 = mkWpTyLams $ binderVars tvs + in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1) + (HsConLikeOut noExtField (RealDataCon con)) + , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res) + } + + check_naughty id + | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) + | otherwise = return () + + +tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc) +-- Typecheck an occurrence of an unbound Id +-- +-- Some of these started life as a true expression hole "_". +-- Others might simply be variables that accidentally have no binding site +-- +-- We turn all of them into HsVar, since HsUnboundVar can't contain an +-- Id; and indeed the evidence for the ExprHole does bind it, so it's +-- not unbound any more! +tcUnboundId rn_expr occ res_ty + = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) + ; name <- newSysName occ + ; let ev = mkLocalId name Many ty + ; emitNewExprHole occ ev ty + ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr + (HsVar noExtField (noLoc ev)) ty res_ty } + + +{- +Note [Adding the implicit parameter to 'assert'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker transforms (assert e1 e2) to (assertError e1 e2). +This isn't really the Right Thing because there's no way to "undo" +if you want to see the original source code in the typechecker +output. We'll have fix this in due course, when we care more about +being able to reconstruct the exact original program. + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude, because it relies on our +knowing *now* that the type is ok, which in turn relies on the +eager-unification part of the type checker pushing enough information +here. In theory the Right Thing to do is to have a new form of +constraint but I definitely cannot face that! And it works ok as-is. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +When data type families are involved it's a bit more complicated. + data family F a + data instance F [Int] = A | B | C +Then we want to generate something like + tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] +Usually that coercion is hidden inside the wrappers for +constructors of F [Int] but here we have to do it explicitly. + +It's all grotesquely complicated. + +Note [Instantiating stupid theta] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, when we infer the type of an Id, we don't instantiate, +because we wish to allow for visible type application later on. +But if a datacon has a stupid theta, we're a bit stuck. We need +to emit the stupid theta constraints with instantiated types. It's +difficult to defer this to the lazy instantiation, because a stupid +theta has no spot to put it in a type. So we just instantiate eagerly +in this case. Thus, users cannot use visible type application with +a data constructor sporting a stupid theta. I won't feel so bad for +the users that complain. + +Note [Linear fields generalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Polymorphisation of linear fields], linear field of data +constructors get a polymorphic type when the data constructor is used as a term. + + Just :: forall {p} a. a #p-> Maybe a + +This rule is known only to the typechecker: Just keeps its linear type in Core. + +In order to desugar this generalised typing rule, we simply eta-expand: + + \a (x # p :: a) -> Just @a x + +has the appropriate type. We insert these eta-expansion with WpFun wrappers. + +A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums, +certain newtypes with -XUnliftedNewtypes) then this strategy produces + + \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #) + +Which has type + + forall r1 r2 a b. a #p-> b #q-> (# a, b #) + +Which violates the levity-polymorphism restriction see Note [Levity polymorphism +checking] in DsMonad. + +So we really must instantiate r1 and r2 rather than quantify over them. For +simplicity, we just instantiate the entire type, as described in Note +[Instantiating stupid theta]. It breaks visible type application with unboxed +tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used +anywhere. + +A better plan: let's force all representation variable to be *inferred*, so that +they are not subject to visible type applications. Then we can instantiate +inferred argument eagerly. +-} + +isTagToEnum :: HsExpr GhcTc -> Bool +isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey +isTagToEnum _ = False + +tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [LHsExprArgOut] + -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +-- tagToEnum# :: forall a. Int# -> a +-- See Note [tagToEnum#] Urgh! +tcTagToEnum expr fun args app_res_ty res_ty + = do { res_ty <- readExpType res_ty + ; ty' <- zonkTcType res_ty + + -- Check that the type is algebraic + ; case tcSplitTyConApp_maybe ty' of { + Nothing -> do { addErrTc (mk_error ty' doc1) + ; vanilla_result } ; + Just (tc, tc_args) -> + + do { -- Look through any type family + ; fam_envs <- tcGetFamInstEnvs + ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of { + Nothing -> do { check_enumeration ty' tc + ; vanilla_result } ; + Just (rep_tc, rep_args, coi) -> + + do { -- coi :: tc tc_args ~R rep_tc rep_args + check_enumeration ty' rep_tc + ; let val_arg = dropWhile (not . isHsValArg) args + rep_ty = mkTyConApp rep_tc rep_args + fun' = mkHsWrap (WpTyApp rep_ty) fun + expr' = applyHsArgs fun' val_arg + df_wrap = mkWpCastR (mkTcSymCo coi) + ; return (mkHsWrap df_wrap expr') }}}}} + + where + vanilla_result + = do { let expr' = applyHsArgs fun args + ; tcWrapResult expr expr' app_res_ty res_ty } + + check_enumeration ty' tc + | isEnumerationTyCon tc = return () + | otherwise = addErrTc (mk_error ty' doc2) + + doc1 = vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ] + doc2 = text "Result type must be an enumeration type" + + mk_error :: TcType -> SDoc -> SDoc + mk_error ty what + = hang (text "Bad call to tagToEnum#" + <+> text "at type" <+> ppr ty) + 2 what + +{- +************************************************************************ +* * + Template Haskell checks +* * +************************************************************************ +-} + +checkThLocalId :: Id -> TcM () +-- The renamer has already done checkWellStaged, +-- in 'GHC.Rename.Splice.checkThLocalName', so don't repeat that here. +-- Here we just add constraints fro cross-stage lifting +checkThLocalId id + = do { mb_local_use <- getStageAndBindLevel (idName id) + ; case mb_local_use of + Just (top_lvl, bind_lvl, use_stage) + | thLevel use_stage > bind_lvl + -> checkCrossStageLifting top_lvl id use_stage + _ -> return () -- Not a locally-bound thing, or + -- no cross-stage link + } + +-------------------------------------- +checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () +-- If we are inside typed brackets, and (use_lvl > bind_lvl) +-- we must check whether there's a cross-stage lift to do +-- Examples \x -> [|| x ||] +-- [|| map ||] +-- +-- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but +-- this code is applied to *typed* brackets. + +checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) + | isTopLevel top_lvl + = when (isExternalName id_name) (keepAlive id_name) + -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice + + | otherwise + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [|| h x ||] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same splice proxy, but that doesn't + -- matter, although it's a mite untidy. + do { let id_ty = idType id + ; checkTc (isTauTy id_ty) (polySpliceErr id) + -- If x is polymorphic, its occurrence sites might + -- have different instantiations, so we can't use plain + -- 'x' as the splice proxy name. I don't know how to + -- solve this, and it's probably unimportant, so I'm + -- just going to flag an error for now + + ; lift <- if isStringTy id_ty then + do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName + -- See Note [Lifting strings] + ; return (HsVar noExtField (noLoc sid)) } + else + setConstraintVar lie_var $ + -- Put the 'lift' constraint into the right LIE + newMethodFromName (OccurrenceOf id_name) + GHC.Builtin.Names.TH.liftName + [getRuntimeRep id_ty, id_ty] + + -- Update the pending splices + ; ps <- readMutVar ps_var + ; let pending_splice = PendingTcSplice id_name + (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift)) + (nlHsVar id)) + ; writeMutVar ps_var (pending_splice : ps) + + ; return () } + where + id_name = idName id + +checkCrossStageLifting _ _ _ = return () + +polySpliceErr :: Id -> SDoc +polySpliceErr id + = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) + +{- +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in "GHC.ThToHs" + +Local record selectors +~~~~~~~~~~~~~~~~~~~~~~ +Record selectors for TyCons in this module are ordinary local bindings, +which show up as ATcIds rather than AGlobals. So we need to check for +naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. + + +************************************************************************ +* * +\subsection{Record bindings} +* * +************************************************************************ +-} + +getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet +-- These tyvars must not change across the updates +getFixedTyVars upd_fld_occs univ_tvs cons + = mkVarSet [tv1 | con <- cons + , let (u_tvs, _, eqspec, prov_theta + , req_theta, arg_tys, _) + = conLikeFullSig con + theta = eqSpecPreds eqspec + ++ prov_theta + ++ req_theta + flds = conLikeFieldLabels con + fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys) + -- fixed_tys: See Note [Type of a record update] + `unionVarSet` tyCoVarsOfTypes theta + -- Universally-quantified tyvars that + -- appear in any of the *implicit* + -- arguments to the constructor are fixed + -- See Note [Implicit type sharing] + + fixed_tys = [ty | (fl, ty) <- zip flds arg_tys + , not (flLabel fl `elem` upd_fld_occs)] + , (tv1,tv) <- univ_tvs `zip` u_tvs + , tv `elemVarSet` fixed_tvs ] + +{- +Note [Disambiguating record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the -XDuplicateRecordFields extension is used, and the renamer +encounters a record selector or update that it cannot immediately +disambiguate (because it involves fields that belong to multiple +datatypes), it will defer resolution of the ambiguity to the +typechecker. In this case, the `Ambiguous` constructor of +`AmbiguousFieldOcc` is used. + +Consider the following definitions: + + data S = MkS { foo :: Int } + data T = MkT { foo :: Int, bar :: Int } + data U = MkU { bar :: Int, baz :: Int } + +When the renamer sees `foo` as a selector or an update, it will not +know which parent datatype is in use. + +For selectors, there are two possible ways to disambiguate: + +1. Check if the pushed-in type is a function whose domain is a + datatype, for example: + + f s = (foo :: S -> Int) s + + g :: T -> Int + g = foo + + This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. + +2. Check if the selector is applied to an argument that has a type + signature, for example: + + h = foo (s :: S) + + This is checked by `tcApp`. + + +Updates are slightly more complex. The `disambiguateRecordBinds` +function tries to determine the parent datatype in three ways: + +1. Check for types that have all the fields being updated. For example: + + f x = x { foo = 3, bar = 2 } + + Here `f` must be updating `T` because neither `S` nor `U` have + both fields. This may also discover that no possible type exists. + For example the following will be rejected: + + f' x = x { foo = 3, baz = 3 } + +2. Use the type being pushed in, if it is already a TyConApp. The + following are valid updates to `T`: + + g :: T -> T + g x = x { foo = 3 } + + g' x = x { foo = 3 } :: T + +3. Use the type signature of the record expression, if it exists and + is a TyConApp. Thus this is valid update to `T`: + + h x = (x :: T) { foo = 3 } + + +Note that we do not look up the types of variables being updated, and +no constraint-solving is performed, so for example the following will +be rejected as ambiguous: + + let bad (s :: S) = foo s + + let r :: T + r = blah + in r { foo = 3 } + + \r. (r { foo = 3 }, r :: T ) + +We could add further tests, of a more heuristic nature. For example, +rather than looking for an explicit signature, we could try to infer +the type of the argument to a selector or the record expression being +updated, in case we are lucky enough to get a TyConApp straight +away. However, it might be hard for programmers to predict whether a +particular update is sufficiently obvious for the signature to be +omitted. Moreover, this might change the behaviour of typechecker in +non-obvious ways. + +See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. +-} + +-- Given a RdrName that refers to multiple record fields, and the type +-- of its argument, try to determine the name of the selector that is +-- meant. +disambiguateSelector :: Located RdrName -> Type -> TcM Name +disambiguateSelector lr@(L _ rdr) parent_type + = do { fam_inst_envs <- tcGetFamInstEnvs + ; case tyConOf fam_inst_envs parent_type of + Nothing -> ambiguousSelector lr + Just p -> + do { xs <- lookupParents rdr + ; let parent = RecSelData p + ; case lookup parent xs of + Just gre -> do { addUsedGRE True gre + ; return (gre_name gre) } + Nothing -> failWithTc (fieldNotInType parent rdr) } } + +-- This field name really is ambiguous, so add a suitable "ambiguous +-- occurrence" error, then give up. +ambiguousSelector :: Located RdrName -> TcM a +ambiguousSelector (L _ rdr) + = do { addAmbiguousNameErr rdr + ; failM } + +-- | This name really is ambiguous, so add a suitable "ambiguous +-- occurrence" error, then continue +addAmbiguousNameErr :: RdrName -> TcM () +addAmbiguousNameErr rdr + = do { env <- getGlobalRdrEnv + ; let gres = lookupGRE_RdrName rdr env + ; setErrCtxt [] $ addNameClashErrRn rdr gres} + +-- Disambiguate the fields in a record update. +-- See Note [Disambiguating record fields] +disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType + -> [LHsRecUpdField GhcRn] -> ExpRhoType + -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] +disambiguateRecordBinds record_expr record_rho rbnds res_ty + -- Are all the fields unambiguous? + = case mapM isUnambiguous rbnds of + -- If so, just skip to looking up the Ids + -- Always the case if DuplicateRecordFields is off + Just rbnds' -> mapM lookupSelector rbnds' + Nothing -> -- If not, try to identify a single parent + do { fam_inst_envs <- tcGetFamInstEnvs + -- Look up the possible parents for each field + ; rbnds_with_parents <- getUpdFieldsParents + ; let possible_parents = map (map fst . snd) rbnds_with_parents + -- Identify a single parent + ; p <- identifyParent fam_inst_envs possible_parents + -- Pick the right selector with that parent for each field + ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } + where + -- Extract the selector name of a field update if it is unambiguous + isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) + isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of + Unambiguous sel_name _ -> Just (x, sel_name) + Ambiguous{} -> Nothing + + -- Look up the possible parents and selector GREs for each field + getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn + , [(RecSelParent, GlobalRdrElt)])] + getUpdFieldsParents + = fmap (zip rbnds) $ mapM + (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc) + rbnds + + -- Given a the lists of possible parents for each field, + -- identify a single parent + identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent + identifyParent fam_inst_envs possible_parents + = case foldr1 intersect possible_parents of + -- No parents for all fields: record update is ill-typed + [] -> failWithTc (noPossibleParents rbnds) + + -- Exactly one datatype with all the fields: use that + [p] -> return p + + -- Multiple possible parents: try harder to disambiguate + -- Can we get a parent TyCon from the pushed-in type? + _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p) + + -- Does the expression being updated have a type signature? + -- If so, try to extract a parent TyCon from it + | Just {} <- obviousSig (unLoc record_expr) + , Just tc <- tyConOf fam_inst_envs record_rho + -> return (RecSelData tc) + + -- Nothing else we can try... + _ -> failWithTc badOverloadedUpdate + + -- Make a field unambiguous by choosing the given parent. + -- Emits an error if the field cannot have that parent, + -- e.g. if the user writes + -- r { x = e } :: T + -- where T does not have field x. + pickParent :: RecSelParent + -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) + -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + pickParent p (upd, xs) + = case lookup p xs of + -- Phew! The parent is valid for this field. + -- Previously ambiguous fields must be marked as + -- used now that we know which one is meant, but + -- unambiguous ones shouldn't be recorded again + -- (giving duplicate deprecation warnings). + Just gre -> do { unless (null (tail xs)) $ do + let L loc _ = hsRecFieldLbl (unLoc upd) + setSrcSpan loc $ addUsedGRE True gre + ; lookupSelector (upd, gre_name gre) } + -- The field doesn't belong to this parent, so report + -- an error but keep going through all the fields + Nothing -> do { addErrTc (fieldNotInType p + (unLoc (hsRecUpdFieldRdr (unLoc upd)))) + ; lookupSelector (upd, gre_name (snd (head xs))) } + + -- Given a (field update, selector name) pair, look up the + -- selector to give a field update with an unambiguous Id + lookupSelector :: (LHsRecUpdField GhcRn, Name) + -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + lookupSelector (L l upd, n) + = do { i <- tcLookupId n + ; let L loc af = hsRecFieldLbl upd + lbl = rdrNameAmbiguousFieldOcc af + ; return $ L l upd { hsRecFieldLbl + = L loc (Unambiguous i (L loc lbl)) } } + + +-- Extract the outermost TyCon of a type, if there is one; for +-- data families this is the representation tycon (because that's +-- where the fields live). +tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon +tyConOf fam_inst_envs ty0 + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) + Nothing -> Nothing + where + (_, _, ty) = tcSplitSigmaTy ty0 + +-- Variant of tyConOf that works for ExpTypes +tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon +tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 + +-- For an ambiguous record field, find all the candidate record +-- selectors (as GlobalRdrElts) and their parents. +lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] +lookupParents rdr + = do { env <- getGlobalRdrEnv + ; let gres = lookupGRE_RdrName rdr env + ; mapM lookupParent gres } + where + lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) + lookupParent gre = do { id <- tcLookupId (gre_name gre) + ; if isRecordSelector id + then return (recordSelectorTyCon id, gre) + else failWithTc (notSelector (gre_name gre)) } + +-- A type signature on the argument of an ambiguous record selector or +-- the record expression in an update must be "obvious", i.e. the +-- outermost constructor ignoring parentheses. +obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) +obviousSig (ExprWithTySig _ _ ty) = Just ty +obviousSig (HsPar _ p) = obviousSig (unLoc p) +obviousSig _ = Nothing + + +{- +Game plan for record bindings +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Find the TyCon for the bindings, from the first field label. + +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. + +For each binding field = value + +3. Instantiate the field type (from the field label) using the type + envt from step 2. + +4 Type check the value using tcArg, passing the field type as + the expected argument type. + +This extends OK when the field types are universally quantified. +-} + +tcRecordBinds + :: ConLike + -> [TcType] -- Expected type for each field + -> HsRecordBinds GhcRn + -> TcM (HsRecordBinds GhcTc) + +tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields (catMaybes mb_binds) dd) } + where + fields = map flSelector $ conLikeFieldLabels con_like + flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys + + do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) + do_bind (L l fld@(HsRecField { hsRecFieldLbl = f + , hsRecFieldArg = rhs })) + + = do { mb <- tcRecordField con_like flds_w_tys f rhs + ; case mb of + Nothing -> return Nothing + Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' + , hsRecFieldArg = rhs' }))) } + +tcRecordUpd + :: ConLike + -> [TcType] -- Expected type for each field + -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> TcM [LHsRecUpdField GhcTc] + +tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds + where + fields = map flSelector $ conLikeFieldLabels con_like + flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys + + do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecUpdField GhcTc)) + do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af + , hsRecFieldArg = rhs })) + = do { let lbl = rdrNameAmbiguousFieldOcc af + sel_id = selectorAmbiguousFieldOcc af + f = L loc (FieldOcc (idName sel_id) (L loc lbl)) + ; mb <- tcRecordField con_like flds_w_tys f rhs + ; case mb of + Nothing -> return Nothing + Just (f', rhs') -> + return (Just + (L l (fld { hsRecFieldLbl + = L loc (Unambiguous + (extFieldOcc (unLoc f')) + (L loc lbl)) + , hsRecFieldArg = rhs' }))) } + +tcRecordField :: ConLike -> Assoc Name Type + -> LFieldOcc GhcRn -> LHsExpr GhcRn + -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) +tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs + | Just field_ty <- assocMaybe flds_w_tys sel_name + = addErrCtxt (fieldCtxt field_lbl) $ + do { rhs' <- tcCheckPolyExprNC rhs field_ty + ; let field_id = mkUserLocal (nameOccName sel_name) + (nameUnique sel_name) + Many field_ty loc + -- Yuk: the field_id has the *unique* of the selector Id + -- (so we can find it easily) + -- but is a LocalId with the appropriate type of the RHS + -- (so the desugarer knows the type of local binder to make) + ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } + | otherwise + = do { addErrTc (badFieldCon con_like field_lbl) + ; return Nothing } + where + field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) + + +checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () +checkMissingFields con_like rbinds + | null field_labels -- Not declared as a record; + -- But C{} is still valid if no strict fields + = if any isBanged field_strs then + -- Illegal if any arg is strict + addErrTc (missingStrictFields con_like []) + else do + warn <- woptM Opt_WarnMissingFields + when (warn && notNull field_strs && null field_labels) + (warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like [])) + + | otherwise = do -- A record + unless (null missing_s_fields) + (addErrTc (missingStrictFields con_like missing_s_fields)) + + warn <- woptM Opt_WarnMissingFields + when (warn && notNull missing_ns_fields) + (warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like missing_ns_fields)) + + where + missing_s_fields + = [ flLabel fl | (fl, str) <- field_info, + isBanged str, + not (fl `elemField` field_names_used) + ] + missing_ns_fields + = [ flLabel fl | (fl, str) <- field_info, + not (isBanged str), + not (fl `elemField` field_names_used) + ] + + field_names_used = hsRecFields rbinds + field_labels = conLikeFieldLabels con_like + + field_info = zipEqual "missingFields" + field_labels + field_strs + + field_strs = conLikeImplBangs con_like + + fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds + +{- +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +Boring and alphabetical: +-} + +fieldCtxt :: FieldLabelString -> SDoc +fieldCtxt field_name + = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") + +addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a +addExprCtxt e thing_inside = addErrCtxt (exprCtxt (unLoc e)) thing_inside + +exprCtxt :: HsExpr GhcRn -> SDoc +exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) + +addFunResCtxt :: Bool -- There is at least one argument + -> HsExpr GhcTc -> TcType -> ExpRhoType + -> TcM a -> TcM a +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +-- +-- Used for naked variables too; but with has_args = False +addFunResCtxt has_args fun fun_res_ty env_ty + = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) + -- NB: use a landmark error context, so that an empty context + -- doesn't suppress some more useful context + where + mk_msg + = do { mb_env_ty <- readExpType_maybe env_ty + -- by the time the message is rendered, the ExpType + -- will be filled in (except if we're debugging) + ; fun_res' <- zonkTcType fun_res_ty + ; env' <- case mb_env_ty of + Just env_ty -> zonkTcType env_ty + Nothing -> + do { dumping <- doptM Opt_D_dump_tc_trace + ; MASSERT( dumping ) + ; newFlexiTyVarTy liftedTypeKind } + ; let -- See Note [Splitting nested sigma types in mismatched + -- function types] + (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' + -- No need to call tcSplitNestedSigmaTys here, since env_ty is + -- an ExpRhoTy, i.e., it's already instantiated. + (_, _, env_tau) = tcSplitSigmaTy env' + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + n_fun = length args_fun + n_env = length args_env + info | n_fun == n_env = Outputable.empty + | n_fun > n_env + , not_fun res_env + = text "Probable cause:" <+> quotes (ppr fun) + <+> text "is applied to too few arguments" + + | has_args + , not_fun res_fun + = text "Possible cause:" <+> quotes (ppr fun) + <+> text "is applied to too many arguments" + + | otherwise + = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! + ; return info } + where + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False + +{- +Note [Splitting nested sigma types in mismatched function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When one applies a function to too few arguments, GHC tries to determine this +fact if possible so that it may give a helpful error message. It accomplishes +this by checking if the type of the applied function has more argument types +than supplied arguments. + +Previously, GHC computed the number of argument types through tcSplitSigmaTy. +This is incorrect in the face of nested foralls, however! This caused Trac +#13311, for instance: + + f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b + +If one uses `f` like so: + + do { f; putChar 'a' } + +Then tcSplitSigmaTy will decompose the type of `f` into: + + Tyvars: [a] + Context: (Monoid a) + Argument types: [] + Return type: forall b. Monoid b => Maybe a -> Maybe b + +That is, it will conclude that there are *no* argument types, and since `f` +was given no arguments, it won't print a helpful error message. On the other +hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: + + Tyvars: [a, b] + Context: (Monoid a, Monoid b) + Argument types: [Maybe a] + Return type: Maybe b + +So now GHC recognizes that `f` has one more argument type than it was actually +provided. +-} + +badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc +badFieldTypes prs + = hang (text "Record update for insufficiently polymorphic field" + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + +badFieldsUpd + :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -- Field names that don't belong to a single datacon + -> [ConLike] -- Data cons of the type which the first field name belongs to + -> SDoc +badFieldsUpd rbinds data_cons + = hang (text "No constructor has all these fields:") + 2 (pprQuotedList conflictingFields) + -- See Note [Finding the conflicting fields] + where + -- A (preferably small) set of fields such that no constructor contains + -- all of them. See Note [Finding the conflicting fields] + conflictingFields = case nonMembers of + -- nonMember belongs to a different type. + (nonMember, _) : _ -> [aMember, nonMember] + [] -> let + -- All of rbinds belong to one type. In this case, repeatedly add + -- a field to the set until no constructor contains the set. + + -- Each field, together with a list indicating which constructors + -- have all the fields so far. + growingSets :: [(FieldLabelString, [Bool])] + growingSets = scanl1 combine membership + combine (_, setMem) (field, fldMem) + = (field, zipWith (&&) setMem fldMem) + in + -- Fields that don't change the membership status of the set + -- are redundant and can be dropped. + map (fst . head) $ groupBy ((==) `on` snd) growingSets + + aMember = ASSERT( not (null members) ) fst (head members) + (members, nonMembers) = partition (or . snd) membership + + -- For each field, which constructors contain the field? + membership :: [(FieldLabelString, [Bool])] + membership = sortMembership $ + map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ + map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds + + fieldLabelSets :: [Set.Set FieldLabelString] + fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons + + -- Sort in order of increasing number of True, so that a smaller + -- conflicting set can be found. + sortMembership = + map snd . + sortBy (compare `on` fst) . + map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) + + countTrue = count id + +{- +Note [Finding the conflicting fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data A = A {a0, a1 :: Int} + | B {b0, b1 :: Int} +and we see a record update + x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } +Then we'd like to find the smallest subset of fields that no +constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. +We don't really want to report that no constructor has all of +{a0,a1,b0,b1}, because when there are hundreds of fields it's +hard to see what was really wrong. + +We may need more than two fields, though; eg + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } + | C { z,x :: Int, v::Int } +with update + r { x=e1, y=e2, z=e3 }, we + +Finding the smallest subset is hard, so the code here makes +a decent stab, no more. See #7989. +-} + +naughtyRecordSel :: RdrName -> SDoc +naughtyRecordSel sel_id + = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> + text "as a function due to escaped type variables" $$ + text "Probable fix: use pattern-matching syntax instead" + +notSelector :: Name -> SDoc +notSelector field + = hsep [quotes (ppr field), text "is not a record selector"] + +mixedSelectors :: [Id] -> [Id] -> SDoc +mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) + = ptext + (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ + text "Record selectors defined by" + <+> quotes (ppr (tyConName rep_dc)) + <> text ":" + <+> pprWithCommas ppr data_sels $$ + text "Pattern synonym selectors defined by" + <+> quotes (ppr (patSynName rep_ps)) + <> text ":" + <+> pprWithCommas ppr pat_syn_sels + where + RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id + RecSelData rep_dc = recordSelectorTyCon dc_rep_id +mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" + + +missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc +missingStrictFields con fields + = header <> rest + where + rest | null fields = Outputable.empty -- Happens for non-record constructors + -- with strict fields + | otherwise = colon <+> pprWithCommas ppr fields + + header = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" + +missingFields :: ConLike -> [FieldLabelString] -> SDoc +missingFields con fields + = header <> rest + where + rest | null fields = Outputable.empty + | otherwise = colon <+> pprWithCommas ppr fields + header = text "Fields of" <+> quotes (ppr con) <+> + text "not initialised" + +-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) + +noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc +noPossibleParents rbinds + = hang (text "No type has all these fields:") + 2 (pprQuotedList fields) + where + fields = map (hsRecFieldLbl . unLoc) rbinds + +badOverloadedUpdate :: SDoc +badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" + +fieldNotInType :: RecSelParent -> RdrName -> SDoc +fieldNotInType p rdr + = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr + +{- +************************************************************************ +* * +\subsection{Static Pointers} +* * +************************************************************************ +-} + +-- | A data type to describe why a variable is not closed. +data NotClosedReason = NotLetBoundReason + | NotTypeClosed VarSet + | NotClosed Name NotClosedReason + +-- | Checks if the given name is closed and emits an error if not. +-- +-- See Note [Not-closed error messages]. +checkClosedInStaticForm :: Name -> TcM () +checkClosedInStaticForm name = do + type_env <- getLclTypeEnv + case checkClosed type_env name of + Nothing -> return () + Just reason -> addErrTc $ explain name reason + where + -- See Note [Checking closedness]. + checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason + checkClosed type_env n = checkLoop type_env (unitNameSet n) n + + checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason + checkLoop type_env visited n = do + -- The @visited@ set is an accumulating parameter that contains the set of + -- visited nodes, so we avoid repeating cycles in the traversal. + case lookupNameEnv type_env n of + Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of + ClosedLet -> Nothing + NotLetBound -> Just NotLetBoundReason + NonClosedLet fvs type_closed -> listToMaybe $ + -- Look for a non-closed variable in fvs + [ NotClosed n' reason + | n' <- nameSetElemsStable fvs + , not (elemNameSet n' visited) + , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] + ] ++ + if type_closed then + [] + else + -- We consider non-let-bound variables easier to figure out than + -- non-closed types, so we report non-closed types to the user + -- only if we cannot spot the former. + [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] + -- The binding is closed. + _ -> Nothing + + -- Converts a reason into a human-readable sentence. + -- + -- @explain name reason@ starts with + -- + -- " is used in a static form but it is not closed because it" + -- + -- and then follows a list of causes. For each id in the path, the text + -- + -- "uses which" + -- + -- is appended, yielding something like + -- + -- "uses which uses which uses which" + -- + -- until the end of the path is reached, which is reported as either + -- + -- "is not let-bound" + -- + -- when the final node is not let-bound, or + -- + -- "has a non-closed type because it contains the type variables: + -- v1, v2, v3" + -- + -- when the final node has a non-closed type. + -- + explain :: Name -> NotClosedReason -> SDoc + explain name reason = + quotes (ppr name) <+> text "is used in a static form but it is not closed" + <+> text "because it" + $$ + sep (causes reason) + + causes :: NotClosedReason -> [SDoc] + causes NotLetBoundReason = [text "is not let-bound."] + causes (NotTypeClosed vs) = + [ text "has a non-closed type because it contains the" + , text "type variables:" <+> + pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) + ] + causes (NotClosed n reason) = + let msg = text "uses" <+> quotes (ppr n) <+> text "which" + in case reason of + NotClosed _ _ -> msg : causes reason + _ -> let (xs0, xs1) = splitAt 1 $ causes reason + in fmap (msg <+>) xs0 ++ xs1 + +-- Note [Not-closed error messages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When variables in a static form are not closed, we go through the trouble +-- of explaining why they aren't. +-- +-- Thus, the following program +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > f x = static g +-- > where +-- > g = h +-- > h = x +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which uses 'x' which is not let-bound. +-- +-- And a program like +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > import Data.Typeable +-- > import GHC.StaticPtr +-- > +-- > f :: Typeable a => a -> StaticPtr TypeRep +-- > f x = const (static (g undefined)) (h x) +-- > where +-- > g = h +-- > h = typeOf +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which has a non-closed type because it contains the +-- type variables: 'a' +-- + +-- Note [Checking closedness] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- @checkClosed@ checks if a binding is closed and returns a reason if it is +-- not. +-- +-- The bindings define a graph where the nodes are ids, and there is an edge +-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free +-- variables. +-- +-- When @n@ is not closed, it has to exist in the graph some node reachable +-- from @n@ that it is not a let-bound variable or that it has a non-closed +-- type. Thus, the "reason" is a path from @n@ to this offending node. +-- +-- When @n@ is not closed, we traverse the graph reachable from @n@ to build +-- the reason. +-- diff --git a/GHC/Tc/Gen/Expr.hs-boot b/GHC/Tc/Gen/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Expr.hs-boot @@ -0,0 +1,46 @@ +module GHC.Tc.Gen.Expr where +import GHC.Types.Name +import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) +import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Origin ( CtOrigin ) +import GHC.Core.Type ( Mult ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) + +tcCheckPolyExpr :: + LHsExpr GhcRn + -> TcSigmaType + -> TcM (LHsExpr GhcTc) + +tcMonoExpr, tcMonoExprNC :: + LHsExpr GhcRn + -> ExpRhoType + -> TcM (LHsExpr GhcTc) +tcCheckMonoExpr, tcCheckMonoExprNC :: + LHsExpr GhcRn + -> TcRhoType + -> TcM (LHsExpr GhcTc) + +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + +tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) + +tcInferRho, tcInferRhoNC :: + LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) + +tcSyntaxOp :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpType -- ^ overall result type + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments + -> TcM (a, SyntaxExprTc) + +tcSyntaxOpGen :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaType] -> [Mult] -> TcM a) + -> TcM (a, SyntaxExprTc) + + +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) diff --git a/GHC/Tc/Gen/Foreign.hs b/GHC/Tc/Gen/Foreign.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Foreign.hs @@ -0,0 +1,561 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking @foreign@ declarations +-- +-- A foreign declaration is used to either give an externally +-- implemented function a Haskell type (and calling interface) or +-- give a Haskell function an external calling interface. Either way, +-- the range of argument and result types these functions can accommodate +-- is restricted to what the outside world understands (read C), and this +-- module checks to see if a foreign declaration has got a legal type. +module GHC.Tc.Gen.Foreign + ( tcForeignImports + , tcForeignExports + + -- Low-level exports for hooks + , isForeignImport, isForeignExport + , tcFImport, tcFExport + , tcForeignImports' + , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes + , normaliseFfiType + , nonIOok, mustBeIO + , checkSafe, noCheckSafe + , tcForeignExports' + , tcCheckFEType + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Env + +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Types.ForeignCall +import GHC.Utils.Error +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names +import GHC.Driver.Session +import GHC.Utils.Outputable as Outputable +import GHC.Platform +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Driver.Hooks +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad + +-- Defines a binding +isForeignImport :: LForeignDecl name -> Bool +isForeignImport (L _ (ForeignImport {})) = True +isForeignImport _ = False + +-- Exports a binding +isForeignExport :: LForeignDecl name -> Bool +isForeignExport (L _ (ForeignExport {})) = True +isForeignExport _ = False + +{- +Note [Don't recur in normaliseFfiType'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +normaliseFfiType' is the workhorse for normalising a type used in a foreign +declaration. If we have + +newtype Age = MkAge Int + +we want to see that Age -> IO () is the same as Int -> IO (). But, we don't +need to recur on any type parameters, because no paramaterized types (with +interesting parameters) are marshalable! The full list of marshalable types +is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that +list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled +the same way regardless of type parameter. So, no need to recur into +parameters. + +Similarly, we don't need to look in AppTy's, because nothing headed by +an AppTy will be marshalable. +-} + +-- normaliseFfiType takes the type from an FFI declaration, and +-- evaluates any type synonyms, type functions, and newtypes. However, +-- we are only allowed to look through newtypes if the constructor is +-- in scope. We return a bag of all the newtype constructors thus found. +-- Always returns a Representational coercion +normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) +normaliseFfiType ty + = do fam_envs <- tcGetFamInstEnvs + normaliseFfiType' fam_envs ty + +normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) +normaliseFfiType' env ty0 = go Representational initRecTc ty0 + where + go :: Role -> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) + go role rec_nts ty + | Just ty' <- tcView ty -- Expand synonyms + = go role rec_nts ty' + + | Just (tc, tys) <- splitTyConApp_maybe ty + = go_tc_app role rec_nts tc tys + + | (bndrs, inner_ty) <- splitForAllVarBndrs ty + , not (null bndrs) + = do (coi, nty1, gres1) <- go role rec_nts inner_ty + return ( mkHomoForAllCos (binderVars bndrs) coi + , mkForAllTys bndrs nty1, gres1 ) + + | otherwise -- see Note [Don't recur in normaliseFfiType'] + = return (mkReflCo role ty, ty, emptyBag) + + go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type] + -> TcM (Coercion, Type, Bag GlobalRdrElt) + go_tc_app role rec_nts tc tys + -- We don't want to look through the IO newtype, even if it is + -- in scope, so we have a special case for it: + | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] + = children_only + + | isNewTyCon tc -- Expand newtypes + , Just rec_nts' <- checkRecTc rec_nts tc + -- See Note [Expanding newtypes] in GHC.Core.TyCon + -- We can't just use isRecursiveTyCon; sometimes recursion is ok: + -- newtype T = T (Ptr T) + -- Here, we don't reject the type for being recursive. + -- If this is a recursive newtype then it will normally + -- be rejected later as not being a valid FFI type. + = do { rdr_env <- getGlobalRdrEnv + ; case checkNewtypeFFI rdr_env tc of + Nothing -> nothing + Just gre -> do { (co', ty', gres) <- go role rec_nts' nt_rhs + ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } + + | isFamilyTyCon tc -- Expand open tycons + , (co, ty) <- normaliseTcApp env role tc tys + , not (isReflexiveCo co) + = do (co', ty', gres) <- go role rec_nts ty + return (mkTransCo co co', ty', gres) + + | otherwise + = nothing -- see Note [Don't recur in normaliseFfiType'] + where + tc_key = getUnique tc + children_only + = do xs <- zipWithM (\ty r -> go r rec_nts ty) tys (tyConRolesX role tc) + let (cos, tys', gres) = unzip3 xs + return ( mkTyConAppCo role tc cos + , mkTyConApp tc tys', unionManyBags gres) + nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys [] + nt_rhs = newTyConInstRhs tc tys + + ty = mkTyConApp tc tys + nothing = return (mkReflCo role ty, ty, emptyBag) + +checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt +checkNewtypeFFI rdr_env tc + | Just con <- tyConSingleDataCon_maybe tc + , Just gre <- lookupGRE_Name rdr_env (dataConName con) + = Just gre -- See Note [Newtype constructor usage in foreign declarations] + | otherwise + = Nothing + +{- +Note [Newtype constructor usage in foreign declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC automatically "unwraps" newtype constructors in foreign import/export +declarations. In effect that means that a newtype data constructor is +used even though it is not mentioned expclitly in the source, so we don't +want to report it as "defined but not used" or "imported but not used". +eg newtype D = MkD Int + foreign import foo :: D -> IO () +Here 'MkD' us used. See #7408. + +GHC also expands type functions during this process, so it's not enough +just to look at the free variables of the declaration. +eg type instance F Bool = D + foreign import bar :: F Bool -> IO () +Here again 'MkD' is used. + +So we really have wait until the type checker to decide what is used. +That's why tcForeignImports and tecForeignExports return a (Bag GRE) +for the newtype constructors they see. Then GHC.Tc.Module can add them +to the module's usages. + + +************************************************************************ +* * +\subsection{Imports} +* * +************************************************************************ +-} + +tcForeignImports :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) +tcForeignImports decls + = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) + +tcForeignImports' :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignImports' decls + = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ + filter isForeignImport decls + ; return (ids, decls, unionManyBags gres) } + +tcFImport :: LForeignDecl GhcRn + -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) +tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty + , fd_fi = imp_decl })) + = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ + do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty + ; let + -- Drop the foralls before inspecting the + -- structure of the foreign type. + (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) + id = mkLocalId nm Many sig_ty + -- Use a LocalId to obey the invariant that locally-defined + -- things are LocalIds. However, it does not need zonking, + -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it). + + ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl + -- Can't use sig_ty here because sig_ty :: Type and + -- we need HsType Id hence the undefined + ; let fi_decl = ForeignImport { fd_name = L nloc id + , fd_sig_ty = undefined + , fd_i_ext = mkSymCo norm_co + , fd_fi = imp_decl' } + ; return (id, L dloc fi_decl, gres) } +tcFImport d = pprPanic "tcFImport" (ppr d) + +-- ------------ Checking types for foreign import ---------------------- + +tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport + +tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) + -- Foreign import label + = do checkCg checkCOrAsmOrLlvmOrInterp + -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) + check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) + cconv' <- checkCConv cconv + return (CImport (L lc cconv') safety mh l src) + +tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do + -- Foreign wrapper (former f.e.d.) + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid + -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. + -- The use of the latter form is DEPRECATED, though. + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + case arg_tys of + [Scaled arg1_mult arg1_ty] -> do + checkNoLinearFFI arg1_mult + checkForeignArgs isFFIExternalTy arg1_tys + checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty + checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty + where + (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty + _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) + return (CImport (L lc cconv') safety mh CWrapper src) + +tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh + (CFunction target) src) + | isDynamicTarget target = do -- Foreign import dynamic + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + case arg_tys of -- The first arg must be Ptr or FunPtr + [] -> + addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) + (Scaled arg1_mult arg1_ty:arg_tys) -> do + dflags <- getDynFlags + let curried_res_ty = mkVisFunTys arg_tys res_ty + checkNoLinearFFI arg1_mult + check (isFFIDynTy curried_res_ty arg1_ty) + (illegalForeignTyErr argument) + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + | cconv == PrimCallConv = do + dflags <- getDynFlags + checkTc (xopt LangExt.GHCForeignImportPrim dflags) + (text "Use GHCForeignImportPrim to allow `foreign import prim'.") + checkCg checkCOrAsmOrLlvmOrInterp + checkCTarget target + checkTc (playSafe safety) + (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys + -- prim import result is more liberal, allows (#,,#) + checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty + return idecl + | otherwise = do -- Normal foreign import + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + checkCTarget target + dflags <- getDynFlags + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty + case target of + StaticTarget _ _ _ False + | not (null arg_tys) -> + addErrTc (text "`value' imports cannot have function types") + _ -> return () + return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + + +-- This makes a convenient place to check +-- that the C identifier is valid for C +checkCTarget :: CCallTarget -> TcM () +checkCTarget (StaticTarget _ str _ _) = do + checkCg checkCOrAsmOrLlvmOrInterp + checkTc (isCLabelString str) (badCName str) + +checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" + + +checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () +checkMissingAmpersand dflags arg_tys res_ty + | null arg_tys && isFunPtrTy res_ty && + wopt Opt_WarnDodgyForeignImports dflags + = addWarn (Reason Opt_WarnDodgyForeignImports) + (text "possible missing & in foreign import of FunPtr") + | otherwise + = return () + +{- +************************************************************************ +* * +\subsection{Exports} +* * +************************************************************************ +-} + +tcForeignExports :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) +tcForeignExports decls = + getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) + +tcForeignExports' :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignExports' decls + = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) + where + combine (binds, fs, gres1) (L loc fe) = do + (b, f, gres2) <- setSrcSpan loc (tcFExport fe) + return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) + +tcFExport :: ForeignDecl GhcRn + -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) +tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) + = addErrCtxt (foreignDeclCtxt fo) $ do + + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty + + (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty + + spec' <- tcCheckFEType norm_sig_ty spec + + -- we're exporting a function, but at a type possibly more + -- constrained than its declared/inferred type. Hence the need + -- to create a local binding which will call the exported function + -- at a particular type (and, maybe, overloading). + + + -- We need to give a name to the new top-level binding that + -- is *stable* (i.e. the compiler won't change it later), + -- because this name will be referred to by the C code stub. + id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + return ( mkVarBind id rhs + , ForeignExport { fd_name = L loc id + , fd_sig_ty = undefined + , fd_e_ext = norm_co, fd_fe = spec' } + , gres) +tcFExport d = pprPanic "tcFExport" (ppr d) + +-- ------------ Checking argument types for foreign export ---------------------- + +tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport +tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do + checkCg checkCOrAsmOrLlvm + checkTc (isCLabelString str) (badCName str) + cconv' <- checkCConv cconv + checkForeignArgs isFFIExternalTy arg_tys + checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport (L l (CExportStatic esrc str cconv')) src) + where + -- Drop the foralls before inspecting + -- the structure of the foreign type. + (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty) + +{- +************************************************************************ +* * +\subsection{Miscellaneous} +* * +************************************************************************ +-} + +------------ Checking argument types for foreign import ---------------------- +checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM () +checkForeignArgs pred tys = mapM_ go tys + where + go (Scaled mult ty) = checkNoLinearFFI mult >> + check (pred ty) (illegalForeignTyErr argument) + +checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472) +checkNoLinearFFI Many = return () +checkNoLinearFFI _ = addErrTc $ illegalForeignTyErr argument + (text "Linear types are not supported in FFI declarations, see #18472") + +------------ Checking result types for foreign calls ---------------------- +-- | Check that the type has the form +-- (IO t) or (t) , and that t satisfies the given predicate. +-- When calling this function, any newtype wrappers (should) have been +-- already dealt with by normaliseFfiType. +-- +-- We also check that the Safe Haskell condition of FFI imports having +-- results in the IO monad holds. +-- +checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () +checkForeignRes non_io_result_ok check_safe pred_res_ty ty + | Just (_, res_ty) <- tcSplitIOType_maybe ty + = -- Got an IO result type, that's always fine! + check (pred_res_ty res_ty) (illegalForeignTyErr result) + + -- We disallow nested foralls in foreign types + -- (at least, for the time being). See #16702. + | tcIsForAllTy ty + = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall") + + -- Case for non-IO result type with FFI Import + | not non_io_result_ok + = addErrTc $ illegalForeignTyErr result (text "IO result type expected") + + | otherwise + = do { dflags <- getDynFlags + ; case pred_res_ty ty of + -- Handle normal typecheck fail, we want to handle this first and + -- only report safe haskell errors if the normal type check is OK. + NotValid msg -> addErrTc $ illegalForeignTyErr result msg + + -- handle safe infer fail + _ | check_safe && safeInferOn dflags + -> recordUnsafeInfer emptyBag + + -- handle safe language typecheck fail + _ | check_safe && safeLanguageOn dflags + -> addErrTc (illegalForeignTyErr result safeHsErr) + + -- success! non-IO return is fine + _ -> return () } + where + safeHsErr = + text "Safe Haskell is on, all FFI imports must be in the IO monad" + +nonIOok, mustBeIO :: Bool +nonIOok = True +mustBeIO = False + +checkSafe, noCheckSafe :: Bool +checkSafe = True +noCheckSafe = False + +-- Checking a supported backend is in use + +checkCOrAsmOrLlvm :: HscTarget -> Validity +checkCOrAsmOrLlvm HscC = IsValid +checkCOrAsmOrLlvm HscAsm = IsValid +checkCOrAsmOrLlvm HscLlvm = IsValid +checkCOrAsmOrLlvm _ + = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") + +checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity +checkCOrAsmOrLlvmOrInterp HscC = IsValid +checkCOrAsmOrLlvmOrInterp HscAsm = IsValid +checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid +checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid +checkCOrAsmOrLlvmOrInterp _ + = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") + +checkCg :: (HscTarget -> Validity) -> TcM () +checkCg check = do + dflags <- getDynFlags + let target = hscTarget dflags + case target of + HscNothing -> return () + _ -> + case check target of + IsValid -> return () + NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) + +-- Calling conventions + +checkCConv :: CCallConv -> TcM CCallConv +checkCConv CCallConv = return CCallConv +checkCConv CApiConv = return CApiConv +checkCConv StdCallConv = do dflags <- getDynFlags + let platform = targetPlatform dflags + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ + addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) + (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + return CCallConv +checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv +checkCConv JavaScriptCallConv = do dflags <- getDynFlags + if platformArch (targetPlatform dflags) == ArchJavaScript + then return JavaScriptCallConv + else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") + return JavaScriptCallConv + +-- Warnings + +check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () +check IsValid _ = return () +check (NotValid doc) err_fn = addErrTc (err_fn doc) + +illegalForeignTyErr :: SDoc -> SDoc -> SDoc +illegalForeignTyErr arg_or_res extra + = hang msg 2 extra + where + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] + +-- Used for 'arg_or_res' argument to illegalForeignTyErr +argument, result :: SDoc +argument = text "argument" +result = text "result" + +badCName :: CLabelString -> MsgDoc +badCName target + = sep [quotes (ppr target) <+> text "is not a valid C identifier"] + +foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc +foreignDeclCtxt fo + = hang (text "When checking declaration:") + 2 (ppr fo) diff --git a/GHC/Tc/Gen/HsType.hs b/GHC/Tc/Gen/HsType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/HsType.hs @@ -0,0 +1,3927 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typechecking user-specified @MonoTypes@ +module GHC.Tc.Gen.HsType ( + -- Type signatures + kcClassSigType, tcClassSigType, + tcHsSigType, tcHsSigWcType, + tcHsPartialSigType, + tcStandaloneKindSig, + funsSigCtxt, addSigCtxt, pprSigCtxt, + + tcHsClsInstType, + tcHsDeriv, tcDerivStrategy, + tcHsTypeApp, + UserTypeCtxt(..), + bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, + bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, + bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, + ContextKind(..), + + -- Type checking type and class decls, and instances thereof + bindTyClTyVars, tcFamTyPats, + etaExpandAlgTyCon, tcbVisibilities, + + -- tyvars + zonkAndScopedSort, + + -- Kind-checking types + -- No kind generalisation, no checkValidType + InitialKindStrategy(..), + SAKS_or_CUSK(..), + kcDeclHeader, + tcNamedWildCardBinders, + tcHsLiftedType, tcHsOpenType, + tcHsLiftedTypeNC, tcHsOpenTypeNC, + tcInferLHsTypeKind, tcInferLHsType, tcInferLHsTypeUnsaturated, + tcCheckLHsType, + tcHsMbContext, tcHsContext, tcLHsPredType, + failIfEmitsConstraints, + solveEqualities, -- useful re-export + + kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, + + -- Sort-checking kinds + tcLHsKindSig, checkDataKindSig, DataSort(..), + checkClassKindSig, + + -- Multiplicity + tcMult, + + -- Pattern type signatures + tcHsPatSigType, + + -- Error messages + funAppCtxt, addTyConFlavCtxt + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Instantiate( tcInstInvisibleTyBinders ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity +import GHC.Tc.Utils.Unify +import GHC.IfaceToCore +import GHC.Tc.Solver +import GHC.Tc.Utils.Zonk +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Errors ( reportAllUnsolved ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBindersN, tcInstInvisibleTyBinder ) +import GHC.Core.Type +import GHC.Builtin.Types.Prim +import GHC.Types.Name.Env +import GHC.Types.Name.Reader( lookupLocalRdrOcc ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Types.Name +-- import GHC.Types.Name.Set +import GHC.Types.Var.Env +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Settings.Constants ( mAX_CTUPLE_SIZE ) +import GHC.Utils.Error( MsgDoc ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Misc +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Builtin.Names hiding ( wildCardName ) +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt +import GHC.Parser.Annotation + +import GHC.Data.Maybe +import GHC.Data.Bag( unitBag ) +import Data.List ( find ) +import Control.Monad + +{- + ---------------------------- + General notes + ---------------------------- + +Unlike with expressions, type-checking types both does some checking and +desugars at the same time. This is necessary because we often want to perform +equality checks on the types right away, and it would be incredibly painful +to do this on un-desugared types. Luckily, desugared types are close enough +to HsTypes to make the error messages sane. + +During type-checking, we perform as little validity checking as possible. +Generally, after type-checking, you will want to do validity checking, say +with GHC.Tc.Validity.checkValidType. + +Validity checking +~~~~~~~~~~~~~~~~~ +Some of the validity check could in principle be done by the kind checker, +but not all: + +- During desugaring, we normalise by expanding type synonyms. Only + after this step can we check things like type-synonym saturation + e.g. type T k = k Int + type S a = a + Then (T S) is ok, because T is saturated; (T S) expands to (S Int); + and then S is saturated. This is a GHC extension. + +- Similarly, also a GHC extension, we look through synonyms before complaining + about the form of a class or instance declaration + +- Ambiguity checks involve functional dependencies + +Also, in a mutually recursive group of types, we can't look at the TyCon until we've +finished building the loop. So to keep things simple, we postpone most validity +checking until step (3). + +%************************************************************************ +%* * + Check types AND do validity checking +* * +************************************************************************ + +Note [Keeping implicitly quantified variables in order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user implicitly quantifies over variables (say, in a type +signature), we need to come up with some ordering on these variables. +This is done by bumping the TcLevel, bringing the tyvars into scope, +and then type-checking the thing_inside. The constraints are all +wrapped in an implication, which is then solved. Finally, we can +zonk all the binders and then order them with scopedSort. + +It's critical to solve before zonking and ordering in order to uncover +any unifications. You might worry that this eager solving could cause +trouble elsewhere. I don't think it will. Because it will solve only +in an increased TcLevel, it can't unify anything that was mentioned +elsewhere. Additionally, we require that the order of implicitly +quantified variables is manifest by the scope of these variables, so +we're not going to learn more information later that will help order +these variables. + +Note [Recipe for checking a signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Checking a user-written signature requires several steps: + + 1. Generate constraints. + 2. Solve constraints. + 3. Promote tyvars and/or kind-generalize. + 4. Zonk. + 5. Check validity. + +There may be some surprises in here: + +Step 2 is necessary for two reasons: most signatures also bring +implicitly quantified variables into scope, and solving is necessary +to get these in the right order (see Note [Keeping implicitly +quantified variables in order]). Additionally, solving is necessary in +order to kind-generalize correctly: otherwise, we do not know which +metavariables are left unsolved. + +Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to +kindGeneralize{All,Some,None}. Here, we have to deal with the fact that +metatyvars generated in the type may have a bumped TcLevel, because explicit +foralls raise the TcLevel. To avoid these variables from ever being visible in +the surrounding context, we must obey the following dictum: + + Every metavariable in a type must either be + (A) generalized, or + (B) promoted, or See Note [Promotion in signatures] + (C) a cause to error See Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType + +The kindGeneralize functions do not require pre-zonking; they zonk as they +go. + +If you are actually doing kind-generalization, you need to bump the level +before generating constraints, as we will only generalize variables with +a TcLevel higher than the ambient one. + +After promoting/generalizing, we need to zonk again because both +promoting and generalizing fill in metavariables. + +Note [Promotion in signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If an unsolved metavariable in a signature is not generalized +(because we're not generalizing the construct -- e.g., pattern +sig -- or because the metavars are constrained -- see kindGeneralizeSome) +we need to promote to maintain (WantedTvInv) of Note [TcLevel and untouchable type variables] +in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing +and the reinstantiating with a fresh metavariable at the current level. +So in some sense, we generalize *all* variables, but then re-instantiate +some of them. + +Here is an example of why we must promote: + foo (x :: forall a. a -> Proxy b) = ... + +In the pattern signature, `b` is unbound, and will thus be brought into +scope. We do not know its kind: it will be assigned kappa[2]. Note that +kappa is at TcLevel 2, because it is invented under a forall. (A priori, +the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel +than the surrounding context.) This kappa cannot be solved for while checking +the pattern signature (which is not kind-generalized). When we are checking +the *body* of foo, though, we need to unify the type of x with the argument +type of bar. At this point, the ambient TcLevel is 1, and spotting a +matavariable with level 2 would violate the (WantedTvInv) invariant of +Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing, +we promote the metavariable to level 1. This is all done in kindGeneralizeNone. + +-} + +funsSigCtxt :: [Located Name] -> UserTypeCtxt +-- Returns FunSigCtxt, with no redundant-context-reporting, +-- form a list of located names +funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False +funsSigCtxt [] = panic "funSigCtxt" + +addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a +addSigCtxt ctxt hs_ty thing_inside + = setSrcSpan (getLoc hs_ty) $ + addErrCtxt (pprSigCtxt ctxt hs_ty) $ + thing_inside + +pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc +-- (pprSigCtxt ctxt ) +-- prints In the type signature for 'f': +-- f :: +-- The is either empty or "the ambiguity check for" +pprSigCtxt ctxt hs_ty + | Just n <- isSigMaybe ctxt + = hang (text "In the type signature:") + 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) + + | otherwise + = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) + 2 (ppr hs_ty) + +tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type +-- This one is used when we have a LHsSigWcType, but in +-- a place where wildcards aren't allowed. The renamer has +-- already checked this, so we can simply ignore it. +tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) + +kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () +-- This is a special form of tcClassSigType that is used during the +-- kind-checking phase to infer the kind of class variables. Cf. tc_hs_sig_type. +-- Importantly, this does *not* kind-generalize. Consider +-- class SC f where +-- meth :: forall a (x :: f a). Proxy x -> () +-- When instantiating Proxy with kappa, we must unify kappa := f a. But we're +-- still working out the kind of f, and thus f a will have a coercion in it. +-- Coercions block unification (Note [Equalities with incompatible kinds] in +-- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll +-- end up promoting kappa to the top level (because kind-generalization is +-- normally done right before adding a binding to the context), and then we +-- can't set kappa := f a, because a is local. +kcClassSigType skol_info names (HsIB { hsib_ext = sig_vars + , hsib_body = hs_ty }) + = addSigCtxt (funsSigCtxt names) hs_ty $ + do { (tc_lvl, (wanted, (spec_tkvs, _))) + <- pushTcLevelM $ + solveLocalEqualitiesX "kcClassSigType" $ + bindImplicitTKBndrs_Skol sig_vars $ + tcLHsType hs_ty liftedTypeKind + + ; emitResidualTvConstraint skol_info spec_tkvs tc_lvl wanted } + +tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type +-- Does not do validity checking +tcClassSigType skol_info names sig_ty + = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ + do { (implic, ty) <- tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + ; emitImplication implic + ; return ty } + -- Do not zonk-to-Type, nor perform a validity check + -- We are in a knot with the class and associated types + -- Zonking and validity checking is done by tcClassDecl + -- + -- No need to fail here if the type has an error: + -- If we're in the kind-checking phase, the solveEqualities + -- in kcTyClGroup catches the error + -- If we're in the type-checking phase, the solveEqualities + -- in tcClassDecl1 gets it + -- Failing fast here degrades the error message in, e.g., tcfail135: + -- class Foo f where + -- baa :: f a -> f + -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. + -- It should be that f has kind `k2 -> *`, but we never get a chance + -- to run the solver where the kind of f is touchable. This is + -- painfully delicate. + +tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +-- Does validity checking +-- See Note [Recipe for checking a signature] +tcHsSigType ctxt sig_ty + = addSigCtxt ctxt (hsSigType sig_ty) $ + do { traceTc "tcHsSigType {" (ppr sig_ty) + + -- Generalise here: see Note [Kind generalisation] + ; (implic, ty) <- tc_hs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) + + -- Spit out the implication (and perhaps fail fast) + -- See Note [Failure in local type signatures] in GHC.Tc.Solver + ; emitFlatConstraints (mkImplicWC (unitBag implic)) + + ; ty <- zonkTcType ty + ; checkValidType ctxt ty + ; traceTc "end tcHsSigType }" (ppr ty) + ; return ty } + where + skol_info = SigTypeSkol ctxt + +tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn + -> ContextKind -> TcM (Implication, TcType) +-- Kind-checks/desugars an 'LHsSigType', +-- solve equalities, +-- and then kind-generalizes. +-- This will never emit constraints, as it uses solveEqualities internally. +-- No validity checking or zonking +-- Returns also an implication for the unsolved constraints +tc_hs_sig_type skol_info hs_sig_type ctxt_kind + | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type + = do { (tc_lvl, (wanted, (spec_tkvs, ty))) + <- pushTcLevelM $ + solveLocalEqualitiesX "tc_hs_sig_type" $ + -- See Note [Failure in local type signatures] + bindImplicitTKBndrs_Skol sig_vars $ + do { kind <- newExpectedKind ctxt_kind + ; tcLHsType hs_ty kind } + -- Any remaining variables (unsolved in the solveLocalEqualities) + -- should be in the global tyvars, and therefore won't be quantified + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + ; let ty1 = mkSpecForAllTys spec_tkvs ty + + -- This bit is very much like decideMonoTyVars in GHC.Tc.Solver, + -- but constraints are so much simpler in kinds, it is much + -- easier here. (In particular, we never quantify over a + -- constraint in a type.) + ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) + ; let should_gen = not . (`elemVarSet` constrained) + + ; kvs <- kindGeneralizeSome should_gen ty1 + + -- Build an implication for any as-yet-unsolved kind equalities + -- See Note [Skolem escape in type signatures] + ; implic <- buildTvImplication skol_info (kvs ++ spec_tkvs) tc_lvl wanted + + ; return (implic, mkInfForAllTys kvs ty1) } + +{- Note [Skolem escape in type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcHsSigType is tricky. Consider (T11142) + foo :: forall b. (forall k (a :: k). SameKind a b) -> () +This is ill-kinded becuase of a nested skolem-escape. + +That will show up as an un-solvable constraint in the implication +returned by buildTvImplication in tc_hs_sig_type. See Note [Skolem +escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable +(the unification variable for b's kind is untouchable). + +Then, in GHC.Tc.Solver.emitFlatConstraints (called from tcHsSigType) +we'll try to float out the constraint, be unable to do so, and fail. +See GHC.Tc.Solver Note [Failure in local type signatures] for more +detail on this. + +The separation between tcHsSigType and tc_hs_sig_type is because +tcClassSigType wants to use the latter, but *not* fail fast, because +there are skolems from the class decl which are in scope; but it's fine +not to because tcClassDecl1 has a solveEqualities wrapped around all +the tcClassSigType calls. + +That's why tcHsSigType does emitFlatConstraints (which fails fast) but +tcClassSigType just does emitImplication (which does not). Ugh. + +c.f. see also Note [Skolem escape and forall-types]. The difference +is that we don't need to simplify at a forall type, only at the +top level of a signature. +-} + +-- Does validity checking and zonking. +tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) +tcStandaloneKindSig (L _ kisig) = case kisig of + StandaloneKindSig _ (L _ name) ksig -> + let ctxt = StandaloneKindSigCtxt name in + addSigCtxt ctxt (hsSigType ksig) $ + do { let mode = mkMode KindLevel + ; kind <- tc_top_lhs_type mode ksig (expectedKindInCtxt ctxt) + ; checkValidType ctxt kind + ; return (name, kind) } + + +tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type +tcTopLHsType hs_ty ctxt_kind + = tc_top_lhs_type (mkMode TypeLevel) hs_ty ctxt_kind + +tc_top_lhs_type :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type +-- tcTopLHsType is used for kind-checking top-level HsType where +-- we want to fully solve /all/ equalities, and report errors +-- Does zonking, but not validity checking because it's used +-- for things (like deriving and instances) that aren't +-- ordinary types +-- Used for both types and kinds +tc_top_lhs_type mode hs_sig_type ctxt_kind + | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type + = do { traceTc "tcTopLHsType {" (ppr hs_ty) + ; (spec_tkvs, ty) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Skol sig_vars $ + do { kind <- newExpectedKind ctxt_kind + ; tc_lhs_type mode hs_ty kind } + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + ; let ty1 = mkSpecForAllTys spec_tkvs ty + ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type + ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) + ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) + ; return final_ty} + +----------------- +tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) +-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause +-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments +-- E.g. class C (a::*) (b::k->k) +-- data T a b = ... deriving( C Int ) +-- returns ([k], C, [k, Int], [k->k]) +-- Return values are fully zonked +tcHsDeriv hs_ty + = do { ty <- checkNoErrs $ -- Avoid redundant error report + -- with "illegal deriving", below + tcTopLHsType hs_ty AnyKind + ; let (tvs, pred) = splitForAllTys ty + (kind_args, _) = splitFunTys (tcTypeKind pred) + ; case getClassPredTys_maybe pred of + Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) + Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } + +-- | Typecheck a deriving strategy. For most deriving strategies, this is a +-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. +tcDerivStrategy :: + Maybe (LDerivStrategy GhcRn) + -- ^ The deriving strategy + -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]) + -- ^ The typechecked deriving strategy and the tyvars that it binds + -- (if using 'ViaStrategy'). +tcDerivStrategy mb_lds + = case mb_lds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpan loc $ do + (ds', tvs) <- tc_deriv_strategy ds + pure (Just (L loc ds'), tvs) + where + tc_deriv_strategy :: DerivStrategy GhcRn + -> TcM (DerivStrategy GhcTc, [TyVar]) + tc_deriv_strategy StockStrategy = boring_case StockStrategy + tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy + tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy + tc_deriv_strategy (ViaStrategy ty) = do + ty' <- checkNoErrs $ tcTopLHsType ty AnyKind + let (via_tvs, via_pred) = splitForAllTys ty' + pure (ViaStrategy via_pred, via_tvs) + + boring_case :: ds -> TcM (ds, [TyVar]) + boring_case ds = pure (ds, []) + +tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt + -> LHsSigType GhcRn + -> TcM Type +-- Like tcHsSigType, but for a class instance declaration +tcHsClsInstType user_ctxt hs_inst_ty + = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $ + do { -- Fail eagerly if tcTopLHsType fails. We are at top level so + -- these constraints will never be solved later. And failing + -- eagerly avoids follow-on errors when checkValidInstance + -- sees an unsolved coercion hole + inst_ty <- checkNoErrs $ + tcTopLHsType hs_inst_ty (TheKind constraintKind) + ; checkValidInstance user_ctxt hs_inst_ty inst_ty + ; return inst_ty } + +---------------------------------------------- +-- | Type-check a visible type application +tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcHsTypeApp wc_ty kind + | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty + = do { mode <- mkHoleMode TypeLevel HM_VTA + -- HM_VTA: See Note [Wildcards in visible type application] + ; ty <- addTypeCtxt hs_ty $ + solveLocalEqualities "tcHsTypeApp" $ + -- We are looking at a user-written type, very like a + -- signature so we want to solve its equalities right now + tcNamedWildCardBinders sig_wcs $ \ _ -> + tc_lhs_type mode hs_ty kind + + -- We do not kind-generalize type applications: we just + -- instantiate with exactly what the user says. + -- See Note [No generalization in type application] + -- We still must call kindGeneralizeNone, though, according + -- to Note [Recipe for checking a signature] + ; kindGeneralizeNone ty + ; ty <- zonkTcType ty + ; checkValidType TypeAppCtxt ty + ; return ty } + +{- Note [Wildcards in visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so +any unnamed wildcards stay unchanged in hswc_body. When called in +tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole +on these anonymous wildcards. However, this would trigger +error/warning when an anonymous wildcard is passed in as a visible type +argument, which we do not want because users should be able to write +@_ to skip a instantiating a type variable variable without fuss. The +solution is to switch the PartialTypeSignatures flags here to let the +typechecker know that it's checking a '@_' and do not emit hole +constraints on it. See related Note [Wildcards in visible kind +application] and Note [The wildcard story for types] in GHC.Hs.Type + +Ugh! + +Note [No generalization in type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not kind-generalize type applications. Imagine + + id @(Proxy Nothing) + +If we kind-generalized, we would get + + id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) + +which is very sneakily impredicative instantiation. + +There is also the possibility of mentioning a wildcard +(`id @(Proxy _)`), which definitely should not be kind-generalized. + +-} + +tcFamTyPats :: TyCon + -> HsTyPats GhcRn -- Patterns + -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) +-- Check the LHS of a type/data family instance +-- e.g. type instance F ty1 .. tyn = ... +-- Used for both type and data families +tcFamTyPats fam_tc hs_pats + = do { traceTc "tcFamTyPats {" $ + vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] + + ; mode <- mkHoleMode TypeLevel HM_FamPat + -- HM_FamPat: See Note [Wildcards in family instances] in + -- GHC.Rename.Module + ; let fun_ty = mkTyConApp fam_tc [] + ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats + + -- Hack alert: see Note [tcFamTyPats: zonking the result kind] + ; res_kind <- zonkTcType res_kind + + ; traceTc "End tcFamTyPats }" $ + vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] + + ; return (fam_app, res_kind) } + where + fam_name = tyConName fam_tc + fam_arity = tyConArity fam_tc + lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) + +{- Note [tcFamTyPats: zonking the result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#19250) + F :: forall k. k -> k + type instance F (x :: Constraint) = () + +The tricky point is this: + is that () an empty type tuple (() :: Type), or + an empty constraint tuple (() :: Constraint)? +We work this out in a hacky way, by looking at the expected kind: +see Note [Inferring tuple kinds]. + +In this case, we kind-check the RHS using the kind gotten from the LHS: +see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl. + +But we want the kind from the LHS to be /zonked/, so that when +kind-checking the RHS (tcCheckLHsType) we can "see" what we learned +from kind-checking the LHS (tcFamTyPats). In our example above, the +type of the LHS is just `kappa` (by instantiating the forall k), but +then we learn (from x::Constraint) that kappa ~ Constraint. We want +that info when kind-checking the RHS. + +Easy solution: just zonk that return kind. Of course this won't help +if there is lots of type-family reduction to do, but it works fine in +common cases. +-} + + +{- +************************************************************************ +* * + The main kind checker: no validity checks here +* * +************************************************************************ +-} + +--------------------------- +tcHsOpenType, tcHsLiftedType, + tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsOpenType hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty +tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty + +tcHsOpenTypeNC hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek } +tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind + +-- Like tcHsType, but takes an expected kind +tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType +tcCheckLHsType hs_ty exp_kind + = addTypeCtxt hs_ty $ + do { ek <- newExpectedKind exp_kind + ; tcLHsType hs_ty ek } + +tcInferLHsType :: LHsType GhcRn -> TcM TcType +tcInferLHsType hs_ty + = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty + ; return ty } + +tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind) +-- Called from outside: set the context +-- Eagerly instantiate any trailing invisible binders +tcInferLHsTypeKind lhs_ty@(L loc hs_ty) + = addTypeCtxt lhs_ty $ + setSrcSpan loc $ -- Cover the tcInstInvisibleTyBinders + do { (res_ty, res_kind) <- tc_infer_hs_type (mkMode TypeLevel) hs_ty + ; tcInstInvisibleTyBinders res_ty res_kind } + -- See Note [Do not always instantiate eagerly in types] + +-- Used to check the argument of GHCi :kind +-- Allow and report wildcards, e.g. :kind T _ +-- Do not saturate family applications: see Note [Dealing with :kind] +-- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types] +tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) +tcInferLHsTypeUnsaturated hs_ty + = addTypeCtxt hs_ty $ + do { mode <- mkHoleMode TypeLevel HM_Sig -- Allow and report holes + ; case splitHsAppTys (unLoc hs_ty) of + Just (hs_fun_ty, hs_args) + -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty + ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args } + -- Notice the 'nosat'; do not instantiate trailing + -- invisible arguments of a type family. + -- See Note [Dealing with :kind] + Nothing -> tc_infer_lhs_type mode hs_ty } + +{- Note [Dealing with :kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi command + ghci> type family F :: Either j k + ghci> :kind F + F :: forall {j,k}. Either j k + +We will only get the 'forall' if we /refrain/ from saturating those +invisible binders. But generally we /do/ saturate those invisible +binders (see tcInferTyApps), and we want to do so for nested application +even in GHCi. Consider for example (#16287) + ghci> type family F :: k + ghci> data T :: (forall k. k) -> Type + ghci> :kind T F +We want to reject this. It's just at the very top level that we want +to switch off saturation. + +So tcInferLHsTypeUnsaturated does a little special case for top level +applications. Actually the common case is a bare variable, as above. + +Note [Do not always instantiate eagerly in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Terms are eagerly instantiated. This means that if you say + + x = id + +then `id` gets instantiated to have type alpha -> alpha. The variable +alpha is then unconstrained and regeneralized. But we cannot do this +in types, as we have no type-level lambda. So, when we are sure +that we will not want to regeneralize later -- because we are done +checking a type, for example -- we can instantiate. But we do not +instantiate at variables, nor do we in tcInferLHsTypeUnsaturated, +which is used by :kind in GHCi. + +************************************************************************ +* * + Type-checking modes +* * +************************************************************************ + +The kind-checker is parameterised by a TcTyMode, which contains some +information about where we're checking a type. + +The renamer issues errors about what it can. All errors issued here must +concern things that the renamer can't handle. + +-} + +tcMult :: HsArrow GhcRn -> TcM Mult +tcMult hc = tc_mult (mkMode TypeLevel) hc + +-- | Info about the context in which we're checking a type. Currently, +-- differentiates only between types and kinds, but this will likely +-- grow, at least to include the distinction between patterns and +-- not-patterns. +-- +-- To find out where the mode is used, search for 'mode_tyki' +-- +-- This data type is purely local, not exported from this module +data TcTyMode + = TcTyMode { mode_tyki :: TypeOrKind + + -- See Note [Levels for wildcards] + -- Nothing <=> no wildcards expected + , mode_holes :: Maybe (TcLevel, HoleMode) + } + +-- HoleMode says how to treat the occurrences +-- of anonymous wildcards; see tcAnonWildCardOcc +data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int + | HM_FamPat -- Family instances: F _ Int = Bool + | HM_VTA -- Visible type and kind application: + -- f @(Maybe _) + -- Maybe @(_ -> _) + +mkMode :: TypeOrKind -> TcTyMode +mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing } + +mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode +mkHoleMode tyki hm + = do { lvl <- getTcLevel + ; return (TcTyMode { mode_tyki = tyki + , mode_holes = Just (lvl,hm) }) } + +kindLevel :: TcTyMode -> TcTyMode +kindLevel mode = mode { mode_tyki = KindLevel } + +instance Outputable HoleMode where + ppr HM_Sig = text "HM_Sig" + ppr HM_FamPat = text "HM_FamPat" + ppr HM_VTA = text "HM_VTA" + +instance Outputable TcTyMode where + ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm }) + = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma + , ppr hm ]) + +{- +Note [Bidirectional type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In expressions, whenever we see a polymorphic identifier, say `id`, we are +free to instantiate it with metavariables, knowing that we can always +re-generalize with type-lambdas when necessary. For example: + + rank2 :: (forall a. a -> a) -> () + x = rank2 id + +When checking the body of `x`, we can instantiate `id` with a metavariable. +Then, when we're checking the application of `rank2`, we notice that we really +need a polymorphic `id`, and then re-generalize over the unconstrained +metavariable. + +In types, however, we're not so lucky, because *we cannot re-generalize*! +There is no lambda. So, we must be careful only to instantiate at the last +possible moment, when we're sure we're never going to want the lost polymorphism +again. This is done in calls to tcInstInvisibleTyBinders. + +To implement this behavior, we use bidirectional type checking, where we +explicitly think about whether we know the kind of the type we're checking +or not. Note that there is a difference between not knowing a kind and +knowing a metavariable kind: the metavariables are TauTvs, and cannot become +forall-quantified kinds. Previously (before dependent types), there were +no higher-rank kinds, and so we could instantiate early and be sure that +no types would have polymorphic kinds, and so we could always assume that +the kind of a type was a fresh metavariable. Not so anymore, thus the +need for two algorithms. + +For HsType forms that can never be kind-polymorphic, we implement only the +"down" direction, where we safely assume a metavariable kind. For HsType forms +that *can* be kind-polymorphic, we implement just the "up" (functions with +"infer" in their name) version, as we gain nothing by also implementing the +"down" version. + +Note [Future-proofing the type checker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As discussed in Note [Bidirectional type checking], each HsType form is +handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions +are mutually recursive, so that either one can work for any type former. +But, we want to make sure that our pattern-matches are complete. So, +we have a bunch of repetitive code just so that we get warnings if we're +missing any patterns. + +-} + +------------------------------------------ +-- | Check and desugar a type, returning the core type and its +-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression +-- level. +tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +tc_infer_lhs_type mode (L span ty) + = setSrcSpan span $ + tc_infer_hs_type mode ty + +--------------------------- +-- | Call 'tc_infer_hs_type' and check its result against an expected kind. +tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType +tc_infer_hs_type_ek mode hs_ty ek + = do { (ty, k) <- tc_infer_hs_type mode hs_ty + ; checkExpectedKind hs_ty ty k ek } + +--------------------------- +-- | Infer the kind of a type and desugar. This is the "up" type-checker, +-- as described in Note [Bidirectional type checking] +tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) + +tc_infer_hs_type mode (HsParTy _ t) + = tc_infer_lhs_type mode t + +tc_infer_hs_type mode ty + | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty + = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty + ; tcInferTyApps mode hs_fun_ty fun_ty hs_args } + +tc_infer_hs_type mode (HsKindSig _ ty sig) + = do { let mode' = mode { mode_tyki = KindLevel } + ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig + -- We must typecheck the kind signature, and solve all + -- its equalities etc; from this point on we may do + -- things like instantiate its foralls, so it needs + -- to be fully determined (#14904) + ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig') + ; ty' <- tc_lhs_type mode ty sig' + ; return (ty', sig') } + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate +-- the splice location to the typechecker. Here we skip over it in order to have +-- the same kind inferred for a given expression whether it was produced from +-- splices or not. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) + = tc_infer_hs_type mode ty + +tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty + +-- See Note [Typechecking NHsCoreTys] +tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) + = do env <- getLclEnv + -- Raw uniques since we go from NameEnv to TvSubstEnv. + let subst_prs :: [(Unique, TcTyVar)] + subst_prs = [ (getUnique nm, tv) + | ATyVar nm tv <- nameEnvElts (tcl_env env) ] + subst = mkTvSubst + (mkInScopeSet $ mkVarSet $ map snd subst_prs) + (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs) + ty' = substTy subst ty + return (ty', tcTypeKind ty') + +tc_infer_hs_type _ (HsExplicitListTy _ _ tys) + | null tys -- this is so that we can use visible kind application with '[] + -- e.g ... '[] @Bool + = return (mkTyConTy promotedNilDataCon, + mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) + +tc_infer_hs_type mode other_ty + = do { kv <- newMetaKindVar + ; ty' <- tc_hs_type mode other_ty kv + ; return (ty', kv) } + +{- +Note [Typechecking NHsCoreTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NHsCoreTy is an escape hatch that allows embedding Core Types in HsTypes. +As such, there's not much to be done in order to typecheck an NHsCoreTy, +since it's already been typechecked to some extent. There is one thing that +we must do, however: we must substitute the type variables from the tcl_env. +To see why, consider GeneralizedNewtypeDeriving, which is one of the main +clients of NHsCoreTy (example adapted from #14579): + + newtype T a = MkT a deriving newtype Eq + +This will produce an InstInfo GhcPs that looks roughly like this: + + instance forall a_1. Eq a_1 => Eq (T a_1) where + (==) = coerce @( a_1 -> a_1 -> Bool) -- The type within @(...) is an NHsCoreTy + @(T a_1 -> T a_1 -> Bool) -- So is this + (==) + +This is then fed into the renamer. Since all of the type variables in this +InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically +identical. Things get more interesting when the InstInfo is fed into the +typechecker, however. GHC will first generate fresh skolems to instantiate +the instance-bound type variables with. In the example above, we might generate +the skolem a_2 and use that to instantiate a_1, which extends the local type +environment (tcl_env) with [a_1 :-> a_2]. This gives us: + + instance forall a_2. Eq a_2 => Eq (T a_2) where ... + +To ensure that the body of this instance is well scoped, every occurrence of +the `a` type variable should refer to a_2, the new skolem. However, the +NHsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the +substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this +substitution to each NHsCoreTy and all is well: + + instance forall a_2. Eq a_2 => Eq (T a_2) where + (==) = coerce @( a_2 -> a_2 -> Bool) + @(T a_2 -> T a_2 -> Bool) + (==) +-} + +------------------------------------------ +tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType +tcLHsType hs_ty exp_kind + = tc_lhs_type (mkMode TypeLevel) hs_ty exp_kind + +tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType +tc_lhs_type mode (L span ty) exp_kind + = setSrcSpan span $ + tc_hs_type mode ty exp_kind + +tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType +-- See Note [Bidirectional type checking] + +tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type _ ty@(HsBangTy _ bang _) _ + -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), + -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of + -- bangs are invalid, so fail. (#7210, #14761) + = do { let bangError err = failWith $ + text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ + text err <+> text "annotation cannot appear nested inside a type" + ; case bang of + HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" + HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" + HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" + HsSrcBang _ _ _ -> bangError "strictness" } +tc_hs_type _ ty@(HsRecTy {}) _ + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. +-- Here we get rid of it and add the finalizers to the global environment +-- while capturing the local environment. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) + exp_kind + = do addModFinalizersWithLclEnv mod_finalizers + tc_hs_type mode ty exp_kind + +-- This should never happen; type splices are expanded by the renamer +tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind + = failWithTc (text "Unexpected type splice:" <+> ppr ty) + +---------- Functions and applications +tc_hs_type mode ty@(HsFunTy _ mult ty1 ty2) exp_kind + | mode_tyki mode == KindLevel && not (isUnrestricted mult) + = failWithTc (text "Linear arrows disallowed in kinds:" <+> ppr ty) + | otherwise + = tc_fun_type mode mult ty1 ty2 exp_kind + +tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind + | op `hasKey` funTyConKey + = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind + +--------- Foralls +tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind + = do { (tclvl, wanted, (tv_bndrs, ty')) + <- pushLevelAndCaptureConstraints $ + bindExplicitTKTele_Skol_M mode tele $ + -- The _M variant passes on the mode from the type, to + -- any wildards in kind signatures on the forall'd variables + -- e.g. f :: _ -> Int -> forall (a :: _). blah + tc_lhs_type mode ty exp_kind + -- Why exp_kind? See Note [Body kind of HsForAllTy] + + -- Do not kind-generalise here! See Note [Kind generalisation] + + ; let skol_info = ForAllSkol (ppr forall) $ sep $ case tele of + HsForAllVis { hsf_vis_bndrs = hs_tvs } -> + map ppr hs_tvs + HsForAllInvis { hsf_invis_bndrs = hs_tvs } -> + map ppr hs_tvs + tv_bndrs' = construct_bndrs tv_bndrs + skol_tvs = binderVars tv_bndrs' + ; implic <- buildTvImplication skol_info skol_tvs tclvl wanted + ; emitImplication implic + -- /Always/ emit this implication even if wanted is empty + -- We need the implication so that we check for a bad telescope + -- See Note [Skolem escape and forall-types] + + ; return (mkForAllTys tv_bndrs' ty') } + where + construct_bndrs :: Either [TcReqTVBinder] [TcInvisTVBinder] + -> [TcTyVarBinder] + construct_bndrs (Left req_tv_bndrs) = + map (mkTyVarBinder Required . binderVar) req_tv_bndrs + construct_bndrs (Right inv_tv_bndrs) = + map tyVarSpecToBinder inv_tv_bndrs + +tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind + | null (unLoc ctxt) + = tc_lhs_type mode rn_ty exp_kind + + -- See Note [Body kind of a HsQualTy] + | tcIsConstraintKind exp_kind + = do { ctxt' <- tc_hs_context mode ctxt + ; ty' <- tc_lhs_type mode rn_ty constraintKind + ; return (mkPhiTy ctxt' ty') } + + | otherwise + = do { ctxt' <- tc_hs_context mode ctxt + + ; ek <- newOpenTypeKind -- The body kind (result of the function) can + -- be TYPE r, for any r, hence newOpenTypeKind + ; ty' <- tc_lhs_type mode rn_ty ek + ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') + liftedTypeKind exp_kind } + +--------- Lists, arrays, and tuples +tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind + ; checkWiredInTyCon listTyCon + ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } + +-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type +-- See Note [Inferring tuple kinds] +tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind + -- (NB: not zonking before looking at exp_k, to avoid left-right bias) + | Just tup_sort <- tupKindSort_maybe exp_kind + = traceTc "tc_hs_type tuple" (ppr hs_tys) >> + tc_tuple rn_ty mode tup_sort hs_tys exp_kind + | otherwise + = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) + ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys + ; kinds <- mapM zonkTcType kinds + -- Infer each arg type separately, because errors can be + -- confusing if we give them a shared kind. Eg #7410 + -- (Either Int, Int), we do not want to get an error saying + -- "the second argument of a tuple should have kind *->*" + + ; let (arg_kind, tup_sort) + = case [ (k,s) | k <- kinds + , Just s <- [tupKindSort_maybe k] ] of + ((k,s) : _) -> (k,s) + [] -> (liftedTypeKind, BoxedTuple) + -- In the [] case, it's not clear what the kind is, so guess * + + ; tys' <- sequence [ setSrcSpan loc $ + checkExpectedKind hs_ty ty kind arg_kind + | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] + + ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } + + +tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind + = tc_tuple rn_ty mode tup_sort tys exp_kind + where + tup_sort = case hs_tup_sort of -- Fourth case dealt with above + HsUnboxedTuple -> UnboxedTuple + HsBoxedTuple -> BoxedTuple + HsConstraintTuple -> ConstraintTuple + _ -> panic "tc_hs_type HsTupleTy" + +tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind + = do { let arity = length hs_tys + ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys + ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds + ; let arg_reps = map kindRep arg_kinds + arg_tys = arg_reps ++ tau_tys + sum_ty = mkTyConApp (sumTyCon arity) arg_tys + sum_kind = unboxedSumKind arg_reps + ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind + } + +--------- Promoted lists and tuples +tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind + = do { tks <- mapM (tc_infer_lhs_type mode) tys + ; (taus', kind) <- unifyKinds tys tks + ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') + ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } + where + mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] + mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] + +tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind + -- using newMetaKindVar means that we force instantiations of any polykinded + -- types. At first, I just used tc_infer_lhs_type, but that led to #11255. + = do { ks <- replicateM arity newMetaKindVar + ; taus <- zipWithM (tc_lhs_type mode) tys ks + ; let kind_con = tupleTyCon Boxed arity + ty_con = promotedTupleDataCon Boxed arity + tup_k = mkTyConApp kind_con ks + ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } + where + arity = length tys + +--------- Constraint types +tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind + = do { MASSERT( isTypeLevel (mode_tyki mode) ) + ; ty' <- tc_lhs_type mode ty liftedTypeKind + ; let n' = mkStrLitTy $ hsIPNameFS n + ; ipClass <- tcLookupClass ipClassName + ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) + constraintKind exp_kind } + +tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind + -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to + -- handle it in 'coreView' and 'tcView'. + = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind + +--------- Literals +tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind + = do { checkWiredInTyCon typeNatKindCon + ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } + +tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind + = do { checkWiredInTyCon typeSymbolKindCon + ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } + +--------- Potentially kind-polymorphic types: call the "up" checker +-- See Note [Future-proofing the type checker] +tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsWildCardTy _) ek = tcAnonWildCardOcc mode ty ek + +{- +Note [Variable Specificity and Forall Visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall +binder. Furthermore, each invisible type variable binder also has a +Specificity. Together, these determine the variable binders (ArgFlag) for each +variable in the generated ForAllTy type. + +This table summarises this relation: +---------------------------------------------------------------------------- +| User-written type HsForAllTelescope Specificity ArgFlag +|--------------------------------------------------------------------------- +| f :: forall a. type HsForAllInvis SpecifiedSpec Specified +| f :: forall {a}. type HsForAllInvis InferredSpec Inferred +| f :: forall a -> type HsForAllVis SpecifiedSpec Required +| f :: forall {a} -> type HsForAllVis InferredSpec / +| This last form is non-sensical and is thus rejected. +---------------------------------------------------------------------------- + +For more information regarding the interpretation of the resulting ArgFlag, see +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". +-} + +------------------------------------------ +tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult +tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy +------------------------------------------ +tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind + -> TcM TcType +tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of + TypeLevel -> + do { arg_k <- newOpenTypeKind + ; res_k <- newOpenTypeKind + ; ty1' <- tc_lhs_type mode ty1 arg_k + ; ty2' <- tc_lhs_type mode ty2 res_k + ; mult' <- tc_mult mode mult + ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + KindLevel -> -- no representation polymorphism in kinds. yet. + do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind + ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind + ; mult' <- tc_mult mode mult + ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + +{- Note [Skolem escape and forall-types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Checking telescopes]. + +Consider + f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () + +The Proxy '[a,b] forces a and b to have the same kind. But a's +kind must be bound outside the 'forall a', and hence escapes. +We discover this by building an implication constraint for +each forall. So the inner implication constraint will look like + forall kb (b::kb). kb ~ ka +where ka is a's kind. We can't unify these two, /even/ if ka is +unification variable, because it would be untouchable inside +this inner implication. + +That's what the pushLevelAndCaptureConstraints, plus subsequent +buildTvImplication/emitImplication is all about, when kind-checking +HsForAllTy. + +Note that + +* We don't need to /simplify/ the constraints here + because we aren't generalising. We just capture them. + +* We can't use emitResidualTvConstraint, because that has a fast-path + for empty constraints. We can't take that fast path here, because + we must do the bad-telescope check even if there are no inner wanted + constraints. See Note [Checking telescopes] in + GHC.Tc.Types.Constraint. Lacking this check led to #16247. +-} + +{- ********************************************************************* +* * + Tuples +* * +********************************************************************* -} + +--------------------------- +tupKindSort_maybe :: TcKind -> Maybe TupleSort +tupKindSort_maybe k + | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' + | Just k' <- tcView k = tupKindSort_maybe k' + | tcIsConstraintKind k = Just ConstraintTuple + | tcIsLiftedTypeKind k = Just BoxedTuple + | otherwise = Nothing + +tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType +tc_tuple rn_ty mode tup_sort tys exp_kind + = do { arg_kinds <- case tup_sort of + BoxedTuple -> return (replicate arity liftedTypeKind) + UnboxedTuple -> replicateM arity newOpenTypeKind + ConstraintTuple -> return (replicate arity constraintKind) + ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds + ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } + where + arity = length tys + +finish_tuple :: HsType GhcRn + -> TupleSort + -> [TcType] -- ^ argument types + -> [TcKind] -- ^ of these kinds + -> TcKind -- ^ expected kind of the whole tuple + -> TcM TcType +finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do + traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) + case tup_sort of + ConstraintTuple + | [tau_ty] <- tau_tys + -- Drop any uses of 1-tuple constraints here. + -- See Note [Ignore unary constraint tuples] + -> check_expected_kind tau_ty constraintKind + | arity > mAX_CTUPLE_SIZE + -> failWith (bigConstraintTuple arity) + | otherwise + -> do tycon <- tcLookupTyCon (cTupleTyConName arity) + check_expected_kind (mkTyConApp tycon tau_tys) constraintKind + BoxedTuple -> do + let tycon = tupleTyCon Boxed arity + checkWiredInTyCon tycon + check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind + UnboxedTuple -> + let tycon = tupleTyCon Unboxed arity + tau_reps = map kindRep tau_kinds + -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + arg_tys = tau_reps ++ tau_tys + res_kind = unboxedTupleKind tau_reps in + check_expected_kind (mkTyConApp tycon arg_tys) res_kind + where + arity = length tau_tys + check_expected_kind ty act_kind = + checkExpectedKind rn_ty ty act_kind exp_kind + +bigConstraintTuple :: Arity -> MsgDoc +bigConstraintTuple arity + = hang (text "Constraint tuple arity too large:" <+> int arity + <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) + 2 (text "Instead, use a nested tuple") + +{- +Note [Ignore unary constraint tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in +GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First, +recall the definition of a unary tuple data type: + + data Solo a = Solo a + +Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and +lazy. Therefore, the presence of `Solo` matters semantically. On the other +hand, suppose we had a unary constraint tuple: + + class a => Solo% a + +This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is +semantically equivalent to `a`. Therefore, a 1-tuple constraint would have +no user-visible impact, nor would it allow you to express anything that +you couldn't otherwise. + +We could simply add Solo% for consistency with tuples (Solo) and unboxed +tuples (Solo#), but that would require even more magic to wire in another +magical class, so we opt not to do so. We must be careful, however, since +one can try to sneak in uses of unary constraint tuples through Template +Haskell, such as in this program (from #17511): + + f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] + (ConT ''String))) + -- f :: Solo% (Show Int) => String + f = "abc" + +This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, +and since it is used in a Constraint position, GHC will attempt to treat +it as thought it were a constraint tuple, which can potentially lead to +trouble if one attempts to look up the name of a constraint tuple of arity +1 (as it won't exist). To avoid this trouble, we simply take any unary +constraint tuples discovered when typechecking and drop them—i.e., treat +"Solo% a" as though the user had written "a". This is always safe to do +since the two constraints should be semantically equivalent. +-} + +{- ********************************************************************* +* * + Type applications +* * +********************************************************************* -} + +splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) +splitHsAppTys hs_ty + | is_app hs_ty = Just (go (noLoc hs_ty) []) + | otherwise = Nothing + where + is_app :: HsType GhcRn -> Bool + is_app (HsAppKindTy {}) = True + is_app (HsAppTy {}) = True + is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey) + -- I'm not sure why this funTyConKey test is necessary + -- Can it even happen? Perhaps for t1 `(->)` t2 + -- but then maybe it's ok to treat that like a normal + -- application rather than using the special rule for HsFunTy + is_app (HsTyVar {}) = True + is_app (HsParTy _ (L _ ty)) = is_app ty + is_app _ = False + + go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) + go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) + go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as) + go (L _ (HsOpTy _ l op@(L sp _) r)) as + = ( L sp (HsTyVar noExtField NotPromoted op) + , HsValArg l : HsValArg r : as ) + go f as = (f, as) + +--------------------------- +tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +-- Version of tc_infer_lhs_type specialised for the head of an +-- application. In particular, for a HsTyVar (which includes type +-- constructors, it does not zoom off into tcInferTyApps and family +-- saturation +tcInferTyAppHead mode (L _ (HsTyVar _ _ (L _ tv))) + = tcTyVar mode tv +tcInferTyAppHead mode ty + = tc_infer_lhs_type mode ty + +--------------------------- +-- | Apply a type of a given kind to a list of arguments. This instantiates +-- invisible parameters as necessary. Always consumes all the arguments, +-- using matchExpectedFunKind as necessary. +-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- +-- These kinds should be used to instantiate invisible kind variables; +-- they come from an enclosing class for an associated type/data family. +-- +-- tcInferTyApps also arranges to saturate any trailing invisible arguments +-- of a type-family application, which is usually the right thing to do +-- tcInferTyApps_nosat does not do this saturation; it is used only +-- by ":kind" in GHCi +tcInferTyApps, tcInferTyApps_nosat + :: TcTyMode + -> LHsType GhcRn -- ^ Function (for printing only) + -> TcType -- ^ Function + -> [LHsTypeArg GhcRn] -- ^ Args + -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) +tcInferTyApps mode hs_ty fun hs_args + = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args + ; saturateFamApp f_args res_k } + +tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args + = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) + ; (f_args, res_k) <- go_init 1 fun orig_hs_args + ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k) + ; return (f_args, res_k) } + where + + -- go_init just initialises the auxiliary + -- arguments of the 'go' loop + go_init n fun all_args + = go n fun empty_subst fun_ki all_args + where + fun_ki = tcTypeKind fun + -- We do (tcTypeKind fun) here, even though the caller + -- knows the function kind, to absolutely guarantee + -- INVARIANT for 'go' + -- Note that in a typical application (F t1 t2 t3), + -- the 'fun' is just a TyCon, so tcTypeKind is fast + + empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType fun_ki + + go :: Int -- The # of the next argument + -> TcType -- Function applied to some args + -> TCvSubst -- Applies to function kind + -> TcKind -- Function kind + -> [LHsTypeArg GhcRn] -- Un-type-checked args + -> TcM (TcType, TcKind) -- Result type and its kind + -- INVARIANT: in any call (go n fun subst fun_ki args) + -- tcTypeKind fun = subst(fun_ki) + -- So the 'subst' and 'fun_ki' arguments are simply + -- there to avoid repeatedly calling tcTypeKind. + -- + -- Reason for INVARIANT: to support the Purely Kinded Type Invariant + -- it's important that if fun_ki has a forall, then so does + -- (tcTypeKind fun), because the next thing we are going to do + -- is apply 'fun' to an argument type. + + -- Dispatch on all_args first, for performance reasons + go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of + + ---------------- No user-written args left. We're done! + ([], _) -> return (fun, substTy subst fun_ki) + + ---------------- HsArgPar: We don't care about parens here + (HsArgPar _ : args, _) -> go n fun subst fun_ki args + + ---------------- HsTypeArg: a kind application (fun @ki) + (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> + case ki_binder of + + -- FunTy with PredTy on LHS, or ForAllTy with Inferred + Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki + Anon InvisArg _ -> instantiate ki_binder inner_ki + + Named (Bndr _ Specified) -> -- Visible kind application + do { traceTc "tcInferTyApps (vis kind app)" + (vcat [ ppr ki_binder, ppr hs_ki_arg + , ppr (tyBinderType ki_binder) + , ppr subst ]) + + ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; arg_mode <- mkHoleMode KindLevel HM_VTA + -- HM_VKA: see Note [Wildcards in visible kind application] + ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ + tc_lhs_type arg_mode hs_ki_arg exp_kind + + ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg + ; go (n+1) fun' subst' inner_ki hs_args } + + -- Attempted visible kind application (fun @ki), but fun_ki is + -- forall k -> blah or k1 -> k2 + -- So we need a normal application. Error. + _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki + + -- No binder; try applying the substitution, or fail if that's not possible + (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ + ty_app_err ki_arg substed_fun_ki + + ---------------- HsValArg: a normal argument (fun ty) + (HsValArg arg : args, Just (ki_binder, inner_ki)) + -- next binder is invisible; need to instantiate it + | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; + -- or ForAllTy with Inferred or Specified + -> instantiate ki_binder inner_ki + + -- "normal" case + | otherwise + -> do { traceTc "tcInferTyApps (vis normal app)" + (vcat [ ppr ki_binder + , ppr arg + , ppr (tyBinderType ki_binder) + , ppr subst ]) + ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ + tc_lhs_type mode arg exp_kind + ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' + ; go (n+1) fun' subst' inner_ki args } + + -- no binder; try applying the substitution, or infer another arrow in fun kind + (HsValArg _ : _, Nothing) + -> try_again_after_substing_or $ + do { let arrows_needed = n_initial_val_args all_args + ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki + + ; fun' <- zonkTcType (fun `mkTcCastTy` co) + -- This zonk is essential, to expose the fruits + -- of matchExpectedFunKind to the 'go' loop + + ; traceTc "tcInferTyApps (no binder)" $ + vcat [ ppr fun <+> dcolon <+> ppr fun_ki + , ppr arrows_needed + , ppr co + , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] + ; go_init n fun' all_args } + -- Use go_init to establish go's INVARIANT + where + instantiate ki_binder inner_ki + = do { traceTc "tcInferTyApps (need to instantiate)" + (vcat [ ppr ki_binder, ppr subst]) + ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder + ; go n (mkAppTy fun arg') subst' inner_ki all_args } + -- Because tcInvisibleTyBinder instantiate ki_binder, + -- the kind of arg' will have the same shape as the kind + -- of ki_binder. So we don't need mkAppTyM here. + + try_again_after_substing_or fallthrough + | not (isEmptyTCvSubst subst) + = go n fun zapped_subst substed_fun_ki all_args + | otherwise + = fallthrough + + zapped_subst = zapTCvSubst subst + substed_fun_ki = substTy subst fun_ki + hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) + + n_initial_val_args :: [HsArg tm ty] -> Arity + -- Count how many leading HsValArgs we have + n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args + n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args + n_initial_val_args _ = 0 + + ty_app_err arg ty + = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) + + +mkAppTyM :: TCvSubst + -> TcType -> TyCoBinder -- fun, plus its top-level binder + -> TcType -- arg + -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) +-- Precondition: the application (fun arg) is well-kinded after zonking +-- That is, the application makes sense +-- +-- Precondition: for (mkAppTyM subst fun bndr arg) +-- tcTypeKind fun = Pi bndr. body +-- That is, fun always has a ForAllTy or FunTy at the top +-- and 'bndr' is fun's pi-binder +-- +-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type +-- invariant, then so does the result type (fun arg) +-- +-- We do not require that +-- tcTypeKind arg = tyVarKind (binderVar bndr) +-- This must be true after zonking (precondition 1), but it's not +-- required for the (PKTI). +mkAppTyM subst fun ki_binder arg + | -- See Note [mkAppTyM]: Nasty case 2 + TyConApp tc args <- fun + , isTypeSynonymTyCon tc + , args `lengthIs` (tyConArity tc - 1) + , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym + = do { arg' <- zonkTcType arg + ; args' <- zonkTcTypes args + ; let subst' = case ki_binder of + Anon {} -> subst + Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' + ; return (subst', mkTyConApp tc (args' ++ [arg'])) } + + +mkAppTyM subst fun (Anon {}) arg + = return (subst, mk_app_ty fun arg) + +mkAppTyM subst fun (Named (Bndr tv _)) arg + = do { arg' <- if isTrickyTvBinder tv + then -- See Note [mkAppTyM]: Nasty case 1 + zonkTcType arg + else return arg + ; return ( extendTvSubstAndInScope subst tv arg' + , mk_app_ty fun arg' ) } + +mk_app_ty :: TcType -> TcType -> TcType +-- This function just adds an ASSERT for mkAppTyM's precondition +mk_app_ty fun arg + = ASSERT2( isPiTy fun_kind + , ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg ) + mkAppTy fun arg + where + fun_kind = tcTypeKind fun + +isTrickyTvBinder :: TcTyVar -> Bool +-- NB: isTrickyTvBinder is just an optimisation +-- It would be absolutely sound to return True always +isTrickyTvBinder tv = isPiTy (tyVarKind tv) + +{- Note [The Purely Kinded Type Invariant (PKTI)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type inference, we maintain this invariant + + (PKTI) It is legal to call 'tcTypeKind' on any Type ty, + on any sub-term of ty, /without/ zonking ty + + Moreover, any such returned kind + will itself satisfy (PKTI) + +By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". +The way in which tcTypeKind can crash is in applications + (a t1 t2 .. tn) +if 'a' is a type variable whose kind doesn't have enough arrows +or foralls. (The crash is in piResultTys.) + +The loop in tcInferTyApps has to be very careful to maintain the (PKTI). +For example, suppose + kappa is a unification variable + We have already unified kappa := Type + yielding co :: Refl (Type -> Type) + a :: kappa +then consider the type + (a Int) +If we call tcTypeKind on that, we'll crash, because the (un-zonked) +kind of 'a' is just kappa, not an arrow kind. So we must zonk first. + +So the type inference engine is very careful when building applications. +This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int), +where (a :: kappa). Then in tcInferApps we'll run out of binders on +a's kind, so we'll call matchExpectedFunKind, and unify + kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) +At this point we must zonk the function type to expose the arrrow, so +that (a Int) will satisfy (PKTI). + +The absence of this caused #14174 and #14520. + +The calls to mkAppTyM is the other place we are very careful. + +Note [mkAppTyM] +~~~~~~~~~~~~~~~ +mkAppTyM is trying to guarantee the Purely Kinded Type Invariant +(PKTI) for its result type (fun arg). There are two ways it can go wrong: + +* Nasty case 1: forall types (polykinds/T14174a) + T :: forall (p :: *->*). p Int -> p Bool + Now kind-check (T x), where x::kappa. + Well, T and x both satisfy the PKTI, but + T x :: x Int -> x Bool + and (x Int) does /not/ satisfy the PKTI. + +* Nasty case 2: type synonyms + type S f a = f a + Even though (S ff aa) would satisfy the (PKTI) if S was a data type + (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) + if S is a type synonym, because the /expansion/ of (S ff aa) is + (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps + (ff :: kappa), where 'kappa' has already been unified with (*->*). + + We check for nasty case 2 on the final argument of a type synonym. + +Notice that in both cases the trickiness only happens if the +bound variable has a pi-type. Hence isTrickyTvBinder. +-} + + +saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) +-- Precondition for (saturateFamApp ty kind): +-- tcTypeKind ty = kind +-- +-- If 'ty' is an unsaturated family application with trailing +-- invisible arguments, instantiate them. +-- See Note [saturateFamApp] + +saturateFamApp ty kind + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , mustBeSaturated tc + , let n_to_inst = tyConArity tc - length args + = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind + ; return (ty `mkTcAppTys` extra_args, ki') } + | otherwise + = return (ty, kind) + +{- Note [saturateFamApp] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: Either j k + type instance F @Type = Right Maybe + type instance F @Type = Right Either``` + +Then F :: forall {j,k}. Either j k + +The two type instances do a visible kind application that instantiates +'j' but not 'k'. But we want to end up with instances that look like + type instance F @Type @(*->*) = Right @Type @(*->*) Maybe + +so that F has arity 2. We must instantiate that trailing invisible +binder. In general, Invisible binders precede Specified and Required, +so this is only going to bite for apparently-nullary families. + +Note that + type family F2 :: forall k. k -> * +is quite different and really does have arity 0. + +It's not just type instances where we need to saturate those +unsaturated arguments: see #11246. Hence doing this in tcInferApps. +-} + +appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn +appTypeToArg f [] = f +appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args +appTypeToArg f (HsTypeArg l arg : args) + = appTypeToArg (mkHsAppKindTy l f arg) args + + +{- ********************************************************************* +* * + checkExpectedKind +* * +********************************************************************* -} + +-- | This instantiates invisible arguments for the type being checked if it must +-- be saturated and is not yet saturated. It then calls and uses the result +-- from checkExpectedKindX to build the final type +checkExpectedKind :: HasDebugCallStack + => HsType GhcRn -- ^ type we're checking (for printing) + -> TcType -- ^ type we're checking + -> TcKind -- ^ the known kind of that type + -> TcKind -- ^ the expected kind + -> TcM TcType +-- Just a convenience wrapper to save calls to 'ppr' +checkExpectedKind hs_ty ty act_kind exp_kind + = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) + + ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind + + ; let origin = TypeEqOrigin { uo_actual = act_kind' + , uo_expected = exp_kind + , uo_thing = Just (ppr hs_ty) + , uo_visible = True } -- the hs_ty is visible + + ; traceTc "checkExpectedKindX" $ + vcat [ ppr hs_ty + , text "act_kind':" <+> ppr act_kind' + , text "exp_kind:" <+> ppr exp_kind ] + + ; let res_ty = ty `mkTcAppTys` new_args + + ; if act_kind' `tcEqType` exp_kind + then return res_ty -- This is very common + else do { co_k <- uType KindLevel origin act_kind' exp_kind + ; traceTc "checkExpectedKind" (vcat [ ppr act_kind + , ppr exp_kind + , ppr co_k ]) + ; return (res_ty `mkTcCastTy` co_k) } } + where + -- We need to make sure that both kinds have the same number of implicit + -- foralls out front. If the actual kind has more, instantiate accordingly. + -- Otherwise, just pass the type & kind through: the errors are caught + -- in unifyType. + n_exp_invis_bndrs = invisibleTyBndrCount exp_kind + n_act_invis_bndrs = invisibleTyBndrCount act_kind + n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs + +--------------------------- +tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] +tcHsMbContext Nothing = return [] +tcHsMbContext (Just cxt) = tcHsContext cxt + +tcHsContext :: LHsContext GhcRn -> TcM [PredType] +tcHsContext cxt = tc_hs_context (mkMode TypeLevel) cxt + +tcLHsPredType :: LHsType GhcRn -> TcM PredType +tcLHsPredType pred = tc_lhs_pred (mkMode TypeLevel) pred + +tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] +tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) + +tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType +tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind + +--------------------------- +tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) +-- See Note [Type checking recursive type and class declarations] +-- in GHC.Tc.TyCl +-- This does not instantiate. See Note [Do not always instantiate eagerly in types] +tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon + = do { traceTc "lk1" (ppr name) + ; thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + ATcTyCon tc_tc + -> do { -- See Note [GADT kind self-reference] + unless (isTypeLevel (mode_tyki mode)) + (promotionErr name TyConPE) + ; check_tc tc_tc + ; return (mkTyConTy tc_tc, tyConKind tc_tc) } + + AGlobal (ATyCon tc) + -> do { check_tc tc + ; return (mkTyConTy tc, tyConKind tc) } + + AGlobal (AConLike (RealDataCon dc)) + -> do { data_kinds <- xoptM LangExt.DataKinds + ; unless (data_kinds || specialPromotedDc dc) $ + promotionErr name NoDataKindsDC + ; when (isFamInstTyCon (dataConTyCon dc)) $ + -- see #15245 + promotionErr name FamDataConPE + ; let (_, _, _, theta, _, _) = dataConFullSig dc + ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta)) + ; case dc_theta_illegal_constraint theta of + Just pred -> promotionErr name $ + ConstrainedDataConPE pred + Nothing -> pure () + ; let tc = promoteDataCon dc + ; return (mkTyConApp tc [], tyConKind tc) } + + APromotionErr err -> promotionErr name err + + _ -> wrongThingErr "type" thing name } + where + check_tc :: TyCon -> TcM () + check_tc tc = do { data_kinds <- xoptM LangExt.DataKinds + ; unless (isTypeLevel (mode_tyki mode) || + data_kinds || + isKindTyCon tc) $ + promotionErr name NoDataKindsTC } + + -- We cannot promote a data constructor with a context that contains + -- constraints other than equalities, so error if we find one. + -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep + dc_theta_illegal_constraint :: ThetaType -> Maybe PredType + dc_theta_illegal_constraint = find (not . isEqPred) + +{- +Note [GADT kind self-reference] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A promoted type cannot be used in the body of that type's declaration. +#11554 shows this example, which made GHC loop: + + import Data.Kind + data P (x :: k) = Q + data A :: Type where + B :: forall (a :: A). P a -> A + +In order to check the constructor B, we need to have the promoted type A, but in +order to get that promoted type, B must first be checked. To prevent looping, a +TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode. +Any ATcTyCon is a TyCon being defined in the current recursive group (see data +type decl for TcTyThing), and all such TyCons are illegal in kinds. + +#11962 proposes checking the head of a data declaration separately from +its constructors. This would allow the example above to pass. + +Note [Body kind of a HsForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type, but in principle +there's no reason to prohibit *unlifted* types. +In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all (via CPR analysis; see +typecheck/should_compile/tc170). + +Moreover in instance heads we get forall-types with +kind Constraint. + +It's tempting to check that the body kind is either * or #. But this is +wrong. For example: + + class C a b + newtype N = Mk Foo deriving (C a) + +We're doing newtype-deriving for C. But notice how `a` isn't in scope in +the predicate `C a`. So we quantify, yielding `forall a. C a` even though +`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but +convenient. Bottom line: don't check for * or # here. + +Note [Body kind of a HsQualTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ctxt is non-empty, the HsQualTy really is a /function/, so the +kind of the result really is '*', and in that case the kind of the +body-type can be lifted or unlifted. + +However, consider + instance Eq a => Eq [a] where ... +or + f :: (Eq a => Eq [a]) => blah +Here both body-kind of the HsQualTy is Constraint rather than *. +Rather crudely we tell the difference by looking at exp_kind. It's +very convenient to typecheck instance types like any other HsSigType. + +Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's +better to reject in checkValidType. If we say that the body kind +should be '*' we risk getting TWO error messages, one saying that Eq +[a] doesn't have kind '*', and one saying that we need a Constraint to +the left of the outer (=>). + +How do we figure out the right body kind? Well, it's a bit of a +kludge: I just look at the expected kind. If it's Constraint, we +must be in this instance situation context. It's a kludge because it +wouldn't work if any unification was involved to compute that result +kind -- but it isn't. (The true way might be to use the 'mode' +parameter, but that seemed like a sledgehammer to crack a nut.) + +Note [Inferring tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the arguments to give good error messages in + e.g. (Maybe, Maybe) + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. + +Note [Desugaring types] +~~~~~~~~~~~~~~~~~~~~~~~ +The type desugarer is phase 2 of dealing with HsTypes. Specifically: + + * It transforms from HsType to Type + + * It zonks any kinds. The returned type should have no mutable kind + or type variables (hence returning Type not TcType): + - any unconstrained kind variables are defaulted to (Any *) just + as in GHC.Tc.Utils.Zonk. + - there are no mutable type variables because we are + kind-checking a type + Reason: the returned type may be put in a TyCon or DataCon where + it will never subsequently be zonked. + +You might worry about nested scopes: + ..a:kappa in scope.. + let f :: forall b. T '[a,b] -> Int +In this case, f's type could have a mutable kind variable kappa in it; +and we might then default it to (Any *) when dealing with f's type +signature. But we don't expect this to happen because we can't get a +lexically scoped type variable with a mutable kind variable in it. A +delicate point, this. If it becomes an issue we might need to +distinguish top-level from nested uses. + +Moreover + * it cannot fail, + * it does no unifications + * it does no validity checking, except for structural matters, such as + (a) spurious ! annotations. + (b) a class used as a type + +Note [Kind of a type splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these terms, each with TH type splice inside: + [| e1 :: Maybe $(..blah..) |] + [| e2 :: $(..blah..) |] +When kind-checking the type signature, we'll kind-check the splice +$(..blah..); we want to give it a kind that can fit in any context, +as if $(..blah..) :: forall k. k. + +In the e1 example, the context of the splice fixes kappa to *. But +in the e2 example, we'll desugar the type, zonking the kind unification +variables as we go. When we encounter the unconstrained kappa, we +want to default it to '*', not to (Any *). + +-} + +addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a + -- Wrap a context around only if we want to show that contexts. + -- Omit invisible ones and ones user's won't grok +addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. +addTypeCtxt (L _ ty) thing + = addErrCtxt doc thing + where + doc = text "In the type" <+> quotes (ppr ty) + + +{- ********************************************************************* +* * + Type-variable binders +* * +********************************************************************* -} + +tcNamedWildCardBinders :: [Name] + -> ([(Name, TcTyVar)] -> TcM a) + -> TcM a +-- Bring into scope the /named/ wildcard binders. Remember that +-- plain wildcards _ are anonymous and dealt with by HsWildCardTy +-- Soe Note [The wildcard story for types] in GHC.Hs.Type +tcNamedWildCardBinders wc_names thing_inside + = do { wcs <- mapM newNamedWildTyVar wc_names + ; let wc_prs = wc_names `zip` wcs + ; tcExtendNameTyVarEnv wc_prs $ + thing_inside wc_prs } + +newNamedWildTyVar :: Name -> TcM TcTyVar +-- ^ New unification variable '_' for a wildcard +newNamedWildTyVar _name -- Currently ignoring the "_x" wildcard name used in the type + = do { kind <- newMetaKindVar + ; details <- newMetaDetails TauTv + ; wc_name <- newMetaTyVarName (fsLit "w") -- See Note [Wildcard names] + ; let tyvar = mkTcTyVar wc_name kind details + ; traceTc "newWildTyVar" (ppr tyvar) + ; return tyvar } + +--------------------------- +tcAnonWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType +tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) + ty exp_kind + -- hole_lvl: see Note [Checking partial type signatures] + -- esp the bullet on nested forall types + = do { kv_details <- newTauTvDetailsAtLevel hole_lvl + ; kv_name <- newMetaTyVarName (fsLit "k") + ; wc_details <- newTauTvDetailsAtLevel hole_lvl + ; wc_name <- newMetaTyVarName (fsLit wc_nm) + ; let kv = mkTcTyVar kv_name liftedTypeKind kv_details + wc_kind = mkTyVarTy kv + wc_tv = mkTcTyVar wc_name wc_kind wc_details + + ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes) + ; when emit_holes $ + emitAnonTypeHole wc_tv + -- Why the 'when' guard? + -- See Note [Wildcards in visible kind application] + + -- You might think that this would always just unify + -- wc_kind with exp_kind, so we could avoid even creating kv + -- But the level numbers might not allow that unification, + -- so we have to do it properly (T14140a) + ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind } + where + -- See Note [Wildcard names] + wc_nm = case hole_mode of + HM_Sig -> "w" + HM_FamPat -> "_" + HM_VTA -> "w" + + emit_holes = case hole_mode of + HM_Sig -> True + HM_FamPat -> False + HM_VTA -> False + +tcAnonWildCardOcc mode ty _ +-- mode_holes is Nothing. Should not happen, because renamer +-- should already have rejected holes in unexpected places + = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty) + +{- Note [Wildcard names] +~~~~~~~~~~~~~~~~~~~~~~~~ +So we hackily use the mode_holes flag to control the name used +for wildcards: + +* For proper holes (whether in a visible type application (VTA) or no), + we rename the '_' to 'w'. This is so that we see variables like 'w0' + or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For + example, we prefer + Found type wildcard ‘_’ standing for ‘w0’ + over + Found type wildcard ‘_’ standing for ‘_1’ + + Even in the VTA case, where we do not emit an error to be printed, we + want to do the renaming, as the variables may appear in other, + non-wildcard error messages. + +* However, holes in the left-hand sides of type families ("type + patterns") stand for type variables which we do not care to name -- + much like the use of an underscore in an ordinary term-level + pattern. When we spot these, we neither wish to generate an error + message nor to rename the variable. We don't rename the variable so + that we can pretty-print a type family LHS as, e.g., + F _ Int _ = ... + and not + F w1 Int w2 = ... + + See also Note [Wildcards in family instances] in + GHC.Rename.Module. The choice of HM_FamPat is made in + tcFamTyPats. There is also some unsavory magic, relying on that + underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser. + +Note [Wildcards in visible kind application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are cases where users might want to pass in a wildcard as a visible kind +argument, for instance: + +data T :: forall k1 k2. k1 → k2 → Type where + MkT :: T a b +x :: T @_ @Nat False n +x = MkT + +So we should allow '@_' without emitting any hole constraints, and +regardless of whether PartialTypeSignatures is enabled or not. But how +would the typechecker know which '_' is being used in VKA and which is +not when it calls emitNamedTypeHole in +tcHsPartialSigType on all HsWildCardBndrs? The solution is to neither +rename nor include unnamed wildcards in HsWildCardBndrs, but instead +give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. + +And whenever we see a '@', we set mode_holes to HM_VKA, so that +we do not call emitAnonTypeHole in tcAnonWildCardOcc. +See related Note [Wildcards in visible type application] here and +Note [The wildcard story for types] in GHC.Hs.Type +-} + +{- ********************************************************************* +* * + Kind inference for type declarations +* * +********************************************************************* -} + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +data InitialKindStrategy + = InitialKindCheck SAKS_or_CUSK + | InitialKindInfer + +-- Does the declaration have a standalone kind signature (SAKS) or a complete +-- user-specified kind (CUSK)? +data SAKS_or_CUSK + = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) + | CUSK -- Complete user-specified kind (CUSK) + +instance Outputable SAKS_or_CUSK where + ppr (SAKS k) = text "SAKS" <+> ppr k + ppr CUSK = text "CUSK" + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +kcDeclHeader + :: InitialKindStrategy + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon +kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig +kcDeclHeader InitialKindInfer = kcInferDeclHeader + +{- Note [kcCheckDeclHeader vs kcInferDeclHeader] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind +of a type constructor. + +* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that + case, find the full, final, poly-kinded kind of the TyCon. It's very like a + term-level binding where we have a complete type signature for the function. + +* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a + CUSK. Find a monomorphic kind, with unification variables in it; they will be + generalised later. It's very like a term-level binding where we do not have a + type signature (or, more accurately, where we have a partial type signature), + so we infer the type and generalise. +-} + +------------------------------ +kcCheckDeclHeader + :: SAKS_or_CUSK + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon +kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig +kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk + +kcCheckDeclHeader_cusk + :: Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon +kcCheckDeclHeader_cusk name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_tvs }) kc_res_ki + -- CUSK case + -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addTyConFlavCtxt name flav $ + do { (scoped_kvs, (tc_tvs, res_kind)) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol kv_ns $ + bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ + newExpectedKind =<< kc_res_ki + + -- Now, because we're in a CUSK, + -- we quantify over the mentioned kind vars + ; let spec_req_tkvs = scoped_kvs ++ tc_tvs + all_kinds = res_kind : map tyVarKind spec_req_tkvs + + ; candidates' <- candidateQTyVarsOfKinds all_kinds + -- 'candidates' are all the variables that we are going to + -- skolemise and then quantify over. We do not include spec_req_tvs + -- because they are /already/ skolems + + ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds)) + candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } + inf_candidates = candidates `delCandidates` spec_req_tkvs + + ; inferred <- quantifyTyVars inf_candidates + -- NB: 'inferred' comes back sorted in dependency order + + ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs + ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs + ; res_kind <- zonkTcType res_kind + + ; let mentioned_kv_set = candidateKindVars candidates + specified = scopedSort scoped_kvs + -- NB: maintain the L-R order of scoped_kvs + + final_tc_binders = mkNamedTyConBinders Inferred inferred + ++ mkNamedTyConBinders Specified specified + ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs + + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs + True -- it is generalised + flav + -- If the ordering from + -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + -- doesn't work, we catch it here, before an error cascade + ; checkTyConTelescope tycon + + ; traceTc "kcCheckDeclHeader_cusk " $ + vcat [ text "name" <+> ppr name + , text "kv_ns" <+> ppr kv_ns + , text "hs_tvs" <+> ppr hs_tvs + , text "scoped_kvs" <+> ppr scoped_kvs + , text "tc_tvs" <+> ppr tc_tvs + , text "res_kind" <+> ppr res_kind + , text "candidates" <+> ppr candidates + , text "inferred" <+> ppr inferred + , text "specified" <+> ppr specified + , text "final_tc_binders" <+> ppr final_tc_binders + , text "mkTyConKind final_tc_bndrs res_kind" + <+> ppr (mkTyConKind final_tc_binders res_kind) + , text "all_tv_prs" <+> ppr all_tv_prs ] + + ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and +-- other kinds). +-- +-- This function does not do telescope checking. +kcInferDeclHeader + :: Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon +kcInferDeclHeader name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_tvs }) kc_res_ki + -- No standalane kind signature and no CUSK. + -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addTyConFlavCtxt name flav $ + do { (scoped_kvs, (tc_tvs, res_kind)) + -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + <- bindImplicitTKBndrs_Q_Tv kv_ns $ + bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ + newExpectedKind =<< kc_res_ki + -- Why "_Tv" not "_Skol"? See third wrinkle in + -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, + + ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they + -- might unify with kind vars in other types in a mutually + -- recursive group. + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + + tc_binders = mkAnonTyConBinders VisArg tc_tvs + -- Also, note that tc_binders has the tyvars from only the + -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] + -- in GHC.Tc.TyCl + -- + -- mkAnonTyConBinder: see Note [No polymorphic recursion] + + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + -- NB: bindExplicitTKBndrs_Q_Tv does not clone; + -- ditto Implicit + -- See Note [Non-cloning for tyvar binders] + + tycon = mkTcTyCon name tc_binders res_kind all_tv_prs + False -- not yet generalised + flav + + ; traceTc "kcInferDeclHeader: not-cusk" $ + vcat [ ppr name, ppr kv_ns, ppr hs_tvs + , ppr scoped_kvs + , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] + ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- | Kind-check a declaration header against a standalone kind signature. +-- See Note [Arity inference in kcCheckDeclHeader_sig] +kcCheckDeclHeader_sig + :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon +kcCheckDeclHeader_sig kisig name flav + (HsQTvs { hsq_ext = implicit_nms + , hsq_explicit = explicit_nms }) kc_res_ki + = addTyConFlavCtxt name flav $ + do { -- Step 1: zip user-written binders with quantifiers from the kind signature. + -- For example: + -- + -- type F :: forall k -> k -> forall j. j -> Type + -- data F i a b = ... + -- + -- Results in the following 'zipped_binders': + -- + -- TyBinder LHsTyVarBndr + -- --------------------------------------- + -- ZippedBinder forall k -> i + -- ZippedBinder k -> a + -- ZippedBinder forall j. + -- ZippedBinder j -> b + -- + let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms + + -- Report binders that don't have a corresponding quantifier. + -- For example: + -- + -- type T :: Type -> Type + -- data T b1 b2 b3 = ... + -- + -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders. + -- + ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs) + + -- Convert each ZippedBinder to TyConBinder for tyConBinders + -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars + ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders + + ; (implicit_tvs, (invis_binders, r_ki)) + <- pushTcLevelM_ $ + solveEqualities $ -- #16687 + bindImplicitTKBndrs_Tv implicit_nms $ + tcExtendNameTyVarEnv explicit_tv_prs $ + do { -- Check that inline kind annotations on binders are valid. + -- For example: + -- + -- type T :: Maybe k -> Type + -- data T (a :: Maybe j) = ... + -- + -- Here we unify Maybe k ~ Maybe j + mapM_ check_zipped_binder zipped_binders + + -- Kind-check the result kind annotation, if present: + -- + -- data T a b :: res_ki where + -- ^^^^^^^^^ + -- We do it here because at this point the environment has been + -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. + ; ctx_k <- kc_res_ki + ; m_res_ki <- case ctx_k of + AnyKind -> return Nothing + _ -> Just <$> newExpectedKind ctx_k + + -- Step 2: split off invisible binders. + -- For example: + -- + -- type F :: forall k1 k2. (k1, k2) -> Type + -- type family F + -- + -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? + -- See Note [Arity inference in kcCheckDeclHeader_sig] + ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki + + -- Check that the inline result kind annotation is valid. + -- For example: + -- + -- type T :: Type -> Maybe k + -- type family T a :: Maybe j where + -- + -- Here we unify Maybe k ~ Maybe j + ; whenIsJust m_res_ki $ \res_ki -> + discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] + unifyKind Nothing r_ki res_ki + + ; return (invis_binders, r_ki) } + + -- Zonk the implicitly quantified variables. + ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs + + -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. + ; invis_tcbs <- mapM invis_to_tcb invis_binders + + -- Build the final, generalized TcTyCon + ; let tcbs = vis_tcbs ++ invis_tcbs + implicit_tv_prs = implicit_nms `zip` implicit_tvs + all_tv_prs = implicit_tv_prs ++ explicit_tv_prs + tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav + + ; traceTc "kcCheckDeclHeader_sig done:" $ vcat + [ text "tyConName = " <+> ppr (tyConName tc) + , text "kisig =" <+> debugPprType kisig + , text "tyConKind =" <+> debugPprType (tyConKind tc) + , text "tyConBinders = " <+> ppr (tyConBinders tc) + , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) + , text "tyConResKind" <+> debugPprType (tyConResKind tc) + ] + ; return tc } + where + -- Consider this declaration: + -- + -- type T :: forall a. forall b -> (a~b) => Proxy a -> Type + -- data T x p = MkT + -- + -- Here, we have every possible variant of ZippedBinder: + -- + -- TyBinder LHsTyVarBndr + -- ---------------------------------------------- + -- ZippedBinder forall {k}. + -- ZippedBinder forall (a::k). + -- ZippedBinder forall (b::k) -> x + -- ZippedBinder (a~b) => + -- ZippedBinder Proxy a -> p + -- + -- Given a ZippedBinder zipped_to_tcb produces: + -- + -- * TyConBinder for tyConBinders + -- * (Name, TcTyVar) for tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr + -- + zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)]) + zipped_to_tcb zb = case zb of + + -- Inferred variable, no user-written binder. + -- Example: forall {k}. + ZippedBinder (Named (Bndr v Specified)) Nothing -> + return (mkNamedTyConBinder Specified v, []) + + -- Specified variable, no user-written binder. + -- Example: forall (a::k). + ZippedBinder (Named (Bndr v Inferred)) Nothing -> + return (mkNamedTyConBinder Inferred v, []) + + -- Constraint, no user-written binder. + -- Example: (a~b) => + ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do + name <- newSysName (mkTyVarOccFS (fsLit "ev")) + let tv = mkTyVar name (scaledThing bndr_ki) + return (mkAnonTyConBinder InvisArg tv, []) + + -- Non-dependent visible argument with a user-written binder. + -- Example: Proxy a -> + ZippedBinder (Anon VisArg bndr_ki) (Just b) -> + return $ + let v_name = getName b + tv = mkTyVar v_name (scaledThing bndr_ki) + tcb = mkAnonTyConBinder VisArg tv + in (tcb, [(v_name, tv)]) + + -- Dependent visible argument with a user-written binder. + -- Example: forall (b::k) -> + ZippedBinder (Named (Bndr v Required)) (Just b) -> + return $ + let v_name = getName b + tcb = mkNamedTyConBinder Required v + in (tcb, [(v_name, v)]) + + -- 'zipBinders' does not produce any other variants of ZippedBinder. + _ -> panic "goVis: invalid ZippedBinder" + + -- Given an invisible binder that comes from 'split_invis', + -- convert it to TyConBinder. + invis_to_tcb :: TyCoBinder -> TcM TyConBinder + invis_to_tcb tb = do + (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing) + MASSERT(null stv) + return tcb + + -- Check that the inline kind annotation on a binder is valid + -- by unifying it with the kind of the quantifier. + check_zipped_binder :: ZippedBinder -> TcM () + check_zipped_binder (ZippedBinder _ Nothing) = return () + check_zipped_binder (ZippedBinder tb (Just b)) = + case unLoc b of + UserTyVar _ _ _ -> return () + KindedTyVar _ _ v v_hs_ki -> do + v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki + discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] + unifyKind (Just (HsTyVar noExtField NotPromoted v)) + (tyBinderType tb) + v_ki + + -- Split the invisible binders that should become a part of 'tyConBinders' + -- rather than 'tyConResKind'. + -- See Note [Arity inference in kcCheckDeclHeader_sig] + split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) + split_invis sig_ki Nothing = + -- instantiate all invisible binders + splitPiTysInvisible sig_ki + split_invis sig_ki (Just res_ki) = + -- subtraction a la checkExpectedKind + let n_res_invis_bndrs = invisibleTyBndrCount res_ki + n_sig_invis_bndrs = invisibleTyBndrCount sig_ki + n_inst = n_sig_invis_bndrs - n_res_invis_bndrs + in splitPiTysInvisibleN n_inst sig_ki + +-- A quantifier from a kind signature zipped with a user-written binder for it. +data ZippedBinder = + ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn)) + +-- See Note [Arity inference in kcCheckDeclHeader_sig] +zipBinders + :: Kind -- kind signature + -> [LHsTyVarBndr () GhcRn] -- user-written binders + -> ([ZippedBinder], -- zipped binders + [LHsTyVarBndr () GhcRn], -- remaining user-written binders + Kind) -- remainder of the kind signature +zipBinders = zip_binders [] + where + zip_binders acc ki [] = (reverse acc, [], ki) + zip_binders acc ki (b:bs) = + case tcSplitPiTy_maybe ki of + Nothing -> (reverse acc, b:bs, ki) + Just (tb, ki') -> + let + (zb, bs') | zippable = (ZippedBinder tb (Just b), bs) + | otherwise = (ZippedBinder tb Nothing, b:bs) + zippable = + case tb of + Named (Bndr _ (Invisible _)) -> False + Named (Bndr _ Required) -> True + Anon InvisArg _ -> False + Anon VisArg _ -> True + in + zip_binders (zb:acc) ki' bs' + +tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc +tooManyBindersErr ki bndrs = + hang (text "Not a function kind:") + 4 (ppr ki) $$ + hang (text "but extra binders found:") + 4 (fsep (map ppr bndrs)) + +{- Note [Arity inference in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig +verifies that the declaration conforms to the signature. The end result is a +TcTyCon 'tc' such that: + + tyConKind tc == kisig + +This TcTyCon would be rather easy to produce if we didn't have to worry about +arity. Consider these declarations: + + type family S1 :: forall k. k -> Type + type family S2 (a :: k) :: Type + +Both S1 and S2 can be given the same standalone kind signature: + + type S2 :: forall k. k -> Type + +And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from +tyConBinders and tyConResKind, such that + + tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc) + +For S1 and S2, tyConBinders and tyConResKind are different: + + tyConBinders S1 == [] + tyConResKind S1 == forall k. k -> Type + tyConKind S1 == forall k. k -> Type + + tyConBinders S2 == [spec k, anon-vis (a :: k)] + tyConResKind S2 == Type + tyConKind S1 == forall k. k -> Type + +This difference determines the arity: + + tyConArity tc == length (tyConBinders tc) + +That is, the arity of S1 is 0, while the arity of S2 is 2. + +'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone +kind signature into binders and the result kind. It does so in two rounds: + +1. zip user-written binders (vis_tcbs) +2. split off invisible binders (invis_tcbs) + +Consider the following declarations: + + type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type + type family F a b + + type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type + type family G a b :: forall r2. (r1, r2) -> Type + +In step 1 (zip user-written binders), we zip the quantifiers in the signature +with the binders in the header using 'zipBinders'. In both F and G, this results in +the following zipped binders: + + TyBinder LHsTyVarBndr + --------------------------------------- + ZippedBinder Type -> a + ZippedBinder forall j. + ZippedBinder j -> b + + +At this point, we have accumulated three zipped binders which correspond to a +prefix of the standalone kind signature: + + Type -> forall j. j -> ... + +In step 2 (split off invisible binders), we have to decide how much remaining +invisible binders of the standalone kind signature to split off: + + forall k1 k2. (k1, k2) -> Type + ^^^^^^^^^^^^^ + split off or not? + +This decision is made in 'split_invis': + +* If a user-written result kind signature is not provided, as in F, + then split off all invisible binders. This is why we need special treatment + for AnyKind. +* If a user-written result kind signature is provided, as in G, + then do as checkExpectedKind does and split off (n_sig - n_res) binders. + That is, split off such an amount of binders that the remainder of the + standalone kind signature and the user-written result kind signature have the + same amount of invisible quantifiers. + +For F, split_invis splits away all invisible binders, and we have 2: + + forall k1 k2. (k1, k2) -> Type + ^^^^^^^^^^^^^ + split away both binders + +The resulting arity of F is 3+2=5. (length vis_tcbs = 3, + length invis_tcbs = 2, + length tcbs = 5) + +For G, split_invis decides to split off 1 invisible binder, so that we have the +same amount of invisible quantifiers left: + + res_ki = forall r2. (r1, r2) -> Type + kisig = forall k1 k2. (k1, k2) -> Type + ^^^ + split off this one. + +The resulting arity of G is 3+1=4. (length vis_tcbs = 3, + length invis_tcbs = 1, + length tcbs = 4) + +-} + +{- Note [discardResult in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use 'unifyKind' to check inline kind annotations in declaration headers +against the signature. + + type T :: [i] -> Maybe j -> Type + data T (a :: [k1]) (b :: Maybe k2) :: Type where ... + +Here, we will unify: + + [k1] ~ [i] + Maybe k2 ~ Maybe j + Type ~ Type + +The end result is that we fill in unification variables k1, k2: + + k1 := i + k2 := j + +We also validate that the user isn't confused: + + type T :: Type -> Type + data T (a :: Bool) = ... + +This will report that (Type ~ Bool) failed to unify. + +Now, consider the following example: + + type family Id a where Id x = x + type T :: Bool -> Type + type T (a :: Id Bool) = ... + +We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. +However, we are free to discard it, as the kind of 'T' is determined by the +signature, not by the inline kind annotation: + + we have T :: Bool -> Type + rather than T :: Id Bool -> Type + +This (Id Bool) will not show up anywhere after we're done validating it, so we +have no use for the produced coercion. +-} + +{- Note [No polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should this kind-check? + data T ka (a::ka) b = MkT (T Type Int Bool) + (T (Type -> Type) Maybe Bool) + +Notice that T is used at two different kinds in its RHS. No! +This should not kind-check. Polymorphic recursion is known to +be a tough nut. + +Previously, we laboriously (with help from the renamer) +tried to give T the polymorphic kind + T :: forall ka -> ka -> kappa -> Type +where kappa is a unification variable, even in the inferInitialKinds +phase (which is what kcInferDeclHeader is all about). But +that is dangerously fragile (see the ticket). + +Solution: make kcInferDeclHeader give T a straightforward +monomorphic kind, with no quantification whatsoever. That's why +we use mkAnonTyConBinder for all arguments when figuring out +tc_binders. + +But notice that (#16322 comment:3) + +* The algorithm successfully kind-checks this declaration: + data T2 ka (a::ka) = MkT2 (T2 Type a) + + Starting with (inferInitialKinds) + T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> * + we get + kappa4 := kappa1 -- from the (a:ka) kind signature + kappa1 := Type -- From application T2 Type + + These constraints are soluble so generaliseTcTyCon gives + T2 :: forall (k::Type) -> k -> * + + But now the /typechecking/ (aka desugaring, tcTyClDecl) phase + fails, because the call (T2 Type a) in the RHS is ill-kinded. + + We'd really prefer all errors to show up in the kind checking + phase. + +* This algorithm still accepts (in all phases) + data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) + although T3 is really polymorphic-recursive too. + Perhaps we should somehow reject that. + +Note [Kind-checking tyvar binders for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind-checking the type-variable binders for associated + data/newtype decls + family decls +we behave specially for type variables that are already in scope; +that is, bound by the enclosing class decl. This is done in +kcLHsQTyVarBndrs: + * The use of tcImplicitQTKBndrs + * The tcLookupLocal_maybe code in kc_hs_tv + +See Note [Associated type tyvar names] in GHC.Core.Class and + Note [TyVar binders for associated decls] in GHC.Hs.Decls + +We must do the same for family instance decls, where the in-scope +variables may be bound by the enclosing class instance decl. +Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen. + +Note [Kind variable ordering for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should be the kind of `T` in the following example? (#15591) + + class C (a :: Type) where + type T (x :: f a) + +As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify +the kind variables in left-to-right order of first occurrence in order to +support visible kind application. But we cannot perform this analysis on just +T alone, since its variable `a` actually occurs /before/ `f` if you consider +the fact that `a` was previously bound by the parent class `C`. That is to say, +the kind of `T` should end up being: + + T :: forall a f. f a -> Type + +(It wouldn't necessarily be /wrong/ if the kind ended up being, say, +forall f a. f a -> Type, but that would not be as predictable for users of +visible kind application.) + +In contrast, if `T` were redefined to be a top-level type family, like `T2` +below: + + type family T2 (x :: f (a :: Type)) + +Then `a` first appears /after/ `f`, so the kind of `T2` should be: + + T2 :: forall f a. f a -> Type + +In order to make this distinction, we need to know (in kcCheckDeclHeader) which +type variables have been bound by the parent class (if there is one). With +the class-bound variables in hand, we can ensure that we always quantify +these first. +-} + + +{- ********************************************************************* +* * + Expected kinds +* * +********************************************************************* -} + +-- | Describes the kind expected in a certain context. +data ContextKind = TheKind Kind -- ^ a specific kind + | AnyKind -- ^ any kind will do + | OpenKind -- ^ something of the form @TYPE _@ + +----------------------- +newExpectedKind :: ContextKind -> TcM Kind +newExpectedKind (TheKind k) = return k +newExpectedKind AnyKind = newMetaKindVar +newExpectedKind OpenKind = newOpenTypeKind + +----------------------- +expectedKindInCtxt :: UserTypeCtxt -> ContextKind +-- Depending on the context, we might accept any kind (for instance, in a TH +-- splice), or only certain kinds (like in type signatures). +expectedKindInCtxt (TySynCtxt _) = AnyKind +expectedKindInCtxt ThBrackCtxt = AnyKind +expectedKindInCtxt (GhciCtxt {}) = AnyKind +-- The types in a 'default' decl can have varying kinds +-- See Note [Extended defaults]" in GHC.Tc.Utils.Env +expectedKindInCtxt DefaultDeclCtxt = AnyKind +expectedKindInCtxt TypeAppCtxt = AnyKind +expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind +expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind +expectedKindInCtxt SpecInstCtxt = TheKind constraintKind +expectedKindInCtxt _ = OpenKind + + +{- ********************************************************************* +* * + Bringing type variables into scope +* * +********************************************************************* -} + +{- Note [Non-cloning for tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +bindExplictTKBndrs_Q_Skol, bindExplictTKBndrs_Skol, do not clone; +and nor do the Implicit versions. There is no need. + +bindExplictTKBndrs_Q_Tv does not clone; and similarly Implicit. +We take advantage of this in kcInferDeclHeader: + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) +If we cloned, we'd need to take a bit more care here; not hard. + +The main payoff is that avoidng gratuitious cloning means that we can +almost always take the fast path in swizzleTcTyConBndrs. "Almost +always" means not the case of mutual recursion with polymorphic kinds. + + +Note [Cloning for tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +bindExplicitTKBndrs_Tv does cloning, making up a Name with a fresh Unique, +unlike bindExplicitTKBndrs_Q_Tv. (Nor do the Skol variants clone.) +And similarly for bindImplicit... + +This for a narrow and tricky reason which, alas, I couldn't find a +simpler way round. #16221 is the poster child: + + data SameKind :: k -> k -> * + data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int + +When kind-checking T, we give (a :: kappa1). Then: + +- In kcConDecl we make a TyVarTv unification variable kappa2 for k2 + (as described in Note [Kind-checking for GADTs], even though this + example is an existential) +- So we get (b :: kappa2) via bindExplicitTKBndrs_Tv +- We end up unifying kappa1 := kappa2, because of the (SameKind a b) + +Now we generalise over kappa2. But if kappa2's Name is precisely k2 +(i.e. we did not clone) we'll end up giving T the utterlly final kind + T :: forall k2. k2 -> * +Nothing directly wrong with that but when we typecheck the data constructor +we have k2 in scope; but then it's brought into scope /again/ when we find +the forall k2. This is chaotic, and we end up giving it the type + MkT :: forall k2 (a :: k2) k2 (b :: k2). + SameKind @k2 a b -> Int -> T @{k2} a +which is bogus -- because of the shadowing of k2, we can't +apply T to the kind or a! + +And there no reason /not/ to clone the Name when making a unification +variable. So that's what we do. +-} + +-------------------------------------- +-- Implicit binders +-------------------------------------- + +bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, + bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv + :: [Name] -> TcM a -> TcM ([TcTyVar], a) +bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar) +bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar) +bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar +bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX cloneFlexiKindedTyVarTyVar + -- newFlexiKinded... see Note [Non-cloning for tyvar binders] + -- cloneFlexiKindedTyVarTyVar: see Note [Cloning for tyvar binders] + +bindImplicitTKBndrsX + :: (Name -> TcM TcTyVar) -- new_tv function + -> [Name] + -> TcM a + -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed in [Name] +bindImplicitTKBndrsX new_tv tv_names thing_inside + = do { tkvs <- mapM new_tv tv_names + ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs) + ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) + thing_inside + ; return (tkvs, res) } + +newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar +-- Behave like new_tv, except that if the tyvar is in scope, use it +newImplicitTyVarQ new_tv name + = do { mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of + Just (ATyVar _ tv) -> return tv + _ -> new_tv name } + +newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar +newFlexiKindedTyVar new_tv name + = do { kind <- newMetaKindVar + ; new_tv name kind } + +newFlexiKindedSkolemTyVar :: Name -> TcM TyVar +newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar + +newFlexiKindedTyVarTyVar :: Name -> TcM TyVar +newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar + +cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar +cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar + -- See Note [Cloning for tyvar binders] + +-------------------------------------- +-- Explicit binders +-------------------------------------- + +-- | Skolemise the 'HsTyVarBndr's in an 'LHsForAllTelescope. +-- Returns 'Left' for visible @forall@s and 'Right' for invisible @forall@s. +bindExplicitTKTele_Skol_M + :: TcTyMode + -> HsForAllTelescope GhcRn + -> TcM a + -> TcM (Either [TcReqTVBinder] [TcInvisTVBinder], a) +bindExplicitTKTele_Skol_M mode tele thing_inside = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> do + (req_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside + pure (Left req_tv_bndrs, thing) + HsForAllInvis { hsf_invis_bndrs = bndrs } -> do + (inv_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside + pure (Right inv_tv_bndrs, thing) + +bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv + :: (OutputableBndrFlag flag) + => [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Skol_M, bindExplicitTKBndrs_Tv_M + :: (OutputableBndrFlag flag) + => TcTyMode + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) newSkolemTyVar) +bindExplicitTKBndrs_Skol_M mode = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode) newSkolemTyVar) +bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) cloneTyVarTyVar) +bindExplicitTKBndrs_Tv_M mode = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode) cloneTyVarTyVar) + -- newSkolemTyVar: see Note [Non-cloning for tyvar binders] + -- cloneTyVarTyVar: see Note [Cloning for tyvar binders] + +bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv + :: ContextKind + -> [LHsTyVarBndr () GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) + +bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) +bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) + -- See Note [Non-cloning for tyvar binders] + +bindExplicitTKBndrsX_Q + :: (HsTyVarBndr () GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr () GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr] +bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside + = do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside + ; return ((binderVars tv_bndrs),res) } + +bindExplicitTKBndrsX :: (OutputableBndrFlag flag) + => (HsTyVarBndr flag GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr] +bindExplicitTKBndrsX tc_tv hs_tvs thing_inside + = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) + ; go hs_tvs } + where + go [] = do { res <- thing_inside + ; return ([], res) } + go (L _ hs_tv : hs_tvs) + = do { tv <- tc_tv hs_tv + -- Extend the environment as we go, in case a binder + -- is mentioned in the kind of a later binder + -- e.g. forall k (a::k). blah + -- NB: tv's Name may differ from hs_tv's + -- See GHC.Tc.Utils.TcMType Note [Cloning for tyvar binders] + ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ + go hs_tvs + ; return ((Bndr tv (hsTyVarBndrFlag hs_tv)):tvs, res) } + +----------------- +tcHsTyVarBndr :: TcTyMode -> (Name -> Kind -> TcM TyVar) + -> HsTyVarBndr flag GhcRn -> TcM TcTyVar +tcHsTyVarBndr _ new_tv (UserTyVar _ _ (L _ tv_nm)) + = do { kind <- newMetaKindVar + ; new_tv tv_nm kind } +tcHsTyVarBndr mode new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) + = do { kind <- tc_lhs_kind_sig mode (TyVarBndrKindCtxt tv_nm) lhs_kind + ; new_tv tv_nm kind } + +----------------- +tcHsQTyVarBndr :: ContextKind + -> (Name -> Kind -> TcM TyVar) + -> HsTyVarBndr () GhcRn -> TcM TcTyVar +-- Just like tcHsTyVarBndr, but also +-- - uses the in-scope TyVar from class, if it exists +-- - takes a ContextKind to use for the no-sig case +tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ _ (L _ tv_nm)) + = do { mb_tv <- tcLookupLcl_maybe tv_nm + ; case mb_tv of + Just (ATyVar _ tv) -> return tv + _ -> do { kind <- newExpectedKind ctxt_kind + ; new_tv tv_nm kind } } + +tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) + = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind + ; mb_tv <- tcLookupLcl_maybe tv_nm + ; case mb_tv of + Just (ATyVar _ tv) + -> do { discardResult $ unifyKind (Just hs_tv) + kind (tyVarKind tv) + -- This unify rejects: + -- class C (m :: * -> *) where + -- type F (m :: *) = ... + ; return tv } + + _ -> new_tv tv_nm kind } + where + hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm) + -- Used for error messages only + +-------------------------------------- +-- Binding type/class variables in the +-- kind-checking and typechecking phases +-------------------------------------- + +bindTyClTyVars :: Name + -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a +-- ^ Used for the type variables of a type or class decl +-- in the "kind checking" and "type checking" pass, +-- but not in the initial-kind run. +bindTyClTyVars tycon_name thing_inside + = do { tycon <- tcLookupTcTyCon tycon_name + ; let scoped_prs = tcTyConScopedTyVars tycon + res_kind = tyConResKind tycon + binders = tyConBinders tycon + ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs) + ; tcExtendNameTyVarEnv scoped_prs $ + thing_inside tycon binders res_kind } + + +{- ********************************************************************* +* * + Kind generalisation +* * +********************************************************************* -} + +zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] +zonkAndScopedSort spec_tkvs + = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs + -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv + + -- Do a stable topological sort, following + -- Note [Ordering of implicit variables] in GHC.Rename.HsType + ; return (scopedSort spec_tkvs) } + +-- | Generalize some of the free variables in the given type. +-- All such variables should be *kind* variables; any type variables +-- should be explicitly quantified (with a `forall`) before now. +-- The supplied predicate says which free variables to quantify. +-- But in all cases, +-- generalize only those variables whose TcLevel is strictly greater +-- than the ambient level. This "strictly greater than" means that +-- you likely need to push the level before creating whatever type +-- gets passed here. Any variable whose level is greater than the +-- ambient level but is not selected to be generalized will be +-- promoted. (See [Promoting unification variables] in "GHC.Tc.Solver" +-- and Note [Recipe for checking a signature].) +-- The resulting KindVar are the variables to +-- quantify over, in the correct, well-scoped order. They should +-- generally be Inferred, not Specified, but that's really up to +-- the caller of this function. +kindGeneralizeSome :: (TcTyVar -> Bool) + -> TcType -- ^ needn't be zonked + -> TcM [KindVar] +kindGeneralizeSome should_gen kind_or_type + = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type) + + -- use the "Kind" variant here, as any types we see + -- here will already have all type variables quantified; + -- thus, every free variable is really a kv, never a tv. + ; dvs <- candidateQTyVarsOfKind kind_or_type + + -- So 'dvs' are the variables free in kind_or_type, with a level greater + -- than the ambient level, hence candidates for quantification + -- Next: filter out the ones we don't want to generalize (specified by should_gen) + -- and promote them instead + + ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen) + + ; _ <- promoteTyVarSet to_promote + ; qkvs <- quantifyTyVars dvs' + + ; traceTc "kindGeneralizeSome }" $ + vcat [ text "Kind or type:" <+> ppr kind_or_type + , text "dvs:" <+> ppr dvs + , text "dvs':" <+> ppr dvs' + , text "to_promote:" <+> ppr to_promote + , text "qkvs:" <+> pprTyVars qkvs ] + + ; return qkvs } + +-- | Specialized version of 'kindGeneralizeSome', but where all variables +-- can be generalized. Use this variant when you can be sure that no more +-- constraints on the type's metavariables will arise or be solved. +kindGeneralizeAll :: TcType -- needn't be zonked + -> TcM [KindVar] +kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty + ; kindGeneralizeSome (const True) ty } + +-- | Specialized version of 'kindGeneralizeSome', but where no variables +-- can be generalized, but perhaps some may neeed to be promoted. +-- Use this variant when it is unknowable whether metavariables might +-- later be constrained. +-- +-- To see why this promotion is needed, see +-- Note [Recipe for checking a signature], and especially +-- Note [Promotion in signatures]. +kindGeneralizeNone :: TcType -- needn't be zonked + -> TcM () +kindGeneralizeNone ty + = do { traceTc "kindGeneralizeNone" empty + ; kvs <- kindGeneralizeSome (const False) ty + ; MASSERT( null kvs ) + } + +{- Note [Levels and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = e +with no type signature. We are currently at level i. +We must + * Push the level to level (i+1) + * Allocate a fresh alpha[i+1] for the result type + * Check that e :: alpha[i+1], gathering constraint WC + * Solve WC as far as possible + * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] + * Find the free variables with level > i, in this case gamma[i] + * Skolemise those free variables and quantify over them, giving + f :: forall g. beta[i-1] -> g + * Emit the residiual constraint wrapped in an implication for g, + thus forall g. WC + +All of this happens for types too. Consider + f :: Int -> (forall a. Proxy a -> Int) + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, because it requires a more +polymorphic argument. + +NB: There are no explicit kind variables written in f's signature. +When there are, the renamer adds these kind variables to the list of +variables bound by the forall, so you can indeed have a type that's +higher-rank in its kind. But only by explicit request. + +Note [Kinds of quantified type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyVarBndrsGen quantifies over a specified list of type variables, +*and* over the kind variables mentioned in the kinds of those tyvars. + +Note that we must zonk those kinds (obviously) but less obviously, we +must return type variables whose kinds are zonked too. Example + (a :: k7) where k7 := k9 -> k9 +We must return + [k9, a:k9->k9] +and NOT + [k9, a:k7] +Reason: we're going to turn this into a for-all type, + forall k9. forall (a:k7). blah +which the type checker will then instantiate, and instantiate does not +look through unification variables! + +Hence using zonked_kinds when forming tvs'. + +-} + +----------------------------------- +etaExpandAlgTyCon :: [TyConBinder] + -> Kind -- must be zonked + -> TcM ([TyConBinder], Kind) +-- GADT decls can have a (perhaps partial) kind signature +-- e.g. data T a :: * -> * -> * where ... +-- This function makes up suitable (kinded) TyConBinders for the +-- argument kinds. E.g. in this case it might return +-- ([b::*, c::*], *) +-- Never emits constraints. +-- It's a little trickier than you might think: see +-- Note [TyConBinders for the result kind signature of a data type] +-- See Note [Datatype return kinds] in GHC.Tc.TyCl +etaExpandAlgTyCon tc_bndrs kind + = do { loc <- getSrcSpanM + ; uniqs <- newUniqueSupply + ; rdr_env <- getLocalRdrEnv + ; let new_occs = [ occ + | str <- allNameStrings + , let occ = mkOccName tvName str + , isNothing (lookupLocalRdrOcc rdr_env occ) + -- Note [Avoid name clashes for associated data types] + , not (occ `elem` lhs_occs) ] + new_uniqs = uniqsFromSupply uniqs + subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs)) + ; return (go loc new_occs new_uniqs subst [] kind) } + where + lhs_tvs = map binderVar tc_bndrs + lhs_occs = map getOccName lhs_tvs + + go loc occs uniqs subst acc kind + = case splitPiTy_maybe kind of + Nothing -> (reverse acc, substTy subst kind) + + Just (Anon af arg, kind') + -> go loc occs' uniqs' subst' (tcb : acc) kind' + where + arg' = substTy subst (scaledThing arg) + tv = mkTyVar (mkInternalName uniq occ loc) arg' + subst' = extendTCvInScope subst tv + tcb = Bndr tv (AnonTCB af) + (uniq:uniqs') = uniqs + (occ:occs') = occs + + Just (Named (Bndr tv vis), kind') + -> go loc occs uniqs subst' (tcb : acc) kind' + where + (subst', tv') = substTyVarBndr subst tv + tcb = Bndr tv' (NamedTCB vis) + +-- | A description of whether something is a +-- +-- * @data@ or @newtype@ ('DataDeclSort') +-- +-- * @data instance@ or @newtype instance@ ('DataInstanceSort') +-- +-- * @data family@ ('DataFamilySort') +-- +-- At present, this data type is only consumed by 'checkDataKindSig'. +data DataSort + = DataDeclSort NewOrData + | DataInstanceSort NewOrData + | DataFamilySort + +-- | Checks that the return kind in a data declaration's kind signature is +-- permissible. There are three cases: +-- +-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ +-- declaration, check that the return kind is @Type@. +-- +-- If the declaration is a @newtype@ or @newtype instance@ and the +-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so +-- that a return kind of the form @TYPE r@ (for some @r@) is permitted. +-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl". +-- +-- If dealing with a @data family@ declaration, check that the return kind is +-- either of the form: +-- +-- 1. @TYPE r@ (for some @r@), or +-- +-- 2. @k@ (where @k@ is a bare kind variable; see #12369) +-- +-- See also Note [Datatype return kinds] in "GHC.Tc.TyCl" +checkDataKindSig :: DataSort -> Kind -- any arguments in the kind are stripped off + -> TcM () +checkDataKindSig data_sort kind + = do { dflags <- getDynFlags + ; traceTc "checkDataKindSig" (ppr kind) + ; checkTc (is_TYPE_or_Type dflags || is_kind_var) + (err_msg dflags) } + where + res_kind = snd (tcSplitPiTys kind) + -- Look for the result kind after + -- peeling off any foralls and arrows + + pp_dec :: SDoc + pp_dec = text $ + case data_sort of + DataDeclSort DataType -> "Data type" + DataDeclSort NewType -> "Newtype" + DataInstanceSort DataType -> "Data instance" + DataInstanceSort NewType -> "Newtype instance" + DataFamilySort -> "Data family" + + is_newtype :: Bool + is_newtype = + case data_sort of + DataDeclSort new_or_data -> new_or_data == NewType + DataInstanceSort new_or_data -> new_or_data == NewType + DataFamilySort -> False + + is_data_family :: Bool + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + + tYPE_ok :: DynFlags -> Bool + tYPE_ok dflags = + (is_newtype && xopt LangExt.UnliftedNewtypes dflags) + -- With UnliftedNewtypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE r` since we don't want to accept + -- Constraint or Nat. + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. + || is_data_family + -- If this is a `data family` declaration, we don't need to check if + -- UnliftedNewtypes is enabled, since data family declarations can + -- have return kind `TYPE r` unconditionally (#16827). + + is_TYPE :: Bool + is_TYPE = tcIsRuntimeTypeKind res_kind + + is_Type :: Bool + is_Type = tcIsLiftedTypeKind res_kind + + is_TYPE_or_Type :: DynFlags -> Bool + is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE + | otherwise = is_Type + + -- In the particular case of a data family, permit a return kind of the + -- form `:: k` (where `k` is a bare kind variable). + is_kind_var :: Bool + is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind) + | otherwise = False + + err_msg :: DynFlags -> SDoc + err_msg dflags = + sep [ (sep [ pp_dec <+> + text "has non-" <> + (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind) + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr res_kind) ]) + , if not (tYPE_ok dflags) && is_TYPE && is_newtype && + not (xopt LangExt.UnliftedNewtypes dflags) + then text "Perhaps you intended to use UnliftedNewtypes" + else empty ] + +-- | Checks that the result kind of a class is exactly `Constraint`, rejecting +-- type synonyms and type families that reduce to `Constraint`. See #16826. +checkClassKindSig :: Kind -> TcM () +checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg + where + err_msg :: SDoc + err_msg = + text "Kind signature on a class must end with" <+> ppr constraintKind $$ + text "unobscured by type families" + +tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] +-- Result is in 1-1 correspondence with orig_args +tcbVisibilities tc orig_args + = go (tyConKind tc) init_subst orig_args + where + init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + go _ _ [] + = [] + + go fun_kind subst all_args@(arg : args) + | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind + = case tcb of + Anon af _ -> AnonTCB af : go inner_kind subst args + Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args + where + subst' = extendTCvSubst subst tv arg + + | not (isEmptyTCvSubst subst) + = go (substTy subst fun_kind) init_subst all_args + + | otherwise + = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) + + +{- Note [TyConBinders for the result kind signature of a data type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + data T (a::*) :: * -> forall k. k -> * +we want to generate the extra TyConBinders for T, so we finally get + (a::*) (b::*) (k::*) (c::k) +The function etaExpandAlgTyCon generates these extra TyConBinders from +the result kind signature. + +We need to take care to give the TyConBinders + (a) OccNames that are fresh (because the TyConBinders of a TyCon + must have distinct OccNames + + (b) Uniques that are fresh (obviously) + +For (a) we need to avoid clashes with the tyvars declared by +the user before the "::"; in the above example that is 'a'. +And also see Note [Avoid name clashes for associated data types]. + +For (b) suppose we have + data T :: forall k. k -> forall k. k -> * +where the two k's are identical even up to their uniques. Surprisingly, +this can happen: see #14515. + +It's reasonably easy to solve all this; just run down the list with a +substitution; hence the recursive 'go' function. But it has to be +done. + +Note [Avoid name clashes for associated data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider class C a b where + data D b :: * -> * +When typechecking the decl for D, we'll invent an extra type variable +for D, to fill out its kind. Ideally we don't want this type variable +to be 'a', because when pretty printing we'll get + class C a b where + data D b a0 +(NB: the tidying happens in the conversion to Iface syntax, which happens +as part of pretty-printing a TyThing.) + +That's why we look in the LocalRdrEnv to see what's in scope. This is +important only to get nice-looking output when doing ":info C" in GHCi. +It isn't essential for correctness. + + +************************************************************************ +* * + Partial signatures +* * +************************************************************************ + +-} + +tcHsPartialSigType + :: UserTypeCtxt + -> LHsSigWcType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , Maybe TcType -- Extra-constraints wildcard + , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with + -- the implicitly and explicitly bound type variables + , TcThetaType -- Theta part + , TcType ) -- Tau part +-- See Note [Checking partial type signatures] +tcHsPartialSigType ctxt sig_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty + , HsIB { hsib_ext = implicit_hs_tvs + , hsib_body = hs_ty } <- ib_ty + , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty + = addSigCtxt ctxt hs_ty $ + do { mode <- mkHoleMode TypeLevel HM_Sig + ; (implicit_tvs, (explicit_tvbndrs, (wcs, wcx, theta, tau))) + <- solveLocalEqualities "tcHsPartialSigType" $ + -- See Note [Failure in local type signatures] + tcNamedWildCardBinders sig_wcs $ \ wcs -> + bindImplicitTKBndrs_Tv implicit_hs_tvs $ + bindExplicitTKBndrs_Tv_M mode explicit_hs_tvs $ + do { -- Instantiate the type-class context; but if there + -- is an extra-constraints wildcard, just discard it here + (theta, wcx) <- tcPartialContext mode hs_ctxt + + ; ek <- newOpenTypeKind + ; tau <- addTypeCtxt hs_tau $ + tc_lhs_type mode hs_tau ek + + ; return (wcs, wcx, theta, tau) } + + ; let implicit_tvbndrs = map (mkTyVarBinder SpecifiedSpec) implicit_tvs + + -- No kind-generalization here: + ; kindGeneralizeNone (mkInvisForAllTys implicit_tvbndrs $ + mkInvisForAllTys explicit_tvbndrs $ + mkPhiTy theta $ + tau) + + -- Spit out the wildcards (including the extra-constraints one) + -- as "hole" constraints, so that they'll be reported if necessary + -- See Note [Extra-constraint holes in partial type signatures] + ; mapM_ emitNamedTypeHole wcs + + -- Zonk, so that any nested foralls can "see" their occurrences + -- See Note [Checking partial type signatures], and in particular + -- Note [Levels for wildcards] + ; implicit_tvbndrs <- mapM zonkInvisTVBinder implicit_tvbndrs + ; explicit_tvbndrs <- mapM zonkInvisTVBinder explicit_tvbndrs + ; theta <- mapM zonkTcType theta + ; tau <- zonkTcType tau + + -- We return a proper (Name,InvisTVBinder) environment, to be sure that + -- we bring the right name into scope in the function body. + -- Test case: partial-sigs/should_compile/LocalDefinitionBug + ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvbndrs) + ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvbndrs) + + -- NB: checkValidType on the final inferred type will be + -- done later by checkInferredPolyId. We can't do it + -- here because we don't have a complete type to check + + ; traceTc "tcHsPartialSigType" (ppr tv_prs) + ; return (wcs, wcx, tv_prs, theta, tau) } + +tcPartialContext :: TcTyMode -> HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) +tcPartialContext mode hs_theta + | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta + , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { wc_tv_ty <- setSrcSpan wc_loc $ + tcAnonWildCardOcc mode ty constraintKind + ; theta <- mapM (tc_lhs_pred mode) hs_theta1 + ; return (theta, Just wc_tv_ty) } + | otherwise + = do { theta <- mapM (tc_lhs_pred mode) hs_theta + ; return (theta, Nothing) } + +{- Note [Checking partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is about tcHsPartialSigType. See also +Note [Recipe for checking a signature] + +When we have a partial signature like + f :: forall a. a -> _ +we do the following + +* tcHsPartialSigType does not make quantified type (forall a. blah) + and then instantiate it -- it makes no sense to instantiate a type + with wildcards in it. Rather, tcHsPartialSigType just returns the + 'a' and the 'blah' separately. + + Nor, for the same reason, do we push a level in tcHsPartialSigType. + +* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ + a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider + f :: forall a. a -> _ + g :: forall b. _ -> b + f = g + g = f + They are typechecked as a recursive group, with monomorphic types, + so 'a' and 'b' will get unified together. Very like kind inference + for mutually recursive data types (sans CUSKs or SAKS); see + Note [Cloning for tyvar binders] in GHC.Tc.Gen.HsType + +* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike + the companion CompleteSig) contains the original, as-yet-unchecked + source-code LHsSigWcType + +* Then, for f and g /separately/, we call tcInstSig, which in turn + call tchsPartialSig (defined near this Note). It kind-checks the + LHsSigWcType, creating fresh unification variables for each "_" + wildcard. It's important that the wildcards for f and g are distinct + because they might get instantiated completely differently. E.g. + f,g :: forall a. a -> _ + f x = a + g x = True + It's really as if we'd written two distinct signatures. + +* Nested foralls. See Note [Levels for wildcards] + +* Just as for ordinary signatures, we must solve local equalities and + zonk the type after kind-checking it, to ensure that all the nested + forall binders can "see" their occurrenceds + + Just as for ordinary signatures, this zonk also gets any Refl casts + out of the way of instantiation. Example: #18008 had + foo :: (forall a. (Show a => blah) |> Refl) -> _ + and that Refl cast messed things up. See #18062. + +Note [Levels for wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b. (forall a. a -> _) -> b +We do /not/ allow the "_" to be instantiated to 'a'; although we do +(as before) allow it to be instantiated to the (top level) 'b'. +Why not? Suppose + f x = (x True, x 'c') + +During typecking the RHS we must instantiate that (forall a. a -> _), +so we must know /precisely/ where all the a's are; they must not be +hidden under (possibly-not-yet-filled-in) unification variables! + +We achieve this as follows: + +- For /named/ wildcards such sas + g :: forall b. (forall la. a -> _x) -> b + there is no problem: we create them at the outer level (ie the + ambient level of teh signature itself), and push the level when we + go inside a forall. So now the unification variable for the "_x" + can't unify with skolem 'a'. + +- For /anonymous/ wildcards, such as 'f' above, we carry the ambient + level of the signature to the hole in the TcLevel part of the + mode_holes field of TcTyMode. Then, in tcAnonWildCardOcc we us that + level (and /not/ the level ambient at the occurrence of "_") to + create the unification variable for the wildcard. That is the sole + purpose of the TcLevel in the mode_holes field: to transport the + ambient level of the signature down to the anonymous wildcard + occurrences. + +Note [Extra-constraint holes in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (_) => a -> a + f x = ... + +* The renamer leaves '_' untouched. + +* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in + tcWildCardBinders. + +* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar + with the inferred constraints, e.g. (Eq a, Show a) + +* GHC.Tc.Errors.mkHoleError finally reports the error. + +An annoying difficulty happens if there are more than 62 inferred +constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. +Where do we find the TyCon? For good reasons we only have constraint +tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types). So how +can we make a 70-tuple? This was the root cause of #14217. + +It's incredibly tiresome, because we only need this type to fill +in the hole, to communicate to the error reporting machinery. Nothing +more. So I use a HACK: + +* I make an /ordinary/ tuple of the constraints, in + GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because + ordinary tuples can't contain constraints, but it works fine. And for + ordinary tuples we don't have the same limit as for constraint + tuples (which need selectors and an associated class). + +* Because it is ill-kinded, it trips an assert in writeMetaTyVar, + so now I disable the assertion if we are writing a type of + kind Constraint. (That seldom/never normally happens so we aren't + losing much.) + +Result works fine, but it may eventually bite us. + + +************************************************************************ +* * + Pattern signatures (i.e signatures that occur in patterns) +* * +********************************************************************* -} + +tcHsPatSigType :: UserTypeCtxt + -> HsPatSigType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +-- Used for type-checking type signatures in +-- (a) patterns e.g f (x::Int) = e +-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +-- +-- This may emit constraints +-- See Note [Recipe for checking a signature] +tcHsPatSigType ctxt + (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } + , hsps_body = hs_ty }) + = addSigCtxt ctxt hs_ty $ + do { sig_tkv_prs <- mapM new_implicit_tv sig_ns + ; mode <- mkHoleMode TypeLevel HM_Sig + ; (wcs, sig_ty) + <- addTypeCtxt hs_ty $ + solveLocalEqualities "tcHsPatSigType" $ + -- See Note [Failure in local type signatures] + -- and c.f #16033 + tcNamedWildCardBinders sig_wcs $ \ wcs -> + tcExtendNameTyVarEnv sig_tkv_prs $ + do { ek <- newOpenTypeKind + ; sig_ty <- tc_lhs_type mode hs_ty ek + ; return (wcs, sig_ty) } + + ; mapM_ emitNamedTypeHole wcs + + -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty + -- contains a forall). Promote these. + -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... + -- When we instantiate x, we have to compare the kind of the argument + -- to a's kind, which will be a metavariable. + -- kindGeneralizeNone does this: + ; kindGeneralizeNone sig_ty + ; sig_ty <- zonkTcType sig_ty + ; checkValidType ctxt sig_ty + + ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) + ; return (wcs, sig_tkv_prs, sig_ty) } + where + new_implicit_tv name + = do { kind <- newMetaKindVar + ; tv <- case ctxt of + RuleSigCtxt {} -> newSkolemTyVar name kind + _ -> newPatSigTyVar name kind + -- See Note [Typechecking pattern signature binders] + -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) + ; return (name, tv) } + +{- Note [Typechecking pattern signature binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Type variables in the type environment] in GHC.Tc.Utils. +Consider + + data T where + MkT :: forall a. a -> (a -> Int) -> T + + f :: T -> ... + f (MkT x (f :: b -> c)) = + +Here + * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', + It must be a skolem so that it retains its identity, and + GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem. + + * The type signature pattern (f :: b -> c) makes freshs meta-tyvars + beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the + environment + + * Then unification makes beta := a_sk, gamma := Int + That's why we must make beta and gamma a MetaTv, + not a SkolemTv, so that it can unify to a_sk (or Int, respectively). + + * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, + so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, + +Another example (#13881): + fl :: forall (l :: [a]). Sing l -> Sing l + fl (SNil :: Sing (l :: [y])) = SNil +When we reach the pattern signature, 'l' is in scope from the +outer 'forall': + "a" :-> a_sk :: * + "l" :-> l_sk :: [a_sk] +We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check +the pattern signature + Sing (l :: [y]) +That unifies y_sig := a_sk. We return from tcHsPatSigType with +the pair ("y" :-> y_sig). + +For RULE binders, though, things are a bit different (yuk). + RULE "foo" forall (x::a) (y::[a]). f x y = ... +Here this really is the binding site of the type variable so we'd like +to use a skolem, so that we get a complaint if we unify two of them +together. Hence the new_tv function in tcHsPatSigType. + + +************************************************************************ +* * + Checking kinds +* * +************************************************************************ + +-} + +unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) +unifyKinds rn_tys act_kinds + = do { kind <- newMetaKindVar + ; let check rn_ty (ty, act_kind) + = checkExpectedKind (unLoc rn_ty) ty act_kind kind + ; tys' <- zipWithM check rn_tys act_kinds + ; return (tys', kind) } + +{- +************************************************************************ +* * + Sort checking kinds +* * +************************************************************************ + +tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. +It does sort checking and desugaring at the same time, in one single pass. +-} + +tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind +tcLHsKindSig ctxt hs_kind + = tc_lhs_kind_sig (mkMode KindLevel) ctxt hs_kind + +tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind +tc_lhs_kind_sig mode ctxt hs_kind +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +-- Result is zonked + = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $ + solveLocalEqualities "tcLHsKindSig" $ + tc_lhs_type mode hs_kind liftedTypeKind + ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) + -- No generalization: + ; kindGeneralizeNone kind + ; kind <- zonkTcType kind + -- This zonk is very important in the case of higher rank kinds + -- E.g. #13879 f :: forall (p :: forall z (y::z). ). + -- + -- When instantiating p's kind at occurrences of p in + -- it's crucial that the kind we instantiate is fully zonked, + -- else we may fail to substitute properly + + ; checkValidType ctxt kind + ; traceTc "tcLHsKindSig2" (ppr kind) + ; return kind } + +promotionErr :: Name -> PromotionErr -> TcM a +promotionErr name err + = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + 2 (parens reason)) + where + reason = case err of + ConstrainedDataConPE pred + -> text "it has an unpromotable context" + <+> quotes (ppr pred) + FamDataConPE -> text "it comes from a data family instance" + NoDataKindsTC -> text "perhaps you intended to use DataKinds" + NoDataKindsDC -> text "perhaps you intended to use DataKinds" + PatSynPE -> text "pattern synonyms cannot be promoted" + _ -> text "it is defined and used in the same recursive group" + +{- +************************************************************************ +* * + Error messages and such +* * +************************************************************************ +-} + + +-- | If the inner action emits constraints, report them as errors and fail; +-- otherwise, propagates the return value. Useful as a wrapper around +-- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be +-- another chance to solve constraints +failIfEmitsConstraints :: TcM a -> TcM a +failIfEmitsConstraints thing_inside + = checkNoErrs $ -- We say that we fail if there are constraints! + -- c.f same checkNoErrs in solveEqualities + do { (res, lie) <- captureConstraints thing_inside + ; reportAllUnsolved lie + ; return res + } + +-- | Make an appropriate message for an error in a function argument. +-- Used for both expressions and types. +funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc +funAppCtxt fun arg arg_no + = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), + quotes (ppr fun) <> text ", namely"]) + 2 (quotes (ppr arg)) + +-- | Add a "In the data declaration for T" or some such. +addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a +addTyConFlavCtxt name flav + = addErrCtxt $ hsep [ text "In the", ppr flav + , text "declaration for", quotes (ppr name) ] diff --git a/GHC/Tc/Gen/Match.hs b/GHC/Tc/Gen/Match.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Match.hs @@ -0,0 +1,1110 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck some @Matches@ +module GHC.Tc.Gen.Match + ( tcMatchesFun + , tcGRHS + , tcGRHSsPat + , tcMatchesCase + , tcMatchLambda + , TcMatchCtxt(..) + , TcStmtChecker + , TcExprStmtChecker + , TcCmdStmtChecker + , tcStmts + , tcStmtsAndThen + , tcDoStmts + , tcBody + , tcDoStmt + , tcGuardStmt + ) +where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC + , tcMonoExpr, tcMonoExprNC, tcExpr + , tcCheckMonoExpr, tcCheckMonoExprNC + , tcCheckPolyExpr, tcCheckId ) + +import GHC.Types.Basic (LexicalFixity(..)) +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Unify +import GHC.Tc.Types.Origin +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Types.Name +import GHC.Builtin.Types +import GHC.Types.Id +import GHC.Core.TyCon +import GHC.Builtin.Types.Prim +import GHC.Tc.Types.Evidence +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.SrcLoc +import GHC.Driver.Session ( getDynFlags ) + +-- Create chunkified tuple tybes for monad comprehensions +import GHC.Core.Make + +import Control.Monad +import Control.Arrow ( second ) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{tcMatchesFun, tcMatchesCase} +* * +************************************************************************ + +@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a +@FunMonoBind@. The second argument is the name of the function, which +is used in error messages. It checks that all the equations have the +same number of arguments before using @tcMatches@ to do the work. +-} + +tcMatchesFun :: Located Name + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> ExpRhoType -- Expected type of function + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) + -- Returns type of body +tcMatchesFun fn@(L _ fun_name) matches exp_ty + = do { -- Check that they all have the same no of arguments + -- Location is in the monad, set the caller so that + -- any inter-equation error messages get some vaguely + -- sensible location. Note: we have to do this odd + -- ann-grabbing, because we don't always have annotations in + -- hand when we call tcMatchesFun... + traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) + ; checkArgs fun_name matches + + ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> + -- NB: exp_type may be polymorphic, but + -- matchExpectedFunTys can cope with that + tcScalingUsage Many $ + -- toplevel bindings and let bindings are, at the + -- moment, always unrestricted. The value being bound + -- must, accordingly, be unrestricted. Hence them + -- being scaled by Many. When let binders come with a + -- multiplicity, then @tcMatchesFun@ will have to take + -- a multiplicity argument, and scale accordingly. + tcMatches match_ctxt pat_tys rhs_ty matches } + where + arity = matchGroupArity matches + herald = text "The equation(s) for" + <+> quotes (ppr fun_name) <+> text "have" + ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True + -- But that's wrong for f :: Int -> forall a. blah + what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness } + match_ctxt = MC { mc_what = what, mc_body = tcBody } + strictness + | [L _ match] <- unLoc $ mg_alts matches + , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match + = SrcStrict + | otherwise + = NoSrcStrict + +{- +@tcMatchesCase@ doesn't do the argument-count check because the +parser guarantees that each equation has exactly one argument. +-} + +tcMatchesCase :: (Outputable (body GhcRn)) => + TcMatchCtxt body -- Case context + -> Scaled TcSigmaType -- Type of scrutinee + -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives + -> ExpRhoType -- Type of whole case expressions + -> TcM (MatchGroup GhcTc (Located (body GhcTc))) + -- Translated alternatives + -- wrapper goes from MatchGroup's ty to expected ty + +tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty + = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches + +tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify + -> TcMatchCtxt HsExpr + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> ExpRhoType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcMatchLambda herald match_ctxt match res_ty + = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> + tcMatches match_ctxt pat_tys rhs_ty match + where + n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case + | otherwise = matchGroupArity match + +-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. + +tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType + -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) +-- Used for pattern bindings +tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) + where + match_ctxt = MC { mc_what = PatBindRhs, + mc_body = tcBody } + +{- ********************************************************************* +* * + tcMatch +* * +********************************************************************* -} + +data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is + mc_body :: Located (body GhcRn) -- Type checker for a body of + -- an alternative + -> ExpRhoType + -> TcM (Located (body GhcTc)) } + +-- | Type-check a MatchGroup. +tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body + -> [Scaled ExpSigmaType] -- Expected pattern types + -> ExpRhoType -- Expected result-type of the Match. + -> MatchGroup GhcRn (Located (body GhcRn)) + -> TcM (MatchGroup GhcTc (Located (body GhcTc))) + +tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches + , mg_origin = origin }) + | null matches -- Deal with case e of {} + -- Since there are no branches, no one else will fill in rhs_ty + -- when in inference mode, so we must do it ourselves, + -- here, using expTypeToType + = do { tcEmitBindingUsage bottomUE + ; pat_tys <- mapM scaledExpTypeToType pat_tys + ; rhs_ty <- expTypeToType rhs_ty + ; return (MG { mg_alts = L l [] + , mg_ext = MatchGroupTc pat_tys rhs_ty + , mg_origin = origin }) } + + | otherwise + = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches + ; let (usages,matches') = unzip umatches + ; tcEmitBindingUsage $ supUEs usages + ; pat_tys <- mapM readScaledExpType pat_tys + ; rhs_ty <- readExpType rhs_ty + ; return (MG { mg_alts = L l matches' + , mg_ext = MatchGroupTc pat_tys rhs_ty + , mg_origin = origin }) } + +------------- +tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body + -> [Scaled ExpSigmaType] -- Expected pattern types + -> ExpRhoType -- Expected result-type of the Match. + -> LMatch GhcRn (Located (body GhcRn)) + -> TcM (LMatch GhcTc (Located (body GhcTc))) + +tcMatch ctxt pat_tys rhs_ty match + = wrapLocM (tc_match ctxt pat_tys rhs_ty) match + where + tc_match ctxt pat_tys rhs_ty + match@(Match { m_pats = pats, m_grhss = grhss }) + = add_match_ctxt match $ + do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ + tcGRHSs ctxt grhss rhs_ty + ; return (Match { m_ext = noExtField + , m_ctxt = mc_what ctxt, m_pats = pats' + , m_grhss = grhss' }) } + + -- For (\x -> e), tcExpr has already said "In the expression \x->e" + -- so we don't want to add "In the lambda abstraction \x->e" + add_match_ctxt match thing_inside + = case mc_what ctxt of + LambdaExpr -> thing_inside + _ -> addErrCtxt (pprMatchInCtxt match) thing_inside + +------------- +tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType + -> TcM (GRHSs GhcTc (Located (body GhcTc))) + +-- Notice that we pass in the full res_ty, so that we get +-- good inference from simple things like +-- f = \(x::forall a.a->a) -> +-- We used to force it to be a monotype when there was more than one guard +-- but we don't need to do that any more + +tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty + = do { (binds', ugrhss) + <- tcLocalBinds binds $ + mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss + ; let (usages, grhss') = unzip ugrhss + ; tcEmitBindingUsage $ supUEs usages + ; return (GRHSs noExtField grhss' (L l binds')) } + +------------- +tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) + -> TcM (GRHS GhcTc (Located (body GhcTc))) + +tcGRHS ctxt res_ty (GRHS _ guards rhs) + = do { (guards', rhs') + <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ + mc_body ctxt rhs + ; return (GRHS noExtField guards' rhs') } + where + stmt_ctxt = PatGuard (mc_what ctxt) + +{- +************************************************************************ +* * +\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} +* * +************************************************************************ +-} + +tcDoStmts :: HsStmtContext GhcRn + -> Located [LStmt GhcRn (LHsExpr GhcRn)] + -> ExpRhoType + -> TcM (HsExpr GhcTc) -- Returns a HsDo +tcDoStmts ListComp (L l stmts) res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, elt_ty) <- matchExpectedListTy res_ty + ; let list_ty = mkListTy elt_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts + (mkCheckExpType elt_ty) + ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } + +tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty + = do { stmts' <- tcStmts doExpr tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty doExpr (L l stmts')) } + +tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty + = do { stmts' <- tcStmts mDoExpr tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty mDoExpr (L l stmts')) } + +tcDoStmts MonadComp (L l stmts) res_ty + = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty MonadComp (L l stmts')) } + +tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) + +tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcBody body res_ty + = do { traceTc "tcBody" (ppr res_ty) + ; tcMonoExpr body res_ty + } + +{- +************************************************************************ +* * +\subsection{tcStmts} +* * +************************************************************************ +-} + +type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType +type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType + +type TcStmtChecker body rho_type + = forall thing. HsStmtContext GhcRn + -> Stmt GhcRn (Located (body GhcRn)) + -> rho_type -- Result type for comprehension + -> (rho_type -> TcM thing) -- Checker for what follows the stmt + -> TcM (Stmt GhcTc (Located (body GhcTc)), thing) + +tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn + -> TcStmtChecker body rho_type -- NB: higher-rank type + -> [LStmt GhcRn (Located (body GhcRn))] + -> rho_type + -> TcM [LStmt GhcTc (Located (body GhcTc))] +tcStmts ctxt stmt_chk stmts res_ty + = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ + const (return ()) + ; return stmts' } + +tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn + -> TcStmtChecker body rho_type -- NB: higher-rank type + -> [LStmt GhcRn (Located (body GhcRn))] + -> rho_type + -> (rho_type -> TcM thing) + -> TcM ([LStmt GhcTc (Located (body GhcTc))], thing) + +-- Note the higher-rank type. stmt_chk is applied at different +-- types in the equations for tcStmts + +tcStmtsAndThen _ _ [] res_ty thing_inside + = do { thing <- thing_inside res_ty + ; return ([], thing) } + +-- LetStmts are handled uniformly, regardless of context +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) + res_ty thing_inside + = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside + ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } + +-- Don't set the error context for an ApplicativeStmt. It ought to be +-- possible to do this with a popErrCtxt in the tcStmt case for +-- ApplicativeStmt, but it did something strange and broke a test (ado002). +tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside + | ApplicativeStmt{} <- stmt + = do { (stmt', (stmts', thing)) <- + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ + thing_inside + ; return (L loc stmt' : stmts', thing) } + + -- For the vanilla case, handle the location-setting part + | otherwise + = do { (stmt', (stmts', thing)) <- + setSrcSpan loc $ + addErrCtxt (pprStmtInCtxt ctxt stmt) $ + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + popErrCtxt $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ + thing_inside + ; return (L loc stmt' : stmts', thing) } + +--------------------------------------------------- +-- Pattern guards +--------------------------------------------------- + +tcGuardStmt :: TcExprStmtChecker +tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside + = do { guard' <- tcScalingUsage Many $ tcCheckMonoExpr guard boolTy + -- Scale the guard to Many (see #19120 and #19193) + ; thing <- thing_inside res_ty + ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } + +tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside + = do { -- The Many on the next line and the unrestricted on the line after + -- are linked. These must be the same multiplicity. Consider + -- x <- rhs -> u + -- + -- The multiplicity of x in u must be the same as the multiplicity at + -- which the rhs has been consumed. When solving #18738, we want these + -- two multiplicity to still be the same. + (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs + -- Stmt has a context already + ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) + pat (unrestricted rhs_ty) $ + thing_inside res_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +tcGuardStmt _ stmt _ _ + = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- List comprehensions +-- (no rebindable syntax) +--------------------------------------------------- + +-- Dealt with separately, rather than by tcMcStmt, because +-- a) We have special desugaring rules for list comprehensions, +-- which avoid creating intermediate lists. They in turn +-- assume that the bind/return operations are the regular +-- polymorphic ones, and in particular don't have any +-- coercion matching stuff in them. It's hard to avoid the +-- potential for non-trivial coercions in tcMcStmt + +tcLcStmt :: TyCon -- The list type constructor ([]) + -> TcExprStmtChecker + +tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside + = do { body' <- tcMonoExprNC body elt_ty + ; thing <- thing_inside (panic "tcLcStmt: thing_inside") + ; return (LastStmt x body' noret noSyntaxExpr, thing) } + +-- A generator, pat <- rhs +tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside + = do { pat_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + thing_inside elt_ty + ; return (mkTcBindStmt pat' rhs', thing) } + +-- A boolean guard +tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside + = do { rhs' <- tcCheckMonoExpr rhs boolTy + ; thing <- thing_inside elt_ty + ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } + +-- ParStmt: See notes with tcMcStmt +tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside + = do { (pairs', thing) <- loop bndr_stmts_s + ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } + where + -- loop :: [([LStmt GhcRn], [GhcRn])] + -- -> TcM ([([LStmt GhcTc], [GhcTc])], thing) + loop [] = do { thing <- thing_inside elt_ty + ; return ([], thing) } -- matching in the branches + + loop (ParStmtBlock x stmts names _ : pairs) + = do { (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> + do { ids <- tcLookupLocalIds names + ; (pairs', thing) <- loop pairs + ; return (ids, pairs', thing) } + ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } + +tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts + , trS_bndrs = bindersMap + , trS_by = by, trS_using = using }) elt_ty thing_inside + = do { let (bndr_names, n_bndr_names) = unzip bindersMap + unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) + -- The inner 'stmts' lack a LastStmt, so the element type + -- passed in to tcStmtsAndThen is never looked at + ; (stmts', (bndr_ids, by')) + <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do + { by' <- traverse tcInferRho by + ; bndr_ids <- tcLookupLocalIds bndr_names + ; return (bndr_ids, by') } + + ; let m_app ty = mkTyConApp m_tc [ty] + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) + -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm + ; let n_app = case form of + ThenForm -> (\ty -> ty) + _ -> m_app + + by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present + by_arrow = case by' of + Nothing -> \ty -> ty + Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTyMany` e_ty) `mkVisFunTyMany` ty + + tup_ty = mkBigCoreVarTupTy bndr_ids + poly_arg_ty = m_app alphaTy + poly_res_ty = m_app (n_app alphaTy) + using_poly_ty = mkInfForAllTy alphaTyVar $ + by_arrow $ + poly_arg_ty `mkVisFunTyMany` poly_res_ty + + ; using' <- tcCheckPolyExpr using using_poly_ty + ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in GHC.Hs.Expr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = fmap fst by', trS_using = final_using + , trS_ret = noSyntaxExpr + , trS_bind = noSyntaxExpr + , trS_fmap = noExpr + , trS_ext = unitTy + , trS_form = form }, thing) } + +tcLcStmt _ _ stmt _ _ + = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Monad comprehensions +-- (supports rebindable syntax) +--------------------------------------------------- + +tcMcStmt :: TcExprStmtChecker + +tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside + = do { (body', return_op') + <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ + \ [a_ty] [mult]-> + tcScalingUsage mult $ tcCheckMonoExprNC body a_ty + ; thing <- thing_inside (panic "tcMcStmt: thing_inside") + ; return (LastStmt x body' noret return_op', thing) } + +-- Generators for monad comprehensions ( pat <- rhs ) +-- +-- [ body | q <- gen ] -> gen :: m a +-- q :: a +-- + +tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + = do { ((rhs', pat_mult, pat', thing, new_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn) + [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] -> + do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', pat_mult, pat', thing, new_res_ty) } + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> + tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty + + ; let xbstc = XBindStmtTc + { xbstc_bindOp = bind_op' + , xbstc_boundResultType = new_res_ty + , xbstc_boundResultMult = pat_mult + , xbstc_failOp = fail_op' + } + ; return (BindStmt xbstc pat' rhs', thing) } + +-- Boolean expressions. +-- +-- [ body | stmts, expr ] -> expr :: m Bool +-- +tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- guard_op :: test_ty -> rhs_ty + -- then_op :: rhs_ty -> new_res_ty -> res_ty + -- Where test_ty is, for example, Bool + ; ((thing, rhs', rhs_ty, guard_op'), then_op') + <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] -> + do { (rhs', guard_op') + <- tcScalingUsage rhs_mult $ + tcSyntaxOp MCompOrigin guard_op [SynAny] + (mkCheckExpType rhs_ty) $ + \ [test_ty] [test_mult] -> + tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty + ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) + ; return (thing, rhs', rhs_ty, guard_op') } + ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } + +-- Grouping statements +-- +-- [ body | stmts, then group by e using f ] +-- -> e :: t +-- f :: forall a. (a -> t) -> m a -> m (m a) +-- [ body | stmts, then group using f ] +-- -> f :: forall a. m a -> m (m a) + +-- We type [ body | (stmts, group by e using f), ... ] +-- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... +-- +-- We type the functions as follows: +-- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) +-- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) +-- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) +-- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) +-- +tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap + , trS_by = by, trS_using = using, trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }) res_ty thing_inside + = do { m1_ty <- newFlexiTyVarTy typeToTypeKind + ; m2_ty <- newFlexiTyVarTy typeToTypeKind + ; tup_ty <- newFlexiTyVarTy liftedTypeKind + ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm + ; n_app <- case form of + ThenForm -> return (\ty -> ty) + _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind + ; return (n_ty `mkAppTy`) } + ; let by_arrow :: Type -> Type + -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) + -- or res ('by' absent) + by_arrow = case by of + Nothing -> \res -> res + Just {} -> \res -> (alphaTy `mkVisFunTyMany` by_e_ty) `mkVisFunTyMany` res + + poly_arg_ty = m1_ty `mkAppTy` alphaTy + using_arg_ty = m1_ty `mkAppTy` tup_ty + poly_res_ty = m2_ty `mkAppTy` n_app alphaTy + using_res_ty = m2_ty `mkAppTy` n_app tup_ty + using_poly_ty = mkInfForAllTy alphaTyVar $ + by_arrow $ + poly_arg_ty `mkVisFunTyMany` poly_res_ty + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let (bndr_names, n_bndr_names) = unzip bindersMap + ; (stmts', (bndr_ids, by', return_op')) <- + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts + (mkCheckExpType using_arg_ty) $ \res_ty' -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e' <- tcCheckMonoExpr e by_e_ty + ; return (Just e') } + + -- Find the Ids (and hence types) of all old binders + ; bndr_ids <- tcLookupLocalIds bndr_names + + -- 'return' is only used for the binders, so we know its type. + -- return :: (a,b,c,..) -> m (a,b,c,..) + ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op + [synKnownType (mkBigCoreVarTupTy bndr_ids)] + res_ty' $ \ _ _ -> return () + + ; return (bndr_ids, by', return_op') } + + --------------- Typecheck the 'bind' function ------------- + -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType using_res_ty + , synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ] + res_ty $ \ _ _ -> return () + + --------------- Typecheck the 'fmap' function ------------- + ; fmap_op' <- case form of + ThenForm -> return noExpr + _ -> fmap unLoc . tcCheckPolyExpr (noLoc fmap_op) $ + mkInfForAllTy alphaTyVar $ + mkInfForAllTy betaTyVar $ + (alphaTy `mkVisFunTyMany` betaTy) + `mkVisFunTyMany` (n_app alphaTy) + `mkVisFunTyMany` (n_app betaTy) + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + + ; using' <- tcCheckPolyExpr using using_poly_ty + ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' + + --------------- Building the bindersMap ---------------- + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in GHC.Hs.Expr + n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids $ + thing_inside (mkCheckExpType new_res_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = by', trS_using = final_using + , trS_ret = return_op', trS_bind = bind_op' + , trS_ext = n_app tup_ty + , trS_fmap = fmap_op', trS_form = form }, thing) } + +-- A parallel set of comprehensions +-- [ (g x, h x) | ... ; let g v = ... +-- | ... ; let h v = ... ] +-- +-- It's possible that g,h are overloaded, so we need to feed the LIE from the +-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). +-- Similarly if we had an existential pattern match: +-- +-- data T = forall a. Show a => C a +-- +-- [ (show x, show y) | ... ; C x <- ... +-- | ... ; C y <- ... ] +-- +-- Then we need the LIE from (show x, show y) to be simplified against +-- the bindings for x and y. +-- +-- It's difficult to do this in parallel, so we rely on the renamer to +-- ensure that g,h and x,y don't duplicate, and simply grow the environment. +-- So the binders of the first parallel group will be in scope in the second +-- group. But that's fine; there's no shadowing to worry about. +-- +-- Note: The `mzip` function will get typechecked via: +-- +-- ParStmt [st1::t1, st2::t2, st3::t3] +-- +-- mzip :: m st1 +-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call +-- -> m (st1, (st2, st3)) +-- +tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside + = do { m_ty <- newFlexiTyVarTy typeToTypeKind + + ; let mzip_ty = mkInfForAllTys [alphaTyVar, betaTyVar] $ + (m_ty `mkAppTy` alphaTy) + `mkVisFunTyMany` + (m_ty `mkAppTy` betaTy) + `mkVisFunTyMany` + (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) + ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLoc mzip_op) mzip_ty + + -- type dummies since we don't know all binder types yet + ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) + [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] + + -- Typecheck bind: + ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] + tuple_ty = mk_tuple_ty tup_tys + + ; (((blocks', thing), inner_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType (m_ty `mkAppTy` tuple_ty) + , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ + \ [inner_res_ty] _ -> + do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) + tup_tys bndr_stmts_s + ; return (stuff, inner_res_ty) } + + ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } + + where + mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys + + -- loop :: Type -- m_ty + -- -> ExpRhoType -- inner_res_ty + -- -> [TcType] -- tup_tys + -- -> [ParStmtBlock Name] + -- -> TcM ([([LStmt GhcTc], [TcId])], thing) + loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty + ; return ([], thing) } + -- matching in the branches + + loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) + (ParStmtBlock x stmts names return_op : pairs) + = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in + ; (stmts', (ids, return_op', pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ + \m_tup_ty' -> + do { ids <- tcLookupLocalIds names + ; let tup_ty = mkBigCoreVarTupTy ids + ; (_, return_op') <- + tcSyntaxOp MCompOrigin return_op + [synKnownType tup_ty] m_tup_ty' $ + \ _ _ -> return () + ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs + ; return (ids, return_op', pairs', thing) } + ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } + loop _ _ _ _ = panic "tcMcStmt.loop" + +tcMcStmt _ stmt _ _ + = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Do-notation +-- (supports rebindable syntax) +--------------------------------------------------- + +tcDoStmt :: TcExprStmtChecker + +tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside + = do { body' <- tcMonoExprNC body res_ty + ; thing <- thing_inside (panic "tcDoStmt: thing_inside") + ; return (LastStmt x body' noret noSyntaxExpr, thing) } + +tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty + -- This level of generality is needed for using do-notation + -- in full generality; see #1537 + + ((rhs', pat_mult, pat', new_res_ty, thing), bind_op') + <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] -> + do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', pat_mult, pat', new_res_ty, thing) } + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> + tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty + ; let xbstc = XBindStmtTc + { xbstc_bindOp = bind_op' + , xbstc_boundResultType = new_res_ty + , xbstc_boundResultMult = pat_mult + , xbstc_failOp = fail_op' + } + ; return (BindStmt xbstc pat' rhs', thing) } + +tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside + = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ + thing_inside . mkCheckExpType + ; ((pairs', body_ty, thing), mb_join') <- case mb_join of + Nothing -> (, Nothing) <$> tc_app_stmts res_ty + Just join_op -> + second Just <$> + (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ + \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) + + ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } + +tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside + = do { -- Deal with rebindable syntax; + -- (>>) :: rhs_ty -> new_res_ty -> res_ty + ; ((rhs', rhs_ty, thing), then_op') + <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] -> + do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', rhs_ty, thing) } + ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } + +tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names, recS_ret_fn = ret_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) + res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith (\n t -> mkLocalId n Many t) tup_names tup_elt_tys + -- Many because it's a recursive definition + tup_ty = mkBigCoreTupTy tup_elt_tys + + ; tcExtendIdEnv tup_ids $ do + { ((stmts', (ret_op', tup_rets)), stmts_ty) + <- tcInfer $ \ exp_ty -> + tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> + do { tup_rets <- zipWithM tcCheckId tup_names + (map mkCheckExpType tup_elt_tys) + -- Unify the types of the "final" Ids (which may + -- be polymorphic) with those of "knot-tied" Ids + ; (_, ret_op') + <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] + inner_res_ty $ \_ _ -> return () + ; return (ret_op', tup_rets) } + + ; ((_, mfix_op'), mfix_res_ty) + <- tcInfer $ \ exp_ty -> + tcSyntaxOp DoOrigin mfix_op + [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $ + \ _ _ -> return () + + ; ((thing, new_res_ty), bind_op') + <- tcSyntaxOp DoOrigin bind_op + [ synKnownType mfix_res_ty + , SynFun (synKnownType tup_ty) SynRho ] + res_ty $ + \ [new_res_ty] _ -> + do { thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (thing, new_res_ty) } + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), + ppr later_ids <+> ppr (map idType later_ids)] + ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' + , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' + , recS_ext = RecStmtTc + { recS_bind_ty = new_res_ty + , recS_later_rets = [] + , recS_rec_rets = tup_rets + , recS_ret_ty = stmts_ty} }, thing) + }} + +tcDoStmt _ stmt _ _ + = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) + + + +--------------------------------------------------- +-- MonadFail Proposal warnings +--------------------------------------------------- + +-- The idea behind issuing MonadFail warnings is that we add them whenever a +-- failable pattern is encountered. However, instead of throwing a type error +-- when the constraint cannot be satisfied, we only issue a warning in +-- "GHC.Tc.Errors". + +tcMonadFailOp :: CtOrigin + -> LPat GhcTc + -> SyntaxExpr GhcRn -- The fail op + -> TcType -- Type of the whole do-expression + -> TcRn (FailOperator GhcTc) -- Typechecked fail op +-- Get a 'fail' operator expression, to use if the pattern match fails. +-- This won't be used in cases where we've already determined the pattern +-- match can't fail (so the fail op is Nothing), however, it seems that the +-- isIrrefutableHsPat test is still required here for some reason I haven't +-- yet determined. +tcMonadFailOp orig pat fail_op res_ty = do + dflags <- getDynFlags + if isIrrefutableHsPat dflags pat + then return Nothing + else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] + (mkCheckExpType res_ty) $ \_ _ -> return ()) + +{- +Note [Treat rebindable syntax first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking + do { bar; ... } :: IO () +we want to typecheck 'bar' in the knowledge that it should be an IO thing, +pushing info from the context into the RHS. To do this, we check the +rebindable syntax first, and push that information into (tcLExprNC rhs). +Otherwise the error shows up when checking the rebindable syntax, and +the expected/inferred stuff is back to front (see #3613). + +Note [typechecking ApplicativeStmt] + +join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) + +fresh type variables: + pat_ty_1..pat_ty_n + exp_ty_1..exp_ty_n + t_1..t_(n-1) + +body :: body_ty +(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty +pat_i :: pat_ty_i +e_i :: exp_ty_i +<$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1 +<*>_i :: t_(i-1) -> exp_ty_i -> t_i +join :: tn -> res_ty +-} + +tcApplicativeStmts + :: HsStmtContext GhcRn + -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] + -> ExpRhoType -- rhs_ty + -> (TcRhoType -> TcM t) -- thing_inside + -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t) + +tcApplicativeStmts ctxt pairs rhs_ty thing_inside + = do { body_ty <- newFlexiTyVarTy liftedTypeKind + ; let arity = length pairs + ; ts <- replicateM (arity-1) $ newInferExpType + ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind + ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind + ; let fun_ty = mkVisFunTysMany pat_tys body_ty + + -- NB. do the <$>,<*> operators first, we don't want type errors here + -- i.e. goOps before goArgs + -- See Note [Treat rebindable syntax first] + ; let (ops, args) = unzip pairs + ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys) + + -- Typecheck each ApplicativeArg separately + -- See Note [ApplicativeDo and constraints] + ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) + + -- Bring into scope all the things bound by the args, + -- and typecheck the thing_inside + -- See Note [ApplicativeDo and constraints] + ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $ + thing_inside body_ty + + ; return (zip ops' args', body_ty, res) } + where + goOps _ [] = return [] + goOps t_left ((op,t_i,exp_ty) : ops) + = do { (_, op') + <- tcSyntaxOp DoOrigin op + [synKnownType t_left, synKnownType exp_ty] t_i $ + \ _ _ -> return () + ; t_i <- readExpType t_i + ; ops' <- goOps t_i ops + ; return (op' : ops') } + + goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) + -> TcM (ApplicativeArg GhcTc) + + goArg body_ty (ApplicativeArgOne + { xarg_app_arg_one = fail_op + , app_arg_pattern = pat + , arg_expr = rhs + , .. + }, pat_ty, exp_ty) + = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ + addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $ + do { rhs' <- tcCheckMonoExprNC rhs exp_ty + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + return () + ; fail_op' <- fmap join . forM fail_op $ \fail -> + tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty + + ; return (ApplicativeArgOne + { xarg_app_arg_one = fail_op' + , app_arg_pattern = pat' + , arg_expr = rhs' + , .. } + ) } + + goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty) + = do { (stmts', (ret',pat')) <- + tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ + \res_ty -> do + { ret' <- tcExpr ret res_ty + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + return () + ; return (ret', pat') + } + ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) } + + get_arg_bndrs :: ApplicativeArg GhcTc -> [Id] + get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat + +{- Note [ApplicativeDo and constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An applicative-do is supposed to take place in parallel, so +constraints bound in one arm can't possibly be available in another +(#13242). Our current rule is this (more details and discussion +on the ticket). Consider + + ...stmts... + ApplicativeStmts [arg1, arg2, ... argN] + ...more stmts... + +where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts. +Now, we say that: + +* Constraints required by the argi can be solved from + constraint bound by ...stmts... + +* Constraints and existentials bound by the argi are not available + to solve constraints required either by argj (where i /= j), + or by ...more stmts.... + +* Within the stmts of each 'argi' individually, however, constraints bound + by earlier stmts can be used to solve later ones. + +To achieve this, we just typecheck each 'argi' separately, bring all +the variables they bind into scope, and typecheck the thing_inside. + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same +number of args are used in each equation. +-} + +checkArgs :: Name -> MatchGroup GhcRn body -> TcM () +checkArgs _ (MG { mg_alts = L _ [] }) + = return () +checkArgs fun (MG { mg_alts = L _ (match1:matches) }) + | null bad_matches + = return () + | otherwise + = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLoc match1)) + , nest 2 (ppr (getLoc (head bad_matches)))]) + where + n_args1 = args_in_match match1 + bad_matches = [m | m <- matches, args_in_match m /= n_args1] + + args_in_match :: LMatch GhcRn body -> Int + args_in_match (L _ (Match { m_pats = pats })) = length pats diff --git a/GHC/Tc/Gen/Match.hs-boot b/GHC/Tc/Gen/Match.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Match.hs-boot @@ -0,0 +1,17 @@ +module GHC.Tc.Gen.Match where +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) +import GHC.Tc.Types.Evidence ( HsWrapper ) +import GHC.Types.Name ( Name ) +import GHC.Tc.Utils.TcType( ExpSigmaType, TcRhoType ) +import GHC.Tc.Types ( TcM ) +import GHC.Types.SrcLoc ( Located ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) + +tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) + -> TcRhoType + -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) + +tcMatchesFun :: Located Name + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> ExpSigmaType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) diff --git a/GHC/Tc/Gen/Pat.hs b/GHC/Tc/Gen/Pat.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Pat.hs @@ -0,0 +1,1345 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typechecking patterns +module GHC.Tc.Gen.Pat + ( tcLetPat + , newLetBndr + , LetBndrSpec(..) + , tcCheckPat, tcCheckPat_O, tcInferPat + , tcPats + , addDataConStupidTheta + , badFieldCon + , polyPatSig + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho ) + +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Core.Multiplicity +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity( arityErr ) +import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify +import GHC.Tc.Gen.HsType +import GHC.Builtin.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Builtin.Names +import GHC.Types.Basic hiding (SuccessFlag(..)) +import GHC.Driver.Session +import GHC.Types.SrcLoc +import GHC.Types.Var.Set +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import qualified GHC.LanguageExtensions as LangExt +import Control.Arrow ( second ) +import Control.Monad ( when ) +import GHC.Data.List.SetOps ( getNth ) + +{- +************************************************************************ +* * + External interface +* * +************************************************************************ +-} + +tcLetPat :: (Name -> Maybe TcId) + -> LetBndrSpec + -> LPat GhcRn -> Scaled ExpSigmaType + -> TcM a + -> TcM (LPat GhcTc, a) +tcLetPat sig_fn no_gen pat pat_ty thing_inside + = do { bind_lvl <- getTcLevel + ; let ctxt = LetPat { pc_lvl = bind_lvl + , pc_sig_fn = sig_fn + , pc_new = no_gen } + penv = PE { pe_lazy = True + , pe_ctxt = ctxt + , pe_orig = PatOrigin } + + ; tc_lpat pat_ty penv pat thing_inside } + +----------------- +tcPats :: HsMatchContext GhcRn + -> [LPat GhcRn] -- Patterns, + -> [Scaled ExpSigmaType] -- and their types + -> TcM a -- and the checker for the body + -> TcM ([LPat GhcTc], a) + +-- This is the externally-callable wrapper function +-- Typecheck the patterns, extend the environment to bind the variables, +-- do the thing inside, use any existentially-bound dictionaries to +-- discharge parts of the returning LIE, and deal with pattern type +-- signatures + +-- 1. Initialise the PatState +-- 2. Check the patterns +-- 3. Check the body +-- 4. Check that no existentials escape + +tcPats ctxt pats pat_tys thing_inside + = tc_lpats pat_tys penv pats thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } + +tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn + -> TcM a + -> TcM ((LPat GhcTc, a), TcSigmaType) +tcInferPat ctxt pat thing_inside + = tcInfer $ \ exp_ty -> + tc_lpat (unrestricted exp_ty) penv pat thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } + +tcCheckPat :: HsMatchContext GhcRn + -> LPat GhcRn -> Scaled TcSigmaType + -> TcM a -- Checker for body + -> TcM (LPat GhcTc, a) +tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin + +-- | A variant of 'tcPat' that takes a custom origin +tcCheckPat_O :: HsMatchContext GhcRn + -> CtOrigin -- ^ origin to use if the type needs inst'ing + -> LPat GhcRn -> Scaled TcSigmaType + -> TcM a -- Checker for body + -> TcM (LPat GhcTc, a) +tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside + = tc_lpat (Scaled pat_mult (mkCheckExpType pat_ty)) penv pat thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } + + +{- +************************************************************************ +* * + PatEnv, PatCtxt, LetBndrSpec +* * +************************************************************************ +-} + +data PatEnv + = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed + , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears + , pe_orig :: CtOrigin -- origin to use if the pat_ty needs inst'ing + } + +data PatCtxt + = LamPat -- Used for lambdas, case etc + (HsMatchContext GhcRn) + + | LetPat -- Used only for let(rec) pattern bindings + -- See Note [Typing patterns in pattern bindings] + { pc_lvl :: TcLevel + -- Level of the binding group + + , pc_sig_fn :: Name -> Maybe TcId + -- Tells the expected type + -- for binders with a signature + + , pc_new :: LetBndrSpec + -- How to make a new binder + } -- for binders without signatures + +data LetBndrSpec + = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds + -- so clone a fresh binder for the local monomorphic Id + + | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going + -- to be an AbsBinds; So we must bind the global version + -- of the binder right away. + -- And here is the inline-pragma information + +instance Outputable LetBndrSpec where + ppr LetLclBndr = text "LetLclBndr" + ppr (LetGblBndr {}) = text "LetGblBndr" + +makeLazy :: PatEnv -> PatEnv +makeLazy penv = penv { pe_lazy = True } + +inPatBind :: PatEnv -> Bool +inPatBind (PE { pe_ctxt = LetPat {} }) = True +inPatBind (PE { pe_ctxt = LamPat {} }) = False + +{- ********************************************************************* +* * + Binders +* * +********************************************************************* -} + +tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaType -> TcM (HsWrapper, TcId) +-- (coi, xp) = tcPatBndr penv x pat_ty +-- Then coi : pat_ty ~ typeof(xp) +-- +tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl + , pc_sig_fn = sig_fn + , pc_new = no_gen } }) + bndr_name exp_pat_ty + -- For the LetPat cases, see + -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind + + | Just bndr_id <- sig_fn bndr_name -- There is a signature + = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id) + -- See Note [Subsumption check at pattern variables] + ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) + ; return (wrap, bndr_id) } + + | otherwise -- No signature + = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of + Check pat_ty -> promoteTcType bind_lvl pat_ty + Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res ) + -- If we were under a constructor that bumped the + -- level, we'd be in checking mode (see tcConArg) + -- hence this assertion + do { bndr_ty <- inferResultToType infer_res + ; return (mkTcNomReflCo bndr_ty, bndr_ty) } + ; let bndr_mult = scaledMult exp_pat_ty + ; bndr_id <- newLetBndr no_gen bndr_name bndr_mult bndr_ty + ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl + , ppr exp_pat_ty, ppr bndr_ty, ppr co + , ppr bndr_id ]) + ; return (mkWpCastN co, bndr_id) } + +tcPatBndr _ bndr_name pat_ty + = do { let pat_mult = scaledMult pat_ty + ; pat_ty <- expTypeToType (scaledThing pat_ty) + ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) + ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_mult pat_ty) } + -- We should not have "OrCoVar" here, this is a bug (#17545) + -- Whether or not there is a sig is irrelevant, + -- as this is local + +newLetBndr :: LetBndrSpec -> Name -> Mult -> TcType -> TcM TcId +-- Make up a suitable Id for the pattern-binder. +-- See Note [Typechecking pattern bindings], item (4) in GHC.Tc.Gen.Bind +-- +-- In the polymorphic case when we are going to generalise +-- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version" +-- of the Id; the original name will be bound to the polymorphic version +-- by the AbsBinds +-- In the monomorphic case when we are not going to generalise +-- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, +-- and we use the original name directly +newLetBndr LetLclBndr name w ty + = do { mono_name <- cloneLocalName name + ; return (mkLocalId mono_name w ty) } +newLetBndr (LetGblBndr prags) name w ty + = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name) + +tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt +-- Used during typechecking patterns +tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2 + +{- Note [Subsumption check at pattern variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across a variable with a type signature, we need to do a +subsumption, not equality, check against the context type. e.g. + + data T = MkT (forall a. a->a) + f :: forall b. [b]->[b] + MkT f = blah + +Since 'blah' returns a value of type T, its payload is a polymorphic +function of type (forall a. a->a). And that's enough to bind the +less-polymorphic function 'f', but we need some impedance matching +to witness the instantiation. + + +************************************************************************ +* * + The main worker functions +* * +************************************************************************ + +Note [Nesting] +~~~~~~~~~~~~~~ +tcPat takes a "thing inside" over which the pattern scopes. This is partly +so that tcPat can extend the environment for the thing_inside, but also +so that constraints arising in the thing_inside can be discharged by the +pattern. + +This does not work so well for the ErrCtxt carried by the monad: we don't +want the error-context for the pattern to scope over the RHS. +Hence the getErrCtxt/setErrCtxt stuff in tcMultiple +-} + +-------------------- + +type Checker inp out = forall r. + PatEnv + -> inp + -> TcM r -- Thing inside + -> TcM ( out + , r -- Result of thing inside + ) + +tcMultiple :: Checker inp out -> Checker [inp] [out] +tcMultiple tc_pat penv args thing_inside + = do { err_ctxt <- getErrCtxt + ; let loop _ [] + = do { res <- thing_inside + ; return ([], res) } + + loop penv (arg:args) + = do { (p', (ps', res)) + <- tc_pat penv arg $ + setErrCtxt err_ctxt $ + loop penv args + -- setErrCtxt: restore context before doing the next pattern + -- See note [Nesting] above + + ; return (p':ps', res) } + + ; loop penv args } + +-------------------- +tc_lpat :: Scaled ExpSigmaType + -> Checker (LPat GhcRn) (LPat GhcTc) +tc_lpat pat_ty penv (L span pat) thing_inside + = setSrcSpan span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat) + thing_inside + ; return (L span pat', res) } + +tc_lpats :: [Scaled ExpSigmaType] + -> Checker [LPat GhcRn] [LPat GhcTc] +tc_lpats tys penv pats + = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) + tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p) + penv + (zipEqual "tc_lpats" pats tys) + +-------------------- +-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. +checkManyPattern :: Scaled a -> TcM HsWrapper +checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) + +tc_pat :: Scaled ExpSigmaType + -- ^ Fully refined result type + -> Checker (Pat GhcRn) (Pat GhcTc) + -- ^ Translated pattern + +tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of + + VarPat x (L l name) -> do + { (wrap, id) <- tcPatBndr penv name pat_ty + ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $ + tcExtendIdEnv1 name id thing_inside + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } + + ParPat x pat -> do + { (pat', res) <- tc_lpat pat_ty penv pat thing_inside + ; return (ParPat x pat', res) } + + BangPat x pat -> do + { (pat', res) <- tc_lpat pat_ty penv pat thing_inside + ; return (BangPat x pat', res) } + + LazyPat x pat -> do + { mult_wrap <- checkManyPattern pat_ty + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + ; (pat', (res, pat_ct)) + <- tc_lpat pat_ty (makeLazy penv) pat $ + captureConstraints thing_inside + -- Ignore refined penv', revert to penv + + ; emitConstraints pat_ct + -- captureConstraints/extendConstraints: + -- see Note [Hopping the LIE in lazy patterns] + + -- Check that the expected pattern type is itself lifted + ; pat_ty <- readExpType (scaledThing pat_ty) + ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind + + ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) } + + WildPat _ -> do + { mult_wrap <- checkManyPattern pat_ty + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + ; res <- thing_inside + ; pat_ty <- expTypeToType (scaledThing pat_ty) + ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } + + AsPat x (L nm_loc name) pat -> do + { mult_wrap <- checkManyPattern pat_ty + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + ; (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ + tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) + penv pat thing_inside + -- NB: if we do inference on: + -- \ (y@(x::forall a. a->a)) = e + -- we'll fail. The as-pattern infers a monotype for 'y', which then + -- fails to unify with the polymorphic type for 'x'. This could + -- perhaps be fixed, but only with a bit more work. + -- + -- If you fix it, don't forget the bindInstsOfPatIds! + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } + + ViewPat _ expr pat -> do + { mult_wrap <- checkManyPattern pat_ty + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + -- + -- It should be possible to have view patterns at linear (or otherwise + -- non-Many) multiplicity. But it is not clear at the moment what + -- restriction need to be put in place, if any, for linear view + -- patterns to desugar to type-correct Core. + + ; (expr',expr_ty) <- tcInferRho expr + -- Note [View patterns and polymorphism] + + -- Expression must be a function + ; let expr_orig = lexprCtOrigin expr + herald = text "A view pattern expression expects" + ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) + <- matchActualFunTySigma herald expr_orig (Just (unLoc expr)) (1,[]) expr_ty + -- See Note [View patterns and polymorphism] + -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) + + -- Check that overall pattern is more polymorphic than arg type + ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty + -- expr_wrap2 :: pat_ty "->" inf_arg_ty + + -- Pattern must have inf_res_sigma + ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside + + ; let Scaled w h_pat_ty = pat_ty + ; pat_ty <- readExpType h_pat_ty + ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper + (Scaled w pat_ty) inf_res_sigma doc + -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" + -- (pat_ty -> inf_res_sigma) + expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap + doc = text "When checking the view pattern function:" <+> (ppr expr) + ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)} + +{- Note [View patterns and polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this exotic example: + pair :: forall a. Bool -> a -> forall b. b -> (a,b) + + f :: Int -> blah + f (pair True -> x) = ...here (x :: forall b. b -> (Int,b)) + +The expresion (pair True) should have type + pair True :: Int -> forall b. b -> (Int,b) +so that it is ready to consume the incoming Int. It should be an +arrow type (t1 -> t2); hence using (tcInferRho expr). + +Then, when taking that arrow apart we want to get a *sigma* type +(forall b. b->(Int,b)), because that's what we want to bind 'x' to. +Fortunately that's what matchExpectedFunTySigma returns anyway. +-} + +-- Type signatures in patterns +-- See Note [Pattern coercions] below + SigPat _ pat sig_ty -> do + { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) + sig_ty (scaledThing pat_ty) + -- Using tcExtendNameTyVarEnv is appropriate here + -- because we're not really bringing fresh tyvars into scope. + -- We're *naming* existing tyvars. Note that it is OK for a tyvar + -- from an outer scope to mention one of these tyvars in its kind. + ; (pat', res) <- tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv tv_binds $ + tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } + +------------------------ +-- Lists, tuples, arrays + ListPat Nothing pats -> do + { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty) + ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) + penv pats thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat coi + (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) +} + + ListPat (Just e) pats -> do + { tau_pat_ty <- expTypeToType (scaledThing pat_ty) + ; ((pats', res, elt_ty), e') + <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] + SynList $ + \ [elt_ty] _ -> + do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) + penv pats thing_inside + ; return (pats', res, elt_ty) } + ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) +} + + TuplePat _ pats boxity -> do + { let arity = length pats + tc = tupleTyCon boxity arity + -- NB: tupleTyCon does not flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) + penv (scaledThing pat_ty) + -- Unboxed tuples have RuntimeRep vars, which we discard: + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys) + penv pats thing_inside + + ; dflags <- getDynFlags + + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) + -- so that we can experiment with lazy tuple-matching. + -- This is a pretty odd place to make the switch, but + -- it was easy to do. + ; let + unmangled_result = TuplePat con_arg_tys pats' boxity + -- pat_ty /= pat_ty iff coi /= IdCo + possibly_mangled_result + | gopt Opt_IrrefutableTuples dflags && + isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) + | otherwise = unmangled_result + + ; pat_ty <- readExpType (scaledThing pat_ty) + ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced + return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) + } + + SumPat _ pat alt arity -> do + { let tc = sumTyCon arity + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) + penv (scaledThing pat_ty) + ; -- Drop levity vars, we don't care about them here + let con_arg_tys = drop arity arg_tys + ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1))) + penv pat thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty + , res) + } + +------------------------ +-- Data constructors + ConPat NoExtField con arg_pats -> + tcConPat penv con pat_ty arg_pats thing_inside + +------------------------ +-- Literal patterns + LitPat x simple_lit -> do + { let lit_ty = hsLitType simple_lit + ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty + ; res <- thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty + , res) } + +------------------------ +-- Overloaded patterns: n, and n+k + +-- In the case of a negative literal (the more complicated case), +-- we get +-- +-- case v of (-5) -> blah +-- +-- becoming +-- +-- if v == (negate (fromInteger 5)) then blah else ... +-- +-- There are two bits of rebindable syntax: +-- (==) :: pat_ty -> neg_lit_ty -> Bool +-- negate :: lit_ty -> neg_lit_ty +-- where lit_ty is the type of the overloaded literal 5. +-- +-- When there is no negation, neg_lit_ty and lit_ty are the same + NPat _ (L l over_lit) mb_neg eq -> do + { mult_wrap <- checkManyPattern pat_ty + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + -- + -- It may be possible to refine linear pattern so that they work in + -- linear environments. But it is not clear how useful this is. + ; let orig = LiteralOrigin over_lit + ; ((lit', mb_neg'), eq') + <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny] + (mkCheckExpType boolTy) $ + \ [neg_lit_ty] _ -> + let new_over_lit lit_ty = newOverloadedLit over_lit + (mkCheckExpType lit_ty) + in case mb_neg of + Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + second Just <$> + (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ + \ [lit_ty] _ -> new_over_lit lit_ty) + -- applied to a closed literal: linearity doesn't matter as + -- literals are typed in an empty environment, hence have + -- all multiplicities. + + ; res <- thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat mult_wrap (NPat pat_ty (L l lit') mb_neg' eq') pat_ty, res) } + +{- +Note [NPlusK patterns] +~~~~~~~~~~~~~~~~~~~~~~ +From + + case v of x + 5 -> blah + +we get + + if v >= 5 then (\x -> blah) (v - 5) else ... + +There are two bits of rebindable syntax: + (>=) :: pat_ty -> lit1_ty -> Bool + (-) :: pat_ty -> lit2_ty -> var_ty + +lit1_ty and lit2_ty could conceivably be different. +var_ty is the type inferred for x, the variable in the pattern. + +Note that we need to type-check the literal twice, because it is used +twice, and may be used at different types. The second HsOverLit stored in the +AST is used for the subtraction operation. +-} + +-- See Note [NPlusK patterns] + NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus -> do + { mult_wrap <- checkManyPattern pat_ty + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + ; let pat_exp_ty = scaledThing pat_ty + orig = LiteralOrigin lit + ; (lit1', ge') + <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho] + (mkCheckExpType boolTy) $ + \ [lit1_ty] _ -> + newOverloadedLit lit (mkCheckExpType lit1_ty) + ; ((lit2', minus_wrap, bndr_id), minus') + <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $ + \ [lit2_ty, var_ty] _ -> + do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) + ; (wrap, bndr_id) <- setSrcSpan nm_loc $ + tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) + -- co :: var_ty ~ idType bndr_id + + -- minus_wrap is applicable to minus' + ; return (lit2', wrap, bndr_id) } + + ; pat_ty <- readExpType pat_exp_ty + -- The Report says that n+k patterns must be in Integral + -- but it's silly to insist on this in the RebindableSyntax case + ; unlessM (xoptM LangExt.RebindableSyntax) $ + do { icls <- tcLookupClass integralClassName + ; instStupidTheta orig [mkClassPred icls [pat_ty]] } + + ; res <- tcExtendIdEnv1 name bndr_id thing_inside + + ; let minus'' = case minus' of + NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') + -- this should be statically avoidable + -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr" + SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus'_res_wrap } + -> SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus_wrap <.> minus'_res_wrap } + -- Oy. This should really be a record update, but + -- we get warnings if we try. #17783 + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' + ; return (mkHsWrapPat mult_wrap pat' pat_ty, res) } + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSplicePat'. +-- Here we get rid of it and add the finalizers to the global environment. +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + SplicePat _ splice -> case splice of + (HsSpliced _ mod_finalizers (HsSplicedPat pat)) -> do + { addModFinalizersWithLclEnv mod_finalizers + ; tc_pat pat_ty penv pat thing_inside } + _ -> panic "invalid splice in splice pat" + + +{- +Note [Hopping the LIE in lazy patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a lazy pattern, we must *not* discharge constraints from the RHS +from dictionaries bound in the pattern. E.g. + f ~(C x) = 3 +We can't discharge the Num constraint from dictionaries bound by +the pattern C! + +So we have to make the constraints from thing_inside "hop around" +the pattern. Hence the captureConstraints and emitConstraints. + +The same thing ensures that equality constraints in a lazy match +are not made available in the RHS of the match. For example + data T a where { T1 :: Int -> T Int; ... } + f :: T a -> Int -> a + f ~(T1 i) y = y +It's obviously not sound to refine a to Int in the right +hand side, because the argument might not match T1 at all! + +Finally, a lazy pattern should not bind any existential type variables +because they won't be in scope when we do the desugaring + + +************************************************************************ +* * + Pattern signatures (pat :: type) +* * +************************************************************************ +-} + +tcPatSig :: Bool -- True <=> pattern binding + -> HsPatSigType GhcRn + -> ExpSigmaType + -> TcM (TcType, -- The type to use for "inside" the signature + [(Name,TcTyVar)], -- The new bit of type environment, binding + -- the scoped type variables + [(Name,TcTyVar)], -- The wildcards + HsWrapper) -- Coercion due to unification with actual ty + -- Of shape: res_ty ~ sig_ty +tcPatSig in_pat_bind sig res_ty + = do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig + -- sig_tvs are the type variables free in 'sig', + -- and not already in scope. These are the ones + -- that should be brought into scope + + ; if null sig_tvs then do { + -- Just do the subsumption check and return + wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + ; return (sig_ty, [], sig_wcs, wrap) + } else do + -- Type signature binds at least one scoped type variable + + -- A pattern binding cannot bind scoped type variables + -- It is more convenient to make the test here + -- than in the renamer + { when in_pat_bind (addErr (patBindSigErr sig_tvs)) + + -- Now do a subsumption check of the pattern signature against res_ty + ; wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + + -- Phew! + ; return (sig_ty, sig_tvs, sig_wcs, wrap) + } } + where + mk_msg sig_ty tidy_env + = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty + ; res_ty <- readExpType res_ty -- should be filled in by now + ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty + ; let msg = vcat [ hang (text "When checking that the pattern signature:") + 4 (ppr sig_ty) + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr res_ty)) ] + ; return (tidy_env, msg) } + +patBindSigErr :: [(Name,TcTyVar)] -> SDoc +patBindSigErr sig_tvs + = hang (text "You cannot bind scoped type variable" <> plural sig_tvs + <+> pprQuotedList (map fst sig_tvs)) + 2 (text "in a pattern binding signature") + + +{- ********************************************************************* +* * + Most of the work for constructors is here + (the rest is in the ConPatIn case of tc_pat) +* * +************************************************************************ + +[Pattern matching indexed data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following declarations: + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +and a case expression + + case x :: Map (Int, c) w of MapPair m -> ... + +As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the +worker/wrapper types for MapPair are + + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is +:R123Map, which means the straight use of boxySplitTyConApp would give a type +error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls +boxySplitTyConApp with the family tycon Map instead, which gives us the family +type list {(Int, c), w}. To get the correct split for :R123Map, we need to +unify the family type list {(Int, c), w} with the instance types {(a, b), v} +(provided by tyConFamInst_maybe together with the family tycon). This +unification yields the substitution [a -> Int, b -> c, v -> w], which gives us +the split arguments for the representation tycon :R123Map as {Int, c, w} + +In other words, boxySplitTyConAppWithFamily implicitly takes the coercion + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +moving between representation and family type into account. To produce type +correct Core, this coercion needs to be used to case the type of the scrutinee +from the family to the representation type. This is achieved by +unwrapFamInstScrutinee using a CoPat around the result pattern. + +Now it might appear seem as if we could have used the previous GADT type +refinement infrastructure of refineAlt and friends instead of the explicit +unification and CoPat generation. However, that would be wrong. Why? The +whole point of GADT refinement is that the refinement is local to the case +alternative. In contrast, the substitution generated by the unification of +the family type list and instance types needs to be propagated to the outside. +Imagine that in the above example, the type of the scrutinee would have been +(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the +substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the +instantiation of x with (a, b) must be global; ie, it must be valid in *all* +alternatives of the case expression, whereas in the GADT case it might vary +between alternatives. + +RIP GADT refinement: refinements have been replaced by the use of explicit +equality constraints that are used in conjunction with implication constraints +to express the local scope of GADT refinements. +-} + +-- Running example: +-- MkT :: forall a b c. (a~[b]) => b -> c -> T a +-- with scrutinee of type (T ty) + +tcConPat :: PatEnv -> Located Name + -> Scaled ExpSigmaType -- Type of the pattern + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTc, a) +tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside + = do { con_like <- tcLookupConLike con_name + ; case con_like of + RealDataCon data_con -> tcDataConPat penv con_lname data_con + pat_ty arg_pats thing_inside + PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn + pat_ty arg_pats thing_inside + } + +tcDataConPat :: PatEnv -> Located Name -> DataCon + -> Scaled ExpSigmaType -- Type of the pattern + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTc, a) +tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled + arg_pats thing_inside + = do { let tycon = dataConTyCon data_con + -- For data families this is the representation tycon + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + header = L con_span (RealDataCon data_con) + + -- Instantiate the constructor type variables [a->ty] + -- This may involve doing a family-instance coercion, + -- and building a wrapper + ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty_scaled + ; pat_ty <- readExpType (scaledThing pat_ty_scaled) + + -- Add the stupid theta + ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys + + ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) + ; checkExistentials ex_tvs all_arg_tys penv + + ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys + -- NB: Do not use zipTvSubst! See #14154 + -- We want to create a well-kinded substitution, so + -- that the instantiated type is well-kinded + + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs + -- Get location from monad, not from ex_tvs + + ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys + -- pat_ty' is type of the actual constructor application + -- pat_ty' /= pat_ty iff coi /= IdCo + + arg_tys' = substScaledTys tenv arg_tys + pat_mult = scaledMult pat_ty_scaled + arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' + + ; traceTc "tcConPat" (vcat [ ppr con_name + , pprTyVars univ_tvs + , pprTyVars ex_tvs + , ppr eq_spec + , ppr theta + , pprTyVars ex_tvs' + , ppr ctxt_res_tys + , ppr arg_tys' + , ppr arg_pats ]) + ; if null ex_tvs && null eq_spec && null theta + then do { -- The common case; no class bindings etc + -- (see Note [Arrows and patterns]) + (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys_scaled + penv arg_pats thing_inside + ; let res_pat = ConPat { pat_con = header + , pat_args = arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = [], cpt_dicts = [] + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = ctxt_res_tys + , cpt_wrap = idHsWrapper + } + } + + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + + else do -- The general case, with existential, + -- and local equality constraints + { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) + -- order is *important* as we generate the list of + -- dictionary binders from theta' + no_equalities = null eq_spec && not (any isEqPred theta) + skol_info = PatSkol (RealDataCon data_con) mc + mc = case pe_ctxt penv of + LamPat mc -> mc + LetPat {} -> PatBindRhs + + ; gadts_on <- xoptM LangExt.GADTs + ; families_on <- xoptM LangExt.TypeFamilies + ; checkTc (no_equalities || gadts_on || families_on) + (text "A pattern match on a GADT requires the" <+> + text "GADTs or TypeFamilies language extension") + -- #2905 decided that a *pattern-match* of a GADT + -- should require the GADT language flag. + -- Re TypeFamilies see also #7156 + + ; given <- newEvVars theta' + ; (ev_binds, (arg_pats', res)) + <- checkConstraints skol_info ex_tvs' given $ + tcConArgs (RealDataCon data_con) arg_tys_scaled penv arg_pats thing_inside + + ; let res_pat = ConPat + { pat_con = header + , pat_args = arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs' + , cpt_dicts = given + , cpt_binds = ev_binds + , cpt_arg_tys = ctxt_res_tys + , cpt_wrap = idHsWrapper + } + } + ; return (mkHsWrapPat wrap res_pat pat_ty, res) + } } + +tcPatSynPat :: PatEnv -> Located Name -> PatSyn + -> Scaled ExpSigmaType -- Type of the pattern + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTc, a) +tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside + = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn + + ; (subst, univ_tvs') <- newMetaTyVars univ_tvs + + ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys) + ; checkExistentials ex_tvs all_arg_tys penv + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs + ; let ty' = substTy tenv ty + arg_tys' = substScaledTys tenv arg_tys + pat_mult = scaledMult pat_ty + arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' + prov_theta' = substTheta tenv prov_theta + req_theta' = substTheta tenv req_theta + + ; mult_wrap <- checkManyPattern pat_ty + -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + + ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' + ; traceTc "tcPatSynPat" (ppr pat_syn $$ + ppr pat_ty $$ + ppr ty' $$ + ppr ex_tvs' $$ + ppr prov_theta' $$ + ppr req_theta' $$ + ppr arg_tys') + + ; prov_dicts' <- newEvVars prov_theta' + + ; let skol_info = case pe_ctxt penv of + LamPat mc -> PatSkol (PatSynCon pat_syn) mc + LetPat {} -> UnkSkol -- Doesn't matter + + ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' + ; traceTc "instCall" (ppr req_wrap) + + ; traceTc "checkConstraints {" Outputable.empty + ; (ev_binds, (arg_pats', res)) + <- checkConstraints skol_info ex_tvs' prov_dicts' $ + tcConArgs (PatSynCon pat_syn) arg_tys_scaled penv arg_pats thing_inside + + ; traceTc "checkConstraints }" (ppr ev_binds) + ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn + , pat_args = arg_pats' + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs' + , cpt_dicts = prov_dicts' + , cpt_binds = ev_binds + , cpt_arg_tys = mkTyVarTys univ_tvs' + , cpt_wrap = req_wrap + } + } + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) } + +---------------------------- +-- | Convenient wrapper for calling a matchExpectedXXX function +matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) + -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) +-- See Note [Matching polytyped patterns] +-- Returns a wrapper : pat_ty ~R inner_ty +matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + ; (co, res) <- inner_match pat_rho + ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) + ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } + +---------------------------- +matchExpectedConTy :: PatEnv + -> TyCon -- The TyCon that this data + -- constructor actually returns + -- In the case of a data family this is + -- the /representation/ TyCon + -> Scaled ExpSigmaType -- The type of the pattern; in the + -- case of a data family this would + -- mention the /family/ TyCon + -> TcM (HsWrapper, [TcSigmaType]) +-- See Note [Matching constructor patterns] +-- Returns a wrapper : pat_ty "->" T ty1 ... tyn +matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty + | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc + -- Comments refer to Note [Matching constructor patterns] + -- co_tc :: forall a. T [a] ~ T7 a + = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + + ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) + -- tys = [ty1,ty2] + + ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, + ppr (tyConTyVars data_tc), + ppr fam_tc, ppr fam_args, + ppr exp_pat_ty, + ppr pat_ty, + ppr pat_rho, ppr wrap]) + ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho + -- co1 : T (ty1,ty2) ~N pat_rho + -- could use tcSubType here... but it's the wrong way round + -- for actual vs. expected in error messages. + + ; let tys' = mkTyVarTys tvs' + co2 = mkTcUnbranchedAxInstCo co_tc tys' [] + -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 + + full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 + -- full_co :: pat_rho ~R T7 ty1 ty2 + + ; return ( mkWpCastR full_co <.> wrap, tys') } + + | otherwise + = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) + ; (wrap, pat_rho) <- topInstantiate orig pat_ty + ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho + ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } + +{- +Note [Matching constructor patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (coi, tys) = matchExpectedConType data_tc pat_ty + + * In the simple case, pat_ty = tc tys + + * If pat_ty is a polytype, we want to instantiate it + This is like part of a subsumption check. Eg + f :: (forall a. [a]) -> blah + f [] = blah + + * In a type family case, suppose we have + data family T a + data instance T (p,q) = A p | B q + Then we'll have internally generated + data T7 p q = A p | B q + axiom coT7 p q :: T (p,q) ~ T7 p q + + So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that + coi = coi2 . coi1 : T7 t ~ pat_ty + coi1 : T (ty1,ty2) ~ pat_ty + coi2 : T7 ty1 ty2 ~ T (ty1,ty2) + + For families we do all this matching here, not in the unifier, + because we never want a whisper of the data_tycon to appear in + error messages; it's a purely internal thing +-} + +tcConArgs :: ConLike -> [Scaled TcSigmaType] + -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) + +tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of + PrefixCon arg_pats -> do + { checkTc (con_arity == no_of_args) -- Check correct arity + (arityErr (text "constructor") con_like con_arity no_of_args) + ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys + ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys + thing_inside + ; return (PrefixCon arg_pats', res) } + where + con_arity = conLikeArity con_like + no_of_args = length arg_pats + + InfixCon p1 p2 -> do + { checkTc (con_arity == 2) -- Check correct arity + (arityErr (text "constructor") con_like con_arity 2) + ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check + ; ([p1',p2'], res) <- tcMultiple tcConArg penv [(p1,arg_ty1),(p2,arg_ty2)] + thing_inside + ; return (InfixCon p1' p2', res) } + where + con_arity = conLikeArity con_like + + RecCon (HsRecFields rpats dd) -> do + { (rpats', res) <- tcMultiple tc_field penv rpats thing_inside + ; return (RecCon (HsRecFields rpats' dd), res) } + where + tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) + (LHsRecField GhcTc (LPat GhcTc)) + tc_field penv + (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) + thing_inside + = do { sel' <- tcLookupId sel + ; pat_ty <- setSrcSpan loc $ find_field_ty sel + (occNameFS $ rdrNameOcc rdr) + ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' + pun), res) } + + + find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType) + find_field_ty sel lbl + = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of + + -- No matching field; chances are this field label comes from some + -- other record type (or maybe none). If this happens, just fail, + -- otherwise we get crashes later (#8570), and similar: + -- f (R { foo = (a,b) }) = a+b + -- If foo isn't one of R's fields, we don't want to crash when + -- typechecking the "a+b". + [] -> failWith (badFieldCon con_like lbl) + + -- The normal case, when the field comes from the right constructor + (pat_ty : extras) -> do + traceTc "find_field" (ppr pat_ty <+> ppr extras) + ASSERT( null extras ) (return pat_ty) + + field_tys :: [(FieldLabel, Scaled TcType)] + field_tys = zip (conLikeFieldLabels con_like) arg_tys + -- Don't use zipEqual! If the constructor isn't really a record, then + -- dataConFieldLabels will be empty (and each field in the pattern + -- will generate an error below). + +tcConArg :: Checker (LPat GhcRn, Scaled TcSigmaType) (LPat GhcTc) +tcConArg penv (arg_pat, Scaled arg_mult arg_ty) + = tc_lpat (Scaled arg_mult (mkCheckExpType arg_ty)) penv arg_pat + +addDataConStupidTheta :: DataCon -> [TcType] -> TcM () +-- Instantiate the "stupid theta" of the data con, and throw +-- the constraints into the constraint set +addDataConStupidTheta data_con inst_tys + | null stupid_theta = return () + | otherwise = instStupidTheta origin inst_theta + where + origin = OccurrenceOf (dataConName data_con) + -- The origin should always report "occurrence of C" + -- even when C occurs in a pattern + stupid_theta = dataConStupidTheta data_con + univ_tvs = dataConUnivTyVars data_con + tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys) + -- NB: inst_tys can be longer than the univ tyvars + -- because the constructor might have existentials + inst_theta = substTheta tenv stupid_theta + +{- +Note [Arrows and patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +(Oct 07) Arrow notation has the odd property that it involves +"holes in the scope". For example: + expr :: Arrow a => a () Int + expr = proc (y,z) -> do + x <- term -< y + expr' -< x + +Here the 'proc (y,z)' binding scopes over the arrow tails but not the +arrow body (e.g 'term'). As things stand (bogusly) all the +constraints from the proc body are gathered together, so constraints +from 'term' will be seen by the tcPat for (y,z). But we must *not* +bind constraints from 'term' here, because the desugarer will not make +these bindings scope over 'term'. + +The Right Thing is not to confuse these constraints together. But for +now the Easy Thing is to ensure that we do not have existential or +GADT constraints in a 'proc', and to short-cut the constraint +simplification for such vanilla patterns so that it binds no +constraints. Hence the 'fast path' in tcConPat; but it's also a good +plan for ordinary vanilla patterns to bypass the constraint +simplification step. + +************************************************************************ +* * + Note [Pattern coercions] +* * +************************************************************************ + +In principle, these program would be reasonable: + + f :: (forall a. a->a) -> Int + f (x :: Int->Int) = x 3 + + g :: (forall a. [a]) -> Bool + g [] = True + +In both cases, the function type signature restricts what arguments can be passed +in a call (to polymorphic ones). The pattern type signature then instantiates this +type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we +generate the translated term + f = \x' :: (forall a. a->a). let x = x' Int in x 3 + +From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. +And it requires a significant amount of code to implement, because we need to decorate +the translated pattern with coercion functions (generated from the subsumption check +by tcSub). + +So for now I'm just insisting on type *equality* in patterns. No subsumption. + +Old notes about desugaring, at a time when pattern coercions were handled: + +A SigPat is a type coercion and must be handled one at a time. We can't +combine them unless the type of the pattern inside is identical, and we don't +bother to check for that. For example: + + data T = T1 Int | T2 Bool + f :: (forall a. a -> a) -> T -> t + f (g::Int->Int) (T1 i) = T1 (g i) + f (g::Bool->Bool) (T2 b) = T2 (g b) + +We desugar this as follows: + + f = \ g::(forall a. a->a) t::T -> + let gi = g Int + in case t of { T1 i -> T1 (gi i) + other -> + let gb = g Bool + in case t of { T2 b -> T2 (gb b) + other -> fail }} + +Note that we do not treat the first column of patterns as a +column of variables, because the coerced variables (gi, gb) +would be of different types. So we get rather grotty code. +But I don't think this is a common case, and if it was we could +doubtless improve it. + +Meanwhile, the strategy is: + * treat each SigPat coercion (always non-identity coercions) + as a separate block + * deal with the stuff inside, and then wrap a binding round + the result to bind the new variable (gi, gb, etc) + + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +Note [Existential check] +~~~~~~~~~~~~~~~~~~~~~~~~ +Lazy patterns can't bind existentials. They arise in two ways: + * Let bindings let { C a b = e } in b + * Twiddle patterns f ~(C a b) = e +The pe_lazy field of PatEnv says whether we are inside a lazy +pattern (perhaps deeply) + +See also Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind +-} + +maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b +-- Not all patterns are worth pushing a context +maybeWrapPatCtxt pat tcm thing_inside + | not (worth_wrapping pat) = tcm thing_inside + | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside + -- Remember to pop before doing thing_inside + where + worth_wrapping (VarPat {}) = False + worth_wrapping (ParPat {}) = False + worth_wrapping (AsPat {}) = False + worth_wrapping _ = True + msg = hang (text "In the pattern:") 2 (ppr pat) + +----------------------------------------------- +checkExistentials :: [TyVar] -- existentials + -> [Type] -- argument types + -> PatEnv -> TcM () + -- See Note [Existential check]] + -- See Note [Arrows and patterns] +checkExistentials ex_tvs tys _ + | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () +checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = return () +checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat +checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat +checkExistentials _ _ _ = return () + +existentialLazyPat :: SDoc +existentialLazyPat + = hang (text "An existential or GADT data constructor cannot be used") + 2 (text "inside a lazy (~) pattern") + +existentialProcPat :: SDoc +existentialProcPat + = text "Proc patterns cannot use existential or GADT data constructors" + +badFieldCon :: ConLike -> FieldLabelString -> SDoc +badFieldCon con field + = hsep [text "Constructor" <+> quotes (ppr con), + text "does not have field", quotes (ppr field)] + +polyPatSig :: TcType -> SDoc +polyPatSig sig_ty + = hang (text "Illegal polymorphic type signature in pattern:") + 2 (ppr sig_ty) diff --git a/GHC/Tc/Gen/Rule.hs b/GHC/Tc/Gen/Rule.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Rule.hs @@ -0,0 +1,494 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking rewrite rules +module GHC.Tc.Gen.Rule ( tcRules ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Solver +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify( buildImplicationFor ) +import GHC.Tc.Types.Evidence( mkTcCoVarCo ) +import GHC.Core.Type +import GHC.Core.TyCon( isTypeFamilyTyCon ) +import GHC.Types.Id +import GHC.Types.Var( EvVar ) +import GHC.Types.Var.Set +import GHC.Types.Basic ( RuleName ) +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag + +{- +Note [Typechecking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We *infer* the typ of the LHS, and use that type to *check* the type of +the RHS. That means that higher-rank rules work reasonably well. Here's +an example (test simplCore/should_compile/rule2.hs) produced by Roman: + + foo :: (forall m. m a -> m b) -> m a -> m b + foo f = ... + + bar :: (forall m. m a -> m a) -> m a -> m a + bar f = ... + + {-# RULES "foo/bar" foo = bar #-} + +He wanted the rule to typecheck. + +Note [TcLevel in type checking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Bringing type variables into scope naturally bumps the TcLevel. Thus, we type +check the term-level binders in a bumped level, and we must accordingly bump +the level whenever these binders are in scope. + +Note [Re-quantify type variables in rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example from #17710: + + foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b + foo x = Proxy + {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-} + +Written out in more detail, the "foo" rewrite rule looks like this: + + forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0 + +Where b0 is a unification variable. Where should b0 be quantified? We have to +quantify it after k, since (b0 :: k). But generalization usually puts inferred +type variables (such as b0) at the /front/ of the telescope! This creates a +conflict. + +One option is to simply throw an error, per the principles of +Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen +if we were generalising over a normal type signature. On the other hand, the +types in a rewrite rule aren't quite "normal", since the notions of specified +and inferred type variables aren't applicable. + +A more permissive design (and the design that GHC uses) is to simply requantify +all of the type variables. That is, we would end up with this: + + forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b + +It's a bit strange putting the generalized variable `b` after the user-written +variables `k` and `a`. But again, the notion of specificity is not relevant to +rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not +only makes "foo" typecheck, but it also makes the implementation simpler. + +See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which +explains a very similar design when generalising over a type family instance +equation. +-} + +tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc] +tcRules decls = mapM (wrapLocM tcRuleDecls) decls + +tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) +tcRuleDecls (HsRules { rds_src = src + , rds_rules = decls }) + = do { tc_decls <- mapM (wrapLocM tcRule) decls + ; return $ HsRules { rds_ext = noExtField + , rds_src = src + , rds_rules = tc_decls } } + +tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc) +tcRule (HsRule { rd_ext = ext + , rd_name = rname@(L _ (_,name)) + , rd_act = act + , rd_tyvs = ty_bndrs + , rd_tmvs = tm_bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = addErrCtxt (ruleCtxt name) $ + do { traceTc "---- Rule ------" (pprFullRuleName rname) + + -- Note [Typechecking rules] + ; (tc_lvl, stuff) <- pushTcLevelM $ + generateRuleConstraints ty_bndrs tm_bndrs lhs rhs + + ; let (id_bndrs, lhs', lhs_wanted + , rhs', rhs_wanted, rule_ty) = stuff + + ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname + , ppr lhs_wanted + , ppr rhs_wanted ]) + + ; (lhs_evs, residual_lhs_wanted) + <- simplifyRule name tc_lvl lhs_wanted rhs_wanted + + -- SimplfyRule Plan, step 4 + -- Now figure out what to quantify over + -- c.f. GHC.Tc.Solver.simplifyInfer + -- We quantify over any tyvars free in *either* the rule + -- *or* the bound variables. The latter is important. Consider + -- ss (x,(y,z)) = (x,z) + -- RULE: forall v. fst (ss v) = fst v + -- The type of the rhs of the rule is just a, but v::(a,(b,c)) + -- + -- We also need to get the completely-unconstrained tyvars of + -- the LHS, lest they otherwise get defaulted to Any; but we do that + -- during zonking (see GHC.Tc.Utils.Zonk.zonkRule) + + ; let tpl_ids = lhs_evs ++ id_bndrs + + -- See Note [Re-quantify type variables in rules] + ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) + ; qtkvs <- quantifyTyVars forall_tkvs + ; traceTc "tcRule" (vcat [ pprFullRuleName rname + , ppr forall_tkvs + , ppr qtkvs + , ppr rule_ty + , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] + ]) + + -- SimplfyRule Plan, step 5 + -- Simplify the LHS and RHS constraints: + -- For the LHS constraints we must solve the remaining constraints + -- (a) so that we report insoluble ones + -- (b) so that we bind any soluble ones + ; let skol_info = RuleSkol name + ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + lhs_evs residual_lhs_wanted + ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + lhs_evs rhs_wanted + + ; emitImplications (lhs_implic `unionBags` rhs_implic) + ; return $ HsRule { rd_ext = ext + , rd_name = rname + , rd_act = act + , rd_tyvs = ty_bndrs -- preserved for ppr-ing + , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc) + (qtkvs ++ tpl_ids) + , rd_lhs = mkHsDictLet lhs_binds lhs' + , rd_rhs = mkHsDictLet rhs_binds rhs' } } + +generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] + -> LHsExpr GhcRn -> LHsExpr GhcRn + -> TcM ( [TcId] + , LHsExpr GhcTc, WantedConstraints + , LHsExpr GhcTc, WantedConstraints + , TcType ) +generateRuleConstraints ty_bndrs tm_bndrs lhs rhs + = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ + tcRuleBndrs ty_bndrs tm_bndrs + -- bndr_wanted constraints can include wildcard hole + -- constraints, which we should not forget about. + -- It may mention the skolem type variables bound by + -- the RULE. c.f. #10072 + + ; tcExtendTyVarEnv tv_bndrs $ + tcExtendIdEnv id_bndrs $ + do { -- See Note [Solve order for RULES] + ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) + ; (rhs', rhs_wanted) <- captureConstraints $ + tcCheckMonoExpr rhs rule_ty + ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted + ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } + +-- See Note [TcLevel in type checking rules] +tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] + -> TcM ([TcTyVar], [Id]) +tcRuleBndrs (Just bndrs) xs + = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ + tcRuleTmBndrs xs + ; let tys1 = binderVars tybndrs1 + ; return (tys1 ++ tys2, tms) } + +tcRuleBndrs Nothing xs + = tcRuleTmBndrs xs + +-- See Note [TcLevel in type checking rules] +tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) +tcRuleTmBndrs [] = return ([],[]) +tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) + = do { ty <- newOpenFlexiTyVarTy + ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs + ; return (tyvars, mkLocalId name Many ty : tmvars) } +tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) +-- e.g x :: a->a +-- The tyvar 'a' is brought into scope first, just as if you'd written +-- a::*, x :: a->a +-- If there's an explicit forall, the renamer would have already reported an +-- error for each out-of-scope type variable used + = do { let ctxt = RuleSigCtxt name + ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty + ; let id = mkLocalId name Many id_ty + -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType + + -- The type variables scope over subsequent bindings; yuk + ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ + tcRuleTmBndrs rule_bndrs + ; return (map snd tvs ++ tyvars, id : tmvars) } + +ruleCtxt :: FastString -> SDoc +ruleCtxt name = text "When checking the rewrite rule" <+> + doubleQuotes (ftext name) + + +{- +********************************************************************************* +* * + Constraint simplification for rules +* * +*********************************************************************************** + +Note [The SimplifyRule Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example. Consider the following left-hand side of a rule + f (x == y) (y > z) = ... +If we typecheck this expression we get constraints + d1 :: Ord a, d2 :: Eq a +We do NOT want to "simplify" to the LHS + forall x::a, y::a, z::a, d1::Ord a. + f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... +Instead we want + forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. + f ((==) d2 x y) ((>) d1 y z) = ... + +Here is another example: + fromIntegral :: (Integral a, Num b) => a -> b + {-# RULES "foo" fromIntegral = id :: Int -> Int #-} +In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But +we *dont* want to get + forall dIntegralInt. + fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int +because the scsel will mess up RULE matching. Instead we want + forall dIntegralInt, dNumInt. + fromIntegral Int Int dIntegralInt dNumInt = id Int + +Even if we have + g (x == y) (y == z) = .. +where the two dictionaries are *identical*, we do NOT WANT + forall x::a, y::a, z::a, d1::Eq a + f ((==) d1 x y) ((>) d1 y z) = ... +because that will only match if the dict args are (visibly) equal. +Instead we want to quantify over the dictionaries separately. + +In short, simplifyRuleLhs must *only* squash equalities, leaving +all dicts unchanged, with absolutely no sharing. + +Also note that we can't solve the LHS constraints in isolation: +Example foo :: Ord a => a -> a + foo_spec :: Int -> Int + {-# RULE "foo" foo = foo_spec #-} +Here, it's the RHS that fixes the type variable + +HOWEVER, under a nested implication things are different +Consider + f :: (forall a. Eq a => a->a) -> Bool -> ... + {-# RULES "foo" forall (v::forall b. Eq b => b->b). + f b True = ... + #-} +Here we *must* solve the wanted (Eq a) from the given (Eq a) +resulting from skolemising the argument type of g. So we +revert to SimplCheck when going under an implication. + + +--------- So the SimplifyRule Plan is this ----------------------- + +* Step 0: typecheck the LHS and RHS to get constraints from each + +* Step 1: Simplify the LHS and RHS constraints all together in one bag + We do this to discover all unification equalities + +* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take + advantage of those unifications + +* Setp 3: Partition the LHS constraints into the ones we will + quantify over, and the others. + See Note [RULE quantification over equalities] + +* Step 4: Decide on the type variables to quantify over + +* Step 5: Simplify the LHS and RHS constraints separately, using the + quantified constraints as givens + +Note [Solve order for RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step 1 above, we need to be a bit careful about solve order. +Consider + f :: Int -> T Int + type instance T Int = Bool + + RULE f 3 = True + +From the RULE we get + lhs-constraints: T Int ~ alpha + rhs-constraints: Bool ~ alpha +where 'alpha' is the type that connects the two. If we glom them +all together, and solve the RHS constraint first, we might solve +with alpha := Bool. But then we'd end up with a RULE like + + RULE: f 3 |> (co :: T Int ~ Bool) = True + +which is terrible. We want + + RULE: f 3 = True |> (sym co :: Bool ~ T Int) + +So we are careful to solve the LHS constraints first, and *then* the +RHS constraints. Actually much of this is done by the on-the-fly +constraint solving, so the same order must be observed in +tcRule. + + +Note [RULE quantification over equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding which equalities to quantify over is tricky: + * We do not want to quantify over insoluble equalities (Int ~ Bool) + (a) because we prefer to report a LHS type error + (b) because if such things end up in 'givens' we get a bogus + "inaccessible code" error + + * But we do want to quantify over things like (a ~ F b), where + F is a type function. + +The difficulty is that it's hard to tell what is insoluble! +So we see whether the simplification step yielded any type errors, +and if so refrain from quantifying over *any* equalities. + +Note [Quantifying over coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Equality constraints from the LHS will emit coercion hole Wanteds. +These don't have a name, so we can't quantify over them directly. +Instead, because we really do want to quantify here, invent a new +EvVar for the coercion, fill the hole with the invented EvVar, and +then quantify over the EvVar. Not too tricky -- just some +impedance matching, really. + +Note [Simplify cloned constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this stage, we're simplifying constraints only for insolubility +and for unification. Note that all the evidence is quickly discarded. +We use a clone of the real constraint. If we don't do this, +then RHS coercion-hole constraints get filled in, only to get filled +in *again* when solving the implications emitted from tcRule. That's +terrible, so we avoid the problem by cloning the constraints. + +-} + +simplifyRule :: RuleName + -> TcLevel -- Level at which to solve the constraints + -> WantedConstraints -- Constraints from LHS + -> WantedConstraints -- Constraints from RHS + -> TcM ( [EvVar] -- Quantify over these LHS vars + , WantedConstraints) -- Residual un-quantified LHS constraints +-- See Note [The SimplifyRule Plan] +-- NB: This consumes all simple constraints on the LHS, but not +-- any LHS implication constraints. +simplifyRule name tc_lvl lhs_wanted rhs_wanted + = do { + -- Note [The SimplifyRule Plan] step 1 + -- First solve the LHS and *then* solve the RHS + -- Crucially, this performs unifications + -- Why clone? See Note [Simplify cloned constraints] + ; lhs_clone <- cloneWC lhs_wanted + ; rhs_clone <- cloneWC rhs_wanted + ; setTcLevel tc_lvl $ + runTcSDeriveds $ + do { _ <- solveWanteds lhs_clone + ; _ <- solveWanteds rhs_clone + -- Why do them separately? + -- See Note [Solve order for RULES] + ; return () } + + -- Note [The SimplifyRule Plan] step 2 + ; lhs_wanted <- zonkWC lhs_wanted + ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted + + -- Note [The SimplifyRule Plan] step 3 + ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts) + + ; traceTc "simplifyRule" $ + vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) + , text "lhs_wanted" <+> ppr lhs_wanted + , text "rhs_wanted" <+> ppr rhs_wanted + , text "quant_cts" <+> ppr quant_cts + , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted + ] + + ; return (quant_evs, residual_lhs_wanted) } + + where + mk_quant_ev :: Ct -> TcM EvVar + mk_quant_ev ct + | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct + = case dest of + EvVarDest ev_id -> return ev_id + HoleDest hole -> -- See Note [Quantifying over coercion holes] + do { ev_id <- newEvVar pred + ; fillCoercionHole hole (mkTcCoVarCo ev_id) + ; return ev_id } + mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) + + +getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints) +-- Extract all the constraints we can quantify over, +-- also returning the depleted WantedConstraints +-- +-- NB: we must look inside implications, because with +-- -fdefer-type-errors we generate implications rather eagerly; +-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732. +-- +-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, +-- and attempt to solve them from the quantified constraints. That +-- nearly works, but fails for a constraint like (d :: Eq Int). +-- We /do/ want to quantify over it, but the short-cut solver +-- (see GHC.Tc.Solver.Interact Note [Shortcut solving]) ignores the quantified +-- and instead solves from the top level. +-- +-- So we must partition the WantedConstraints ourselves +-- Not hard, but tiresome. + +getRuleQuantCts wc + = float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) + float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes }) + = ( simple_yes `andCts` implic_yes + , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_holes = holes }) + where + (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples + (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) + emptyBag implics + + float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) + float_implic skol_tvs yes1 imp + = (yes1 `andCts` yes2, imp { ic_wanted = no }) + where + (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) + new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp + + rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool + rule_quant_ct skol_tvs ct + | EqPred _ t1 t2 <- classifyPredType (ctPred ct) + , not (ok_eq t1 t2) + = False -- Note [RULE quantification over equalities] + | otherwise + = tyCoVarsOfCt ct `disjointVarSet` skol_tvs + + ok_eq t1 t2 + | t1 `tcEqType` t2 = False + | otherwise = is_fun_app t1 || is_fun_app t2 + + is_fun_app ty -- ty is of form (F tys) where F is a type function + = case tyConAppTyCon_maybe ty of + Just tc -> isTypeFamilyTyCon tc + Nothing -> False diff --git a/GHC/Tc/Gen/Sig.hs b/GHC/Tc/Gen/Sig.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Sig.hs @@ -0,0 +1,844 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Sig( + TcSigInfo(..), + TcIdSigInfo(..), TcIdSigInst, + TcPatSynInfo(..), + TcSigFun, + + isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, + completeSigPolyId_maybe, + + tcTySigs, tcUserTypeSig, completeSigFromId, + tcInstSig, + + TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, + mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Gen.HsType +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity ( checkValidType ) +import GHC.Tc.Utils.Unify( tcSkolemise, unifyType ) +import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) +import GHC.Tc.Utils.Env( tcLookupId ) +import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) +import GHC.Core.Type ( mkTyVarBinders ) +import GHC.Core.Multiplicity + +import GHC.Driver.Session +import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) +import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) +import GHC.Builtin.Names( mkUnboundName ) +import GHC.Types.Basic +import GHC.Unit.Module( getModule ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc as Utils ( singleton ) +import GHC.Data.Maybe( orElse ) +import Data.Maybe( mapMaybe ) +import Control.Monad( unless ) + + +{- ------------------------------------------------------------- + Note [Overview of type signatures] +---------------------------------------------------------------- +Type signatures, including partial signatures, are jolly tricky, +especially on value bindings. Here's an overview. + + f :: forall a. [a] -> [a] + g :: forall b. _ -> b + + f = ...g... + g = ...f... + +* HsSyn: a signature in a binding starts off as a TypeSig, in + type HsBinds.Sig + +* When starting a mutually recursive group, like f/g above, we + call tcTySig on each signature in the group. + +* tcTySig: Sig -> TcIdSigInfo + - For a /complete/ signature, like 'f' above, tcTySig kind-checks + the HsType, producing a Type, and wraps it in a CompleteSig, and + extend the type environment with this polymorphic 'f'. + + - For a /partial/signature, like 'g' above, tcTySig does nothing + Instead it just wraps the pieces in a PartialSig, to be handled + later. + +* tcInstSig: TcIdSigInfo -> TcIdSigInst + In tcMonoBinds, when looking at an individual binding, we use + tcInstSig to instantiate the signature forall's in the signature, + and attribute that instantiated (monomorphic) type to the + binder. You can see this in GHC.Tc.Gen.Bind.tcLhsId. + + The instantiation does the obvious thing for complete signatures, + but for /partial/ signatures it starts from the HsSyn, so it + has to kind-check it etc: tcHsPartialSigType. It's convenient + to do this at the same time as instantiation, because we can + make the wildcards into unification variables right away, raather + than somehow quantifying over them. And the "TcLevel" of those + unification variables is correct because we are in tcMonoBinds. + + +Note [Scoped tyvars] +~~~~~~~~~~~~~~~~~~~~ +The -XScopedTypeVariables flag brings lexically-scoped type variables +into scope for any explicitly forall-quantified type variables: + f :: forall a. a -> a + f x = e +Then 'a' is in scope inside 'e'. + +However, we do *not* support this + - For pattern bindings e.g + f :: forall a. a->a + (f,g) = e + +Note [Binding scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type variables *brought into lexical scope* by a type signature +may be a subset of the *quantified type variables* of the signatures, +for two reasons: + +* With kind polymorphism a signature like + f :: forall f a. f a -> f a + may actually give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a + So the sig_tvs will be [k,f,a], but only f,a are scoped. + NB: the scoped ones are not necessarily the *initial* ones! + +* Even aside from kind polymorphism, there may be more instantiated + type variables than lexically-scoped ones. For example: + type T a = forall b. b -> (a,b) + f :: forall c. T c + Here, the signature for f will have one scoped type variable, c, + but two instantiated type variables, c' and b'. + +However, all of this only applies to the renamer. The typechecker +just puts all of them into the type environment; any lexical-scope +errors were dealt with by the renamer. + +-} + + +{- ********************************************************************* +* * + Utility functions for TcSigInfo +* * +********************************************************************* -} + +tcIdSigName :: TcIdSigInfo -> Name +tcIdSigName (CompleteSig { sig_bndr = id }) = idName id +tcIdSigName (PartialSig { psig_name = n }) = n + +tcSigInfoName :: TcSigInfo -> Name +tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi +tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi + +completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId +completeSigPolyId_maybe sig + | TcIdSig sig_info <- sig + , CompleteSig { sig_bndr = id } <- sig_info = Just id + | otherwise = Nothing + + +{- ********************************************************************* +* * + Typechecking user signatures +* * +********************************************************************* -} + +tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) +tcTySigs hs_sigs + = checkNoErrs $ + do { -- Fail if any of the signatures is duff + -- Hence mapAndReportM + -- See Note [Fail eagerly on bad signatures] + ty_sigs_s <- mapAndReportM tcTySig hs_sigs + + ; let ty_sigs = concat ty_sigs_s + poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs + -- The returned [TcId] are the ones for which we have + -- a complete type signature. + -- See Note [Complete and partial type signatures] + env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] + + ; return (poly_ids, lookupNameEnv env) } + +tcTySig :: LSig GhcRn -> TcM [TcSigInfo] +tcTySig (L _ (IdSig _ id)) + = do { let ctxt = FunSigCtxt (idName id) False + -- False: do not report redundant constraints + -- The user has no control over the signature! + sig = completeSigFromId ctxt id + ; return [TcIdSig sig] } + +tcTySig (L loc (TypeSig _ names sig_ty)) + = setSrcSpan loc $ + do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) + | L _ name <- names ] + ; return (map TcIdSig sigs) } + +tcTySig (L loc (PatSynSig _ names sig_ty)) + = setSrcSpan loc $ + do { tpsigs <- sequence [ tcPatSynSig name sig_ty + | L _ name <- names ] + ; return (map TcPatSynSig tpsigs) } + +tcTySig _ = return [] + + +tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name + -> TcM TcIdSigInfo +-- A function or expression type signature +-- Returns a fully quantified type signature; even the wildcards +-- are quantified with ordinary skolems that should be instantiated +-- +-- The SrcSpan is what to declare as the binding site of the +-- any skolems in the signature. For function signatures we +-- use the whole `f :: ty' signature; for expression signatures +-- just the type part. +-- +-- Just n => Function type signature name :: type +-- Nothing => Expression type signature :: type +tcUserTypeSig loc hs_sig_ty mb_name + | isCompleteHsSig hs_sig_ty + = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty + ; traceTc "tcuser" (ppr sigma_ty) + ; return $ + CompleteSig { sig_bndr = mkLocalId name Many sigma_ty + -- We use `Many' as the multiplicity here, + -- as if this identifier corresponds to + -- anything, it is a top-level + -- definition. Which are all unrestricted in + -- the current implementation. + , sig_ctxt = ctxt_T + , sig_loc = loc } } + -- Location of the in f :: + + -- Partial sig with wildcards + | otherwise + = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty + , sig_ctxt = ctxt_F, sig_loc = loc }) + where + name = case mb_name of + Just n -> n + Nothing -> mkUnboundName (mkVarOcc "") + ctxt_F = case mb_name of + Just n -> FunSigCtxt n False + Nothing -> ExprSigCtxt + ctxt_T = case mb_name of + Just n -> FunSigCtxt n True + Nothing -> ExprSigCtxt + + + +completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo +-- Used for instance methods and record selectors +completeSigFromId ctxt id + = CompleteSig { sig_bndr = id + , sig_ctxt = ctxt + , sig_loc = getSrcSpan id } + +isCompleteHsSig :: LHsSigWcType GhcRn -> Bool +-- ^ If there are no wildcards, return a LHsSigType +isCompleteHsSig (HsWC { hswc_ext = wcs + , hswc_body = HsIB { hsib_body = hs_ty } }) + = null wcs && no_anon_wc hs_ty + +no_anon_wc :: LHsType GhcRn -> Bool +no_anon_wc lty = go lty + where + go (L _ ty) = case ty of + HsWildCardTy _ -> False + HsAppTy _ ty1 ty2 -> go ty1 && go ty2 + HsAppKindTy _ ty ki -> go ty && go ki + HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w) + HsListTy _ ty -> go ty + HsTupleTy _ _ tys -> gos tys + HsSumTy _ tys -> gos tys + HsOpTy _ ty1 _ ty2 -> go ty1 && go ty2 + HsParTy _ ty -> go ty + HsIParamTy _ _ ty -> go ty + HsKindSig _ ty kind -> go ty && go kind + HsDocTy _ ty _ -> go ty + HsBangTy _ _ ty -> go ty + HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds + HsExplicitListTy _ _ tys -> gos tys + HsExplicitTupleTy _ tys -> gos tys + HsForAllTy { hst_tele = tele + , hst_body = ty } -> no_anon_wc_tele tele + && go ty + HsQualTy { hst_ctxt = L _ ctxt + , hst_body = ty } -> gos ctxt && go ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty + HsSpliceTy{} -> True + HsTyLit{} -> True + HsTyVar{} -> True + HsStarTy{} -> True + XHsType (NHsCoreTy{}) -> True -- Core type, which does not have any wildcard + + gos = all go + +no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool +no_anon_wc_tele tele = case tele of + HsForAllVis { hsf_vis_bndrs = ltvs } -> all (go . unLoc) ltvs + HsForAllInvis { hsf_invis_bndrs = ltvs } -> all (go . unLoc) ltvs + where + go (UserTyVar _ _ _) = True + go (KindedTyVar _ _ _ ki) = no_anon_wc ki + +{- Note [Fail eagerly on bad signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a type signature is wrong, fail immediately: + + * the type sigs may bind type variables, so proceeding without them + can lead to a cascade of errors + + * the type signature might be ambiguous, in which case checking + the code against the signature will give a very similar error + to the ambiguity error. + +ToDo: this means we fall over if any top-level type signature in the +module is wrong, because we typecheck all the signatures together +(see GHC.Tc.Gen.Bind.tcValBinds). Moreover, because of top-level +captureTopConstraints, only insoluble constraints will be reported. +We typecheck all signatures at the same time because a signature +like f,g :: blah might have f and g from different SCCs. + +So it's a bit awkward to get better error recovery, and no one +has complained! +-} + +{- ********************************************************************* +* * + Type checking a pattern synonym signature +* * +************************************************************************ + +Note [Pattern synonym signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Pattern synonym signatures are surprisingly tricky (see #11224 for example). +In general they look like this: + + pattern P :: forall univ_tvs. req_theta + => forall ex_tvs. prov_theta + => arg1 -> .. -> argn -> res_ty + +For parsing and renaming we treat the signature as an ordinary LHsSigType. + +Once we get to type checking, we decompose it into its parts, in tcPatSynSig. + +* Note that 'forall univ_tvs' and 'req_theta =>' + and 'forall ex_tvs' and 'prov_theta =>' + are all optional. We gather the pieces at the top of tcPatSynSig + +* Initially the implicitly-bound tyvars (added by the renamer) include both + universal and existential vars. + +* After we kind-check the pieces and convert to Types, we do kind generalisation. + +Note [solveEqualities in tcPatSynSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that we solve /all/ the equalities in a pattern +synonym signature, because we are going to zonk the signature to +a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that +fails if there are un-filled-in coercion variables mentioned +in the type (#15694). + +The best thing is simply to use solveEqualities to solve all the +equalites, rather than leaving them in the ambient constraints +to be solved later. Pattern synonyms are top-level, so there's +no problem with completely solving them. + +(NB: this solveEqualities wraps newImplicitTKBndrs, which itself +does a solveLocalEqualities; so solveEqualities isn't going to +make any further progress; it'll just report any unsolved ones, +and fail, as it should.) +-} + +tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo +-- See Note [Pattern synonym signatures] +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcPatSynSig name sig_ty + | HsIB { hsib_ext = implicit_hs_tvs + , hsib_body = hs_ty } <- sig_ty + , (univ_hs_tvbndrs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty + , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 + = do { traceTc "tcPatSynSig 1" (ppr sig_ty) + ; (implicit_tvs, (univ_tvbndrs, (ex_tvbndrs, (req, prov, body_ty)))) + <- pushTcLevelM_ $ + solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] + bindImplicitTKBndrs_Skol implicit_hs_tvs $ + bindExplicitTKBndrs_Skol univ_hs_tvbndrs $ + bindExplicitTKBndrs_Skol ex_hs_tvbndrs $ + do { req <- tcHsContext hs_req + ; prov <- tcHsContext hs_prov + ; body_ty <- tcHsOpenType hs_body_ty + -- A (literal) pattern can be unlifted; + -- e.g. pattern Zero <- 0# (#12094) + ; return (req, prov, body_ty) } + + ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvbndrs + req ex_tvbndrs prov body_ty + + -- Kind generalisation + ; kvs <- kindGeneralizeAll ungen_patsyn_ty + ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) + + -- These are /signatures/ so we zonk to squeeze out any kind + -- unification variables. Do this after kindGeneralize which may + -- default kind variables to *. + ; implicit_tvs <- zonkAndScopedSort implicit_tvs + ; univ_tvbndrs <- mapM zonkTyCoVarKindBinder univ_tvbndrs + ; ex_tvbndrs <- mapM zonkTyCoVarKindBinder ex_tvbndrs + ; req <- zonkTcTypes req + ; prov <- zonkTcTypes prov + ; body_ty <- zonkTcType body_ty + + -- Skolems have TcLevels too, though they're used only for debugging. + -- If you don't do this, the debugging checks fail in GHC.Tc.TyCl.PatSyn. + -- Test case: patsyn/should_compile/T13441 +{- + ; tclvl <- getTcLevel + ; let env0 = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs + (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs + (env2, univ_tvs') = promoteSkolemsX tclvl env1 univ_tvs + (env3, ex_tvs') = promoteSkolemsX tclvl env2 ex_tvs + req' = substTys env3 req + prov' = substTys env3 prov + body_ty' = substTy env3 body_ty +-} + ; let implicit_tvs' = implicit_tvs + univ_tvbndrs' = univ_tvbndrs + ex_tvbndrs' = ex_tvbndrs + req' = req + prov' = prov + body_ty' = body_ty + + -- Now do validity checking + ; checkValidType ctxt $ + build_patsyn_type kvs implicit_tvs' univ_tvbndrs' req' ex_tvbndrs' prov' body_ty' + + -- arguments become the types of binders. We thus cannot allow + -- levity polymorphism here + ; let (arg_tys, _) = tcSplitFunTys body_ty' + ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys + + ; traceTc "tcTySig }" $ + vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' + , text "kvs" <+> ppr_tvs kvs + , text "univ_tvs" <+> ppr_tvs (binderVars univ_tvbndrs') + , text "req" <+> ppr req' + , text "ex_tvs" <+> ppr_tvs (binderVars ex_tvbndrs') + , text "prov" <+> ppr prov' + , text "body_ty" <+> ppr body_ty' ] + ; return (TPSI { patsig_name = name + , patsig_implicit_bndrs = mkTyVarBinders InferredSpec kvs ++ + mkTyVarBinders SpecifiedSpec implicit_tvs' + , patsig_univ_bndrs = univ_tvbndrs' + , patsig_req = req' + , patsig_ex_bndrs = ex_tvbndrs' + , patsig_prov = prov' + , patsig_body_ty = body_ty' }) } + where + ctxt = PatSynCtxt name + + build_patsyn_type kvs imp univ_bndrs req ex_bndrs prov body + = mkInfForAllTys kvs $ + mkSpecForAllTys imp $ + mkInvisForAllTys univ_bndrs $ + mkPhiTy req $ + mkInvisForAllTys ex_bndrs $ + mkPhiTy prov $ + body + +ppr_tvs :: [TyVar] -> SDoc +ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) + | tv <- tvs]) + + +{- ********************************************************************* +* * + Instantiating user signatures +* * +********************************************************************* -} + + +tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst +-- Instantiate a type signature; only used with plan InferGen +tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { (tv_prs, theta, tau) <- tcInstTypeBndrs poly_id + -- See Note [Pattern bindings and complete signatures] + + ; return (TISI { sig_inst_sig = sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = [] + , sig_inst_wcx = Nothing + , sig_inst_theta = theta + , sig_inst_tau = tau }) } + +tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty + , sig_ctxt = ctxt + , sig_loc = loc }) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { traceTc "Staring partial sig {" (ppr hs_sig) + ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty + -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType + ; let inst_sig = TISI { sig_inst_sig = hs_sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = wcs + , sig_inst_wcx = wcx + , sig_inst_theta = theta + , sig_inst_tau = tau } + ; traceTc "End partial sig }" (ppr inst_sig) + ; return inst_sig } + + +{- Note [Pattern bindings and complete signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = MkT a a + f :: forall a. a->a + g :: forall b. b->b + MkT f g = MkT (\x->x) (\y->y) +Here we'll infer a type from the pattern of 'T a', but if we feed in +the signature types for f and g, we'll end up unifying 'a' and 'b' + +So we instantiate f and g's signature with TyVarTv skolems +(newMetaTyVarTyVars) that can unify with each other. If too much +unification takes place, we'll find out when we do the final +impedance-matching check in GHC.Tc.Gen.Bind.mkExport + +See Note [Signature skolems] in GHC.Tc.Utils.TcType + +None of this applies to a function binding with a complete +signature, which doesn't use tcInstSig. See GHC.Tc.Gen.Bind.tcPolyCheck. +-} + +{- ********************************************************************* +* * + Pragmas and PragEnv +* * +********************************************************************* -} + +type TcPragEnv = NameEnv [LSig GhcRn] + +emptyPragEnv :: TcPragEnv +emptyPragEnv = emptyNameEnv + +lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] +lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] + +extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv +extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) Utils.singleton prag_fn n sig + +--------------- +mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv +mkPragEnv sigs binds + = foldl' extendPragEnv emptyNameEnv prs + where + prs = mapMaybe get_sig sigs + + get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) + get_sig (L l (SpecSig x lnm@(L _ nm) ty inl)) + = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl)) + get_sig (L l (InlineSig x lnm@(L _ nm) inl)) + = Just (nm, L l $ InlineSig x lnm (add_arity nm inl)) + get_sig (L l (SCCFunSig x st lnm@(L _ nm) str)) + = Just (nm, L l $ SCCFunSig x st lnm str) + get_sig _ = Nothing + + add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function + | Inline <- inl_inline inl_prag + -- add arity only for real INLINE pragmas, not INLINABLE + = case lookupNameEnv ar_env n of + Just ar -> inl_prag { inl_sat = Just ar } + Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) + -- There really should be a binding for every INLINE pragma + inl_prag + | otherwise + = inl_prag + + -- ar_env maps a local to the arity of its definition + ar_env :: NameEnv Arity + ar_env = foldr lhsBindArity emptyNameEnv binds + +lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupArity ms) +lhsBindArity _ env = env -- PatBind/VarBind + + +----------------- +addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId +addInlinePrags poly_id prags_for_me + | inl@(L _ prag) : inls <- inl_prags + = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) + ; unless (null inls) (warn_multiple_inlines inl inls) + ; return (poly_id `setInlinePragma` prag) } + | otherwise + = return poly_id + where + inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] + + warn_multiple_inlines _ [] = return () + + warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) + | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 + , noUserInlineSpec (inlinePragmaSpec prag1) + = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop + -- and inl2 is a user NOINLINE pragma; we don't want to complain + warn_multiple_inlines inl2 inls + | otherwise + = setSrcSpan loc $ + addWarnTc NoReason + (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (inl1:inl2:inls)))) + + pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) + + +{- ********************************************************************* +* * + SPECIALISE pragmas +* * +************************************************************************ + +Note [Handling SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is this: + + foo :: Num a => a -> b -> a + {-# SPECIALISE foo :: Int -> b -> Int #-} + +We check that + (forall a b. Num a => a -> b -> a) + is more polymorphic than + forall b. Int -> b -> Int +(for which we could use tcSubType, but see below), generating a HsWrapper +to connect the two, something like + wrap = /\b. Int b dNumInt +This wrapper is put in the TcSpecPrag, in the ABExport record of +the AbsBinds. + + + f :: (Eq a, Ix b) => a -> b -> Bool + {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} + f = + +From this the typechecker generates + + AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds + + SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX + -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) + +From these we generate: + + Rule: forall p, q, (dp:Ix p), (dq:Ix q). + f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq + + Spec bind: f_spec = wrap_fn + +Note that + + * The LHS of the rule may mention dictionary *expressions* (eg + $dfIxPair dp dq), and that is essential because the dp, dq are + needed on the RHS. + + * The RHS of f_spec, has a *copy* of 'binds', so that it + can fully specialise it. + +From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: + + f_spec :: Int -> b -> Int + f_spec = wrap + + RULE: forall b (d:Num b). f b d = f_spec b + +The RULE is generated by taking apart the HsWrapper, which is a little +delicate, but works. + +Some wrinkles + +1. In tcSpecWrapper, rather than calling tcSubType, we directly call + skolemise/instantiate. That is mainly because of wrinkle (2). + + Historical note: in the past, tcSubType did co/contra stuff, which + could generate too complex a LHS for the RULE, which was another + reason for not using tcSubType. But that reason has gone away + with simple subsumption (#17775). + +2. We need to take care with type families (#5821). Consider + type instance F Int = Bool + f :: Num a => a -> F a + {-# SPECIALISE foo :: Int -> Bool #-} + + We *could* try to generate an f_spec with precisely the declared type: + f_spec :: Int -> Bool + f_spec = Int dNumInt |> co + + RULE: forall d. f Int d = f_spec |> sym co + + but the 'co' and 'sym co' are (a) playing no useful role, and (b) are + hard to generate. At all costs we must avoid this: + RULE: forall d. f Int d |> co = f_spec + because the LHS will never match (indeed it's rejected in + decomposeRuleLhs). + + So we simply do this: + - Generate a constraint to check that the specialised type (after + skolemisation) is equal to the instantiated function type. + - But *discard* the evidence (coercion) for that constraint, + so that we ultimately generate the simpler code + f_spec :: Int -> F Int + f_spec = Int dNumInt + + RULE: forall d. f Int d = f_spec + You can see this discarding happening in tcSpecPrag + +3. Note that the HsWrapper can transform *any* function with the right + type prefix + forall ab. (Eq a, Ix b) => XXX + regardless of XXX. It's sort of polymorphic in XXX. This is + useful: we use the same wrapper to transform each of the class ops, as + well as the dict. That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags +-} + +tcSpecPrags :: Id -> [LSig GhcRn] + -> TcM [LTcSpecPrag] +-- Add INLINE and SPECIALSE pragmas +-- INLINE prags are added to the (polymorphic) Id directly +-- SPECIALISE prags are passed to the desugarer via TcSpecPrags +-- Pre-condition: the poly_id is zonked +-- Reason: required by tcSubExp +tcSpecPrags poly_id prag_sigs + = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) + ; unless (null bad_sigs) warn_discarded_sigs + ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs + ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } + where + spec_sigs = filter isSpecLSig prag_sigs + bad_sigs = filter is_bad_sig prag_sigs + is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) + + warn_discarded_sigs + = addWarnTc NoReason + (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) bad_sigs))) + +-------------- +tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] +tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) +-- See Note [Handling SPECIALISE pragmas] +-- +-- The Name fun_name in the SpecSig may not be the same as that of the poly_id +-- Example: SPECIALISE for a class method: the Name in the SpecSig is +-- for the selector Id, but the poly_id is something like $cop +-- However we want to use fun_name in the error message, since that is +-- what the user wrote (#8537) + = addErrCtxt (spec_ctxt prag) $ + do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) + (text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name)) + -- Note [SPECIALISE pragmas] + ; spec_prags <- mapM tc_one hs_tys + ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) + ; return spec_prags } + where + name = idName poly_id + poly_ty = idType poly_id + spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) + + tc_one hs_ty + = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty + ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty + ; return (SpecPrag poly_id wrap inl) } + +tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) + +-------------- +tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper +-- A simpler variant of tcSubType, used for SPECIALISE pragmas +-- See Note [Handling SPECIALISE pragmas], wrinkle 1 +tcSpecWrapper ctxt poly_ty spec_ty + = do { (sk_wrap, inst_wrap) + <- tcSkolemise ctxt spec_ty $ \ spec_tau -> + do { (inst_wrap, tau) <- topInstantiate orig poly_ty + ; _ <- unifyType Nothing spec_tau tau + -- Deliberately ignore the evidence + -- See Note [Handling SPECIALISE pragmas], + -- wrinkle (2) + ; return inst_wrap } + ; return (sk_wrap <.> inst_wrap) } + where + orig = SpecPragOrigin ctxt + +-------------- +tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] +-- SPECIALISE pragmas for imported things +tcImpPrags prags + = do { this_mod <- getModule + ; dflags <- getDynFlags + ; if (not_specialising dflags) then + return [] + else do + { pss <- mapAndRecoverM (wrapLocM tcImpSpec) + [L loc (name,prag) + | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] + ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } + where + -- Ignore SPECIALISE pragmas for imported things + -- when we aren't specialising, or when we aren't generating + -- code. The latter happens when Haddocking the base library; + -- we don't want complaints about lack of INLINABLE pragmas + not_specialising dflags + | not (gopt Opt_Specialise dflags) = True + | otherwise = case hscTarget dflags of + HscNothing -> True + HscInterpreted -> True + _other -> False + +tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] +tcImpSpec (name, prag) + = do { id <- tcLookupId name + ; if isAnyInlinePragma (idInlinePragma id) + then tcSpecPrag id prag + else do { addWarnTc NoReason (impSpecErr name) + ; return [] } } + -- If there is no INLINE/INLINABLE pragma there will be no unfolding. In + -- that case, just delete the SPECIALISE pragma altogether, lest the + -- desugarer fall over because it can't find the unfolding. See #18118. + +impSpecErr :: Name -> SDoc +impSpecErr name + = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) + 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" + , parens $ sep + [ text "or its defining module" <+> quotes (ppr mod) + , text "was compiled without -O"]]) + where + mod = nameModule name diff --git a/GHC/Tc/Gen/Splice.hs b/GHC/Tc/Gen/Splice.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Splice.hs @@ -0,0 +1,2436 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Template Haskell splices +module GHC.Tc.Gen.Splice( + tcSpliceExpr, tcTypedBracket, tcUntypedBracket, +-- runQuasiQuoteExpr, runQuasiQuotePat, +-- runQuasiQuoteDecl, runQuasiQuoteType, + runAnnotation, + + runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + tcTopSpliceExpr, lookupThName_maybe, + defaultRunMeta, runMeta', runRemoteModFinalizers, + finishTH, runTopSplice + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Types.Annotations +import GHC.Driver.Finder +import GHC.Types.Name +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity + +import GHC.Utils.Outputable +import GHC.Tc.Gen.Expr +import GHC.Types.SrcLoc +import GHC.Builtin.Names.TH +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Core.Coercion( etaExpandCoAxBranch ) +import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) + +import Control.Monad + +import GHCi.Message +import GHCi.RemoteTypes +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types +import GHC.Driver.Main + -- These imports are the reason that GHC.Tc.Gen.Splice + -- is very high up the module hierarchy +import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) +import GHC.Types.Name.Reader +import GHC.Driver.Types +import GHC.ThToHs +import GHC.Rename.Expr +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..) ) +import GHC.Rename.Fixity ( lookupFixityRn_help ) +import GHC.Rename.HsType +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Core.Type as Type +import GHC.Types.Name.Set +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.HsType +import GHC.IfaceToCore +import GHC.Core.TyCo.Rep as TyCoRep +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv as InstEnv +import GHC.Tc.Utils.Instantiate +import GHC.Types.Name.Env +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Types.Name.Occurrence as OccName +import GHC.Driver.Hooks +import GHC.Types.Var +import GHC.Unit.Module +import GHC.Iface.Load +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.PatSyn +import GHC.Core.ConLike +import GHC.Core.DataCon as DataCon +import GHC.Tc.Types.Evidence +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.Serialized +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Types.Unique +import GHC.Types.Var.Set +import Data.List ( find ) +import Data.Maybe +import GHC.Data.FastString +import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) +import GHC.Data.Maybe( MaybeErr(..) ) +import GHC.Driver.Session +import GHC.Utils.Panic as Panic +import GHC.Utils.Lexeme +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Driver.Plugins +import GHC.Data.Bag + +import qualified Language.Haskell.TH as TH +-- THSyntax gives access to internal functions and data types +import qualified Language.Haskell.TH.Syntax as TH + +#if defined(HAVE_INTERNAL_INTERPRETER) +-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler +import GHC.Desugar ( AnnotationWrapper(..) ) +import Unsafe.Coerce ( unsafeCoerce ) +#endif + +import Control.Exception +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Dynamic ( fromDynamic, toDyn ) +import qualified Data.Map as Map +import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) +import Data.Data (Data) +import Data.Proxy ( Proxy (..) ) + +{- +************************************************************************ +* * +\subsection{Main interface + stubs for the non-GHCI case +* * +************************************************************************ +-} + +tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + -- None of these functions add constraints to the LIE + +-- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) +-- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) +-- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) +-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] + +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +{- +************************************************************************ +* * +\subsection{Quoting an expression} +* * +************************************************************************ +-} + +-- See Note [How brackets and nested splices are handled] +-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) +tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty + = addErrCtxt (quotationCtxtDoc brack) $ + do { cur_stage <- getStage + ; ps_ref <- newMutVar [] + ; lie_var <- getConstraintVar -- Any constraints arising from nested splices + -- should get thrown into the constraint set + -- from outside the bracket + + -- Make a new type variable for the type of the overall quote + ; m_var <- mkTyVarTy <$> mkMetaTyVar + -- Make sure the type variable satisfies Quote + ; ev_var <- emitQuoteWanted m_var + -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring + -- brackets. + ; let wrapper = QuoteWrapper ev_var m_var + -- Typecheck expr to make sure it is valid, + -- Throw away the typechecked expression but return its type. + -- We'll typecheck it again when we splice it in somewhere + ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $ + tcScalingUsage Many $ + -- Scale by Many, TH lifting is currently nonlinear (#18465) + tcInferRhoNC expr + -- NC for no context; tcBracket does that + ; let rep = getRuntimeRep expr_ty + ; meta_ty <- tcTExpTy m_var expr_ty + ; ps' <- readMutVar ps_ref + ; texpco <- tcLookupId unsafeCodeCoerceName + ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") + rn_expr + (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) + (nlHsTyApp texpco [rep, expr_ty])) + (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps')))) + meta_ty res_ty } +tcTypedBracket _ other_brack _ + = pprPanic "tcTypedBracket" (ppr other_brack) + +-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) +-- See Note [Typechecking Overloaded Quotes] +tcUntypedBracket rn_expr brack ps res_ty + = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) + + + -- Create the type m Exp for expression bracket, m Type for a type + -- bracket and so on. The brack_info is a Maybe because the + -- VarBracket ('a) isn't overloaded, but also shouldn't contain any + -- splices. + ; (brack_info, expected_type) <- brackTy brack + + -- Match the expected type with the type of all the internal + -- splices. They might have further constrained types and if they do + -- we want to reflect that in the overall type of the bracket. + ; ps' <- case quoteWrapperTyVarTy <$> brack_info of + Just m_var -> mapM (tcPendingSplice m_var) ps + Nothing -> ASSERT(null ps) return [] + + ; traceTc "tc_bracket done untyped" (ppr expected_type) + + -- Unify the overall type of the bracket with the expected result + -- type + ; tcWrapResultO BracketOrigin rn_expr + (HsTcBracketOut noExtField brack_info brack ps') + expected_type res_ty + + } + +-- | A type variable with kind * -> * named "m" +mkMetaTyVar :: TcM TyVar +mkMetaTyVar = + newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind) + + +-- | For a type 'm', emit the constraint 'Quote m'. +emitQuoteWanted :: Type -> TcM EvVar +emitQuoteWanted m_var = do + quote_con <- tcLookupTyCon quoteClassName + emitWantedEvVar BracketOrigin $ + mkTyConApp quote_con [m_var] + +--------------- +-- | Compute the expected type of a quotation, and also the QuoteWrapper in +-- the case where it is an overloaded quotation. All quotation forms are +-- overloaded aprt from Variable quotations ('foo) +brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type) +brackTy b = + let mkTy n = do + -- New polymorphic type variable for the bracket + m_var <- mkTyVarTy <$> mkMetaTyVar + -- Emit a Quote constraint for the bracket + ev_var <- emitQuoteWanted m_var + -- Construct the final expected type of the quote, for example + -- m Exp or m Type + final_ty <- mkAppTy m_var <$> tcMetaTy n + -- Return the evidence variable and metavariable to be used during + -- desugaring. + let wrapper = QuoteWrapper ev_var m_var + return (Just wrapper, final_ty) + in + case b of + (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName + -- Result type is Var (not Quote-monadic) + (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp + (TypBr {}) -> mkTy typeTyConName -- Result type is m Type + (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec] + (PatBr {}) -> mkTy patTyConName -- Result type is m Pat + (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" + (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr" + +--------------- +-- | Typechecking a pending splice from a untyped bracket +tcPendingSplice :: TcType -- Metavariable for the expected overall type of the + -- quotation. + -> PendingRnSplice + -> TcM PendingTcSplice +tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) + -- See Note [Typechecking Overloaded Quotes] + = do { meta_ty <- tcMetaTy meta_ty_name + -- Expected type of splice, e.g. m Exp + ; let expected_type = mkAppTy m_var meta_ty + ; expr' <- tcScalingUsage Many $ tcCheckPolyExpr expr expected_type + -- Scale by Many, TH lifting is currently nonlinear (#18465) + ; return (PendingTcSplice splice_name expr') } + where + meta_ty_name = case flavour of + UntypedExpSplice -> expTyConName + UntypedPatSplice -> patTyConName + UntypedTypeSplice -> typeTyConName + UntypedDeclSplice -> decsTyConName + +--------------- +-- Takes a m and tau and returns the type m (TExp tau) +tcTExpTy :: TcType -> TcType -> TcM TcType +tcTExpTy m_ty exp_ty + = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) + ; codeCon <- tcLookupTyCon codeTyConName + ; let rep = getRuntimeRep exp_ty + ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } + where + err_msg ty + = vcat [ text "Illegal polytype:" <+> ppr ty + , text "The type of a Typed Template Haskell expression must" <+> + text "not have any quantification." ] + +quotationCtxtDoc :: HsBracket GhcRn -> SDoc +quotationCtxtDoc br_body + = hang (text "In the Template Haskell quotation") + 2 (ppr br_body) + + + -- The whole of the rest of the file is the else-branch (ie stage2 only) + +{- +Note [How top-level splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level splices (those not inside a [| .. |] quotation bracket) are handled +very straightforwardly: + + 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) + + 2. runMetaT: desugar, compile, run it, and convert result back to + GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, + HsExpr RdrName etc) + + 3. treat the result as if that's what you saw in the first place + e.g for HsType, rename and kind-check + for HsExpr, rename and type-check + + (The last step is different for decls, because they can *only* be + top-level: we return the result of step 2.) + +Note [How brackets and nested splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nested splices (those inside a [| .. |] quotation bracket), +are treated quite differently. + +Remember, there are two forms of bracket + typed [|| e ||] + and untyped [| e |] + +The life cycle of a typed bracket: + * Starts as HsBracket + + * When renaming: + * Set the ThStage to (Brack s RnPendingTyped) + * Rename the body + * Result is still a HsBracket + + * When typechecking: + * Set the ThStage to (Brack s (TcPending ps_var lie_var)) + * Typecheck the body, and throw away the elaborated result + * Nested splices (which must be typed) are typechecked, and + the results accumulated in ps_var; their constraints + accumulate in lie_var + * Result is a HsTcBracketOut rn_brack pending_splices + where rn_brack is the incoming renamed bracket + +The life cycle of a un-typed bracket: + * Starts as HsBracket + + * When renaming: + * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) + * Rename the body + * Nested splices (which must be untyped) are renamed, and the + results accumulated in ps_var + * Result is still (HsRnBracketOut rn_body pending_splices) + + * When typechecking a HsRnBracketOut + * Typecheck the pending_splices individually + * Ignore the body of the bracket; just check that the context + expects a bracket of that type (e.g. a [p| pat |] bracket should + be in a context needing a (Q Pat) + * Result is a HsTcBracketOut rn_brack pending_splices + where rn_brack is the incoming renamed bracket + + +In both cases, desugaring happens like this: + * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket. It + + a) Extends the ds_meta environment with the PendingSplices + attached to the bracket + + b) Converts the quoted (HsExpr Name) to a CoreExpr that, when + run, will produce a suitable TH expression/type/decl. This + is why we leave the *renamed* expression attached to the bracket: + the quoted expression should not be decorated with all the goop + added by the type checker + + * Each splice carries a unique Name, called a "splice point", thus + ${n}(e). The name is initialised to an (Unqual "splice") when the + splice is created; the renamer gives it a unique. + + * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across + a splice, it looks up the splice's Name, n, in the ds_meta envt, + to find an (HsExpr Id) that should be substituted for the splice; + it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). + +Example: + Source: f = [| Just $(g 3) |] + The [| |] part is a HsBracket + + Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} + The [| |] part is a HsBracketOut, containing *renamed* + (not typechecked) expression + The "s7" is the "splice point"; the (g Int 3) part + is a typechecked expression + + Desugared: f = do { s7 <- g Int 3 + ; return (ConE "Data.Maybe.Just" s7) } + + +Note [Template Haskell state diagram] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the ThStages, s, their corresponding level numbers +(the result of (thLevel s)), and their state transitions. +The top level of the program is stage Comp: + + Start here + | + V + ----------- $ ------------ $ + | Comp | ---------> | Splice | -----| + | 1 | | 0 | <----| + ----------- ------------ + ^ | ^ | + $ | | [||] $ | | [||] + | v | v + -------------- ---------------- + | Brack Comp | | Brack Splice | + | 2 | | 1 | + -------------- ---------------- + +* Normal top-level declarations start in state Comp + (which has level 1). + Annotations start in state Splice, since they are + treated very like a splice (only without a '$') + +* Code compiled in state Splice (and only such code) + will be *run at compile time*, with the result replacing + the splice + +* The original paper used level -1 instead of 0, etc. + +* The original paper did not allow a splice within a + splice, but there is no reason not to. This is the + $ transition in the top right. + +Note [Template Haskell levels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Imported things are impLevel (= 0) + +* However things at level 0 are not *necessarily* imported. + eg $( \b -> ... ) here b is bound at level 0 + +* In GHCi, variables bound by a previous command are treated + as impLevel, because we have bytecode for them. + +* Variables are bound at the "current level" + +* The current level starts off at outerLevel (= 1) + +* The level is decremented by splicing $(..) + incremented by brackets [| |] + incremented by name-quoting 'f + +* When a variable is used, checkWellStaged compares + bind: binding level, and + use: current level at usage site + + Generally + bind > use Always error (bound later than used) + [| \x -> $(f x) |] + + bind = use Always OK (bound same stage as used) + [| \x -> $(f [| x |]) |] + + bind < use Inside brackets, it depends + Inside splice, OK + Inside neither, OK + + For (bind < use) inside brackets, there are three cases: + - Imported things OK f = [| map |] + - Top-level things OK g = [| f |] + - Non-top-level Only if there is a liftable instance + h = \(x:Int) -> [| x |] + + To track top-level-ness we use the ThBindEnv in TcLclEnv + + For example: + f = ... + g1 = $(map ...) is OK + g2 = $(f ...) is not OK; because we haven't compiled f yet + +Note [Typechecking Overloaded Quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The main function for typechecking untyped quotations is `tcUntypedBracket`. + +Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`. +When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and +emit a constraint `Quote m`. All this is done in the `brackTy` function. +`brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc). + +The meta variable and the constraint evidence variable are +returned together in a `QuoteWrapper` and then passed along to two further places +during compilation: + +1. Typechecking nested splices (immediately in tcPendingSplice) +2. Desugaring quotations (see GHC.HsToCore.Quote) + +`tcPendingSplice` takes the `m` type variable as an argument and checks +each nested splice against this variable `m`. During this +process the variable `m` can either be fixed to a specific value or further constrained by the +nested splices. + +Once we have checked all the nested splices, the quote type is checked against +the expected return type. + +The process is very simple and like typechecking a list where the quotation is +like the container and the splices are the elements of the list which must have +a specific type. + +After the typechecking process is completed, the evidence variable for `Quote m` +and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline +and used when desugaring quotations. + +Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored +in the `PendingStuff` as the nested splices are gathered up in a different way +to untyped splices. Untyped splices are found in the renamer but typed splices are +not typechecked and extracted until during typechecking. + +-} + +-- | We only want to produce warnings for TH-splices if the user requests so. +-- See Note [Warnings for TH splices]. +getThSpliceOrigin :: TcM Origin +getThSpliceOrigin = do + warn <- goptM Opt_EnableThSpliceWarnings + if warn then return FromSource else return Generated + +{- Note [Warnings for TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only produce warnings for TH splices when the user requests so +(-fenable-th-splice-warnings). There are multiple reasons: + + * It's not clear that the user that compiles a splice is the author of the code + that produces the warning. Think of the situation where she just splices in + code from a third-party library that produces incomplete pattern matches. + In this scenario, the user isn't even able to fix that warning. + * Gathering information for producing the warnings (pattern-match check + warnings in particular) is costly. There's no point in doing so if the user + is not interested in those warnings. + +That's why we store Origin flags in the Haskell AST. The functions from ThToHs +take such a flag and depending on whether TH splice warnings were enabled or +not, we pass FromSource (if the user requests warnings) or Generated +(otherwise). This is implemented in getThSpliceOrigin. + +For correct pattern-match warnings it's crucial that we annotate the Origin +consistently (#17270). In the future we could offer the Origin as part of the +TH AST. That would enable us to give quotes from the current module get +FromSource origin, and/or third library authors to tag certain parts of +generated code as FromSource to enable warnings. That effort is tracked in +#14838. +-} + +{- +************************************************************************ +* * +\subsection{Splicing an expression} +* * +************************************************************************ +-} + +tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty + = addErrCtxt (spliceCtxtDoc splice) $ + setSrcSpan (getLoc expr) $ do + { stage <- getStage + ; case stage of + Splice {} -> tcTopSplice expr res_ty + Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty + RunSplice _ -> + -- See Note [RunSplice ThLevel] in "GHC.Tc.Types". + pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ + "running another splice") (ppr splice) + Comp -> tcTopSplice expr res_ty + } +tcSpliceExpr splice _ + = pprPanic "tcSpliceExpr" (ppr splice) + +{- Note [Collecting modFinalizers in typed splices] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local +environment (see Note [Delaying modFinalizers in untyped splices] in +GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the +finalizer list in the global environment and set them to use the current local +environment (with 'addModFinalizersWithLclEnv'). + +-} + +tcNestedSplice :: ThStage -> PendingStuff -> Name + -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + -- See Note [How brackets and nested splices are handled] + -- A splice inside brackets +tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty + = do { res_ty <- expTypeToType res_ty + ; let rep = getRuntimeRep res_ty + ; meta_exp_ty <- tcTExpTy m_var res_ty + ; expr' <- setStage pop_stage $ + setConstraintVar lie_var $ + tcCheckMonoExpr expr meta_exp_ty + ; untype_code <- tcLookupId unTypeCodeName + ; let expr'' = mkHsApp + (mkLHsWrap (applyQuoteWrapper q) + (nlHsTyApp untype_code [rep, res_ty])) expr' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) + + -- The returned expression is ignored; it's in the pending splices + -- But we still return a plausible expression + -- (a) in case we print it in debug messages, and + -- (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp + ; return (HsSpliceE noExtField $ + HsSpliced noExtField (ThModFinalizers []) $ + HsSplicedExpr (unLoc expr'')) } + + +tcNestedSplice _ _ splice_name _ _ + = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) + +tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcTopSplice expr res_ty + = do { -- Typecheck the expression, + -- making sure it has type Q (T res_ty) + res_ty <- expTypeToType res_ty + ; q_type <- tcMetaTy qTyConName + -- Top level splices must still be of type Q (TExp a) + ; meta_exp_ty <- tcTExpTy q_type res_ty + ; q_expr <- tcTopSpliceExpr Typed $ + tcCheckMonoExpr expr meta_exp_ty + ; lcl_env <- getLclEnv + ; let delayed_splice + = DelayedSplice lcl_env expr res_ty q_expr + ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice))) + + } + + +-- This is called in the zonker +-- See Note [Running typed splices in the zonker] +runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) +runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) + = do + errs_var <- getErrsVar + setLclEnv lcl_env $ setErrsVar errs_var $ do { + -- Set the errs_var to the errs_var from the current context, + -- otherwise error messages can go missing in GHCi (#19470) + zonked_ty <- zonkTcType res_ty + ; zonked_q_expr <- zonkTopLExpr q_expr + -- See Note [Collecting modFinalizers in typed splices]. + ; modfinalizers_ref <- newTcRef [] + -- Run the expression + ; expr2 <- setStage (RunSplice modfinalizers_ref) $ + runMetaE zonked_q_expr + ; mod_finalizers <- readTcRef modfinalizers_ref + ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers + -- We use orig_expr here and not q_expr when tracing as a call to + -- unsafeTExpCoerce is added to the original expression by the + -- typechecker when typed quotes are type checked. + ; traceSplice (SpliceInfo { spliceDescription = "expression" + , spliceIsDecl = False + , spliceSource = Just orig_expr + , spliceGenerated = ppr expr2 }) + -- Rename and typecheck the spliced-in expression, + -- making sure it has type res_ty + -- These steps should never fail; this is a *typed* splice + ; (res, wcs) <- + captureConstraints $ + addErrCtxt (spliceResultDoc zonked_q_expr) $ do + { (exp3, _fvs) <- rnLExpr expr2 + ; tcCheckMonoExpr exp3 zonked_ty } + ; ev <- simplifyTop wcs + ; return $ unLoc (mkHsDictLet (EvBinds ev) res) + } + + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +spliceCtxtDoc :: HsSplice GhcRn -> SDoc +spliceCtxtDoc splice + = hang (text "In the Template Haskell splice") + 2 (pprSplice splice) + +spliceResultDoc :: LHsExpr GhcTc -> SDoc +spliceResultDoc expr + = sep [ text "In the result of the splice:" + , nest 2 (char '$' <> ppr expr) + , text "To see what the splice expanded to, use -ddump-splices"] + +------------------- +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) +-- Note [How top-level splices are handled] +-- Type check an expression that is the body of a top-level splice +-- (the caller will compile and run it) +-- Note that set the level to Splice, regardless of the original level, +-- before typechecking the expression. For example: +-- f x = $( ...$(g 3) ... ) +-- The recursive call to tcCheckPolyExpr will simply expand the +-- inner escape before dealing with the outer one + +tcTopSpliceExpr isTypedSplice tc_action + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + unsetGOptM Opt_DeferTypeErrors $ + -- Don't defer type errors. Not only are we + -- going to run this code, but we do an unsafe + -- coerce, so we get a seg-fault if, say we + -- splice a type into a place where an expression + -- is expected (#7276) + setStage (Splice isTypedSplice) $ + do { -- Typecheck the expression + (mb_expr', wanted) <- tryCaptureConstraints tc_action + -- If tc_action fails (perhaps because of insoluble constraints) + -- we want to capture and report those constraints, else we may + -- just get a silent failure (#20179). Hence the 'try' part. + + ; const_binds <- simplifyTop wanted + + ; case mb_expr' of + Nothing -> failM -- In this case simplifyTop should have + -- reported some errors + Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' } + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +runAnnotation target expr = do + -- Find the classes we want instances for in order to call toAnnotationWrapper + loc <- getSrcSpanM + data_class <- tcLookupClass dataClassName + to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName + + -- Check the instances we require live in another module (we want to execute it..) + -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr + -- also resolves the LIE constraints to detect e.g. instance ambiguity + zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( + do { (expr', expr_ty) <- tcInferRhoNC expr + -- We manually wrap the typechecked expression in a call to toAnnotationWrapper + -- By instantiating the call >here< it gets registered in the + -- LIE consulted by tcTopSpliceExpr + -- and hence ensures the appropriate dictionary is bound by const_binds + ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + ; let specialised_to_annotation_wrapper_expr + = L loc (mkHsWrap wrapper + (HsVar noExtField (L loc to_annotation_wrapper_id))) + ; return (L loc (HsApp noExtField + specialised_to_annotation_wrapper_expr expr')) + }) + + -- Run the appropriately wrapped expression to get the value of + -- the annotation and its dictionaries. The return value is of + -- type AnnotationWrapper by construction, so this conversion is + -- safe + serialized <- runMetaAW zonked_wrapped_expr' + return Annotation { + ann_target = target, + ann_value = serialized + } + +convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) +convertAnnotationWrapper fhv = do + interp <- tcGetInterp + case interp of + ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + annotation_wrapper <- liftIO $ wormhole InternalInterp fhv + return $ Right $ + case unsafeCoerce annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- annotation are exposed at this point. This is also why we are + -- doing all this stuff inside the context of runMeta: it has the + -- facilities to deal with user error in a meta-level expression + seqSerialized serialized `seq` serialized + +-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms +seqSerialized :: Serialized -> () +seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () + +#endif + +{- +************************************************************************ +* * +\subsection{Running an expression} +* * +************************************************************************ +-} + +runQuasi :: TH.Q a -> TcM a +runQuasi act = TH.runQ act + +runRemoteModFinalizers :: ThModFinalizers -> TcM () +runRemoteModFinalizers (ThModFinalizers finRefs) = do + let withForeignRefs [] f = f [] + withForeignRefs (x : xs) f = withForeignRef x $ \r -> + withForeignRefs xs $ \rs -> f (r : rs) + interp <- tcGetInterp + case interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + qs <- liftIO (withForeignRefs finRefs $ mapM localRef) + runQuasi $ sequence_ qs +#endif + + ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do + tcg <- getGblEnv + th_state <- readTcRef (tcg_th_remote_state tcg) + case th_state of + Nothing -> return () -- TH was not started, nothing to do + Just fhv -> do + liftIO $ withForeignRef fhv $ \st -> + withForeignRefs finRefs $ \qrefs -> + writeIServ i (putMessage (RunModFinalizers st qrefs)) + () <- runRemoteTH i [] + readQResult i + +runQResult + :: (a -> String) + -> (Origin -> SrcSpan -> a -> b) + -> (ForeignHValue -> TcM a) + -> SrcSpan + -> ForeignHValue {- TH.Q a -} + -> TcM b +runQResult show_th f runQ expr_span hval + = do { th_result <- runQ hval + ; th_origin <- getThSpliceOrigin + ; traceTc "Got TH result:" (text (show_th th_result)) + ; return (f th_origin expr_span th_result) } + + +----------------- +runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) + -> LHsExpr GhcTc + -> TcM hs_syn +runMeta unwrap e + = do { h <- getHooked runMetaHook defaultRunMeta + ; unwrap h e } + +defaultRunMeta :: MetaHook TcM +defaultRunMeta (MetaE r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) +defaultRunMeta (MetaP r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) +defaultRunMeta (MetaT r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) +defaultRunMeta (MetaD r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) +defaultRunMeta (MetaAW r) + = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) + -- We turn off showing the code in meta-level exceptions because doing so exposes + -- the toAnnotationWrapper function that we slap around the user's code + +---------------- +runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper + -> TcM Serialized +runMetaAW = runMeta metaRequestAW + +runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) + -> TcM (LHsExpr GhcPs) +runMetaE = runMeta metaRequestE + +runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) + -> TcM (LPat GhcPs) +runMetaP = runMeta metaRequestP + +runMetaT :: LHsExpr GhcTc -- Of type (Q Type) + -> TcM (LHsType GhcPs) +runMetaT = runMeta metaRequestT + +runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] + -> TcM [LHsDecl GhcPs] +runMetaD = runMeta metaRequestD + +--------------- +runMeta' :: Bool -- Whether code should be printed in the exception message + -> (hs_syn -> SDoc) -- how to print the code + -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x + -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or + -- something like that + -> TcM hs_syn -- Of type t +runMeta' show_code ppr_hs run_and_convert expr + = do { traceTc "About to run" (ppr expr) + ; recordThSpliceUse -- seems to be the best place to do this, + -- we catch all kinds of splices and annotations. + + -- Check that we've had no errors of any sort so far. + -- For example, if we found an error in an earlier defn f, but + -- recovered giving it type f :: forall a.a, it'd be very dodgy + -- to carry ont. Mind you, the staging restrictions mean we won't + -- actually run f, but it still seems wrong. And, more concretely, + -- see #5358 for an example that fell over when trying to + -- reify a function with a "?" kind in it. (These don't occur + -- in type-correct programs. + ; failIfErrsM + + -- run plugins + ; hsc_env <- getTopEnv + ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr + + -- Desugar + ; ds_expr <- initDsTc (dsLExpr expr') + -- Compile and link it; might fail if linking fails + ; src_span <- getSrcSpanM + ; traceTc "About to run (desugared)" (ppr ds_expr) + ; either_hval <- tryM $ liftIO $ + GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr + ; case either_hval of { + Left exn -> fail_with_exn "compile and link" exn ; + Right hval -> do + + { -- Coerce it to Q t, and run it + + -- Running might fail if it throws an exception of any kind (hence tryAllM) + -- including, say, a pattern-match exception in the code we are running + -- + -- We also do the TH -> HS syntax conversion inside the same + -- exception-catching thing so that if there are any lurking + -- exceptions in the data structure returned by hval, we'll + -- encounter them inside the try + -- + -- See Note [Exceptions in TH] + let expr_span = getLoc expr + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { mb_result <- run_and_convert expr_span hval + ; case mb_result of + Left err -> failWithTc err + Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) + ; return $! result } } + + ; case either_tval of + Right v -> return v + Left se -> case fromException se of + Just IOEnvFailure -> failM -- Error already in Tc monad + _ -> fail_with_exn "run" se -- Exception + }}} + where + -- see Note [Concealed TH exceptions] + fail_with_exn :: Exception e => String -> e -> TcM a + fail_with_exn phase exn = do + exn_msg <- liftIO $ Panic.safeShowException exn + let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", + nest 2 (text exn_msg), + if show_code then text "Code:" <+> ppr expr else empty] + failWithTc msg + +{- +Note [Running typed splices in the zonker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +See #15471 for the full discussion. + +For many years typed splices were run immediately after they were type checked +however, this is too early as it means to zonk some type variables before +they can be unified with type variables in the surrounding context. + +For example, + +``` +module A where + +test_foo :: forall a . Q (TExp (a -> a)) +test_foo = [|| id ||] + +module B where + +import A + +qux = $$(test_foo) +``` + +We would expect `qux` to have inferred type `forall a . a -> a` but if +we run the splices too early the unified variables are zonked to `Any`. The +inferred type is the unusable `Any -> Any`. + +To run the splice, we must compile `test_foo` all the way to byte code. +But at the moment when the type checker is looking at the splice, test_foo +has type `Q (TExp (alpha -> alpha))` and we +certainly can't compile code involving unification variables! + +We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` +which definitely is not what we want. Moreover, if we had + qux = [$$(test_foo), (\x -> x +1::Int)] +then `alpha` would have to be `Int`. + +Conclusion: we must defer taking decisions about `alpha` until the +typechecker is done; and *then* we can run the splice. It's fine to do it +later, because we know it'll produce type-correct code. + +Deferring running the splice until later, in the zonker, means that the +unification variables propagate upwards from the splice into the surrounding +context and are unified correctly. + +This is implemented by storing the arguments we need for running the splice +in a `DelayedSplice`. In the zonker, the arguments are passed to +`GHC.Tc.Gen.Splice.runTopSplice` and the expression inserted into the AST as normal. + + + +Note [Exceptions in TH] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like this + $( f 4 ) +where + f :: Int -> Q [Dec] + f n | n>3 = fail "Too many declarations" + | otherwise = ... + +The 'fail' is a user-generated failure, and should be displayed as a +perfectly ordinary compiler error message, not a panic or anything +like that. Here's how it's processed: + + * 'fail' is the monad fail. The monad instance for Q in TH.Syntax + effectively transforms (fail s) to + qReport True s >> fail + where 'qReport' comes from the Quasi class and fail from its monad + superclass. + + * The TcM monad is an instance of Quasi (see GHC.Tc.Gen.Splice), and it implements + (qReport True s) by using addErr to add an error message to the bag of errors. + The 'fail' in TcM raises an IOEnvFailure exception + + * 'qReport' forces the message to ensure any exception hidden in unevaluated + thunk doesn't get into the bag of errors. Otherwise the following splice + will trigger panic (#8987): + $(fail undefined) + See also Note [Concealed TH exceptions] + + * So, when running a splice, we catch all exceptions; then for + - an IOEnvFailure exception, we assume the error is already + in the error-bag (above) + - other errors, we add an error to the bag + and then fail + +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + + +To call runQ in the Tc monad, we need to make TcM an instance of Quasi: +-} + +instance TH.Quasi TcM where + qNewName s = do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + qReport True msg = seqList msg $ addErr (text msg) + qReport False msg = seqList msg $ addWarn NoReason (text msg) + + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s _ -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + + qLookupName = lookupName + qReify = reify + qReifyFixity nm = lookupThName nm >>= reifyFixity + qReifyType = reifyTypeOfThing + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness nm = do { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + qRecover recover main = tryTcDiscardingErrs recover main + + qAddDependentFile fp = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + qAddTempFile suffix = do + dflags <- getDynFlags + liftIO $ newTempName dflags TFL_GhcSession suffix + + qAddTopDecls thds = do + l <- getSrcSpanM + th_origin <- getThSpliceOrigin + let either_hval = convertToHsDecls th_origin l thds + ds <- case either_hval of + Left exn -> failWithTc $ + hang (text "Error in a declaration passed to addTopDecls:") + 2 exn + Right ds -> return ds + mapM_ (checkTopDecl . unLoc) ds + th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + updTcRef th_topdecls_var (\topds -> ds ++ topds) + where + checkTopDecl :: HsDecl GhcPs -> TcM () + checkTopDecl (ValD _ binds) + = mapM_ bindName (collectHsBindBinders binds) + checkTopDecl (SigD _ _) + = return () + checkTopDecl (AnnD _ _) + = return () + checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) + = bindName name + checkTopDecl _ + = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" + + bindName :: RdrName -> TcM () + bindName (Exact n) + = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } + + bindName name = + addErr $ + hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) + 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + + qAddForeignFilePath lang fp = do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + qAddModFinalizer fin = do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + qAddCorePlugin plugin = do + hsc_env <- getTopEnv + r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin) + let err = hang + (text "addCorePlugin: invalid plugin module " + <+> text (show plugin) + ) + 2 + (text "Plugins in the current package can't be specified.") + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + qGetQ :: forall a. Typeable a => TcM (Maybe a) + qGetQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + + qPutQ x = do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + qIsExtEnabled = xoptM + + qExtsEnabled = + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + +-- | Adds a mod finalizer reference to the local environment. +addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () +addModFinalizerRef finRef = do + th_stage <- getStage + case th_stage of + RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) + -- This case happens only if a splice is executed and the caller does + -- not set the 'ThStage' to 'RunSplice' to collect finalizers. + -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + _ -> + pprPanic "addModFinalizer was called when no finalizers were collected" + (ppr th_stage) + +-- | Releases the external interpreter state. +finishTH :: TcM () +finishTH = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp {}) -> do + tcg <- getGblEnv + writeTcRef (tcg_th_remote_state tcg) Nothing + + +runTHExp :: ForeignHValue -> TcM TH.Exp +runTHExp = runTH THExp + +runTHPat :: ForeignHValue -> TcM TH.Pat +runTHPat = runTH THPat + +runTHType :: ForeignHValue -> TcM TH.Type +runTHType = runTH THType + +runTHDec :: ForeignHValue -> TcM [TH.Dec] +runTHDec = runTH THDec + +runTH :: Binary a => THResultType -> ForeignHValue -> TcM a +runTH ty fhv = do + interp <- tcGetInterp + case interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + -- Run it in the local TcM + hv <- liftIO $ wormhole InternalInterp fhv + r <- runQuasi (unsafeCoerce hv :: TH.Q a) + return r +#endif + + ExternalInterp conf iserv -> + -- Run it on the server. For an overview of how TH works with + -- Remote GHCi, see Note [Remote Template Haskell] in + -- libraries/ghci/GHCi/TH.hs. + withIServ_ conf iserv $ \i -> do + rstate <- getTHState i + loc <- TH.qLocation + liftIO $ + withForeignRef rstate $ \state_hv -> + withForeignRef fhv $ \q_hv -> + writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) + runRemoteTH i [] + bs <- readQResult i + return $! runGet get (LB.fromStrict bs) + + +-- | communicate with a remotely-running TH computation until it finishes. +-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. +runRemoteTH + :: IServInstance + -> [Messages] -- saved from nested calls to qRecover + -> TcM () +runRemoteTH iserv recovers = do + THMsg msg <- liftIO $ readIServ iserv getTHMessage + case msg of + RunTHDone -> return () + StartRecover -> do -- Note [TH recover with -fexternal-interpreter] + v <- getErrsVar + msgs <- readTcRef v + writeTcRef v emptyMessages + runRemoteTH iserv (msgs : recovers) + EndRecover caught_error -> do + let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of + [] -> panic "EndRecover" + a : b -> (a,b) + v <- getErrsVar + (warn_msgs,_) <- readTcRef v + -- keep the warnings only if there were no errors + writeTcRef v $ if caught_error + then prev_msgs + else (prev_warns `unionBags` warn_msgs, prev_errs) + runRemoteTH iserv rest + _other -> do + r <- handleTHMessage msg + liftIO $ writeIServ iserv (put r) + runRemoteTH iserv recovers + +-- | Read a value of type QResult from the iserv +readQResult :: Binary a => IServInstance -> TcM a +readQResult i = do + qr <- liftIO $ readIServ i get + case qr of + QDone a -> return a + QException str -> liftIO $ throwIO (ErrorCall str) + QFail str -> fail str + +{- Note [TH recover with -fexternal-interpreter] + +Recover is slightly tricky to implement. + +The meaning of "recover a b" is + - Do a + - If it finished with no errors, then keep the warnings it generated + - If it failed, discard any messages it generated, and do b + +Note that "failed" here can mean either + (1) threw an exception (failTc) + (2) generated an error message (addErrTcM) + +The messages are managed by GHC in the TcM monad, whereas the +exception-handling is done in the ghc-iserv process, so we have to +coordinate between the two. + +On the server: + - emit a StartRecover message + - run "a; FailIfErrs" inside a try + - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed + - if "a; FailIfErrs" failed, run "b" + +Back in GHC, when we receive: + + FailIfErrrs + failTc if there are any error messages (= failIfErrsM) + StartRecover + save the current messages and start with an empty set. + EndRecover caught_error + Restore the previous messages, + and merge in the new messages if caught_error is false. +-} + +-- | Retrieve (or create, if it hasn't been created already), the +-- remote TH state. The TH state is a remote reference to an IORef +-- QState living on the server, and we have to pass this to each RunTH +-- call we make. +-- +-- The TH state is stored in tcg_th_remote_state in the TcGblEnv. +-- +getTHState :: IServInstance -> TcM (ForeignRef (IORef QState)) +getTHState i = do + tcg <- getGblEnv + th_state <- readTcRef (tcg_th_remote_state tcg) + case th_state of + Just rhv -> return rhv + Nothing -> do + hsc_env <- getTopEnv + fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH + writeTcRef (tcg_th_remote_state tcg) (Just fhv) + return fhv + +wrapTHResult :: TcM a -> TcM (THResult a) +wrapTHResult tcm = do + e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic + case e of + Left e -> return (THException (show e)) + Right a -> return (THComplete a) + +handleTHMessage :: THMessage a -> TcM a +handleTHMessage msg = case msg of + NewName a -> wrapTHResult $ TH.qNewName a + Report b str -> wrapTHResult $ TH.qReport b str + LookupName b str -> wrapTHResult $ TH.qLookupName b str + Reify n -> wrapTHResult $ TH.qReify n + ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n + ReifyType n -> wrapTHResult $ TH.qReifyType n + ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts + ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + ReifyAnnotations lookup tyrep -> + wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) + ReifyModule m -> wrapTHResult $ TH.qReifyModule m + ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm + AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + AddModFinalizer r -> do + hsc_env <- getTopEnv + wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef + AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str + AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext + ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled + FailIfErrs -> wrapTHResult failIfErrsM + _ -> panic ("handleTHMessage: unexpected message " ++ show msg) + +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] +getAnnotationsByTypeRep th_name tyrep + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep + ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +{- +************************************************************************ +* * + Instance Testing +* * +************************************************************************ +-} + +reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] +reifyInstances th_nm th_tys + = addErrCtxt (text "In the argument of reifyInstances:" + <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ + do { loc <- getSrcSpanM + ; th_origin <- getThSpliceOrigin + ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) + -- #9262 says to bring vars into scope, like in HsForAllTy case + -- of rnHsTyKi + ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty + -- Rename to HsType Name + ; ((tv_names, rn_ty), _fvs) + <- checkNoErrs $ -- If there are out-of-scope Names here, then we + -- must error before proceeding to typecheck the + -- renamed type, as that will result in GHC + -- internal errors (#13837). + rnImplicitBndrs Nothing tv_rdrs $ \ tv_names -> + do { (rn_ty, fvs) <- rnLHsType doc rdr_ty + ; return ((tv_names, rn_ty), fvs) } + ; (_tvs, ty) + <- pushTcLevelM_ $ + solveEqualities $ -- Avoid error cascade if there are unsolved + bindImplicitTKBndrs_Skol tv_names $ + tcInferLHsType rn_ty + ; ty <- zonkTcTypeToType ty + -- Substitute out the meta type variables + -- In particular, the type might have kind + -- variables inside it (#7477) + + ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty)) + ; case splitTyConApp_maybe ty of -- This expands any type synonyms + Just (tc, tys) -- See #7910 + | Just cls <- tyConClass_maybe tc + -> do { inst_envs <- tcGetInstEnvs + ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys + ; traceTc "reifyInstances1" (ppr matches) + ; reifyClassInstances cls (map fst matches ++ unifies) } + | isOpenFamilyTyCon tc + -> do { inst_envs <- tcGetFamInstEnvs + ; let matches = lookupFamInstEnv inst_envs tc tys + ; traceTc "reifyInstances2" (ppr matches) + ; reifyFamilyInstances tc (map fim_instance matches) } + _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application")) } + where + doc = ClassInstanceCtx + bale_out msg = failWithTc msg + + cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) + cvt origin loc th_ty = case convertToHsType origin loc th_ty of + Left msg -> failWithTc msg + Right ty -> return ty + +{- +************************************************************************ +* * + Reification +* * +************************************************************************ +-} + +lookupName :: Bool -- True <=> type namespace + -- False <=> value namespace + -> String -> TcM (Maybe TH.Name) +lookupName is_type_name s + = do { lcl_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv lcl_env rdr_name of + Just n -> return (Just (reifyName n)) + Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name + ; return (fmap reifyName mb_nm) } } + where + th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' + + occ_fs :: FastString + occ_fs = mkFastString (TH.nameBase th_name) + + occ :: OccName + occ | is_type_name + = if isLexVarSym occ_fs || isLexCon occ_fs + then mkTcOccFS occ_fs + else mkTyVarOccFS occ_fs + | otherwise + = if isLexCon occ_fs then mkDataOccFS occ_fs + else mkVarOccFS occ_fs + + rdr_name = case TH.nameModule th_name of + Nothing -> mkRdrUnqual occ + Just mod -> mkRdrQual (mkModuleName mod) occ + +getThing :: TH.Name -> TcM TcTyThing +getThing th_name + = do { name <- lookupThName th_name + ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) + ; tcLookupTh name } + -- ToDo: this tcLookup could fail, which would give a + -- rather unhelpful error message + where + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns _ = panic "reify/ppr_ns" + +reify :: TH.Name -> TcM TH.Info +reify th_name + = do { traceTc "reify 1" (text (TH.showName th_name)) + ; thing <- getThing th_name + ; traceTc "reify 2" (ppr thing) + ; reifyThing thing } + +lookupThName :: TH.Name -> TcM Name +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +lookupThName_maybe th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A + ; return (listToMaybe names) } + where + lookup rdr_name + = do { -- Repeat much of lookupOccRn, because we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return (Just name) + Nothing -> lookupGlobalOccRn_maybe rdr_name } + +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (tcl_env lcl_env) name of { + Just thing -> return thing; + Nothing -> + + case lookupNameEnv (tcg_type_env gbl_env) name of { + Just thing -> return (AGlobal thing); + Nothing -> + + -- EZY: I don't think this choice matters, no TH in signatures! + if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name + then -- It's defined in this module + failWithTc (notInEnv name) + + else + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return (AGlobal thing) + Failed msg -> failWithTc msg + }}}} + +notInScope :: TH.Name -> SDoc +notInScope th_name = quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" + -- Ugh! Rather an indirect way to display the name + +notInEnv :: Name -> SDoc +notInEnv name = quotes (ppr name) <+> + text "is not in the type environment at a reify" + +------------------------------ +reifyRoles :: TH.Name -> TcM [TH.Role] +reifyRoles th_name + = do { thing <- getThing th_name + ; case thing of + AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) + _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) + } + where + reify_role Nominal = TH.NominalR + reify_role Representational = TH.RepresentationalR + reify_role Phantom = TH.PhantomR + +------------------------------ +reifyThing :: TcTyThing -> TcM TH.Info +-- The only reason this is monadic is for error reporting, +-- which in turn is mainly for the case when TH can't express +-- some random GHC extension + +reifyThing (AGlobal (AnId id)) + = do { ty <- reifyType (idType id) + ; let v = reifyName id + ; case idDetails id of + ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls)) + RecSelId{sel_tycon=RecSelData tc} + -> return (TH.VarI (reifySelector id tc) ty Nothing) + _ -> return (TH.VarI v ty Nothing) + } + +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (AConLike (RealDataCon dc))) + = do { let name = dataConName dc + ; ty <- reifyType (idType (dataConWrapId dc)) + ; return (TH.DataConI (reifyName name) ty + (reifyName (dataConOrigTyCon dc))) + } + +reifyThing (AGlobal (AConLike (PatSynCon ps))) + = do { let name = reifyName ps + ; ty <- reifyPatSynType (patSynSigBndr ps) + ; return (TH.PatSynI name ty) } + +reifyThing (ATcId {tct_id = id}) + = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even + -- though it may be incomplete + ; ty2 <- reifyType ty1 + ; return (TH.VarI (reifyName id) ty2 Nothing) } + +reifyThing (ATyVar tv tv1) + = do { ty1 <- zonkTcTyVar tv1 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } + +reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) + +------------------------------------------- +reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn +reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- remove kind patterns (#8884) + = do { tvs' <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; lhs' <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) + lhs_types_only lhs' + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs + ; rhs' <- reifyType rhs + ; return (TH.TySynEqn tvs' lhs_type rhs') } + +reifyTyCon :: TyCon -> TcM TH.Info +reifyTyCon tc + | Just cls <- tyConClass_maybe tc + = reifyClass cls + + | isFunTyCon tc + = return (TH.PrimTyConI (reifyName tc) 2 False) + + | isPrimTyCon tc + = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) + (isUnliftedTyCon tc)) + + | isTypeFamilyTyCon tc + = do { let tvs = tyConTyVars tc + res_kind = tyConResKind tc + resVar = famTcResVar tc + + ; kind' <- reifyKind res_kind + ; let (resultSig, injectivity) = + case resVar of + Nothing -> (TH.KindSig kind', Nothing) + Just name -> + let thName = reifyName name + injAnnot = tyConInjectivityInfo tc + sig = TH.TyVarSig (TH.KindedTV thName () kind') + inj = case injAnnot of + NotInjective -> Nothing + Injective ms -> + Just (TH.InjectivityAnn thName injRHS) + where + injRHS = map (reifyName . tyVarName) + (filterByList ms tvs) + in (sig, inj) + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; let tfHead = + TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity + ; if isOpenTypeFamilyTyCon tc + then do { fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc + (familyInstances fam_envs tc) + ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } + else do { eqns <- + case isClosedSynFamilyTyConWithAxiom_maybe tc of + Just ax -> mapM (reifyAxBranch tc) $ + fromBranches $ coAxiomBranches ax + Nothing -> return [] + ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) + []) } } + + | isDataFamilyTyCon tc + = do { let res_kind = tyConResKind tc + + ; kind' <- fmap Just (reifyKind res_kind) + + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } + + | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; return (TH.TyConI + (TH.TySynD (reifyName tc) tvs' rhs')) + } + + | otherwise + = do { cxt <- reifyCxt (tyConStupidTheta tc) + ; let tvs = tyConTyVars tc + dataCons = tyConDataCons tc + isGadt = isGadtSyntaxTyCon tc + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons + ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) + ; let name = reifyName tc + deriv = [] -- Don't know about deriving + decl | isNewTyCon tc = + TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv + | otherwise = + TH.DataD cxt name r_tvs Nothing cons deriv + ; return (TH.TyConI decl) } + +reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con +reifyDataCon isGadtDataCon tys dc + = do { let -- used for H98 data constructors + (ex_tvs, theta, arg_tys) + = dataConInstSig dc tys + -- used for GADTs data constructors + g_user_tvs' = dataConUserTyVarBinders dc + (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') + = dataConFullSig dc + (srcUnpks, srcStricts) + = mapAndUnzip reifySourceBang (dataConSrcBangs dc) + dcdBangs = zipWith TH.Bang srcUnpks srcStricts + fields = dataConFieldLabels dc + name = reifyName dc + -- Universal tvs present in eq_spec need to be filtered out, as + -- they will not appear anywhere in the type. + eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) + + ; (univ_subst, _) + -- See Note [Freshen reified GADT constructors' universal tyvars] + <- freshenTyVarBndrs $ + filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs + ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' + g_theta = substTys tvb_subst g_theta' + g_arg_tys = substTys tvb_subst (map scaledThing g_arg_tys') + g_res_ty = substTy tvb_subst g_res_ty' + + ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) + + ; main_con <- + if | not (null fields) && not isGadtDataCon -> + return $ TH.RecC name (zip3 (map reifyFieldLabel fields) + dcdBangs r_arg_tys) + | not (null fields) -> do + { res_ty <- reifyType g_res_ty + ; return $ TH.RecGadtC [name] + (zip3 (map (reifyName . flSelector) fields) + dcdBangs r_arg_tys) res_ty } + -- We need to check not isGadtDataCon here because GADT + -- constructors can be declared infix. + -- See Note [Infix GADT constructors] in GHC.Tc.TyCl. + | dataConIsInfix dc && not isGadtDataCon -> + ASSERT( r_arg_tys `lengthIs` 2 ) do + { let [r_a1, r_a2] = r_arg_tys + [s1, s2] = dcdBangs + ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } + | isGadtDataCon -> do + { res_ty <- reifyType g_res_ty + ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty } + | otherwise -> + return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) + + ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) + | otherwise = ASSERT( all isTyVar ex_tvs ) + -- no covars for haskell syntax + (map mk_specified ex_tvs, theta) + ret_con | null ex_tvs' && null theta' = return main_con + | otherwise = do + { cxt <- reifyCxt theta' + ; ex_tvs'' <- reifyTyVarBndrs ex_tvs' + ; return (TH.ForallC ex_tvs'' cxt main_con) } + ; ASSERT( r_arg_tys `equalLength` dcdBangs ) + ret_con } + where + mk_specified tv = Bndr tv SpecifiedSpec + + subst_tv_binders subst tv_bndrs = + let tvs = binderVars tv_bndrs + flags = map binderArgFlag tv_bndrs + (subst', tvs') = substTyVarBndrs subst tvs + tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags) + in (subst', tv_bndrs') + +{- +Note [Freshen reified GADT constructors' universal tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose one were to reify this GADT: + + data a :~: b where + Refl :: forall a b. (a ~ b) => a :~: b + +We ought to be careful here about the uniques we give to the occurrences of `a` +and `b` in this definition. That is because in the original DataCon, all uses +of `a` and `b` have the same unique, since `a` and `b` are both universally +quantified type variables--that is, they are used in both the (:~:) tycon as +well as in the constructor type signature. But when we turn the DataCon +definition into the reified one, the `a` and `b` in the constructor type +signature becomes differently scoped than the `a` and `b` in `data a :~: b`. + +While it wouldn't technically be *wrong* per se to re-use the same uniques for +`a` and `b` across these two different scopes, it's somewhat annoying for end +users of Template Haskell, since they wouldn't be able to rely on the +assumption that all TH names have globally distinct uniques (#13885). For this +reason, we freshen the universally quantified tyvars that go into the reified +GADT constructor type signature to give them distinct uniques from their +counterparts in the tycon. +-} + +------------------------------ +reifyClass :: Class -> TcM TH.Info +reifyClass cls + = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) + ; assocTys <- concatMapM reifyAT ats + ; ops <- concatMapM reify_op op_stuff + ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) + ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) + ; return (TH.ClassI dec insts) } + where + (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls + fds' = map reifyFunDep fds + reify_op (op, def_meth) + = do { let (_, _, ty) = tcSplitMethodTy (idType op) + -- Use tcSplitMethodTy to get rid of the extraneous class + -- variables and predicates at the beginning of op's type + -- (see #15551). + ; ty' <- reifyType ty + ; let nm' = reifyName op + ; case def_meth of + Just (_, GenericDM gdm_ty) -> + do { gdm_ty' <- reifyType gdm_ty + ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } + _ -> return [TH.SigD nm' ty'] } + + reifyAT :: ClassATItem -> TcM [TH.Dec] + reifyAT (ATI tycon def) = do + tycon' <- reifyTyCon tycon + case tycon' of + TH.FamilyI dec _ -> do + let (tyName, tyArgs) = tfNames dec + (dec :) <$> maybe (return []) + (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) + def + _ -> pprPanic "reifyAT" (text (show tycon')) + + reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec + reifyDefImpl n args ty = + TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) + <$> reifyType ty + + tfNames :: TH.Dec -> (TH.Name, [TH.Name]) + tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) + = (n, map bndrName args) + tfNames d = pprPanic "tfNames" (text (show d)) + + bndrName :: TH.TyVarBndr flag -> TH.Name + bndrName (TH.PlainTV n _) = n + bndrName (TH.KindedTV n _ _) = n + +------------------------------ +-- | Annotate (with TH.SigT) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to annotate type patterns for poly-kinded tyvars in +-- reifying class and type instances. +-- See @Note [Reified instances and explicit kind signatures]@. +annotThType :: Bool -- True <=> annotate + -> TyCoRep.Type -> TH.Type -> TcM TH.Type + -- tiny optimization: if the type is annotated, don't annotate again. +annotThType _ _ th_ty@(TH.SigT {}) = return th_ty +annotThType True ty th_ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty + = do { let ki = tcTypeKind ty + ; th_ki <- reifyKind ki + ; return (TH.SigT th_ty th_ki) } +annotThType _ _ th_ty = return th_ty + +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +-- See @Note [Reified instances and explicit kind signatures]@. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + -- See "Wrinkle: Oversaturated data family instances" in + -- @Note [Reified instances and explicit kind signatures]@ + ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle + ++ repeat True -- (2) in Wrinkle + where + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [TyCoBinder] + tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc + +{- +Note [Reified instances and explicit kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Reified class instances and type family instances often include extra kind +information to disambiguate instances. Here is one such example that +illustrates this (#8953): + + type family Poly (a :: k) :: Type + type instance Poly (x :: Bool) = Int + type instance Poly (x :: Maybe k) = Double + +If you're not careful, reifying these instances might yield this: + + type instance Poly x = Int + type instance Poly x = Double + +To avoid this, we go through some care to annotate things with extra kind +information. Some functions which accomplish this feat include: + +* annotThType: This annotates a type with a kind signature if the type contains + a free variable. +* tyConArgsPolyKinded: This checks every argument that a type constructor can + accept and reports if the type of the argument is poly-kinded. This + information is ultimately fed into annotThType. + +----- +-- Wrinkle: Oversaturated data family instances +----- + +What constitutes an argument to a type constructor in the definition of +tyConArgsPolyKinded? For most type constructors, it's simply the visible +type variable binders (i.e., tyConVisibleTyVars). There is one corner case +we must keep in mind, however: data family instances can appear oversaturated +(#17296). For instance: + + data family Foo :: Type -> Type + data instance Foo x + + data family Bar :: k + data family Bar x + +For these sorts of data family instances, tyConVisibleTyVars isn't enough, +as they won't give you the kinds of the oversaturated arguments. We must +also consult: + +1. The kinds of the arguments in the result kind (i.e., the tyConResKind). + This will tell us, e.g., the kind of `x` in `Foo x` above. +2. If we go beyond the number of arguments in the result kind (like the + `x` in `Bar x`), then we conservatively assume that the argument's + kind is poly-kinded. + +----- +-- Wrinkle: data family instances with return kinds +----- + +Another squirrelly corner case is this: + + data family Foo (a :: k) + data instance Foo :: Bool -> Type + data instance Foo :: Char -> Type + +If you're not careful, reifying these instances might yield this: + + data instance Foo + data instance Foo + +We can fix this ambiguity by reifying the instances' explicit return kinds. We +should only do this if necessary (see +Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), +but more importantly, we *only* do this if either of the following are true: + +1. The data family instance has no constructors. +2. The data family instance is declared with GADT syntax. + +If neither of these are true, then reifying the return kind would yield +something like this: + + data instance (Bar a :: Type) = MkBar a + +Which is not valid syntax. +-} + +------------------------------ +reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] +reifyClassInstances cls insts + = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts + +reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> ClsInst -> TcM TH.Dec +reifyClassInstance is_poly_tvs i + = do { cxt <- reifyCxt theta + ; let vis_types = filterOutInvisibleTypes cls_tc types + ; thtypes <- reifyTypes vis_types + ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes + ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes + ; return $ (TH.InstanceD over cxt head_ty []) } + where + (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) + cls_tc = classTyCon cls + dfun = instanceDFunId i + over = case overlapMode (is_flag i) of + NoOverlap _ -> Nothing + Overlappable _ -> Just TH.Overlappable + Overlapping _ -> Just TH.Overlapping + Overlaps _ -> Just TH.Overlaps + Incoherent _ -> Just TH.Incoherent + +------------------------------ +reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] +reifyFamilyInstances fam_tc fam_insts + = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts + +reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> FamInst -> TcM TH.Dec +reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor + , fi_axiom = ax + , fi_fam = fam }) + | let fam_tc = coAxiomTyCon ax + branch = coAxiomSingleBranch ax + , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch + = case flavor of + SynFamilyInst -> + -- remove kind patterns (#8884) + do { th_tvs <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; th_lhs <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only + th_lhs + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs + ; th_rhs <- reifyType rhs + ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } + + DataFamilyInst rep_tc -> + do { let -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See #9692 + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch + fam' = reifyName fam + dataCons = tyConDataCons rep_tc + isGadt = isGadtSyntaxTyCon rep_tc + ; th_tvs <- reifyTyVarsToMaybe ee_tvs + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons + ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs + ; th_tys <- reifyTypes types_only + ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys + ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys + ; mb_sig <- + -- See "Wrinkle: data family instances with return kinds" in + -- Note [Reified instances and explicit kind signatures] + if (null cons || isGadtSyntaxTyCon rep_tc) + && tyConAppNeedsKindSig False fam_tc (length ee_lhs) + then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs) + ; th_full_kind <- reifyKind full_kind + ; pure $ Just th_full_kind } + else pure Nothing + ; return $ + if isNewTyCon rep_tc + then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] + else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] + } + +------------------------------ +reifyType :: TyCoRep.Type -> TcM TH.Type +-- Monadic only because of failure +reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT + -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it + -- with Constraint (#14869). +reifyType ty@(ForAllTy (Bndr _ argf) _) + = reify_for_all argf ty +reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } +reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) +reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here +reifyType ty@(AppTy {}) = do + let (ty_head, ty_args) = splitAppTys ty + ty_head' <- reifyType ty_head + ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) + pure $ mkThAppTs ty_head' ty_args' + where + -- Make sure to filter out any invisible arguments. For instance, if you + -- reify the following: + -- + -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) + -- + -- Then you should receive back `f Bool`, not `f Type Bool`, since the + -- `Type` argument is invisible (#15792). + filter_out_invisible_args :: Type -> [Type] -> [Type] + filter_out_invisible_args ty_head ty_args = + filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) + ty_args +reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 }) + | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) + | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] + ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) + | InvisArg <- af = noTH (sLit "linear invisible argument") (ppr ty) + | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] + ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } +reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH +reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) + +reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type +-- Arg of reify_for_all is always ForAllTy or a predicate FunTy +reify_for_all argf ty + | isVisibleArgFlag argf + = do let (req_bndrs, phi) = tcSplitForAllTysReq ty + tvbndrs' <- reifyTyVarBndrs req_bndrs + phi' <- reifyType phi + pure $ TH.ForallVisT tvbndrs' phi' + | otherwise + = do let (inv_bndrs, phi) = tcSplitForAllTysInvis ty + tvbndrs' <- reifyTyVarBndrs inv_bndrs + let (cxt, tau) = tcSplitPhiTy phi + cxt' <- reifyCxt cxt + tau' <- reifyType tau + pure $ TH.ForallT tvbndrs' cxt' tau' + +reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit +reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) +reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) + +reifyTypes :: [Type] -> TcM [TH.Type] +reifyTypes = mapM reifyType + +reifyPatSynType + :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) -> TcM TH.Type +-- reifies a pattern synonym's type and returns its *complete* type +-- signature; see NOTE [Pattern synonym signatures and Template +-- Haskell] +reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) + = do { univTyVars' <- reifyTyVarBndrs univTyVars + ; req' <- reifyCxt req + ; exTyVars' <- reifyTyVarBndrs exTyVars + ; prov' <- reifyCxt prov + ; tau' <- reifyType (mkVisFunTys argTys resTy) + ; return $ TH.ForallT univTyVars' req' + $ TH.ForallT exTyVars' prov' tau' } + +reifyKind :: Kind -> TcM TH.Kind +reifyKind = reifyType + +reifyCxt :: [PredType] -> TcM [TH.Pred] +reifyCxt = mapM reifyType + +reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep +reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) + +class ReifyFlag flag flag' | flag -> flag' where + reifyFlag :: flag -> flag' + +instance ReifyFlag () () where + reifyFlag () = () + +instance ReifyFlag Specificity TH.Specificity where + reifyFlag SpecifiedSpec = TH.SpecifiedSpec + reifyFlag InferredSpec = TH.InferredSpec + +reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] +reifyTyVars = reifyTyVarBndrs . map mk_bndr + where + mk_bndr tv = Bndr tv () + +reifyTyVarBndrs :: ReifyFlag flag flag' + => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag'] +reifyTyVarBndrs = mapM reify_tvbndr + where + -- even if the kind is *, we need to include a kind annotation, + -- in case a poly-kind would be inferred without the annotation. + -- See #8953 or test th/T8953 + reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv) + (reifyFlag fl) + <$> reifyKind (tyVarKind tv) + +reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()]) +reifyTyVarsToMaybe [] = pure Nothing +reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys + +reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type +reify_tc_app tc tys + = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) + ; maybe_sig_t (mkThAppTs r_tc tys') } + where + arity = tyConArity tc + + r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) + | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) + | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + | isTupleTyCon tc = if isPromotedDataCon tc + then TH.PromotedTupleT arity + else TH.TupleT arity + | tc `hasKey` constraintKindTyConKey + = TH.ConstraintT + | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT + | tc `hasKey` listTyConKey = TH.ListT + | tc `hasKey` nilDataConKey = TH.PromotedNilT + | tc `hasKey` consDataConKey = TH.PromotedConsT + | tc `hasKey` heqTyConKey = TH.EqualityT + | tc `hasKey` eqPrimTyConKey = TH.EqualityT + | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) + | isPromotedDataCon tc = TH.PromotedT (reifyName tc) + | otherwise = TH.ConT (reifyName tc) + + -- See Note [When does a tycon application need an explicit kind + -- signature?] in GHC.Core.TyCo.Rep + maybe_sig_t th_type + | tyConAppNeedsKindSig + False -- We don't reify types using visible kind applications, so + -- don't count specified binders as contributing towards + -- injective positions in the kind of the tycon. + tc (length tys) + = do { let full_kind = tcTypeKind (mkTyConApp tc tys) + ; th_full_kind <- reifyKind full_kind + ; return (TH.SigT th_type th_full_kind) } + | otherwise + = return th_type + +------------------------------ +reifyName :: NamedThing n => n -> TH.Name +reifyName thing + | isExternalName name + = mk_varg pkg_str mod_str occ_str + | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) + -- Many of the things we reify have local bindings, and + -- NameL's aren't supposed to appear in binding positions, so + -- we use NameU. When/if we start to reify nested things, that + -- have free variables, we may need to generate NameL's for them. + where + name = getName thing + mod = ASSERT( isExternalName name ) nameModule name + pkg_str = unitString (moduleUnit mod) + mod_str = moduleNameString (moduleName mod) + occ_str = occNameString occ + occ = nameOccName name + mk_varg | OccName.isDataOcc occ = TH.mkNameG_d + | OccName.isVarOcc occ = TH.mkNameG_v + | OccName.isTcOcc occ = TH.mkNameG_tc + | otherwise = pprPanic "reifyName" (ppr name) + +-- See Note [Reifying field labels] +reifyFieldLabel :: FieldLabel -> TH.Name +reifyFieldLabel fl + | flIsOverloaded fl + = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str)) + | otherwise = TH.mkNameG_v pkg_str mod_str occ_str + where + name = flSelector fl + mod = ASSERT( isExternalName name ) nameModule name + pkg_str = unitString (moduleUnit mod) + mod_str = moduleNameString (moduleName mod) + occ_str = unpackFS (flLabel fl) + +reifySelector :: Id -> TyCon -> TH.Name +reifySelector id tc + = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of + Just fl -> reifyFieldLabel fl + Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc) + +------------------------------ +reifyFixity :: Name -> TcM (Maybe TH.Fixity) +reifyFixity name + = do { (found, fix) <- lookupFixityRn_help name + ; return (if found then Just (conv_fix fix) else Nothing) } + where + conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) + conv_dir BasicTypes.InfixR = TH.InfixR + conv_dir BasicTypes.InfixL = TH.InfixL + conv_dir BasicTypes.InfixN = TH.InfixN + +reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness +reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness +reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack +reifyUnpackedness SrcUnpack = TH.SourceUnpack + +reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness +reifyStrictness NoSrcStrict = TH.NoSourceStrictness +reifyStrictness SrcStrict = TH.SourceStrict +reifyStrictness SrcLazy = TH.SourceLazy + +reifySourceBang :: DataCon.HsSrcBang + -> (TH.SourceUnpackedness, TH.SourceStrictness) +reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) + +reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness +reifyDecidedStrictness HsLazy = TH.DecidedLazy +reifyDecidedStrictness HsStrict = TH.DecidedStrict +reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack + +reifyTypeOfThing :: TH.Name -> TcM TH.Type +reifyTypeOfThing th_name = do + thing <- getThing th_name + case thing of + AGlobal (AnId id) -> reifyType (idType id) + AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) + AGlobal (AConLike (RealDataCon dc)) -> + reifyType (idType (dataConWrapId dc)) + AGlobal (AConLike (PatSynCon ps)) -> + reifyPatSynType (patSynSigBndr ps) + ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType + ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType + -- Impossible cases, supposedly: + AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" + ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" + APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" + +------------------------------ +lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget +lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) +lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) + = return $ ModuleTarget $ + mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + +reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] +reifyAnnotations th_name + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name + ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +------------------------------ +modToTHMod :: Module -> TH.Module +modToTHMod m = TH.Module (TH.PkgName $ unitString $ moduleUnit m) + (TH.ModName $ moduleNameString $ moduleName m) + +reifyModule :: TH.Module -> TcM TH.ModuleInfo +reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do + this_mod <- getModule + let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString) + if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod + where + reifyThisModule = do + usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports + return $ TH.ModuleInfo usages + + reifyFromIface reifMod = do + iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod + let usages = [modToTHMod m | usage <- mi_usages iface, + Just m <- [usageToModule (moduleUnit reifMod) usage] ] + return $ TH.ModuleInfo usages + + usageToModule :: Unit -> Usage -> Maybe Module + usageToModule _ (UsageFile {}) = Nothing + usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn + usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m + usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m + +------------------------------ +mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type +mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys + +noTH :: PtrString -> SDoc -> TcM a +noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> + text "in Template Haskell:", + nest 2 d]) + +ppr_th :: TH.Ppr a => a -> SDoc +ppr_th x = text (TH.pprint x) + +{- +Note [Reifying field labels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reifying a datatype declared with DuplicateRecordFields enabled, we want +the reified names of the fields to be labels rather than selector functions. +That is, we want (reify ''T) and (reify 'foo) to produce + + data T = MkT { foo :: Int } + foo :: T -> Int + +rather than + + data T = MkT { $sel:foo:MkT :: Int } + $sel:foo:MkT :: T -> Int + +because otherwise TH code that uses the field names as strings will silently do +the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather +than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the +environment, NameG can't be used to represent such fields. Instead, +reifyFieldLabel uses NameQ. + +However, this means that extracting the field name from the output of reify, and +trying to reify it again, may fail with an ambiguity error if there are multiple +such fields defined in the module (see the test case +overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to +the TH AST to make it able to represent duplicate record fields. +-} + +tcGetInterp :: TcM Interp +tcGetInterp = do + hsc_env <- getTopEnv + case hsc_interp hsc_env of + Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter") + Just i -> pure i diff --git a/GHC/Tc/Gen/Splice.hs-boot b/GHC/Tc/Gen/Splice.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Splice.hs-boot @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Splice where + +import GHC.Prelude +import GHC.Types.Name +import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) +import GHC.Tc.Types( TcM , SpliceType ) +import GHC.Tc.Utils.TcType ( ExpRhoType ) +import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) +import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) + +import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, + LHsDecl, ThModFinalizers ) +import qualified Language.Haskell.TH as TH + +tcSpliceExpr :: HsSplice GhcRn + -> ExpRhoType + -> TcM (HsExpr GhcTc) + +tcUntypedBracket :: HsExpr GhcRn + -> HsBracket GhcRn + -> [PendingRnSplice] + -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcTypedBracket :: HsExpr GhcRn + -> HsBracket GhcRn + -> ExpRhoType + -> TcM (HsExpr GhcTc) + +runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) + +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation + +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) + +runMetaE :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs) +runMetaP :: LHsExpr GhcTc -> TcM (LPat GhcPs) +runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs) +runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +runQuasi :: TH.Q a -> TcM a +runRemoteModFinalizers :: ThModFinalizers -> TcM () +finishTH :: TcM () diff --git a/GHC/Tc/Instance/Class.hs b/GHC/Tc/Instance/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/Class.hs @@ -0,0 +1,712 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Instance.Class ( + matchGlobalInst, + ClsInstResult(..), + InstanceWhat(..), safeOverlap, instanceReturnsDictCon, + AssocInstInfo(..), isNotAssociated + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate( tcInstType ) +import GHC.Tc.Instance.Typeable +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Core.Predicate +import GHC.Rename.Env( addUsedGRE ) +import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) +import GHC.Core.InstEnv +import GHC.Tc.Utils.Instantiate( instDFunType ) +import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) +import GHC.Builtin.Names + +import GHC.Types.Id +import GHC.Core.Type +import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) + +import GHC.Types.Name ( Name, pprDefinedAt ) +import GHC.Types.Var.Env ( VarEnv ) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Utils.Misc( splitAtList, fstOf3 ) +import Data.Maybe + +{- ******************************************************************* +* * + A helper for associated types within + class instance declarations +* * +**********************************************************************-} + +-- | Extra information about the parent instance declaration, needed +-- when type-checking associated types. The 'Class' is the enclosing +-- class, the [TyVar] are the /scoped/ type variable of the instance decl. +-- The @VarEnv Type@ maps class variables to their instance types. +data AssocInstInfo + = NotAssociated + | InClsInst { ai_class :: Class + , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance + -- Why scoped? See bind_me in + -- 'GHC.Tc.Validity.checkConsistentFamInst' + , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types + -- See Note [Matching in the consistent-instantiation check] + } + +isNotAssociated :: AssocInstInfo -> Bool +isNotAssociated (NotAssociated {}) = True +isNotAssociated (InClsInst {}) = False + + +{- ******************************************************************* +* * + Class lookup +* * +**********************************************************************-} + +-- | Indicates if Instance met the Safe Haskell overlapping instances safety +-- check. +-- +-- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +type SafeOverlapping = Bool + +data ClsInstResult + = NoInstance -- Definitely no instance + + | OneInst { cir_new_theta :: [TcPredType] + , cir_mk_ev :: [EvExpr] -> EvTerm + , cir_what :: InstanceWhat } + + | NotSure -- Multiple matches and/or one or more unifiers + +data InstanceWhat + = BuiltinInstance + | BuiltinEqInstance -- A built-in "equality instance"; see the + -- GHC.Tc.Solver.Monad Note [Solved dictionaries] + | LocalInstance + | TopLevInstance { iw_dfun_id :: DFunId + , iw_safe_over :: SafeOverlapping } + +instance Outputable ClsInstResult where + ppr NoInstance = text "NoInstance" + ppr NotSure = text "NotSure" + ppr (OneInst { cir_new_theta = ev + , cir_what = what }) + = text "OneInst" <+> vcat [ppr ev, ppr what] + +instance Outputable InstanceWhat where + ppr BuiltinInstance = text "a built-in instance" + ppr BuiltinEqInstance = text "a built-in equality instance" + ppr LocalInstance = text "a locally-quantified instance" + ppr (TopLevInstance { iw_dfun_id = dfun }) + = hang (text "instance" <+> pprSigmaType (idType dfun)) + 2 (text "--" <+> pprDefinedAt (idName dfun)) + +safeOverlap :: InstanceWhat -> Bool +safeOverlap (TopLevInstance { iw_safe_over = so }) = so +safeOverlap _ = True + +instanceReturnsDictCon :: InstanceWhat -> Bool +-- See Note [Solved dictionaries] in GHC.Tc.Solver.Monad +instanceReturnsDictCon (TopLevInstance {}) = True +instanceReturnsDictCon BuiltinInstance = True +instanceReturnsDictCon BuiltinEqInstance = False +instanceReturnsDictCon LocalInstance = False + +matchGlobalInst :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchGlobalInst dflags short_cut clas tys + | cls_name == knownNatClassName + = matchKnownNat dflags short_cut clas tys + | cls_name == knownSymbolClassName + = matchKnownSymbol dflags short_cut clas tys + | isCTupleClass clas = matchCTuple clas tys + | cls_name == typeableClassName = matchTypeable clas tys + | clas `hasKey` heqTyConKey = matchHeteroEquality tys + | clas `hasKey` eqTyConKey = matchHomoEquality tys + | clas `hasKey` coercibleTyConKey = matchCoercible tys + | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys + | otherwise = matchInstEnv dflags short_cut clas tys + where + cls_name = className clas + + +{- ******************************************************************** +* * + Looking in the instance environment +* * +***********************************************************************-} + + +matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult +matchInstEnv dflags short_cut_solver clas tys + = do { instEnvs <- tcGetInstEnvs + ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] + (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys + safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) + ; traceTc "matchInstEnv" $ + vcat [ text "goal:" <+> ppr clas <+> ppr tys + , text "matches:" <+> ppr matches + , text "unify:" <+> ppr unify ] + ; case (matches, unify, safeHaskFail) of + + -- Nothing matches + ([], [], _) + -> do { traceTc "matchClass not matching" (ppr pred) + ; return NoInstance } + + -- A single match (& no safe haskell failure) + ([(ispec, inst_tys)], [], False) + | short_cut_solver -- Called from the short-cut solver + , isOverlappable ispec + -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT + -- then don't let the short-cut solver choose it, because a + -- later instance might overlap it. #14434 is an example + -- See Note [Shortcut solving: overlap] + -> do { traceTc "matchClass: ignoring overlappable" (ppr pred) + ; return NotSure } + + | otherwise + -> do { let dfun_id = instanceDFunId ispec + ; traceTc "matchClass success" $ + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ] + -- Record that this dfun is needed + ; match_one (null unsafeOverlaps) dfun_id inst_tys } + + -- More than one matches (or Safe Haskell fail!). Defer any + -- reactions of a multitude until we learn more about the reagent + _ -> do { traceTc "matchClass multiple matches, deferring choice" $ + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches] + ; return NotSure } } + where + pred = mkClassPred clas tys + +match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult + -- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv +match_one so dfun_id mb_inst_tys + = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys) + ; (tys, theta) <- instDFunType dfun_id mb_inst_tys + ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta) + ; return $ OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_what = TopLevInstance { iw_dfun_id = dfun_id + , iw_safe_over = so } } } + + +{- Note [Shortcut solving: overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + instance {-# OVERLAPPABLE #-} C a where ... +and we are typechecking + f :: C a => a -> a + f = e -- Gives rise to [W] C a + +We don't want to solve the wanted constraint with the overlappable +instance; rather we want to use the supplied (C a)! That was the whole +point of it being overlappable! #14434 wwas an example. + +Alas even if the instance has no overlap flag, thus + instance C a where ... +there is nothing to stop it being overlapped. GHC provides no way to +declare an instance as "final" so it can't be overlapped. But really +only final instances are OK for short-cut solving. Sigh. #15135 +was a puzzling example. +-} + + +{- ******************************************************************** +* * + Class lookup for CTuples +* * +***********************************************************************-} + +matchCTuple :: Class -> [Type] -> TcM ClsInstResult +matchCTuple clas tys -- (isCTupleClass clas) holds + = return (OneInst { cir_new_theta = tys + , cir_mk_ev = tuple_ev + , cir_what = BuiltinInstance }) + -- The dfun *is* the data constructor! + where + data_con = tyConSingleDataCon (classTyCon clas) + tuple_ev = evDFunApp (dataConWrapId data_con) tys + +{- ******************************************************************** +* * + Class lookup for Literals +* * +***********************************************************************-} + +{- +Note [KnownNat & KnownSymbol and EvLit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A part of the type-level literals implementation are the classes +"KnownNat" and "KnownSymbol", which provide a "smart" constructor for +defining singleton values. Here is the key stuff from GHC.TypeNats + + class KnownNat (n :: Nat) where + natSing :: SNat n + + newtype SNat (n :: Nat) = SNat Natural + +Conceptually, this class has infinitely many instances: + + instance KnownNat 0 where natSing = SNat 0 + instance KnownNat 1 where natSing = SNat 1 + instance KnownNat 2 where natSing = SNat 2 + ... + +In practice, we solve `KnownNat` predicates in the type-checker +(see GHC.Tc.Solver.Interact) because we can't have infinitely many instances. +The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`. + +We make the following assumptions about dictionaries in GHC: + 1. The "dictionary" for classes with a single method---like `KnownNat`---is + a newtype for the type of the method, so using a evidence amounts + to a coercion, and + 2. Newtypes use the same representation as their definition types. + +So, the evidence for `KnownNat` is just a value of the representation type, +wrapped in two newtype constructors: one to make it into a `SNat` value, +and another to make it into a `KnownNat` dictionary. + +Also note that `natSing` and `SNat` are never actually exposed from the +library---they are just an implementation detail. Instead, users see +a more convenient function, defined in terms of `natSing`: + + natVal :: KnownNat n => proxy n -> Natural + +The reason we don't use this directly in the class is that it is simpler +and more efficient to pass around a Natural rather than an entire function, +especially when the `KnowNat` evidence is packaged up in an existential. + +The story for kind `Symbol` is analogous: + * class KnownSymbol + * newtype SSymbol + * Evidence: a Core literal (e.g. mkNaturalExpr) + + +Note [Fabricating Evidence for Literals in Backpack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Let `T` be a type of kind `Nat`. When solving for a purported instance +of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`, +in which case the evidence `EvLit (EvNum n)` is generated on the +fly. It might appear that this is sufficient as users cannot define +their own instances of `KnownNat`. However, for backpack module this +would not work (see issue #15379). Consider the signature `Abstract` + +> signature Abstract where +> data T :: Nat +> instance KnownNat T + +and a module `Util` that depends on it: + +> module Util where +> import Abstract +> printT :: IO () +> printT = do print $ natVal (Proxy :: Proxy T) + +Clearly, we need to "use" the dictionary associated with `KnownNat T` +in the module `Util`, but it is too early for the compiler to produce +a real dictionary as we still have not fixed what `T` is. Only when we +mixin a concrete module + +> module Concrete where +> type T = 42 + +do we really get hold of the underlying integer. So the strategy that +we follow is the following + +1. If T is indeed available as a type alias for an integer constant, + generate the dictionary on the fly, failing which + +2. Look up the type class environment for the evidence. + +Finally actual code gets generate for Util only when a module like +Concrete gets "mixed-in" in place of the signature Abstract. As a +result all things, including the typeclass instances, in Concrete gets +reexported. So `KnownNat` gets resolved the normal way post-Backpack. + +A similar generation works for `KnownSymbol` as well + +-} + +matchKnownNat :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownNat _ _ clas [ty] -- clas = KnownNat + | Just n <- isNumLitTy ty = makeLitDict clas ty (mkNaturalExpr n) +matchKnownNat df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + +matchKnownSymbol :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownSymbol _ _ clas [ty] -- clas = KnownSymbol + | Just s <- isStrLitTy ty = do + et <- mkStringExprFS s + makeLitDict clas ty et +matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + +makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult +-- makeLitDict adds a coercion that will convert the literal into a dictionary +-- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] +-- in GHC.Tc.Types.Evidence. The coercion happens in 2 steps: +-- +-- Integer -> SNat n -- representation of literal to singleton +-- SNat n -> KnownNat n -- singleton to dictionary +-- +-- The process is mirrored for Symbols: +-- String -> SSymbol n +-- SSymbol n -> KnownSymbol n +makeLitDict clas ty et + | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] + -- co_dict :: KnownNat n ~ SNat n + , [ meth ] <- classMethods clas + , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth) + -- If the method type is forall n. KnownNat n => SNat n + -- then tcRep is SNat + , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] + -- SNat n ~ Integer + , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) + = return $ OneInst { cir_new_theta = [] + , cir_mk_ev = \_ -> ev_tm + , cir_what = BuiltinInstance } + + | otherwise + = pprPanic "makeLitDict" $ + text "Unexpected evidence for" <+> ppr (className clas) + $$ vcat (map (ppr . idType) (classMethods clas)) + +{- ******************************************************************** +* * + Class lookup for Typeable +* * +***********************************************************************-} + +-- | Assumes that we've checked that this is the 'Typeable' class, +-- and it was applied to the correct argument. +matchTypeable :: Class -> [Type] -> TcM ClsInstResult +matchTypeable clas [k,t] -- clas = Typeable + -- For the first two cases, See Note [No Typeable for polytypes or qualified types] + | isForAllTy k = return NoInstance -- Polytype + | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type + + -- Now cases that do work + | k `eqType` typeNatKind = doTyLit knownNatClassName t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] + | Just (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult arg ret + | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] + , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks + | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt + +matchTypeable _ _ = return NoInstance + +-- | Representation for a type @ty@ of the form @arg -> ret@. +doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult +doFunTy clas ty mult arg_ty ret_ty + = return $ OneInst { cir_new_theta = preds + , cir_mk_ev = mk_ev + , cir_what = BuiltinInstance } + where + preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty] + mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $ + EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev) + mk_ev _ = panic "GHC.Tc.Solver.Interact.doFunTy" + + +-- | Representation for type constructor applied to some kinds. +-- 'onlyNamedBndrsApplied' has ensured that this application results in a type +-- of monomorphic kind (e.g. all kind variables have been instantiated). +doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult +doTyConApp clas ty tc kind_args + | tyConIsTypeable tc + = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args) + , cir_mk_ev = mk_ev + , cir_what = BuiltinInstance } + | otherwise + = return NoInstance + where + mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds) + +-- | Representation for TyCon applications of a concrete kind. We just use the +-- kind itself, but first we must make sure that we've instantiated all kind- +-- polymorphism, but no more. +onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool +onlyNamedBndrsApplied tc ks + = all isNamedTyConBinder used_bndrs && + not (any isNamedTyConBinder leftover_bndrs) + where + bndrs = tyConBinders tc + (used_bndrs, leftover_bndrs) = splitAtList ks bndrs + +doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult +-- Representation for an application of a type to a type-or-kind. +-- This may happen when the type expression starts with a type variable. +-- Example (ignoring kind parameter): +-- Typeable (f Int Char) --> +-- (Typeable (f Int), Typeable Char) --> +-- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) +-- Typeable f +doTyApp clas ty f tk + | isForAllTy (tcTypeKind f) + = return NoInstance -- We can't solve until we know the ctr. + | otherwise + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] + , cir_mk_ev = mk_ev + , cir_what = BuiltinInstance } + where + mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) + mk_ev _ = panic "doTyApp" + + +-- Emit a `Typeable` constraint for the given type. +mk_typeable_pred :: Class -> Type -> PredType +mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ] + + -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal + -- we generate a sub-goal for the appropriate class. + -- See Note [Typeable for Nat and Symbol] +doTyLit :: Name -> Type -> TcM ClsInstResult +doTyLit kc t = do { kc_clas <- tcLookupClass kc + ; let kc_pred = mkClassPred kc_clas [ t ] + mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) + mk_ev _ = panic "doTyLit" + ; return (OneInst { cir_new_theta = [kc_pred] + , cir_mk_ev = mk_ev + , cir_what = BuiltinInstance }) } + +{- Note [Typeable (T a b c)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For type applications we always decompose using binary application, +via doTyApp, until we get to a *kind* instantiation. Example + Proxy :: forall k. k -> * + +To solve Typeable (Proxy (* -> *) Maybe) we + - First decompose with doTyApp, + to get (Typeable (Proxy (* -> *))) and Typeable Maybe + - Then solve (Typeable (Proxy (* -> *))) with doTyConApp + +If we attempt to short-cut by solving it all at once, via +doTyConApp + +(this note is sadly truncated FIXME) + + +Note [No Typeable for polytypes or qualified types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not support impredicative typeable, such as + Typeable (forall a. a->a) + Typeable (Eq a => a -> a) + Typeable (() => Int) + Typeable (((),()) => Int) + +See #9858. For forall's the case is clear: we simply don't have +a TypeRep for them. For qualified but not polymorphic types, like +(Eq a => a -> a), things are murkier. But: + + * We don't need a TypeRep for these things. TypeReps are for + monotypes only. + + * Perhaps we could treat `=>` as another type constructor for `Typeable` + purposes, and thus support things like `Eq Int => Int`, however, + at the current state of affairs this would be an odd exception as + no other class works with impredicative types. + For now we leave it off, until we have a better story for impredicativity. + + +Note [Typeable for Nat and Symbol] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have special Typeable instances for Nat and Symbol. Roughly we +have this instance, implemented here by doTyLit: + instance KnownNat n => Typeable (n :: Nat) where + typeRep = typeNatTypeRep @n +where + Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a + +Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a +runtime value 'n'; it turns it into a string with 'show' and uses +that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon. +See #10348. + +Because of this rule it's inadvisable (see #15322) to have a constraint + f :: (Typeable (n :: Nat)) => blah +in a function signature; it gives rise to overlap problems just as +if you'd written + f :: Eq [a] => blah +-} + +{- ******************************************************************** +* * + Class lookup for lifted equality +* * +***********************************************************************-} + +-- See also Note [The equality types story] in GHC.Builtin.Types.Prim +matchHeteroEquality :: [Type] -> TcM ClsInstResult +-- Solves (t1 ~~ t2) +matchHeteroEquality args + = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ] + , cir_mk_ev = evDataConApp heqDataCon args + , cir_what = BuiltinEqInstance }) + +matchHomoEquality :: [Type] -> TcM ClsInstResult +-- Solves (t1 ~ t2) +matchHomoEquality args@[k,t1,t2] + = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ] + , cir_mk_ev = evDataConApp eqDataCon args + , cir_what = BuiltinEqInstance }) +matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args) + +-- See also Note [The equality types story] in GHC.Builtin.Types.Prim +matchCoercible :: [Type] -> TcM ClsInstResult +matchCoercible args@[k, t1, t2] + = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] + , cir_mk_ev = evDataConApp coercibleDataCon args + , cir_what = BuiltinEqInstance }) + where + args' = [k, k, t1, t2] +matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args) + + +{- ******************************************************************** +* * + Class lookup for overloaded record fields +* * +***********************************************************************-} + +{- +Note [HasField instances] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + data T y = MkT { foo :: [y] } + +and `foo` is in scope. Then GHC will automatically solve a constraint like + + HasField "foo" (T Int) b + +by emitting a new wanted + + T alpha -> [alpha] ~# T Int -> b + +and building a HasField dictionary out of the selector function `foo`, +appropriately cast. + +The HasField class is defined (in GHC.Records) thus: + + class HasField (x :: k) r a | x r -> a where + getField :: r -> a + +Since this is a one-method class, it is represented as a newtype. +Hence we can solve `HasField "foo" (T Int) b` by taking an expression +of type `T Int -> b` and casting it using the newtype coercion. +Note that + + foo :: forall y . T y -> [y] + +so the expression we construct is + + foo @alpha |> co + +where + + co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b + +is built from + + co1 :: (T alpha -> [alpha]) ~# (T Int -> b) + +which is the new wanted, and + + co2 :: (T Int -> b) ~# HasField "foo" (T Int) b + +which can be derived from the newtype coercion. + +If `foo` is not in scope, or has a higher-rank or existentially +quantified type, then the constraint is not solved automatically, but +may be solved by a user-supplied HasField instance. Similarly, if we +encounter a HasField constraint where the field is not a literal +string, or does not belong to the type, then we fall back on the +normal constraint solver behaviour. +-} + +-- See Note [HasField instances] +matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult +matchHasField dflags short_cut clas tys + = do { fam_inst_envs <- tcGetFamInstEnvs + ; rdr_env <- getGlobalRdrEnv + ; case tys of + -- We are matching HasField {k} x r a... + [_k_ty, x_ty, r_ty, a_ty] + -- x should be a literal string + | Just x <- isStrLitTy x_ty + -- r should be an applied type constructor + , Just (tc, args) <- tcSplitTyConApp_maybe r_ty + -- use representation tycon (if data family); it has the fields + , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) + -- x should be a field of r + , Just fl <- lookupTyConFieldLabel x r_tc + -- the field selector should be in scope + , Just gre <- lookupGRE_FieldLabel rdr_env fl + + -> do { sel_id <- tcLookupId (flSelector fl) + ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id + + -- The first new wanted constraint equates the actual + -- type of the selector with the type (r -> a) within + -- the HasField x r a dictionary. The preds will + -- typically be empty, but if the datatype has a + -- "stupid theta" then we have to include it here. + ; let theta = mkPrimEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds + + -- Use the equality proof to cast the selector Id to + -- type (r -> a), then use the newtype coercion to cast + -- it to a HasField dictionary. + mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co + where + co = mkTcSubCo (evTermCoercion (EvExpr ev1)) + `mkTcTransCo` mkTcSymCo co2 + mk_ev [] = panic "matchHasField.mk_ev" + + Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) + tys + + tvs = mkTyVarTys (map snd tv_prs) + + -- The selector must not be "naughty" (i.e. the field + -- cannot have an existentially quantified type), and + -- it must not be higher-rank. + ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty + then do { addUsedGRE True gre + ; return OneInst { cir_new_theta = theta + , cir_mk_ev = mk_ev + , cir_what = BuiltinInstance } } + else matchInstEnv dflags short_cut clas tys } + + _ -> matchInstEnv dflags short_cut clas tys } diff --git a/GHC/Tc/Instance/Family.hs b/GHC/Tc/Instance/Family.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/Family.hs @@ -0,0 +1,1030 @@ +{-# LANGUAGE CPP, GADTs, ViewPatterns #-} + +-- | The @FamInst@ type: family instance heads +module GHC.Tc.Instance.Family ( + FamInstEnvs, tcGetFamInstEnvs, + checkFamInstConsistency, tcExtendLocalFamInstEnv, + tcLookupDataFamInst, tcLookupDataFamInst_maybe, + tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, + newFamInst, + + -- * Injectivity + reportInjectivityErrors, reportConflictingInjectivityErrs + ) where + +import GHC.Prelude + +import GHC.Driver.Types +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv( roughMatchTcs ) +import GHC.Core.Coercion +import GHC.Tc.Types.Evidence +import GHC.Iface.Load +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Core.TyCon +import GHC.Tc.Utils.TcType +import GHC.Core.Coercion.Axiom +import GHC.Driver.Session +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Name.Reader +import GHC.Core.DataCon ( dataConName ) +import GHC.Data.Maybe +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) +import GHC.Types.Name +import GHC.Utils.Panic +import GHC.Types.Var.Set +import GHC.Utils.FV +import GHC.Data.Bag( Bag, unionBags, unitBag ) +import Control.Monad +import Data.List ( sortBy ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Function ( on ) + +import qualified GHC.LanguageExtensions as LangExt + +#include "HsVersions.h" + +{- Note [The type family instance consistency story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To preserve type safety we must ensure that for any given module, all +the type family instances used either in that module or in any module +it directly or indirectly imports are consistent. For example, consider + + module F where + type family F a + + module A where + import F( F ) + type instance F Int = Bool + f :: F Int -> Bool + f x = x + + module B where + import F( F ) + type instance F Int = Char + g :: Char -> F Int + g x = x + + module Bad where + import A( f ) + import B( g ) + bad :: Char -> Int + bad c = f (g c) + +Even though module Bad never mentions the type family F at all, by +combining the functions f and g that were type checked in contradictory +type family instance environments, the function bad is able to coerce +from one type to another. So when we type check Bad we must verify that +the type family instances defined in module A are consistent with those +defined in module B. + +How do we ensure that we maintain the necessary consistency? + +* Call a module which defines at least one type family instance a + "family instance module". This flag `mi_finsts` is recorded in the + interface file. + +* For every module we calculate the set of all of its direct and + indirect dependencies that are family instance modules. This list + `dep_finsts` is also recorded in the interface file so we can compute + this list for a module from the lists for its direct dependencies. + +* When type checking a module M we check consistency of all the type + family instances that are either provided by its `dep_finsts` or + defined in the module M itself. This is a pairwise check, i.e., for + every pair of instances we must check that they are consistent. + + - For family instances coming from `dep_finsts`, this is checked in + checkFamInstConsistency, called from tcRnImports. See Note + [Checking family instance consistency] for details on this check + (and in particular how we avoid having to do all these checks for + every module we compile). + + - That leaves checking the family instances defined in M itself + against instances defined in either M or its `dep_finsts`. This is + checked in `tcExtendLocalFamInstEnv'. + +There are four subtle points in this scheme which have not been +addressed yet. + +* We have checked consistency of the family instances *defined* by M + or its imports, but this is not by definition the same thing as the + family instances *used* by M or its imports. Specifically, we need to + ensure when we use a type family instance while compiling M that this + instance was really defined from either M or one of its imports, + rather than being an instance that we happened to know about from + reading an interface file in the course of compiling an unrelated + module. Otherwise, we'll end up with no record of the fact that M + depends on this family instance and type safety will be compromised. + See #13102. + +* It can also happen that M uses a function defined in another module + which is not transitively imported by M. Examples include the + desugaring of various overloaded constructs, and references inserted + by Template Haskell splices. If that function's definition makes use + of type family instances which are not checked against those visible + from M, type safety can again be compromised. See #13251. + +* When a module C imports a boot module B.hs-boot, we check that C's + type family instances are compatible with those visible from + B.hs-boot. However, C will eventually be linked against a different + module B.hs, which might define additional type family instances which + are inconsistent with C's. This can also lead to loss of type safety. + See #9562. + +* The call to checkFamConsistency for imported functions occurs very + early (in tcRnImports) and that causes problems if the imported + instances use type declared in the module being compiled. + See Note [Loading your own hi-boot file] in GHC.Iface.Load. +-} + +{- +************************************************************************ +* * + Making a FamInst +* * +************************************************************************ +-} + +-- All type variables in a FamInst must be fresh. This function +-- creates the fresh variables and applies the necessary substitution +-- It is defined here to avoid a dependency from FamInstEnv on the monad +-- code. + +newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst +-- Freshen the type variables of the FamInst branches +newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) + = do { + -- Freshen the type variables + (subst, tvs') <- freshenTyVarBndrs tvs + ; (subst, cvs') <- freshenCoVarBndrsX subst cvs + ; let lhs' = substTys subst lhs + rhs' = substTy subst rhs + + ; return (FamInst { fi_fam = tyConName fam_tc + , fi_flavor = flavor + , fi_tcs = roughMatchTcs lhs + , fi_tvs = tvs' + , fi_cvs = cvs' + , fi_tys = lhs' + , fi_rhs = rhs' + , fi_axiom = axiom }) } + where + CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs + , cab_lhs = lhs + , cab_rhs = rhs } = coAxiomSingleBranch axiom + + +{- +************************************************************************ +* * + Optimised overlap checking for family instances +* * +************************************************************************ + +Note [Checking family instance consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For any two family instance modules that we import directly or indirectly, we +check whether the instances in the two modules are consistent, *unless* we can +be certain that the instances of the two modules have already been checked for +consistency during the compilation of modules that we import. + +Why do we need to check? Consider + module X1 where module X2 where + data T1 data T2 + type instance F T1 b = Int type instance F a T2 = Char + f1 :: F T1 a -> Int f2 :: Char -> F a T2 + f1 x = x f2 x = x + +Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. +Notice that neither instance is an orphan. + +How do we know which pairs of modules have already been checked? For each +module M we directly import, we look up the family instance modules that M +imports (directly or indirectly), say F1, ..., FN. For any two modules +among M, F1, ..., FN, we know that the family instances defined in those +two modules are consistent--because we checked that when we compiled M. + +For every other pair of family instance modules we import (directly or +indirectly), we check that they are consistent now. (So that we can be +certain that the modules in our `GHC.Driver.Types.dep_finsts' are consistent.) + +There is some fancy footwork regarding hs-boot module loops, see +Note [Don't check hs-boot type family instances too early] + +Note [Checking family instance optimization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Checking family instance consistency] +we need to ensure that every pair of transitive imports that define type family +instances is consistent. + +Let's define df(A) = transitive imports of A that define type family instances ++ A, if A defines type family instances + +Then for every direct import A, df(A) is already consistent. + +Let's name the current module M. + +We want to make sure that df(M) is consistent. +df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports. + +We perform the check iteratively, maintaining a set of consistent modules 'C' +and trying to add df(D_i) to it. + +The key part is how to ensure that the union C U df(D_i) is consistent. + +Let's consider two modules: A and B from C U df(D_i). +There are nine possible ways to choose A and B from C U df(D_i): + + | A in C only | A in C and B in df(D_i) | A in df(D_i) only +-------------------------------------------------------------------------------- +B in C only | Already checked | Already checked | Needs to be checked + | when checking C | when checking C | +-------------------------------------------------------------------------------- +B in C and | Already checked | Already checked | Already checked when +B in df(D_i) | when checking C | when checking C | checking df(D_i) +-------------------------------------------------------------------------------- +B in df(D_i) | Needs to be | Already checked | Already checked when +only | checked | when checking df(D_i) | checking df(D_i) + +That means to ensure that C U df(D_i) is consistent we need to check every +module from C - df(D_i) against every module from df(D_i) - C and +every module from df(D_i) - C against every module from C - df(D_i). +But since the checks are symmetric it suffices to pick A from C - df(D_i) +and B from df(D_i) - C. + +In other words these are the modules we need to check: + [ (m1, m2) | m1 <- C, m1 not in df(D_i) + , m2 <- df(D_i), m2 not in C ] + +One final thing to note here is that if there's lot of overlap between +subsequent df(D_i)'s then we expect those set differences to be small. +That situation should be pretty common in practice, there's usually +a set of utility modules that every module imports directly or indirectly. + +This is basically the idea from #13092, comment:14. +-} + +-- This function doesn't check ALL instances for consistency, +-- only ones that aren't involved in recursive knot-tying +-- loops; see Note [Don't check hs-boot type family instances too early]. +-- We don't need to check the current module, this is done in +-- tcExtendLocalFamInstEnv. +-- See Note [The type family instance consistency story]. +checkFamInstConsistency :: [Module] -> TcM () +checkFamInstConsistency directlyImpMods + = do { (eps, hpt) <- getEpsAndHpt + ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) + ; let { -- Fetch the iface of a given module. Must succeed as + -- all directly imported modules must already have been loaded. + modIface mod = + case lookupIfaceByModule hpt (eps_PIT eps) mod of + Nothing -> panicDoc "FamInst.checkFamInstConsistency" + (ppr mod $$ pprHPT hpt) + Just iface -> iface + + -- Which family instance modules were checked for consistency + -- when we compiled `mod`? + -- Itself (if a family instance module) and its dep_finsts. + -- This is df(D_i) from + -- Note [Checking family instance optimization] + ; modConsistent :: Module -> [Module] + ; modConsistent mod = + if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps + where + deps = dep_finsts . mi_deps . modIface $ mod + + ; hmiModule = mi_module . hm_iface + ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) + | hmi <- eltsHpt hpt] + + } + + ; checkMany hpt_fam_insts modConsistent directlyImpMods + } + where + -- See Note [Checking family instance optimization] + checkMany + :: ModuleEnv FamInstEnv -- home package family instances + -> (Module -> [Module]) -- given A, modules checked when A was checked + -> [Module] -- modules to process + -> TcM () + checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods + where + go :: [Module] -- list of consistent modules + -> ModuleSet -- set of consistent modules, same elements as the + -- list above + -> [Module] -- modules to process + -> TcM () + go _ _ [] = return () + go consistent consistent_set (mod:mods) = do + sequence_ + [ check hpt_fam_insts m1 m2 + | m1 <- to_check_from_mod + -- loop over toCheckFromMod first, it's usually smaller, + -- it may even be empty + , m2 <- to_check_from_consistent + ] + go consistent' consistent_set' mods + where + mod_deps_consistent = modConsistent mod + mod_deps_consistent_set = mkModuleSet mod_deps_consistent + consistent' = to_check_from_mod ++ consistent + consistent_set' = + extendModuleSetList consistent_set to_check_from_mod + to_check_from_consistent = + filterOut (`elemModuleSet` mod_deps_consistent_set) consistent + to_check_from_mod = + filterOut (`elemModuleSet` consistent_set) mod_deps_consistent + -- Why don't we just minusModuleSet here? + -- We could, but doing so means one of two things: + -- + -- 1. When looping over the cartesian product we convert + -- a set into a non-deterministicly ordered list. Which + -- happens to be fine for interface file determinism + -- in this case, today, because the order only + -- determines the order of deferred checks. But such + -- invariants are hard to keep. + -- + -- 2. When looping over the cartesian product we convert + -- a set into a deterministically ordered list - this + -- adds some additional cost of sorting for every + -- direct import. + -- + -- That also explains why we need to keep both 'consistent' + -- and 'consistentSet'. + -- + -- See also Note [ModuleEnv performance and determinism]. + check hpt_fam_insts m1 m2 + = do { env1' <- getFamInsts hpt_fam_insts m1 + ; env2' <- getFamInsts hpt_fam_insts m2 + -- We're checking each element of env1 against env2. + -- The cost of that is dominated by the size of env1, because + -- for each instance in env1 we look it up in the type family + -- environment env2, and lookup is cheap. + -- The code below ensures that env1 is the smaller environment. + ; let sizeE1 = famInstEnvSize env1' + sizeE2 = famInstEnvSize env2' + (env1, env2) = if sizeE1 < sizeE2 then (env1', env2') + else (env2', env1') + -- Note [Don't check hs-boot type family instances too early] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Family instance consistency checking involves checking that + -- the family instances of our imported modules are consistent with + -- one another; this might lead you to think that this process + -- has nothing to do with the module we are about to typecheck. + -- Not so! Consider the following case: + -- + -- -- A.hs-boot + -- type family F a + -- + -- -- B.hs + -- import {-# SOURCE #-} A + -- type instance F Int = Bool + -- + -- -- A.hs + -- import B + -- type family F a + -- + -- When typechecking A, we are NOT allowed to poke the TyThing + -- for F until we have typechecked the family. Thus, we + -- can't do consistency checking for the instance in B + -- (checkFamInstConsistency is called during renaming). + -- Failing to defer the consistency check lead to #11062. + -- + -- Additionally, we should also defer consistency checking when + -- type from the hs-boot file of the current module occurs on + -- the left hand side, as we will poke its TyThing when checking + -- for overlap. + -- + -- -- F.hs + -- type family F a + -- + -- -- A.hs-boot + -- import F + -- data T + -- + -- -- B.hs + -- import {-# SOURCE #-} A + -- import F + -- type instance F T = Int + -- + -- -- A.hs + -- import B + -- data T = MkT + -- + -- In fact, it is even necessary to defer for occurrences in + -- the RHS, because we may test for *compatibility* in event + -- of an overlap. + -- + -- Why don't we defer ALL of the checks to later? Well, many + -- instances aren't involved in the recursive loop at all. So + -- we might as well check them immediately; and there isn't + -- a good time to check them later in any case: every time + -- we finish kind-checking a type declaration and add it to + -- a context, we *then* consistency check all of the instances + -- which mentioned that type. We DO want to check instances + -- as quickly as possible, so that we aren't typechecking + -- values with inconsistent axioms in scope. + -- + -- See also Note [Tying the knot] + -- for why we are doing this at all. + ; let check_now = famInstEnvElts env1 + ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now + ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now + } + +getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv +getFamInsts hpt_fam_insts mod + | Just env <- lookupModuleEnv hpt_fam_insts mod = return env + | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) + ; eps <- getEps + ; return (expectJust "checkFamInstConsistency" $ + lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } + where + doc = ppr mod <+> text "is a family-instance module" + +{- +************************************************************************ +* * + Lookup +* * +************************************************************************ + +-} + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion +tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) +tcInstNewTyCon_maybe = instNewTyCon_maybe + +-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if +-- there is no data family to unwrap. +-- Returns a Representational coercion +tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] + -> (TyCon, [TcType], Coercion) +tcLookupDataFamInst fam_inst_envs tc tc_args + | Just (rep_tc, rep_args, co) + <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + = (rep_tc, rep_args, co) + | otherwise + = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) + +tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] + -> Maybe (TyCon, [TcType], Coercion) +-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) +-- and returns a coercion between the two: co :: F [a] ~R FList a. +tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + | isDataFamilyTyCon tc + , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args + , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax + , fi_cvs = cvs }) + , fim_tys = rep_args + , fim_cos = rep_cos } <- match + , let rep_tc = dataFamInstRepTyCon rep_fam + co = mkUnbranchedAxInstCo Representational ax rep_args + (mkCoVarCos cvs) + = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv + Just (rep_tc, rep_args, co) + + | otherwise + = Nothing + +-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, +-- potentially looking through newtype /instances/. +-- +-- It is only used by the type inference engine (specifically, when +-- solving representational equality), and hence it is careful to unwrap +-- only if the relevant data constructor is in scope. That's why +-- it get a GlobalRdrEnv argument. +-- +-- It is careful not to unwrap data/newtype instances if it can't +-- continue unwrapping. Such care is necessary for proper error +-- messages. +-- +-- It does not look through type families. +-- It does not normalise arguments to a tycon. +-- +-- If the result is Just (rep_ty, (co, gres), rep_ty), then +-- co : ty ~R rep_ty +-- gres are the GREs for the data constructors that +-- had to be in scope +tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs + -> GlobalRdrEnv + -> Type + -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) +tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty +-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe + = topNormaliseTypeX stepper plus ty + where + plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) + -> (Bag GlobalRdrElt, TcCoercion) + plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 + , co1 `mkTransCo` co2 ) + + stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) + stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance + + -- For newtype instances we take a double step or nothing, so that + -- we don't return the representation type of the newtype instance, + -- which would lead to terrible error messages + unwrap_newtype_instance rec_nts tc tys + | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys + = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ + unwrap_newtype rec_nts tc' tys' + | otherwise = NS_Done + + unwrap_newtype rec_nts tc tys + | Just con <- newTyConDataCon_maybe tc + , Just gre <- lookupGRE_Name rdr_env (dataConName con) + -- This is where we check that the + -- data constructor is in scope + = mapStepResult (\co -> (unitBag gre, co)) $ + unwrapNewTypeStepper rec_nts tc tys + + | otherwise + = NS_Done + +{- +************************************************************************ +* * + Extending the family instance environment +* * +************************************************************************ +-} + +-- Add new locally-defined family instances, checking consistency with +-- previous locally-defined family instances as well as all instances +-- available from imported modules. This requires loading all of our +-- imports that define family instances (if we haven't loaded them already). +tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a + +-- If we weren't actually given any instances to add, then we don't want +-- to go to the bother of loading family instance module dependencies. +tcExtendLocalFamInstEnv [] thing_inside = thing_inside + +-- Otherwise proceed... +tcExtendLocalFamInstEnv fam_insts thing_inside + = do { -- Load family-instance modules "below" this module, so that + -- allLocalFamInst can check for consistency with them + -- See Note [The type family instance consistency story] + loadDependentFamInstModules fam_insts + + -- Now add the instances one by one + ; env <- getGblEnv + ; (inst_env', fam_insts') <- foldlM addLocalFamInst + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts + + ; let env' = env { tcg_fam_insts = fam_insts' + , tcg_fam_inst_env = inst_env' } + ; setGblEnv env' thing_inside + } + +loadDependentFamInstModules :: [FamInst] -> TcM () +-- Load family-instance modules "below" this module, so that +-- allLocalFamInst can check for consistency with them +-- See Note [The type family instance consistency story] +loadDependentFamInstModules fam_insts + = do { env <- getGblEnv + ; let this_mod = tcg_mod env + imports = tcg_imports env + + want_module mod -- See Note [Home package family instances] + | mod == this_mod = False + | home_fams_only = moduleUnit mod == moduleUnit this_mod + | otherwise = True + home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts + + ; loadModuleInterfaces (text "Loading family-instance modules") $ + filter want_module (imp_finsts imports) } + +{- Note [Home package family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Optimization: If we're only defining type family instances +for type families *defined in the home package*, then we +only have to load interface files that belong to the home +package. The reason is that there's no recursion between +packages, so modules in other packages can't possibly define +instances for our type families. + +(Within the home package, we could import a module M that +imports us via an hs-boot file, and thereby defines an +instance of a type family defined in this module. So we can't +apply the same logic to avoid reading any interface files at +all, when we define an instances for type family defined in +the current module. +-} + +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] +-- in GHC.Core.FamInstEnv +addLocalFamInst :: (FamInstEnv,[FamInst]) + -> FamInst + -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst (home_fie, my_fis) fam_inst + -- home_fie includes home package and this module + -- my_fies is just the ones from this module + = do { traceTc "addLocalFamInst" (ppr fam_inst) + + -- Unlike the case of class instances, don't override existing + -- instances in GHCi; it's unsound. See #7102. + + ; mod <- getModule + ; traceTc "alfi" (ppr mod) + + -- Fetch imported instances, so that we report + -- overlaps correctly. + -- Really we ought to only check consistency with + -- those instances which are transitively imported + -- by the current module, rather than every instance + -- we've ever seen. Fixing this is part of #13102. + ; eps <- getEps + ; let inst_envs = (eps_fam_inst_env eps, home_fie) + home_fie' = extendFamInstEnv home_fie fam_inst + + -- Check for conflicting instance decls and injectivity violations + ; ((), no_errs) <- askNoErrs $ + do { checkForConflicts inst_envs fam_inst + ; checkForInjectivityConflicts inst_envs fam_inst + ; checkInjectiveEquation fam_inst + } + + ; if no_errs then + return (home_fie', fam_inst : my_fis) + else + return (home_fie, my_fis) } + +{- +************************************************************************ +* * + Checking an instance against conflicts with an instance env +* * +************************************************************************ + +Check whether a single family instance conflicts with those in two instance +environments (one for the EPS and one for the HPT). +-} + +-- | Checks to make sure no two family instances overlap. +checkForConflicts :: FamInstEnvs -> FamInst -> TcM () +checkForConflicts inst_envs fam_inst + = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst + ; traceTc "checkForConflicts" $ + vcat [ ppr (map fim_instance conflicts) + , ppr fam_inst + -- , ppr inst_envs + ] + ; reportConflictInstErr fam_inst conflicts } + +checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM () + -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv, check 1B1. +checkForInjectivityConflicts instEnvs famInst + | isTypeFamilyTyCon tycon -- as opposed to data family tycon + , Injective inj <- tyConInjectivityInfo tycon + = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in + reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst)) + + | otherwise + = return () + + where tycon = famInstTyCon famInst + +-- | Check whether a new open type family equation can be added without +-- violating injectivity annotation supplied by the user. Returns True when +-- this is possible and False if adding this equation would violate injectivity +-- annotation. This looks only at the one equation; it does not look for +-- interaction between equations. Use checkForInjectivityConflicts for that. +-- Does checks (2)-(4) of Note [Verifying injectivity annotation] in "GHC.Core.FamInstEnv". +checkInjectiveEquation :: FamInst -> TcM () +checkInjectiveEquation famInst + | isTypeFamilyTyCon tycon + -- type family is injective in at least one argument + , Injective inj <- tyConInjectivityInfo tycon = do + { dflags <- getDynFlags + ; let axiom = coAxiomSingleBranch fi_ax + -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + ; reportInjectivityErrors dflags fi_ax axiom inj + } + + -- if there was no injectivity annotation or tycon does not represent a + -- type family we report no conflicts + | otherwise + = return () + + where tycon = famInstTyCon famInst + fi_ax = fi_axiom famInst + +-- | Report a list of injectivity errors together with their source locations. +-- Looks only at one equation; does not look for conflicts *among* equations. +reportInjectivityErrors + :: DynFlags + -> CoAxiom br -- ^ Type family for which we generate errors + -> CoAxBranch -- ^ Currently checked equation (represented by axiom) + -> [Bool] -- ^ Injectivity annotation + -> TcM () +reportInjectivityErrors dflags fi_ax axiom inj + = ASSERT2( any id inj, text "No injective type variables" ) + do let lhs = coAxBranchLHS axiom + rhs = coAxBranchRHS axiom + fam_tc = coAxiomTyCon fi_ax + (unused_inj_tvs, unused_vis, undec_inst_flag) + = unusedInjTvsInRHS dflags fam_tc lhs rhs + inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs + tf_headed = isTFHeaded rhs + bare_variables = bareTvInRHSViolated lhs rhs + wrong_bare_rhs = not $ null bare_variables + + when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs + unused_vis undec_inst_flag axiom + when tf_headed $ reportTfHeadedErr fam_tc axiom + when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom + +-- | Is type headed by a type family application? +isTFHeaded :: Type -> Bool +-- See Note [Verifying injectivity annotation], case 3. +isTFHeaded ty | Just ty' <- coreView ty + = isTFHeaded ty' +isTFHeaded ty | (TyConApp tc args) <- ty + , isTypeFamilyTyCon tc + = args `lengthIs` tyConArity tc +isTFHeaded _ = False + + +-- | If a RHS is a bare type variable return a set of LHS patterns that are not +-- bare type variables. +bareTvInRHSViolated :: [Type] -> Type -> [Type] +-- See Note [Verifying injectivity annotation], case 2. +bareTvInRHSViolated pats rhs | isTyVarTy rhs + = filter (not . isTyVarTy) pats +bareTvInRHSViolated _ _ = [] + +------------------------------------------------------------------ +-- Checking for the coverage condition for injective type families +------------------------------------------------------------------ + +{- +Note [Coverage condition for injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Injective Type Families paper describes how we can tell whether +or not a type family equation upholds the injectivity condition. +Briefly, consider the following: + + type family F a b = r | r -> a -- NB: b is not injective + + type instance F ty1 ty2 = ty3 + +We need to make sure that all variables mentioned in ty1 are mentioned in ty3 +-- that's how we know that knowing ty3 determines ty1. But they can't be +mentioned just anywhere in ty3: they must be in *injective* positions in ty3. +For example: + + type instance F a Int = Maybe (G a) + +This is no good, if G is not injective. However, if G is indeed injective, +then this would appear to meet our needs. There is a trap here, though: while +knowing G a does indeed determine a, trying to compute a from G a might not +terminate. This is precisely the same problem that we have with functional +dependencies and their liberal coverage condition. Here is the test case: + + type family G a = r | r -> a + type instance G [a] = [G a] + [W] G alpha ~ [alpha] + +We see that the equation given applies, because G alpha equals a list. So we +learn that alpha must be [beta] for some beta. We then have + + [W] G [beta] ~ [[beta]] + +This can reduce to + + [W] [G beta] ~ [[beta]] + +which then decomposes to + + [W] G beta ~ [beta] + +right where we started. The equation G [a] = [G a] thus is dangerous: while +it does not violate the injectivity assumption, it might throw us into a loop, +with a particularly dastardly Wanted. + +We thus do what functional dependencies do: require -XUndecidableInstances to +accept this. + +Checking the coverage condition is not terribly hard, but we also want to produce +a nice error message. A nice error message has at least two properties: + +1. If any of the variables involved are invisible or are used in an invisible context, +we want to print invisible arguments (as -fprint-explicit-kinds does). + +2. If we fail to accept the equation because we're worried about non-termination, +we want to suggest UndecidableInstances. + +To gather the right information, we can talk about the *usage* of a variable. Every +variable is used either visibly or invisibly, and it is either not used at all, +in a context where acceptance requires UndecidableInstances, or in a context that +does not require UndecidableInstances. If a variable is used both visibly and +invisibly, then we want to remember the fact that it was used invisibly: printing +out invisibles will be helpful for the user to understand what is going on. +If a variable is used where we need -XUndecidableInstances and where we don't, +we can similarly just remember the latter. + +We thus define Visibility and NeedsUndecInstFlag below. These enumerations are +*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair +of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a +variable is NotPresent, but this extra slack in the representation causes no +harm.) We finally define VarUsages as a mapping from variables to VarUsage. +Its Monoid instance combines two maps, using the Semigroup instance of VarUsage +to combine elements that are represented in both maps. In this way, we can +compositionally analyze types (and portions thereof). + +To do the injectivity check: + +1. We build VarUsages that represent the LHS (rather, the portion of the LHS +that is flagged as injective); each usage on the LHS is NotPresent, because we +have not yet looked at the RHS. + +2. We also build a VarUsage for the RHS, done by injTyVarUsages. + +3. We then combine these maps. Now, every variable in the injective components of the LHS +will be mapped to its correct usage (either NotPresent or perhaps needing +-XUndecidableInstances in order to be seen as injective). + +4. We look up each var used in an injective argument on the LHS in +the map, making a list of tvs that should be determined by the RHS +but aren't. + +5. We then return the set of bad variables, whether any of the bad +ones were used invisibly, and whether any bad ones need -XUndecidableInstances. +If -XUndecidableInstances is enabled, than a var that needs the flag +won't be bad, so it won't appear in this list. + +6. We use all this information to produce a nice error message, (a) switching +on -fprint-explicit-kinds if appropriate and (b) telling the user about +-XUndecidableInstances if appropriate. + +-} + +-- | Return the set of type variables that a type family equation is +-- expected to be injective in but is not. Suppose we have @type family +-- F a b = r | r -> a@. Then any variables that appear free in the first +-- argument to F in an equation must be fixed by that equation's RHS. +-- This function returns all such variables that are not indeed fixed. +-- It also returns whether any of these variables appear invisibly +-- and whether -XUndecidableInstances would help. +-- See Note [Coverage condition for injective type families]. +unusedInjTvsInRHS :: DynFlags + -> TyCon -- type family + -> [Type] -- LHS arguments + -> Type -- the RHS + -> ( TyVarSet + , Bool -- True <=> one or more variable is used invisibly + , Bool ) -- True <=> suggest -XUndecidableInstances +-- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. +-- This function implements check (4) described there, further +-- described in Note [Coverage condition for injective type families]. +-- In theory (and modulo the -XUndecidableInstances wrinkle), +-- instead of implementing this whole check in this way, we could +-- attempt to unify equation with itself. We would reject exactly the same +-- equations but this method gives us more precise error messages by returning +-- precise names of variables that are not mentioned in the RHS. +unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs = + -- Note [Coverage condition for injective type families], step 5 + (bad_vars, any_invisible, suggest_undec) + where + undec_inst = xopt LangExt.UndecidableInstances dflags + + inj_lhs = filterByList inj_list lhs + lhs_vars = tyCoVarsOfTypes inj_lhs + + rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs + + bad_vars = lhs_vars `minusVarSet` rhs_inj_vars + + any_bad = not $ isEmptyVarSet bad_vars + + invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs] + + any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars) + suggest_undec = any_bad && + not undec_inst && + (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs)) + +-- When the type family is not injective in any arguments +unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False) + +--------------------------------------- +-- Producing injectivity error messages +--------------------------------------- + +-- | Report error message for a pair of equations violating an injectivity +-- annotation. No error message if there are no branches. +reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () +reportConflictingInjectivityErrs _ [] _ = return () +reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn + = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] + where + herald = text "Type family equation right-hand sides overlap; this violates" $$ + text "the family's injectivity annotation:" + +-- | Injectivity error herald common to all injectivity errors. +injectivityErrorHerald :: SDoc +injectivityErrorHerald = + text "Type family equation violates the family's injectivity annotation." + + +-- | Report error message for equation with injective type variables unused in +-- the RHS. Note [Coverage condition for injective type families], step 6 +reportUnusedInjectiveVarsErr :: TyCon + -> TyVarSet + -> Bool -- True <=> print invisible arguments + -> Bool -- True <=> suggest -XUndecidableInstances + -> CoAxBranch + -> TcM () +reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn + = let (loc, doc) = buildInjectivityError fam_tc + (injectivityErrorHerald $$ + herald $$ + text "In the type family equation:") + (tyfamEqn :| []) + in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) + where + herald = sep [ what <+> text "variable" <> + pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) + , text "cannot be inferred from the right-hand side." ] + $$ extra + + what | has_kinds = text "Type/kind" + | otherwise = text "Type" + + extra | undec_inst = text "Using UndecidableInstances might help" + | otherwise = empty + +-- | Report error message for equation that has a type family call at the top +-- level of RHS +reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () +reportTfHeadedErr fam_tc branch + = addErrs [buildInjectivityError fam_tc + (injectivityErrorHerald $$ + text "RHS of injective type family equation cannot" <+> + text "be a type family:") + (branch :| [])] + +-- | Report error message for equation that has a bare type variable in the RHS +-- but LHS pattern is not a bare type variable. +reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () +reportBareVariableInRHSErr fam_tc tys branch + = addErrs [buildInjectivityError fam_tc + (injectivityErrorHerald $$ + text "RHS of injective type family equation is a bare" <+> + text "type variable" $$ + text "but these LHS type and kind patterns are not bare" <+> + text "variables:" <+> pprQuotedList tys) + (branch :| [])] + +buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc) +buildInjectivityError fam_tc herald (eqn1 :| rest_eqns) + = ( coAxBranchSpan eqn1 + , hang herald + 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) ) + +reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () +reportConflictInstErr _ [] + = return () -- No conflicts +reportConflictInstErr fam_inst (match1 : _) + | FamInstMatch { fim_instance = conf_inst } <- match1 + , let sorted = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst] + fi1 = head sorted + span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + = setSrcSpan span $ addErr $ + hang (text "Conflicting family instance declarations:") + 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) + | fi <- sorted + , let ax = famInstAxiom fi ]) + where + getSpan = getSrcSpan . famInstAxiom + -- The sortBy just arranges that instances are displayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users + +tcGetFamInstEnvs :: TcM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/GHC/Tc/Instance/FunDeps.hs b/GHC/Tc/Instance/FunDeps.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/FunDeps.hs @@ -0,0 +1,682 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 2000 + + +-} + +{-# LANGUAGE CPP #-} + +-- | Functional dependencies +-- +-- It's better to read it as: "if we know these, then we're going to know these" +module GHC.Tc.Instance.FunDeps + ( FunDepEqn(..) + , pprEquation + , improveFromInstEnv + , improveFromAnother + , checkInstCoverage + , checkFunDeps + , pprFundeps + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Var +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Tc.Utils.TcType( transSuperClasses ) +import GHC.Core.Coercion.Axiom( TypeEqn ) +import GHC.Core.Unify +import GHC.Core.InstEnv +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Error( Validity(..), allValid ) +import GHC.Types.SrcLoc +import GHC.Utils.Misc + +import GHC.Data.Pair ( Pair(..) ) +import Data.List ( nubBy ) +import Data.Maybe +import Data.Foldable ( fold ) + +{- +************************************************************************ +* * +\subsection{Generate equations from functional dependencies} +* * +************************************************************************ + + +Each functional dependency with one variable in the RHS is responsible +for generating a single equality. For instance: + class C a b | a -> b +The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha +will generate the following FunDepEqn + FDEqn { fd_qtvs = [] + , fd_eqs = [Pair Bool alpha] + , fd_pred1 = C Int Bool + , fd_pred2 = C Int alpha + , fd_loc = ... } +However notice that a functional dependency may have more than one variable +in the RHS which will create more than one pair of types in fd_eqs. Example: + class C a b c | a -> b c + [Wanted] C Int alpha alpha + [Wanted] C Int Bool beta +Will generate: + FDEqn { fd_qtvs = [] + , fd_eqs = [Pair Bool alpha, Pair alpha beta] + , fd_pred1 = C Int Bool + , fd_pred2 = C Int alpha + , fd_loc = ... } + +INVARIANT: Corresponding types aren't already equal +That is, there exists at least one non-identity equality in FDEqs. + +Assume: + class C a b c | a -> b c + instance C Int x x +And: [Wanted] C Int Bool alpha +We will /match/ the LHS of fundep equations, producing a matching substitution +and create equations for the RHS sides. In our last example we'd have generated: + ({x}, [fd1,fd2]) +where + fd1 = FDEq 1 Bool x + fd2 = FDEq 2 alpha x +To ``execute'' the equation, make fresh type variable for each tyvar in the set, +instantiate the two types with these fresh variables, and then unify or generate +a new constraint. In the above example we would generate a new unification +variable 'beta' for x and produce the following constraints: + [Wanted] (Bool ~ beta) + [Wanted] (alpha ~ beta) + +Notice the subtle difference between the above class declaration and: + class C a b c | a -> b, a -> c +where we would generate: + ({x},[fd1]),({x},[fd2]) +This means that the template variable would be instantiated to different +unification variables when producing the FD constraints. + +Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' +-} + +data FunDepEqn loc + = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars + -- to fresh unification vars, + -- Non-empty only for FunDepEqns arising from instance decls + + , fd_eqs :: [TypeEqn] -- Make these pairs of types equal + , fd_pred1 :: PredType -- The FunDepEqn arose from + , fd_pred2 :: PredType -- combining these two constraints + , fd_loc :: loc } + +{- +Given a bunch of predicates that must hold, such as + + C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 + +improve figures out what extra equations must hold. +For example, if we have + + class C a b | a->b where ... + +then improve will return + + [(t1,t2), (t4,t5)] + +NOTA BENE: + + * improve does not iterate. It's possible that when we make + t1=t2, for example, that will in turn trigger a new equation. + This would happen if we also had + C t1 t7, C t2 t8 + If t1=t2, we also get t7=t8. + + improve does *not* do this extra step. It relies on the caller + doing so. + + * The equations unify types that are not already equal. So there + is no effect iff the result of improve is empty +-} + +instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type +-- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys) +instFD (ls,rs) tvs tys + = (map lookup ls, map lookup rs) + where + env = zipVarEnv tvs tys + lookup tv = lookupVarEnv_NF env tv + +zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true + -> [Type] -> [Type] + -> [TypeEqn] +-- Create a list of (Type,Type) pairs from two lists of types, +-- making sure that the types are not already equal +zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2) + | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 + | otherwise = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2 +zipAndComputeFDEqs _ _ _ = [] + +-- Improve a class constraint from another class constraint +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +improveFromAnother :: loc + -> PredType -- Template item (usually given, or inert) + -> PredType -- Workitem [that can be improved] + -> [FunDepEqn loc] +-- Post: FDEqs always oriented from the other to the workitem +-- Equations have empty quantified variables +improveFromAnother loc pred1 pred2 + | Just (cls1, tys1) <- getClassPredTys_maybe pred1 + , Just (cls2, tys2) <- getClassPredTys_maybe pred2 + , cls1 == cls2 + = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc } + | let (cls_tvs, cls_fds) = classTvsFds cls1 + , fd <- cls_fds + , let (ltys1, rs1) = instFD fd cls_tvs tys1 + (ltys2, rs2) = instFD fd cls_tvs tys2 + , eqTypes ltys1 ltys2 -- The LHSs match + , let eqs = zipAndComputeFDEqs eqType rs1 rs2 + , not (null eqs) ] + +improveFromAnother _ _ _ = [] + + +-- Improve a class constraint from instance declarations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +instance Outputable (FunDepEqn a) where + ppr = pprEquation + +pprEquation :: FunDepEqn a -> SDoc +pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) + = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), + nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 + | Pair t1 t2 <- pairs])] + +improveFromInstEnv :: InstEnvs + -> (PredType -> SrcSpan -> loc) + -> PredType + -> [FunDepEqn loc] -- Needs to be a FunDepEqn because + -- of quantified variables +-- Post: Equations oriented from the template (matching instance) to the workitem! +improveFromInstEnv inst_env mk_loc pred + | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred ) + getClassPredTys_maybe pred + , let (cls_tvs, cls_fds) = classTvsFds cls + instances = classInstances inst_env cls + rough_tcs = roughMatchTcs tys + = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs + , fd_pred1 = p_inst, fd_pred2 = pred + , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) } + | fd <- cls_fds -- Iterate through the fundeps first, + -- because there often are none! + , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs + -- Trim the rough_tcs based on the head of the fundep. + -- Remember that instanceCantMatch treats both arguments + -- symmetrically, so it's ok to trim the rough_tcs, + -- rather than trimming each inst_tcs in turn + , ispec <- instances + , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec + tys trimmed_tcs -- NB: orientation + , let p_inst = mkClassPred cls (is_tys ispec) + ] +improveFromInstEnv _ _ _ = [] + + +improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class + -> ClsInst -- An instance template + -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -> [([TyCoVar], [TypeEqn])] -- Empty or singleton + +improveClsFD clas_tvs fd + (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) + tys_actual rough_tcs_actual + +-- Compare instance {a,b} C sx sp sy sq +-- with wanted [W] C tx tp ty tq +-- for fundep (x,y -> p,q) from class (C x p y q) +-- If (sx,sy) unifies with (tx,ty), take the subst S + +-- 'qtvs' are the quantified type variables, the ones which can be instantiated +-- to make the types match. For example, given +-- class C a b | a->b where ... +-- instance C (Maybe x) (Tree x) where .. +-- +-- and a wanted constraint of form (C (Maybe t1) t2), +-- then we will call checkClsFD with +-- +-- is_qtvs = {x}, is_tys = [Maybe x, Tree x] +-- tys_actual = [Maybe t1, t2] +-- +-- We can instantiate x to t1, and then we want to force +-- (Tree x) [t1/x] ~ t2 + + | instanceCantMatch rough_tcs_inst rough_tcs_actual + = [] -- Filter out ones that can't possibly match, + + | otherwise + = ASSERT2( equalLength tys_inst tys_actual && + equalLength tys_inst clas_tvs + , ppr tys_inst <+> ppr tys_actual ) + + case tcMatchTyKis ltys1 ltys2 of + Nothing -> [] + Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) + -- Don't include any equations that already hold. + -- Reason: then we know if any actual improvement has happened, + -- in which case we need to iterate the solver + -- In making this check we must taking account of the fact that any + -- qtvs that aren't already instantiated can be instantiated to anything + -- at all + -- NB: We can't do this 'is-useful-equation' check element-wise + -- because of: + -- class C a b c | a -> b c + -- instance C Int x x + -- [Wanted] C Int alpha Int + -- We would get that x -> alpha (isJust) and x -> Int (isJust) + -- so we would produce no FDs, which is clearly wrong. + -> [] + + | null fdeqs + -> [] + + | otherwise + -> -- pprTrace "iproveClsFD" (vcat + -- [ text "is_tvs =" <+> ppr qtvs + -- , text "tys_inst =" <+> ppr tys_inst + -- , text "tys_actual =" <+> ppr tys_actual + -- , text "ltys1 =" <+> ppr ltys1 + -- , text "ltys2 =" <+> ppr ltys2 + -- , text "subst =" <+> ppr subst ]) $ + [(meta_tvs, fdeqs)] + -- We could avoid this substTy stuff by producing the eqn + -- (qtvs, ls1++rs1, ls2++rs2) + -- which will re-do the ls1/ls2 unification when the equation is + -- executed. What we're doing instead is recording the partial + -- work of the ls1/ls2 unification leaving a smaller unification problem + where + rtys1' = map (substTyUnchecked subst) rtys1 + + fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 + -- Don't discard anything! + -- We could discard equal types but it's an overkill to call + -- eqType again, since we know for sure that /at least one/ + -- equation in there is useful) + + meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv)) + | tv <- qtvs, tv `notElemTCvSubst` subst ] + -- meta_tvs are the quantified type variables + -- that have not been substituted out + -- + -- Eg. class C a b | a -> b + -- instance C Int [y] + -- Given constraint C Int z + -- we generate the equation + -- ({y}, [y], z) + -- + -- But note (a) we get them from the dfun_id, so they are *in order* + -- because the kind variables may be mentioned in the + -- type variables' kinds + -- (b) we must apply 'subst' to the kinds, in case we have + -- matched out a kind variable, but not a type variable + -- whose kind mentions that kind variable! + -- #6015, #6068 + where + (ltys1, rtys1) = instFD fd clas_tvs tys_inst + (ltys2, rtys2) = instFD fd clas_tvs tys_actual + +{- +%************************************************************************ +%* * + The Coverage condition for instance declarations +* * +************************************************************************ + +Note [Coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Example + class C a b | a -> b + instance theta => C t1 t2 + +For the coverage condition, we check + (normal) fv(t2) `subset` fv(t1) + (liberal) fv(t2) `subset` oclose(fv(t1), theta) + +The liberal version ensures the self-consistency of the instance, but +it does not guarantee termination. Example: + + class Mul a b c | a b -> c where + (.*.) :: a -> b -> c + + instance Mul Int Int Int where (.*.) = (*) + instance Mul Int Float Float where x .*. y = fromIntegral x * y + instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v + +In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). +But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) + +But it is a mistake to accept the instance because then this defn: + f = \ b x y -> if b then x .*. [y] else y +makes instance inference go into a loop, because it requires the constraint + Mul a [b] b +-} + +checkInstCoverage :: Bool -- Be liberal + -> Class -> [PredType] -> [Type] + -> Validity +-- "be_liberal" flag says whether to use "liberal" coverage of +-- See Note [Coverage Condition] below +-- +-- Return values +-- Nothing => no problems +-- Just msg => coverage problem described by msg + +checkInstCoverage be_liberal clas theta inst_taus + = allValid (map fundep_ok fds) + where + (tyvars, fds) = classTvsFds clas + fundep_ok fd + | and (isEmptyVarSet <$> undetermined_tvs) = IsValid + | otherwise = NotValid msg + where + (ls,rs) = instFD fd tyvars inst_taus + ls_tvs = tyCoVarsOfTypes ls + rs_tvs = splitVisVarsOfTypes rs + + undetermined_tvs | be_liberal = liberal_undet_tvs + | otherwise = conserv_undet_tvs + + closed_ls_tvs = oclose theta ls_tvs + liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs + conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs + + undet_set = fold undetermined_tvs + + msg = pprWithExplicitKindsWhen + (isEmptyVarSet $ pSnd undetermined_tvs) $ + vcat [ -- text "ls_tvs" <+> ppr ls_tvs + -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) + -- , text "theta" <+> ppr theta + -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) + -- , text "rs_tvs" <+> ppr rs_tvs + sep [ text "The" + <+> ppWhen be_liberal (text "liberal") + <+> text "coverage condition fails in class" + <+> quotes (ppr clas) + , nest 2 $ text "for functional dependency:" + <+> quotes (pprFunDep fd) ] + , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls + , nest 2 $ + (if isSingleton ls + then text "does not" + else text "do not jointly") + <+> text "determine rhs type"<>plural rs + <+> pprQuotedList rs ] + , text "Un-determined variable" <> pluralVarSet undet_set <> colon + <+> pprVarSet undet_set (pprWithCommas ppr) + , ppWhen (not be_liberal && + and (isEmptyVarSet <$> liberal_undet_tvs)) $ + text "Using UndecidableInstances might help" ] + +{- Note [Closing over kinds in coverage] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a fundep (a::k) -> b +Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, +then fixing x really fixes k2 as well, and so k2 should be added to +the lhs tyvars in the fundep check. + +Example (#8391), using liberal coverage + data Foo a = ... -- Foo :: forall k. k -> * + class Bar a b | a -> b + instance Bar a (Foo a) + + In the instance decl, (a:k) does fix (Foo k a), but only if we notice + that (a:k) fixes k. #10109 is another example. + +Here is a more subtle example, from HList-0.4.0.0 (#10564) + + class HasFieldM (l :: k) r (v :: Maybe *) + | l r -> v where ... + class HasFieldM1 (b :: Maybe [*]) (l :: k) r v + | b l r -> v where ... + class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) + | e1 l -> r + + data Label :: k -> * + type family LabelsOf (a :: [*]) :: * + + instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, + HasFieldM1 b l (r xs) v) + => HasFieldM l (r xs) v where + +Is the instance OK? Does {l,r,xs} determine v? Well: + + * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, + plus the fundep "| el l -> r" in class HMameberM, + we get {l,k,xs} -> b + + * Note the 'k'!! We must call closeOverKinds on the seed set + ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b + fundep won't fire. This was the reason for #10564. + + * So starting from seeds {l,r,xs,k} we do oclose to get + first {l,r,xs,k,b}, via the HMemberM constraint, and then + {l,r,xs,k,b,v}, via the HasFieldM1 constraint. + + * And that fixes v. + +However, we must closeOverKinds whenever augmenting the seed set +in oclose! Consider #10109: + + data Succ a -- Succ :: forall k. k -> * + class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab + instance (Add a b ab) => Add (Succ {k1} (a :: k1)) + b + (Succ {k3} (ab :: k3}) + +We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. +Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to +closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all +the variables free in (Succ {k3} ab). + +Bottom line: + * closeOverKinds on initial seeds (done automatically + by tyCoVarsOfTypes in checkInstCoverage) + * and closeOverKinds whenever extending those seeds (in oclose) + +Note [The liberal coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(oclose preds tvs) closes the set of type variables tvs, +wrt functional dependencies in preds. The result is a superset +of the argument set. For example, if we have + class C a b | a->b where ... +then + oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} +because if we know x and y then that fixes z. + +We also use equality predicates in the predicates; if we have an +assumption `t1 ~ t2`, then we use the fact that if we know `t1` we +also know `t2` and the other way. + eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} + +oclose is used (only) when checking the coverage condition for +an instance declaration + +Note [Equality superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class (a ~ [b]) => C a b + +Remember from Note [The equality types story] in GHC.Builtin.Types.Prim, that + * (a ~~ b) is a superclass of (a ~ b) + * (a ~# b) is a superclass of (a ~~ b) + +So when oclose expands superclasses we'll get a (a ~# [b]) superclass. +But that's an EqPred not a ClassPred, and we jolly well do want to +account for the mutual functional dependencies implied by (t1 ~# t2). +Hence the EqPred handling in oclose. See #10778. + +Note [Care with type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12803) + class C x y | x -> y + type family F a b + type family G c d = r | r -> d + +Now consider + oclose (C (F a b) (G c d)) {a,b} + +Knowing {a,b} fixes (F a b) regardless of the injectivity of F. +But knowing (G c d) fixes only {d}, because G is only injective +in its second parameter. + +Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. +-} + +oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet +-- See Note [The liberal coverage condition] +oclose preds fixed_tvs + | null tv_fds = fixed_tvs -- Fast escape hatch for common case. + | otherwise = fixVarSet extend fixed_tvs + where + extend fixed_tvs = foldl' add fixed_tvs tv_fds + where + add fixed_tvs (ls,rs) + | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs + | otherwise = fixed_tvs + -- closeOverKinds: see Note [Closing over kinds in coverage] + + tv_fds :: [(TyCoVarSet,TyCoVarSet)] + tv_fds = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs) + -- See Note [Care with type functions] + | pred <- preds + , pred' <- pred : transSuperClasses pred + -- Look for fundeps in superclasses too + , (ls, rs) <- determined pred' ] + + determined :: PredType -> [([Type],[Type])] + determined pred + = case classifyPredType pred of + EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] + -- See Note [Equality superclasses] + ClassPred cls tys -> [ instFD fd cls_tvs tys + | let (cls_tvs, cls_fds) = classTvsFds cls + , fd <- cls_fds ] + _ -> [] + + +{- ********************************************************************* +* * + Check that a new instance decl is OK wrt fundeps +* * +************************************************************************ + +Here is the bad case: + class C a b | a->b where ... + instance C Int Bool where ... + instance C Int Char where ... + +The point is that a->b, so Int in the first parameter must uniquely +determine the second. In general, given the same class decl, and given + + instance C s1 s2 where ... + instance C t1 t2 where ... + +Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). + +Matters are a little more complicated if there are free variables in +the s2/t2. + + class D a b c | a -> b + instance D a b => D [(a,a)] [b] Int + instance D a b => D [a] [b] Bool + +The instance decls don't overlap, because the third parameter keeps +them separate. But we want to make sure that given any constraint + D s1 s2 s3 +if s1 matches + +Note [Bogus consistency check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In checkFunDeps we check that a new ClsInst is consistent with all the +ClsInsts in the environment. + +The bogus aspect is discussed in #10675. Currently it if the two +types are *contradicatory*, using (isNothing . tcUnifyTys). But all +the papers say we should check if the two types are *equal* thus + not (substTys subst rtys1 `eqTypes` substTys subst rtys2) +For now I'm leaving the bogus form because that's the way it has +been for years. +-} + +checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] +-- The Consistency Check. +-- Check whether adding DFunId would break functional-dependency constraints +-- Used only for instance decls defined in the module being compiled +-- Returns a list of the ClsInst in InstEnvs that are inconsistent +-- with the proposed new ClsInst +checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls + , is_tys = tys1, is_tcs = rough_tcs1 }) + | null fds + = [] + | otherwise + = nubBy eq_inst $ + [ ispec | ispec <- cls_insts + , fd <- fds + , is_inconsistent fd ispec ] + where + cls_insts = classInstances inst_envs cls + (cls_tvs, fds) = classTvsFds cls + qtv_set1 = mkVarSet qtvs1 + + is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) + | instanceCantMatch trimmed_tcs rough_tcs2 + = False + | otherwise + = case tcUnifyTyKis bind_fn ltys1 ltys2 of + Nothing -> False + Just subst + -> isNothing $ -- Bogus legacy test (#10675) + -- See Note [Bogus consistency check] + tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) + + where + trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 + (ltys1, rtys1) = instFD fd cls_tvs tys1 + (ltys2, rtys2) = instFD fd cls_tvs tys2 + qtv_set2 = mkVarSet qtvs2 + bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe + | tv `elemVarSet` qtv_set2 = BindMe + | otherwise = Skolem + + eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 + -- A single instance may appear twice in the un-nubbed conflict list + -- because it may conflict with more than one fundep. E.g. + -- class C a b c | a -> b, a -> c + -- instance C Int Bool Bool + -- instance C Int Char Char + -- The second instance conflicts with the first by *both* fundeps + +trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] +-- Computing rough_tcs for a particular fundep +-- class C a b c | a -> b where ... +-- For each instance .... => C ta tb tc +-- we want to match only on the type ta; so our +-- rough-match thing must similarly be filtered. +-- Hence, we Nothing-ise the tb and tc types right here +-- +-- Result list is same length as input list, just with more Nothings +trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs + = zipWith select clas_tvs mb_tcs + where + select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc + | otherwise = Nothing diff --git a/GHC/Tc/Instance/Typeable.hs b/GHC/Tc/Instance/Typeable.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Instance/Typeable.hs @@ -0,0 +1,762 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) +import GHC.Iface.Env( newGlobalBinder ) +import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence ( mkWpTyApps ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Driver.Types ( lookupId ) +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim ( primTyCons ) +import GHC.Builtin.Types + ( tupleTyCon, sumTyCon, runtimeRepTyCon + , vecCountTyCon, vecElemTyCon + , nilDataCon, consDataCon ) +import GHC.Types.Name +import GHC.Types.Id +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Unit.Module +import GHC.Hs +import GHC.Driver.Session +import GHC.Data.Bag +import GHC.Types.Var ( VarBndr(..) ) +import GHC.Core.Map +import GHC.Settings.Constants +import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) +import GHC.Utils.Outputable +import GHC.Data.FastString ( FastString, mkFastString, fsLit ) + +import Control.Monad.Trans.State +import Control.Monad.Trans.Class (lift) +import Data.Maybe ( isJust ) +import Data.Word( Word64 ) + +{- Note [Grand plan for Typeable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The overall plan is this: + +1. Generate a binding for each module p:M + (done in GHC.Tc.Instance.Typeable by mkModIdBindings) + M.$trModule :: GHC.Unit.Module + M.$trModule = Module "p" "M" + ("tr" is short for "type representation"; see GHC.Types) + + We might want to add the filename too. + This can be used for the lightweight stack-tracing stuff too + + Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv + +2. Generate a binding for every data type declaration T in module M, + M.$tcT :: GHC.Types.TyCon + M.$tcT = TyCon ...fingerprint info... + $trModule + "T" + 0# + kind_rep + + Here 0# is the number of arguments expected by the tycon to fully determine + its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a + recipe for computing the kind of an instantiation of the tycon (see + Note [Representing TyCon kinds: KindRep] later in this file for details). + + We define (in GHC.Core.TyCon) + + type TyConRepName = Name + + to use for these M.$tcT "tycon rep names". Note that these must be + treated as "never exported" names by Backpack (see + Note [Handling never-exported TyThings under Backpack]). Consequently + they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl. + +3. Record the TyConRepName in T's TyCon, including for promoted + data and type constructors, and kinds like * and #. + + The TyConRepName is not an "implicit Id". It's more like a record + selector: the TyCon knows its name but you have to go to the + interface file to find its type, value, etc + +4. Solve Typeable constraints. This is done by a custom Typeable solver, + currently in GHC.Tc.Solver.Interact, that use M.$tcT so solve (Typeable T). + +There are many wrinkles: + +* The timing of when we produce this bindings is rather important: they must be + defined after the rest of the module has been typechecked since we need to be + able to lookup Module and TyCon in the type environment and we may be + currently compiling GHC.Types (where they are defined). + +* GHC.Prim doesn't have any associated object code, so we need to put the + representations for types defined in this module elsewhere. We chose this + place to be GHC.Types. GHC.Tc.Instance.Typeable.mkPrimTypeableBinds is responsible for + injecting the bindings for the GHC.Prim representions when compiling + GHC.Types. + +* TyCon.tyConRepModOcc is responsible for determining where to find + the representation binding for a given type. This is where we handle + the special case for GHC.Prim. + +* To save space and reduce dependencies, we need use quite low-level + representations for TyCon and Module. See GHC.Types + Note [Runtime representation of modules and tycons] + +* The KindReps can unfortunately get quite large. Moreover, the simplifier will + float out various pieces of them, resulting in numerous top-level bindings. + Consequently we mark the KindRep bindings as noinline, ensuring that the + float-outs don't make it into the interface file. This is important since + there is generally little benefit to inlining KindReps and they would + otherwise strongly affect compiler performance. + +* In general there are lots of things of kind *, * -> *, and * -> * -> *. To + reduce the number of bindings we need to produce, we generate their KindReps + once in GHC.Types. These are referred to as "built-in" KindReps below. + +* Even though KindReps aren't inlined, this scheme still has more of an effect on + compilation time than I'd like. This is especially true in the case of + families of type constructors (e.g. tuples and unboxed sums). The problem is + particularly bad in the case of sums, since each arity-N tycon brings with it + N promoted datacons, each with a KindRep whose size also scales with N. + Consequently we currently simply don't allow sums to be Typeable. + + In general we might consider moving some or all of this generation logic back + to the solver since the performance hit we take in doing this at + type-definition time is non-trivial and Typeable isn't very widely used. This + is discussed in #13261. + +-} + +-- | Generate the Typeable bindings for a module. This is the only +-- entry-point of this module and is invoked by the typechecker driver in +-- 'tcRnSrcDecls'. +-- +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +mkTypeableBinds :: TcM TcGblEnv +mkTypeableBinds + = do { dflags <- getDynFlags + ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do + { -- Create a binding for $trModule. + -- Do this before processing any data type declarations, + -- which need tcg_tr_module to be initialised + ; tcg_env <- mkModIdBindings + -- Now we can generate the TyCon representations... + -- First we handle the primitive TyCons if we are compiling GHC.Types + ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos + + -- Then we produce bindings for the user-defined types in this module. + ; setGblEnv tcg_env $ + do { mod <- getModule + ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) + mod_id = case tcg_tr_module tcg_env of -- Should be set by now + Just mod_id -> mod_id + Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) + ; traceTc "mkTypeableBinds" (ppr tycons) + ; this_mod_todos <- todoForTyCons mod mod_id tycons + ; mkTypeRepTodoBinds (this_mod_todos : prim_todos) + } } } + where + needs_typeable_binds tc + | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] + = False + | otherwise = + isAlgTyCon tc + || isDataFamilyTyCon tc + || isClassTyCon tc + + +{- ********************************************************************* +* * + Building top-level binding for $trModule +* * +********************************************************************* -} + +mkModIdBindings :: TcM TcGblEnv +mkModIdBindings + = do { mod <- getModule + ; loc <- getSrcSpanM + ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc + ; trModuleTyCon <- tcLookupTyCon trModuleTyConName + ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) + ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod + + ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv + ; return (tcg_env { tcg_tr_module = Just mod_id } + `addTypecheckedBinds` [unitBag mod_bind]) } + +mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) +mkModIdRHS mod + = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName + ; trNameLit <- mkTrNameLit + ; return $ nlHsDataCon trModuleDataCon + `nlHsApp` trNameLit (unitFS (moduleUnit mod)) + `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) + } + +{- ********************************************************************* +* * + Building type-representation bindings +* * +********************************************************************* -} + +-- | Information we need about a 'TyCon' to generate its representation. We +-- carry the 'Id' in order to share it between the generation of the @TyCon@ and +-- @KindRep@ bindings. +data TypeableTyCon + = TypeableTyCon + { tycon :: !TyCon + , tycon_rep_id :: !Id + } + +-- | A group of 'TyCon's in need of type-rep bindings. +data TypeRepTodo + = TypeRepTodo + { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding + , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint + , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint + , todo_tycons :: [TypeableTyCon] + -- ^ The 'TyCon's in need of bindings kinds + } + | ExportedKindRepsTodo [(Kind, Id)] + -- ^ Build exported 'KindRep' bindings for the given set of kinds. + +todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo +todoForTyCons mod mod_id tycons = do + trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName + let mk_rep_id :: TyConRepName -> Id + mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy + + let typeable_tycons :: [TypeableTyCon] + typeable_tycons = + [ TypeableTyCon { tycon = tc'' + , tycon_rep_id = mk_rep_id rep_name + } + | tc <- tycons + , tc' <- tc : tyConATs tc + -- We need type representations for any associated types + , let promoted = map promoteDataCon (tyConDataCons tc') + , tc'' <- tc' : promoted + -- Don't make bindings for data-family instance tycons. + -- Do, however, make them for their promoted datacon (see #13915). + , not $ isFamInstTyCon tc'' + , Just rep_name <- pure $ tyConRepName_maybe tc'' + , tyConIsTypeable tc'' + ] + return TypeRepTodo { mod_rep_expr = nlHsVar mod_id + , pkg_fingerprint = pkg_fpr + , mod_fingerprint = mod_fpr + , todo_tycons = typeable_tycons + } + where + mod_fpr = fingerprintString $ moduleNameString $ moduleName mod + pkg_fpr = fingerprintString $ unitString $ moduleUnit mod + +todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo +todoForExportedKindReps kinds = do + trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName + let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) + return $ ExportedKindRepsTodo $ map mkId kinds + +-- | Generate TyCon bindings for a set of type constructors +mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv +mkTypeRepTodoBinds [] = getGblEnv +mkTypeRepTodoBinds todos + = do { stuff <- collect_stuff + + -- First extend the type environment with all of the bindings + -- which we are going to produce since we may need to refer to them + -- while generating kind representations (namely, when we want to + -- represent a TyConApp in a kind, we must be able to look up the + -- TyCon associated with the applied type constructor). + ; let produced_bndrs :: [Id] + produced_bndrs = [ tycon_rep_id + | todo@(TypeRepTodo{}) <- todos + , TypeableTyCon {..} <- todo_tycons todo + ] ++ + [ rep_id + | ExportedKindRepsTodo kinds <- todos + , (_, rep_id) <- kinds + ] + ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv + + ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] + mk_binds todo@(TypeRepTodo {}) = + mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) + mk_binds (ExportedKindRepsTodo kinds) = + mkExportedKindReps stuff kinds >> return [] + + ; (gbl_env, binds) <- setGblEnv gbl_env + $ runKindRepM (mapM mk_binds todos) + ; return $ gbl_env `addTypecheckedBinds` concat binds } + +-- | Generate bindings for the type representation of a wired-in 'TyCon's +-- defined by the virtual "GHC.Prim" module. This is where we inject the +-- representation bindings for these primitive types into "GHC.Types" +-- +-- See Note [Grand plan for Typeable] in this module. +mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) +mkPrimTypeableTodos + = do { mod <- getModule + ; if mod == gHC_TYPES + then do { -- Build Module binding for GHC.Prim + trModuleTyCon <- tcLookupTyCon trModuleTyConName + ; let ghc_prim_module_id = + mkExportedVanillaId trGhcPrimModuleName + (mkTyConTy trModuleTyCon) + + ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id + <$> mkModIdRHS gHC_PRIM + + -- Extend our environment with above + ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] + getGblEnv + ; let gbl_env' = gbl_env `addTypecheckedBinds` + [unitBag ghc_prim_module_bind] + + -- Build TypeRepTodos for built-in KindReps + ; todo1 <- todoForExportedKindReps builtInKindReps + -- Build TypeRepTodos for types in GHC.Prim + ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id + ghcPrimTypeableTyCons + ; return ( gbl_env' , [todo1, todo2]) + } + else do gbl_env <- getGblEnv + return (gbl_env, []) + } + +-- | This is the list of primitive 'TyCon's for which we must generate bindings +-- in "GHC.Types". This should include all types defined in "GHC.Prim". +-- +-- The majority of the types we need here are contained in 'primTyCons'. +-- However, not all of them: in particular unboxed tuples are absent since we +-- don't want to include them in the original name cache. See +-- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. +ghcPrimTypeableTyCons :: [TyCon] +ghcPrimTypeableTyCons = concat + [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ] + , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] + , map sumTyCon [2..mAX_SUM_SIZE] + , primTyCons + ] + +data TypeableStuff + = Stuff { platform :: Platform -- ^ Target platform + , trTyConDataCon :: DataCon -- ^ of @TyCon@ + , trNameLit :: FastString -> LHsExpr GhcTc + -- ^ To construct @TrName@s + -- The various TyCon and DataCons of KindRep + , kindRepTyCon :: TyCon + , kindRepTyConAppDataCon :: DataCon + , kindRepVarDataCon :: DataCon + , kindRepAppDataCon :: DataCon + , kindRepFunDataCon :: DataCon + , kindRepTYPEDataCon :: DataCon + , kindRepTypeLitSDataCon :: DataCon + , typeLitSymbolDataCon :: DataCon + , typeLitNatDataCon :: DataCon + } + +-- | Collect various tidbits which we'll need to generate TyCon representations. +collect_stuff :: TcM TypeableStuff +collect_stuff = do + platform <- targetPlatform <$> getDynFlags + trTyConDataCon <- tcLookupDataCon trTyConDataConName + kindRepTyCon <- tcLookupTyCon kindRepTyConName + kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName + kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName + kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName + kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName + kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName + kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName + typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName + typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName + trNameLit <- mkTrNameLit + return Stuff {..} + +-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we +-- can save the work of repeating lookups when constructing many TyCon +-- representations. +mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) +mkTrNameLit = do + trNameSDataCon <- tcLookupDataCon trNameSDataConName + let trNameLit :: FastString -> LHsExpr GhcTc + trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit fs) + return trNameLit + +-- | Make Typeable bindings for the given 'TyCon'. +mkTyConRepBinds :: TypeableStuff -> TypeRepTodo + -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) +mkTyConRepBinds stuff todo (TypeableTyCon {..}) + = do -- Make a KindRep + let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon) + liftTc $ traceTc "mkTyConKindRepBinds" + (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) + let ctx = mkDeBruijnContext (map binderVar bndrs) + kind_rep <- getKindRep stuff ctx kind + + -- Make the TyCon binding + let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep + tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs + return $ unitBag tycon_rep_bind + +-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type +-- families and polytypes. +tyConIsTypeable :: TyCon -> Bool +tyConIsTypeable tc = + isJust (tyConRepName_maybe tc) + && kindIsTypeable (dropForAlls $ tyConKind tc) + +-- | Is a particular 'Kind' representable by @Typeable@? Here we look for +-- polytypes and types containing casts (which may be, for instance, a type +-- family). +kindIsTypeable :: Kind -> Bool +-- We handle types of the form (TYPE LiftedRep) specifically to avoid +-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) +-- to be typeable without inspecting rr, but this exhibits bad behavior +-- when rr is a type family. +kindIsTypeable ty + | Just ty' <- coreView ty = kindIsTypeable ty' +kindIsTypeable ty + | isLiftedTypeKind ty = True +kindIsTypeable (TyVarTy _) = True +kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b +kindIsTypeable (FunTy _ w a b) = kindIsTypeable w && + kindIsTypeable a && + kindIsTypeable b +kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc + && all kindIsTypeable args +kindIsTypeable (ForAllTy{}) = False +kindIsTypeable (LitTy _) = True +kindIsTypeable (CastTy{}) = False + -- See Note [Typeable instances for casted types] +kindIsTypeable (CoercionTy{}) = False + +-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in +-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') +-- or a binding which we generated in the current module (in which case it will +-- be 'Just' the RHS of the binding). +type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc)) + +-- | A monad within which we will generate 'KindRep's. Here we keep an +-- environment containing 'KindRep's which we've already generated so we can +-- re-use them opportunistically. +newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } + deriving (Functor, Applicative, Monad) + +liftTc :: TcRn a -> KindRepM a +liftTc = KindRepM . lift + +-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they +-- can be reused across modules. +builtInKindReps :: [(Kind, Name)] +builtInKindReps = + [ (star, starKindRepName) + , (mkVisFunTyMany star star, starArrStarKindRepName) + , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName) + ] + where + star = liftedTypeKind + +initialKindRepEnv :: TcRn KindRepEnv +initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps + where + add_kind_rep acc (k,n) = do + id <- tcLookupId n + return $! extendTypeMap acc k (id, Nothing) + +-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. +mkExportedKindReps :: TypeableStuff + -> [(Kind, Id)] -- ^ the kinds to generate bindings for + -> KindRepM () +mkExportedKindReps stuff = mapM_ kindrep_binding + where + empty_scope = mkDeBruijnContext [] + + kindrep_binding :: (Kind, Id) -> KindRepM () + kindrep_binding (kind, rep_bndr) = do + -- We build the binding manually here instead of using mkKindRepRhs + -- since the latter would find the built-in 'KindRep's in the + -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). + rhs <- mkKindRepRhs stuff empty_scope kind + addKindRepBind empty_scope kind rep_bndr rhs + +addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () +addKindRepBind in_scope k bndr rhs = + KindRepM $ modify' $ + \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) + +-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking +-- environment. +runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a) +runKindRepM (KindRepM action) = do + kindRepEnv <- initialKindRepEnv + (res, reps_env) <- runStateT action kindRepEnv + let rep_binds = foldTypeMap to_bind_pair [] reps_env + to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest + to_bind_pair (_, Nothing) rest = rest + tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv + let binds = map (uncurry mkVarBind) rep_binds + tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds] + return (tcg_env', res) + +-- | Produce or find a 'KindRep' for the given kind. +getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables + -> Kind -- ^ the kind we want a 'KindRep' for + -> KindRepM (LHsExpr GhcTc) +getKindRep stuff@(Stuff {..}) in_scope = go + where + go :: Kind -> KindRepM (LHsExpr GhcTc) + go = KindRepM . StateT . go' + + go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) + go' k env + -- Look through type synonyms + | Just k' <- tcView k = go' k' env + + -- We've already generated the needed KindRep + | Just (id, _) <- lookupTypeMapWithScope env in_scope k + = return (nlHsVar id, env) + + -- We need to construct a new KindRep binding + | otherwise + = do -- Place a NOINLINE pragma on KindReps since they tend to be quite + -- large and bloat interface files. + rep_bndr <- (`setInlinePragma` neverInlinePragma) + <$> newSysLocalId (fsLit "$krep") Many (mkTyConTy kindRepTyCon) + + -- do we need to tie a knot here? + flip runStateT env $ unKindRepM $ do + rhs <- mkKindRepRhs stuff in_scope k + addKindRepBind in_scope k rep_bndr rhs + return $ nlHsVar rep_bndr + +-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and +-- in-scope kind variable set. +mkKindRepRhs :: TypeableStuff + -> CmEnv -- ^ in-scope kind variables + -> Kind -- ^ the kind we want a 'KindRep' for + -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression +mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep + where + new_kind_rep k + -- We handle (TYPE LiftedRep) etc separately to make it + -- clear to consumers (e.g. serializers) that there is + -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) + | not (tcIsConstraintKind k) + -- Typeable respects the Constraint/Type distinction + -- so do not follow the special case here + , Just arg <- kindRep_maybe k + , Just (tc, []) <- splitTyConApp_maybe arg + , Just dc <- isPromotedDataCon_maybe tc + = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc + + new_kind_rep (TyVarTy v) + | Just idx <- lookupCME in_scope v + = return $ nlHsDataCon kindRepVarDataCon + `nlHsApp` nlHsIntLit (fromIntegral idx) + | otherwise + = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v) + + new_kind_rep (AppTy t1 t2) + = do rep1 <- getKindRep stuff in_scope t1 + rep2 <- getKindRep stuff in_scope t2 + return $ nlHsDataCon kindRepAppDataCon + `nlHsApp` rep1 `nlHsApp` rep2 + + new_kind_rep k@(TyConApp tc tys) + | Just rep_name <- tyConRepName_maybe tc + = do rep_id <- liftTc $ lookupId rep_name + tys' <- mapM (getKindRep stuff in_scope) tys + return $ nlHsDataCon kindRepTyConAppDataCon + `nlHsApp` nlHsVar rep_id + `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' + | otherwise + = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) + + new_kind_rep (ForAllTy (Bndr var _) ty) + = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) + + new_kind_rep (FunTy _ _ t1 t2) + = do rep1 <- getKindRep stuff in_scope t1 + rep2 <- getKindRep stuff in_scope t2 + return $ nlHsDataCon kindRepFunDataCon + `nlHsApp` rep1 `nlHsApp` rep2 + + new_kind_rep (LitTy (NumTyLit n)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitNatDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) + + new_kind_rep (LitTy (StrTyLit s)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitSymbolDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) + + -- See Note [Typeable instances for casted types] + new_kind_rep (CastTy ty co) + = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) + + new_kind_rep (CoercionTy co) + = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) + +-- | Produce the right-hand-side of a @TyCon@ representation. +mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo + -> TyCon -- ^ the 'TyCon' we are producing a binding for + -> LHsExpr GhcTc -- ^ its 'KindRep' + -> LHsExpr GhcTc +mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep + = nlHsDataCon trTyConDataCon + `nlHsApp` nlHsLit (word64 platform high) + `nlHsApp` nlHsLit (word64 platform low) + `nlHsApp` mod_rep_expr todo + `nlHsApp` trNameLit (mkFastString tycon_str) + `nlHsApp` nlHsLit (int n_kind_vars) + `nlHsApp` kind_rep + where + n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) + tycon_str = add_tick (occNameString (getOccName tycon)) + add_tick s | isPromotedDataCon tycon = '\'' : s + | otherwise = s + + -- This must match the computation done in + -- Data.Typeable.Internal.mkTyConFingerprint. + Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo + , mod_fingerprint todo + , fingerprintString tycon_str + ] + + int :: Int -> HsLit GhcTc + int n = HsIntPrim (SourceText $ show n) (toInteger n) + +word64 :: Platform -> Word64 -> HsLit GhcTc +word64 platform n = case platformWordSize platform of + PW4 -> HsWord64Prim NoSourceText (toInteger n) + PW8 -> HsWordPrim NoSourceText (toInteger n) + +{- +Note [Representing TyCon kinds: KindRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One of the operations supported by Typeable is typeRepKind, + + typeRepKind :: TypeRep (a :: k) -> TypeRep k + +Implementing this is a bit tricky for poly-kinded types like + + data Proxy (a :: k) :: Type + -- Proxy :: forall k. k -> Type + +The TypeRep encoding of `Proxy Type Int` looks like this: + + $tcProxy :: GHC.Types.TyCon + $trInt :: TypeRep Int + TrType :: TypeRep Type + + $trProxyType :: TypeRep (Proxy Type :: Type -> Type) + $trProxyType = TrTyCon $tcProxy + [TrType] -- kind variable instantiation + (tyConKind $tcProxy [TrType]) -- The TypeRep of + -- Type -> Type + + $trProxy :: TypeRep (Proxy Type Int) + $trProxy = TrApp $trProxyType $trInt TrType + + $tkProxy :: GHC.Types.KindRep + $tkProxy = KindRepFun (KindRepVar 0) + (KindRepTyConApp (KindRepTYPE LiftedRep) []) + +Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent +polymorphic types. So instead + + * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations) + of all its kind arguments. We can't represent a tycon that is + applied to only some of its kind arguments. + + * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a + GHC.Types.KindRep, which represents the polymorphic kind of Proxy + Proxy :: forall k. k->Type + + * A KindRep is just a recipe that we can instantiate with the + argument kinds, using Data.Typeable.Internal.tyConKind and + store in the relevant 'TypeRep' constructor. + + Data.Typeable.Internal.typeRepKind looks up the stored kinds. + + * In a KindRep, the kind variables are represented by 0-indexed + de Bruijn numbers: + + type KindBndr = Int -- de Bruijn index + + data KindRep = KindRepTyConApp TyCon [KindRep] + | KindRepVar !KindBndr + | KindRepApp KindRep KindRep + | KindRepFun KindRep KindRep + ... + +Note [Typeable instances for casted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At present, GHC does not manufacture TypeReps for types containing casts +(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow. + +In today's GHC, we normalize all types before computing their TypeRep. +For example: + + type family F a + type instance F Int = Type + + data D = forall (a :: F Int). MkD a + + tr :: TypeRep (MkD Bool) + tr = typeRep + +When computing the TypeRep for `MkD Bool` (or rather, +`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the +TypeRep for `MkD Bool`. + +Why does this work? If we have a type definition with casts, then the +only coercions that those casts can mention are either Refl, type family +axioms, built-in axioms, and coercions built from those roots. Therefore, +type family (and built-in) axioms will apply precisely when type normalization +succeeds (i.e, the type family applications are reducible). Therefore, it +is safe to ignore the cast entirely when constructing the TypeRep. + +This approach would be fragile in a future where GHC permits other forms of +coercions to appear in casts (e.g., coercion quantification as described +in #15710). If GHC permits local assumptions to appear in casts that cannot be +reduced with conventional normalization, then discarding casts would become +unsafe. It would be unfortunate for the Typeable solver to become a roadblock +obstructing such a future, so we deliberately do not implement the ability +for TypeReps to represent types with casts at the moment. + +If we do wish to allow this in the future, it will likely require modeling +casts and coercions in TypeReps themselves. +-} + +mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc +mkList ty = foldr consApp (nilExpr ty) + where + cons = consExpr ty + consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc + consApp x xs = cons `nlHsApp` x `nlHsApp` xs + + nilExpr :: Type -> LHsExpr GhcTc + nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) + + consExpr :: Type -> LHsExpr GhcTc + consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/GHC/Tc/Module.hs b/GHC/Tc/Module.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Module.hs @@ -0,0 +1,3122 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking a whole module +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker +module GHC.Tc.Module ( + tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, + isGHCiMonad, + runTcInteractive, -- Used by GHC API clients (#8878) + tcRnLookupName, + tcRnGetInfo, + tcRnModule, tcRnModuleTcRnM, + tcTopSrcDecls, + rnTopSrcDecls, + checkBootDecl, checkHiBootIface', + findExtraSigImports, + implicitRequirements, + checkUnit, + mergeSignatures, + tcRnMergeSignatures, + instantiateSignature, + tcRnInstantiateSignature, + loadUnqualIfaces, + -- More private... + badReexportedBootThing, + checkBootDeclM, + missingBootThing, + getRenamedStuff, RenamedStuff + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) +import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) +import GHC.Iface.Env ( externaliseName ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Validity( checkValidType ) +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) +import GHC.Rename.HsType +import GHC.Rename.Expr +import GHC.Rename.Utils ( HsDocContext(..) ) +import GHC.Rename.Fixity ( lookupFixityRn ) +import GHC.Builtin.Types ( unitTy, mkListTy ) +import GHC.Driver.Plugins +import GHC.Driver.Session +import GHC.Hs +import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) +import GHC.Iface.Type ( ShowForAllFlag(..) ) +import GHC.Core.PatSyn ( pprPatSynType ) +import GHC.Core.Predicate ( classMethodTy ) +import GHC.Builtin.Names +import GHC.Builtin.Utils +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Zonk +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Export +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import qualified GHC.Data.BooleanFormula as BF +import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) +import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Tc.Instance.Family +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + ( FamInst, pprFamInst, famInstsRepTyCons + , famInstEnvElts, extendFamInstEnvList, normaliseType ) +import GHC.Tc.Gen.Annotation +import GHC.Tc.Gen.Bind +import GHC.Iface.Make ( coAxiomToIfaceDecl ) +import GHC.Parser.Header ( mkPrelImports ) +import GHC.Tc.Gen.Default +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Rule +import GHC.Tc.Gen.Foreign +import GHC.Tc.TyCl.Instance +import GHC.IfaceToCore +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.TyCl +import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) +import GHC.Tc.Utils.Backpack +import GHC.Iface.Load +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Module +import GHC.Utils.Error +import GHC.Types.Id as Id +import GHC.Types.Id.Info( IdDetails(..) ) +import GHC.Types.Var.Env +import GHC.Unit.Module +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Core.TyCon +import GHC.Types.SrcLoc +import GHC.Driver.Types +import GHC.Data.List.SetOps +import GHC.Utils.Outputable as Outputable +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Class +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Core.Coercion.Axiom +import GHC.Types.Annotations +import Data.List ( sortBy, sort ) +import Data.Ord +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Tc.Utils.Instantiate (tcGetInsts) +import qualified GHC.LanguageExtensions as LangExt +import Data.Data ( Data ) +import GHC.Hs.Dump +import qualified Data.Set as S + +import Control.DeepSeq +import Control.Monad + +import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) + + +#include "HsVersions.h" + +{- +************************************************************************ +* * + Typecheck and rename a module +* * +************************************************************************ +-} + +-- | Top level entry point for typechecker and renamer +tcRnModule :: HscEnv + -> ModSummary + -> Bool -- True <=> save renamed syntax + -> HsParsedModule + -> IO (Messages, Maybe TcGblEnv) + +tcRnModule hsc_env mod_sum save_rn_syntax + parsedModule@HsParsedModule {hpm_module= L loc this_module} + | RealSrcSpan real_loc _ <- loc + = withTiming dflags + (text "Renamer/typechecker"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ + withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ + + tcRnModuleTcRnM hsc_env mod_sum parsedModule pair + + | otherwise + = return ((emptyBag, unitBag err_msg), Nothing) + + where + hsc_src = ms_hsc_src mod_sum + dflags = hsc_dflags hsc_env + err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ + text "Module does not have a RealSrcSpan:" <+> ppr this_mod + + this_pkg = homeUnit (hsc_dflags hsc_env) + + pair :: (Module, SrcSpan) + pair@(this_mod,_) + | Just (L mod_loc mod) <- hsmodName this_module + = (mkModule this_pkg mod, mod_loc) + + | otherwise -- 'module M where' is omitted + = (mAIN, srcLocSpan (srcSpanStart loc)) + + + + +tcRnModuleTcRnM :: HscEnv + -> ModSummary + -> HsParsedModule + -> (Module, SrcSpan) + -> TcRn TcGblEnv +-- Factored out separately from tcRnModule so that a Core plugin can +-- call the type checker directly +tcRnModuleTcRnM hsc_env mod_sum + (HsParsedModule { + hpm_module = + (L loc (HsModule _ maybe_mod export_ies + import_decls local_decls mod_deprec + maybe_doc_hdr)), + hpm_src_files = src_files + }) + (this_mod, prel_imp_loc) + = setSrcSpan loc $ + do { let { explicit_mod_hdr = isJust maybe_mod + ; hsc_src = ms_hsc_src mod_sum } + ; -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + tcg_env <- getGblEnv + ; boot_info <- tcHiBootIface hsc_src this_mod + ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) + $ do + { -- Deal with imports; first add implicit prelude + implicit_prelude <- xoptM LangExt.ImplicitPrelude + ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc + implicit_prelude import_decls } + + ; whenWOptM Opt_WarnImplicitPrelude $ + when (notNull prel_imports) $ + addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) + + ; -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (L _ idecl) = + ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) + } + ; raw_sig_imports <- liftIO + $ findExtraSigImports hsc_env hsc_src + (moduleName this_mod) + ; raw_req_imports <- liftIO + $ implicitRequirements hsc_env + (map simplifyImport (prel_imports + ++ import_decls)) + ; let { mkImport (Nothing, L _ mod_name) = noLoc + $ (simpleImportDecl mod_name) + { ideclHiding = Just (False, noLoc [])} + ; mkImport _ = panic "mkImport" } + ; let { all_imports = prel_imports ++ import_decls + ++ map mkImport (raw_sig_imports ++ raw_req_imports) } + ; -- OK now finally rename the imports + tcg_env <- {-# SCC "tcRnImports" #-} + tcRnImports hsc_env all_imports + + ; -- If the whole module is warned about or deprecated + -- (via mod_deprec) record that in tcg_warns. If we do thereby add + -- a WarnAll, it will override any subsequent deprecations added to tcg_warns + let { tcg_env1 = case mod_deprec of + Just (L _ txt) -> + tcg_env {tcg_warns = WarnAll txt} + Nothing -> tcg_env + } + ; setGblEnv tcg_env1 + $ do { -- Rename and type check the declarations + traceRn "rn1a" empty + ; tcg_env <- if isHsBootOrSig hsc_src + then do { + ; tcg_env <- tcRnHsBootDecls hsc_src local_decls + ; traceRn "rn4a: before exports" empty + ; tcg_env <- setGblEnv tcg_env $ + rnExports explicit_mod_hdr export_ies + ; traceRn "rn4b: after exports" empty + ; return tcg_env + } + else {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls explicit_mod_hdr export_ies local_decls + + ; whenM (goptM Opt_DoCoreLinting) $ + do { let (warns, errs) = lintGblEnv (hsc_dflags hsc_env) tcg_env + ; mapBagM_ (addWarn NoReason) warns + ; mapBagM_ addErr errs + ; failIfErrsM } -- if we have a lint error, we're only + -- going to get in deeper trouble by proceeding + + ; setGblEnv tcg_env + $ do { -- Compare hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_info + ; -- The new type env is already available to stuff + -- slurped from interface files, via + -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this + -- includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for + -- boot_dfuns, which may be mentioned in imported + -- unfoldings. + + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env + { tcg_doc_hdr = maybe_doc_hdr }) + ; -- Report unused names + -- Do this /after/ typeinference, so that when reporting + -- a function with no type signature we can give the + -- inferred type + reportUnusedNames tcg_env hsc_src + ; -- add extra source files to tcg_dependent_files + addDependentFiles src_files + -- Ensure plugins run with the same tcg_env that we pass in + ; setGblEnv tcg_env + $ do { tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env + ; -- Dump output and return + tcDump tcg_env + ; return tcg_env + } + } + } + } + } + +implicitPreludeWarn :: SDoc +implicitPreludeWarn + = text "Module `Prelude' implicitly imported" + +{- +************************************************************************ +* * + Import declarations +* * +************************************************************************ +-} + +tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv +tcRnImports hsc_env import_decls + = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; + + ; this_mod <- getModule + ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot + ; dep_mods = imp_dep_mods imports + + -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file. This + -- filtering also ensures that we don't see instances from + -- modules batch (@--make@) compiled before this one, but + -- which are not below this one. + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; (home_insts, home_fam_insts) = hptInstances hsc_env + want_instances + } ; + + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { + tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = rn_imports, + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ do { + + ; traceRn "rn1" (ppr (imp_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module (including orphan family + -- instance-module) interfaces, so that their rules and + -- instance decls will be found. But filter out a + -- self hs-boot: these instances will be checked when + -- we define them locally. + -- (We don't need to load non-orphan family instance + -- modules until we either try to use the instances they + -- define, or define our own family instances, at which + -- point we need to check them for consistency.) + ; loadModuleInterfaces (text "Loading orphan modules") + (filter (/= this_mod) (imp_orphs imports)) + + -- Check type-family consistency between imports. + -- See Note [The type family instance consistency story] + ; traceRn "rn1: checking family instance consistency {" empty + ; let { dir_imp_mods = moduleEnvKeys + . imp_mods + $ imports } + ; checkFamInstConsistency dir_imp_mods + ; traceRn "rn1: } checking family instance consistency" empty + + ; getGblEnv } } + +{- +************************************************************************ +* * + Type-checking the top level of a module +* * +************************************************************************ +-} + +tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (Located [LIE GhcPs]) + -> [LHsDecl GhcPs] -- Declarations + -> TcM TcGblEnv +tcRnSrcDecls explicit_mod_hdr export_ies decls + = do { -- Do all the declarations + ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls + + ------ Simplify constraints --------- + -- + -- We do this after checkMainType, so that we use the type + -- info that checkMainType adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop, + -- and affects how names are rendered in error messages + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + ; new_ev_binds <- {-# SCC "simplifyTop" #-} + setEnvs (tcg_env, tcl_env) $ + do { lie_main <- checkMainType tcg_env + ; simplifyTop (lie `andWC` lie_main) } + + -- Emit Typeable bindings + ; tcg_env <- setGblEnv tcg_env $ + mkTypeableBinds + + ; traceTc "Tc9" empty + + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures + ; (id_env, ev_binds', binds', fords', imp_specs', rules') + <- zonkTcGblEnv new_ev_binds tcg_env + + --------- Run finalizers -------------- + -- Finalizers must run after constraints are simplified, lest types + -- might not be complete when using reify (see #12777). + -- and also after we zonk the first time because we run typed splices + -- in the zonker which gives rise to the finalisers. + ; let -- init_tcg_env: + -- * Remove accumulated bindings, rules and so on from + -- TcGblEnv. They are now in ev_binds', binds', etc. + -- * Add the zonked Ids from the value bindings to tcg_type_env + -- Up to now these Ids are only in tcl_env's type-envt + init_tcg_env = tcg_env { tcg_binds = emptyBag + , tcg_ev_binds = emptyBag + , tcg_imp_specs = [] + , tcg_rules = [] + , tcg_fords = [] + , tcg_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env } + ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env + run_th_modfinalizers + ; finishTH + ; traceTc "Tc11" empty + + --------- Deal with the exports ---------- + -- Can't be done earlier, because the export list must "see" + -- the declarations created by the finalizers + ; tcg_env <- setEnvs (tcg_env, tcl_env) $ + rnExports explicit_mod_hdr export_ies + + --------- Emit the ':Main.main = runMainIO main' declaration ---------- + -- Do this /after/ rnExports, so that it can consult + -- the tcg_exports created by rnExports + ; (tcg_env, main_ev_binds) + <- setEnvs (tcg_env, tcl_env) $ + do { (tcg_env, lie) <- captureTopConstraints $ + checkMain explicit_mod_hdr export_ies + ; ev_binds <- simplifyTop lie + ; return (tcg_env, ev_binds) } + + ---------- Final zonking --------------- + -- Zonk the new bindings arising from running the finalisers, + -- and main. This won't give rise to any more finalisers as you + -- can't nest finalisers inside finalisers. + ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) + <- zonkTcGblEnv main_ev_binds tcg_env + + ; let { !final_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env_mf + -- Add the zonked Ids from the value bindings (they were in tcl_env) + -- Force !final_type_env, lest we retain an old reference + -- to the previous tcg_env + + ; tcg_env' = tcg_env + { tcg_binds = binds' `unionBags` binds_mf + , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf + , tcg_imp_specs = imp_specs' ++ imp_specs_mf + , tcg_rules = rules' ++ rules_mf + , tcg_fords = fords' ++ fords_mf } } ; + + ; setGlobalTypeEnv tcg_env' final_type_env + } + +zonkTcGblEnv :: Bag EvBind -> TcGblEnv + -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, + [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) +zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds + , tcg_ev_binds = cur_ev_binds + , tcg_imp_specs = imp_specs + , tcg_rules = rules + , tcg_fords = fords }) + = {-# SCC "zonkTopDecls" #-} + setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering + -- error messages during zonking (notably levity errors) + do { failIfErrsM -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! + ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds + ; zonkTopDecls all_ev_binds binds rules imp_specs fords } + +-- | Runs TH finalizers and renames and typechecks the top-level declarations +-- that they could introduce. +run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) +run_th_modfinalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + th_modfinalizers <- readTcRef th_modfinalizers_var + if null th_modfinalizers + then getEnvs + else do + writeTcRef th_modfinalizers_var [] + let run_finalizer (lcl_env, f) = + setLclEnv lcl_env (runRemoteModFinalizers f) + + (_, lie_th) <- captureTopConstraints $ + mapM_ run_finalizer th_modfinalizers + + -- Finalizers can add top-level declarations with addTopDecls, so + -- we have to run tc_rn_src_decls to get them + (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] + + setEnvs (tcg_env, tcl_env) $ do + -- Subsequent rounds of finalizers run after any new constraints are + -- simplified, or some types might not be complete when using reify + -- (see #12777). + new_ev_binds <- {-# SCC "simplifyTop2" #-} + simplifyTop (lie_th `andWC` lie_top_decls) + addTopEvBinds new_ev_binds run_th_modfinalizers + -- addTopDecls can add declarations which add new finalizers. + +tc_rn_src_decls :: [LHsDecl GhcPs] + -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module +-- Never emits constraints; calls captureTopConstraints internally +tc_rn_src_decls ds + = {-# SCC "tc_rn_src_decls" #-} + do { (first_group, group_tail) <- findSplice ds + -- If ds is [] we get ([], Nothing) + + -- Deal with decls up to, but not including, the first splice + ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group + -- rnTopSrcDecls fails if there are any errors + + -- Get TH-generated top-level declarations and make sure they don't + -- contain any splices since we don't handle that at the moment + -- + -- The plumbing here is a bit odd: see #10853 + ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + ; th_ds <- readTcRef th_topdecls_var + ; writeTcRef th_topdecls_var [] + + ; (tcg_env, rn_decls) <- + if null th_ds + then return (tcg_env, rn_decls) + else do { (th_group, th_group_tail) <- findSplice th_ds + ; case th_group_tail of + { Nothing -> return () + ; Just (SpliceDecl _ (L loc _) _, _) -> + setSrcSpan loc + $ addErr (text + ("Declaration splices are not " + ++ "permitted inside top-level " + ++ "declarations added with addTopDecls")) + } + -- Rename TH-generated top-level declarations + ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env + $ rnTopSrcDecls th_group + + -- Dump generated top-level declarations + ; let msg = "top-level declarations added with addTopDecls" + ; traceSplice + $ SpliceInfo { spliceDescription = msg + , spliceIsDecl = True + , spliceSource = Nothing + , spliceGenerated = ppr th_rn_decls } + ; return (tcg_env, appendGroups rn_decls th_rn_decls) + } + + -- Type check all declarations + -- NB: set the env **before** captureTopConstraints so that error messages + -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that + -- the captureTopConstraints must go here, not in tcRnSrcDecls. + ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ + captureTopConstraints $ + tcTopSrcDecls rn_decls + + -- If there is no splice, we're nearly done + ; setEnvs (tcg_env, tcl_env) $ + case group_tail of + { Nothing -> return (tcg_env, tcl_env, lie1) + + -- If there's a splice, we must carry on + ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> + do { + -- We need to simplify any constraints from the previous declaration + -- group, or else we might reify metavariables, as in #16980. + ; ev_binds1 <- simplifyTop lie1 + + -- Rename the splice expression, and get its supporting decls + ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice + + -- Glue them on the front of the remaining decls and loop + ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + addTopEvBinds ev_binds1 $ + tc_rn_src_decls (spliced_decls ++ rest_ds) + } + } + } + +{- +************************************************************************ +* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +* * +************************************************************************ +-} + +tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv +tcRnHsBootDecls hsc_src decls + = do { (first_group, group_tail) <- findSplice decls + + -- Rename the declarations + ; (tcg_env, HsGroup { hs_tyclds = tycl_decls + , hs_derivds = deriv_decls + , hs_fords = for_decls + , hs_defds = def_decls + , hs_ruleds = rule_decls + , hs_annds = _ + , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) + <- rnTopSrcDecls first_group + + -- The empty list is for extra dependencies coming from .hs-boot files + -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Module + + ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { + -- NB: setGblEnv **before** captureTopConstraints so that + -- if the latter reports errors, it knows what's in scope + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d + Nothing -> return () + ; mapM_ (badBootDecl hsc_src "foreign") for_decls + ; mapM_ (badBootDecl hsc_src "default") def_decls + ; mapM_ (badBootDecl hsc_src "rule") rule_decls + + -- Typecheck type/class/instance decls + ; traceTc "Tc2 (boot)" empty + ; (tcg_env, inst_infos, _deriv_binds) + <- tcTyClsInstDecls tycl_decls deriv_decls val_binds + ; setGblEnv tcg_env $ do { + + -- Emit Typeable bindings + ; tcg_env <- mkTypeableBinds + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds val_sigs + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 + }}} + ; traceTc "boot" (ppr lie); return gbl_env } + +badBootDecl :: HscSource -> String -> Located decl -> TcM () +badBootDecl hsc_src what (L loc _) + = addErrAt loc (char 'A' <+> text what + <+> text "declaration is not (currently) allowed in a" + <+> (case hsc_src of + HsBootFile -> text "hs-boot" + HsigFile -> text "hsig" + _ -> panic "badBootDecl: should be an hsig or hs-boot file") + <+> text "file") + +{- +Once we've typechecked the body of the module, we want to compare what +we've found (gathered in a TypeEnv) with the hi-boot details (if any). +-} + +checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv +-- Compare the hi-boot file for this module (if there is one) +-- with the type environment we've just come up with +-- In the common case where there is no hi-boot file, the list +-- of boot_names is empty. + +checkHiBootIface tcg_env boot_info + | NoSelfBoot <- boot_info -- Common case + = return tcg_env + + | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! + = return tcg_env + + | SelfBoot { sb_mds = boot_details } <- boot_info + , TcGblEnv { tcg_binds = binds + , tcg_insts = local_insts + , tcg_type_env = local_type_env + , tcg_exports = local_exports } <- tcg_env + = do { -- This code is tricky, see Note [DFun knot-tying] + ; dfun_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details + + -- Now add the boot-dfun bindings $fxblah = $fblah + -- to (a) the type envt, and (b) the top-level bindings + ; let boot_dfuns = map fst dfun_prs + type_env' = extendTypeEnvWithIds local_type_env boot_dfuns + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + tcg_env_w_binds + = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + + ; type_env' `seq` + -- Why the seq? Without, we will put a TypeEnv thunk in + -- tcg_type_env_var. That thunk will eventually get + -- forced if we are typechecking interfaces, but that + -- is no good if we are trying to typecheck the very + -- DFun we were going to put in. + -- TODO: Maybe setGlobalTypeEnv should be strict. + setGlobalTypeEnv tcg_env_w_binds type_env' } + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "checkHiBootIface: unreachable code" +#endif + +{- Note [DFun impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We return a list of "impedance-matching" bindings for the dfuns +defined in the hs-boot file, such as + $fxEqT = $fEqT +We need these because the module and hi-boot file might differ in +the name it chose for the dfun: the name of a dfun is not +uniquely determined by its type; there might be multiple dfuns +which, individually, would map to the same name (in which case +we have to disambiguate them.) There's no way for the hi file +to know exactly what disambiguation to use... without looking +at the hi-boot file itself. + +In fact, the names will always differ because we always pick names +prefixed with "$fx" for boot dfuns, and "$f" for real dfuns +(so that this impedance matching is always possible). + +Note [DFun knot-tying] +~~~~~~~~~~~~~~~~~~~~~~ +The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from +typechecking the hi-boot file that we are presently implementing. +Suppose we are typechecking the module A: when we typecheck the +hi-boot file, whenever we see an identifier A.T, we knot-tie this +identifier to the *local* type environment (via if_rec_types.) The +contract then is that we don't *look* at 'SelfBootInfo' until we've +finished typechecking the module and updated the type environment with +the new tycons and ids. + +This most works well, but there is one problem: DFuns! We do not want +to look at the mb_insts of the ModDetails in SelfBootInfo, because a +dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a +(lazily evaluated) lookup in the if_rec_types. We could extend the +type env, do a setGloblaTypeEnv etc; but that all seems very indirect. +It is much more directly simply to extract the DFunIds from the +md_types of the SelfBootInfo. + +See #4003, #16038 for why we need to take care here. +-} + +checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] + -> ModDetails -> TcM [(Id, Id)] +-- Variant which doesn't require a full TcGblEnv; you could get the +-- local components from another ModDetails. +checkHiBootIface' + local_insts local_type_env local_exports + (ModDetails { md_types = boot_type_env + , md_fam_insts = boot_fam_insts + , md_exports = boot_exports }) + = do { traceTc "checkHiBootIface" $ vcat + [ ppr boot_type_env, ppr boot_exports] + + -- Check the exports of the boot module, one by one + ; mapM_ check_export boot_exports + + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") + -- FIXME: Why? The actual comparison is not hard, but what would + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... + + -- Check instance declarations + -- and generate an impedance-matching binding + ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns + + ; failIfErrsM + + ; return (catMaybes mb_dfun_prs) } + + where + boot_dfun_names = map idName boot_dfuns + boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env + -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts + -- We don't want to look at md_insts! + -- Why not? See Note [DFun knot-tying] + + check_export boot_avail -- boot_avail is exported by the boot iface + | name `elem` boot_dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) + + -- Check that the actual module exports the same thing + | not (null missing_names) + = addErrAt (nameSrcSpan (head missing_names)) + (missingBootThing True (head missing_names) "exported by") + + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) + | isNothing mb_boot_thing = return () + + -- Check that the actual module also defines the thing, and + -- then compare the definitions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = checkBootDeclM True boot_thing real_thing + + | otherwise + = addErrTc (missingBootThing True name "defined in") + where + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail `minusList` availNames avail + + local_export_env :: NameEnv AvailInfo + local_export_env = availsToNameEnv local_exports + + check_cls_inst :: DFunId -> TcM (Maybe (Id, Id)) + -- Returns a pair of the boot dfun in terms of the equivalent + -- real dfun. Delicate (like checkBootDecl) because it depends + -- on the types lining up precisely even to the ordering of + -- the type variables in the foralls. + check_cls_inst boot_dfun + | (real_dfun : _) <- find_real_dfun boot_dfun + , let local_boot_dfun = Id.mkExportedVanillaId + (idName boot_dfun) (idType real_dfun) + = return (Just (local_boot_dfun, real_dfun)) + -- Two tricky points here: + -- + -- * The local_boot_fun should have a Name from the /boot-file/, + -- but type from the dfun defined in /this module/. + -- That ensures that the TyCon etc inside the type are + -- the ones defined in this module, not the ones gotten + -- from the hi-boot file, which may have a lot less info + -- (#8743, comment:10). + -- + -- * The DFunIds from boot_details are /GlobalIds/, because + -- they come from typechecking M.hi-boot. + -- But all bindings in this module should be for /LocalIds/, + -- otherwise dependency analysis fails (#16038). This + -- is another reason for using mkExportedVanillaId, rather + -- that modifying boot_dfun, to make local_boot_fun. + + | otherwise + = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ + do { traceTc "check_cls_inst" $ vcat + [ text "local_insts" <+> + vcat (map (ppr . idType . instanceDFunId) local_insts) + , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] + + ; addErrTc (instMisMatch boot_dfun) + ; return Nothing } + + find_real_dfun :: DFunId -> [DFunId] + find_real_dfun boot_dfun + = [dfun | inst <- local_insts + , let dfun = instanceDFunId inst + , idType dfun `eqType` boot_dfun_ty ] + where + boot_dfun_ty = idType boot_dfun + + +-- In general, to perform these checks we have to +-- compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +-- | Compares two things for equivalence between boot-file and normal code, +-- reporting an error if they don't match up. +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +checkBootDeclM is_boot boot_thing real_thing + = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> + addErrAt span + (bootMisMatch is_boot err real_thing boot_thing) + where + -- Here we use the span of the boot thing or, if it doesn't have a sensible + -- span, that of the real thing, + span + | let span = nameSrcSpan (getName boot_thing) + , isGoodSrcSpan span + = span + | otherwise + = nameSrcSpan (getName real_thing) + +-- | Compares the two things for equivalence between boot-file and normal +-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ +-- failure. If the difference will be apparent to the user, @Just empty@ is +-- perfectly suitable. +checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc + +checkBootDecl _ (AnId id1) (AnId id2) + = ASSERT(id1 == id2) + check (idType id1 `eqType` idType id2) + (text "The two types are different") + +checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) + = checkBootTyCon is_boot tc1 tc2 + +checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ _ = Just empty -- probably shouldn't happen + +-- | Combines two potential error messages +andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc +Nothing `andThenCheck` msg = msg +msg `andThenCheck` Nothing = msg +Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) +infixr 0 `andThenCheck` + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, return the provided check +checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc +checkUnless True _ = Nothing +checkUnless False k = k + +-- | Run the check provided for every pair of elements in the lists. +-- The provided SDoc should name the element type, in the plural. +checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc + -> Maybe SDoc +checkListBy check_fun as bs whats = go [] as bs + where + herald = text "The" <+> whats <+> text "do not match" + + go [] [] [] = Nothing + go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) + go docs (x:xs) (y:ys) = case check_fun x y of + Just doc -> go (doc:docs) xs ys + Nothing -> go docs xs ys + go _ _ _ = Just (hang (herald <> colon) + 2 (text "There are different numbers of" <+> whats)) + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, fail with the given SDoc. +check :: Bool -> SDoc -> Maybe SDoc +check True _ = Nothing +check False doc = Just doc + +-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. +checkSuccess :: Maybe SDoc +checkSuccess = Nothing + +---------------- +checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc +checkBootTyCon is_boot tc1 tc2 + | not (eqType (tyConKind tc1) (tyConKind tc2)) + = Just $ text "The types have different kinds" -- First off, check the kind + + | Just c1 <- tyConClass_maybe tc1 + , Just c2 <- tyConClass_maybe tc2 + , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = classExtraBigSig c1 + (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + = classExtraBigSig c2 + , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 + = let + eqSig (id1, def_meth1) (id2, def_meth2) + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "are different") `andThenCheck` + check (eqTypeX env op_ty1 op_ty2) + (text "The types of" <+> pname1 <+> + text "are different") `andThenCheck` + if is_boot + then check (eqMaybeBy eqDM def_meth1 def_meth2) + (text "The default methods associated with" <+> pname1 <+> + text "are different") + else check (subDM op_ty1 def_meth1 def_meth2) + (text "The default methods associated with" <+> pname1 <+> + text "are not compatible") + where + name1 = idName id1 + name2 = idName id2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) + op_ty1 = classMethodTy id1 + op_ty2 = classMethodTy id2 + + eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) + = checkBootTyCon is_boot tc1 tc2 `andThenCheck` + check (eqATDef def_ats1 def_ats2) + (text "The associated type defaults differ") + + eqDM (_, VanillaDM) (_, VanillaDM) = True + eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 + eqDM _ _ = False + + -- NB: first argument is from hsig, second is from real impl. + -- Order of pattern matching matters. + subDM _ Nothing _ = True + subDM _ _ Nothing = False + -- If the hsig wrote: + -- + -- f :: a -> a + -- default f :: a -> a + -- + -- this should be validly implementable using an old-fashioned + -- vanilla default method. + subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM)) + = eqTypeX env t1 t2 + -- This case can occur when merging signatures + subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True + subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + + -- Ignore the location of the defaults + eqATDef Nothing Nothing = True + eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 + eqATDef _ _ = False + + eqFD (as1,bs1) (as2,bs2) = + eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + in + checkRoles roles1 roles2 `andThenCheck` + -- Checks kind of class + check (eqListBy eqFD clas_fds1 clas_fds2) + (text "The functional dependencies do not match") `andThenCheck` + checkUnless (isAbstractTyCon tc1) $ + check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) + (text "The class constraints do not match") `andThenCheck` + checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` + checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` + check (classMinimalDef c1 `BF.implies` classMinimalDef c2) + (text "The MINIMAL pragmas are not compatible") + + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = ASSERT(tc1 == tc2) + checkRoles roles1 roles2 `andThenCheck` + check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say + -- This allows abstract 'data T a' to be implemented using 'type T = ...' + -- and abstract 'class K a' to be implement using 'type K = ...' + -- See Note [Synonyms implement abstract data] + | not is_boot -- don't support for hs-boot yet + , isAbstractTyCon tc1 + , Just (tvs, ty) <- synTyConDefn_maybe tc2 + , Just (tc2', args) <- tcSplitTyConApp_maybe ty + = checkSynAbsData tvs ty tc2' args + -- TODO: When it's a synonym implementing a class, we really + -- should check if the fundeps are satisfied, but + -- there is not an obvious way to do this for a constraint synonym. + -- So for now, let it all through (it won't cause segfaults, anyway). + -- Tracked at #12704. + + -- This allows abstract 'data T :: Nat' to be implemented using + -- 'type T = 42' Since the kinds already match (we have checked this + -- upfront) all we need to check is that the implementation 'type T + -- = ...' defined an actual literal. See #15138 for the case this + -- handles. + | not is_boot + , isAbstractTyCon tc1 + , Just (_,ty2) <- synTyConDefn_maybe tc2 + , isJust (isLitTy ty2) + = Nothing + + | Just fam_flav1 <- famTyConFlav_maybe tc1 + , Just fam_flav2 <- famTyConFlav_maybe tc2 + = ASSERT(tc1 == tc2) + let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True + eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True + -- This case only happens for hsig merging: + eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True + eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True + eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True + eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) + = eqClosedFamilyAx ax1 ax2 + eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 + eqFamFlav _ _ = False + injInfo1 = tyConInjectivityInfo tc1 + injInfo2 = tyConInjectivityInfo tc2 + in + -- check equality of roles, family flavours and injectivity annotations + -- (NB: Type family roles are always nominal. But the check is + -- harmless enough.) + checkRoles roles1 roles2 `andThenCheck` + check (eqFamFlav fam_flav1 fam_flav2) + (whenPprDebug $ + text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> + text "do not match") `andThenCheck` + check (injInfo1 == injInfo2) (text "Injectivities do not match") + + | isAlgTyCon tc1 && isAlgTyCon tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = ASSERT(tc1 == tc2) + checkRoles roles1 roles2 `andThenCheck` + check (eqListBy (eqTypeX env) + (tyConStupidTheta tc1) (tyConStupidTheta tc2)) + (text "The datatype contexts do not match") `andThenCheck` + eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) + + | otherwise = Just empty -- two very different types -- should be obvious + where + roles1 = tyConRoles tc1 -- the abstract one + roles2 = tyConRoles tc2 + roles_msg = text "The roles do not match." $$ + (text "Roles on abstract types default to" <+> + quotes (text "representational") <+> text "in boot files.") + + roles_subtype_msg = text "The roles are not compatible:" $$ + text "Main module:" <+> ppr roles2 $$ + text "Hsig file:" <+> ppr roles1 + + checkRoles r1 r2 + | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] + = check (r1 == r2) roles_msg + | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg + + -- Note [Role subtyping] + -- ~~~~~~~~~~~~~~~~~~~~~ + -- In the current formulation of roles, role subtyping is only OK if the + -- "abstract" TyCon was not representationally injective. Among the most + -- notable examples of non representationally injective TyCons are abstract + -- data, which can be implemented via newtypes (which are not + -- representationally injective). The key example is + -- in this example from #13140: + -- + -- -- In an hsig file + -- data T a -- abstract! + -- type role T nominal + -- + -- -- Elsewhere + -- foo :: Coercible (T a) (T b) => a -> b + -- foo x = x + -- + -- We must NOT allow foo to typecheck, because if we instantiate + -- T with a concrete data type with a phantom role would cause + -- Coercible (T a) (T b) to be provable. Fortunately, if T is not + -- representationally injective, we cannot make the inference that a ~N b if + -- T a ~R T b. + -- + -- Unconditional role subtyping would be possible if we setup + -- an extra set of roles saying when we can project out coercions + -- (we call these proj-roles); then it would NOT be valid to instantiate T + -- with a data type at phantom since the proj-role subtyping check + -- would fail. See #13140 for more details. + -- + -- One consequence of this is we get no role subtyping for non-abstract + -- data types in signatures. Suppose you have: + -- + -- signature A where + -- type role T nominal + -- data T a = MkT + -- + -- If you write this, we'll treat T as injective, and make inferences + -- like T a ~R T b ==> a ~N b (mkNthCo). But if we can + -- subsequently replace T with one at phantom role, we would then be able to + -- infer things like T Int ~R T Bool which is bad news. + -- + -- We could allow role subtyping here if we didn't treat *any* data types + -- defined in signatures as injective. But this would be a bit surprising, + -- replacing a data type in a module with one in a signature could cause + -- your code to stop typechecking (whereas if you made the type abstract, + -- it is more understandable that the type checker knows less). + -- + -- It would have been best if this was purely a question of defaults + -- (i.e., a user could explicitly ask for one behavior or another) but + -- the current role system isn't expressive enough to do this. + -- Having explicit proj-roles would solve this problem. + + rolesSubtypeOf [] [] = True + -- NB: this relation is the OPPOSITE of the subroling relation + rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys + rolesSubtypeOf _ _ = False + + -- Note [Synonyms implement abstract data] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- An abstract data type or class can be implemented using a type synonym, + -- but ONLY if the type synonym is nullary and has no type family + -- applications. This arises from two properties of skolem abstract data: + -- + -- For any T (with some number of paramaters), + -- + -- 1. T is a valid type (it is "curryable"), and + -- + -- 2. T is valid in an instance head (no type families). + -- + -- See also 'HowAbstract' and Note [Skolem abstract data]. + + -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@, + -- check that this synonym is an acceptable implementation of @tc1@. + -- See Note [Synonyms implement abstract data] + checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc + checkSynAbsData tvs ty tc2' args = + check (null (tcTyFamInsts ty)) + (text "Illegal type family application in implementation of abstract data.") + `andThenCheck` + check (null tvs) + (text "Illegal parameterized type synonym in implementation of abstract data." $$ + text "(Try eta reducing your type synonym so that it is nullary.)") + `andThenCheck` + -- Don't report roles errors unless the type synonym is nullary + checkUnless (not (null tvs)) $ + ASSERT( null roles2 ) + -- If we have something like: + -- + -- signature H where + -- data T a + -- module H where + -- data K a b = ... + -- type T = K Int + -- + -- we need to drop the first role of K when comparing! + checkRoles roles1 (drop (length args) (tyConRoles tc2')) +{- + -- Hypothetically, if we were allow to non-nullary type synonyms, here + -- is how you would check the roles + if length tvs == length roles1 + then checkRoles roles1 roles2 + else case tcSplitTyConApp_maybe ty of + Just (tc2', args) -> + checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2) + Nothing -> Just roles_msg +-} + + eqAlgRhs _ AbstractTyCon _rhs2 + = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon + eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") + eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = + eqCon (data_con tc1) (data_con tc2) + eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> + text "definition with a" <+> quotes (text "newtype") <+> + text "definition") + + eqCon c1 c2 + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "differ") `andThenCheck` + check (dataConIsInfix c1 == dataConIsInfix c2) + (text "The fixities of" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) + (text "The strictness annotations for" <+> pname1 <+> + text "differ") `andThenCheck` + check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) + (text "The record label lists for" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) + (text "The types for" <+> pname1 <+> text "differ") + where + name1 = dataConName c1 + name2 = dataConName c2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) + + eqClosedFamilyAx Nothing Nothing = True + eqClosedFamilyAx Nothing (Just _) = False + eqClosedFamilyAx (Just _) Nothing = False + eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) + (Just (CoAxiom { co_ax_branches = branches2 })) + = numBranches branches1 == numBranches branches2 + && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2) + where + branch_list1 = fromBranches branches1 + branch_list2 = fromBranches branches2 + + eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 + , cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 + , cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 + , Just env <- eqVarBndrs env1 cvs1 cvs2 + = eqListBy (eqTypeX env) lhs1 lhs2 && + eqTypeX env rhs1 rhs2 + + | otherwise = False + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + +---------------- +missingBootThing :: Bool -> Name -> String -> SDoc +missingBootThing is_boot name what + = quotes (ppr name) <+> text "is exported by the" + <+> (if is_boot then text "hs-boot" else text "hsig") + <+> text "file, but not" + <+> text what <+> text "the module" + +badReexportedBootThing :: Bool -> Name -> Name -> SDoc +badReexportedBootThing is_boot name name' + = withUserStyle alwaysQualify AllTheWay $ vcat + [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") + <+> text "file (re)exports" <+> quotes (ppr name) + , text "but the implementing module exports a different identifier" <+> quotes (ppr name') + ] + +bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc +bootMisMatch is_boot extra_info real_thing boot_thing + = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc + where + to_doc + = pprTyThingInContext $ showToHeader { ss_forall = + if is_boot + then ShowForAllMust + else ShowForAllWhen } + + real_doc = to_doc real_thing + boot_doc = to_doc boot_thing + + pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc + pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc + = vcat + [ ppr real_thing <+> + text "has conflicting definitions in the module", + text "and its" <+> + (if is_boot + then text "hs-boot file" + else text "hsig file"), + text "Main module:" <+> real_doc, + (if is_boot + then text "Boot file: " + else text "Hsig file: ") + <+> boot_doc, + extra_info + ] + +instMisMatch :: DFunId -> SDoc +instMisMatch dfun + = hang (text "instance" <+> ppr (idType dfun)) + 2 (text "is defined in the hs-boot file, but not in the module itself") + +{- +************************************************************************ +* * + Type-checking the top level of a module (continued) +* * +************************************************************************ +-} + +rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) +-- Fails if there are any errors +rnTopSrcDecls group + = do { -- Rename the source decls + traceRn "rn12" empty ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; + traceRn "rn13" empty ; + (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; + traceRn "rn13-plugin" empty ; + + -- save the renamed syntax, if we want it + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; + + -- Dump trace of renaming part + rnDump rn_decls ; + return (tcg_env', rn_decls) + } + +tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_valds = hs_val_binds@(XValBindsLR + (NValBinds val_binds val_sigs)) }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + -- Source-language instances, including derivings, + -- and import the supporting declarations + traceTc "Tc3" empty ; + (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs)) + <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; + + setGblEnv tcg_env $ do { + + -- Generate Applicative/Monad proposal (AMP) warnings + traceTc "Tc3b" empty ; + + -- Generate Semigroup/Monoid warnings + traceTc "Tc3c" empty ; + tcSemigroupWarnings ; + + -- Foreign import declarations next. + traceTc "Tc4" empty ; + (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { + + -- Default declarations + traceTc "Tc4a" empty ; + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + + -- Value declarations next. + -- It is important that we check the top-level value bindings + -- before the GHC-generated derived bindings, since the latter + -- may be defined in terms of the former. (For instance, + -- the bindings produced in a Data instance.) + traceTc "Tc5" empty ; + tc_envs <- tcTopBinds val_binds val_sigs; + setEnvs tc_envs $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs@(tcg_env, tcl_env) + <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; + setEnvs tc_envs $ do { -- Environment doesn't change now + + -- Second pass over class and instance declarations, + -- now using the kind-checked decls + traceTc "Tc6" empty ; + inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + + -- Foreign exports + traceTc "Tc7" empty ; + (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; + + -- Annotations + annotations <- tcAnnotations annotation_decls ; + + -- Rules + rules <- tcRules rule_decls ; + + -- Wrap up + traceTc "Tc7a" empty ; + let { all_binds = inst_binds `unionBags` + foe_binds + + ; fo_gres = fi_gres `unionBags` foe_gres + ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre) + emptyFVs fo_gres + + ; sig_names = mkNameSet (collectHsValBinders hs_val_binds) + `minusNameSet` getTypeSigNames val_sigs + + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names + , tcg_rules = tcg_rules tcg_env + ++ flattenRuleDecls rules + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + + -- See Note [Newtype constructor usage in foreign declarations] + addUsedGREs (bagToList fo_gres) ; + + return (tcg_env', tcl_env) + }}}}}} + +tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" + + +tcSemigroupWarnings :: TcM () +tcSemigroupWarnings = do + traceTc "tcSemigroupWarnings" empty + let warnFlag = Opt_WarnSemigroup + tcPreludeClashWarn warnFlag sappendName + tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName + + +-- | Warn on local definitions of names that would clash with future Prelude +-- elements. +-- +-- A name clashes if the following criteria are met: +-- 1. It would is imported (unqualified) from Prelude +-- 2. It is locally defined in the current module +-- 3. It has the same literal name as the reference function +-- 4. It is not identical to the reference function +tcPreludeClashWarn :: WarningFlag + -> Name + -> TcM () +tcPreludeClashWarn warnFlag name = do + { warn <- woptM warnFlag + ; when warn $ do + { traceTc "tcPreludeClashWarn/wouldBeImported" empty + -- Is the name imported (unqualified) from Prelude? (Point 4 above) + ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv + -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude + -- will not appear in rnImports automatically if it is set.) + + -- Continue only the name is imported from Prelude + ; when (importedViaPrelude name rnImports) $ do + -- Handle 2.-4. + { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv + + ; let clashes :: GlobalRdrElt -> Bool + clashes x = isLocalDef && nameClashes && isNotInProperModule + where + isLocalDef = gre_lcl x == True + -- Names are identical ... + nameClashes = nameOccName (gre_name x) == nameOccName name + -- ... but not the actual definitions, because we don't want to + -- warn about a bad definition of e.g. <> in Data.Semigroup, which + -- is the (only) proper place where this should be defined + isNotInProperModule = gre_name x /= name + + -- List of all offending definitions + clashingElts :: [GlobalRdrElt] + clashingElts = filter clashes rdrElts + + ; traceTc "tcPreludeClashWarn/prelude_functions" + (hang (ppr name) 4 (sep [ppr clashingElts])) + + ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep + [ text "Local definition of" + , (quotes . ppr . nameOccName . gre_name) x + , text "clashes with a future Prelude name." ] + $$ + text "This will become an error in a future release." ) + ; mapM_ warn_msg clashingElts + }}} + + where + + -- Is the given name imported via Prelude? + -- + -- Possible scenarios: + -- a) Prelude is imported implicitly, issue warnings. + -- b) Prelude is imported explicitly, but without mentioning the name in + -- question. Issue no warnings. + -- c) Prelude is imported hiding the name in question. Issue no warnings. + -- d) Qualified import of Prelude, no warnings. + importedViaPrelude :: Name + -> [ImportDecl GhcRn] + -> Bool + importedViaPrelude name = any importViaPrelude + where + isPrelude :: ImportDecl GhcRn -> Bool + isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME + + -- Implicit (Prelude) import? + isImplicit :: ImportDecl GhcRn -> Bool + isImplicit = ideclImplicit + + -- Unqualified import? + isUnqualified :: ImportDecl GhcRn -> Bool + isUnqualified = not . isImportDeclQualified . ideclQualified + + -- List of explicitly imported (or hidden) Names from a single import. + -- Nothing -> No explicit imports + -- Just (False, ) -> Explicit import list of + -- Just (True , ) -> Explicit hiding of + importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name]) + importListOf = fmap toImportList . ideclHiding + where + toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) + + isExplicit :: ImportDecl GhcRn -> Bool + isExplicit x = case importListOf x of + Nothing -> False + Just (False, explicit) + -> nameOccName name `elem` map nameOccName explicit + Just (True, hidden) + -> nameOccName name `notElem` map nameOccName hidden + + -- Check whether the given name would be imported (unqualified) from + -- an import declaration. + importViaPrelude :: ImportDecl GhcRn -> Bool + importViaPrelude x = isPrelude x + && isUnqualified x + && (isImplicit x || isExplicit x) + + +-- Notation: is* is for classes the type is an instance of, should* for those +-- that it should also be an instance of based on the corresponding +-- is*. +tcMissingParentClassWarn :: WarningFlag + -> Name -- ^ Instances of this ... + -> Name -- ^ should also be instances of this + -> TcM () +tcMissingParentClassWarn warnFlag isName shouldName + = do { warn <- woptM warnFlag + ; when warn $ do + { traceTc "tcMissingParentClassWarn" empty + ; isClass' <- tcLookupClass_maybe isName + ; shouldClass' <- tcLookupClass_maybe shouldName + ; case (isClass', shouldClass') of + (Just isClass, Just shouldClass) -> do + { localInstances <- tcGetInsts + ; let isInstance m = is_cls m == isClass + isInsts = filter isInstance localInstances + ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts) + ; forM_ isInsts (checkShouldInst isClass shouldClass) + } + (is',should') -> + traceTc "tcMissingParentClassWarn/notIsShould" + (hang (ppr isName <> text "/" <> ppr shouldName) 2 ( + (hsep [ quotes (text "Is"), text "lookup for" + , ppr isName + , text "resulted in", ppr is' ]) + $$ + (hsep [ quotes (text "Should"), text "lookup for" + , ppr shouldName + , text "resulted in", ppr should' ]))) + }} + where + -- Check whether the desired superclass exists in a given environment. + checkShouldInst :: Class -- ^ Class of existing instance + -> Class -- ^ Class there should be an instance of + -> ClsInst -- ^ Existing instance + -> TcM () + checkShouldInst isClass shouldClass isInst + = do { instEnv <- tcGetInstEnvs + ; let (instanceMatches, shouldInsts, _) + = lookupInstEnv False instEnv shouldClass (is_tys isInst) + + ; traceTc "tcMissingParentClassWarn/checkShouldInst" + (hang (ppr isInst) 4 + (sep [ppr instanceMatches, ppr shouldInsts])) + + -- ": Warning: is an instance of but not + -- " e.g. "Foo is an instance of Monad but not Applicative" + ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst + warnMsg (Just name:_) = + addWarnAt (Reason warnFlag) instLoc $ + hsep [ (quotes . ppr . nameOccName) name + , text "is an instance of" + , (ppr . nameOccName . className) isClass + , text "but not" + , (ppr . nameOccName . className) shouldClass ] + <> text "." + $$ + hsep [ text "This will become an error in" + , text "a future release." ] + warnMsg _ = pure () + ; when (null shouldInsts && null instanceMatches) $ + warnMsg (is_tcs isInst) + } + + tcLookupClass_maybe :: Name -> TcM (Maybe Class) + tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case + Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls + _else -> pure Nothing + + +--------------------------- +tcTyClsInstDecls :: [TyClGroup GhcRn] + -> [LDerivDecl GhcRn] + -> [(RecFlag, LHsBinds GhcRn)] + -> TcM (TcGblEnv, -- The full inst env + [InstInfo GhcRn], -- Source-code instance decls to + -- process; contains all dfuns for + -- this module + HsValBinds GhcRn) -- Supporting bindings for derived + -- instances + +tcTyClsInstDecls tycl_decls deriv_decls binds + = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ + tcAddPatSynPlaceholders (getPatSynBinds binds) $ + do { (tcg_env, inst_info, deriv_info) + <- tcTyAndClassDecls tycl_decls ; + ; setGblEnv tcg_env $ do { + -- With the @TyClDecl@s and @InstDecl@s checked we're ready to + -- process the deriving clauses, including data family deriving + -- clauses discovered in @tcTyAndClassDecls@. + -- + -- Careful to quit now in case there were instance errors, so that + -- the deriving errors don't pile up as well. + ; failIfErrsM + ; (tcg_env', inst_info', val_binds) + <- tcInstDeclsDeriv deriv_info deriv_decls + ; setGblEnv tcg_env' $ do { + failIfErrsM + ; pure (tcg_env', inst_info' ++ inst_info, val_binds) + }}} + +{- ********************************************************************* +* * + Checking for 'main' +* * +************************************************************************ +-} + +checkMainType :: TcGblEnv -> TcRn WantedConstraints +-- If this is the Main module, and it defines a function main, +-- check that its type is of form IO tau. +-- If not, do nothing +-- See Note [Dealing with main] +checkMainType tcg_env + = do { dflags <- getDynFlags + ; if tcg_mod tcg_env /= mainModIs dflags + then return emptyWC else + + do { rdr_env <- getGlobalRdrEnv + ; let main_occ = getMainOcc dflags + main_gres = lookupGlobalRdrEnv rdr_env main_occ + ; case filter isLocalGRE main_gres of { + [] -> return emptyWC ; + (_:_:_) -> return emptyWC ; + [main_gre] -> + + do { let main_name = gre_name main_gre + ctxt = FunSigCtxt main_name False + ; main_id <- tcLookupId main_name + ; (io_ty,_) <- getIOType + ; (_, lie) <- captureTopConstraints $ + setMainCtxt main_name io_ty $ + tcSubTypeSigma ctxt (idType main_id) io_ty + ; return lie } } } } + +checkMain :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (Located [LIE GhcPs]) -- Export specs of Main module + -> TcM TcGblEnv +-- If we are in module Main, check that 'main' is exported, +-- and generate the runMainIO binding that calls it +-- See Note [Dealing with main] +checkMain explicit_mod_hdr export_ies + = do { dflags <- getDynFlags + ; tcg_env <- getGblEnv + + ; let main_mod = mainModIs dflags + main_occ = getMainOcc dflags + + exported_mains :: [Name] + -- Exported things that are called 'main' + exported_mains = [ name | avail <- tcg_exports tcg_env + , name <- availNames avail + , nameOccName name == main_occ ] + + ; if | tcg_mod tcg_env /= main_mod + -> -- Not the main module + return tcg_env + + | [main_name] <- exported_mains + -> -- The module indeed exports a function called 'main' + generateMainBinding tcg_env main_name + + | otherwise + -> ASSERT( null exported_mains ) + -- A fully-checked export list can't contain more + -- than one function with the same OccName + do { complain_no_main dflags main_mod main_occ + ; return tcg_env } } + where + complain_no_main dflags main_mod main_occ + = unless (interactive && not explicit_mod_hdr) $ + addErrTc (noMainMsg main_mod main_occ) -- #12906 + where + interactive = ghcLink dflags == LinkInMemory + -- Without an explicit module header... + -- in interactive mode, don't worry about the absence of 'main'. + -- in other modes, add error message and go on with typechecking. + + noMainMsg main_mod main_occ + = text "The" <+> ppMainFn main_occ + <+> text "is not" <+> text defOrExp <+> text "module" + <+> quotes (ppr main_mod) + + defOrExp | explicit_export_list = "exported by" + | otherwise = "defined in" + explicit_export_list = explicit_mod_hdr && isJust export_ies + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainOcc :: DynFlags -> OccName +getMainOcc dflags = case mainFunIs dflags of + Just fn -> mkVarOccFS (mkFastString fn) + Nothing -> mainOcc + +ppMainFn :: OccName -> SDoc +ppMainFn main_occ + | main_occ == mainOcc + = text "IO action" <+> quotes (ppr main_occ) + | otherwise + = text "main IO action" <+> quotes (ppr main_occ) + +mainOcc :: OccName +mainOcc = mkVarOccFS (fsLit "main") + +generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv +-- There is a single exported 'main' function, called 'foo' (say), +-- which may be locally defined or imported +-- Define and typecheck the binding +-- :Main.main :: IO res_ty = runMainIO res_ty foo +-- This wraps the user's main function in the top-level stuff +-- defined in runMainIO (eg catching otherwise un-caught exceptions) +-- See Note [Dealing with main] +generateMainBinding tcg_env main_name = do + { traceTc "checkMain found" (ppr main_name) + ; (io_ty, res_ty) <- getIOType + ; let loc = getSrcSpan main_name + main_expr_rn = L loc (HsVar noExtField (L loc main_name)) + ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ + tcCheckMonoExpr main_expr_rn io_ty + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty + ; co = mkWpTyApps [res_ty] + -- The ev_binds of the `main` function may contain deferred + -- type errors when type of `main` is not `IO a`. The `ev_binds` + -- must be put inside `runMainIO` to ensure the deferred type + -- error can be emitted correctly. See #13838. + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ + mkHsDictLet ev_binds main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name + , tcg_binds = tcg_binds tcg_env + `snocBag` main_bind + , tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) }) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + } + +getIOType :: TcM (TcType, TcType) +-- Return (IO alpha, alpha) for fresh alpha +getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; return (mkTyConApp ioTyCon [res_ty], res_ty) } + +setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) +setMainCtxt main_name io_ty thing_inside + = setSrcSpan (getSrcSpan main_name) $ + addErrCtxt main_ctxt $ + checkConstraints skol_info [] [] $ -- Builds an implication if necessary + thing_inside -- e.g. with -fdefer-type-errors + where + skol_info = SigSkol (FunSigCtxt main_name False) io_ty [] + main_ctxt = text "When checking the type of the" + <+> ppMainFn (nameOccName main_name) + +{- Note [Dealing with main] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with the 'main' declaration is surprisingly tricky. Here are +the moving parts: + +* The flag -main-is=M.foo allows you to set the main module to 'M', + and the main function to 'foo'. We access them through + mainModIs :: DynFlags -> Module -- returns M + getMainOcc :: DynFlags -> OccName -- returns foo + Of course usually M = Main, and foo = main. + +* checkMainType: when typechecking module M, we add an extra check that + foo :: IO tau, for some type tau. + This avoids getting ambiguous-type errors from the monomorphism restriction + applying to things like + main = return () + Note that checkMainType does not consult the export list because + we have not yet done rnExports (and can't do it until later). + +* rnExports: checks the export list. Very annoyingly, we can only do + this after running any finalisers, which may add new declarations. + That's why checkMainType and checkMain have to be separate. + +* checkMain: does two things: + - check that the export list does indeed export something called 'foo' + - generateMainBinding: generate the root-main binding + :Main.main = runMainIO M.foo + See Note [Root-main id] + +An annoying consequence of having both checkMainType and checkMain is +that, when (but only when) -fdefer-type-errors is on, we may report an +ill-typed 'main' twice (as warnings): once in checkMainType and once +in checkMain. See test typecheck/should_fail/T13292. + +We have the following tests to check this processing: +----------------+----------------------------------------------------------------------------------+ + | Module Header: | + +-------------+-------------+-------------+-------------+-------------+------------+ + | module | module Main | | module Main |module |module Main | + | Main(main) | | | (module X)| Main () | (Sub.main)| +----------------+==================================================================================+ +`main` function | ERROR: | Main.main | ERROR: | Main.main | ERROR: | Sub.main | +in Main module | Ambiguous | | Ambiguous | | `main` not | | +and in imported | | | | | exported | | +module Sub. | T19397E1 | T16453M0 | T19397E2 | T16453M3 | | T16453M1 | + | | | | X = Main | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`main`function | Sub.main | ERROR: | Sub.main | Sub.main | ERROR: | Sub.main | +only in imported| | No `main` in| | | `main` not | | +submodule Sub. | | `Main` | | | exported | | + | T19397M0 | T16453E1 | T19397M1 | T16453M4 | | T16453M5 | + | | | | X = Sub | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`foo` function | Sub.foo | ERROR: | Sub.foo | Sub.foo | ERROR: | Sub.foo | +in submodule | | No `foo` in | | | `foo` not | | +Sub. | | `Main` | | | exported | | +GHC option: | | | | | | | + -main-is foo | T19397M2 | T19397E3 | T19397M3 | T19397M4 | T19397E4 | T16453M6 | + | Remark 1) | | | X = Sub | | Remark 3) | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ + +Remarks: +* The first line shows the exported `main` function or the error. +* The second line shows the coresponding test case. +* The module `Sub` contains the following functions: + main :: IO () + foo :: IO () +* Remark 1) Here the header is `Main (foo)`. +* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`. +* Remark 3) Here the header is `Main (Sub.foo)`. + + +Note [Root-main Id] +~~~~~~~~~~~~~~~~~~~ +The function that the RTS invokes is always :Main.main, which we call +root_main_id. (Because GHC allows the user to have a module not +called Main as the main module, we can't rely on the main function +being called "Main.main". That's why root_main_id has a fixed module +":Main".) + +This is unusual: it's a LocalId whose Name has a Module from another +module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we +get two defns for 'main' in the interface file! + + +********************************************************* +* * + GHCi stuff +* * +********************************************************* +-} + +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) +-- Initialise the tcg_inst_env with instances from all home modules. +-- This mimics the more selective call to hptInstances in tcRnImports +runTcInteractive hsc_env thing_inside + = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ + do { traceTc "setInteractiveContext" $ + vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) + , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) + , text "ic_rn_gbl_env (LocalDef)" <+> + vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) + , let local_gres = filter isLocalGRE gres + , not (null local_gres) ]) ] + + ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface + : dep_orphs (mi_deps iface)) + (loadSrcInterface (text "runTcInteractive") m + NotBoot mb_pkg) + + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> + case i of -- force above: see #15111 + IIModule n -> getOrphans n Nothing + IIDecl i -> + let mb_pkg = sl_fs <$> ideclPkgQual i in + getOrphans (unLoc (ideclName i)) mb_pkg + + ; let imports = emptyImportAvails { + imp_orphs = orphs + } + + ; (gbl_env, lcl_env) <- getEnvs + ; let gbl_env' = gbl_env { + tcg_rdr_env = ic_rn_gbl_env icxt + , tcg_type_env = type_env + , tcg_inst_env = extendInstEnvList + (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) + home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts + , tcg_field_env = mkNameEnv con_fields + -- setting tcg_field_env is necessary + -- to make RecordWildCards work (test: ghci049) + , tcg_fix_env = ic_fix_env icxt + , tcg_default = ic_default icxt + -- must calculate imp_orphs of the ImportAvails + -- so that instance visibility is done correctly + , tcg_imports = imports + } + + lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids + + ; setEnvs (gbl_env', lcl_env') thing_inside } + where + (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) + + icxt = hsc_IC hsc_env + (ic_insts, ic_finsts) = ic_instances icxt + (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) + + is_closed :: TyThing -> Either (Name, TcTyThing) TyThing + -- Put Ids with free type variables (always RuntimeUnks) + -- in the *local* type environment + -- See Note [Initialising the type environment for GHCi] + is_closed thing + | AnId id <- thing + , not (isTypeClosedLetBndr id) + = Left (idName id, ATcId { tct_id = id + , tct_info = NotLetBound }) + | otherwise + = Right thing + + type_env1 = mkTypeEnvWithImplicits top_ty_things + type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) + -- Putting the dfuns in the type_env + -- is just to keep Core Lint happy + + con_fields = [ (dataConName c, dataConFieldLabels c) + | ATyCon t <- top_ty_things + , c <- tyConDataCons t ] + + +{- Note [Initialising the type environment for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the Ids in ic_things, defined by the user in 'let' stmts, +have closed types. E.g. + ghci> let foo x y = x && not y + +However the GHCi debugger creates top-level bindings for Ids whose +types have free RuntimeUnk skolem variables, standing for unknown +types. If we don't register these free TyVars as global TyVars then +the typechecker will try to quantify over them and fall over in +skolemiseQuantifiedTyVar. so we must add any free TyVars to the +typechecker's global TyVar set. That is done by using +tcExtendLocalTypeEnv. + +We do this by splitting out the Ids with open types, using 'is_closed' +to do the partition. The top-level things go in the global TypeEnv; +the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the +local TypeEnv. + +Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope +things are already in the interactive context's GlobalRdrEnv. +Extending the local RdrEnv isn't terrible, but it means there is an +entry for the same Name in both global and local RdrEnvs, and that +lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). + +We don't bother with the tcl_th_bndrs environment either. +-} + +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound +-- values, coerced to (). +tcRnStmt :: HscEnv -> GhciLStmt GhcPs + -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) +tcRnStmt hsc_env rdr_stmt + = runTcInteractive hsc_env $ do { + + -- The real work is done here + ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; + zonked_expr <- zonkTopLExpr tc_expr ; + zonked_ids <- zonkTopBndrs bound_ids ; + + failIfErrsM ; -- we can't do the next step if there are levity polymorphism errors + -- test case: ghci/scripts/T13202{,a} + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! + mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ; + + traceTc "tcs 1" empty ; + this_mod <- getModule ; + global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; + -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types + +{- --------------------------------------------- + At one stage I removed any shadowed bindings from the type_env; + they are inaccessible but might, I suppose, cause a space leak if we leave them there. + However, with Template Haskell they aren't necessarily inaccessible. Consider this + GHCi session + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + In the last line we use 'fName', which resolves to the *first* 'f' + in scope. If we delete it from the type env, GHCi crashes because + it doesn't expect that. + + Hence this code is commented out + +-------------------------------------------------- -} + + traceOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; + + return (global_ids, zonked_expr, fix_env) + } + where + bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", + nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))]) + +{- +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + +Here is the grand plan, implemented in tcUserStmt + + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] + + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + + expr (of non-IO type, + result not showable) ==> error +-} + +-- | A plan is an attempt to lift some code into the IO monad. +type PlanResult = ([Id], LHsExpr GhcTc) +type Plan = TcM PlanResult + +-- | Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans :: [Plan] -> TcM PlanResult +runPlans [] = panic "runPlans" +runPlans [p] = p +runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p + +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environment'. +-- +-- By 'lift' and 'environment we mean that the code is changed to +-- execute properly in an IO monad. See Note [Interactively-bound Ids +-- in GHCi] in GHC.Driver.Types for more details. We do this lifting by trying +-- different ways ('plans') of lifting the code into the IO monad and +-- type checking each plan until one succeeds. +tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (BodyStmt _ expr _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO + ; uniq <- newUnique + ; interPrintName <- getInteractivePrintName + ; let fresh_it = itName uniq loc + matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr + (noLoc emptyLocalBinds)] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind FromSource + (L loc fresh_it) matches) + { fun_ext = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + -- [let it = expr] + let_stmt = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField + $ XValBindsLR + (NValBinds [(NonRecursive,unitBag the_bind)] []) + + -- [it <- e] + bind_stmt = L loc $ BindStmt + (XBindStmtRn + { xbsrn_bindOp = mkRnSyntaxExpr bindIOName + , xbsrn_failOp = Nothing + }) + (L loc (VarPat noExtField (L loc fresh_it))) + (nlHsApp ghciStep rn_expr) + + -- [; print it] + print_it = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) + (nlHsVar fresh_it)) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- NewA + no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName + [rn_expr , nlHsVar interPrintName]) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_b = L loc $ BodyStmt noExtField (rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_c = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- See Note [GHCi Plans] + + it_plans = [ + -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; when (isUnitTy $ it_ty) failM + ; return stuff }, + + -- Plan B; a naked bind statement + tcGhciStmts [bind_stmt], + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } ] + + -- Plans where we don't bind "it" + no_it_plans = [ + tcGhciStmts [no_it_a] , + tcGhciStmts [no_it_b] , + tcGhciStmts [no_it_c] ] + + ; generate_it <- goptM Opt_NoIt + + -- We disable `-fdefer-type-errors` in GHCi for naked expressions. + -- See Note [Deferred type errors in GHCi] + + -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` + -- and `-fdefer-out-of-scope-variables`. However the flag + -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and + -- `-fno-defer-out-of-scope-variables`. Thus the later two flags + -- also need to be unset here. + ; plan <- unsetGOptM Opt_DeferTypeErrors $ + unsetGOptM Opt_DeferTypedHoles $ + unsetGOptM Opt_DeferOutOfScopeVariables $ + runPlans $ if generate_it + then no_it_plans + else it_plans + + ; fix_env <- getFixityEnv + ; return (plan, fix_env) } + +{- Note [Deferred type errors in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHCi, we ensure that type errors don't get deferred when type checking the +naked expressions. Deferring type errors here is unhelpful because the +expression gets evaluated right away anyway. It also would potentially emit +two redundant type-error warnings, one from each plan. + +#14963 reveals another bug that when deferred type errors is enabled +in GHCi, any reference of imported/loaded variables (directly or indirectly) +in interactively issued naked expressions will cause ghc panic. See more +detailed discussion in #14963. + +The interactively issued declarations, statements, as well as the modules +loaded into GHCi, are not affected. That means, for declaration, you could +have + + Prelude> :set -fdefer-type-errors + Prelude> x :: IO (); x = putStrLn True + :14:26: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True + +But for naked expressions, you will have + + Prelude> :set -fdefer-type-errors + Prelude> putStrLn True + :2:10: error: + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘it’: it = putStrLn True + + Prelude> let x = putStrLn True + :2:18: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True +-} + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ + rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do + fix_env <- getFixityEnv + return (fix_env, emptyFVs) + -- Don't try to typecheck if the renamer fails! + ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump rn_stmt ; + + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt x pat expr)) <- rn_stmt + = L loc $ BindStmt x pat (nlHsApp ghciStep expr) + | otherwise = rn_stmt + + ; opt_pr_flag <- goptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] + | otherwise = [] + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) + ; return (plan, fix_env) } + where + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) + (nlHsVar v)) + (mkRnSyntaxExpr thenIOName) noSyntaxExpr + +{- +Note [GHCi Plans] +~~~~~~~~~~~~~~~~~ +When a user types an expression in the repl we try to print it in three different +ways. Also, depending on whether -fno-it is set, we bind a variable called `it` +which can be used to refer to the result of the expression subsequently in the repl. + +The normal plans are : + A. [it <- e; print e] but not if it::() + B. [it <- e] + C. [let it = e; print it] + +When -fno-it is set, the plans are: + A. [e >>= print] + B. [e] + C. [let it = e in print it] + +The reason for -fno-it is explained in #14336. `it` can lead to the repl +leaking memory as it is repeatedly queried. +-} + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [()]'. +tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult +tcGhciStmts stmts + = do { ioTyCon <- tcLookupTyCon ioTyConName + ; ret_id <- tcLookupId returnIOName -- return @ IO + ; let ret_ty = mkListTy unitTy + io_ret_ty = mkTyConApp ioTyCon [ret_ty] + tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts + (mkCheckExpType io_ret_ty) + names = collectLStmtsBinders stmts + + -- OK, we're ready to typecheck the stmts + ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty + ; ((tc_stmts, ids), lie) <- captureTopConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty + ; const_binds <- checkNoErrs (simplifyInteractive lie) + -- checkNoErrs ensures that the plan fails if context redn fails + + + ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty + + -- rec_expr is the expression + -- returnIO @ [()] [unsafeCoerce# () x, .., unsafeCorece# () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + + ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName + -- We use unsafeCoerce# here because of (U11) in + -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + + ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ + noLoc $ ExplicitList unitTy Nothing $ + map mk_item ids + + mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) + , getRuntimeRep unitTy + , idType id, unitTy] + `nlHsApp` nlHsVar id + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + + ; return (ids, mkHsDictLet (EvBinds const_binds) $ + noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts))) + } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr GhcRn) +getGhciStepIO = do + ghciTy <- getGHCiMonad + a_tv <- newName (mkTyVarOccFS (fsLit "a")) + let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) + ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + + step_ty = noLoc $ HsForAllTy + { hst_tele = mkHsForAllInvisTele + [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)] + , hst_xforall = noExtField + , hst_body = nlHsFunTy ghciM ioM } + + stepTy :: LHsSigWcType GhcRn + stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) + + return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) + +isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) +isGHCiMonad hsc_env ty + = runTcInteractive hsc_env $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = gre_name n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = mkTyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + + Just _ -> failWithTc $ text "Ambiguous type!" + Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + +-- | How should we infer a type? See Note [TcRnExprMode] +data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type) + | TM_NoInst -- ^ Do not instantiate the type (:type +v) + | TM_Default -- ^ Default the type eagerly (:type +d) + +-- | tcRnExpr just finds the type of an expression +-- for :type +tcRnExpr :: HscEnv + -> TcRnExprMode + -> LHsExpr GhcPs + -> IO (Messages, Maybe Type) +tcRnExpr hsc_env mode rdr_expr + = runTcInteractive hsc_env $ + do { + + (rn_expr, _fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + + -- Now typecheck the expression, and generalise its type + -- it might have a rank-2 type (e.g. :t runST) + uniq <- newUnique ; + let { fresh_it = itName uniq (getLoc rdr_expr) } ; + ((tclvl, (_tc_expr, res_ty)), lie) + <- captureTopConstraints $ + pushTcLevelM $ + tc_infer rn_expr ; + + -- Generalise + (qtvs, dicts, _, residual, _) + <- simplifyInfer tclvl infer_mode + [] {- No sig vars -} + [(fresh_it, res_ty)] + lie ; + + -- Ignore the dictionary bindings + _ <- perhaps_disable_default_warnings $ + simplifyInteractive residual ; + + let { all_expr_ty = mkInfForAllTys qtvs $ + mkPhiTy (map idType dicts) res_ty } ; + ty <- zonkTcType all_expr_ty ; + + -- We normalise type families, so that the type of an expression is the + -- same as of a bound expression (GHC.Tc.Gen.Bind.mkInferredPolyId). See Trac + -- #10321 for further discussion. + fam_envs <- tcGetFamInstEnvs ; + -- normaliseType returns a coercion which we discard, so the Role is + -- irrelevant + return (snd (normaliseType fam_envs Nominal ty)) + } + where + tc_infer expr | inst = tcInferRho expr + | otherwise = tcInferSigma expr + -- tcInferSigma: see Note [Implementing :type] + + -- See Note [TcRnExprMode] + (inst, infer_mode, perhaps_disable_default_warnings) = case mode of + TM_Inst -> (True, NoRestrictions, id) + TM_NoInst -> (False, NoRestrictions, id) + TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) + +{- Note [Implementing :type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider :type const + +We want forall a b. a -> b -> a +and not forall {a}{b}. a -> b -> a + +The latter is what we'd get if we eagerly instantiated and then +re-generalised with Inferred binders. It makes a difference, because +it tells us we where we can use Visible Type Application (VTA). + +And also for :type const @Int +we want forall b. Int -> b -> Int +and not forall {b}. Int -> b -> Int + +Solution: use tcInferSigma, which in turn uses tcInferApp, which +has a special case for application chains. +-} + +-------------------------- +tcRnImportDecls :: HscEnv + -> [LImportDecl GhcPs] + -> IO (Messages, Maybe GlobalRdrEnv) +-- Find the new chunk of GlobalRdrEnv created by this list of import +-- decls. In contract tcRnImports *extends* the TcGblEnv. +tcRnImportDecls hsc_env import_decls + = runTcInteractive hsc_env $ + do { gbl_env <- updGblEnv zap_rdr_env $ + tcRnImports hsc_env import_decls + ; return (tcg_rdr_env gbl_env) } + where + zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } + +-- tcRnType just finds the kind of a type +tcRnType :: HscEnv + -> ZonkFlexi + -> Bool -- Normalise the returned type + -> LHsType GhcPs + -> IO (Messages, Maybe (Type, Kind)) +tcRnType hsc_env flexi normalise rdr_type + = runTcInteractive hsc_env $ + setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] + do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs) + <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type) + -- The type can have wild cards, but no implicit + -- generalisation; e.g. :kind (T _) + ; failIfErrsM + + -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here + + -- Now kind-check the type + -- It can have any rank or kind + -- First bring into scope any wildcards + ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) + ; (ty, kind) <- pushTcLevelM_ $ + -- must push level to satisfy level precondition of + -- kindGeneralize, below + solveEqualities $ + tcNamedWildCardBinders wcs $ \ wcs' -> + do { mapM_ emitNamedTypeHole wcs' + ; tcInferLHsTypeUnsaturated rn_type } + + -- Do kind generalisation; see Note [Kind-generalise in tcRnType] + ; kvs <- kindGeneralizeAll kind + ; e <- mkEmptyZonkEnv flexi + + ; ty <- zonkTcTypeToTypeX e ty + + -- Do validity checking on type + ; checkValidType (GhciCtxt True) ty + + ; ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs + ; let (_, ty') + = normaliseType fam_envs Nominal ty + ; return ty' } + else return ty ; + + ; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) } + +{- Note [TcRnExprMode] +~~~~~~~~~~~~~~~~~~~~~~ +How should we infer a type when a user asks for the type of an expression e +at the GHCi prompt? We offer 3 different possibilities, described below. Each +considers this example, with -fprint-explicit-foralls enabled: + + foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + :type{,-spec,-def} foo @Int + +:type / TM_Inst + + In this mode, we report the type that would be inferred if a variable + were assigned to expression e, without applying the monomorphism restriction. + This means we instantiate the type and then regeneralize, as discussed + in #11376. + + > :type foo @Int + forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String + + Note that the variables and constraints are reordered here, because this + is possible during regeneralization. Also note that the variables are + reported as Inferred instead of Specified. + +:type +v / TM_NoInst + + This mode is for the benefit of users using TypeApplications. It does no + instantiation whatsoever, sometimes meaning that class constraints are not + solved. + + > :type +v foo @Int + forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String + + Note that Show Int is still reported, because the solver never got a chance + to see it. + +:type +d / TM_Default + + This mode is for the benefit of users who wish to see instantiations of + generalized types, and in particular to instantiate Foldable and Traversable. + In this mode, any type variable that can be defaulted is defaulted. Because + GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are + defaulted. + + > :type +d foo @Int + Int -> [Integer] -> String + + Note that this mode can sometimes lead to a type error, if a type variable is + used with a defaultable class but cannot actually be defaulted: + + bar :: (Num a, Monoid a) => a -> a + > :type +d bar + ** error ** + + The error arises because GHC tries to default a but cannot find a concrete + type in the defaulting list that is both Num and Monoid. (If this list is + modified to include an element that is both Num and Monoid, the defaulting + would succeed, of course.) + +Note [Kind-generalise in tcRnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on PolyKinds when kind-checking a user type, so that we will +kind-generalise the type, even when PolyKinds is not otherwise on. +This gives the right default behaviour at the GHCi prompt, where if +you say ":k T", and T has a polymorphic kind, you'd like to see that +polymorphism. Of course. If T isn't kind-polymorphic you won't get +anything unexpected, but the apparent *loss* of polymorphism, for +types that you know are polymorphic, is quite surprising. See Trac +#7688 for a discussion. + +Note that the goal is to generalise the *kind of the type*, not +the type itself! Example: + ghci> data SameKind :: k -> k -> Type + ghci> :k SameKind _ + +We want to get `k -> Type`, not `Any -> Type`, which is what we would +get without kind-generalisation. Note that `:k SameKind` is OK, as +GHC will not instantiate SameKind here, and so we see its full kind +of `forall k. k -> k -> Type`. + +************************************************************************ +* * + tcRnDeclsi +* * +************************************************************************ + +tcRnDeclsi exists to allow class, data, and other declarations in GHCi. +-} + +tcRnDeclsi :: HscEnv + -> [LHsDecl GhcPs] + -> IO (Messages, Maybe TcGblEnv) +tcRnDeclsi hsc_env local_decls + = runTcInteractive hsc_env $ + tcRnSrcDecls False Nothing local_decls + +externaliseAndTidyId :: Module -> Id -> TcM Id +externaliseAndTidyId this_mod id + = do { name' <- externaliseName this_mod (idName id) + ; return $ globaliseId id + `setIdName` name' + `setIdType` tidyTopType (idType id) } + + +{- +************************************************************************ +* * + More GHCi stuff, to do with browsing and getting info +* * +************************************************************************ +-} + +-- | ASSUMES that the module is either in the 'HomePackageTable' or is +-- a package module with an interface on disk. If neither of these is +-- true, then the result will be an error indicating the interface +-- could not be found. +getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) +getModuleInterface hsc_env mod + = runTcInteractive hsc_env $ + loadModuleInterface (text "getModuleInterface") mod + +tcRnLookupRdrName :: HscEnv -> Located RdrName + -> IO (Messages, Maybe [Name]) +-- ^ Find all the Names that this RdrName could mean, in GHCi +tcRnLookupRdrName hsc_env (L loc rdr_name) + = runTcInteractive hsc_env $ + setSrcSpan loc $ + do { -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let rdr_names = dataTcOccs rdr_name + ; names_s <- mapM lookupInfoOccRn rdr_names + ; let names = concat names_s + ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) + ; return names } + +tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) +tcRnLookupName hsc_env name + = runTcInteractive hsc_env $ + tcRnLookupName' name + +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: + +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" + +tcRnGetInfo :: HscEnv + -> Name + -> IO ( Messages + , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) + +-- Used to implement :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env name + = runTcInteractive hsc_env $ + do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + + ; thing <- tcRnLookupName' name + ; fixity <- lookupFixityRn name + ; (cls_insts, fam_insts) <- lookupInsts thing + ; let info = lookupKnownNameInfo name + ; return (thing, fixity, cls_insts, fam_insts, info) } + + +-- Lookup all class and family instances for a type constructor. +-- +-- This function filters all instances in the type environment, so there +-- is a lot of duplicated work if it is called many times in the same +-- type environment. If this becomes a problem, the NameEnv computed +-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions +-- could be changed to consult that index. +lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) +lookupInsts (ATyCon tc) + = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs + ; (pkg_fie, home_fie) <- tcGetFamInstEnvs + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + + -- Return only the instances relevant to the given thing, i.e. + -- the instances whose head contains the thing's name. + ; let cls_insts = + [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , instIsVisible vis_mods ispec + , tc_name `elemNameSet` orphNamesOfClsInst ispec ] + ; let fam_insts = + [ fispec + | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie + , tc_name `elemNameSet` orphNamesOfFamInst fispec ] + ; return (cls_insts, fam_insts) } + where + tc_name = tyConName tc + +lookupInsts _ = return ([],[]) + +loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () +-- Load the interface for everything that is in scope unqualified +-- This is so that we can accurately report the instances for +-- something +loadUnqualIfaces hsc_env ictxt + = initIfaceTcRn $ do + mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) + where + this_pkg = homeUnit (hsc_dflags hsc_env) + + unqual_mods = [ nameModule name + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) + , let name = gre_name gre + , nameIsFromExternalPackage this_pkg name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre ] -- In scope unqualified + doc = text "Need interface for module whose export(s) are in scope unqualified" + + + +{- +************************************************************************ +* * + Debugging output + This is what happens when you do -ddump-types +* * +************************************************************************ +-} + +-- | Dump, with a banner, if -ddump-rn +rnDump :: (Outputable a, Data a) => a -> TcRn () +rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) + +tcDump :: TcGblEnv -> TcRn () +tcDump env + = do { dflags <- getDynFlags ; + + -- Dump short output if -ddump-types or -ddump-tc + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) + "" FormatText short_dump) ; + + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; + + -- Dump bindings as an hsSyn AST if -ddump-tc-ast + dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump + } + where + short_dump = pprTcGblEnv env + full_dump = pprLHsBinds (tcg_binds env) + -- NB: foreign x-d's have undefined's in their types; + -- hence can't show the tc_fords + ast_dump = showAstData NoBlankSrcSpan (tcg_binds env) + +-- It's unpleasant having both pprModGuts and pprModDetails here +pprTcGblEnv :: TcGblEnv -> SDoc +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_imports = imports }) + = getPprDebug $ \debug -> + vcat [ ppr_types debug type_env + , ppr_tycons debug fam_insts type_env + , ppr_datacons debug type_env + , ppr_patsyns type_env + , ppr_insts insts + , ppr_fam_insts fam_insts + , ppr_rules rules + , text "Dependent modules:" <+> + pprUFM (imp_dep_mods imports) (ppr . sort) + , text "Dependent packages:" <+> + ppr (S.toList $ imp_dep_pkgs imports)] + -- The use of sort is just to reduce unnecessary + -- wobbling in testsuite output + +ppr_rules :: [LRuleDecl GhcTc] -> SDoc +ppr_rules rules + = ppUnless (null rules) $ + hang (text "RULES") + 2 (vcat (map ppr rules)) + +ppr_types :: Bool -> TypeEnv -> SDoc +ppr_types debug type_env + = ppr_things "TYPE SIGNATURES" ppr_sig + (sortBy (comparing getOccName) ids) + where + ids = [id | id <- typeEnvIds type_env, want_sig id] + want_sig id + | debug = True + | otherwise = hasTopUserName id + && case idDetails id of + VanillaId -> True + RecSelId {} -> True + ClassOpId {} -> True + FCallId {} -> True + _ -> False + -- Data cons (workers and wrappers), pattern synonyms, + -- etc are suppressed (unless -dppr-debug), + -- because they appear elsewhere + + ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id))) + +ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc +ppr_tycons debug fam_insts type_env + = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons + , ppr_things "COERCION AXIOMS" ppr_ax + (typeEnvCoAxioms type_env) ] + where + fi_tycons = famInstsRepTyCons fam_insts + + tycons = sortBy (comparing getOccName) $ + [tycon | tycon <- typeEnvTyCons type_env + , want_tycon tycon] + -- Sort by OccName to reduce unnecessary changes + want_tycon tycon | debug = True + | otherwise = isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + ppr_tc tc + = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc) + <> braces (ppr (tyConArity tc)) <+> dcolon) + 2 (ppr (tidyTopType (tyConKind tc))) + , nest 2 $ + ppWhen show_roles $ + text "roles" <+> (sep (map ppr roles)) ] + where + show_roles = debug || not (all (== boring_role) roles) + roles = tyConRoles tc + boring_role | isClassTyCon tc = Nominal + | otherwise = Representational + -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles + + ppr_ax ax = ppr (coAxiomToIfaceDecl ax) + -- We go via IfaceDecl rather than using pprCoAxiom + -- This way we get the full axiom (both LHS and RHS) with + -- wildcard binders tidied to _1, _2, etc. + +ppr_datacons :: Bool -> TypeEnv -> SDoc +ppr_datacons debug type_env + = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs + -- The filter gets rid of class data constructors + where + ppr_dc dc = sdocWithDynFlags (\dflags -> + ppr dc <+> dcolon <+> ppr (dataConDisplayType dflags dc)) + all_dcs = typeEnvDataCons type_env + wanted_dcs | debug = all_dcs + | otherwise = filterOut is_cls_dc all_dcs + is_cls_dc dc = isClassTyCon (dataConTyCon dc) + +ppr_patsyns :: TypeEnv -> SDoc +ppr_patsyns type_env + = ppr_things "PATTERN SYNONYMS" ppr_ps + (typeEnvPatSyns type_env) + where + ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts ispecs + = ppr_things "CLASS INSTANCES" pprInstance ispecs + +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts fam_insts + = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts + +ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc +ppr_things herald ppr_one things + | null things = empty + | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) + +hasTopUserName :: NamedThing x => x -> Bool +-- A top-level thing whose name is not "derived" +-- Thus excluding things like $tcX, from Typeable boilerplate +-- and C:Coll from class-dictionary data constructors +hasTopUserName x + = isExternalName name && not (isDerivedOccName (nameOccName name)) + where + name = getName x + +{- +******************************************************************************** + +Type Checker Plugins + +******************************************************************************** +-} + +withTcPlugins :: HscEnv -> TcM a -> TcM a +withTcPlugins hsc_env m = + do let plugins = getTcPlugins (hsc_dflags hsc_env) + case plugins of + [] -> m -- Common fast case + _ -> do ev_binds_var <- newTcEvBinds + (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins + -- This ensures that tcPluginStop is called even if a type + -- error occurs during compilation (Fix of #10078) + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m + mapM_ (flip runTcPluginM ev_binds_var) stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + startPlugin ev_binds_var (TcPlugin start solve stop) = + do s <- runTcPluginM start ev_binds_var + return (solve s, stop s) + +getTcPlugins :: DynFlags -> [GHC.Tc.Utils.Monad.TcPlugin] +getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) + + +withHoleFitPlugins :: HscEnv -> TcM a -> TcM a +withHoleFitPlugins hsc_env m = + case (getHfPlugins (hsc_dflags hsc_env)) of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins + -- This ensures that hfPluginStop is called even if a type + -- error occurs during compilation. + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m + sequence_ stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + startPlugin (HoleFitPluginR init plugin stop) = + do ref <- init + return (plugin ref, stop ref) + +getHfPlugins :: DynFlags -> [HoleFitPluginR] +getHfPlugins dflags = + catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args) + + +runRenamerPlugin :: TcGblEnv + -> HsGroup GhcRn + -> TcM (TcGblEnv, HsGroup GhcRn) +runRenamerPlugin gbl_env hs_group = do + dflags <- getDynFlags + withPlugins dflags + (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g)) + (gbl_env, hs_group) + + +-- XXX: should this really be a Maybe X? Check under which circumstances this +-- can become a Nothing and decide whether this should instead throw an +-- exception/signal an error. +type RenamedStuff = + (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], + Maybe LHsDocString)) + +-- | Extract the renamed information from TcGblEnv. +getRenamedStuff :: TcGblEnv -> RenamedStuff +getRenamedStuff tc_result + = fmap (\decls -> ( decls, tcg_rn_imports tc_result + , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) ) + (tcg_rn_decls tc_result) + +runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv +runTypecheckerPlugin sum hsc_env gbl_env = do + let dflags = hsc_dflags hsc_env + withPlugins dflags + (\p opts env -> mark_plugin_unsafe dflags + >> typeCheckResultAction p opts sum env) + gbl_env + +mark_plugin_unsafe :: DynFlags -> TcM () +mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ + recordUnsafeInfer pluginUnsafe + where + unsafeText = "Use of plugins makes the module unsafe" + pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan + (Outputable.text unsafeText) ) diff --git a/GHC/Tc/Module.hs-boot b/GHC/Tc/Module.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Module.hs-boot @@ -0,0 +1,12 @@ +module GHC.Tc.Module where + +import GHC.Prelude +import GHC.Core.Type(TyThing) +import GHC.Tc.Types (TcM) +import GHC.Utils.Outputable (SDoc) +import GHC.Types.Name (Name) + +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +missingBootThing :: Bool -> Name -> String -> SDoc +badReexportedBootThing :: Bool -> Name -> Name -> SDoc diff --git a/GHC/Tc/Plugin.hs b/GHC/Tc/Plugin.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Plugin.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP #-} +-- | This module provides an interface for typechecker plugins to +-- access select functions of the 'TcM', principally those to do with +-- reading parts of the state. +module GHC.Tc.Plugin ( + -- * Basic TcPluginM functionality + TcPluginM, + tcPluginIO, + tcPluginTrace, + unsafeTcPluginTcM, + + -- * Finding Modules and Names + FindResult(..), + findImportedModule, + lookupOrig, + + -- * Looking up Names in the typechecking environment + tcLookupGlobal, + tcLookupTyCon, + tcLookupDataCon, + tcLookupClass, + tcLookup, + tcLookupId, + + -- * Getting the TcM state + getTopEnv, + getEnvs, + getInstEnvs, + getFamInstEnvs, + matchFam, + + -- * Type variables + newUnique, + newFlexiTyVar, + isTouchableTcPluginM, + + -- * Zonking + zonkTcType, + zonkCt, + + -- * Creating constraints + newWanted, + newDerived, + newGiven, + newCoercionHole, + + -- * Manipulating evidence bindings + newEvVar, + setEvBind, + getEvBindsTcPluginM + ) where + +import GHC.Prelude + +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Solver.Monad as TcS +import qualified GHC.Tc.Utils.Env as TcM +import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Instance.Family as TcM +import qualified GHC.Iface.Env as IfaceEnv +import qualified GHC.Driver.Finder as Finder + +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM + , unsafeTcPluginTcM, getEvBindsTcPluginM + , liftIO, traceTc ) +import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) +import GHC.Tc.Utils.TcMType ( TcTyVar, TcType ) +import GHC.Tc.Utils.Env ( TcTyThing ) +import GHC.Tc.Types.Evidence ( TcCoercion, CoercionHole, EvTerm(..) + , EvExpr, EvBind, mkGivenEvBind ) +import GHC.Types.Var ( EvVar ) + +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Driver.Types +import GHC.Utils.Outputable +import GHC.Core.Type +import GHC.Core.Coercion ( BlockSubstFlag(..) ) +import GHC.Types.Id +import GHC.Core.InstEnv +import GHC.Data.FastString +import GHC.Types.Unique + + +-- | Perform some IO, typically to interact with an external tool. +tcPluginIO :: IO a -> TcPluginM a +tcPluginIO a = unsafeTcPluginTcM (liftIO a) + +-- | Output useful for debugging the compiler. +tcPluginTrace :: String -> SDoc -> TcPluginM () +tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) + + +findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult +findImportedModule mod_name mb_pkg = do + hsc_env <- getTopEnv + tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg + +lookupOrig :: Module -> OccName -> TcPluginM Name +lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod + + +tcLookupGlobal :: Name -> TcPluginM TyThing +tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal + +tcLookupTyCon :: Name -> TcPluginM TyCon +tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon + +tcLookupDataCon :: Name -> TcPluginM DataCon +tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon + +tcLookupClass :: Name -> TcPluginM Class +tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass + +tcLookup :: Name -> TcPluginM TcTyThing +tcLookup = unsafeTcPluginTcM . TcM.tcLookup + +tcLookupId :: Name -> TcPluginM Id +tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId + + +getTopEnv :: TcPluginM HscEnv +getTopEnv = unsafeTcPluginTcM TcM.getTopEnv + +getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) +getEnvs = unsafeTcPluginTcM TcM.getEnvs + +getInstEnvs :: TcPluginM InstEnvs +getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs + +getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) +getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs + +matchFam :: TyCon -> [Type] + -> TcPluginM (Maybe (TcCoercion, TcType)) +matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args + +newUnique :: TcPluginM Unique +newUnique = unsafeTcPluginTcM TcM.newUnique + +newFlexiTyVar :: Kind -> TcPluginM TcTyVar +newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar + +isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool +isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM + +-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. +zonkTcType :: TcType -> TcPluginM TcType +zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType + +zonkCt :: Ct -> TcPluginM Ct +zonkCt = unsafeTcPluginTcM . TcM.zonkCt + + +-- | Create a new wanted constraint. +newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence +newWanted loc pty + = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty) + +-- | Create a new derived constraint. +newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence +newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } + +-- | Create a new given constraint, with the supplied evidence. This +-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it +-- will panic. +newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence +newGiven loc pty evtm = do + new_ev <- newEvVar pty + setEvBind $ mkGivenEvBind new_ev (EvExpr evtm) + return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } + +-- | Create a fresh evidence variable. +newEvVar :: PredType -> TcPluginM EvVar +newEvVar = unsafeTcPluginTcM . TcM.newEvVar + +-- | Create a fresh coercion hole. +newCoercionHole :: PredType -> TcPluginM CoercionHole +newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst + +-- | Bind an evidence variable. This must not be invoked from +-- 'tcPluginInit' or 'tcPluginStop', or it will panic. +setEvBind :: EvBind -> TcPluginM () +setEvBind ev_bind = do + tc_evbinds <- getEvBindsTcPluginM + unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind diff --git a/GHC/Tc/Solver.hs b/GHC/Tc/Solver.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver.hs @@ -0,0 +1,2839 @@ +{-# LANGUAGE CPP #-} + +module GHC.Tc.Solver( + simplifyInfer, InferMode(..), + growThetaTyVars, + simplifyAmbiguityCheck, + simplifyDefault, + simplifyTop, simplifyTopImplic, + simplifyInteractive, + solveEqualities, solveLocalEqualities, solveLocalEqualitiesX, + simplifyWantedsTcM, + tcCheckSatisfiability, + tcNormalise, + + captureTopConstraints, + + simpl_top, + + promoteTyVarSet, emitFlatConstraints, + + -- For Rules we need these + solveWanteds, solveWantedsAndDrop, + approximateWC, runTcSDeriveds + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Core.Class ( Class, classKey, classTyCon ) +import GHC.Driver.Session +import GHC.Types.Id ( idType ) +import GHC.Tc.Utils.Instantiate +import GHC.Data.List.SetOps +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Builtin.Utils +import GHC.Builtin.Names +import GHC.Tc.Errors +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Interact +import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) +import GHC.Tc.Solver.Flatten ( flattenType ) +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Builtin.Types ( liftedRepTy, manyDataConTy ) +import GHC.Core.Unify ( tcMatchTyKi ) +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import GHC.Utils.Error ( emptyMessages ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Foldable ( toList ) +import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty(..) ) + +{- +********************************************************************************* +* * +* External interface * +* * +********************************************************************************* +-} + +captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureTopConstraints m) runs m, and returns the type constraints it +-- generates plus the constraints produced by static forms inside. +-- If it fails with an exception, it reports any insolubles +-- (out of scope variables) before doing so +-- +-- captureTopConstraints is used exclusively by GHC.Tc.Module at the top +-- level of a module. +-- +-- Importantly, if captureTopConstraints propagates an exception, it +-- reports any insoluble constraints first, lest they be lost +-- altogether. This is important, because solveLocalEqualities (maybe +-- other things too) throws an exception without adding any error +-- messages; it just puts the unsolved constraints back into the +-- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors] +-- #16376 is an example of what goes wrong if you don't do this. +-- +-- NB: the caller should bring any environments into scope before +-- calling this, so that the reportUnsolved has access to the most +-- complete GlobalRdrEnv +captureTopConstraints thing_inside + = do { static_wc_var <- TcM.newTcRef emptyWC ; + ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ + TcM.tryCaptureConstraints thing_inside + ; stWC <- TcM.readTcRef static_wc_var + + -- See GHC.Tc.Utils.Monad Note [Constraints and errors] + -- If the thing_inside threw an exception, but generated some insoluble + -- constraints, report the latter before propagating the exception + -- Otherwise they will be lost altogether + ; case mb_res of + Just res -> return (res, lie `andWC` stWC) + Nothing -> do { _ <- simplifyTop lie; failM } } + -- This call to simplifyTop is the reason + -- this function is here instead of GHC.Tc.Utils.Monad + -- We call simplifyTop so that it does defaulting + -- (esp of runtime-reps) before reporting errors + +simplifyTopImplic :: Bag Implication -> TcM () +simplifyTopImplic implics + = do { empty_binds <- simplifyTop (mkImplicWC implics) + + -- Since all the inputs are implications the returned bindings will be empty + ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds ) + + ; return () } + +simplifyTop :: WantedConstraints -> TcM (Bag EvBind) +-- Simplify top-level constraints +-- Usually these will be implications, +-- but when there is nothing to quantify we don't wrap +-- in a degenerate implication, so we do that here instead +simplifyTop wanteds + = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds + ; ((final_wc, unsafe_ol), binds1) <- runTcS $ + do { final_wc <- simpl_top wanteds + ; unsafe_ol <- getSafeOverlapFailures + ; return (final_wc, unsafe_ol) } + ; traceTc "End simplifyTop }" empty + + ; binds2 <- reportUnsolved final_wc + + ; traceTc "reportUnsolved (unsafe overlapping) {" empty + ; unless (isEmptyCts unsafe_ol) $ do { + -- grab current error messages and clear, warnAllUnsolved will + -- update error messages which we'll grab and then restore saved + -- messages. + ; errs_var <- getErrsVar + ; saved_msg <- TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var emptyMessages + + ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol } + + ; whyUnsafe <- fst <$> TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var saved_msg + ; recordUnsafeInfer whyUnsafe + } + ; traceTc "reportUnsolved (unsafe overlapping) }" empty + + ; return (evBindMapBinds binds1 `unionBags` binds2) } + + +-- | Type-check a thing that emits only equality constraints, solving any +-- constraints we can and re-emitting constraints that we can't. The thing_inside +-- should generally bump the TcLevel to make sure that this run of the solver +-- doesn't affect anything lying around. +solveLocalEqualities :: String -> TcM a -> TcM a +-- Note [Failure in local type signatures] +solveLocalEqualities callsite thing_inside + = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside + ; emitFlatConstraints wanted + ; return res } + +emitFlatConstraints :: WantedConstraints -> TcM () +-- See Note [Failure in local type signatures] +emitFlatConstraints wanted + = do { wanted <- TcM.zonkWC wanted + ; case floatKindEqualities wanted of + Nothing -> do { traceTc "emitFlatConstraints: failing" (ppr wanted) + ; emitConstraints wanted -- So they get reported! + ; failM } + Just (simples, holes) + -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples) + ; traceTc "emitFlatConstraints:" $ + vcat [ text "simples:" <+> ppr simples + , text "holes: " <+> ppr holes ] + ; emitHoles holes -- Holes don't need promotion + ; emitSimples simples } } + +floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole) +-- Float out all the constraints from the WantedConstraints, +-- Return Nothing if any constraints can't be floated (captured +-- by skolems), or if there is an insoluble constraint, or +-- IC_Telescope telescope error +floatKindEqualities wc = float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole) + float_wc trapping_tvs (WC { wc_simple = simples + , wc_impl = implics + , wc_holes = holes }) + | all is_floatable simples + = do { (inner_simples, inner_holes) + <- flatMapBagPairM (float_implic trapping_tvs) implics + ; return ( simples `unionBags` inner_simples + , holes `unionBags` inner_holes) } + | otherwise + = Nothing + where + is_floatable ct + | insolubleEqCt ct = False + | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs + + float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole) + float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_no_eqs = no_eqs + , ic_skols = skols, ic_status = status }) + | isInsolubleStatus status + = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope + | otherwise + = do { (simples, holes) <- float_wc new_trapping_tvs wanted + ; when (not (isEmptyBag simples) && not no_eqs) $ + Nothing + -- If there are some constraints to float out, but we can't + -- because we don't float out past local equalities + -- (c.f GHC.Tc.Solver.approximateWC), then fail + ; return (simples, holes) } + where + new_trapping_tvs = trapping_tvs `extendVarSetList` skols + + +{- Note [Failure in local type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind checking a type signature, we like to fail fast if we can't +solve all the kind equality constraints: see Note [Fail fast on kind +errors]. But what about /local/ type signatures, mentioning in-scope +type variables for which there might be given equalities. Here's +an example (T15076b): + + class (a ~ b) => C a b + data SameKind :: k -> k -> Type where { SK :: SameKind a b } + + bar :: forall (a :: Type) (b :: Type). + C a b => Proxy a -> Proxy b -> () + bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y) + +Consider the type singature on 'undefined'. It's ill-kinded unless +a~b. But the superclass of (C a b) means that indeed (a~b). So all +should be well. BUT it's hard to see that when kind-checking the signature +for undefined. We want to emit a residual (a~b) constraint, to solve +later. + +Another possiblity is that we might have something like + F alpha ~ [Int] +where alpha is bound further out, which might become soluble +"later" when we learn more about alpha. So we want to emit +those residual constraints. + +BUT it's no good simply wrapping all unsolved constraints from +a type signature in an implication constraint to solve later. The +problem is that we are going to /use/ that signature, including +instantiate it. Say we have + f :: forall a. (forall b. blah) -> blah2 + f x = +To typecheck the definition of f, we have to instantiate those +foralls. Moreover, any unsolved kind equalities will be coercion +holes in the type. If we naively wrap them in an implication like + forall a. (co1:k1~k2, forall b. co2:k3~k4) +hoping to solve it later, we might end up filling in the holes +co1 and co2 with coercions involving 'a' and 'b' -- but by now +we've instantiated the type. Chaos! + +Moreover, the unsolved constraints might be skolem-escpae things, and +if we proceed with f bound to a nonsensical type, we get a cascade of +follow-up errors. For example polykinds/T12593, T15577, and many others. + +So here's the plan: + +* solveLocalEqualitiesX: try to solve the constraints (solveLocalEqualitiesX) + +* buildTvImplication: build an implication for the residual, unsolved + constraint + +* emitFlatConstraints: try to float out every unsolved equalities + inside that implication, in the hope that it constrains only global + type variables, not the locally-quantified ones. + + * If we fail, or find an insoluble constraint, emit the implication, + so that the errors will be reported, and fail. + + * If we succeed in floating all the equalities, promote them and + re-emit them as flat constraint, not wrapped at all (since they + don't mention any of the quantified variables. + +* Note that this float-and-promote step means that anonymous + wildcards get floated to top level, as we want; see + Note [Checking partial type signatures] in GHC.Tc.Gen.HsType. + +All this is done: + +* in solveLocalEqualities, where there is no kind-generalisation + to complicate matters. + +* in GHC.Tc.Gen.HsType.tcHsSigType, where quantification intervenes. + +See also #18062, #11506 +-} + +solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) +solveLocalEqualitiesX callsite thing_inside + = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) + + ; (result, wanted) <- captureConstraints thing_inside + + ; traceTc "solveLocalEqualities: running solver" (ppr wanted) + ; residual_wanted <- runTcSEqualities (solveWanteds wanted) + + ; traceTc "solveLocalEqualitiesX end }" $ + text "residual_wanted =" <+> ppr residual_wanted + + ; return (residual_wanted, result) } + +-- | Type-check a thing that emits only equality constraints, then +-- solve those constraints. Fails outright if there is trouble. +-- Use this if you're not going to get another crack at solving +-- (because, e.g., you're checking a datatype declaration) +solveEqualities :: TcM a -> TcM a +solveEqualities thing_inside + = checkNoErrs $ -- See Note [Fail fast on kind errors] + do { lvl <- TcM.getTcLevel + ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl) + + ; (result, wanted) <- captureConstraints thing_inside + + ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted + ; final_wc <- runTcSEqualities $ simpl_top wanted + -- NB: Use simpl_top here so that we potentially default RuntimeRep + -- vars to LiftedRep. This is needed to avoid #14991. + + ; traceTc "End solveEqualities }" empty + ; reportAllUnsolved final_wc + ; return result } + +-- | Simplify top-level constraints, but without reporting any unsolved +-- constraints nor unsafe overlapping. +simpl_top :: WantedConstraints -> TcS WantedConstraints + -- See Note [Top-level Defaulting Plan] +simpl_top wanteds + = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) + -- This is where the main work happens + ; dflags <- getDynFlags + ; try_tyvar_defaulting dflags wc_first_go } + where + try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints + try_tyvar_defaulting dflags wc + | isEmptyWC wc + = return wc + | insolubleWC wc + , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] + = try_class_defaulting wc + | otherwise + = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) + ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs + -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked + -- filter isMetaTyVar: we might have runtime-skolems in GHCi, + -- and we definitely don't want to try to assign to those! + -- The isTyVar is needed to weed out coercion variables + + ; defaulted <- mapM defaultTyVarTcS meta_tvs -- Has unification side effects + ; if or defaulted + then do { wc_residual <- nestTcS (solveWanteds wc) + -- See Note [Must simplify after defaulting] + ; try_class_defaulting wc_residual } + else try_class_defaulting wc } -- No defaulting took place + + try_class_defaulting :: WantedConstraints -> TcS WantedConstraints + try_class_defaulting wc + | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] + = return wc + | otherwise -- See Note [When to do type-class defaulting] + = do { something_happened <- applyDefaultingRules wc + -- See Note [Top-level Defaulting Plan] + ; if something_happened + then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) + ; try_class_defaulting wc_residual } + -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + else try_callstack_defaulting wc } + + try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints + try_callstack_defaulting wc + | isEmptyWC wc + = return wc + | otherwise + = defaultCallStacks wc + +-- | Default any remaining @CallStack@ constraints to empty @CallStack@s. +defaultCallStacks :: WantedConstraints -> TcS WantedConstraints +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +defaultCallStacks wanteds + = do simples <- handle_simples (wc_simple wanteds) + mb_implics <- mapBagM handle_implic (wc_impl wanteds) + return (wanteds { wc_simple = simples + , wc_impl = catBagMaybes mb_implics }) + + where + + handle_simples simples + = catBagMaybes <$> mapBagM defaultCallStack simples + + handle_implic :: Implication -> TcS (Maybe Implication) + -- The Maybe is because solving the CallStack constraint + -- may well allow us to discard the implication entirely + handle_implic implic + | isSolvedStatus (ic_status implic) + = return (Just implic) + | otherwise + = do { wanteds <- setEvBindsTcS (ic_binds implic) $ + -- defaultCallStack sets a binding, so + -- we must set the correct binding group + defaultCallStacks (ic_wanted implic) + ; setImplicationStatus (implic { ic_wanted = wanteds }) } + + defaultCallStack ct + | ClassPred cls tys <- classifyPredType (ctPred ct) + , Just {} <- isCallStackPred cls tys + = do { solveCallStack (ctEvidence ct) EvCsEmpty + ; return Nothing } + + defaultCallStack ct + = return (Just ct) + + +{- Note [Fail fast on kind errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +solveEqualities is used to solve kind equalities when kind-checking +user-written types. If solving fails we should fail outright, rather +than just accumulate an error message, for two reasons: + + * A kind-bogus type signature may cause a cascade of knock-on + errors if we let it pass + + * More seriously, we don't have a convenient term-level place to add + deferred bindings for unsolved kind-equality constraints, so we + don't build evidence bindings (by usine reportAllUnsolved). That + means that we'll be left with a type that has coercion holes + in it, something like + |> co-hole + where co-hole is not filled in. Eeek! That un-filled-in + hole actually causes GHC to crash with "fvProv falls into a hole" + See #11563, #11520, #11516, #11399 + +So it's important to use 'checkNoErrs' here! + +Note [When to do type-class defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC +was false, on the grounds that defaulting can't help solve insoluble +constraints. But if we *don't* do defaulting we may report a whole +lot of errors that would be solved by defaulting; these errors are +quite spurious because fixing the single insoluble error means that +defaulting happens again, which makes all the other errors go away. +This is jolly confusing: #9033. + +So it seems better to always do type-class defaulting. + +However, always doing defaulting does mean that we'll do it in +situations like this (#5934): + run :: (forall s. GenST s) -> Int + run = fromInteger 0 +We don't unify the return type of fromInteger with the given function +type, because the latter involves foralls. So we're left with + (Num alpha, alpha ~ (forall s. GenST s) -> Int) +Now we do defaulting, get alpha := Integer, and report that we can't +match Integer with (forall s. GenST s) -> Int. That's not totally +stupid, but perhaps a little strange. + +Another potential alternative would be to suppress *all* non-insoluble +errors if there are *any* insoluble errors, anywhere, but that seems +too drastic. + +Note [Must simplify after defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a deeply buried constraint + (t:*) ~ (a:Open) +which we couldn't solve because of the kind incompatibility, and 'a' is free. +Then when we default 'a' we can solve the constraint. And we want to do +that before starting in on type classes. We MUST do it before reporting +errors, because it isn't an error! #7967 was due to this. + +Note [Top-level Defaulting Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have considered two design choices for where/when to apply defaulting. + (i) Do it in SimplCheck mode only /whenever/ you try to solve some + simple constraints, maybe deep inside the context of implications. + This used to be the case in GHC 7.4.1. + (ii) Do it in a tight loop at simplifyTop, once all other constraints have + finished. This is the current story. + +Option (i) had many disadvantages: + a) Firstly, it was deep inside the actual solver. + b) Secondly, it was dependent on the context (Infer a type signature, + or Check a type signature, or Interactive) since we did not want + to always start defaulting when inferring (though there is an exception to + this, see Note [Default while Inferring]). + c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: + f :: Int -> Bool + f x = const True (\y -> let w :: a -> a + w a = const a (y+1) + in w y) + We will get an implication constraint (for beta the type of y): + [untch=beta] forall a. 0 => Num beta + which we really cannot default /while solving/ the implication, since beta is + untouchable. + +Instead our new defaulting story is to pull defaulting out of the solver loop and +go with option (ii), implemented at SimplifyTop. Namely: + - First, have a go at solving the residual constraint of the whole + program + - Try to approximate it with a simple constraint + - Figure out derived defaulting equations for that simple constraint + - Go round the loop again if you did manage to get some equations + +Now, that has to do with class defaulting. However there exists type variable /kind/ +defaulting. Again this is done at the top-level and the plan is: + - At the top-level, once you had a go at solving the constraint, do + figure out /all/ the touchable unification variables of the wanted constraints. + - Apply defaulting to their kinds + +More details in Note [DefaultTyVar]. + +Note [Safe Haskell Overlapping Instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Safe Haskell, we apply an extra restriction to overlapping instances. The +motive is to prevent untrusted code provided by a third-party, changing the +behavior of trusted code through type-classes. This is due to the global and +implicit nature of type-classes that can hide the source of the dictionary. + +Another way to state this is: if a module M compiles without importing another +module N, changing M to import N shouldn't change the behavior of M. + +Overlapping instances with type-classes can violate this principle. However, +overlapping instances aren't always unsafe. They are just unsafe when the most +selected dictionary comes from untrusted code (code compiled with -XSafe) and +overlaps instances provided by other modules. + +In particular, in Safe Haskell at a call site with overlapping instances, we +apply the following rule to determine if it is a 'unsafe' overlap: + + 1) Most specific instance, I1, defined in an `-XSafe` compiled module. + 2) I1 is an orphan instance or a MPTC. + 3) At least one overlapped instance, Ix, is both: + A) from a different module than I1 + B) Ix is not marked `OVERLAPPABLE` + +This is a slightly involved heuristic, but captures the situation of an +imported module N changing the behavior of existing code. For example, if +condition (2) isn't violated, then the module author M must depend either on a +type-class or type defined in N. + +Secondly, when should these heuristics be enforced? We enforced them when the +type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. +This allows `-XUnsafe` modules to operate without restriction, and for Safe +Haskell inferrence to infer modules with unsafe overlaps as unsafe. + +One alternative design would be to also consider if an instance was imported as +a `safe` import or not and only apply the restriction to instances imported +safely. However, since instances are global and can be imported through more +than one path, this alternative doesn't work. + +Note [Safe Haskell Overlapping Instances Implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +How is this implemented? It's complicated! So we'll step through it all: + + 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where + we check if a particular type-class method call is safe or unsafe. We do this + through the return type, `ClsInstLookupResult`, where the last parameter is a + list of instances that are unsafe to overlap. When the method call is safe, + the list is null. + + 2) `GHC.Tc.Solver.Interact.matchClassInst` -- This module drives the instance resolution + / dictionary generation. The return type is `ClsInstResult`, which either + says no instance matched, or one found, and if it was a safe or unsafe + overlap. + + 3) `GHC.Tc.Solver.Interact.doTopReactDict` -- Takes a dictionary / class constraint and + tries to resolve it by calling (in part) `matchClassInst`. The resolving + mechanism has a work list (of constraints) that it process one at a time. If + the constraint can't be resolved, it's added to an inert set. When compiling + an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know + compilation should fail. These are handled as normal constraint resolution + failures from here-on (see step 6). + + Otherwise, we may be inferring safety (or using `-Wunsafe`), and + compilation should succeed, but print warnings and/or mark the compiled module + as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds + the unsafe (but resolved!) constraint to the `inert_safehask` field of + `InertCans`. + + 4) `GHC.Tc.Solver.simplifyTop`: + * Call simpl_top, the top-level function for driving the simplifier for + constraint resolution. + + * Once finished, call `getSafeOverlapFailures` to retrieve the + list of overlapping instances that were successfully resolved, + but unsafe. Remember, this is only applicable for generating warnings + (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` + cause compilation failure by not resolving the unsafe constraint at all. + + * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`, + while for resolved but unsafe overlapping dictionary constraints, call + `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a + warning message for the user. + + * In the case of `warnAllUnsolved` for resolved, but unsafe + dictionary constraints, we collect the generated warning + message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to + mark the module we are compiling as unsafe, passing the + warning message along as the reason. + + 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by + actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we + know is the constraint that is unresolved or unsafe. For dictionary, all we + know is that we need a dictionary of type C, but not what instances are + available and how they overlap. So we once again call `lookupInstEnv` to + figure that out so we can generate a helpful error message. + + 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an + IORef called `tcg_safeInfer`. + + 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling + `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence + failed. + +Note [No defaulting in the ambiguity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying constraints for the ambiguity check, we use +solveWantedsAndDrop, not simpl_top, so that we do no defaulting. +#11947 was an example: + f :: Num a => Int -> Int +This is ambiguous of course, but we don't want to default the +(Num alpha) constraint to (Num Int)! Doing so gives a defaulting +warning, but no error. + +Note [Defaulting insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a set of wanteds is insoluble, we have no hope of accepting the +program. Yet we do not stop constraint solving, etc., because we may +simplify the wanteds to produce better error messages. So, once +we have an insoluble constraint, everything we do is just about producing +helpful error messages. + +Should we default in this case or not? Let's look at an example (tcfail004): + + (f,g) = (1,2,3) + +With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). +Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) +find the latter more helpful. Several other test cases (e.g. tcfail005) suggest +similarly. So: we should not do class defaulting with insolubles. + +On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: + + f :: Integer i => i + f = 0 + +Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind +TYPE r0 -> Constraint and then complains that r0 is actually untouchable +(presumably, because it can't be sure if `Integer i` entails an equality). +If we default, we are told of a clash between (* -> Constraint) and Constraint. +The latter seems far better, suggesting we *should* do RuntimeRep-defaulting +even on insolubles. + +But, evidently, not always. Witness UnliftedNewtypesInfinite: + + newtype Foo = FooC (# Int#, Foo #) + +This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). +If we default RuntimeRep-vars, we get + + Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted + +which is just plain wrong. + +Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not +want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps +is not set. +-} + +------------------ +simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () +simplifyAmbiguityCheck ty wanteds + = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) + ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds + -- NB: no defaulting! See Note [No defaulting in the ambiguity check] + + ; traceTc "End simplifyAmbiguityCheck }" empty + + -- Normally report all errors; but with -XAllowAmbiguousTypes + -- report only insoluble ones, since they represent genuinely + -- inaccessible code + ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes + ; traceTc "reportUnsolved(ambig) {" empty + ; unless (allow_ambiguous && not (insolubleWC final_wc)) + (discardResult (reportUnsolved final_wc)) + ; traceTc "reportUnsolved(ambig) }" empty + + ; return () } + +------------------ +simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) +simplifyInteractive wanteds + = traceTc "simplifyInteractive" empty >> + simplifyTop wanteds + +------------------ +simplifyDefault :: ThetaType -- Wanted; has no type variables in it + -> TcM () -- Succeeds if the constraint is soluble +simplifyDefault theta + = do { traceTc "simplifyDefault" empty + ; wanteds <- newWanteds DefaultOrigin theta + ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) + ; reportAllUnsolved unsolved + ; return () } + +------------------ +tcCheckSatisfiability :: Bag EvVar -> TcM Bool +-- Return True if satisfiable, False if definitely contradictory +tcCheckSatisfiability given_ids + = do { lcl_env <- TcM.getLclEnv + ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + ; (res, _ev_binds) <- runTcS $ + do { traceTcS "checkSatisfiability {" (ppr given_ids) + ; let given_cts = mkGivens given_loc (bagToList given_ids) + -- See Note [Superclasses and satisfiability] + ; solveSimpleGivens given_cts + ; insols <- getInertInsols + ; insols <- try_harder insols + ; traceTcS "checkSatisfiability }" (ppr insols) + ; return (isEmptyBag insols) } + ; return res } + where + try_harder :: Cts -> TcS Cts + -- Maybe we have to search up the superclass chain to find + -- an unsatisfiable constraint. Example: pmcheck/T3927b. + -- At the moment we try just once + try_harder insols + | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable + = return insols -- Hurrah -- stop now. + | otherwise + = do { pending_given <- getPendingGivenScs + ; new_given <- makeSuperClasses pending_given + ; solveSimpleGivens new_given + ; getInertInsols } + +-- | Normalise a type as much as possible using the given constraints. +-- See @Note [tcNormalise]@. +tcNormalise :: Bag EvVar -> Type -> TcM Type +tcNormalise given_ids ty + = do { lcl_env <- TcM.getLclEnv + ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + ; norm_loc <- getCtLocM PatCheckOrigin Nothing + ; (res, _ev_binds) <- runTcS $ + do { traceTcS "tcNormalise {" (ppr given_ids) + ; let given_cts = mkGivens given_loc (bagToList given_ids) + ; solveSimpleGivens given_cts + ; ty' <- flattenType norm_loc ty + ; traceTcS "tcNormalise }" (ppr ty') + ; pure ty' } + ; return res } + +{- Note [Superclasses and satisfiability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expand superclasses before starting, because (Int ~ Bool), has +(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) +as a superclass, and it's the latter that is insoluble. See +Note [The equality types story] in GHC.Builtin.Types.Prim. + +If we fail to prove unsatisfiability we (arbitrarily) try just once to +find superclasses, using try_harder. Reason: we might have a type +signature + f :: F op (Implements push) => .. +where F is a type function. This happened in #3972. + +We could do more than once but we'd have to have /some/ limit: in the +the recursive case, we would go on forever in the common case where +the constraints /are/ satisfiable (#10592 comment:12!). + +For stratightforard situations without type functions the try_harder +step does nothing. + +Note [tcNormalise] +~~~~~~~~~~~~~~~~~~ +tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas +most invocations of the constraint solver are intended to simplify a set of +constraints or to decide if a particular set of constraints is satisfiable, +the purpose of tcNormalise is to take a type, plus some local constraints, and +normalise the type as much as possible with respect to those constraints. + +It does *not* reduce type or data family applications or look through newtypes. + +Why is this useful? As one example, when coverage-checking an EmptyCase +expression, it's possible that the type of the scrutinee will only reduce +if some local equalities are solved for. See "Wrinkle: Local equalities" +in Note [Type normalisation] in "GHC.HsToCore.PmCheck". + +To accomplish its stated goal, tcNormalise first feeds the local constraints +into solveSimpleGivens, then uses flattenType to simplify the desired type +with respect to the givens. + +*********************************************************************************** +* * +* Inference +* * +*********************************************************************************** + +Note [Inferring the type of a let-bound variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = rhs + +To infer f's type we do the following: + * Gather the constraints for the RHS with ambient level *one more than* + the current one. This is done by the call + pushLevelAndCaptureConstraints (tcMonoBinds...) + in GHC.Tc.Gen.Bind.tcPolyInfer + + * Call simplifyInfer to simplify the constraints and decide what to + quantify over. We pass in the level used for the RHS constraints, + here called rhs_tclvl. + +This ensures that the implication constraint we generate, if any, +has a strictly-increased level compared to the ambient level outside +the let binding. + +-} + +-- | How should we choose which constraints to quantify over? +data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, + -- never quantifying over any constraints + | EagerDefaulting -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module", + -- the :type +d case; this mode refuses + -- to quantify over any defaultable constraint + | NoRestrictions -- ^ Quantify over any constraint that + -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds' + +instance Outputable InferMode where + ppr ApplyMR = text "ApplyMR" + ppr EagerDefaulting = text "EagerDefaulting" + ppr NoRestrictions = text "NoRestrictions" + +simplifyInfer :: TcLevel -- Used when generating the constraints + -> InferMode + -> [TcIdSigInst] -- Any signatures (possibly partial) + -> [(Name, TcTauType)] -- Variables to be generalised, + -- and their tau-types + -> WantedConstraints + -> TcM ([TcTyVar], -- Quantify over these type variables + [EvVar], -- ... and these constraints (fully zonked) + TcEvBinds, -- ... binding these evidence variables + WantedConstraints, -- Redidual as-yet-unsolved constraints + Bool) -- True <=> the residual constraints are insoluble + +simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds + | isEmptyWC wanteds + = do { -- When quantifying, we want to preserve any order of variables as they + -- appear in partial signatures. cf. decideQuantifiedTyVars + let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs + , (_,Bndr tv _) <- sig_inst_skols sig ] + psig_theta = [ pred | sig <- partial_sigs + , pred <- sig_inst_theta sig ] + + ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) + ; qtkvs <- quantifyTyVars dep_vars + ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) + ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } + + | otherwise + = do { traceTc "simplifyInfer {" $ vcat + [ text "sigs =" <+> ppr sigs + , text "binds =" <+> ppr name_taus + , text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "infer_mode =" <+> ppr infer_mode + , text "(unzonked) wanted =" <+> ppr wanteds + ] + + ; let psig_theta = concatMap sig_inst_theta partial_sigs + + -- First do full-blown solving + -- NB: we must gather up all the bindings from doing + -- this solving; hence (runTcSWithEvBinds ev_binds_var). + -- And note that since there are nested implications, + -- calling solveWanteds will side-effect their evidence + -- bindings, so we can't just revert to the input + -- constraint. + + ; tc_env <- TcM.getEnv + ; ev_binds_var <- TcM.newTcEvBinds + ; psig_theta_vars <- mapM TcM.newEvVar psig_theta + ; wanted_transformed_incl_derivs + <- setTcLevel rhs_tclvl $ + runTcSWithEvBinds ev_binds_var $ + do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ + env_lcl tc_env + psig_givens = mkGivens loc psig_theta_vars + ; _ <- solveSimpleGivens psig_givens + -- See Note [Add signature contexts as givens] + ; solveWanteds wanteds } + + -- Find quant_pred_candidates, the predicates that + -- we'll consider quantifying over + -- NB1: wanted_transformed does not include anything provable from + -- the psig_theta; it's just the extra bit + -- NB2: We do not do any defaulting when inferring a type, this can lead + -- to less polymorphic types, see Note [Default while Inferring] + ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs + ; let definite_error = insolubleWC wanted_transformed_incl_derivs + -- See Note [Quantification with errors] + -- NB: must include derived errors in this test, + -- hence "incl_derivs" + wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs + quant_pred_candidates + | definite_error = [] + | otherwise = ctsPreds (approximateWC False wanted_transformed) + + -- Decide what type variables and constraints to quantify + -- NB: quant_pred_candidates is already fully zonked + -- NB: bound_theta are constraints we want to quantify over, + -- including the psig_theta, which we always quantify over + -- NB: bound_theta are fully zonked + ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl + name_taus partial_sigs + quant_pred_candidates + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + + -- We must produce bindings for the psig_theta_vars, because we may have + -- used them in evidence bindings constructed by solveWanteds earlier + -- Easiest way to do this is to emit them as new Wanteds (#14643) + ; ct_loc <- getCtLocM AnnOrigin Nothing + ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var + , ctev_dest = EvVarDest psig_theta_var + , ctev_nosh = WDeriv + , ctev_loc = ct_loc } + | psig_theta_var <- psig_theta_vars ] + + -- Now construct the residual constraint + ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var + name_taus co_vars qtvs bound_theta_vars + (wanted_transformed `andWC` mkSimpleWC psig_wanted) + + -- All done! + ; traceTc "} simplifyInfer/produced residual implication for quantification" $ + vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates + , text "psig_theta =" <+> ppr psig_theta + , text "bound_theta =" <+> ppr bound_theta + , text "qtvs =" <+> ppr qtvs + , text "definite_error =" <+> ppr definite_error ] + + ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var + , residual_wanted, definite_error ) } + -- NB: bound_theta_vars must be fully zonked + where + partial_sigs = filter isPartialSig sigs + +-------------------- +mkResidualConstraints :: TcLevel -> EvBindsVar + -> [(Name, TcTauType)] + -> VarSet -> [TcTyVar] -> [EvVar] + -> WantedConstraints -> TcM WantedConstraints +-- Emit the remaining constraints from the RHS. +-- See Note [Emitting the residual implication in simplifyInfer] +mkResidualConstraints rhs_tclvl ev_binds_var + name_taus co_vars qtvs full_theta_vars wanteds + | isEmptyWC wanteds + = return wanteds + + | otherwise + = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds) + ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple + is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars + + ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple) + + ; let inner_wanted = wanteds { wc_simple = inner_simple } + ; implics <- if isEmptyWC inner_wanted + then return emptyBag + else do implic1 <- newImplication + return $ unitBag $ + implic1 { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_no_eqs = False + , ic_info = skol_info } + + ; return (emptyWC { wc_simple = outer_simple + , wc_impl = implics })} + where + full_theta = map idType full_theta_vars + skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) + | (name, ty) <- name_taus ] + -- Don't add the quantified variables here, because + -- they are also bound in ic_skols and we want them + -- to be tidied uniformly + +-------------------- +ctsPreds :: Cts -> [PredType] +ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts + , let ev = ctEvidence ct ] + +{- Note [Emitting the residual implication in simplifyInfer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = e +where f's type is inferred to be something like (a, Proxy k (Int |> co)) +and we have an as-yet-unsolved, or perhaps insoluble, constraint + [W] co :: Type ~ k +We can't form types like (forall co. blah), so we can't generalise over +the coercion variable, and hence we can't generalise over things free in +its kind, in the case 'k'. But we can still generalise over 'a'. So +we'll generalise to + f :: forall a. (a, Proxy k (Int |> co)) +Now we do NOT want to form the residual implication constraint + forall a. [W] co :: Type ~ k +because then co's eventual binding (which will be a value binding if we +use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose +type mentions 'co'). Instead, just as we don't generalise over 'co', we +should not bury its constraint inside the implication. Instead, we must +put it outside. + +That is the reason for the partitionBag in emitResidualConstraints, +which takes the CoVars free in the inferred type, and pulls their +constraints out. (NB: this set of CoVars should be closed-over-kinds.) + +All rather subtle; see #14584. + +Note [Add signature contexts as givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#11016): + f2 :: (?x :: Int) => _ + f2 = ?x +or this + f3 :: a ~ Bool => (a, _) + f3 = (True, False) +or theis + f4 :: (Ord a, _) => a -> Bool + f4 x = x==x + +We'll use plan InferGen because there are holes in the type. But: + * For f2 we want to have the (?x :: Int) constraint floating around + so that the functional dependencies kick in. Otherwise the + occurrence of ?x on the RHS produces constraint (?x :: alpha), and + we won't unify alpha:=Int. + * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool) + in the RHS + * For f4 we want to use the (Ord a) in the signature to solve the Eq a + constraint. + +Solution: in simplifyInfer, just before simplifying the constraints +gathered from the RHS, add Given constraints for the context of any +type signatures. + +************************************************************************ +* * + Quantification +* * +************************************************************************ + +Note [Deciding quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the monomorphism restriction does not apply, then we quantify as follows: + +* Step 1. Take the global tyvars, and "grow" them using the equality + constraints + E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can + happen because alpha is untouchable here) then do not quantify over + beta, because alpha fixes beta, and beta is effectively free in + the environment too + + We also account for the monomorphism restriction; if it applies, + add the free vars of all the constraints. + + Result is mono_tvs; we will not quantify over these. + +* Step 2. Default any non-mono tyvars (i.e ones that are definitely + not going to become further constrained), and re-simplify the + candidate constraints. + + Motivation for re-simplification (#7857): imagine we have a + constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are + not free in the envt, and instance forall (a::*) (b::*). (C a) => C + (a -> b) The instance doesn't match while l1,l2 are polymorphic, but + it will match when we default them to LiftedRep. + + This is all very tiresome. + +* Step 3: decide which variables to quantify over, as follows: + + - Take the free vars of the tau-type (zonked_tau_tvs) and "grow" + them using all the constraints. These are tau_tvs_plus + + - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being + careful to close over kinds, and to skolemise the quantified tyvars. + (This actually unifies each quantifies meta-tyvar with a fresh skolem.) + + Result is qtvs. + +* Step 4: Filter the constraints using pickQuantifiablePreds and the + qtvs. We have to zonk the constraints first, so they "see" the + freshly created skolems. + +-} + +decideQuantification + :: InferMode + -> TcLevel + -> [(Name, TcTauType)] -- Variables to be generalised + -> [TcIdSigInst] -- Partial type signatures (if any) + -> [PredType] -- Candidate theta; already zonked + -> TcM ( [TcTyVar] -- Quantify over these (skolems) + , [PredType] -- and this context (fully zonked) + , VarSet) +-- See Note [Deciding quantification] +decideQuantification infer_mode rhs_tclvl name_taus psigs candidates + = do { -- Step 1: find the mono_tvs + ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode + name_taus psigs candidates + + -- Step 2: default any non-mono tyvars, and re-simplify + -- This step may do some unification, but result candidates is zonked + ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates + + -- Step 3: decide which kind/type variables to quantify over + ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates + + -- Step 4: choose which of the remaining candidate + -- predicates to actually quantify over + -- NB: decideQuantifiedTyVars turned some meta tyvars + -- into quantified skolems, so we have to zonk again + ; candidates <- TcM.zonkTcTypes candidates + ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) + ; let quantifiable_candidates + = pickQuantifiablePreds (mkVarSet qtvs) candidates + -- NB: do /not/ run pickQuantifiablePreds over psig_theta, + -- because we always want to quantify over psig_theta, and not + -- drop any of them; e.g. CallStack constraints. c.f #14658 + + theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] + (psig_theta ++ quantifiable_candidates) + + ; traceTc "decideQuantification" + (vcat [ text "infer_mode:" <+> ppr infer_mode + , text "candidates:" <+> ppr candidates + , text "psig_theta:" <+> ppr psig_theta + , text "mono_tvs:" <+> ppr mono_tvs + , text "co_vars:" <+> ppr co_vars + , text "qtvs:" <+> ppr qtvs + , text "theta:" <+> ppr theta ]) + ; return (qtvs, theta, co_vars) } + +------------------ +decideMonoTyVars :: InferMode + -> [(Name,TcType)] + -> [TcIdSigInst] + -> [PredType] + -> TcM (TcTyCoVarSet, [PredType], CoVarSet) +-- Decide which tyvars and covars cannot be generalised: +-- (a) Free in the environment +-- (b) Mentioned in a constraint we can't generalise +-- (c) Connected by an equality to (a) or (b) +-- Also return CoVars that appear free in the final quantified types +-- we can't quantify over these, and we must make sure they are in scope +decideMonoTyVars infer_mode name_taus psigs candidates + = do { (no_quant, maybe_quant) <- pick infer_mode candidates + + -- If possible, we quantify over partial-sig qtvs, so they are + -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs + ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $ + concatMap (map snd . sig_inst_skols) psigs + + ; psig_theta <- mapM TcM.zonkTcType $ + concatMap sig_inst_theta psigs + + ; taus <- mapM (TcM.zonkTcType . snd) name_taus + + ; tc_lvl <- TcM.getTcLevel + ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta + + co_vars = coVarsOfTypes (psig_tys ++ taus) + co_var_tvs = closeOverKinds co_vars + -- The co_var_tvs are tvs mentioned in the types of covars or + -- coercion holes. We can't quantify over these covars, so we + -- must include the variable in their types in the mono_tvs. + -- E.g. If we can't quantify over co :: k~Type, then we can't + -- quantify over k either! Hence closeOverKinds + + mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ + tyCoVarsOfTypes candidates + -- We need to grab all the non-quantifiable tyvars in the + -- candidates so that we can grow this set to find other + -- non-quantifiable tyvars. This can happen with something + -- like + -- f x y = ... + -- where z = x 3 + -- The body of z tries to unify the type of x (call it alpha[1]) + -- with (beta[2] -> gamma[2]). This unification fails because + -- alpha is untouchable. But we need to know not to quantify over + -- beta or gamma, because they are in the equality constraint with + -- alpha. Actual test case: typecheck/should_compile/tc213 + + mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs + + eq_constraints = filter isEqPrimPred candidates + mono_tvs2 = growThetaTyVars eq_constraints mono_tvs1 + + constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ + (growThetaTyVars eq_constraints + (tyCoVarsOfTypes no_quant) + `minusVarSet` mono_tvs2) + `delVarSetList` psig_qtvs + -- constrained_tvs: the tyvars that we are not going to + -- quantify solely because of the monomorphism restriction + -- + -- (`minusVarSet` mono_tvs2`): a type variable is only + -- "constrained" (so that the MR bites) if it is not + -- free in the environment (#13785) + -- + -- (`delVarSetList` psig_qtvs): if the user has explicitly + -- asked for quantification, then that request "wins" + -- over the MR. Note: do /not/ delete psig_qtvs from + -- mono_tvs1, because mono_tvs1 cannot under any circumstances + -- be quantified (#14479); see + -- Note [Quantification and partial signatures], Wrinkle 3, 4 + + mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs + + -- Warn about the monomorphism restriction + ; warn_mono <- woptM Opt_WarnMonomorphism + ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ + warnTc (Reason Opt_WarnMonomorphism) + (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) + mr_msg + + ; traceTc "decideMonoTyVars" $ vcat + [ text "mono_tvs0 =" <+> ppr mono_tvs0 + , text "no_quant =" <+> ppr no_quant + , text "maybe_quant =" <+> ppr maybe_quant + , text "eq_constraints =" <+> ppr eq_constraints + , text "mono_tvs =" <+> ppr mono_tvs + , text "co_vars =" <+> ppr co_vars ] + + ; return (mono_tvs, maybe_quant, co_vars) } + where + pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) + -- Split the candidates into ones we definitely + -- won't quantify, and ones that we might + pick NoRestrictions cand = return ([], cand) + pick ApplyMR cand = return (cand, []) + pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings + ; return (partition (is_int_ct os) cand) } + + -- For EagerDefaulting, do not quantify over + -- over any interactive class constraint + is_int_ct ovl_strings pred + | Just (cls, _) <- getClassPredTys_maybe pred + = isInteractiveClass ovl_strings cls + | otherwise + = False + + pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus + mr_msg = + hang (sep [ text "The Monomorphism Restriction applies to the binding" + <> plural name_taus + , text "for" <+> pp_bndrs ]) + 2 (hsep [ text "Consider giving" + , text (if isSingleton name_taus then "it" else "them") + , text "a type signature"]) + +------------------- +defaultTyVarsAndSimplify :: TcLevel + -> TyCoVarSet + -> [PredType] -- Assumed zonked + -> TcM [PredType] -- Guaranteed zonked +-- Default any tyvar free in the constraints, +-- and re-simplify in case the defaulting allows further simplification +defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates + = do { -- Promote any tyvars that we cannot generalise + -- See Note [Promote momomorphic tyvars] + ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) + ; any_promoted <- promoteTyVarSet mono_tvs + + -- Default any kind/levity vars + ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} + <- candidateQTyVarsOfTypes candidates + -- any covars should already be handled by + -- the logic in decideMonoTyVars, which looks at + -- the constraints generated + + ; poly_kinds <- xoptM LangExt.PolyKinds + ; default_kvs <- mapM (default_one poly_kinds True) + (dVarSetElems cand_kvs) + ; default_tvs <- mapM (default_one poly_kinds False) + (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) + ; let some_default = or default_kvs || or default_tvs + + ; case () of + _ | some_default -> simplify_cand candidates + | any_promoted -> mapM TcM.zonkTcType candidates + | otherwise -> return candidates + } + where + default_one poly_kinds is_kind_var tv + | not (isMetaTyVar tv) + = return False + | tv `elemVarSet` mono_tvs + = return False + | otherwise + = defaultTyVar (not poly_kinds && is_kind_var) tv + + simplify_cand candidates + = do { clone_wanteds <- newWanteds DefaultOrigin candidates + ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ + simplifyWantedsTcM clone_wanteds + -- Discard evidence; simples is fully zonked + + ; let new_candidates = ctsPreds simples + ; traceTc "Simplified after defaulting" $ + vcat [ text "Before:" <+> ppr candidates + , text "After:" <+> ppr new_candidates ] + ; return new_candidates } + +------------------ +decideQuantifiedTyVars + :: [(Name,TcType)] -- Annotated theta and (name,tau) pairs + -> [TcIdSigInst] -- Partial signatures + -> [PredType] -- Candidates, zonked + -> TcM [TyVar] +-- Fix what tyvars we are going to quantify over, and quantify them +decideQuantifiedTyVars name_taus psigs candidates + = do { -- Why psig_tys? We try to quantify over everything free in here + -- See Note [Quantification and partial signatures] + -- Wrinkles 2 and 3 + ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs + , (_,Bndr tv _) <- sig_inst_skols sig ] + ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs + , pred <- sig_inst_theta sig ] + ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus + + ; let -- Try to quantify over variables free in these types + psig_tys = psig_tv_tys ++ psig_theta + seed_tys = psig_tys ++ tau_tys + + -- Now "grow" those seeds to find ones reachable via 'candidates' + grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) + + -- Now we have to classify them into kind variables and type variables + -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars + -- + -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces + -- them in that order, so that the final qtvs quantifies in the same + -- order as the partial signatures do (#13524) + ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $ + psig_tys ++ candidates ++ tau_tys + ; let pick = (`dVarSetIntersectVarSet` grown_tcvs) + dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } + + ; traceTc "decideQuantifiedTyVars" (vcat + [ text "candidates =" <+> ppr candidates + , text "tau_tys =" <+> ppr tau_tys + , text "seed_tys =" <+> ppr seed_tys + , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys) + , text "grown_tcvs =" <+> ppr grown_tcvs + , text "dvs =" <+> ppr dvs_plus]) + + ; quantifyTyVars dvs_plus } + +------------------ +growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet +-- See Note [Growing the tau-tvs using constraints] +growThetaTyVars theta tcvs + | null theta = tcvs + | otherwise = transCloVarSet mk_next seed_tcvs + where + seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips + (ips, non_ips) = partition isIPLikePred theta + -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType + + mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones + mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips + grow_one so_far pred tcvs + | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs + | otherwise = tcvs + where + pred_tcvs = tyCoVarsOfType pred + + +{- Note [Promote momomorphic tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Promote any type variables that are free in the environment. Eg + f :: forall qtvs. bound_theta => zonked_tau +The free vars of f's type become free in the envt, and hence will show +up whenever 'f' is called. They may currently at rhs_tclvl, but they +had better be unifiable at the outer_tclvl! Example: envt mentions +alpha[1] + tau_ty = beta[2] -> beta[2] + constraints = alpha ~ [beta] +we don't quantify over beta (since it is fixed by envt) +so we must promote it! The inferred type is just + f :: beta -> beta + +NB: promoteTyVar ignores coercion variables + +Note [Quantification and partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When choosing type variables to quantify, the basic plan is to +quantify over all type variables that are + * free in the tau_tvs, and + * not forced to be monomorphic (mono_tvs), + for example by being free in the environment. + +However, in the case of a partial type signature, be doing inference +*in the presence of a type signature*. For example: + f :: _ -> a + f x = ... +or + g :: (Eq _a) => _b -> _b +In both cases we use plan InferGen, and hence call simplifyInfer. But +those 'a' variables are skolems (actually TyVarTvs), and we should be +sure to quantify over them. This leads to several wrinkles: + +* Wrinkle 1. In the case of a type error + f :: _ -> Maybe a + f x = True && x + The inferred type of 'f' is f :: Bool -> Bool, but there's a + left-over error of form (HoleCan (Maybe a ~ Bool)). The error-reporting + machine expects to find a binding site for the skolem 'a', so we + add it to the quantified tyvars. + +* Wrinkle 2. Consider the partial type signature + f :: (Eq _) => Int -> Int + f x = x + In normal cases that makes sense; e.g. + g :: Eq _a => _a -> _a + g x = x + where the signature makes the type less general than it could + be. But for 'f' we must therefore quantify over the user-annotated + constraints, to get + f :: forall a. Eq a => Int -> Int + (thereby correctly triggering an ambiguity error later). If we don't + we'll end up with a strange open type + f :: Eq alpha => Int -> Int + which isn't ambiguous but is still very wrong. + + Bottom line: Try to quantify over any variable free in psig_theta, + just like the tau-part of the type. + +* Wrinkle 3 (#13482). Also consider + f :: forall a. _ => Int -> Int + f x = if (undefined :: a) == undefined then x else 0 + Here we get an (Eq a) constraint, but it's not mentioned in the + psig_theta nor the type of 'f'. But we still want to quantify + over 'a' even if the monomorphism restriction is on. + +* Wrinkle 4 (#14479) + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + In the signature for 'g', we cannot quantify over 'b' because it turns out to + get unified with 'a', which is free in g's environment. So we carefully + refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars. We + report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Note [Growing the tau-tvs using constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(growThetaTyVars insts tvs) is the result of extending the set + of tyvars, tvs, using all conceivable links from pred + +E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} +Then growThetaTyVars preds tvs = {a,b,c} + +Notice that + growThetaTyVars is conservative if v might be fixed by vs + => v `elem` grow(vs,C) + +Note [Quantification with errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find that the RHS of the definition has some absolutely-insoluble +constraints (including especially "variable not in scope"), we + +* Abandon all attempts to find a context to quantify over, + and instead make the function fully-polymorphic in whatever + type we have found + +* Return a flag from simplifyInfer, indicating that we found an + insoluble constraint. This flag is used to suppress the ambiguity + check for the inferred type, which may well be bogus, and which + tends to obscure the real error. This fix feels a bit clunky, + but I failed to come up with anything better. + +Reasons: + - Avoid downstream errors + - Do not perform an ambiguity test on a bogus type, which might well + fail spuriously, thereby obfuscating the original insoluble error. + #14000 is an example + +I tried an alternative approach: simply failM, after emitting the +residual implication constraint; the exception will be caught in +GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type +(forall a. a). But that didn't work with -fdefer-type-errors, because +the recovery from failM emits no code at all, so there is no function +to run! But -fdefer-type-errors aspires to produce a runnable program. + +NB that we must include *derived* errors in the check for insolubles. +Example: + (a::*) ~ Int# +We get an insoluble derived error *~#, and we don't want to discard +it before doing the isInsolubleWC test! (#8262) + +Note [Default while Inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our current plan is that defaulting only happens at simplifyTop and +not simplifyInfer. This may lead to some insoluble deferred constraints. +Example: + +instance D g => C g Int b + +constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha +type inferred = gamma -> gamma + +Now, if we try to default (alpha := Int) we will be able to refine the implication to + (forall b. 0 => C gamma Int b) +which can then be simplified further to + (forall b. 0 => D gamma) +Finally, we /can/ approximate this implication with (D gamma) and infer the quantified +type: forall g. D g => g -> g + +Instead what will currently happen is that we will get a quantified type +(forall g. g -> g) and an implication: + forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha + +Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an +unsolvable implication: + forall g. 0 => (forall b. 0 => D g) + +The concrete example would be: + h :: C g a s => g -> a -> ST s a + f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) + +But it is quite tedious to do defaulting and resolve the implication constraints, and +we have not observed code breaking because of the lack of defaulting in inference, so +we don't do it for now. + + + +Note [Minimize by Superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we quantify over a constraint, in simplifyInfer we need to +quantify over a constraint that is minimal in some sense: For +instance, if the final wanted constraint is (Eq alpha, Ord alpha), +we'd like to quantify over Ord alpha, because we can just get Eq alpha +from superclass selection from Ord alpha. This minimization is what +mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint +to check the original wanted. + + +Note [Avoid unnecessary constraint simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -------- NB NB NB (Jun 12) ------------- + This note not longer applies; see the notes with #4361. + But I'm leaving it in here so we remember the issue.) + ---------------------------------------- +When inferring the type of a let-binding, with simplifyInfer, +try to avoid unnecessarily simplifying class constraints. +Doing so aids sharing, but it also helps with delicate +situations like + + instance C t => C [t] where .. + + f :: C [t] => .... + f x = let g y = ...(constraint C [t])... + in ... +When inferring a type for 'g', we don't want to apply the +instance decl, because then we can't satisfy (C t). So we +just notice that g isn't quantified over 't' and partition +the constraints before simplifying. + +This only half-works, but then let-generalisation only half-works. + +********************************************************************************* +* * +* Main Simplifier * +* * +*********************************************************************************** + +-} + +simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints +-- Solve the specified Wanted constraints +-- Discard the evidence binds +-- Discards all Derived stuff in result +-- Postcondition: fully zonked and unflattened constraints +simplifyWantedsTcM wanted + = do { traceTc "simplifyWantedsTcM {" (ppr wanted) + ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) + ; result <- TcM.zonkWC result + ; traceTc "simplifyWantedsTcM }" (ppr result) + ; return result } + +solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints +-- Since solveWanteds returns the residual WantedConstraints, +-- it should always be called within a runTcS or something similar, +-- Result is not zonked +solveWantedsAndDrop wanted + = do { wc <- solveWanteds wanted + ; return (dropDerivedWC wc) } + +solveWanteds :: WantedConstraints -> TcS WantedConstraints +-- so that the inert set doesn't mindlessly propagate. +-- NB: wc_simples may be wanted /or/ derived now +solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics, wc_holes = holes }) + = do { cur_lvl <- TcS.getTcLevel + ; traceTcS "solveWanteds {" $ + vcat [ text "Level =" <+> ppr cur_lvl + , ppr wc ] + + ; wc1 <- solveSimpleWanteds simples + -- Any insoluble constraints are in 'simples' and so get rewritten + -- See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad + + ; (floated_eqs, implics2) <- solveNestedImplications $ + implics `unionBags` wc_impl wc1 + + ; dflags <- getDynFlags + ; solved_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs + (wc1 { wc_impl = implics2 }) + + ; holes' <- simplifyHoles holes + ; let final_wc = solved_wc { wc_holes = holes' } + + ; ev_binds_var <- getTcEvBindsVar + ; bb <- TcS.getTcEvBindsMap ev_binds_var + ; traceTcS "solveWanteds }" $ + vcat [ text "final wc =" <+> ppr final_wc + , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] + + ; return final_wc } + +simpl_loop :: Int -> IntWithInf -> Cts + -> WantedConstraints -> TcS WantedConstraints +simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples }) + | n `intGtLimit` limit + = do { -- Add an error (not a warning) if we blow the limit, + -- Typically if we blow the limit we are going to report some other error + -- (an unsolved constraint), and we don't want that error to suppress + -- the iteration limit warning! + addErrTcS (hang (text "solveWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Unsolved:" <+> ppr wc + , ppUnless (isEmptyBag floated_eqs) $ + text "Floated equalities:" <+> ppr floated_eqs + , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" + ])) + ; return wc } + + | not (isEmptyBag floated_eqs) + = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples }) + -- Put floated_eqs first so they get solved first + -- NB: the floated_eqs may include /derived/ equalities + -- arising from fundeps inside an implication + + | superClassesMightHelp wc + = -- We still have unsolved goals, and apparently no way to solve them, + -- so try expanding superclasses at this level, both Given and Wanted + do { pending_given <- getPendingGivenScs + ; let (pending_wanted, simples1) = getPendingWantedScs simples + ; if null pending_given && null pending_wanted + then return wc -- After all, superclasses did not help + else + do { new_given <- makeSuperClasses pending_given + ; new_wanted <- makeSuperClasses pending_wanted + ; solveSimpleGivens new_given -- Add the new Givens to the inert set + ; simplify_again n limit (null pending_given) + wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } + + | otherwise + = return wc + +simplify_again :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +-- We have definitely decided to have another go at solving +-- the wanted constraints (we have tried at least once already +simplify_again n limit no_new_given_scs + wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { csTraceTcS $ + text "simpl_loop iteration=" <> int n + <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma + , int (lengthBag simples) <+> text "simples to solve" ]) + ; traceTcS "simpl_loop: wc =" (ppr wc) + + ; (unifs1, wc1) <- reportUnifications $ + solveSimpleWanteds $ + simples + + -- See Note [Cutting off simpl_loop] + -- We have already tried to solve the nested implications once + -- Try again only if we have unified some meta-variables + -- (which is a bit like adding more givens), or we have some + -- new Given superclasses + ; let new_implics = wc_impl wc1 + ; if unifs1 == 0 && + no_new_given_scs && + isEmptyBag new_implics + + then -- Do not even try to solve the implications + simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics }) + + else -- Try to solve the implications + do { (floated_eqs2, implics2) <- solveNestedImplications $ + implics `unionBags` new_implics + ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 }) + } } + +solveNestedImplications :: Bag Implication + -> TcS (Cts, Bag Implication) +-- Precondition: the TcS inerts may contain unsolved simples which have +-- to be converted to givens before we go inside a nested implication. +solveNestedImplications implics + | isEmptyBag implics + = return (emptyBag, emptyBag) + | otherwise + = do { traceTcS "solveNestedImplications starting {" empty + ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics + ; let floated_eqs = concatBag floated_eqs_s + + -- ... and we are back in the original TcS inerts + -- Notice that the original includes the _insoluble_simples so it was safe to ignore + -- them in the beginning of this function. + ; traceTcS "solveNestedImplications end }" $ + vcat [ text "all floated_eqs =" <+> ppr floated_eqs + , text "unsolved_implics =" <+> ppr unsolved_implics ] + + ; return (floated_eqs, catBagMaybes unsolved_implics) } + +solveImplication :: Implication -- Wanted + -> TcS (Cts, -- All wanted or derived floated equalities: var = type + Maybe Implication) -- Simplified implication (empty or singleton) +-- Precondition: The TcS monad contains an empty worklist and given-only inerts +-- which after trying to solve this implication we must restore to their original value +solveImplication imp@(Implic { ic_tclvl = tclvl + , ic_binds = ev_binds_var + , ic_skols = skols + , ic_given = given_ids + , ic_wanted = wanteds + , ic_info = info + , ic_status = status }) + | isSolvedStatus status + = return (emptyCts, Just imp) -- Do nothing + + | otherwise -- Even for IC_Insoluble it is worth doing more work + -- The insoluble stuff might be in one sub-implication + -- and other unsolved goals in another; and we want to + -- solve the latter as much as possible + = do { inerts <- getTcSInerts + ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) + + -- commented out; see `where` clause below + -- ; when debugIsOn check_tc_level + + -- Solve the nested constraints + ; (no_given_eqs, given_insols, residual_wanted) + <- nestImplicTcS ev_binds_var tclvl $ + do { let loc = mkGivenLoc tclvl info (ic_env imp) + givens = mkGivens loc given_ids + ; solveSimpleGivens givens + + ; residual_wanted <- solveWanteds wanteds + -- solveWanteds, *not* solveWantedsAndDrop, because + -- we want to retain derived equalities so we can float + -- them out in floatEqualities + + ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols + -- Call getNoGivenEqs /after/ solveWanteds, because + -- solveWanteds can augment the givens, via expandSuperClasses, + -- to reveal given superclass equalities + + ; return (no_eqs, given_insols, residual_wanted) } + + ; (floated_eqs, residual_wanted) + <- floatEqualities skols given_ids ev_binds_var + no_given_eqs residual_wanted + + ; traceTcS "solveImplication 2" + (ppr given_insols $$ ppr residual_wanted) + ; let final_wanted = residual_wanted `addInsols` given_insols + -- Don't lose track of the insoluble givens, + -- which signal unreachable code; put them in ic_wanted + + ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs + , ic_wanted = final_wanted }) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + ; traceTcS "solveImplication end }" $ vcat + [ text "no_given_eqs =" <+> ppr no_given_eqs + , text "floated_eqs =" <+> ppr floated_eqs + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) + , text "implication tvcs =" <+> ppr tcvs ] + + ; return (floated_eqs, res_implic) } + + where + -- TcLevels must be strictly increasing (see (ImplicInv) in + -- Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType), + -- and in fact I think they should always increase one level at a time. + + -- Though sensible, this check causes lots of testsuite failures. It is + -- remaining commented out for now. + {- + check_tc_level = do { cur_lvl <- TcS.getTcLevel + ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) } + -} + +---------------------- +setImplicationStatus :: Implication -> TcS (Maybe Implication) +-- Finalise the implication returned from solveImplication: +-- * Set the ic_status field +-- * Trim the ic_wanted field to remove Derived constraints +-- Precondition: the ic_status field is not already IC_Solved +-- Return Nothing if we can discard the implication altogether +setImplicationStatus implic@(Implic { ic_status = status + , ic_info = info + , ic_wanted = wc + , ic_given = givens }) + | ASSERT2( not (isSolvedStatus status ), ppr info ) + -- Precondition: we only set the status if it is not already solved + not (isSolvedWC pruned_wc) + = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) + + ; implic <- neededEvVars implic + + ; let new_status | insolubleWC pruned_wc = IC_Insoluble + | otherwise = IC_Unsolved + new_implic = implic { ic_status = new_status + , ic_wanted = pruned_wc } + + ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) + + ; return $ Just new_implic } + + | otherwise -- Everything is solved + -- Set status to IC_Solved, + -- and compute the dead givens and outer needs + -- See Note [Tracking redundant constraints] + = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic) + + ; implic@(Implic { ic_need_inner = need_inner + , ic_need_outer = need_outer }) <- neededEvVars implic + + ; bad_telescope <- checkBadTelescope implic + + ; let dead_givens | warnRedundantGivens info + = filterOut (`elemVarSet` need_inner) givens + | otherwise = [] -- None to report + + discard_entire_implication -- Can we discard the entire implication? + = null dead_givens -- No warning from this implication + && not bad_telescope + && isEmptyWC pruned_wc -- No live children + && isEmptyVarSet need_outer -- No needed vars to pass up to parent + + final_status + | bad_telescope = IC_BadTelescope + | otherwise = IC_Solved { ics_dead = dead_givens } + final_implic = implic { ic_status = final_status + , ic_wanted = pruned_wc } + + ; traceTcS "setImplicationStatus(all-solved) }" $ + vcat [ text "discard:" <+> ppr discard_entire_implication + , text "new_implic:" <+> ppr final_implic ] + + ; return $ if discard_entire_implication + then Nothing + else Just final_implic } + where + WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc + + pruned_simples = dropDerivedSimples simples + pruned_implics = filterBag keep_me implics + pruned_wc = WC { wc_simple = pruned_simples + , wc_impl = pruned_implics + , wc_holes = holes } -- do not prune holes; these should be reported + + keep_me :: Implication -> Bool + keep_me ic + | IC_Solved { ics_dead = dead_givens } <- ic_status ic + -- Fully solved + , null dead_givens -- No redundant givens to report + , isEmptyBag (wc_impl (ic_wanted ic)) + -- And no children that might have things to report + = False -- Tnen we don't need to keep it + | otherwise + = True -- Otherwise, keep it + +checkBadTelescope :: Implication -> TcS Bool +-- True <=> the skolems form a bad telescope +-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint +checkBadTelescope (Implic { ic_info = info + , ic_skols = skols }) + | ForAllSkol {} <- info + = do{ skols <- mapM TcS.zonkTyCoVarKind skols + ; return (go emptyVarSet (reverse skols))} + + | otherwise + = return False + + where + go :: TyVarSet -- skolems that appear *later* than the current ones + -> [TcTyVar] -- ordered skolems, in reverse order + -> Bool -- True <=> there is an out-of-order skolem + go _ [] = False + go later_skols (one_skol : earlier_skols) + | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols + = True + | otherwise + = go (later_skols `extendVarSet` one_skol) earlier_skols + +warnRedundantGivens :: SkolemInfo -> Bool +warnRedundantGivens (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt _ warn_redundant -> warn_redundant + ExprSigCtxt -> True + _ -> False + + -- To think about: do we want to report redundant givens for + -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. +warnRedundantGivens (InstSkol {}) = True +warnRedundantGivens _ = False + +neededEvVars :: Implication -> TcS Implication +-- Find all the evidence variables that are "needed", +-- and delete dead evidence bindings +-- See Note [Tracking redundant constraints] +-- See Note [Delete dead Given evidence bindings] +-- +-- - Start from initial_seeds (from nested implications) +-- +-- - Add free vars of RHS of all Wanted evidence bindings +-- and coercion variables accumulated in tcvs (all Wanted) +-- +-- - Generate 'needed', the needed set of EvVars, by doing transitive +-- closure through Given bindings +-- e.g. Needed {a,b} +-- Given a = sc_sel a2 +-- Then a2 is needed too +-- +-- - Prune out all Given bindings that are not needed +-- +-- - From the 'needed' set, delete ev_bndrs, the binders of the +-- evidence bindings, to give the final needed variables +-- +neededEvVars implic@(Implic { ic_given = givens + , ic_binds = ev_binds_var + , ic_wanted = WC { wc_impl = implics } + , ic_need_inner = old_needs }) + = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + + ; let seeds1 = foldr add_implic_seeds old_needs implics + seeds2 = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds + -- It's OK to use a non-deterministic fold here + -- because add_wanted is commutative + seeds3 = seeds2 `unionVarSet` tcvs + need_inner = findNeededEvVars ev_binds seeds3 + live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds + need_outer = varSetMinusEvBindMap need_inner live_ev_binds + `delVarSetList` givens + + ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds + -- See Note [Delete dead Given evidence bindings] + + ; traceTcS "neededEvVars" $ + vcat [ text "old_needs:" <+> ppr old_needs + , text "seeds3:" <+> ppr seeds3 + , text "tcvs:" <+> ppr tcvs + , text "ev_binds:" <+> ppr ev_binds + , text "live_ev_binds:" <+> ppr live_ev_binds ] + + ; return (implic { ic_need_inner = need_inner + , ic_need_outer = need_outer }) } + where + add_implic_seeds (Implic { ic_need_outer = needs }) acc + = needs `unionVarSet` acc + + needed_ev_bind needed (EvBind { eb_lhs = ev_var + , eb_is_given = is_given }) + | is_given = ev_var `elemVarSet` needed + | otherwise = True -- Keep all wanted bindings + + add_wanted :: EvBind -> VarSet -> VarSet + add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs + | is_given = needs -- Add the rhs vars of the Wanted bindings only + | otherwise = evVarsOfTerm rhs `unionVarSet` needs + +------------------------------------------------- +simplifyHoles :: Bag Hole -> TcS (Bag Hole) +simplifyHoles = mapBagM simpl_hole + where + simpl_hole :: Hole -> TcS Hole + simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) + = do { ty' <- flattenType loc ty + ; return (h { hole_ty = ty' }) } + +{- Note [Delete dead Given evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a result of superclass expansion, we speculatively +generate evidence bindings for Givens. E.g. + f :: (a ~ b) => a -> b -> Bool + f x y = ... +We'll have + [G] d1 :: (a~b) +and we'll speculatively generate the evidence binding + [G] d2 :: (a ~# b) = sc_sel d + +Now d2 is available for solving. But it may not be needed! Usually +such dead superclass selections will eventually be dropped as dead +code, but: + + * It won't always be dropped (#13032). In the case of an + unlifted-equality superclass like d2 above, we generate + case heq_sc d1 of d2 -> ... + and we can't (in general) drop that case expression in case + d1 is bottom. So it's technically unsound to have added it + in the first place. + + * Simply generating all those extra superclasses can generate lots of + code that has to be zonked, only to be discarded later. Better not + to generate it in the first place. + + Moreover, if we simplify this implication more than once + (e.g. because we can't solve it completely on the first iteration + of simpl_looop), we'll generate all the same bindings AGAIN! + +Easy solution: take advantage of the work we are doing to track dead +(unused) Givens, and use it to prune the Given bindings too. This is +all done by neededEvVars. + +This led to a remarkable 25% overall compiler allocation decrease in +test T12227. + +But we don't get to discard all redundant equality superclasses, alas; +see #15205. + +Note [Tracking redundant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Opt_WarnRedundantConstraints, GHC can report which +constraints of a type signature (or instance declaration) are +redundant, and can be omitted. Here is an overview of how it +works: + +----- What is a redundant constraint? + +* The things that can be redundant are precisely the Given + constraints of an implication. + +* A constraint can be redundant in two different ways: + a) It is implied by other givens. E.g. + f :: (Eq a, Ord a) => blah -- Eq a unnecessary + g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary + b) It is not needed by the Wanted constraints covered by the + implication E.g. + f :: Eq a => a -> Bool + f x = True -- Equality not used + +* To find (a), when we have two Given constraints, + we must be careful to drop the one that is a naked variable (if poss). + So if we have + f :: (Eq a, Ord a) => blah + then we may find [G] sc_sel (d1::Ord a) :: Eq a + [G] d2 :: Eq a + We want to discard d2 in favour of the superclass selection from + the Ord dictionary. This is done by GHC.Tc.Solver.Interact.solveOneFromTheOther + See Note [Replacement vs keeping]. + +* To find (b) we need to know which evidence bindings are 'wanted'; + hence the eb_is_given field on an EvBind. + +----- How tracking works + +* The ic_need fields of an Implic records in-scope (given) evidence + variables bound by the context, that were needed to solve this + implication (so far). See the declaration of Implication. + +* When the constraint solver finishes solving all the wanteds in + an implication, it sets its status to IC_Solved + + - The ics_dead field, of IC_Solved, records the subset of this + implication's ic_given that are redundant (not needed). + +* We compute which evidence variables are needed by an implication + in setImplicationStatus. A variable is needed if + a) it is free in the RHS of a Wanted EvBind, + b) it is free in the RHS of an EvBind whose LHS is needed, + c) it is in the ics_need of a nested implication. + +* We need to be careful not to discard an implication + prematurely, even one that is fully solved, because we might + thereby forget which variables it needs, and hence wrongly + report a constraint as redundant. But we can discard it once + its free vars have been incorporated into its parent; or if it + simply has no free vars. This careful discarding is also + handled in setImplicationStatus. + +----- Reporting redundant constraints + +* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints. + +* We don't report redundant givens for *every* implication; only + for those which reply True to GHC.Tc.Solver.warnRedundantGivens: + + - For example, in a class declaration, the default method *can* + use the class constraint, but it certainly doesn't *have* to, + and we don't want to report an error there. + + - More subtly, in a function definition + f :: (Ord a, Ord a, Ix a) => a -> a + f x = rhs + we do an ambiguity check on the type (which would find that one + of the Ord a constraints was redundant), and then we check that + the definition has that type (which might find that both are + redundant). We don't want to report the same error twice, so we + disable it for the ambiguity check. Hence using two different + FunSigCtxts, one with the warn-redundant field set True, and the + other set False in + - GHC.Tc.Gen.Bind.tcSpecPrag + - GHC.Tc.Gen.Bind.tcTySig + + This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors + so that we can discard implication constraints that we don't need. + So ics_dead consists only of the *reportable* redundant givens. + +----- Shortcomings + +Consider (see #9939) + f2 :: (Eq a, Ord a) => a -> a -> Bool + -- Ord a redundant, but Eq a is reported + f2 x y = (x == y) + +We report (Eq a) as redundant, whereas actually (Ord a) is. But it's +really not easy to detect that! + + +Note [Cutting off simpl_loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very important not to iterate in simpl_loop unless there is a chance +of progress. #8474 is a classic example: + + * There's a deeply-nested chain of implication constraints. + ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int + + * From the innermost one we get a [D] alpha ~ Int, + but alpha is untouchable until we get out to the outermost one + + * We float [D] alpha~Int out (it is in floated_eqs), but since alpha + is untouchable, the solveInteract in simpl_loop makes no progress + + * So there is no point in attempting to re-solve + ?yn:betan => [W] ?x:Int + via solveNestedImplications, because we'll just get the + same [D] again + + * If we *do* re-solve, we'll get an infinite loop. It is cut off by + the fixed bound of 10, but solving the next takes 10*10*...*10 (ie + exponentially many) iterations! + +Conclusion: we should call solveNestedImplications only if we did +some unification in solveSimpleWanteds; because that's the only way +we'll get more Givens (a unification is like adding a Given) to +allow the implication to make progress. +-} + +promoteTyVarTcS :: TcTyVar -> TcS () +-- When we float a constraint out of an implication we must restore +-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType +-- See Note [Promoting unification variables] +-- We don't just call promoteTyVar because we want to use unifyTyVar, +-- not writeMetaTyVar +promoteTyVarTcS tv + = do { tclvl <- TcS.getTcLevel + ; when (isFloatedTouchableMetaTyVar tclvl tv) $ + do { cloned_tv <- TcS.cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; unifyTyVar tv (mkTyVarTy rhs_tv) } } + +-- | Like 'defaultTyVar', but in the TcS monad. +defaultTyVarTcS :: TcTyVar -> TcS Bool +defaultTyVarTcS the_tv + | isRuntimeRepVar the_tv + , not (isTyVarTyVar the_tv) + -- TyVarTvs should only be unified with a tyvar + -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar + -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) + ; unifyTyVar the_tv liftedRepTy + ; return True } + | isMultiplicityVar the_tv + , not (isTyVarTyVar the_tv) -- TyVarTvs should only be unified with a tyvar + -- never with a type; c.f. TcMType.defaultTyVar + -- See Note [Kind generalisation and SigTvs] + = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) + ; unifyTyVar the_tv manyDataConTy + ; return True } + | otherwise + = return False -- the common case + +approximateWC :: Bool -> WantedConstraints -> Cts +-- Postcondition: Wanted or Derived Cts +-- See Note [ApproximateWC] +approximateWC float_past_equalities wc + = float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts + float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) + = filterBag (is_floatable trapping_tvs) simples `unionBags` + concatMapBag (float_implic trapping_tvs) implics + where + + float_implic :: TcTyCoVarSet -> Implication -> Cts + float_implic trapping_tvs imp + | float_past_equalities || ic_no_eqs imp + = float_wc new_trapping_tvs (ic_wanted imp) + | otherwise -- Take care with equalities + = emptyCts -- See (1) under Note [ApproximateWC] + where + new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp + + is_floatable skol_tvs ct + | isGivenCt ct = False + | insolubleEqCt ct = False + | otherwise = tyCoVarsOfCt ct `disjointVarSet` skol_tvs + +{- Note [ApproximateWC] +~~~~~~~~~~~~~~~~~~~~~~~ +approximateWC takes a constraint, typically arising from the RHS of a +let-binding whose type we are *inferring*, and extracts from it some +*simple* constraints that we might plausibly abstract over. Of course +the top-level simple constraints are plausible, but we also float constraints +out from inside, if they are not captured by skolems. + +The same function is used when doing type-class defaulting (see the call +to applyDefaultingRules) to extract constraints that might be defaulted. + +There is one caveat: + +1. When inferring most-general types (in simplifyInfer), we do *not* + float anything out if the implication binds equality constraints, + because that defeats the OutsideIn story. Consider + data T a where + TInt :: T Int + MkT :: T a + + f TInt = 3::Int + + We get the implication (a ~ Int => res ~ Int), where so far we've decided + f :: T a -> res + We don't want to float (res~Int) out because then we'll infer + f :: T a -> Int + which is only on of the possible types. (GHC 7.6 accidentally *did* + float out of such implications, which meant it would happily infer + non-principal types.) + + HOWEVER (#12797) in findDefaultableGroups we are not worried about + the most-general type; and we /do/ want to float out of equalities. + Hence the boolean flag to approximateWC. + +------ Historical note ----------- +There used to be a second caveat, driven by #8155 + + 2. We do not float out an inner constraint that shares a type variable + (transitively) with one that is trapped by a skolem. Eg + forall a. F a ~ beta, Integral beta + We don't want to float out (Integral beta). Doing so would be bad + when defaulting, because then we'll default beta:=Integer, and that + makes the error message much worse; we'd get + Can't solve F a ~ Integer + rather than + Can't solve Integral (F a) + + Moreover, floating out these "contaminated" constraints doesn't help + when generalising either. If we generalise over (Integral b), we still + can't solve the retained implication (forall a. F a ~ b). Indeed, + arguably that too would be a harder error to understand. + +But this transitive closure stuff gives rise to a complex rule for +when defaulting actually happens, and one that was never documented. +Moreover (#12923), the more complex rule is sometimes NOT what +you want. So I simply removed the extra code to implement the +contamination stuff. There was zero effect on the testsuite (not even +#8155). +------ End of historical note ----------- + + +Note [DefaultTyVar] +~~~~~~~~~~~~~~~~~~~ +defaultTyVar is used on any un-instantiated meta type variables to +default any RuntimeRep variables to LiftedRep. This is important +to ensure that instance declarations match. For example consider + + instance Show (a->b) + foo x = show (\_ -> True) + +Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), +and that won't match the tcTypeKind (*) in the instance decl. See tests +tc217 and tc175. + +We look only at touchable type variables. No further constraints +are going to affect these type variables, so it's time to do it by +hand. However we aren't ready to default them fully to () or +whatever, because the type-class defaulting rules have yet to run. + +An alternate implementation would be to emit a derived constraint setting +the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. + +Note [Promote _and_ default when inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are inferring a type, we simplify the constraint, and then use +approximateWC to produce a list of candidate constraints. Then we MUST + + a) Promote any meta-tyvars that have been floated out by + approximateWC, to restore invariant (WantedInv) described in + Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType. + + b) Default the kind of any meta-tyvars that are not mentioned in + in the environment. + +To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we +have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it +should! If we don't solve the constraint, we'll stupidly quantify over +(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over +(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. +#7641 is a simpler example. + +Note [Promoting unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an equality out of an implication we must "promote" free +unification variables of the equality, in order to maintain Invariant +(WantedInv) from Note [TcLevel and untouchable type variables] in +TcType. for the leftover implication. + +This is absolutely necessary. Consider the following example. We start +with two implications and a class with a functional dependency. + + class C x y | x -> y + instance C [a] [a] + + (I1) [untch=beta]forall b. 0 => F Int ~ [beta] + (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] + +We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. +They may react to yield that (beta := [alpha]) which can then be pushed inwards +the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that +(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable +beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: + + class C x y | x -> y where + op :: x -> y -> () + + instance C [a] [a] + + type family F a :: * + + h :: F Int -> () + h = undefined + + data TEx where + TEx :: a -> TEx + + f (x::beta) = + let g1 :: forall b. b -> () + g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) + + + +********************************************************************************* +* * +* Floating equalities * +* * +********************************************************************************* + +Note [Float Equalities out of Implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For ordinary pattern matches (including existentials) we float +equalities out of implications, for instance: + data T where + MkT :: Eq a => a -> T + f x y = case x of MkT _ -> (y::Int) +We get the implication constraint (x::T) (y::alpha): + forall a. [untouchable=alpha] Eq a => alpha ~ Int +We want to float out the equality into a scope where alpha is no +longer untouchable, to solve the implication! + +But we cannot float equalities out of implications whose givens may +yield or contain equalities: + + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a + + h :: T a -> a -> Int + + f x y = case x of + T1 -> y::Int + T2 -> y::Bool + T3 -> h x y + +We generate constraint, for (x::T alpha) and (y :: beta): + [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch + [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch + (alpha ~ beta) -- From 3rd branch + +If we float the equality (beta ~ Int) outside of the first implication and +the equality (beta ~ Bool) out of the second we get an insoluble constraint. +But if we just leave them inside the implications, we unify alpha := beta and +solve everything. + +Principle: + We do not want to float equalities out which may + need the given *evidence* to become soluble. + +Consequence: classes with functional dependencies don't matter (since there is +no evidence for a fundep equality), but equality superclasses do matter (since +they carry evidence). +-} + +floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool + -> WantedConstraints + -> TcS (Cts, WantedConstraints) +-- Main idea: see Note [Float Equalities out of Implications] +-- +-- Precondition: the wc_simple of the incoming WantedConstraints are +-- fully zonked, so that we can see their free variables +-- +-- Postcondition: The returned floated constraints (Cts) are only +-- Wanted or Derived +-- +-- Also performs some unifications (via promoteTyVar), adding to +-- monadically-carried ty_binds. These will be used when processing +-- floated_eqs later +-- +-- Subtleties: Note [Float equalities from under a skolem binding] +-- Note [Skolem escape] +-- Note [What prevents a constraint from floating] +floatEqualities skols given_ids ev_binds_var no_given_eqs + wanteds@(WC { wc_simple = simples }) + | not no_given_eqs -- There are some given equalities, so don't float + = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] + + | otherwise + = do { -- First zonk: the inert set (from whence they came) is fully + -- zonked, but unflattening may have filled in unification + -- variables, and we /must/ see them. Otherwise we may float + -- constraints that mention the skolems! + simples <- TcS.zonkSimples simples + ; binds <- TcS.getTcEvBindsMap ev_binds_var + + -- Now we can pick the ones to float + -- The constraints are un-flattened and de-canonicalised + ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples + + seed_skols = mkVarSet skols `unionVarSet` + mkVarSet given_ids `unionVarSet` + foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` + evBindMapToVarSet binds + -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) + -- Include the EvIds of any non-floating constraints + + extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols + -- extended_skols contains the EvIds of all the trapped constraints + -- See Note [What prevents a constraint from floating] (3) + + (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols) + candidate_eqs + + remaining_simples = no_float_cts `andCts` no_flt_eqs + + -- Promote any unification variables mentioned in the floated equalities + -- See Note [Promoting unification variables] + ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs) + + ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols + , text "Extended skols =" <+> ppr extended_skols + , text "Simples =" <+> ppr simples + , text "Candidate eqs =" <+> ppr candidate_eqs + , text "Floated eqs =" <+> ppr flt_eqs]) + ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) } + + where + add_non_flt_ct :: Ct -> VarSet -> VarSet + add_non_flt_ct ct acc | isDerivedCt ct = acc + | otherwise = extendVarSet acc (ctEvId ct) + + is_floatable :: VarSet -> Ct -> Bool + is_floatable skols ct + | isDerivedCt ct = tyCoVarsOfCt ct `disjointVarSet` skols + | otherwise = not (ctEvId ct `elemVarSet` skols) + + add_captured_ev_ids :: Cts -> VarSet -> VarSet + add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts + where + extra_skol ct acc + | isDerivedCt ct = acc + | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct) + | otherwise = acc + + -- Identify which equalities are candidates for floating + -- Float out alpha ~ ty which might be unified outside + -- See Note [Which equalities to float] + is_float_eq_candidate ct + | pred <- ctPred ct + , EqPred NomEq ty1 ty2 <- classifyPredType pred + , case ct of + CIrredCan {} -> False -- See Note [Do not float blocked constraints] + _ -> True -- See #18855 + = float_eq ty1 ty2 || float_eq ty2 ty1 + | otherwise + = False + + float_eq ty1 ty2 + = case getTyVar_maybe ty1 of + Just tv1 -> isMetaTyVar tv1 + && (not (isTyVarTyVar tv1) || isTyVarTy ty2) + Nothing -> False + +{- Note [Do not float blocked constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As #18855 showed, we must not float an equality that is blocked. +Consider + forall a[4]. [W] co1: alpha[4] ~ Maybe (a[4] |> bco) + [W] co2: alpha[4] ~ Maybe (beta[4] |> bco]) + [W] bco: kappa[2] ~ Type + +Now co1, co2 are blocked by bco. We will eventually float out bco +and solve it at level 2. But the danger is that we will *also* +float out co2, and that is bad bad bad. Because we'll promote alpha +and beta to level 2, and then fail to unify the promoted beta +with the skolem a[4]. + +Solution: don't float out blocked equalities. Remember: we only want +to float out if we can solve; see Note [Which equalities to float]. + +(Future plan: kill floating altogether.) + +Note [Float equalities from under a skolem binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Which of the simple equalities can we float out? Obviously, only +ones that don't mention the skolem-bound variables. But that is +over-eager. Consider + [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int +The second constraint doesn't mention 'a'. But if we float it, +we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that +beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll +we left with the constraint + [2] forall a. a ~ gamma'[1] +which is insoluble because gamma became untouchable. + +Solution: float only constraints that stand a jolly good chance of +being soluble simply by being floated, namely ones of form + a ~ ty +where 'a' is a currently-untouchable unification variable, but may +become touchable by being floated (perhaps by more than one level). + +We had a very complicated rule previously, but this is nice and +simple. (To see the notes, look at this Note in a version of +GHC.Tc.Solver prior to Oct 2014). + +Note [Which equalities to float] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Which equalities should we float? We want to float ones where there +is a decent chance that floating outwards will allow unification to +happen. In particular, float out equalities that are: + +* Of form (alpha ~# ty) or (ty ~# alpha), where + * alpha is a meta-tyvar. + * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar. In that + case, floating out won't help either, and it may affect grouping + of error messages. + + NB: generally we won't see (ty ~ alpha), with alpha on the right because + of Note [Unification variables on the left] in GHC.Tc.Utils.Unify. + But if we start with (F tys ~ alpha), it will orient as (fmv ~ alpha), + and unflatten back to (F tys ~ alpha). So we must look for alpha on + the right too. Example T4494. + +* Nominal. No point in floating (alpha ~R# ty), because we do not + unify representational equalities even if alpha is touchable. + See Note [Do not unify representational equalities] in GHC.Tc.Solver.Interact. + +Note [Skolem escape] +~~~~~~~~~~~~~~~~~~~~ +You might worry about skolem escape with all this floating. +For example, consider + [2] forall a. (a ~ F beta[2] delta, + Maybe beta[2] ~ gamma[1]) + +The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and +solve with gamma := beta. But what if later delta:=Int, and + F b Int = b. +Then we'd get a ~ beta[2], and solve to get beta:=a, and now the +skolem has escaped! + +But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] +to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. + +Note [What prevents a constraint from floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What /prevents/ a constraint from floating? If it mentions one of the +"bound variables of the implication". What are they? + +The "bound variables of the implication" are + + 1. The skolem type variables `ic_skols` + + 2. The "given" evidence variables `ic_given`. Example: + forall a. (co :: t1 ~# t2) => [W] co2 : (a ~# b |> co) + Here 'co' is bound + + 3. The binders of all evidence bindings in `ic_binds`. Example + forall a. (d :: t1 ~ t2) + EvBinds { (co :: t1 ~# t2) = superclass-sel d } + => [W] co2 : (a ~# b |> co) + Here `co` is gotten by superclass selection from `d`, and the + wanted constraint co2 must not float. + + 4. And the evidence variable of any equality constraint (incl + Wanted ones) whose type mentions a bound variable. Example: + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + Here, since `k` is bound, so is `co2` and hence so is `co1`. + +Here (1,2,3) are handled by the "seed_skols" calculation, and +(4) is done by the transCloVarSet call. + +The possible dependence on givens, and evidence bindings, is more +subtle than we'd realised at first. See #14584. + +How can (4) arise? Suppose we have (k :: *), (a :: k), and ([G} k ~ *). +Then form an equality like (a ~ Int) we might end up with + [W] co1 :: k ~ * + [W] co2 :: (a |> co1) ~ Int + + +********************************************************************************* +* * +* Defaulting and disambiguation * +* * +********************************************************************************* +-} + +applyDefaultingRules :: WantedConstraints -> TcS Bool +-- True <=> I did some defaulting, by unifying a meta-tyvar +-- Input WantedConstraints are not necessarily zonked + +applyDefaultingRules wanteds + | isEmptyWC wanteds + = return False + | otherwise + = do { info@(default_tys, _) <- getDefaultInfo + ; wanteds <- TcS.zonkWC wanteds + + ; let groups = findDefaultableGroups info wanteds + + ; traceTcS "applyDefaultingRules {" $ + vcat [ text "wanteds =" <+> ppr wanteds + , text "groups =" <+> ppr groups + , text "info =" <+> ppr info ] + + ; something_happeneds <- mapM (disambigGroup default_tys) groups + + ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) + + ; return (or something_happeneds) } + +findDefaultableGroups + :: ( [Type] + , (Bool,Bool) ) -- (Overloaded strings, extended default rules) + -> WantedConstraints -- Unsolved (wanted or derived) + -> [(TyVar, [Ct])] +findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds + | null default_tys + = [] + | otherwise + = [ (tv, map fstOf3 group) + | group'@((_,_,tv) :| _) <- unary_groups + , let group = toList group' + , defaultable_tyvar tv + , defaultable_classes (map sndOf3 group) ] + where + simples = approximateWC True wanteds + (unaries, non_unaries) = partitionWith find_unary (bagToList simples) + unary_groups = equivClasses cmp_tv unaries + + unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints + unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints + non_unaries :: [Ct] -- and *other* constraints + + -- Finds unary type-class constraints + -- But take account of polykinded classes like Typeable, + -- which may look like (Typeable * (a:*)) (#8931) + find_unary :: Ct -> Either (Ct, Class, TyVar) Ct + find_unary cc + | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) + , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys + -- Ignore invisible arguments for this purpose + , Just tv <- tcGetTyVar_maybe ty + , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and + -- we definitely don't want to try to assign to those! + = Left (cc, cls, tv) + find_unary cc = Right cc -- Non unary or non dictionary + + bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries + bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries + + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 + + defaultable_tyvar :: TcTyVar -> Bool + defaultable_tyvar tv + = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] + b2 = not (tv `elemVarSet` bad_tvs) + in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] + + defaultable_classes :: [Class] -> Bool + defaultable_classes clss + | extended_defaults = any (isInteractiveClass ovl_strings) clss + | otherwise = all is_std_class clss && (any (isNumClass ovl_strings) clss) + + -- is_std_class adds IsString to the standard numeric classes, + -- when -foverloaded-strings is enabled + is_std_class cls = isStandardClass cls || + (ovl_strings && (cls `hasKey` isStringClassKey)) + +------------------------------ +disambigGroup :: [Type] -- The default types + -> (TcTyVar, [Ct]) -- All classes of the form (C a) + -- sharing same type variable + -> TcS Bool -- True <=> something happened, reflected in ty_binds + +disambigGroup [] _ + = return False +disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) + = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) + ; fake_ev_binds_var <- TcS.newTcEvBinds + ; tclvl <- TcS.getTcLevel + ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group + + ; if success then + -- Success: record the type variable binding, and return + do { unifyTyVar the_tv default_ty + ; wrapWarnTcS $ warnDefaulting wanteds default_ty + ; traceTcS "disambigGroup succeeded }" (ppr default_ty) + ; return True } + else + -- Failure: try with the next type + do { traceTcS "disambigGroup failed, will try other default types }" + (ppr default_ty) + ; disambigGroup default_tys group } } + where + try_group + | Just subst <- mb_subst + = do { lcl_env <- TcS.getLclEnv + ; tc_lvl <- TcS.getTcLevel + ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env + ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) + wanteds + ; fmap isEmptyWC $ + solveSimpleWanteds $ listToBag $ + map mkNonCanonical wanted_evs } + + | otherwise + = return False + + the_ty = mkTyVarTy the_tv + mb_subst = tcMatchTyKi the_ty default_ty + -- Make sure the kinds match too; hence this call to tcMatchTyKi + -- E.g. suppose the only constraint was (Typeable k (a::k)) + -- With the addition of polykinded defaulting we also want to reject + -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. + +-- In interactive mode, or with -XExtendedDefaultRules, +-- we default Show a to Show () to avoid graututious errors on "show []" +isInteractiveClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isInteractiveClass ovl_strings cls + = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) + + -- isNumClass adds IsString to the standard numeric classes, + -- when -foverloaded-strings is enabled +isNumClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isNumClass ovl_strings cls + = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + + +{- +Note [Avoiding spurious errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing the unification for defaulting, we check for skolem +type variables, and simply don't default them. For example: + f = (*) -- Monomorphic + g :: Num a => a -> a + g x = f x x +Here, we get a complaint when checking the type signature for g, +that g isn't polymorphic enough; but then we get another one when +dealing with the (Num a) context arising from f's definition; +we try to unify a with Int (to default it), but find that it's +already been unified with the rigid variable from g's type sig. + +Note [Multi-parameter defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XExtendedDefaultRules, we default only based on single-variable +constraints, but do not exclude from defaulting any type variables which also +appear in multi-variable constraints. This means that the following will +default properly: + + default (Integer, Double) + + class A b (c :: Symbol) where + a :: b -> Proxy c + + instance A Integer c where a _ = Proxy + + main = print (a 5 :: Proxy "5") + +Note that if we change the above instance ("instance A Integer") to +"instance A Double", we get an error: + + No instance for (A Integer "5") + +This is because the first defaulted type (Integer) has successfully satisfied +its single-parameter constraints (in this case Num). +-} diff --git a/GHC/Tc/Solver/Canonical.hs b/GHC/Tc/Solver/Canonical.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Canonical.hs @@ -0,0 +1,2553 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Tc.Solver.Canonical( + canonicalize, + unifyDerived, + makeSuperClasses, maybeSym, + StopOrContinue(..), stopWith, continueWith, + solveCallStack -- For GHC.Tc.Solver + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Unify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) ) +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Tc.Solver.Flatten +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.EvTerm +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking +import GHC.Core.Coercion +import GHC.Core +import GHC.Types.Id( mkTemplateLocals ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) +import GHC.Types.Var +import GHC.Types.Var.Env( mkInScopeSet ) +import GHC.Types.Var.Set( delVarSetList ) +import GHC.Utils.Outputable +import GHC.Driver.Session( DynFlags ) +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Hs.Type( HsIPName(..) ) + +import GHC.Data.Pair +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Monad +import Control.Monad +import Data.Maybe ( isJust ) +import Data.List ( zip4 ) +import GHC.Types.Basic + +import Data.Bifunctor ( bimap ) +import Data.Foldable ( traverse_ ) + +{- +************************************************************************ +* * +* The Canonicaliser * +* * +************************************************************************ + +Note [Canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~ + +Canonicalization converts a simple constraint to a canonical form. It is +unary (i.e. treats individual constraints one at a time). + +Constraints originating from user-written code come into being as +CNonCanonicals. We know nothing about these constraints. So, first: + + Classify CNonCanoncal constraints, depending on whether they + are equalities, class predicates, or other. + +Then proceed depending on the shape of the constraint. Generally speaking, +each constraint gets flattened and then decomposed into one of several forms +(see type Ct in GHC.Tc.Types). + +When an already-canonicalized constraint gets kicked out of the inert set, +it must be recanonicalized. But we know a bit about its shape from the +last time through, so we can skip the classification step. + +-} + +-- Top-level canonicalization +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +canonicalize :: Ct -> TcS (StopOrContinue Ct) +canonicalize (CNonCanonical { cc_ev = ev }) + = {-# SCC "canNC" #-} + case classifyPredType pred of + ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) + canClassNC ev cls tys + EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) + canEqNC ev eq_rel ty1 ty2 + IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) + canIrred OtherCIS ev + ForAllPred tvs theta p -> do traceTcS "canEvNC:forall" (ppr pred) + canForAllNC ev tvs theta p + where + pred = ctEvPred ev + +canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) + = canForAll ev pend_sc + +canonicalize (CIrredCan { cc_ev = ev, cc_status = status }) + | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev) + = -- For insolubles (all of which are equalities, do /not/ flatten the arguments + -- In #14350 doing so led entire-unnecessary and ridiculously large + -- type function expansion. Instead, canEqNC just applies + -- the substitution to the predicate, and may do decomposition; + -- e.g. a ~ [a], where [G] a ~ [Int], can decompose + canEqNC ev eq_rel ty1 ty2 + + | otherwise + = canIrred status ev + +canonicalize (CDictCan { cc_ev = ev, cc_class = cls + , cc_tyargs = xis, cc_pend_sc = pend_sc }) + = {-# SCC "canClass" #-} + canClass ev cls xis pend_sc + +canonicalize (CTyEqCan { cc_ev = ev + , cc_tyvar = tv + , cc_rhs = xi + , cc_eq_rel = eq_rel }) + = {-# SCC "canEqLeafTyVarEq" #-} + canEqNC ev eq_rel (mkTyVarTy tv) xi + -- NB: Don't use canEqTyVar because that expects flattened types, + -- and tv and xi may not be flat w.r.t. an updated inert set + +canonicalize (CFunEqCan { cc_ev = ev + , cc_fun = fn + , cc_tyargs = xis1 + , cc_fsk = fsk }) + = {-# SCC "canEqLeafFunEq" #-} + canCFunEqCan ev fn xis1 fsk + +{- +************************************************************************ +* * +* Class Canonicalization +* * +************************************************************************ +-} + +canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) +-- "NC" means "non-canonical"; that is, we have got here +-- from a NonCanonical constraint, not from a CDictCan +-- Precondition: EvVar is class evidence +canClassNC ev cls tys + | isGiven ev -- See Note [Eagerly expand given superclasses] + = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys + ; emitWork sc_cts + ; canClass ev cls tys False } + + | isWanted ev + , Just ip_name <- isCallStackPred cls tys + , OccurrenceOf func <- ctLocOrigin loc + -- If we're given a CallStack constraint that arose from a function + -- call, we need to push the current call-site onto the stack instead + -- of solving it directly from a given. + -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad + = do { -- First we emit a new constraint that will capture the + -- given CallStack. + ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name)) + -- We change the origin to IPOccOrigin so + -- this rule does not fire again. + -- See Note [Overview of implicit CallStacks] + + ; new_ev <- newWantedEvVarNC new_loc pred + + -- Then we solve the wanted by pushing the call-site + -- onto the newly emitted CallStack + ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev) + ; solveCallStack ev ev_cs + + ; canClass new_ev cls tys False } + + | otherwise + = canClass ev cls tys (has_scs cls) + + where + has_scs cls = not (null (classSCTheta cls)) + loc = ctEvLoc ev + pred = ctEvPred ev + +solveCallStack :: CtEvidence -> EvCallStack -> TcS () +-- Also called from GHC.Tc.Solver when defaulting call stacks +solveCallStack ev ev_cs = do + -- We're given ev_cs :: CallStack, but the evidence term should be a + -- dictionary, so we have to coerce ev_cs to a dictionary for + -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] + cs_tm <- evCallStack ev_cs + let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) + setEvBindIfWanted ev ev_tm + +canClass :: CtEvidence + -> Class -> [Type] + -> Bool -- True <=> un-explored superclasses + -> TcS (StopOrContinue Ct) +-- Precondition: EvVar is class evidence + +canClass ev cls tys pend_sc + = -- all classes do *nominal* matching + ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) + do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys + ; MASSERT( isTcReflCo _kind_co ) + ; let co = mkTcTyConAppCo Nominal cls_tc cos + xi = mkClassPred cls xis + mk_ct new_ev = CDictCan { cc_ev = new_ev + , cc_tyargs = xis + , cc_class = cls + , cc_pend_sc = pend_sc } + ; mb <- rewriteEvidence ev xi co + ; traceTcS "canClass" (vcat [ ppr ev + , ppr xi, ppr mb ]) + ; return (fmap mk_ct mb) } + where + cls_tc = classTyCon cls + +{- Note [The superclass story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to add superclass constraints for two reasons: + +* For givens [G], they give us a route to proof. E.g. + f :: Ord a => a -> Bool + f x = x == x + We get a Wanted (Eq a), which can only be solved from the superclass + of the Given (Ord a). + +* For wanteds [W], and deriveds [WD], [D], they may give useful + functional dependencies. E.g. + class C a b | a -> b where ... + class C a b => D a b where ... + Now a [W] constraint (D Int beta) has (C Int beta) as a superclass + and that might tell us about beta, via C's fundeps. We can get this + by generating a [D] (C Int beta) constraint. It's derived because + we don't actually have to cough up any evidence for it; it's only there + to generate fundep equalities. + +See Note [Why adding superclasses can help]. + +For these reasons we want to generate superclass constraints for both +Givens and Wanteds. But: + +* (Minor) they are often not needed, so generating them aggressively + is a waste of time. + +* (Major) if we want recursive superclasses, there would be an infinite + number of them. Here is a real-life example (#10318); + + class (Frac (Frac a) ~ Frac a, + Fractional (Frac a), + IntegralDomain (Frac a)) + => IntegralDomain a where + type Frac a :: * + + Notice that IntegralDomain has an associated type Frac, and one + of IntegralDomain's superclasses is another IntegralDomain constraint. + +So here's the plan: + +1. Eagerly generate superclasses for given (but not wanted) + constraints; see Note [Eagerly expand given superclasses]. + This is done using mkStrictSuperClasses in canClassNC, when + we take a non-canonical Given constraint and cannonicalise it. + + However stop if you encounter the same class twice. That is, + mkStrictSuperClasses expands eagerly, but has a conservative + termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType. + +2. Solve the wanteds as usual, but do no further expansion of + superclasses for canonical CDictCans in solveSimpleGivens or + solveSimpleWanteds; Note [Danger of adding superclasses during solving] + + However, /do/ continue to eagerly expand superclasses for new /given/ + /non-canonical/ constraints (canClassNC does this). As #12175 + showed, a type-family application can expand to a class constraint, + and we want to see its superclasses for just the same reason as + Note [Eagerly expand given superclasses]. + +3. If we have any remaining unsolved wanteds + (see Note [When superclasses help] in GHC.Tc.Types.Constraint) + try harder: take both the Givens and Wanteds, and expand + superclasses again. See the calls to expandSuperClasses in + GHC.Tc.Solver.simpl_loop and solveWanteds. + + This may succeed in generating (a finite number of) extra Givens, + and extra Deriveds. Both may help the proof. + +3a An important wrinkle: only expand Givens from the current level. + Two reasons: + - We only want to expand it once, and that is best done at + the level it is bound, rather than repeatedly at the leaves + of the implication tree + - We may be inside a type where we can't create term-level + evidence anyway, so we can't superclass-expand, say, + (a ~ b) to get (a ~# b). This happened in #15290. + +4. Go round to (2) again. This loop (2,3,4) is implemented + in GHC.Tc.Solver.simpl_loop. + +The cc_pend_sc flag in a CDictCan records whether the superclasses of +this constraint have been expanded. Specifically, in Step 3 we only +expand superclasses for constraints with cc_pend_sc set to true (i.e. +isPendingScDict holds). + +Why do we do this? Two reasons: + +* To avoid repeated work, by repeatedly expanding the superclasses of + same constraint, + +* To terminate the above loop, at least in the -XNoRecursiveSuperClasses + case. If there are recursive superclasses we could, in principle, + expand forever, always encountering new constraints. + +When we take a CNonCanonical or CIrredCan, but end up classifying it +as a CDictCan, we set the cc_pend_sc flag to False. + +Note [Superclass loops] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class C a => D a + class D a => C a + +Then, when we expand superclasses, we'll get back to the self-same +predicate, so we have reached a fixpoint in expansion and there is no +point in fruitlessly expanding further. This case just falls out from +our strategy. Consider + f :: C a => a -> Bool + f x = x==x +Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses +G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its sc_pend flag set.) +When processing d3 we find a match with d1 in the inert set, and we always +keep the inert item (d1) if possible: see Note [Replacement vs keeping] in +GHC.Tc.Solver.Interact. So d3 dies a quick, happy death. + +Note [Eagerly expand given superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step (1) of Note [The superclass story], why do we eagerly expand +Given superclasses by one layer? (By "one layer" we mean expand transitively +until you meet the same class again -- the conservative criterion embodied +in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) +We do this eagerly for Givens mainly because of some very obscure +cases like this: + + instance Bad a => Eq (T a) + + f :: (Ord (T a)) => blah + f x = ....needs Eq (T a), Ord (T a).... + +Here if we can't satisfy (Eq (T a)) from the givens we'll use the +instance declaration; but then we are stuck with (Bad a). Sigh. +This is really a case of non-confluent proofs, but to stop our users +complaining we expand one layer in advance. + +Note [Instance and Given overlap] in GHC.Tc.Solver.Interact. + +We also want to do this if we have + + f :: F (T a) => blah + +where + type instance F (T a) = Ord (T a) + +So we may need to do a little work on the givens to expose the +class that has the superclasses. That's why the superclass +expansion for Givens happens in canClassNC. + +This same scenario happens with quantified constraints, whose superclasses +are also eagerly expanded. Test case: typecheck/should_compile/T16502b +These are handled in canForAllNC, analogously to canClassNC. + +Note [Why adding superclasses can help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Examples of how adding superclasses can help: + + --- Example 1 + class C a b | a -> b + Suppose we want to solve + [G] C a b + [W] C a beta + Then adding [D] beta~b will let us solve it. + + -- Example 2 (similar but using a type-equality superclass) + class (F a ~ b) => C a b + And try to sllve: + [G] C a b + [W] C a beta + Follow the superclass rules to add + [G] F a ~ b + [D] F a ~ beta + Now we get [D] beta ~ b, and can solve that. + + -- Example (tcfail138) + class L a b | a -> b + class (G a, L a b) => C a b + + instance C a b' => G (Maybe a) + instance C a b => C (Maybe a) a + instance L (Maybe a) a + + When solving the superclasses of the (C (Maybe a) a) instance, we get + [G] C a b, and hance by superclasses, [G] G a, [G] L a b + [W] G (Maybe a) + Use the instance decl to get + [W] C a beta + Generate its derived superclass + [D] L a beta. Now using fundeps, combine with [G] L a b to get + [D] beta ~ b + which is what we want. + +Note [Danger of adding superclasses during solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's a serious, but now out-dated example, from #4497: + + class Num (RealOf t) => Normed t + type family RealOf x + +Assume the generated wanted constraint is: + [W] RealOf e ~ e + [W] Normed e + +If we were to be adding the superclasses during simplification we'd get: + [W] RealOf e ~ e + [W] Normed e + [D] RealOf e ~ fuv + [D] Num fuv +==> + e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv + +While looks exactly like our original constraint. If we add the +superclass of (Normed fuv) again we'd loop. By adding superclasses +definitely only once, during canonicalisation, this situation can't +happen. + +Mind you, now that Wanteds cannot rewrite Derived, I think this particular +situation can't happen. + +Note [Nested quantified constraint superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (typecheck/should_compile/T17202) + + class C1 a + class (forall c. C1 c) => C2 a + class (forall b. (b ~ F a) => C2 a) => C3 a + +Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass +to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a +superclass, as well. But we now must be careful: we cannot just add +(forall c. C1 c) as a Given, because we need to remember g2's context. +That new constraint is Given only when forall b. (b ~ F a) is true. + +It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c), +but that's problematic, because it's nested, and ForAllPred is not capable +of representing a nested quantified constraint. (We could change ForAllPred +to allow this, but the solution in this Note is much more local and simpler.) + +So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c). + +More generally, if we are expanding the superclasses of + g0 :: forall tvs. theta => cls tys +and find a superclass constraint + forall sc_tvs. sc_theta => sc_inner_pred +we must have a selector + sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred +and thus build + g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred + g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids. + sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids + +Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the +last bound variables and the last arguments. This avoids the need to produce +the sc_theta_ids at all. So our final construction is + + g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. + sel_id tys (g0 tvs theta_ids) sc_tvs + + -} + +makeSuperClasses :: [Ct] -> TcS [Ct] +-- Returns strict superclasses, transitively, see Note [The superclasses story] +-- See Note [The superclass story] +-- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType +-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s +-- superclasses, up to /and including/ the first repetition of C +-- +-- Example: class D a => C a +-- class C [a] => D a +-- makeSuperClasses (C x) will return (D x, C [x]) +-- +-- NB: the incoming constraints have had their cc_pend_sc flag already +-- flipped to False, by isPendingScDict, so we are /obliged/ to at +-- least produce the immediate superclasses +makeSuperClasses cts = concatMapM go cts + where + go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) + = mkStrictSuperClasses ev [] [] cls tys + go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev })) + = ASSERT2( isClassPred pred, ppr pred ) -- The cts should all have + -- class pred heads + mkStrictSuperClasses ev tvs theta cls tys + where + (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) + go ct = pprPanic "makeSuperClasses" (ppr ct) + +mkStrictSuperClasses + :: CtEvidence + -> [TyVar] -> ThetaType -- These two args are non-empty only when taking + -- superclasses of a /quantified/ constraint + -> Class -> [Type] -> TcS [Ct] +-- Return constraints for the strict superclasses of +-- ev :: forall as. theta => cls tys +mkStrictSuperClasses ev tvs theta cls tys + = mk_strict_superclasses (unitNameSet (className cls)) + ev tvs theta cls tys + +mk_strict_superclasses :: NameSet -> CtEvidence + -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcS [Ct] +-- Always return the immediate superclasses of (cls tys); +-- and expand their superclasses, provided none of them are in rec_clss +-- nor are repeated +mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) + tvs theta cls tys + = concatMapM (do_one_given (mk_given_loc loc)) $ + classSCSelIds cls + where + dict_ids = mkTemplateLocals theta + size = sizeTypes tys + + do_one_given given_loc sel_id + | isUnliftedType sc_pred + , not (null tvs && null theta) + = -- See Note [Equality superclasses in quantified constraints] + return [] + | otherwise + = do { given_ev <- newGivenEvVar given_loc $ + mk_given_desc sel_id sc_pred + ; mk_superclasses rec_clss given_ev tvs theta sc_pred } + where + sc_pred = classMethodInstTy sel_id tys + + -- See Note [Nested quantified constraint superclasses] + mk_given_desc :: Id -> PredType -> (PredType, EvTerm) + mk_given_desc sel_id sc_pred + = (swizzled_pred, swizzled_evterm) + where + (sc_tvs, sc_rho) = splitForAllTys sc_pred + (sc_theta, sc_inner_pred) = splitFunTys sc_rho + + all_tvs = tvs `chkAppend` sc_tvs + all_theta = theta `chkAppend` (map scaledThing sc_theta) + swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred + + -- evar :: forall tvs. theta => cls tys + -- sel_id :: forall cls_tvs. cls cls_tvs + -- -> forall sc_tvs. sc_theta => sc_inner_pred + -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred + swizzled_evterm = EvExpr $ + mkLams all_tvs $ + mkLams dict_ids $ + Var sel_id + `mkTyApps` tys + `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) + `mkVarApps` sc_tvs + + mk_given_loc loc + | isCTupleClass cls + = loc -- For tuple predicates, just take them apart, without + -- adding their (large) size into the chain. When we + -- get down to a base predicate, we'll include its size. + -- #10335 + + | GivenOrigin skol_info <- ctLocOrigin loc + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + -- for explantation of this transformation for givens + = case skol_info of + InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) } + InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } + _ -> loc + + | otherwise -- Probably doesn't happen, since this function + = loc -- is only used for Givens, but does no harm + +mk_strict_superclasses rec_clss ev tvs theta cls tys + | all noFreeVarsOfType tys + = return [] -- Wanteds with no variables yield no deriveds. + -- See Note [Improvement from Ground Wanteds] + + | otherwise -- Wanted/Derived case, just add Derived superclasses + -- that can lead to improvement. + = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta ) + concatMapM do_one_derived (immSuperClasses cls tys) + where + loc = ctEvLoc ev + + do_one_derived sc_pred + = do { sc_ev <- newDerivedNC loc sc_pred + ; mk_superclasses rec_clss sc_ev [] [] sc_pred } + +{- Note [Improvement from Ground Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose class C b a => D a b +and consider + [W] D Int Bool +Is there any point in emitting [D] C Bool Int? No! The only point of +emitting superclass constraints for W/D constraints is to get +improvement, extra unifications that result from functional +dependencies. See Note [Why adding superclasses can help] above. + +But no variables means no improvement; case closed. +-} + +mk_superclasses :: NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] +-- Return this constraint, plus its superclasses, if any +mk_superclasses rec_clss ev tvs theta pred + | ClassPred cls tys <- classifyPredType pred + = mk_superclasses_of rec_clss ev tvs theta cls tys + + | otherwise -- Superclass is not a class predicate + = return [mkNonCanonical ev] + +mk_superclasses_of :: NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> Class -> [Type] + -> TcS [Ct] +-- Always return this class constraint, +-- and expand its superclasses +mk_superclasses_of rec_clss ev tvs theta cls tys + | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) + ; return [this_ct] } -- cc_pend_sc of this_ct = True + | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys + , ppr (isCTupleClass cls) + , ppr rec_clss + ]) + ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys + ; return (this_ct : sc_cts) } + -- cc_pend_sc of this_ct = False + where + cls_nm = className cls + loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss + -- Tuples never contribute to recursion, and can be nested + rec_clss' = rec_clss `extendNameSet` cls_nm + + this_ct | null tvs, null theta + = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys + , cc_pend_sc = loop_found } + -- NB: If there is a loop, we cut off, so we have not + -- added the superclasses, hence cc_pend_sc = True + | otherwise + = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys + , qci_ev = ev + , qci_pend_sc = loop_found }) + + +{- Note [Equality superclasses in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#15359, #15593, #15625) + f :: (forall a. theta => a ~ b) => stuff + +It's a bit odd to have a local, quantified constraint for `(a~b)`, +but some people want such a thing (see the tickets). And for +Coercible it is definitely useful + f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) + => stuff + +Moreover it's not hard to arrange; we just need to look up /equality/ +constraints in the quantified-constraint environment, which we do in +GHC.Tc.Solver.Interact.doTopReactOther. + +There is a wrinkle though, in the case where 'theta' is empty, so +we have + f :: (forall a. a~b) => stuff + +Now, potentially, the superclass machinery kicks in, in +makeSuperClasses, giving us a a second quantified constraint + (forall a. a ~# b) +BUT this is an unboxed value! And nothing has prepared us for +dictionary "functions" that are unboxed. Actually it does just +about work, but the simplifier ends up with stuff like + case (/\a. eq_sel d) of df -> ...(df @Int)... +and fails to simplify that any further. And it doesn't satisfy +isPredTy any more. + +So for now we simply decline to take superclasses in the quantified +case. Instead we have a special case in GHC.Tc.Solver.Interact.doTopReactOther, +which looks for primitive equalities specially in the quantified +constraints. + +See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. + + +************************************************************************ +* * +* Irreducibles canonicalization +* * +************************************************************************ +-} + +canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct) +-- Precondition: ty not a tuple and no other evidence form +canIrred status ev + = do { let pred = ctEvPred ev + ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) + ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred + ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> + do { -- Re-classify, in case flattening has improved its shape + ; case classifyPredType (ctEvPred new_ev) of + ClassPred cls tys -> canClassNC new_ev cls tys + EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 + _ -> continueWith $ + mkIrredCt status new_ev } } + +{- ********************************************************************* +* * +* Quantified predicates +* * +********************************************************************* -} + +{- Note [Quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The -XQuantifiedConstraints extension allows type-class contexts like this: + + data Rose f x = Rose x (f (Rose f x)) + + instance (Eq a, forall b. Eq b => Eq (f b)) + => Eq (Rose f a) where + (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 + +Note the (forall b. Eq b => Eq (f b)) in the instance contexts. +This quantified constraint is needed to solve the + [W] (Eq (f (Rose f x))) +constraint which arises form the (==) definition. + +The wiki page is + https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints +which in turn contains a link to the GHC Proposal where the change +is specified, and a Haskell Symposium paper about it. + +We implement two main extensions to the design in the paper: + + 1. We allow a variable in the instance head, e.g. + f :: forall m a. (forall b. m b) => D (m a) + Notice the 'm' in the head of the quantified constraint, not + a class. + + 2. We support superclasses to quantified constraints. + For example (contrived): + f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool + f x y = x==y + Here we need (Eq (m a)); but the quantified constraint deals only + with Ord. But we can make it work by using its superclass. + +Here are the moving parts + * Language extension {-# LANGUAGE QuantifiedConstraints #-} + and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension + + * A new form of evidence, EvDFun, that is used to discharge + such wanted constraints + + * checkValidType gets some changes to accept forall-constraints + only in the right places. + + * Predicate.Pred gets a new constructor ForAllPred, and + and classifyPredType analyses a PredType to decompose + the new forall-constraints + + * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts, + which holds all the Given forall-constraints. In effect, + such Given constraints are like local instance decls. + + * When trying to solve a class constraint, via + GHC.Tc.Solver.Interact.matchInstEnv, use the InstEnv from inert_insts + so that we include the local Given forall-constraints + in the lookup. (See GHC.Tc.Solver.Monad.getInstEnvs.) + + * GHC.Tc.Solver.Canonical.canForAll deals with solving a + forall-constraint. See + Note [Solving a Wanted forall-constraint] + + * We augment the kick-out code to kick out an inert + forall constraint if it can be rewritten by a new + type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable + +Note that a quantified constraint is never /inferred/ +(by GHC.Tc.Solver.simplifyInfer). A function can only have a +quantified constraint in its type if it is given an explicit +type signature. + +-} + +canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType + -> TcS (StopOrContinue Ct) +canForAllNC ev tvs theta pred + | isGiven ev -- See Note [Eagerly expand given superclasses] + , Just (cls, tys) <- cls_pred_tys_maybe + = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys + ; emitWork sc_cts + ; canForAll ev False } + + | otherwise + = canForAll ev (isJust cls_pred_tys_maybe) + + where + cls_pred_tys_maybe = getClassPredTys_maybe pred + +canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct) +-- We have a constraint (forall as. blah => C tys) +canForAll ev pend_sc + = do { -- First rewrite it to apply the current substitution + -- Do not bother with type-family reductions; we can't + -- do them under a forall anyway (c.f. Flatten.flatten_one + -- on a forall type) + let pred = ctEvPred ev + ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred + ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> + + do { -- Now decompose into its pieces and solve it + -- (It takes a lot less code to flatten before decomposing.) + ; case classifyPredType (ctEvPred new_ev) of + ForAllPred tvs theta pred + -> solveForAll new_ev tvs theta pred pend_sc + _ -> pprPanic "canForAll" (ppr new_ev) + } } + +solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool + -> TcS (StopOrContinue Ct) +solveForAll ev tvs theta pred pend_sc + | CtWanted { ctev_dest = dest } <- ev + = -- See Note [Solving a Wanted forall-constraint] + do { let skol_info = QuantCtxtSkol + empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs + ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs + ; given_ev_vars <- mapM newEvVar (substTheta subst theta) + + ; (lvl, (w_id, wanteds)) + <- pushLevelNoWorkList (ppr skol_info) $ + do { wanted_ev <- newWantedEvVarNC loc $ + substTy subst pred + ; return ( ctEvEvId wanted_ev + , unitBag (mkNonCanonical wanted_ev)) } + + ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs + given_ev_vars wanteds + + ; setWantedEvTerm dest $ + EvFun { et_tvs = skol_tvs, et_given = given_ev_vars + , et_binds = ev_binds, et_body = w_id } + + ; stopWith ev "Wanted forall-constraint" } + + | isGiven ev -- See Note [Solving a Given forall-constraint] + = do { addInertForAll qci + ; stopWith ev "Given forall-constraint" } + + | otherwise + = do { traceTcS "discarding derived forall-constraint" (ppr ev) + ; stopWith ev "Derived forall-constraint" } + where + loc = ctEvLoc ev + qci = QCI { qci_ev = ev, qci_tvs = tvs + , qci_pred = pred, qci_pend_sc = pend_sc } + +{- Note [Solving a Wanted forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a wanted forall (quantified) constraint + [W] df :: forall ab. (Eq a, Ord b) => C x a b +is delightfully easy. Just build an implication constraint + forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a +and discharge df thus: + df = /\ab. \g1 g2. let in d +where is filled in by solving the implication constraint. +All the machinery is to hand; there is little to do. + +Note [Solving a Given forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a Given constraint + [G] df :: forall ab. (Eq a, Ord b) => C x a b +we just add it to TcS's local InstEnv of known instances, +via addInertForall. Then, if we look up (C x Int Bool), say, +we'll find a match in the InstEnv. + + +************************************************************************ +* * +* Equalities +* * +************************************************************************ + +Note [Canonicalising equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to canonicalise an equality, we look at the structure of the +two types at hand, looking for similarities. A difficulty is that the +types may look dissimilar before flattening but similar after flattening. +However, we don't just want to jump in and flatten right away, because +this might be wasted effort. So, after looking for similarities and failing, +we flatten and then try again. Of course, we don't want to loop, so we +track whether or not we've already flattened. + +It is conceivable to do a better job at tracking whether or not a type +is flattened, but this is left as future work. (Mar '15) + + +Note [Decomposing FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~ +can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This +means that we may very well have a FunTy containing a type of some +unknown kind. For instance, we may have, + + FunTy (a :: k) Int + +Where k is a unification variable. So the calls to getRuntimeRep_maybe may +fail (returning Nothing). In that case we'll fall through, zonk, and try again. +Zonking should fill the variable k, meaning that decomposition will succeed the +second time around. + +Also note that we require the AnonArgFlag to match. This will stop +us decomposing + (Int -> Bool) ~ (Show a => blah) +It's as if we treat (->) and (=>) as different type constructors. +-} + +canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) +canEqNC ev eq_rel ty1 ty2 + = do { result <- zonk_eq_types ty1 ty2 + ; case result of + Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 + Right ty -> canEqReflexive ev eq_rel ty } + +can_eq_nc + :: Bool -- True => both types are flat + -> CtEvidence + -> EqRel + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp + -> TcS (StopOrContinue Ct) +can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + = do { traceTcS "can_eq_nc" $ + vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] + ; rdr_env <- getGlobalRdrEnvTcS + ; fam_insts <- getFamInstEnvs + ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } + +can_eq_nc' + :: Bool -- True => both input types are flattened + -> GlobalRdrEnv -- needed to see which newtypes are in scope + -> FamInstEnvs -- needed to unwrap data instances + -> CtEvidence + -> EqRel + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp + -> TcS (StopOrContinue Ct) + +-- Expand synonyms first; see Note [Type synonyms and canonicalization] +can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 + | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 + +-- need to check for reflexivity in the ReprEq case. +-- See Note [Eager reflexivity check] +-- Check only when flat because the zonk_eq_types check in canEqNC takes +-- care of the non-flat case. +can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _ + | ty1 `tcEqType` ty2 + = canEqReflexive ev ReprEq ty1 + +-- When working with ReprEq, unwrap newtypes. +-- See Note [Unwrap newtypes first] +-- This must be above the TyVarTy case, in order to guarantee (TyEq:N) +can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | ReprEq <- eq_rel + , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 + = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2 + + | ReprEq <- eq_rel + , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 + = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1 + +-- Then, get rid of casts +can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 + | not (isTyVarTy ty2) -- See (3) in Note [Equalities with incompatible kinds] + = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 +can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ + | not (isTyVarTy ty1) -- See (3) in Note [Equalities with incompatible kinds] + = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 + +-- NB: pattern match on True: we want only flat types sent to canEqTyVar. +-- See also Note [No top-level newtypes on RHS of representational equalities] +can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2 + = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2 +can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2 + = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1 + +---------------------- +-- Otherwise try to decompose +---------------------- + +-- Literals +can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ + | l1 == l2 + = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1) + ; stopWith ev "Equal LitTy" } + +-- Decompose FunTy: (s -> t) and (c => t) +-- NB: don't decompose (Int -> blah) ~ (Show a => blah) +can_eq_nc' _flat _rdr_env _envs ev eq_rel + (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ + (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ + | af1 == af2 -- Don't decompose (Int -> blah) ~ (Show a => blah) + , Just ty1a_rep <- getRuntimeRep_maybe ty1a -- getRutimeRep_maybe: + , Just ty1b_rep <- getRuntimeRep_maybe ty1b -- see Note [Decomposing FunTy] + , Just ty2a_rep <- getRuntimeRep_maybe ty2a + , Just ty2b_rep <- getRuntimeRep_maybe ty2b + = canDecomposableTyConAppOK ev eq_rel funTyCon + [am1, ty1a_rep, ty1b_rep, ty1a, ty1b] + [am2, ty2a_rep, ty2b_rep, ty2a, ty2b] + +-- Decompose type constructor applications +-- NB: e have expanded type synonyms already +can_eq_nc' _flat _rdr_env _envs ev eq_rel + (TyConApp tc1 tys1) _ + (TyConApp tc2 tys2) _ + | not (isTypeFamilyTyCon tc1) + , not (isTypeFamilyTyCon tc2) + = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 + +can_eq_nc' _flat _rdr_env _envs ev eq_rel + s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ + = can_eq_nc_forall ev eq_rel s1 s2 + +-- See Note [Canonicalising type applications] about why we require flat types +can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _ + | NomEq <- eq_rel + , Just (t2, s2) <- tcSplitAppTy_maybe ty2 + = can_eq_app ev t1 s1 t2 s2 +can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ + | NomEq <- eq_rel + , Just (t1, s1) <- tcSplitAppTy_maybe ty1 + = can_eq_app ev t1 s1 t2 s2 + +-- No similarity in type structure detected. Flatten and try again. +can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 + = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 + ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 + ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 + ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } + +-- We've flattened and the types don't match. Give up. +can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 + = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) + ; case eq_rel of -- See Note [Unsolved equalities] + ReprEq -> continueWith (mkIrredCt OtherCIS ev) + NomEq -> continueWith (mkIrredCt InsolubleCIS ev) } + -- No need to call canEqFailure/canEqHardFailure because they + -- flatten, and the types involved here are already flat + +{- Note [Unsolved equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved equality like + (a b ~R# Int) +that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. +So we want to make it a potentially-soluble Irred not an insoluble one. +Missing this point is what caused #15431 +-} + +--------------------------------- +can_eq_nc_forall :: CtEvidence -> EqRel + -> Type -> Type -- LHS and RHS + -> TcS (StopOrContinue Ct) +-- (forall as. phi1) ~ (forall bs. phi2) +-- Check for length match of as, bs +-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs] +-- But remember also to unify the kinds of as and bs +-- (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] +-- Remember also that we might have forall z (a:z). blah +-- so we must proceed one binder at a time (#13879) + +can_eq_nc_forall ev eq_rel s1 s2 + | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev + = do { let free_tvs = tyCoVarsOfTypes [s1,s2] + (bndrs1, phi1) = tcSplitForAllVarBndrs s1 + (bndrs2, phi2) = tcSplitForAllVarBndrs s2 + ; if not (equalLength bndrs1 bndrs2) + then do { traceTcS "Forall failure" $ + vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 + , ppr (map binderArgFlag bndrs1) + , ppr (map binderArgFlag bndrs2) ] + ; canEqHardFailure ev s1 s2 } + else + do { traceTcS "Creating implication for polytype equality" $ ppr ev + ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs + ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ + binderVars bndrs1 + + ; let skol_info = UnifyForAllSkol phi1 + phi1' = substTy subst1 phi1 + + -- Unify the kinds, extend the substitution + go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] + -> TcS (TcCoercion, Cts) + go (skol_tv:skol_tvs) subst (bndr2:bndrs2) + = do { let tv2 = binderVar bndr2 + ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv) + (substTy subst (tyVarKind tv2)) + ; let subst' = extendTvSubstAndInScope subst tv2 + (mkCastTy (mkTyVarTy skol_tv) kind_co) + -- skol_tv is already in the in-scope set, but the + -- free vars of kind_co are not; hence "...AndInScope" + ; (co, wanteds2) <- go skol_tvs subst' bndrs2 + ; return ( mkTcForAllCo skol_tv kind_co co + , wanteds1 `unionBags` wanteds2 ) } + + -- Done: unify phi1 ~ phi2 + go [] subst bndrs2 + = ASSERT( null bndrs2 ) + unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) + + go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] + + empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) + + ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ + go skol_tvs empty_subst2 bndrs2 + ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds + + ; setWantedEq orig_dest all_co + ; stopWith ev "Deferred polytype equality" } } + + | otherwise + = do { traceTcS "Omitting decomposition of given polytype equality" $ + pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] + ; stopWith ev "Discard given polytype equality" } + + where + unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) + -- This version returns the wanted constraint rather + -- than putting it in the work list + unify loc role ty1 ty2 + | ty1 `tcEqType` ty2 + = return (mkTcReflCo role ty1, emptyBag) + | otherwise + = do { (wanted, co) <- newWantedEq loc role ty1 ty2 + ; return (co, unitBag (mkNonCanonical wanted)) } + +--------------------------------- +-- | Compare types for equality, while zonking as necessary. Gives up +-- as soon as it finds that two types are not equal. +-- This is quite handy when some unification has made two +-- types in an inert Wanted to be equal. We can discover the equality without +-- flattening, which is sometimes very expensive (in the case of type functions). +-- In particular, this function makes a ~20% improvement in test case +-- perf/compiler/T5030. +-- +-- Returns either the (partially zonked) types in the case of +-- inequality, or the one type in the case of equality. canEqReflexive is +-- a good next step in the 'Right' case. Returning 'Left' is always safe. +-- +-- NB: This does *not* look through type synonyms. In fact, it treats type +-- synonyms as rigid constructors. In the future, it might be convenient +-- to look at only those arguments of type synonyms that actually appear +-- in the synonym RHS. But we're not there yet. +zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) +zonk_eq_types = go + where + go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 + go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 + go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 + + -- We handle FunTys explicitly here despite the fact that they could also be + -- treated as an application. Why? Well, for one it's cheaper to just look + -- at two types (the argument and result types) than four (the argument, + -- result, and their RuntimeReps). Also, we haven't completely zonked yet, + -- so we may run into an unzonked type variable while trying to compute the + -- RuntimeReps of the argument and result types. This can be observed in + -- testcase tc269. + go ty1 ty2 + | Just (Scaled w1 arg1, res1) <- split1 + , Just (Scaled w2 arg2, res2) <- split2 + , eqType w1 w2 + = do { res_a <- go arg1 arg2 + ; res_b <- go res1 res2 + ; return $ combine_rev (mkVisFunTy w1) res_b res_a + } + | isJust split1 || isJust split2 + = bale_out ty1 ty2 + where + split1 = tcSplitFunTy_maybe ty1 + split2 = tcSplitFunTy_maybe ty2 + + go ty1 ty2 + | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2 + = if tc1 == tc2 && tys1 `equalLength` tys2 + -- Crucial to check for equal-length args, because + -- we cannot assume that the two args to 'go' have + -- the same kind. E.g go (Proxy * (Maybe Int)) + -- (Proxy (*->*) Maybe) + -- We'll call (go (Maybe Int) Maybe) + -- See #13083 + then tycon tc1 tys1 tys2 + else bale_out ty1 ty2 + + go ty1 ty2 + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = do { res_a <- go ty1a ty2a + ; res_b <- go ty1b ty2b + ; return $ combine_rev mkAppTy res_b res_a } + + go ty1@(LitTy lit1) (LitTy lit2) + | lit1 == lit2 + = return (Right ty1) + + go ty1 ty2 = bale_out ty1 ty2 + -- We don't handle more complex forms here + + bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) + + tyvar :: SwapFlag -> TcTyVar -> TcType + -> TcS (Either (Pair TcType) TcType) + -- Try to do as little as possible, as anything we do here is redundant + -- with flattening. In particular, no need to zonk kinds. That's why + -- we don't use the already-defined zonking functions + tyvar swapped tv ty + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> give_up + Indirect ty' -> do { trace_indirect tv ty' + ; unSwap swapped go ty' ty } } + _ -> give_up + where + give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty + + tyvar_tyvar tv1 tv2 + | tv1 == tv2 = return (Right (mkTyVarTy tv1)) + | otherwise = do { (ty1', progress1) <- quick_zonk tv1 + ; (ty2', progress2) <- quick_zonk tv2 + ; if progress1 || progress2 + then go ty1' ty2' + else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } + + trace_indirect tv ty + = traceTcS "Following filled tyvar (zonk_eq_types)" + (ppr tv <+> equals <+> ppr ty) + + quick_zonk tv = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> return (TyVarTy tv, False) + Indirect ty' -> do { trace_indirect tv ty' + ; return (ty', True) } } + _ -> return (TyVarTy tv, False) + + -- This happens for type families, too. But recall that failure + -- here just means to try harder, so it's OK if the type function + -- isn't injective. + tycon :: TyCon -> [TcType] -> [TcType] + -> TcS (Either (Pair TcType) TcType) + tycon tc tys1 tys2 + = do { results <- zipWithM go tys1 tys2 + ; return $ case combine_results results of + Left tys -> Left (mkTyConApp tc <$> tys) + Right tys -> Right (mkTyConApp tc tys) } + + combine_results :: [Either (Pair TcType) TcType] + -> Either (Pair [TcType]) [TcType] + combine_results = bimap (fmap reverse) reverse . + foldl' (combine_rev (:)) (Right []) + + -- combine (in reverse) a new result onto an already-combined result + combine_rev :: (a -> b -> c) + -> Either (Pair b) b + -> Either (Pair a) a + -> Either (Pair c) c + combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) + combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) + combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) + combine_rev f (Right tys) (Right ty) = Right (f ty tys) + +{- See Note [Unwrap newtypes first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + newtype N m a = MkN (m a) +Then N will get a conservative, Nominal role for its second parameter 'a', +because it appears as an argument to the unknown 'm'. Now consider + [W] N Maybe a ~R# N Maybe b + +If we decompose, we'll get + [W] a ~N# b + +But if instead we unwrap we'll get + [W] Maybe a ~R# Maybe b +which in turn gives us + [W] a ~R# b +which is easier to satisfy. + +Bottom line: unwrap newtypes before decomposing them! +c.f. #9123 comment:52,53 for a compelling example. + +Note [Newtypes can blow the stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + newtype Y = MkY (Int -> Y) + +and now wish to prove + + [W] X ~R Y + +This Wanted will loop, expanding out the newtypes ever deeper looking +for a solid match or a solid discrepancy. Indeed, there is something +appropriate to this looping, because X and Y *do* have the same representation, +in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized +coercion will ever witness it. This loop won't actually cause GHC to hang, +though, because we check our depth when unwrapping newtypes. + +Note [Eager reflexivity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + +and + + [W] X ~R X + +Naively, we would start unwrapping X and end up in a loop. Instead, +we do this eager reflexivity check. This is necessary only for representational +equality because the flattener technology deals with the similar case +(recursive type families) for nominal equality. + +Note that this check does not catch all cases, but it will catch the cases +we're most worried about, types like X above that are actually inhabited. + +Here's another place where this reflexivity check is key: +Consider trying to prove (f a) ~R (f a). The AppTys in there can't +be decomposed, because representational equality isn't congruent with respect +to AppTy. So, when canonicalising the equality above, we get stuck and +would normally produce a CIrredCan. However, we really do want to +be able to solve (f a) ~R (f a). So, in the representational case only, +we do a reflexivity check. + +(This would be sound in the nominal case, but unnecessary, and I [Richard +E.] am worried that it would slow down the common case.) +-} + +------------------------ +-- | We're able to unwrap a newtype. Update the bits accordingly. +can_eq_newtype_nc :: CtEvidence -- ^ :: ty1 ~ ty2 + -> SwapFlag + -> TcType -- ^ ty1 + -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' + -> TcType -- ^ ty2 + -> TcType -- ^ ty2, with type synonyms + -> TcS (StopOrContinue Ct) +can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2 + = do { traceTcS "can_eq_newtype_nc" $ + vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ] + + -- check for blowing our stack: + -- See Note [Newtypes can blow the stack] + ; checkReductionDepth (ctEvLoc ev) ty1 + + -- Next, we record uses of newtype constructors, since coercing + -- through newtypes is tantamount to using their constructors. + ; addUsedGREs gre_list + -- If a newtype constructor was imported, don't warn about not + -- importing it... + ; traverse_ keepAlive $ map gre_name gre_list + -- ...and similarly, if a newtype constructor was defined in the same + -- module, don't warn about it being unused. + -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. + + ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2 + (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) + ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } + where + gre_list = bagToList gres + +--------- +-- ^ Decompose a type application. +-- All input types must be flat. See Note [Canonicalising type applications] +-- Nominal equality only! +can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 + -> Xi -> Xi -- s1 t1 + -> Xi -> Xi -- s2 t2 + -> TcS (StopOrContinue Ct) + +-- AppTys only decompose for nominal equality, so this case just leads +-- to an irreducible constraint; see typecheck/should_compile/T10494 +-- See Note [Decomposing equality], note {4} +can_eq_app ev s1 t1 s2 t2 + | CtDerived {} <- ev + = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] + ; stopWith ev "Decomposed [D] AppTy" } + + | CtWanted { ctev_dest = dest } <- ev + = do { co_s <- unifyWanted loc Nominal s1 s2 + ; let arg_loc + | isNextArgVisible s1 = loc + | otherwise = updateCtLocOrigin loc toInvisibleOrigin + ; co_t <- unifyWanted arg_loc Nominal t1 t2 + ; let co = mkAppCo co_s co_t + ; setWantedEq dest co + ; stopWith ev "Decomposed [W] AppTy" } + + -- If there is a ForAll/(->) mismatch, the use of the Left coercion + -- below is ill-typed, potentially leading to a panic in splitTyConApp + -- Test case: typecheck/should_run/Typeable1 + -- We could also include this mismatch check above (for W and D), but it's slow + -- and we'll get a better error message not doing it + | s1k `mismatches` s2k + = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) + + | CtGiven { ctev_evar = evar } <- ev + = do { let co = mkTcCoVarCo evar + co_s = mkTcLRCo CLeft co + co_t = mkTcLRCo CRight co + ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 + , evCoercion co_s ) + ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 + , evCoercion co_t ) + ; emitWorkNC [evar_t] + ; canEqNC evar_s NomEq s1 s2 } + + where + loc = ctEvLoc ev + + s1k = tcTypeKind s1 + s2k = tcTypeKind s2 + + k1 `mismatches` k2 + = isForAllTy k1 && not (isForAllTy k2) + || not (isForAllTy k1) && isForAllTy k2 + +----------------------- +-- | Break apart an equality over a casted type +-- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) +canEqCast :: Bool -- are both types flat? + -> CtEvidence + -> EqRel + -> SwapFlag + -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 + -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty + -> TcS (StopOrContinue Ct) +canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2 + = do { traceTcS "Decomposing cast" (vcat [ ppr ev + , ppr ty1 <+> text "|>" <+> ppr co1 + , ppr ps_ty2 ]) + ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2 + (mkTcGReflRightCo role ty1 co1) + (mkTcReflCo role ps_ty2) + ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 } + where + role = eqRelRole eq_rel + +------------------------ +canTyConApp :: CtEvidence -> EqRel + -> TyCon -> [TcType] + -> TyCon -> [TcType] + -> TcS (StopOrContinue Ct) +-- See Note [Decomposing TyConApps] +-- Neither tc1 nor tc2 is a saturated funTyCon +canTyConApp ev eq_rel tc1 tys1 tc2 tys2 + | tc1 == tc2 + , tys1 `equalLength` tys2 + = do { inerts <- getTcSInerts + ; if can_decompose inerts + then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 + else canEqFailure ev eq_rel ty1 ty2 } + + -- See Note [Skolem abstract data] (at tyConSkolem) + | tyConSkolem tc1 || tyConSkolem tc2 + = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) + ; continueWith (mkIrredCt OtherCIS ev) } + + -- Fail straight away for better error messages + -- See Note [Use canEqFailure in canDecomposableTyConApp] + | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational && + isGenerativeTyCon tc2 Representational) + = canEqFailure ev eq_rel ty1 ty2 + | otherwise + = canEqHardFailure ev ty1 ty2 + where + -- Reconstruct the types for error messages. This would do + -- the wrong thing (from a pretty printing point of view) + -- for functions, because we've lost the AnonArgFlag; but + -- in fact we never call canTyConApp on a saturated FunTyCon + ty1 = mkTyConApp tc1 tys1 + ty2 = mkTyConApp tc2 tys2 + + loc = ctEvLoc ev + pred = ctEvPred ev + + -- See Note [Decomposing equality] + can_decompose inerts + = isInjectiveTyCon tc1 (eqRelRole eq_rel) + || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts)) + +{- +Note [Use canEqFailure in canDecomposableTyConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must use canEqFailure, not canEqHardFailure here, because there is +the possibility of success if working with a representational equality. +Here is one case: + + type family TF a where TF Char = Bool + data family DF a + newtype instance DF Bool = MkDF Int + +Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet +know `a`. This is *not* a hard failure, because we might soon learn +that `a` is, in fact, Char, and then the equality succeeds. + +Here is another case: + + [G] Age ~R Int + +where Age's constructor is not in scope. We don't want to report +an "inaccessible code" error in the context of this Given! + +For example, see typecheck/should_compile/T10493, repeated here: + + import Data.Ord (Down) -- no constructor + + foo :: Coercible (Down Int) Int => Down Int -> Int + foo = coerce + +That should compile, but only because we use canEqFailure and not +canEqHardFailure. + +Note [Decomposing equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a constraint (of any flavour and role) that looks like +T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer, +of course, is "it depends". This Note spells it all out. + +In this Note, "decomposition" refers to taking the constraint + [fl] (T tys1 ~X T tys2) +(for some flavour fl and some role X) and replacing it with + [fls'] (tys1 ~Xs' tys2) +where that notation indicates a list of new constraints, where the +new constraints may have different flavours and different roles. + +The key property to consider is injectivity. When decomposing a Given the +decomposition is sound if and only if T is injective in all of its type +arguments. When decomposing a Wanted, the decomposition is sound (assuming the +correct roles in the produced equality constraints), but it may be a guess -- +that is, an unforced decision by the constraint solver. Decomposing Wanteds +over injective TyCons does not entail guessing. But sometimes we want to +decompose a Wanted even when the TyCon involved is not injective! (See below.) + +So, in broad strokes, we want this rule: + +(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective +at role X. + +Pursuing the details requires exploring three axes: +* Flavour: Given vs. Derived vs. Wanted +* Role: Nominal vs. Representational +* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable + +(So a type variable isn't a TyCon, but it's convenient to put the AppTy case +in the same table.) + +Right away, we can say that Derived behaves just as Wanted for the purposes +of decomposition. The difference between Derived and Wanted is the handling of +evidence. Since decomposition in these cases isn't a matter of soundness but of +guessing, we want the same behavior regardless of evidence. + +Here is a table (discussion following) detailing where decomposition of + (T s1 ... sn) ~r (T t1 .. tn) +is allowed. The first four lines (Data types ... type family) refer +to TyConApps with various TyCons T; the last line is for AppTy, where +there is presumably a type variable at the head, so it's actually + (s s1 ... sn) ~r (t t1 .. tn) + +NOMINAL GIVEN WANTED + +Datatype YES YES +Newtype YES YES +Data family YES YES +Type family YES, in injective args{1} YES, in injective args{1} +Type variable YES YES + +REPRESENTATIONAL GIVEN WANTED + +Datatype YES YES +Newtype NO{2} MAYBE{2} +Data family NO{3} MAYBE{3} +Type family NO NO +Type variable NO{4} NO{4} + +{1}: Type families can be injective in some, but not all, of their arguments, +so we want to do partial decomposition. This is quite different than the way +other decomposition is done, where the decomposed equalities replace the original +one. We thus proceed much like we do with superclasses: emitting new Givens +when "decomposing" a partially-injective type family Given and new Deriveds +when "decomposing" a partially-injective type family Wanted. (As of the time of +writing, 13 June 2015, the implementation of injective type families has not +been merged, but it should be soon. Please delete this parenthetical if the +implementation is indeed merged.) + +{2}: See Note [Decomposing newtypes at representational role] + +{3}: Because of the possibility of newtype instances, we must treat +data families like newtypes. See also Note [Decomposing newtypes at +representational role]. See #10534 and test case +typecheck/should_fail/T10534. + +{4}: Because type variables can stand in for newtypes, we conservatively do not +decompose AppTys over representational equality. + +In the implementation of can_eq_nc and friends, we don't directly pattern +match using lines like in the tables above, as those tables don't cover +all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, +boiling the tables above down to rule (*). The exceptions to rule (*) are for +injective type families, which are handled separately from other decompositions, +and the MAYBE entries above. + +Note [Decomposing newtypes at representational role] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note discusses the 'newtype' line in the REPRESENTATIONAL table +in Note [Decomposing equality]. (At nominal role, newtypes are fully +decomposable.) + +Here is a representative example of why representational equality over +newtypes is tricky: + + newtype Nt a = Mk Bool -- NB: a is not used in the RHS, + type role Nt representational -- but the user gives it an R role anyway + +If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to +[W] alpha ~R beta, because it's possible that alpha and beta aren't +representationally equal. Here's another example. + + newtype Nt a = MkNt (Id a) + type family Id a where Id a = a + + [W] Nt Int ~R Nt Age + +Because of its use of a type family, Nt's parameter will get inferred to have +a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which +is unsatisfiable. Unwrapping, though, leads to a solution. + +Conclusion: + * Unwrap newtypes before attempting to decompose them. + This is done in can_eq_nc'. + +It all comes from the fact that newtypes aren't necessarily injective +w.r.t. representational equality. + +Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use +NthCo on representational coercions over newtypes. NthCo comes into play +only when decomposing givens. + +Conclusion: + * Do not decompose [G] N s ~R N t + +Is it sensible to decompose *Wanted* constraints over newtypes? Yes! +It's the only way we could ever prove (IO Int ~R IO Age), recalling +that IO is a newtype. + +However we must be careful. Consider + + type role Nt representational + + [G] Nt a ~R Nt b (1) + [W] NT alpha ~R Nt b (2) + [W] alpha ~ a (3) + +If we focus on (3) first, we'll substitute in (2), and now it's +identical to the given (1), so we succeed. But if we focus on (2) +first, and decompose it, we'll get (alpha ~R b), which is not soluble. +This is exactly like the question of overlapping Givens for class +constraints: see Note [Instance and Given overlap] in GHC.Tc.Solver.Interact. + +Conclusion: + * Decompose [W] N s ~R N t iff there no given constraint that could + later solve it. + +-} + +canDecomposableTyConAppOK :: CtEvidence -> EqRel + -> TyCon -> [TcType] -> [TcType] + -> TcS (StopOrContinue Ct) +-- Precondition: tys1 and tys2 are the same length, hence "OK" +canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 + = ASSERT( tys1 `equalLength` tys2 ) + do { traceTcS "canDecomposableTyConAppOK" + (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) + ; case ev of + CtDerived {} + -> unifyDeriveds loc tc_roles tys1 tys2 + + CtWanted { ctev_dest = dest } + -- new_locs and tc_roles are both infinite, so + -- we are guaranteed that cos has the same length + -- as tys1 and tys2 + -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2 + ; setWantedEq dest (mkTyConAppCo role tc cos) } + + CtGiven { ctev_evar = evar } + -> do { let ev_co = mkCoVarCo evar + ; given_evs <- newGivenEvVars loc $ + [ ( mkPrimEqPredRole r ty1 ty2 + , evCoercion $ mkNthCo r i ev_co ) + | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] + , r /= Phantom + , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] + ; emitWorkNC given_evs } + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + + -- infinite, as tyConRolesX returns an infinite tail of Nominal + tc_roles = tyConRolesX role tc + + -- Add nuances to the location during decomposition: + -- * if the argument is a kind argument, remember this, so that error + -- messages say "kind", not "type". This is determined based on whether + -- the corresponding tyConBinder is named (that is, dependent) + -- * if the argument is invisible, note this as well, again by + -- looking at the corresponding binder + -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't + -- do either of these changes. (Forgetting to do so led to #16188) + -- + -- NB: infinite in length + new_locs = [ new_loc + | bndr <- tyConBinders tc + , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc + | otherwise = loc + new_loc | isVisibleTyConBinder bndr + = updateCtLocOrigin new_loc0 toInvisibleOrigin + | otherwise + = new_loc0 ] + ++ repeat loc + +-- | Call when canonicalizing an equality fails, but if the equality is +-- representational, there is some hope for the future. +-- Examples in Note [Use canEqFailure in canDecomposableTyConApp] +canEqFailure :: CtEvidence -> EqRel + -> TcType -> TcType -> TcS (StopOrContinue Ct) +canEqFailure ev NomEq ty1 ty2 + = canEqHardFailure ev ty1 ty2 +canEqFailure ev ReprEq ty1 ty2 + = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1 + ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 + -- We must flatten the types before putting them in the + -- inert set, so that we are sure to kick them out when + -- new equalities become available + ; traceTcS "canEqFailure with ReprEq" $ + vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ] + ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 + ; continueWith (mkIrredCt OtherCIS new_ev) } + +-- | Call when canonicalizing an equality fails with utterly no hope. +canEqHardFailure :: CtEvidence + -> TcType -> TcType -> TcS (StopOrContinue Ct) +-- See Note [Make sure that insolubles are fully rewritten] +canEqHardFailure ev ty1 ty2 + = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) + ; (s1, co1) <- flatten FM_SubstOnly ev ty1 + ; (s2, co2) <- flatten FM_SubstOnly ev ty2 + ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 + ; continueWith (mkIrredCt InsolubleCIS new_ev) } + +{- +Note [Decomposing TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (T s1 t1 ~ T s2 t2), then we can just decompose to + (s1 ~ s2, t1 ~ t2) +and push those back into the work list. But if + s1 = K k1 s2 = K k2 +then we will just decomopose s1~s2, and it might be better to +do so on the spot. An important special case is where s1=s2, +and we get just Refl. + +So canDecomposableTyCon is a fast-path decomposition that uses +unifyWanted etc to short-cut that work. + +Note [Canonicalising type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (s1 t1) ~ ty2, how should we proceed? +The simple things is to see if ty2 is of form (s2 t2), and +decompose. By this time s1 and s2 can't be saturated type +function applications, because those have been dealt with +by an earlier equation in can_eq_nc, so it is always sound to +decompose. + +However, over-eager decomposition gives bad error messages +for things like + a b ~ Maybe c + e f ~ p -> q +Suppose (in the first example) we already know a~Array. Then if we +decompose the application eagerly, yielding + a ~ Maybe + b ~ c +we get an error "Can't match Array ~ Maybe", +but we'd prefer to get "Can't match Array b ~ Maybe c". + +So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of +replacing (a b) by (Array b), before using try_decompose_app to +decompose it. + +Note [Make sure that insolubles are fully rewritten] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When an equality fails, we still want to rewrite the equality +all the way down, so that it accurately reflects + (a) the mutable reference substitution in force at start of solving + (b) any ty-binds in force at this point in solving +See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad. +And if we don't do this there is a bad danger that +GHC.Tc.Solver.applyTyVarDefaulting will find a variable +that has in fact been substituted. + +Note [Do not decompose Given polytype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? +No -- what would the evidence look like? So instead we simply discard +this given evidence. + + +Note [Combining insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As this point we have an insoluble constraint, like Int~Bool. + + * If it is Wanted, delete it from the cache, so that subsequent + Int~Bool constraints give rise to separate error messages + + * But if it is Derived, DO NOT delete from cache. A class constraint + may get kicked out of the inert set, and then have its functional + dependency Derived constraints generated a second time. In that + case we don't want to get two (or more) error messages by + generating two (or more) insoluble fundep constraints from the same + class constraint. + +Note [No top-level newtypes on RHS of representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we're in this situation: + + work item: [W] c1 : a ~R b + inert: [G] c2 : b ~R Id a + +where + newtype Id a = Id a + +We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened +and the Id newtype is unwrapped. This is assured by requiring only flat +types in canEqTyVar *and* having the newtype-unwrapping check above +the tyvar check in can_eq_nc. + +Note [Occurs check error] +~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an occurs check error, are we necessarily hosed? Say our +tyvar is tv1 and the type it appears in is xi2. Because xi2 is function +free, then if we're computing w.r.t. nominal equality, then, yes, we're +hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. +representational equality, this is a little subtler. Once again, (a ~R [a]) +is a bad thing, but (a ~R N a) for a newtype N might be just fine. This +means also that (a ~ b a) might be fine, because `b` might become a newtype. + +So, we must check: does tv1 appear in xi2 under any type constructor +that is generative w.r.t. representational equality? That's what +isInsolubleOccursCheck does. + +See also #10715, which induced this addition. + +Note [canCFunEqCan] +~~~~~~~~~~~~~~~~~~~ +Flattening the arguments to a type family can change the kind of the type +family application. As an easy example, consider (Any k) where (k ~ Type) +is in the inert set. The original (Any k :: k) becomes (Any Type :: Type). +The problem here is that the fsk in the CFunEqCan will have the old kind. + +The solution is to come up with a new fsk/fmv of the right kind. For +givens, this is easy: just introduce a new fsk and update the flat-cache +with the new one. For wanteds, we want to solve the old one if favor of +the new one, so we use dischargeFmv. This also kicks out constraints +from the inert set; this behavior is correct, as the kind-change may +allow more constraints to be solved. + +We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case +if we really need to. Of course `flattenArgsNom` should return `Refl` +whenever possible, but #15577 was an infinite loop because even +though the coercion was homo-kinded, `kind_co` was not `Refl`, so we +made a new (identical) CFunEqCan, and then the entire process repeated. +-} + +canCFunEqCan :: CtEvidence + -> TyCon -> [TcType] -- LHS + -> TcTyVar -- RHS + -> TcS (StopOrContinue Ct) +-- ^ Canonicalise a CFunEqCan. We know that +-- the arg types are already flat, +-- and the RHS is a fsk, which we must *not* substitute. +-- So just substitute in the LHS +canCFunEqCan ev fn tys fsk + = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys + -- cos :: tys' ~ tys + + ; let lhs_co = mkTcTyConAppCo Nominal fn cos + -- :: F tys' ~ F tys + new_lhs = mkTyConApp fn tys' + + flav = ctEvFlavour ev + ; (ev', fsk') + <- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan] + then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs) + ; let fsk_ty = mkTyVarTy fsk + ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty + lhs_co (mkTcNomReflCo fsk_ty) + ; return (ev', fsk) } + else do { traceTcS "canCFunEqCan: non-refl" $ + vcat [ text "Kind co:" <+> ppr kind_co + , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk) + , text "LHS:" <+> hang (ppr (mkTyConApp fn tys)) + 2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys))) + , text "New LHS" <+> hang (ppr new_lhs) + 2 (dcolon <+> ppr (tcTypeKind new_lhs)) ] + ; (ev', new_co, new_fsk) + <- newFlattenSkolem flav (ctEvLoc ev) fn tys' + ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co + -- sym lhs_co :: F tys ~ F tys' + -- new_co :: F tys' ~ new_fsk + -- co :: F tys ~ (new_fsk |> kind_co) + co = mkTcSymCo lhs_co `mkTcTransCo` + mkTcCoherenceRightCo Nominal + (mkTyVarTy new_fsk) + kind_co + new_co + + ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev) + ; dischargeFunEq ev fsk co xi + ; return (ev', new_fsk) } + + ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev') + ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn + , cc_tyargs = tys', cc_fsk = fsk' }) } + +--------------------- +canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs + -> EqRel -> SwapFlag + -> TcTyVar -- tv1 + -> TcType -- lhs: pretty lhs, already flat + -> TcType -> TcType -- rhs: already flat + -> TcS (StopOrContinue Ct) +canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 + | k1 `tcEqType` k2 + = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 + + | otherwise + = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2 + + where + k1 = tyVarKind tv1 + k2 = tcTypeKind xi2 + +canEqTyVarHetero :: CtEvidence -- :: (tv1 :: ki1) ~ (xi2 :: ki2) + -> EqRel -> SwapFlag + -> TcTyVar -> TcType -- tv1, pretty tv1 + -> TcKind -- ki1 + -> TcType -> TcType -- xi2, pretty xi2 :: ki2 + -> TcKind -- ki2 + -> TcS (StopOrContinue Ct) +canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 + -- See Note [Equalities with incompatible kinds] + = do { kind_co <- emit_kind_co -- :: ki2 ~N ki1 + + ; let -- kind_co :: (ki2 :: *) ~N (ki1 :: *) (whether swapped or not) + -- co1 :: kind(tv1) ~N ki1 + rhs' = xi2 `mkCastTy` kind_co -- :: ki1 + ps_rhs' = ps_xi2 `mkCastTy` kind_co -- :: ki1 + rhs_co = mkTcGReflLeftCo role xi2 kind_co + -- rhs_co :: (xi2 |> kind_co) ~ xi2 + + lhs' = mkTyVarTy tv1 -- same as old lhs + lhs_co = mkTcReflCo role lhs' + + ; traceTcS "Hetero equality gives rise to kind equality" + (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ]) + ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co + + -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more + ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' } + where + emit_kind_co :: TcS CoercionN + emit_kind_co + | CtGiven { ctev_evar = evar } <- ev + = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 + ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) + ; emitWorkNC [kind_ev] + ; return (ctEvCoercion kind_ev) } + + | otherwise + = unifyWanted kind_loc Nominal ki2 ki1 + + loc = ctev_loc ev + role = eqRelRole eq_rel + kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc + kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1 + + maybe_sym = case swapped of + IsSwapped -> id -- if the input is swapped, then we already + -- will have k2 ~ k1 + NotSwapped -> mkTcSymCo + +-- guaranteed that tcTypeKind lhs == tcTypeKind rhs +canEqTyVarHomo :: CtEvidence + -> EqRel -> SwapFlag + -> TcTyVar -- lhs: tv1 + -> TcType -- pretty lhs, flat + -> TcType -> TcType -- rhs, flat + -> TcS (StopOrContinue Ct) +canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _ + | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2 + , tv1 == tv2 + = canEqReflexive ev eq_rel (mkTyVarTy tv1) + -- we don't need to check co because it must be reflexive + + -- this guarantees (TyEq:TV) + | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2 + , swapOverTyVars (isGiven ev) tv1 tv2 + = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) + ; let role = eqRelRole eq_rel + sym_co2 = mkTcSymCo co2 + ty1 = mkTyVarTy tv1 + new_lhs = ty1 `mkCastTy` sym_co2 + lhs_co = mkTcGReflLeftCo role ty1 sym_co2 + + new_rhs = mkTyVarTy tv2 + rhs_co = mkTcGReflRightCo role new_rhs co2 + + ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co + + ; dflags <- getDynFlags + ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) } + +canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2 + = do { dflags <- getDynFlags + ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 } + +-- The RHS here is either not a casted tyvar, or it's a tyvar but we want +-- to rewrite the LHS to the RHS (as per swapOverTyVars) +canEqTyVar2 :: DynFlags + -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs) + -> EqRel + -> SwapFlag + -> TcTyVar -- lhs = tv, flat + -> TcType -- rhs, flat + -> TcS (StopOrContinue Ct) +-- LHS is an inert type variable, +-- and RHS is fully rewritten, but with type synonyms +-- preserved as much as possible +-- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) +-- the "flat" requirement guarantees (TyEq:AFF) +-- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo +canEqTyVar2 dflags ev eq_rel swapped tv1 rhs + -- this next line checks also for coercion holes; see + -- Note [Equalities with incompatible kinds] + | MTVU_OK rhs' <- mtvu -- No occurs check + -- Must do the occurs check even on tyvar/tyvar + -- equalities, in case have x ~ (y :: ..x...) + -- #12593 + -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H) + = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2 + ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1 + , cc_rhs = rhs', cc_eq_rel = eq_rel }) } + + | otherwise -- For some reason (occurs check, or forall) we can't unify + -- We must not use it for further rewriting! + = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs) + ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2 + ; let status | isInsolubleOccursCheck eq_rel tv1 rhs + = InsolubleCIS + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver + + | MTVU_HoleBlocker <- mtvu + = BlockedCIS + -- This is the case detailed in + -- Note [Equalities with incompatible kinds] + + | otherwise + = OtherCIS + -- A representational equality with an occurs-check problem isn't + -- insoluble! For example: + -- a ~R b a + -- We might learn that b is the newtype Id. + -- But, the occurs-check certainly prevents the equality from being + -- canonical, and we might loop if we were to use it in rewriting. + + ; continueWith (mkIrredCt status new_ev) } + where + mtvu = metaTyVarUpdateOK dflags tv1 rhs + + role = eqRelRole eq_rel + + lhs = mkTyVarTy tv1 + + rewrite_co1 = mkTcReflCo role lhs + rewrite_co2 = mkTcReflCo role rhs + +-- | Solve a reflexive equality constraint +canEqReflexive :: CtEvidence -- ty ~ ty + -> EqRel + -> TcType -- ty + -> TcS (StopOrContinue Ct) -- always Stop +canEqReflexive ev eq_rel ty + = do { setEvBindIfWanted ev (evCoercion $ + mkTcReflCo (eqRelRole eq_rel) ty) + ; stopWith ev "Solved by reflexivity" } + +{- Note [Equalities with incompatible kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What do we do when we have an equality + + (tv :: k1) ~ (rhs :: k2) + +where k1 and k2 differ? Easy: we create a coercion that relates k1 and +k2 and use this to cast. To wit, from + + [X] (tv :: k1) ~ (rhs :: k2) + +we go to + + [noDerived X] co :: k2 ~ k1 + [X] (tv :: k1) ~ ((rhs |> co) :: k1) + +where + + noDerived G = G + noDerived _ = W + +Wrinkles: + + (1) The noDerived step is because Derived equalities have no evidence. + And yet we absolutely need evidence to be able to proceed here. + Given evidence will use the KindCo coercion; Wanted evidence will + be a coercion hole. Even a Derived hetero equality begets a Wanted + kind equality. + + (2) Though it would be sound to do so, we must not mark the rewritten Wanted + [W] (tv :: k1) ~ ((rhs |> co) :: k1) + as canonical in the inert set. In particular, we must not unify tv. + If we did, the Wanted becomes a Given (effectively), and then can + rewrite other Wanteds. But that's bad: See Note [Wanteds to not rewrite Wanteds] + in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for + tales of destruction. + + So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have + any coercion holes. This is checked in metaTyVarUpdateOK. We also + must be sure to kick out any constraints that mention coercion holes + when those holes get filled in. + + (2a) We don't want to do this for CoercionHoles that witness + CFunEqCans (that are produced by the flattener), as these will disappear + once we unflatten. So we remember in the CoercionHole structure + whether the presence of the hole should block substitution or not. + A bit gross, this. + + (2b) We must now absolutely make sure to kick out any constraints that + mention a newly-filled-in coercion hole. This is done in + kickOutAfterFillingCoercionHole. + + (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the + algorithm detailed here, producing [W] co :: k2 ~ k1, and adding + [W] (a :: k1) ~ ((rhs |> co) :: k1) to the irreducibles. Some time + later, we solve co, and fill in co's coercion hole. This kicks out + the irreducible as described in (2b). + But now, during canonicalization, we see the cast + and remove it, in canEqCast. By the time we get into canEqTyVar, the equality + is heterogeneous again, and the process repeats. + + To avoid this, we don't strip casts off a type if the other type + in the equality is a tyvar. And this is an improvement regardless: + because tyvars can, generally, unify with casted types, there's no + reason to go through the work of stripping off the cast when the + cast appears opposite a tyvar. This is implemented in the cast case + of can_eq_nc'. + + (4) Reporting an error for a constraint that is blocked only because + of wrinkle (2) is hard: what would we say to users? And we don't + really need to report, because if a constraint is blocked, then + there is unsolved wanted blocking it; that unsolved wanted will + be reported. We thus push such errors to the bottom of the queue + in the error-reporting code; they should never be printed. + + (4a) It would seem possible to do this filtering just based on the + presence of a blocking coercion hole. However, this is no good, + as it suppresses e.g. no-instance-found errors. We thus record + a CtIrredStatus in CIrredCan and filter based on this status. + This happened in T14584. An alternative approach is to expressly + look for *equalities* with blocking coercion holes, but actually + recording the blockage in a status field seems nicer. + + (4b) The error message might be printed with -fdefer-type-errors, + so it still must exist. This is the only reason why there is + a message at all. Otherwise, we could simply do nothing. + +Historical note: + +We used to do this via emitting a Derived kind equality and then parking +the heterogeneous equality as irreducible. But this new approach is much +more direct. And it doesn't produce duplicate Deriveds (as the old one did). + +Note [Type synonyms and canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat type synonym applications as xi types, that is, they do not +count as type function applications. However, we do need to be a bit +careful with type synonyms: like type functions they may not be +generative or injective. However, unlike type functions, they are +parametric, so there is no problem in expanding them whenever we see +them, since we do not need to know anything about their arguments in +order to expand them; this is what justifies not having to treat them +as specially as type function applications. The thing that causes +some subtleties is that we prefer to leave type synonym applications +*unexpanded* whenever possible, in order to generate better error +messages. + +If we encounter an equality constraint with type synonym applications +on both sides, or a type synonym application on one side and some sort +of type application on the other, we simply must expand out the type +synonyms in order to continue decomposing the equality constraint into +primitive equality constraints. For example, suppose we have + + type F a = [Int] + +and we encounter the equality + + F a ~ [b] + +In order to continue we must expand F a into [Int], giving us the +equality + + [Int] ~ [b] + +which we can then decompose into the more primitive equality +constraint + + Int ~ b. + +However, if we encounter an equality constraint with a type synonym +application on one side and a variable on the other side, we should +NOT (necessarily) expand the type synonym, since for the purpose of +good error messages we want to leave type synonyms unexpanded as much +as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar. + +-} + +{- +************************************************************************ +* * + Evidence transformation +* * +************************************************************************ +-} + +data StopOrContinue a + = ContinueWith a -- The constraint was not solved, although it may have + -- been rewritten + + | Stop CtEvidence -- The (rewritten) constraint was solved + SDoc -- Tells how it was solved + -- Any new sub-goals have been put on the work list + deriving (Functor) + +instance Outputable a => Outputable (StopOrContinue a) where + ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev + ppr (ContinueWith w) = text "ContinueWith" <+> ppr w + +continueWith :: a -> TcS (StopOrContinue a) +continueWith = return . ContinueWith + +stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) +stopWith ev s = return (Stop ev (text s)) + +andWhenContinue :: TcS (StopOrContinue a) + -> (a -> TcS (StopOrContinue b)) + -> TcS (StopOrContinue b) +andWhenContinue tcs1 tcs2 + = do { r <- tcs1 + ; case r of + Stop ev s -> return (Stop ev s) + ContinueWith ct -> tcs2 ct } +infixr 0 `andWhenContinue` -- allow chaining with ($) + +rewriteEvidence :: CtEvidence -- old evidence + -> TcPredType -- new predicate + -> TcCoercion -- Of type :: new predicate ~ + -> TcS (StopOrContinue CtEvidence) +-- Returns Just new_ev iff either (i) 'co' is reflexivity +-- or (ii) 'co' is not reflexivity, and 'new_pred' not cached +-- In either case, there is nothing new to do with new_ev +{- + rewriteEvidence old_ev new_pred co +Main purpose: create new evidence for new_pred; + unless new_pred is cached already +* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev +* If old_ev was wanted, create a binding for old_ev, in terms of new_ev +* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev +* Returns Nothing if new_ev is already cached + + Old evidence New predicate is Return new evidence + flavour of same flavor + ------------------------------------------------------------------- + Wanted Already solved or in inert Nothing + or Derived Not Just new_evidence + + Given Already in inert Nothing + Not Just new_evidence + +Note [Rewriting with Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the coercion is just reflexivity then you may re-use the same +variable. But be careful! Although the coercion is Refl, new_pred +may reflect the result of unification alpha := ty, so new_pred might +not _look_ the same as old_pred, and it's vital to proceed from now on +using new_pred. + +qThe flattener preserves type synonyms, so they should appear in new_pred +as well as in old_pred; that is important for good error messages. + -} + + +rewriteEvidence old_ev@(CtDerived {}) new_pred _co + = -- If derived, don't even look at the coercion. + -- This is very important, DO NOT re-order the equations for + -- rewriteEvidence to put the isTcReflCo test first! + -- Why? Because for *Derived* constraints, c, the coercion, which + -- was produced by flattening, may contain suspended calls to + -- (ctEvExpr c), which fails for Derived constraints. + -- (Getting this wrong caused #7384.) + continueWith (old_ev { ctev_pred = new_pred }) + +rewriteEvidence old_ev new_pred co + | isTcReflCo co -- See Note [Rewriting with Refl] + = continueWith (old_ev { ctev_pred = new_pred }) + +rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co + = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) + ; continueWith new_ev } + where + -- mkEvCast optimises ReflCo + new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational + (ctEvRole ev) + (mkTcSymCo co)) + +rewriteEvidence ev@(CtWanted { ctev_dest = dest + , ctev_nosh = si + , ctev_loc = loc }) new_pred co + = do { mb_new_ev <- newWanted_SI si loc new_pred + -- The "_SI" variant ensures that we make a new Wanted + -- with the same shadow-info as the existing one + -- with the same shadow-info as the existing one (#16735) + ; MASSERT( tcCoercionRole co == ctEvRole ev ) + ; setWantedEvTerm dest + (mkEvCast (getEvExpr mb_new_ev) + (tcDowngradeRole Representational (ctEvRole ev) co)) + ; case mb_new_ev of + Fresh new_ev -> continueWith new_ev + Cached _ -> stopWith ev "Cached wanted" } + + +rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) + -- or orhs ~ olhs (swapped) + -> SwapFlag + -> TcType -> TcType -- New predicate nlhs ~ nrhs + -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs + -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs + -> TcS CtEvidence -- Of type nlhs ~ nrhs +-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) +-- we generate +-- If not swapped +-- g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co +-- If 'swapped' +-- g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co +-- +-- For (Wanted w) we do the dual thing. +-- New w1 : nlhs ~ nrhs +-- If not swapped +-- w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co +-- If swapped +-- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co +-- +-- It's all a form of rewwriteEvidence, specialised for equalities +rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co + | CtDerived {} <- old_ev -- Don't force the evidence for a Derived + = return (old_ev { ctev_pred = new_pred }) + + | NotSwapped <- swapped + , isTcReflCo lhs_co -- See Note [Rewriting with Refl] + , isTcReflCo rhs_co + = return (old_ev { ctev_pred = new_pred }) + + | CtGiven { ctev_evar = old_evar } <- old_ev + = do { let new_tm = evCoercion (lhs_co + `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) + `mkTcTransCo` mkTcSymCo rhs_co) + ; newGivenEvVar loc' (new_pred, new_tm) } + + | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev + = case dest of + HoleDest hole -> + do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc' + (ctEvRole old_ev) nlhs nrhs + -- The "_SI" variant ensures that we make a new Wanted + -- with the same shadow-info as the existing one (#16735) + ; let co = maybeSym swapped $ + mkSymCo lhs_co + `mkTransCo` hole_co + `mkTransCo` rhs_co + ; setWantedEq dest co + ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) + ; return new_ev } + + _ -> panic "rewriteEqEvidence" + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise + = panic "rewriteEvidence" +#endif + where + new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs + + -- equality is like a type class. Bumping the depth is necessary because + -- of recursive newtypes, where "reducing" a newtype can actually make + -- it bigger. See Note [Newtypes can blow the stack]. + loc = ctEvLoc old_ev + loc' = bumpCtLocDepth loc + +{- Note [unifyWanted and unifyDerived] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When decomposing equalities we often create new wanted constraints for +(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. +Similar remarks apply for Derived. + +Rather than making an equality test (which traverses the structure of the +type, perhaps fruitlessly), unifyWanted traverses the common structure, and +bales out when it finds a difference by creating a new Wanted constraint. +But where it succeeds in finding common structure, it just builds a coercion +to reflect it. +-} + +unifyWanted :: CtLoc -> Role + -> TcType -> TcType -> TcS Coercion +-- Return coercion witnessing the equality of the two types, +-- emitting new work equalities where necessary to achieve that +-- Very good short-cut when the two types are equal, or nearly so +-- See Note [unifyWanted and unifyDerived] +-- The returned coercion's role matches the input parameter +unifyWanted loc Phantom ty1 ty2 + = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) + ; return (mkPhantomCo kind_co ty1 ty2) } + +unifyWanted loc role orig_ty1 orig_ty2 + = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 + go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' + + go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + = do { co_s <- unifyWanted loc role s1 s2 + ; co_t <- unifyWanted loc role t1 t2 + ; co_w <- unifyWanted loc Nominal w1 w2 + ; return (mkFunCo role co_w co_s co_t) } + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2, tys1 `equalLength` tys2 + , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality + = do { cos <- zipWith3M (unifyWanted loc) + (tyConRolesX role tc1) tys1 tys2 + ; return (mkTyConAppCo role tc1 cos) } + + go ty1@(TyVarTy tv) ty2 + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty1' -> go ty1' ty2 + Nothing -> bale_out ty1 ty2} + go ty1 ty2@(TyVarTy tv) + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty2' -> go ty1 ty2' + Nothing -> bale_out ty1 ty2 } + + go ty1@(CoercionTy {}) (CoercionTy {}) + = return (mkReflCo role ty1) -- we just don't care about coercions! + + go ty1 ty2 = bale_out ty1 ty2 + + bale_out ty1 ty2 + | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) + -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) + | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 + +unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () +-- See Note [unifyWanted and unifyDerived] +unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 + +unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () +-- See Note [unifyWanted and unifyDerived] +unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 + +unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () +-- Create new Derived and put it in the work list +-- Should do nothing if the two types are equal +-- See Note [unifyWanted and unifyDerived] +unify_derived _ Phantom _ _ = return () +unify_derived loc role orig_ty1 orig_ty2 + = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 + go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' + + go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + = do { unify_derived loc role s1 s2 + ; unify_derived loc role t1 t2 + ; unify_derived loc Nominal w1 w2 } + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2, tys1 `equalLength` tys2 + , isInjectiveTyCon tc1 role + = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 + go ty1@(TyVarTy tv) ty2 + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty1' -> go ty1' ty2 + Nothing -> bale_out ty1 ty2 } + go ty1 ty2@(TyVarTy tv) + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty2' -> go ty1 ty2' + Nothing -> bale_out ty1 ty2 } + go ty1 ty2 = bale_out ty1 ty2 + + bale_out ty1 ty2 + | ty1 `tcEqType` ty2 = return () + -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) + | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 + +maybeSym :: SwapFlag -> TcCoercion -> TcCoercion +maybeSym IsSwapped co = mkTcSymCo co +maybeSym NotSwapped co = co diff --git a/GHC/Tc/Solver/Flatten.hs b/GHC/Tc/Solver/Flatten.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Flatten.hs @@ -0,0 +1,1948 @@ +{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Tc.Solver.Flatten( + FlattenMode(..), + flatten, flattenKind, flattenArgsNom, + rewriteTyVar, flattenType, + + unflattenWanteds + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Tc.Types.Evidence +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- performs delicate algorithm on types +import GHC.Core.Coercion +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Outputable +import GHC.Tc.Solver.Monad as TcS +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Utils.Misc +import GHC.Data.Bag +import Control.Monad +import GHC.Utils.Monad ( zipWith3M ) +import Data.Foldable ( foldrM ) + +import Control.Arrow ( first ) + +{- +Note [The flattening story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A CFunEqCan is either of form + [G] : F xis ~ fsk -- fsk is a FlatSkolTv + [W] x : F xis ~ fmv -- fmv is a FlatMetaTv + where + x is the witness variable + xis are function-free + fsk/fmv is a flatten skolem; + it is always untouchable (level 0) + +* CFunEqCans can have any flavour: [G], [W], [WD] or [D] + +* KEY INSIGHTS: + + - A given flatten-skolem, fsk, is known a-priori to be equal to + F xis (the LHS), with evidence. The fsk is still a + unification variable, but it is "owned" by its CFunEqCan, and + is filled in (unflattened) only by unflattenGivens. + + - A unification flatten-skolem, fmv, stands for the as-yet-unknown + type to which (F xis) will eventually reduce. It is filled in + + + - All fsk/fmv variables are "untouchable". To make it simple to test, + we simply give them TcLevel=0. This means that in a CTyVarEq, say, + fmv ~ Int + we NEVER unify fmv. + + - A unification flatten-skolem, fmv, ONLY gets unified when either + a) The CFunEqCan takes a step, using an axiom + b) By unflattenWanteds + They are never unified in any other form of equality. + For example [W] ffmv ~ Int is stuck; it does not unify with fmv. + +* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. + That would destroy the invariant about the shape of a CFunEqCan, + and it would risk wanted/wanted interactions. The only way we + learn information about fsk is when the CFunEqCan takes a step. + + However we *do* substitute in the LHS of a CFunEqCan (else it + would never get to fire!) + +* Unflattening: + - We unflatten Givens when leaving their scope (see unflattenGivens) + - We unflatten Wanteds at the end of each attempt to simplify the + wanteds; see unflattenWanteds, called from solveSimpleWanteds. + +* Ownership of fsk/fmv. Each canonical [G], [W], or [WD] + CFunEqCan x : F xis ~ fsk/fmv + "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv. + Why? We make a fresh fsk/fmv when the constraint is born; + and we never rewrite the RHS of a CFunEqCan. + + In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W], + but does not "own" it. If we reduce a [D] F Int ~ fmv, where + say type instance F Int = ty, then we don't discharge fmv := ty. + Rather we simply generate [D] fmv ~ ty (in GHC.Tc.Solver.Interact.reduce_top_fun_eq, + and dischargeFmv) + +* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 + then xis1 /= xis2 + i.e. at most one CFunEqCan with a particular LHS + +* Flattening a type (F xis): + - If we are flattening in a Wanted/Derived constraint + then create new [W] x : F xis ~ fmv + else create new [G] x : F xis ~ fsk + with fresh evidence variable x and flatten-skolem fsk/fmv + + - Add it to the work list + + - Replace (F xis) with fsk/fmv in the type you are flattening + + - You can also add the CFunEqCan to the "flat cache", which + simply keeps track of all the function applications you + have flattened. + + - If (F xis) is in the cache already, just + use its fsk/fmv and evidence x, and emit nothing. + + - No need to substitute in the flat-cache. It's not the end + of the world if we start with, say (F alpha ~ fmv1) and + (F Int ~ fmv2) and then find alpha := Int. Athat will + simply give rise to fmv1 := fmv2 via [Interacting rule] below + +* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv + - Flatten xis (to substitute any tyvars; there are already no functions) + cos :: xis ~ flat_xis + - New wanted x2 :: F flat_xis ~ fsk/fmv + - Add new wanted to flat cache + - Discharge x = F cos ; x2 + +* [Interacting rule] + (inert) [W] x1 : F tys ~ fmv1 + (work item) [W] x2 : F tys ~ fmv2 + Just solve one from the other: + x2 := x1 + fmv2 := fmv1 + This just unites the two fsks into one. + Always solve given from wanted if poss. + +* For top-level reductions, see Note [Top-level reductions for type functions] + in GHC.Tc.Solver.Interact + + +Why given-fsks, alone, doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. + + [W] w : alpha ~ [F alpha Int] + +---> flatten + w = ...w'... + [W] w' : alpha ~ [fsk] + [G] : F alpha Int ~ fsk + +--> unify (no occurs check) + alpha := [fsk] + +But since fsk = F alpha Int, this is really an occurs check error. If +that is all we know about alpha, we will succeed in constraint +solving, producing a program with an infinite type. + +Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk) +using axiom, zonking would not see it, so (x::alpha) sitting in the +tree will get zonked to an infinite type. (Zonking always only does +refl stuff.) + +Why flatten-meta-vars, alone doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at Simple13, with unification-fmvs only + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fmv] + [W] x : F a ~ fmv + +--> subst a in x + g' = g;[x] + x = F g' ; x2 + [W] x2 : F [fmv] ~ fmv + +And now we have an evidence cycle between g' and x! + +If we used a given instead (ie current story) + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fsk] + [G] : F a ~ fsk + +---> Substitute for a + [G] g' : a ~ [fsk] + [G] F (sym g'); : F [fsk] ~ fsk + + +Why is it right to treat fmv's differently to ordinary unification vars? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + f :: forall a. a -> a -> Bool + g :: F Int -> F Int -> Bool + +Consider + f (x:Int) (y:Bool) +This gives alpha~Int, alpha~Bool. There is an inconsistency, +but really only one error. SherLoc may tell you which location +is most likely, based on other occurrences of alpha. + +Consider + g (x:Int) (y:Bool) +Here we get (F Int ~ Int, F Int ~ Bool), which flattens to + (fmv ~ Int, fmv ~ Bool) +But there are really TWO separate errors. + + ** We must not complain about Int~Bool. ** + +Moreover these two errors could arise in entirely unrelated parts of +the code. (In the alpha case, there must be *some* connection (eg +v:alpha in common envt).) + +Note [Unflattening can force the solver to iterate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at #10340: + type family Any :: * -- No instances + get :: MonadState s m => m s + instance MonadState s (State s) where ... + + foo :: State Any Any + foo = get + +For 'foo' we instantiate 'get' at types mm ss + [WD] MonadState ss mm, [WD] mm ss ~ State Any Any +Flatten, and decompose + [WD] MonadState ss mm, [WD] Any ~ fmv + [WD] mm ~ State fmv, [WD] fmv ~ ss +Unify mm := State fmv: + [WD] MonadState ss (State fmv) + [WD] Any ~ fmv, [WD] fmv ~ ss +Now we are stuck; the instance does not match!! So unflatten: + fmv := Any + ss := Any (*) + [WD] MonadState Any (State Any) + +The unification (*) represents progress, so we must do a second +round of solving; this time it succeeds. This is done by the 'go' +loop in solveSimpleWanteds. + +This story does not feel right but it's the best I can do; and the +iteration only happens in pretty obscure circumstances. + + +************************************************************************ +* * +* Examples + Here is a long series of examples I had to work through +* * +************************************************************************ + +Simple20 +~~~~~~~~ +axiom F [a] = [F a] + + [G] F [a] ~ a +--> + [G] fsk ~ a + [G] [F a] ~ fsk (nc) +--> + [G] F a ~ fsk2 + [G] fsk ~ [fsk2] + [G] fsk ~ a +--> + [G] F a ~ fsk2 + [G] a ~ [fsk2] + [G] fsk ~ a + +---------------------------------------- +indexed-types/should_compile/T44984 + + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha + +flatten +~~~~~~~ + fmv0 := F Bool + fmv1 := H (F Bool) + fmv2 := H alpha + alpha := F Bool +plus + fmv1 ~ fmv2 + +But these two are equal under the above assumptions. +Solve by Refl. + + +--- under plan B, namely solve fmv1:=fmv2 eagerly --- + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 fmv2 := fmv1 + + fmv0 ~ alpha + +flatten + fmv0 := F Bool + fmv1 := H fmv0 = H (F Bool) + retain H alpha ~ fmv2 + because fmv2 has been filled + alpha := F Bool + + +---------------------------- +indexed-types/should_failt/T4179 + +after solving + [W] fmv_1 ~ fmv_2 + [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) + [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) + +---------------------------------------- +indexed-types/should_fail/T7729a + +a) [W] BasePrimMonad (Rand m) ~ m1 +b) [W] tt m1 ~ BasePrimMonad (Rand m) + +---> process (b) first + BasePrimMonad (Ramd m) ~ fmv_atH + fmv_atH ~ tt m1 + +---> now process (a) + m1 ~ s_atH ~ tt m1 -- An obscure occurs check + + +---------------------------------------- +typecheck/TcTypeNatSimple + +Original constraint + [W] x + y ~ x + alpha (non-canonical) +==> + [W] x + y ~ fmv1 (CFunEqCan) + [W] x + alpha ~ fmv2 (CFuneqCan) + [W] fmv1 ~ fmv2 (CTyEqCan) + +(sigh) + +---------------------------------------- +indexed-types/should_fail/GADTwrong1 + + [G] Const a ~ () +==> flatten + [G] fsk ~ () + work item: Const a ~ fsk +==> fire top rule + [G] fsk ~ () + work item fsk ~ () + +Surely the work item should rewrite to () ~ ()? Well, maybe not; +it'a very special case. More generally, our givens look like +F a ~ Int, where (F a) is not reducible. + + +---------------------------------------- +indexed_types/should_fail/T8227: + +Why using a different can-rewrite rule in CFunEqCan heads +does not work. + +Assuming NOT rewriting wanteds with wanteds + + Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk + [W] fmv_aBk ~ fsk_aBh + + [G] Scalar fsk_aBg ~ fsk_aBh + [G] V a ~ f_aBg + + Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk + fmv_aBi, fmv_aBk are flatten unification variables + + Work item: [W] V fsk_aBh ~ fmv_aBi + +Note that the inert wanteds are cyclic, because we do not rewrite +wanteds with wanteds. + + +Then we go into a loop when normalise the work-item, because we +use rewriteOrSame on the argument of V. + +Conclusion: Don't make canRewrite context specific; instead use +[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. + + +---------------------------------------- + +Here is a somewhat similar case: + + type family G a :: * + + blah :: (G a ~ Bool, Eq (G a)) => a -> a + blah = error "urk" + + foo x = blah x + +For foo we get + [W] Eq (G a), G a ~ Bool +Flattening + [W] G a ~ fmv, Eq fmv, fmv ~ Bool +We can't simplify away the Eq Bool unless we substitute for fmv. +Maybe that doesn't matter: we would still be left with unsolved +G a ~ Bool. + +-------------------------- +#9318 has a very simple program leading to + + [W] F Int ~ Int + [W] F Int ~ Bool + +We don't want to get "Error Int~Bool". But if fmv's can rewrite +wanteds, we will + + [W] fmv ~ Int + [W] fmv ~ Bool +---> + [W] Int ~ Bool + + +************************************************************************ +* * +* FlattenEnv & FlatM +* The flattening environment & monad +* * +************************************************************************ + +-} + +type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list] + +data FlattenEnv + = FE { fe_mode :: !FlattenMode + , fe_loc :: CtLoc -- See Note [Flattener CtLoc] + -- unbanged because it's bogus in rewriteTyVar + , fe_flavour :: !CtFlavour + , fe_eq_rel :: !EqRel -- See Note [Flattener EqRels] + , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list] + +data FlattenMode -- Postcondition for all three: inert wrt the type substitution + = FM_FlattenAll -- Postcondition: function-free + | FM_SubstOnly -- See Note [Flattening under a forall] + +-- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] +-- -- Postcondition: +-- -- * tyvar is only mentioned in result under a rigid path +-- -- e.g. [a] is ok, but F a won't happen +-- -- * If flat_top is True, top level is not a function application +-- -- (but under type constructors is ok e.g. [F a]) + +instance Outputable FlattenMode where + ppr FM_FlattenAll = text "FM_FlattenAll" + ppr FM_SubstOnly = text "FM_SubstOnly" + +eqFlattenMode :: FlattenMode -> FlattenMode -> Bool +eqFlattenMode FM_FlattenAll FM_FlattenAll = True +eqFlattenMode FM_SubstOnly FM_SubstOnly = True +-- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 +eqFlattenMode _ _ = False + +-- | The 'FlatM' monad is a wrapper around 'TcS' with the following +-- extra capabilities: (1) it offers access to a 'FlattenEnv'; +-- and (2) it maintains the flattening worklist. +-- See Note [The flattening work list]. +newtype FlatM a + = FlatM { runFlatM :: FlattenEnv -> TcS a } + deriving (Functor) + +instance Monad FlatM where + m >>= k = FlatM $ \env -> + do { a <- runFlatM m env + ; runFlatM (k a) env } + +instance Applicative FlatM where + pure x = FlatM $ const (pure x) + (<*>) = ap + +liftTcS :: TcS a -> FlatM a +liftTcS thing_inside + = FlatM $ const thing_inside + +emitFlatWork :: Ct -> FlatM () +-- See Note [The flattening work list] +emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :) + +-- convenient wrapper when you have a CtEvidence describing +-- the flattening operation +runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a +runFlattenCtEv mode ev + = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) + +-- Run thing_inside (which does flattening), and put all +-- the work it generates onto the main work list +-- See Note [The flattening work list] +runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a +runFlatten mode loc flav eq_rel thing_inside + = do { flat_ref <- newTcRef [] + ; let fmode = FE { fe_mode = mode + , fe_loc = bumpCtLocDepth loc + -- See Note [Flatten when discharging CFunEqCan] + , fe_flavour = flav + , fe_eq_rel = eq_rel + , fe_work = flat_ref } + ; res <- runFlatM thing_inside fmode + ; new_flats <- readTcRef flat_ref + ; updWorkListTcS (add_flats new_flats) + ; return res } + where + add_flats new_flats wl + = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } + + add_funeqs [] wl = wl + add_funeqs (f:fs) wl = add_funeqs fs (f:wl) + -- add_funeqs fs ws = reverse fs ++ ws + -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] + -- = [f3,f2,f1,w1,w2,w3,w4] + +traceFlat :: String -> SDoc -> FlatM () +traceFlat herald doc = liftTcS $ traceTcS herald doc +{-# INLINE traceFlat #-} -- see Note [INLINE conditional tracing utilities] + +getFlatEnvField :: (FlattenEnv -> a) -> FlatM a +getFlatEnvField accessor + = FlatM $ \env -> return (accessor env) + +getEqRel :: FlatM EqRel +getEqRel = getFlatEnvField fe_eq_rel + +getRole :: FlatM Role +getRole = eqRelRole <$> getEqRel + +getFlavour :: FlatM CtFlavour +getFlavour = getFlatEnvField fe_flavour + +getFlavourRole :: FlatM CtFlavourRole +getFlavourRole + = do { flavour <- getFlavour + ; eq_rel <- getEqRel + ; return (flavour, eq_rel) } + +getMode :: FlatM FlattenMode +getMode = getFlatEnvField fe_mode + +getLoc :: FlatM CtLoc +getLoc = getFlatEnvField fe_loc + +checkStackDepth :: Type -> FlatM () +checkStackDepth ty + = do { loc <- getLoc + ; liftTcS $ checkReductionDepth loc ty } + +-- | Change the 'EqRel' in a 'FlatM'. +setEqRel :: EqRel -> FlatM a -> FlatM a +setEqRel new_eq_rel thing_inside + = FlatM $ \env -> + if new_eq_rel == fe_eq_rel env + then runFlatM thing_inside env + else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel }) + +-- | Change the 'FlattenMode' in a 'FlattenEnv'. +setMode :: FlattenMode -> FlatM a -> FlatM a +setMode new_mode thing_inside + = FlatM $ \env -> + if new_mode `eqFlattenMode` fe_mode env + then runFlatM thing_inside env + else runFlatM thing_inside (env { fe_mode = new_mode }) + +-- | Make sure that flattening actually produces a coercion (in other +-- words, make sure our flavour is not Derived) +-- Note [No derived kind equalities] +noBogusCoercions :: FlatM a -> FlatM a +noBogusCoercions thing_inside + = FlatM $ \env -> + -- No new thunk is made if the flavour hasn't changed (note the bang). + let !env' = case fe_flavour env of + Derived -> env { fe_flavour = Wanted WDeriv } + _ -> env + in + runFlatM thing_inside env' + +bumpDepth :: FlatM a -> FlatM a +bumpDepth (FlatM thing_inside) + = FlatM $ \env -> do + -- bumpDepth can be called a lot during flattening so we force the + -- new env to avoid accumulating thunks. + { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } + ; thing_inside env' } + +{- +Note [The flattening work list] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "flattening work list", held in the fe_work field of FlattenEnv, +is a list of CFunEqCans generated during flattening. The key idea +is this. Consider flattening (Eq (F (G Int) (H Bool)): + * The flattener recursively calls itself on sub-terms before building + the main term, so it will encounter the terms in order + G Int + H Bool + F (G Int) (H Bool) + flattening to sub-goals + w1: G Int ~ fuv0 + w2: H Bool ~ fuv1 + w3: F fuv0 fuv1 ~ fuv2 + + * Processing w3 first is BAD, because we can't reduce i t,so it'll + get put into the inert set, and later kicked out when w1, w2 are + solved. In #9872 this led to inert sets containing hundreds + of suspended calls. + + * So we want to process w1, w2 first. + + * So you might think that we should just use a FIFO deque for the work-list, + so that putting adding goals in order w1,w2,w3 would mean we processed + w1 first. + + * BUT suppose we have 'type instance G Int = H Char'. Then processing + w1 leads to a new goal + w4: H Char ~ fuv0 + We do NOT want to put that on the far end of a deque! Instead we want + to put it at the *front* of the work-list so that we continue to work + on it. + +So the work-list structure is this: + + * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on + top (extendWorkListFunEq), and take new work from the top + (selectWorkItem). + + * When flattening, emitFlatWork pushes new flattening goals (like + w1,w2,w3) onto the flattening work list, fe_work, another + push-down stack. + + * When we finish flattening, we *reverse* the fe_work stack + onto the wl_funeqs stack (which brings w1 to the top). + +The function runFlatten initialises the fe_work stack, and reverses +it onto wl_fun_eqs at the end. + +Note [Flattener EqRels] +~~~~~~~~~~~~~~~~~~~~~~~ +When flattening, we need to know which equality relation -- nominal +or representation -- we should be respecting. The only difference is +that we rewrite variables by representational equalities when fe_eq_rel +is ReprEq, and that we unwrap newtypes when flattening w.r.t. +representational equality. + +Note [Flattener CtLoc] +~~~~~~~~~~~~~~~~~~~~~~ +The flattener does eager type-family reduction. +Type families might loop, and we +don't want GHC to do so. A natural solution is to have a bounded depth +to these processes. A central difficulty is that such a solution isn't +quite compositional. For example, say it takes F Int 10 steps to get to Bool. +How many steps does it take to get from F Int -> F Int to Bool -> Bool? +10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to +know and hard to track. So, we punt, essentially. We store a CtLoc in +the FlattenEnv and just update the environment when recurring. In the +TyConApp case, where there may be multiple type families to flatten, +we just copy the current CtLoc into each branch. If any branch hits the +stack limit, then the whole thing fails. + +A consequence of this is that setting the stack limits appropriately +will be essentially impossible. So, the official recommendation if a +stack limit is hit is to disable the check entirely. Otherwise, there +will be baffling, unpredictable errors. + +Note [Lazy flattening] +~~~~~~~~~~~~~~~~~~~~~~ +The idea of FM_Avoid mode is to flatten less aggressively. If we have + a ~ [F Int] +there seems to be no great merit in lifting out (F Int). But if it was + a ~ [G a Int] +then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, +which gets rid of the occurs-check problem. (For the flat_top Bool, see +comments above and at call sites.) + +HOWEVER, the lazy flattening actually seems to make type inference go +*slower*, not faster. perf/compiler/T3064 is a case in point; it gets +*dramatically* worse with FM_Avoid. I think it may be because +floating the types out means we normalise them, and that often makes +them smaller and perhaps allows more re-use of previously solved +goals. But to be honest I'm not absolutely certain, so I am leaving +FM_Avoid in the code base. What I'm removing is the unique place +where it is *used*, namely in GHC.Tc.Solver.Canonical.canEqTyVar. + +See also Note [Conservative unification check] in GHC.Tc.Utils.Unify, which gives +other examples where lazy flattening caused problems. + +Bottom line: FM_Avoid is unused for now (Nov 14). +Note: T5321Fun got faster when I disabled FM_Avoid + T5837 did too, but it's pathological anyway + +Note [Phantoms in the flattener] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + +data Proxy p = Proxy + +and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` +is really irrelevant -- it will be ignored when solving for representational +equality later on. So, we omit flattening `ty` entirely. This may +violate the expectation of "xi"s for a bit, but the canonicaliser will +soon throw out the phantoms when decomposing a TyConApp. (Or, the +canonicaliser will emit an insoluble, in which case the unflattened version +yields a better error message anyway.) + +Note [No derived kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A kind-level coercion can appear in types, via mkCastTy. So, whenever +we are generating a coercion in a dependent context (in other words, +in a kind) we need to make sure that our flavour is never Derived +(as Derived constraints have no evidence). The noBogusCoercions function +changes the flavour from Derived just for this purpose. + +-} + +{- ********************************************************************* +* * +* Externally callable flattening functions * +* * +* They are all wrapped in runFlatten, so their * +* flattening work gets put into the work list * +* * +********************************************************************* + +Note [rewriteTyVar] +~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an injective function F and + inert_funeqs: F t1 ~ fsk1 + F t2 ~ fsk2 + inert_eqs: fsk1 ~ [a] + a ~ Int + fsk2 ~ [Int] + +We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the +[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans +when trying to find derived equalities arising from injectivity. +-} + +-- | See Note [Flattening]. +-- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty +-- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll', +-- then 'xi' is almost function-free (Note [Almost function-free] +-- in "GHC.Tc.Types"). +flatten :: FlattenMode -> CtEvidence -> TcType + -> TcS (Xi, TcCoercion) +flatten mode ev ty + = do { traceTcS "flatten {" (ppr mode <+> ppr ty) + ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty) + ; traceTcS "flatten }" (ppr ty') + ; return (ty', co) } + +-- Apply the inert set as an *inert generalised substitution* to +-- a variable, zonking along the way. +-- See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad. +-- Equivalently, this flattens the variable with respect to NomEq +-- in a Derived constraint. (Why Derived? Because Derived allows the +-- most about of rewriting.) Returns no coercion, because we're +-- using Derived constraints. +-- See Note [rewriteTyVar] +rewriteTyVar :: TcTyVar -> TcS TcType +rewriteTyVar tv + = do { traceTcS "rewriteTyVar {" (ppr tv) + ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $ + flattenTyVar tv + ; traceTcS "rewriteTyVar }" (ppr ty) + ; return ty } + where + fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv) + +-- specialized to flattening kinds: never Derived, always Nominal +-- See Note [No derived kind equalities] +-- See Note [Flattening] +flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN) +flattenKind loc flav ty + = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty) + ; let flav' = case flav of + Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not + _ -> flav + ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty) + ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic + ; return (ty', co) } + +-- See Note [Flattening] +flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN) +-- Externally-callable, hence runFlatten +-- Flatten a vector of types all at once; in fact they are +-- always the arguments of type family or class, so +-- ctEvFlavour ev = Nominal +-- and we want to flatten all at nominal role +-- The kind passed in is the kind of the type family or class, call it T +-- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys)) +-- +-- For Derived constraints the returned coercion may be undefined +-- because flattening may use a Derived equality ([D] a ~ ty) +flattenArgsNom ev tc tys + = do { traceTcS "flatten_args {" (vcat (map ppr tys)) + ; (tys', cos, kind_co) + <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys) + ; traceTcS "flatten }" (vcat (map ppr tys')) + ; return (tys', cos, kind_co) } + +-- | Flatten a type w.r.t. nominal equality. This is useful to rewrite +-- a type w.r.t. any givens. It does not do type-family reduction. This +-- will never emit new constraints. Call this when the inert set contains +-- only givens. +flattenType :: CtLoc -> TcType -> TcS TcType +flattenType loc ty + -- More info about FM_SubstOnly in Note [Holes] in GHC.Tc.Types.Constraint + = do { (xi, _) <- runFlatten FM_SubstOnly loc Given NomEq $ + flatten_one ty + -- use Given flavor so that it is rewritten + -- only w.r.t. Givens, never Wanteds/Deriveds + -- (Shouldn't matter, if only Givens are present + -- anyway) + ; return xi } + +{- ********************************************************************* +* * +* The main flattening functions +* * +********************************************************************* -} + +{- Note [Flattening] +~~~~~~~~~~~~~~~~~~~~ + flatten ty ==> (xi, co) + where + xi has no type functions, unless they appear under ForAlls + has no skolems that are mapped in the inert set + has no filled-in metavariables + co :: xi ~ ty + +Key invariants: + (F0) co :: xi ~ zonk(ty) + (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind + (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) + +Note that it is flatten's job to flatten *every type function it sees*. +flatten is only called on *arguments* to type functions, by canEqGiven. + +Flattening also: + * zonks, removing any metavariables, and + * applies the substitution embodied in the inert set + +The result of flattening is *almost function-free*. See +Note [Almost function-free] in GHC.Tc.Utils. + +Because flattening zonks and the returned coercion ("co" above) is also +zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, +we can rely on this fact: + + (F0) co :: xi ~ zonk(ty) + +Note that the left-hand type of co is *always* precisely xi. The right-hand +type may or may not be ty, however: if ty has unzonked filled-in metavariables, +then the right-hand type of co will be the zonked version of ty. +It is for this reason that we +occasionally have to explicitly zonk, when (co :: xi ~ ty) is important +even before we zonk the whole program. For example, see the FTRNotFollowed +case in flattenTyVar. + +Why have these invariants on flattening? Because we sometimes use tcTypeKind +during canonicalisation, and we want this kind to be zonked (e.g., see +GHC.Tc.Solver.Canonical.canEqTyVar). + +Flattening is always homogeneous. That is, the kind of the result of flattening is +always the same as the kind of the input, modulo zonking. More formally: + + (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) + +This invariant means that the kind of a flattened type might not itself be flat. + +Recall that in comments we use alpha[flat = ty] to represent a +flattening skolem variable alpha which has been generated to stand in +for ty. + +----- Example of flattening a constraint: ------ + flatten (List (F (G Int))) ==> (xi, cc) + where + xi = List alpha + cc = { G Int ~ beta[flat = G Int], + F beta ~ alpha[flat = F beta] } +Here + * alpha and beta are 'flattening skolem variables'. + * All the constraints in cc are 'given', and all their coercion terms + are the identity. + +NB: Flattening Skolems only occur in canonical constraints, which +are never zonked, so we don't need to worry about zonking doing +accidental unflattening. + +Note that we prefer to leave type synonyms unexpanded when possible, +so when the flattener encounters one, it first asks whether its +transitive expansion contains any type function applications. If so, +it expands the synonym and proceeds; if not, it simply returns the +unexpanded synonym. + +Note [flatten_args performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In programs with lots of type-level evaluation, flatten_args becomes +part of a tight loop. For example, see test perf/compiler/T9872a, which +calls flatten_args a whopping 7,106,808 times. It is thus important +that flatten_args be efficient. + +Performance testing showed that the current implementation is indeed +efficient. It's critically important that zipWithAndUnzipM be +specialized to TcS, and it's also quite helpful to actually `inline` +it. On test T9872a, here are the allocation stats (Dec 16, 2014): + + * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap + * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap + * Specialized, inlined: 6,281,539,792 bytes allocated in the heap + +To improve performance even further, flatten_args_nom is split off +from flatten_args, as nominal equality is the common case. This would +be natural to write using mapAndUnzipM, but even inlined, that function +is not as performant as a hand-written loop. + + * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap + * hand-written recursion: 5,848,602,848 bytes allocated in the heap + +If you make any change here, pay close attention to the T9872{a,b,c} tests +and T5321Fun. + +If we need to make this yet more performant, a possible way forward is to +duplicate the flattener code for the nominal case, and make that case +faster. This doesn't seem quite worth it, yet. + +Note [flatten_exact_fam_app_fully performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The refactor of GRefl seems to cause performance trouble for T9872x: +the allocation of flatten_exact_fam_app_fully_performance +increased. See note [Generalized reflexive coercion] in +GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the +current state. + +The explicit pattern match in homogenise_result helps with T9872a, b, c. + +Still, it increases the expected allocation of T9872d by ~2%. + +TODO: a step-by-step replay of the refactor to analyze the performance. + +-} + +{-# INLINE flatten_args_tc #-} +flatten_args_tc + :: TyCon -- T + -> [Role] -- Role r + -> [Type] -- Arg types [t1,..,tn] + -> FlatM ( [Xi] -- List of flattened args [x1,..,xn] + -- 1-1 corresp with [t1,..,tn] + , [Coercion] -- List of arg coercions [co1,..,con] + -- 1-1 corresp with [t1,..,tn] + -- coi :: xi ~r ti + , CoercionN) -- Result coercion, rco + -- rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con)) +flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet + -- NB: TyCon kinds are always closed + where + (bndrs, named) + = ty_con_binders_ty_binders' (tyConBinders tc) + -- it's possible that the result kind has arrows (for, e.g., a type family) + -- so we must split it + (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc) + !all_bndrs = bndrs `chkAppend` inner_bndrs + !any_named_bndrs = named || inner_named + -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. + +{-# INLINE flatten_args #-} +flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are + -- named. + -> Kind -> TcTyCoVarSet -- function kind; kind's free vars + -> [Role] -> [Type] -- these are in 1-to-1 correspondence + -> FlatM ([Xi], [Coercion], CoercionN) +-- Coercions :: Xi ~ Type, at roles given +-- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys) +-- That is, the third coercion relates the kind of some function (whose kind is +-- passed as the first parameter) instantiated at xis to the kind of that +-- function instantiated at the tys. This is useful in keeping flattening +-- homoegeneous. The list of roles must be at least as long as the list of +-- types. +flatten_args orig_binders + any_named_bndrs + orig_inner_ki + orig_fvs + orig_roles + orig_tys + = if any_named_bndrs + then flatten_args_slow orig_binders + orig_inner_ki + orig_fvs + orig_roles + orig_tys + else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys + +{-# INLINE flatten_args_fast #-} +-- | fast path flatten_args, in which none of the binders are named and +-- therefore we can avoid tracking a lifting context. +-- There are many bang patterns in here. It's been observed that they +-- greatly improve performance of an optimized build. +-- The T9872 test cases are good witnesses of this fact. +flatten_args_fast :: [TyCoBinder] + -> Kind + -> [Role] + -> [Type] + -> FlatM ([Xi], [Coercion], CoercionN) +flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys + = fmap finish (iterate orig_tys orig_roles orig_binders) + where + + iterate :: [Type] + -> [Role] + -> [TyCoBinder] + -> FlatM ([Xi], [Coercion], [TyCoBinder]) + iterate (ty:tys) (role:roles) (_:binders) = do + (xi, co) <- go role ty + (xis, cos, binders) <- iterate tys roles binders + pure (xi : xis, co : cos, binders) + iterate [] _ binders = pure ([], [], binders) + iterate _ _ _ = pprPanic + "flatten_args wandered into deeper water than usual" (vcat []) + -- This debug information is commented out because leaving it in + -- causes a ~2% increase in allocations in T9872{a,c,d}. + {- + (vcat [ppr orig_binders, + ppr orig_inner_ki, + ppr (take 10 orig_roles), -- often infinite! + ppr orig_tys]) + -} + + {-# INLINE go #-} + go :: Role + -> Type + -> FlatM (Xi, Coercion) + go role ty + = case role of + -- In the slow path we bind the Xi and Coercion from the recursive + -- call and then use it such + -- + -- let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder) + -- casted_xi = xi `mkCastTy` kind_co + -- casted_co = xi |> kind_co ~r xi ; co + -- + -- but this isn't necessary: + -- mkTcSymCo (Refl a b) = Refl a b, + -- mkCastTy x (Refl _ _) = x + -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co + -- + -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since + -- we've already established that they're all anonymous. + Nominal -> setEqRel NomEq $ flatten_one ty + Representational -> setEqRel ReprEq $ flatten_one ty + Phantom -> -- See Note [Phantoms in the flattener] + do { ty <- liftTcS $ zonkTcType ty + ; return (ty, mkReflCo Phantom ty) } + + + {-# INLINE finish #-} + finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN) + finish (xis, cos, binders) = (xis, cos, kind_co) + where + final_kind = mkPiTys binders orig_inner_ki + kind_co = mkNomReflCo final_kind + +{-# INLINE flatten_args_slow #-} +-- | Slow path, compared to flatten_args_fast, because this one must track +-- a lifting context. +flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet + -> [Role] -> [Type] + -> FlatM ([Xi], [Coercion], CoercionN) +flatten_args_slow binders inner_ki fvs roles tys +-- Arguments used dependently must be flattened with proper coercions, but +-- we're not guaranteed to get a proper coercion when flattening with the +-- "Derived" flavour. So we must call noBogusCoercions when flattening arguments +-- corresponding to binders that are dependent. However, we might legitimately +-- have *more* arguments than binders, in the case that the inner_ki is a variable +-- that gets instantiated with a Π-type. We conservatively choose not to produce +-- bogus coercions for these, too. Note that this might miss an opportunity for +-- a Derived rewriting a Derived. The solution would be to generate evidence for +-- Deriveds, thus avoiding this whole noBogusCoercions idea. See also +-- Note [No derived kind equalities] + = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True) + roles tys + ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) } + where + {-# INLINE fl #-} + fl :: Bool -- must we ensure to produce a real coercion here? + -- see comment at top of function + -> Role -> Type -> FlatM (Xi, Coercion) + fl True r ty = noBogusCoercions $ fl1 r ty + fl False r ty = fl1 r ty + + {-# INLINE fl1 #-} + fl1 :: Role -> Type -> FlatM (Xi, Coercion) + fl1 Nominal ty + = setEqRel NomEq $ + flatten_one ty + + fl1 Representational ty + = setEqRel ReprEq $ + flatten_one ty + + fl1 Phantom ty + -- See Note [Phantoms in the flattener] + = do { ty <- liftTcS $ zonkTcType ty + ; return (ty, mkReflCo Phantom ty) } + +------------------ +flatten_one :: TcType -> FlatM (Xi, Coercion) +-- Flatten a type to get rid of type function applications, returning +-- the new type-function-free type, and a collection of new equality +-- constraints. See Note [Flattening] for more detail. +-- +-- Postcondition: Coercion :: Xi ~ TcType +-- The role on the result coercion matches the EqRel in the FlattenEnv + +flatten_one xi@(LitTy {}) + = do { role <- getRole + ; return (xi, mkReflCo role xi) } + +flatten_one (TyVarTy tv) + = flattenTyVar tv + +flatten_one (AppTy ty1 ty2) + = flatten_app_tys ty1 [ty2] + +flatten_one (TyConApp tc tys) + -- Expand type synonyms that mention type families + -- on the RHS; see Note [Flattening synonyms] + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { mode <- getMode + ; case mode of + FM_FlattenAll | not (isFamFreeTyCon tc) + -> flatten_one expanded_ty + _ -> flatten_ty_con_app tc tys } + + -- Otherwise, it's a type function application, and we have to + -- flatten it away as well, and generate a new given equality constraint + -- between the application and a newly generated flattening skolem variable. + | isTypeFamilyTyCon tc + = flatten_fam_app tc tys + + -- For * a normal data type application + -- * data family application + -- we just recursively flatten the arguments. + | otherwise +-- FM_Avoid stuff commented out; see Note [Lazy flattening] +-- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid +-- FE { fe_mode = FM_Avoid tv _ } +-- -> fmode { fe_mode = FM_Avoid tv False } +-- _ -> fmode + = flatten_ty_con_app tc tys + +flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) + = do { (xi1,co1) <- flatten_one ty1 + ; (xi2,co2) <- flatten_one ty2 + ; (xi3,co3) <- setEqRel NomEq $ flatten_one mult + ; role <- getRole + ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 } + , mkFunCo role co3 co1 co2) } + +flatten_one ty@(ForAllTy {}) +-- TODO (RAE): This is inadequate, as it doesn't flatten the kind of +-- the bound tyvar. Doing so will require carrying around a substitution +-- and the usual substTyVarBndr-like silliness. Argh. + +-- We allow for-alls when, but only when, no type function +-- applications inside the forall involve the bound type variables. + = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty + tvs = binderVars bndrs + ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho + -- Substitute only under a forall + -- See Note [Flattening under a forall] + ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } + +flatten_one (CastTy ty g) + = do { (xi, co) <- flatten_one ty + ; (g', _) <- flatten_co g + ; role <- getRole + ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') } + -- It makes a /big/ difference to call castCoercionKind1 not + -- the more general castCoercionKind2. + -- See Note [castCoercionKind1] in GHC.Core.Coercion + +flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co + +-- | "Flatten" a coercion. Really, just zonk it so we can uphold +-- (F1) of Note [Flattening] +flatten_co :: Coercion -> FlatM (Coercion, Coercion) +flatten_co co + = do { co <- liftTcS $ zonkCo co + ; env_role <- getRole + ; let co' = mkTcReflCo env_role (mkCoercionTy co) + ; return (co, co') } + +-- flatten (nested) AppTys +flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion) +-- commoning up nested applications allows us to look up the function's kind +-- only once. Without commoning up like this, we would spend a quadratic amount +-- of time looking up functions' types +flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys) +flatten_app_tys fun_ty arg_tys + = do { (fun_xi, fun_co) <- flatten_one fun_ty + ; flatten_app_ty_args fun_xi fun_co arg_tys } + +-- Given a flattened function (with the coercion produced by flattening) and +-- a bunch of unflattened arguments, flatten the arguments and apply. +-- The coercion argument's role matches the role stored in the FlatM monad. +-- +-- The bang patterns used here were observed to improve performance. If you +-- wish to remove them, be sure to check for regeressions in allocations. +flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion) +flatten_app_ty_args fun_xi fun_co [] + -- this will be a common case when called from flatten_fam_app, so shortcut + = return (fun_xi, fun_co) +flatten_app_ty_args fun_xi fun_co arg_tys + = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of + Just (tc, xis) -> + do { let tc_roles = tyConRolesRepresentational tc + arg_roles = dropList xis tc_roles + ; (arg_xis, arg_cos, kind_co) + <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys + + -- Here, we have fun_co :: T xi1 xi2 ~ ty + -- and we need to apply fun_co to the arg_cos. The problem is + -- that using mkAppCo is wrong because that function expects + -- its second coercion to be Nominal, and the arg_cos might + -- not be. The solution is to use transitivity: + -- T arg_cos ;; fun_co + ; eq_rel <- getEqRel + ; let app_xi = mkTyConApp tc (xis ++ arg_xis) + app_co = case eq_rel of + NomEq -> mkAppCos fun_co arg_cos + ReprEq -> mkTcTyConAppCo Representational tc + (zipWith mkReflCo tc_roles xis ++ arg_cos) + `mkTcTransCo` + mkAppCos fun_co (map mkNomReflCo arg_tys) + ; return (app_xi, app_co, kind_co) } + Nothing -> + do { (arg_xis, arg_cos, kind_co) + <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys + ; let arg_xi = mkAppTys fun_xi arg_xis + arg_co = mkAppCos fun_co arg_cos + ; return (arg_xi, arg_co, kind_co) } + + ; role <- getRole + ; return (homogenise_result xi co role kind_co) } + +flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) +flatten_ty_con_app tc tys + = do { role <- getRole + ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys + ; let tyconapp_xi = mkTyConApp tc xis + tyconapp_co = mkTyConAppCo role tc cos + ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) } + +-- Make the result of flattening homogeneous (Note [Flattening] (F2)) +homogenise_result :: Xi -- a flattened type + -> Coercion -- :: xi ~r original ty + -> Role -- r + -> CoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty) + -> (Xi, Coercion) -- (xi |> kind_co, (xi |> kind_co) + -- ~r original ty) +homogenise_result xi co r kind_co + -- the explicit pattern match here improves the performance of T9872a, b, c by + -- ~2% + | isGReflCo kind_co = (xi `mkCastTy` kind_co, co) + | otherwise = (xi `mkCastTy` kind_co + , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co) +{-# INLINE homogenise_result #-} + +-- Flatten a vector (list of arguments). +flatten_vector :: Kind -- of the function being applied to these arguments + -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the + -- args have? + -> [Type] -- the args to flatten + -> FlatM ([Xi], [Coercion], CoercionN) +flatten_vector ki roles tys + = do { eq_rel <- getEqRel + ; case eq_rel of + NomEq -> flatten_args bndrs + any_named_bndrs + inner_ki + fvs + (repeat Nominal) + tys + ReprEq -> flatten_args bndrs + any_named_bndrs + inner_ki + fvs + roles + tys + } + where + (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki + fvs = tyCoVarsOfType ki +{-# INLINE flatten_vector #-} + +{- +Note [Flattening synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Not expanding synonyms aggressively improves error messages, and +keeps types smaller. But we need to take care. + +Suppose + type T a = a -> a +and we want to flatten the type (T (F a)). Then we can safely flatten +the (F a) to a skolem, and return (T fsk). We don't need to expand the +synonym. This works because TcTyConAppCo can deal with synonyms +(unlike TyConAppCo), see Note [TcCoercions] in GHC.Tc.Types.Evidence. + +But (#8979) for + type T a = (F a, a) where F is a type function +we must expand the synonym in (say) T Int, to expose the type function +to the flattener. + + +Note [Flattening under a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under a forall, we + (a) MUST apply the inert substitution + (b) MUST NOT flatten type family applications +Hence FMSubstOnly. + +For (a) consider c ~ a, a ~ T (forall b. (b, [c])) +If we don't apply the c~a substitution to the second constraint +we won't see the occurs-check error. + +For (b) consider (a ~ forall b. F a b), we don't want to flatten +to (a ~ forall b.fsk, F a b ~ fsk) +because now the 'b' has escaped its scope. We'd have to flatten to + (a ~ forall b. fsk b, forall b. F a b ~ fsk b) +and we have not begun to think about how to make that work! + +************************************************************************ +* * + Flattening a type-family application +* * +************************************************************************ +-} + +flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) + -- flatten_fam_app can be over-saturated + -- flatten_exact_fam_app is exactly saturated + -- flatten_exact_fam_app_fully lifts out the application to top level + -- Postcondition: Coercion :: Xi ~ F tys +flatten_fam_app tc tys -- Can be over-saturated + = ASSERT2( tys `lengthAtLeast` tyConArity tc + , ppr tc $$ ppr (tyConArity tc) $$ ppr tys) + + do { mode <- getMode + ; case mode of + { FM_SubstOnly -> flatten_ty_con_app tc tys + ; FM_FlattenAll -> + + -- Type functions are saturated + -- The type function might be *over* saturated + -- in which case the remaining arguments should + -- be dealt with by AppTys + do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys + ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1 + -- co1 :: xi1 ~ F tys1 + + ; flatten_app_ty_args xi1 co1 tys_rest } } } + +-- the [TcType] exactly saturate the TyCon +-- See note [flatten_exact_fam_app_fully performance] +flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion) +flatten_exact_fam_app_fully tc tys + -- See Note [Reduce type family applications eagerly] + -- the following tcTypeKind should never be evaluated, as it's just used in + -- casting, and casts by refl are dropped + = do { mOut <- try_to_reduce_nocache tc tys + ; case mOut of + Just out -> pure out + Nothing -> do + { -- First, flatten the arguments + ; (xis, cos, kind_co) + <- setEqRel NomEq $ -- just do this once, instead of for + -- each arg + flatten_args_tc tc (repeat Nominal) tys + -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys) + ; eq_rel <- getEqRel + ; cur_flav <- getFlavour + ; let role = eqRelRole eq_rel + ret_co = mkTyConAppCo role tc cos + -- ret_co :: F xis ~ F tys; might be heterogeneous + + -- Now, look in the cache + ; mb_ct <- liftTcS $ lookupFlatCache tc xis + ; case mb_ct of + Just (co, rhs_ty, flav) -- co :: F xis ~ fsk + -- flav is [G] or [WD] + -- See Note [Type family equations] in GHC.Tc.Solver.Monad + | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav + -> -- Usable hit in the flat-cache + do { traceFlat "flatten/flat-cache hit" $ + (ppr tc <+> ppr xis $$ ppr rhs_ty) + ; (fsk_xi, fsk_co) <- flatten_one rhs_ty + -- The fsk may already have been unified, so + -- flatten it + -- fsk_co :: fsk_xi ~ fsk + ; let xi = fsk_xi `mkCastTy` kind_co + co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co + `mkTransCo` + maybeTcSubCo eq_rel (mkSymCo co) + `mkTransCo` ret_co + ; return (xi, co') + } + -- :: fsk_xi ~ F xis + + -- Try to reduce the family application right now + -- See Note [Reduce type family applications eagerly] + _ -> do { mOut <- try_to_reduce tc + xis + kind_co + (`mkTransCo` ret_co) + ; case mOut of + Just out -> pure out + Nothing -> do + { loc <- getLoc + ; (ev, co, fsk) <- liftTcS $ + newFlattenSkolem cur_flav loc tc xis + + -- The new constraint (F xis ~ fsk) is not + -- necessarily inert (e.g. the LHS may be a + -- redex) so we must put it in the work list + ; let ct = CFunEqCan { cc_ev = ev + , cc_fun = tc + , cc_tyargs = xis + , cc_fsk = fsk } + ; emitFlatWork ct + + ; traceFlat "flatten/flat-cache miss" $ + (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev) + + -- NB: fsk's kind is already flattened because + -- the xis are flattened + ; let fsk_ty = mkTyVarTy fsk + xi = fsk_ty `mkCastTy` kind_co + co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co)) + `mkTransCo` ret_co + ; return (xi, co') + } + } + } + } + + where + + -- try_to_reduce and try_to_reduce_nocache (below) could be unified into + -- a more general definition, but it was observed that separating them + -- gives better performance (lower allocation numbers in T9872x). + + try_to_reduce :: TyCon -- F, family tycon + -> [Type] -- args, not necessarily flattened + -> CoercionN -- kind_co :: tcTypeKind(F args) ~N + -- tcTypeKind(F orig_args) + -- where + -- orig_args is what was passed to the outer + -- function + -> ( Coercion -- :: (xi |> kind_co) ~ F args + -> Coercion ) -- what to return from outer function + -> FlatM (Maybe (Xi, Coercion)) + try_to_reduce tc tys kind_co update_co + = do { checkStackDepth (mkTyConApp tc tys) + ; mb_match <- liftTcS $ matchFam tc tys + ; case mb_match of + -- NB: norm_co will always be homogeneous. All type families + -- are homogeneous. + Just (norm_co, norm_ty) + -> do { traceFlat "Eager T.F. reduction success" $ + vcat [ ppr tc, ppr tys, ppr norm_ty + , ppr norm_co <+> dcolon + <+> ppr (coercionKind norm_co) + ] + ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty + ; eq_rel <- getEqRel + ; let co = maybeTcSubCo eq_rel norm_co + `mkTransCo` mkSymCo final_co + ; flavour <- getFlavour + -- NB: only extend cache with nominal equalities + ; when (eq_rel == NomEq) $ + liftTcS $ + extendFlatCache tc tys ( co, xi, flavour ) + ; let role = eqRelRole eq_rel + xi' = xi `mkCastTy` kind_co + co' = update_co $ + mkTcCoherenceLeftCo role xi kind_co (mkSymCo co) + ; return $ Just (xi', co') } + Nothing -> pure Nothing } + + try_to_reduce_nocache :: TyCon -- F, family tycon + -> [Type] -- args, not necessarily flattened + -> FlatM (Maybe (Xi, Coercion)) + try_to_reduce_nocache tc tys + = do { checkStackDepth (mkTyConApp tc tys) + ; mb_match <- liftTcS $ matchFam tc tys + ; case mb_match of + -- NB: norm_co will always be homogeneous. All type families + -- are homogeneous. + Just (norm_co, norm_ty) + -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty + ; eq_rel <- getEqRel + ; let co = mkSymCo (maybeTcSubCo eq_rel norm_co + `mkTransCo` mkSymCo final_co) + ; return $ Just (xi, co) } + Nothing -> pure Nothing } + +{- Note [Reduce type family applications eagerly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we come across a type-family application like (Append (Cons x Nil) t), +then, rather than flattening to a skolem etc, we may as well just reduce +it on the spot to (Cons x t). This saves a lot of intermediate steps. +Examples that are helped are tests T9872, and T5321Fun. + +Performance testing indicates that it's best to try this *twice*, once +before flattening arguments and once after flattening arguments. +Adding the extra reduction attempt before flattening arguments cut +the allocation amounts for the T9872{a,b,c} tests by half. + +An example of where the early reduction appears helpful: + + type family Last x where + Last '[x] = x + Last (h ': t) = Last t + + workitem: (x ~ Last '[1,2,3,4,5,6]) + +Flattening the argument never gets us anywhere, but trying to flatten +it at every step is quadratic in the length of the list. Reducing more +eagerly makes simplifying the right-hand type linear in its length. + +Testing also indicated that the early reduction should *not* use the +flat-cache, but that the later reduction *should*. (Although the +effect was not large.) Hence the Bool argument to try_to_reduce. To +me (SLPJ) this seems odd; I get that eager reduction usually succeeds; +and if don't use the cache for eager reduction, we will miss most of +the opportunities for using it at all. More exploration would be good +here. + +At the end, once we've got a flat rhs, we extend the flatten-cache to record +the result. Doing so can save lots of work when the same redex shows up more +than once. Note that we record the link from the redex all the way to its +*final* value, not just the single step reduction. Interestingly, using the +flat-cache for the first reduction resulted in an increase in allocations +of about 3% for the four T9872x tests. However, using the flat-cache in +the later reduction is a similar gain. I (Richard E) don't currently (Dec '14) +have any knowledge as to *why* these facts are true. + +************************************************************************ +* * + Flattening a type variable +* * +********************************************************************* -} + +-- | The result of flattening a tyvar "one step". +data FlattenTvResult + = FTRNotFollowed + -- ^ The inert set doesn't make the tyvar equal to anything else + + | FTRFollowed TcType Coercion + -- ^ The tyvar flattens to a not-necessarily flat other type. + -- co :: new type ~r old type, where the role is determined by + -- the FlattenEnv + +flattenTyVar :: TyVar -> FlatM (Xi, Coercion) +flattenTyVar tv + = do { mb_yes <- flatten_tyvar1 tv + ; case mb_yes of + FTRFollowed ty1 co1 -- Recur + -> do { (ty2, co2) <- flatten_one ty1 + -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2) + ; return (ty2, co2 `mkTransCo` co1) } + + FTRNotFollowed -- Done, but make sure the kind is zonked + -- Note [Flattening] invariant (F0) and (F1) + -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv + ; role <- getRole + ; let ty' = mkTyVarTy tv' + ; return (ty', mkTcReflCo role ty') } } + +flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult +-- "Flattening" a type variable means to apply the substitution to it +-- Specifically, look up the tyvar in +-- * the internal MetaTyVar box +-- * the inerts +-- See also the documentation for FlattenTvResult + +flatten_tyvar1 tv + = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty -> do { traceFlat "Following filled tyvar" + (ppr tv <+> equals <+> ppr ty) + ; role <- getRole + ; return (FTRFollowed ty (mkReflCo role ty)) } ; + Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv) + ; fr <- getFlavourRole + ; flatten_tyvar2 tv fr } } + +flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult +-- The tyvar is not a filled-in meta-tyvar +-- Try in the inert equalities +-- See Definition [Applying a generalised substitution] in GHC.Tc.Solver.Monad +-- See Note [Stability of flattening] in GHC.Tc.Solver.Monad + +flatten_tyvar2 tv fr@(_, eq_rel) + = do { ieqs <- liftTcS $ getInertEqs + ; mode <- getMode + ; case lookupDVarEnv ieqs tv of + Just (ct:_) -- If the first doesn't work, + -- the subsequent ones won't either + | CTyEqCan { cc_ev = ctev, cc_tyvar = tv + , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct + , let ct_fr = (ctEvFlavour ctev, ct_eq_rel) + , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR + -> do { traceFlat "Following inert tyvar" + (ppr mode <+> + ppr tv <+> + equals <+> + ppr rhs_ty $$ ppr ctev) + ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev) + rewrite_co = case (ct_eq_rel, eq_rel) of + (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) + -- if this ASSERT fails, then + -- eqCanRewriteFR answered incorrectly + rewrite_co1 + (NomEq, NomEq) -> rewrite_co1 + (NomEq, ReprEq) -> mkSubCo rewrite_co1 + + ; return (FTRFollowed rhs_ty rewrite_co) } + -- NB: ct is Derived then fmode must be also, hence + -- we are not going to touch the returned coercion + -- so ctEvCoercion is fine. + + _other -> return FTRNotFollowed } + +{- +Note [An alternative story for the inert substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This entire note is just background, left here in case we ever want + to return the previous state of affairs) + +We used (GHC 7.8) to have this story for the inert substitution inert_eqs + + * 'a' is not in fvs(ty) + * They are *inert* in the weaker sense that there is no infinite chain of + (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc + +This means that flattening must be recursive, but it does allow + [G] a ~ [b] + [G] b ~ Maybe c + +This avoids "saturating" the Givens, which can save a modest amount of work. +It is easy to implement, in GHC.Tc.Solver.Interact.kick_out, by only kicking out an inert +only if (a) the work item can rewrite the inert AND + (b) the inert cannot rewrite the work item + +This is significantly harder to think about. It can save a LOT of work +in occurs-check cases, but we don't care about them much. #5837 +is an example; all the constraints here are Givens + + [G] a ~ TF (a,Int) + --> + work TF (a,Int) ~ fsk + inert fsk ~ a + + ---> + work fsk ~ (TF a, TF Int) + inert fsk ~ a + + ---> + work a ~ (TF a, TF Int) + inert fsk ~ a + + ---> (attempting to flatten (TF a) so that it does not mention a + work TF a ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (substitute for a) + work TF (fsk2, TF Int) ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (top-level reduction, re-orient) + work fsk2 ~ (TF fsk2, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (attempt to flatten (TF fsk2) to get rid of fsk2 + work TF fsk2 ~ fsk3 + work fsk2 ~ (fsk3, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> + work TF fsk2 ~ fsk3 + inert fsk2 ~ (fsk3, TF Int) + inert a ~ ((fsk3, TF Int), TF Int) + inert fsk ~ ((fsk3, TF Int), TF Int) + +Because the incoming given rewrites all the inert givens, we get more and +more duplication in the inert set. But this really only happens in pathological +casee, so we don't care. + + +************************************************************************ +* * + Unflattening +* * +************************************************************************ + +An unflattening example: + [W] F a ~ alpha +flattens to + [W] F a ~ fmv (CFunEqCan) + [W] fmv ~ alpha (CTyEqCan) +We must solve both! +-} + +unflattenWanteds :: Cts -> Cts -> TcS Cts +unflattenWanteds tv_eqs funeqs + = do { tclvl <- getTcLevel + + ; traceTcS "Unflattening" $ braces $ + vcat [ text "Funeqs =" <+> pprCts funeqs + , text "Tv eqs =" <+> pprCts tv_eqs ] + + -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check + -- Occurs check: consider [W] alpha ~ [F alpha] + -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] + -- ==> (unify) [W] F [fmv] ~ fmv + -- See Note [Unflatten using funeqs first] + ; funeqs <- foldrM unflatten_funeq emptyCts funeqs + ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) + + -- Step 2: unify the tv_eqs, if possible + ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs + ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) + + -- Step 3: fill any remaining fmvs with fresh unification variables + ; funeqs <- mapBagM finalise_funeq funeqs + ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) + + -- Step 4: remove any tv_eqs that look like ty ~ ty + ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs + + ; let all_flat = tv_eqs `andCts` funeqs + ; traceTcS "Unflattening done" $ braces (pprCts all_flat) + + ; return all_flat } + where + ---------------- + unflatten_funeq :: Ct -> Cts -> TcS Cts + unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis + , cc_fsk = fmv, cc_ev = ev }) rest + = do { -- fmv should be an un-filled flatten meta-tv; + -- we now fix its final value by filling it, being careful + -- to observe the occurs check. Zonking will eliminate it + -- altogether in due course + rhs' <- zonkTcType (mkTyConApp tc xis) + ; case occCheckExpand [fmv] rhs' of + Just rhs'' -- Normal case: fill the tyvar + -> do { setReflEvidence ev NomEq rhs'' + ; unflattenFmv fmv rhs'' + ; return rest } + + Nothing -> -- Occurs check + return (ct `consCts` rest) } + + unflatten_funeq other_ct _ + = pprPanic "unflatten_funeq" (ppr other_ct) + + ---------------- + finalise_funeq :: Ct -> TcS Ct + finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) + = do { demoteUnfilledFmv fmv + ; return (mkNonCanonical ev) } + finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) + + ---------------- + unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts + unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv + , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest + + | NomEq <- eq_rel -- See Note [Do not unify representational equalities] + -- in GHC.Tc.Solver.Interact + , isFmvTyVar tv -- Previously these fmvs were untouchable, + -- but now they are touchable + -- NB: unlike unflattenFmv, filling a fmv here /does/ + -- bump the unification count; it is "improvement" + -- Note [Unflattening can force the solver to iterate] + = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct ) + -- CTyEqCan invariant (TyEq:K) should ensure this is true + do { is_filled <- isFilledMetaTyVar tv + ; elim <- case is_filled of + False -> do { traceTcS "unflatten_eq 2" (ppr ct) + ; tryFill ev tv rhs } + True -> do { traceTcS "unflatten_eq 3" (ppr ct) + ; try_fill_rhs ev tclvl tv rhs } + ; if elim + then do { setReflEvidence ev eq_rel (mkTyVarTy tv) + ; return rest } + else return (ct `consCts` rest) } + + | otherwise + = return (ct `consCts` rest) + + unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct) + + ---------------- + try_fill_rhs ev tclvl lhs_tv rhs + -- Constraint is lhs_tv ~ rhs_tv, + -- and lhs_tv is filled, so try RHS + | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs + -- co :: kind(rhs_tv) ~ kind(lhs_tv) + , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv + && not (isTyVarTyVar rhs_tv)) + -- LHS is a filled fmv, and so is a type + -- family application, which a TyVarTv should + -- not unify with + = do { is_filled <- isFilledMetaTyVar rhs_tv + ; if is_filled then return False + else tryFill ev rhs_tv + (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) } + + | otherwise + = return False + + ---------------- + finalise_eq :: Ct -> Cts -> TcS Cts + finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv + , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest + | isFmvTyVar tv + = do { ty1 <- zonkTcTyVar tv + ; rhs' <- zonkTcType rhs + ; if ty1 `tcEqType` rhs' + then do { setReflEvidence ev eq_rel rhs' + ; return rest } + else return (mkNonCanonical ev `consCts` rest) } + + | otherwise + = return (mkNonCanonical ev `consCts` rest) + + finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) + +tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool +-- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv +-- If tv does not appear in 'rhs', it set tv := rhs, +-- binds the evidence (which should be a CtWanted) to Refl +-- and return True. Otherwise returns False +tryFill ev tv rhs + = ASSERT2( not (isGiven ev), ppr ev ) + do { rhs' <- zonkTcType rhs + ; case () of + _ | Just tv' <- tcGetTyVar_maybe rhs' + , tv == tv' -- tv == rhs + -> return True + + _ | Just rhs'' <- occCheckExpand [tv] rhs' + -> do { -- Fill the tyvar + unifyTyVar tv rhs'' + ; return True } + + _ | otherwise -- Occurs check + -> return False + } + +setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS () +setReflEvidence ev eq_rel rhs + = setEvBindIfWanted ev (evCoercion refl_co) + where + refl_co = mkTcReflCo (eqRelRole eq_rel) rhs + +{- +Note [Unflatten using funeqs first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + [W] G a ~ Int + [W] F (G a) ~ G a + +do not want to end up with + [W] F Int ~ Int +because that might actually hold! Better to end up with the two above +unsolved constraints. The flat form will be + + G a ~ fmv1 (CFunEqCan) + F fmv1 ~ fmv2 (CFunEqCan) + fmv1 ~ Int (CTyEqCan) + fmv1 ~ fmv2 (CTyEqCan) + +Flatten using the fun-eqs first. +-} + +-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at +-- least one named binder. +split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) +split_pi_tys' ty = split ty ty + where + -- put common cases first + split _ (ForAllTy b res) = let (bs, ty, _) = split res res + in (Named b : bs, ty, True) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + = let (bs, ty, named) = split res res + in (Anon af (mkScaled w arg) : bs, ty, named) + + split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' + split orig_ty _ = ([], orig_ty, False) +{-# INLINE split_pi_tys' #-} + +-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff +-- there is at least one named binder. +ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) +ty_con_binders_ty_binders' = foldr go ([], False) + where + go (Bndr tv (NamedTCB vis)) (bndrs, _) + = (Named (Bndr tv vis) : bndrs, True) + go (Bndr tv (AnonTCB af)) (bndrs, n) + = (Anon af (unrestricted (tyVarKind tv)) : bndrs, n) + {-# INLINE go #-} +{-# INLINE ty_con_binders_ty_binders' #-} diff --git a/GHC/Tc/Solver/Interact.hs b/GHC/Tc/Solver/Interact.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Interact.hs @@ -0,0 +1,2740 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Solver.Interact ( + solveSimpleGivens, -- Solves [Ct] + solveSimpleWanteds, -- Solves Cts + ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Types.Basic ( SwapFlag(..), isSwapped, + infinity, IntWithInf, intGtLimit ) +import GHC.Tc.Solver.Canonical +import GHC.Tc.Solver.Flatten +import GHC.Tc.Utils.Unify( canSolveByUnification ) +import GHC.Types.Var.Set +import GHC.Core.Type as Type +import GHC.Core.Coercion ( BlockSubstFlag(..) ) +import GHC.Core.InstEnv ( DFunInstType ) +import GHC.Core.Coercion.Axiom ( sfInteractTop, sfInteractInert ) + +import GHC.Types.Var +import GHC.Tc.Utils.TcType +import GHC.Builtin.Names ( coercibleTyConKey, + heqTyConKey, eqTyConKey, ipClassKey ) +import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Family +import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap ) +import GHC.Core.FamInstEnv +import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) + +import GHC.Tc.Types.Evidence +import GHC.Utils.Outputable + +import GHC.Tc.Types +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Solver.Monad +import GHC.Data.Bag +import GHC.Utils.Monad ( concatMapM, foldlM ) + +import GHC.Core +import Data.List( partition, deleteFirstsBy ) +import GHC.Types.SrcLoc +import GHC.Types.Var.Env + +import Control.Monad +import GHC.Data.Maybe( isJust ) +import GHC.Data.Pair (Pair(..)) +import GHC.Types.Unique( hasKey ) +import GHC.Driver.Session +import GHC.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe + +{- +********************************************************************** +* * +* Main Interaction Solver * +* * +********************************************************************** + +Note [Basic Simplifier Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Pick an element from the WorkList if there exists one with depth + less than our context-stack depth. + +2. Run it down the 'stage' pipeline. Stages are: + - canonicalization + - inert reactions + - spontaneous reactions + - top-level interactions + Each stage returns a StopOrContinue and may have sideffected + the inerts or worklist. + + The threading of the stages is as follows: + - If (Stop) is returned by a stage then we start again from Step 1. + - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to + the next stage in the pipeline. +4. If the element has survived (i.e. ContinueWith x) the last stage + then we add him in the inerts and jump back to Step 1. + +If in Step 1 no such element exists, we have exceeded our context-stack +depth and will simply fail. + +Note [Unflatten after solving the simple wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We unflatten after solving the wc_simples of an implication, and before attempting +to float. This means that + + * The fsk/fmv flatten-skolems only survive during solveSimples. We don't + need to worry about them across successive passes over the constraint tree. + (E.g. we don't need the old ic_fsk field of an implication. + + * When floating an equality outwards, we don't need to worry about floating its + associated flattening constraints. + + * Another tricky case becomes easy: #4935 + type instance F True a b = a + type instance F False a b = b + + [w] F c a b ~ gamma + (c ~ True) => a ~ gamma + (c ~ False) => b ~ gamma + + Obviously this is soluble with gamma := F c a b, and unflattening + will do exactly that after solving the simple constraints and before + attempting the implications. Before, when we were not unflattening, + we had to push Wanted funeqs in as new givens. Yuk! + + Another example that becomes easy: indexed_types/should_fail/T7786 + [W] BuriedUnder sub k Empty ~ fsk + [W] Intersect fsk inv ~ s + [w] xxx[1] ~ s + [W] forall[2] . (xxx[1] ~ Empty) + => Intersect (BuriedUnder sub k Empty) inv ~ Empty + +Note [Running plugins on unflattened wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is an annoying mismatch between solveSimpleGivens and +solveSimpleWanteds, because the latter needs to fiddle with the inert +set, unflatten and zonk the wanteds. It passes the zonked wanteds +to runTcPluginsWanteds, which produces a replacement set of wanteds, +some additional insolubles and a flag indicating whether to go round +the loop again. If so, prepareInertsForImplications is used to remove +the previous wanteds (which will still be in the inert set). Note +that prepareInertsForImplications will discard the insolubles, so we +must keep track of them separately. +-} + +solveSimpleGivens :: [Ct] -> TcS () +solveSimpleGivens givens + | null givens -- Shortcut for common case + = return () + | otherwise + = do { traceTcS "solveSimpleGivens {" (ppr givens) + ; go givens + ; traceTcS "End solveSimpleGivens }" empty } + where + go givens = do { solveSimples (listToBag givens) + ; new_givens <- runTcPluginsGiven + ; when (notNull new_givens) $ + go new_givens } + +solveSimpleWanteds :: Cts -> TcS WantedConstraints +-- NB: 'simples' may contain /derived/ equalities, floated +-- out from a nested implication. So don't discard deriveds! +-- The result is not necessarily zonked +solveSimpleWanteds simples + = do { traceTcS "solveSimpleWanteds {" (ppr simples) + ; dflags <- getDynFlags + ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) + ; traceTcS "solveSimpleWanteds end }" $ + vcat [ text "iterations =" <+> ppr n + , text "residual =" <+> ppr wc ] + ; return wc } + where + go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) + go n limit wc + | n `intGtLimit` limit + = failTcS (hang (text "solveSimpleWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" + , text "Simples =" <+> ppr simples + , text "WC =" <+> ppr wc ])) + + | isEmptyBag (wc_simple wc) + = return (n,wc) + + | otherwise + = do { -- Solve + (unif_count, wc1) <- solve_simple_wanteds wc + + -- Run plugins + ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 + -- See Note [Running plugins on unflattened wanteds] + + ; if unif_count == 0 && not rerun_plugin + then return (n, wc2) -- Done + else do { traceTcS "solveSimple going round again:" $ + ppr unif_count $$ ppr rerun_plugin + ; go (n+1) limit wc2 } } -- Loop + + +solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints) +-- Try solving these constraints +-- Affects the unification state (of course) but not the inert set +-- The result is not necessarily zonked +solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes }) + = nestTcS $ + do { solveSimples simples1 + ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts + ; (unif_count, unflattened_eqs) <- reportUnifications $ + unflattenWanteds tv_eqs fun_eqs + -- See Note [Unflatten after solving the simple wanteds] + ; return ( unif_count + , WC { wc_simple = others `andCts` unflattened_eqs + , wc_impl = implics1 `unionBags` implics2 + , wc_holes = holes }) } + +{- Note [The solveSimpleWanteds loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a bunch of simple constraints is done in a loop, +(the 'go' loop of 'solveSimpleWanteds'): + 1. Try to solve them; unflattening may lead to improvement that + was not exploitable during solving + 2. Try the plugin + 3. If step 1 did improvement during unflattening; or if the plugin + wants to run again, go back to step 1 + +Non-obviously, improvement can also take place during +the unflattening that takes place in step (1). See GHC.Tc.Solver.Flatten, +See Note [Unflattening can force the solver to iterate] +-} + +-- The main solver loop implements Note [Basic Simplifier Plan] +--------------------------------------------------------------- +solveSimples :: Cts -> TcS () +-- Returns the final InertSet in TcS +-- Has no effect on work-list or residual-implications +-- The constraints are initially examined in left-to-right order + +solveSimples cts + = {-# SCC "solveSimples" #-} + do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts) + ; solve_loop } + where + solve_loop + = {-# SCC "solve_loop" #-} + do { sel <- selectNextWorkItem + ; case sel of + Nothing -> return () + Just ct -> do { runSolverPipeline thePipeline ct + ; solve_loop } } + +-- | Extract the (inert) givens and invoke the plugins on them. +-- Remove solved givens from the inert set and emit insolubles, but +-- return new work produced so that 'solveSimpleGivens' can feed it back +-- into the main solver. +runTcPluginsGiven :: TcS [Ct] +runTcPluginsGiven + = do { plugins <- getTcPlugins + ; if null plugins then return [] else + do { givens <- getInertGivens + ; if null givens then return [] else + do { p <- runTcPlugins plugins (givens,[],[]) + ; let (solved_givens, _, _) = pluginSolvedCts p + insols = pluginBadCts p + ; updInertCans (removeInertCts solved_givens) + ; updInertIrreds (\irreds -> extendCtsList irreds insols) + ; return (pluginNewCts p) } } } + +-- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on +-- them and produce an updated bag of wanteds (possibly with some new +-- work) and a bag of insolubles. The boolean indicates whether +-- 'solveSimpleWanteds' should feed the updated wanteds back into the +-- main solver. +runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) +runTcPluginsWanted wc@(WC { wc_simple = simples1 }) + | isEmptyBag simples1 + = return (False, wc) + | otherwise + = do { plugins <- getTcPlugins + ; if null plugins then return (False, wc) else + + do { given <- getInertGivens + ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs + ; let (wanted, derived) = partition isWantedCt (bagToList simples1) + ; p <- runTcPlugins plugins (given, derived, wanted) + ; let (_, _, solved_wanted) = pluginSolvedCts p + (_, unsolved_derived, unsolved_wanted) = pluginInputCts p + new_wanted = pluginNewCts p + insols = pluginBadCts p + +-- SLPJ: I'm deeply suspicious of this +-- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) + + ; mapM_ setEv solved_wanted + ; return ( notNull (pluginNewCts p) + , wc { wc_simple = listToBag new_wanted `andCts` + listToBag unsolved_wanted `andCts` + listToBag unsolved_derived `andCts` + listToBag insols } ) } } + where + setEv :: (EvTerm,Ct) -> TcS () + setEv (ev,ct) = case ctEvidence ct of + CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev + _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" + +-- | A triple of (given, derived, wanted) constraints to pass to plugins +type SplitCts = ([Ct], [Ct], [Ct]) + +-- | A solved triple of constraints, with evidence for wanteds +type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)]) + +-- | Represents collections of constraints generated by typechecker +-- plugins +data TcPluginProgress = TcPluginProgress + { pluginInputCts :: SplitCts + -- ^ Original inputs to the plugins with solved/bad constraints + -- removed, but otherwise unmodified + , pluginSolvedCts :: SolvedCts + -- ^ Constraints solved by plugins + , pluginBadCts :: [Ct] + -- ^ Constraints reported as insoluble by plugins + , pluginNewCts :: [Ct] + -- ^ New constraints emitted by plugins + } + +getTcPlugins :: TcS [TcPluginSolver] +getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) } + +-- | Starting from a triple of (given, derived, wanted) constraints, +-- invoke each of the typechecker plugins in turn and return +-- +-- * the remaining unmodified constraints, +-- * constraints that have been solved, +-- * constraints that are insoluble, and +-- * new work. +-- +-- Note that new work generated by one plugin will not be seen by +-- other plugins on this pass (but the main constraint solver will be +-- re-invoked and they will see it later). There is no check that new +-- work differs from the original constraints supplied to the plugin: +-- the plugin itself should perform this check if necessary. +runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress +runTcPlugins plugins all_cts + = foldM do_plugin initialProgress plugins + where + do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress + do_plugin p solver = do + result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) + return $ progress p result + + progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress + progress p (TcPluginContradiction bad_cts) = + p { pluginInputCts = discard bad_cts (pluginInputCts p) + , pluginBadCts = bad_cts ++ pluginBadCts p + } + progress p (TcPluginOk solved_cts new_cts) = + p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p) + , pluginSolvedCts = add solved_cts (pluginSolvedCts p) + , pluginNewCts = new_cts ++ pluginNewCts p + } + + initialProgress = TcPluginProgress all_cts ([], [], []) [] [] + + discard :: [Ct] -> SplitCts -> SplitCts + discard cts (xs, ys, zs) = + (xs `without` cts, ys `without` cts, zs `without` cts) + + without :: [Ct] -> [Ct] -> [Ct] + without = deleteFirstsBy eqCt + + eqCt :: Ct -> Ct -> Bool + eqCt c c' = ctFlavour c == ctFlavour c' + && ctPred c `tcEqType` ctPred c' + + add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts + add xs scs = foldl' addOne scs xs + + addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts + addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of + CtGiven {} -> (ct:givens, deriveds, wanteds) + CtDerived{} -> (givens, ct:deriveds, wanteds) + CtWanted {} -> (givens, deriveds, (ev,ct):wanteds) + + +type WorkItem = Ct +type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) + +runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline + -> WorkItem -- The work item + -> TcS () +-- Run this item down the pipeline, leaving behind new work and inerts +runSolverPipeline pipeline workItem + = do { wl <- getWorkList + ; inerts <- getTcSInerts + ; tclevel <- getTcLevel + ; traceTcS "----------------------------- " empty + ; traceTcS "Start solver pipeline {" $ + vcat [ text "tclevel =" <+> ppr tclevel + , text "work item =" <+> ppr workItem + , text "inerts =" <+> ppr inerts + , text "rest of worklist =" <+> ppr wl ] + + ; bumpStepCountTcS -- One step for each constraint processed + ; final_res <- run_pipeline pipeline (ContinueWith workItem) + + ; case final_res of + Stop ev s -> do { traceFireTcS ev s + ; traceTcS "End solver pipeline (discharged) }" empty + ; return () } + ContinueWith ct -> do { addInertCan ct + ; traceFireTcS (ctEvidence ct) (text "Kept as inert") + ; traceTcS "End solver pipeline (kept as inert) }" $ + (text "final_item =" <+> ppr ct) } + } + where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct + -> TcS (StopOrContinue Ct) + run_pipeline [] res = return res + run_pipeline _ (Stop ev s) = return (Stop ev s) + run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) + = do { traceTcS ("runStage " ++ stg_name ++ " {") + (text "workitem = " <+> ppr ct) + ; res <- stg ct + ; traceTcS ("end stage " ++ stg_name ++ " }") empty + ; run_pipeline stgs res } + +{- +Example 1: + Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) + Reagent: a ~ [b] (given) + +React with (c~d) ==> IR (ContinueWith (a~[b])) True [] +React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t] +React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True [] + +Example 2: + Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty} + Reagent: a ~w [b] + +React with (c ~w d) ==> IR (ContinueWith (a~[b])) True [] +React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!) +etc. + +Example 3: + Inert: {a ~ Int, F Int ~ b} (given) + Reagent: F a ~ b (wanted) + +React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] +React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing +-} + +thePipeline :: [(String,SimplifierStage)] +thePipeline = [ ("canonicalization", GHC.Tc.Solver.Canonical.canonicalize) + , ("interact with inerts", interactWithInertsStage) + , ("top-level reactions", topReactionsStage) ] + +{- +********************************************************************************* +* * + The interact-with-inert Stage +* * +********************************************************************************* + +Note [The Solver Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We always add Givens first. So you might think that the solver has +the invariant + + If the work-item is Given, + then the inert item must Given + +But this isn't quite true. Suppose we have, + c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int +After processing the first two, we get + c1: [G] beta ~ [alpha], c2 : [W] blah +Now, c3 does not interact with the given c1, so when we spontaneously +solve c3, we must re-react it with the inert set. So we can attempt a +reaction between inert c2 [W] and work-item c3 [G]. + +It *is* true that [Solver Invariant] + If the work-item is Given, + AND there is a reaction + then the inert item must Given +or, equivalently, + If the work-item is Given, + and the inert item is Wanted/Derived + then there is no reaction +-} + +-- Interaction result of WorkItem <~> Ct + +interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) +-- Precondition: if the workitem is a CTyEqCan then it will not be able to +-- react with anything at this stage. + +interactWithInertsStage wi + = do { inerts <- getTcSInerts + ; let ics = inert_cans inerts + ; case wi of + CTyEqCan {} -> interactTyVarEq ics wi + CFunEqCan {} -> interactFunEq ics wi + CIrredCan {} -> interactIrred ics wi + CDictCan {} -> interactDict ics wi + _ -> pprPanic "interactWithInerts" (ppr wi) } + -- CNonCanonical have been canonicalised + +data InteractResult + = KeepInert -- Keep the inert item, and solve the work item from it + -- (if the latter is Wanted; just discard it if not) + | KeepWork -- Keep the work item, and solve the inert item from it + + | KeepBoth -- See Note [KeepBoth] + +instance Outputable InteractResult where + ppr KeepBoth = text "keep both" + ppr KeepInert = text "keep inert" + ppr KeepWork = text "keep work-item" + +{- Note [KeepBoth] +~~~~~~~~~~~~~~~~~~ +Consider + Inert: [WD] C ty1 ty2 + Work item: [D] C ty1 ty2 + +Here we can simply drop the work item. But what about + Inert: [W] C ty1 ty2 + Work item: [D] C ty1 ty2 + +Here we /cannot/ drop the work item, becuase we lose the [D] form, and +that is essential for e.g. fundeps, see isImprovable. We could zap +the inert item to [WD], but the simplest thing to do is simply to keep +both. (They probably started as [WD] and got split; this is relatively +rare and it doesn't seem worth trying to put them back together again.) +-} + +solveOneFromTheOther :: CtEvidence -- Inert + -> CtEvidence -- WorkItem + -> TcS InteractResult +-- Precondition: +-- * inert and work item represent evidence for the /same/ predicate +-- +-- We can always solve one from the other: even if both are wanted, +-- although we don't rewrite wanteds with wanteds, we can combine +-- two wanteds into one by solving one from the other + +solveOneFromTheOther ev_i ev_w + | CtDerived {} <- ev_w -- Work item is Derived + = case ev_i of + CtWanted { ctev_nosh = WOnly } -> return KeepBoth + _ -> return KeepInert + + | CtDerived {} <- ev_i -- Inert item is Derived + = case ev_w of + CtWanted { ctev_nosh = WOnly } -> return KeepBoth + _ -> return KeepWork + -- The ev_w is inert wrt earlier inert-set items, + -- so it's safe to continue on from this point + + -- After this, neither ev_i or ev_w are Derived + | CtWanted { ctev_loc = loc_w } <- ev_w + , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w + = -- inert must be Given + do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) + ; return KeepWork } + + | CtWanted { ctev_nosh = nosh_w } <- ev_w + -- Inert is Given or Wanted + = case ev_i of + CtWanted { ctev_nosh = WOnly } + | WDeriv <- nosh_w -> return KeepWork + _ -> return KeepInert + -- Consider work item [WD] C ty1 ty2 + -- inert item [W] C ty1 ty2 + -- Then we must keep the work item. But if the + -- work item was [W] C ty1 ty2 + -- then we are free to discard the work item in favour of inert + -- Remember, no Deriveds at this point + + -- From here on the work-item is Given + + | CtWanted { ctev_loc = loc_i } <- ev_i + , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i + = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w) + ; return KeepInert } -- Just discard the un-usable Given + -- This never actually happens because + -- Givens get processed first + + | CtWanted {} <- ev_i + = return KeepWork + + -- From here on both are Given + -- See Note [Replacement vs keeping] + + | lvl_i == lvl_w + = do { ev_binds_var <- getTcEvBindsVar + ; binds <- getTcEvBindsMap ev_binds_var + ; return (same_level_strategy binds) } + + | otherwise -- Both are Given, levels differ + = return different_level_strategy + where + pred = ctEvPred ev_i + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + lvl_i = ctLocLevel loc_i + lvl_w = ctLocLevel loc_w + ev_id_i = ctEvEvId ev_i + ev_id_w = ctEvEvId ev_w + + different_level_strategy -- Both Given + | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert + | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork + -- See Note [Replacement vs keeping] (the different-level bullet) + -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] + + same_level_strategy binds -- Both Given + | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i + = case ctLocOrigin loc_w of + GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork + | otherwise -> KeepInert + _ -> KeepWork + + | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w + = KeepInert + + | has_binding binds ev_id_w + , not (has_binding binds ev_id_i) + , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w)) + = KeepWork + + | otherwise + = KeepInert + + has_binding binds ev_id = isJust (lookupEvBind binds ev_id) + +{- +Note [Replacement vs keeping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have two Given constraints both of type (C tys), say, which should +we keep? More subtle than you might think! + + * Constraints come from different levels (different_level_strategy) + + - For implicit parameters we want to keep the innermost (deepest) + one, so that it overrides the outer one. + See Note [Shadowing of Implicit Parameters] + + - For everything else, we want to keep the outermost one. Reason: that + makes it more likely that the inner one will turn out to be unused, + and can be reported as redundant. See Note [Tracking redundant constraints] + in GHC.Tc.Solver. + + It transpires that using the outermost one is responsible for an + 8% performance improvement in nofib cryptarithm2, compared to + just rolling the dice. I didn't investigate why. + + * Constraints coming from the same level (i.e. same implication) + + (a) Always get rid of InstSC ones if possible, since they are less + useful for solving. If both are InstSC, choose the one with + the smallest TypeSize + See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + + (b) Keep the one that has a non-trivial evidence binding. + Example: f :: (Eq a, Ord a) => blah + then we may find [G] d3 :: Eq a + [G] d2 :: Eq a + with bindings d3 = sc_sel (d1::Ord a) + We want to discard d2 in favour of the superclass selection from + the Ord dictionary. + Why? See Note [Tracking redundant constraints] in GHC.Tc.Solver again. + + (c) But don't do (b) if the evidence binding depends transitively on the + one without a binding. Example (with RecursiveSuperClasses) + class C a => D a + class D a => C a + Inert: d1 :: C a, d2 :: D a + Binds: d3 = sc_sel d2, d2 = sc_sel d1 + Work item: d3 :: C a + Then it'd be ridiculous to replace d1 with d3 in the inert set! + Hence the findNeedEvVars test. See #14774. + + * Finally, when there is still a choice, use KeepInert rather than + KeepWork, for two reasons: + - to avoid unnecessary munging of the inert set. + - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical + +Doing the depth-check for implicit parameters, rather than making the work item +always override, is important. Consider + + data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } + + f :: (?x::a) => T a -> Int + f T1 = ?x + f T2 = 3 + +We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add +two new givens in the work-list: [G] (?x::Int) + [G] (a ~ Int) +Now consider these steps + - process a~Int, kicking out (?x::a) + - process (?x::Int), the inner given, adding to inert set + - process (?x::a), the outer given, overriding the inner given +Wrong! The depth-check ensures that the inner implicit parameter wins. +(Actually I think that the order in which the work-list is processed means +that this chain of events won't happen, but that's very fragile.) + +********************************************************************************* +* * + interactIrred +* * +********************************************************************************* + +Note [Multiple matching irreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that it's impossible to have multiple irreds all match the +work item; after all, interactIrred looks for matches and solves one from the +other. However, note that interacting insoluble, non-droppable irreds does not +do this matching. We thus might end up with several insoluble, non-droppable, +matching irreds in the inert set. When another irred comes along that we have +not yet labeled insoluble, we can find multiple matches. These multiple matches +cause no harm, but it would be wrong to ASSERT that they aren't there (as we +once had done). This problem can be tickled by typecheck/should_compile/holes. + +-} + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) + +interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_status = status }) + | InsolubleCIS <- status + -- For insolubles, don't allow the constraint to be dropped + -- which can happen with solveOneFromTheOther, so that + -- we get distinct error messages with -fdefer-type-errors + -- See Note [Do not add duplicate derived insolubles] + , not (isDroppableCt workItem) + = continueWith workItem + + | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w + , ((ct_i, swap) : _rest) <- bagToList matching_irreds + -- See Note [Multiple matching irreds] + , let ev_i = ctEvidence ct_i + = do { what_next <- solveOneFromTheOther ev_i ev_w + ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) + ; case what_next of + KeepBoth -> continueWith workItem + KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) + ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } + KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) + ; updInertIrreds (\_ -> others) + ; continueWith workItem } } + + | otherwise + = continueWith workItem + + where + swap_me :: SwapFlag -> CtEvidence -> EvTerm + swap_me swap ev + = case swap of + NotSwapped -> ctEvTerm ev + IsSwapped -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev))) + +interactIrred _ wi = pprPanic "interactIrred" (ppr wi) + +findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct) +findMatchingIrreds irreds ev + | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred + -- See Note [Solving irreducible equalities] + = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds + | otherwise + = partitionBagWith match_non_eq irreds + where + pred = ctEvPred ev + match_non_eq ct + | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped) + | otherwise = Right ct + + match_eq eq_rel1 lty1 rty1 ct + | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct) + , eq_rel1 == eq_rel2 + , Just swap <- match_eq_help lty1 rty1 lty2 rty2 + = Left (ct, swap) + | otherwise + = Right ct + + match_eq_help lty1 rty1 lty2 rty2 + | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2 + = Just NotSwapped + | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2 + = Just IsSwapped + | otherwise + = Nothing + +{- Note [Solving irreducible equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14333) + [G] a b ~R# c d + [W] c d ~R# a b +Clearly we should be able to solve this! Even though the constraints are +not decomposable. We solve this when looking up the work-item in the +irreducible constraints to look for an identical one. When doing this +lookup, findMatchingIrreds spots the equality case, and matches either +way around. It has to return a swap-flag so we can generate evidence +that is the right way round too. + +Note [Do not add duplicate derived insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *must* add an insoluble (Int ~ Bool) even if there is +one such there already, because they may come from distinct call +sites. Not only do we want an error message for each, but with +-fdefer-type-errors we must generate evidence for each. But for +*derived* insolubles, we only want to report each one once. Why? + +(a) A constraint (C r s t) where r -> s, say, may generate the same fundep + equality many times, as the original constraint is successively rewritten. + +(b) Ditto the successive iterations of the main solver itself, as it traverses + the constraint tree. See example below. + +Also for *given* insolubles we may get repeated errors, as we +repeatedly traverse the constraint tree. These are relatively rare +anyway, so removing duplicates seems ok. (Alternatively we could take +the SrcLoc into account.) + +Note that the test does not need to be particularly efficient because +it is only used if the program has a type error anyway. + +Example of (b): assume a top-level class and instance declaration: + + class D a b | a -> b + instance D [a] [a] + +Assume we have started with an implication: + + forall c. Eq c => { wc_simple = D [c] c [W] } + +which we have simplified to: + + forall c. Eq c => { wc_simple = D [c] c [W] + (c ~ [c]) [D] } + +For some reason, e.g. because we floated an equality somewhere else, +we might try to re-solve this implication. If we do not do a +dropDerivedWC, then we will end up trying to solve the following +constraints the second time: + + (D [c] c) [W] + (c ~ [c]) [D] + +which will result in two Deriveds to end up in the insoluble set: + + wc_simple = D [c] c [W] + (c ~ [c]) [D], (c ~ [c]) [D] +-} + +{- +********************************************************************************* +* * + interactDict +* * +********************************************************************************* + +Note [Shortcut solving] +~~~~~~~~~~~~~~~~~~~~~~~ +When we interact a [W] constraint with a [G] constraint that solves it, there is +a possibility that we could produce better code if instead we solved from a +top-level instance declaration (See #12791, #5835). For example: + + class M a b where m :: a -> b + + type C a b = (Num a, M a b) + + f :: C Int b => b -> Int -> Int + f _ x = x + 1 + +The body of `f` requires a [W] `Num Int` instance. We could solve this +constraint from the givens because we have `C Int b` and that provides us a +solution for `Num Int`. This would let us produce core like the following +(with -O2): + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> + + @ Int + (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) + eta1 + A.f1 + +This is bad! We could do /much/ better if we solved [W] `Num Int` directly +from the instance that we have in scope: + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) _ _ (x :: Int) -> + case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } + +** NB: It is important to emphasize that all this is purely an optimization: +** exactly the same programs should typecheck with or without this +** procedure. + +Solving fully +~~~~~~~~~~~~~ +There is a reason why the solver does not simply try to solve such +constraints with top-level instances. If the solver finds a relevant +instance declaration in scope, that instance may require a context +that can't be solved for. A good example of this is: + + f :: Ord [a] => ... + f x = ..Need Eq [a]... + +If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would +be left with the obligation to solve the constraint Eq a, which we cannot. So we +must be conservative in our attempt to use an instance declaration to solve the +[W] constraint we're interested in. + +Our rule is that we try to solve all of the instance's subgoals +recursively all at once. Precisely: We only attempt to solve +constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci +are themselves class constraints of the form `C1', ... Cm' => C' t1' +... tn'` and we only succeed if the entire tree of constraints is +solvable from instances. + +An example that succeeds: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [Int] b => b -> Bool + f x = m x == [] + +We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This +produces the following core: + + f :: forall b. C [Int] b => b -> Bool + f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> + GHC.Classes.$fEq[]_$s$c== + (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) + +An example that fails: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [a] b => b -> Bool + f x = m x == [] + +Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: + + f :: forall a b. C [a] b => b -> Bool + f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> + == + @ [a] + (A.$p1C @ [a] @ b $dC) + (m @ [a] @ b $dC eta) + (GHC.Types.[] @ a) + +Note [Shortcut solving: type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#13943) + class Take (n :: Nat) where ... + instance {-# OVERLAPPING #-} Take 0 where .. + instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. + +And we have [W] Take 3. That only matches one instance so we get +[W] Take (3-1). Really we should now flatten to reduce the (3-1) to 2, and +so on -- but that is reproducing yet more of the solver. Sigh. For now, +we just give up (remember all this is just an optimisation). + +But we must not just naively try to lookup (Take (3-1)) in the +InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a +unique match on the (Take n) instance. That leads immediately to an +infinite loop. Hence the check that 'preds' have no type families +(isTyFamFree). + +Note [Shortcut solving: incoherence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This optimization relies on coherence of dictionaries to be correct. When we +cannot assume coherence because of IncoherentInstances then this optimization +can change the behavior of the user's code. + +The following four modules produce a program whose output would change depending +on whether we apply this optimization when IncoherentInstances is in effect: + +######### + {-# LANGUAGE MultiParamTypeClasses #-} + module A where + + class A a where + int :: a -> Int + + class A a => C a b where + m :: b -> a -> a + +######### + {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + module B where + + import A + + instance A a where + int _ = 1 + + instance C a [b] where + m _ = id + +######### + {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} + {-# LANGUAGE IncoherentInstances #-} + module C where + + import A + + instance A Int where + int _ = 2 + + instance C Int [Int] where + m _ = id + + intC :: C Int a => a -> Int -> Int + intC _ x = int x + +######### + module Main where + + import A + import B + import C + + main :: IO () + main = print (intC [] (0::Int)) + +The output of `main` if we avoid the optimization under the effect of +IncoherentInstances is `1`. If we were to do the optimization, the output of +`main` would be `2`. + +Note [Shortcut try_solve_from_instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The workhorse of the short-cut solver is + try_solve_from_instance :: (EvBindMap, DictMap CtEvidence) + -> CtEvidence -- Solve this + -> MaybeT TcS (EvBindMap, DictMap CtEvidence) +Note that: + +* The CtEvidence is the goal to be solved + +* The MaybeT manages early failure if we find a subgoal that + cannot be solved from instances. + +* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional + state that allows try_solve_from_instance to augmennt the evidence + bindings and inert_solved_dicts as it goes. + + If it succeeds, we commit all these bindings and solved dicts to the + main TcS InertSet. If not, we abandon it all entirely. + +Passing along the solved_dicts important for two reasons: + +* We need to be able to handle recursive super classes. The + solved_dicts state ensures that we remember what we have already + tried to solve to avoid looping. + +* As #15164 showed, it can be important to exploit sharing between + goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; + and to solve G2 we may need H. If we don't spot this sharing we may + solve H twice; and if this pattern repeats we may get exponentially bad + behaviour. +-} + +interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) +interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) + | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys + , let ev_i = ctEvidence ct_i + = -- There is a matching dictionary in the inert set + do { -- First to try to solve it /completely/ from top level instances + -- See Note [Shortcut solving] + dflags <- getDynFlags + ; short_cut_worked <- shortCutSolver dflags ev_w ev_i + ; if short_cut_worked + then stopWith ev_w "interactDict/solved from instance" + else + + do { -- Ths short-cut solver didn't fire, so we + -- solve ev_w from the matching inert ev_i we found + what_next <- solveOneFromTheOther ev_i ev_w + ; traceTcS "lookupInertDict" (ppr what_next) + ; case what_next of + KeepBoth -> continueWith workItem + KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) + ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } + KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) + ; updInertDicts $ \ ds -> delDict ds cls tys + ; continueWith workItem } } } + + | cls `hasKey` ipClassKey + , isGiven ev_w + = interactGivenIP inerts workItem + + | otherwise + = do { addFunDepWork inerts ev_w cls + ; continueWith workItem } + +interactDict _ wi = pprPanic "interactDict" (ppr wi) + +-- See Note [Shortcut solving] +shortCutSolver :: DynFlags + -> CtEvidence -- Work item + -> CtEvidence -- Inert we want to try to replace + -> TcS Bool -- True <=> success +shortCutSolver dflags ev_w ev_i + | isWanted ev_w + && isGiven ev_i + -- We are about to solve a [W] constraint from a [G] constraint. We take + -- a moment to see if we can get a better solution using an instance. + -- Note that we only do this for the sake of performance. Exactly the same + -- programs should typecheck regardless of whether we take this step or + -- not. See Note [Shortcut solving] + + && not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627) + + && not (xopt LangExt.IncoherentInstances dflags) + -- If IncoherentInstances is on then we cannot rely on coherence of proofs + -- in order to justify this optimization: The proof provided by the + -- [G] constraint's superclass may be different from the top-level proof. + -- See Note [Shortcut solving: incoherence] + + && gopt Opt_SolveConstantDicts dflags + -- Enabled by the -fsolve-constant-dicts flag + + = do { ev_binds_var <- getTcEvBindsVar + ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w ) + getTcEvBindsMap ev_binds_var + ; solved_dicts <- getSolvedDicts + + ; mb_stuff <- runMaybeT $ try_solve_from_instance + (ev_binds, solved_dicts) ev_w + + ; case mb_stuff of + Nothing -> return False + Just (ev_binds', solved_dicts') + -> do { setTcEvBindsMap ev_binds_var ev_binds' + ; setSolvedDicts solved_dicts' + ; return True } } + + | otherwise + = return False + where + -- This `CtLoc` is used only to check the well-staged condition of any + -- candidate DFun. Our subgoals all have the same stage as our root + -- [W] constraint so it is safe to use this while solving them. + loc_w = ctEvLoc ev_w + + try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] + :: (EvBindMap, DictMap CtEvidence) -> CtEvidence + -> MaybeT TcS (EvBindMap, DictMap CtEvidence) + try_solve_from_instance (ev_binds, solved_dicts) ev + | let pred = ctEvPred ev + loc = ctEvLoc ev + , ClassPred cls tys <- classifyPredType pred + = do { inst_res <- lift $ matchGlobalInst dflags True cls tys + ; case inst_res of + OneInst { cir_new_theta = preds + , cir_mk_ev = mk_ev + , cir_what = what } + | safeOverlap what + , all isTyFamFree preds -- Note [Shortcut solving: type families] + -> do { let solved_dicts' = addDict solved_dicts cls tys ev + -- solved_dicts': it is important that we add our goal + -- to the cache before we solve! Otherwise we may end + -- up in a loop while solving recursive dictionaries. + + ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) + ; loc' <- lift $ checkInstanceOK loc what pred + + ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds + -- Emit work for subgoals but use our local cache + -- so we can solve recursive dictionaries. + + ; let ev_tm = mk_ev (map getEvExpr evc_vs) + ev_binds' = extendEvBinds ev_binds $ + mkWantedEvBind (ctEvEvId ev) ev_tm + + ; foldlM try_solve_from_instance + (ev_binds', solved_dicts') + (freshGoals evc_vs) } + + _ -> mzero } + | otherwise = mzero + + + -- Use a local cache of solved dicts while emitting EvVars for new work + -- We bail out of the entire computation if we need to emit an EvVar for + -- a subgoal that isn't a ClassPred. + new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew + new_wanted_cached loc cache pty + | ClassPred cls tys <- classifyPredType pty + = lift $ case findDict cache loc_w cls tys of + Just ctev -> return $ Cached (ctEvExpr ctev) + Nothing -> Fresh <$> newWantedNC loc pty + | otherwise = mzero + +addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () +-- Add derived constraints from type-class functional dependencies. +addFunDepWork inerts work_ev cls + | isImprovable work_ev + = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) + -- No need to check flavour; fundeps work between + -- any pair of constraints, regardless of flavour + -- Importantly we don't throw workitem back in the + -- worklist because this can cause loops (see #5236) + | otherwise + = return () + where + work_pred = ctEvPred work_ev + work_loc = ctEvLoc work_ev + + add_fds inert_ct + | isImprovable inert_ev + = do { traceTcS "addFunDepWork" (vcat + [ ppr work_ev + , pprCtLoc work_loc, ppr (isGivenLoc work_loc) + , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) + , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ; + + emitFunDepDeriveds $ + improveFromAnother derived_loc inert_pred work_pred + -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok + -- NB: We do create FDs for given to report insoluble equations that arise + -- from pairs of Givens, and also because of floating when we approximate + -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs + } + | otherwise + = return () + where + inert_ev = ctEvidence inert_ct + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` + ctl_depth inert_loc + , ctl_origin = FunDepOrigin1 work_pred + (ctLocOrigin work_loc) + (ctLocSpan work_loc) + inert_pred + (ctLocOrigin inert_loc) + (ctLocSpan inert_loc) } + +{- +********************************************************************** +* * + Implicit parameters +* * +********************************************************************** +-} + +interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- Work item is Given (?x:ty) +-- See Note [Shadowing of Implicit Parameters] +interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls + , cc_tyargs = tys@(ip_str:_) }) + = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } + ; stopWith ev "Given IP" } + where + dicts = inert_dicts inerts + ip_dicts = findDictsByClass dicts cls + other_ip_dicts = filterBag (not . is_this_ip) ip_dicts + filtered_dicts = addDictsByClass dicts cls other_ip_dicts + + -- Pick out any Given constraints for the same implicit parameter + is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ }) + = isGiven ev && ip_str `tcEqType` ip_str' + is_this_ip _ = False + +interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) + +{- Note [Shadowing of Implicit Parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in +two incompatible ways: either by using the parameter from the +signature, or by using the local definition. Our intention is +that the local definition should "shadow" the parameter of the +signature, and we implement this as follows: when we add a new +*given* implicit parameter to the inert set, it replaces any existing +givens for the same implicit parameter. + +Similarly, consider + f :: (?x::a) => Bool -> a + + g v = let ?x::Int = 3 + in (f v, let ?x::Bool = True in f v) + +This should probably be well typed, with + g :: Bool -> (Int, Bool) + +So the inner binding for ?x::Bool *overrides* the outer one. + +See ticket #17104 for a rather tricky example of this overriding +behaviour. + +All this works for the normal cases but it has an odd side effect in +some pathological programs like this: +-- This is accepted, the second parameter shadows +f1 :: (?x :: Int, ?x :: Char) => Char +f1 = ?x + +-- This is rejected, the second parameter shadows +f2 :: (?x :: Int, ?x :: Char) => Int +f2 = ?x + +Both of these are actually wrong: when we try to use either one, +we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), +which would lead to an error. + +I can think of two ways to fix this: + + 1. Simply disallow multiple constraints for the same implicit + parameter---this is never useful, and it can be detected completely + syntactically. + + 2. Move the shadowing machinery to the location where we nest + implications, and add some code here that will produce an + error if we get multiple givens for the same implicit parameter. + + +********************************************************************** +* * + interactFunEq +* * +********************************************************************** +-} + +interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- Try interacting the work item with the inert set +interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc + , cc_tyargs = args, cc_fsk = fsk }) + | Just inert_ct@(CFunEqCan { cc_ev = ev_i + , cc_fsk = fsk_i }) + <- findFunEq (inert_funeqs inerts) tc args + , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev + = do { traceTcS "reactFunEq (rewrite inert item):" $ + vcat [ text "work_item =" <+> ppr work_item + , text "inertItem=" <+> ppr ev_i + , text "(swap_flag, upgrade)" <+> ppr pr ] + ; if isSwapped swap_flag + then do { -- Rewrite inert using work-item + let work_item' | upgrade_flag = upgradeWanted work_item + | otherwise = work_item + ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item' + -- Do the updInertFunEqs before the reactFunEq, so that + -- we don't kick out the inertItem as well as consuming it! + ; reactFunEq ev fsk ev_i fsk_i + ; stopWith ev "Work item rewrites inert" } + else do { -- Rewrite work-item using inert + ; when upgrade_flag $ + updInertFunEqs $ \ feqs -> insertFunEq feqs tc args + (upgradeWanted inert_ct) + ; reactFunEq ev_i fsk_i ev fsk + ; stopWith ev "Inert rewrites work item" } } + + | otherwise -- Try improvement + = do { improveLocalFunEqs ev inerts tc args fsk + ; continueWith work_item } + +interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item) + +upgradeWanted :: Ct -> Ct +-- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2 +-- so upgrade the [W] to [WD] before putting it in the inert set +upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) } + where + upgrade_ev ev = ASSERT2( isWanted ev, ppr ct ) + ev { ctev_nosh = WDeriv } + +improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar + -> TcS () +-- Generate derived improvement equalities, by comparing +-- the current work item with inert CFunEqs +-- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' +-- +-- See Note [FunDep and implicit parameter reactions] +improveLocalFunEqs work_ev inerts fam_tc args fsk + | isGiven work_ev -- See Note [No FunEq improvement for Givens] + || not (isImprovable work_ev) + = return () + + | otherwise + = do { eqns <- improvement_eqns + ; if not (null eqns) + then do { traceTcS "interactFunEq improvements: " $ + vcat [ text "Eqns:" <+> ppr eqns + , text "Candidates:" <+> ppr funeqs_for_tc + , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] + ; emitFunDepDeriveds eqns } + else return () } + + where + funeqs = inert_funeqs inerts + funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc + work_loc = ctEvLoc work_ev + work_pred = ctEvPred work_ev + fam_inj_info = tyConInjectivityInfo fam_tc + + -------------------- + improvement_eqns :: TcS [FunDepEqn CtLoc] + improvement_eqns + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = -- Try built-in families, notably for arithmethic + do { rhs <- rewriteTyVar fsk + ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc } + + | Injective injective_args <- fam_inj_info + = -- Try improvement from type families with injectivity annotations + do { rhs <- rewriteTyVar fsk + ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc } + + | otherwise + = return [] + + -------------------- + do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev }) + = do { inert_rhs <- rewriteTyVar ifsk + ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) } + + do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) + + -------------------- + -- See Note [Type inference for type families with injectivity] + do_one_injective inj_args rhs (CFunEqCan { cc_tyargs = inert_args + , cc_fsk = ifsk, cc_ev = inert_ev }) + | isImprovable inert_ev + = do { inert_rhs <- rewriteTyVar ifsk + ; return $ if rhs `tcEqType` inert_rhs + then mk_fd_eqns inert_ev $ + [ Pair arg iarg + | (arg, iarg, True) <- zip3 args inert_args inj_args ] + else [] } + | otherwise + = return [] + + do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) + + -------------------- + mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc] + mk_fd_eqns inert_ev eqns + | null eqns = [] + | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns + , fd_pred1 = work_pred + , fd_pred2 = ctEvPred inert_ev + , fd_loc = loc } ] + where + inert_loc = ctEvLoc inert_ev + loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` + ctl_depth work_loc } + +------------- +reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 + -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 + -> TcS () +reactFunEq from_this fsk1 solve_this fsk2 + = do { traceTcS "reactFunEq" + (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2]) + ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) + ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ + ppr solve_this $$ ppr fsk2) } + +{- Note [Type inference for type families with injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a type family with an injectivity annotation: + type family F a b = r | r -> b + +Then if we have two CFunEqCan constraints for F with the same RHS + F s1 t1 ~ rhs + F s2 t2 ~ rhs +then we can use the injectivity to get a new Derived constraint on +the injective argument + [D] t1 ~ t2 + +That in turn can help GHC solve constraints that would otherwise require +guessing. For example, consider the ambiguity check for + f :: F Int b -> Int +We get the constraint + [W] F Int b ~ F Int beta +where beta is a unification variable. Injectivity lets us pick beta ~ b. + +Injectivity information is also used at the call sites. For example: + g = f True +gives rise to + [W] F Int b ~ Bool +from which we can derive b. This requires looking at the defining equations of +a type family, ie. finding equation with a matching RHS (Bool in this example) +and inferring values of type variables (b in this example) from the LHS patterns +of the matching equation. For closed type families we have to perform +additional apartness check for the selected equation to check that the selected +is guaranteed to fire for given LHS arguments. + +These new constraints are simply *Derived* constraints; they have no evidence. +We could go further and offer evidence from decomposing injective type-function +applications, but that would require new evidence forms, and an extension to +FC, so we don't do that right now (Dec 14). + +See also Note [Injective type families] in GHC.Core.TyCon + + +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtEvidence), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + (i) Will set g2 := g1 `cast` g3 + (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + (iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. + + +Note [Efficient Orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are interacting two FunEqCans with the same LHS: + (inert) ci :: (F ty ~ xi_i) + (work) cw :: (F ty ~ xi_w) +We prefer to keep the inert (else we pass the work item on down +the pipeline, which is a bit silly). If we keep the inert, we +will (a) discharge 'cw' + (b) produce a new equality work-item (xi_w ~ xi_i) +Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): + new_work :: xi_w ~ xi_i + cw := ci ; sym new_work +Why? Consider the simplest case when xi1 is a type variable. If +we generate xi1~xi2, processing that constraint will kick out 'ci'. +If we generate xi2~xi1, there is less chance of that happening. +Of course it can and should still happen if xi1=a, xi1=Int, say. +But we want to avoid it happening needlessly. + +Similarly, if we *can't* keep the inert item (because inert is Wanted, +and work is Given, say), we prefer to orient the new equality (xi_i ~ +xi_w). + +Note [Carefully solve the right CFunEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ---- OLD COMMENT, NOW NOT NEEDED + ---- because we now allow multiple + ---- wanted FunEqs with the same head +Consider the constraints + c1 :: F Int ~ a -- Arising from an application line 5 + c2 :: F Int ~ Bool -- Arising from an application line 10 +Suppose that 'a' is a unification variable, arising only from +flattening. So there is no error on line 5; it's just a flattening +variable. But there is (or might be) an error on line 10. + +Two ways to combine them, leaving either (Plan A) + c1 :: F Int ~ a -- Arising from an application line 5 + c3 :: a ~ Bool -- Arising from an application line 10 +or (Plan B) + c2 :: F Int ~ Bool -- Arising from an application line 10 + c4 :: a ~ Bool -- Arising from an application line 5 + +Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error +on the *totally innocent* line 5. An example is test SimpleFail16 +where the expected/actual message comes out backwards if we use +the wrong plan. + +The second is the right thing to do. Hence the isMetaTyVarTy +test when solving pairwise CFunEqCan. + + +********************************************************************** +* * + interactTyVarEq +* * +********************************************************************** +-} + +inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole + -> Maybe ( CtEvidence -- The evidence for the inert + , SwapFlag -- Whether we need mkSymCo + , Bool) -- True <=> keep a [D] version + -- of the [WD] constraint +inertsCanDischarge inerts tv rhs fr + | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i + , cc_eq_rel = eq_rel } + <- findTyEqs inerts tv + , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr + , rhs_i `tcEqType` rhs ] + = -- Inert: a ~ ty + -- Work item: a ~ ty + Just (ev_i, NotSwapped, keep_deriv ev_i) + + | Just tv_rhs <- getTyVar_maybe rhs + , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i + , cc_eq_rel = eq_rel } + <- findTyEqs inerts tv_rhs + , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr + , rhs_i `tcEqType` mkTyVarTy tv ] + = -- Inert: a ~ b + -- Work item: b ~ a + Just (ev_i, IsSwapped, keep_deriv ev_i) + + | otherwise + = Nothing + + where + keep_deriv ev_i + | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] + , (Wanted WDeriv, _) <- fr -- work item is [WD] + = True -- Keep a derived version of the work item + | otherwise + = False -- Work item is fully discharged + +interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- CTyEqCans are always consumed, so always returns Stop +interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv + , cc_rhs = rhs + , cc_ev = ev + , cc_eq_rel = eq_rel }) + | Just (ev_i, swapped, keep_deriv) + <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel) + = do { setEvBindIfWanted ev $ + evCoercion (maybeSym swapped $ + tcDowngradeRole (eqRelRole eq_rel) + (ctEvRole ev_i) + (ctEvCoercion ev_i)) + + ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev + , ctev_loc = ctEvLoc ev } + ; when keep_deriv $ + emitWork [workItem { cc_ev = deriv_ev }] + -- As a Derived it might not be fully rewritten, + -- so we emit it as new work + + ; stopWith ev "Solved from inert" } + + | ReprEq <- eq_rel -- See Note [Do not unify representational equalities] + = do { traceTcS "Not unifying representational equality" (ppr workItem) + ; continueWith workItem } + + | isGiven ev -- See Note [Touchables and givens] + = continueWith workItem + + | otherwise + = do { tclvl <- getTcLevel + ; if canSolveByUnification tclvl tv rhs + then do { solveByUnification ev tv rhs + ; n_kicked <- kickOutAfterUnification tv + ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) } + + else continueWith workItem } + +interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) + +solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () +-- Solve with the identity coercion +-- Precondition: kind(xi) equals kind(tv) +-- Precondition: CtEvidence is Wanted or Derived +-- Precondition: CtEvidence is nominal +-- Returns: workItem where +-- workItem = the new Given constraint +-- +-- NB: No need for an occurs check here, because solveByUnification always +-- arises from a CTyEqCan, a *canonical* constraint. Its invariant (TyEq:OC) +-- says that in (a ~ xi), the type variable a does not appear in xi. +-- See GHC.Tc.Types.Constraint.Ct invariants. +-- +-- Post: tv is unified (by side effect) with xi; +-- we often write tv := xi +solveByUnification wd tv xi + = do { let tv_ty = mkTyVarTy tv + ; traceTcS "Sneaky unification:" $ + vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, + text "Coercion:" <+> pprEq tv_ty xi, + text "Left Kind is:" <+> ppr (tcTypeKind tv_ty), + text "Right Kind is:" <+> ppr (tcTypeKind xi) ] + + ; unifyTyVar tv xi + ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) } + +{- Note [Avoid double unifications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The spontaneous solver has to return a given which mentions the unified unification +variable *on the left* of the equality. Here is what happens if not: + Original wanted: (a ~ alpha), (alpha ~ Int) +We spontaneously solve the first wanted, without changing the order! + given : a ~ alpha [having unified alpha := a] +Now the second wanted comes along, but he cannot rewrite the given, so we simply continue. +At the end we spontaneously solve that guy, *reunifying* [alpha := Int] + +We avoid this problem by orienting the resulting given so that the unification +variable is on the left. [Note that alternatively we could attempt to +enforce this at canonicalization] + +See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding +double unifications is the main reason we disallow touchable +unification variables as RHS of type family equations: F xis ~ alpha. + +Note [Do not unify representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [W] alpha ~R# b +where alpha is touchable. Should we unify alpha := b? + +Certainly not! Unifying forces alpha and be to be the same; but they +only need to be representationally equal types. + +For example, we might have another constraint [W] alpha ~# N b +where + newtype N b = MkN b +and we want to get alpha := N b. + +See also #15144, which was caused by unifying a representational +equality (in the unflattener). + + +************************************************************************ +* * +* Functional dependencies, instantiation of equations +* * +************************************************************************ + +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer +now!). + +Note [FunDep and implicit parameter reactions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, our story of interacting two dictionaries (or a dictionary +and top-level instances) for functional dependencies, and implicit +parameters, is that we simply produce new Derived equalities. So for example + + class D a b | a -> b where ... + Inert: + d1 :g D Int Bool + WorkItem: + d2 :w D Int alpha + + We generate the extra work item + cv :d alpha ~ Bool + where 'cv' is currently unused. However, this new item can perhaps be + spontaneously solved to become given and react with d2, + discharging it in favour of a new constraint d2' thus: + d2' :w D Int Bool + d2 := d2' |> D Int cv + Now d2' can be discharged from d1 + +We could be more aggressive and try to *immediately* solve the dictionary +using those extra equalities, but that requires those equalities to carry +evidence and derived do not carry evidence. + +If that were the case with the same inert set and work item we might dischard +d2 directly: + + cv :w alpha ~ Bool + d2 := d1 |> D Int cv + +But in general it's a bit painful to figure out the necessary coercion, +so we just take the first approach. Here is a better example. Consider: + class C a b c | a -> b +And: + [Given] d1 : C T Int Char + [Wanted] d2 : C T beta Int +In this case, it's *not even possible* to solve the wanted immediately. +So we should simply output the functional dependency and add this guy +[but NOT its superclasses] back in the worklist. Even worse: + [Given] d1 : C T Int beta + [Wanted] d2: C T beta Int +Then it is solvable, but its very hard to detect this on the spot. + +It's exactly the same with implicit parameters, except that the +"aggressive" approach would be much easier to implement. + +Note [Weird fundeps] +~~~~~~~~~~~~~~~~~~~~ +Consider class Het a b | a -> b where + het :: m (f c) -> a -> m b + + class GHet (a :: * -> *) (b :: * -> *) | a -> b + instance GHet (K a) (K [a]) + instance Het a b => GHet (K a) (K b) + +The two instances don't actually conflict on their fundeps, +although it's pretty strange. So they are both accepted. Now +try [W] GHet (K Int) (K Bool) +This triggers fundeps from both instance decls; + [D] K Bool ~ K [a] + [D] K Bool ~ K beta +And there's a risk of complaining about Bool ~ [a]. But in fact +the Wanted matches the second instance, so we never get as far +as the fundeps. + +#7875 is a case in point. +-} + +emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS () +-- See Note [FunDep and implicit parameter reactions] +emitFunDepDeriveds fd_eqns + = mapM_ do_one_FDEqn fd_eqns + where + do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) + | null tvs -- Common shortcut + = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) + ; mapM_ (unifyDerived loc Nominal) eqs } + | otherwise + = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) + ; subst <- instFlexi tvs -- Takes account of kind substitution + ; mapM_ (do_one_eq loc subst) eqs } + + do_one_eq loc subst (Pair ty1 ty2) + = unifyDerived loc Nominal $ + Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) + +{- +********************************************************************** +* * + The top-reaction Stage +* * +********************************************************************** +-} + +topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) +-- The work item does not react with the inert set, +-- so try interaction with top-level instances. Note: +topReactionsStage work_item + = do { traceTcS "doTopReact" (ppr work_item) + ; case work_item of + CDictCan {} -> do { inerts <- getTcSInerts + ; doTopReactDict inerts work_item } + CFunEqCan {} -> doTopReactFunEq work_item + CIrredCan {} -> doTopReactOther work_item + CTyEqCan {} -> doTopReactOther work_item + _ -> -- Any other work item does not react with any top-level equations + continueWith work_item } + + +-------------------- +doTopReactOther :: Ct -> TcS (StopOrContinue Ct) +-- Try local quantified constraints for +-- CTyEqCan e.g. (a ~# ty) +-- and CIrredCan e.g. (c a) +-- +-- Why equalities? See GHC.Tc.Solver.Canonical +-- Note [Equality superclasses in quantified constraints] +doTopReactOther work_item + | isGiven ev + = continueWith work_item + + | EqPred eq_rel t1 t2 <- classifyPredType pred + = doTopReactEqPred work_item eq_rel t1 t2 + + | otherwise + = do { res <- matchLocalInst pred loc + ; case res of + OneInst {} -> chooseInstance work_item res + _ -> continueWith work_item } + + where + ev = ctEvidence work_item + loc = ctEvLoc ev + pred = ctEvPred ev + +doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) +doTopReactEqPred work_item eq_rel t1 t2 + -- See Note [Looking up primitive equalities in quantified constraints] + | Just (cls, tys) <- boxEqPred eq_rel t1 t2 + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> chooseInstance work_item + (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) + _ -> continueWith work_item } + + | otherwise + = continueWith work_item + where + ev = ctEvidence work_item + loc = ctEvLoc ev + + mk_eq_ev cls tys mk_ev evs + = case (mk_ev evs) of + EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) + ev -> pprPanic "mk_eq_ev" (ppr ev) + where + [sc_id] = classSCSelIds cls + +{- Note [Looking up primitive equalities in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For equalities (a ~# b) look up (a ~ b), and then do a superclass +selection. This avoids having to support quantified constraints whose +kind is not Constraint, such as (forall a. F a ~# b) + +See + * Note [Evidence for quantified constraints] in GHC.Core.Predicate + * Note [Equality superclasses in quantified constraints] + in GHC.Tc.Solver.Canonical + +Note [Flatten when discharging CFunEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have the following scenario (#16512): + +type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where + LV (a ': as) b = a -> LV as b + +[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan) +[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan) +[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan) + +We start with w1. Because LV is injective, we wish to see if the RHS of the +equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an +fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs. +That performs the match, but it allows a type family application (such as the +LV in the RHS of the equation) to match with anything. (See "Injective type +families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which +means we can improve as0 (and b, but that's not interesting here). However, +because the RHS of w1 can't see through fmv2 (we have no way of looking up a +LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough), +we invent a new unification variable here. We thus get (as0 := a : as1). +Rewriting: + +[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1 +[WD] w2 :: fmv1 ~ (a -> fmv2) +[WD] w3 :: LV (a : as1) b ~ fmv2 + +We can now reduce both CFunEqCans, using the equation for LV. We get + +[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b) + +Now we decompose (and flatten) to + +[WD] w4 :: LV as1 (a -> b) ~ fmv3 +[WD] w5 :: fmv3 ~ (a -> fmv1) +[WD] w6 :: LV as1 b ~ fmv4 + +which is exactly where we started. These goals really are insoluble, but +we would prefer not to loop. We thus need to find a way to bump the reduction +depth, so that we can detect the loop and abort. + +The key observation is that we are performing a reduction. We thus wish +to bump the level when discharging a CFunEqCan. Where does this bumped +level go, though? It can't just go on the reduct, as that's a type. Instead, +it must go on any CFunEqCans produced after flattening. We thus flatten +when discharging, making sure that the level is bumped in the new +fun-eqs. The flattening happens in reduce_top_fun_eq and the level +is bumped when setting up the FlatM monad in GHC.Tc.Solver.Flatten.runFlatten. +(This bumping will happen for call sites other than this one, but that +makes sense -- any constraints emitted by the flattener are offshoots +the work item and should have a higher level. We don't have any test +cases that require the bumping in this other cases, but it's convenient +and causes no harm to bump at every flatten.) + +Test case: typecheck/should_fail/T16512a + +-} + +-------------------- +doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) +doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc + , cc_tyargs = args, cc_fsk = fsk }) + + | fsk `elemVarSet` tyCoVarsOfTypes args + = no_reduction -- See Note [FunEq occurs-check principle] + + | otherwise -- Note [Reduction for Derived CFunEqCans] + = do { match_res <- matchFam fam_tc args + -- Look up in top-level instances, or built-in axiom + -- See Note [MATCHING-SYNONYMS] + ; case match_res of + Nothing -> no_reduction + Just match_info -> reduce_top_fun_eq old_ev fsk match_info } + where + no_reduction + = do { improveTopFunEqs old_ev fam_tc args fsk + ; continueWith work_item } + +doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) + +reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType) + -> TcS (StopOrContinue Ct) +-- We have found an applicable top-level axiom: use it to reduce +-- Precondition: fsk is not free in rhs_ty +-- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev +reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty) + | not (isDerived old_ev) -- Precondition of shortCutReduction + , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty + , isTypeFamilyTyCon tc + , tc_args `lengthIs` tyConArity tc -- Short-cut + = -- RHS is another type-family application + -- Try shortcut; see Note [Top-level reductions for type functions] + do { shortCutReduction old_ev fsk ax_co tc tc_args + ; stopWith old_ev "Fun/Top (shortcut)" } + + | otherwise + = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) + , ppr old_ev $$ ppr rhs_ty ) + -- Guaranteed by Note [FunEq occurs-check principle] + do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty + -- flatten_co :: rhs_xi ~ rhs_ty + -- See Note [Flatten when discharging CFunEqCan] + ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co + ; dischargeFunEq old_ev fsk total_co rhs_xi + ; traceTcS "doTopReactFunEq" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr ax_co ] + ; stopWith old_ev "Fun/Top" } + +improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS () +-- See Note [FunDep and implicit parameter reactions] +improveTopFunEqs ev fam_tc args fsk + | isGiven ev -- See Note [No FunEq improvement for Givens] + || not (isImprovable ev) + = return () + + | otherwise + = do { fam_envs <- getFamInstEnvs + ; rhs <- rewriteTyVar fsk + ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs + ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs + , ppr eqns ]) + ; mapM_ (unifyDerived loc Nominal) eqns } + where + loc = bumpCtLocDepth (ctEvLoc ev) + -- ToDo: this location is wrong; it should be FunDepOrigin2 + -- See #14778 + +improve_top_fun_eqs :: FamInstEnvs + -> TyCon -> [TcType] -> TcType + -> TcS [TypeEqn] +improve_top_fun_eqs fam_envs fam_tc args rhs_ty + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = return (sfInteractTop ops args rhs_ty) + + -- see Note [Type inference for type families with injectivity] + | isOpenTypeFamilyTyCon fam_tc + , Injective injective_args <- tyConInjectivityInfo fam_tc + , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc + = -- it is possible to have several compatible equations in an open type + -- family but we only want to derive equalities from one such equation. + do { let improvs = buildImprovementData fam_insts + fi_tvs fi_tys fi_rhs (const Nothing) + + ; traceTcS "improve_top_fun_eqs2" (ppr improvs) + ; concatMapM (injImproveEqns injective_args) $ + take 1 improvs } + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc + , Injective injective_args <- tyConInjectivityInfo fam_tc + = concatMapM (injImproveEqns injective_args) $ + buildImprovementData (fromBranches (co_ax_branches ax)) + cab_tvs cab_lhs cab_rhs Just + + | otherwise + = return [] + + where + buildImprovementData + :: [a] -- axioms for a TF (FamInst or CoAxBranch) + -> (a -> [TyVar]) -- get bound tyvars of an axiom + -> (a -> [Type]) -- get LHS of an axiom + -> (a -> Type) -- get RHS of an axiom + -> (a -> Maybe CoAxBranch) -- Just => apartness check required + -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )] + -- Result: + -- ( [arguments of a matching axiom] + -- , RHS-unifying substitution + -- , axiom variables without substitution + -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] ) + buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap = + [ (ax_args, subst, unsubstTvs, wrap axiom) + | axiom <- axioms + , let ax_args = axiomLHS axiom + ax_rhs = axiomRHS axiom + ax_tvs = axiomTVs axiom + , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty] + , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) + unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ] + -- The order of unsubstTvs is important; it must be + -- in telescope order e.g. (k:*) (a:k) + + injImproveEqns :: [Bool] + -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch) + -> TcS [TypeEqn] + injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) + = do { subst <- instFlexiX subst unsubstTvs + -- If the current substitution bind [k -> *], and + -- one of the un-substituted tyvars is (a::k), we'd better + -- be sure to apply the current substitution to a's kind. + -- Hence instFlexiX. #13135 was an example. + + ; return [ Pair (substTyUnchecked subst ax_arg) arg + -- NB: the ax_arg part is on the left + -- see Note [Improvement orientation] + | case cabr of + Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' + _ -> True + , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } + + +shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion + -> TyCon -> [TcType] -> TcS () +-- See Note [Top-level reductions for type functions] +-- Previously, we flattened the tc_args here, but there's no need to do so. +-- And, if we did, this function would have all the complication of +-- GHC.Tc.Solver.Canonical.canCFunEqCan. See Note [canCFunEqCan] +shortCutReduction old_ev fsk ax_co fam_tc tc_args + = ASSERT( ctEvEqRel old_ev == NomEq) + -- ax_co :: F args ~ G tc_args + -- old_ev :: F args ~ fsk + do { new_ev <- case ctEvFlavour old_ev of + Given -> newGivenEvVar deeper_loc + ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) + , evCoercion (mkTcSymCo ax_co + `mkTcTransCo` ctEvCoercion old_ev) ) + + Wanted {} -> + -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst + do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal + (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) + ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co + ; return new_ev } + + Derived -> pprPanic "shortCutReduction" (ppr old_ev) + + ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc + , cc_tyargs = tc_args, cc_fsk = fsk } + ; updWorkListTcS (extendWorkListFunEq new_ct) } + where + deeper_loc = bumpCtLocDepth (ctEvLoc old_ev) + +{- Note [Top-level reductions for type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c.f. Note [The flattening story] in GHC.Tc.Solver.Flatten + +Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom. +Here is what we do, in four cases: + +* Wanteds: general firing rule + (work item) [W] x : F tys ~ fmv + instantiate axiom: ax_co : F tys ~ rhs + + Then: + Discharge fmv := rhs + Discharge x := ax_co ; sym x2 + This is *the* way that fmv's get unified; even though they are + "untouchable". + + NB: Given Note [FunEq occurs-check principle], fmv does not appear + in tys, and hence does not appear in the instantiated RHS. So + the unification can't make an infinite type. + +* Wanteds: short cut firing rule + Applies when the RHS of the axiom is another type-function application + (work item) [W] x : F tys ~ fmv + instantiate axiom: ax_co : F tys ~ G rhs_tys + + It would be a waste to create yet another fmv for (G rhs_tys). + Instead (shortCutReduction): + - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) + - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv) + - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan) + - Discharge x := ax_co ; G cos ; x2 + +* Givens: general firing rule + (work item) [G] g : F tys ~ fsk + instantiate axiom: ax_co : F tys ~ rhs + + Now add non-canonical given (since rhs is not flat) + [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical) + +* Givens: short cut firing rule + Applies when the RHS of the axiom is another type-function application + (work item) [G] g : F tys ~ fsk + instantiate axiom: ax_co : F tys ~ G rhs_tys + + It would be a waste to create yet another fsk for (G rhs_tys). + Instead (shortCutReduction): + - Flatten rhs_tys: flat_cos : tys ~ flat_tys + - Add new Canonical given + [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan) + +Note [FunEq occurs-check principle] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I have spent a lot of time finding a good way to deal with +CFunEqCan constraints like + F (fuv, a) ~ fuv +where flatten-skolem occurs on the LHS. Now in principle we +might may progress by doing a reduction, but in practice its +hard to find examples where it is useful, and easy to find examples +where we fall into an infinite reduction loop. A rule that works +very well is this: + + *** FunEq occurs-check principle *** + + Do not reduce a CFunEqCan + F tys ~ fsk + if fsk appears free in tys + Instead we treat it as stuck. + +Examples: + +* #5837 has [G] a ~ TF (a,Int), with an instance + type instance TF (a,b) = (TF a, TF b) + This readily loops when solving givens. But with the FunEq occurs + check principle, it rapidly gets stuck which is fine. + +* #12444 is a good example, explained in comment:2. We have + type instance F (Succ x) = Succ (F x) + [W] alpha ~ Succ (F alpha) + If we allow the reduction to happen, we get an infinite loop + +Note [Cached solved FunEqs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When trying to solve, say (FunExpensive big-type ~ ty), it's important +to see if we have reduced (FunExpensive big-type) before, lest we +simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover +we must use `funEqCanDischarge` because both uses might (say) be Wanteds, +and we *still* want to save the re-computation. + +Note [MATCHING-SYNONYMS] +~~~~~~~~~~~~~~~~~~~~~~~~ +When trying to match a dictionary (D tau) to a top-level instance, or a +type family equation (F taus_1 ~ tau_2) to a top-level family instance, +we do *not* need to expand type synonyms because the matcher will do that for us. + +Note [Improvement orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A very delicate point is the orientation of derived equalities +arising from injectivity improvement (#12522). Suppose we have + type family F x = t | t -> x + type instance F (a, Int) = (Int, G a) +where G is injective; and wanted constraints + + [W] TF (alpha, beta) ~ fuv + [W] fuv ~ (Int, ) + +The injectivity will give rise to derived constraints + + [D] gamma1 ~ alpha + [D] Int ~ beta + +The fresh unification variable gamma1 comes from the fact that we +can only do "partial improvement" here; see Section 5.2 of +"Injective type families for Haskell" (HS'15). + +Now, it's very important to orient the equations this way round, +so that the fresh unification variable will be eliminated in +favour of alpha. If we instead had + [D] alpha ~ gamma1 +then we would unify alpha := gamma1; and kick out the wanted +constraint. But when we grough it back in, it'd look like + [W] TF (gamma1, beta) ~ fuv +and exactly the same thing would happen again! Infinite loop. + +This all seems fragile, and it might seem more robust to avoid +introducing gamma1 in the first place, in the case where the +actual argument (alpha, beta) partly matches the improvement +template. But that's a bit tricky, esp when we remember that the +kinds much match too; so it's easier to let the normal machinery +handle it. Instead we are careful to orient the new derived +equality with the template on the left. Delicate, but it works. + +Note [No FunEq improvement for Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do improvements (injectivity etc) for Givens. Why? + +* It generates Derived constraints on skolems, which don't do us + much good, except perhaps identify inaccessible branches. + (They'd be perfectly valid though.) + +* For type-nat stuff the derived constraints include type families; + e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this, + we'll generate a Derived/Wanted CFunEqCan; and, since the same + InertCans (after solving Givens) are used for each iteration, that + massively confused the unflattening step (GHC.Tc.Solver.Flatten.unflatten). + + In fact it led to some infinite loops: + indexed-types/should_compile/T10806 + indexed-types/should_compile/T10507 + polykinds/T10742 + +Note [Reduction for Derived CFunEqCans] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You may wonder if it's important to use top-level instances to +simplify [D] CFunEqCan's. But it is. Here's an example (T10226). + + type instance F Int = Int + type instance FInv Int = Int + +Suppose we have to solve + [WD] FInv (F alpha) ~ alpha + [WD] F alpha ~ Int + + --> flatten + [WD] F alpha ~ fuv0 + [WD] FInv fuv0 ~ fuv1 -- (A) + [WD] fuv1 ~ alpha + [WD] fuv0 ~ Int -- (B) + + --> Rewwrite (A) with (B), splitting it + [WD] F alpha ~ fuv0 + [W] FInv fuv0 ~ fuv1 + [D] FInv Int ~ fuv1 -- (C) + [WD] fuv1 ~ alpha + [WD] fuv0 ~ Int + + --> Reduce (C) with top-level instance + **** This is the key step *** + [WD] F alpha ~ fuv0 + [W] FInv fuv0 ~ fuv1 + [D] fuv1 ~ Int -- (D) + [WD] fuv1 ~ alpha -- (E) + [WD] fuv0 ~ Int + + --> Rewrite (D) with (E) + [WD] F alpha ~ fuv0 + [W] FInv fuv0 ~ fuv1 + [D] alpha ~ Int -- (F) + [WD] fuv1 ~ alpha + [WD] fuv0 ~ Int + + --> unify (F) alpha := Int, and that solves it + +Another example is indexed-types/should_compile/T10634 +-} + +{- ******************************************************************* +* * + Top-level reaction for class constraints (CDictCan) +* * +**********************************************************************-} + +doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) +-- Try to use type-class instance declarations to simplify the constraint +doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls + , cc_tyargs = xis }) + | isGiven ev -- Never use instances for Given constraints + = do { try_fundep_improvement + ; continueWith work_item } + + | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached + = do { setEvBindIfWanted ev (ctEvTerm solved_ev) + ; stopWith ev "Dict/Top (cached)" } + + | otherwise -- Wanted or Derived, but not cached + = do { dflags <- getDynFlags + ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc + ; case lkup_res of + OneInst { cir_what = what } + -> do { insertSafeOverlapFailureTcS what work_item + ; addSolvedDict what ev cls xis + ; chooseInstance work_item lkup_res } + _ -> -- NoInstance or NotSure + do { when (isImprovable ev) $ + try_fundep_improvement + ; continueWith work_item } } + where + dict_pred = mkClassPred cls xis + dict_loc = ctEvLoc ev + dict_origin = ctLocOrigin dict_loc + + -- We didn't solve it; so try functional dependencies with + -- the instance environment, and return + -- See also Note [Weird fundeps] + try_fundep_improvement + = do { traceTcS "try_fundeps" (ppr work_item) + ; instEnvs <- getInstEnvs + ; emitFunDepDeriveds $ + improveFromInstEnv instEnvs mk_ct_loc dict_pred } + + mk_ct_loc :: PredType -- From instance decl + -> SrcSpan -- also from instance deol + -> CtLoc + mk_ct_loc inst_pred inst_loc + = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin + inst_pred inst_loc } + +doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) + + +chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct) +chooseInstance work_item + (OneInst { cir_new_theta = theta + , cir_what = what + , cir_mk_ev = mk_ev }) + = do { traceTcS "doTopReact/found instance for" $ ppr ev + ; deeper_loc <- checkInstanceOK loc what pred + ; if isDerived ev then finish_derived deeper_loc theta + else finish_wanted deeper_loc theta mk_ev } + where + ev = ctEvidence work_item + pred = ctEvPred ev + loc = ctEvLoc ev + + finish_wanted :: CtLoc -> [TcPredType] + -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct) + -- Precondition: evidence term matches the predicate workItem + finish_wanted loc theta mk_ev + = do { evb <- getTcEvBindsVar + ; if isCoEvBindsVar evb + then -- See Note [Instances in no-evidence implications] + continueWith work_item + else + do { evc_vars <- mapM (newWanted loc) theta + ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (freshGoals evc_vars) + ; stopWith ev "Dict/Top (solved wanted)" } } + + finish_derived loc theta + = -- Use type-class instances for Deriveds, in the hope + -- of generating some improvements + -- C.f. Example 3 of Note [The improvement story] + -- It's easy because no evidence is involved + do { emitNewDeriveds loc theta + ; traceTcS "finish_derived" (ppr (ctl_depth loc)) + ; stopWith ev "Dict/Top (solved derived)" } + +chooseInstance work_item lookup_res + = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) + +checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc +-- Check that it's OK to use this insstance: +-- (a) the use is well staged in the Template Haskell sense +-- (b) we have not recursed too deep +-- Returns the CtLoc to used for sub-goals +checkInstanceOK loc what pred + = do { checkWellStagedDFun loc what pred + ; checkReductionDepth deeper_loc pred + ; return deeper_loc } + where + deeper_loc = zap_origin (bumpCtLocDepth loc) + origin = ctLocOrigin loc + + zap_origin loc -- After applying an instance we can set ScOrigin to + -- infinity, so that prohibitedSuperClassSolve never fires + | ScOrigin {} <- origin + = setCtLocOrigin loc (ScOrigin infinity) + | otherwise + = loc + +{- Note [Instances in no-evidence implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #15290 we had + [G] forall p q. Coercible p q => Coercible (m p) (m q)) + [W] forall a. m (Int, IntStateT m a) + ~R# + m (Int, StateT Int m a) + +The Given is an ordinary quantified constraint; the Wanted is an implication +equality that arises from + [W] (forall a. t1) ~R# (forall a. t2) + +But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) +we can't generate any term evidence. So we can't actually use that +lovely quantified constraint. Alas! + +This test arranges to ignore the instance-based solution under these +(rare) circumstances. It's sad, but I really don't see what else we can do. +-} + + +matchClassInst :: DynFlags -> InertSet + -> Class -> [Type] + -> CtLoc -> TcS ClsInstResult +matchClassInst dflags inerts clas tys loc +-- First check whether there is an in-scope Given that could +-- match this constraint. In that case, do not use any instance +-- whether top level, or local quantified constraints. +-- ee Note [Instance and Given overlap] + | not (xopt LangExt.IncoherentInstances dflags) + , not (naturallyCoherentClass clas) + , let matchable_givens = matchableGivens loc pred inerts + , not (isEmptyBag matchable_givens) + = do { traceTcS "Delaying instance application" $ + vcat [ text "Work item=" <+> pprClassPred clas tys + , text "Potential matching givens:" <+> ppr matchable_givens ] + ; return NotSure } + + | otherwise + = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' + ; local_res <- matchLocalInst pred loc + ; case local_res of + OneInst {} -> -- See Note [Local instances and incoherence] + do { traceTcS "} matchClassInst local match" $ ppr local_res + ; return local_res } + + NotSure -> -- In the NotSure case for local instances + -- we don't want to try global instances + do { traceTcS "} matchClassInst local not sure" empty + ; return local_res } + + NoInstance -- No local instances, so try global ones + -> do { global_res <- matchGlobalInst dflags False clas tys + ; traceTcS "} matchClassInst global result" $ ppr global_res + ; return global_res } } + where + pred = mkClassPred clas tys + +-- | If a class is "naturally coherent", then we needn't worry at all, in any +-- way, about overlapping/incoherent instances. Just solve the thing! +-- See Note [Naturally coherent classes] +-- See also Note [The equality class story] in "GHC.Builtin.Types.Prim". +naturallyCoherentClass :: Class -> Bool +naturallyCoherentClass cls + = isCTupleClass cls + || cls `hasKey` heqTyConKey + || cls `hasKey` eqTyConKey + || cls `hasKey` coercibleTyConKey + + +{- Note [Instance and Given overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example, from the OutsideIn(X) paper: + instance P x => Q [x] + instance (x ~ y) => R y [x] + + wob :: forall a b. (Q [b], R b a) => a -> Int + + g :: forall a. Q [a] => [a] -> Int + g x = wob x + +From 'g' we get the implication constraint: + forall a. Q [a] => (Q [beta], R beta [a]) +If we react (Q [beta]) with its top-level axiom, we end up with a +(P beta), which we have no way of discharging. On the other hand, +if we react R beta [a] with the top-level we get (beta ~ a), which +is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is +now solvable by the given Q [a]. + +The partial solution is that: + In matchClassInst (and thus in topReact), we return a matching + instance only when there is no Given in the inerts which is + unifiable to this particular dictionary. + + We treat any meta-tyvar as "unifiable" for this purpose, + *including* untouchable ones. But not skolems like 'a' in + the implication constraint above. + +The end effect is that, much as we do for overlapping instances, we +delay choosing a class instance if there is a possibility of another +instance OR a given to match our constraint later on. This fixes +#4981 and #5002. + +Other notes: + +* The check is done *first*, so that it also covers classes + with built-in instance solving, such as + - constraint tuples + - natural numbers + - Typeable + +* Flatten-skolems: we do not treat a flatten-skolem as unifiable + for this purpose. + E.g. f :: Eq (F a) => [a] -> [a] + f xs = ....(xs==xs)..... + Here we get [W] Eq [a], and we don't want to refrain from solving + it because of the given (Eq (F a)) constraint! + +* The given-overlap problem is arguably not easy to appear in practice + due to our aggressive prioritization of equality solving over other + constraints, but it is possible. I've added a test case in + typecheck/should-compile/GivenOverlapping.hs + +* Another "live" example is #10195; another is #10177. + +* We ignore the overlap problem if -XIncoherentInstances is in force: + see #6002 for a worked-out example where this makes a + difference. + +* Moreover notice that our goals here are different than the goals of + the top-level overlapping checks. There we are interested in + validating the following principle: + + If we inline a function f at a site where the same global + instance environment is available as the instance environment at + the definition site of f then we should get the same behaviour. + + But for the Given Overlap check our goal is just related to completeness of + constraint solving. + +* The solution is only a partial one. Consider the above example with + g :: forall a. Q [a] => [a] -> Int + g x = let v = wob x + in v + and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most + general type for 'v'. When generalising v's type we'll simplify its + Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we + will use the instance declaration after all. #11948 was a case + in point. + +All of this is disgustingly delicate, so to discourage people from writing +simplifiable class givens, we warn about signatures that contain them; +see GHC.Tc.Validity Note [Simplifiable given constraints]. + +Note [Naturally coherent classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A few built-in classes are "naturally coherent". This term means that +the "instance" for the class is bidirectional with its superclass(es). +For example, consider (~~), which behaves as if it was defined like +this: + class a ~# b => a ~~ b + instance a ~# b => a ~~ b +(See Note [The equality types story] in GHC.Builtin.Types.Prim.) + +Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2, +without worrying about Note [Instance and Given overlap]. Why? Because +if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and +so the reduction of the [W] constraint does not risk losing any solutions. + +On the other hand, it can be fatal to /fail/ to reduce such +equalities, on the grounds of Note [Instance and Given overlap], +because many good things flow from [W] t1 ~# t2. + +The same reasoning applies to + +* (~~) heqTyCOn +* (~) eqTyCon +* Coercible coercibleTyCon + +And less obviously to: + +* Tuple classes. For reasons described in GHC.Tc.Solver.Monad + Note [Tuples hiding implicit parameters], we may have a constraint + [W] (?x::Int, C a) + with an exactly-matching Given constraint. We must decompose this + tuple and solve the components separately, otherwise we won't solve + it at all! It is perfectly safe to decompose it, because again the + superclasses invert the instance; e.g. + class (c1, c2) => (% c1, c2 %) + instance (c1, c2) => (% c1, c2 %) + Example in #14218 + +Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b + +PS: the term "naturally coherent" doesn't really seem helpful. +Perhaps "invertible" or something? I left it for now though. + +Note [Local instances and incoherence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) + => c b -> Bool + f x = x==x + +We get [W] Eq (c b), and we must use the local instance to solve it. + +BUT that wanted also unifies with the top-level Eq [a] instance, +and Eq (Maybe a) etc. We want the local instance to "win", otherwise +we can't solve the wanted at all. So we mark it as Incohherent. +According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll +make it win even if there are other instances that unify. + +Moreover this is not a hack! The evidence for this local instance +will be constructed by GHC at a call site... from the very instances +that unify with it here. It is not like an incoherent user-written +instance which might have utterly different behaviour. + +Consdider f :: Eq a => blah. If we have [W] Eq a, we certainly +get it from the Eq a context, without worrying that there are +lots of top-level instances that unify with [W] Eq a! We'll use +those instances to build evidence to pass to f. That's just the +nullary case of what's happening here. +-} + +matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult +-- Look up the predicate in Given quantified constraints, +-- which are effectively just local instance declarations. +matchLocalInst pred loc + = do { ics <- getInertCans + ; case match_local_inst (inert_insts ics) of + ([], False) -> do { traceTcS "No local instance for" (ppr pred) + ; return NoInstance } + ([(dfun_ev, inst_tys)], unifs) + | not unifs + -> do { let dfun_id = ctEvEvId dfun_ev + ; (tys, theta) <- instDFunType dfun_id inst_tys + ; let result = OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_what = LocalInstance } + ; traceTcS "Local inst found:" (ppr result) + ; return result } + _ -> do { traceTcS "Multiple local instances for" (ppr pred) + ; return NotSure }} + where + pred_tv_set = tyCoVarsOfType pred + + match_local_inst :: [QCInst] + -> ( [(CtEvidence, [DFunInstType])] + , Bool ) -- True <=> Some unify but do not match + match_local_inst [] + = ([], False) + match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred + , qci_ev = ev }) + : qcis) + | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) + , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) + emptyTvSubstEnv qpred pred + , let match = (ev, map (lookupVarEnv tv_subst) qtvs) + = (match:matches, unif) + + | otherwise + = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred) + , ppr qci $$ ppr pred ) + -- ASSERT: unification relies on the + -- quantified variables being fresh + (matches, unif || this_unif) + where + qtv_set = mkVarSet qtvs + this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc + (matches, unif) = match_local_inst qcis diff --git a/GHC/Tc/Solver/Monad.hs b/GHC/Tc/Solver/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Monad.hs @@ -0,0 +1,3665 @@ +{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Type definitions for the constraint solver +module GHC.Tc.Solver.Monad ( + + -- The work list + WorkList(..), isEmptyWorkList, emptyWorkList, + extendWorkListNonEq, extendWorkListCt, + extendWorkListCts, extendWorkListEq, extendWorkListFunEq, + appendWorkList, + selectNextWorkItem, + workListSize, workListWantedCount, + getWorkList, updWorkListTcS, pushLevelNoWorkList, + + -- The TcS monad + TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, + failTcS, warnTcS, addErrTcS, + runTcSEqualities, + nestTcS, nestImplicTcS, setEvBindsTcS, + emitImplicationTcS, emitTvImplicationTcS, + + runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive, + matchGlobalInst, TcM.ClsInstResult(..), + + QCInst(..), + + -- Tracing etc + panicTcS, traceTcS, + traceFireTcS, bumpStepCountTcS, csTraceTcS, + wrapErrTcS, wrapWarnTcS, + + -- Evidence creation and transformation + MaybeNew(..), freshGoals, isFresh, getEvExpr, + + newTcEvBinds, newNoTcEvBinds, + newWantedEq, newWantedEq_SI, emitNewWantedEq, + newWanted, newWanted_SI, newWantedEvVar, + newWantedNC, newWantedEvVarNC, + newDerivedNC, + newBoundEvVarId, + unifyTyVar, unflattenFmv, reportUnifications, + setEvBind, setWantedEq, + setWantedEvTerm, setEvBindIfWanted, + newEvVar, newGivenEvVar, newGivenEvVars, + emitNewDeriveds, emitNewDerivedEq, + checkReductionDepth, + getSolvedDicts, setSolvedDicts, + + getInstEnvs, getFamInstEnvs, -- Getting the environments + getTopEnv, getGblEnv, getLclEnv, + getTcEvBindsVar, getTcLevel, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + tcLookupClass, tcLookupId, + + -- Inerts + InertSet(..), InertCans(..), + updInertTcS, updInertCans, updInertDicts, updInertIrreds, + getNoGivenEqs, setInertCans, + getInertEqs, getInertCans, getInertGivens, + getInertInsols, + getTcSInerts, setTcSInerts, + matchableGivens, prohibitedSuperClassSolve, mightMatchLater, + getUnsolvedInerts, + removeInertCts, getPendingGivenScs, + addInertCan, insertFunEq, addInertForAll, + emitWorkNC, emitWork, + isImprovable, + + -- The Model + kickOutAfterUnification, + + -- Inert Safe Haskell safe-overlap failures + addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, + getSafeOverlapFailures, + + -- Inert CDictCans + DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict, + addDictsByClass, delDict, foldDicts, filterDicts, findDict, + + -- Inert CTyEqCans + EqualCtList, findTyEqs, foldTyEqs, isInInertEqs, + lookupInertTyVar, + + -- Inert solved dictionaries + addSolvedDict, lookupSolvedDict, + + -- Irreds + foldIrreds, + + -- The flattening cache + lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems + dischargeFunEq, pprKicked, + + -- Inert CFunEqCans + updInertFunEqs, findFunEq, + findFunEqsByTyCon, + + instDFunType, -- Instantiation + + -- MetaTyVars + newFlexiTcSTy, instFlexi, instFlexiX, + cloneMetaTyVar, demoteUnfilledFmv, + tcInstSkolTyVarsX, + + TcLevel, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, + zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, + zonkTyCoVarsAndFVList, + zonkSimples, zonkWC, + zonkTyCoVarKind, + + -- References + newTcRef, readTcRef, writeTcRef, updTcRef, + + -- Misc + getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, + matchFam, matchFamTcM, + checkWellStagedDFun, + pprEq -- Smaller utils, re-exported from TcM + -- TODO (DV): these are only really used in the + -- instance matcher in GHC.Tc.Solver. I am wondering + -- if the whole instance matcher simply belongs + -- here +) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Types + +import qualified GHC.Tc.Utils.Instantiate as TcM +import GHC.Core.InstEnv +import GHC.Tc.Instance.Family as FamInst +import GHC.Core.FamInstEnv + +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) +import qualified GHC.Tc.Utils.Env as TcM + ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) +import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) +import GHC.Tc.Utils.TcType +import GHC.Driver.Session +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Unify + +import GHC.Utils.Error +import GHC.Tc.Types.Evidence +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Tc.Errors ( solverDepthErrorTcS ) + +import GHC.Types.Name +import GHC.Unit.Module ( HasModule, getModule ) +import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) +import qualified GHC.Rename.Env as TcM +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Utils.Outputable +import GHC.Data.Bag as Bag +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Data.Maybe + +import GHC.Core.Map +import Control.Monad +import GHC.Utils.Monad +import Data.IORef +import Data.List ( partition, mapAccumL ) + +#if defined(DEBUG) +import GHC.Data.Graph.Directed +import GHC.Types.Unique.Set +#endif + +{- +************************************************************************ +* * +* Worklists * +* Canonical and non-canonical constraints that the simplifier has to * +* work on. Including their simplification depths. * +* * +* * +************************************************************************ + +Note [WorkList priorities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A WorkList contains canonical and non-canonical items (of all flavours). +Notice that each Ct now has a simplification depth. We may +consider using this depth for prioritization as well in the future. + +As a simple form of priority queue, our worklist separates out + +* equalities (wl_eqs); see Note [Prioritise equalities] +* type-function equalities (wl_funeqs) +* all the rest (wl_rest) + +Note [Prioritise equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important to process equalities /first/: + +* (Efficiency) The general reason to do so is that if we process a + class constraint first, we may end up putting it into the inert set + and then kicking it out later. That's extra work compared to just + doing the equality first. + +* (Avoiding fundep iteration) As #14723 showed, it's possible to + get non-termination if we + - Emit the Derived fundep equalities for a class constraint, + generating some fresh unification variables. + - That leads to some unification + - Which kicks out the class constraint + - Which isn't solved (because there are still some more Derived + equalities in the work-list), but generates yet more fundeps + Solution: prioritise derived equalities over class constraints + +* (Class equalities) We need to prioritise equalities even if they + are hidden inside a class constraint; + see Note [Prioritise class equalities] + +* (Kick-out) We want to apply this priority scheme to kicked-out + constraints too (see the call to extendWorkListCt in kick_out_rewritable + E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become + homo-kinded when kicked out, and hence we want to prioritise it. + +* (Derived equalities) Originally we tried to postpone processing + Derived equalities, in the hope that we might never need to deal + with them at all; but in fact we must process Derived equalities + eagerly, partly for the (Efficiency) reason, and more importantly + for (Avoiding fundep iteration). + +Note [Prioritise class equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prioritise equalities in the solver (see selectWorkItem). But class +constraints like (a ~ b) and (a ~~ b) are actually equalities too; +see Note [The equality types story] in GHC.Builtin.Types.Prim. + +Failing to prioritise these is inefficient (more kick-outs etc). +But, worse, it can prevent us spotting a "recursive knot" among +Wanted constraints. See comment:10 of #12734 for a worked-out +example. + +So we arrange to put these particular class constraints in the wl_eqs. + + NB: since we do not currently apply the substitution to the + inert_solved_dicts, the knot-tying still seems a bit fragile. + But this makes it better. + +-} + +-- See Note [WorkList priorities] +data WorkList + = WL { wl_eqs :: [Ct] -- CTyEqCan, CDictCan, CIrredCan + -- Given, Wanted, and Derived + -- Contains both equality constraints and their + -- class-level variants (a~b) and (a~~b); + -- See Note [Prioritise equalities] + -- See Note [Prioritise class equalities] + + , wl_funeqs :: [Ct] + + , wl_rest :: [Ct] + + , wl_implics :: Bag Implication -- See Note [Residual implications] + } + +appendWorkList :: WorkList -> WorkList -> WorkList +appendWorkList + (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1 + , wl_implics = implics1 }) + (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2 + , wl_implics = implics2 }) + = WL { wl_eqs = eqs1 ++ eqs2 + , wl_funeqs = funeqs1 ++ funeqs2 + , wl_rest = rest1 ++ rest2 + , wl_implics = implics1 `unionBags` implics2 } + +workListSize :: WorkList -> Int +workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) + = length eqs + length funeqs + length rest + +workListWantedCount :: WorkList -> Int +-- Count the things we need to solve +-- excluding the insolubles (c.f. inert_count) +workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest }) + = count isWantedCt eqs + count is_wanted rest + where + is_wanted ct + | CIrredCan { cc_status = InsolubleCIS } <- ct + = False + | otherwise + = isWantedCt ct + +extendWorkListEq :: Ct -> WorkList -> WorkList +extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } + +extendWorkListFunEq :: Ct -> WorkList -> WorkList +extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl } + +extendWorkListNonEq :: Ct -> WorkList -> WorkList +-- Extension by non equality +extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } + +extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList +extendWorkListDeriveds evs wl + = extendWorkListCts (map mkNonCanonical evs) wl + +extendWorkListImplic :: Implication -> WorkList -> WorkList +extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } + +extendWorkListCt :: Ct -> WorkList -> WorkList +-- Agnostic +extendWorkListCt ct wl + = case classifyPredType (ctPred ct) of + EqPred NomEq ty1 _ + | Just tc <- tcTyConAppTyCon_maybe ty1 + , isTypeFamilyTyCon tc + -> extendWorkListFunEq ct wl + + EqPred {} + -> extendWorkListEq ct wl + + ClassPred cls _ -- See Note [Prioritise class equalities] + | isEqPredClass cls + -> extendWorkListEq ct wl + + _ -> extendWorkListNonEq ct wl + +extendWorkListCts :: [Ct] -> WorkList -> WorkList +-- Agnostic +extendWorkListCts cts wl = foldr extendWorkListCt wl cts + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs + , wl_rest = rest, wl_implics = implics }) + = null eqs && null rest && null funeqs && isEmptyBag implics + +emptyWorkList :: WorkList +emptyWorkList = WL { wl_eqs = [], wl_rest = [] + , wl_funeqs = [], wl_implics = emptyBag } + +selectWorkItem :: WorkList -> Maybe (Ct, WorkList) +-- See Note [Prioritise equalities] +selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs + , wl_rest = rest }) + | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) + | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes }) + | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) + | otherwise = Nothing + +getWorkList :: TcS WorkList +getWorkList = do { wl_var <- getTcSWorkListRef + ; wrapTcS (TcM.readTcRef wl_var) } + +selectNextWorkItem :: TcS (Maybe Ct) +-- Pick which work item to do next +-- See Note [Prioritise equalities] +selectNextWorkItem + = do { wl_var <- getTcSWorkListRef + ; wl <- readTcRef wl_var + ; case selectWorkItem wl of { + Nothing -> return Nothing ; + Just (ct, new_wl) -> + do { -- checkReductionDepth (ctLoc ct) (ctPred ct) + -- This is done by GHC.Tc.Solver.Interact.chooseInstance + ; writeTcRef wl_var new_wl + ; return (Just ct) } } } + +-- Pretty printing +instance Outputable WorkList where + ppr (WL { wl_eqs = eqs, wl_funeqs = feqs + , wl_rest = rest, wl_implics = implics }) + = text "WL" <+> (braces $ + vcat [ ppUnless (null eqs) $ + text "Eqs =" <+> vcat (map ppr eqs) + , ppUnless (null feqs) $ + text "Funeqs =" <+> vcat (map ppr feqs) + , ppUnless (null rest) $ + text "Non-eqs =" <+> vcat (map ppr rest) + , ppUnless (isEmptyBag implics) $ + ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) + (text "(Implics omitted)") + ]) + + +{- ********************************************************************* +* * + InertSet: the inert set +* * +* * +********************************************************************* -} + +data InertSet + = IS { inert_cans :: InertCans + -- Canonical Given, Wanted, Derived + -- Sometimes called "the inert set" + + , inert_fsks :: [(TcTyVar, TcType)] + -- A list of (fsk, ty) pairs; we add one element when we flatten + -- a function application in a Given constraint, creating + -- a new fsk in newFlattenSkolem. When leaving a nested scope, + -- unflattenGivens unifies fsk := ty + -- + -- We could also get this info from inert_funeqs, filtered by + -- level, but it seems simpler and more direct to capture the + -- fsk as we generate them. + + , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) + -- See Note [Type family equations] + -- If F tys :-> (co, rhs, flav), + -- then co :: F tys ~ rhs + -- flav is [G] or [WD] + -- + -- Just a hash-cons cache for use when flattening only + -- These include entirely un-processed goals, so don't use + -- them to solve a top-level goal, else you may end up solving + -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache + -- when allocating a new flatten-skolem. + -- Not necessarily inert wrt top-level equations (or inert_cans) + + -- NB: An ExactFunEqMap -- this doesn't match via loose types! + + , inert_solved_dicts :: DictMap CtEvidence + -- All Wanteds, of form ev :: C t1 .. tn + -- See Note [Solved dictionaries] + -- and Note [Do not add superclasses of solved dictionaries] + } + +instance Outputable InertSet where + ppr (IS { inert_cans = ics + , inert_fsks = ifsks + , inert_solved_dicts = solved_dicts }) + = vcat [ ppr ics + , text "Inert fsks =" <+> ppr ifsks + , ppUnless (null dicts) $ + text "Solved dicts =" <+> vcat (map ppr dicts) ] + where + dicts = bagToList (dictsToBag solved_dicts) + +emptyInertCans :: InertCans +emptyInertCans + = IC { inert_count = 0 + , inert_eqs = emptyDVarEnv + , inert_dicts = emptyDicts + , inert_safehask = emptyDicts + , inert_funeqs = emptyFunEqs + , inert_insts = [] + , inert_irreds = emptyCts } + +emptyInert :: InertSet +emptyInert + = IS { inert_cans = emptyInertCans + , inert_fsks = [] + , inert_flat_cache = emptyExactFunEqs + , inert_solved_dicts = emptyDictMap } + + +{- Note [Solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we apply a top-level instance declaration, we add the "solved" +dictionary to the inert_solved_dicts. In general, we use it to avoid +creating a new EvVar when we have a new goal that we have solved in +the past. + +But in particular, we can use it to create *recursive* dictionaries. +The simplest, degenerate case is + instance C [a] => C [a] where ... +If we have + [W] d1 :: C [x] +then we can apply the instance to get + d1 = $dfCList d + [W] d2 :: C [x] +Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. + d1 = $dfCList d + d2 = d1 + +See Note [Example of recursive dictionaries] + +VERY IMPORTANT INVARIANT: + + (Solved Dictionary Invariant) + Every member of the inert_solved_dicts is the result + of applying an instance declaration that "takes a step" + + An instance "takes a step" if it has the form + dfunDList d1 d2 = MkD (...) (...) (...) + That is, the dfun is lazy in its arguments, and guarantees to + immediately return a dictionary constructor. NB: all dictionary + data constructors are lazy in their arguments. + + This property is crucial to ensure that all dictionaries are + non-bottom, which in turn ensures that the whole "recursive + dictionary" idea works at all, even if we get something like + rec { d = dfunDList d dx } + See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. + + Reason: + - All instances, except two exceptions listed below, "take a step" + in the above sense + + - Exception 1: local quantified constraints have no such guarantee; + indeed, adding a "solved dictionary" when appling a quantified + constraint led to the ability to define unsafeCoerce + in #17267. + + - Exception 2: the magic built-in instance for (~) has no + such guarantee. It behaves as if we had + class (a ~# b) => (a ~ b) where {} + instance (a ~# b) => (a ~ b) where {} + The "dfun" for the instance is strict in the coercion. + Anyway there's no point in recording a "solved dict" for + (t1 ~ t2); it's not going to allow a recursive dictionary + to be constructed. Ditto (~~) and Coercible. + +THEREFORE we only add a "solved dictionary" + - when applying an instance declaration + - subject to Exceptions 1 and 2 above + +In implementation terms + - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary, + conditional on the kind of instance + + - It is only called when applying an instance decl, + in GHC.Tc.Solver.Interact.doTopReactDict + + - ClsInst.InstanceWhat says what kind of instance was + used to solve the constraint. In particular + * LocalInstance identifies quantified constraints + * BuiltinEqInstance identifies the strange built-in + instances for equality. + + - ClsInst.instanceReturnsDictCon says which kind of + instance guarantees to return a dictionary constructor + +Other notes about solved dictionaries + +* See also Note [Do not add superclasses of solved dictionaries] + +* The inert_solved_dicts field is not rewritten by equalities, + so it may get out of date. + +* The inert_solved_dicts are all Wanteds, never givens + +* We only cache dictionaries from top-level instances, not from + local quantified constraints. Reason: if we cached the latter + we'd need to purge the cache when bringing new quantified + constraints into scope, because quantified constraints "shadow" + top-level instances. + +Note [Do not add superclasses of solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every member of inert_solved_dicts is the result of applying a +dictionary function, NOT of applying superclass selection to anything. +Consider + + class Ord a => C a where + instance Ord [a] => C [a] where ... + +Suppose we are trying to solve + [G] d1 : Ord a + [W] d2 : C [a] + +Then we'll use the instance decl to give + + [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 + [W] d3 : Ord [a] + +We must not add d4 : Ord [a] to the 'solved' set (by taking the +superclass of d2), otherwise we'll use it to solve d3, without ever +using d1, which would be a catastrophe. + +Solution: when extending the solved dictionaries, do not add superclasses. +That's why each element of the inert_solved_dicts is the result of applying +a dictionary function. + +Note [Example of recursive dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +--- Example 1 + + data D r = ZeroD | SuccD (r (D r)); + + instance (Eq (r (D r))) => Eq (D r) where + ZeroD == ZeroD = True + (SuccD a) == (SuccD b) = a == b + _ == _ = False; + + equalDC :: D [] -> D [] -> Bool; + equalDC = (==); + +We need to prove (Eq (D [])). Here's how we go: + + [W] d1 : Eq (D []) +By instance decl of Eq (D r): + [W] d2 : Eq [D []] where d1 = dfEqD d2 +By instance decl of Eq [a]: + [W] d3 : Eq (D []) where d2 = dfEqList d3 + d1 = dfEqD d2 +Now this wanted can interact with our "solved" d1 to get: + d3 = d1 + +-- Example 2: +This code arises in the context of "Scrap Your Boilerplate with Class" + + class Sat a + class Data ctx a + instance Sat (ctx Char) => Data ctx Char -- dfunData1 + instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 + + class Data Maybe a => Foo a + + instance Foo t => Sat (Maybe t) -- dfunSat + + instance Data Maybe a => Foo a -- dfunFoo1 + instance Foo a => Foo [a] -- dfunFoo2 + instance Foo [Char] -- dfunFoo3 + +Consider generating the superclasses of the instance declaration + instance Foo a => Foo [a] + +So our problem is this + [G] d0 : Foo t + [W] d1 : Data Maybe [t] -- Desired superclass + +We may add the given in the inert set, along with its superclasses + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + WorkList + [W] d1 : Data Maybe [t] + +Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + WorkList: + [W] d2 : Sat (Maybe [t]) + [W] d3 : Data Maybe t + +Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList: + [W] d3 : Data Maybe t + [W] d4 : Foo [t] + +Now, we can just solve d3 from d01; d3 := d01 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList + [W] d4 : Foo [t] + +Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + d4 : Foo [t] + WorkList: + [W] d5 : Foo t + +Now, d5 can be solved! d5 := d0 + +Result + d1 := dfunData2 d2 d3 + d2 := dfunSat d4 + d3 := d01 + d4 := dfunFoo2 d5 + d5 := d0 +-} + +{- ********************************************************************* +* * + InertCans: the canonical inerts +* * +* * +********************************************************************* -} + +data InertCans -- See Note [Detailed InertCans Invariants] for more + = IC { inert_eqs :: InertEqs + -- See Note [inert_eqs: the inert equalities] + -- All CTyEqCans; index is the LHS tyvar + -- Domain = skolems and untouchables; a touchable would be unified + + , inert_funeqs :: FunEqMap Ct + -- All CFunEqCans; index is the whole family head type. + -- All Nominal (that's an invariant of all CFunEqCans) + -- LHS is fully rewritten (modulo eqCanRewrite constraints) + -- wrt inert_eqs + -- Can include all flavours, [G], [W], [WD], [D] + -- See Note [Type family equations] + + , inert_dicts :: DictMap Ct + -- Dictionaries only + -- All fully rewritten (modulo flavour constraints) + -- wrt inert_eqs + + , inert_insts :: [QCInst] + + , inert_safehask :: DictMap Ct + -- Failed dictionary resolution due to Safe Haskell overlapping + -- instances restriction. We keep this separate from inert_dicts + -- as it doesn't cause compilation failure, just safe inference + -- failure. + -- + -- ^ See Note [Safe Haskell Overlapping Instances Implementation] + -- in "GHC.Tc.Solver" + + , inert_irreds :: Cts + -- Irreducible predicates that cannot be made canonical, + -- and which don't interact with others (e.g. (c a)) + -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) + + , inert_count :: Int + -- Number of Wanted goals in + -- inert_eqs, inert_dicts, inert_safehask, inert_irreds + -- Does not include insolubles + -- When non-zero, keep trying to solve + } + +type InertEqs = DTyVarEnv EqualCtList +type EqualCtList = [Ct] -- See Note [EqualCtList invariants] + +{- Note [Detailed InertCans Invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The InertCans represents a collection of constraints with the following properties: + + * All canonical + + * No two dictionaries with the same head + * No two CIrreds with the same type + + * Family equations inert wrt top-level family axioms + + * Dictionaries have no matching top-level instance + + * Given family or dictionary constraints don't mention touchable + unification variables + + * Non-CTyEqCan constraints are fully rewritten with respect + to the CTyEqCan equalities (modulo canRewrite of course; + eg a wanted cannot rewrite a given) + + * CTyEqCan equalities: see Note [inert_eqs: the inert equalities] + Also see documentation in Constraint.Ct for a list of invariants + +Note [EqualCtList invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * All are equalities + * All these equalities have the same LHS + * The list is never empty + * No element of the list can rewrite any other + * Derived before Wanted + +From the fourth invariant it follows that the list is + - A single [G], or + - Zero or one [D] or [WD], followed by any number of [W] + +The Wanteds can't rewrite anything which is why we put them last + +Note [Type family equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type-family equations, CFunEqCans, of form (ev : F tys ~ ty), +live in three places + + * The work-list, of course + + * The inert_funeqs are un-solved but fully processed, and in + the InertCans. They can be [G], [W], [WD], or [D]. + + * The inert_flat_cache. This is used when flattening, to get maximal + sharing. Everything in the inert_flat_cache is [G] or [WD] + + It contains lots of things that are still in the work-list. + E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the + work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work + list. Now if we flatten w2 before we get to w3, we still want to + share that (G a). + Because it contains work-list things, DO NOT use the flat cache to solve + a top-level goal. Eg in the above example we don't want to solve w3 + using w3 itself! + +The CFunEqCan Ownership Invariant: + + * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv + It "owns" that fsk/fmv, in the sense that: + - reducing a [W/WD] CFunEqCan fills in the fmv + - unflattening a [W/WD] CFunEqCan fills in the fmv + (in both cases unless an occurs-check would result) + + * In contrast a [D] CFunEqCan does not "own" its fmv: + - reducing a [D] CFunEqCan does not fill in the fmv; + it just generates an equality + - unflattening ignores [D] CFunEqCans altogether + + +Note [inert_eqs: the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Definition [Can-rewrite relation] +A "can-rewrite" relation between flavours, written f1 >= f2, is a +binary relation with the following properties + + (R1) >= is transitive + (R2) If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 + +Lemma. If f1 >= f then f1 >= f1 +Proof. By property (R2), with f1=f2 + +Definition [Generalised substitution] +A "generalised substitution" S is a set of triples (a -f-> t), where + a is a type variable + t is a type + f is a flavour +such that + (WF1) if (a -f1-> t1) in S + (a -f2-> t2) in S + then neither (f1 >= f2) nor (f2 >= f1) hold + (WF2) if (a -f-> t) is in S, then t /= a + +Definition [Applying a generalised substitution] +If S is a generalised substitution + S(f,a) = t, if (a -fs-> t) in S, and fs >= f + = a, otherwise +Application extends naturally to types S(f,t), modulo roles. +See Note [Flavours with roles]. + +Theorem: S(f,a) is well defined as a function. +Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, + and f1 >= f and f2 >= f + Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) + +Notation: repeated application. + S^0(f,t) = t + S^(n+1)(f,t) = S(f, S^n(t)) + +Definition: inert generalised substitution +A generalised substitution S is "inert" iff + + (IG1) there is an n such that + for every f,t, S^n(f,t) = S^(n+1)(f,t) + +By (IG1) we define S*(f,t) to be the result of exahaustively +applying S(f,_) to t. + +---------------------------------------------------------------- +Our main invariant: + the inert CTyEqCans should be an inert generalised substitution +---------------------------------------------------------------- + +Note that inertness is not the same as idempotence. To apply S to a +type, you may have to apply it recursive. But inertness does +guarantee that this recursive use will terminate. + +Note [Extending the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Main Theorem [Stability under extension] + Suppose we have a "work item" + a -fw-> t + and an inert generalised substitution S, + THEN the extended substitution T = S+(a -fw-> t) + is an inert generalised substitution + PROVIDED + (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) + (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) + (T3) a not in t -- No occurs check in the work item + + AND, for every (b -fs-> s) in S: + (K0) not (fw >= fs) + Reason: suppose we kick out (a -fs-> s), + and add (a -fw-> t) to the inert set. + The latter can't rewrite the former, + so the kick-out achieved nothing + + OR { (K1) not (a = b) + Reason: if fw >= fs, WF1 says we can't have both + a -fw-> t and a -fs-> s + + AND (K2): guarantees inertness of the new substitution + { (K2a) not (fs >= fs) + OR (K2b) fs >= fw + OR (K2d) a not in s } + + AND (K3) See Note [K3: completeness of solving] + { (K3a) If the role of fs is nominal: s /= a + (K3b) If the role of fs is representational: + s is not of form (a t1 .. tn) } } + + +Conditions (T1-T3) are established by the canonicaliser +Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable + +The idea is that +* (T1-2) are guaranteed by exhaustively rewriting the work-item + with S(fw,_). + +* T3 is guaranteed by a simple occurs-check on the work item. + This is done during canonicalisation, in canEqTyVar; invariant + (TyEq:OC) of CTyEqCan. + +* (K1-3) are the "kick-out" criteria. (As stated, they are really the + "keep" criteria.) If the current inert S contains a triple that does + not satisfy (K1-3), then we remove it from S by "kicking it out", + and re-processing it. + +* Note that kicking out is a Bad Thing, because it means we have to + re-process a constraint. The less we kick out, the better. + TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed + this but haven't done the empirical study to check. + +* Assume we have G>=G, G>=W and that's all. Then, when performing + a unification we add a new given a -G-> ty. But doing so does NOT require + us to kick out an inert wanted that mentions a, because of (K2a). This + is a common case, hence good not to kick out. + +* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing + Proof: using Definition [Can-rewrite relation], fw can't rewrite anything + and so K0 holds. Intuitively, since fw can't rewrite anything, + adding it cannot cause any loops + This is a common case, because Wanteds cannot rewrite Wanteds. + It's used to avoid even looking for constraint to kick out. + +* Lemma (L1): The conditions of the Main Theorem imply that there is no + (a -fs-> t) in S, s.t. (fs >= fw). + Proof. Suppose the contrary (fs >= fw). Then because of (T1), + S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we + have (a -fs-> a) in S, which contradicts (WF2). + +* The extended substitution satisfies (WF1) and (WF2) + - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). + - (T3) guarantees (WF2). + +* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t), + T^1(f,t), T^2(f,T).... must pass through the new work item infinitely + often, since the substitution without the work item is inert; and must + pass through at least one of the triples in S infinitely often. + + - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f), + and hence this triple never plays a role in application S(f,a). + It is always safe to extend S with such a triple. + + (NB: we could strengten K1) in this way too, but see K3. + + - (K2b): If this holds then, by (T2), b is not in t. So applying the + work item does not generate any new opportunities for applying S + + - (K2c): If this holds, we can't pass through this triple infinitely + often, because if we did then fs>=f, fw>=f, hence by (R2) + * either fw>=fs, contradicting K2c + * or fs>=fw; so by the argument in K2b we can't have a loop + + - (K2d): if a not in s, we hae no further opportunity to apply the + work item, similar to (K2b) + + NB: Dimitrios has a PDF that does this in more detail + +Key lemma to make it watertight. + Under the conditions of the Main Theorem, + forall f st fw >= f, a is not in S^k(f,t), for any k + +Also, consider roles more carefully. See Note [Flavours with roles] + +Note [K3: completeness of solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(K3) is not necessary for the extended substitution +to be inert. In fact K1 could be made stronger by saying + ... then (not (fw >= fs) or not (fs >= fs)) +But it's not enough for S to be inert; we also want completeness. +That is, we want to be able to solve all soluble wanted equalities. +Suppose we have + + work-item b -G-> a + inert-item a -W-> b + +Assuming (G >= W) but not (W >= W), this fulfills all the conditions, +so we could extend the inerts, thus: + + inert-items b -G-> a + a -W-> b + +But if we kicked-out the inert item, we'd get + + work-item a -W-> b + inert-item b -G-> a + +Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. +So we add one more clause to the kick-out criteria + +Another way to understand (K3) is that we treat an inert item + a -f-> b +in the same way as + b -f-> a +So if we kick out one, we should kick out the other. The orientation +is somewhat accidental. + +When considering roles, we also need the second clause (K3b). Consider + + work-item c -G/N-> a + inert-item a -W/R-> b c + +The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. +But we don't kick out the inert item because not (W/R >= W/R). So we just +add the work item. But then, consider if we hit the following: + + work-item b -G/N-> Id + inert-items a -W/R-> b c + c -G/N-> a +where + newtype Id x = Id x + +For similar reasons, if we only had (K3a), we wouldn't kick the +representational inert out. And then, we'd miss solving the inert, which +now reduced to reflexivity. + +The solution here is to kick out representational inerts whenever the +tyvar of a work item is "exposed", where exposed means being at the +head of the top-level application chain (a t1 .. tn). See +TcType.isTyVarHead. This is encoded in (K3b). + +Beware: if we make this test succeed too often, we kick out too much, +and the solver might loop. Consider (#14363) + work item: [G] a ~R f b + inert item: [G] b ~R f a +In GHC 8.2 the completeness tests more aggressive, and kicked out +the inert item; but no rewriting happened and there was an infinite +loop. All we need is to have the tyvar at the head. + +Note [Flavours with roles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The system described in Note [inert_eqs: the inert equalities] +discusses an abstract +set of flavours. In GHC, flavours have two components: the flavour proper, +taken from {Wanted, Derived, Given} and the equality relation (often called +role), taken from {NomEq, ReprEq}. +When substituting w.r.t. the inert set, +as described in Note [inert_eqs: the inert equalities], +we must be careful to respect all components of a flavour. +For example, if we have + + inert set: a -G/R-> Int + b -G/R-> Bool + + type role T nominal representational + +and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT +T Int Bool. The reason is that T's first parameter has a nominal role, and +thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of +substitution means that the proof in Note [The inert equalities] may need +to be revisited, but we don't think that the end conclusion is wrong. +-} + +instance Outputable InertCans where + ppr (IC { inert_eqs = eqs + , inert_funeqs = funeqs, inert_dicts = dicts + , inert_safehask = safehask, inert_irreds = irreds + , inert_insts = insts + , inert_count = count }) + = braces $ vcat + [ ppUnless (isEmptyDVarEnv eqs) $ + text "Equalities:" + <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) + , ppUnless (isEmptyTcAppMap funeqs) $ + text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) + , ppUnless (isEmptyTcAppMap dicts) $ + text "Dictionaries =" <+> pprCts (dictsToBag dicts) + , ppUnless (isEmptyTcAppMap safehask) $ + text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) + , ppUnless (isEmptyCts irreds) $ + text "Irreds =" <+> pprCts irreds + , ppUnless (null insts) $ + text "Given instances =" <+> vcat (map ppr insts) + , text "Unsolved goals =" <+> int count + ] + +{- ********************************************************************* +* * + Shadow constraints and improvement +* * +************************************************************************ + +Note [The improvement story and derived shadows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not +rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for +solving. Here's a classic example (indexed-types/should_fail/T4093a) + + Ambiguity check for f: (Foo e ~ Maybe e) => Foo e + + We get [G] Foo e ~ Maybe e + [W] Foo e ~ Foo ee -- ee is a unification variable + [W] Foo ee ~ Maybe ee + + Flatten: [G] Foo e ~ fsk + [G] fsk ~ Maybe e -- (A) + + [W] Foo ee ~ fmv + [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee + [W] fmv ~ Maybe ee + + --> rewrite (B) with (A) + [W] Foo ee ~ fmv + [W] fmv ~ Maybe e + [W] fmv ~ Maybe ee + + But now we appear to be stuck, since we don't rewrite Wanteds with + Wanteds. This is silly because we can see that ee := e is the + only solution. + +The basic plan is + * generate Derived constraints that shadow Wanted constraints + * allow Derived to rewrite Derived + * in order to cause some unifications to take place + * that in turn solve the original Wanteds + +The ONLY reason for all these Derived equalities is to tell us how to +unify a variable: that is, what Mark Jones calls "improvement". + +The same idea is sometimes also called "saturation"; find all the +equalities that must hold in any solution. + +Or, equivalently, you can think of the derived shadows as implementing +the "model": a non-idempotent but no-occurs-check substitution, +reflecting *all* *Nominal* equalities (a ~N ty) that are not +immediately soluble by unification. + +More specifically, here's how it works (Oct 16): + +* Wanted constraints are born as [WD]; this behaves like a + [W] and a [D] paired together. + +* When we are about to add a [WD] to the inert set, if it can + be rewritten by a [D] a ~ ty, then we split it into [W] and [D], + putting the latter into the work list (see maybeEmitShadow). + +In the example above, we get to the point where we are stuck: + [WD] Foo ee ~ fmv + [WD] fmv ~ Maybe e + [WD] fmv ~ Maybe ee + +But now when [WD] fmv ~ Maybe ee is about to be added, we'll +split it into [W] and [D], since the inert [WD] fmv ~ Maybe e +can rewrite it. Then: + work item: [D] fmv ~ Maybe ee + inert: [W] fmv ~ Maybe ee + [WD] fmv ~ Maybe e -- (C) + [WD] Foo ee ~ fmv + +See Note [Splitting WD constraints]. Now the work item is rewritten +by (C) and we soon get ee := e. + +Additional notes: + + * The derived shadow equalities live in inert_eqs, along with + the Givens and Wanteds; see Note [EqualCtList invariants]. + + * We make Derived shadows only for Wanteds, not Givens. So we + have only [G], not [GD] and [G] plus splitting. See + Note [Add derived shadows only for Wanteds] + + * We also get Derived equalities from functional dependencies + and type-function injectivity; see calls to unifyDerived. + + * This splitting business applies to CFunEqCans too; and then + we do apply type-function reductions to the [D] CFunEqCan. + See Note [Reduction for Derived CFunEqCans] + + * It's worth having [WD] rather than just [W] and [D] because + * efficiency: silly to process the same thing twice + * inert_funeqs, inert_dicts is a finite map keyed by + the type; it's inconvenient for it to map to TWO constraints + +Note [Splitting WD constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are about to add a [WD] constraint to the inert set; and we +know that the inert set has fully rewritten it. Should we split +it into [W] and [D], and put the [D] in the work list for further +work? + +* CDictCan (C tys) or CFunEqCan (F tys ~ fsk): + Yes if the inert set could rewrite tys to make the class constraint, + or type family, fire. That is, yes if the inert_eqs intersects + with the free vars of tys. For this test we use + (anyRewritableTyVar True) which ignores casts and coercions in tys, + because rewriting the casts or coercions won't make the thing fire + more often. + +* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'. + We need to check both 'a' and 'ty' against the inert set: + - Inert set contains [D] a ~ ty2 + Then we want to put [D] a ~ ty in the worklist, so we'll + get [D] ty ~ ty2 with consequent good things + + - Inert set contains [D] b ~ a, where b is in ty. + We can't just add [WD] a ~ ty[b] to the inert set, because + that breaks the inert-set invariants. If we tried to + canonicalise another [D] constraint mentioning 'a', we'd + get an infinite loop + + Moreover we must use (anyRewritableTyVar False) for the RHS, + because even tyvars in the casts and coercions could give + an infinite loop if we don't expose it + +* CIrredCan: Yes if the inert set can rewrite the constraint. + We used to think splitting irreds was unnecessary, but + see Note [Splitting Irred WD constraints] + +* Others: nothing is gained by splitting. + +Note [Splitting Irred WD constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Splitting Irred constraints can make a difference. Here is the +scenario: + + a[sk] :: F v -- F is a type family + beta :: alpha + + work item: [WD] a ~ beta + +This is heterogeneous, so we try flattening the kinds. + + co :: F v ~ fmv + [WD] (a |> co) ~ beta + +This is still hetero, so we emit a kind equality and make the work item an +inert Irred. + + work item: [D] fmv ~ alpha + inert: [WD] (a |> co) ~ beta (CIrredCan) + +Can't make progress on the work item. Add to inert set. This kicks out the +old inert, because a [D] can rewrite a [WD]. + + work item: [WD] (a |> co) ~ beta + inert: [D] fmv ~ alpha (CTyEqCan) + +Can't make progress on this work item either (although GHC tries by +decomposing the cast and reflattening... but that doesn't make a difference), +which is still hetero. Emit a new kind equality and add to inert set. But, +critically, we split the Irred. + + work list: + [D] fmv ~ alpha (CTyEqCan) + [D] (a |> co) ~ beta (CIrred) -- this one was split off + inert: + [W] (a |> co) ~ beta + [D] fmv ~ alpha + +We quickly solve the first work item, as it's the same as an inert. + + work item: [D] (a |> co) ~ beta + inert: + [W] (a |> co) ~ beta + [D] fmv ~ alpha + +We decompose the cast, yielding + + [D] a ~ beta + +We then flatten the kinds. The lhs kind is F v, which flattens to fmv which +then rewrites to alpha. + + co' :: F v ~ alpha + [D] (a |> co') ~ beta + +Now this equality is homo-kinded. So we swizzle it around to + + [D] beta ~ (a |> co') + +and set beta := a |> co', and go home happy. + +If we don't split the Irreds, we loop. This is all dangerously subtle. + +This is triggered by test case typecheck/should_compile/SplitWD. + +Note [Examples of how Derived shadows helps completeness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#10009, a very nasty example: + + f :: (UnF (F b) ~ b) => F b -> () + + g :: forall a. (UnF (F a) ~ a) => a -> () + g _ = f (undefined :: F a) + + For g we get [G] UnF (F a) ~ a + [WD] UnF (F beta) ~ beta + [WD] F a ~ F beta + Flatten: + [G] g1: F a ~ fsk1 fsk1 := F a + [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 + [G] g3: fsk2 ~ a + + [WD] w1: F beta ~ fmv1 + [WD] w2: UnF fmv1 ~ fmv2 + [WD] w3: fmv2 ~ beta + [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache + -- and re-orient to put meta-var on left + +Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2 +React that with g2: [D] d2: fmv2 ~ fsk2 +React that with w3: [D] beta ~ fsk2 + and g3: [D] beta ~ a -- Hooray beta := a +And that is enough to solve everything + +Note [Add derived shadows only for Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only add shadows for Wanted constraints. That is, we have +[WD] but not [GD]; and maybeEmitShaodw looks only at [WD] +constraints. + +It does just possibly make sense ot add a derived shadow for a +Given. If we created a Derived shadow of a Given, it could be +rewritten by other Deriveds, and that could, conceivably, lead to a +useful unification. + +But (a) I have been unable to come up with an example of this + happening + (b) see #12660 for how adding the derived shadows + of a Given led to an infinite loop. + (c) It's unlikely that rewriting derived Givens will lead + to a unification because Givens don't mention touchable + unification variables + +For (b) there may be other ways to solve the loop, but simply +reraining from adding derived shadows of Givens is particularly +simple. And it's more efficient too! + +Still, here's one possible reason for adding derived shadows +for Givens. Consider + work-item [G] a ~ [b], inerts has [D] b ~ a. +If we added the derived shadow (into the work list) + [D] a ~ [b] +When we process it, we'll rewrite to a ~ [a] and get an +occurs check. Without it we'll miss the occurs check (reporting +inaccessible code); but that's probably OK. + +Note [Keep CDictCan shadows as CDictCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class C a => D a b +and [G] D a b, [G] C a in the inert set. Now we insert +[D] b ~ c. We want to kick out a derived shadow for [D] D a b, +so we can rewrite it with the new constraint, and perhaps get +instance reduction or other consequences. + +BUT we do not want to kick out a *non-canonical* (D a b). If we +did, we would do this: + - rewrite it to [D] D a c, with pend_sc = True + - use expandSuperClasses to add C a + - go round again, which solves C a from the givens +This loop goes on for ever and triggers the simpl_loop limit. + +Solution: kick out the CDictCan which will have pend_sc = False, +because we've already added its superclasses. So we won't re-add +them. If we forget the pend_sc flag, our cunning scheme for avoiding +generating superclasses repeatedly will fail. + +See #11379 for a case of this. + +Note [Do not do improvement for WOnly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do improvement between two constraints (e.g. for injectivity +or functional dependencies) only if both are "improvable". And +we improve a constraint wrt the top-level instances only if +it is improvable. + +Improvable: [G] [WD] [D} +Not improvable: [W] + +Reasons: + +* It's less work: fewer pairs to compare + +* Every [W] has a shadow [D] so nothing is lost + +* Consider [WD] C Int b, where 'b' is a skolem, and + class C a b | a -> b + instance C Int Bool + We'll do a fundep on it and emit [D] b ~ Bool + That will kick out constraint [WD] C Int b + Then we'll split it to [W] C Int b (keep in inert) + and [D] C Int b (in work list) + When processing the latter we'll rewrite it to + [D] C Int Bool + At that point it would be /stupid/ to interact it + with the inert [W] C Int b in the inert set; after all, + it's the very constraint from which the [D] C Int Bool + was split! We can avoid this by not doing improvement + on [W] constraints. This came up in #12860. +-} + +maybeEmitShadow :: InertCans -> Ct -> TcS Ct +-- See Note [The improvement story and derived shadows] +maybeEmitShadow ics ct + | let ev = ctEvidence ct + , CtWanted { ctev_pred = pred, ctev_loc = loc + , ctev_nosh = WDeriv } <- ev + , shouldSplitWD (inert_eqs ics) ct + = do { traceTcS "Emit derived shadow" (ppr ct) + ; let derived_ev = CtDerived { ctev_pred = pred + , ctev_loc = loc } + shadow_ct = ct { cc_ev = derived_ev } + -- Te shadow constraint keeps the canonical shape. + -- This just saves work, but is sometimes important; + -- see Note [Keep CDictCan shadows as CDictCan] + ; emitWork [shadow_ct] + + ; let ev' = ev { ctev_nosh = WOnly } + ct' = ct { cc_ev = ev' } + -- Record that it now has a shadow + -- This is /the/ place we set the flag to WOnly + ; return ct' } + + | otherwise + = return ct + +shouldSplitWD :: InertEqs -> Ct -> Bool +-- Precondition: 'ct' is [WD], and is inert +-- True <=> we should split ct ito [W] and [D] because +-- the inert_eqs can make progress on the [D] +-- See Note [Splitting WD constraints] + +shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys }) + = should_split_match_args inert_eqs tys + -- We don't need to split if the tv is the RHS fsk + +shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys }) + = should_split_match_args inert_eqs tys + -- NB True: ignore coercions + -- See Note [Splitting WD constraints] + +shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty + , cc_eq_rel = eq_rel }) + = tv `elemDVarEnv` inert_eqs + || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty + -- NB False: do not ignore casts and coercions + -- See Note [Splitting WD constraints] + +shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev }) + = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev) + +shouldSplitWD _ _ = False -- No point in splitting otherwise + +should_split_match_args :: InertEqs -> [TcType] -> Bool +-- True if the inert_eqs can rewrite anything in the argument +-- types, ignoring casts and coercions +should_split_match_args inert_eqs tys + = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys + -- NB True: ignore casts coercions + -- See Note [Splitting WD constraints] + +canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool +canRewriteTv inert_eqs eq_rel tv + | Just (ct : _) <- lookupDVarEnv inert_eqs tv + , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct + = eq_rel1 `eqCanRewrite` eq_rel + | otherwise + = False + +isImprovable :: CtEvidence -> Bool +-- See Note [Do not do improvement for WOnly] +isImprovable (CtWanted { ctev_nosh = WOnly }) = False +isImprovable _ = True + + +{- ********************************************************************* +* * + Inert equalities +* * +********************************************************************* -} + +addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs +addTyEq old_eqs tv ct + = extendDVarEnv_C add_eq old_eqs tv [ct] + where + add_eq old_eqs _ + | isWantedCt ct + , (eq1 : eqs) <- old_eqs + = eq1 : ct : eqs + | otherwise + = ct : old_eqs + +foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b +foldTyEqs k eqs z + = foldDVarEnv (\cts z -> foldr k z cts) z eqs + +findTyEqs :: InertCans -> TyVar -> EqualCtList +findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` [] + +delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs +delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv + where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 + isThisOne _ = False + +lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType +lookupInertTyVar ieqs tv + = case lookupDVarEnv ieqs tv of + Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs + _ -> Nothing + +{- ********************************************************************* +* * + Inert instances: inert_insts +* * +********************************************************************* -} + +addInertForAll :: QCInst -> TcS () +-- Add a local Given instance, typically arising from a type signature +addInertForAll new_qci + = do { ics <- getInertCans + ; insts' <- add_qci (inert_insts ics) + ; setInertCans (ics { inert_insts = insts' }) } + where + add_qci :: [QCInst] -> TcS [QCInst] + -- See Note [Do not add duplicate quantified instances] + add_qci qcis + | any same_qci qcis + = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) + ; return qcis } + + | otherwise + = do { traceTcS "adding new inert quantified instance" (ppr new_qci) + ; return (new_qci : qcis) } + + same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) + (ctEvPred (qci_ev new_qci)) + +{- Note [Do not add duplicate quantified instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#15244): + + f :: (C g, D g) => .... + class S g => C g where ... + class S g => D g where ... + class (forall a. Eq a => Eq (g a)) => S g where ... + +Then in f's RHS there are two identical quantified constraints +available, one via the superclasses of C and one via the superclasses +of D. The two are identical, and it seems wrong to reject the program +because of that. But without doing duplicate-elimination we will have +two matching QCInsts when we try to solve constraints arising from f's +RHS. + +The simplest thing is simply to eliminate duplicates, which we do here. +-} + +{- ********************************************************************* +* * + Adding an inert +* * +************************************************************************ + +Note [Adding an equality to the InertCans] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding an equality to the inerts: + +* Split [WD] into [W] and [D] if the inerts can rewrite the latter; + done by maybeEmitShadow. + +* Kick out any constraints that can be rewritten by the thing + we are adding. Done by kickOutRewritable. + +* Note that unifying a:=ty, is like adding [G] a~ty; just use + kickOutRewritable with Nominal, Given. See kickOutAfterUnification. + +Note [Kicking out CFunEqCan for fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + New: [D] fmv1 ~ fmv2 + Inert: [W] F alpha ~ fmv1 + [W] F beta ~ fmv2 + +where F is injective. The new (derived) equality certainly can't +rewrite the inerts. But we *must* kick out the first one, to get: + + New: [W] F alpha ~ fmv1 + Inert: [W] F beta ~ fmv2 + [D] fmv1 ~ fmv2 + +and now improvement will discover [D] alpha ~ beta. This is important; +eg in #9587. + +So in kickOutRewritable we look at all the tyvars of the +CFunEqCan, including the fsk. +-} + +addInertCan :: Ct -> TcS () -- Constraints *other than* equalities +-- Precondition: item /is/ canonical +-- See Note [Adding an equality to the InertCans] +addInertCan ct + = do { traceTcS "insertInertCan {" $ + text "Trying to insert new inert item:" <+> ppr ct + + ; ics <- getInertCans + ; ct <- maybeEmitShadow ics ct + ; ics <- maybeKickOut ics ct + ; setInertCans (add_item ics ct) + + ; traceTcS "addInertCan }" $ empty } + +maybeKickOut :: InertCans -> Ct -> TcS InertCans +-- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan +maybeKickOut ics ct + | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct + = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics + ; return ics' } + | otherwise + = return ics + +add_item :: InertCans -> Ct -> InertCans +add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) + = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } + +add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) + = ics { inert_eqs = addTyEq (inert_eqs ics) tv item + , inert_count = bumpUnsolvedCount ev (inert_count ics) } + +add_item ics@(IC { inert_irreds = irreds, inert_count = count }) + item@(CIrredCan { cc_ev = ev, cc_status = status }) + = ics { inert_irreds = irreds `Bag.snocBag` item + , inert_count = case status of + InsolubleCIS -> count + _ -> bumpUnsolvedCount ev count } + -- inert_count does not include insolubles + + +add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) + = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item + , inert_count = bumpUnsolvedCount ev (inert_count ics) } + +add_item _ item + = pprPanic "upd_inert set: can't happen! Inserting " $ + ppr item -- Can't be CNonCanonical because they only land in inert_irreds + +bumpUnsolvedCount :: CtEvidence -> Int -> Int +bumpUnsolvedCount ev n | isWanted ev = n+1 + | otherwise = n + + +----------------------------------------- +kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that + -- is being added to the inert set + -> TcTyVar -- The new equality is tv ~ ty + -> InertCans + -> TcS (Int, InertCans) +kickOutRewritable new_fr new_tv ics + = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics + n_kicked = workListSize kicked_out + + ; unless (n_kicked == 0) $ + do { updWorkListTcS (appendWorkList kicked_out) + ; csTraceTcS $ + hang (text "Kick out, tv =" <+> ppr new_tv) + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } + + ; return (n_kicked, ics') } + +kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that + -- is being added to the inert set + -> TcTyVar -- The new equality is tv ~ ty + -> InertCans + -> (WorkList, InertCans) +-- See Note [kickOutRewritable] +kick_out_rewritable new_fr new_tv + ics@(IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_safehask = safehask + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insts = old_insts + , inert_count = n }) + | not (new_fr `eqMayRewriteFR` new_fr) + = (emptyWorkList, ics) + -- If new_fr can't rewrite itself, it can't rewrite + -- anything else, so no need to kick out anything. + -- (This is a common case: wanteds can't rewrite wanteds) + -- Lemma (L2) in Note [Extending the inert equalities] + + | otherwise + = (kicked_out, inert_cans_in) + where + inert_cans_in = IC { inert_eqs = tv_eqs_in + , inert_dicts = dicts_in + , inert_safehask = safehask -- ?? + , inert_funeqs = feqs_in + , inert_irreds = irs_in + , inert_insts = insts_in + , inert_count = n - workListWantedCount kicked_out } + + kicked_out :: WorkList + -- NB: use extendWorkList to ensure that kicked-out equalities get priority + -- See Note [Prioritise equalities] (Kick-out). + -- The irreds may include non-canonical (hetero-kinded) equality + -- constraints, which perhaps may have become soluble after new_tv + -- is substituted; ditto the dictionaries, which may include (a~b) + -- or (a~~b) constraints. + kicked_out = foldr extendWorkListCt + (emptyWorkList { wl_eqs = tv_eqs_out + , wl_funeqs = feqs_out }) + ((dicts_out `andCts` irs_out) + `extendCtsList` insts_out) + + (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs + (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap + -- See Note [Kicking out CFunEqCan for fundeps] + (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap + (irs_out, irs_in) = partitionBag kick_out_ct irreds + -- Kick out even insolubles: See Note [Rewrite insolubles] + -- Of course we must kick out irreducibles like (c a), in case + -- we can rewrite 'c' to something more useful + + -- Kick-out for inert instances + -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical + insts_out :: [Ct] + insts_in :: [QCInst] + (insts_out, insts_in) + | fr_may_rewrite (Given, NomEq) -- All the insts are Givens + = partitionWith kick_out_qci old_insts + | otherwise + = ([], old_insts) + kick_out_qci qci + | let ev = qci_ev qci + , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) + = Left (mkNonCanonical ev) + | otherwise + = Right qci + + (_, new_role) = new_fr + + fr_can_rewrite_ty :: EqRel -> Type -> Bool + fr_can_rewrite_ty role ty = anyRewritableTyVar False role + fr_can_rewrite_tv ty + fr_can_rewrite_tv :: EqRel -> TyVar -> Bool + fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role + && tv == new_tv + + fr_may_rewrite :: CtFlavourRole -> Bool + fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs + -- Can the new item rewrite the inert item? + + kick_out_ct :: Ct -> Bool + -- Kick it out if the new CTyEqCan can rewrite the inert one + -- See Note [kickOutRewritable] + kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct + = fr_may_rewrite fs + && fr_can_rewrite_ty role (ctPred ct) + -- False: ignore casts and coercions + -- NB: this includes the fsk of a CFunEqCan. It can't + -- actually be rewritten, but we need to kick it out + -- so we get to take advantage of injectivity + -- See Note [Kicking out CFunEqCan for fundeps] + + kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList) + -> ([Ct], DTyVarEnv EqualCtList) + kick_out_eqs eqs (acc_out, acc_in) + = (eqs_out ++ acc_out, case eqs_in of + [] -> acc_in + (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in) + where + (eqs_out, eqs_in) = partition kick_out_eq eqs + + -- Implements criteria K1-K3 in Note [Extending the inert equalities] + kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty + , cc_ev = ev, cc_eq_rel = eq_rel }) + | not (fr_may_rewrite fs) + = False -- Keep it in the inert set if the new thing can't rewrite it + + -- Below here (fr_may_rewrite fs) is True + | tv == new_tv = True -- (K1) + | kick_out_for_inertness = True + | kick_out_for_completeness = True + | otherwise = False + + where + fs = (ctEvFlavour ev, eq_rel) + kick_out_for_inertness + = (fs `eqMayRewriteFR` fs) -- (K2a) + && not (fs `eqMayRewriteFR` new_fr) -- (K2b) + && fr_can_rewrite_ty eq_rel rhs_ty -- (K2d) + -- (K2c) is guaranteed by the first guard of keep_eq + + kick_out_for_completeness + = case eq_rel of + NomEq -> rhs_ty `eqType` mkTyVarTy new_tv + ReprEq -> isTyVarHead new_tv rhs_ty + + kick_out_eq ct = pprPanic "keep_eq" (ppr ct) + +kickOutAfterUnification :: TcTyVar -> TcS Int +kickOutAfterUnification new_tv + = do { ics <- getInertCans + ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) + new_tv ics + -- Given because the tv := xi is given; NomEq because + -- only nominal equalities are solved by unification + + ; setInertCans ics2 + ; return n_kicked } + +-- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" +kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () +kickOutAfterFillingCoercionHole hole + = do { ics <- getInertCans + ; let (kicked_out, ics') = kick_out ics + n_kicked = workListSize kicked_out + + ; unless (n_kicked == 0) $ + do { updWorkListTcS (appendWorkList kicked_out) + ; csTraceTcS $ + hang (text "Kick out, hole =" <+> ppr hole) + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } + + ; setInertCans ics' } + where + kick_out :: InertCans -> (WorkList, InertCans) + kick_out ics@(IC { inert_irreds = irreds }) + = let (to_kick, to_keep) = partitionBag kick_ct irreds + + kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList + ics' = ics { inert_irreds = to_keep } + in + (kicked_out, ics') + + kick_ct :: Ct -> Bool + -- This is not particularly efficient. Ways to do better: + -- 1) Have a custom function that looks for a coercion hole and returns a Bool + -- 2) Keep co-hole-blocked constraints in a separate part of the inert set, + -- keyed by their co-hole. (Is it possible for more than one co-hole to be + -- in a constraint? I doubt it.) + kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS }) + = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev) + kick_ct _other = False + +{- Note [kickOutRewritable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [inert_eqs: the inert equalities]. + +When we add a new inert equality (a ~N ty) to the inert set, +we must kick out any inert items that could be rewritten by the +new equality, to maintain the inert-set invariants. + + - We want to kick out an existing inert constraint if + a) the new constraint can rewrite the inert one + b) 'a' is free in the inert constraint (so that it *will*) + rewrite it if we kick it out. + + For (b) we use tyCoVarsOfCt, which returns the type variables /and + the kind variables/ that are directly visible in the type. Hence + we will have exposed all the rewriting we care about to make the + most precise kinds visible for matching classes etc. No need to + kick out constraints that mention type variables whose kinds + contain this variable! + + - A Derived equality can kick out [D] constraints in inert_eqs, + inert_dicts, inert_irreds etc. + + - We don't kick out constraints from inert_solved_dicts, and + inert_solved_funeqs optimistically. But when we lookup we have to + take the substitution into account + + +Note [Rewrite insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an insoluble alpha ~ [alpha], which is insoluble +because an occurs check. And then we unify alpha := [Int]. Then we +really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can +be decomposed. Otherwise we end up with a "Can't match [Int] ~ +[[Int]]" which is true, but a bit confusing because the outer type +constructors match. + +Hence: + * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, + simpl_loop), we feed the insolubles in solveSimpleWanteds, + so that they get rewritten (albeit not solved). + + * We kick insolubles out of the inert set, if they can be + rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable) + + * We rewrite those insolubles in GHC.Tc.Solver.Canonical. + See Note [Make sure that insolubles are fully rewritten] +-} + + + +-------------- +addInertSafehask :: InertCans -> Ct -> InertCans +addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) + = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item } + +addInertSafehask _ item + = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item + +insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS () +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +insertSafeOverlapFailureTcS what item + | safeOverlap what = return () + | otherwise = updInertCans (\ics -> addInertSafehask ics item) + +getSafeOverlapFailures :: TcS Cts +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +getSafeOverlapFailures + = do { IC { inert_safehask = safehask } <- getInertCans + ; return $ foldDicts consCts safehask emptyCts } + +-------------- +addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS () +-- Conditionally add a new item in the solved set of the monad +-- See Note [Solved dictionaries] +addSolvedDict what item cls tys + | isWanted item + , instanceReturnsDictCon what + = do { traceTcS "updSolvedSetTcs:" $ ppr item + ; updInertTcS $ \ ics -> + ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } + | otherwise + = return () + +getSolvedDicts :: TcS (DictMap CtEvidence) +getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) } + +setSolvedDicts :: DictMap CtEvidence -> TcS () +setSolvedDicts solved_dicts + = updInertTcS $ \ ics -> + ics { inert_solved_dicts = solved_dicts } + + +{- ********************************************************************* +* * + Other inert-set operations +* * +********************************************************************* -} + +updInertTcS :: (InertSet -> InertSet) -> TcS () +-- Modify the inert set with the supplied function +updInertTcS upd_fn + = do { is_var <- getTcSInertsRef + ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var + ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } + +getInertCans :: TcS InertCans +getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } + +setInertCans :: InertCans -> TcS () +setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } + +updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a +-- Modify the inert set with the supplied function +updRetInertCans upd_fn + = do { is_var <- getTcSInertsRef + ; wrapTcS (do { inerts <- TcM.readTcRef is_var + ; let (res, cans') = upd_fn (inert_cans inerts) + ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) + ; return res }) } + +updInertCans :: (InertCans -> InertCans) -> TcS () +-- Modify the inert set with the supplied function +updInertCans upd_fn + = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } + +updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertDicts upd_fn + = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } + +updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertSafehask upd_fn + = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } + +updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertFunEqs upd_fn + = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) } + +updInertIrreds :: (Cts -> Cts) -> TcS () +-- Modify the inert set with the supplied function +updInertIrreds upd_fn + = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } + +getInertEqs :: TcS (DTyVarEnv EqualCtList) +getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } + +getInertInsols :: TcS Cts +-- Returns insoluble equality constraints +-- specifically including Givens +getInertInsols = do { inert <- getInertCans + ; return (filterBag insolubleEqCt (inert_irreds inert)) } + +getInertGivens :: TcS [Ct] +-- Returns the Given constraints in the inert set, +-- with type functions *not* unflattened +getInertGivens + = do { inerts <- getInertCans + ; let all_cts = foldDicts (:) (inert_dicts inerts) + $ foldFunEqs (:) (inert_funeqs inerts) + $ concat (dVarEnvElts (inert_eqs inerts)) + ; return (filter isGivenCt all_cts) } + +getPendingGivenScs :: TcS [Ct] +-- Find all inert Given dictionaries, or quantified constraints, +-- whose cc_pend_sc flag is True +-- and that belong to the current level +-- Set their cc_pend_sc flag to False in the inert set, and return that Ct +getPendingGivenScs = do { lvl <- getTcLevel + ; updRetInertCans (get_sc_pending lvl) } + +get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) +get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) + = ASSERT2( all isGivenCt sc_pending, ppr sc_pending ) + -- When getPendingScDics is called, + -- there are never any Wanteds in the inert set + (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' }) + where + sc_pending = sc_pend_insts ++ sc_pend_dicts + + sc_pend_dicts = foldDicts get_pending dicts [] + dicts' = foldr add dicts sc_pend_dicts + + (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts + + get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True + -- but flipping the flag + get_pending dict dicts + | Just dict' <- isPendingScDict dict + , belongs_to_this_level (ctEvidence dict) + = dict' : dicts + | otherwise + = dicts + + add :: Ct -> DictMap Ct -> DictMap Ct + add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts + = addDictCt dicts cls tys ct + add ct _ = pprPanic "getPendingScDicts" (ppr ct) + + get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) + get_pending_inst cts qci@(QCI { qci_ev = ev }) + | Just qci' <- isPendingScInst qci + , belongs_to_this_level ev + = (CQuantCan qci' : cts, qci') + | otherwise + = (cts, qci) + + belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl + -- We only want Givens from this level; see (3a) in + -- Note [The superclass story] in GHC.Tc.Solver.Canonical + +getUnsolvedInerts :: TcS ( Bag Implication + , Cts -- Tyvar eqs: a ~ ty + , Cts -- Fun eqs: F a ~ ty + , Cts ) -- All others +-- Return all the unsolved [Wanted] or [Derived] constraints +-- +-- Post-condition: the returned simple constraints are all fully zonked +-- (because they come from the inert set) +-- the unsolved implics may not be +getUnsolvedInerts + = do { IC { inert_eqs = tv_eqs + , inert_funeqs = fun_eqs + , inert_irreds = irreds + , inert_dicts = idicts + } <- getInertCans + + ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts + unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts + unsolved_irreds = Bag.filterBag is_unsolved irreds + unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts + unsolved_others = unsolved_irreds `unionBags` unsolved_dicts + + ; implics <- getWorkListImplics + + ; traceTcS "getUnsolvedInerts" $ + vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs + , text "fun eqs =" <+> ppr unsolved_fun_eqs + , text "others =" <+> ppr unsolved_others + , text "implics =" <+> ppr implics ] + + ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) } + where + add_if_unsolved :: Ct -> Cts -> Cts + add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts + | otherwise = cts + + is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived + + -- For CFunEqCans we ignore the Derived ones, and keep + -- only the Wanteds for flattening. The Derived ones + -- share a unification variable with the corresponding + -- Wanted, so we definitely don't want to participate + -- in unflattening + -- See Note [Type family equations] + add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts + | otherwise = cts + +isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool +-- True if (a ~N ty) is in the inert set, in either Given or Wanted +isInInertEqs eqs tv rhs + = case lookupDVarEnv eqs tv of + Nothing -> False + Just cts -> any (same_pred rhs) cts + where + same_pred rhs ct + | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct + , NomEq <- eq_rel + , rhs `eqType` rhs2 = True + | otherwise = False + +getNoGivenEqs :: TcLevel -- TcLevel of this implication + -> [TcTyVar] -- Skolems of this implication + -> TcS ( Bool -- True <=> definitely no residual given equalities + , Cts ) -- Insoluble equalities arising from givens +-- See Note [When does an implication have given equalities?] +getNoGivenEqs tclvl skol_tvs + = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) + <- getInertCans + ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds + || anyDVarEnv eqs_given_here ieqs + insols = filterBag insolubleEqCt irreds + -- Specifically includes ones that originated in some + -- outer context but were refined to an insoluble by + -- a local equality; so do /not/ add ct_given_here. + + ; traceTcS "getNoGivenEqs" $ + vcat [ if has_given_eqs then text "May have given equalities" + else text "No given equalities" + , text "Skols:" <+> ppr skol_tvs + , text "Inerts:" <+> ppr inerts + , text "Insols:" <+> ppr insols] + ; return (not has_given_eqs, insols) } + where + eqs_given_here :: EqualCtList -> Bool + eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })] + -- Givens are always a singleton + = not (skolem_bound_here tv) && ct_given_here ct + eqs_given_here _ = False + + ct_given_here :: Ct -> Bool + -- True for a Given bound by the current implication, + -- i.e. the current level + ct_given_here ct = isGiven ev + && tclvl == ctLocLevel (ctEvLoc ev) + where + ev = ctEvidence ct + + skol_tv_set = mkVarSet skol_tvs + skolem_bound_here tv -- See Note [Let-bound skolems] + = case tcTyVarDetails tv of + SkolemTv {} -> tv `elemVarSet` skol_tv_set + _ -> False + +-- | Returns Given constraints that might, +-- potentially, match the given pred. This is used when checking to see if a +-- Given might overlap with an instance. See Note [Instance and Given overlap] +-- in "GHC.Tc.Solver.Interact" +matchableGivens :: CtLoc -> PredType -> InertSet -> Cts +matchableGivens loc_w pred_w (IS { inert_cans = inert_cans }) + = filterBag matchable_given all_relevant_givens + where + -- just look in class constraints and irreds. matchableGivens does get called + -- for ~R constraints, but we don't need to look through equalities, because + -- canonical equalities are used for rewriting. We'll only get caught by + -- non-canonical -- that is, irreducible -- equalities. + all_relevant_givens :: Cts + all_relevant_givens + | Just (clas, _) <- getClassPredTys_maybe pred_w + = findDictsByClass (inert_dicts inert_cans) clas + `unionBags` inert_irreds inert_cans + | otherwise + = inert_irreds inert_cans + + matchable_given :: Ct -> Bool + matchable_given ct + | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct + = mightMatchLater pred_g loc_g pred_w loc_w + + | otherwise + = False + +mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool +mightMatchLater given_pred given_loc wanted_pred wanted_loc + = not (prohibitedSuperClassSolve given_loc wanted_loc) + && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred]) + where + bind_meta_tv :: TcTyVar -> BindFlag + -- Any meta tyvar may be unified later, so we treat it as + -- bindable when unifying with givens. That ensures that we + -- conservatively assume that a meta tyvar might get unified with + -- something that matches the 'given', until demonstrated + -- otherwise. More info in Note [Instance and Given overlap] + -- in GHC.Tc.Solver.Interact + bind_meta_tv tv | isMetaTyVar tv + , not (isFskTyVar tv) = BindMe + | otherwise = Skolem + +prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool +-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance +prohibitedSuperClassSolve from_loc solve_loc + | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc + , ScOrigin wanted_size <- ctLocOrigin solve_loc + = given_size >= wanted_size + | otherwise + = False + +{- Note [Unsolved Derived equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In getUnsolvedInerts, we return a derived equality from the inert_eqs +because it is a candidate for floating out of this implication. We +only float equalities with a meta-tyvar on the left, so we only pull +those out here. + +Note [When does an implication have given equalities?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an implication + beta => alpha ~ Int +where beta is a unification variable that has already been unified +to () in an outer scope. Then we can float the (alpha ~ Int) out +just fine. So when deciding whether the givens contain an equality, +we should canonicalise first, rather than just looking at the original +givens (#8644). + +So we simply look at the inert, canonical Givens and see if there are +any equalities among them, the calculation of has_given_eqs. There +are some wrinkles: + + * We must know which ones are bound in *this* implication and which + are bound further out. We can find that out from the TcLevel + of the Given, which is itself recorded in the tcl_tclvl field + of the TcLclEnv stored in the Given (ev_given_here). + + What about interactions between inner and outer givens? + - Outer given is rewritten by an inner given, then there must + have been an inner given equality, hence the “given-eq” flag + will be true anyway. + + - Inner given rewritten by outer, retains its level (ie. The inner one) + + * We must take account of *potential* equalities, like the one above: + beta => ...blah... + If we still don't know what beta is, we conservatively treat it as potentially + becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. + + * When flattening givens, we generate Given equalities like + : F [a] ~ f, + with Refl evidence, and we *don't* want those to count as an equality + in the givens! After all, the entire flattening business is just an + internal matter, and the evidence does not mention any of the 'givens' + of this implication. So we do not treat inert_funeqs as a 'given equality'. + + * See Note [Let-bound skolems] for another wrinkle + + * We do *not* need to worry about representational equalities, because + these do not affect the ability to float constraints. + +Note [Let-bound skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +If * the inert set contains a canonical Given CTyEqCan (a ~ ty) +and * 'a' is a skolem bound in this very implication, + +then: +a) The Given is pretty much a let-binding, like + f :: (a ~ b->c) => a -> a + Here the equality constraint is like saying + let a = b->c in ... + It is not adding any new, local equality information, + and hence can be ignored by has_given_eqs + +b) 'a' will have been completely substituted out in the inert set, + so we can safely discard it. Notably, it doesn't need to be + returned as part of 'fsks' + +For an example, see #9211. + +See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure +that the right variable is on the left of the equality when both are +tyvars. + +You might wonder whether the skokem really needs to be bound "in the +very same implication" as the equuality constraint. +(c.f. #15009) Consider this: + + data S a where + MkS :: (a ~ Int) => S a + + g :: forall a. S a -> a -> blah + g x y = let h = \z. ( z :: Int + , case x of + MkS -> [y,z]) + in ... + +From the type signature for `g`, we get `y::a` . Then when we +encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the +body of the lambda we'll get + + [W] alpha[1] ~ Int -- From z::Int + [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] + +Now, suppose we decide to float `alpha ~ a` out of the implication +and then unify `alpha := a`. Now we are stuck! But if treat +`alpha ~ Int` first, and unify `alpha := Int`, all is fine. +But we absolutely cannot float that equality or we will get stuck. +-} + +removeInertCts :: [Ct] -> InertCans -> InertCans +-- ^ Remove inert constraints from the 'InertCans', for use when a +-- typechecker plugin wishes to discard a given. +removeInertCts cts icans = foldl' removeInertCt icans cts + +removeInertCt :: InertCans -> Ct -> InertCans +removeInertCt is ct = + case ct of + + CDictCan { cc_class = cl, cc_tyargs = tys } -> + is { inert_dicts = delDict (inert_dicts is) cl tys } + + CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> + is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } + + CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> + is { inert_eqs = delTyEq (inert_eqs is) x ty } + + CQuantCan {} -> panic "removeInertCt: CQuantCan" + CIrredCan {} -> panic "removeInertCt: CIrredEvCan" + CNonCanonical {} -> panic "removeInertCt: CNonCanonical" + +lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) +lookupFlatCache fam_tc tys + = do { IS { inert_flat_cache = flat_cache + , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts + ; return (firstJusts [lookup_inerts inert_funeqs, + lookup_flats flat_cache]) } + where + lookup_inerts inert_funeqs + | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis }) + <- findFunEq inert_funeqs fam_tc tys + , tys `eqTypes` xis -- The lookup might find a near-match; see + -- Note [Use loose types in inert set] + = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) + | otherwise = Nothing + + lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys + + +lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) +-- Is this exact predicate type cached in the solved or canonicals of the InertSet? +lookupInInerts loc pty + | ClassPred cls tys <- classifyPredType pty + = do { inerts <- getTcSInerts + ; return (lookupSolvedDict inerts loc cls tys `mplus` + fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) } + | otherwise -- NB: No caching for equalities, IPs, holes, or errors + = return Nothing + +-- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not +-- match the input exactly. Note [Use loose types in inert set]. +lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct +lookupInertDict (IC { inert_dicts = dicts }) loc cls tys + = case findDict dicts loc cls tys of + Just ct -> Just ct + _ -> Nothing + +-- | Look up a solved inert. NB: the returned 'CtEvidence' might not +-- match the input exactly. See Note [Use loose types in inert set]. +lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence +-- Returns just if exactly this predicate type exists in the solved. +lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys + = case findDict solved loc cls tys of + Just ev -> Just ev + _ -> Nothing + +{- ********************************************************************* +* * + Irreds +* * +********************************************************************* -} + +foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b +foldIrreds k irreds z = foldr k z irreds + + +{- ********************************************************************* +* * + TcAppMap +* * +************************************************************************ + +Note [Use loose types in inert set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly +solvable from the other. So, we do lookup in the inert set using +loose types, which omit the kind-check. + +We must be careful when using the result of a lookup because it may +not match the requested info exactly! + +-} + +type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a) + -- Indexed by tycon then the arg types, using "loose" matching, where + -- we don't require kind equality. This allows, for example, (a |> co) + -- to match (a). + -- See Note [Use loose types in inert set] + -- Used for types and classes; hence UniqDFM + -- See Note [foldTM determinism] for why we use UniqDFM here + +isEmptyTcAppMap :: TcAppMap a -> Bool +isEmptyTcAppMap m = isNullUDFM m + +emptyTcAppMap :: TcAppMap a +emptyTcAppMap = emptyUDFM + +findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a +findTcApp m u tys = do { tys_map <- lookupUDFM m u + ; lookupTM tys tys_map } + +delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a +delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls + +insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a +insertTcApp m cls tys ct = alterUDFM alter_tm m cls + where + alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) + +alterTcApp :: forall a. TcAppMap a -> Unique -> [Type] -> XT a -> TcAppMap a +alterTcApp m cls tys xt_ct = alterUDFM alter_tm m cls + where + alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a) + alter_tm mb_tm = Just (alterTM tys xt_ct (mb_tm `orElse` emptyTM)) + +-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b +-- mapTcApp f = mapUDFM (mapTM f) + +filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct +filterTcAppMap f m + = mapUDFM do_tm m + where + do_tm tm = foldTM insert_mb tm emptyTM + insert_mb ct tm + | f ct = insertTM tys ct tm + | otherwise = tm + where + tys = case ct of + CFunEqCan { cc_tyargs = tys } -> tys + CDictCan { cc_tyargs = tys } -> tys + _ -> pprPanic "filterTcAppMap" (ppr ct) + +tcAppMapToBag :: TcAppMap a -> Bag a +tcAppMapToBag m = foldTcAppMap consBag m emptyBag + +foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b +foldTcAppMap k m z = foldUDFM (foldTM k) z m + + +{- ********************************************************************* +* * + DictMap +* * +********************************************************************* -} + + +{- Note [Tuples hiding implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f,g :: (?x::Int, C a) => a -> a + f v = let ?x = 4 in g v + +The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). +We must /not/ solve this from the Given (?x::Int, C a), because of +the intervening binding for (?x::Int). #14218. + +We deal with this by arranging that we always fail when looking up a +tuple constraint that hides an implicit parameter. Not that this applies + * both to the inert_dicts (lookupInertDict) + * and to the solved_dicts (looukpSolvedDict) +An alternative would be not to extend these sets with such tuple +constraints, but it seemed more direct to deal with the lookup. + +Note [Solving CallStack constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose f :: HasCallStack => blah. Then + +* Each call to 'f' gives rise to + [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f + with a CtOrigin that says "OccurrenceOf f". + Remember that HasCallStack is just shorthand for + IP "callStack CallStack + See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + +* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by + pushing the call-site info on the stack, and changing the CtOrigin + to record that has been done. + Bind: s1 = pushCallStack s2 + [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin + +* Then, and only then, we can solve the constraint from an enclosing + Given. + +So we must be careful /not/ to solve 's1' from the Givens. Again, +we ensure this by arranging that findDict always misses when looking +up souch constraints. +-} + +type DictMap a = TcAppMap a + +emptyDictMap :: DictMap a +emptyDictMap = emptyTcAppMap + +findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a +findDict m loc cls tys + | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters] + = Nothing + + | Just {} <- isCallStackPred cls tys + , OccurrenceOf {} <- ctLocOrigin loc + = Nothing -- See Note [Solving CallStack constraints] + + | otherwise + = findTcApp m (getUnique cls) tys + +findDictsByClass :: DictMap a -> Class -> Bag a +findDictsByClass m cls + | Just tm <- lookupUDFM_Directly m (getUnique cls) = foldTM consBag tm emptyBag + | otherwise = emptyBag + +delDict :: DictMap a -> Class -> [Type] -> DictMap a +delDict m cls tys = delTcApp m (getUnique cls) tys + +addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a +addDict m cls tys item = insertTcApp m (getUnique cls) tys item + +addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct +-- Like addDict, but combines [W] and [D] to [WD] +-- See Note [KeepBoth] in GHC.Tc.Solver.Interact +addDictCt m cls tys new_ct = alterTcApp m (getUnique cls) tys xt_ct + where + new_ct_ev = ctEvidence new_ct + + xt_ct :: Maybe Ct -> Maybe Ct + xt_ct (Just old_ct) + | CtWanted { ctev_nosh = WOnly } <- old_ct_ev + , CtDerived {} <- new_ct_ev + = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }}) + | CtDerived {} <- old_ct_ev + , CtWanted { ctev_nosh = WOnly } <- new_ct_ev + = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }}) + where + old_ct_ev = ctEvidence old_ct + + xt_ct _ = Just new_ct + +addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct +addDictsByClass m cls items + = addToUDFM_Directly m (getUnique cls) (foldr add emptyTM items) + where + add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm + add ct _ = pprPanic "addDictsByClass" (ppr ct) + +filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct +filterDicts f m = filterTcAppMap f m + +partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) +partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) + where + k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) + | otherwise = (yeses, add ct noes) + add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m + = addDict m cls tys ct + add ct _ = pprPanic "partitionDicts" (ppr ct) + +dictsToBag :: DictMap a -> Bag a +dictsToBag = tcAppMapToBag + +foldDicts :: (a -> b -> b) -> DictMap a -> b -> b +foldDicts = foldTcAppMap + +emptyDicts :: DictMap a +emptyDicts = emptyTcAppMap + + +{- ********************************************************************* +* * + FunEqMap +* * +********************************************************************* -} + +type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair + +emptyFunEqs :: TcAppMap a +emptyFunEqs = emptyTcAppMap + +findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a +findFunEq m tc tys = findTcApp m (getUnique tc) tys + +funEqsToBag :: FunEqMap a -> Bag a +funEqsToBag m = foldTcAppMap consBag m emptyBag + +findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] +-- Get inert function equation constraints that have the given tycon +-- in their head. Not that the constraints remain in the inert set. +-- We use this to check for derived interactions with built-in type-function +-- constructors. +findFunEqsByTyCon m tc + | Just tm <- lookupUDFM m (getUnique tc) = foldTM (:) tm [] + | otherwise = [] + +foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b +foldFunEqs = foldTcAppMap + +-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b +-- mapFunEqs = mapTcApp + +-- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct +-- filterFunEqs = filterTcAppMap + +insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a +insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val + +partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) +-- Optimise for the case where the predicate is false +-- partitionFunEqs is called only from kick-out, and kick-out usually +-- kicks out very few equalities, so we want to optimise for that case +partitionFunEqs f m = (yeses, foldr del m yeses) + where + yeses = foldTcAppMap k m [] + k ct yeses | f ct = ct : yeses + | otherwise = yeses + del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m + = delFunEq m tc tys + del ct _ = pprPanic "partitionFunEqs" (ppr ct) + +delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a +delFunEq m tc tys = delTcApp m (getUnique tc) tys + +------------------------------ +type ExactFunEqMap a = UniqFM TyCon (ListMap TypeMap a) + +emptyExactFunEqs :: ExactFunEqMap a +emptyExactFunEqs = emptyUFM + +findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a +findExactFunEq m tc tys = do { tys_map <- lookupUFM m tc + ; lookupTM tys tys_map } + +insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a +insertExactFunEq m tc tys val = alterUFM alter_tm m tc + where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) + +{- +************************************************************************ +* * +* The TcS solver monad * +* * +************************************************************************ + +Note [The TcS monad] +~~~~~~~~~~~~~~~~~~~~ +The TcS monad is a weak form of the main Tc monad + +All you can do is + * fail + * allocate new variables + * fill in evidence variables + +Filling in a dictionary evidence variable means to create a binding +for it, so TcS carries a mutable location where the binding can be +added. This is initialised from the innermost implication constraint. +-} + +data TcSEnv + = TcSEnv { + tcs_ev_binds :: EvBindsVar, + + tcs_unified :: IORef Int, + -- The number of unification variables we have filled + -- The important thing is whether it is non-zero + + tcs_count :: IORef Int, -- Global step count + + tcs_inerts :: IORef InertSet, -- Current inert set + + -- The main work-list and the flattening worklist + -- See Note [Work list priorities] and + tcs_worklist :: IORef WorkList -- Current worklist + } + +--------------- +newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) + +instance Applicative TcS where + pure x = TcS (\_ -> return x) + (<*>) = ap + +instance Monad TcS where + m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) + +instance MonadFail TcS where + fail err = TcS (\_ -> fail err) + +instance MonadUnique TcS where + getUniqueSupplyM = wrapTcS getUniqueSupplyM + +instance HasModule TcS where + getModule = wrapTcS getModule + +instance MonadThings TcS where + lookupThing n = wrapTcS (lookupThing n) + +-- Basic functionality +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +wrapTcS :: TcM a -> TcS a +-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, +-- and TcS is supposed to have limited functionality +wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds + +wrapErrTcS :: TcM a -> TcS a +-- The thing wrapped should just fail +-- There's no static check; it's up to the user +-- Having a variant for each error message is too painful +wrapErrTcS = wrapTcS + +wrapWarnTcS :: TcM a -> TcS a +-- The thing wrapped should just add a warning, or no-op +-- There's no static check; it's up to the user +wrapWarnTcS = wrapTcS + +failTcS, panicTcS :: SDoc -> TcS a +warnTcS :: WarningFlag -> SDoc -> TcS () +addErrTcS :: SDoc -> TcS () +failTcS = wrapTcS . TcM.failWith +warnTcS flag = wrapTcS . TcM.addWarn (Reason flag) +addErrTcS = wrapTcS . TcM.addErr +panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc + +traceTcS :: String -> SDoc -> TcS () +traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) +{-# INLINE traceTcS #-} -- see Note [INLINE conditional tracing utilities] + +runTcPluginTcS :: TcPluginM a -> TcS a +runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar + +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + +getGlobalRdrEnvTcS :: TcS GlobalRdrEnv +getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv + +bumpStepCountTcS :: TcS () +bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env + ; n <- TcM.readTcRef ref + ; TcM.writeTcRef ref (n+1) } + +csTraceTcS :: SDoc -> TcS () +csTraceTcS doc + = wrapTcS $ csTraceTcM (return doc) +{-# INLINE csTraceTcS #-} -- see Note [INLINE conditional tracing utilities] + +traceFireTcS :: CtEvidence -> SDoc -> TcS () +-- Dump a rule-firing trace +traceFireTcS ev doc + = TcS $ \env -> csTraceTcM $ + do { n <- TcM.readTcRef (tcs_count env) + ; tclvl <- TcM.getTcLevel + ; return (hang (text "Step" <+> int n + <> brackets (text "l:" <> ppr tclvl <> comma <> + text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) + <+> doc <> colon) + 4 (ppr ev)) } +{-# INLINE traceFireTcS #-} -- see Note [INLINE conditional tracing utilities] + +csTraceTcM :: TcM SDoc -> TcM () +-- Constraint-solver tracing, -ddump-cs-trace +csTraceTcM mk_doc + = do { dflags <- getDynFlags + ; when ( dopt Opt_D_dump_cs_trace dflags + || dopt Opt_D_dump_tc_trace dflags ) + ( do { msg <- mk_doc + ; TcM.dumpTcRn False + (dumpOptionsFromFlag Opt_D_dump_cs_trace) + "" FormatText + msg }) } +{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] + +runTcS :: TcS a -- What to run + -> TcM (a, EvBindMap) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; return (res, ev_binds) } + +-- | This variant of 'runTcS' will keep solving, even when only Deriveds +-- are left around. It also doesn't return any evidence, as callers won't +-- need it. +runTcSDeriveds :: TcS a -> TcM a +runTcSDeriveds tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds ev_binds_var tcs } + +-- | This can deal only with equality constraints. +runTcSEqualities :: TcS a -> TcM a +runTcSEqualities thing_inside + = do { ev_binds_var <- TcM.newNoTcEvBinds + ; runTcSWithEvBinds ev_binds_var thing_inside } + +runTcSWithEvBinds :: EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds ev_binds_var tcs + = do { unified_var <- TcM.newTcRef 0 + ; step_count <- TcM.newTcRef 0 + ; inert_var <- TcM.newTcRef emptyInert + ; wl_var <- TcM.newTcRef emptyWorkList + ; let env = TcSEnv { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_count = step_count + , tcs_inerts = inert_var + , tcs_worklist = wl_var } + + -- Run the computation + ; res <- unTcS tcs env + + ; count <- TcM.readTcRef step_count + ; when (count > 0) $ + csTraceTcM $ return (text "Constraint solver steps =" <+> int count) + + ; unflattenGivens inert_var + +#if defined(DEBUG) + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; checkForCyclicBinds ev_binds +#endif + + ; return res } + +---------------------------- +#if defined(DEBUG) +checkForCyclicBinds :: EvBindMap -> TcM () +checkForCyclicBinds ev_binds_map + | null cycles + = return () + | null coercion_cycles + = TcM.traceTc "Cycle in evidence binds" $ ppr cycles + | otherwise + = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles + where + ev_binds = evBindMapBinds ev_binds_map + + cycles :: [[EvBind]] + cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] + + coercion_cycles = [c | c <- cycles, any is_co_bind c] + is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b) + + edges :: [ Node EvVar EvBind ] + edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs)) + | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic even + -- if the edges are in nondeterministic order as explained in + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. +#endif + +---------------------------- +setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a +setEvBindsTcS ref (TcS thing_inside) + = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) + +nestImplicTcS :: EvBindsVar + -> TcLevel -> TcS a + -> TcS a +nestImplicTcS ref inner_tclvl (TcS thing_inside) + = TcS $ \ TcSEnv { tcs_unified = unified_var + , tcs_inerts = old_inert_var + , tcs_count = count + } -> + do { inerts <- TcM.readTcRef old_inert_var + ; let nest_inert = emptyInert + { inert_cans = inert_cans inerts + , inert_solved_dicts = inert_solved_dicts inerts } + -- See Note [Do not inherit the flat cache] + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = TcSEnv { tcs_ev_binds = ref + , tcs_unified = unified_var + , tcs_count = count + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + ; res <- TcM.setTcLevel inner_tclvl $ + thing_inside nest_env + + ; unflattenGivens new_inert_var + +#if defined(DEBUG) + -- Perform a check that the thing_inside did not cause cycles + ; ev_binds <- TcM.getTcEvBindsMap ref + ; checkForCyclicBinds ev_binds +#endif + ; return res } + +{- Note [Do not inherit the flat cache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want to inherit the flat cache when processing nested +implications. Consider + a ~ F b, forall c. b~Int => blah +If we have F b ~ fsk in the flat-cache, and we push that into the +nested implication, we might miss that F b can be rewritten to F Int, +and hence perhaps solve it. Moreover, the fsk from outside is +flattened out after solving the outer level, but and we don't +do that flattening recursively. +-} + +nestTcS :: TcS a -> TcS a +-- Use the current untouchables, augmenting the current +-- evidence bindings, and solved dictionaries +-- But have no effect on the InertCans, or on the inert_flat_cache +-- (we want to inherit the latter from processing the Givens) +nestTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> + do { inerts <- TcM.readTcRef inerts_var + ; new_inert_var <- TcM.newTcRef inerts + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + + ; res <- thing_inside nest_env + + ; new_inerts <- TcM.readTcRef new_inert_var + + -- we want to propagate the safe haskell failures + ; let old_ic = inert_cans inerts + new_ic = inert_cans new_inerts + nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } + + ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] + (inerts { inert_solved_dicts = inert_solved_dicts new_inerts + , inert_cans = nxt_ic }) + + ; return res } + +emitImplicationTcS :: TcLevel -> SkolemInfo + -> [TcTyVar] -- Skolems + -> [EvVar] -- Givens + -> Cts -- Wanteds + -> TcS TcEvBinds +-- Add an implication to the TcS monad work-list +emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds + = do { let wc = emptyWC { wc_simple = wanteds } + ; imp <- wrapTcS $ + do { ev_binds_var <- TcM.newTcEvBinds + ; imp <- TcM.newImplication + ; return (imp { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_given = givens + , ic_wanted = wc + , ic_binds = ev_binds_var + , ic_info = skol_info }) } + + ; emitImplication imp + ; return (TcEvBinds (ic_binds imp)) } + +emitTvImplicationTcS :: TcLevel -> SkolemInfo + -> [TcTyVar] -- Skolems + -> Cts -- Wanteds + -> TcS () +-- Just like emitImplicationTcS but no givens and no bindings +emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds + = do { let wc = emptyWC { wc_simple = wanteds } + ; imp <- wrapTcS $ + do { ev_binds_var <- TcM.newNoTcEvBinds + ; imp <- TcM.newImplication + ; return (imp { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_wanted = wc + , ic_binds = ev_binds_var + , ic_info = skol_info }) } + + ; emitImplication imp } + + +{- Note [Propagate the solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really quite important that nestTcS does not discard the solved +dictionaries from the thing_inside. +Consider + Eq [a] + forall b. empty => Eq [a] +We solve the simple (Eq [a]), under nestTcS, and then turn our attention to +the implications. It's definitely fine to use the solved dictionaries on +the inner implications, and it can make a significant performance difference +if you do so. +-} + +-- Getters and setters of GHC.Tc.Utils.Env fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- Getter of inerts and worklist +getTcSInertsRef :: TcS (IORef InertSet) +getTcSInertsRef = TcS (return . tcs_inerts) + +getTcSWorkListRef :: TcS (IORef WorkList) +getTcSWorkListRef = TcS (return . tcs_worklist) + +getTcSInerts :: TcS InertSet +getTcSInerts = getTcSInertsRef >>= readTcRef + +setTcSInerts :: InertSet -> TcS () +setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics } + +getWorkListImplics :: TcS (Bag Implication) +getWorkListImplics + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- readTcRef wl_var + ; return (wl_implics wl_curr) } + +pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) +-- Push the level and run thing_inside +-- However, thing_inside should not generate any work items +#if defined(DEBUG) +pushLevelNoWorkList err_doc (TcS thing_inside) + = TcS (\env -> TcM.pushTcLevelM $ + thing_inside (env { tcs_worklist = wl_panic }) + ) + where + wl_panic = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc + -- This panic checks that the thing-inside + -- does not emit any work-list constraints +#else +pushLevelNoWorkList _ (TcS thing_inside) + = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check +#endif + +updWorkListTcS :: (WorkList -> WorkList) -> TcS () +updWorkListTcS f + = do { wl_var <- getTcSWorkListRef + ; updTcRef wl_var f } + +emitWorkNC :: [CtEvidence] -> TcS () +emitWorkNC evs + | null evs + = return () + | otherwise + = emitWork (map mkNonCanonical evs) + +emitWork :: [Ct] -> TcS () +emitWork [] = return () -- avoid printing, among other work +emitWork cts + = do { traceTcS "Emitting fresh work" (vcat (map ppr cts)) + ; updWorkListTcS (extendWorkListCts cts) } + +emitImplication :: Implication -> TcS () +emitImplication implic + = updWorkListTcS (extendWorkListImplic implic) + +newTcRef :: a -> TcS (TcRef a) +newTcRef x = wrapTcS (TcM.newTcRef x) + +readTcRef :: TcRef a -> TcS a +readTcRef ref = wrapTcS (TcM.readTcRef ref) + +writeTcRef :: TcRef a -> a -> TcS () +writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) + +updTcRef :: TcRef a -> (a->a) -> TcS () +updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) + +getTcEvBindsVar :: TcS EvBindsVar +getTcEvBindsVar = TcS (return . tcs_ev_binds) + +getTcLevel :: TcS TcLevel +getTcLevel = wrapTcS TcM.getTcLevel + +getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet +getTcEvTyCoVars ev_binds_var + = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var + +getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap +getTcEvBindsMap ev_binds_var + = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var + +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () +setTcEvBindsMap ev_binds_var binds + = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds + +unifyTyVar :: TcTyVar -> TcType -> TcS () +-- Unify a meta-tyvar with a type +-- We keep track of how many unifications have happened in tcs_unified, +-- +-- We should never unify the same variable twice! +unifyTyVar tv ty + = ASSERT2( isMetaTyVar tv, ppr tv ) + TcS $ \ env -> + do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) + ; TcM.writeMetaTyVar tv ty + ; TcM.updTcRef (tcs_unified env) (+1) } + +reportUnifications :: TcS a -> TcS (Int, a) +reportUnifications (TcS thing_inside) + = TcS $ \ env -> + do { inner_unified <- TcM.newTcRef 0 + ; res <- thing_inside (env { tcs_unified = inner_unified }) + ; n_unifs <- TcM.readTcRef inner_unified + ; TcM.updTcRef (tcs_unified env) (+ n_unifs) + ; return (n_unifs, res) } + +getDefaultInfo :: TcS ([Type], (Bool, Bool)) +getDefaultInfo = wrapTcS TcM.tcGetDefaultTys + +-- Just get some environments needed for instance looking up and matching +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +getInstEnvs :: TcS InstEnvs +getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs + +getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) +getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs + +getTopEnv :: TcS HscEnv +getTopEnv = wrapTcS $ TcM.getTopEnv + +getGblEnv :: TcS TcGblEnv +getGblEnv = wrapTcS $ TcM.getGblEnv + +getLclEnv :: TcS TcLclEnv +getLclEnv = wrapTcS $ TcM.getLclEnv + +tcLookupClass :: Name -> TcS Class +tcLookupClass c = wrapTcS $ TcM.tcLookupClass c + +tcLookupId :: Name -> TcS Id +tcLookupId n = wrapTcS $ TcM.tcLookupId n + +-- Setting names as used (used in the deriving of Coercible evidence) +-- Too hackish to expose it to TcS? In that case somehow extract the used +-- constructors from the result of solveInteract +addUsedGREs :: [GlobalRdrElt] -> TcS () +addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres + +addUsedGRE :: Bool -> GlobalRdrElt -> TcS () +addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre + +keepAlive :: Name -> TcS () +keepAlive = wrapTcS . TcM.keepAlive + +-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS () +-- Check that we do not try to use an instance before it is available. E.g. +-- instance Eq T where ... +-- f x = $( ... (\(p::T) -> p == p)... ) +-- Here we can't use the equality function from the instance in the splice + +checkWellStagedDFun loc what pred + | TopLevInstance { iw_dfun_id = dfun_id } <- what + , let bind_lvl = TcM.topIdLvl dfun_id + , bind_lvl > impLevel + = wrapTcS $ TcM.setCtLocM loc $ + do { use_stage <- TcM.getStage + ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } + + | otherwise + = return () -- Fast path for common case + where + pp_thing = text "instance for" <+> quotes (ppr pred) + +pprEq :: TcType -> TcType -> SDoc +pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 + +isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) +isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv) + +isFilledMetaTyVar :: TcTyVar -> TcS Bool +isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) + +zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet +zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs) + +zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] +zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs) + +zonkCo :: Coercion -> TcS Coercion +zonkCo = wrapTcS . TcM.zonkCo + +zonkTcType :: TcType -> TcS TcType +zonkTcType ty = wrapTcS (TcM.zonkTcType ty) + +zonkTcTypes :: [TcType] -> TcS [TcType] +zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys) + +zonkTcTyVar :: TcTyVar -> TcS TcType +zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv) + +zonkSimples :: Cts -> TcS Cts +zonkSimples cts = wrapTcS (TcM.zonkSimples cts) + +zonkWC :: WantedConstraints -> TcS WantedConstraints +zonkWC wc = wrapTcS (TcM.zonkWC wc) + +zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar +zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv) + +{- ********************************************************************* +* * +* Flatten skolems * +* * +********************************************************************* -} + +newFlattenSkolem :: CtFlavour -> CtLoc + -> TyCon -> [TcType] -- F xis + -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk +newFlattenSkolem flav loc tc xis + = do { stuff@(ev, co, fsk) <- new_skolem + ; let fsk_ty = mkTyVarTy fsk + ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) + ; return stuff } + where + fam_ty = mkTyConApp tc xis + + new_skolem + | Given <- flav + = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty) + + -- Extend the inert_fsks list, for use by unflattenGivens + ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is } + + -- Construct the Refl evidence + ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk) + co = mkNomReflCo fam_ty + ; ev <- newGivenEvVar loc (pred, evCoercion co) + ; return (ev, co, fsk) } + + | otherwise -- Generate a [WD] for both Wanted and Derived + -- See Note [No Derived CFunEqCans] + = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty) + -- See (2a) in "GHC.Tc.Solver.Canonical" + -- Note [Equalities with incompatible kinds] + ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal + fam_ty (mkTyVarTy fmv) + ; return (ev, hole_co, fmv) } + +---------------------------- +unflattenGivens :: IORef InertSet -> TcM () +-- Unflatten all the fsks created by flattening types in Given +-- constraints. We must be sure to do this, else we end up with +-- flatten-skolems buried in any residual Wanteds +-- +-- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv) +-- is filled in. Nothing else does so. +-- +-- It's here (rather than in GHC.Tc.Solver.Flatten) because the Right Places +-- to call it are in runTcSWithEvBinds/nestImplicTcS, where it +-- is nicely paired with the creation an empty inert_fsks list. +unflattenGivens inert_var + = do { inerts <- TcM.readTcRef inert_var + ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts)) + ; mapM_ flatten_one (inert_fsks inerts) } + where + flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty + +---------------------------- +extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () +extendFlatCache tc xi_args stuff@(_, ty, fl) + | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache + -- only has [G] and [WD] CFunEqCans + = do { dflags <- getDynFlags + ; when (gopt Opt_FlatCache dflags) $ + do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args + , ppr fl, ppr ty ]) + -- 'co' can be bottom, in the case of derived items + ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> + is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } } + + | otherwise + = return () + +---------------------------- +unflattenFmv :: TcTyVar -> TcType -> TcS () +-- Fill a flatten-meta-var, simply by unifying it. +-- This does NOT count as a unification in tcs_unified. +unflattenFmv tv ty + = ASSERT2( isMetaTyVar tv, ppr tv ) + TcS $ \ _ -> + do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty) + ; TcM.writeMetaTyVar tv ty } + +---------------------------- +demoteUnfilledFmv :: TcTyVar -> TcS () +-- If a flatten-meta-var is still un-filled, +-- turn it into an ordinary meta-var +demoteUnfilledFmv fmv + = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv + ; unless is_filled $ + do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) + ; TcM.writeMetaTyVar fmv tv_ty } } + +----------------------------- +dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () +-- (dischargeFunEq tv co ty) +-- Preconditions +-- - ev :: F tys ~ tv is a CFunEqCan +-- - tv is a FlatMetaTv of FlatSkolTv +-- - co :: F tys ~ xi +-- - fmv/fsk `notElem` xi +-- - fmv not filled (for Wanteds) +-- - xi is flattened (and obeys Note [Almost function-free] in GHC.Tc.Types) +-- +-- Then for [W] or [WD], we actually fill in the fmv: +-- set fmv := xi, +-- set ev := co +-- kick out any inert things that are now rewritable +-- +-- For [D], we instead emit an equality that must ultimately hold +-- [D] xi ~ fmv +-- Does not evaluate 'co' if 'ev' is Derived +-- +-- For [G], emit this equality +-- [G] (sym ev; co) :: fsk ~ xi + +-- See GHC.Tc.Solver.Flatten Note [The flattening story], +-- especially "Ownership of fsk/fmv" +dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi + = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co ) + ; emitWorkNC [new_ev] } + where + new_pred = mkPrimEqPred (mkTyVarTy fsk) xi + new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co + +dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi + = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) + do { setWantedEvTerm dest (evCoercion co) + ; unflattenFmv fmv xi + ; n_kicked <- kickOutAfterUnification fmv + ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) } + +dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi + = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv) + -- FunEqs are always at Nominal role + +pprKicked :: Int -> SDoc +pprKicked 0 = empty +pprKicked n = parens (int n <+> text "kicked out") + +{- ********************************************************************* +* * +* Instantiation etc. +* * +********************************************************************* -} + +-- Instantiations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) +instDFunType dfun_id inst_tys + = wrapTcS $ TcM.instDFunType dfun_id inst_tys + +newFlexiTcSTy :: Kind -> TcS TcType +newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) + +cloneMetaTyVar :: TcTyVar -> TcS TcTyVar +cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) + +instFlexi :: [TKVar] -> TcS TCvSubst +instFlexi = instFlexiX emptyTCvSubst + +instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst +instFlexiX subst tvs + = wrapTcS (foldlM instFlexiHelper subst tvs) + +instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst +instFlexiHelper subst tv + = do { uniq <- TcM.newUnique + ; details <- TcM.newMetaDetails TauTv + ; let name = setNameUnique (tyVarName tv) uniq + kind = substTyUnchecked subst (tyVarKind tv) + ty' = mkTyVarTy (mkTcTyVar name kind details) + ; TcM.traceTc "instFlexi" (ppr ty') + ; return (extendTvSubst subst tv ty') } + +matchGlobalInst :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcS TcM.ClsInstResult +matchGlobalInst dflags short_cut cls tys + = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) + +tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs + +-- Creating and setting evidence variables and CtFlavors +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data MaybeNew = Fresh CtEvidence | Cached EvExpr + +isFresh :: MaybeNew -> Bool +isFresh (Fresh {}) = True +isFresh (Cached {}) = False + +freshGoals :: [MaybeNew] -> [CtEvidence] +freshGoals mns = [ ctev | Fresh ctev <- mns ] + +getEvExpr :: MaybeNew -> EvExpr +getEvExpr (Fresh ctev) = ctEvExpr ctev +getEvExpr (Cached evt) = evt + +setEvBind :: EvBind -> TcS () +setEvBind ev_bind + = do { evb <- getTcEvBindsVar + ; wrapTcS $ TcM.addTcEvBind evb ev_bind } + +-- | Mark variables as used filling a coercion hole +useVars :: CoVarSet -> TcS () +useVars co_vars + = do { ev_binds_var <- getTcEvBindsVar + ; let ref = ebv_tcvs ev_binds_var + ; wrapTcS $ + do { tcvs <- TcM.readTcRef ref + ; let tcvs' = tcvs `unionVarSet` co_vars + ; TcM.writeTcRef ref tcvs' } } + +-- | Equalities only +setWantedEq :: TcEvDest -> Coercion -> TcS () +setWantedEq (HoleDest hole) co + = do { useVars (coVarsOfCo co) + ; fillCoercionHole hole co } +setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev) + +-- | Good for both equalities and non-equalities +setWantedEvTerm :: TcEvDest -> EvTerm -> TcS () +setWantedEvTerm (HoleDest hole) tm + | Just co <- evTermCoercion_maybe tm + = do { useVars (coVarsOfCo co) + ; fillCoercionHole hole co } + | otherwise + = -- See Note [Yukky eq_sel for a HoleDest] + do { let co_var = coHoleCoVar hole + ; setEvBind (mkWantedEvBind co_var tm) + ; fillCoercionHole hole (mkTcCoVarCo co_var) } + +setWantedEvTerm (EvVarDest ev_id) tm + = setEvBind (mkWantedEvBind ev_id tm) + +{- Note [Yukky eq_sel for a HoleDest] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How can it be that a Wanted with HoleDest gets evidence that isn't +just a coercion? i.e. evTermCoercion_maybe returns Nothing. + +Consider [G] forall a. blah => a ~ T + [W] S ~# T + +Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ +T) in the quantified constraints, and wraps the (boxed) evidence it +gets back in an eq_sel to extract the unboxed (S ~# T). We can't put +that term into a coercion, so we add a value binding + h = eq_sel (...) +and the coercion variable h to fill the coercion hole. +We even re-use the CoHole's Id for this binding! + +Yuk! +-} + +fillCoercionHole :: CoercionHole -> Coercion -> TcS () +fillCoercionHole hole co + = do { wrapTcS $ TcM.fillCoercionHole hole co + ; kickOutAfterFillingCoercionHole hole } + +setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () +setEvBindIfWanted ev tm + = case ev of + CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm + _ -> return () + +newTcEvBinds :: TcS EvBindsVar +newTcEvBinds = wrapTcS TcM.newTcEvBinds + +newNoTcEvBinds :: TcS EvBindsVar +newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds + +newEvVar :: TcPredType -> TcS EvVar +newEvVar pred = wrapTcS (TcM.newEvVar pred) + +newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence +-- Make a new variable of the given PredType, +-- immediately bind it to the given term +-- and return its CtEvidence +-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint +newGivenEvVar loc (pred, rhs) + = do { new_ev <- newBoundEvVarId pred rhs + ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } + +-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the +-- given term +newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar +newBoundEvVarId pred rhs + = do { new_ev <- newEvVar pred + ; setEvBind (mkGivenEvBind new_ev rhs) + ; return new_ev } + +newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] +newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts + +emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion +-- | Emit a new Wanted equality into the work-list +emitNewWantedEq loc role ty1 ty2 + = do { (ev, co) <- newWantedEq loc role ty1 ty2 + ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) + ; return co } + +-- | Make a new equality CtEvidence +newWantedEq :: CtLoc -> Role -> TcType -> TcType + -> TcS (CtEvidence, Coercion) +newWantedEq = newWantedEq_SI YesBlockSubst WDeriv + +newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role + -> TcType -> TcType + -> TcS (CtEvidence, Coercion) +newWantedEq_SI blocker si loc role ty1 ty2 + = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty + ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) + ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole + , ctev_nosh = si + , ctev_loc = loc} + , mkHoleCo hole ) } + where + pty = mkPrimEqPredRole role ty1 ty2 + +-- no equalities here. Use newWantedEq instead +newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence +newWantedEvVarNC = newWantedEvVarNC_SI WDeriv + +newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC_SI si loc pty + = do { new_ev <- newEvVar pty + ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ + pprCtLoc loc) + ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev + , ctev_nosh = si + , ctev_loc = loc })} + +newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew +newWantedEvVar = newWantedEvVar_SI WDeriv + +newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew +-- For anything except ClassPred, this is the same as newWantedEvVarNC +newWantedEvVar_SI si loc pty + = do { mb_ct <- lookupInInerts loc pty + ; case mb_ct of + Just ctev + | not (isDerived ctev) + -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev + ; return $ Cached (ctEvExpr ctev) } + _ -> do { ctev <- newWantedEvVarNC_SI si loc pty + ; return (Fresh ctev) } } + +newWanted :: CtLoc -> PredType -> TcS MaybeNew +-- Deals with both equalities and non equalities. Tries to look +-- up non-equalities in the cache +newWanted = newWanted_SI WDeriv + +newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew +newWanted_SI si loc pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2 + | otherwise + = newWantedEvVar_SI si loc pty + +-- deals with both equalities and non equalities. Doesn't do any cache lookups. +newWantedNC :: CtLoc -> PredType -> TcS CtEvidence +newWantedNC loc pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = fst <$> newWantedEq loc role ty1 ty2 + | otherwise + = newWantedEvVarNC loc pty + +emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS () +emitNewDeriveds loc preds + | null preds + = return () + | otherwise + = do { evs <- mapM (newDerivedNC loc) preds + ; traceTcS "Emitting new deriveds" (ppr evs) + ; updWorkListTcS (extendWorkListDeriveds evs) } + +emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS () +-- Create new equality Derived and put it in the work list +-- There's no caching, no lookupInInerts +emitNewDerivedEq loc role ty1 ty2 + = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2) + ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc) + ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) } + -- Very important: put in the wl_eqs + -- See Note [Prioritise equalities] (Avoiding fundep iteration) + +newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence +newDerivedNC loc pred + = do { -- checkReductionDepth loc pred + ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) } + +-- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? --------- +-- | Checks if the depth of the given location is too much. Fails if +-- it's too big, with an appropriate error message. +checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced + -> TcS () +checkReductionDepth loc ty + = do { dflags <- getDynFlags + ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $ + wrapErrTcS $ + solverDepthErrorTcS loc ty } + +matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType)) +-- Given (F tys) return (ty, co), where co :: F tys ~N ty +matchFam tycon args = wrapTcS $ matchFamTcM tycon args + +matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType)) +-- Given (F tys) return (ty, co), where co :: F tys ~N ty +matchFamTcM tycon args + = do { fam_envs <- FamInst.tcGetFamInstEnvs + ; let match_fam_result + = reduceTyFamApp_maybe fam_envs Nominal tycon args + ; TcM.traceTc "matchFamTcM" $ + vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) + , ppr_res match_fam_result ] + ; return match_fam_result } + where + ppr_res Nothing = text "Match failed" + ppr_res (Just (co,ty)) = hang (text "Match succeeded:") + 2 (vcat [ text "Rewrites to:" <+> ppr ty + , text "Coercion:" <+> ppr co ]) + +{- +Note [Residual implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wl_implics in the WorkList are the residual implication +constraints that are generated while solving or canonicalising the +current worklist. Specifically, when canonicalising + (forall a. t1 ~ forall a. t2) +from which we get the implication + (forall a. t1 ~ t2) +See GHC.Tc.Solver.Monad.deferTcSForAllEq +-} diff --git a/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl.hs @@ -0,0 +1,4955 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck type and class declarations +module GHC.Tc.TyCl ( + tcTyAndClassDecls, + + -- Functions used by GHC.Tc.TyCl.Instance to check + -- data/type family instance declarations + kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon, + tcFamTyPats, tcTyFamInstEqn, + tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, + unravelFamInstPats, addConsistencyConstraints, + wrongKindOfFamily + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Driver.Types +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Validity +import GHC.Tc.Utils.Zonk +import GHC.Tc.TyCl.Utils +import GHC.Tc.TyCl.Class +import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) +import GHC.Tc.Deriv (DerivInfo(..)) +import GHC.Tc.Utils.Unify ( checkTvConstraints ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Class( AssocInstInfo(..) ) +import GHC.Tc.Utils.TcMType +import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) +import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity +import GHC.Rename.Env( lookupConstructorFields ) +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Tc.Types.Origin +import GHC.Core.Type +import GHC.Core.TyCo.Rep -- for checkValidRoles +import GHC.Core.TyCo.Ppr( pprTyVars ) +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Unit.Module +import GHC.Unit.State +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Utils.Outputable +import GHC.Data.Maybe +import GHC.Core.Unify +import GHC.Utils.Misc +import GHC.Types.SrcLoc +import GHC.Data.List.SetOps +import GHC.Driver.Session +import GHC.Types.Unique +import GHC.Core.ConLike( ConLike(..) ) +import GHC.Types.Basic +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Function ( on ) +import Data.Functor.Identity +import Data.List +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.Set as Set +import Data.Tuple( swap ) + +{- +************************************************************************ +* * +\subsection{Type checking for type and class declarations} +* * +************************************************************************ + +Note [Grouping of type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly +connected component of mutually dependent types and classes. We kind check and +type check each group separately to enhance kind polymorphism. Take the +following example: + + type Id a = a + data X = X (Id Int) + +If we were to kind check the two declarations together, we would give Id the +kind * -> *, since we apply it to an Int in the definition of X. But we can do +better than that, since Id really is kind polymorphic, and should get kind +forall (k::*). k -> k. Since it does not depend on anything else, it can be +kind-checked by itself, hence getting the most general kind. We then kind check +X, which works fine because we then know the polymorphic kind of Id, and simply +instantiate k to *. + +Note [Check role annotations in a second pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Role inference potentially depends on the types of all of the datacons declared +in a mutually recursive group. The validity of a role annotation, in turn, +depends on the result of role inference. Because the types of datacons might +be ill-formed (see #7175 and Note [Checking GADT return types]) we must check +*all* the tycons in a group for validity before checking *any* of the roles. +Thus, we take two passes over the resulting tycons, first checking for general +validity and then checking for valid role annotations. +-} + +tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in + -- dependency order + -> TcM ( TcGblEnv -- Input env extended by types and + -- classes + -- and their implicit Ids,DataCons + , [InstInfo GhcRn] -- Source-code instance decls info + , [DerivInfo] -- Deriving info + ) +-- Fails if there are any errors +tcTyAndClassDecls tyclds_s + -- The code recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + -- Type check each group in dependency order folding the global env + = checkNoErrs $ fold_env [] [] tyclds_s + where + fold_env :: [InstInfo GhcRn] + -> [DerivInfo] + -> [TyClGroup GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) + fold_env inst_info deriv_info [] + = do { gbl_env <- getGblEnv + ; return (gbl_env, inst_info, deriv_info) } + fold_env inst_info deriv_info (tyclds:tyclds_s) + = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds + ; setGblEnv tcg_env $ + -- remaining groups are typechecked in the extended global env. + fold_env (inst_info' ++ inst_info) + (deriv_info' ++ deriv_info) + tyclds_s } + +tcTyClGroup :: TyClGroup GhcRn + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) +-- Typecheck one strongly-connected component of type, class, and instance decls +-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls +tcTyClGroup (TyClGroup { group_tyclds = tyclds + , group_roles = roles + , group_kisigs = kisigs + , group_instds = instds }) + = do { let role_annots = mkRoleAnnotEnv roles + + -- Step 1: Typecheck the standalone kind signatures and type/class declarations + ; traceTc "---- tcTyClGroup ---- {" empty + ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) + ; (tyclss, data_deriv_info) <- + tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] + do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs + ; tcTyClDecls tyclds kisig_env role_annots } + + -- Step 1.5: Make sure we don't have any type synonym cycles + ; traceTc "Starting synonym cycle check" (ppr tyclss) + ; this_uid <- fmap homeUnit getDynFlags + ; checkSynCycles this_uid tyclss tyclds + ; traceTc "Done synonym cycle check" (ppr tyclss) + + -- Step 2: Perform the validity check on those types/classes + -- We can do this now because we are done with the recursive knot + -- Do it before Step 3 (adding implicit things) because the latter + -- expects well-formed TyCons + ; traceTc "Starting validity check" (ppr tyclss) + ; tyclss <- concatMapM checkValidTyCl tyclss + ; traceTc "Done validity check" (ppr tyclss) + ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss + -- See Note [Check role annotations in a second pass] + + ; traceTc "---- end tcTyClGroup ---- }" empty + + -- Step 3: Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; gbl_env <- addTyConsToGblEnv tyclss + + -- Step 4: check instance declarations + ; (gbl_env', inst_info, datafam_deriv_info) <- + setGblEnv gbl_env $ + tcInstDecls1 instds + + ; let deriv_info = datafam_deriv_info ++ data_deriv_info + ; return (gbl_env', inst_info, deriv_info) } + +-- Gives the kind for every TyCon that has a standalone kind signature +type KindSigEnv = NameEnv Kind + +tcTyClDecls + :: [LTyClDecl GhcRn] + -> KindSigEnv + -> RoleAnnotEnv + -> TcM ([TyCon], [DerivInfo]) +tcTyClDecls tyclds kisig_env role_annots + = do { -- Step 1: kind-check this group and returns the final + -- (possibly-polymorphic) kind of each TyCon and Class + -- See Note [Kind checking for type and class decls] + tc_tycons <- kcTyClGroup kisig_env tyclds + ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) + + -- Step 2: type-check all groups together, returning + -- the final TyCons and Classes + -- + -- NB: We have to be careful here to NOT eagerly unfold + -- type synonyms, as we have not tested for type synonym + -- loops yet and could fall into a black hole. + ; fixM $ \ ~(rec_tyclss, _) -> do + { tcg_env <- getGblEnv + ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss + + -- Populate environment with knot-tied ATyCon for TyCons + -- NB: if the decls mention any ill-staged data cons + -- (see Note [Recursion and promoting data constructors]) + -- we will have failed already in kcTyClGroup, so no worries here + ; (tycons, data_deriv_infos) <- + tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ + + -- Also extend the local type envt with bindings giving + -- a TcTyCon for each knot-tied TyCon or Class + -- See Note [Type checking recursive type and class declarations] + -- and Note [Type environment evolution] + tcExtendKindEnvWithTyCons tc_tycons $ + + -- Kind and type check declarations for this group + mapAndUnzipM (tcTyClDecl roles) tyclds + ; return (tycons, concat data_deriv_infos) + } } + where + ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma + , ppr (tyConBinders tc) <> comma + , ppr (tyConResKind tc) + , ppr (isTcTyCon tc) ]) + +zipRecTyClss :: [TcTyCon] + -> [TyCon] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the TyCons bound by decls +-- being careful not to look at the knot-tied [TyThing] +-- The TyThings in the result list must have a visible ATyCon, +-- because typechecking types (in, say, tcTyClDecl) looks at +-- this outer constructor +zipRecTyClss tc_tycons rec_tycons + = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] + where + rec_tc_env :: NameEnv TyCon + rec_tc_env = foldr add_tc emptyNameEnv rec_tycons + + add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) + + add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_one_tc tc env = extendNameEnv env (tyConName tc) tc + + get name = case lookupNameEnv rec_tc_env name of + Just tc -> tc + other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) + +{- +************************************************************************ +* * + Kind checking +* * +************************************************************************ + +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: + + 1. Make up a kind variable for each parameter of the declarations, + and extend the kind environment (which is in the TcLclEnv) + + 2. Kind check the declarations + +We need to kind check all types in the mutually recursive group +before we know the kind of the type variables. For example: + + class C a where + op :: D b => a -> b -> b + + class D c where + bop :: (Monad c) => ... + +Here, the kind of the locally-polymorphic type variable "b" +depends on *all the uses of class D*. For example, the use of +Monad c in bop's type signature means that D must have kind Type->Type. + +Note: we don't treat type synonyms specially (we used to, in the past); +in particular, even if we have a type synonym cycle, we still kind check +it normally, and test for cycles later (checkSynCycles). The reason +we can get away with this is because we have more systematic TYPE r +inference, which means that we can do unification between kinds that +aren't lifted (this historically was not true.) + +The downside of not directly reading off the kinds of the RHS of +type synonyms in topological order is that we don't transparently +support making synonyms of types with higher-rank kinds. But +you can always specify a CUSK directly to make this work out. +See tc269 for an example. + +Note [CUSKs and PolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T (a :: *) = MkT (S a) -- Has CUSK + data S a = MkS (T Int) (S a) -- No CUSK + +Via inferInitialKinds we get + T :: * -> * + S :: kappa -> * + +Then we call kcTyClDecl on each decl in the group, to constrain the +kind unification variables. BUT we /skip/ the RHS of any decl with +a CUSK. Here we skip the RHS of T, so we eventually get + S :: forall k. k -> * + +This gets us more polymorphism than we would otherwise get, similar +(but implemented strangely differently from) the treatment of type +signatures in value declarations. + +However, we only want to do so when we have PolyKinds. +When we have NoPolyKinds, we don't skip those decls, because we have defaulting +(#16609). Skipping won't bring us more polymorphism when we have defaulting. +Consider + + data T1 a = MkT1 T2 -- No CUSK + data T2 = MkT2 (T1 Maybe) -- Has CUSK + +If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. +With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the +program type-checks. +But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens +in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking +(T1 Maybe) will throw a type error. + +Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. + +Open type families +~~~~~~~~~~~~~~~~~~ +This treatment of type synonyms only applies to Haskell 98-style synonyms. +General type functions can be recursive, and hence, appear in `alg_decls'. + +The kind of an open type family is solely determinded by its kind signature; +hence, only kind signatures participate in the construction of the initial +kind environment (as constructed by `inferInitialKind'). In fact, we ignore +instances of families altogether in the following. However, we need to include +the kinds of *associated* families into the construction of the initial kind +environment. (This is handled by `allDecls'). + +See also Note [Kind checking recursive type and class declarations] + +Note [How TcTyCons work] +~~~~~~~~~~~~~~~~~~~~~~~~ +TcTyCons are used for two distinct purposes + +1. When recovering from a type error in a type declaration, + we want to put the erroneous TyCon in the environment in a + way that won't lead to more errors. We use a TcTyCon for this; + see makeRecoveryTyCon. + +2. When checking a type/class declaration (in module GHC.Tc.TyCl), we come + upon knowledge of the eventual tycon in bits and pieces. + + S1) First, we use inferInitialKinds to look over the user-provided + kind signature of a tycon (including, for example, the number + of parameters written to the tycon) to get an initial shape of + the tycon's kind. We record that shape in a TcTyCon. + + For CUSK tycons, the TcTyCon has the final, generalised kind. + For non-CUSK tycons, the TcTyCon has as its tyConBinders only + the explicit arguments given -- no kind variables, etc. + + S2) Then, using these initial kinds, we kind-check the body of the + tycon (class methods, data constructors, etc.), filling in the + metavariables in the tycon's initial kind. + + S3) We then generalize to get the (non-CUSK) tycon's final, fixed + kind. Finally, once this has happened for all tycons in a + mutually recursive group, we can desugar the lot. + + For convenience, we store partially-known tycons in TcTyCons, which + might store meta-variables. These TcTyCons are stored in the local + environment in GHC.Tc.TyCl, until the real full TyCons can be created + during desugaring. A desugared program should never have a TcTyCon. + +3. In a TcTyCon, everything is zonked after the kind-checking pass (S2). + +4. tyConScopedTyVars. A challenging piece in all of this is that we + end up taking three separate passes over every declaration: + - one in inferInitialKind (this pass look only at the head, not the body) + - one in kcTyClDecls (to kind-check the body) + - a final one in tcTyClDecls (to desugar) + + In the latter two passes, we need to connect the user-written type + variables in an LHsQTyVars with the variables in the tycon's + inferred kind. Because the tycon might not have a CUSK, this + matching up is, in general, quite hard to do. (Look through the + git history between Dec 2015 and Apr 2016 for + GHC.Tc.Gen.HsType.splitTelescopeTvs!) + + Instead of trying, we just store the list of type variables to + bring into scope, in the tyConScopedTyVars field of the TcTyCon. + These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars. + + In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather + than just [TcTyVar]? Consider these mutually-recursive decls + data T (a :: k1) b = MkT (S a b) + data S (c :: k2) d = MkS (T c d) + We start with k1 bound to kappa1, and k2 to kappa2; so initially + in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But + then kappa1 and kappa2 get unified; so after the zonking in + 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. + +See also Note [Type checking recursive type and class declarations]. + +Note [Swizzling the tyvars before generaliseTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note only applies when /inferring/ the kind of a TyCon. +If there is a separate kind signature, or a CUSK, we take an entirely +different code path. + +For inference, consider + class C (f :: k) x where + type T f + op :: D f => blah + class D (g :: j) y where + op :: C g => y -> blah + +Here C and D are considered mutually recursive. Neither has a CUSK. +Just before generalisation we have the (un-quantified) kinds + C :: k1 -> k2 -> Constraint + T :: k1 -> Type + D :: k1 -> Type -> Constraint +Notice that f's kind and g's kind have been unified to 'k1'. We say +that k1 is the "representative" of k in C's decl, and of j in D's decl. + +Now when quantifying, we'd like to end up with + C :: forall {k2}. forall k. k -> k2 -> Constraint + T :: forall k. k -> Type + D :: forall j. j -> Type -> Constraint + +That is, we want to swizzle the representative to have the Name given +by the user. Partly this is to improve error messages and the output of +:info in GHCi. But it is /also/ important because the code for a +default method may mention the class variable(s), but at that point +(tcClassDecl2), we only have the final class tyvars available. +(Alternatively, we could record the scoped type variables in the +TyCon, but it's a nuisance to do so.) + +Notes: + +* On the input to generaliseTyClDecl, the mapping between the + user-specified Name and the representative TyVar is recorded in the + tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see + this representative TyVar. + +* The swizzling is actually performed by swizzleTcTyConBndrs + +* We must do the swizzling across the whole class decl. Consider + class C f where + type S (f :: k) + type T f + Here f's kind k is a parameter of C, and its identity is shared + with S and T. So if we swizzle the representative k at all, we + must do so consistently for the entire declaration. + + Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, + rather than in generaliseTcTyCon. + +There are errors to catch here. Suppose we had + class E (f :: j) (g :: k) where + op :: SameKind f g -> blah + +Then, just before generalisation we will have the (unquantified) + E :: k1 -> k1 -> Constraint + +That's bad! Two distinctly-named tyvars (j and k) have ended up with +the same representative k1. So when swizzling, we check (in +check_duplicate_tc_binders) that two distinct source names map +to the same representative. + +Here's an interesting case: + class C1 f where + type S (f :: k1) + type T (f :: k2) +Here k1 and k2 are different Names, but they end up mapped to the +same representative TyVar. To make the swizzling consistent (remember +we must have a single k across C1, S and T) we reject the program. + +Another interesting case + class C2 f where + type S (f :: k) (p::Type) + type T (f :: k) (p::Type->Type) + +Here the two k's (and the two p's) get distinct Uniques, because they +are seen by the renamer as locally bound in S and T resp. But again +the two (distinct) k's end up bound to the same representative TyVar. +You might argue that this should be accepted, but it's definitely +rejected (via an entirely different code path) if you add a kind sig: + type C2' :: j -> Constraint + class C2' f where + type S (f :: k) (p::Type) +We get + • Expected kind ‘j’, but ‘f’ has kind ‘k’ + • In the associated type family declaration for ‘S’ + +So we reject C2 too, even without the kind signature. We have +to do a bit of work to get a good error message, since both k's +look the same to the user. + +Another case + class C3 (f :: k1) where + type S (f :: k2) + +This will be rejected too. + + +Note [Type environment evolution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As we typecheck a group of declarations the type environment evolves. +Consider for example: + data B (a :: Type) = MkB (Proxy 'MkB) + +We do the following steps: + + 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the + type env with promotion errors + B :-> TyConPE + MkB :-> DataConPE + + 2. kcTyCLGroup + - Do inferInitialKinds, which will signal a promotion + error if B is used in any of the kinds needed to initialise + B's kind (e.g. (a :: Type)) here + + - Extend the type env with these initial kinds (monomorphic for + decls that lack a CUSK) + B :-> TcTyCon + (thereby overriding the B :-> TyConPE binding) + and do kcLTyClDecl on each decl to get equality constraints on + all those initial kinds + + - Generalise the initial kind, making a poly-kinded TcTyCon + + 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded + TcTyCons, again overriding the promotion-error bindings. + + But note that the data constructor promotion errors are still in place + so that (in our example) a use of MkB will still be signalled as + an error. + + 4. Typecheck the decls. + + 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons + + +Note [Missed opportunity to retain higher-rank kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 'kcTyClGroup', there is a missed opportunity to make kind +inference work in a few more cases. The idea is analogous +to Note [Single function non-recursive binding special-case]: + + * If we have an SCC with a single decl, which is non-recursive, + instead of creating a unification variable representing the + kind of the decl and unifying it with the rhs, we can just + read the type directly of the rhs. + + * Furthermore, we can update our SCC analysis to ignore + dependencies on declarations which have CUSKs: we don't + have to kind-check these all at once, since we can use + the CUSK to initialize the kind environment. + +Unfortunately this requires reworking a bit of the code in +'kcLTyClDecl' so I've decided to punt unless someone shouts about it. + +Note [Don't process associated types in getInitialKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, we processed associated types in the thing_inside in getInitialKind, +but this was wrong -- we want to do ATs sepearately. +The consequence for not doing it this way is #15142: + + class ListTuple (tuple :: Type) (as :: [(k, Type)]) where + type ListToTuple as :: Type + +We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify +kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring +`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't +unified with Type. And then, when we generalize the kind of ListToTuple (which +indeed has a CUSK, according to the rules), we skolemize the free metavariable +kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, +because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] +will unify with Type. + +Bottom line: as associated types should have no effect on a CUSK enclosing class, +we move processing them to a separate action, run after the outer kind has +been generalized. + +-} + +kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon] + +-- Kind check this group, kind generalize, and return the resulting local env +-- This binds the TyCons and Classes of the group, but not the DataCons +-- See Note [Kind checking for type and class decls] +-- and Note [Inferring kinds for type declarations] +kcTyClGroup kisig_env decls + = do { mod <- getModule + ; traceTc "---- kcTyClGroup ---- {" + (text "module" <+> ppr mod $$ vcat (map ppr decls)) + + -- Kind checking; + -- 1. Bind kind variables for decls + -- 2. Kind-check decls + -- 3. Generalise the inferred kinds + -- See Note [Kind checking for type and class decls] + + ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds + -- See Note [CUSKs and PolyKinds] + ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls + + get_kind d + | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d)) + = Right (d, SAKS ki) + + | cusks_enabled && hsDeclHasCusk (unLoc d) + = Right (d, CUSK) + + | otherwise = Left d + + ; checked_tcs <- checkInitialKinds kinded_decls + ; inferred_tcs + <- tcExtendKindEnvWithTyCons checked_tcs $ + pushTcLevelM_ $ -- We are going to kind-generalise, so + -- unification variables in here must + -- be one level in + solveEqualities $ + do { -- Step 1: Bind kind variables for all decls + mono_tcs <- inferInitialKinds kindless_decls + + ; traceTc "kcTyClGroup: initial kinds" $ + ppr_tc_kinds mono_tcs + + -- Step 2: Set extended envt, kind-check the decls + -- NB: the environment extension overrides the tycon + -- promotion-errors bindings + -- See Note [Type environment evolution] + ; tcExtendKindEnvWithTyCons mono_tcs $ + mapM_ kcLTyClDecl kindless_decls + + ; return mono_tcs } + + -- Step 3: generalisation + -- Finally, go through each tycon and give it its final kind, + -- with all the required, specified, and inferred variables + -- in order. + ; let inferred_tc_env = mkNameEnv $ + map (\tc -> (tyConName tc, tc)) inferred_tcs + ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) + kindless_decls + + ; let poly_tcs = checked_tcs ++ generalized_tcs + ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) + ; return poly_tcs } + where + ppr_tc_kinds tcs = vcat (map pp_tc tcs) + pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) + +type ScopedPairs = [(Name, TcTyVar)] + -- The ScopedPairs for a TcTyCon are precisely + -- specified-tvs ++ required-tvs + -- You can distinguish them because there are tyConArity required-tvs + +generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon] +-- See Note [Swizzling the tyvars before generaliseTcTyCon] +generaliseTyClDecl inferred_tc_env (L _ decl) + = do { let names_in_this_decl :: [Name] + names_in_this_decl = tycld_names decl + + -- Extract the specified/required binders and skolemise them + ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl + + -- Zonk, to manifest the side-effects of skolemisation to the swizzler + -- NB: it's important to skolemise them all before this step. E.g. + -- class C f where { type T (f :: k) } + -- We only skolemise k when looking at T's binders, + -- but k appears in f's kind in C's binders. + ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs + + -- Swizzle + ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) + + -- And finally generalise + ; mapAndReportM generaliseTcTyCon swizzled_infos } + where + tycld_names :: TyClDecl GhcRn -> [Name] + tycld_names decl = tcdName decl : at_names decl + + at_names :: TyClDecl GhcRn -> [Name] + at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats + at_names _ = [] -- Only class decls have associated types + + skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs) + -- Zonk and skolemise the Specified and Required binders + skolemise_tc_tycon tc_name + = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name + -- This lookup should not fail + ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc) + ; return (tc, scoped_prs) } + + zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind) + zonk_tc_tycon (tc, scoped_prs) + = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs + -- We really have to do this again, even though + -- we have just done zonkAndSkolemise + ; res_kind <- zonkTcType (tyConResKind tc) + ; return (tc, scoped_prs, res_kind) } + +swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)] + -> TcM [(TcTyCon, ScopedPairs, TcKind)] +swizzleTcTyConBndrs tc_infos + | all no_swizzle swizzle_prs + -- This fast path happens almost all the time + -- See Note [Non-cloning for tyvar binders] in GHC.Tc.Gen.HsType + = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos)) + ; return tc_infos } + + | otherwise + = do { check_duplicate_tc_binders + + ; traceTc "swizzleTcTyConBndrs" $ + vcat [ text "before" <+> ppr_infos tc_infos + , text "swizzle_prs" <+> ppr swizzle_prs + , text "after" <+> ppr_infos swizzled_infos ] + + ; return swizzled_infos } + + where + swizzled_infos = [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind) + | (tc, scoped_prs, kind) <- tc_infos ] + + swizzle_prs :: [(Name,TyVar)] + -- Pairs the user-specifed Name with its representative TyVar + -- See Note [Swizzling the tyvars before generaliseTcTyCon] + swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] + + no_swizzle :: (Name,TyVar) -> Bool + no_swizzle (nm, tv) = nm == tyVarName tv + + ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) + | (tc, prs, _) <- infos ] + + -- Check for duplicates + -- E.g. data SameKind (a::k) (b::k) + -- data T (a::k1) (b::k2) = MkT (SameKind a b) + -- Here k1 and k2 start as TyVarTvs, and get unified with each other + -- If this happens, things get very confused later, so fail fast + check_duplicate_tc_binders :: TcM () + check_duplicate_tc_binders = unless (null err_prs) $ + do { mapM_ report_dup err_prs; failM } + + -------------- Error reporting ------------ + err_prs :: [(Name,Name)] + err_prs = [ (n1,n2) + | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs + , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ] + -- This nubBy avoids bogus error reports when we have + -- [("f", f), ..., ("f",f)....] in swizzle_prs + -- which happens with class C f where { type T f } + + report_dup :: (Name,Name) -> TcM () + report_dup (n1,n2) + = setSrcSpan (getSrcSpan n2) $ addErrTc $ + hang (text "Different names for the same type variable:") 2 info + where + info | nameOccName n1 /= nameOccName n2 + = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) + | otherwise -- Same OccNames! See C2 in + -- Note [Swizzling the tyvars before generaliseTcTyCon] + = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) + , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] + + -------------- The swizzler ------------ + -- This does a deep traverse, simply doing a + -- Name-to-Name change, governed by swizzle_env + -- The 'swap' is what gets from the representative TyVar + -- back to the original user-specified Name + swizzle_env = mkVarEnv (map swap swizzle_prs) + + swizzleMapper :: TyCoMapper () Identity + swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv + , tcm_covar = swizzle_cv + , tcm_hole = swizzle_hole + , tcm_tycobinder = swizzle_bndr + , tcm_tycon = swizzle_tycon } + swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) + -- These types are pre-zonked + swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) + -- TcTyCons can't appear in kinds (yet) + swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) + swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) + + swizzle_bndr _ tcv _ + = return ((), swizzle_var tcv) + + swizzle_var :: Var -> Var + swizzle_var v + | Just nm <- lookupVarEnv swizzle_env v + = updateVarType swizzle_ty (v `setVarName` nm) + | otherwise + = updateVarType swizzle_ty v + + (map_type, _, _, _) = mapTyCo swizzleMapper + swizzle_ty ty = runIdentity (map_type ty) + + +generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon +generaliseTcTyCon (tc, scoped_prs, tc_res_kind) + -- See Note [Required, Specified, and Inferred for types] + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + do { -- Step 1: Separate Specified from Required variables + -- NB: spec_req_tvs = spec_tvs ++ req_tvs + -- And req_tvs is 1-1 with tyConTyVars + -- See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon + ; let spec_req_tvs = map snd scoped_prs + n_spec = length spec_req_tvs - tyConArity tc + (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs + sorted_spec_tvs = scopedSort spec_tvs + -- NB: We can't do the sort until we've zonked + -- Maintain the L-R order of scoped_tvs + + -- Step 2a: find all the Inferred variables we want to quantify over + ; dvs1 <- candidateQTyVarsOfKinds $ + (tc_res_kind : map tyVarKind spec_req_tvs) + ; let dvs2 = dvs1 `delCandidates` spec_req_tvs + + -- Step 2b: quantify, mainly meaning skolemise the free variables + -- Returned 'inferred' are scope-sorted and skolemised + ; inferred <- quantifyTyVars dvs2 + + ; traceTc "generaliseTcTyCon: pre zonk" + (vcat [ text "tycon =" <+> ppr tc + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dvs1 =" <+> ppr dvs1 + , text "inferred =" <+> pprTyVars inferred ]) + + -- Step 3: Final zonk (following kind generalisation) + -- See Note [Swizzling the tyvars before generaliseTcTyCon] + ; ze <- emptyZonkEnv + ; (ze, inferred) <- zonkTyBndrsX ze inferred + ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs + ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs + ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind + + ; traceTc "generaliseTcTyCon: post zonk" $ + vcat [ text "tycon =" <+> ppr tc + , text "inferred =" <+> pprTyVars inferred + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs + , text "req_tvs =" <+> ppr req_tvs + , text "zonk-env =" <+> ppr ze ] + + -- Step 4: Make the TyConBinders. + ; let dep_fv_set = candidateKindVars dvs1 + inferred_tcbs = mkNamedTyConBinders Inferred inferred + specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs + required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs + + -- Step 5: Assemble the final list. + final_tcbs = concat [ inferred_tcbs + , specified_tcbs + , required_tcbs ] + + -- Step 6: Make the result TcTyCon + tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind + (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) + True {- it's generalised now -} + (tyConFlavour tc) + + ; traceTc "generaliseTcTyCon done" $ + vcat [ text "tycon =" <+> ppr tc + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dep_fv_set =" <+> ppr dep_fv_set + , text "inferred_tcbs =" <+> ppr inferred_tcbs + , text "specified_tcbs =" <+> ppr specified_tcbs + , text "required_tcbs =" <+> ppr required_tcbs + , text "final_tcbs =" <+> ppr final_tcbs ] + + -- Step 7: Check for validity. + -- We do this here because we're about to put the tycon into the + -- the environment, and we don't want anything malformed there + ; checkTyConTelescope tycon + + ; return tycon } + +{- Note [Required, Specified, and Inferred for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each forall'd type variable in a type or kind is one of + + * Required: an argument must be provided at every call site + + * Specified: the argument can be inferred at call sites, but + may be instantiated with visible type/kind application + + * Inferred: the must be inferred at call sites; it + is unavailable for use with visible type/kind application. + +Why have Inferred at all? Because we just can't make user-facing +promises about the ordering of some variables. These might swizzle +around even between minor released. By forbidding visible type +application, we ensure users aren't caught unawares. + +Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + +The question for this Note is this: + given a TyClDecl, how are its quantified type variables classified? +Much of the debate is memorialized in #15743. + +Here is our design choice. When inferring the ordering of variables +for a TyCl declaration (that is, for those variables that he user +has not specified the order with an explicit `forall`), we use the +following order: + + 1. Inferred variables + 2. Specified variables; in the left-to-right order in which + the user wrote them, modified by scopedSort (see below) + to put them in depdendency order. + 3. Required variables before a top-level :: + 4. All variables after a top-level :: + +If this ordering does not make a valid telescope, we reject the definition. + +Example: + data SameKind :: k -> k -> * + data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +For Bad: + - a, c, d, x are Required; they are explicitly listed by the user + as the positional arguments of Bad + - b is Specified; it appears explicitly in a kind signature + - k, the kind of a, is Inferred; it is not mentioned explicitly at all + +Putting variables in the order Inferred, Specified, Required +gives us this telescope: + Inferred: k + Specified: b : Proxy a + Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) + +But this order is ill-scoped, because b's kind mentions a, which occurs +after b in the telescope. So we reject Bad. + +Associated types +~~~~~~~~~~~~~~~~ +For associated types everything above is determined by the +associated-type declaration alone, ignoring the class header. +Here is an example (#15592) + class C (a :: k) b where + type F (x :: b a) + +In the kind of C, 'k' is Specified. But what about F? +In the kind of F, + + * Should k be Inferred or Specified? It's Specified for C, + but not mentioned in F's declaration. + + * In which order should the Specified variables a and b occur? + It's clearly 'a' then 'b' in C's declaration, but the L-R ordering + in F's declaration is 'b' then 'a'. + +In both cases we make the choice by looking at F's declaration alone, +so it gets the kind + F :: forall {k}. forall b a. b a -> Type + +How it works +~~~~~~~~~~~~ +These design choices are implemented by two completely different code +paths for + + * Declarations with a standalone kind signature or a complete user-specified + kind signature (CUSK). Handled by the kcCheckDeclHeader. + + * Declarations without a kind signature (standalone or CUSK) are handled by + kcInferDeclHeader; see Note [Inferring kinds for type declarations]. + +Note that neither code path worries about point (4) above, as this +is nicely handled by not mangling the res_kind. (Mangling res_kinds is done +*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.) + +We can tell Inferred apart from Specified by looking at the scoped +tyvars; Specified are always included there. + +Design alternatives +~~~~~~~~~~~~~~~~~~~ +* For associated types we considered putting the class variables + before the local variables, in a nod to the treatment for class + methods. But it got too compilicated; see #15592, comment:21ff. + +* We rigidly require the ordering above, even though we could be much more + permissive. Relevant musings are at + https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 + The bottom line conclusion is that, if the user wants a different ordering, + then can specify it themselves, and it is better to be predictable and dumb + than clever and capricious. + + I (Richard) conjecture we could be fully permissive, allowing all classes + of variables to intermix. We would have to augment ScopedSort to refuse to + reorder Required variables (or check that it wouldn't have). But this would + allow more programs. See #15743 for examples. Interestingly, Idris seems + to allow this intermixing. The intermixing would be fully specified, in that + we can be sure that inference wouldn't change between versions. However, + would users be able to predict it? That I cannot answer. + +Test cases (and tickets) relevant to these design decisions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + T15591* + T15592* + T15743* + +Note [Inferring kinds for type declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note deals with /inference/ for type declarations +that do not have a CUSK. Consider + data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) + data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) + +We do kind inference as follows: + +* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. + Make a unification variable for each of the Required and Specified + type variables in the header. + + Record the connection between the Names the user wrote and the + fresh unification variables in the tcTyConScopedTyVars field + of the TcTyCon we are making + [ (a, aa) + , (k1, kk1) + , (k2, kk2) + , (x, xx) ] + (I'm using the convention that double letter like 'aa' or 'kk' + mean a unification variable.) + + These unification variables + - Are TyVarTvs: that is, unification variables that can + unify only with other type variables. + See Note [Signature skolems] in GHC.Tc.Utils.TcType + + - Have complete fresh Names; see GHC.Tc.Utils.TcMType + Note [Unification variables need fresh Names] + + Assign initial monomorphic kinds to S, T + T :: kk1 -> * -> kk2 -> * + S :: kk3 -> * -> kk4 -> * + +* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and + T, with these monomorphic kinds. Now kind-check the declarations, + and solve the resulting equalities. The goal here is to discover + constraints on all these unification variables. + + Here we find that kk1 := kk3, and kk2 := kk4. + + This is why we can't use skolems for kk1 etc; they have to + unify with each other. + +* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. + We find the free variables of the kind, skolemise them, + sort them out into Inferred/Required/Specified (see the above + Note [Required, Specified, and Inferred for types]), + and perform some validity checks. + + This makes the utterly-final TyConBinders for the TyCon. + + All this is very similar at the level of terms: see GHC.Tc.Gen.Bind + Note [Quantified variables in partial type signatures] + + But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon] + +* Step 4. Extend the type environment with a TcTyCon for S and T, now + with their utterly-final polymorphic kinds (needed for recursive + occurrences of S, T). Now typecheck the declarations, and build the + final AlgTyCon for S and T resp. + +The first three steps are in kcTyClGroup; the fourth is in +tcTyClDecls. + +There are some wrinkles + +* Do not default TyVarTvs. We always want to kind-generalise over + TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is + not allowed to unify with a type; it must stand for a type + variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and + GHC.Tc.Utils.TcMType.defaultTyVar. Here's another example (#14555): + data Exp :: [TYPE rep] -> TYPE rep -> Type where + Lam :: Exp (a:xs) b -> Exp xs (a -> b) + We want to kind-generalise over the 'rep' variable. + #14563 is another example. + +* Duplicate type variables. Consider #11203 + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + Here we will unify k1 with k2, but this time doing so is an error, + because k1 and k2 are bound in the same declaration. + + We spot this during validity checking (findDupTyVarTvs), + in generaliseTcTyCon. + +* Required arguments. Even the Required arguments should be made + into TyVarTvs, not skolems. Consider + data T k (a :: k) + Here, k is a Required, dependent variable. For uniformity, it is helpful + to have k be a TyVarTv, in parallel with other dependent variables. + +* Duplicate skolemisation is expected. When generalising in Step 3, + we may find that one of the variables we want to quantify has + already been skolemised. For example, suppose we have already + generalise S. When we come to T we'll find that kk1 (now the same as + kk3) has already been skolemised. + + That's fine -- but it means that + a) when collecting quantification candidates, in + candidateQTyVarsOfKind, we must collect skolems + b) quantifyTyVars should be a no-op on such a skolem + +Note [Tricky scoping in generaliseTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider #16342 + class C (a::ka) x where + cop :: D a x => x -> Proxy a -> Proxy a + cop _ x = x :: Proxy (a::ka) + + class D (b::kb) y where + dop :: C b y => y -> Proxy b -> Proxy b + dop _ x = x :: Proxy (b::kb) + +C and D are mutually recursive, by the time we get to +generaliseTcTyCon we'll have unified kka := kkb. + +But when typechecking the default declarations for 'cop' and 'dop' in +tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. +But at that point all we have is the utterly-final Class itself. + +Conclusion: the classTyVars of a class must have the same Name as +that originally assigned by the user. In our example, C must have +classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite +the fact that kka and kkb got unified! + +We achieve this sleight of hand in generaliseTcTyCon, using +the specialised function zonkRecTyVarBndrs. We make the call + zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] +where the [ka,a,x] are the Names originally assigned by the user, and +[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. +zonkRecTyVarBndrs builds a recursive ZonkEnv that binds + kkb :-> (ka :: ) + aa :-> (a :: ) + etc +That is, it maps each skolemised TcTyVars to the utterly-final +TyVar to put in the class, with its correct user-specified name. +When generalising D we'll do the same thing, but the ZonkEnv will map + kkb :-> (kb :: ) + bb :-> (b :: ) + etc +Note that 'kkb' again appears in the domain of the mapping, but this +time mapped to 'kb'. That's how C and D end up with differently-named +final TyVars despite the fact that we unified kka:=kkb + +zonkRecTyVarBndrs we need to do knot-tying because of the need to +apply this same substitution to the kind of each. + +Note [Inferring visible dependent quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T k :: k -> Type where + MkT1 :: T Type Int + MkT2 :: T (Type -> Type) Maybe + +This looks like it should work. However, it is polymorphically recursive, +as the uses of T in the constructor types specialize the k in the kind +of T. This trips up our dear users (#17131, #17541), and so we add +a "landmark" context (which cannot be suppressed) whenever we +spot inferred visible dependent quantification (VDQ). + +It's hard to know when we've actually been tripped up by polymorphic recursion +specifically, so we just include a note to users whenever we infer VDQ. The +testsuite did not show up a single spurious inclusion of this message. + +The context is added in addVDQNote, which looks for a visible TyConBinder +that also appears in the TyCon's kind. (I first looked at the kind for +a visible, dependent quantifier, but Note [No polymorphic recursion] in +GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in kcTyClDecl, +which is used only when inferring the kind of a tycon (never with a CUSK or +SAK). + +Once upon a time, I (Richard E) thought that the tycon-kind could +not be a forall-type. But this is wrong: data T :: forall k. k -> Type +(with -XNoCUSKs) could end up here. And this is all OK. + + +-} + +-------------- +tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a +tcExtendKindEnvWithTyCons tcs + = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] + +-------------- +mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv +-- Maps each tycon/datacon to a suitable promotion error +-- tc :-> APromotionErr TyConPE +-- dc :-> APromotionErr RecDataConPE +-- See Note [Recursion and promoting data constructors] + +mkPromotionErrorEnv decls + = foldr (plusNameEnv . mk_prom_err_env . unLoc) + emptyNameEnv decls + +mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv +mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) + = unitNameEnv nm (APromotionErr ClassPE) + `plusNameEnv` + mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) + | L _ at <- ats ] + +mk_prom_err_env (DataDecl { tcdLName = L _ name + , tcdDataDefn = HsDataDefn { dd_cons = cons } }) + = unitNameEnv name (APromotionErr TyConPE) + `plusNameEnv` + mkNameEnv [ (con, APromotionErr RecDataConPE) + | L _ con' <- cons + , L _ con <- getConNames con' ] + +mk_prom_err_env decl + = unitNameEnv (tcdName decl) (APromotionErr TyConPE) + -- Works for family declarations too + +-------------- +inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] +-- Returns a TcTyCon for each TyCon bound by the decls, +-- each with its initial kind + +inferInitialKinds decls + = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) + ; tcs <- concatMapM infer_initial_kind decls + ; traceTc "inferInitialKinds done }" empty + ; return tcs } + where + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) + +-- Check type/class declarations against their standalone kind signatures or +-- CUSKs, producing a generalized TcTyCon for each. +checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon] +checkInitialKinds decls + = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) + ; tcs <- concatMapM check_initial_kind decls + ; traceTc "checkInitialKinds done }" empty + ; return tcs } + where + check_initial_kind (ldecl, msig) = + addLocM (getInitialKind (InitialKindCheck msig)) ldecl + +-- | Get the initial kind of a TyClDecl, either generalized or non-generalized, +-- depending on the 'InitialKindStrategy'. +getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] + +-- Allocate a fresh kind variable for each TyCon and Class +-- For each tycon, return a TcTyCon with kind k +-- where k is the kind of tc, derived from the LHS +-- of the definition (and probably including +-- kind unification variables) +-- Example: data T a b = ... +-- return (T, kv1 -> kv2 -> kv3) +-- +-- This pass deals with (ie incorporates into the kind it produces) +-- * The kind signatures on type-variable binders +-- * The result kinds signature on a TyClDecl +-- +-- No family instances are passed to checkInitialKinds/inferInitialKinds +getInitialKind strategy + (ClassDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdATs = ats }) + = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ + return (TheKind constraintKind) + ; let parent_tv_prs = tcTyConScopedTyVars cls + -- See Note [Don't process associated types in getInitialKind] + ; inner_tcs <- + tcExtendNameTyVarEnv parent_tv_prs $ + mapM (addLocM (getAssocFamInitialKind cls)) ats + ; return (cls : inner_tcs) } + where + getAssocFamInitialKind cls = + case strategy of + InitialKindInfer -> get_fam_decl_initial_kind (Just cls) + InitialKindCheck _ -> check_initial_kind_assoc_fam cls + +getInitialKind strategy + (DataDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig + , dd_ND = new_or_data } }) + = do { let flav = newOrDataToFlavour new_or_data + ctxt = DataKindCtxt name + ; tc <- kcDeclHeader strategy name flav ktvs $ + case m_sig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return $ dataDeclDefaultResultKind new_or_data + ; return [tc] } + +getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) + = do { tc <- get_fam_decl_initial_kind Nothing decl + ; return [tc] } + +getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = + FamilyDecl { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } } ) + = do { let flav = getFamFlav Nothing info + ctxt = TyFamResKindCtxt name + ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> + case msig of + CUSK -> return (TheKind liftedTypeKind) + SAKS _ -> return AnyKind + ; return [tc] } + +getInitialKind strategy + (SynDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdRhs = rhs }) + = do { let ctxt = TySynKindCtxt name + ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ + case hsTyKindSig rhs of + Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig + Nothing -> return AnyKind + ; return [tc] } + +get_fam_decl_initial_kind + :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls + -> FamilyDecl GhcRn + -> TcM TcTyCon +get_fam_decl_initial_kind mb_parent_tycon + FamilyDecl { fdLName = L _ name + , fdTyVars = ktvs + , fdResultSig = L _ resultSig + , fdInfo = info } + = kcDeclHeader InitialKindInfer name flav ktvs $ + case resultSig of + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki + _ -- open type families have * return kind by default + | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) + -- closed type families have their return kind inferred + -- by default + | otherwise -> return AnyKind + where + flav = getFamFlav mb_parent_tycon info + ctxt = TyFamResKindCtxt name + +-- See Note [Standalone kind signatures for associated types] +check_initial_kind_assoc_fam + :: TcTyCon -- parent class + -> FamilyDecl GhcRn + -> TcM TcTyCon +check_initial_kind_assoc_fam cls + FamilyDecl + { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } + = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return (TheKind liftedTypeKind) + where + ctxt = TyFamResKindCtxt name + flav = getFamFlav (Just cls) info + +{- Note [Standalone kind signatures for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If associated types had standalone kind signatures, would they wear them + +---------------------------+------------------------------ + like this? (OUT) | or like this? (IN) +---------------------------+------------------------------ + type T :: Type -> Type | class C a where + class C a where | type T :: Type -> Type + type T a | type T a + +The (IN) variant is syntactically ambiguous: + + class C a where + type T :: a -- standalone kind signature? + type T :: a -- declaration header? + +The (OUT) variant does not suffer from this issue, but it might not be the +direction in which we want to take Haskell: we seek to unify type families and +functions, and, by extension, associated types with class methods. And yet we +give class methods their signatures inside the class, not outside. Neither do +we have the counterpart of InstanceSigs for StandaloneKindSignatures. + +For now, we dodge the question by using CUSKs for associated types instead of +standalone kind signatures. This is a simple addition to the rule we used to +have before standalone kind signatures: + + old rule: associated type has a CUSK iff its parent class has a CUSK + new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature + +-} + +-- See Note [Data declaration default result kind] +dataDeclDefaultResultKind :: NewOrData -> ContextKind +dataDeclDefaultResultKind NewType = OpenKind + -- See Note [Implementation of UnliftedNewtypes], point . +dataDeclDefaultResultKind DataType = TheKind liftedTypeKind + +{- Note [Data declaration default result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When the user has not written an inline result kind annotation on a data +declaration, we assume it to be 'Type'. That is, the following declarations +D1 and D2 are considered equivalent: + + data D1 where ... + data D2 :: Type where ... + +The consequence of this assumption is that we reject D3 even though we +accept D4: + + data D3 where + MkD3 :: ... -> D3 param + + data D4 :: Type -> Type where + MkD4 :: ... -> D4 param + +However, there's a twist: for newtypes, we must relax +the assumed result kind to (TYPE r): + + newtype D5 where + MkD5 :: Int# -> D5 + +See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note +. +-} + +--------------------------------- +getFamFlav + :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls + -> FamilyInfo pass + -> TyConFlavour +getFamFlav mb_parent_tycon info = + case info of + DataFamily -> DataFamilyFlavour mb_parent_tycon + OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon + ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon] + ClosedTypeFamilyFlavour + +{- Note [Closed type family mb_parent_tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no way to write a closed type family inside a class declaration: + + class C a where + type family F a where -- error: parse error on input ‘where’ + +In fact, it is not clear what the meaning of such a declaration would be. +Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. +-} + +------------------------------------------------------------------------ +kcLTyClDecl :: LTyClDecl GhcRn -> TcM () + -- See Note [Kind checking for type and class decls] + -- Called only for declarations without a signature (no CUSKs or SAKs here) +kcLTyClDecl (L loc decl) + = setSrcSpan loc $ + do { tycon <- tcLookupTcTyCon tc_name + ; traceTc "kcTyClDecl {" (ppr tc_name) + ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] + addErrCtxt (tcMkDeclCtxt decl) $ + kcTyClDecl decl tycon + ; traceTc "kcTyClDecl done }" (ppr tc_name) } + where + tc_name = tcdName decl + +kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () +-- This function is used solely for its side effect on kind variables +-- NB kind signatures on the type variables and +-- result kind signature have already been dealt with +-- by inferInitialKind, so we can ignore them here. + +kcTyClDecl (DataDecl { tcdLName = (L _ name) + , tcdDataDefn = defn }) tyCon + | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) + , dd_ctxt = (L _ []) + , dd_ND = new_or_data } <- defn + = -- See Note [Implementation of UnliftedNewtypes] STEP 2 + kcConDecls new_or_data (tyConResKind tyCon) cons + + -- hs_tvs and dd_kindSig already dealt with in inferInitialKind + -- This must be a GADT-style decl, + -- (see invariants of DataDefn declaration) + -- so (a) we don't need to bring the hs_tvs into scope, because the + -- ConDecls bind all their own variables + -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it + + | HsDataDefn { dd_ctxt = ctxt + , dd_cons = cons + , dd_ND = new_or_data } <- defn + = bindTyClTyVars name $ \ _ _ _ -> + do { _ <- tcHsContext ctxt + ; kcConDecls new_or_data (tyConResKind tyCon) cons + } + +kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon + = bindTyClTyVars name $ \ _ _ res_kind -> + discardResult $ tcCheckLHsType rhs (TheKind res_kind) + -- NB: check against the result kind that we allocated + -- in inferInitialKinds. + +kcTyClDecl (ClassDecl { tcdLName = L _ name + , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon + = bindTyClTyVars name $ \ _ _ _ -> + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM_ kc_sig) sigs } + where + kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty + kc_sig _ = return () + + skol_info = TyConSkol ClassFlavour name + +kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc +-- closed type families look at their equations, but other families don't +-- do anything here + = case fd_info of + ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns + _ -> return () + +------------------- + +-- Type check the types of the arguments to a data constructor. +-- This includes doing kind unification if the type is a newtype. +-- See Note [Implementation of UnliftedNewtypes] for why we need +-- the first two arguments. +kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () +kcConArgTys new_or_data res_kind arg_tys = do + { let exp_kind = getArgExpKind new_or_data res_kind + ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind + tcMult mult) + + -- See Note [Implementation of UnliftedNewtypes], STEP 2 + } + +kcConDecls :: NewOrData + -> Kind -- The result kind signature + -> [LConDecl GhcRn] -- The data constructors + -> TcM () +kcConDecls new_or_data res_kind cons + = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons + where + (_, final_res_kind) = splitPiTys res_kind + -- See Note [kcConDecls result kind] + +-- Kind check a data constructor. In additional to the data constructor, +-- we also need to know about whether or not its corresponding type was +-- declared with data or newtype, and we need to know the result kind of +-- this type. See Note [Implementation of UnliftedNewtypes] for why +-- we need the first two arguments. +kcConDecl :: NewOrData + -> Kind -- Result kind of the type constructor + -- Usually Type but can be TYPE UnliftedRep + -- or even TYPE r, in the case of unlifted newtype + -> ConDecl GhcRn + -> TcM () +kcConDecl new_or_data res_kind (ConDeclH98 + { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = ex_ctxt, con_args = args }) + = addErrCtxt (dataConCtxtName [name]) $ + discardResult $ + bindExplicitTKBndrs_Tv ex_tvs $ + do { _ <- tcHsMbContext ex_ctxt + ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) + -- We don't need to check the telescope here, + -- because that's done in tcConDecl + } + +kcConDecl new_or_data res_kind (ConDeclGADT + { con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt + , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms }) + = -- Even though the GADT-style data constructor's type is closed, + -- we must still kind-check the type, because that may influence + -- the inferred kind of the /type/ constructor. Example: + -- data T f a where + -- MkT :: f a -> T f a + -- If we don't look at MkT we won't get the correct kind + -- for the type constructor T + addErrCtxt (dataConCtxtName names) $ + discardResult $ + bindImplicitTKBndrs_Tv implicit_tkv_nms $ + bindExplicitTKBndrs_Tv explicit_tkv_nms $ + -- Why "_Tv"? See Note [Kind-checking for GADTs] + do { _ <- tcHsMbContext cxt + ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) + ; _ <- tcHsOpenType res_ty + ; return () } + +{- Note [kcConDecls result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We might have e.g. + data T a :: Type -> Type where ... +or + newtype instance N a :: Type -> Type where .. +in which case, the 'res_kind' passed to kcConDecls will be + Type->Type + +We must look past those arrows, or even foralls, to the Type in the +corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here. + +I am a bit concerned about tycons with a declaration like + data T a :: Type -> forall k. k -> Type where ... + +It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon +with tyConResKind of Type -> forall k. k -> Type. Even that is fine: +the splitPiTys will look past the forall. But I'm bothered about +what if the type "in the corner" mentions k? This is incredibly +obscure but something like this could be bad: + data T a :: Type -> foral k. k -> TYPE (F k) where ... + +I bet we are not quite right here, but my brain suffered a buffer +overflow and I thought it best to nail the common cases right now. + +Note [Recursion and promoting data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to allow promotion in a strongly connected component +when kind checking. + +Consider: + data T f = K (f (K Any)) + +When kind checking the `data T' declaration the local env contains the +mappings: + T -> ATcTyCon + K -> APromotionErr + +APromotionErr is only used for DataCons, and only used during type checking +in tcTyClGroup. + +Note [Kind-checking for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Proxy a where + MkProxy1 :: forall k (b :: k). Proxy b + MkProxy2 :: forall j (c :: j). Proxy c + +It seems reasonable that this should be accepted. But something very strange +is going on here: when we're kind-checking this declaration, we need to unify +the kind of `a` with k and j -- even though k and j's scopes are local to the type of +MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during +the kind-checking pass. First off, note that it's OK if the kind-checking pass +is too permissive: we'll snag the problems in the type-checking pass later. +(This extra permissiveness might happen with something like + + data SameKind :: k -> k -> Type + data Bad a where + MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) + +which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected +in the second pass, though. Test case: polykinds/TyVarTvKinds3) +Recall that the kind-checking pass exists solely to collect constraints +on the kinds and to power unification. + +To achieve the use of TyVarTvs, we must be careful to use specialized functions +that produce TyVarTvs, not ordinary skolems. This is why we need +kcExplicitTKBndrs and kcImplicitTKBndrs in GHC.Tc.Gen.HsType, separate from their +tc... variants. + +The drawback of this approach is sometimes it will accept a definition that +a (hypothetical) declarative specification would likely reject. As a general +rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, +the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs +approach allows a limited form of polymorphic recursion *without* a CUSK. + +To wit: + data T a = forall k (b :: k). MkT (T b) Int + (test case: dependent/should_compile/T14066a) + +Note that this is polymorphically recursive, with the recursive occurrence +of T used at a kind other than a's kind. The approach outlined here accepts +this definition, because this kind is still a kind variable (and so the +TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a +way to describe exactly what declarations will be accepted and which will +be rejected (without a CUSK). However, the accepted definitions are indeed +well-kinded and any rejected definitions would be accepted with a CUSK, +and so this wrinkle need not cause anyone to lose sleep. + +************************************************************************ +* * +\subsection{Type checking} +* * +************************************************************************ + +Note [Type checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this point we have completed *kind-checking* of a mutually +recursive group of type/class decls (done in kcTyClGroup). However, +we discarded the kind-checked types (eg RHSs of data type decls); +note that kcTyClDecl returns (). There are two reasons: + + * It's convenient, because we don't have to rebuild a + kinded HsDecl (a fairly elaborate type) + + * It's necessary, because after kind-generalisation, the + TyCons/Classes may now be kind-polymorphic, and hence need + to be given kind arguments. + +Example: + data T f a = MkT (f a) (T f a) +During kind-checking, we give T the kind T :: k1 -> k2 -> * +and figure out constraints on k1, k2 etc. Then we generalise +to get T :: forall k. (k->*) -> k -> * +So now the (T f a) in the RHS must be elaborated to (T k f a). + +However, during tcTyClDecl of T (above) we will be in a recursive +"knot". So we aren't allowed to look at the TyCon T itself; we are only +allowed to put it (lazily) in the returned structures. But when +kind-checking the RHS of T's decl, we *do* need to know T's kind (so +that we can correctly elaboarate (T k f a). How can we get T's kind +without looking at T? Delicate answer: during tcTyClDecl, we extend + + *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) + *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) + +Then: + + * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the + fully-known, not knot-tied TcTyCon for T. + + * Then, in GHC.Tc.Utils.Zonk.zonkTcTypeToType (and zonkTcTyCon in particular) + we look in the *global* env to get the TyCon. + +This fancy footwork (with two bindings for T) is only necessary for the +TyCons or Classes of this recursive group. Earlier, finished groups, +live in the global env only. + +See also Note [Kind checking recursive type and class declarations] + +Note [Kind checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before we can type-check the decls, we must kind check them. This +is done by establishing an "initial kind", which is a rather uninformed +guess at a tycon's kind (by counting arguments, mainly) and then +using this initial kind for recursive occurrences. + +The initial kind is stored in exactly the same way during +kind-checking as it is during type-checking (Note [Type checking +recursive type and class declarations]): in the *local* environment, +with ATcTyCon. But we still must store *something* in the *global* +environment. Even though we discard the result of kind-checking, we +sometimes need to produce error messages. These error messages will +want to refer to the tycons being checked, except that they don't +exist yet, and it would be Terribly Annoying to get the error messages +to refer back to HsSyn. So we create a TcTyCon and put it in the +global env. This tycon can print out its name and knows its kind, but +any other action taken on it will panic. Note that TcTyCons are *not* +knot-tied, unlike the rather valid but knot-tied ones that occur +during type-checking. + +Note [Declarations for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wired-in things we simply ignore the declaration +and take the wired-in information. That avoids complications. +e.g. the need to make the data constructor worker name for + a constraint tuple match the wired-in one + +Note [Datatype return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several poorly lit corners around datatype/newtype return kinds. +This Note explains these. We cover data/newtype families and instances +in Note [Data family/instance return kinds]. + +data T a :: where ... -- See Point DT4 +newtype T a :: where ... -- See Point DT5 + +DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations + can have declared return kinds. This Note does not apply to Haskell98 + syntax. + +DT2 Where these kinds come from: The return kind is part of the TyCon kind, gotten either + by checkInitialKind (standalone kind signature / CUSK) or + inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is + then passed to tcDataDefn. + +DT3 Eta-expansion: Any forall-bound variables and function arguments in a result kind + become parameters to the type. That is, when we say + + data T a :: Type -> Type where ... + + we really mean for T to have two parameters. The second parameter + is produced by processing the return kind in etaExpandAlgTyCon, + called in tcDataDefn. + + See also Note [TyConBinders for the result kind signatures of a data type] + in GHC.Tc.Gen.HsType. + +DT4 Datatype return kind restriction: A data type return kind must end + in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By + "end in", we mean we strip any foralls and function arguments off before + checking. + + Examples: + data T1 :: Type -- good + data T2 :: Bool -> Type -- good + data T3 :: Bool -> forall k. Type -- strange, but still accepted + data T4 :: forall k. k -> Type -- good + data T5 :: Bool -- bad + data T6 :: Type -> Bool -- bad + + Exactly the same applies to data instance (but not data family) + declarations. Examples + data instance D1 :: Type -- good + data instance D2 :: Bool -> Type -- good + + We can "look through" type synonyms + type Star = Type + data T7 :: Bool -> Star -- good (synonym expansion ok) + type Arrow = (->) + data T8 :: Arrow Bool Type -- good (ditto) + + But we specifically do *not* do type family reduction here. + type family ARROW where + ARROW = (->) + data T9 :: ARROW Bool Type -- bad + + type family F a where + F Int = Bool + F Bool = Type + data T10 :: Bool -> F Bool -- bad + + The /principle/ here is that in the TyCon for a data type or data instance, + we must be able to lay out all the type-variable binders, one by one, until + we reach (TYPE xx). There is no place for a cast here. We could add one, + but let's not! + + This check is done in checkDataKindSig. For data declarations, this + call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl. + +DT5 Newtype return kind restriction. + If -XUnliftedNewtypes is not on, then newtypes are treated just + like datatypes --- see (4) above. + + If -XUnliftedNewtypes is on, then a newtype return kind must end in + TYPE xyz, for some xyz (after type synonym expansion). The "xyz" + may include type families, but the TYPE part must be visible + /without/ expanding type families (only synonyms). + + This kind is unified with the kind of the representation type (the + type of the one argument to the one constructor). See also steps + (2) and (3) of Note [Implementation of UnliftedNewtypes]. + + The checks are done in the same places as for datatypes. + Examples (assume -XUnliftedNewtypes): + + newtype N1 :: Type -- good + newtype N2 :: Bool -> Type -- good + newtype N3 :: forall r. Bool -> TYPE r -- good + + type family F (t :: Type) :: RuntimeRep + newtype N4 :: forall t -> TYPE (F t) -- good + + type family STAR where + STAR = Type + newtype N5 :: Bool -> STAR -- bad + +Note [Data family/instance return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Within this note, understand "instance" to mean data or newtype +instance, and understand "family" to mean data family. No type +families or classes here. Some examples: + +data family T a :: -- See Point DF56 + +data instance T [a] :: where ... -- See Point DF2 +newtype instance T [a] :: where ... -- See Point DF2 + +Here is the Plan for Data Families: + +DF0 Where these kinds come from: + + Families: The return kind is either written in a standalone signature + or extracted from a family declaration in getInitialKind. + If a family declaration is missing a result kind, it is assumed to be + Type. This assumption is in getInitialKind for CUSKs or + get_fam_decl_initial_kind for non-signature & non-CUSK cases. + + Instances: The data family already has a known kind. The return kind + of an instance is then calculated by applying the data family tycon + to the patterns provided, as computed by the typeKind lhs_ty in the + end of tcDataFamInstHeader. In the case of an instance written in GADT + syntax, there are potentially *two* return kinds: the one computed from + applying the data family tycon to the patterns, and the one given by + the user. This second kind is checked by the tc_kind_sig function within + tcDataFamInstHeader. See also DF3, below. + +DF1 In a data/newtype instance, we treat the kind of the /data family/, + once instantiated, as the "master kind" for the representation + TyCon. For example: + data family T1 :: Type -> Type -> Type + data instance T1 Int :: F Bool -> Type where ... + The "master kind" for the representation TyCon R:T1Int comes + from T1, not from the signature on the data instance. It is as + if we declared + data R:T1Int :: Type -> Type where ... + See Note [Liberalising data family return kinds] for an alternative + plan. But this current plan is simple, and ensures that all instances + are simple instantiations of the master, without strange casts. + + An example with non-trivial instantiation: + data family T2 :: forall k. Type -> k + data instance T2 :: Type -> Type -> Type where ... + Here 'k' gets instantiated with (Type -> Type), driven by + the signature on the 'data instance'. (See also DT3 of + Note [Datatype return kinds] about eta-expansion, which applies here, + too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.) + + A newtype example: + + data Color = Red | Blue + type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep + data family Foo (x :: Color) :: TYPE (Interpret x) + newtype instance Foo 'Red :: TYPE IntRep where + FooRedC :: Int# -> Foo 'Red + + Here we get that Foo 'Red :: TYPE (Interpret Red), and our + representation newtype looks like + newtype R:FooRed :: TYPE (Interpret Red) where + FooRedC :: Int# -> R:FooRed + Remember: the master kind comes from the /family/ tycon. + +DF2 /After/ this instantiation, the return kind of the master kind + must obey the usual rules for data/newtype return kinds (DT4, DT5) + of Note [Datatype return kinds]. Examples: + data family T3 k :: k + data instance T3 Type where ... -- OK + data instance T3 (Type->Type) where ... -- OK + data instance T3 (F Int) where ... -- Not OK + +DF3 Any kind signatures on the data/newtype instance are checked for + equality with the master kind (and hence may guide instantiation) + but are otherwise ignored. So in the T1 example above, we check + that (F Int ~ Type) by unification; but otherwise ignore the + user-supplied signature from the /family/ not the /instance/. + + We must be sure to instantiate any trailing invisible binders + before doing this unification. See the call to tcInstInvisibleBinders + in tcDataFamInstHeader. For example: + data family D :: forall k. k + data instance D :: Type -- forall k. k <: Type + data instance D :: Type -> Type -- forall k. k <: Type -> Type + -- NB: these do not overlap + we must instantiate D before unifying with the signature in the + data instance declaration + +DF4 We also (redundantly) check that any user-specified return kind + signature in the data instance also obeys DT4/DT5. For example we + reject + data family T1 :: Type -> Type -> Type + data instance T1 Int :: Type -> F Int + even if (F Int ~ Type). We could omit this check, because we + use the master kind; but it seems more uniform to check it, again + with checkDataKindSig. + +DF5 Data /family/ return kind restrictions. Consider + data family D8 a :: F a + where F is a type family. No data/newtype instance can instantiate + this so that it obeys the rules of DT4 or DT5. So GHC proactively + rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5). + Remember that a data family supports both data and newtype instances. + + More precisely, the return kind of a data family must be either + * TYPE xyz (for some type xyz) or + * a kind variable + Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5). + This is checked by the call to checkDataKindSig in tcFamDecl1. Examples: + + data family D1 :: Type -- good + data family D2 :: Bool -> Type -- good + data family D3 k :: k -- good + data family D4 :: forall k -> k -- good + data family D5 :: forall k. k -> k -- good + data family D6 :: forall r. TYPE r -- good + data family D7 :: Bool -> STAR -- bad (see STAR from point 5) + +DF6 Two return kinds for instances: If an instance has two return kinds, + one from the family declaration and one from the instance declaration + (see point DF3 above), they are unified. More accurately, we make sure + that the kind of the applied data family is a subkind of the user-written + kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but + that's overkill for our needs here. Instead, we just instantiate any + invisible binders in the (instantiated) kind of the data family + (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders + and then unify the resulting kind with the kind written by the user. + This unification naturally produces a coercion, which we can drop, as + the kind annotation on the instance is redundant (except perhaps for + effects of unification). + + This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes]. + +Note [Liberalising data family return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Could we allow this? + type family F a where { F Int = Type } + data family T a :: F a + data instance T Int where + MkT :: T Int + +In the 'data instance', T Int :: F Int, and F Int = Type, so all seems +well. But there are lots of complications: + +* The representation constructor R:TInt presumably has kind Type. + So the axiom connecting the two would have to look like + axTInt :: T Int ~ R:TInt |> sym axFInt + and that doesn't match expectation in DataFamInstTyCon + in AlgTyConFlav + +* The wrapper can't have type + $WMkT :: Int -> T Int + because T Int has the wrong kind. It would have to be + $WMkT :: Int -> (T Int) |> axFInt + +* The code for $WMkT would also be more complicated, needing + two coherence coercions. Try it! + +* Code for pattern matching would be complicated in an + exactly dual way. + +So yes, we could allow this, but we currently do not. That's +why we have DF2 in Note [Data family/instance return kinds]. + +Note [Implementation of UnliftedNewtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expected behavior of UnliftedNewtypes: + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 + +What follows is a high-level overview of the implementation of the +proposal. + +STEP 1: Getting the initial kind, as done by inferInitialKind. We have +two sub-cases: + +* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind + the user writes, whatever it may be. + +* Without a SAK/CUSK: If there is no kind signature, the tycon is given + a kind `TYPE r`, for a fresh unification variable `r`. We do this even + when -XUnliftedNewtypes is not on; see , below. + +STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. +The key function here is kcConDecl, which looks at an individual constructor +declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes +is enabled; see , below), we generate a correct ContextKind +for the checking argument types: see getArgExpKind. + +Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is +enabled (we use r0 to denote a unification variable): + +newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) ++ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) + is the kind that inferInitialKind invented for (Foo rep). + +data Color = Red | Blue +type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep +data family Foo (x :: Color) :: TYPE (Interpret x) +newtype instance Foo 'Red = FooRedC Int# ++ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep + +Note that, in the GADT case, we might have a kind signature with arrows +(newtype XYZ a b :: Type -> Type where ...). We want only the final +component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon +in kcTyClDecl. + +STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function +here is tcConDecl. Once again, we must use getArgExpKind to ensure that the +representation type's kind matches that of the newtype, for two reasons: + + A. It is possible that a GADT has a CUSK. (Note that this is *not* + possible for H98 types.) Recall that CUSK types don't go through + kcTyClDecl, so we might not have done this kind check. + B. We need to produce the coercion to put on the argument type + if the kinds are different (for both H98 and GADT). + +Example of (B): + +type family F a where + F Int = LiftedRep + +newtype N :: TYPE (F Int) where + MkN :: Int -> N + +We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where +axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the +newtype kind, which is the principal correctness condition for newtypes. + +Wrinkle: Consider (#17021, typecheck/should_fail/T17021) + + type family Id (x :: a) :: a where + Id x = x + + newtype T :: TYPE (Id LiftedRep) where + MkT :: Int -> T + + In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, + never Int -> (T |> TYPE axId); otherwise, the result type of the + constructor wouldn't match the datatype. However, type-checking the + HsType T might reasonably result in (T |> hole). We thus must ensure + that this cast is dropped, forcing the type-checker to add one to + the Int instead. + + Why is it always safe to drop the cast? This result type is type-checked by + tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is + important that even after dropping the cast, the type's kind has the form + TYPE r. This is guaranteed by restrictions on the kinds of datatypes. + For example, a declaration like `newtype T :: Id Type` is rejected: a + newtype's final kind always has the form TYPE r, just as we want. + +Note that this is possible in the H98 case only for a data family, because +the H98 syntax doesn't permit a kind signature on the newtype itself. + +There are also some changes for dealing with families: + +1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if + UnliftedNewtypes is on. This allows us to write things like: + data family Foo :: TYPE 'IntRep + +2. In a newtype instance (with -XUnliftedNewtypes), if the user does + not write a kind signature, we want to allow the possibility that + the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. + This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example: + + data family Bar (a :: RuntimeRep) :: TYPE a + newtype instance Bar 'IntRep = BarIntC Int# + newtype instance Bar 'WordRep :: TYPE 'WordRep where + BarWordC :: Word# -> Bar 'WordRep + + The data instance corresponding to IntRep does not specify a kind signature, + so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). + The data instance corresponding to WordRep does have a kind signature, so + we use that kind signature. + +3. A data family and its newtype instance may be declared with slightly + different kinds. See point DF6 in Note [Data family/instance return kinds] + +There's also a change in the renamer: + +* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means + for a newtype to have a CUSK. This is necessary since UnliftedNewtypes + means that, for newtypes without kind signatures, we must use the field + inside the data constructor to determine the result kind. + See Note [Unlifted Newtypes and CUSKs] for more detail. + +For completeness, it was also necessary to make coerce work on +unlifted types, resolving #13595. + +: It's tempting to think that the expected kind for a newtype +constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type. +But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is +an example: + + newtype A = MkA Int# + +If we expect the argument to MkA to have kind Type, then we get a kind-mismatch +error. The problem is that there is no way to connect this mismatch error to +-XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow +the A to type-check, but then find the problem when doing validity checking (and +where we get make a suitable error message). One potential worry is + + {-# LANGUAGE PolyKinds #-} + newtype B a = MkB a + +This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just +as we would like. Another potential problem comes in a case like + + -- no UnliftedNewtypes + + data family D :: k + newtype instance D = MkD Any + +Here, we want inference to tell us that k should be instantiated to Type in +the instance. With the approach described here (checking for Type only in +the validity checker), that will not happen. But I cannot think of a non-contrived +example that will notice this lack of inference, so it seems better to improve +error messages than be able to infer this instantiation. + +-} + +tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) +tcTyClDecl roles_info (L loc decl) + | Just thing <- wiredInNameTyThing_maybe (tcdName decl) + = case thing of -- See Note [Declarations for wired-in things] + ATyCon tc -> return (tc, wiredInDerivInfo tc decl) + _ -> pprPanic "tcTyClDecl" (ppr thing) + + | otherwise + = setSrcSpan loc $ tcAddDeclCtxt decl $ + do { traceTc "---- tcTyClDecl ---- {" (ppr decl) + ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl + ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) + ; return (tc, deriv_infos) } + +noDerivInfos :: a -> (a, [DerivInfo]) +noDerivInfos a = (a, []) + +wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] +wiredInDerivInfo tycon decl + | DataDecl { tcdDataDefn = dataDefn } <- decl + , HsDataDefn { dd_derivs = derivs } <- dataDefn + = [ DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = + if isFunTyCon tycon || isPrimTyCon tycon + then [] -- no tyConTyVars + else mkTyVarNamePairs (tyConTyVars tycon) + , di_clauses = unLoc derivs + , di_ctxt = tcMkDeclCtxt decl } ] +wiredInDerivInfo _ _ = [] + + -- "type family" declarations +tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) +tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) + = fmap noDerivInfos $ + tcFamDecl1 parent fd + + -- "type" synonym declaration +tcTyClDecl1 _parent roles_info + (SynDecl { tcdLName = L _ tc_name + , tcdRhs = rhs }) + = ASSERT( isNothing _parent ) + fmap noDerivInfos $ + tcTySynRhs roles_info tc_name rhs + + -- "data/newtype" declaration +tcTyClDecl1 _parent roles_info + decl@(DataDecl { tcdLName = L _ tc_name + , tcdDataDefn = defn }) + = ASSERT( isNothing _parent ) + tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn + +tcTyClDecl1 _parent roles_info + (ClassDecl { tcdLName = L _ class_name + , tcdCtxt = hs_ctxt + , tcdMeths = meths + , tcdFDs = fundeps + , tcdSigs = sigs + , tcdATs = ats + , tcdATDefs = at_defs }) + = ASSERT( isNothing _parent ) + do { clas <- tcClassDecl1 roles_info class_name hs_ctxt + meths fundeps sigs ats at_defs + ; return (noDerivInfos (classTyCon clas)) } + + +{- ********************************************************************* +* * + Class declarations +* * +********************************************************************* -} + +tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn + -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] + -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] + -> TcM Class +tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs + = fixM $ \ clas -> + -- We need the knot because 'clas' is passed into tcClassATs + bindTyClTyVars class_name $ \ _ binders res_kind -> + do { checkClassKindSig res_kind + ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) + ; let tycon_name = class_name -- We use the same name + roles = roles_info tycon_name -- for TyCon and Class + + ; (ctxt, fds, sig_stuff, at_stuff) + <- pushTcLevelM_ $ + solveEqualities $ + checkTvConstraints skol_info (binderVars binders) $ + -- The checkTvConstraints is needed bring into scope the + -- skolems bound by the class decl header (#17841) + do { ctxt <- tcHsContext hs_ctxt + ; fds <- mapM (addLocM tc_fundep) fundeps + ; sig_stuff <- tcClassSigs class_name sigs meths + ; at_stuff <- tcClassATs class_name clas ats at_defs + ; return (ctxt, fds, sig_stuff, at_stuff) } + + -- The solveEqualities will report errors for any + -- unsolved equalities, so these zonks should not encounter + -- any unfilled coercion variables unless there is such an error + -- The zonk also squeeze out the TcTyCons, and converts + -- Skolems to tyvars. + ; ze <- emptyZonkEnv + ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff + -- ToDo: do we need to zonk at_stuff? + + -- TODO: Allow us to distinguish between abstract class, + -- and concrete class with no methods (maybe by + -- specifying a trailing where or not + + ; mindef <- tcClassMinimalDef class_name sigs sig_stuff + ; is_boot <- tcIsHsBootOrSig + ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff + = Nothing + | otherwise + = Just (ctxt, at_stuff, sig_stuff, mindef) + + ; clas <- buildClass class_name binders roles fds body + ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ + ppr fds) + ; return clas } + where + skol_info = TyConSkol ClassFlavour class_name + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; + ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; + ; return (tvs1', tvs2') } + + +{- Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following is an example of associated type defaults: + class C a where + data D a + + type F a b :: * + type F a b = [a] -- Default + +Note that we can get default definitions only for type families, not data +families. +-} + +tcClassATs :: Name -- The class name (not knot-tied) + -> Class -- The class parent of this associated type + -> [LFamilyDecl GhcRn] -- Associated types. + -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. + -> TcM [ClassATItem] +tcClassATs class_name cls ats at_defs + = do { -- Complain about associated type defaults for non associated-types + sequence_ [ failWithTc (badATErr class_name n) + | n <- map at_def_tycon at_defs + , not (n `elemNameSet` at_names) ] + ; mapM tc_at ats } + where + at_def_tycon :: LTyFamDefltDecl GhcRn -> Name + at_def_tycon = tyFamInstDeclName . unLoc + + at_fam_name :: LFamilyDecl GhcRn -> Name + at_fam_name = familyDeclName . unLoc + + at_names = mkNameSet (map at_fam_name ats) + + at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] + -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (at_def_tycon at_def) [at_def]) + emptyNameEnv at_defs + + tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at + ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) + `orElse` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } + +------------------------- +tcDefaultAssocDecl :: + TyCon -- ^ Family TyCon (not knot-tied) + -> [LTyFamDefltDecl GhcRn] -- ^ Defaults + -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc (text "More than one default declaration for" + <+> ppr (tyFamInstDeclName (unLoc d1))) + +tcDefaultAssocDecl fam_tc + [L loc (TyFamInstDecl { tfid_eqn = + HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }}})] + = -- See Note [Type-checking default assoc decls] + setSrcSpan loc $ + tcAddFamInstCtxt (text "default type instance") tc_name $ + do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) + ; let fam_tc_name = tyConName fam_tc + vis_arity = length (tyConVisibleTyVars fam_tc) + vis_pats = numVisibleArgs hs_pats + + -- Kind of family check + ; ASSERT( fam_tc_name == tc_name ) + checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + + -- Arity check + ; checkTc (vis_pats == vis_arity) + (wrongNumberOfParmsErr vis_arity) + + -- Typecheck RHS + -- + -- You might think we should pass in some AssocInstInfo, as we're looking + -- at an associated type. But this would be wrong, because an associated + -- type default LHS can mention *different* type variables than the + -- enclosing class. So it's treated more as a freestanding beast. + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated + imp_vars (mb_expl_bndrs `orElse` []) + hs_pats hs_rhs_ty + + ; let fam_tvs = tyConTyVars fam_tc + ; traceTc "tcDefaultAssocDecl 2" (vcat + [ text "hs_pats" <+> ppr hs_pats + , text "hs_rhs_ty" <+> ppr hs_rhs_ty + , text "fam_tvs" <+> ppr fam_tvs + , text "qtvs" <+> ppr qtvs + -- NB: Do *not* print `pats` or rhs_ty here, as they can mention + -- knot-tied TyCons. See #18648. + ]) + ; let subst = case traverse getTyVar_maybe pats of + Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs) + Nothing -> emptyTCvSubst + -- The Nothing case can only be reached in invalid + -- associated type family defaults. In such cases, we + -- simply create an empty substitution and let GHC fall + -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt. + -- See Note [Type-checking default assoc decls]. + ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI loc pats) + -- We perform checks for well-formedness and validity later, in + -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. + } + +{- Note [Type-checking default assoc decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this default declaration for an associated type + + class C a where + type F (a :: k) b :: Type + type F (x :: j) y = Proxy x -> y + +Note that the class variable 'a' doesn't scope over the default assoc +decl, nor do the type variables `k` and `b`. Instead, the default decl is +treated more like a top-level type instance. However, we store the default rhs +(Proxy x -> y) in F's TyCon, using F's own type variables, so we need to +convert it to (Proxy a -> b). We do this in the tcDefaultAssocDecl function by +creating a substitution [j |-> k, x |-> a, b |-> y] and applying this +substitution to the RHS. + +In order to create this substitution, we must first ensure that all of +the arguments in the default instance consist of distinct type variables. +Checking for this property proves surprisingly tricky. Three potential places +where GHC could check for this property include: + +1. Before typechecking (in the parser or renamer) +2. During typechecking (in tcDefaultAssocDecl) +3. After typechecking (using GHC.Tc.Validity) + +Currently, GHC picks option (3) and implements this check using +GHC.Tc.Validity.checkValidAssocTyFamDeflt. GHC previously used options (1) and +(2), but neither option quite worked out for reasons that we will explain +shortly. + +The first thing that checkValidAssocTyFamDeflt does is check that all arguments +in an associated type family default are type variables. As a motivating +example, consider this erroneous program (inspired by #11361): + + class C a where + type F (a :: k) b :: Type + type F x b = x + +If you squint, you'll notice that the kind of `x` is actually Type. However, +we cannot substitute from [Type |-> k], so we reject this default. This also +explains why GHC no longer implements option (1) above, since figuring out that +`x`'s kind is Type would be much more difficult without the knowledge that the +typechecker provides. + +Next, checkValidAssocTyFamDeflt checks that all arguments are distinct. Here is +another offending example, this time taken from #13971: + + class C2 (a :: j) where + type F2 (a :: j) (b :: k) + type F2 (x :: z) y = SameKind x y + data SameKind :: k -> k -> Type + +All of the arguments in the default equation for `F2` are type variables, so +that passes the first check. However, if we were to build this substitution, +then both `j` and `k` map to `z`! In terms of visible kind application, it's as +if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear +that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is +also rejected. + +There is one more design consideration in play here: what error message should +checkValidAssocTyFamDeflt produce if one of its checks fails? Ideally, it would +be something like this: + + Illegal duplicate variable ‘z’ in: + ‘type F2 @z @z x y = ...’ + The arguments to ‘F2’ must all be distinct type variables + +This requires printing out the arguments to the associated type family. This +can be dangerous, however. Consider this example, adapted from #18648: + + class C3 a where + type F3 a + type F3 (F3 a) = a + +F3's default is illegal, since its argument is not a bare type variable. But +note that when we typecheck F3's default, the F3 type constructor is knot-tied. +Therefore, if we print the type `F3 a` in an error message, GHC will diverge! +This is the reason why GHC no longer implements option (2) above and instead +waits until /after/ typechecking has finished, at which point the typechecker +knot has been worked out. + +As one final point, one might worry that the typechecker knot could cause the +substitution that tcDefaultAssocDecl creates to diverge, but this is not the +case. Since the LHS of a valid associated type family default is always just +variables, it won't contain any tycons. Accordingly, the patterns used in the +substitution won't actually be knot-tied, even though we're in the knot. (This +is too delicate for my taste, but it works.) If we're dealing with /invalid/ +default, such as F3's above, then we simply create an empty substitution and +rely on checkValidAssocTyFamDeflt throwing an error message afterwards before +any damage is done. +-} + +{- ********************************************************************* +* * + Type family declarations +* * +********************************************************************* -} + +tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon +tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info + , fdLName = tc_lname@(L _ tc_name) + , fdResultSig = L _ sig + , fdInjectivityAnn = inj }) + | DataFamily <- fam_info + = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + { traceTc "data family:" (ppr tc_name) + ; checkFamFlag tc_name + + -- Check that the result kind is OK + -- We allow things like + -- data family T (a :: Type) :: forall k. k -> Type + -- We treat T as having arity 1, but result kind forall k. k -> Type + -- But we want to check that the result kind finishes in + -- Type or a kind-variable + -- For the latter, consider + -- data family D a :: forall k. Type -> k + -- When UnliftedNewtypes is enabled, we loosen this restriction + -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). + -- See also Note [Datatype return kinds] + ; checkDataKindSig DataFamilySort res_kind + ; tc_rep_name <- newTyConRepName tc_name + ; let inj = Injective $ replicate (length binders) True + tycon = mkFamilyTyCon tc_name binders + res_kind + (resultVariableName sig) + (DataFamilyTyCon tc_rep_name) + parent inj + ; return tycon } + + | OpenTypeFamily <- fam_info + = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + { traceTc "open type family:" (ppr tc_name) + ; checkFamFlag tc_name + ; inj' <- tcInjectivity binders inj + ; checkResultSigFlag tc_name sig -- check after injectivity for better errors + ; let tycon = mkFamilyTyCon tc_name binders res_kind + (resultVariableName sig) OpenSynFamilyTyCon + parent inj' + ; return tycon } + + | ClosedTypeFamily mb_eqns <- fam_info + = -- Closed type families are a little tricky, because they contain the definition + -- of both the type family and the equations for a CoAxiom. + do { traceTc "Closed type family:" (ppr tc_name) + -- the variables in the header scope only over the injectivity + -- declaration but this is not involved here + ; (inj', binders, res_kind) + <- bindTyClTyVars tc_name $ \ _ binders res_kind -> + do { inj' <- tcInjectivity binders inj + ; return (inj', binders, res_kind) } + + ; checkFamFlag tc_name -- make sure we have -XTypeFamilies + ; checkResultSigFlag tc_name sig + + -- If Nothing, this is an abstract family in a hs-boot file; + -- but eqns might be empty in the Just case as well + ; case mb_eqns of + Nothing -> + return $ mkFamilyTyCon tc_name binders res_kind + (resultVariableName sig) + AbstractClosedSynFamilyTyCon parent + inj' + Just eqns -> do { + + -- Process the equations, creating CoAxBranches + ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind + noTcTyConScopedTyVars + False {- this doesn't matter here -} + ClosedTypeFamilyFlavour + + ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns + -- Do not attempt to drop equations dominated by earlier + -- ones here; in the case of mutual recursion with a data + -- type, we get a knot-tying failure. Instead we check + -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom + -- Example: tc265 + + -- Create a CoAxiom, with the correct src location. + ; co_ax_name <- newFamInstAxiomName tc_lname [] + + ; let mb_co_ax + | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list + | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) + + fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) + (ClosedSynFamilyTyCon mb_co_ax) parent inj' + + -- We check for instance validity later, when doing validity + -- checking for the tycon. Exception: checking equations + -- overlap done by dropDominatedAxioms + ; return fam_tc } } + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker +#endif + +-- | Maybe return a list of Bools that say whether a type family was declared +-- injective in the corresponding type arguments. Length of the list is equal to +-- the number of arguments (including implicit kind/coercion arguments). +-- True on position +-- N means that a function is injective in its Nth argument. False means it is +-- not. +tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) + -> TcM Injectivity +tcInjectivity _ Nothing + = return NotInjective + + -- User provided an injectivity annotation, so for each tyvar argument we + -- check whether a type family was declared injective in that argument. We + -- return a list of Bools, where True means that corresponding type variable + -- was mentioned in lInjNames (type family is injective in that argument) and + -- False means that it was not mentioned in lInjNames (type family is not + -- injective in that type variable). We also extend injectivity information to + -- kind variables, so if a user declares: + -- + -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a + -- + -- then we mark both `a` and `k1` as injective. + -- NB: the return kind is considered to be *input* argument to a type family. + -- Since injectivity allows to infer input arguments from the result in theory + -- we should always mark the result kind variable (`k3` in this example) as + -- injective. The reason is that result type has always an assigned kind and + -- therefore we can always infer the result kind if we know the result type. + -- But this does not seem to be useful in any way so we don't do it. (Another + -- reason is that the implementation would not be straightforward.) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) + = setSrcSpan loc $ + do { let tvs = binderVars tcbs + ; dflags <- getDynFlags + ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) + (text "Illegal injectivity annotation" $$ + text "Use TypeFamilyDependencies to allow this") + ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames + ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds + ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars + closeOverKinds (mkVarSet inj_tvs) + ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs + ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs + , ppr inj_ktvs, ppr inj_bools ]) + ; return $ Injective inj_bools } + +tcTySynRhs :: RolesInfo -> Name + -> LHsType GhcRn -> TcM TyCon +tcTySynRhs roles_info tc_name hs_ty + = bindTyClTyVars tc_name $ \ _ binders res_kind -> + do { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; rhs_ty <- pushTcLevelM_ $ + solveEqualities $ + tcCheckLHsType hs_ty (TheKind res_kind) + ; rhs_ty <- zonkTcTypeToType rhs_ty + ; let roles = roles_info tc_name + tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty + ; return tycon } + +tcDataDefn :: SDoc -> RolesInfo -> Name + -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) + -- NB: not used for newtype/data instances (whether associated or not) +tcDataDefn err_ctxt roles_info tc_name + (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = ctxt + , dd_kindSig = mb_ksig -- Already in tc's kind + -- via inferInitialKinds + , dd_cons = cons + , dd_derivs = derivs }) + = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind -> + -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need + -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon' + -- + -- The TyCon tyvars must scope over + -- - the stupid theta (dd_ctxt) + -- - for H98 constructors only, the ConDecl + -- But it does no harm to bring them into scope + -- over GADT ConDecls as well; and it's awkward not to + do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons + -- see Note [Datatype return kinds] + ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind + + ; tcg_env <- getGblEnv + ; let hsc_src = tcg_src tcg_env + ; unless (mk_permissive_kind hsc_src cons) $ + checkDataKindSig (DataDeclSort new_or_data) final_res_kind + + ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt + ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta + ; kind_signatures <- xoptM LangExt.KindSignatures + + -- Check that we don't use kind signatures without Glasgow extensions + ; when (isJust mb_ksig) $ + checkTc (kind_signatures) (badSigTyDecl tc_name) + + ; tycon <- fixM $ \ tycon -> do + { let final_bndrs = tycon_binders `chkAppend` extra_bndrs + res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) + roles = roles_info tc_name + ; data_cons <- tcConDecls + tycon + new_or_data + final_bndrs + final_res_kind + res_ty + cons + ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons + ; tc_rep_nm <- newTyConRepName tc_name + ; return (mkAlgTyCon tc_name + final_bndrs + final_res_kind + roles + (fmap unLoc cType) + stupid_theta tc_rhs + (VanillaAlgTyCon tc_rep_nm) + gadt_syntax) } + ; let deriv_info = DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = tcTyConScopedTyVars tctc + , di_clauses = unLoc derivs + , di_ctxt = err_ctxt } + ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) + ; return (tycon, [deriv_info]) } + where + -- Abstract data types in hsig files can have arbitrary kinds, + -- because they may be implemented by type synonyms + -- (which themselves can have arbitrary kinds, not just *). See #13955. + -- + -- Note that this is only a property that data type declarations possess, + -- so one could not have, say, a data family instance in an hsig file that + -- has kind `Bool`. Therefore, this check need only occur in the code that + -- typechecks data type declarations. + mk_permissive_kind HsigFile [] = True + mk_permissive_kind _ _ = False + + -- In hs-boot, a 'data' declaration with no constructors + -- indicates a nominally distinct abstract data type. + mk_tc_rhs HsBootFile _ [] + = return AbstractTyCon + + mk_tc_rhs HsigFile _ [] -- ditto + = return AbstractTyCon + + mk_tc_rhs _ tycon data_cons + = case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs tc_name tycon (head data_cons) + + +------------------------- +kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () +-- Used for the equations of a closed type family only +-- Not used for data/type instances +kcTyFamInstEqn tc_fam_tc + (L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) + = setSrcSpan loc $ + do { traceTc "kcTyFamInstEqn" (vcat + [ text "tc_name =" <+> ppr eqn_tc_name + , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) + , text "hsib_vars =" <+> ppr imp_vars + , text "feqn_bndrs =" <+> ppr mb_expl_bndrs + , text "feqn_pats =" <+> ppr hs_pats ]) + -- this check reports an arity error instead of a kind error; easier for user + ; let vis_pats = numVisibleArgs hs_pats + + -- First, check if we're dealing with a closed type family equation, and + -- if so, ensure that each equation's type constructor is for the right + -- type family. E.g. barf on + -- type family F a where { G Int = Bool } + ; checkTc (tc_fam_tc_name == eqn_tc_name) $ + wrongTyFamName tc_fam_tc_name eqn_tc_name + + ; checkTc (vis_pats == vis_arity) $ + wrongNumberOfParmsErr vis_arity + + ; discardResult $ + bindImplicitTKBndrs_Q_Tv imp_vars $ + bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ + do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats + ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) } + -- Why "_Tv" here? Consider (#14066 + -- type family Bar x y where + -- Bar (x :: a) (y :: b) = Int + -- Bar (x :: c) (y :: d) = Bool + -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately + } + where + vis_arity = length (tyConVisibleTyVars tc_fam_tc) + tc_fam_tc_name = getName tc_fam_tc + +-------------------------- +tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn + -> TcM (KnotTied CoAxBranch) +-- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families +-- (typechecked here) have TyFamInstEqns + +tcTyFamInstEqn fam_tc mb_clsinfo + (L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) + = setSrcSpan loc $ + do { traceTc "tcTyFamInstEqn" $ + vcat [ ppr fam_tc <+> ppr hs_pats + , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) + , case mb_clsinfo of + NotAssociated {} -> empty + InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] + + -- First, check the arity of visible arguments + -- If we wait until validity checking, we'll get kind errors + -- below when an arity error will be much easier to understand. + -- Note that for closed type families, kcTyFamInstEqn has already + -- checked the arity previously. + ; let vis_arity = length (tyConVisibleTyVars fam_tc) + vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ + wrongNumberOfParmsErr vis_arity + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo + imp_vars (mb_expl_bndrs `orElse` []) + hs_pats hs_rhs_ty + -- Don't print results they may be knot-tied + -- (tcFamInstEqnGuts zonks to Type) + ; return (mkCoAxBranch qtvs [] [] pats rhs_ty + (map (const Nominal) qtvs) + loc) } + +{- +Kind check type patterns and kind annotate the embedded type variables. + type instance F [a] = rhs + + * Here we check that a type instance matches its kind signature, but we do + not check whether there is a pattern for each type index; the latter + check is only required for type synonym instances. + +Note [Instantiating a family tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's possible that kind-checking the result of a family tycon applied to +its patterns will instantiate the tycon further. For example, we might +have + + type family F :: k where + F = Int + F = Maybe + +After checking (F :: forall k. k) (with no visible patterns), we still need +to instantiate the k. With data family instances, this problem can be even +more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See +indexed-types/should_compile/T12369 for an example. + +So, the kind-checker must return the new skolems and args (that is, Type +or (Type -> Type) for the equations above) and the instantiated kind. + +Note [Generalising in tcTyFamInstEqnGuts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like + type instance forall (a::k) b. F t1 t2 = rhs + +Then imp_vars = [k], exp_bndrs = [a::k, b] + +We want to quantify over + * k, a, and b (all user-specified) + * and any inferred free kind vars from + - the kinds of k, a, b + - the types t1, t2 + +However, unlike a type signature like + f :: forall (a::k). blah + +we do /not/ care about the Inferred/Specified designation +or order for the final quantified tyvars. Type-family +instances are not invoked directly in Haskell source code, +so visible type application etc plays no role. + +So, the simple thing is + - gather candidates from [k, a, b] and pats + - quantify over them + +Hence the slightly mysterious call: + candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs) + +Simple, neat, but a little non-obvious! + +See also Note [Re-quantify type variables in rules] in GHC.Tc.Gen.Rule, which explains +a very similar design when generalising over the type of a rewrite rule. +-} + +-------------------------- +tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo + -> [Name] -> [LHsTyVarBndr () GhcRn] -- Implicit and explicicit binder + -> HsTyPats GhcRn -- Patterns + -> LHsType GhcRn -- RHS + -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) +-- Used only for type families, not data families +tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty + = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) + + -- By now, for type families (but not data families) we should + -- have checked that the number of patterns matches tyConArity + + -- This code is closely related to the code + -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk + ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol imp_vars $ + bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ + do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats + -- Ensure that the instance is consistent with its + -- parent class (#16008) + ; addConsistencyConstraints mb_clsinfo lhs_ty + ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind) + ; return (lhs_ty, rhs_ty) } + + -- See Note [Generalising in tcTyFamInstEqnGuts] + -- This code (and the stuff immediately above) is very similar + -- to that in tcDataFamInstHeader. Maybe we should abstract the + -- common code; but for the moment I concluded that it's + -- clearer to duplicate it. Still, if you fix a bug here, + -- check there too! + ; let scoped_tvs = imp_tvs ++ exp_tvs + ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) + ; qtvs <- quantifyTyVars dvs + + ; traceTc "tcTyFamInstEqnGuts 2" $ + vcat [ ppr fam_tc + , text "scoped_tvs" <+> pprTyVars scoped_tvs + , text "lhs_ty" <+> ppr lhs_ty + , text "dvs" <+> ppr dvs + , text "qtvs" <+> pprTyVars qtvs ] + + ; (ze, qtvs) <- zonkTyBndrs qtvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + + ; let pats = unravelFamInstPats lhs_ty + -- Note that we do this after solveEqualities + -- so that any strange coercions inside lhs_ty + -- have been solved before we attempt to unravel it + ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) + ; return (qtvs, pats, rhs_ty) } + +----------------- +unravelFamInstPats :: TcType -> [TcType] +-- Decompose fam_app to get the argument patterns +-- +-- We expect fam_app to look like (F t1 .. tn) +-- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), +-- but that can't happen here because we already checked the +-- arity of F matches the number of pattern +unravelFamInstPats fam_app + = case splitTyConApp_maybe fam_app of + Just (_, pats) -> pats + Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" + -- The Nothing case cannot happen for type families, because + -- we don't call unravelFamInstPats until we've solved the + -- equalities. For data families, it shouldn't happen either, + -- we need to fail hard and early if it does. See trac issue #15905 + -- for an example of this happening. + +addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () +-- In the corresponding positions of the class and type-family, +-- ensure the family argument is the same as the class argument +-- E.g class C a b c d where +-- F c x y a :: Type +-- Here the first arg of F should be the same as the third of C +-- and the fourth arg of F should be the same as the first of C +-- +-- We emit /Derived/ constraints (a bit like fundeps) to encourage +-- unification to happen, but without actually reporting errors. +-- If, despite the efforts, corresponding positions do not match, +-- checkConsistentFamInst will complain +addConsistencyConstraints mb_clsinfo fam_app + | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo + , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app + = do { let eqs = [ (cls_ty, pat) + | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats + , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] + ; traceTc "addConsistencyConstraints" (ppr eqs) + ; emitDerivedEqs AssocFamPatOrigin eqs } + -- Improve inference + -- Any mis-match is reports by checkConsistentFamInst + | otherwise + = return () + +{- Note [Constraints in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This isn't the whole story. See comment in tcFamTyPats. + +At first glance, it seems there is a complicated story to tell in tcFamTyPats +around constraint solving. After all, type family patterns can now do +GADT pattern-matching, which is jolly complicated. But, there's a key fact +which makes this all simple: everything is at top level! There cannot +be untouchable type variables. There can't be weird interaction between +case branches. There can't be global skolems. + +This means that the semantics of type-level GADT matching is a little +different than term level. If we have + + data G a where + MkGBool :: G Bool + +And then + + type family F (a :: G k) :: k + type instance F MkGBool = True + +we get + + axF : F Bool (MkGBool ) ~ True + +Simple! No casting on the RHS, because we can affect the kind parameter +to F. + +If we ever introduce local type families, this all gets a lot more +complicated, and will end up looking awfully like term-level GADT +pattern-matching. + + +** The new story ** + +Here is really what we want: + +The matcher really can't deal with covars in arbitrary spots in coercions. +But it can deal with covars that are arguments to GADT data constructors. +So we somehow want to allow covars only in precisely those spots, then use +them as givens when checking the RHS. TODO (RAE): Implement plan. + +Note [Quantified kind variables of a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider type family KindFam (p :: k1) (q :: k1) + data T :: Maybe k1 -> k2 -> * + type instance KindFam (a :: Maybe k) b = T a b -> Int +The HsBSig for the family patterns will be ([k], [a]) + +Then in the family instance we want to + * Bring into scope [ "k" -> k:*, "a" -> a:k ] + * Kind-check the RHS + * Quantify the type instance over k and k', as well as a,b, thus + type instance [k, k', a:Maybe k, b:k'] + KindFam (Maybe k) k' a b = T k k' a b -> Int + +Notice that in the third step we quantify over all the visibly-mentioned +type variables (a,b), but also over the implicitly mentioned kind variables +(k, k'). In this case one is bound explicitly but often there will be +none. The role of the kind signature (a :: Maybe k) is to add a constraint +that 'a' must have that kind, and to bring 'k' into scope. + + + +************************************************************************ +* * + Data types +* * +************************************************************************ +-} + +dataDeclChecks :: Name -> NewOrData + -> LHsContext GhcRn -> [LConDecl GhcRn] + -> TcM Bool +dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons + = do { -- Check that we don't use GADT syntax in H98 world + gadtSyntax_ok <- xoptM LangExt.GADTSyntax + ; let gadt_syntax = consUseGadtSyntax cons + ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration + ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) + + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM LangExt.EmptyDataDecls + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) + ; return gadt_syntax } + + +----------------------------------- +consUseGadtSyntax :: [LConDecl GhcRn] -> Bool +consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True +consUseGadtSyntax _ = False + -- All constructors have same shape + +----------------------------------- +tcConDecls :: KnotTied TyCon -> NewOrData + -> [TyConBinder] -> TcKind -- binders and result kind of tycon + -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon] +tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl + = concatMapM $ addLocM $ + tcConDecl rep_tycon (mkTyConTagMap rep_tycon) + tmpl_bndrs res_kind res_tmpl new_or_data + -- It's important that we pay for tag allocation here, once per TyCon, + -- See Note [Constructor tag allocation], fixes #14657 + +tcConDecl :: KnotTied TyCon -- Representation tycon. Knot-tied! + -> NameEnv ConTag + -> [TyConBinder] -> TcKind -- tycon binders and result kind + -> KnotTied Type + -- Return type template (T tys), where T is the family TyCon + -> NewOrData + -> ConDecl GhcRn + -> TcM [DataCon] + +tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data + (ConDeclH98 { con_name = name + , con_ex_tvs = explicit_tkv_nms + , con_mb_cxt = hs_ctxt + , con_args = hs_args }) + = addErrCtxt (dataConCtxtName [name]) $ + do { -- NB: the tyvars from the declaration header are in scope + + -- Get hold of the existential type variables + -- e.g. data T a = forall k (b::k) f. MkT a (f b) + -- Here tmpl_bndrs = {a} + -- hs_qvars = HsQTvs { hsq_implicit = {k} + -- , hsq_explicit = {f,b} } + + ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) + + ; (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)) + <- pushTcLevelM_ $ + solveEqualities $ + bindExplicitTKBndrs_Skol explicit_tkv_nms $ + do { ctxt <- tcHsMbContext hs_ctxt + ; let exp_kind = getArgExpKind new_or_data res_kind + ; btys <- tcConArgs exp_kind hs_args + ; field_lbls <- lookupConstructorFields (unLoc name) + ; let (arg_tys, stricts) = unzip btys + ; return (ctxt, arg_tys, field_lbls, stricts) + } + + ; let tmpl_tvs = binderVars tmpl_bndrs + + -- exp_tvs have explicit, user-written binding sites + -- the kvs below are those kind variables entirely unmentioned by the user + -- and discovered only by generalization + + ; kvs <- kindGeneralizeAll (mkSpecForAllTys tmpl_tvs $ + mkInvisForAllTys exp_tvbndrs $ + mkPhiTy ctxt $ + mkVisFunTys arg_tys $ + unitTy) + -- That type is a lie, of course. (It shouldn't end in ()!) + -- And we could construct a proper result type from the info + -- at hand. But the result would mention only the tmpl_tvs, + -- and so it just creates more work to do it right. Really, + -- we're only doing this to find the right kind variables to + -- quantify over, and this type is fine for that purpose. + + -- Zonk to Types + ; (ze, qkvs) <- zonkTyBndrs kvs + ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs + ; let user_qtvs = binderVars user_qtvbndrs + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt + + ; fam_envs <- tcGetFamInstEnvs + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) + ; let + univ_tvbs = tyConInvisTVBinders tmpl_bndrs + univ_tvs = binderVars univ_tvbs + ex_tvbs = mkTyVarBinders InferredSpec qkvs ++ + user_qtvbndrs + ex_tvs = qkvs ++ user_qtvs + -- For H98 datatypes, the user-written tyvar binders are precisely + -- the universals followed by the existentials. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + user_tvbs = univ_tvbs ++ ex_tvbs + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfixH98 name hs_args + ; rep_nm <- newTyConRepName name + + ; buildDataCon fam_envs name is_infix rep_nm + stricts Nothing field_lbls + univ_tvs ex_tvs user_tvbs + [{- no eq_preds -}] ctxt arg_tys + res_tmpl rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; traceTc "tcConDecl 2" (ppr name) + ; mapM buildOneDataCon [name] + } + +tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data + -- NB: don't use res_kind here, as it's ill-scoped. Instead, + -- we get the res_kind by typechecking the result type. + (ConDeclGADT { con_g_ext = implicit_tkv_nms + , con_names = names + , con_qvars = explicit_tkv_nms + , con_mb_cxt = cxt, con_args = hs_args + , con_res_ty = hs_res_ty }) + = addErrCtxt (dataConCtxtName names) $ + do { traceTc "tcConDecl 1 gadt" (ppr names) + ; let (L _ name : _) = names + + ; (imp_tvs, (exp_tvbndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) + <- pushTcLevelM_ $ -- We are going to generalise + solveEqualities $ -- We won't get another crack, and we don't + -- want an error cascade + bindImplicitTKBndrs_Skol implicit_tkv_nms $ + bindExplicitTKBndrs_Skol explicit_tkv_nms $ + do { ctxt <- tcHsMbContext cxt + ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty + -- See Note [GADT return kinds] + + -- See Note [Datatype return kinds] + ; let exp_kind = getArgExpKind new_or_data res_kind + + ; btys <- tcConArgs exp_kind hs_args + ; let (arg_tys, stricts) = unzip btys + ; field_lbls <- lookupConstructorFields name + ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) + } + ; imp_tvs <- zonkAndScopedSort imp_tvs + + ; tkvs <- kindGeneralizeAll (mkSpecForAllTys imp_tvs $ + mkInvisForAllTys exp_tvbndrs $ + mkPhiTy ctxt $ + mkVisFunTys arg_tys $ + res_ty) + + ; let tvbndrs = (mkTyVarBinders InferredSpec tkvs) + ++ (mkTyVarBinders SpecifiedSpec imp_tvs) + ++ exp_tvbndrs + + -- Zonk to Types + ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; res_ty <- zonkTcTypeToTypeX ze res_ty + + ; let (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) + = rejigConRes tmpl_bndrs res_tmpl tvbndrs res_ty + -- See Note [Checking GADT return types] + + ctxt' = substTys arg_subst ctxt + arg_tys' = substScaledTys arg_subst arg_tys + res_ty' = substTy arg_subst res_ty + + + ; fam_envs <- tcGetFamInstEnvs + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) + ; let + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfixGADT name hs_args + ; rep_nm <- newTyConRepName name + + ; buildDataCon fam_envs name is_infix + rep_nm + stricts Nothing field_lbls + univ_tvs ex_tvs tvbndrs' eq_preds + ctxt' arg_tys' res_ty' rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; traceTc "tcConDecl 2" (ppr names) + ; mapM buildOneDataCon names + } + +{- Note [GADT return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family Star where Star = Type + data T :: Type where + MkT :: Int -> T + +If, for some stupid reason, tcInferLHsTypeKind on the return type of +MkT returned (T |> ax, Star), then the return-type check in +checkValidDataCon would reject the decl (although of course there is +nothing wrong with it). We are implicitly requiring tha +tcInferLHsTypeKind doesn't any gratuitous top-level casts. +-} + +-- | Produce an "expected kind" for the arguments of a data/newtype. +-- If the declaration is indeed for a newtype, +-- then this expected kind will be the kind provided. Otherwise, +-- it is OpenKind for datatypes and liftedTypeKind. +-- Why do we not check for -XUnliftedNewtypes? See point +-- in Note [Implementation of UnliftedNewtypes] +getArgExpKind :: NewOrData -> Kind -> ContextKind +getArgExpKind NewType res_ki = TheKind res_ki +getArgExpKind DataType _ = OpenKind + +tcConIsInfixH98 :: Name + -> HsConDetails a b + -> TcM Bool +tcConIsInfixH98 _ details + = case details of + InfixCon {} -> return True + _ -> return False + +tcConIsInfixGADT :: Name + -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r + -> TcM Bool +tcConIsInfixGADT con details + = case details of + InfixCon {} -> return True + RecCon {} -> return False + PrefixCon arg_tys -- See Note [Infix GADT constructors] + | isSymOcc (getOccName con) + , [_ty1,_ty2] <- map hsScaledThing arg_tys + -> do { fix_env <- getFixityEnv + ; return (con `elemNameEnv` fix_env) } + | otherwise -> return False + +tcConArgs :: ContextKind -- expected kind of arguments + -- always OpenKind for datatypes, but unlifted newtypes + -- might have a specific kind + -> HsConDeclDetails GhcRn + -> TcM [(Scaled TcType, HsSrcBang)] +tcConArgs exp_kind (PrefixCon btys) + = mapM (tcConArg exp_kind) btys +tcConArgs exp_kind (InfixCon bty1 bty2) + = do { bty1' <- tcConArg exp_kind bty1 + ; bty2' <- tcConArg exp_kind bty2 + ; return [bty1', bty2'] } +tcConArgs exp_kind (RecCon fields) + = mapM (tcConArg exp_kind) btys + where + -- We need a one-to-one mapping from field_names to btys + combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) + (unLoc fields) + explode (ns,ty) = zip ns (repeat ty) + exploded = concatMap explode combined + (_,btys) = unzip exploded + + +tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, + -- but might be an unlifted type with UnliftedNewtypes + -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang) +tcConArg exp_kind (HsScaled w bty) + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind + ; w' <- tcDataConMult w + ; traceTc "tcConArg 2" (ppr bty) + ; return (Scaled w' arg_ty, getBangStrictness bty) } + +tcDataConMult :: HsArrow GhcRn -> TcM Mult +tcDataConMult arr@(HsUnrestrictedArrow _) = do + -- See Note [Function arrows in GADT constructors] + linearEnabled <- xoptM LangExt.LinearTypes + if linearEnabled then tcMult arr else return oneDataConTy +tcDataConMult arr = tcMult arr + +{- +Note [Function arrows in GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the absence of -XLinearTypes, we always interpret function arrows +in GADT constructor types as linear, even if the user wrote an +unrestricted arrow. See the "Without -XLinearTypes" section of the +linear types GHC proposal (#111). We opt to do this in the +typechecker, and not in an earlier pass, to ensure that the AST +matches what the user wrote (#18791). + +Note [Infix GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not currently have syntax to declare an infix constructor in GADT syntax, +but it makes a (small) difference to the Show instance. So as a slightly +ad-hoc solution, we regard a GADT data constructor as infix if + a) it is an operator symbol + b) it has two arguments + c) there is a fixity declaration for it +For example: + infix 6 (:--:) + data T a where + (:--:) :: t1 -> t2 -> T Int + + +Note [Checking GADT return types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a delicacy around checking the return types of a datacon. The +central problem is dealing with a declaration like + + data T a where + MkT :: T a -> Q a + +Note that the return type of MkT is totally bogus. When creating the T +tycon, we also need to create the MkT datacon, which must have a "rejigged" +return type. That is, the MkT datacon's type must be transformed to have +a uniform return type with explicit coercions for GADT-like type parameters. +This rejigging is what rejigConRes does. The problem is, though, that checking +that the return type is appropriate is much easier when done over *Type*, +not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully +defined yet. + +So, we want to make rejigConRes lazy and then check the validity of +the return type in checkValidDataCon. To do this we /always/ return a +6-tuple from rejigConRes (so that we can compute the return type from it, which +checkValidDataCon needs), but the first three fields may be bogus if +the return type isn't valid (the last equation for rejigConRes). + +This is better than an earlier solution which reduced the number of +errors reported in one pass. See #7175, and #10836. +-} + +-- Example +-- data instance T (b,c) where +-- TI :: forall e. e -> T (e,e) +-- +-- The representation tycon looks like this: +-- data :R7T b c where +-- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 +-- In this case orig_res_ty = T (e,e) + +rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. + -- data instance T [a] b c ... + -- gives template ([a,b,c], T [a] b c) + -> [InvisTVBinder] -- The constructor's type variables (both inferred and user-written) + -> KnotTied Type -- res_ty + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [InvisTVBinder], -- The constructor's rejigged, user-written + -- type variables + [EqSpec], -- Equality predicates + TCvSubst) -- Substitution to apply to argument types + -- We don't check that the TyCon given in the ResTy is + -- the same as the parent tycon, because checkValidDataCon will do it +-- NB: All arguments may potentially be knot-tied +rejigConRes tmpl_bndrs res_tmpl dc_tvbndrs res_ty + -- E.g. data T [a] b c where + -- MkT :: forall x y z. T [(x,y)] z z + -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs + -- (NB: unlike the H98 case, the dc_tvs are not all existential) + -- Then we generate + -- Univ tyvars Eq-spec + -- a a~(x,y) + -- b b~z + -- z + -- Existentials are the leftover type vars: [x,y] + -- The user-written type variables are what is listed in the forall: + -- [x, y, z] (all specified). We must rejig these as well. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + -- So we return ( [a,b,z], [x,y] + -- , [], [x,y,z] + -- , [a~(x,y),b~z], ) + | Just subst <- tcMatchTy res_tmpl res_ty + = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst + raw_ex_tvs = dc_tvs `minusList` univ_tvs + (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs + + -- After rejigging the existential tyvars, the resulting substitution + -- gives us exactly what we need to rejig the user-written tyvars, + -- since the dcUserTyVarBinders invariant guarantees that the + -- substitution has *all* the tyvars in its domain. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + subst_user_tvs = mapVarBndrs (getTyVar "rejigConRes" . substTyVar arg_subst) + substed_tvbndrs = subst_user_tvs dc_tvbndrs + + substed_eqs = map (substEqSpec arg_subst) raw_eqs + in + (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst) + + | otherwise + -- If the return type of the data constructor doesn't match the parent + -- type constructor, or the arity is wrong, the tcMatchTy will fail + -- e.g data T a b where + -- T1 :: Maybe a -- Wrong tycon + -- T2 :: T [a] -- Wrong arity + -- We are detect that later, in checkValidDataCon, but meanwhile + -- we must do *something*, not just crash. So we do something simple + -- albeit bogus, relying on checkValidDataCon to check the + -- bad-result-type error before seeing that the other fields look odd + -- See Note [Checking GADT return types] + = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_tvbndrs, [], emptyTCvSubst) + where + dc_tvs = binderVars dc_tvbndrs + tmpl_tvs = binderVars tmpl_bndrs + +{- Note [mkGADTVars] +~~~~~~~~~~~~~~~~~~~~ +Running example: + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: forall (x1 : *) (y :: x1) (z :: *). + T x1 * (Proxy (y :: x1), z) z + +We need the rejigged type to be + + MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). + forall (y :: x1) (z :: *). + (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) + => T x1 k2 a b + +You might naively expect that z should become a universal tyvar, +not an existential. (After all, x1 becomes a universal tyvar.) +But z has kind * while b has kind k2, so the return type + T x1 k2 a z +is ill-kinded. Another way to say it is this: the universal +tyvars must have exactly the same kinds as the tyConTyVars. + +So we need an existential tyvar and a heterogeneous equality +constraint. (The b ~ z is a bit redundant with the k2 ~ * that +comes before in that b ~ z implies k2 ~ *. I'm sure we could do +some analysis that could eliminate k2 ~ *. But we don't do this +yet.) + +The data con signature has already been fully kind-checked. +The return type + + T x1 * (Proxy (y :: x1), z) z +becomes + qtkvs = [x1 :: *, y :: x1, z :: *] + res_tmpl = T x1 * (Proxy x1 y, z) z + +We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We +know this match will succeed because of the validity check (actually done +later, but laziness saves us -- see Note [Checking GADT return types]). +Thus, we get + + subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } + +Now, we need to figure out what the GADT equalities should be. In this case, +we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a +renaming. The others should be GADT equalities. We also need to make +sure that the universally-quantified variables of the datacon match up +with the tyvars of the tycon, as required for Core context well-formedness. +(This last bit is why we have to rejig at all!) + +`choose` walks down the tycon tyvars, figuring out what to do with each one. +It carries two substitutions: + - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables + mentioned in the datacon signature. + - r_sub's domain is *result* tyvars, names written by the programmer in + the datacon signature. The final rejigged type will use these names, but + the subst is still needed because sometimes the printed name of these variables + is different. (See choose_tv_name, below.) + +Before explaining the details of `choose`, let's just look at its operation +on our example: + + choose [] [] {} {} [k1, k2, a, b] + --> -- first branch of `case` statement + choose + univs: [x1 :: *] + eq_spec: [] + t_sub: {k1 |-> x1} + r_sub: {x1 |-> x1} + t_tvs: [k2, a, b] + --> -- second branch of `case` statement + choose + univs: [k2 :: *, x1 :: *] + eq_spec: [k2 ~ *] + t_sub: {k1 |-> x1, k2 |-> k2} + r_sub: {x1 |-> x1} + t_tvs: [a, b] + --> -- second branch of `case` statement + choose + univs: [a :: k2, k2 :: *, x1 :: *] + eq_spec: [ a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} + r_sub: {x1 |-> x1} + t_tvs: [b] + --> -- second branch of `case` statement + choose + univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] + eq_spec: [ b ~ z + , a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} + r_sub: {x1 |-> x1} + t_tvs: [] + --> -- end of recursion + ( [x1 :: *, k2 :: *, a :: k2, b :: k2] + , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] + , {x1 |-> x1} ) + +`choose` looks up each tycon tyvar in the matching (it *must* be matched!). + +* If it finds a bare result tyvar (the first branch of the `case` + statement), it checks to make sure that the result tyvar isn't yet + in the list of univ_tvs. If it is in that list, then we have a + repeated variable in the return type, and we in fact need a GADT + equality. + +* It then checks to make sure that the kind of the result tyvar + matches the kind of the template tyvar. This check is what forces + `z` to be existential, as it should be, explained above. + +* Assuming no repeated variables or kind-changing, we wish to use the + variable name given in the datacon signature (that is, `x1` not + `k1`), not the tycon signature (which may have been made up by + GHC). So, we add a mapping from the tycon tyvar to the result tyvar + to t_sub. + +* If we discover that a mapping in `subst` gives us a non-tyvar (the + second branch of the `case` statement), then we have a GADT equality + to create. We create a fresh equality, but we don't extend any + substitutions. The template variable substitution is meant for use + in universal tyvar kinds, and these shouldn't be affected by any + GADT equalities. + +This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways +of simplifying it: + +1) The first branch of the `case` statement is really an optimization, used +in order to get fewer GADT equalities. It might be possible to make a GADT +equality for *every* univ. tyvar, even if the equality is trivial, and then +either deal with the bigger type or somehow reduce it later. + +2) This algorithm strives to use the names for type variables as specified +by the user in the datacon signature. If we always used the tycon tyvar +names, for example, this would be simplified. This change would almost +certainly degrade error messages a bit, though. +-} + +-- ^ From information about a source datacon definition, extract out +-- what the universal variables and the GADT equalities should be. +-- See Note [mkGADTVars]. +mkGADTVars :: [TyVar] -- ^ The tycon vars + -> [TyVar] -- ^ The datacon vars + -> TCvSubst -- ^ The matching between the template result type + -- and the actual result type + -> ( [TyVar] + , [EqSpec] + , TCvSubst ) -- ^ The univ. variables, the GADT equalities, + -- and a subst to apply to the GADT equalities + -- and existentials. +mkGADTVars tmpl_tvs dc_tvs subst + = choose [] [] empty_subst empty_subst tmpl_tvs + where + in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) + `unionInScope` getTCvInScope subst + empty_subst = mkEmptyTCvSubst in_scope + + choose :: [TyVar] -- accumulator of univ tvs, reversed + -> [EqSpec] -- accumulator of GADT equalities, reversed + -> TCvSubst -- template substitution + -> TCvSubst -- res. substitution + -> [TyVar] -- template tvs (the univ tvs passed in) + -> ( [TyVar] -- the univ_tvs + , [EqSpec] -- GADT equalities + , TCvSubst ) -- a substitution to fix kinds in ex_tvs + + choose univs eqs _t_sub r_sub [] + = (reverse univs, reverse eqs, r_sub) + choose univs eqs t_sub r_sub (t_tv:t_tvs) + | Just r_ty <- lookupTyVar subst t_tv + = case getTyVar_maybe r_ty of + Just r_tv + | not (r_tv `elem` univs) + , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) + -> -- simple, well-kinded variable substitution. + choose (r_tv:univs) eqs + (extendTvSubst t_sub t_tv r_ty') + (extendTvSubst r_sub r_tv r_ty') + t_tvs + where + r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) + r_ty' = mkTyVarTy r_tv1 + + -- Not a simple substitution: make an equality predicate + _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) + (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) + -- We've updated the kind of t_tv, + -- so add it to t_sub (#14162) + r_sub t_tvs + where + t_tv' = updateTyVarKind (substTy t_sub) t_tv + + | otherwise + = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) + + -- choose an appropriate name for a univ tyvar. + -- This *must* preserve the Unique of the result tv, so that we + -- can detect repeated variables. It prefers user-specified names + -- over system names. A result variable with a system name can + -- happen with GHC-generated implicit kind variables. + choose_tv_name :: TyVar -> TyVar -> Name + choose_tv_name r_tv t_tv + | isSystemName r_tv_name + = setNameUnique t_tv_name (getUnique r_tv_name) + + | otherwise + = r_tv_name + + where + r_tv_name = getName r_tv + t_tv_name = getName t_tv + +{- +Note [Substitution in template variables kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data G (a :: Maybe k) where + MkG :: G Nothing + +With explicit kind variables + +data G k (a :: Maybe k) where + MkG :: G k1 (Nothing k1) + +Note how k1 is distinct from k. So, when we match the template +`G k a` against `G k1 (Nothing k1)`, we get a subst +[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two +mappings, we surely don't want to add (k, k1) to the list of +GADT equalities -- that would be overly complex and would create +more untouchable variables than we need. So, when figuring out +which tyvars are GADT-like and which aren't (the fundamental +job of `choose`), we want to treat `k` as *not* GADT-like. +Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) +instead of (a :: Maybe k). This is the reason for dealing +with a substitution in here. + +However, we do not *always* want to substitute. Consider + +data H (a :: k) where + MkH :: H Int + +With explicit kind variables: + +data H k (a :: k) where + MkH :: H * Int + +Here, we have a kind-indexed GADT. The subst in question is +[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s +kind, because that would give a constructor with the type + +MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a + +The problem here is that a's kind is wrong -- it needs to be k, not *! +So, if the matching for a variable is anything but another bare variable, +we drop the mapping from the substitution before proceeding. This +was not an issue before kind-indexed GADTs because this case could +never happen. + +************************************************************************ +* * + Validity checking +* * +************************************************************************ + +Validity checking is done once the mutually-recursive knot has been +tied, so we can look at things freely. +-} + +checkValidTyCl :: TyCon -> TcM [TyCon] +-- The returned list is either a singleton (if valid) +-- or a list of "fake tycons" (if not); the fake tycons +-- include any implicits, like promoted data constructors +-- See Note [Recover from validity error] +checkValidTyCl tc + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + recoverM recovery_code $ + do { traceTc "Starting validity for tycon" (ppr tc) + ; checkValidTyCon tc + ; traceTc "Done validity for tycon" (ppr tc) + ; return [tc] } + where + recovery_code -- See Note [Recover from validity error] + = do { traceTc "Aborted validity for tycon" (ppr tc) + ; return (concatMap mk_fake_tc $ + ATyCon tc : implicitTyConThings tc) } + + mk_fake_tc (ATyCon tc) + | isClassTyCon tc = [tc] -- Ugh! Note [Recover from validity error] + | otherwise = [makeRecoveryTyCon tc] + mk_fake_tc (AConLike (RealDataCon dc)) + = [makeRecoveryTyCon (promoteDataCon dc)] + mk_fake_tc _ = [] + +{- Note [Recover from validity error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We recover from a validity error in a type or class, which allows us +to report multiple validity errors. In the failure case we return a +TyCon of the right kind, but with no interesting behaviour +(makeRecoveryTyCon). Why? Suppose we have + type T a = Fun +where Fun is a type family of arity 1. The RHS is invalid, but we +want to go on checking validity of subsequent type declarations. +So we replace T with an abstract TyCon which will do no harm. +See indexed-types/should_fail/BadSock and #10896 + +Some notes: + +* We must make fakes for promoted DataCons too. Consider (#15215) + data T a = MkT ... + data S a = ...T...MkT.... + If there is an error in the definition of 'T' we add a "fake type + constructor" to the type environment, so that we can continue to + typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' + and so there was an internal error when we met 'MkT' in the body of + 'S'. + +* Painfully, we *don't* want to do this for classes. + Consider tcfail041: + class (?x::Int) => C a where ... + instance C Int + The class is invalid because of the superclass constraint. But + we still want it to look like a /class/, else the instance bleats + that the instance is mal-formed because it hasn't got a class in + the head. + + This is really bogus; now we have in scope a Class that is invalid + in some way, with unknown downstream consequences. A better + alternative might be to make a fake class TyCon. A job for another day. +-} + +------------------------- +-- For data types declared with record syntax, we require +-- that each constructor that has a field 'f' +-- (a) has the same result type +-- (b) has the same type for 'f' +-- module alpha conversion of the quantified type variables +-- of the constructor. +-- +-- Note that we allow existentials to match because the +-- fields can never meet. E.g +-- data T where +-- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T +-- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T +-- Here we do not complain about f1,f2 because they are existential + +checkValidTyCon :: TyCon -> TcM () +checkValidTyCon tc + | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim + = return () + + | isWiredIn tc -- validity-checking wired-in tycons is a waste of + -- time. More importantly, a wired-in tycon might + -- violate assumptions. Example: (~) has a superclass + -- mentioning (~#), which is ill-kinded in source Haskell + = traceTc "Skipping validity check for wired-in" (ppr tc) + + | otherwise + = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) + ; if | Just cl <- tyConClass_maybe tc + -> checkValidClass cl + + | Just syn_rhs <- synTyConRhs_maybe tc + -> do { checkValidType syn_ctxt syn_rhs + ; checkTySynRhs syn_ctxt syn_rhs } + + | Just fam_flav <- famTyConFlav_maybe tc + -> case fam_flav of + { ClosedSynFamilyTyCon (Just ax) + -> tcAddClosedTypeFamilyDeclCtxt tc $ + checkValidCoAxiom ax + ; ClosedSynFamilyTyCon Nothing -> return () + ; AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBootOrSig + ; checkTc hsBoot $ + text "You may define an abstract closed type family" $$ + text "only in a .hs-boot file" } + ; DataFamilyTyCon {} -> return () + ; OpenSynFamilyTyCon -> return () + ; BuiltInSynFamTyCon _ -> return () } + + | otherwise -> do + { -- Check the context on the data decl + traceTc "cvtc1" (ppr tc) + ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) + + ; traceTc "cvtc2" (ppr tc) + + ; dflags <- getDynFlags + ; existential_ok <- xoptM LangExt.ExistentialQuantification + ; gadt_ok <- xoptM LangExt.GADTs + ; let ex_ok = existential_ok || gadt_ok + -- Data cons can have existential context + ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons + ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) + + -- Check that fields with the same name share a type + ; mapM_ check_fields groups }} + where + syn_ctxt = TySynCtxt name + name = tyConName tc + data_cons = tyConDataCons tc + + groups = equivClasses cmp_fld (concatMap get_fields data_cons) + cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2 + get_fields con = dataConFieldLabels con `zip` repeat con + -- dataConFieldLabels may return the empty list, which is fine + + -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils + -- We must check (a) that the named field has the same + -- type in each constructor + -- (b) that those constructors have the same result type + -- + -- However, the constructors may have differently named type variable + -- and (worse) we don't know how the correspond to each other. E.g. + -- C1 :: forall a b. { f :: a, g :: b } -> T a b + -- C2 :: forall d c. { f :: c, g :: c } -> T c d + -- + -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's + -- result type against other candidates' types BOTH WAYS ROUND. + -- If they magically agrees, take the substitution and + -- apply them to the latter ones, and see if they match perfectly. + check_fields ((label, con1) :| other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = recoverM (return ()) $ mapM_ checkOne other_fields + -- Check that all the fields in the group have the same type + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + where + res1 = dataConOrigResTy con1 + fty1 = dataConFieldType con1 lbl + lbl = flLabel label + + checkOne (_, con2) -- Do it both ways to ensure they are structurally identical + = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 + ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } + where + res2 = dataConOrigResTy con2 + fty2 = dataConFieldType con2 lbl + +checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () +-- Checks the partial record field selector, and warns. +-- See Note [Checking partial record field] +checkPartialRecordField all_cons fld + = setSrcSpan loc $ + warnIfFlag Opt_WarnPartialFields + (not is_exhaustive && not (startsWithUnderscore occ_name)) + (sep [text "Use of partial record field selector" <> colon, + nest 2 $ quotes (ppr occ_name)]) + where + sel_name = flSelector fld + loc = getSrcSpan sel_name + occ_name = getOccName sel_name + + (cons_with_field, cons_without_field) = partition has_field all_cons + has_field con = fld `elem` (dataConFieldLabels con) + is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field + + con1 = ASSERT( not (null cons_with_field) ) head cons_with_field + (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1 + eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) + inst_tys = substTyVars eq_subst univ_tvs + +checkFieldCompat :: FieldLabelString -> DataCon -> DataCon + -> Type -> Type -> Type -> Type -> TcM () +checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 + = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) + ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } + where + mb_subst1 = tcMatchTy res1 res2 + mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 + +------------------------------- +checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () +checkValidDataCon dflags existential_ok tc con + = setSrcSpan (getSrcSpan con) $ + addErrCtxt (dataConCtxt con) $ + do { -- Check that the return type of the data constructor + -- matches the type constructor; eg reject this: + -- data T a where { MkT :: Bogus a } + -- It's important to do this first: + -- see Note [Checking GADT return types] + -- and c.f. Note [Check role annotations in a second pass] + let tc_tvs = tyConTyVars tc + res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) + orig_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) + + + ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty)) + (badDataConTyCon con res_ty_tmpl) + -- Note that checkTc aborts if it finds an error. This is + -- critical to avoid panicking when we call dataConDisplayType + -- on an un-rejiggable datacon! + -- Also NB that we match the *kind* as well as the *type* (#18357) + -- However, if the kind is the only thing that doesn't match, the + -- error message is terrible. E.g. test T18357b + -- type family Star where Star = Type + -- newtype T :: Type where MkT :: Int -> (T :: Star) + + ; traceTc "checkValidDataCon 2" (ppr data_con_display_type) + + -- Check that the result type is a *monotype* + -- e.g. reject this: MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; checkValidMonoType orig_res_ty + + -- If we are dealing with a newtype, we allow levity polymorphism + -- regardless of whether or not UnliftedNewtypes is enabled. A + -- later check in checkNewDataCon handles this, producing a + -- better error message than checkForLevPoly would. + ; unless (isNewTyCon tc) + (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)) + + -- Extra checks for newtype data constructors. Importantly, these + -- checks /must/ come before the call to checkValidType below. This + -- is because checkValidType invokes the constraint solver, and + -- invoking the solver on an ill formed newtype constructor can + -- confuse GHC to the point of panicking. See #17955 for an example. + ; when (isNewTyCon tc) (checkNewDataCon con) + + -- Check all argument types for validity + ; checkValidType ctxt data_con_display_type + + -- Check that existentials are allowed if they are used + ; checkTc (existential_ok || isVanillaDataCon con) + (badExistential con) + + -- Check that UNPACK pragmas and bangs work out + -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" + -- data T = MkT {-# UNPACK #-} !a -- Can't unpack + ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..] + + -- Check the dcUserTyVarBinders invariant + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + -- checked here because we sometimes build invalid DataCons before + -- erroring above here + ; when debugIsOn $ + do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con + user_tvs = dataConUserTyVars con + user_tvbs_invariant + = Set.fromList (filterEqSpec eq_spec univs ++ exs) + == Set.fromList user_tvs + ; MASSERT2( user_tvbs_invariant + , vcat ([ ppr con + , ppr univs + , ppr exs + , ppr eq_spec + , ppr user_tvs ])) } + + ; traceTc "Done validity of data con" $ + vcat [ ppr con + , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con) + , text "Datacon rep type:" <+> ppr (dataConRepType con) + , text "Datacon display type:" <+> ppr data_con_display_type + , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) + , case tyConFamInst_maybe (dataConTyCon con) of + Nothing -> text "not family" + Just (f, _) -> ppr (tyConBinders f) ] + } + where + ctxt = ConArgCtxt (dataConName con) + + check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM () + check_bang (HsSrcBang _ _ SrcLazy) _ n + | not (xopt LangExt.StrictData dflags) + = addErrTc + (bad_bang n (text "Lazy annotation (~) without StrictData")) + check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n + | isSrcUnpacked want_unpack, not is_strict + = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'")) + | isSrcUnpacked want_unpack + , case rep_bang of { HsUnpack {} -> False; _ -> True } + -- If not optimising, we don't unpack (rep_bang is never + -- HsUnpack), so don't complain! This happens, e.g., in Haddock. + -- See dataConSrcToImplBang. + , not (gopt Opt_OmitInterfacePragmas dflags) + -- When typechecking an indefinite package in Backpack, we + -- may attempt to UNPACK an abstract type. The test here will + -- conclude that this is unusable, but it might become usable + -- when we actually fill in the abstract type. As such, don't + -- warn in this case (it gives users the wrong idea about whether + -- or not UNPACK on abstract types is supported; it is!) + , homeUnitIsDefinite dflags + = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) + where + is_strict = case strict_mark of + NoSrcStrict -> xopt LangExt.StrictData dflags + bang -> isSrcStrict bang + + check_bang _ _ _ + = return () + + bad_bang n herald + = hang herald 2 (text "on the" <+> speakNth n + <+> text "argument of" <+> quotes (ppr con)) + + data_con_display_type = dataConDisplayType dflags con + +------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Further checks for the data constructor of a newtype +checkNewDataCon con + = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) + -- One argument + + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let allowedArgType = + unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True + ; checkTc allowedArgType $ vcat + [ text "A newtype cannot have an unlifted argument type" + , text "Perhaps you intended to use UnliftedNewtypes" + ] + ; dflags <- getDynFlags + + ; let check_con what msg = + checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)) + + ; checkTc (ok_mult (scaledMult arg_ty1)) $ + text "A newtype constructor must be linear" + + ; check_con (null eq_spec) $ + text "A newtype constructor must have a return type of form T a1 ... an" + -- Return type is (T a b c) + + ; check_con (null theta) $ + text "A newtype constructor cannot have a context in its type" + + ; check_con (null ex_tvs) $ + text "A newtype constructor cannot have existential type variables" + -- No existentials + + ; checkTc (all ok_bang (dataConSrcBangs con)) + (newtypeStrictError con) + -- No strictness annotations + } + where + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig con + + (arg_ty1 : _) = arg_tys + + ok_bang (HsSrcBang _ _ SrcStrict) = False + ok_bang (HsSrcBang _ _ SrcLazy) = False + ok_bang _ = True + + ok_mult One = True + ok_mult _ = False + +------------------------------- +checkValidClass :: Class -> TcM () +checkValidClass cls + = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods + ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses + ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses + ; fundep_classes <- xoptM LangExt.FunctionalDependencies + ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses + + -- Check that the class is unary, unless multiparameter type classes + -- are enabled; also recognize deprecated nullary type classes + -- extension (subsumed by multiparameter type classes, #8993) + ; checkTc (multi_param_type_classes || cls_arity == 1 || + (nullary_type_classes && cls_arity == 0)) + (classArityErr cls_arity cls) + ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) + + -- Check the super-classes + ; checkValidTheta (ClassSCCtxt (className cls)) theta + + -- Now check for cyclic superclasses + -- If there are superclass cycles, checkClassCycleErrs bails. + ; unless undecidable_super_classes $ + case checkClassCycles cls of + Just err -> setSrcSpan (getSrcSpan cls) $ + addErrTc err + Nothing -> return () + + -- Check the class operations. + -- But only if there have been no earlier errors + -- See Note [Abort when superclass cycle is detected] + ; whenNoErrs $ + mapM_ (check_op constrained_class_methods) op_stuff + + -- Check the associated type defaults are well-formed and instantiated + ; mapM_ check_at at_stuff } + where + (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls + cls_arity = length (tyConVisibleTyVars (classTyCon cls)) + -- Ignore invisible variables + cls_tv_set = mkVarSet tyvars + + check_op constrained_class_methods (sel_id, dm) + = setSrcSpan (getSrcSpan sel_id) $ + addErrCtxt (classOpCtxt sel_id op_ty) $ do + { traceTc "class op type" (ppr op_ty) + ; checkValidType ctxt op_ty + -- This implements the ambiguity check, among other things + -- Example: tc223 + -- class Error e => Game b mv e | b -> mv e where + -- newBoard :: MonadState b m => m () + -- Here, MonadState has a fundep m->b, so newBoard is fine + + -- a method cannot be levity polymorphic, as we have to store the + -- method in a dictionary + -- example of what this prevents: + -- class BoundedX (a :: TYPE r) where minBound :: a + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + ; checkForLevPoly empty tau1 + + ; unless constrained_class_methods $ + mapM_ check_constraint (tail (cls_pred:op_theta)) + + ; check_dm ctxt sel_id cls_pred tau2 dm + } + where + ctxt = FunSigCtxt op_name True -- Report redundant class constraints + op_name = idName sel_id + op_ty = idType sel_id + (_,cls_pred,tau1) = tcSplitMethodTy op_ty + -- See Note [Splitting nested sigma types in class type signatures] + (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 + + check_constraint :: TcPredType -> TcM () + check_constraint pred -- See Note [Class method constraints] + = when (not (isEmptyVarSet pred_tvs) && + pred_tvs `subVarSet` cls_tv_set) + (addErrTc (badMethPred sel_id pred)) + where + pred_tvs = tyCoVarsOfType pred + + check_at (ATI fam_tc m_dflt_rhs) + = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) + (noClassTyVarErr cls fam_tc) + -- Check that the associated type mentions at least + -- one of the class type variables + -- The check is disabled for nullary type classes, + -- since there is no possible ambiguity (#10020) + + -- Check that any default declarations for associated types are valid + ; whenIsJust m_dflt_rhs $ \ (rhs, at_validity_info) -> + case at_validity_info of + NoATVI -> pure () + ATVI loc pats -> + setSrcSpan loc $ + tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ + do { checkValidAssocTyFamDeflt fam_tc pats + ; checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }} + where + fam_tvs = tyConTyVars fam_tc + + check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () + -- Check validity of the /top-level/ generic-default type + -- E.g for class C a where + -- default op :: forall b. (a~b) => blah + -- we do not want to do an ambiguity check on a type with + -- a free TyVar 'a' (#11608). See TcType + -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType + -- Hence the mkDefaultMethodType to close the type. + check_dm ctxt sel_id vanilla_cls_pred vanilla_tau + (Just (dm_name, dm_spec@(GenericDM dm_ty))) + = setSrcSpan (getSrcSpan dm_name) $ do + -- We have carefully set the SrcSpan on the generic + -- default-method Name to be that of the generic + -- default type signature + + -- First, we check that the method's default type signature + -- aligns with the non-default type signature. + -- See Note [Default method type signatures must align] + let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls + -- Note that the second field of this tuple contains the context + -- of the default type signature, making it apparent that we + -- ignore method contexts completely when validity-checking + -- default type signatures. See the end of + -- Note [Default method type signatures must align] + -- to learn why this is OK. + -- + -- See also + -- Note [Splitting nested sigma types in class type signatures] + -- for an explanation of why we don't use tcSplitSigmaTy here. + (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty + + -- Given this class definition: + -- + -- class C a b where + -- op :: forall p q. (Ord a, D p q) + -- => a -> b -> p -> (a, b) + -- default op :: forall r s. E r + -- => a -> b -> s -> (a, b) + -- + -- We want to match up two types of the form: + -- + -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) + -- Default type sig: C a b => a -> b -> s -> (a, b) + -- + -- Notice that the two type signatures can be quantified over + -- different class type variables! Therefore, it's important that + -- we include the class predicate parts to match up a with aa and + -- b with bb. + vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau + dm_phi_ty = mkPhiTy [cls_pred] dm_tau + + traceTc "check_dm" $ vcat + [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty + , text "dm_phi_ty" <+> ppr dm_phi_ty ] + + -- Actually checking that the types align is done with a call to + -- tcMatchTys. We need to get a match in both directions to rule + -- out degenerate cases like these: + -- + -- class Foo a where + -- foo1 :: a -> b + -- default foo1 :: a -> Int + -- + -- foo2 :: a -> Int + -- default foo2 :: a -> b + unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] + [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ + hang (text "The default type signature for" + <+> ppr sel_id <> colon) + 2 (ppr dm_ty) + $$ (text "does not match its corresponding" + <+> text "non-default type signature") + + -- Now do an ambiguity check on the default type signature. + checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) + check_dm _ _ _ _ _ = return () + +checkFamFlag :: Name -> TcM () +-- Check that we don't use families without -XTypeFamilies +-- The parser won't even parse them, but I suppose a GHC API +-- client might have a go! +checkFamFlag tc_name + = do { idx_tys <- xoptM LangExt.TypeFamilies + ; checkTc idx_tys err_msg } + where + err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) + 2 (text "Enable TypeFamilies to allow indexed type families") + +checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () +checkResultSigFlag tc_name (TyVarSig _ tvb) + = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies + ; checkTc ty_fam_deps $ + hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) + 2 (text "Enable TypeFamilyDependencies to allow result variable names") } +checkResultSigFlag _ _ = return () -- other cases OK + +{- Note [Class method constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Haskell 2010 is supposed to reject + class C a where + op :: Eq a => a -> a +where the method type constrains only the class variable(s). (The extension +-XConstrainedClassMethods switches off this check.) But regardless +we should not reject + class C a where + op :: (?x::Int) => a -> a +as pointed out in #11793. So the test here rejects the program if + * -XConstrainedClassMethods is off + * the tyvars of the constraint are non-empty + * all the tyvars are class tyvars, none are locally quantified + +Note [Abort when superclass cycle is detected] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must avoid doing the ambiguity check for the methods (in +checkValidClass.check_op) when there are already errors accumulated. +This is because one of the errors may be a superclass cycle, and +superclass cycles cause canonicalization to loop. Here is a +representative example: + + class D a => C a where + meth :: D a => () + class C a => D a + +This fixes #9415, #9739 + +Note [Default method type signatures must align] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC enforces the invariant that a class method's default type signature +must "align" with that of the method's non-default type signature, as per +GHC #12918. For instance, if you have: + + class Foo a where + bar :: forall b. Context => a -> b + +Then a default type signature for bar must be alpha equivalent to +(forall b. a -> b). That is, the types must be the same modulo differences in +contexts. So the following would be acceptable default type signatures: + + default bar :: forall b. Context1 => a -> b + default bar :: forall x. Context2 => a -> x + +But the following are NOT acceptable default type signatures: + + default bar :: forall b. b -> a + default bar :: forall x. x + default bar :: a -> Int + +Note that a is bound by the class declaration for Foo itself, so it is +not allowed to differ in the default type signature. + +The default type signature (default bar :: a -> Int) deserves special mention, +since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To +write this, you need to declare the default type signature like so: + + default bar :: forall b. (b ~ Int). a -> b + +As noted in #12918, there are several reasons to do this: + +1. It would make no sense to have a type that was flat-out incompatible with + the non-default type signature. For instance, if you had: + + class Foo a where + bar :: a -> Int + default bar :: a -> Bool + + Then that would always fail in an instance declaration. So this check + nips such cases in the bud before they have the chance to produce + confusing error messages. + +2. Internally, GHC uses TypeApplications to instantiate the default method in + an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance. + Thus, GHC needs to know exactly what the universally quantified type + variables are, and when instantiated that way, the default method's type + must match the expected type. + +3. Aesthetically, by only allowing the default type signature to differ in its + context, we are making it more explicit the ways in which the default type + signature is less polymorphic than the non-default type signature. + +You might be wondering: why are the contexts allowed to be different, but not +the rest of the type signature? That's because default implementations often +rely on assumptions that the more general, non-default type signatures do not. +For instance, in the Enum class declaration: + + class Enum a where + enum :: [a] + default enum :: (Generic a, GEnum (Rep a)) => [a] + enum = map to genum + + class GEnum f where + genum :: [f a] + +The default implementation for enum only works for types that are instances of +Generic, and for which their generic Rep type is an instance of GEnum. But +clearly enum doesn't _have_ to use this implementation, so naturally, the +context for enum is allowed to be different to accommodate this. As a result, +when we validity-check default type signatures, we ignore contexts completely. + +Note that when checking whether two type signatures match, we must take care to +split as many foralls as it takes to retrieve the tau types we which to check. +See Note [Splitting nested sigma types in class type signatures]. + +Note [Splitting nested sigma types in class type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this type synonym and class definition: + + type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + + class Each s t a b where + each :: Traversal s t a b + default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b + +It might seem obvious that the tau types in both type signatures for `each` +are the same, but actually getting GHC to conclude this is surprisingly tricky. +That is because in general, the form of a class method's non-default type +signature is: + + forall a. C a => forall d. D d => E a b + +And the general form of a default type signature is: + + forall f. F f => E a f -- The variable `a` comes from the class + +So it you want to get the tau types in each type signature, you might find it +reasonable to call tcSplitSigmaTy twice on the non-default type signature, and +call it once on the default type signature. For most classes and methods, this +will work, but Each is a bit of an exceptional case. The way `each` is written, +it doesn't quantify any additional type variables besides those of the Each +class itself, so the non-default type signature for `each` is actually this: + + forall s t a b. Each s t a b => Traversal s t a b + +Notice that there _appears_ to only be one forall. But there's actually another +forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy +twice, you'll also go under the forall in Traversal! That is, you'll end up +with: + + (a -> f b) -> s -> f t + +A problem arises because you only call tcSplitSigmaTy once on the default type +signature for `each`, which gives you + + Traversal s t a b + +Or, equivalently: + + forall f. Applicative f => (a -> f b) -> s -> f t + +This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will +say that the tau types for `each` are not equal. + +A solution to this problem is to use tcSplitNestedSigmaTys instead of +tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it +sees until it can't go any further, so if you called it on the default type +signature for `each`, it would return (a -> f b) -> s -> f t like we desired. + +Note [Checking partial record field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This check checks the partial record field selector, and warns (#7169). + +For example: + + data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } + +The function 'm2' is partial record field, and will fail when it is applied to +'B'. The warning identifies such partial fields. The check is performed at the +declaration of T, not at the call-sites of m2. + +The warning can be suppressed by prefixing the field-name with an underscore. +For example: + + data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } + +************************************************************************ +* * + Checking role validity +* * +************************************************************************ +-} + +checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () +checkValidRoleAnnots role_annots tc + | isTypeSynonymTyCon tc = check_no_roles + | isFamilyTyCon tc = check_no_roles + | isAlgTyCon tc = check_roles + | otherwise = return () + where + -- Role annotations are given only on *explicit* variables, + -- but a tycon stores roles for all variables. + -- So, we drop the implicit roles (which are all Nominal, anyway). + name = tyConName tc + roles = tyConRoles tc + (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ + zip roles (tyConBinders tc) + role_annot_decl_maybe = lookupRoleAnnot role_annots name + + pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) + pick_vis (role, tvb) + | isVisibleTyConBinder tvb = Just (role, binderVar tvb) + | otherwise = Nothing + + check_roles + = whenIsJust role_annot_decl_maybe $ + \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> + addRoleAnnotCtxt name $ + setSrcSpan loc $ do + { role_annots_ok <- xoptM LangExt.RoleAnnotations + ; checkTc role_annots_ok $ needXRoleAnnotations tc + ; checkTc (vis_vars `equalLength` the_role_annots) + (wrongNumberOfRoles vis_vars decl) + ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles + -- Representational or phantom roles for class parameters + -- quickly lead to incoherence. So, we require + -- IncoherentInstances to have them. See #8773, #14292 + ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances + ; checkTc ( incoherent_roles_ok + || (not $ isClassTyCon tc) + || (all (== Nominal) vis_roles)) + incoherentRoles + + ; lint <- goptM Opt_DoCoreLinting + ; when lint $ checkValidRoles tc } + + check_no_roles + = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl + +checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 + = when (r1 /= r2) $ + addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 + +-- This is a double-check on the role inference algorithm. It is only run when +-- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils +checkValidRoles :: TyCon -> TcM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +checkValidRoles tc + | isAlgTyCon tc + -- tyConDataCons returns an empty list for data families + = mapM_ check_dc_roles (tyConDataCons tc) + | Just rhs <- synTyConRhs_maybe tc + = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs + | otherwise + = return () + where + check_dc_roles datacon + = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) + ; mapM_ (check_ty_roles role_env Representational) $ + eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) } + -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon + univ_roles = zipVarEnv univ_tvs (tyConRoles tc) + -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs + ex_roles = mkVarEnv (map (, Nominal) ex_tvs) + role_env = univ_roles `plusVarEnv` ex_roles + + check_ty_roles env role ty + | Just ty' <- coreView ty -- #14101 + = check_ty_roles env role ty' + + check_ty_roles env role (TyVarTy tv) + = case lookupVarEnv env tv of + Just role' -> unless (role' `ltRole` role || role' == role) $ + report_error $ text "type variable" <+> quotes (ppr tv) <+> + text "cannot have role" <+> ppr role <+> + text "because it was assigned role" <+> ppr role' + Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> + text "missing in environment" + + check_ty_roles env Representational (TyConApp tc tys) + = let roles' = tyConRoles tc in + zipWithM_ (maybe_check_ty_roles env) roles' tys + + check_ty_roles env Nominal (TyConApp _ tys) + = mapM_ (check_ty_roles env Nominal) tys + + check_ty_roles _ Phantom ty@(TyConApp {}) + = pprPanic "check_ty_roles" (ppr ty) + + check_ty_roles env role (AppTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env Nominal ty2 + + check_ty_roles env role (FunTy _ w ty1 ty2) + = check_ty_roles env Nominal w + >> check_ty_roles env role ty1 + >> check_ty_roles env role ty2 + + check_ty_roles env role (ForAllTy (Bndr tv _) ty) + = check_ty_roles env Nominal (tyVarKind tv) + >> check_ty_roles (extendVarEnv env tv Nominal) role ty + + check_ty_roles _ _ (LitTy {}) = return () + + check_ty_roles env role (CastTy t _) + = check_ty_roles env role t + + check_ty_roles _ role (CoercionTy co) + = unless (role == Phantom) $ + report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role + + maybe_check_ty_roles env role ty + = when (role == Nominal || role == Representational) $ + check_ty_roles env role ty + + report_error doc + = addErrTc $ vcat [text "Internal error in role inference:", + doc, + text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] + +{- +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc +tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, + text "declaration for", quotes (ppr (tcdName decl))] + +addVDQNote :: TcTyCon -> TcM a -> TcM a +-- See Note [Inferring visible dependent quantification] +-- Only types without a signature (CUSK or SAK) here +addVDQNote tycon thing_inside + | ASSERT2( isTcTyCon tycon, ppr tycon ) + ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind ) + has_vdq + = addLandmarkErrCtxt vdq_warning thing_inside + | otherwise + = thing_inside + where + -- Check whether a tycon has visible dependent quantification. + -- This will *always* be a TcTyCon. Furthermore, it will *always* + -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. + -- Thus, all the TyConBinders will be anonymous. Thus, the + -- free variables of the tycon's kind will be the same as the free + -- variables from all the binders. + has_vdq = any is_vdq_tcb (tyConBinders tycon) + tc_kind = tyConKind tycon + kind_fvs = tyCoVarsOfType tc_kind + + is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && + isVisibleTyConBinder tcb + + vdq_warning = vcat + [ text "NB: Type" <+> quotes (ppr tycon) <+> + text "was inferred to use visible dependent quantification." + , text "Most types with visible dependent quantification are" + , text "polymorphically recursive and need a standalone kind" + , text "signature. Perhaps supply one, with StandaloneKindSignatures." + ] + +tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a +tcAddDeclCtxt decl thing_inside + = addErrCtxt (tcMkDeclCtxt decl) thing_inside + +tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a +tcAddTyFamInstCtxt decl + = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) + +tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc +tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = + HsIB { hsib_body = eqn }}) + = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") + (unLoc (feqn_tycon eqn)) + +tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a +tcAddDataFamInstCtxt decl + = addErrCtxt (tcMkDataFamInstCtxt decl) + +tcMkFamInstCtxt :: SDoc -> Name -> SDoc +tcMkFamInstCtxt flavour tycon + = hsep [ text "In the" <+> flavour <+> text "declaration for" + , quotes (ppr tycon) ] + +tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a +tcAddFamInstCtxt flavour tycon thing_inside + = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside + +tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a +tcAddClosedTypeFamilyDeclCtxt tc + = addErrCtxt ctxt + where + ctxt = text "In the equations for closed type family" <+> + quotes (ppr tc) + +resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc +resultTypeMisMatch field_name con1 con2 + = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "have a common field" <+> quotes (ppr field_name) <> comma], + nest 2 $ text "but have different result types"] + +fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc +fieldTypeMisMatch field_name con1 con2 + = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "give different types for field", quotes (ppr field_name)] + +dataConCtxtName :: [Located Name] -> SDoc +dataConCtxtName [con] + = text "In the definition of data constructor" <+> quotes (ppr con) +dataConCtxtName con + = text "In the definition of data constructors" <+> interpp'SP con + +dataConCtxt :: Outputable a => a -> SDoc +dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) + +classOpCtxt :: Var -> Type -> SDoc +classOpCtxt sel_id tau = sep [text "When checking the class method:", + nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] + +classArityErr :: Int -> Class -> SDoc +classArityErr n cls + | n == 0 = mkErr "No" "no-parameter" + | otherwise = mkErr "Too many" "multi-parameter" + where + mkErr howMany allowWhat = + vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), + parens (text ("Enable MultiParamTypeClasses to allow " + ++ allowWhat ++ " classes"))] + +classFunDepsErr :: Class -> SDoc +classFunDepsErr cls + = vcat [text "Fundeps in class" <+> quotes (ppr cls), + parens (text "Enable FunctionalDependencies to allow fundeps")] + +badMethPred :: Id -> TcPredType -> SDoc +badMethPred sel_id pred + = vcat [ hang (text "Constraint" <+> quotes (ppr pred) + <+> text "in the type of" <+> quotes (ppr sel_id)) + 2 (text "constrains only the class type variables") + , text "Enable ConstrainedClassMethods to allow it" ] + +noClassTyVarErr :: Class -> TyCon -> SDoc +noClassTyVarErr clas fam_tc + = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) + , text "mentions none of the type or kind variables of the class" <+> + quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] + +badDataConTyCon :: DataCon -> Type -> SDoc +badDataConTyCon data_con res_ty_tmpl + = hang (text "Data constructor" <+> quotes (ppr data_con) <+> + text "returns type" <+> quotes (ppr actual_res_ty)) + 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) + where + actual_res_ty = dataConOrigResTy data_con + +badGadtDecl :: Name -> SDoc +badGadtDecl tc_name + = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) + , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] + +badExistential :: DataCon -> SDoc +badExistential con + = sdocWithDynFlags (\dflags -> + hang (text "Data constructor" <+> quotes (ppr con) <+> + text "has existential type variables, a context, or a specialised result type") + 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con) + , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) + +badStupidTheta :: Name -> SDoc +badStupidTheta tc_name + = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) + +newtypeConError :: Name -> Int -> SDoc +newtypeConError tycon n + = sep [text "A newtype must have exactly one constructor,", + nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] + +newtypeStrictError :: DataCon -> SDoc +newtypeStrictError con + = sep [text "A newtype constructor cannot have a strictness annotation,", + nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] + +newtypeFieldErr :: DataCon -> Int -> SDoc +newtypeFieldErr con_name n_flds + = sep [text "The constructor of a newtype must have exactly one field", + nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] + +badSigTyDecl :: Name -> SDoc +badSigTyDecl tc_name + = vcat [ text "Illegal kind signature" <+> + quotes (ppr tc_name) + , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] + +emptyConDeclsErr :: Name -> SDoc +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> text "has no constructors", + nest 2 $ text "(EmptyDataDecls permits this)"] + +wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily family + = text "Wrong category of family instance; declaration was for a" + <+> kindOfFamily + where + kindOfFamily | isTypeFamilyTyCon family = text "type family" + | isDataFamilyTyCon family = text "data family" + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) + +-- | Produce an error for oversaturated type family equations with too many +-- required arguments. +-- See Note [Oversaturated type family equations] in "GHC.Tc.Validity". +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr max_args + = text "Number of parameters must match family declaration; expected" + <+> ppr max_args + +badRoleAnnot :: Name -> Role -> Role -> SDoc +badRoleAnnot var annot inferred + = hang (text "Role mismatch on variable" <+> ppr var <> colon) + 2 (sep [ text "Annotation says", ppr annot + , text "but role", ppr inferred + , text "is required" ]) + +wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc +wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) + = hang (text "Wrong number of roles listed in role annotation;" $$ + text "Expected" <+> (ppr $ length tyvars) <> comma <+> + text "got" <+> (ppr $ length annots) <> colon) + 2 (ppr d) + + +illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () +illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) + = setErrCtxt [] $ + setSrcSpan loc $ + addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") + +needXRoleAnnotations :: TyCon -> SDoc +needXRoleAnnotations tc + = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ + text "did you intend to use RoleAnnotations?" + +incoherentRoles :: SDoc +incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> + text "for class parameters can lead to incoherence.") $$ + (text "Use IncoherentInstances to allow this; bad role found") + +wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName fam_tc_name eqn_tc_name + = hang (text "Mismatched type name in type family instance.") + 2 (vcat [ text "Expected:" <+> ppr fam_tc_name + , text " Actual:" <+> ppr eqn_tc_name ]) + +addTyConCtxt :: TyCon -> TcM a -> TcM a +addTyConCtxt tc = addTyConFlavCtxt name flav + where + name = getName tc + flav = tyConFlavour tc + +addRoleAnnotCtxt :: Name -> TcM a -> TcM a +addRoleAnnotCtxt name + = addErrCtxt $ + text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/GHC/Tc/TyCl/Build.hs b/GHC/Tc/TyCl/Build.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Build.hs @@ -0,0 +1,418 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.TyCl.Build ( + buildDataCon, + buildPatSyn, + TcMethInfo, MethInfo, buildClass, + mkNewTyConRhs, + newImplicitBinder, newTyConRepName + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Iface.Env +import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) +import GHC.Builtin.Types( isCTupleTyConName ) +import GHC.Builtin.Types.Prim ( voidPrimTy ) +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Types.Id +import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity + +import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) +import GHC.Driver.Session +import GHC.Tc.Utils.Monad +import GHC.Types.Unique.Supply +import GHC.Utils.Misc +import GHC.Utils.Outputable + + +mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs +-- ^ Monadic because it makes a Name for the coercion TyCon +-- We pass the Name of the parent TyCon, as well as the TyCon itself, +-- because the latter is part of a knot, whereas the former is not. +mkNewTyConRhs tycon_name tycon con + = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc + ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs + ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) + ; return (NewTyCon { data_con = con, + nt_rhs = rhs_ty, + nt_etad_rhs = (etad_tvs, etad_rhs), + nt_co = nt_ax, + nt_lev_poly = isKindLevPoly res_kind } ) } + -- Coreview looks through newtypes with a Nothing + -- for nt_co, or uses explicit coercions otherwise + where + tvs = tyConTyVars tycon + roles = tyConRoles tycon + res_kind = tyConResKind tycon + con_arg_ty = case dataConRepArgTys con of + [arg_ty] -> scaledThing arg_ty + tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) + rhs_ty = substTyWith (dataConUnivTyVars con) + (mkTyVarTys tvs) con_arg_ty + -- Instantiate the newtype's RHS with the + -- type variables from the tycon + -- NB: a newtype DataCon has a type that must look like + -- forall tvs. -> T tvs + -- Note that we *can't* use dataConInstOrigArgTys here because + -- the newtype arising from class Foo a => Bar a where {} + -- has a single argument (Foo a) that is a *type class*, so + -- dataConInstOrigArgTys returns []. + + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can + etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty + etad_rhs :: Type -- See Note [Tricky iface loop] in GHC.Iface.Load + (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty + + eta_reduce :: [TyVar] -- Reversed + -> [Role] -- also reversed + -> Type -- Rhs type + -> ([TyVar], [Role], Type) -- Eta-reduced version + -- (tyvars in normal order) + eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, + Just tv <- getTyVar_maybe arg, + tv == a, + not (a `elemVarSet` tyCoVarsOfType fun) + = eta_reduce as rs fun + eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) + +------------------------------------------------------ +buildDataCon :: FamInstEnvs + -> Name + -> Bool -- Declared infix + -> TyConRepName + -> [HsSrcBang] + -> Maybe [HsImplBang] + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + -> [FieldLabel] -- Field labels + -> [TyVar] -- Universals + -> [TyCoVar] -- Existentials + -> [InvisTVBinder] -- User-written 'TyVarBinder's + -> [EqSpec] -- Equality spec + -> KnotTied ThetaType -- Does not include the "stupid theta" + -- or the GADT equalities + -> [KnotTied (Scaled Type)] -- Arguments + -> KnotTied Type -- Result types + -> KnotTied TyCon -- Rep tycon + -> NameEnv ConTag -- Maps the Name of each DataCon to its + -- ConTag + -> TcRnIf m n DataCon +-- A wrapper for DataCon.mkDataCon that +-- a) makes the worker Id +-- b) makes the wrapper Id if necessary, including +-- allocating its unique (hence monadic) +buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs + field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty + rep_tycon tag_map + = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc + ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc + -- This last one takes the name of the data constructor in the source + -- code, which (for Haskell source anyway) will be in the DataName name + -- space, and puts it into the VarName name space + + ; traceIf (text "buildDataCon 1" <+> ppr src_name) + ; us <- newUniqueSupply + ; dflags <- getDynFlags + ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs + tag = lookupNameEnv_NF tag_map src_name + -- See Note [Constructor tag allocation], fixes #14657 + data_con = mkDataCon src_name declared_infix prom_info + src_bangs field_lbls + univ_tvs ex_tvs user_tvbs eq_spec ctxt + arg_tys res_ty NoRRI rep_tycon tag + stupid_ctxt dc_wrk dc_rep + dc_wrk = mkDataConWorkId work_name data_con + dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name + impl_bangs data_con) + + ; traceIf (text "buildDataCon 2" <+> ppr src_name) + ; return data_con } + + +-- The stupid context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +-- ToDo: Or functionally dependent on? +-- This whole stupid theta thing is, well, stupid. +mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] +mkDataConStupidTheta tycon arg_tys univ_tvs + | null stupid_theta = [] -- The common case + | otherwise = filter in_arg_tys stupid_theta + where + tc_subst = zipTvSubst (tyConTyVars tycon) + (mkTyVarTys univ_tvs) + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + -- Start by instantiating the master copy of the + -- stupid theta, taken from the TyCon + + arg_tyvars = tyCoVarsOfTypes arg_tys + in_arg_tys pred = tyCoVarsOfType pred `intersectsVarSet` arg_tyvars + + +------------------------------------------------------ +buildPatSyn :: Name -> Bool + -> (Id,Bool) -> Maybe (Id, Bool) + -> ([InvisTVBinder], ThetaType) -- ^ Univ and req + -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov + -> [Type] -- ^ Argument types + -> Type -- ^ Result type + -> [FieldLabel] -- ^ Field labels for + -- a record pattern synonym + -> PatSyn +buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys + pat_ty field_labels + = -- The assertion checks that the matcher is + -- compatible with the pattern synonym + ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 + , ex_tvs `equalLength` ex_tvs1 + , pat_ty `eqType` substTy subst (scaledThing pat_ty1) + , prov_theta `eqTypes` substTys subst prov_theta1 + , req_theta `eqTypes` substTys subst req_theta1 + , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1)) + ]) + , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 + , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 + , ppr pat_ty <+> twiddle <+> ppr pat_ty1 + , ppr prov_theta <+> twiddle <+> ppr prov_theta1 + , ppr req_theta <+> twiddle <+> ppr req_theta1 + , ppr arg_tys <+> twiddle <+> ppr arg_tys1])) + mkPatSyn src_name declared_infix + (univ_tvs, req_theta) (ex_tvs, prov_theta) + arg_tys pat_ty + matcher builder field_labels + where + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id + ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy (scaledThing cont_sigma) + (arg_tys1, _) = (tcSplitFunTys cont_tau) + twiddle = char '~' + subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) + (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) + + -- For a nullary pattern synonym we add a single void argument to the + -- matcher to preserve laziness in the case of unlifted types. + -- See #12746 + compareArgTys :: [Type] -> [Type] -> Bool + compareArgTys [] [x] = x `eqType` voidPrimTy + compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys + + +------------------------------------------------------ +type TcMethInfo = MethInfo -- this variant needs zonking +type MethInfo -- A temporary intermediate, to communicate + -- between tcClassSigs and buildClass. + = ( Name -- Name of the class op + , Type -- Type of the class op + , Maybe (DefMethSpec (SrcSpan, Type))) + -- Nothing => no default method + -- + -- Just VanillaDM => There is an ordinary + -- polymorphic default method + -- + -- Just (GenericDM (loc, ty)) => There is a generic default metho + -- Here is its type, and the location + -- of the type signature + -- We need that location /only/ to attach it to the + -- generic default method's Name; and we need /that/ + -- only to give the right location of an ambiguity error + -- for the generic default method, spat out by checkValidClass + +buildClass :: Name -- Name of the class/tycon (they have the same Name) + -> [TyConBinder] -- Of the tycon + -> [Role] + -> [FunDep TyVar] -- Functional dependencies + -- Super classes, associated types, method info, minimal complete def. + -- This is Nothing if the class is abstract. + -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef) + -> TcRnIf m n Class + +buildClass tycon_name binders roles fds Nothing + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; tc_rep_name <- newTyConRepName tycon_name + ; let univ_tvs = binderVars binders + tycon = mkClassTyCon tycon_name binders roles + AbstractTyCon rec_clas tc_rep_name + result = mkAbstractClass tycon_name univ_tvs fds tycon + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + +buildClass tycon_name binders roles fds + (Just (sc_theta, at_items, sig_stuff, mindef)) + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc + ; tc_rep_name <- newTyConRepName tycon_name + + ; op_items <- mapM (mk_op_item rec_clas) sig_stuff + -- Build the selector id and default method id + + -- Make selectors for the superclasses + ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) + (takeList sc_theta [fIRST_TAG..]) + ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas + | sc_name <- sc_sel_names] + -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we + -- can construct names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + + ; let use_newtype = isSingleton arg_tys + -- Use a newtype if the data constructor + -- (a) has exactly one value field + -- i.e. exactly one operation or superclass taken together + -- (b) that value is of lifted type (which they always are, because + -- we box equality superclasses) + -- See note [Class newtypes and equality predicates] + + -- We treat the dictionary superclasses as ordinary arguments. + -- That means that in the case of + -- class C a => D a + -- we don't get a newtype with no arguments! + args = sc_sel_names ++ op_names + op_tys = [ty | (_,ty,_) <- sig_stuff] + op_names = [op | (op,_,_) <- sig_stuff] + arg_tys = sc_theta ++ op_tys + rec_tycon = classTyCon rec_clas + univ_bndrs = tyConInvisTVBinders binders + univ_tvs = binderVars univ_bndrs + + ; rep_nm <- newTyConRepName datacon_name + ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") + datacon_name + False -- Not declared infix + rep_nm + (map (const no_bang) args) + (Just (map (const HsLazy) args)) + [{- No fields -}] + univ_tvs + [{- no existentials -}] + univ_bndrs + [{- No GADT equalities -}] + [{- No theta -}] + (map unrestricted arg_tys) -- type classes are unrestricted + (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) + rec_tycon + (mkTyConTagMap rec_tycon) + + ; rhs <- case () of + _ | use_newtype + -> mkNewTyConRhs tycon_name rec_tycon dict_con + | isCTupleTyConName tycon_name + -> return (TupleTyCon { data_con = dict_con + , tup_sort = ConstraintTuple }) + | otherwise + -> return (mkDataTyConRhs [dict_con]) + + ; let { tycon = mkClassTyCon tycon_name binders roles + rhs rec_clas tc_rep_name + -- A class can be recursive, and in the case of newtypes + -- this matters. For example + -- class C a where { op :: C b => a -> b -> Int } + -- Because C has only one operation, it is represented by + -- a newtype, and it should be a *recursive* newtype. + -- [If we don't make it a recursive newtype, we'll expand the + -- newtype like a synonym, but that will lead to an infinite + -- type] + + ; result = mkClass tycon_name univ_tvs fds + sc_theta sc_sel_ids at_items + op_items mindef tycon + } + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + where + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem + mk_op_item rec_clas (op_name, _, dm_spec) + = do { dm_info <- mk_dm_info op_name dm_spec + ; return (mkDictSelId op_name rec_clas, dm_info) } + + mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type)) + -> TcRnIf n m (Maybe (Name, DefMethSpec Type)) + mk_dm_info _ Nothing + = return Nothing + mk_dm_info op_name (Just VanillaDM) + = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc + ; return (Just (dm_name, VanillaDM)) } + mk_dm_info op_name (Just (GenericDM (loc, dm_ty))) + = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc + ; return (Just (dm_name, GenericDM dm_ty)) } + +{- +Note [Class newtypes and equality predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class (a ~ F b) => C a b where + op :: a -> b + +We cannot represent this by a newtype, even though it's not +existential, because there are two value fields (the equality +predicate and op. See #2238 + +Moreover, + class (a ~ F b) => C a b where {} +Here we can't use a newtype either, even though there is only +one field, because equality predicates are unboxed, and classes +are boxed. +-} + +newImplicitBinder :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRnIf m n Name -- Implicit name +-- Called in GHC.Tc.TyCl.Build to allocate the implicit binders of type/class decls +-- For source type/class decls, this is the first occurrence +-- For iface ones, GHC.Iface.Load has already allocated a suitable name in the cache +newImplicitBinder base_name mk_sys_occ + = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name) + +newImplicitBinderLoc :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> SrcSpan + -> TcRnIf m n Name -- Implicit name +-- Just the same, but lets you specify the SrcSpan +newImplicitBinderLoc base_name mk_sys_occ loc + | Just mod <- nameModule_maybe base_name + = newGlobalBinder mod occ loc + | otherwise -- When typechecking a [d| decl bracket |], + -- TH generates types, classes etc with Internal names, + -- so we follow suit for the implicit binders + = do { uniq <- newUnique + ; return (mkInternalName uniq occ loc) } + where + occ = mk_sys_occ (nameOccName base_name) + +-- | Make the 'TyConRepName' for this 'TyCon' +newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName +newTyConRepName tc_name + | Just mod <- nameModule_maybe tc_name + , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) + = newGlobalBinder mod occ noSrcSpan + | otherwise + = newImplicitBinder tc_name mkTyConRepOcc diff --git a/GHC/Tc/TyCl/Class.hs b/GHC/Tc/TyCl/Class.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Class.hs @@ -0,0 +1,556 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking class declarations +module GHC.Tc.TyCl.Class + ( tcClassSigs + , tcClassDecl2 + , findMethodBind + , instantiateMethod + , tcClassMinimalDef + , HsSigFun + , mkHsSigFun + , badMethodErr + , instDeclCtxt1 + , instDeclCtxt2 + , instDeclCtxt3 + , tcATDefault + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Gen.Sig +import GHC.Tc.Types.Evidence ( idHsWrapper ) +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.TcMType +import GHC.Core.Type ( piResultTys ) +import GHC.Core.Predicate +import GHC.Core.Multiplicity +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad +import GHC.Driver.Phases (HscSource(..)) +import GHC.Tc.TyCl.Build( TcMethInfo ) +import GHC.Core.Class +import GHC.Core.Coercion ( pprCoAxiom ) +import GHC.Driver.Session +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Core.TyCon +import GHC.Data.Maybe +import GHC.Types.Basic +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.BooleanFormula +import GHC.Utils.Misc + +import Control.Monad +import Data.List ( mapAccumL, partition ) + +{- +Dictionary handling +~~~~~~~~~~~~~~~~~~~ +Every class implicitly declares a new data type, corresponding to dictionaries +of that class. So, for example: + + class (D a) => C a where + op1 :: a -> a + op2 :: forall b. Ord b => a -> b -> b + +would implicitly declare + + data CDict a = CDict (D a) + (a -> a) + (forall b. Ord b => a -> b -> b) + +(We could use a record decl, but that means changing more of the existing apparatus. +One step at a time!) + +For classes with just one superclass+method, we use a newtype decl instead: + + class C a where + op :: forallb. a -> b -> b + +generates + + newtype CDict a = CDict (forall b. a -> b -> b) + +Now DictTy in Type is just a form of type synomym: + DictTy c t = TyConTy CDict `AppTy` t + +Death to "ExpandingDicts". + + +************************************************************************ +* * + Type-checking the class op signatures +* * +************************************************************************ +-} + +illegalHsigDefaultMethod :: Name -> SDoc +illegalHsigDefaultMethod n = + text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" + +tcClassSigs :: Name -- Name of the class + -> [LSig GhcRn] + -> LHsBinds GhcRn + -> TcM [TcMethInfo] -- Exactly one for each method +tcClassSigs clas sigs def_methods + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs + ; let gen_dm_env :: NameEnv (SrcSpan, Type) + gen_dm_env = mkNameEnv gen_dm_prs + + ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs + + ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] + ; sequence_ [ failWithTc (badMethodErr clas n) + | n <- dm_bind_names, not (n `elemNameSet` op_names) ] + -- Value binding for non class-method (ie no TypeSig) + + ; tcg_env <- getGblEnv + ; if tcg_src tcg_env == HsigFile + then + -- Error if we have value bindings + -- (Generic signatures without value bindings indicate + -- that a default of this form is expected to be + -- provided.) + when (not (null def_methods)) $ + failWithTc (illegalHsigDefaultMethod clas) + else + -- Error for each generic signature without value binding + sequence_ [ failWithTc (badGenericMethod clas n) + | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] + + ; traceTc "tcClassSigs 2" (ppr clas) + ; return op_info } + where + vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] + dm_bind_names :: [Name] -- These ones have a value binding in the class decl + dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] + + skol_info = TyConSkol ClassFlavour clas + + tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) + -> TcM [TcMethInfo] + tc_sig gen_dm_env (op_names, op_hs_ty) + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType skol_info op_names op_hs_ty + -- Class tyvars already in scope + + ; traceTc "ClsSig 2" (ppr op_names) + ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } + where + f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) + | nm `elem` dm_bind_names = Just VanillaDM + | otherwise = Nothing + + tc_gen_sig (op_names, gen_hs_ty) + = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty + ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } + +{- +************************************************************************ +* * + Class Declarations +* * +************************************************************************ +-} + +tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration + -> TcM (LHsBinds GhcTc) + +tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, + tcdMeths = default_binds})) + = recoverM (return emptyLHsBinds) $ + setSrcSpan (getLoc class_name) $ + do { clas <- tcLookupLocatedClass class_name + + -- We make a separate binding for each default method. + -- At one time I used a single AbsBinds for all of them, thus + -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } + -- But that desugars into + -- ds = \d -> (..., ..., ...) + -- dm1 = \d -> case ds d of (a,b,c) -> a + -- And since ds is big, it doesn't get inlined, so we don't get good + -- default methods. Better to make separate AbsBinds for each + ; let (tyvars, _, _, op_items) = classBigSig clas + prag_fn = mkPragEnv sigs default_binds + sig_fn = mkHsSigFun sigs + clas_tyvars = snd (tcSuperSkolTyVars tyvars) + pred = mkClassPred clas (mkTyVarTys clas_tyvars) + ; this_dict <- newEvVar pred + + ; let tc_item = tcDefMeth clas clas_tyvars this_dict + default_binds sig_fn prag_fn + ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ + mapM tc_item op_items + + ; return (unionManyBags dm_binds) } + +tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) + +tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn + -> HsSigFun -> TcPragEnv -> ClassOpItem + -> TcM (LHsBinds GhcTc) +-- Generate code for default methods +-- This is incompatible with Hugs, which expects a polymorphic +-- default method for every class op, regardless of whether or not +-- the programmer supplied an explicit default decl for the class. +-- (If necessary we can fix that, but we don't have a convenient Id to hand.) + +tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) + = do { -- No default method + mapM_ (addLocM (badDmPrag sel_id)) + (lookupPragEnv prag_fn (idName sel_id)) + ; return emptyBag } + +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn + (sel_id, Just (dm_name, dm_spec)) + | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn + = do { -- First look up the default method; it should be there! + -- It can be the ordinary default method + -- or the generic-default method. E.g of the latter + -- class C a where + -- op :: a -> a -> Bool + -- default op :: Eq a => a -> a -> Bool + -- op x y = x==y + -- The default method we generate is + -- $gm :: (C a, Eq a) => a -> a -> Bool + -- $gm x y = x==y + + global_dm_id <- tcLookupId dm_name + ; global_dm_id <- addInlinePrags global_dm_id prags + ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc + -- Base the local_dm_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + + ; spec_prags <- discardConstraints $ + tcSpecPrags global_dm_id prags + ; warnTc NoReason + (not (null spec_prags)) + (text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name)) + + ; let hs_ty = hs_sig_fn sel_name + `orElse` pprPanic "tc_dm" (ppr sel_name) + -- We need the HsType so that we can bring the right + -- type variables into scope + -- + -- Eg. class C a where + -- op :: forall b. Eq b => a -> [b] -> a + -- gen_op :: a -> a + -- generic gen_op :: D a => a -> a + -- The "local_dm_ty" is precisely the type in the above + -- type signatures, ie with no "forall a. C a =>" prefix + + local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) + + lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + + warn_redundant = case dm_spec of + GenericDM {} -> True + VanillaDM -> False + -- For GenericDM, warn if the user specifies a signature + -- with redundant constraints; but not for VanillaDM, where + -- the default method may well be 'error' or something + + ctxt = FunSigCtxt sel_name warn_redundant + + ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty + local_dm_sig = CompleteSig { sig_bndr = local_dm_id + , sig_ctxt = ctxt + , sig_loc = getLoc (hsSigType hs_ty) } + + ; (ev_binds, (tc_bind, _)) + <- checkConstraints skol_info tyvars [this_dict] $ + tcPolyCheck no_prag_fn local_dm_sig + (L bind_loc lm_bind) + + ; let export = ABE { abe_ext = noExtField + , abe_poly = global_dm_id + , abe_mono = local_dm_id + , abe_wrap = idHsWrapper + , abe_prags = IsDefaultMethod } + full_bind = AbsBinds { abs_ext = noExtField + , abs_tvs = tyvars + , abs_ev_vars = [this_dict] + , abs_exports = [export] + , abs_ev_binds = [ev_binds] + , abs_binds = tc_bind + , abs_sig = True } + + ; return (unitBag (L bind_loc full_bind)) } + + | otherwise = pprPanic "tcDefMeth" (ppr sel_id) + where + skol_info = TyConSkol ClassFlavour (getName clas) + sel_name = idName sel_id + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; + -- they are all for meth_id + +--------------- +tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef +tcClassMinimalDef _clas sigs op_info + = case findMinimalDef sigs of + Nothing -> return defMindef + Just mindef -> do + -- Warn if the given mindef does not imply the default one + -- That is, the given mindef should at least ensure that the + -- class ops without default methods are required, since we + -- have no way to fill them in otherwise + tcg_env <- getGblEnv + -- However, only do this test when it's not an hsig file, + -- since you can't write a default implementation. + when (tcg_src tcg_env /= HsigFile) $ + whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ + (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) + return mindef + where + -- By default require all methods without a default implementation + defMindef :: ClassMinimalDef + defMindef = mkAnd [ noLoc (mkVar name) + | (name, _, Nothing) <- op_info ] + +instantiateMethod :: Class -> TcId -> [TcType] -> TcType +-- Take a class operation, say +-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a +-- Instantiate it at [ty1,ty2] +-- Return the "local method type": +-- forall c. Ix x => (ty2,c) -> ty1 +instantiateMethod clas sel_id inst_tys + = ASSERT( ok_first_pred ) local_meth_ty + where + rho_ty = piResultTys (idType sel_id) inst_tys + (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + ok_first_pred = case getClassPredTys_maybe first_pred of + Just (clas1, _tys) -> clas == clas1 + Nothing -> False + -- The first predicate should be of form (C a b) + -- where C is the class in question + + +--------------------------- +type HsSigFun = Name -> Maybe (LHsSigType GhcRn) + +mkHsSigFun :: [LSig GhcRn] -> HsSigFun +mkHsSigFun sigs = lookupNameEnv env + where + env = mkHsSigEnv get_classop_sig sigs + + get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) + get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) + get_classop_sig _ = Nothing + +--------------------------- +findMethodBind :: Name -- Selector + -> LHsBinds GhcRn -- A group of bindings + -> TcPragEnv + -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) + -- Returns the binding, the binding + -- site of the method binder, and any inline or + -- specialisation pragmas +findMethodBind sel_name binds prag_fn + = foldl' mplus Nothing (mapBag f binds) + where + prags = lookupPragEnv prag_fn sel_name + + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) + | op_name == sel_name + = Just (bind, bndr_loc, prags) + f _other = Nothing + +--------------------------- +findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef +findMinimalDef = firstJusts . map toMinimalDef + where + toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef + toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) + toMinimalDef _ = Nothing + +{- +Note [Polymorphic methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Foo a where + op :: forall b. Ord b => a -> b -> b -> b + instance Foo c => Foo [c] where + op = e + +When typechecking the binding 'op = e', we'll have a meth_id for op +whose type is + op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b + +So tcPolyBinds must be capable of dealing with nested polytypes; +and so it is. See GHC.Tc.Gen.Bind.tcMonoBinds (with type-sig case). + +Note [Silly default-method bind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we pass the default method binding to the type checker, it must +look like op2 = e +not $dmop2 = e +otherwise the "$dm" stuff comes out error messages. But we want the +"$dm" to come out in the interface file. So we typecheck the former, +and wrap it in a let, thus + $dmop2 = let op2 = e in op2 +This makes the error messages right. + + +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +badMethodErr :: Outputable a => a -> Name -> SDoc +badMethodErr clas op + = hsep [text "Class", quotes (ppr clas), + text "does not have a method", quotes (ppr op)] + +badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod clas op + = hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] + +{- +badGenericInstanceType :: LHsBinds Name -> SDoc +badGenericInstanceType binds + = vcat [text "Illegal type pattern in the generic bindings", + nest 2 (ppr binds)] + +missingGenericInstances :: [Name] -> SDoc +missingGenericInstances missing + = text "Missing type patterns for" <+> pprQuotedList missing + +dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc +dupGenericInsts tc_inst_infos + = vcat [text "More than one type pattern for a single generic type constructor:", + nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), + text "All the type patterns for a generic type constructor must be identical" + ] + where + ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) +-} +badDmPrag :: TcId -> Sig GhcRn -> TcM () +badDmPrag sel_id prag + = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") + <+> quotes (ppr sel_id) + <+> text "lacks an accompanying binding") + +warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc +warningMinimalDefIncomplete mindef + = vcat [ text "The MINIMAL pragma does not require:" + , nest 2 (pprBooleanFormulaNice mindef) + , text "but there is no default implementation." ] + +instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + +instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 dfun_ty + = instDeclCtxt3 cls tys + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +instDeclCtxt3 :: Class -> [Type] -> SDoc +instDeclCtxt3 cls cls_tys + = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) + +inst_decl_ctxt :: SDoc -> SDoc +inst_decl_ctxt doc = hang (text "In the instance declaration for") + 2 (quotes doc) + +tcATDefault :: SrcSpan + -> TCvSubst + -> NameSet + -> ClassATItem + -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instantiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just (rhs_ty, _loc) <- defs + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTyUnchecked subst' rhs_ty + tcv' = tyCoVarsOfTypesList pat_tys' + (tv', cv') = partition isTyVar tcv' + tvs' = scopedSort tv' + cvs' = scopedSort cv' + ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' + fam_tc pat_tys' rhs' + -- NB: no validity check. We check validity of default instances + -- in the class definition. Because type instance arguments cannot + -- be type family applications and cannot be polytypes, the + -- validity check is redundant. + + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingAT (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + +warnMissingAT :: Name -> TcM () +warnMissingAT name + = do { warn <- woptM Opt_WarnMissingMethods + ; traceTc "warn" (ppr name <+> ppr warn) + ; hsc_src <- fmap tcg_src getGblEnv + -- Warn only if -Wmissing-methods AND not a signature + ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile) + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name)) } diff --git a/GHC/Tc/TyCl/Instance.hs b/GHC/Tc/TyCl/Instance.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Instance.hs @@ -0,0 +1,2250 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking instance declarations +module GHC.Tc.TyCl.Instance + ( tcInstDecls1 + , tcInstDeclsDeriv + , tcInstDecls2 + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Gen.Bind +import GHC.Tc.TyCl +import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) +import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, + HsSigFun, mkHsSigFun, badMethodErr, + findMethodBind, instantiateMethod ) +import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Monad +import GHC.Tc.Validity +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) +import GHC.Core.Multiplicity +import GHC.Core.InstEnv +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Tc.Deriv +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Unify +import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams ) +import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID ) +import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) +import GHC.Core.Type +import GHC.Core.Predicate( classMethodInstTy ) +import GHC.Tc.Types.Evidence +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.Class +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Data.Bag +import GHC.Types.Basic +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Data.FastString +import GHC.Types.Id +import GHC.Data.List.SetOps +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc +import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Tuple +import GHC.Data.Maybe +import Data.List( mapAccumL ) + + +{- +Typechecking instance declarations is done in two passes. The first +pass, made by @tcInstDecls1@, collects information to be used in the +second pass. + +This pre-processed info includes the as-yet-unprocessed bindings +inside the instance declaration. These are type-checked in the second +pass, when the class-instance envs and GVE contain all the info from +all the instance and value decls. Indeed that's the reason we need +two passes over the instance decls. + + +Note [How instance declarations are translated] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is how we translate instance declarations into Core + +Running example: + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = +===> + -- Method selectors + op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b + op1 = ... + op2 = ... + + -- Default methods get the 'self' dictionary as argument + -- so they can call other methods at the same type + -- Default methods get the same type as their method selector + $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b + $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). + -- NB: type variables 'a' and 'b' are *both* in scope in + -- Note [Tricky type variable scoping] + + -- A top-level definition for each instance method + -- Here op1_i, op2_i are the "instance method Ids" + -- The INLINE pragma comes from the user pragma + {-# INLINE [2] op1_i #-} -- From the instance decl bindings + op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b + op1_i = /\a. \(d:C a). + let this :: C [a] + this = df_i a d + -- Note [Subtle interaction of recursion and overlap] + + local_op1 :: forall b. Ix b => [a] -> b -> b + local_op1 = + -- Source code; run the type checker on this + -- NB: Type variable 'a' (but not 'b') is in scope in + -- Note [Tricky type variable scoping] + + in local_op1 a d + + op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) + + -- The dictionary function itself + {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions + df_i :: forall a. C a -> C [a] + df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) + -- But see Note [Default methods in instances] + -- We can't apply the type checker to the default-method call + + -- Use a RULE to short-circuit applications of the class ops + {-# RULE "op1@C[a]" forall a, d:C a. + op1 [a] (df_i d) = op1_i a d #-} + +Note [Instances and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Note that df_i may be mutually recursive with both op1_i and op2_i. + It's crucial that df_i is not chosen as the loop breaker, even + though op1_i has a (user-specified) INLINE pragma. + +* Instead the idea is to inline df_i into op1_i, which may then select + methods from the MkC record, and thereby break the recursion with + df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at + the same type, it won't mention df_i, so there won't be recursion in + the first place.) + +* If op1_i is marked INLINE by the user there's a danger that we won't + inline df_i in it, and that in turn means that (since it'll be a + loop-breaker because df_i isn't), op1_i will ironically never be + inlined. But this is OK: the recursion breaking happens by way of + a RULE (the magic ClassOp rule above), and RULES work inside InlineRule + unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Opt.Simplify.Utils + +Note [ClassOp/DFun selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One thing we see a lot is stuff like + op2 (df d1 d2) +where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* +'op2' and 'df' to get + case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of + MkD _ op2 _ _ _ -> op2 +And that will reduce to ($cop2 d1 d2) which is what we wanted. + +But it's tricky to make this work in practice, because it requires us to +inline both 'op2' and 'df'. But neither is keen to inline without having +seen the other's result; and it's very easy to get code bloat (from the +big intermediate) if you inline a bit too much. + +Instead we use a cunning trick. + * We arrange that 'df' and 'op2' NEVER inline. + + * We arrange that 'df' is ALWAYS defined in the sylised form + df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... + + * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) + that lists its methods. + + * We make GHC.Core.Unfold.exprIsConApp_maybe spot a DFunUnfolding and return + a suitable constructor application -- inlining df "on the fly" as it + were. + + * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that + extracts the right piece iff its argument satisfies + exprIsConApp_maybe. This is done in GHC.Types.Id.Make.mkDictSelId + + * We make 'df' CONLIKE, so that shared uses still match; eg + let d = df d1 d2 + in ...(op2 d)...(op1 d)... + +Note [Single-method classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the class has just one method (or, more accurately, just one element +of {superclasses + methods}), then we use a different strategy. + + class C a where op :: a -> a + instance C a => C [a] where op = + +We translate the class decl into a newtype, which just gives a +top-level axiom. The "constructor" MkC expands to a cast, as does the +class-op selector. + + axiom Co:C a :: C a ~ (a->a) + + op :: forall a. C a -> (a -> a) + op a d = d |> (Co:C a) + + MkC :: forall a. (a->a) -> C a + MkC = /\a.\op. op |> (sym Co:C a) + +The clever RULE stuff doesn't work now, because ($df a d) isn't +a constructor application, so exprIsConApp_maybe won't return +Just . + +Instead, we simply rely on the fact that casts are cheap: + + $df :: forall a. C a => C [a] + {-# INLINE df #-} -- NB: INLINE this + $df = /\a. \d. MkC [a] ($cop_list a d) + = $cop_list |> forall a. C a -> (sym (Co:C [a])) + + $cop_list :: forall a. C a => [a] -> [a] + $cop_list = + +So if we see + (op ($df a d)) +we'll inline 'op' and '$df', since both are simply casts, and +good things happen. + +Why do we use this different strategy? Because otherwise we +end up with non-inlined dictionaries that look like + $df = $cop |> blah +which adds an extra indirection to every use, which seems stupid. See +#4138 for an example (although the regression reported there +wasn't due to the indirection). + +There is an awkward wrinkle though: we want to be very +careful when we have + instance C a => C [a] where + {-# INLINE op #-} + op = ... +then we'll get an INLINE pragma on $cop_list but it's important that +$cop_list only inlines when it's applied to *two* arguments (the +dictionary and the list argument). So we must not eta-expand $df +above. We ensure that this doesn't happen by putting an INLINE +pragma on the dfun itself; after all, it ends up being just a cast. + +There is one more dark corner to the INLINE story, even more deeply +buried. Consider this (#3772): + + class DeepSeq a => C a where + gen :: Int -> a + + instance C a => C [a] where + gen n = ... + + class DeepSeq a where + deepSeq :: a -> b -> b + + instance DeepSeq a => DeepSeq [a] where + {-# INLINE deepSeq #-} + deepSeq xs b = foldr deepSeq b xs + +That gives rise to these defns: + + $cdeepSeq :: DeepSeq a -> [a] -> b -> b + -- User INLINE( 3 args )! + $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... + + $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] + -- DFun (with auto INLINE pragma) + $fDeepSeq[] a d = $cdeepSeq a d |> blah + + $cp1 a d :: C a => DeepSep [a] + -- We don't want to eta-expand this, lest + -- $cdeepSeq gets inlined in it! + $cp1 a d = $fDeepSep[] a (scsel a d) + + $fC[] :: C a => C [a] + -- Ordinary DFun + $fC[] a d = MkC ($cp1 a d) ($cgen a d) + +Here $cp1 is the code that generates the superclass for C [a]. The +issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] +and then $cdeepSeq will inline there, which is definitely wrong. Like +on the dfun, we solve this by adding an INLINE pragma to $cp1. + +Note [Subtle interaction of recursion and overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + class C a where { op1,op2 :: a -> a } + instance C a => C [a] where + op1 x = op2 x ++ op2 x + op2 x = ... + instance C [Int] where + ... + +When type-checking the C [a] instance, we need a C [a] dictionary (for +the call of op2). If we look up in the instance environment, we find +an overlap. And in *general* the right thing is to complain (see Note +[Overlapping instances] in GHC.Core.InstEnv). But in *this* case it's wrong to +complain, because we just want to delegate to the op2 of this same +instance. + +Why is this justified? Because we generate a (C [a]) constraint in +a context in which 'a' cannot be instantiated to anything that matches +other overlapping instances, or else we would not be executing this +version of op1 in the first place. + +It might even be a bit disguised: + + nullFail :: C [a] => [a] -> [a] + nullFail x = op2 x ++ op2 x + + instance C a => C [a] where + op1 x = nullFail x + +Precisely this is used in package 'regex-base', module Context.hs. +See the overlapping instances for RegexContext, and the fact that they +call 'nullFail' just like the example above. The DoCon package also +does the same thing; it shows up in module Fraction.hs. + +Conclusion: when typechecking the methods in a C [a] instance, we want to +treat the 'a' as an *existential* type variable, in the sense described +by Note [Binding when looking up instances]. That is why isOverlappableTyVar +responds True to an InstSkol, which is the kind of skolem we use in +tcInstDecl2. + + +Note [Tricky type variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In our example + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = + +note that 'a' and 'b' are *both* in scope in , but only 'a' is +in scope in . In particular, we must make sure that 'b' is in +scope when typechecking . This is achieved by subFunTys, +which brings appropriate tyvars into scope. This happens for both + and for , but that doesn't matter: the *renamer* will have +complained if 'b' is mentioned in . + + + +************************************************************************ +* * +\subsection{Extracting instance decls} +* * +************************************************************************ + +Gather up the instance declarations from their various sources +-} + +tcInstDecls1 -- Deal with both source-code and imported instance decls + :: [LInstDecl GhcRn] -- Source code instance decls + -> TcM (TcGblEnv, -- The full inst env + [InstInfo GhcRn], -- Source-code instance decls to process; + -- contains all dfuns for this module + [DerivInfo]) -- From data family instances + +tcInstDecls1 inst_decls + = do { -- Do class and family instance declarations + ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls + + ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff + fam_insts = concat fam_insts_s + local_infos = concat local_infos_s + + ; gbl_env <- addClsInsts local_infos $ + addFamInsts fam_insts $ + getGblEnv + + ; return ( gbl_env + , local_infos + , concat datafam_deriv_infos ) } + +-- | Use DerivInfo for data family instances (produced by tcInstDecls1), +-- datatype declarations (TyClDecl), and standalone deriving declarations +-- (DerivDecl) to check and process all derived class instances. +tcInstDeclsDeriv + :: [DerivInfo] + -> [LDerivDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) +tcInstDeclsDeriv deriv_infos derivds + = do th_stage <- getStage -- See Note [Deriving inside TH brackets] + if isBrackStage th_stage + then do { gbl_env <- getGblEnv + ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } + else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds + ; return (tcg_env, bagToList info_bag, valbinds) } + +addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a +addClsInsts infos thing_inside + = tcExtendLocalInstEnv (map iSpec infos) thing_inside + +addFamInsts :: [FamInst] -> TcM a -> TcM a +-- Extend (a) the family instance envt +-- (b) the type envt with stuff from data type decls +addFamInsts fam_insts thing_inside + = tcExtendLocalFamInstEnv fam_insts $ + tcExtendGlobalEnv axioms $ + do { traceTc "addFamInsts" (pprFamInsts fam_insts) + ; gbl_env <- addTyConsToGblEnv data_rep_tycons + -- Does not add its axiom; that comes + -- from adding the 'axioms' above + ; setGblEnv gbl_env thing_inside } + where + axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts + data_rep_tycons = famInstsRepTyCons fam_insts + -- The representation tycons for 'data instances' declarations + +{- +Note [Deriving inside TH brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a declaration bracket + [d| data T = A | B deriving( Show ) |] + +there is really no point in generating the derived code for deriving( +Show) and then type-checking it. This will happen at the call site +anyway, and the type check should never fail! Moreover (#6005) +the scoping of the generated code inside the bracket does not seem to +work out. + +The easy solution is simply not to generate the derived instances at +all. (A less brutal solution would be to generate them with no +bindings.) This will become moot when we shift to the new TH plan, so +the brutal solution will do. +-} + +tcLocalInstDecl :: LInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) + -- A source-file instance declaration + -- Type-check all the stuff before the "where" + -- + -- We check for respectable instance type, and context +tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) + = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl) + ; return ([], [fam_inst], []) } + +tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) + = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl) + ; return ([], [fam_inst], maybeToList m_deriv_info) } + +tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) + = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) + ; return (insts, fam_insts, deriv_infos) } + +tcClsInstDecl :: LClsInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) +-- The returned DerivInfos are for any associated data families +tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = overlap_mode + , cid_datafam_insts = adts })) + = setSrcSpan loc $ + addErrCtxt (instDeclCtxt1 hs_ty) $ + do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty + ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty + -- NB: tcHsClsInstType does checkValidInstance + + ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars + ; let tv_skol_prs = [ (tyVarName tv, skol_tv) + | (tv, skol_tv) <- tyvars `zip` skol_tvs ] + -- Map from the skolemized Names to the original Names. + -- See Note [Associated data family instances and di_scoped_tvs]. + tv_skol_env = mkVarEnv $ map swap tv_skol_prs + n_inferred = countWhile ((== Inferred) . binderArgFlag) $ + fst $ splitForAllVarBndrs dfun_ty + visible_skol_tvs = drop n_inferred skol_tvs + + ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs) + + -- Next, process any associated types. + ; (datafam_stuff, tyfam_insts) + <- tcExtendNameTyVarEnv tv_skol_prs $ + do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env + mb_info = InClsInst { ai_class = clas + , ai_tyvars = visible_skol_tvs + , ai_inst_env = mini_env } + ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts + ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats + + -- Check for missing associated types and build them + -- from their defaults (if available) + ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) + (classATItems clas) + + ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } + + + -- Finally, construct the Core representation of the instance. + -- (This no longer includes the associated types.) + ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty)) + -- Dfun location is that of instance *header* + + ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name + tyvars theta clas inst_tys + + ; let inst_binds = InstBindings + { ib_binds = binds + , ib_tyvars = map Var.varName tyvars -- Scope over bindings + , ib_pragmas = uprags + , ib_extensions = [] + , ib_derived = False } + inst_info = InstInfo { iSpec = ispec, iBinds = inst_binds } + + (datafam_insts, m_deriv_infos) = unzip datafam_stuff + deriv_infos = catMaybes m_deriv_infos + all_insts = tyfam_insts ++ datafam_insts + + -- In hs-boot files there should be no bindings + ; is_boot <- tcIsHsBootOrSig + ; let no_binds = isEmptyLHsBinds binds && null uprags + ; failIfTc (is_boot && not no_binds) badBootDeclErr + + ; return ( [inst_info], all_insts, deriv_infos ) } + where + defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSet` + mkNameSet (map (unLoc . feqn_tycon + . hsib_body + . dfid_eqn + . unLoc) adts) + +{- +************************************************************************ +* * + Type family instances +* * +************************************************************************ + +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). +-} + +tcTyFamInstDecl :: AssocInstInfo + -> LTyFamInstDecl GhcRn -> TcM FamInst + -- "type instance" + -- See Note [Associated type instances] +tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) + = setSrcSpan loc $ + tcAddTyFamInstCtxt decl $ + do { let fam_lname = feqn_tycon (hsib_body eqn) + ; fam_tc <- tcLookupLocatedTyCon fam_lname + ; tcFamInstDeclChecks mb_clsinfo fam_tc + + -- (0) Check it's an open type family + ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) + + -- (1) do the work of verifying the synonym group + ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo + (L (getLoc fam_lname) eqn) + + + -- (2) check for validity + ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch + ; checkValidCoAxBranch fam_tc co_ax_branch + + -- (3) construct coercion axiom + ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] + ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch + ; newFamInst SynFamilyInst axiom } + + +--------------------- +tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () +-- Used for both type and data families +tcFamInstDeclChecks mb_clsinfo fam_tc + = do { -- Type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file + ; traceTc "tcFamInstDecl" (ppr fam_tc) + ; type_families <- xoptM LangExt.TypeFamilies + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + ; checkTc type_families $ badFamInstDecl fam_tc + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Check that it is a family TyCon, and that + -- oplevel type instances are not for associated types. + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + + ; when (isNotAssociated mb_clsinfo && -- Not in a class decl + isTyConAssoc fam_tc) -- but an associated type + (addErr $ assocInClassErr fam_tc) + } + +{- Note [Associated type instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow this: + class C a where + type T x a + instance C Int where + type T (S y) Int = y + type T Z Int = Char + +Note that + a) The variable 'x' is not bound by the class decl + b) 'x' is instantiated to a non-type-variable in the instance + c) There are several type instance decls for T in the instance + +All this is fine. Of course, you can't give any *more* instances +for (T ty Int) elsewhere, because it's an *associated* type. + + +************************************************************************ +* * + Data family instances +* * +************************************************************************ + +For some reason data family instances are a lot more complicated +than type family instances +-} + +tcDataFamInstDecl :: + AssocInstInfo + -> TyVarEnv Name -- If this is an associated data family instance, maps the + -- parent class's skolemized type variables to their + -- original Names. If this is a non-associated instance, + -- this will be empty. + -- See Note [Associated data family instances and di_scoped_tvs]. + -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) + -- "newtype instance" and "data instance" +tcDataFamInstDecl mb_clsinfo tv_skol_env + (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars + , hsib_body = + FamEqn { feqn_bndrs = mb_bndrs + , feqn_pats = hs_pats + , feqn_tycon = lfam_name@(L _ fam_name) + , feqn_fixity = fixity + , feqn_rhs = HsDataDefn { dd_ND = new_or_data + , dd_cType = cType + , dd_ctxt = hs_ctxt + , dd_cons = hs_cons + , dd_kindSig = m_ksig + , dd_derivs = derivs } }}})) + = setSrcSpan loc $ + tcAddDataFamInstCtxt decl $ + do { fam_tc <- tcLookupLocatedTyCon lfam_name + + ; tcFamInstDeclChecks mb_clsinfo fam_tc + + -- Check that the family declaration is for the right kind + ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons + -- Do /not/ check that the number of patterns = tyConArity fam_tc + -- See [Arity of data families] in GHC.Core.FamInstEnv + ; (qtvs, pats, res_kind, stupid_theta) + <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs + fixity hs_ctxt hs_pats m_ksig hs_cons + new_or_data + + -- Eta-reduce the axiom if possible + -- Quite tricky: see Note [Implementing eta reduction for data families] + ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats + eta_tvs = map binderVar eta_tcbs + post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs + + full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs + (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) + ++ eta_tcbs + -- Put the eta-removed tyvars at the end + -- Remember, qtvs is in arbitrary order, except kind vars are + -- first, so there is no reason to suppose that the eta_tvs + -- (obtained from the pats) are at the end (#11148) + + -- Eta-expand the representation tycon until it has result + -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we + -- go one step further and ensure that it has kind `TYPE 'LiftedRep`. + -- + -- See also Note [Arity of data families] in GHC.Core.FamInstEnv + -- NB: we can do this after eta-reducing the axiom, because if + -- we did it before the "extra" tvs from etaExpandAlgTyCon + -- would always be eta-reduced + -- + ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind + + -- Check the result kind; it may come from a user-written signature. + -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a) + ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs + all_pats = pats `chkAppend` extra_pats + orig_res_ty = mkTyConApp fam_tc all_pats + ty_binders = full_tcbs `chkAppend` extra_tcbs + + ; traceTc "tcDataFamInstDecl" $ + vcat [ text "Fam tycon:" <+> ppr fam_tc + , text "Pats:" <+> ppr pats + , text "visiblities:" <+> ppr (tcbVisibilities fam_tc pats) + , text "all_pats:" <+> ppr all_pats + , text "ty_binders" <+> ppr ty_binders + , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) + , text "res_kind:" <+> ppr res_kind + , text "final_res_kind:" <+> ppr final_res_kind + , text "eta_pats" <+> ppr eta_pats + , text "eta_tcbs" <+> ppr eta_tcbs ] + + ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> + do { data_cons <- tcExtendTyVarEnv qtvs $ + -- For H98 decls, the tyvars scope + -- over the data constructors + tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind + orig_res_ty hs_cons + + ; rep_tc_name <- newFamInstTyConName lfam_name pats + ; axiom_name <- newFamInstAxiomName lfam_name [pats] + ; tc_rhs <- case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) + + ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs) + axiom = mkSingleCoAxiom Representational axiom_name + post_eta_qtvs eta_tvs [] fam_tc eta_pats ax_rhs + parent = DataFamInstTyCon axiom fam_tc all_pats + + -- NB: Use the full ty_binders from the pats. See bullet toward + -- the end of Note [Data type families] in GHC.Core.TyCon + rep_tc = mkAlgTyCon rep_tc_name + ty_binders final_res_kind + (map (const Nominal) ty_binders) + (fmap unLoc cType) stupid_theta + tc_rhs parent + gadt_syntax + -- We always assume that indexed types are recursive. Why? + -- (1) Due to their open nature, we can never be sure that a + -- further instance might not introduce a new recursive + -- dependency. (2) They are always valid loop breakers as + -- they involve a coercion. + ; return (rep_tc, axiom) } + + -- Remember to check validity; no recursion to worry about here + -- Check that left-hand sides are ok (mono-types, no type families, + -- consistent instantiations, etc) + ; let ax_branch = coAxiomSingleBranch axiom + ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch + ; checkValidCoAxBranch fam_tc ax_branch + ; checkValidTyCon rep_tc + + ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc) + m_deriv_info = case derivs of + L _ [] -> Nothing + L _ preds -> + Just $ DerivInfo { di_rep_tc = rep_tc + , di_scoped_tvs = scoped_tvs + , di_clauses = preds + , di_ctxt = tcMkDataFamInstCtxt decl } + + ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom + ; return (fam_inst, m_deriv_info) } + where + eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + -- Splits the incoming patterns into two: the [TyVar] + -- are the patterns that can be eta-reduced away. + -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) + -- + -- NB: quadratic algorithm, but types are small here + eta_reduce fam_tc pats + = go (reverse (zip3 pats fvs_s vis_s)) [] + where + vis_s :: [TyConBndrVis] + vis_s = tcbVisibilities fam_tc pats + + fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats + -- Each elt is the free vars of all /earlier/ pats + (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats + add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs) + + go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs + | Just tv <- getTyVar_maybe pat + , not (tv `elemVarSet` fvs_to_the_left) + = go pats (Bndr tv tcb_vis : etad_tvs) + go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) + + -- Create a Name-TyVar mapping to bring into scope when typechecking any + -- deriving clauses this data family instance may have. + -- See Note [Associated data family instances and di_scoped_tvs]. + mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar) + mk_deriv_info_scoped_tv_pr tv = + let n = lookupWithDefaultVarEnv tv_skol_env (tyVarName tv) tv + in (n, tv) + +{- +Note [Associated data family instances and di_scoped_tvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some care is required to implement `deriving` correctly for associated data +family instances. Consider this example from #18055: + + class C a where + data D a + + class X a b + + instance C (Maybe a) where + data D (Maybe a) deriving (X a) + +When typechecking the `X a` in `deriving (X a)`, we must ensure that the `a` +from the instance header is brought into scope. This is the role of +di_scoped_tvs, which maps from the original, renamed `a` to the skolemized, +typechecked `a`. When typechecking the `deriving` clause, this mapping will be +consulted when looking up the `a` in `X a`. + +A naïve attempt at creating the di_scoped_tvs is to simply reuse the +tyConTyVars of the representation TyCon for `data D (Maybe a)`. This is only +half correct, however. We do want the typechecked `a`'s Name in the /range/ +of the mapping, but we do not want it in the /domain/ of the mapping. +To ensure that the original `a`'s Name ends up in the domain, we consult a +TyVarEnv (passed as an argument to tcDataFamInstDecl) that maps from the +typechecked `a`'s Name to the original `a`'s Name. In the even that +tcDataFamInstDecl is processing a non-associated data family instance, this +TyVarEnv will simply be empty, and there is nothing to worry about. +-} + +----------------------- +tcDataFamInstHeader + :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr () GhcRn] + -> LexicalFixity -> LHsContext GhcRn + -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] + -> NewOrData + -> TcM ([TyVar], [Type], Kind, ThetaType) +-- The "header" of a data family instance is the part other than +-- the data constructors themselves +-- e.g. data instance D [a] :: * -> * where ... +-- Here the "header" is the bit before the "where" +tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity + hs_ctxt hs_pats m_ksig hs_cons new_or_data + = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats) + ; (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol imp_vars $ + bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ + do { stupid_theta <- tcHsContext hs_ctxt + ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats + ; (lhs_applied_ty, lhs_applied_kind) + <- tcInstInvisibleTyBinders lhs_ty lhs_kind + -- See Note [Data family/instance return kinds] + -- in GHC.Tc.TyCl point (DF3) + + -- Ensure that the instance is consistent + -- with its parent class + ; addConsistencyConstraints mb_clsinfo lhs_ty + + -- Add constraints from the result signature + ; res_kind <- tc_kind_sig m_ksig + + -- Add constraints from the data constructors + ; kcConDecls new_or_data res_kind hs_cons + + -- Check that the result kind of the TyCon applied to its args + -- is compatible with the explicit signature (or Type, if there + -- is none) + ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats + ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind + + ; traceTc "tcDataFamInstHeader" $ + vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ] + ; return ( stupid_theta + , lhs_applied_ty + , lhs_applied_kind + , res_kind ) } + + -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] + -- This code (and the stuff immediately above) is very similar + -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the + -- common code; but for the moment I concluded that it's + -- clearer to duplicate it. Still, if you fix a bug here, + -- check there too! + ; let scoped_tvs = imp_tvs ++ exp_tvs + ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) + ; qtvs <- quantifyTyVars dvs + + -- Zonk the patterns etc into the Type world + ; (ze, qtvs) <- zonkTyBndrs qtvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta + ; master_res_kind <- zonkTcTypeToTypeX ze master_res_kind + ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind + + -- We check that res_kind is OK with checkDataKindSig in + -- tcDataFamInstDecl, after eta-expansion. We need to check that + -- it's ok because res_kind can come from a user-written kind signature. + -- See Note [Datatype return kinds], point (4a) + + ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind + ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind + + -- Check that type patterns match the class instance head + -- The call to splitTyConApp_maybe here is just an inlining of + -- the body of unravelFamInstPats. + ; pats <- case splitTyConApp_maybe lhs_ty of + Just (_, pats) -> pure pats + Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) + + ; return (qtvs, pats, master_res_kind, stupid_theta) } + where + fam_name = tyConName fam_tc + data_ctxt = DataKindCtxt fam_name + exp_bndrs = mb_bndrs `orElse` [] + + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, wrinkle (2). + tc_kind_sig Nothing + = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; if unlifted_newtypes && new_or_data == NewType + then newOpenTypeKind + else pure liftedTypeKind + } + + -- See Note [Result kind signature for a data family instance] + tc_kind_sig (Just hs_kind) + = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind + ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind + ; lvl <- getTcLevel + ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs + -- Perhaps surprisingly, we don't need the skolemised tvs themselves + ; return (substTy subst inner_kind) } + +{- Note [Result kind signature for a data family instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expected type might have a forall at the type. Normally, we +can't skolemise in kinds because we don't have type-level lambda. +But here, we're at the top-level of an instance declaration, so +we actually have a place to put the regeneralised variables. +Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcSkolemise +Examples in indexed-types/should_compile/T12369 + +Note [Implementing eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data D :: * -> * -> * -> * -> * + + data instance D [(a,b)] p q :: * -> * where + D1 :: blah1 + D2 :: blah2 + +Then we'll generate a representation data type + data Drep a b p q z where + D1 :: blah1 + D2 :: blah2 + +and an axiom to connect them + axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z + +except that we'll eta-reduce the axiom to + axiom AxDrep forall a b. D [(a,b]] = Drep a b + +This is described at some length in Note [Eta reduction for data families] +in GHC.Core.Coercion.Axiom. There are several fiddly subtleties lurking here, +however, so this Note aims to describe these subtleties: + +* The representation tycon Drep is parameterised over the free + variables of the pattern, in no particular order. So there is no + guarantee that 'p' and 'q' will come last in Drep's parameters, and + in the right order. So, if the /patterns/ of the family instance + are eta-reducible, we re-order Drep's parameters to put the + eta-reduced type variables last. + +* Although we eta-reduce the axiom, we eta-/expand/ the representation + tycon Drep. The kind of D says it takes four arguments, but the + data instance header only supplies three. But the AlgTyCon for Drep + itself must have enough TyConBinders so that its result kind is Type. + So, with etaExpandAlgTyCon we make up some extra TyConBinders. + See point (3) in Note [Datatype return kinds] in GHC.Tc.TyCl. + +* The result kind in the instance might be a polykind, like this: + data family DP a :: forall k. k -> * + data instance DP [b] :: forall k1 k2. (k1,k2) -> * + + So in type-checking the LHS (DP Int) we need to check that it is + more polymorphic than the signature. To do that we must skolemise + the signature and instantiate the call of DP. So we end up with + data instance DP [b] @(k1,k2) (z :: (k1,k2)) where + + Note that we must parameterise the representation tycon DPrep over + 'k1' and 'k2', as well as 'b'. + + The skolemise bit is done in tc_kind_sig, while the instantiate bit + is done by tcFamTyPats. + +* Very fiddly point. When we eta-reduce to + axiom AxDrep forall a b. D [(a,b]] = Drep a b + + we want the kind of (D [(a,b)]) to be the same as the kind of + (Drep a b). This ensures that applying the axiom doesn't change the + kind. Why is that hard? Because the kind of (Drep a b) depends on + the TyConBndrVis on Drep's arguments. In particular do we have + (forall (k::*). blah) or (* -> blah)? + + We must match whatever D does! In #15817 we had + data family X a :: forall k. * -> * -- Note: a forall that is not used + data instance X Int b = MkX + + So the data instance is really + data istance X Int @k b = MkX + + The axiom will look like + axiom X Int = Xrep + + and it's important that XRep :: forall k * -> *, following X. + + To achieve this we get the TyConBndrVis flags from tcbVisibilities, + and use those flags for any eta-reduced arguments. Sigh. + +* The final turn of the knife is that tcbVisibilities is itself + tricky to sort out. Consider + data family D k :: k + Then consider D (forall k2. k2 -> k2) Type Type + The visibility flags on an application of D may affected by the arguments + themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities + does. + +-} + + +{- ********************************************************************* +* * + Class instance declarations, pass 2 +* * +********************************************************************* -} + +tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] + -> TcM (LHsBinds GhcTc) +-- (a) From each class declaration, +-- generate any default-method bindings +-- (b) From each instance decl +-- generate the dfun binding + +tcInstDecls2 tycl_decls inst_decls + = do { -- (a) Default methods from class decls + let class_decls = filter (isClassDecl . unLoc) tycl_decls + ; dm_binds_s <- mapM tcClassDecl2 class_decls + ; let dm_binds = unionManyBags dm_binds_s + + -- (b) instance declarations + ; let dm_ids = collectHsBindsBinders dm_binds + -- Add the default method Ids (again) + -- (they were arready added in GHC.Tc.TyCl.Utils.tcAddImplicits) + -- See Note [Default methods in the type environment] + ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls + + -- Done + ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } + +{- Note [Default methods in the type environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default method Ids are already in the type environment (see Note +[Default method Ids and Template Haskell] in TcTyDcls), BUT they +don't have their InlinePragmas yet. Usually that would not matter, +because the simplifier propagates information from binding site to +use. But, unusually, when compiling instance decls we *copy* the +INLINE pragma from the default method to the method for that +particular operation (see Note [INLINE and default methods] below). + +So right here in tcInstDecls2 we must re-extend the type envt with +the default method Ids replete with their INLINE pragmas. Urk. +-} + +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) + -- Returns a binding for the dfun +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ + do { -- Instantiate the instance decl with skolem constants + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id + ; dfun_ev_vars <- newEvVars dfun_theta + -- We instantiate the dfun_id with superSkolems. + -- See Note [Subtle interaction of recursion and overlap] + -- and Note [Binding when looking up instances] + + ; let (clas, inst_tys) = tcSplitDFunHead inst_head + (class_tyvars, sc_theta, _, op_items) = classBigSig clas + sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta + + ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) + + -- Deal with 'SPECIALISE instance' pragmas + -- See Note [SPECIALISE instance pragmas] + ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds + + -- Typecheck superclasses and methods + -- See Note [Typechecking plan for instance declarations] + ; dfun_ev_binds_var <- newTcEvBinds + ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) + <- pushTcLevelM $ + do { (sc_ids, sc_binds, sc_implics) + <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars + inst_tys dfun_ev_binds + sc_theta' + + -- Typecheck the methods + ; (meth_ids, meth_binds, meth_implics) + <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars + inst_tys dfun_ev_binds spec_inst_info + op_items ibinds + + ; return ( sc_ids ++ meth_ids + , sc_binds `unionBags` meth_binds + , sc_implics `unionBags` meth_implics ) } + + ; imp <- newImplication + ; emitImplication $ + imp { ic_tclvl = tclvl + , ic_skols = inst_tyvars + , ic_given = dfun_ev_vars + , ic_wanted = mkImplicWC sc_meth_implics + , ic_binds = dfun_ev_binds_var + , ic_info = InstSkol } + + -- Create the result bindings + ; self_dict <- newDict clas inst_tys + ; let class_tc = classTyCon clas + [dict_constr] = tyConDataCons class_tc + dict_bind = mkVarBind self_dict (L loc con_app_args) + + -- We don't produce a binding for the dict_constr; instead we + -- rely on the simplifier to unfold this saturated application + -- We do this rather than generate an HsCon directly, because + -- it means that the special cases (e.g. dictionary with only one + -- member) are dealt with by the common MkId.mkDataConWrapId + -- code rather than needing to be repeated here. + -- con_app_tys = MkD ty1 ty2 + -- con_app_scs = MkD ty1 ty2 sc1 sc2 + -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 + con_app_tys = mkHsWrap (mkWpTyApps inst_tys) + (HsConLikeOut noExtField (RealDataCon dict_constr)) + -- NB: We *can* have covars in inst_tys, in the case of + -- promoted GADT constructors. + + con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids + + app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc + app_to_meth fun meth_id = HsApp noExtField (L loc fun) + (L loc (wrapId arg_wrapper meth_id)) + + inst_tv_tys = mkTyVarTys inst_tyvars + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys + + is_newtype = isNewTyCon class_tc + dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids + dfun_spec_prags + | is_newtype = SpecPrags [] + | otherwise = SpecPrags spec_inst_prags + -- Newtype dfuns just inline unconditionally, + -- so don't attempt to specialise them + + export = ABE { abe_ext = noExtField + , abe_wrap = idHsWrapper + , abe_poly = dfun_id_w_prags + , abe_mono = self_dict + , abe_prags = dfun_spec_prags } + -- NB: see Note [SPECIALISE instance pragmas] + main_bind = AbsBinds { abs_ext = noExtField + , abs_tvs = inst_tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = [] + , abs_binds = unitBag dict_bind + , abs_sig = True } + + ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) + } + where + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id + +addDFunPrags :: DFunId -> [Id] -> DFunId +-- DFuns need a special Unfolding and InlinePrag +-- See Note [ClassOp/DFun selection] +-- and Note [Single-method classes] +-- It's easiest to create those unfoldings right here, where +-- have all the pieces in hand, even though we are messing with +-- Core at this point, which the typechecker doesn't usually do +-- However we take care to build the unfolding using the TyVars from +-- the DFunId rather than from the skolem pieces that the typechecker +-- is messing with. +addDFunPrags dfun_id sc_meth_ids + | is_newtype + = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app + `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + | otherwise + = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args + `setInlinePragma` dfunInlinePragma + where + con_app = mkLams dfun_bndrs $ + mkApps (Var (dataConWrapId dict_con)) dict_args + -- mkApps is OK because of the checkForLevPoly call in checkValidClass + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + dict_args = map Type inst_tys ++ + [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] + + (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) + ev_ids = mkTemplateLocalsNum 1 dfun_theta + dfun_bndrs = dfun_tvs ++ ev_ids + clas_tc = classTyCon clas + [dict_con] = tyConDataCons clas_tc + is_newtype = isNewTyCon clas_tc + +wrapId :: HsWrapper -> Id -> HsExpr GhcTc +wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) + +{- Note [Typechecking plan for instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For instance declarations we generate the following bindings and implication +constraints. Example: + + instance Ord a => Ord [a] where compare = + +generates this: + + Bindings: + -- Method bindings + $ccompare :: forall a. Ord a => a -> a -> Ordering + $ccompare = /\a \(d:Ord a). let in ... + + -- Superclass bindings + $cp1Ord :: forall a. Ord a => Eq [a] + $cp1Ord = /\a \(d:Ord a). let + in dfEqList (dw :: Eq a) + + Constraints: + forall a. Ord a => + -- Method constraint + (forall. (empty) => ) + -- Superclass constraint + /\ (forall. (empty) => dw :: Eq a) + +Notice that + + * Per-meth/sc implication. There is one inner implication per + superclass or method, with no skolem variables or givens. The only + reason for this one is to gather the evidence bindings privately + for this superclass or method. This implication is generated + by checkInstConstraints. + + * Overall instance implication. There is an overall enclosing + implication for the whole instance declaration, with the expected + skolems and givens. We need this to get the correct "redundant + constraint" warnings, gathering all the uses from all the methods + and superclasses. See GHC.Tc.Solver Note [Tracking redundant + constraints] + + * The given constraints in the outer implication may generate + evidence, notably by superclass selection. Since the method and + superclass bindings are top-level, we want that evidence copied + into *every* method or superclass definition. (Some of it will + be usused in some, but dead-code elimination will drop it.) + + We achieve this by putting the evidence variable for the overall + instance implication into the AbsBinds for each method/superclass. + Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. + (And that in turn is why the abs_ev_binds field of AbBinds is a + [TcEvBinds] rather than simply TcEvBinds. + + This is a bit of a hack, but works very nicely in practice. + + * Note that if a method has a locally-polymorphic binding, there will + be yet another implication for that, generated by tcPolyCheck + in tcMethodBody. E.g. + class C a where + foo :: forall b. Ord b => blah + + +************************************************************************ +* * + Type-checking superclasses +* * +************************************************************************ +-} + +tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> TcEvBinds + -> TcThetaType + -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) +-- Make a new top-level function binding for each superclass, +-- something like +-- $Ordp1 :: forall a. Ord a => Eq [a] +-- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) +-- +-- See Note [Recursive superclasses] for why this is so hard! +-- In effect, we build a special-purpose solver for the first step +-- of solving each superclass constraint +tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta + = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) + ; return (ids, listToBag binds, listToBag implics) } + where + loc = getSrcSpan dfun_id + size = sizeTypes inst_tys + tc_super (sc_pred, n) + = do { (sc_implic, ev_binds_var, sc_ev_tm) + <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred + + ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) + ; sc_ev_id <- newEvVar sc_pred + ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm + ; let sc_top_ty = mkInfForAllTys tyvars $ + mkPhiTy (map idType dfun_evs) sc_pred + sc_top_id = mkLocalId sc_top_name Many sc_top_ty + export = ABE { abe_ext = noExtField + , abe_wrap = idHsWrapper + , abe_poly = sc_top_id + , abe_mono = sc_ev_id + , abe_prags = noSpecPrags } + local_ev_binds = TcEvBinds ev_binds_var + bind = AbsBinds { abs_ext = noExtField + , abs_tvs = tyvars + , abs_ev_vars = dfun_evs + , abs_exports = [export] + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] + , abs_binds = emptyBag + , abs_sig = False } + ; return (sc_top_id, L loc bind, sc_implic) } + +------------------- +checkInstConstraints :: TcM result + -> TcM (Implication, EvBindsVar, result) +-- See Note [Typechecking plan for instance declarations] +checkInstConstraints thing_inside + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ + thing_inside + + ; ev_binds_var <- newTcEvBinds + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = InstSkol } + + ; return (implic', ev_binds_var, result) } + +{- +Note [Recursive superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #3731, #4809, #5751, #5913, #6117, #6161, which all +describe somewhat more complicated situations, but ones +encountered in practice. + +See also tests tcrun020, tcrun021, tcrun033, and #11427. + +----- THE PROBLEM -------- +The problem is that it is all too easy to create a class whose +superclass is bottom when it should not be. + +Consider the following (extreme) situation: + class C a => D a where ... + instance D [a] => D [a] where ... (dfunD) + instance C [a] => C [a] where ... (dfunC) +Although this looks wrong (assume D [a] to prove D [a]), it is only a +more extreme case of what happens with recursive dictionaries, and it +can, just about, make sense because the methods do some work before +recursing. + +To implement the dfunD we must generate code for the superclass C [a], +which we had better not get by superclass selection from the supplied +argument: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (scsel d) .. + +Otherwise if we later encounter a situation where +we have a [Wanted] dw::D [a] we might solve it thus: + dw := dfunD dw +Which is all fine except that now ** the superclass C is bottom **! + +The instance we want is: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... + +----- THE SOLUTION -------- +The basic solution is simple: be very careful about using superclass +selection to generate a superclass witness in a dictionary function +definition. More precisely: + + Superclass Invariant: in every class dictionary, + every superclass dictionary field + is non-bottom + +To achieve the Superclass Invariant, in a dfun definition we can +generate a guaranteed-non-bottom superclass witness from: + (sc1) one of the dictionary arguments itself (all non-bottom) + (sc2) an immediate superclass of a smaller dictionary + (sc3) a call of a dfun (always returns a dictionary constructor) + +The tricky case is (sc2). We proceed by induction on the size of +the (type of) the dictionary, defined by GHC.Tc.Validity.sizeTypes. +Let's suppose we are building a dictionary of size 3, and +suppose the Superclass Invariant holds of smaller dictionaries. +Then if we have a smaller dictionary, its immediate superclasses +will be non-bottom by induction. + +What does "we have a smaller dictionary" mean? It might be +one of the arguments of the instance, or one of its superclasses. +Here is an example, taken from CmmExpr: + class Ord r => UserOfRegs r a where ... +(i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where +(i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + +For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a), +since it is smaller than the thing we are building (UserOfRegs r (Maybe a). + +But for (i2) that isn't the case, so we must add an explicit, and +perhaps surprising, (Ord r) argument to the instance declaration. + +Here's another example from #6161: + + class Super a => Duper a where ... + class Duper (Fam a) => Foo a where ... +(i3) instance Foo a => Duper (Fam a) where ... +(i4) instance Foo Float where ... + +It would be horribly wrong to define + dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3) + dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ... + + dfFooFloat :: Foo Float -- from (i4) + dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ... + +Now the Super superclass of Duper is definitely bottom! + +This won't happen because when processing (i3) we can use the +superclasses of (Foo a), which is smaller, namely Duper (Fam a). But +that is *not* smaller than the target so we can't take *its* +superclasses. As a result the program is rightly rejected, unless you +add (Super (Fam a)) to the context of (i3). + +Note [Solving superclass constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that every superclass witness is generated by +one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]. +Answer: + + * Superclass "wanted" constraints have CtOrigin of (ScOrigin size) + where 'size' is the size of the instance declaration. e.g. + class C a => D a where... + instance blah => D [a] where ... + The wanted superclass constraint for C [a] has origin + ScOrigin size, where size = size( D [a] ). + + * (sc1) When we rewrite such a wanted constraint, it retains its + origin. But if we apply an instance declaration, we can set the + origin to (ScOrigin infinity), thus lifting any restrictions by + making prohibitedSuperClassSolve return False. + + * (sc2) ScOrigin wanted constraints can't be solved from a + superclass selection, except at a smaller type. This test is + implemented by GHC.Tc.Solver.Interact.prohibitedSuperClassSolve + + * The "given" constraints of an instance decl have CtOrigin + GivenOrigin InstSkol. + + * When we make a superclass selection from InstSkol we use + a SkolemInfo of (InstSC size), where 'size' is the size of + the constraint whose superclass we are taking. A similarly + when taking the superclass of an InstSC. This is implemented + in GHC.Tc.Solver.Canonical.newSCWorkFromFlavored + +Note [Silent superclass arguments] (historical interest only) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB1: this note describes our *old* solution to the + recursive-superclass problem. I'm keeping the Note + for now, just as institutional memory. + However, the code for silent superclass arguments + was removed in late Dec 2014 + +NB2: the silent-superclass solution introduced new problems + of its own, in the form of instance overlap. Tests + SilentParametersOverlapping, T5051, and T7862 are examples + +NB3: the silent-superclass solution also generated tons of + extra dictionaries. For example, in monad-transformer + code, when constructing a Monad dictionary you had to pass + an Applicative dictionary; and to construct that you need + a Functor dictionary. Yet these extra dictionaries were + often never used. Test T3064 compiled *far* faster after + silent superclasses were eliminated. + +Our solution to this problem "silent superclass arguments". We pass +to each dfun some ``silent superclass arguments’’, which are the +immediate superclasses of the dictionary we are trying to +construct. In our example: + dfun :: forall a. C [a] -> D [a] -> D [a] + dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... +Notice the extra (dc :: C [a]) argument compared to the previous version. + +This gives us: + + ----------------------------------------------------------- + DFun Superclass Invariant + ~~~~~~~~~~~~~~~~~~~~~~~~ + In the body of a DFun, every superclass argument to the + returned dictionary is + either * one of the arguments of the DFun, + or * constant, bound at top level + ----------------------------------------------------------- + +This net effect is that it is safe to treat a dfun application as +wrapping a dictionary constructor around its arguments (in particular, +a dfun never picks superclasses from the arguments under the +dictionary constructor). No superclass is hidden inside a dfun +application. + +The extra arguments required to satisfy the DFun Superclass Invariant +always come first, and are called the "silent" arguments. You can +find out how many silent arguments there are using Id.dfunNSilent; +and then you can just drop that number of arguments to see the ones +that were in the original instance declaration. + +DFun types are built (only) by MkId.mkDictFunId, so that is where we +decide what silent arguments are to be added. +-} + +{- +************************************************************************ +* * + Type-checking an instance method +* * +************************************************************************ + +tcMethod +- Make the method bindings, as a [(NonRec, HsBinds)], one per method +- Remembering to use fresh Name (the instance method Name) as the binder +- Bring the instance method Ids into scope, for the benefit of tcInstSig +- Use sig_fn mapping instance method Name -> instance tyvars +- Ditto prag_fn +- Use tcValBinds to do the checking +-} + +tcMethods :: DFunId -> Class + -> [TcTyVar] -> [EvVar] + -> [TcType] + -> TcEvBinds + -> ([Located TcSpecPrag], TcPragEnv) + -> [ClassOpItem] + -> InstBindings GhcRn + -> TcM ([Id], LHsBinds GhcTc, Bag Implication) + -- The returned inst_meth_ids all have types starting + -- forall tvs. theta => ... +tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds (spec_inst_prags, prag_fn) op_items + (InstBindings { ib_binds = binds + , ib_tyvars = lexical_tvs + , ib_pragmas = sigs + , ib_extensions = exts + , ib_derived = is_derived }) + = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $ + -- The lexical_tvs scope over the 'where' part + do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + ; checkMinimalDefinition + ; checkMethBindMembership + ; (ids, binds, mb_implics) <- set_exts exts $ + unset_warnings_deriving $ + mapAndUnzip3M tc_item op_items + ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } + where + set_exts :: [LangExt.Extension] -> TcM a -> TcM a + set_exts es thing = foldr setXOptM thing es + + -- See Note [Avoid -Winaccessible-code when deriving] + unset_warnings_deriving :: TcM a -> TcM a + unset_warnings_deriving + | is_derived = unsetWOptM Opt_WarnInaccessibleCode + | otherwise = id + + hs_sig_fn = mkHsSigFun sigs + inst_loc = getSrcSpan dfun_id + + ---------------------- + tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) + tc_item (sel_id, dm_info) + | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn + = tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived hs_sig_fn + spec_inst_prags prags + sel_id user_bind bndr_loc + | otherwise + = do { traceTc "tc_def" (ppr sel_id) + ; tc_default sel_id dm_info } + + ---------------------- + tc_default :: Id -> DefMethInfo + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) + + tc_default sel_id (Just (dm_name, _)) + = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas sel_id dm_name + ; tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived hs_sig_fn + spec_inst_prags inline_prags + sel_id meth_bind inst_loc } + + tc_default sel_id Nothing -- No default method at all + = do { traceTc "tc_def: warn" (ppr sel_id) + ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + ; dflags <- getDynFlags + ; let meth_bind = mkVarBind meth_id $ + mkLHsWrap lam_wrapper (error_rhs dflags) + ; return (meth_id, meth_bind, Nothing) } + where + error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) + error_fun = L inst_loc $ + wrapId (mkWpTyApps + [ getRuntimeRep meth_tau, meth_tau]) + nO_METHOD_BINDING_ERROR_ID + error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText + (unsafeMkByteString (error_string dflags)))) + meth_tau = classMethodInstTy sel_id inst_tys + error_string dflags = showSDoc dflags + (hcat [ppr inst_loc, vbar, ppr sel_id ]) + lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars + + ---------------------- + -- Check if one of the minimal complete definitions is satisfied + checkMinimalDefinition + = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ + warnUnsatisfiedMinimalDefinition + + methodExists meth = isJust (findMethodBind meth binds prag_fn) + + ---------------------- + -- Check if any method bindings do not correspond to the class. + -- See Note [Mismatched class methods and associated type families]. + checkMethBindMembership + = mapM_ (addErrTc . badMethodErr clas) mismatched_meths + where + bind_nms = map unLoc $ collectMethodBinders binds + cls_meth_nms = map (idName . fst) op_items + mismatched_meths = bind_nms `minusList` cls_meth_nms + +{- +Note [Mismatched class methods and associated type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's entirely possible for someone to put methods or associated type family +instances inside of a class in which it doesn't belong. For instance, we'd +want to fail if someone wrote this: + + instance Eq () where + type Rep () = Maybe + compare = undefined + +Since neither the type family `Rep` nor the method `compare` belong to the +class `Eq`. Normally, this is caught in the renamer when resolving RdrNames, +since that would discover that the parent class `Eq` is incorrect. + +However, there is a scenario in which the renamer could fail to catch this: +if the instance was generated through Template Haskell, as in #12387. In that +case, Template Haskell will provide fully resolved names (e.g., +`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going +on. For this reason, we also put an extra validity check for this in the +typechecker as a last resort. + +Note [Avoid -Winaccessible-code when deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Winaccessible-code can be particularly noisy when deriving instances for +GADTs. Consider the following example (adapted from #8128): + + data T a where + MkT1 :: Int -> T Int + MkT2 :: T Bool + MkT3 :: T Bool + deriving instance Eq (T a) + deriving instance Ord (T a) + +In the derived Ord instance, GHC will generate the following code: + + instance Ord (T a) where + compare x y + = case x of + MkT2 + -> case y of + MkT1 {} -> GT + MkT2 -> EQ + _ -> LT + ... + +However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2 +differ, so if -Winaccessible-code is enabled, then deriving this instance will +result in unwelcome warnings. + +One conceivable approach to fixing this issue would be to change `deriving Ord` +such that it becomes smarter about not generating unreachable cases. This, +however, would be a highly nontrivial refactor, as we'd have to propagate +through typing information everywhere in the algorithm that generates Ord +instances in order to determine which cases were unreachable. This seems like +a lot of work for minimal gain, so we have opted not to go for this approach. + +Instead, we take the much simpler approach of always disabling +-Winaccessible-code for derived code. To accomplish this, we do the following: + +1. In tcMethods (which typechecks method bindings), disable + -Winaccessible-code. +2. When creating Implications during typechecking, record this flag + (in ic_warn_inaccessible) at the time of creation. +3. After typechecking comes error reporting, where GHC must decide how to + report inaccessible code to the user, on an Implication-by-Implication + basis. If an Implication's DynFlags indicate that -Winaccessible-code was + disabled, then don't bother reporting it. That's it! +-} + +------------------------ +tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] + -> TcEvBinds -> Bool + -> HsSigFun + -> [LTcSpecPrag] -> [LSig GhcRn] + -> Id -> LHsBind GhcRn -> SrcSpan + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) +tcMethodBody clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived + sig_fn spec_inst_prags prags + sel_id (L bind_loc meth_bind) bndr_loc + = add_meth_ctxt $ + do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) + ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ + mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + + ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + + -- taking instance signature into account might change the type of + -- the local_meth_id + ; (meth_implic, ev_binds_var, tc_bind) + <- checkInstConstraints $ + tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) + + ; global_meth_id <- addInlinePrags global_meth_id prags + ; spec_prags <- tcSpecPrags global_meth_id prags + + ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags + export = ABE { abe_ext = noExtField + , abe_poly = global_meth_id + , abe_mono = local_meth_id + , abe_wrap = idHsWrapper + , abe_prags = specs } + + local_ev_binds = TcEvBinds ev_binds_var + full_bind = AbsBinds { abs_ext = noExtField + , abs_tvs = tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = [dfun_ev_binds, local_ev_binds] + , abs_binds = tc_bind + , abs_sig = True } + + ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } + where + -- For instance decls that come from deriving clauses + -- we want to print out the full source code if there's an error + -- because otherwise the user won't see the code at all + add_meth_ctxt thing + | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing + | otherwise = thing + +tcMethodBodyHelp :: HsSigFun -> Id -> TcId + -> LHsBind GhcRn -> TcM (LHsBinds GhcTc) +tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind + | Just hs_sig_ty <- hs_sig_fn sel_name + -- There is a signature in the instance + -- See Note [Instance method signatures] + = do { (sig_ty, hs_wrap) + <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $ + do { inst_sigs <- xoptM LangExt.InstanceSigs + ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) + ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty + ; let local_meth_ty = idType local_meth_id + ctxt = FunSigCtxt sel_name False + -- False <=> do not report redundant constraints when + -- checking instance-sig <= class-meth-sig + -- The instance-sig is the focus here; the class-meth-sig + -- is fixed (#18036) + ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ + tcSubTypeSigma ctxt sig_ty local_meth_ty + ; return (sig_ty, hs_wrap) } + + ; inner_meth_name <- newName (nameOccName sel_name) + ; let ctxt = FunSigCtxt sel_name True + -- True <=> check for redundant constraints in the + -- user-specified instance signature + inner_meth_id = mkLocalId inner_meth_name Many sig_ty + inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id + , sig_ctxt = ctxt + , sig_loc = getLoc (hsSigType hs_sig_ty) } + + + ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind + + ; let export = ABE { abe_ext = noExtField + , abe_poly = local_meth_id + , abe_mono = inner_id + , abe_wrap = hs_wrap + , abe_prags = noSpecPrags } + + ; return (unitBag $ L (getLoc meth_bind) $ + AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = [] + , abs_exports = [export] + , abs_binds = tc_bind, abs_ev_binds = [] + , abs_sig = True }) } + + | otherwise -- No instance signature + = do { let ctxt = FunSigCtxt sel_name False + -- False <=> don't report redundant constraints + -- The signature is not under the users control! + tc_sig = completeSigFromId ctxt local_meth_id + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = } + -- In , 'c' is scope but 'b' is not! + + ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind + ; return tc_bind } + + where + sel_name = idName sel_id + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; + -- they are all for meth_id + + +------------------------ +mkMethIds :: Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcId) + -- returns (poly_id, local_id), but ignoring any instance signature + -- See Note [Instance method signatures] +mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id + = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) + ; local_meth_name <- newName sel_occ + -- Base the local_meth_name on the selector name, because + -- type errors from tcMethodBody come from here + ; let poly_meth_id = mkLocalId poly_meth_name Many poly_meth_ty + local_meth_id = mkLocalId local_meth_name Many local_meth_ty + + ; return (poly_meth_id, local_meth_id) } + where + sel_name = idName sel_id + -- Force so that a thunk doesn't end up in a Name (#19619) + !sel_occ = nameOccName sel_name + local_meth_ty = instantiateMethod clas sel_id inst_tys + poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty + theta = map idType dfun_ev_vars + +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) +methSigCtxt sel_name sig_ty meth_ty env0 + = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty + ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty + ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) + 2 (vcat [ text "is more general than its signature in the class" + , text "Instance sig:" <+> ppr sig_ty + , text " Class sig:" <+> ppr meth_ty ]) + ; return (env2, msg) } + +misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc +misplacedInstSig name hs_ty + = vcat [ hang (text "Illegal type signature in instance declaration:") + 2 (hang (pprPrefixName name) + 2 (dcolon <+> ppr hs_ty)) + , text "(Use InstanceSigs to allow this)" ] + +{- Note [Instance method signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XInstanceSigs we allow the user to supply a signature for the +method in an instance declaration. Here is an artificial example: + + data T a = MkT a + instance Ord a => Ord (T a) where + (>) :: forall b. b -> b -> Bool + (>) = error "You can't compare Ts" + +The instance signature can be *more* polymorphic than the instantiated +class method (in this case: Age -> Age -> Bool), but it cannot be less +polymorphic. Moreover, if a signature is given, the implementation +code should match the signature, and type variables bound in the +singature should scope over the method body. + +We achieve this by building a TcSigInfo for the method, whether or not +there is an instance method signature, and using that to typecheck +the declaration (in tcMethodBody). That means, conveniently, +that the type variables bound in the signature will scope over the body. + +What about the check that the instance method signature is more +polymorphic than the instantiated class method type? We just do a +tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like +this (for the example above + + AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a] + , abs_exports + = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool + , gr_lcl :: T a -> T a -> Bool } + , abs_binds + = AbsBind { abs_tvs = [], abs_ev_vars = [] + , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool + , gr_inner :: forall b. b -> b -> Bool } + , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = [] + , ..etc.. } + } } + +Wow! Three nested AbsBinds! + * The outer one abstracts over the tyvars and dicts for the instance + * The middle one is only present if there is an instance signature, + and does the impedance matching for that signature + * The inner one is for the method binding itself against either the + signature from the class, or the instance signature. +-} + +---------------------- +mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id + -- There are two sources: + -- * spec_prags_for_me: {-# SPECIALISE op :: #-} + -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper. + -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind +mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + where + spec_prags_from_inst + | isInlinePragma (idInlinePragma meth_id) + = [] -- Do not inherit SPECIALISE from the instance if the + -- method is marked INLINE, because then it'll be inlined + -- and the specialisation would do nothing. (Indeed it'll provoke + -- a warning from the desugarer + | otherwise + = [ L inst_loc (SpecPrag meth_id wrap inl) + | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] + + +mkDefMethBind :: DFunId -> Class -> Id -> Name + -> TcM (LHsBind GhcRn, [LSig GhcRn]) +-- The is a default method (vanailla or generic) defined in the class +-- So make a binding op = $dmop @t1 @t2 +-- where $dmop is the name of the default method in the class, +-- and t1,t2 are the instance types. +-- See Note [Default methods in instances] for why we use +-- visible type application here +mkDefMethBind dfun_id clas sel_id dm_name + = do { dflags <- getDynFlags + ; dm_id <- tcLookupId dm_name + ; let inline_prag = idInlinePragma dm_id + inline_prags | isAnyInlinePragma inline_prag + = [noLoc (InlineSig noExtField fn inline_prag)] + | otherwise + = [] + -- Copy the inline pragma (if any) from the default method + -- to this version. Note [INLINE and default methods] + + fn = noLoc (idName sel_id) + visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys + , tyConBinderArgFlag tcb /= Inferred ] + rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys + bind = noLoc $ mkTopFunBind Generated fn $ + [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] + + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" + FormatHaskell + (vcat [ppr clas <+> ppr inst_tys, + nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) + + ; return (bind, inline_prags) } + where + (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id) + + mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn + mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy + $ noLoc $ XHsType $ NHsCoreTy ty)) + -- NB: use visible type application + -- See Note [Default methods in instances] + +---------------------- +derivBindCtxt :: Id -> Class -> [Type ] -> SDoc +derivBindCtxt sel_id clas tys + = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) + , nest 2 (text "in a derived instance for" + <+> quotes (pprClassPred clas tys) <> colon) + , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] + +warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () +warnUnsatisfiedMinimalDefinition mindef + = do { warn <- woptM Opt_WarnMissingMethods + ; warnTc (Reason Opt_WarnMissingMethods) warn message + } + where + message = vcat [text "No explicit implementation for" + ,nest 2 $ pprBooleanFormulaNice mindef + ] + +{- +Note [Export helper functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange to export the "helper functions" of an instance declaration, +so that they are not subject to preInlineUnconditionally, even if their +RHS is trivial. Reason: they are mentioned in the DFunUnfolding of +the dict fun as Ids, not as CoreExprs, so we can't substitute a +non-variable for them. + +We could change this by making DFunUnfoldings have CoreExprs, but it +seems a bit simpler this way. + +Note [Default methods in instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + + class Baz v x where + foo :: x -> x + foo y = + + instance Baz Int Int + +From the class decl we get + + $dmfoo :: forall v x. Baz v x => x -> x + $dmfoo y = + +Notice that the type is ambiguous. So we use Visible Type Application +to disambiguate: + + $dBazIntInt = MkBaz fooIntInt + fooIntInt = $dmfoo @Int @Int + +Lacking VTA we'd get ambiguity errors involving the default method. This applies +equally to vanilla default methods (#1061) and generic default methods +(#12220). + +Historical note: before we had VTA we had to generate +post-type-checked code, which took a lot more code, and didn't work for +generic default methods. + +Note [INLINE and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Default methods need special case. They are supposed to behave rather like +macros. For example + + class Foo a where + op1, op2 :: Bool -> a -> a + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + + instance Foo Int where + -- op1 via default method + op2 b x = + +The instance declaration should behave + + just as if 'op1' had been defined with the + code, and INLINE pragma, from its original + definition. + +That is, just as if you'd written + + instance Foo Int where + op2 b x = + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + +So for the above example we generate: + + {-# INLINE $dmop1 #-} + -- $dmop1 has an InlineCompulsory unfolding + $dmop1 d b x = op2 d (not b) x + + $fFooInt = MkD $cop1 $cop2 + + {-# INLINE $cop1 #-} + $cop1 = $dmop1 $fFooInt + + $cop2 = + +Note carefully: + +* We *copy* any INLINE pragma from the default method $dmop1 to the + instance $cop1. Otherwise we'll just inline the former in the + latter and stop, which isn't what the user expected + +* Regardless of its pragma, we give the default method an + unfolding with an InlineCompulsory source. That means + that it'll be inlined at every use site, notably in + each instance declaration, such as $cop1. This inlining + must happen even though + a) $dmop1 is not saturated in $cop1 + b) $cop1 itself has an INLINE pragma + + It's vital that $dmop1 *is* inlined in this way, to allow the mutual + recursion between $fooInt and $cop1 to be broken + +* To communicate the need for an InlineCompulsory to the desugarer + (which makes the Unfoldings), we use the IsDefaultMethod constructor + in TcSpecPrags. + + +************************************************************************ +* * + Specialise instance pragmas +* * +************************************************************************ + +Note [SPECIALISE instance pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance (Ix a, Ix b) => Ix (a,b) where + {-# SPECIALISE instance Ix (Int,Int) #-} + range (x,y) = ... + +We make a specialised version of the dictionary function, AND +specialised versions of each *method*. Thus we should generate +something like this: + + $dfIxPair :: (Ix a, Ix b) => Ix (a,b) + {-# DFUN [$crangePair, ...] #-} + {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} + $dfIxPair da db = Ix ($crangePair da db) (...other methods...) + + $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] + {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} + $crange da db = + +The SPECIALISE pragmas are acted upon by the desugarer, which generate + + dii :: Ix Int + dii = ... + + $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) + {-# DFUN [$crangePair di di, ...] #-} + $s$dfIxPair = Ix ($crangePair di di) (...) + + {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} + + $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] + $c$crangePair = ...specialised RHS of $crangePair... + + {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} + +Note that + + * The specialised dictionary $s$dfIxPair is very much needed, in case we + call a function that takes a dictionary, but in a context where the + specialised dictionary can be used. See #7797. + + * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because + it still has a DFunUnfolding. See Note [ClassOp/DFun selection] + + * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: + --> {ClassOp rule for range} $crangePair Int Int d1 d2 + --> {SPEC rule for $crangePair} $s$crangePair + or thus: + --> {SPEC rule for $dfIxPair} range $s$dfIxPair + --> {ClassOpRule for range} $s$crangePair + It doesn't matter which way. + + * We want to specialise the RHS of both $dfIxPair and $crangePair, + but the SAME HsWrapper will do for both! We can call tcSpecPrag + just once, and pass the result (in spec_inst_info) to tcMethods. +-} + +tcSpecInstPrags :: DFunId -> InstBindings GhcRn + -> TcM ([Located TcSpecPrag], TcPragEnv) +tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ + filter isSpecInstLSig uprags + -- The filter removes the pragmas for methods + ; return (spec_inst_prags, mkPragEnv uprags binds) } + +------------------------------ +tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag +tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) + = addErrCtxt (spec_ctxt prag) $ + do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty + ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } + where + spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) + +tcSpecInst _ _ = panic "tcSpecInst" + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + +instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 dfun_ty + = inst_decl_ctxt (ppr (mkClassPred cls tys)) + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +inst_decl_ctxt :: SDoc -> SDoc +inst_decl_ctxt doc = hang (text "In the instance declaration for") + 2 (quotes doc) + +badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr + = text "Illegal family instance in hs-boot file" + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] + +assocInClassErr :: TyCon -> SDoc +assocInClassErr name + = text "Associated type" <+> quotes (ppr name) <+> + text "must be inside a class instance" + +badFamInstDecl :: TyCon -> SDoc +badFamInstDecl tc_name + = vcat [ text "Illegal family instance for" <+> + quotes (ppr tc_name) + , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] + +notOpenFamily :: TyCon -> SDoc +notOpenFamily tc + = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/GHC/Tc/TyCl/Instance.hs-boot b/GHC/Tc/TyCl/Instance.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Instance.hs-boot @@ -0,0 +1,16 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.TyCl.Instance ( tcInstDecls1 ) where + +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Env( InstInfo ) +import GHC.Tc.Deriv + +-- We need this because of the mutual recursion +-- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance +tcInstDecls1 :: [LInstDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) diff --git a/GHC/Tc/TyCl/PatSyn.hs b/GHC/Tc/TyCl/PatSyn.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/PatSyn.hs @@ -0,0 +1,1147 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking pattern synonym declarations +module GHC.Tc.TyCl.PatSyn + ( tcPatSynDecl + , tcPatSynBuilderBind + , tcPatSynBuilderOcc + , nonBidirectionalErr + ) +where + +import GHC.Prelude + +import GHC.Hs +import GHC.Tc.Gen.Pat +import GHC.Core.Multiplicity +import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Zonk +import GHC.Builtin.Types.Prim +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Core.PatSyn +import GHC.Types.Name.Set +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Var +import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) +import GHC.Types.Id +import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType ) +import GHC.Tc.Gen.Bind +import GHC.Types.Basic +import GHC.Tc.Solver +import GHC.Tc.Utils.Unify +import GHC.Core.Predicate +import GHC.Builtin.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build +import GHC.Types.Var.Set +import GHC.Types.Id.Make +import GHC.Tc.TyCl.Utils +import GHC.Core.ConLike +import GHC.Types.FieldLabel +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Driver.Session ( getDynFlags ) +import Data.Maybe( mapMaybe ) +import Control.Monad ( zipWithM ) +import Data.List( partition ) + +#include "HsVersions.h" + +{- +************************************************************************ +* * + Type checking a pattern synonym +* * +************************************************************************ +-} + +tcPatSynDecl :: PatSynBind GhcRn GhcRn + -> Maybe TcSigInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcPatSynDecl psb mb_sig + = recoverM (recoverPSB psb) $ + case mb_sig of + Nothing -> tcInferPatSynDecl psb + Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi + _ -> panic "tcPatSynDecl" + +recoverPSB :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc, TcGblEnv) +-- See Note [Pattern synonym error recovery] +recoverPSB (PSB { psb_id = L _ name + , psb_args = details }) + = do { matcher_name <- newImplicitBinder name mkMatcherOcc + ; let placeholder = AConLike $ PatSynCon $ + mk_placeholder matcher_name + ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv + ; return (emptyBag, gbl_env) } + where + (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details + mk_placeholder matcher_name + = mkPatSyn name is_infix + ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) + [] -- Arg tys + alphaTy + (matcher_id, True) Nothing + [] -- Field labels + where + -- The matcher_id is used only by the desugarer, so actually + -- and error-thunk would probably do just as well here. + matcher_id = mkLocalId matcher_name Many $ + mkSpecForAllTys [alphaTyVar] alphaTy + +{- Note [Pattern synonym error recovery] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If type inference for a pattern synonym fails, we can't continue with +the rest of tc_patsyn_finish, because we may get knock-on errors, or +even a crash. E.g. from + pattern What = True :: Maybe +we get a kind error; and we must stop right away (#15289). + +We stop if there are /any/ unsolved constraints, not just insoluble +ones; because pattern synonyms are top-level things, we will never +solve them later if we can't solve them now. And if we were to carry +on, tc_patsyn_finish does zonkTcTypeToType, which defaults any +unsolved unificatdion variables to Any, which confuses the error +reporting no end (#15685). + +So we use simplifyTop to completely solve the constraint, report +any errors, throw an exception. + +Even in the event of such an error we can recover and carry on, just +as we do for value bindings, provided we plug in placeholder for the +pattern synonym: see recoverPSB. The goal of the placeholder is not +to cause a raft of follow-on errors. I've used the simplest thing for +now, but we might need to elaborate it a bit later. (e.g. I've given +it zero args, which may cause knock-on errors if it is used in a +pattern.) But it'll do for now. + +-} + +tcInferPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details + , psb_def = lpat, psb_dir = dir }) + = addPatSynCtxt lname $ + do { traceTc "tcInferPatSynDecl {" $ ppr name + + ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details + ; (tclvl, wanted, ((lpat', args), pat_ty)) + <- pushLevelAndCaptureConstraints $ + tcInferPat PatSyn lpat $ + mapM tcLookupId arg_names + + ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' + + named_taus = (name, pat_ty) : map mk_named_tau args + mk_named_tau arg + = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) + -- The mkSpecForAllTys is important (#14552), albeit + -- slightly artificial (there is no variable with this funny type). + -- We do not want to quantify over variable (alpha::k) + -- that mention the existentially-bound type variables + -- ex_tvs in its kind k. + -- See Note [Type variables whose kind is captured] + + ; (univ_tvs, req_dicts, ev_binds, residual, _) + <- simplifyInfer tclvl NoRestrictions [] named_taus wanted + ; top_ev_binds <- checkNoErrs (simplifyTop residual) + ; addTopEvBinds top_ev_binds $ + + do { prov_dicts <- mapM zonkId prov_dicts + ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts + -- Filtering: see Note [Remove redundant provided dicts] + (prov_theta, prov_evs) + = unzip (mapMaybe mkProvEvidence filtered_prov_dicts) + req_theta = map evVarPred req_dicts + + -- Report coercions that escape + -- See Note [Coercions that escape] + ; args <- mapM zonkId args + ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts + , let bad_cos = filterDVarSet isId $ + (tyCoVarsOfTypeDSet (idType arg)) + , not (isEmptyDVarSet bad_cos) ] + ; mapM_ dependentArgErr bad_args + + ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) + ; tc_patsyn_finish lname dir is_infix lpat' + (mkTyVarBinders InferredSpec univ_tvs + , req_theta, ev_binds, req_dicts) + (mkTyVarBinders InferredSpec ex_tvs + , mkTyVarTys ex_tvs, prov_theta, prov_evs) + (map nlHsVar args, map idType args) + pat_ty rec_fields } } + +mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) +-- See Note [Equality evidence in pattern synonyms] +mkProvEvidence ev_id + | EqPred r ty1 ty2 <- classifyPredType pred + , let k1 = tcTypeKind ty1 + k2 = tcTypeKind ty2 + is_homo = k1 `tcEqType` k2 + homo_tys = [k1, ty1, ty2] + hetero_tys = [k1, k2, ty1, ty2] + = case r of + ReprEq | is_homo + -> Just ( mkClassPred coercibleClass homo_tys + , evDataConApp coercibleDataCon homo_tys eq_con_args ) + | otherwise -> Nothing + NomEq | is_homo + -> Just ( mkClassPred eqClass homo_tys + , evDataConApp eqDataCon homo_tys eq_con_args ) + | otherwise + -> Just ( mkClassPred heqClass hetero_tys + , evDataConApp heqDataCon hetero_tys eq_con_args ) + + | otherwise + = Just (pred, EvExpr (evId ev_id)) + where + pred = evVarPred ev_id + eq_con_args = [evId ev_id] + +dependentArgErr :: (Id, DTyCoVarSet) -> TcM () +-- See Note [Coercions that escape] +dependentArgErr (arg, bad_cos) + = addErrTc $ + vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" + , hang (text "Pattern-bound variable") + 2 (ppr arg <+> dcolon <+> ppr (idType arg)) + , nest 2 $ + hang (text "has a type that mentions pattern-bound coercion" + <> plural bad_co_list <> colon) + 2 (pprWithCommas ppr bad_co_list) + , text "Hint: use -fprint-explicit-coercions to see the coercions" + , text "Probable fix: add a pattern signature" ] + where + bad_co_list = dVarSetElems bad_cos + +{- Note [Type variables whose kind is captured] +~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data AST a = Sym [a] + class Prj s where { prj :: [a] -> Maybe (s a) } + pattern P x <= Sym (prj -> Just x) + +Here we get a matcher with this type + $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r + +No problem. But note that 's' is not fixed by the type of the +pattern (AST a), nor is it existentially bound. It's really only +fixed by the type of the continuation. + +#14552 showed that this can go wrong if the kind of 's' mentions +existentially bound variables. We obviously can't make a type like + $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r) + -> r -> r +But neither is 's' itself existentially bound, so the forall (s::k->*) +can't go in the inner forall either. (What would the matcher apply +the continuation to?) + +Solution: do not quantiify over any unification variable whose kind +mentions the existentials. We can conveniently do that by making the +"taus" passed to simplifyInfer look like + forall ex_tvs. arg_ty + +After that, Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType takes +over and errors. + +Note [Remove redundant provided dicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that + HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2) + => a1 :~~: a2 +(NB: technically the (k1~k2) existential dictionary is not necessary, +but it's there at the moment.) + +Now consider (#14394): + pattern Foo = HRefl +in a non-poly-kinded module. We don't want to get + pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b +with that redundant (* ~ *). We'd like to remove it; hence the call to +mkMinimalWithSCs. + +Similarly consider + data S a where { MkS :: Ord a => a -> S a } + pattern Bam x y <- (MkS (x::a), MkS (y::a))) + +The pattern (Bam x y) binds two (Ord a) dictionaries, but we only +need one. Again mkMimimalWithSCs removes the redundant one. + +Note [Equality evidence in pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data X a where + MkX :: Eq a => [a] -> X (Maybe a) + pattern P x = MkG x + +Then there is a danger that GHC will infer + P :: forall a. () => + forall b. (a ~# Maybe b, Eq b) => [b] -> X a + +The 'builder' for P, which is called in user-code, will then +have type + $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a + +and that is bad because (a ~# Maybe b) is not a predicate type +(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +and is not implicitly instantiated. + +So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and +marginally less efficient, if the builder/martcher are not inlined. + +See also Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType + +Note [Coercions that escape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#14507 showed an example where the inferred type of the matcher +for the pattern synonym was something like + $mSO :: forall (r :: TYPE rep) kk (a :: k). + TypeRep k a + -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r) + -> (Void# -> r) + -> r + +What is that co_a2sv :: Bool ~# *?? It was bound (via a superclass +selection) by the pattern being matched; and indeed it is implicit in +the context (Bool ~ k). You could imagine trying to extract it like +this: + $mSO :: forall (r :: TYPE rep) kk (a :: k). + TypeRep k a + -> ( co :: ((Bool :: *) ~ (k :: *)) => + let co_a2sv = sc_sel co + in TypeRep Bool (a |> co_a2sv) -> r) + -> (Void# -> r) + -> r + +But we simply don't allow that in types. Maybe one day but not now. + +How to detect this situation? We just look for free coercion variables +in the types of any of the arguments to the matcher. The error message +is not very helpful, but at least we don't get a Lint error. +-} + +tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcPatSynInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details + , psb_def = lpat, psb_dir = dir } + TPSI{ patsig_implicit_bndrs = implicit_bndrs + , patsig_univ_bndrs = explicit_univ_bndrs, patsig_prov = prov_theta + , patsig_ex_bndrs = explicit_ex_bndrs, patsig_req = req_theta + , patsig_body_ty = sig_body_ty } + = addPatSynCtxt lname $ + do { let decl_arity = length arg_names + (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details + + ; traceTc "tcCheckPatSynDecl" $ + vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta + , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] + + ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of + Right stuff -> return stuff + Left missing -> wrongNumberOfParmsErr name decl_arity missing + + -- Complain about: pattern P :: () => forall x. x -> P x + -- The existential 'x' should not appear in the result type + -- Can't check this until we know P's arity + ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs + ; checkTc (null bad_tvs) $ + hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma + , text "namely" <+> quotes (ppr pat_ty) ]) + 2 (text "mentions existential type variable" <> plural bad_tvs + <+> pprQuotedList bad_tvs) + + -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig + ; let univ_fvs = closeOverKinds $ + (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` (binderVars explicit_univ_bndrs)) + (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_bndrs + univ_bndrs = extra_univ ++ explicit_univ_bndrs + ex_bndrs = extra_ex ++ explicit_ex_bndrs + univ_tvs = binderVars univ_bndrs + ex_tvs = binderVars ex_bndrs + + -- Right! Let's check the pattern against the signature + -- See Note [Checking against a pattern signature] + ; req_dicts <- newEvVars req_theta + ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- + ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) + pushLevelAndCaptureConstraints $ + tcExtendTyVarEnv univ_tvs $ + tcCheckPat PatSyn lpat (unrestricted pat_ty) $ + do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) + empty_subst = mkEmptyTCvSubst in_scope + ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs + -- newMetaTyVarX: see the "Existential type variables" + -- part of Note [Checking against a pattern signature] + ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) + ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) + ; let prov_theta' = substTheta subst prov_theta + -- Add univ_tvs to the in_scope set to + -- satisfy the substitution invariant. There's no need to + -- add 'ex_tvs' as they are already in the domain of the + -- substitution. + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' + ; args' <- zipWithM (tc_arg subst) arg_names (map scaledThing arg_tys) + ; return (ex_tvs', prov_dicts, args') } + + ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] + -- The type here is a bit bogus, but we do not print + -- the type for PatSynCtxt, so it doesn't matter + -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin" + ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted + + -- Solve the constraints now, because we are about to make a PatSyn, + -- which should not contain unification variables and the like (#10997) + ; simplifyTopImplic implics + + -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct + -- Otherwise we may get a type error when typechecking the builder, + -- when that should be impossible + + ; traceTc "tcCheckPatSynDecl }" $ ppr name + ; tc_patsyn_finish lname dir is_infix lpat' + (univ_bndrs, req_theta, ev_binds, req_dicts) + (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) + (args', (map scaledThing arg_tys)) + pat_ty rec_fields } + where + tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc) + tc_arg subst arg_name arg_ty + = do { -- Look up the variable actually bound by lpat + -- and check that it has the expected type + arg_id <- tcLookupId arg_name + ; wrap <- tcSubTypeSigma GenSigCtxt + (idType arg_id) + (substTyUnchecked subst arg_ty) + -- Why do we need tcSubType here? + -- See Note [Pattern synonyms and higher rank types] + ; return (mkLHsWrap wrap $ nlHsVar arg_id) } + +{- [Pattern synonyms and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT (forall a. a->a) + + pattern P :: (Int -> Int) -> T + pattern P x <- MkT x + +This should work. But in the matcher we must match against MkT, and then +instantiate its argument 'x', to get a function of type (Int -> Int). +Equality is not enough! #13752 was an example. + + +Note [The pattern-synonym signature splitting rule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a pattern signature, we must split + the kind-generalised variables, and + the implicitly-bound variables +into universal and existential. The rule is this +(see discussion on #11224): + + The universal tyvars are the ones mentioned in + - univ_tvs: the user-specified (forall'd) universals + - req_theta + - res_ty + The existential tyvars are all the rest + +For example + + pattern P :: () => b -> T a + pattern P x = ... + +Here 'a' is universal, and 'b' is existential. But there is a wrinkle: +how do we split the arg_tys from req_ty? Consider + + pattern Q :: () => b -> S c -> T a + pattern Q x = ... + +This is an odd example because Q has only one syntactic argument, and +so presumably is defined by a view pattern matching a function. But +it can happen (#11977, #12108). + +We don't know Q's arity from the pattern signature, so we have to wait +until we see the pattern declaration itself before deciding res_ty is, +and hence which variables are existential and which are universal. + +And that in turn is why TcPatSynInfo has a separate field, +patsig_implicit_bndrs, to capture the implicitly bound type variables, +because we don't yet know how to split them up. + +It's a slight compromise, because it means we don't really know the +pattern synonym's real signature until we see its declaration. So, +for example, in hs-boot file, we may need to think what to do... +(eg don't have any implicitly-bound variables). + + +Note [Checking against a pattern signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the actual supplied pattern against the pattern synonym +signature, we need to be quite careful. + +----- Provided constraints +Example + + data T a where + MkT :: Ord a => a -> T a + + pattern P :: () => Eq a => a -> [T a] + pattern P x = [MkT x] + +We must check that the (Eq a) that P claims to bind (and to +make available to matches against P), is derivable from the +actual pattern. For example: + f (P (x::a)) = ...here (Eq a) should be available... +And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs. + +----- Existential type variables +Unusually, we instantiate the existential tyvars of the pattern with +*meta* type variables. For example + + data S where + MkS :: Eq a => [a] -> S + + pattern P :: () => Eq x => x -> S + pattern P x <- MkS x + +The pattern synonym conceals from its client the fact that MkS has a +list inside it. The client just thinks it's a type 'x'. So we must +unify x := [a] during type checking, and then use the instantiating type +[a] (called ex_tys) when building the matcher. In this case we'll get + + $mP :: S -> (forall x. Ex x => x -> r) -> r -> r + $mP x k = case x of + MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a] + dl = $dfunEqList d + in k [a] dl ys + +All this applies when type-checking the /matching/ side of +a pattern synonym. What about the /building/ side? + +* For Unidirectional, there is no builder + +* For ExplicitBidirectional, the builder is completely separate + code, typechecked in tcPatSynBuilderBind + +* For ImplicitBidirectional, the builder is still typechecked in + tcPatSynBuilderBind, by converting the pattern to an expression and + typechecking it. + + At one point, for ImplicitBidirectional I used TyVarTvs (instead of + TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here + is redundant since tcPatSynBuilderBind does the job, (b) it was + still incomplete (TyVarTvs can unify with each other), and (c) it + didn't even work (#13441 was accepted with + ExplicitBidirectional, but rejected if expressed in + ImplicitBidirectional form. Conclusion: trying to be too clever is + a bad idea. +-} + +collectPatSynArgInfo :: HsPatSynDetails (Located Name) + -> ([Name], [Name], Bool) +collectPatSynArgInfo details = + case details of + PrefixCon names -> (map unLoc names, [], False) + InfixCon name1 name2 -> (map unLoc [name1, name2], [], True) + RecCon names -> (vars, sels, False) + where + (vars, sels) = unzip (map splitRecordPatSyn names) + where + splitRecordPatSyn :: RecordPatSynField (Located Name) + -> (Name, Name) + splitRecordPatSyn (RecordPatSynField + { recordPatSynPatVar = L _ patVar + , recordPatSynSelectorId = L _ selId }) + = (patVar, selId) + +addPatSynCtxt :: Located Name -> TcM a -> TcM a +addPatSynCtxt (L loc name) thing_inside + = setSrcSpan loc $ + addErrCtxt (text "In the declaration for pattern synonym" + <+> quotes (ppr name)) $ + thing_inside + +wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a +wrongNumberOfParmsErr name decl_arity missing + = failWithTc $ + hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has") + <+> speakNOf decl_arity (text "argument")) + 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") + +------------------------- +-- Shared by both tcInferPatSyn and tcCheckPatSyn +tc_patsyn_finish :: Located Name -- ^ PatSyn Name + -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) + -> Bool -- ^ Whether infix + -> LPat GhcTc -- ^ Pattern of the PatSyn + -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar]) + -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm]) + -> ([LHsExpr GhcTc], [TcType]) -- ^ Pattern arguments and types + -> TcType -- ^ Pattern type + -> [Name] -- ^ Selector names + -- ^ Whether fields, empty if not record PatSyn + -> TcM (LHsBinds GhcTc, TcGblEnv) +tc_patsyn_finish lname dir is_infix lpat' + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) + pat_ty field_labels + = do { -- Zonk everything. We are about to build a final PatSyn + -- so there had better be no unification variables in there + + (ze, univ_tvs') <- zonkTyVarBinders univ_tvs + ; req_theta' <- zonkTcTypesToTypesX ze req_theta + ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs + ; prov_theta' <- zonkTcTypesToTypesX ze prov_theta + ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty + ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys + + ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyTyCoVarBinders env1 ex_tvs' + req_theta = tidyTypes env2 req_theta' + prov_theta = tidyTypes env2 prov_theta' + arg_tys = tidyTypes env2 arg_tys' + pat_ty = tidyType env2 pat_ty' + + ; traceTc "tc_patsyn_finish {" $ + ppr (unLoc lname) $$ ppr (unLoc lpat') $$ + ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ + ppr (ex_tvs, prov_theta, prov_dicts) $$ + ppr args $$ + ppr arg_tys $$ + ppr pat_ty + + -- Make the 'matcher' + ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' + (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) + (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) + pat_ty + + -- Make the 'builder' + ; builder_id <- mkPatSynBuilderId dir lname + univ_tvs req_theta + ex_tvs prov_theta + arg_tys pat_ty + + -- TODO: Make this have the proper information + ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name) + , flIsOverloaded = False + , flSelector = name } + field_labels' = map mkFieldLabel field_labels + + + -- Make the PatSyn itself + ; let patSyn = mkPatSyn (unLoc lname) is_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + arg_tys + pat_ty + matcher_id builder_id + field_labels' + + -- Selectors + ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) + tything = AConLike (PatSynCon patSyn) + ; tcg_env <- tcExtendGlobalEnv [tything] $ + tcRecSelBinds rn_rec_sel_binds + + ; traceTc "tc_patsyn_finish }" empty + ; return (matcher_bind, tcg_env) } + +{- +************************************************************************ +* * + Constructing the "matcher" Id and its binding +* * +************************************************************************ +-} + +tcPatSynMatcher :: Located Name + -> LPat GhcTc + -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) + -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) + -> ([LHsExpr GhcTc], [TcType]) + -> TcType + -> TcM ((Id, Bool), LHsBinds GhcTc) +-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn +tcPatSynMatcher (L loc name) lpat + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_dicts) + (args, arg_tys) pat_ty + = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc + ; tv_name <- newNameAt (mkTyVarOcc "r") loc + ; let rr_tv = mkTyVar rr_name runtimeRepTy + rr = mkTyVarTy rr_tv + res_tv = mkTyVar tv_name (tYPE rr) + res_ty = mkTyVarTy res_tv + is_unlifted = null args && null prov_dicts + (cont_args, cont_arg_tys) + | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) + | otherwise = (args, arg_tys) + cont_ty = mkInfSigmaTy ex_tvs prov_theta $ + mkVisFunTysMany cont_arg_tys res_ty + + fail_ty = mkVisFunTyMany voidPrimTy res_ty + + ; matcher_name <- newImplicitBinder name mkMatcherOcc + ; scrutinee <- newSysLocalId (fsLit "scrut") Many pat_ty + ; cont <- newSysLocalId (fsLit "cont") Many cont_ty + ; fail <- newSysLocalId (fsLit "fail") Many fail_ty + + ; dflags <- getDynFlags + ; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty + matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau + matcher_id = mkExportedVanillaId matcher_name matcher_sigma + -- See Note [Exported LocalIds] in GHC.Types.Id + + inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys + cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args + + fail' = nlHsApps fail [nlHsVar voidPrimId] + + args = map nlVarPat [scrutinee, cont, fail] + lwpat = noLoc $ WildPat pat_ty + cases = if isIrrefutableHsPat dflags lpat + then [mkHsCaseAlt lpat cont'] + else [mkHsCaseAlt lpat cont', + mkHsCaseAlt lwpat fail'] + body = mkLHsWrap (mkWpLet req_ev_binds) $ + L (getLoc lpat) $ + HsCase noExtField (nlHsVar scrutinee) $ + MG{ mg_alts = L (getLoc lpat) cases + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty + , mg_origin = Generated + } + body' = noLoc $ + HsLam noExtField $ + MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr + args body] + , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty + , mg_origin = Generated + } + match = mkMatch (mkPrefixFunRhs (L loc name)) [] + (mkHsLams (rr_tv:res_tv:univ_tvs) + req_dicts body') + (noLoc (EmptyLocalBinds noExtField)) + mg :: MatchGroup GhcTc (LHsExpr GhcTc) + mg = MG{ mg_alts = L (getLoc match) [match] + , mg_ext = MatchGroupTc [] res_ty + , mg_origin = Generated + } + + ; let bind = FunBind{ fun_id = L loc matcher_id + , fun_matches = mg + , fun_ext = idHsWrapper + , fun_tick = [] } + matcher_bind = unitBag (noLoc bind) + + ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) + ; traceTc "tcPatSynMatcher" (ppr matcher_bind) + + ; return ((matcher_id, is_unlifted), matcher_bind) } + +mkPatSynRecSelBinds :: PatSyn + -> [FieldLabel] -- ^ Visible field labels + -> [(Id, LHsBind GhcRn)] +mkPatSynRecSelBinds ps fields + = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl + | fld_lbl <- fields ] + +isUnidirectional :: HsPatSynDir a -> Bool +isUnidirectional Unidirectional = True +isUnidirectional ImplicitBidirectional = False +isUnidirectional ExplicitBidirectional{} = False + +{- +************************************************************************ +* * + Constructing the "builder" Id +* * +************************************************************************ +-} + +mkPatSynBuilderId :: HsPatSynDir a -> Located Name + -> [InvisTVBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType + -> [Type] -> Type + -> TcM (Maybe (Id, Bool)) +mkPatSynBuilderId dir (L _ name) + univ_bndrs req_theta ex_bndrs prov_theta + arg_tys pat_ty + | isUnidirectional dir + = return Nothing + | otherwise + = do { builder_name <- newImplicitBinder name mkBuilderOcc + ; let theta = req_theta ++ prov_theta + need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta + builder_sigma = add_void need_dummy_arg $ + mkInvisForAllTys univ_bndrs $ + mkInvisForAllTys ex_bndrs $ + mkPhiTy theta $ + mkVisFunTysMany arg_tys $ + pat_ty + builder_id = mkExportedVanillaId builder_name builder_sigma + -- See Note [Exported LocalIds] in GHC.Types.Id + + builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id + + ; return (Just (builder_id', need_dummy_arg)) } + where + +tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) +-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn +tcPatSynBuilderBind (PSB { psb_id = L loc name + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) + | isUnidirectional dir + = return emptyBag + + | Left why <- mb_match_group -- Can't invert the pattern + = setSrcSpan (getLoc lpat) $ failWithTc $ + vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" + <+> quotes (ppr name) <> colon) + 2 why + , text "RHS pattern:" <+> ppr lpat ] + + | Right match_group <- mb_match_group -- Bidirectional + = do { patsyn <- tcLookupPatSyn name + ; case patSynBuilder patsyn of { + Nothing -> return emptyBag ; + -- This case happens if we found a type error in the + -- pattern synonym, recovered, and put a placeholder + -- with patSynBuilder=Nothing in the environment + + Just (builder_id, need_dummy_arg) -> -- Normal case + do { -- Bidirectional, so patSynBuilder returns Just + let match_group' | need_dummy_arg = add_dummy_arg match_group + | otherwise = match_group + + bind = FunBind { fun_id = L loc (idName builder_id) + , fun_matches = match_group' + , fun_ext = emptyNameSet + , fun_tick = [] } + + sig = completeSigFromId (PatSynCtxt name) builder_id + + ; traceTc "tcPatSynBuilderBind {" $ + ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) + ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) + ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds + ; return builder_binds } } } + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with +#endif + where + mb_match_group + = case dir of + ExplicitBidirectional explicit_mg -> Right explicit_mg + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) + Unidirectional -> panic "tcPatSynBuilderBind" + + mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) + mk_mg body = mkMatchGroup Generated [builder_match] + where + builder_args = [L loc (VarPat noExtField (L loc n)) + | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_args body + (noLoc (EmptyLocalBinds noExtField)) + + args = case details of + PrefixCon args -> args + InfixCon arg1 arg2 -> [arg1, arg2] + RecCon args -> map recordPatSynPatVar args + + add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) + -> MatchGroup GhcRn (LHsExpr GhcRn) + add_dummy_arg mg@(MG { mg_alts = + (L l [L loc match@(Match { m_pats = pats })]) }) + = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } + add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ + pprMatches other_mg + +tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType) +-- monadic only for failure +tcPatSynBuilderOcc ps + | Just (builder_id, add_void_arg) <- builder + , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) + builder_ty = idType builder_id + = return $ + if add_void_arg + then ( builder_expr -- still just return builder_expr; the void# arg is added + -- by dsConLike in the desugarer + , tcFunResultTy builder_ty ) + else (builder_expr, builder_ty) + + | otherwise -- Unidirectional + = nonBidirectionalErr name + where + name = patSynName ps + builder = patSynBuilder ps + +add_void :: Bool -> Type -> Type +add_void need_dummy_arg ty + | need_dummy_arg = mkVisFunTyMany voidPrimTy ty + | otherwise = ty + +tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn + -> Either MsgDoc (LHsExpr GhcRn) +-- Given a /pattern/, return an /expression/ that builds a value +-- that matches the pattern. E.g. if the pattern is (Just [x]), +-- the expression is (Just [x]). They look the same, but the +-- input uses constructors from HsPat and the output uses constructors +-- from HsExpr. +-- +-- Returns (Left r) if the pattern is not invertible, for reason r. +-- See Note [Builder for a bidirectional pattern synonym] +tcPatToExpr name args pat = go pat + where + lhsVars = mkNameSet (map unLoc args) + + -- Make a prefix con for prefix and infix patterns for simplicity + mkPrefixConExpr :: Located Name -> [LPat GhcRn] + -> Either MsgDoc (HsExpr GhcRn) + mkPrefixConExpr lcon@(L loc _) pats + = do { exprs <- mapM go pats + ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) + (HsVar noExtField lcon) exprs) } + + mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) + -> Either MsgDoc (HsExpr GhcRn) + mkRecordConExpr con fields + = do { exprFields <- mapM go fields + ; return (RecordCon noExtField con exprFields) } + + go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) + go (L loc p) = L loc <$> go1 p + + go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) + go1 (ConPat NoExtField con info) + = case info of + PrefixCon ps -> mkPrefixConExpr con ps + InfixCon l r -> mkPrefixConExpr con [l,r] + RecCon fields -> mkRecordConExpr con fields + + go1 (SigPat _ pat _) = go1 (unLoc pat) + -- See Note [Type signatures and the builder expression] + + go1 (VarPat _ (L l var)) + | var `elemNameSet` lhsVars + = return $ HsVar noExtField (L l var) + | otherwise + = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") + go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat + go1 p@(ListPat reb pats) + | Nothing <- reb = do { exprs <- mapM go pats + ; return $ ExplicitList noExtField Nothing exprs } + | otherwise = notInvertibleListPat p + go1 (TuplePat _ pats box) = do { exprs <- mapM go pats + ; return $ ExplicitTuple noExtField + (map (noLoc . (Present noExtField)) exprs) + box } + go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) + ; return $ ExplicitSum noExtField alt arity + (noLoc expr) + } + go1 (LitPat _ lit) = return $ HsLit noExtField lit + go1 (NPat _ (L _ n) mb_neg _) + | Just (SyntaxExprRn neg) <- mb_neg + = return $ unLoc $ foldl' nlHsApp (noLoc neg) + [noLoc (HsOverLit noExtField n)] + | otherwise = return $ HsOverLit noExtField n + go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) + = go1 pat + go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" + + -- The following patterns are not invertible. + go1 p@(BangPat {}) = notInvertible p -- #14112 + go1 p@(LazyPat {}) = notInvertible p + go1 p@(WildPat {}) = notInvertible p + go1 p@(AsPat {}) = notInvertible p + go1 p@(ViewPat {}) = notInvertible p + go1 p@(NPlusKPat {}) = notInvertible p + go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p + go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p + go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p + + notInvertible p = Left (not_invertible_msg p) + + not_invertible_msg p + = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" + $+$ hang (text "Suggestion: instead use an explicitly bidirectional" + <+> text "pattern synonym, e.g.") + 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow + <+> ppr pat <+> text "where") + 2 (pp_name <+> pp_args <+> equals <+> text "...")) + where + pp_name = ppr name + pp_args = hsep (map ppr args) + + -- We should really be able to invert list patterns, even when + -- rebindable syntax is on, but doing so involves a bit of + -- refactoring; see #14380. Until then we reject with a + -- helpful error message. + notInvertibleListPat p + = Left (vcat [ not_invertible_msg p + , text "Reason: rebindable syntax is on." + , text "This is fixable: add use-case to #14380" ]) + +{- Note [Builder for a bidirectional pattern synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a bidirectional pattern synonym we need to produce an /expression/ +that matches the supplied /pattern/, given values for the arguments +of the pattern synonym. For example + pattern F x y = (Just x, [y]) +The 'builder' for F looks like + $builderF x y = (Just x, [y]) + +We can't always do this: + * Some patterns aren't invertible; e.g. view patterns + pattern F x = (reverse -> x:_) + + * The RHS pattern might bind more variables than the pattern + synonym, so again we can't invert it + pattern F x = (x,y) + + * Ditto wildcards + pattern F x = (x,_) + + +Note [Redundant constraints for builder] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The builder can have redundant constraints, which are awkward to eliminate. +Consider + pattern P = Just 34 +To match against this pattern we need (Eq a, Num a). But to build +(Just 34) we need only (Num a). Fortunately instTcSigFromId sets +sig_warn_redundant to False. + +************************************************************************ +* * + Helper functions +* * +************************************************************************ + +Note [As-patterns in pattern synonym definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rationale for rejecting as-patterns in pattern synonym definitions +is that an as-pattern would introduce nonindependent pattern synonym +arguments, e.g. given a pattern synonym like: + + pattern K x y = x@(Just y) + +one could write a nonsensical function like + + f (K Nothing x) = ... + +or + g (K (Just True) False) = ... + +Note [Type signatures and the builder expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + pattern L x = Left x :: Either [a] [b] + +In tc{Infer/Check}PatSynDecl we will check that the pattern has the +specified type. We check the pattern *as a pattern*, so the type +signature is a pattern signature, and so brings 'a' and 'b' into +scope. But we don't have a way to bind 'a, b' in the LHS, as we do +'x', say. Nevertheless, the signature may be useful to constrain +the type. + +When making the binding for the *builder*, though, we don't want + $buildL x = Left x :: Either [a] [b] +because that wil either mean (forall a b. Either [a] [b]), or we'll +get a complaint that 'a' and 'b' are out of scope. (Actually the +latter; #9867.) No, the job of the signature is done, so when +converting the pattern to an expression (for the builder RHS) we +simply discard the signature. + +Note [Record PatSyn Desugaring] +------------------------------- +It is important that prov_theta comes before req_theta as this ordering is used +when desugaring record pattern synonym updates. + +Any change to this ordering should make sure to change GHC.HsToCore.Expr if you +want to avoid difficult to decipher core lint errors! + -} + + +nonBidirectionalErr :: Outputable name => name -> TcM a +nonBidirectionalErr name = failWithTc $ + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" + +-- Walk the whole pattern and for all ConPatOuts, collect the +-- existentially-bound type variables and evidence binding variables. +-- +-- These are used in computing the type of a pattern synonym and also +-- in generating matcher functions, since success continuations need +-- to be passed these pattern-bound evidences. +tcCollectEx + :: LPat GhcTc + -> ( [TyVar] -- Existentially-bound type variables + -- in correctly-scoped order; e.g. [ k:*, x:k ] + , [EvVar] ) -- and evidence variables + +tcCollectEx pat = go pat + where + go :: LPat GhcTc -> ([TyVar], [EvVar]) + go = go1 . unLoc + + go1 :: Pat GhcTc -> ([TyVar], [EvVar]) + go1 (LazyPat _ p) = go p + go1 (AsPat _ _ p) = go p + go1 (ParPat _ p) = go p + go1 (BangPat _ p) = go p + go1 (ListPat _ ps) = mergeMany . map go $ ps + go1 (TuplePat _ ps _) = mergeMany . map go $ ps + go1 (SumPat _ p _ _) = go p + go1 (ViewPat _ _ p) = go p + go1 con@ConPat{ pat_con_ext = con' } + = merge (cpt_tvs con', cpt_dicts con') $ + goConDetails $ pat_args con + go1 (SigPat _ p _) = go p + go1 (XPat (CoPat _ p _)) = go1 p + go1 (NPlusKPat _ n k _ geq subtract) + = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract + go1 _ = empty + + goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) + goConDetails (PrefixCon ps) = mergeMany . map go $ ps + goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 + goConDetails (RecCon HsRecFields{ rec_flds = flds }) + = mergeMany . map goRecFd $ flds + + goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) + goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p + + merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) + mergeMany = foldr merge empty + empty = ([], []) diff --git a/GHC/Tc/TyCl/PatSyn.hs-boot b/GHC/Tc/TyCl/PatSyn.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/PatSyn.hs-boot @@ -0,0 +1,16 @@ +module GHC.Tc.TyCl.PatSyn where + +import GHC.Hs ( PatSynBind, LHsBinds ) +import GHC.Tc.Types ( TcM, TcSigInfo ) +import GHC.Tc.Utils.Monad ( TcGblEnv) +import GHC.Utils.Outputable ( Outputable ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) +import Data.Maybe ( Maybe ) + +tcPatSynDecl :: PatSynBind GhcRn GhcRn + -> Maybe TcSigInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) + +tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) + +nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/GHC/Tc/TyCl/Utils.hs b/GHC/Tc/TyCl/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/TyCl/Utils.hs @@ -0,0 +1,1103 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Analysis functions over data types. Specifically, detecting recursive types. +-- +-- This stuff is only used for source-code decls; it's recorded in interface +-- files for imported data types. +module GHC.Tc.TyCl.Utils( + RolesInfo, + inferRoles, + checkSynCycles, + checkClassCycles, + + -- * Implicits + addTyConsToGblEnv, mkDefaultMethodType, + + -- * Record selectors + tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Bind( tcValBinds ) +import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) +import GHC.Core.Multiplicity +import GHC.Tc.Utils.TcType +import GHC.Core.Predicate +import GHC.Builtin.Types( unitTy ) +import GHC.Core.Make( rEC_SEL_ERROR_ID ) +import GHC.Hs +import GHC.Core.Class +import GHC.Core.Type +import GHC.Driver.Types +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set hiding (unitFV) +import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.Coercion ( ltRole ) +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique ( mkBuiltinUnique ) +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Utils.FV as FV +import GHC.Unit.Module +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad + +{- +************************************************************************ +* * + Cycles in type synonym declarations +* * +************************************************************************ +-} + +synonymTyConsOfType :: Type -> [TyCon] +-- Does not look through type synonyms at all +-- Return a list of synonym tycons +-- Keep this synchronized with 'expandTypeSynonyms' +synonymTyConsOfType ty + = nameEnvElts (go ty) + where + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys + go (LitTy _) = emptyNameEnv + go (TyVarTy _) = emptyNameEnv + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy _ w a b) = go w `plusNameEnv` go a `plusNameEnv` go b + go (ForAllTy _ ty) = go ty + go (CastTy ty co) = go ty `plusNameEnv` go_co co + go (CoercionTy co) = go_co co + + -- Note [TyCon cycles through coercions?!] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Although, in principle, it's possible for a type synonym loop + -- could go through a coercion (since a coercion can refer to + -- a TyCon or Type), it doesn't seem possible to actually construct + -- a Haskell program which tickles this case. Here is an example + -- program which causes a coercion: + -- + -- type family Star where + -- Star = Type + -- + -- data T :: Star -> Type + -- data S :: forall (a :: Type). T a -> Type + -- + -- Here, the application 'T a' must first coerce a :: Type to a :: Star, + -- witnessed by the type family. But if we now try to make Type refer + -- to a type synonym which in turn refers to Star, we'll run into + -- trouble: we're trying to define and use the type constructor + -- in the same recursive group. Possibly this restriction will be + -- lifted in the future but for now, this code is "just for completeness + -- sake". + go_mco MRefl = emptyNameEnv + go_mco (MCo co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `plusNameEnv` go_mco mco + go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs + go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' + go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' + go_co (FunCo _ co_mult co co') = go_co co_mult `plusNameEnv` go_co co `plusNameEnv` go_co co' + go_co (CoVarCo _) = emptyNameEnv + go_co (HoleCo {}) = emptyNameEnv + go_co (AxiomInstCo _ _ cs) = go_co_s cs + go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' + go_co (SymCo co) = go_co co + go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' + go_co (NthCo _ _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_co_s cs + + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyNameEnv + go_prov CorePrepProv = emptyNameEnv + + go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc + | otherwise = emptyNameEnv + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos + +-- | A monad for type synonym cycle checking, which keeps +-- track of the TyCons which are known to be acyclic, or +-- a failure message reporting that a cycle was found. +newtype SynCycleM a = SynCycleM { + runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } + deriving (Functor) + +type SynCycleState = NameSet + +instance Applicative SynCycleM where + pure x = SynCycleM $ \state -> Right (x, state) + (<*>) = ap + +instance Monad SynCycleM where + m >>= f = SynCycleM $ \state -> + case runSynCycleM m state of + Right (x, state') -> + runSynCycleM (f x) state' + Left err -> Left err + +failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () +failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) + +-- | Test if a 'Name' is acyclic, short-circuiting if we've +-- seen it already. +checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM () +checkNameIsAcyclic n m = SynCycleM $ \s -> + if n `elemNameSet` s + then Right ((), s) -- short circuit + else case runSynCycleM m s of + Right ((), s') -> Right ((), extendNameSet s' n) + Left err -> Left err + +-- | Checks if any of the passed in 'TyCon's have cycles. +-- Takes the 'Unit' of the home package (as we can avoid +-- checking those TyCons: cycles never go through foreign packages) and +-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we +-- can give better error messages. +checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () +checkSynCycles this_uid tcs tyclds = do + case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of + Left (loc, err) -> setSrcSpan loc $ failWithTc err + Right _ -> return () + where + -- Try our best to print the LTyClDecl for locally defined things + lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds) + + -- Short circuit if we've already seen this Name and concluded + -- it was acyclic. + go :: NameSet -> [TyCon] -> TyCon -> SynCycleM () + go so_far seen_tcs tc = + checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc + + -- Expand type synonyms, complaining if you find the same + -- type synonym a second time. + go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM () + go' so_far seen_tcs tc + | n `elemNameSet` so_far + = failSynCycleM (getSrcSpan (head seen_tcs)) $ + sep [ text "Cycle in type synonym declarations:" + , nest 2 (vcat (map ppr_decl seen_tcs)) ] + -- Optimization: we don't allow cycles through external packages, + -- so once we find a non-local name we are guaranteed to not + -- have a cycle. + -- + -- This won't hold once we get recursive packages with Backpack, + -- but for now it's fine. + | not (isHoleModule mod || + moduleUnit mod == this_uid || + isInteractiveModule mod) + = return () + | Just ty <- synTyConRhs_maybe tc = + go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty + | otherwise = return () + where + n = tyConName tc + mod = nameModule n + ppr_decl tc = + case lookupNameEnv lcl_decls n of + Just (L loc decl) -> ppr loc <> colon <+> ppr decl + Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n + <+> text "from external module" + where + n = tyConName tc + + go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM () + go_ty so_far seen_tcs ty = + mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) + +{- Note [Superclass cycle check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass cycle check for C decides if we can statically +guarantee that expanding C's superclass cycles transitively is +guaranteed to terminate. This is a Haskell98 requirement, +but one that we lift with -XUndecidableSuperClasses. + +The worry is that a superclass cycle could make the type checker loop. +More precisely, with a constraint (Given or Wanted) + C ty1 .. tyn +one approach is to instantiate all of C's superclasses, transitively. +We can only do so if that set is finite. + +This potential loop occurs only through superclasses. This, for +example, is fine + class C a where + op :: C b => a -> b -> b +even though C's full definition uses C. + +Making the check static also makes it conservative. Eg + type family F a + class F a => C a +Here an instance of (F a) might mention C: + type instance F [a] = C a +and now we'd have a loop. + +The static check works like this, starting with C + * Look at C's superclass predicates + * If any is a type-function application, + or is headed by a type variable, fail + * If any has C at the head, fail + * If any has a type class D at the head, + make the same test with D + +A tricky point is: what if there is a type variable at the head? +Consider this: + class f (C f) => C f + class c => Id c +and now expand superclasses for constraint (C Id): + C Id + --> Id (C Id) + --> C Id + --> .... +Each step expands superclasses one layer, and clearly does not terminate. +-} + +checkClassCycles :: Class -> Maybe SDoc +-- Nothing <=> ok +-- Just err <=> possible cycle error +checkClassCycles cls + = do { (definite_cycle, err) <- go (unitNameSet (getName cls)) + cls (mkTyVarTys (classTyVars cls)) + ; let herald | definite_cycle = text "Superclass cycle for" + | otherwise = text "Potential superclass cycle for" + ; return (vcat [ herald <+> quotes (ppr cls) + , nest 2 err, hint]) } + where + hint = text "Use UndecidableSuperClasses to accept this" + + -- Expand superclasses starting with (C a b), complaining + -- if you find the same class a second time, or a type function + -- or predicate headed by a type variable + -- + -- NB: this code duplicates TcType.transSuperClasses, but + -- with more error message generation clobber + -- Make sure the two stay in sync. + go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go so_far cls tys = firstJusts $ + map (go_pred so_far) $ + immSuperClasses cls tys + + go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc) + -- Nothing <=> ok + -- Just (True, err) <=> definite cycle + -- Just (False, err) <=> possible cycle + go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms + | Just (tc, tys) <- tcSplitTyConApp_maybe pred + = go_tc so_far pred tc tys + | hasTyVarHead pred + = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") + 2 (quotes (ppr pred))) + | otherwise + = Nothing + + go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) + go_tc so_far pred tc tys + | isFamilyTyCon tc + = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") + 2 (quotes (ppr pred))) + | Just cls <- tyConClass_maybe tc + = go_cls so_far cls tys + | otherwise -- Equality predicate, for example + = Nothing + + go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go_cls so_far cls tys + | cls_nm `elemNameSet` so_far + = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) + | isCTupleClass cls + = go so_far cls tys + | otherwise + = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys + ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) + $$ err) } + where + cls_nm = getName cls + +{- +************************************************************************ +* * + Role inference +* * +************************************************************************ + +Note [Role inference] +~~~~~~~~~~~~~~~~~~~~~ +The role inference algorithm datatype definitions to infer the roles on the +parameters. Although these roles are stored in the tycons, we can perform this +algorithm on the built tycons, as long as we don't peek at an as-yet-unknown +roles field! Ah, the magic of laziness. + +First, we choose appropriate initial roles. For families and classes, roles +(including initial roles) are N. For datatypes, we start with the role in the +role annotation (if any), or otherwise use Phantom. This is done in +initialRoleEnv1. + +The function irGroup then propagates role information until it reaches a +fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a +monad RoleM, which is a combination reader and state monad. In its state are +the current RoleEnv, which gets updated by role propagation, and an update +bit, which we use to know whether or not we've reached the fixpoint. The +environment of RoleM contains the tycon whose parameters we are inferring, and +a VarEnv from parameters to their positions, so we can update the RoleEnv. +Between tycons, this reader information is missing; it is added by +addRoleInferenceInfo. + +There are two kinds of tycons to consider: algebraic ones (excluding classes) +and type synonyms. (Remember, families don't participate -- all their parameters +are N.) An algebraic tycon processes each of its datacons, in turn. Note that +a datacon's universally quantified parameters might be different from the parent +tycon's parameters, so we use the datacon's univ parameters in the mapping from +vars to positions. Note also that we don't want to infer roles for existentials +(they're all at N, too), so we put them in the set of local variables. As an +optimisation, we skip any tycons whose roles are already all Nominal, as there +nowhere else for them to go. For synonyms, we just analyse their right-hand sides. + +irType walks through a type, looking for uses of a variable of interest and +propagating role information. Because anything used under a phantom position +is at phantom and anything used under a nominal position is at nominal, the +irType function can assume that anything it sees is at representational. (The +other possibilities are pruned when they're encountered.) + +The rest of the code is just plumbing. + +How do we know that this algorithm is correct? It should meet the following +specification: + +Let Z be a role context -- a mapping from variables to roles. The following +rules define the property (Z |- t : r), where t is a type and r is a role: + +Z(a) = r' r' <= r +------------------------- RCVar +Z |- a : r + +---------- RCConst +Z |- T : r -- T is a type constructor + +Z |- t1 : r +Z |- t2 : N +-------------- RCApp +Z |- t1 t2 : r + +forall i<=n. (r_i is R or N) implies Z |- t_i : r_i +roles(T) = r_1 .. r_n +---------------------------------------------------- RCDApp +Z |- T t_1 .. t_n : R + +Z, a:N |- t : r +---------------------- RCAll +Z |- forall a:k.t : r + + +We also have the following rules: + +For all datacon_i in type T, where a_1 .. a_n are universally quantified +and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, +then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, +then roles(T) = r_1 .. r_n + +roles(->) = R, R +roles(~#) = N, N + +With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, +called from checkValidTycon. + +Note [Role-checking data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + MkT :: Eq b => F a -> (a->a) -> T (G a) + +Then we want to check the roles at which 'a' is used +in MkT's type. We want to work on the user-written type, +so we need to take into account + * the arguments: (F a) and (a->a) + * the context: C a b + * the result type: (G a) -- this is in the eq_spec + + +Note [Coercions in role inference] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing +the kind of a type is totally irrelevant to the representation of that type. So, +we want to totally ignore coercions when doing role inference. This includes omitting +any type variables that appear in nominal positions but only within coercions. +-} + +type RolesInfo = Name -> [Role] + +type RoleEnv = NameEnv [Role] -- from tycon names to roles + +-- This, and any of the functions it calls, must *not* look at the roles +-- field of a tycon we are inferring roles about! +-- See Note [Role inference] +inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role] +inferRoles hsc_src annots tycons + = let role_env = initialRoleEnv hsc_src annots tycons + role_env' = irGroup role_env tycons in + \name -> case lookupNameEnv role_env' name of + Just roles -> roles + Nothing -> pprPanic "inferRoles" (ppr name) + +initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv +initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv . + map (initialRoleEnv1 hsc_src annots) + +initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role]) +initialRoleEnv1 hsc_src annots_env tc + | isFamilyTyCon tc = (name, map (const Nominal) bndrs) + | isAlgTyCon tc = (name, default_roles) + | isTypeSynonymTyCon tc = (name, default_roles) + | otherwise = pprPanic "initialRoleEnv1" (ppr tc) + where name = tyConName tc + bndrs = tyConBinders tc + argflags = map tyConBinderArgFlag bndrs + num_exps = count isVisibleArgFlag argflags + + -- if the number of annotations in the role annotation decl + -- is wrong, just ignore it. We check this in the validity check. + role_annots + = case lookupRoleAnnot annots_env name of + Just (L _ (RoleAnnotDecl _ _ annots)) + | annots `lengthIs` num_exps -> map unLoc annots + _ -> replicate num_exps Nothing + default_roles = build_default_roles argflags role_annots + + build_default_roles (argf : argfs) (m_annot : ras) + | isVisibleArgFlag argf + = (m_annot `orElse` default_role) : build_default_roles argfs ras + build_default_roles (_argf : argfs) ras + = Nominal : build_default_roles argfs ras + build_default_roles [] [] = [] + build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" + (vcat [ppr tc, ppr role_annots]) + + default_role + | isClassTyCon tc = Nominal + -- Note [Default roles for abstract TyCons in hs-boot/hsig] + | HsBootFile <- hsc_src + , isAbstractTyCon tc = Representational + | HsigFile <- hsc_src + , isAbstractTyCon tc = Nominal + | otherwise = Phantom + +-- Note [Default roles for abstract TyCons in hs-boot/hsig] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- What should the default role for an abstract TyCon be? +-- +-- Originally, we inferred phantom role for abstract TyCons +-- in hs-boot files, because the type variables were never used. +-- +-- This was silly, because the role of the abstract TyCon +-- was required to match the implementation, and the roles of +-- data types are almost never phantom. Thus, in ticket #9204, +-- the default was changed so be representational (the most common case). If +-- the implementing data type was actually nominal, you'd get an easy +-- to understand error, and add the role annotation yourself. +-- +-- Then Backpack was added, and with it we added role *subtyping* +-- the matching judgment: if an abstract TyCon has a nominal +-- parameter, it's OK to implement it with a representational +-- parameter. But now, the representational default is not a good +-- one, because you should *only* request representational if +-- you're planning to do coercions. To be maximally flexible +-- with what data types you will accept, you want the default +-- for hsig files is nominal. We don't allow role subtyping +-- with hs-boot files (it's good practice to give an exactly +-- accurate role here, because any types that use the abstract +-- type will propagate the role information.) + +irGroup :: RoleEnv -> [TyCon] -> RoleEnv +irGroup env tcs + = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in + if update + then irGroup env' tcs + else env' + +irTyCon :: TyCon -> RoleM () +irTyCon tc + | isAlgTyCon tc + = do { old_roles <- lookupRoles tc + ; unless (all (== Nominal) old_roles) $ -- also catches data families, + -- which don't want or need role inference + irTcTyVars tc $ + do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 + ; whenIsJust (tyConClass_maybe tc) irClass + ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} + + | Just ty <- synTyConRhs_maybe tc + = irTcTyVars tc $ + irType emptyVarSet ty + + | otherwise + = return () + +-- any type variable used in an associated type must be Nominal +irClass :: Class -> RoleM () +irClass cls + = mapM_ ir_at (classATs cls) + where + cls_tvs = classTyVars cls + cls_tv_set = mkVarSet cls_tvs + + ir_at at_tc + = mapM_ (updateRole Nominal) nvars + where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc + +-- See Note [Role inference] +irDataCon :: DataCon -> RoleM () +irDataCon datacon + = setRoleInferenceVars univ_tvs $ + irExTyVars ex_tvs $ \ ex_var_set -> + do mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys) + mapM_ (markNominal ex_var_set) (map tyVarKind ex_tvs ++ map scaledMult arg_tys) -- Field multiplicities are nominal (#18799) + -- See Note [Role-checking data constructor arguments] + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon + +irType :: VarSet -> Type -> RoleM () +irType = go + where + go lcls ty | Just ty' <- coreView ty -- #14101 + = go lcls ty' + go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ + updateRole Representational tv + go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 + go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc + ; zipWithM_ (go_app lcls) roles tys } + go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb + lcls' = extendVarSet lcls tv + ; markNominal lcls (tyVarKind tv) + ; go lcls' ty } + go lcls (FunTy _ w arg res) = markNominal lcls w >> go lcls arg >> go lcls res + go _ (LitTy {}) = return () + -- See Note [Coercions in role inference] + go lcls (CastTy ty _) = go lcls ty + go _ (CoercionTy _) = return () + + go_app _ Phantom _ = return () -- nothing to do here + go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N + go_app lcls Representational ty = go lcls ty + +irTcTyVars :: TyCon -> RoleM a -> RoleM a +irTcTyVars tc thing + = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) + where + go [] = thing + go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) + ; addRoleInferenceVar tv $ go tvs } + +irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a +irExTyVars orig_tvs thing = go emptyVarSet orig_tvs + where + go lcls [] = thing lcls + go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) + ; go (extendVarSet lcls tv) tvs } + +markNominal :: TyVarSet -- local variables + -> Type -> RoleM () +markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in + mapM_ (updateRole Nominal) nvars + where + -- get_ty_vars gets all the tyvars (no covars!) from a type *without* + -- recurring into coercions. Recall: coercions are totally ignored during + -- role inference. See [Coercions in role inference] + get_ty_vars :: Type -> FV + get_ty_vars (TyVarTy tv) = unitFV tv + get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (FunTy _ w t1 t2) = get_ty_vars w `unionFV` get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys + get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) + get_ty_vars (LitTy {}) = emptyFV + get_ty_vars (CastTy ty _) = get_ty_vars ty + get_ty_vars (CoercionTy _) = emptyFV + +-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps +lookupRolesX :: TyCon -> RoleM [Role] +lookupRolesX tc + = do { roles <- lookupRoles tc + ; return $ roles ++ repeat Nominal } + +-- gets the roles either from the environment or the tycon +lookupRoles :: TyCon -> RoleM [Role] +lookupRoles tc + = do { env <- getRoleEnv + ; case lookupNameEnv env (tyConName tc) of + Just roles -> return roles + Nothing -> return $ tyConRoles tc } + +-- tries to update a role; won't ever update a role "downwards" +updateRole :: Role -> TyVar -> RoleM () +updateRole role tv + = do { var_ns <- getVarNs + ; name <- getTyConName + ; case lookupVarEnv var_ns tv of + Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) + Just n -> updateRoleEnv name n role } + +-- the state in the RoleM monad +data RoleInferenceState = RIS { role_env :: RoleEnv + , update :: Bool } + +-- the environment in the RoleM monad +type VarPositions = VarEnv Int + +-- See [Role inference] +newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon + -> VarPositions + -> Int -- size of VarPositions + -> RoleInferenceState + -> (a, RoleInferenceState) } + deriving (Functor) + +instance Applicative RoleM where + pure x = RM $ \_ _ _ state -> (x, state) + (<*>) = ap + +instance Monad RoleM where + a >>= f = RM $ \m_info vps nvps state -> + let (a', state') = unRM a m_info vps nvps state in + unRM (f a') m_info vps nvps state' + +runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) +runRoleM env thing = (env', update) + where RIS { role_env = env', update = update } + = snd $ unRM thing Nothing emptyVarEnv 0 state + state = RIS { role_env = env + , update = False } + +setRoleInferenceTc :: Name -> RoleM a -> RoleM a +setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> + ASSERT( isNothing m_name ) + ASSERT( isEmptyVarEnv vps ) + ASSERT( nvps == 0 ) + unRM thing (Just name) vps nvps state + +addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a +addRoleInferenceVar tv thing + = RM $ \m_name vps nvps state -> + ASSERT( isJust m_name ) + unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state + +setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a +setRoleInferenceVars tvs thing + = RM $ \m_name _vps _nvps state -> + ASSERT( isJust m_name ) + unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") + state + +getRoleEnv :: RoleM RoleEnv +getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) + +getVarNs :: RoleM VarPositions +getVarNs = RM $ \_ vps _ state -> (vps, state) + +getTyConName :: RoleM Name +getTyConName = RM $ \m_name _ _ state -> + case m_name of + Nothing -> panic "getTyConName" + Just name -> (name, state) + +updateRoleEnv :: Name -> Int -> Role -> RoleM () +updateRoleEnv name n role + = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), + case lookupNameEnv role_env name of + Nothing -> pprPanic "updateRoleEnv" (ppr name) + Just roles -> let (before, old_role : after) = splitAt n roles in + if role `ltRole` old_role + then let roles' = before ++ role : after + role_env' = extendNameEnv role_env name roles' in + RIS { role_env = role_env', update = True } + else state ) + + +{- ********************************************************************* +* * + Building implicits +* * +********************************************************************* -} + +addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv +-- Given a [TyCon], add to the TcGblEnv +-- * extend the TypeEnv with the tycons +-- * extend the TypeEnv with their implicitTyThings +-- * extend the TypeEnv with any default method Ids +-- * add bindings for record selectors +addTyConsToGblEnv tyclss + = tcExtendTyConEnv tyclss $ + tcExtendGlobalEnvImplicit implicit_things $ + tcExtendGlobalValEnv def_meth_ids $ + do { traceTc "tcAddTyCons" $ vcat + [ text "tycons" <+> ppr tyclss + , text "implicits" <+> ppr implicit_things ] + ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) + ; return gbl_env } + where + implicit_things = concatMap implicitTyConThings tyclss + def_meth_ids = mkDefaultMethodIds tyclss + +mkDefaultMethodIds :: [TyCon] -> [Id] +-- We want to put the default-method Ids (both vanilla and generic) +-- into the type environment so that they are found when we typecheck +-- the filled-in default methods of each instance declaration +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds tycons + = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec) + | tc <- tycons + , Just cls <- [tyConClass_maybe tc] + , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] + +mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type +-- Returns the top-level type of the default method +mkDefaultMethodType _ sel_id VanillaDM = idType sel_id +mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty + where + pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) + cls_bndrs = tyConBinders (classTyCon cls) + tv_bndrs = tyVarSpecToBinders $ tyConInvisTVBinders cls_bndrs + -- NB: the Class doesn't have TyConBinders; we reach into its + -- TyCon to get those. We /do/ need the TyConBinders because + -- we need the correct visibility: these default methods are + -- used in code generated by the fill-in for missing + -- methods in instances (GHC.Tc.TyCl.Instance.mkDefMethBind), and + -- then typechecked. So we need the right visibility info + -- (#13998) + +{- +************************************************************************ +* * + Building record selectors +* * +************************************************************************ +-} + +{- +Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (because they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. +-} + +{- +************************************************************************ +* * + Building record selectors +* * +************************************************************************ +-} + +tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv +tcRecSelBinds sel_bind_prs + = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ + do { (rec_sel_binds, tcg_env) <- discardWarnings $ + -- See Note [Impredicative record selectors] + setXOptM LangExt.ImpredicativeTypes $ + tcValBinds TopLevel binds sigs getGblEnv + ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } + where + sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] + binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] + +mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] +-- NB We produce *un-typechecked* bindings, rather like 'deriving' +-- This makes life easier, because the later type checking will add +-- all necessary type abstractions and applications +mkRecSelBinds tycons + = map mkRecSelBind [ (tc,fld) | tc <- tycons + , fld <- tyConFieldLabels tc ] + +mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) +mkRecSelBind (tycon, fl) + = mkOneRecordSelector all_cons (RecSelData tycon) fl + where + all_cons = map RealDataCon (tyConDataCons tycon) + +mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel + -> (Id, LHsBind GhcRn) +mkOneRecordSelector all_cons idDetails fl + = (sel_id, L loc sel_bind) + where + loc = getSrcSpan sel_name + lbl = flLabel fl + sel_name = flSelector fl + + sel_id = mkExportedLocalId rec_details sel_name sel_ty + rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } + + -- Find a representative constructor, con1 + cons_w_field = conLikesWithFields all_cons [lbl] + con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + + -- Selector type; Note [Polymorphic selectors] + field_ty = conLikeFieldType con1 lbl + data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $ + conLikeUserTyVarBinders con1 + data_tv_set= tyCoVarsOfTypes inst_tys + is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] + | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $ + mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! + -- req_theta is empty for normal DataCon + mkPhiTy req_theta $ + mkVisFunTyMany data_ty $ + -- Record selectors are always typed with Many. We + -- could improve on it in the case where all the + -- fields in all the constructor have multiplicity Many. + field_ty + + -- Make the binding: sel (C2 { fld = x }) = x + -- sel (C7 { fld = x }) = x + -- where cons_w_field = [C2,C7] + sel_bind = mkTopFunBind Generated sel_lname alts + where + alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) + [] unit_rhs] + | otherwise = map mk_match cons_w_field ++ deflt + mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) + [L loc (mk_sel_pat con)] + (L loc (HsVar noExtField (L loc field_var))) + mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields) + rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } + rec_field = noLoc (HsRecField + { hsRecFieldLbl + = L loc (FieldOcc sel_name + (L loc $ mkVarUnqual lbl)) + , hsRecFieldArg + = L loc (VarPat noExtField (L loc field_var)) + , hsRecPun = False }) + sel_lname = L loc sel_name + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc + + -- Add catch-all default case unless the case is exhaustive + -- We do this explicitly so that we get a nice error message that + -- mentions this particular record selector + deflt | all dealt_with all_cons = [] + | otherwise = [mkSimpleMatch CaseAlt + [L loc (WildPat noExtField)] + (mkHsApp (L loc (HsVar noExtField + (L loc (getName rEC_SEL_ERROR_ID)))) + (L loc (HsLit noExtField msg_lit)))] + + -- Do not add a default case unless there are unmatched + -- constructors. We must take account of GADTs, else we + -- get overlap warning messages from the pattern-match checker + -- NB: we need to pass type args for the *representation* TyCon + -- to dataConCannotMatch, hence the calculation of inst_tys + -- This matters in data families + -- data instance T Int a where + -- A :: { fld :: Int } -> T Int Bool + -- B :: { fld :: Int } -> T Int Char + dealt_with :: ConLike -> Bool + dealt_with (PatSynCon _) = False -- We can't predict overlap + dealt_with con@(RealDataCon dc) = + con `elem` cons_w_field || dataConCannotMatch inst_tys dc + + (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 + + eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) + -- inst_tys corresponds to one of the following: + -- + -- * The arguments to the user-written return type (for GADT constructors). + -- In this scenario, eq_subst provides a mapping from the universally + -- quantified type variables to the argument types. Note that eq_subst + -- does not need to be applied to any other part of the DataCon + -- (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon). + -- * The universally quantified type variables + -- (for Haskell98-style constructors and pattern synonyms). In these + -- scenarios, eq_subst is an empty substitution. + inst_tys = substTyVars eq_subst univ_tvs + + unit_rhs = mkLHsTupleExpr [] + msg_lit = HsStringPrim NoSourceText (bytesFS lbl) + +{- +Note [Polymorphic selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take care to build the type of a polymorphic selector in the right +order, so that visible type application works according to the specification in +the GHC User's Guide (see the "Field selectors and TypeApplications" section). +We won't bother rehashing the entire specification in this Note, but the tricky +part is dealing with GADT constructor fields. Here is an appropriately tricky +example to illustrate the challenges: + + {-# LANGUAGE PolyKinds #-} + data T a b where + MkT :: forall b a x. + { field1 :: forall c. (Num a, Show c) => (Either a c, Proxy b) + , field2 :: x + } + -> T a b + +Our goal is to obtain the following type for `field1`: + + field1 :: forall {k} (b :: k) a. + T a b -> forall c. (Num a, Show c) => (Either a c, Proxy b) + +(`field2` is naughty, per Note [Naughty record selectors], so we cannot turn +it into a top-level field selector.) + +Some potential gotchas, inspired by #18023: + +1. Since the user wrote `forall b a x.` in the type of `MkT`, we want the `b` + to appear before the `a` when quantified in the type of `field1`. +2. On the other hand, we *don't* want to quantify `x` in the type of `field1`. + This is because `x` does not appear in the GADT return type, so it is not + needed in the selector type. +3. Because of PolyKinds, the kind of `b` is generalized to `k`. Moreover, since + this `k` is not written in the source code, it is inferred (i.e., not + available for explicit type applications) and thus written as {k} in the type + of `field1`. + +In order to address these gotchas, we start by looking at the +conLikeUserTyVarBinders, which gives the order and specificity of each binder. +This effectively solves (1) and (3). To solve (2), we filter the binders to +leave only those that are needed for the selector type. + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selectors that don't really exist. + +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a + +For naughty selectors we make a dummy binding + sel = () +so that the later type-check will add them to the environment, and they'll be +exported. The function is never called, because the typechecker spots the +sel_naughty field. + +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in GHC.Tc.TyCl.checkValidTyCon] +E.g. + data T where + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + T3 :: T Int + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + T3 -> error "T3 does not have field f" + +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +Note the need for casts in the result! + +Note [Selector running example] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's OK to combine GADTs and type families. Here's a running example: + + data instance T [a] where + T1 { fld :: b } :: T [Maybe b] + +The representation type looks like this + data :R7T a where + T1 { fld :: b } :: :R7T (Maybe b) + +and there's coercion from the family type to the representation type + :CoR7T a :: T [a] ~ :R7T a + +The selector we want for fld looks like this: + + fld :: forall b. T [Maybe b] -> b + fld = /\b. \(d::T [Maybe b]). + case d `cast` :CoR7T (Maybe b) of + T1 (x::b) -> x + +The scrutinee of the case has type :R7T (Maybe b), which can be +gotten by applying the eq_spec to the univ_tvs of the data con. + +Note [Impredicative record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are situations where generating code for record selectors requires the +use of ImpredicativeTypes. Here is one example (adapted from #18005): + + type S = (forall b. b -> b) -> Int + data T = MkT {unT :: S} + | Dummy + +We want to generate HsBinds for unT that look something like this: + + unT :: S + unT (MkT x) = x + unT _ = recSelError "unT"# + +Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`. +Therefore, when used in the right-hand side of `unT`, GHC attempts to +instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative. +To make sure that GHC is OK with this, we enable ImpredicativeTypes interally +when typechecking these HsBinds so that the user does not have to. + +Although ImpredicativeTypes is somewhat fragile and unpredictable in GHC right +now, it will become robust when Quick Look impredicativity is implemented. In +the meantime, using ImpredicativeTypes to instantiate the `a` type variable in +recSelError's type does actually work, so its use here is benign. +-} diff --git a/GHC/Tc/Types.hs b/GHC/Tc/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types.hs @@ -0,0 +1,1768 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + +-} + +{-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving, + ViewPatterns #-} + +-- | Various types used during typechecking. +-- +-- Please see "GHC.Tc.Utils.Monad" as well for operations on these types. You probably +-- want to import it, instead of this module. +-- +-- All the monads exported here are built on top of the same IOEnv monad. The +-- monad functions like a Reader monad in the way it passes the environment +-- around. This is done to allow the environment to be manipulated in a stack +-- like fashion when entering expressions... etc. +-- +-- For state that is global and should be returned at the end (e.g not part +-- of the stack mechanism), you should use a TcRef (= IORef) to store them. +module GHC.Tc.Types( + TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module + TcRef, + + -- The environment types + Env(..), + TcGblEnv(..), TcLclEnv(..), + setLclEnvTcLevel, getLclEnvTcLevel, + setLclEnvLoc, getLclEnvLoc, + IfGblEnv(..), IfLclEnv(..), + tcVisibleOrphanMods, + + -- Frontend types (shouldn't really be here) + FrontendResult(..), + + -- Renamer types + ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin, + ImportAvails(..), emptyImportAvails, plusImportAvails, + WhereFrom(..), mkModDeps, modDepsElts, + + -- Typechecker types + TcTypeEnv, TcBinderStack, TcBinder(..), + TcTyThing(..), PromotionErr(..), + IdBindingInfo(..), ClosedTypeId, RhsNames, + IsGroupClosed(..), + SelfBootInfo(..), + tcTyThingCategory, pprTcTyThingCategory, + peCategory, pprPECategory, + CompleteMatch(..), + + -- Desugaring types + DsM, DsLclEnv(..), DsGblEnv(..), + DsMetaEnv, DsMetaVal(..), CompleteMatchMap, + mkCompleteMatchMap, extendCompleteMatchMap, + + -- Template Haskell + ThStage(..), SpliceType(..), PendingStuff(..), + topStage, topAnnStage, topSpliceStage, + ThLevel, impLevel, outerLevel, thLevel, + ForeignSrcLang(..), + + -- Arrows + ArrowCtxt(..), + + -- TcSigInfo + TcSigFun, TcSigInfo(..), TcIdSigInfo(..), + TcIdSigInst(..), TcPatSynInfo(..), + isPartialSig, hasCompleteSig, + + -- Misc other types + TcId, TcIdSet, + NameShape(..), + removeBindingShadowing, + getPlatform, + + -- Constraint solver plugins + TcPlugin(..), TcPluginResult(..), TcPluginSolver, + TcPluginM, runTcPluginM, unsafeTcPluginTcM, + getEvBindsTcPluginM, + + -- Role annotations + RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, + lookupRoleAnnot, getRoleAnnots, + + -- Linting + lintGblEnv + ) where + +#include "HsVersions.h" + +import GHC.Prelude +import GHC.Platform + +import GHC.Hs +import GHC.Driver.Types +import GHC.Tc.Types.Evidence +import GHC.Core.Type +import GHC.Core.TyCon ( TyCon, tyConKind ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Core.Lint ( lintAxioms ) +import GHC.Types.Id ( idType, idName ) +import GHC.Types.FieldLabel ( FieldLabel ) +import GHC.Core.UsageEnv +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Types.Annotations +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Deltas) +import GHC.Data.IOEnv +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Unit +import GHC.Types.SrcLoc +import GHC.Types.Var.Set +import GHC.Utils.Error +import GHC.Types.Unique.FM +import GHC.Types.Basic +import GHC.Data.Bag +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Data.List.SetOps +import GHC.Utils.Fingerprint +import GHC.Utils.Misc +import GHC.Builtin.Names ( isUnboundName ) +import GHC.Types.CostCentre.State + +import Control.Monad (ap) +import Data.Set ( Set ) +import qualified Data.Set as S + +import Data.List ( sort ) +import Data.Map ( Map ) +import Data.Dynamic ( Dynamic ) +import Data.Typeable ( TypeRep ) +import Data.Maybe ( mapMaybe ) +import GHCi.Message +import GHCi.RemoteTypes + +import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin ) + +import qualified Language.Haskell.TH as TH + +-- | A 'NameShape' is a substitution on 'Name's that can be used +-- to refine the identities of a hole while we are renaming interfaces +-- (see "GHC.Iface.Rename"). Specifically, a 'NameShape' for +-- 'ns_module_name' @A@, defines a mapping from @{A.T}@ +-- (for some 'OccName' @T@) to some arbitrary other 'Name'. +-- +-- The most intruiging thing about a 'NameShape', however, is +-- how it's constructed. A 'NameShape' is *implied* by the +-- exported 'AvailInfo's of the implementor of an interface: +-- if an implementor of signature @\@ exports @M.T@, you implicitly +-- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' +-- is computed from the list of 'AvailInfo's that are exported +-- by the implementation of a module, or successively merged +-- together by the export lists of signatures which are joining +-- together. +-- +-- It's not the most obvious way to go about doing this, but it +-- does seem to work! +-- +-- NB: Can't boot this and put it in NameShape because then we +-- start pulling in too many DynFlags things. +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } + + +{- +************************************************************************ +* * + Standard monad definition for TcRn + All the combinators for the monad can be found in GHC.Tc.Utils.Monad +* * +************************************************************************ + +The monad itself has to be defined here, because it is mentioned by ErrCtxt +-} + +type TcRnIf a b = IOEnv (Env a b) +type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference +type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff +type IfG = IfM () -- Top level +type IfL = IfM IfLclEnv -- Nested +type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring + +-- TcRn is the type-checking and renaming monad: the main monad that +-- most type-checking takes place in. The global environment is +-- 'TcGblEnv', which tracks all of the top-level type-checking +-- information we've accumulated while checking a module, while the +-- local environment is 'TcLclEnv', which tracks local information as +-- we move inside expressions. + +-- | Historical "renaming monad" (now it's just 'TcRn'). +type RnM = TcRn + +-- | Historical "type-checking monad" (now it's just 'TcRn'). +type TcM = TcRn + +-- We 'stack' these envs through the Reader like monad infrastructure +-- as we move into an expression (although the change is focused in +-- the lcl type). +data Env gbl lcl + = Env { + env_top :: !HscEnv, -- Top-level stuff that never changes + -- Includes all info about imported things + -- BangPattern is to fix leak, see #15111 + + env_um :: !Char, -- Mask for Uniques + + env_gbl :: gbl, -- Info about things defined at the top level + -- of the module being compiled + + env_lcl :: lcl -- Nested stuff; changes as we go into + } + +instance ContainsDynFlags (Env gbl lcl) where + extractDynFlags env = hsc_dflags (env_top env) + +instance ContainsModule gbl => ContainsModule (Env gbl lcl) where + extractModule env = extractModule (env_gbl env) + + +{- +************************************************************************ +* * + The interface environments + Used when dealing with IfaceDecls +* * +************************************************************************ +-} + +data IfGblEnv + = IfGblEnv { + -- Some information about where this environment came from; + -- useful for debugging. + if_doc :: SDoc, + -- The type environment for the module being compiled, + -- in case the interface refers back to it via a reference that + -- was originally a hi-boot file. + -- We need the module name so we can test when it's appropriate + -- to look in this env. + -- See Note [Tying the knot] in GHC.IfaceToCore + if_rec_types :: Maybe (Module, IfG TypeEnv) + -- Allows a read effect, so it can be in a mutable + -- variable; c.f. handling the external package type env + -- Nothing => interactive stuff, no loops possible + } + +data IfLclEnv + = IfLclEnv { + -- The module for the current IfaceDecl + -- So if we see f = \x -> x + -- it means M.f = \x -> x, where M is the if_mod + -- NB: This is a semantic module, see + -- Note [Identity versus semantic module] + if_mod :: Module, + + -- Whether or not the IfaceDecl came from a boot + -- file or not; we'll use this to choose between + -- NoUnfolding and BootUnfolding + if_boot :: IsBootInterface, + + -- The field is used only for error reporting + -- if (say) there's a Lint error in it + if_loc :: SDoc, + -- Where the interface came from: + -- .hi file, or GHCi state, or ext core + -- plus which bit is currently being examined + + if_nsubst :: Maybe NameShape, + + -- This field is used to make sure "implicit" declarations + -- (anything that cannot be exported in mi_exports) get + -- wired up correctly in typecheckIfacesForMerging. Most + -- of the time it's @Nothing@. See Note [Resolving never-exported Names] + -- in GHC.IfaceToCore. + if_implicits_env :: Maybe TypeEnv, + + if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings + if_id_env :: FastStringEnv Id -- Nested id binding + } + +{- +************************************************************************ +* * + Desugarer monad +* * +************************************************************************ + +Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around +a @UniqueSupply@ and some annotations, which +presumably include source-file location information: +-} + +data DsGblEnv + = DsGblEnv + { ds_mod :: Module -- For SCC profiling + , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env + , ds_unqual :: PrintUnqualified + , ds_msgs :: IORef Messages -- Warning messages + , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, + -- possibly-imported things + , ds_complete_matches :: CompleteMatchMap + -- Additional complete pattern matches + , ds_cc_st :: IORef CostCentreState + -- Tracking indices for cost centre annotations + } + +instance ContainsModule DsGblEnv where + extractModule = ds_mod + +data DsLclEnv = DsLclEnv { + dsl_meta :: DsMetaEnv, -- Template Haskell bindings + dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs + + -- See Note [Note [Type and Term Equality Propagation] in "GHC.HsToCore.PmCheck" + -- The set of reaching values Deltas is augmented as we walk inwards, + -- refined through each pattern match in turn + dsl_deltas :: Deltas + } + +-- Inside [| |] brackets, the desugarer looks +-- up variables in the DsMetaEnv +type DsMetaEnv = NameEnv DsMetaVal + +data DsMetaVal + = DsBound Id -- Bound by a pattern inside the [| |]. + -- Will be dynamically alpha renamed. + -- The Id has type THSyntax.Var + + | DsSplice (HsExpr GhcTc) -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut + + +{- +************************************************************************ +* * + Global typechecker environment +* * +************************************************************************ +-} + +-- | 'FrontendResult' describes the result of running the frontend of a Haskell +-- module. Currently one always gets a 'FrontendTypecheck', since running the +-- frontend involves typechecking a program. hs-sig merges are not handled here. +-- +-- This data type really should be in GHC.Driver.Types, but it needs +-- to have a TcGblEnv which is only defined here. +data FrontendResult + = FrontendTypecheck TcGblEnv + +-- Note [Identity versus semantic module] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When typechecking an hsig file, it is convenient to keep track +-- of two different "this module" identifiers: +-- +-- - The IDENTITY module is simply thisPackage + the module +-- name; i.e. it uniquely *identifies* the interface file +-- we're compiling. For example, p[A=]:A is an +-- identity module identifying the requirement named A +-- from library p. +-- +-- - The SEMANTIC module, which is the actual module that +-- this signature is intended to represent (e.g. if +-- we have a identity module p[A=base:Data.IORef]:A, +-- then the semantic module is base:Data.IORef) +-- +-- Which one should you use? +-- +-- - In the desugarer and later phases of compilation, +-- identity and semantic modules coincide, since we never compile +-- signatures (we just generate blank object files for +-- hsig files.) +-- +-- A corrolary of this is that the following invariant holds at any point +-- past desugaring, +-- +-- if I have a Module, this_mod, in hand representing the module +-- currently being compiled, +-- then moduleUnit this_mod == thisPackage dflags +-- +-- - For any code involving Names, we want semantic modules. +-- See lookupIfaceTop in GHC.Iface.Env, mkIface and addFingerprints +-- in GHC.Iface.{Make,Recomp}, and tcLookupGlobal in GHC.Tc.Utils.Env +-- +-- - When reading interfaces, we want the identity module to +-- identify the specific interface we want (such interfaces +-- should never be loaded into the EPS). However, if a +-- hole module is requested, we look for A.hi +-- in the home library we are compiling. (See GHC.Iface.Load.) +-- Similarly, in GHC.Rename.Names we check for self-imports using +-- identity modules, to allow signatures to import their implementor. +-- +-- - For recompilation avoidance, you want the identity module, +-- since that will actually say the specific interface you +-- want to track (and recompile if it changes) + +-- | 'TcGblEnv' describes the top-level of the module at the +-- point at which the typechecker is finished work. +-- It is this structure that is handed on to the desugarer +-- For state that needs to be updated during the typechecking +-- phase and returned at end, use a 'TcRef' (= 'IORef'). +data TcGblEnv + = TcGblEnv { + tcg_mod :: Module, -- ^ Module being compiled + tcg_semantic_mod :: Module, -- ^ If a signature, the backing module + -- See also Note [Identity versus semantic module] + tcg_src :: HscSource, + -- ^ What kind of module (regular Haskell, hs-boot, hsig) + + tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming + tcg_default :: Maybe [Type], + -- ^ Types used for defaulting. @Nothing@ => no @default@ decl + + tcg_fix_env :: FixityEnv, -- ^ Just for things in this module + tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module + -- See Note [The interactive package] in "GHC.Driver.Types" + + tcg_type_env :: TypeEnv, + -- ^ Global type env for the module we are compiling now. All + -- TyCons and Classes (for this module) end up in here right away, + -- along with their derived constructors, selectors. + -- + -- (Ids defined in this module start in the local envt, though they + -- move to the global envt during zonking) + -- + -- NB: for what "things in this module" means, see + -- Note [The interactive package] in "GHC.Driver.Types" + + tcg_type_env_var :: TcRef TypeEnv, + -- Used only to initialise the interface-file + -- typechecker in initIfaceTcRn, so that it can see stuff + -- bound in this module when dealing with hi-boot recursions + -- Updated at intervals (e.g. after dealing with types and classes) + + tcg_inst_env :: !InstEnv, + -- ^ Instance envt for all /home-package/ modules; + -- Includes the dfuns in tcg_insts + -- NB. BangPattern is to fix a leak, see #15111 + tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances + -- NB. BangPattern is to fix a leak, see #15111 + tcg_ann_env :: AnnEnv, -- ^ And for annotations + + -- Now a bunch of things about this module that are simply + -- accumulated, but never consulted until the end. + -- Nevertheless, it's convenient to accumulate them along + -- with the rest of the info from this module. + tcg_exports :: [AvailInfo], -- ^ What is exported + tcg_imports :: ImportAvails, + -- ^ Information about what was imported from where, including + -- things bound in this module. Also store Safe Haskell info + -- here about transitive trusted package requirements. + -- + -- There are not many uses of this field, so you can grep for + -- all them. + -- + -- The ImportAvails records information about the following + -- things: + -- + -- 1. All of the modules you directly imported (tcRnImports) + -- 2. The orphans (only!) of all imported modules in a GHCi + -- session (runTcInteractive) + -- 3. The module that instantiated a signature + -- 4. Each of the signatures that merged in + -- + -- It is used in the following ways: + -- - imp_orphs is used to determine what orphan modules should be + -- visible in the context (tcVisibleOrphanMods) + -- - imp_finsts is used to determine what family instances should + -- be visible (tcExtendLocalFamInstEnv) + -- - To resolve the meaning of the export list of a module + -- (tcRnExports) + -- - imp_mods is used to compute usage info (mkIfaceTc, deSugar) + -- - imp_trust_own_pkg is used for Safe Haskell in interfaces + -- (mkIfaceTc, as well as in "GHC.Driver.Main") + -- - To create the Dependencies field in interface (mkDependencies) + + -- These three fields track unused bindings and imports + -- See Note [Tracking unused binding and imports] + tcg_dus :: DefUses, + tcg_used_gres :: TcRef [GlobalRdrElt], + tcg_keep :: TcRef NameSet, + + tcg_th_used :: TcRef Bool, + -- ^ @True@ \<=> Template Haskell syntax used. + -- + -- We need this so that we can generate a dependency on the + -- Template Haskell package, because the desugarer is going + -- to emit loads of references to TH symbols. The reference + -- is implicit rather than explicit, so we have to zap a + -- mutable variable. + + tcg_th_splice_used :: TcRef Bool, + -- ^ @True@ \<=> A Template Haskell splice was used. + -- + -- Splices disable recompilation avoidance (see #481) + + tcg_dfun_n :: TcRef OccSet, + -- ^ Allows us to choose unique DFun names. + + tcg_merged :: [(Module, Fingerprint)], + -- ^ The requirements we merged with; we always have to recompile + -- if any of these changed. + + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fields are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls + + tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)], + -- Nothing <=> no explicit export list + -- Is always Nothing if we don't want to retain renamed + -- exports. + -- If present contains each renamed export list item + -- together with its exported names. + + tcg_rn_imports :: [LImportDecl GhcRn], + -- Keep the renamed imports regardless. They are not + -- voluminous and are needed if you want to report unused imports + + tcg_rn_decls :: Maybe (HsGroup GhcRn), + -- ^ Renamed decls, maybe. @Nothing@ \<=> Don't retain renamed + -- decls. + + tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile + + tcg_th_topdecls :: TcRef [LHsDecl GhcPs], + -- ^ Top-level declarations from addTopDecls + + tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)], + -- ^ Foreign files emitted from TH. + + tcg_th_topnames :: TcRef NameSet, + -- ^ Exact names bound in top-level declarations in tcg_th_topdecls + + tcg_th_modfinalizers :: TcRef [(TcLclEnv, ThModFinalizers)], + -- ^ Template Haskell module finalizers. + -- + -- They can use particular local environments. + + tcg_th_coreplugins :: TcRef [String], + -- ^ Core plugins added by Template Haskell code. + + tcg_th_state :: TcRef (Map TypeRep Dynamic), + tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), + -- ^ Template Haskell state + + tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings + + -- Things defined in this module, or (in GHCi) + -- in the declarations for a single GHCi command. + -- For the latter, see Note [The interactive package] in GHC.Driver.Types + tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Unit.Module + -- for which every module has a top-level defn + -- except in GHCi in which case we have Nothing + tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module + tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature + tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids + tcg_warns :: Warnings, -- ...Warnings and deprecations + tcg_anns :: [Annotation], -- ...Annotations + tcg_tcs :: [TyCon], -- ...TyCons and Classes + tcg_insts :: [ClsInst], -- ...Instances + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl GhcTc], -- ...Rules + tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports + tcg_patsyns :: [PatSyn], -- ...Pattern synonyms + + tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs + tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the + -- prog uses hpc instrumentation. + -- NB. BangPattern is to fix a leak, see #15111 + + tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a + -- corresponding hi-boot file + + tcg_main :: Maybe Name, -- ^ The Name of the main + -- function, if this module is + -- the main module. + + tcg_safeInfer :: TcRef (Bool, WarningMessages), + -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell) + -- See Note [Safe Haskell Overlapping Instances Implementation], + -- although this is used for more than just that failure case. + + tcg_tc_plugins :: [TcPluginSolver], + -- ^ A list of user-defined plugins for the constraint solver. + tcg_hf_plugins :: [HoleFitPlugin], + -- ^ A list of user-defined plugins for hole fit suggestions. + + tcg_top_loc :: RealSrcSpan, + -- ^ The RealSrcSpan this module came from + + tcg_static_wc :: TcRef WantedConstraints, + -- ^ Wanted constraints of static forms. + -- See Note [Constraints in static forms]. + tcg_complete_matches :: [CompleteMatch], + + -- ^ Tracking indices for cost centre annotations + tcg_cc_st :: TcRef CostCentreState + } + +-- NB: topModIdentity, not topModSemantic! +-- Definition sites of orphan identities will be identity modules, not semantic +-- modules. + +-- Note [Constraints in static forms] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When a static form produces constraints like +-- +-- f :: StaticPtr (Bool -> String) +-- f = static show +-- +-- we collect them in tcg_static_wc and resolve them at the end +-- of type checking. They need to be resolved separately because +-- we don't want to resolve them in the context of the enclosing +-- expression. Consider +-- +-- g :: Show a => StaticPtr (a -> String) +-- g = static show +-- +-- If the @Show a0@ constraint that the body of the static form produces was +-- resolved in the context of the enclosing expression, then the body of the +-- static form wouldn't be closed because the Show dictionary would come from +-- g's context instead of coming from the top level. + +tcVisibleOrphanMods :: TcGblEnv -> ModuleSet +tcVisibleOrphanMods tcg_env + = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) + +instance ContainsModule TcGblEnv where + extractModule env = tcg_semantic_mod env + +type RecFieldEnv = NameEnv [FieldLabel] + -- Maps a constructor name *in this module* + -- to the fields for that constructor. + -- This is used when dealing with ".." notation in record + -- construction and pattern matching. + -- The FieldEnv deals *only* with constructors defined in *this* + -- module. For imported modules, we get the same info from the + -- TypeEnv + +data SelfBootInfo + = NoSelfBoot -- No corresponding hi-boot file + | SelfBoot + { sb_mds :: ModDetails -- There was a hi-boot file, + , sb_tcs :: NameSet } -- defining these TyCons, +-- What is sb_tcs used for? See Note [Extra dependencies from .hs-boot files] +-- in GHC.Rename.Module + + +{- Note [Tracking unused binding and imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We gather three sorts of usage information + + * tcg_dus :: DefUses (defs/uses) + Records what is defined in this module and what is used. + + Records *defined* Names (local, top-level) + and *used* Names (local or imported) + + Used (a) to report "defined but not used" + (see GHC.Rename.Names.reportUnusedNames) + (b) to generate version-tracking usage info in interface + files (see GHC.Iface.Make.mkUsedNames) + This usage info is mainly gathered by the renamer's + gathering of free-variables + + * tcg_used_gres :: TcRef [GlobalRdrElt] + Records occurrences of imported entities. + + Used only to report unused import declarations + + Records each *occurrence* an *imported* (not locally-defined) entity. + The occurrence is recorded by keeping a GlobalRdrElt for it. + These is not the GRE that is in the GlobalRdrEnv; rather it + is recorded *after* the filtering done by pickGREs. So it reflect + /how that occurrence is in scope/. See Note [GRE filtering] in + RdrName. + + * tcg_keep :: TcRef NameSet + Records names of the type constructors, data constructors, and Ids that + are used by the constraint solver. + + The typechecker may use find that some imported or + locally-defined things are used, even though they + do not appear to be mentioned in the source code: + + (a) The to/from functions for generic data types + + (b) Top-level variables appearing free in the RHS of an + orphan rule + + (c) Top-level variables appearing free in a TH bracket + See Note [Keeping things alive for Template Haskell] + in GHC.Rename.Splice + + (d) The data constructor of a newtype that is used + to solve a Coercible instance (e.g. #10347). Example + module T10347 (N, mkN) where + import Data.Coerce + newtype N a = MkN Int + mkN :: Int -> N a + mkN = coerce + + Then we wish to record `MkN` as used, since it is (morally) + used to perform the coercion in `mkN`. To do so, the + Coercible solver updates tcg_keep's TcRef whenever it + encounters a use of `coerce` that crosses newtype boundaries. + + The tcg_keep field is used in two distinct ways: + + * Desugar.addExportFlagsAndRules. Where things like (a-c) are locally + defined, we should give them an Exported flag, so that the + simplifier does not discard them as dead code, and so that they are + exposed in the interface file (but not to export to the user). + + * GHC.Rename.Names.reportUnusedNames. Where newtype data constructors + like (d) are imported, we don't want to report them as unused. + + +************************************************************************ +* * + The local typechecker environment +* * +************************************************************************ + +Note [The Global-Env/Local-Env story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type checking, we keep in the tcg_type_env + * All types and classes + * All Ids derived from types and classes (constructors, selectors) + +At the end of type checking, we zonk the local bindings, +and as we do so we add to the tcg_type_env + * Locally defined top-level Ids + +Why? Because they are now Ids not TcIds. This final GlobalEnv is + a) fed back (via the knot) to typechecking the + unfoldings of interface signatures + b) used in the ModDetails of this module +-} + +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer + = TcLclEnv { + tcl_loc :: RealSrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + tcl_in_gen_code :: Bool, -- See Note [Rebindable syntax and HsExpansion] + tcl_tclvl :: TcLevel, + + tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_th_bndrs :: ThBindEnv, -- and binder info + -- The ThBindEnv records the TH binding level of in-scope Names + -- defined in this module (not imported) + -- We can't put this info in the TypeEnv because it's needed + -- (and extended) in the renamer, for untyed splices + + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Maintained during renaming, of course, but also during + -- type checking, solely so that when renaming a Template-Haskell + -- splice we have the right environment for the renamer. + -- + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence constructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + tcl_env :: TcTypeEnv, -- The local type environment: + -- Ids and TyVars defined in this module + + tcl_usage :: TcRef UsageEnv, -- Required multiplicity of bindings is accumulated here. + + + tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, + -- and for tidying types + + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef Messages -- Place to accumulate errors + } + +setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv +setLclEnvTcLevel env lvl = env { tcl_tclvl = lvl } + +getLclEnvTcLevel :: TcLclEnv -> TcLevel +getLclEnvTcLevel = tcl_tclvl + +setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv +setLclEnvLoc env loc = env { tcl_loc = loc } + +getLclEnvLoc :: TcLclEnv -> RealSrcSpan +getLclEnvLoc = tcl_loc + +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) + -- Monadic so that we have a chance + -- to deal with bound type variables just before error + -- message construction + + -- Bool: True <=> this is a landmark context; do not + -- discard it when trimming for display + +-- These are here to avoid module loops: one might expect them +-- in GHC.Tc.Types.Constraint, but they refer to ErrCtxt which refers to TcM. +-- Easier to just keep these definitions here, alongside TcM. +pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc +pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc +-- Just add information w/o updating the origin! +pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +type TcTypeEnv = NameEnv TcTyThing + +type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) + -- Domain = all Ids bound in this module (ie not imported) + -- The TopLevelFlag tells if the binding is syntactically top level. + -- We need to know this, because the cross-stage persistence story allows + -- cross-stage at arbitrary types if the Id is bound at top level. + -- + -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being + -- bound at top level! See Note [Template Haskell levels] in GHC.Tc.Gen.Splice + +{- Note [Given Insts] + ~~~~~~~~~~~~~~~~~~ +Because of GADTs, we have to pass inwards the Insts provided by type signatures +and existential contexts. Consider + data T a where { T1 :: b -> b -> T [b] } + f :: Eq a => T a -> Bool + f (T1 x y) = [x]==[y] + +The constructor T1 binds an existential variable 'b', and we need Eq [b]. +Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we +pass it inwards. + +-} + +-- | Type alias for 'IORef'; the convention is we'll use this for mutable +-- bits of data in 'TcGblEnv' which are updated during typechecking and +-- returned at the end. +type TcRef a = IORef a +-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? +type TcId = Id +type TcIdSet = IdSet + +--------------------------- +-- The TcBinderStack +--------------------------- + +type TcBinderStack = [TcBinder] + -- This is a stack of locally-bound ids and tyvars, + -- innermost on top + -- Used only in error reporting (relevantBindings in TcError), + -- and in tidying + -- We can't use the tcl_env type environment, because it doesn't + -- keep track of the nesting order + +data TcBinder + = TcIdBndr + TcId + TopLevelFlag -- Tells whether the binding is syntactically top-level + -- (The monomorphic Ids for a recursive group count + -- as not-top-level for this purpose.) + + | TcIdBndr_ExpType -- Variant that allows the type to be specified as + -- an ExpType + Name + ExpType + TopLevelFlag + + | TcTvBndr -- e.g. case x of P (y::a) -> blah + Name -- We bind the lexical name "a" to the type of y, + TyVar -- which might be an utterly different (perhaps + -- existential) tyvar + +instance Outputable TcBinder where + ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcTvBndr name tv) = ppr name <+> ppr tv + +instance HasOccName TcBinder where + occName (TcIdBndr id _) = occName (idName id) + occName (TcIdBndr_ExpType name _ _) = occName name + occName (TcTvBndr name _) = occName name + +-- fixes #12177 +-- Builds up a list of bindings whose OccName has not been seen before +-- i.e., If ys = removeBindingShadowing xs +-- then +-- - ys is obtained from xs by deleting some elements +-- - ys has no duplicate OccNames +-- - The first duplicated OccName in xs is retained in ys +-- Overloaded so that it can be used for both GlobalRdrElt in typed-hole +-- substitutions and TcBinder when looking for relevant bindings. +removeBindingShadowing :: HasOccName a => [a] -> [a] +removeBindingShadowing bindings = reverse $ fst $ foldl + (\(bindingAcc, seenNames) binding -> + if occName binding `elemOccSet` seenNames -- if we've seen it + then (bindingAcc, seenNames) -- skip it + else (binding:bindingAcc, extendOccSet seenNames (occName binding))) + ([], emptyOccSet) bindings + + +-- | Get target platform +getPlatform :: TcM Platform +getPlatform = targetPlatform <$> getDynFlags + +--------------------------- +-- Template Haskell stages and levels +--------------------------- + +data SpliceType = Typed | Untyped + +data ThStage -- See Note [Template Haskell state diagram] + -- and Note [Template Haskell levels] in GHC.Tc.Gen.Splice + -- Start at: Comp + -- At bracket: wrap current stage in Brack + -- At splice: currently Brack: return to previous stage + -- currently Comp/Splice: compile and run + = Splice SpliceType -- Inside a top-level splice + -- This code will be run *at compile time*; + -- the result replaces the splice + -- Binding level = 0 + + | RunSplice (TcRef [ForeignRef (TH.Q ())]) + -- Set when running a splice, i.e. NOT when renaming or typechecking the + -- Haskell code for the splice. See Note [RunSplice ThLevel]. + -- + -- Contains a list of mod finalizers collected while executing the splice. + -- + -- 'addModFinalizer' inserts finalizers here, and from here they are taken + -- to construct an @HsSpliced@ annotation for untyped splices. See Note + -- [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + -- + -- For typed splices, the typechecker takes finalizers from here and + -- inserts them in the list of finalizers in the global environment. + -- + -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice". + + | Comp -- Ordinary Haskell code + -- Binding level = 1 + + | Brack -- Inside brackets + ThStage -- Enclosing stage + PendingStuff + +data PendingStuff + = RnPendingUntyped -- Renaming the inside of an *untyped* bracket + (TcRef [PendingRnSplice]) -- Pending splices in here + + | RnPendingTyped -- Renaming the inside of a *typed* bracket + + | TcPending -- Typechecking the inside of a typed bracket + (TcRef [PendingTcSplice]) -- Accumulate pending splices here + (TcRef WantedConstraints) -- and type constraints here + QuoteWrapper -- A type variable and evidence variable + -- for the overall monad of + -- the bracket. Splices are checked + -- against this monad. The evidence + -- variable is used for desugaring + -- `lift`. + + +topStage, topAnnStage, topSpliceStage :: ThStage +topStage = Comp +topAnnStage = Splice Untyped +topSpliceStage = Splice Untyped + +instance Outputable ThStage where + ppr (Splice _) = text "Splice" + ppr (RunSplice _) = text "RunSplice" + ppr Comp = text "Comp" + ppr (Brack s _) = text "Brack" <> parens (ppr s) + +type ThLevel = Int + -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice + -- Incremented when going inside a bracket, + -- decremented when going inside a splice + -- NB: ThLevel is one greater than the 'n' in Fig 2 of the + -- original "Template meta-programming for Haskell" paper + +impLevel, outerLevel :: ThLevel +impLevel = 0 -- Imported things; they can be used inside a top level splice +outerLevel = 1 -- Things defined outside brackets + +thLevel :: ThStage -> ThLevel +thLevel (Splice _) = 0 +thLevel Comp = 1 +thLevel (Brack s _) = thLevel s + 1 +thLevel (RunSplice _) = panic "thLevel: called when running a splice" + -- See Note [RunSplice ThLevel]. + +{- Node [RunSplice ThLevel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'RunSplice' stage is set when executing a splice, and only when running a +splice. In particular it is not set when the splice is renamed or typechecked. + +'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert +the finalizer (see Note [Delaying modFinalizers in untyped splices]), and +'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to +set 'RunSplice' when renaming or typechecking the splice, where 'Splice', +'Brack' or 'Comp' are used instead. + +-} + +--------------------------- +-- Arrow-notation context +--------------------------- + +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +For example + + proc x -> (e1 -< e2) + +Here, x is not in scope in e1, but it is in scope in e2. This can get +a bit complicated: + + let x = 3 in + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. + +We implement this by +recording the environment when passing a proc (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). + +All this can be dealt with by the *renamer*. But the type checker needs +to be involved too. Example (arrowfail001) + class Foo a where foo :: a -> () + data Bar = forall a. Foo a => Bar a + get :: Bar -> () + get = proc x -> case x of Bar a -> foo -< a +Here the call of 'foo' gives rise to a (Foo a) constraint that should not +be captured by the pattern match on 'Bar'. Rather it should join the +constraints from further out. So we must capture the constraint bag +from further out in the ArrowCtxt that we push inwards. +-} + +data ArrowCtxt -- Note [Escaping the arrow scope] + = NoArrowCtxt + | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) + + +--------------------------- +-- TcTyThing +--------------------------- + +-- | A typecheckable thing available in a local context. Could be +-- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. +-- See "GHC.Tc.Utils.Env" for how to retrieve a 'TyThing' given a 'Name'. +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + + | ATcId -- Ids defined in this module; may not be fully zonked + { tct_id :: TcId + , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] + } + + | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] + + | ATcTyCon TyCon -- Used temporarily, during kind checking, for the + -- tycons and clases in this recursive group + -- The TyCon is always a TcTyCon. Its kind + -- can be a mono-kind or a poly-kind; in TcTyClsDcls see + -- Note [Type checking recursive type and class declarations] + + | APromotionErr PromotionErr + +data PromotionErr + = TyConPE -- TyCon used in a kind before we are ready + -- data T :: T -> * where ... + | ClassPE -- Ditto Class + + | FamDataConPE -- Data constructor for a data family + -- See Note [AFamDataCon: not promoting data family constructors] + -- in GHC.Tc.Utils.Env. + | ConstrainedDataConPE PredType + -- Data constructor with a non-equality context + -- See Note [Don't promote data constructors with + -- non-equality contexts] in GHC.Tc.Gen.HsType + | PatSynPE -- Pattern synonyms + -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env + + | RecDataConPE -- Data constructor in a recursive loop + -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl + | NoDataKindsTC -- -XDataKinds not enabled (for a tycon) + | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) + +instance Outputable TcTyThing where -- Debugging only + ppr (AGlobal g) = ppr g + ppr elt@(ATcId {}) = text "Identifier" <> + brackets (ppr (tct_id elt) <> dcolon + <> ppr (varType (tct_id elt)) <> comma + <+> ppr (tct_info elt)) + ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv + <+> dcolon <+> ppr (varType tv) + ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) + ppr (APromotionErr err) = text "APromotionErr" <+> ppr err + +-- | IdBindingInfo describes how an Id is bound. +-- +-- It is used for the following purposes: +-- a) for static forms in 'GHC.Tc.Gen.Expr.checkClosedInStaticForm' and +-- b) to figure out when a nested binding can be generalised, +-- in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'. +-- +data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId] + = NotLetBound + | ClosedLet + | NonClosedLet + RhsNames -- Used for (static e) checks only + ClosedTypeId -- Used for generalisation checks + -- and for (static e) checks + +-- | IsGroupClosed describes a group of mutually-recursive bindings +data IsGroupClosed + = IsGroupClosed + (NameEnv RhsNames) -- Free var info for the RHS of each binding in the goup + -- Used only for (static e) checks + + ClosedTypeId -- True <=> all the free vars of the group are + -- imported or ClosedLet or + -- NonClosedLet with ClosedTypeId=True. + -- In particular, no tyvars, no NotLetBound + +type RhsNames = NameSet -- Names of variables, mentioned on the RHS of + -- a definition, that are not Global or ClosedLet + +type ClosedTypeId = Bool + -- See Note [Meaning of IdBindingInfo and ClosedTypeId] + +{- Note [Meaning of IdBindingInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NotLetBound means that + the Id is not let-bound (e.g. it is bound in a + lambda-abstraction or in a case pattern) + +ClosedLet means that + - The Id is let-bound, + - Any free term variables are also Global or ClosedLet + - Its type has no free variables (NB: a top-level binding subject + to the MR might have free vars in its type) + These ClosedLets can definitely be floated to top level; and we + may need to do so for static forms. + + Property: ClosedLet + is equivalent to + NonClosedLet emptyNameSet True + +(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that + - The Id is let-bound + + - The fvs::RhsNames contains the free names of the RHS, + excluding Global and ClosedLet ones. + + - For the ClosedTypeId field see Note [Bindings with closed types] + +For (static e) to be valid, we need for every 'x' free in 'e', +that x's binding is floatable to the top level. Specifically: + * x's RhsNames must be empty + * x's type has no free variables +See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +This test is made in GHC.Tc.Gen.Expr.checkClosedInStaticForm. +Actually knowing x's RhsNames (rather than just its emptiness +or otherwise) is just so we can produce better error messages + +Note [Bindings with closed types: ClosedTypeId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f x = let g ys = map not ys + in ... + +Can we generalise 'g' under the OutsideIn algorithm? Yes, +because all g's free variables are top-level; that is they themselves +have no free type variables, and it is the type variables in the +environment that makes things tricky for OutsideIn generalisation. + +Here's the invariant: + If an Id has ClosedTypeId=True (in its IdBindingInfo), then + the Id's type is /definitely/ closed (has no free type variables). + Specifically, + a) The Id's actual type is closed (has no free tyvars) + b) Either the Id has a (closed) user-supplied type signature + or all its free variables are Global/ClosedLet + or NonClosedLet with ClosedTypeId=True. + In particular, none are NotLetBound. + +Why is (b) needed? Consider + \x. (x :: Int, let y = x+1 in ...) +Initially x::alpha. If we happen to typecheck the 'let' before the +(x::Int), y's type will have a free tyvar; but if the other way round +it won't. So we treat any let-bound variable with a free +non-let-bound variable as not ClosedTypeId, regardless of what the +free vars of its type actually are. + +But if it has a signature, all is well: + \x. ...(let { y::Int; y = x+1 } in + let { v = y+2 } in ...)... +Here the signature on 'v' makes 'y' a ClosedTypeId, so we can +generalise 'v'. + +Note that: + + * A top-level binding may not have ClosedTypeId=True, if it suffers + from the MR + + * A nested binding may be closed (eg 'g' in the example we started + with). Indeed, that's the point; whether a function is defined at + top level or nested is orthogonal to the question of whether or + not it is closed. + + * A binding may be non-closed because it mentions a lexically scoped + *type variable* Eg + f :: forall a. blah + f x = let g y = ...(y::a)... + +Under OutsideIn we are free to generalise an Id all of whose free +variables have ClosedTypeId=True (or imported). This is an extension +compared to the JFP paper on OutsideIn, which used "top-level" as a +proxy for "closed". (It's not a good proxy anyway -- the MR can make +a top-level binding with a free type variable.) + +Note [Type variables in the type environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type environment has a binding for each lexically-scoped +type variable that is in scope. For example + + f :: forall a. a -> a + f x = (x :: a) + + g1 :: [a] -> a + g1 (ys :: [b]) = head ys :: b + + g2 :: [Int] -> Int + g2 (ys :: [c]) = head ys :: c + +* The forall'd variable 'a' in the signature scopes over f's RHS. + +* The pattern-bound type variable 'b' in 'g1' scopes over g1's + RHS; note that it is bound to a skolem 'a' which is not itself + lexically in scope. + +* The pattern-bound type variable 'c' in 'g2' is bound to + Int; that is, pattern-bound type variables can stand for + arbitrary types. (see + GHC proposal #128 "Allow ScopedTypeVariables to refer to types" + https://github.com/ghc-proposals/ghc-proposals/pull/128, + and the paper + "Type variables in patterns", Haskell Symposium 2018. + + +This is implemented by the constructor + ATyVar Name TcTyVar +in the type environment. + +* The Name is the name of the original, lexically scoped type + variable + +* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes + a unification variable (like in 'g1', 'g2'). We never zonk the + type environment so in the latter case it always stays as a + unification variable, although that variable may be later + unified with a type (such as Int in 'g2'). +-} + +instance Outputable IdBindingInfo where + ppr NotLetBound = text "NotLetBound" + ppr ClosedLet = text "TopLevelLet" + ppr (NonClosedLet fvs closed_type) = + text "TopLevelLet" <+> ppr fvs <+> ppr closed_type + +instance Outputable PromotionErr where + ppr ClassPE = text "ClassPE" + ppr TyConPE = text "TyConPE" + ppr PatSynPE = text "PatSynPE" + ppr FamDataConPE = text "FamDataConPE" + ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" + <+> parens (ppr pred) + ppr RecDataConPE = text "RecDataConPE" + ppr NoDataKindsTC = text "NoDataKindsTC" + ppr NoDataKindsDC = text "NoDataKindsDC" + +-------------- +pprTcTyThingCategory :: TcTyThing -> SDoc +pprTcTyThingCategory = text . capitalise . tcTyThingCategory + +tcTyThingCategory :: TcTyThing -> String +tcTyThingCategory (AGlobal thing) = tyThingCategory thing +tcTyThingCategory (ATyVar {}) = "type variable" +tcTyThingCategory (ATcId {}) = "local identifier" +tcTyThingCategory (ATcTyCon {}) = "local tycon" +tcTyThingCategory (APromotionErr pe) = peCategory pe + +-------------- +pprPECategory :: PromotionErr -> SDoc +pprPECategory = text . capitalise . peCategory + +peCategory :: PromotionErr -> String +peCategory ClassPE = "class" +peCategory TyConPE = "type constructor" +peCategory PatSynPE = "pattern synonym" +peCategory FamDataConPE = "data constructor" +peCategory ConstrainedDataConPE{} = "data constructor" +peCategory RecDataConPE = "data constructor" +peCategory NoDataKindsTC = "type constructor" +peCategory NoDataKindsDC = "data constructor" + +{- +************************************************************************ +* * + Operations over ImportAvails +* * +************************************************************************ +-} + +-- | 'ImportAvails' summarises what was imported from where, irrespective of +-- whether the imported things are actually used or not. It is used: +-- +-- * when processing the export list, +-- +-- * when constructing usage info for the interface file, +-- +-- * to identify the list of directly imported modules for initialisation +-- purposes and for optimised overlap checking of family instances, +-- +-- * when figuring out what things are really unused +-- +data ImportAvails + = ImportAvails { + imp_mods :: ImportedMods, + -- = ModuleEnv [ImportedModsVal], + -- ^ Domain is all directly-imported modules + -- + -- See the documentation on ImportedModsVal in "GHC.Driver.Types" for the + -- meaning of the fields. + -- + -- We need a full ModuleEnv rather than a ModuleNameEnv here, + -- because we might be importing modules of the same name from + -- different packages. (currently not the case, but might be in the + -- future). + + imp_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot, + -- ^ Home-package modules needed by the module being compiled + -- + -- It doesn't matter whether any of these dependencies + -- are actually /used/ when compiling the module; they + -- are listed if they are below it at all. For + -- example, suppose M imports A which imports X. Then + -- compiling M might not need to consult X.hi, but X + -- is still listed in M's dependencies. + + imp_dep_pkgs :: Set UnitId, + -- ^ Packages needed by the module being compiled, whether directly, + -- or via other modules in this package, or via modules imported + -- from other packages. + + imp_trust_pkgs :: Set UnitId, + -- ^ This is strictly a subset of imp_dep_pkgs and records the + -- packages the current module needs to trust for Safe Haskell + -- compilation to succeed. A package is required to be trusted if + -- we are dependent on a trustworthy module in that package. + -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool) + -- where True for the bool indicates the package is required to be + -- trusted is the more logical design, doing so complicates a lot + -- of code not concerned with Safe Haskell. + -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names" + + imp_trust_own_pkg :: Bool, + -- ^ Do we require that our own package is trusted? + -- This is to handle efficiently the case where a Safe module imports + -- a Trustworthy module that resides in the same package as it. + -- See Note [Trust Own Package] in "GHC.Rename.Names" + + imp_orphs :: [Module], + -- ^ Orphan modules below us in the import tree (and maybe including + -- us for imported modules) + + imp_finsts :: [Module] + -- ^ Family instance modules below us in the import tree (and maybe + -- including us for imported modules) + } + +mkModDeps :: [ModuleNameWithIsBoot] + -> ModuleNameEnv ModuleNameWithIsBoot +mkModDeps deps = foldl' add emptyUFM deps + where + add env elt = addToUFM env (gwib_mod elt) elt + +modDepsElts + :: ModuleNameEnv ModuleNameWithIsBoot + -> [ModuleNameWithIsBoot] +modDepsElts = sort . nonDetEltsUFM + -- It's OK to use nonDetEltsUFM here because sorting by module names + -- restores determinism + +emptyImportAvails :: ImportAvails +emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, + imp_dep_pkgs = S.empty, + imp_trust_pkgs = S.empty, + imp_trust_own_pkg = False, + imp_orphs = [], + imp_finsts = [] } + +-- | Union two ImportAvails +-- +-- This function is a key part of Import handling, basically +-- for each import we create a separate ImportAvails structure +-- and then union them all together with this function. +plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails +plusImportAvails + (ImportAvails { imp_mods = mods1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, + imp_orphs = orphs1, imp_finsts = finsts1 }) + (ImportAvails { imp_mods = mods2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, + imp_orphs = orphs2, imp_finsts = finsts2 }) + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `S.union` dpkgs2, + imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_trust_own_pkg = tself1 || tself2, + imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2 } + where + plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 }) + r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2}) + | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot))) + boot1 == IsBoot = r2 + | otherwise = r1 + -- If either side can "see" a non-hi-boot interface, use that + -- Reusing existing tuples saves 10% of allocations on test + -- perf/compiler/MultiLayerModules + +{- +************************************************************************ +* * +\subsection{Where from} +* * +************************************************************************ + +The @WhereFrom@ type controls where the renamer looks for an interface file +-} + +data WhereFrom + = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) + | ImportBySystem -- Non user import. + | ImportByPlugin -- Importing a plugin; + -- See Note [Care with plugin imports] in GHC.Iface.Load + +instance Outputable WhereFrom where + ppr (ImportByUser IsBoot) = text "{- SOURCE -}" + ppr (ImportByUser NotBoot) = empty + ppr ImportBySystem = text "{- SYSTEM -}" + ppr ImportByPlugin = text "{- PLUGIN -}" + + +{- ********************************************************************* +* * + Type signatures +* * +********************************************************************* -} + +-- These data types need to be here only because +-- GHC.Tc.Solver uses them, and GHC.Tc.Solver is fairly +-- low down in the module hierarchy + +type TcSigFun = Name -> Maybe TcSigInfo + +data TcSigInfo = TcIdSig TcIdSigInfo + | TcPatSynSig TcPatSynInfo + +data TcIdSigInfo -- See Note [Complete and partial type signatures] + = CompleteSig -- A complete signature with no wildcards, + -- so the complete polymorphic type is known. + { sig_bndr :: TcId -- The polymorphic Id with that type + + , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, + -- the Name in the FunSigCtxt is not the same + -- as the TcId; the former is 'op', while the + -- latter is '$dmop' or some such + + , sig_loc :: SrcSpan -- Location of the type signature + } + + | PartialSig -- A partial type signature (i.e. includes one or more + -- wildcards). In this case it doesn't make sense to give + -- the polymorphic Id, because we are going to /infer/ its + -- type, so we can't make the polymorphic Id ab-initio + { psig_name :: Name -- Name of the function; used when report wildcards + , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in + -- HsSyn form + , sig_ctxt :: UserTypeCtxt + , sig_loc :: SrcSpan -- Location of the type signature + } + + +{- Note [Complete and partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type signature is partial when it contains one or more wildcards +(= type holes). The wildcard can either be: +* A (type) wildcard occurring in sig_theta or sig_tau. These are + stored in sig_wcs. + f :: Bool -> _ + g :: Eq _a => _a -> _a -> Bool +* Or an extra-constraints wildcard, stored in sig_cts: + h :: (Num a, _) => a -> a + +A type signature is a complete type signature when there are no +wildcards in the type signature, i.e. iff sig_wcs is empty and +sig_extra_cts is Nothing. +-} + +data TcIdSigInst + = TISI { sig_inst_sig :: TcIdSigInfo + + , sig_inst_skols :: [(Name, InvisTVBinder)] + -- Instantiated type and kind variables, TyVarTvs + -- The Name is the Name that the renamer chose; + -- but the TcTyVar may come from instantiating + -- the type and hence have a different unique. + -- No need to keep track of whether they are truly lexically + -- scoped because the renamer has named them uniquely + -- See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig + -- + -- NB: The order of sig_inst_skols is irrelevant + -- for a CompleteSig, but for a PartialSig see + -- Note [Quantified variables in partial type signatures] + + , sig_inst_theta :: TcThetaType + -- Instantiated theta. In the case of a + -- PartialSig, sig_theta does not include + -- the extra-constraints wildcard + + , sig_inst_tau :: TcSigmaType -- Instantiated tau + -- See Note [sig_inst_tau may be polymorphic] + + -- Relevant for partial signature only + , sig_inst_wcs :: [(Name, TcTyVar)] + -- Like sig_inst_skols, but for /named/ wildcards (_a etc). + -- The named wildcards scope over the binding, and hence + -- their Names may appear in type signatures in the binding + + , sig_inst_wcx :: Maybe TcType + -- Extra-constraints wildcard to fill in, if any + -- If this exists, it is surely of the form (meta_tv |> co) + -- (where the co might be reflexive). This is filled in + -- only from the return value of GHC.Tc.Gen.HsType.tcAnonWildCardOcc + } + +{- Note [sig_inst_tau may be polymorphic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that "sig_inst_tau" might actually be a polymorphic type, +if the original function had a signature like + forall a. Eq a => forall b. Ord b => .... +But that's ok: tcMatchesFun (called by tcRhs) can deal with that +It happens, too! See Note [Polymorphic methods] in GHC.Tc.TyCl.Class. + +Note [Quantified variables in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a b. _ -> a -> _ -> b + f (x,y) p q = q + +Then we expect f's final type to be + f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b + +Note that x,y are Inferred, and can't be use for visible type +application (VTA). But a,b are Specified, and remain Specified +in the final type, so we can use VTA for them. (Exception: if +it turns out that a's kind mentions b we need to reorder them +with scopedSort.) + +The sig_inst_skols of the TISI from a partial signature records +that original order, and is used to get the variables of f's +final type in the correct order. + + +Note [Wildcards in partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wildcards in psig_wcs may stand for a type mentioning +the universally-quantified tyvars of psig_ty + +E.g. f :: forall a. _ -> a + f x = x +We get sig_inst_skols = [a] + sig_inst_tau = _22 -> a + sig_inst_wcs = [_22] +and _22 in the end is unified with the type 'a' + +Moreover the kind of a wildcard in sig_inst_wcs may mention +the universally-quantified tyvars sig_inst_skols +e.g. f :: t a -> t _ +Here we get + sig_inst_skols = [k:*, (t::k ->*), (a::k)] + sig_inst_tau = t a -> t _22 + sig_inst_wcs = [ _22::k ] +-} + +data TcPatSynInfo + = TPSI { + patsig_name :: Name, + patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and + -- implicitly-bound type vars (Specified) + -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn + patsig_univ_bndrs :: [InvisTVBinder], -- Bound by explicit user forall + patsig_req :: TcThetaType, + patsig_ex_bndrs :: [InvisTVBinder], -- Bound by explicit user forall + patsig_prov :: TcThetaType, + patsig_body_ty :: TcSigmaType + } + +instance Outputable TcSigInfo where + ppr (TcIdSig idsi) = ppr idsi + ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi + +instance Outputable TcIdSigInfo where + ppr (CompleteSig { sig_bndr = bndr }) + = ppr bndr <+> dcolon <+> ppr (idType bndr) + ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty }) + = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty + +instance Outputable TcIdSigInst where + ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols + , sig_inst_theta = theta, sig_inst_tau = tau }) + = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) + +instance Outputable TcPatSynInfo where + ppr (TPSI{ patsig_name = name}) = ppr name + +isPartialSig :: TcIdSigInst -> Bool +isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True +isPartialSig _ = False + +-- | No signature or a partial signature +hasCompleteSig :: TcSigFun -> Name -> Bool +hasCompleteSig sig_fn name + = case sig_fn name of + Just (TcIdSig (CompleteSig {})) -> True + _ -> False + + +{- +Constraint Solver Plugins +------------------------- +-} + +type TcPluginSolver = [Ct] -- given + -> [Ct] -- derived + -> [Ct] -- wanted + -> TcPluginM TcPluginResult + +newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) deriving (Functor) + +instance Applicative TcPluginM where + pure x = TcPluginM (const $ pure x) + (<*>) = ap + +instance Monad TcPluginM where + TcPluginM m >>= k = + TcPluginM (\ ev -> do a <- m ev + runTcPluginM (k a) ev) + +instance MonadFail TcPluginM where + fail x = TcPluginM (const $ fail x) + +runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a +runTcPluginM (TcPluginM m) = m + +-- | This function provides an escape for direct access to +-- the 'TcM` monad. It should not be used lightly, and +-- the provided 'TcPluginM' API should be favoured instead. +unsafeTcPluginTcM :: TcM a -> TcPluginM a +unsafeTcPluginTcM = TcPluginM . const + +-- | Access the 'EvBindsVar' carried by the 'TcPluginM' during +-- constraint solving. Returns 'Nothing' if invoked during +-- 'tcPluginInit' or 'tcPluginStop'. +getEvBindsTcPluginM :: TcPluginM EvBindsVar +getEvBindsTcPluginM = TcPluginM return + + +data TcPlugin = forall s. TcPlugin + { tcPluginInit :: TcPluginM s + -- ^ Initialize plugin, when entering type-checker. + + , tcPluginSolve :: s -> TcPluginSolver + -- ^ Solve some constraints. + -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS. + + , tcPluginStop :: s -> TcPluginM () + -- ^ Clean up after the plugin, when exiting the type-checker. + } + +data TcPluginResult + = TcPluginContradiction [Ct] + -- ^ The plugin found a contradiction. + -- The returned constraints are removed from the inert set, + -- and recorded as insoluble. + + | TcPluginOk [(EvTerm,Ct)] [Ct] + -- ^ The first field is for constraints that were solved. + -- These are removed from the inert set, + -- and the evidence for them is recorded. + -- The second field contains new work, that should be processed by + -- the constraint solver. + +{- ********************************************************************* +* * + Role annotations +* * +********************************************************************* -} + +type RoleAnnotEnv = NameEnv (LRoleAnnotDecl GhcRn) + +mkRoleAnnotEnv :: [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv +mkRoleAnnotEnv role_annot_decls + = mkNameEnv [ (name, ra_decl) + | ra_decl <- role_annot_decls + , let name = roleAnnotDeclName (unLoc ra_decl) + , not (isUnboundName name) ] + -- Some of the role annots will be unbound; + -- we don't wish to include these + +emptyRoleAnnotEnv :: RoleAnnotEnv +emptyRoleAnnotEnv = emptyNameEnv + +lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) +lookupRoleAnnot = lookupNameEnv + +getRoleAnnots :: [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn] +getRoleAnnots bndrs role_env + = mapMaybe (lookupRoleAnnot role_env) bndrs + +{- ********************************************************************* +* * + Linting a TcGblEnv +* * +********************************************************************* -} + +-- | Check the 'TcGblEnv' for consistency. Currently, only checks +-- axioms, but should check other aspects, too. +lintGblEnv :: DynFlags -> TcGblEnv -> (Bag SDoc, Bag SDoc) +lintGblEnv dflags tcg_env = lintAxioms dflags axioms + where + axioms = typeEnvCoAxioms (tcg_type_env tcg_env) diff --git a/GHC/Tc/Types.hs-boot b/GHC/Tc/Types.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types.hs-boot @@ -0,0 +1,12 @@ +module GHC.Tc.Types where + +import GHC.Tc.Utils.TcType +import GHC.Types.SrcLoc + +data TcLclEnv + +setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv +getLclEnvTcLevel :: TcLclEnv -> TcLevel + +setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv +getLclEnvLoc :: TcLclEnv -> RealSrcSpan diff --git a/GHC/Tc/Types/Constraint.hs b/GHC/Tc/Types/Constraint.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Constraint.hs @@ -0,0 +1,1853 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | This module defines types and simple operations over constraints, as used +-- in the type-checker and constraint solver. +module GHC.Tc.Types.Constraint ( + -- QCInst + QCInst(..), isPendingScInst, + + -- Canonical constraints + Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts, + singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, + isEmptyCts, isCTyEqCan, isCFunEqCan, + isPendingScDict, superClassesMightHelp, getPendingWantedScs, + isCDictCan_Maybe, isCFunEqCan_maybe, + isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt, + isUserTypeErrorCt, getUserTypeErrorMsg, + ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, + ctEvId, mkTcEqPredLikeEv, + mkNonCanonical, mkNonCanonicalCt, mkGivens, + mkIrredCt, + ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, + ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, + tyCoVarsOfCt, tyCoVarsOfCts, + tyCoVarsOfCtList, tyCoVarsOfCtsList, + + Hole(..), HoleSort(..), isOutOfScopeHole, + + WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, + isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, + addInsols, dropMisleading, addSimples, addImplics, addHoles, + tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, + tyCoVarsOfWCList, insolubleCt, insolubleEqCt, + isDroppableCt, insolubleImplic, + arisesFromGivens, + + Implication(..), implicationPrototype, + ImplicStatus(..), isInsolubleStatus, isSolvedStatus, + SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, + bumpSubGoalDepth, subGoalDepthExceeded, + CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, + ctLocTypeOrKind_maybe, + ctLocDepth, bumpCtLocDepth, isGivenLoc, + setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, + pprCtLoc, + + -- CtEvidence + CtEvidence(..), TcEvDest(..), + mkKindLoc, toKindLoc, mkGivenLoc, + isWanted, isGiven, isDerived, isGivenOrWDeriv, + ctEvRole, + + wrapType, + + CtFlavour(..), ShadowInfo(..), ctEvFlavour, + CtFlavourRole, ctEvFlavourRole, ctFlavourRole, + eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR, + eqCanDischargeFR, + funEqCanDischarge, funEqCanDischargeF, + + -- Pretty printing + pprEvVarTheta, + pprEvVars, pprEvVarWithType, + + ) + where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Types ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel + , setLclEnvLoc, getLclEnvLoc ) + +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Types.Var + +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin + +import GHC.Core + +import GHC.Core.TyCo.Ppr +import GHC.Types.Name.Occurrence +import GHC.Utils.FV +import GHC.Types.Var.Set +import GHC.Driver.Session +import GHC.Types.Basic + +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Utils.Misc + +import Control.Monad ( msum ) + +{- +************************************************************************ +* * +* Canonical constraints * +* * +* These are the constraints the low-level simplifier works with * +* * +************************************************************************ +-} + +-- The syntax of xi (ξ) types: +-- xi ::= a | T xis | xis -> xis | ... | forall a. tau +-- Two important notes: +-- (i) No type families, unless we are under a ForAll +-- (ii) Note that xi types can contain unexpanded type synonyms; +-- however, the (transitive) expansions of those type synonyms +-- will not contain any type functions, unless we are under a ForAll. +-- We enforce the structure of Xi types when we flatten (GHC.Tc.Solver.Canonical) + +type Xi = Type -- In many comments, "xi" ranges over Xi + +type Cts = Bag Ct + +data Ct + -- Atomic canonical constraints + = CDictCan { -- e.g. Num xi + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + + cc_class :: Class, + cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi + + cc_pend_sc :: Bool -- See Note [The superclass story] in GHC.Tc.Solver.Canonical + -- True <=> (a) cc_class has superclasses + -- (b) we have not (yet) added those + -- superclasses as Givens + } + + | CIrredCan { -- These stand for yet-unusable predicates + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_status :: CtIrredStatus + + -- For the might-be-soluble case, the ctev_pred of the evidence is + -- of form (tv xi1 xi2 ... xin) with a tyvar at the head + -- or (tv1 ~ ty2) where the CTyEqCan kind invariant (TyEq:K) fails + -- or (F tys ~ ty) where the CFunEqCan kind invariant fails + -- See Note [CIrredCan constraints] + + -- The definitely-insoluble case is for things like + -- Int ~ Bool tycons don't match + -- a ~ [a] occurs check + } + + | CTyEqCan { -- tv ~ rhs + -- Invariants: + -- * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad + -- * (TyEq:OC) tv not in deep tvs(rhs) (occurs check) + -- * (TyEq:F) If tv is a TauTv, then rhs has no foralls + -- (this avoids substituting a forall for the tyvar in other types) + -- * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] + -- * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*, + -- See Note [Almost function-free] + -- * (TyEq:N) If the equality is representational, rhs has no top-level newtype + -- See Note [No top-level newtypes on RHS of representational + -- equalities] in GHC.Tc.Solver.Canonical + -- * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented + -- to give best chance of + -- unification happening; eg if rhs is touchable then lhs is too + -- See "GHC.Tc.Solver.Canonical" Note [Canonical orientation for tyvar/tyvar equality constraints] + -- * (TyEq:H) The RHS has no blocking coercion holes. See "GHC.Tc.Solver.Canonical" + -- Note [Equalities with incompatible kinds], wrinkle (2) + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_tyvar :: TcTyVar, + cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) + -- See invariants above + + cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev + } + + | CFunEqCan { -- F xis ~ fsk + -- Invariants: + -- * isTypeFamilyTyCon cc_fun + -- * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant] + -- * always Nominal role + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_fun :: TyCon, -- A type function + + cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) + -- Either under-saturated or exactly saturated + -- *never* over-saturated (because if so + -- we should have decomposed) + + cc_fsk :: TcTyVar -- [G] always a FlatSkolTv + -- [W], [WD], or [D] always a FlatMetaTv + -- See Note [The flattening story] in GHC.Tc.Solver.Flatten + } + + | CNonCanonical { -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad + cc_ev :: CtEvidence + } + + | CQuantCan QCInst -- A quantified constraint + -- NB: I expect to make more of the cases in Ct + -- look like this, with the payload in an + -- auxiliary type + +------------ +data QCInst -- A much simplified version of ClsInst + -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical + = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty + -- Always Given + , qci_tvs :: [TcTyVar] -- The tvs + , qci_pred :: TcPredType -- The ty + , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan + -- Invariant: True => qci_pred is a ClassPred + } + +instance Outputable QCInst where + ppr (QCI { qci_ev = ev }) = ppr ev + +------------ +-- | A hole stores the information needed to report diagnostics +-- about holes in terms (unbound identifiers or underscores) or +-- in types (also called wildcards, as used in partial type +-- signatures). See Note [Holes]. +data Hole + = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this? + , hole_occ :: OccName -- ^ The name of this hole + , hole_ty :: TcType -- ^ Type to be printed to the user + -- For expression holes: type of expr + -- For type holes: the missing type + , hole_loc :: CtLoc -- ^ Where hole was written + } + -- For the hole_loc, we usually only want the TcLclEnv stored within. + -- Except when we flatten, where we need a whole location. And this + -- might get reported to the user if reducing type families in a + -- hole type loops. + + +-- | Used to indicate which sort of hole we have. +data HoleSort = ExprHole Id + -- ^ Either an out-of-scope variable or a "true" hole in an + -- expression (TypedHoles). + -- The 'Id' is where to store "evidence": this evidence + -- will be an erroring expression for -fdefer-type-errors. + | TypeHole + -- ^ A hole in a type (PartialTypeSignatures) + +instance Outputable Hole where + ppr (Hole { hole_sort = ExprHole id + , hole_occ = occ + , hole_ty = ty }) + = parens $ (braces $ ppr occ <> colon <> ppr id) <+> dcolon <+> ppr ty + ppr (Hole { hole_sort = TypeHole + , hole_occ = occ + , hole_ty = ty }) + = braces $ ppr occ <> colon <> ppr ty + +instance Outputable HoleSort where + ppr (ExprHole id) = text "ExprHole:" <> ppr id + ppr TypeHole = text "TypeHole" + +------------ +-- | Used to indicate extra information about why a CIrredCan is irreducible +data CtIrredStatus + = InsolubleCIS -- this constraint will never be solved + | BlockedCIS -- this constraint is blocked on a coercion hole + -- The hole will appear in the ctEvPred of the constraint with this status + -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" + -- Wrinkle (4a) + | OtherCIS + +instance Outputable CtIrredStatus where + ppr InsolubleCIS = text "(insoluble)" + ppr BlockedCIS = text "(blocked)" + ppr OtherCIS = text "(soluble)" + +{- Note [CIrredCan constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CIrredCan constraints are used for constraints that are "stuck" + - we can't solve them (yet) + - we can't use them to solve other constraints + - but they may become soluble if we substitute for some + of the type variables in the constraint + +Example 1: (c Int), where c :: * -> Constraint. We can't do anything + with this yet, but if later c := Num, *then* we can solve it + +Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable + We don't want to use this to substitute 'b' for 'a', in case + 'k' is subsequently unified with (say) *->*, because then + we'd have ill-kinded types floating about. Rather we want + to defer using the equality altogether until 'k' get resolved. + +Note [Ct/evidence invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field +of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, + ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) +This holds by construction; look at the unique place where CDictCan is +built (in GHC.Tc.Solver.Canonical). + +In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in +the evidence may *not* be fully zonked; we are careful not to look at it +during constraint solving. See Note [Evidence field of CtEvidence]. + +Note [Ct kind invariant] +~~~~~~~~~~~~~~~~~~~~~~~~ +CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind +of the rhs. This is necessary because both constraints are used for substitutions +during solving. If the kinds differed, then the substitution would take a well-kinded +type to an ill-kinded one. + +Note [Almost function-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type is *almost function-free* if it has no type functions (something that +responds True to isTypeFamilyTyCon), except (possibly) + * under a forall, or + * in a coercion (either in a CastTy or a CercionTy) + +The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF). +This is for two reasons: + +1. There cannot be a top-level function. If there were, the equality should + really be a CFunEqCan, not a CTyEqCan. + +2. Nested functions aren't too bad, on the other hand. However, consider this + scenario: + + type family F a = r | r -> a + + [D] F ty1 ~ fsk1 + [D] F ty2 ~ fsk2 + [D] fsk1 ~ [G Int] + [D] fsk2 ~ [G Bool] + + type instance G Int = Char + type instance G Bool = Char + + If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 -- + good! They don't look equal -- but if we aggressively reduce that G Int and + G Bool they would become equal. The "almost function free" makes sure that + these redexes are exposed. + + Note that this equality does *not* depend on casts or coercions, and so + skipping these forms is OK. In addition, the result of a type family cannot + be a polytype, so skipping foralls is OK, too. We skip foralls because we + want the output of the flattener to be almost function-free. See Note + [Flattening under a forall] in GHC.Tc.Solver.Flatten. + + As I (Richard E) write this, it is unclear if the scenario pictured above + can happen -- I would expect the G Int and G Bool to be reduced. But + perhaps it can arise somehow, and maintaining almost function-free is cheap. + +Historical note: CTyEqCans used to require only condition (1) above: that no +type family was at the top of an RHS. But work on #16512 suggested that the +injectivity checks were not complete, and adding the requirement that functions +do not appear even in a nested fashion was easy (it was already true, but +unenforced). + +The almost-function-free property is checked by isAlmostFunctionFree in GHC.Tc.Utils.TcType. +The flattener (in GHC.Tc.Solver.Flatten) produces types that are almost function-free. + +Note [Holes] +~~~~~~~~~~~~ +This Note explains how GHC tracks *holes*. + +A hole represents one of two conditions: + - A missing bit of an expression. Example: foo x = x + _ + - A missing bit of a type. Example: bar :: Int -> _ + +What these have in common is that both cause GHC to emit a diagnostic to the +user describing the bit that is left out. + +When a hole is encountered, a new entry of type Hole is added to the ambient +WantedConstraints. The type (hole_ty) of the hole is then simplified during +solving (with respect to any Givens in surrounding implications). It is +reported with all the other errors in GHC.Tc.Errors. No type family reduction +is done on hole types; this is purely because we think it will produce +better error messages not to reduce type families. This is why the +GHC.Tc.Solver.Flatten.flattenType function uses FM_SubstOnly. + +For expression holes, the user has the option of deferring errors until runtime +with -fdefer-type-errors. In this case, the hole actually has evidence: this +evidence is an erroring expression that prints an error and crashes at runtime. +The ExprHole variant of holes stores the Id that will be bound to this evidence; +during constraint generation, this Id was inserted into the expression output +by the type checker. + +You might think that the type of the stored Id is the same as the type of the +hole. However, because the hole type (hole_ty) is rewritten with respect to +givens, this might not be the case. That is, the hole_ty is always (~) to the +type of the Id, but they might not be `eqType`. We need the type of the generated +evidence to match what is expected in the context of the hole, and so we must +store these types separately. + +Type-level holes have no evidence at all. +-} + +mkNonCanonical :: CtEvidence -> Ct +mkNonCanonical ev = CNonCanonical { cc_ev = ev } + +mkNonCanonicalCt :: Ct -> Ct +mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } + +mkIrredCt :: CtIrredStatus -> CtEvidence -> Ct +mkIrredCt status ev = CIrredCan { cc_ev = ev, cc_status = status } + +mkGivens :: CtLoc -> [EvId] -> [Ct] +mkGivens loc ev_ids + = map mk ev_ids + where + mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id + , ctev_pred = evVarPred ev_id + , ctev_loc = loc }) + +ctEvidence :: Ct -> CtEvidence +ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev +ctEvidence ct = cc_ev ct + +ctLoc :: Ct -> CtLoc +ctLoc = ctEvLoc . ctEvidence + +setCtLoc :: Ct -> CtLoc -> Ct +setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } } + +ctOrigin :: Ct -> CtOrigin +ctOrigin = ctLocOrigin . ctLoc + +ctPred :: Ct -> PredType +-- See Note [Ct/evidence invariant] +ctPred ct = ctEvPred (ctEvidence ct) + +ctEvId :: Ct -> EvVar +-- The evidence Id for this Ct +ctEvId ct = ctEvEvId (ctEvidence ct) + +-- | Makes a new equality predicate with the same role as the given +-- evidence. +mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType +mkTcEqPredLikeEv ev + = case predTypeEqRel pred of + NomEq -> mkPrimEqPred + ReprEq -> mkReprPrimEqPred + where + pred = ctEvPred ev + +-- | Get the flavour of the given 'Ct' +ctFlavour :: Ct -> CtFlavour +ctFlavour = ctEvFlavour . ctEvidence + +-- | Get the equality relation for the given 'Ct' +ctEqRel :: Ct -> EqRel +ctEqRel = ctEvEqRel . ctEvidence + +instance Outputable Ct where + ppr ct = ppr (ctEvidence ct) <+> parens pp_sort + where + pp_sort = case ct of + CTyEqCan {} -> text "CTyEqCan" + CFunEqCan {} -> text "CFunEqCan" + CNonCanonical {} -> text "CNonCanonical" + CDictCan { cc_pend_sc = pend_sc } + | pend_sc -> text "CDictCan(psc)" + | otherwise -> text "CDictCan" + CIrredCan { cc_status = status } -> text "CIrredCan" <> ppr status + CQuantCan (QCI { qci_pend_sc = pend_sc }) + | pend_sc -> text "CQuantCan(psc)" + | otherwise -> text "CQuantCan" + +{- +************************************************************************ +* * + Simple functions over evidence variables +* * +************************************************************************ +-} + +---------------- Getting free tyvars ------------------------- + +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCt :: Ct -> TcTyCoVarSet +tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt + +-- | Returns free variables of constraints as a deterministically ordered. +-- list. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfCtList :: Ct -> [TcTyCoVar] +tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfCt :: Ct -> FV +tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) + -- This must consult only the ctPred, so that it gets *tidied* fvs if the + -- constraint has been tidied. Tidying a constraint does not tidy the + -- fields of the Ct, only the predicate in the CtEvidence. + +-- | Returns free variables of a bag of constraints as a non-deterministic +-- set. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfCts :: Cts -> TcTyCoVarSet +tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a deterministically +-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] +tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfCts :: Cts -> FV +tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV + +-- | Returns free variables of WantedConstraints as a non-deterministic +-- set. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a deterministically +-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a composable FV +-- computation. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfWC :: WantedConstraints -> FV +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes }) + = tyCoFVsOfCts simple `unionFV` + tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV` + tyCoFVsOfBag tyCoFVsOfHole holes + +-- | Returns free variables of Implication as a composable FV computation. +-- See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfImplic :: Implication -> FV +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoFVsOfImplic (Implic { ic_skols = skols + , ic_given = givens + , ic_wanted = wanted }) + | isEmptyWC wanted + = emptyFV + | otherwise + = tyCoFVsVarBndrs skols $ + tyCoFVsVarBndrs givens $ + tyCoFVsOfWC wanted + +tyCoFVsOfHole :: Hole -> FV +tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty + +tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV +tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV + +--------------------------- +dropDerivedWC :: WantedConstraints -> WantedConstraints +-- See Note [Dropping derived constraints] +dropDerivedWC wc@(WC { wc_simple = simples }) + = wc { wc_simple = dropDerivedSimples simples } + -- The wc_impl implications are already (recursively) filtered + +-------------------------- +dropDerivedSimples :: Cts -> Cts +-- Drop all Derived constraints, but make [W] back into [WD], +-- so that if we re-simplify these constraints we will get all +-- the right derived constraints re-generated. Forgetting this +-- step led to #12936 +dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples + +dropDerivedCt :: Ct -> Maybe Ct +dropDerivedCt ct + = case ctEvFlavour ev of + Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) + Wanted _ -> Just ct' + _ | isDroppableCt ct -> Nothing + | otherwise -> Just ct + where + ev = ctEvidence ct + ev_wd = ev { ctev_nosh = WDeriv } + ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] + +{- Note [Resetting cc_pend_sc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we discard Derived constraints, in dropDerivedSimples, we must +set the cc_pend_sc flag to True, so that if we re-process this +CDictCan we will re-generate its derived superclasses. Otherwise +we might miss some fundeps. #13662 showed this up. + +See Note [The superclass story] in GHC.Tc.Solver.Canonical. +-} + +isDroppableCt :: Ct -> Bool +isDroppableCt ct + = isDerived ev && not keep_deriv + -- Drop only derived constraints, and then only if they + -- obey Note [Dropping derived constraints] + where + ev = ctEvidence ct + loc = ctEvLoc ev + orig = ctLocOrigin loc + + keep_deriv + = case ct of + CIrredCan { cc_status = InsolubleCIS } -> keep_eq True + _ -> keep_eq False + + keep_eq definitely_insoluble + | isGivenOrigin orig -- Arising only from givens + = definitely_insoluble -- Keep only definitely insoluble + | otherwise + = case orig of + -- See Note [Dropping derived constraints] + -- For fundeps, drop wanted/wanted interactions + FunDepOrigin2 {} -> True -- Top-level/Wanted + FunDepOrigin1 _ orig1 _ _ orig2 _ + | g1 || g2 -> True -- Given/Wanted errors: keep all + | otherwise -> False -- Wanted/Wanted errors: discard + where + g1 = isGivenOrigin orig1 + g2 = isGivenOrigin orig2 + + _ -> False + +arisesFromGivens :: Ct -> Bool +arisesFromGivens ct + = case ctEvidence ct of + CtGiven {} -> True + CtWanted {} -> False + CtDerived { ctev_loc = loc } -> isGivenLoc loc + +isGivenLoc :: CtLoc -> Bool +isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) + +{- Note [Dropping derived constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we discard derived constraints at the end of constraint solving; +see dropDerivedWC. For example + + * Superclasses: if we have an unsolved [W] (Ord a), we don't want to + complain about an unsolved [D] (Eq a) as well. + + * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate + [D] Int ~ Bool, and we don't want to report that because it's + incomprehensible. That is why we don't rewrite wanteds with wanteds! + + * We might float out some Wanteds from an implication, leaving behind + their insoluble Deriveds. For example: + + forall a[2]. [W] alpha[1] ~ Int + [W] alpha[1] ~ Bool + [D] Int ~ Bool + + The Derived is insoluble, but we very much want to drop it when floating + out. + +But (tiresomely) we do keep *some* Derived constraints: + + * Type holes are derived constraints, because they have no evidence + and we want to keep them, so we get the error report + + * We keep most derived equalities arising from functional dependencies + - Given/Given interactions (subset of FunDepOrigin1): + The definitely-insoluble ones reflect unreachable code. + + Others not-definitely-insoluble ones like [D] a ~ Int do not + reflect unreachable code; indeed if fundeps generated proofs, it'd + be a useful equality. See #14763. So we discard them. + + - Given/Wanted interacGiven or Wanted interacting with an + instance declaration (FunDepOrigin2) + + - Given/Wanted interactions (FunDepOrigin1); see #9612 + + - But for Wanted/Wanted interactions we do /not/ want to report an + error (#13506). Consider [W] C Int Int, [W] C Int Bool, with + a fundep on class C. We don't want to report an insoluble Int~Bool; + c.f. "wanteds do not rewrite wanteds". + +To distinguish these cases we use the CtOrigin. + +NB: we keep *all* derived insolubles under some circumstances: + + * They are looked at by simplifyInfer, to decide whether to + generalise. Example: [W] a ~ Int, [W] a ~ Bool + We get [D] Int ~ Bool, and indeed the constraints are insoluble, + and we want simplifyInfer to see that, even though we don't + ultimately want to generate an (inexplicable) error message from it + + +************************************************************************ +* * + CtEvidence + The "flavor" of a canonical constraint +* * +************************************************************************ +-} + +isWantedCt :: Ct -> Bool +isWantedCt = isWanted . ctEvidence + +isGivenCt :: Ct -> Bool +isGivenCt = isGiven . ctEvidence + +isDerivedCt :: Ct -> Bool +isDerivedCt = isDerived . ctEvidence + +isCTyEqCan :: Ct -> Bool +isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan _ = False + +isCDictCan_Maybe :: Ct -> Maybe Class +isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls +isCDictCan_Maybe _ = Nothing + +isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) +isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) +isCFunEqCan_maybe _ = Nothing + +isCFunEqCan :: Ct -> Bool +isCFunEqCan (CFunEqCan {}) = True +isCFunEqCan _ = False + +isCNonCanonical :: Ct -> Bool +isCNonCanonical (CNonCanonical {}) = True +isCNonCanonical _ = False + +{- Note [Custom type errors in constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When GHC reports a type-error about an unsolved-constraint, we check +to see if the constraint contains any custom-type errors, and if so +we report them. Here are some examples of constraints containing type +errors: + +TypeError msg -- The actual constraint is a type error + +TypError msg ~ Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + +Eq (TypeError msg) -- A class constraint is stuck due to a type error + +F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err + +It is also possible to have constraints where the type error is nested deeper, +for example see #11990, and also: + +Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. +-} + +-- | A constraint is considered to be a custom type error, if it contains +-- custom type errors anywhere in it. +-- See Note [Custom type errors in constraints] +getUserTypeErrorMsg :: Ct -> Maybe Type +getUserTypeErrorMsg ct = findUserTypeError (ctPred ct) + where + findUserTypeError t = msum ( userTypeError_maybe t + : map findUserTypeError (subTys t) + ) + + subTys t = case splitAppTys t of + (t,[]) -> + case splitTyConApp_maybe t of + Nothing -> [] + Just (_,ts) -> ts + (t,ts) -> t : ts + + + + +isUserTypeErrorCt :: Ct -> Bool +isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of + Just _ -> True + _ -> False + +isPendingScDict :: Ct -> Maybe Ct +-- Says whether this is a CDictCan with cc_pend_sc is True, +-- AND if so flips the flag +isPendingScDict ct@(CDictCan { cc_pend_sc = True }) + = Just (ct { cc_pend_sc = False }) +isPendingScDict _ = Nothing + +isPendingScInst :: QCInst -> Maybe QCInst +-- Same as isPendingScDict, but for QCInsts +isPendingScInst qci@(QCI { qci_pend_sc = True }) + = Just (qci { qci_pend_sc = False }) +isPendingScInst _ = Nothing + +setPendingScDict :: Ct -> Ct +-- Set the cc_pend_sc flag to True +setPendingScDict ct@(CDictCan { cc_pend_sc = False }) + = ct { cc_pend_sc = True } +setPendingScDict ct = ct + +superClassesMightHelp :: WantedConstraints -> Bool +-- ^ True if taking superclasses of givens, or of wanteds (to perhaps +-- expose more equalities or functional dependencies) might help to +-- solve this constraint. See Note [When superclasses help] +superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) + = anyBag might_help_ct simples || anyBag might_help_implic implics + where + might_help_implic ic + | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) + | otherwise = False + + might_help_ct ct = isWantedCt ct && not (is_ip ct) + + is_ip (CDictCan { cc_class = cls }) = isIPClass cls + is_ip _ = False + +getPendingWantedScs :: Cts -> ([Ct], Cts) +getPendingWantedScs simples + = mapAccumBagL get [] simples + where + get acc ct | Just ct' <- isPendingScDict ct + = (ct':acc, ct') + | otherwise + = (acc, ct) + +{- Note [When superclasses help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First read Note [The superclass story] in GHC.Tc.Solver.Canonical. + +We expand superclasses and iterate only if there is at unsolved wanted +for which expansion of superclasses (e.g. from given constraints) +might actually help. The function superClassesMightHelp tells if +doing this superclass expansion might help solve this constraint. +Note that + + * We look inside implications; maybe it'll help to expand the Givens + at level 2 to help solve an unsolved Wanted buried inside an + implication. E.g. + forall a. Ord a => forall b. [W] Eq a + + * Superclasses help only for Wanted constraints. Derived constraints + are not really "unsolved" and we certainly don't want them to + trigger superclass expansion. This was a good part of the loop + in #11523 + + * Even for Wanted constraints, we say "no" for implicit parameters. + we have [W] ?x::ty, expanding superclasses won't help: + - Superclasses can't be implicit parameters + - If we have a [G] ?x:ty2, then we'll have another unsolved + [D] ty ~ ty2 (from the functional dependency) + which will trigger superclass expansion. + + It's a bit of a special case, but it's easy to do. The runtime cost + is low because the unsolved set is usually empty anyway (errors + aside), and the first non-implicit-parameter will terminate the search. + + The special case is worth it (#11480, comment:2) because it + applies to CallStack constraints, which aren't type errors. If we have + f :: (C a) => blah + f x = ...undefined... + we'll get a CallStack constraint. If that's the only unsolved + constraint it'll eventually be solved by defaulting. So we don't + want to emit warnings about hitting the simplifier's iteration + limit. A CallStack constraint really isn't an unsolved + constraint; it can always be solved by defaulting. +-} + +singleCt :: Ct -> Cts +singleCt = unitBag + +andCts :: Cts -> Cts -> Cts +andCts = unionBags + +listToCts :: [Ct] -> Cts +listToCts = listToBag + +ctsElts :: Cts -> [Ct] +ctsElts = bagToList + +consCts :: Ct -> Cts -> Cts +consCts = consBag + +snocCts :: Cts -> Ct -> Cts +snocCts = snocBag + +extendCtsList :: Cts -> [Ct] -> Cts +extendCtsList cts xs | null xs = cts + | otherwise = cts `unionBags` listToBag xs + +andManyCts :: [Cts] -> Cts +andManyCts = unionManyBags + +emptyCts :: Cts +emptyCts = emptyBag + +isEmptyCts :: Cts -> Bool +isEmptyCts = isEmptyBag + +pprCts :: Cts -> SDoc +pprCts cts = vcat (map ppr (bagToList cts)) + +{- +************************************************************************ +* * + Wanted constraints + These are forced to be in GHC.Tc.Types because + TcLclEnv mentions WantedConstraints + WantedConstraint mentions CtLoc + CtLoc mentions ErrCtxt + ErrCtxt mentions TcM +* * +v%************************************************************************ +-} + +data WantedConstraints + = WC { wc_simple :: Cts -- Unsolved constraints, all wanted + , wc_impl :: Bag Implication + , wc_holes :: Bag Hole + } + +emptyWC :: WantedConstraints +emptyWC = WC { wc_simple = emptyBag + , wc_impl = emptyBag + , wc_holes = emptyBag } + +mkSimpleWC :: [CtEvidence] -> WantedConstraints +mkSimpleWC cts + = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) } + +mkImplicWC :: Bag Implication -> WantedConstraints +mkImplicWC implic + = emptyWC { wc_impl = implic } + +isEmptyWC :: WantedConstraints -> Bool +isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_holes = holes }) + = isEmptyBag f && isEmptyBag i && isEmptyBag holes + +-- | Checks whether a the given wanted constraints are solved, i.e. +-- that there are no simple constraints left and all the implications +-- are solved. +isSolvedWC :: WantedConstraints -> Bool +isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_holes = holes} = + isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag holes + +andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints +andWC (WC { wc_simple = f1, wc_impl = i1, wc_holes = h1 }) + (WC { wc_simple = f2, wc_impl = i2, wc_holes = h2 }) + = WC { wc_simple = f1 `unionBags` f2 + , wc_impl = i1 `unionBags` i2 + , wc_holes = h1 `unionBags` h2 } + +unionsWC :: [WantedConstraints] -> WantedConstraints +unionsWC = foldr andWC emptyWC + +addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints +addSimples wc cts + = wc { wc_simple = wc_simple wc `unionBags` cts } + -- Consider: Put the new constraints at the front, so they get solved first + +addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints +addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } + +addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints +addInsols wc cts + = wc { wc_simple = wc_simple wc `unionBags` cts } + +addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints +addHoles wc holes + = wc { wc_holes = holes `unionBags` wc_holes wc } + +dropMisleading :: WantedConstraints -> WantedConstraints +-- Drop misleading constraints; really just class constraints +-- See Note [Constraints and errors] in GHC.Tc.Utils.Monad +dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes }) + = WC { wc_simple = filterBag keep_ct simples + , wc_impl = mapBag drop_implic implics + , wc_holes = filterBag isOutOfScopeHole holes } + where + drop_implic implic + = implic { ic_wanted = dropMisleading (ic_wanted implic) } + keep_ct ct + = case classifyPredType (ctPred ct) of + ClassPred {} -> False + _ -> True + +isSolvedStatus :: ImplicStatus -> Bool +isSolvedStatus (IC_Solved {}) = True +isSolvedStatus _ = False + +isInsolubleStatus :: ImplicStatus -> Bool +isInsolubleStatus IC_Insoluble = True +isInsolubleStatus IC_BadTelescope = True +isInsolubleStatus _ = False + +insolubleImplic :: Implication -> Bool +insolubleImplic ic = isInsolubleStatus (ic_status ic) + +insolubleWC :: WantedConstraints -> Bool +insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_holes = holes }) + = anyBag insolubleCt simples + || anyBag insolubleImplic implics + || anyBag isOutOfScopeHole holes -- See Note [Insoluble holes] + +insolubleCt :: Ct -> Bool +-- Definitely insoluble, in particular /excluding/ type-hole constraints +-- Namely: a) an equality constraint +-- b) that is insoluble +-- c) and does not arise from a Given +insolubleCt ct + | not (insolubleEqCt ct) = False + | arisesFromGivens ct = False -- See Note [Given insolubles] + | otherwise = True + +insolubleEqCt :: Ct -> Bool +-- Returns True of /equality/ constraints +-- that are /definitely/ insoluble +-- It won't detect some definite errors like +-- F a ~ T (F a) +-- where F is a type family, which actually has an occurs check +-- +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- E.g. It'll reply True for a ~ [a] +-- but False for [a] ~ a +-- and +-- True for Int ~ F a Int +-- but False for Maybe Int ~ F a Int Int +-- (where F is an arity-1 type function) +insolubleEqCt (CIrredCan { cc_status = InsolubleCIS }) = True +insolubleEqCt _ = False + +-- | Does this hole represent an "out of scope" error? +-- See Note [Insoluble holes] +isOutOfScopeHole :: Hole -> Bool +isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore occ) + +instance Outputable WantedConstraints where + ppr (WC {wc_simple = s, wc_impl = i, wc_holes = h}) + = text "WC" <+> braces (vcat + [ ppr_bag (text "wc_simple") s + , ppr_bag (text "wc_impl") i + , ppr_bag (text "wc_holes") h ]) + +ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc +ppr_bag doc bag + | isEmptyBag bag = empty + | otherwise = hang (doc <+> equals) + 2 (foldr (($$) . ppr) empty bag) + +{- Note [Given insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14325, comment:) + class (a~b) => C a b + + foo :: C a c => a -> c + foo x = x + + hm3 :: C (f b) b => b -> f b + hm3 x = foo x + +In the RHS of hm3, from the [G] C (f b) b we get the insoluble +[G] f b ~# b. Then we also get an unsolved [W] C b (f b). +Residual implication looks like + forall b. C (f b) b => [G] f b ~# b + [W] C f (f b) + +We do /not/ want to set the implication status to IC_Insoluble, +because that'll suppress reports of [W] C b (f b). But we +may not report the insoluble [G] f b ~# b either (see Note [Given errors] +in GHC.Tc.Errors), so we may fail to report anything at all! Yikes. + +The same applies to Derived constraints that /arise from/ Givens. +E.g. f :: (C Int [a]) => blah +where a fundep means we get + [D] Int ~ [a] +By the same reasoning we must not suppress other errors (#15767) + +Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) + should ignore givens even if they are insoluble. + +Note [Insoluble holes] +~~~~~~~~~~~~~~~~~~~~~~ +Hole constraints that ARE NOT treated as truly insoluble: + a) type holes, arising from PartialTypeSignatures, + b) "true" expression holes arising from TypedHoles + +An "expression hole" or "type hole" isn't really an error +at all; it's a report saying "_ :: Int" here. But an out-of-scope +variable masquerading as expression holes IS treated as truly +insoluble, so that it trumps other errors during error reporting. +Yuk! + +************************************************************************ +* * + Implication constraints +* * +************************************************************************ +-} + +data Implication + = Implic { -- Invariants for a tree of implications: + -- see TcType Note [TcLevel and untouchable type variables] + + ic_tclvl :: TcLevel, -- TcLevel of unification variables + -- allocated /inside/ this implication + + ic_skols :: [TcTyVar], -- Introduced skolems + ic_info :: SkolemInfo, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + + ic_given :: [EvVar], -- Given evidence variables + -- (order does not matter) + -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType + + ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure + -- False <=> ic_givens might have equalities + + ic_warn_inaccessible :: Bool, + -- True <=> -Winaccessible-code is enabled + -- at construction. See + -- Note [Avoid -Winaccessible-code when deriving] + -- in GHC.Tc.TyCl.Instance + + ic_env :: TcLclEnv, + -- Records the TcLClEnv at the time of creation. + -- + -- The TcLclEnv gives the source location + -- and error context for the implication, and + -- hence for all the given evidence variables. + + ic_wanted :: WantedConstraints, -- The wanteds + -- See Invariang (WantedInf) in GHC.Tc.Utils.TcType + + ic_binds :: EvBindsVar, -- Points to the place to fill in the + -- abstraction and bindings. + + -- The ic_need fields keep track of which Given evidence + -- is used by this implication or its children + -- NB: including stuff used by nested implications that have since + -- been discarded + -- See Note [Needed evidence variables] + ic_need_inner :: VarSet, -- Includes all used Given evidence + ic_need_outer :: VarSet, -- Includes only the free Given evidence + -- i.e. ic_need_inner after deleting + -- (a) givens (b) binders of ic_binds + + ic_status :: ImplicStatus + } + +implicationPrototype :: Implication +implicationPrototype + = Implic { -- These fields must be initialised + ic_tclvl = panic "newImplic:tclvl" + , ic_binds = panic "newImplic:binds" + , ic_info = panic "newImplic:info" + , ic_env = panic "newImplic:env" + , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" + + -- The rest have sensible default values + , ic_skols = [] + , ic_given = [] + , ic_wanted = emptyWC + , ic_no_eqs = False + , ic_status = IC_Unsolved + , ic_need_inner = emptyVarSet + , ic_need_outer = emptyVarSet } + +data ImplicStatus + = IC_Solved -- All wanteds in the tree are solved, all the way down + { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + + | IC_Insoluble -- At least one insoluble constraint in the tree + + | IC_BadTelescope -- solved, but the skolems in the telescope are out of + -- dependency order + + | IC_Unsolved -- Neither of the above; might go either way + +instance Outputable Implication where + ppr (Implic { ic_tclvl = tclvl, ic_skols = skols + , ic_given = given, ic_no_eqs = no_eqs + , ic_wanted = wanted, ic_status = status + , ic_binds = binds + , ic_need_inner = need_in, ic_need_outer = need_out + , ic_info = info }) + = hang (text "Implic" <+> lbrace) + 2 (sep [ text "TcLevel =" <+> ppr tclvl + , text "Skolems =" <+> pprTyVars skols + , text "No-eqs =" <+> ppr no_eqs + , text "Status =" <+> ppr status + , hang (text "Given =") 2 (pprEvVars given) + , hang (text "Wanted =") 2 (ppr wanted) + , text "Binds =" <+> ppr binds + , whenPprDebug (text "Needed inner =" <+> ppr need_in) + , whenPprDebug (text "Needed outer =" <+> ppr need_out) + , pprSkolInfo info ] <+> rbrace) + +instance Outputable ImplicStatus where + ppr IC_Insoluble = text "Insoluble" + ppr IC_BadTelescope = text "Bad telescope" + ppr IC_Unsolved = text "Unsolved" + ppr (IC_Solved { ics_dead = dead }) + = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) + +{- Note [Checking telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind-checking a /user-written/ type, we might have a "bad telescope" +like this one: + data SameKind :: forall k. k -> k -> Type + type Foo :: forall a k (b :: k). SameKind a b -> Type + +The kind of 'a' mentions 'k' which is bound after 'a'. Oops. + +One approach to doing this would be to bring each of a, k, and b into +scope, one at a time, creating a separate implication constraint for +each one, and bumping the TcLevel. This would work, because the kind +of, say, a would be untouchable when k is in scope (and the constraint +couldn't float out because k blocks it). However, it leads to terrible +error messages, complaining about skolem escape. While it is indeed a +problem of skolem escape, we can do better. + +Instead, our approach is to bring the block of variables into scope +all at once, creating one implication constraint for the lot: + +* We make a single implication constraint when kind-checking + the 'forall' in Foo's kind, something like + forall a k (b::k). { wanted constraints } + +* Having solved {wanted}, before discarding the now-solved implication, + the constraint solver checks the dependency order of the skolem + variables (ic_skols). This is done in setImplicationStatus. + +* This check is only necessary if the implication was born from a + 'forall' in a user-written signature (the HsForAllTy case in + GHC.Tc.Gen.HsType. If, say, it comes from checking a pattern match + that binds existentials, where the type of the data constructor is + known to be valid (it in tcConPat), no need for the check. + + So the check is done if and only if ic_info is ForAllSkol + +* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the + original, user-written type variables. + +* Be careful /NOT/ to discard an implication with a ForAllSkol + ic_info, even if ic_wanted is empty. We must give the + constraint solver a chance to make that bad-telescope test! Hence + the extra guard in emitResidualTvConstraint; see #16247 + +Note [Needed evidence variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Th ic_need_evs field holds the free vars of ic_binds, and all the +ic_binds in nested implications. + + * Main purpose: if one of the ic_givens is not mentioned in here, it + is redundant. + + * solveImplication may drop an implication altogether if it has no + remaining 'wanteds'. But we still track the free vars of its + evidence binds, even though it has now disappeared. + +Note [Shadowing in a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We assume NO SHADOWING in a constraint. Specifically + * The unification variables are all implicitly quantified at top + level, and are all unique + * The skolem variables bound in ic_skols are all freah when the + implication is created. +So we can safely substitute. For example, if we have + forall a. a~Int => ...(forall b. ...a...)... +we can push the (a~Int) constraint inwards in the "givens" without +worrying that 'b' might clash. + +Note [Skolems in an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems in an implication are not there to perform a skolem escape +check. That happens because all the environment variables are in the +untouchables, and therefore cannot be unified with anything at all, +let alone the skolems. + +Instead, ic_skols is used only when considering floating a constraint +outside the implication in GHC.Tc.Solver.floatEqualities or +GHC.Tc.Solver.approximateImplications + +Note [Insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the errors that we get during canonicalization are best +reported when all constraints have been simplified as much as +possible. For instance, assume that during simplification the +following constraints arise: + + [Wanted] F alpha ~ uf1 + [Wanted] beta ~ uf1 beta + +When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail +we will simply see a message: + 'Can't construct the infinite type beta ~ uf1 beta' +and the user has no idea what the uf1 variable is. + +Instead our plan is that we will NOT fail immediately, but: + (1) Record the "frozen" error in the ic_insols field + (2) Isolate the offending constraint from the rest of the inerts + (3) Keep on simplifying/canonicalizing + +At the end, we will hopefully have substituted uf1 := F alpha, and we +will be able to report a more informative error: + 'Can't construct the infinite type beta ~ F alpha beta' + +Insoluble constraints *do* include Derived constraints. For example, +a functional dependency might give rise to [D] Int ~ Bool, and we must +report that. If insolubles did not contain Deriveds, reportErrors would +never see it. + + +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +pprEvVars :: [EvVar] -> SDoc -- Print with their types +pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) + +pprEvVarTheta :: [EvVar] -> SDoc +pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) + +pprEvVarWithType :: EvVar -> SDoc +pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) + + + +wrapType :: Type -> [TyVar] -> [PredType] -> Type +wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty + + +{- +************************************************************************ +* * + CtEvidence +* * +************************************************************************ + +Note [Evidence field of CtEvidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During constraint solving we never look at the type of ctev_evar/ctev_dest; +instead we look at the ctev_pred field. The evtm/evar field +may be un-zonked. + +Note [Bind new Givens immediately] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Givens we make new EvVars and bind them immediately. Two main reasons: + * Gain sharing. E.g. suppose we start with g :: C a b, where + class D a => C a b + class (E a, F a) => D a + If we generate all g's superclasses as separate EvTerms we might + get selD1 (selC1 g) :: E a + selD2 (selC1 g) :: F a + selC1 g :: D a + which we could do more economically as: + g1 :: D a = selC1 g + g2 :: E a = selD1 g1 + g3 :: F a = selD2 g1 + + * For *coercion* evidence we *must* bind each given: + class (a~b) => C a b where .... + f :: C a b => .... + Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. + But that superclass selector can't (yet) appear in a coercion + (see evTermCoercion), so the easy thing is to bind it to an Id. + +So a Given has EvVar inside it rather than (as previously) an EvTerm. + +-} + +-- | A place for type-checking evidence to go after it is generated. +-- Wanted equalities are always HoleDest; other wanteds are always +-- EvVarDest. +data TcEvDest + = EvVarDest EvVar -- ^ bind this var to the evidence + -- EvVarDest is always used for non-type-equalities + -- e.g. class constraints + + | HoleDest CoercionHole -- ^ fill in this hole with the evidence + -- HoleDest is always used for type-equalities + -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep" + +data CtEvidence + = CtGiven -- Truly given, not depending on subgoals + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] + , ctev_loc :: CtLoc } + + + | CtWanted -- Wanted goal + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_dest :: TcEvDest + , ctev_nosh :: ShadowInfo -- See Note [Constraint flavours] + , ctev_loc :: CtLoc } + + | CtDerived -- A goal that we don't really have to solve and can't + -- immediately rewrite anything other than a derived + -- (there's no evidence!) but if we do manage to solve + -- it may help in solving other goals. + { ctev_pred :: TcPredType + , ctev_loc :: CtLoc } + +ctEvPred :: CtEvidence -> TcPredType +-- The predicate of a flavor +ctEvPred = ctev_pred + +ctEvLoc :: CtEvidence -> CtLoc +ctEvLoc = ctev_loc + +ctEvOrigin :: CtEvidence -> CtOrigin +ctEvOrigin = ctLocOrigin . ctEvLoc + +-- | Get the equality relation relevant for a 'CtEvidence' +ctEvEqRel :: CtEvidence -> EqRel +ctEvEqRel = predTypeEqRel . ctEvPred + +-- | Get the role relevant for a 'CtEvidence' +ctEvRole :: CtEvidence -> Role +ctEvRole = eqRelRole . ctEvEqRel + +ctEvTerm :: CtEvidence -> EvTerm +ctEvTerm ev = EvExpr (ctEvExpr ev) + +ctEvExpr :: CtEvidence -> EvExpr +ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) + = Coercion $ ctEvCoercion ev +ctEvExpr ev = evId (ctEvEvId ev) + +ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion +ctEvCoercion (CtGiven { ctev_evar = ev_id }) + = mkTcCoVarCo ev_id +ctEvCoercion (CtWanted { ctev_dest = dest }) + | HoleDest hole <- dest + = -- ctEvCoercion is only called on type equalities + -- and they always have HoleDests + mkHoleCo hole +ctEvCoercion ev + = pprPanic "ctEvCoercion" (ppr ev) + +ctEvEvId :: CtEvidence -> EvVar +ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev +ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h +ctEvEvId (CtGiven { ctev_evar = ev }) = ev +ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev) + +instance Outputable TcEvDest where + ppr (HoleDest h) = text "hole" <> ppr h + ppr (EvVarDest ev) = ppr ev + +instance Outputable CtEvidence where + ppr ev = ppr (ctEvFlavour ev) + <+> pp_ev + <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon + -- Show the sub-goal depth too + <+> ppr (ctEvPred ev) + where + pp_ev = case ev of + CtGiven { ctev_evar = v } -> ppr v + CtWanted {ctev_dest = d } -> ppr d + CtDerived {} -> text "_" + +isWanted :: CtEvidence -> Bool +isWanted (CtWanted {}) = True +isWanted _ = False + +isGiven :: CtEvidence -> Bool +isGiven (CtGiven {}) = True +isGiven _ = False + +isDerived :: CtEvidence -> Bool +isDerived (CtDerived {}) = True +isDerived _ = False + +{- +%************************************************************************ +%* * + CtFlavour +%* * +%************************************************************************ + +Note [Constraint flavours] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constraints come in four flavours: + +* [G] Given: we have evidence + +* [W] Wanted WOnly: we want evidence + +* [D] Derived: any solution must satisfy this constraint, but + we don't need evidence for it. Examples include: + - superclasses of [W] class constraints + - equalities arising from functional dependencies + or injectivity + +* [WD] Wanted WDeriv: a single constraint that represents + both [W] and [D] + We keep them paired as one both for efficiency, and because + when we have a finite map F tys -> CFunEqCan, it's inconvenient + to have two CFunEqCans in the range + +The ctev_nosh field of a Wanted distinguishes between [W] and [WD] + +Wanted constraints are born as [WD], but are split into [W] and its +"shadow" [D] in GHC.Tc.Solver.Monad.maybeEmitShadow. + +See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad +-} + +data CtFlavour -- See Note [Constraint flavours] + = Given + | Wanted ShadowInfo + | Derived + deriving Eq + +data ShadowInfo + = WDeriv -- [WD] This Wanted constraint has no Derived shadow, + -- so it behaves like a pair of a Wanted and a Derived + | WOnly -- [W] It has a separate derived shadow + -- See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad + deriving( Eq ) + +isGivenOrWDeriv :: CtFlavour -> Bool +isGivenOrWDeriv Given = True +isGivenOrWDeriv (Wanted WDeriv) = True +isGivenOrWDeriv _ = False + +instance Outputable CtFlavour where + ppr Given = text "[G]" + ppr (Wanted WDeriv) = text "[WD]" + ppr (Wanted WOnly) = text "[W]" + ppr Derived = text "[D]" + +ctEvFlavour :: CtEvidence -> CtFlavour +ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh +ctEvFlavour (CtGiven {}) = Given +ctEvFlavour (CtDerived {}) = Derived + +-- | Whether or not one 'Ct' can rewrite another is determined by its +-- flavour and its equality relation. See also +-- Note [Flavours with roles] in "GHC.Tc.Solver.Monad" +type CtFlavourRole = (CtFlavour, EqRel) + +-- | Extract the flavour, role, and boxity from a 'CtEvidence' +ctEvFlavourRole :: CtEvidence -> CtFlavourRole +ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) + +-- | Extract the flavour and role from a 'Ct' +ctFlavourRole :: Ct -> CtFlavourRole +-- Uses short-cuts to role for special cases +ctFlavourRole (CDictCan { cc_ev = ev }) + = (ctEvFlavour ev, NomEq) +ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) + = (ctEvFlavour ev, eq_rel) +ctFlavourRole (CFunEqCan { cc_ev = ev }) + = (ctEvFlavour ev, NomEq) +ctFlavourRole ct + = ctEvFlavourRole (ctEvidence ct) + +{- Note [eqCanRewrite] +~~~~~~~~~~~~~~~~~~~~~~ +(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form +tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of +a can-rewrite relation, see Definition [Can-rewrite relation] in +GHC.Tc.Solver.Monad. + +With the solver handling Coercible constraints like equality constraints, +the rewrite conditions must take role into account, never allowing +a representational equality to rewrite a nominal one. + +Note [Wanteds do not rewrite Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Wanteds to rewrite Wanteds, because that can give rise +to very confusing type error messages. A good example is #8450. +Here's another + f :: a -> Bool + f x = ( [x,'c'], [x,True] ) `seq` True +Here we get + [W] a ~ Char + [W] a ~ Bool +but we do not want to complain about Bool ~ Char! + +Note [Deriveds do rewrite Deriveds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +However we DO allow Deriveds to rewrite Deriveds, because that's how +improvement works; see Note [The improvement story] in GHC.Tc.Solver.Interact. + +However, for now at least I'm only letting (Derived,NomEq) rewrite +(Derived,NomEq) and not doing anything for ReprEq. If we have + eqCanRewriteFR (Derived, NomEq) (Derived, _) = True +then we lose property R2 of Definition [Can-rewrite relation] +in GHC.Tc.Solver.Monad + R2. If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 +Consider f1 = (Given, ReprEq) + f2 = (Derived, NomEq) + f = (Derived, ReprEq) + +I thought maybe we could never get Derived ReprEq constraints, but +we can; straight from the Wanteds during improvement. And from a Derived +ReprEq we could conceivably get a Derived NomEq improvement (by decomposing +a type constructor with Nomninal role), and hence unify. +-} + +eqCanRewrite :: EqRel -> EqRel -> Bool +eqCanRewrite NomEq _ = True +eqCanRewrite ReprEq ReprEq = True +eqCanRewrite ReprEq NomEq = False + +eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- Can fr1 actually rewrite fr2? +-- Very important function! +-- See Note [eqCanRewrite] +-- See Note [Wanteds do not rewrite Wanteds] +-- See Note [Deriveds do rewrite Deriveds] +eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True +eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True +eqCanRewriteFR _ _ = False + +eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- Is it /possible/ that fr1 can rewrite fr2? +-- This is used when deciding which inerts to kick out, +-- at which time a [WD] inert may be split into [W] and [D] +eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True +eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True +eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 + +----------------- +{- Note [funEqCanDischarge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have two CFunEqCans with the same LHS: + (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2) +Can we drop x2 in favour of x1, either unifying +f2 (if it's a flatten meta-var) or adding a new Given +(f1 ~ f2), if x2 is a Given? + +Answer: yes if funEqCanDischarge is true. +-} + +funEqCanDischarge + :: CtEvidence -> CtEvidence + -> ( SwapFlag -- NotSwapped => lhs can discharge rhs + -- Swapped => rhs can discharge lhs + , Bool) -- True <=> upgrade non-discharded one + -- from [W] to [WD] +-- See Note [funEqCanDischarge] +funEqCanDischarge ev1 ev2 + = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 ) + ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 ) + -- CFunEqCans are all Nominal, hence asserts + funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2) + +funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool) +funEqCanDischargeF Given _ = (NotSwapped, False) +funEqCanDischargeF _ Given = (IsSwapped, False) +funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False) +funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True) +funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False) +funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True) +funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True) +funEqCanDischargeF Derived Derived = (NotSwapped, False) + + +{- Note [eqCanDischarge] +~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have two identical CTyEqCan equality constraints +(i.e. both LHS and RHS are the same) + (x1:a~t) `eqCanDischarge` (xs:a~t) +Can we just drop x2 in favour of x1? + +Answer: yes if eqCanDischarge is true. + +Note that we do /not/ allow Wanted to discharge Derived. +We must keep both. Why? Because the Derived may rewrite +other Deriveds in the model whereas the Wanted cannot. + +However a Wanted can certainly discharge an identical Wanted. So +eqCanDischarge does /not/ define a can-rewrite relation in the +sense of Definition [Can-rewrite relation] in GHC.Tc.Solver.Monad. + +We /do/ say that a [W] can discharge a [WD]. In evidence terms it +certainly can, and the /caller/ arranges that the otherwise-lost [D] +is spat out as a new Derived. -} + +eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- See Note [eqCanDischarge] +eqCanDischargeFR (f1,r1) (f2, r2) = eqCanRewrite r1 r2 + && eqCanDischargeF f1 f2 + +eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool +eqCanDischargeF Given _ = True +eqCanDischargeF (Wanted _) (Wanted _) = True +eqCanDischargeF (Wanted WDeriv) Derived = True +eqCanDischargeF Derived Derived = True +eqCanDischargeF _ _ = False + + +{- +************************************************************************ +* * + SubGoalDepth +* * +************************************************************************ + +Note [SubGoalDepth] +~~~~~~~~~~~~~~~~~~~ +The 'SubGoalDepth' takes care of stopping the constraint solver from looping. + +The counter starts at zero and increases. It includes dictionary constraints, +equality simplification, and type family reduction. (Why combine these? Because +it's actually quite easy to mistake one for another, in sufficiently involved +scenarios, like ConstraintKinds.) + +The flag -freduction-depth=n fixes the maximium level. + +* The counter includes the depth of type class instance declarations. Example: + [W] d{7} : Eq [Int] + That is d's dictionary-constraint depth is 7. If we use the instance + $dfEqList :: Eq a => Eq [a] + to simplify it, we get + d{7} = $dfEqList d'{8} + where d'{8} : Eq Int, and d' has depth 8. + + For civilised (decidable) instance declarations, each increase of + depth removes a type constructor from the type, so the depth never + gets big; i.e. is bounded by the structural depth of the type. + +* The counter also increments when resolving +equalities involving type functions. Example: + Assume we have a wanted at depth 7: + [W] d{7} : F () ~ a + If there is a type function equation "F () = Int", this would be rewritten to + [W] d{8} : Int ~ a + and remembered as having depth 8. + + Again, without UndecidableInstances, this counter is bounded, but without it + can resolve things ad infinitum. Hence there is a maximum level. + +* Lastly, every time an equality is rewritten, the counter increases. Again, + rewriting an equality constraint normally makes progress, but it's possible + the "progress" is just the reduction of an infinitely-reducing type family. + Hence we need to track the rewrites. + +When compiling a program requires a greater depth, then GHC recommends turning +off this check entirely by setting -freduction-depth=0. This is because the +exact number that works is highly variable, and is likely to change even between +minor releases. Because this check is solely to prevent infinite compilation +times, it seems safe to disable it when a user has ascertained that their program +doesn't loop at the type level. + +-} + +-- | See Note [SubGoalDepth] +newtype SubGoalDepth = SubGoalDepth Int + deriving (Eq, Ord, Outputable) + +initialSubGoalDepth :: SubGoalDepth +initialSubGoalDepth = SubGoalDepth 0 + +bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth +bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) + +maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth +maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) + +subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool +subGoalDepthExceeded dflags (SubGoalDepth d) + = mkIntWithInf d > reductionDepth dflags + +{- +************************************************************************ +* * + CtLoc +* * +************************************************************************ + +The 'CtLoc' gives information about where a constraint came from. +This is important for decent error message reporting because +dictionaries don't appear in the original source code. +type will evolve... + +-} + +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: TcLclEnv + , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure + , ctl_depth :: !SubGoalDepth } + + -- The TcLclEnv includes particularly + -- source location: tcl_loc :: RealSrcSpan + -- context: tcl_ctxt :: [ErrCtxt] + -- binder stack: tcl_bndrs :: TcBinderStack + -- level: tcl_tclvl :: TcLevel + +mkKindLoc :: TcType -> TcType -- original *types* being compared + -> CtLoc -> CtLoc +mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) + (KindEqOrigin s1 (Just s2) (ctLocOrigin loc) + (ctLocTypeOrKind_maybe loc)) + +-- | Take a CtLoc and moves it to the kind level +toKindLoc :: CtLoc -> CtLoc +toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } + +mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc +mkGivenLoc tclvl skol_info env + = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = setLclEnvTcLevel env tclvl + , ctl_t_or_k = Nothing -- this only matters for error msgs + , ctl_depth = initialSubGoalDepth } + +ctLocEnv :: CtLoc -> TcLclEnv +ctLocEnv = ctl_env + +ctLocLevel :: CtLoc -> TcLevel +ctLocLevel loc = getLclEnvTcLevel (ctLocEnv loc) + +ctLocDepth :: CtLoc -> SubGoalDepth +ctLocDepth = ctl_depth + +ctLocOrigin :: CtLoc -> CtOrigin +ctLocOrigin = ctl_origin + +ctLocSpan :: CtLoc -> RealSrcSpan +ctLocSpan (CtLoc { ctl_env = lcl}) = getLclEnvLoc lcl + +ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind +ctLocTypeOrKind_maybe = ctl_t_or_k + +setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc +setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setLclEnvLoc lcl loc) + +bumpCtLocDepth :: CtLoc -> CtLoc +bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } + +setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc +setCtLocOrigin ctl orig = ctl { ctl_origin = orig } + +updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc +updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd + = ctl { ctl_origin = upd orig } + +setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc +setCtLocEnv ctl env = ctl { ctl_env = env } + +pprCtLoc :: CtLoc -> SDoc +-- "arising from ... at ..." +-- Not an instance of Outputable because of the "arising from" prefix +pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) + = sep [ pprCtOrigin o + , text "at" <+> ppr (getLclEnvLoc lcl)] diff --git a/GHC/Tc/Types/EvTerm.hs b/GHC/Tc/Types/EvTerm.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/EvTerm.hs @@ -0,0 +1,71 @@ + +-- (those who have too heavy dependencies for GHC.Tc.Types.Evidence) +module GHC.Tc.Types.EvTerm + ( evDelayedError, evCallStack ) +where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Core.Type +import GHC.Core +import GHC.Core.Make +import GHC.Types.Literal ( Literal(..) ) +import GHC.Tc.Types.Evidence +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Types.Name +import GHC.Unit +import GHC.Core.Utils +import GHC.Builtin.Names +import GHC.Types.SrcLoc + +-- Used with Opt_DeferTypeErrors +-- See Note [Deferring coercion errors to runtime] +-- in GHC.Tc.Solver +evDelayedError :: Type -> FastString -> EvTerm +evDelayedError ty msg + = EvExpr $ + Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] + where + errorId = tYPE_ERROR_ID + litMsg = Lit (LitString (bytesFS msg)) + +-- Dictionary for CallStack implicit parameters +evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => + EvCallStack -> m EvExpr +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +evCallStack cs = do + df <- getDynFlags + let platform = targetPlatform df + m <- getModule + srcLocDataCon <- lookupDataCon srcLocDataConName + let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> + sequence [ mkStringExprFS (unitFS $ moduleUnit m) + , mkStringExprFS (moduleNameFS $ moduleName m) + , mkStringExprFS (srcSpanFile l) + , return $ mkIntExprInt platform (srcSpanStartLine l) + , return $ mkIntExprInt platform (srcSpanStartCol l) + , return $ mkIntExprInt platform (srcSpanEndLine l) + , return $ mkIntExprInt platform (srcSpanEndCol l) + ] + + emptyCS <- Var <$> lookupId emptyCallStackName + + pushCSVar <- lookupId pushCallStackName + let pushCS name loc rest = + mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] + + let mkPush name loc tm = do + nameExpr <- mkStringExprFS name + locExpr <- mkSrcLoc loc + -- at this point tm :: IP sym CallStack + -- but we need the actual CallStack to pass to pushCS, + -- so we use unwrapIP to strip the dictionary wrapper + -- See Note [Overview of implicit CallStacks] + let ip_co = unwrapIP (exprType tm) + return (pushCS nameExpr locExpr (Cast tm ip_co)) + + case cs of + EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm + EvCsEmpty -> return emptyCS diff --git a/GHC/Tc/Types/Evidence.hs b/GHC/Tc/Types/Evidence.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Evidence.hs @@ -0,0 +1,1060 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Types.Evidence ( + + -- * HsWrapper + HsWrapper(..), + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, + mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders, + mkWpFun, idHsWrapper, isIdHsWrapper, + pprHsWrapper, hsWrapDictBinders, + + -- * Evidence bindings + TcEvBinds(..), EvBindsVar(..), + EvBindMap(..), emptyEvBindMap, extendEvBinds, + lookupEvBind, evBindMapBinds, + foldEvBindMap, nonDetStrictFoldEvBindMap, + filterEvBindMap, + isEmptyEvBindMap, + evBindMapToVarSet, + varSetMinusEvBindMap, + EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, + evBindVar, isCoEvBindsVar, + + -- * EvTerm (already a CoreExpr) + EvTerm(..), EvExpr, + evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector, + mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars, + + evTermCoercion, evTermCoercion_maybe, + EvCallStack(..), + EvTypeable(..), + + -- * TcCoercion + TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, + TcMCoercion, + Role(..), LeftOrRight(..), pickLR, + mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, + mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, + mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, + mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, + tcDowngradeRole, + mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo, + mkTcCoherenceLeftCo, + mkTcCoherenceRightCo, + mkTcKindCo, + tcCoercionKind, + mkTcCoVarCo, + mkTcFamilyTyConAppCo, + isTcReflCo, isTcReflexiveCo, + tcCoercionRole, + unwrapIP, wrapIP, + + -- * QuoteWrapper + QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy + ) where +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Unique.DFM +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Core.Coercion.Axiom +import GHC.Core.Coercion +import GHC.Core.Ppr () -- Instance OutputableBndr TyVar +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.DataCon( DataCon, dataConWrapId ) +import GHC.Core.Class( Class ) +import GHC.Builtin.Names +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Core.Predicate +import GHC.Types.Name +import GHC.Data.Pair + +import GHC.Core +import GHC.Core.Class ( classSCSelId ) +import GHC.Core.FVs ( exprSomeFreeVars ) + +import GHC.Utils.Misc +import GHC.Data.Bag +import qualified Data.Data as Data +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import Data.IORef( IORef ) +import GHC.Types.Unique.Set +import GHC.Core.Multiplicity + +{- +Note [TcCoercions] +~~~~~~~~~~~~~~~~~~ +| TcCoercions are a hack used by the typechecker. Normally, +Coercions have free variables of type (a ~# b): we call these +CoVars. However, the type checker passes around equality evidence +(boxed up) at type (a ~ b). + +An TcCoercion is simply a Coercion whose free variables have may be either +boxed or unboxed. After we are done with typechecking the desugarer finds the +boxed free variables, unboxes them, and creates a resulting real Coercion with +kosher free variables. + +-} + +type TcCoercion = Coercion +type TcCoercionN = CoercionN -- A Nominal coercion ~N +type TcCoercionR = CoercionR -- A Representational coercion ~R +type TcCoercionP = CoercionP -- a phantom coercion +type TcMCoercion = MCoercion + +mkTcReflCo :: Role -> TcType -> TcCoercion +mkTcSymCo :: TcCoercion -> TcCoercion +mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcNomReflCo :: TcType -> TcCoercionN +mkTcRepReflCo :: TcType -> TcCoercionR +mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion +mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion +mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -> TcCoercion +mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex + -> [TcType] -> [TcCoercion] -> TcCoercion +mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] + -> [TcCoercion] -> TcCoercionR +mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion +mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion +mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion +mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion +mkTcSubCo :: TcCoercionN -> TcCoercionR +tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion +mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR +mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion +mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion +mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN + -> TcCoercion -> TcCoercion +mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN + -> TcCoercion -> TcCoercion +mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP +mkTcKindCo :: TcCoercion -> TcCoercionN +mkTcCoVarCo :: CoVar -> TcCoercion +mkTcFamilyTyConAppCo :: TyCon -> [TcCoercionN] -> TcCoercionN + +tcCoercionKind :: TcCoercion -> Pair TcType +tcCoercionRole :: TcCoercion -> Role +isTcReflCo :: TcCoercion -> Bool + +-- | This version does a slow check, calculating the related types and seeing +-- if they are equal. +isTcReflexiveCo :: TcCoercion -> Bool + +mkTcReflCo = mkReflCo +mkTcSymCo = mkSymCo +mkTcTransCo = mkTransCo +mkTcNomReflCo = mkNomReflCo +mkTcRepReflCo = mkRepReflCo +mkTcTyConAppCo = mkTyConAppCo +mkTcAppCo = mkAppCo +mkTcFunCo = mkFunCo +mkTcAxInstCo = mkAxInstCo +mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational +mkTcForAllCo = mkForAllCo +mkTcForAllCos = mkForAllCos +mkTcNthCo = mkNthCo +mkTcLRCo = mkLRCo +mkTcSubCo = mkSubCo +tcDowngradeRole = downgradeRole +mkTcAxiomRuleCo = mkAxiomRuleCo +mkTcGReflRightCo = mkGReflRightCo +mkTcGReflLeftCo = mkGReflLeftCo +mkTcCoherenceLeftCo = mkCoherenceLeftCo +mkTcCoherenceRightCo = mkCoherenceRightCo +mkTcPhantomCo = mkPhantomCo +mkTcKindCo = mkKindCo +mkTcCoVarCo = mkCoVarCo +mkTcFamilyTyConAppCo = mkFamilyTyConAppCo + +tcCoercionKind = coercionKind +tcCoercionRole = coercionRole +isTcReflCo = isReflCo +isTcReflexiveCo = isReflexiveCo + +-- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. +-- Note that the input coercion should always be nominal. +maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion +maybeTcSubCo NomEq = id +maybeTcSubCo ReprEq = mkTcSubCo + + +{- +%************************************************************************ +%* * + HsWrapper +* * +************************************************************************ +-} + +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] + -- + -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) + -- But ([] a) `WpCompose` ([] b) = ([] b a) + + | WpFun HsWrapper HsWrapper (Scaled TcType) SDoc + -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w t1). wrap2[ e wrap1[x] ] + -- So note that if wrap1 :: exp_arg <= act_arg + -- wrap2 :: act_res <= exp_res + -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) + -- This isn't the same as for mkFunCo, but it has to be this way + -- because we can't use 'sym' to flip around these HsWrappers + -- The TcType is the "from" type of the first wrapper + -- The SDoc explains the circumstances under which we have created this + -- WpFun, in case we run afoul of levity polymorphism restrictions in + -- the desugarer. See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + + | WpCast TcCoercionR -- A cast: [] `cast` co + -- Guaranteed not the identity coercion + -- At role Representational + + -- Evidence abstraction and application + -- (both dictionaries and coercions) + | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable + | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + -- Kind and Type abstraction and application + | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) + | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) + + + | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, + -- so that the identity coercion is always exactly WpHole + + | WpMultCoercion Coercion -- Require that a Coercion be reflexive; otherwise, + -- error in the desugarer. See GHC.Tc.Utils.Unify + -- Note [Wrapper returned from tcSubMult] + +-- Cannot derive Data instance because SDoc is not Data (it stores a function). +-- So we do it manually: +instance Data.Data HsWrapper where + gfoldl _ z WpHole = z WpHole + gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2 + gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3 + gfoldl k z (WpCast a1) = z WpCast `k` a1 + gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1 + gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1 + gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 + gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 + gfoldl k z (WpLet a1) = z WpLet `k` a1 + gfoldl k z (WpMultCoercion a1) = z WpMultCoercion `k` a1 + + gunfold k z c = case Data.constrIndex c of + 1 -> z WpHole + 2 -> k (k (z WpCompose)) + 3 -> k (k (k (z wpFunEmpty))) + 4 -> k (z WpCast) + 5 -> k (z WpEvLam) + 6 -> k (z WpEvApp) + 7 -> k (z WpTyLam) + 8 -> k (z WpTyApp) + 9 -> k (z WpLet) + _ -> k (z WpMultCoercion) + + toConstr WpHole = wpHole_constr + toConstr (WpCompose _ _) = wpCompose_constr + toConstr (WpFun _ _ _ _) = wpFun_constr + toConstr (WpCast _) = wpCast_constr + toConstr (WpEvLam _) = wpEvLam_constr + toConstr (WpEvApp _) = wpEvApp_constr + toConstr (WpTyLam _) = wpTyLam_constr + toConstr (WpTyApp _) = wpTyApp_constr + toConstr (WpLet _) = wpLet_constr + toConstr (WpMultCoercion _) = wpMultCoercion_constr + + dataTypeOf _ = hsWrapper_dataType + +hsWrapper_dataType :: Data.DataType +hsWrapper_dataType + = Data.mkDataType "HsWrapper" + [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr + , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr + , wpLet_constr, wpMultCoercion_constr ] + +wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, + wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr, + wpMultCoercion_constr :: Data.Constr +wpHole_constr = mkHsWrapperConstr "WpHole" +wpCompose_constr = mkHsWrapperConstr "WpCompose" +wpFun_constr = mkHsWrapperConstr "WpFun" +wpCast_constr = mkHsWrapperConstr "WpCast" +wpEvLam_constr = mkHsWrapperConstr "WpEvLam" +wpEvApp_constr = mkHsWrapperConstr "WpEvApp" +wpTyLam_constr = mkHsWrapperConstr "WpTyLam" +wpTyApp_constr = mkHsWrapperConstr "WpTyApp" +wpLet_constr = mkHsWrapperConstr "WpLet" +wpMultCoercion_constr = mkHsWrapperConstr "WpMultCoercion" + +mkHsWrapperConstr :: String -> Data.Constr +mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix + +wpFunEmpty :: HsWrapper -> HsWrapper -> Scaled TcType -> HsWrapper +wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 + +mkWpFun :: HsWrapper -> HsWrapper + -> (Scaled TcType) -- the "from" type of the first wrapper + -> TcType -- either type of the second wrapper (used only when the + -- second wrapper is the identity) + -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." + -> HsWrapper +mkWpFun WpHole WpHole _ _ _ = WpHole +mkWpFun WpHole (WpCast co2) (Scaled w t1) _ _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole (Scaled w _) t2 _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2) +mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d + +mkWpCastR :: TcCoercionR -> HsWrapper +mkWpCastR co + | isTcReflCo co = WpHole + | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) + WpCast co + +mkWpCastN :: TcCoercionN -> HsWrapper +mkWpCastN co + | isTcReflCo co = WpHole + | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co) + WpCast (mkTcSubCo co) + -- The mkTcSubCo converts Nominal to Representational + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_app_fn WpTyApp tys + +mkWpEvApps :: [EvTerm] -> HsWrapper +mkWpEvApps args = mk_co_app_fn WpEvApp args + +mkWpEvVarApps :: [EvVar] -> HsWrapper +mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_lam_fn WpTyLam ids + +mkWpLams :: [Var] -> HsWrapper +mkWpLams ids = mk_co_lam_fn WpEvLam ids + +mkWpLet :: TcEvBinds -> HsWrapper +-- This no-op is a quite a common case +mkWpLet (EvBinds b) | isEmptyBag b = WpHole +mkWpLet ev_binds = WpLet ev_binds + +mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as + +mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +-- For applications, the *first* argument must +-- come *last* in the composition sequence +mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as + +idHsWrapper :: HsWrapper +idHsWrapper = WpHole + +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper _ = False + +hsWrapDictBinders :: HsWrapper -> Bag DictId +-- ^ Identifies the /lambda-bound/ dictionaries of an 'HsWrapper'. This is used +-- (only) to allow the pattern-match overlap checker to know what Given +-- dictionaries are in scope. +-- +-- We specifically do not collect dictionaries bound in a 'WpLet'. These are +-- either superclasses of lambda-bound ones, or (extremely numerous) results of +-- binding Wanted dictionaries. We definitely don't want all those cluttering +-- up the Given dictionaries for pattern-match overlap checking! +hsWrapDictBinders wrap = go wrap + where + go (WpEvLam dict_id) = unitBag dict_id + go (w1 `WpCompose` w2) = go w1 `unionBags` go w2 + go (WpFun _ w _ _) = go w + go WpHole = emptyBag + go (WpCast {}) = emptyBag + go (WpEvApp {}) = emptyBag + go (WpTyLam {}) = emptyBag + go (WpTyApp {}) = emptyBag + go (WpLet {}) = emptyBag + go (WpMultCoercion {}) = emptyBag + +collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) +-- Collect the outer lambda binders of a HsWrapper, +-- stopping as soon as you get to a non-lambda binder +collectHsWrapBinders wrap = go wrap [] + where + -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn) + go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) + go (WpEvLam v) wraps = add_lam v (gos wraps) + go (WpTyLam v) wraps = add_lam v (gos wraps) + go (WpCompose w1 w2) wraps = go w1 (w2:wraps) + go wrap wraps = ([], foldl' (<.>) wrap wraps) + + gos [] = ([], WpHole) + gos (w:ws) = go w ws + + add_lam v (vs,w) = (v:vs, w) + +{- +************************************************************************ +* * + Evidence bindings +* * +************************************************************************ +-} + +data TcEvBinds + = TcEvBinds -- Mutable evidence bindings + EvBindsVar -- Mutable because they are updated "later" + -- when an implication constraint is solved + + | EvBinds -- Immutable after zonking + (Bag EvBind) + +data EvBindsVar + = EvBindsVar { + ebv_uniq :: Unique, + -- The Unique is for debug printing only + + ebv_binds :: IORef EvBindMap, + -- The main payload: the value-level evidence bindings + -- (dictionaries etc) + -- Some Given, some Wanted + + ebv_tcvs :: IORef CoVarSet + -- The free Given coercion vars needed by Wanted coercions that + -- are solved by filling in their HoleDest in-place. Since they + -- don't appear in ebv_binds, we keep track of their free + -- variables so that we can report unused given constraints + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + } + + | CoEvBindsVar { -- See Note [Coercion evidence only] + + -- See above for comments on ebv_uniq, ebv_tcvs + ebv_uniq :: Unique, + ebv_tcvs :: IORef CoVarSet + } + +instance Data.Data TcEvBinds where + -- Placeholder; we can't travers into TcEvBinds + toConstr _ = abstractConstr "TcEvBinds" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "TcEvBinds" + +{- Note [Coercion evidence only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Class constraints etc give rise to /term/ bindings for evidence, and +we have nowhere to put term bindings in /types/. So in some places we +use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level +evidence bindings are allowed. Notebly (): + + - Places in types where we are solving kind constraints (all of which + are equalities); see solveEqualities, solveLocalEqualities + + - When unifying forall-types +-} + +isCoEvBindsVar :: EvBindsVar -> Bool +isCoEvBindsVar (CoEvBindsVar {}) = True +isCoEvBindsVar (EvBindsVar {}) = False + +----------------- +newtype EvBindMap + = EvBindMap { + ev_bind_varenv :: DVarEnv EvBind + } -- Map from evidence variables to evidence terms + -- We use @DVarEnv@ here to get deterministic ordering when we + -- turn it into a Bag. + -- If we don't do that, when we generate let bindings for + -- dictionaries in dsTcEvBinds they will be generated in random + -- order. + -- + -- For example: + -- + -- let $dEq = GHC.Classes.$fEqInt in + -- let $$dNum = GHC.Num.$fNumInt in ... + -- + -- vs + -- + -- let $dNum = GHC.Num.$fNumInt in + -- let $dEq = GHC.Classes.$fEqInt in ... + -- + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why + -- @UniqFM@ can lead to nondeterministic order. + +emptyEvBindMap :: EvBindMap +emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv } + +extendEvBinds :: EvBindMap -> EvBind -> EvBindMap +extendEvBinds bs ev_bind + = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs) + (eb_lhs ev_bind) + ev_bind } + +isEmptyEvBindMap :: EvBindMap -> Bool +isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m + +lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind +lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs) + +evBindMapBinds :: EvBindMap -> Bag EvBind +evBindMapBinds = foldEvBindMap consBag emptyBag + +foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a +foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a +nonDetStrictFoldEvBindMap k z bs = nonDetStrictFoldDVarEnv k z (ev_bind_varenv bs) + +filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap +filterEvBindMap k (EvBindMap { ev_bind_varenv = env }) + = EvBindMap { ev_bind_varenv = filterDVarEnv k env } + +evBindMapToVarSet :: EvBindMap -> VarSet +evBindMapToVarSet (EvBindMap dve) = unsafeUFMToUniqSet (mapUFM evBindVar (udfmToUfm dve)) + +varSetMinusEvBindMap :: VarSet -> EvBindMap -> VarSet +varSetMinusEvBindMap vs (EvBindMap dve) = vs `uniqSetMinusUDFM` dve + +instance Outputable EvBindMap where + ppr (EvBindMap m) = ppr m + +----------------- +-- All evidence is bound by EvBinds; no side effects +data EvBind + = EvBind { eb_lhs :: EvVar + , eb_rhs :: EvTerm + , eb_is_given :: Bool -- True <=> given + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + } + +evBindVar :: EvBind -> EvVar +evBindVar = eb_lhs + +mkWantedEvBind :: EvVar -> EvTerm -> EvBind +mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } + +-- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm +mkGivenEvBind :: EvVar -> EvTerm -> EvBind +mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } + + +-- An EvTerm is, conceptually, a CoreExpr that implements the constraint. +-- Unfortunately, we cannot just do +-- type EvTerm = CoreExpr +-- Because of staging problems issues around EvTypeable +data EvTerm + = EvExpr EvExpr + + | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) + + | EvFun -- /\as \ds. let binds in v + { et_tvs :: [TyVar] + , et_given :: [EvVar] + , et_binds :: TcEvBinds -- This field is why we need an EvFun + -- constructor, and can't just use EvExpr + , et_body :: EvVar } + + deriving Data.Data + +type EvExpr = CoreExpr + +-- An EvTerm is (usually) constructed by any of the constructors here +-- and those more complicates ones who were moved to module GHC.Tc.Types.EvTerm + +-- | Any sort of evidence Id, including coercions +evId :: EvId -> EvExpr +evId = Var + +-- coercion bindings +-- See Note [Coercion evidence terms] +evCoercion :: TcCoercion -> EvTerm +evCoercion co = EvExpr (Coercion co) + +-- | d |> co +evCast :: EvExpr -> TcCoercion -> EvTerm +evCast et tc | isReflCo tc = EvExpr et + | otherwise = EvExpr (Cast et tc) + +-- Dictionary instance application +evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm +evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets + +evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm +evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets + +-- Selector id plus the types at which it +-- should be instantiated, used for HasField +-- dictionaries; see Note [HasField instances] +-- in TcInterface +evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr +evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms + +-- Dictionary for (Typeable ty) +evTypeable :: Type -> EvTypeable -> EvTerm +evTypeable = EvTypeable + +-- | Instructions on how to make a 'Typeable' dictionary. +-- See Note [Typeable evidence terms] +data EvTypeable + = EvTypeableTyCon TyCon [EvTerm] + -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of + -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for + -- the applied kinds.. + + | EvTypeableTyApp EvTerm EvTerm + -- ^ Dictionary for @Typeable (s t)@, + -- given a dictionaries for @s@ and @t@. + + | EvTypeableTrFun EvTerm EvTerm EvTerm + -- ^ Dictionary for @Typeable (s # w -> t)@, + -- given a dictionaries for @w@, @s@, and @t@. + + | EvTypeableTyLit EvTerm + -- ^ Dictionary for a type literal, + -- e.g. @Typeable "foo"@ or @Typeable 3@ + -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ + -- (see #10348) + deriving Data.Data + +-- | Evidence for @CallStack@ implicit parameters. +data EvCallStack + -- See Note [Overview of implicit CallStacks] + = EvCsEmpty + | EvCsPushCall Name RealSrcSpan EvExpr + -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at + -- @loc@, in a calling context @stk@. + deriving Data.Data + +{- +Note [Typeable evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The EvTypeable data type looks isomorphic to Type, but the EvTerms +inside can be EvIds. Eg + f :: forall a. Typeable a => a -> TypeRep + f x = typeRep (undefined :: Proxy [a]) +Here for the (Typeable [a]) dictionary passed to typeRep we make +evidence + dl :: Typeable [a] = EvTypeable [a] + (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) +where + d :: Typable a +is the lambda-bound dictionary passed into f. + +Note [Coercion evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "coercion evidence term" takes one of these forms + co_tm ::= EvId v where v :: t1 ~# t2 + | EvCoercion co + | EvCast co_tm co + +We do quite often need to get a TcCoercion from an EvTerm; see +'evTermCoercion'. + +INVARIANT: The evidence for any constraint with type (t1 ~# t2) is +a coercion evidence term. Consider for example + [G] d :: F Int a +If we have + ax7 a :: F Int a ~ (a ~ Bool) +then we do NOT generate the constraint + [G] (d |> ax7 a) :: a ~ Bool +because that does not satisfy the invariant (d is not a coercion variable). +Instead we make a binding + g1 :: a~Bool = g |> ax7 a +and the constraint + [G] g1 :: a~Bool +See #7238 and Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint + +Note [EvBinds/EvTerm] +~~~~~~~~~~~~~~~~~~~~~ +How evidence is created and updated. Bindings for dictionaries, +and coercions and implicit parameters are carried around in TcEvBinds +which during constraint generation and simplification is always of the +form (TcEvBinds ref). After constraint simplification is finished it +will be transformed to t an (EvBinds ev_bag). + +Evidence for coercions *SHOULD* be filled in using the TcEvBinds +However, all EvVars that correspond to *wanted* coercion terms in +an EvBind must be mutable variables so that they can be readily +inlined (by zonking) after constraint simplification is finished. + +Conclusion: a new wanted coercion variable should be made mutable. +[Notice though that evidence variables that bind coercion terms + from super classes will be "given" and hence rigid] + + +Note [Overview of implicit CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations) + +The goal of CallStack evidence terms is to reify locations +in the program source as runtime values, without any support +from the RTS. We accomplish this by assigning a special meaning +to constraints of type GHC.Stack.Types.HasCallStack, an alias + + type HasCallStack = (?callStack :: CallStack) + +Implicit parameters of type GHC.Stack.Types.CallStack (the name is not +important) are solved in three steps: + +1. Occurrences of CallStack IPs are solved directly from the given IP, + just like a regular IP. For example, the occurrence of `?stk` in + + error :: (?stk :: CallStack) => String -> a + error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) + + will be solved for the `?stk` in `error`s context as before. + +2. In a function call, instead of simply passing the given IP, we first + append the current call-site to it. For example, consider a + call to the callstack-aware `error` above. + + undefined :: (?stk :: CallStack) => a + undefined = error "undefined!" + + Here we want to take the given `?stk` and append the current + call-site, before passing it to `error`. In essence, we want to + rewrite `error "undefined!"` to + + let ?stk = pushCallStack ?stk + in error "undefined!" + + We achieve this effect by emitting a NEW wanted + + [W] d :: IP "stk" CallStack + + from which we build the evidence term + + EvCsPushCall "error" (EvId d) + + that we use to solve the call to `error`. The new wanted `d` will + then be solved per rule (1), ie as a regular IP. + + (see GHC.Tc.Solver.Interact.interactDict) + +3. We default any insoluble CallStacks to the empty CallStack. Suppose + `undefined` did not request a CallStack, ie + + undefinedNoStk :: a + undefinedNoStk = error "undefined!" + + Under the usual IP rules, the new wanted from rule (2) would be + insoluble as there's no given IP from which to solve it, so we + would get an "unbound implicit parameter" error. + + We don't ever want to emit an insoluble CallStack IP, so we add a + defaulting pass to default any remaining wanted CallStacks to the + empty CallStack with the evidence term + + EvCsEmpty + + (see GHC.Tc.Solver.simpl_top and GHC.Tc.Solver.defaultCallStacks) + +This provides a lightweight mechanism for building up call-stacks +explicitly, but is notably limited by the fact that the stack will +stop at the first function whose type does not include a CallStack IP. +For example, using the above definition of `undefined`: + + head :: [a] -> a + head [] = undefined + head (x:_) = x + + g = head [] + +the resulting CallStack will include the call to `undefined` in `head` +and the call to `error` in `undefined`, but *not* the call to `head` +in `g`, because `head` did not explicitly request a CallStack. + + +Important Details: +- GHC should NEVER report an insoluble CallStack constraint. + +- GHC should NEVER infer a CallStack constraint unless one was requested + with a partial type signature (See TcType.pickQuantifiablePreds). + +- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], + where the String is the name of the binder that is used at the + SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the + package/module/file name, as well as the full source-span. Both + CallStack and SrcLoc are kept abstract so only GHC can construct new + values. + +- We will automatically solve any wanted CallStack regardless of the + name of the IP, i.e. + + f = show (?stk :: CallStack) + g = show (?loc :: CallStack) + + are both valid. However, we will only push new SrcLocs onto existing + CallStacks when the IP names match, e.g. in + + head :: (?loc :: CallStack) => [a] -> a + head [] = error (show (?stk :: CallStack)) + + the printed CallStack will NOT include head's call-site. This reflects the + standard scoping rules of implicit-parameters. + +- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. + The desugarer will need to unwrap the IP newtype before pushing a new + call-site onto a given stack (See GHC.HsToCore.Binds.dsEvCallStack) + +- When we emit a new wanted CallStack from rule (2) we set its origin to + `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` + (see GHC.Tc.Solver.Interact.interactDict). + + This is a bit shady, but is how we ensure that the new wanted is + solved like a regular IP. + +-} + +mkEvCast :: EvExpr -> TcCoercion -> EvTerm +mkEvCast ev lco + | ASSERT2( tcCoercionRole lco == Representational + , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) + isTcReflCo lco = EvExpr ev + | otherwise = evCast ev lco + + +mkEvScSelectors -- Assume class (..., D ty, ...) => C a b + :: Class -> [TcType] -- C ty1 ty2 + -> [(TcPredType, -- D ty[ty1/a,ty2/b] + EvExpr) -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b] + ] +mkEvScSelectors cls tys + = zipWith mk_pr (immSuperClasses cls tys) [0..] + where + mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys) + where + sc_sel_id = classSCSelId cls i -- Zero-indexed + +emptyTcEvBinds :: TcEvBinds +emptyTcEvBinds = EvBinds emptyBag + +isEmptyTcEvBinds :: TcEvBinds -> Bool +isEmptyTcEvBinds (EvBinds b) = isEmptyBag b +isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" + +evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion +-- Applied only to EvTerms of type (s~t) +-- See Note [Coercion evidence terms] +evTermCoercion_maybe ev_term + | EvExpr e <- ev_term = go e + | otherwise = Nothing + where + go :: EvExpr -> Maybe TcCoercion + go (Var v) = return (mkCoVarCo v) + go (Coercion co) = return co + go (Cast tm co) = do { co' <- go tm + ; return (mkCoCast co' co) } + go _ = Nothing + +evTermCoercion :: EvTerm -> TcCoercion +evTermCoercion tm = case evTermCoercion_maybe tm of + Just co -> co + Nothing -> pprPanic "evTermCoercion" (ppr tm) + + +{- ********************************************************************* +* * + Free variables +* * +********************************************************************* -} + +findNeededEvVars :: EvBindMap -> VarSet -> VarSet +-- Find all the Given evidence needed by seeds, +-- looking transitively through binds +findNeededEvVars ev_binds seeds + = transCloVarSet also_needs seeds + where + also_needs :: VarSet -> VarSet + also_needs needs = nonDetStrictFoldUniqSet add emptyVarSet needs + -- It's OK to use a non-deterministic fold here because we immediately + -- forget about the ordering by creating a set + + add :: Var -> VarSet -> VarSet + add v needs + | Just ev_bind <- lookupEvBind ev_binds v + , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind + , is_given + = evVarsOfTerm rhs `unionVarSet` needs + | otherwise + = needs + +evVarsOfTerm :: EvTerm -> VarSet +evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e +evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev +evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] + +evVarsOfTerms :: [EvTerm] -> VarSet +evVarsOfTerms = mapUnionVarSet evVarsOfTerm + +evVarsOfTypeable :: EvTypeable -> VarSet +evVarsOfTypeable ev = + case ev of + EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e + EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] + EvTypeableTrFun em e1 e2 -> evVarsOfTerms [em,e1,e2] + EvTypeableTyLit e -> evVarsOfTerm e + + +{- Note [Free vars of EvFun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the free vars of an EvFun is made tricky by the fact the +bindings et_binds may be a mutable variable. Fortunately, we +can just squeeze by. Here's how. + +* evVarsOfTerm is used only by GHC.Tc.Solver.neededEvVars. +* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the + ic_binds field of an Implication +* So we can track usage via the processing for that implication, + (see Note [Tracking redundant constraints] in GHC.Tc.Solver). + We can ignore usage from the EvFun altogether. + +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) + +pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc +-- With -fprint-typechecker-elaboration, print the wrapper +-- otherwise just print what's inside +-- The pp_thing_inside function takes Bool to say whether +-- it's in a position that needs parens for a non-atomic thing +pprHsWrapper wrap pp_thing_inside + = sdocOption sdocPrintTypecheckerElaboration $ \case + True -> help pp_thing_inside wrap False + False -> pp_thing_inside False + where + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpFun f1 f2 (Scaled w t1) _) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+> + help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False + help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" + <+> pprParendCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] + help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] + help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] + help it (WpMultCoercion co) = add_parens $ sep [it False, nest 2 (text "" + <+> pprParendCo co)] + +pprLamBndr :: Id -> SDoc +pprLamBndr v = pprBndr LambdaBind v + +add_parens, no_parens :: SDoc -> Bool -> SDoc +add_parens d True = parens d +add_parens d False = d +no_parens d _ = d + +instance Outputable TcEvBinds where + ppr (TcEvBinds v) = ppr v + ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) + +instance Outputable EvBindsVar where + ppr (EvBindsVar { ebv_uniq = u }) + = text "EvBindsVar" <> angleBrackets (ppr u) + ppr (CoEvBindsVar { ebv_uniq = u }) + = text "CoEvBindsVar" <> angleBrackets (ppr u) + +instance Uniquable EvBindsVar where + getUnique = ebv_uniq + +instance Outputable EvBind where + ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) + = sep [ pp_gw <+> ppr v + , nest 2 $ equals <+> ppr e ] + where + pp_gw = brackets (if is_given then char 'G' else char 'W') + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing + +instance Outputable EvTerm where + ppr (EvExpr e) = ppr e + ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty + ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w }) + = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow) + 2 (ppr bs $$ ppr w) -- Not very pretty + +instance Outputable EvCallStack where + ppr EvCsEmpty + = text "[]" + ppr (EvCsPushCall name loc tm) + = ppr (name,loc) <+> text ":" <+> ppr tm + +instance Outputable EvTypeable where + ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts + ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) + ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> mulArrow (ppr tm) <+> ppr t2) + ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 + + +---------------------------------------------------------------------- +-- Helper functions for dealing with IP newtype-dictionaries +---------------------------------------------------------------------- + +-- | Create a 'Coercion' that unwraps an implicit-parameter or +-- overloaded-label dictionary to expose the underlying value. We +-- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, +-- and return a 'Coercion' `co :: IP sym ty ~ ty` or +-- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also +-- Note [Type-checking overloaded labels] in "GHC.Tc.Gen.Expr". +unwrapIP :: Type -> CoercionR +unwrapIP ty = + case unwrapNewTyCon_maybe tc of + Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] + Nothing -> pprPanic "unwrapIP" $ + text "The dictionary for" <+> quotes (ppr tc) + <+> text "is not a newtype!" + where + (tc, tys) = splitTyConApp ty + +-- | Create a 'Coercion' that wraps a value in an implicit-parameter +-- dictionary. See 'unwrapIP'. +wrapIP :: Type -> CoercionR +wrapIP ty = mkSymCo (unwrapIP ty) + +---------------------------------------------------------------------- +-- A datatype used to pass information when desugaring quotations +---------------------------------------------------------------------- + +-- We have to pass a `EvVar` and `Type` into `dsBracket` so that the +-- correct evidence and types are applied to all the TH combinators. +-- This data type bundles them up together with some convenience methods. +-- +-- The EvVar is evidence for `Quote m` +-- The Type is a metavariable for `m` +-- +data QuoteWrapper = QuoteWrapper EvVar Type deriving Data.Data + +quoteWrapperTyVarTy :: QuoteWrapper -> Type +quoteWrapperTyVarTy (QuoteWrapper _ t) = t + +-- | Convert the QuoteWrapper into a normal HsWrapper which can be used to +-- apply its contents. +applyQuoteWrapper :: QuoteWrapper -> HsWrapper +applyQuoteWrapper (QuoteWrapper ev_var m_var) + = mkWpEvVarApps [ev_var] <.> mkWpTyApps [m_var] diff --git a/GHC/Tc/Types/Origin.hs b/GHC/Tc/Types/Origin.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/Origin.hs @@ -0,0 +1,661 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Describes the provenance of types as they flow through the type-checker. +-- The datatypes here are mainly used for error message generation. +module GHC.Tc.Types.Origin ( + -- UserTypeCtxt + UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, + + -- SkolemInfo + SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, + + -- CtOrigin + CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, + isVisibleOrigin, toInvisibleOrigin, + pprCtOrigin, isGivenOrigin + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Utils.TcType + +import GHC.Hs + +import GHC.Types.Id +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.PatSyn +import GHC.Core.Multiplicity ( scaledThing ) + +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Reader + +import GHC.Types.SrcLoc +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.Basic + +{- ********************************************************************* +* * + UserTypeCtxt +* * +********************************************************************* -} + +------------------------------------- +-- | UserTypeCtxt describes the origin of the polymorphic type +-- in the places where we need an expression to have that type +data UserTypeCtxt + = FunSigCtxt -- Function type signature, when checking the type + -- Also used for types in SPECIALISE pragmas + Name -- Name of the function + Bool -- True <=> report redundant constraints + -- This is usually True, but False for + -- * Record selectors (not important here) + -- * Class and instance methods. Here + -- the code may legitimately be more + -- polymorphic than the signature + -- generated from the class + -- declaration + + | InfSigCtxt Name -- Inferred type for function + | ExprSigCtxt -- Expression type signature + | KindSigCtxt -- Kind signature + | StandaloneKindSigCtxt -- Standalone kind signature + Name -- Name of the type/class + | TypeAppCtxt -- Visible type application + | ConArgCtxt Name -- Data constructor argument + | TySynCtxt Name -- RHS of a type synonym decl + | PatSynCtxt Name -- Type sig for a pattern synonym + | PatSigCtxt -- Type sig in pattern + -- eg f (x::t) = ... + -- or (x::t, y) = e + | RuleSigCtxt Name -- LHS of a RULE forall + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... + | ResSigCtxt -- Result type sig + -- f x :: t = .... + | ForSigCtxt Name -- Foreign import or export signature + | DefaultDeclCtxt -- Types in a default declaration + | InstDeclCtxt Bool -- An instance declaration + -- True: stand-alone deriving + -- False: vanilla instance declaration + | SpecInstCtxt -- SPECIALISE instance pragma + | ThBrackCtxt -- Template Haskell type brackets [t| ... |] + | GenSigCtxt -- Higher-rank or impredicative situations + -- e.g. (f e) where f has a higher-rank type + -- We might want to elaborate this + | GhciCtxt Bool -- GHCi command :kind + -- The Bool indicates if we are checking the outermost + -- type application. + -- See Note [Unsaturated type synonyms in GHCi] in + -- GHC.Tc.Validity. + + | ClassSCCtxt Name -- Superclasses of a class + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: => a -> a + | DataTyCtxt Name -- The "stupid theta" part of a data decl + -- data => T a = MkT a + | DerivClauseCtxt -- A 'deriving' clause + | TyVarBndrKindCtxt Name -- The kind of a type variable being bound + | DataKindCtxt Name -- The kind of a data/newtype (instance) + | TySynKindCtxt Name -- The kind of the RHS of a type synonym + | TyFamResKindCtxt Name -- The result kind of a type family + +{- +-- Notes re TySynCtxt +-- We allow type synonyms that aren't types; e.g. type List = [] +-- +-- If the RHS mentions tyvars that aren't in scope, we'll +-- quantify over them: +-- e.g. type T = a->a +-- will become type T = forall a. a->a +-- +-- With gla-exts that's right, but for H98 we should complain. +-} + + +pprUserTypeCtxt :: UserTypeCtxt -> SDoc +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt n) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" +pprUserTypeCtxt KindSigCtxt = text "a kind signature" +pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) +pprUserTypeCtxt TypeAppCtxt = text "a type argument" +pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) +pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" +pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" +pprUserTypeCtxt ResSigCtxt = text "a result type signature" +pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" +pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" +pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" +pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" +pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" +pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" +pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" +pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) +pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) +pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" +pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) +pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) + +isSigMaybe :: UserTypeCtxt -> Maybe Name +isSigMaybe (FunSigCtxt n _) = Just n +isSigMaybe (ConArgCtxt n) = Just n +isSigMaybe (ForSigCtxt n) = Just n +isSigMaybe (PatSynCtxt n) = Just n +isSigMaybe _ = Nothing + +{- +************************************************************************ +* * + SkolemInfo +* * +************************************************************************ +-} + +-- SkolemInfo gives the origin of *given* constraints +-- a) type variables are skolemised +-- b) an implication constraint is generated +data SkolemInfo + = SigSkol -- A skolem that is created by instantiating + -- a programmer-supplied type signature + -- Location of the binding site is on the TyVar + -- See Note [SigSkol SkolemInfo] + UserTypeCtxt -- What sort of signature + TcType -- Original type signature (before skolemisation) + [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar + -- to its instantiated version + + | SigTypeSkol UserTypeCtxt + -- like SigSkol, but when we're kind-checking the *type* + -- hence, we have less info + + | ForAllSkol -- Bound by a user-written "forall". + SDoc -- Shows the entire forall type + SDoc -- Shows just the binders, used when reporting a bad telescope + -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint + + | DerivSkol Type -- Bound by a 'deriving' clause; + -- the type is the instance we are trying to derive + + | InstSkol -- Bound at an instance decl + | InstSC TypeSize -- A "given" constraint obtained by superclass selection. + -- If (C ty1 .. tyn) is the largest class from + -- which we made a superclass selection in the chain, + -- then TypeSize = sizeTypes [ty1, .., tyn] + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + + | FamInstSkol -- Bound at a family instance decl + | PatSkol -- An existential type variable bound by a pattern for + ConLike -- a data constructor with an existential type. + (HsMatchContext GhcRn) + -- e.g. data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. + + | ArrowSkol -- An arrow form (see GHC.Tc.Gen.Arrow) + + | IPSkol [HsIPName] -- Binding site of an implicit parameter + + | RuleSkol RuleName -- The LHS of a RULE + + | InferSkol [(Name,TcType)] + -- We have inferred a type for these (mutually-recursivive) + -- polymorphic Ids, and are now checking that their RHS + -- constraints are satisfied. + + | BracketSkol -- Template Haskell bracket + + | UnifyForAllSkol -- We are unifying two for-all types + TcType -- The instantiated type *inside* the forall + + | TyConSkol TyConFlavour Name -- bound in a type declaration of the given flavour + + | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or + -- as any variable in a GADT datacon decl + + | ReifySkol -- Bound during Template Haskell reification + + | QuantCtxtSkol -- Quantified context, e.g. + -- f :: forall c. (forall a. c a => c [a]) => blah + + | RuntimeUnkSkol -- Runtime skolem from the GHCi debugger #14628 + + | UnkSkol -- Unhelpful info (until I improve it) + +instance Outputable SkolemInfo where + ppr = pprSkolInfo + +pprSkolInfo :: SkolemInfo -> SDoc +-- Complete the sentence "is a rigid type variable bound by..." +pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty +pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx +pprSkolInfo (ForAllSkol pt _) = quotes pt +pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" + <+> pprWithCommas ppr ips +pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) +pprSkolInfo InstSkol = text "the instance declaration" +pprSkolInfo (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n)) +pprSkolInfo FamInstSkol = text "a family instance declaration" +pprSkolInfo BracketSkol = text "a Template Haskell bracket" +pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name +pprSkolInfo ArrowSkol = text "an arrow form" +pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl + , text "in" <+> pprMatchContext mc ] +pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") + 2 (vcat [ ppr name <+> dcolon <+> ppr ty + | (name,ty) <- ids ]) +pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty +pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) +pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name) +pprSkolInfo ReifySkol = text "the type being reified" + +pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" +pprSkolInfo RuntimeUnkSkol = text "Unknown type from GHCi runtime" + +-- UnkSkol +-- For type variables the others are dealt with by pprSkolTvBinding. +-- For Insts, these cases should not happen +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" + +pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc +-- The type is already tidied +pprSigSkolInfo ctxt ty + = case ctxt of + FunSigCtxt f _ -> vcat [ text "the type signature for:" + , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] + PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms] + _ -> vcat [ pprUserTypeCtxt ctxt <> colon + , nest 2 (ppr ty) ] + +pprPatSkolInfo :: ConLike -> SDoc +pprPatSkolInfo (RealDataCon dc) + = sdocWithDynFlags (\dflags -> + sep [ text "a pattern with constructor:" + , nest 2 $ ppr dc <+> dcolon + <+> pprType (dataConDisplayType dflags dc) <> comma ]) + -- pprType prints forall's regardless of -fprint-explicit-foralls + -- which is what we want here, since we might be saying + -- type variable 't' is bound by ... + +pprPatSkolInfo (PatSynCon ps) + = sep [ text "a pattern with pattern synonym:" + , nest 2 $ ppr ps <+> dcolon + <+> pprPatSynType ps <> comma ] + +{- Note [Skolem info for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For pattern synonym SkolemInfo we have + SigSkol (PatSynCtxt p) ty _ +but the type 'ty' is not very helpful. The full pattern-synonym type +has the provided and required pieces, which it is inconvenient to +record and display here. So we simply don't display the type at all, +contenting outselves with just the name of the pattern synonym, which +is fine. We could do more, but it doesn't seem worth it. + +Note [SigSkol SkolemInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we skolemise a type + f :: forall a. Eq a => forall b. b -> a +Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated + a' -> b' -> a. +But when, in an error message, we report that "b is a rigid type +variable bound by the type signature for f", we want to show the foralls +in the right place. So we proceed as follows: + +* In SigSkol we record + - the original signature forall a. a -> forall b. b -> a + - the instantiation mapping [a :-> a', b :-> b'] + +* Then when tidying in GHC.Tc.Utils.TcMType.tidySkolemInfo, we first tidy a' to + whatever it tidies to, say a''; and then we walk over the type + replacing the binder a by the tidied version a'', to give + forall a''. Eq a'' => forall b''. b'' -> a'' + We need to do this under (=>) arrows, to match what topSkolemise + does. + +* Typically a'' will have a nice pretty name like "a", but the point is + that the foral-bound variables of the signature we report line up with + the instantiated skolems lying around in other types. + + +************************************************************************ +* * + CtOrigin +* * +************************************************************************ +-} + +data CtOrigin + = GivenOrigin SkolemInfo + + -- All the others are for *wanted* constraints + | OccurrenceOf Name -- Occurrence of an overloaded identifier + | OccurrenceOfRecSel RdrName -- Occurrence of a record selector + | AppOrigin -- An application of some kind + + | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for + -- function or instance + + | TypeEqOrigin { uo_actual :: TcType + , uo_expected :: TcType + , uo_thing :: Maybe SDoc + -- ^ The thing that has type "actual" + , uo_visible :: Bool + -- ^ Is at least one of the three elements above visible? + -- (Errors from the polymorphic subsumption check are considered + -- visible.) Only used for prioritizing error messages. + } + + | KindEqOrigin + TcType (Maybe TcType) -- A kind equality arising from unifying these two types + CtOrigin -- originally arising from this + (Maybe TypeOrKind) -- the level of the eq this arises from + + | IPOccOrigin HsIPName -- Occurrence of an implicit parameter + | OverLabelOrigin FastString -- Occurrence of an overloaded label + + | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal + | NegateOrigin -- Occurrence of syntactic negation + + | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc + | AssocFamPatOrigin -- When matching the patterns of an associated + -- family instance with that of its parent class + | SectionOrigin + | TupleOrigin -- (..,..) + | ExprSigOrigin -- e :: ty + | PatSigOrigin -- p :: ty + | PatOrigin -- Instantiating a polytyped pattern at a constructor + | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature + (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in + -- particular the name and the right-hand side + | RecordUpdOrigin + | ViewPatOrigin + + | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration + -- If the instance head is C ty1 .. tyn + -- then TypeSize = sizeTypes [ty1, .., tyn] + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + + | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to + -- standalone deriving). + | DerivOriginDC DataCon Int Bool + -- Checking constraints arising from this data con and field index. The + -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if + -- standalong deriving (with a wildcard constraint) is being used. This + -- is used to inform error messages on how to recommended fixes (e.g., if + -- the argument is True, then don't recommend "use standalone deriving", + -- but rather "fill in the wildcard constraint yourself"). + -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer + | DerivOriginCoerce Id Type Type Bool + -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from + -- `ty1` to `ty2`. + | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for + -- constraints coming from a wildcard constraint, + -- e.g., deriving instance _ => Eq (Foo a) + -- See Note [Inferring the instance context] + -- in GHC.Tc.Deriv.Infer + | DefaultOrigin -- Typechecking a default decl + | DoOrigin -- Arising from a do expression + | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in + -- a do expression + | MCompOrigin -- Arising from a monad comprehension + | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a + -- monad comprehension + | IfOrigin -- Arising from an if statement + | ProcOrigin -- Arising from a proc expression + | AnnOrigin -- An annotation + + | FunDepOrigin1 -- A functional dependency from combining + PredType CtOrigin RealSrcSpan -- This constraint arising from ... + PredType CtOrigin RealSrcSpan -- and this constraint arising from ... + + | FunDepOrigin2 -- A functional dependency from combining + PredType CtOrigin -- This constraint arising from ... + PredType SrcSpan -- and this top-level instance + -- We only need a CtOrigin on the first, because the location + -- is pinned on the entire error message + + | ExprHoleOrigin OccName -- from an expression hole + | TypeHoleOrigin OccName -- from a type hole (partial type signature) + | PatCheckOrigin -- normalisation of a type during pattern-match checking + | UnboundOccurrenceOf OccName + | ListOrigin -- An overloaded list + | BracketOrigin -- An overloaded quotation bracket + | StaticOrigin -- A static form + | Shouldn'tHappenOrigin String + -- the user should never see this one, + -- unless ImpredicativeTypes is on, where all + -- bets are off + | InstProvidedOrigin Module ClsInst + -- Skolem variable arose when we were testing if an instance + -- is solvable or not. + | NonLinearPatternOrigin + | UsageEnvironmentOf Name + +-- An origin is visible if the place where the constraint arises is manifest +-- in user code. Currently, all origins are visible except for invisible +-- TypeEqOrigins. This is used when choosing which error of +-- several to report +isVisibleOrigin :: CtOrigin -> Bool +isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis +isVisibleOrigin (KindEqOrigin _ _ sub_orig _) = isVisibleOrigin sub_orig +isVisibleOrigin _ = True + +-- Converts a visible origin to an invisible one, if possible. Currently, +-- this works only for TypeEqOrigin +toInvisibleOrigin :: CtOrigin -> CtOrigin +toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False } +toInvisibleOrigin orig = orig + +isGivenOrigin :: CtOrigin -> Bool +isGivenOrigin (GivenOrigin {}) = True +isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2 +isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1 +isGivenOrigin _ = False + +instance Outputable CtOrigin where + ppr = pprCtOrigin + +ctoHerald :: SDoc +ctoHerald = text "arising from" + +-- | Extract a suitable CtOrigin from a HsExpr +lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin +lexprCtOrigin (L _ e) = exprCtOrigin e + +exprCtOrigin :: HsExpr GhcRn -> CtOrigin +exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name +exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf uv +exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" +exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) +exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l +exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip +exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit +exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" +exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches +exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms +exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op +exprCtOrigin (NegApp _ e _) = lexprCtOrigin e +exprCtOrigin (HsPar _ e) = lexprCtOrigin e +exprCtOrigin (SectionL _ _ _) = SectionOrigin +exprCtOrigin (SectionR _ _ _) = SectionOrigin +exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" +exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" +exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches +exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" +exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs +exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e +exprCtOrigin (HsDo {}) = DoOrigin +exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" +exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" +exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" +exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin +exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" +exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e +exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" +exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" +exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" +exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e +exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e +exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a + +-- | Extract a suitable CtOrigin from a MatchGroup +matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin +matchesCtOrigin (MG { mg_alts = alts }) + | L _ [L _ match] <- alts + , Match { m_grhss = grhss } <- match + = grhssCtOrigin grhss + + | otherwise + = Shouldn'tHappenOrigin "multi-way match" + +-- | Extract a suitable CtOrigin from guarded RHSs +grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin +grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss + +-- | Extract a suitable CtOrigin from a list of guarded RHSs +lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin +lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e +lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" + +pprCtOrigin :: CtOrigin -> SDoc +-- "arising from ..." +-- Not an instance of Outputable because of the "arising from" prefix +pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk + +pprCtOrigin (SpecPragOrigin ctxt) + = case ctxt of + FunSigCtxt n _ -> text "for" <+> quotes (ppr n) + SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" + _ -> text "a SPECIALISE pragma" -- Never happens I think + +pprCtOrigin (FunDepOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = hang (ctoHerald <+> text "a functional dependency between constraints:") + 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1) + , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) + +pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) + = hang (ctoHerald <+> text "a functional dependency between:") + 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) + 2 (pprCtOrigin orig1 ) + , hang (text "instance" <+> quotes (ppr pred2)) + 2 (text "at" <+> ppr loc2) ]) + +pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) + = hang (ctoHerald <+> text "a kind equality arising from") + 2 (sep [ppr t1, char '~', ppr t2]) + +pprCtOrigin AssocFamPatOrigin + = text "when matching a family LHS with its class instance head" + +pprCtOrigin (KindEqOrigin t1 Nothing _ _) + = hang (ctoHerald <+> text "a kind equality when matching") + 2 (ppr t1) + +pprCtOrigin (UnboundOccurrenceOf name) + = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) + +pprCtOrigin (DerivOriginDC dc n _) + = hang (ctoHerald <+> text "the" <+> speakNth n + <+> text "field of" <+> quotes (ppr dc)) + 2 (parens (text "type" <+> quotes (ppr (scaledThing ty)))) + where + ty = dataConOrigArgTys dc !! (n-1) + +pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _) + = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) + 2 (sep [ text "from type" <+> quotes (ppr ty1) + , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) + +pprCtOrigin (DoPatOrigin pat) + = ctoHerald <+> text "a do statement" + $$ + text "with the failable pattern" <+> quotes (ppr pat) + +pprCtOrigin (MCompPatOrigin pat) + = ctoHerald <+> hsep [ text "the failable pattern" + , quotes (ppr pat) + , text "in a statement in a monad comprehension" ] + +pprCtOrigin (Shouldn'tHappenOrigin note) + = sdocOption sdocImpredicativeTypes $ \case + True -> text "a situation created by impredicative types" + False -> vcat [ text "<< This should not appear in error messages. If you see this" + , text "in an error message, please report a bug mentioning" + <+> quotes (text note) <+> text "at" + , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" + ] + +pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) + = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") + 2 (text "the signature of" <+> quotes (ppr name)) + +pprCtOrigin (InstProvidedOrigin mod cls_inst) + = vcat [ text "arising when attempting to show that" + , ppr cls_inst + , text "is provided by" <+> quotes (ppr mod)] + +pprCtOrigin simple_origin + = ctoHerald <+> pprCtO simple_origin + +-- | Short one-liners +pprCtO :: CtOrigin -> SDoc +pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] +pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] +pprCtO AppOrigin = text "an application" +pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] +pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" + ,quotes (char '#' <> ppr l)] +pprCtO RecordUpdOrigin = text "a record update" +pprCtO ExprSigOrigin = text "an expression type signature" +pprCtO PatSigOrigin = text "a pattern type signature" +pprCtO PatOrigin = text "a pattern" +pprCtO ViewPatOrigin = text "a view pattern" +pprCtO IfOrigin = text "an if expression" +pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] +pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] +pprCtO SectionOrigin = text "an operator section" +pprCtO AssocFamPatOrigin = text "the LHS of a family instance" +pprCtO TupleOrigin = text "a tuple" +pprCtO NegateOrigin = text "a use of syntactic negation" +pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" + <> whenPprDebug (parens (ppr n)) +pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" +pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" +pprCtO DefaultOrigin = text "a 'default' declaration" +pprCtO DoOrigin = text "a do statement" +pprCtO MCompOrigin = text "a statement in a monad comprehension" +pprCtO ProcOrigin = text "a proc expression" +pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] +pprCtO AnnOrigin = text "an annotation" +pprCtO (ExprHoleOrigin occ) = text "a use of" <+> quotes (ppr occ) +pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) +pprCtO PatCheckOrigin = text "a pattern-match completeness check" +pprCtO ListOrigin = text "an overloaded list" +pprCtO StaticOrigin = text "a static form" +pprCtO NonLinearPatternOrigin = text "a non-linear pattern" +pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] +pprCtO BracketOrigin = text "a quotation bracket" +pprCtO _ = panic "pprCtOrigin" diff --git a/GHC/Tc/Utils/Backpack.hs b/GHC/Tc/Utils/Backpack.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Backpack.hs @@ -0,0 +1,1013 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Utils.Backpack ( + findExtraSigImports', + findExtraSigImports, + implicitRequirements', + implicitRequirements, + checkUnit, + tcRnCheckUnit, + tcRnMergeSignatures, + mergeSignatures, + tcRnInstantiateSignature, + instantiateSignature, +) where + +import GHC.Prelude + +import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) +import GHC.Unit.State +import GHC.Tc.Gen.Export +import GHC.Driver.Session +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Monad +import GHC.Tc.TyCl.Utils +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Tc.Utils.Instantiate +import GHC.IfaceToCore +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Iface.Load +import GHC.Rename.Names +import GHC.Utils.Error +import GHC.Types.Id +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.SrcLoc +import GHC.Driver.Types +import GHC.Utils.Outputable +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Data.FastString +import GHC.Rename.Fixity ( lookupFixityRn ) +import GHC.Data.Maybe +import GHC.Tc.Utils.Env +import GHC.Types.Var +import GHC.Iface.Syntax +import GHC.Builtin.Names +import qualified Data.Map as Map + +import GHC.Driver.Finder +import GHC.Types.Unique.DSet +import GHC.Types.Name.Shape +import GHC.Tc.Errors +import GHC.Tc.Utils.Unify +import GHC.Iface.Rename +import GHC.Utils.Misc + +import Control.Monad +import Data.List (find) + +import {-# SOURCE #-} GHC.Tc.Module + +#include "HsVersions.h" + +fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc +fixityMisMatch real_thing real_fixity sig_fixity = + vcat [ppr real_thing <+> text "has conflicting fixities in the module", + text "and its hsig file", + text "Main module:" <+> ppr_fix real_fixity, + text "Hsig file:" <+> ppr_fix sig_fixity] + where + ppr_fix f = + ppr f <+> + (if f == defaultFixity + then parens (text "default") + else empty) + +checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () +checkHsigDeclM sig_iface sig_thing real_thing = do + let name = getName real_thing + -- TODO: Distinguish between signature merging and signature + -- implementation cases. + checkBootDeclM False sig_thing real_thing + real_fixity <- lookupFixityRn name + let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of + Nothing -> defaultFixity + Just f -> f + when (real_fixity /= sig_fixity) $ + addErrAt (nameSrcSpan name) + (fixityMisMatch real_thing real_fixity sig_fixity) + +-- | Given a 'ModDetails' of an instantiated signature (note that the +-- 'ModDetails' must be knot-tied consistently with the actual implementation) +-- and a 'GlobalRdrEnv' constructed from the implementor of this interface, +-- verify that the actual implementation actually matches the original +-- interface. +-- +-- Note that it is already assumed that the implementation *exports* +-- a sufficient set of entities, since otherwise the renaming and then +-- typechecking of the signature 'ModIface' would have failed. +checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () +checkHsigIface tcg_env gr sig_iface + ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, + md_types = sig_type_env, md_exports = sig_exports } = do + traceTc "checkHsigIface" $ vcat + [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] + mapM_ check_export (map availName sig_exports) + unless (null sig_fam_insts) $ + panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++ + "instances in hsig files yet...") + -- Delete instances so we don't look them up when + -- checking instance satisfiability + -- TODO: this should not be necessary + tcg_env <- getGblEnv + setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_insts = [], + tcg_fam_insts = [] } $ do + mapM_ check_inst sig_insts + failIfErrsM + where + -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig + -- in package p that defines T; and we implement with himpl:H. Then the + -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just + -- have to look up the right name. + sig_type_occ_env = mkOccEnv + . map (\t -> (nameOccName (getName t), t)) + $ nameEnvElts sig_type_env + dfun_names = map getName sig_insts + check_export name + -- Skip instances, we'll check them later + -- TODO: Actually this should never happen, because DFuns are + -- never exported... + | name `elem` dfun_names = return () + -- See if we can find the type directly in the hsig ModDetails + -- TODO: need to special case wired in names + | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do + -- NB: We use tcLookupImported_maybe because we want to EXCLUDE + -- tcg_env (TODO: but maybe this isn't relevant anymore). + r <- tcLookupImported_maybe name + case r of + Failed err -> addErr err + Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing + + -- The hsig did NOT define this function; that means it must + -- be a reexport. In this case, make sure the 'Name' of the + -- reexport matches the 'Name exported here. + | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = + when (name /= name') $ do + -- See Note [Error reporting bad reexport] + -- TODO: Actually this error swizzle doesn't work + let p (L _ ie) = name `elem` ieNames ie + loc = case tcg_rn_exports tcg_env of + Just es | Just e <- find p (map fst es) + -- TODO: maybe we can be a little more + -- precise here and use the Located + -- info for the *specific* name we matched. + -> getLoc e + _ -> nameSrcSpan name + addErrAt loc + (badReexportedBootThing False name name') + -- This should actually never happen, but whatever... + | otherwise = + addErrAt (nameSrcSpan name) + (missingBootThing False name "exported by") + +-- Note [Error reporting bad reexport] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NB: You want to be a bit careful about what location you report on reexports. +-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the +-- correct source location. However, if it was *reexported*, obviously the name +-- is not going to have the right location. In this case, we need to grovel in +-- tcg_rn_exports to figure out where the reexport came from. + + + +-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't +-- assume that the implementing file actually implemented the instances (they +-- may be reexported from elsewhere). Where should we look for the instances? +-- We do the same as we would otherwise: consult the EPS. This isn't perfect +-- (we might conclude the module exports an instance when it doesn't, see +-- #9422), but we will never refuse to compile something. +check_inst :: ClsInst -> TcM () +check_inst sig_inst = do + -- TODO: This could be very well generalized to support instance + -- declarations in boot files. + tcg_env <- getGblEnv + -- NB: Have to tug on the interface, not necessarily + -- tugged... but it didn't work? + mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) + -- Based off of 'simplifyDeriv' + let ty = idType (instanceDFunId sig_inst) + skol_info = InstSkol + -- Based off of tcSplitDFunTy + (tvs, theta, pred) = + case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, pred) -> + (tvs, theta, pred) }} + origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst + (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + (tclvl,cts) <- pushTcLevelM $ do + wanted <- newWanted origin + (Just TypeLevel) + (substTy skol_subst pred) + givens <- forM theta $ \given -> do + loc <- getCtLocM origin (Just TypeLevel) + let given_pred = substTy skol_subst (scaledThing given) + new_ev <- newEvVar given_pred + return CtGiven { ctev_pred = given_pred + -- Doesn't matter, make something up + , ctev_evar = new_ev + , ctev_loc = loc + } + return $ wanted : givens + unsolved <- simplifyWantedsTcM cts + + (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved + reportAllUnsolved (mkImplicWC implic) + +-- | Return this list of requirement interfaces that need to be merged +-- to form @mod_name@, or @[]@ if this is not a requirement. +requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule] +requirementMerges pkgstate mod_name = + fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) + where + -- update IndefUnitId ppr info as they may have changed since the + -- time the IndefUnitId was created + fixupModule (Module iud name) = Module iud' name + where + iud' = iud { instUnitInstanceOf = cid' } + cid = instUnitInstanceOf iud + cid' = updateIndefUnitId pkgstate cid + +-- | For a module @modname@ of type 'HscSource', determine the list +-- of extra "imports" of other requirements which should be considered part of +-- the import of the requirement, because it transitively depends on those +-- requirements by imports of modules from other packages. The situation +-- is something like this: +-- +-- unit p where +-- signature A +-- signature B +-- import A +-- +-- unit q where +-- dependency p[A=\,B=\] +-- signature A +-- signature B +-- +-- Although q's B does not directly import A, we still have to make sure we +-- process A first, because the merging process will cause B to indirectly +-- import A. This function finds the TRANSITIVE closure of all such imports +-- we need to make. +findExtraSigImports' :: HscEnv + -> HscSource + -> ModuleName + -> IO (UniqDSet ModuleName) +findExtraSigImports' hsc_env HsigFile modname = + fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) -> + (initIfaceLoad hsc_env + . withException + $ moduleFreeHolesPrecise (text "findExtraSigImports") + (mkModule (VirtUnit iuid) mod_name))) + where + pkgstate = unitState (hsc_dflags hsc_env) + reqs = requirementMerges pkgstate modname + +findExtraSigImports' _ _ _ = return emptyUniqDSet + +-- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and +-- "GHC.Tc.Module". +findExtraSigImports :: HscEnv -> HscSource -> ModuleName + -> IO [(Maybe FastString, Located ModuleName)] +findExtraSigImports hsc_env hsc_src modname = do + extra_requirements <- findExtraSigImports' hsc_env hsc_src modname + return [ (Nothing, noLoc mod_name) + | mod_name <- uniqDSetToList extra_requirements ] + +-- A version of 'implicitRequirements'' which is more friendly +-- for "GHC.Driver.Make" and "GHC.Tc.Module". +implicitRequirements :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [(Maybe FastString, Located ModuleName)] +implicitRequirements hsc_env normal_imports + = do mns <- implicitRequirements' hsc_env normal_imports + return [ (Nothing, noLoc mn) | mn <- mns ] + +-- Given a list of 'import M' statements in a module, figure out +-- any extra implicit requirement imports they may have. For +-- example, if they 'import M' and M resolves to p[A=], then +-- they actually also import the local requirement B. +implicitRequirements' :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [ModuleName] +implicitRequirements' hsc_env normal_imports + = fmap concat $ + forM normal_imports $ \(mb_pkg, L _ imp) -> do + found <- findImportedModule hsc_env imp mb_pkg + case found of + Found _ mod | not (isHomeModule dflags mod) -> + return (uniqDSetToList (moduleFreeHoles mod)) + _ -> return [] + where dflags = hsc_dflags hsc_env + +-- | Given a 'Unit', make sure it is well typed. This is because +-- unit IDs come from Cabal, which does not know if things are well-typed or +-- not; a component may have been filled with implementations for the holes +-- that don't actually fulfill the requirements. +checkUnit :: Unit -> TcM () +checkUnit HoleUnit = return () +checkUnit (RealUnit _) = return () -- if it's already compiled, must be well-typed +checkUnit (VirtUnit indef) = do + let insts = instUnitInsts indef + forM_ insts $ \(mod_name, mod) -> + -- NB: direct hole instantiations are well-typed by construction + -- (because we FORCE things to be merged in), so don't check them + when (not (isHoleModule mod)) $ do + checkUnit (moduleUnit mod) + _ <- mod `checkImplements` Module indef mod_name + return () + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnCheckUnit :: + HscEnv -> Unit -> + IO (Messages, Maybe ()) +tcRnCheckUnit hsc_env uid = + withTiming dflags + (text "Check unit id" <+> ppr uid) + (const ()) $ + initTc hsc_env + HsigFile -- bogus + False + mAIN -- bogus + (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus + $ checkUnit uid + where + dflags = hsc_dflags hsc_env + loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) + +-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... + +-- | Top-level driver for signature merging (run after typechecking +-- an @hsig@ file). +tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface + -> IO (Messages, Maybe TcGblEnv) +tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = + withTiming dflags + (text "Signature merging" <+> brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ + mergeSignatures hpm orig_tcg_env iface + where + dflags = hsc_dflags hsc_env + this_mod = mi_module iface + real_loc = tcg_top_loc orig_tcg_env + +thinModIface :: [AvailInfo] -> ModIface -> ModIface +thinModIface avails iface = + iface { + mi_exports = avails, + -- mi_fixities = ..., + -- mi_warns = ..., + -- mi_anns = ..., + -- TODO: The use of nameOccName here is a bit dodgy, because + -- perhaps there might be two IfaceTopBndr that are the same + -- OccName but different Name. Requires better understanding + -- of invariants here. + mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls + -- mi_insts = ..., + -- mi_fam_insts = ..., + } + where + decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs + filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) + + exported_occs = mkOccSet [ occName n + | a <- avails + , n <- availNames a ] + exported_decls = filter_decls exported_occs + + non_exported_occs = mkOccSet [ occName n + | (_, d) <- exported_decls + , n <- ifaceDeclNeverExportedRefs d ] + non_exported_decls = filter_decls non_exported_occs + + dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True + dfun_pred _ = False + dfun_decls = filter (dfun_pred . snd) (mi_decls iface) + +-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this +-- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept +-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps) +-- refers to it; we can't decide to keep it by looking at the exports +-- of a module after thinning. Keep this synchronized with +-- 'rnIfaceDecl'. +ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name] +ifaceDeclNeverExportedRefs d@IfaceFamily{} = + case ifFamFlav d of + IfaceClosedSynFamilyTyCon (Just (n, _)) + -> [n] + _ -> [] +ifaceDeclNeverExportedRefs _ = [] + + +-- Note [Blank hsigs for all requirements] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- One invariant that a client of GHC must uphold is that there +-- must be an hsig file for every requirement (according to +-- @-this-unit-id@); this ensures that for every interface +-- file (hi), there is a source file (hsig), which helps grease +-- the wheels of recompilation avoidance which assumes that +-- source files always exist. + +{- +inheritedSigPvpWarning :: WarningTxt +inheritedSigPvpWarning = + WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))] + where + msg = "Inherited requirements from non-signature libraries (libraries " ++ + "with modules) should not be used, as this mode of use is not " ++ + "compatible with PVP-style version bounds. Instead, copy the " ++ + "declaration to the local hsig file or move the signature to a " ++ + "library of its own and add that library as a dependency." +-} + +-- Note [Handling never-exported TyThings under Backpack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will +-- never be mentioned in the export list of a module (mi_avails). +-- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported +-- TyThings DO have a standalone IfaceDecl declaration in their +-- interface file. +-- +-- Originally, Backpack was designed under the assumption that anything +-- you could declare in a module could also be exported; thus, merging +-- the export lists of two signatures is just merging the declarations +-- of two signatures writ small. Of course, in GHC Haskell, there are a +-- few important things which are not explicitly exported but still can +-- be used: in particular, dictionary functions for instances, Typeable +-- TyCon bindings, and coercion axioms for type families also count. +-- +-- When handling these non-exported things, there two primary things +-- we need to watch out for: +-- +-- * Signature matching/merging is done by comparing each +-- of the exported entities of a signature and a module. These exported +-- entities may refer to non-exported TyThings which must be tested for +-- consistency. For example, an instance (ClsInst) will refer to a +-- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the +-- embedded 'DFunId' in 'is_dfun'. +-- +-- For this to work at all, we must ensure that pointers in 'is_dfun' refer +-- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same. +-- Unfortunately, this is the OPPOSITE of how we treat most other references +-- to 'Name's, so this case needs to be handled specially. +-- +-- The details are in the documentation for 'typecheckIfacesForMerging'. +-- and the Note [Resolving never-exported Names] in GHC.IfaceToCore. +-- +-- * When we rename modules and signatures, we use the export lists to +-- decide how the declarations should be renamed. However, this +-- means we don't get any guidance for how to rename non-exported +-- entities. Fortunately, we only need to rename these entities +-- *consistently*, so that 'typecheckIfacesForMerging' can wire them +-- up as needed. +-- +-- The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'. +-- +-- The root cause for all of these complications is the fact that these +-- logically "implicit" entities are defined indirectly in an interface +-- file. #13151 gives a proposal to make these *truly* implicit. + +merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc +merge_msg mod_name [] = + text "while checking the local signature" <+> ppr mod_name <+> + text "for consistency" +merge_msg mod_name reqs = + hang (text "while merging the signatures from" <> colon) + 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ + bullet <+> text "...and the local signature for" <+> ppr mod_name) + +-- | Given a local 'ModIface', merge all inherited requirements +-- from 'requirementMerges' into this signature, producing +-- a final 'TcGblEnv' that matches the local signature and +-- all required signatures. +mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv +mergeSignatures + (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), + hpm_src_files = src_files }) + orig_tcg_env lcl_iface0 = setSrcSpan loc $ do + -- The lcl_iface0 is the ModIface for the local hsig + -- file, which is guaranteed to exist, see + -- Note [Blank hsigs for all requirements] + hsc_env <- getTopEnv + dflags <- getDynFlags + + -- Copy over some things from the original TcGblEnv that + -- we want to preserve + updGblEnv (\env -> env { + -- Renamed imports/declarations are often used + -- by programs that use the GHC API, e.g., Haddock. + -- These won't get filled by the merging process (since + -- we don't actually rename the parsed module again) so + -- we need to take them directly from the previous + -- typechecking. + -- + -- NB: the export declarations aren't in their final + -- form yet. We'll fill those in when we reprocess + -- the export declarations. + tcg_rn_imports = tcg_rn_imports orig_tcg_env, + tcg_rn_decls = tcg_rn_decls orig_tcg_env, + -- Annotations + tcg_ann_env = tcg_ann_env orig_tcg_env, + -- Documentation header + tcg_doc_hdr = tcg_doc_hdr orig_tcg_env + -- tcg_dus? + -- tcg_th_used = tcg_th_used orig_tcg_env, + -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env + }) $ do + tcg_env <- getGblEnv + + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + mod_name = moduleName (tcg_mod tcg_env) + pkgstate = unitState dflags + + -- STEP 1: Figure out all of the external signature interfaces + -- we are going to merge in. + let reqs = requirementMerges pkgstate mod_name + + addErrCtxt (merge_msg mod_name reqs) $ do + + -- STEP 2: Read in the RAW forms of all of these interfaces + ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) -> + let m = mkModule (VirtUnit iuid) mod_name + im = fst (getModuleInstantiation m) + in fmap fst + . withException + $ findAndReadIface (text "mergeSignatures") im m NotBoot + + -- STEP 3: Get the unrenamed exports of all these interfaces, + -- thin it according to the export list, and do shaping on them. + let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as + -- This function gets run on every inherited interface, and + -- it's responsible for: + -- + -- 1. Merging the exports of the interface into @nsubst@, + -- 2. Adding these exports to the "OK to import" set (@oks@) + -- if they came from a package with no exposed modules + -- (this means we won't report a PVP error in this case), and + -- 3. Thinning the interface according to an explicit export + -- list. + -- + gen_subst (nsubst,oks,ifaces) (imod@(Module iuid _), ireq_iface) = do + let insts = instUnitInsts iuid + isFromSignaturePackage = + let inst_uid = instUnitInstanceOf iuid + pkg = unsafeLookupUnitId pkgstate (indefUnit inst_uid) + in null (unitExposedModules pkg) + -- 3(a). Rename the exports according to how the dependency + -- was instantiated. The resulting export list will be accurate + -- except for exports *from the signature itself* (which may + -- be subsequently updated by exports from other signatures in + -- the merge. + as1 <- tcRnModExports insts ireq_iface + -- 3(b). Thin the interface if it comes from a signature package. + (thinned_iface, as2) <- case mb_exports of + Just (L loc _) + -- Check if the package containing this signature is + -- a signature package (i.e., does not expose any + -- modules.) If so, we can thin it. + | isFromSignaturePackage + -> setSrcSpan loc $ do + -- Suppress missing errors; they might be used to refer + -- to entities from other signatures we are merging in. + -- If an identifier truly doesn't exist in any of the + -- signatures that are merged in, we will discover this + -- when we run exports_from_avail on the final merged + -- export list. + (mb_r, msgs) <- tryTc $ do + -- Suppose that we have written in a signature: + -- signature A ( module A ) where {- empty -} + -- If I am also inheriting a signature from a + -- signature package, does 'module A' scope over + -- all of its exports? + -- + -- There are two possible interpretations: + -- + -- 1. For non self-reexports, a module reexport + -- is interpreted only in terms of the local + -- signature module, and not any of the inherited + -- ones. The reason for this is because after + -- typechecking, module exports are completely + -- erased from the interface of a file, so we + -- have no way of "interpreting" a module reexport. + -- Thus, it's only useful for the local signature + -- module (where we have a useful GlobalRdrEnv.) + -- + -- 2. On the other hand, a common idiom when + -- you want to "export everything, plus a reexport" + -- in modules is to say module A ( module A, reex ). + -- This applies to signature modules too; and in + -- particular, you probably still want the entities + -- from the inherited signatures to be preserved + -- too. + -- + -- We think it's worth making a special case for + -- self reexports to make use case (2) work. To + -- do this, we take the exports of the inherited + -- signature @as1@, and bundle them into a + -- GlobalRdrEnv where we treat them as having come + -- from the import @import A@. Thus, we will + -- pick them up if they are referenced explicitly + -- (@foo@) or even if we do a module reexport + -- (@module A@). + let ispec = ImpSpec ImpDeclSpec{ + -- NB: This needs to be mod name + -- of the local signature, not + -- the (original) module name of + -- the inherited signature, + -- because we need module + -- LocalSig (from the local + -- export list) to match it! + is_mod = mod_name, + is_as = mod_name, + is_qual = False, + is_dloc = loc + } ImpAll + rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) + setGblEnv tcg_env { + tcg_rdr_env = rdr_env + } $ exports_from_avail mb_exports rdr_env + -- NB: tcg_imports is also empty! + emptyImportAvails + (tcg_semantic_mod tcg_env) + case mb_r of + Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) + Nothing -> addMessages msgs >> failM + -- We can't think signatures from non signature packages + _ -> return (ireq_iface, as1) + -- 3(c). Only identifiers from signature packages are "ok" to + -- import (that is, they are safe from a PVP perspective.) + -- (NB: This code is actually dead right now.) + let oks' | isFromSignaturePackage + = extendOccSetList oks (exportOccs as2) + | otherwise + = oks + -- 3(d). Extend the name substitution (performing shaping) + mb_r <- extend_ns nsubst as2 + case mb_r of + Left err -> failWithTc err + Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) + nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) + ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) + -- Process each interface, getting the thinned interfaces as well as + -- the final, full set of exports @nsubst@ and the exports which are + -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.) + (nsubst, ok_to_use, rev_thinned_ifaces) + <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) + let thinned_ifaces = reverse rev_thinned_ifaces + exports = nameShapeExports nsubst + rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports) + _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) + warns = NoWarnings + {- + -- TODO: Warnings are transitive, but this is not what we want here: + -- if a module reexports an entity from a signature, that should be OK. + -- Not supported in current warning framework + warns | null warn_occs = NoWarnings + | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs + -} + setGblEnv tcg_env { + -- The top-level GlobalRdrEnv is quite interesting. It consists + -- of two components: + -- 1. First, we reuse the GlobalRdrEnv of the local signature. + -- This is very useful, because it means that if we have + -- to print a message involving some entity that the local + -- signature imported, we'll qualify it accordingly. + -- 2. Second, we need to add all of the declarations we are + -- going to merge in (as they need to be in scope for the + -- final test of the export list.) + tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env, + -- Inherit imports from the local signature, so that module + -- reexports are picked up correctly + tcg_imports = tcg_imports orig_tcg_env, + tcg_exports = exports, + tcg_dus = usesOnly (availsToNameSetWithSelectors exports), + tcg_warns = warns + } $ do + tcg_env <- getGblEnv + + -- Make sure we didn't refer to anything that doesn't actually exist + -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return () + (mb_lies, _) <- exports_from_avail mb_exports rdr_env + (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) + + {- -- NB: This is commented out, because warns above is disabled. + -- If you tried to explicitly export an identifier that has a warning + -- attached to it, that's probably a mistake. Warn about it. + case mb_lies of + Nothing -> return () + Just lies -> + forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) -> + setSrcSpan loc $ + unless (nameOccName n `elemOccSet` ok_to_use) $ + addWarn NoReason $ vcat [ + text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.", + parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.") + ] + -} + + failIfErrsM + + -- Save the exports + setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do + tcg_env <- getGblEnv + + -- STEP 4: Rename the interfaces + ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> + tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface + lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0 + let ifaces = lcl_iface : ext_ifaces + + -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env + let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) + | (occ, f) <- concatMap mi_fixities ifaces + , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] + + -- STEP 5: Typecheck the interfaces + let type_env_var = tcg_type_env_var tcg_env + + -- typecheckIfacesForMerging does two things: + -- 1. It merges the all of the ifaces together, and typechecks the + -- result to type_env. + -- 2. It typechecks each iface individually, but with their 'Name's + -- resolving to the merged type_env from (1). + -- See typecheckIfacesForMerging for more details. + (type_env, detailss) <- initIfaceTcRn $ + typecheckIfacesForMerging inner_mod ifaces type_env_var + let infos = zip ifaces detailss + + -- Test for cycles + checkSynCycles (homeUnit dflags) (typeEnvTyCons type_env) [] + + -- NB on type_env: it contains NO dfuns. DFuns are recorded inside + -- detailss, and given a Name that doesn't correspond to anything real. See + -- also Note [Signature merging DFuns] + + -- Add the merged type_env to TcGblEnv, so that it gets serialized + -- out when we finally write out the interface. + -- + -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly, + -- rather than use tcExtendGlobalEnv (the normal method to add newly + -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these + -- TyThings to 'tcg_type_env_var', which is consulted when + -- we read in interfaces to tie the knot. But *these TyThings themselves + -- come from interface*, so that would result in deadlock. Don't + -- update it! + setGblEnv tcg_env { + tcg_tcs = typeEnvTyCons type_env, + tcg_patsyns = typeEnvPatSyns type_env, + tcg_type_env = type_env, + tcg_fix_env = fix_env + } $ do + tcg_env <- getGblEnv + + -- STEP 6: Check for compatibility/merge things + tcg_env <- (\x -> foldM x tcg_env infos) + $ \tcg_env (iface, details) -> do + + let check_export name + | Just sig_thing <- lookupTypeEnv (md_types details) name + = case lookupTypeEnv type_env (getName sig_thing) of + Just thing -> checkHsigDeclM iface sig_thing thing + Nothing -> panic "mergeSignatures: check_export" + -- Oops! We're looking for this export but it's + -- not actually in the type environment of the signature's + -- ModDetails. + -- + -- NB: This case happens because the we're iterating + -- over the union of all exports, so some interfaces + -- won't have everything. Note that md_exports is nonsense + -- (it's the same as exports); maybe we should fix this + -- eventually. + | otherwise + = return () + mapM_ check_export (map availName exports) + + -- Note [Signature merging instances] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Merge instances into the global environment. The algorithm here is + -- dumb and simple: if an instance has exactly the same DFun type + -- (tested by 'memberInstEnv') as an existing instance, we drop it; + -- otherwise, we add it even, even if this would cause overlap. + -- + -- Why don't we deduplicate instances with identical heads? There's no + -- good choice if they have premises: + -- + -- instance K1 a => K (T a) + -- instance K2 a => K (T a) + -- + -- Why not eagerly error in this case? The overlapping head does not + -- necessarily mean that the instances are unimplementable: in fact, + -- they may be implemented without overlap (if, for example, the + -- implementing module has 'instance K (T a)'; both are implemented in + -- this case.) The implements test just checks that the wanteds are + -- derivable assuming the givens. + -- + -- Still, overlapping instances with hypotheses like above are going + -- to be a bad deal, because instance resolution when we're typechecking + -- against the merged signature is going to have a bad time when + -- there are overlapping heads like this: we never backtrack, so it + -- may be difficult to see that a wanted is derivable. For now, + -- we hope that we get lucky / the overlapping instances never + -- get used, but it is not a very good situation to be in. + -- + let merge_inst (insts, inst_env) inst + | memberInstEnv inst_env inst -- test DFun Type equality + = (insts, inst_env) + | otherwise + -- NB: is_dfun_name inst is still nonsense here, + -- see Note [Signature merging DFuns] + = (inst:insts, extendInstEnv inst_env inst) + (insts, inst_env) = foldl' merge_inst + (tcg_insts tcg_env, tcg_inst_env tcg_env) + (md_insts details) + -- This is a HACK to prevent calculateAvails from including imp_mod + -- in the listing. We don't want it because a module is NOT + -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 + iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } + avails = plusImportAvails (tcg_imports tcg_env) $ + calculateAvails dflags iface' False NotBoot ImportedBySystem + return tcg_env { + tcg_inst_env = inst_env, + tcg_insts = insts, + tcg_imports = avails, + tcg_merged = + if outer_mod == mi_module iface + -- Don't add ourselves! + then tcg_merged tcg_env + else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env + } + + -- Note [Signature merging DFuns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Once we know all of instances which will be defined by this merged + -- signature, we go through each of the DFuns and rename them with a fresh, + -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing + -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'. + -- + -- We can't do this fixup earlier, because we need a way to identify each + -- source DFun (from each of the signatures we are merging in) so that + -- when we have a ClsInst, we can pull up the correct DFun to check if + -- the types match. + -- + -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename + dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do + n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) + let dfun = setVarName (is_dfun inst) n + return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) + tcg_env <- return tcg_env { + tcg_insts = map snd dfun_insts, + tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) + } + + addDependentFiles src_files + + return tcg_env + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnInstantiateSignature :: + HscEnv -> Module -> RealSrcSpan -> + IO (Messages, Maybe TcGblEnv) +tcRnInstantiateSignature hsc_env this_mod real_loc = + withTiming dflags + (text "Signature instantiation"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature + where + dflags = hsc_dflags hsc_env + +exportOccs :: [AvailInfo] -> [OccName] +exportOccs = concatMap (map occName . availNames) + +impl_msg :: Module -> InstantiatedModule -> SDoc +impl_msg impl_mod (Module req_uid req_mod_name) = + text "while checking that" <+> ppr impl_mod <+> + text "implements signature" <+> ppr req_mod_name <+> + text "in" <+> ppr req_uid + +-- | Check if module implements a signature. (The signature is +-- always un-hashed, which is why its components are specified +-- explicitly.) +checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv +checkImplements impl_mod req_mod@(Module uid mod_name) = + addErrCtxt (impl_msg impl_mod req_mod) $ do + let insts = instUnitInsts uid + + -- STEP 1: Load the implementing interface, and make a RdrEnv + -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', + -- so that we treat all orphan instances it provides as visible + -- when we verify that all instances are checked (see #12945), and so that + -- when we eventually write out the interface we record appropriate + -- dependency information. + impl_iface <- initIfaceTcRn $ + loadSysInterface (text "checkImplements 1") impl_mod + let impl_gr = mkGlobalRdrEnv + (gresFromAvails Nothing (mi_exports impl_iface)) + nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) + + -- Load all the orphans, so the subsequent 'checkHsigIface' sees + -- all the instances it needs to + loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") + (dep_orphs (mi_deps impl_iface)) + + dflags <- getDynFlags + let avails = calculateAvails dflags + impl_iface False{- safe -} NotBoot ImportedBySystem + fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) + | (occ, f) <- mi_fixities impl_iface + , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] + updGblEnv (\tcg_env -> tcg_env { + -- Setting tcg_rdr_env to treat all exported entities from + -- the implementing module as in scope improves error messages, + -- as it reduces the amount of qualification we need. Unfortunately, + -- we still end up qualifying references to external modules + -- (see bkpfail07 for an example); we'd need to record more + -- information in ModIface to solve this. + tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr, + tcg_imports = tcg_imports tcg_env `plusImportAvails` avails, + -- This is here so that when we call 'lookupFixityRn' for something + -- directly implemented by the module, we grab the right thing + tcg_fix_env = fix_env + }) $ do + + -- STEP 2: Load the *unrenamed, uninstantiated* interface for + -- the ORIGINAL signature. We are going to eventually rename it, + -- but we must proceed slowly, because it is NOT known if the + -- instantiation is correct. + let sig_mod = mkModule (VirtUnit uid) mod_name + isig_mod = fst (getModuleInstantiation sig_mod) + mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod NotBoot + isig_iface <- case mb_isig_iface of + Succeeded (iface, _) -> return iface + Failed err -> failWithTc $ + hang (text "Could not find hi interface for signature" <+> + quotes (ppr isig_mod) <> colon) 4 err + + -- STEP 3: Check that the implementing interface exports everything + -- we need. (Notice we IGNORE the Modules in the AvailInfos.) + forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> + case lookupGlobalRdrEnv impl_gr occ of + [] -> addErr $ quotes (ppr occ) + <+> text "is exported by the hsig file, but not" + <+> text "exported by the implementing module" + <+> quotes (ppr impl_mod) + _ -> return () + failIfErrsM + + -- STEP 4: Now that the export is complete, rename the interface... + sig_iface <- tcRnModIface insts (Just nsubst) isig_iface + + -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst + -- lets us determine how top-level identifiers should be handled.) + sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface + + -- STEP 6: Check that it's sufficient + tcg_env <- getGblEnv + checkHsigIface tcg_env impl_gr sig_iface sig_details + + -- STEP 7: Return the updated 'TcGblEnv' with the signature exports, + -- so we write them out. + return tcg_env { + tcg_exports = mi_exports sig_iface + } + +-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite +-- library to use the actual implementations of the relevant entities, +-- checking that the implementation matches the signature. +instantiateSignature :: TcRn TcGblEnv +instantiateSignature = do + tcg_env <- getGblEnv + dflags <- getDynFlags + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + -- TODO: setup the local RdrEnv so the error messages look a little better. + -- But this information isn't stored anywhere. Should we RETYPECHECK + -- the local one just to get the information? Hmm... + MASSERT( isHomeModule dflags outer_mod ) + MASSERT( isJust (homeUnitInstanceOfId dflags) ) + let uid = fromJust (homeUnitInstanceOfId dflags) + -- we need to fetch the most recent ppr infos from the unit + -- database because we might have modified it + uid' = updateIndefUnitId (unitState dflags) uid + inner_mod `checkImplements` + Module + (mkInstantiatedUnit uid' (homeUnitInstantiations dflags)) + (moduleName outer_mod) diff --git a/GHC/Tc/Utils/Env.hs b/GHC/Tc/Utils/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Env.hs @@ -0,0 +1,1167 @@ +-- (c) The University of Glasgow 2006 +{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an + -- orphan +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Utils.Env( + TyThing(..), TcTyThing(..), TcId, + + -- Instance environment, and InstInfo type + InstInfo(..), iDFunId, pprInstInfoDetails, + simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, + InstBindings(..), + + -- Global environment + tcExtendGlobalEnv, tcExtendTyConEnv, + tcExtendGlobalEnvImplicit, setGlobalTypeEnv, + tcExtendGlobalValEnv, + tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, + tcLookupTyCon, tcLookupClass, + tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, + tcLookupLocatedGlobalId, tcLookupLocatedTyCon, + tcLookupLocatedClass, tcLookupAxiom, + lookupGlobal, ioLookupDataCon, + addTypecheckedBinds, + + -- Local environment + tcExtendKindEnv, tcExtendKindEnvList, + tcExtendTyVarEnv, tcExtendNameTyVarEnv, + tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds, + tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, + tcExtendBinderStack, tcExtendLocalTypeEnv, + isTypeClosedLetBndr, + tcCheckUsage, + + tcLookup, tcLookupLocated, tcLookupLocalIds, + tcLookupId, tcLookupIdMaybe, tcLookupTyVar, + tcLookupTcTyCon, + tcLookupLcl_maybe, + getInLocalScope, + wrongThingErr, pprBinders, + + tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, + getTypeSigNames, + tcExtendRecEnv, -- For knot-tying + + -- Tidying + tcInitTidyEnv, tcInitOpenTidyEnv, + + -- Instances + tcLookupInstance, tcGetInstEnvs, + + -- Rules + tcExtendRules, + + -- Defaults + tcGetDefaultTys, + + -- Template Haskell stuff + checkWellStaged, tcMetaTy, thLevel, + topIdLvl, isBrackStage, + + -- New Ids + newDFunName, newFamInstTyConName, + newFamInstAxiomName, + mkStableIdFromString, mkStableIdFromName, + mkWrapperName + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Iface.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Core.UsageEnv +import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper) +import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult ) +import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) ) +import GHC.Iface.Load +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name.Reader +import GHC.Core.InstEnv +import GHC.Core.DataCon ( DataCon ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion.Axiom + +import GHC.Core.Class +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Var.Env +import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Types.SrcLoc +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.List.SetOps +import GHC.Utils.Error +import GHC.Data.Maybe( MaybeErr(..), orElse ) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.Misc ( HasDebugCallStack ) + +import Data.IORef +import Data.List (intercalate) +import Control.Monad + +{- ********************************************************************* +* * + An IO interface to looking up globals +* * +********************************************************************* -} + +lookupGlobal :: HscEnv -> Name -> IO TyThing +-- A variant of lookupGlobal_maybe for the clients which are not +-- interested in recovering from lookup failure and accept panic. +lookupGlobal hsc_env name + = do { + mb_thing <- lookupGlobal_maybe hsc_env name + ; case mb_thing of + Succeeded thing -> return thing + Failed msg -> pprPanic "lookupGlobal" msg + } + +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +-- This may look up an Id that one has previously looked up. +-- If so, we are going to read its interface file, and add its bindings +-- to the ExternalPackageTable. +lookupGlobal_maybe hsc_env name + = do { -- Try local envt + let mod = icInteractiveModule (hsc_IC hsc_env) + dflags = hsc_dflags hsc_env + tcg_semantic_mod = canonicalizeModuleIfHome dflags mod + + ; if nameIsLocalOrFrom tcg_semantic_mod name + then (return + (Failed (text "Can't find local name: " <+> ppr name))) + -- Internal names can happen in GHCi + else + -- Try home package table and external package table + lookupImported_maybe hsc_env name + } + +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +-- Returns (Failed err) if we can't find the interface file for the thing +lookupImported_maybe hsc_env name + = do { mb_thing <- lookupTypeHscEnv hsc_env name + ; case mb_thing of + Just thing -> return (Succeeded thing) + Nothing -> importDecl_maybe hsc_env name + } + +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +importDecl_maybe hsc_env name + | Just thing <- wiredInNameTyThing_maybe name + = do { when (needWiredInHomeIface thing) + (initIfaceLoad hsc_env (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] + ; return (Succeeded thing) } + | otherwise + = initIfaceLoad hsc_env (importDecl name) + +ioLookupDataCon :: HscEnv -> Name -> IO DataCon +ioLookupDataCon hsc_env name = do + mb_thing <- ioLookupDataCon_maybe hsc_env name + case mb_thing of + Succeeded thing -> return thing + Failed msg -> pprPanic "lookupDataConIO" msg + +ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon) +ioLookupDataCon_maybe hsc_env name = do + thing <- lookupGlobal hsc_env name + return $ case thing of + AConLike (RealDataCon con) -> Succeeded con + _ -> Failed $ + pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+> + text "used as a data constructor" + +addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv +addTypecheckedBinds tcg_env binds + | isHsBootOrSig (tcg_src tcg_env) = tcg_env + -- Do not add the code for record-selector bindings + -- when compiling hs-boot files + | otherwise = tcg_env { tcg_binds = foldr unionBags + (tcg_binds tcg_env) + binds } + +{- +************************************************************************ +* * +* tcLookupGlobal * +* * +************************************************************************ + +Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, +unless you know that the SrcSpan in the monad is already set to the +span of the Name. +-} + + +tcLookupLocatedGlobal :: Located Name -> TcM TyThing +-- c.f. GHC.IfaceToCore.tcIfaceGlobal +tcLookupLocatedGlobal name + = addLocM tcLookupGlobal name + +tcLookupGlobal :: Name -> TcM TyThing +-- The Name is almost always an ExternalName, but not always +-- In GHCi, we may make command-line bindings (ghci> let x = True) +-- that bind a GlobalId, but with an InternalName +tcLookupGlobal name + = do { -- Try local envt + env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of { + Just thing -> return thing ; + Nothing -> + + -- Should it have been in the local envt? + -- (NB: use semantic mod here, since names never use + -- identity module, see Note [Identity versus semantic module].) + if nameIsLocalOrFrom (tcg_semantic_mod env) name + then notFound name -- Internal names can happen in GHCi + else + + -- Try home package table and external package table + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return thing + Failed msg -> failWithTc msg + }}} + +-- Look up only in this module's global env't. Don't look in imports, etc. +-- Panic if it's not there. +tcLookupGlobalOnly :: Name -> TcM TyThing +tcLookupGlobalOnly name + = do { env <- getGblEnv + ; return $ case lookupNameEnv (tcg_type_env env) name of + Just thing -> thing + Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) } + +tcLookupDataCon :: Name -> TcM DataCon +tcLookupDataCon name = do + thing <- tcLookupGlobal name + case thing of + AConLike (RealDataCon con) -> return con + _ -> wrongThingErr "data constructor" (AGlobal thing) name + +tcLookupPatSyn :: Name -> TcM PatSyn +tcLookupPatSyn name = do + thing <- tcLookupGlobal name + case thing of + AConLike (PatSynCon ps) -> return ps + _ -> wrongThingErr "pattern synonym" (AGlobal thing) name + +tcLookupConLike :: Name -> TcM ConLike +tcLookupConLike name = do + thing <- tcLookupGlobal name + case thing of + AConLike cl -> return cl + _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name + +tcLookupClass :: Name -> TcM Class +tcLookupClass name = do + thing <- tcLookupGlobal name + case thing of + ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls + _ -> wrongThingErr "class" (AGlobal thing) name + +tcLookupTyCon :: Name -> TcM TyCon +tcLookupTyCon name = do + thing <- tcLookupGlobal name + case thing of + ATyCon tc -> return tc + _ -> wrongThingErr "type constructor" (AGlobal thing) name + +tcLookupAxiom :: Name -> TcM (CoAxiom Branched) +tcLookupAxiom name = do + thing <- tcLookupGlobal name + case thing of + ACoAxiom ax -> return ax + _ -> wrongThingErr "axiom" (AGlobal thing) name + +tcLookupLocatedGlobalId :: Located Name -> TcM Id +tcLookupLocatedGlobalId = addLocM tcLookupId + +tcLookupLocatedClass :: Located Name -> TcM Class +tcLookupLocatedClass = addLocM tcLookupClass + +tcLookupLocatedTyCon :: Located Name -> TcM TyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon + +-- Find the instance that exactly matches a type class application. The class arguments must be precisely +-- the same as in the instance declaration (modulo renaming & casts). +-- +tcLookupInstance :: Class -> [Type] -> TcM ClsInst +tcLookupInstance cls tys + = do { instEnv <- tcGetInstEnvs + ; case lookupUniqueInstEnv instEnv cls tys of + Left err -> failWithTc $ text "Couldn't match instance:" <+> err + Right (inst, tys) + | uniqueTyVars tys -> return inst + | otherwise -> failWithTc errNotExact + } + where + errNotExact = text "Not an exact match (i.e., some variables get instantiated)" + + uniqueTyVars tys = all isTyVarTy tys + && hasNoDups (map (getTyVar "tcLookupInstance") tys) + +tcGetInstEnvs :: TcM InstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetInstEnvs = do { eps <- getEps + ; env <- getGblEnv + ; return (InstEnvs { ie_global = eps_inst_env eps + , ie_local = tcg_inst_env env + , ie_visible = tcVisibleOrphanMods env }) } + +instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where + lookupThing = tcLookupGlobal + +{- +************************************************************************ +* * + Extending the global environment +* * +************************************************************************ +-} + +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + writeMutVar (tcg_type_env_var tcg_env) new_type_env + ; return (tcg_env { tcg_type_env = new_type_env }) } + + +tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r + -- Just extend the global environment with some TyThings + -- Do not extend tcg_tcs, tcg_patsyns etc +tcExtendGlobalEnvImplicit things thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } + +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendGlobalEnv things thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, + tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit things thing_inside + } + +tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendTyConEnv tycons thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside + } + +tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a + -- Same deal as tcExtendGlobalEnv, but for Ids +tcExtendGlobalValEnv ids thing_inside + = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside + +tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r +-- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs +tcExtendRecEnv gbl_stuff thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + tcg_env' = tcg_env { tcg_type_env = ge' } + -- No need for setGlobalTypeEnv (which side-effects the + -- tcg_type_env_var); tcExtendRecEnv is used just + -- when kind-check a group of type/class decls. It would + -- in any case be wrong for an interface-file decl to end up + -- with a TcTyCon in it! + ; setGblEnv tcg_env' thing_inside } + +{- +************************************************************************ +* * +\subsection{The local environment} +* * +************************************************************************ +-} + +tcLookupLocated :: Located Name -> TcM TcTyThing +tcLookupLocated = addLocM tcLookup + +tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) +tcLookupLcl_maybe name + = do { local_env <- getLclTypeEnv + ; return (lookupNameEnv local_env name) } + +tcLookup :: Name -> TcM TcTyThing +tcLookup name = do + local_env <- getLclTypeEnv + case lookupNameEnv local_env name of + Just thing -> return thing + Nothing -> (AGlobal <$> tcLookupGlobal name) + +tcLookupTyVar :: Name -> TcM TcTyVar +tcLookupTyVar name + = do { thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return tv + _ -> pprPanic "tcLookupTyVar" (ppr name) } + +tcLookupId :: Name -> TcM Id +-- Used when we aren't interested in the binding level, nor refinement. +-- The "no refinement" part means that we return the un-refined Id regardless +-- +-- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId) +tcLookupId name = do + thing <- tcLookupIdMaybe name + case thing of + Just id -> return id + _ -> pprPanic "tcLookupId" (ppr name) + +tcLookupIdMaybe :: Name -> TcM (Maybe Id) +tcLookupIdMaybe name + = do { thing <- tcLookup name + ; case thing of + ATcId { tct_id = id} -> return $ Just id + AGlobal (AnId id) -> return $ Just id + _ -> return Nothing } + +tcLookupLocalIds :: [Name] -> TcM [TcId] +-- We expect the variables to all be bound, and all at +-- the same level as the lookup. Only used in one place... +tcLookupLocalIds ns + = do { env <- getLclEnv + ; return (map (lookup (tcl_env env)) ns) } + where + lookup lenv name + = case lookupNameEnv lenv name of + Just (ATcId { tct_id = id }) -> id + _ -> pprPanic "tcLookupLocalIds" (ppr name) + +-- inferInitialKind has made a suitably-shaped kind for the type or class +-- Look it up in the local environment. This is used only for tycons +-- that we're currently type-checking, so we're sure to find a TcTyCon. +tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon +tcLookupTcTyCon name = do + thing <- tcLookup name + case thing of + ATcTyCon tc -> return tc + _ -> pprPanic "tcLookupTcTyCon" (ppr name) + +getInLocalScope :: TcM (Name -> Bool) +getInLocalScope = do { lcl_env <- getLclTypeEnv + ; return (`elemNameEnv` lcl_env) } + +tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r +-- Used only during kind checking, for TcThings that are +-- ATcTyCon or APromotionErr +-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr +tcExtendKindEnvList things thing_inside + = do { traceTc "tcExtendKindEnvList" (ppr things) + ; updLclEnv upd_env thing_inside } + where + upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } + +tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r +-- A variant of tcExtendKindEvnList +tcExtendKindEnv extra_env thing_inside + = do { traceTc "tcExtendKindEnv" (ppr extra_env) + ; updLclEnv upd_env thing_inside } + where + upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } + +----------------------- +-- Scoped type and kind variables +tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r +tcExtendTyVarEnv tvs thing_inside + = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside + +tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r +tcExtendNameTyVarEnv binds thing_inside + -- this should be used only for explicitly mentioned scoped variables. + -- thus, no coercion variables + = do { tc_extend_local_env NotTopLevel + [(name, ATyVar name tv) | (name, tv) <- binds] $ + tcExtendBinderStack tv_binds $ + thing_inside } + where + tv_binds :: [TcBinder] + tv_binds = [TcTvBndr name tv | (name,tv) <- binds] + +isTypeClosedLetBndr :: Id -> Bool +-- See Note [Bindings with closed types] in GHC.Tc.Types +isTypeClosedLetBndr = noFreeVarsOfType . idType + +tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a +-- Used for binding the recursive uses of Ids in a binding +-- both top-level value bindings and nested let/where-bindings +-- Does not extend the TcBinderStack +tcExtendRecIds pairs thing_inside + = tc_extend_local_env NotTopLevel + [ (name, ATcId { tct_id = let_id + , tct_info = NonClosedLet emptyNameSet False }) + | (name, let_id) <- pairs ] $ + thing_inside + +tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a +-- Used for binding the Ids that have a complete user type signature +-- Does not extend the TcBinderStack +tcExtendSigIds top_lvl sig_ids thing_inside + = tc_extend_local_env top_lvl + [ (idName id, ATcId { tct_id = id + , tct_info = info }) + | id <- sig_ids + , let closed = isTypeClosedLetBndr id + info = NonClosedLet emptyNameSet closed ] + thing_inside + + +tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed + -> [TcId] -> TcM a -> TcM a +-- Used for both top-level value bindings and nested let/where-bindings +-- Adds to the TcBinderStack too +tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) + ids thing_inside + = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $ + tc_extend_local_env top_lvl + [ (idName id, ATcId { tct_id = id + , tct_info = mk_tct_info id }) + | id <- ids ] + thing_inside + where + mk_tct_info id + | type_closed && isEmptyNameSet rhs_fvs = ClosedLet + | otherwise = NonClosedLet rhs_fvs type_closed + where + name = idName id + rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet + type_closed = isTypeClosedLetBndr id && + (fv_type_closed || hasCompleteSig sig_fn name) + +tcExtendIdEnv :: [TcId] -> TcM a -> TcM a +-- For lambda-bound and case-bound Ids +-- Extends the TcBinderStack as well +tcExtendIdEnv ids thing_inside + = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside + +tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a +-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair +tcExtendIdEnv1 name id thing_inside + = tcExtendIdEnv2 [(name,id)] thing_inside + +tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +tcExtendIdEnv2 names_w_ids thing_inside + = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel + | (_,mono_id) <- names_w_ids ] $ + tc_extend_local_env NotTopLevel + [ (name, ATcId { tct_id = id + , tct_info = NotLetBound }) + | (name,id) <- names_w_ids] + thing_inside + +tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a +tc_extend_local_env top_lvl extra_env thing_inside +-- Precondition: the argument list extra_env has TcTyThings +-- that ATcId or ATyVar, but nothing else +-- +-- Invariant: the ATcIds are fully zonked. Reasons: +-- (a) The kinds of the forall'd type variables are defaulted +-- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar) +-- (b) There are no via-Indirect occurrences of the bound variables +-- in the types, because instantiation does not look through such things +-- (c) The call to tyCoVarsOfTypes is ok without looking through refs + +-- The second argument of type TyVarSet is a set of type variables +-- that are bound together with extra_env and should not be regarded +-- as free in the types of extra_env. + = do { traceTc "tc_extend_local_env" (ppr extra_env) + ; stage <- getStage + ; env0@(TcLclEnv { tcl_rdr = rdr_env + , tcl_th_bndrs = th_bndrs + , tcl_env = lcl_type_env }) <- getLclEnv + + ; let thlvl = (top_lvl, thLevel stage) + + env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env + [ n | (n, _) <- extra_env, isInternalName n ] + -- The LocalRdrEnv contains only non-top-level names + -- (GlobalRdrEnv handles the top level) + + , tcl_th_bndrs = extendNameEnvList th_bndrs + [(n, thlvl) | (n, ATcId {}) <- extra_env] + -- We only track Ids in tcl_th_bndrs + + , tcl_env = extendNameEnvList lcl_type_env extra_env } + + -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and + -- Template Haskell staging env simultaneously. Reason for extending + -- LocalRdrEnv: after running a TH splice we need to do renaming. + + ; setLclEnv env1 thing_inside } + +tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv +tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things + = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } + +-- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the +-- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the +-- usage environment. See also Note [Wrapper returned from tcSubMult] in +-- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function. +tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper) +tcCheckUsage name id_mult thing_inside + = do { (local_usage, result) <- tcCollectingUsage thing_inside + ; wrapper <- check_then_add_usage local_usage + ; return (result, wrapper) } + where + check_then_add_usage :: UsageEnv -> TcM HsWrapper + -- Checks that the usage of the newly introduced binder is compatible with + -- its multiplicity, and combines the usage of non-new binders to |uenv| + check_then_add_usage uenv + = do { let actual_u = lookupUE uenv name + ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u) + ; wrapper <- case actual_u of + Bottom -> return idHsWrapper + Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult + MUsage m -> do { m <- promote_mult m + ; tcSubMult (UsageEnvironmentOf name) m id_mult } + ; tcEmitBindingUsage (deleteUE uenv name) + ; return wrapper } + + -- This is gross. The problem is in test case typecheck/should_compile/T18998: + -- f :: a %1-> Id n a -> Id n a + -- f x (MkId _) = MkId x + -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors + -- invents a new multiplicity variable p[2] for the application MkId x. This + -- variable is at level 2, bumped because of the GADT pattern-match (MkId _). + -- We eventually unify the variable with One, due to the call to tcSubMult in + -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check + -- fails. + -- + -- What to do? If we did inference "for real", the sub-multiplicity constraint + -- would end up in the implication of the GADT pattern-match, and all would + -- be well. But we don't have a real sub-multiplicity constraint to put in + -- the implication. (Multiplicity inference works outside the usual generate- + -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we + -- must promote all multiplicity variables to reflect this outer TcLevel. + -- It's reminiscent of floating a constraint, really, so promotion is + -- appropriate. The promoteTcType function works only on types of kind TYPE rr, + -- so we can't use it here. Thus, this dirtiness. + -- + -- It works nicely in practice. + -- + -- We use a set to avoid calling promoteMetaTyVarTo twice on the same + -- metavariable. This happened in #19400. + promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m) + ; any_promoted <- promoteTyVarSet fvs + ; if any_promoted then zonkTcType m else return m + } + +{- ********************************************************************* +* * + The TcBinderStack +* * +********************************************************************* -} + +tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a +tcExtendBinderStack bndrs thing_inside + = do { traceTc "tcExtendBinderStack" (ppr bndrs) + ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) + thing_inside } + +tcInitTidyEnv :: TcM TidyEnv +-- We initialise the "tidy-env", used for tidying types before printing, +-- by building a reverse map from the in-scope type variables to the +-- OccName that the programmer originally used for them +tcInitTidyEnv + = do { lcl_env <- getLclEnv + ; go emptyTidyEnv (tcl_bndrs lcl_env) } + where + go (env, subst) [] + = return (env, subst) + go (env, subst) (b : bs) + | TcTvBndr name tyvar <- b + = do { let (env', occ') = tidyOccName env (nameOccName name) + name' = tidyNameOcc name occ' + tyvar1 = setTyVarName tyvar name' + ; tyvar2 <- zonkTcTyVarToTyVar tyvar1 + -- Be sure to zonk here! Tidying applies to zonked + -- types, so if we don't zonk we may create an + -- ill-kinded type (#14175) + ; go (env', extendVarEnv subst tyvar tyvar2) bs } + | otherwise + = go (env, subst) bs + +-- | Get a 'TidyEnv' that includes mappings for all vars free in the given +-- type. Useful when tidying open types. +tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv +tcInitOpenTidyEnv tvs + = do { env1 <- tcInitTidyEnv + ; let env2 = tidyFreeTyCoVars env1 tvs + ; return env2 } + + + +{- ********************************************************************* +* * + Adding placeholders +* * +********************************************************************* -} + +tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a +-- See Note [AFamDataCon: not promoting data family constructors] +tcAddDataFamConPlaceholders inst_decls thing_inside + = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) + | lid <- inst_decls, con <- get_cons lid ] + thing_inside + -- Note [AFamDataCon: not promoting data family constructors] + where + -- get_cons extracts the *constructor* bindings of the declaration + get_cons :: LInstDecl GhcRn -> [Name] + get_cons (L _ (TyFamInstD {})) = [] + get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid + get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) + = concatMap (get_fi_cons . unLoc) fids + + get_fi_cons :: DataFamInstDecl GhcRn -> [Name] + get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) + = map unLoc $ concatMap (getConNames . unLoc) cons + + +tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a +-- See Note [Don't promote pattern synonyms] +tcAddPatSynPlaceholders pat_syns thing_inside + = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) + | PSB{ psb_id = L _ name } <- pat_syns ] + thing_inside + +getTypeSigNames :: [LSig GhcRn] -> NameSet +-- Get the names that have a user type sig +getTypeSigNames sigs + = foldr get_type_sig emptyNameSet sigs + where + get_type_sig :: LSig GhcRn -> NameSet -> NameSet + get_type_sig sig ns = + case sig of + L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names) + L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names) + _ -> ns + + +{- Note [AFamDataCon: not promoting data family constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T Int = MkT + data Proxy (a :: k) + data S = MkS (Proxy 'MkT) + +Is it ok to use the promoted data family instance constructor 'MkT' in +the data declaration for S (where both declarations live in the same module)? +No, we don't allow this. It *might* make sense, but at least it would mean that +we'd have to interleave typechecking instances and data types, whereas at +present we do data types *then* instances. + +So to check for this we put in the TcLclEnv a binding for all the family +constructors, bound to AFamDataCon, so that if we trip over 'MkT' when +type checking 'S' we'll produce a decent error message. + +#12088 describes this limitation. Of course, when MkT and S live in +different modules then all is well. + +Note [Don't promote pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never promote pattern synonyms. + +Consider this (#11265): + pattern A = True + instance Eq A +We want a civilised error message from the occurrence of 'A' +in the instance, yet 'A' really has not yet been type checked. + +Similarly (#9161) + {-# LANGUAGE PatternSynonyms, DataKinds #-} + pattern A = () + b :: A + b = undefined +Here, the type signature for b mentions A. But A is a pattern +synonym, which is typechecked as part of a group of bindings (for very +good reasons; a view pattern in the RHS may mention a value binding). +It is entirely reasonable to reject this, but to do so we need A to be +in the kind environment when kind-checking the signature for B. + +Hence tcAddPatSynPlaceholers adds a binding + A -> APromotionErr PatSynPE +to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind +environment, and will give a 'wrongThingErr' as a result. But the +lookup of A won't fail. + + +************************************************************************ +* * +\subsection{Rules} +* * +************************************************************************ +-} + +tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a + -- Just pop the new rules into the EPS and envt resp + -- All the rules come from an interface file, not source + -- Nevertheless, some may be for this module, if we read + -- its interface instead of its source code +tcExtendRules lcl_rules thing_inside + = do { env <- getGblEnv + ; let + env' = env { tcg_rules = lcl_rules ++ tcg_rules env } + ; setGblEnv env' thing_inside } + +{- +************************************************************************ +* * + Meta level +* * +************************************************************************ +-} + +checkWellStaged :: SDoc -- What the stage check is for + -> ThLevel -- Binding level (increases inside brackets) + -> ThLevel -- Use stage + -> TcM () -- Fail if badly staged, adding an error +checkWellStaged pp_thing bind_lvl use_lvl + | use_lvl >= bind_lvl -- OK! Used later than bound + = return () -- E.g. \x -> [| $(f x) |] + + | bind_lvl == outerLevel -- GHC restriction on top level splices + = stageRestrictionError pp_thing + + | otherwise -- Badly staged + = failWithTc $ -- E.g. \x -> $(f x) + text "Stage error:" <+> pp_thing <+> + hsep [text "is bound at stage" <+> ppr bind_lvl, + text "but used at stage" <+> ppr use_lvl] + +stageRestrictionError :: SDoc -> TcM a +stageRestrictionError pp_thing + = failWithTc $ + sep [ text "GHC stage restriction:" + , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," + , text "and must be imported, not defined locally"])] + +topIdLvl :: Id -> ThLevel +-- Globals may either be imported, or may be from an earlier "chunk" +-- (separated by declaration splices) of this module. The former +-- *can* be used inside a top-level splice, but the latter cannot. +-- Hence we give the former impLevel, but the latter topLevel +-- E.g. this is bad: +-- x = [| foo |] +-- $( f x ) +-- By the time we are processing the $(f x), the binding for "x" +-- will be in the global env, not the local one. +topIdLvl id | isLocalId id = outerLevel + | otherwise = impLevel + +tcMetaTy :: Name -> TcM Type +-- Given the name of a Template Haskell data type, +-- return the type +-- E.g. given the name "Expr" return the type "Expr" +tcMetaTy tc_name = do + t <- tcLookupTyCon tc_name + return (mkTyConTy t) + +isBrackStage :: ThStage -> Bool +isBrackStage (Brack {}) = True +isBrackStage _other = False + +{- +************************************************************************ +* * + getDefaultTys +* * +************************************************************************ +-} + +tcGetDefaultTys :: TcM ([Type], -- Default types + (Bool, -- True <=> Use overloaded strings + Bool)) -- True <=> Use extended defaulting rules +tcGetDefaultTys + = do { dflags <- getDynFlags + ; let ovl_strings = xopt LangExt.OverloadedStrings dflags + extended_defaults = xopt LangExt.ExtendedDefaultRules dflags + -- See also #1974 + flags = (ovl_strings, extended_defaults) + + ; mb_defaults <- getDeclaredDefaultTys + ; case mb_defaults of { + Just tys -> return (tys, flags) ; + -- User-supplied defaults + Nothing -> do + + -- No use-supplied default + -- Use [Integer, Double], plus modifications + { integer_ty <- tcMetaTy integerTyConName + ; list_ty <- tcMetaTy listTyConName + ; checkWiredInTyCon doubleTyCon + ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] + -- Note [Extended defaults] + ++ [integer_ty, doubleTy] + ++ opt_deflt ovl_strings [stringTy] + ; return (deflt_tys, flags) } } } + where + opt_deflt True xs = xs + opt_deflt False _ = [] + +{- +Note [Extended defaults] +~~~~~~~~~~~~~~~~~~~~~ +In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we +try when defaulting. This has very little real impact, except in the following case. +Consider: + Text.Printf.printf "hello" +This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't +want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to +default the 'a' to (), rather than to Integer (which is what would otherwise happen; +and then GHCi doesn't attempt to print the (). So in interactive mode, we add +() to the list of defaulting types. See #1200. + +Additionally, the list type [] is added as a default specialization for +Traversable and Foldable. As such the default default list now has types of +varying kinds, e.g. ([] :: * -> *) and (Integer :: *). + +************************************************************************ +* * +\subsection{The InstInfo type} +* * +************************************************************************ + +The InstInfo type summarises the information in an instance declaration + + instance c => k (t tvs) where b + +It is used just for *local* instance decls (not ones from interface files). +But local instance decls includes + - derived ones + - generic ones +as well as explicit user written ones. +-} + +data InstInfo a + = InstInfo + { iSpec :: ClsInst -- Includes the dfun id + , iBinds :: InstBindings a + } + +iDFunId :: InstInfo a -> DFunId +iDFunId info = instanceDFunId (iSpec info) + +data InstBindings a + = InstBindings + { ib_tyvars :: [Name] -- Names of the tyvars from the instance head + -- that are lexically in scope in the bindings + -- Must correspond 1-1 with the forall'd tyvars + -- of the dfun Id. When typechecking, we are + -- going to extend the typechecker's envt with + -- ib_tyvars -> dfun_forall_tyvars + + , ib_binds :: LHsBinds a -- Bindings for the instance methods + + , ib_pragmas :: [LSig a] -- User pragmas recorded for generating + -- specialised instances + + , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should + -- be enabled when type-checking + -- this instance; needed for + -- GeneralizedNewtypeDeriving + + , ib_derived :: Bool + -- True <=> This code was generated by GHC from a deriving clause + -- or standalone deriving declaration + -- Used only to improve error messages + } + +instance (OutputableBndrId a) + => Outputable (InstInfo (GhcPass a)) where + ppr = pprInstInfoDetails + +pprInstInfoDetails :: (OutputableBndrId a) + => InstInfo (GhcPass a) -> SDoc +pprInstInfoDetails info + = hang (pprInstanceHdr (iSpec info) <+> text "where") + 2 (details (iBinds info)) + where + details (InstBindings { ib_pragmas = p, ib_binds = b }) = + pprDeclList (pprLHsBindsForUser b p) + +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) +simpleInstInfoClsTy info = case instanceHead (iSpec info) of + (_, cls, [ty]) -> (cls, ty) + _ -> panic "simpleInstInfoClsTy" + +simpleInstInfoTy :: InstInfo a -> Type +simpleInstInfoTy info = snd (simpleInstInfoClsTy info) + +simpleInstInfoTyCon :: InstInfo a -> TyCon + -- Gets the type constructor for a simple instance declaration, + -- i.e. one of the form instance (...) => C (T a b c) where ... +simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) + +-- | Make a name for the dict fun for an instance decl. It's an *external* +-- name, like other top-level names, and hence must be made with +-- newGlobalBinder. +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name +newDFunName clas tys loc + = do { is_boot <- tcIsHsBootOrSig + ; mod <- getModule + ; let info_string = occNameString (getOccName clas) ++ + concatMap (occNameString.getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) + ; newGlobalBinder mod dfun_occ loc } + +newFamInstTyConName :: Located Name -> [Type] -> TcM Name +newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] + +newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name +newFamInstAxiomName (L loc name) branches + = mk_fam_inst_name mkInstTyCoOcc loc name branches + +mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name +mk_fam_inst_name adaptOcc loc tc_name tyss + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + intercalate "|" ty_strings + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod (adaptOcc occ) loc } + where + ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss + +{- +Stable names used for foreign exports and annotations. +For stable names, the name must be unique (see #1533). If the +same thing has several stable Ids based on it, the +top-level bindings generated must not have the same name. +Hence we create an External name (doesn't change), and we +append a Unique to the string right here. +-} + +mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromString str sig_ty loc occ_wrapper = do + uniq <- newUnique + mod <- getModule + name <- mkWrapperName "stable" str + let occ = mkVarOccFS name :: OccName + gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name + id = mkExportedVanillaId gnm sig_ty :: Id + return id + +mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromName nm = mkStableIdFromString (getOccString nm) + +mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) + => String -> String -> m FastString +mkWrapperName what nameBase + = do dflags <- getDynFlags + thisMod <- getModule + let -- Note [Generating fresh names for ccall wrapper] + wrapperRef = nextWrapperNum dflags + pkg = unitString (moduleUnit thisMod) + mod = moduleNameString (moduleName thisMod) + wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> + let num = lookupWithDefaultModuleEnv mod_env 0 thisMod + mod_env' = extendModuleEnv mod_env thisMod (num+1) + in (mod_env', num) + let components = [what, show wrapperNum, pkg, mod, nameBase] + return $ mkFastString $ zEncodeString $ intercalate ":" components + +{- +Note [Generating fresh names for FFI wrappers] + +We used to use a unique, rather than nextWrapperNum, to distinguish +between FFI wrapper functions. However, the wrapper names that we +generate are external names. This means that if a call to them ends up +in an unfolding, then we can't alpha-rename them, and thus if the +unique randomly changes from one compile to another then we get a +spurious ABI change (#4012). + +The wrapper counter has to be per-module, not global, so that the number we end +up using is not dependent on the modules compiled before the current one. +-} + +{- +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +pprBinders :: [Name] -> SDoc +-- Used in error messages +-- Use quotes for a single one; they look a bit "busy" for several +pprBinders [bndr] = quotes (ppr bndr) +pprBinders bndrs = pprWithCommas ppr bndrs + +notFound :: Name -> TcM TyThing +notFound name + = do { lcl_env <- getLclEnv + ; let stage = tcl_th_ctxt lcl_env + ; case stage of -- See Note [Out of scope might be a staging error] + Splice {} + | isUnboundName name -> failM -- If the name really isn't in scope + -- don't report it again (#11941) + | otherwise -> stageRestrictionError (quotes (ppr name)) + _ -> failWithTc $ + vcat[text "GHC internal error:" <+> quotes (ppr name) <+> + text "is not in scope during type checking, but it passed the renamer", + text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] + -- Take care: printing the whole gbl env can + -- cause an infinite loop, in the case where we + -- are in the middle of a recursive TyCon/Class group; + -- so let's just not print it! Getting a loop here is + -- very unhelpful, because it hides one compiler bug with another + } + +wrongThingErr :: String -> TcTyThing -> Name -> TcM a +-- It's important that this only calls pprTcTyThingCategory, which in +-- turn does not look at the details of the TcTyThing. +-- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind +wrongThingErr expected thing name + = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> + text "used as a" <+> text expected) + +{- Note [Out of scope might be a staging error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = 3 + data T = MkT $(foo x) + +where 'foo' is imported from somewhere. + +This is really a staging error, because we can't run code involving 'x'. +But in fact the type checker processes types first, so 'x' won't even be +in the type envt when we look for it in $(foo x). So inside splices we +report something missing from the type env as a staging error. +See #5752 and #5795. +-} diff --git a/GHC/Tc/Utils/Env.hs-boot b/GHC/Tc/Utils/Env.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Env.hs-boot @@ -0,0 +1,10 @@ +module GHC.Tc.Utils.Env where + +import GHC.Tc.Types( TcM ) +import GHC.Types.Var.Env( TidyEnv ) + +-- Annoyingly, there's a recursion between tcInitTidyEnv +-- (which does zonking and hence needs GHC.Tc.Utils.TcMType) and +-- addErrTc etc which live in GHC.Tc.Utils.Monad. Rats. +tcInitTidyEnv :: TcM TidyEnv + diff --git a/GHC/Tc/Utils/Instantiate.hs b/GHC/Tc/Utils/Instantiate.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Instantiate.hs @@ -0,0 +1,991 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, MultiWayIf, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Tc.Utils.Instantiate ( + topSkolemise, + topInstantiate, topInstantiateInferred, + instCall, instDFunType, instStupidTheta, instTyVarsWith, + newWanted, newWanteds, + + tcInstType, tcInstTypeBndrs, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, + tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, + + freshenTyVarBndrs, freshenCoVarBndrsX, + + tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, + + newOverloadedLit, mkOverLit, + + newClsInst, + tcGetInsts, tcGetInstEnvs, getOverlapFlag, + tcExtendLocalInstEnv, + instCallConstraints, newMethodFromName, + tcSyntaxName, + + -- Simple functions over evidence variables + tyCoVarsOfWC, + tyCoVarsOfCt, tyCoVarsOfCts, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp ) +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) + +import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence +import GHC.Core.InstEnv +import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) +import GHC.Core ( isOrphan ) +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Utils.TcMType +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( debugPprType ) +import GHC.Tc.Utils.TcType +import GHC.Driver.Types +import GHC.Core.Class( Class ) +import GHC.Types.Id.Make( mkDictFunId ) +import GHC.Core( Expr(..) ) -- For the Coercion constructor +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var +import GHC.Core.DataCon +import GHC.Types.Var.Env +import GHC.Builtin.Names +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Basic ( TypeOrKind(..) ) +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ( sortBy, mapAccumL ) +import Control.Monad( unless ) +import Data.Function ( on ) + +{- +************************************************************************ +* * + Creating and emittind constraints +* * +************************************************************************ +-} + +newMethodFromName + :: CtOrigin -- ^ why do we need this? + -> Name -- ^ name of the method + -> [TcRhoType] -- ^ types with which to instantiate the class + -> TcM (HsExpr GhcTc) +-- ^ Used when 'Name' is the wired-in name for a wired-in class method, +-- so the caller knows its type for sure, which should be of form +-- +-- > forall a. C a => +-- +-- 'newMethodFromName' is supposed to instantiate just the outer +-- type variable and constraint + +newMethodFromName origin name ty_args + = do { id <- tcLookupId name + -- Use tcLookupId not tcLookupGlobalId; the method is almost + -- always a class op, but with -XRebindableSyntax GHC is + -- meant to find whatever thing is in scope, and that may + -- be an ordinary function. + + ; let ty = piResultTys (idType id) ty_args + (theta, _caller_knows_this) = tcSplitPhiTy ty + ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) + instCall origin ty_args theta + + ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } + +{- +************************************************************************ +* * + Instantiation and skolemisation +* * +************************************************************************ + +Note [Skolemisation] +~~~~~~~~~~~~~~~~~~~~ +topSkolemise decomposes and skolemises a type, returning a type +with no top level foralls or (=>) + +Examples: + + topSkolemise (forall a. Ord a => a -> a) + = ( wp, [a], [d:Ord a], a->a ) + where wp = /\a. \(d:Ord a). a d + + topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b ) + where wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). a d1 b d2 + +This second example is the reason for the recursive 'go' +function in topSkolemise: we must remove successive layers +of foralls and (=>). + +In general, + if topSkolemise ty = (wrap, tvs, evs, rho) + and e :: rho + then wrap e :: ty + and 'wrap' binds {tvs, evs} + +-} + +topSkolemise :: TcSigmaType + -> TcM ( HsWrapper + , [(Name,TyVar)] -- All skolemised variables + , [EvVar] -- All "given"s + , TcRhoType ) +-- See Note [Skolemisation] +topSkolemise ty + = go init_subst idHsWrapper [] [] ty + where + init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + + -- Why recursive? See Note [Skolemisation] + go subst wrap tv_prs ev_vars ty + | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty + , not (null tvs && null theta) + = do { (subst', tvs1) <- tcInstSkolTyVarsX subst tvs + ; ev_vars1 <- newEvVars (substTheta subst' theta) + ; go subst' + (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1) + (tv_prs ++ (map tyVarName tvs `zip` tvs1)) + (ev_vars ++ ev_vars1) + inner_ty } + + | otherwise + = return (wrap, tv_prs, ev_vars, substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +-- | Instantiate all outer type variables +-- and any context. Never looks through arrows. +topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- if topInstantiate ty = (wrap, rho) +-- and e :: ty +-- then wrap e :: rho (that is, wrap :: ty "->" rho) +-- NB: always returns a rho-type, with no top-level forall or (=>) +topInstantiate = top_instantiate True + +-- | Instantiate all outer 'Inferred' binders +-- and any context. Never looks through arrows or specified type variables. +-- Used for visible type application. +topInstantiateInferred :: CtOrigin -> TcSigmaType + -> TcM (HsWrapper, TcSigmaType) +-- if topInstantiate ty = (wrap, rho) +-- and e :: ty +-- then wrap e :: rho +-- NB: may return a sigma-type +topInstantiateInferred = top_instantiate False + +top_instantiate :: Bool -- True <=> instantiate *all* variables + -- False <=> instantiate only the inferred ones + -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +top_instantiate inst_all orig ty + | (binders, phi) <- tcSplitForAllVarBndrs ty + , (theta, rho) <- tcSplitPhiTy phi + , not (null binders && null theta) + = do { let (inst_bndrs, leave_bndrs) = span should_inst binders + (inst_theta, leave_theta) + | null leave_bndrs = (theta, []) + | otherwise = ([], theta) + in_scope = mkInScopeSet (tyCoVarsOfType ty) + empty_subst = mkEmptyTCvSubst in_scope + inst_tvs = binderVars inst_bndrs + ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs + ; let inst_theta' = substTheta subst inst_theta + sigma' = substTy subst (mkForAllTys leave_bndrs $ + mkPhiTy leave_theta rho) + inst_tv_tys' = mkTyVarTys inst_tvs' + + ; wrap1 <- instCall orig inst_tv_tys' inst_theta' + ; traceTc "Instantiating" + (vcat [ text "all tyvars?" <+> ppr inst_all + , text "origin" <+> pprCtOrigin orig + , text "type" <+> debugPprType ty + , text "theta" <+> ppr theta + , text "leave_bndrs" <+> ppr leave_bndrs + , text "with" <+> vcat (map debugPprType inst_tv_tys') + , text "theta:" <+> ppr inst_theta' ]) + + ; (wrap2, rho2) <- + if null leave_bndrs -- NB: if inst_all is True then leave_bndrs = [] + + -- account for types like forall a. Num a => forall b. Ord b => ... + then top_instantiate inst_all orig sigma' + + -- but don't loop if there were any un-inst'able tyvars + else return (idHsWrapper, sigma') + + ; return (wrap2 <.> wrap1, rho2) } + + | otherwise = return (idHsWrapper, ty) + where + + should_inst bndr + | inst_all = True + | otherwise = binderArgFlag bndr == Inferred + +instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst +-- Use this when you want to instantiate (forall a b c. ty) with +-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might +-- not yet match (perhaps because there are unsolved constraints; #14154) +-- If they don't match, emit a kind-equality to promise that they will +-- eventually do so, and thus make a kind-homongeneous substitution. +instTyVarsWith orig tvs tys + = go emptyTCvSubst tvs tys + where + go subst [] [] + = return subst + go subst (tv:tvs) (ty:tys) + | tv_kind `tcEqType` ty_kind + = go (extendTvSubstAndInScope subst tv ty) tvs tys + | otherwise + = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind + ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } + where + tv_kind = substTy subst (tyVarKind tv) + ty_kind = tcTypeKind ty + + go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) + + +{- +************************************************************************ +* * + Instantiating a call +* * +************************************************************************ + +Note [Handling boxed equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The solver deals entirely in terms of unboxed (primitive) equality. +There should never be a boxed Wanted equality. Ever. But, what if +we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality +is boxed, so naive treatment here would emit a boxed Wanted equality. + +So we simply check for this case and make the right boxing of evidence. + +-} + +---------------- +instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper +-- Instantiate the constraints of a call +-- (instCall o tys theta) +-- (a) Makes fresh dictionaries as necessary for the constraints (theta) +-- (b) Throws these dictionaries into the LIE +-- (c) Returns an HsWrapper ([.] tys dicts) + +instCall orig tys theta + = do { dict_app <- instCallConstraints orig theta + ; return (dict_app <.> mkWpTyApps tys) } + +---------------- +instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper +-- Instantiates the TcTheta, puts all constraints thereby generated +-- into the LIE, and returns a HsWrapper to enclose the call site. + +instCallConstraints orig preds + | null preds + = return idHsWrapper + | otherwise + = do { evs <- mapM go preds + ; traceTc "instCallConstraints" (ppr evs) + ; return (mkWpEvApps evs) } + where + go :: TcPredType -> TcM EvTerm + go pred + | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 + = do { co <- unifyType Nothing ty1 ty2 + ; return (evCoercion co) } + + -- Try short-cut #2 + | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred + , tc `hasKey` heqTyConKey + = do { co <- unifyType Nothing ty1 ty2 + ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) } + + | otherwise + = emitWanted orig pred + +instDFunType :: DFunId -> [DFunInstType] + -> TcM ( [TcType] -- instantiated argument types + , TcThetaType ) -- instantiated constraint +-- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv +instDFunType dfun_id dfun_inst_tys + = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys + ; return (inst_tys, substTheta subst dfun_theta) } + where + dfun_ty = idType dfun_id + (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) + -- With quantified constraints, the + -- type of a dfun may not be closed + + go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) + go subst [] [] = return (subst, []) + go subst (tv:tvs) (Just ty : mb_tys) + = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) + tvs + mb_tys + ; return (subst', ty : tys) } + go subst (tv:tvs) (Nothing : mb_tys) + = do { (subst', tv') <- newMetaTyVarX subst tv + ; (subst'', tys) <- go subst' tvs mb_tys + ; return (subst'', mkTyVarTy tv' : tys) } + go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys) + +---------------- +instStupidTheta :: CtOrigin -> TcThetaType -> TcM () +-- Similar to instCall, but only emit the constraints in the LIE +-- Used exclusively for the 'stupid theta' of a data constructor +instStupidTheta orig theta + = do { _co <- instCallConstraints orig theta -- Discard the coercion + ; return () } + + +{- ********************************************************************* +* * + Instantiating Kinds +* * +********************************************************************* -} + +-- | Given ty::forall k1 k2. k, instantiate all the invisible forall-binders +-- returning ty @kk1 @kk2 :: k[kk1/k1, kk2/k1] +tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind) +tcInstInvisibleTyBinders ty kind + = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind + ; return (mkAppTys ty extra_args, kind') } + where + n_invis = invisibleTyBndrCount kind + +tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind) +tcInstInvisibleTyBindersN 0 kind + = return ([], kind) +tcInstInvisibleTyBindersN n ty + = go n empty_subst ty + where + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + + go n subst kind + | n > 0 + , Just (bndr, body) <- tcSplitPiTy_maybe kind + , isInvisibleBinder bndr + = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr + ; (args, inner_ty) <- go (n-1) subst' body + ; return (arg:args, inner_ty) } + | otherwise + = return ([], substTy subst kind) + +-- | Used only in *types* +tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) +tcInstInvisibleTyBinder subst (Named (Bndr tv _)) + = do { (subst', tv') <- newMetaTyVarX subst tv + ; return (subst', mkTyVarTy tv') } + +tcInstInvisibleTyBinder subst (Anon af ty) + | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty)) + -- Equality is the *only* constraint currently handled in types. + -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep + = ASSERT( af == InvisArg ) + do { co <- unifyKind Nothing k1 k2 + ; arg' <- mk co + ; return (subst, arg') } + + | otherwise -- This should never happen + -- See GHC.Core.TyCo.Rep Note [Constraints in kinds] + = pprPanic "tcInvisibleTyBinder" (ppr ty) + +------------------------------- +get_eq_tys_maybe :: Type + -> Maybe ( Coercion -> TcM Type + -- given a coercion proving t1 ~# t2, produce the + -- right instantiation for the TyBinder at hand + , Type -- t1 + , Type -- t2 + ) +-- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep +get_eq_tys_maybe ty + -- Lifted heterogeneous equality (~~) + | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty + , tc `hasKey` heqTyConKey + = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2) + + -- Lifted homogeneous equality (~) + | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty + , tc `hasKey` eqTyConKey + = Just (\co -> mkEqBoxTy co k1 k2, k1, k2) + + | otherwise + = Nothing + +-- | This takes @a ~# b@ and returns @a ~~ b@. +mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +-- monadic just for convenience with mkEqBoxTy +mkHEqBoxTy co ty1 ty2 + = return $ + mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] + where k1 = tcTypeKind ty1 + k2 = tcTypeKind ty2 + +-- | This takes @a ~# b@ and returns @a ~ b@. +mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +mkEqBoxTy co ty1 ty2 + = return $ + mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] + where k = tcTypeKind ty1 + +{- ********************************************************************* +* * + SkolemTvs (immutable) +* * +********************************************************************* -} + +tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) + -- ^ How to instantiate the type variables + -> Id -- ^ Type to instantiate + -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) +tcInstType inst_tyvars id + | null tyvars -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + = return ([], theta, tau) + | otherwise + = do { (subst, tyvars') <- inst_tyvars tyvars + ; let tv_prs = map tyVarName tyvars `zip` tyvars' + subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho) + ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } + where + (tyvars, rho) = tcSplitForAllTys (idType id) + (theta, tau) = tcSplitPhiTy rho + +tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType) + -- (type vars, preds (incl equalities), rho) +-- Instantiate the binders of a type signature with TyVarTvs +tcInstTypeBndrs id + | null tyvars -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + = return ([], theta, tau) + | otherwise + = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptyTCvSubst tyvars + ; let tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars' + subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho) + ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } + where + (tyvars, rho) = splitForAllTysInvis (idType id) + (theta, tau) = tcSplitPhiTy rho + + inst_invis_bndr :: TCvSubst -> InvisTVBinder + -> TcM (TCvSubst, InvisTVBinder) + inst_invis_bndr subst (Bndr tv spec) + = do { (subst', tv') <- newMetaTyVarTyVarX subst tv + ; return (subst', Bndr tv' spec) } + +tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) +-- Instantiate a type signature with skolem constants. +-- We could give them fresh names, but no need to do so +tcSkolDFunType dfun + = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun + ; return (map snd tv_prs, theta, tau) } + +tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) +-- Make skolem constants, but do *not* give them new names, as above +-- Moreover, make them "super skolems"; see comments with superSkolemTv +-- see Note [Kind substitution when instantiating] +-- Precondition: tyvars should be ordered by scoping +tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst + +tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) +tcSuperSkolTyVar subst tv + = (extendTvSubstWithClone subst tv new_tv, new_tv) + where + kind = substTyUnchecked subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv + +-- | Given a list of @['TyVar']@, skolemize the type variables, +-- returning a substitution mapping the original tyvars to the +-- skolems, and the list of newly bound skolems. +tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst + +tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False + +tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst + +tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] +tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst + +tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +-- Skolemise one level deeper, hence pushTcLevel +-- See Note [Skolemising type variables] +tcInstSkolTyVarsPushLevel overlappable subst tvs + = do { tc_lvl <- getTcLevel + ; let pushed_lvl = pushTcLevel tc_lvl + ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } + +tcInstSkolTyVarsAt :: TcLevel -> Bool + -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsAt lvl overlappable subst tvs + = freshenTyCoVarsX new_skol_tv subst tvs + where + details = SkolemTv lvl overlappable + new_skol_tv name kind = mkTcTyVar name kind details + +------------------ +freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) +-- ^ Give fresh uniques to a bunch of TyVars, but they stay +-- as TyVars, rather than becoming TcTyVars +-- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.newClsInst' +freshenTyVarBndrs = freshenTyCoVars mkTyVar + +freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) +-- ^ Give fresh uniques to a bunch of CoVars +-- Used in "GHC.Tc.Instance.Family.newFamInst" +freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst + +------------------ +freshenTyCoVars :: (Name -> Kind -> TyCoVar) + -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) +freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst + +freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) + -> TCvSubst -> [TyCoVar] + -> TcM (TCvSubst, [TyCoVar]) +freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) + +freshenTyCoVarX :: (Name -> Kind -> TyCoVar) + -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) +-- This a complete freshening operation: +-- the skolems have a fresh unique, and a location from the monad +-- See Note [Skolemising type variables] +freshenTyCoVarX mk_tcv subst tycovar + = do { loc <- getSrcSpanM + ; uniq <- newUnique + ; let old_name = tyVarName tycovar + -- Force so we don't retain reference to the old name and id + -- See (#19619) for more discussion + !old_occ_name = getOccName old_name + new_name = mkInternalName uniq old_occ_name loc + new_kind = substTyUnchecked subst (tyVarKind tycovar) + new_tcv = mk_tcv new_name new_kind + subst1 = extendTCvSubstWithClone subst tycovar new_tcv + ; return (subst1, new_tcv) } + +{- Note [Skolemising type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcInstSkolTyVars family of functions instantiate a list of TyVars +to fresh skolem TcTyVars. Important notes: + +a) Level allocation. We generally skolemise /before/ calling + pushLevelAndCaptureConstraints. So we want their level to the level + of the soon-to-be-created implication, which has a level ONE HIGHER + than the current level. Hence the pushTcLevel. It feels like a + slight hack. + +b) The [TyVar] should be ordered (kind vars first) + See Note [Kind substitution when instantiating] + +c) It's a complete freshening operation: the skolems have a fresh + unique, and a location from the monad + +d) The resulting skolems are + non-overlappable for tcInstSkolTyVars, + but overlappable for tcInstSuperSkolTyVars + See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example + of where this matters. + +Note [Kind substitution when instantiating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we instantiate a bunch of kind and type variables, first we +expect them to be topologically sorted. +Then we have to instantiate the kind variables, build a substitution +from old variables to the new variables, then instantiate the type +variables substituting the original kind. + +Exemple: If we want to instantiate + [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] +we want + [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] +instead of the bogus + [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] +-} + +{- ********************************************************************* +* * + Literals +* * +********************************************************************* -} + +{- +In newOverloadedLit we convert directly to an Int or Integer if we +know that's what we want. This may save some time, by not +temporarily generating overloaded literals, but it won't catch all +cases (the rest are caught in lookupInst). + +-} + +newOverloadedLit :: HsOverLit GhcRn + -> ExpRhoType + -> TcM (HsOverLit GhcTc) +newOverloadedLit + lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty + | not rebindable + = do { res_ty <- expTypeToType res_ty + ; dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + -- Do not generate a LitInst for rebindable syntax. + -- Reason: If we do, tcSimplify will call lookupInst, which + -- will call tcSyntaxName, which does unification, + -- which tcSimplify doesn't like + Just expr -> return (lit { ol_witness = expr + , ol_ext = OverLitTc False res_ty }) + Nothing -> newNonTrivialOverloadedLit orig lit + (mkCheckExpType res_ty) } + + | otherwise + = newNonTrivialOverloadedLit orig lit res_ty + where + orig = LiteralOrigin lit + +-- Does not handle things that 'shortCutLit' can handle. See also +-- newOverloadedLit in GHC.Tc.Utils.Unify +newNonTrivialOverloadedLit :: CtOrigin + -> HsOverLit GhcRn + -> ExpRhoType + -> TcM (HsOverLit GhcTc) +newNonTrivialOverloadedLit orig + lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) + , ol_ext = rebindable }) res_ty + = do { hs_lit <- mkOverLit val + ; let lit_ty = hsLitType hs_lit + ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) + [synKnownType lit_ty] res_ty $ + \_ _ -> return () + ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] + ; res_ty <- readExpType res_ty + ; return (lit { ol_witness = witness + , ol_ext = OverLitTc rebindable res_ty }) } +newNonTrivialOverloadedLit _ lit _ + = pprPanic "newNonTrivialOverloadedLit" (ppr lit) + +------------ +mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) +mkOverLit (HsIntegral i) + = do { integer_ty <- tcMetaTy integerTyConName + ; return (HsInteger (il_text i) + (il_value i) integer_ty) } + +mkOverLit (HsFractional r) + = do { rat_ty <- tcMetaTy rationalTyConName + ; return (HsRat noExtField r rat_ty) } + +mkOverLit (HsIsString src s) = return (HsString src s) + +{- +************************************************************************ +* * + Re-mappable syntax + + Used only for arrow syntax -- find a way to nuke this +* * +************************************************************************ + +Suppose we are doing the -XRebindableSyntax thing, and we encounter +a do-expression. We have to find (>>) in the current environment, which is +done by the rename. Then we have to check that it has the same type as +Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had +this: + + (>>) :: HB m n mn => m a -> n b -> mn b + +So the idea is to generate a local binding for (>>), thus: + + let then72 :: forall a b. m a -> m b -> m b + then72 = ...something involving the user's (>>)... + in + ...the do-expression... + +Now the do-expression can proceed using then72, which has exactly +the expected type. + +In fact tcSyntaxName just generates the RHS for then72, because we only +want an actual binding in the do-expression case. For literals, we can +just use the expression inline. +-} + +tcSyntaxName :: CtOrigin + -> TcType -- ^ Type to instantiate it at + -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) + -> TcM (Name, HsExpr GhcTc) + -- ^ (Standard name, suitable expression) +-- USED ONLY FOR CmdTop (sigh) *** +-- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" + +tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) + | std_nm == user_nm + = do rhs <- newMethodFromName orig std_nm [ty] + return (std_nm, rhs) + +tcSyntaxName orig ty (std_nm, user_nm_expr) = do + std_id <- tcLookupId std_nm + let + -- C.f. newMethodAtLoc + ([tv], _, tau) = tcSplitSigmaTy (idType std_id) + sigma1 = substTyWith [tv] [ty] tau + -- Actually, the "tau-type" might be a sigma-type in the + -- case of locally-polymorphic methods. + + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do + + -- Check that the user-supplied thing has the + -- same type as the standard one. + -- Tiresome jiggling because tcCheckSigma takes a located expression + span <- getSrcSpanM + expr <- tcCheckPolyExpr (L span user_nm_expr) sigma1 + return (std_nm, unLoc expr) + +syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv + -> TcRn (TidyEnv, SDoc) +syntaxNameCtxt name orig ty tidy_env + = do { inst_loc <- getCtLocM orig (Just TypeLevel) + ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) + <+> text "(needed by a syntactic construct)" + , nest 2 (text "has the required type:" + <+> ppr (tidyType tidy_env ty)) + , nest 2 (pprCtLoc inst_loc) ] + ; return (tidy_env, msg) } + +{- +************************************************************************ +* * + Instances +* * +************************************************************************ +-} + +getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag +-- Construct the OverlapFlag from the global module flags, +-- but if the overlap_mode argument is (Just m), +-- set the OverlapMode to 'm' +getOverlapFlag overlap_mode + = do { dflags <- getDynFlags + ; let overlap_ok = xopt LangExt.OverlappingInstances dflags + incoherent_ok = xopt LangExt.IncoherentInstances dflags + use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags + , overlapMode = x } + default_oflag | incoherent_ok = use (Incoherent NoSourceText) + | overlap_ok = use (Overlaps NoSourceText) + | otherwise = use (NoOverlap NoSourceText) + + final_oflag = setOverlapModeMaybe default_oflag overlap_mode + ; return final_oflag } + +tcGetInsts :: TcM [ClsInst] +-- Gets the local class instances. +tcGetInsts = fmap tcg_insts getGblEnv + +newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcM ClsInst +newClsInst overlap_mode dfun_name tvs theta clas tys + = do { (subst, tvs') <- freshenTyVarBndrs tvs + -- Be sure to freshen those type variables, + -- so they are sure not to appear in any lookup + ; let tys' = substTys subst tys + + dfun = mkDictFunId dfun_name tvs theta clas tys + -- The dfun uses the original 'tvs' because + -- (a) they don't need to be fresh + -- (b) they may be mentioned in the ib_binds field of + -- an InstInfo, and in GHC.Tc.Utils.Env.pprInstInfoDetails it's + -- helpful to use the same names + + ; oflag <- getOverlapFlag overlap_mode + ; let inst = mkLocalInstance dfun oflag tvs' clas tys' + ; warnIfFlag Opt_WarnOrphans + (isOrphan (is_orphan inst)) + (instOrphWarn inst) + ; return inst } + +instOrphWarn :: ClsInst -> SDoc +instOrphWarn inst + = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) + $$ text "To avoid this" + $$ nest 4 (vcat possibilities) + where + possibilities = + text "move the instance declaration to the module of the class or of the type, or" : + text "wrap the type with a newtype and declare the instance on the new type." : + [] + +tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a + -- Add new locally-defined instances +tcExtendLocalInstEnv dfuns thing_inside + = do { traceDFuns dfuns + ; env <- getGblEnv + -- Force the access to the TcgEnv so it isn't retained. + -- During auditing it is much easier to observe in -hi profiles if + -- there are a very small number of TcGblEnv. Keeping a TcGblEnv + -- alive is quite dangerous because it contains reference to many + -- large data structures. + ; let !init_inst_env = tcg_inst_env env + !init_insts = tcg_insts env + ; (inst_env', cls_insts') <- foldlM addLocalInst + (init_inst_env, init_insts) + dfuns + ; let env' = env { tcg_insts = cls_insts' + , tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- If overwrite_inst, then we can overwrite a direct match +addLocalInst (home_ie, my_insts) ispec + = do { + -- Load imported instances, so that we report + -- duplicates correctly + + -- 'matches' are existing instance declarations that are less + -- specific than the new one + -- 'dups' are those 'matches' that are equal to the new one + ; isGHCi <- getIsGHCi + ; eps <- getEps + ; tcg_env <- getGblEnv + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + -- See Note [Override identical instances in GHCi] + ; let home_ie' + | isGHCi = deleteFromInstEnv home_ie ispec + | otherwise = home_ie + + global_ie = eps_inst_env eps + inst_envs = InstEnvs { ie_global = global_ie + , ie_local = home_ie' + , ie_visible = tcVisibleOrphanMods tcg_env } + + -- Check for inconsistent functional dependencies + ; let inconsistent_ispecs = checkFunDeps inst_envs ispec + ; unless (null inconsistent_ispecs) $ + funDepErr ispec inconsistent_ispecs + + -- Check for duplicate instance decls. + ; let (_tvs, cls, tys) = instanceHead ispec + (matches, _, _) = lookupInstEnv False inst_envs cls tys + dups = filter (identicalClsInstHead ispec) (map fst matches) + ; unless (null dups) $ + dupInstErr ispec (head dups) + + ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } + +{- +Note [Signature files and type class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instances in signature files do not have an effect when compiling: +when you compile a signature against an implementation, you will +see the instances WHETHER OR NOT the instance is declared in +the file (this is because the signatures go in the EPS and we +can't filter them out easily.) This is also why we cannot +place the instance in the hi file: it would show up as a duplicate, +and we don't have instance reexports anyway. + +However, you might find them useful when typechecking against +a signature: the instance is a way of indicating to GHC that +some instance exists, in case downstream code uses it. + +Implementing this is a little tricky. Consider the following +situation (sigof03): + + module A where + instance C T where ... + + module ASig where + instance C T + +When compiling ASig, A.hi is loaded, which brings its instances +into the EPS. When we process the instance declaration in ASig, +we should ignore it for the purpose of doing a duplicate check, +since it's not actually a duplicate. But don't skip the check +entirely, we still want this to fail (tcfail221): + + module ASig where + instance C T + instance C T + +Note that in some situations, the interface containing the type +class instances may not have been loaded yet at all. The usual +situation when A imports another module which provides the +instances (sigof02m): + + module A(module B) where + import B + +See also Note [Signature lazy interface loading]. We can't +rely on this, however, since sometimes we'll have spurious +type class instances in the EPS, see #9422 (sigof02dm) + +************************************************************************ +* * + Errors and tracing +* * +************************************************************************ +-} + +traceDFuns :: [ClsInst] -> TcRn () +traceDFuns ispecs + = traceTc "Adding instances:" (vcat (map pp ispecs)) + where + pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) + 2 (ppr ispec) + -- Print the dfun name itself too + +funDepErr :: ClsInst -> [ClsInst] -> TcRn () +funDepErr ispec ispecs + = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") + (ispec : ispecs) + +dupInstErr :: ClsInst -> ClsInst -> TcRn () +dupInstErr ispec dup_ispec + = addClsInstsErr (text "Duplicate instance declarations:") + [ispec, dup_ispec] + +addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () +addClsInstsErr herald ispecs + = setSrcSpan (getSrcSpan (head sorted)) $ + addErr (hang herald 2 (pprInstances sorted)) + where + sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs + -- The sortBy just arranges that instances are displayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users diff --git a/GHC/Tc/Utils/Monad.hs b/GHC/Tc/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Monad.hs @@ -0,0 +1,2092 @@ +{- +(c) The University of Glasgow 2006 + +-} + +{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE ViewPatterns #-} + + +-- | Functions for working with the typechecker environment (setters, +-- getters...). +module GHC.Tc.Utils.Monad( + -- * Initialisation + initTc, initTcWithGbl, initTcInteractive, initTcRnIf, + + -- * Simple accessors + discardResult, + getTopEnv, updTopEnv, getGblEnv, updGblEnv, + setGblEnv, getLclEnv, updLclEnv, setLclEnv, + getEnvs, setEnvs, + xoptM, doptM, goptM, woptM, + setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, + whenDOptM, whenGOptM, whenWOptM, + whenXOptM, unlessXOptM, + getGhcMode, + withDoDynamicToo, + getEpsVar, + getEps, + updateEps, updateEps_, + getHpt, getEpsAndHpt, + + -- * Arrow scopes + newArrowScope, escapeArrowScope, + + -- * Unique supply + newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, + newSysName, newSysLocalId, newSysLocalIds, + + -- * Accessing input/output + newTcRef, readTcRef, writeTcRef, updTcRef, + + -- * Debugging + traceTc, traceRn, traceOptTcRn, dumpOptTcRn, + dumpTcRn, + getPrintUnqualified, + printForUserTcRn, + traceIf, traceHiDiffs, traceOptIf, + debugTc, + + -- * Typechecker global environment + getIsGHCi, getGHCiMonad, getInteractivePrintName, + tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, + getRdrEnvs, getImports, + getFixityEnv, extendFixityEnv, getRecFieldEnv, + getDeclaredDefaultTys, + addDependentFiles, + + -- * Error management + getSrcSpanM, setSrcSpan, addLocM, inGeneratedCode, + wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, + getErrsVar, setErrsVar, + addErr, + failWith, failAt, + addErrAt, addErrs, + checkErr, + addMessages, + discardWarnings, + + -- * Usage environment + tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, + + -- * Shared error message stuff: renamer and typechecker + mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, + reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, + attemptM, tryTc, + askNoErrs, discardErrs, tryTcDiscardingErrs, + checkNoErrs, whenNoErrs, + ifErrsM, failIfErrsM, + + -- * Context management for the type checker + getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, + addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, + + -- * Error message generation (type checker) + addErrTc, + addErrTcM, + failWithTc, failWithTcM, + checkTc, checkTcM, + failIfTc, failIfTcM, + warnIfFlag, warnIf, warnTc, warnTcM, + addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, + mkErrInfo, + + -- * Type constraints + newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, + addTcEvBind, addTopEvBinds, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + chooseUniqueOccTc, + getConstraintVar, setConstraintVar, + emitConstraints, emitStaticConstraints, emitSimple, emitSimples, + emitImplication, emitImplications, emitInsoluble, + emitHole, emitHoles, + discardConstraints, captureConstraints, tryCaptureConstraints, + pushLevelAndCaptureConstraints, + pushTcLevelM_, pushTcLevelM, pushTcLevelsM, + getTcLevel, setTcLevel, isTouchableTcM, + getLclTypeEnv, setLclTypeEnv, + traceTcConstraints, + emitNamedTypeHole, emitAnonTypeHole, + + -- * Template Haskell context + recordThUse, recordThSpliceUse, + keepAlive, getStage, getStageAndBindLevel, setStage, + addModFinalizersWithLclEnv, + + -- * Safe Haskell context + recordUnsafeInfer, finalSafeMode, fixSafeInstances, + + -- * Stuff for the renamer's local env + getLocalRdrEnv, setLocalRdrEnv, + + -- * Stuff for interface decls + mkIfLclEnv, + initIfaceTcRn, + initIfaceCheck, + initIfaceLcl, + initIfaceLclWithSubst, + initIfaceLoad, + getIfModule, + failIfM, + forkM_maybe, + forkM, + setImplicitEnvM, + + withException, + + -- * Stuff for cost centres. + ContainsCostCentreState(..), getCCIndexM, + + -- * Types etc. + module GHC.Tc.Types, + module GHC.Data.IOEnv + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Tc.Types -- Re-export all +import GHC.Data.IOEnv -- Re-export all +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin + +import GHC.Hs hiding (LIE) +import GHC.Driver.Types +import GHC.Unit +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Core.UsageEnv +import GHC.Core.Multiplicity +import GHC.Core.Type + +import GHC.Tc.Utils.TcType +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Builtin.Names + +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Error +import GHC.Types.SrcLoc +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Data.Bag +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique.Supply +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Types.Annotations +import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) +import GHC.Data.Maybe +import GHC.Types.CostCentre.State + +import qualified GHC.LanguageExtensions as LangExt + +import Data.IORef +import Control.Monad + +import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv ) + +import qualified Data.Map as Map + +{- +************************************************************************ +* * + initTc +* * +************************************************************************ +-} + +-- | Setup the initial typechecking environment +initTc :: HscEnv + -> HscSource + -> Bool -- True <=> retain renamed syntax trees + -> Module + -> RealSrcSpan + -> TcM r + -> IO (Messages, Maybe r) + -- Nothing => error thrown by the thing inside + -- (error messages should have been printed already) + +initTc hsc_env hsc_src keep_rn_syntax mod loc do_this + = do { keep_var <- newIORef emptyNameSet ; + used_gre_var <- newIORef [] ; + th_var <- newIORef False ; + th_splice_var<- newIORef False ; + infer_var <- newIORef (True, emptyBag) ; + dfun_n_var <- newIORef emptyOccSet ; + type_env_var <- case hsc_type_env_var hsc_env of { + Just (_mod, te_var) -> return te_var ; + Nothing -> newIORef emptyNameEnv } ; + + dependent_files_var <- newIORef [] ; + static_wc_var <- newIORef emptyWC ; + cc_st_var <- newIORef newCostCentreState ; + th_topdecls_var <- newIORef [] ; + th_foreign_files_var <- newIORef [] ; + th_topnames_var <- newIORef emptyNameSet ; + th_modfinalizers_var <- newIORef [] ; + th_coreplugins_var <- newIORef [] ; + th_state_var <- newIORef Map.empty ; + th_remote_state_var <- newIORef Nothing ; + let { + dflags = hsc_dflags hsc_env ; + + maybe_rn_syntax :: forall a. a -> Maybe a ; + maybe_rn_syntax empty_val + | dopt Opt_D_dump_rn_ast dflags = Just empty_val + + | gopt Opt_WriteHie dflags = Just empty_val + + -- We want to serialize the documentation in the .hi-files, + -- and need to extract it from the renamed syntax first. + -- See 'GHC.HsToCore.Docs.extractDocs'. + | gopt Opt_Haddock dflags = Just empty_val + + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + + gbl_env = TcGblEnv { + tcg_th_topdecls = th_topdecls_var, + tcg_th_foreign_files = th_foreign_files_var, + tcg_th_topnames = th_topnames_var, + tcg_th_modfinalizers = th_modfinalizers_var, + tcg_th_coreplugins = th_coreplugins_var, + tcg_th_state = th_state_var, + tcg_th_remote_state = th_remote_state_var, + + tcg_mod = mod, + tcg_semantic_mod = + canonicalizeModuleIfHome dflags mod, + tcg_src = hsc_src, + tcg_rdr_env = emptyGlobalRdrEnv, + tcg_fix_env = emptyNameEnv, + tcg_field_env = emptyNameEnv, + tcg_default = if moduleUnit mod == primUnit + || moduleUnit mod == bignumUnit + then Just [] -- See Note [Default types] + else Nothing, + tcg_type_env = emptyNameEnv, + tcg_type_env_var = type_env_var, + tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_ann_env = emptyAnnEnv, + tcg_th_used = th_var, + tcg_th_splice_used = th_splice_var, + tcg_exports = [], + tcg_imports = emptyImportAvails, + tcg_used_gres = used_gre_var, + tcg_dus = emptyDUs, + + tcg_rn_imports = [], + tcg_rn_exports = + if hsc_src == HsigFile + -- Always retain renamed syntax, so that we can give + -- better errors. (TODO: how?) + then Just [] + else maybe_rn_syntax [], + tcg_rn_decls = maybe_rn_syntax emptyRnGroup, + tcg_tr_module = Nothing, + tcg_binds = emptyLHsBinds, + tcg_imp_specs = [], + tcg_sigs = emptyNameSet, + tcg_ev_binds = emptyBag, + tcg_warns = NoWarnings, + tcg_anns = [], + tcg_tcs = [], + tcg_insts = [], + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_patsyns = [], + tcg_merged = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, + tcg_doc_hdr = Nothing, + tcg_hpc = False, + tcg_main = Nothing, + tcg_self_boot = NoSelfBoot, + tcg_safeInfer = infer_var, + tcg_dependent_files = dependent_files_var, + tcg_tc_plugins = [], + tcg_hf_plugins = [], + tcg_top_loc = loc, + tcg_static_wc = static_wc_var, + tcg_complete_matches = [], + tcg_cc_st = cc_st_var + } ; + } ; + + -- OK, here's the business end! + initTcWithGbl hsc_env gbl_env loc do_this + } + +-- | Run a 'TcM' action in the context of an existing 'GblEnv'. +initTcWithGbl :: HscEnv + -> TcGblEnv + -> RealSrcSpan + -> TcM r + -> IO (Messages, Maybe r) +initTcWithGbl hsc_env gbl_env loc do_this + = do { lie_var <- newIORef emptyWC + ; errs_var <- newIORef (emptyBag, emptyBag) + ; usage_var <- newIORef zeroUE + ; let lcl_env = TcLclEnv { + tcl_errs = errs_var, + tcl_loc = loc, + -- tcl_loc should be over-ridden very soon! + tcl_in_gen_code = False, + tcl_ctxt = [], + tcl_rdr = emptyLocalRdrEnv, + tcl_th_ctxt = topStage, + tcl_th_bndrs = emptyNameEnv, + tcl_arrow_ctxt = NoArrowCtxt, + tcl_env = emptyNameEnv, + tcl_usage = usage_var, + tcl_bndrs = [], + tcl_lie = lie_var, + tcl_tclvl = topTcLevel + } + + ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ + do { r <- tryM do_this + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } + + -- Check for unsolved constraints + -- If we succeed (maybe_res = Just r), there should be + -- no unsolved constraints. But if we exit via an + -- exception (maybe_res = Nothing), we may have skipped + -- solving, so don't panic then (#13466) + ; lie <- readIORef (tcl_lie lcl_env) + ; when (isJust maybe_res && not (isEmptyWC lie)) $ + pprPanic "initTc: unsolved constraints" (ppr lie) + + -- Collect any error messages + ; msgs <- readIORef (tcl_errs lcl_env) + + ; let { final_res | errorsFound dflags msgs = Nothing + | otherwise = maybe_res } + + ; return (msgs, final_res) + } + where dflags = hsc_dflags hsc_env + +initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) +-- Initialise the type checker monad for use in GHCi +initTcInteractive hsc_env thing_inside + = initTc hsc_env HsSrcFile False + (icInteractiveModule (hsc_IC hsc_env)) + (realSrcLocSpan interactive_src_loc) + thing_inside + where + interactive_src_loc = mkRealSrcLoc (fsLit "") 1 1 + +{- Note [Default types] +~~~~~~~~~~~~~~~~~~~~~~~ +The Integer type is simply not available in ghc-prim and ghc-bignum packages (it +is declared in ghc-bignum). So we set the defaulting types to (Just []), meaning +there are no default types, rather than Nothing, which means "use the default +default types of Integer, Double". + +If you don't do this, attempted defaulting in package ghc-prim causes +an actual crash (attempting to look up the Integer type). + + +************************************************************************ +* * + Initialisation +* * +************************************************************************ +-} + +initTcRnIf :: Char -- ^ Mask for unique supply + -> HscEnv + -> gbl -> lcl + -> TcRnIf gbl lcl a + -> IO a +initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside + = do { let { env = Env { env_top = hsc_env, + env_um = uniq_mask, + env_gbl = gbl_env, + env_lcl = lcl_env} } + + ; runIOEnv env thing_inside + } + +{- +************************************************************************ +* * + Simple accessors +* * +************************************************************************ +-} + +discardResult :: TcM a -> TcM () +discardResult a = a >> return () + +getTopEnv :: TcRnIf gbl lcl HscEnv +getTopEnv = do { env <- getEnv; return (env_top env) } + +updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = upd top }) + +getGblEnv :: TcRnIf gbl lcl gbl +getGblEnv = do { Env{..} <- getEnv; return env_gbl } + +updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> + env { env_gbl = upd gbl }) + +setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) + +getLclEnv :: TcRnIf gbl lcl lcl +getLclEnv = do { Env{..} <- getEnv; return env_lcl } + +updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> + env { env_lcl = upd lcl }) + +setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a +setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) + +getEnvs :: TcRnIf gbl lcl (gbl, lcl) +getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } + +setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a +setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) + +-- Command-line flags + +xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool +xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } + +doptM :: DumpFlag -> TcRnIf gbl lcl Bool +doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } + +goptM :: GeneralFlag -> TcRnIf gbl lcl Bool +goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } + +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } + +setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setXOptM flag = + updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) + +unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetXOptM flag = + updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) + +unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetGOptM flag = + updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) + +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = + updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) + +-- | Do it flag is true +whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenDOptM flag thing_inside = do b <- doptM flag + when b thing_inside +{-# INLINE whenDOptM #-} -- see Note [INLINE conditional tracing utilities] + + +whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenGOptM flag thing_inside = do b <- goptM flag + when b thing_inside +{-# INLINE whenGOptM #-} -- see Note [INLINE conditional tracing utilities] + +whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenWOptM flag thing_inside = do b <- woptM flag + when b thing_inside +{-# INLINE whenWOptM #-} -- see Note [INLINE conditional tracing utilities] + +whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenXOptM flag thing_inside = do b <- xoptM flag + when b thing_inside +{-# INLINE whenXOptM #-} -- see Note [INLINE conditional tracing utilities] + +unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +unlessXOptM flag thing_inside = do b <- xoptM flag + unless b thing_inside +{-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities] + +getGhcMode :: TcRnIf gbl lcl GhcMode +getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } + +withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a +withDoDynamicToo = + updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> + top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags }) + +getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) +getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } + +getEps :: TcRnIf gbl lcl ExternalPackageState +getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } + +-- | Update the external package state. Returns the second result of the +-- modifier function. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) + -> TcRnIf gbl lcl a +updateEps upd_fn = do + traceIf (text "updating EPS") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var upd_fn + +-- | Update the external package state. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps_ :: (ExternalPackageState -> ExternalPackageState) + -> TcRnIf gbl lcl () +updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ())) + +getHpt :: TcRnIf gbl lcl HomePackageTable +getHpt = do { env <- getTopEnv; return (hsc_HPT env) } + +getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) +getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) + ; return (eps, hsc_HPT env) } + +-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing +-- an exception if it is an error. +withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a +withException do_this = do + r <- do_this + dflags <- getDynFlags + case r of + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Succeeded result -> return result + +{- +************************************************************************ +* * + Arrow scopes +* * +************************************************************************ +-} + +newArrowScope :: TcM a -> TcM a +newArrowScope + = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } + +-- Return to the stored environment (from the enclosing proc) +escapeArrowScope :: TcM a -> TcM a +escapeArrowScope + = updLclEnv $ \ env -> + case tcl_arrow_ctxt env of + NoArrowCtxt -> env + ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt + , tcl_lie = lie + , tcl_rdr = rdr_env } + +{- +************************************************************************ +* * + Unique supply +* * +************************************************************************ +-} + +newUnique :: TcRnIf gbl lcl Unique +newUnique + = do { env <- getEnv + ; let mask = env_um env + ; liftIO $! uniqFromMask mask } + +newUniqueSupply :: TcRnIf gbl lcl UniqSupply +newUniqueSupply + = do { env <- getEnv + ; let mask = env_um env + ; liftIO $! mkSplitUniqSupply mask } + +cloneLocalName :: Name -> TcM Name +-- Make a fresh Internal name with the same OccName and SrcSpan +cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) + +newName :: OccName -> TcM Name +newName occ = do { loc <- getSrcSpanM + ; newNameAt occ loc } + +newNameAt :: OccName -> SrcSpan -> TcM Name +newNameAt occ span + = do { uniq <- newUnique + ; return (mkInternalName uniq occ span) } + +newSysName :: OccName -> TcRnIf gbl lcl Name +newSysName occ + = do { uniq <- newUnique + ; return (mkSystemName uniq occ) } + +newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId +newSysLocalId fs w ty + = do { u <- newUnique + ; return (mkSysLocal fs u w ty) } + +newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; let mkId' n (Scaled w t) = mkSysLocal fs n w t + ; return (zipWith mkId' (uniqsFromSupply us) tys) } + +instance MonadUnique (IOEnv (Env gbl lcl)) where + getUniqueM = newUnique + getUniqueSupplyM = newUniqueSupply + +{- +************************************************************************ +* * + Accessing input/output +* * +************************************************************************ +-} + +newTcRef :: a -> TcRnIf gbl lcl (TcRef a) +newTcRef = newMutVar + +readTcRef :: TcRef a -> TcRnIf gbl lcl a +readTcRef = readMutVar + +writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () +writeTcRef = writeMutVar + +updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () +-- Returns () +updTcRef ref fn = liftIO $ do { old <- readIORef ref + ; writeIORef ref (fn old) } + +{- +************************************************************************ +* * + Debugging +* * +************************************************************************ +-} + +-- Note [INLINE conditional tracing utilities] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In general we want to optimise for the case where tracing is not enabled. +-- To ensure this happens, we ensure that traceTc and friends are inlined; this +-- ensures that the allocation of the document can be pushed into the tracing +-- path, keeping the non-traced path free of this extraneous work. For +-- instance, instead of +-- +-- let thunk = ... +-- in if doTracing +-- then emitTraceMsg thunk +-- else return () +-- +-- where the conditional is buried in a non-inlined utility function (e.g. +-- traceTc), we would rather have: +-- +-- if doTracing +-- then let thunk = ... +-- in emitTraceMsg thunk +-- else return () +-- +-- See #18168. +-- + +-- Typechecker trace +traceTc :: String -> SDoc -> TcRn () +traceTc herald doc = + labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc +{-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities] + +-- Renamer Trace +traceRn :: String -> SDoc -> TcRn () +traceRn herald doc = + labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc +{-# INLINE traceRn #-} -- see Note [INLINE conditional tracing utilities] + +-- | Trace when a certain flag is enabled. This is like `traceOptTcRn` +-- but accepts a string as a label and formats the trace message uniformly. +labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () +labelledTraceOptTcRn flag herald doc = + traceOptTcRn flag (formatTraceMsg herald doc) +{-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] + +formatTraceMsg :: String -> SDoc -> SDoc +formatTraceMsg herald doc = hang (text herald) 2 doc + +traceOptTcRn :: DumpFlag -> SDoc -> TcRn () +traceOptTcRn flag doc = do + whenDOptM flag $ + dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc +{-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] + +-- | Dump if the given 'DumpFlag' is set. +dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () +dumpOptTcRn flag title fmt doc = do + whenDOptM flag $ + dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc +{-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities] + +-- | Unconditionally dump some trace output +-- +-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the +-- output generated by `-ddump-types` to be in 'PprUser' style. However, +-- generally we want all other debugging output to use 'PprDump' +-- style. We 'PprUser' style if 'useUserStyle' is True. +-- +dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () +dumpTcRn useUserStyle dumpOpt title fmt doc = do + dflags <- getDynFlags + printer <- getPrintUnqualified dflags + real_doc <- wrapDocLoc doc + let sty = if useUserStyle + then mkUserStyle printer AllTheWay + else mkDumpStyle printer + liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc + +-- | Add current location if -dppr-debug +-- (otherwise the full location is usually way too much) +wrapDocLoc :: SDoc -> TcRn SDoc +wrapDocLoc doc = do + dflags <- getDynFlags + if hasPprDebug dflags + then do + loc <- getSrcSpanM + return (mkLocMessage SevOutput loc doc) + else + return doc + +getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified +getPrintUnqualified dflags + = do { rdr_env <- getGlobalRdrEnv + ; return $ mkPrintUnqualified dflags rdr_env } + +-- | Like logInfoTcRn, but for user consumption +printForUserTcRn :: SDoc -> TcRn () +printForUserTcRn doc + = do { dflags <- getDynFlags + ; printer <- getPrintUnqualified dflags + ; liftIO (printOutputForUser dflags printer doc) } + +{- +traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is +available. Alas, they behave inconsistently with the other stuff; +e.g. are unaffected by -dump-to-file. +-} + +traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () +traceIf = traceOptIf Opt_D_dump_if_trace +traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs +{-# INLINE traceIf #-} +{-# INLINE traceHiDiffs #-} + -- see Note [INLINE conditional tracing utilities] + +traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () +traceOptIf flag doc + = whenDOptM flag $ -- No RdrEnv available, so qualify everything + do { dflags <- getDynFlags + ; liftIO (putMsg dflags doc) } +{-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities] + +{- +************************************************************************ +* * + Typechecker global environment +* * +************************************************************************ +-} + +getIsGHCi :: TcRn Bool +getIsGHCi = do { mod <- getModule + ; return (isInteractiveModule mod) } + +getGHCiMonad :: TcRn Name +getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } + +getInteractivePrintName :: TcRn Name +getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } + +tcIsHsBootOrSig :: TcRn Bool +tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } + +tcIsHsig :: TcRn Bool +tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } + +tcSelfBootInfo :: TcRn SelfBootInfo +tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } + +getGlobalRdrEnv :: TcRn GlobalRdrEnv +getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } + +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } + +getImports :: TcRn ImportAvails +getImports = do { env <- getGblEnv; return (tcg_imports env) } + +getFixityEnv :: TcRn FixityEnv +getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } + +extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a +extendFixityEnv new_bit + = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> + env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) + +getRecFieldEnv :: TcRn RecFieldEnv +getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } + +getDeclaredDefaultTys :: TcRn (Maybe [Type]) +getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } + +addDependentFiles :: [FilePath] -> TcRn () +addDependentFiles fs = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fs ++ dep_files) + +{- +************************************************************************ +* * + Error management +* * +************************************************************************ +-} + +getSrcSpanM :: TcRn SrcSpan + -- Avoid clash with Name.getSrcLoc +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } + +-- See Note [Rebindable syntax and HsExpansion]. +inGeneratedCode :: TcRn Bool +inGeneratedCode = tcl_in_gen_code <$> getLclEnv + +setSrcSpan :: SrcSpan -> TcRn a -> TcRn a +setSrcSpan (RealSrcSpan loc _) thing_inside = + updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) + thing_inside +setSrcSpan loc@(UnhelpfulSpan _) thing_inside + -- See Note [Rebindable syntax and HsExpansion]. + | isGeneratedSrcSpan loc = + updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside + | otherwise = thing_inside + +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = setSrcSpan loc $ fn a + +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) +wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a + ; return (L loc b) } + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (L loc b, c) + +wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (b, L loc c) + +wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () +wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) + +-- Reporting errors + +getErrsVar :: TcRn (TcRef Messages) +getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } + +setErrsVar :: TcRef Messages -> TcRn a -> TcRn a +setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) + +addErr :: MsgDoc -> TcRn () +addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } + +failWith :: MsgDoc -> TcRn a +failWith msg = addErr msg >> failM + +failAt :: SrcSpan -> MsgDoc -> TcRn a +failAt loc msg = addErrAt loc msg >> failM + +addErrAt :: SrcSpan -> MsgDoc -> TcRn () +-- addErrAt is mainly (exclusively?) used by the renamer, where +-- tidying is not an issue, but it's all lazy so the extra +-- work doesn't matter +addErrAt loc msg = do { ctxt <- getErrCtxt + ; tidy_env <- tcInitTidyEnv + ; err_info <- mkErrInfo tidy_env ctxt + ; addLongErrAt loc msg err_info } + +addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () +addErrs msgs = mapM_ add msgs + where + add (loc,msg) = addErrAt loc msg + +checkErr :: Bool -> MsgDoc -> TcRn () +-- Add the error if the bool is False +checkErr ok msg = unless ok (addErr msg) + +addMessages :: Messages -> TcRn () +addMessages msgs1 + = do { errs_var <- getErrsVar ; + msgs0 <- readTcRef errs_var ; + writeTcRef errs_var (unionMessages msgs0 msgs1) } + +discardWarnings :: TcRn a -> TcRn a +-- Ignore warnings inside the thing inside; +-- used to ignore-unused-variable warnings inside derived code +discardWarnings thing_inside + = do { errs_var <- getErrsVar + ; (old_warns, _) <- readTcRef errs_var + + ; result <- thing_inside + + -- Revert warnings to old_warns + ; (_new_warns, new_errs) <- readTcRef errs_var + ; writeTcRef errs_var (old_warns, new_errs) + + ; return result } + +{- +************************************************************************ +* * + Shared error message stuff: renamer and typechecker +* * +************************************************************************ +-} + +mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg +mkLongErrAt loc msg extra + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + return $ mkLongErrMsg dflags loc printer msg extra } + +mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg +mkErrDocAt loc errDoc + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + return $ mkErrDoc dflags loc printer errDoc } + +addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError + +reportErrors :: [ErrMsg] -> TcM () +reportErrors = mapM_ reportError + +reportError :: ErrMsg -> TcRn () +reportError err + = do { traceTc "Adding error:" (pprLocErrMsg err) ; + errs_var <- getErrsVar ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns, errs `snocBag` err) } + +reportWarning :: WarnReason -> ErrMsg -> TcRn () +reportWarning reason err + = do { let warn = makeIntoWarning reason err + -- 'err' was built by mkLongErrMsg or something like that, + -- so it's of error severity. For a warning we downgrade + -- its severity to SevWarning + + ; traceTc "Adding warning:" (pprLocErrMsg warn) + ; errs_var <- getErrsVar + ; (warns, errs) <- readTcRef errs_var + ; writeTcRef errs_var (warns `snocBag` warn, errs) } + + +----------------------- +checkNoErrs :: TcM r -> TcM r +-- (checkNoErrs m) succeeds iff m succeeds and generates no errors +-- If m fails then (checkNoErrsTc m) fails. +-- If m succeeds, it checks whether m generated any errors messages +-- (it might have recovered internally) +-- If so, it fails too. +-- Regardless, any errors generated by m are propagated to the enclosing context. +checkNoErrs main + = do { (res, no_errs) <- askNoErrs main + ; unless no_errs failM + ; return res } + +----------------------- +whenNoErrs :: TcM () -> TcM () +whenNoErrs thing = ifErrsM (return ()) thing + +ifErrsM :: TcRn r -> TcRn r -> TcRn r +-- ifErrsM bale_out normal +-- does 'bale_out' if there are errors in errors collection +-- otherwise does 'normal' +ifErrsM bale_out normal + = do { errs_var <- getErrsVar ; + msgs <- readTcRef errs_var ; + dflags <- getDynFlags ; + if errorsFound dflags msgs then + bale_out + else + normal } + +failIfErrsM :: TcRn () +-- Useful to avoid error cascades +failIfErrsM = ifErrsM failM (return ()) + +{- ********************************************************************* +* * + Context management for the type checker +* * +************************************************************************ +-} + +{- Note [Inlining addErrCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You will notice a bunch of INLINE pragamas on addErrCtxt and friends. +The reason is to promote better eta-expansion in client modules. +Consider + \e s. addErrCtxt c (tc_foo x) e s +It looks as if tc_foo is applied to only two arguments, but if we +inline addErrCtxt it'll turn into something more like + \e s. tc_foo x (munge c e) s +This is much better because Called Arity analysis can see that tc_foo +is applied to four arguments. See #18379 for a concrete example. + +This reliance on delicate inlining and Called Arity is not good. +See #18202 for a more general approach. But meanwhile, these +ininings seem unobjectional, and they solve the immediate +problem. -} + +getErrCtxt :: TcM [ErrCtxt] +getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } + +setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a +{-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] +setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) + +-- | Add a fixed message to the error context. This message should not +-- do any tidying. +addErrCtxt :: MsgDoc -> TcM a -> TcM a +{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] +addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) + +-- | Add a message to the error context. This message may do tidying. +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +{-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] +addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m + +-- | Add a fixed landmark message to the error context. A landmark +-- message is always sure to be reported, even if there is a lot of +-- context. It also doesn't count toward the maximum number of contexts +-- reported. +addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a +{-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] +addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) + +-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations +-- and tidying. +addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +{-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] +addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m + +push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) + -> Bool -> [ErrCtxt] -> [ErrCtxt] +push_ctxt ctxt in_gen ctxts + | in_gen = ctxts + | otherwise = ctxt : ctxts + +updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a +{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt] +-- Helper function for the above +-- The Bool is true if we are in generated code +updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt + , tcl_in_gen_code = in_gen }) -> + env { tcl_ctxt = upd in_gen ctxt }) + +popErrCtxt :: TcM a -> TcM a +popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) + +getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc +getCtLocM origin t_or_k + = do { env <- getLclEnv + ; return (CtLoc { ctl_origin = origin + , ctl_env = env + , ctl_t_or_k = t_or_k + , ctl_depth = initialSubGoalDepth }) } + +setCtLocM :: CtLoc -> TcM a -> TcM a +-- Set the SrcSpan and error context from the CtLoc +setCtLocM (CtLoc { ctl_env = lcl }) thing_inside + = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl + , tcl_bndrs = tcl_bndrs lcl + , tcl_ctxt = tcl_ctxt lcl }) + thing_inside + + +{- ********************************************************************* +* * + Error recovery and exceptions +* * +********************************************************************* -} + +tcTryM :: TcRn r -> TcRn (Maybe r) +-- The most basic function: catch the exception +-- Nothing => an exception happened +-- Just r => no exception, result R +-- Errors and constraints are propagated in both cases +-- Never throws an exception +tcTryM thing_inside + = do { either_res <- tryM thing_inside + ; return (case either_res of + Left _ -> Nothing + Right r -> Just r) } + -- In the Left case the exception is always the IOEnv + -- built-in in exception; see IOEnv.failM + +----------------------- +capture_constraints :: TcM r -> TcM (r, WantedConstraints) +-- capture_constraints simply captures and returns the +-- constraints generated by thing_inside +-- Precondition: thing_inside must not throw an exception! +-- Reason for precondition: an exception would blow past the place +-- where we read the lie_var, and we'd lose the constraints altogether +capture_constraints thing_inside + = do { lie_var <- newTcRef emptyWC + ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $ + thing_inside + ; lie <- readTcRef lie_var + ; return (res, lie) } + +capture_messages :: TcM r -> TcM (r, Messages) +-- capture_messages simply captures and returns the +-- errors arnd warnings generated by thing_inside +-- Precondition: thing_inside must not throw an exception! +-- Reason for precondition: an exception would blow past the place +-- where we read the msg_var, and we'd lose the constraints altogether +capture_messages thing_inside + = do { msg_var <- newTcRef emptyMessages + ; res <- setErrsVar msg_var thing_inside + ; msgs <- readTcRef msg_var + ; return (res, msgs) } + +----------------------- +-- (askNoErrs m) runs m +-- If m fails, +-- then (askNoErrs m) fails, propagating only +-- insoluble constraints +-- +-- If m succeeds with result r, +-- then (askNoErrs m) succeeds with result (r, b), +-- where b is True iff m generated no errors +-- +-- Regardless of success or failure, +-- propagate any errors/warnings generated by m +askNoErrs :: TcRn a -> TcRn (a, Bool) +askNoErrs thing_inside + = do { ((mb_res, lie), msgs) <- capture_messages $ + capture_constraints $ + tcTryM thing_inside + ; addMessages msgs + + ; case mb_res of + Nothing -> do { emitConstraints (dropMisleading lie) + ; failM } + + Just res -> do { emitConstraints lie + ; dflags <- getDynFlags + ; let errs_found = errorsFound dflags msgs + || insolubleWC lie + ; return (res, not errs_found) } } + +----------------------- +tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints) +-- (tryCaptureConstraints_maybe m) runs m, +-- and returns the type constraints it generates +-- It never throws an exception; instead if thing_inside fails, +-- it returns Nothing and the /insoluble/ constraints +-- Error messages are propagated +tryCaptureConstraints thing_inside + = do { (mb_res, lie) <- capture_constraints $ + tcTryM thing_inside + + -- See Note [Constraints and errors] + ; let lie_to_keep = case mb_res of + Nothing -> dropMisleading lie + Just {} -> lie + + ; return (mb_res, lie_to_keep) } + +captureConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureConstraints m) runs m, and returns the type constraints it generates +-- If thing_inside fails (throwing an exception), +-- then (captureConstraints thing_inside) fails too +-- propagating the insoluble constraints only +-- Error messages are propagated in either case +captureConstraints thing_inside + = do { (mb_res, lie) <- tryCaptureConstraints thing_inside + + -- See Note [Constraints and errors] + -- If the thing_inside threw an exception, emit the insoluble + -- constraints only (returned by tryCaptureConstraints) + -- so that they are not lost + ; case mb_res of + Nothing -> do { emitConstraints lie; failM } + Just res -> return (res, lie) } + +----------------------- +-- | @tcCollectingUsage thing_inside@ runs @thing_inside@ and returns the usage +-- information which was collected as part of the execution of +-- @thing_inside@. Careful: @tcCollectingUsage thing_inside@ itself does not +-- report any usage information, it's up to the caller to incorporate the +-- returned usage information into the larger context appropriately. +tcCollectingUsage :: TcM a -> TcM (UsageEnv,a) +tcCollectingUsage thing_inside + = do { env0 <- getLclEnv + ; local_usage_ref <- newTcRef zeroUE + ; let env1 = env0 { tcl_usage = local_usage_ref } + ; result <- setLclEnv env1 thing_inside + ; local_usage <- readTcRef local_usage_ref + ; return (local_usage,result) } + +-- | @tcScalingUsage mult thing_inside@ runs @thing_inside@ and scales all the +-- usage information by @mult@. +tcScalingUsage :: Mult -> TcM a -> TcM a +tcScalingUsage mult thing_inside + = do { (usage, result) <- tcCollectingUsage thing_inside + ; traceTc "tcScalingUsage" (ppr mult) + ; tcEmitBindingUsage $ scaleUE mult usage + ; return result } + +tcEmitBindingUsage :: UsageEnv -> TcM () +tcEmitBindingUsage ue + = do { lcl_env <- getLclEnv + ; let usage = tcl_usage lcl_env + ; updTcRef usage (addUE ue) } + +----------------------- +attemptM :: TcRn r -> TcRn (Maybe r) +-- (attemptM thing_inside) runs thing_inside +-- If thing_inside succeeds, returning r, +-- we return (Just r), and propagate all constraints and errors +-- If thing_inside fail, throwing an exception, +-- we return Nothing, propagating insoluble constraints, +-- and all errors +-- attemptM never throws an exception +attemptM thing_inside + = do { (mb_r, lie) <- tryCaptureConstraints thing_inside + ; emitConstraints lie + + -- Debug trace + ; when (isNothing mb_r) $ + traceTc "attemptM recovering with insoluble constraints" $ + (ppr lie) + + ; return mb_r } + +----------------------- +recoverM :: TcRn r -- Recovery action; do this if the main one fails + -> TcRn r -- Main action: do this first; + -- if it generates errors, propagate them all + -> TcRn r +-- (recoverM recover thing_inside) runs thing_inside +-- If thing_inside fails, propagate its errors and insoluble constraints +-- and run 'recover' +-- If thing_inside succeeds, propagate all its errors and constraints +-- +-- Can fail, if 'recover' fails +recoverM recover thing + = do { mb_res <- attemptM thing ; + case mb_res of + Nothing -> recover + Just res -> return res } + +----------------------- + +-- | Drop elements of the input that fail, so the result +-- list can be shorter than the argument list +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndRecoverM f xs + = do { mb_rs <- mapM (attemptM . f) xs + ; return [r | Just r <- mb_rs] } + +-- | Apply the function to all elements on the input list +-- If all succeed, return the list of results +-- Otherwise fail, propagating all errors +mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndReportM f xs + = do { mb_rs <- mapM (attemptM . f) xs + ; when (any isNothing mb_rs) failM + ; return [r | Just r <- mb_rs] } + +-- | The accumulator is not updated if the action fails +foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b +foldAndRecoverM _ acc [] = return acc +foldAndRecoverM f acc (x:xs) = + do { mb_r <- attemptM (f acc x) + ; case mb_r of + Nothing -> foldAndRecoverM f acc xs + Just acc' -> foldAndRecoverM f acc' xs } + +----------------------- +tryTc :: TcRn a -> TcRn (Maybe a, Messages) +-- (tryTc m) executes m, and returns +-- Just r, if m succeeds (returning r) +-- Nothing, if m fails +-- It also returns all the errors and warnings accumulated by m +-- It always succeeds (never raises an exception) +tryTc thing_inside + = capture_messages (attemptM thing_inside) + +----------------------- +discardErrs :: TcRn a -> TcRn a +-- (discardErrs m) runs m, +-- discarding all error messages and warnings generated by m +-- If m fails, discardErrs fails, and vice versa +discardErrs m + = do { errs_var <- newTcRef emptyMessages + ; setErrsVar errs_var m } + +----------------------- +tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r +-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside'; +-- if 'main' succeeds with no error messages, it's the answer +-- otherwise discard everything from 'main', including errors, +-- and try 'recover' instead. +tryTcDiscardingErrs recover thing_inside + = do { ((mb_res, lie), msgs) <- capture_messages $ + capture_constraints $ + tcTryM thing_inside + ; dflags <- getDynFlags + ; case mb_res of + Just res | not (errorsFound dflags msgs) + , not (insolubleWC lie) + -> -- 'main' succeeded with no errors + do { addMessages msgs -- msgs might still have warnings + ; emitConstraints lie + ; return res } + + _ -> -- 'main' failed, or produced an error message + recover -- Discard all errors and warnings + -- and unsolved constraints entirely + } + +{- +************************************************************************ +* * + Error message generation (type checker) +* * +************************************************************************ + + The addErrTc functions add an error message, but do not cause failure. + The 'M' variants pass a TidyEnv that has already been used to + tidy up the message; we then use it to tidy the context messages +-} + +addErrTc :: MsgDoc -> TcM () +addErrTc err_msg = do { env0 <- tcInitTidyEnv + ; addErrTcM (env0, err_msg) } + +addErrTcM :: (TidyEnv, MsgDoc) -> TcM () +addErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + add_err_tcm tidy_env err_msg loc ctxt } + +-- The failWith functions add an error message and cause failure + +failWithTc :: MsgDoc -> TcM a -- Add an error message and fail +failWithTc err_msg + = addErrTc err_msg >> failM + +failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail +failWithTcM local_and_msg + = addErrTcM local_and_msg >> failM + +checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true +checkTc True _ = return () +checkTc False err = failWithTc err + +checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +checkTcM True _ = return () +checkTcM False err = failWithTcM err + +failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false +failIfTc False _ = return () +failIfTc True err = failWithTc err + +failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () + -- Check that the boolean is false +failIfTcM False _ = return () +failIfTcM True err = failWithTcM err + + +-- Warnings have no 'M' variant, nor failure + +-- | Display a warning if a condition is met, +-- and the warning is enabled +warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () +warnIfFlag warn_flag is_bad msg + = do { warn_on <- woptM warn_flag + ; when (warn_on && is_bad) $ + addWarn (Reason warn_flag) msg } + +-- | Display a warning if a condition is met. +warnIf :: Bool -> MsgDoc -> TcRn () +warnIf is_bad msg + = when is_bad (addWarn NoReason msg) + +-- | Display a warning if a condition is met. +warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () +warnTc reason warn_if_true warn_msg + | warn_if_true = addWarnTc reason warn_msg + | otherwise = return () + +-- | Display a warning if a condition is met. +warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () +warnTcM reason warn_if_true warn_msg + | warn_if_true = addWarnTcM reason warn_msg + | otherwise = return () + +-- | Display a warning in the current context. +addWarnTc :: WarnReason -> MsgDoc -> TcM () +addWarnTc reason msg + = do { env0 <- tcInitTidyEnv ; + addWarnTcM reason (env0, msg) } + +-- | Display a warning in a given context. +addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () +addWarnTcM reason (env0, msg) + = do { ctxt <- getErrCtxt ; + err_info <- mkErrInfo env0 ctxt ; + add_warn reason msg err_info } + +-- | Display a warning for the current source location. +addWarn :: WarnReason -> MsgDoc -> TcRn () +addWarn reason msg = add_warn reason msg Outputable.empty + +-- | Display a warning for a given source location. +addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () +addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty + +-- | Display a warning, with an optional flag, for the current source +-- location. +add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () +add_warn reason msg extra_info + = do { loc <- getSrcSpanM + ; add_warn_at reason loc msg extra_info } + +-- | Display a warning, with an optional flag, for a given location. +add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at reason loc msg extra_info + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + let { warn = mkLongWarnMsg dflags loc printer + msg extra_info } ; + reportWarning reason warn } + + +{- +----------------------------------- + Other helper functions +-} + +add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan + -> [ErrCtxt] + -> TcM () +add_err_tcm tidy_env err_msg loc ctxt + = do { err_info <- mkErrInfo tidy_env ctxt ; + addLongErrAt loc err_msg err_info } + +mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc +-- Tidy the error info, trimming excessive contexts +mkErrInfo env ctxts +-- = do +-- dbg <- hasPprDebug <$> getDynFlags +-- if dbg -- In -dppr-debug style the output +-- then return empty -- just becomes too voluminous +-- else go dbg 0 env ctxts + = go False 0 env ctxts + where + go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc + go _ _ _ [] = return empty + go dbg n env ((is_landmark, ctxt) : ctxts) + | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg) <- ctxt env + ; let n' = if is_landmark then n else n+1 + ; rest <- go dbg n' env' ctxts + ; return (msg $$ rest) } + | otherwise + = go dbg n env ctxts + +mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts +mAX_CONTEXTS = 3 + +-- debugTc is useful for monadic debugging code + +debugTc :: TcM () -> TcM () +debugTc thing + | debugIsOn = thing + | otherwise = return () + +{- +************************************************************************ +* * + Type constraints +* * +************************************************************************ +-} + +addTopEvBinds :: Bag EvBind -> TcM a -> TcM a +addTopEvBinds new_ev_binds thing_inside + =updGblEnv upd_env thing_inside + where + upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env + `unionBags` new_ev_binds } + +newTcEvBinds :: TcM EvBindsVar +newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap + ; tcvs_ref <- newTcRef emptyVarSet + ; uniq <- newUnique + ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) + ; return (EvBindsVar { ebv_binds = binds_ref + , ebv_tcvs = tcvs_ref + , ebv_uniq = uniq }) } + +-- | Creates an EvBindsVar incapable of holding any bindings. It still +-- tracks covar usages (see comments on ebv_tcvs in "GHC.Tc.Types.Evidence"), thus +-- must be made monadically +newNoTcEvBinds :: TcM EvBindsVar +newNoTcEvBinds + = do { tcvs_ref <- newTcRef emptyVarSet + ; uniq <- newUnique + ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) + ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref + , ebv_uniq = uniq }) } + +cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar +-- Clone the refs, so that any binding created when +-- solving don't pollute the original +cloneEvBindsVar ebv@(EvBindsVar {}) + = do { binds_ref <- newTcRef emptyEvBindMap + ; tcvs_ref <- newTcRef emptyVarSet + ; return (ebv { ebv_binds = binds_ref + , ebv_tcvs = tcvs_ref }) } +cloneEvBindsVar ebv@(CoEvBindsVar {}) + = do { tcvs_ref <- newTcRef emptyVarSet + ; return (ebv { ebv_tcvs = tcvs_ref }) } + +getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet +getTcEvTyCoVars ev_binds_var + = readTcRef (ebv_tcvs ev_binds_var) + +getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap +getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) + = readTcRef ev_ref +getTcEvBindsMap (CoEvBindsVar {}) + = return emptyEvBindMap + +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () +setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds + = writeTcRef ev_ref binds +setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds + | isEmptyEvBindMap ev_binds + = return () + | otherwise + = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) + +addTcEvBind :: EvBindsVar -> EvBind -> TcM () +-- Add a binding to the TcEvBinds by side effect +addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind + = do { traceTc "addTcEvBind" $ ppr u $$ + ppr ev_bind + ; bnds <- readTcRef ev_ref + ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } +addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind + = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) + +chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName +chooseUniqueOccTc fn = + do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; set <- readTcRef dfun_n_var + ; let occ = fn set + ; writeTcRef dfun_n_var (extendOccSet set occ) + ; return occ } + +getConstraintVar :: TcM (TcRef WantedConstraints) +getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } + +setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a +setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) + +emitStaticConstraints :: WantedConstraints -> TcM () +emitStaticConstraints static_lie + = do { gbl_env <- getGblEnv + ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } + +emitConstraints :: WantedConstraints -> TcM () +emitConstraints ct + | isEmptyWC ct + = return () + | otherwise + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`andWC` ct) } + +emitSimple :: Ct -> TcM () +emitSimple ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` unitBag ct) } + +emitSimples :: Cts -> TcM () +emitSimples cts + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` cts) } + +emitImplication :: Implication -> TcM () +emitImplication ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` unitBag ct) } + +emitImplications :: Bag Implication -> TcM () +emitImplications ct + = unless (isEmptyBag ct) $ + do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` ct) } + +emitInsoluble :: Ct -> TcM () +emitInsoluble ct + = do { traceTc "emitInsoluble" (ppr ct) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addInsols` unitBag ct) } + +emitHole :: Hole -> TcM () +emitHole hole + = do { traceTc "emitHole" (ppr hole) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addHoles` unitBag hole) } + +emitHoles :: Bag Hole -> TcM () +emitHoles holes + = do { traceTc "emitHoles" (ppr holes) + ; lie_var <- getConstraintVar + ; updTcRef lie_var (`addHoles` holes) } + +-- | Throw out any constraints emitted by the thing_inside +discardConstraints :: TcM a -> TcM a +discardConstraints thing_inside = fst <$> captureConstraints thing_inside + +-- | The name says it all. The returned TcLevel is the *inner* TcLevel. +pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) +pushLevelAndCaptureConstraints thing_inside + = do { env <- getLclEnv + ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') + ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $ + captureConstraints thing_inside + ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') + ; return (tclvl', lie, res) } + +pushTcLevelM_ :: TcM a -> TcM a +pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x + +pushTcLevelM :: TcM a -> TcM (TcLevel, a) +-- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType +pushTcLevelM thing_inside + = do { env <- getLclEnv + ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) + thing_inside + ; return (tclvl', res) } + +-- Returns pushed TcLevel +pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) +pushTcLevelsM num_levels thing_inside + = do { env <- getLclEnv + ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env) + ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $ + thing_inside + ; return (res, tclvl') } + +getTcLevel :: TcM TcLevel +getTcLevel = do { env <- getLclEnv + ; return (tcl_tclvl env) } + +setTcLevel :: TcLevel -> TcM a -> TcM a +setTcLevel tclvl thing_inside + = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside + +isTouchableTcM :: TcTyVar -> TcM Bool +isTouchableTcM tv + = do { lvl <- getTcLevel + ; return (isTouchableMetaTyVar lvl tv) } + +getLclTypeEnv :: TcM TcTypeEnv +getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } + +setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a +-- Set the local type envt, but do *not* disturb other fields, +-- notably the lie_var +setLclTypeEnv lcl_env thing_inside + = updLclEnv upd thing_inside + where + upd env = env { tcl_env = tcl_env lcl_env } + +traceTcConstraints :: String -> TcM () +traceTcConstraints msg + = do { lie_var <- getConstraintVar + ; lie <- readTcRef lie_var + ; traceOptTcRn Opt_D_dump_tc_trace $ + hang (text (msg ++ ": LIE:")) 2 (ppr lie) + } + +emitAnonTypeHole :: TcTyVar -> TcM () +emitAnonTypeHole tv + = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing + ; let hole = Hole { hole_sort = TypeHole + , hole_occ = occ + , hole_ty = mkTyVarTy tv + , hole_loc = ct_loc } + ; emitHole hole } + where + occ = mkTyVarOcc "_" + +emitNamedTypeHole :: (Name, TcTyVar) -> TcM () +emitNamedTypeHole (name, tv) + = do { ct_loc <- setSrcSpan (nameSrcSpan name) $ + getCtLocM (TypeHoleOrigin occ) Nothing + ; let hole = Hole { hole_sort = TypeHole + , hole_occ = occ + , hole_ty = mkTyVarTy tv + , hole_loc = ct_loc } + ; emitHole hole } + where + occ = nameOccName name + +{- Note [Constraints and errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#12124): + + foo :: Maybe Int + foo = return (case Left 3 of + Left -> 1 -- Hard error here! + _ -> 0) + +The call to 'return' will generate a (Monad m) wanted constraint; but +then there'll be "hard error" (i.e. an exception in the TcM monad), from +the unsaturated Left constructor pattern. + +We'll recover in tcPolyBinds, using recoverM. But then the final +tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly +un-filled-in, and will emit a misleading error message. + +The underlying problem is that an exception interrupts the constraint +gathering process. Bottom line: if we have an exception, it's best +simply to discard any gathered constraints. Hence in 'attemptM' we +capture the constraints in a fresh variable, and only emit them into +the surrounding context if we exit normally. If an exception is +raised, simply discard the collected constraints... we have a hard +error to report. So this capture-the-emit dance isn't as stupid as it +looks :-). + +However suppose we throw an exception inside an invocation of +captureConstraints, and discard all the constraints. Some of those +constraints might be "variable out of scope" Hole constraints, and that +might have been the actual original cause of the exception! For +example (#12529): + f = p @ Int +Here 'p' is out of scope, so we get an insoluble Hole constraint. But +the visible type application fails in the monad (throws an exception). +We must not discard the out-of-scope error. + +So we /retain the insoluble constraints/ if there is an exception. +Hence: + - insolublesOnly in tryCaptureConstraints + - emitConstraints in the Left case of captureConstraints + +However note that freshly-generated constraints like (Int ~ Bool), or +((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as +insoluble. The constraint solver does that. So they'll be discarded. +That's probably ok; but see th/5358 as a not-so-good example: + t1 :: Int + t1 x = x -- Manifestly wrong + + foo = $(...raises exception...) +We report the exception, but not the bug in t1. Oh well. Possible +solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints. + + +************************************************************************ +* * + Template Haskell context +* * +************************************************************************ +-} + +recordThUse :: TcM () +recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } + +recordThSpliceUse :: TcM () +recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } + +keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set +keepAlive name + = do { env <- getGblEnv + ; traceRn "keep alive" (ppr name) + ; updTcRef (tcg_keep env) (`extendNameSet` name) } + +getStage :: TcM ThStage +getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } + +getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) +getStageAndBindLevel name + = do { env <- getLclEnv; + ; case lookupNameEnv (tcl_th_bndrs env) name of + Nothing -> return Nothing + Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } + +setStage :: ThStage -> TcM a -> TcRn a +setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) + +-- | Adds the given modFinalizers to the global environment and set them to use +-- the current local environment. +addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () +addModFinalizersWithLclEnv mod_finalizers + = do lcl_env <- getLclEnv + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + updTcRef th_modfinalizers_var $ \fins -> + (lcl_env, mod_finalizers) : fins + +{- +************************************************************************ +* * + Safe Haskell context +* * +************************************************************************ +-} + +-- | Mark that safe inference has failed +-- See Note [Safe Haskell Overlapping Instances Implementation] +-- although this is used for more than just that failure case. +recordUnsafeInfer :: WarningMessages -> TcM () +recordUnsafeInfer warns = + getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) + +-- | Figure out the final correct safe haskell mode +finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode +finalSafeMode dflags tcg_env = do + safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) + return $ case safeHaskell dflags of + Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred + | otherwise -> Sf_None + s -> s + +-- | Switch instances to safe instances if we're in Safe mode. +fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] +fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id +fixSafeInstances _ = map fixSafe + where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } + in inst { is_flag = new_flag } + +{- +************************************************************************ +* * + Stuff for the renamer's local env +* * +************************************************************************ +-} + +getLocalRdrEnv :: RnM LocalRdrEnv +getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } + +setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a +setLocalRdrEnv rdr_env thing_inside + = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside + +{- +************************************************************************ +* * + Stuff for interface decls +* * +************************************************************************ +-} + +mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv +mkIfLclEnv mod loc boot + = IfLclEnv { if_mod = mod, + if_loc = loc, + if_boot = boot, + if_nsubst = Nothing, + if_implicits_env = Nothing, + if_tv_env = emptyFsEnv, + if_id_env = emptyFsEnv } + +-- | Run an 'IfG' (top-level interface monad) computation inside an existing +-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' +-- based on 'TcGblEnv'. +initIfaceTcRn :: IfG a -> TcRn a +initIfaceTcRn thing_inside + = do { tcg_env <- getGblEnv + ; dflags <- getDynFlags + ; let !mod = tcg_semantic_mod tcg_env + -- When we are instantiating a signature, we DEFINITELY + -- do not want to knot tie. + is_instantiate = homeUnitIsDefinite dflags && + not (null (homeUnitInstantiations dflags)) + ; let { if_env = IfGblEnv { + if_doc = text "initIfaceTcRn", + if_rec_types = + if is_instantiate + then Nothing + else Just (mod, get_type_env) + } + ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } + ; setEnvs (if_env, ()) thing_inside } + +-- Used when sucking in a ModIface into a ModDetails to put in +-- the HPT. Notably, unlike initIfaceCheck, this does NOT use +-- hsc_type_env_var (since we're not actually going to typecheck, +-- so this variable will never get updated!) +initIfaceLoad :: HscEnv -> IfG a -> IO a +initIfaceLoad hsc_env do_this + = do let gbl_env = IfGblEnv { + if_doc = text "initIfaceLoad", + if_rec_types = Nothing + } + initTcRnIf 'i' hsc_env gbl_env () do_this + +initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a +-- Used when checking the up-to-date-ness of the old Iface +-- Initialise the environment with no useful info at all +initIfaceCheck doc hsc_env do_this + = do let rec_types = case hsc_type_env_var hsc_env of + Just (mod,var) -> Just (mod, readTcRef var) + Nothing -> Nothing + gbl_env = IfGblEnv { + if_doc = text "initIfaceCheck" <+> doc, + if_rec_types = rec_types + } + initTcRnIf 'i' hsc_env gbl_env () do_this + +initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a +initIfaceLcl mod loc_doc hi_boot_file thing_inside + = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside + +-- | Initialize interface typechecking, but with a 'NameShape' +-- to apply when typechecking top-level 'OccName's (see +-- 'lookupIfaceTop') +initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a +initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside + = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside + +getIfModule :: IfL Module +getIfModule = do { env <- getLclEnv; return (if_mod env) } + +-------------------- +failIfM :: MsgDoc -> IfL a +-- The Iface monad doesn't have a place to accumulate errors, so we +-- just fall over fast if one happens; it "shouldn't happen". +-- We use IfL here so that we can get context info out of the local env +failIfM msg + = do { env <- getLclEnv + ; let full_msg = (if_loc env <> colon) $$ nest 2 msg + ; dflags <- getDynFlags + ; liftIO (putLogMsg dflags NoReason SevFatal + noSrcSpan $ withPprStyle defaultErrStyle full_msg) + ; failM } + +-------------------- +forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) +-- Run thing_inside in an interleaved thread. +-- It shares everything with the parent thread, so this is DANGEROUS. +-- +-- It returns Nothing if the computation fails +-- +-- It's used for lazily type-checking interface +-- signatures, which is pretty benign + +forkM_maybe doc thing_inside + = do { -- see Note [Masking exceptions in forkM_maybe] + ; unsafeInterleaveM $ uninterruptibleMaskM_ $ + do { traceIf (text "Starting fork {" <+> doc) + ; mb_res <- tryM $ + updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ + thing_inside + ; case mb_res of + Right r -> do { traceIf (text "} ending fork" <+> doc) + ; return (Just r) } + Left exn -> do { + + -- Bleat about errors in the forked thread, if -ddump-if-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures (see tcInterfaceSigs) + whenDOptM Opt_D_dump_if_trace $ do + dflags <- getDynFlags + let msg = hang (text "forkM failed:" <+> doc) + 2 (text (show exn)) + liftIO $ putLogMsg dflags + NoReason + SevFatal + noSrcSpan + $ withPprStyle defaultErrStyle msg + + ; traceIf (text "} ending fork (badly)" <+> doc) + ; return Nothing } + }} + +forkM :: SDoc -> IfL a -> IfL a +forkM doc thing_inside + = do { mb_res <- forkM_maybe doc thing_inside + ; return (case mb_res of + Nothing -> pgmError "Cannot continue after interface file error" + -- pprPanic "forkM" doc + Just r -> r) } + +setImplicitEnvM :: TypeEnv -> IfL a -> IfL a +setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl + { if_implicits_env = Just tenv }) m + +{- +Note [Masking exceptions in forkM_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When using GHC-as-API it must be possible to interrupt snippets of code +executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible +by throwing an asynchronous interrupt to the GHC thread. However, there is a +subtle problem: runStmt first typechecks the code before running it, and the +exception might interrupt the type checker rather than the code. Moreover, the +typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and +more importantly might be inside an exception handler inside that +unsafeInterleaveIO. If that is the case, the exception handler will rethrow the +asynchronous exception as a synchronous exception, and the exception will end +up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed +discussion). We don't currently know a general solution to this problem, but +we can use uninterruptibleMask_ to avoid the situation. +-} + +-- | Environments which track 'CostCentreState' +class ContainsCostCentreState e where + extractCostCentreState :: e -> TcRef CostCentreState + +instance ContainsCostCentreState TcGblEnv where + extractCostCentreState = tcg_cc_st + +instance ContainsCostCentreState DsGblEnv where + extractCostCentreState = ds_cc_st + +-- | Get the next cost centre index associated with a given name. +getCCIndexM :: (ContainsCostCentreState gbl) + => FastString -> TcRnIf gbl lcl CostCentreIndex +getCCIndexM nm = do + env <- getGblEnv + let cc_st_ref = extractCostCentreState env + cc_st <- readTcRef cc_st_ref + let (idx, cc_st') = getCCIndex nm cc_st + writeTcRef cc_st_ref cc_st' + return idx diff --git a/GHC/Tc/Utils/TcMType.hs b/GHC/Tc/Utils/TcMType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcMType.hs @@ -0,0 +1,2537 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, MultiWayIf, PatternSynonyms #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Monadic type operations +-- +-- This module contains monadic operations over types that contain mutable type +-- variables. +module GHC.Tc.Utils.TcMType ( + TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, + + -------------------------------- + -- Creating new mutable type variables + newFlexiTyVar, + newNamedFlexiTyVar, + newFlexiTyVarTy, -- Kind -> TcM TcType + newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] + newOpenFlexiTyVarTy, newOpenTypeKind, + newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, + cloneMetaTyVar, + newFmvTyVar, newFskTyVar, + + newMultiplicityVar, + readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, + newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, + + -------------------------------- + -- Creating new evidence variables + newEvVar, newEvVars, newDict, + newWanted, newWanteds, cloneWanted, cloneWC, + emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, + emitDerivedEqs, + newTcEvBinds, newNoTcEvBinds, addTcEvBind, + emitNewExprHole, + + newCoercionHole, fillCoercionHole, isFilledCoercionHole, + unpackCoercionHole, unpackCoercionHole_maybe, + checkCoercionHole, + + newImplication, + + -------------------------------- + -- Instantiation + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, + newMetaTyVarTyVarX, + newTyVarTyVar, cloneTyVarTyVar, + newPatSigTyVar, newSkolemTyVar, newWildCardX, + + -------------------------------- + -- Expected types + ExpType(..), ExpSigmaType, ExpRhoType, + mkCheckExpType, newInferExpType, tcInfer, + readExpType, readExpType_maybe, readScaledExpType, + expTypeToType, scaledExpTypeToType, + checkingExpType_maybe, checkingExpType, + inferResultToType, fillInferResult, promoteTcType, + promoteTyVar, promoteTyVarSet, + + -------------------------------- + -- Zonking and tidying + zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, + tidyEvVar, tidyCt, tidyHole, tidySkolemInfo, + zonkTcTyVar, zonkTcTyVars, + zonkTcTyVarToTyVar, zonkInvisTVBinder, + zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, + zonkTyCoVarsAndFVList, + candidateQTyVarsOfType, candidateQTyVarsOfKind, + candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, + zonkAndSkolemise, skolemiseQuantifiedTyVar, + defaultTyVar, quantifyTyVars, isQuantifiableTv, + zonkTcType, zonkTcTypes, zonkCo, + zonkTyCoVarKind, zonkTyCoVarKindBinder, + + zonkEvVar, zonkWC, zonkImplication, zonkSimples, + zonkId, zonkCoVar, + zonkCt, zonkSkolemInfo, + + skolemiseUnboundMetaTyVar, + + ------------------------------ + -- Levity polymorphism + ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr + ) where + +#include "HsVersions.h" + +-- friends: +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Types.Var +import GHC.Core.Predicate +import GHC.Tc.Types.Origin + +-- others: +import GHC.Tc.Utils.Monad -- TcType, amongst others +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Types.Id as Id +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Types.Var.Env +import GHC.Types.Name.Env +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.Pair +import GHC.Types.Unique.Set +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.Basic ( TypeOrKind(..) ) + +import Control.Monad +import GHC.Data.Maybe +import Control.Arrow ( second ) +import qualified Data.Semigroup as Semi + +{- +************************************************************************ +* * + Kind variables +* * +************************************************************************ +-} + +newMetaKindVar :: TcM TcKind +newMetaKindVar + = do { details <- newMetaDetails TauTv + ; name <- newMetaTyVarName (fsLit "k") + -- All MetaKindVars are called "k" + -- They may be jiggled by tidying + ; let kv = mkTcTyVar name liftedTypeKind details + ; traceTc "newMetaKindVar" (ppr kv) + ; return (mkTyVarTy kv) } + +newMetaKindVars :: Int -> TcM [TcKind] +newMetaKindVars n = replicateM n newMetaKindVar + +{- +************************************************************************ +* * + Evidence variables; range over constraints we can abstract over +* * +************************************************************************ +-} + +newEvVars :: TcThetaType -> TcM [EvVar] +newEvVars theta = mapM newEvVar theta + +-------------- + +newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar +-- Creates new *rigid* variables for predicates +newEvVar ty = do { name <- newSysName (predTypeOccName ty) + ; return (mkLocalIdOrCoVar name Many ty) } + +newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence +-- Deals with both equality and non-equality predicates +newWanted orig t_or_k pty + = do loc <- getCtLocM orig t_or_k + d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole YesBlockSubst pty + else EvVarDest <$> newEvVar pty + return $ CtWanted { ctev_dest = d + , ctev_pred = pty + , ctev_nosh = WDeriv + , ctev_loc = loc } + +newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] +newWanteds orig = mapM (newWanted orig Nothing) + +---------------------------------------------- +-- Cloning constraints +---------------------------------------------- + +cloneWanted :: Ct -> TcM Ct +cloneWanted ct + | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct + = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty + ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } + | otherwise + = return ct + +cloneWC :: WantedConstraints -> TcM WantedConstraints +-- Clone all the evidence bindings in +-- a) the ic_bind field of any implications +-- b) the CoercionHoles of any wanted constraints +-- so that solving the WantedConstraints will not have any visible side +-- effect, /except/ from causing unifications +cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { simples' <- mapBagM cloneWanted simples + ; implics' <- mapBagM cloneImplication implics + ; return (wc { wc_simple = simples', wc_impl = implics' }) } + +cloneImplication :: Implication -> TcM Implication +cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) + = do { binds' <- cloneEvBindsVar binds + ; inner_wanted' <- cloneWC inner_wanted + ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } + +---------------------------------------------- +-- Emitting constraints +---------------------------------------------- + +-- | Emits a new Wanted. Deals with both equalities and non-equalities. +emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm +emitWanted origin pty + = do { ev <- newWanted origin Nothing pty + ; emitSimple $ mkNonCanonical ev + ; return $ ctEvTerm ev } + +emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () +-- Emit some new derived nominal equalities +emitDerivedEqs origin pairs + | null pairs + = return () + | otherwise + = do { loc <- getCtLocM origin Nothing + ; emitSimples (listToBag (map (mk_one loc) pairs)) } + where + mk_one loc (ty1, ty2) + = mkNonCanonical $ + CtDerived { ctev_pred = mkPrimEqPred ty1 ty2 + , ctev_loc = loc } + +-- | Emits a new equality constraint +emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion +emitWantedEq origin t_or_k role ty1 ty2 + = do { hole <- newCoercionHole YesBlockSubst pty + ; loc <- getCtLocM origin (Just t_or_k) + ; emitSimple $ mkNonCanonical $ + CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole + , ctev_nosh = WDeriv, ctev_loc = loc } + ; return (HoleCo hole) } + where + pty = mkPrimEqPredRole role ty1 ty2 + +-- | Creates a new EvVar and immediately emits it as a Wanted. +-- No equality predicates here. +emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar +emitWantedEvVar origin ty + = do { new_cv <- newEvVar ty + ; loc <- getCtLocM origin Nothing + ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv + , ctev_pred = ty + , ctev_nosh = WDeriv + , ctev_loc = loc } + ; emitSimple $ mkNonCanonical ctev + ; return new_cv } + +emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] +emitWantedEvVars orig = mapM (emitWantedEvVar orig) + +-- | Emit a new wanted expression hole +emitNewExprHole :: OccName -- of the hole + -> Id -- of the evidence + -> Type -> TcM () +emitNewExprHole occ ev_id ty + = do { loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel) + ; let hole = Hole { hole_sort = ExprHole ev_id + , hole_occ = getOccName ev_id + , hole_ty = ty + , hole_loc = loc } + ; emitHole hole } + +newDict :: Class -> [TcType] -> TcM DictId +newDict cls tys + = do { name <- newSysName (mkDictOcc (getOccName cls)) + ; return (mkLocalId name Many (mkClassPred cls tys)) } + +predTypeOccName :: PredType -> OccName +predTypeOccName ty = case classifyPredType ty of + ClassPred cls _ -> mkDictOcc (getOccName cls) + EqPred {} -> mkVarOccFS (fsLit "co") + IrredPred {} -> mkVarOccFS (fsLit "irred") + ForAllPred {} -> mkVarOccFS (fsLit "df") + +-- | Create a new 'Implication' with as many sensible defaults for its fields +-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do +-- /not/ have sensible defaults, so they are initialized with lazy thunks that +-- will 'panic' if forced, so one should take care to initialize these fields +-- after creation. +-- +-- This is monadic to look up the 'TcLclEnv', which is used to initialize +-- 'ic_env', and to set the -Winaccessible-code flag. See +-- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance". +newImplication :: TcM Implication +newImplication + = do env <- getLclEnv + warn_inaccessible <- woptM Opt_WarnInaccessibleCode + return (implicationPrototype { ic_env = env + , ic_warn_inaccessible = warn_inaccessible }) + +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +newCoercionHole :: BlockSubstFlag -- should the presence of this hole block substitution? + -- See sub-wrinkle in TcCanonical + -- Note [Equalities with incompatible kinds] + -> TcPredType -> TcM CoercionHole +newCoercionHole blocker pred_ty + = do { co_var <- newEvVar pred_ty + ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker) + ; ref <- newMutVar Nothing + ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker + , ch_ref = ref } } + +-- | Put a value in a coercion hole +fillCoercionHole :: CoercionHole -> Coercion -> TcM () +fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co + = do { +#if defined(DEBUG) + ; cts <- readTcRef ref + ; whenIsJust cts $ \old_co -> + pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) +#endif + ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) + ; writeTcRef ref (Just co) } + +-- | Is a coercion hole filled in? +isFilledCoercionHole :: CoercionHole -> TcM Bool +isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref + +-- | Retrieve the contents of a coercion hole. Panics if the hole +-- is unfilled +unpackCoercionHole :: CoercionHole -> TcM Coercion +unpackCoercionHole hole + = do { contents <- unpackCoercionHole_maybe hole + ; case contents of + Just co -> return co + Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } + +-- | Retrieve the contents of a coercion hole, if it is filled +unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) +unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref + +-- | Check that a coercion is appropriate for filling a hole. (The hole +-- itself is needed only for printing. +-- Always returns the checked coercion, but this return value is necessary +-- so that the input coercion is forced only when the output is forced. +checkCoercionHole :: CoVar -> Coercion -> TcM Coercion +checkCoercionHole cv co + | debugIsOn + = do { cv_ty <- zonkTcType (varType cv) + -- co is already zonked, but cv might not be + ; return $ + ASSERT2( ok cv_ty + , (text "Bad coercion hole" <+> + ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role + , ppr cv_ty ]) ) + co } + | otherwise + = return co + + where + (Pair t1 t2, role) = coercionKindRole co + ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty + = t1 `eqType` cv_t1 + && t2 `eqType` cv_t2 + && role == eqRelRole cv_rel + | otherwise + = False + +{- ********************************************************************** +* + ExpType functions +* +********************************************************************** -} + +{- Note [ExpType] +~~~~~~~~~~~~~~~~~ +An ExpType is used as the "expected type" when type-checking an expression. +An ExpType can hold a "hole" that can be filled in by the type-checker. +This allows us to have one tcExpr that works in both checking mode and +synthesis mode (that is, bidirectional type-checking). Previously, this +was achieved by using ordinary unification variables, but we don't need +or want that generality. (For example, #11397 was caused by doing the +wrong thing with unification variables.) Instead, we observe that these +holes should + +1. never be nested +2. never appear as the type of a variable +3. be used linearly (never be duplicated) + +By defining ExpType, separately from Type, we can achieve goals 1 and 2 +statically. + +See also [wiki:typechecking] + +Note [TcLevel of ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data G a where + MkG :: G Bool + + foo MkG = True + +This is a classic untouchable-variable / ambiguous GADT return type +scenario. But, with ExpTypes, we'll be inferring the type of the RHS. +We thus must track a TcLevel in an Inferring ExpType. If we try to +fill the ExpType and find that the TcLevels don't work out, we fill +the ExpType with a tau-tv at the low TcLevel, hopefully to be worked +out later by some means -- see fillInferResult, and Note [fillInferResult] + +This behaviour triggered in test gadt/gadt-escape1. +-} + +-- actual data definition is in GHC.Tc.Utils.TcType + +newInferExpType :: TcM ExpType +newInferExpType + = do { u <- newUnique + ; tclvl <- getTcLevel + ; traceTc "newInferExpType" (ppr u <+> ppr tclvl) + ; ref <- newMutVar Nothing + ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl + , ir_ref = ref })) } + +-- | Extract a type out of an ExpType, if one exists. But one should always +-- exist. Unless you're quite sure you know what you're doing. +readExpType_maybe :: ExpType -> TcM (Maybe TcType) +readExpType_maybe (Check ty) = return (Just ty) +readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref + +-- | Same as readExpType, but for Scaled ExpTypes +readScaledExpType :: Scaled ExpType -> TcM (Scaled Type) +readScaledExpType (Scaled m exp_ty) + = do { ty <- readExpType exp_ty + ; return (Scaled m ty) } + +-- | Extract a type out of an ExpType. Otherwise, panics. +readExpType :: ExpType -> TcM TcType +readExpType exp_ty + = do { mb_ty <- readExpType_maybe exp_ty + ; case mb_ty of + Just ty -> return ty + Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } + +-- | Returns the expected type when in checking mode. +checkingExpType_maybe :: ExpType -> Maybe TcType +checkingExpType_maybe (Check ty) = Just ty +checkingExpType_maybe _ = Nothing + +-- | Returns the expected type when in checking mode. Panics if in inference +-- mode. +checkingExpType :: String -> ExpType -> TcType +checkingExpType _ (Check ty) = ty +checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) + +scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType) +scaledExpTypeToType (Scaled m exp_ty) + = do { ty <- expTypeToType exp_ty + ; return (Scaled m ty) } + +-- | Extracts the expected type if there is one, or generates a new +-- TauTv if there isn't. +expTypeToType :: ExpType -> TcM TcType +expTypeToType (Check ty) = return ty +expTypeToType (Infer inf_res) = inferResultToType inf_res + +inferResultToType :: InferResult -> TcM Type +inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl + , ir_ref = ref }) + = do { mb_inferred_ty <- readTcRef ref + ; tau <- case mb_inferred_ty of + Just ty -> do { ensureMonoType ty + -- See Note [inferResultToType] + ; return ty } + Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) + -- See Note [TcLevel of ExpType] + ; writeMutVar ref (Just tau) + ; return tau } + ; traceTc "Forcing ExpType to be monomorphic:" + (ppr u <+> text ":=" <+> ppr tau) + ; return tau } + +{- Note [inferResultToType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +expTypeToType and inferResultType convert an InferResult to a monotype. +It must be a monotype because if the InferResult isn't already filled in, +we fill it in with a unification variable (hence monotype). So to preserve +order-independence we check for mono-type-ness even if it *is* filled in +already. + +See also Note [TcLevel of ExpType] above, and +Note [fillInferResult]. +-} + +-- | Infer a type using a fresh ExpType +-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" +tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +tcInfer tc_check + = do { res_ty <- newInferExpType + ; result <- tc_check res_ty + ; res_ty <- readExpType res_ty + ; return (result, res_ty) } + +fillInferResult :: TcType -> InferResult -> TcM TcCoercionN +-- If co = fillInferResult t1 t2 +-- => co :: t1 ~ t2 +-- See Note [fillInferResult] +fillInferResult act_res_ty (IR { ir_uniq = u, ir_lvl = res_lvl + , ir_ref = ref }) + = do { mb_exp_res_ty <- readTcRef ref + ; case mb_exp_res_ty of + Just exp_res_ty + -> do { traceTc "Joining inferred ExpType" $ + ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty + ; cur_lvl <- getTcLevel + ; unless (cur_lvl `sameDepthAs` res_lvl) $ + ensureMonoType act_res_ty + ; unifyType Nothing act_res_ty exp_res_ty } + Nothing + -> do { traceTc "Filling inferred ExpType" $ + ppr u <+> text ":=" <+> ppr act_res_ty + ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty + ; writeTcRef ref (Just act_res_ty) + ; return prom_co } + } + + +{- Note [fillInferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When inferring, we use fillInferResult to "fill in" the hole in InferResult + data InferResult = IR { ir_uniq :: Unique + , ir_lvl :: TcLevel + , ir_ref :: IORef (Maybe TcType) } + +There are two things to worry about: + +1. What if it is under a GADT or existential pattern match? + - GADTs: a unification variable (and Infer's hole is similar) is untouchable + - Existentials: be careful about skolem-escape + +2. What if it is filled in more than once? E.g. multiple branches of a case + case e of + T1 -> e1 + T2 -> e2 + +Our typing rules are: + +* The RHS of a existential or GADT alternative must always be a + monotype, regardless of the number of alternatives. + +* Multiple non-existential/GADT branches can have (the same) + higher rank type (#18412). E.g. this is OK: + case e of + True -> hr + False -> hr + where hr:: (forall a. a->a) -> Int + c.f. Section 7.1 of "Practical type inference for arbitrary-rank types" + We use choice (2) in that Section. + (GHC 8.10 and earlier used choice (1).) + + But note that + case e of + True -> hr + False -> \x -> hr x + will fail, because we still /infer/ both branches, so the \x will get + a (monotype) unification variable, which will fail to unify with + (forall a. a->a) + +For (1) we can detect the GADT/existential situation by seeing that +the current TcLevel is greater than that stored in ir_lvl of the Infer +ExpType. We bump the level whenever we go past a GADT/existential match. + +Then, before filling the hole use promoteTcType to promote the type +to the outer ir_lvl. promoteTcType does this + - create a fresh unification variable alpha at level ir_lvl + - emits an equality alpha[ir_lvl] ~ ty + - fills the hole with alpha +That forces the type to be a monotype (since unification variables can +only unify with monotypes); and catches skolem-escapes because the +alpha is untouchable until the equality floats out. + +For (2), we simply look to see if the hole is filled already. + - if not, we promote (as above) and fill the hole + - if it is filled, we simply unify with the type that is + already there + +There is one wrinkle. Suppose we have + case e of + T1 -> e1 :: (forall a. a->a) -> Int + G2 -> e2 +where T1 is not GADT or existential, but G2 is a GADT. Then supppose the +T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. +But now the G2 alternative must not *just* unify with that else we'd risk +allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first +we'd have filled the hole with a unification variable, which enforces a +monotype. + +So if we check G2 second, we still want to emit a constraint that restricts +the RHS to be a monotype. This is done by ensureMonoType, and it works +by simply generating a constraint (alpha ~ ty), where alpha is a fresh +unification variable. We discard the evidence. + +-} + +{- ********************************************************************* +* * + Promoting types +* * +********************************************************************* -} + +ensureMonoType :: TcType -> TcM () +-- Assuming that the argument type is of kind (TYPE r), +-- ensure that it is a /monotype/ +-- If it is not a monotype we can see right away (since unification +-- varibles and type-function applications stand for monotypes), but +-- we emit a Wanted equality just to delay the error message until later +ensureMonoType res_ty + | isTauTy res_ty -- isTauTy doesn't need zonking or anything + = return () + | otherwise + = do { mono_ty <- newOpenFlexiTyVarTy + ; let eq_orig = TypeEqOrigin { uo_actual = res_ty + , uo_expected = mono_ty + , uo_thing = Nothing + , uo_visible = False } + + ; _co <- emitWantedEq eq_orig TypeLevel Nominal res_ty mono_ty + ; return () } + +promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType) +-- See Note [Promoting a type] +-- See also Note [fillInferResult] +-- promoteTcType level ty = (co, ty') +-- * Returns ty' whose max level is just 'level' +-- and whose kind is ~# to the kind of 'ty' +-- and whose kind has form TYPE rr +-- * and co :: ty ~ ty' +-- * and emits constraints to justify the coercion +-- +-- NB: we expect that 'ty' has already kind (TYPE rr) for +-- some rr::RuntimeRep. It is, after all, the type of a term. +promoteTcType dest_lvl ty + = do { cur_lvl <- getTcLevel + ; if (cur_lvl `sameDepthAs` dest_lvl) + then return (mkTcNomReflCo ty, ty) + else promote_it } + where + promote_it :: TcM (TcCoercion, TcType) + promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty + -- where alpha and rr are fresh and from level dest_lvl + = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy + ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr) + ; let eq_orig = TypeEqOrigin { uo_actual = ty + , uo_expected = prom_ty + , uo_thing = Nothing + , uo_visible = False } + + ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty + ; return (co, prom_ty) } + +{- Note [Promoting a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12427) + + data T where + MkT :: (Int -> Int) -> a -> T + + h y = case y of MkT v w -> v + +We'll infer the RHS type with an expected type ExpType of + (IR { ir_lvl = l, ir_ref = ref, ... ) +where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern +match will increase the level, so we'll end up in tcSubType, trying to +unify the type of v, + v :: Int -> Int +with the expected type. But this attempt takes place at level (l+1), +rightly so, since v's type could have mentioned existential variables, +(like w's does) and we want to catch that. + +So we + - create a new meta-var alpha[l+1] + - fill in the InferRes ref cell 'ref' with alpha + - emit an equality constraint, thus + [W] alpha[l+1] ~ (Int -> Int) + +That constraint will float outwards, as it should, unless v's +type mentions a skolem-captured variable. + +This approach fails if v has a higher rank type; see +Note [Promotion and higher rank types] + + +Note [Promotion and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If v had a higher-rank type, say v :: (forall a. a->a) -> Int, +then we'd emit an equality + [W] alpha[l+1] ~ ((forall a. a->a) -> Int) +which will sadly fail because we can't unify a unification variable +with a polytype. But there is nothing really wrong with the program +here. + +We could just about solve this by "promote the type" of v, to expose +its polymorphic "shape" while still leaving constraints that will +prevent existential escape. But we must be careful! Exposing +the "shape" of the type is precisely what we must NOT do under +a GADT pattern match! So in this case we might promote the type +to + (forall a. a->a) -> alpha[l+1] +and emit the constraint + [W] alpha[l+1] ~ Int +Now the promoted type can fill the ref cell, while the emitted +equality can float or not, according to the usual rules. + +But that's not quite right! We are exposing the arrow! We could +deal with that too: + (forall a. mu[l+1] a a) -> alpha[l+1] +with constraints + [W] alpha[l+1] ~ Int + [W] mu[l+1] ~ (->) +Here we abstract over the '->' inside the forall, in case that +is subject to an equality constraint from a GADT match. + +Note that we kept the outer (->) because that's part of +the polymorphic "shape". And because of impredicativity, +GADT matches can't give equalities that affect polymorphic +shape. + +This reasoning just seems too complicated, so I decided not +to do it. These higher-rank notes are just here to record +the thinking. +-} + + +{- ********************************************************************* +* * + MetaTvs (meta type variables; mutable) +* * +********************************************************************* -} + +{- Note [TyVarTv] +~~~~~~~~~~~~~~~~~ + +A TyVarTv can unify with type *variables* only, including other TyVarTvs and +skolems. Sometimes, they can unify with type variables that the user would +rather keep distinct; see #11203 for an example. So, any client of this +function needs to either allow the TyVarTvs to unify with each other or check +that they don't (say, with a call to findDubTyVarTvs). + +Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in +patterns, to make sure these type variables only refer to other type variables, +but this restriction was dropped, and ScopedTypeVariables can now refer to full +types (GHC Proposal 29). + +The remaining uses of newTyVarTyVars are +* In kind signatures, see + GHC.Tc.TyCl Note [Inferring kinds for type declarations] + and Note [Kind checking for GADTs] +* In partial type signatures, see Note [Quantified variables in partial type signatures] +-} + +newMetaTyVarName :: FastString -> TcM Name +-- Makes a /System/ Name, which is eagerly eliminated by +-- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and +-- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2) +newMetaTyVarName str + = do { uniq <- newUnique + ; return (mkSystemName uniq (mkTyVarOccFS str)) } + +cloneMetaTyVarName :: Name -> TcM Name +cloneMetaTyVarName name + = do { uniq <- newUnique + ; return (mkSystemName uniq (nameOccName name)) } + -- See Note [Name of an instantiated type variable] + +{- Note [Name of an instantiated type variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we give a unification variable a System Name, which +influences the way it is tidied; see TypeRep.tidyTyVarBndr. +-} + +metaInfoToTyVarName :: MetaInfo -> FastString +metaInfoToTyVarName meta_info = + case meta_info of + TauTv -> fsLit "t" + FlatMetaTv -> fsLit "fmv" + FlatSkolTv -> fsLit "fsk" + TyVarTv -> fsLit "a" + +newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar +newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi + +newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar +-- Make a new meta tyvar out of thin air +newNamedAnonMetaTyVar tyvar_name meta_info kind + + = do { name <- newMetaTyVarName tyvar_name + ; details <- newMetaDetails meta_info + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newAnonMetaTyVar" (ppr tyvar) + ; return tyvar } + +-- makes a new skolem tv +newSkolemTyVar :: Name -> Kind -> TcM TcTyVar +newSkolemTyVar name kind + = do { lvl <- getTcLevel + ; return (mkTcTyVar name kind (SkolemTv lvl False)) } + +newTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Does not clone a fresh unique +newTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newTyVarTyVar" (ppr tyvar) + ; return tyvar } + +cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Clones a fresh unique +cloneTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; uniq <- newUnique + ; let name' = name `setNameUnique` uniq + tyvar = mkTcTyVar name' kind details + -- Don't use cloneMetaTyVar, which makes a SystemName + -- We want to keep the original more user-friendly Name + -- In practical terms that means that in error messages, + -- when the Name is tidied we get 'a' rather than 'a0' + ; traceTc "cloneTyVarTyVar" (ppr tyvar) + ; return tyvar } + +newPatSigTyVar :: Name -> Kind -> TcM TcTyVar +newPatSigTyVar name kind + = do { details <- newMetaDetails TauTv + ; uniq <- newUnique + ; let name' = name `setNameUnique` uniq + tyvar = mkTcTyVar name' kind details + -- Don't use cloneMetaTyVar; + -- same reasoning as in newTyVarTyVar + ; traceTc "newPatSigTyVar" (ppr tyvar) + ; return tyvar } + +cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar +-- Make a fresh MetaTyVar, basing the name +-- on that of the supplied TyVar +cloneAnonMetaTyVar info tv kind + = do { details <- newMetaDetails info + ; name <- cloneMetaTyVarName (tyVarName tv) + ; let tyvar = mkTcTyVar name kind details + ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) + ; return tyvar } + +newFskTyVar :: TcType -> TcM TcTyVar +newFskTyVar fam_ty + = do { details <- newMetaDetails FlatSkolTv + ; name <- newMetaTyVarName (fsLit "fsk") + ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } + +newFmvTyVar :: TcType -> TcM TcTyVar +-- Very like newMetaTyVar, except sets mtv_tclvl to one less +-- so that the fmv is untouchable. +newFmvTyVar fam_ty + = do { details <- newMetaDetails FlatMetaTv + ; name <- newMetaTyVarName (fsLit "s") + ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; tclvl <- getTcLevel + ; return (MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails +newTauTvDetailsAtLevel tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = TauTv + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +cloneMetaTyVar :: TcTyVar -> TcM TcTyVar +cloneMetaTyVar tv + = ASSERT( isTcTyVar tv ) + do { ref <- newMutVar Flexi + ; name' <- cloneMetaTyVarName (tyVarName tv) + ; let details' = case tcTyVarDetails tv of + details@(MetaTv {}) -> details { mtv_ref = ref } + _ -> pprPanic "cloneMetaTyVar" (ppr tv) + tyvar = mkTcTyVar name' (tyVarKind tv) details' + ; traceTc "cloneMetaTyVar" (ppr tyvar) + ; return tyvar } + +-- Works for both type and kind variables +readMetaTyVar :: TyVar -> TcM MetaDetails +readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) + readMutVar (metaTyVarRef tyvar) + +isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) +isFilledMetaTyVar_maybe tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { cts <- readTcRef ref + ; case cts of + Indirect ty -> return (Just ty) + Flexi -> return Nothing } + | otherwise + = return Nothing + +isFilledMetaTyVar :: TyVar -> TcM Bool +-- True of a filled-in (Indirect) meta type variable +isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv + +isUnfilledMetaTyVar :: TyVar -> TcM Bool +-- True of a un-filled-in (Flexi) meta type variable +-- NB: Not the opposite of isFilledMetaTyVar +isUnfilledMetaTyVar tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { details <- readMutVar ref + ; return (isFlexi details) } + | otherwise = return False + +-------------------- +-- Works with both type and kind variables +writeMetaTyVar :: TcTyVar -> TcType -> TcM () +-- Write into a currently-empty MetaTyVar + +writeMetaTyVar tyvar ty + | not debugIsOn + = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty + +-- Everything from here on only happens if DEBUG is on + | not (isTcTyVar tyvar) + = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar ) + return () + + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar + = writeMetaTyVarRef tyvar ref ty + + | otherwise + = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar ) + return () + +-------------------- +writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () +-- Here the tyvar is for error checking only; +-- the ref cell must be for the same tyvar +writeMetaTyVarRef tyvar ref ty + | not debugIsOn + = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) + <+> text ":=" <+> ppr ty) + ; writeTcRef ref (Indirect ty) } + + -- Everything from here on only happens if DEBUG is on + | otherwise + = do { meta_details <- readMutVar ref; + -- Zonk kinds to allow the error check to work + ; zonked_tv_kind <- zonkTcType tv_kind + ; zonked_ty_kind <- zonkTcType ty_kind + ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind + || tcEqKind zonked_ty_kind zonked_tv_kind + -- Hack alert! tcIsConstraintKind: see GHC.Tc.Gen.HsType + -- Note [Extra-constraint holes in partial type signatures] + + kind_msg = hang (text "Ill-kinded update to meta tyvar") + 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) + <+> text ":=" + <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) + + ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) + + -- Check for double updates + ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details ) + + -- Check for level OK + -- See Note [Level check when unifying] + ; MASSERT2( level_check_ok, level_check_msg ) + -- another level check problem, see #97 + + -- Check Kinds ok + ; MASSERT2( kind_check_ok, kind_msg ) + + -- Do the write + ; writeMutVar ref (Indirect ty) } + where + tv_kind = tyVarKind tyvar + ty_kind = tcTypeKind ty + + tv_lvl = tcTyVarLevel tyvar + ty_lvl = tcTypeLevel ty + + level_check_ok = not (ty_lvl `strictlyDeeperThan` tv_lvl) + level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty + + double_upd_msg details = hang (text "Double update of meta tyvar") + 2 (ppr tyvar $$ ppr details) + +{- Note [Level check when unifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unifying + alpha:lvl := ty +we expect that the TcLevel of 'ty' will be <= lvl. +However, during unflatting we do + fuv:l := ty:(l+1) +which is usually wrong; hence the check isFmmvTyVar in level_check_ok. +See Note [TcLevel assignment] in GHC.Tc.Utils.TcType. +-} + +promoteTyVar :: TcTyVar -> TcM Bool +-- When we float a constraint out of an implication we must restore +-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType +-- Return True <=> we did some promotion +-- Also returns either the original tyvar (no promotion) or the new one +-- See Note [Promoting unification variables] +promoteTyVar tv + = do { tclvl <- getTcLevel + ; if (isFloatedTouchableMetaTyVar tclvl tv) + then do { cloned_tv <- cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; writeMetaTyVar tv (mkTyVarTy rhs_tv) + ; return True } + else return False } + +-- Returns whether or not *any* tyvar is defaulted +promoteTyVarSet :: TcTyVarSet -> TcM Bool +promoteTyVarSet tvs + = do { bools <- mapM promoteTyVar (nonDetEltsUniqSet tvs) + -- Non-determinism is OK because order of promotion doesn't matter + + ; return (or bools) } + + +{- +% Generating fresh variables for pattern match check +-} + + +{- +************************************************************************ +* * + MetaTvs: TauTvs +* * +************************************************************************ + +Note [Never need to instantiate coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With coercion variables sloshing around in types, it might seem that we +sometimes need to instantiate coercion variables. This would be problematic, +because coercion variables inhabit unboxed equality (~#), and the constraint +solver thinks in terms only of boxed equality (~). The solution is that +we never need to instantiate coercion variables in the first place. + +The tyvars that we need to instantiate come from the types of functions, +data constructors, and patterns. These will never be quantified over +coercion variables, except for the special case of the promoted Eq#. But, +that can't ever appear in user code, so we're safe! +-} + + +newMultiplicityVar :: TcM TcType +newMultiplicityVar = newFlexiTyVarTy multiplicityTy + +newFlexiTyVar :: Kind -> TcM TcTyVar +newFlexiTyVar kind = newAnonMetaTyVar TauTv kind + +-- | Create a new flexi ty var with a specific name +newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar +newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind + +newFlexiTyVarTy :: Kind -> TcM TcType +newFlexiTyVarTy kind = do + tc_tyvar <- newFlexiTyVar kind + return (mkTyVarTy tc_tyvar) + +newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] +newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) + +newOpenTypeKind :: TcM TcKind +newOpenTypeKind + = do { rr <- newFlexiTyVarTy runtimeRepTy + ; return (tYPE rr) } + +-- | Create a tyvar that can be a lifted or unlifted type. +-- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh +newOpenFlexiTyVarTy :: TcM TcType +newOpenFlexiTyVarTy + = do { kind <- newOpenTypeKind + ; newFlexiTyVarTy kind } + +newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- Instantiate with META type variables +-- Note that this works for a sequence of kind, type, and coercion variables +-- variables. Eg [ (k:*), (a:k->k) ] +-- Gives [ (k7:*), (a8:k7->k7) ] +newMetaTyVars = newMetaTyVarsX emptyTCvSubst + -- emptyTCvSubst has an empty in-scope set, but that's fine here + -- Since the tyvars are freshly made, they cannot possibly be + -- captured by any existing for-alls. + +newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- Just like newMetaTyVars, but start with an existing substitution. +newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst + +newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +-- Make a new unification variable tyvar whose Name and Kind come from +-- an existing TyVar. We substitute kind variables in the kind. +newMetaTyVarX = new_meta_tv_x TauTv + +newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +-- Just like newMetaTyVarX, but make a TyVarTv +newMetaTyVarTyVarX = new_meta_tv_x TyVarTv + +newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +newWildCardX subst tv + = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) + ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } + +new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +new_meta_tv_x info subst tv + = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind + ; let subst1 = extendTvSubstWithClone subst tv new_tv + ; return (subst1, new_tv) } + where + substd_kind = substTyUnchecked subst (tyVarKind tv) + -- NOTE: #12549 is fixed so we could use + -- substTy here, but the tc_infer_args problem + -- is not yet fixed so leaving as unchecked for now. + -- OLD NOTE: + -- Unchecked because we call newMetaTyVarX from + -- tcInstTyBinder, which is called from tcInferTyApps + -- which does not yet take enough trouble to ensure + -- the in-scope set is right; e.g. #12785 trips + -- if we use substTy here + +newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType +newMetaTyVarTyAtLevel tc_lvl kind + = do { details <- newTauTvDetailsAtLevel tc_lvl + ; name <- newMetaTyVarName (fsLit "p") + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + +{- ********************************************************************* +* * + Finding variables to quantify over +* * +********************************************************************* -} + +{- Note [Dependent type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell type inference we quantify over type variables; but we only +quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds +we default the kind variables to *. + +So, to support this defaulting, and only for that reason, when +collecting the free vars of a type (in candidateQTyVarsOfType and friends), +prior to quantifying, we must keep the type and kind variables separate. + +But what does that mean in a system where kind variables /are/ type +variables? It's a fairly arbitrary distinction based on how the +variables appear: + + - "Kind variables" appear in the kind of some other free variable + or in the kind of a locally quantified type variable + (forall (a :: kappa). ...) or in the kind of a coercion + (a |> (co :: kappa1 ~ kappa2)). + + These are the ones we default to * if -XPolyKinds is off + + - "Type variables" are all free vars that are not kind variables + +E.g. In the type T k (a::k) + 'k' is a kind variable, because it occurs in the kind of 'a', + even though it also appears at "top level" of the type + 'a' is a type variable, because it doesn't + +We gather these variables using a CandidatesQTvs record: + DV { dv_kvs: Variables free in the kind of a free type variable + or of a forall-bound type variable + , dv_tvs: Variables syntactically free in the type } + +So: dv_kvs are the kind variables of the type + (dv_tvs - dv_kvs) are the type variable of the type + +Note that + +* A variable can occur in both. + T k (x::k) The first occurrence of k makes it + show up in dv_tvs, the second in dv_kvs + +* We include any coercion variables in the "dependent", + "kind-variable" set because we never quantify over them. + +* The "kind variables" might depend on each other; e.g + (k1 :: k2), (k2 :: *) + The "type variables" do not depend on each other; if + one did, it'd be classified as a kind variable! + +Note [CandidatesQTvs determinism and order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Determinism: when we quantify over type variables we decide the + order in which they appear in the final type. Because the order of + type variables in the type can end up in the interface file and + affects some optimizations like worker-wrapper, we want this order to + be deterministic. + + To achieve that we use deterministic sets of variables that can be + converted to lists in a deterministic order. For more information + about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +* Order: as well as being deterministic, we use an + accumulating-parameter style for candidateQTyVarsOfType so that we + add variables one at a time, left to right. That means we tend to + produce the variables in left-to-right order. This is just to make + it bit more predictable for the programmer. + +Note [Naughty quantification candidates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14880, dependent/should_compile/T14880-2), suppose +we are trying to generalise this type: + + forall arg. ... (alpha[tau]:arg) ... + +We have a metavariable alpha whose kind mentions a skolem variable +bound inside the very type we are generalising. +This can arise while type-checking a user-written type signature +(see the test case for the full code). + +We cannot generalise over alpha! That would produce a type like + forall {a :: arg}. forall arg. ...blah... +The fact that alpha's kind mentions arg renders it completely +ineligible for generalisation. + +However, we are not going to learn any new constraints on alpha, +because its kind isn't even in scope in the outer context (but see Wrinkle). +So alpha is entirely unconstrained. + +What then should we do with alpha? During generalization, every +metavariable is either (A) promoted, (B) generalized, or (C) zapped +(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType). + + * We can't generalise it. + * We can't promote it, because its kind prevents that + * We can't simply leave it be, because this type is about to + go into the typing environment (as the type of some let-bound + variable, say), and then chaos erupts when we try to instantiate. + +Previously, we zapped it to Any. This worked, but it had the unfortunate +effect of causing Any sometimes to appear in error messages. If this +kind of signature happens, the user probably has made a mistake -- no +one really wants Any in their types. So we now error. This must be +a hard error (failure in the monad) to avoid other messages from mentioning +Any. + +We do this eager erroring in candidateQTyVars, which always precedes +generalisation, because at that moment we have a clear picture of what +skolems are in scope within the type itself (e.g. that 'forall arg'). + +Wrinkle: + +We must make absolutely sure that alpha indeed is not +from an outer context. (Otherwise, we might indeed learn more information +about it.) This can be done easily: we just check alpha's TcLevel. +That level must be strictly greater than the ambient TcLevel in order +to treat it as naughty. We say "strictly greater than" because the call to +candidateQTyVars is made outside the bumped TcLevel, as stated in the +comment to candidateQTyVarsOfType. The level check is done in go_tv +in collect_cand_qtvs. Skipping this check caused #16517. + +-} + +data CandidatesQTvs + -- See Note [Dependent type variables] + -- See Note [CandidatesQTvs determinism and order] + -- + -- Invariants: + -- * All variables are fully zonked, including their kinds + -- * All variables are at a level greater than the ambient level + -- See Note [Use level numbers for quantification] + -- + -- This *can* contain skolems. For example, in `data X k :: k -> Type` + -- we need to know that the k is a dependent variable. This is done + -- by collecting the candidates in the kind after skolemising. It also + -- comes up when generalizing a associated type instance, where instance + -- variables are skolems. (Recall that associated type instances are generalized + -- independently from their enclosing class instance, and the associated + -- type instance may be generalized by more, fewer, or different variables + -- than the class instance.) + -- + = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) + , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) + -- A variable may appear in both sets + -- E.g. T k (x::k) The first occurrence of k makes it + -- show up in dv_tvs, the second in dv_kvs + -- See Note [Dependent type variables] + + , dv_cvs :: CoVarSet + -- These are covars. Included only so that we don't repeatedly + -- look at covars' kinds in accumulator. Not used by quantifyTyVars. + } + +instance Semi.Semigroup CandidatesQTvs where + (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) + <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) + = DV { dv_kvs = kv1 `unionDVarSet` kv2 + , dv_tvs = tv1 `unionDVarSet` tv2 + , dv_cvs = cv1 `unionVarSet` cv2 } + +instance Monoid CandidatesQTvs where + mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } + mappend = (Semi.<>) + +instance Outputable CandidatesQTvs where + ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) + = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs + , text "dv_tvs =" <+> ppr tvs + , text "dv_cvs =" <+> ppr cvs ]) + + +candidateKindVars :: CandidatesQTvs -> TyVarSet +candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) + +partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) +-- The selected TyVars are returned as a non-deterministic TyVarSet +partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred + = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) + where + (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs + (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs + extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs + +-- | Gathers free variables to use as quantification candidates (in +-- 'quantifyTyVars'). This might output the same var +-- in both sets, if it's used in both a type and a kind. +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +-- See Note [CandidatesQTvs determinism and order] +-- See Note [Dependent type variables] +candidateQTyVarsOfType :: TcType -- not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfType ty = collect_cand_qtvs ty False emptyVarSet mempty ty + +-- | Like 'candidateQTyVarsOfType', but over a list of types +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs +candidateQTyVarsOfTypes tys = foldlM (\acc ty -> collect_cand_qtvs ty False emptyVarSet acc ty) + mempty tys + +-- | Like 'candidateQTyVarsOfType', but consider every free variable +-- to be dependent. This is appropriate when generalizing a *kind*, +-- instead of a type. (That way, -XNoPolyKinds will default the variables +-- to Type.) +candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKind ty = collect_cand_qtvs ty True emptyVarSet mempty ty + +candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty) + mempty tys + +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs +delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars + = DV { dv_kvs = kvs `delDVarSetList` vars + , dv_tvs = tvs `delDVarSetList` vars + , dv_cvs = cvs `delVarSetList` vars } + +collect_cand_qtvs + :: TcType -- original type that we started recurring into; for errors + -> Bool -- True <=> consider every fv in Type to be dependent + -> VarSet -- Bound variables (locals only) + -> CandidatesQTvs -- Accumulating parameter + -> Type -- Not necessarily zonked + -> TcM CandidatesQTvs + +-- Key points: +-- * Looks through meta-tyvars as it goes; +-- no need to zonk in advance +-- +-- * Needs to be monadic anyway, because it handles naughty +-- quantification; see Note [Naughty quantification candidates] +-- +-- * Returns fully-zonked CandidateQTvs, including their kinds +-- so that subsequent dependency analysis (to build a well +-- scoped telescope) works correctly + +collect_cand_qtvs orig_ty is_dep bound dvs ty + = go dvs ty + where + is_bound tv = tv `elemVarSet` bound + + ----------------- + go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs + -- Uses accumulating-parameter style + go dv (AppTy t1 t2) = foldlM go dv [t1, t2] + go dv (TyConApp _ tys) = foldlM go dv tys + go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] + go dv (LitTy {}) = return dv + go dv (CastTy ty co) = do dv1 <- go dv ty + collect_cand_qtvs_co orig_ty bound dv1 co + go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty bound dv co + + go dv (TyVarTy tv) + | is_bound tv = return dv + | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv + ; case m_contents of + Just ind_ty -> go dv ind_ty + Nothing -> go_tv dv tv } + + go dv (ForAllTy (Bndr tv _) ty) + = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv) + ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty } + + ----------------- + go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv + | tv `elemDVarSet` kvs + = return dv -- We have met this tyvar already + + | not is_dep + , tv `elemDVarSet` tvs + = return dv -- We have met this tyvar already + + | otherwise + = do { tv_kind <- zonkTcType (tyVarKind tv) + -- This zonk is annoying, but it is necessary, both to + -- ensure that the collected candidates have zonked kinds + -- (#15795) and to make the naughty check + -- (which comes next) works correctly + + ; let tv_kind_vars = tyCoVarsOfType tv_kind + ; cur_lvl <- getTcLevel + ; if | tcTyVarLevel tv <= cur_lvl + -> return dv -- this variable is from an outer context; skip + -- See Note [Use level numbers ofor quantification] + + | intersectsVarSet bound tv_kind_vars + -- the tyvar must not be from an outer context, but we have + -- already checked for this. + -- See Note [Naughty quantification candidates] + -> do { traceTc "Naughty quantifier" $ + vcat [ ppr tv <+> dcolon <+> ppr tv_kind + , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) + , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] + + ; let escapees = intersectVarSet bound tv_kind_vars + ; naughtyQuantification orig_ty tv escapees } + + | otherwise + -> do { let tv' = tv `setTyVarKind` tv_kind + dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } + | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } + -- See Note [Order of accumulation] + + -- See Note [Recurring into kinds for candidateQTyVars] + ; collect_cand_qtvs orig_ty True bound dv' tv_kind } } + +collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors + -> VarSet -- bound variables + -> CandidatesQTvs -> Coercion + -> TcM CandidatesQTvs +collect_cand_qtvs_co orig_ty bound = go_co + where + go_co dv (Refl ty) = collect_cand_qtvs orig_ty True bound dv ty + go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty + go_mco dv1 mco + go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos + go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (FunCo _ w co1 co2) = foldlM go_co dv [w, co1, co2] + go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos + go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos + go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov + dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1 + collect_cand_qtvs orig_ty True bound dv2 t2 + go_co dv (SymCo co) = go_co dv co + go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (NthCo _ _ co) = go_co dv co + go_co dv (LRCo _ co) = go_co dv co + go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (KindCo co) = go_co dv co + go_co dv (SubCo co) = go_co dv co + + go_co dv (HoleCo hole) + = do m_co <- unpackCoercionHole_maybe hole + case m_co of + Just co -> go_co dv co + Nothing -> go_cv dv (coHoleCoVar hole) + + go_co dv (CoVarCo cv) = go_cv dv cv + + go_co dv (ForAllCo tcv kind_co co) + = do { dv1 <- go_co dv kind_co + ; collect_cand_qtvs_co orig_ty (bound `extendVarSet` tcv) dv1 co } + + go_mco dv MRefl = return dv + go_mco dv (MCo co) = go_co dv co + + go_prov dv (PhantomProv co) = go_co dv co + go_prov dv (ProofIrrelProv co) = go_co dv co + go_prov dv (PluginProv _) = return dv + go_prov dv CorePrepProv = return dv + + go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs + go_cv dv@(DV { dv_cvs = cvs }) cv + | is_bound cv = return dv + | cv `elemVarSet` cvs = return dv + + -- See Note [Recurring into kinds for candidateQTyVars] + | otherwise = collect_cand_qtvs orig_ty True bound + (dv { dv_cvs = cvs `extendVarSet` cv }) + (idType cv) + + is_bound tv = tv `elemVarSet` bound + +{- Note [Order of accumulation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might be tempted (like I was) to use unitDVarSet and mappend +rather than extendDVarSet. However, the union algorithm for +deterministic sets depends on (roughly) the size of the sets. The +elements from the smaller set end up to the right of the elements from +the larger one. When sets are equal, the left-hand argument to +`mappend` goes to the right of the right-hand argument. + +In our case, if we use unitDVarSet and mappend, we learn that the free +variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify +over them in that order. (The a comes after the b because we union the +singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, +the size criterion works to our advantage.) This is just annoying to +users, so I use `extendDVarSet`, which unambiguously puts the new +element to the right. + +Note that the unitDVarSet/mappend implementation would not be wrong +against any specification -- just suboptimal and confounding to users. + +Note [Recurring into kinds for candidateQTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying +attention to the end of the Note about using an empty bound set when +traversing a variable's kind. + +That Note concludes with the recommendation that we empty out the bound +set when recurring into the kind of a type variable. Yet, we do not do +this here. I have two tasks in order to convince you that this code is +right. First, I must show why it is safe to ignore the reasoning in that +Note. Then, I must show why is is necessary to contradict the reasoning in +that Note. + +Why it is safe: There can be no +shadowing in the candidateQ... functions: they work on the output of +type inference, which is seeded by the renamer and its insistence to +use different Uniques for different variables. (In contrast, the Core +functions work on the output of optimizations, which may introduce +shadowing.) Without shadowing, the problem studied by +Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. + +Why it is necessary: +Wiping the bound set would be just plain wrong here. Consider + + forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) + +We really don't want to think k1 and k2 are free here. (It's true that we'll +never be able to fill in `hole`, but we don't want to go off the rails just +because we have an insoluble coercion hole.) So: why is it wrong to wipe +the bound variables here but right in Core? Because the final statement +in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not +every variable is either free or bound. A variable can be a hole, too! +The reasoning in that Note then breaks down. + +And the reasoning applies just as well to free non-hole variables, so we +retain the bound set always. + +-} + +{- ********************************************************************* +* * + Quantification +* * +************************************************************************ + +Note [quantifyTyVars] +~~~~~~~~~~~~~~~~~~~~~ +quantifyTyVars is given the free vars of a type that we +are about to wrap in a forall. + +It takes these free type/kind variables (partitioned into dependent and +non-dependent variables) skolemises metavariables with a TcLevel greater +than the ambient level (see Note [Use level numbers of quantification]). + +* This function distinguishes between dependent and non-dependent + variables only to keep correct defaulting behavior with -XNoPolyKinds. + With -XPolyKinds, it treats both classes of variables identically. + +* quantifyTyVars never quantifies over + - a coercion variable (or any tv mentioned in the kind of a covar) + - a runtime-rep variable + +Note [Use level numbers for quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The level numbers assigned to metavariables are very useful. Not only +do they track touchability (Note [TcLevel and untouchable type variables] +in GHC.Tc.Utils.TcType), but they also allow us to determine which variables to +generalise. The rule is this: + + When generalising, quantify only metavariables with a TcLevel greater + than the ambient level. + +This works because we bump the level every time we go inside a new +source-level construct. In a traditional generalisation algorithm, we +would gather all free variables that aren't free in an environment. +However, if a variable is in that environment, it will always have a lower +TcLevel: it came from an outer scope. So we can replace the "free in +environment" check with a level-number check. + +Here is an example: + + f x = x + (z True) + where + z y = x * x + +We start by saying (x :: alpha[1]). When inferring the type of z, we'll +quickly discover that z :: alpha[1]. But it would be disastrous to +generalise over alpha in the type of z. So we need to know that alpha +comes from an outer environment. By contrast, the type of y is beta[2], +and we are free to generalise over it. What's the difference between +alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for +generalisation, and so we generalise it. alpha[1] does not, and so +we leave it alone. + +Note that not *every* variable with a higher level will get generalised, +either due to the monomorphism restriction or other quirks. See, for +example, the code in GHC.Tc.Solver.decideMonoTyVars and in +GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible +variables from being generalised. + +Using level numbers for quantification is implemented in the candidateQTyVars... +functions, by adding only those variables with a level strictly higher than +the ambient level to the set of candidates. + +Note [quantifyTyVars determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The results of quantifyTyVars are wrapped in a forall and can end up in the +interface file. One such example is inferred type signatures. They also affect +the results of optimizations, for example worker-wrapper. This means that to +get deterministic builds quantifyTyVars needs to be deterministic. + +To achieve this CandidatesQTvs is backed by deterministic sets which allows them +to be later converted to a list in a deterministic order. + +For more information about deterministic sets see +Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. +-} + +quantifyTyVars + :: CandidatesQTvs -- See Note [Dependent type variables] + -- Already zonked + -> TcM [TcTyVar] +-- See Note [quantifyTyVars] +-- Can be given a mixture of TcTyVars and TyVars, in the case of +-- associated type declarations. Also accepts covars, but *never* returns any. +-- According to Note [Use level numbers for quantification] and the +-- invariants on CandidateQTvs, we do not have to filter out variables +-- free in the environment here. Just quantify unconditionally, subject +-- to the restrictions in Note [quantifyTyVars]. +quantifyTyVars dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) + -- short-circuit common case + | isEmptyDVarSet dep_tkvs + , isEmptyDVarSet nondep_tkvs + = do { traceTc "quantifyTyVars has nothing to quantify" empty + ; return [] } + + | otherwise + = do { traceTc "quantifyTyVars 1" (ppr dvs) + + ; let dep_kvs = scopedSort $ dVarSetElems dep_tkvs + -- scopedSort: put the kind variables into + -- well-scoped order. + -- E.g. [k, (a::k)] not the other way round + + nondep_tvs = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs) + -- See Note [Dependent type variables] + -- The `minus` dep_tkvs removes any kind-level vars + -- e.g. T k (a::k) Since k appear in a kind it'll + -- be in dv_kvs, and is dependent. So remove it from + -- dv_tvs which will also contain k + -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV + + -- In the non-PolyKinds case, default the kind variables + -- to *, and zonk the tyvars as usual. Notice that this + -- may make quantifyTyVars return a shorter list + -- than it was passed, but that's ok + ; poly_kinds <- xoptM LangExt.PolyKinds + ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs + ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs + ; let final_qtvs = dep_kvs' ++ nondep_tvs' + -- Because of the order, any kind variables + -- mentioned in the kinds of the nondep_tvs' + -- now refer to the dep_kvs' + + ; traceTc "quantifyTyVars 2" + (vcat [ text "nondep:" <+> pprTyVars nondep_tvs + , text "dep:" <+> pprTyVars dep_kvs + , text "dep_kvs'" <+> pprTyVars dep_kvs' + , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ]) + + -- We should never quantify over coercion variables; check this + ; let co_vars = filter isCoVar final_qtvs + ; MASSERT2( null co_vars, ppr co_vars ) + + ; return final_qtvs } + where + -- zonk_quant returns a tyvar if it should be quantified over; + -- otherwise, it returns Nothing. The latter case happens for + -- * Kind variables, with -XNoPolyKinds: don't quantify over these + -- * RuntimeRep variables: we never quantify over these + zonk_quant default_kind tkv + | not (isTyVar tkv) + = return Nothing -- this can happen for a covar that's associated with + -- a coercion hole. Test case: typecheck/should_compile/T2494 + + | not (isTcTyVar tkv) + = return (Just tkv) -- For associated types in a class with a standalone + -- kind signature, we have the class variables in + -- scope, and they are TyVars not TcTyVars + | otherwise + = do { deflt_done <- defaultTyVar default_kind tkv + ; case deflt_done of + True -> return Nothing + False -> do { tv <- skolemiseQuantifiedTyVar tkv + ; return (Just tv) } } + +isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification + -> TcTyVar + -> Bool +isQuantifiableTv outer_tclvl tcv + | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately + = tcTyVarLevel tcv > outer_tclvl + | otherwise + = False + +zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar +-- A tyvar binder is never a unification variable (TauTv), +-- rather it is always a skolem. It *might* be a TyVarTv. +-- (Because non-CUSK type declarations use TyVarTvs.) +-- Regardless, it may have a kind that has not yet been zonked, +-- and may include kind unification variables. +zonkAndSkolemise tyvar + | isTyVarTyVar tyvar + -- We want to preserve the binding location of the original TyVarTv. + -- This is important for error messages. If we don't do this, then + -- we get bad locations in, e.g., typecheck/should_fail/T2688 + = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar + ; skolemiseQuantifiedTyVar zonked_tyvar } + + | otherwise + = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar ) + zonkTyCoVarKind tyvar + +skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar +-- The quantified type variables often include meta type variables +-- we want to freeze them into ordinary type variables +-- The meta tyvar is updated to point to the new skolem TyVar. Now any +-- bound occurrences of the original type variable will get zonked to +-- the immutable version. +-- +-- We leave skolem TyVars alone; they are immutable. +-- +-- This function is called on both kind and type variables, +-- but kind variables *only* if PolyKinds is on. + +skolemiseQuantifiedTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) + ; return (setTyVarKind tv kind) } + -- It might be a skolem type variable, + -- for example from a user type signature + + MetaTv {} -> skolemiseUnboundMetaTyVar tv + + _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk + +defaultTyVar :: Bool -- True <=> please default this kind variable to * + -> TcTyVar -- If it's a MetaTyVar then it is unbound + -> TcM Bool -- True <=> defaulted away altogether + +defaultTyVar default_kind tv + | not (isMetaTyVar tv) + = return False + + | isTyVarTyVar tv + -- Do not default TyVarTvs. Doing so would violate the invariants + -- on TyVarTvs; see Note [Signature skolems] in GHC.Tc.Utils.TcType. + -- #13343 is an example; #14555 is another + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return False + + + | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var + -- unless it is a TyVarTv, handled earlier + = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) + ; writeMetaTyVar tv liftedRepTy + ; return True } + | isMultiplicityVar tv + = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv) + ; writeMetaTyVar tv manyDataConTy + ; return True } + + | default_kind -- -XNoPolyKinds and this is a kind var + = default_kind_var tv -- so default it to * if possible + + | otherwise + = return False + + where + default_kind_var :: TyVar -> TcM Bool + -- defaultKindVar is used exclusively with -XNoPolyKinds + -- See Note [Defaulting with -XNoPolyKinds] + -- It takes an (unconstrained) meta tyvar and defaults it. + -- Works only on vars of type *; for other kinds, it issues an error. + default_kind_var kv + | isLiftedTypeKind (tyVarKind kv) + = do { traceTc "Defaulting a kind var to *" (ppr kv) + ; writeMetaTyVar kv liftedTypeKind + ; return True } + | otherwise + = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') + , text "of kind:" <+> ppr (tyVarKind kv') + , text "Perhaps enable PolyKinds or add a kind signature" ]) + -- We failed to default it, so return False to say so. + -- Hence, it'll get skolemised. That might seem odd, but we must either + -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType + -- Note [Recipe for checking a signature] + -- Otherwise we get level-number assertion failures. It doesn't matter much + -- because we are in an error situation anyway. + ; return False + } + where + (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv + +skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar +-- We have a Meta tyvar with a ref-cell inside it +-- Skolemise it, so that we are totally out of Meta-tyvar-land +-- We create a skolem TcTyVar, not a regular TyVar +-- See Note [Zonking to Skolem] +skolemiseUnboundMetaTyVar tv + = ASSERT2( isMetaTyVar tv, ppr tv ) + do { when debugIsOn (check_empty tv) + ; here <- getSrcSpanM -- Get the location from "here" + -- ie where we are generalising + ; kind <- zonkTcType (tyVarKind tv) + ; let tv_name = tyVarName tv + -- See Note [Skolemising and identity] + final_name | isSystemName tv_name + = mkInternalName (nameUnique tv_name) + (nameOccName tv_name) here + | otherwise + = tv_name + final_tv = mkTcTyVar final_name kind details + + ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) + ; writeMetaTyVar tv (mkTyVarTy final_tv) + ; return final_tv } + + where + details = SkolemTv (metaTyVarTcLevel tv) False + check_empty tv -- [Sept 04] Check for non-empty. + = when debugIsOn $ -- See note [Silly Type Synonym] + do { cts <- readMetaTyVar tv + ; case cts of + Flexi -> return () + Indirect ty -> WARN( True, ppr tv $$ ppr ty ) + return () } + +{- Note [Defaulting with -XNoPolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Compose f g a = Mk (f (g a)) + +We infer + + Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * + Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). + f (g a) -> Compose k1 k2 f g a + +Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. +What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, +we just defaulted all kind variables to *. But that's no good here, +because the kind variables in 'Mk aren't of kind *, so defaulting to * +is ill-kinded. + +After some debate on #11334, we decided to issue an error in this case. +The code is in defaultKindVar. + +Note [What is a meta variable?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "meta type-variable", also know as a "unification variable" is a placeholder +introduced by the typechecker for an as-yet-unknown monotype. + +For example, when we see a call `reverse (f xs)`, we know that we calling + reverse :: forall a. [a] -> [a] +So we know that the argument `f xs` must be a "list of something". But what is +the "something"? We don't know until we explore the `f xs` a bit more. So we set +out what we do know at the call of `reverse` by instantiating its type with a fresh +meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the +result, is `[alpha]`. The unification variable `alpha` stands for the +as-yet-unknown type of the elements of the list. + +As type inference progresses we may learn more about `alpha`. For example, suppose +`f` has the type + f :: forall b. b -> [Maybe b] +Then we instantiate `f`'s type with another fresh unification variable, say +`beta`; and equate `f`'s result type with reverse's argument type, thus +`[alpha] ~ [Maybe beta]`. + +Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've +refined our knowledge about `alpha`. And so on. + +If you found this Note useful, you may also want to have a look at +Section 5 of "Practical type inference for higher rank types" (Peyton Jones, +Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). + +Note [What is zonking?] +~~~~~~~~~~~~~~~~~~~~~~~ +GHC relies heavily on mutability in the typechecker for efficient operation. +For this reason, throughout much of the type checking process meta type +variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable +variables (known as TcRefs). + +Zonking is the process of ripping out these mutable variables and replacing them +with a real Type. This involves traversing the entire type expression, but the +interesting part of replacing the mutable variables occurs in zonkTyVarOcc. + +There are two ways to zonk a Type: + + * zonkTcTypeToType, which is intended to be used at the end of type-checking + for the final zonk. It has to deal with unfilled metavars, either by filling + it with a value like Any or failing (determined by the UnboundTyVarZonker + used). + + * zonkTcType, which will happily ignore unfilled metavars. This is the + appropriate function to use while in the middle of type-checking. + +Note [Zonking to Skolem] +~~~~~~~~~~~~~~~~~~~~~~~~ +We used to zonk quantified type variables to regular TyVars. However, this +leads to problems. Consider this program from the regression test suite: + + eval :: Int -> String -> String -> String + eval 0 root actual = evalRHS 0 root actual + + evalRHS :: Int -> a + evalRHS 0 root actual = eval 0 root actual + +It leads to the deferral of an equality (wrapped in an implication constraint) + + forall a. () => ((String -> String -> String) ~ a) + +which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck). +In the meantime `a' is zonked and quantified to form `evalRHS's signature. +This has the *side effect* of also zonking the `a' in the deferred equality +(which at this point is being handed around wrapped in an implication +constraint). + +Finally, the equality (with the zonked `a') will be handed back to the +simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop. +If we zonk `a' with a regular type variable, we will have this regular type +variable now floating around in the simplifier, which in many places assumes to +only see proper TcTyVars. + +We can avoid this problem by zonking with a skolem TcTyVar. The +skolem is rigid (which we require for a quantified variable), but is +still a TcTyVar that the simplifier knows how to deal with. + +Note [Skolemising and identity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some places, we make a TyVarTv for a binder. E.g. + class C a where ... +As Note [Inferring kinds for type declarations] discusses, +we make a TyVarTv for 'a'. Later we skolemise it, and we'd +like to retain its identity, location info etc. (If we don't +retain its identity we'll have to do some pointless swizzling; +see GHC.Tc.TyCl.swizzleTcTyConBndrs. If we retain its identity +but not its location we'll lose the detailed binding site info. + +Conclusion: use the Name of the TyVarTv. But we don't want +to do that when skolemising random unification variables; +there the location we want is the skolemisation site. + +Fortunately we can tell the difference: random unification +variables have System Names. That's why final_name is +set based on the isSystemName test. + + +Note [Silly Type Synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + type C u a = u -- Note 'a' unused + + foo :: (forall a. C u a -> C u a) -> u + foo x = ... + + bar :: Num u => u + bar = foo (\t -> t + t) + +* From the (\t -> t+t) we get type {Num d} => d -> d + where d is fresh. + +* Now unify with type of foo's arg, and we get: + {Num (C d a)} => C d a -> C d a + where a is fresh. + +* Now abstract over the 'a', but float out the Num (C d a) constraint + because it does not 'really' mention a. (see exactTyVarsOfType) + The arg to foo becomes + \/\a -> \t -> t+t + +* So we get a dict binding for Num (C d a), which is zonked to give + a = () + [Note Sept 04: now that we are zonking quantified type variables + on construction, the 'a' will be frozen as a regular tyvar on + quantification, so the floated dict will still have type (C d a). + Which renders this whole note moot; happily!] + +* Then the \/\a abstraction has a zonked 'a' in it. + +All very silly. I think its harmless to ignore the problem. We'll end up with +a \/\a in the final result but all the occurrences of a will be zonked to () + +************************************************************************ +* * + Zonking types +* * +************************************************************************ + +-} + +zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet +-- Zonk a type and take its free variables +-- With kind polymorphism it can be essential to zonk *first* +-- so that we find the right set of free variables. Eg +-- forall k1. forall (a:k2). a +-- where k2:=k1 is in the substitution. We don't want +-- k2 to look free in this type! +zonkTcTypeAndFV ty + = tyCoVarsOfTypeDSet <$> zonkTcType ty + +zonkTyCoVar :: TyCoVar -> TcM TcType +-- Works on TyVars and TcTyVars +zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv + | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv + | otherwise = ASSERT2( isCoVar tv, ppr tv ) + mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv + -- Hackily, when typechecking type and class decls + -- we have TyVars in scope added (only) in + -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet +zonkTyCoVarsAndFV tycovars + = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) + -- It's OK to use nonDetEltsUniqSet here because we immediately forget about + -- the ordering by turning it into a nondeterministic set and the order + -- of zonking doesn't matter for determinism. + +zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet +zonkDTyCoVarSetAndFV tycovars + = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) + +-- Takes a list of TyCoVars, zonks them and returns a +-- deterministically ordered list of their free variables. +zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar] +zonkTyCoVarsAndFVList tycovars + = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars + +zonkTcTyVars :: [TcTyVar] -> TcM [TcType] +zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars + +----------------- Types +zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar +zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) + ; return (setTyVarKind tv kind') } + +zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl) +zonkTyCoVarKindBinder (Bndr tv fl) = do { kind' <- zonkTcType (tyVarKind tv) + ; return $ Bndr (setTyVarKind tv kind') fl } + +{- +************************************************************************ +* * + Zonking constraints +* * +************************************************************************ +-} + +zonkImplication :: Implication -> TcM Implication +zonkImplication implic@(Implic { ic_skols = skols + , ic_given = given + , ic_wanted = wanted + , ic_info = info }) + = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! + -- as #7230 showed + ; given' <- mapM zonkEvVar given + ; info' <- zonkSkolemInfo info + ; wanted' <- zonkWCRec wanted + ; return (implic { ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' }) } + +zonkEvVar :: EvVar -> TcM EvVar +zonkEvVar var = updateIdTypeAndMultM zonkTcType var + + +zonkWC :: WantedConstraints -> TcM WantedConstraints +zonkWC wc = zonkWCRec wc + +zonkWCRec :: WantedConstraints -> TcM WantedConstraints +zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes }) + = do { simple' <- zonkSimples simple + ; implic' <- mapBagM zonkImplication implic + ; holes' <- mapBagM zonkHole holes + ; return (WC { wc_simple = simple', wc_impl = implic', wc_holes = holes' }) } + +zonkSimples :: Cts -> TcM Cts +zonkSimples cts = do { cts' <- mapBagM zonkCt cts + ; traceTc "zonkSimples done:" (ppr cts') + ; return cts' } + +zonkHole :: Hole -> TcM Hole +zonkHole hole@(Hole { hole_ty = ty }) + = do { ty' <- zonkTcType ty + ; return (hole { hole_ty = ty' }) } + -- No need to zonk the Id in any ExprHole because we never look at it + -- until after the final zonk and desugaring + +{- Note [zonkCt behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +zonkCt tries to maintain the canonical form of a Ct. For example, + - a CDictCan should stay a CDictCan; + - a CIrredCan should stay a CIrredCan with its cc_status flag intact + +Why?, for example: +- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the + simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, + constraints are zonked before being passed to the plugin. This means if we + don't preserve a canonical form, @expandSuperClasses@ fails to expand + superclasses. This is what happened in #11525. + +- For CIrredCan we want to see if a constraint is insoluble with insolubleWC + +On the other hand, we change CTyEqCan to CNonCanonical, because of all of +CTyEqCan's invariants, which can break during zonking. Besides, the constraint +will be canonicalised again, so there is little benefit in keeping the +CTyEqCan structure. + +NB: we do not expect to see any CFunEqCans, because zonkCt is only +called on unflattened constraints. + +NB: Constraints are always re-flattened etc by the canonicaliser in +@GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that +are actually in the inert set carry all the guarantees. So it is okay if zonkCt +creates e.g. a CDictCan where the cc_tyars are /not/ function free. +-} + +zonkCt :: Ct -> TcM Ct +-- See Note [zonkCt behaviour] +zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) + = do { ev' <- zonkCtEvidence ev + ; args' <- mapM zonkTcType args + ; return $ ct { cc_ev = ev', cc_tyargs = args' } } + +zonkCt (CTyEqCan { cc_ev = ev }) + = mkNonCanonical <$> zonkCtEvidence ev + +zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag + = do { ev' <- zonkCtEvidence ev + ; return (ct { cc_ev = ev' }) } + +zonkCt ct + = ASSERT( not (isCFunEqCan ct) ) + -- We do not expect to see any CFunEqCans, because zonkCt is only called on + -- unflattened constraints. + do { fl' <- zonkCtEvidence (ctEvidence ct) + ; return (mkNonCanonical fl') } + +zonkCtEvidence :: CtEvidence -> TcM CtEvidence +zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred'}) } +zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest }) + = do { pred' <- zonkTcType pred + ; let dest' = case dest of + EvVarDest ev -> EvVarDest $ setVarType ev pred' + -- necessary in simplifyInfer + HoleDest h -> HoleDest h + ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) } +zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred' }) } + +zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo +zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty + ; return (SigSkol cx ty' tv_prs) } +zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol ntys') } + where + do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } +zonkSkolemInfo skol_info = return skol_info + +{- +%************************************************************************ +%* * +\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} +* * +* For internal use only! * +* * +************************************************************************ + +-} + +-- For unbound, mutable tyvars, zonkType uses the function given to it +-- For tyvars bound at a for-all, zonkType zonks them to an immutable +-- type variable and zonks the kind too +zonkTcType :: TcType -> TcM TcType +zonkTcTypes :: [TcType] -> TcM [TcType] +zonkCo :: Coercion -> TcM Coercion + +(zonkTcType, zonkTcTypes, zonkCo, _) + = mapTyCo zonkTcTypeMapper + +-- | A suitable TyCoMapper for zonking a type during type-checking, +-- before all metavars are filled in. +zonkTcTypeMapper :: TyCoMapper () TcM +zonkTcTypeMapper = TyCoMapper + { tcm_tyvar = const zonkTcTyVar + , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) + , tcm_hole = hole + , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv + , tcm_tycon = zonkTcTyCon } + where + hole :: () -> CoercionHole -> TcM Coercion + hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) + = do { contents <- readTcRef ref + ; case contents of + Just co -> do { co' <- zonkCo co + ; checkCoercionHole cv co' } + Nothing -> do { cv' <- zonkCoVar cv + ; return $ HoleCo (hole { ch_co_var = cv' }) } } + +zonkTcTyCon :: TcTyCon -> TcM TcTyCon +-- Only called on TcTyCons +-- A non-poly TcTyCon may have unification +-- variables that need zonking, but poly ones cannot +zonkTcTyCon tc + | tcTyConIsPoly tc = return tc + | otherwise = do { tck' <- zonkTcType (tyConKind tc) + ; return (setTcTyConKind tc tck') } + +zonkTcTyVar :: TcTyVar -> TcM TcType +-- Simply look through all Flexis +zonkTcTyVar tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return + MetaTv { mtv_ref = ref } + -> do { cts <- readMutVar ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> do { zty <- zonkTcType ty + ; writeTcRef ref (Indirect zty) + -- See Note [Sharing in zonking] + ; return zty } } + + | otherwise -- coercion variable + = zonk_kind_and_return + where + zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv + ; return (mkTyVarTy z_tv) } + +-- Variant that assumes that any result of zonking is still a TyVar. +-- Should be used only on skolems and TyVarTvs +zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar +zonkTcTyVarToTyVar tv + = do { ty <- zonkTcTyVar tv + ; let tv' = case tcGetTyVar_maybe ty of + Just tv' -> tv' + Nothing -> pprPanic "zonkTcTyVarToTyVar" + (ppr tv $$ ppr ty) + ; return tv' } + +zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TyVar spec) +zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv + ; return (Bndr tv' spec) } + +-- zonkId is used *during* typechecking just to zonk the Id's type +zonkId :: TcId -> TcM TcId +zonkId id = Id.updateIdTypeAndMultM zonkTcType id + +zonkCoVar :: CoVar -> TcM CoVar +zonkCoVar = zonkId + +{- Note [Sharing in zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + alpha :-> beta :-> gamma :-> ty +where the ":->" means that the unification variable has been +filled in with Indirect. Then when zonking alpha, it'd be nice +to short-circuit beta too, so we end up with + alpha :-> zty + beta :-> zty + gamma :-> zty +where zty is the zonked version of ty. That way, if we come across +beta later, we'll have less work to do. (And indeed the same for +alpha.) + +This is easily achieved: just overwrite (Indirect ty) with (Indirect +zty). Non-systematic perf comparisons suggest that this is a modest +win. + +But c.f Note [Sharing when zonking to Type] in GHC.Tc.Utils.Zonk. + +%************************************************************************ +%* * + Tidying +* * +************************************************************************ +-} + +zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) +zonkTidyTcType env ty = do { ty' <- zonkTcType ty + ; return (tidyOpenType env ty') } + +zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType]) +zonkTidyTcTypes = zonkTidyTcTypes' [] + where zonkTidyTcTypes' zs env [] = return (env, reverse zs) + zonkTidyTcTypes' zs env (ty:tys) + = do { (env', ty') <- zonkTidyTcType env ty + ; zonkTidyTcTypes' (ty':zs) env' tys } + +zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) +zonkTidyOrigin env (GivenOrigin skol_info) + = do { skol_info1 <- zonkSkolemInfo skol_info + ; let skol_info2 = tidySkolemInfo env skol_info1 + ; return (env, GivenOrigin skol_info2) } +zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act + , uo_expected = exp }) + = do { (env1, act') <- zonkTidyTcType env act + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( env2, orig { uo_actual = act' + , uo_expected = exp' }) } +zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, m_ty2') <- case m_ty2 of + Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 + Nothing -> return (env1, Nothing) + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } +zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) } +zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; (env3, o1') <- zonkTidyOrigin env2 o1 + ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } +zonkTidyOrigin env orig = return (env, orig) + +---------------- +tidyCt :: TidyEnv -> Ct -> Ct +-- Used only in error reporting +tidyCt env ct + = ct { cc_ev = tidy_ev (ctEvidence ct) } + where + tidy_ev :: CtEvidence -> CtEvidence + -- NB: we do not tidy the ctev_evar field because we don't + -- show it in error messages + tidy_ev ctev = ctev { ctev_pred = tidyType env (ctev_pred ctev) } + +tidyHole :: TidyEnv -> Hole -> Hole +tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } + +---------------- +tidyEvVar :: TidyEnv -> EvVar -> EvVar +tidyEvVar env var = updateIdTypeAndMult (tidyType env) var + +---------------- +tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo +tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) +tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs +tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) +tidySkolemInfo _ info = info + +tidySigSkol :: TidyEnv -> UserTypeCtxt + -> TcType -> [(Name,TcTyVar)] -> SkolemInfo +-- We need to take special care when tidying SigSkol +-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" +tidySigSkol env cx ty tv_prs + = SigSkol cx (tidy_ty env ty) tv_prs' + where + tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs + inst_env = mkNameEnv tv_prs' + + tidy_ty env (ForAllTy (Bndr tv vis) ty) + = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) + where + (env', tv') = tidy_tv_bndr env tv + + tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under c => t + = ty { ft_mult = tidy_ty env w, + ft_arg = tidyType env arg, + ft_res = tidy_ty env res } + + tidy_ty env ty = tidyType env ty + + tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) + tidy_tv_bndr env@(occ_env, subst) tv + | Just tv' <- lookupNameEnv inst_env (tyVarName tv) + = ((occ_env, extendVarEnv subst tv tv'), tv') + + | otherwise + = tidyVarBndr env tv + +------------------------------------------------------------------------- +{- +%************************************************************************ +%* * + Levity polymorphism checks +* * +************************************************************************* + +See Note [Levity polymorphism checking] in GHC.HsToCore.Monad + +-} + +-- | According to the rules around representation polymorphism +-- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder +-- can have a representation-polymorphic type. This check ensures +-- that we respect this rule. It is a bit regrettable that this error +-- occurs in zonking, after which we should have reported all errors. +-- But it's hard to see where else to do it, because this can be discovered +-- only after all solving is done. And, perhaps most importantly, this +-- isn't really a compositional property of a type system, so it's +-- not a terrible surprise that the check has to go in an awkward spot. +ensureNotLevPoly :: Type -- its zonked type + -> SDoc -- where this happened + -> TcM () +ensureNotLevPoly ty doc + = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type + -- forall a. a. See, for example, test ghci/scripts/T9140 + checkForLevPoly doc ty + + -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad +checkForLevPoly :: SDoc -> Type -> TcM () +checkForLevPoly = checkForLevPolyX addErr + +checkForLevPolyX :: Monad m + => (SDoc -> m ()) -- how to report an error + -> SDoc -> Type -> m () +checkForLevPolyX add_err extra ty + | isTypeLevPoly ty + = add_err (formatLevPolyErr ty $$ extra) + | otherwise + = return () + +formatLevPolyErr :: Type -- levity-polymorphic type + -> SDoc +formatLevPolyErr ty + = hang (text "A levity-polymorphic type is not allowed here:") + 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty + , text "Kind:" <+> pprWithTYPE tidy_ki ]) + where + (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty + tidy_ki = tidyType tidy_env (tcTypeKind ty) + +{- +%************************************************************************ +%* * + Error messages +* * +************************************************************************* + +-} + +-- See Note [Naughty quantification candidates] +naughtyQuantification :: TcType -- original type user wanted to quantify + -> TcTyVar -- naughty var + -> TyVarSet -- skolems that would escape + -> TcM a +naughtyQuantification orig_ty tv escapees + = do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked + + ; escapees' <- mapM zonkTcTyVarToTyVar $ + nonDetEltsUniqSet escapees + -- we'll just be printing, so no harmful non-determinism + + ; let fvs = tyCoVarsOfTypeWellScoped orig_ty1 + env0 = tidyFreeTyCoVars emptyTidyEnv fvs + env = env0 `delTidyEnvList` escapees' + -- this avoids gratuitous renaming of the escaped + -- variables; very confusing to users! + + orig_ty' = tidyType env orig_ty1 + ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) + doc = pprWithExplicitKindsWhen True $ + vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' + , quotes $ ppr_tidied escapees' + , text "would escape" <+> itsOrTheir escapees' <+> text "scope" + ] + , sep [ text "if I tried to quantify" + , ppr_tidied [tv] + , text "in this type:" + ] + , nest 2 (pprTidiedType orig_ty') + , text "(Indeed, I sometimes struggle even printing this correctly," + , text " due to its ill-scoped nature.)" + ] + + ; failWithTcM (env, doc) } diff --git a/GHC/Tc/Utils/TcType.hs b/GHC/Tc/Utils/TcType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcType.hs @@ -0,0 +1,2486 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Types used in the typechecker +-- +-- This module provides the Type interface for front-end parts of the +-- compiler. These parts +-- +-- * treat "source types" as opaque: +-- newtypes, and predicates are meaningful. +-- * look through usage types +-- +module GHC.Tc.Utils.TcType ( + -------------------------------- + -- Types + TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, + TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, + TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder, + TcTyCon, KnotTied, + + ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, + + SyntaxOpType(..), synKnownType, mkSynFunTys, + + -- TcLevel + TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, + strictlyDeeperThan, sameDepthAs, + tcTypeLevel, tcTyVarLevel, maxTcLevel, + promoteSkolem, promoteSkolemX, promoteSkolemsX, + -------------------------------- + -- MetaDetails + TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, + MetaDetails(Flexi, Indirect), MetaInfo(..), + isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, + tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, + isFskTyVar, isFmvTyVar, isFlattenTyVar, + isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, + isFlexi, isIndirect, isRuntimeUnkSkol, + metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, + isTouchableMetaTyVar, + isFloatedTouchableMetaTyVar, + findDupTyVarTvs, mkTyVarNamePairs, + + -------------------------------- + -- Builders + mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, + mkTcAppTy, mkTcAppTys, mkTcCastTy, + + -------------------------------- + -- Splitters + -- These are important because they do not look through newtypes + getTyVar, + tcSplitForAllTy_maybe, + tcSplitForAllTys, + tcSplitForAllTysReq, tcSplitForAllTysInvis, + tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs, + tcSplitPhiTy, tcSplitPredFunTy_maybe, + tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, + tcSplitFunTysN, + tcSplitTyConApp, tcSplitTyConApp_maybe, + tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, + tcRepGetNumAppTys, + tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, + tcSplitSigmaTy, tcSplitNestedSigmaTys, + + --------------------------------- + -- Predicates. + -- Again, newtypes are opaque + eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, + isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, + isIntegerTy, isNaturalTy, + isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, + isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, + isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck, + checkValidClsArgs, hasTyVarHead, + isRigidTy, isAlmostFunctionFree, + + --------------------------------- + -- Misc type manipulators + + deNoteType, + orphNamesOfType, orphNamesOfCo, + orphNamesOfTypes, orphNamesOfCoCon, + getDFunTyKey, evVarPred, + + --------------------------------- + -- Predicate types + mkMinimalBySCs, transSuperClasses, + pickQuantifiablePreds, pickCapturedPreds, + immSuperClasses, boxEqPred, + isImprovementPred, + + -- * Finding type instances + tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree, + + -- * Finding "exact" (non-dead) type variables + exactTyCoVarsOfType, exactTyCoVarsOfTypes, + anyRewritableTyVar, + + --------------------------------- + -- Foreign import and export + isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool + isFFIImportResultTy, -- :: DynFlags -> Type -> Bool + isFFIExportResultTy, -- :: Type -> Bool + isFFIExternalTy, -- :: Type -> Bool + isFFIDynTy, -- :: Type -> Type -> Bool + isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool + isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool + isFFILabelTy, -- :: Type -> Bool + isFFITy, -- :: Type -> Bool + isFunPtrTy, -- :: Type -> Bool + tcSplitIOType_maybe, -- :: Type -> Maybe Type + + -------------------------------- + -- Reexported from Kind + Kind, tcTypeKind, + liftedTypeKind, + constraintKind, + isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, + + -------------------------------- + -- Reexported from Type + Type, PredType, ThetaType, TyCoBinder, + ArgFlag(..), AnonArgFlag(..), + + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTys, mkTyCoInvForAllTy, + mkInfForAllTy, mkInfForAllTys, + mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTyMany, + mkVisFunTyMany, mkVisFunTysMany, mkInvisFunTysMany, + mkTyConApp, mkAppTy, mkAppTys, + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + + isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass, + mkClassPred, + tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, + isRuntimeRepVar, isKindLevPoly, + isVisibleBinder, isInvisibleBinder, + + -- Type substitutions + TCvSubst(..), -- Representation visible to a few friends + TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + zipTvSubst, + mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, + getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, + extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, + Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, + Type.extendTvSubst, + isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, + Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, + substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTheta, + + isUnliftedType, -- Source types are always lifted + isUnboxedTupleType, -- Ditto + isPrimitiveType, + + tcView, coreView, + + tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, + tyCoFVsOfType, tyCoFVsOfTypes, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, + tyCoVarsOfTypeList, tyCoVarsOfTypesList, + noFreeVarsOfType, + + -------------------------------- + pprKind, pprParendKind, pprSigmaType, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, + pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, + pprTCvBndr, pprTCvBndrs, + + TypeSize, sizeType, sizeTypes, scopedSort, + + --------------------------------- + -- argument visibility + tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible + + ) where + +#include "HsVersions.h" + +-- friends: +import GHC.Prelude + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.Class +import GHC.Types.Var +import GHC.Types.ForeignCall +import GHC.Types.Var.Set +import GHC.Core.Coercion +import GHC.Core.Type as Type +import GHC.Core.Predicate +import GHC.Types.RepType +import GHC.Core.TyCon + +-- others: +import GHC.Driver.Session +import GHC.Core.FVs +import GHC.Types.Name as Name + -- We use this to make dictionaries for type literals. + -- Perhaps there's a better way to do this? +import GHC.Types.Name.Set +import GHC.Types.Var.Env +import GHC.Builtin.Names +import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey + , listTyCon, constraintKind ) +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Data.List.SetOps ( getNth, findDupsEq ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Error( Validity(..), MsgDoc, isValid ) +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ( mapAccumL ) +-- import Data.Functor.Identity( Identity(..) ) +import Data.IORef +import Data.List.NonEmpty( NonEmpty(..) ) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ + +The type checker divides the generic Type world into the +following more structured beasts: + +sigma ::= forall tyvars. phi + -- A sigma type is a qualified type + -- + -- Note that even if 'tyvars' is empty, theta + -- may not be: e.g. (?x::Int) => Int + + -- Note that 'sigma' is in prenex form: + -- all the foralls are at the front. + -- A 'phi' type has no foralls to the right of + -- an arrow + +phi :: theta => rho + +rho ::= sigma -> rho + | tau + +-- A 'tau' type has no quantification anywhere +-- Note that the args of a type constructor must be taus +tau ::= tyvar + | tycon tau_1 .. tau_n + | tau_1 tau_2 + | tau_1 -> tau_2 + +-- In all cases, a (saturated) type synonym application is legal, +-- provided it expands to the required form. + +Note [TcTyVars and TyVars in the typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker uses a lot of type variables with special properties, +notably being a unification variable with a mutable reference. These +use the 'TcTyVar' variant of Var.Var. + +Note, though, that a /bound/ type variable can (and probably should) +be a TyVar. E.g + forall a. a -> a +Here 'a' is really just a deBruijn-number; it certainly does not have +a significant TcLevel (as every TcTyVar does). So a forall-bound type +variable should be TyVars; and hence a TyVar can appear free in a TcType. + +The type checker and constraint solver can also encounter /free/ type +variables that use the 'TyVar' variant of Var.Var, for a couple of +reasons: + + - When typechecking a class decl, say + class C (a :: k) where + foo :: T a -> Int + We have first kind-check the header; fix k and (a:k) to be + TyVars, bring 'k' and 'a' into scope, and kind check the + signature for 'foo'. In doing so we call solveEqualities to + solve any kind equalities in foo's signature. So the solver + may see free occurrences of 'k'. + + See calls to tcExtendTyVarEnv for other places that ordinary + TyVars are bought into scope, and hence may show up in the types + and kinds generated by GHC.Tc.Gen.HsType. + + - The pattern-match overlap checker calls the constraint solver, + long after TcTyVars have been zonked away + +It's convenient to simply treat these TyVars as skolem constants, +which of course they are. We give them a level number of "outermost", +so they behave as global constants. Specifically: + +* Var.tcTyVarDetails succeeds on a TyVar, returning + vanillaSkolemTv, as well as on a TcTyVar. + +* tcIsTcTyVar returns True for both TyVar and TcTyVar variants + of Var.Var. The "tc" prefix means "a type variable that can be + encountered by the typechecker". + +This is a bit of a change from an earlier era when we remoselessly +insisted on real TcTyVars in the type checker. But that seems +unnecessary (for skolems, TyVars are fine) and it's now very hard +to guarantee, with the advent of kind equalities. + +Note [Coercion variables in free variable lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several places in the GHC codebase where functions like +tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type +variables of a type. The "Co" part of these functions' names shouldn't be +dismissed, as it is entirely possible that they will include coercion variables +in addition to type variables! As a result, there are some places in GHC.Tc.Utils.TcType +where we must take care to check that a variable is a _type_ variable (using +isTyVar) before calling tcTyVarDetails--a partial function that is not defined +for coercion variables--on the variable. Failing to do so led to +GHC #12785. +-} + +-- See Note [TcTyVars and TyVars in the typechecker] +type TcCoVar = CoVar -- Used only during type inference +type TcType = Type -- A TcType can have mutable type variables +type TcTyCoVar = Var -- Either a TcTyVar or a CoVar + -- Invariant on ForAllTy in TcTypes: + -- forall a. T + -- a cannot occur inside a MutTyVar in T; that is, + -- T is "flattened" before quantifying over a + +type TcTyVarBinder = TyVarBinder +type TcInvisTVBinder = InvisTVBinder +type TcReqTVBinder = ReqTVBinder +type TcTyCon = TyCon -- these can be the TcTyCon constructor + +-- These types do not have boxy type variables in them +type TcPredType = PredType +type TcThetaType = ThetaType +type TcSigmaType = TcType +type TcRhoType = TcType -- Note [TcRhoType] +type TcTauType = TcType +type TcKind = Kind +type TcTyVarSet = TyVarSet +type TcTyCoVarSet = TyCoVarSet +type TcDTyVarSet = DTyVarSet +type TcDTyCoVarSet = DTyCoVarSet + +{- ********************************************************************* +* * + ExpType: an "expected type" in the type checker +* * +********************************************************************* -} + +-- | An expected type to check against during type-checking. +-- See Note [ExpType] in "GHC.Tc.Utils.TcMType", where you'll also find manipulators. +data ExpType = Check TcType + | Infer !InferResult + +data InferResult + = IR { ir_uniq :: Unique -- For debugging only + + , ir_lvl :: TcLevel -- See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType + + , ir_ref :: IORef (Maybe TcType) } + -- The type that fills in this hole should be a Type, + -- that is, its kind should be (TYPE rr) for some rr + +type ExpSigmaType = ExpType +type ExpRhoType = ExpType + +instance Outputable ExpType where + ppr (Check ty) = text "Check" <> braces (ppr ty) + ppr (Infer ir) = ppr ir + +instance Outputable InferResult where + ppr (IR { ir_uniq = u, ir_lvl = lvl }) + = text "Infer" <> braces (ppr u <> comma <> ppr lvl) + +-- | Make an 'ExpType' suitable for checking. +mkCheckExpType :: TcType -> ExpType +mkCheckExpType = Check + + +{- ********************************************************************* +* * + SyntaxOpType +* * +********************************************************************* -} + +-- | What to expect for an argument to a rebindable-syntax operator. +-- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. +-- The callback called from tcSyntaxOp gets a list of types; the meaning +-- of these types is determined by a left-to-right depth-first traversal +-- of the 'SyntaxOpType' tree. So if you pass in +-- +-- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny +-- +-- you'll get three types back: one for the first 'SynAny', the /element/ +-- type of the list, and one for the last 'SynAny'. You don't get anything +-- for the 'SynType', because you've said positively that it should be an +-- Int, and so it shall be. +-- +-- You'll also get three multiplicities back: one for each function arrow. See +-- also Note [Linear types] in Multiplicity. +-- +-- This is defined here to avoid defining it in "GHC.Tc.Gen.Expr" boot file. +data SyntaxOpType + = SynAny -- ^ Any type + | SynRho -- ^ A rho type, skolemised or instantiated as appropriate + | SynList -- ^ A list type. You get back the element type of the list + | SynFun SyntaxOpType SyntaxOpType + -- ^ A function. + | SynType ExpType -- ^ A known type. +infixr 0 `SynFun` + +-- | Like 'SynType' but accepts a regular TcType +synKnownType :: TcType -> SyntaxOpType +synKnownType = SynType . mkCheckExpType + +-- | Like 'mkFunTys' but for 'SyntaxOpType' +mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType +mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys + + +{- +Note [TcRhoType] +~~~~~~~~~~~~~~~~ +A TcRhoType has no foralls or contexts at the top + NO forall a. a -> Int + NO Eq a => a -> a + YES a -> a + YES (forall a. a->a) -> Int + YES Int -> forall a. a -> Int + + +************************************************************************ +* * + TyVarDetails, MetaDetails, MetaInfo +* * +************************************************************************ + +TyVarDetails gives extra info about type variables, used during type +checking. It's attached to mutable type variables only. +It's knot-tied back to "GHC.Types.Var". There is no reason in principle +why "GHC.Types.Var" shouldn't actually have the definition, but it "belongs" here. + +Note [Signature skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +A TyVarTv is a specialised variant of TauTv, with the following invariants: + + * A TyVarTv can be unified only with a TyVar, + not with any other type + + * Its MetaDetails, if filled in, will always be another TyVarTv + or a SkolemTv + +TyVarTvs are only distinguished to improve error messages. +Consider this + + data T (a:k1) = MkT (S a) + data S (b:k2) = MkS (T b) + +When doing kind inference on {S,T} we don't want *skolems* for k1,k2, +because they end up unifying; we want those TyVarTvs again. + + +Note [TyVars and TcTyVars during type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Var type has constructors TyVar and TcTyVar. They are used +as follows: + +* TcTyVar: used /only/ during type checking. Should never appear + afterwards. May contain a mutable field, in the MetaTv case. + +* TyVar: is never seen by the constraint solver, except locally + inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar. + We instantiate these with TcTyVars before exposing the type + to the constraint solver. + +I have swithered about the latter invariant, excluding TyVars from the +constraint solver. It's not strictly essential, and indeed +(historically but still there) Var.tcTyVarDetails returns +vanillaSkolemTv for a TyVar. + +But ultimately I want to seeparate Type from TcType, and in that case +we would need to enforce the separation. +-} + +-- A TyVarDetails is inside a TyVar +-- See Note [TyVars and TcTyVars] +data TcTyVarDetails + = SkolemTv -- A skolem + TcLevel -- Level of the implication that binds it + -- See GHC.Tc.Utils.Unify Note [Deeper level on the left] for + -- how this level number is used + Bool -- True <=> this skolem type variable can be overlapped + -- when looking up instances + -- See Note [Binding when looking up instances] in GHC.Core.InstEnv + + | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi + -- interactive context + + | MetaTv { mtv_info :: MetaInfo + , mtv_ref :: IORef MetaDetails + , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] + +vanillaSkolemTv, superSkolemTv :: TcTyVarDetails +-- See Note [Binding when looking up instances] in GHC.Core.InstEnv +vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated +superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type + -- The choice of level number here is a bit dodgy, but + -- topTcLevel works in the places that vanillaSkolemTv is used + +instance Outputable TcTyVarDetails where + ppr = pprTcTyVarDetails + +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +-- For debugging +pprTcTyVarDetails (RuntimeUnk {}) = text "rt" +pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl +pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl +pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) + = ppr info <> colon <> ppr tclvl + +----------------------------- +data MetaDetails + = Flexi -- Flexi type variables unify to become Indirects + | Indirect TcType + +data MetaInfo + = TauTv -- This MetaTv is an ordinary unification variable + -- A TauTv is always filled in with a tau-type, which + -- never contains any ForAlls. + + | TyVarTv -- A variant of TauTv, except that it should not be + -- unified with a type, only with a type variable + -- See Note [Signature skolems] + + | FlatMetaTv -- A flatten meta-tyvar + -- It is a meta-tyvar, but it is always untouchable, with level 0 + -- See Note [The flattening story] in GHC.Tc.Solver.Flatten + + | FlatSkolTv -- A flatten skolem tyvar + -- Just like FlatMetaTv, but is completely "owned" by + -- its Given CFunEqCan. + -- It is filled in /only/ by unflattenGivens + -- See Note [The flattening story] in GHC.Tc.Solver.Flatten + +instance Outputable MetaDetails where + ppr Flexi = text "Flexi" + ppr (Indirect ty) = text "Indirect" <+> ppr ty + +instance Outputable MetaInfo where + ppr TauTv = text "tau" + ppr TyVarTv = text "tyv" + ppr FlatMetaTv = text "fmv" + ppr FlatSkolTv = text "fsk" + +{- ********************************************************************* +* * + Untouchable type variables +* * +********************************************************************* -} + +newtype TcLevel = TcLevel Int deriving( Eq, Ord ) + -- See Note [TcLevel and untouchable type variables] for what this Int is + -- See also Note [TcLevel assignment] + +{- +Note [TcLevel and untouchable type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Each unification variable (MetaTv) + and each Implication + has a level number (of type TcLevel) + +* INVARIANTS. In a tree of Implications, + + (ImplicInv) The level number (ic_tclvl) of an Implication is + STRICTLY GREATER THAN that of its parent + + (SkolInv) The level number of the skolems (ic_skols) of an + Implication is equal to the level of the implication + itself (ic_tclvl) + + (GivenInv) The level number of a unification variable appearing + in the 'ic_given' of an implication I should be + STRICTLY LESS THAN the ic_tclvl of I + + (WantedInv) The level number of a unification variable appearing + in the 'ic_wanted' of an implication I should be + LESS THAN OR EQUAL TO the ic_tclvl of I + See Note [WantedInv] + +* A unification variable is *touchable* if its level number + is EQUAL TO that of its immediate parent implication, + and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv) + +Note [WantedInv] +~~~~~~~~~~~~~~~~ +Why is WantedInv important? Consider this implication, where +the constraint (C alpha[3]) disobeys WantedInv: + + forall[2] a. blah => (C alpha[3]) + (forall[3] b. alpha[3] ~ b) + +We can unify alpha:=b in the inner implication, because 'alpha' is +touchable; but then 'b' has excaped its scope into the outer implication. + +Note [Skolem escape prevention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only unify touchable unification variables. Because of +(WantedInv), there can be no occurrences of the variable further out, +so the unification can't cause the skolems to escape. Example: + data T = forall a. MkT a (a->Int) + f x (MkT v f) = length [v,x] +We decide (x::alpha), and generate an implication like + [1]forall a. (a ~ alpha[0]) +But we must not unify alpha:=a, because the skolem would escape. + +For the cases where we DO want to unify, we rely on floating the +equality. Example (with same T) + g x (MkT v f) = x && True +We decide (x::alpha), and generate an implication like + [1]forall a. (Bool ~ alpha[0]) +We do NOT unify directly, bur rather float out (if the constraint +does not mention 'a') to get + (Bool ~ alpha[0]) /\ [1]forall a.() +and NOW we can unify alpha. + +The same idea of only unifying touchables solves another problem. +Suppose we had + (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) +In this example, beta is touchable inside the implication. The +first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside +the implication where a new constraint + uf ~ beta +emerges. If we (wrongly) spontaneously solved it to get uf := beta, +the whole implication disappears but when we pop out again we are left with +(F Int ~ uf) which will be unified by our final zonking stage and +uf will get unified *once more* to (F Int). + +Note [TcLevel assignment] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange the TcLevels like this + + 0 Top level + 1 First-level implication constraints + 2 Second-level implication constraints + ...etc... +-} + +maxTcLevel :: TcLevel -> TcLevel -> TcLevel +maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) + +topTcLevel :: TcLevel +-- See Note [TcLevel assignment] +topTcLevel = TcLevel 0 -- 0 = outermost level + +isTopTcLevel :: TcLevel -> Bool +isTopTcLevel (TcLevel 0) = True +isTopTcLevel _ = False + +pushTcLevel :: TcLevel -> TcLevel +-- See Note [TcLevel assignment] +pushTcLevel (TcLevel us) = TcLevel (us + 1) + +strictlyDeeperThan :: TcLevel -> TcLevel -> Bool +strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) + = tv_tclvl > ctxt_tclvl + +sameDepthAs :: TcLevel -> TcLevel -> Bool +sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) + = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl + -- So <= would be equivalent + +checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool +-- Checks (WantedInv) from Note [TcLevel and untouchable type variables] +checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) + = ctxt_tclvl >= tv_tclvl + +-- Returns topTcLevel for non-TcTyVars +tcTyVarLevel :: TcTyVar -> TcLevel +tcTyVarLevel tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl + SkolemTv tv_lvl _ -> tv_lvl + RuntimeUnk -> topTcLevel + + +tcTypeLevel :: TcType -> TcLevel +-- Max level of any free var of the type +tcTypeLevel ty + = nonDetStrictFoldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty) + -- It's safe to use a non-deterministic fold because `maxTcLevel` is + -- commutative. + where + add v lvl + | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v + | otherwise = lvl + +instance Outputable TcLevel where + ppr (TcLevel us) = ppr us + +promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar +promoteSkolem tclvl skol + | tclvl < tcTyVarLevel skol + = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) + setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol)) + + | otherwise + = skol + +-- | Change the TcLevel in a skolem, extending a substitution +promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar) +promoteSkolemX tclvl subst skol + = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) + (new_subst, new_skol) + where + new_skol + | tclvl < tcTyVarLevel skol + = setTcTyVarDetails (updateTyVarKind (substTy subst) skol) + (SkolemTv tclvl (isOverlappableTyVar skol)) + | otherwise + = updateTyVarKind (substTy subst) skol + new_subst = extendTvSubstWithClone subst skol new_skol + +promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar]) +promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl) + +{- ********************************************************************* +* * + Finding type family instances +* * +************************************************************************ +-} + +-- | Finds outermost type-family applications occurring in a type, +-- after expanding synonyms. In the list (F, tys) that is returned +-- we guarantee that tys matches F's arity. For example, given +-- type family F a :: * -> * (arity 1) +-- calling tcTyFamInsts on (Maybe (F Int Bool) will return +-- (F, [Int]), not (F, [Int,Bool]) +-- +-- This is important for its use in deciding termination of type +-- instances (see #11581). E.g. +-- type instance G [Int] = ...(F Int \)... +-- we don't need to take \ into account when asking if +-- the calls on the RHS are smaller than the LHS +tcTyFamInsts :: Type -> [(TyCon, [Type])] +tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis + +-- | Like 'tcTyFamInsts', except that the output records whether the +-- type family and its arguments occur as an /invisible/ argument in +-- some type application. This information is useful because it helps GHC know +-- when to turn on @-fprint-explicit-kinds@ during error reporting so that +-- users can actually see the type family being mentioned. +-- +-- As an example, consider: +-- +-- @ +-- class C a +-- data T (a :: k) +-- type family F a :: k +-- instance C (T @(F Int) (F Bool)) +-- @ +-- +-- There are two occurrences of the type family `F` in that `C` instance, so +-- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return: +-- +-- @ +-- [ ('True', F, [Int]) +-- , ('False', F, [Bool]) ] +-- @ +-- +-- @F Int@ is paired with 'True' since it appears as an /invisible/ argument +-- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a +-- /visible/ argument to @C@. +-- +-- See also @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". +tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] +tcTyFamInstsAndVis = tcTyFamInstsAndVisX False + +tcTyFamInstsAndVisX + :: Bool -- ^ Is this an invisible argument to some type application? + -> Type -> [(Bool, TyCon, [Type])] +tcTyFamInstsAndVisX = go + where + go is_invis_arg ty + | Just exp_ty <- tcView ty = go is_invis_arg exp_ty + go _ (TyVarTy _) = [] + go is_invis_arg (TyConApp tc tys) + | isTypeFamilyTyCon tc + = [(is_invis_arg, tc, take (tyConArity tc) tys)] + | otherwise + = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys + go _ (LitTy {}) = [] + go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) + ++ go is_invis_arg ty + go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w + ++ go is_invis_arg ty1 + ++ go is_invis_arg ty2 + go is_invis_arg ty@(AppTy _ _) = + let (ty_head, ty_args) = splitAppTys ty + ty_arg_flags = appTyArgFlags ty_head ty_args + in go is_invis_arg ty_head + ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag)) + ty_arg_flags ty_args) + go is_invis_arg (CastTy ty _) = go is_invis_arg ty + go _ (CoercionTy _) = [] -- don't count tyfams in coercions, + -- as they never get normalized, + -- anyway + +-- | In an application of a 'TyCon' to some arguments, find the outermost +-- occurrences of type family applications within the arguments. This function +-- will not consider the 'TyCon' itself when checking for type family +-- applications. +-- +-- See 'tcTyFamInstsAndVis' for more details on how this works (as this +-- function is called inside of 'tcTyFamInstsAndVis'). +tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])] +tcTyConAppTyFamInstsAndVis = tcTyConAppTyFamInstsAndVisX False + +tcTyConAppTyFamInstsAndVisX + :: Bool -- ^ Is this an invisible argument to some type application? + -> TyCon -> [Type] -> [(Bool, TyCon, [Type])] +tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys = + let (invis_tys, vis_tys) = partitionInvisibleTypes tc tys + in concat $ map (tcTyFamInstsAndVisX True) invis_tys + ++ map (tcTyFamInstsAndVisX is_invis_arg) vis_tys + +isTyFamFree :: Type -> Bool +-- ^ Check that a type does not contain any type family applications. +isTyFamFree = null . tcTyFamInsts + +anyRewritableTyVar :: Bool -- Ignore casts and coercions + -> EqRel -- Ambient role + -> (EqRel -> TcTyVar -> Bool) + -> TcType -> Bool +-- (anyRewritableTyVar ignore_cos pred ty) returns True +-- if the 'pred' returns True of any free TyVar in 'ty' +-- Do not look inside casts and coercions if 'ignore_cos' is True +-- See Note [anyRewritableTyVar must be role-aware] +anyRewritableTyVar ignore_cos role pred ty + = go role emptyVarSet ty + where + -- NB: No need to expand synonyms, because we can find + -- all free variables of a synonym by looking at its + -- arguments + + go_tv rl bvs tv | tv `elemVarSet` bvs = False + | otherwise = pred rl tv + + go rl bvs (TyVarTy tv) = go_tv rl bvs tv + go _ _ (LitTy {}) = False + go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys + go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg + go rl bvs (FunTy _ w arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || + go rl bvs arg || go rl bvs res || go NomEq bvs w + where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 + res_rep = getRuntimeRep res + go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty + go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co + go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check + + go_tc NomEq bvs _ tys = any (go NomEq bvs) tys + go_tc ReprEq bvs tc tys = any (go_arg bvs) + (tyConRolesRepresentational tc `zip` tys) + + go_arg bvs (Nominal, ty) = go NomEq bvs ty + go_arg bvs (Representational, ty) = go ReprEq bvs ty + go_arg _ (Phantom, _) = False -- We never rewrite with phantoms + + go_co rl bvs co + | ignore_cos = False + | otherwise = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co) + -- We don't have an equivalent of anyRewritableTyVar for coercions + -- (at least not yet) so take the free vars and test them + +{- Note [anyRewritableTyVar must be role-aware] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +anyRewritableTyVar is used during kick-out from the inert set, +to decide if, given a new equality (a ~ ty), we should kick out +a constraint C. Rather than gather free variables and see if 'a' +is among them, we instead pass in a predicate; this is just efficiency. + +Moreover, consider + work item: [G] a ~R f b + inert item: [G] b ~R f a +We use anyRewritableTyVar to decide whether to kick out the inert item, +on the grounds that the work item might rewrite it. Well, 'a' is certainly +free in [G] b ~R f a. But because the role of a type variable ('f' in +this case) is nominal, the work item can't actually rewrite the inert item. +Moreover, if we were to kick out the inert item the exact same situation +would re-occur and we end up with an infinite loop in which each kicks +out the other (#14363). +-} + +{- ********************************************************************* +* * + The "exact" free variables of a type +* * +********************************************************************* -} + +{- Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! + +exactTyCoVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It only matters +occasionally -- see the calls to exactTyCoVarsOfType. + +We place this function here in GHC.Tc.Utils.TcType, not in GHC.Core.TyCo.FVs, +because we want to "see" tcView (efficiency issue only). +-} + +exactTyCoVarsOfType :: Type -> TyCoVarSet +exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. + +exactTyCoVarsOfType ty = runTyCoVars (exact_ty ty) +exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys) + +exact_ty :: Type -> Endo TyCoVarSet +exact_tys :: [Type] -> Endo TyCoVarSet +(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet + +exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +exactTcvFolder = deepTcvFolder { tcf_view = tcView } + -- This is the key line + +{- +************************************************************************ +* * + Predicates +* * +************************************************************************ +-} + +tcIsTcTyVar :: TcTyVar -> Bool +-- See Note [TcTyVars and TyVars in the typechecker] +tcIsTcTyVar tv = isTyVar tv + +isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool +isTouchableMetaTyVar ctxt_tclvl tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv + , not (isFlattenInfo info) + = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, + ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) + tv_tclvl `sameDepthAs` ctxt_tclvl + + | otherwise = False + +isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool +isFloatedTouchableMetaTyVar ctxt_tclvl tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv + , not (isFlattenInfo info) + = tv_tclvl `strictlyDeeperThan` ctxt_tclvl + + | otherwise = False + +isImmutableTyVar :: TyVar -> Bool +isImmutableTyVar tv = isSkolemTyVar tv + +isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, + isMetaTyVar, isAmbiguousTyVar, + isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool + +isTyConableTyVar tv + -- True of a meta-type variable that can be filled in + -- with a type constructor application; in particular, + -- not a TyVarTv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv { mtv_info = TyVarTv } -> False + _ -> True + | otherwise = True + +isFmvTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = FlatMetaTv } -> True + _ -> False + +isFskTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = FlatSkolTv } -> True + _ -> False + +-- | True of both given and wanted flatten-skolems (fmv and fsk) +isFlattenTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> isFlattenInfo info + _ -> False + +isSkolemTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv {} -> False + _other -> True + +isOverlappableTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + SkolemTv _ overlappable -> overlappable + _ -> False + | otherwise = False + +isMetaTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv {} -> True + _ -> False + | otherwise = False + +-- isAmbiguousTyVar is used only when reporting type errors +-- It picks out variables that are unbound, namely meta +-- type variables and the RuntimUnk variables created by +-- GHC.Runtime.Heap.Inspect.zonkRTTIType. These are "ambiguous" in +-- the sense that they stand for an as-yet-unknown type +isAmbiguousTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv {} -> True + RuntimeUnk {} -> True + _ -> False + | otherwise = False + +isMetaTyVarTy :: TcType -> Bool +isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv +isMetaTyVarTy _ = False + +metaTyVarInfo :: TcTyVar -> MetaInfo +metaTyVarInfo tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> info + _ -> pprPanic "metaTyVarInfo" (ppr tv) + +isFlattenInfo :: MetaInfo -> Bool +isFlattenInfo FlatMetaTv = True +isFlattenInfo FlatSkolTv = True +isFlattenInfo _ = False + +metaTyVarTcLevel :: TcTyVar -> TcLevel +metaTyVarTcLevel tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> tclvl + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel +metaTyVarTcLevel_maybe tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> Just tclvl + _ -> Nothing + +metaTyVarRef :: TyVar -> IORef MetaDetails +metaTyVarRef tv + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } -> ref + _ -> pprPanic "metaTyVarRef" (ppr tv) + +setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar +setMetaTyVarTcLevel tv tclvl + = case tcTyVarDetails tv of + details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +isTyVarTyVar :: Var -> Bool +isTyVarTyVar tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = TyVarTv } -> True + _ -> False + +isFlexi, isIndirect :: MetaDetails -> Bool +isFlexi Flexi = True +isFlexi _ = False + +isIndirect (Indirect _) = True +isIndirect _ = False + +isRuntimeUnkSkol :: TyVar -> Bool +-- Called only in GHC.Tc.Errors; see Note [Runtime skolems] there +isRuntimeUnkSkol x + | RuntimeUnk <- tcTyVarDetails x = True + | otherwise = False + +mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)] +-- Just pair each TyVar with its own name +mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs] + +findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)] +-- If we have [...(x1,tv)...(x2,tv)...] +-- return (x1,x2) in the result list +findDupTyVarTvs prs + = concatMap mk_result_prs $ + findDupsEq eq_snd prs + where + eq_snd (_,tv1) (_,tv2) = tv1 == tv2 + mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs + +{- +************************************************************************ +* * + Tau, sigma and rho +* * +************************************************************************ +-} + +mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type +mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) + +-- | Make a sigma ty where all type variables are 'Inferred'. That is, +-- they cannot be used with visible type application. +mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type +mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty + +-- | Make a sigma ty where all type variables are "specified". That is, +-- they can be used with visible type application +mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type +mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty + +mkPhiTy :: [PredType] -> Type -> Type +mkPhiTy = mkInvisFunTysMany + +--------------- +getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to + -- construct a dictionary function name +getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LitTy x) = getDFunTyLitKey x +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (FunTy {}) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey (CastTy ty _) = getDFunTyKey ty +getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) + +getDFunTyLitKey :: TyLit -> OccName +getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) +getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm + +{- ********************************************************************* +* * + Building types +* * +********************************************************************* -} + +-- ToDo: I think we need Tc versions of these +-- Reason: mkCastTy checks isReflexiveCastTy, which checks +-- for equality; and that has a different answer +-- depending on whether or not Type = Constraint + +mkTcAppTys :: Type -> [Type] -> Type +mkTcAppTys = mkAppTys + +mkTcAppTy :: Type -> Type -> Type +mkTcAppTy = mkAppTy + +mkTcCastTy :: Type -> Coercion -> Type +mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy? + +{- +************************************************************************ +* * + Expanding and splitting +* * +************************************************************************ + +These tcSplit functions are like their non-Tc analogues, but + *) they do not look through newtypes + +However, they are non-monadic and do not follow through mutable type +variables. It's up to you to make sure this doesn't matter. +-} + +-- | Splits a forall type into a list of 'TyBinder's and the inner type. +-- Always succeeds, even if it returns an empty list. +tcSplitPiTys :: Type -> ([TyBinder], Type) +tcSplitPiTys ty + = ASSERT( all isTyBinder (fst sty) ) sty + where sty = splitPiTys ty + +-- | Splits a type into a TyBinder and a body, if possible. Panics otherwise +tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) +tcSplitPiTy_maybe ty + = ASSERT( isMaybeTyBinder sty ) sty + where + sty = splitPiTy_maybe ty + isMaybeTyBinder (Just (t,_)) = isTyBinder t + isMaybeTyBinder _ = True + +tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) +tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty' +tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty) +tcSplitForAllTy_maybe _ = Nothing + +-- | Like 'tcSplitPiTys', but splits off only named binders, +-- returning just the tycovars. +tcSplitForAllTys :: Type -> ([TyVar], Type) +tcSplitForAllTys ty + = ASSERT( all isTyVar (fst sty) ) sty + where sty = splitForAllTys ty + +-- | Like 'tcSplitForAllTys', but only splits 'ForAllTy's with 'Required' type +-- variable binders. All split tyvars are annotated with '()'. +tcSplitForAllTysReq :: Type -> ([TcReqTVBinder], Type) +tcSplitForAllTysReq ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty + where sty = splitForAllTysReq ty + +-- | Like 'tcSplitForAllTys', but only splits 'ForAllTy's with 'Invisible' type +-- variable binders. All split tyvars are annotated with their 'Specificity'. +tcSplitForAllTysInvis :: Type -> ([TcInvisTVBinder], Type) +tcSplitForAllTysInvis ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty + where sty = splitForAllTysInvis ty + +-- | Like 'tcSplitForAllTys', but splits off only named binders. +tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type) +tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty + where sty = splitForAllVarBndrs ty + +-- | Is this a ForAllTy with a named binder? +tcIsForAllTy :: Type -> Bool +tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' +tcIsForAllTy (ForAllTy {}) = True +tcIsForAllTy _ = False + +tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) +-- Split off the first predicate argument from a type +tcSplitPredFunTy_maybe ty + | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg + , ft_arg = arg, ft_res = res }) + = Just (arg, res) +tcSplitPredFunTy_maybe _ + = Nothing + +tcSplitPhiTy :: Type -> (ThetaType, Type) +tcSplitPhiTy ty + = split ty [] + where + split ty ts + = case tcSplitPredFunTy_maybe ty of + Just (pred, ty) -> split ty (pred:ts) + Nothing -> (reverse ts, ty) + +-- | Split a sigma type into its parts. +tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) +tcSplitSigmaTy ty = case tcSplitForAllTys ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + +-- | Split a sigma type into its parts, going underneath as many @ForAllTy@s +-- as possible. For example, given this type synonym: +-- +-- @ +-- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t +-- @ +-- +-- if you called @tcSplitSigmaTy@ on this type: +-- +-- @ +-- forall s t a b. Each s t a b => Traversal s t a b +-- @ +-- +-- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But +-- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return +-- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@. +tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) +-- NB: This is basically a pure version of topInstantiate (from Inst) that +-- doesn't compute an HsWrapper. +tcSplitNestedSigmaTys ty + -- If there's a forall, split it apart and try splitting the rho type + -- underneath it. + | (tvs1, theta1, rho1) <- tcSplitSigmaTy ty + , not (null tvs1 && null theta1) + = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 + in (tvs1 ++ tvs2, theta1 ++ theta2, rho2) + -- If there's no forall, we're done. + | otherwise = ([], [], ty) + +----------------------- +tcTyConAppTyCon :: Type -> TyCon +tcTyConAppTyCon ty + = case tcTyConAppTyCon_maybe ty of + Just tc -> tc + Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) + +-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. +tcTyConAppTyCon_maybe :: Type -> Maybe TyCon +tcTyConAppTyCon_maybe ty + | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' +tcTyConAppTyCon_maybe (TyConApp tc _) + = Just tc +tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg }) + = Just funTyCon -- (=>) is /not/ a TyCon in its own right + -- C.f. tcRepSplitAppTy_maybe +tcTyConAppTyCon_maybe _ + = Nothing + +tcTyConAppArgs :: Type -> [Type] +tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of + Just (_, args) -> args + Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) + +tcSplitTyConApp :: Type -> (TyCon, [Type]) +tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) + +----------------------- +tcSplitFunTys :: Type -> ([Scaled Type], Type) +tcSplitFunTys ty = case tcSplitFunTy_maybe ty of + Nothing -> ([], ty) + Just (arg,res) -> (arg:args, res') + where + (args,res') = tcSplitFunTys res + +tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type) +tcSplitFunTy_maybe ty + | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' +tcSplitFunTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | VisArg <- af = Just (Scaled w arg, res) +tcSplitFunTy_maybe _ = Nothing + -- Note the VisArg guard + -- Consider (?x::Int) => Bool + -- We don't want to treat this as a function type! + -- A concrete example is test tc230: + -- f :: () -> (?p :: ()) => () -> () + -- + -- g = f () () + +tcSplitFunTysN :: Arity -- n: Number of desired args + -> TcRhoType + -> Either Arity -- Number of missing arrows + ([Scaled TcSigmaType],-- Arg types (always N types) + TcSigmaType) -- The rest of the type +-- ^ Split off exactly the specified number argument types +-- Returns +-- (Left m) if there are 'm' missing arrows in the type +-- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res +tcSplitFunTysN n ty + | n == 0 + = Right ([], ty) + | Just (arg,res) <- tcSplitFunTy_maybe ty + = case tcSplitFunTysN (n-1) res of + Left m -> Left m + Right (args,body) -> Right (arg:args, body) + | otherwise + = Left n + +tcSplitFunTy :: Type -> (Scaled Type, Type) +tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) + +tcFunArgTy :: Type -> Scaled Type +tcFunArgTy ty = fst (tcSplitFunTy ty) + +tcFunResultTy :: Type -> Type +tcFunResultTy ty = snd (tcSplitFunTy ty) + +-- | Strips off n *visible* arguments and returns the resulting type +tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type +tcFunResultTyN n ty + | Right (_, res_ty) <- tcSplitFunTysN n ty + = res_ty + | otherwise + = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) + +----------------------- +tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) +tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' +tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty + +tcSplitAppTy :: Type -> (Type, Type) +tcSplitAppTy ty = case tcSplitAppTy_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitAppTy" (pprType ty) + +tcSplitAppTys :: Type -> (Type, [Type]) +tcSplitAppTys ty + = go ty [] + where + go ty args = case tcSplitAppTy_maybe ty of + Just (ty', arg) -> go ty' (arg:args) + Nothing -> (ty,args) + +-- | Returns the number of arguments in the given type, without +-- looking through synonyms. This is used only for error reporting. +-- We don't look through synonyms because of #11313. +tcRepGetNumAppTys :: Type -> Arity +tcRepGetNumAppTys = length . snd . repSplitAppTys + +----------------------- +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind type +tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty' +tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) +tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv)) +tcGetCastedTyVar_maybe _ = Nothing + +tcGetTyVar_maybe :: Type -> Maybe TyVar +tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' +tcGetTyVar_maybe (TyVarTy tv) = Just tv +tcGetTyVar_maybe _ = Nothing + +tcGetTyVar :: String -> Type -> TyVar +tcGetTyVar msg ty + = case tcGetTyVar_maybe ty of + Just tv -> tv + Nothing -> pprPanic msg (ppr ty) + +tcIsTyVarTy :: Type -> Bool +tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' +tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as + -- this is only used for + -- e.g., FlexibleContexts +tcIsTyVarTy (TyVarTy _) = True +tcIsTyVarTy _ = False + +----------------------- +tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) +-- Split the type of a dictionary function +-- We don't use tcSplitSigmaTy, because a DFun may (with NDP) +-- have non-Pred arguments, such as +-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m +-- +-- Also NB splitFunTys, not tcSplitFunTys; +-- the latter specifically stops at PredTy arguments, +-- and we don't want to do that here +tcSplitDFunTy ty + = case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, tau) -> + case tcSplitDFunHead tau of { (clas, tys) -> + (tvs, map scaledThing theta, clas, tys) }}} + +tcSplitDFunHead :: Type -> (Class, [Type]) +tcSplitDFunHead = getClassPredTys + +tcSplitMethodTy :: Type -> ([TyVar], PredType, Type) +-- A class method (selector) always has a type like +-- forall as. C as => blah +-- So if the class looks like +-- class C a where +-- op :: forall b. (Eq a, Ix b) => a -> b +-- the class method type looks like +-- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b +-- +-- tcSplitMethodTy just peels off the outer forall and +-- that first predicate +tcSplitMethodTy ty + | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty + , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho + = (sel_tyvars, first_pred, local_meth_ty) + | otherwise + = pprPanic "tcSplitMethodTy" (ppr ty) + + +{- ********************************************************************* +* * + Type equalities +* * +********************************************************************* -} + +tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool +tcEqKind = tcEqType + +tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool +-- tcEqType is a proper implements the same Note [Non-trivial definitional +-- equality] (in GHC.Core.TyCo.Rep) as `eqType`, but Type.eqType believes (* == +-- Constraint), and that is NOT what we want in the type checker! +tcEqType ty1 ty2 + = tc_eq_type False False ki1 ki2 + && tc_eq_type False False ty1 ty2 + where + ki1 = tcTypeKind ty1 + ki2 = tcTypeKind ty2 + +-- | Just like 'tcEqType', but will return True for types of different kinds +-- as long as their non-coercion structure is identical. +tcEqTypeNoKindCheck :: TcType -> TcType -> Bool +tcEqTypeNoKindCheck ty1 ty2 + = tc_eq_type False False ty1 ty2 + +-- | Like 'tcEqType', but returns True if the /visible/ part of the types +-- are equal, even if they are really unequal (in the invisible bits) +tcEqTypeVis :: TcType -> TcType -> Bool +tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 + +-- | Like 'pickyEqTypeVis', but returns a Bool for convenience +pickyEqType :: TcType -> TcType -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +-- This ignores kinds and coercions, because this is used only for printing. +pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 + + + +-- | Real worker for 'tcEqType'. No kind check! +tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms + -> Bool -- ^ True <=> compare visible args only + -> Type -> Type + -> Bool +-- Flags False, False is the usual setting for tc_eq_type +tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 + = go orig_env orig_ty1 orig_ty2 + where + go :: RnEnv2 -> Type -> Type -> Bool + go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2 + go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = rnOccL env tv1 == rnOccR env tv2 + + go _ (LitTy lit1) (LitTy lit2) + = lit1 == lit2 + + go env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = vis1 == vis2 + && (vis_only || go env (varType tv1) (varType tv2)) + && go (rnBndr2 env tv1 tv2) ty1 ty2 + + -- Make sure we handle all FunTy cases since falling through to the + -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked + -- kind variable, which causes things to blow up. + go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) + = go env w1 w2 && go env arg1 arg2 && go env res1 res2 + go env ty (FunTy _ w arg res) = eqFunTy env w arg res ty + go env (FunTy _ w arg res) ty = eqFunTy env w arg res ty + + -- See Note [Equality on AppTys] in GHC.Core.Type + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 + = go env s1 s2 && go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 + = go env s1 s2 && go env t1 t2 + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 + + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go _ _ _ = False + + gos _ _ [] [] = True + gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) + && gos env igs ts1 ts2 + gos _ _ _ _ = False + + tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore + tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles + | otherwise = repeat False -- Ignore nothing + -- The repeat False is necessary because tycons + -- can legitimately be oversaturated + where + bndrs = tyConBinders tc + inviss = map isInvisibleTyConBinder bndrs + + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + + -- @eqFunTy w arg res ty@ is True when @ty@ equals @FunTy w arg res@. This is + -- sometimes hard to know directly because @ty@ might have some casts + -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't + -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or + -- res is unzonked/unflattened. Thus this function, which handles this + -- corner case. + eqFunTy :: RnEnv2 -> Mult -> Type -> Type -> Type -> Bool + -- Last arg is /not/ FunTy + eqFunTy env w arg res ty@(AppTy{}) = get_args ty [] + where + get_args :: Type -> [Type] -> Bool + get_args (AppTy f x) args = get_args f (x:args) + get_args (CastTy t _) args = get_args t args + get_args (TyConApp tc tys) args + | tc == funTyCon + , [w', _, _, arg', res'] <- tys ++ args + = go env w w' && go env arg arg' && go env res res' + get_args _ _ = False + eqFunTy _ _ _ _ _ = False + +{- ********************************************************************* +* * + Predicate types +* * +************************************************************************ + +Deconstructors and tests on predicate types + +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + class C f where... -- C :: forall k. k -> Constraint + g :: forall (f::*). C f => f -> f + +Here the (C f) in the signature is really (C * f), and we +don't want to complain that the * isn't a type variable! +-} + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred ty = case getClassPredTys_maybe ty of + Just (_, tys) -> all isTyVarTy tys + _ -> False + +------------------------- +checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool +-- If the Bool is True (flexible contexts), return True (i.e. ok) +-- Otherwise, check that the type (not kind) args are all headed by a tyvar +-- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected +-- This function is here rather than in GHC.Tc.Validity because it is +-- called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity +checkValidClsArgs flexible_contexts cls kts + | flexible_contexts = True + | otherwise = all hasTyVarHead tys + where + tys = filterOutInvisibleTypes (classTyCon cls) kts + +hasTyVarHead :: Type -> Bool +-- Returns true of (a t1 .. tn), where 'a' is a type variable +hasTyVarHead ty -- Haskell 98 allows predicates of form + | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) + | otherwise -- where a is a type variable + = case tcSplitAppTy_maybe ty of + Just (ty, _) -> hasTyVarHead ty + Nothing -> False + +evVarPred :: EvVar -> PredType +evVarPred var = varType var + -- Historical note: I used to have an ASSERT here, + -- checking (isEvVarType (varType var)). But with something like + -- f :: c => _ -> _ + -- we end up with (c :: kappa), and (kappa ~ Constraint). Until + -- we solve and zonk (which there is no particular reason to do for + -- partial signatures, (isEvVarType kappa) will return False. But + -- nothing is wrong. So I just removed the ASSERT. + +------------------ +-- | When inferring types, should we quantify over a given predicate? +-- Generally true of classes; generally false of equality constraints. +-- Equality constraints that mention quantified type variables and +-- implicit variables complicate the story. See Notes +-- [Inheriting implicit parameters] and [Quantifying over equality constraints] +pickQuantifiablePreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- This function decides whether a particular constraint should be +-- quantified over, given the type variables that are being quantified +pickQuantifiablePreds qtvs theta + = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without + -- -XFlexibleContexts: see #10608, #10351 + -- flex_ctxt <- xoptM Opt_FlexibleContexts + mapMaybe (pick_me flex_ctxt) theta + where + pick_me flex_ctxt pred + = case classifyPredType pred of + + ClassPred cls tys + | Just {} <- isCallStackPred cls tys + -- NEVER infer a CallStack constraint. Otherwise we let + -- the constraints bubble up to be solved from the outer + -- context, or be defaulted when we reach the top-level. + -- See Note [Overview of implicit CallStacks] + -> Nothing + + | isIPClass cls + -> Just pred -- See note [Inheriting implicit parameters] + + | pick_cls_pred flex_ctxt cls tys + -> Just pred + + EqPred eq_rel ty1 ty2 + | quantify_equality eq_rel ty1 ty2 + , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 + -- boxEqPred: See Note [Lift equality constraints when quantifying] + , pick_cls_pred flex_ctxt cls tys + -> Just (mkClassPred cls tys) + + IrredPred ty + | tyCoVarsOfType ty `intersectsVarSet` qtvs + -> Just pred + + _ -> Nothing + + + pick_cls_pred flex_ctxt cls tys + = tyCoVarsOfTypes tys `intersectsVarSet` qtvs + && (checkValidClsArgs flex_ctxt cls tys) + -- Only quantify over predicates that checkValidType + -- will pass! See #10351. + + -- See Note [Quantifying over equality constraints] + quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 + quantify_equality ReprEq _ _ = True + + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) | isTypeFamilyTyCon tc + -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs + _ -> False + +boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) +-- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version +-- (t1 ~ t2) or (t1 `Coercible` t2) +boxEqPred eq_rel ty1 ty2 + = case eq_rel of + NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) + | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) + ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) + | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible + -- so we can't abstract over it + -- Nothing fundamental: we could add it + where + k1 = tcTypeKind ty1 + k2 = tcTypeKind ty2 + homo_kind = k1 `tcEqType` k2 + +pickCapturedPreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- A simpler version of pickQuantifiablePreds, used to winnow down +-- the inferred constraints of a group of bindings, into those for +-- one particular identifier +pickCapturedPreds qtvs theta + = filter captured theta + where + captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) + + +-- Superclasses + +type PredWithSCs a = (PredType, [PredType], a) + +mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a] +-- Remove predicates that +-- +-- - are the same as another predicate +-- +-- - can be deduced from another by superclasses, +-- +-- - are a reflexive equality (e.g * ~ *) +-- (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn) +-- +-- The result is a subset of the input. +-- The 'a' is just paired up with the PredType; +-- typically it might be a dictionary Id +mkMinimalBySCs get_pred xs = go preds_with_scs [] + where + preds_with_scs :: [PredWithSCs a] + preds_with_scs = [ (pred, pred : transSuperClasses pred, x) + | x <- xs + , let pred = get_pred x ] + + go :: [PredWithSCs a] -- Work list + -> [PredWithSCs a] -- Accumulating result + -> [a] + go [] min_preds + = reverse (map thdOf3 min_preds) + -- The 'reverse' isn't strictly necessary, but it + -- means that the results are returned in the same + -- order as the input, which is generally saner + go (work_item@(p,_,_) : work_list) min_preds + | EqPred _ t1 t2 <- classifyPredType p + , t1 `tcEqType` t2 -- See GHC.Tc.TyCl.PatSyn + -- Note [Remove redundant provided dicts] + = go work_list min_preds + | p `in_cloud` work_list || p `in_cloud` min_preds + = go work_list min_preds + | otherwise + = go work_list (work_item : min_preds) + + in_cloud :: PredType -> [PredWithSCs a] -> Bool + in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ] + +transSuperClasses :: PredType -> [PredType] +-- (transSuperClasses p) returns (p's superclasses) not including p +-- Stop if you encounter the same class again +-- See Note [Expanding superclasses] +transSuperClasses p + = go emptyNameSet p + where + go :: NameSet -> PredType -> [PredType] + go rec_clss p + | ClassPred cls tys <- classifyPredType p + , let cls_nm = className cls + , not (cls_nm `elemNameSet` rec_clss) + , let rec_clss' | isCTupleClass cls = rec_clss + | otherwise = rec_clss `extendNameSet` cls_nm + = [ p' | sc <- immSuperClasses cls tys + , p' <- sc : go rec_clss' sc ] + | otherwise + = [] + +immSuperClasses :: Class -> [Type] -> [PredType] +immSuperClasses cls tys + = substTheta (zipTvSubst tyvars tys) sc_theta + where + (tyvars,sc_theta,_,_) = classBigSig cls + +isImprovementPred :: PredType -> Bool +-- Either it's an equality, or has some functional dependency +isImprovementPred ty + = case classifyPredType ty of + EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) + EqPred ReprEq _ _ -> False + ClassPred cls _ -> classHasFds cls + IrredPred {} -> True -- Might have equalities after reduction? + ForAllPred {} -> False + +-- | Is the equality +-- a ~r ...a.... +-- definitely insoluble or not? +-- a ~r Maybe a -- Definitely insoluble +-- a ~N ...(F a)... -- Not definitely insoluble +-- -- Perhaps (F a) reduces to Int +-- a ~R ...(N a)... -- Not definitely insoluble +-- -- Perhaps newtype N a = MkN Int +-- See Note [Occurs check error] in +-- "GHC.Tc.Solver.Canonical" for the motivation for this function. +isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool +isInsolubleOccursCheck eq_rel tv ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' + go (TyVarTy tv') = tv == tv' || go (tyVarKind tv') + go (LitTy {}) = False + go (AppTy t1 t2) = case eq_rel of -- See Note [AppTy and ReprEq] + NomEq -> go t1 || go t2 + ReprEq -> go t1 + go (FunTy _ w t1 t2) = go w || go t1 || go t2 + go (ForAllTy (Bndr tv' _) inner_ty) + | tv' == tv = False + | otherwise = go (varType tv') || go inner_ty + go (CastTy ty _) = go ty -- ToDo: what about the coercion + go (CoercionTy _) = False -- ToDo: what about the coercion + go (TyConApp tc tys) + | isGenerativeTyCon tc role = any go tys + | otherwise = any go (drop (tyConArity tc) tys) + -- (a ~ F b a), where F has arity 1, + -- has an insoluble occurs check + + role = eqRelRole eq_rel + +{- Note [Expanding superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we expand superclasses, we use the following algorithm: + +transSuperClasses( C tys ) returns the transitive superclasses + of (C tys), not including C itself + +For example + class C a b => D a b + class D b a => C a b + +Then + transSuperClasses( Ord ty ) = [Eq ty] + transSuperClasses( C ta tb ) = [D tb ta, C tb ta] + +Notice that in the recursive-superclass case we include C again at +the end of the chain. One could exclude C in this case, but +the code is more awkward and there seems no good reason to do so. +(However C.f. GHC.Tc.Solver.Canonical.mk_strict_superclasses, which /does/ +appear to do so.) + +The algorithm is expand( so_far, pred ): + + 1. If pred is not a class constraint, return empty set + Otherwise pred = C ts + 2. If C is in so_far, return empty set (breaks loops) + 3. Find the immediate superclasses constraints of (C ts) + 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss ) + +Notice that + + * With normal Haskell-98 classes, the loop-detector will never bite, + so we'll get all the superclasses. + + * We need the loop-breaker in case we have UndecidableSuperClasses on + + * Since there is only a finite number of distinct classes, expansion + must terminate. + + * The loop breaking is a bit conservative. Notably, a tuple class + could contain many times without threatening termination: + (Eq a, (Ord a, Ix a)) + And this is try of any class that we can statically guarantee + as non-recursive (in some sense). For now, we just make a special + case for tuples. Something better would be cool. + +See also GHC.Tc.TyCl.Utils.checkClassCycles. + +Note [Lift equality constraints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't quantify over a constraint (t1 ~# t2) because that isn't a +predicate type; see Note [Types for coercions, predicates, and evidence] +in GHC.Core.TyCo.Rep. + +So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted +to Coercible. + +This tiresome lifting is the reason that pick_me (in +pickQuantifiablePreds) returns a Maybe rather than a Bool. + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t)? In general, we don't. +Doing so may simply postpone a type error from the function definition site to +its call site. (At worst, imagine (Int ~ Bool)). + +However, consider this + forall a. (F [a] ~ Int) => blah +Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call +site we will know 'a', and perhaps we have instance F [Bool] = Int. +So we *do* quantify over a type-family equality where the arguments mention +the quantified variables. + +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f x = (x::Int) + ?y + +where f is *not* a top-level binding. +From the RHS of f we'll get the constraint (?y::Int). +There are two types we might infer for f: + + f :: Int -> Int + +(so we get ?y from the context of f's definition), or + + f :: (?y::Int) => Int -> Int + +At first you might think the first was better, because then +?y behaves like a free variable of the definition, rather than +having to be passed at each call site. But of course, the WHOLE +IDEA is that ?y should be passed at each call site (that's what +dynamic binding means) so we'd better infer the second. + +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See pickQuantifiablePreds. + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t)? In general, we don't. +Doing so may simply postpone a type error from the function definition site to +its call site. (At worst, imagine (Int ~ Bool)). + +However, consider this + forall a. (F [a] ~ Int) => blah +Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call +site we will know 'a', and perhaps we have instance F [Bool] = Int. +So we *do* quantify over a type-family equality where the arguments mention +the quantified variables. + +************************************************************************ +* * + Classifying types +* * +************************************************************************ +-} + +isSigmaTy :: TcType -> Bool +-- isSigmaTy returns true of any qualified type. It doesn't +-- *necessarily* have any foralls. E.g +-- f :: (?x::Int) => Int -> Int +isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' +isSigmaTy (ForAllTy {}) = True +isSigmaTy (FunTy { ft_af = InvisArg }) = True +isSigmaTy _ = False + +isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] +isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' +isRhoTy (ForAllTy {}) = False +isRhoTy (FunTy { ft_af = InvisArg }) = False +isRhoTy _ = True + +-- | Like 'isRhoTy', but also says 'True' for 'Infer' types +isRhoExpTy :: ExpType -> Bool +isRhoExpTy (Check ty) = isRhoTy ty +isRhoExpTy (Infer {}) = True + +isOverloadedTy :: Type -> Bool +-- Yes for a type of a function that might require evidence-passing +-- Used only by bindLocalMethods +isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' +isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty +isOverloadedTy (FunTy { ft_af = InvisArg }) = True +isOverloadedTy _ = False + +isFloatTy, isDoubleTy, isIntegerTy, isNaturalTy, + isIntTy, isWordTy, isBoolTy, + isUnitTy, isCharTy, isAnyTy :: Type -> Bool +isFloatTy = is_tc floatTyConKey +isDoubleTy = is_tc doubleTyConKey +isIntegerTy = is_tc integerTyConKey +isNaturalTy = is_tc naturalTyConKey +isIntTy = is_tc intTyConKey +isWordTy = is_tc wordTyConKey +isBoolTy = is_tc boolTyConKey +isUnitTy = is_tc unitTyConKey +isCharTy = is_tc charTyConKey +isAnyTy = is_tc anyTyConKey + +-- | Does a type represent a floating-point number? +isFloatingTy :: Type -> Bool +isFloatingTy ty = isFloatTy ty || isDoubleTy ty + +-- | Is a type 'String'? +isStringTy :: Type -> Bool +isStringTy ty + = case tcSplitTyConApp_maybe ty of + Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty + _ -> False + +-- | Is a type a 'CallStack'? +isCallStackTy :: Type -> Bool +isCallStackTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` callStackTyConKey + | otherwise + = False + +-- | Is a 'PredType' a 'CallStack' implicit parameter? +-- +-- If so, return the name of the parameter. +isCallStackPred :: Class -> [Type] -> Maybe FastString +isCallStackPred cls tys + | [ty1, ty2] <- tys + , isIPClass cls + , isCallStackTy ty2 + = isStrLitTy ty1 + | otherwise + = Nothing + +is_tc :: Unique -> Type -> Bool +-- Newtypes are opaque to this +is_tc uniq ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> uniq == getUnique tc + Nothing -> False + +-- | Does the given tyvar appear at the head of a chain of applications +-- (a t1 ... tn) +isTyVarHead :: TcTyVar -> TcType -> Bool +isTyVarHead tv (TyVarTy tv') = tv == tv' +isTyVarHead tv (AppTy fun _) = isTyVarHead tv fun +isTyVarHead tv (CastTy ty _) = isTyVarHead tv ty +isTyVarHead _ (TyConApp {}) = False +isTyVarHead _ (LitTy {}) = False +isTyVarHead _ (ForAllTy {}) = False +isTyVarHead _ (FunTy {}) = False +isTyVarHead _ (CoercionTy {}) = False + + +{- Note [AppTy and ReprEq] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a ~R# b a + a ~R# a b + +The former is /not/ a definite error; we might instantiate 'b' with Id + newtype Id a = MkId a +but the latter /is/ a definite error. + +On the other hand, with nominal equality, both are definite errors +-} + +isRigidTy :: TcType -> Bool +isRigidTy ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal + | Just {} <- tcSplitAppTy_maybe ty = True + | isForAllTy ty = True + | otherwise = False + + +-- | Is this type *almost function-free*? See Note [Almost function-free] +-- in "GHC.Tc.Types" +isAlmostFunctionFree :: TcType -> Bool +isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty' +isAlmostFunctionFree (TyVarTy {}) = True +isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 && + isAlmostFunctionFree ty2 +isAlmostFunctionFree (TyConApp tc args) + | isTypeFamilyTyCon tc = False + | otherwise = all isAlmostFunctionFree args +isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr) +isAlmostFunctionFree (FunTy _ w ty1 ty2) = isAlmostFunctionFree w && + isAlmostFunctionFree ty1 && + isAlmostFunctionFree ty2 +isAlmostFunctionFree (LitTy {}) = True +isAlmostFunctionFree (CastTy ty _) = isAlmostFunctionFree ty +isAlmostFunctionFree (CoercionTy {}) = True + +{- +************************************************************************ +* * + Misc +* * +************************************************************************ + +Note [Visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC implements a generalisation of the algorithm described in the +"Visible Type Application" paper (available from +http://www.cis.upenn.edu/~sweirich/publications.html). A key part +of that algorithm is to distinguish user-specified variables from inferred +variables. For example, the following should typecheck: + + f :: forall a b. a -> b -> b + f = const id + + g = const id + + x = f @Int @Bool 5 False + y = g 5 @Bool False + +The idea is that we wish to allow visible type application when we are +instantiating a specified, fixed variable. In practice, specified, fixed +variables are either written in a type signature (or +annotation), OR are imported from another module. (We could do better here, +for example by doing SCC analysis on parts of a module and considering any +type from outside one's SCC to be fully specified, but this is very confusing to +users. The simple rule above is much more straightforward and predictable.) + +So, both of f's quantified variables are specified and may be instantiated. +But g has no type signature, so only id's variable is specified (because id +is imported). We write the type of g as forall {a}. a -> forall b. b -> b. +Note that the a is in braces, meaning it cannot be instantiated with +visible type application. + +Tracking specified vs. inferred variables is done conveniently by a field +in TyBinder. + +-} + +deNoteType :: Type -> Type +-- Remove all *outermost* type synonyms and other notes +deNoteType ty | Just ty' <- coreView ty = deNoteType ty' +deNoteType ty = ty + +{- +Find the free tycons and classes of a type. This is used in the front +end of the compiler. +-} + +{- +************************************************************************ +* * + External types +* * +************************************************************************ + +The compiler's foreign function interface supports the passing of a +restricted set of types as arguments and results (the restricting factor +being the ) +-} + +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) +-- (tcSplitIOType_maybe t) returns Just (IO,t',co) +-- if co : t ~ IO t' +-- returns Nothing otherwise +tcSplitIOType_maybe ty + = case tcSplitTyConApp_maybe ty of + Just (io_tycon, [io_res_ty]) + | io_tycon `hasKey` ioTyConKey -> + Just (io_tycon, io_res_ty) + _ -> + Nothing + +isFFITy :: Type -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty) + +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity +-- Checks for valid argument type for a 'foreign import' +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + +isFFIExternalTy :: Type -> Validity +-- Types that are allowed as arguments of a 'foreign export' +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty + +isFFIImportResultTy :: DynFlags -> Type -> Validity +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) ty + +isFFIExportResultTy :: Type -> Validity +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty + +isFFIDynTy :: Type -> Type -> Validity +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normaliseFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = IsValid + | otherwise + = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma + , text " Actual:" <+> ppr ty ]) + +isFFILabelTy :: Type -> Validity +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. +isFFILabelTy ty = checkRepTyCon ok ty + where + ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + = IsValid + | otherwise + = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") + +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types, or the well-known type +-- Any, which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. +isFFIPrimArgumentTy dflags ty + | isAnyTy ty = IsValid + | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Validity +-- Checks for valid result type for a 'foreign import prim' Currently +-- it must be an unlifted type, including unboxed tuples, unboxed +-- sums, or the well-known type Any. +isFFIPrimResultTy dflags ty + | isAnyTy ty = IsValid + | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + +isFunPtrTy :: Type -> Bool +isFunPtrTy ty + | Just (tc, [_]) <- splitTyConApp_maybe ty + = tc `hasKey` funPtrTyConKey + | otherwise + = False + +-- normaliseFfiType gets run before checkRepTyCon, so we don't +-- need to worry about looking through newtypes or type functions +-- here; that's already been taken care of. +checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity +checkRepTyCon check_tc ty + = case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) + | otherwise -> case check_tc tc of + IsValid -> IsValid + NotValid extra -> NotValid (msg $$ extra) + Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") + where + msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" + mk_nt_reason tc tys + | null tys = text "because its data constructor is not in scope" + | otherwise = text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + nt_fix = text "Possible fix: import the data constructor to bring it into scope" + +{- +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + +---------------------------------------------- +These chaps do the work; they are not exported +---------------------------------------------- +-} + +legalFEArgTyCon :: TyCon -> Validity +legalFEArgTyCon tc + -- It's illegal to make foreign exports that take unboxed + -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 + = boxedMarshalableTyCon tc + +legalFIResultTyCon :: DynFlags -> TyCon -> Validity +legalFIResultTyCon dflags tc + | tc == unitTyCon = IsValid + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Validity +legalFEResultTyCon tc + | tc == unitTyCon = IsValid + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity +-- Checks validity of types going from Haskell -> external world +legalOutgoingTyCon dflags _ tc + = marshalableTyCon dflags tc + +legalFFITyCon :: TyCon -> Validity +-- True for any TyCon that can possibly be an arg or result of an FFI call +legalFFITyCon tc + | isUnliftedTyCon tc = IsValid + | tc == unitTyCon = IsValid + | otherwise = boxedMarshalableTyCon tc + +marshalableTyCon :: DynFlags -> TyCon -> Validity +marshalableTyCon dflags tc + | isUnliftedTyCon tc + , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) + , not (null (tyConPrimRep tc)) -- Note [Marshalling void] + = validIfUnliftedFFITypes dflags + | otherwise + = boxedMarshalableTyCon tc + +boxedMarshalableTyCon :: TyCon -> Validity +boxedMarshalableTyCon tc + | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + ] + = IsValid + + | otherwise = NotValid empty + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity +-- Check args of 'foreign import prim', only allow simple unlifted types. +-- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since +-- currently they're of the wrong kind to use in function args anyway. +legalFIPrimArgTyCon dflags tc + | isUnliftedTyCon tc + , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) + = validIfUnliftedFFITypes dflags + | otherwise + = NotValid unlifted_only + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple and sum result types. +legalFIPrimResultTyCon dflags tc + | isUnliftedTyCon tc + , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc + || not (null (tyConPrimRep tc)) -- Note [Marshalling void] + = validIfUnliftedFFITypes dflags + + | otherwise + = NotValid unlifted_only + +unlifted_only :: MsgDoc +unlifted_only = text "foreign import prim only accepts simple unlifted types" + +validIfUnliftedFFITypes :: DynFlags -> Validity +validIfUnliftedFFITypes dflags + | xopt LangExt.UnliftedFFITypes dflags = IsValid + | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") + +{- +Note [Marshalling void] +~~~~~~~~~~~~~~~~~~~~~~~ +We don't treat State# (whose PrimRep is VoidRep) as marshalable. +In turn that means you can't write + foreign import foo :: Int -> State# RealWorld + +Reason: the back end falls over with panic "primRepHint:VoidRep"; + and there is no compelling reason to permit it +-} + +{- +************************************************************************ +* * + The "Paterson size" of a type +* * +************************************************************************ +-} + +{- +Note [Paterson conditions on PredTypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are considering whether *class* constraints terminate +(see Note [Paterson conditions]). Precisely, the Paterson conditions +would have us check that "the constraint has fewer constructors and variables +(taken together and counting repetitions) than the head.". + +However, we can be a bit more refined by looking at which kind of constraint +this actually is. There are two main tricks: + + 1. It seems like it should be OK not to count the tuple type constructor + for a PredType like (Show a, Eq a) :: Constraint, since we don't + count the "implicit" tuple in the ThetaType itself. + + In fact, the Paterson test just checks *each component* of the top level + ThetaType against the size bound, one at a time. By analogy, it should be + OK to return the size of the *largest* tuple component as the size of the + whole tuple. + + 2. Once we get into an implicit parameter or equality we + can't get back to a class constraint, so it's safe + to say "size 0". See #4200. + +NB: we don't want to detect PredTypes in sizeType (and then call +sizePred on them), or we might get an infinite loop if that PredType +is irreducible. See #5581. +-} + +type TypeSize = IntWithInf + +sizeType :: Type -> TypeSize +-- Size of a type: the number of variables and constructors +-- Ignore kinds altogether +sizeType = go + where + go ty | Just exp_ty <- tcView ty = go exp_ty + go (TyVarTy {}) = 1 + go (TyConApp tc tys) + | isTypeFamilyTyCon tc = infinity -- Type-family applications can + -- expand to any arbitrary size + | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 + -- Why filter out invisible args? I suppose any + -- size ordering is sound, but why is this better? + -- I came across this when investigating #14010. + go (LitTy {}) = 1 + go (FunTy _ w arg res) = go w + go arg + go res + 1 + go (AppTy fun arg) = go fun + go arg + go (ForAllTy (Bndr tv vis) ty) + | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 + | otherwise = go ty + 1 + go (CastTy ty _) = go ty + go (CoercionTy {}) = 0 + +sizeTypes :: [Type] -> TypeSize +sizeTypes tys = sum (map sizeType tys) + +----------------------------------------------------------------------------------- +----------------------------------------------------------------------------------- +----------------------- +-- | For every arg a tycon can take, the returned list says True if the argument +-- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to +-- allow for oversaturation. +tcTyConVisibilities :: TyCon -> [Bool] +tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True + where + tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) + tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc)) + +-- | If the tycon is applied to the types, is the next argument visible? +isNextTyConArgVisible :: TyCon -> [Type] -> Bool +isNextTyConArgVisible tc tys + = tcTyConVisibilities tc `getNth` length tys + +-- | Should this type be applied to a visible argument? +isNextArgVisible :: TcType -> Bool +isNextArgVisible ty + | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr + | otherwise = True + -- this second case might happen if, say, we have an unzonked TauTv. + -- But TauTvs can't range over types that take invisible arguments diff --git a/GHC/Tc/Utils/TcType.hs-boot b/GHC/Tc/Utils/TcType.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcType.hs-boot @@ -0,0 +1,8 @@ +module GHC.Tc.Utils.TcType where +import GHC.Utils.Outputable( SDoc ) + +data MetaDetails + +data TcTyVarDetails +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +vanillaSkolemTv :: TcTyVarDetails diff --git a/GHC/Tc/Utils/Unify.hs b/GHC/Tc/Utils/Unify.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Unify.hs @@ -0,0 +1,2081 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections, + ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Type subsumption and unification +module GHC.Tc.Utils.Unify ( + -- Full-blown subsumption + tcWrapResult, tcWrapResultO, tcWrapResultMono, + tcSkolemise, tcSkolemiseScoped, tcSkolemiseET, + tcSubType, tcSubTypeSigma, tcSubTypePat, + tcSubMult, + checkConstraints, checkTvConstraints, + buildImplicationFor, buildTvImplication, emitResidualTvConstraint, + + -- Various unifications + unifyType, unifyKind, + uType, promoteTcType, + swapOverTyVars, canSolveByUnification, + + -------------------------------- + -- Holes + tcInfer, + matchExpectedListTy, + matchExpectedTyConApp, + matchExpectedAppTy, + matchExpectedFunTys, + matchActualFunTysRho, matchActualFunTySigma, + matchExpectedFunKind, + + metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..) + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr( debugPprType ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Env +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Multiplicity +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Types.Name( isSystemName ) +import GHC.Tc.Utils.Instantiate +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Types.Basic +import GHC.Data.Bag +import GHC.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt +import GHC.Utils.Outputable as Outputable + +import Control.Monad +import Control.Arrow ( second ) + +{- +************************************************************************ +* * + matchExpected functions +* * +************************************************************************ + +Note [Herald for matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'herald' always looks like: + "The equation(s) for 'f' have" + "The abstraction (\x.e) takes" + "The section (+ x) expects" + "The function 'f' is applied to" + +This is used to construct a message of form + + The abstraction `\Just 1 -> ...' takes two arguments + but its type `Maybe a -> a' has only one + + The equation(s) for `f' have two arguments + but its type `Maybe a -> a' has only one + + The section `(f 3)' requires 'f' to take two arguments + but its type `Int -> Int' has only one + + The function 'f' is applied to two arguments + but its type `Int -> Int' has only one + +When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the +picture, we have a choice in deciding whether to count the type applications as +proper arguments: + + The function 'f' is applied to one visible type argument + and two value arguments + but its type `forall a. a -> a` has only one visible type argument + and one value argument + +Or whether to include the type applications as part of the herald itself: + + The expression 'f @Int' is applied to two arguments + but its type `Int -> Int` has only one + +The latter is easier to implement and is arguably easier to understand, so we +choose to implement that option. + +Note [matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchExpectedFunTys checks that a sigma has the form +of an n-ary function. It passes the decomposed type to the +thing_inside, and returns a wrapper to coerce between the two types + +It's used wherever a language construct must have a functional type, +namely: + A lambda expression + A function definition + An operator section + +This function must be written CPS'd because it needs to fill in the +ExpTypes produced for arguments before it can fill in the ExpType +passed in. + +-} + +-- Use this one when you have an "expected" type. +-- This function skolemises at each polytype. +matchExpectedFunTys :: forall a. + SDoc -- See Note [Herald for matchExpectedFunTys] + -> UserTypeCtxt + -> Arity + -> ExpRhoType -- Skolemised + -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a) + -> TcM (HsWrapper, a) +-- If matchExpectedFunTys n ty = (_, wrap) +-- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, +-- where [t1, ..., tn], ty_r are passed to the thing_inside +matchExpectedFunTys herald ctx arity orig_ty thing_inside + = case orig_ty of + Check ty -> go [] arity ty + _ -> defer [] arity orig_ty + where + -- Skolemise any foralls /before/ the zero-arg case + -- so that we guarantee to return a rho-type + go acc_arg_tys n ty + | (tvs, theta, _) <- tcSplitSigmaTy ty + , not (null tvs && null theta) + = do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' -> + go acc_arg_tys n ty' + ; return (wrap_gen <.> wrap_res, result) } + + -- No more args; do this /before/ tcView, so + -- that we do not unnecessarily unwrap synonyms + go acc_arg_tys 0 rho_ty + = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty) + ; return (idHsWrapper, result) } + + go acc_arg_tys n ty + | Just ty' <- tcView ty = go acc_arg_tys n ty' + + go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) + = ASSERT( af == VisArg ) + do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) + (n-1) res_ty + ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc + ; return ( fun_wrap, result ) } + where + doc = text "When inferring the argument type of a function with type" <+> + quotes (ppr orig_ty) + + go acc_arg_tys n ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go acc_arg_tys n ty' + Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + go acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $ + defer acc_arg_tys n (mkCheckExpType ty) + + ------------ + defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) + defer acc_arg_tys n fun_ty + = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType) + ; res_ty <- newInferExpType + ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty + ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys + ; res_ty <- readExpType res_ty + ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty + ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty + -- Not a good origin at all :-( + ; return (wrap, result) } + + ------------ + mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt arg_tys res_ty env + = do { (env', ty) <- zonkTidyTcType env (mkVisFunTys arg_tys' res_ty) + ; return ( env', mk_fun_tys_msg herald ty arity) } + where + arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) (reverse arg_tys) + -- this is safe b/c we're called from "go" + +-- Like 'matchExpectedFunTys', but used when you have an "actual" type, +-- for example in function application +matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys] + -> CtOrigin + -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType + -> Arity + -> TcSigmaType + -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType) +-- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) +-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) +-- and res_ty is a RhoType +-- NB: the returned type is top-instantiated; it's a RhoType +matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty + = go n_val_args_wanted [] fun_ty + where + go 0 _ fun_ty + = do { (wrap, rho) <- topInstantiate ct_orig fun_ty + ; return (wrap, [], rho) } + go n so_far fun_ty + = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma + herald ct_orig mb_thing + (n_val_args_wanted, so_far) + fun_ty + ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 + ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc + ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } + where + doc = text "When inferring the argument type of a function with type" <+> + quotes (ppr fun_ty) + +-- | matchActualFunTySigm does looks for just one function arrow +-- returning an uninstantiated sigma-type +matchActualFunTySigma + :: SDoc -- See Note [Herald for matchExpectedFunTys] + -> CtOrigin + -> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType + -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and + -- types of values args to which function has + -- been applied already (reversed) + -- Both are used only for error messages) + -> TcSigmaType -- Type to analyse + -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType) +-- See Note [matchActualFunTys error handling] for all these arguments + +-- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty +-- then wrap :: fun_ty ~> (arg_ty -> res_ty) +-- and NB: res_ty is an (uninstantiated) SigmaType + +matchActualFunTySigma herald ct_orig mb_thing err_info fun_ty + = go fun_ty +-- Does not allocate unnecessary meta variables: if the input already is +-- a function, we just take it apart. Not only is this efficient, +-- it's important for higher rank: the argument might be of form +-- (forall a. ty) -> other +-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd +-- hide the forall inside a meta-variable + +-- (*) Sometimes it's necessary to call matchActualFunTys with only part +-- (that is, to the right of some arrows) of the type of the function in +-- question. (See GHC.Tc.Gen.Expr.tcArgs.) This argument is the reversed list of +-- arguments already seen (that is, not part of the TcSigmaType passed +-- in elsewhere). + + where + go :: TcSigmaType -- The remainder of the type as we're processing + -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType) + go ty | Just ty' <- tcView ty = go ty' + + go ty + | not (null tvs && null theta) + = do { (wrap1, rho) <- topInstantiate ct_orig ty + ; (wrap2, arg_ty, res_ty) <- go rho + ; return (wrap2 <.> wrap1, arg_ty, res_ty) } + where + (tvs, theta, _) = tcSplitSigmaTy ty + + go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) + = ASSERT( af == VisArg ) + return (idHsWrapper, Scaled w arg_ty, res_ty) + + go ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go ty' + Flexi -> defer ty } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + go ty = addErrCtxtM (mk_ctxt ty) (defer ty) + + ------------ + defer fun_ty + = do { arg_ty <- newOpenFlexiTyVarTy + ; res_ty <- newOpenFlexiTyVarTy + ; mult <- newFlexiTyVarTy multiplicityTy + ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty + ; co <- unifyType mb_thing fun_ty unif_fun_ty + ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } + + ------------ + mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt res_ty env + = do { (env', ty) <- zonkTidyTcType env $ + mkVisFunTys (reverse arg_tys_so_far) res_ty + ; return (env', mk_fun_tys_msg herald ty n_val_args_in_call) } + (n_val_args_in_call, arg_tys_so_far) = err_info + +mk_fun_tys_msg :: SDoc -> TcType -> Arity -> SDoc +mk_fun_tys_msg herald ty n_args_in_call + | n_args_in_call <= n_fun_args -- Enough args, in the end + = text "In the result of a function call" + | otherwise + = hang (herald <+> speakNOf n_args_in_call (text "value argument") <> comma) + 2 (sep [ text "but its type" <+> quotes (pprType ty) + , if n_fun_args == 0 then text "has none" + else text "has only" <+> speakN n_fun_args]) + where + (args, _) = tcSplitFunTys ty + n_fun_args = length args + +{- Note [matchActualFunTys error handling] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchActualFunTysPart is made much more complicated by the +desire to produce good error messages. Consider the application + f @Int x y +In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments, +and then call matchActualFunTysPart for each individual value +argument. It, in turn, must instantiate any type/dictionary args, +before looking for an arrow type. + +But if it doesn't find an arrow type, it wants to generate a message +like "f is applied to two arguments but its type only has one". +To do that, it needs to konw about the args that tcArgs has already +munched up -- hence passing in n_val_args_in_call and arg_tys_so_far; +and hence also the accumulating so_far arg to 'go'. + +This allows us (in mk_ctxt) to construct f's /instantiated/ type, +with just the values-arg arrows, which is what we really want +in the error message. + +Ugh! +-} + +---------------------- +matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) +-- Special case for lists +matchExpectedListTy exp_ty + = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty + ; return (co, elt_ty) } + +--------------------- +matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * + -> TcRhoType -- orig_ty + -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty + [TcSigmaType]) -- Element types, k1 k2 k3 a b c + +-- It's used for wired-in tycons, so we call checkWiredInTyCon +-- Precondition: never called with FunTyCon +-- Precondition: input type :: * +-- Postcondition: (T k1 k2 k3 a b c) is well-kinded + +matchExpectedTyConApp tc orig_ty + = ASSERT(not $ isFunTyCon tc) go orig_ty + where + go ty + | Just ty' <- tcView ty + = go ty' + + go ty@(TyConApp tycon args) + | tc == tycon -- Common case + = return (mkTcNomReflCo ty, args) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- If the common case does not occur, instantiate a template + -- T k1 .. kn t1 .. tm, and unify with the original type + -- Doing it this way ensures that the types we return are + -- kind-compatible with T. For example, suppose we have + -- matchExpectedTyConApp T (f Maybe) + -- where data T a = MkT a + -- Then we don't want to instantiate T's data constructors with + -- (a::*) ~ Maybe + -- because that'll make types that are utterly ill-kinded. + -- This happened in #7368 + defer + = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) + ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) + ; let args = mkTyVarTys arg_tvs + tc_template = mkTyConApp tc args + ; co <- unifyType Nothing tc_template orig_ty + ; return (co, args) } + +---------------------- +matchExpectedAppTy :: TcRhoType -- orig_ty + -> TcM (TcCoercion, -- m a ~N orig_ty + (TcSigmaType, TcSigmaType)) -- Returns m, a +-- If the incoming type is a mutable type variable of kind k, then +-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. + +matchExpectedAppTy orig_ty + = go orig_ty + where + go ty + | Just ty' <- tcView ty = go ty' + + | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty + = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty)) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- Defer splitting by generating an equality constraint + defer + = do { ty1 <- newFlexiTyVarTy kind1 + ; ty2 <- newFlexiTyVarTy kind2 + ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty + ; return (co, (ty1, ty2)) } + + orig_kind = tcTypeKind orig_ty + kind1 = mkVisFunTyMany liftedTypeKind orig_kind + kind2 = liftedTypeKind -- m :: * -> k + -- arg type :: * + +{- +************************************************************************ +* * + Subsumption checking +* * +************************************************************************ + +Note [Subsumption checking: tcSubType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the tcSubType calls have the form + tcSubType actual_ty expected_ty +which checks + actual_ty <= expected_ty + +That is, that a value of type actual_ty is acceptable in +a place expecting a value of type expected_ty. I.e. that + + actual ty is more polymorphic than expected_ty + +It returns a wrapper function + co_fn :: actual_ty ~ expected_ty +which takes an HsExpr of type actual_ty into one of type +expected_ty. +-} + + +----------------- +-- tcWrapResult needs both un-type-checked (for origins and error messages) +-- and type-checked (for wrapping) expressions +tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr + +tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResultO orig rn_expr expr actual_ty res_ty + = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty + , text "Expected:" <+> ppr res_ty ]) + ; wrap <- tcSubTypeNC orig GenSigCtxt (Just rn_expr) actual_ty res_ty + ; return (mkHsWrap wrap expr) } + +tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc + -> TcRhoType -- Actual -- a rho-type not a sigma-type + -> ExpRhoType -- Expected + -> TcM (HsExpr GhcTc) +-- A version of tcWrapResult to use when the actual type is a +-- rho-type, so nothing to instantiate; just go straight to unify. +-- It means we don't need to pass in a CtOrigin +tcWrapResultMono rn_expr expr act_ty res_ty + = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr ) + do { co <- case res_ty of + Infer inf_res -> fillInferResult act_ty inf_res + Check exp_ty -> unifyType (Just rn_expr) act_ty exp_ty + ; return (mkHsWrapCo co expr) } + +------------------------ +tcSubTypePat :: CtOrigin -> UserTypeCtxt + -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- Used in patterns; polarity is backwards compared +-- to tcSubType +-- If wrap = tc_sub_type_et t1 t2 +-- => wrap :: t1 ~> t2 +tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected + = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected + +tcSubTypePat _ _ (Infer inf_res) ty_expected + = do { co <- fillInferResult ty_expected inf_res + -- In patterns we do not instantatiate + + ; return (mkWpCastN (mkTcSymCo co)) } + +--------------- +tcSubType :: CtOrigin -> UserTypeCtxt + -> TcSigmaType -- Actual + -> ExpRhoType -- Expected + -> TcM HsWrapper +-- Checks that 'actual' is more polymorphic than 'expected' +tcSubType orig ctxt ty_actual ty_expected + = addSubTypeCtxt ty_actual ty_expected $ + do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) + ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected } + +tcSubTypeNC :: CtOrigin -- Used when instantiating + -> UserTypeCtxt -- Used when skolemising + -> Maybe (HsExpr GhcRn) -- The expression that has type 'actual' (if known) + -> TcSigmaType -- Actual type + -> ExpRhoType -- Expected type + -> TcM HsWrapper +tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty + = case res_ty of + Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt + ty_actual ty_expected + + Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual + -- See Note [Instantiation of InferResult] + ; co <- fillInferResult rho inf_res + ; return (mkWpCastN co <.> wrap) } + +{- Note [Instantiation of InferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now always instantiate before filling in InferResult, so that +the result is a TcRhoType: see #17173 for discussion. + +For example: + +1. Consider + f x = (*) + We want to instantiate the type of (*) before returning, else we + will infer the type + f :: forall {a}. a -> forall b. Num b => b -> b -> b + This is surely confusing for users. + + And worse, the monomorphism restriction won't work properly. The MR is + dealt with in simplifyInfer, and simplifyInfer has no way of + instantiating. This could perhaps be worked around, but it may be + hard to know even when instantiation should happen. + +2. Another reason. Consider + f :: (?x :: Int) => a -> a + g y = let ?x = 3::Int in f + Here want to instantiate f's type so that the ?x::Int constraint + gets discharged by the enclosing implicit-parameter binding. + +3. Suppose one defines plus = (+). If we instantiate lazily, we will + infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism + restriction compels us to infer + plus :: Integer -> Integer -> Integer + (or similar monotype). Indeed, the only way to know whether to apply + the monomorphism restriction at all is to instantiate + +There is one place where we don't want to instantiate eagerly, +namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type +command. See Note [Implementing :type] in GHC.Tc.Module. +-} + +--------------- +tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- External entry point, but no ExpTypes on either side +-- Checks that actual <= expected +-- Returns HsWrapper :: actual ~ expected +tcSubTypeSigma ctxt ty_actual ty_expected + = tc_sub_type (unifyType Nothing) eq_orig ctxt ty_actual ty_expected + where + eq_orig = TypeEqOrigin { uo_actual = ty_actual + , uo_expected = ty_expected + , uo_thing = Nothing + , uo_visible = True } + +--------------- +tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify + -> CtOrigin -- Used when instantiating + -> UserTypeCtxt -- Used when skolemising + -> TcSigmaType -- Actual; a sigma-type + -> TcSigmaType -- Expected; also a sigma-type + -> TcM HsWrapper +-- Checks that actual_ty is more polymorphic than expected_ty +-- If wrap = tc_sub_type t1 t2 +-- => wrap :: t1 ~> t2 +tc_sub_type unify inst_orig ctxt ty_actual ty_expected + | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] + , not (possibly_poly ty_actual) + = do { traceTc "tc_sub_type (drop to equality)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; mkWpCastN <$> + unify ty_actual ty_expected } + + | otherwise -- This is the general case + = do { traceTc "tc_sub_type (general case)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + + ; (sk_wrap, inner_wrap) + <- tcSkolemise ctxt ty_expected $ \ sk_rho -> + do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual + ; cow <- unify rho_a sk_rho + ; return (mkWpCastN cow <.> wrap) } + + ; return (sk_wrap <.> inner_wrap) } + where + possibly_poly ty + | isForAllTy ty = True + | Just (_, _, res) <- splitFunTy_maybe ty = possibly_poly res + | otherwise = False + -- NB *not* tcSplitFunTy, because here we want + -- to decompose type-class arguments too + + definitely_poly ty + | (tvs, theta, tau) <- tcSplitSigmaTy ty + , (tv:_) <- tvs + , null theta + , isInsolubleOccursCheck NomEq tv tau + = True + | otherwise + = False + +------------------------ +addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a +addSubTypeCtxt ty_actual ty_expected thing_inside + | isRhoTy ty_actual -- If there is no polymorphism involved, the + , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) + = thing_inside -- gives enough context by itself + | otherwise + = addErrCtxtM mk_msg thing_inside + where + mk_msg tidy_env + = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual + -- might not be filled if we're debugging. ugh. + ; mb_ty_expected <- readExpType_maybe ty_expected + ; (tidy_env, ty_expected) <- case mb_ty_expected of + Just ty -> second mkCheckExpType <$> + zonkTidyTcType tidy_env ty + Nothing -> return (tidy_env, ty_expected) + ; ty_expected <- readExpType ty_expected + ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected + ; let msg = vcat [ hang (text "When checking that:") + 4 (ppr ty_actual) + , nest 2 (hang (text "is more polymorphic than:") + 2 (ppr ty_expected)) ] + ; return (tidy_env, msg) } + +{- Note [Don't skolemise unnecessarily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are trying to solve + (Char->Char) <= (forall a. a->a) +We could skolemise the 'forall a', and then complain +that (Char ~ a) is insoluble; but that's a pretty obscure +error. It's better to say that + (Char->Char) ~ (forall a. a->a) +fails. + +So roughly: + * if the ty_expected has an outermost forall + (i.e. skolemisation is the next thing we'd do) + * and the ty_actual has no top-level polymorphism (but looking deeply) +then we can revert to simple equality. But we need to be careful. +These examples are all fine: + + * (Char -> forall a. a->a) <= (forall a. Char -> a -> a) + Polymorphism is buried in ty_actual + + * (Char->Char) <= (forall a. Char -> Char) + ty_expected isn't really polymorphic + + * (Char->Char) <= (forall a. (a~Char) => a -> a) + ty_expected isn't really polymorphic + + * (Char->Char) <= (forall a. F [a] Char -> Char) + where type instance F [x] t = t + ty_expected isn't really polymorphic + +If we prematurely go to equality we'll reject a program we should +accept (e.g. #13752). So the test (which is only to improve +error message) is very conservative: + * ty_actual is /definitely/ monomorphic + * ty_expected is /definitely/ polymorphic + +Note [Settting the argument context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we are doing the ambiguity check for the (bogus) + f :: (forall a b. C b => a -> a) -> Int + +We'll call + tcSubType ((forall a b. C b => a->a) -> Int ) + ((forall a b. C b => a->a) -> Int ) + +with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing +on the argument type of the (->) -- and at that point we want to switch +to a UserTypeCtxt of GenSigCtxt. Why? + +* Error messages. If we stick with FunSigCtxt we get errors like + * Could not deduce: C b + from the context: C b0 + bound by the type signature for: + f :: forall a b. C b => a->a + But of course f does not have that type signature! + Example tests: T10508, T7220a, Simple14 + +* Implications. We may decide to build an implication for the whole + ambiguity check, but we don't need one for each level within it, + and GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt. + See Note [When to build an implication] + +Note [Wrapper returned from tcSubMult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no notion of multiplicity coercion in Core, therefore the wrapper +returned by tcSubMult (and derived functions such as tcCheckUsage and +checkManyPattern) is quite unlike any other wrapper: it checks whether the +coercion produced by the constraint solver is trivial, producing a type error +is it is not. This is implemented via the WpMultCoercion wrapper, as desugared +by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check. + +This wrapper needs to be placed in the term; otherwise, checking of the +eventual coercion won't be triggered during desugaring. But it can be put +anywhere, since it doesn't affect the desugared code. + +Why do we check this in the desugarer? It's a convenient place, since it's +right after all the constraints are solved. We need the constraints to be +solved to check whether they are trivial or not. Plus there is precedent for +type errors during desuraging (such as the levity polymorphism +restriction). An alternative would be to have a kind of constraint which can +only produce trivial evidence, then this check would happen in the constraint +solver. +-} + +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper +tcSubMult origin w_actual w_expected + | Just (w1, w2) <- isMultMul w_actual = + do { w1 <- tcSubMult origin w1 w_expected + ; w2 <- tcSubMult origin w2 w_expected + ; return (w1 <.> w2) } + -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is + -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p + -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating + -- multiplicities] in Multiplicity. +tcSubMult origin w_actual w_expected = + case submult w_actual w_expected of + Submult -> return WpHole + Unknown -> tcEqMult origin w_actual w_expected + +tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper +tcEqMult origin w_actual w_expected = do + { + -- Note that here we do not call to `submult`, so we check + -- for strict equality. + ; coercion <- uType TypeLevel origin w_actual w_expected + ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion } + + +{- ********************************************************************* +* * + Generalisation +* * +********************************************************************* -} + +{- Note [Skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~ +tcSkolemise takes "expected type" and strip off quantifiers to expose the +type underneath, binding the new skolems for the 'thing_inside' +The returned 'HsWrapper' has type (specific_ty -> expected_ty). + +Note that for a nested type like + forall a. Eq a => forall b. Ord b => blah +we still only build one implication constraint + forall a b. (Eq a, Ord b) => +This is just an optimisation, but it's why we use topSkolemise to +build the pieces from all the layers, before making a single call +to checkConstraints. + +tcSkolemiseScoped is very similar, but differs in two ways: + +* It deals specially with just the outer forall, bringing those + type variables into lexical scope. To my surprise, I found that + doing this regardless (in tcSkolemise) caused a non-trivial (1%-ish) + perf hit on the compiler. + +* It always calls checkConstraints, even if there are no skolem + variables at all. Reason: there might be nested deferred errors + that must not be allowed to float to top level. + See Note [When to build an implication] below. +-} + +tcSkolemise, tcSkolemiseScoped + :: UserTypeCtxt -> TcSigmaType + -> (TcType -> TcM result) + -> TcM (HsWrapper, result) + -- ^ The wrapper has type: spec_ty ~> expected_ty + +tcSkolemiseScoped ctxt expected_ty thing_inside + = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty + ; let skol_tvs = map snd tv_prs + skol_info = SigSkol ctxt expected_ty tv_prs + + ; (ev_binds, res) + <- checkConstraints skol_info skol_tvs given $ + tcExtendNameTyVarEnv tv_prs $ + thing_inside rho_ty + + ; return (wrap <.> mkWpLet ev_binds, res) } + +tcSkolemise ctxt expected_ty thing_inside + | isRhoTy expected_ty -- Short cut for common case + = do { res <- thing_inside expected_ty + ; return (idHsWrapper, res) } + | otherwise + = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty + + ; let skol_tvs = map snd tv_prs + skol_info = SigSkol ctxt expected_ty tv_prs + + ; (ev_binds, result) + <- checkConstraints skol_info skol_tvs given $ + thing_inside rho_ty + + ; return (wrap <.> mkWpLet ev_binds, result) } + -- The ev_binds returned by checkConstraints is very + -- often empty, in which case mkWpLet is a no-op + +-- | Variant of 'tcSkolemise' that takes an ExpType +tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType + -> (ExpRhoType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemiseET _ et@(Infer {}) thing_inside + = (idHsWrapper, ) <$> thing_inside et +tcSkolemiseET ctxt (Check ty) thing_inside + = tcSkolemise ctxt ty $ \rho_ty -> + thing_inside (mkCheckExpType rho_ty) + +checkConstraints :: SkolemInfo + -> [TcTyVar] -- Skolems + -> [EvVar] -- Given + -> TcM result + -> TcM (TcEvBinds, result) + +checkConstraints skol_info skol_tvs given thing_inside + = do { implication_needed <- implicationNeeded skol_info skol_tvs given + + ; if implication_needed + then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted + ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) + ; emitImplications implics + ; return (ev_binds, result) } + + else -- Fast path. We check every function argument with tcCheckPolyExpr, + -- which uses tcSkolemise and hence checkConstraints. + -- So this fast path is well-exercised + do { res <- thing_inside + ; return (emptyTcEvBinds, res) } } + +checkTvConstraints :: SkolemInfo + -> [TcTyVar] -- Skolem tyvars + -> TcM result + -> TcM result + +checkTvConstraints skol_info skol_tvs thing_inside + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted + ; return result } + +emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM () +emitResidualTvConstraint skol_info skol_tvs tclvl wanted + | isEmptyWC wanted + = return () + + | otherwise + = do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted + ; emitImplication implic } + +buildTvImplication :: SkolemInfo -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM Implication +buildTvImplication skol_info skol_tvs tclvl wanted + = do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints + -- are solved by filling in coercion holes, not + -- by creating a value-level evidence binding + ; implic <- newImplication + + ; return (implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info }) } + +implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool +-- See Note [When to build an implication] +implicationNeeded skol_info skol_tvs given + | null skol_tvs + , null given + , not (alwaysBuildImplication skol_info) + = -- Empty skolems and givens + do { tc_lvl <- getTcLevel + ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are + then return False -- already inside an implication + else + do { dflags <- getDynFlags -- If any deferral can happen, + -- we must build an implication + ; return (gopt Opt_DeferTypeErrors dflags || + gopt Opt_DeferTypedHoles dflags || + gopt Opt_DeferOutOfScopeVariables dflags) } } + + | otherwise -- Non-empty skolems or givens + = return True -- Definitely need an implication + +alwaysBuildImplication :: SkolemInfo -> Bool +-- See Note [When to build an implication] +alwaysBuildImplication _ = False + +{- Commmented out for now while I figure out about error messages. + See #14185 + +alwaysBuildImplication (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt {} -> True -- RHS of a binding with a signature + _ -> False +alwaysBuildImplication (RuleSkol {}) = True +alwaysBuildImplication (InstSkol {}) = True +alwaysBuildImplication (FamInstSkol {}) = True +alwaysBuildImplication _ = False +-} + +buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] + -> [EvVar] -> WantedConstraints + -> TcM (Bag Implication, TcEvBinds) +buildImplicationFor tclvl skol_info skol_tvs given wanted + | isEmptyWC wanted && null given + -- Optimisation : if there are no wanteds, and no givens + -- don't generate an implication at all. + -- Reason for the (null given): we don't want to lose + -- the "inaccessible alternative" error check + = return (emptyBag, emptyTcEvBinds) + + | otherwise + = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs ) + -- Why allow TyVarTvs? Because implicitly declared kind variables in + -- non-CUSK type declarations are TyVarTvs, and we need to bring them + -- into scope as a skolem in an implication. This is OK, though, + -- because TyVarTvs will always remain tyvars, even after unification. + do { ev_binds_var <- newTcEvBinds + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given = given + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = skol_info } + + ; return (unitBag implic', TcEvBinds ev_binds_var) } + +{- Note [When to build an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have some 'skolems' and some 'givens', and we are +considering whether to wrap the constraints in their scope into an +implication. We must /always/ so if either 'skolems' or 'givens' are +non-empty. But what if both are empty? You might think we could +always drop the implication. Other things being equal, the fewer +implications the better. Less clutter and overhead. But we must +take care: + +* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, + we'll make a /term-level/ evidence binding for 'g = error "blah"'. + We must have an EvBindsVar those bindings!, otherwise they end up as + top-level unlifted bindings, which are verboten. This only matters + at top level, so we check for that + See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors. + cf #14149 for an example of what goes wrong. + +* If you have + f :: Int; f = f_blah + g :: Bool; g = g_blah + If we don't build an implication for f or g (no tyvars, no givens), + the constraints for f_blah and g_blah are solved together. And that + can yield /very/ confusing error messages, because we can get + [W] C Int b1 -- from f_blah + [W] C Int b2 -- from g_blan + and fundpes can yield [D] b1 ~ b2, even though the two functions have + literally nothing to do with each other. #14185 is an example. + Building an implication keeps them separage. +-} + +{- +************************************************************************ +* * + Boxy unification +* * +************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. +-} + +unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1' + -> TcTauType -> TcTauType -> TcM TcCoercionN +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyType thing ty1 ty2 + = uType TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = ppr <$> thing + , uo_visible = True } + +unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN +-- Like unifyType, but swap expected and actual in error messages +-- This is used when typechecking patterns +unifyTypeET ty1 ty2 + = uType TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty2 -- NB swapped + , uo_expected = ty1 -- NB swapped + , uo_thing = Nothing + , uo_visible = True } + + +unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN +unifyKind thing ty1 ty2 + = uType KindLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = ppr <$> thing + , uo_visible = True } + + +{- +%************************************************************************ +%* * + uType and friends +%* * +%************************************************************************ + +uType is the heart of the unifier. +-} + +uType, uType_defer + :: TypeOrKind + -> CtOrigin + -> TcType -- ty1 is the *actual* type + -> TcType -- ty2 is the *expected* type + -> TcM CoercionN + +-------------- +-- It is always safe to defer unification to the main constraint solver +-- See Note [Deferred unification] +uType_defer t_or_k origin ty1 ty2 + = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2 + + -- Error trace only + -- NB. do *not* call mkErrInfo unless tracing is on, + -- because it is hugely expensive (#5631) + ; whenDOptM Opt_D_dump_tc_trace $ do + { ctxt <- getErrCtxt + ; doc <- mkErrInfo emptyTidyEnv ctxt + ; traceTc "utype_defer" (vcat [ debugPprType ty1 + , debugPprType ty2 + , pprCtOrigin origin + , doc]) + ; traceTc "utype_defer2" (ppr co) + } + ; return co } + +-------------- +uType t_or_k origin orig_ty1 orig_ty2 + = do { tclvl <- getTcLevel + ; traceTc "u_tys" $ vcat + [ text "tclvl" <+> ppr tclvl + , sep [ ppr orig_ty1, text "~", ppr orig_ty2] + , pprCtOrigin origin] + ; co <- go orig_ty1 orig_ty2 + ; if isReflCo co + then traceTc "u_tys yields no coercion" Outputable.empty + else traceTc "u_tys yields coercion:" (ppr co) + ; return co } + where + go :: TcType -> TcType -> TcM CoercionN + -- The arguments to 'go' are always semantically identical + -- to orig_ty{1,2} except for looking through type synonyms + + -- Unwrap casts before looking for variables. This way, we can easily + -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we + -- didn't do it this way, and then the unification above was deferred. + go (CastTy t1 co1) t2 + = do { co_tys <- uType t_or_k origin t1 t2 + ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) } + + go t1 (CastTy t2 co2) + = do { co_tys <- uType t_or_k origin t1 t2 + ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) } + + -- Variables; go for uUnfilledVar + -- Note that we pass in *original* (before synonym expansion), + -- so that type variables tend to get filled in with + -- the most informative version of the type + go (TyVarTy tv1) ty2 + = do { lookup_res <- lookupTcTyVar tv1 + ; case lookup_res of + Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) + ; go ty1 ty2 } + Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 } + go ty1 (TyVarTy tv2) + = do { lookup_res <- lookupTcTyVar tv2 + ; case lookup_res of + Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) + ; go ty1 ty2 } + Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 } + + -- See Note [Expanding synonyms during unification] + go ty1@(TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = return $ mkNomReflCo ty1 + + -- See Note [Expanding synonyms during unification] + -- + -- Also NB that we recurse to 'go' so that we don't push a + -- new item on the origin stack. As a result if we have + -- type Foo = Int + -- and we try to unify Foo ~ Bool + -- we'll end up saying "can't match Foo with Bool" + -- rather than "can't match "Int with Bool". See #4535. + go ty1 ty2 + | Just ty1' <- tcView ty1 = go ty1' ty2 + | Just ty2' <- tcView ty2 = go ty1 ty2' + + -- Functions (or predicate functions) just check the two parts + go (FunTy _ w1 fun1 arg1) (FunTy _ w2 fun2 arg2) + = do { co_l <- uType t_or_k origin fun1 fun2 + ; co_r <- uType t_or_k origin arg1 arg2 + ; co_w <- uType t_or_k origin w1 w2 + ; return $ mkFunCo Nominal co_w co_l co_r } + + -- Always defer if a type synonym family (type function) + -- is involved. (Data families behave rigidly.) + go ty1@(TyConApp tc1 _) ty2 + | isTypeFamilyTyCon tc1 = defer ty1 ty2 + go ty1 ty2@(TyConApp tc2 _) + | isTypeFamilyTyCon tc2 = defer ty1 ty2 + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, equalLength tys1 tys2 + = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 ) + do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2 + ; return $ mkTyConAppCo Nominal tc1 cos } + where + origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin) + (tcTyConVisibilities tc1) + + go (LitTy m) ty@(LitTy n) + | m == n + = return $ mkNomReflCo ty + + -- See Note [Care with type applications] + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go (AppTy s1 t1) (AppTy s2 t2) + = go_app (isNextArgVisible s1) s1 t1 s2 t2 + + go (AppTy s1 t1) (TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = ASSERT( not (mustBeSaturated tc2) ) + go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2' + + go (TyConApp tc1 ts1) (AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = ASSERT( not (mustBeSaturated tc1) ) + go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2 + + go (CoercionTy co1) (CoercionTy co2) + = do { let ty1 = coercionType co1 + ty2 = coercionType co2 + ; kco <- uType KindLevel + (KindEqOrigin orig_ty1 (Just orig_ty2) origin + (Just t_or_k)) + ty1 ty2 + ; return $ mkProofIrrelCo Nominal kco co1 co2 } + + -- Anything else fails + -- E.g. unifying for-all types, which is relative unusual + go ty1 ty2 = defer ty1 ty2 + + ------------------ + defer ty1 ty2 -- See Note [Check for equality before deferring] + | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1) + | otherwise = uType_defer t_or_k origin ty1 ty2 + + ------------------ + go_app vis s1 t1 s2 t2 + = do { co_s <- uType t_or_k origin s1 s2 + ; let arg_origin + | vis = origin + | otherwise = toInvisibleOrigin origin + ; co_t <- uType t_or_k arg_origin t1 t2 + ; return $ mkAppCo co_s co_t } + +{- Note [Check for equality before deferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Particularly in ambiguity checks we can get equalities like (ty ~ ty). +If ty involves a type function we may defer, which isn't very sensible. +An egregious example of this was in test T9872a, which has a type signature + Proxy :: Proxy (Solutions Cubes) +Doing the ambiguity check on this signature generates the equality + Solutions Cubes ~ Solutions Cubes +and currently the constraint solver normalises both sides at vast cost. +This little short-cut in 'defer' helps quite a bit. + +Note [Care with type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note: type applications need a bit of care! +They can match FunTy and TyConApp, so use splitAppTy_maybe +NB: we've already dealt with type variables and Notes, +so if one type is an App the other one jolly well better be too + +Note [Mismatched type lists and application decomposition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we find two TyConApps, you might think that the argument lists +are guaranteed equal length. But they aren't. Consider matching + w (T x) ~ Foo (T x y) +We do match (w ~ Foo) first, but in some circumstances we simply create +a deferred constraint; and then go ahead and match (T x ~ T x y). +This came up in #3950. + +So either + (a) either we must check for identical argument kinds + when decomposing applications, + + (b) or we must be prepared for ill-kinded unification sub-problems + +Currently we adopt (b) since it seems more robust -- no need to maintain +a global invariant. + +Note [Expanding synonyms during unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand synonyms during unification, but: + * We expand *after* the variable case so that we tend to unify + variables with un-expanded type synonym. This just makes it + more likely that the inferred types will mention type synonyms + understandable to the user + + * Similarly, we expand *after* the CastTy case, just in case the + CastTy wraps a variable. + + * We expand *before* the TyConApp case. For example, if we have + type Phantom a = Int + and are unifying + Phantom Int ~ Phantom Char + it is *wrong* to unify Int and Char. + + * The problem case immediately above can happen only with arguments + to the tycon. So we check for nullary tycons *before* expanding. + This is particularly helpful when checking (* ~ *), because * is + now a type synonym. + +Note [Deferred Unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, +and yet its consistency is undetermined. Previously, there was no way to still +make it consistent. So a mismatch error was issued. + +Now these unifications are deferred until constraint simplification, where type +family instances and given equations may (or may not) establish the consistency. +Deferred unifications are of the form + F ... ~ ... +or x ~ ... +where F is a type function and x is a type variable. +E.g. + id :: x ~ y => x -> y + id e = e + +involves the unification x = y. It is deferred until we bring into account the +context x ~ y to establish that it holds. + +If available, we defer original types (rather than those where closed type +synonyms have already been expanded via tcCoreView). This is, as usual, to +improve error messages. + + +************************************************************************ +* * + uUnfilledVar and friends +* * +************************************************************************ + +@uunfilledVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @uVar@ (defined below) nips +back into @uTys@ if it turns out that the variable is already bound. +-} + +---------- +uUnfilledVar :: CtOrigin + -> TypeOrKind + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2 + -> TcM Coercion +-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar +-- It might be a skolem, or untouchable, or meta + +uUnfilledVar origin t_or_k swapped tv1 ty2 + = do { ty2 <- zonkTcType ty2 + -- Zonk to expose things to the + -- occurs check, and so that if ty2 + -- looks like a type variable then it + -- /is/ a type variable + ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 } + +---------- +uUnfilledVar1 :: CtOrigin + -> TypeOrKind + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2, zonked + -> TcM Coercion +uUnfilledVar1 origin t_or_k swapped tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 + = go tv2 + + | otherwise + = uUnfilledVar2 origin t_or_k swapped tv1 ty2 + + where + -- 'go' handles the case where both are + -- tyvars so we might want to swap + -- E.g. maybe tv2 is a meta-tyvar and tv1 is not + go tv2 | tv1 == tv2 -- Same type variable => no-op + = return (mkNomReflCo (mkTyVarTy tv1)) + + | swapOverTyVars False tv1 tv2 -- Distinct type variables + -- Swap meta tyvar to the left if poss + = do { tv1 <- zonkTyCoVarKind tv1 + -- We must zonk tv1's kind because that might + -- not have happened yet, and it's an invariant of + -- uUnfilledTyVar2 that ty2 is fully zonked + -- Omitting this caused #16902 + ; uUnfilledVar2 origin t_or_k (flipSwap swapped) + tv2 (mkTyVarTy tv1) } + + | otherwise + = uUnfilledVar2 origin t_or_k swapped tv1 ty2 + +---------- +uUnfilledVar2 :: CtOrigin + -> TypeOrKind + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2, zonked + -> TcM Coercion +uUnfilledVar2 origin t_or_k swapped tv1 ty2 + = do { dflags <- getDynFlags + ; cur_lvl <- getTcLevel + ; go dflags cur_lvl } + where + go dflags cur_lvl + | canSolveByUnification cur_lvl tv1 ty2 + , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2 + = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1) + ; traceTc "uUnfilledVar2 ok" $ + vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2) + , ppr (isTcReflCo co_k), ppr co_k ] + + ; if isTcReflCo co_k + -- Only proceed if the kinds match + -- NB: tv1 should still be unfilled, despite the kind unification + -- because tv1 is not free in ty2 (or, hence, in its kind) + then do { writeMetaTyVar tv1 ty2' + ; return (mkTcNomReflCo ty2') } + + else defer } -- This cannot be solved now. See GHC.Tc.Solver.Canonical + -- Note [Equalities with incompatible kinds] + + | otherwise + = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) + -- Occurs check or an untouchable: just defer + -- NB: occurs check isn't necessarily fatal: + -- eg tv1 occurred in type family parameter + ; defer } + + ty1 = mkTyVarTy tv1 + kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) + + defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 + +swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool +swapOverTyVars is_given tv1 tv2 + -- See Note [Unification variables on the left] + | not is_given, pri1 == 0, pri2 > 0 = True + | not is_given, pri2 == 0, pri1 > 0 = False + + -- Level comparison: see Note [TyVar/TyVar orientation] + | lvl1 `strictlyDeeperThan` lvl2 = False + | lvl2 `strictlyDeeperThan` lvl1 = True + + -- Priority: see Note [TyVar/TyVar orientation] + | pri1 > pri2 = False + | pri2 > pri1 = True + + -- Names: see Note [TyVar/TyVar orientation] + | isSystemName tv2_name, not (isSystemName tv1_name) = True + + | otherwise = False + + where + lvl1 = tcTyVarLevel tv1 + lvl2 = tcTyVarLevel tv2 + pri1 = lhsPriority tv1 + pri2 = lhsPriority tv2 + tv1_name = Var.varName tv1 + tv2_name = Var.varName tv2 + + +lhsPriority :: TcTyVar -> Int +-- Higher => more important to be on the LHS +-- See Note [TyVar/TyVar orientation] +lhsPriority tv + = ASSERT2( isTyVar tv, ppr tv) + case tcTyVarDetails tv of + RuntimeUnk -> 0 + SkolemTv {} -> 0 + MetaTv { mtv_info = info } -> case info of + FlatSkolTv -> 1 + TyVarTv -> 2 + TauTv -> 3 + FlatMetaTv -> 4 +{- Note [TyVar/TyVar orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)? +This is a surprisingly tricky question! This is invariant (TyEq:TV). + +The question is answered by swapOverTyVars, which is use + - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 + - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqTyVarHomo + +First note: only swap if you have to! + See Note [Avoid unnecessary swaps] + +So we look for a positive reason to swap, using a three-step test: + +* Level comparison. If 'a' has deeper level than 'b', + put 'a' on the left. See Note [Deeper level on the left] + +* Priority. If the levels are the same, look at what kind of + type variable it is, using 'lhsPriority'. + + Generally speaking we always try to put a MetaTv on the left + in preference to SkolemTv or RuntimeUnkTv: + a) Because the MetaTv may be touchable and can be unified + b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities + looks for meta tyvars on the left + + Tie-breaking rules for MetaTvs: + - FlatMetaTv = 4: always put on the left. + See Note [Fmv Orientation Invariant] + + NB: FlatMetaTvs always have the current level, never an + outer one. So nothing can be deeper than a FlatMetaTv. + + - TauTv = 3: if we have tyv_tv ~ tau_tv, + put tau_tv on the left because there are fewer + restrictions on updating TauTvs. Or to say it another + way, then we won't lose the TyVarTv flag + + - TyVarTv = 2: remember, flat-skols are *only* updated by + the unflattener, never unified, so TyVarTvs come next + + - FlatSkolTv = 1: put on the left in preference to a SkolemTv. + See Note [Eliminate flat-skols] + +* Names. If the level and priority comparisons are all + equal, try to eliminate a TyVars with a System Name in + favour of ones with a Name derived from a user type signature + +* Age. At one point in the past we tried to break any remaining + ties by eliminating the younger type variable, based on their + Uniques. See Note [Eliminate younger unification variables] + (which also explains why we don't do this any more) + +Note [Unification variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of +level, so that the unification variable is on the left. + +* We /don't/ want this for Givens because if we ave + [G] a[2] ~ alpha[1] + [W] Bool ~ a[2] + we want to rewrite the wanted to Bool ~ alpha[1], + so we can float the constraint and solve it. + +* But for Wanteds putting the unification variable on + the left means an easier job when floating, and when + reporting errors -- just fewer cases to consider. + + In particular, we get better skolem-escape messages: + see #18114 + +Note [Deeper level on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The most important thing is that we want to put tyvars with +the deepest level on the left. The reason to do so differs for +Wanteds and Givens, but either way, deepest wins! Simple. + +* Wanteds. Putting the deepest variable on the left maximise the + chances that it's a touchable meta-tyvar which can be solved. + +* Givens. Suppose we have something like + forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] + + If we orient the Given a[2] on the left, we'll rewrite the Wanted to + (beta[1] ~ b[1]), and that can float out of the implication. + Otherwise it can't. By putting the deepest variable on the left + we maximise our changes of eliminating skolem capture. + + See also GHC.Tc.Solver.Monad Note [Let-bound skolems] for another reason + to orient with the deepest skolem on the left. + + IMPORTANT NOTE: this test does a level-number comparison on + skolems, so it's important that skolems have (accurate) level + numbers. + +See #15009 for an further analysis of why "deepest on the left" +is a good plan. + +Note [Fmv Orientation Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * We always orient a constraint + fmv ~ alpha + with fmv on the left, even if alpha is + a touchable unification variable + +Reason: doing it the other way round would unify alpha:=fmv, but that +really doesn't add any info to alpha. But a later constraint alpha ~ +Int might unlock everything. Comment:9 of #12526 gives a detailed +example. + +WARNING: I've gone to and fro on this one several times. +I'm now pretty sure that unifying alpha:=fmv is a bad idea! +So orienting with fmvs on the left is a good thing. + +This example comes from IndTypesPerfMerge. (Others include +T10226, T10009.) + From the ambiguity check for + f :: (F a ~ a) => a + we get: + [G] F a ~ a + [WD] F alpha ~ alpha, alpha ~ a + + From Givens we get + [G] F a ~ fsk, fsk ~ a + + Now if we flatten we get + [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a + + Now, if we unified alpha := fmv, we'd get + [WD] F fmv ~ fmv, [WD] fmv ~ a + And now we are stuck. + +So instead the Fmv Orientation Invariant puts the fmv on the +left, giving + [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a + + Now we get alpha:=a, and everything works out + +Note [Eliminate flat-skols] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have [G] Num (F [a]) +then we flatten to + [G] Num fsk + [G] F [a] ~ fsk +where fsk is a flatten-skolem (FlatSkolTv). Suppose we have + type instance F [a] = a +then we'll reduce the second constraint to + [G] a ~ fsk +and then replace all uses of 'a' with fsk. That's bad because +in error messages instead of saying 'a' we'll say (F [a]). In all +places, including those where the programmer wrote 'a' in the first +place. Very confusing! See #7862. + +Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate +the fsk. + +Note [Avoid unnecessary swaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we swap without actually improving matters, we can get an infinite loop. +Consider + work item: a ~ b + inert item: b ~ c +We canonicalise the work-item to (a ~ c). If we then swap it before +adding to the inert set, we'll add (c ~ a), and therefore kick out the +inert guy, so we get + new work item: b ~ c + inert item: c ~ a +And now the cycle just repeats + +Note [Eliminate younger unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a choice of unifying + alpha := beta or beta := alpha +we try, if possible, to eliminate the "younger" one, as determined +by `ltUnique`. Reason: the younger one is less likely to appear free in +an existing inert constraint, and hence we are less likely to be forced +into kicking out and rewriting inert constraints. + +This is a performance optimisation only. It turns out to fix +#14723 all by itself, but clearly not reliably so! + +It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). +But, to my surprise, it didn't seem to make any significant difference +to the compiler's performance, so I didn't take it any further. Still +it seemed to too nice to discard altogether, so I'm leaving these +notes. SLPJ Jan 18. +-} + +-- @trySpontaneousSolve wi@ solves equalities where one side is a +-- touchable unification variable. +-- Returns True <=> spontaneous solve happened +canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool +canSolveByUnification tclvl tv xi + | isTouchableMetaTyVar tclvl tv + = case metaTyVarInfo tv of + TyVarTv -> is_tyvar xi + _ -> True + + | otherwise -- Untouchable + = False + where + is_tyvar xi + = case tcGetTyVar_maybe xi of + Nothing -> False + Just tv -> case tcTyVarDetails tv of + MetaTv { mtv_info = info } + -> case info of + TyVarTv -> True + _ -> False + SkolemTv {} -> True + RuntimeUnk -> True + +{- Note [Prevent unification with type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prevent unification with type families because of an uneasy compromise. +It's perfectly sound to unify with type families, and it even improves the +error messages in the testsuite. It also modestly improves performance, at +least in some cases. But it's disastrous for test case perf/compiler/T3064. +Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. +What do we do? Do we reduce F? Or do we use the given? Hard to know what's +best. GHC reduces. This is a disaster for T3064, where the type's size +spirals out of control during reduction. (We're not helped by the fact that +the flattener re-flattens all the arguments every time around.) If we prevent +unification with type families, then the solver happens to use the equality +before expanding the type family. + +It would be lovely in the future to revisit this problem and remove this +extra, unnecessary check. But we retain it for now as it seems to work +better in practice. + +Note [Refactoring hazard: checkTauTvUpdate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I (Richard E.) have a sad story about refactoring this code, retained here +to prevent others (or a future me!) from falling into the same traps. + +It all started with #11407, which was caused by the fact that the TyVarTy +case of defer_me didn't look in the kind. But it seemed reasonable to +simply remove the defer_me check instead. + +It referred to two Notes (since removed) that were out of date, and the +fast_check code in occurCheckExpand seemed to do just about the same thing as +defer_me. The one piece that defer_me did that wasn't repeated by +occurCheckExpand was the type-family check. (See Note [Prevent unification +with type families].) So I checked the result of occurCheckExpand for any +type family occurrences and deferred if there were any. This was done +in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 . + +This approach turned out not to be performant, because the expanded +type was bigger than the original type, and tyConsOfType (needed to +see if there are any type family occurrences) looks through type +synonyms. So it then struck me that we could dispense with the +defer_me check entirely. This simplified the code nicely, and it cut +the allocations in T5030 by half. But, as documented in Note [Prevent +unification with type families], this destroyed performance in +T3064. Regardless, I missed this regression and the change was +committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d . + +Bottom lines: + * defer_me is back, but now fixed w.r.t. #11407. + * Tread carefully before you start to refactor here. There can be + lots of hard-to-predict consequences. + +Note [Type synonyms and the occur check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking we try to update a variable with type synonyms not +expanded, which improves later error messages, unless looking +inside a type synonym may help resolve a spurious occurs check +error. Consider: + type A a = () + + f :: (A a -> a -> ()) -> () + f = \ _ -> () + + x :: () + x = f (\ x p -> p x) + +We will eventually get a constraint of the form t ~ A t. The ok function above will +properly expand the type (A t) to just (), which is ok to be unified with t. If we had +unified with the original type A t, we would lead the type checker into an infinite loop. + +Hence, if the occurs check fails for a type synonym application, then (and *only* then), +the ok function expands the synonym to detect opportunities for occurs check success using +the underlying definition of the type synonym. + +The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact, +function @occ_check_ok@. + +Note [Non-TcTyVars in GHC.Tc.Utils.Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because the same code is now shared between unifying types and unifying +kinds, we sometimes will see proper TyVars floating around the unifier. +Example (from test case polykinds/PolyKinds12): + + type family Apply (f :: k1 -> k2) (x :: k1) :: k2 + type instance Apply g y = g y + +When checking the instance declaration, we first *kind-check* the LHS +and RHS, discovering that the instance really should be + + type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y + +During this kind-checking, all the tyvars will be TcTyVars. Then, however, +as a second pass, we desugar the RHS (which is done in functions prefixed +with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper +TyVars, not TcTyVars, get some kind unification must happen. + +Thus, we always check if a TyVar is a TcTyVar before asking if it's a +meta-tyvar. + +This used to not be necessary for type-checking (that is, before * :: *) +because expressions get desugared via an algorithm separate from +type-checking (with wrappers, etc.). Types get desugared very differently, +causing this wibble in behavior seen here. +-} + +data LookupTyVarResult -- The result of a lookupTcTyVar call + = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv + | Filled TcType + +lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult +lookupTcTyVar tyvar + | MetaTv { mtv_ref = ref } <- details + = do { meta_details <- readMutVar ref + ; case meta_details of + Indirect ty -> return (Filled ty) + Flexi -> do { is_touchable <- isTouchableTcM tyvar + -- Note [Unifying untouchables] + ; if is_touchable then + return (Unfilled details) + else + return (Unfilled vanillaSkolemTv) } } + | otherwise + = return (Unfilled details) + where + details = tcTyVarDetails tyvar + +{- +Note [Unifying untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat an untouchable type variable as if it was a skolem. That +ensures it won't unify with anything. It's a slight hack, because +we return a made-up TcTyVarDetails, but I think it works smoothly. +-} + +-- | Breaks apart a function kind into its pieces. +matchExpectedFunKind + :: Outputable fun + => fun -- ^ type, only for errors + -> Arity -- ^ n: number of desired arrows + -> TcKind -- ^ fun_ kind + -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) + +matchExpectedFunKind hs_ty n k = go n k + where + go 0 k = return (mkNomReflCo k) + + go n k | Just k' <- tcView k = go n k' + + go n k@(TyVarTy kvar) + | isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> go n fun_kind + Flexi -> defer n k } + + go n (FunTy _ w arg res) + = do { co <- go (n-1) res + ; return (mkTcFunCo Nominal (mkTcNomReflCo w) (mkTcNomReflCo arg) co) } + + go n other + = defer n other + + defer n k + = do { arg_kinds <- newMetaKindVars n + ; res_kind <- newMetaKindVar + ; let new_fun = mkVisFunTysMany arg_kinds res_kind + origin = TypeEqOrigin { uo_actual = k + , uo_expected = new_fun + , uo_thing = Just (ppr hs_ty) + , uo_visible = True + } + ; uType KindLevel origin k new_fun } + +{- ********************************************************************* +* * + Occurrence checking +* * +********************************************************************* -} + + +{- Note [Occurrence checking: look inside kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are considering unifying + (alpha :: *) ~ Int -> (beta :: alpha -> alpha) +This may be an error (what is that alpha doing inside beta's kind?), +but we must not make the mistake of actually unifying or we'll +build an infinite data structure. So when looking for occurrences +of alpha in the rhs, we must look in the kinds of type variables +that occur there. + +NB: we may be able to remove the problem via expansion; see + Note [Occurs check expansion]. So we have to try that. + +Note [Checking for foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unless we have -XImpredicativeTypes (which is a totally unsupported +feature), we do not want to unify + alpha ~ (forall a. a->a) -> Int +So we look for foralls hidden inside the type, and it's convenient +to do that at the same time as the occurs check (which looks for +occurrences of alpha). + +However, it's not just a question of looking for foralls /anywhere/! +Consider + (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) +This is legal; e.g. dependent/should_compile/T11635. + +We don't want to reject it because of the forall in beta's kind, +but (see Note [Occurrence checking: look inside kinds]) we do +need to look in beta's kind. So we carry a flag saying if a 'forall' +is OK, and switch the flag on when stepping inside a kind. + +Why is it OK? Why does it not count as impredicative polymorphism? +The reason foralls are bad is because we reply on "seeing" foralls +when doing implicit instantiation. But the forall inside the kind is +fine. We'll generate a kind equality constraint + (forall k. k->*) ~ (forall k. k->*) +to check that the kinds of lhs and rhs are compatible. If alpha's +kind had instead been + (alpha :: kappa) +then this kind equality would rightly complain about unifying kappa +with (forall k. k->*) + +-} + +data MetaTyVarUpdateResult a + = MTVU_OK a + | MTVU_Bad -- Forall, predicate, or type family + | MTVU_HoleBlocker -- Blocking coercion hole + -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" + | MTVU_Occurs + deriving (Functor) + +instance Applicative MetaTyVarUpdateResult where + pure = MTVU_OK + (<*>) = ap + +instance Monad MetaTyVarUpdateResult where + MTVU_OK x >>= k = k x + MTVU_Bad >>= _ = MTVU_Bad + MTVU_HoleBlocker >>= _ = MTVU_HoleBlocker + MTVU_Occurs >>= _ = MTVU_Occurs + +instance Outputable a => Outputable (MetaTyVarUpdateResult a) where + ppr (MTVU_OK a) = text "MTVU_OK" <+> ppr a + ppr MTVU_Bad = text "MTVU_Bad" + ppr MTVU_HoleBlocker = text "MTVU_HoleBlocker" + ppr MTVU_Occurs = text "MTVU_Occurs" + +occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult () +-- Just for error-message generation; so we return MetaTyVarUpdateResult +-- so the caller can report the right kind of error +-- Check whether +-- a) the given variable occurs in the given type. +-- b) there is a forall in the type (unless we have -XImpredicativeTypes) +occCheckForErrors dflags tv ty + = case preCheck dflags True tv ty of + MTVU_OK _ -> MTVU_OK () + MTVU_Bad -> MTVU_Bad + MTVU_HoleBlocker -> MTVU_HoleBlocker + MTVU_Occurs -> case occCheckExpand [tv] ty of + Nothing -> MTVU_Occurs + Just _ -> MTVU_OK () + +---------------- +metaTyVarUpdateOK :: DynFlags + -> TcTyVar -- tv :: k1 + -> TcType -- ty :: k2 + -> MetaTyVarUpdateResult TcType -- possibly-expanded ty +-- (metaTyVarUpdateOK tv ty) +-- We are about to update the meta-tyvar tv with ty +-- Check (a) that tv doesn't occur in ty (occurs check) +-- (b) that ty does not have any foralls +-- (in the impredicative case), or type functions +-- (c) that ty does not have any blocking coercion holes +-- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" +-- +-- We have two possible outcomes: +-- (1) Return the type to update the type variable with, +-- [we know the update is ok] +-- (2) Return Nothing, +-- [the update might be dodgy] +-- +-- Note that "Nothing" does not mean "definite error". For example +-- type family F a +-- type instance F Int = Int +-- consider +-- a ~ F a +-- This is perfectly reasonable, if we later get a ~ Int. For now, though, +-- we return Nothing, leaving it to the later constraint simplifier to +-- sort matters out. +-- +-- See Note [Refactoring hazard: checkTauTvUpdate] + +metaTyVarUpdateOK dflags tv ty + = case preCheck dflags False tv ty of + -- False <=> type families not ok + -- See Note [Prevent unification with type families] + MTVU_OK _ -> MTVU_OK ty + MTVU_Bad -> MTVU_Bad -- forall, predicate, type function + MTVU_HoleBlocker -> MTVU_HoleBlocker -- coercion hole + MTVU_Occurs -> case occCheckExpand [tv] ty of + Just expanded_ty -> MTVU_OK expanded_ty + Nothing -> MTVU_Occurs + +preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () +-- A quick check for +-- (a) a forall type (unless -XImpredicativeTypes) +-- (b) a predicate type (unless -XImpredicativeTypes) +-- (c) a type family +-- (d) a blocking coercion hole +-- (e) an occurrence of the type variable (occurs check) +-- +-- For (a), (b), and (c) we check only the top level of the type, NOT +-- inside the kinds of variables it mentions. For (d) we look deeply +-- in coercions, and for (e) we do look in the kinds of course. + +preCheck dflags ty_fam_ok tv ty + = fast_check ty + where + details = tcTyVarDetails tv + impredicative_ok = canUnifyWithPolyType dflags details + + ok :: MetaTyVarUpdateResult () + ok = MTVU_OK () + + fast_check :: TcType -> MetaTyVarUpdateResult () + fast_check (TyVarTy tv') + | tv == tv' = MTVU_Occurs + | otherwise = fast_check_occ (tyVarKind tv') + -- See Note [Occurrence checking: look inside kinds] + + fast_check (TyConApp tc tys) + | bad_tc tc = MTVU_Bad + | otherwise = mapM fast_check tys >> ok + fast_check (LitTy {}) = ok + fast_check (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) + | InvisArg <- af + , not impredicative_ok = MTVU_Bad + | otherwise = fast_check w >> fast_check a >> fast_check r + fast_check (AppTy fun arg) = fast_check fun >> fast_check arg + fast_check (CastTy ty co) = fast_check ty >> fast_check_co co + fast_check (CoercionTy co) = fast_check_co co + fast_check (ForAllTy (Bndr tv' _) ty) + | not impredicative_ok = MTVU_Bad + | tv == tv' = ok + | otherwise = do { fast_check_occ (tyVarKind tv') + ; fast_check_occ ty } + -- Under a forall we look only for occurrences of + -- the type variable + + -- For kinds, we only do an occurs check; we do not worry + -- about type families or foralls + -- See Note [Checking for foralls] + fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs + | otherwise = ok + + -- no bother about impredicativity in coercions, as they're + -- inferred + fast_check_co co | not (gopt Opt_DeferTypeErrors dflags) + , badCoercionHoleCo co = MTVU_HoleBlocker + -- Wrinkle (4b) in "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds] + + | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs + | otherwise = ok + + bad_tc :: TyCon -> Bool + bad_tc tc + | not (impredicative_ok || isTauTyCon tc) = True + | not (ty_fam_ok || isFamFreeTyCon tc) = True + | otherwise = False + +canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool +canUnifyWithPolyType dflags details + = case details of + MetaTv { mtv_info = TyVarTv } -> False + MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags + _other -> True + -- We can have non-meta tyvars in given constraints diff --git a/GHC/Tc/Utils/Unify.hs-boot b/GHC/Tc/Utils/Unify.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Unify.hs-boot @@ -0,0 +1,18 @@ +module GHC.Tc.Utils.Unify where + +import GHC.Prelude +import GHC.Tc.Utils.TcType ( TcTauType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper ) +import GHC.Tc.Types.Origin ( CtOrigin ) +import GHC.Hs.Expr ( HsExpr ) +import GHC.Hs.Type ( HsType, Mult ) +import GHC.Hs.Extension ( GhcRn ) + +-- This boot file exists only to tie the knot between +-- GHC.Tc.Utils.Unify and Inst + +unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion +unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion + +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper diff --git a/GHC/Tc/Utils/Zonk.hs b/GHC/Tc/Utils/Zonk.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/Zonk.hs @@ -0,0 +1,1952 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + +-} + +{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Specialisations of the @HsSyn@ syntax for the typechecker +-- +-- This module is an extension of @HsSyn@ syntax, for use in the type checker. +module GHC.Tc.Utils.Zonk ( + -- * Extracting types from HsSyn + hsLitType, hsPatType, hsLPatType, + + -- * Other HsSyn functions + mkHsDictLet, mkHsApp, + mkHsAppTy, mkHsCaseAlt, + shortCutLit, hsOverLitName, + conLikeResTy, + + -- * re-exported from TcMonad + TcId, TcIdSet, + + -- * Zonking + -- | For a description of "zonking", see Note [What is zonking?] + -- in "GHC.Tc.Utils.TcMType" + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, + ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, + zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, + zonkTyBndrs, zonkTyBndrsX, + zonkTcTypeToType, zonkTcTypeToTypeX, + zonkTcTypesToTypes, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, + zonkTyVarOcc, + zonkCoToCo, + zonkEvBinds, zonkTcEvBinds, + zonkTcMethInfoToMethInfoX, + lookupTyVarOcc + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Hs +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.Predicate +import GHC.Tc.Utils.Monad +import GHC.Builtin.Names +import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) +import GHC.Tc.Types.Evidence +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Builtin.Types.Prim +import GHC.Core.TyCon +import GHC.Builtin.Types +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Driver.Types +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Platform +import GHC.Types.Basic +import GHC.Data.Maybe +import GHC.Types.SrcLoc +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Types.Unique.FM +import GHC.Core.Multiplicity +import GHC.Core + +import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) + +import Control.Monad +import Data.List ( partition ) +import Control.Arrow ( second ) + +{- +************************************************************************ +* * + Extracting the type from HsSyn +* * +************************************************************************ + +-} + +hsLPatType :: LPat GhcTc -> Type +hsLPatType (L _ p) = hsPatType p + +hsPatType :: Pat GhcTc -> Type +hsPatType (ParPat _ pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat _ lvar) = idType (unLoc lvar) +hsPatType (BangPat _ pat) = hsLPatType pat +hsPatType (LazyPat _ pat) = hsLPatType pat +hsPatType (LitPat _ lit) = hsLitType lit +hsPatType (AsPat _ var _) = idType (unLoc var) +hsPatType (ViewPat ty _ _) = ty +hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty +hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty +hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make +hsPatType (SumPat tys _ _ _ ) = mkSumTy tys +hsPatType (ConPat { pat_con = lcon + , pat_con_ext = ConPatTc + { cpt_arg_tys = tys + } + }) + = conLikeResTy (unLoc lcon) tys +hsPatType (SigPat ty _ _) = ty +hsPatType (NPat ty _ _ _) = ty +hsPatType (NPlusKPat ty _ _ _ _ _) = ty +hsPatType (XPat (CoPat _ _ ty)) = ty +hsPatType SplicePat{} = panic "hsPatType: SplicePat" + +hsLitType :: HsLit (GhcPass p) -> TcType +hsLitType (HsChar _ _) = charTy +hsLitType (HsCharPrim _ _) = charPrimTy +hsLitType (HsString _ _) = stringTy +hsLitType (HsStringPrim _ _) = addrPrimTy +hsLitType (HsInt _ _) = intTy +hsLitType (HsIntPrim _ _) = intPrimTy +hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord64Prim _ _) = word64PrimTy +hsLitType (HsInteger _ _ ty) = ty +hsLitType (HsRat _ _ ty) = ty +hsLitType (HsFloatPrim _ _) = floatPrimTy +hsLitType (HsDoublePrim _ _) = doublePrimTy + +-- Overloaded literals. Here mainly because it uses isIntTy etc + +shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) +shortCutLit platform (HsIntegral int@(IL src neg i)) ty + | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) + | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O + +shortCutLit _ (HsFractional f) ty + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing + +shortCutLit _ (HsIsString src s) ty + | isStringTy ty = Just (HsLit noExtField (HsString src s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc +mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) + +------------------------------ +hsOverLitName :: OverLitVal -> Name +-- Get the canonical 'fromX' name for a particular OverLitVal +hsOverLitName (HsIntegral {}) = fromIntegerName +hsOverLitName (HsFractional {}) = fromRationalName +hsOverLitName (HsIsString {}) = fromStringName + +{- +************************************************************************ +* * +\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +* * +************************************************************************ + +The rest of the zonking is done *after* typechecking. +The main zonking pass runs over the bindings + + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void + c) convert each TcId to an Id by zonking its type + +The type variables are converted by binding mutable tyvars to immutable ones +and then zonking as normal. + +The Ids are converted by binding them in the normal Tc envt; that +way we maintain sharing; eg an Id is zonked at its binding site and they +all occurrences of that Id point to the common zonked copy + +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. +-} + +-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. + +-- | See Note [The ZonkEnv] +-- Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Utils.TcMType". +data ZonkEnv -- See Note [The ZonkEnv] + = ZonkEnv { ze_flexi :: ZonkFlexi + , ze_tv_env :: TyCoVarEnv TyCoVar + , ze_id_env :: IdEnv Id + , ze_meta_tv_env :: TcRef (TyVarEnv Type) } + +{- Note [The ZonkEnv] +~~~~~~~~~~~~~~~~~~~~~ +* ze_flexi :: ZonkFlexi says what to do with a + unification variable that is still un-unified. + See Note [Un-unified unification variables] + +* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site + of a tyvar or covar, we zonk the kind right away and add a mapping + to the env. This prevents re-zonking the kind at every + occurrence. But this is *just* an optimisation. + +* ze_id_env : IdEnv Id promotes sharing among Ids, by making all + occurrences of the Id point to a single zonked copy, built at the + binding site. + + Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. + In a mutually recursive group + rec { f = ...g...; g = ...f... } + we want the occurrence of g to point to the one zonked Id for g, + and the same for f. + + Because it is knot-tied, we must be careful to consult it lazily. + Specifically, zonkIdOcc is not monadic. + +* ze_meta_tv_env: see Note [Sharing when zonking to Type] + + +Notes: + * We must be careful never to put coercion variables (which are Ids, + after all) in the knot-tied ze_id_env, because coercions can + appear in types, and we sometimes inspect a zonked type in this + module. [Question: where, precisely?] + + * In zonkTyVarOcc we consult ze_tv_env in a monadic context, + a second reason that ze_tv_env can't be monadic. + + * An obvious suggestion would be to have one VarEnv Var to + replace both ze_id_env and ze_tv_env, but that doesn't work + because of the knot-tying stuff mentioned above. + +Note [Un-unified unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do if we find a Flexi unification variable? +There are three possibilities: + +* DefaultFlexi: this is the common case, in situations like + length @alpha ([] @alpha) + It really doesn't matter what type we choose for alpha. But + we must choose a type! We can't leave mutable unification + variables floating around: after typecheck is complete, every + type variable occurrence must have a binding site. + + So we default it to 'Any' of the right kind. + + All this works for both type and kind variables (indeed + the two are the same thing). + +* SkolemiseFlexi: is a special case for the LHS of RULES. + See Note [Zonking the LHS of a RULE] + +* RuntimeUnkFlexi: is a special case for the GHCi debugger. + It's a way to have a variable that is not a mutable + unification variable, but doesn't have a binding site + either. +-} + +data ZonkFlexi -- See Note [Un-unified unification variables] + = DefaultFlexi -- Default unbound unification variables to Any + | SkolemiseFlexi -- Skolemise unbound unification variables + -- See Note [Zonking the LHS of a RULE] + | RuntimeUnkFlexi -- Used in the GHCi debugger + +instance Outputable ZonkEnv where + ppr (ZonkEnv { ze_tv_env = tv_env + , ze_id_env = id_env }) + = text "ZE" <+> braces (vcat + [ text "ze_tv_env =" <+> ppr tv_env + , text "ze_id_env =" <+> ppr id_env ]) + +-- The EvBinds have to already be zonked, but that's usually the case. +emptyZonkEnv :: TcM ZonkEnv +emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi + +mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv +mkEmptyZonkEnv flexi + = do { mtv_env_ref <- newTcRef emptyVarEnv + ; return (ZonkEnv { ze_flexi = flexi + , ze_tv_env = emptyVarEnv + , ze_id_env = emptyVarEnv + , ze_meta_tv_env = mtv_env_ref }) } + +initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b +initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi + ; thing_inside ze } + +-- | Extend the knot-tied environment. +extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv +extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids + -- NB: Don't look at the var to decide which env't to put it in. That + -- would end up knot-tying all the env'ts. + = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + -- Given coercion variables will actually end up here. That's OK though: + -- coercion variables are never looked up in the knot-tied env't, so zonking + -- them simply doesn't get optimised. No one gets hurt. An improvement (?) + -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the + -- recursive groups. But perhaps the time it takes to do the analysis is + -- more than the savings. + +extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv +extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars + = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] + , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + where + (tycovars, ids) = partition isTyCoVar vars + +extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv +extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id + = ze { ze_id_env = extendVarEnv id_env id id } + +extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv +extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv + = ze { ze_tv_env = extendVarEnv ty_env tv tv } + +setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv +setZonkType ze flexi = ze { ze_flexi = flexi } + +zonkEnvIds :: ZonkEnv -> TypeEnv +zonkEnvIds (ZonkEnv { ze_id_env = id_env}) + = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- immediately by creating a TypeEnv + +zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id +zonkLIdOcc env = mapLoc (zonkIdOcc env) + +zonkIdOcc :: ZonkEnv -> TcId -> Id +-- Ids defined in this module should be in the envt; +-- ignore others. (Actually, data constructors are also +-- not LocalVars, even when locally defined, but that is fine.) +-- (Also foreign-imported things aren't currently in the ZonkEnv; +-- that's ok because they don't need zonking.) +-- +-- Actually, Template Haskell works in 'chunks' of declarations, and +-- an earlier chunk won't be in the 'env' that the zonking phase +-- carries around. Instead it'll be in the tcg_gbl_env, already fully +-- zonked. There's no point in looking it up there (except for error +-- checking), and it's not conveniently to hand; hence the simple +-- 'orElse' case in the LocalVar branch. +-- +-- Even without template splices, in module Main, the checking of +-- 'main' is done as a separate chunk. +zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id + | isLocalVar id = lookupVarEnv id_env id `orElse` + id + | otherwise = id + +zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] +zonkIdOccs env ids = map (zonkIdOcc env) ids + +-- zonkIdBndr is used *after* typechecking to get the Id's type +-- to its final form. The TyVarEnv give +zonkIdBndr :: ZonkEnv -> TcId -> TcM Id +zonkIdBndr env v + = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) + ensureNotLevPoly ty' + (text "In the type of binder" <+> quotes (ppr v)) + + return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w')) + +zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] +zonkIdBndrs env ids = mapM (zonkIdBndr env) ids + +zonkTopBndrs :: [TcId] -> TcM [Id] +zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids + +zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc) +zonkFieldOcc env (FieldOcc sel lbl) + = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel + +zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) +zonkEvBndrsX = mapAccumLM zonkEvBndrX + +zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) +-- Works for dictionaries and coercions +zonkEvBndrX env var + = do { var' <- zonkEvBndr env var + ; return (extendZonkEnv env [var'], var') } + +zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar +-- Works for dictionaries and coercions +-- Does not extend the ZonkEnv +zonkEvBndr env var + = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var + +{- +zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm +zonkEvVarOcc env v + | isCoVar v + = EvCoercion <$> zonkCoVarOcc env v + | otherwise + = return (EvId $ zonkIdOcc env v) +-} + +zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) +zonkCoreBndrX env v + | isId v = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnv env v', v') } + | otherwise = zonkTyBndrX env v + +zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var]) +zonkCoreBndrsX = mapAccumLM zonkCoreBndrX + +zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar]) +zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs + +zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) +zonkTyBndrsX = mapAccumLM zonkTyBndrX + +zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced +-- +-- It does not clone: the new TyVar has the sane Name +-- as the old one. This important when zonking the +-- TyVarBndrs of a TyCon, whose Names may scope. +zonkTyBndrX env tv + = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) ) + do { ki <- zonkTcTypeToTypeX env (tyVarKind tv) + -- Internal names tidy up better, for iface files. + ; let tv' = mkTyVar (tyVarName tv) ki + ; return (extendTyZonkEnv env tv', tv') } + +zonkTyVarBinders :: [VarBndr TcTyVar vis] + -> TcM (ZonkEnv, [VarBndr TyVar vis]) +zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs + +zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] + -> TcM (ZonkEnv, [VarBndr TyVar vis]) +zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX + +zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis + -> TcM (ZonkEnv, VarBndr TyVar vis) +-- Takes a TcTyVar and guarantees to return a TyVar +zonkTyVarBinderX env (Bndr tv vis) + = do { (env', tv') <- zonkTyBndrX env tv + ; return (env', Bndr tv' vis) } + +zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) +zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e + +zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc) +zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e + +zonkTopDecls :: Bag EvBind + -> LHsBinds GhcTc + -> [LRuleDecl GhcTc] -> [LTcSpecPrag] + -> [LForeignDecl GhcTc] + -> TcM (TypeEnv, + Bag EvBind, + LHsBinds GhcTc, + [LForeignDecl GhcTc], + [LTcSpecPrag], + [LRuleDecl GhcTc]) +zonkTopDecls ev_binds binds rules imp_specs fords + = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds + ; (env2, binds') <- zonkRecMonoBinds env1 binds + -- Top level is implicitly recursive + ; rules' <- zonkRules env2 rules + ; specs' <- zonkLTcSpecPrags env2 imp_specs + ; fords' <- zonkForeignExports env2 fords + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } + +--------------------------------------------- +zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc + -> TcM (ZonkEnv, HsLocalBinds GhcTc) +zonkLocalBinds env (EmptyLocalBinds x) + = return (env, (EmptyLocalBinds x)) + +zonkLocalBinds _ (HsValBinds _ (ValBinds {})) + = panic "zonkLocalBinds" -- Not in typechecker output + +zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) + = do { (env1, new_binds) <- go env binds + ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } + where + go env [] + = return (env, []) + go env ((r,b):bs) + = do { (env1, b') <- zonkRecMonoBinds env b + ; (env2, bs') <- go env1 bs + ; return (env2, (r,b'):bs') } + +zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do + new_binds <- mapM (wrapLocM zonk_ip_bind) binds + let + env1 = extendIdZonkEnvRec env + [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] + (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds + return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) + where + zonk_ip_bind (IPBind x n e) + = do n' <- mapIPNameTc (zonkIdBndr env) n + e' <- zonkLExpr env e + return (IPBind x n' e') + +--------------------------------------------- +zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) +zonkRecMonoBinds env binds + = fixM (\ ~(_, new_binds) -> do + { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) + ; binds' <- zonkMonoBinds env1 binds + ; return (env1, binds') }) + +--------------------------------------------- +zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc) +zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds + +zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc) +zonk_lbind env = wrapLocM (zonk_bind env) + +zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) +zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc fvs ty}) + = do { (_env, new_pat) <- zonkPat env pat -- Env already extended + ; new_grhss <- zonkGRHSs env zonkLExpr grhss + ; new_ty <- zonkTcTypeToTypeX env ty + ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss + , pat_ext = NPatBindTc fvs new_ty }) } + +zonk_bind env (VarBind { var_ext = x + , var_id = var, var_rhs = expr }) + = do { new_var <- zonkIdBndr env var + ; new_expr <- zonkLExpr env expr + ; return (VarBind { var_ext = x + , var_id = new_var + , var_rhs = new_expr }) } + +zonk_bind env bind@(FunBind { fun_id = L loc var + , fun_matches = ms + , fun_ext = co_fn }) + = do { new_var <- zonkIdBndr env var + ; (env1, new_co_fn) <- zonkCoFn env co_fn + ; new_ms <- zonkMatchGroup env1 zonkLExpr ms + ; return (bind { fun_id = L loc new_var + , fun_matches = new_ms + , fun_ext = new_co_fn }) } + +zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs + , abs_ev_binds = ev_binds + , abs_exports = exports + , abs_binds = val_binds + , abs_sig = has_sig }) + = ASSERT( all isImmutableTyVar tyvars ) + do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars + ; (env1, new_evs) <- zonkEvBndrsX env0 evs + ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds + ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> + do { let env3 = extendIdZonkEnvRec env2 $ + collectHsBindsBinders new_val_binds + ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds + ; new_exports <- mapM (zonk_export env3) exports + ; return (new_val_binds, new_exports) } + ; return (AbsBinds { abs_ext = noExtField + , abs_tvs = new_tyvars, abs_ev_vars = new_evs + , abs_ev_binds = new_ev_binds + , abs_exports = new_exports, abs_binds = new_val_bind + , abs_sig = has_sig }) } + where + zonk_val_bind env lbind + | has_sig + , (L loc bind@(FunBind { fun_id = (L mloc mono_id) + , fun_matches = ms + , fun_ext = co_fn })) <- lbind + = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id + -- Specifically /not/ zonkIdBndr; we do not + -- want to complain about a levity-polymorphic binder + ; (env', new_co_fn) <- zonkCoFn env co_fn + ; new_ms <- zonkMatchGroup env' zonkLExpr ms + ; return $ L loc $ + bind { fun_id = L mloc new_mono_id + , fun_matches = new_ms + , fun_ext = new_co_fn } } + | otherwise + = zonk_lbind env lbind -- The normal case + + zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc) + zonk_export env (ABE{ abe_ext = x + , abe_wrap = wrap + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = prags }) + = do new_poly_id <- zonkIdBndr env poly_id + (_, new_wrap) <- zonkCoFn env wrap + new_prags <- zonkSpecPrags env prags + return (ABE{ abe_ext = x + , abe_wrap = new_wrap + , abe_poly = new_poly_id + , abe_mono = zonkIdOcc env mono_id + , abe_prags = new_prags }) + +zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) + = do { id' <- zonkIdBndr env id + ; (env1, lpat') <- zonkPat env lpat + ; let details' = zonkPatSynDetails env1 details + ; (_env2, dir') <- zonkPatSynDir env1 dir + ; return $ PatSynBind x $ + bind { psb_id = L loc id' + , psb_args = details' + , psb_def = lpat' + , psb_dir = dir' } } + +zonkPatSynDetails :: ZonkEnv + -> HsPatSynDetails (Located TcId) + -> HsPatSynDetails (Located Id) +zonkPatSynDetails env (PrefixCon as) + = PrefixCon (map (zonkLIdOcc env) as) +zonkPatSynDetails env (InfixCon a1 a2) + = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) +zonkPatSynDetails env (RecCon flds) + = RecCon (map (fmap (zonkLIdOcc env)) flds) + +zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc + -> TcM (ZonkEnv, HsPatSynDir GhcTc) +zonkPatSynDir env Unidirectional = return (env, Unidirectional) +zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) +zonkPatSynDir env (ExplicitBidirectional mg) = do + mg' <- zonkMatchGroup env zonkLExpr mg + return (env, ExplicitBidirectional mg') + +zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags +zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod +zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps + ; return (SpecPrags ps') } + +zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] +zonkLTcSpecPrags env ps + = mapM zonk_prag ps + where + zonk_prag (L loc (SpecPrag id co_fn inl)) + = do { (_, co_fn') <- zonkCoFn env co_fn + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } + +{- +************************************************************************ +* * +\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} +* * +************************************************************************ +-} + +zonkMatchGroup :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) + -> MatchGroup GhcTc (Located (body GhcTc)) + -> TcM (MatchGroup GhcTc (Located (body GhcTc))) +zonkMatchGroup env zBody (MG { mg_alts = L l ms + , mg_ext = MatchGroupTc arg_tys res_ty + , mg_origin = origin }) + = do { ms' <- mapM (zonkMatch env zBody) ms + ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys + ; res_ty' <- zonkTcTypeToTypeX env res_ty + ; return (MG { mg_alts = L l ms' + , mg_ext = MatchGroupTc arg_tys' res_ty' + , mg_origin = origin }) } + +zonkMatch :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) + -> LMatch GhcTc (Located (body GhcTc)) + -> TcM (LMatch GhcTc (Located (body GhcTc))) +zonkMatch env zBody (L loc match@(Match { m_pats = pats + , m_grhss = grhss })) + = do { (env1, new_pats) <- zonkPats env pats + ; new_grhss <- zonkGRHSs env1 zBody grhss + ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } + +------------------------------------------------------------------------- +zonkGRHSs :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) + -> GRHSs GhcTc (Located (body GhcTc)) + -> TcM (GRHSs GhcTc (Located (body GhcTc))) + +zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do + (new_env, new_binds) <- zonkLocalBinds env binds + let + zonk_grhs (GRHS xx guarded rhs) + = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded + new_rhs <- zBody env2 rhs + return (GRHS xx new_guarded new_rhs) + new_grhss <- mapM (wrapLocM zonk_grhs) grhss + return (GRHSs x new_grhss (L l new_binds)) + +{- +************************************************************************ +* * +\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} +* * +************************************************************************ +-} + +zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc] +zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) +zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc) + +zonkLExprs env exprs = mapM (zonkLExpr env) exprs +zonkLExpr env expr = wrapLocM (zonkExpr env) expr + +zonkExpr env (HsVar x (L l id)) + = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) + return (HsVar x (L l (zonkIdOcc env id))) + +zonkExpr _ e@(HsConLikeOut {}) = return e + +zonkExpr _ (HsIPVar x id) + = return (HsIPVar x id) + +zonkExpr _ e@HsOverLabel{} = return e + +zonkExpr env (HsLit x (HsRat e f ty)) + = do new_ty <- zonkTcTypeToTypeX env ty + return (HsLit x (HsRat e f new_ty)) + +zonkExpr _ (HsLit x lit) + = return (HsLit x lit) + +zonkExpr env (HsOverLit x lit) + = do { lit' <- zonkOverLit env lit + ; return (HsOverLit x lit') } + +zonkExpr env (HsLam x matches) + = do new_matches <- zonkMatchGroup env zonkLExpr matches + return (HsLam x new_matches) + +zonkExpr env (HsLamCase x matches) + = do new_matches <- zonkMatchGroup env zonkLExpr matches + return (HsLamCase x new_matches) + +zonkExpr env (HsApp x e1 e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (HsApp x new_e1 new_e2) + +zonkExpr env (HsAppType ty e t) + = do new_e <- zonkLExpr env e + new_ty <- zonkTcTypeToTypeX env ty + return (HsAppType new_ty new_e t) + -- NB: the type is an HsType; can't zonk that! + +zonkExpr _ e@(HsRnBracketOut _ _ _) + = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) + +zonkExpr env (HsTcBracketOut x wrap body bs) + = do wrap' <- traverse zonkQuoteWrap wrap + bs' <- mapM (zonk_b env) bs + return (HsTcBracketOut x wrap' body bs') + where + zonkQuoteWrap (QuoteWrapper ev ty) = do + let ev' = zonkIdOcc env ev + ty' <- zonkTcTypeToTypeX env ty + return (QuoteWrapper ev' ty') + + zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e + return (PendingTcSplice n e') + +zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) = + runTopSplice s >>= zonkExpr env + +zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) + +zonkExpr env (OpApp fixity e1 op e2) + = do new_e1 <- zonkLExpr env e1 + new_op <- zonkLExpr env op + new_e2 <- zonkLExpr env e2 + return (OpApp fixity new_e1 new_op new_e2) + +zonkExpr env (NegApp x expr op) + = do (env', new_op) <- zonkSyntaxExpr env op + new_expr <- zonkLExpr env' expr + return (NegApp x new_expr new_op) + +zonkExpr env (HsPar x e) + = do new_e <- zonkLExpr env e + return (HsPar x new_e) + +zonkExpr env (SectionL x expr op) + = do new_expr <- zonkLExpr env expr + new_op <- zonkLExpr env op + return (SectionL x new_expr new_op) + +zonkExpr env (SectionR x op expr) + = do new_op <- zonkLExpr env op + new_expr <- zonkLExpr env expr + return (SectionR x new_op new_expr) + +zonkExpr env (ExplicitTuple x tup_args boxed) + = do { new_tup_args <- mapM zonk_tup_arg tup_args + ; return (ExplicitTuple x new_tup_args boxed) } + where + zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e + ; return (L l (Present x e')) } + zonk_tup_arg (L l (Missing t)) = do { t' <- zonkScaledTcTypeToTypeX env t + ; return (L l (Missing t')) } + + +zonkExpr env (ExplicitSum args alt arity expr) + = do new_args <- mapM (zonkTcTypeToTypeX env) args + new_expr <- zonkLExpr env expr + return (ExplicitSum new_args alt arity new_expr) + +zonkExpr env (HsCase x expr ms) + = do new_expr <- zonkLExpr env expr + new_ms <- zonkMatchGroup env zonkLExpr ms + return (HsCase x new_expr new_ms) + +zonkExpr env (HsIf x e1 e2 e3) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_e3 <- zonkLExpr env e3 + return (HsIf x new_e1 new_e2 new_e3) + +zonkExpr env (HsMultiIf ty alts) + = do { alts' <- mapM (wrapLocM zonk_alt) alts + ; ty' <- zonkTcTypeToTypeX env ty + ; return $ HsMultiIf ty' alts' } + where zonk_alt (GRHS x guard expr) + = do { (env', guard') <- zonkStmts env zonkLExpr guard + ; expr' <- zonkLExpr env' expr + ; return $ GRHS x guard' expr' } + +zonkExpr env (HsLet x (L l binds) expr) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_expr <- zonkLExpr new_env expr + return (HsLet x (L l new_binds) new_expr) + +zonkExpr env (HsDo ty do_or_lc (L l stmts)) + = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts + new_ty <- zonkTcTypeToTypeX env ty + return (HsDo new_ty do_or_lc (L l new_stmts)) + +zonkExpr env (ExplicitList ty wit exprs) + = do (env1, new_wit) <- zonkWit env wit + new_ty <- zonkTcTypeToTypeX env1 ty + new_exprs <- zonkLExprs env1 exprs + return (ExplicitList new_ty new_wit new_exprs) + where zonkWit env Nothing = return (env, Nothing) + zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln + +zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) + ; new_rbinds <- zonkRecFields env rbinds + ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } + , rcon_flds = new_rbinds }) } + +zonkExpr env (RecordUpd { rupd_flds = rbinds + , rupd_expr = expr + , rupd_ext = RecordUpdTc + { rupd_cons = cons, rupd_in_tys = in_tys + , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) + = do { new_expr <- zonkLExpr env expr + ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys + ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys + ; new_rbinds <- zonkRecUpdFields env rbinds + ; (_, new_recwrap) <- zonkCoFn env req_wrap + ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds + , rupd_ext = RecordUpdTc + { rupd_cons = cons, rupd_in_tys = new_in_tys + , rupd_out_tys = new_out_tys + , rupd_wrap = new_recwrap }}) } + +zonkExpr env (ExprWithTySig _ e ty) + = do { e' <- zonkLExpr env e + ; return (ExprWithTySig noExtField e' ty) } + +zonkExpr env (ArithSeq expr wit info) + = do (env1, new_wit) <- zonkWit env wit + new_expr <- zonkExpr env expr + new_info <- zonkArithSeq env1 info + return (ArithSeq new_expr new_wit new_info) + where zonkWit env Nothing = return (env, Nothing) + zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln + +zonkExpr env (HsPragE x prag expr) + = do new_expr <- zonkLExpr env expr + return (HsPragE x prag new_expr) + +-- arrow notation extensions +zonkExpr env (HsProc x pat body) + = do { (env1, new_pat) <- zonkPat env pat + ; new_body <- zonkCmdTop env1 body + ; return (HsProc x new_pat new_body) } + +-- StaticPointers extension +zonkExpr env (HsStatic fvs expr) + = HsStatic fvs <$> zonkLExpr env expr + +zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr))) + = do (env1, new_co_fn) <- zonkCoFn env co_fn + new_expr <- zonkExpr env1 expr + return (XExpr (WrapExpr (HsWrap new_co_fn new_expr))) + +zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b))) + = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b + +zonkExpr _ e@(HsUnboundVar {}) + = return e + +zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) + +------------------------------------------------------------------------- +{- +Note [Skolems in zonkSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider rebindable syntax with something like + + (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' + +The x and y become skolems that are in scope when type-checking the +arguments to the bind. This means that we must extend the ZonkEnv with +these skolems when zonking the arguments to the bind. But the skolems +are different between the two arguments, and so we should theoretically +carry around different environments to use for the different arguments. + +However, this becomes a logistical nightmare, especially in dealing with +the more exotic Stmt forms. So, we simplify by making the critical +assumption that the uniques of the skolems are different. (This assumption +is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.) +Now, we can safely just extend one environment. +-} + +-- See Note [Skolems in zonkSyntaxExpr] +zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc + -> TcM (ZonkEnv, SyntaxExpr GhcTc) +zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = do { (env0, res_wrap') <- zonkCoFn env res_wrap + ; expr' <- zonkExpr env0 expr + ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps + ; return (env1, SyntaxExprTc { syn_expr = expr' + , syn_arg_wraps = arg_wraps' + , syn_res_wrap = res_wrap' }) } +zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc) + +------------------------------------------------------------------------- + +zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc) +zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc) + +zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd + +zonkCmd env (XCmd (HsWrap w cmd)) + = do { (env1, w') <- zonkCoFn env w + ; cmd' <- zonkCmd env1 cmd + ; return (XCmd (HsWrap w' cmd')) } +zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_ty <- zonkTcTypeToTypeX env ty + return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) + +zonkCmd env (HsCmdArrForm x op f fixity args) + = do new_op <- zonkLExpr env op + new_args <- mapM (zonkCmdTop env) args + return (HsCmdArrForm x new_op f fixity new_args) + +zonkCmd env (HsCmdApp x c e) + = do new_c <- zonkLCmd env c + new_e <- zonkLExpr env e + return (HsCmdApp x new_c new_e) + +zonkCmd env (HsCmdLam x matches) + = do new_matches <- zonkMatchGroup env zonkLCmd matches + return (HsCmdLam x new_matches) + +zonkCmd env (HsCmdPar x c) + = do new_c <- zonkLCmd env c + return (HsCmdPar x new_c) + +zonkCmd env (HsCmdCase x expr ms) + = do new_expr <- zonkLExpr env expr + new_ms <- zonkMatchGroup env zonkLCmd ms + return (HsCmdCase x new_expr new_ms) + +zonkCmd env (HsCmdLamCase x ms) + = do new_ms <- zonkMatchGroup env zonkLCmd ms + return (HsCmdLamCase x new_ms) + +zonkCmd env (HsCmdIf x eCond ePred cThen cElse) + = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond + ; new_ePred <- zonkLExpr env1 ePred + ; new_cThen <- zonkLCmd env1 cThen + ; new_cElse <- zonkLCmd env1 cElse + ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } + +zonkCmd env (HsCmdLet x (L l binds) cmd) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_cmd <- zonkLCmd new_env cmd + return (HsCmdLet x (L l new_binds) new_cmd) + +zonkCmd env (HsCmdDo ty (L l stmts)) + = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts + new_ty <- zonkTcTypeToTypeX env ty + return (HsCmdDo new_ty (L l new_stmts)) + + + +zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc) +zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd + +zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) +zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) + = do new_cmd <- zonkLCmd env cmd + new_stack_tys <- zonkTcTypeToTypeX env stack_tys + new_ty <- zonkTcTypeToTypeX env ty + new_ids <- mapSndM (zonkExpr env) ids + + MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) ) + -- desugarer assumes that this is not levity polymorphic... + -- but indeed it should always be lifted due to the typing + -- rules for arrows + + return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) + +------------------------------------------------------------------------- +zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) +zonkCoFn env WpHole = return (env, WpHole) +zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; return (env2, WpCompose c1' c2') } +zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; t1' <- zonkScaledTcTypeToTypeX env2 t1 + ; return (env2, WpFun c1' c2' t1' d) } +zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co + ; return (env, WpCast co') } +zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev + ; return (env', WpEvLam ev') } +zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg + ; return (env, WpEvApp arg') } +zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) + do { (env', tv') <- zonkTyBndrX env tv + ; return (env', WpTyLam tv') } +zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty + ; return (env, WpTyApp ty') } +zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs + ; return (env1, WpLet bs') } +zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co + ; return (env, WpMultCoercion co') } + +------------------------------------------------------------------------- +zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc) +zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) + = do { ty' <- zonkTcTypeToTypeX env ty + ; e' <- zonkExpr env e + ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } + +------------------------------------------------------------------------- +zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc) + +zonkArithSeq env (From e) + = do new_e <- zonkLExpr env e + return (From new_e) + +zonkArithSeq env (FromThen e1 e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (FromThen new_e1 new_e2) + +zonkArithSeq env (FromTo e1 e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (FromTo new_e1 new_e2) + +zonkArithSeq env (FromThenTo e1 e2 e3) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_e3 <- zonkLExpr env e3 + return (FromThenTo new_e1 new_e2 new_e3) + + +------------------------------------------------------------------------- +zonkStmts :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) + -> [LStmt GhcTc (Located (body GhcTc))] + -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) +zonkStmts env _ [] = return (env, []) +zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s + ; (env2, ss') <- zonkStmts env1 zBody ss + ; return (env2, s' : ss') } + +zonkStmt :: ZonkEnv + -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) + -> Stmt GhcTc (Located (body GhcTc)) + -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) +zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) + = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op + ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty + ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs + ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs + , b <- bs] + env2 = extendIdZonkEnvRec env1 new_binders + ; new_mzip <- zonkExpr env2 mzip_op + ; return (env2 + , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} + where + zonk_branch :: ZonkEnv -> ParStmtBlock GhcTc GhcTc + -> TcM (ParStmtBlock GhcTc GhcTc) + zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) + = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts + ; (env3, new_return) <- zonkSyntaxExpr env2 return_op + ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) + new_return) } + +zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id + , recS_bind_fn = bind_id + , recS_ext = + RecStmtTc { recS_bind_ty = bind_ty + , recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty} }) + = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id + ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id + ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id + ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty + ; new_rvs <- zonkIdBndrs env3 rvs + ; new_lvs <- zonkIdBndrs env3 lvs + ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty + ; let env4 = extendIdZonkEnvRec env3 new_rvs + ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts + -- Zonk the ret-expressions in an envt that + -- has the polymorphic bindings in the envt + ; new_later_rets <- mapM (zonkExpr env5) later_rets + ; new_rec_rets <- mapM (zonkExpr env5) rec_rets + ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed + RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs + , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id + , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_ext = RecStmtTc + { recS_bind_ty = new_bind_ty + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets + , recS_ret_ty = new_ret_ty } }) } + +zonkStmt env zBody (BodyStmt ty body then_op guard_op) + = do (env1, new_then_op) <- zonkSyntaxExpr env then_op + (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op + new_body <- zBody env2 body + new_ty <- zonkTcTypeToTypeX env2 ty + return (env2, BodyStmt new_ty new_body new_then_op new_guard_op) + +zonkStmt env zBody (LastStmt x body noret ret_op) + = do (env1, new_ret) <- zonkSyntaxExpr env ret_op + new_body <- zBody env1 body + return (env, LastStmt x new_body noret new_ret) + +zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_ext = bind_arg_ty + , trS_fmap = liftM_op }) + = do { + ; (env1, bind_op') <- zonkSyntaxExpr env bind_op + ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty + ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts + ; by' <- fmapMaybeM (zonkLExpr env2) by + ; using' <- zonkLExpr env2 using + + ; (env3, return_op') <- zonkSyntaxExpr env2 return_op + ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap + ; liftM_op' <- zonkExpr env3 liftM_op + ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') + ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op' + , trS_ext = bind_arg_ty' + , trS_fmap = liftM_op' }) } + where + zonkBinderMapEntry env (oldBinder, newBinder) = do + let oldBinder' = zonkIdOcc env oldBinder + newBinder' <- zonkIdBndr env newBinder + return (oldBinder', newBinder') + +zonkStmt env _ (LetStmt x (L l binds)) + = do (env1, new_binds) <- zonkLocalBinds env binds + return (env1, LetStmt x (L l new_binds)) + +zonkStmt env zBody (BindStmt xbs pat body) + = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs) + ; new_w <- zonkTcTypeToTypeX env1 (xbstc_boundResultMult xbs) + ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs) + ; new_body <- zBody env1 body + ; (env2, new_pat) <- zonkPat env1 pat + ; new_fail <- case xbstc_failOp xbs of + Nothing -> return Nothing + Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f) + ; return ( env2 + , BindStmt (XBindStmtTc + { xbstc_bindOp = new_bind + , xbstc_boundResultType = new_bind_ty + , xbstc_boundResultMult = new_w + , xbstc_failOp = new_fail + }) + new_pat new_body) } + +-- Scopes: join > ops (in reverse order) > pats (in forward order) +-- > rest of stmts +zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) + = do { (env1, new_mb_join) <- zonk_join env mb_join + ; (env2, new_args) <- zonk_args env1 args + ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty + ; return ( env2 + , ApplicativeStmt new_body_ty new_args new_mb_join) } + where + zonk_join env Nothing = return (env, Nothing) + zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j + + get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc + get_pat (_, ApplicativeArgOne _ pat _ _) = pat + get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat + + replace_pat :: LPat GhcTc + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody) + = (op, ApplicativeArgOne fail_op pat a isBody) + replace_pat pat (op, ApplicativeArgMany x a b _ c) + = (op, ApplicativeArgMany x a b pat c) + + zonk_args env args + = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) + ; (env2, new_pats) <- zonkPats env1 (map get_pat args) + ; return (env2, zipWithEqual "zonkStmt" replace_pat + new_pats (reverse new_args_rev)) } + + -- these need to go backward, because if any operators are higher-rank, + -- later operators may introduce skolems that are in scope for earlier + -- arguments + zonk_args_rev env ((op, arg) : args) + = do { (env1, new_op) <- zonkSyntaxExpr env op + ; new_arg <- zonk_arg env1 arg + ; (env2, new_args) <- zonk_args_rev env1 args + ; return (env2, (new_op, new_arg) : new_args) } + zonk_args_rev env [] = return (env, []) + + zonk_arg env (ApplicativeArgOne fail_op pat expr isBody) + = do { new_expr <- zonkLExpr env expr + ; new_fail <- forM fail_op $ \old_fail -> + do { (_, fail') <- zonkSyntaxExpr env old_fail + ; return fail' + } + ; return (ApplicativeArgOne new_fail pat new_expr isBody) } + zonk_arg env (ApplicativeArgMany x stmts ret pat ctxt) + = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts + ; new_ret <- zonkExpr env1 ret + ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) } + +------------------------------------------------------------------------- +zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc) +zonkRecFields env (HsRecFields flds dd) + = do { flds' <- mapM zonk_rbind flds + ; return (HsRecFields flds' dd) } + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) + ; new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldLbl = new_id + , hsRecFieldArg = new_expr })) } + +zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc] + -> TcM [LHsRecUpdField GhcTc] +zonkRecUpdFields env = mapM zonk_rbind + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) + ; new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id + , hsRecFieldArg = new_expr })) } + +------------------------------------------------------------------------- +mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a + -> TcM (Either (Located HsIPName) b) +mapIPNameTc _ (Left x) = return (Left x) +mapIPNameTc f (Right x) = do r <- f x + return (Right r) + +{- +************************************************************************ +* * +\subsection[BackSubst-Pats]{Patterns} +* * +************************************************************************ +-} + +zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc) +-- Extend the environment as we go, because it's possible for one +-- pattern to bind something that is used in another (inside or +-- to the right) +zonkPat env pat = wrapLocSndM (zonk_pat env) pat + +zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) +zonk_pat env (ParPat x p) + = do { (env', p') <- zonkPat env p + ; return (env', ParPat x p') } + +zonk_pat env (WildPat ty) + = do { ty' <- zonkTcTypeToTypeX env ty + ; ensureNotLevPoly ty' + (text "In a wildcard pattern") + ; return (env, WildPat ty') } + +zonk_pat env (VarPat x (L l v)) + = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnv env v', VarPat x (L l v')) } + +zonk_pat env (LazyPat x pat) + = do { (env', pat') <- zonkPat env pat + ; return (env', LazyPat x pat') } + +zonk_pat env (BangPat x pat) + = do { (env', pat') <- zonkPat env pat + ; return (env', BangPat x pat') } + +zonk_pat env (AsPat x (L loc v) pat) + = do { v' <- zonkIdBndr env v + ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat + ; return (env', AsPat x (L loc v') pat') } + +zonk_pat env (ViewPat ty expr pat) + = do { expr' <- zonkLExpr env expr + ; (env', pat') <- zonkPat env pat + ; ty' <- zonkTcTypeToTypeX env ty + ; return (env', ViewPat ty' expr' pat') } + +zonk_pat env (ListPat (ListPatTc ty Nothing) pats) + = do { ty' <- zonkTcTypeToTypeX env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat (ListPatTc ty' Nothing) pats') } + +zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) + = do { (env', wit') <- zonkSyntaxExpr env wit + ; ty2' <- zonkTcTypeToTypeX env' ty2 + ; ty' <- zonkTcTypeToTypeX env' ty + ; (env'', pats') <- zonkPats env' pats + ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') } + +zonk_pat env (TuplePat tys pats boxed) + = do { tys' <- mapM (zonkTcTypeToTypeX env) tys + ; (env', pats') <- zonkPats env pats + ; return (env', TuplePat tys' pats' boxed) } + +zonk_pat env (SumPat tys pat alt arity ) + = do { tys' <- mapM (zonkTcTypeToTypeX env) tys + ; (env', pat') <- zonkPat env pat + ; return (env', SumPat tys' pat' alt arity) } + +zonk_pat env p@(ConPat { pat_con = L _ con + , pat_args = args + , pat_con_ext = p'@(ConPatTc + { cpt_tvs = tyvars + , cpt_dicts = evs + , cpt_binds = binds + , cpt_wrap = wrapper + , cpt_arg_tys = tys + }) + }) + = ASSERT( all isImmutableTyVar tyvars ) + do { new_tys <- mapM (zonkTcTypeToTypeX env) tys + + -- an unboxed tuple pattern (but only an unboxed tuple pattern) + -- might have levity-polymorphic arguments. Check for this badness. + ; case con of + RealDataCon dc + | isUnboxedTupleTyCon (dataConTyCon dc) + -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) + _ -> return () + + ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars + -- Must zonk the existential variables, because their + -- /kind/ need potential zonking. + -- cf typecheck/should_compile/tc221.hs + ; (env1, new_evs) <- zonkEvBndrsX env0 evs + ; (env2, new_binds) <- zonkTcEvBinds env1 binds + ; (env3, new_wrapper) <- zonkCoFn env2 wrapper + ; (env', new_args) <- zonkConStuff env3 args + ; pure ( env' + , p + { pat_args = new_args + , pat_con_ext = p' + { cpt_arg_tys = new_tys + , cpt_tvs = new_tyvars + , cpt_dicts = new_evs + , cpt_binds = new_binds + , cpt_wrap = new_wrapper + } + } + ) + } + where + doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p + +zonk_pat env (LitPat x lit) = return (env, LitPat x lit) + +zonk_pat env (SigPat ty pat hs_ty) + = do { ty' <- zonkTcTypeToTypeX env ty + ; (env', pat') <- zonkPat env pat + ; return (env', SigPat ty' pat' hs_ty) } + +zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) + = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr + ; (env2, mb_neg') <- case mb_neg of + Nothing -> return (env1, Nothing) + Just n -> second Just <$> zonkSyntaxExpr env1 n + + ; lit' <- zonkOverLit env2 lit + ; ty' <- zonkTcTypeToTypeX env2 ty + ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } + +zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) + = do { (env1, e1') <- zonkSyntaxExpr env e1 + ; (env2, e2') <- zonkSyntaxExpr env1 e2 + ; n' <- zonkIdBndr env2 n + ; lit1' <- zonkOverLit env2 lit1 + ; lit2' <- zonkOverLit env2 lit2 + ; ty' <- zonkTcTypeToTypeX env2 ty + ; return (extendIdZonkEnv env2 n', + NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } + +zonk_pat env (XPat (CoPat co_fn pat ty)) + = do { (env', co_fn') <- zonkCoFn env co_fn + ; (env'', pat') <- zonkPat env' (noLoc pat) + ; ty' <- zonkTcTypeToTypeX env'' ty + ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty') + } + +zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) + +--------------------------- +zonkConStuff :: ZonkEnv + -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)) + -> TcM (ZonkEnv, + HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))) +zonkConStuff env (PrefixCon pats) + = do { (env', pats') <- zonkPats env pats + ; return (env', PrefixCon pats') } + +zonkConStuff env (InfixCon p1 p2) + = do { (env1, p1') <- zonkPat env p1 + ; (env', p2') <- zonkPat env1 p2 + ; return (env', InfixCon p1' p2') } + +zonkConStuff env (RecCon (HsRecFields rpats dd)) + = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) + ; let rpats' = zipWith (\(L l rp) p' -> + L l (rp { hsRecFieldArg = p' })) + rpats pats' + ; return (env', RecCon (HsRecFields rpats' dd)) } + -- Field selectors have declared types; hence no zonking + +--------------------------- +zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc]) +zonkPats env [] = return (env, []) +zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat + ; (env', pats') <- zonkPats env1 pats + ; return (env', pat':pats') } + +{- +************************************************************************ +* * +\subsection[BackSubst-Foreign]{Foreign exports} +* * +************************************************************************ +-} + +zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc] + -> TcM [LForeignDecl GhcTc] +zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls + +zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc) +zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co + , fd_fe = spec }) + = return (ForeignExport { fd_name = zonkLIdOcc env i + , fd_sig_ty = undefined, fd_e_ext = co + , fd_fe = spec }) +zonkForeignExport _ for_imp + = return for_imp -- Foreign imports don't need zonking + +zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc] +zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs + +zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc) +zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} + , rd_lhs = lhs + , rd_rhs = rhs }) + = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs + + ; let env_lhs = setZonkType env_inside SkolemiseFlexi + -- See Note [Zonking the LHS of a RULE] + + ; new_lhs <- zonkLExpr env_lhs lhs + ; new_rhs <- zonkLExpr env_inside rhs + + ; return $ rule { rd_tmvs = new_tm_bndrs + , rd_lhs = new_lhs + , rd_rhs = new_rhs } } + where + zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc) + zonk_tm_bndr env (L l (RuleBndr x (L loc v))) + = do { (env', v') <- zonk_it env v + ; return (env', L l (RuleBndr x (L loc v'))) } + zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" + + zonk_it env v + | isId v = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnvRec env [v'], v') } + | otherwise = ASSERT( isImmutableTyVar v) + zonkTyBndrX env v + -- DV: used to be return (env,v) but that is plain + -- wrong because we may need to go inside the kind + -- of v and zonk there! + +{- +************************************************************************ +* * + Constraints and evidence +* * +************************************************************************ +-} + +zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm +zonkEvTerm env (EvExpr e) + = EvExpr <$> zonkCoreExpr env e +zonkEvTerm env (EvTypeable ty ev) + = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev +zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs + , et_binds = ev_binds, et_body = body_id }) + = do { (env0, new_tvs) <- zonkTyBndrsX env tvs + ; (env1, new_evs) <- zonkEvBndrsX env0 evs + ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds + ; let new_body_id = zonkIdOcc env2 body_id + ; return (EvFun { et_tvs = new_tvs, et_given = new_evs + , et_binds = new_ev_binds, et_body = new_body_id }) } + +zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr +zonkCoreExpr env (Var v) + | isCoVar v + = Coercion <$> zonkCoVarOcc env v + | otherwise + = return (Var $ zonkIdOcc env v) +zonkCoreExpr _ (Lit l) + = return $ Lit l +zonkCoreExpr env (Coercion co) + = Coercion <$> zonkCoToCo env co +zonkCoreExpr env (Type ty) + = Type <$> zonkTcTypeToTypeX env ty + +zonkCoreExpr env (Cast e co) + = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co +zonkCoreExpr env (Tick t e) + = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks? + +zonkCoreExpr env (App e1 e2) + = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2 +zonkCoreExpr env (Lam v e) + = do { (env1, v') <- zonkCoreBndrX env v + ; Lam v' <$> zonkCoreExpr env1 e } +zonkCoreExpr env (Let bind e) + = do (env1, bind') <- zonkCoreBind env bind + Let bind'<$> zonkCoreExpr env1 e +zonkCoreExpr env (Case scrut b ty alts) + = do scrut' <- zonkCoreExpr env scrut + ty' <- zonkTcTypeToTypeX env ty + b' <- zonkIdBndr env b + let env1 = extendIdZonkEnv env b' + alts' <- mapM (zonkCoreAlt env1) alts + return $ Case scrut' b' ty' alts' + +zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt +zonkCoreAlt env (dc, bndrs, rhs) + = do (env1, bndrs') <- zonkCoreBndrsX env bndrs + rhs' <- zonkCoreExpr env1 rhs + return $ (dc, bndrs', rhs') + +zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) +zonkCoreBind env (NonRec v e) + = do v' <- zonkIdBndr env v + e' <- zonkCoreExpr env e + let env1 = extendIdZonkEnv env v' + return (env1, NonRec v' e') +zonkCoreBind env (Rec pairs) + = do (env1, pairs') <- fixM go + return (env1, Rec pairs') + where + go ~(_, new_pairs) = do + let env1 = extendIdZonkEnvRec env (map fst new_pairs) + pairs' <- mapM (zonkCorePair env1) pairs + return (env1, pairs') + +zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr) +zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e + +zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable +zonkEvTypeable env (EvTypeableTyCon tycon e) + = do { e' <- mapM (zonkEvTerm env) e + ; return $ EvTypeableTyCon tycon e' } +zonkEvTypeable env (EvTypeableTyApp t1 t2) + = do { t1' <- zonkEvTerm env t1 + ; t2' <- zonkEvTerm env t2 + ; return (EvTypeableTyApp t1' t2') } +zonkEvTypeable env (EvTypeableTrFun tm t1 t2) + = do { tm' <- zonkEvTerm env tm + ; t1' <- zonkEvTerm env t1 + ; t2' <- zonkEvTerm env t2 + ; return (EvTypeableTrFun tm' t1' t2') } +zonkEvTypeable env (EvTypeableTyLit t1) + = do { t1' <- zonkEvTerm env t1 + ; return (EvTypeableTyLit t1') } + +zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) +zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs + ; return (env, [EvBinds (unionManyBags bs')]) } + +zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) +zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs + ; return (env', EvBinds bs') } + +zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) +zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var +zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs + +zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) +zonkEvBindsVar env (EvBindsVar { ebv_binds = ref }) + = do { bs <- readMutVar ref + ; zonkEvBinds env (evBindMapBinds bs) } +zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag) + +zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) +zonkEvBinds env binds + = {-# SCC "zonkEvBinds" #-} + fixM (\ ~( _, new_binds) -> do + { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) + ; binds' <- mapBagM (zonkEvBind env1) binds + ; return (env1, binds') }) + where + collect_ev_bndrs :: Bag EvBind -> [EvVar] + collect_ev_bndrs = foldr add [] + add (EvBind { eb_lhs = var }) vars = var : vars + +zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind +zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) + = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var + + -- Optimise the common case of Refl coercions + -- See Note [Optimise coercion zonking] + -- This has a very big effect on some programs (eg #5030) + + ; term' <- case getEqPredTys_maybe (idType var') of + Just (r, ty1, ty2) | ty1 `eqType` ty2 + -> return (evCoercion (mkTcReflCo r ty1)) + _other -> zonkEvTerm env term + + ; return (bind { eb_lhs = var', eb_rhs = term' }) } + +{- Note [Optimise coercion zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When optimising evidence binds we may come across situations where +a coercion looks like + cv = ReflCo ty +or cv1 = cv2 +where the type 'ty' is big. In such cases it is a waste of time to zonk both + * The variable on the LHS + * The coercion on the RHS +Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just +use Refl on the right, ignoring the actual coercion on the RHS. + +This can have a very big effect, because the constraint solver sometimes does go +to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) + + +************************************************************************ +* * + Zonking types +* * +************************************************************************ +-} + +{- Note [Sharing when zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: + + In GHC.Tc.Utils.TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to + (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Utils.TcMType. But we + /can't/ do this when zonking a TcType to a Type (#15552, esp + comment:3). Suppose we have + + alpha -> alpha + where + alpha is already unified: + alpha := T{tc-tycon} Int -> Int + and T is knot-tied + + By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, + but the global env contains a mapping "T" :-> T{knot-tied-tc}. See + Note [Type checking recursive type and class declarations] in + GHC.Tc.TyCl. + + Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow + the same path as Note [Sharing in zonking] in GHC.Tc.Utils.TcMType, we'll + update alpha to + alpha := T{knot-tied-tc} Int -> Int + + But alas, if we encounter alpha for a /second/ time, we end up + looking at T{knot-tied-tc} and fall into a black hole. The whole + point of zonkTcTypeToType is that it produces a type full of + knot-tied tycons, and you must not look at the result!! + + To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not + the same as zonkTcTypeToType. (If we distinguished TcType from + Type, this issue would have been a type error!) + +Solutions: (see #15552 for other variants) + +One possible solution is simply not to do the short-circuiting. +That has less sharing, but maybe sharing is rare. And indeed, +that usually turns out to be viable from a perf point of view + +But zonkTyVarOcc implements something a bit better + +* ZonkEnv contains ze_meta_tv_env, which maps + from a MetaTyVar (unification variable) + to a Type (not a TcType) + +* In zonkTyVarOcc, we check this map to see if we have zonked + this variable before. If so, use the previous answer; if not + zonk it, and extend the map. + +* The map is of course stateful, held in a TcRef. (That is unlike + the treatment of lexically-scoped variables in ze_tv_env and + ze_id_env.) + +* In zonkTyVarOcc we read the TcRef to look up the unification + variable: + - if we get a hit we use the zonked result; + - if not, in zonk_meta we see if the variable is `Indirect ty`, + zonk that, and update the map (in finish_meta) + But Nota Bene that the "update map" step must re-read the TcRef + (or, more precisely, use updTcRef) because the zonking of the + `Indirect ty` may have added lots of stuff to the map. See + #19668 for an example where this made an asymptotic difference! + +Is it worth the extra work of carrying ze_meta_tv_env? Some +non-systematic perf measurements suggest that compiler allocation is +reduced overall (by 0.5% or so) but compile time really doesn't +change. But in some cases it makes a HUGE difference: see test +T9198 and #19668. So yes, it seems worth it. +-} + +zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType +zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi + , ze_tv_env = tv_env + , ze_meta_tv_env = mtv_env_ref }) tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> lookup_in_tv_env + RuntimeUnk {} -> lookup_in_tv_env + MetaTv { mtv_ref = ref } + -> do { mtv_env <- readTcRef mtv_env_ref + -- See Note [Sharing when zonking to Type] + ; case lookupVarEnv mtv_env tv of + Just ty -> return ty + Nothing -> do { mtv_details <- readTcRef ref + ; zonk_meta ref mtv_details } } + | otherwise + = lookup_in_tv_env + + where + lookup_in_tv_env -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv + Just tv' -> return (mkTyVarTy tv') + + zonk_meta ref Flexi + = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) + ; ty <- commitFlexi flexi tv kind + ; writeMetaTyVarRef tv ref ty -- Belt and braces + ; finish_meta ty } + + zonk_meta _ (Indirect ty) + = do { zty <- zonkTcTypeToTypeX env ty + ; finish_meta zty } + + finish_meta ty + = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) + ; return ty } + +lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar +lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv + = lookupVarEnv tv_env tv + +commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type +-- Only monadic so we can do tc-tracing +commitFlexi flexi tv zonked_kind + = case flexi of + SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) + + DefaultFlexi + | isRuntimeRepTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) + ; return liftedRepTy } + | isMultiplicityTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) + ; return manyDataConTy } + | otherwise + -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) + ; return (anyTypeOfKind zonked_kind) } + + RuntimeUnkFlexi + -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) + ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad + where + name = tyVarName tv + +zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion +zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv + | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env + = return $ mkCoVarCo cv' + | otherwise + = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') } + +zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion +zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) + = do { contents <- readTcRef ref + ; case contents of + Just co -> do { co' <- zonkCoToCo env co + ; checkCoercionHole cv co' } + + -- This next case should happen only in the presence of + -- (undeferred) type errors. Originally, I put in a panic + -- here, but that caused too many uses of `failIfErrsM`. + Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole) + ; when debugIsOn $ + whenNoErrs $ + MASSERT2( False + , text "Type-correct unfilled coercion hole" + <+> ppr hole ) + ; cv' <- zonkCoVar cv + ; return $ mkCoVarCo cv' } } + -- This will be an out-of-scope variable, but keeping + -- this as a coercion hole led to #15787 + +zonk_tycomapper :: TyCoMapper ZonkEnv TcM +zonk_tycomapper = TyCoMapper + { tcm_tyvar = zonkTyVarOcc + , tcm_covar = zonkCoVarOcc + , tcm_hole = zonkCoHole + , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv + , tcm_tycon = zonkTcTyConToTyCon } + +-- Zonk a TyCon by changing a TcTyCon to a regular TyCon +zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon +zonkTcTyConToTyCon tc + | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) + ; case thing of + ATyCon real_tc -> return real_tc + _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } + | otherwise = return tc -- it's already zonked + +-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. +zonkTcTypeToType :: TcType -> TcM Type +zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty + +zonkTcTypesToTypes :: [TcType] -> TcM [Type] +zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys + +zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType) +zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m + <*> zonkTcTypeToTypeX env ty + +zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type +zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] +zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) + = mapTyCoX zonk_tycomapper + +zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type] +zonkScaledTcTypesToTypesX env scaled_tys = + mapM (zonkScaledTcTypeToTypeX env) scaled_tys + +zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo +zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) + = do { ty' <- zonkTcTypeToTypeX ze ty + ; gdm_spec' <- zonk_gdm gdm_spec + ; return (name, ty', gdm_spec') } + where + zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) + -> TcM (Maybe (DefMethSpec (SrcSpan, Type))) + zonk_gdm Nothing = return Nothing + zonk_gdm (Just VanillaDM) = return (Just VanillaDM) + zonk_gdm (Just (GenericDM (loc, ty))) + = do { ty' <- zonkTcTypeToTypeX ze ty + ; return (Just (GenericDM (loc, ty'))) } + +--------------------------------------- +{- Note [Zonking the LHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] + +We need to gather the type variables mentioned on the LHS so we can +quantify over them. Example: + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo alpha (C alpha)) and we do +not want to zap the unbound meta-tyvar 'alpha' to Any, because that +limits the applicability of the rule. Instead, we want to quantify +over it! + +We do this in two stages. + +* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We + do this by using zonkTvSkolemising as the UnboundTyVarZonker in the + ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a + UnboundTyVarZonker.) + +* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds + Note [Free tyvars on rule LHS] + +Quantifying here is awkward because (a) the data type is big and (b) +finding the free type vars of an expression is necessarily monadic +operation. (consider /\a -> f @ b, where b is side-effected to a) +-} diff --git a/GHC/Tc/Validity.hs b/GHC/Tc/Validity.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Validity.hs @@ -0,0 +1,2978 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, TupleSections, ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Validity ( + Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, + checkValidTheta, + checkValidInstance, checkValidInstHead, validDerivPred, + checkTySynRhs, + checkValidCoAxiom, checkValidCoAxBranch, + checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, + badATErr, arityErr, + checkTyConTelescope, + allDistinctTyVars + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Maybe + +-- friends: +import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) +import GHC.Tc.Solver ( simplifyAmbiguityCheck ) +import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes ) +import GHC.Builtin.Types ( heqTyConName, eqTyConName, coercibleTyConName, manyDataConTy ) +import GHC.Builtin.Names +import GHC.Core.Type +import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Predicate +import GHC.Tc.Types.Origin + +-- others: +import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) +import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env ( tcInitTidyEnv, tcInitOpenTidyEnv ) +import GHC.Tc.Instance.FunDeps +import GHC.Core.FamInstEnv + ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) +import GHC.Tc.Instance.Family +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Var ( VarBndr(..), mkTyVar ) +import GHC.Utils.FV +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Utils.Misc +import GHC.Data.List.SetOps +import GHC.Types.SrcLoc +import GHC.Utils.Outputable as Outputable +import GHC.Types.Unique ( mkAlphaTyVarUnique ) +import GHC.Data.Bag ( emptyBag ) +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Foldable +import Data.Function +import Data.List ( (\\), nub ) +import qualified Data.List.NonEmpty as NE + +{- +************************************************************************ +* * + Checking for ambiguity +* * +************************************************************************ + +Note [The ambiguity check for type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +checkAmbiguity is a check on *user-supplied type signatures*. It is +*purely* there to report functions that cannot possibly be called. So for +example we want to reject: + f :: C a => Int +The idea is there can be no legal calls to 'f' because every call will +give rise to an ambiguous constraint. We could soundly omit the +ambiguity check on type signatures entirely, at the expense of +delaying ambiguity errors to call sites. Indeed, the flag +-XAllowAmbiguousTypes switches off the ambiguity check. + +What about things like this: + class D a b | a -> b where .. + h :: D Int b => Int +The Int may well fix 'b' at the call site, so that signature should +not be rejected. Moreover, using *visible* fundeps is too +conservative. Consider + class X a b where ... + class D a b | a -> b where ... + instance D a b => X [a] b where... + h :: X a b => a -> a +Here h's type looks ambiguous in 'b', but here's a legal call: + ...(h [True])... +That gives rise to a (X [Bool] beta) constraint, and using the +instance means we need (D Bool beta) and that fixes 'beta' via D's +fundep! + +Behind all these special cases there is a simple guiding principle. +Consider + + f :: + f = ...blah... + + g :: + g = f + +You would think that the definition of g would surely typecheck! +After all f has exactly the same type, and g=f. But in fact f's type +is instantiated and the instantiated constraints are solved against +the originals, so in the case of an ambiguous type it won't work. +Consider our earlier example f :: C a => Int. Then in g's definition, +we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), +and fail. + +So in fact we use this as our *definition* of ambiguity. We use a +very similar test for *inferred* types, to ensure that they are +unambiguous. See Note [Impedance matching] in GHC.Tc.Gen.Bind. + +This test is very conveniently implemented by calling + tcSubType +This neatly takes account of the functional dependency stuff above, +and implicit parameter (see Note [Implicit parameters and ambiguity]). +And this is what checkAmbiguity does. + +What about this, though? + g :: C [a] => Int +Is every call to 'g' ambiguous? After all, we might have + instance C [a] where ... +at the call site. So maybe that type is ok! Indeed even f's +quintessentially ambiguous type might, just possibly be callable: +with -XFlexibleInstances we could have + instance C a where ... +and now a call could be legal after all! Well, we'll reject this +unless the instance is available *here*. + +Note [When to call checkAmbiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call checkAmbiguity + (a) on user-specified type signatures + (b) in checkValidType + +Conncerning (b), you might wonder about nested foralls. What about + f :: forall b. (forall a. Eq a => b) -> b +The nested forall is ambiguous. Originally we called checkAmbiguity +in the forall case of check_type, but that had two bad consequences: + * We got two error messages about (Eq b) in a nested forall like this: + g :: forall a. Eq a => forall b. Eq b => a -> a + * If we try to check for ambiguity of a nested forall like + (forall a. Eq a => b), the implication constraint doesn't bind + all the skolems, which results in "No skolem info" in error + messages (see #10432). + +To avoid this, we call checkAmbiguity once, at the top, in checkValidType. +(I'm still a bit worried about unbound skolems when the type mentions +in-scope type variables.) + +In fact, because of the co/contra-variance implemented in tcSubType, +this *does* catch function f above. too. + +Concerning (a) the ambiguity check is only used for *user* types, not +for types coming from interface files. The latter can legitimately +have ambiguous types. Example + + class S a where s :: a -> (Int,Int) + instance S Char where s _ = (1,1) + f:: S a => [a] -> Int -> (Int,Int) + f (_::[a]) x = (a*x,b) + where (a,b) = s (undefined::a) + +Here the worker for f gets the type + fw :: forall a. S a => Int -> (# Int, Int #) + + +Note [Implicit parameters and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only a *class* predicate can give rise to ambiguity +An *implicit parameter* cannot. For example: + foo :: (?x :: [a]) => Int + foo = length ?x +is fine. The call site will supply a particular 'x' + +Furthermore, the type variables fixed by an implicit parameter +propagate to the others. E.g. + foo :: (Show a, ?x::[a]) => Int + foo = show (?x++?x) +The type of foo looks ambiguous. But it isn't, because at a call site +we might have + let ?x = 5::Int in foo +and all is well. In effect, implicit parameters are, well, parameters, +so we can take their type variables into account as part of the +"tau-tvs" stuff. This is done in the function 'GHC.Tc.Instance.FunDeps.grow'. +-} + +checkAmbiguity :: UserTypeCtxt -> Type -> TcM () +checkAmbiguity ctxt ty + | wantAmbiguityCheck ctxt + = do { traceTc "Ambiguity check for" (ppr ty) + -- Solve the constraints eagerly because an ambiguous type + -- can cause a cascade of further errors. Since the free + -- tyvars are skolemised, we can safely use tcSimplifyTop + ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes + ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ + captureConstraints $ + tcSubTypeSigma ctxt ty ty + ; simplifyAmbiguityCheck ty wanted + + ; traceTc "Done ambiguity check for" (ppr ty) } + + | otherwise + = return () + where + mk_msg allow_ambiguous + = vcat [ text "In the ambiguity check for" <+> what + , ppUnless allow_ambiguous ambig_msg ] + ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" + what | Just n <- isSigMaybe ctxt = quotes (ppr n) + | otherwise = pprUserTypeCtxt ctxt + +wantAmbiguityCheck :: UserTypeCtxt -> Bool +wantAmbiguityCheck ctxt + = case ctxt of -- See Note [When we don't check for ambiguity] + GhciCtxt {} -> False + TySynCtxt {} -> False + TypeAppCtxt -> False + StandaloneKindSigCtxt{} -> False + _ -> True + +checkUserTypeError :: Type -> TcM () +-- Check to see if the type signature mentions "TypeError blah" +-- anywhere in it, and fail if so. +-- +-- Very unsatisfactorily (#11144) we need to tidy the type +-- because it may have come from an /inferred/ signature, not a +-- user-supplied one. This is really only a half-baked fix; +-- the other errors in checkValidType don't do tidying, and so +-- may give bad error messages when given an inferred type. +checkUserTypeError = check + where + check ty + | Just msg <- userTypeError_maybe ty = fail_with msg + | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts + | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2 + | Just (_,t1) <- splitForAllTy_maybe ty = check t1 + | otherwise = return () + + fail_with msg = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_msg) = tidyOpenType env0 msg + ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } + + +{- Note [When we don't check for ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a few places we do not want to check a user-specified type for ambiguity + +* GhciCtxt: Allow ambiguous types in GHCi's :kind command + E.g. type family T a :: * -- T :: forall k. k -> * + Then :k T should work in GHCi, not complain that + (T k) is ambiguous! + +* TySynCtxt: type T a b = C a b => blah + It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow + cure the ambiguity. So we defer the ambiguity check to the use site. + + There is also an implementation reason (#11608). In the RHS of + a type synonym we don't (currently) instantiate 'a' and 'b' with + TcTyVars before calling checkValidType, so we get assertion failures + from doing an ambiguity check on a type with TyVars in it. Fixing this + would not be hard, but let's wait till there's a reason. + +* TypeAppCtxt: visible type application + f @ty + No need to check ty for ambiguity + +* StandaloneKindSigCtxt: type T :: ksig + Kinds need a different ambiguity check than types, and the currently + implemented check is only good for types. See #14419, in particular + https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844 + +************************************************************************ +* * + Checking validity of a user-defined type +* * +************************************************************************ + +When dealing with a user-written type, we first translate it from an HsType +to a Type, performing kind checking, and then check various things that should +be true about it. We don't want to perform these checks at the same time +as the initial translation because (a) they are unnecessary for interface-file +types and (b) when checking a mutually recursive group of type and class decls, +we can't "look" at the tycons/classes yet. Also, the checks are rather +diverse, and used to really mess up the other code. + +One thing we check for is 'rank'. + + Rank 0: monotypes (no foralls) + Rank 1: foralls at the front only, Rank 0 inside + Rank 2: foralls at the front, Rank 1 on left of fn arrow, + + basic ::= tyvar | T basic ... basic + + r2 ::= forall tvs. cxt => r2a + r2a ::= r1 -> r2a | basic + r1 ::= forall tvs. cxt => r0 + r0 ::= r0 -> r0 | basic + +Another thing is to check that type synonyms are saturated. +This might not necessarily show up in kind checking. + type A i = i + data T k = MkT (k Int) + f :: T A -- BAD! +-} + +checkValidType :: UserTypeCtxt -> Type -> TcM () +-- Checks that a user-written type is valid for the given context +-- Assumes argument is fully zonked +-- Not used for instance decls; checkValidInstance instead +checkValidType ctxt ty + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) + ; rankn_flag <- xoptM LangExt.RankNTypes + ; impred_flag <- xoptM LangExt.ImpredicativeTypes + ; let gen_rank :: Rank -> Rank + gen_rank r | rankn_flag = ArbitraryRank + | otherwise = r + + rank1 = gen_rank r1 + rank0 = gen_rank r0 + + r0 = rankZeroMonoType + r1 = LimitedRank True r0 + + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + ResSigCtxt -> MustBeMonoType + PatSigCtxt -> rank0 + RuleSigCtxt _ -> rank1 + TySynCtxt _ -> rank0 + + ExprSigCtxt -> rank1 + KindSigCtxt -> rank1 + StandaloneKindSigCtxt{} -> rank1 + TypeAppCtxt | impred_flag -> ArbitraryRank + | otherwise -> tyConArgMonoType + -- Normally, ImpredicativeTypes is handled in check_arg_type, + -- but visible type applications don't go through there. + -- So we do this check here. + + FunSigCtxt {} -> rank1 + InfSigCtxt {} -> rank1 -- Inferred types should obey the + -- same rules as declared ones + + ConArgCtxt _ -> rank1 -- We are given the type of the entire + -- constructor, hence rank 1 + PatSynCtxt _ -> rank1 + + ForSigCtxt _ -> rank1 + SpecInstCtxt -> rank1 + ThBrackCtxt -> rank1 + GhciCtxt {} -> ArbitraryRank + + TyVarBndrKindCtxt _ -> rank0 + DataKindCtxt _ -> rank1 + TySynKindCtxt _ -> rank1 + TyFamResKindCtxt _ -> rank1 + + _ -> panic "checkValidType" + -- Can't happen; not used for *user* sigs + + ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; expand <- initialExpandMode + ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand } + + -- Check the internal validity of the type itself + -- Fail if bad things happen, else we misleading + -- (and more complicated) errors in checkAmbiguity + ; checkNoErrs $ + do { check_type ve ty + ; checkUserTypeError ty + ; traceTc "done ct" (ppr ty) } + + -- Check for ambiguous types. See Note [When to call checkAmbiguity] + -- NB: this will happen even for monotypes, but that should be cheap; + -- and there may be nested foralls for the subtype test to examine + ; checkAmbiguity ctxt ty + + ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) } + +checkValidMonoType :: Type -> TcM () +-- Assumes argument is fully zonked +checkValidMonoType ty + = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; expand <- initialExpandMode + ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt + , ve_rank = MustBeMonoType, ve_expand = expand } + ; check_type ve ty } + +checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () +checkTySynRhs ctxt ty + | tcReturnsConstraintKind actual_kind + = do { ck <- xoptM LangExt.ConstraintKinds + ; if ck + then when (tcIsConstraintKind actual_kind) + (do { dflags <- getDynFlags + ; expand <- initialExpandMode + ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) + else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) } + + | otherwise + = return () + where + actual_kind = tcTypeKind ty + +{- +Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~ +Technically + Int -> forall a. a->a +is still a rank-1 type, but it's not Haskell 98 (#5957). So the +validity checker allow a forall after an arrow only if we allow it +before -- that is, with Rank2Types or RankNTypes +-} + +data Rank = ArbitraryRank -- Any rank ok + + | LimitedRank -- Note [Higher rank types] + Bool -- Forall ok at top + Rank -- Use for function arguments + + | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype + + | MustBeMonoType -- Monotype regardless of flags + +instance Outputable Rank where + ppr ArbitraryRank = text "ArbitraryRank" + ppr (LimitedRank top_forall_ok r) + = text "LimitedRank" <+> ppr top_forall_ok + <+> parens (ppr r) + ppr (MonoType msg) = text "MonoType" <+> parens msg + ppr MustBeMonoType = text "MustBeMonoType" + +rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank +rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes") +tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") +synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") +constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype" + , text "Perhaps you intended to use QuantifiedConstraints" ]) + +funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result +funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) +funArgResRank other_rank = (other_rank, other_rank) + +forAllAllowed :: Rank -> Bool +forAllAllowed ArbitraryRank = True +forAllAllowed (LimitedRank forall_ok _) = forall_ok +forAllAllowed _ = False + +allConstraintsAllowed :: UserTypeCtxt -> Bool +-- We don't allow arbitrary constraints in kinds +allConstraintsAllowed (TyVarBndrKindCtxt {}) = False +allConstraintsAllowed (DataKindCtxt {}) = False +allConstraintsAllowed (TySynKindCtxt {}) = False +allConstraintsAllowed (TyFamResKindCtxt {}) = False +allConstraintsAllowed (StandaloneKindSigCtxt {}) = False +allConstraintsAllowed _ = True + +-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the +-- context for the type of a term, where visible, dependent quantification is +-- currently disallowed. +-- +-- An example of something that is unambiguously the type of a term is the +-- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the +-- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the +-- kind of a type, not the type of a term, so it is permitted. +-- +-- For more examples, see +-- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places +-- where VDQ is permitted) and +-- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where +-- VDQ is disallowed). +vdqAllowed :: UserTypeCtxt -> Bool +-- Currently allowed in the kinds of types... +vdqAllowed (KindSigCtxt {}) = True +vdqAllowed (StandaloneKindSigCtxt {}) = True +vdqAllowed (TySynCtxt {}) = True +vdqAllowed (ThBrackCtxt {}) = True +vdqAllowed (GhciCtxt {}) = True +vdqAllowed (TyVarBndrKindCtxt {}) = True +vdqAllowed (DataKindCtxt {}) = True +vdqAllowed (TySynKindCtxt {}) = True +vdqAllowed (TyFamResKindCtxt {}) = True +-- ...but not in the types of terms. +vdqAllowed (ConArgCtxt {}) = False + -- We could envision allowing VDQ in data constructor types so long as the + -- constructor is only ever used at the type level, but for now, GHC adopts + -- the stance that VDQ is never allowed in data constructor types. +vdqAllowed (FunSigCtxt {}) = False +vdqAllowed (InfSigCtxt {}) = False +vdqAllowed (ExprSigCtxt {}) = False +vdqAllowed (TypeAppCtxt {}) = False +vdqAllowed (PatSynCtxt {}) = False +vdqAllowed (PatSigCtxt {}) = False +vdqAllowed (RuleSigCtxt {}) = False +vdqAllowed (ResSigCtxt {}) = False +vdqAllowed (ForSigCtxt {}) = False +vdqAllowed (DefaultDeclCtxt {}) = False +-- We count class constraints as "types of terms". All of the cases below deal +-- with class constraints. +vdqAllowed (InstDeclCtxt {}) = False +vdqAllowed (SpecInstCtxt {}) = False +vdqAllowed (GenSigCtxt {}) = False +vdqAllowed (ClassSCCtxt {}) = False +vdqAllowed (SigmaCtxt {}) = False +vdqAllowed (DataTyCtxt {}) = False +vdqAllowed (DerivClauseCtxt {}) = False + +{- +Note [Correctness and performance of type synonym validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the type A arg1 arg2, where A is a type synonym. How should we check +this type for validity? We have three distinct choices, corresponding to the +three constructors of ExpandMode: + +1. Expand the application of A, and check the resulting type (`Expand`). +2. Don't expand the application of A. Only check the arguments (`NoExpand`). +3. Check the arguments *and* check the expanded type (`Both`). + +It's tempting to think that we could always just pick choice (3), but this +results in serious performance issues when checking a type like in the +signature for `f` below: + + type S = ... + f :: S (S (S (S (S (S ....(S Int)...)))) + +When checking the type of `f`, we'll check the outer `S` application with and +without expansion, and in *each* of those checks, we'll check the next `S` +application with and without expansion... the result is exponential blowup! So +clearly we don't want to use `Both` 100% of the time. + +On the other hand, neither is it correct to use exclusively `Expand` or +exclusively `NoExpand` 100% of the time: + +* If one always expands, then one can miss erroneous programs like the one in + the `tcfail129` test case: + + type Foo a = String -> Maybe a + type Bar m = m Int + blah = undefined :: Bar Foo + + If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type + synonyms is unsaturated. +* If one never expands and only checks the arguments, then one can miss + erroneous programs like the one in #16059: + + type Foo b = Eq b => b + f :: forall b (a :: Foo b). Int + + The kind of `a` contains a constraint, which is illegal, but this will only + be caught if `Foo b` is expanded. + +Therefore, it's impossible to have these validity checks be simultaneously +correct and performant if one sticks exclusively to a single `ExpandMode`. In +that case, the solution is to vary the `ExpandMode`s! In more detail: + +1. When we start validity checking, we start with `Expand` if + LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we + do this), and we start with `Both` otherwise. The `initialExpandMode` + function is responsible for this. +2. When expanding an application of a type synonym (in `check_syn_tc_app`), we + determine which things to check based on the current `ExpandMode` argument. + Importantly, if the current mode is `Both`, then we check the arguments in + `NoExpand` mode and check the expanded type in `Both` mode. + + Switching to `NoExpand` when checking the arguments is vital to avoid + exponential blowup. One consequence of this choice is that if you have + the following type synonym in one module (with RankNTypes enabled): + + {-# LANGUAGE RankNTypes #-} + module A where + type A = forall a. a + + And you define the following in a separate module *without* RankNTypes + enabled: + + module B where + + import A + + type Const a b = a + f :: Const Int A -> Int + + Then `f` will be accepted, even though `A` (which is technically a rank-n + type) appears in its type. We view this as an acceptable compromise, since + `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in + a type post-expansion, such as in the following variant: + + g :: Const A A -> Int + + Then that would be rejected unless RankNTypes were enabled. +-} + +-- | When validity-checking an application of a type synonym, should we +-- check the arguments, check the expanded type, or both? +-- See Note [Correctness and performance of type synonym validity checking] +data ExpandMode + = Expand -- ^ Only check the expanded type. + | NoExpand -- ^ Only check the arguments. + | Both -- ^ Check both the arguments and the expanded type. + +instance Outputable ExpandMode where + ppr e = text $ case e of + Expand -> "Expand" + NoExpand -> "NoExpand" + Both -> "Both" + +-- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the +-- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start +-- in 'Both' mode. +initialExpandMode :: TcM ExpandMode +initialExpandMode = do + liberal_flag <- xoptM LangExt.LiberalTypeSynonyms + pure $ if liberal_flag then Expand else Both + +-- | Information about a type being validity-checked. +data ValidityEnv = ValidityEnv + { ve_tidy_env :: TidyEnv + , ve_ctxt :: UserTypeCtxt + , ve_rank :: Rank + , ve_expand :: ExpandMode } + +instance Outputable ValidityEnv where + ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand }) = + hang (text "ValidityEnv") + 2 (vcat [ text "ve_tidy_env" <+> ppr env + , text "ve_ctxt" <+> pprUserTypeCtxt ctxt + , text "ve_rank" <+> ppr rank + , text "ve_expand" <+> ppr expand ]) + +---------------------------------------- +check_type :: ValidityEnv -> Type -> TcM () +-- The args say what the *type context* requires, independent +-- of *flag* settings. You test the flag settings at usage sites. +-- +-- Rank is allowed rank for function args +-- Rank 0 means no for-alls anywhere + +check_type _ (TyVarTy _) = return () + +check_type ve (AppTy ty1 ty2) + = do { check_type ve ty1 + ; check_arg_type False ve ty2 } + +check_type ve ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = check_syn_tc_app ve ty tc tys + | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys + | otherwise = mapM_ (check_arg_type False ve) tys + +check_type _ (LitTy {}) = return () + +check_type ve (CastTy ty _) = check_type ve ty + +-- Check for rank-n types, such as (forall x. x -> x) or (Show x => x). +-- +-- Critically, this case must come *after* the case for TyConApp. +-- See Note [Liberal type synonyms]. +check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt + , ve_rank = rank, ve_expand = expand }) ty + | not (null tvbs && null theta) + = do { traceTc "check_type" (ppr ty $$ ppr rank) + ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty) + -- Reject e.g. (Maybe (?x::Int => Int)), + -- with a decent error message + + ; checkConstraintsOK ve theta ty + -- Reject forall (a :: Eq b => b). blah + -- In a kind signature we don't allow constraints + + ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs + || vdqAllowed ctxt) + (illegalVDQTyErr env ty) + -- Reject visible, dependent quantification in the type of a + -- term (e.g., `f :: forall a -> a -> Maybe a`) + + ; check_valid_theta env' SigmaCtxt expand theta + -- Allow type T = ?x::Int => Int -> Int + -- but not type T = ?x::Int + + ; check_type (ve{ve_tidy_env = env'}) tau + -- Allow foralls to right of arrow + + ; checkEscapingKind env' tvbs' theta tau } + where + (tvbs, phi) = tcSplitForAllVarBndrs ty + (theta, tau) = tcSplitPhiTy phi + (env', tvbs') = tidyTyCoVarBinders env tvbs + +check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ _ arg_ty res_ty) + = do { check_type (ve{ve_rank = arg_rank}) arg_ty + ; check_type (ve{ve_rank = res_rank}) res_ty } + where + (arg_rank, res_rank) = funArgResRank rank + +check_type _ ty = pprPanic "check_type" (ppr ty) + +---------------------------------------- +check_syn_tc_app :: ValidityEnv + -> KindOrType -> TyCon -> [KindOrType] -> TcM () +-- Used for type synonyms and type synonym families, +-- which must be saturated, +-- but not data families, which need not be saturated +check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand }) + ty tc tys + | tys `lengthAtLeast` tc_arity -- Saturated + -- Check that the synonym has enough args + -- This applies equally to open and closed synonyms + -- It's OK to have an *over-applied* type synonym + -- data Tree a b = ... + -- type Foo a = Tree [a] + -- f :: Foo a b -> ... + = case expand of + _ | isTypeFamilyTyCon tc + -> check_args_only expand + -- See Note [Correctness and performance of type synonym validity + -- checking] + Expand -> check_expansion_only expand + NoExpand -> check_args_only expand + Both -> check_args_only NoExpand *> check_expansion_only Both + + | GhciCtxt True <- ctxt -- Accept outermost under-saturated type synonym or + -- type family constructors in GHCi :kind commands. + -- See Note [Unsaturated type synonyms in GHCi] + = check_args_only expand + + | otherwise + = failWithTc (tyConArityErr tc tys) + where + tc_arity = tyConArity tc + + check_arg :: ExpandMode -> KindOrType -> TcM () + check_arg expand = + check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand}) + + check_args_only, check_expansion_only :: ExpandMode -> TcM () + check_args_only expand = mapM_ (check_arg expand) tys + + check_expansion_only expand + = ASSERT2( isTypeSynonymTyCon tc, ppr tc ) + case tcView ty of + Just ty' -> let err_ctxt = text "In the expansion of type synonym" + <+> quotes (ppr tc) + in addErrCtxt err_ctxt $ + check_type (ve{ve_expand = expand}) ty' + Nothing -> pprPanic "check_syn_tc_app" (ppr ty) + +{- +Note [Unsaturated type synonyms in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, GHC disallows unsaturated uses of type synonyms or type +families. For instance, if one defines `type Const a b = a`, then GHC will not +permit using `Const` unless it is applied to (at least) two arguments. There is +an exception to this rule, however: GHCi's :kind command. For instance, it +is quite common to look up the kind of a type constructor like so: + + λ> :kind Const + Const :: j -> k -> j + λ> :kind Const Int + Const Int :: k -> Type + +Strictly speaking, the two uses of `Const` above are unsaturated, but this +is an extremely benign (and useful) example of unsaturation, so we allow it +here as a special case. + +That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise, +this GHCi interaction would be possible: + + λ> newtype Fix f = MkFix (f (Fix f)) + λ> type Id a = a + λ> :kind Fix Id + Fix Id :: Type + +This is rather dodgy, so we move to disallow this. We only permit unsaturated +synonyms in GHCi if they are *top-level*—that is, if the synonym is the +outermost type being applied. This allows `Const` and `Const Int` in the +first example, but not `Fix Id` in the second example, as `Id` is not the +outermost type being applied (`Fix` is). + +We track this outermost property in the GhciCtxt constructor of UserTypeCtxt. +A field of True in GhciCtxt indicates that we're in an outermost position. Any +time we invoke `check_arg` to check the validity of an argument, we switch the +field to False. +-} + +---------------------------------------- +check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM () +check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys + = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples + ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty) + + ; impred <- xoptM LangExt.ImpredicativeTypes + ; let rank' = if impred then ArbitraryRank else tyConArgMonoType + -- c.f. check_arg_type + -- However, args are allowed to be unlifted, or + -- more unboxed tuples, so can't use check_arg_ty + ; mapM_ (check_type (ve{ve_rank = rank'})) tys } + +---------------------------------------- +check_arg_type + :: Bool -- ^ Is this the argument to a type synonym? + -> ValidityEnv -> KindOrType -> TcM () +-- The sort of type that can instantiate a type variable, +-- or be the argument of a type constructor. +-- Not an unboxed tuple, but now *can* be a forall (since impredicativity) +-- Other unboxed types are very occasionally allowed as type +-- arguments depending on the kind of the type constructor +-- +-- For example, we want to reject things like: +-- +-- instance Ord a => Ord (forall s. T s a) +-- and +-- g :: T s (forall b.b) +-- +-- NB: unboxed tuples can have polymorphic or unboxed args. +-- This happens in the workers for functions returning +-- product types with polymorphic components. +-- But not in user code. +-- Anyway, they are dealt with by a special case in check_tau_type + +check_arg_type _ _ (CoercionTy {}) = return () + +check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty + = do { impred <- xoptM LangExt.ImpredicativeTypes + ; let rank' = case rank of -- Predictive => must be monotype + -- Rank-n arguments to type synonyms are OK, provided + -- that LiberalTypeSynonyms is enabled. + _ | type_syn -> synArgMonoType + MustBeMonoType -> MustBeMonoType -- Monotype, regardless + _other | impred -> ArbitraryRank + | otherwise -> tyConArgMonoType + -- Make sure that MustBeMonoType is propagated, + -- so that we don't suggest -XImpredicativeTypes in + -- (Ord (forall a.a)) => a -> a + -- and so that if it Must be a monotype, we check that it is! + ctxt' :: UserTypeCtxt + ctxt' + | GhciCtxt _ <- ctxt = GhciCtxt False + -- When checking an argument, set the field of GhciCtxt to + -- False to indicate that we are no longer in an outermost + -- position (and thus unsaturated synonyms are no longer + -- allowed). + -- See Note [Unsaturated type synonyms in GHCi] + | otherwise = ctxt + + ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } + +---------------------------------------- +forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) +forAllTyErr env rank ty + = ( env + , vcat [ hang herald 2 (ppr_tidy env ty) + , suggestion ] ) + where + (tvs, _theta, _tau) = tcSplitSigmaTy ty + herald | null tvs = text "Illegal qualified type:" + | otherwise = text "Illegal polymorphic type:" + suggestion = case rank of + LimitedRank {} -> text "Perhaps you intended to use RankNTypes" + MonoType d -> d + _ -> Outputable.empty -- Polytype is always illegal + +-- | Reject type variables that would escape their escape through a kind. +-- See @Note [Type variables escaping through kinds]@. +checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM () +checkEscapingKind env tvbs theta tau = + case occCheckExpand (binderVars tvbs) phi_kind of + -- Ensure that none of the tvs occur in the kind of the forall + -- /after/ expanding type synonyms. + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind + Just _ -> pure () + where + tau_kind = tcTypeKind tau + phi_kind | null theta = tau_kind + | otherwise = liftedTypeKind + -- If there are any constraints, the kind is *. (#11405) + +forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind + -> (TidyEnv, SDoc) +forAllEscapeErr env tvbs theta tau tau_kind + = ( env + , vcat [ hang (text "Quantified type's kind mentions quantified type variable") + 2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau))) + -- NB: Don't tidy this type since the tvbs were already tidied + -- previously, and re-tidying them will make the names of type + -- variables different from tau_kind. + , hang (text "where the body of the forall has this kind:") + 2 (quotes (ppr_tidy env tau_kind)) ] ) + +{- +Note [Type variables escaping through kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + + type family T (r :: RuntimeRep) :: TYPE r + foo :: forall r. T r + +Something smells funny about the type of `foo`. If you spell out the kind +explicitly, it becomes clearer from where the smell originates: + + foo :: ((forall r. T r) :: TYPE r) + +The type variable `r` appears in the result kind, which escapes the scope of +its binding site! This is not desirable, so we establish a validity check +(`checkEscapingKind`) to catch any type variables that might escape through +kinds in this way. +-} + +ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +ubxArgTyErr env ty + = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:" + , ppr_tidy env ty ] + , text "Perhaps you intended to use UnboxedTuples" ] ) + +checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () +checkConstraintsOK ve theta ty + | null theta = return () + | allConstraintsAllowed (ve_ctxt ve) = return () + | otherwise + = -- We are in a kind, where we allow only equality predicates + -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263 + checkTcM (all isEqPred theta) $ + constraintTyErr (ve_tidy_env ve) ty + +constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintTyErr env ty + = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) + +-- | Reject a use of visible, dependent quantification in the type of a term. +illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +illegalVDQTyErr env ty = + (env, vcat + [ hang (text "Illegal visible, dependent quantification" <+> + text "in the type of a term:") + 2 (ppr_tidy env ty) + , text "(GHC does not yet support this)" ] ) + +{- +Note [Liberal type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* +doing validity checking. This allows us to instantiate a synonym defn +with a for-all type, or with a partially-applied type synonym. + e.g. type T a b = a + type S m = m () + f :: S (T Int) +Here, T is partially applied, so it's illegal in H98. But if you +expand S first, then T we get just + f :: Int +which is fine. + +IMPORTANT: suppose T is a type synonym. Then we must do validity +checking on an application (T ty1 ty2) + + *either* before expansion (i.e. check ty1, ty2) + *or* after expansion (i.e. expand T ty1 ty2, and then check) + BUT NOT BOTH + +If we do both, we get exponential behaviour!! + + data TIACons1 i r c = c i ::: r c + type TIACons2 t x = TIACons1 t (TIACons1 t x) + type TIACons3 t x = TIACons2 t (TIACons1 t x) + type TIACons4 t x = TIACons2 t (TIACons2 t x) + type TIACons7 t x = TIACons4 t (TIACons3 t x) + +The order in which you do validity checking is also somewhat delicate. Consider +the `check_type` function, which drives the validity checking for unsaturated +uses of type synonyms. There is a special case for rank-n types, such as +(forall x. x -> x) or (Show x => x), since those require at least one language +extension to use. It used to be the case that this case came before every other +case, but this can lead to bugs. Imagine you have this scenario (from #15954): + + type A a = Int + type B (a :: Type -> Type) = forall x. x -> x + type C = B A + +If the rank-n case came first, then in the process of checking for `forall`s +or contexts, we would expand away `B A` to `forall x. x -> x`. This is because +the functions that split apart `forall`s/contexts +(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded +away to `forall x. x -> x` before the actually validity checks occur, we will +have completely obfuscated the fact that we had an unsaturated application of +the `A` type synonym. + +We have since learned from our mistakes and now put this rank-n case /after/ +the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be +caught properly. But be careful! We can't make the rank-n case /last/ either, +as the FunTy case must came after the rank-n case. Otherwise, something like +(Eq a => Int) would be treated as a function type (FunTy), which just +wouldn't do. + +************************************************************************ +* * +\subsection{Checking a theta or source type} +* * +************************************************************************ + +Note [Implicit parameters in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Implicit parameters _only_ allowed in type signatures; not in instance +decls, superclasses etc. The reason for not allowing implicit params in +instances is a bit subtle. If we allowed + instance (?x::Int, Eq a) => Foo [a] where ... +then when we saw + (e :: (?x::Int) => t) +it would be unclear how to discharge all the potential uses of the ?x +in e. For example, a constraint Foo [Int] might come out of e, and +applying the instance decl would show up two uses of ?x. #8912. +-} + +checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () +-- Assumes argument is fully zonked +checkValidTheta ctxt theta + = addErrCtxtM (checkThetaCtxt ctxt theta) $ + do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) + ; expand <- initialExpandMode + ; check_valid_theta env ctxt expand theta } + +------------------------- +check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode + -> [PredType] -> TcM () +check_valid_theta _ _ _ [] + = return () +check_valid_theta env ctxt expand theta + = do { dflags <- getDynFlags + ; warnTcM (Reason Opt_WarnDuplicateConstraints) + (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) + (dupPredWarn env dups) + ; traceTc "check_valid_theta" (ppr theta) + ; mapM_ (check_pred_ty env dflags ctxt expand) theta } + where + (_,dups) = removeDups nonDetCmpType theta + -- It's OK to use nonDetCmpType because dups only appears in the + -- warning + +------------------------- +{- Note [Validity checking for constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look through constraint synonyms so that we can see the underlying +constraint(s). For example + type Foo = ?x::Int + instance Foo => C T +We should reject the instance because it has an implicit parameter in +the context. + +But we record, in 'under_syn', whether we have looked under a synonym +to avoid requiring language extensions at the use site. Main example +(#9838): + + {-# LANGUAGE ConstraintKinds #-} + module A where + type EqShow a = (Eq a, Show a) + + module B where + import A + foo :: EqShow a => a -> String + +We don't want to require ConstraintKinds in module B. +-} + +check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode + -> PredType -> TcM () +-- Check the validity of a predicate in a signature +-- See Note [Validity checking for constraints] +check_pred_ty env dflags ctxt expand pred + = do { check_type ve pred + ; check_pred_help False env dflags ctxt pred } + where + rank | xopt LangExt.QuantifiedConstraints dflags + = ArbitraryRank + | otherwise + = constraintMonoType + + ve :: ValidityEnv + ve = ValidityEnv{ ve_tidy_env = env + , ve_ctxt = SigmaCtxt + , ve_rank = rank + , ve_expand = expand } + +check_pred_help :: Bool -- True <=> under a type synonym + -> TidyEnv + -> DynFlags -> UserTypeCtxt + -> PredType -> TcM () +check_pred_help under_syn env dflags ctxt pred + | Just pred' <- tcView pred -- Switch on under_syn when going under a + -- synonym (#9838, yuk) + = check_pred_help True env dflags ctxt pred' + + | otherwise -- A bit like classifyPredType, but not the same + -- E.g. we treat (~) like (~#); and we look inside tuples + = case classifyPredType pred of + ClassPred cls tys + | isCTupleClass cls -> check_tuple_pred under_syn env dflags ctxt pred tys + | otherwise -> check_class_pred env dflags ctxt pred cls tys + + EqPred _ _ _ -> pprPanic "check_pred_help" (ppr pred) + -- EqPreds, such as (t1 ~ #t2) or (t1 ~R# t2), don't even have kind Constraint + -- and should never appear before the '=>' of a type. Thus + -- f :: (a ~# b) => blah + -- is wrong. For user written signatures, it'll be rejected by kind-checking + -- well before we get to validity checking. For inferred types we are careful + -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described + -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType + + ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head + IrredPred {} -> check_irred_pred under_syn env dflags ctxt pred + +check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () +check_eq_pred env dflags pred + = -- Equational constraints are valid in all contexts if type + -- families are permitted + checkTcM (xopt LangExt.TypeFamilies dflags + || xopt LangExt.GADTs dflags) + (eqPredTyErr env pred) + +check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt + -> PredType -> ThetaType -> PredType -> TcM () +check_quant_pred env dflags ctxt pred theta head_pred + = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $ + do { -- Check the instance head + case classifyPredType head_pred of + -- SigmaCtxt tells checkValidInstHead that + -- this is the head of a quantified constraint + ClassPred cls tys -> do { checkValidInstHead SigmaCtxt cls tys + ; check_pred_help False env dflags ctxt head_pred } + -- need check_pred_help to do extra pred-only validity + -- checks, such as for (~). Otherwise, we get #17563 + -- NB: checks for the context are covered by the check_type + -- in check_pred_ty + IrredPred {} | hasTyVarHead head_pred + -> return () + _ -> failWithTcM (badQuantHeadErr env pred) + + -- Check for termination + ; unless (xopt LangExt.UndecidableInstances dflags) $ + checkInstTermination theta head_pred + } + +check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () +check_tuple_pred under_syn env dflags ctxt pred ts + = do { -- See Note [ConstraintKinds in predicates] + checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags) + (predTupleErr env pred) + ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } + -- This case will not normally be executed because without + -- -XConstraintKinds tuple types are only kind-checked as * + +check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () +check_irred_pred under_syn env dflags ctxt pred + -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint + -- where X is a type function + = do { -- If it looks like (x t1 t2), require ConstraintKinds + -- see Note [ConstraintKinds in predicates] + -- But (X t1 t2) is always ok because we just require ConstraintKinds + -- at the definition site (#9838) + failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) + && hasTyVarHead pred) + (predIrredErr env pred) + + -- Make sure it is OK to have an irred pred in this context + -- See Note [Irreducible predicates in superclasses] + ; failIfTcM (is_superclass ctxt + && not (xopt LangExt.UndecidableInstances dflags) + && has_tyfun_head pred) + (predSuperClassErr env pred) } + where + is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } + has_tyfun_head ty + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isTypeFamilyTyCon tc + Nothing -> False + +{- Note [ConstraintKinds in predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't check for -XConstraintKinds under a type synonym, because that +was done at the type synonym definition site; see #9838 +e.g. module A where + type C a = (Eq a, Ix a) -- Needs -XConstraintKinds + module B where + import A + f :: C a => a -> a -- Does *not* need -XConstraintKinds + +Note [Irreducible predicates in superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Allowing type-family calls in class superclasses is somewhat dangerous +because we can write: + + type family Fooish x :: * -> Constraint + type instance Fooish () = Foo + class Fooish () a => Foo a where + +This will cause the constraint simplifier to loop because every time we canonicalise a +(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately +solved to add+canonicalise another (Foo a) constraint. -} + +------------------------- +check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt + -> PredType -> Class -> [TcType] -> TcM () +check_class_pred env dflags ctxt pred cls tys + | isEqPredClass cls -- (~) and (~~) are classified as classes, + -- but here we want to treat them as equalities + = check_eq_pred env dflags pred + + | isIPClass cls + = do { check_arity + ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) } + + | otherwise -- Includes Coercible + = do { check_arity + ; checkSimplifiableClassConstraint env dflags ctxt cls tys + ; checkTcM arg_tys_ok (predTyVarErr env pred) } + where + check_arity = checkTc (tys `lengthIs` classArity cls) + (tyConArityErr (classTyCon cls) tys) + + -- Check the arguments of a class constraint + flexible_contexts = xopt LangExt.FlexibleContexts dflags + undecidable_ok = xopt LangExt.UndecidableInstances dflags + arg_tys_ok = case ctxt of + SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine + InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys + -- Further checks on head and theta + -- in checkInstTermination + _ -> checkValidClsArgs flexible_contexts cls tys + +checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt + -> Class -> [TcType] -> TcM () +-- See Note [Simplifiable given constraints] +checkSimplifiableClassConstraint env dflags ctxt cls tys + | not (wopt Opt_WarnSimplifiableClassConstraints dflags) + = return () + | xopt LangExt.MonoLocalBinds dflags + = return () + + | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta" + = return () -- of a data type declaration + + | cls `hasKey` coercibleTyConKey + = return () -- Oddly, we treat (Coercible t1 t2) as unconditionally OK + -- matchGlobalInst will reply "yes" because we can reduce + -- (Coercible a b) to (a ~R# b) + + | otherwise + = do { result <- matchGlobalInst dflags False cls tys + ; case result of + OneInst { cir_what = what } + -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints) + (simplifiable_constraint_warn what) + _ -> return () } + where + pred = mkClassPred cls tys + + simplifiable_constraint_warn :: InstanceWhat -> SDoc + simplifiable_constraint_warn what + = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)) + <+> text "matches") + 2 (ppr what) + , hang (text "This makes type inference for inner bindings fragile;") + 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] + +{- Note [Simplifiable given constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type signature like + f :: Eq [(a,b)] => a -> b +is very fragile, for reasons described at length in GHC.Tc.Solver.Interact +Note [Instance and Given overlap]. As that Note discusses, for the +most part the clever stuff in GHC.Tc.Solver.Interact means that we don't use a +top-level instance if a local Given might fire, so there is no +fragility. But if we /infer/ the type of a local let-binding, things +can go wrong (#11948 is an example, discussed in the Note). + +So this warning is switched on only if we have NoMonoLocalBinds; in +that case the warning discourages users from writing simplifiable +class constraints. + +The warning only fires if the constraint in the signature +matches the top-level instances in only one way, and with no +unifiers -- that is, under the same circumstances that +GHC.Tc.Solver.Interact.matchInstEnv fires an interaction with the top +level instances. For example (#13526), consider + + instance {-# OVERLAPPABLE #-} Eq (T a) where ... + instance Eq (T Char) where .. + f :: Eq (T a) => ... + +We don't want to complain about this, even though the context +(Eq (T a)) matches an instance, because the user may be +deliberately deferring the choice so that the Eq (T Char) +has a chance to fire when 'f' is called. And the fragility +only matters when there's a risk that the instance might +fire instead of the local 'given'; and there is no such +risk in this case. Just use the same rules as for instance +firing! +-} + +------------------------- +okIPCtxt :: UserTypeCtxt -> Bool + -- See Note [Implicit parameters in instance decls] +okIPCtxt (FunSigCtxt {}) = True +okIPCtxt (InfSigCtxt {}) = True +okIPCtxt ExprSigCtxt = True +okIPCtxt TypeAppCtxt = True +okIPCtxt PatSigCtxt = True +okIPCtxt ResSigCtxt = True +okIPCtxt GenSigCtxt = True +okIPCtxt (ConArgCtxt {}) = True +okIPCtxt (ForSigCtxt {}) = True -- ?? +okIPCtxt ThBrackCtxt = True +okIPCtxt (GhciCtxt {}) = True +okIPCtxt SigmaCtxt = True +okIPCtxt (DataTyCtxt {}) = True +okIPCtxt (PatSynCtxt {}) = True +okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int + -- #11466 + +okIPCtxt (KindSigCtxt {}) = False +okIPCtxt (StandaloneKindSigCtxt {}) = False +okIPCtxt (ClassSCCtxt {}) = False +okIPCtxt (InstDeclCtxt {}) = False +okIPCtxt (SpecInstCtxt {}) = False +okIPCtxt (RuleSigCtxt {}) = False +okIPCtxt DefaultDeclCtxt = False +okIPCtxt DerivClauseCtxt = False +okIPCtxt (TyVarBndrKindCtxt {}) = False +okIPCtxt (DataKindCtxt {}) = False +okIPCtxt (TySynKindCtxt {}) = False +okIPCtxt (TyFamResKindCtxt {}) = False + +{- +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +MultiParam check: + + class C f where... -- C :: forall k. k -> Constraint + instance C Maybe where... + + The dictionary gets type [C * Maybe] even if it's not a MultiParam + type class. + +Flexibility check: + + class C f where... -- C :: forall k. k -> Constraint + data D a = D a + instance C D where + + The dictionary gets type [C * (D *)]. IA0_TODO it should be + generalized actually. +-} + +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) +checkThetaCtxt ctxt theta env + = return ( env + , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) + , text "While checking" <+> pprUserTypeCtxt ctxt ] ) + +eqPredTyErr, predTupleErr, predIrredErr, + predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) +badQuantHeadErr env pred + = ( env + , hang (text "Quantified predicate must have a class or type variable head:") + 2 (ppr_tidy env pred) ) +eqPredTyErr env pred + = ( env + , text "Illegal equational constraint" <+> ppr_tidy env pred $$ + parens (text "Use GADTs or TypeFamilies to permit this") ) +predTupleErr env pred + = ( env + , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) + 2 (parens constraintKindsMsg) ) +predIrredErr env pred + = ( env + , hang (text "Illegal constraint:" <+> ppr_tidy env pred) + 2 (parens constraintKindsMsg) ) +predSuperClassErr env pred + = ( env + , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) + <+> text "in a superclass context") + 2 (parens undecidableMsg) ) + +predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) +predTyVarErr env pred + = (env + , vcat [ hang (text "Non type-variable argument") + 2 (text "in the constraint:" <+> ppr_tidy env pred) + , parens (text "Use FlexibleContexts to permit this") ]) + +badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) +badIPPred env pred + = ( env + , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) + +constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintSynErr env kind + = ( env + , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) + 2 (parens constraintKindsMsg) ) + +dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) +dupPredWarn env dups + = ( env + , text "Duplicate constraint" <> plural primaryDups <> text ":" + <+> pprWithCommas (ppr_tidy env) primaryDups ) + where + primaryDups = map NE.head dups + +tyConArityErr :: TyCon -> [TcType] -> SDoc +-- For type-constructor arity errors, be careful to report +-- the number of /visible/ arguments required and supplied, +-- ignoring the /invisible/ arguments, which the user does not see. +-- (e.g. #10516) +tyConArityErr tc tks + = arityErr (ppr (tyConFlavour tc)) (tyConName tc) + tc_type_arity tc_type_args + where + vis_tks = filterOutInvisibleTypes tc tks + + -- tc_type_arity = number of *type* args expected + -- tc_type_args = number of *type* args encountered + tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) + tc_type_args = length vis_tks + +arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc +arityErr what name n m + = hsep [ text "The" <+> what, quotes (ppr name), text "should have", + n_arguments <> comma, text "but has been given", + if m==0 then text "none" else int m] + where + n_arguments | n == 0 = text "no arguments" + | n == 1 = text "1 argument" + | True = hsep [int n, text "arguments"] + +{- +************************************************************************ +* * +\subsection{Checking for a decent instance head type} +* * +************************************************************************ + +@checkValidInstHead@ checks the type {\em and} its syntactic constraints: +it must normally look like: @instance Foo (Tycon a b c ...) ...@ + +The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ +flag is on, or (2)~the instance is imported (they must have been +compiled elsewhere). In these cases, we let them go through anyway. + +We can also have instances for functions: @instance Foo (a -> b) ...@. +-} + +checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () +checkValidInstHead ctxt clas cls_args + = do { dflags <- getDynFlags + ; is_boot <- tcIsHsBootOrSig + ; is_sig <- tcIsHsig + ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args + ; checkValidTypePats (classTyCon clas) cls_args + } + +{- + +Note [Instances of built-in classes in signature files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +User defined instances for KnownNat, KnownSymbol and Typeable are +disallowed -- they are generated when needed by GHC itself on-the-fly. + +However, if they occur in a Backpack signature file, they have an +entirely different meaning. Suppose in M.hsig we see + + signature M where + data T :: Nat + instance KnownNat T + +That says that any module satisfying M.hsig must provide a KnownNat +instance for T. We absolultely need that instance when compiling a +module that imports M.hsig: see #15379 and +Note [Fabricating Evidence for Literals in Backpack] in GHC.Tc.Instance.Class. + +Hence, checkValidInstHead accepts a user-written instance declaration +in hsig files, where `is_sig` is True. + +-} + +check_special_inst_head :: DynFlags -> Bool -> Bool + -> UserTypeCtxt -> Class -> [Type] -> TcM () +-- Wow! There are a surprising number of ad-hoc special cases here. +check_special_inst_head dflags is_boot is_sig ctxt clas cls_args + + -- If not in an hs-boot file, abstract classes cannot have instances + | isAbstractClass clas + , not is_boot + = failWithTc abstract_class_msg + + -- For Typeable, don't complain about instances for + -- standalone deriving; they are no-ops, and we warn about + -- it in GHC.Tc.Deriv.deriveStandalone. + | clas_nm == typeableClassName + , not is_sig + -- Note [Instances of built-in classes in signature files] + , hand_written_bindings + = failWithTc rejected_class_msg + + -- Handwritten instances of KnownNat/KnownSymbol class + -- are always forbidden (#12837) + | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ] + , not is_sig + -- Note [Instances of built-in classes in signature files] + , hand_written_bindings + = failWithTc rejected_class_msg + + -- For the most part we don't allow + -- instances for (~), (~~), or Coercible; + -- but we DO want to allow them in quantified constraints: + -- f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m... + | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ] + , not quantified_constraint + = failWithTc rejected_class_msg + + -- Check for hand-written Generic instances (disallowed in Safe Haskell) + | clas_nm `elem` genericClassNames + , hand_written_bindings + = do { failIfTc (safeLanguageOn dflags) gen_inst_err + ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } + + | clas_nm == hasFieldClassName + = checkHasFieldInst clas cls_args + + | isCTupleClass clas + = failWithTc tuple_class_msg + + -- Check language restrictions on the args to the class + | check_h98_arg_shape + , Just msg <- mb_ty_args_msg + = failWithTc (instTypeErr clas cls_args msg) + + | otherwise + = pure () + where + clas_nm = getName clas + ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args + + hand_written_bindings + = case ctxt of + InstDeclCtxt stand_alone -> not stand_alone + SpecInstCtxt -> False + DerivClauseCtxt -> False + _ -> True + + check_h98_arg_shape = case ctxt of + SpecInstCtxt -> False + DerivClauseCtxt -> False + SigmaCtxt -> False + _ -> True + -- SigmaCtxt: once we are in quantified-constraint land, we + -- aren't so picky about enforcing H98-language restrictions + -- E.g. we want to allow a head like Coercible (m a) (m b) + + + -- When we are looking at the head of a quantified constraint, + -- check_quant_pred sets ctxt to SigmaCtxt + quantified_constraint = case ctxt of + SigmaCtxt -> True + _ -> False + + head_type_synonym_msg = parens ( + text "All instance types must be of the form (T t1 ... tn)" $$ + text "where T is not a synonym." $$ + text "Use TypeSynonymInstances if you want to disable this.") + + head_type_args_tyvars_msg = parens (vcat [ + text "All instance types must be of the form (T a1 ... an)", + text "where a1 ... an are *distinct type variables*,", + text "and each type variable appears at most once in the instance head.", + text "Use FlexibleInstances if you want to disable this."]) + + head_one_type_msg = parens $ + text "Only one type can be given in an instance head." $$ + text "Use MultiParamTypeClasses if you want to allow more, or zero." + + rejected_class_msg = text "Class" <+> quotes (ppr clas_nm) + <+> text "does not support user-specified instances" + tuple_class_msg = text "You can't specify an instance for a tuple constraint" + + gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)") + + abstract_class_msg = text "Cannot define instance for abstract class" + <+> quotes (ppr clas_nm) + + mb_ty_args_msg + | not (xopt LangExt.TypeSynonymInstances dflags) + , not (all tcInstHeadTyNotSynonym ty_args) + = Just head_type_synonym_msg + + | not (xopt LangExt.FlexibleInstances dflags) + , not (all tcInstHeadTyAppAllTyVars ty_args) + = Just head_type_args_tyvars_msg + + | length ty_args /= 1 + , not (xopt LangExt.MultiParamTypeClasses dflags) + , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) + = Just head_one_type_msg + + | otherwise + = Nothing + +tcInstHeadTyNotSynonym :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must not be type synonyms, but everywhere else type synonyms +-- are transparent, so we need a special function here +tcInstHeadTyNotSynonym ty + = case ty of -- Do not use splitTyConApp, + -- because that expands synonyms! + TyConApp tc _ -> not (isTypeSynonymTyCon tc) || tc == unrestrictedFunTyCon + -- Allow (->), e.g. instance Category (->), + -- even though it's a type synonym for FUN 'Many + _ -> True + +tcInstHeadTyAppAllTyVars :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must be a constructor applied to type variable arguments +-- or a type-level literal. +-- But we allow +-- 1) kind instantiations +-- 2) the type (->) = FUN 'Many, even though it's not in this form. +tcInstHeadTyAppAllTyVars ty + | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) + = let tys' = filterOutInvisibleTypes tc tys -- avoid kinds + tys'' | tc == funTyCon, tys_h:tys_t <- tys', tys_h `eqType` manyDataConTy = tys_t + | otherwise = tys' + in ok tys'' + | LitTy _ <- ty = True -- accept type literals (#13833) + | otherwise + = False + where + -- Check that all the types are type variables, + -- and that each is distinct + ok tys = equalLength tvs tys && hasNoDups tvs + where + tvs = mapMaybe tcGetTyVar_maybe tys + +dropCasts :: Type -> Type +-- See Note [Casts during validity checking] +-- This function can turn a well-kinded type into an ill-kinded +-- one, so I've kept it local to this module +-- To consider: drop only HoleCo casts +dropCasts (CastTy ty _) = dropCasts ty +dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) +dropCasts ty@(FunTy _ w t1 t2) = ty { ft_mult = dropCasts w, ft_arg = dropCasts t1, ft_res = dropCasts t2 } +dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) +dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) +dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy + +dropCastsB :: TyVarBinder -> TyVarBinder +dropCastsB b = b -- Don't bother in the kind of a forall + +instTypeErr :: Class -> [Type] -> SDoc -> SDoc +instTypeErr cls tys msg + = hang (hang (text "Illegal instance declaration for") + 2 (quotes (pprClassPred cls tys))) + 2 msg + +-- | See Note [Validity checking of HasField instances] +checkHasFieldInst :: Class -> [Type] -> TcM () +checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] = + case splitTyConApp_maybe r_ty of + Nothing -> whoops (text "Record data type must be specified") + Just (tc, _) + | isFamilyTyCon tc + -> whoops (text "Record data type may not be a data family") + | otherwise -> case isStrLitTy x_ty of + Just lbl + | isJust (lookupTyConFieldLabel lbl tc) + -> whoops (ppr tc <+> text "already has a field" + <+> quotes (ppr lbl)) + | otherwise -> return () + Nothing + | null (tyConFieldLabels tc) -> return () + | otherwise -> whoops (ppr tc <+> text "has fields") + where + whoops = addErrTc . instTypeErr cls tys +checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) + +{- Note [Casts during validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the (bogus) + instance Eq Char# +We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an +insoluble equality constraint for * ~ #. We'll report the insoluble +constraint separately, but we don't want to *also* complain that Eq is +not applied to a type constructor. So we look gaily look through +CastTys here. + +Another example: Eq (Either a). Then we actually get a cast in +the middle: + Eq ((Either |> g) a) + + +Note [Validity checking of HasField instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The HasField class has magic constraint solving behaviour (see Note +[HasField instances] in GHC.Tc.Solver.Interact). However, we permit users to +declare their own instances, provided they do not clash with the +built-in behaviour. In particular, we forbid: + + 1. `HasField _ r _` where r is a variable + + 2. `HasField _ (T ...) _` if T is a data family + (because it might have fields introduced later) + + 3. `HasField x (T ...) _` where x is a variable, + if T has any fields at all + + 4. `HasField "foo" (T ...) _` if T has a "foo" field + +The usual functional dependency checks also apply. + + +Note [Valid 'deriving' predicate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +validDerivPred checks for OK 'deriving' context. See Note [Exotic +derived instance contexts] in GHC.Tc.Deriv. However the predicate is +here because it uses sizeTypes, fvTypes. + +It checks for three things + + * No repeated variables (hasNoDups fvs) + + * No type constructors. This is done by comparing + sizeTypes tys == length (fvTypes tys) + sizeTypes counts variables and constructors; fvTypes returns variables. + So if they are the same, there must be no constructors. But there + might be applications thus (f (g x)). + + Note that tys only includes the visible arguments of the class type + constructor. Including the non-visible arguments can cause the following, + perfectly valid instance to be rejected: + class Category (cat :: k -> k -> *) where ... + newtype T (c :: * -> * -> *) a b = MkT (c a b) + instance Category c => Category (T c) where ... + since the first argument to Category is a non-visible *, which sizeTypes + would count as a constructor! See #11833. + + * Also check for a bizarre corner case, when the derived instance decl + would look like + instance C a b => D (T a) where ... + Note that 'b' isn't a parameter of T. This gives rise to all sorts of + problems; in particular, it's hard to compare solutions for equality + when finding the fixpoint, and that means the inferContext loop does + not converge. See #5287. + +Note [Equality class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't have users writing instances for the equality classes. But we +still need to be able to write instances for them ourselves. So we allow +instances only in the defining module. + +-} + +validDerivPred :: TyVarSet -> PredType -> Bool +-- See Note [Valid 'deriving' predicate] +validDerivPred tv_set pred + = case classifyPredType pred of + ClassPred cls tys -> cls `hasKey` typeableClassKey + -- Typeable constraints are bigger than they appear due + -- to kind polymorphism, but that's OK + || check_tys cls tys + EqPred {} -> False -- reject equality constraints + _ -> True -- Non-class predicates are ok + where + check_tys cls tys + = hasNoDups fvs + -- use sizePred to ignore implicit args + && lengthIs fvs (sizePred pred) + && all (`elemVarSet` tv_set) fvs + where tys' = filterOutInvisibleTypes (classTyCon cls) tys + fvs = fvTypes tys' + +{- +************************************************************************ +* * +\subsection{Checking instance for termination} +* * +************************************************************************ +-} + +{- Note [Instances and constraint synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, we don't allow instances for constraint synonyms at all. +Consider these (#13267): + type C1 a = Show (a -> Bool) + instance C1 Int where -- I1 + show _ = "ur" + +This elicits "show is not a (visible) method of class C1", which isn't +a great message. But it comes from the renamer, so it's hard to improve. + +This needs a bit more care: + type C2 a = (Show a, Show Int) + instance C2 Int -- I2 + +If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose +the instance head, we'll expand the synonym on fly, and it'll look like + instance (%,%) (Show Int, Show Int) +and we /really/ don't want that. So we carefully do /not/ expand +synonyms, by matching on TyConApp directly. +-} + +checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () +checkValidInstance ctxt hs_type ty + | not is_tc_app + = failWithTc (hang (text "Instance head is not headed by a class:") + 2 ( ppr tau)) + + | isNothing mb_cls + = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) + , text "A class instance must be for a class" ]) + + | not arity_ok + = failWithTc (text "Arity mis-match in instance head") + + | otherwise + = do { setSrcSpan head_loc $ + checkValidInstHead ctxt clas inst_tys + + ; traceTc "checkValidInstance {" (ppr ty) + + ; env0 <- tcInitTidyEnv + ; expand <- initialExpandMode + ; check_valid_theta env0 ctxt expand theta + + -- The Termination and Coverate Conditions + -- Check that instance inference will terminate (if we care) + -- For Haskell 98 this will already have been done by checkValidTheta, + -- but as we may be using other extensions we need to check. + -- + -- Note that the Termination Condition is *more conservative* than + -- the checkAmbiguity test we do on other type signatures + -- e.g. Bar a => Bar Int is ambiguous, but it also fails + -- the termination condition, because 'a' appears more often + -- in the constraint than in the head + ; undecidable_ok <- xoptM LangExt.UndecidableInstances + ; if undecidable_ok + then checkAmbiguity ctxt ty + else checkInstTermination theta tau + + ; traceTc "cvi 2" (ppr ty) + + ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of + IsValid -> return () -- Check succeeded + NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) + + ; traceTc "End checkValidInstance }" empty + + ; return () } + where + (_tvs, theta, tau) = tcSplitSigmaTy ty + is_tc_app = case tau of { TyConApp {} -> True; _ -> False } + TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] + mb_cls = tyConClass_maybe tc + Just clas = mb_cls + arity_ok = inst_tys `lengthIs` classArity clas + + -- The location of the "head" of the instance + head_loc = getLoc (getLHsInstDeclHead hs_type) + +{- +Note [Paterson conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Termination test: the so-called "Paterson conditions" (see Section 5 of +"Understanding functional dependencies via Constraint Handling Rules, +JFP Jan 2007). + +We check that each assertion in the context satisfies: + (1) no variable has more occurrences in the assertion than in the head, and + (2) the assertion has fewer constructors and variables (taken together + and counting repetitions) than the head. +This is only needed with -fglasgow-exts, as Haskell 98 restrictions +(which have already been checked) guarantee termination. + +The underlying idea is that + + for any ground substitution, each assertion in the + context has fewer type constructors than the head. +-} + +checkInstTermination :: ThetaType -> TcPredType -> TcM () +-- See Note [Paterson conditions] +checkInstTermination theta head_pred + = check_preds emptyVarSet theta + where + head_fvs = fvType head_pred + head_size = sizeType head_pred + + check_preds :: VarSet -> [PredType] -> TcM () + check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds + + check :: VarSet -> PredType -> TcM () + check foralld_tvs pred + = case classifyPredType pred of + EqPred {} -> return () -- See #4200. + IrredPred {} -> check2 foralld_tvs pred (sizeType pred) + ClassPred cls tys + | isTerminatingClass cls + -> return () + + | isCTupleClass cls -- Look inside tuple predicates; #8359 + -> check_preds foralld_tvs tys + + | otherwise -- Other ClassPreds + -> check2 foralld_tvs pred bogus_size + where + bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys) + -- See Note [Invisible arguments and termination] + + ForAllPred tvs _ head_pred' + -> check (foralld_tvs `extendVarSetList` tvs) head_pred' + -- Termination of the quantified predicate itself is checked + -- when the predicates are individually checked for validity + + check2 foralld_tvs pred pred_size + | not (null bad_tvs) = failWithTc (noMoreMsg bad_tvs what (ppr head_pred)) + | not (isTyFamFree pred) = failWithTc (nestedMsg what) + | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred)) + | otherwise = return () + -- isTyFamFree: see Note [Type families in instance contexts] + where + what = text "constraint" <+> quotes (ppr pred) + bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred) + \\ head_fvs + +smallerMsg :: SDoc -> SDoc -> SDoc +smallerMsg what inst_head + = vcat [ hang (text "The" <+> what) + 2 (sep [ text "is no smaller than" + , text "the instance head" <+> quotes inst_head ]) + , parens undecidableMsg ] + +noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc +noMoreMsg tvs what inst_head + = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1) + <+> occurs <+> text "more often") + 2 (sep [ text "in the" <+> what + , text "than in the instance head" <+> quotes inst_head ]) + , parens undecidableMsg ] + where + tvs1 = nub tvs + occurs = if isSingleton tvs1 then text "occurs" + else text "occur" + +undecidableMsg, constraintKindsMsg :: SDoc +undecidableMsg = text "Use UndecidableInstances to permit this" +constraintKindsMsg = text "Use ConstraintKinds to permit this" + +{- Note [Type families in instance contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are these OK? + type family F a + instance F a => C (Maybe [a]) where ... + instance C (F a) => C [[[a]]] where ... + +No: the type family in the instance head might blow up to an +arbitrarily large type, depending on how 'a' is instantiated. +So we require UndecidableInstances if we have a type family +in the instance head. #15172. + +Note [Invisible arguments and termination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the ​Paterson conditions for termination an instance +declaration, we check for the number of "constructors and variables" +in the instance head and constraints. Question: Do we look at + + * All the arguments, visible or invisible? + * Just the visible arguments? + +I think both will ensure termination, provided we are consistent. +Currently we are /not/ consistent, which is really a bug. It's +described in #15177, which contains a number of examples. +The suspicious bits are the calls to filterOutInvisibleTypes. +-} + + +{- +************************************************************************ +* * + Checking type instance well-formedness and termination +* * +************************************************************************ +-} + +checkValidCoAxiom :: CoAxiom Branched -> TcM () +checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) + = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list + ; foldlM_ check_branch_compat [] branch_list } + where + branch_list = fromBranches branches + injectivity = tyConInjectivityInfo fam_tc + + check_branch_compat :: [CoAxBranch] -- previous branches in reverse order + -> CoAxBranch -- current branch + -> TcM [CoAxBranch]-- current branch : previous branches + -- Check for + -- (a) this branch is dominated by previous ones + -- (b) failure of injectivity + check_branch_compat prev_branches cur_branch + | cur_branch `isDominatedBy` prev_branches + = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ + inaccessibleCoAxBranch fam_tc cur_branch + ; return prev_branches } + | otherwise + = do { check_injectivity prev_branches cur_branch + ; return (cur_branch : prev_branches) } + + -- Injectivity check: check whether a new (CoAxBranch) can extend + -- already checked equations without violating injectivity + -- annotation supplied by the user. + -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + check_injectivity prev_branches cur_branch + | Injective inj <- injectivity + = do { dflags <- getDynFlags + ; let conflicts = + fst $ foldl' (gather_conflicts inj prev_branches cur_branch) + ([], 0) prev_branches + ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch + ; reportInjectivityErrors dflags ax cur_branch inj } + | otherwise + = return () + + gather_conflicts inj prev_branches cur_branch (acc, n) branch + -- n is 0-based index of branch in prev_branches + = case injectiveBranches inj cur_branch branch of + -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv + InjectivityUnified ax1 ax2 + | ax1 `isDominatedBy` (replace_br prev_branches n ax2) + -> (acc, n + 1) + | otherwise + -> (branch : acc, n + 1) + InjectivityAccepted -> (acc, n + 1) + + -- Replace n-th element in the list. Assumes 0-based indexing. + replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] + replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs + + +-- Check that a "type instance" is well-formed (which includes decidability +-- unless -XUndecidableInstances is given). +-- +checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () +checkValidCoAxBranch fam_tc + (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = typats + , cab_rhs = rhs, cab_loc = loc }) + = setSrcSpan loc $ + checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs + +-- | Do validity checks on a type family equation, including consistency +-- with any enclosing class instance head, termination, and lack of +-- polytypes. +checkValidTyFamEqn :: TyCon -- ^ of the type family + -> [Var] -- ^ Bound variables in the equation + -> [Type] -- ^ Type patterns + -> Type -- ^ Rhs + -> TcM () +checkValidTyFamEqn fam_tc qvs typats rhs + = do { checkValidTypePats fam_tc typats + + -- Check for things used on the right but not bound on the left + ; checkFamPatBinders fam_tc qvs typats rhs + + -- Check for oversaturated visible kind arguments in a type family + -- equation. + -- See Note [Oversaturated type family equations] + ; when (isTypeFamilyTyCon fam_tc) $ + case drop (tyConArity fam_tc) typats of + [] -> pure () + spec_arg:_ -> + addErr $ text "Illegal oversaturated visible kind argument:" + <+> quotes (char '@' <> pprParendType spec_arg) + + -- The argument patterns, and RHS, are all boxed tau types + -- E.g Reject type family F (a :: k1) :: k2 + -- type instance F (forall a. a->a) = ... + -- type instance F Int# = ... + -- type instance F Int = forall a. a->a + -- type instance F Int = Int# + -- See #9357 + ; checkValidMonoType rhs + + -- We have a decidable instance unless otherwise permitted + ; undecidable_ok <- xoptM LangExt.UndecidableInstances + ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) + ; unless undecidable_ok $ + mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } + +-- | Checks that an associated type family default: +-- +-- 1. Only consists of arguments that are bare type variables, and +-- +-- 2. Has a distinct type variable in each argument. +-- +-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl". +checkValidAssocTyFamDeflt :: TyCon -- ^ of the type family + -> [Type] -- ^ Type patterns + -> TcM () +checkValidAssocTyFamDeflt fam_tc pats = + do { cpt_tvs <- zipWithM extract_tv pats pats_vis + ; check_all_distinct_tvs $ zip cpt_tvs pats_vis } + where + pats_vis :: [ArgFlag] + pats_vis = tyConArgFlags fam_tc pats + + -- Checks that a pattern on the LHS of a default is a type + -- variable. If so, return the underlying type variable, and if + -- not, throw an error. + -- See Note [Type-checking default assoc decls] + extract_tv :: Type -- The particular type pattern from which to extract + -- its underlying type variable + -> ArgFlag -- The visibility of the type pattern + -- (only used for error message purposes) + -> TcM TyVar + extract_tv pat pat_vis = + case getTyVar_maybe pat of + Just tv -> pure tv + Nothing -> failWithTc $ + pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") + 2 (vcat [ppr_eqn, suggestion]) + + -- Checks that no type variables in an associated default declaration are + -- duplicated. If that is the case, throw an error. + -- See Note [Type-checking default assoc decls] + check_all_distinct_tvs :: + [(TyVar, ArgFlag)] -- The type variable arguments in the associated + -- default declaration, along with their respective + -- visibilities (the latter are only used for error + -- message purposes) + -> TcM () + check_all_distinct_tvs cpt_tvs_vis = + let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in + traverse_ + (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ + pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + hang (text "Illegal duplicate variable" + <+> quotes (ppr pat_tv) <+> text "in:") + 2 (vcat [ppr_eqn, suggestion])) + dups + + ppr_eqn :: SDoc + ppr_eqn = + quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) + <+> equals <+> text "...") + + suggestion :: SDoc + suggestion = text "The arguments to" <+> quotes (ppr fam_tc) + <+> text "must all be distinct type variables" + +-- Make sure that each type family application is +-- (1) strictly smaller than the lhs, +-- (2) mentions no type variable more often than the lhs, and +-- (3) does not contain any further type family instances. +-- +checkFamInstRhs :: TyCon -> [Type] -- LHS + -> [(TyCon, [Type])] -- type family calls in RHS + -> [MsgDoc] +checkFamInstRhs lhs_tc lhs_tys famInsts + = mapMaybe check famInsts + where + lhs_size = sizeTyConAppArgs lhs_tc lhs_tys + inst_head = pprType (TyConApp lhs_tc lhs_tys) + lhs_fvs = fvTypes lhs_tys + check (tc, tys) + | not (all isTyFamFree tys) = Just (nestedMsg what) + | not (null bad_tvs) = Just (noMoreMsg bad_tvs what inst_head) + | lhs_size <= fam_app_size = Just (smallerMsg what inst_head) + | otherwise = Nothing + where + what = text "type family application" + <+> quotes (pprType (TyConApp tc tys)) + fam_app_size = sizeTyConAppArgs tc tys + bad_tvs = fvTypes tys \\ lhs_fvs + -- The (\\) is list difference; e.g. + -- [a,b,a,a] \\ [a,a] = [b,a] + -- So we are counting repetitions + +----------------- +checkFamPatBinders :: TyCon + -> [TcTyVar] -- Bound on LHS of family instance + -> [TcType] -- LHS patterns + -> Type -- RHS + -> TcM () +-- We do these binder checks now, in tcFamTyPatsAndGen, rather +-- than later, in checkValidFamEqn, for two reasons: +-- - We have the implicitly and explicitly +-- bound type variables conveniently to hand +-- - If implicit variables are out of scope it may +-- cause a crash; notably in tcConDecl in tcDataFamInstDecl +checkFamPatBinders fam_tc qtvs pats rhs + = do { traceTc "checkFamPatBinders" $ + vcat [ debugPprType (mkTyConApp fam_tc pats) + , ppr (mkTyConApp fam_tc pats) + , text "qtvs:" <+> ppr qtvs + , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) + , text "cpt_tvs:" <+> ppr cpt_tvs + , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ] + + -- Check for implicitly-bound tyvars, mentioned on the + -- RHS but not bound on the LHS + -- data T = MkT (forall (a::k). blah) + -- data family D Int = MkD (forall (a::k). blah) + -- In both cases, 'k' is not bound on the LHS, but is used on the RHS + -- We catch the former in kcDeclHeader, and the latter right here + -- See Note [Check type-family instance binders] + ; check_tvs bad_rhs_tvs (text "mentioned in the RHS") + (text "bound on the LHS of") + + -- Check for explicitly forall'd variable that is not bound on LHS + -- data instance forall a. T Int = MkT Int + -- See Note [Unused explicitly bound variables in a family pattern] + -- See Note [Check type-family instance binders] + ; check_tvs bad_qtvs (text "bound by a forall") + (text "used in") + } + where + cpt_tvs = tyCoVarsOfTypes pats + inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats + -- The type variables that are in injective positions. + -- See Note [Dodgy binding sites in type family instances] + -- NB: The False above is irrelevant, as we never have type families in + -- patterns. + -- + -- NB: It's OK to use the nondeterministic `fvVarSet` function here, + -- since the order of `inj_cpt_tvs` is never revealed in an error + -- message. + rhs_fvs = tyCoFVsOfType rhs + used_tvs = cpt_tvs `unionVarSet` fvVarSet rhs_fvs + bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs + -- Bound but not used at all + bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs) + -- Used on RHS but not bound on LHS + dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs + + check_tvs tvs what what2 + = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ + hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs + <+> isOrAre tvs <+> what <> comma) + 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" + , mk_extra tvs ]) + + -- mk_extra: #7536: give a decent error message for + -- type T a = Int + -- type instance F (T a) = a + mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $ + hang (text "The real LHS (expanding synonyms) is:") + 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) + + +-- | Checks that a list of type patterns is valid in a matching (LHS) +-- position of a class instances or type/data family instance. +-- +-- Specifically: +-- * All monotypes +-- * No type-family applications +checkValidTypePats :: TyCon -> [Type] -> TcM () +checkValidTypePats tc pat_ty_args + = do { -- Check that each of pat_ty_args is a monotype. + -- One could imagine generalising to allow + -- instance C (forall a. a->a) + -- but we don't know what all the consequences might be. + traverse_ checkValidMonoType pat_ty_args + + -- Ensure that no type family applications occur a type pattern + ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of + [] -> pure () + ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ + ty_fam_inst_illegal_err tf_is_invis_arg + (mkTyConApp tf_tc tf_args) } + where + inst_ty = mkTyConApp tc pat_ty_args + + ty_fam_inst_illegal_err :: Bool -> Type -> SDoc + ty_fam_inst_illegal_err invis_arg ty + = pprWithExplicitKindsWhen invis_arg $ + hang (text "Illegal type synonym family application" + <+> quotes (ppr ty) <+> text "in instance" <> colon) + 2 (ppr inst_ty) + +-- Error messages + +inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc +inaccessibleCoAxBranch fam_tc cur_branch + = text "Type family instance equation is overlapped:" $$ + nest 2 (pprCoAxBranchUser fam_tc cur_branch) + +nestedMsg :: SDoc -> SDoc +nestedMsg what + = sep [ text "Illegal nested" <+> what + , parens undecidableMsg ] + +badATErr :: Name -> Name -> SDoc +badATErr clas op + = hsep [text "Class", quotes (ppr clas), + text "does not have an associated type", quotes (ppr op)] + + +------------------------- +checkConsistentFamInst :: AssocInstInfo + -> TyCon -- ^ Family tycon + -> CoAxBranch + -> TcM () +-- See Note [Checking consistent instantiation] + +checkConsistentFamInst NotAssociated _ _ + = return () + +checkConsistentFamInst (InClsInst { ai_class = clas + , ai_tyvars = inst_tvs + , ai_inst_env = mini_env }) + fam_tc branch + = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs + , ppr arg_triples + , ppr mini_env + , ppr ax_tvs + , ppr ax_arg_tys + , ppr arg_triples ]) + -- Check that the associated type indeed comes from this class + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) + (badATErr (className clas) (tyConName fam_tc)) + + ; check_match arg_triples + } + where + (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch + + arg_triples :: [(Type,Type, ArgFlag)] + arg_triples = [ (cls_arg_ty, at_arg_ty, vis) + | (fam_tc_tv, vis, at_arg_ty) + <- zip3 (tyConTyVars fam_tc) + (tyConArgFlags fam_tc ax_arg_tys) + ax_arg_tys + , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] + + pp_wrong_at_arg vis + = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $ + vcat [ text "Type indexes must match class instance head" + , text "Expected:" <+> pp_expected_ty + , text " Actual:" <+> pp_actual_ty ] + + -- Fiddling around to arrange that wildcards unconditionally print as "_" + -- We only need to print the LHS, not the RHS at all + -- See Note [Printing conflicts with class header] + (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs + (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs) + + pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ + toIfaceTcArgs fam_tc $ + [ case lookupVarEnv mini_env at_tv of + Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty + Nothing -> mk_wildcard at_tv + | at_tv <- tyConTyVars fam_tc ] + + pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ + toIfaceTcArgs fam_tc $ + tidyTypes tidy_env2 ax_arg_tys + + mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) + tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan + + -- For check_match, bind_me, see + -- Note [Matching in the consistent-instantiation check] + check_match :: [(Type,Type,ArgFlag)] -> TcM () + check_match triples = go emptyTCvSubst emptyTCvSubst triples + + go _ _ [] = return () + go lr_subst rl_subst ((ty1,ty2,vis):triples) + | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2 + , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 + = go lr_subst1 rl_subst1 triples + | otherwise + = addErrTc (pp_wrong_at_arg vis) + + -- The /scoped/ type variables from the class-instance header + -- should not be alpha-renamed. Inferred ones can be. + no_bind_set = mkVarSet inst_tvs + bind_me tv | tv `elemVarSet` no_bind_set = Skolem + | otherwise = BindMe + + +{- Note [Check type-family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type family instance, we require (of course), type variables +used on the RHS are matched on the LHS. This is checked by +checkFamPatBinders. Here is an interesting example: + + type family T :: k + type instance T = (Nothing :: Maybe a) + +Upon a cursory glance, it may appear that the kind variable `a` is unbound +since there are no (visible) LHS patterns in `T`. However, there is an +*invisible* pattern due to the return kind, so inside of GHC, the instance +looks closer to this: + + type family T @k :: k + type instance T @(Maybe a) = (Nothing :: Maybe a) + +Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in +fact not unbound. Contrast that with this example (#13985) + + type instance T = Proxy (Nothing :: Maybe a) + +This would looks like this inside of GHC: + + type instance T @(*) = Proxy (Nothing :: Maybe a) + +So this time, `a` is neither bound by a visible nor invisible type pattern on +the LHS, so `a` would be reported as not in scope. + +Finally, here's one more brain-teaser (from #9574). In the example below: + + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + type Codomain 'KProxy = NatTr (Proxy :: o -> *) + +As it turns out, `o` is in scope in this example. That is because `o` is +bound by the kind signature of the LHS type pattern 'KProxy. To make this more +obvious, one can also write the instance like so: + + instance Funct ('KProxy :: KProxy o) where + type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) + +Note [Dodgy binding sites in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from #7536): + + type T a = Int + type instance F (T a) = a + +This `F` instance is extremely fishy, since the RHS, `a`, purports to be +"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because +`T a` expands to `Int`, which doesn't mention at all, so it's as if one had +actually written: + + type instance F Int = a + +That is clearly bogus, so to reject this, we check that every type variable +that is mentioned on the RHS is /actually/ bound on the LHS. In other words, +we need to do something slightly more sophisticated that just compute the free +variables of the LHS patterns. + +It's tempting to just expand all type synonyms on the LHS and then compute +their free variables, but even that isn't sophisticated enough. After all, +an impish user could write the following (#17008): + + type family ConstType (a :: Type) :: Type where + ConstType _ = Type + + type family F (x :: ConstType a) :: Type where + F (x :: ConstType a) = a + +Just like in the previous example, the `a` on the RHS isn't actually bound +on the LHS, but this time a type family is responsible for the deception, not +a type synonym. + +We avoid both issues by requiring that all RHS type variables are mentioned +in injective positions on the left-hand side (by way of +`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective +position, as `T` is not an injective type constructor, so we do not count that. +Similarly for the `a` in `ConstType a`. + +Note [Matching in the consistent-instantiation check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Matching the class-instance header to family-instance tyvars is +tricker than it sounds. Consider (#13972) + class C (a :: k) where + type T k :: Type + instance C Left where + type T (a -> Either a b) = Int + +Here there are no lexically-scoped variables from (C Left). +Yet the real class-instance header is C @(p -> Either @p @q)) (Left @p @q) +while the type-family instance is T (a -> Either @a @b) +So we allow alpha-renaming of variables that don't come +from the class-instance header. + +We track the lexically-scoped type variables from the +class-instance header in ai_tyvars. + +Here's another example (#14045a) + class C (a :: k) where + data S (a :: k) + instance C (z :: Bool) where + data S :: Bool -> Type where + +Again, there is no lexical connection, but we will get + class-instance header: C @Bool (z::Bool) + family instance S @Bool (a::Bool) + +When looking for mis-matches, we check left-to-right, +kinds first. If we look at types first, we'll fail to +suggest -fprint-explicit-kinds for a mis-match with + T @k vs T @Type +somewhere deep inside the type + +Note [Checking consistent instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #11450 for background discussion on this check. + + class C a b where + type T a x b + +With this class decl, if we have an instance decl + instance C ty1 ty2 where ... +then the type instance must look like + type T ty1 v ty2 = ... +with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. +For example: + + instance C [p] Int + type T [p] y Int = (p,y,y) + +Note that + +* We used to allow completely different bound variables in the + associated type instance; e.g. + instance C [p] Int + type T [q] y Int = ... + But from GHC 8.2 onwards, we don't. It's much simpler this way. + See #11450. + +* When the class variable isn't used on the RHS of the type instance, + it's tempting to allow wildcards, thus + instance C [p] Int + type T [_] y Int = (y,y) + But it's awkward to do the test, and it doesn't work if the + variable is repeated: + instance C (p,p) Int + type T (_,_) y Int = (y,y) + Even though 'p' is not used on the RHS, we still need to use 'p' + on the LHS to establish the repeated pattern. So to keep it simple + we just require equality. + +* For variables in associated type families that are not bound by the class + itself, we do _not_ check if they are over-specific. In other words, + it's perfectly acceptable to have an instance like this: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + + While the first and third arguments to T are required to be exactly [p] and + Int, respectively, since they are bound by C, the second argument is allowed + to be more specific than just a type variable. Furthermore, it is permissible + to define multiple equations for T that differ only in the non-class-bound + argument: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + type T [p] (Either x y) Int = x -> y + + We once considered requiring that non-class-bound variables in associated + type family instances be instantiated with distinct type variables. However, + that requirement proved too restrictive in practice, as there were examples + of extremely simple associated type family instances that this check would + reject, and fixing them required tiresome boilerplate in the form of + auxiliary type families. For instance, you would have to define the above + example as: + + instance C [p] Int where + type T [p] x Int = CAux x + + type family CAux x where + CAux (Maybe x) = x + CAux (Either x y) = x -> y + + We decided that this restriction wasn't buying us much, so we opted not + to pursue that design (see also GHC #13398). + +Implementation + * Form the mini-envt from the class type variables a,b + to the instance decl types [p],Int: [a->[p], b->Int] + + * Look at the tyvars a,x,b of the type family constructor T + (it shares tyvars with the class C) + + * Apply the mini-evnt to them, and check that the result is + consistent with the instance types [p] y Int. (where y can be any type, as + it is not scoped over the class type variables. + +We make all the instance type variables scope over the +type instances, of course, which picks up non-obvious kinds. Eg + class Foo (a :: k) where + type F a + instance Foo (b :: k -> k) where + type F b = Int +Here the instance is kind-indexed and really looks like + type F (k->k) (b::k->k) = Int +But if the 'b' didn't scope, we would make F's instance too +poly-kinded. + +Note [Printing conflicts with class header] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's remarkably painful to give a decent error message for conflicts +with the class header. Consider + clase C b where + type F a b c + instance C [b] where + type F x Int _ _ = ... + +Here we want to report a conflict between + Expected: F _ [b] _ + Actual: F x Int _ _ + +But if the type instance shadows the class variable like this +(rename/should_fail/T15828): + instance C [b] where + type forall b. F x (Tree b) _ _ = ... + +then we must use a fresh variable name + Expected: F _ [b] _ + Actual: F x [b1] _ _ + +Notice that: + - We want to print an underscore in the "Expected" type in + positions where the class header has no influence over the + parameter. Hence the fancy footwork in pp_expected_ty + + - Although the binders in the axiom are already tidy, we must + re-tidy them to get a fresh variable name when we shadow + + - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the + class-instance variables a second time, from 'a' to 'a1' say. + Remember, the ax_tvs of the axiom share identity with the + class-instance variables, inst_tvs.. + + - We use tidyCoAxBndrsForUser to get underscores rather than + _1, _2, etc in the axiom tyvars; see the definition of + tidyCoAxBndrsForUser + +This all seems absurdly complicated. + +Note [Unused explicitly bound variables in a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Why is 'unusedExplicitForAllErr' not just a warning? + +Consider the following examples: + + type instance F a = Maybe b + type instance forall b. F a = Bool + type instance forall b. F a = Maybe b + +In every case, b is a type variable not determined by the LHS pattern. The +first is caught by the renamer, but we catch the last two here. Perhaps one +could argue that the second should be accepted, albeit with a warning, but +consider the fact that in a type family instance, there is no way to interact +with such a varable. At least with @x :: forall a. Int@ we can use visibile +type application, like @x \@Bool 1@. (Of course it does nothing, but it is +permissible.) In the type family case, the only sensible explanation is that +the user has made a mistake -- thus we throw an error. + +Note [Oversaturated type family equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type family tycons have very rigid arities. We want to reject something like +this: + + type family Foo :: Type -> Type where + Foo x = ... + +Because Foo has arity zero (i.e., it doesn't bind anything to the left of the +double colon), we want to disallow any equation for Foo that has more than zero +arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an +equation has more arguments than the arity of the type family, reject. + +Things get trickier when visible kind application enters the picture. Consider +the following example: + + type family Bar (x :: j) :: forall k. Either j k where + Bar 5 @Symbol = ... + +The arity of Bar is two, since it binds two variables, `j` and `x`. But even +though Bar's equation has two arguments, it's still invalid. Imagine the same +equation in Core: + + Bar Nat 5 Symbol = ... + +Here, it becomes apparent that Bar is actually taking /three/ arguments! So +we can't just rely on a simple counting argument to reject +`Bar 5 @Symbol = ...`, since it only has two user-written arguments. +Moreover, there's one explicit argument (5) and one visible kind argument +(@Symbol), which matches up perfectly with the fact that Bar has one required +binder (x) and one specified binder (j), so that's not a valid way to detect +oversaturation either. + +To solve this problem in a robust way, we do the following: + +1. When kind-checking, we count the number of user-written *required* + arguments and check if there is an equal number of required tycon binders. + If not, reject. (See `wrongNumberOfParmsErr` in GHC.Tc.TyCl.) + + We perform this step during kind-checking, not during validity checking, + since we can give better error messages if we catch it early. +2. When validity checking, take all of the (Core) type patterns from on + equation, drop the first n of them (where n is the arity of the type family + tycon), and check if there are any types leftover. If so, reject. + + Why does this work? We know that after dropping the first n type patterns, + none of the leftover types can be required arguments, since step (1) would + have already caught that. Moreover, the only places where visible kind + applications should be allowed are in the first n types, since those are the + only arguments that can correspond to binding forms. Therefore, the + remaining arguments must correspond to oversaturated uses of visible kind + applications, which are precisely what we want to reject. + +Note that we only perform this check for type families, and not for data +families. This is because it is perfectly acceptable to oversaturate data +family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv. + +************************************************************************ +* * + Telescope checking +* * +************************************************************************ + +Note [Bad TyCon telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Now that we can mix type and kind variables, there are an awful lot of +ways to shoot yourself in the foot. Here are some. + + data SameKind :: k -> k -> * -- just to force unification + +1. data T1 a k (b :: k) (x :: SameKind a b) + +The problem here is that we discover that a and b should have the same +kind. But this kind mentions k, which is bound *after* a. +(Testcase: dependent/should_fail/BadTelescope) + +2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +Note that b is not bound. Yet its kind mentions a. Because we have +a nice rule that all implicitly bound variables come before others, +this is bogus. + +To catch these errors, we call checkTyConTelescope during kind-checking +datatype declarations. This checks for + +* Ill-scoped binders. From (1) and (2) above we can get putative + kinds like + T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> * + where 'k' is mentioned a's kind before k is bound + + This is easy to check for: just look for + out-of-scope variables in the kind + +* We should arguably also check for ambiguous binders + but we don't. See Note [Ambiguous kind vars]. + +See also + * Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl. + * Note [Checking telescopes] in GHC.Tc.Types.Constraint discusses how + this check works for `forall x y z.` written in a type. + +Note [Ambiguous kind vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to be concerned about ambiguous binders. Suppose we have the kind + S1 :: forall k -> * -> * + S2 :: forall k. * -> * +Here S1 is OK, because k is Required, and at a use of S1 we will +see (S1 *) or (S1 (*->*)) or whatever. + +But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and +we have no way (ever) to figure out how 'k' should be instantiated. +For example if we see (S2 Int), that tells us nothing about k's +instantiation. (In this case we'll instantiate it to Any, but that +seems wrong.) This is really the same test as we make for ambiguous +type in term type signatures. + +Now, it's impossible for a Specified variable not to occur +at all in the kind -- after all, it is Specified so it must have +occurred. (It /used/ to be possible; see tests T13983 and T7873. But +with the advent of the forall-or-nothing rule for kind variables, +those strange cases went away. See Note [forall-or-nothing rule] in +GHC.Rename.HsType.) + +But one might worry about + type v k = * + S3 :: forall k. V k -> * +which appears to mention 'k' but doesn't really. Or + S4 :: forall k. F k -> * +where F is a type function. But we simply don't check for +those cases of ambiguity, yet anyway. The worst that can happen +is ambiguity at the call sites. + +Historical note: this test used to be called reportFloatingKvs. +-} + +-- | Check a list of binders to see if they make a valid telescope. +-- See Note [Bad TyCon telescopes] +type TelescopeAcc + = ( TyVarSet -- Bound earlier in the telescope + , Bool -- At least one binder occurred (in a kind) before + -- it was bound in the telescope. E.g. + ) -- T :: forall (a::k) k. blah + +checkTyConTelescope :: TyCon -> TcM () +checkTyConTelescope tc + | bad_scope + = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] + addErr $ + vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") + 2 pp_tc_kind + , extra + , hang (text "Perhaps try this order instead:") + 2 (pprTyVars sorted_tvs) ] + + | otherwise + = return () + where + tcbs = tyConBinders tc + tvs = binderVars tcbs + sorted_tvs = scopedSort tvs + + (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs + + add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc + add_one (bound, bad_scope) tcb + = ( bound `extendVarSet` tv + , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) ) + where + tv = binderVar tcb + fkvs = tyCoVarsOfType (tyVarKind tv) + + inferred_tvs = [ binderVar tcb + | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] + specified_tvs = [ binderVar tcb + | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ] + + pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) + pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) + + pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc) + ppr_untidy ty = pprIfaceType (toIfaceType ty) + -- We need ppr_untidy here because pprType will tidy the type, which + -- will turn the bogus kind we are trying to report + -- T :: forall (a::k) k (b::k) -> blah + -- into a misleadingly sanitised version + -- T :: forall (a::k) k1 (b::k1) -> blah + + extra + | null inferred_tvs && null specified_tvs + = empty + | null inferred_tvs + = hang (text "NB: Specified variables") + 2 (sep [pp_spec, text "always come first"]) + | null specified_tvs + = hang (text "NB: Inferred variables") + 2 (sep [pp_inf, text "always come first"]) + | otherwise + = hang (text "NB: Inferred variables") + 2 (vcat [ sep [ pp_inf, text "always come first"] + , sep [text "then Specified variables", pp_spec]]) + +{- +************************************************************************ +* * +\subsection{Auxiliary functions} +* * +************************************************************************ +-} + +-- Free variables of a type, retaining repetitions, and expanding synonyms +-- This ignores coercions, as coercions aren't user-written +fvType :: Type -> [TyCoVar] +fvType ty | Just exp_ty <- tcView ty = fvType exp_ty +fvType (TyVarTy tv) = [tv] +fvType (TyConApp _ tys) = fvTypes tys +fvType (LitTy {}) = [] +fvType (AppTy fun arg) = fvType fun ++ fvType arg +fvType (FunTy _ w arg res) = fvType w ++ fvType arg ++ fvType res +fvType (ForAllTy (Bndr tv _) ty) + = fvType (tyVarKind tv) ++ + filter (/= tv) (fvType ty) +fvType (CastTy ty _) = fvType ty +fvType (CoercionTy {}) = [] + +fvTypes :: [Type] -> [TyVar] +fvTypes tys = concatMap fvType tys + +sizeType :: Type -> Int +-- Size of a type: the number of variables and constructors +sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty +sizeType (TyVarTy {}) = 1 +sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys +sizeType (LitTy {}) = 1 +sizeType (AppTy fun arg) = sizeType fun + sizeType arg +sizeType (FunTy _ w arg res) = sizeType w + sizeType arg + sizeType res + 1 +sizeType (ForAllTy _ ty) = sizeType ty +sizeType (CastTy ty _) = sizeType ty +sizeType (CoercionTy _) = 0 + +sizeTypes :: [Type] -> Int +sizeTypes = foldr ((+) . sizeType) 0 + +sizeTyConAppArgs :: TyCon -> [Type] -> Int +sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys) + -- See Note [Invisible arguments and termination] + +-- Size of a predicate +-- +-- We are considering whether class constraints terminate. +-- Equality constraints and constraints for the implicit +-- parameter class always terminate so it is safe to say "size 0". +-- See #4200. +sizePred :: PredType -> Int +sizePred ty = goClass ty + where + goClass p = go (classifyPredType p) + + go (ClassPred cls tys') + | isTerminatingClass cls = 0 + | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys') + -- The filtering looks bogus + -- See Note [Invisible arguments and termination] + go (EqPred {}) = 0 + go (IrredPred ty) = sizeType ty + go (ForAllPred _ _ pred) = goClass pred + +-- | When this says "True", ignore this class constraint during +-- a termination check +isTerminatingClass :: Class -> Bool +isTerminatingClass cls + = isIPClass cls -- Implicit parameter constraints always terminate because + -- there are no instances for them --- they are only solved + -- by "local instances" in expressions + || isEqPredClass cls + || cls `hasKey` typeableClassKey + || cls `hasKey` coercibleTyConKey + +-- | Tidy before printing a type +ppr_tidy :: TidyEnv -> Type -> SDoc +ppr_tidy env ty = pprType (tidyType env ty) + +allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool +-- (allDistinctTyVars tvs tys) returns True if tys are +-- a) all tyvars +-- b) all distinct +-- c) disjoint from tvs +allDistinctTyVars _ [] = True +allDistinctTyVars tkvs (ty : tys) + = case getTyVar_maybe ty of + Nothing -> False + Just tv | tv `elemVarSet` tkvs -> False + | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys diff --git a/GHC/ThToHs.hs b/GHC/ThToHs.hs --- a/GHC/ThToHs.hs +++ b/GHC/ThToHs.hs @@ -6,12 +6,19 @@ This module converts Template Haskell syntax into Hs syntax -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module GHC.ThToHs ( convertToHsExpr , convertToPat @@ -21,29 +28,29 @@ ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs as Hs -import PrelNames -import RdrName -import qualified Name -import Module -import RdrHsSyn -import OccName -import SrcLoc -import Type -import qualified Coercion ( Role(..) ) -import TysWiredIn -import BasicTypes as Hs -import ForeignCall -import Unique -import ErrUtils -import Bag -import Lexeme -import Util -import FastString -import Outputable -import MonadUtils ( foldrM ) +import GHC.Builtin.Names +import GHC.Types.Name.Reader +import qualified GHC.Types.Name as Name +import GHC.Unit.Module +import GHC.Parser.PostProcess +import GHC.Types.Name.Occurrence as OccName +import GHC.Types.SrcLoc +import GHC.Core.Type as Hs +import qualified GHC.Core.Coercion as Coercion ( Role(..) ) +import GHC.Builtin.Types +import GHC.Types.Basic as Hs +import GHC.Types.ForeignCall +import GHC.Types.Unique +import GHC.Utils.Error +import GHC.Data.Bag +import GHC.Utils.Lexeme +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable as Outputable +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import qualified Data.ByteString as BS import Control.Monad( unless, ap ) @@ -118,34 +125,33 @@ setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a -returnL x = CvtM (\_ loc -> Right (loc, cL loc x)) +returnL :: a -> CvtM (Located a) +returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a) +returnJustL :: a -> CvtM (Maybe (Located a)) returnJustL = fmap Just . returnL -wrapParL :: HasSrcSpan a => - (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a) -wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x))) +wrapParL :: (Located a -> a) -> a -> CvtM a +wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x))) wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing wrapMsg what item (CvtM m) = CvtM $ \origin loc -> case m origin loc of - Left err -> Left (err $$ getPprStyle msg) + Left err -> Left (err $$ msg) Right v -> Right v where -- Show the item in pretty syntax normally, -- but with all its constructors if you say -dppr-debug - msg sty = hang (text "When splicing a TH" <+> text what <> colon) - 2 (if debugStyle sty - then text (show item) - else text (pprint item)) + msg = hang (text "When splicing a TH" <+> text what <> colon) + 2 (getPprDebug $ \case + True -> text (show item) + False -> text (pprint item)) -wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a +wrapL :: CvtM a -> CvtM (Located a) wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of Left err -> Left err - Right (loc',v) -> Right (loc',cL loc v) + Right (loc', v) -> Right (loc', L loc v) ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] @@ -265,7 +271,7 @@ <+> text "are not allowed:") $$ (Outputable.ppr adts')) ; returnJustL $ TyClD noExtField $ - ClassDecl { tcdCExt = noExtField + ClassDecl { tcdCExt = NoLayoutInfo , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' @@ -279,14 +285,14 @@ ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' + ; (L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts' - , cid_overlap_mode = fmap (cL loc . overlap) o } } + , cid_overlap_mode = fmap (L loc . overlap) o } } where overlap pragma = case pragma of @@ -350,7 +356,7 @@ , feqn_fixity = Prefix } }}} cvtDec (TySynInstD eqn) - = do { (dL->L _ eqn') <- cvtTySynEqn eqn + = do { (L _ eqn') <- cvtTySynEqn eqn ; returnJustL $ InstD noExtField $ TyFamInstD { tfid_ext = noExtField , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } @@ -376,8 +382,8 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext funPrec cxt ; ds' <- traverse cvtDerivStrategy ds - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty' + ; (L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' ; returnJustL $ DerivD noExtField $ DerivDecl { deriv_ext =noExtField , deriv_strategy = ds' @@ -474,7 +480,7 @@ ; return (listToBag binds', sigs', fams', ats', adts') } ---------------- -cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] -> CvtM ( LHsContext GhcPs , Located RdrName , LHsQTyVars GhcPs) @@ -482,13 +488,13 @@ = do { cxt' <- cvtContext funPrec cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') + ; return (cxt', tc', mkHsQTvs tvs') } -cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type +cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type -> CvtM ( LHsContext GhcPs , Located RdrName - , Maybe [LHsTyVarBndr GhcPs] + , Maybe [LHsTyVarBndr () GhcPs] , HsTyPats GhcPs) cvt_datainst_hdr cxt bndrs tys = do { cxt' <- cvtContext funPrec cxt @@ -523,29 +529,29 @@ ------------------------------------------------------------------- is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) -is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d) +is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d) is_fam_decl decl = Right decl is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) -is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) - = Left (cL loc d) +is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) + = Left (L loc d) is_tyfam_inst decl = Right decl is_datafam_inst :: LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) -is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) - = Left (cL loc d) +is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) + = Left (L loc d) is_datafam_inst decl = Right decl is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) -is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig) -is_sig decl = Right decl +is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig) +is_sig decl = Right decl is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) -is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind) -is_bind decl = Right decl +is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind) +is_bind decl = Right decl is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) @@ -565,7 +571,7 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; tys' <- mapM cvt_arg strtys - ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') } + ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon (map hsLinear tys')) } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c @@ -577,33 +583,34 @@ = do { c' <- cNameL c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') } + ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon (hsLinear st1') + (hsLinear st2')) } cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L _ con') <- cvtConstr con + ; L _ con' <- cvtConstr con ; returnL $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = Just lcxt - add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2)) - = Just (cL loc (cxt1 ++ cxt2)) + add_cxt (L loc cxt1) (Just (L _ cxt2)) + = Just (L loc (cxt1 ++ cxt2)) + add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs + -> ConDecl GhcPs -> ConDecl GhcPs add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) - , con_qvars = mkHsQTvs all_tvs + , con_qvars = all_tvs , con_mb_cxt = add_cxt cxt' cxt } where - all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars + all_tvs = tvs' ++ qvars add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) , con_ex_tvs = all_tvs , con_mb_cxt = add_cxt cxt' cxt } where - all_tvs = hsQTvExplicit tvs' ++ ex_tvs - - add_forall _ _ (XConDecl nec) = noExtCon nec + all_tvs = tvs' ++ ex_tvs cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name") @@ -611,9 +618,8 @@ cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys - ; (dL->L _ ty') <- cvtType ty - ; c_ty <- mk_arr_apps args ty' - ; returnL $ fst $ mkGadtDecl c' c_ty} + ; ty' <- cvtType ty + ; returnL $ mk_gadt_decl c' (PrefixCon $ map hsLinear args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name") @@ -622,10 +628,20 @@ = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; let rec_ty = noLoc (HsFunTy noExtField - (noLoc $ HsRecTy noExtField rec_flds) ty') - ; returnL $ fst $ mkGadtDecl c' rec_ty } + ; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' } +mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs + -> ConDecl GhcPs +mk_gadt_decl names args res_ty + = ConDeclGADT { con_g_ext = noExtField + , con_names = names + , con_forall = noLoc False + , con_qvars = [] + , con_mb_cxt = Nothing + , con_args = args + , con_res_ty = res_ty + , con_doc = Nothing } + cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack @@ -646,12 +662,12 @@ cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) - = do { (dL->L li i') <- vNameL i + = do { L li i' <- vNameL i ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_ext = noExtField , cd_fld_names - = [cL li $ FieldOcc noExtField (cL li i')] + = [L li $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -672,7 +688,7 @@ cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) cvtForD (ImportF callconv safety from nm ty) -- the prim and javascript calling conventions do not support headers - -- and are inserted verbatim, analogous to mkImport in RdrHsSyn + -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess | callconv == TH.Prim || callconv == TH.JavaScript = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing (CFunction (StaticTarget (SourceText from) @@ -762,7 +778,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm ; let act = cvtPhases phases AlwaysActive - ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs + ; ty_bndrs' <- traverse cvtTvs ty_bndrs ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs @@ -829,7 +845,7 @@ cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameL n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' } + ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkHsPatSigType ty' } --------------------------------------------------- -- Declarations @@ -851,7 +867,7 @@ ((_:_), (_:_)) -> failWith (text "Implicit parameters mixed with other bindings") -cvtClause :: HsMatchContext RdrName +cvtClause :: HsMatchContext GhcPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps @@ -922,7 +938,7 @@ ; return $ ExplicitSum noExtField alt arity e'} cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' } + ; return $ mkHsIf x' y' z' } cvt (MultiIfE alts) | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts @@ -933,8 +949,8 @@ ; th_origin <- getOrigin ; return $ HsCase noExtField e' (mkMatchGroup th_origin ms') } - cvt (DoE ss) = cvtHsDo DoExpr ss - cvt (MDoE ss) = cvtHsDo MDoExpr ss + cvt (DoE m ss) = cvtHsDo (DoExpr (mk_mod <$> m)) ss + cvt (MDoE m ss) = cvtHsDo (MDoExpr (mk_mod <$> m)) ss cvt (CompE ss) = cvtHsDo ListComp ss cvt (ArithSeqE dd) = do { dd' <- cvtDD dd ; return $ ArithSeq noExtField Nothing dd' } @@ -1059,7 +1075,7 @@ (map noLoc es') boxity } -{- Note [Operator assocation] +{- Note [Operator association] We must be quite careful about adding parens: * Infix (UInfix ...) op arg Needs parens round the first arg * Infix (Infix ...) op arg Needs parens round the first arg @@ -1075,7 +1091,7 @@ UInfixE x * (UInfixE y + z) ---> (x * y) + z This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and -@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely +@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be completely right-biased for types and left-biased for everything else. So we left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. @@ -1124,7 +1140,7 @@ -- Do notation and statements ------------------------------------- -cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs) +cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs) cvtHsDo do_or_lc stmts | null stmts = failWith (text "Empty stmt list in do-block") | otherwise @@ -1132,8 +1148,8 @@ ; let Just (stmts'', last') = snocView stmts' ; last'' <- case last' of - (dL->L loc (BodyStmt _ body _ _)) - -> return (cL loc (mkLastStmt body)) + (L loc (BodyStmt _ body _ _)) + -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } @@ -1147,7 +1163,7 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } -cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } +cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkPsBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds ; returnL $ LetStmt noExtField (noLoc ds') } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss @@ -1157,13 +1173,13 @@ ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') } -cvtMatch :: HsMatchContext RdrName +cvtMatch :: HsMatchContext GhcPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of - (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875 - _ -> p' + (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875 + _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } @@ -1227,8 +1243,7 @@ cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' ; return $ HsString (quotedSourceText s) s' } -cvtLit (StringPrimL s) = do { let { s' = BS.pack s } - ; force s' +cvtLit (StringPrimL s) = do { let { !s' = BS.pack s } ; return $ HsStringPrim NoSourceText s' } cvtLit (BytesPrimL (Bytes fptr off sz)) = do let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr -> @@ -1238,7 +1253,7 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal" -- cvtLit should not be called on IntegerL, RationalL -- That precondition is established right here in - -- Convert.hs, hence panic + -- "GHC.ThToHs", hence panic quotedSourceText :: String -> SourceText quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" @@ -1268,12 +1283,22 @@ ; return $ SumPat noExtField p' alt arity } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; let pps = map (parenthesizePat appPrec) ps' - ; return $ ConPatIn s' (PrefixCon pps) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = s' + , pat_args = PrefixCon pps + } + } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 ; wrapParL (ParPat noExtField) $ - ConPatIn s' $ - InfixCon (parenthesizePat opPrec p1') - (parenthesizePat opPrec p2') } + ConPat + { pat_con_ext = NoExtField + , pat_con = s' + , pat_args = InfixCon + (parenthesizePat opPrec p1') + (parenthesizePat opPrec p2') + } + } -- See Note [Operator association] cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] cvtp (ParensP p) = do { p' <- cvtPat p; @@ -1286,22 +1311,26 @@ ; return $ AsPat noExtField s' p' } cvtp TH.WildP = return $ WildPat noExtField cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' - $ Hs.RecCon (HsRecFields fs' Nothing) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = c' + , pat_args = Hs.RecCon $ HsRecFields fs' Nothing + } + } cvtp (ListP ps) = do { ps' <- cvtPats ps ; return $ ListPat noExtField ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat noExtField p' (mkLHsSigWcType t') } + ; return $ SigPat noExtField p' (mkHsPatSigType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noExtField e' p'} cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) - = do { (dL->L ls s') <- vNameL s + = do { L ls s' <- vNameL s ; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl - = cL ls $ mkFieldOcc (cL ls s') + = L ls $ mkFieldOcc (L ls s') , hsRecFieldArg = p' , hsRecPun = False}) } @@ -1317,22 +1346,39 @@ cvtOpAppP x op y = do { op' <- cNameL op ; y' <- cvtPat y - ; return (ConPatIn op' (InfixCon x y')) } + ; return $ ConPat + { pat_con_ext = noExtField + , pat_con = op' + , pat_args = InfixCon x y' + } + } ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) -cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } +class CvtFlag flag flag' | flag -> flag' where + cvtFlag :: flag -> flag' -cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) -cvt_tv (TH.PlainTV nm) +instance CvtFlag () () where + cvtFlag () = () + +instance CvtFlag TH.Specificity Hs.Specificity where + cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec + cvtFlag TH.InferredSpec = Hs.InferredSpec + +cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs] +cvtTvs tvs = mapM cvt_tv tvs + +cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs) +cvt_tv (TH.PlainTV nm fl) = do { nm' <- tNameL nm - ; returnL $ UserTyVar noExtField nm' } -cvt_tv (TH.KindedTV nm ki) + ; let fl' = cvtFlag fl + ; returnL $ UserTyVar noExtField fl' nm' } +cvt_tv (TH.KindedTV nm fl ki) = do { nm' <- tNameL nm + ; let fl' = cvtFlag fl ; ki' <- cvtKind ki - ; returnL $ KindedTyVar noExtField nm' ki' } + ; returnL $ KindedTyVar noExtField fl' nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1412,9 +1458,25 @@ _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' - returnL (HsFunTy noExtField x'' y'') + returnL (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x'' y'') | otherwise -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon))) + tys' + MulArrowT + | Just normals <- m_normals + , [w',x',y'] <- normals -> do + x'' <- case unLoc x' of + HsFunTy{} -> returnL (HsParTy noExtField x') + HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646 + HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 + _ -> return $ + parenthesizeHsType sigPrec x' + let y'' = parenthesizeHsType sigPrec y' + w'' = hsTypeToArrow w' + returnL (HsFunTy noExtField w'' x'' y'') + | otherwise + -> mk_apps (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) tys' ListT @@ -1438,7 +1500,8 @@ ; cxt' <- cvtContext funPrec cxt ; ty' <- cvtType ty ; loc <- getL - ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty + ; let tele = mkHsForAllInvisTele tvs' + hs_ty = mkHsForAllTy loc tele rho_ty rho_ty = mkHsQualTy cxt loc cxt' ty' ; return hs_ty } @@ -1448,7 +1511,8 @@ -> do { tvs' <- cvtTvs tvs ; ty' <- cvtType ty ; loc <- getL - ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' } + ; let tele = mkHsForAllVisTele tvs' + ; pure $ mkHsForAllTy loc tele ty' } SigT ty ki -> do { ty' <- cvtType ty @@ -1503,7 +1567,7 @@ PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax | Just normals <- m_normals - , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals + , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals -> do returnL (HsExplicitListTy noExtField ip (ty1:tys2)) | otherwise @@ -1543,6 +1607,13 @@ _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } +hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs +hsTypeToArrow w = case unLoc w of + HsTyVar _ _ (L _ (isExact_maybe -> Just n)) + | n == oneDataConName -> HsLinearArrow NormalSyntax + | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax + _ -> HsExplicitMult NormalSyntax w + -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only -- contain data constructor names. See #15572/#17394. We use this function to @@ -1576,7 +1647,7 @@ go type_args where -- See Note [Adding parens for splices] - add_parens lt@(dL->L _ t) + add_parens lt@(L _ t) | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) | otherwise = return lt @@ -1592,8 +1663,9 @@ parens, as written in the source. When a Template Haskell (TH) splice is evaluated, the original splice is first -renamed and type checked and then finally converted to core in DsMeta. This core -is then run in the TH engine, and the result comes back as a TH AST. +renamed and type checked and then finally converted to core in +GHC.HsToCore.Quote. This core is then run in the TH engine, and the result +comes back as a TH AST. In the process, all parens are stripped out, as they are not needed. @@ -1602,19 +1674,12 @@ In order to pretty-print this hsSyn AST, parens need to be adde back at certain points so that the code is readable with its original meaning. -So scattered through Convert.hs are various points where parens are added. +So scattered through "GHC.ThToHs" are various points where parens are added. See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289 -} -- --------------------------------------------------------------------- --- | Constructs an arrow type with a specified return type -mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) -mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL - where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) - go arg ret_ty = do { ret_ty_l <- returnL ret_ty - ; return (HsFunTy noExtField arg ret_ty_l) } - split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) split_ty_app ty = go ty [] where @@ -1680,21 +1745,20 @@ | null exis, null provs = cvtType (ForallT univs reqs ty) | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty) - ; return $ cL l (HsQualTy { hst_ctxt = cL l [] - , hst_xqual = noExtField - , hst_body = ty' }) } + ; return $ L l (HsQualTy { hst_ctxt = L l [] + , hst_xqual = noExtField + , hst_body = ty' }) } | null reqs = do { l <- getL - ; univs' <- hsQTvExplicit <$> cvtTvs univs + ; univs' <- cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) ; let forTy = HsForAllTy - { hst_fvf = ForallInvis - , hst_bndrs = univs' + { hst_tele = mkHsForAllInvisTele univs' , hst_xforall = noExtField - , hst_body = cL l cxtTy } - cxtTy = HsQualTy { hst_ctxt = cL l [] + , hst_body = L l cxtTy } + cxtTy = HsQualTy { hst_ctxt = L l [] , hst_xqual = noExtField , hst_body = ty' } - ; return $ cL l forTy } + ; return $ L l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty = cvtType ty @@ -1734,29 +1798,27 @@ | otherwise = return () --- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the +-- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' -- using the provided 'LHsQTyVars' and 'LHsType'. -mkHsForAllTy :: [TH.TyVarBndr] - -- ^ The original Template Haskell type variable binders - -> SrcSpan +mkHsForAllTy :: SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall - -> ForallVisFlag - -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@) - -- or invisible (e.g., @forall a.@) - -> LHsQTyVars GhcPs + -> HsForAllTelescope GhcPs -- ^ The converted type variable binders -> LHsType GhcPs -- ^ The converted rho type -> LHsType GhcPs -- ^ The complete type, quantified with a forall if necessary -mkHsForAllTy tvs loc fvf tvs' rho_ty - | null tvs = rho_ty - | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf - , hst_bndrs = hsQTvExplicit tvs' - , hst_xforall = noExtField - , hst_body = rho_ty } +mkHsForAllTy loc tele rho_ty + | no_tvs = rho_ty + | otherwise = L loc $ HsForAllTy { hst_tele = tele + , hst_xforall = noExtField + , hst_body = rho_ty } + where + no_tvs = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> null bndrs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> null bndrs -- | If passed an empty 'TH.Cxt', this simply returns the third argument -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided @@ -1778,9 +1840,9 @@ -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty - | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField - , hst_ctxt = ctxt' - , hst_body = ty } + | otherwise = L loc $ HsQualTy { hst_xqual = noExtField + , hst_ctxt = ctxt' + , hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName @@ -1909,8 +1971,8 @@ mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) -mk_pkg :: TH.PkgName -> UnitId -mk_pkg pkg = stringToUnitId (TH.pkgString pkg) +mk_pkg :: TH.PkgName -> Unit +mk_pkg pkg = stringToUnit (TH.pkgString pkg) mk_uniq :: Int -> Unique mk_uniq u = mkUniqueGrimily u @@ -1967,7 +2029,7 @@ the way System Names are printed. There's a small complication of course; see Note [Looking up Exact -RdrNames] in RnEnv. +RdrNames] in GHC.Rename.Env. -} {- @@ -1994,17 +2056,17 @@ Due to the two forall quantifiers and constraint contexts (either of which might be empty), pattern synonym type signatures are treated -specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and -`typecheck/TcSplice.hs`: +specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and +`GHC.Tc.Gen.Splice`: (a) When desugaring a pattern synonym from HsSyn to TH.Dec in - `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.: + `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.: ForallT univs reqs (ForallT exis provs ty) (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) (b) When converting pattern synonyms from TH.Dec to HsSyn in - `hsSyn/Convert.hs`, we convert their TH type signatures back to an + `GHC.ThToHs`, we convert their TH type signatures back to an appropriate Haskell pattern synonym type of the form forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t @@ -2012,7 +2074,7 @@ where initial empty `univs` type variables or an empty `reqs` constraint context are represented *explicitly* as `() =>`. - (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always + (c) When reifying a pattern synonym in `GHC.Tc.Gen.Splice`, we always return its *full* type, i.e.: ForallT univs reqs (ForallT exis provs ty) diff --git a/GHC/Types/Annotations.hs b/GHC/Types/Annotations.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Annotations.hs @@ -0,0 +1,140 @@ +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +{-# LANGUAGE DeriveFunctor #-} +module GHC.Types.Annotations ( + -- * Main Annotation data types + Annotation(..), AnnPayload, + AnnTarget(..), CoreAnnTarget, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, + findAnns, findAnnsByTypeRep, + deserializeAnns + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Unit.Module ( Module ) +import GHC.Unit.Module.Env +import GHC.Types.Name.Env +import GHC.Types.Name +import GHC.Utils.Outputable +import GHC.Serialized + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Data.Word ( Word8 ) + + +-- | Represents an annotation after it has been sufficiently desugared from +-- it's initial form of 'GHC.Hs.Decls.AnnDecl' +data Annotation = Annotation { + ann_target :: CoreAnnTarget, -- ^ The target of the annotation + ann_value :: AnnPayload + } + +type AnnPayload = Serialized -- ^ The "payload" of an annotation + -- allows recovery of its value at a given type, + -- and can be persisted to an interface file + +-- | An annotation target +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: + -- a type or identifier + | ModuleTarget Module -- ^ We are annotating a particular module + deriving (Functor) + +-- | The kind of annotation target found in the middle end of the compiler +type CoreAnnTarget = AnnTarget Name + +instance Outputable name => Outputable (AnnTarget name) where + ppr (NamedTarget nm) = text "Named target" <+> ppr nm + ppr (ModuleTarget mod) = text "Module target" <+> ppr mod + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) + +-- | A collection of annotations +data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload]) + , ann_name_env :: !(NameEnv [AnnPayload]) + } + +-- | An empty annotation environment. +emptyAnnEnv :: AnnEnv +emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv + +-- | Construct a new annotation environment that contains the list of +-- annotations provided. +mkAnnEnv :: [Annotation] -> AnnEnv +mkAnnEnv = extendAnnEnvList emptyAnnEnv + +-- | Add the given annotation to the environment. +extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv +extendAnnEnvList env = + foldl' extendAnnEnv env + +extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv +extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) = + case tgt of + NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload]) + ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env + +-- | Union two annotation environments. +plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv +plusAnnEnv a b = + MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b) + , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b) + } + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns deserialize env + = mapMaybe (fromSerialized deserialize) . findAnnPayloads env + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] +findAnnsByTypeRep env target tyrep + = [ ws | Serialized tyrep' ws <- findAnnPayloads env target + , tyrep' == tyrep ] + +-- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'. +findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload] +findAnnPayloads env target = + case target of + ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod + NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name + +-- | Deserialize all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) +deserializeAnns deserialize env + = ( mapModuleEnv deserAnns (ann_mod_env env) + , mapNameEnv deserAnns (ann_name_env env) + ) + where deserAnns = mapMaybe (fromSerialized deserialize) + diff --git a/GHC/Types/Avail.hs b/GHC/Types/Avail.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Avail.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- +-- (c) The University of Glasgow +-- + +#include "HsVersions.h" + +module GHC.Types.Avail ( + Avails, + AvailInfo(..), + avail, + availsToNameSet, + availsToNameSetWithSelectors, + availsToNameEnv, + availName, availNames, availNonFldNames, + availNamesWithSelectors, + availFlds, + availsNamesWithOccs, + availNamesWithOccs, + stableAvailCmp, + plusAvail, + trimAvail, + filterAvail, + filterAvails, + nubAvails + + + ) where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set + +import GHC.Types.FieldLabel +import GHC.Utils.Binary +import GHC.Data.List.SetOps +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Data.Data ( Data ) +import Data.List ( find ) +import Data.Function + +-- ----------------------------------------------------------------------------- +-- The AvailInfo type + +-- | Records what things are \"available\", i.e. in scope +data AvailInfo + + -- | An ordinary identifier in scope + = Avail Name + + -- | A type or class in scope + -- + -- The __AvailTC Invariant__: If the type or class is itself to be in scope, + -- it must be /first/ in this list. Thus, typically: + -- + -- > AvailTC Eq [Eq, ==, \/=] [] + | AvailTC + Name -- ^ The name of the type or class + [Name] -- ^ The available pieces of type or class, + -- excluding field selectors. + [FieldLabel] -- ^ The record fields of the type + -- (see Note [Representing fields in AvailInfo]). + + deriving ( Eq -- ^ Used when deciding if the interface has changed + , Data ) + +-- | A collection of 'AvailInfo' - several things that are \"available\" +type Avails = [AvailInfo] + +{- +Note [Representing fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -XDuplicateRecordFields is disabled (the normal case), a +datatype like + + data T = MkT { foo :: Int } + +gives rise to the AvailInfo + + AvailTC T [T, MkT] [FieldLabel "foo" False foo] + +whereas if -XDuplicateRecordFields is enabled it gives + + AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] + +since the label does not match the selector name. + +The labels in a field list are not necessarily unique: +data families allow the same parent (the family tycon) to have +multiple distinct fields with the same label. For example, + + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool} + +gives rise to + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" True $sel:foo:MkFBool ] + +Moreover, note that the flIsOverloaded flag need not be the same for +all the elements of the list. In the example above, this occurs if +the two data instances are defined in different modules, one with +`-XDuplicateRecordFields` enabled and one with it disabled. Thus it +is possible to have + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" False foo ] + +If the two data instances are defined in different modules, both +without `-XDuplicateRecordFields`, it will be impossible to export +them from the same module (even with `-XDuplicateRecordfields` +enabled), because they would be represented identically. The +workaround here is to enable `-XDuplicateRecordFields` on the defining +modules. +-} + +-- | Compare lexicographically +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = + (n `stableNameCmp` m) `thenCmp` + (cmpList stableNameCmp ns ms) `thenCmp` + (cmpList (stableNameCmp `on` flSelector) nfs mfs) +stableAvailCmp (AvailTC {}) (Avail {}) = GT + +avail :: Name -> AvailInfo +avail n = Avail n + +-- ----------------------------------------------------------------------------- +-- Operations on AvailInfo + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNames avail) + +availsToNameSetWithSelectors :: [AvailInfo] -> NameSet +availsToNameSetWithSelectors avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNamesWithSelectors avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) + +-- | Just the main name made available, i.e. not the available pieces +-- of type or class brought into scope by the 'GenAvailInfo' +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _ _) = n + +-- | All names made available by the availability information (excluding overloaded selectors) +availNames :: AvailInfo -> [Name] +availNames (Avail n) = [n] +availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] + +-- | All names made available by the availability information (including overloaded selectors) +availNamesWithSelectors :: AvailInfo -> [Name] +availNamesWithSelectors (Avail n) = [n] +availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs + +-- | Names for non-fields made available by the availability information +availNonFldNames :: AvailInfo -> [Name] +availNonFldNames (Avail n) = [n] +availNonFldNames (AvailTC _ ns _) = ns + +-- | Fields made available by the availability information +availFlds :: AvailInfo -> [FieldLabel] +availFlds (AvailTC _ _ fs) = fs +availFlds _ = [] + +availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] +availsNamesWithOccs = concatMap availNamesWithOccs + +-- | 'Name's made available by the availability information, paired with +-- the 'OccName' used to refer to each one. +-- +-- When @DuplicateRecordFields@ is in use, the 'Name' may be the +-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the +-- 'OccName' will be the label of the field (e.g. @foo@). +-- +-- See Note [Representing fields in AvailInfo]. +availNamesWithOccs :: AvailInfo -> [(Name, OccName)] +availNamesWithOccs (Avail n) = [(n, nameOccName n)] +availNamesWithOccs (AvailTC _ ns fs) + = [ (n, nameOccName n) | n <- ns ] ++ + [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] + +-- ----------------------------------------------------------------------------- +-- Utility + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 +plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (fs1 `unionLists` fs2) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (fs1 `unionLists` fs2) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (fs1 `unionLists` fs2) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) + = AvailTC n1 ss1 (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) + = AvailTC n1 ss2 (fs1 `unionLists` fs2) +plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) + +-- | trims an 'AvailInfo' to keep only a single name +trimAvail :: AvailInfo -> Name -> AvailInfo +trimAvail (Avail n) _ = Avail n +trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of + Just x -> AvailTC n [] [x] + Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] + +-- | filters 'AvailInfo's by the given predicate +filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] +filterAvails keep avails = foldr (filterAvail keep) [] avails + +-- | filters an 'AvailInfo' by the given predicate +filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] +filterAvail keep ie rest = + case ie of + Avail n | keep n -> ie : rest + | otherwise -> rest + AvailTC tc ns fs -> + let ns' = filter keep ns + fs' = filter (keep . flSelector) fs in + if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest + + +-- | Combines 'AvailInfo's from the same family +-- 'avails' may have several items with the same availName +-- E.g import Ix( Ix(..), index ) +-- will give Ix(Ix,index,range) and Ix(index) +-- We want to combine these; addAvail does that +nubAvails :: [AvailInfo] -> [AvailInfo] +nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) + where + add env avail = extendNameEnv_C plusAvail env (availName avail) avail + +-- ----------------------------------------------------------------------------- +-- Printing + +instance Outputable AvailInfo where + ppr = pprAvail + +pprAvail :: AvailInfo -> SDoc +pprAvail (Avail n) + = ppr n +pprAvail (AvailTC n ns fs) + = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi + , fsep (punctuate comma (map (ppr . flLabel) fs))]) + +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac ad) = do + putByte bh 1 + put_ bh ab + put_ bh ac + put_ bh ad + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + ad <- get bh + return (AvailTC ab ac ad) diff --git a/GHC/Types/Basic.hs b/GHC/Types/Basic.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Basic.hs @@ -0,0 +1,1845 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +\section[BasicTypes]{Miscellaneous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Types.Basic ( + LeftOrRight(..), + pickLR, + + ConTag, ConTagZ, fIRST_TAG, + + Arity, RepArity, JoinArity, + + Alignment, mkAlignment, alignmentOf, alignmentBytes, + + PromotionFlag(..), isPromoted, + FunctionOrData(..), + + WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), + + Fixity(..), FixityDirection(..), + defaultFixity, maxPrecedence, minPrecedence, + negateFixity, funTyFixity, + compareFixity, + LexicalFixity(..), + + RecFlag(..), isRec, isNonRec, boolToRecFlag, + Origin(..), isGenerated, + + RuleName, pprRuleName, + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, + + Boxity(..), isBoxed, + + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, + maybeParen, + + TupleSort(..), tupleSortBoxity, boxityTupleSort, + tupleParens, + + sumParens, pprAlternative, + + -- ** The OneShotInfo type + OneShotInfo(..), + noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, + bestOneShot, worstOneShot, + + OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, + isNoOccInfo, strongLoopBreaker, weakLoopBreaker, + + InsideLam(..), + BranchCount, oneBranch, + InterestingCxt(..), + TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, + isAlwaysTailCalled, + + EP(..), + + DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, isSwapped, + + CompilerPhase(..), PhaseNum, + + Activation(..), isActive, competesWith, + isNeverActive, isAlwaysActive, activeInFinalPhase, + activateAfterInitial, activateDuringFinal, + + RuleMatchInfo(..), isConLike, isFunLike, + InlineSpec(..), noUserInlineSpec, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, + inlinePragmaSpec, inlinePragmaSat, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, + pprInline, pprInlineDebug, + + SuccessFlag(..), succeeded, failed, successIf, + + IntegralLit(..), FractionalLit(..), + negateIntegralLit, negateFractionalLit, + mkIntegralLit, mkFractionalLit, + integralFractionalLit, + + SourceText(..), pprWithSourceText, + + IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, + + SpliceExplicitFlag(..), + + TypeOrKind(..), isTypeLevel, isKindLevel + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.SrcLoc ( Located,unLoc ) +import Data.Data hiding (Fixity, Prefix, Infix) +import Data.Function (on) +import Data.Bits +import qualified Data.Semigroup as Semi + +{- +************************************************************************ +* * + Binary choice +* * +************************************************************************ +-} + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +instance Outputable LeftOrRight where + ppr CLeft = text "Left" + ppr CRight = text "Right" + +{- +************************************************************************ +* * +\subsection[Arity]{Arity} +* * +************************************************************************ +-} + +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 +-- See also Note [Definition of arity] in "GHC.Core.Opt.Arity" +type Arity = Int + +-- | Representation Arity +-- +-- The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int + +-- | The number of arguments that a join point takes. Unlike the arity of a +-- function, this is a purely syntactic property and is fixed when the join +-- point is created (or converted from a value). Both type and value arguments +-- are counted. +type JoinArity = Int + +{- +************************************************************************ +* * + Constructor tags +* * +************************************************************************ +-} + +-- | Constructor Tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + +-- | A *zero-indexed* constructor tag +type ConTagZ = Int + +fIRST_TAG :: ConTag +-- ^ Tags are allocated from here for real constructors +-- or for superclass selectors +fIRST_TAG = 1 + +{- +************************************************************************ +* * +\subsection[Alignment]{Alignment} +* * +************************************************************************ +-} + +-- | A power-of-two alignment +newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) + +-- Builds an alignment, throws on non power of 2 input. This is not +-- ideal, but convenient for internal use and better then silently +-- passing incorrect data. +mkAlignment :: Int -> Alignment +mkAlignment n + | n == 1 = Alignment 1 + | n == 2 = Alignment 2 + | n == 4 = Alignment 4 + | n == 8 = Alignment 8 + | n == 16 = Alignment 16 + | n == 32 = Alignment 32 + | n == 64 = Alignment 64 + | n == 128 = Alignment 128 + | n == 256 = Alignment 256 + | n == 512 = Alignment 512 + | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" + +-- Calculates an alignment of a number. x is aligned at N bytes means +-- the remainder from x / N is zero. Currently, interested in N <= 8, +-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX +-- context. +alignmentOf :: Int -> Alignment +alignmentOf x = case x .&. 7 of + 0 -> Alignment 8 + 4 -> Alignment 4 + 2 -> Alignment 2 + _ -> Alignment 1 + +instance Outputable Alignment where + ppr (Alignment m) = ppr m +{- +************************************************************************ +* * + One-shot information +* * +************************************************************************ +-} + +{- +Note [OneShotInfo overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lambda-bound Ids (and only lambda-bound Ids) may be decorated with +one-shot info. The idea is that if we see + (\x{one-shot}. e) +it means that this lambda will only be applied once. In particular +that means we can float redexes under the lambda without losing +work. For example, consider + let t = expensive in + (\x{one-shot}. case t of { True -> ...; False -> ... }) + +Because it's a one-shot lambda, we can safely inline t, giving + (\x{one_shot}. case of + { True -> ...; False -> ... }) + +Moving parts: + +* Usage analysis, performed as part of demand-analysis, finds + out whether functions call their argument once. Consider + f g x = Just (case g x of { ... }) + + Here 'f' is lazy in 'g', but it guarantees to call it no + more than once. So g will get a C1(U) usage demand. + +* Occurrence analysis propagates this usage information + (in the demand signature of a function) to its calls. + Example, given 'f' above + f (\x.e) blah + + Since f's demand signature says it has a C1(U) usage demand on its + first argument, the occurrence analyser sets the \x to be one-shot. + This is done via the occ_one_shots field of OccEnv. + +* Float-in and float-out take account of one-shot-ness + +* Occurrence analysis doesn't set "inside-lam" for occurrences inside + a one-shot lambda + +Other notes + +* A one-shot lambda can use its argument many times. To elaborate + the example above + let t = expensive in + (\x{one-shot}. case t of { True -> x+x; False -> x*x }) + + Here the '\x' is one-shot, which justifies inlining 't', + but x is used many times. That's absolutely fine. + +* It's entirely possible to have + (\x{one-shot}. \y{many-shot}. e) + + For example + let t = expensive + g = \x -> let v = x+t in + \y -> x + v + in map (g 5) xs + + Here the `\x` is a one-shot binder: `g` is applied to one argument + exactly once. And because the `\x` is one-shot, it would be fine to + float that `let t = expensive` binding inside the `\x`. + + But the `\y` is most definitely not one-shot! +-} + +-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound +-- variable info. Sometimes we know whether the lambda binding this variable +-- is a "one-shot" lambda; that is, whether it is applied at most once. +-- +-- This information may be useful in optimisation, as computations may +-- safely be floated inside such a lambda without risk of duplicating +-- work. +-- +-- See also Note [OneShotInfo overview] above. +data OneShotInfo + = NoOneShotInfo -- ^ No information + | OneShotLam -- ^ The lambda is applied at most once. + deriving (Eq) + +-- | It is always safe to assume that an 'Id' has no lambda-bound variable information +noOneShotInfo :: OneShotInfo +noOneShotInfo = NoOneShotInfo + +isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool +isOneShotInfo OneShotLam = True +isOneShotInfo _ = False + +hasNoOneShotInfo NoOneShotInfo = True +hasNoOneShotInfo _ = False + +worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo +worstOneShot NoOneShotInfo _ = NoOneShotInfo +worstOneShot OneShotLam os = os + +bestOneShot NoOneShotInfo os = os +bestOneShot OneShotLam _ = OneShotLam + +pprOneShotInfo :: OneShotInfo -> SDoc +pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo OneShotLam = text "OneShot" + +instance Outputable OneShotInfo where + ppr = pprOneShotInfo + +{- +************************************************************************ +* * + Swap flag +* * +************************************************************************ +-} + +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + +instance Outputable SwapFlag where + ppr IsSwapped = text "Is-swapped" + ppr NotSwapped = text "Not-swapped" + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +isSwapped :: SwapFlag -> Bool +isSwapped IsSwapped = True +isSwapped NotSwapped = False + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a + + +{- ********************************************************************* +* * + Promotion flag +* * +********************************************************************* -} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False + +instance Outputable PromotionFlag where + ppr NotPromoted = text "NotPromoted" + ppr IsPromoted = text "IsPromoted" + +{- +************************************************************************ +* * +\subsection[FunctionOrData]{FunctionOrData} +* * +************************************************************************ +-} + +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord, Data) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" + +{- +************************************************************************ +* * + Deprecations +* * +************************************************************************ +-} + +-- | A String Literal in the source, including its original raw format for use by +-- source to source manipulation tools. +data StringLiteral = StringLiteral + { sl_st :: SourceText, -- literal raw source. + -- See not [Literal source text] + sl_fs :: FastString -- literal string value + } deriving Data + +instance Eq StringLiteral where + (StringLiteral _ a) == (StringLiteral _ b) = a == b + +instance Outputable StringLiteral where + ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) + +-- | Warning Text +-- +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt = WarningTxt (Located SourceText) + [Located StringLiteral] + | DeprecatedTxt (Located SourceText) + [Located StringLiteral] + deriving (Eq, Data) + +instance Outputable WarningTxt where + ppr (WarningTxt lsrc ws) + = case unLoc lsrc of + NoSourceText -> pp_ws ws + SourceText src -> text src <+> pp_ws ws <+> text "#-}" + + ppr (DeprecatedTxt lsrc ds) + = case unLoc lsrc of + NoSourceText -> pp_ws ds + SourceText src -> text src <+> pp_ws ds <+> text "#-}" + +pp_ws :: [Located StringLiteral] -> SDoc +pp_ws [l] = ppr $ unLoc l +pp_ws ws + = text "[" + <+> vcat (punctuate comma (map (ppr . unLoc) ws)) + <+> text "]" + + +pprWarningTxtForMsg :: WarningTxt -> SDoc +pprWarningTxtForMsg (WarningTxt _ ws) + = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) +pprWarningTxtForMsg (DeprecatedTxt _ ds) + = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ +-} + +type RuleName = FastString + +pprRuleName :: RuleName -> SDoc +pprRuleName rn = doubleQuotes (ftext rn) + +{- +************************************************************************ +* * +\subsection[Fixity]{Fixity info} +* * +************************************************************************ +-} + +------------------------ +data Fixity = Fixity SourceText Int FixityDirection + -- Note [Pragma source text] + deriving Data + +instance Outputable Fixity where + ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] + +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 + +------------------------ +data FixityDirection = InfixL | InfixR | InfixN + deriving (Eq, Data) + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +------------------------ +maxPrecedence, minPrecedence :: Int +maxPrecedence = 9 +minPrecedence = 0 + +defaultFixity :: Fixity +defaultFixity = Fixity NoSourceText maxPrecedence InfixL + +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 + +{- +Consider + +\begin{verbatim} + a `op1` b `op2` c +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange application, or +whether there's an error. +-} + +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) + +-- |Captures the fixity of declarations as they are parsed. This is not +-- necessarily the same as the fixity declaration, as the normal fixity may be +-- overridden using parens or backticks. +data LexicalFixity = Prefix | Infix deriving (Data,Eq) + +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +{- +************************************************************************ +* * +\subsection[Top-level/local]{Top-level/not-top level flag} +* * +************************************************************************ +-} + +data TopLevelFlag + = TopLevel + | NotTopLevel + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = text "" + ppr NotTopLevel = text "" + +{- +************************************************************************ +* * + Boxity flag +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +instance Outputable Boxity where + ppr Boxed = text "Boxed" + ppr Unboxed = text "Unboxed" + +{- +************************************************************************ +* * + Recursive/Non-Recursive flag +* * +************************************************************************ +-} + +-- | Recursivity Flag +data RecFlag = Recursive + | NonRecursive + deriving( Eq, Data ) + +isRec :: RecFlag -> Bool +isRec Recursive = True +isRec NonRecursive = False + +isNonRec :: RecFlag -> Bool +isNonRec Recursive = False +isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = text "Recursive" + ppr NonRecursive = text "NonRecursive" + +{- +************************************************************************ +* * + Code origin +* * +************************************************************************ +-} + +data Origin = FromSource + | Generated + deriving( Eq, Data ) + +isGenerated :: Origin -> Bool +isGenerated Generated = True +isGenerated FromSource = False + +instance Outputable Origin where + ppr FromSource = text "FromSource" + ppr Generated = text "Generated" + +{- +************************************************************************ +* * + Instance overlap flag +* * +************************************************************************ +-} + +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] (in "GHC.Core.InstEnv") for a +-- explanation of the `isSafeOverlap` field. +-- +-- - 'GHC.Parser.Annotation.AnnKeywordId' : +-- 'GHC.Parser.Annotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or +-- @'\{-\# OVERLAPPING'@ or +-- @'\{-\# OVERLAPS'@ or +-- @'\{-\# INCOHERENT'@, +-- 'GHC.Parser.Annotation.AnnClose' @`\#-\}`@, + +-- For details on above see note [Api annotations] in "GHC.Parser.Annotation" +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasIncoherentFlag :: OverlapMode -> Bool +hasIncoherentFlag mode = + case mode of + Incoherent _ -> True + _ -> False + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap SourceText + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps SourceText + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent SourceText + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also note [Incoherent instances] in "GHC.Core.InstEnv" + + deriving (Eq, Data) + + +instance Outputable OverlapFlag where + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance Outputable OverlapMode where + ppr (NoOverlap _) = empty + ppr (Overlappable _) = text "[overlappable]" + ppr (Overlapping _) = text "[overlapping]" + ppr (Overlaps _) = text "[overlap ok]" + ppr (Incoherent _) = text "[incoherent]" + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = text "[safe]" +pprSafeOverlap False = empty + +{- +************************************************************************ +* * + Precedence +* * +************************************************************************ +-} + +-- | A general-purpose pretty-printing precedence type. +newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) +-- See Note [Precedence in types] + +topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator +starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) + -- See Note [Star kind precedence] +appPrec = PprPrec 4 -- Constructor args; no parens for atomic + +maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +{- Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many pretty-printing functions have type + ppr_ty :: PprPrec -> Type -> SDoc + +The PprPrec gives the binding strength of the context. For example, in + T ty1 ty2 +we will pretty-print 'ty1' and 'ty2' with the call + (ppr_ty appPrec ty) +to indicate that the context is that of an argument of a TyConApp. + +We use this consistently for Type and HsType. + +Note [Type operator precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the +pretty printer follows the following precedence order: + + TyConPrec Type constructor application + TyOpPrec/FunPrec Operator application and function arrow + +We have funPrec and opPrec to represent the precedence of function +arrow and type operators respectively, but currently we implement +funPrec == opPrec, so that we don't distinguish the two. Reason: +it's hard to parse a type like + a ~ b => c * d -> e - f + +By treating opPrec = funPrec we end up with more parens + (a ~ b) => (c * d) -> (e - f) + +But the two are different constructors of PprPrec so we could make +(->) bind more or less tightly if we wanted. + +Note [Star kind precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We parenthesize the (*) kind to avoid two issues: + +1. Printing invalid or incorrect code. + For example, instead of type F @(*) x = x + GHC used to print type F @* x = x + However, (@*) is a type operator, not a kind application. + +2. Printing kinds that are correct but hard to read. + Should Either * Int be read as Either (*) Int + or as (*) Either Int ? + This depends on whether -XStarIsType is enabled, but it would be + easier if we didn't have to check for the flag when reading the code. + +At the same time, we cannot parenthesize (*) blindly. +Consider this Haskell98 kind: ((* -> *) -> *) -> * +With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*) + +The solution is to assign a special precedence to (*), 'starPrec', which is +higher than 'funPrec' but lower than 'appPrec': + + F * * * becomes F (*) (*) (*) + F A * B becomes F A (*) B + Proxy * becomes Proxy (*) + a * -> * becomes a (*) -> * +-} + +{- +************************************************************************ +* * + Tuples +* * +************************************************************************ +-} + +data TupleSort + = BoxedTuple + | UnboxedTuple + | ConstraintTuple + deriving( Eq, Data ) + +instance Outputable TupleSort where + ppr ts = text $ + case ts of + BoxedTuple -> "BoxedTuple" + UnboxedTuple -> "UnboxedTuple" + ConstraintTuple -> "ConstraintTuple" + +tupleSortBoxity :: TupleSort -> Boxity +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity ConstraintTuple = Boxed + +boxityTupleSort :: Boxity -> TupleSort +boxityTupleSort Boxed = BoxedTuple +boxityTupleSort Unboxed = UnboxedTuple + +tupleParens :: TupleSort -> SDoc -> SDoc +tupleParens BoxedTuple p = parens p +tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") +tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) + = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) + (parens p) + +{- +************************************************************************ +* * + Sums +* * +************************************************************************ +-} + +sumParens :: SDoc -> SDoc +sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") + +-- | Pretty print an alternative in an unboxed sum e.g. "| a | |". +pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use + -> a -- ^ The things to be pretty printed + -> ConTag -- ^ Alternative (one-based) + -> Arity -- ^ Arity + -> SDoc -- ^ 'SDoc' where the alternative havs been pretty + -- printed and finally packed into a paragraph. +pprAlternative pp x alt arity = + fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) + +{- +************************************************************************ +* * +\subsection[Generic]{Generic flag} +* * +************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +two pieces of code (normally either RenamedExpr's or Id's) +If we have a such a pair (EP from to), the idea is that 'from' and 'to' +represents functions of type + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. +-} + +-- | Embedding Projection pair +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T + +{- +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + + +************************************************************************ +* * +\subsection{Occurrence information} +* * +************************************************************************ + +This data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty +near the base of the module hierarchy. So it seemed simpler to put the defn of +OccInfo here, safely at the bottom +-} + +-- | identifier Occurrence Information +data OccInfo + = ManyOccs { occ_tail :: !TailCallInfo } + -- ^ There are many occurrences, or unknown occurrences + + | IAmDead -- ^ Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc { occ_in_lam :: !InsideLam + , occ_n_br :: {-# UNPACK #-} !BranchCount + , occ_int_cxt :: !InterestingCxt + , occ_tail :: !TailCallInfo } + -- ^ Occurs exactly once (per branch), not inside a rule + + -- | This identifier breaks a loop of mutually recursive functions. The field + -- marks whether it is only a loop breaker due to a reference in a rule + | IAmALoopBreaker { occ_rules_only :: !RulesOnly + , occ_tail :: !TailCallInfo } + -- Note [LoopBreaker OccInfo] + deriving (Eq) + +type RulesOnly = Bool + +type BranchCount = Int + -- For OneOcc, the BranchCount says how many syntactic occurrences there are + -- At the moment we really only check for 1 or >1, but in principle + -- we could pay attention to how *many* occurences there are + -- (notably in postInlineUnconditionally). + -- But meanwhile, Ints are very efficiently represented. + +oneBranch :: BranchCount +oneBranch = 1 + +{- +Note [LoopBreaker OccInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all + +See OccurAnal Note [Weak loop breakers] +-} + +noOccInfo :: OccInfo +noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } + +isNoOccInfo :: OccInfo -> Bool +isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo } = True +isNoOccInfo _ = False + +isManyOccs :: OccInfo -> Bool +isManyOccs ManyOccs{} = True +isManyOccs _ = False + +seqOccInfo :: OccInfo -> () +seqOccInfo occ = occ `seq` () + +----------------- +-- | Interesting Context +data InterestingCxt + = IsInteresting + -- ^ Function: is applied + -- Data value: scrutinised by a case with at least one non-DEFAULT branch + | NotInteresting + deriving (Eq) + +-- | If there is any 'interesting' identifier occurrence, then the +-- aggregated occurrence info of that identifier is considered interesting. +instance Semi.Semigroup InterestingCxt where + NotInteresting <> x = x + IsInteresting <> _ = IsInteresting + +instance Monoid InterestingCxt where + mempty = NotInteresting + mappend = (Semi.<>) + +----------------- +-- | Inside Lambda +data InsideLam + = IsInsideLam + -- ^ Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. + | NotInsideLam + deriving (Eq) + +-- | If any occurrence of an identifier is inside a lambda, then the +-- occurrence info of that identifier marks it as occurring inside a lambda +instance Semi.Semigroup InsideLam where + NotInsideLam <> x = x + IsInsideLam <> _ = IsInsideLam + +instance Monoid InsideLam where + mempty = NotInsideLam + mappend = (Semi.<>) + +----------------- +data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] + | NoTailCallInfo + deriving (Eq) + +tailCallInfo :: OccInfo -> TailCallInfo +tailCallInfo IAmDead = NoTailCallInfo +tailCallInfo other = occ_tail other + +zapOccTailCallInfo :: OccInfo -> OccInfo +zapOccTailCallInfo IAmDead = IAmDead +zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } + +isAlwaysTailCalled :: OccInfo -> Bool +isAlwaysTailCalled occ + = case tailCallInfo occ of AlwaysTailCalled{} -> True + NoTailCallInfo -> False + +instance Outputable TailCallInfo where + ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] + ppr _ = empty + +----------------- +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo +weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo + +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker{}) = True +isWeakLoopBreaker _ = False + +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True + -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False + +isDeadOcc :: OccInfo -> Bool +isDeadOcc IAmDead = True +isDeadOcc _ = False + +isOneOcc :: OccInfo -> Bool +isOneOcc (OneOcc {}) = True +isOneOcc _ = False + +zapFragileOcc :: OccInfo -> OccInfo +-- Keep only the most robust data: deadness, loop-breaker-hood +zapFragileOcc (OneOcc {}) = noOccInfo +zapFragileOcc occ = zapOccTailCallInfo occ + +instance Outputable OccInfo where + -- only used for debugging; never parsed. KSW 1999-07 + ppr (ManyOccs tails) = pprShortTailCallInfo tails + ppr IAmDead = text "Dead" + ppr (IAmALoopBreaker rule_only tails) + = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails + where + pp_ro | rule_only = char '!' + | otherwise = empty + ppr (OneOcc inside_lam one_branch int_cxt tail_info) + = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail + where + pp_lam IsInsideLam = char 'L' + pp_lam NotInsideLam = empty + pp_args IsInteresting = char '!' + pp_args NotInteresting = empty + pp_tail = pprShortTailCallInfo tail_info + +pprShortTailCallInfo :: TailCallInfo -> SDoc +pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) +pprShortTailCallInfo NoTailCallInfo = empty + +{- +Note [TailCallInfo] +~~~~~~~~~~~~~~~~~~~ +The occurrence analyser determines what can be made into a join point, but it +doesn't change the binder into a JoinId because then it would be inconsistent +with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to +change the IdDetails. + +The AlwaysTailCalled marker actually means slightly more than simply that the +function is always tail-called. See Note [Invariants on join points]. + +This info is quite fragile and should not be relied upon unless the occurrence +analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of +the join-point-hood of a binder; a join id itself will not be marked +AlwaysTailCalled. + +Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that +being tail-called would mean that the variable could only appear once per branch +(thus getting a `OneOcc { }` occurrence info), but a join +point can also be invoked from other join points, not just from case branches: + + let j1 x = ... + j2 y = ... j1 z {- tail call -} ... + in case w of + A -> j1 v + B -> j2 u + C -> j2 q + +Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get +ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`. + +************************************************************************ +* * + Default method specification +* * +************************************************************************ + +The DefMethSpec enumeration just indicates what sort of default method +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMethInfo before begin put in a +Class object. +-} + +-- | Default Method Specification +data DefMethSpec ty + = VanillaDM -- Default method given with polymorphic code + | GenericDM ty -- Default method given with code of this type + +instance Outputable (DefMethSpec ty) where + ppr VanillaDM = text "{- Has default method -}" + ppr (GenericDM {}) = text "{- Has generic default method -}" + +{- +************************************************************************ +* * +\subsection{Success flag} +* * +************************************************************************ +-} + +data SuccessFlag = Succeeded | Failed + +instance Outputable SuccessFlag where + ppr Succeeded = text "Succeeded" + ppr Failed = text "Failed" + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True + +{- +************************************************************************ +* * +\subsection{Source Text} +* * +************************************************************************ +Keeping Source Text for source to source conversions + +Note [Pragma source text] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer does a case-insensitive match for pragmas, as well as +accepting both UK and US spelling variants. + +So + + {-# SPECIALISE #-} + {-# SPECIALIZE #-} + {-# Specialize #-} + +will all generate ITspec_prag token for the start of the pragma. + +In order to be able to do source to source conversions, the original +source text for the token needs to be preserved, hence the +`SourceText` field. + +So the lexer will then generate + + ITspec_prag "{ -# SPECIALISE" + ITspec_prag "{ -# SPECIALIZE" + ITspec_prag "{ -# Specialize" + +for the cases above. + [without the space between '{' and '-', otherwise this comment won't parse] + + +Note [Literal source text] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer/parser converts literals from their original source text +versions to an appropriate internal representation. This is a problem +for tools doing source to source conversions, so the original source +text is stored in literals where this can occur. + +Motivating examples for HsLit + + HsChar '\n' == '\x20` + HsCharPrim '\x41`# == `A` + HsString "\x20\x41" == " A" + HsStringPrim "\x20"# == " "# + HsInt 001 == 1 + HsIntPrim 002# == 2# + HsWordPrim 003## == 3## + HsInt64Prim 004## == 4## + HsWord64Prim 005## == 5## + HsInteger 006 == 6 + +For OverLitVal + + HsIntegral 003 == 0x003 + HsIsString "\x41nd" == "And" +-} + + -- Note [Literal source text],[Pragma source text] +data SourceText = SourceText String + | NoSourceText -- ^ For when code is generated, e.g. TH, + -- deriving. The pretty printer will then make + -- its own representation of the item. + deriving (Data, Show, Eq ) + +instance Outputable SourceText where + ppr (SourceText s) = text "SourceText" <+> text s + ppr NoSourceText = text "NoSourceText" + +-- | Special combinator for showing string literals. +pprWithSourceText :: SourceText -> SDoc -> SDoc +pprWithSourceText NoSourceText d = d +pprWithSourceText (SourceText src) _ = text src + +{- +************************************************************************ +* * +\subsection{Activation} +* * +************************************************************************ + +When a rule or inlining is active + +Note [Compiler phases] +~~~~~~~~~~~~~~~~~~~~~~ +The CompilerPhase says which phase the simplifier is running in: + +* InitialPhase: before all user-visible phases + +* Phase 2,1,0: user-visible phases; the phase number + controls rule ordering an inlining. + +* FinalPhase: used for all subsequent simplifier + runs. By delaying inlining of wrappers to FinalPhase we can + ensure that RULE have a good chance to fire. See + Note [Wrapper activation] in GHC.Core.Opt.WorkWrap + + NB: FinalPhase is run repeatedly, not just once. + + NB: users don't have access to InitialPhase or FinalPhase. + They write {-# INLINE[n] f #-}, meaning (Phase n) + +The phase sequencing is done by GHC.Opt.Simplify.Driver +-} + +-- | Phase Number +type PhaseNum = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +data CompilerPhase + = InitialPhase -- The first phase -- number = infinity! + | Phase PhaseNum -- User-specificable phases + | FinalPhase -- The last phase -- number = -infinity! + deriving Eq + +instance Outputable CompilerPhase where + ppr (Phase n) = int n + ppr InitialPhase = text "InitialPhase" + ppr FinalPhase = text "FinalPhase" + +-- See note [Pragma source text] +data Activation + = AlwaysActive + | ActiveBefore SourceText PhaseNum -- Active only *strictly before* this phase + | ActiveAfter SourceText PhaseNum -- Active in this phase and later + | FinalActive -- Active in final phase only + | NeverActive + deriving( Eq, Data ) + -- Eq used in comparing rules in GHC.Hs.Decls + +activateAfterInitial :: Activation +-- Active in the first phase after the initial phase +-- Currently we have just phases [2,1,0,FinalPhase,FinalPhase,...] +-- Where FinalPhase means GHC's internal simplification steps +-- after all rules have run +activateAfterInitial = ActiveAfter NoSourceText 2 + +activateDuringFinal :: Activation +-- Active in the final simplification phase (which is repeated) +activateDuringFinal = FinalActive + +isActive :: CompilerPhase -> Activation -> Bool +isActive InitialPhase act = activeInInitialPhase act +isActive (Phase p) act = activeInPhase p act +isActive FinalPhase act = activeInFinalPhase act + +activeInInitialPhase :: Activation -> Bool +activeInInitialPhase AlwaysActive = True +activeInInitialPhase (ActiveBefore {}) = True +activeInInitialPhase _ = False + +activeInPhase :: PhaseNum -> Activation -> Bool +activeInPhase _ AlwaysActive = True +activeInPhase _ NeverActive = False +activeInPhase _ FinalActive = False +activeInPhase p (ActiveAfter _ n) = p <= n +activeInPhase p (ActiveBefore _ n) = p > n + +activeInFinalPhase :: Activation -> Bool +activeInFinalPhase AlwaysActive = True +activeInFinalPhase FinalActive = True +activeInFinalPhase (ActiveAfter {}) = True +activeInFinalPhase _ = False + +isNeverActive, isAlwaysActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive _ = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive _ = False + +competesWith :: Activation -> Activation -> Bool +-- See Note [Activation competition] +competesWith AlwaysActive _ = True + +competesWith NeverActive _ = False +competesWith _ NeverActive = False + +competesWith FinalActive FinalActive = True +competesWith FinalActive _ = False + +competesWith (ActiveBefore {}) AlwaysActive = True +competesWith (ActiveBefore {}) FinalActive = False +competesWith (ActiveBefore {}) (ActiveBefore {}) = True +competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b + +competesWith (ActiveAfter {}) AlwaysActive = False +competesWith (ActiveAfter {}) FinalActive = True +competesWith (ActiveAfter {}) (ActiveBefore {}) = False +competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b + +{- Note [Competing activations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes a RULE and an inlining may compete, or two RULES. +See Note [Rules and inlining/other rules] in GHC.HsToCore. + +We say that act1 "competes with" act2 iff + act1 is active in the phase when act2 *becomes* active +NB: remember that phases count *down*: 2, 1, 0! + +It's too conservative to ensure that the two are never simultaneously +active. For example, a rule might be always active, and an inlining +might switch on in phase 2. We could switch off the rule, but it does +no harm. +-} + + +{- ********************************************************************* +* * + InlinePragma, InlineSpec, RuleMatchInfo +* * +********************************************************************* -} + + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_src :: SourceText -- Note [Pragma source text] + , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] + + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the + -- number of implicit, dictionary arguments when making + -- the Unfolding, and don't look at inl_sat further + + , inl_act :: Activation -- Says during which phases inlining is allowed + -- See Note [inl_inline and inl_act] + + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq, Data ) + +-- | Rule Match Information +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] + | FunLike + deriving( Eq, Data, Show ) + -- Show needed for GHC.Parser.Lexer + +-- | Inline Specification +data InlineSpec -- What the user's INLINE pragma looked like + = Inline -- User wrote INLINE + | Inlinable -- User wrote INLINABLE + | NoInline -- User wrote NOINLINE + | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE + -- e.g. in `defaultInlinePragma` or when created by CSE + deriving( Eq, Data, Show ) + -- Show needed for GHC.Parser.Lexer + +{- Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = NoUserInline + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. + +If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair + +Note [inl_inline and inl_act] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* inl_inline says what the user wrote: did she say INLINE, NOINLINE, + INLINABLE, or nothing at all + +* inl_act says in what phases the unfolding is active or inactive + E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 + If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 + If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 + So note that inl_act does not say what pragma you wrote: it just + expresses its consequences + +* inl_act just says when the unfolding is active; it doesn't say what + to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, + but in addition f will get a "stable unfolding" with UnfoldingGuidance + that tells the inliner to be pretty eager about it. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in GHC.Core.Rules. +-} + +isConLike :: RuleMatchInfo -> Bool +isConLike ConLike = True +isConLike _ = False + +isFunLike :: RuleMatchInfo -> Bool +isFunLike FunLike = True +isFunLike _ = False + +noUserInlineSpec :: InlineSpec -> Bool +noUserInlineSpec NoUserInline = True +noUserInlineSpec _ = False + +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = NoUserInline + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } + +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + +-- A DFun has an always-active inline activation so that +-- exprIsConApp_maybe can "see" its unfolding +-- (However, its actual Unfolding is a DFunUnfolding, which is +-- never inlined other than via exprIsConApp_maybe.) +dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive + , inl_rule = ConLike } + +isDefaultInlinePragma :: InlinePragma -> Bool +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = case inl_inline prag of + Inline -> True + _ -> False + +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable -> True + _ -> False + +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline -> True + Inlinable -> True + _ -> False + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + +inlinePragmaActivation :: InlinePragma -> Activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation + +inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info + +setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma +setInlinePragmaActivation prag activation = prag { inl_act = activation } + +setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } + +instance Outputable Activation where + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") + ppr (ActiveBefore _ n) = brackets (char '~' <> int n) + ppr (ActiveAfter _ n) = brackets (int n) + ppr FinalActive = text "[final]" + +instance Outputable RuleMatchInfo where + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" + +instance Outputable InlineSpec where + ppr Inline = text "INLINE" + ppr NoInline = text "NOINLINE" + ppr Inlinable = text "INLINABLE" + ppr NoUserInline = text "NOUSERINLINE" -- what is better? + +instance Outputable InlinePragma where + ppr = pprInline + +pprInline :: InlinePragma -> SDoc +pprInline = pprInline' True + +pprInlineDebug :: InlinePragma -> SDoc +pprInlineDebug = pprInline' False + +pprInline' :: Bool -- True <=> do not display the inl_inline field + -> InlinePragma + -> SDoc +pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info + where + pp_inl x = if emptyInline then empty else ppr x + + pp_act Inline AlwaysActive = empty + pp_act NoInline NeverActive = empty + pp_act _ act = ppr act + + pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) + | otherwise = empty + pp_info | isFunLike info = empty + | otherwise = ppr info + + + +{- ********************************************************************* +* * + Integer literals +* * +********************************************************************* -} + +-- | Integral Literal +-- +-- Used (instead of Integer) to represent negative zegative zero which is +-- required for NegativeLiterals extension to correctly parse `-0::Double` +-- as negative zero. See also #13211. +data IntegralLit + = IL { il_text :: SourceText + , il_neg :: Bool -- See Note [Negative zero] + , il_value :: Integer + } + deriving (Data, Show) + +mkIntegralLit :: Integral a => a -> IntegralLit +mkIntegralLit i = IL { il_text = SourceText (show i_integer) + , il_neg = i < 0 + , il_value = i_integer } + where + i_integer :: Integer + i_integer = toInteger i + +negateIntegralLit :: IntegralLit -> IntegralLit +negateIntegralLit (IL text neg value) + = case text of + SourceText ('-':src) -> IL (SourceText src) False (negate value) + SourceText src -> IL (SourceText ('-':src)) True (negate value) + NoSourceText -> IL NoSourceText (not neg) (negate value) + +-- | Fractional Literal +-- +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +data FractionalLit + = FL { fl_text :: SourceText -- How the value was written in the source + , fl_neg :: Bool -- See Note [Negative zero] + , fl_value :: Rational -- Numeric value of the literal + } + deriving (Data, Show) + -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on + +mkFractionalLit :: Real a => a -> FractionalLit +mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) + -- Converting to a Double here may technically lose + -- precision (see #15502). We could alternatively + -- convert to a Rational for the most accuracy, but + -- it would cause Floats and Doubles to be displayed + -- strangely, so we opt not to do this. (In contrast + -- to mkIntegralLit, where we always convert to an + -- Integer for the highest accuracy.) + , fl_neg = r < 0 + , fl_value = toRational r } + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL text neg value) + = case text of + SourceText ('-':src) -> FL (SourceText src) False value + SourceText src -> FL (SourceText ('-':src)) True value + NoSourceText -> FL NoSourceText (not neg) (negate value) + +integralFractionalLit :: Bool -> Integer -> FractionalLit +integralFractionalLit neg i = FL { fl_text = SourceText (show i), + fl_neg = neg, + fl_value = fromInteger i } + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) + +instance Eq IntegralLit where + (==) = (==) `on` il_value + +instance Ord IntegralLit where + compare = compare `on` il_value + +instance Outputable IntegralLit where + ppr (IL (SourceText src) _ _) = text src + ppr (IL NoSourceText _ value) = text (show value) + +instance Eq FractionalLit where + (==) = (==) `on` fl_value + +instance Ord FractionalLit where + compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) + +{- +************************************************************************ +* * + IntWithInf +* * +************************************************************************ + +Represents an integer or positive infinity + +-} + +-- | An integer or infinity +data IntWithInf = Int {-# UNPACK #-} !Int + | Infinity + deriving Eq + +-- | A representation of infinity +infinity :: IntWithInf +infinity = Infinity + +instance Ord IntWithInf where + compare Infinity Infinity = EQ + compare (Int _) Infinity = LT + compare Infinity (Int _) = GT + compare (Int a) (Int b) = a `compare` b + +instance Outputable IntWithInf where + ppr Infinity = char '∞' + ppr (Int n) = int n + +instance Num IntWithInf where + (+) = plusWithInf + (*) = mulWithInf + + abs Infinity = Infinity + abs (Int n) = Int (abs n) + + signum Infinity = Int 1 + signum (Int n) = Int (signum n) + + fromInteger = Int . fromInteger + + (-) = panic "subtracting IntWithInfs" + +intGtLimit :: Int -> IntWithInf -> Bool +intGtLimit _ Infinity = False +intGtLimit n (Int m) = n > m + +-- | Add two 'IntWithInf's +plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf +plusWithInf Infinity _ = Infinity +plusWithInf _ Infinity = Infinity +plusWithInf (Int a) (Int b) = Int (a + b) + +-- | Multiply two 'IntWithInf's +mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf +mulWithInf Infinity _ = Infinity +mulWithInf _ Infinity = Infinity +mulWithInf (Int a) (Int b) = Int (a * b) + +-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity +treatZeroAsInf :: Int -> IntWithInf +treatZeroAsInf 0 = Infinity +treatZeroAsInf n = Int n + +-- | Inject any integer into an 'IntWithInf' +mkIntWithInf :: Int -> IntWithInf +mkIntWithInf = Int + +data SpliceExplicitFlag + = ExplicitSplice | -- ^ <=> $(f x y) + ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression + deriving Data + +{- ********************************************************************* +* * + Types vs Kinds +* * +********************************************************************* -} + +-- | Flag to see whether we're type-checking terms or kind-checking types +data TypeOrKind = TypeLevel | KindLevel + deriving Eq + +instance Outputable TypeOrKind where + ppr TypeLevel = text "TypeLevel" + ppr KindLevel = text "KindLevel" + +isTypeLevel :: TypeOrKind -> Bool +isTypeLevel TypeLevel = True +isTypeLevel KindLevel = False + +isKindLevel :: TypeOrKind -> Bool +isKindLevel TypeLevel = False +isKindLevel KindLevel = True diff --git a/GHC/Types/CostCentre.hs b/GHC/Types/CostCentre.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/CostCentre.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module GHC.Types.CostCentre ( + CostCentre(..), CcName, CCFlavour(..), + -- All abstract except to friend: ParseIface.y + + CostCentreStack, + CollectedCCs, emptyCollectedCCs, collectCC, + currentCCS, dontCareCCS, + isCurrentCCS, + maybeSingletonCCS, + + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, + isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, + + pprCostCentreCore, + costCentreUserName, costCentreUserNameFS, + costCentreSrcSpan, + + cmpCostCentre -- used for removing dups in a list + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Types.Var +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.Unique +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Types.CostCentre.State + +import Data.Data + +----------------------------------------------------------------------------- +-- Cost Centres + +-- | A Cost Centre is a single @{-# SCC #-}@ annotation. + +data CostCentre + = NormalCC { + cc_flavour :: CCFlavour, + -- ^ Two cost centres may have the same name and + -- module but different SrcSpans, so we need a way to + -- distinguish them easily and give them different + -- object-code labels. So every CostCentre has an + -- associated flavour that indicates how it was + -- generated, and flavours that allow multiple instances + -- of the same name and module have a deterministic 0-based + -- index. + cc_name :: CcName, -- ^ Name of the cost centre itself + cc_mod :: Module, -- ^ Name of module defining this CC. + cc_loc :: SrcSpan + } + + | AllCafsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_loc :: SrcSpan + } + deriving Data + +type CcName = FastString + +-- | The flavour of a cost centre. +-- +-- Index fields represent 0-based indices giving source-code ordering of +-- centres with the same module, name, and flavour. +data CCFlavour = CafCC -- ^ Auto-generated top-level thunk + | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression + | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration + | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage + deriving (Eq, Ord, Data) + +-- | Extract the index from a flavour +flavourIndex :: CCFlavour -> Int +flavourIndex CafCC = 0 +flavourIndex (ExprCC x) = unCostCentreIndex x +flavourIndex (DeclCC x) = unCostCentreIndex x +flavourIndex (HpcCC x) = unCostCentreIndex x + +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + +instance Ord CostCentre where + compare = cmpCostCentre + +cmpCostCentre :: CostCentre -> CostCentre -> Ordering + +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) + = m1 `compare` m2 + +cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} + NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} + -- first key is module name, then centre name, then flavour + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) + +cmpCostCentre other_1 other_2 + = let + tag1 = tag_CC other_1 + tag2 = tag_CC other_2 + in + if tag1 < tag2 then LT else GT + where + tag_CC :: CostCentre -> Int + tag_CC (NormalCC {}) = 0 + tag_CC (AllCafsCC {}) = 1 + + +----------------------------------------------------------------------------- +-- Predicates on CostCentre + +isCafCC :: CostCentre -> Bool +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_flavour = CafCC}) = True +isCafCC _ = False + +-- | Is this a cost-centre which records scc counts +isSccCountCC :: CostCentre -> Bool +isSccCountCC cc | isCafCC cc = False + | otherwise = True + +-- | Is this a cost-centre which can be sccd ? +sccAbleCC :: CostCentre -> Bool +sccAbleCC cc | isCafCC cc = False + | otherwise = True + +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m + + +----------------------------------------------------------------------------- +-- Building cost centres + +mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre +mkUserCC cc_name mod loc flavour + = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, + cc_flavour = flavour + } + +mkAutoCC :: Id -> Module -> CostCentre +mkAutoCC id mod + = NormalCC { cc_name = str, cc_mod = mod, + cc_loc = nameSrcSpan (getName id), + cc_flavour = CafCC + } + where + name = getName id + -- beware: only external names are guaranteed to have unique + -- Occnames. If the name is not external, we must append its + -- Unique. + -- See bug #249, tests prof001, prof002, also #2411 + str | isExternalName name = occNameFS (getOccName id) + | otherwise = occNameFS (getOccName id) + `appendFS` + mkFastString ('_' : show (getUnique name)) +mkAllCafsCC :: Module -> SrcSpan -> CostCentre +mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } + +----------------------------------------------------------------------------- +-- Cost Centre Stacks + +-- | A Cost Centre Stack is something that can be attached to a closure. +-- This is either: +-- +-- * the current cost centre stack (CCCS) +-- * a pre-defined cost centre stack (there are several +-- pre-defined CCSs, see below). + +data CostCentreStack + = CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. + + | DontCareCCS -- We need a CCS to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. + + | SingletonCCS CostCentre + + deriving (Eq, Ord) -- needed for Ord on CLabel + + +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) + +emptyCollectedCCs :: CollectedCCs +emptyCollectedCCs = ([], []) + +collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs +collectCC cc ccs (c, cs) = (cc : c, ccs : cs) + +currentCCS, dontCareCCS :: CostCentreStack + +currentCCS = CurrentCCS +dontCareCCS = DontCareCCS + +----------------------------------------------------------------------------- +-- Predicates on Cost-Centre Stacks + +isCurrentCCS :: CostCentreStack -> Bool +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False + +isCafCCS :: CostCentreStack -> Bool +isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS _ = False + +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre +maybeSingletonCCS (SingletonCCS cc) = Just cc +maybeSingletonCCS _ = Nothing + +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = SingletonCCS cc + + +----------------------------------------------------------------------------- +-- Printing Cost Centre Stacks. + +-- The outputable instance for CostCentreStack prints the CCS as a C +-- expression. + +instance Outputable CostCentreStack where + ppr CurrentCCS = text "CCCS" + ppr DontCareCCS = text "CCS_DONT_CARE" + ppr (SingletonCCS cc) = ppr cc <> text "_ccs" + + +----------------------------------------------------------------------------- +-- Printing Cost Centres +-- +-- There are several different ways in which we might want to print a +-- cost centre: +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- +-- The last 3 are derived from costCentreStr below. The first is given +-- by costCentreName. + +instance Outputable CostCentre where + ppr cc = getPprStyle $ \ sty -> + if codeStyle sty + then ppCostCentreLbl cc + else text (costCentreUserName cc) + +-- Printing in Core +pprCostCentreCore :: CostCentre -> SDoc +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr m) +pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, + cc_mod = m, cc_loc = loc}) + = text "__scc" <+> braces (hsep [ + ppr m <> char '.' <> ftext n, + pprFlavourCore flavour, + whenPprDebug (ppr loc) + ]) + +-- ^ Print a flavour in Core +pprFlavourCore :: CCFlavour -> SDoc +pprFlavourCore CafCC = text "__C" +pprFlavourCore f = pprIdxCore $ flavourIndex f + +-- ^ Print a flavour's index in Core +pprIdxCore :: Int -> SDoc +pprIdxCore 0 = empty +pprIdxCore idx = whenPprDebug $ ppr idx + +-- Printing as a C label +ppCostCentreLbl :: CostCentre -> SDoc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) + = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + ppFlavourLblComponent f <> text "_cc" + +-- ^ Print the flavour component of a C label +ppFlavourLblComponent :: CCFlavour -> SDoc +ppFlavourLblComponent CafCC = text "CAF" +ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i +ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i +ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i + +-- ^ Print the flavour index component of a C label +ppIdxLblComponent :: CostCentreIndex -> SDoc +ppIdxLblComponent n = + case unCostCentreIndex n of + 0 -> empty + n -> ppr n + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName :: CostCentre -> String +costCentreUserName = unpackFS . costCentreUserNameFS + +costCentreUserNameFS :: CostCentre -> FastString +costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" +costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) + = case is_caf of + CafCC -> mkFastString "CAF:" `appendFS` name + _ -> name + +costCentreSrcSpan :: CostCentre -> SrcSpan +costCentreSrcSpan = cc_loc + +instance Binary CCFlavour where + put_ bh CafCC = do + putByte bh 0 + put_ bh (ExprCC i) = do + putByte bh 1 + put_ bh i + put_ bh (DeclCC i) = do + putByte bh 2 + put_ bh i + put_ bh (HpcCC i) = do + putByte bh 3 + put_ bh i + get bh = do + h <- getByte bh + case h of + 0 -> do return CafCC + 1 -> ExprCC <$> get bh + 2 -> DeclCC <$> get bh + _ -> HpcCC <$> get bh + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + return (NormalCC aa ab ac noSrcSpan) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. diff --git a/GHC/Types/CostCentre/State.hs b/GHC/Types/CostCentre/State.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/CostCentre/State.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Types.CostCentre.State + ( CostCentreState + , newCostCentreState + , CostCentreIndex + , unCostCentreIndex + , getCCIndex + ) +where + +import GHC.Prelude +import GHC.Data.FastString +import GHC.Data.FastString.Env + +import Data.Data +import GHC.Utils.Binary + +-- | Per-module state for tracking cost centre indices. +-- +-- See documentation of 'GHC.Types.CostCentre.cc_flavour' for more details. +newtype CostCentreState = CostCentreState (FastStringEnv Int) + +-- | Initialize cost centre state. +newCostCentreState :: CostCentreState +newCostCentreState = CostCentreState emptyFsEnv + +-- | An index into a given cost centre module,name,flavour set +newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } + deriving (Eq, Ord, Data, Binary) + +-- | Get a new index for a given cost centre name. +getCCIndex :: FastString + -> CostCentreState + -> (CostCentreIndex, CostCentreState) +getCCIndex nm (CostCentreState m) = + (CostCentreIndex idx, CostCentreState m') + where + m_idx = lookupFsEnv m nm + idx = maybe 0 id m_idx + m' = extendFsEnv m nm (idx + 1) diff --git a/GHC/Types/Cpr.hs b/GHC/Types/Cpr.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Cpr.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +-- | Types for the Constructed Product Result lattice. "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils" +-- are its primary customers via 'GHC.Types.Id.idCprInfo'. +module GHC.Types.Cpr ( + CprResult, topCpr, botCpr, conCpr, asConCpr, + CprType (..), topCprType, botCprType, conCprType, + lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy, + CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig + ) where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Utils.Binary + +-- +-- * CprResult +-- + +-- | The constructed product result lattice. +-- +-- @ +-- NoCPR +-- | +-- ConCPR ConTag +-- | +-- BotCPR +-- @ +data CprResult = NoCPR -- ^ Top of the lattice + | ConCPR !ConTag -- ^ Returns a constructor from a data type + | BotCPR -- ^ Bottom of the lattice + deriving( Eq, Show ) + +lubCpr :: CprResult -> CprResult -> CprResult +lubCpr (ConCPR t1) (ConCPR t2) + | t1 == t2 = ConCPR t1 +lubCpr BotCPR cpr = cpr +lubCpr cpr BotCPR = cpr +lubCpr _ _ = NoCPR + +topCpr :: CprResult +topCpr = NoCPR + +botCpr :: CprResult +botCpr = BotCPR + +conCpr :: ConTag -> CprResult +conCpr = ConCPR + +trimCpr :: CprResult -> CprResult +trimCpr ConCPR{} = NoCPR +trimCpr cpr = cpr + +asConCpr :: CprResult -> Maybe ConTag +asConCpr (ConCPR t) = Just t +asConCpr NoCPR = Nothing +asConCpr BotCPR = Nothing + +-- +-- * CprType +-- + +-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. +data CprType + = CprType + { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression + -- eats before returning the 'ct_cpr' + , ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to + -- 'ct_arty' arguments + } + +instance Eq CprType where + a == b = ct_cpr a == ct_cpr b + && (ct_arty a == ct_arty b || ct_cpr a == topCpr) + +topCprType :: CprType +topCprType = CprType 0 topCpr + +botCprType :: CprType +botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments + +conCprType :: ConTag -> CprType +conCprType con_tag = CprType 0 (conCpr con_tag) + +lubCprType :: CprType -> CprType -> CprType +lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) + -- The arity of bottom CPR types can be extended arbitrarily. + | cpr1 == botCpr && n1 <= n2 = ty2 + | cpr2 == botCpr && n2 <= n1 = ty1 + -- There might be non-bottom CPR types with mismatching arities. + -- Consider test DmdAnalGADTs. We want to return top in these cases. + | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) + | otherwise = topCprType + +applyCprTy :: CprType -> Arity -> CprType +applyCprTy (CprType n res) k + | n >= k = CprType (n-k) res + | res == botCpr = botCprType + | otherwise = topCprType + +abstractCprTy :: CprType -> CprType +abstractCprTy (CprType n res) + | res == topCpr = topCprType + | otherwise = CprType (n+1) res + +ensureCprTyArity :: Arity -> CprType -> CprType +ensureCprTyArity n ty@(CprType m _) + | n == m = ty + | otherwise = topCprType + +trimCprTy :: CprType -> CprType +trimCprTy (CprType arty res) = CprType arty (trimCpr res) + +-- | The arity of the wrapped 'CprType' is the arity at which it is safe +-- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand" +newtype CprSig = CprSig { getCprSig :: CprType } + deriving (Eq, Binary) + +-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' +-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in +-- "GHC.Types.Demand" +mkCprSigForArity :: Arity -> CprType -> CprSig +mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty) + +topCprSig :: CprSig +topCprSig = CprSig topCprType + +mkCprSig :: Arity -> CprResult -> CprSig +mkCprSig arty cpr = CprSig (CprType arty cpr) + +seqCprSig :: CprSig -> () +seqCprSig sig = sig `seq` () + +instance Outputable CprResult where + ppr NoCPR = empty + ppr (ConCPR n) = char 'm' <> int n + ppr BotCPR = char 'b' + +instance Outputable CprType where + ppr (CprType arty res) = ppr arty <> ppr res + +-- | Only print the CPR result +instance Outputable CprSig where + ppr (CprSig ty) = ppr (ct_cpr ty) + +instance Binary CprResult where + put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n } + put_ bh NoCPR = putByte bh 1 + put_ bh BotCPR = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (ConCPR n) } + 1 -> return NoCPR + _ -> return BotCPR + +instance Binary CprType where + put_ bh (CprType arty cpr) = do + put_ bh arty + put_ bh cpr + get bh = CprType <$> get bh <*> get bh diff --git a/GHC/Types/Demand.hs b/GHC/Types/Demand.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Demand.hs @@ -0,0 +1,2080 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Demand]{@Demand@: A decoupled implementation of a demand domain} +-} + +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Demand ( + StrDmd, UseDmd(..), Count, + + Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, + mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, + toCleanDmd, + absDmd, topDmd, botDmd, seqDmd, + lubDmd, bothDmd, + lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, + isTopDmd, isAbsDmd, isSeqDmd, + peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, + addCaseBndrDmd, + + DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, + BothDmdArg, mkBothDmdArg, toBothDmdArg, + nopDmdType, botDmdType, addDemand, + + DmdEnv, emptyDmdEnv, keepAliveDmdEnv, + peelFV, findIdDemand, + + Divergence(..), lubDivergence, isDeadEndDiv, + topDiv, botDiv, exnDiv, + appIsDeadEnd, isDeadEndSig, pprIfaceStrictSig, + StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, + nopSig, botSig, + isTopSig, hasDemandEnvSig, + splitStrictSig, strictSigDmdEnv, + prependArgsStrictSig, etaConvertStrictSig, + + seqDemand, seqDemandList, seqDmdType, seqStrictSig, + + evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, + splitDmdTy, splitFVs, deferAfterPreciseException, + postProcessUnsat, postProcessDmdType, + + splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, + mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, + dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, + TypeShape(..), trimToType, + + useCount, isUsedOnce, reuseEnv, + zapUsageDemand, zapUsageEnvSig, + zapUsedOnceDemand, zapUsedOnceSig, + strictifyDictDmd, strictifyDmd + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Types.Var ( Var, Id ) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.FM +import GHC.Utils.Misc +import GHC.Types.Basic +import GHC.Utils.Binary +import GHC.Data.Maybe ( orElse ) + +import GHC.Core.Type ( Type ) +import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) +import GHC.Core.DataCon ( splitDataProductType_maybe ) +import GHC.Core.Multiplicity ( scaledThing ) + +{- +************************************************************************ +* * + Joint domain for Strictness and Absence +* * +************************************************************************ +-} + +data JointDmd s u = JD { sd :: s, ud :: u } + deriving ( Eq, Show ) + +getStrDmd :: JointDmd s u -> s +getStrDmd = sd + +getUseDmd :: JointDmd s u -> u +getUseDmd = ud + +-- Pretty-printing +instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where + ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) + +-- Well-formedness preserving constructors for the joint domain +mkJointDmd :: s -> u -> JointDmd s u +mkJointDmd s u = JD { sd = s, ud = u } + +mkJointDmds :: [s] -> [u] -> [JointDmd s u] +mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as + + +{- +************************************************************************ +* * + Strictness domain +* * +************************************************************************ + + Lazy + | + HeadStr + / \ + SCall SProd + \ / + HyperStr + +Note [Exceptions and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to smart about catching exceptions, but we aren't anymore. +See #14998 for the way it's resolved at the moment. + +Here's a historic breakdown: + +Apparently, exception handling prim-ops didn't use to have any special +strictness signatures, thus defaulting to nopSig, which assumes they use their +arguments lazily. Joachim was the first to realise that we could provide richer +information. Thus, in 0558911f91c (Dec 13), he added signatures to +primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call +their argument, which is useful information for usage analysis. Still with a +'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. + +In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a +'strictApply1Dmd' leads to substantial performance gains. That was at the cost +of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in +28638dfe79e (Dec 15). + +Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, +Ben opened #11222. Simon made the demand analyser "understand catch" in +9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call +its argument strictly, but also swallow any thrown exceptions in +'postProcessDivergence'. This was realized by extending the 'Str' constructor of +'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and +adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element +between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, +so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). + +This left the other variants like 'catchRetry#' having 'catchArgDmd', which is +where #14998 picked up. Item 1 was concerned with measuring the impact of also +making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that +there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 +(Apr 18). There was a lot of dead code resulting from that change, that we +removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and +removed any code that was dealing with the peculiarities. + +Where did the speed-ups vanish to? In #14998, item 3 established that +turning 'catch#' strict in its first argument didn't bring back any of the +alleged performance benefits. Item 2 of that ticket finally found out that it +was entirely due to 'catchException's new (since #11555) definition, which +was simply + + catchException !io handler = catch io handler + +While 'catchException' is arguably the saner semantics for 'catch', it is an +internal helper function in "GHC.IO". Its use in +"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: +Remove the bang and you find the regressions we originally wanted to avoid with +'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". + +So history keeps telling us that the only possibly correct strictness annotation +for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really +is not strict in its argument: Just try this in GHCi + + :set -XScopedTypeVariables + import Control.Exception + catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") + +Any analysis that assumes otherwise will be broken in some way or another +(beyond `-fno-pendantic-bottoms`). + +But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a +subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is +only used by `raiseIO#` in order to preserve precise exceptions by strictness +analysis, while not impacting the ability to eliminate dead code. +See Note [Precise exceptions and strictness analysis]. + +-} + +-- | Vanilla strictness domain +data StrDmd + = HyperStr -- ^ Hyper-strict (bottom of the lattice). + -- See Note [HyperStr and Use demands] + + | SCall StrDmd -- ^ Call demand + -- Used only for values of function type + + | SProd [ArgStr] -- ^ Product + -- Used only for values of product type + -- Invariant: not all components are HyperStr (use HyperStr) + -- not all components are Lazy (use HeadStr) + + | HeadStr -- ^ Head-Strict + -- A polymorphic demand: used for values of all types, + -- including a type variable + + deriving ( Eq, Show ) + +-- | Strictness of a function argument. +type ArgStr = Str StrDmd + +-- | Strictness demand. +data Str s = Lazy -- ^ Lazy (top of the lattice) + | Str s -- ^ Strict + deriving ( Eq, Show ) + +-- Well-formedness preserving constructors for the Strictness domain +strBot, strTop :: ArgStr +strBot = Str HyperStr +strTop = Lazy + +mkSCall :: StrDmd -> StrDmd +mkSCall HyperStr = HyperStr +mkSCall s = SCall s + +mkSProd :: [ArgStr] -> StrDmd +mkSProd sx + | any isHyperStr sx = HyperStr + | all isLazy sx = HeadStr + | otherwise = SProd sx + +isLazy :: ArgStr -> Bool +isLazy Lazy = True +isLazy (Str {}) = False + +isHyperStr :: ArgStr -> Bool +isHyperStr (Str HyperStr) = True +isHyperStr _ = False + +-- Pretty-printing +instance Outputable StrDmd where + ppr HyperStr = char 'B' + ppr (SCall s) = char 'C' <> parens (ppr s) + ppr HeadStr = char 'S' + ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) + +instance Outputable ArgStr where + ppr (Str s) = ppr s + ppr Lazy = char 'L' + +lubArgStr :: ArgStr -> ArgStr -> ArgStr +lubArgStr Lazy _ = Lazy +lubArgStr _ Lazy = Lazy +lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) + +lubStr :: StrDmd -> StrDmd -> StrDmd +lubStr HyperStr s = s +lubStr (SCall s1) HyperStr = SCall s1 +lubStr (SCall _) HeadStr = HeadStr +lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) +lubStr (SCall _) (SProd _) = HeadStr +lubStr (SProd sx) HyperStr = SProd sx +lubStr (SProd _) HeadStr = HeadStr +lubStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) + | otherwise = HeadStr +lubStr (SProd _) (SCall _) = HeadStr +lubStr HeadStr _ = HeadStr + +bothArgStr :: ArgStr -> ArgStr -> ArgStr +bothArgStr Lazy s = s +bothArgStr s Lazy = s +bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) + +bothStr :: StrDmd -> StrDmd -> StrDmd +bothStr HyperStr _ = HyperStr +bothStr HeadStr s = s +bothStr (SCall _) HyperStr = HyperStr +bothStr (SCall s1) HeadStr = SCall s1 +bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) +bothStr (SCall _) (SProd _) = HyperStr -- Weird + +bothStr (SProd _) HyperStr = HyperStr +bothStr (SProd s1) HeadStr = SProd s1 +bothStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) + | otherwise = HyperStr -- Weird +bothStr (SProd _) (SCall _) = HyperStr + +-- utility functions to deal with memory leaks +seqStrDmd :: StrDmd -> () +seqStrDmd (SProd ds) = seqStrDmdList ds +seqStrDmd (SCall s) = seqStrDmd s +seqStrDmd _ = () + +seqStrDmdList :: [ArgStr] -> () +seqStrDmdList [] = () +seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds + +seqArgStr :: ArgStr -> () +seqArgStr Lazy = () +seqArgStr (Str s) = seqStrDmd s + +-- Splitting polymorphic demands +splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] +splitArgStrProdDmd n Lazy = Just (replicate n Lazy) +splitArgStrProdDmd n (Str s) = splitStrProdDmd n s + +splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] +splitStrProdDmd n HyperStr = Just (replicate n strBot) +splitStrProdDmd n HeadStr = Just (replicate n strTop) +splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), + text "splitStrProdDmd" $$ ppr n $$ ppr ds ) + Just ds +splitStrProdDmd _ (SCall {}) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +{- +************************************************************************ +* * + Absence domain +* * +************************************************************************ + + Used + / \ + UCall UProd + \ / + UHead + | + Count x - + | + Abs +-} + +-- | Domain for genuine usage +data UseDmd + = UCall Count UseDmd -- ^ Call demand for absence. + -- Used only for values of function type + + | UProd [ArgUse] -- ^ Product. + -- Used only for values of product type + -- See Note [Don't optimise UProd(Used) to Used] + -- + -- Invariant: Not all components are Abs + -- (in that case, use UHead) + + | UHead -- ^ May be used but its sub-components are + -- definitely *not* used. For product types, UHead + -- is equivalent to U(AAA); see mkUProd. + -- + -- UHead is needed only to express the demand + -- of 'seq' and 'case' which are polymorphic; + -- i.e. the scrutinised value is of type 'a' + -- rather than a product type. That's why we + -- can't use UProd [A,A,A] + -- + -- Since (UCall _ Abs) is ill-typed, UHead doesn't + -- make sense for lambdas + + | Used -- ^ May be used and its sub-components may be used. + -- (top of the lattice) + deriving ( Eq, Show ) + +-- Extended usage demand for absence and counting +type ArgUse = Use UseDmd + +data Use u + = Abs -- Definitely unused + -- Bottom of the lattice + + | Use Count u -- May be used with some cardinality + deriving ( Eq, Show ) + +-- | Abstract counting of usages +data Count = One | Many + deriving ( Eq, Show ) + +-- Pretty-printing +instance Outputable ArgUse where + ppr Abs = char 'A' + ppr (Use Many a) = ppr a + ppr (Use One a) = char '1' <> char '*' <> ppr a + +instance Outputable UseDmd where + ppr Used = char 'U' + ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) + ppr UHead = char 'H' + ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) + +instance Outputable Count where + ppr One = char '1' + ppr Many = text "" + +useBot, useTop :: ArgUse +useBot = Abs +useTop = Use Many Used + +mkUCall :: Count -> UseDmd -> UseDmd +--mkUCall c Used = Used c +mkUCall c a = UCall c a + +mkUProd :: [ArgUse] -> UseDmd +mkUProd ux + | all (== Abs) ux = UHead + | otherwise = UProd ux + +lubCount :: Count -> Count -> Count +lubCount _ Many = Many +lubCount Many _ = Many +lubCount x _ = x + +lubArgUse :: ArgUse -> ArgUse -> ArgUse +lubArgUse Abs x = x +lubArgUse x Abs = x +lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) + +lubUse :: UseDmd -> UseDmd -> UseDmd +lubUse UHead u = u +lubUse (UCall c u) UHead = UCall c u +lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) +lubUse (UCall _ _) _ = Used +lubUse (UProd ux) UHead = UProd ux +lubUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 + | otherwise = Used +lubUse (UProd {}) (UCall {}) = Used +-- lubUse (UProd {}) Used = Used +lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) +lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) +lubUse Used _ = Used -- Note [Used should win] + +-- `both` is different from `lub` in its treatment of counting; if +-- `both` is computed for two used, the result always has +-- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). +-- Also, x `bothUse` x /= x (for anything but Abs). + +bothArgUse :: ArgUse -> ArgUse -> ArgUse +bothArgUse Abs x = x +bothArgUse x Abs = x +bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) + + +bothUse :: UseDmd -> UseDmd -> UseDmd +bothUse UHead u = u +bothUse (UCall c u) UHead = UCall c u + +-- Exciting special treatment of inner demand for call demands: +-- use `lubUse` instead of `bothUse`! +bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) + +bothUse (UCall {}) _ = Used +bothUse (UProd ux) UHead = UProd ux +bothUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 + | otherwise = Used +bothUse (UProd {}) (UCall {}) = Used +-- bothUse (UProd {}) Used = Used -- Note [Used should win] +bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) +bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) +bothUse Used _ = Used -- Note [Used should win] + +peelUseCall :: UseDmd -> Maybe (Count, UseDmd) +peelUseCall (UCall c u) = Just (c,u) +peelUseCall _ = Nothing + +addCaseBndrDmd :: Demand -- On the case binder + -> [Demand] -- On the components of the constructor + -> [Demand] -- Final demands for the components of the constructor +-- See Note [Demand on case-alternative binders] +addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds + = case mu of + Abs -> alt_dmds + Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) + where + Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call + Just us = splitUseProdDmd arity u -- Ditto + where + arity = length alt_dmds + +{- Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis: + f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=] + { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +It's true that ds_dnz is *itself* absent, but the use of wild_X7 means +that it is very much alive and demanded. See #10148 for how the +consequences play out. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + +Note [Don't optimise UProd(Used) to Used] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These two UseDmds: + UProd [Used, Used] and Used +are semantically equivalent, but we do not turn the former into +the latter, for a regrettable-subtle reason. Suppose we did. +then + f (x,y) = (y,x) +would get + StrDmd = Str = SProd [Lazy, Lazy] + UseDmd = Used = UProd [Used, Used] +But with the joint demand of doesn't convey any clue +that there is a product involved, and so the worthSplittingFun +will not fire. (We'd need to use the type as well to make it fire.) +Moreover, consider + g h p@(_,_) = h p +This too would get , but this time there really isn't any +point in w/w since the components of the pair are not used at all. + +So the solution is: don't aggressively collapse UProd [Used,Used] to +Used; instead leave it as-is. In effect we are using the UseDmd to do a +little bit of boxity analysis. Not very nice. + +Note [Used should win] +~~~~~~~~~~~~~~~~~~~~~~ +Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. +Why? Because Used carries the implication the whole thing is used, +box and all, so we don't want to w/w it. If we use it both boxed and +unboxed, then we are definitely using the box, and so we are quite +likely to pay a reboxing cost. So we make Used win here. + +Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer + +Baseline: (A) Not making Used win (UProd wins) +Compare with: (B) making Used win for lub and both + + Min -0.3% -5.6% -10.7% -11.0% -33.3% + Max +0.3% +45.6% +11.5% +11.5% +6.9% + Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% + +Baseline: (B) Making Used win for both lub and both +Compare with: (C) making Used win for both, but UProd win for lub + + Min -0.1% -0.3% -7.9% -8.0% -6.5% + Max +0.1% +1.0% +21.0% +21.0% +0.5% + Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% +-} + +-- If a demand is used multiple times (i.e. reused), than any use-once +-- mentioned there, that is not protected by a UCall, can happen many times. +markReusedDmd :: ArgUse -> ArgUse +markReusedDmd Abs = Abs +markReusedDmd (Use _ a) = Use Many (markReused a) + +markReused :: UseDmd -> UseDmd +markReused (UCall _ u) = UCall Many u -- No need to recurse here +markReused (UProd ux) = UProd (map markReusedDmd ux) +markReused u = u + +isUsedMU :: ArgUse -> Bool +-- True <=> markReusedDmd d = d +isUsedMU Abs = True +isUsedMU (Use One _) = False +isUsedMU (Use Many u) = isUsedU u + +isUsedU :: UseDmd -> Bool +-- True <=> markReused d = d +isUsedU Used = True +isUsedU UHead = True +isUsedU (UProd us) = all isUsedMU us +isUsedU (UCall One _) = False +isUsedU (UCall Many _) = True -- No need to recurse + +-- Squashing usage demand demands +seqUseDmd :: UseDmd -> () +seqUseDmd (UProd ds) = seqArgUseList ds +seqUseDmd (UCall c d) = c `seq` seqUseDmd d +seqUseDmd _ = () + +seqArgUseList :: [ArgUse] -> () +seqArgUseList [] = () +seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds + +seqArgUse :: ArgUse -> () +seqArgUse (Use c u) = c `seq` seqUseDmd u +seqArgUse _ = () + +-- Splitting polymorphic Maybe-Used demands +splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] +splitUseProdDmd n Used = Just (replicate n useTop) +splitUseProdDmd n UHead = Just (replicate n Abs) +splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), + text "splitUseProdDmd" $$ ppr n + $$ ppr ds ) + Just ds +splitUseProdDmd _ (UCall _ _) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +useCount :: Use u -> Count +useCount Abs = One +useCount (Use One _) = One +useCount _ = Many + + +{- +************************************************************************ +* * + Clean demand for Strictness and Usage +* * +************************************************************************ + +This domain differst from JointDemand in the sense that pure absence +is taken away, i.e., we deal *only* with non-absent demands. + +Note [Strict demands] +~~~~~~~~~~~~~~~~~~~~~ +isStrictDmd returns true only of demands that are + both strict + and used +In particular, it is False for , which can and does +arise in, say (#7319) + f x = raise# +Then 'x' is not used, so f gets strictness -> . +Now the w/w generates + fx = let x = absentError "unused" + in raise +At this point we really don't want to convert to + fx = case absentError "unused" of x -> raise +Since the program is going to diverge, this swaps one error for another, +but it's really a bad idea to *ever* evaluate an absent argument. +In #7319 we get + T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] + +Note [Dealing with call demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Call demands are constructed and deconstructed coherently for +strictness and absence. For instance, the strictness signature for the +following function + +f :: (Int -> (Int, Int)) -> (Int, Bool) +f g = (snd (g 3), True) + +should be: m +-} + +type CleanDemand = JointDmd StrDmd UseDmd + -- A demand that is at least head-strict + +bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand +bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) + = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } + +mkHeadStrict :: CleanDemand -> CleanDemand +mkHeadStrict cd = cd { sd = HeadStr } + +mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand +mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } +mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } + +evalDmd :: Demand +-- Evaluated strictly, and used arbitrarily deeply +evalDmd = JD { sd = Str HeadStr, ud = useTop } + +mkProdDmd :: [Demand] -> CleanDemand +mkProdDmd dx + = JD { sd = mkSProd $ map getStrDmd dx + , ud = mkUProd $ map getUseDmd dx } + +-- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. +mkCallDmd :: CleanDemand -> CleanDemand +mkCallDmd (JD {sd = d, ud = u}) + = JD { sd = mkSCall d, ud = mkUCall One u } + +-- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. +mkCallDmds :: Arity -> CleanDemand -> CleanDemand +mkCallDmds arity cd = iterate mkCallDmd cd !! arity + +-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap +mkWorkerDemand :: Int -> Demand +mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } + where go 0 = Used + go n = mkUCall One $ go (n-1) + +cleanEvalDmd :: CleanDemand +cleanEvalDmd = JD { sd = HeadStr, ud = Used } + +cleanEvalProdDmd :: Arity -> CleanDemand +cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } + + +{- +************************************************************************ +* * + Demand: Combining Strictness and Usage +* * +************************************************************************ +-} + +type Demand = JointDmd ArgStr ArgUse + +lubDmd :: Demand -> Demand -> Demand +lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `lubArgStr` s2 + , ud = a1 `lubArgUse` a2 } + +bothDmd :: Demand -> Demand -> Demand +bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `bothArgStr` s2 + , ud = a1 `bothArgUse` a2 } + +lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand + +strictApply1Dmd = JD { sd = Str (SCall HeadStr) + , ud = Use Many (UCall One Used) } + +lazyApply1Dmd = JD { sd = Lazy + , ud = Use One (UCall One Used) } + +-- Second argument of catch#: +-- uses its arg at most once, applies it once +-- but is lazy (might not be called at all) +lazyApply2Dmd = JD { sd = Lazy + , ud = Use One (UCall One (UCall One Used)) } + +absDmd :: Demand +absDmd = JD { sd = Lazy, ud = Abs } + +topDmd :: Demand +topDmd = JD { sd = Lazy, ud = useTop } + +botDmd :: Demand +botDmd = JD { sd = strBot, ud = useBot } + +seqDmd :: Demand +seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } + +oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) +oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } +oneifyDmd jd = jd + +isTopDmd :: Demand -> Bool +-- Used to suppress pretty-printing of an uninformative demand +isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True +isTopDmd _ = False + +isAbsDmd :: JointDmd (Str s) (Use u) -> Bool +isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr +isAbsDmd _ = False -- for a bottom demand + +isSeqDmd :: Demand -> Bool +isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True +isSeqDmd _ = False + +isUsedOnce :: JointDmd (Str s) (Use u) -> Bool +isUsedOnce (JD { ud = a }) = case useCount a of + One -> True + Many -> False + +-- More utility functions for strictness +seqDemand :: Demand -> () +seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u + +seqDemandList :: [Demand] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +isStrictDmd :: JointDmd (Str s) (Use u) -> Bool +-- See Note [Strict demands] +isStrictDmd (JD {ud = Abs}) = False +isStrictDmd (JD {sd = Lazy}) = False +isStrictDmd _ = True + +isWeakDmd :: Demand -> Bool +isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a + +cleanUseDmd_maybe :: Demand -> Maybe UseDmd +cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u +cleanUseDmd_maybe _ = Nothing + +splitFVs :: Bool -- Thunk + -> DmdEnv -> (DmdEnv, DmdEnv) +splitFVs is_thunk rhs_fvs + | is_thunk = strictPairToTuple $ + nonDetStrictFoldUFM_Directly add (emptyVarEnv :*: emptyVarEnv) rhs_fvs + -- It's OK to use a non-deterministic fold because we + -- immediately forget the ordering by putting the elements + -- in the envs again + | otherwise = partitionVarEnv isWeakDmd rhs_fvs + where + add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv :*: sig_fv) + | Lazy <- s = addToUFM_Directly lazy_fv uniq dmd :*: sig_fv + | otherwise = addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) + :*: + addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) + +keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv +-- (keepAliveDmdType dt vs) makes sure that the Ids in vs have +-- /some/ usage in the returned demand types -- they are not Absent +-- See Note [Absence analysis for stable unfoldings and RULES] +-- in GHC.Core.Opt.DmdAnal +keepAliveDmdEnv env vs + = nonDetStrictFoldVarSet add env vs + where + add :: Id -> DmdEnv -> DmdEnv + add v env = extendVarEnv_C add_dmd env v topDmd + + add_dmd :: Demand -> Demand -> Demand + -- If the existing usage is Absent, make it used + -- Otherwise leave it alone + add_dmd dmd _ | isAbsDmd dmd = topDmd + | otherwise = dmd + +splitProdDmd_maybe :: Demand -> Maybe [Demand] +-- Split a product into its components, iff there is any +-- useful information to be extracted thereby +-- The demand is not necessarily strict! +splitProdDmd_maybe (JD { sd = s, ud = u }) + = case (s,u) of + (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u + -> Just (mkJointDmds sx ux) + (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s + -> Just (mkJointDmds sx ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing + +data StrictPair a b = !a :*: !b + +strictPairToTuple :: StrictPair a b -> (a, b) +strictPairToTuple (x :*: y) = (x, y) + +{- ********************************************************************* +* * + TypeShape and demand trimming +* * +********************************************************************* -} + + +data TypeShape -- See Note [Trimming a demand to a type] + -- in GHC.Core.Opt.DmdAnal + = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk + +trimToType :: Demand -> TypeShape -> Demand +-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal +trimToType (JD { sd = ms, ud = mu }) ts + = JD (go_ms ms ts) (go_mu mu ts) + where + go_ms :: ArgStr -> TypeShape -> ArgStr + go_ms Lazy _ = Lazy + go_ms (Str s) ts = Str (go_s s ts) + + go_s :: StrDmd -> TypeShape -> StrDmd + go_s HyperStr _ = HyperStr + go_s (SCall s) (TsFun ts) = SCall (go_s s ts) + go_s (SProd mss) (TsProd tss) + | equalLength mss tss = SProd (zipWith go_ms mss tss) + go_s _ _ = HeadStr + + go_mu :: ArgUse -> TypeShape -> ArgUse + go_mu Abs _ = Abs + go_mu (Use c u) ts = Use c (go_u u ts) + + go_u :: UseDmd -> TypeShape -> UseDmd + go_u UHead _ = UHead + go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) + go_u (UProd mus) (TsProd tss) + | equalLength mus tss = UProd (zipWith go_mu mus tss) + go_u _ _ = Used + +instance Outputable TypeShape where + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) + + + +{- ********************************************************************* +* * + Termination +* * +********************************************************************* -} + +-- | Divergence lattice. Models a subset lattice of the following exhaustive +-- set of divergence results: +-- +-- [n] nontermination (e.g. loops) +-- [i] throws imprecise exception +-- [p] throws precise exception +-- [c] converges (reduces to WHNF) +-- +-- The different lattice elements correspond to different subsets, indicated by +-- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an +-- exception, and may or may not reduce to WHNF). +-- +-- @ +-- Dunno (nipc) +-- | +-- ExnOrDiv (nip) +-- | +-- Diverges (ni) +-- @ +-- +-- As you can see, we don't distinguish __n__ and __i__. +-- See Note [Precise exceptions and strictness analysis] for why __p__ is so +-- special compared to __i__. +data Divergence + = Diverges -- ^ Definitely throws an imprecise exception or diverges. + | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise + -- exception or diverges. Never converges, hence 'isDeadEndDiv'! + -- See scenario 1 in Note [Precise exceptions and strictness analysis]. + | Dunno -- ^ Might diverge, throw any kind of exception or converge. + deriving( Eq, Show ) + +lubDivergence :: Divergence -> Divergence -> Divergence +lubDivergence Diverges div = div +lubDivergence div Diverges = div +lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv +lubDivergence _ _ = Dunno +-- This needs to commute with defaultFvDmd, i.e. +-- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 +-- (See Note [Default demand on free variables and arguments] for why) + +bothDivergence :: Divergence -> Divergence -> Divergence +-- See Note [Asymmetry of 'both*'], which concludes that 'bothDivergence' needs +-- to be symmetric. +-- Strictly speaking, we should have @bothDivergence Dunno Diverges = ExnOrDiv@. +-- But that regresses in too many places (every infinite loop, basically) to be +-- worth it and is only relevant in higher-order scenarios +-- (e.g. Divergence of @f (throwIO blah)@). +-- So 'bothDivergence' currently is 'glbDivergence', really. +bothDivergence Dunno Dunno = Dunno +bothDivergence Diverges _ = Diverges +bothDivergence _ Diverges = Diverges +bothDivergence _ _ = ExnOrDiv + +instance Outputable Divergence where + ppr Diverges = char 'b' -- for (b)ottom + ppr ExnOrDiv = char 'x' -- for e(x)ception + ppr Dunno = empty + +{- Note [Precise vs imprecise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An exception is considered to be /precise/ when it is thrown by the 'raiseIO#' +primop. It follows that all other primops (such as 'raise#' or +division-by-zero) throw /imprecise/ exceptions. Note that the actual type of +the exception thrown doesn't have any impact! + +GHC undertakes some effort not to apply an optimisation that would mask a +/precise/ exception with some other source of nontermination, such as genuine +divergence or an imprecise exception, so that the user can reliably +intercept the precise exception with a catch handler before and after +optimisations. + +See also the wiki page on precise exceptions: +https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions +Section 5 of "Tackling the awkward squad" talks about semantic concerns. +Imprecise exceptions are actually more interesting than precise ones (which are +fairly standard) from the perspective of semantics. See the paper "A Semantics +for Imprecise Exceptions" for more details. + +Note [Dead ends] +~~~~~~~~~~~~~~~~ +We call an expression that either diverges or throws a precise or imprecise +exception a "dead end". We used to call such an expression just "bottoming", +but with the measures we take to preserve precise exception semantics +(see Note [Precise exceptions and strictness analysis]), that is no longer +accurate: 'exnDiv' is no longer the bottom of the Divergence lattice. + +Yet externally to demand analysis, we mostly care about being able to drop dead +code etc., which is all due to the property that such an expression never +returns, hence we consider throwing a precise exception to be a dead end. +See also 'isDeadEndDiv'. + +Note [Precise exceptions and strictness analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to take care to preserve precise exception semantics in strictness +analysis (#17676). There are two scenarios that need careful treatment. + +The fixes were discussed at +https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions + +Recall that raiseIO# raises a *precise* exception, in contrast to raise# which +raises an *imprecise* exception. See Note [Precise vs imprecise exceptions]. + +Scenario 1: Precise exceptions in case alternatives +--------------------------------------------------- +Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv. +Here's why. Consider this example from #13380 (similarly #17676): + f x y | x>0 = raiseIO# Exc + | y>0 = return 1 + | otherwise = return 2 +Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and +loose with the precise exception; after optimisation, (f 42 (error "boom")) +turns from throwing the precise Exc to throwing the imprecise user error +"boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be +achieved by giving it divergence exnDiv. +See Note [Default demand on free variables and arguments]. + +Why don't we just give it topDiv instead of introducing exnDiv? +Because then the simplifier will fail to discard raiseIO#'s continuation in + case raiseIO# x s of { (# s', r #) -> } +which we'd like to optimise to + case raiseIO# x s of {} +Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and +its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it +behaves exactly as botDiv, so that dead code elimination works as expected. +This is tracked by T13380b. + +Scenario 2: Precise exceptions in case scrutinees +------------------------------------------------- +Consider (more complete examples in #148, #1592, testcase strun003) + + case foo x s of { (# s', r #) -> y } + +Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception +(ultimately via raiseIO#), then we must not force 'y', which may fail to +terminate or throw an imprecise exception, until we have performed @foo x s@. + +So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to +model the exceptional control flow) when @foo x s@ may throw a precise +exception. Motivated by T13380{d,e,f}. +See Note [Which scrutinees may throw precise exceptions] in "GHC.Core.Opt.DmdAnal". + +We have to be careful not to discard dead-end Divergence from case +alternatives, though (#18086): + + m = putStrLn "foo" >> error "bar" + +'m' should still have 'exnDiv', which is why it is not sufficient to lub with +'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'. + +Historical Note: This used to be called the "IO hack". But that term is rather +a bad fit because +1. It's easily confused with the "State hack", which also affects IO. +2. Neither "IO" nor "hack" is a good description of what goes on here, which + is deferring strictness results after possibly throwing a precise exception. + The "hack" is probably not having to defer when we can prove that the + expression may not throw a precise exception (increasing precision of the + analysis), but that's just a favourable guess. +-} + +------------------------------------------------------------------------ +-- Combined demand result -- +------------------------------------------------------------------------ + +topDiv, exnDiv, botDiv :: Divergence +topDiv = Dunno +exnDiv = ExnOrDiv +botDiv = Diverges + +-- | True if the result indicates that evaluation will not return. +-- See Note [Dead ends]. +isDeadEndDiv :: Divergence -> Bool +isDeadEndDiv Diverges = True +isDeadEndDiv ExnOrDiv = True +isDeadEndDiv Dunno = False + +-- See Notes [Default demand on free variables and arguments] +-- and Scenario 1 in [Precise exceptions and strictness analysis] +defaultFvDmd :: Divergence -> Demand +defaultFvDmd Dunno = absDmd +defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv! +defaultFvDmd Diverges = botDmd -- Diverges + +defaultArgDmd :: Divergence -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes === (Bot -> BotRes) === ... +-- TopRes === (Top -> TopRes) === ... +-- This function makes that concrete +-- Also see Note [Default demand on free variables and arguments] +defaultArgDmd Dunno = topDmd +-- NB: not botDmd! We don't want to mask the precise exception by forcing the +-- argument. But it is still absent. +defaultArgDmd ExnOrDiv = absDmd +defaultArgDmd Diverges = botDmd + +{- Note [Default demand on free variables and arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Free variables not mentioned in the environment of a 'DmdType' +are demanded according to the demand type's Divergence: + * In a Diverges (botDiv) context, that demand is botDmd + (HyperStr and Absent). + * In all other contexts, the demand is absDmd (Lazy and Absent). +This is recorded in 'defaultFvDmd'. + +Similarly, we can eta-expand demand types to get demands on excess arguments +not accounted for in the type, by consulting 'defaultArgDmd': + * In a Diverges (botDiv) context, that demand is again botDmd. + * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge + before evaluating the excess argument, but don't want to eagerly evaluate + it (cf. Note [Precise exceptions and strictness analysis]). + * In a Dunno context (topDiv), the demand is topDmd, because + it's perfectly possible to enter the additional lambda and evaluate it + in unforeseen ways (so, not Absent). + + +************************************************************************ +* * + Demand environments and types +* * +************************************************************************ +-} + +type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables and arguments] + +data DmdType = DmdType + DmdEnv -- Demand on explicitly-mentioned + -- free variables + [Demand] -- Demand on arguments + Divergence -- See [Demand type Divergence] + +{- +Note [Demand type Divergence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand. +This is described in detail in Note [Understanding DmdType and StrictSig]. +Here, we'll focus on what that means for a DmdType's Divergence in a higher-order +scenario. + +Consider + err x y = x `seq` y `seq` error (show x) +this has a strictness signature of + b +meaning that we don't know what happens when we call errin weaker contexts than +C(C(S)), like @err `seq` ()@ (S) and @err 1 `seq` ()@ (C(S)). We may not unleash +the botDiv, hence assume topDiv. Of course, in @err 1 2 `seq` ()@ the incoming +demand C(C(S)) is strong enough and we see that the expression diverges. + +Now consider a function + f g = g 1 2 +with signature , and the expression + f err `seq` () +now f puts a strictness demand of C(C(S)) onto its argument, which is unleashed +on err via the App rule. In contrast to weaker head strictness, this demand is +strong enough to unleash err's signature and hence we see that the whole +expression diverges! + +Note [Asymmetry of 'both*'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'both' for DmdTypes is *asymmetrical*, because there can only one +be one type contributing argument demands! For example, given (e1 e2), we get +a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do +(dt1 `bothType` dt2). Similarly with + case e of { p -> rhs } +we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then +compute (dt_rhs `bothType` dt_scrut). + +We + 1. combine the information on the free variables, + 2. take the demand on arguments from the first argument + 3. combine the termination results, as in bothDivergence. + +Since we don't use argument demands of the second argument anyway, 'both's +second argument is just a 'BothDmdType'. + +But note that the argument demand types are not guaranteed to be observed in +left to right order. For example, analysis of a case expression will pass the +demand type for the alts as the left argument and the type for the scrutinee as +the right argument. Also, it is not at all clear if there is such an order; +consider the LetUp case, where the RHS might be forced at any point while +evaluating the let body. +Therefore, it is crucial that 'bothDivergence' is symmetric! +-} + +-- Equality needed for fixpoints in GHC.Core.Opt.DmdAnal +instance Eq DmdType where + (==) (DmdType fv1 ds1 div1) + (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 + -- It's OK to use nonDetUFMToList here because we're testing for + -- equality and even though the lists will be in some arbitrary + -- Unique order, it is the same order for both + && ds1 == ds2 && div1 == div2 + +-- | Compute the least upper bound of two 'DmdType's elicited /by the same +-- incoming demand/! +lubDmdType :: DmdType -> DmdType -> DmdType +lubDmdType d1 d2 + = DmdType lub_fv lub_ds lub_div + where + n = max (dmdTypeDepth d1) (dmdTypeDepth d2) + (DmdType fv1 ds1 r1) = etaExpandDmdType n d1 + (DmdType fv2 ds2 r2) = etaExpandDmdType n d2 + + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2) + lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 + lub_div = lubDivergence r1 r2 + +type BothDmdArg = (DmdEnv, Divergence) + +mkBothDmdArg :: DmdEnv -> BothDmdArg +mkBothDmdArg env = (env, topDiv) + +toBothDmdArg :: DmdType -> BothDmdArg +toBothDmdArg (DmdType fv _ r) = (fv, r) + +bothDmdType :: DmdType -> BothDmdArg -> DmdType +bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) + -- See Note [Asymmetry of 'both*'] + -- 'both' takes the argument/result info from its *first* arg, + -- using its second arg just for its free-var info. + = DmdType (plusVarEnv_CD bothDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) + ds1 + (r1 `bothDivergence` t2) + +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [hcat (map ppr ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = nonDetUFMToList fv + -- It's OK to use nonDetUFMToList here because we only do it for + -- pretty printing + +emptyDmdEnv :: VarEnv Demand +emptyDmdEnv = emptyVarEnv + +botDmdType :: DmdType +botDmdType = DmdType emptyDmdEnv [] botDiv + +-- | The demand type of doing nothing (lazy, absent, no Divergence +-- information). Note that it is ''not'' the top of the lattice (which would be +-- "may use everything"), so it is (no longer) called topDmdType. +-- (SG: I agree, but why is it still 'topDmd' then?) +nopDmdType :: DmdType +nopDmdType = DmdType emptyDmdEnv [] topDiv + +isTopDmdType :: DmdType -> Bool +isTopDmdType (DmdType env args div) + = div == topDiv && null args && isEmptyVarEnv env + +-- | The demand type of an unspecified expression that is guaranteed to +-- throw a (precise or imprecise) exception or diverge. +exnDmdType :: DmdType +exnDmdType = DmdType emptyDmdEnv [] exnDiv + +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth (DmdType _ ds _) = length ds + +-- | This makes sure we can use the demand type with n arguments after eta +-- expansion, where n must not be lower than the demand types depth. +-- It appends the argument list with the correct 'defaultArgDmd'. +etaExpandDmdType :: Arity -> DmdType -> DmdType +etaExpandDmdType n d + | n == depth = d + | n > depth = DmdType fv inc_ds div + | otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d) + where depth = dmdTypeDepth d + DmdType fv ds div = d + -- Arity increase: + -- * Demands on FVs are still valid + -- * Demands on args also valid, plus we can extend with defaultArgDmd + -- as appropriate for the given Divergence + -- * Divergence is still valid: + -- - A dead end after 2 arguments stays a dead end after 3 arguments + -- - The remaining case is Dunno, which is already topDiv + inc_ds = take n (ds ++ repeat (defaultArgDmd div)) + +-- | A conservative approximation for a given 'DmdType' in case of an arity +-- decrease. Currently, it's just nopDmdType. +decreaseArityDmdType :: DmdType -> DmdType +decreaseArityDmdType _ = nopDmdType + +seqDmdType :: DmdType -> () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () + +seqDmdEnv :: DmdEnv -> () +seqDmdEnv env = seqEltsUFM seqDemandList env + +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (defaultArgDmd res_ty, ty) + +-- | When e is evaluated after executing an IO action that may throw a precise +-- exception, we act as if there is an additional control flow path that is +-- taken if e throws a precise exception. The demand type of this control flow +-- path +-- * is lazy and absent ('topDmd') in all free variables and arguments +-- * has 'exnDiv' 'Divergence' result +-- So we can simply take a variant of 'nopDmdType', 'exnDmdType'. +-- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'! +-- That means failure to drop dead-ends, see #18086. +-- See Note [Precise exceptions and strictness analysis] +deferAfterPreciseException :: DmdType -> DmdType +deferAfterPreciseException = lubDmdType exnDmdType + +strictenDmd :: Demand -> Demand +strictenDmd (JD { sd = s, ud = u}) + = JD { sd = poke_s s, ud = poke_u u } + where + poke_s Lazy = Str HeadStr + poke_s s = s + poke_u Abs = useTop + poke_u u = u + +-- Deferring and peeling + +type DmdShell -- Describes the "outer shell" + -- of a Demand + = JointDmd (Str ()) (Use ()) + +toCleanDmd :: Demand -> (DmdShell, CleanDemand) +-- Splits a Demand into its "shell" and the inner "clean demand" +toCleanDmd (JD { sd = s, ud = u }) + = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) + -- See Note [Analyzing with lazy demand and lambdas] + -- See Note [Analysing with absent demand] + where + (ss, s') = case s of + Str s' -> (Str (), s') + Lazy -> (Lazy, HeadStr) + + (us, u') = case u of + Use c u' -> (Use c (), u') + Abs -> (Abs, Used) + +-- This is used in dmdAnalStar when post-processing +-- a function's argument demand. So we only care about what +-- does to free variables, and whether it terminates. +-- see Note [Asymmetry of 'both*'] +postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg +postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) + = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) + +postProcessDivergence :: Str () -> Divergence -> Divergence +-- In a Lazy scenario, we might not force the Divergence, in which case we +-- converge, hence Dunno. +postProcessDivergence Lazy _ = Dunno +postProcessDivergence _ d = d + +postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv +postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env + | Abs <- us = emptyDmdEnv + -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild + -- of the environment. Be careful, bad things will happen if this doesn't + -- match postProcessDmd (see #13977). + | Str _ <- ss + , Use One _ <- us = env + | otherwise = mapVarEnv (postProcessDmd ds) env + -- For the Absent case just discard all usage information + -- We only processed the thing at all to analyse the body + -- See Note [Always analyse in virgin pass] + +reuseEnv :: DmdEnv -> DmdEnv +reuseEnv = mapVarEnv (postProcessDmd + (JD { sd = Str (), ud = Use Many () })) + +postProcessUnsat :: DmdShell -> DmdType -> DmdType +postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) + = DmdType (postProcessDmdEnv ds fv) + (map (postProcessDmd ds) args) + (postProcessDivergence ss res_ty) + +postProcessDmd :: DmdShell -> Demand -> Demand +postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) + = JD { sd = s', ud = a' } + where + s' = case ss of + Lazy -> Lazy + Str _ -> s + a' = case us of + Abs -> Abs + Use Many _ -> markReusedDmd a + Use One _ -> a + +-- Peels one call level from the demand, and also returns +-- whether it was unsaturated (separately for strictness and usage) +peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) +-- Exploiting the fact that +-- on the strictness side C(B) = B +-- and on the usage side C(U) = U +peelCallDmd (JD {sd = s, ud = u}) + = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) + where + (s', ss) = case s of + SCall s' -> (s', Str ()) + HyperStr -> (HyperStr, Str ()) + _ -> (HeadStr, Lazy) + (u', us) = case u of + UCall c u' -> (u', Use c ()) + _ -> (Used, Use Many ()) + -- The _ cases for usage includes UHead which seems a bit wrong + -- because the body isn't used at all! + -- c.f. the Abs case in toCleanDmd + +-- Peels that multiple nestings of calls clean demand and also returns +-- whether it was unsaturated (separately for strictness and usage +-- see Note [Demands from unsaturated function calls] +peelManyCalls :: Int -> CleanDemand -> DmdShell +peelManyCalls n (JD { sd = str, ud = abs }) + = JD { sd = go_str n str, ud = go_abs n abs } + where + go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer + go_str 0 _ = Str () + go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) + go_str n (SCall d') = go_str (n-1) d' + go_str _ _ = Lazy + + go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least + go_abs 0 _ = Use One () -- one UCall Many in the demand + go_abs n (UCall One d') = go_abs (n-1) d' + go_abs _ _ = Use Many () + +{- +Note [Demands from unsaturated function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a demand transformer d1 -> d2 -> r for f. +If a sufficiently detailed demand is fed into this transformer, +e.g arising from "f x1 x2" in a strict, use-once context, +then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for +the free variable environment) and furthermore the result information r is the +one we want to use. + +An anonymous lambda is also an unsaturated function all (needs one argument, +none given), so this applies to that case as well. + +But the demand fed into f might be less than . There are a few cases: + * Not enough demand on the strictness side: + - In that case, we need to zap all strictness in the demand on arguments and + free variables. + - And finally Divergence information: If r says that f Diverges for sure, + then this holds when the demand guarantees that two arguments are going to + be passed. If the demand is lower, we may just as well converge. + If we were tracking definite convegence, than that would still hold under + a weaker demand than expected by the demand transformer. + * Not enough demand from the usage side: The missing usage can be expanded + using UCall Many, therefore this is subsumed by the third case: + * At least one of the uses has a cardinality of Many. + - Even if f puts a One demand on any of its argument or free variables, if + we call f multiple times, we may evaluate this argument or free variable + multiple times. So forget about any occurrence of "One" in the demand. + +In dmdTransformSig, we call peelManyCalls to find out if we are in any of these +cases, and then call postProcessUnsat to reduce the demand appropriately. + +Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use +peelCallDmd, which peels only one level, but also returns the demand put on the +body of the function. +-} + +peelFV :: DmdType -> Var -> (DmdType, Demand) +peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds res, dmd) + where + fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables and arguments] + dmd = lookupVarEnv fv id `orElse` defaultFvDmd res + +addDemand :: Demand -> DmdType -> DmdType +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res + +findIdDemand :: DmdType -> Var -> Demand +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultFvDmd res + +{- +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just returned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Analyzing with lazy demand and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The insight for analyzing lambdas follows from the fact that for +strictness S = C(L). This polymorphic expansion is critical for +cardinality analysis of the following example: + +{-# NOINLINE build #-} +build g = (g (:) [], g (:) []) + +h c z = build (\x -> + let z1 = z ++ z + in if c + then \y -> x (y ++ z1) + else \y -> x (z1 ++ y)) + +One can see that `build` assigns to `g` demand . +Therefore, when analyzing the lambda `(\x -> ...)`, we +expect each lambda \y -> ... to be annotated as "one-shot" +one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a +demand . + +This is achieved by, first, converting the lazy demand L into the +strict S by the second clause of the analysis. + +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand . The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by postProcessDmdType. + +* In a previous incarnation of GHC we needed to be extra careful in the + case of an *unlifted type*, because unlifted values are evaluated + even if they are not used. Example (see #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + However, the argument of toCleanDmd always satisfies the let/app + invariant; so if it is unlifted it is also okForSpeculation, and so + can be evaluated in a short finite time -- and that rules out nasty + cases like the one above. (I'm not quite sure why this was a + problem in an earlier version of GHC, but it isn't now.) +-} + +{- ********************************************************************* +* * + Demand signatures +* * +************************************************************************ + +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand +transfomer, namely + + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. +Also see Note [Demand type Divergence] for the meaning of a Divergence in a +strictness signature. + +If an Id is applied to less arguments than its arity, it means that +the demand on the function at a call site is weaker than the vanilla +call demand, used for signature inference. Therefore we place a top +demand on all arguments. Otherwise, the demand is specified by Id's +signature. + +For example, the demand transformer described by the demand signature + StrictSig (DmdType {x -> } m) +says that when the function is applied to two arguments, it +unleashes demand on the free var x, on the first arg, +and on the second, then returning a constructor. + +If this same function is applied to one arg, all we can say is that it +uses x with , and its arg with demand . + +Note [Understanding DmdType and StrictSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand types are sound approximations of an expression's semantics relative to +the incoming demand we put the expression under. Consider the following +expression: + + \x y -> x `seq` (y, 2*x) + +Here is a table with demand types resulting from different incoming demands we +put that expression under. Note the monotonicity; a stronger incoming demand +yields a more precise demand type: + + incoming demand | demand type + ---------------------------------------------------- + | {} + | {} + | {} + +Note that in the first example, the depth of the demand type was *higher* than +the arity of the incoming call demand due to the anonymous lambda. +The converse is also possible and happens when we unleash demand signatures. +In @f x y@, the incoming call demand on f has arity 2. But if all we have is a +demand signature with depth 1 for @f@ (which we can safely unleash, see below), +the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. + +So: Demand types are elicited by putting an expression under an incoming (call) +demand, the arity of which can be lower or higher than the depth of the +resulting demand type. +In contrast, a demand signature summarises a function's semantics *without* +immediately specifying the incoming demand it was produced under. Despite StrSig +being a newtype wrapper around DmdType, it actually encodes two things: + + * The threshold (i.e., minimum arity) to unleash the signature + * A demand type that is sound to unleash when the minimum arity requirement is + met. + +Here comes the subtle part: The threshold is encoded in the wrapped demand +type's depth! So in mkStrictSigForArity we make sure to trim the list of +argument demands to the given threshold arity. Call sites will make sure that +this corresponds to the arity of the call demand that elicited the wrapped +demand type. See also Note [What are demand signatures?] in GHC.Core.Opt.DmdAnal. +-} + +-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe +-- to unleash. Better construct this through 'mkStrictSigForArity'. +-- See Note [Understanding DmdType and StrictSig] +newtype StrictSig = StrictSig DmdType + deriving( Eq ) + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig :: StrictSig -> SDoc +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res + +-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' +-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] +mkStrictSigForArity :: Arity -> DmdType -> StrictSig +mkStrictSigForArity arity dmd_ty@(DmdType fvs args div) + | arity < dmdTypeDepth dmd_ty = StrictSig (DmdType fvs (take arity args) div) + | otherwise = StrictSig (etaExpandDmdType arity dmd_ty) + +mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig +mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) + +splitStrictSig :: StrictSig -> ([Demand], Divergence) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +prependArgsStrictSig :: Int -> StrictSig -> StrictSig +-- ^ Add extra ('topDmd') arguments to a strictness signature. +-- In contrast to 'etaConvertStrictSig', this /prepends/ additional argument +-- demands. This is used by FloatOut. +prependArgsStrictSig new_args sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | new_args == 0 = sig + | isTopDmdType dmd_ty = sig + | new_args < 0 = pprPanic "prependArgsStrictSig: negative new_args" + (ppr new_args $$ ppr sig) + | otherwise = StrictSig (DmdType env dmds' res) + where + dmds' = replicate new_args topDmd ++ dmds + +etaConvertStrictSig :: Arity -> StrictSig -> StrictSig +-- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to +-- the former (when the Simplifier identifies a new join points, for example). +-- In contrast to 'prependArgsStrictSig', this /appends/ extra arg demands if +-- necessary. +-- This works by looking at the 'DmdType' (which was produced under a call +-- demand for the old arity) and trying to transfer as many facts as we can to +-- the call demand of new arity. +-- An arity increase (resulting in a stronger incoming demand) can retain much +-- of the info, while an arity decrease (a weakening of the incoming demand) +-- must fall back to a conservative default. +etaConvertStrictSig arity (StrictSig dmd_ty) + | arity < dmdTypeDepth dmd_ty = StrictSig $ decreaseArityDmdType dmd_ty + | otherwise = StrictSig $ etaExpandDmdType arity dmd_ty + +isTopSig :: StrictSig -> Bool +isTopSig (StrictSig ty) = isTopDmdType ty + +hasDemandEnvSig :: StrictSig -> Bool +hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) + +strictSigDmdEnv :: StrictSig -> DmdEnv +strictSigDmdEnv (StrictSig (DmdType env _ _)) = env + +-- | True if the signature diverges or throws an exception in a saturated call. +-- See Note [Dead ends]. +isDeadEndSig :: StrictSig -> Bool +isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res + +botSig :: StrictSig +botSig = StrictSig botDmdType + +nopSig :: StrictSig +nopSig = StrictSig nopDmdType + +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty + +dmdTransformSig :: StrictSig -> CleanDemand -> DmdType +-- (dmdTransformSig fun_sig dmd) considers a call to a function whose +-- signature is fun_sig, with demand dmd. We return the demand +-- that the function places on its context (eg its args) +dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd + = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty + -- see Note [Demands from unsaturated function calls] + +dmdTransformDataConSig :: Arity -> CleanDemand -> DmdType +-- Same as dmdTransformSig but for a data constructor (worker), +-- which has a special kind of demand transformer. +-- If the constructor is saturated, we feed the demand on +-- the result into the constructor arguments. +dmdTransformDataConSig arity (JD { sd = str, ud = abs }) + | Just str_dmds <- go_str arity str + , Just abs_dmds <- go_abs arity abs + = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) topDiv + + | otherwise -- Not saturated + = nopDmdType + where + go_str 0 dmd = splitStrProdDmd arity dmd + go_str n (SCall s') = go_str (n-1) s' + go_str n HyperStr = go_str (n-1) HyperStr + go_str _ _ = Nothing + + go_abs 0 dmd = splitUseProdDmd arity dmd + go_abs n (UCall One u') = go_abs (n-1) u' + go_abs _ _ = Nothing + +dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType +-- Like dmdTransformDataConSig, we have a special demand transformer +-- for dictionary selectors. If the selector is saturated (ie has one +-- argument: the dictionary), we feed the demand on the result into +-- the indicated dictionary component. +dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd + | (cd',defer_use) <- peelCallDmd cd + , Just jds <- splitProdDmd_maybe dict_dmd + = postProcessUnsat defer_use $ + DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv + | otherwise + = nopDmdType -- See Note [Demand transformer for a dictionary selector] + where + enhance cd old | isAbsDmd old = old + | otherwise = mkOnceUsedDmd cd -- This is the one! + +dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" + +{- +Note [Demand transformer for a dictionary selector] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' +into the appropriate field of the dictionary. What *is* the appropriate field? +We just look at the strictness signature of the class op, which will be +something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. + +For single-method classes, which are represented by newtypes the signature +of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. +That's fine: if we are doing strictness analysis we are also doing inlining, +so we'll have inlined 'op' into a cast. So we can bale out in a conservative +way, returning nopDmdType. + +It is (just.. #8329) possible to be running strictness analysis *without* +having inlined class ops from single-method classes. Suppose you are using +ghc --make; and the first module has a local -O0 flag. So you may load a class +without interface pragmas, ie (currently) without an unfolding for the class +ops. Now if a subsequent module in the --make sweep has a local -O flag +you might do strictness analysis, but there is no inlining for the class op. +This is weird, so I'm not worried about whether this optimises brilliantly; but +it should not fall over. +-} + +argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +-- See Note [Computing one-shot info] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + | unsaturated_call = [] + | otherwise = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args + + go [] = [] + go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds + + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as + +-- saturatedByOneShots n C1(C1(...)) = True, +-- <=> +-- there are at least n nested C1(..) calls +-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap +saturatedByOneShots :: Int -> Demand -> Bool +saturatedByOneShots n (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go n arg_usg + _ -> False + where + go 0 _ = True + go n (UCall One u) = go (n-1) u + go _ _ = False + +argOneShots :: Demand -- depending on saturation + -> [OneShotInfo] +argOneShots (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go arg_usg + _ -> [] + where + go (UCall One u) = OneShotLam : go u + go (UCall Many u) = NoOneShotInfo : go u + go _ = [] + +{- Note [Computing one-shot info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + C1(C(C1(U))) C1(U) U +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal". +-} + +-- | Returns true if an application to n args would diverge or throw an +-- exception. See Note [Unsaturated applications] and Note [Dead ends]. +appIsDeadEnd :: StrictSig -> Int -> Bool +appIsDeadEnd (StrictSig (DmdType _ ds res)) n + = isDeadEndDiv res && not (lengthExceeds ds n) + +{- +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a function having bottom as its demand result is applied to a less +number of arguments than its syntactic arity, we cannot say for sure +that it is going to diverge. This is the reason why we use the +function appIsDeadEnd, which, given a strictness signature and a number +of arguments, says conservatively if the function is never going to return. +See Note [Dead ends]. +-} + +zapUsageEnvSig :: StrictSig -> StrictSig +-- Remove the usage environment from the demand +zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r + +zapUsageDemand :: Demand -> Demand +-- Remove the usage info, but not the strictness info, from the demand +zapUsageDemand = kill_usage $ KillFlags + { kf_abs = True + , kf_used_once = True + , kf_called_once = True + } + +-- | Remove all 1* information (but not C1 information) from the demand +zapUsedOnceDemand :: Demand -> Demand +zapUsedOnceDemand = kill_usage $ KillFlags + { kf_abs = False + , kf_used_once = True + , kf_called_once = False + } + +-- | Remove all 1* information (but not C1 information) from the strictness +-- signature +zapUsedOnceSig :: StrictSig -> StrictSig +zapUsedOnceSig (StrictSig (DmdType env ds r)) + = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) + +data KillFlags = KillFlags + { kf_abs :: Bool + , kf_used_once :: Bool + , kf_called_once :: Bool + } + +kill_usage :: KillFlags -> Demand -> Demand +kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} + +zap_musg :: KillFlags -> ArgUse -> ArgUse +zap_musg kfs Abs + | kf_abs kfs = useTop + | otherwise = Abs +zap_musg kfs (Use c u) + | kf_used_once kfs = Use Many (zap_usg kfs u) + | otherwise = Use c (zap_usg kfs u) + +zap_usg :: KillFlags -> UseDmd -> UseDmd +zap_usg kfs (UCall c u) + | kf_called_once kfs = UCall Many (zap_usg kfs u) + | otherwise = UCall c (zap_usg kfs u) +zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) +zap_usg _ u = u + +-- If the argument is a used non-newtype dictionary, give it strict +-- demand. Also split the product type & demand and recur in order to +-- similarly strictify the argument's contained used non-newtype +-- superclass dictionaries. We use the demand as our recursive measure +-- to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty dmd = case getUseDmd dmd of + Use n _ | + Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) + <- splitDataProductType_maybe ty, + not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary + -> seqDmd `bothDmd` -- main idea: ensure it's strict + case splitProdDmd_maybe dmd of + -- superclass cycles should not be a problem, since the demand we are + -- consuming would also have to be infinite in order for us to diverge + Nothing -> dmd -- no components have interesting demand, so stop + -- looking for superclass dicts + Just dmds + | all (not . isAbsDmd) dmds -> evalDmd + -- abstract to strict w/ arbitrary component use, since this + -- smells like reboxing; results in CBV boxed + -- + -- TODO revisit this if we ever do boxity analysis + | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd (map scaledThing inst_con_arg_tys) dmds of + JD {sd = s,ud = a} -> JD (Str s) (Use n a) + -- TODO could optimize with an aborting variant of zipWith since + -- the superclass dicts are always a prefix + _ -> dmd -- unused or not a dictionary + +strictifyDmd :: Demand -> Demand +strictifyDmd dmd@(JD { sd = str }) + = dmd { sd = str `bothArgStr` Str HeadStr } + +{- +Note [HyperStr and Use demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The information "HyperStr" needs to be in the strictness signature, and not in +the demand signature, because we still want to know about the demand on things. Consider + + f (x,y) True = error (show x) + f (x,y) False = x+1 + +The signature of f should be m. If we were not +distinguishing the uses on x and y in the True case, we could either not figure +out how deeply we can unpack x, or that we do not have to pass y. + + +************************************************************************ +* * + Serialisation +* * +************************************************************************ +-} + +instance Binary StrDmd where + put_ bh HyperStr = do putByte bh 0 + put_ bh HeadStr = do putByte bh 1 + put_ bh (SCall s) = do putByte bh 2 + put_ bh s + put_ bh (SProd sx) = do putByte bh 3 + put_ bh sx + get bh = do + h <- getByte bh + case h of + 0 -> do return HyperStr + 1 -> do return HeadStr + 2 -> do s <- get bh + return (SCall s) + _ -> do sx <- get bh + return (SProd sx) + +instance Binary ArgStr where + put_ bh Lazy = do + putByte bh 0 + put_ bh (Str s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return Lazy + _ -> do s <- get bh + return $ Str s + +instance Binary Count where + put_ bh One = do putByte bh 0 + put_ bh Many = do putByte bh 1 + + get bh = do h <- getByte bh + case h of + 0 -> return One + _ -> return Many + +instance Binary ArgUse where + put_ bh Abs = do + putByte bh 0 + put_ bh (Use c u) = do + putByte bh 1 + put_ bh c + put_ bh u + + get bh = do + h <- getByte bh + case h of + 0 -> return Abs + _ -> do c <- get bh + u <- get bh + return $ Use c u + +instance Binary UseDmd where + put_ bh Used = do + putByte bh 0 + put_ bh UHead = do + putByte bh 1 + put_ bh (UCall c u) = do + putByte bh 2 + put_ bh c + put_ bh u + put_ bh (UProd ux) = do + putByte bh 3 + put_ bh ux + + get bh = do + h <- getByte bh + case h of + 0 -> return $ Used + 1 -> return $ UHead + 2 -> do c <- get bh + u <- get bh + return (UCall c u) + _ -> do ux <- get bh + return (UProd ux) + +instance (Binary s, Binary u) => Binary (JointDmd s u) where + put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y + get bh = do + x <- get bh + y <- get bh + return $ JD { sd = x, ud = y } + +instance Binary StrictSig where + put_ bh (StrictSig aa) = do + put_ bh aa + get bh = do + aa <- get bh + return (StrictSig aa) + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + put_ bh (DmdType _ ds dr) + = do put_ bh ds + put_ bh dr + get bh + = do ds <- get bh + dr <- get bh + return (DmdType emptyDmdEnv ds dr) + +instance Binary Divergence where + put_ bh Dunno = putByte bh 0 + put_ bh ExnOrDiv = putByte bh 1 + put_ bh Diverges = putByte bh 2 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return Dunno + 1 -> return ExnOrDiv + _ -> return Diverges } diff --git a/GHC/Types/FieldLabel.hs b/GHC/Types/FieldLabel.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/FieldLabel.hs @@ -0,0 +1,132 @@ +{- +% +% (c) Adam Gundry 2013-2015 +% + +This module defines the representation of FieldLabels as stored in +TyCons. As well as a selector name, these have some extra structure +to support the DuplicateRecordFields extension. + +In the normal case (with NoDuplicateRecordFields), a datatype like + + data T = MkT { foo :: Int } + +has + + FieldLabel { flLabel = "foo" + , flIsOverloaded = False + , flSelector = foo }. + +In particular, the Name of the selector has the same string +representation as the label. If DuplicateRecordFields +is enabled, however, the same declaration instead gives + + FieldLabel { flLabel = "foo" + , flIsOverloaded = True + , flSelector = $sel:foo:MkT }. + +Now the name of the selector ($sel:foo:MkT) does not match the label of +the field (foo). We must be careful not to show the selector name to +the user! The point of mangling the selector name is to allow a +module to define the same field label in different datatypes: + + data T = MkT { foo :: Int } + data U = MkU { foo :: Bool } + +Now there will be two FieldLabel values for 'foo', one in T and one in +U. They share the same label (FieldLabelString), but the selector +functions differ. + +See also Note [Representing fields in AvailInfo] in GHC.Types.Avail. + +Note [Why selector names include data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As explained above, a selector name includes the name of the first +data constructor in the type, so that the same label can appear +multiple times in the same module. (This is irrespective of whether +the first constructor has that field, for simplicity.) + +We use a data constructor name, rather than the type constructor name, +because data family instances do not have a representation type +constructor name generated until relatively late in the typechecking +process. + +Of course, datatypes with no constructors cannot have any fields. + +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Types.FieldLabel + ( FieldLabelString + , FieldLabelEnv + , FieldLbl(..) + , FieldLabel + , mkFieldLabelOccs + ) +where + +import GHC.Prelude + +import GHC.Types.Name.Occurrence +import GHC.Types.Name + +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Utils.Outputable +import GHC.Utils.Binary + +import Data.Data + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +type FieldLabelString = FastString + +-- | A map from labels to all the auxiliary information +type FieldLabelEnv = DFastStringEnv FieldLabel + + +type FieldLabel = FieldLbl Name + +-- | Fields in an algebraic record type +data FieldLbl a = FieldLabel { + flLabel :: FieldLabelString, -- ^ User-visible label of the field + flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on + -- in the defining module for this datatype? + flSelector :: a -- ^ Record selector function + } + deriving (Eq, Functor, Foldable, Traversable) +deriving instance Data a => Data (FieldLbl a) + +instance Outputable a => Outputable (FieldLbl a) where + ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) + +instance Binary a => Binary (FieldLbl a) where + put_ bh (FieldLabel aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + ab <- get bh + ac <- get bh + ad <- get bh + return (FieldLabel ab ac ad) + + +-- | Record selector OccNames are built from the underlying field name +-- and the name of the first data constructor of the type, to support +-- duplicate record field names. +-- See Note [Why selector names include data constructors]. +mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName +mkFieldLabelOccs lbl dc is_overloaded + = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = sel_occ } + where + str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc + sel_occ | is_overloaded = mkRecFldSelOcc str + | otherwise = mkVarOccFS lbl diff --git a/GHC/Types/ForeignCall.hs b/GHC/Types/ForeignCall.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/ForeignCall.hs @@ -0,0 +1,357 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Foreign]{Foreign calls} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.ForeignCall ( + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, + + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + Header(..), CType(..), + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Unit.Module +import GHC.Types.Basic ( SourceText, pprWithSourceText ) + +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsubsection{Data types} +* * +************************************************************************ +-} + +newtype ForeignCall = CCall CCallSpec + deriving Eq + +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + +data Safety + = PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call. Additionally, in the threaded + -- RTS we arrange for the external call to be executed + -- by a separate OS thread, i.e., _concurrently_ to the + -- execution of other Haskell threads. + + | PlayInterruptible -- ^ Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. + + | PlayRisky -- ^ None of the above can happen; the call will return + -- without interacting with the runtime system at all. + -- Specifically: + -- + -- * No GC + -- * No call backs + -- * No blocking + -- * No precise exceptions + -- + deriving ( Eq, Show, Data ) + -- Show used just for Show Lex.Token, I think + +instance Outputable Safety where + ppr PlaySafe = text "safe" + ppr PlayInterruptible = text "interruptible" + ppr PlayRisky = text "unsafe" + +playSafe :: Safety -> Bool +playSafe PlaySafe = True +playSafe PlayInterruptible = True +playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False + +{- +************************************************************************ +* * +\subsubsection{Calling C} +* * +************************************************************************ +-} + +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + SourceText -- of the CLabelString. + -- See note [Pragma source text] in GHC.Types.Basic + CLabelString -- C Name of exported function + CCallConv + deriving Data + +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + deriving( Eq ) + +-- The call target: + +-- | How to call a particular function in C-land. +data CCallTarget + -- An "unboxed" ccall# to named function in a particular package. + = StaticTarget + SourceText -- of the CLabelString. + -- See note [Pragma source text] in GHC.Types.Basic + CLabelString -- C-land name of label. + + (Maybe Unit) -- What package the function is in. + -- If Nothing, then it's taken to be in the current package. + -- Note: This information is only used for PrimCalls on Windows. + -- See CLabel.labelDynamic and CoreToStg.coreToStgApp + -- for the difference in representation between PrimCalls + -- and ForeignCalls. If the CCallTarget is representing + -- a regular ForeignCall then it's safe to set this to Nothing. + + -- The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports + | DynamicTarget + + deriving( Eq, Data ) + +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget _ = False + +{- +Stuff to do with calling convention: + +ccall: Caller allocates parameters, *and* deallocates them. + +stdcall: Caller allocates parameters, callee deallocates. + Function name has @N after it, where N is number of arg bytes + e.g. _Foo@8. This convention is x86 (win32) specific. + +See: http://www.programmersheaven.com/2/Calling-conventions +-} + +-- any changes here should be replicated in the CallConv type in template haskell +data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv + deriving (Eq, Data) + +instance Outputable CCallConv where + ppr StdCallConv = text "stdcall" + ppr CCallConv = text "ccall" + ppr CApiConv = text "capi" + ppr PrimCallConv = text "prim" + ppr JavaScriptCallConv = text "javascript" + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +ccallConvToInt :: CCallConv -> Int +ccallConvToInt StdCallConv = 0 +ccallConvToInt CCallConv = 1 +ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" +ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" +ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" + +{- +Generate the gcc attribute corresponding to the given +calling convention (used by PprAbsC): +-} + +ccallConvAttribute :: CCallConv -> SDoc +ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" +ccallConvAttribute CCallConv = empty +ccallConvAttribute CApiConv = empty +ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" +ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" + +type CLabelString = FastString -- A C label, completely unencoded + +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (unpackFS lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate + +-- Printing into C files: + +instance Outputable CExportSpec where + ppr (CExportStatic _ str _) = pprCLabelString str + +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety) + = hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ] + where + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_safe" + | otherwise = text "_unsafe" + + ppr_fun (StaticTarget st lbl mPkgId isFun) + = text (if isFun then "__ffi_static_ccall" + else "__ffi_static_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <> text ":" + <> ppr lbl + <+> (pprWithSourceText st empty) + + ppr_fun DynamicTarget + = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\"" + +-- The filename for a C header file +-- Note [Pragma source text] in GHC.Types.Basic +data Header = Header SourceText FastString + deriving (Eq, Data) + +instance Outputable Header where + ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) + +-- | A C type, used in CAPI FFI calls +-- +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{-\# CTYPE'@, +-- 'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal', +-- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@, + +-- For details on above see note [Api annotations] in "GHC.Parser.Annotation" +data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.Basic + (Maybe Header) -- header to include for this type + (SourceText,FastString) -- the type itself + deriving (Eq, Data) + +instance Outputable CType where + ppr (CType stp mh (stct,ct)) + = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc + <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h + +{- +************************************************************************ +* * +\subsubsection{Misc} +* * +************************************************************************ +-} + +instance Binary ForeignCall where + put_ bh (CCall aa) = put_ bh aa + get bh = do aa <- get bh; return (CCall aa) + +instance Binary Safety where + put_ bh PlaySafe = do + putByte bh 0 + put_ bh PlayInterruptible = do + putByte bh 1 + put_ bh PlayRisky = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return PlaySafe + 1 -> do return PlayInterruptible + _ -> do return PlayRisky + +instance Binary CExportSpec where + put_ bh (CExportStatic ss aa ab) = do + put_ bh ss + put_ bh aa + put_ bh ab + get bh = do + ss <- get bh + aa <- get bh + ab <- get bh + return (CExportStatic ss aa ab) + +instance Binary CCallSpec where + put_ bh (CCallSpec aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (CCallSpec aa ab ac) + +instance Binary CCallTarget where + put_ bh (StaticTarget ss aa ab ac) = do + putByte bh 0 + put_ bh ss + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh DynamicTarget = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + aa <- get bh + ab <- get bh + ac <- get bh + return (StaticTarget ss aa ab ac) + _ -> do return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = do + putByte bh 0 + put_ bh StdCallConv = do + putByte bh 1 + put_ bh PrimCallConv = do + putByte bh 2 + put_ bh CApiConv = do + putByte bh 3 + put_ bh JavaScriptCallConv = do + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> do return CCallConv + 1 -> do return StdCallConv + 2 -> do return PrimCallConv + 3 -> do return CApiConv + _ -> do return JavaScriptCallConv + +instance Binary CType where + put_ bh (CType s mh fs) = do put_ bh s + put_ bh mh + put_ bh fs + get bh = do s <- get bh + mh <- get bh + fs <- get bh + return (CType s mh fs) + +instance Binary Header where + put_ bh (Header s h) = put_ bh s >> put_ bh h + get bh = do s <- get bh + h <- get bh + return (Header s h) diff --git a/GHC/Types/Id.hs b/GHC/Types/Id.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Id.hs @@ -0,0 +1,1002 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Id]{@Ids@: Value and constructor identifiers} +-} + +{-# LANGUAGE CPP #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id' represents names that not only have a 'GHC.Types.Name.Name' but also a +-- 'GHC.Core.TyCo.Rep.Type' and some additional details (a 'GHC.Types.Id.Info.IdInfo' and +-- one of LocalIdDetails or GlobalIdDetails) that are added, +-- modified and inspected by various compiler passes. These 'GHC.Types.Var.Var' names +-- may either be global or local, see "GHC.Types.Var#globalvslocal" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" + +module GHC.Types.Id ( + -- * The main types + Var, Id, isId, + + -- * In and Out variants + InVar, InId, + OutVar, OutId, + + -- ** Simple construction + mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, + mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, + mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, + mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, + mkUserLocal, mkUserLocalOrCoVar, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkScaledTemplateLocal, + mkWorkerId, + + -- ** Taking an Id apart + idName, idType, idMult, idScaledType, idUnique, idInfo, idDetails, + recordSelectorTyCon, + + -- ** Modifying an Id + setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult, + updateIdTypeButNotMult, updateIdTypeAndMult, updateIdTypeAndMultM, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapIdUsedOnceInfo, zapIdTailCallInfo, + zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, + transferPolyIdInfo, scaleIdBy, scaleVarBy, + + -- ** Predicates on Ids + isImplicitId, isDeadBinder, + isStrictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isPatSynRecordSelector, + isDataConRecordSelector, + isClassOpId_maybe, isDFunId, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, + isDataConWrapId, isDataConWrapId_maybe, + isDataConId_maybe, + idDataCon, + isConLikeId, isDeadEndId, idIsFrom, + hasNoBinding, + + -- ** Join variables + JoinId, isJoinId, isJoinId_maybe, idJoinArity, + asJoinId, asJoinId_maybe, zapJoinId, + + -- ** Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, + idInlineActivation, setInlineActivation, idRuleMatchInfo, + + -- ** One-shot lambdas + isOneShotBndr, isProbablyOneShotLambda, + setOneShotLambda, clearOneShotLambda, + updOneShotInfo, setIdOneShotInfo, + isStateHackType, stateHackOneShot, typeOneShot, + + -- ** Reading 'IdInfo' fields + idArity, + idCallArity, idFunRepArity, + idUnfolding, realIdUnfolding, + idSpecialisation, idCoreRules, idHasRules, + idCafInfo, idLFInfo_maybe, + idOneShotInfo, idStateHackOneShotInfo, + idOccInfo, + isNeverLevPolyId, + + -- ** Writing 'IdInfo' fields + setIdUnfolding, setCaseBndrEvald, + setIdArity, + setIdCallArity, + + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, zapIdOccInfo, + setIdLFInfo, + + setIdDemandInfo, + setIdStrictness, + setIdCprInfo, + + idDemandInfo, + idStrictness, + idCprInfo, + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, + isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) + +import GHC.Types.Id.Info +import GHC.Types.Basic + +-- Imported and re-exported +import GHC.Types.Var( Id, CoVar, JoinId, + InId, InVar, + OutId, OutVar, + idInfo, idDetails, setIdDetails, globaliseId, + isId, isLocalId, isGlobalId, isExportedId, + setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM) +import qualified GHC.Types.Var as Var + +import GHC.Core.Type +import GHC.Types.RepType +import GHC.Builtin.Types.Prim +import GHC.Core.DataCon +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Core.Class +import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) +import GHC.Types.ForeignCall +import GHC.Data.Maybe +import GHC.Types.SrcLoc +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Core.Multiplicity + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setIdUnfolding`, + `setIdArity`, + `setIdCallArity`, + `setIdOccInfo`, + `setIdOneShotInfo`, + + `setIdSpecialisation`, + `setInlinePragma`, + `setInlineActivation`, + `idCafInfo`, + + `setIdDemandInfo`, + `setIdStrictness`, + `setIdCprInfo`, + + `asJoinId`, + `asJoinId_maybe` + +{- +************************************************************************ +* * +\subsection{Basic Id manipulation} +* * +************************************************************************ +-} + +idName :: Id -> Name +idName = Var.varName + +idUnique :: Id -> Unique +idUnique = Var.varUnique + +idType :: Id -> Kind +idType = Var.varType + +idMult :: Id -> Mult +idMult = Var.varMult + +idScaledType :: Id -> Scaled Type +idScaledType id = Scaled (idMult id) (idType id) + +scaleIdBy :: Mult -> Id -> Id +scaleIdBy m id = setIdMult id (m `mkMultMul` idMult id) + +-- | Like 'scaleIdBy', but skips non-Ids. Useful for scaling +-- a mixed list of ids and tyvars. +scaleVarBy :: Mult -> Var -> Var +scaleVarBy m id + | isId id = scaleIdBy m id + | otherwise = id + +setIdName :: Id -> Name -> Id +setIdName = Var.setVarName + +setIdUnique :: Id -> Unique -> Id +setIdUnique = Var.setVarUnique + +-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and +-- reduce space usage +setIdType :: Id -> Type -> Id +setIdType id ty = seqType ty `seq` Var.setVarType id ty + +setIdExported :: Id -> Id +setIdExported = Var.setIdExported + +setIdNotExported :: Id -> Id +setIdNotExported = Var.setIdNotExported + +localiseId :: Id -> Id +-- Make an Id with the same unique and type as the +-- incoming Id, but with an *Internal* Name and *LocalId* flavour +localiseId id + | ASSERT( isId id ) isLocalId id && isInternalName name + = id + | otherwise + = Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id) + where + name = idName id + +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo = Var.lazySetIdInfo + +setIdInfo :: Id -> IdInfo -> Id +setIdInfo id info = info `seq` (lazySetIdInfo id info) + -- Try to avoid space leaks by seq'ing + +modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) + +-- maybeModifyIdInfo tries to avoid unnecessary thrashing +maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id +maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info +maybeModifyIdInfo Nothing id = id + +{- +************************************************************************ +* * +\subsection{Simple Id construction} +* * +************************************************************************ + +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. + +Note [Free type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we cached the free type variables of the type of an Id +at the root of the type in a TyNote. The idea was to avoid repeating +the free-type-variable calculation. But it turned out to slow down +the compiler overall. I don't quite know why; perhaps finding free +type variables of an Id isn't all that common whereas applying a +substitution (which changes the free type variables) is more common. +Anyway, we removed it in March 2008. +-} + +-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var.Var#globalvslocal" +mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId = Var.mkGlobalVar + +-- | Make a global 'Id' without any extra information at all +mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo + +-- | Make a global 'Id' with no global information but some generic 'IdInfo' +mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo = mkGlobalId VanillaId + + +-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" +mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id +mkLocalId name w ty = ASSERT( not (isCoVarType ty) ) + mkLocalIdWithInfo name w ty vanillaIdInfo + +-- | Make a local CoVar +mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar name ty + = ASSERT( isCoVarType ty ) + Var.mkLocalVar CoVarId name Many ty vanillaIdInfo + +-- | Like 'mkLocalId', but checks the type to see if it should make a covar +mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id +mkLocalIdOrCoVar name w ty + -- We should ASSERT(eqType w Many) in the isCoVarType case. + -- However, currently this assertion does not hold. + -- In tests with -fdefer-type-errors, such as T14584a, + -- we create a linear 'case' where the scrutinee is a coercion + -- (see castBottomExpr). This problem is covered by #17291. + | isCoVarType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name w ty + + -- proper ids only; no covars! +mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id +mkLocalIdWithInfo name w ty info = ASSERT( not (isCoVarType ty) ) + Var.mkLocalVar VanillaId name w ty info + -- Note [Free type variables] + +-- | Create a local 'Id' that is marked as exported. +-- This prevents things attached to it from being removed as dead code. +-- See Note [Exported LocalIds] +mkExportedLocalId :: IdDetails -> Name -> Type -> Id +mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo + -- Note [Free type variables] + +mkExportedVanillaId :: Name -> Type -> Id +mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo + -- Note [Free type variables] + + +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- that are created by the compiler out of thin air +mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id +mkSysLocal fs uniq w ty = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkSystemVarName uniq fs) w ty + +-- | Like 'mkSysLocal', but checks to see if we have a covar type +mkSysLocalOrCoVar :: FastString -> Unique -> Mult -> Type -> Id +mkSysLocalOrCoVar fs uniq w ty + = mkLocalIdOrCoVar (mkSystemVarName uniq fs) w ty + +mkSysLocalM :: MonadUnique m => FastString -> Mult -> Type -> m Id +mkSysLocalM fs w ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq w ty)) + +mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Mult -> Type -> m Id +mkSysLocalOrCoVarM fs w ty + = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq w ty)) + +-- | Create a user local 'Id'. These are local 'Id's (see "GHC.Types.Var#globalvslocal") with a name and location that the user might recognize +mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id +mkUserLocal occ uniq w ty loc = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkInternalName uniq occ loc) w ty + +-- | Like 'mkUserLocal', but checks if we have a coercion type +mkUserLocalOrCoVar :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id +mkUserLocalOrCoVar occ uniq w ty loc + = mkLocalIdOrCoVar (mkInternalName uniq occ loc) w ty + +{- +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. +-} + +-- | Workers get local names. "CoreTidy" will externalise these if necessary +mkWorkerId :: Unique -> Id -> Type -> Id +mkWorkerId uniq unwrkr ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) Many ty + +-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings +mkTemplateLocal :: Int -> Type -> Id +mkTemplateLocal i ty = mkScaledTemplateLocal i (unrestricted ty) + +mkScaledTemplateLocal :: Int -> Scaled Type -> Id +mkScaledTemplateLocal i (Scaled w ty) = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) w ty + -- "OrCoVar" since this is used in a superclass selector, + -- and "~" and "~~" have coercion "superclasses". + +-- | Create a template local for a series of types +mkTemplateLocals :: [Type] -> [Id] +mkTemplateLocals = mkTemplateLocalsNum 1 + +-- | Create a template local for a series of type, but start from a specified template local +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys + +{- Note [Exported LocalIds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use mkExportedLocalId for things like + - Dictionary functions (DFunId) + - Wrapper and matcher Ids for pattern synonyms + - Default methods for classes + - Pattern-synonym matcher and builder Ids + - etc + +They marked as "exported" in the sense that they should be kept alive +even if apparently unused in other bindings, and not dropped as dead +code by the occurrence analyser. (But "exported" here does not mean +"brought into lexical scope by an import declaration". Indeed these +things are always internal Ids that the user never sees.) + +It's very important that they are *LocalIds*, not GlobalIds, for lots +of reasons: + + * We want to treat them as free variables for the purpose of + dependency analysis (e.g. GHC.Core.FVs.exprFreeVars). + + * Look them up in the current substitution when we come across + occurrences of them (in Subst.lookupIdSubst). Lacking this we + can get an out-of-date unfolding, which can in turn make the + simplifier go into an infinite loop (#9857) + + * Ensure that for dfuns that the specialiser does not float dict uses + above their defns, which would prevent good simplifications happening. + + * The strictness analyser treats a occurrence of a GlobalId as + imported and assumes it contains strictness in its IdInfo, which + isn't true if the thing is bound in the same module as the + occurrence. + +In CoreTidy we must make all these LocalIds into GlobalIds, so that in +importing modules (in --make mode) we treat them as properly global. +That is what is happening in, say tidy_insts in GHC.Iface.Tidy. + +************************************************************************ +* * +\subsection{Special Ids} +* * +************************************************************************ +-} + +-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. +recordSelectorTyCon :: Id -> RecSelParent +recordSelectorTyCon id + = case Var.idDetails id of + RecSelId { sel_tycon = parent } -> parent + _ -> panic "recordSelectorTyCon" + + +isRecordSelector :: Id -> Bool +isNaughtyRecordSelector :: Id -> Bool +isPatSynRecordSelector :: Id -> Bool +isDataConRecordSelector :: Id -> Bool +isPrimOpId :: Id -> Bool +isFCallId :: Id -> Bool +isDataConWorkId :: Id -> Bool +isDataConWrapId :: Id -> Bool +isDFunId :: Id -> Bool + +isClassOpId_maybe :: Id -> Maybe Class +isPrimOpId_maybe :: Id -> Maybe PrimOp +isFCallId_maybe :: Id -> Maybe ForeignCall +isDataConWorkId_maybe :: Id -> Maybe DataCon +isDataConWrapId_maybe :: Id -> Maybe DataCon + +isRecordSelector id = case Var.idDetails id of + RecSelId {} -> True + _ -> False + +isDataConRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelData _} -> True + _ -> False + +isPatSynRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelPatSyn _} -> True + _ -> False + +isNaughtyRecordSelector id = case Var.idDetails id of + RecSelId { sel_naughty = n } -> n + _ -> False + +isClassOpId_maybe id = case Var.idDetails id of + ClassOpId cls -> Just cls + _other -> Nothing + +isPrimOpId id = case Var.idDetails id of + PrimOpId _ -> True + _ -> False + +isDFunId id = case Var.idDetails id of + DFunId {} -> True + _ -> False + +isPrimOpId_maybe id = case Var.idDetails id of + PrimOpId op -> Just op + _ -> Nothing + +isFCallId id = case Var.idDetails id of + FCallId _ -> True + _ -> False + +isFCallId_maybe id = case Var.idDetails id of + FCallId call -> Just call + _ -> Nothing + +isDataConWorkId id = case Var.idDetails id of + DataConWorkId _ -> True + _ -> False + +isDataConWorkId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + _ -> Nothing + +isDataConWrapId id = case Var.idDetails id of + DataConWrapId _ -> True + _ -> False + +isDataConWrapId_maybe id = case Var.idDetails id of + DataConWrapId con -> Just con + _ -> Nothing + +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + _ -> Nothing + +isJoinId :: Var -> Bool +-- It is convenient in GHC.Core.Opt.SetLevels.lvlMFE to apply isJoinId +-- to the free vars of an expression, so it's convenient +-- if it returns False for type variables +isJoinId id + | isId id = case Var.idDetails id of + JoinId {} -> True + _ -> False + | otherwise = False + +isJoinId_maybe :: Var -> Maybe JoinArity +isJoinId_maybe id + | isId id = ASSERT2( isId id, ppr id ) + case Var.idDetails id of + JoinId arity -> Just arity + _ -> Nothing + | otherwise = Nothing + +idDataCon :: Id -> DataCon +-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. +-- +-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker +idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) + +hasNoBinding :: Id -> Bool +-- ^ Returns @True@ of an 'Id' which may not have a +-- binding, even though it is defined in this module. + +-- Data constructor workers used to be things of this kind, but they aren't any +-- more. Instead, we inject a binding for them at the CorePrep stage. The +-- exception to this is unboxed tuples and sums datacons, which definitely have +-- no binding +hasNoBinding id = case Var.idDetails id of + PrimOpId _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc + _ -> isCompulsoryUnfolding (idUnfolding id) + -- See Note [Levity-polymorphic Ids] + +isImplicitId :: Id -> Bool +-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other +-- declarations, so we don't need to put its signature in an interface +-- file, even if it's mentioned in some other interface unfolding. +isImplicitId id + = case Var.idDetails id of + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True + -- These are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + _ -> False + +idIsFrom :: Module -> Id -> Bool +idIsFrom mod id = nameIsLocalOrFrom mod (idName id) + +{- Note [Levity-polymorphic Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some levity-polymorphic Ids must be applied and inlined, not left +un-saturated. Example: + unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b + +This has a compulsory unfolding because we can't lambda-bind those +arguments. But the compulsory unfolding may leave levity-polymorphic +lambdas if it is not applied to enough arguments; e.g. (#14561) + bad :: forall (a :: TYPE r). a -> a + bad = unsafeCoerce# + +The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop. +And we want that magic to apply to levity-polymorphic compulsory-inline things. +The easiest way to do this is for hasNoBinding to return True of all things +that have compulsory unfolding. Some Ids with a compulsory unfolding also +have a binding, but it does not harm to say they don't here, and its a very +simple way to fix #14561. +-} + +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = False -- TyVars count as not dead + +{- +************************************************************************ +* * + Join variables +* * +************************************************************************ +-} + +idJoinArity :: JoinId -> JoinArity +idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) + +asJoinId :: Id -> JoinArity -> JoinId +asJoinId id arity = WARN(not (isLocalId id), + text "global id being marked as join var:" <+> ppr id) + WARN(not (is_vanilla_or_join id), + ppr id <+> pprIdDetails (idDetails id)) + id `setIdDetails` JoinId arity + where + is_vanilla_or_join id = case Var.idDetails id of + VanillaId -> True + JoinId {} -> True + _ -> False + +zapJoinId :: Id -> Id +-- May be a regular id already +zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) + -- Core Lint may complain if still marked + -- as AlwaysTailCalled + | otherwise = jid + +asJoinId_maybe :: Id -> Maybe JoinArity -> Id +asJoinId_maybe id (Just arity) = asJoinId id arity +asJoinId_maybe id Nothing = zapJoinId id + +{- +************************************************************************ +* * +\subsection{IdInfo stuff} +* * +************************************************************************ +-} + + --------------------------------- + -- ARITY +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) + +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id + +idCallArity :: Id -> Arity +idCallArity id = callArityInfo (idInfo id) + +setIdCallArity :: Id -> Arity -> Id +setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id + +idFunRepArity :: Id -> RepArity +idFunRepArity x = countFunRepArgs (idArity x) (idType x) + +-- | Returns true if an application to n args diverges or throws an exception +-- See Note [Dead ends] in "GHC.Types.Demand". +isDeadEndId :: Var -> Bool +isDeadEndId v + | isId v = isDeadEndSig (idStrictness v) + | otherwise = False + +-- | Accesses the 'Id''s 'strictnessInfo'. +idStrictness :: Id -> StrictSig +idStrictness id = strictnessInfo (idInfo id) + +setIdStrictness :: Id -> StrictSig -> Id +setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id + +idCprInfo :: Id -> CprSig +idCprInfo id = cprInfo (idInfo id) + +setIdCprInfo :: Id -> CprSig -> Id +setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id + +zapIdStrictness :: Id -> Id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id + +-- | This predicate says whether the 'Id' has a strict demand placed on it or +-- has a type such that it can always be evaluated strictly (i.e an +-- unlifted type, as of GHC 7.6). We need to +-- check separately whether the 'Id' has a so-called \"strict type\" because if +-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict +-- type, we still want @isStrictId id@ to be @True@. +isStrictId :: Id -> Bool +isStrictId id + = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) + not (isJoinId id) && ( + (isStrictType (idType id)) || + -- Take the best of both strictnesses - old and new + (isStrictDmd (idDemandInfo id)) + ) + + --------------------------------- + -- UNFOLDING +idUnfolding :: Id -> Unfolding +-- Do not expose the unfolding of a loop breaker! +idUnfolding id + | isStrongLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info + where + info = idInfo id + +realIdUnfolding :: Id -> Unfolding +-- Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = unfoldingInfo (idInfo id) + +setIdUnfolding :: Id -> Unfolding -> Id +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id + +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) + +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id + +setCaseBndrEvald :: StrictnessMark -> Id -> Id +-- Used for variables bound by a case expressions, both the case-binder +-- itself, and any pattern-bound variables that are argument of a +-- strict constructor. It just marks the variable as already-evaluated, +-- so that (for example) a subsequent 'seq' can be dropped +setCaseBndrEvald str id + | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding + | otherwise = id + + --------------------------------- + -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in GHC.Types.Id.Info + +idSpecialisation :: Id -> RuleInfo +idSpecialisation id = ruleInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = ruleInfoRules (idSpecialisation id) + +idHasRules :: Id -> Bool +idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) + +setIdSpecialisation :: Id -> RuleInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id + + --------------------------------- + -- CAF INFO +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + + --------------------------------- + -- Lambda form info + +idLFInfo_maybe :: Id -> Maybe LambdaFormInfo +idLFInfo_maybe = lfInfo . idInfo + +setIdLFInfo :: Id -> LambdaFormInfo -> Id +setIdLFInfo id lf = modifyIdInfo (`setLFInfo` lf) id + + --------------------------------- + -- Occurrence INFO +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id + +zapIdOccInfo :: Id -> Id +zapIdOccInfo b = b `setIdOccInfo` noOccInfo + +{- + --------------------------------- + -- INLINING +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. +-} + +idInlinePragma :: Id -> InlinePragma +idInlinePragma id = inlinePragInfo (idInfo id) + +setInlinePragma :: Id -> InlinePragma -> Id +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id + +modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id + +idInlineActivation :: Id -> Activation +idInlineActivation id = inlinePragmaActivation (idInlinePragma id) + +setInlineActivation :: Id -> Activation -> Id +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) + +idRuleMatchInfo :: Id -> RuleMatchInfo +idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) + +isConLikeId :: Id -> Bool +isConLikeId id = isConLike (idRuleMatchInfo id) + +{- + --------------------------------- + -- ONE-SHOT LAMBDAS +-} + +idOneShotInfo :: Id -> OneShotInfo +idOneShotInfo id = oneShotInfo (idInfo id) + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = stateHackOneShot + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +-- | Should we apply the state hack to values of this 'Type'? +stateHackOneShot :: OneShotInfo +stateHackOneShot = OneShotLam + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = stateHackOneShot + | otherwise = NoOneShotInfo + +isStateHackType :: Type -> Bool +isStateHackType ty + | hasNoStateHack unsafeGlobalDynFlags + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + +isProbablyOneShotLambda :: Id -> Bool +isProbablyOneShotLambda id = case idStateHackOneShotInfo id of + OneShotLam -> True + NoOneShotInfo -> False + +setOneShotLambda :: Id -> Id +setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id + +setIdOneShotInfo :: Id -> OneShotInfo -> Id +setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id + +updOneShotInfo :: Id -> OneShotInfo -> Id +-- Combine the info in the Id with new info +updOneShotInfo id one_shot + | do_upd = setIdOneShotInfo id one_shot + | otherwise = id + where + do_upd = case (idOneShotInfo id, one_shot) of + (NoOneShotInfo, _) -> True + (OneShotLam, _) -> False + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes + +zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id + +zapLamIdInfo :: Id -> Id +zapLamIdInfo = zapInfo zapLamInfo + +zapFragileIdInfo :: Id -> Id +zapFragileIdInfo = zapInfo zapFragileInfo + +zapIdDemandInfo :: Id -> Id +zapIdDemandInfo = zapInfo zapDemandInfo + +zapIdUsageInfo :: Id -> Id +zapIdUsageInfo = zapInfo zapUsageInfo + +zapIdUsageEnvInfo :: Id -> Id +zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo + +zapIdUsedOnceInfo :: Id -> Id +zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo + +zapIdTailCallInfo :: Id -> Id +zapIdTailCallInfo = zapInfo zapTailCallInfo + +zapStableUnfolding :: Id -> Id +zapStableUnfolding id + | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding + | otherwise = id + +{- +Note [transferPolyIdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This transfer is used in three places: + FloatOut (long-distance let-floating) + GHC.Core.Opt.Simplify.Utils.abstractFloats (short-distance let-floating) + StgLiftLams (selectively lambda-lift local functions to top-level) + +Consider the short-distance let-floating: + + f = /\a. let g = rhs in ... + +Then if we float thus + + g' = /\a. rhs + f = /\a. ...[g' a/g].... + +we *do not* want to lose g's + * strictness information + * arity + * inline pragma (though that is bit more debatable) + * occurrence info + +Mostly this is just an optimisation, but it's *vital* to +transfer the occurrence info. Consider + + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } + +where the '*' means 'LoopBreaker'. Then if we float we must get + + Rec { g'* = /\a. ...(g' a)... } + NonRec { f = /\a. ...[g' a/g]....} + +where g' is also marked as LoopBreaker. If not, terrible things +can happen if we re-simplify the binding (and the Simplifier does +sometimes simplify a term twice); see #4345. + +It's not so simple to retain + * worker info + * rules +so we simply discard those. Sooner or later this may bite us. + +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. + f = \x. e +--> + g' = \y. \x. e + + substitute (g' y) for g +Notice that g' has an arity one more than the original g +-} + +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id +transferPolyIdInfo old_id abstract_wrt new_id + = modifyIdInfo transfer new_id + where + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders + + old_info = idInfo old_id + old_arity = arityInfo old_info + old_inline_prag = inlinePragInfo old_info + old_occ_info = occInfo old_info + new_arity = old_arity + arity_increase + new_occ_info = zapOccTailCallInfo old_occ_info + + old_strictness = strictnessInfo old_info + new_strictness = prependArgsStrictSig arity_increase old_strictness + old_cpr = cprInfo old_info + + transfer new_info = new_info `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag + `setOccInfo` new_occ_info + `setStrictnessInfo` new_strictness + `setCprInfo` old_cpr + +isNeverLevPolyId :: Id -> Bool +isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/GHC/Types/Id/Info.hs b/GHC/Types/Id/Info.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Info.hs @@ -0,0 +1,756 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BinaryLiterals #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Types.Id.Info ( + -- * The IdDetails type + IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, + JoinArity, isJoinIdDetails_maybe, + RecSelParent(..), + + -- * The IdInfo type + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + + -- ** The OneShotInfo type + OneShotInfo(..), + oneShotInfo, noOneShotInfo, hasNoOneShotInfo, + setOneShotInfo, + + -- ** Zapping various forms of Info + zapLamInfo, zapFragileInfo, + zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + zapTailCallInfo, zapCallArityInfo, zapUnfolding, + + -- ** The ArityInfo type + ArityInfo, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + callArityInfo, setCallArityInfo, + + -- ** Demand and strictness Info + strictnessInfo, setStrictnessInfo, + cprInfo, setCprInfo, + demandInfo, setDemandInfo, pprStrictness, + + -- ** Unfolding Info + unfoldingInfo, setUnfoldingInfo, + + -- ** The InlinePragInfo type + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, + + -- ** The OccInfo type + OccInfo(..), + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, + occInfo, setOccInfo, + + InsideLam(..), BranchCount, + + TailCallInfo(..), + tailCallInfo, isAlwaysTailCalled, + + -- ** The RuleInfo type + RuleInfo(..), + emptyRuleInfo, + isEmptyRuleInfo, ruleInfoFreeVars, + ruleInfoRules, setRuleInfoHead, + ruleInfo, setRuleInfo, + + -- ** The CAFInfo type + CafInfo(..), + ppCafInfo, mayHaveCafRefs, + cafInfo, setCafInfo, + + -- ** The LambdaFormInfo type + LambdaFormInfo(..), + lfInfo, setLFInfo, + + -- ** Tick-box Info + TickBoxOp(..), TickBoxId, + + -- ** Levity info + LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, + isNeverLevPolyIdInfo + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Core hiding( hasCoreUnfolding ) +import GHC.Core( hasCoreUnfolding ) + +import GHC.Core.Class +import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.PatSyn +import GHC.Core.Type +import GHC.Types.ForeignCall +import GHC.Utils.Outputable +import GHC.Unit.Module +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Utils.Misc + +import Data.Word +import Data.Bits + +import GHC.StgToCmm.Types (LambdaFormInfo (..)) + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setRuleInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setOneShotInfo`, + `setOccInfo`, + `setCafInfo`, + `setStrictnessInfo`, + `setCprInfo`, + `setDemandInfo`, + `setNeverLevPoly`, + `setLevityInfoWithType` + +{- +************************************************************************ +* * + IdDetails +* * +************************************************************************ +-} + +-- | Identifier Details +-- +-- The 'IdDetails' of an 'Id' give stable, and necessary, +-- information about the Id. +data IdDetails + = VanillaId + + -- | The 'Id' for a record selector + | RecSelId + { sel_tycon :: RecSelParent + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + -- data T = forall a. MkT { x :: a } + } -- See Note [Naughty record selectors] in GHC.Tc.TyCl + + | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ + | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ + + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] + | ClassOpId Class -- ^ The 'Id' is a superclass selector, + -- or class operation of a class + + | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. + -- Type will be simple: no type families, newtypes, etc + + | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) + + | DFunId Bool -- ^ A dictionary function. + -- Bool = True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary + + | CoVarId -- ^ A coercion variable + -- This only covers /un-lifted/ coercions, of type + -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants + | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments + -- Note [Join points] in "GHC.Core" + +-- | Recursive Selector Parent +data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq + -- Either `TyCon` or `PatSyn` depending + -- on the origin of the record selector. + -- For a data type family, this is the + -- /instance/ 'TyCon' not the family 'TyCon' + +instance Outputable RecSelParent where + ppr p = case p of + RecSelData ty_con -> ppr ty_con + RecSelPatSyn ps -> ppr ps + +-- | Just a synonym for 'CoVarId'. Written separately so it can be +-- exported in the hs-boot file. +coVarDetails :: IdDetails +coVarDetails = CoVarId + +-- | Check if an 'IdDetails' says 'CoVarId'. +isCoVarDetails :: IdDetails -> Bool +isCoVarDetails CoVarId = True +isCoVarDetails _ = False + +isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity +isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity +isJoinIdDetails_maybe _ = Nothing + +instance Outputable IdDetails where + ppr = pprIdDetails + +pprIdDetails :: IdDetails -> SDoc +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = text "DataCon" + pp (DataConWrapId _) = text "DataConWrapper" + pp (ClassOpId {}) = text "ClassOp" + pp (PrimOpId _) = text "PrimOp" + pp (FCallId _) = text "ForeignCall" + pp (TickBoxOpId _) = text "TickBoxOp" + pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ text "RecSel" <> + ppWhen is_naughty (text "(naughty)") + pp CoVarId = text "CoVarId" + pp (JoinId arity) = text "JoinId" <> parens (int arity) + +{- +************************************************************************ +* * +\subsection{The main IdInfo type} +* * +************************************************************************ +-} + +-- | Identifier Information +-- +-- An 'IdInfo' gives /optional/ information about an 'Id'. If +-- present it never lies, but it may not be present, in which case there +-- is always a conservative assumption which can be made. +-- +-- Two 'Id's may have different info even though they have the same +-- 'Unique' (and are hence the same 'Id'); for example, one might lack +-- the properties attached to the other. +-- +-- Most of the 'IdInfo' gives information about the value, or definition, of +-- the 'Id', independent of its usage. Exceptions to this +-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. +-- +-- Performance note: when we update 'IdInfo', we have to reallocate this +-- entire record, so it is a good idea not to let this data structure get +-- too big. +data IdInfo + = IdInfo { + ruleInfo :: RuleInfo, + -- ^ Specialisations of the 'Id's function which exist. + -- See Note [Specialisations and RULES in IdInfo] + unfoldingInfo :: Unfolding, + -- ^ The 'Id's unfolding + inlinePragInfo :: InlinePragma, + -- ^ Any inline pragma attached to the 'Id' + occInfo :: OccInfo, + -- ^ How the 'Id' occurs in the program + strictnessInfo :: StrictSig, + -- ^ A strictness signature. Digests how a function uses its arguments + -- if applied to at least 'arityInfo' arguments. + cprInfo :: CprSig, + -- ^ Information on whether the function will ultimately return a + -- freshly allocated constructor. + demandInfo :: Demand, + -- ^ ID demand information + bitfield :: {-# UNPACK #-} !BitField, + -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, LevityInfo, and + -- call arity info in one 64-bit word. Packing these fields reduces size + -- of `IdInfo` from 12 words to 7 words and reduces residency by almost + -- 4% in some programs. See #17497 and associated MR. + -- + -- See documentation of the getters for what these packed fields mean. + lfInfo :: !(Maybe LambdaFormInfo) + } + +-- | Encodes arities, OneShotInfo, CafInfo and LevityInfo. +-- From least-significant to most-significant bits: +-- +-- - Bit 0 (1): OneShotInfo +-- - Bit 1 (1): CafInfo +-- - Bit 2 (1): LevityInfo +-- - Bits 3-32(30): Call Arity info +-- - Bits 33-62(30): Arity info +-- +newtype BitField = BitField Word64 + +emptyBitField :: BitField +emptyBitField = BitField 0 + +bitfieldGetOneShotInfo :: BitField -> OneShotInfo +bitfieldGetOneShotInfo (BitField bits) = + if testBit bits 0 then OneShotLam else NoOneShotInfo + +bitfieldGetCafInfo :: BitField -> CafInfo +bitfieldGetCafInfo (BitField bits) = + if testBit bits 1 then NoCafRefs else MayHaveCafRefs + +bitfieldGetLevityInfo :: BitField -> LevityInfo +bitfieldGetLevityInfo (BitField bits) = + if testBit bits 2 then NeverLevityPolymorphic else NoLevityInfo + +bitfieldGetCallArityInfo :: BitField -> ArityInfo +bitfieldGetCallArityInfo (BitField bits) = + fromIntegral (bits `shiftR` 3) .&. ((1 `shiftL` 30) - 1) + +bitfieldGetArityInfo :: BitField -> ArityInfo +bitfieldGetArityInfo (BitField bits) = + fromIntegral (bits `shiftR` 33) + +bitfieldSetOneShotInfo :: OneShotInfo -> BitField -> BitField +bitfieldSetOneShotInfo info (BitField bits) = + case info of + NoOneShotInfo -> BitField (clearBit bits 0) + OneShotLam -> BitField (setBit bits 0) + +bitfieldSetCafInfo :: CafInfo -> BitField -> BitField +bitfieldSetCafInfo info (BitField bits) = + case info of + MayHaveCafRefs -> BitField (clearBit bits 1) + NoCafRefs -> BitField (setBit bits 1) + +bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField +bitfieldSetLevityInfo info (BitField bits) = + case info of + NoLevityInfo -> BitField (clearBit bits 2) + NeverLevityPolymorphic -> BitField (setBit bits 2) + +bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField +bitfieldSetCallArityInfo info bf@(BitField bits) = + ASSERT(info < 2^(30 :: Int) - 1) + bitfieldSetArityInfo (bitfieldGetArityInfo bf) $ + BitField ((fromIntegral info `shiftL` 3) .|. (bits .&. 0b111)) + +bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField +bitfieldSetArityInfo info (BitField bits) = + ASSERT(info < 2^(30 :: Int) - 1) + BitField ((fromIntegral info `shiftL` 33) .|. (bits .&. ((1 `shiftL` 33) - 1))) + +-- Getters + +-- | When applied, will this Id ever have a levity-polymorphic type? +levityInfo :: IdInfo -> LevityInfo +levityInfo = bitfieldGetLevityInfo . bitfield + +-- | Info about a lambda-bound variable, if the 'Id' is one +oneShotInfo :: IdInfo -> OneShotInfo +oneShotInfo = bitfieldGetOneShotInfo . bitfield + +-- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments +-- this 'Id' has to be applied to before it doesn any meaningful work. +arityInfo :: IdInfo -> ArityInfo +arityInfo = bitfieldGetArityInfo . bitfield + +-- | 'Id' CAF info +cafInfo :: IdInfo -> CafInfo +cafInfo = bitfieldGetCafInfo . bitfield + +-- | How this is called. This is the number of arguments to which a binding can +-- be eta-expanded without losing any sharing. n <=> all calls have at least n +-- arguments +callArityInfo :: IdInfo -> ArityInfo +callArityInfo = bitfieldGetCallArityInfo . bitfield + +-- Setters + +setRuleInfo :: IdInfo -> RuleInfo -> IdInfo +setRuleInfo info sp = sp `seq` info { ruleInfo = sp } +setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo :: IdInfo -> OccInfo -> IdInfo +setOccInfo info oc = oc `seq` info { occInfo = oc } + -- Try to avoid space leaks by seq'ing + +setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo +setUnfoldingInfo info uf + = -- We don't seq the unfolding, as we generate intermediate + -- unfoldings which are just thrown away, so evaluating them is a + -- waste of time. + -- seqUnfolding uf `seq` + info { unfoldingInfo = uf } + +setArityInfo :: IdInfo -> ArityInfo -> IdInfo +setArityInfo info ar = + info { bitfield = bitfieldSetArityInfo ar (bitfield info) } + +setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo +setCallArityInfo info ar = + info { bitfield = bitfieldSetCallArityInfo ar (bitfield info) } + +setCafInfo :: IdInfo -> CafInfo -> IdInfo +setCafInfo info caf = + info { bitfield = bitfieldSetCafInfo caf (bitfield info) } + +setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo +setLFInfo info lf = info { lfInfo = Just lf } + +setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo +setOneShotInfo info lb = + info { bitfield = bitfieldSetOneShotInfo lb (bitfield info) } + +setDemandInfo :: IdInfo -> Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo +setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } + +setCprInfo :: IdInfo -> CprSig -> IdInfo +setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } + +-- | Basic 'IdInfo' that carries no useful information whatsoever +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + ruleInfo = emptyRuleInfo, + unfoldingInfo = noUnfolding, + inlinePragInfo = defaultInlinePragma, + occInfo = noOccInfo, + demandInfo = topDmd, + strictnessInfo = nopSig, + cprInfo = topCprSig, + bitfield = bitfieldSetCafInfo vanillaCafInfo $ + bitfieldSetArityInfo unknownArity $ + bitfieldSetCallArityInfo unknownArity $ + bitfieldSetOneShotInfo NoOneShotInfo $ + bitfieldSetLevityInfo NoLevityInfo $ + emptyBitField, + lfInfo = Nothing + } + +-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references +noCafIdInfo :: IdInfo +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in GHC.Types.Id.Make. + +{- +************************************************************************ +* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +* * +************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) +-} + +-- | Arity Information +-- +-- An 'ArityInfo' of @n@ tells us that partial application of this +-- 'Id' to up to @n-1@ value arguments does essentially no work. +-- +-- That is not necessarily the same as saying that it has @n@ leading +-- lambdas, because coerces may get in the way. +-- +-- The arity might increase later in the compilation process, if +-- an extra lambda floats up to the binding site. +type ArityInfo = Arity + +-- | It is always safe to assume that an 'Id' has an arity of 0 +unknownArity :: Arity +unknownArity = 0 + +ppArityInfo :: Int -> SDoc +ppArityInfo 0 = empty +ppArityInfo n = hsep [text "Arity", int n] + +{- +************************************************************************ +* * +\subsection{Inline-pragma information} +* * +************************************************************************ +-} + +-- | Inline Pragma Information +-- +-- Tells when the inlining is active. +-- When it is active the thing may be inlined, depending on how +-- big it is. +-- +-- If there was an @INLINE@ pragma, then as a separate matter, the +-- RHS will have been made to look small with a Core inline 'Note' +-- +-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves +-- entirely as a way to inhibit inlining until we want it +type InlinePragInfo = InlinePragma + +{- +************************************************************************ +* * + Strictness +* * +************************************************************************ +-} + +pprStrictness :: StrictSig -> SDoc +pprStrictness sig = ppr sig + +{- +************************************************************************ +* * + RuleInfo +* * +************************************************************************ + +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalId has an *empty* RuleInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +just for convenience really. + +However, LocalIds may have non-empty RuleInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. +-} + +-- | Rule Information +-- +-- Records the specializations of this 'Id' that we know about +-- in the form of rewrite 'CoreRule's that target them +data RuleInfo + = RuleInfo + [CoreRule] + DVarSet -- Locally-defined free vars of *both* LHS and RHS + -- of rules. I don't think it needs to include the + -- ru_fn though. + -- Note [Rule dependency info] in "GHC.Core.Opt.OccurAnal" + +-- | Assume that no specializations exist: always safe +emptyRuleInfo :: RuleInfo +emptyRuleInfo = RuleInfo [] emptyDVarSet + +isEmptyRuleInfo :: RuleInfo -> Bool +isEmptyRuleInfo (RuleInfo rs _) = null rs + +-- | Retrieve the locally-defined free variables of both the left and +-- right hand sides of the specialization rules +ruleInfoFreeVars :: RuleInfo -> DVarSet +ruleInfoFreeVars (RuleInfo _ fvs) = fvs + +ruleInfoRules :: RuleInfo -> [CoreRule] +ruleInfoRules (RuleInfo rules _) = rules + +-- | Change the name of the function the rule is keyed on all of the 'CoreRule's +setRuleInfoHead :: Name -> RuleInfo -> RuleInfo +setRuleInfoHead fn (RuleInfo rules fvs) + = RuleInfo (map (setRuleIdName fn) rules) fvs + +{- +************************************************************************ +* * +\subsection[CG-IdInfo]{Code generator-related information} +* * +************************************************************************ +-} + +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). + +-- | Constant applicative form Information +-- +-- Records whether an 'Id' makes Constant Applicative Form references +data CafInfo + = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: + -- + -- 1. A function or static constructor + -- that refers to one or more CAFs, or + -- + -- 2. A real live CAF + + | NoCafRefs -- ^ A function or static constructor + -- that refers to no CAFs. + deriving (Eq, Ord) + +-- | Assumes that the 'Id' has CAF references: definitely safe +vanillaCafInfo :: CafInfo +vanillaCafInfo = MayHaveCafRefs + +mayHaveCafRefs :: CafInfo -> Bool +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +instance Outputable CafInfo where + ppr = ppCafInfo + +ppCafInfo :: CafInfo -> SDoc +ppCafInfo NoCafRefs = text "NoCafRefs" +ppCafInfo MayHaveCafRefs = empty + +{- +************************************************************************ +* * +\subsection{Bulk operations on IdInfo} +* * +************************************************************************ +-} + +-- | This is used to remove information on lambda binders that we have +-- setup as part of a lambda group, assuming they will be applied all at once, +-- but turn out to be part of an unsaturated lambda as in e.g: +-- +-- > (\x1. \x2. e) arg1 +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, demandInfo = topDmd}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ occ | isAlwaysTailCalled occ = False + is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False + is_safe_occ _other = True + + safe_occ = case occ of + OneOcc{} -> occ { occ_in_lam = IsInsideLam + , occ_tail = NoTailCallInfo } + IAmALoopBreaker{} + -> occ { occ_tail = NoTailCallInfo } + _other -> occ + + is_safe_dmd dmd = not (isStrictDmd dmd) + +-- | Remove all demand info on the 'IdInfo' +zapDemandInfo :: IdInfo -> Maybe IdInfo +zapDemandInfo info = Just (info {demandInfo = topDmd}) + +-- | Remove usage (but not strictness) info on the 'IdInfo' +zapUsageInfo :: IdInfo -> Maybe IdInfo +zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) + +-- | Remove usage environment info from the strictness signature on the 'IdInfo' +zapUsageEnvInfo :: IdInfo -> Maybe IdInfo +zapUsageEnvInfo info + | hasDemandEnvSig (strictnessInfo info) + = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) + | otherwise + = Nothing + +zapUsedOnceInfo :: IdInfo -> Maybe IdInfo +zapUsedOnceInfo info + = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) + , demandInfo = zapUsedOnceDemand (demandInfo info) } + +zapFragileInfo :: IdInfo -> Maybe IdInfo +-- ^ Zap info that depends on free variables +zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) + = new_unf `seq` -- The unfolding field is not (currently) strict, so we + -- force it here to avoid a (zapFragileUnfolding unf) thunk + -- which might leak space + Just (info `setRuleInfo` emptyRuleInfo + `setUnfoldingInfo` new_unf + `setOccInfo` zapFragileOcc occ) + where + new_unf = zapFragileUnfolding unf + +zapFragileUnfolding :: Unfolding -> Unfolding +zapFragileUnfolding unf + | hasCoreUnfolding unf = noUnfolding + | otherwise = unf + +zapUnfolding :: Unfolding -> Unfolding +-- Squash all unfolding info, preserving only evaluated-ness +zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding + | otherwise = noUnfolding + +zapTailCallInfo :: IdInfo -> Maybe IdInfo +zapTailCallInfo info + = case occInfo info of + occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) + | otherwise -> Nothing + where + safe_occ = occ { occ_tail = NoTailCallInfo } + +zapCallArityInfo :: IdInfo -> IdInfo +zapCallArityInfo info = setCallArityInfo info 0 + +{- +************************************************************************ +* * +\subsection{TickBoxOp} +* * +************************************************************************ +-} + +type TickBoxId = Int + +-- | Tick box for Hpc-style coverage +data TickBoxOp + = TickBox Module {-# UNPACK #-} !TickBoxId + +instance Outputable TickBoxOp where + ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) + +{- +************************************************************************ +* * + Levity +* * +************************************************************************ + +Note [Levity info] +~~~~~~~~~~~~~~~~~~ + +Ids store whether or not they can be levity-polymorphic at any amount +of saturation. This is helpful in optimizing the levity-polymorphism check +done in the desugarer, where we can usually learn that something is not +levity-polymorphic without actually figuring out its type. See +isExprLevPoly in GHC.Core.Utils for where this info is used. Storing +this is required to prevent perf/compiler/T5631 from blowing up. + +-} + +-- See Note [Levity info] +data LevityInfo = NoLevityInfo -- always safe + | NeverLevityPolymorphic + deriving Eq + +instance Outputable LevityInfo where + ppr NoLevityInfo = text "NoLevityInfo" + ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" + +-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when +-- applied). The Type is only there for checking that it's really never levity +-- polymorphic +setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo +setNeverLevPoly info ty + = ASSERT2( not (resultIsLevPoly ty), ppr ty ) + info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } + +setLevityInfoWithType :: IdInfo -> Type -> IdInfo +setLevityInfoWithType info ty + | not (resultIsLevPoly ty) + = info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } + | otherwise + = info + +isNeverLevPolyIdInfo :: IdInfo -> Bool +isNeverLevPolyIdInfo info + | NeverLevityPolymorphic <- levityInfo info = True + | otherwise = False diff --git a/GHC/Types/Id/Info.hs-boot b/GHC/Types/Id/Info.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Info.hs-boot @@ -0,0 +1,11 @@ +module GHC.Types.Id.Info where +import GHC.Prelude +import GHC.Utils.Outputable +data IdInfo +data IdDetails + +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails +isCoVarDetails :: IdDetails -> Bool +pprIdDetails :: IdDetails -> SDoc + diff --git a/GHC/Types/Id/Make.hs b/GHC/Types/Id/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Make.hs @@ -0,0 +1,1788 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +This module contains definitions for the IdInfo for things that +have a standard form, namely: + +- data constructors +- record selectors +- method and superclass selectors +- primitive operations +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Id.Make ( + mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + + mkPrimOpId, mkFCallId, + + unwrapNewTypeBody, wrapFamInstBody, + DataConBoxer(..), vanillaDataConBoxer, + mkDataConRep, mkDataConWorkId, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, ghcPrimIds, + realWorldPrimId, + voidPrimId, voidArgId, + nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, magicDictId, coerceId, + proxyHashId, noinlineId, noinlineIdName, + coerceName, + + -- Re-export error Ids + module GHC.Core.Opt.ConstantFold + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types +import GHC.Core.Opt.ConstantFold +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Rep +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Tc.Utils.TcType as TcType +import GHC.Core.Make +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Utils ( mkCast, mkDefaultCase ) +import GHC.Core.Unfold +import GHC.Types.Literal +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Types.Name.Set +import GHC.Types.Name +import GHC.Builtin.PrimOps +import GHC.Types.ForeignCall +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import GHC.Builtin.Names +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Utils.Misc +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Types.Var (VarBndr(Bndr)) +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe ( maybeToList ) + +{- +************************************************************************ +* * +\subsection{Wired in Ids} +* * +************************************************************************ + +Note [Wired-in Ids] +~~~~~~~~~~~~~~~~~~~ +A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') +rather than by looking it up its name in some environment or fetching +it from an interface file. + +There are several reasons why an Id might appear in the wiredInIds: + +* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] + +* magicIds: see Note [magicIds] + +* errorIds, defined in GHC.Core.Make. + These error functions (e.g. rUNTIME_ERROR_ID) are wired in + because the desugarer generates code that mentions them directly + +In all cases except ghcPrimIds, there is a definition site in a +library module, which may be called (e.g. in higher order situations); +but the wired-in version means that the details are never read from +that module's interface file; instead, the full definition is right +here. + +Note [ghcPrimIds (aka pseudoops)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ghcPrimIds + + * Are exported from GHC.Prim + + * Can't be defined in Haskell, and hence no Haskell binding site, + but have perfectly reasonable unfoldings in Core + + * Either have a CompulsoryUnfolding (hence always inlined), or + of an EvaldUnfolding and void representation (e.g. void#) + + * Are (or should be) defined in primops.txt.pp as 'pseudoop' + Reason: that's how we generate documentation for them + +Note [magicIds] +~~~~~~~~~~~~~~~ +The magicIds + + * Are exported from GHC.Magic + + * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). + This definition at least generates Haddock documentation for them. + + * May or may not have a CompulsoryUnfolding. + + * But have some special behaviour that can't be done via an + unfolding from an interface file +-} + +wiredInIds :: [Id] +wiredInIds + = magicIds + ++ ghcPrimIds + ++ errorIds -- Defined in GHC.Core.Make + +magicIds :: [Id] -- See Note [magicIds] +magicIds = [lazyId, oneShotId, noinlineId] + +ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] +ghcPrimIds + = [ realWorldPrimId + , voidPrimId + , nullAddrId + , seqId + , magicDictId + , coerceId + , proxyHashId + ] + +{- +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ + +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + Con T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of q -> ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + +Note [Wrappers for data instance tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of data instances, the wrapper also applies the coercion turning +the representation type into the family instance type to cast the result of +the wrapper. For example, consider the declarations + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +The tycon to which the datacon MapPair belongs gets a unique internal +name of the form :R123Map, and we call it the representation tycon. +In contrast, Map is the family tycon (accessible via +tyConFamInst_maybe). A coercion allows you to move between +representation and family type. It is accessible from :R123Map via +tyConFamilyCoercion_maybe and has kind + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +The wrapper and worker of MapPair get the types + + -- Wrapper + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) + + -- Worker + MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +This coercion is conditionally applied by wrapFamInstBody. + +It's a bit more complicated if the data instance is a GADT as well! + + data instance T [a] where + T1 :: forall b. b -> T [Maybe b] + +Hence we translate to + + -- Wrapper + $WT1 :: forall b. b -> T [Maybe b] + $WT1 b v = T1 (Maybe b) b (Maybe b) v + `cast` sym (Co7T (Maybe b)) + + -- Worker + T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c + + -- Coercion from family type to representation type + Co7T a :: T [a] ~ :R7T a + +Newtype instances through an additional wrinkle into the mix. Consider the +following example (adapted from #15318, comment:2): + + data family T a + newtype instance T [a] = MkT [a] + +Within the newtype instance, there are three distinct types at play: + +1. The newtype's underlying type, [a]. +2. The instance's representation type, TList a (where TList is the + representation tycon). +3. The family type, T [a]. + +We need two coercions in order to cast from (1) to (3): + +(a) A newtype coercion axiom: + + axiom coTList a :: TList a ~ [a] + + (Where TList is the representation tycon of the newtype instance.) + +(b) A data family instance coercion axiom: + + axiom coT a :: T [a] ~ TList a + +When we translate the newtype instance to Core, we obtain: + + -- Wrapper + $WMkT :: forall a. [a] -> T [a] + $WMkT a x = MkT a x |> Sym (coT a) + + -- Worker + MkT :: forall a. [a] -> TList [a] + MkT a x = x |> Sym (coTList a) + +Unlike for data instances, the worker for a newtype instance is actually an +executable function which expands to a cast, but otherwise, the general +strategy is essentially the same as for data instances. Also note that we have +a wrapper, which is unusual for a newtype, but we make GHC produce one anyway +for symmetry with the way data instances are handled. + +Note [Newtype datacons] +~~~~~~~~~~~~~~~~~~~~~~~ +The "data constructor" for a newtype should always be vanilla. At one +point this wasn't true, because the newtype arising from + class C a => D a +looked like + newtype T:D a = D:D (C a) +so the data constructor for T:C had a single argument, namely the +predicate (C a). But now we treat that as an ordinary argument, not +part of the theta-type, so all is well. + +Note [Newtype workers] +~~~~~~~~~~~~~~~~~~~~~~ +A newtype does not really have a worker. Instead, newtype constructors +just unfold into a cast. But we need *something* for, say, MkAge to refer +to. So, we do this: + +* The Id used as the newtype worker will have a compulsory unfolding to + a cast. See Note [Compulsory newtype unfolding] + +* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, + as those have special treatment in the back end. + +* There is no top-level binding, because the compulsory unfolding + means that it will be inlined (to a cast) at every call site. + +We probably should have a NewtypeWorkId, but these Ids disappear as soon as +we desugar anyway, so it seems a step too far. + +Note [Compulsory newtype unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype wrappers, just like workers, have compulsory unfoldings. +This is needed so that two optimizations involving newtypes have the same +effect whether a wrapper is present or not: + +(1) Case-of-known constructor. + See Note [beta-reduction in exprIsConApp_maybe]. + +(2) Matching against the map/coerce RULE. Suppose we have the RULE + + {-# RULE "map/coerce" map coerce = ... #-} + + As described in Note [Getting the map/coerce RULE to work], + the occurrence of 'coerce' is transformed into: + + {-# RULE "map/coerce" forall (c :: T1 ~R# T2). + map ((\v -> v) `cast` c) = ... #-} + + We'd like 'map Age' to match the LHS. For this to happen, Age + must be unfolded, otherwise we'll be stuck. This is tested in T16208. + +It also allows for the posssibility of levity polymorphic newtypes +with wrappers (with -XUnliftedNewtypes): + + newtype N (a :: TYPE r) = MkN a + +With -XUnliftedNewtypes, this is allowed -- even though MkN is levity- +polymorphic. It's OK because MkN evaporates in the compiled code, becoming +just a cast. That is, it has a compulsory unfolding. As long as its +argument is not levity-polymorphic (which it can't be, according to +Note [Levity polymorphism invariants] in GHC.Core), and it's saturated, +no levity-polymorphic code ends up in the code generator. The saturation +condition is effectively checked by Note [Detecting forced eta expansion] +in GHC.HsToCore.Expr. + +However, if we make a *wrapper* for a newtype, we get into trouble. +The saturation condition is no longer checked (because hasNoBinding +returns False) and indeed we generate a forbidden levity-polymorphic +binding. + +The solution is simple, though: just make the newtype wrappers +as ephemeral as the newtype workers. In other words, give the wrappers +compulsory unfoldings and no bindings. The compulsory unfolding is given +in wrap_unf in mkDataConRep, and the lack of a binding happens in +GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no +implicit bindings. + +Note [Records and linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the fields, in a record constructor, are linear, because there is no syntax +to specify the type of record field. There will be (see the proposal +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#records-and-projections +), but it isn't implemented yet. + +Projections of records can't be linear: + + data Foo = MkFoo { a :: A, b :: B } + +If we had + + a :: Foo %1 -> A + +We could write + + bad :: A %1 -> B %1 -> A + bad x y = a (MkFoo { a=x, b=y }) + +There is an exception: if `b` (more generally all the fields besides `a`) is +unrestricted, then is perfectly possible to have a linear projection. Such a +linear projection has as simple definition. + + data Bar = MkBar { c :: C, d # Many :: D } + + c :: Bar %1 -> C + c MkBar{ c=x, d=_} = x + +The `# Many` syntax, for records, does not exist yet. But there is one important +special case which already happens: when there is a single field (usually a +newtype). + + newtype Baz = MkBaz { unbaz :: E } + +unbaz could be linear. And, in fact, it is linear in the proposal design. + +However, this hasn't been implemented yet. + +************************************************************************ +* * +\subsection{Dictionary selectors} +* * +************************************************************************ + +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +Note [Type classes and linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Constraints, in particular type classes, don't have attached linearity +information. Implicitly, they are all unrestricted. See the linear types proposal, +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst . + +When translating to core `C => ...` is always translated to an unrestricted +arrow `C # Many -> ...`. + +Therefore there is no loss of generality if we make all selectors unrestricted. + +-} + +mkDictSelId :: Name -- Name of one of the *value* selectors + -- (dictionary superclass or method) + -> Class -> Id +mkDictSelId name clas + = mkGlobalId (ClassOpId clas) name sel_ty info + where + tycon = classTyCon clas + sel_names = map idName (classAllSelIds clas) + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUserTyVarBinders data_con + n_ty_args = length tyvars + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name + + sel_ty = mkInvisForAllTys tyvars $ + mkInvisFunTyMany (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ + scaledThing (getNth arg_tys val_index) + -- See Note [Type classes and linear types] + + base_info = noCafIdInfo + `setArityInfo` 1 + `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig + `setLevityInfoWithType` sel_ty + + info | new_tycon + = base_info `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 + (mkDictSelRhs clas val_index) + -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance + -- for why alwaysInlinePragma + + | otherwise + = base_info `setRuleInfo` mkRuleInfo [rule] + -- Add a magic BuiltinRule, but no unfolding + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule val_index n_ty_args } + + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined + + strict_sig = mkClosedStrictSig [arg_dmd] topDiv + arg_dmd | new_tycon = evalDmd + | otherwise = mkManyUsedDmd $ + mkProdDmd [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] + +mkDictSelRhs :: Class + -> Int -- 0-indexed selector among (superclasses ++ methods) + -> CoreExpr +mkDictSelRhs clas val_index + = mkLams tyvars (Lam dict_id rhs_body) + where + tycon = classTyCon clas + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + + the_arg_id = getNth arg_ids val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 pred + arg_ids = mkTemplateLocalsNum 2 (map scaledThing arg_tys) + + rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) + (Var dict_id) + | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) + arg_ids (varToCoreExpr the_arg_id) + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } + +dictSelRule :: Int -> Arity -> RuleFun +-- Tries to persuade the argument to look like a constructor +-- application, using exprIsConApp_maybe, and then selects +-- from it +-- sel_i t1..tk (D t1..tk op1 ... opm) = opi +-- +dictSelRule val_index n_ty_args _ id_unf _ args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (wrapFloats floats $ getNth con_args val_index) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Data constructors +* * +************************************************************************ +-} + +mkDataConWorkId :: Name -> DataCon -> Id +mkDataConWorkId wkr_name data_con + | isNewTyCon tycon + = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info + -- See Note [Newtype workers] + + | otherwise + = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info + + where + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + + ----------- Workers for data types -------------- + alg_wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) + `setInlinePragInfo` wkr_inline_prag + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + `setLevityInfoWithType` wkr_ty + -- NB: unboxed tuples have workers, so we can't use + -- setNeverLevPoly + + wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } + wkr_arity = dataConRepArity data_con + ----------- Workers for newtypes -------------- + univ_tvs = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` dataConWrapperInlinePragma + `setUnfoldingInfo` newtype_unf + `setLevityInfoWithType` wkr_ty + id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) + res_ty_args = mkTyCoVarTys univ_tvs + newtype_unf = ASSERT2( isVanillaDataCon data_con && + isSingleton arg_tys + , ppr data_con ) + -- Note [Newtype datacons] + mkCompulsoryUnfolding $ + mkLams univ_tvs $ Lam id_arg1 $ + wrapNewTypeBody tycon res_ty_args (Var id_arg1) + +dataConCPR :: DataCon -> CprResult +dataConCPR con + | isDataTyCon tycon -- Real data types only; that is, + -- not unboxed tuples or newtypes + , null (dataConExTyCoVars con) -- No existentials + , wkr_arity > 0 + , wkr_arity <= mAX_CPR_SIZE + = conCpr (dataConTag con) + | otherwise + = topCpr + where + tycon = dataConTyCon con + wkr_arity = dataConRepArity con + + mAX_CPR_SIZE :: Arity + mAX_CPR_SIZE = 10 + -- We do not treat very big tuples as CPR-ish: + -- a) for a start we get into trouble because there aren't + -- "enough" unboxed tuple types (a tiresome restriction, + -- but hard to fix), + -- b) more importantly, big unboxed tuples get returned mainly + -- on the stack, and are often then allocated in the heap + -- by the caller. So doing CPR for them may in fact make + -- things worse. + +{- +------------------------------------------------- +-- Data constructor representation +-- +-- This is where we decide how to wrap/unwrap the +-- constructor fields +-- +-------------------------------------------------- +-} + +type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) + -- Unbox: bind rep vars by decomposing src var + +data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) + -- Box: build src arg using these rep vars + +-- | Data Constructor Boxer +newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) + -- Bind these src-level vars, returning the + -- rep-level vars to bind in the pattern + +vanillaDataConBoxer :: DataConBoxer +-- No transformation on arguments needed +vanillaDataConBoxer = DCB (\_tys args -> return (args, [])) + +{- +Note [Inline partially-applied constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We allow the wrapper to inline when partially applied to avoid +boxing values unnecessarily. For example, consider + + data Foo a = Foo !Int a + + instance Traversable Foo where + traverse f (Foo i a) = Foo i <$> f a + +This desugars to + + traverse f foo = case foo of + Foo i# a -> let i = I# i# + in map ($WFoo i) (f a) + +If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. +But if we inline the wrapper, we get + + map (\a. case i of I# i# a -> Foo i# a) (f a) + +and now case-of-known-constructor eliminates the redundant allocation. + +-} + +mkDataConRep :: DynFlags + -> FamInstEnvs + -> Name + -> Maybe [HsImplBang] + -- See Note [Bangs on imported data constructors] + -> DataCon + -> UniqSM DataConRep +mkDataConRep dflags fam_envs wrap_name mb_bangs data_con + | not wrapper_reqd + = return NoDataConRep + + | otherwise + = do { wrap_args <- mapM newLocal wrap_arg_tys + ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + initial_wrap_app + + ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info + wrap_info = noCafIdInfo + `setArityInfo` wrap_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setInlinePragInfo` wrap_prag + `setUnfoldingInfo` wrap_unf + `setStrictnessInfo` wrap_sig + `setCprInfo` mkCprSig wrap_arity (dataConCPR data_con) + -- We need to get the CAF info right here because GHC.Iface.Tidy + -- does not tidy the IdInfo of implicit bindings (like the wrapper) + -- so it not make sure that the CAF info is sane + `setLevityInfoWithType` wrap_ty + + wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv + + wrap_arg_dmds = + replicate (length theta) topDmd ++ map mk_dmd arg_ibangs + -- Don't forget the dictionary arguments when building + -- the strictness signature (#14290). + + mk_dmd str | isBanged str = evalDmd + | otherwise = topDmd + + wrap_prag = dataConWrapperInlinePragma + `setInlinePragmaActivation` activateDuringFinal + -- See Note [Activation for data constructor wrappers] + + -- The wrapper will usually be inlined (see wrap_unf), so its + -- strictness and CPR info is usually irrelevant. But this is + -- not always the case; GHC may choose not to inline it. In + -- particular, the wrapper constructor is not inlined inside + -- an INLINE rhs or when it is not applied to any arguments. + -- See Note [Inline partially-applied constructor wrappers] + -- Passing Nothing here allows the wrapper to inline when + -- unsaturated. + wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs + -- See Note [Compulsory newtype unfolding] + | otherwise = mkInlineUnfolding wrap_rhs + wrap_rhs = mkLams wrap_tvs $ + mkLams wrap_args $ + wrapFamInstBody tycon res_ty_args $ + wrap_body + + ; return (DCR { dcr_wrap_id = wrap_id + , dcr_boxer = mk_boxer boxers + , dcr_arg_tys = rep_tys + , dcr_stricts = rep_strs + -- For newtypes, dcr_bangs is always [HsLazy]. + -- See Note [HsImplBangs for newtypes]. + , dcr_bangs = arg_ibangs }) } + + where + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) + = dataConFullSig data_con + wrap_tvs = dataConUserTyVars data_con + res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs + + tycon = dataConTyCon data_con -- The representation TyCon (not family) + wrap_ty = dataConWrapperType data_con + ev_tys = eqSpecPreds eq_spec ++ theta + all_arg_tys = map unrestricted ev_tys ++ orig_arg_tys + ev_ibangs = map (const HsLazy) ev_tys + orig_bangs = dataConSrcBangs data_con + + wrap_arg_tys = (map unrestricted theta) ++ orig_arg_tys + wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys + -- The wrap_args are the arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper + + new_tycon = isNewTyCon tycon + arg_ibangs + | new_tycon + = map (const HsLazy) orig_arg_tys -- See Note [HsImplBangs for newtypes] + -- orig_arg_tys should be a singleton, but + -- if a user declared a wrong newtype we + -- detect this later (see test T2334A) + | otherwise + = case mb_bangs of + Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) + orig_arg_tys orig_bangs + Just bangs -> bangs + + (rep_tys_w_strs, wrappers) + = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) + + (unboxers, boxers) = unzip wrappers + (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + + wrapper_reqd = + (not new_tycon + -- (Most) newtypes have only a worker, with the exception + -- of some newtypes written with GADT syntax. See below. + && (any isBanged (ev_ibangs ++ arg_ibangs) + -- Some forcing/unboxing (includes eq_spec) + || (not $ null eq_spec))) -- GADT + || isFamInstTyCon tycon -- Cast result + || dataConUserTyVarsArePermuted data_con + -- If the data type was written with GADT syntax and + -- orders the type variables differently from what the + -- worker expects, it needs a data con wrapper to reorder + -- the type variables. + -- See Note [Data con wrappers and GADT syntax]. + + initial_wrap_app = Var (dataConWorkId data_con) + `mkTyApps` res_ty_args + `mkVarApps` ex_tvs + `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec + + mk_boxer :: [Boxer] -> DataConBoxer + mk_boxer boxers = DCB (\ ty_args src_vars -> + do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars + subst1 = zipTvSubst univ_tvs ty_args + subst2 = extendTCvSubstList subst1 ex_tvs + (mkTyCoVarTys ex_vars) + ; (rep_ids, binds) <- go subst2 boxers term_vars + ; return (ex_vars ++ rep_ids, binds) } ) + + go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) + go subst (UnitBox : boxers) (src_var : src_vars) + = do { (rep_ids2, binds) <- go subst boxers src_vars + ; return (src_var : rep_ids2, binds) } + go subst (Boxer boxer : boxers) (src_var : src_vars) + = do { (rep_ids1, arg) <- boxer subst + ; (rep_ids2, binds) <- go subst boxers src_vars + ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } + go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) + + mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr + mk_rep_app [] con_app + = return con_app + mk_rep_app ((wrap_arg, unboxer) : prs) con_app + = do { (rep_ids, unbox_fn) <- unboxer wrap_arg + ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) + ; return (unbox_fn expr) } + + +dataConWrapperInlinePragma :: InlinePragma +-- See Note [DataCon wrappers are conlike] +dataConWrapperInlinePragma = alwaysInlinePragma { inl_rule = ConLike + , inl_inline = Inline } + +{- Note [Activation for data constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Activation on a data constructor wrapper allows it to inline only in Phase +0. This way rules have a chance to fire if they mention a data constructor on +the left + RULE "foo" f (K a b) = ... +Since the LHS of rules are simplified with InitialPhase, we won't +inline the wrapper on the LHS either. + +On the other hand, this means that exprIsConApp_maybe must be able to deal +with wrappers so that case-of-constructor is not delayed; see +Note [exprIsConApp_maybe on data constructors with wrappers] for details. + +It used to activate in phases 2 (afterInitial) and later, but it makes it +awkward to write a RULE[1] with a constructor on the left: it would work if a +constructor has no wrapper, but whether a constructor has a wrapper depends, for +instance, on the order of type argument of that constructors. Therefore changing +the order of type argument could make previously working RULEs fail. + +See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . + +Note [DataCon wrappers are conlike] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DataCon workers are clearly ConLike --- they are the “Con” in +“ConLike”, after all --- but what about DataCon wrappers? Should they +be marked ConLike, too? + +Yes, absolutely! As described in Note [CONLIKE pragma] in +GHC.Types.Basic, isConLike influences GHC.Core.Utils.exprIsExpandable, +which is used by both RULE matching and the case-of-known-constructor +optimization. It’s crucial that both of those things can see +applications of DataCon wrappers: + + * User-defined RULEs match on wrappers, not workers, so we might + need to look through an unfolding built from a DataCon wrapper to + determine if a RULE matches. + + * Likewise, if we have something like + let x = $WC a b in ... case x of { C y z -> e } ... + we still want to apply case-of-known-constructor. + +Therefore, it’s important that we consider DataCon wrappers conlike. +This is especially true now that we don’t inline DataCon wrappers +until the final simplifier phase; see Note [Activation for data +constructor wrappers]. + +For further reading, see: + * Note [Conlike is interesting] in GHC.Core.Op.Simplify.Utils + * Note [Lone variables] in GHC.Core.Unfold + * Note [exprIsConApp_maybe on data constructors with wrappers] + in GHC.Core.SimpleOpt + * #18012 + +Note [Bangs on imported data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs +from imported modules. + +- Nothing <=> use HsSrcBangs +- Just bangs <=> use HsImplBangs + +For imported types we can't work it all out from the HsSrcBangs, +because we want to be very sure to follow what the original module +(where the data type was declared) decided, and that depends on what +flags were enabled when it was compiled. So we record the decisions in +the interface file. + +The HsImplBangs passed are in 1-1 correspondence with the +dataConOrigArgTys of the DataCon. + +Note [Data con wrappers and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int# + +We certainly do not want to make a wrapper + $WMkT x = case x of y { DEFAULT -> MkT y } + +For a start, it's still to generate a no-op. But worse, since wrappers +are currently injected at TidyCore, we don't even optimise it away! +So the stupid case expression stays there. This actually happened for +the Integer data type (see #1600 comment:66)! + +Note [Data con wrappers and GADT syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two very similar data types: + + data T1 a b = MkT1 b + + data T2 a b where + MkT2 :: forall b a. b -> T2 a b + +Despite their similar appearance, T2 will have a data con wrapper but T1 will +not. What sets them apart? The types of their constructors, which are: + + MkT1 :: forall a b. b -> T1 a b + MkT2 :: forall b a. b -> T2 a b + +MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` +would normally appear. See Note [DataCon user type variable binders] in GHC.Core.DataCon +for further discussion on this topic. + +The worker data cons for T1 and T2, however, both have types such that `a` is +expected to come before `b` as arguments. Because MkT2 permutes this order, it +needs a data con wrapper to swizzle around the type variables to be in the +order the worker expects. + +A somewhat surprising consequence of this is that *newtypes* can have data con +wrappers! After all, a newtype can also be written with GADT syntax: + + newtype T3 a b where + MkT3 :: forall b a. b -> T3 a b + +Again, this needs a wrapper data con to reorder the type variables. It does +mean that this newtype constructor requires another level of indirection when +being called, but the inliner should make swift work of that. + +Note [HsImplBangs for newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the time, we use the dataConSrctoImplBang function to decide what +strictness/unpackedness to use for the fields of a data type constructor. But +there is an exception to this rule: newtype constructors. You might not think +that newtypes would pose a challenge, since newtypes are seemingly forbidden +from having strictness annotations in the first place. But consider this +(from #16141): + + {-# LANGUAGE StrictData #-} + {-# OPTIONS_GHC -O #-} + newtype T a b where + MkT :: forall b a. Int -> T a b + +Because StrictData (plus optimization) is enabled, invoking +dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! +This would be disastrous, since the wrapper for `MkT` uses a coercion involving +Int, not Int#. + +Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the +case of a newtype constructor, we simply hardcode its dcr_bangs field to +[HsLazy]. +-} + +------------------------- +newLocal :: Scaled Type -> UniqSM Var +newLocal (Scaled w ty) = do { uniq <- getUniqueM + ; return (mkSysLocalOrCoVar (fsLit "dt") uniq w ty) } + -- We should not have "OrCoVar" here, this is a bug (#17545) + + +-- | Unpack/Strictness decisions from source module. +-- +-- This function should only ever be invoked for data constructor fields, and +-- never on the field of a newtype constructor. +-- See @Note [HsImplBangs for newtypes]@. +dataConSrcToImplBang + :: DynFlags + -> FamInstEnvs + -> Scaled Type + -> HsSrcBang + -> HsImplBang + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk NoSrcStrict) + | xopt LangExt.StrictData dflags -- StrictData => strict field + = dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk SrcStrict) + | otherwise -- no StrictData => lazy field + = HsLazy + +dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) + = HsLazy + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang _ unpk_prag SrcStrict) + | isUnliftedType (scaledThing arg_ty) + = HsLazy -- For !Int#, say, use HsLazy + -- See Note [Data con wrappers and unlifted types] + + | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas + -- Don't unpack if we aren't optimising; rather arbitrarily, + -- we use -fomit-iface-pragmas as the indication + , let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) + -- Unwrap type families and newtypes + arg_ty' = case mb_co of { Just (_,ty) -> scaledSet arg_ty ty; Nothing -> arg_ty } + , isUnpackableType dflags fam_envs (scaledThing arg_ty') + , (rep_tys, _) <- dataConArgUnpack arg_ty' + , case unpk_prag of + NoSrcUnpack -> + gopt Opt_UnboxStrictFields dflags + || (gopt Opt_UnboxSmallStrictFields dflags + && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] + srcUnpack -> isSrcUnpacked srcUnpack + = case mb_co of + Nothing -> HsUnpack Nothing + Just (co,_) -> HsUnpack (Just co) + + | otherwise -- Record the strict-but-no-unpack decision + = HsStrict + + +-- | Wrappers/Workers and representation following Unpack/Strictness +-- decisions +dataConArgRep + :: Scaled Type + -> HsImplBang + -> ([(Scaled Type,StrictnessMark)] -- Rep types + ,(Unboxer,Boxer)) + +dataConArgRep arg_ty HsLazy + = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep arg_ty HsStrict + = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + +dataConArgRep arg_ty (HsUnpack Nothing) + | (rep_tys, wrappers) <- dataConArgUnpack arg_ty + = (rep_tys, wrappers) + +dataConArgRep (Scaled w _) (HsUnpack (Just co)) + | let co_rep_ty = coercionRKind co + , (rep_tys, wrappers) <- dataConArgUnpack (Scaled w co_rep_ty) + = (rep_tys, wrapCo co co_rep_ty wrappers) + + +------------------------- +wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) +wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty + = (unboxer, boxer) + where + unboxer arg_id = do { rep_id <- newLocal (Scaled (idMult arg_id) rep_ty) + ; (rep_ids, rep_fn) <- unbox_rep rep_id + ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) + ; return (rep_ids, Let co_bind . rep_fn) } + boxer = Boxer $ \ subst -> + do { (rep_ids, rep_expr) + <- case box_rep of + UnitBox -> do { rep_id <- newLocal (linear $ TcType.substTy subst rep_ty) + ; return ([rep_id], Var rep_id) } + Boxer boxer -> boxer subst + ; let sco = substCoUnchecked subst co + ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } + +------------------------ +seqUnboxer :: Unboxer +seqUnboxer v = return ([v], mkDefaultCase (Var v) v) + +unitUnboxer :: Unboxer +unitUnboxer v = return ([v], \e -> e) + +unitBoxer :: Boxer +unitBoxer = UnitBox + +------------------------- +dataConArgUnpack + :: Scaled Type + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) + +dataConArgUnpack (Scaled arg_mult arg_ty) + | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty + , Just con <- tyConSingleAlgDataCon_maybe tc + -- NB: check for an *algebraic* data type + -- A recursive newtype might mean that + -- 'arg_ty' is a newtype + , let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args + = ASSERT( null (dataConExTyCoVars con) ) + -- Note [Unpacking GADTs and existentials] + ( rep_tys `zip` dataConRepStrictness con + ,( \ arg_id -> + do { rep_ids <- mapM newLocal rep_tys + ; let r_mult = idMult arg_id + ; let rep_ids' = map (scaleIdBy r_mult) rep_ids + ; let unbox_fn body + = mkSingleAltCase (Var arg_id) arg_id + (DataAlt con) rep_ids' body + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal . TcType.substScaledTyUnchecked subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTysUnchecked subst tc_args) + `mkVarApps` rep_ids ) } ) ) + | otherwise + = pprPanic "dataConArgUnpack" (ppr arg_ty) + -- An interface file specified Unpacked, but we couldn't unpack it + +isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool +-- True if we can unpack the UNPACK the argument type +-- See Note [Recursive unboxing] +-- We look "deeply" inside rather than relying on the DataCons +-- we encounter on the way, because otherwise we might well +-- end up relying on ourselves! +isUnpackableType dflags fam_envs ty + | Just data_con <- unpackable_type ty + = ok_con_args emptyNameSet data_con + | otherwise + = False + where + ok_con_args dcs con + | dc_name `elemNameSet` dcs + = False + | otherwise + = all (ok_arg dcs') + (dataConOrigArgTys con `zip` dataConSrcBangs con) + -- NB: dataConSrcBangs gives the *user* request; + -- We'd get a black hole if we used dataConImplBangs + where + dc_name = getName con + dcs' = dcs `extendNameSet` dc_name + + ok_arg dcs (Scaled _ ty, bang) + = not (attempt_unpack bang) || ok_ty dcs norm_ty + where + norm_ty = topNormaliseType fam_envs ty + + ok_ty dcs ty + | Just data_con <- unpackable_type ty + = ok_con_args dcs data_con + | otherwise + = True -- NB True here, in contrast to False at top level + + attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags + attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) + = True + attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) + = True -- Be conservative + attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags -- Be conservative + attempt_unpack _ = False + + unpackable_type :: Type -> Maybe DataCon + -- Works just on a single level + unpackable_type ty + | Just (tc, _) <- splitTyConApp_maybe ty + , Just data_con <- tyConSingleAlgDataCon_maybe tc + , null (dataConExTyCoVars data_con) + -- See Note [Unpacking GADTs and existentials] + = Just data_con + | otherwise + = Nothing + +{- +Note [Unpacking GADTs and existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is nothing stopping us unpacking a data type with equality +components, like + data Equal a b where + Equal :: Equal a a + +And it'd be fine to unpack a product type with existential components +too, but that would require a bit more plumbing, so currently we don't. + +So for now we require: null (dataConExTyCoVars data_con) +See #14978 + +Note [Unpack one-wide fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag UnboxSmallStrictFields ensures that any field that can +(safely) be unboxed to a word-sized unboxed field, should be so unboxed. +For example: + + data A = A Int# + newtype B = B A + data C = C !B + data D = D !C + data E = E !() + data F = F !D + data G = G !F !F + +All of these should have an Int# as their representation, except +G which should have two Int#s. + +However + + data T = T !(S Int) + data S = S !a + +Here we can represent T with an Int#. + +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data R = MkR {-# UNPACK #-} !S Int + data S = MkS {-# UNPACK #-} !Int +The representation arguments of MkR are the *representation* arguments +of S (plus Int); the rep args of MkS are Int#. This is all fine. + +But be careful not to try to unbox this! + data T = MkT {-# UNPACK #-} !T Int +Because then we'd get an infinite number of arguments. + +Here is a more complicated case: + data S = MkS {-# UNPACK #-} !T Int + data T = MkT {-# UNPACK #-} !S Int +Each of S and T must decide independently whether to unpack +and they had better not both say yes. So they must both say no. + +Also behave conservatively when there is no UNPACK pragma + data T = MkS !T Int +with -funbox-strict-fields or -funbox-small-strict-fields +we need to behave as if there was an UNPACK pragma there. + +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + +************************************************************************ +* * + Wrapping and unwrapping newtypes and type families +* * +************************************************************************ +-} + +wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +-- The wrapper for the data constructor for a newtype looks like this: +-- newtype T a = MkT (a,Int) +-- MkT :: forall a. (a,Int) -> T a +-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) +-- where CoT is the coercion TyCon associated with the newtype +-- +-- The call (wrapNewTypeBody T [a] e) returns the +-- body of the wrapper, namely +-- e `cast` (CoT [a]) +-- +-- If a coercion constructor is provided in the newtype, then we use +-- it, otherwise the wrap/unwrap are both no-ops + +wrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkSymCo co) + where + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] + +-- When unwrapping, we do *not* apply any family coercion, because this will +-- be done via a CoPat by the type checker. We have to do it this way as +-- computing the right type arguments for the coercion requires more than just +-- a splitting operation (cf, GHC.Tc.Gen.Pat.tcConPat). + +unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) + +-- If the type constructor is a representation type of a data instance, wrap +-- the expression into a cast adjusting the expression type, which is an +-- instance of the representation type, to the corresponding instance of the +-- family instance type. +-- See Note [Wrappers for data instance tycons] +wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +wrapFamInstBody tycon args body + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) + | otherwise + = body + +{- +************************************************************************ +* * +\subsection{Primitive operations} +* * +************************************************************************ +-} + +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op + = id + where + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op + ty = mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty) + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + (AnId id) UserSyntax + id = mkGlobalId (PrimOpId prim_op) name ty info + + -- PrimOps don't ever construct a product, but we want to preserve bottoms + cpr + | isDeadEndDiv (snd (splitStrictSig strict_sig)) = botCpr + | otherwise = topCpr + + info = noCafIdInfo + `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setCprInfo` mkCprSig arity cpr + `setInlinePragInfo` neverInlinePragma + `setLevityInfoWithType` res_ty + -- We give PrimOps a NOINLINE pragma so that we don't + -- get silly warnings from Desugar.dsRule (the inline_shadows_rule + -- test) about a RULE conflicting with a possible inlining + -- cf #7287 + +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id +mkFCallId dflags uniq fcall ty + = ASSERT( noFreeVarsOfType ty ) + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkGlobalId (FCallId fcall) name ty info + where + occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! + + name = mkFCallName uniq occ_str + + info = noCafIdInfo + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig + `setLevityInfoWithType` ty + + (bndrs, _) = tcSplitPiTys ty + arity = count isAnonTyCoBinder bndrs + strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv + -- the call does not claim to be strict in its arguments, since they + -- may be lifted (foreign import prim) and the called code doesn't + -- necessarily force them. See #11076. +{- +************************************************************************ +* * +\subsection{DictFuns and default methods} +* * +************************************************************************ + +Note [Dict funs and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dict funs and default methods are *not* ImplicitIds. Their definition +involves user-written code, so we can't figure out their strictness etc +based on fixed info, as we can for constructors and record selectors (say). + +NB: See also Note [Exported LocalIds] in GHC.Types.Id +-} + +mkDictFunId :: Name -- Name to use for the dict fun; + -> [TyVar] + -> ThetaType + -> Class + -> [Type] + -> Id +-- Implements the DFun Superclass Invariant (see GHC.Tc.TyCl.Instance) +-- See Note [Dict funs and default methods] + +mkDictFunId dfun_name tvs theta clas tys + = mkExportedLocalId (DFunId is_nt) + dfun_name + dfun_ty + where + is_nt = isNewTyCon (classTyCon clas) + dfun_ty = mkDictFunTy tvs theta clas tys + +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type +mkDictFunTy tvs theta clas tys + = mkSpecSigmaTy tvs theta (mkClassPred clas tys) + +{- +************************************************************************ +* * +\subsection{Un-definable} +* * +************************************************************************ + +These Ids can't be defined in Haskell. They could be defined in +unfoldings in the wired-in GHC.Prim interface file, but we'd have to +ensure that they were definitely, definitely inlined, because there is +no curried identifier for them. That's what mkCompulsoryUnfolding +does. If we had a way to get a compulsory unfolding from an interface +file, we could do that, but we don't right now. + +The type variables we use here are "open" type variables: this means +they can unify with both unlifted and lifted types. Hence we provide +another gun with which to shoot yourself in the foot. +-} + +nullAddrName, seqName, + realWorldName, voidPrimIdName, coercionTokenName, + magicDictName, coerceName, proxyName :: Name +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId +coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId +proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId + +lazyIdName, oneShotName, noinlineIdName :: Name +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId + +------------------------------------------------ +proxyHashId :: Id +proxyHashId + = pcMiscPrelId proxyName ty + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` ty) + where + -- proxy# :: forall {k} (a:k). Proxy# k a + -- + -- The visibility of the `k` binder is Inferred to match the type of the + -- Proxy data constructor (#16293). + [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id + kv_ty = mkTyVarTy kv + tv_ty = mkTyVarTy tv + ty = mkInfForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty + +------------------------------------------------ +nullAddrId :: Id +-- nullAddr# :: Addr# +-- The reason it is here is because we don't provide +-- a way to write this literal in Haskell. +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) + `setNeverLevPoly` addrPrimTy + +------------------------------------------------ +seqId :: Id -- See Note [seqId magic] +seqId = pcMiscPrelId seqName ty info + where + info = noCafIdInfo `setInlinePragInfo` inline_prag + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + inline_prag + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter + NoSourceText 0 + -- Make 'seq' not inline-always, so that simpleOptExpr + -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the + -- LHS of rules. That way we can have rules for 'seq'; + -- see Note [seqId magic] + + -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b + ty = + mkInfForAllTy runtimeRep2TyVar + $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] + $ mkVisFunTyMany alphaTy (mkVisFunTyMany openBetaTy openBetaTy) + + [x,y] = mkTemplateLocals [alphaTy, openBetaTy] + rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ + Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] + +------------------------------------------------ +lazyId :: Id -- See Note [lazyId magic] +lazyId = pcMiscPrelId lazyIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) + +noinlineId :: Id -- See Note [noinlineId magic] +noinlineId = pcMiscPrelId noinlineIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) + +oneShotId :: Id -- See Note [The oneShot function] +oneShotId = pcMiscPrelId oneShotName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar ] + (mkVisFunTyMany fun_ty fun_ty) + fun_ty = mkVisFunTyMany openAlphaTy openBetaTy + [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] + x' = setOneShotLambda x -- Here is the magic bit! + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar + , body, x'] $ + Var body `App` Var x + +-------------------------------------------------------------------------------- +magicDictId :: Id -- See Note [magicDictId magic] +magicDictId = pcMiscPrelId magicDictName ty info + where + info = noCafIdInfo `setInlinePragInfo` neverInlinePragma + `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] alphaTy + +-------------------------------------------------------------------------------- + +coerceId :: Id +coerceId = pcMiscPrelId coerceName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] + ty = mkInvisForAllTys [ Bndr rv InferredSpec + , Bndr av SpecifiedSpec + , Bndr bv SpecifiedSpec + ] $ + mkInvisFunTyMany eqRTy $ + mkVisFunTyMany a b + + bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy + (\r -> [tYPE r, tYPE r]) + + [r, a, b] = mkTyVarTys bndrs + + [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] + rhs = mkLams (bndrs ++ [eqR, x]) $ + mkWildCase (Var eqR) (unrestricted eqRTy) b $ + [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] + +{- +Note [seqId magic] +~~~~~~~~~~~~~~~~~~ +'GHC.Prim.seq' is special in several ways. + +a) Its fixity is set in GHC.Iface.Load.ghcPrimIface + +b) It has quite a bit of desugaring magic. + See GHC.HsToCore.Utils Note [Desugaring seq (1)] and (2) and (3) + +c) There is some special rule handing: Note [User-defined RULES for seq] + +Historical note: + In GHC.Tc.Gen.Expr we used to need a special typing rule for 'seq', to handle calls + whose second argument had an unboxed type, e.g. x `seq` 3# + + However, with levity polymorphism we can now give seq the type seq :: + forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this + case without special treatment in the typechecker. + +Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Roman found situations where he had + case (f n) of _ -> e +where he knew that f (which was strict in n) would terminate if n did. +Notice that the result of (f n) is discarded. So it makes sense to +transform to + case n of _ -> e + +Rather than attempt some general analysis to support this, I've added +enough support that you can do this using a rewrite rule: + + RULE "f/seq" forall n. seq (f n) = seq n + +You write that rule. When GHC sees a case expression that discards +its result, it mentally transforms it to a call to 'seq' and looks for +a RULE. (This is done in GHC.Core.Opt.Simplify.trySeqRules.) As usual, the +correctness of the rule is up to you. + +VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. +If we wrote + RULE "f/seq" forall n e. seq (f n) e = seq n e +with rule arity 2, then two bad things would happen: + + - The magical desugaring done in Note [seqId magic] item (b) + for saturated application of 'seq' would turn the LHS into + a case expression! + + - The code in GHC.Core.Opt.Simplify.rebuildCase would need to actually supply + the value argument, which turns out to be awkward. + +See also: Note [User-defined RULES for seq] in GHC.Core.Opt.Simplify. + + +Note [lazyId magic] +~~~~~~~~~~~~~~~~~~~ +lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) + +'lazy' is used to make sure that a sub-expression, and its free variables, +are truly used call-by-need, with no code motion. Key examples: + +* pseq: pseq a b = a `seq` lazy b + We want to make sure that the free vars of 'b' are not evaluated + before 'a', even though the expression is plainly strict in 'b'. + +* catch: catch a b = catch# (lazy a) b + Again, it's clear that 'a' will be evaluated strictly (and indeed + applied to a state token) but we want to make sure that any exceptions + arising from the evaluation of 'a' are caught by the catch (see + #11555). + +Implementing 'lazy' is a bit tricky: + +* It must not have a strictness signature: by being a built-in Id, + all the info about lazyId comes from here, not from GHC.Base.hi. + This is important, because the strictness analyser will spot it as + strict! + +* It must not have an unfolding: it gets "inlined" by a HACK in + CorePrep. It's very important to do this inlining *after* unfoldings + are exposed in the interface file. Otherwise, the unfolding for + (say) pseq in the interface file will not mention 'lazy', so if we + inline 'pseq' we'll totally miss the very thing that 'lazy' was + there for in the first place. See #3259 for a real world + example. + +* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must + avoid using call by value here: + case e of r -> catch# r b + Avoiding that is the whole point of 'lazy'. So in CorePrep (which + generate the 'case' expression for a call-by-value call) we must + spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' + instead. + +* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it + appears un-applied, we'll end up just calling it. + +Note [noinlineId magic] +~~~~~~~~~~~~~~~~~~~~~~~ +noinline :: forall a. a -> a + +'noinline' is used to make sure that a function f is never inlined, +e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE +could be used to achieve this effect; however, this has the unfortunate +result of leaving a (useless) call to noinline at runtime. So we have +a little bit of magic to optimize away 'noinline' after we are done +running the simplifier. + +'noinline' needs to be wired-in because it gets inserted automatically +when we serialize an expression to the interface format. See +Note [Inlining and hs-boot files] in GHC.CoreToIface + +Note that noinline as currently implemented can hide some simplifications since +it hides strictness from the demand analyser. Specifically, the demand analyser +will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' +specifies that it is strict in its argument. We considered fixing this this by adding a +special case to the demand analyser to address #16588. However, the special +case seemed like a large and expensive hammer to address a rare case and +consequently we rather opted to use a more minimal solution. + +Note [The oneShot function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the context of making left-folds fuse somewhat okish (see ticket #7994 +and Note [Left folds via right fold]) it was determined that it would be useful +if library authors could explicitly tell the compiler that a certain lambda is +called at most once. The oneShot function allows that. + +'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted +types as well (#10744); e.g. + oneShot (\x:Int# -> x +# 1#) + +Like most magic functions it has a compulsory unfolding, so there is no need +for a real definition somewhere. We have one in GHC.Magic for the convenience +of putting the documentation there. + +It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: + +A typical call looks like + oneShot (\y. e) +after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get + (\f \x[oneshot]. f x) (\y. e) + --> \x[oneshot]. ((\y.e) x) + --> \x[oneshot] e[x/y] +which is what we want. + +It is only effective if the one-shot info survives as long as possible; in +particular it must make it into the interface in unfoldings. See Note [Preserve +OneShotInfo] in GHC.Core.Tidy. + +Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. + + +Note [magicDictId magic] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The identifier `magicDict` is just a place-holder, which is used to +implement a primitive that we cannot define in Haskell but we can write +in Core. It is declared with a place-holder type: + + magicDict :: forall a. a + +The intention is that the identifier will be used in a very specific way, +to create dictionaries for classes with a single method. Consider a class +like this: + + class C a where + f :: T a + +We are going to use `magicDict`, in conjunction with a built-in Prelude +rule, to cast values of type `T a` into dictionaries for `C a`. To do +this, we define a function like this in the library: + + data WrapC a b = WrapC (C a => Proxy a -> b) + + withT :: (C a => Proxy a -> b) + -> T a -> Proxy a -> b + withT f x y = magicDict (WrapC f) x y + +The purpose of `WrapC` is to avoid having `f` instantiated. +Also, it avoids impredicativity, because `magicDict`'s type +cannot be instantiated with a forall. The field of `WrapC` contains +a `Proxy` parameter which is used to link the type of the constraint, +`C a`, with the type of the `Wrap` value being made. + +Next, we add a built-in Prelude rule (see GHC.Core.Opt.ConstantFold), +which will replace the RHS of this definition with the appropriate +definition in Core. The rewrite rule works as follows: + + magicDict @t (wrap @a @b f) x y +----> + f (x `cast` co a) y + +The `co` coercion is the newtype-coercion extracted from the type-class. +The type class is obtain by looking at the type of wrap. + +In the constant folding rule it's very import to make sure to strip all ticks +from the expression as if there's an occurence of +magicDict we *must* convert it for correctness. See #19667 for where this went +wrong in GHCi. + + +------------------------------------------------------------- +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: Void# -> (# p, q #) + +This comes up in strictness analysis + +Note [evaldUnfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The evaldUnfolding makes it look that some primitive value is +evaluated, which in turn makes Simplify.interestingArg return True, +which in turn makes INLINE things applied to said value likely to be +inlined. +-} + +realWorldPrimId :: Id -- :: State# RealWorld +realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setOneShotInfo` stateHackOneShot + `setNeverLevPoly` realWorldStatePrimTy) + +voidPrimId :: Id -- Global constant :: Void# +voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` voidPrimTy) + +voidArgId :: Id -- Local lambda-bound :: Void# +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey Many voidPrimTy + +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg" + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) + noCafIdInfo + +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobalWithInfo name ty info + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. diff --git a/GHC/Types/Id/Make.hs-boot b/GHC/Types/Id/Make.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Id/Make.hs-boot @@ -0,0 +1,16 @@ +module GHC.Types.Id.Make where +import GHC.Types.Name( Name ) +import GHC.Types.Var( Id ) +import GHC.Core.Class( Class ) +import {-# SOURCE #-} GHC.Core.DataCon( DataCon ) +import {-# SOURCE #-} GHC.Builtin.PrimOps( PrimOp ) + +data DataConBoxer + +mkDataConWorkId :: Name -> DataCon -> Id +mkDictSelId :: Name -> Class -> Id + +mkPrimOpId :: PrimOp -> Id +voidPrimId :: Id + +magicDictId :: Id diff --git a/GHC/Types/Literal.hs b/GHC/Types/Literal.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Literal.hs @@ -0,0 +1,815 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[Literal]{@Literal@: literals} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Literal + ( + -- * Main data type + Literal(..) -- Exported to ParseIface + , LitNumType(..) + + -- ** Creating Literals + , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked + , mkLitWord, mkLitWordWrap, mkLitWordWrapC + , mkLitInt64, mkLitInt64Wrap + , mkLitWord64, mkLitWord64Wrap + , mkLitFloat, mkLitDouble + , mkLitChar, mkLitString + , mkLitInteger, mkLitNatural + , mkLitNumber, mkLitNumberWrap + + -- ** Operations on Literals + , literalType + , absentLiteralOf + , pprLiteral + , litNumIsSigned + , litNumCheckRange + + -- ** Predicates on Literals and their contents + , litIsDupable, litIsTrivial, litIsLifted + , inCharRange + , isZeroLit + , litFitsInChar + , litValue, isLitValue, isLitValue_maybe, mapLitValue + + -- ** Coercions + , word2IntLit, int2WordLit + , narrowLit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit + , char2IntLit, int2CharLit + , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit + , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Builtin.Types.Prim +import {-# SOURCE #-} GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Basic +import GHC.Utils.Binary +import GHC.Settings.Constants +import GHC.Platform +import GHC.Types.Unique.FM +import GHC.Utils.Misc + +import Data.ByteString (ByteString) +import Data.Int +import Data.Word +import Data.Char +import Data.Maybe ( isJust ) +import Data.Data ( Data ) +import Data.Proxy +import Numeric ( fromRat ) + +{- +************************************************************************ +* * +\subsection{Literals} +* * +************************************************************************ +-} + +-- | So-called 'Literal's are one of: +-- +-- * An unboxed numeric literal or floating-point literal which is presumed +-- to be surrounded by appropriate constructors (@Int#@, etc.), so that +-- the overall thing makes sense. +-- +-- We maintain the invariant that the 'Integer' in the 'LitNumber' +-- constructor is actually in the (possibly target-dependent) range. +-- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying +-- the target machine's wrapping semantics. Use these in situations +-- where you know the wrapping semantics are correct. +-- +-- * The literal derived from the label mentioned in a \"foreign label\" +-- declaration ('LitLabel') +-- +-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' +-- (i.e. 'MutVar#') when the value is never used. +-- +-- * A character +-- * A string +-- * The NULL pointer +-- +data Literal + = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with + -- 'mkLitChar' + + | LitNumber !LitNumType !Integer + -- ^ Any numeric literal that can be + -- internally represented with an Integer. + + | LitString !ByteString -- ^ A string-literal: stored and emitted + -- UTF-8 encoded, we'll arrange to decode it + -- at runtime. Also emitted with a @\'\\0\'@ + -- terminator. Create with 'mkLitString' + + | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value + -- that can be represented as a Literal. Create + -- with 'nullAddrLit' + + | LitRubbish -- ^ A nonsense value, used when an unlifted + -- binding is absent and has type + -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. + -- May be lowered by code-gen to any possible + -- value. Also see Note [Rubbish literals] + + | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' + | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' + + | LitLabel FastString (Maybe Int) FunctionOrData + -- ^ A label literal. Parameters: + -- + -- 1) The name of the symbol mentioned in the + -- declaration + -- + -- 2) The size (in bytes) of the arguments + -- the label expects. Only applicable with + -- @stdcall@ labels. @Just x@ => @\@ will + -- be appended to label name when emitting + -- assembly. + -- + -- 3) Flag indicating whether the symbol + -- references a function or a data + deriving Data + +-- | Numeric literal type +data LitNumType + = LitNumInteger -- ^ @Integer@ (see Note [BigNum literals]) + | LitNumNatural -- ^ @Natural@ (see Note [BigNum literals]) + | LitNumInt -- ^ @Int#@ - according to target machine + | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits + | LitNumWord -- ^ @Word#@ - according to target machine + | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits + deriving (Data,Enum,Eq,Ord) + +-- | Indicate if a numeric literal type supports negative numbers +litNumIsSigned :: LitNumType -> Bool +litNumIsSigned nt = case nt of + LitNumInteger -> True + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> False + LitNumWord64 -> False + +{- +Note [BigNum literals] +~~~~~~~~~~~~~~~~~~~~~~ + +GHC supports 2 kinds of arbitrary precision integers (a.k.a BigNum): + + * Natural: natural represented as a Word# or as a BigNat + + * Integer: integer represented a an Int# or as a BigNat (Integer's + constructors indicate the sign) + +BigNum literal instances are removed from Core during the CorePrep phase. They +are replaced with expression to build them at runtime from machine literals +(Word#, Int#, etc.) or from a list of Word#s. + +Note [String literals] +~~~~~~~~~~~~~~~~~~~~~~ + +String literals are UTF-8 encoded and stored into ByteStrings in the following +ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals +with the BytesPrimL constructor (see #14741). + +It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite +bad for performance with large strings (see #16198 and #14741). + +To include string literals into output objects, the assembler code generator has +to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] +for more details. + +-} + +instance Binary LitNumType where + put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) + get bh = do + h <- getByte bh + return (toEnum (fromIntegral h)) + +instance Binary Literal where + put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa + put_ bh (LitString ab) = do putByte bh 1; put_ bh ab + put_ bh (LitNullAddr) = do putByte bh 2 + put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah + put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai + put_ bh (LitLabel aj mb fod) + = do putByte bh 5 + put_ bh aj + put_ bh mb + put_ bh fod + put_ bh (LitNumber nt i) + = do putByte bh 6 + put_ bh nt + put_ bh i + put_ bh (LitRubbish) = do putByte bh 7 + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (LitChar aa) + 1 -> do + ab <- get bh + return (LitString ab) + 2 -> do + return (LitNullAddr) + 3 -> do + ah <- get bh + return (LitFloat ah) + 4 -> do + ai <- get bh + return (LitDouble ai) + 5 -> do + aj <- get bh + mb <- get bh + fod <- get bh + return (LitLabel aj mb fod) + 6 -> do + nt <- get bh + i <- get bh + return (LitNumber nt i) + _ -> do + return (LitRubbish) + +instance Outputable Literal where + ppr = pprLiteral id + +instance Eq Literal where + a == b = compare a b == EQ + +-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in +-- 'GHC.Data.TrieMap.CoreMap'. +instance Ord Literal where + compare = cmpLit + +{- + Construction + ~~~~~~~~~~~~ +-} + +{- Note [Word/Int underflow/overflow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and +unsigned integral types): "All arithmetic is performed modulo 2^n, where n is +the number of bits in the type." + +GHC stores Word# and Int# constant values as Integer. Core optimizations such +as constant folding must ensure that the Integer value remains in the valid +target Word/Int range (see #13172). The following functions are used to +ensure this. + +Note that we *don't* warn the user about overflow. It's not done at runtime +either, and compilation of completely harmless things like + ((124076834 :: Word32) + (2147483647 :: Word32)) +doesn't yield a warning. Instead we simply squash the value into the *target* +Int/Word range. +-} + +-- | Wrap a literal number according to its type +wrapLitNumber :: Platform -> Literal -> Literal +wrapLitNumber platform v@(LitNumber nt i) = case nt of + LitNumInt -> case platformWordSize platform of + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) + LitNumWord -> case platformWordSize platform of + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) + LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) + LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) + LitNumInteger -> v + LitNumNatural -> v +wrapLitNumber _ x = x + +-- | Create a numeric 'Literal' of the given type +mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal +mkLitNumberWrap platform nt i = wrapLitNumber platform (LitNumber nt i) + +-- | Check that a given number is in the range of a numeric literal +litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool +litNumCheckRange platform nt i = case nt of + LitNumInt -> platformInIntRange platform i + LitNumWord -> platformInWordRange platform i + LitNumInt64 -> inInt64Range i + LitNumWord64 -> inWord64Range i + LitNumNatural -> i >= 0 + LitNumInteger -> True + +-- | Create a numeric 'Literal' of the given type +mkLitNumber :: Platform -> LitNumType -> Integer -> Literal +mkLitNumber platform nt i = + ASSERT2(litNumCheckRange platform nt i, integer i) + (LitNumber nt i) + +-- | Creates a 'Literal' of type @Int#@ +mkLitInt :: Platform -> Integer -> Literal +mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x ) + (mkLitIntUnchecked x) + +-- | Creates a 'Literal' of type @Int#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrap :: Platform -> Integer -> Literal +mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i + +-- | Creates a 'Literal' of type @Int#@ without checking its range. +mkLitIntUnchecked :: Integer -> Literal +mkLitIntUnchecked i = LitNumber LitNumInt i + +-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating +-- overflow. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the overflow flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitIntWrapC platform i = (n, i /= i') + where + n@(LitNumber _ i') = mkLitIntWrap platform i + +-- | Creates a 'Literal' of type @Word#@ +mkLitWord :: Platform -> Integer -> Literal +mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x ) + (mkLitWordUnchecked x) + +-- | Creates a 'Literal' of type @Word#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrap :: Platform -> Integer -> Literal +mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i + +-- | Creates a 'Literal' of type @Word#@ without checking its range. +mkLitWordUnchecked :: Integer -> Literal +mkLitWordUnchecked i = LitNumber LitNumWord i + +-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating +-- carry. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the carry flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitWordWrapC platform i = (n, i /= i') + where + n@(LitNumber _ i') = mkLitWordWrap platform i + +-- | Creates a 'Literal' of type @Int64#@ +mkLitInt64 :: Integer -> Literal +mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) + +-- | Creates a 'Literal' of type @Int64#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt64Wrap :: Platform -> Integer -> Literal +mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i + +-- | Creates a 'Literal' of type @Int64#@ without checking its range. +mkLitInt64Unchecked :: Integer -> Literal +mkLitInt64Unchecked i = LitNumber LitNumInt64 i + +-- | Creates a 'Literal' of type @Word64#@ +mkLitWord64 :: Integer -> Literal +mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) + +-- | Creates a 'Literal' of type @Word64#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord64Wrap :: Platform -> Integer -> Literal +mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i + +-- | Creates a 'Literal' of type @Word64#@ without checking its range. +mkLitWord64Unchecked :: Integer -> Literal +mkLitWord64Unchecked i = LitNumber LitNumWord64 i + +-- | Creates a 'Literal' of type @Float#@ +mkLitFloat :: Rational -> Literal +mkLitFloat = LitFloat + +-- | Creates a 'Literal' of type @Double#@ +mkLitDouble :: Rational -> Literal +mkLitDouble = LitDouble + +-- | Creates a 'Literal' of type @Char#@ +mkLitChar :: Char -> Literal +mkLitChar = LitChar + +-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to +-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ +mkLitString :: String -> Literal +-- stored UTF-8 encoded +mkLitString s = LitString (bytesFS $ mkFastString s) + +mkLitInteger :: Integer -> Literal +mkLitInteger x = LitNumber LitNumInteger x + +mkLitNatural :: Integer -> Literal +mkLitNatural x = ASSERT2( inNaturalRange x, integer x ) + (LitNumber LitNumNatural x) + +inNaturalRange :: Integer -> Bool +inNaturalRange x = x >= 0 + +inInt64Range, inWord64Range :: Integer -> Bool +inInt64Range x = x >= toInteger (minBound :: Int64) && + x <= toInteger (maxBound :: Int64) +inWord64Range x = x >= toInteger (minBound :: Word64) && + x <= toInteger (maxBound :: Word64) + +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR + +-- | Tests whether the literal represents a zero of whatever type it is +isZeroLit :: Literal -> Bool +isZeroLit (LitNumber _ 0) = True +isZeroLit (LitFloat 0) = True +isZeroLit (LitDouble 0) = True +isZeroLit _ = False + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. +litValue :: Literal -> Integer +litValue l = case isLitValue_maybe l of + Just x -> x + Nothing -> pprPanic "litValue" (ppr l) + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char' and numbers. +isLitValue_maybe :: Literal -> Maybe Integer +isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c +isLitValue_maybe (LitNumber _ i) = Just i +isLitValue_maybe _ = Nothing + +-- | Apply a function to the 'Integer' contained in the 'Literal', for when that +-- makes sense, e.g. for 'Char' and numbers. +-- For fixed-size integral literals, the result will be wrapped in accordance +-- with the semantics of the target type. +-- See Note [Word/Int underflow/overflow] +mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal +mapLitValue _ f (LitChar c) = mkLitChar (fchar c) + where fchar = chr . fromInteger . f . toInteger . ord +mapLitValue platform f (LitNumber nt i) = wrapLitNumber platform (LitNumber nt (f i)) +mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) + +-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', +-- 'Int', 'Word', 'LitInteger' and 'LitNatural'. +isLitValue :: Literal -> Bool +isLitValue = isJust . isLitValue_maybe + +{- + Coercions + ~~~~~~~~~ +-} + +narrow8IntLit, narrow16IntLit, narrow32IntLit, + narrow8WordLit, narrow16WordLit, narrow32WordLit, + char2IntLit, int2CharLit, + float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, + float2DoubleLit, double2FloatLit + :: Literal -> Literal + +word2IntLit, int2WordLit :: Platform -> Literal -> Literal +word2IntLit platform (LitNumber LitNumWord w) + -- Map Word range [max_int+1, max_word] + -- to Int range [min_int , -1] + -- Range [0,max_int] has the same representation with both Int and Word + | w > platformMaxInt platform = mkLitInt platform (w - platformMaxWord platform - 1) + | otherwise = mkLitInt platform w +word2IntLit _ l = pprPanic "word2IntLit" (ppr l) + +int2WordLit platform (LitNumber LitNumInt i) + -- Map Int range [min_int , -1] + -- to Word range [max_int+1, max_word] + -- Range [0,max_int] has the same representation with both Int and Word + | i < 0 = mkLitWord platform (1 + platformMaxWord platform + i) + | otherwise = mkLitWord platform i +int2WordLit _ l = pprPanic "int2WordLit" (ppr l) + +-- | Narrow a literal number (unchecked result range) +narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal +narrowLit _ (LitNumber nt i) = LitNumber nt (toInteger (fromInteger i :: a)) +narrowLit _ l = pprPanic "narrowLit" (ppr l) + +narrow8IntLit = narrowLit (Proxy :: Proxy Int8) +narrow16IntLit = narrowLit (Proxy :: Proxy Int16) +narrow32IntLit = narrowLit (Proxy :: Proxy Int32) +narrow8WordLit = narrowLit (Proxy :: Proxy Word8) +narrow16WordLit = narrowLit (Proxy :: Proxy Word16) +narrow32WordLit = narrowLit (Proxy :: Proxy Word32) + +char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) +char2IntLit l = pprPanic "char2IntLit" (ppr l) +int2CharLit (LitNumber _ i) = LitChar (chr (fromInteger i)) +int2CharLit l = pprPanic "int2CharLit" (ppr l) + +float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) +float2IntLit l = pprPanic "float2IntLit" (ppr l) +int2FloatLit (LitNumber _ i) = LitFloat (fromInteger i) +int2FloatLit l = pprPanic "int2FloatLit" (ppr l) + +double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) +double2IntLit l = pprPanic "double2IntLit" (ppr l) +int2DoubleLit (LitNumber _ i) = LitDouble (fromInteger i) +int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) + +float2DoubleLit (LitFloat f) = LitDouble f +float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) +double2FloatLit (LitDouble d) = LitFloat d +double2FloatLit l = pprPanic "double2FloatLit" (ppr l) + +nullAddrLit :: Literal +nullAddrLit = LitNullAddr + +-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. +rubbishLit :: Literal +rubbishLit = LitRubbish + +{- + Predicates + ~~~~~~~~~~ +-} + +-- | True if there is absolutely no penalty to duplicating the literal. +-- False principally of strings. +-- +-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would +-- blow up code sizes. Not only this, it's also unsafe. +-- +-- Consider a program that wants to traverse a string. One way it might do this +-- is to first compute the Addr# pointing to the end of the string, and then, +-- starting from the beginning, bump a pointer using eqAddr# to determine the +-- end. For instance, +-- +-- @ +-- -- Given pointers to the start and end of a string, count how many zeros +-- -- the string contains. +-- countZeros :: Addr# -> Addr# -> -> Int +-- countZeros start end = go start 0 +-- where +-- go off n +-- | off `addrEq#` end = n +-- | otherwise = go (off `plusAddr#` 1) n' +-- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 +-- | otherwise = n +-- @ +-- +-- Consider what happens if we considered strings to be trivial (and therefore +-- duplicable) and emitted a call like @countZeros "hello"# ("hello"# +-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same +-- string, meaning that an iteration like the above would blow up terribly. +-- This is what happened in #12757. +-- +-- Ultimately the solution here is to make primitive strings a bit more +-- structured, ensuring that the compiler can't inline in ways that will break +-- user code. One approach to this is described in #8472. +litIsTrivial :: Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsTrivial +litIsTrivial (LitString _) = False +litIsTrivial (LitNumber nt _) = case nt of + LitNumInteger -> False + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True +litIsTrivial _ = True + +-- | True if code space does not go bad if we duplicate this literal +litIsDupable :: Platform -> Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsDupable +litIsDupable platform x = case x of + (LitNumber nt i) -> case nt of + LitNumInteger -> platformInIntRange platform i + LitNumNatural -> platformInWordRange platform i + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True + (LitString _) -> False + _ -> True + +litFitsInChar :: Literal -> Bool +litFitsInChar (LitNumber _ i) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False + +litIsLifted :: Literal -> Bool +litIsLifted (LitNumber nt _) = case nt of + LitNumInteger -> True + LitNumNatural -> True + LitNumInt -> False + LitNumInt64 -> False + LitNumWord -> False + LitNumWord64 -> False +litIsLifted _ = False + +{- + Types + ~~~~~ +-} + +-- | Find the Haskell 'Type' the literal occupies +literalType :: Literal -> Type +literalType LitNullAddr = addrPrimTy +literalType (LitChar _) = charPrimTy +literalType (LitString _) = addrPrimTy +literalType (LitFloat _) = floatPrimTy +literalType (LitDouble _) = doublePrimTy +literalType (LitLabel _ _ _) = addrPrimTy +literalType (LitNumber lt _) = case lt of + LitNumInteger -> integerTy + LitNumNatural -> naturalTy + LitNumInt -> intPrimTy + LitNumInt64 -> int64PrimTy + LitNumWord -> wordPrimTy + LitNumWord64 -> word64PrimTy +literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) + where + a = alphaTyVarUnliftedRep + +absentLiteralOf :: TyCon -> Maybe Literal +-- Return a literal of the appropriate primitive +-- TyCon, to use as a placeholder when it doesn't matter +-- Rubbish literals are handled in GHC.Core.Opt.WorkWrap.Utils, because +-- 1. Looking at the TyCon is not enough, we need the actual type +-- 2. This would need to return a type application to a literal +absentLiteralOf tc = lookupUFM absent_lits tc + +absent_lits :: UniqFM TyCon Literal +absent_lits = listToUFM_Directly + -- Explicitly construct the mape from the known + -- keys of these tyCons. + [ (addrPrimTyConKey, LitNullAddr) + , (charPrimTyConKey, LitChar 'x') + , (intPrimTyConKey, mkLitIntUnchecked 0) + , (int64PrimTyConKey, mkLitInt64Unchecked 0) + , (wordPrimTyConKey, mkLitWordUnchecked 0) + , (word64PrimTyConKey, mkLitWord64Unchecked 0) + , (floatPrimTyConKey, LitFloat 0) + , (doublePrimTyConKey, LitDouble 0) + ] + +{- + Comparison + ~~~~~~~~~~ +-} + +cmpLit :: Literal -> Literal -> Ordering +cmpLit (LitChar a) (LitChar b) = a `compare` b +cmpLit (LitString a) (LitString b) = a `compare` b +cmpLit (LitNullAddr) (LitNullAddr) = EQ +cmpLit (LitFloat a) (LitFloat b) = a `compare` b +cmpLit (LitDouble a) (LitDouble b) = a `compare` b +cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b +cmpLit (LitNumber nt1 a) (LitNumber nt2 b) + | nt1 == nt2 = a `compare` b + | otherwise = nt1 `compare` nt2 +cmpLit (LitRubbish) (LitRubbish) = EQ +cmpLit lit1 lit2 + | litTag lit1 < litTag lit2 = LT + | otherwise = GT + +litTag :: Literal -> Int +litTag (LitChar _) = 1 +litTag (LitString _) = 2 +litTag (LitNullAddr) = 3 +litTag (LitFloat _) = 4 +litTag (LitDouble _) = 5 +litTag (LitLabel _ _ _) = 6 +litTag (LitNumber {}) = 7 +litTag (LitRubbish) = 8 + +{- + Printing + ~~~~~~~~ +* See Note [Printing of literals in Core] +-} + +pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc +pprLiteral _ (LitChar c) = pprPrimChar c +pprLiteral _ (LitString s) = pprHsBytes s +pprLiteral _ (LitNullAddr) = text "__NULL" +pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix +pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix +pprLiteral add_par (LitNumber nt i) + = case nt of + LitNumInteger -> pprIntegerVal add_par i + LitNumNatural -> pprIntegerVal add_par i + LitNumInt -> pprPrimInt i + LitNumInt64 -> pprPrimInt64 i + LitNumWord -> pprPrimWord i + LitNumWord64 -> pprPrimWord64 i +pprLiteral add_par (LitLabel l mb fod) = + add_par (text "__label" <+> b <+> ppr fod) + where b = case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) +pprLiteral _ (LitRubbish) = text "__RUBBISH" + +pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc +-- See Note [Printing of literals in Core]. +pprIntegerVal add_par i | i < 0 = add_par (integer i) + | otherwise = integer i + +{- +Note [Printing of literals in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function `add_par` is used to wrap parenthesis around negative integers +(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring +an atomic thing (for example function application). + +Although not all Core literals would be valid Haskell, we are trying to stay +as close as possible to Haskell syntax in the printing of Core, to make it +easier for a Haskell user to read Core. + +To that end: + * We do print parenthesis around negative `LitInteger`, because we print + `LitInteger` using plain number literals (no prefix or suffix), and plain + number literals in Haskell require parenthesis in contexts like function + application (i.e. `1 - -1` is not valid Haskell). + + * We don't print parenthesis around other (negative) literals, because they + aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's + parser). + +Literal Output Output if context requires + an atom (if different) +------- ------- ---------------------- +LitChar 'a'# +LitString "aaa"# +LitNullAddr "__NULL" +LitInt -1# +LitInt64 -1L# +LitWord 1## +LitWord64 1L## +LitFloat -1.0# +LitDouble -1.0## +LitInteger -1 (-1) +LitLabel "__label" ... ("__label" ...) +LitRubbish "__RUBBISH" + +Note [Rubbish literals] +~~~~~~~~~~~~~~~~~~~~~~~ +During worker/wrapper after demand analysis, where an argument +is unused (absent) we do the following w/w split (supposing that +y is absent): + + f x y z = e +===> + f x y z = $wf x z + $wf x z = let y = + in e + +Usually the binding for y is ultimately optimised away, and +even if not it should never be evaluated -- but that's the +way the w/w split starts off. + +What is ? +* For lifted values can be a call to 'error'. +* For primitive types like Int# or Word# we can use any random + value of that type. +* But what about /unlifted/ but /boxed/ types like MutVar# or + Array#? We need a literal value of that type. + +That is 'LitRubbish'. Since we need a rubbish literal for +many boxed, unlifted types, we say that LitRubbish has type + LitRubbish :: forall (a :: TYPE UnliftedRep). a + +So we might see a w/w split like + $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) + in e + +Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted +heap pointers. + +Here are the moving parts: + +* We define LitRubbish as a constructor in GHC.Types.Literal.Literal + +* It is given its polymorphic type by Literal.literalType + +* GHC.Core.Opt.WorkWrap.Utils.mk_absent_let introduces a LitRubbish for absent + arguments of boxed, unlifted type. + +* In CoreToSTG we convert (RubishLit @t) to just (). STG is + untyped, so it doesn't matter that it points to a lifted + value. The important thing is that it is a heap pointer, + which the garbage collector can follow if it encounters it. + + We considered maintaining LitRubbish in STG, and lowering + it in the code generators, but it seems simpler to do it + once and for all in CoreToSTG. + + In GHC.ByteCode.Asm we just lower it as a 0 literal, because + it's all boxed and lifted to the host GC anyway. +-} diff --git a/GHC/Types/Name.hs b/GHC/Types/Name.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name.hs @@ -0,0 +1,729 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Name]{@Name@: to transmit name info from renamer to typechecker} +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name' is the type of names that have had their scoping and +-- binding resolved. They have an 'OccName' but also a 'GHC.Types.Unique.Unique' +-- that disambiguates Names that have the same 'OccName' and indeed is used for all +-- 'Name' comparison. Names also contain information about where they originated +-- from, see "GHC.Types.Name#name_sorts" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" +-- +-- #name_sorts# +-- Names are one of: +-- +-- * External, if they name things declared in other modules. Some external +-- Names are wired in, i.e. they name primitives defined in the compiler itself +-- +-- * Internal, if they name things in the module being compiled. Some internal +-- Names are system names, if they are names manufactured by the compiler + +module GHC.Types.Name ( + -- * The main types + Name, -- Abstract + BuiltInSyntax(..), + + -- ** Creating 'Name's + mkSystemName, mkSystemNameAt, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, + mkSystemVarName, mkSysTvName, + mkFCallName, + mkExternalName, mkWiredInName, + + -- ** Manipulating and deconstructing 'Name's + nameUnique, setNameUnique, + nameOccName, nameNameSpace, nameModule, nameModule_maybe, + setNameLoc, + tidyNameOcc, + localiseName, + + nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + + -- ** Predicates on 'Name's + isSystemName, isInternalName, isExternalName, + isTyVarName, isTyConName, isDataConName, + isValName, isVarName, isDynLinkName, + isWiredInName, isWiredIn, isBuiltInSyntax, + isHoleName, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, nameIsHomePackage, + nameIsHomePackageImport, nameIsFromExternalPackage, + stableNameCmp, + + -- * Class 'NamedThing' and overloaded friends + NamedThing(..), + getSrcLoc, getSrcSpan, getOccString, getOccFS, + + pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, + nameStableString, + + -- Re-export the OccName stuff + module GHC.Types.Name.Occurrence + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing ) + +import GHC.Platform +import GHC.Types.Name.Occurrence +import GHC.Unit.Module +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Binary +import GHC.Data.FastString +import GHC.Utils.Outputable + +import Control.DeepSeq +import Data.Data + +{- +************************************************************************ +* * +\subsection[Name-datatype]{The @Name@ datatype, and name construction} +* * +************************************************************************ +-} + +-- | A unique, unambiguous name for something, containing information about where +-- that thing originated. +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: {-# UNPACK #-} !Unique, + n_loc :: !SrcSpan -- Definition site + } + +-- NOTE: we make the n_loc field strict to eliminate some potential +-- (and real!) space leaks, due to the fact that we don't look at +-- the SrcLoc in a Name all that often. + +-- See Note [About the NameSorts] +data NameSort + = External Module + + | WiredIn Module TyThing BuiltInSyntax + -- A variant of External, for wired-in things + + | Internal -- A user-defined Id or TyVar + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') + +instance Outputable NameSort where + ppr (External _) = text "external" + ppr (WiredIn _ _ _) = text "wired-in" + ppr Internal = text "internal" + ppr System = text "system" + +instance NFData Name where + rnf Name{..} = rnf n_sort + +instance NFData NameSort where + rnf (External m) = rnf m + rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () + -- XXX this is a *lie*, we're not going to rnf the TyThing, but + -- since the TyThings for WiredIn Names are all static they can't + -- be hiding space leaks or errors. + rnf Internal = () + rnf System = () + +-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, +-- which have special syntactic forms. They aren't in scope +-- as such. +data BuiltInSyntax = BuiltInSyntax | UserSyntax + +{- +Note [About the NameSorts] + +1. Initially, top-level Ids (including locally-defined ones) get External names, + and all other local Ids get Internal names + +2. In any invocation of GHC, an External Name for "M.x" has one and only one + unique. This unique association is ensured via the Name Cache; + see Note [The Name Cache] in GHC.Iface.Env. + +3. Things with a External name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @External@ first. + +4. In the tidy-core phase, a External that is not visible to an importer + is changed to Internal, and a Internal that is visible is changed to External + +5. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) + +Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, + not read from an interface file. + E.g. Bool, True, Int, Float, and many others + +All built-in syntax is for wired-in things. +-} + +instance HasOccName Name where + occName = nameOccName + +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameNameSpace :: Name -> NameSpace +nameModule :: HasDebugCallStack => Name -> Module +nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan + +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameNameSpace name = occNameSpace (n_occ name) +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name + +{- +************************************************************************ +* * +\subsection{Predicates on names} +* * +************************************************************************ +-} + +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName _ = False + +isWiredIn :: NamedThing thing => thing -> Bool +isWiredIn = isWiredInName . getName + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe _ = Nothing + +isBuiltInSyntax :: Name -> Bool +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax _ = False + +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName _ = False + +isInternalName name = not (isExternalName name) + +isHoleName :: Name -> Bool +isHoleName = isHoleModule . nameModule + +-- | Will the 'Name' come from a dynamically linked package? +isDynLinkName :: Platform -> Module -> Name -> Bool +isDynLinkName platform this_mod name + | Just mod <- nameModule_maybe name + -- Issue #8696 - when GHC is dynamically linked, it will attempt + -- to load the dynamic dependencies of object files at compile + -- time for things like QuasiQuotes or + -- TemplateHaskell. Unfortunately, this interacts badly with + -- intra-package linking, because we don't generate indirect + -- (dynamic) symbols for intra-package calls. This means that if a + -- module with an intra-package call is loaded without its + -- dependencies, then GHC fails to link. + -- + -- In the mean time, always force dynamic indirections to be + -- generated: when the module name isn't the module being + -- compiled, references are dynamic. + = case platformOS platform of + -- On Windows the hack for #8696 makes it unlinkable. + -- As the entire setup of the code from Cmm down to the RTS expects + -- the use of trampolines for the imported functions only when + -- doing intra-package linking, e.g. referring to a symbol defined in the same + -- package should not use a trampoline. + -- I much rather have dynamic TH not supported than the entire Dynamic linking + -- not due to a hack. + -- Also not sure this would break on Windows anyway. + OSMinGW32 -> moduleUnit mod /= moduleUnit this_mod + + -- For the other platforms, still perform the hack + _ -> mod /= this_mod + + | otherwise = False -- no, it is not even an external name + + +nameModule name = + nameModule_maybe name `orElse` + pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) + +nameModule_maybe :: Name -> Maybe Module +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe _ = Nothing + +nameIsLocalOrFrom :: Module -> Name -> Bool +-- ^ Returns True if the name is +-- (a) Internal +-- (b) External but from the specified module +-- (c) External but from the 'interactive' package +-- +-- The key idea is that +-- False means: the entity is defined in some other module +-- you can find the details (type, fixity, instances) +-- in some interface file +-- those details will be stored in the EPT or HPT +-- +-- True means: the entity is defined in this module or earlier in +-- the GHCi session +-- you can find details (type, fixity, instances) in the +-- TcGblEnv or TcLclEnv +-- +-- The isInteractiveModule part is because successive interactions of a GHCi session +-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come +-- from the magic 'interactive' package; and all the details are kept in the +-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. +-- See Note [The interactive package] in "GHC.Driver.Types" + +nameIsLocalOrFrom from name + | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod + | otherwise = True + +nameIsHomePackage :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +nameIsHomePackage this_mod + = \nm -> case n_sort nm of + External nm_mod -> moduleUnit nm_mod == this_pkg + WiredIn nm_mod _ _ -> moduleUnit nm_mod == this_pkg + Internal -> True + System -> False + where + this_pkg = moduleUnit this_mod + +nameIsHomePackageImport :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +-- /other than/ the this_mod +nameIsHomePackageImport this_mod + = \nm -> case nameModule_maybe nm of + Nothing -> False + Just nm_mod -> nm_mod /= this_mod + && moduleUnit nm_mod == this_pkg + where + this_pkg = moduleUnit this_mod + +-- | Returns True if the Name comes from some other package: neither this +-- package nor the interactive package. +nameIsFromExternalPackage :: Unit -> Name -> Bool +nameIsFromExternalPackage this_unit name + | Just mod <- nameModule_maybe name + , moduleUnit mod /= this_unit -- Not the current unit + , not (isInteractiveModule mod) -- Not the 'interactive' package + = True + | otherwise + = False + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +isTyConName :: Name -> Bool +isTyConName name = isTcOcc (nameOccName name) + +isDataConName :: Name -> Bool +isDataConName name = isDataOcc (nameOccName name) + +isValName :: Name -> Bool +isValName name = isValOcc (nameOccName name) + +isVarName :: Name -> Bool +isVarName = isVarOcc . nameOccName + +isSystemName (Name {n_sort = System}) = True +isSystemName _ = False + +{- +************************************************************************ +* * +\subsection{Making names} +* * +************************************************************************ +-} + +-- | Create a name which is (for now at least) local to the current module and hence +-- does not need a 'Module' to disambiguate it from other 'Name's +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which makes + -- the OccNames distinct when they need to be + +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + +-- | Create a name which definitely originates in the given module +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +-- WATCH OUT! External Names should be in the Name Cache +-- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName +-- with some fresh unique without populating the Name Cache +mkExternalName uniq mod occ loc + = Name { n_uniq = uniq, n_sort = External mod, + n_occ = occ, n_loc = loc } + +-- | Create a name which is actually defined by the compiler itself +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name +mkWiredInName mod occ uniq thing built_in + = Name { n_uniq = uniq, + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } + +-- | Create a name brought into being by the compiler +mkSystemName :: Unique -> OccName -> Name +mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan + +mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name +mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System + , n_occ = occ, n_loc = loc } + +mkSystemVarName :: Unique -> FastString -> Name +mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) + +mkSysTvName :: Unique -> FastString -> Name +mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) + +-- | Make a name for a foreign call +mkFCallName :: Unique -> String -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan + -- The encoded string completely describes the ccall + +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique :: Name -> Unique -> Name +setNameUnique name uniq = name {n_uniq = uniq} + +-- This is used for hsigs: we want to use the name of the originally exported +-- entity, but edit the location to refer to the reexport site +setNameLoc :: Name -> SrcSpan -> Name +setNameLoc name loc = name {n_loc = loc} + +tidyNameOcc :: Name -> OccName -> Name +-- We set the OccName of a Name when tidying +-- In doing so, we change System --> Internal, so that when we print +-- it we don't get the unique by default. It's tidy now! +tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} +tidyNameOcc name occ = name { n_occ = occ } + +-- | Make the 'Name' into an internal name, regardless of what it was to begin with +localiseName :: Name -> Name +localiseName n = n { n_sort = Internal } + +{- +************************************************************************ +* * +\subsection{Hashing and comparison} +* * +************************************************************************ +-} + +cmpName :: Name -> Name -> Ordering +cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 + +-- | Compare Names lexicographically +-- This only works for Names that originate in the source code or have been +-- tidied. +stableNameCmp :: Name -> Name -> Ordering +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + -- The ordinary compare on OccNames is lexicographic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT + +{- +************************************************************************ +* * +\subsection[Name-instances]{Instance declarations} +* * +************************************************************************ +-} + +-- | The same comments as for `Name`'s `Ord` instance apply. +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which +-- means that the ordering is not stable across deserialization or rebuilds. +-- +-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug +-- caused by improper use of this instance. + +-- For a deterministic lexicographic ordering, use `stableNameCmp`. +instance Ord Name where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b + +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" + +{- +************************************************************************ +* * +\subsection{Binary} +* * +************************************************************************ +-} + +-- | Assumes that the 'Name' is a non-binding one. See +-- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for +-- serializing binding 'Name's. See 'UserData' for the rationale for this +-- distinction. +instance Binary Name where + put_ bh name = + case getUserData bh of + UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name + + get bh = + case getUserData bh of + UserData { ud_get_name = get_name } -> get_name bh + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance Outputable Name where + ppr name = pprName name + +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + +pprName :: Name -> SDoc +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = getPprStyle $ \sty -> + getPprDebug $ \debug -> + case sort of + WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin + External mod -> pprExternal debug sty uniq mod occ False UserSyntax + System -> pprSystem debug sty uniq occ + Internal -> pprInternal debug sty uniq occ + +-- | Print the string of Name unqualifiedly directly. +pprNameUnqualified :: Name -> SDoc +pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ + +pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal debug sty uniq mod occ is_wired is_builtin + | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + | debug = pp_mod <> ppr_occ_name occ + <> braces (hsep [if is_wired then text "(w)" else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax + | otherwise = + if isHoleModule mod + then case qualName sty mod occ of + NameUnqual -> ppr_occ_name occ + _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + else pprModulePrefix sty mod occ <> ppr_occ_name occ + where + pp_mod = ppUnlessOption sdocSuppressModulePrefixes + (ppr mod <> dot) + +pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprInternal debug sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style + +-- Like Internal, except that we only omit the unique in Iface style +pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem debug sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debug = ppr_occ_name occ <> ppr_underscore_unique uniq + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique + + +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +-- Print the "M." part of a name, based on whether it's in scope or not +-- See Note [Printing original names] in GHC.Driver.Types +pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ + case qualName sty mod occ of -- See Outputable.QualifyName: + NameQual modname -> ppr modname <> dot -- Name is in scope + NameNotInScope1 -> ppr mod <> dot -- Not in scope + NameNotInScope2 -> ppr (moduleUnit mod) <> colon -- Module not in + <> ppr (moduleName mod) <> dot -- scope either + NameUnqual -> empty -- In scope unqualified + +pprUnique :: Unique -> SDoc +-- Print a unique unless we are suppressing them +pprUnique uniq + = ppUnlessOption sdocSuppressUniques $ + pprUniqueAlways uniq + +ppr_underscore_unique :: Unique -> SDoc +-- Print an underscore separating the name from its unique +-- But suppress it if we aren't printing the uniques anyway +ppr_underscore_unique uniq + = ppUnlessOption sdocSuppressUniques $ + char '_' <> pprUniqueAlways uniq + +ppr_occ_name :: OccName -> SDoc +ppr_occ_name occ = ftext (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above + +-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are +-- cached behind the scenes in the FastString implementation. +ppr_z_occ_name :: OccName -> SDoc +ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) + +-- Prints (if mod information is available) "Defined at " or +-- "Defined in " information for a Name. +pprDefinedAt :: Name -> SDoc +pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name + +pprNameDefnLoc :: Name -> SDoc +-- Prints "at " or +-- or "in " depending on what info is available +pprNameDefnLoc name + = case nameSrcLoc name of + -- nameSrcLoc rather than nameSrcSpan + -- It seems less cluttered to show a location + -- rather than a span for the definition point + RealSrcLoc s _ -> text "at" <+> ppr s + UnhelpfulLoc s + | isInternalName name || isSystemName name + -> text "at" <+> ftext s + | otherwise + -> text "in" <+> quotes (ppr (nameModule name)) + + +-- | Get a string representation of a 'Name' that's unique and stable +-- across recompilations. Used for deterministic generation of binds for +-- derived instances. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" +nameStableString :: Name -> String +nameStableString Name{..} = + nameSortStableString n_sort ++ "$" ++ occNameString n_occ + +nameSortStableString :: NameSort -> String +nameSortStableString System = "$_sys" +nameSortStableString Internal = "$_in" +nameSortStableString (External mod) = moduleStableString mod +nameSortStableString (WiredIn mod _ _) = moduleStableString mod + +{- +************************************************************************ +* * +\subsection{Overloaded functions related to Names} +* * +************************************************************************ +-} + +-- | A class allowing convenient access to the 'Name' of various datatypes +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method + +instance NamedThing e => NamedThing (Located e) where + getName = getName . unLoc + +getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan +getOccString :: NamedThing a => a -> String +getOccFS :: NamedThing a => a -> FastString + +getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName +getOccString = occNameString . getOccName +getOccFS = occNameFS . getOccName + +pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName :: NamedThing a => a -> SDoc +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) + where + name = getName thing diff --git a/GHC/Types/Name.hs-boot b/GHC/Types/Name.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Name.hs-boot @@ -0,0 +1,5 @@ +module GHC.Types.Name where + +import GHC.Prelude () + +data Name diff --git a/GHC/Types/Name/Cache.hs b/GHC/Types/Name/Cache.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Cache.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | The Name Cache +module GHC.Types.Name.Cache + ( lookupOrigNameCache + , extendOrigNameCache + , extendNameCache + , initNameCache + , NameCache(..), OrigNameCache + ) where + +import GHC.Prelude + +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Unique.Supply +import GHC.Builtin.Types +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Builtin.Names + +#include "HsVersions.h" + +{- + +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invocation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. + + +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower +their cost we use two tricks, + + a. We specially encode tuple and sum Names in interface files' symbol tables + to avoid having to look up their names while loading interface files. + Namely these names are encoded as by their Uniques. We know how to get from + a Unique back to the Name which it represents via the mapping defined in + the SumTupleUniques module. See Note [Symbol table representation of names] + in GHC.Iface.Binary and for details. + + b. We don't include them in the Orig name cache but instead parse their + OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with + them. + +Why is the second measure necessary? Good question; afterall, 1) the parser +emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never +needs to looked-up during interface loading due to (a). It turns out that there +are two reasons why we might look up an Orig RdrName for built-in syntax, + + * If you use setRdrNameSpace on an Exact RdrName it may be + turned into an Orig RdrName. + + * Template Haskell turns a BuiltInSyntax Name into a TH.NameG + (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName + (GHC.ThToHs.thRdrName). So, e.g. $(do { reify '(,); ... }) will + go this route (#8954). + +-} + +-- | Per-module cache of original 'OccName's given 'Name's +type OrigNameCache = ModuleEnv (OccEnv Name) + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE + , Just name <- isBuiltInOcc_maybe occ + = -- See Note [Known-key names], 3(c) in GHC.Builtin.Names + -- Special case for tuples; there are too many + -- of them to pre-populate the original-name cache + Just name + + | otherwise + = case lookupModuleEnv nc mod of + Nothing -> Nothing + Just occ_env -> lookupOccEnv occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name + +extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendNameCache nc mod occ name + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) + where + combine _ occ_env = extendOccEnv occ_env occ name + +-- | The NameCache makes sure that there is just one Unique assigned for +-- each original name; i.e. (module-name, occ-name) pair and provides +-- something of a lookup mechanism for those names. +data NameCache + = NameCache { nsUniqs :: !UniqSupply, + -- ^ Supply of uniques + nsNames :: !OrigNameCache + -- ^ Ensures that one original name gets one unique + } + +-- | Return a function to atomically update the name cache. +initNameCache :: UniqSupply -> [Name] -> NameCache +initNameCache us names + = NameCache { nsUniqs = us, + nsNames = initOrigNames names } + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/GHC/Types/Name/Env.hs b/GHC/Types/Name/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Env.hs @@ -0,0 +1,179 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[NameEnv]{@NameEnv@: name environments} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Types.Name.Env ( + -- * Var, Id and TyVar environments (maps) + NameEnv, + + -- ** Manipulating these environments + mkNameEnv, mkNameEnvWith, + emptyNameEnv, isEmptyNameEnv, + unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, + extendNameEnvList, extendNameEnvList_C, + filterNameEnv, anyNameEnv, + plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, + elemNameEnv, mapNameEnv, disjointNameEnv, + + DNameEnv, + + emptyDNameEnv, + lookupDNameEnv, + delFromDNameEnv, filterDNameEnv, + mapDNameEnv, + adjustDNameEnv, alterDNameEnv, extendDNameEnv, + -- ** Dependency analysis + depAnal + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Graph.Directed +import GHC.Types.Name +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Data.Maybe + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +{- +Note [depAnal determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +depAnal is deterministic provided it gets the nodes in a deterministic order. +The order of lists that get_defs and get_uses return doesn't matter, as these +are only used to construct the edges, and stronglyConnCompFromEdgedVertices is +deterministic even when the edges are not in deterministic order as explained +in Note [Deterministic SCC] in GHC.Data.Graph.Directed. +-} + +depAnal :: forall node. + (node -> [Name]) -- Defs + -> (node -> [Name]) -- Uses + -> [node] + -> [SCC node] +-- Perform dependency analysis on a group of definitions, +-- where each definition may define more than one Name +-- +-- The get_defs and get_uses functions are called only once per node +depAnal get_defs get_uses nodes + = stronglyConnCompFromEdgedVerticesUniq graph_nodes + where + graph_nodes = (map mk_node keyed_nodes) :: [Node Int node] + keyed_nodes = nodes `zip` [(1::Int)..] + mk_node (node, key) = + let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node)) + in DigraphNode node key edges + + key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it + key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +-- | Name Environment +type NameEnv a = UniqFM Name a -- Domain is Name + +emptyNameEnv :: NameEnv a +isEmptyNameEnv :: NameEnv a -> Bool +mkNameEnv :: [(Name,a)] -> NameEnv a +mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_CD :: (a->a->a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a +plusNameEnv_CD2 :: (Maybe a->Maybe a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 +disjointNameEnv :: NameEnv a -> NameEnv a -> Bool + +nameEnvElts x = eltsUFM x +emptyNameEnv = emptyUFM +isEmptyNameEnv = isNullUFM +unitNameEnv x y = unitUFM x y +extendNameEnv x y z = addToUFM x y z +extendNameEnvList x l = addListToUFM x l +lookupNameEnv x y = lookupUFM x y +alterNameEnv = alterUFM +mkNameEnv l = listToUFM l +mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) +elemNameEnv x y = elemUFM x y +plusNameEnv x y = plusUFM x y +plusNameEnv_C f x y = plusUFM_C f x y +plusNameEnv_CD f x d y b = plusUFM_CD f x d y b +plusNameEnv_CD2 f x y = plusUFM_CD2 f x y +extendNameEnv_C f x y z = addToUFM_C f x y z +mapNameEnv f x = mapUFM f x +extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendNameEnvList_C x y z = addListToUFM_C x y z +delFromNameEnv x y = delFromUFM x y +delListFromNameEnv x y = delListFromUFM x y +filterNameEnv x y = filterUFM x y +anyNameEnv f x = foldUFM ((||) . f) False x +disjointNameEnv x y = disjointUFM x y + +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) + +-- | Deterministic Name Environment +-- +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why +-- we need DNameEnv. +type DNameEnv a = UniqDFM Name a + +emptyDNameEnv :: DNameEnv a +emptyDNameEnv = emptyUDFM + +lookupDNameEnv :: DNameEnv a -> Name -> Maybe a +lookupDNameEnv = lookupUDFM + +delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a +delFromDNameEnv = delFromUDFM + +filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a +filterDNameEnv = filterUDFM + +mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b +mapDNameEnv = mapUDFM + +adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a +adjustDNameEnv = adjustUDFM + +alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a +alterDNameEnv = alterUDFM + +extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a +extendDNameEnv = addToUDFM diff --git a/GHC/Types/Name/Occurrence.hs b/GHC/Types/Name/Occurrence.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Occurrence.hs @@ -0,0 +1,915 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName' represents names as strings with just a little more information: +-- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or +-- data constructors +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" + +module GHC.Types.Name.Occurrence ( + -- * The 'NameSpace' type + NameSpace, -- Abstract + + nameSpacesRelated, + + -- ** Construction + -- $real_vs_source_data_constructors + tcName, clsName, tcClsName, dataName, varName, + tvName, srcDataName, + + -- ** Pretty Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The 'OccName' type + OccName, -- Abstract, instance of Outputable + pprOccName, + + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkDataOcc, mkDataOccFS, + mkTyVarOcc, mkTyVarOccFS, + mkTcOcc, mkTcOccFS, + mkClsOcc, mkClsOccFS, + mkDFunOcc, + setOccNameSpace, + demoteOccName, + HasOccName(..), + + -- ** Derived 'OccName's + isDerivedOccName, + mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, + mkNewTyCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkSuperDictAuxOcc, + mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkRecFldSelOcc, + mkTyConRepOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, startsWithUnderscore, + + isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + + -- * The 'OccEnv' type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, + lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, + alterOccEnv, pprOccEnv, + + -- * The 'OccSet' type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, + extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, + isEmptyOccSet, intersectOccSet, + filterOccSet, + + -- * Tidying up + TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, + tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + ) where + +import GHC.Prelude + +import GHC.Utils.Misc +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Utils.Outputable +import GHC.Utils.Lexeme +import GHC.Utils.Binary +import Control.DeepSeq +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsection{Name space} +* * +************************************************************************ +-} + +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in GHC.Core.DataCon +-- +-- $real_vs_source_data_constructors +-- There are two forms of data constructor: +-- +-- [Source data constructors] The data constructors mentioned in Haskell source code +-- +-- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type +-- +-- For example: +-- +-- > data T = T !(Int, Int) +-- +-- The source datacon has type @(Int, Int) -> T@ +-- The real datacon has type @Int -> Int -> T@ +-- +-- GHC chooses a representation based on the strictness etc. + +tcName, clsName, tcClsName :: NameSpace +dataName, srcDataName :: NameSpace +tvName, varName :: NameSpace + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space + +tvName = TvName +varName = VarName + +isDataConNameSpace :: NameSpace -> Bool +isDataConNameSpace DataName = True +isDataConNameSpace _ = False + +isTcClsNameSpace :: NameSpace -> Bool +isTcClsNameSpace TcClsName = True +isTcClsNameSpace _ = False + +isTvNameSpace :: NameSpace -> Bool +isTvNameSpace TvName = True +isTvNameSpace _ = False + +isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace _ = False + +isValNameSpace :: NameSpace -> Bool +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace _ = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = text "tv" +pprNameSpaceBrief TcClsName = text "tc" + +-- demoteNameSpace lowers the NameSpace if possible. We can not know +-- in advance, since a TvName can appear in an HsTyVar. +-- See Note [Demotion] in GHC.Rename.Env +demoteNameSpace :: NameSpace -> Maybe NameSpace +demoteNameSpace VarName = Nothing +demoteNameSpace DataName = Nothing +demoteNameSpace TvName = Nothing +demoteNameSpace TcClsName = Just DataName + +{- +************************************************************************ +* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +* * +************************************************************************ +-} + +-- | Occurrence Name +-- +-- In this context that means: +-- "classified (i.e. as a type name, value name, etc) but not qualified +-- and not yet resolved" +data OccName = OccName + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + -- Compares lexicographically, *not* by Unique of the string + compare (OccName sp1 s1) (OccName sp2 s2) + = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id + +instance NFData OccName where + rnf x = x `seq` () + +{- +************************************************************************ +* * +\subsection{Printing} +* * +************************************************************************ +-} + +instance Outputable OccName where + ppr = pprOccName + +instance OutputableBndr OccName where + pprBndr _ = ppr + pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) + pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) + +pprOccName :: OccName -> SDoc +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS occ) + else pp_occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) + where + pp_occ = sdocOption sdocSuppressUniques $ \case + True -> text (strip_th_unique (unpackFS occ)) + False -> ftext occ + + -- See Note [Suppressing uniques in OccNames] + strip_th_unique ('[' : c : _) | isAlphaNum c = [] + strip_th_unique (c : cs) = c : strip_th_unique cs + strip_th_unique [] = [] + +{- +Note [Suppressing uniques in OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is a hack to de-wobblify the OccNames that contain uniques from +Template Haskell that have been turned into a string in the OccName. +See Note [Unique OccNames from Template Haskell] in "GHC.ThToHs" + +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) + +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs + +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s + +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs + +mkDataOcc :: String -> OccName +mkDataOcc = mkOccName dataName + +mkDataOccFS :: FastString -> OccName +mkDataOccFS = mkOccNameFS dataName + +mkTyVarOcc :: String -> OccName +mkTyVarOcc = mkOccName tvName + +mkTyVarOccFS :: FastString -> OccName +mkTyVarOccFS fs = mkOccNameFS tvName fs + +mkTcOcc :: String -> OccName +mkTcOcc = mkOccName tcName + +mkTcOccFS :: FastString -> OccName +mkTcOccFS = mkOccNameFS tcName + +mkClsOcc :: String -> OccName +mkClsOcc = mkOccName clsName + +mkClsOccFS :: FastString -> OccName +mkClsOccFS = mkOccNameFS clsName + +-- demoteOccName lowers the Namespace of OccName. +-- see Note [Demotion] +demoteOccName :: OccName -> Maybe OccName +demoteOccName (OccName space name) = do + space' <- demoteNameSpace space + return $ OccName space' name + +-- Name spaces are related if there is a chance to mean the one when one writes +-- the other, i.e. variables <-> data constructors and type variables <-> type constructors +nameSpacesRelated :: NameSpace -> NameSpace -> Bool +nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 + +otherNameSpace :: NameSpace -> NameSpace +otherNameSpace VarName = DataName +otherNameSpace DataName = VarName +otherNameSpace TvName = TcClsName +otherNameSpace TcClsName = TvName + + + +{- | Other names in the compiler add additional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName + +{- +************************************************************************ +* * + Environments +* * +************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +Note [The Unique of an OccName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, and indeed FastStrings are allocated keys +sequentially starting at 0. + +So we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char representing the name space. This in turn makes it +easy to build an OccEnv. +-} + +instance Uniquable OccName where + -- See Note [The Unique of an OccName] + getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName DataName fs) = mkDataOccUnique fs + getUnique (OccName TvName fs) = mkTvOccUnique fs + getUnique (OccName TcClsName fs) = mkTcOccUnique fs + +newtype OccEnv a = A (UniqFM OccName a) + deriving Data + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt +alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt + +emptyOccEnv = A emptyUFM +unitOccEnv x y = A $ unitUFM x y +extendOccEnv (A x) y z = A $ addToUFM x y z +extendOccEnvList (A x) l = A $ addListToUFM x l +lookupOccEnv (A x) y = lookupUFM x y +mkOccEnv l = A $ listToUFM l +elemOccEnv x (A y) = elemUFM x y +foldOccEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusOccEnv (A x) (A y) = A $ plusUFM x y +plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z +mapOccEnv f (A x) = A $ mapUFM f x +mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +delFromOccEnv (A x) y = A $ delFromUFM x y +delListFromOccEnv (A x) y = A $ delListFromUFM x y +filterOccEnv x (A y) = A $ filterUFM x y +alterOccEnv fn (A y) k = A $ alterUFM fn y k + +instance Outputable a => Outputable (OccEnv a) where + ppr x = pprOccEnv ppr x + +pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc +pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env + +type OccSet = UniqSet OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +filterOccSet = filterUniqSet + +{- +************************************************************************ +* * +\subsection{Predicates and taking them apart} +* * +************************************************************************ +-} + +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc _ = False + +isTvOcc (OccName TvName _) = True +isTvOcc _ = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc _ = False + +-- | /Value/ 'OccNames's are those that are either in +-- the variable or data constructor namespaces +isValOcc :: OccName -> Bool +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc _ = False + +isDataOcc (OccName DataName _) = True +isDataOcc _ = False + +-- | Test if the 'OccName' is a data constructor that starts with +-- a symbol (e.g. @:@, or @[]@) +isDataSymOcc :: OccName -> Bool +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc _ = False +-- Pretty inefficient! + +-- | Test if the 'OccName' is that for any operator (whether +-- it is a data constructor or variable or whatever) +isSymOcc :: OccName -> Bool +isSymOcc (OccName DataName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexSym s +isSymOcc (OccName VarName s) = isLexSym s +isSymOcc (OccName TvName s) = isLexSym s +-- Pretty inefficient! + +parenSymOcc :: OccName -> SDoc -> SDoc +-- ^ Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc + +startsWithUnderscore :: OccName -> Bool +-- ^ Haskell 98 encourages compilers to suppress warnings about unused +-- names in a pattern if they start with @_@: this implements that test +startsWithUnderscore occ = headFS (occNameFS occ) == '_' + +{- +************************************************************************ +* * +\subsection{Making system names} +* * +************************************************************************ + +Here's our convention for splitting up the interface file name space: + + d... dictionary identifiers + (local variables, so no name-clash worries) + +All of these other OccNames contain a mixture of alphabetic +and symbolic characters, and hence cannot possibly clash with +a user-written type or function name + + $f... Dict-fun identifiers (from inst decls) + $dmop Default method for 'op' + $pnC n'th superclass selector for class C + $wf Worker for function 'f' + $sf.. Specialised version of f + D:C Data constructor for dictionary for class C + NTCo:T Coercion connecting newtype T with its representation type + TFCo:R Coercion connecting a data family to its representation type R + +In encoded form these appear as Zdfxxx etc + + :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! + +This knowledge is encoded in the following functions. + +@mk_deriv@ generates an @OccName@ from the prefix and a string. +NB: The string must already be encoded! +-} + +-- | Build an 'OccName' derived from another 'OccName'. +-- +-- Note that the pieces of the name are passed in as a @[FastString]@ so that +-- the whole name can be constructed with a single 'concatFS', minimizing +-- unnecessary intermediate allocations. +mk_deriv :: NameSpace + -> FastString -- ^ A prefix which distinguishes one sort of + -- derived name from another + -> [FastString] -- ^ The name we are deriving from in pieces which + -- will be concatenated. + -> OccName +mk_deriv occ_sp sys_prefix str = + mkOccNameFS occ_sp (concatFS $ sys_prefix : str) + +isDerivedOccName :: OccName -> Bool +-- ^ Test for definitions internally generated by GHC. This predicate +-- is used to suppress printing of internal definitions in some debug prints +isDerivedOccName occ = + case occNameString occ of + '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo + c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions + _other -> False + +isDefaultMethodOcc :: OccName -> Bool +isDefaultMethodOcc occ = + case occNameString occ of + '$':'d':'m':_ -> True + _ -> False + +-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? +-- This is needed as these bindings are renamed differently. +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +isTypeableBindOcc :: OccName -> Bool +isTypeableBindOcc occ = + case occNameString occ of + '$':'t':'c':_ -> True -- mkTyConRepOcc + '$':'t':'r':_ -> True -- Module binding + _ -> False + +mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, + mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkDataTOcc, mkDataCOcc, + mkTyConRepOcc + :: OccName -> OccName + +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkMatcherOcc = mk_simple_deriv varName "$m" +mkBuilderOcc = mk_simple_deriv varName "$b" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" +mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible +mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class +mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" + +-- Used in derived instances for the names of auxilary bindings. +-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. +mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" +mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" +mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" +mkDataTOcc = mk_simple_deriv varName "$t" +mkDataCOcc = mk_simple_deriv varName "$c" + +-- TyConRepName stuff; see Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable +mkTyConRepOcc occ = mk_simple_deriv varName prefix occ + where + prefix | isDataOcc occ = "$tc'" + | otherwise = "$tc" + +-- Generic deriving mechanism +mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" + +-- Overloaded record field selectors +mkRecFldSelOcc :: String -> OccName +mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] + +mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName +mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ + +mkSuperDictAuxOcc :: Int -> OccName -> OccName +mkSuperDictAuxOcc index cls_tc_occ + = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] + +mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 + -> OccName -- ^ Class, e.g. @Ord@ + -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ +mkSuperDictSelOcc index cls_tc_occ + = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] + +mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' + -> OccName -- ^ Local name, e.g. @sat@ + -> OccName -- ^ Nice unique version, e.g. @$L23sat@ +mkLocalOcc uniq occ + = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] + -- The Unique might print with characters + -- that need encoding (e.g. 'z'!) + +-- | Derive a name for the representation type constructor of a +-- @data@\/@newtype@ instance. +mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ @R:Map@ +mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) + +mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. + -- Only used in debug mode, for extra clarity + -> Bool -- ^ Is this a hs-boot instance DFun? + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot set + = chooseUniqueOcc VarName (prefix ++ info_str) set + where + prefix | is_boot = "$fx" + | otherwise = "$f" + +{- +Sometimes we need to pick an OccName that has not already been used, +given a set of in-use OccNames. +-} + +chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName +chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) + where + loop occ n + | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) + | otherwise = occ + +{- +We used to add a '$m' to indicate a method, but that gives rise to bad +error messages from the type checker when we print the function name or pattern +of an instance-decl binding. Why? Because the binding is zapped +to use the method name in place of the selector name. +(See GHC.Tc.TyCl.Class.tcMethodBind) + +The way it is now, -ddump-xx output may look confusing, but +you can always say -dppr-debug to get the uniques. + +However, we *do* have to zap the first character to be lower case, +because overloaded constructors (blarg) generate methods too. +And convert to VarName space + +e.g. a call to constructor MkFoo where + data (Ord a) => Foo a = MkFoo a + +If this is necessary, we do it by prefixing '$m'. These +guys never show up in error messages. What a hack. +-} + +mkMethodOcc :: OccName -> OccName +mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ + +{- +************************************************************************ +* * +\subsection{Tidying them up} +* * +************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +Note [TidyOccEnv] +~~~~~~~~~~~~~~~~~ +type TidyOccEnv = UniqFM Int + +* Domain = The OccName's FastString. These FastStrings are "taken"; + make sure that we don't re-use + +* Int, n = A plausible starting point for new guesses + There is no guarantee that "FSn" is available; + you must look that up in the TidyOccEnv. But + it's a good place to start looking. + +* When looking for a renaming for "foo2" we strip off the "2" and start + with "foo". Otherwise if we tidy twice we get silly names like foo23. + + However, if it started with digits at the end, we always make a name + with digits at the end, rather than shortening "foo2" to just "foo", + even if "foo" is unused. Reasons: + - Plain "foo" might be used later + - We use trailing digits to subtly indicate a unification variable + in typechecker error message; see TypeRep.tidyTyVarBndr + +We have to take care though! Consider a machine-generated module (#10370) + module Foo where + a1 = e1 + a2 = e2 + ... + a2000 = e2000 +Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, +we have to do a linear search to find a free one, "a2001". That might just be +acceptable once. But if we now come across "a8" again, we don't want to repeat +that search. + +So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for +starting the search; and we make sure to update the starting point for "a" +after we allocate a new one. + + +Note [Tidying multiple names at once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider + + > :t (id,id,id) + +Every id contributes a type variable to the type signature, and all of them are +"a". If we tidy them one by one, we get + + (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) + +which is a bit unfortunate, as it unfairly renames only two of them. What we +would like to see is + + (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) + +To achieve this, the function avoidClashesOccEnv can be used to prepare the +TidyEnv, by “blocking” every name that occurs twice in the map. This way, none +of the "a"s will get the privilege of keeping this name, and all of them will +get a suitable number by tidyOccName. + +This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs +for an example where this is used. + +This is #12382. + +-} + +type TidyOccEnv = UniqFM FastString Int -- The in-scope OccNames + -- See Note [TidyOccEnv] + +emptyTidyOccEnv :: TidyOccEnv +emptyTidyOccEnv = emptyUFM + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl' add emptyUFM + where + add env (OccName _ fs) = addToUFM env fs 1 + +delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv +delTidyOccEnvList = delListFromUFM + +-- see Note [Tidying multiple names at once] +avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv +avoidClashesOccEnv env occs = go env emptyUFM occs + where + go env _ [] = env + go env seenOnce ((OccName _ fs):occs) + | fs `elemUFM` env = go env seenOnce occs + | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs + | otherwise = go env (addToUFM seenOnce fs ()) occs + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) +tidyOccName env occ@(OccName occ_sp fs) + | not (fs `elemUFM` env) + = -- Desired OccName is free, so use it, + -- and record in 'env' that it's no longer available + (addToUFM env fs 1, occ) + + | otherwise + = case lookupUFM env base1 of + Nothing -> (addToUFM env base1 2, OccName occ_sp base1) + Just n -> find 1 n + where + base :: String -- Drop trailing digits (see Note [TidyOccEnv]) + base = dropWhileEndLE isDigit (unpackFS fs) + base1 = mkFastString (base ++ "1") + + find !k !n + = case lookupUFM env new_fs of + Just {} -> find (k+1 :: Int) (n+k) + -- By using n+k, the n argument to find goes + -- 1, add 1, add 2, add 3, etc which + -- moves at quadratic speed through a dense patch + + Nothing -> (new_env, OccName occ_sp new_fs) + where + new_fs = mkFastString (base ++ show n) + new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) + -- Update: base1, so that next time we'll start where we left off + -- new_fs, so that we know it is taken + -- If they are the same (n==1), the former wins + -- See Note [TidyOccEnv] + + +{- +************************************************************************ +* * + Binary instance + Here rather than in GHC.Iface.Binary because OccName is abstract +* * +************************************************************************ +-} + +instance Binary NameSpace where + put_ bh VarName = do + putByte bh 0 + put_ bh DataName = do + putByte bh 1 + put_ bh TvName = do + putByte bh 2 + put_ bh TcClsName = do + putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> do return VarName + 1 -> do return DataName + 2 -> do return TvName + _ -> do return TcClsName + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) diff --git a/GHC/Types/Name/Occurrence.hs-boot b/GHC/Types/Name/Occurrence.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Occurrence.hs-boot @@ -0,0 +1,5 @@ +module GHC.Types.Name.Occurrence where + +import GHC.Prelude () + +data OccName diff --git a/GHC/Types/Name/Reader.hs b/GHC/Types/Name/Reader.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Reader.hs @@ -0,0 +1,1393 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName' is the type of names that come directly from the parser. They +-- have not yet had their scoping and binding resolved by the renamer and can be +-- thought of to a first approximation as an 'GHC.Types.Name.Occurrence.OccName' with an optional module +-- qualifier +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" + +module GHC.Types.Name.Reader ( + -- * The main type + RdrName(..), -- Constructors exported only to GHC.Iface.Binary + + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + + -- ** Destruction + rdrNameOcc, rdrNameSpace, demoteRdrName, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + + -- * Local mapping of 'RdrName' to 'Name.Name' + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, + lookupLocalRdrEnv, lookupLocalRdrOcc, + elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, delLocalRdrEnvList, + + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, + pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, + lookupGRE_Name_OccName, + getGRE_NameQualifier_maybes, + transformGREs, pickGREs, pickGREsModExp, + + -- * GlobalRdrElts + gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, + greRdrNames, greSrcSpan, greQualModName, + gresToAvailInfo, + + -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' + GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel, + unQualOK, qualSpecOK, unQualSpecOK, + pprNameProvenance, + Parent(..), greParent_maybe, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, isExplicitItem, bestImport, + + -- * Utils for StarIsType + starInfo + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Name.Set +import GHC.Data.Maybe +import GHC.Types.SrcLoc as SrcLoc +import GHC.Data.FastString +import GHC.Types.FieldLabel +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Misc as Utils +import GHC.Types.Name.Env + +import Data.Data +import Data.List( sortBy ) + +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', +-- 'GHC.Parser.Annotation.AnnOpen' @'('@ or @'['@ or @'[:'@, +-- 'GHC.Parser.Annotation.AnnClose' @')'@ or @']'@ or @':]'@,, +-- 'GHC.Parser.Annotation.AnnBackquote' @'`'@, +-- 'GHC.Parser.Annotation.AnnVal' +-- 'GHC.Parser.Annotation.AnnTilde', + +-- For details on above see note [Api annotations] in "GHC.Parser.Annotation" +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + +{- +************************************************************************ +* * +\subsection{Simple functions} +* * +************************************************************************ +-} + +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +rdrNameSpace :: RdrName -> NameSpace +rdrNameSpace = occNameSpace . rdrNameOcc + +-- demoteRdrName lowers the NameSpace of RdrName. +-- see Note [Demotion] in GHC.Types.Name.Occurrence +demoteRdrName :: RdrName -> Maybe RdrName +demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +demoteRdrName (Orig _ _) = Nothing +demoteRdrName (Exact _) = Nothing + + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and +-- the 'OccName' are taken from the first and second elements of the tuple respectively +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + +isRdrDataCon :: RdrName -> Bool +isRdrTyVar :: RdrName -> Bool +isRdrTc :: RdrName -> Bool + +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName :: RdrName -> Bool +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual :: RdrName -> Bool +isUnqual (Unqual _) = True +isUnqual _ = False + +isQual :: RdrName -> Bool +isQual (Qual _ _) = True +isQual _ = False + +isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + +isOrig :: RdrName -> Bool +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe :: RdrName -> Maybe (Module, OccName) +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact :: RdrName -> Bool +isExact (Exact _) = True +isExact _ = False + +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT + +{- +************************************************************************ +* * + LocalRdrEnv +* * +************************************************************************ +-} + +-- | Local Reader Environment +-- +-- This environment is used to store local bindings +-- (@let@, @where@, lambda, @case@). +-- It is keyed by OccName, because we never use it for qualified names +-- We keep the current mapping, *and* the set of all Names in scope +-- Reason: see Note [Splicing Exact names] in "GHC.Rename.Env" +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (text "LocalRdrEnv {") + 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env + , text "in_scope =" + <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) + ] <+> char '}') + where + ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name + -- So we can see if the keys line up correctly + +emptyLocalRdrEnv :: LocalRdrEnv +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv + , lre_in_scope = emptyNameSet } + +extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv +-- The Name should be a non-top-level thing +extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name + = WARN( isExternalName name, ppr name ) + lre { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = extendNameSet ns name } + +extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names + = WARN( any isExternalName names, ppr names ) + lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = extendNameSetList ns names } + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr + | Unqual occ <- rdr + = lookupOccEnv env occ + + -- See Note [Local bindings with Exact Names] + | Exact name <- rdr + , name `elemNameSet` ns + = Just name + + | otherwise + = Nothing + +lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns + +delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +delLocalRdrEnvList lre@(LRE { lre_env = env }) occs + = lre { lre_env = delListFromOccEnv env occs } + +{- +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in GHC.Rename.HsType.bindHsQTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + +************************************************************************ +* * + GlobalRdrEnv +* * +************************************************************************ +-} + +-- | Global Reader Environment +type GlobalRdrEnv = OccEnv [GlobalRdrElt] +-- ^ Keyed by 'OccName'; when looking up a qualified name +-- we look up the 'OccName' part, and then check the 'Provenance' +-- to see if the appropriate qualification is valid. This +-- saves routinely doubling the size of the env by adding both +-- qualified and unqualified names to the domain. +-- +-- The list in the codomain is required because there may be name clashes +-- These only get reported on lookup, not on construction +-- +-- INVARIANT 1: All the members of the list have distinct +-- 'gre_name' fields; that is, no duplicate Names +-- +-- INVARIANT 2: Imported provenance => Name is an ExternalName +-- However LocalDefs can have an InternalName. This +-- happens only when type-checking a [d| ... |] Template +-- Haskell quotation; see this note in GHC.Rename.Names +-- Note [Top-level Names in Template Haskell decl quotes] +-- +-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then +-- greOccName gre = occ +-- +-- NB: greOccName gre is usually the same as +-- nameOccName (gre_name gre), but not always in the +-- case of record selectors; see greOccName + +-- | Global Reader Element +-- +-- An element of the 'GlobalRdrEnv' +data GlobalRdrElt + = GRE { gre_name :: Name + , gre_par :: Parent + , gre_lcl :: Bool -- ^ True <=> the thing was defined locally + , gre_imp :: [ImportSpec] -- ^ In scope through these imports + } deriving (Data, Eq) + -- INVARIANT: either gre_lcl = True or gre_imp is non-empty + -- See Note [GlobalRdrElt provenance] + +-- | The children of a Name are the things that are abbreviated by the ".." +-- notation in export lists. See Note [Parents] +data Parent = NoParent + | ParentIs { par_is :: Name } + | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } + -- ^ See Note [Parents for record fields] + deriving (Eq, Data) + +instance Outputable Parent where + ppr NoParent = empty + ppr (ParentIs n) = text "parent:" <> ppr n + ppr (FldParent n f) = text "fldparent:" + <> ppr n <> colon <> ppr f + +plusParent :: Parent -> Parent -> Parent +-- See Note [Combining parents] +plusParent p1@(ParentIs _) p2 = hasParent p1 p2 +plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 +plusParent p1 p2@(ParentIs _) = hasParent p2 p1 +plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 +plusParent _ _ = NoParent + +hasParent :: Parent -> Parent -> Parent +#if defined(DEBUG) +hasParent p NoParent = p +hasParent p p' + | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree +#endif +hasParent p _ = p + + +{- Note [GlobalRdrElt provenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", +i.e. how the Name came to be in scope. It can be in scope two ways: + - gre_lcl = True: it is bound in this module + - gre_imp: a list of all the imports that brought it into scope + +It's an INVARIANT that you have one or the other; that is, either +gre_lcl is True, or gre_imp is non-empty. + +It is just possible to have *both* if there is a module loop: a Name +is defined locally in A, and also brought into scope by importing a +module that SOURCE-imported A. Example (#7672): + + A.hs-boot module A where + data T + + B.hs module B(Decl.T) where + import {-# SOURCE #-} qualified A as Decl + + A.hs module A where + import qualified B + data T = Z | S B.T + +In A.hs, 'T' is locally bound, *and* imported as B.T. + +Note [Parents] +~~~~~~~~~~~~~~~~~ + Parent Children +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + data T Data constructors + Record-field ids + + data family T Data constructors and record-field ids + of all visible data instances of T + + class C Class operations + Associated type constructors + +~~~~~~~~~~~~~~~~~~~~~~~~~ + Constructor Meaning + ~~~~~~~~~~~~~~~~~~~~~~~~ + NoParent Can not be bundled with a type constructor. + ParentIs n Can be bundled with the type constructor corresponding to + n. + FldParent See Note [Parents for record fields] + + + + +Note [Parents for record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record fields, in addition to the Name of the type constructor +(stored in par_is), we use FldParent to store the field label. This +extra information is used for identifying overloaded record fields +during renaming. + +In a definition arising from a normal module (without +-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the +field's label is the same as the OccName of the selector's Name. The +GlobalRdrEnv will contain an entry like this: + + "x" |-> GRE x (FldParent T Nothing) LocalDef + +When -XDuplicateRecordFields is enabled for the module that contains +T, the selector's Name will be mangled (see comments in GHC.Types.FieldLabel). +Thus we store the actual field label in par_lbl, and the GlobalRdrEnv +entry looks like this: + + "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef + +Note that the OccName used when adding a GRE to the environment +(greOccName) now depends on the parent field: for FldParent it is the +field label, if present, rather than the selector name. + +~~ + +Record pattern synonym selectors are treated differently. Their parent +information is `NoParent` in the module in which they are defined. This is because +a pattern synonym `P` has no parent constructor either. + +However, if `f` is bundled with a type constructor `T` then whenever `f` is +imported the parent will use the `Parent` constructor so the parent of `f` is +now `T`. + + +Note [Combining parents] +~~~~~~~~~~~~~~~~~~~~~~~~ +With an associated type we might have + module M where + class C a where + data T a + op :: T a -> a + instance C Int where + data T Int = TInt + instance C Bool where + data T Bool = TBool + +Then: C is the parent of T + T is the parent of TInt and TBool +So: in an export list + C(..) is short for C( op, T ) + T(..) is short for T( TInt, TBool ) + +Module M exports everything, so its exports will be + AvailTC C [C,T,op] + AvailTC T [T,TInt,TBool] +On import we convert to GlobalRdrElt and then combine +those. For T that will mean we have + one GRE with Parent C + one GRE with NoParent +That's why plusParent picks the "best" case. +-} + +-- | make a 'GlobalRdrEnv' where all the elements point to the same +-- Provenance (useful for "hiding" imports, or imports with no details). +gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] +-- prov = Nothing => locally bound +-- Just spec => imported as described by spec +gresFromAvails prov avails + = concatMap (gresFromAvail (const prov)) avails + +localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] +-- Turn an Avail into a list of LocalDef GlobalRdrElts +localGREsFromAvail = gresFromAvail (const Nothing) + +gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] +gresFromAvail prov_fn avail + = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) + where + mk_gre n + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = [is] } + + mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = n }) + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = False, gre_imp = [is] } + where + mb_lbl | is_overloaded = Just lbl + | otherwise = Nothing + + +greQualModName :: GlobalRdrElt -> ModuleName +-- Get a suitable module qualifier for the GRE +-- (used in mkPrintUnqualified) +-- Prerecondition: the gre_name is always External +greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + | lcl, Just mod <- nameModule_maybe name = moduleName mod + | (is:_) <- iss = is_as (is_decl is) + | otherwise = pprPanic "greQualModName" (ppr gre) + +greRdrNames :: GlobalRdrElt -> [RdrName] +greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } + = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) + where + occ = greOccName gre + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) + | lcl = nameSrcSpan name + | (is:_) <- iss = is_dloc (is_decl is) + | otherwise = pprPanic "greSrcSpan" (ppr gre) + +mkParent :: Name -> AvailInfo -> Parent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _ _) | n == m = NoParent + | otherwise = ParentIs m + +greParent_maybe :: GlobalRdrElt -> Maybe Name +greParent_maybe gre = case gre_par gre of + NoParent -> Nothing + ParentIs n -> Just n + FldParent n _ -> Just n + +-- | Takes a list of distinct GREs and folds them +-- into AvailInfos. This is more efficient than mapping each individual +-- GRE to an AvailInfo and the folding using `plusAvail` but needs the +-- uniqueness assumption. +gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] +gresToAvailInfo gres + = nameEnvElts avail_env + where + avail_env :: NameEnv AvailInfo -- Keyed by the parent + (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres + + add :: (NameEnv AvailInfo, NameSet) + -> GlobalRdrElt + -> (NameEnv AvailInfo, NameSet) + add (env, done) gre + | name `elemNameSet` done + = (env, done) -- Don't insert twice into the AvailInfo + | otherwise + = ( extendNameEnv_Acc comb availFromGRE env key gre + , done `extendNameSet` name ) + where + name = gre_name gre + key = case greParent_maybe gre of + Just parent -> parent + Nothing -> gre_name gre + + -- We want to insert the child `k` into a list of children but + -- need to maintain the invariant that the parent is first. + -- + -- We also use the invariant that `k` is not already in `ns`. + insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] + insertChildIntoChildren _ [] k = [k] + insertChildIntoChildren p (n:ns) k + | p == k = k:n:ns + | otherwise = n:k:ns + + comb :: GlobalRdrElt -> AvailInfo -> AvailInfo + comb _ (Avail n) = Avail n -- Duplicated name, should not happen + comb gre (AvailTC m ns fls) + = case gre_par gre of + NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls + FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) + +availFromGRE :: GlobalRdrElt -> AvailInfo +availFromGRE (GRE { gre_name = me, gre_par = parent }) + = case parent of + ParentIs p -> AvailTC p [me] [] + NoParent | isTyConName me -> AvailTC me [me] [] + | otherwise -> avail me + FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] + +mkFieldLabel :: Name -> Maybe FastString -> FieldLabel +mkFieldLabel me mb_lbl = + case mb_lbl of + Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) + , flIsOverloaded = False + , flSelector = me } + Just lbl -> FieldLabel { flLabel = lbl + , flIsOverloaded = True + , flSelector = me } + +emptyGlobalRdrEnv :: GlobalRdrEnv +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +instance Outputable GlobalRdrElt where + ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) + 2 (pprNameProvenance gre) + +pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc +pprGlobalRdrEnv locals_only env + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) + <+> lbrace + , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] + <+> rbrace) ] + where + remove_locals gres | locals_only = filter isLocalGRE gres + | otherwise = gres + pp [] = empty + pp gres = hang (ppr occ + <+> parens (text "unique" <+> ppr (getUnique occ)) + <> colon) + 2 (vcat (map ppr gres)) + where + occ = nameOccName (gre_name (head gres)) + +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of + Nothing -> [] + Just gres -> gres + +greOccName :: GlobalRdrElt -> OccName +greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl +greOccName gre = nameOccName (gre_name gre) + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env (rdrNameOcc rdr_name) of + Nothing -> [] + Just gres -> pickGREs rdr_name gres + +lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment. This tests +-- whether it is in scope, ignoring anything else that might be in +-- scope with the same 'OccName'. +lookupGRE_Name env name + = lookupGRE_Name_OccName env name (nameOccName name) + +lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt +-- ^ Look for a particular record field selector in the environment, where the +-- selector name and field label may be different: the GlobalRdrEnv is keyed on +-- the label. See Note [Parents for record fields] for why this happens. +lookupGRE_FieldLabel env fl + = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) + +lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' +-- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and +-- Note [Parents for record fields]. +lookupGRE_Name_OccName env name occ + = case [ gre | gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] of + [] -> Nothing + [gre] -> Just gre + gres -> pprPanic "lookupGRE_Name_OccName" + (ppr name $$ ppr occ $$ ppr gres) + -- See INVARIANT 1 on GlobalRdrEnv + + +getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" +-- [] means the thing is not in scope at all +getGRE_NameQualifier_maybes env name + = case lookupGRE_Name env name of + Just gre -> [qualifier_maybe gre] + Nothing -> [] + where + qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl = Nothing + | otherwise = Just $ map (is_as . is_decl) iss + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_lcl = lcl }) = lcl + +isRecFldGRE :: GlobalRdrElt -> Bool +isRecFldGRE (GRE {gre_par = FldParent{}}) = True +isRecFldGRE _ = False + +isOverloadedRecFldGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with DuplicateRecordFields? +-- (See Note [Parents for record fields]) +isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True +isOverloadedRecFldGRE _ = False + +-- Returns the field label of this GRE, if it has one +greLabel :: GlobalRdrElt -> Maybe FieldLabelString +greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl +greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) +greLabel _ = Nothing + +unQualOK :: GlobalRdrElt -> Bool +-- ^ Test if an unqualified version of this thing would be in scope +unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) + | lcl = True + | otherwise = any unQualSpecOK iss + +{- Note [GRE filtering] +~~~~~~~~~~~~~~~~~~~~~~~ +(pickGREs rdr gres) takes a list of GREs which have the same OccName +as 'rdr', say "x". It does two things: + +(a) filters the GREs to a subset that are in scope + * Qualified, as 'M.x' if want_qual is Qual M _ + * Unqualified, as 'x' if want_unqual is Unqual _ + +(b) for that subset, filter the provenance field (gre_lcl and gre_imp) + to ones that brought it into scope qualified or unqualified resp. + +Example: + module A ( f ) where + import qualified Foo( f ) + import Baz( f ) + f = undefined + +Let's suppose that Foo.f and Baz.f are the same entity really, but the local +'f' is different, so there will be two GREs matching "f": + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] + +The use of "f" in the export list is ambiguous because it's in scope +from the local def and the import Baz(f); but *not* the import qualified Foo. +pickGREs returns two GRE + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Bar ] + +Now the "ambiguous occurrence" message can correctly report how the +ambiguity arises. +-} + +pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +-- ^ Takes a list of GREs which have the right OccName 'x' +-- Pick those GREs that are in scope +-- * Qualified, as 'M.x' if want_qual is Qual M _ +-- * Unqualified, as 'x' if want_unqual is Unqual _ +-- +-- Return each such GRE, with its ImportSpecs filtered, to reflect +-- how it is in scope qualified or unqualified respectively. +-- See Note [GRE filtering] +pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres +pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres +pickGREs _ _ = [] -- I don't think this actually happens + +pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt +pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl, null iss' = Nothing + | otherwise = Just (gre { gre_imp = iss' }) + where + iss' = filter unQualSpecOK iss + +pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt +pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) + | not lcl', null iss' = Nothing + | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) + where + iss' = filter (qualSpecOK mod) iss + lcl' = lcl && name_is_from mod n + + name_is_from :: ModuleName -> Name -> Bool + name_is_from mod name = case nameModule_maybe name of + Just n_mod -> moduleName n_mod == mod + Nothing -> False + +pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] +-- ^ Pick GREs that are in scope *both* qualified *and* unqualified +-- Return each GRE that is, as a pair +-- (qual_gre, unqual_gre) +-- These two GREs are the original GRE with imports filtered to express how +-- it is in scope qualified an unqualified respectively +-- +-- Used only for the 'module M' item in export list; +-- see 'GHC.Tc.Gen.Export.exports_from_avail' +pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres + +pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) +pickBothGRE mod gre@(GRE { gre_name = n }) + | isBuiltInSyntax n = Nothing + | Just gre1 <- pickQualGRE mod gre + , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) + | otherwise = Nothing + where + -- isBuiltInSyntax filter out names for built-in syntax They + -- just clutter up the environment (esp tuples), and the + -- parser will generate Exact RdrNames for them, so the + -- cluttered envt is no use. Really, it's only useful for + -- GHC.Base and GHC.Tuple. + +-- Building GlobalRdrEnvs + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_Acc insertGRE Utils.singleton env + (greOccName gre) + gre + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1 + , gre_lcl = gre_lcl g1 || gre_lcl g2 + , gre_imp = gre_imp g1 ++ gre_imp g2 + , gre_par = gre_par g1 `plusParent` gre_par g2 } + +transformGREs :: (GlobalRdrElt -> GlobalRdrElt) + -> [OccName] + -> GlobalRdrEnv -> GlobalRdrEnv +-- ^ Apply a transformation function to the GREs for these OccNames +transformGREs trans_gre occs rdr_env + = foldr trans rdr_env occs + where + trans occ env + = case lookupOccEnv env occ of + Just gres -> extendOccEnv env occ (map trans_gre gres) + Nothing -> env + +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre + = extendOccEnv_Acc insertGRE Utils.singleton env + (greOccName gre) gre + +shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv +shadowNames = foldl' shadowName + +{- Note [GlobalRdrEnv shadowing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before adding new names to the GlobalRdrEnv we nuke some existing entries; +this is "shadowing". The actual work is done by RdrEnv.shadowName. +Suppose + env' = shadowName env M.f + +Then: + * Looking up (Unqual f) in env' should succeed, returning M.f, + even if env contains existing unqualified bindings for f. + They are shadowed + + * Looking up (Qual M.f) in env' should succeed, returning M.f + + * Looking up (Qual X.f) in env', where X /= M, should be the same as + looking up (Qual X.f) in env. + That is, shadowName does /not/ delete earlier qualified bindings + +There are two reasons for shadowing: + +* The GHCi REPL + + - Ids bought into scope on the command line (eg let x = True) have + External Names, like Ghci4.x. We want a new binding for 'x' (say) + to override the existing binding for 'x'. Example: + + ghci> :load M -- Brings `x` and `M.x` into scope + ghci> x + ghci> "Hello" + ghci> M.x + ghci> "hello" + ghci> let x = True -- Shadows `x` + ghci> x -- The locally bound `x` + -- NOT an ambiguous reference + ghci> True + ghci> M.x -- M.x is still in scope! + ghci> "Hello" + So when we add `x = True` we must not delete the `M.x` from the + `GlobalRdrEnv`; rather we just want to make it "qualified only"; + hence the `mk_fake-imp_spec` in `shadowName`. See also Note + [Interactively-bound Ids in GHCi] in GHC.Driver.Types + + - Data types also have External Names, like Ghci4.T; but we still want + 'T' to mean the newly-declared 'T', not an old one. + +* Nested Template Haskell declaration brackets + See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + + Consider a TH decl quote: + module M where + f x = h [d| f = ...f...M.f... |] + We must shadow the outer unqualified binding of 'f', else we'll get + a complaint when extending the GlobalRdrEnv, saying that there are + two bindings for 'f'. There are several tricky points: + + - This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. + + - The External Name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + - We only shadow *External* names (which come from the main module), + or from earlier GHCi commands. Do not shadow *Internal* names + because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + At that stage, the class op 'f' will have an Internal name. +-} + +shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv +-- Remove certain old GREs that share the same OccName as this new Name. +-- See Note [GlobalRdrEnv shadowing] for details +shadowName env name + = alterOccEnv (fmap alter_fn) env (nameOccName name) + where + alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] + alter_fn gres = mapMaybe (shadow_with name) gres + + shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt + shadow_with new_name + old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) + = case nameModule_maybe old_name of + Nothing -> Just old_gre -- Old name is Internal; do not shadow + Just old_mod + | Just new_mod <- nameModule_maybe new_name + , new_mod == old_mod -- Old name same as new name; shadow completely + -> Nothing + + | null iss' -- Nothing remains + -> Nothing + + | otherwise + -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + + where + iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss + lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] + | otherwise = [] + + mk_fake_imp_spec old_name old_mod -- Urgh! + = ImpSpec id_spec ImpAll + where + old_mod_name = moduleName old_mod + id_spec = ImpDeclSpec { is_mod = old_mod_name + , is_as = old_mod_name + , is_qual = True + , is_dloc = nameSrcSpan old_name } + + shadow_is :: Name -> ImportSpec -> Maybe ImportSpec + shadow_is new_name is@(ImpSpec { is_decl = id_spec }) + | Just new_mod <- nameModule_maybe new_name + , is_as id_spec == moduleName new_mod + = Nothing -- Shadow both qualified and unqualified + | otherwise -- Shadow unqualified only + = Just (is { is_decl = id_spec { is_qual = True } }) + + +{- +************************************************************************ +* * + ImportSpec +* * +************************************************************************ +-} + +-- | Import Specification +-- +-- The 'ImportSpec' of something says how it came to be imported +-- It's quite elaborate so that we can give accurate unused-name warnings. +data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, + is_item :: ImpItemSpec } + deriving( Eq, Data ) + +-- | Import Declaration Specification +-- +-- Describes a particular import declaration and is +-- shared among all the 'Provenance's for that decl +data ImpDeclSpec + = ImpDeclSpec { + is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ + -- Note the @Muggle@ may well not be + -- the defining module for this thing! + + -- TODO: either should be Module, or there + -- should be a Maybe UnitId here too. + is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: Bool, -- ^ Was this import qualified? + is_dloc :: SrcSpan -- ^ The location of the entire import declaration + } deriving (Eq, Data) + +-- | Import Item Specification +-- +-- Describes import info a particular Name +data ImpItemSpec + = ImpAll -- ^ The import had no import list, + -- or had a hiding list + + | ImpSome { + is_explicit :: Bool, + is_iloc :: SrcSpan -- Location of the import item + } -- ^ The import had an import list. + -- The 'is_explicit' field is @True@ iff the thing was named + -- /explicitly/ in the import specs rather + -- than being imported as part of a "..." group. Consider: + -- + -- > import C( T(..) ) + -- + -- Here the constructors of @T@ are not named explicitly; + -- only @T@ is named explicitly. + deriving (Eq, Data) + +bestImport :: [ImportSpec] -> ImportSpec +-- See Note [Choosing the best import declaration] +bestImport iss + = case sortBy best iss of + (is:_) -> is + [] -> pprPanic "bestImport" (ppr iss) + where + best :: ImportSpec -> ImportSpec -> Ordering + -- Less means better + -- Unqualified always wins over qualified; then + -- import-all wins over import-some; then + -- earlier declaration wins over later + best (ImpSpec { is_item = item1, is_decl = d1 }) + (ImpSpec { is_item = item2, is_decl = d2 }) + = (is_qual d1 `compare` is_qual d2) `thenCmp` + (best_item item1 item2) `thenCmp` + SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) + + best_item :: ImpItemSpec -> ImpItemSpec -> Ordering + best_item ImpAll ImpAll = EQ + best_item ImpAll (ImpSome {}) = LT + best_item (ImpSome {}) ImpAll = GT + best_item (ImpSome { is_explicit = e1 }) + (ImpSome { is_explicit = e2 }) = e1 `compare` e2 + -- False < True, so if e1 is explicit and e2 is not, we get GT + +{- Note [Choosing the best import declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reporting unused import declarations we use the following rules. + (see [wiki:commentary/compiler/unused-imports]) + +Say that an import-item is either + * an entire import-all decl (eg import Foo), or + * a particular item in an import list (eg import Foo( ..., x, ...)). +The general idea is that for each /occurrence/ of an imported name, we will +attribute that use to one import-item. Once we have processed all the +occurrences, any import items with no uses attributed to them are unused, +and are warned about. More precisely: + +1. For every RdrName in the program text, find its GlobalRdrElt. + +2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one + the "chosen import-item", and mark it "used". This is done + by 'bestImport' + +3. After processing all the RdrNames, bleat about any + import-items that are unused. + This is done in GHC.Rename.Names.warnUnusedImportDecls. + +The function 'bestImport' returns the dominant import among the +ImportSpecs it is given, implementing Step 2. We say import-item A +dominates import-item B if we choose A over B. In general, we try to +choose the import that is most likely to render other imports +unnecessary. Here is the dominance relationship we choose: + + a) import Foo dominates import qualified Foo. + + b) import Foo dominates import Foo(x). + + c) Otherwise choose the textually first one. + +Rationale for (a). Consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + x + +The unqualified 'x' can only come from import #2. The qualified 'M.x' +could come from either, but bestImport picks import #2, because it is +more likely to be useful in other imports, as indeed it is in this +case (see #5211 for a concrete example). + +But the rules are not perfect; consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + M.y + +The M.x will use import #2, but M.y can only use import #1. +-} + + +unQualSpecOK :: ImportSpec -> Bool +-- ^ Is in scope unqualified? +unQualSpecOK is = not (is_qual (is_decl is)) + +qualSpecOK :: ModuleName -> ImportSpec -> Bool +-- ^ Is in scope qualified with the given module? +qualSpecOK mod is = mod == is_as (is_decl is) + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> ModuleName +importSpecModule is = is_mod (is_decl is) + +isExplicitItem :: ImpItemSpec -> Bool +isExplicitItem ImpAll = False +isExplicitItem (ImpSome {is_explicit = exp}) = exp + +pprNameProvenance :: GlobalRdrElt -> SDoc +-- ^ Print out one place where the name was define/imported +-- (With -dppr-debug, print them all) +pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + = ifPprDebug (vcat pp_provs) + (head pp_provs) + where + pp_provs = pp_lcl ++ map pp_is iss + pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] + else [] + pp_is is = sep [ppr is, ppr_defn_site is name] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn_site :: ImportSpec -> Name -> SDoc +ppr_defn_site imp_spec name + | same_module && not (isGoodSrcSpan loc) + = empty -- Nothing interesting to say + | otherwise + = parens $ hang (text "and originally defined" <+> pp_mod) + 2 (pprLoc loc) + where + loc = nameSrcSpan name + defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + same_module = importSpecModule imp_spec == moduleName defining_mod + pp_mod | same_module = empty + | otherwise = text "in" <+> quotes (ppr defining_mod) + + +instance Outputable ImportSpec where + ppr imp_spec + = text "imported" <+> qual + <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) + <+> pprLoc (importSpecLoc imp_spec) + where + qual | is_qual (is_decl imp_spec) = text "qualified" + | otherwise = empty + +pprLoc :: SrcSpan -> SDoc +pprLoc (RealSrcSpan s _) = text "at" <+> ppr s +pprLoc (UnhelpfulSpan {}) = empty + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that he's working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- The user might unknowingly be working on a module with NoStarIsType +-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a +-- hint whenever an assumption about '*' is violated. Unfortunately, it is +-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). +-- +-- 'starInfo' generates an appropriate hint to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, the resulting SDoc will contain a helpful suggestion. +-- Otherwise it is empty. +-- +starInfo :: Bool -> RdrName -> SDoc +starInfo star_is_type rdr_name = + -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to + -- take star_is_type as input? Why not refactor? + -- + -- The reason is that `sdocOption sdocStarIsType` would indicate that + -- StarIsType is enabled in the module that tries to load the problematic + -- definition, not in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + if isUnqualStar && not star_is_type + then text "With NoStarIsType, " <> + quotes (ppr rdr_name) <> + text " is treated as a regular type operator. " + $$ + text "Did you mean to use " <> quotes (text "Type") <> + text " from Data.Kind instead?" + else empty + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/GHC/Types/Name/Set.hs b/GHC/Types/Name/Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Set.hs @@ -0,0 +1,226 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Types.Name.Set ( + -- * Names set type + NameSet, + + -- ** Manipulating these sets + emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, + minusNameSet, elemNameSet, extendNameSet, extendNameSetList, + delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, + intersectsNameSet, disjointNameSet, intersectNameSet, + nameSetAny, nameSetAll, nameSetElemsStable, + + -- * Free variables + FreeVars, + + -- ** Manipulating sets of free variables + isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs, + intersectFVs, + + -- * Defs and uses + Defs, Uses, DefUse, DefUses, + + -- ** Manipulating defs and uses + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses, allUses, + + -- * Non-CAFfy names + NonCaffySet(..) + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Data.OrdList +import GHC.Types.Unique.Set +import Data.List (sortBy) + +{- +************************************************************************ +* * +\subsection[Sets of names} +* * +************************************************************************ +-} + +type NameSet = UniqSet Name + +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +extendNameSetList :: NameSet -> [Name] -> NameSet +extendNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSet :: NameSet -> NameSet -> NameSet +unionNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet +intersectNameSet :: NameSet -> NameSet -> NameSet +intersectsNameSet :: NameSet -> NameSet -> Bool +disjointNameSet :: NameSet -> NameSet -> Bool +-- ^ True if there is a non-empty intersection. +-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +extendNameSetList = addListToUniqSet +extendNameSet = addOneToUniqSet +unionNameSet = unionUniqSets +unionNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +delFromNameSet = delOneFromUniqSet +filterNameSet = filterUniqSet +intersectNameSet = intersectUniqSets +disjointNameSet = disjointUniqSets + +delListFromNameSet set ns = foldl' delFromNameSet set ns + +intersectsNameSet s1 s2 = not (s1 `disjointNameSet` s2) + +nameSetAny :: (Name -> Bool) -> NameSet -> Bool +nameSetAny = uniqSetAny + +nameSetAll :: (Name -> Bool) -> NameSet -> Bool +nameSetAll = uniqSetAll + +-- | Get the elements of a NameSet with some stable ordering. +-- This only works for Names that originate in the source code or have been +-- tidied. +-- See Note [Deterministic UniqFM] to learn about nondeterminism +nameSetElemsStable :: NameSet -> [Name] +nameSetElemsStable ns = + sortBy stableNameCmp $ nonDetEltsUniqSet ns + -- It's OK to use nonDetEltsUniqSet here because we immediately sort + -- with stableNameCmp + +{- +************************************************************************ +* * +\subsection{Free variables} +* * +************************************************************************ + +These synonyms are useful when we are thinking of free variables +-} + +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars +intersectFVs :: FreeVars -> FreeVars -> FreeVars + +isEmptyFVs :: NameSet -> Bool +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionNameSets +plusFV = unionNameSet +mkFVs = mkNameSet +addOneFV = extendNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns +intersectFVs = intersectNameSet + +{- +************************************************************************ +* * + Defs and uses +* * +************************************************************************ +-} + +-- | A set of names that are defined somewhere +type Defs = NameSet + +-- | A set of names that are used somewhere +type Uses = NameSet + +-- | @(Just ds, us) =>@ The use of any member of the @ds@ +-- implies that all the @us@ are used too. +-- Also, @us@ may mention @ds@. +-- +-- @Nothing =>@ Nothing is defined in this group, but +-- nevertheless all the uses are essential. +-- Used for instance declarations, for example +type DefUse = (Maybe Defs, Uses) + +-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' +-- In a single (def, use) pair, the defs also scope over the uses +type DefUses = OrdList DefUse + +emptyDUs :: DefUses +emptyDUs = nilOL + +usesOnly :: Uses -> DefUses +usesOnly uses = unitOL (Nothing, uses) + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = appOL + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, _u1) d2 = d2 + get (Just d1, _u1) d2 = d1 `unionNameSet` d2 + +allUses :: DefUses -> Uses +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned +allUses dus = foldr get emptyNameSet dus + where + get (_d1, u1) u2 = u1 `unionNameSet` u2 + +duUses :: DefUses -> Uses +-- ^ Collect all 'Uses', regardless of whether the group is itself used, +-- but remove 'Defs' on the way +duUses dus = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. +-- The result is a superset of the input 'Uses'; and includes things defined +-- in the input 'DefUses' (but only if they are used) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses -- Used + || nameSetAny (startsWithUnderscore . nameOccName) defs + -- At least one starts with an "_", + -- so treat the group as used + = rhs_uses `unionNameSet` uses + | otherwise -- No def is used + = uses + +-- | 'Id's which have no CAF references. This is a result of analysis of C--. +-- It is always safe to use an empty 'NonCaffySet'. TODO Refer to Note. +newtype NonCaffySet = NonCaffySet NameSet + deriving (Semigroup, Monoid) diff --git a/GHC/Types/Name/Shape.hs b/GHC/Types/Name/Shape.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Name/Shape.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE CPP #-} + +module GHC.Types.Name.Shape + ( NameShape(..) + , emptyNameShape + , mkNameShape + , extendNameShape + , nameShapeExports + , substNameShape + , maybeSubstNameShape + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Driver.Types +import GHC.Unit.Module +import GHC.Types.Unique.FM +import GHC.Types.Avail +import GHC.Types.FieldLabel + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Tc.Utils.Monad +import GHC.Utils.Misc +import GHC.Iface.Env + +import Control.Monad + +-- Note [NameShape] +-- ~~~~~~~~~~~~~~~~ +-- When we write a declaration in a signature, e.g., data T, we +-- ascribe to it a *name variable*, e.g., {m.T}. This +-- name variable may be substituted with an actual original +-- name when the signature is implemented (or even if we +-- merge the signature with one which reexports this entity +-- from another module). + +-- When we instantiate a signature m with a module M, +-- we also need to substitute over names. To do so, we must +-- compute the *name substitution* induced by the *exports* +-- of the module in question. A NameShape represents +-- such a name substitution for a single module instantiation. +-- The "shape" in the name comes from the fact that the computation +-- of a name substitution is essentially the *shaping pass* from +-- Backpack'14, but in a far more restricted form. + +-- The name substitution for an export list is easy to explain. If we are +-- filling the module variable , given an export N of the form +-- M.n or {m'.n} (where n is an OccName), the induced name +-- substitution is from {m.n} to N. So, for example, if we have +-- A=impl:B, and the exports of impl:B are impl:B.f and +-- impl:C.g, then our name substitution is {A.f} to impl:B.f +-- and {A.g} to impl:C.g + + + + +-- The 'NameShape' type is defined in GHC.Tc.Types, because GHC.Tc.Types +-- needs to refer to NameShape, and having GHC.Tc.Types import +-- NameShape (even by SOURCE) would cause a large number of +-- modules to be pulled into the DynFlags cycle. +{- +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } +-} + +-- NB: substitution functions need 'HscEnv' since they need the name cache +-- to allocate new names if we change the 'Module' of a 'Name' + +-- | Create an empty 'NameShape' (i.e., the renaming that +-- would occur with an implementing module with no exports) +-- for a specific hole @mod_name@. +emptyNameShape :: ModuleName -> NameShape +emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv + +-- | Create a 'NameShape' corresponding to an implementing +-- module for the hole @mod_name@ that exports a list of 'AvailInfo's. +mkNameShape :: ModuleName -> [AvailInfo] -> NameShape +mkNameShape mod_name as = + NameShape mod_name as $ mkOccEnv $ do + a <- as + n <- availName a : availNamesWithSelectors a + return (occName n, n) + +-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's +-- with Backpack style mix-in linking. This is used solely when merging +-- signatures together: we successively merge the exports of each +-- signature until we have the final, full exports of the merged signature. +-- +-- What makes this operation nontrivial is what we are supposed to do when +-- we want to merge in an export for M.T when we already have an existing +-- export {H.T}. What should happen in this case is that {H.T} should be +-- unified with @M.T@: we've determined a more *precise* identity for the +-- export at 'OccName' @T@. +-- +-- Note that we don't do unrestricted unification: only name holes from +-- @ns_mod_name ns@ are flexible. This is because we have a much more +-- restricted notion of shaping than in Backpack'14: we do shaping +-- *as* we do type-checking. Thus, once we shape a signature, its +-- exports are *final* and we're not allowed to refine them further, +extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape) +extendNameShape hsc_env ns as = + case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of + Left err -> return (Left err) + Right nsubst -> do + as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns) + as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as + let new_avails = mergeAvails as1 as2 + return . Right $ ns { + ns_exports = new_avails, + -- TODO: stop repeatedly rebuilding the OccEnv + ns_map = mkOccEnv $ do + a <- new_avails + n <- availName a : availNames a + return (occName n, n) + } + +-- | The export list associated with this 'NameShape' (i.e., what +-- the exports of an implementing module which induces this 'NameShape' +-- would be.) +nameShapeExports :: NameShape -> [AvailInfo] +nameShapeExports = ns_exports + +-- | Given a 'Name', substitute it according to the 'NameShape' implied +-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module +-- exports @M.T@. +substNameShape :: NameShape -> Name -> Name +substNameShape ns n | nameModule n == ns_module ns + , Just n' <- lookupOccEnv (ns_map ns) (occName n) + = n' + | otherwise + = n + +-- | Like 'substNameShape', but returns @Nothing@ if no substitution +-- works. +maybeSubstNameShape :: NameShape -> Name -> Maybe Name +maybeSubstNameShape ns n + | nameModule n == ns_module ns + = lookupOccEnv (ns_map ns) (occName n) + | otherwise + = Nothing + +-- | The 'Module' of any 'Name's a 'NameShape' has action over. +ns_module :: NameShape -> Module +ns_module = mkHoleModule . ns_mod_name + +{- +************************************************************************ +* * + Name substitutions +* * +************************************************************************ +-} + +-- | Substitution on @{A.T}@. We enforce the invariant that the +-- 'nameModule' of keys of this map have 'moduleUnit' @hole@ +-- (meaning that if we have a hole substitution, the keys of the map +-- are never affected.) Alternatively, this is isomorphic to +-- @Map ('ModuleName', 'OccName') 'Name'@. +type ShNameSubst = NameEnv Name + +-- NB: In this module, we actually only ever construct 'ShNameSubst' +-- at a single 'ModuleName'. But 'ShNameSubst' is more convenient to +-- work with. + +-- | Substitute names in a 'Name'. +substName :: ShNameSubst -> Name -> Name +substName env n | Just n' <- lookupNameEnv env n = n' + | otherwise = n + +-- | Substitute names in an 'AvailInfo'. This has special behavior +-- for type constructors, where it is sufficient to substitute the 'availName' +-- to induce a substitution on 'availNames'. +substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo +substNameAvailInfo _ env (Avail n) = return (Avail (substName env n)) +substNameAvailInfo hsc_env env (AvailTC n ns fs) = + let mb_mod = fmap nameModule (lookupNameEnv env n) + in AvailTC (substName env n) + <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns + <*> mapM (setNameFieldSelector hsc_env mb_mod) fs + +-- | Set the 'Module' of a 'FieldSelector' +setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel +setNameFieldSelector _ Nothing f = return f +setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do + sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel + return (FieldLabel l b sel') + +{- +************************************************************************ +* * + AvailInfo merging +* * +************************************************************************ +-} + +-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have +-- already been unified ('uAvailInfos'). +mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] +mergeAvails as1 as2 = + let mkNE as = mkNameEnv [(availName a, a) | a <- as] + in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2)) + +{- +************************************************************************ +* * + AvailInfo unification +* * +************************************************************************ +-} + +-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst +uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ + let mkOE as = listToUFM $ do a <- as + n <- availNames a + return (nameOccName n, a) + in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv + (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2))) + -- Edward: I have to say, this is pretty clever. + +-- | Unify two 'AvailInfo's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo + -> Either SDoc ShNameSubst +uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2 +uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2 +uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine" + <+> ppr a1 <+> text "with" <+> ppr a2 + <+> parens (text "one is a type, the other is a plain identifier") + +-- | Unify two 'Name's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst +uName flexi subst n1 n2 + | n1 == n2 = Right subst + | isFlexi n1 = uHoleName flexi subst n1 n2 + | isFlexi n2 = uHoleName flexi subst n2 n1 + | otherwise = Left (text "While merging export lists, could not unify" + <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra) + where + isFlexi n = isHoleName n && moduleName (nameModule n) == flexi + extra | isHoleName n1 || isHoleName n2 + = text "Neither name variable originates from the current signature." + | otherwise + = empty + +-- | Unify a name @h@ which 'isHoleName' with another name, given an existing +-- substitution @subst@, with only name holes from @flexi@ unifiable (all +-- other name holes rigid.) +uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name + -> Either SDoc ShNameSubst +uHoleName flexi subst h n = + ASSERT( isHoleName h ) + case lookupNameEnv subst h of + Just n' -> uName flexi subst n' n + -- Do a quick check if the other name is substituted. + Nothing | Just n' <- lookupNameEnv subst n -> + ASSERT( isHoleName n ) uName flexi subst h n' + | otherwise -> + Right (extendNameEnv subst h n) diff --git a/GHC/Types/RepType.hs b/GHC/Types/RepType.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/RepType.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Types.RepType + ( + -- * Code generator views onto Types + UnaryType, NvUnaryType, isNvUnaryType, + unwrapType, + + -- * Predicates on types + isVoidTy, + + -- * Type representation for the code generator + typePrimRep, typePrimRep1, + runtimeRepPrimRep, typePrimRepArgs, + PrimRep(..), primRepToType, + countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1, + + -- * Unboxed sum representation type + ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), + slotPrimRep, primRepSlot + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Basic (Arity, RepArity) +import GHC.Core.DataCon +import GHC.Utils.Outputable +import GHC.Builtin.Names +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Utils.Misc +import GHC.Builtin.Types.Prim +import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind ) + +import Data.List (sort) +import qualified Data.IntSet as IS + +{- ********************************************************************** +* * + Representation types +* * +********************************************************************** -} + +type NvUnaryType = Type +type UnaryType = Type + -- Both are always a value type; i.e. its kind is TYPE rr + -- for some rr; moreover the rr is never a variable. + -- + -- NvUnaryType : never an unboxed tuple or sum, or void + -- + -- UnaryType : never an unboxed tuple or sum; + -- can be Void# or (# #) + +isNvUnaryType :: Type -> Bool +isNvUnaryType ty + | [_] <- typePrimRep ty + = True + | otherwise + = False + +-- INVARIANT: the result list is never empty. +typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] +typePrimRepArgs ty + | [] <- reps + = [VoidRep] + | otherwise + = reps + where + reps = typePrimRep ty + +-- | Gets rid of the stuff that prevents us from understanding the +-- runtime representation of a type. Including: +-- 1. Casts +-- 2. Newtypes +-- 3. Foralls +-- 4. Synonyms +-- But not type/data families, because we don't have the envs to hand. +unwrapType :: Type -> Type +unwrapType ty + | Just (_, unwrapped) + <- topNormaliseTypeX stepper mappend inner_ty + = unwrapped + | otherwise + = inner_ty + where + inner_ty = go ty + + go t | Just t' <- coreView t = go t' + go (ForAllTy _ t) = go t + go (CastTy t _) = go t + go t = t + + -- cf. Coercion.unwrapNewTypeStepper + stepper rec_nts tc tys + | Just (ty', _) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' (go ty') () + Nothing -> NS_Abort -- infinite newtypes + | otherwise + = NS_Done + +countFunRepArgs :: Arity -> Type -> RepArity +countFunRepArgs 0 _ + = 0 +countFunRepArgs n ty + | FunTy _ _ arg res <- unwrapType ty + = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + | otherwise + = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) + +countConRepArgs :: DataCon -> RepArity +countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) + where + go :: Arity -> Type -> RepArity + go 0 _ + = 0 + go n ty + | FunTy _ _ arg res <- unwrapType ty + = length (typePrimRep arg) + go (n - 1) res + | otherwise + = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) + +-- | True if the type has zero width. +isVoidTy :: Type -> Bool +isVoidTy = null . typePrimRep + + +{- ********************************************************************** +* * + Unboxed sums + See Note [Translating unboxed sums to unboxed tuples] in GHC.Stg.Unarise +* * +********************************************************************** -} + +type SortedSlotTys = [SlotTy] + +-- | Given the arguments of a sum type constructor application, +-- return the unboxed sum rep type. +-- +-- E.g. +-- +-- (# Int# | Maybe Int | (# Int#, Float# #) #) +-- +-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`, +-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot] +-- +-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head +-- of the list we have the slot for the tag. +ubxSumRepType :: [[PrimRep]] -> [SlotTy] +ubxSumRepType constrs0 + -- These first two cases never classify an actual unboxed sum, which always + -- has at least two disjuncts. But it could happen if a user writes, e.g., + -- forall (a :: TYPE (SumRep [IntRep])). ... + -- which could never be instantiated. We still don't want to panic. + | constrs0 `lengthLessThan` 2 + = [WordSlot] + + | otherwise + = let + combine_alts :: [SortedSlotTys] -- slots of constructors + -> SortedSlotTys -- final slots + combine_alts constrs = foldl' merge [] constrs + + merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys + merge existing_slots [] + = existing_slots + merge [] needed_slots + = needed_slots + merge (es : ess) (s : ss) + | Just s' <- s `fitsIn` es + = -- found a slot, use it + s' : merge ess ss + | s < es + = -- we need a new slot and this is the right place for it + s : merge (es : ess) ss + | otherwise + = -- keep searching for a slot + es : merge ess (s : ss) + + -- Nesting unboxed tuples and sums is OK, so we need to flatten first. + rep :: [PrimRep] -> SortedSlotTys + rep ty = sort (map primRepSlot ty) + + sumRep = WordSlot : combine_alts (map rep constrs0) + -- WordSlot: for the tag of the sum + in + sumRep + +layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag. + -- We assume that they are in increasing order + -> [SlotTy] -- Slot types of things we want to map to locations in the + -- sum layout + -> [Int] -- Where to map 'things' in the sum layout +layoutUbxSum sum_slots0 arg_slots0 = + go arg_slots0 IS.empty + where + go :: [SlotTy] -> IS.IntSet -> [Int] + go [] _ + = [] + go (arg : args) used + = let slot_idx = findSlot arg 0 sum_slots0 used + in slot_idx : go args (IS.insert slot_idx used) + + findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int + findSlot arg slot_idx (slot : slots) useds + | not (IS.member slot_idx useds) + , Just slot == arg `fitsIn` slot + = slot_idx + | otherwise + = findSlot arg (slot_idx + 1) slots useds + findSlot _ _ [] _ + = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0) + +-------------------------------------------------------------------------------- + +-- We have 3 kinds of slots: +-- +-- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e. +-- boxed objects). These come in two variants: Lifted and unlifted (see +-- #19645). +-- +-- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep. +-- +-- - Float slots: Shared between floating point types. +-- +-- - Void slots: Shared between void types. Not used in sums. +-- +-- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit +-- values, so that we can pack things more tightly. +data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot + deriving (Eq, Ord) + -- Constructor order is important! If slot A could fit into slot B + -- then slot A must occur first. E.g. FloatSlot before DoubleSlot + -- + -- We are assuming that WordSlot is smaller than or equal to Word64Slot + -- (would not be true on a 128-bit machine) + +instance Outputable SlotTy where + ppr PtrLiftedSlot = text "PtrLiftedSlot" + ppr PtrUnliftedSlot = text "PtrUnliftedSlot" + ppr Word64Slot = text "Word64Slot" + ppr WordSlot = text "WordSlot" + ppr DoubleSlot = text "DoubleSlot" + ppr FloatSlot = text "FloatSlot" + +typeSlotTy :: UnaryType -> Maybe SlotTy +typeSlotTy ty + | isVoidTy ty + = Nothing + | otherwise + = Just (primRepSlot (typePrimRep1 ty)) + +primRepSlot :: PrimRep -> SlotTy +primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") +primRepSlot LiftedRep = PtrLiftedSlot +primRepSlot UnliftedRep = PtrUnliftedSlot +primRepSlot IntRep = WordSlot +primRepSlot Int8Rep = WordSlot +primRepSlot Int16Rep = WordSlot +primRepSlot Int32Rep = WordSlot +primRepSlot Int64Rep = Word64Slot +primRepSlot WordRep = WordSlot +primRepSlot Word8Rep = WordSlot +primRepSlot Word16Rep = WordSlot +primRepSlot Word32Rep = WordSlot +primRepSlot Word64Rep = Word64Slot +primRepSlot AddrRep = WordSlot +primRepSlot FloatRep = FloatSlot +primRepSlot DoubleRep = DoubleSlot +primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") + +slotPrimRep :: SlotTy -> PrimRep +slotPrimRep PtrLiftedSlot = LiftedRep +slotPrimRep PtrUnliftedSlot = UnliftedRep +slotPrimRep Word64Slot = Word64Rep +slotPrimRep WordSlot = WordRep +slotPrimRep DoubleSlot = DoubleRep +slotPrimRep FloatSlot = FloatRep + +-- | Returns the bigger type if one fits into the other. (commutative) +-- +-- Note that lifted and unlifted pointers are *not* in a fits-in relation for +-- the reasons described in Note [Don't merge lifted and unlifted slots] in +-- GHC.Stg.Unarise. +fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy +fitsIn ty1 ty2 + | ty1 == ty2 + = Just ty1 + | isWordSlot ty1 && isWordSlot ty2 + = Just (max ty1 ty2) + | isFloatSlot ty1 && isFloatSlot ty2 + = Just (max ty1 ty2) + | otherwise + = Nothing + where + isWordSlot Word64Slot = True + isWordSlot WordSlot = True + isWordSlot _ = False + + isFloatSlot DoubleSlot = True + isFloatSlot FloatSlot = True + isFloatSlot _ = False + + +{- ********************************************************************** +* * + PrimRep +* * +************************************************************************* + +Note [RuntimeRep and PrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes the relationship between GHC.Types.RuntimeRep +(of levity-polymorphism fame) and GHC.Core.TyCon.PrimRep, as these types +are closely related. + +A "primitive entity" is one that can be + * stored in one register + * manipulated with one machine instruction + + +Examples include: + * a 32-bit integer + * a 32-bit float + * a 64-bit float + * a machine address (heap pointer), etc. + * a quad-float (on a machine with SIMD register and instructions) + * ...etc... + +The "representation or a primitive entity" specifies what kind of register is +needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep +enumerates all the possibilities. + +data PrimRep + = VoidRep + | LiftedRep -- ^ Lifted pointer + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + ...etc... + | VecRep Int PrimElemRep -- ^ SIMD fixed-width vector + +The Haskell source language is a bit more flexible: a single value may need multiple PrimReps. +For example + + utup :: (# Int, Int #) -> Bool + utup x = ... + +Here x :: (# Int, Int #), and that takes two registers, and two instructions to move around. +Unboxed sums are similar. + +Every Haskell expression e has a type ty, whose kind is of form TYPE rep + e :: ty :: TYPE rep +where rep :: RuntimeRep. Here rep describes the runtime representation for e's value, +but RuntimeRep has some extra cases: + +data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type + | TupleRep [RuntimeRep] -- ^ An unboxed tuple of the given reps + | SumRep [RuntimeRep] -- ^ An unboxed sum of the given reps + | LiftedRep -- ^ lifted; represented by a pointer + | UnliftedRep -- ^ unlifted; represented by a pointer + | IntRep -- ^ signed, word-sized value + ...etc... + +It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep, +which describe unboxed products and sums respectively. RuntimeRep is defined +in the library ghc-prim:GHC.Types. It is also "wired-in" to GHC: see +GHC.Builtin.Types.runtimeRepTyCon. The unarisation pass, in GHC.Stg.Unarise, transforms the +program, so that every variable has a type that has a PrimRep. For +example, unarisation transforms our utup function above, to take two Int +arguments instead of one (# Int, Int #) argument. + +See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. + +Note [VoidRep] +~~~~~~~~~~~~~~ +PrimRep contains a constructor VoidRep, while RuntimeRep does +not. Yet representations are often characterised by a list of PrimReps, +where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) + +However, after the unariser, all identifiers have exactly one PrimRep, but +void arguments still exist. Thus, PrimRep includes VoidRep to describe these +binders. Perhaps post-unariser representations (which need VoidRep) should be +a different type than pre-unariser representations (which use a list and do +not need VoidRep), but we have what we have. + +RuntimeRep instead uses TupleRep '[] to denote a void argument. When +converting a TupleRep '[] into a list of PrimReps, we get an empty list. + +Note [Getting from RuntimeRep to PrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep]. + +How do we get from an Id to the list or PrimReps used to store it? We get +the Id's type ty (using idType), then ty's kind ki (using typeKind), then +pattern-match on ki to extract rep (in kindPrimRep), then extract the PrimRep +from the RuntimeRep (in runtimeRepPrimRep). + +We now must convert the RuntimeRep to a list of PrimReps. Let's look at two +examples: + + 1. x :: Int# + 2. y :: (# Int, Word# #) + +With these types, we can extract these kinds: + + 1. Int# :: TYPE IntRep + 2. (# Int, Word# #) :: TYPE (TupleRep [LiftedRep, WordRep]) + +In the end, we will get these PrimReps: + + 1. [IntRep] + 2. [LiftedRep, WordRep] + +It would thus seem that we should have a function somewhere of +type `RuntimeRep -> [PrimRep]`. This doesn't work though: when we +look at the argument of TYPE, we get something of type Type (of course). +RuntimeRep exists in the user's program, but not in GHC as such. +Instead, we must decompose the Type of kind RuntimeRep into tycons and +extract the PrimReps from the TyCons. This is what runtimeRepPrimRep does: +it takes a Type and returns a [PrimRep] + +runtimeRepPrimRep works by using tyConRuntimeRepInfo. That function +should be passed the TyCon produced by promoting one of the constructors +of RuntimeRep into type-level data. The RuntimeRep promoted datacons are +associated with a RuntimeRepInfo (stored directly in the PromotedDataCon +constructor of TyCon). This pairing happens in GHC.Builtin.Types. A RuntimeRepInfo +usually(*) contains a function from [Type] to [PrimRep]: the [Type] are +the arguments to the promoted datacon. These arguments are necessary +for the TupleRep and SumRep constructors, so that this process can recur, +producing a flattened list of PrimReps. Calling this extracted function +happens in runtimeRepPrimRep; the functions themselves are defined in +tupleRepDataCon and sumRepDataCon, both in GHC.Builtin.Types. + +The (*) above is to support vector representations. RuntimeRep refers +to VecCount and VecElem, whose promoted datacons have nuggets of information +related to vectors; these form the other alternatives for RuntimeRepInfo. + +Returning to our examples, the Types we get (after stripping off TYPE) are + + 1. TyConApp (PromotedDataCon "IntRep") [] + 2. TyConApp (PromotedDataCon "TupleRep") + [TyConApp (PromotedDataCon ":") + [ TyConApp (AlgTyCon "RuntimeRep") [] + , TyConApp (PromotedDataCon "LiftedRep") [] + , TyConApp (PromotedDataCon ":") + [ TyConApp (AlgTyCon "RuntimeRep") [] + , TyConApp (PromotedDataCon "WordRep") [] + , TyConApp (PromotedDataCon "'[]") + [TyConApp (AlgTyCon "RuntimeRep") []]]]] + +runtimeRepPrimRep calls tyConRuntimeRepInfo on (PromotedDataCon "IntRep"), resp. +(PromotedDataCon "TupleRep"), extracting a function that will produce the PrimReps. +In example 1, this function is passed an empty list (the empty list of args to IntRep) +and returns the PrimRep IntRep. (See the definition of runtimeRepSimpleDataCons in +GHC.Builtin.Types and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted +list as the one argument to the extracted function. The extracted function is defined +as prim_rep_fun within tupleRepDataCon in GHC.Builtin.Types. It takes one argument, decomposes +the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep +to process the LiftedRep and WordRep, concatentating the results. + +-} + +-- | Discovers the primitive representation of a 'Type'. Returns +-- a list of 'PrimRep': it's a list because of the possibility of +-- no runtime representation (void) or multiple (unboxed tuple/sum) +-- See also Note [Getting from RuntimeRep to PrimRep] +typePrimRep :: HasDebugCallStack => Type -> [PrimRep] +typePrimRep ty = kindPrimRep (text "typePrimRep" <+> + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) + (typeKind ty) + +-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- an empty list of PrimReps becomes a VoidRep. +-- This assumption holds after unarise, see Note [Post-unarisation invariants]. +-- Before unarise it may or may not hold. +-- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 ty = case typePrimRep ty of + [] -> VoidRep + [rep] -> rep + _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) + +-- | Find the runtime representation of a 'TyCon'. Defined here to +-- avoid module loops. Returns a list of the register shapes necessary. +-- See also Note [Getting from RuntimeRep to PrimRep] +tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] +tyConPrimRep tc + = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) + res_kind + where + res_kind = tyConResKind tc + +-- | Like 'tyConPrimRep', but assumed that there is precisely zero or +-- one 'PrimRep' output +-- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] +tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep +tyConPrimRep1 tc = case tyConPrimRep tc of + [] -> VoidRep + [rep] -> rep + _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- of values of types of this kind. +-- See also Note [Getting from RuntimeRep to PrimRep] +kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] +kindPrimRep doc ki + | Just ki' <- coreView ki + = kindPrimRep doc ki' +kindPrimRep doc (TyConApp typ [runtime_rep]) + = ASSERT( typ `hasKey` tYPETyConKey ) + runtimeRepPrimRep doc runtime_rep +kindPrimRep doc ki + = pprPanic "kindPrimRep" (ppr ki $$ doc) + +-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that +-- it encodes. See also Note [Getting from RuntimeRep to PrimRep] +runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] +runtimeRepPrimRep doc rr_ty + | Just rr_ty' <- coreView rr_ty + = runtimeRepPrimRep doc rr_ty' + | TyConApp rr_dc args <- rr_ty + , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + = fun args + | otherwise + = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) + +-- | Convert a PrimRep back to a Type. Used only in the unariser to give types +-- to fresh Ids. Really, only the type's representation matters. +-- See also Note [RuntimeRep and PrimRep] +primRepToType :: PrimRep -> Type +primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep diff --git a/GHC/Types/SrcLoc.hs b/GHC/Types/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SrcLoc.hs @@ -0,0 +1,895 @@ +-- (c) The University of Glasgow, 1992-2006 + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + + +-- | This module contains types that relate to the positions of things +-- in source files, and allow tagging of those things with locations +module GHC.Types.SrcLoc ( + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), + + -- ** Constructing SrcLoc + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + + noSrcLoc, -- "I'm sorry, I haven't a clue" + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session + + advanceSrcLoc, + advanceBufPos, + + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + + -- * SrcSpan + RealSrcSpan, -- Abstract + SrcSpan(..), + UnhelpfulSpanReason(..), + + -- ** Constructing SrcSpan + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, + noSrcSpan, generatedSrcSpan, isGeneratedSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + interactiveSrcSpan, + srcLocSpan, realSrcLocSpan, + combineSrcSpans, + srcSpanFirstCharacter, + + -- ** Deconstructing SrcSpan + srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + pprUserRealSpan, pprUnhelpfulSpanReason, + unhelpfulSpanFS, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Predicates on SrcSpan + isGoodSrcSpan, isOneLineSpan, + containsSpan, + + -- * StringBuffer locations + BufPos(..), + getBufPos, + BufSpan(..), + getBufSpan, + + -- * Located + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, + mkGeneralLocated, + + -- ** Deconstructing Located + getLoc, unLoc, + unRealSrcSpan, getRealSrcSpan, + + -- ** Modifying Located + mapLoc, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, cmpBufSpan, + combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost_smallest, + spans, isSubspanOf, isRealSubspanOf, + sortLocated, sortRealLocated, + lookupSrcLoc, lookupSrcSpan, + + liftL, + + -- * Parser locations + PsLoc(..), + PsSpan(..), + PsLocated, + advancePsLoc, + mkPsSpan, + psSpanStart, + psSpanEnd, + mkSrcSpanPs, + + -- * Layout information + LayoutInfo(..), + leftmostColumn + + ) where + +import GHC.Prelude + +import GHC.Utils.Misc +import GHC.Utils.Json +import GHC.Utils.Outputable +import GHC.Data.FastString + +import Control.DeepSeq +import Control.Applicative (liftA2) +import Data.Bits +import Data.Data +import Data.List (sortBy, intercalate) +import Data.Function (on) +import qualified Data.Map as Map +import qualified Data.Semigroup + +{- +************************************************************************ +* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +* * +************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +-} + +-- | Real Source Location +-- +-- Represents a single point within a file +data RealSrcLoc + = SrcLoc FastString -- A precise location (file name) + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !Int -- column number, begins at 1 + deriving (Eq, Ord) + +-- | 0-based offset identifying the raw location in the 'StringBuffer'. +-- +-- The lexer increments the 'BufPos' every time a character (UTF-8 code point) +-- is read from the input buffer. As UTF-8 is a variable-length encoding and +-- 'StringBuffer' needs a byte offset for indexing, a 'BufPos' cannot be used +-- for indexing. +-- +-- The parser guarantees that 'BufPos' are monotonic. See #17632. This means +-- that syntactic constructs that appear later in the 'StringBuffer' are guaranteed to +-- have a higher 'BufPos'. Constrast that with 'RealSrcLoc', which does *not* make the +-- analogous guarantee about higher line/column numbers. +-- +-- This is due to #line and {-# LINE ... #-} pragmas that can arbitrarily +-- modify 'RealSrcLoc'. Notice how 'setSrcLoc' and 'resetAlrLastLoc' in +-- "GHC.Parser.Lexer" update 'PsLoc', modifying 'RealSrcLoc' but preserving +-- 'BufPos'. +-- +-- Monotonicity makes 'BufPos' useful to determine the order in which syntactic +-- elements appear in the source. Consider this example (haddockA041 in the test suite): +-- +-- haddockA041.hs +-- {-# LANGUAGE CPP #-} +-- -- | Module header documentation +-- module Comments_and_CPP_include where +-- #include "IncludeMe.hs" +-- +-- IncludeMe.hs: +-- -- | Comment on T +-- data T = MkT -- ^ Comment on MkT +-- +-- After the C preprocessor runs, the 'StringBuffer' will contain a program that +-- looks like this (unimportant lines at the beginning removed): +-- +-- # 1 "haddockA041.hs" +-- {-# LANGUAGE CPP #-} +-- -- | Module header documentation +-- module Comments_and_CPP_include where +-- # 1 "IncludeMe.hs" 1 +-- -- | Comment on T +-- data T = MkT -- ^ Comment on MkT +-- # 7 "haddockA041.hs" 2 +-- +-- The line pragmas inserted by CPP make the error messages more informative. +-- The downside is that we can't use RealSrcLoc to determine the ordering of +-- syntactic elements. +-- +-- With RealSrcLoc, we have the following location information recorded in the AST: +-- * The module name is located at haddockA041.hs:3:8-31 +-- * The Haddock comment "Comment on T" is located at IncludeMe:1:1-17 +-- * The data declaration is located at IncludeMe.hs:2:1-32 +-- +-- Is the Haddock comment located between the module name and the data +-- declaration? This is impossible to tell because the locations are not +-- comparable; they even refer to different files. +-- +-- On the other hand, with 'BufPos', we have the following location information: +-- * The module name is located at 846-870 +-- * The Haddock comment "Comment on T" is located at 898-915 +-- * The data declaration is located at 916-928 +-- +-- Aside: if you're wondering why the numbers are so high, try running +-- @ghc -E haddockA041.hs@ +-- and see the extra fluff that CPP inserts at the start of the file. +-- +-- For error messages, 'BufPos' is not useful at all. On the other hand, this is +-- exactly what we need to determine the order of syntactic elements: +-- 870 < 898, therefore the Haddock comment appears *after* the module name. +-- 915 < 916, therefore the Haddock comment appears *before* the data declaration. +-- +-- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock +-- comments with parts of the AST using location information (#17544). +newtype BufPos = BufPos { bufPos :: Int } + deriving (Eq, Ord, Show) + +-- | Source Location +data SrcLoc + = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos] + | UnhelpfulLoc FastString -- Just a general indication + deriving (Eq, Show) + +{- +************************************************************************ +* * +\subsection[SrcLoc-access-fns]{Access functions} +* * +************************************************************************ +-} + +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing + +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc x line col + +getBufPos :: SrcLoc -> Maybe BufPos +getBufPos (RealSrcLoc _ mbpos) = mbpos +getBufPos (UnhelpfulLoc _) = Nothing + +-- | Built-in "bad" 'SrcLoc' values for particular locations +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") + +-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc + +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString +srcLocFile (SrcLoc fname _ _) = fname + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocLine :: RealSrcLoc -> Int +srcLocLine (SrcLoc _ l _) = l + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocCol :: RealSrcLoc -> Int +srcLocCol (SrcLoc _ _ c) = c + +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case +advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c) +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) + +advance_tabstop :: Int -> Int +advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1 + +advanceBufPos :: BufPos -> BufPos +advanceBufPos (BufPos i) = BufPos (i+1) + +{- +************************************************************************ +* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +* * +************************************************************************ +-} + +sortLocated :: [Located a] -> [Located a] +sortLocated = sortBy (leftmost_smallest `on` getLoc) + +sortRealLocated :: [RealLocated a] -> [RealLocated a] +sortRealLocated = sortBy (compare `on` getLoc) + +lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a +lookupSrcLoc (RealSrcLoc l _) = Map.lookup l +lookupSrcLoc (UnhelpfulLoc _) = const Nothing + +lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a +lookupSrcSpan (RealSrcSpan l _) = Map.lookup l +lookupSrcSpan (UnhelpfulSpan _) = const Nothing + +instance Outputable RealSrcLoc where + ppr (SrcLoc src_path src_line src_col) + = hcat [ pprFastFilePath src_path <> colon + , int src_line <> colon + , int src_col ] + +-- I don't know why there is this style-based difference +-- if userStyle sty || debugStyle sty then +-- hcat [ pprFastFilePath src_path, char ':', +-- int src_line, +-- char ':', int src_col +-- ] +-- else +-- hcat [text "{-# LINE ", int src_line, space, +-- char '\"', pprFastFilePath src_path, text " #-}"] + +instance Outputable SrcLoc where + ppr (RealSrcLoc l _) = ppr l + ppr (UnhelpfulLoc s) = ftext s + +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" + +{- +************************************************************************ +* * +\subsection[SrcSpan]{Source Spans} +* * +************************************************************************ +-} + +{- | +A 'RealSrcSpan' delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column /after/ the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} + +-- | Real Source Span +data RealSrcSpan + = RealSrcSpan' + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } + deriving Eq + +-- | StringBuffer Source Span +data BufSpan = + BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } + deriving (Eq, Ord, Show) + +instance Semigroup BufSpan where + BufSpan start1 end1 <> BufSpan start2 end2 = + BufSpan (min start1 start2) (max end1 end2) + +-- | Source Span +-- +-- A 'SrcSpan' identifies either a specific portion of a text file +-- or a human-readable description of a location. +data SrcSpan = + RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] + | UnhelpfulSpan !UnhelpfulSpanReason + + deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we + -- derive Show for Token + +data UnhelpfulSpanReason + = UnhelpfulNoLocationInfo + | UnhelpfulWiredIn + | UnhelpfulInteractive + | UnhelpfulGenerated + | UnhelpfulOther !FastString + deriving (Eq, Show) + +{- Note [Why Maybe BufPos] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). +Why the Maybe? + +Surely, the lexer can always fill in the buffer position, and it guarantees to do so. +However, sometimes the SrcLoc/SrcSpan is constructed in a different context +where the buffer location is not available, and then we use Nothing instead of +a fake value like BufPos (-1). + +Perhaps the compiler could be re-engineered to pass around BufPos more +carefully and never discard it, and this 'Maybe' could be removed. If you're +interested in doing so, you may find this ripgrep query useful: + + rg "RealSrc(Loc|Span).*?Nothing" + +For example, it is not uncommon to whip up source locations for e.g. error +messages, constructing a SrcSpan without a BufSpan. +-} + +instance ToJson SrcSpan where + json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (RealSrcSpan rss _) = json rss + +instance ToJson RealSrcSpan where + json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) + , ("startLine", JSInt srcSpanSLine) + , ("startCol", JSInt srcSpanSCol) + , ("endLine", JSInt srcSpanELine) + , ("endCol", JSInt srcSpanECol) + ] + +instance NFData SrcSpan where + rnf x = x `seq` () + +getBufSpan :: SrcSpan -> Maybe BufSpan +getBufSpan (RealSrcSpan _ mbspan) = mbspan +getBufSpan (UnhelpfulSpan _) = Nothing + +-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty +noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo +wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn +interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive +generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated + +isGeneratedSrcSpan :: SrcSpan -> Bool +isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True +isGeneratedSrcSpan _ = False + +-- | Create a "bad" 'SrcSpan' that has not location information +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther + +-- | Create a 'SrcSpan' corresponding to a single point +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) +srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) + +realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col + +-- | Create a 'SrcSpan' between two points in a file +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +-- | 'True' if the span is known to straddle only one line. +isOneLineRealSpan :: RealSrcSpan -> Bool +isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) + = line1 == line2 + +-- | 'True' if the span is a single point +isPointRealSpan :: RealSrcSpan -> Bool +isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) + = line1 == line2 && col1 == col2 + +-- | Create a 'SrcSpan' between two points in a file +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan (UnhelpfulOther str) +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) +mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Returns UnhelpfulSpan if the files differ. +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) + | srcSpanFile span1 == srcSpanFile span2 + = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) + | otherwise = UnhelpfulSpan $ + UnhelpfulOther (fsLit "") + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans span1 span2 + = RealSrcSpan' file line_start col_start line_end col_end + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 + +combineBufSpans :: BufSpan -> BufSpan -> BufSpan +combineBufSpans span1 span2 = BufSpan start end + where + start = min (bufSpanStart span1) (bufSpanStart span2) + end = max (bufSpanEnd span1) (bufSpanEnd span2) + + +-- | Convert a SrcSpan into one that represents only its first character +srcSpanFirstCharacter :: SrcSpan -> SrcSpan +srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter (RealSrcSpan span mbspan) = + RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) + where + loc1@(SrcLoc f l c) = realSrcSpanStart span + loc2 = SrcLoc f l (c+1) + mkBufSpan bspan = + let bpos1@(BufPos i) = bufSpanStart bspan + bpos2 = BufPos (i+1) + in BufSpan bpos1 bpos2 + +{- +************************************************************************ +* * +\subsection[SrcSpan-predicates]{Predicates} +* * +************************************************************************ +-} + +-- | Test if a 'SrcSpan' is "good", i.e. has precise location information +isGoodSrcSpan :: SrcSpan -> Bool +isGoodSrcSpan (RealSrcSpan _ _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False + +isOneLineSpan :: SrcSpan -> Bool +-- ^ True if the span is known to straddle only one line. +-- For "bad" 'SrcSpan', it returns False +isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False + +-- | Tests whether the first span "contains" the other span, meaning +-- that it covers at least as much source code. True where spans are equal. +containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool +containsSpan s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanEndLine s1, srcSpanEndCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + -- We check file equality last because it is (presumably?) least + -- likely to fail. +{- +%************************************************************************ +%* * +\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} +* * +************************************************************************ +-} + +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int + +srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l +srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l +srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l +srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c + +{- +************************************************************************ +* * +\subsection[SrcSpan-access-fns]{Access functions} +* * +************************************************************************ +-} + +-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanStart :: SrcSpan -> SrcLoc +srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) + +-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanEnd :: SrcSpan -> SrcLoc +srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) + +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +-- | Obtains the filename for a 'SrcSpan' if it is "good" +srcSpanFileName_maybe :: SrcSpan -> Maybe FastString +srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing + +{- +************************************************************************ +* * +\subsection[SrcSpan-instances]{Instances} +* * +************************************************************************ +-} + +-- We want to order RealSrcSpans first by the start point, then by the +-- end point. +instance Ord RealSrcSpan where + a `compare` b = + (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` + (realSrcSpanEnd a `compare` realSrcSpanEnd b) + +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by GHC.Parser.Lexer, because we derive Show for Token +instance Show RealSrcSpan where + show span@(RealSrcSpan' file sl sc el ec) + | isPointRealSpan span + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) + + | isOneLineRealSpan span + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,ec]) + + | otherwise + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + + +instance Outputable RealSrcSpan where + ppr span = pprUserRealSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- text (showUserRealSpan True span) +-- else +-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, +-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] + +instance Outputable SrcSpan where + ppr span = pprUserSpan True span + +instance Outputable UnhelpfulSpanReason where + ppr = pprUnhelpfulSpanReason + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- pprUserSpan True span +-- else +-- case span of +-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" +-- RealSrcSpan s -> ppr s + +unhelpfulSpanFS :: UnhelpfulSpanReason -> FastString +unhelpfulSpanFS r = case r of + UnhelpfulOther s -> s + UnhelpfulNoLocationInfo -> fsLit "" + UnhelpfulWiredIn -> fsLit "" + UnhelpfulInteractive -> fsLit "" + UnhelpfulGenerated -> fsLit "" + +pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc +pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) + +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r +pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) + | isPointRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int col ] + +pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) + | isOneLineRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int scol + , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] + -- For single-character or point spans, we just + -- output the starting column number + +pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , parens (int sline <> comma <> int scol) + , char '-' + , parens (int eline <> comma <> int ecol') ] + where + ecol' = if ecol == 0 then ecol else ecol - 1 + +{- +************************************************************************ +* * +\subsection[Located]{Attaching SrcSpans to things} +* * +************************************************************************ +-} + +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data GenLocated l e = L l e + deriving (Eq, Ord, Data, Functor, Foldable, Traversable) + +type Located = GenLocated SrcSpan +type RealLocated = GenLocated RealSrcSpan + +mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b +mapLoc = fmap + +unLoc :: GenLocated l e -> e +unLoc (L _ e) = e + +getLoc :: GenLocated l e -> l +getLoc (L l _) = l + +noLoc :: e -> Located e +noLoc e = L noSrcSpan e + +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e + +combineLocs :: Located a -> Located b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: + +-- | Tests whether the two located things are equal +eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Ord instance, but this is useful sometimes: + +-- | Tests the ordering of the two located things +cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +-- | Compare the 'BufSpan' of two located things. +-- +-- Precondition: both operands have an associated 'BufSpan'. +cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering +cmpBufSpan (L l1 _) (L l2 _) + | Just a <- getBufSpan l1 + , Just b <- getBufSpan l2 + = compare a b + + | otherwise = panic "cmpBufSpan: no BufSpan" + +instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where + ppr (L l e) = -- TODO: We can't do this since Located was refactored into + -- GenLocated: + -- Print spans without the file name etc + -- ifPprDebug (braces (pprUserSpan False l)) + whenPprDebug (braces (ppr l)) + $$ ppr e + +{- +************************************************************************ +* * +\subsection{Ordering SrcSpans for InteractiveUI} +* * +************************************************************************ +-} + +-- | Strategies for ordering 'SrcSpan's +leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering +rightmost_smallest = compareSrcSpanBy (flip compare) +leftmost_smallest = compareSrcSpanBy compare +leftmost_largest = compareSrcSpanBy $ \a b -> + (realSrcSpanStart a `compare` realSrcSpanStart b) + `thenCmp` + (realSrcSpanEnd b `compare` realSrcSpanEnd a) + +compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering +compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b +compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ + +-- | Determines whether a span encloses a given line and column index +spans :: SrcSpan -> (Int, Int) -> Bool +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span + where loc = mkRealSrcLoc (srcSpanFile span) l c + +-- | Determines whether a span is enclosed by another one +isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other + -> SrcSpan -- ^ The span it may be enclosed by + -> Bool +isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent +isSubspanOf _ _ = False + +-- | Determines whether a span is enclosed by another one +isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other + -> RealSrcSpan -- ^ The span it may be enclosed by + -> Bool +isRealSubspanOf src parent + | srcSpanFile parent /= srcSpanFile src = False + | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && + realSrcSpanEnd parent >= realSrcSpanEnd src + +liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) +liftL f (L loc a) = do + a' <- f a + return $ L loc a' + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan (L l _) = l + +unRealSrcSpan :: RealLocated a -> a +unRealSrcSpan (L _ e) = e + + +-- | A location as produced by the parser. Consists of two components: +-- +-- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc) +-- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632) +data PsLoc + = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } + deriving (Eq, Ord, Show) + +data PsSpan + = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } + deriving (Eq, Ord, Show) + +type PsLocated = GenLocated PsSpan + +advancePsLoc :: PsLoc -> Char -> PsLoc +advancePsLoc (PsLoc real_loc buf_loc) c = + PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) + +mkPsSpan :: PsLoc -> PsLoc -> PsSpan +mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2) + +psSpanStart :: PsSpan -> PsLoc +psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) + +psSpanEnd :: PsSpan -> PsLoc +psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) + +mkSrcSpanPs :: PsSpan -> SrcSpan +mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b) + +-- | Layout information for declarations. +data LayoutInfo = + + -- | Explicit braces written by the user. + -- + -- @ + -- class C a where { foo :: a; bar :: a } + -- @ + ExplicitBraces + | + -- | Virtual braces inserted by the layout algorithm. + -- + -- @ + -- class C a where + -- foo :: a + -- bar :: a + -- @ + VirtualBraces + !Int -- ^ Layout column (indentation level, begins at 1) + | + -- | Empty or compiler-generated blocks do not have layout information + -- associated with them. + NoLayoutInfo + + deriving (Eq, Ord, Show, Data) + +-- | Indentation level is 1-indexed, so the leftmost column is 1. +leftmostColumn :: Int +leftmostColumn = 1 diff --git a/GHC/Types/Unique.hs b/GHC/Types/Unique.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique.hs @@ -0,0 +1,448 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ + +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). +-} + +{-# LANGUAGE CPP, BangPatterns, MagicHash #-} + +module GHC.Types.Unique ( + -- * Main data types + Unique, Uniquable(..), + uNIQUE_BITS, + + -- ** Constructors, destructors and operations on 'Unique's + hasKey, + + pprUniqueAlways, + + mkUniqueGrimily, + getKey, + mkUnique, unpkUnique, + eqUnique, ltUnique, + incrUnique, + + newTagUnique, + initTyVarUnique, + initExitJoinUnique, + nonDetCmpUnique, + isValidKnownKeyUnique, + + -- ** Making built-in uniques + + -- now all the built-in GHC.Types.Uniques (and functions to make them) + -- [the Oh-So-Wonderful Haskell module system wins again...] + mkAlphaTyVarUnique, + mkPrimOpIdUnique, mkPrimOpWrapperUnique, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkCoVarUnique, + + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkCostCentreUnique, + + mkBuiltinUnique, + mkPseudoUniqueD, + mkPseudoUniqueE, + mkPseudoUniqueH, + + -- ** Deriving uniques + -- *** From TyCon name uniques + tyConRepNameUnique, + -- *** From DataCon name uniques + dataConWorkerUnique, dataConTyRepNameUnique, + + -- ** Local uniques + -- | These are exposed exclusively for use by 'GHC.Types.Var.Env.uniqAway', which + -- has rather peculiar needs. See Note [Local uniques]. + mkLocalUnique, minLocalUnique, maxLocalUnique + ) where + +#include "HsVersions.h" +#include "Unique.h" + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc + +-- just for implementing a fast [0,61) -> Char function +import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) + +import Data.Char ( chr, ord ) +import Data.Bits + +{- +************************************************************************ +* * +\subsection[Unique-type]{@Unique@ type and operations} +* * +************************************************************************ + +The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. +Fast comparison is everything on @Uniques@: +-} + +-- | Unique identifier. +-- +-- The type of unique identifiers that are used in many places in GHC +-- for fast ordering and equality tests. You should generate these with +-- the functions from the 'UniqSupply' module +-- +-- These are sometimes also referred to as \"keys\" in comments in GHC. +newtype Unique = MkUnique Int + +{-# INLINE uNIQUE_BITS #-} +uNIQUE_BITS :: Int +uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS + +{- +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. +-} + +unpkUnique :: Unique -> (Char, Int) -- The reverse + +mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply +getKey :: Unique -> Int -- for Var + +incrUnique :: Unique -> Unique +stepUnique :: Unique -> Int -> Unique +newTagUnique :: Unique -> Char -> Unique + +mkUniqueGrimily = MkUnique + +{-# INLINE getKey #-} +getKey (MkUnique x) = x + +incrUnique (MkUnique i) = MkUnique (i + 1) +stepUnique (MkUnique i) n = MkUnique (i + n) + +mkLocalUnique :: Int -> Unique +mkLocalUnique i = mkUnique 'X' i + +minLocalUnique :: Unique +minLocalUnique = mkLocalUnique 0 + +maxLocalUnique :: Unique +maxLocalUnique = mkLocalUnique uniqueMask + +-- newTagUnique changes the "domain" of a unique to a different char +newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u + +-- | How many bits are devoted to the unique index (as opposed to the class +-- character). +uniqueMask :: Int +uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 + +-- pop the Char in the top 8 bits of the Unique(Supply) + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +-- and as long as the Char fits in 8 bits, which we assume anyway! + +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +-- NOT EXPORTED, so that we can see all the Chars that +-- are used in this one module +mkUnique c i + = MkUnique (tag .|. bits) + where + tag = ord c `shiftL` uNIQUE_BITS + bits = i .&. uniqueMask + +unpkUnique (MkUnique u) + = let + -- as long as the Char may have its eighth bit set, we + -- really do need the logical right-shift here! + tag = chr (u `shiftR` uNIQUE_BITS) + i = u .&. uniqueMask + in + (tag, i) + +-- | The interface file symbol-table encoding assumes that known-key uniques fit +-- in 30-bits; verify this. +-- +-- See Note [Symbol table representation of names] in "GHC.Iface.Binary" for details. +isValidKnownKeyUnique :: Unique -> Bool +isValidKnownKeyUnique u = + case unpkUnique u of + (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) + +{- +************************************************************************ +* * +\subsection[Uniquable-class]{The @Uniquable@ class} +* * +************************************************************************ +-} + +-- | Class of things that we can obtain a 'Unique' from +class Uniquable a where + getUnique :: a -> Unique + +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + +instance Uniquable FastString where + getUnique fs = mkUniqueGrimily (uniqueOfFS fs) + +instance Uniquable Int where + getUnique i = mkUniqueGrimily i + +{- +************************************************************************ +* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +* * +************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). +-} + +-- Note [Unique Determinism] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The order of allocated @Uniques@ is not stable across rebuilds. +-- The main reason for that is that typechecking interface files pulls +-- @Uniques@ from @UniqSupply@ and the interface file for the module being +-- currently compiled can, but doesn't have to exist. +-- +-- It gets more complicated if you take into account that the interface +-- files are loaded lazily and that building multiple files at once has to +-- work for any subset of interface files present. When you add parallelism +-- this makes @Uniques@ hopelessly random. +-- +-- As such, to get deterministic builds, the order of the allocated +-- @Uniques@ should not affect the final result. +-- see also wiki/deterministic-builds +-- +-- Note [Unique Determinism and code generation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The goal of the deterministic builds (wiki/deterministic-builds, #4012) +-- is to get ABI compatible binaries given the same inputs and environment. +-- The motivation behind that is that if the ABI doesn't change the +-- binaries can be safely reused. +-- Note that this is weaker than bit-for-bit identical binaries and getting +-- bit-for-bit identical binaries is not a goal for now. +-- This means that we don't care about nondeterminism that happens after +-- the interface files are created, in particular we don't care about +-- register allocation and code generation. +-- To track progress on bit-for-bit determinism see #12262. + +eqUnique :: Unique -> Unique -> Bool +eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 + +ltUnique :: Unique -> Unique -> Bool +ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 + +-- Provided here to make it explicit at the call-site that it can +-- introduce non-determinism. +-- See Note [Unique Determinism] +-- See Note [No Ord for Unique] +nonDetCmpUnique :: Unique -> Unique -> Ordering +nonDetCmpUnique (MkUnique u1) (MkUnique u2) + = if u1 == u2 then EQ else if u1 < u2 then LT else GT + +{- +Note [No Ord for Unique] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Unique Determinism] the relative order of Uniques +is nondeterministic. To prevent from accidental use the Ord Unique +instance has been removed. +This makes it easier to maintain deterministic builds, but comes with some +drawbacks. +The biggest drawback is that Maps keyed by Uniques can't directly be used. +The alternatives are: + + 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which + 2) Create a newtype wrapper based on Unique ordering where nondeterminism + is controlled. See Module.ModuleEnv + 3) Change the algorithm to use nonDetCmpUnique and document why it's still + deterministic + 4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel +-} + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Uniquable Unique where + getUnique u = u + +-- We do sometimes make strings with @Uniques@ in them: + +showUnique :: Unique -> String +showUnique uniq + = case unpkUnique uniq of + (tag, u) -> finish_show tag u (iToBase62 u) + +finish_show :: Char -> Int -> String -> String +finish_show 't' u _pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + [chr (ord 'a' + u)] +finish_show tag _ pp_u = tag : pp_u + +pprUniqueAlways :: Unique -> SDoc +-- The "always" means regardless of -dsuppress-uniques +-- It replaces the old pprUnique to remind callers that +-- they should consider whether they want to consult +-- Opt_SuppressUniques +pprUniqueAlways u + = text (showUnique u) + +instance Outputable Unique where + ppr = pprUniqueAlways + +instance Show Unique where + show uniq = showUnique uniq + +{- +************************************************************************ +* * +\subsection[Utils-base62]{Base-62 numbers} +* * +************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. +Code stolen from Lennart. +-} + +iToBase62 :: Int -> String +iToBase62 n_ + = ASSERT(n_ >= 0) go n_ "" + where + go n cs | n < 62 + = let !c = chooseChar62 n in c : cs + | otherwise + = go q (c : cs) where (!q, r) = quotRem n 62 + !c = chooseChar62 r + + chooseChar62 :: Int -> Char + {-# INLINE chooseChar62 #-} + chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) + chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# + +{- +************************************************************************ +* * +\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} +* * +************************************************************************ + +Allocation of unique supply characters: + v,t,u : for renumbering value-, type- and usage- vars. + B: builtin + C-E: pseudo uniques (used in native-code generator) + X: uniques from mkLocalUnique + _: unifiable tyvars (above) + 0-9: prelude things below + (no numbers left any more..) + :: (prelude) parallel array data constructors + + other a-z: lower case chars for unique supplies. Used so far: + + d desugarer + f AbsC flattener + g SimplStg + k constraint tuple tycons + m constraint tuple datacons + n Native codegen + r Hsc name cache + s simplifier + z anonymous sums +-} + +mkAlphaTyVarUnique :: Int -> Unique +mkPreludeClassUnique :: Int -> Unique +mkPreludeTyConUnique :: Int -> Unique +mkPreludeDataConUnique :: Arity -> Unique +mkPrimOpIdUnique :: Int -> Unique +-- See Note [Primop wrappers] in GHC.Builtin.PrimOps. +mkPrimOpWrapperUnique :: Int -> Unique +mkPreludeMiscIdUnique :: Int -> Unique +mkCoVarUnique :: Int -> Unique + +mkAlphaTyVarUnique i = mkUnique '1' i +mkCoVarUnique i = mkUnique 'g' i +mkPreludeClassUnique i = mkUnique '2' i + +-------------------------------------------------- +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +mkPreludeTyConUnique i = mkUnique '3' (2*i) + +tyConRepNameUnique :: Unique -> Unique +tyConRepNameUnique u = incrUnique u + +-------------------------------------------------- +-- Wired-in data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon +-- Prelude data constructors are too simple to need wrappers. + +mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic + +-------------------------------------------------- +dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique +dataConWorkerUnique u = incrUnique u +dataConTyRepNameUnique u = stepUnique u 2 + +-------------------------------------------------- +mkPrimOpIdUnique op = mkUnique '9' (2*op) +mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) +mkPreludeMiscIdUnique i = mkUnique '0' i + +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, + mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUnique 'B' i +mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs +mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUnique 'R' +mkRegSubUnique = mkUnique 'S' +mkRegPairUnique = mkUnique 'P' +mkRegClassUnique = mkUnique 'L' + +mkCostCentreUnique :: Int -> Unique +mkCostCentreUnique = mkUnique 'C' + +mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique +-- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence +mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) +mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) +mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) +mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) + +initExitJoinUnique :: Unique +initExitJoinUnique = mkUnique 's' 0 + diff --git a/GHC/Types/Unique/DFM.hs b/GHC/Types/Unique/DFM.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/DFM.hs @@ -0,0 +1,443 @@ +{- +(c) Bartosz Nitka, Facebook, 2015 + +UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +This is very similar to @UniqFM@, the major difference being that the order of +folding is not dependent on @Unique@ ordering, giving determinism. +Currently the ordering is determined by insertion order. + +See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ ordering +is not deterministic. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.DFM ( + -- * Unique-keyed deterministic mappings + UniqDFM, -- abstract type + + -- ** Manipulating those mappings + emptyUDFM, + unitUDFM, + addToUDFM, + addToUDFM_C, + addToUDFM_C_Directly, + addToUDFM_Directly, + addListToUDFM, + delFromUDFM, + delListFromUDFM, + adjustUDFM, + adjustUDFM_Directly, + alterUDFM, + mapUDFM, + plusUDFM, + plusUDFM_C, + lookupUDFM, lookupUDFM_Directly, + elemUDFM, + foldUDFM, + eltsUDFM, + filterUDFM, filterUDFM_Directly, + isNullUDFM, + sizeUDFM, + intersectUDFM, udfmIntersectUFM, + disjointUDFM, disjointUdfmUfm, + equalKeysUDFM, + minusUDFM, + listToUDFM, listToUDFM_Directly, + udfmMinusUFM, ufmMinusUDFM, + partitionUDFM, + anyUDFM, allUDFM, + pprUniqDFM, pprUDFM, + + udfmToList, + udfmToUfm, + nonDetStrictFoldUDFM, + unsafeCastUDFMKey, + alwaysUnsafeUfmToUdfm, + ) where + +import GHC.Prelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) +import GHC.Utils.Outputable + +import qualified Data.IntMap as M +import Data.Data +import Data.Functor.Classes (Eq1 (..)) +import Data.List (sortBy) +import Data.Function (on) +import qualified Data.Semigroup as Semi +import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) +import Unsafe.Coerce + +-- Note [Deterministic UniqFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A @UniqDFM@ is just like @UniqFM@ with the following additional +-- property: the function `udfmToList` returns the elements in some +-- deterministic order not depending on the Unique key for those elements. +-- +-- If the client of the map performs operations on the map in deterministic +-- order then `udfmToList` returns them in deterministic order. +-- +-- There is an implementation cost: each element is given a serial number +-- as it is added, and `udfmToList` sorts it's result by this serial +-- number. So you should only use `UniqDFM` if you need the deterministic +-- property. +-- +-- `foldUDFM` also preserves determinism. +-- +-- Normal @UniqFM@ when you turn it into a list will use +-- Data.IntMap.toList function that returns the elements in the order of +-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with +-- with a list ordered by @Uniques@. +-- The order of @Uniques@ is known to be not stable across rebuilds. +-- See Note [Unique Determinism] in GHC.Types.Unique. +-- +-- +-- There's more than one way to implement this. The implementation here tags +-- every value with the insertion time that can later be used to sort the +-- values when asked to convert to a list. +-- +-- An alternative would be to have +-- +-- data UniqDFM ele = UDFM (M.IntMap ele) [ele] +-- +-- where the list determines the order. This makes deletion tricky as we'd +-- only accumulate elements in that list, but makes merging easier as you +-- can just merge both structures independently. +-- Deletion can probably be done in amortized fashion when the size of the +-- list is twice the size of the set. + +-- | A type of values tagged with insertion time +data TaggedVal val = + TaggedVal + val + {-# UNPACK #-} !Int -- ^ insertion time + deriving (Data, Functor) + +taggedFst :: TaggedVal val -> val +taggedFst (TaggedVal v _) = v + +taggedSnd :: TaggedVal val -> Int +taggedSnd (TaggedVal _ i) = i + +instance Eq val => Eq (TaggedVal val) where + (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 + +-- | Type of unique deterministic finite maps +-- +-- The key is just here to keep us honest. It's always safe +-- to use a single type as key. +-- If two types don't overlap in their uniques it's also safe +-- to index the same map at multiple key types. But this is +-- very much discouraged. +data UniqDFM key ele = + UDFM + !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and + -- values are tagged with insertion time. + -- The invariant is that all the tags will + -- be distinct within a single map + {-# UNPACK #-} !Int -- Upper bound on the values' insertion + -- time. See Note [Overflow on plusUDFM] + deriving (Data, Functor) + +-- | Deterministic, in O(n log n). +instance Foldable (UniqDFM key) where + foldr = foldUDFM + +-- | Deterministic, in O(n log n). +instance Traversable (UniqDFM key) where + traverse f = fmap listToUDFM_Directly + . traverse (\(u,a) -> (u,) <$> f a) + . udfmToList + +emptyUDFM :: UniqDFM key elt +emptyUDFM = UDFM M.empty 0 + +unitUDFM :: Uniquable key => key -> elt -> UniqDFM key elt +unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 + +-- The new binding always goes to the right of existing ones +addToUDFM :: Uniquable key => UniqDFM key elt -> key -> elt -> UniqDFM key elt +addToUDFM m k v = addToUDFM_Directly m (getUnique k) v + +-- The new binding always goes to the right of existing ones +addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt +addToUDFM_Directly (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i + -- Keep the old tag, but insert the new value + -- This means that udfmToList typically returns elements + -- in the order of insertion, rather than the reverse + +addToUDFM_C_Directly + :: (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM key elt + -> Unique -> elt + -> UniqDFM key elt +addToUDFM_C_Directly f (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal old_v old_i) + = TaggedVal (f old_v new_v) old_i + -- Flip the arguments, because M.insertWith uses (new->old->result) + -- but f needs (old->new->result) + -- Like addToUDFM_Directly, keep the old tag + +addToUDFM_C + :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM key elt -- old + -> key -> elt -- new + -> UniqDFM key elt -- result +addToUDFM_C f m k v = addToUDFM_C_Directly f m (getUnique k) v + +addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt +addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) + +addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt +addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) + +addListToUDFM_Directly_C + :: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt +addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v) + +delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt +delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i + +plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft_C f udfml udfmr + | otherwise = insertUDFMIntoLeft_C f udfmr udfml + +-- Note [Overflow on plusUDFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There are multiple ways of implementing plusUDFM. +-- The main problem that needs to be solved is overlap on times of +-- insertion between different keys in two maps. +-- Consider: +-- +-- A = fromList [(a, (x, 1))] +-- B = fromList [(b, (y, 1))] +-- +-- If you merge them naively you end up with: +-- +-- C = fromList [(a, (x, 1)), (b, (y, 1))] +-- +-- Which loses information about ordering and brings us back into +-- non-deterministic world. +-- +-- The solution I considered before would increment the tags on one of the +-- sets by the upper bound of the other set. The problem with this approach +-- is that you'll run out of tags for some merge patterns. +-- Say you start with A with upper bound 1, you merge A with A to get A' and +-- the upper bound becomes 2. You merge A' with A' and the upper bound +-- doubles again. After 64 merges you overflow. +-- This solution would have the same time complexity as plusUFM, namely O(n+m). +-- +-- The solution I ended up with has time complexity of +-- O(m log m + m * min (n+m, W)) where m is the smaller set. +-- It simply inserts the elements of the smaller set into the larger +-- set in the order that they were inserted into the smaller set. That's +-- O(m log m) for extracting the elements from the smaller set in the +-- insertion order and O(m * min(n+m, W)) to insert them into the bigger +-- set. + +plusUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft udfml udfmr + | otherwise = insertUDFMIntoLeft udfmr udfml + +insertUDFMIntoLeft :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr + +insertUDFMIntoLeft_C + :: (elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +insertUDFMIntoLeft_C f udfml udfmr = + addListToUDFM_Directly_C f udfml $ udfmToList udfmr + +lookupUDFM :: Uniquable key => UniqDFM key elt -> key -> Maybe elt +lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m + +lookupUDFM_Directly :: UniqDFM key elt -> Unique -> Maybe elt +lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m + +elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool +elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m + +-- | Performs a deterministic fold over the UniqDFM. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a +foldUDFM k z m = foldr k z (eltsUDFM m) + +-- | Performs a nondeterministic strict fold over the UniqDFM. +-- It's O(n), same as the corresponding function on `UniqFM`. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a +nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m + where + k' acc (TaggedVal v _) = k v acc + +eltsUDFM :: UniqDFM key elt -> [elt] +eltsUDFM (UDFM m _i) = + map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m + +filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt +filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i + +filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt +filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i + where + p' k (TaggedVal v _) = p (getUnique k) v + +-- | Converts `UniqDFM` to a list, with elements in deterministic order. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +udfmToList :: UniqDFM key elt -> [(Unique, elt)] +udfmToList (UDFM m _i) = + [ (getUnique k, taggedFst v) + | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] + +-- Determines whether two 'UniqDFM's contain the same keys. +equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool +equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 + +isNullUDFM :: UniqDFM key elt -> Bool +isNullUDFM (UDFM m _) = M.null m + +sizeUDFM :: UniqDFM key elt -> Int +sizeUDFM (UDFM m _i) = M.size m + +intersectUDFM :: UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +udfmIntersectUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1 +udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +disjointUDFM :: UniqDFM key elt -> UniqDFM key elt -> Bool +disjointUDFM (UDFM x _i) (UDFM y _j) = M.disjoint x y + +disjointUdfmUfm :: UniqDFM key elt -> UniqFM key elt2 -> Bool +disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToIntMap y) + +minusUDFM :: UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1 +minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +udfmMinusUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1 +udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +ufmMinusUDFM :: UniqFM key elt1 -> UniqDFM key elt2 -> UniqFM key elt1 +ufmMinusUDFM x (UDFM y _i) = unsafeIntMapToUFM (M.difference (ufmToIntMap x) y) + +-- | Partition UniqDFM into two UniqDFMs according to the predicate +partitionUDFM :: (elt -> Bool) -> UniqDFM key elt -> (UniqDFM key elt, UniqDFM key elt) +partitionUDFM p (UDFM m i) = + case M.partition (p . taggedFst) m of + (left, right) -> (UDFM left i, UDFM right i) + +-- | Delete a list of elements from a UniqDFM +delListFromUDFM :: Uniquable key => UniqDFM key elt -> [key] -> UniqDFM key elt +delListFromUDFM = foldl' delFromUDFM + +-- | This allows for lossy conversion from UniqDFM to UniqFM +udfmToUfm :: UniqDFM key elt -> UniqFM key elt +udfmToUfm (UDFM m _i) = unsafeIntMapToUFM (M.map taggedFst m) + +listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM key elt +listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM + +listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM key elt +listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM + +-- | Apply a function to a particular element +adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt +adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i + +-- | Apply a function to a particular element +adjustUDFM_Directly :: (elt -> elt) -> UniqDFM key elt -> Unique -> UniqDFM key elt +adjustUDFM_Directly f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey k) m) i + +-- | The expression (alterUDFM f k map) alters value x at k, or absence +-- thereof. alterUDFM can be used to insert, delete, or update a value in +-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are +-- more efficient. +alterUDFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqDFM key elt -- old + -> key -- new + -> UniqDFM key elt -- result +alterUDFM f (UDFM m i) k = + UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) + where + alterf Nothing = inject $ f Nothing + alterf (Just (TaggedVal v _)) = inject $ f (Just v) + inject Nothing = Nothing + inject (Just v) = Just $ TaggedVal v i + +-- | Map a function over every value in a UniqDFM +mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 +mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i + +anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool +anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m + +allUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool +allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m + +instance Semi.Semigroup (UniqDFM key a) where + (<>) = plusUDFM + +instance Monoid (UniqDFM key a) where + mempty = emptyUDFM + mappend = (Semi.<>) + +-- This should not be used in committed code, provided for convenience to +-- make ad-hoc conversions when developing +alwaysUnsafeUfmToUdfm :: UniqFM key elt -> UniqDFM key elt +alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList + +-- | Cast the key domain of a UniqFM. +-- +-- As long as the domains don't overlap in their uniques +-- this is safe. +unsafeCastUDFMKey :: UniqDFM key1 elt -> UniqDFM key2 elt +unsafeCastUDFMKey = unsafeCoerce -- Only phantom parameter changes so + -- this is safe and avoids reallocation. + +-- Output-ery + +instance Outputable a => Outputable (UniqDFM key a) where + ppr ufm = pprUniqDFM ppr ufm + +pprUniqDFM :: (a -> SDoc) -> UniqDFM key a -> SDoc +pprUniqDFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- udfmToList ufm ] + +pprUDFM :: UniqDFM key a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/GHC/Types/Unique/DSet.hs b/GHC/Types/Unique/DSet.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/DSet.hs @@ -0,0 +1,144 @@ +-- (c) Bartosz Nitka, Facebook, 2015 + +-- | +-- Specialised deterministic sets, for things with @Uniques@ +-- +-- Based on 'UniqDFM's (as you would expect). +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why we need it. +-- +-- Basically, the things need to be in class 'Uniquable'. + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.DSet ( + -- * Unique set type + UniqDSet, -- type synonym for UniqFM a + getUniqDSet, + pprUniqDSet, + + -- ** Manipulating these sets + delOneFromUniqDSet, delListFromUniqDSet, + emptyUniqDSet, + unitUniqDSet, + mkUniqDSet, + addOneToUniqDSet, addListToUniqDSet, + unionUniqDSets, unionManyUniqDSets, + minusUniqDSet, uniqDSetMinusUniqSet, + intersectUniqDSets, uniqDSetIntersectUniqSet, + nonDetStrictFoldUniqDSet, + elementOfUniqDSet, + filterUniqDSet, + sizeUniqDSet, + isEmptyUniqDSet, + lookupUniqDSet, + uniqDSetToList, + partitionUniqDSet, + mapUniqDSet + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set +import GHC.Types.Unique + +import Data.Coerce +import Data.Data +import qualified Data.Semigroup as Semi + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. +-- Beyond preserving invariants, we may also want to 'override' typeclass +-- instances. + +newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqDSet :: UniqDSet a +emptyUniqDSet = UniqDSet emptyUDFM + +unitUniqDSet :: Uniquable a => a -> UniqDSet a +unitUniqDSet x = UniqDSet (unitUDFM x x) + +mkUniqDSet :: Uniquable a => [a] -> UniqDSet a +mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet + +-- The new element always goes to the right of existing ones. +addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) + +addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +addListToUniqDSet = foldl' addOneToUniqDSet + +delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s + +delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s + +unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) + +unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a +unionManyUniqDSets [] = emptyUniqDSet +unionManyUniqDSets (x:xs) = foldl' unionUniqDSets x xs + +minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a +minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) + +uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a +uniqDSetMinusUniqSet xs ys + = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) + +intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) + +uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a +uniqDSetIntersectUniqSet xs ys + = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b +nonDetStrictFoldUniqDSet f acc (UniqDSet s) = nonDetStrictFoldUDFM f acc s + +elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool +elementOfUniqDSet k = elemUDFM k . getUniqDSet + +filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a +filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) + +sizeUniqDSet :: UniqDSet a -> Int +sizeUniqDSet = sizeUDFM . getUniqDSet + +isEmptyUniqDSet :: UniqDSet a -> Bool +isEmptyUniqDSet = isNullUDFM . getUniqDSet + +lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a +lookupUniqDSet = lookupUDFM . getUniqDSet + +uniqDSetToList :: UniqDSet a -> [a] +uniqDSetToList = eltsUDFM . getUniqDSet + +partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) +partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set +mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList + +-- Two 'UniqDSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqDSet a) where + UniqDSet a == UniqDSet b = equalKeysUDFM a b + +getUniqDSet :: UniqDSet a -> UniqDFM a a +getUniqDSet = getUniqDSet' + +instance Outputable a => Outputable (UniqDSet a) where + ppr = pprUniqDSet ppr + +pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc +pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/GHC/Types/Unique/FM.hs b/GHC/Types/Unique/FM.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/FM.hs @@ -0,0 +1,481 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +UniqFM: Specialised finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +The interface is based on @FiniteMap@s, but the implementation uses +@Data.IntMap@, which is both maintained and faster than the past +implementation (see commit log). + +The @UniqFM@ interface maps directly to Data.IntMap, only +``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased +and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order +of arguments of combining function. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.FM ( + -- * Unique-keyed mappings + UniqFM, -- abstract type + NonDetUniqFM(..), -- wrapper for opting into nondeterminism + + -- ** Manipulating those mappings + emptyUFM, + unitUFM, + unitDirectlyUFM, + listToUFM, + listToUFM_Directly, + listToUFM_C, + listToIdentityUFM, + addToUFM,addToUFM_C,addToUFM_Acc, + addListToUFM,addListToUFM_C, + addToUFM_Directly, + addListToUFM_Directly, + adjustUFM, alterUFM, + adjustUFM_Directly, + delFromUFM, + delFromUFM_Directly, + delListFromUFM, + delListFromUFM_Directly, + plusUFM, + plusUFM_C, + plusUFM_CD, + plusUFM_CD2, + mergeUFM, + plusMaybeUFM_C, + plusUFMList, + minusUFM, + intersectUFM, + intersectUFM_C, + disjointUFM, + equalKeysUFM, + nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_Directly, + anyUFM, allUFM, seqEltsUFM, + mapUFM, mapUFM_Directly, + mapMaybeUFM, + elemUFM, elemUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, + sizeUFM, + isNullUFM, + lookupUFM, lookupUFM_Directly, + lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + nonDetEltsUFM, eltsUFM, nonDetKeysUFM, + ufmToSet_Directly, + nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM, + unsafeCastUFMKey, + pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM + ) where + +import GHC.Prelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) +import GHC.Utils.Outputable + +import qualified Data.IntMap as M +import qualified Data.IntSet as S +import Data.Data +import qualified Data.Semigroup as Semi +import Data.Functor.Classes (Eq1 (..)) +import Data.Coerce + +-- | A finite map from @uniques@ of one type to +-- elements in another type. +-- +-- The key is just here to keep us honest. It's always safe +-- to use a single type as key. +-- If two types don't overlap in their uniques it's also safe +-- to index the same map at multiple key types. But this is +-- very much discouraged. +newtype UniqFM key ele = UFM (M.IntMap ele) + deriving (Data, Eq, Functor) + -- Nondeterministic Foldable and Traversable instances are accessible through + -- use of the 'NonDetUniqFM' wrapper. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. + +emptyUFM :: UniqFM key elt +emptyUFM = UFM M.empty + +isNullUFM :: UniqFM key elt -> Bool +isNullUFM (UFM m) = M.null m + +unitUFM :: Uniquable key => key -> elt -> UniqFM key elt +unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) + +-- when you've got the Unique already +unitDirectlyUFM :: Unique -> elt -> UniqFM key elt +unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) + +listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt +listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM + +listToUFM_Directly :: [(Unique, elt)] -> UniqFM key elt +listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM + +listToIdentityUFM :: Uniquable key => [key] -> UniqFM key key +listToIdentityUFM = foldl' (\m x -> addToUFM m x x) emptyUFM + +listToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> [(key, elt)] + -> UniqFM key elt +listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM + +addToUFM :: Uniquable key => UniqFM key elt -> key -> elt -> UniqFM key elt +addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) + +addListToUFM :: Uniquable key => UniqFM key elt -> [(key,elt)] -> UniqFM key elt +addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) + +addListToUFM_Directly :: UniqFM key elt -> [(Unique,elt)] -> UniqFM key elt +addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) + +addToUFM_Directly :: UniqFM key elt -> Unique -> elt -> UniqFM key elt +addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) + +addToUFM_C + :: Uniquable key + => (elt -> elt -> elt) -- old -> new -> result + -> UniqFM key elt -- old + -> key -> elt -- new + -> UniqFM key elt -- result +-- Arguments of combining function of M.insertWith and addToUFM_C are flipped. +addToUFM_C f (UFM m) k v = + UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) + +addToUFM_Acc + :: Uniquable key + => (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM key elts -- old + -> key -> elt -- new + -> UniqFM key elts -- result +addToUFM_Acc exi new (UFM m) k v = + UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) + +alterUFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqFM key elt -- old + -> key -- new + -> UniqFM key elt -- result +alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) + +-- | Add elements to the map, combining existing values with inserted ones using +-- the given function. +addListToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> UniqFM key elt -> [(key,elt)] + -> UniqFM key elt +addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) + +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM key elt -> key -> UniqFM key elt +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) + +adjustUFM_Directly :: (elt -> elt) -> UniqFM key elt -> Unique -> UniqFM key elt +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + +delFromUFM :: Uniquable key => UniqFM key elt -> key -> UniqFM key elt +delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) + +delListFromUFM :: Uniquable key => UniqFM key elt -> [key] -> UniqFM key elt +delListFromUFM = foldl' delFromUFM + +delListFromUFM_Directly :: UniqFM key elt -> [Unique] -> UniqFM key elt +delListFromUFM_Directly = foldl' delFromUFM_Directly + +delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt +delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) + +-- Bindings in right argument shadow those in the left +plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +-- M.union is left-biased, plusUFM should be right-biased. +plusUFM (UFM x) (UFM y) = UFM (M.union y x) + -- Note (M.union y x), with arguments flipped + -- M.union is left-biased, plusUFM should be right-biased. + +plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) + +-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the +-- combinding function and `d1` resp. `d2` as the default value if +-- there is no entry in `m1` reps. `m2`. The domain is the union of +-- the domains of `m1` and `m2`. +-- +-- Representative example: +-- +-- @ +-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 +-- == {A: f 1 42, B: f 2 3, C: f 23 4 } +-- @ +plusUFM_CD + :: (elta -> eltb -> eltc) + -> UniqFM key elta -- map X + -> elta -- default for X + -> UniqFM key eltb -- map Y + -> eltb -- default for Y + -> UniqFM key eltc +plusUFM_CD f (UFM xm) dx (UFM ym) dy + = UFM $ M.mergeWithKey + (\_ x y -> Just (x `f` y)) + (M.map (\x -> x `f` dy)) + (M.map (\y -> dx `f` y)) + xm ym + +-- | `plusUFM_CD2 f m1 m2` merges the maps using `f` as the combining +-- function. Unlike `plusUFM_CD`, a missing value is not defaulted: it is +-- instead passed as `Nothing` to `f`. `f` can never have both its arguments +-- be `Nothing`. +-- +-- `plusUFM_CD2 f m1 m2` is the same as `plusUFM_CD f (mapUFM Just m1) Nothing +-- (mapUFM Just m2) Nothing`. +plusUFM_CD2 + :: (Maybe elta -> Maybe eltb -> eltc) + -> UniqFM key elta -- map X + -> UniqFM key eltb -- map Y + -> UniqFM key eltc +plusUFM_CD2 f (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> Just (Just x `f` Just y)) + (M.map (\x -> Just x `f` Nothing)) + (M.map (\y -> Nothing `f` Just y)) + xm ym + +mergeUFM + :: (elta -> eltb -> Maybe eltc) + -> (UniqFM key elta -> UniqFM key eltc) -- map X + -> (UniqFM key eltb -> UniqFM key eltc) -- map Y + -> UniqFM key elta + -> UniqFM key eltb + -> UniqFM key eltc +mergeUFM f g h (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> (x `f` y)) + (coerce g) + (coerce h) + xm ym + +plusMaybeUFM_C :: (elt -> elt -> Maybe elt) + -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +plusMaybeUFM_C f (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> x `f` y) + id + id + xm ym + +plusUFMList :: [UniqFM key elt] -> UniqFM key elt +plusUFMList = foldl' plusUFM emptyUFM + +minusUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 +minusUFM (UFM x) (UFM y) = UFM (M.difference x y) + +intersectUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 +intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) + +intersectUFM_C + :: (elt1 -> elt2 -> elt3) + -> UniqFM key elt1 + -> UniqFM key elt2 + -> UniqFM key elt3 +intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) + +disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool +disjointUFM (UFM x) (UFM y) = M.disjoint x y + +foldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a +foldUFM k z (UFM m) = M.foldr k z m + +mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 +mapUFM f (UFM m) = UFM (M.map f m) + +mapMaybeUFM :: (elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2 +mapMaybeUFM f (UFM m) = UFM (M.mapMaybe f m) + +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) + +filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt +filterUFM p (UFM m) = UFM (M.filter p m) + +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM key elt -> UniqFM key elt +filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) + +partitionUFM :: (elt -> Bool) -> UniqFM key elt -> (UniqFM key elt, UniqFM key elt) +partitionUFM p (UFM m) = + case M.partition p m of + (left, right) -> (UFM left, UFM right) + +sizeUFM :: UniqFM key elt -> Int +sizeUFM (UFM m) = M.size m + +elemUFM :: Uniquable key => key -> UniqFM key elt -> Bool +elemUFM k (UFM m) = M.member (getKey $ getUnique k) m + +elemUFM_Directly :: Unique -> UniqFM key elt -> Bool +elemUFM_Directly u (UFM m) = M.member (getKey u) m + +lookupUFM :: Uniquable key => UniqFM key elt -> key -> Maybe elt +lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m + +-- when you've got the Unique already +lookupUFM_Directly :: UniqFM key elt -> Unique -> Maybe elt +lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m + +lookupWithDefaultUFM :: Uniquable key => UniqFM key elt -> elt -> key -> elt +lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m + +lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt +lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m + +eltsUFM :: UniqFM key elt -> [elt] +eltsUFM (UFM m) = M.elems m + +ufmToSet_Directly :: UniqFM key elt -> S.IntSet +ufmToSet_Directly (UFM m) = M.keysSet m + +anyUFM :: (elt -> Bool) -> UniqFM key elt -> Bool +anyUFM p (UFM m) = M.foldr ((||) . p) False m + +allUFM :: (elt -> Bool) -> UniqFM key elt -> Bool +allUFM p (UFM m) = M.foldr ((&&) . p) True m + +seqEltsUFM :: ([elt] -> ()) -> UniqFM key elt -> () +seqEltsUFM seqList = seqList . nonDetEltsUFM + -- It's OK to use nonDetEltsUFM here because the type guarantees that + -- the only interesting thing this function can do is to force the + -- elements. + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUFM :: UniqFM key elt -> [elt] +nonDetEltsUFM (UFM m) = M.elems m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUFM :: UniqFM key elt -> [Unique] +nonDetKeysUFM (UFM m) = map getUnique $ M.keys m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetUFMToList :: UniqFM key elt -> [(Unique, elt)] +nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m + +-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites +-- that the provided 'Foldable' and 'Traversable' instances are +-- nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism. +newtype NonDetUniqFM key ele = NonDetUniqFM { getNonDet :: UniqFM key ele } + deriving (Functor) + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism. +instance forall key. Foldable (NonDetUniqFM key) where + foldr f z (NonDetUniqFM (UFM m)) = foldr f z m + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" to learn about determinism. +instance forall key. Traversable (NonDetUniqFM key) where + traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m + +ufmToIntMap :: UniqFM key elt -> M.IntMap elt +ufmToIntMap (UFM m) = m + +unsafeIntMapToUFM :: M.IntMap elt -> UniqFM key elt +unsafeIntMapToUFM = UFM + +-- | Cast the key domain of a UniqFM. +-- +-- As long as the domains don't overlap in their uniques +-- this is safe. +unsafeCastUFMKey :: UniqFM key1 elt -> UniqFM key2 elt +unsafeCastUFMKey (UFM m) = UFM m + +-- Determines whether two 'UniqFM's contain the same keys. +equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool +equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 + +-- Instances + +instance Semi.Semigroup (UniqFM key a) where + (<>) = plusUFM + +instance Monoid (UniqFM key a) where + mempty = emptyUFM + mappend = (Semi.<>) + +-- Output-ery + +instance Outputable a => Outputable (UniqFM key a) where + ppr ufm = pprUniqFM ppr ufm + +pprUniqFM :: (a -> SDoc) -> UniqFM key a -> SDoc +pprUniqFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- nonDetUFMToList ufm ] + -- It's OK to use nonDetUFMToList here because we only use it for + -- pretty-printing. + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +pprUFM :: UniqFM key a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFM ufm pp = pp (nonDetEltsUFM ufm) + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetUFMToList. +pprUFMWithKeys + :: UniqFM key a -- ^ The things to be pretty printed + -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralUFM :: UniqFM key a -> SDoc +pluralUFM ufm + | sizeUFM ufm == 1 = empty + | otherwise = char 's' diff --git a/GHC/Types/Unique/Set.hs b/GHC/Types/Unique/Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/Set.hs @@ -0,0 +1,198 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @Uniquable@. +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.Set ( + -- * Unique set type + UniqSet, -- type synonym for UniqFM a + getUniqSet, + pprUniqSet, + + -- ** Manipulating these sets + emptyUniqSet, + unitUniqSet, + mkUniqSet, + addOneToUniqSet, addListToUniqSet, + delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, + delListFromUniqSet_Directly, + unionUniqSets, unionManyUniqSets, + minusUniqSet, uniqSetMinusUFM, uniqSetMinusUDFM, + intersectUniqSets, + disjointUniqSets, + restrictUniqSetToUFM, + uniqSetAny, uniqSetAll, + elementOfUniqSet, + elemUniqSet_Directly, + filterUniqSet, + filterUniqSet_Directly, + sizeUniqSet, + isEmptyUniqSet, + lookupUniqSet, + lookupUniqSet_Directly, + partitionUniqSet, + mapUniqSet, + unsafeUFMToUniqSet, + nonDetEltsUniqSet, + nonDetKeysUniqSet, + nonDetStrictFoldUniqSet, + ) where + +import GHC.Prelude + +import GHC.Types.Unique.DFM +import GHC.Types.Unique.FM +import GHC.Types.Unique +import Data.Coerce +import GHC.Utils.Outputable +import Data.Data +import qualified Data.Semigroup as Semi + +-- Note [UniqSet invariant] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- UniqSet has the following invariant: +-- The keys in the map are the uniques of the values +-- It means that to implement mapUniqSet you have to update +-- both the keys and the values. + +newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqSet :: UniqSet a +emptyUniqSet = UniqSet emptyUFM + +unitUniqSet :: Uniquable a => a -> UniqSet a +unitUniqSet x = UniqSet $ unitUFM x x + +mkUniqSet :: Uniquable a => [a] -> UniqSet a +mkUniqSet = foldl' addOneToUniqSet emptyUniqSet + +addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) + +addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +addListToUniqSet = foldl' addOneToUniqSet + +delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) + +delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a +delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) + +delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) + +delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a +delListFromUniqSet_Directly (UniqSet s) l = + UniqSet (delListFromUFM_Directly s l) + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) + +unionManyUniqSets :: [UniqSet a] -> UniqSet a +unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet + +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) + +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) + +disjointUniqSets :: UniqSet a -> UniqSet a -> Bool +disjointUniqSets (UniqSet s) (UniqSet t) = disjointUFM s t + +restrictUniqSetToUFM :: UniqSet key -> UniqFM key b -> UniqSet key +restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) + +uniqSetMinusUFM :: UniqSet key -> UniqFM key b -> UniqSet key +uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) + +uniqSetMinusUDFM :: UniqSet key -> UniqDFM key b -> UniqSet key +uniqSetMinusUDFM (UniqSet s) t = UniqSet (ufmMinusUDFM s t) + +elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool +elementOfUniqSet a (UniqSet s) = elemUFM a s + +elemUniqSet_Directly :: Unique -> UniqSet a -> Bool +elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s + +filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) + +filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt +filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) + +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) +partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) + +uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAny p (UniqSet s) = anyUFM p s + +uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAll p (UniqSet s) = allUFM p s + +sizeUniqSet :: UniqSet a -> Int +sizeUniqSet (UniqSet s) = sizeUFM s + +isEmptyUniqSet :: UniqSet a -> Bool +isEmptyUniqSet (UniqSet s) = isNullUFM s + +-- | What's the point you might ask? We might have changed an object +-- without it's key changing. In which case this lookup makes sense. +lookupUniqSet :: Uniquable key => UniqSet key -> key -> Maybe key +lookupUniqSet (UniqSet s) k = lookupUFM s k + +lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a +lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUniqSet :: UniqSet elt -> [elt] +nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUniqSet :: UniqSet elt -> [Unique] +nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a +nonDetStrictFoldUniqSet c n (UniqSet s) = nonDetStrictFoldUFM c n s + +-- See Note [UniqSet invariant] +mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet + +-- Two 'UniqSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqSet a) where + UniqSet a == UniqSet b = equalKeysUFM a b + +getUniqSet :: UniqSet a -> UniqFM a a +getUniqSet = getUniqSet' + +-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ +-- assuming, without checking, that it maps each 'Unique' to a value +-- that has that 'Unique'. See Note [UniqSet invariant]. +unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a +unsafeUFMToUniqSet = UniqSet + +instance Outputable a => Outputable (UniqSet a) where + ppr = pprUniqSet ppr + +pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc +-- It's OK to use nonDetUFMToList here because we only use it for +-- pretty-printing. +pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet diff --git a/GHC/Types/Unique/Supply.hs b/GHC/Types/Unique/Supply.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/Supply.hs @@ -0,0 +1,364 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# OPTIONS_GHC -fno-state-hack #-} + -- This -fno-state-hack is important + -- See Note [Optimising the unique supply] + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} + +#if !defined(GHC_LOADED_INTO_GHCI) +{-# LANGUAGE UnboxedTuples #-} +#endif + +module GHC.Types.Unique.Supply ( + -- * Main data type + UniqSupply, -- Abstractly + + -- ** Operations on supplies + uniqFromSupply, uniqsFromSupply, -- basic ops + takeUniqFromSupply, uniqFromMask, + + mkSplitUniqSupply, + splitUniqSupply, listSplitUniqSupply, + + -- * Unique supply monad and its abstraction + UniqSM, MonadUnique(..), + + -- ** Operations on the monad + initUs, initUs_, + + -- * Set supply strategy + initUniqSupply + ) where + +import GHC.Prelude + +import GHC.Types.Unique +import GHC.Utils.Panic.Plain (panic) + +import GHC.IO + +import GHC.Utils.Monad +import Control.Monad +import Data.Bits +import Data.Char +import GHC.Exts( inline ) + +#include "Unique.h" + +{- +************************************************************************ +* * +\subsection{Splittable Unique supply: @UniqSupply@} +* * +************************************************************************ +-} + +{- Note [How the unique supply works] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea (due to Lennart Augustsson) is that a UniqSupply is +lazily-evaluated infinite tree. + +* At each MkSplitUniqSupply node is a unique Int, and two + sub-trees (see data UniqSupply) + +* takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) + returns the unique Int and one of the sub-trees + +* splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) + returns the two sub-trees + +* When you poke on one of the thunks, it does a foreign call + to get a fresh Int from a thread-safe counter, and returns + a fresh MkSplitUniqSupply node. This has to be as efficient + as possible: it should allocate only + * The fresh node + * A thunk for each sub-tree + +Note [Optimising the unique supply] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The inner loop of mkSplitUniqSupply is a function closure + + mk_supply :: IO UniqSupply + mk_supply = unsafeInterleaveIO $ + genSym >>= \ u -> + mk_supply >>= \ s1 -> + mk_supply >>= \ s2 -> + return (MkSplitUniqSupply (mask .|. u) s1 s2) + +It's a classic example of an IO action that is captured +and the called repeatedly (see #18238 for some discussion). +It turns out that we can get something like + + $wmkSplitUniqSupply c# s + = letrec + mk_supply + = \s -> unsafeDupableInterleaveIO1 + (\s2 -> case noDuplicate# s2 of s3 -> + ... + case mk_supply s4 of (# s5, t1 #) -> + ... + (# s6, MkSplitUniqSupply ... #) + in mk_supply s + +This is bad becuase we allocate that inner (\s2...) every time. +Why doesn't full laziness float out the (\s2...)? Because of +the state hack (#18238). + +So for this module we switch the state hack off -- it's an example +of when it makes things worse rather than better. And we use +multiShotIO (see Note [multiShotIO]) thus: + + mk_supply = multiShotIO $ + unsafeInterleaveIO $ + genSym >>= \ u -> + ... + +Now full laziness can float that lambda out, and we get + + $wmkSplitUniqSupply c# s + = letrec + lvl = \s2 -> case noDuplicate# s2 of s3 -> + ... + case unsafeDupableInterleaveIO + lvl s4 of (# s5, t1 #) -> + ... + (# s6, MkSplitUniqSupply ... #) + in unsafeDupableInterleaveIO1 lvl s + +This is all terribly delicate. It just so happened that before I +fixed #18078, and even with the state-hack still enabled, we were +getting this: + + $wmkSplitUniqSupply c# s + = letrec + mk_supply = \s2 -> case noDuplicate# s2 of s3 -> + ... + case mks_help s3 of (# s5,t1 #) -> + ... + (# s6, MkSplitUniqSupply ... #) + mks_help = unsafeDupableInterleaveIO mk_supply + -- mks_help marked as loop breaker + in mks_help s + +The fact that we didn't need full laziness was somewhat fortuitious. +We got the right number of allocations. But the partial application of +the arity-2 unsafeDupableInterleaveIO in mks_help makes it quite a +bit slower. (Test perf/should_run/UniqLoop had a 20% perf change.) + +Sigh. The test perf/should_run/UniqLoop keeps track of this loop. +Watch it carefully. + +Note [multiShotIO] +~~~~~~~~~~~~~~~~~~ +The function multiShotIO :: IO a -> IO a +says that the argument IO action may be invoked repeatedly (is +multi-shot), and so there should be a multi-shot lambda around it. +It's quite easy to define, in any module with `-fno-state-hack`: + multiShotIO :: IO a -> IO a + {-# INLINE multiShotIO #-} + multiShotIO (IO m) = IO (\s -> inline m s) + +Because of -fno-state-hack, that '\s' will be multi-shot. Now, +ignoring the casts from IO: + multiShotIO (\ss{one-shot}. blah) + ==> let m = \ss{one-shot}. blah + in \s. inline m s + ==> \s. (\ss{one-shot}.blah) s + ==> \s. blah[s/ss] + +The magic `inline` function does two things +* It prevents eta reduction. If we wrote just + multiShotIO (IO m) = IO (\s -> m s) + the lamda would eta-reduce to 'm' and all would be lost. + +* It helps ensure that 'm' really does inline. + +Note that 'inline' evaporates in phase 0. See Note [inlineIdMagic] +in GHC.Core.Opt.ConstantFold.match_inline. + +The INLINE pragma on multiShotIO is very important, else the +'inline' call will evaporate when compiling the module that +defines 'multiShotIO', before it is ever exported. +-} + + +-- | Unique Supply +-- +-- A value of type 'UniqSupply' is unique, and it can +-- supply /one/ distinct 'Unique'. Also, from the supply, one can +-- also manufacture an arbitrary number of further 'UniqueSupply' values, +-- which will be distinct from the first and from all others. +data UniqSupply + = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies + +mkSplitUniqSupply :: Char -> IO UniqSupply +-- ^ Create a unique supply out of thin air. The character given must +-- be distinct from those of all calls to this function in the compiler +-- for the values generated to be truly unique. + +-- See Note [How the unique supply works] +-- See Note [Optimising the unique supply] +mkSplitUniqSupply c + = mk_supply + where + !mask = ord c `shiftL` uNIQUE_BITS + + -- Here comes THE MAGIC: see Note [How the unique supply works] + -- This is one of the most hammered bits in the whole compiler + -- See Note [Optimising the unique supply] + -- NB: Use unsafeInterleaveIO for thread-safety. + mk_supply = multiShotIO $ + unsafeInterleaveIO $ + genSym >>= \ u -> + mk_supply >>= \ s1 -> + mk_supply >>= \ s2 -> + return (MkSplitUniqSupply (mask .|. u) s1 s2) + +multiShotIO :: IO a -> IO a +{-# INLINE multiShotIO #-} +-- See Note [multiShotIO] +multiShotIO (IO m) = IO (\s -> inline m s) + +foreign import ccall unsafe "genSym" genSym :: IO Int +foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO () + +splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +-- ^ Build two 'UniqSupply' from a single one, each of which +-- can supply its own 'Unique'. +listSplitUniqSupply :: UniqSupply -> [UniqSupply] +-- ^ Create an infinite list of 'UniqSupply' from a single one +uniqFromSupply :: UniqSupply -> Unique +-- ^ Obtain the 'Unique' from this particular 'UniqSupply' +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 + +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) + +uniqFromMask :: Char -> IO Unique +uniqFromMask mask + = do { uqNum <- genSym + ; return $! mkUnique mask uqNum } + + +{- +************************************************************************ +* * +\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} +* * +************************************************************************ +-} + +-- Avoids using unboxed tuples when loading into GHCi +#if !defined(GHC_LOADED_INTO_GHCI) + +type UniqResult result = (# result, UniqSupply #) + +pattern UniqResult :: a -> b -> (# a, b #) +pattern UniqResult x y = (# x, y #) +{-# COMPLETE UniqResult #-} + +#else + +data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply + deriving (Functor) + +#endif + +-- | A monad which just gives the ability to obtain 'Unique's +newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } + deriving (Functor) + +instance Monad UniqSM where + (>>=) = thenUs + (>>) = (*>) + +instance Applicative UniqSM where + pure = returnUs + (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of + UniqResult ff us1 -> case x us1 of + UniqResult xx us2 -> UniqResult (ff xx) us2 + (*>) = thenUs_ + +-- TODO: try to get rid of this instance +instance MonadFail UniqSM where + fail = panic + +-- | Run the 'UniqSM' action, returning the final 'UniqSupply' +initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) +initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } + +-- | Run the 'UniqSM' action, discarding the final 'UniqSupply' +initUs_ :: UniqSupply -> UniqSM a -> a +initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } + +{-# INLINE thenUs #-} +{-# INLINE returnUs #-} +{-# INLINE splitUniqSupply #-} + +-- @thenUs@ is where we split the @UniqSupply@. + +liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) +liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) + +instance MonadFix UniqSM where + mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) + +thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +thenUs (USM expr) cont + = USM (\us0 -> case (expr us0) of + UniqResult result us1 -> unUSM (cont result) us1) + +thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b +thenUs_ (USM expr) (USM cont) + = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) + +returnUs :: a -> UniqSM a +returnUs result = USM (\us -> UniqResult result us) + +getUs :: UniqSM UniqSupply +getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) + +-- | A monad for generating unique identifiers +class Monad m => MonadUnique m where + -- | Get a new UniqueSupply + getUniqueSupplyM :: m UniqSupply + -- | Get a new unique identifier + getUniqueM :: m Unique + -- | Get an infinite list of new unique identifiers + getUniquesM :: m [Unique] + + -- This default definition of getUniqueM, while correct, is not as + -- efficient as it could be since it needlessly generates and throws away + -- an extra Unique. For your instances consider providing an explicit + -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. + getUniqueM = liftM uniqFromSupply getUniqueSupplyM + getUniquesM = liftM uniqsFromSupply getUniqueSupplyM + +instance MonadUnique UniqSM where + getUniqueSupplyM = getUs + getUniqueM = getUniqueUs + getUniquesM = getUniquesUs + +getUniqueUs :: UniqSM Unique +getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of + (u,us1) -> UniqResult u us1) + +getUniquesUs :: UniqSM [Unique] +getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of + (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) diff --git a/GHC/Types/Var.hs b/GHC/Types/Var.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Var.hs @@ -0,0 +1,913 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{@Vars@: Variables} +-} + +{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, + PatternSynonyms, BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types" +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var' is a synonym for the 'GHC.Types.Id.Id' type but it may additionally +-- potentially contain type variables, which have a 'GHC.Core.TyCo.Rep.Kind' +-- rather than a 'GHC.Core.TyCo.Rep.Type' and only contain some extra +-- details during typechecking. +-- +-- These 'Var' names may either be global or local, see "GHC.Types.Var#globalvslocal" +-- +-- #globalvslocal# +-- Global 'Id's and 'Var's are those that are imported or correspond +-- to a data constructor, primitive operation, or record selectors. +-- Local 'Id's and 'Var's are those bound within an expression +-- (e.g. by a lambda) or at the top level of the module being compiled. + +module GHC.Types.Var ( + -- * The main data type and synonyms + Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, + TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, + + -- * In and Out variants + InVar, InCoVar, InId, InTyVar, + OutVar, OutCoVar, OutId, OutTyVar, + + -- ** Taking 'Var's apart + varName, varUnique, varType, + varMult, varMultMaybe, + + -- ** Modifying 'Var's + setVarName, setVarUnique, setVarType, + updateVarType, updateVarTypeM, + + -- ** Constructing, taking apart, modifying 'Id's + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, + idInfo, idDetails, + lazySetIdInfo, setIdDetails, globaliseId, + setIdExported, setIdNotExported, setIdMult, + updateIdTypeButNotMult, + updateIdTypeAndMult, updateIdTypeAndMultM, + + -- ** Predicates + isId, isTyVar, isTcTyVar, + isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, + isGlobalId, isExportedId, + mustHaveLocalBinding, + + -- * ArgFlags + ArgFlag(Invisible,Required,Specified,Inferred), + isVisibleArgFlag, isInvisibleArgFlag, sameVis, + AnonArgFlag(..), Specificity(..), + + -- * TyVar's + VarBndr(..), TyCoVarBinder, TyVarBinder, InvisTVBinder, ReqTVBinder, + binderVar, binderVars, binderArgFlag, binderType, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinder, mkTyVarBinders, + isTyVarBinder, tyVarSpecToBinder, tyVarSpecToBinders, + mapVarBndr, mapVarBndrs, lookupVarBndr, + + -- ** Constructing TyVar's + mkTyVar, mkTcTyVar, + + -- ** Taking 'TyVar's apart + tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, + + -- ** Modifying 'TyVar's + setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, + updateTyVarKindM, + + nonDetCmpVar + + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) +import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, + vanillaIdInfo, pprIdDetails ) +import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) +import GHC.Types.Name hiding (varName) +import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique + , mkUniqueGrimily, nonDetCmpUnique ) +import GHC.Utils.Misc +import GHC.Utils.Binary +import GHC.Utils.Outputable + +import Data.Data + +{- +************************************************************************ +* * + Synonyms +* * +************************************************************************ +-- These synonyms are here and not in Id because otherwise we need a very +-- large number of SOURCE imports of "GHC.Types.Id" :-( +-} + +-- | Identifier +type Id = Var -- A term-level identifier + -- predicate: isId + +-- | Coercion Variable +type CoVar = Id -- See Note [Evidence: EvIds and CoVars] + -- predicate: isCoVar + +-- | +type NcId = Id -- A term-level (value) variable that is + -- /not/ an (unlifted) coercion + -- predicate: isNonCoVarId + +-- | Type or kind Variable +type TyVar = Var -- Type *or* kind variable (historical) + +-- | Type or Kind Variable +type TKVar = Var -- Type *or* kind variable (historical) + +-- | Type variable that might be a metavariable +type TcTyVar = Var + +-- | Type Variable +type TypeVar = Var -- Definitely a type variable + +-- | Kind Variable +type KindVar = Var -- Definitely a kind variable + -- See Note [Kind and type variables] + +-- See Note [Evidence: EvIds and CoVars] +-- | Evidence Identifier +type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar + +-- | Evidence Variable +type EvVar = EvId -- ...historical name for EvId + +-- | Dictionary Function Identifier +type DFunId = Id -- A dictionary function + +-- | Dictionary Identifier +type DictId = EvId -- A dictionary variable + +-- | Implicit parameter Identifier +type IpId = EvId -- A term-level implicit parameter + +-- | Equality Variable +type EqVar = EvId -- Boxed equality evidence +type JoinId = Id -- A join variable + +-- | Type or Coercion Variable +type TyCoVar = Id -- Type, *or* coercion variable + -- predicate: isTyCoVar + + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +type InVar = Var +type InTyVar = TyVar +type InCoVar = CoVar +type InId = Id +type OutVar = Var +type OutTyVar = TyVar +type OutCoVar = CoVar +type OutId = Id + + + +{- Note [Evidence: EvIds and CoVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* An EvId (evidence Id) is a term-level evidence variable + (dictionary, implicit parameter, or equality). Could be boxed or unboxed. + +* DictId, IpId, and EqVar are synonyms when we know what kind of + evidence we are talking about. For example, an EqVar has type (t1 ~ t2). + +* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) + +Note [Kind and type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before kind polymorphism, TyVar were used to mean type variables. Now +they are used to mean kind *or* type variables. KindVar is used when we +know for sure that it is a kind variable. In future, we might want to +go over the whole compiler code to use: + - TKVar to mean kind or type variables + - TypeVar to mean type variables only + - KindVar to mean kind variables + + +************************************************************************ +* * +\subsection{The main data type declarations} +* * +************************************************************************ + + +Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a +@Type@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Vars@ is +in its @VarDetails@. +-} + +-- | Variable +-- +-- Essentially a typed 'Name', that may also contain some additional information +-- about the 'Var' and its use sites. +data Var + = TyVar { -- Type and kind variables + -- see Note [Kind and type variables] + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + -- ^ Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question + } + + | TcTyVar { -- Used only during type inference + -- Used for kind variables during + -- inference, as well + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Kind, + tc_tv_details :: TcTyVarDetails + } + + | Id { + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Type, + varMult :: Mult, -- See Note [Multiplicity of let binders] + idScope :: IdScope, + id_details :: IdDetails, -- Stable, doesn't change + id_info :: IdInfo } -- Unstable, updated by simplifier + +-- | Identifier Scope +data IdScope -- See Note [GlobalId/LocalId] + = GlobalId + | LocalId ExportFlag + +data ExportFlag -- See Note [ExportFlag on binders] + = NotExported -- ^ Not exported: may be discarded as dead code. + | Exported -- ^ Exported: kept alive + +{- Note [ExportFlag on binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An ExportFlag of "Exported" on a top-level binder says "keep this +binding alive; do not drop it as dead code". This transitively +keeps alive all the other top-level bindings that this binding refers +to. This property is persisted all the way down the pipeline, so that +the binding will be compiled all the way to object code, and its +symbols will appear in the linker symbol table. + +However, note that this use of "exported" is quite different to the +export list on a Haskell module. Setting the ExportFlag on an Id does +/not/ mean that if you import the module (in Haskell source code) you +will see this Id. Of course, things that appear in the export list +of the source Haskell module do indeed have their ExportFlag set. +But many other things, such as dictionary functions, are kept alive +by having their ExportFlag set, even though they are not exported +in the source-code sense. + +We should probably use a different term for ExportFlag, like +KeepAlive. + +Note [GlobalId/LocalId] +~~~~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + * has a Unique that is globally unique across the whole + GHC invocation (a single invocation may compile multiple modules) + * never treated as a candidate by the free-variable finder; + it's a constant! + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + * always treated as a candidate by the free-variable finder + +After CoreTidy, top-level LocalIds are turned into GlobalIds + +Note [Multiplicity of let binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, let-binders' multiplicity is always completely determined by syntax: +a recursive let will always have multiplicity Many (it's a prerequisite for +being recursive), and non-recursive let doesn't have a conventional multiplicity, +instead they act, for the purpose of multiplicity, as an alias for their +right-hand side. + +Therefore, the `varMult` field of identifier is only used by binders in lambda +and case expressions. In a let expression the `varMult` field holds an +arbitrary value which will (and must!) be ignored. +-} + +instance Outputable Var where + ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> + getPprDebug $ \debug -> + getPprStyle $ \sty -> + let + ppr_var = case var of + (TyVar {}) + | debug + -> brackets (text "tv") + + (TcTyVar {tc_tv_details = d}) + | dumpStyle sty || debug + -> brackets (pprTcTyVarDetails d) + + (Id { idScope = s, id_details = d }) + | debug + -> brackets (ppr_id_scope s <> pprIdDetails d) + + _ -> empty + in if + | debug && (not supp_var_kinds) + -> parens (ppr (varName var) <+> ppr (varMultMaybe var) + <+> ppr_var <+> + dcolon <+> pprKind (tyVarKind var)) + | otherwise + -> ppr (varName var) <> ppr_var + +ppr_id_scope :: IdScope -> SDoc +ppr_id_scope GlobalId = text "gid" +ppr_id_scope (LocalId Exported) = text "lidx" +ppr_id_scope (LocalId NotExported) = text "lid" + +instance NamedThing Var where + getName = varName + +instance Uniquable Var where + getUnique = varUnique + +instance Eq Var where + a == b = realUnique a == realUnique b + +instance Ord Var where + a <= b = realUnique a <= realUnique b + a < b = realUnique a < realUnique b + a >= b = realUnique a >= realUnique b + a > b = realUnique a > realUnique b + a `compare` b = a `nonDetCmpVar` b + +-- | Compare Vars by their Uniques. +-- This is what Ord Var does, provided here to make it explicit at the +-- call-site that it can introduce non-determinism. +-- See Note [Unique Determinism] +nonDetCmpVar :: Var -> Var -> Ordering +nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b + +instance Data Var where + -- don't traverse? + toConstr _ = abstractConstr "Var" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Var" + +instance HasOccName Var where + occName = nameOccName . varName + +varUnique :: Var -> Unique +varUnique var = mkUniqueGrimily (realUnique var) + +varMultMaybe :: Id -> Maybe Mult +varMultMaybe (Id { varMult = mult }) = Just mult +varMultMaybe _ = Nothing + +setVarUnique :: Var -> Unique -> Var +setVarUnique var uniq + = var { realUnique = getKey uniq, + varName = setNameUnique (varName var) uniq } + +setVarName :: Var -> Name -> Var +setVarName var new_name + = var { realUnique = getKey (getUnique new_name), + varName = new_name } + +setVarType :: Var -> Type -> Var +setVarType id ty = id { varType = ty } + +-- | Update a 'Var's type. Does not update the /multiplicity/ +-- stored in an 'Id', if any. Because of the possibility for +-- abuse, ASSERTs that there is no multiplicity to update. +updateVarType :: (Type -> Type) -> Var -> Var +updateVarType upd var + | debugIsOn + = case var of + Id { id_details = details } -> ASSERT( isCoVarDetails details ) + result + _ -> result + | otherwise + = result + where + result = var { varType = upd (varType var) } + +-- | Update a 'Var's type monadically. Does not update the /multiplicity/ +-- stored in an 'Id', if any. Because of the possibility for +-- abuse, ASSERTs that there is no multiplicity to update. +updateVarTypeM :: Monad m => (Type -> m Type) -> Var -> m Var +updateVarTypeM upd var + | debugIsOn + = case var of + Id { id_details = details } -> ASSERT( isCoVarDetails details ) + result + _ -> result + | otherwise + = result + where + result = do { ty' <- upd (varType var) + ; return (var { varType = ty' }) } + +{- ********************************************************************* +* * +* ArgFlag +* * +********************************************************************* -} + +-- | Argument Flag +-- +-- Is something required to appear in source Haskell ('Required'), +-- permitted by request ('Specified') (visible type application), or +-- prohibited entirely from appearing in source Haskell ('Inferred')? +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +data ArgFlag = Invisible Specificity + | Required + deriving (Eq, Ord, Data) + -- (<) on ArgFlag means "is less visible than" + +-- | Whether an 'Invisible' argument may appear in source Haskell. +data Specificity = InferredSpec + -- ^ the argument may not appear in source Haskell, it is + -- only inferred. + | SpecifiedSpec + -- ^ the argument may appear in source Haskell, but isn't + -- required. + deriving (Eq, Ord, Data) + +pattern Inferred, Specified :: ArgFlag +pattern Inferred = Invisible InferredSpec +pattern Specified = Invisible SpecifiedSpec + +{-# COMPLETE Required, Specified, Inferred #-} + +-- | Does this 'ArgFlag' classify an argument that is written in Haskell? +isVisibleArgFlag :: ArgFlag -> Bool +isVisibleArgFlag Required = True +isVisibleArgFlag _ = False + +-- | Does this 'ArgFlag' classify an argument that is not written in Haskell? +isInvisibleArgFlag :: ArgFlag -> Bool +isInvisibleArgFlag = not . isVisibleArgFlag + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +sameVis :: ArgFlag -> ArgFlag -> Bool +sameVis Required Required = True +sameVis (Invisible _) (Invisible _) = True +sameVis _ _ = False + +instance Outputable ArgFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Binary Specificity where + put_ bh SpecifiedSpec = putByte bh 0 + put_ bh InferredSpec = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return SpecifiedSpec + _ -> return InferredSpec + +instance Binary ArgFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +-- | The non-dependent version of 'ArgFlag'. +-- See Note [AnonArgFlag] +-- Appears here partly so that it's together with its friends ArgFlag +-- and ForallVisFlag, but also because it is used in IfaceType, rather +-- early in the compilation chain +data AnonArgFlag + = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. + -- The argument is visible in source code. + | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. + -- The argument is invisible in source code. + deriving (Eq, Ord, Data) + +instance Outputable AnonArgFlag where + ppr VisArg = text "[vis]" + ppr InvisArg = text "[invis]" + +instance Binary AnonArgFlag where + put_ bh VisArg = putByte bh 0 + put_ bh InvisArg = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return VisArg + _ -> return InvisArg + +{- Note [AnonArgFlag] +~~~~~~~~~~~~~~~~~~~~~ +AnonArgFlag is used principally in the FunTy constructor of Type. + FunTy VisArg t1 t2 means t1 -> t2 + FunTy InvisArg t1 t2 means t1 => t2 + +However, the AnonArgFlag in a FunTy is just redundant, cached +information. In (FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) + * if (isPredTy t1 = True) then af = InvisArg + * if (isPredTy t1 = False) then af = VisArg +where isPredTy is defined in GHC.Core.Type, and sees if t1's +kind is Constraint. See GHC.Core.TyCo.Rep +Note [Types for coercions, predicates, and evidence] + +GHC.Core.Utils.mkFunctionType :: Mult -> Type -> Type -> Type +uses isPredTy to decide the AnonArgFlag for the FunTy. + +The term (Lam b e), and coercion (FunCo co1 co2) don't carry +AnonArgFlags; instead they use mkFunctionType when we want to +get their types; see mkLamType and coercionLKind/RKind resp. +This is just an engineering choice; we could cache here too +if we wanted. + +Why bother with all this? After all, we are in Core, where (=>) and +(->) behave the same. We maintain this distinction throughout Core so +that we can cheaply and conveniently determine +* How to print a type +* How to split up a type: tcSplitSigmaTy +* How to specialise it (over type classes; GHC.Core.Opt.Specialise) + +For the specialisation point, consider +(\ (d :: Ord a). blah). We want to give it type + (Ord a => blah_ty) +with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. +Why? Because the /specialiser/ treats dictionary arguments specially. +Suppose we do w/w on 'foo', thus (#11272, #6056) + foo :: Ord a => Int -> blah + foo a d x = case x of I# x' -> $wfoo @a d x' + + $wfoo :: Ord a => Int# -> blah + +Now, at a call we see (foo @Int dOrdInt). The specialiser will +specialise this to $sfoo, where + $sfoo :: Int -> blah + $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' + +Now we /must/ also specialise $wfoo! But it wasn't user-written, +and has a type built with mkLamTypes. + +Conclusion: the easiest thing is to make mkLamType build + (c => ty) +when the argument is a predicate type. See GHC.Core.TyCo.Rep +Note [Types for coercions, predicates, and evidence] +-} + +{- ********************************************************************* +* * +* VarBndr, TyCoVarBinder +* * +********************************************************************* -} + +-- Variable Binder +-- +-- VarBndr is polymorphic in both var and visibility fields. +-- Currently there are nine different uses of 'VarBndr': +-- * Var.TyVarBinder = VarBndr TyVar ArgFlag +-- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +-- * Var.InvisTVBinder = VarBndr TyVar Specificity +-- * Var.ReqTVBinder = VarBndr TyVar () +-- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis +-- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +-- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +-- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +-- * IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity +data VarBndr var argf = Bndr var argf + deriving( Data ) + +-- | Variable Binder +-- +-- A 'TyCoVarBinder' is the binder of a ForAllTy +-- It's convenient to define this synonym here rather its natural +-- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot +-- +-- A 'TyVarBinder' is a binder with only TyVar +type TyCoVarBinder = VarBndr TyCoVar ArgFlag +type TyVarBinder = VarBndr TyVar ArgFlag +type InvisTVBinder = VarBndr TyVar Specificity +type ReqTVBinder = VarBndr TyVar () + +tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ArgFlag] +tyVarSpecToBinders = map tyVarSpecToBinder + +tyVarSpecToBinder :: (VarBndr a Specificity) -> (VarBndr a ArgFlag) +tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) + +binderVar :: VarBndr tv argf -> tv +binderVar (Bndr v _) = v + +binderVars :: [VarBndr tv argf] -> [tv] +binderVars tvbs = map binderVar tvbs + +binderArgFlag :: VarBndr tv argf -> argf +binderArgFlag (Bndr _ argf) = argf + +binderType :: VarBndr TyCoVar argf -> Type +binderType (Bndr tv _) = varType tv + +-- | Make a named binder +mkTyCoVarBinder :: vis -> TyCoVar -> (VarBndr TyCoVar vis) +mkTyCoVarBinder vis var = Bndr var vis + +-- | Make a named binder +-- 'var' should be a type variable +mkTyVarBinder :: vis -> TyVar -> (VarBndr TyVar vis) +mkTyVarBinder vis var + = ASSERT( isTyVar var ) + Bndr var vis + +-- | Make many named binders +mkTyCoVarBinders :: vis -> [TyCoVar] -> [VarBndr TyCoVar vis] +mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) + +-- | Make many named binders +-- Input vars should be type variables +mkTyVarBinders :: vis -> [TyVar] -> [VarBndr TyVar vis] +mkTyVarBinders vis = map (mkTyVarBinder vis) + +isTyVarBinder :: TyCoVarBinder -> Bool +isTyVarBinder (Bndr v _) = isTyVar v + +mapVarBndr :: (var -> var') -> (VarBndr var flag) -> (VarBndr var' flag) +mapVarBndr f (Bndr v fl) = Bndr (f v) fl + +mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag] +mapVarBndrs f = map (mapVarBndr f) + +lookupVarBndr :: Eq var => var -> [VarBndr var flag] -> Maybe flag +lookupVarBndr var bndrs = lookup var zipped_bndrs + where + zipped_bndrs = map (\(Bndr v f) -> (v,f)) bndrs + +instance Outputable tv => Outputable (VarBndr tv ArgFlag) where + ppr (Bndr v Required) = ppr v + ppr (Bndr v Specified) = char '@' <> ppr v + ppr (Bndr v Inferred) = braces (ppr v) + +instance Outputable tv => Outputable (VarBndr tv Specificity) where + ppr = ppr . tyVarSpecToBinder + +instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where + put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } + + get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } + +instance NamedThing tv => NamedThing (VarBndr tv flag) where + getName (Bndr tv _) = getName tv + +{- +************************************************************************ +* * +* Type and kind variables * +* * +************************************************************************ +-} + +tyVarName :: TyVar -> Name +tyVarName = varName + +tyVarKind :: TyVar -> Kind +tyVarKind = varType + +setTyVarUnique :: TyVar -> Unique -> TyVar +setTyVarUnique = setVarUnique + +setTyVarName :: TyVar -> Name -> TyVar +setTyVarName = setVarName + +setTyVarKind :: TyVar -> Kind -> TyVar +setTyVarKind tv k = tv {varType = k} + +updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar +updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} + +updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar +updateTyVarKindM update tv + = do { k' <- update (tyVarKind tv) + ; return $ tv {varType = k'} } + +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar { varName = name + , realUnique = getKey (nameUnique name) + , varType = kind + } + +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details + = -- NB: 'kind' may be a coercion kind; cf, 'GHC.Tc.Utils.TcMType.newMetaCoVar' + TcTyVar { varName = name, + realUnique = getKey (nameUnique name), + varType = kind, + tc_tv_details = details + } + +tcTyVarDetails :: TyVar -> TcTyVarDetails +-- See Note [TcTyVars in the typechecker] in GHC.Tc.Utils.TcType +tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details +tcTyVarDetails (TyVar {}) = vanillaSkolemTv +tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) + +setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar +setTcTyVarDetails tv details = tv { tc_tv_details = details } + +{- +%************************************************************************ +%* * +\subsection{Ids} +* * +************************************************************************ +-} + +idInfo :: HasDebugCallStack => Id -> IdInfo +idInfo (Id { id_info = info }) = info +idInfo other = pprPanic "idInfo" (ppr other) + +idDetails :: Id -> IdDetails +idDetails (Id { id_details = details }) = details +idDetails other = pprPanic "idDetails" (ppr other) + +-- The next three have a 'Var' suffix even though they always build +-- Ids, because "GHC.Types.Id" uses 'mkGlobalId' etc with different types +mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalVar details name ty info + = mk_id name manyDataConTy ty GlobalId details info + -- There is no support for linear global variables yet. They would require + -- being checked at link-time, which can be useful, but is not a priority. + +mkLocalVar :: IdDetails -> Name -> Mult -> Type -> IdInfo -> Id +mkLocalVar details name w ty info + = mk_id name w ty (LocalId NotExported) details info + +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name manyDataConTy ty (LocalId NotExported) coVarDetails vanillaIdInfo + +-- | Exported 'Var's will not be removed as dead code +mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkExportedLocalVar details name ty info + = mk_id name manyDataConTy ty (LocalId Exported) details info + -- There is no support for exporting linear variables. See also [mkGlobalVar] + +mk_id :: Name -> Mult -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name !w ty scope details info + = Id { varName = name, + realUnique = getKey (nameUnique name), + varMult = w, + varType = ty, + idScope = scope, + id_details = details, + id_info = info } + +------------------- +lazySetIdInfo :: Id -> IdInfo -> Var +lazySetIdInfo id info = id { id_info = info } + +setIdDetails :: Id -> IdDetails -> Id +setIdDetails id details = id { id_details = details } + +globaliseId :: Id -> Id +-- ^ If it's a local, make it global +globaliseId id = id { idScope = GlobalId } + +setIdExported :: Id -> Id +-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors +-- and class operations, which are born as global 'Id's and automatically exported +setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } +setIdExported id@(Id { idScope = GlobalId }) = id +setIdExported tv = pprPanic "setIdExported" (ppr tv) + +setIdNotExported :: Id -> Id +-- ^ We can only do this to LocalIds +setIdNotExported id = ASSERT( isLocalId id ) + id { idScope = LocalId NotExported } + +----------------------- +updateIdTypeButNotMult :: (Type -> Type) -> Id -> Id +updateIdTypeButNotMult f id = id { varType = f (varType id) } + + +updateIdTypeAndMult :: (Type -> Type) -> Id -> Id +updateIdTypeAndMult f id@(Id { varType = ty + , varMult = mult }) + = id { varType = ty' + , varMult = mult' } + where + !ty' = f ty + !mult' = f mult +updateIdTypeAndMult _ other = pprPanic "updateIdTypeAndMult" (ppr other) + +updateIdTypeAndMultM :: Monad m => (Type -> m Type) -> Id -> m Id +updateIdTypeAndMultM f id@(Id { varType = ty + , varMult = mult }) + = do { !ty' <- f ty + ; !mult' <- f mult + ; return (id { varType = ty', varMult = mult' }) } +updateIdTypeAndMultM _ other = pprPanic "updateIdTypeAndMultM" (ppr other) + +setIdMult :: Id -> Mult -> Id +setIdMult id !r | isId id = id { varMult = r } + | otherwise = pprPanic "setIdMult" (ppr id <+> ppr r) + +{- +************************************************************************ +* * +\subsection{Predicates over variables} +* * +************************************************************************ +-} + +-- | Is this a type-level (i.e., computationally irrelevant, thus erasable) +-- variable? Satisfies @isTyVar = not . isId@. +isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar +isTyVar (TyVar {}) = True +isTyVar (TcTyVar {}) = True +isTyVar _ = False + +isTcTyVar :: Var -> Bool -- True of TcTyVar only +isTcTyVar (TcTyVar {}) = True +isTcTyVar _ = False + +isTyCoVar :: Var -> Bool +isTyCoVar v = isTyVar v || isCoVar v + +-- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? +-- Satisfies @isId = not . isTyVar@. +isId :: Var -> Bool +isId (Id {}) = True +isId _ = False + +-- | Is this a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isCoVar :: Var -> Bool +isCoVar (Id { id_details = details }) = isCoVarDetails details +isCoVar _ = False + +-- | Is this a term variable ('Id') that is /not/ a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isNonCoVarId :: Var -> Bool +isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) +isNonCoVarId _ = False + +isLocalId :: Var -> Bool +isLocalId (Id { idScope = LocalId _ }) = True +isLocalId _ = False + +-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar :: Var -> Bool +isLocalVar v = not (isGlobalId v) + +isGlobalId :: Var -> Bool +isGlobalId (Id { idScope = GlobalId }) = True +isGlobalId _ = False + +-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's +-- that must have a binding in this module. The converse +-- is not quite right: there are some global 'Id's that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding :: Var -> Bool +mustHaveLocalBinding var = isLocalVar var + +-- | 'isExportedIdVar' means \"don't throw this away\" +isExportedId :: Var -> Bool +isExportedId (Id { idScope = GlobalId }) = True +isExportedId (Id { idScope = LocalId Exported}) = True +isExportedId _ = False diff --git a/GHC/Types/Var.hs-boot b/GHC/Types/Var.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/Var.hs-boot @@ -0,0 +1,13 @@ +module GHC.Types.Var where + +import GHC.Prelude () + -- We compile this GHC with -XNoImplicitPrelude, so if there are no imports + -- it does not seem to depend on anything. But it does! We must, for + -- example, compile GHC.Types in the ghc-prim library first. So this + -- otherwise-unnecessary import tells the build system that this module + -- depends on GhcPrelude, which ensures that GHC.Type is built first. + +data ArgFlag +data AnonArgFlag +data Var +type TyVar = Var diff --git a/GHC/Types/Var/Env.hs b/GHC/Types/Var/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Var/Env.hs @@ -0,0 +1,633 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Types.Var.Env ( + -- * Var, Id and TyVar environments (maps) + VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, + + -- ** Manipulating these environments + emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, + elemVarEnv, disjointVarEnv, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, + extendVarEnvList, + plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + plusVarEnvList, alterVarEnv, + delVarEnvList, delVarEnv, + minusVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + mapVarEnv, zipVarEnv, + modifyVarEnv, modifyVarEnv_Directly, + isEmptyVarEnv, + elemVarEnvByKey, + filterVarEnv, restrictVarEnv, + partitionVarEnv, + + -- * Deterministic Var environments (maps) + DVarEnv, DIdEnv, DTyVarEnv, + + -- ** Manipulating these environments + emptyDVarEnv, mkDVarEnv, + dVarEnvElts, + extendDVarEnv, extendDVarEnv_C, + extendDVarEnvList, + lookupDVarEnv, elemDVarEnv, + isEmptyDVarEnv, foldDVarEnv, nonDetStrictFoldDVarEnv, + mapDVarEnv, filterDVarEnv, + modifyDVarEnv, + alterDVarEnv, + plusDVarEnv, plusDVarEnv_C, + unitDVarEnv, + delDVarEnv, + delDVarEnvList, + minusDVarEnv, + partitionDVarEnv, + anyDVarEnv, + + -- * The InScopeSet type + InScopeSet, + + -- ** Operations on InScopeSets + emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, + getInScopeVars, lookupInScope, lookupInScope_Directly, + unionInScope, elemInScopeSet, uniqAway, + varSetInScope, + unsafeGetFreshLocalUnique, + + -- * The RnEnv2 type + RnEnv2, + + -- ** Operations on RnEnv2s + mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, + delBndrL, delBndrR, delBndrsL, delBndrsR, + addRnInScopeSet, + rnEtaL, rnEtaR, + rnInScope, rnInScopeSet, lookupRnInScope, + rnEnvL, rnEnvR, + + -- * TidyEnv and its operation + TidyEnv, + emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList + ) where + +import GHC.Prelude +import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM + +import GHC.Types.Name.Occurrence +import GHC.Types.Name +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable + +{- +************************************************************************ +* * + In-scope sets +* * +************************************************************************ +-} + +-- | A set of variables that are in scope at some point +-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides +-- the motivation for this abstraction. +newtype InScopeSet = InScope VarSet + -- Note [Lookups in in-scope set] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We store a VarSet here, but we use this for lookups rather than just + -- membership tests. Typically the InScopeSet contains the canonical + -- version of the variable (e.g. with an informative unfolding), so this + -- lookup is useful (see, for instance, Note [In-scope set as a + -- substitution]). + +instance Outputable InScopeSet where + ppr (InScope s) = + text "InScope" <+> + braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) + -- It's OK to use nonDetEltsUniqSet here because it's + -- only for pretty printing + -- In-scope sets get big, and with -dppr-debug + -- the output is overwhelming + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet + +getInScopeVars :: InScopeSet -> VarSet +getInScopeVars (InScope vs) = vs + +mkInScopeSet :: VarSet -> InScopeSet +mkInScopeSet in_scope = InScope in_scope + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope) v + = InScope (extendVarSet in_scope v) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope) vs + = InScope $ foldl' extendVarSet in_scope vs + +extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet +extendInScopeSetSet (InScope in_scope) vs + = InScope (in_scope `unionVarSet` vs) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope + +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. +lookupInScope :: InScopeSet -> Var -> Maybe Var +lookupInScope (InScope in_scope) v = lookupVarSet in_scope v + +lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var +lookupInScope_Directly (InScope in_scope) uniq + = lookupVarSet_Directly in_scope uniq + +unionInScope :: InScopeSet -> InScopeSet -> InScopeSet +unionInScope (InScope s1) (InScope s2) + = InScope (s1 `unionVarSet` s2) + +varSetInScope :: VarSet -> InScopeSet -> Bool +varSetInScope vars (InScope s1) = vars `subVarSet` s1 + +{- +Note [Local uniques] +~~~~~~~~~~~~~~~~~~~~ +Sometimes one must create conjure up a unique which is unique in a particular +context (but not necessarily globally unique). For instance, one might need to +create a fresh local identifier which does not shadow any of the locally +in-scope variables. For this we purpose we provide 'uniqAway'. + +'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique' +operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To +ensure that we do not conflict with uniques allocated by future allocations +from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are +allocated into a dedicated region of the unique space (namely the X tag). + +Note that one must be quite carefully when using uniques generated in this way +since they are only locally unique. In particular, two successive calls to +'uniqAway' on the same 'InScopeSet' will produce the same unique. + -} + +-- | @uniqAway in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. See Note [Local uniques]. +uniqAway :: InScopeSet -> Var -> Var +-- It starts with v's current unique, of course, in the hope that it won't +-- have to change, and thereafter uses the successor to the last derived unique +-- found in the in-scope set. +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' in_scope var + = setVarUnique var (unsafeGetFreshLocalUnique in_scope) + +-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the +-- given 'InScopeSet'. This must be used very carefully since one can very easily +-- introduce non-unique 'Unique's this way. See Note [Local uniques]. +unsafeGetFreshLocalUnique :: InScopeSet -> Unique +unsafeGetFreshLocalUnique (InScope set) + | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) + , let uniq' = mkLocalUnique uniq + , not $ uniq' `ltUnique` minLocalUnique + = incrUnique uniq' + + | otherwise + = minLocalUnique + +{- +************************************************************************ +* * + Dual renaming +* * +************************************************************************ +-} + +-- | Rename Environment 2 +-- +-- When we are comparing (or matching) types or terms, we are faced with +-- \"going under\" corresponding binders. E.g. when comparing: +-- +-- > \x. e1 ~ \y. e2 +-- +-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of +-- things we must be careful of. In particular, @x@ might be free in @e2@, or +-- y in @e1@. So the idea is that we come up with a fresh binder that is free +-- in neither, and rename @x@ and @y@ respectively. That means we must maintain: +-- +-- 1. A renaming for the left-hand expression +-- +-- 2. A renaming for the right-hand expressions +-- +-- 3. An in-scope set +-- +-- Furthermore, when matching, we want to be able to have an 'occurs check', +-- to prevent: +-- +-- > \x. f ~ \y. y +-- +-- matching with [@f@ -> @y@]. So for each expression we want to know that set of +-- locally-bound variables. That is precisely the domain of the mappings 1. +-- and 2., but we must ensure that we always extend the mappings as we go in. +-- +-- All of this information is bundled up in the 'RnEnv2' +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 +addRnInScopeSet env vs + | isEmptyVarSet vs = env + | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } + +rnInScope :: Var -> RnEnv2 -> Bool +rnInScope x env = x `elemInScopeSet` in_scope env + +rnInScopeSet :: RnEnv2 -> InScopeSet +rnInScopeSet = in_scope + +-- | Retrieve the left mapping +rnEnvL :: RnEnv2 -> VarEnv Var +rnEnvL = envL + +-- | Retrieve the right mapping +rnEnvR :: RnEnv2 -> VarEnv Var +rnEnvR = envR + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, +-- and binder @bR@ in the Right term. +-- It finds a new binder, @new_b@, +-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ +rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR + +rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but returns the new variable as well as the +-- new environment +rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = (RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->x], [y->y, z->x], {y,x} } + +rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the left +-- side only. +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the right +-- side only. +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envR = extendVarEnv envR bR new_b + , envL = envL + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndrL' but used for eta expansion +-- See Note [Eta expansion] +rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used for eta expansion +-- See Note [Eta expansion] +rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- ^ Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env +inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env + +lookupRnInScope :: RnEnv2 -> Var -> Var +lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +-- ^ Wipe the left or right side renaming +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } + +rnSwap :: RnEnv2 -> RnEnv2 +-- ^ swap the meaning of left and right +rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) + = RV2 { envL = envR, envR = envL, in_scope = in_scope } + +{- +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~ +When matching + (\x.M) ~ N +we rename x to x' with, where x' is not in scope in +either term. Then we want to behave as if we'd seen + (\x'.M) ~ (\x'.N x') +Since x' isn't in scope in N, the form (\x'. N x') doesn't +capture any variables in N. But we must nevertheless extend +the envR with a binding [x' -> x'], to support the occurs check. +For example, if we don't do this, we can get silly matches like + forall a. (\y.a) ~ v +succeeding with [a -> v y], which is bogus of course. + + +************************************************************************ +* * + Tidying +* * +************************************************************************ +-} + +-- | Tidy Environment +-- +-- When tidying up print names, we keep a mapping of in-scope occ-names +-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings +type TidyEnv = (TidyOccEnv, VarEnv Var) + +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) + +mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv +mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) + +delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv +delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') + where + occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs + var_env' = var_env `delVarEnvList` vs + +{- +************************************************************************ +* * +\subsection{@VarEnv@s} +* * +************************************************************************ +-} + +-- We would like this to be `UniqFM Var elt` +-- but the code uses various key types. +-- So for now make it explicitly untyped + +-- | Variable Environment +type VarEnv elt = UniqFM Var elt + +-- | Identifier Environment +type IdEnv elt = UniqFM Id elt + +-- | Type Variable Environment +type TyVarEnv elt = UniqFM Var elt + +-- | Type or Coercion Variable Environment +type TyCoVarEnv elt = UniqFM TyCoVar elt + +-- | Coercion Variable Environment +type CoVarEnv elt = UniqFM CoVar elt + +emptyVarEnv :: VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b +plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +plusVarEnvList :: [VarEnv a] -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a + +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) +restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a +delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a +plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a +plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a +mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a + +isEmptyVarEnv :: VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +lookupVarEnv_NF :: VarEnv a -> Var -> a +lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool +disjointVarEnv :: VarEnv a -> VarEnv a -> Bool + +elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly +disjointVarEnv = disjointUFM +alterVarEnv = alterUFM +extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc +extendVarEnvList = addListToUFM +plusVarEnv_C = plusUFM_C +plusVarEnv_CD = plusUFM_CD +plusMaybeVarEnv_C = plusMaybeUFM_C +delVarEnvList = delListFromUFM +delVarEnv = delFromUFM +minusVarEnv = minusUFM +plusVarEnv = plusUFM +plusVarEnvList = plusUFMList +lookupVarEnv = lookupUFM +filterVarEnv = filterUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM +mapVarEnv = mapUFM +mkVarEnv = listToUFM +mkVarEnv_Directly= listToUFM_Directly +emptyVarEnv = emptyUFM +unitVarEnv = unitUFM +isEmptyVarEnv = isNullUFM +partitionVarEnv = partitionUFM + +restrictVarEnv env vs = filterUFM_Directly keep env + where + keep u _ = u `elemVarSetByKey` vs + +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case lookupVarEnv env id of + Just xx -> xx + Nothing -> panic "lookupVarEnv_NF: Nothing" + +{- +@modifyVarEnv@: Look up a thing in the VarEnv, +then mash it with the modify function, and put it back. +-} + +modifyVarEnv mangle_fn env key + = case (lookupVarEnv env key) of + Nothing -> env + Just xx -> extendVarEnv env key (mangle_fn xx) + +modifyVarEnv_Directly :: (a -> a) -> UniqFM key a -> Unique -> UniqFM key a +modifyVarEnv_Directly mangle_fn env key + = case (lookupUFM_Directly env key) of + Nothing -> env + Just xx -> addToUFM_Directly env key (mangle_fn xx) + +-- Deterministic VarEnv +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarEnv. + +-- | Deterministic Variable Environment +type DVarEnv elt = UniqDFM Var elt + +-- | Deterministic Identifier Environment +-- Sadly not always indexed by Id, but it is in the common case. +type DIdEnv elt = UniqDFM Var elt + +-- | Deterministic Type Variable Environment +type DTyVarEnv elt = UniqDFM TyVar elt + +emptyDVarEnv :: DVarEnv a +emptyDVarEnv = emptyUDFM + +dVarEnvElts :: DVarEnv a -> [a] +dVarEnvElts = eltsUDFM + +mkDVarEnv :: [(Var, a)] -> DVarEnv a +mkDVarEnv = listToUDFM + +extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv = addToUDFM + +minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a +minusDVarEnv = minusUDFM + +lookupDVarEnv :: DVarEnv a -> Var -> Maybe a +lookupDVarEnv = lookupUDFM + +foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b +foldDVarEnv = foldUDFM + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b +nonDetStrictFoldDVarEnv = nonDetStrictFoldUDFM + +mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b +mapDVarEnv = mapUDFM + +filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a +filterDVarEnv = filterUDFM + +alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a +alterDVarEnv = alterUDFM + +plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv = plusUDFM + +plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv_C = plusUDFM_C + +unitDVarEnv :: Var -> a -> DVarEnv a +unitDVarEnv = unitUDFM + +delDVarEnv :: DVarEnv a -> Var -> DVarEnv a +delDVarEnv = delFromUDFM + +delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a +delDVarEnvList = delListFromUDFM + +isEmptyDVarEnv :: DVarEnv a -> Bool +isEmptyDVarEnv = isNullUDFM + +elemDVarEnv :: Var -> DVarEnv a -> Bool +elemDVarEnv = elemUDFM + +extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv_C = addToUDFM_C + +modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a +modifyDVarEnv mangle_fn env key + = case (lookupDVarEnv env key) of + Nothing -> env + Just xx -> extendDVarEnv env key (mangle_fn xx) + +partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) +partitionDVarEnv = partitionUDFM + +extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a +extendDVarEnvList = addListToUDFM + +anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool +anyDVarEnv = anyUDFM diff --git a/GHC/Types/Var/Set.hs b/GHC/Types/Var/Set.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Var/Set.hs @@ -0,0 +1,362 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +module GHC.Types.Var.Set ( + -- * Var, Id and TyVar set types + VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, + + -- ** Manipulating these sets + emptyVarSet, unitVarSet, mkVarSet, + extendVarSet, extendVarSetList, + elemVarSet, subVarSet, + unionVarSet, unionVarSets, mapUnionVarSet, + intersectVarSet, intersectsVarSet, disjointVarSet, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, + minusVarSet, filterVarSet, mapVarSet, + anyVarSet, allVarSet, + transCloVarSet, fixVarSet, + lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, + sizeVarSet, seqVarSet, + elemVarSetByKey, partitionVarSet, + pluralVarSet, pprVarSet, + nonDetStrictFoldVarSet, + + -- * Deterministic Var set types + DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, + + -- ** Manipulating these sets + emptyDVarSet, unitDVarSet, mkDVarSet, + extendDVarSet, extendDVarSetList, + elemDVarSet, dVarSetElems, subDVarSet, + unionDVarSet, unionDVarSets, mapUnionDVarSet, + intersectDVarSet, dVarSetIntersectVarSet, + intersectsDVarSet, disjointDVarSet, + isEmptyDVarSet, delDVarSet, delDVarSetList, + minusDVarSet, + nonDetStrictFoldDVarSet, + filterDVarSet, mapDVarSet, + dVarSetMinusVarSet, anyDVarSet, allDVarSet, + transCloDVarSet, + sizeDVarSet, seqDVarSet, + partitionDVarSet, + dVarSetToVarSet, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Var ( Var, TyVar, CoVar, TyCoVar, Id ) +import GHC.Types.Unique +import GHC.Types.Name ( Name ) +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM( disjointUFM, pluralUFM, pprUFM ) +import GHC.Types.Unique.DFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) +import GHC.Utils.Outputable (SDoc) + +-- | A non-deterministic Variable Set +-- +-- A non-deterministic set of variables. +-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why it's not +-- deterministic and why it matters. Use DVarSet if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code, for example when abstracting variables. +type VarSet = UniqSet Var + +-- | Identifier Set +type IdSet = UniqSet Id + +-- | Type Variable Set +type TyVarSet = UniqSet TyVar + +-- | Coercion Variable Set +type CoVarSet = UniqSet CoVar + +-- | Type or Coercion Variable Set +type TyCoVarSet = UniqSet TyCoVar + +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet + +mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet +-- ^ map the function over the list, and union the results + +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +extendVarSetList:: VarSet -> [Var] -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var +lookupVarSet :: VarSet -> Var -> Maybe Var + -- Returns the set element, which may be + -- (==) to the argument, but not the same as +lookupVarSetByName :: VarSet -> Name -> Maybe Var +sizeVarSet :: VarSet -> Int +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet + +delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool +partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) + +emptyVarSet = emptyUniqSet +unitVarSet = unitUniqSet +extendVarSet = addOneToUniqSet +extendVarSetList= addListToUniqSet +intersectVarSet = intersectUniqSets + +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection +disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection +subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; + -- ditto disjointVarSet, subVarSet + +unionVarSet = unionUniqSets +unionVarSets = unionManyUniqSets +elemVarSet = elementOfUniqSet +minusVarSet = minusUniqSet +delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet +isEmptyVarSet = isEmptyUniqSet +mkVarSet = mkUniqSet +lookupVarSet_Directly = lookupUniqSet_Directly +lookupVarSet = lookupUniqSet +lookupVarSetByName set name = lookupUniqSet_Directly set (getUnique name) +sizeVarSet = sizeUniqSet +filterVarSet = filterUniqSet +delVarSetByKey = delOneFromUniqSet_Directly +elemVarSetByKey = elemUniqSet_Directly +partitionVarSet = partitionUniqSet + +mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs + +-- See comments with type signatures +intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) +disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) +subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) + +anyVarSet :: (Var -> Bool) -> VarSet -> Bool +anyVarSet = uniqSetAny + +allVarSet :: (Var -> Bool) -> VarSet -> Bool +allVarSet = uniqSetAll + +mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapVarSet = mapUniqSet + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a +nonDetStrictFoldVarSet = nonDetStrictFoldUniqSet + +fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set + -> VarSet -> VarSet +-- (fixVarSet f s) repeatedly applies f to the set s, +-- until it reaches a fixed point. +fixVarSet fn vars + | new_vars `subVarSet` vars = vars + | otherwise = fixVarSet fn new_vars + where + new_vars = fn vars + +transCloVarSet :: (VarSet -> VarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> VarSet -> VarSet +-- (transCloVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +-- Use fixVarSet if the function needs to see the whole set all at once +transCloVarSet fn seeds + = go seeds seeds + where + go :: VarSet -- Accumulating result + -> VarSet -- Work-list; un-processed subset of accumulating result + -> VarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyVarSet new_vs = acc + | otherwise = go (acc `unionVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusVarSet` acc + +seqVarSet :: VarSet -> () +seqVarSet s = sizeVarSet s `seq` () + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralVarSet :: VarSet -> SDoc +pluralVarSet = pluralUFM . getUniqSet + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +-- Passing a list to the pretty-printing function allows the caller +-- to decide on the order of Vars (eg. toposort them) without them having +-- to use nonDetEltsUFM at the call site. This prevents from let-binding +-- non-deterministically ordered lists and reusing them where determinism +-- matters. +pprVarSet :: VarSet -- ^ The things to be pretty printed + -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the + -- elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprVarSet = pprUFM . getUniqSet + +-- Deterministic VarSet +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarSet. + +-- | Deterministic Variable Set +type DVarSet = UniqDSet Var + +-- | Deterministic Identifier Set +type DIdSet = UniqDSet Id + +-- | Deterministic Type Variable Set +type DTyVarSet = UniqDSet TyVar + +-- | Deterministic Type or Coercion Variable Set +type DTyCoVarSet = UniqDSet TyCoVar + +emptyDVarSet :: DVarSet +emptyDVarSet = emptyUniqDSet + +unitDVarSet :: Var -> DVarSet +unitDVarSet = unitUniqDSet + +mkDVarSet :: [Var] -> DVarSet +mkDVarSet = mkUniqDSet + +-- The new element always goes to the right of existing ones. +extendDVarSet :: DVarSet -> Var -> DVarSet +extendDVarSet = addOneToUniqDSet + +elemDVarSet :: Var -> DVarSet -> Bool +elemDVarSet = elementOfUniqDSet + +dVarSetElems :: DVarSet -> [Var] +dVarSetElems = uniqDSetToList + +subDVarSet :: DVarSet -> DVarSet -> Bool +subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) + +unionDVarSet :: DVarSet -> DVarSet -> DVarSet +unionDVarSet = unionUniqDSets + +unionDVarSets :: [DVarSet] -> DVarSet +unionDVarSets = unionManyUniqDSets + +-- | Map the function over the list, and union the results +mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet +mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs + +intersectDVarSet :: DVarSet -> DVarSet -> DVarSet +intersectDVarSet = intersectUniqDSets + +dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetIntersectVarSet = uniqDSetIntersectUniqSet + +-- | True if empty intersection +disjointDVarSet :: DVarSet -> DVarSet -> Bool +disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) + +-- | True if non-empty intersection +intersectsDVarSet :: DVarSet -> DVarSet -> Bool +intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) + +isEmptyDVarSet :: DVarSet -> Bool +isEmptyDVarSet = isEmptyUniqDSet + +delDVarSet :: DVarSet -> Var -> DVarSet +delDVarSet = delOneFromUniqDSet + +minusDVarSet :: DVarSet -> DVarSet -> DVarSet +minusDVarSet = minusUniqDSet + +dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetMinusVarSet = uniqDSetMinusUniqSet + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetStrictFoldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a +nonDetStrictFoldDVarSet = nonDetStrictFoldUniqDSet + +anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool +anyDVarSet p = anyUDFM p . getUniqDSet + +allDVarSet :: (Var -> Bool) -> DVarSet -> Bool +allDVarSet p = allUDFM p . getUniqDSet + +mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapDVarSet = mapUniqDSet + +filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet +filterDVarSet = filterUniqDSet + +sizeDVarSet :: DVarSet -> Int +sizeDVarSet = sizeUniqDSet + +-- | Partition DVarSet according to the predicate given +partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) +partitionDVarSet = partitionUniqDSet + +-- | Delete a list of variables from DVarSet +delDVarSetList :: DVarSet -> [Var] -> DVarSet +delDVarSetList = delListFromUniqDSet + +seqDVarSet :: DVarSet -> () +seqDVarSet s = sizeDVarSet s `seq` () + +-- | Add a list of variables to DVarSet +extendDVarSetList :: DVarSet -> [Var] -> DVarSet +extendDVarSetList = addListToUniqDSet + +-- | Convert a DVarSet to a VarSet by forgetting the order of insertion +dVarSetToVarSet :: DVarSet -> VarSet +dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet + +-- | transCloVarSet for DVarSet +transCloDVarSet :: (DVarSet -> DVarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> DVarSet -> DVarSet +-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +transCloDVarSet fn seeds + = go seeds seeds + where + go :: DVarSet -- Accumulating result + -> DVarSet -- Work-list; un-processed subset of accumulating result + -> DVarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyDVarSet new_vs = acc + | otherwise = go (acc `unionDVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusDVarSet` acc diff --git a/GHC/Unit.hs b/GHC/Unit.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | Units are library components from Cabal packages compiled and installed in +-- a database +module GHC.Unit + ( module GHC.Unit.Types + , module GHC.Unit.Info + , module GHC.Unit.Parser + , module GHC.Unit.State + , module GHC.Unit.Module + ) +where + +import GHC.Unit.Types +import GHC.Unit.Info +import GHC.Unit.Parser +import GHC.Unit.State +import GHC.Unit.Module + +{- + +Note [About Units] +~~~~~~~~~~~~~~~~~~ + +Haskell users are used to manipulate Cabal packages. These packages are +identified by: + - a package name :: String + - a package version :: Version + - (a revision number, when they are registered on Hackage) + +Cabal packages may contain several components (libraries, programs, +testsuites). In GHC we are mostly interested in libraries because those are +the components that can be depended upon by other components. Components in a +package are identified by their component name. Historically only one library +component was allowed per package, hence it didn't need a name. For this +reason, component name may be empty for one library component in each +package: + - a component name :: Maybe String + +UnitId +------ + +Cabal libraries can be compiled in various ways (different compiler options +or Cabal flags, different dependencies, etc.), hence using package name, +package version and component name isn't enough to identify a built library. +We use another identifier called UnitId: + + package name \ + package version | ________ + component name | hash of all this ==> | UnitId | + Cabal flags | -------- + compiler options | + dependencies' UnitId / + +Fortunately GHC doesn't have to generate these UnitId: they are provided by +external build tools (e.g. Cabal) with `-this-unit-id` command-line parameter. + +UnitIds are important because they are used to generate internal names +(symbols, etc.). + +Wired-in units +-------------- + +Certain libraries (ghc-prim, base, etc.) are known to the compiler and to the +RTS as they provide some basic primitives. Hence UnitIds of wired-in libraries +are fixed. Instead of letting Cabal chose the UnitId for these libraries, their +.cabal file uses the following stanza to force it to a specific value: + + ghc-options: -this-unit-id ghc-prim -- taken from ghc-prim.cabal + +The RTS also uses entities of wired-in units by directly referring to symbols +such as "base_GHCziIOziException_heapOverflow_closure" where the prefix is +the UnitId of "base" unit. + +Unit databases +-------------- + +Units are stored in databases in order to be reused by other codes: + + UnitKey ---> UnitInfo { exposed modules, package name, package version + component name, various file paths, + dependencies :: [UnitKey], etc. } + +Because of the wired-in units described above, we can't exactly use UnitIds +as UnitKeys in the database: if we did this, we could only have a single unit +(compiled library) in the database for each wired-in library. As we want to +support databases containing several different units for the same wired-in +library, we do this: + + * for non wired-in units: + * UnitId = UnitKey = Identifier (hash) computed by Cabal + + * for wired-in units: + * UnitKey = Identifier computed by Cabal (just like for non wired-in units) + * UnitId = unit-id specified with -this-unit-id command-line flag + +We can expose several units to GHC via the `package-id ` command-line +parameter. We must use the UnitKeys of the units so that GHC can find them in +the database. + +During unit loading, GHC replaces UnitKeys with UnitIds. It identifies wired +units by their package name (stored in their UnitInfo) and uses wired-in UnitIds +for them. + +For example, knowing that "base", "ghc-prim" and "rts" are wired-in units, the +following dependency graph expressed with database UnitKeys will be transformed +into a similar graph expressed with UnitIds: + + UnitKeys + ~~~~~~~~ ----------> rts-1.0-hashABC <-- + | | + | | + foo-2.0-hash123 --> base-4.1-hashXYZ ---> ghc-prim-0.5.3-hashUVW + + UnitIds + ~~~~~~~ ---------------> rts <-- + | | + | | + foo-2.0-hash123 --> base ---------------> ghc-prim + + +Note that "foo-2.0-hash123" isn't wired-in so its UnitId is the same as its UnitKey. + + +Module signatures / indefinite units / instantiated units +--------------------------------------------------------- + +GHC distinguishes two kinds of units: + + * definite units: + * units without module holes and with definite dependencies + * can be compiled into machine code (.o/.a/.so/.dll/...) + + * indefinite units: + * units with some module holes or with some indefinite dependencies + * can only be type-checked + +Module holes are constrained by module signatures (.hsig files). Module +signatures are a kind of interface (similar to .hs-boot files). They are used in +place of some real code. GHC allows modules from other units to be used to fill +these module holes: the process is called "unit/module instantiation". The +instantiating module may either be a concrete module or a module signature. In +the latter case, the signatures are merged to form a new one. + +You can think of this as polymorphism at the module level: module signatures +give constraints on the "type" of module that can be used to fill the hole +(where "type" means types of the exported module entitites, etc.). + +Module signatures contain enough information (datatypes, abstract types, type +synonyms, classes, etc.) to typecheck modules depending on them but not +enough to compile them. As such, indefinite units found in databases only +provide module interfaces (the .hi ones this time), not object code. + +To distinguish between indefinite and definite unit ids at the type level, we +respectively use 'IndefUnitId' and 'DefUnitId' datatypes that are basically +wrappers over 'UnitId'. + +Unit instantiation / on-the-fly instantiation +--------------------------------------------- + +Indefinite units can be instantiated with modules from other units. The +instantiating units can also be instantiated themselves (if there are +indefinite) and so on. + +On-the-fly unit instantiation is a tricky optimization explained in +http://blog.ezyang.com/2016/08/optimizing-incremental-compilation +Here is a summary: + + 1. Indefinite units can only be type-checked, not compiled into real code. + Type-checking produces interface files (.hi) which are incomplete for code + generation (they lack unfoldings, etc.) but enough to perform type-checking + of units depending on them. + + 2. Type-checking an instantiated unit is cheap as we only have to merge + interface files (.hi) of the instantiated unit and of the instantiating + units, hence it can be done on-the-fly. Interface files of the dependencies + can be concrete or produced on-the-fly recursively. + + 3. When we compile a unit, we mustn't use interfaces produced by the + type-checker (on-the-fly or not) for the instantiated unit dependencies + because they lack some information. + + 4. When we type-check an indefinite unit, we must be consistent about the + interfaces we use for each dependency: only those produced by the + type-checker (on-the-fly or not) or only those produced after a full + compilation, but not both at the same time. + + It can be tricky if we have the following kind of dependency graph: + + X (indefinite) ------> D (definite, compiled) -----> I (instantiated, definite, compiled) + |----------------------------------------------------^ + + Suppose we want to type-check unit X which depends on unit I and D: + * I is definite and compiled: we have compiled .hi files for its modules on disk + * I is instantiated: it is cheap to produce type-checker .hi files for its modules on-the-fly + + But we must not do: + + X (indefinite) ------> D (definite, compiled) -----> I (instantiated, definite, compiled) + |--------------------------------------------------> I (instantiated on-the-fly) + + ==> inconsistent module interfaces for I + + Nor: + + X (indefinite) ------> D (definite, compiled) -------v + |--------------------------------------------------> I (instantiated on-the-fly) + + ==> D's interfaces may refer to things that only exist in I's *compiled* interfaces + + An alternative would be to store both type-checked and compiled interfaces + for every compiled non-instantiated unit (instantiated unit can be done + on-the-fly) so that we could use type-checked interfaces of D in the + example above. But it would increase compilation time and unit size. + + +The 'Unit' datatype represents a unit which may have been instantiated +on-the-fly: + + data Unit = RealUnit DefUnitId -- use compiled interfaces on disk + | VirtUnit InstantiatedUnit -- use on-the-fly instantiation + +'InstantiatedUnit' has two interesting fields: + + * instUnitInstanceOf :: IndefUnitId + -- ^ the indefinite unit that is instantiated + + * instUnitInsts :: [(ModuleName,(Unit,ModuleName)] + -- ^ a list of instantiations, where an instantiation is: + (module hole name, (instantiating unit, instantiating module name)) + +A 'VirtUnit' may be indefinite or definite, it depends on whether some holes +remain in the instantiated unit OR in the instantiating units (recursively). +Having a fully instantiated (i.e. definite) virtual unit can lead to some issues +if there is a matching compiled unit in the preload closure. See Note [VirtUnit +to RealUnit improvement] + +Unit database and indefinite units +---------------------------------- + +We don't store partially instantiated units in the unit database. Units in the +database are either: + + * definite (fully instantiated or without holes): in this case we have + *compiled* module interfaces (.hi) and object codes (.o/.a/.so/.dll/...). + + * fully indefinite (not instantiated at all): in this case we only have + *type-checked* module interfaces (.hi). + +Note that indefinite units are stored as an instantiation of themselves where +each instantiating module is a module variable (see Note [Representation of +module/name variables]). E.g. + + "xyz" (UnitKey) ---> UnitInfo { instanceOf = "xyz" + , instantiatedWith = [A=,B=...] + , ... + } + +Note that non-instantiated units are also stored as an instantiation of +themselves. It is a reminiscence of previous terminology (when "instanceOf" was +"componentId"). E.g. + + "xyz" (UnitKey) ---> UnitInfo { instanceOf = "xyz" + , instantiatedWith = [] + , ... + } + +TODO: We should probably have `instanceOf :: Maybe IndefUnitId` instead. + + +Pretty-printing UnitId +---------------------- + +GHC mostly deals with UnitIds which are some opaque strings. We could display +them when we pretty-print a module origin, a name, etc. But it wouldn't be +very friendly to the user because of the hash they usually contain. E.g. + + foo-4.18.1:thelib-XYZsomeUglyHashABC + +Instead when we want to pretty-print a 'UnitId' we query the database to +get the 'UnitInfo' and print something nicer to the user: + + foo-4.18.1:thelib + +We do the same for wired-in units. + +Currently (2020-04-06), we don't thread the database into every function that +pretty-prints a Name/Module/Unit. Instead querying the database is delayed +until the `SDoc` is transformed into a `Doc` using the database that is +active at this point in time. This is an issue because we want to be able to +unload units from the database and we also want to support several +independent databases loaded at the same time (see #14335). The alternatives +we have are: + + * threading the database into every function that pretty-prints a UnitId + for the user (directly or indirectly). + + * storing enough info to correctly display a UnitId into the UnitId + datatype itself. This is done in the IndefUnitId wrapper (see + 'UnitPprInfo' datatype) but not for every 'UnitId'. Statically defined + 'UnitId' for wired-in units would have empty UnitPprInfo so we need to + find some places to update them if we want to display wired-in UnitId + correctly. This leads to a solution similar to the first one above. + +Note [VirtUnit to RealUnit improvement] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Over the course of instantiating VirtUnits on the fly while typechecking an +indefinite library, we may end up with a fully instantiated VirtUnit. I.e. +one that could be compiled and installed in the database. During +type-checking we generate a virtual UnitId for it, say "abc". + +Now the question is: do we have a matching installed unit in the database? +Suppose we have one with UnitId "xyz" (provided by Cabal so we don't know how +to generate it). The trouble is that if both units end up being used in the +same type-checking session, their names won't match (e.g. "abc:M.X" vs +"xyz:M.X"). + +As we want them to match we just replace the virtual unit with the installed +one: for some reason this is called "improvement". + +There is one last niggle: improvement based on the unit database means +that we might end up developing on a unit that is not transitively +depended upon by the units the user specified directly via command line +flags. This could lead to strange and difficult to understand bugs if those +instantiations are out of date. The solution is to only improve a +unit id if the new unit id is part of the 'preloadClosure'; i.e., the +closure of all the units which were explicitly specified. + +Note [Representation of module/name variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In our ICFP'16, we use to represent module holes, and {A.T} to represent +name holes. This could have been represented by adding some new cases +to the core data types, but this would have made the existing 'moduleName' +and 'moduleUnit' partial, which would have required a lot of modifications +to existing code. + +Instead, we use a fake "hole" unit: + + ===> hole:A + {A.T} ===> hole:A.T + +This encoding is quite convenient, but it is also a bit dangerous too, +because if you have a 'hole:A' you need to know if it's actually a +'Module' or just a module stored in a 'Name'; these two cases must be +treated differently when doing substitutions. 'renameHoleModule' +and 'renameHoleUnit' assume they are NOT operating on a +'Name'; 'NameShape' handles name substitutions exclusively. + +-} diff --git a/GHC/Unit/Info.hs b/GHC/Unit/Info.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Info.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} + +-- | Info about installed units (compiled libraries) +module GHC.Unit.Info + ( GenericUnitInfo (..) + , GenUnitInfo + , UnitInfo + , UnitKey (..) + , UnitKeyInfo + , mkUnitKeyInfo + , mapUnitInfo + , mkUnitPprInfo + + , mkUnit + + , PackageId(..) + , PackageName(..) + , Version(..) + , unitPackageNameString + , unitPackageIdString + , pprUnitInfo + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Unit.Database +import Data.Version +import Data.Bifunctor + +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Unit.Module as Module +import GHC.Types.Unique +import GHC.Unit.Ppr + +-- | Information about an installed unit +-- +-- We parameterize on the unit identifier: +-- * UnitKey: identifier used in the database (cf 'UnitKeyInfo') +-- * UnitId: identifier used to generate code (cf 'UnitInfo') +-- +-- These two identifiers are different for wired-in packages. See Note [About +-- Units] in "GHC.Unit" +type GenUnitInfo unit = GenericUnitInfo (Indefinite unit) PackageId PackageName unit ModuleName (GenModule (GenUnit unit)) + +-- | A unit key in the database +newtype UnitKey = UnitKey FastString + +unitKeyFS :: UnitKey -> FastString +unitKeyFS (UnitKey fs) = fs + +-- | Information about an installed unit (units are identified by their database +-- UnitKey) +type UnitKeyInfo = GenUnitInfo UnitKey + +-- | Information about an installed unit (units are identified by their internal +-- UnitId) +type UnitInfo = GenUnitInfo UnitId + +-- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` +mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo +mkUnitKeyInfo = mapGenericUnitInfo + mkUnitKey' + mkIndefUnitKey' + mkPackageIdentifier' + mkPackageName' + mkModuleName' + mkModule' + where + mkPackageIdentifier' = PackageId . mkFastStringByteString + mkPackageName' = PackageName . mkFastStringByteString + mkUnitKey' = UnitKey . mkFastStringByteString + mkModuleName' = mkModuleNameFS . mkFastStringByteString + mkIndefUnitKey' cid = Indefinite (mkUnitKey' cid) Nothing + mkVirtUnitKey' i = case i of + DbInstUnitId cid insts -> mkGenVirtUnit unitKeyFS (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts) + DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid)) + mkModule' m = case m of + DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n) + DbModuleVar n -> mkHoleModule (mkModuleName' n) + +-- | Map over the unit parameter +mapUnitInfo :: (u -> v) -> (v -> FastString) -> GenUnitInfo u -> GenUnitInfo v +mapUnitInfo f gunitFS = mapGenericUnitInfo + f -- unit identifier + (fmap f) -- indefinite unit identifier + id -- package identifier + id -- package name + id -- module name + (fmap (mapGenUnit f gunitFS)) -- instantiating modules + +-- TODO: there's no need for these to be FastString, as we don't need the uniq +-- feature, but ghc doesn't currently have convenient support for any +-- other compact string types, e.g. plain ByteString or Text. + +newtype PackageId = PackageId FastString deriving (Eq, Ord) +newtype PackageName = PackageName + { unPackageName :: FastString + } + deriving (Eq, Ord) + +instance Uniquable PackageId where + getUnique (PackageId n) = getUnique n + +instance Uniquable PackageName where + getUnique (PackageName n) = getUnique n + +instance Outputable PackageId where + ppr (PackageId str) = ftext str + +instance Outputable PackageName where + ppr (PackageName str) = ftext str + +unitPackageIdString :: GenUnitInfo u -> String +unitPackageIdString pkg = unpackFS str + where + PackageId str = unitPackageId pkg + +unitPackageNameString :: GenUnitInfo u -> String +unitPackageNameString pkg = unpackFS str + where + PackageName str = unitPackageName pkg + +pprUnitInfo :: UnitInfo -> SDoc +pprUnitInfo GenericUnitInfo {..} = + vcat [ + field "name" (ppr unitPackageName), + field "version" (text (showVersion unitPackageVersion)), + field "id" (ppr unitId), + field "exposed" (ppr unitIsExposed), + field "exposed-modules" (ppr unitExposedModules), + field "hidden-modules" (fsep (map ppr unitHiddenModules)), + field "trusted" (ppr unitIsTrusted), + field "import-dirs" (fsep (map text unitImportDirs)), + field "library-dirs" (fsep (map text unitLibraryDirs)), + field "dynamic-library-dirs" (fsep (map text unitLibraryDynDirs)), + field "hs-libraries" (fsep (map text unitLibraries)), + field "extra-libraries" (fsep (map text unitExtDepLibsSys)), + field "extra-ghci-libraries" (fsep (map text unitExtDepLibsGhc)), + field "include-dirs" (fsep (map text unitIncludeDirs)), + field "includes" (fsep (map text unitIncludes)), + field "depends" (fsep (map ppr unitDepends)), + field "cc-options" (fsep (map text unitCcOptions)), + field "ld-options" (fsep (map text unitLinkerOptions)), + field "framework-dirs" (fsep (map text unitExtDepFrameworkDirs)), + field "frameworks" (fsep (map text unitExtDepFrameworks)), + field "haddock-interfaces" (fsep (map text unitHaddockInterfaces)), + field "haddock-html" (fsep (map text unitHaddockHTMLs)) + ] + where + field name body = text name <> colon <+> nest 4 body + +-- | Make a `Unit` from a `UnitInfo` +-- +-- If the unit is definite, make a `RealUnit` from `unitId` field. +-- +-- If the unit is indefinite, make a `VirtUnit` from `unitInstanceOf` and +-- `unitInstantiations` fields. Note that in this case we don't keep track of +-- `unitId`. It can be retrieved later with "improvement", i.e. matching on +-- `unitInstanceOf/unitInstantiations` fields (see Note [About units] in +-- GHC.Unit). +mkUnit :: UnitInfo -> Unit +mkUnit p + | unitIsIndefinite p = mkVirtUnit (unitInstanceOf p) (unitInstantiations p) + | otherwise = RealUnit (Definite (unitId p)) + +-- | Create a UnitPprInfo from a UnitInfo +mkUnitPprInfo :: GenUnitInfo u -> UnitPprInfo +mkUnitPprInfo i = UnitPprInfo + (unitPackageNameString i) + (unitPackageVersion i) + ((unpackFS . unPackageName) <$> unitComponentName i) diff --git a/GHC/Unit/Module.hs b/GHC/Unit/Module.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module.hs @@ -0,0 +1,139 @@ +{- +(c) The University of Glasgow, 2004-2006 + + +Module +~~~~~~~~~~ +Simply the name of a module, represented as a FastString. +These are Uniquable, hence we can build Maps with Modules as +the keys. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module GHC.Unit.Module + ( module GHC.Unit.Types + + -- * The ModuleName type + , module GHC.Unit.Module.Name + + -- * The ModLocation type + , module GHC.Unit.Module.Location + + -- * ModuleEnv + , module GHC.Unit.Module.Env + + -- * Generalization + , getModuleInstantiation + , getUnitInstantiations + , uninstantiateInstantiatedUnit + , uninstantiateInstantiatedModule + + -- * The Module type + , mkHoleModule + , isHoleModule + , stableModuleCmp + , moduleStableString + , moduleIsDefinite + , HasModule(..) + , ContainsModule(..) + , unitIdEq + , installedModuleEq + ) where + +import GHC.Prelude + +import GHC.Types.Unique.DSet +import GHC.Unit.Types +import GHC.Unit.Module.Name +import GHC.Unit.Module.Location +import GHC.Unit.Module.Env +import GHC.Utils.Misc + +-- | A 'Module' is definite if it has no free holes. +moduleIsDefinite :: Module -> Bool +moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles + +-- | Get a string representation of a 'Module' that's unique and stable +-- across recompilations. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" +moduleStableString :: Module -> String +moduleStableString Module{..} = + "$" ++ unitString moduleUnit ++ "$" ++ moduleNameString moduleName + + +-- | This gives a stable ordering, as opposed to the Ord instance which +-- gives an ordering based on the 'Unique's of the components, which may +-- not be stable from run to run of the compiler. +stableModuleCmp :: Module -> Module -> Ordering +stableModuleCmp (Module p1 n1) (Module p2 n2) + = (p1 `stableUnitCmp` p2) `thenCmp` + (n1 `stableModuleNameCmp` n2) + +class ContainsModule t where + extractModule :: t -> Module + +class HasModule m where + getModule :: m Module + + +-- | Test if a 'Module' corresponds to a given 'InstalledModule', +-- modulo instantiation. +installedModuleEq :: InstalledModule -> Module -> Bool +installedModuleEq imod mod = + fst (getModuleInstantiation mod) == imod + +-- | Test if a 'Unit' corresponds to a given 'UnitId', +-- modulo instantiation. +unitIdEq :: UnitId -> Unit -> Bool +unitIdEq iuid uid = toUnitId uid == iuid + +{- +************************************************************************ +* * + Hole substitutions +* * +************************************************************************ +-} + +-- | Given a possibly on-the-fly instantiated module, split it into +-- a 'Module' that we definitely can find on-disk, as well as an +-- instantiation if we need to instantiate it on the fly. If the +-- instantiation is @Nothing@ no on-the-fly renaming is needed. +getModuleInstantiation :: Module -> (InstalledModule, Maybe InstantiatedModule) +getModuleInstantiation m = + let (uid, mb_iuid) = getUnitInstantiations (moduleUnit m) + in (Module uid (moduleName m), + fmap (\iuid -> Module iuid (moduleName m)) mb_iuid) + +-- | Return the unit-id this unit is an instance of and the module instantiations (if any). +getUnitInstantiations :: Unit -> (UnitId, Maybe InstantiatedUnit) +getUnitInstantiations (VirtUnit iuid) = (indefUnit (instUnitInstanceOf iuid), Just iuid) +getUnitInstantiations (RealUnit (Definite uid)) = (uid, Nothing) +getUnitInstantiations HoleUnit = error "Hole unit" + +-- | Remove instantiations of the given instantiated unit +uninstantiateInstantiatedUnit :: InstantiatedUnit -> InstantiatedUnit +uninstantiateInstantiatedUnit u = + mkInstantiatedUnit (instUnitInstanceOf u) + (map (\(m,_) -> (m, mkHoleModule m)) + (instUnitInsts u)) + +-- | Remove instantiations of the given module instantiated unit +uninstantiateInstantiatedModule :: InstantiatedModule -> InstantiatedModule +uninstantiateInstantiatedModule (Module uid n) = Module (uninstantiateInstantiatedUnit uid) n + +-- | Test if a Module is not instantiated +isHoleModule :: GenModule (GenUnit u) -> Bool +isHoleModule (Module HoleUnit _) = True +isHoleModule _ = False + +-- | Create a hole Module +mkHoleModule :: ModuleName -> GenModule (GenUnit u) +mkHoleModule = Module HoleUnit diff --git a/GHC/Unit/Module/Env.hs b/GHC/Unit/Module/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Env.hs @@ -0,0 +1,225 @@ +-- | Module environment +module GHC.Unit.Module.Env + ( -- * Module mappings + ModuleEnv + , elemModuleEnv, extendModuleEnv, extendModuleEnvList + , extendModuleEnvList_C, plusModuleEnv_C + , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv + , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv + , moduleEnvKeys, moduleEnvElts, moduleEnvToList + , unitModuleEnv, isEmptyModuleEnv + , extendModuleEnvWith, filterModuleEnv + + -- * ModuleName mappings + , ModuleNameEnv, DModuleNameEnv + + -- * Sets of Modules + , ModuleSet + , emptyModuleSet, mkModuleSet, moduleSetElts + , extendModuleSet, extendModuleSetList, delModuleSet + , elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet + , unitModuleSet + + -- * InstalledModuleEnv + , InstalledModuleEnv + , emptyInstalledModuleEnv + , lookupInstalledModuleEnv + , extendInstalledModuleEnv + , filterInstalledModuleEnv + , delInstalledModuleEnv + ) +where + +import GHC.Prelude + +import GHC.Unit.Module.Name (ModuleName) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Unit.Types +import GHC.Utils.Misc +import Data.List (sortBy, sort) +import Data.Ord + +import Data.Coerce +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified GHC.Data.FiniteMap as Map + +-- | A map keyed off of 'Module's +newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) + +{- +Note [ModuleEnv performance and determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To prevent accidental reintroduction of nondeterminism the Ord instance +for Module was changed to not depend on Unique ordering and to use the +lexicographic order. This is potentially expensive, but when measured +there was no difference in performance. + +To be on the safe side and not pessimize ModuleEnv uses nondeterministic +ordering on Module and normalizes by doing the lexicographic sort when +turning the env to a list. +See Note [Unique Determinism] for more information about the source of +nondeterminismand and Note [Deterministic UniqFM] for explanation of why +it matters for maps. +-} + +newtype NDModule = NDModule { unNDModule :: Module } + deriving Eq + -- A wrapper for Module with faster nondeterministic Ord. + -- Don't export, See [ModuleEnv performance and determinism] + +instance Ord NDModule where + compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = + (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` + (getUnique n1 `nonDetCmpUnique` getUnique n2) + +filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.filterWithKey (f . unNDModule) e) + +elemModuleEnv :: Module -> ModuleEnv a -> Bool +elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e + +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) + +extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a + -> ModuleEnv a +extendModuleEnvWith f (ModuleEnv e) m x = + ModuleEnv (Map.insertWith f (NDModule m) x e) + +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList (ModuleEnv e) xs = + ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) + +extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] + -> ModuleEnv a +extendModuleEnvList_C f (ModuleEnv e) xs = + ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) + +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = + ModuleEnv (Map.unionWith f e1 e2) + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnvList (ModuleEnv e) ms = + ModuleEnv (Map.deleteList (map NDModule ms) e) + +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) + +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) + +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e + +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +lookupWithDefaultModuleEnv (ModuleEnv e) x m = + Map.findWithDefault x (NDModule m) e + +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) + +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) + +emptyModuleEnv :: ModuleEnv a +emptyModuleEnv = ModuleEnv Map.empty + +moduleEnvKeys :: ModuleEnv a -> [Module] +moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvElts :: ModuleEnv a -> [a] +moduleEnvElts e = map snd $ moduleEnvToList e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvToList :: ModuleEnv a -> [(Module, a)] +moduleEnvToList (ModuleEnv e) = + sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] + -- See Note [ModuleEnv performance and determinism] + +unitModuleEnv :: Module -> a -> ModuleEnv a +unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) + +isEmptyModuleEnv :: ModuleEnv a -> Bool +isEmptyModuleEnv (ModuleEnv e) = Map.null e + +-- | A set of 'Module's +type ModuleSet = Set NDModule + +mkModuleSet :: [Module] -> ModuleSet +mkModuleSet = Set.fromList . coerce + +extendModuleSet :: ModuleSet -> Module -> ModuleSet +extendModuleSet s m = Set.insert (NDModule m) s + +extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet +extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms + +emptyModuleSet :: ModuleSet +emptyModuleSet = Set.empty + +moduleSetElts :: ModuleSet -> [Module] +moduleSetElts = sort . coerce . Set.toList + +elemModuleSet :: Module -> ModuleSet -> Bool +elemModuleSet = Set.member . coerce + +intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +intersectModuleSet = coerce Set.intersection + +minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +minusModuleSet = coerce Set.difference + +delModuleSet :: ModuleSet -> Module -> ModuleSet +delModuleSet = coerce (flip Set.delete) + +unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +unionModuleSet = coerce Set.union + +unitModuleSet :: Module -> ModuleSet +unitModuleSet = coerce Set.singleton + +{- +A ModuleName has a Unique, so we can build mappings of these using +UniqFM. +-} + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +type ModuleNameEnv elt = UniqFM ModuleName elt + + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +-- Has deterministic folds and can be deterministically converted to a list +type DModuleNameEnv elt = UniqDFM ModuleName elt + + +-------------------------------------------------------------------- +-- InstalledModuleEnv +-------------------------------------------------------------------- + +-- | A map keyed off of 'InstalledModule' +newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) + +emptyInstalledModuleEnv :: InstalledModuleEnv a +emptyInstalledModuleEnv = InstalledModuleEnv Map.empty + +lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a +lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e + +extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a +extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) + +filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a +filterInstalledModuleEnv f (InstalledModuleEnv e) = + InstalledModuleEnv (Map.filterWithKey f e) + +delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a +delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) + diff --git a/GHC/Unit/Module/Location.hs b/GHC/Unit/Module/Location.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Location.hs @@ -0,0 +1,87 @@ +-- | Module location +module GHC.Unit.Module.Location + ( ModLocation(..) + , addBootSuffix + , addBootSuffix_maybe + , addBootSuffixLocn + , addBootSuffixLocnOut + , removeBootSuffix + ) +where + +import GHC.Prelude +import GHC.Unit.Types +import GHC.Utils.Outputable + +-- | Module Location +-- +-- Where a module lives on the file system: the actual locations +-- of the .hs, .hi and .o files, if we have them. +-- +-- For a module in another unit, the ml_hs_file and ml_obj_file components of +-- ModLocation are undefined. +-- +-- The locations specified by a ModLocation may or may not +-- correspond to actual files yet: for example, even if the object +-- file doesn't exist, the ModLocation still contains the path to +-- where the object file will reside if/when it is created. + +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + -- ^ The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file :: FilePath, + -- ^ Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_obj_file :: FilePath, + -- ^ Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- unit with a .a file) + + ml_hie_file :: FilePath + -- ^ Where the .hie file is, whether or not it exists + -- yet. + } deriving Show + +instance Outputable ModLocation where + ppr = text . show + +-- | Add the @-boot@ suffix to .hs, .hi and .o files +addBootSuffix :: FilePath -> FilePath +addBootSuffix path = path ++ "-boot" + +-- | Remove the @-boot@ suffix to .hs, .hi and .o files +removeBootSuffix :: FilePath -> FilePath +removeBootSuffix "-boot" = [] +removeBootSuffix (x:xs) = x : removeBootSuffix xs +removeBootSuffix [] = error "removeBootSuffix: no -boot suffix" + + +-- | Add the @-boot@ suffix if the @Bool@ argument is @True@ +addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath +addBootSuffix_maybe is_boot path = case is_boot of + IsBoot -> addBootSuffix path + NotBoot -> path + +-- | Add the @-boot@ suffix to all file paths associated with the module +addBootSuffixLocn :: ModLocation -> ModLocation +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + +-- | Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut :: ModLocation -> ModLocation +addBootSuffixLocnOut locn + = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + + diff --git a/GHC/Unit/Module/Name.hs b/GHC/Unit/Module/Name.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Name.hs @@ -0,0 +1,98 @@ + +-- | The ModuleName type +module GHC.Unit.Module.Name + ( ModuleName + , pprModuleName + , moduleNameFS + , moduleNameString + , moduleNameSlashes, moduleNameColons + , mkModuleName + , mkModuleNameFS + , stableModuleNameCmp + , parseModuleName + ) +where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Data.FastString +import GHC.Utils.Binary +import GHC.Utils.Misc + +import Control.DeepSeq +import Data.Data +import System.FilePath + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP) +import Data.Char (isAlphaNum) + +-- | A ModuleName is essentially a simple string, e.g. @Data.List@. +newtype ModuleName = ModuleName FastString + +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + +instance Eq ModuleName where + nm1 == nm2 = getUnique nm1 == getUnique nm2 + +instance Ord ModuleName where + nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 + +instance Outputable ModuleName where + ppr = pprModuleName + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +instance Data ModuleName where + -- don't traverse? + toConstr _ = abstractConstr "ModuleName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +instance NFData ModuleName where + rnf x = x `seq` () + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 + +pprModuleName :: ModuleName -> SDoc +pprModuleName (ModuleName nm) = + getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS nm) + else ftext nm + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by colons. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +parseModuleName :: ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + diff --git a/GHC/Unit/Module/Name.hs-boot b/GHC/Unit/Module/Name.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Name.hs-boot @@ -0,0 +1,6 @@ +module GHC.Unit.Module.Name where + +import GHC.Prelude () + +data ModuleName + diff --git a/GHC/Unit/Parser.hs b/GHC/Unit/Parser.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Parser.hs @@ -0,0 +1,63 @@ +-- | Parsers for unit/module identifiers +module GHC.Unit.Parser + ( parseUnit + , parseIndefUnitId + , parseHoleyModule + , parseModSubst + ) +where + +import GHC.Prelude + +import GHC.Unit.Types +import GHC.Unit.Module.Name +import GHC.Data.FastString + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP, (<++)) +import Data.Char (isAlphaNum) + +parseUnit :: ReadP Unit +parseUnit = parseVirtUnitId <++ parseDefUnitId + where + parseVirtUnitId = do + uid <- parseIndefUnitId + insts <- parseModSubst + return (mkVirtUnit uid insts) + parseDefUnitId = do + s <- parseUnitId + return (RealUnit (Definite s)) + +parseUnitId :: ReadP UnitId +parseUnitId = do + s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + return (UnitId (mkFastString s)) + +parseIndefUnitId :: ReadP IndefUnitId +parseIndefUnitId = do + uid <- parseUnitId + return (Indefinite uid Nothing) + +parseHoleyModule :: ReadP Module +parseHoleyModule = parseModuleVar <++ parseModule + where + parseModuleVar = do + _ <- Parse.char '<' + modname <- parseModuleName + _ <- Parse.char '>' + return (Module HoleUnit modname) + parseModule = do + uid <- parseUnit + _ <- Parse.char ':' + modname <- parseModuleName + return (Module uid modname) + +parseModSubst :: ReadP [(ModuleName, Module)] +parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') + . flip Parse.sepBy (Parse.char ',') + $ do k <- parseModuleName + _ <- Parse.char '=' + v <- parseHoleyModule + return (k, v) + + diff --git a/GHC/Unit/Ppr.hs b/GHC/Unit/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Ppr.hs @@ -0,0 +1,31 @@ +-- | Unit identifier pretty-printing +module GHC.Unit.Ppr + ( UnitPprInfo (..) + ) +where + +import GHC.Prelude +import GHC.Utils.Outputable +import Data.Version + +-- | Subset of UnitInfo: just enough to pretty-print a unit-id +-- +-- Instead of printing the unit-id which may contain a hash, we print: +-- package-version:componentname +-- +data UnitPprInfo = UnitPprInfo + { unitPprPackageName :: String -- ^ Source package name + , unitPprPackageVersion :: Version -- ^ Source package version + , unitPprComponentName :: Maybe String -- ^ Component name + } + +instance Outputable UnitPprInfo where + ppr pprinfo = text $ mconcat + [ unitPprPackageName pprinfo + , case unitPprPackageVersion pprinfo of + Version [] [] -> "" + version -> "-" ++ showVersion version + , case unitPprComponentName pprinfo of + Nothing -> "" + Just cname -> ":" ++ cname + ] diff --git a/GHC/Unit/State.hs b/GHC/Unit/State.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/State.hs @@ -0,0 +1,2287 @@ +-- (c) The University of Glasgow, 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | Unit manipulation +module GHC.Unit.State ( + module GHC.Unit.Info, + + -- * Reading the package config, and processing cmdline args + UnitState(..), + UnitDatabase (..), + emptyUnitState, + initUnits, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, + listUnitInfo, + + -- * Querying the package config + lookupUnit, + lookupUnit', + unsafeLookupUnit, + lookupUnitId, + lookupUnitId', + unsafeLookupUnitId, + + lookupPackageName, + improveUnit, + searchPackageId, + displayUnitId, + listVisibleModuleNames, + lookupModuleInAllUnits, + lookupModuleWithSuggestions, + lookupModulePackage, + lookupPluginModuleWithSuggestions, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), + UnusableUnitReason(..), + pprReason, + + -- * Inspecting the set of packages in scope + getUnitIncludePath, + getUnitLibraryPath, + getUnitLinkOpts, + getUnitExtraCcOpts, + getUnitFrameworkPath, + getUnitFrameworks, + getPreloadUnitsAnd, + + collectArchives, + collectIncludeDirs, collectLibraryPaths, collectLinkOpts, + packageHsLibs, getLibs, + + -- * Module hole substitution + ShHoleSubst, + renameHoleUnit, + renameHoleModule, + renameHoleUnit', + renameHoleModule', + instUnitToUnit, + instModuleToModule, + + -- * Utils + mkIndefUnitId, + updateIndefUnitId, + unwireUnit, + pprFlag, + pprUnits, + pprUnitsSimple, + pprModuleMap, + homeUnitIsIndefinite, + homeUnitIsDefinite, + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Driver.Session +import GHC.Driver.Ways +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe + +import System.Environment ( getEnv ) +import GHC.Data.FastString +import GHC.Utils.Error ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, + withTiming, DumpFormat (..) ) +import GHC.Utils.Exception + +import System.Directory +import System.FilePath as FilePath +import Control.Monad +import Data.Graph (stronglyConnComp, SCC(..)) +import Data.Char ( toUpper ) +import Data.List as List +import Data.Map (Map) +import Data.Set (Set) +import Data.Monoid (First(..)) +import qualified Data.Semigroup as Semigroup +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import qualified Data.Set as Set + +-- --------------------------------------------------------------------------- +-- The Unit state + +-- | Unit state is all stored in 'DynFlags', including the details of +-- all units, which units are exposed, and which modules they +-- provide. +-- +-- The unit state is computed by 'initUnits', and kept in DynFlags. +-- It is influenced by various command-line flags: +-- +-- * @-package \@ and @-package-id \@ cause @\@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. +-- +-- * @-hide-package \@ causes @\@ to become hidden. +-- +-- * (there are a few more flags, check below for their semantics) +-- +-- The unit state has the following properties. +-- +-- * Let @exposedUnits@ be the set of packages thus exposed. +-- Let @depExposedUnits@ be the transitive closure from @exposedUnits@ of +-- their dependencies. +-- +-- * When searching for a module from a preload import declaration, +-- only the exposed modules in @exposedUnits@ are valid. +-- +-- * When searching for a module from an implicit import, all modules +-- from @depExposedUnits@ are valid. +-- +-- * When linking in a compilation manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with preload @-package@ flags on the command-line, +-- or are a transitive dependency of same, or are \"base\"\/\"rts\". +-- The reason for this is that we might need packages which don't +-- contain any Haskell modules, and therefore won't be discovered +-- by the normal mechanism of dependency tracking. + +-- Notes on DLLs +-- ~~~~~~~~~~~~~ +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + -- | Module is unavailable because the package is unusable. + | ModUnusable UnusableUnitReason + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = panic "ModOrigin: package both exposed/hidden" + g Nothing x = x + g x Nothing = x + _x <> _y = panic "ModOrigin: hidden module redefined" + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +type PreloadUnitClosure = UniqSet UnitId + +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = Map Unit UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'Unit'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name associated with the 'Unit'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: Map ModuleName (Set InstantiatedModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Bool + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) + , uv_explicit = uv_explicit uv1 || uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = Map.empty + , uv_explicit = False + } + mappend = (Semigroup.<>) + + +-- | Unit configuration +data UnitConfig = UnitConfig + { unitConfigPlatformArchOs :: !PlatformMini -- ^ Platform + , unitConfigWays :: !(Set Way) -- ^ Ways to use + , unitConfigProgramName :: !String + -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment + -- variables such as "GHC[JS]_PACKAGE_PATH". + + , unitConfigGlobalDB :: !FilePath -- ^ Path to global DB + , unitConfigGHCDir :: !FilePath -- ^ Main GHC dir: contains settings, etc. + , unitConfigDBName :: !String -- ^ User DB name (e.g. "package.conf.d") + + , unitConfigAutoLink :: ![UnitId] -- ^ Units to link automatically (e.g. base, rts) + , unitConfigDistrustAll :: !Bool -- ^ Distrust all units by default + , unitConfigHideAll :: !Bool -- ^ Hide all units by default + , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default + + , unitConfigAllowVirtualUnits :: !Bool + -- ^ Allow the use of virtual units instantiated on-the-fly (see Note + -- [About units] in GHC.Unit). This should only be used when we are + -- type-checking an indefinite unit (not producing any code). + + , unitConfigDBCache :: Maybe [UnitDatabase UnitId] + -- ^ Cache of databases to use, in the order they were specified on the + -- command line (later databases shadow earlier ones). + -- If Nothing, databases will be found using `unitConfigFlagsDB`. + + -- command-line flags + , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags + , unitConfigFlagsExposed :: [PackageFlag] -- ^ Exposed units + , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units + , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units + , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units + } + +initUnitConfig :: DynFlags -> UnitConfig +initUnitConfig dflags = + let autoLink + | not (gopt Opt_AutoLinkPackages dflags) = [] + -- By default we add base & rts to the preload units (when they are + -- found in the unit database) except when we are building them + | otherwise = filter (/= homeUnitId dflags) [baseUnitId, rtsUnitId] + + in UnitConfig + { unitConfigPlatformArchOs = platformMini (targetPlatform dflags) + , unitConfigProgramName = programName dflags + , unitConfigWays = ways dflags + + , unitConfigGlobalDB = globalPackageDatabasePath dflags + , unitConfigGHCDir = topDir dflags + , unitConfigDBName = "package.conf.d" + + , unitConfigAutoLink = autoLink + , unitConfigDistrustAll = gopt Opt_DistrustAllPackages dflags + , unitConfigHideAll = gopt Opt_HideAllPackages dflags + , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags + + -- when the home unit is indefinite, it means we are type-checking it + -- only (not producing any code). Hence we can use virtual units + -- instantiated on-the-fly (see Note [About units] in GHC.Unit) + , unitConfigAllowVirtualUnits = homeUnitIsIndefinite dflags + + , unitConfigDBCache = unitDatabases dflags + , unitConfigFlagsDB = packageDBFlags dflags + , unitConfigFlagsExposed = packageFlags dflags + , unitConfigFlagsIgnored = ignorePackageFlags dflags + , unitConfigFlagsTrusted = trustFlags dflags + , unitConfigFlagsPlugins = pluginPackageFlags dflags + + } + +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' +type ModuleNameProvidersMap = + Map ModuleName (Map Module ModuleOrigin) + +data UnitState = UnitState { + -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted + -- so that only valid units are here. 'UnitInfo' reflects + -- what was stored *on disk*, except for the 'trusted' flag, which + -- is adjusted at runtime. (In particular, some units in this map + -- may have the 'exposed' flag be 'False'.) + unitInfoMap :: UnitInfoMap, + + -- | The set of transitively reachable units according + -- to the explicitly provided command line arguments. + -- A fully instantiated VirtUnit may only be replaced by a RealUnit from + -- this set. + -- See Note [VirtUnit to RealUnit improvement] + preloadClosure :: PreloadUnitClosure, + + -- | A mapping of 'PackageName' to 'IndefUnitId'. This is used when + -- users refer to packages in Backpack includes. + packageNameMap :: Map PackageName IndefUnitId, + + -- | A mapping from database unit keys to wired in unit ids. + wireMap :: Map UnitId UnitId, + + -- | A mapping from wired in unit ids to unit keys from the database. + unwireMap :: Map UnitId UnitId, + + -- | The units we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a unit + -- is always mentioned before the units it depends on. + preloadUnits :: [UnitId], + + -- | Units which we explicitly depend on (from a command line flag). + -- We'll use this to generate version macros. + explicitUnits :: [Unit], + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility. + pluginModuleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map saying, for each requirement, what interfaces must be merged + -- together when we use them. For example, if our dependencies + -- are @p[A=\]@ and @q[A=\,B=r[C=\]:B]@, then the interfaces + -- to merge for A are @p[A=\]:A@, @q[A=\,B=r[C=\]:B]:A@ + -- and @r[C=\]:C@. + -- + -- There's an entry in this map for each hole in our home library. + requirementContext :: Map ModuleName [InstantiatedModule], + + -- | Indicate if we can instantiate units on-the-fly. + -- + -- This should only be true when we are type-checking an indefinite unit. + -- See Note [About units] in GHC.Unit. + allowVirtualUnits :: !Bool + } + +emptyUnitState :: UnitState +emptyUnitState = UnitState { + unitInfoMap = Map.empty, + preloadClosure = emptyUniqSet, + packageNameMap = Map.empty, + wireMap = Map.empty, + unwireMap = Map.empty, + preloadUnits = [], + explicitUnits = [], + moduleNameProvidersMap = Map.empty, + pluginModuleNameProvidersMap = Map.empty, + requirementContext = Map.empty, + allowVirtualUnits = False + } + +-- | Unit database +data UnitDatabase unit = UnitDatabase + { unitDatabasePath :: FilePath + , unitDatabaseUnits :: [GenUnitInfo unit] + } + +type UnitInfoMap = Map UnitId UnitInfo + +-- | Find the unit we know about with the given unit, if any +lookupUnit :: UnitState -> Unit -> Maybe UnitInfo +lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (preloadClosure pkgs) + +-- | A more specialized interface, which doesn't require a 'UnitState' (so it +-- can be used while we're initializing 'DynFlags') +-- +-- Parameters: +-- * a boolean specifying whether or not to look for on-the-fly renamed interfaces +-- * a 'UnitInfoMap' +-- * a 'PreloadUnitClosure' +lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of + HoleUnit -> error "Hole unit" + RealUnit i -> Map.lookup (unDefinite i) pkg_map + VirtUnit i + | allowOnTheFlyInst + -> -- lookup UnitInfo of the indefinite unit to be instantiated and + -- instantiate it on-the-fly + fmap (renameUnitInfo pkg_map closure (instUnitInsts i)) + (Map.lookup (indefUnit (instUnitInstanceOf i)) pkg_map) + + | otherwise + -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite + -- units. Even if they are real, installed units, they can't use the + -- `RealUnit` constructor (it is reserved for definite units) so we use + -- the `VirtUnit` constructor. + Map.lookup (virtualUnitId i) pkg_map + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo +lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnitId' db uid = Map.lookup uid db + + +-- | Looks up the given unit in the unit state, panicing if it is not found +unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo +unsafeLookupUnit state u = case lookupUnit state u of + Just info -> info + Nothing -> pprPanic "unsafeLookupUnit" (ppr u) + +-- | Looks up the given unit id in the unit state, panicing if it is not found +unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo +unsafeLookupUnitId state uid = case lookupUnitId state uid of + Just info -> info + Nothing -> pprPanic "unsafeLookupUnitId" (ppr uid) + + +-- | Find the unit we know about with the given package name (e.g. @foo@), if any +-- (NB: there might be a locally defined unit name which overrides this) +lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId +lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate) + +-- | Search for units with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: UnitState -> PackageId -> [UnitInfo] +searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId) + (listUnitInfo pkgstate) + +-- | Create a Map UnitId UnitInfo +-- +-- For each instantiated unit, we add two map keys: +-- * the real unit id +-- * the virtual unit id made from its instantiation +-- +-- We do the same thing for fully indefinite units (which are "instantiated" +-- with module holes). +-- +mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap +mkUnitInfoMap infos = foldl' add Map.empty infos + where + mkVirt p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p)) + add pkg_map p + | not (null (unitInstantiations p)) + = Map.insert (mkVirt p) p + $ Map.insert (unitId p) p + $ pkg_map + | otherwise + = Map.insert (unitId p) p pkg_map + +-- | Get a list of entries from the unit database. NB: be careful with +-- this function, although all units in this map are "visible", this +-- does not imply that the exposed-modules of the unit are available +-- (they may have been thinned or renamed). +listUnitInfo :: UnitState -> [UnitInfo] +listUnitInfo state = Map.elems (unitInfoMap state) + +-- ---------------------------------------------------------------------------- +-- Loading the unit db files and building up the unit state + +-- | Read the unit database files, and sets up various internal tables of +-- unit information, according to the unit-related flags on the +-- command-line (@-package@, @-hide-package@ etc.) +-- +-- 'initUnits' can be called again subsequently after updating the +-- 'packageFlags' field of the 'DynFlags', and it will update the +-- 'unitState' in 'DynFlags'. +initUnits :: DynFlags -> IO DynFlags +initUnits dflags = do + + let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () + let ctx = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages + let printer = debugTraceMsg dflags -- printer for trace messages + + (state,dbs) <- withTiming dflags (text "initializing unit database") + forceUnitInfoMap + (mkUnitState ctx printer (initUnitConfig dflags)) + + dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Module Map" + FormatText (pprModuleMap (moduleNameProvidersMap state)) + + let dflags' = dflags + { unitDatabases = Just dbs -- databases are cached and never read again + , unitState = state + } + dflags'' = upd_wired_in_home_instantiations dflags' + + return dflags'' + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId] +readUnitDatabases printer cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readUnitDatabase printer cfg) confs + + +getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | not (null path) && isSearchPathSeparator (last path) + -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (splitSearchPath path) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg) +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOs cfg) + let pkgconf = dir unitConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return pkgconf else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +readUnitDatabase :: (Int -> SDoc -> IO ()) -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) +readUnitDatabase printer cfg conf_file = do + isdir <- doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = dropTrailingPathSeparator conf_file + top_dir = unitConfigGHCDir cfg + pkgroot = takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo) + proto_pkg_configs + -- + return $ UnitDatabase conf_file' pkg_configs1 + where + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir "package.cache" + cache_exists <- doesFileExist filename + if cache_exists + then do + printer 2 $ text "Using binary package database:" <+> text filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + printer 2 $ text "There is no package.cache in" + <+> text conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . isSuffixOf ".conf") + <$> getDirectoryContents conf_dir + if db_empty + then do + printer 3 $ text "There are no .conf files in" + <+> text conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else do + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile conf_file `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file <.> "d" + direxists <- doesDirectoryExist conf_dir + if direxists + then do printer 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +distrustAllUnits :: [UnitInfo] -> [UnitInfo] +distrustAllUnits pkgs = map distrust pkgs + where + distrust pkg = pkg{ unitIsTrusted = False } + +mungeUnitInfo :: FilePath -> FilePath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeDynLibFields + . mungeUnitInfoPaths top_dir pkgroot + +mungeDynLibFields :: UnitInfo -> UnitInfo +mungeDynLibFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- ----------------------------------------------------------------------------- +-- Modify our copy of the unit database based on trust flags, +-- -trust and -distrust. + +applyTrustFlag + :: SDocContext + -> UnitPrecedenceMap + -> UnusableUnits + -> [UnitInfo] + -> TrustFlag + -> IO [UnitInfo] +applyTrustFlag ctx prec_map unusable pkgs flag = + case flag of + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr ctx flag ps + Right (ps,qs) -> return (map trust ps ++ qs) + where trust p = p {unitIsTrusted=True} + + DistrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr ctx flag ps + Right (ps,qs) -> return (distrustAllUnits ps ++ qs) + +-- | A little utility to tell if the home unit is indefinite +-- (if it is not, we should never use on-the-fly renaming.) +homeUnitIsIndefinite :: DynFlags -> Bool +homeUnitIsIndefinite dflags = not (homeUnitIsDefinite dflags) + +-- | A little utility to tell if the home unit is definite +-- (if it is, we should never use on-the-fly renaming.) +homeUnitIsDefinite :: DynFlags -> Bool +homeUnitIsDefinite dflags = unitIsDefinite (homeUnit dflags) + +applyPackageFlag + :: SDocContext + -> UnitPrecedenceMap + -> UnitInfoMap + -> PreloadUnitClosure + -> UnusableUnits + -> Bool -- if False, if you expose a package, it implicitly hides + -- any previously exposed packages with the same name + -> [UnitInfo] + -> VisibilityMap -- Initially exposed + -> PackageFlag -- flag to apply + -> IO VisibilityMap -- Now exposed + +applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm flag = + case flag of + ExposePackage _ arg (ModRenaming b rns) -> + case findPackages prec_map pkg_map closure arg pkgs unusable of + Left ps -> packageFlagErr ctx flag ps + Right (p:_) -> return vm' + where + n = fsPackageName p + + -- If a user says @-unit-id p[A=]@, this imposes + -- a requirement on us: whatever our signature A is, + -- it must fulfill all of p[A=]:A's requirements. + -- This method is responsible for computing what our + -- inherited requirements are. + reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid + | otherwise = Map.empty + + collectHoles uid = case uid of + HoleUnit -> Map.empty + RealUnit {} -> Map.empty -- definite units don't have holes + VirtUnit indef -> + let local = [ Map.singleton + (moduleName mod) + (Set.singleton $ Module indef mod_name) + | (mod_name, mod) <- instUnitInsts indef + , isHoleModule mod ] + recurse = [ collectHoles (moduleUnit mod) + | (_, mod) <- instUnitInsts indef ] + in Map.unionsWith Set.union $ local ++ recurse + + uv = UnitVisibility + { uv_expose_all = b + , uv_renamings = rns + , uv_package_name = First (Just n) + , uv_requirements = reqs + , uv_explicit = True + } + vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared + -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` + -- (or if p-0.1 was registered in the pkgdb as exposed: True), + -- the second package flag would override the first one and you + -- would only see p-0.2 in exposed modules. This is good for + -- usability. + -- + -- However, with thinning and renaming (or Backpack), there might be + -- situations where you legitimately want to see two versions of a + -- package at the same time, and this behavior would make it + -- impossible to do so. So we decided that if you pass + -- -hide-all-packages, this should turn OFF the overriding behavior + -- where an exposed package hides all other packages with the same + -- name. This should not affect Cabal at all, which only ever + -- exposes one package at a time. + -- + -- NB: Why a variable no_hide_others? We have to apply this logic to + -- -plugin-package too, and it's more consistent if the switch in + -- behavior is based off of + -- -hide-all-packages/-hide-all-plugin-packages depending on what + -- flag is in question. + vm_cleared | no_hide_others = vm + -- NB: renamings never clear + | (_:_) <- rns = vm + | otherwise = Map.filterWithKey + (\k uv -> k == mkUnit p + || First (Just n) /= uv_package_name uv) vm + _ -> panic "applyPackageFlag" + + HidePackage str -> + case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of + Left ps -> packageFlagErr ctx flag ps + Right ps -> return vm' + where vm' = foldl' (flip Map.delete) vm (map mkUnit ps) + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: UnitPrecedenceMap + -> UnitInfoMap + -> PreloadUnitClosure + -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + [UnitInfo] +findPackages prec_map pkg_map closure arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (Map.elems unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if str == unitPackageIdString p || str == unitPackageNameString p + then Just p + else Nothing + finder (UnitIdArg uid) p + = case uid of + RealUnit (Definite iuid) + | iuid == unitId p + -> Just p + VirtUnit inst + | indefUnit (instUnitInstanceOf inst) == unitId p + -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p) + _ -> Nothing + +selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- | Rename a 'UnitInfo' according to some module instantiation. +renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map closure insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map closure hsubst + new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) + in conf { + unitInstantiations = new_insts, + unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (unitExposedModules conf) + } + + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- Map.lookup (unitId pkg) prec_map + , Just prec' <- Map.lookup (unitId pkg') prec_map + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +comparing :: Ord a => (t -> a) -> t -> t -> Ordering +comparing f a b = f a `compare` f b + +packageFlagErr :: SDocContext + -> PackageFlag + -> [(UnitInfo, UnusableUnitReason)] + -> IO a +packageFlagErr ctx flag reasons + = packageFlagErr' ctx (pprFlag flag) reasons + +trustFlagErr :: SDocContext + -> TrustFlag + -> [(UnitInfo, UnusableUnitReason)] + -> IO a +trustFlagErr ctx flag reasons + = packageFlagErr' ctx (pprTrustFlag flag) reasons + +packageFlagErr' :: SDocContext + -> SDoc + -> [(UnitInfo, UnusableUnitReason)] + -> IO a +packageFlagErr' ctx flag_doc reasons + = throwGhcExceptionIO (CmdLineError (renderWithStyle ctx $ err)) + where err = text "cannot satisfy " <> flag_doc <> + (if null reasons then Outputable.empty else text ": ") $$ + nest 4 (ppr_reasons $$ + text "(use -v for more information)") + ppr_reasons = vcat (map ppr_reason reasons) + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Module + +type WiringMap = Map UnitId UnitId + +findWiredInUnits + :: (SDoc -> IO ()) -- debug trace + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO ([UnitInfo], -- unit database updated for wired in + WiringMap) -- map from unit id to wired identity + +findWiredInUnits printer prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Module + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = + let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = + [ p | p <- all_ps + , Map.member (mkUnit p) vis_map ] in + case all_exposed_ps of + [] -> case all_ps of + [] -> notfound + many -> pick (head (sortByPreference prec_map many)) + many -> pick (head (sortByPreference prec_map many)) + where + notfound = do + printer $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo)) + pick pkg = do + printer $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (Just (wired_pkg, pkg)) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: Map UnitId UnitId + wiredInMap = Map.fromList + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs + where upd_pkg pkg + | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap + = pkg { unitId = wiredInUnitId + , unitInstanceOf = fmap (const wiredInUnitId) (unitInstanceOf pkg) + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About Units] in GHC.Unit + } + | otherwise + = pkg + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + + + return (updateWiredInDependencies pkgs, wiredInMap) + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Module. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +-- | Some wired units can be used to instantiate the home unit. We need to +-- replace their unit keys with their wired unit ids. +upd_wired_in_home_instantiations :: DynFlags -> DynFlags +upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations = wiredInsts } + where + state = unitState dflags + wiringMap = wireMap state + unwiredInsts = homeUnitInstantiations dflags + wiredInsts = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts + + +upd_wired_in_mod :: WiringMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiringMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WiringMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- Map.lookup key wiredInMap = key' + | otherwise = key + +updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) + where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of + Nothing -> vm + Just r -> Map.insert (RealUnit (Definite to)) r + (Map.delete (RealUnit (Definite from)) vm) + + +-- ---------------------------------------------------------------------------- + +-- | The reason why a unit is unusable. +data UnusableUnitReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This unit transitively depends on a unit that was never present + -- in any of the provided databases. + | BrokenDependencies [UnitId] + -- | This unit transitively depends on a unit involved in a cycle. + -- Note that the list of 'UnitId' reports the direct dependencies + -- of this unit that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [UnitId] + -- | This unit transitively depends on a unit which was ignored. + | IgnoredDependencies [UnitId] + -- | This unit transitively depends on a unit which was + -- shadowed by an ABI-incompatible unit. + | ShadowedDependencies [UnitId] + +instance Outputable UnusableUnitReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +type UnusableUnits = Map UnitId (UnitInfo, UnusableUnitReason) + +pprReason :: SDoc -> UnusableUnitReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportCycles :: (SDoc -> IO ()) -> [SCC UnitInfo] -> IO () +reportCycles printer sccs = mapM_ report sccs + where + report (AcyclicSCC _) = return () + report (CyclicSCC vs) = + printer $ + text "these packages are involved in a cycle:" $$ + nest 2 (hsep (map (ppr . unitId) vs)) + +reportUnusable :: (SDoc -> IO ()) -> UnusableUnits -> IO () +reportUnusable printer pkgs = mapM_ report (Map.toList pkgs) + where + report (ipid, (_, reason)) = + printer $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = Map UnitId [UnitId] + +-- | Compute the reverse dependency index of a unit database. +reverseDeps :: UnitInfoMap -> RevIndex +reverseDeps db = Map.foldl' go Map.empty db + where + go r pkg = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = Map.insertWith (++) to [from] r + +-- | Given a list of 'UnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those units, plus any units which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removeUnits :: [UnitId] -> RevIndex + -> UnitInfoMap + -> (UnitInfoMap, [UnitInfo]) +removeUnits uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- Map.lookup uid m + = case Map.lookup uid index of + Nothing -> go uids (Map.delete uid m, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' +-- which correspond to units that do not exist in the index. +depsNotAvailable :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepends pkg) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in +-- 'unitAbiDepends' which correspond to units that do not exist, OR have +-- mismatching ABIs. +depsAbiMismatch :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- Map.lookup dep_uid pkg_map + = unitAbiHash dep_pkg == abi + | otherwise + = False + +-- ----------------------------------------------------------------------------- +-- Ignore units + +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits +ignoreUnits flags pkgs = Map.fromList (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing unit is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each unit, a mapping from uid -> i indicates that this +-- unit was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- units that were defined later on the command line, if there +-- is an ambiguity. +type UnitPrecedenceMap = Map UnitId Int + +-- | Given a list of databases, merge them together, where +-- units with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: (SDoc -> IO ()) -> [UnitDatabase UnitId] + -> IO (UnitInfoMap, UnitPrecedenceMap) +mergeDatabases printer = foldM merge (Map.empty, Map.empty) . zip [1..] + where + merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do + printer $ + text "loading package database" <+> text db_path + forM_ (Set.toList override_set) $ \pkg -> + printer $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set UnitId + override_set = Set.intersection (Map.keysSet db_map) + (Map.keysSet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: UnitInfoMap + pkg_map' = Map.union db_map pkg_map + + prec_map' :: UnitPrecedenceMap + prec_map' = Map.union (Map.map (const i) db_map) prec_map + +-- | Validates a database, removing unusable units from it +-- (this includes removing units that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken units (dangling dependencies) +-- 2. Remove all units that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all units which have deps with mismatching ABIs +-- +validateDatabase :: UnitConfig -> UnitInfoMap + -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) +validateDatabase cfg pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse (unitConfigFlagsIgnored cfg) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids ] + + -- Find broken units + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (Map.elems pkg_map1) + (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive units + sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) + | pkg <- Map.elems pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignoreUnits ignore_flags (Map.elems pkg_map3) + (pkg_map4, ignored) = removeUnits (Map.keys directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out units whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (Map.elems pkg_map4) + (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + unusable = directly_ignored `Map.union` unusable_ignored + `Map.union` unusable_broken + `Map.union` unusable_cyclic + `Map.union` unusable_shadowed + +-- ----------------------------------------------------------------------------- +-- When all the command-line options are in, we can process our unit +-- settings and populate the unit state. + +mkUnitState + :: SDocContext -- ^ SDocContext used to render exception messages + -> (Int -> SDoc -> IO ()) -- ^ Trace printer + -> UnitConfig + -> IO (UnitState,[UnitDatabase UnitId]) +mkUnitState ctx printer cfg = do +{- + Plan. + + There are two main steps for making the package state: + + 1. We want to build a single, unified package database based + on all of the input databases, which upholds the invariant that + there is only one package per any UnitId and there are no + dangling dependencies. We'll do this by merging, and + then successively filtering out bad dependencies. + + a) Merge all the databases together. + If an input database defines unit ID that is already in + the unified database, that package SHADOWS the existing + package in the current unified database. Note that + order is important: packages defined later in the list of + command line arguments shadow those defined earlier. + + b) Remove all packages with missing dependencies, or + mutually recursive dependencies. + + b) Remove packages selected by -ignore-package from input database + + c) Remove all packages which depended on packages that are now + shadowed by an ABI-incompatible package + + d) report (with -v) any packages that were removed by steps 1-3 + + 2. We want to look at the flags controlling package visibility, + and build a mapping of what module names are in scope and + where they live. + + a) on the final, unified database, we apply -trust/-distrust + flags directly, modifying the database so that the 'trusted' + field has the correct value. + + b) we use the -package/-hide-package flags to compute a + visibility map, stating what packages are "exposed" for + the purposes of computing the module map. + * if any flag refers to a package which was removed by 1-5, then + we can give an error message explaining why + * if -hide-all-packages was not specified, this step also + hides packages which are superseded by later exposed packages + * this step is done TWICE if -plugin-package/-hide-all-plugin-packages + are used + + c) based on the visibility map, we pick wired packages and rewrite + them to have the expected unitId. + + d) finally, using the visibility map and the package database, + we build a mapping saying what every in scope module name points to. +-} + + -- if databases have not been provided, read the database flags + raw_dbs <- case unitConfigDBCache cfg of + Nothing -> readUnitDatabases printer cfg + Just dbs -> return dbs + + -- distrust all units if the flag is set + let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } + dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs + | otherwise = raw_dbs + + + -- This, and the other reverse's that you will see, are due to the fact that + -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order + -- than they are on the command line. + let other_flags = reverse (unitConfigFlagsExposed cfg) + printer 2 $ + text "package flags" <+> ppr other_flags + + -- Merge databases together, without checking validity + (pkg_map1, prec_map) <- mergeDatabases (printer 2) dbs + + -- Now that we've merged everything together, prune out unusable + -- packages. + let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + + reportCycles (printer 2) sccs + reportUnusable (printer 2) unusable + + -- Apply trust flags (these flags apply regardless of whether + -- or not packages are visible or not) + pkgs1 <- foldM (applyTrustFlag ctx prec_map unusable) + (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) + let prelim_pkg_db = mkUnitInfoMap pkgs1 + + -- + -- Calculate the initial set of units from package databases, prior to any package flags. + -- + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if unitConfigHideAll cfg + then emptyUDFM + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same package name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + then Map.insert (mkUnit p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = Map.empty, + uv_explicit = False + } + vm + else vm) + Map.empty pkgs1 + + -- + -- Compute a visibility map according to the command-line flags (-package, + -- -hide-package). This needs to know about the unusable packages, since if a + -- user tries to enable an unusable package, we should let them know. + -- + vis_map2 <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable + (unitConfigHideAll cfg) pkgs1) + vis_map1 other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the unit ids of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + (pkgs2, wired_map) <- findWiredInUnits (printer 2) prec_map pkgs1 vis_map2 + let pkg_db = mkUnitInfoMap pkgs2 + + -- Update the visibility map, so we treat wired packages as visible. + let vis_map = updateVisibilityMap wired_map vis_map2 + + let hide_plugin_pkgs = unitConfigHideAllPlugins cfg + plugin_vis_map <- + case unitConfigFlagsPlugins cfg of + -- common case; try to share the old vis_map + [] | not hide_plugin_pkgs -> return vis_map + | otherwise -> return Map.empty + _ -> do let plugin_vis_map1 + | hide_plugin_pkgs = Map.empty + -- Use the vis_map PRIOR to wired in, + -- because otherwise applyPackageFlag + -- won't work. + | otherwise = vis_map2 + plugin_vis_map2 + <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable + hide_plugin_pkgs pkgs1) + plugin_vis_map1 + (reverse (unitConfigFlagsPlugins cfg)) + -- Updating based on wired in packages is mostly + -- good hygiene, because it won't matter: no wired in + -- package has a compiler plugin. + -- TODO: If a wired in package had a compiler plugin, + -- and you tried to pick different wired in packages + -- with the plugin flags and the normal flags... what + -- would happen? I don't know! But this doesn't seem + -- likely to actually happen. + return (updateVisibilityMap wired_map plugin_vis_map2) + + let pkgname_map = foldl' add Map.empty pkgs2 + where add pn_map p + = Map.insert (unitPackageName p) (unitInstanceOf p) pn_map + + -- The explicitUnits accurately reflects the set of units we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = Map.keys vis_map + req_ctx = Map.map (Set.toList) + $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) + + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = Map.keys (Map.filter uv_explicit vis_map) + + -- add default preload units if they can be found in the db + basicLinkedUnits = fmap (RealUnit . Definite) + $ filter (flip Map.member pkg_db) + $ unitConfigAutoLink cfg + preload3 = ordNub $ (basicLinkedUnits ++ preload1) + + -- Close the preload packages with their dependencies + let dep_preload_err = closeUnitDeps pkg_db (zip (map toUnitId preload3) (repeat Nothing)) + dep_preload <- throwErr ctx dep_preload_err + + let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map + mod_map2 = mkUnusableModuleNameProvidersMap unusable + mod_map = Map.union mod_map1 mod_map2 + + -- Force the result to avoid leaking input parameters + let !state = UnitState + { preloadUnits = dep_preload + , explicitUnits = explicit_pkgs + , unitInfoMap = pkg_db + , preloadClosure = emptyUniqSet + , moduleNameProvidersMap = mod_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet plugin_vis_map + , packageNameMap = pkgname_map + , wireMap = wired_map + , unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ] + , requirementContext = req_ctx + , allowVirtualUnits = unitConfigAllowVirtualUnits cfg + } + + return (state, raw_dbs) + +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit' +-- that it was recorded as in the package database. +unwireUnit :: UnitState -> Unit-> Unit +unwireUnit state uid@(RealUnit (Definite def_uid)) = + maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state)) +unwireUnit _ uid = uid + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from ModuleName to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: SDocContext -- ^ SDocContext used to render exception messages + -> UnitConfig + -> UnitInfoMap + -> PreloadUnitClosure + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_map is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_map multiple times to the actual + -- ModuleNameProvidersMap. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + Map.foldlWithKey extend_modmap emptyMap vis_map_extended + where + vis_map_extended = Map.union vis_map {- preferred -} default_vis + + default_vis = Map.fromList + [ (mkUnit pkg, mempty) + | pkg <- Map.elems pkg_map + -- Exclude specific instantiations of an indefinite + -- package + , unitIsIndefinite pkg || null (unitInstantiations pkg) + ] + + emptyMap = Map.empty + setOrigins m os = fmap (const os) m + extend_modmap modmap uid + UnitVisibility { uv_expose_all = b, uv_renamings = rns } + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, Map Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, Map Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (renderWithStyle ctx + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + (pk', m', fromReexportedModules e pkg) + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM ModuleName (Map Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = mkUnit pkg + unit_lookup uid = lookupUnit' (unitConfigAllowVirtualUnits cfg) pkg_map closure uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = unitExposedModules pkg + hidden_mods = unitHiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap unusables = + Map.foldl' extend_modmap Map.empty unusables + where + extend_modmap modmap (pkg, reason) = addListTo modmap bindings + where bindings :: [(ModuleName, Map Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin = ModUnusable reason + pkg_id = mkUnit pkg + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] + + get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin) + get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) + + exposed_mods = unitExposedModules pkg + hidden_mods = unitHiddenModules pkg + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2) + => Map k1 (Map k2 a) + -> [(k1, Map k2 a)] + -> Map k1 (Map k2 a) +addListTo = foldl' merge + where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m + +-- | Create a singleton module mapping +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin +mkModMap pkg mod = Map.singleton (mkModule pkg mod) + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Find all the include directories in these and the preload packages +getUnitIncludePath :: DynFlags -> [UnitId] -> IO [String] +getUnitIncludePath dflags pkgs = + collectIncludeDirs `fmap` getPreloadUnitsAnd dflags pkgs + +collectIncludeDirs :: [UnitInfo] -> [FilePath] +collectIncludeDirs ps = ordNub (filter notNull (concatMap unitIncludeDirs ps)) + +-- | Find all the library paths in these and the preload packages +getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [String] +getUnitLibraryPath dflags pkgs = + collectLibraryPaths dflags `fmap` getPreloadUnitsAnd dflags pkgs + +collectLibraryPaths :: DynFlags -> [UnitInfo] -> [FilePath] +collectLibraryPaths dflags = ordNub . filter notNull + . concatMap (libraryDirsForWay dflags) + +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String]) +getUnitLinkOpts dflags pkgs = + collectLinkOpts dflags `fmap` getPreloadUnitsAnd dflags pkgs + +collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String]) +collectLinkOpts dflags ps = + ( + concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . unitExtDepLibsSys) ps, + concatMap unitLinkerOptions ps + ) +collectArchives :: DynFlags -> UnitInfo -> IO [FilePath] +collectArchives dflags pc = + filterM doesFileExist [ searchPath ("lib" ++ lib ++ ".a") + | searchPath <- searchPaths + , lib <- libs ] + where searchPaths = ordNub . filter notNull . libraryDirsForWay dflags $ pc + libs = packageHsLibs dflags pc ++ unitExtDepLibsSys pc + +getLibs :: DynFlags -> [UnitId] -> IO [(String,String)] +getLibs dflags pkgs = do + ps <- getPreloadUnitsAnd dflags pkgs + fmap concat . forM ps $ \p -> do + let candidates = [ (l f, f) | l <- collectLibraryPaths dflags [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] + filterM (doesFileExist . fst) candidates + +packageHsLibs :: DynFlags -> UnitInfo -> [String] +packageHsLibs dflags p = map (mkDynName . addSuffix) (unitLibraries p) + where + ways0 = ways dflags + + ways1 = Set.filter (/= WayDyn) ways0 + -- the name of a shared library is libHSfoo-ghc.so + -- we leave out the _dyn, because it is superfluous + + -- debug and profiled RTSs include support for -eventlog + ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1 + = Set.filter (/= WayEventLog) ways1 + | otherwise + = ways1 + + tag = waysTag (Set.filter (not . wayRTSOnly) ways2) + rts_tag = waysTag ways2 + + mkDynName x + | WayDyn `Set.notMember` ways dflags = x + | "HS" `isPrefixOf` x = + x ++ '-':programName dflags ++ projectVersion dflags + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | otherwise + = panic ("Don't understand library name " ++ x) + + -- Add _thr and other rts suffixes to packages named + -- `rts` or `rts-1.0`. Why both? Traditionally the rts + -- package is called `rts` only. However the tooling + -- usually expects a package name to have a version. + -- As such we will gradually move towards the `rts-1.0` + -- package name, at which point the `rts` package name + -- will eventually be unused. + -- + -- This change elevates the need to add custom hooks + -- and handling specifically for the `rts` package for + -- example in ghc-cabal. + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0.2"= rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) + + expandTag t | null t = "" + | otherwise = '_':t + +-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. +libraryDirsForWay :: DynFlags -> UnitInfo -> [String] +libraryDirsForWay dflags + | WayDyn `elem` ways dflags = unitLibraryDynDirs + | otherwise = unitLibraryDirs + +-- | Find all the C-compiler options in these and the preload packages +getUnitExtraCcOpts :: DynFlags -> [UnitId] -> IO [String] +getUnitExtraCcOpts dflags pkgs = do + ps <- getPreloadUnitsAnd dflags pkgs + return (concatMap unitCcOptions ps) + +-- | Find all the package framework paths in these and the preload packages +getUnitFrameworkPath :: DynFlags -> [UnitId] -> IO [String] +getUnitFrameworkPath dflags pkgs = do + ps <- getPreloadUnitsAnd dflags pkgs + return (ordNub (filter notNull (concatMap unitExtDepFrameworkDirs ps))) + +-- | Find all the package frameworks in these and the preload packages +getUnitFrameworks :: DynFlags -> [UnitId] -> IO [String] +getUnitFrameworks dflags pkgs = do + ps <- getPreloadUnitsAnd dflags pkgs + return (concatMap unitExtDepFrameworks ps) + +-- ----------------------------------------------------------------------------- +-- Package Utils + +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllUnits :: UnitState + -> ModuleName + -> [(Module, UnitInfo)] +lookupModuleInAllUnits pkgs m + = case lookupModuleWithSuggestions pkgs m Nothing of + LookupFound a b -> [(a,fst b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs + (moduleUnit m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module (UnitInfo, ModuleOrigin) + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | No modules found, but there were some unusable ones with + -- an exact name match + | LookupUnusable [(Module, ModuleOrigin)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: UnitState + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions pkgs + = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) + +-- | The package which the module **appears** to come from, this could be +-- the one which reexports the module from it's original package. This function +-- is currently only used for -Wunused-packages +lookupModulePackage :: UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo] +lookupModulePackage pkgs mn mfs = + case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of + LookupFound _ (orig_unit, origin) -> + case origin of + ModOrigin {fromOrigUnit, fromExposedReexport} -> + case fromOrigUnit of + -- Just True means, the import is available from its original location + Just True -> + pure [orig_unit] + -- Otherwise, it must be available from a reexport + _ -> pure fromExposedReexport + + _ -> Nothing + + _ -> Nothing + +lookupPluginModuleWithSuggestions :: UnitState + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupPluginModuleWithSuggestions pkgs + = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs) + +lookupModuleWithSuggestions' :: UnitState + -> ModuleNameProvidersMap + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions' pkgs mod_map m mb_pn + = case Map.lookup m mod_map of + Nothing -> LookupNotFound suggestions + Just xs -> + case foldl' classify ([],[],[], []) (Map.toList xs) of + ([], [], [], []) -> LookupNotFound suggestions + (_, _, _, [(m, o)]) -> LookupFound m (mod_unit m, o) + (_, _, _, exposed@(_:_)) -> LookupMultiple exposed + ([], [], unusable@(_:_), []) -> LookupUnusable unusable + (hidden_pkg, hidden_mod, _, []) -> + LookupHidden hidden_pkg hidden_mod + where + classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_unit m) origin0 + x = (m, origin) + in case origin of + ModHidden + -> (hidden_pkg, x:hidden_mod, unusable, exposed) + ModUnusable _ + -> (hidden_pkg, hidden_mod, x:unusable, exposed) + _ | originEmpty origin + -> (hidden_pkg, hidden_mod, unusable, exposed) + | originVisible origin + -> (hidden_pkg, hidden_mod, unusable, x:exposed) + | otherwise + -> (x:hidden_pkg, hidden_mod, unusable, exposed) + + unit_lookup p = lookupUnit pkgs p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) + mod_unit = unit_lookup . moduleUnit + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> UnitInfo + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + filterOrigin (Just pn) pkg o = + case o of + ModHidden -> if go pkg then ModHidden else mempty + (ModUnusable _) -> if go pkg then o else mempty + ModOrigin { fromOrigUnit = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin { + fromOrigUnit = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg + + suggestions = fuzzyLookup (moduleNameString m) all_mods + + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleNameProvidersMap pkgs) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: UnitState -> [ModuleName] +listVisibleModuleNames state = + map fst (filter visible (Map.toList (moduleNameProvidersMap state))) + where visible (_, ms) = any originVisible (Map.elems ms) + +-- | Lookup 'UnitInfo' for every preload unit, for every unit used to +-- instantiate the current unit, and for every unit explicitly passed in the +-- given list of UnitId. +getPreloadUnitsAnd :: DynFlags -> [UnitId] -> IO [UnitInfo] +getPreloadUnitsAnd dflags ids0 = + let + ids = ids0 ++ + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + if homeUnitIsIndefinite dflags + then [] + else map (toUnitId . moduleUnit . snd) + (homeUnitInstantiations dflags) + state = unitState dflags + pkg_map = unitInfoMap state + preload = preloadUnits state + ctx = initSDocContext dflags defaultUserStyle + in do + all_pkgs <- throwErr ctx (closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing)) + return (map (unsafeLookupUnitId state) all_pkgs) + +throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a +throwErr ctx m = case m of + Failed e -> throwGhcExceptionIO (CmdLineError (renderWithStyle ctx e)) + Succeeded r -> return r + +-- | Takes a list of UnitIds (and their "parent" dependency, used for error +-- messages), and returns the list with dependencies included, in reverse +-- dependency order (a units appears before those it depends on). +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId] +closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps + +-- | Similar to closeUnitDeps but takes a list of already loaded units as an +-- additional argument. +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId] +closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps + +-- | Add a UnitId and those it depends on (recursively) to the given list of +-- UnitIds if they are not already in it. Return a list in reverse dependency +-- order (a unit appears before those it depends on). +-- +-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). +-- It it's not found, the optional parent unit is used to return a more precise +-- error message ("dependency of "). +add_unit :: UnitInfoMap + -> [UnitId] + -> (UnitId,Maybe UnitId) + -> MaybeErr MsgDoc [UnitId] +add_unit pkg_map ps (p, mb_parent) + | p `elem` ps = return ps -- Check if we've already added this unit + | otherwise = case lookupUnitId' pkg_map p of + Nothing -> Failed $ + (ftext (fsLit "unknown package:") <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + Just info -> do + -- Add the unit's dependents also + ps' <- foldM add_unit_key ps (unitDepends info) + return (p : ps') + where + add_unit_key ps key + = add_unit pkg_map ps (key, Just p) + +-- ----------------------------------------------------------------------------- + +-- Cabal packages may contain several components (programs, libraries, etc.). +-- As far as GHC is concerned, installed package components ("units") are +-- identified by an opaque IndefUnitId string provided by Cabal. As the string +-- contains a hash, we don't want to display it to users so GHC queries the +-- database to retrieve some infos about the original source package (name, +-- version, component name). +-- +-- Instead we want to display: packagename-version[:componentname] +-- +-- Component name is only displayed if it isn't the default library +-- +-- To do this we need to query the database (cached in DynFlags). We cache +-- these details in the IndefUnitId itself because we don't want to query +-- DynFlags each time we pretty-print the IndefUnitId +-- +mkIndefUnitId :: UnitState -> FastString -> IndefUnitId +mkIndefUnitId pkgstate raw = + let uid = UnitId raw + in case lookupUnitId pkgstate uid of + Nothing -> Indefinite uid Nothing -- we didn't find the unit at all + Just c -> Indefinite uid $ Just $ mkUnitPprInfo c + +-- | Update component ID details from the database +updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId +updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (unitIdFS (indefUnit uid)) + + +displayUnitId :: UnitState -> UnitId -> Maybe String +displayUnitId pkgstate uid = + fmap unitPackageIdString (lookupUnitId pkgstate uid) + +-- ----------------------------------------------------------------------------- +-- Displaying packages + +-- | Show (very verbose) package info +pprUnits :: UnitState -> SDoc +pprUnits = pprUnitsWith pprUnitInfo + +pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc +pprUnitsWith pprIPI pkgstate = + vcat (intersperse (text "---") (map pprIPI (listUnitInfo pkgstate))) + +-- | Show simplified unit info. +-- +-- The idea is to only print package id, and any information that might +-- be different from the package databases (exposure, trust) +pprUnitsSimple :: UnitState -> SDoc +pprUnitsSimple = pprUnitsWith pprIPI + where pprIPI ipi = let i = unitIdFS (unitId ipi) + e = if unitIsExposed ipi then text "E" else text " " + t = if unitIsTrusted ipi then text "T" else text " " + in e <> t <> text " " <> ftext i + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (Map.toList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: UnitInfo -> FastString +fsPackageName info = fs + where + PackageName fs = unitPackageName info + + +-- | Given a fully instantiated 'InstantiatedUnit', improve it into a +-- 'RealUnit' if we can find it in the package database. +improveUnit :: UnitState -> Unit -> Unit +improveUnit state u = improveUnit' (unitInfoMap state) (preloadClosure state) u + +-- | Given a fully instantiated 'InstantiatedUnit', improve it into a +-- 'RealUnit' if we can find it in the package database. +improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit +improveUnit' _ _ uid@(RealUnit _) = uid -- short circuit +improveUnit' pkg_map closure uid = + -- Do NOT lookup indefinite ones, they won't be useful! + case lookupUnit' False pkg_map closure uid of + Nothing -> uid + Just pkg -> + -- Do NOT improve if the indefinite unit id is not + -- part of the closure unique set. See + -- Note [VirtUnit to RealUnit improvement] + if unitId pkg `elementOfUniqSet` closure + then mkUnit pkg + else uid + +-- | Check the database to see if we already have an installed unit that +-- corresponds to the given 'InstantiatedUnit'. +-- +-- Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged or +-- references a matching installed unit. +-- +-- See Note [VirtUnit to RealUnit improvement] +instUnitToUnit :: UnitState -> InstantiatedUnit -> Unit +instUnitToUnit state iuid = + -- NB: suppose that we want to compare the instantiated + -- unit p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- VirtUnit, they won't compare equal; only + -- after improvement will the equality hold. + improveUnit state $ VirtUnit iuid + + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Substitutes holes in a 'Module'. NOT suitable for being called +-- directly on a 'nameModule', see Note [Representation of module/name variable]. +-- @p[A=\]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; +-- similarly, @\@ maps to @q():A@. +renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module +renameHoleModule state = renameHoleModule' (unitInfoMap state) (preloadClosure state) + +-- | Substitutes holes in a 'Unit', suitable for renaming when +-- an include occurs; see Note [Representation of module/name variable]. +-- +-- @p[A=\]@ maps to @p[A=\]@ with @A=\@. +renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit +renameHoleUnit state = renameHoleUnit' (unitInfoMap state) (preloadClosure state) + +-- | Like 'renameHoleModule', but requires only 'ClosureUnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleModule' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map closure env m + | not (isHoleModule m) = + let uid = renameHoleUnit' pkg_map closure env (moduleUnit m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = , that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnit, but requires only 'ClosureUnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleUnit' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map closure env uid = + case uid of + (VirtUnit + InstantiatedUnit{ instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + -- Functorially apply the substitution to the instantiation, + -- then check the 'ClosureUnitInfoMap' to see if there is + -- a compiled version of this 'InstantiatedUnit' we can improve to. + -- See Note [VirtUnit to RealUnit improvement] + else improveUnit' pkg_map closure $ + mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map closure env v)) insts) + _ -> uid + +-- | Injects an 'InstantiatedModule' to 'Module' (see also +-- 'instUnitToUnit'. +instModuleToModule :: UnitState -> InstantiatedModule -> Module +instModuleToModule pkgstate (Module iuid mod_name) = + mkModule (instUnitToUnit pkgstate iuid) mod_name + diff --git a/GHC/Unit/State.hs-boot b/GHC/Unit/State.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Unit/State.hs-boot @@ -0,0 +1,13 @@ +module GHC.Unit.State where + +import GHC.Prelude +import GHC.Data.FastString +import {-# SOURCE #-} GHC.Unit.Types (IndefUnitId, UnitId) + +data UnitState +data UnitDatabase unit + +emptyUnitState :: UnitState +mkIndefUnitId :: UnitState -> FastString -> IndefUnitId +displayUnitId :: UnitState -> UnitId -> Maybe String +updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId diff --git a/GHC/Unit/Types.hs b/GHC/Unit/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Types.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | Unit & Module types +-- +-- This module is used to resolve the loops between Unit and Module types +-- (Module references a Unit and vice-versa). +module GHC.Unit.Types + ( -- * Modules + GenModule (..) + , Module + , InstalledModule + , InstantiatedModule + , mkModule + , pprModule + , pprInstantiatedModule + , moduleFreeHoles + + -- * Units + , GenUnit (..) + , Unit + , UnitId (..) + , GenInstantiatedUnit (..) + , InstantiatedUnit + , IndefUnitId + , DefUnitId + , Instantiations + , GenInstantiations + , mkGenInstantiatedUnit + , mkInstantiatedUnit + , mkInstantiatedUnitHash + , mkGenVirtUnit + , mkVirtUnit + , mapGenUnit + , unitFreeModuleHoles + , fsToUnit + , unitFS + , unitString + , toUnitId + , virtualUnitId + , stringToUnit + , stableUnitCmp + , unitIsDefinite + + -- * Unit Ids + , unitIdString + , stringToUnitId + + -- * Utils + , Definite (..) + , Indefinite (..) + + -- * Wired-in units + , primUnitId + , bignumUnitId + , baseUnitId + , rtsUnitId + , thUnitId + , mainUnitId + , thisGhcUnitId + , interactiveUnitId + + , primUnit + , bignumUnit + , baseUnit + , rtsUnit + , thUnit + , mainUnit + , thisGhcUnit + , interactiveUnit + + , isInteractiveModule + , wiredInUnitIds + + -- * Boot modules + , IsBootInterface (..) + , GenWithIsBoot (..) + , ModuleNameWithIsBoot + , ModuleWithIsBoot + ) +where + +import GHC.Prelude +import GHC.Types.Unique +import GHC.Types.Unique.DSet +import GHC.Unit.Ppr +import GHC.Unit.Module.Name +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.Fingerprint +import GHC.Utils.Misc + +import Control.DeepSeq +import Data.Data +import Data.List (sortBy ) +import Data.Function +import Data.Bifunctor +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.Char8 + +import {-# SOURCE #-} GHC.Unit.State (UnitState,displayUnitId) +import {-# SOURCE #-} GHC.Driver.Session (unitState) + +--------------------------------------------------------------------- +-- MODULES +--------------------------------------------------------------------- + +-- | A generic module is a pair of a unit identifier and a 'ModuleName'. +data GenModule unit = Module + { moduleUnit :: !unit -- ^ Unit the module belongs to + , moduleName :: !ModuleName -- ^ Module name (e.g. A.B.C) + } + deriving (Eq,Ord,Data,Functor) + +-- | A Module is a pair of a 'Unit' and a 'ModuleName'. +type Module = GenModule Unit + +-- | A 'InstalledModule' is a 'Module' whose unit is identified with an +-- 'UnitId'. +type InstalledModule = GenModule UnitId + +-- | An `InstantiatedModule` is a 'Module' whose unit is identified with an `InstantiatedUnit`. +type InstantiatedModule = GenModule InstantiatedUnit + + +mkModule :: u -> ModuleName -> GenModule u +mkModule = Module + +instance Uniquable Module where + getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n) + +instance Binary a => Binary (GenModule a) where + put_ bh (Module p n) = put_ bh p >> put_ bh n + get bh = do p <- get bh; n <- get bh; return (Module p n) + +instance NFData (GenModule a) where + rnf (Module unit name) = unit `seq` name `seq` () + +instance Outputable Module where + ppr = pprModule + +instance Outputable InstalledModule where + ppr (Module p n) = + ppr p <> char ':' <> pprModuleName n + +instance Outputable InstantiatedModule where + ppr = pprInstantiatedModule + +instance Outputable InstantiatedUnit where + ppr uid = + -- getPprStyle $ \sty -> + ppr cid <> + (if not (null insts) -- pprIf + then + brackets (hcat + (punctuate comma $ + [ ppr modname <> text "=" <> pprModule m + | (modname, m) <- insts])) + else empty) + where + cid = instUnitInstanceOf uid + insts = instUnitInsts uid + + +pprModule :: Module -> SDoc +pprModule mod@(Module p n) = getPprStyle doc + where + doc sty + | codeStyle sty = + (if p == mainUnit + then empty -- never qualify the main package in code + else ztext (zEncodeFS (unitFS p)) <> char '_') + <> pprModuleName n + | qualModule sty mod = + case p of + HoleUnit -> angleBrackets (pprModuleName n) + _ -> ppr (moduleUnit mod) <> char ':' <> pprModuleName n + | otherwise = + pprModuleName n + + +pprInstantiatedModule :: InstantiatedModule -> SDoc +pprInstantiatedModule (Module uid m) = + ppr uid <> char ':' <> ppr m + +--------------------------------------------------------------------- +-- UNITS +--------------------------------------------------------------------- + +-- | A unit identifier identifies a (possibly partially) instantiated library. +-- It is primarily used as part of 'Module', which in turn is used in 'Name', +-- which is used to give names to entities when typechecking. +-- +-- There are two possible forms for a 'Unit': +-- +-- 1) It can be a 'RealUnit', in which case we just have a 'DefUnitId' that +-- uniquely identifies some fully compiled, installed library we have on disk. +-- +-- 2) It can be an 'VirtUnit'. When we are typechecking a library with missing +-- holes, we may need to instantiate a library on the fly (in which case we +-- don't have any on-disk representation.) In that case, you have an +-- 'InstantiatedUnit', which explicitly records the instantiation, so that we +-- can substitute over it. +data GenUnit uid + = RealUnit !(Definite uid) + -- ^ Installed definite unit (either a fully instantiated unit or a closed unit) + + | VirtUnit {-# UNPACK #-} !(GenInstantiatedUnit uid) + -- ^ Virtual unit instantiated on-the-fly. It may be definite if all the + -- holes are instantiated but we don't have code objects for it. + + | HoleUnit + -- ^ Fake hole unit + +-- | An instantiated unit. +-- +-- It identifies an indefinite library (with holes) that has been instantiated. +-- +-- This unit may be indefinite or not (i.e. with remaining holes or not). If it +-- is definite, we don't know if it has already been compiled and installed in a +-- database. Nevertheless, we have a mechanism called "improvement" to try to +-- match a fully instantiated unit with existing compiled and installed units: +-- see Note [VirtUnit to RealUnit improvement]. +-- +-- An indefinite unit identifier pretty-prints to something like +-- @p[H=,A=aimpl:A>]@ (@p@ is the 'IndefUnitId', and the +-- brackets enclose the module substitution). +data GenInstantiatedUnit unit + = InstantiatedUnit { + -- | A private, uniquely identifying representation of + -- an InstantiatedUnit. This string is completely private to GHC + -- and is just used to get a unique. + instUnitFS :: !FastString, + -- | Cached unique of 'unitFS'. + instUnitKey :: !Unique, + -- | The indefinite unit being instantiated. + instUnitInstanceOf :: !(Indefinite unit), + -- | The sorted (by 'ModuleName') instantiations of this unit. + instUnitInsts :: !(GenInstantiations unit), + -- | A cache of the free module holes of 'instUnitInsts'. + -- This lets us efficiently tell if a 'InstantiatedUnit' has been + -- fully instantiated (empty set of free module holes) + -- and whether or not a substitution can have any effect. + instUnitHoles :: UniqDSet ModuleName + } + +type Unit = GenUnit UnitId +type InstantiatedUnit = GenInstantiatedUnit UnitId + +type GenInstantiations unit = [(ModuleName,GenModule (GenUnit unit))] +type Instantiations = GenInstantiations UnitId + +holeUnique :: Unique +holeUnique = getUnique holeFS + +holeFS :: FastString +holeFS = fsLit "" + + +instance Eq (GenInstantiatedUnit unit) where + u1 == u2 = instUnitKey u1 == instUnitKey u2 + +instance Ord (GenInstantiatedUnit unit) where + u1 `compare` u2 = instUnitFS u1 `compare` instUnitFS u2 + +instance Binary InstantiatedUnit where + put_ bh indef = do + put_ bh (instUnitInstanceOf indef) + put_ bh (instUnitInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = mkInstantiatedUnitHash cid insts + return InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + +instance Eq Unit where + uid1 == uid2 = unitUnique uid1 == unitUnique uid2 + +instance Uniquable Unit where + getUnique = unitUnique + +instance Ord Unit where + nm1 `compare` nm2 = stableUnitCmp nm1 nm2 + +instance Data Unit where + -- don't traverse? + toConstr _ = abstractConstr "Unit" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Unit" + +instance NFData Unit where + rnf x = x `seq` () + +-- | Compares unit ids lexically, rather than by their 'Unique's +stableUnitCmp :: Unit -> Unit -> Ordering +stableUnitCmp p1 p2 = unitFS p1 `compare` unitFS p2 + +instance Outputable Unit where + ppr pk = pprUnit pk + +pprUnit :: Unit -> SDoc +pprUnit (RealUnit uid) = ppr uid +pprUnit (VirtUnit uid) = ppr uid +pprUnit HoleUnit = ftext holeFS + +instance Show Unit where + show = unitString + +-- Performance: would prefer to have a NameCache like thing +instance Binary Unit where + put_ bh (RealUnit def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (VirtUnit indef_uid) = do + putByte bh 1 + put_ bh indef_uid + put_ bh HoleUnit = do + putByte bh 2 + get bh = do b <- getByte bh + case b of + 0 -> fmap RealUnit (get bh) + 1 -> fmap VirtUnit (get bh) + _ -> pure HoleUnit + +instance Binary unit => Binary (Indefinite unit) where + put_ bh (Indefinite fs _) = put_ bh fs + get bh = do { fs <- get bh; return (Indefinite fs Nothing) } + + + +-- | Retrieve the set of free module holes of a 'Unit'. +unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName +unitFreeModuleHoles (VirtUnit x) = instUnitHoles x +unitFreeModuleHoles (RealUnit _) = emptyUniqDSet +unitFreeModuleHoles HoleUnit = emptyUniqDSet + +-- | Calculate the free holes of a 'Module'. If this set is non-empty, +-- this module was defined in an indefinite library that had required +-- signatures. +-- +-- If a module has free holes, that means that substitutions can operate on it; +-- if it has no free holes, substituting over a module has no effect. +moduleFreeHoles :: GenModule (GenUnit u) -> UniqDSet ModuleName +moduleFreeHoles (Module HoleUnit name) = unitUniqDSet name +moduleFreeHoles (Module u _ ) = unitFreeModuleHoles u + + +-- | Create a new 'GenInstantiatedUnit' given an explicit module substitution. +mkGenInstantiatedUnit :: (unit -> FastString) -> Indefinite unit -> GenInstantiations unit -> GenInstantiatedUnit unit +mkGenInstantiatedUnit gunitFS cid insts = + InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = sorted_insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + where + fs = mkGenInstantiatedUnitHash gunitFS cid sorted_insts + sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts + +-- | Create a new 'InstantiatedUnit' given an explicit module substitution. +mkInstantiatedUnit :: IndefUnitId -> Instantiations -> InstantiatedUnit +mkInstantiatedUnit = mkGenInstantiatedUnit unitIdFS + + +-- | Smart constructor for instantiated GenUnit +mkGenVirtUnit :: (unit -> FastString) -> Indefinite unit -> [(ModuleName, GenModule (GenUnit unit))] -> GenUnit unit +mkGenVirtUnit _gunitFS uid [] = RealUnit $ Definite (indefUnit uid) -- huh? indefinite unit without any instantiation/hole? +mkGenVirtUnit gunitFS uid insts = VirtUnit $ mkGenInstantiatedUnit gunitFS uid insts + +-- | Smart constructor for VirtUnit +mkVirtUnit :: IndefUnitId -> Instantiations -> Unit +mkVirtUnit = mkGenVirtUnit unitIdFS + +-- | Generate a uniquely identifying hash (internal unit-id) for an instantiated +-- unit. +-- +-- This is a one-way function. If the indefinite unit has not been instantiated at all, we return its unit-id. +-- +-- This hash is completely internal to GHC and is not used for symbol names or +-- file paths. It is different from the hash Cabal would produce for the same +-- instantiated unit. +mkGenInstantiatedUnitHash :: (unit -> FastString) -> Indefinite unit -> [(ModuleName, GenModule (GenUnit unit))] -> FastString +mkGenInstantiatedUnitHash gunitFS cid sorted_holes = + mkFastStringByteString + . fingerprintUnitId (bytesFS (gunitFS (indefUnit cid))) + $ hashInstantiations gunitFS sorted_holes + +mkInstantiatedUnitHash :: IndefUnitId -> Instantiations -> FastString +mkInstantiatedUnitHash = mkGenInstantiatedUnitHash unitIdFS + +-- | Generate a hash for a sorted module instantiation. +hashInstantiations :: (unit -> FastString) -> [(ModuleName, GenModule (GenUnit unit))] -> Fingerprint +hashInstantiations gunitFS sorted_holes = + fingerprintByteString + . BS.concat $ do + (m, b) <- sorted_holes + [ bytesFS (moduleNameFS m), BS.Char8.singleton ' ', + bytesFS (genUnitFS gunitFS (moduleUnit b)), BS.Char8.singleton ':', + bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n'] + +fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString +fingerprintUnitId prefix (Fingerprint a b) + = BS.concat + $ [ prefix + , BS.Char8.singleton '-' + , BS.Char8.pack (toBase62Padded a) + , BS.Char8.pack (toBase62Padded b) ] + +unitUnique :: Unit -> Unique +unitUnique (VirtUnit x) = instUnitKey x +unitUnique (RealUnit (Definite x)) = getUnique x +unitUnique HoleUnit = holeUnique + +unitFS :: Unit -> FastString +unitFS = genUnitFS unitIdFS + +genUnitFS :: (unit -> FastString) -> GenUnit unit -> FastString +genUnitFS _gunitFS (VirtUnit x) = instUnitFS x +genUnitFS gunitFS (RealUnit (Definite x)) = gunitFS x +genUnitFS _gunitFS HoleUnit = holeFS + +-- | Create a new simple unit identifier from a 'FastString'. Internally, +-- this is primarily used to specify wired-in unit identifiers. +fsToUnit :: FastString -> Unit +fsToUnit = RealUnit . Definite . UnitId + +unitString :: Unit -> String +unitString = unpackFS . unitFS + +stringToUnit :: String -> Unit +stringToUnit = fsToUnit . mkFastString + +-- | Map over the unit type of a 'GenUnit' +mapGenUnit :: (u -> v) -> (v -> FastString) -> GenUnit u -> GenUnit v +mapGenUnit f gunitFS = go + where + go gu = case gu of + HoleUnit -> HoleUnit + RealUnit d -> RealUnit (fmap f d) + VirtUnit i -> + VirtUnit $ mkGenInstantiatedUnit gunitFS + (fmap f (instUnitInstanceOf i)) + (fmap (second (fmap go)) (instUnitInsts i)) + + +-- | Return the UnitId of the Unit. For on-the-fly instantiated units, return +-- the UnitId of the indefinite unit this unit is an instance of. +toUnitId :: Unit -> UnitId +toUnitId (RealUnit (Definite iuid)) = iuid +toUnitId (VirtUnit indef) = indefUnit (instUnitInstanceOf indef) +toUnitId HoleUnit = error "Hole unit" + +-- | Return the virtual UnitId of an on-the-fly instantiated unit. +virtualUnitId :: InstantiatedUnit -> UnitId +virtualUnitId i = UnitId (instUnitFS i) + +-- | A 'Unit' is definite if it has no free holes. +unitIsDefinite :: Unit -> Bool +unitIsDefinite = isEmptyUniqDSet . unitFreeModuleHoles + +--------------------------------------------------------------------- +-- UNIT IDs +--------------------------------------------------------------------- + +-- | A UnitId identifies a built library in a database and is used to generate +-- unique symbols, etc. It's usually of the form: +-- +-- pkgname-1.2:libname+hash +-- +-- These UnitId are provided to us via the @-this-unit-id@ flag. +-- +-- The library in question may be definite or indefinite; if it is indefinite, +-- none of the holes have been filled (we never install partially instantiated +-- libraries as we can cheaply instantiate them on-the-fly, cf VirtUnit). Put +-- another way, an installed unit id is either fully instantiated, or not +-- instantiated at all. +newtype UnitId = + UnitId { + -- | The full hashed unit identifier, including the component id + -- and the hash. + unitIdFS :: FastString + } + +instance Binary UnitId where + put_ bh (UnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (UnitId fs) + +instance Eq UnitId where + uid1 == uid2 = getUnique uid1 == getUnique uid2 + +instance Ord UnitId where + u1 `compare` u2 = unitIdFS u1 `compare` unitIdFS u2 + +instance Uniquable UnitId where + getUnique = getUnique . unitIdFS + +instance Outputable UnitId where + ppr uid = sdocWithDynFlags $ \dflags -> pprUnitId (unitState dflags) uid + +-- | Pretty-print a UnitId +-- +-- In non-debug mode, query the given database to try to print +-- "package-version:component" instead of the raw UnitId +pprUnitId :: UnitState -> UnitId -> SDoc +pprUnitId state uid@(UnitId fs) = getPprDebug $ \debug -> + if debug + then ftext fs + else case displayUnitId state uid of + Just str -> text str + _ -> ftext fs + +-- | A 'DefUnitId' is an 'UnitId' with the invariant that +-- it only refers to a definite library; i.e., one we have generated +-- code for. +type DefUnitId = Definite UnitId + +unitIdString :: UnitId -> String +unitIdString = unpackFS . unitIdFS + +stringToUnitId :: String -> UnitId +stringToUnitId = UnitId . mkFastString + +--------------------------------------------------------------------- +-- UTILS +--------------------------------------------------------------------- + +-- | A definite unit (i.e. without any free module hole) +newtype Definite unit = Definite { unDefinite :: unit } + deriving (Eq, Ord, Functor) + +instance Outputable unit => Outputable (Definite unit) where + ppr (Definite uid) = ppr uid + +instance Binary unit => Binary (Definite unit) where + put_ bh (Definite uid) = put_ bh uid + get bh = do uid <- get bh; return (Definite uid) + + +-- | An 'IndefUnitId' is an 'UnitId' with the invariant that it only +-- refers to an indefinite library; i.e., one that can be instantiated. +type IndefUnitId = Indefinite UnitId + +data Indefinite unit = Indefinite + { indefUnit :: !unit -- ^ Unit identifier + , indefUnitPprInfo :: Maybe UnitPprInfo -- ^ Cache for some unit info retrieved from the DB + } + deriving (Functor) + +instance Eq unit => Eq (Indefinite unit) where + a == b = indefUnit a == indefUnit b + +instance Ord unit => Ord (Indefinite unit) where + compare a b = compare (indefUnit a) (indefUnit b) + + +instance Uniquable unit => Uniquable (Indefinite unit) where + getUnique (Indefinite n _) = getUnique n + +instance Outputable unit => Outputable (Indefinite unit) where + ppr (Indefinite uid Nothing) = ppr uid + ppr (Indefinite uid (Just pprinfo)) = + getPprDebug $ \debug -> + if debug + then ppr uid + else ppr pprinfo + + +--------------------------------------------------------------------- +-- WIRED-IN UNITS +--------------------------------------------------------------------- + +{- +Note [Wired-in units] +~~~~~~~~~~~~~~~~~~~~~ + +Certain packages are known to the compiler, in that we know about certain +entities that reside in these packages, and the compiler needs to +declare static Modules and Names that refer to these packages. Hence +the wired-in packages can't include version numbers in their package UnitId, +since we don't want to bake the version numbers of these packages into GHC. + +So here's the plan. Wired-in units are still versioned as +normal in the packages database, and you can still have multiple +versions of them installed. To the user, everything looks normal. + +However, for each invocation of GHC, only a single instance of each wired-in +package will be recognised (the desired one is selected via +@-package@\/@-hide-package@), and GHC will internally pretend that it has the +*unversioned* 'UnitId', including in .hi files and object file symbols. + +Unselected versions of wired-in packages will be ignored, as will any other +package that depends directly or indirectly on it (much as if you +had used @-ignore-package@). + +The affected packages are compiled with, e.g., @-this-unit-id base@, so that +the symbols in the object files have the unversioned unit id in their name. + +Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. + +-} + +bignumUnitId, primUnitId, baseUnitId, rtsUnitId, + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId + +bignumUnit, primUnit, baseUnit, rtsUnit, + thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit + +primUnitId = UnitId (fsLit "ghc-prim") +bignumUnitId = UnitId (fsLit "ghc-bignum") +baseUnitId = UnitId (fsLit "base") +rtsUnitId = UnitId (fsLit "rts") +thisGhcUnitId = UnitId (fsLit "ghc") +interactiveUnitId = UnitId (fsLit "interactive") +thUnitId = UnitId (fsLit "template-haskell") + +thUnit = RealUnit (Definite thUnitId) +primUnit = RealUnit (Definite primUnitId) +bignumUnit = RealUnit (Definite bignumUnitId) +baseUnit = RealUnit (Definite baseUnitId) +rtsUnit = RealUnit (Definite rtsUnitId) +thisGhcUnit = RealUnit (Definite thisGhcUnitId) +interactiveUnit = RealUnit (Definite interactiveUnitId) + +-- | This is the package Id for the current program. It is the default +-- package Id if you don't specify a package name. We don't add this prefix +-- to symbol names, since there can be only one main package per program. +mainUnitId = UnitId (fsLit "main") +mainUnit = RealUnit (Definite mainUnitId) + +isInteractiveModule :: Module -> Bool +isInteractiveModule mod = moduleUnit mod == interactiveUnit + +wiredInUnitIds :: [UnitId] +wiredInUnitIds = + [ primUnitId + , bignumUnitId + , baseUnitId + , rtsUnitId + , thUnitId + , thisGhcUnitId + ] + +--------------------------------------------------------------------- +-- Boot Modules +--------------------------------------------------------------------- + +-- Note [Boot Module Naming] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why is this section here? After all, these modules are supposed to be about +-- ways of referring to modules, not modules themselves. Well, the "bootness" of +-- a module is in a way part of its name, because 'import {-# SOURCE #-} Foo' +-- references the boot module in particular while 'import Foo' references the +-- regular module. Backpack signatures live in the normal module namespace (no +-- special import), so they don't matter here. When dealing with the modules +-- themselves, however, one should use not 'IsBoot' or conflate signatures and +-- modules in opposition to boot interfaces. Instead, one should use +-- 'DriverPhases.HscSource'. See Note [HscSource types]. + +-- | Indicates whether a module name is referring to a boot interface (hs-boot +-- file) or regular module (hs file). We need to treat boot modules specially +-- when building compilation graphs, since they break cycles. Regular source +-- files and signature files are treated equivalently. +data IsBootInterface = NotBoot | IsBoot + deriving (Eq, Ord, Show, Data) + +instance Binary IsBootInterface where + put_ bh ib = put_ bh $ + case ib of + NotBoot -> False + IsBoot -> True + get bh = do + b <- get bh + return $ case b of + False -> NotBoot + True -> IsBoot + +-- | This data type just pairs a value 'mod' with an IsBootInterface flag. In +-- practice, 'mod' is usually a @Module@ or @ModuleName@'. +data GenWithIsBoot mod = GWIB + { gwib_mod :: mod + , gwib_isBoot :: IsBootInterface + } deriving ( Eq, Ord, Show + , Functor, Foldable, Traversable + ) + +type ModuleNameWithIsBoot = GenWithIsBoot ModuleName + +type ModuleWithIsBoot = GenWithIsBoot Module + +instance Binary a => Binary (GenWithIsBoot a) where + put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do + put_ bh gwib_mod + put_ bh gwib_isBoot + get bh = do + gwib_mod <- get bh + gwib_isBoot <- get bh + pure $ GWIB { gwib_mod, gwib_isBoot } + +instance Outputable a => Outputable (GenWithIsBoot a) where + ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of + IsBoot -> [] + NotBoot -> [text "{-# SOURCE #-}"] diff --git a/GHC/Unit/Types.hs-boot b/GHC/Unit/Types.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Unit/Types.hs-boot @@ -0,0 +1,18 @@ +module GHC.Unit.Types where + +import GHC.Prelude () +import {-# SOURCE #-} GHC.Utils.Outputable +import {-# SOURCE #-} GHC.Unit.Module.Name + +data UnitId +data GenModule unit +data GenUnit uid +data Indefinite unit + +type Module = GenModule Unit +type Unit = GenUnit UnitId +type IndefUnitId = Indefinite UnitId + +moduleName :: GenModule a -> ModuleName +moduleUnit :: GenModule a -> a +pprModule :: Module -> SDoc diff --git a/GHC/Utils/Asm.hs b/GHC/Utils/Asm.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Asm.hs @@ -0,0 +1,21 @@ +-- | Various utilities used in generating assembler. +-- +-- These are used not only by the native code generator, but also by the +-- "GHC.Driver.Pipeline" +module GHC.Utils.Asm + ( sectionType + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable + +-- | Generate a section type (e.g. @\@progbits@). See #13937. +sectionType :: Platform -- ^ Target platform + -> String -- ^ section type + -> SDoc -- ^ pretty assembler fragment +sectionType platform ty = + case platformArch platform of + ArchARM{} -> char '%' <> text ty + _ -> char '@' <> text ty diff --git a/GHC/Utils/Binary.hs b/GHC/Utils/Binary.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Binary.hs @@ -0,0 +1,1518 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module GHC.Utils.Binary + ( {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle, + SymbolTable, Dictionary, + + BinData(..), dataHandle, handleData, + + openBinMem, +-- closeBin, + + seekBin, + tellBin, + castBin, + withBinBuffer, + + writeBinMem, + readBinMem, + + putAt, getAt, + + -- * For writing instances + putByte, + getByte, + + -- * Variable length encodings + putULEB128, + getULEB128, + putSLEB128, + getSLEB128, + + -- * Fixed length encoding + FixedLengthEncoding(..), + + -- * Lazy Binary I/O + lazyGet, + lazyPut, + + -- * User data + UserData(..), getUserData, setUserData, + newReadState, newWriteState, + putDictionary, getDictionary, putFS, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Name (Name) +import GHC.Data.FastString +import GHC.Utils.Panic.Plain +import GHC.Types.Unique.FM +import GHC.Data.FastMutInt +import GHC.Utils.Fingerprint +import GHC.Types.Basic +import GHC.Types.SrcLoc + +import Control.DeepSeq +import Foreign +import Data.Array +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.IORef +import Data.Char ( ord, chr ) +import Data.Time +import Data.List (unfoldr) +import Type.Reflection +import Type.Reflection.Unsafe +import Data.Kind (Type) +import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) +import Control.Monad ( when, (<$!>), unless ) +import System.IO as IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Real ( Ratio(..) ) +import GHC.Serialized +#if MIN_VERSION_base(4,15,0) +import GHC.ForeignPtr ( unsafeWithForeignPtr ) +#endif + +type BinArray = ForeignPtr Word8 + +#if !MIN_VERSION_base(4,15,0) +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif + +--------------------------------------------------------------- +-- BinData +--------------------------------------------------------------- + +data BinData = BinData Int BinArray + +instance NFData BinData where + rnf (BinData sz _) = rnf sz + +instance Binary BinData where + put_ bh (BinData sz dat) = do + put_ bh sz + putPrim bh sz $ \dest -> + unsafeWithForeignPtr dat $ \orig -> + copyBytes dest orig sz + -- + get bh = do + sz <- get bh + dat <- mallocForeignPtrBytes sz + getPrim bh sz $ \orig -> + unsafeWithForeignPtr dat $ \dest -> + copyBytes dest orig sz + return (BinData sz dat) + +dataHandle :: BinData -> IO BinHandle +dataHandle (BinData size bin) = do + ixr <- newFastMutInt + szr <- newFastMutInt + writeFastMutInt ixr 0 + writeFastMutInt szr size + binr <- newIORef bin + return (BinMem noUserData ixr szr binr) + +handleData :: BinHandle -> IO BinData +handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + bh_usr :: UserData, -- sigh, need parameterized modules :-) + _off_r :: !FastMutInt, -- the current offset + _sz_r :: !FastMutInt, -- size of the array (cached) + _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + +-- | Get access to the underlying buffer. +-- +-- It is quite important that no references to the 'ByteString' leak out of the +-- continuation lest terrible things happen. +withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a +withBinBuffer (BinMem _ ix_r _ arr_r) action = do + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \ptr -> + BS.unsafePackCStringLen (castPtr ptr, ix) >>= action + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +-- | Do not rely on instance sizes for general types, +-- we use variable length encoding for many of them. +class Binary a where + put_ :: BinHandle -> a -> IO () + put :: BinHandle -> a -> IO (Bin a) + get :: BinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do _ <- put bh a; return () + put bh a = do p <- tellBin bh; put_ bh a; return p + +putAt :: Binary a => BinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBin bh p; put_ bh x; return () + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinMem :: Int -> IO BinHandle +openBinMem size + | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- mallocForeignPtrBytes size + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem noUserData ix_r sz_r arr_r) + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBin :: BinHandle -> Bin a -> IO () +seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +writeBinMem :: BinHandle -> FilePath -> IO () +writeBinMem (BinMem _ ix_r _ arr_r) fn = do + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix + hClose h + +readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- mallocForeignPtrBytes filesize + count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize + when (count /= filesize) $ + error ("Binary.readBinMem: only read " ++ show count ++ " bytes") + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + return (BinMem noUserData ix_r sz_r arr_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem _ _ sz_r arr_r) !off = do + !sz <- readFastMutInt sz_r + let !sz' = getSize sz + arr <- readIORef arr_r + arr' <- mallocForeignPtrBytes sz' + withForeignPtr arr $ \old -> + withForeignPtr arr' $ \new -> + copyBytes new old sz + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + where + getSize :: Int -> Int + getSize !sz + | sz > off + = sz + | otherwise + = getSize (sz * 2) + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +-- | Takes a size and action writing up to @size@ bytes. +-- After the action has run advance the index to the buffer +-- by size bytes. +putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () +putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + expandBin h (ix + size) + arr <- readIORef arr_r + unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + +-- -- | Similar to putPrim but advances the index by the actual number of +-- -- bytes written. +-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () +-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do +-- ix <- readFastMutInt ix_r +-- sz <- readFastMutInt sz_r +-- when (ix + size > sz) $ +-- expandBin h (ix + size) +-- arr <- readIORef arr_r +-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) +-- writeFastMutInt ix_r (ix + written) + +getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a +getPrim (BinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) + arr <- readIORef arr_r + w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix) + -- This is safe WRT #17760 as we we guarantee that the above line doesn't + -- diverge + writeFastMutInt ix_r (ix + size) + return w + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 h !w = putPrim h 1 (\op -> poke op w) + +getWord8 :: BinHandle -> IO Word8 +getWord8 h = getPrim h 1 peek + +putWord16 :: BinHandle -> Word16 -> IO () +putWord16 h w = putPrim h 2 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) + pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) + ) + +getWord16 :: BinHandle -> IO Word16 +getWord16 h = getPrim h 2 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + return $! w0 `shiftL` 8 .|. w1 + ) + +putWord32 :: BinHandle -> Word32 -> IO () +putWord32 h w = putPrim h 4 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) + ) + +getWord32 :: BinHandle -> IO Word32 +getWord32 h = getPrim h 4 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + + return $! (w0 `shiftL` 24) .|. + (w1 `shiftL` 16) .|. + (w2 `shiftL` 8) .|. + w3 + ) + +putWord64 :: BinHandle -> Word64 -> IO () +putWord64 h w = putPrim h 8 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) + pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) + pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) + ) + +getWord64 :: BinHandle -> IO Word64 +getWord64 h = getPrim h 8 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + w4 <- fromIntegral <$> peekElemOff op 4 + w5 <- fromIntegral <$> peekElemOff op 5 + w6 <- fromIntegral <$> peekElemOff op 6 + w7 <- fromIntegral <$> peekElemOff op 7 + + return $! (w0 `shiftL` 56) .|. + (w1 `shiftL` 48) .|. + (w2 `shiftL` 40) .|. + (w3 `shiftL` 32) .|. + (w4 `shiftL` 24) .|. + (w5 `shiftL` 16) .|. + (w6 `shiftL` 8) .|. + w7 + ) + +putByte :: BinHandle -> Word8 -> IO () +putByte bh !w = putWord8 bh w + +getByte :: BinHandle -> IO Word8 +getByte h = getWord8 h + +-- ----------------------------------------------------------------------------- +-- Encode numbers in LEB128 encoding. +-- Requires one byte of space per 7 bits of data. +-- +-- There are signed and unsigned variants. +-- Do NOT use the unsigned one for signed values, at worst it will +-- result in wrong results, at best it will lead to bad performance +-- when coercing negative values to an unsigned type. +-- +-- We mark them as SPECIALIZE as it's extremely critical that they get specialized +-- to their specific types. +-- +-- TODO: Each use of putByte performs a bounds check, +-- we should use putPrimMax here. However it's quite hard to return +-- the number of bytes written into putPrimMax without allocating an +-- Int for it, while the code below does not allocate at all. +-- So we eat the cost of the bounds check instead of increasing allocations +-- for now. + +-- Unsigned numbers +{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} +putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () +putULEB128 bh w = +#if defined(DEBUG) + (if w < 0 then panic "putULEB128: Signed number" else id) $ +#endif + go w + where + go :: a -> IO () + go w + | w <= (127 :: a) + = putByte bh (fromIntegral w :: Word8) + | otherwise = do + -- bit 7 (8th bit) indicates more to come. + let !byte = setBit (fromIntegral w) 7 :: Word8 + putByte bh byte + go (w `unsafeShiftR` 7) + +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} +getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a +getULEB128 bh = + go 0 0 + where + go :: Int -> a -> IO a + go shift w = do + b <- getByte bh + let !hasMore = testBit b 7 + let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a + if hasMore + then do + go (shift+7) val + else + return $! val + +-- Signed numbers +{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} +putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () +putSLEB128 bh initial = go initial + where + go :: a -> IO () + go val = do + let !byte = fromIntegral (clearBit val 7) :: Word8 + let !val' = val `unsafeShiftR` 7 + let !signBit = testBit byte 6 + let !done = + -- Unsigned value, val' == 0 and last value can + -- be discriminated from a negative number. + ((val' == 0 && not signBit) || + -- Signed value, + (val' == -1 && signBit)) + + let !byte' = if done then byte else setBit byte 7 + putByte bh byte' + + unless done $ go val' + +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} +getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a +getSLEB128 bh = do + (val,shift,signed) <- go 0 0 + if signed && (shift < finiteBitSize val ) + then return $! ((complement 0 `unsafeShiftL` shift) .|. val) + else return val + where + go :: Int -> a -> IO (a,Int,Bool) + go shift val = do + byte <- getByte bh + let !byteVal = fromIntegral (clearBit byte 7) :: a + let !val' = val .|. (byteVal `unsafeShiftL` shift) + let !more = testBit byte 7 + let !shift' = shift+7 + if more + then go (shift') val' + else do + let !signed = testBit byte 6 + return (val',shift',signed) + +-- ----------------------------------------------------------------------------- +-- Fixed length encoding instances + +-- Sometimes words are used to represent a certain bit pattern instead +-- of a number. Using FixedLengthEncoding we will write the pattern as +-- is to the interface file without the variable length encoding we usually +-- apply. + +-- | Encode the argument in it's full length. This is different from many default +-- binary instances which make no guarantee about the actual encoding and +-- might do things use variable length encoding. +newtype FixedLengthEncoding a = FixedLengthEncoding { unFixedLength :: a } + +instance Binary (FixedLengthEncoding Word8) where + put_ h (FixedLengthEncoding x) = putByte h x + get h = FixedLengthEncoding <$> getByte h + +instance Binary (FixedLengthEncoding Word16) where + put_ h (FixedLengthEncoding x) = putWord16 h x + get h = FixedLengthEncoding <$> getWord16 h + +instance Binary (FixedLengthEncoding Word32) where + put_ h (FixedLengthEncoding x) = putWord32 h x + get h = FixedLengthEncoding <$> getWord32 h + +instance Binary (FixedLengthEncoding Word64) where + put_ h (FixedLengthEncoding x) = putWord64 h x + get h = FixedLengthEncoding <$> getWord64 h + +-- ----------------------------------------------------------------------------- +-- Primitive Word writes + +instance Binary Word8 where + put_ bh !w = putWord8 bh w + get = getWord8 + +instance Binary Word16 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word32 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word64 where + put_ = putULEB128 + get = getULEB128 + +-- ----------------------------------------------------------------------------- +-- Primitive Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int32 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int64 where + put_ h w = putSLEB128 h w + get h = getSLEB128 h + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ _ () = return () + get _ = return () + +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) + +instance Binary a => Binary [a] where + put_ bh l = do + let len = length l + put_ bh len + mapM_ (put_ bh) l + get bh = do + len <- get bh :: IO Int -- Int is variable length encoded so only + -- one byte for small lists. + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + put_ bh arr = do + put_ bh $ bounds arr + put_ bh $ elems arr + get bh = do + bounds <- get bh + xs <- get bh + return $ listArray bounds xs + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where + put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where + put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + g <- get bh + return (a,b,c,d,e,f,g) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + +{- +Finally - a reasonable portable Integer instance. + +We used to encode values in the Int32 range as such, +falling back to a string of all things. In either case +we stored a tag byte to discriminate between the two cases. + +This made some sense as it's highly portable but also not very +efficient. + +However GHC stores a surprisingly large number off large Integer +values. In the examples looked at between 25% and 50% of Integers +serialized were outside of the Int32 range. + +Consider a valie like `2724268014499746065`, some sort of hash +actually generated by GHC. +In the old scheme this was encoded as a list of 19 chars. This +gave a size of 77 Bytes, one for the length of the list and 76 +since we encode chars as Word32 as well. + +We can easily do better. The new plan is: + +* Start with a tag byte + * 0 => Int64 (LEB128 encoded) + * 1 => Negative large interger + * 2 => Positive large integer +* Followed by the value: + * Int64 is encoded as usual + * Large integers are encoded as a list of bytes (Word8). + We use Data.Bits which defines a bit order independent of the representation. + Values are stored LSB first. + +This means our example value `2724268014499746065` is now only 10 bytes large. +* One byte tag +* One byte for the length of the [Word8] list. +* 8 bytes for the actual date. + +The new scheme also does not depend in any way on +architecture specific details. + +We still use this scheme even with LEB128 available, +as it has less overhead for truly large numbers. (> maxBound :: Int64) + +The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal +-} + +instance Binary Integer where + put_ bh i + | i >= lo64 && i <= hi64 = do + putWord8 bh 0 + put_ bh (fromIntegral i :: Int64) + | otherwise = do + if i < 0 + then putWord8 bh 1 + else putWord8 bh 2 + put_ bh (unroll $ abs i) + where + lo64 = fromIntegral (minBound :: Int64) + hi64 = fromIntegral (maxBound :: Int64) + get bh = do + int_kind <- getWord8 bh + case int_kind of + 0 -> fromIntegral <$!> (get bh :: IO Int64) + -- Large integer + 1 -> negate <$!> getInt + 2 -> getInt + _ -> panic "Binary Integer - Invalid byte" + where + getInt :: IO Integer + getInt = roll <$!> (get bh :: IO [Word8]) + +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldl' unstep 0 . reverse + where + unstep a b = a `shiftL` 8 .|. fromIntegral b + + + {- + -- This code is currently commented out. + -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for + -- discussion. + + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + putByte bh 1 + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + -} + +{- +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } + +indexByteArray :: ByteArray# -> Int# -> Word8 +indexByteArray a# n# = W8# (indexWord8Array# a# n#) + +-} +instance (Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (Bin a) where + put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) + get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) + +-- ----------------------------------------------------------------------------- +-- Instances for Data.Typeable stuff + +instance Binary TyCon where + put_ bh tc = do + put_ bh (tyConPackage tc) + put_ bh (tyConModule tc) + put_ bh (tyConName tc) + put_ bh (tyConKindArgs tc) + put_ bh (tyConKindRep tc) + get bh = + mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +instance Binary VecCount where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary VecElem where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary RuntimeRep where + put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps + put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps + put_ bh LiftedRep = putByte bh 3 + put_ bh UnliftedRep = putByte bh 4 + put_ bh IntRep = putByte bh 5 + put_ bh WordRep = putByte bh 6 + put_ bh Int64Rep = putByte bh 7 + put_ bh Word64Rep = putByte bh 8 + put_ bh AddrRep = putByte bh 9 + put_ bh FloatRep = putByte bh 10 + put_ bh DoubleRep = putByte bh 11 + put_ bh Int8Rep = putByte bh 12 + put_ bh Word8Rep = putByte bh 13 + put_ bh Int16Rep = putByte bh 14 + put_ bh Word16Rep = putByte bh 15 +#if __GLASGOW_HASKELL__ >= 809 + put_ bh Int32Rep = putByte bh 16 + put_ bh Word32Rep = putByte bh 17 +#endif + + get bh = do + tag <- getByte bh + case tag of + 0 -> VecRep <$> get bh <*> get bh + 1 -> TupleRep <$> get bh + 2 -> SumRep <$> get bh + 3 -> pure LiftedRep + 4 -> pure UnliftedRep + 5 -> pure IntRep + 6 -> pure WordRep + 7 -> pure Int64Rep + 8 -> pure Word64Rep + 9 -> pure AddrRep + 10 -> pure FloatRep + 11 -> pure DoubleRep + 12 -> pure Int8Rep + 13 -> pure Word8Rep + 14 -> pure Int16Rep + 15 -> pure Word16Rep +#if __GLASGOW_HASKELL__ >= 809 + 16 -> pure Int32Rep + 17 -> pure Word32Rep +#endif + _ -> fail "Binary.putRuntimeRep: invalid tag" + +instance Binary KindRep where + put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k + put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr + put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b + put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b + put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r + put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r + + get bh = do + tag <- getByte bh + case tag of + 0 -> KindRepTyConApp <$> get bh <*> get bh + 1 -> KindRepVar <$> get bh + 2 -> KindRepApp <$> get bh <*> get bh + 3 -> KindRepFun <$> get bh <*> get bh + 4 -> KindRepTYPE <$> get bh + 5 -> KindRepTypeLit <$> get bh <*> get bh + _ -> fail "Binary.putKindRep: invalid tag" + +instance Binary TypeLitSort where + put_ bh TypeLitSymbol = putByte bh 0 + put_ bh TypeLitNat = putByte bh 1 + get bh = do + tag <- getByte bh + case tag of + 0 -> pure TypeLitSymbol + 1 -> pure TypeLitNat + _ -> fail "Binary.putTypeLitSort: invalid tag" + +putTypeRep :: BinHandle -> TypeRep a -> IO () +-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind +-- relations. +-- See Note [Mutually recursive representations of primitive types] +putTypeRep bh rep + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) + = put_ bh (0 :: Word8) +putTypeRep bh (Con' con ks) = do + put_ bh (1 :: Word8) + put_ bh con + put_ bh ks +putTypeRep bh (App f x) = do + put_ bh (2 :: Word8) + putTypeRep bh f + putTypeRep bh x +putTypeRep bh (Fun arg res) = do + put_ bh (3 :: Word8) + putTypeRep bh arg + putTypeRep bh res + +getSomeTypeRep :: BinHandle -> IO SomeTypeRep +getSomeTypeRep bh = do + tag <- get bh :: IO Word8 + case tag of + 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) + 1 -> do con <- get bh :: IO TyCon + ks <- get bh :: IO [SomeTypeRep] + return $ SomeTypeRep $ mkTrCon con ks + + 2 -> do SomeTypeRep f <- getSomeTypeRep bh + SomeTypeRep x <- getSomeTypeRep bh + case typeRepKind f of + Fun arg res -> + case arg `eqTypeRep` typeRepKind x of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ mkTrApp f x + _ -> failure "Kind mismatch in type application" [] + _ -> failure "Kind mismatch in type application" + [ " Found argument of kind: " ++ show (typeRepKind x) + , " Where the constructor: " ++ show f + , " Expects kind: " ++ show arg + ] + _ -> failure "Applied non-arrow" + [ " Applied type: " ++ show f + , " To argument: " ++ show x + ] + 3 -> do SomeTypeRep arg <- getSomeTypeRep bh + SomeTypeRep res <- getSomeTypeRep bh + if + | App argkcon _ <- typeRepKind arg + , App reskcon _ <- typeRepKind res + , Just HRefl <- argkcon `eqTypeRep` tYPErep + , Just HRefl <- reskcon `eqTypeRep` tYPErep + -> return $ SomeTypeRep $ Fun arg res + | otherwise -> failure "Kind mismatch" [] + _ -> failure "Invalid SomeTypeRep" [] + where + tYPErep :: TypeRep TYPE + tYPErep = typeRep + + failure description info = + fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] + ++ map (" "++) info + +instance Typeable a => Binary (TypeRep (a :: k)) where + put_ = putTypeRep + get bh = do + SomeTypeRep rep <- getSomeTypeRep bh + case rep `eqTypeRep` expected of + Just HRefl -> pure rep + Nothing -> fail $ unlines + [ "Binary: Type mismatch" + , " Deserialized type: " ++ show rep + , " Expected type: " ++ show expected + ] + where expected = typeRep :: TypeRep a + +instance Binary SomeTypeRep where + put_ bh (SomeTypeRep rep) = putTypeRep bh rep + get = getSomeTypeRep + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => BinHandle -> a -> IO () +lazyPut bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBin bh + put_ bh pre_a -- save a slot for the ptr + put_ bh a -- dump the object + q <- tellBin bh -- q = ptr to after object + putAt bh pre_a q -- fill in slot before a with ptr to q + seekBin bh q -- finally carry on writing at q + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt + getAt bh { _off_r = off_r } p_a + seekBin bh p -- skip over the object for now + return a + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +-- | Information we keep around during interface file +-- serialization/deserialization. Namely we keep the functions for serializing +-- and deserializing 'Name's and 'FastString's. We do this because we actually +-- use serialization in two distinct settings, +-- +-- * When serializing interface files themselves +-- +-- * When computing the fingerprint of an IfaceDecl (which we computing by +-- hashing its Binary serialization) +-- +-- These two settings have different needs while serializing Names: +-- +-- * Names in interface files are serialized via a symbol table (see Note +-- [Symbol table representation of names] in "GHC.Iface.Binary"). +-- +-- * During fingerprinting a binding Name is serialized as the OccName and a +-- non-binding Name is serialized as the fingerprint of the thing they +-- represent. See Note [Fingerprinting IfaceDecls] for further discussion. +-- +data UserData = + UserData { + -- for *deserialising* only: + ud_get_name :: BinHandle -> IO Name, + ud_get_fs :: BinHandle -> IO FastString, + + -- for *serialising* only: + ud_put_nonbinding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a non-binding 'Name' (e.g. a reference to another + -- binding). + ud_put_binding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) + ud_put_fs :: BinHandle -> FastString -> IO () + } + +newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's + -> (BinHandle -> IO FastString) + -> UserData +newReadState get_name get_fs + = UserData { ud_get_name = get_name, + ud_get_fs = get_fs, + ud_put_nonbinding_name = undef "put_nonbinding_name", + ud_put_binding_name = undef "put_binding_name", + ud_put_fs = undef "put_fs" + } + +newWriteState :: (BinHandle -> Name -> IO ()) + -- ^ how to serialize non-binding 'Name's + -> (BinHandle -> Name -> IO ()) + -- ^ how to serialize binding 'Name's + -> (BinHandle -> FastString -> IO ()) + -> UserData +newWriteState put_nonbinding_name put_binding_name put_fs + = UserData { ud_get_name = undef "get_name", + ud_get_fs = undef "get_fs", + ud_put_nonbinding_name = put_nonbinding_name, + ud_put_binding_name = put_binding_name, + ud_put_fs = put_fs + } + +noUserData :: a +noUserData = undef "UserData" + +undef :: String -> a +undef s = panic ("Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed + +putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) + -- It's OK to use nonDetEltsUFM here because the elements have indices + -- that array uses to create order + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- On disk, the symbol table is an array of IfExtName, when +-- reading it in we turn it into a SymbolTable. + +type SymbolTable = Array Int Name + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +putFS :: BinHandle -> FastString -> IO () +putFS bh fs = putBS bh $ bytesFS fs + +getFS :: BinHandle -> IO FastString +getFS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> pure $! mkFastStringBytes src l ) + +putBS :: BinHandle -> ByteString -> IO () +putBS bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + put_ bh l + putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) + +getBS :: BinHandle -> IO ByteString +getBS bh = do + l <- get bh :: IO Int + BS.create l $ \dest -> do + getPrim bh l (\src -> BS.memcpy dest src l) + +instance Binary ByteString where + put_ bh f = putBS bh f + get bh = getBS bh + +instance Binary FastString where + put_ bh f = + case getUserData bh of + UserData { ud_put_fs = put_fs } -> put_fs bh f + + get bh = + case getUserData bh of + UserData { ud_get_fs = get_fs } -> get_fs bh + +-- Here to avoid loop +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + +instance Binary PromotionFlag where + put_ bh NotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return NotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" + +instance Binary Fingerprint where + put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 + get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + +instance Binary FunctionOrData where + put_ bh IsFunction = putByte bh 0 + put_ bh IsData = putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IsFunction + 1 -> return IsData + _ -> panic "Binary FunctionOrData" + +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + +instance Binary Activation where + put_ bh NeverActive = do + putByte bh 0 + put_ bh FinalActive = do + putByte bh 1 + put_ bh AlwaysActive = do + putByte bh 2 + put_ bh (ActiveBefore src aa) = do + putByte bh 3 + put_ bh src + put_ bh aa + put_ bh (ActiveAfter src ab) = do + putByte bh 4 + put_ bh src + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return NeverActive + 1 -> do return FinalActive + 2 -> do return AlwaysActive + 3 -> do src <- get bh + aa <- get bh + return (ActiveBefore src aa) + _ -> do src <- get bh + ab <- get bh + return (ActiveAfter src ab) + +instance Binary InlinePragma where + put_ bh (InlinePragma s a b c d) = do + put_ bh s + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + s <- get bh + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma s a b c d) + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlineSpec where + put_ bh NoUserInline = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return NoUserInline + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary OverlapMode where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +instance Binary FixityDirection where + put_ bh InfixL = do + putByte bh 0 + put_ bh InfixR = do + putByte bh 1 + put_ bh InfixN = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary Fixity where + put_ bh (Fixity src aa ab) = do + put_ bh src + put_ bh aa + put_ bh ab + get bh = do + src <- get bh + aa <- get bh + ab <- get bh + return (Fixity src aa ab) + +instance Binary WarningTxt where + put_ bh (WarningTxt s w) = do + putByte bh 0 + put_ bh s + put_ bh w + put_ bh (DeprecatedTxt s d) = do + putByte bh 1 + put_ bh s + put_ bh d + + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + w <- get bh + return (WarningTxt s w) + _ -> do s <- get bh + d <- get bh + return (DeprecatedTxt s d) + +instance Binary StringLiteral where + put_ bh (StringLiteral st fs) = do + put_ bh st + put_ bh fs + get bh = do + st <- get bh + fs <- get bh + return (StringLiteral st fs) + +instance Binary a => Binary (Located a) where + put_ bh (L l x) = do + put_ bh l + put_ bh x + + get bh = do + l <- get bh + x <- get bh + return (L l x) + +instance Binary RealSrcSpan where + put_ bh ss = do + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + get bh = do + f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) + +instance Binary BufPos where + put_ bh (BufPos i) = put_ bh i + get bh = BufPos <$> get bh + +instance Binary BufSpan where + put_ bh (BufSpan start end) = do + put_ bh start + put_ bh end + get bh = do + start <- get bh + end <- get bh + return (BufSpan start end) + +instance Binary UnhelpfulSpanReason where + put_ bh r = case r of + UnhelpfulNoLocationInfo -> putByte bh 0 + UnhelpfulWiredIn -> putByte bh 1 + UnhelpfulInteractive -> putByte bh 2 + UnhelpfulGenerated -> putByte bh 3 + UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs + + get bh = do + h <- getByte bh + case h of + 0 -> return UnhelpfulNoLocationInfo + 1 -> return UnhelpfulWiredIn + 2 -> return UnhelpfulInteractive + 3 -> return UnhelpfulGenerated + _ -> UnhelpfulOther <$> get bh + +instance Binary SrcSpan where + put_ bh (RealSrcSpan ss sb) = do + putByte bh 0 + put_ bh ss + put_ bh sb + + put_ bh (UnhelpfulSpan s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + sb <- get bh + return (RealSrcSpan ss sb) + _ -> do s <- get bh + return (UnhelpfulSpan s) + +instance Binary Serialized where + put_ bh (Serialized the_type bytes) = do + put_ bh the_type + put_ bh bytes + get bh = do + the_type <- get bh + bytes <- get bh + return (Serialized the_type bytes) + +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h diff --git a/GHC/Utils/BufHandle.hs b/GHC/Utils/BufHandle.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/BufHandle.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- +-- Fast write-buffered Handles +-- +-- (c) The University of Glasgow 2005-2006 +-- +-- This is a simple abstraction over Handles that offers very fast write +-- buffering, but without the thread safety that Handles provide. It's used +-- to save time in GHC.Utils.Ppr.printDoc. +-- +----------------------------------------------------------------------------- + +module GHC.Utils.BufHandle ( + BufHandle(..), + newBufHandle, + bPutChar, + bPutStr, + bPutFS, + bPutFZS, + bPutPtrString, + bPutReplicate, + bFlush, + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import Control.Monad ( when ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BS +import Data.Char ( ord ) +import Foreign +import Foreign.C.String +import System.IO + +-- ----------------------------------------------------------------------------- + +data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) + {-#UNPACK#-}!FastMutInt + Handle + +newBufHandle :: Handle -> IO BufHandle +newBufHandle hdl = do + ptr <- mallocBytes buf_size + r <- newFastMutInt + writeFastMutInt r 0 + return (BufHandle ptr r hdl) + +buf_size :: Int +buf_size = 8192 + +bPutChar :: BufHandle -> Char -> IO () +bPutChar b@(BufHandle buf r hdl) !c = do + i <- readFastMutInt r + if (i >= buf_size) + then do hPutBuf hdl buf buf_size + writeFastMutInt r 0 + bPutChar b c + else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) + writeFastMutInt r (i+1) + +bPutStr :: BufHandle -> String -> IO () +bPutStr (BufHandle buf r hdl) !str = do + i <- readFastMutInt r + loop str i + where loop "" !i = do writeFastMutInt r i; return () + loop (c:cs) !i + | i >= buf_size = do + hPutBuf hdl buf buf_size + loop (c:cs) 0 + | otherwise = do + pokeElemOff buf i (fromIntegral (ord c)) + loop cs (i+1) + +bPutFS :: BufHandle -> FastString -> IO () +bPutFS b fs = bPutBS b $ bytesFS fs + +bPutFZS :: BufHandle -> FastZString -> IO () +bPutFZS b fs = bPutBS b $ fastZStringToByteString fs + +bPutBS :: BufHandle -> ByteString -> IO () +bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b + +bPutCStringLen :: BufHandle -> CStringLen -> IO () +bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do + i <- readFastMutInt r + if (i + len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl ptr len + else bPutCStringLen b cstr + else do + copyBytes (buf `plusPtr` i) ptr len + writeFastMutInt r (i + len) + +bPutPtrString :: BufHandle -> PtrString -> IO () +bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do + i <- readFastMutInt r + if (i+len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl a len + else bPutPtrString b l + else do + copyBytes (buf `plusPtr` i) a len + writeFastMutInt r (i+len) + +-- | Replicate an 8-bit character +bPutReplicate :: BufHandle -> Int -> Char -> IO () +bPutReplicate (BufHandle buf r hdl) len c = do + i <- readFastMutInt r + let oc = fromIntegral (ord c) + if (i+len) < buf_size + then do + fillBytes (buf `plusPtr` i) oc len + writeFastMutInt r (i+len) + else do + -- flush the current buffer + when (i /= 0) $ hPutBuf hdl buf i + if (len < buf_size) + then do + fillBytes buf oc len + writeFastMutInt r len + else do + -- fill a full buffer + fillBytes buf oc buf_size + -- flush it as many times as necessary + let go n | n >= buf_size = do + hPutBuf hdl buf buf_size + go (n-buf_size) + | otherwise = writeFastMutInt r n + go len + +bFlush :: BufHandle -> IO () +bFlush (BufHandle buf r hdl) = do + i <- readFastMutInt r + when (i > 0) $ hPutBuf hdl buf i + free buf + return () diff --git a/GHC/Utils/CliOption.hs b/GHC/Utils/CliOption.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/CliOption.hs @@ -0,0 +1,27 @@ +module GHC.Utils.CliOption + ( Option (..) + , showOpt + ) where + +import GHC.Prelude + +-- ----------------------------------------------------------------------------- +-- Command-line options + +-- | When invoking external tools as part of the compilation pipeline, we +-- pass these a sequence of options on the command-line. Rather than +-- just using a list of Strings, we use a type that allows us to distinguish +-- between filepaths and 'other stuff'. The reason for this is that +-- this type gives us a handle on transforming filenames, and filenames only, +-- to whatever format they're expected to be on a particular platform. +data Option + = FileOption -- an entry that _contains_ filename(s) / filepaths. + String -- a non-filepath prefix that shouldn't be + -- transformed (e.g., "/out=") + String -- the filepath/filename portion + | Option String + deriving ( Eq ) + +showOpt :: Option -> String +showOpt (FileOption pre f) = pre ++ f +showOpt (Option s) = s diff --git a/GHC/Utils/Encoding.hs b/GHC/Utils/Encoding.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Encoding.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 1997-2006 +-- +-- Character encodings +-- +-- ----------------------------------------------------------------------------- + +module GHC.Utils.Encoding ( + -- * UTF-8 + utf8DecodeCharAddr#, + utf8PrevChar, + utf8CharStart, + utf8DecodeChar, + utf8DecodeByteString, + utf8UnconsByteString, + utf8DecodeShortByteString, + utf8DecodeStringLazy, + utf8EncodeChar, + utf8EncodeString, + utf8EncodeShortByteString, + utf8EncodedLength, + countUTF8Chars, + + -- * Z-encoding + zEncodeString, + zDecodeString, + + -- * Base62-encoding + toBase62, + toBase62Padded + ) where + +import GHC.Prelude + +import Foreign +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Data.Char +import qualified Data.Char as Char +import Numeric +import GHC.IO +import GHC.ST + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import Data.ByteString.Short.Internal (ShortByteString(..)) + +import GHC.Exts + +-- ----------------------------------------------------------------------------- +-- UTF-8 + +-- We can't write the decoder as efficiently as we'd like without +-- resorting to unboxed extensions, unfortunately. I tried to write +-- an IO version of this function, but GHC can't eliminate boxed +-- results from an IO-returning function. +-- +-- We assume we can ignore overflow when parsing a multibyte character here. +-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences +-- before decoding them (see "GHC.Data.StringBuffer"). + +{-# INLINE utf8DecodeChar# #-} +utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #) +utf8DecodeChar# indexWord8# = + let !ch0 = word2Int# (indexWord8# 0#) in + case () of + _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) + + | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> + let !ch1 = word2Int# (indexWord8# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# + (ch1 -# 0x80#)), + 2# #) + + | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> + let !ch1 = word2Int# (indexWord8# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch2 -# 0x80#)), + 3# #) + + | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> + let !ch1 = word2Int# (indexWord8# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + let !ch3 = word2Int# (indexWord8# 3#) in + if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else + (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# + ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch3 -# 0x80#)), + 4# #) + + | otherwise -> fail 1# + where + -- all invalid sequences end up here: + fail :: Int# -> (# Char#, Int# #) + fail nBytes# = (# '\0'#, nBytes# #) + -- '\xFFFD' would be the usual replacement character, but + -- that's a valid symbol in Haskell, so will result in a + -- confusing parse error later on. Instead we use '\0' which + -- will signal a lexer error immediately. + +utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #) +utf8DecodeCharAddr# a# off# = + utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#)) + +utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #) +utf8DecodeCharByteArray# ba# off# = + utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#)) + +utf8DecodeChar :: Ptr Word8 -> (Char, Int) +utf8DecodeChar !(Ptr a#) = + case utf8DecodeCharAddr# a# 0# of + (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) + +-- UTF-8 is cleverly designed so that we can always figure out where +-- the start of the current character is, given any position in a +-- stream. This function finds the start of the previous character, +-- assuming there *is* a previous character. +utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) +utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) + +utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) +utf8CharStart p = go p + where go p = do w <- peek p + if w >= 0x80 && w < 0xC0 + then go (p `plusPtr` (-1)) + else return p + +{-# INLINE utf8DecodeLazy# #-} +utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char] +utf8DecodeLazy# retain decodeChar# len# + = unpack 0# + where + unpack i# + | isTrue# (i# >=# len#) = retain >> return [] + | otherwise = + case decodeChar# i# of + (# c#, nBytes# #) -> do + rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#) + return (C# c# : rest) + +utf8DecodeByteString :: ByteString -> [Char] +utf8DecodeByteString (BS.PS fptr offset len) + = utf8DecodeStringLazy fptr offset len + +utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString) +utf8UnconsByteString (BS.PS _ _ 0) = Nothing +utf8UnconsByteString (BS.PS fptr offset len) + = unsafeDupablePerformIO $ + withForeignPtr fptr $ \ptr -> do + let (c,n) = utf8DecodeChar (ptr `plusPtr` offset) + return $ Just (c, BS.PS fptr (offset + n) (len - n)) + +utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] +utf8DecodeStringLazy fp offset (I# len#) + = unsafeDupablePerformIO $ do + let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset + utf8DecodeLazy# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len# +-- Note that since utf8DecodeLazy# returns a thunk the lifetime of the +-- ForeignPtr actually needs to be longer than the lexical lifetime +-- withForeignPtr would provide here. That's why we use touchForeignPtr to +-- keep the fp alive until the last character has actually been decoded. + +utf8DecodeShortByteString :: ShortByteString -> [Char] +utf8DecodeShortByteString (SBS ba#) + = unsafeDupablePerformIO $ + let len# = sizeofByteArray# ba# in + utf8DecodeLazy# (return ()) (utf8DecodeCharByteArray# ba#) len# + +countUTF8Chars :: ShortByteString -> IO Int +countUTF8Chars (SBS ba) = go 0# 0# + where + len# = sizeofByteArray# ba + go i# n# + | isTrue# (i# >=# len#) = + return (I# n#) + | otherwise = do + case utf8DecodeCharByteArray# ba i# of + (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#) + +{-# INLINE utf8EncodeChar #-} +utf8EncodeChar :: (Int# -> Word# -> State# s -> State# s) + -> Char -> ST s Int +utf8EncodeChar write# c = + let x = ord c in + case () of + _ | x > 0 && x <= 0x007f -> do + write 0 x + return 1 + -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we + -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). + | x <= 0x07ff -> do + write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F)) + write 1 (0x80 .|. (x .&. 0x3F)) + return 2 + | x <= 0xffff -> do + write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F) + write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F) + write 2 (0x80 .|. (x .&. 0x3F)) + return 3 + | otherwise -> do + write 0 (0xF0 .|. (x `shiftR` 18)) + write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F)) + write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F)) + write 3 (0x80 .|. (x .&. 0x3F)) + return 4 + where + {-# INLINE write #-} + write (I# off#) (I# c#) = ST $ \s -> + case write# off# (int2Word# c#) s of + s -> (# s, () #) + +utf8EncodeString :: Ptr Word8 -> String -> IO () +utf8EncodeString (Ptr a#) str = go a# str + where go !_ [] = return () + go a# (c:cs) = do + I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c + go (a# `plusAddr#` off#) cs + +utf8EncodeShortByteString :: String -> IO ShortByteString +utf8EncodeShortByteString str = IO $ \s -> + case utf8EncodedLength str of { I# len# -> + case newByteArray# len# s of { (# s, mba# #) -> + case go mba# 0# str of { ST f_go -> + case f_go s of { (# s, () #) -> + case unsafeFreezeByteArray# mba# s of { (# s, ba# #) -> + (# s, SBS ba# #) }}}}} + where + go _ _ [] = return () + go mba# i# (c:cs) = do + I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c + go mba# (i# +# off#) cs + +utf8EncodedLength :: String -> Int +utf8EncodedLength str = go 0 str + where go !n [] = n + go n (c:cs) + | ord c > 0 && ord c <= 0x007f = go (n+1) cs + | ord c <= 0x07ff = go (n+2) cs + | ord c <= 0xffff = go (n+3) cs + | otherwise = go (n+4) cs + +-- ----------------------------------------------------------------------------- +-- The Z-encoding + +{- +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is done +right before we emit a symbol name into the compiled C or asm code. +Z-encoding of strings is cached in the FastString interface, so we +never encode the same string more than once. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower) and digits + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'zx' or 'Zx' for some + alphabetic character x + +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character + + Before After + -------------------------- + Trak Trak + foo_wib foozuwib + > zg + >1 zg1 + foo# foozh + foo## foozhzh + foo##1 foozhzh1 + fooZ fooZZ + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (# #) Z1H unboxed 1-tuple (note the space) + (#,,,,#) Z5H unboxed 5-tuple + (NB: There is no Z1T nor Z0H.) +-} + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +zEncodeString :: UserString -> EncodedString +zEncodeString cs = case maybe_tuple cs of + Just n -> n -- Tuples go to Z2T etc + Nothing -> go cs + where + go [] = [] + go (c:cs) = encode_digit_ch c ++ go' cs + go' [] = [] + go' (c:cs) = encode_ch c ++ go' cs + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +-- If a digit is at the start of a symbol then we need to encode it. +-- Otherwise package names like 9pH-0.1 give linker errors. +encode_digit_ch :: Char -> EncodedString +encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c +encode_digit_ch c | otherwise = encode_ch c + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = encode_as_unicode_char c + +encode_as_unicode_char :: Char -> EncodedString +encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str + else '0':hex_str + where hex_str = showHex (ord c) "U" + -- ToDo: we could improve the encoding here in various ways. + -- eg. strings of unicode characters come out as 'z1234Uz5678U', we + -- could remove the 'U' in the middle (the 'z' works as a separator). + +zDecodeString :: EncodedString -> UserString +zDecodeString [] = [] +zDecodeString ('Z' : d : rest) + | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : zDecodeString rest +zDecodeString ('z' : d : rest) + | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : zDecodeString rest +zDecodeString (c : rest) = c : zDecodeString rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch + +-- Characters not having a specific code are coded as z224U (in hex) +decode_num_esc :: Char -> EncodedString -> UserString +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest + go n ('U' : rest) = chr n : zDecodeString rest + go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to zDecodeString after decoding the tuple, because + -- the tuple might be embedded in a longer name. + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ('T':rest) = "()" ++ zDecodeString rest + go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest + go 1 ('H':rest) = "(# #)" ++ zDecodeString rest + go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest + go n other = error ("decode_tuple: " ++ show n ++ ' ':other) + +{- +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. +-} + +maybe_tuple :: UserString -> Maybe EncodedString + +maybe_tuple "(# #)" = Just("Z1H") +maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing +maybe_tuple "()" = Just("Z0T") +maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing +maybe_tuple _ = Nothing + +count_commas :: Int -> String -> (Int, String) +count_commas n (',' : cs) = count_commas (n+1) cs +count_commas n cs = (n,cs) + + +{- +************************************************************************ +* * + Base 62 +* * +************************************************************************ + +Note [Base 62 encoding 128-bit integers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of base-62 encoding a single 128-bit integer +(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers +(2 * ceil(10.75) characters). Luckily for us, it's the same number of +characters! +-} + +-------------------------------------------------------------------------- +-- Base 62 + +-- The base-62 code is based off of 'locators' +-- ((c) Operational Dynamics Consulting, BSD3 licensed) + +-- | Size of a 64-bit word when written as a base-62 string +word64Base62Len :: Int +word64Base62Len = 11 + +-- | Converts a 64-bit word into a base-62 string +toBase62Padded :: Word64 -> String +toBase62Padded w = pad ++ str + where + pad = replicate len '0' + len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) + str = toBase62 w + +toBase62 :: Word64 -> String +toBase62 w = showIntAtBase 62 represent w "" + where + represent :: Int -> Char + represent x + | x < 10 = Char.chr (48 + x) + | x < 36 = Char.chr (65 + x - 10) + | x < 62 = Char.chr (97 + x - 36) + | otherwise = error "represent (base 62): impossible!" diff --git a/GHC/Utils/Error.hs b/GHC/Utils/Error.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Error.hs @@ -0,0 +1,990 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[ErrsUtils]{Utilities for error reporting} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Utils.Error ( + -- * Basic types + Validity(..), andValid, allValid, isValid, getInvalids, orValid, + Severity(..), + + -- * Messages + ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason, + ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary, + WarnMsg, MsgDoc, + Messages, ErrorMessages, WarningMessages, + unionMessages, + errMsgSpan, errMsgContext, + errorsFound, isEmptyMessages, + isWarnMsgFatal, + warningsToMessages, + + -- ** Formatting + pprMessageBag, pprErrMsgBagWithLoc, + pprLocErrMsg, printBagOfErrors, + formatErrDoc, + + -- ** Construction + emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, + mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg, + mkPlainWarnMsg, + mkLongWarnMsg, + + -- * Utilities + doIfSet, doIfSet_dyn, + getCaretDiagnostic, + + -- * Dump files + dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, + dumpOptionsFromFlag, DumpOptions (..), + DumpFormat (..), DumpAction, dumpAction, defaultDumpAction, + TraceAction, traceAction, defaultTraceAction, + touchDumpFile, + + -- * Issuing messages during compilation + putMsg, printInfoForUser, printOutputForUser, + logInfo, logOutput, + errorMsg, warningMsg, + fatalErrorMsg, fatalErrorMsg'', + compilationProgressMsg, + showPass, + withTiming, withTimingSilent, withTimingD, withTimingSilentD, + debugTraceMsg, + ghcExit, + prettyPrintGhcErrors, + traceCmd + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Utils.Exception +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Session +import GHC.Data.FastString (unpackFS) +import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) +import GHC.Utils.Json + +import System.Directory +import System.Exit ( ExitCode(..), exitWith ) +import System.FilePath ( takeDirectory, () ) +import Data.List +import qualified Data.Set as Set +import Data.IORef +import Data.Maybe ( fromMaybe ) +import Data.Function +import Data.Time +import Debug.Trace +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch as MC (handle) +import System.IO +import System.IO.Error ( catchIOError ) +import GHC.Conc ( getAllocationCounter ) +import System.CPUTime + +------------------------- +type MsgDoc = SDoc + +------------------------- +data Validity + = IsValid -- ^ Everything is fine + | NotValid MsgDoc -- ^ A problem, and some indication of why + +isValid :: Validity -> Bool +isValid IsValid = True +isValid (NotValid {}) = False + +andValid :: Validity -> Validity -> Validity +andValid IsValid v = v +andValid v _ = v + +-- | If they aren't all valid, return the first +allValid :: [Validity] -> Validity +allValid [] = IsValid +allValid (v : vs) = v `andValid` allValid vs + +getInvalids :: [Validity] -> [MsgDoc] +getInvalids vs = [d | NotValid d <- vs] + +orValid :: Validity -> Validity -> Validity +orValid IsValid _ = IsValid +orValid _ v = v + +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + +type Messages = (WarningMessages, ErrorMessages) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg + +unionMessages :: Messages -> Messages -> Messages +unionMessages (warns1, errs1) (warns2, errs2) = + (warns1 `unionBags` warns2, errs1 `unionBags` errs2) + +data ErrMsg = ErrMsg { + errMsgSpan :: SrcSpan, + errMsgContext :: PrintUnqualified, + errMsgDoc :: ErrDoc, + -- | This has the same text as errDocImportant . errMsgDoc. + errMsgShortString :: String, + errMsgSeverity :: Severity, + errMsgReason :: WarnReason + } + -- The SrcSpan is used for sorting errors into line-number order + + +-- | Categorise error msgs by their importance. This is so each section can +-- be rendered visually distinct. See Note [Error report] for where these come +-- from. +data ErrDoc = ErrDoc { + -- | Primary error msg. + errDocImportant :: [MsgDoc], + -- | Context e.g. \"In the second argument of ...\". + errDocContext :: [MsgDoc], + -- | Supplementary information, e.g. \"Relevant bindings include ...\". + errDocSupplementary :: [MsgDoc] + } + +errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc +errDoc = ErrDoc + +type WarnMsg = ErrMsg + +data Severity + = SevOutput + | SevFatal + | SevInteractive + + | SevDump + -- ^ Log message intended for compiler developers + -- No file\/line\/column stuff + + | SevInfo + -- ^ Log messages intended for end users. + -- No file\/line\/column stuff. + + | SevWarning + | SevError + -- ^ SevWarning and SevError are used for warnings and errors + -- o The message has a file\/line\/column heading, + -- plus "warning:" or "error:", + -- added by mkLocMessags + -- o Output is intended for end users + deriving Show + + +instance ToJson Severity where + json s = JSString (show s) + + +instance Show ErrMsg where + show em = errMsgShortString em + +pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +-- | Make an unannotated error message with location info. +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessage = mkLocMessageAnn Nothing + +-- | Make a possibly annotated error message with location info. +mkLocMessageAnn + :: Maybe String -- ^ optional annotation + -> Severity -- ^ severity + -> SrcSpan -- ^ location + -> MsgDoc -- ^ message + -> MsgDoc + -- Always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "". +mkLocMessageAnn ann severity locn msg + = sdocOption sdocColScheme $ \col_scheme -> + let locn' = sdocOption sdocErrorSpans $ \case + True -> ppr locn + False -> ppr (srcSpanStart locn) + + sevColour = getSeverityColour severity col_scheme + + -- Add optional information + optAnn = case ann of + Nothing -> text "" + Just i -> text " [" <> coloured sevColour (text i) <> text "]" + + -- Add prefixes, like Foo.hs:34: warning: + -- + header = locn' <> colon <+> + coloured sevColour sevText <> optAnn + + in coloured (Col.sMessage col_scheme) + (hang (coloured (Col.sHeader col_scheme) header) 4 + msg) + + where + sevText = + case severity of + SevWarning -> text "warning:" + SevError -> text "error:" + SevFatal -> text "fatal:" + _ -> empty + +getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour +getSeverityColour SevWarning = Col.sWarning +getSeverityColour SevError = Col.sError +getSeverityColour SevFatal = Col.sFatal +getSeverityColour _ = const mempty + +getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty +getCaretDiagnostic severity (RealSrcSpan span _) = do + caretDiagnostic <$> getSrcLine (srcSpanFile span) row + + where + getSrcLine fn i = + getLine i (unpackFS fn) + `catchIOError` \_ -> + pure Nothing + + getLine i fn = do + -- StringBuffer has advantages over readFile: + -- (a) no lazy IO, otherwise IO exceptions may occur in pure code + -- (b) always UTF-8, rather than some system-dependent encoding + -- (Haskell source code must be UTF-8 anyway) + content <- hGetStringBuffer fn + case atLine i content of + Just at_line -> pure $ + case lines (fix <$> lexemeToString at_line (len at_line)) of + srcLine : _ -> Just srcLine + _ -> Nothing + _ -> pure Nothing + + -- allow user to visibly see that their code is incorrectly encoded + -- (StringBuffer.nextChar uses \0 to represent undecodable characters) + fix '\0' = '\xfffd' + fix c = c + + row = srcSpanStartLine span + rowStr = show row + multiline = row /= srcSpanEndLine span + + caretDiagnostic Nothing = empty + caretDiagnostic (Just srcLineWithNewline) = + sdocOption sdocColScheme$ \col_scheme -> + let sevColour = getSeverityColour severity col_scheme + marginColour = Col.sMargin col_scheme + in + coloured marginColour (text marginSpace) <> + text ("\n") <> + coloured marginColour (text marginRow) <> + text (" " ++ srcLinePre) <> + coloured sevColour (text srcLineSpan) <> + text (srcLinePost ++ "\n") <> + coloured marginColour (text marginSpace) <> + coloured sevColour (text (" " ++ caretLine)) + + where + + -- expand tabs in a device-independent manner #13664 + expandTabs tabWidth i s = + case s of + "" -> "" + '\t' : cs -> replicate effectiveWidth ' ' ++ + expandTabs tabWidth (i + effectiveWidth) cs + c : cs -> c : expandTabs tabWidth (i + 1) cs + where effectiveWidth = tabWidth - i `mod` tabWidth + + srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) + + start = srcSpanStartCol span - 1 + end | multiline = length srcLine + | otherwise = srcSpanEndCol span - 1 + width = max 1 (end - start) + + marginWidth = length rowStr + marginSpace = replicate marginWidth ' ' ++ " |" + marginRow = rowStr ++ " |" + + (srcLinePre, srcLineRest) = splitAt start srcLine + (srcLineSpan, srcLinePost) = splitAt width srcLineRest + + caretEllipsis | multiline = "..." + | otherwise = "" + caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis + +makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg +makeIntoWarning reason err = err + { errMsgSeverity = SevWarning + , errMsgReason = reason } + +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mk_err_msg dflags sev locn print_unqual doc + = ErrMsg { errMsgSpan = locn + , errMsgContext = print_unqual + , errMsgDoc = doc + , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) + , errMsgSeverity = sev + , errMsgReason = NoReason } + +mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mkErrDoc dflags = mk_err_msg dflags SevError + +mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- ^ A long (multi-line) error message +mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- ^ A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg +-- ^ Variant that doesn't care about qualified/unqualified names + +mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra]) +mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] []) +mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] []) +mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra]) +mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] []) +mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] []) + +---------------- +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) + +isEmptyMessages :: Messages -> Bool +isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs + +errorsFound :: DynFlags -> Messages -> Bool +errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) + +warningsToMessages :: DynFlags -> WarningMessages -> Messages +warningsToMessages dflags = + partitionBagWith $ \warn -> + case isWarnMsgFatal dflags warn of + Nothing -> Left warn + Just err_reason -> + Right warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason } + +printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () +printBagOfErrors dflags bag_of_errors + = sequence_ [ let style = mkErrStyle unqual + ctx = initSDocContext dflags style + in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc) + | ErrMsg { errMsgSpan = s, + errMsgDoc = doc, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = unqual } <- sortMsgBag (Just dflags) + bag_of_errors ] + +formatErrDoc :: SDocContext -> ErrDoc -> SDoc +formatErrDoc ctx (ErrDoc important context supplementary) + = case msgs of + [msg] -> vcat msg + _ -> vcat $ map starred msgs + where + msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx)) + [important, context, supplementary] + starred = (bullet<+>) . vcat + +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] + +pprLocErrMsg :: ErrMsg -> SDoc +pprLocErrMsg (ErrMsg { errMsgSpan = s + , errMsgDoc = doc + , errMsgSeverity = sev + , errMsgContext = unqual }) + = sdocWithContext $ \ctx -> + withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc) + +sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg] +sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList + where cmp + | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest + | otherwise = SrcLoc.leftmost_smallest + maybeLimit = case join (fmap maxErrors dflags) of + Nothing -> id + Just err_limit -> take err_limit + +ghcExit :: DynFlags -> Int -> IO () +ghcExit dflags val + | val == 0 = exitWith ExitSuccess + | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") + exitWith (ExitFailure val) + +doIfSet :: Bool -> IO () -> IO () +doIfSet flag action | flag = action + | otherwise = return () + +doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO() +doIfSet_dyn dflags flag action | gopt flag dflags = action + | otherwise = return () + +-- ----------------------------------------------------------------------------- +-- Dumping + +dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet dflags flag hdr doc + | not flag = return () + | otherwise = doDump dflags hdr doc +{-# INLINE dumpIfSet #-} -- see Note [INLINE conditional tracing utilities] + +-- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated +-- despite the fact that 'dumpIfSet' has an @INLINE@. +doDump :: DynFlags -> String -> SDoc -> IO () +doDump dflags hdr doc = + putLogMsg dflags + NoReason + SevDump + noSrcSpan + (withPprStyle defaultDumpStyle + (mkDumpDoc hdr doc)) + +-- | A wrapper around 'dumpAction'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify +{-# INLINE dumpIfSet_dyn #-} -- see Note [INLINE conditional tracing utilities] + +-- | A wrapper around 'dumpAction'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +-- +-- Unlike 'dumpIfSet_dyn', has a printer argument +dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String + -> DumpFormat -> SDoc -> IO () +dumpIfSet_dyn_printer printer dflags flag hdr fmt doc + = when (dopt flag dflags) $ do + let sty = mkDumpStyle printer + dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc +{-# INLINE dumpIfSet_dyn_printer #-} -- see Note [INLINE conditional tracing utilities] + +mkDumpDoc :: String -> SDoc -> SDoc +mkDumpDoc hdr doc + = vcat [blankLine, + line <+> text hdr <+> line, + doc, + blankLine] + where + line = text (replicate 20 '=') + + +-- | Ensure that a dump file is created even if it stays empty +touchDumpFile :: DynFlags -> DumpOptions -> IO () +touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ())) + +-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a +-- file, otherwise 'Nothing'. +withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dflags dumpOpt action = do + let mFile = chooseDumpFile dflags dumpOpt + case mFile of + Just fileName -> do + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + unless append $ + writeIORef gdref (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + withFile fileName mode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://gitlab.haskell.org/ghc/ghc/issues/10762 + hSetEncoding handle utf8 + + action (Just handle) + Nothing -> action Nothing + + +-- | Write out a dump. +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout. +-- +-- When @hdr@ is empty, we print in a more compact format (no separators and +-- blank lines) +dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO () +dumpSDocWithStyle sty dflags dumpOpt hdr doc = + withDumpFileHandle dflags dumpOpt writeDump + where + -- write dump to file + writeDump (Just handle) = do + doc' <- if null hdr + then return doc + else do t <- getCurrentTime + let timeStamp = if (gopt Opt_SuppressTimestamps dflags) + then empty + else text (show t) + let d = timeStamp + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc') + + -- write the dump to stdout + writeDump Nothing = do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc') + + +-- | Choose where to put a dump file based on DynFlags +-- +chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath +chooseDumpFile dflags dumpOpt + + | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt + , Just prefix <- getPrefix + = Just $ setDir (prefix ++ dumpSuffix dumpOpt) + + | otherwise + = Nothing + + where getPrefix + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | Just prefix <- dumpPrefixForce dflags + = Just prefix + -- dump file location chosen by GHC.Driver.Pipeline.runPipeline + | Just prefix <- dumpPrefix dflags + = Just prefix + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + setDir f = case dumpDir dflags of + Just d -> d f + Nothing -> f + +-- | Dump options +-- +-- Dumps are printed on stdout by default except when the `dumpForcedToFile` +-- field is set to True. +-- +-- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are +-- written into a file whose suffix is given in the `dumpSuffix` field. +-- +data DumpOptions = DumpOptions + { dumpForcedToFile :: Bool -- ^ Must be dumped into a file, even if + -- -ddump-to-file isn't set + , dumpSuffix :: String -- ^ Filename suffix used when dumped into + -- a file + } + +-- | Create dump options from a 'DumpFlag' +dumpOptionsFromFlag :: DumpFlag -> DumpOptions +dumpOptionsFromFlag Opt_D_th_dec_file = + DumpOptions -- -dth-dec-file dumps expansions of TH + { dumpForcedToFile = True -- splices into MODULE.th.hs even when + , dumpSuffix = "th.hs" -- -ddump-to-file isn't set + } +dumpOptionsFromFlag flag = + DumpOptions + { dumpForcedToFile = False + , dumpSuffix = suffix -- build a suffix from the flag name + } -- e.g. -ddump-asm => ".dump-asm" + where + str = show flag + suff = case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("Bad flag name: " ++ str) + suffix = map (\c -> if c == '_' then '-' else c) suff + + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +-- We want all messages to go through one place, so that we can +-- redirect them if necessary. For example, when GHC is used as a +-- library we might want to catch all messages that GHC tries to +-- output and do something else with them. + +ifVerbose :: DynFlags -> Int -> IO () -> IO () +ifVerbose dflags val act + | verbosity dflags >= val = act + | otherwise = return () +{-# INLINE ifVerbose #-} -- see Note [INLINE conditional tracing utilities] + +errorMsg :: DynFlags -> MsgDoc -> IO () +errorMsg dflags msg + = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg + +warningMsg :: DynFlags -> MsgDoc -> IO () +warningMsg dflags msg + = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg + +fatalErrorMsg :: DynFlags -> MsgDoc -> IO () +fatalErrorMsg dflags msg = + putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg + +fatalErrorMsg'' :: FatalMessager -> String -> IO () +fatalErrorMsg'' fm msg = fm msg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg = do + traceEventIO $ "GHC progress: " ++ msg + ifVerbose dflags 1 $ + logOutput dflags $ withPprStyle defaultUserStyle (text msg) + +showPass :: DynFlags -> String -> IO () +showPass dflags what + = ifVerbose dflags 2 $ + logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) + +data PrintTimings = PrintTimings | DontPrintTimings + deriving (Eq, Show) + +-- | Time a compilation phase. +-- +-- When timings are enabled (e.g. with the @-v2@ flag), the allocations +-- and CPU time used by the phase will be reported to stderr. Consider +-- a typical usage: +-- @withTiming getDynFlags (text "simplify") force PrintTimings pass@. +-- When timings are enabled the following costs are included in the +-- produced accounting, +-- +-- - The cost of executing @pass@ to a result @r@ in WHNF +-- - The cost of evaluating @force r@ to WHNF (e.g. @()@) +-- +-- The choice of the @force@ function depends upon the amount of forcing +-- desired; the goal here is to ensure that the cost of evaluating the result +-- is, to the greatest extent possible, included in the accounting provided by +-- 'withTiming'. Often the pass already sufficiently forces its result during +-- construction; in this case @const ()@ is a reasonable choice. +-- In other cases, it is necessary to evaluate the result to normal form, in +-- which case something like @Control.DeepSeq.rnf@ is appropriate. +-- +-- To avoid adversely affecting compiler performance when timings are not +-- requested, the result is only forced when timings are enabled. +-- +-- See Note [withTiming] for more. +withTiming :: MonadIO m + => DynFlags -- ^ DynFlags + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming dflags what force action = + withTiming' dflags what force PrintTimings action + +-- | Like withTiming but get DynFlags from the Monad. +withTimingD :: (MonadIO m, HasDynFlags m) + => SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingD what force action = do + dflags <- getDynFlags + withTiming' dflags what force PrintTimings action + + +-- | Same as 'withTiming', but doesn't print timings in the +-- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). +-- +-- See Note [withTiming] for more. +withTimingSilent + :: MonadIO m + => DynFlags -- ^ DynFlags + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingSilent dflags what force action = + withTiming' dflags what force DontPrintTimings action + +-- | Same as 'withTiming', but doesn't print timings in the +-- console (when given @-vN@, @N >= 2@ or @-ddump-timings@) +-- and gets the DynFlags from the given Monad. +-- +-- See Note [withTiming] for more. +withTimingSilentD + :: (MonadIO m, HasDynFlags m) + => SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingSilentD what force action = do + dflags <- getDynFlags + withTiming' dflags what force DontPrintTimings action + +-- | Worker for 'withTiming' and 'withTimingSilent'. +withTiming' :: MonadIO m + => DynFlags -- ^ A means of getting a 'DynFlags' (often + -- 'getDynFlags' will work here) + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> PrintTimings -- ^ Whether to print the timings + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming' dflags what force_result prtimings action + = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags + then do whenPrintTimings $ + logInfo dflags $ withPprStyle defaultUserStyle $ + text "***" <+> what <> colon + let ctx = initDefaultSDocContext dflags + eventBegins ctx what + alloc0 <- liftIO getAllocationCounter + start <- liftIO getCPUTime + !r <- action + () <- pure $ force_result r + eventEnds ctx what + end <- liftIO getCPUTime + alloc1 <- liftIO getAllocationCounter + -- recall that allocation counter counts down + let alloc = alloc0 - alloc1 + time = realToFrac (end - start) * 1e-9 + + when (verbosity dflags >= 2 && prtimings == PrintTimings) + $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 time + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + + whenPrintTimings $ + dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText + $ text $ showSDocOneLine ctx + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] + pure r + else action + + where whenPrintTimings = liftIO . when (prtimings == PrintTimings) + eventBegins ctx w = do + whenPrintTimings $ traceMarkerIO (eventBeginsDoc ctx w) + liftIO $ traceEventIO (eventBeginsDoc ctx w) + eventEnds ctx w = do + whenPrintTimings $ traceMarkerIO (eventEndsDoc ctx w) + liftIO $ traceEventIO (eventEndsDoc ctx w) + + eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w + eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w + +debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () +debugTraceMsg dflags val msg = + ifVerbose dflags val $ + logInfo dflags (withPprStyle defaultDumpStyle msg) +{-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities] + +putMsg :: DynFlags -> MsgDoc -> IO () +putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg) + +printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printInfoForUser dflags print_unqual msg + = logInfo dflags (withUserStyle print_unqual AllTheWay msg) + +printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printOutputForUser dflags print_unqual msg + = logOutput dflags (withUserStyle print_unqual AllTheWay msg) + +logInfo :: DynFlags -> MsgDoc -> IO () +logInfo dflags msg + = putLogMsg dflags NoReason SevInfo noSrcSpan msg + +-- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' +logOutput :: DynFlags -> MsgDoc -> IO () +logOutput dflags msg + = putLogMsg dflags NoReason SevOutput noSrcSpan msg + +prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a +prettyPrintGhcErrors dflags + = MC.handle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen dflags panic (text str) doc + PprSorry str doc -> + pprDebugAndThen dflags sorry (text str) doc + PprProgramError str doc -> + pprDebugAndThen dflags pgmError (text str) doc + _ -> + liftIO $ throwIO e + +-- | Checks if given 'WarnMsg' is a fatal warning. +isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) +isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} + = if wopt_fatal wflag dflags + then Just (Just wflag) + else Nothing +isWarnMsgFatal dflags _ + = if gopt Opt_WarnIsError dflags + then Just Nothing + else Nothing + +traceCmd :: DynFlags -> String -> String -> IO a -> IO a +-- trace the command (at two levels of verbosity) +traceCmd dflags phase_name cmd_line action + = do { let verb = verbosity dflags + ; showPass dflags phase_name + ; debugTraceMsg dflags 3 (text cmd_line) + ; case flushErr dflags of + FlushErr io -> io + + -- And run it! + ; action `catchIO` handle_exn verb + } + where + handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') + ; debugTraceMsg dflags 2 + (text "Failed:" + <+> text cmd_line + <+> text (show exn)) + ; throwGhcExceptionIO (ProgramError (show exn))} + +{- Note [withTiming] +~~~~~~~~~~~~~~~~~~~~ + +For reference: + + withTiming + :: MonadIO + => m DynFlags -- how to get the DynFlags + -> SDoc -- label for the computation we're timing + -> (a -> ()) -- how to evaluate the result + -> PrintTimings -- whether to report the timings when passed + -- -v2 or -ddump-timings + -> m a -- computation we're timing + -> m a + +withTiming lets you run an action while: + +(1) measuring the CPU time it took and reporting that on stderr + (when PrintTimings is passed), +(2) emitting start/stop events to GHC's event log, with the label + given as an argument. + +Evaluation of the result +------------------------ + +'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is +to evaluate the result "sufficiently". A given pass might return an 'm a' for +some monad 'm' and result type 'a', but where the 'a' is complex enough +that evaluating it to WHNF barely scratches its surface and leaves many +complex and time-consuming computations unevaluated. Those would only be +forced by the next pass, and the time needed to evaluate them would be +mis-attributed to that next pass. A more appropriate function would be +one that deeply evaluates the result, so as to assign the time spent doing it +to the pass we're timing. + +Note: as hinted at above, the time spent evaluating the application of the +forcing function to the result is included in the timings reported by +'withTiming'. + +How we use it +------------- + +We measure the time and allocations of various passes in GHC's pipeline by just +wrapping the whole pass with 'withTiming'. This also materializes by having +a label for each pass in the eventlog, where each pass is executed in one go, +during a continuous time window. + +However, from STG onwards, the pipeline uses streams to emit groups of +STG/Cmm/etc declarations one at a time, and process them until we get to +assembly code generation. This means that the execution of those last few passes +is interleaved and that we cannot measure how long they take by just wrapping +the whole thing with 'withTiming'. Instead we wrap the processing of each +individual stream element, all along the codegen pipeline, using the appropriate +label for the pass to which this processing belongs. That generates a lot more +data but allows us to get fine-grained timings about all the passes and we can +easily compute totals with tools like ghc-events-analyze (see below). + + +Producing an eventlog for GHC +----------------------------- + +To actually produce the eventlog, you need an eventlog-capable GHC build: + + With Hadrian: + $ hadrian/build -j "stage1.ghc-bin.ghc.link.opts += -eventlog" + + With Make: + $ make -j GhcStage2HcOpts+=-eventlog + +You can then produce an eventlog when compiling say hello.hs by simply +doing: + + If GHC was built by Hadrian: + $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l + + If GHC was built with Make: + $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l + +You could alternatively use -v (with N >= 2) instead of -ddump-timings, +to ask GHC to report timings (on stderr and the eventlog). + +This will write the eventlog to ./ghc.eventlog in both cases. You can then +visualize it or look at the totals for each label by using ghc-events-analyze, +threadscope or any other eventlog consumer. Illustrating with +ghc-events-analyze: + + $ ghc-events-analyze --timed --timed-txt --totals \ + --start "GHC:started:" --stop "GHC:finished:" \ + ghc.eventlog + +This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation +of the execution through the various labels) and ghc.totals.txt (total time +spent in each label). + +-} + + +-- | Format of a dump +-- +-- Dump formats are loosely defined: dumps may contain various additional +-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint +-- (e.g. for syntax highlighters). +data DumpFormat + = FormatHaskell -- ^ Haskell + | FormatCore -- ^ Core + | FormatSTG -- ^ STG + | FormatByteCode -- ^ ByteCode + | FormatCMM -- ^ Cmm + | FormatASM -- ^ Assembly code + | FormatC -- ^ C code/header + | FormatLLVM -- ^ LLVM bytecode + | FormatText -- ^ Unstructured dump + deriving (Show,Eq) + +type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String + -> DumpFormat -> SDoc -> IO () + +type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a + +-- | Default action for 'dumpAction' hook +defaultDumpAction :: DumpAction +defaultDumpAction dflags sty dumpOpt title _fmt doc = do + dumpSDocWithStyle sty dflags dumpOpt title doc + +-- | Default action for 'traceAction' hook +defaultTraceAction :: TraceAction +defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc + +-- | Helper for `dump_action` +dumpAction :: DumpAction +dumpAction dflags = dump_action dflags dflags + +-- | Helper for `trace_action` +traceAction :: TraceAction +traceAction dflags = trace_action dflags dflags diff --git a/GHC/Utils/Error.hs-boot b/GHC/Utils/Error.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Utils/Error.hs-boot @@ -0,0 +1,50 @@ +{-# LANGUAGE RankNTypes #-} + +module GHC.Utils.Error where + +import GHC.Prelude +import GHC.Utils.Outputable (SDoc, PprStyle ) +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Utils.Json +import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) + +type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String + -> DumpFormat -> SDoc -> IO () + +type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a + +data DumpOptions = DumpOptions + { dumpForcedToFile :: Bool + , dumpSuffix :: String + } + +data DumpFormat + = FormatHaskell + | FormatCore + | FormatSTG + | FormatByteCode + | FormatCMM + | FormatASM + | FormatC + | FormatLLVM + | FormatText + +data Severity + = SevOutput + | SevFatal + | SevInteractive + | SevDump + | SevInfo + | SevWarning + | SevError + + +type MsgDoc = SDoc + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +defaultDumpAction :: DumpAction +defaultTraceAction :: TraceAction + +instance ToJson Severity diff --git a/GHC/Utils/Exception.hs b/GHC/Utils/Exception.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Exception.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE ConstraintKinds #-} + +module GHC.Utils.Exception + ( + module Control.Exception, + module GHC.Utils.Exception + ) + where + +import GHC.Prelude + +import Control.Exception +import Control.Exception as CE +import Control.Monad.IO.Class +import Control.Monad.Catch + +-- Monomorphised versions of exception-handling utilities +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = CE.catch + +handleIO :: (IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +tryIO :: IO a -> IO (Either IOException a) +tryIO = CE.try + +type ExceptionMonad m = (MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) diff --git a/GHC/Utils/FV.hs b/GHC/Utils/FV.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/FV.hs @@ -0,0 +1,199 @@ +{- +(c) Bartosz Nitka, Facebook 2015 + +-} + +{-# LANGUAGE BangPatterns #-} + +-- | Utilities for efficiently and deterministically computing free variables. +module GHC.Utils.FV ( + -- * Deterministic free vars computations + FV, InterestingVarFun, + + -- * Running the computations + fvVarList, fvVarSet, fvDVarSet, + + -- ** Manipulating those computations + unitFV, + emptyFV, + mkFVs, + unionFV, + unionsFV, + delFV, + delFVs, + filterFV, + mapUnionFV, + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Var.Set + +-- | Predicate on possible free variables: returns @True@ iff the variable is +-- interesting +type InterestingVarFun = Var -> Bool + +-- Note [Deterministic FV] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- When computing free variables, the order in which you get them affects +-- the results of floating and specialization. If you use UniqFM to collect +-- them and then turn that into a list, you get them in nondeterministic +-- order as described in Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +-- A naive algorithm for free variables relies on merging sets of variables. +-- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log +-- factor. It's cheaper to incrementally add to a list and use a set to check +-- for duplicates. +type FV = InterestingVarFun -- Used for filtering sets as we build them + -> VarSet -- Locally bound variables + -> VarAcc -- Accumulator + -> VarAcc + +type VarAcc = ([Var], VarSet) -- List to preserve ordering and set to check for membership, + -- so that the list doesn't have duplicates + -- For explanation of why using `VarSet` is not deterministic see + -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +-- Note [FV naming conventions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To get the performance and determinism that FV provides, FV computations +-- need to built up from smaller FV computations and then evaluated with +-- one of `fvVarList`, `fvDVarSet` That means the functions +-- returning FV need to be exported. +-- +-- The conventions are: +-- +-- a) non-deterministic functions: +-- * a function that returns VarSet +-- e.g. `tyVarsOfType` +-- b) deterministic functions: +-- * a worker that returns FV +-- e.g. `tyFVsOfType` +-- * a function that returns [Var] +-- e.g. `tyVarsOfTypeList` +-- * a function that returns DVarSet +-- e.g. `tyVarsOfTypeDSet` +-- +-- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented +-- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet +-- respectively. + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order and a non-deterministic set containing +-- those variables. +fvVarAcc :: FV -> ([Var], VarSet) +fvVarAcc fv = fv (const True) emptyVarSet ([], emptyVarSet) + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order. +fvVarList :: FV -> [Var] +fvVarList = fst . fvVarAcc + +-- | Run a free variable computation, returning a deterministic set of free +-- variables. Note that this is just a wrapper around the version that +-- returns a deterministic list. If you need a list you should use +-- `fvVarList`. +fvDVarSet :: FV -> DVarSet +fvDVarSet = mkDVarSet . fvVarList + +-- | Run a free variable computation, returning a non-deterministic set of +-- free variables. Don't use if the set will be later converted to a list +-- and the order of that list will impact the generated code. +fvVarSet :: FV -> VarSet +fvVarSet = snd . fvVarAcc + +-- Note [FV eta expansion] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- Let's consider an eta-reduced implementation of freeVarsOf using FV: +-- +-- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b +-- +-- If GHC doesn't eta-expand it, after inlining unionFV we end up with +-- +-- freeVarsOf = \x -> +-- case x of +-- App a b -> \fv_cand in_scope acc -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which has to create a thunk, resulting in more allocations. +-- +-- On the other hand if it is eta-expanded: +-- +-- freeVarsOf (App a b) fv_cand in_scope acc = +-- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc +-- +-- after inlining unionFV we have: +-- +-- freeVarsOf = \x fv_cand in_scope acc -> +-- case x of +-- App a b -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which saves allocations. +-- +-- GHC when presented with knowledge about all the call sites, correctly +-- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets +-- exported to be composed with other functions, GHC doesn't have that +-- information and has to be more conservative here. +-- +-- Hence functions that get exported and return FV need to be manually +-- eta-expanded. See also #11146. + +-- | Add a variable - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +unitFV :: Id -> FV +unitFV var fv_cand in_scope acc@(have, haveSet) + | var `elemVarSet` in_scope = acc + | var `elemVarSet` haveSet = acc + | fv_cand var = (var:have, extendVarSet haveSet var) + | otherwise = acc +{-# INLINE unitFV #-} + +-- | Return no free variables. +emptyFV :: FV +emptyFV _ _ acc = acc +{-# INLINE emptyFV #-} + +-- | Union two free variable computations. +unionFV :: FV -> FV -> FV +unionFV fv1 fv2 fv_cand in_scope acc = + fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc +{-# INLINE unionFV #-} + +-- | Mark the variable as not free by putting it in scope. +delFV :: Var -> FV -> FV +delFV var fv fv_cand !in_scope acc = + fv fv_cand (extendVarSet in_scope var) acc +{-# INLINE delFV #-} + +-- | Mark many free variables as not free. +delFVs :: VarSet -> FV -> FV +delFVs vars fv fv_cand !in_scope acc = + fv fv_cand (in_scope `unionVarSet` vars) acc +{-# INLINE delFVs #-} + +-- | Filter a free variable computation. +filterFV :: InterestingVarFun -> FV -> FV +filterFV fv_cand2 fv fv_cand1 in_scope acc = + fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc +{-# INLINE filterFV #-} + +-- | Map a free variable computation over a list and union the results. +mapUnionFV :: (a -> FV) -> [a] -> FV +mapUnionFV _f [] _fv_cand _in_scope acc = acc +mapUnionFV f (a:as) fv_cand in_scope acc = + mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc +{-# INLINABLE mapUnionFV #-} + +-- | Union many free variable computations. +unionsFV :: [FV] -> FV +unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc +{-# INLINE unionsFV #-} + +-- | Add multiple variables - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +mkFVs :: [Var] -> FV +mkFVs vars fv_cand in_scope acc = + mapUnionFV unitFV vars fv_cand in_scope acc +{-# INLINE mkFVs #-} diff --git a/GHC/Utils/Fingerprint.hs b/GHC/Utils/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Fingerprint.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ---------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- Fingerprints for recompilation checking and ABI versioning. +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- ---------------------------------------------------------------------------- + +module GHC.Utils.Fingerprint ( + readHexFingerprint, + fingerprintByteString, + -- * Re-exported from GHC.Fingerprint + Fingerprint(..), fingerprint0, + fingerprintFingerprints, + fingerprintData, + fingerprintString, + getFileHash + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import Foreign +import GHC.IO +import Numeric ( readHex ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import GHC.Fingerprint + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + +fingerprintByteString :: BS.ByteString -> Fingerprint +fingerprintByteString bs = unsafeDupablePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/GHC/Utils/IO/Unsafe.hs b/GHC/Utils/IO/Unsafe.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/IO/Unsafe.hs @@ -0,0 +1,22 @@ +{- +(c) The University of Glasgow, 2000-2006 +-} + +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + +module GHC.Utils.IO.Unsafe + ( inlinePerformIO, + ) +where + +#include "HsVersions.h" + +import GHC.Prelude () + +import GHC.Exts +import GHC.IO (IO(..)) + +-- Just like unsafeDupablePerformIO, but we inline it. +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/GHC/Utils/Json.hs b/GHC/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Json.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GADTs #-} +module GHC.Utils.Json where + +import GHC.Prelude + +import GHC.Utils.Outputable +import Data.Char +import Numeric + +-- | Simple data type to represent JSON documents. +data JsonDoc where + JSNull :: JsonDoc + JSBool :: Bool -> JsonDoc + JSInt :: Int -> JsonDoc + JSString :: String -> JsonDoc + JSArray :: [JsonDoc] -> JsonDoc + JSObject :: [(String, JsonDoc)] -> JsonDoc + + +-- This is simple and slow as it is only used for error reporting +renderJSON :: JsonDoc -> SDoc +renderJSON d = + case d of + JSNull -> text "null" + JSBool b -> text $ if b then "true" else "false" + JSInt n -> ppr n + JSString s -> doubleQuotes $ text $ escapeJsonString s + JSArray as -> brackets $ pprList renderJSON as + JSObject fs -> braces $ pprList renderField fs + where + renderField :: (String, JsonDoc) -> SDoc + renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j + + pprList pp xs = hcat (punctuate comma (map pp xs)) + +escapeJsonString :: String -> String +escapeJsonString = concatMap escapeChar + where + escapeChar '\b' = "\\b" + escapeChar '\f' = "\\f" + escapeChar '\n' = "\\n" + escapeChar '\r' = "\\r" + escapeChar '\t' = "\\t" + escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c + escapeChar c = [c] + + uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) + + pad n cs | len < n = replicate (n-len) '0' ++ cs + | otherwise = cs + where len = length cs + +class ToJson a where + json :: a -> JsonDoc diff --git a/GHC/Utils/Lexeme.hs b/GHC/Utils/Lexeme.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Lexeme.hs @@ -0,0 +1,240 @@ +-- (c) The GHC Team +-- +-- Functions to evaluate whether or not a string is a valid identifier. +-- There is considerable overlap between the logic here and the logic +-- in GHC.Parser.Lexer, but sadly there seems to be no way to merge them. + +module GHC.Utils.Lexeme ( + -- * Lexical characteristics of Haskell names + + -- | Use these functions to figure what kind of name a 'FastString' + -- represents; these functions do /not/ check that the identifier + -- is valid. + + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + startsVarSym, startsVarId, startsConSym, startsConId, + + -- * Validating identifiers + + -- | These functions (working over plain old 'String's) check + -- to make sure that the identifier is valid. + okVarOcc, okConOcc, okTcOcc, + okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc + + -- Some of the exports above are not used within GHC, but may + -- be of value to GHC API users. + + ) where + +import GHC.Prelude + +import GHC.Data.FastString + +import Data.Char +import qualified Data.Set as Set + +import GHC.Lexeme + +{- + +************************************************************************ +* * + Lexical categories +* * +************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +Note [Classification of generated names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some names generated for internal use can show up in debugging output, +e.g. when using -ddump-simpl. These generated names start with a $ +but should still be pretty-printed using prefix notation. We make sure +this is the case in isLexVarSym by only classifying a name as a symbol +if all its characters are symbols, not just its first one. +-} + +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- +isLexConId cs -- Prefix type or data constructors + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" + | cs == (fsLit "[]") = True + | otherwise = startsConId (headFS cs) + +isLexVarId cs -- Ordinary prefix identifiers + | nullFS cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) + +isLexConSym cs -- Infix type or data constructors + | nullFS cs = False -- e.g. ":-:", ":", "->" + | cs == (fsLit "->") = True + | otherwise = startsConSym (headFS cs) + +isLexVarSym fs -- Infix identifiers e.g. "+" + | fs == (fsLit "~R#") = True + | otherwise + = case (if nullFS fs then [] else unpackFS fs) of + [] -> False + (c:cs) -> startsVarSym c && all isVarSymChar cs + -- See Note [Classification of generated names] + +{- + +************************************************************************ +* * + Detecting valid names for Template Haskell +* * +************************************************************************ + +-} + +---------------------- +-- External interface +---------------------- + +-- | Is this an acceptable variable name? +okVarOcc :: String -> Bool +okVarOcc str@(c:_) + | startsVarId c + = okVarIdOcc str + | startsVarSym c + = okVarSymOcc str +okVarOcc _ = False + +-- | Is this an acceptable constructor name? +okConOcc :: String -> Bool +okConOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | str == "[]" + = True +okConOcc _ = False + +-- | Is this an acceptable type name? +okTcOcc :: String -> Bool +okTcOcc "[]" = True +okTcOcc "->" = True +okTcOcc "~" = True +okTcOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | startsVarSym c + = okVarSymOcc str +okTcOcc _ = False + +-- | Is this an acceptable alphanumeric variable name, assuming it starts +-- with an acceptable letter? +okVarIdOcc :: String -> Bool +okVarIdOcc str = okIdOcc str && + -- admit "_" as a valid identifier. Required to support typed + -- holes in Template Haskell. See #10267 + (str == "_" || not (str `Set.member` reservedIds)) + +-- | Is this an acceptable symbolic variable name, assuming it starts +-- with an acceptable character? +okVarSymOcc :: String -> Bool +okVarSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) && + not (isDashes str) + +-- | Is this an acceptable alphanumeric constructor name, assuming it +-- starts with an acceptable letter? +okConIdOcc :: String -> Bool +okConIdOcc str = okIdOcc str || + is_tuple_name1 True str || + -- Is it a boxed tuple... + is_tuple_name1 False str || + -- ...or an unboxed tuple (#12407)... + is_sum_name1 str + -- ...or an unboxed sum (#12514)? + where + -- check for tuple name, starting at the beginning + is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest + is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest + is_tuple_name1 _ _ = False + + -- check for tuple tail + is_tuple_name2 True ")" = True + is_tuple_name2 False "#)" = True + is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest + is_tuple_name2 boxed (ws : rest) + | isSpace ws = is_tuple_name2 boxed rest + is_tuple_name2 _ _ = False + + -- check for sum name, starting at the beginning + is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest + is_sum_name1 _ = False + + -- check for sum tail, only allowing at most one underscore + is_sum_name2 _ "#)" = True + is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest + is_sum_name2 False ('_' : rest) = is_sum_name2 True rest + is_sum_name2 underscore (ws : rest) + | isSpace ws = is_sum_name2 underscore rest + is_sum_name2 _ _ = False + +-- | Is this an acceptable symbolic constructor name, assuming it +-- starts with an acceptable character? +okConSymOcc :: String -> Bool +okConSymOcc ":" = True +okConSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) + +---------------------- +-- Internal functions +---------------------- + +-- | Is this string an acceptable id, possibly with a suffix of hashes, +-- but not worrying about case or clashing with reserved words? +okIdOcc :: String -> Bool +okIdOcc str + = let hashes = dropWhile okIdChar str in + all (== '#') hashes -- -XMagicHash allows a suffix of hashes + -- of course, `all` says "True" to an empty list + +-- | Is this character acceptable in an identifier (after the first letter)? +-- See alexGetByte in GHC.Parser.Lexer +okIdChar :: Char -> Bool +okIdChar c = case generalCategory c of + UppercaseLetter -> True + LowercaseLetter -> True + TitlecaseLetter -> True + ModifierLetter -> True -- See #10196 + OtherLetter -> True -- See #1103 + NonSpacingMark -> True -- See #7650 + DecimalNumber -> True + OtherNumber -> True -- See #4373 + _ -> c == '\'' || c == '_' + +-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. +reservedIds :: Set.Set String +reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" + , "do", "else", "foreign", "if", "import", "in" + , "infix", "infixl", "infixr", "instance", "let" + , "module", "newtype", "of", "then", "type", "where" + , "_" ] + +-- | All reserved operators. Taken from section 2.4 of the 2010 Report. +reservedOps :: Set.Set String +reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" + , "@", "~", "=>" ] + +-- | Does this string contain only dashes and has at least 2 of them? +isDashes :: String -> Bool +isDashes ('-' : '-' : rest) = all (== '-') rest +isDashes _ = False diff --git a/GHC/Utils/Misc.hs b/GHC/Utils/Misc.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Misc.hs @@ -0,0 +1,1519 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Highly random utility functions +-- +module GHC.Utils.Misc ( + -- * Flags dependent on the compiler build + ghciSupported, debugIsOn, + isWindowsHost, isDarwinHost, + + -- * Miscellaneous higher-order functions + applyWhen, nTimes, + + -- * General list processing + zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, + + zipWithLazy, zipWith3Lazy, + + filterByList, filterByLists, partitionByList, + + unzipWith, + + mapFst, mapSnd, chkAppend, + mapAndUnzip, mapAndUnzip3, + filterOut, partitionWith, + + dropWhileEndLE, spanEnd, last2, lastMaybe, + + foldl1', foldl2, count, countWhile, all2, + + lengthExceeds, lengthIs, lengthIsNot, + lengthAtLeast, lengthAtMost, lengthLessThan, + listLengthCmp, atLength, + equalLength, compareLength, leLength, ltLength, + + isSingleton, only, GHC.Utils.Misc.singleton, + notNull, snocView, + + isIn, isn'tIn, + + chunkList, + + changeLast, + mapLastM, + + whenNonEmpty, + + mergeListsBy, + isSortedBy, + + -- * Tuples + fstOf3, sndOf3, thdOf3, + firstM, first3M, secondM, + fst3, snd3, third3, + uncurry3, + liftFst, liftSnd, + + -- * List operations controlled by another list + takeList, dropList, splitAtList, split, + dropTail, capitalise, + + -- * Sorting + sortWith, minWith, nubSort, ordNub, + + -- * Comparisons + isEqual, eqListBy, eqMaybeBy, + thenCmp, cmpList, + removeSpaces, + (<&&>), (<||>), + + -- * Edit distance + fuzzyMatch, fuzzyLookup, + + -- * Transitive closures + transitiveClosure, + + -- * Strictness + seqList, strictMap, + + -- * Module names + looksLikeModuleName, + looksLikePackageName, + + -- * Argument processing + getCmd, toCmdArgs, toArgs, + + -- * Integers + exactLog2, + + -- * Floating point + readRational, + readHexRational, + + -- * IO-ish utilities + doesDirNameExist, + getModificationUTCTime, + modificationTimeIfExists, + withAtomicRename, + + global, consIORef, globalM, + sharedGlobal, sharedGlobalM, + + -- * Filenames and paths + Suffix, + splitLongestPrefix, + escapeSpaces, + Direction(..), reslash, + makeRelativeTo, + + -- * Utils for defining Data instances + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC, + + -- * Hashing + hashString, + + -- * Call stacks + HasCallStack, + HasDebugCallStack, + + -- * Utils for flags + OverridingBool(..), + overrideWith, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Exception +import GHC.Utils.Panic.Plain + +import Data.Data +import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.List hiding (group) +import Data.List.NonEmpty ( NonEmpty(..) ) + +import GHC.Exts +import GHC.Stack (HasCallStack) + +import Control.Applicative ( liftA2 ) +import Control.Monad ( liftM, guard ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import GHC.Conc.Sync ( sharedCAF ) +import System.IO.Error as IO ( isDoesNotExistError ) +import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) +import System.FilePath + +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper + , isHexDigit, digitToInt ) +import Data.Int +import Data.Ratio ( (%) ) +import Data.Ord ( comparing ) +import Data.Bits +import Data.Word +import qualified Data.IntMap as IM +import qualified Data.Set as Set + +import Data.Time + +#if defined(DEBUG) +import {-# SOURCE #-} GHC.Utils.Outputable ( warnPprTrace, text ) +#endif + +infixr 9 `thenCmp` + +{- +************************************************************************ +* * +\subsection{Is DEBUG on, are we on Windows, etc?} +* * +************************************************************************ + +These booleans are global constants, set by CPP flags. They allow us to +recompile a single module (this one) to change whether or not debug output +appears. They sometimes let us avoid even running CPP elsewhere. + +It's important that the flags are literal constants (True/False). Then, +with -0, tests of the flags in other modules will simplify to the correct +branch of the conditional, thereby dropping debug code altogether when +the flags are off. +-} + +ghciSupported :: Bool +#if defined(HAVE_INTERNAL_INTERPRETER) +ghciSupported = True +#else +ghciSupported = False +#endif + +debugIsOn :: Bool +#if defined(DEBUG) +debugIsOn = True +#else +debugIsOn = False +#endif + +isWindowsHost :: Bool +#if defined(mingw32_HOST_OS) +isWindowsHost = True +#else +isWindowsHost = False +#endif + +isDarwinHost :: Bool +#if defined(darwin_HOST_OS) +isDarwinHost = True +#else +isDarwinHost = False +#endif + +{- +************************************************************************ +* * +\subsection{Miscellaneous higher-order functions} +* * +************************************************************************ +-} + +-- | Apply a function iff some condition is met. +applyWhen :: Bool -> (a -> a) -> a -> a +applyWhen True f x = f x +applyWhen _ _ x = x + +-- | A for loop: Compose a function with itself n times. (nth rather than twice) +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f + +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thdOf3 :: (a,b,c) -> c +fstOf3 (a,_,_) = a +sndOf3 (_,b,_) = b +thdOf3 (_,_,c) = c + +fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) +fst3 f (a, b, c) = (f a, b, c) + +snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) +snd3 f (a, b, c) = (a, f b, c) + +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +liftFst :: (a -> b) -> (a, c) -> (b, c) +liftFst f (a,c) = (f a, c) + +liftSnd :: (a -> b) -> (c, a) -> (c, b) +liftSnd f (c,a) = (c, f a) + +firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) +firstM f (x, y) = liftM (\x' -> (x', y)) (f x) + +first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) +first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) + +secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) +secondM f (x, y) = (x,) <$> f y + +{- +************************************************************************ +* * +\subsection[Utils-lists]{General list processing} +* * +************************************************************************ +-} + +filterOut :: (a->Bool) -> [a] -> [a] +-- ^ Like filter, only it reverses the sense of the test +filterOut _ [] = [] +filterOut p (x:xs) | p x = filterOut p xs + | otherwise = x : filterOut p xs + +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +-- ^ Uses a function to determine which of two output lists an input element should join +partitionWith _ [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs + +chkAppend :: [a] -> [a] -> [a] +-- Checks for the second argument being empty +-- Used in situations where that situation is common +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys + +{- +A paranoid @zip@ (and some @zipWith@ friends) that checks the lists +are of equal length. Alastair Reid thinks this should only happen if +DEBUGging on; hey, why not? +-} + +zipEqual :: String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] + +#if !defined(DEBUG) +zipEqual _ = zip +zipWithEqual _ = zipWith +zipWith3Equal _ = zipWith3 +zipWith4Equal _ = zipWith4 +#else +zipEqual _ [] [] = [] +zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs +zipEqual msg _ _ = panic ("zipEqual: unequal lists: "++msg) + +zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs +zipWithEqual _ _ [] [] = [] +zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists: "++msg) + +zipWith3Equal msg z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3Equal msg z as bs cs +zipWith3Equal _ _ [] [] [] = [] +zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists: "++msg) + +zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4Equal msg z as bs cs ds +zipWith4Equal _ _ [] [] [] [] = [] +zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) +#endif + +-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) +zipLazy :: [a] -> [b] -> [(a,b)] +zipLazy [] _ = [] +zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys + +-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. +-- The length of the output is always the same as the length of the first +-- list. +zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWithLazy _ [] _ = [] +zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs + +-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. +-- The length of the output is always the same as the length of the first +-- list. +zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +zipWith3Lazy _ [] _ _ = [] +zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +-- | 'filterByLists' takes a list of Bools and two lists as input, and +-- outputs a new list consisting of elements from the last two input lists. For +-- each Bool in the list, if it is 'True', then it takes an element from the +-- former list. If it is 'False', it takes an element from the latter list. +-- The elements taken correspond to the index of the Bool in its list. +-- For example: +-- +-- @ +-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" +-- @ +-- +-- This function does not check whether the lists have equal length. +filterByLists :: [Bool] -> [a] -> [a] -> [a] +filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys +filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys +filterByLists _ _ _ = [] + +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length; when one list runs out, the function stops. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + +stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] +-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in +-- the places where @p@ returns @True@ + +stretchZipWith _ _ _ [] _ = [] +stretchZipWith p z f (x:xs) ys + | p x = f x z : stretchZipWith p z f xs ys + | otherwise = case ys of + [] -> [] + (y:ys) -> f x y : stretchZipWith p z f xs ys + +mapFst :: (a->c) -> [(a,b)] -> [(c,b)] +mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] + +mapFst f xys = [(f x, y) | (x,y) <- xys] +mapSnd f xys = [(x, f y) | (x,y) <- xys] + +mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) + +mapAndUnzip _ [] = ([], []) +mapAndUnzip f (x:xs) + = let (r1, r2) = f x + (rs1, rs2) = mapAndUnzip f xs + in + (r1:rs1, r2:rs2) + +mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) + +mapAndUnzip3 _ [] = ([], [], []) +mapAndUnzip3 f (x:xs) + = let (r1, r2, r3) = f x + (rs1, rs2, rs3) = mapAndUnzip3 f xs + in + (r1:rs1, r2:rs2, r3:rs3) + +zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) +zipWithAndUnzip f (a:as) (b:bs) + = let (r1, r2) = f a b + (rs1, rs2) = zipWithAndUnzip f as bs + in + (r1:rs1, r2:rs2) +zipWithAndUnzip _ _ _ = ([],[]) + +-- | This has the effect of making the two lists have equal length by dropping +-- the tail of the longer one. +zipAndUnzip :: [a] -> [b] -> ([a],[b]) +zipAndUnzip (a:as) (b:bs) + = let (rs1, rs2) = zipAndUnzip as bs + in + (a:rs1, b:rs2) +zipAndUnzip _ _ = ([],[]) + +-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: +-- +-- @ +-- atLength atLenPred atEndPred ls n +-- | n < 0 = atLenPred ls +-- | length ls < n = atEndPred (n - length ls) +-- | otherwise = atLenPred (drop n ls) +-- @ +atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) + -- NB: arg passed to this function may be [] + -> b -- Called when length ls < n + -> [a] + -> Int + -> b +atLength atLenPred atEnd ls0 n0 + | n0 < 0 = atLenPred ls0 + | otherwise = go n0 ls0 + where + -- go's first arg n >= 0 + go 0 ls = atLenPred ls + go _ [] = atEnd -- n > 0 here + go n (_:xs) = go (n-1) xs + +-- Some special cases of atLength: + +-- | @(lengthExceeds xs n) = (length xs > n)@ +lengthExceeds :: [a] -> Int -> Bool +lengthExceeds lst n + | n < 0 + = True + | otherwise + = atLength notNull False lst n + +-- | @(lengthAtLeast xs n) = (length xs >= n)@ +lengthAtLeast :: [a] -> Int -> Bool +lengthAtLeast = atLength (const True) False + +-- | @(lengthIs xs n) = (length xs == n)@ +lengthIs :: [a] -> Int -> Bool +lengthIs lst n + | n < 0 + = False + | otherwise + = atLength null False lst n + +-- | @(lengthIsNot xs n) = (length xs /= n)@ +lengthIsNot :: [a] -> Int -> Bool +lengthIsNot lst n + | n < 0 = True + | otherwise = atLength notNull True lst n + +-- | @(lengthAtMost xs n) = (length xs <= n)@ +lengthAtMost :: [a] -> Int -> Bool +lengthAtMost lst n + | n < 0 + = False + | otherwise + = atLength null True lst n + +-- | @(lengthLessThan xs n) == (length xs < n)@ +lengthLessThan :: [a] -> Int -> Bool +lengthLessThan = atLength (const False) True + +listLengthCmp :: [a] -> Int -> Ordering +listLengthCmp = atLength atLen atEnd + where + atEnd = LT -- Not yet seen 'n' elts, so list length is < n. + + atLen [] = EQ + atLen _ = GT + +equalLength :: [a] -> [b] -> Bool +-- ^ True if length xs == length ys +equalLength [] [] = True +equalLength (_:xs) (_:ys) = equalLength xs ys +equalLength _ _ = False + +compareLength :: [a] -> [b] -> Ordering +compareLength [] [] = EQ +compareLength (_:xs) (_:ys) = compareLength xs ys +compareLength [] _ = LT +compareLength _ [] = GT + +leLength :: [a] -> [b] -> Bool +-- ^ True if length xs <= length ys +leLength xs ys = case compareLength xs ys of + LT -> True + EQ -> True + GT -> False + +ltLength :: [a] -> [b] -> Bool +-- ^ True if length xs < length ys +ltLength xs ys = case compareLength xs ys of + LT -> True + EQ -> False + GT -> False + +---------------------------- +singleton :: a -> [a] +singleton x = [x] + +isSingleton :: [a] -> Bool +isSingleton [_] = True +isSingleton _ = False + +notNull :: [a] -> Bool +notNull [] = False +notNull _ = True + +only :: [a] -> a +#if defined(DEBUG) +only [a] = a +#else +only (a:_) = a +#endif +only _ = panic "Util: only" + +-- Debugging/specialising versions of \tr{elem} and \tr{notElem} + +# if !defined(DEBUG) +isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool +isIn _msg x ys = x `elem` ys +isn'tIn _msg x ys = x `notElem` ys + +# else /* DEBUG */ +isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool +isIn msg x ys + = elem100 0 x ys + where + elem100 :: Eq a => Int -> a -> [a] -> Bool + elem100 _ _ [] = False + elem100 i x (y:ys) + | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) + | otherwise = x == y || elem100 (i + 1) x ys + +isn'tIn msg x ys + = notElem100 0 x ys + where + notElem100 :: Eq a => Int -> a -> [a] -> Bool + notElem100 _ _ [] = True + notElem100 i x (y:ys) + | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) + | otherwise = x /= y && notElem100 (i + 1) x ys +# endif /* DEBUG */ + + +-- | Split a list into chunks of /n/ elements +chunkList :: Int -> [a] -> [[a]] +chunkList _ [] = [] +chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs + +-- | Replace the last element of a list with another element. +changeLast :: [a] -> a -> [a] +changeLast [] _ = panic "changeLast" +changeLast [_] x = [x] +changeLast (x:xs) x' = x : changeLast xs x' + +-- | Apply an effectful function to the last list element. +-- Assumes a non-empty list (panics otherwise). +mapLastM :: Functor f => (a -> f a) -> [a] -> f [a] +mapLastM _ [] = panic "mapLastM: empty list" +mapLastM f [x] = (\x' -> [x']) <$> f x +mapLastM f (x:xs) = (x:) <$> mapLastM f xs + +whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () +whenNonEmpty [] _ = pure () +whenNonEmpty (x:xs) f = f (x :| xs) + +-- | Merge an unsorted list of sorted lists, for example: +-- +-- > mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100] +-- +-- \( O(n \log{} k) \) +mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a] +mergeListsBy cmp lists | debugIsOn, not (all sorted lists) = + -- When debugging is on, we check that the input lists are sorted. + panic "mergeListsBy: input lists must be sorted" + where sorted = isSortedBy cmp +mergeListsBy cmp all_lists = merge_lists all_lists + where + -- Implements "Iterative 2-Way merge" described at + -- https://en.wikipedia.org/wiki/K-way_merge_algorithm + + -- Merge two sorted lists into one in O(n). + merge2 :: [a] -> [a] -> [a] + merge2 [] ys = ys + merge2 xs [] = xs + merge2 (x:xs) (y:ys) = + case cmp x y of + GT -> y : merge2 (x:xs) ys + _ -> x : merge2 xs (y:ys) + + -- Merge the first list with the second, the third with the fourth, and so + -- on. The output has half as much lists as the input. + merge_neighbours :: [[a]] -> [[a]] + merge_neighbours [] = [] + merge_neighbours [xs] = [xs] + merge_neighbours (xs : ys : lists) = + merge2 xs ys : merge_neighbours lists + + -- Since 'merge_neighbours' halves the amount of lists in each iteration, + -- we perform O(log k) iteration. Each iteration is O(n). The total running + -- time is therefore O(n log k). + merge_lists :: [[a]] -> [a] + merge_lists lists = + case merge_neighbours lists of + [] -> [] + [xs] -> xs + lists' -> merge_lists lists' + +isSortedBy :: (a -> a -> Ordering) -> [a] -> Bool +isSortedBy cmp = sorted + where + sorted [] = True + sorted [_] = True + sorted (x:y:xs) = cmp x y /= GT && sorted (y:xs) +{- +************************************************************************ +* * +\subsubsection{Sort utils} +* * +************************************************************************ +-} + +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList + +-- | Remove duplicates but keep elements in order. +-- O(n * log n) +ordNub :: Ord a => [a] -> [a] +ordNub xs + = go Set.empty xs + where + go _ [] = [] + go s (x:xs) + | Set.member x s = go s xs + | otherwise = x : go (Set.insert x s) xs + + +{- +************************************************************************ +* * +\subsection[Utils-transitive-closure]{Transitive closure} +* * +************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. +-} + +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = go [] xs + where + go done [] = done + go done (x:xs) | x `is_in` done = go done xs + | otherwise = go (x:done) (succ x ++ xs) + + _ `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys + +{- +************************************************************************ +* * +\subsection[Utils-accum]{Accumulating} +* * +************************************************************************ + +A combination of foldl with zip. It works with equal length lists. +-} + +foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc +foldl2 _ z [] [] = z +foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs +foldl2 _ _ _ _ = panic "Util: foldl2" + +all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- True if the lists are the same length, and +-- all corresponding elements satisfy the predicate +all2 _ [] [] = True +all2 p (x:xs) (y:ys) = p x y && all2 p xs ys +all2 _ _ _ = False + +-- Count the number of times a predicate is true + +count :: (a -> Bool) -> [a] -> Int +count p = go 0 + where go !n [] = n + go !n (x:xs) | p x = go (n+1) xs + | otherwise = go n xs + +countWhile :: (a -> Bool) -> [a] -> Int +-- Length of an /initial prefix/ of the list satisfying p +countWhile p = go 0 + where go !n (x:xs) | p x = go (n+1) xs + go !n _ = n + +{- +@splitAt@, @take@, and @drop@ but with length of another +list giving the break-off point: +-} + +takeList :: [b] -> [a] -> [a] +-- (takeList as bs) trims bs to the be same length +-- as as, unless as is longer in which case it's a no-op +takeList [] _ = [] +takeList (_:xs) ls = + case ls of + [] -> [] + (y:ys) -> y : takeList xs ys + +dropList :: [b] -> [a] -> [a] +dropList [] xs = xs +dropList _ xs@[] = xs +dropList (_:xs) (_:ys) = dropList xs ys + + +splitAtList :: [b] -> [a] -> ([a], [a]) +splitAtList [] xs = ([], xs) +splitAtList _ xs@[] = (xs, xs) +splitAtList (_:xs) (y:ys) = (y:ys', ys'') + where + (ys', ys'') = splitAtList xs ys + +-- drop from the end of a list +dropTail :: Int -> [a] -> [a] +-- Specification: dropTail n = reverse . drop n . reverse +-- Better implemention due to Joachim Breitner +-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html +dropTail n xs + = go (drop n xs) xs + where + go (_:ys) (x:xs) = x : go ys xs + go _ _ = [] -- Stop when ys runs out + -- It'll always run out before xs does + +-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, +-- but is lazy in the elements and strict in the spine. For reasonably short lists, +-- such as path names and typical lines of text, dropWhileEndLE is generally +-- faster than dropWhileEnd. Its advantage is magnified when the predicate is +-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text +-- is generally much faster than using dropWhileEnd isSpace for that purpose. +-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse +-- Pay attention to the short-circuit (&&)! The order of its arguments is the only +-- difference between dropWhileEnd and dropWhileEndLE. +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +-- | @spanEnd p l == reverse (span p (reverse l))@. The first list +-- returns actually comes after the second list (when you look at the +-- input list). +spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) +spanEnd p l = go l [] [] l + where go yes _rev_yes rev_no [] = (yes, reverse rev_no) + go yes rev_yes rev_no (x:xs) + | p x = go yes (x : rev_yes) rev_no xs + | otherwise = go xs [] (x : rev_yes ++ rev_no) xs + +-- | Get the last two elements in a list. Partial! +{-# INLINE last2 #-} +last2 :: [a] -> (a,a) +last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) + where + partialError = panic "last2 - list length less than two" + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe xs = Just $ last xs + +-- | Split a list into its last element and the initial part of the list. +-- @snocView xs = Just (init xs, last xs)@ for non-empty lists. +-- @snocView xs = Nothing@ otherwise. +-- Unless both parts of the result are guaranteed to be used +-- prefer separate calls to @last@ + @init@. +-- If you are guaranteed to use both, this will +-- be more efficient. +snocView :: [a] -> Maybe ([a],a) +snocView [] = Nothing +snocView xs + | (xs,x) <- go xs + = Just (xs,x) + where + go :: [a] -> ([a],a) + go [x] = ([],x) + go (x:xs) + | !(xs',x') <- go xs + = (x:xs', x') + go [] = error "impossible" + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s + +-- | Convert a word to title case by capitalising the first letter +capitalise :: String -> String +capitalise [] = [] +capitalise (c:cs) = toUpper c : cs + + +{- +************************************************************************ +* * +\subsection[Utils-comparison]{Comparisons} +* * +************************************************************************ +-} + +isEqual :: Ordering -> Bool +-- Often used in (isEqual (a `compare` b)) +isEqual GT = False +isEqual EQ = True +isEqual LT = False + +thenCmp :: Ordering -> Ordering -> Ordering +{-# INLINE thenCmp #-} +thenCmp EQ ordering = ordering +thenCmp ordering _ = ordering + +eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool +eqListBy _ [] [] = True +eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys +eqListBy _ _ _ = False + +eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool +eqMaybeBy _ Nothing Nothing = True +eqMaybeBy eq (Just x) (Just y) = eq x y +eqMaybeBy _ _ _ = False + +cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering + -- `cmpList' uses a user-specified comparer + +cmpList _ [] [] = EQ +cmpList _ [] _ = LT +cmpList _ _ [] = GT +cmpList cmp (a:as) (b:bs) + = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } + +removeSpaces :: String -> String +removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace + +-- Boolean operators lifted to Applicative +(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>) = liftA2 (&&) +infixr 3 <&&> -- same as (&&) + +(<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) = liftA2 (||) +infixr 2 <||> -- same as (||) + +{- +************************************************************************ +* * +\subsection{Edit distance} +* * +************************************************************************ +-} + +-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. +-- See: . +-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing +-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). +-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and +-- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation +restrictedDamerauLevenshteinDistance :: String -> String -> Int +restrictedDamerauLevenshteinDistance str1 str2 + = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + where + m = length str1 + n = length str2 + +restrictedDamerauLevenshteinDistanceWithLengths + :: Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + | m <= n + = if n <= 32 -- n must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 + + | otherwise + = if m <= 32 -- m must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 + +restrictedDamerauLevenshteinDistance' + :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 + | [] <- str1 = n + | otherwise = extractAnswer $ + foldl' (restrictedDamerauLevenshteinDistanceWorker + (matchVectors str1) top_bit_mask vector_mask) + (0, 0, m_ones, 0, m) str2 + where + m_ones@vector_mask = (2 ^ m) - 1 + top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy + extractAnswer (_, _, _, _, distance) = distance + +restrictedDamerauLevenshteinDistanceWorker + :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv + -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) +restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask + (pm, d0, vp, vn, distance) char2 + = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ + seq pm' $ seq d0' $ seq vp' $ seq vn' $ + seq distance'' $ seq char2 $ + (pm', d0', vp', vn', distance'') + where + pm' = IM.findWithDefault 0 (ord char2) str1_mvs + + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) + .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn + -- No need to mask the shiftL because of the restricted range of pm + + hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) + hn' = d0' .&. vp + + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask + hn'_shift = (hn' `shiftL` 1) .&. vector_mask + vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) + vn' = d0' .&. hp'_shift + + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance + distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' + +sizedComplement :: Bits bv => bv -> bv -> bv +sizedComplement vector_mask vect = vector_mask `xor` vect + +matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv +matchVectors = snd . foldl' go (0 :: Int, IM.empty) + where + go (ix, im) char = let ix' = ix + 1 + im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im + in seq ix' $ seq im' $ (ix', im') + +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Word32 -> Int -> Int -> String -> String -> Int #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Integer -> Int -> Int -> String -> String -> Int #-} + +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Word32 -> Word32 -> Word32 + -> (Word32, Word32, Word32, Word32, Int) + -> Char -> (Word32, Word32, Word32, Word32, Int) #-} +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Integer -> Integer -> Integer + -> (Integer, Integer, Integer, Integer, Int) + -> Char -> (Integer, Integer, Integer, Integer, Int) #-} + +{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} + +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} + +fuzzyMatch :: String -> [String] -> [String] +fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] + +-- | Search for possible matches to the users input in the given list, +-- returning a small number of ranked results +fuzzyLookup :: String -> [(String,a)] -> [a] +fuzzyLookup user_entered possibilites + = map fst $ take mAX_RESULTS $ sortBy (comparing snd) + [ (poss_val, distance) | (poss_str, poss_val) <- possibilites + , let distance = restrictedDamerauLevenshteinDistance + poss_str user_entered + , distance <= fuzzy_threshold ] + where + -- Work out an appropriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, + -- The threshold is set to about a quarter of the # of characters the user entered + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 + -- + fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) + mAX_RESULTS = 3 + +{- +************************************************************************ +* * +\subsection[Utils-pairs]{Pairs} +* * +************************************************************************ +-} + +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs + +seqList :: [a] -> b -> b +seqList [] b = b +seqList (x:xs) b = x `seq` seqList xs b + +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x : xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' + +{- +************************************************************************ +* * + Globals and the RTS +* * +************************************************************************ + +When a plugin is loaded, it currently gets linked against a *newly +loaded* copy of the GHC package. This would not be a problem, except +that the new copy has its own mutable state that is not shared with +that state that has already been initialized by the original GHC +package. + +(Note that if the GHC executable was dynamically linked this +wouldn't be a problem, because we could share the GHC library it +links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) + +The solution is to make use of @sharedCAF@ through @sharedGlobal@ +for globals that are shared between multiple copies of ghc packages. +-} + +-- Global variables: + +global :: a -> IORef a +global a = unsafePerformIO (newIORef a) + +consIORef :: IORef [a] -> a -> IO () +consIORef var x = do + atomicModifyIORef' var (\xs -> (x:xs,())) + +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) + +-- Shared global variables: + +sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobal a get_or_set = unsafePerformIO $ + newIORef a >>= flip sharedCAF get_or_set + +sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobalM ma get_or_set = unsafePerformIO $ + ma >>= newIORef >>= flip sharedCAF get_or_set + +-- Module names: + +looksLikeModuleName :: String -> Bool +looksLikeModuleName [] = False +looksLikeModuleName (c:cs) = isUpper c && go cs + where go [] = True + go ('.':cs) = looksLikeModuleName cs + go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs + +-- Similar to 'parse' for Distribution.Package.PackageName, +-- but we don't want to depend on Cabal. +looksLikePackageName :: String -> Bool +looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' + +{- +Akin to @Prelude.words@, but acts like the Bourne shell, treating +quoted strings as Haskell Strings, and also parses Haskell [String] +syntax. +-} + +getCmd :: String -> Either String -- Error + (String, String) -- (Cmd, Rest) +getCmd s = case break isSpace $ dropWhile isSpace s of + ([], _) -> Left ("Couldn't find command in " ++ show s) + res -> Right res + +toCmdArgs :: String -> Either String -- Error + (String, [String]) -- (Cmd, Args) +toCmdArgs s = case getCmd s of + Left err -> Left err + Right (cmd, s') -> case toArgs s' of + Left err -> Left err + Right args -> Right (cmd, args) + +toArgs :: String -> Either String -- Error + [String] -- Args +toArgs str + = case dropWhile isSpace str of + s@('[':_) -> case reads s of + [(args, spaces)] + | all isSpace spaces -> + Right args + _ -> + Left ("Couldn't read " ++ show str ++ " as [String]") + s -> toArgs' s + where + toArgs' :: String -> Either String [String] + -- Remove outer quotes: + -- > toArgs' "\"foo\" \"bar baz\"" + -- Right ["foo", "bar baz"] + -- + -- Keep inner quotes: + -- > toArgs' "-DFOO=\"bar baz\"" + -- Right ["-DFOO=\"bar baz\""] + toArgs' s = case dropWhile isSpace s of + [] -> Right [] + ('"' : _) -> do + -- readAsString removes outer quotes + (arg, rest) <- readAsString s + (arg:) `fmap` toArgs' rest + s' -> case break (isSpace <||> (== '"')) s' of + (argPart1, s''@('"':_)) -> do + (argPart2, rest) <- readAsString s'' + -- show argPart2 to keep inner quotes + ((argPart1 ++ show argPart2):) `fmap` toArgs' rest + (arg, s'') -> (arg:) `fmap` toArgs' s'' + + readAsString :: String -> Either String (String, String) + readAsString s = case reads s of + [(arg, rest)] + -- rest must either be [] or start with a space + | all isSpace (take 1 rest) -> + Right (arg, rest) + _ -> + Left ("Couldn't read " ++ show s ++ " as String") +----------------------------------------------------------------------------- +-- Integers + +-- | Determine the $\log_2$ of exact powers of 2 +exactLog2 :: Integer -> Maybe Integer +exactLog2 x + | x <= 0 = Nothing + | x > fromIntegral (maxBound :: Int32) = Nothing + | x' .&. (-x') /= x' = Nothing + | otherwise = Just (fromIntegral c) + where + x' = fromIntegral x :: Int32 + c = countTrailingZeros x' + +{- +-- ----------------------------------------------------------------------------- +-- Floats +-} + +readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" +readRational__ r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t) + where + readFix r = do + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + readDec s = do + (ds,r) <- nonnull isDigit s + return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], + r) + + lexDecDigits = nonnull isDigit + + lexDotDigits ('.':s) = return (span' isDigit s) + lexDotDigits s = return ("",s) + + nonnull p s = do (cs@(_:_),t) <- return (span' p s) + return (cs,t) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readRational :: String -> Rational -- NB: *does* handle a leading "-" +readRational top_s + = case top_s of + '-' : xs -> - (read_me xs) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readRational__ s ; return x }) of + [x] -> x + [] -> error ("readRational: no parse:" ++ top_s) + _ -> error ("readRational: ambiguous parse:" ++ top_s) + + +readHexRational :: String -> Rational +readHexRational str = + case str of + '-' : xs -> - (readMe xs) + xs -> readMe xs + where + readMe as = + case readHexRational__ as of + Just n -> n + _ -> error ("readHexRational: no parse:" ++ str) + + +readHexRational__ :: String -> Maybe Rational +readHexRational__ ('0' : x : rest) + | x == 'X' || x == 'x' = + do let (front,rest2) = span' isHexDigit rest + guard (not (null front)) + let frontNum = steps 16 0 front + case rest2 of + '.' : rest3 -> + do let (back,rest4) = span' isHexDigit rest3 + guard (not (null back)) + let backNum = steps 16 frontNum back + exp1 = -4 * length back + case rest4 of + p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) + _ -> return (mk backNum exp1) + p : ps | isExp p -> fmap (mk frontNum) (getExp ps) + _ -> Nothing + + where + isExp p = p == 'p' || p == 'P' + + getExp ('+' : ds) = dec ds + getExp ('-' : ds) = fmap negate (dec ds) + getExp ds = dec ds + + mk :: Integer -> Int -> Rational + mk n e = fromInteger n * 2^^e + + dec cs = case span' isDigit cs of + (ds,"") | not (null ds) -> Just (steps 10 0 ds) + _ -> Nothing + + steps base n ds = foldl' (step base) n ds + step base n d = base * n + fromIntegral (digitToInt d) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readHexRational__ _ = Nothing + +----------------------------------------------------------------------------- +-- Verify that the 'dirname' portion of a FilePath exists. +-- +doesDirNameExist :: FilePath -> IO Bool +doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) + +----------------------------------------------------------------------------- +-- Backwards compatibility definition of getModificationTime + +getModificationUTCTime :: FilePath -> IO UTCTime +getModificationUTCTime = getModificationTime + +-- -------------------------------------------------------------- +-- check existence & modification time at the same time + +modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +modificationTimeIfExists f = do + (do t <- getModificationUTCTime f; return (Just t)) + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- +-- atomic file writing by writing to a temporary file first (see #14533) +-- +-- This should be used in all cases where GHC writes files to disk +-- and uses their modification time to skip work later, +-- as otherwise a partially written file (e.g. due to crash or Ctrl+C) +-- also results in a skip. + +withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a +withAtomicRename targetFile f = do + -- The temp file must be on the same file system (mount) as the target file + -- to result in an atomic move on most platforms. + -- The standard way to ensure that is to place it into the same directory. + -- This can still be fooled when somebody mounts a different file system + -- at just the right time, but that is not a case we aim to cover here. + let temp = targetFile <.> "tmp" + res <- f temp + liftIO $ renameFile temp targetFile + return res + +-- -------------------------------------------------------------- +-- split a string at the last character where 'pred' is True, +-- returning a pair of strings. The first component holds the string +-- up (but not including) the last character for which 'pred' returned +-- True, the second whatever comes after (but also not including the +-- last character). +-- +-- If 'pred' returns False for all characters in the string, the original +-- string is returned in the first component (and the second one is just +-- empty). +splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) +splitLongestPrefix str pred + | null r_pre = (str, []) + | otherwise = (reverse (tail r_pre), reverse r_suf) + -- 'tail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred (reverse str) + +escapeSpaces :: String -> String +escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" + +type Suffix = String + +-------------------------------------------------------------- +-- * Search path +-------------------------------------------------------------- + +data Direction = Forwards | Backwards + +reslash :: Direction -> FilePath -> FilePath +reslash d = f + where f ('/' : xs) = slash : f xs + f ('\\' : xs) = slash : f xs + f (x : xs) = x : f xs + f "" = "" + slash = case d of + Forwards -> '/' + Backwards -> '\\' + +makeRelativeTo :: FilePath -> FilePath -> FilePath +this `makeRelativeTo` that = directory thisFilename + where (thisDirectory, thisFilename) = splitFileName this + thatDirectory = dropFileName that + directory = joinPath $ f (splitPath thisDirectory) + (splitPath thatDirectory) + + f (x : xs) (y : ys) + | x == y = f xs ys + f xs ys = replicate (length ys) ".." ++ xs + +{- +************************************************************************ +* * +\subsection[Utils-Data]{Utils for defining Data instances} +* * +************************************************************************ + +These functions helps us to define Data instances for abstract types. +-} + +abstractConstr :: String -> Constr +abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix + +abstractDataType :: String -> DataType +abstractDataType n = mkDataType n [abstractConstr n] + +{- +************************************************************************ +* * +\subsection[Utils-C]{Utils for printing C code} +* * +************************************************************************ +-} + +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] + +{- +************************************************************************ +* * +\subsection[Utils-Hashing]{Utils for hashing} +* * +************************************************************************ +-} + +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = fromIntegral (0xdeadbeef :: Word32) + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +-- | A sample (and useful) hash function for Int32, +-- implemented by extracting the uppermost 32 bits of the 64-bit +-- result of multiplying by a 33-bit constant. The constant is from +-- Knuth, derived from the golden ratio: +-- +-- > golden = round ((sqrt 5 - 1) * 2^32) +-- +-- We get good key uniqueness on small inputs +-- (a problem with previous versions): +-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 +-- +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b + +-- | A call stack constraint, but only when 'isDebugOn'. +#if defined(DEBUG) +type HasDebugCallStack = HasCallStack +#else +type HasDebugCallStack = (() :: Constraint) +#endif + +data OverridingBool + = Auto + | Always + | Never + deriving Show + +overrideWith :: Bool -> OverridingBool -> Bool +overrideWith b Auto = b +overrideWith _ Always = True +overrideWith _ Never = False diff --git a/GHC/Utils/Monad.hs b/GHC/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Monad.hs @@ -0,0 +1,228 @@ +-- | Utilities related to Monad and Applicative classes +-- Mostly for backwards compatibility. + +module GHC.Utils.Monad + ( Applicative(..) + , (<$>) + + , MonadFix(..) + , MonadIO(..) + + , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M + , mapAccumLM + , mapSndM + , concatMapM + , mapMaybeM + , fmapMaybeM, fmapEitherM + , anyM, allM, orM + , foldlM, foldlM_, foldrM + , maybeMapM + , whenM, unlessM + , filterOutM + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import GHC.Prelude + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.Foldable (sequenceA_, foldlM, foldrM) +import Data.List (unzip4, unzip5, zipWith4) + +------------------------------------------------------------------------------- +-- Common functions +-- These are used throughout the compiler +------------------------------------------------------------------------------- + +{- + +Note [Inline @zipWithNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same +as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see +Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. + +The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and +`sequenceA` functions with which they are defined have an opportunity to fuse. + +Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly +rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for +more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) +for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning +'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and +'zipWithM_', respectively, with regards to fusion. + +As such, since there are not any differences between 2-ary 'zipWithM'/ +'zipWithM_' and their n-ary counterparts below aside from the number of +arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ +functions below as well. + +-} + +zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] +{-# INLINE zipWith3M #-} +-- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M f xs ys zs = sequenceA (zipWith3 f xs ys zs) + +zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () +{-# INLINE zipWith3M_ #-} +-- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M_ f xs ys zs = sequenceA_ (zipWith3 f xs ys zs) + +zipWith4M :: Monad m => (a -> b -> c -> d -> m e) + -> [a] -> [b] -> [c] -> [d] -> m [e] +{-# INLINE zipWith4M #-} +-- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith4M f xs ys ws zs = sequenceA (zipWith4 f xs ys ws zs) + +zipWithAndUnzipM :: Monad m + => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +{-# INLINABLE zipWithAndUnzipM #-} +-- See Note [flatten_args performance] in GHC.Tc.Solver.Flatten for why this +-- pragma is essential. +zipWithAndUnzipM f (x:xs) (y:ys) + = do { (c, d) <- f x y + ; (cs, ds) <- zipWithAndUnzipM f xs ys + ; return (c:cs, d:ds) } +zipWithAndUnzipM _ _ _ = return ([], []) + +{- + +Note [Inline @mapAndUnzipNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". +The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` +functions with which it is defined have an opportunity to fuse, see +Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. + +Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a +non-recursive way similarly to 'mapAndUnzipM', and for more than just +uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac +ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', +'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards +to fusion. + +As such, since there are not any differences between 2-ary 'mapAndUnzipM' and +its n-ary counterparts below aside from the number of arguments, the `INLINE` +pragma should be replicated in the @mapAndUnzipNM@ functions below as well. + +-} + +-- | mapAndUnzipM for triples +mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) +{-# INLINE mapAndUnzip3M #-} +-- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip3M f xs = unzip3 <$> traverse f xs + +mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) +{-# INLINE mapAndUnzip4M #-} +-- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip4M f xs = unzip4 <$> traverse f xs + +mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) +{-# INLINE mapAndUnzip5M #-} +-- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip5M f xs = unzip5 <$> traverse f xs + +-- TODO: mapAccumLM is used in many places. Surely most of +-- these don't actually want to be lazy. We should add a strict +-- variant and use it where appropriate. + +-- | Monadic version of mapAccumL +mapAccumLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> [x] -- ^ inputs + -> m (acc, [y]) -- ^ final state, outputs +mapAccumLM f s xs = + go s xs + where + go s (x:xs) = do + (s1, x') <- f s x + (s2, xs') <- go s1 xs + return (s2, x' : xs') + go s [] = return (s, []) + +-- | Monadic version of mapSnd +mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] +mapSndM f xs = go xs + where + go [] = return [] + go ((a,b):xs) = do { c <- f b; rs <- go xs; return ((a,c):rs) } + +-- | Monadic version of concatMap +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +-- | Applicative version of mapMaybe +mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = foldr g (pure []) + where g a = liftA2 (maybe id (:)) (f a) + +-- | Monadic version of fmap +fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) +fmapMaybeM _ Nothing = return Nothing +fmapMaybeM f (Just x) = f x >>= (return . Just) + +-- | Monadic version of fmap +fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) +fmapEitherM fl _ (Left a) = fl a >>= (return . Left) +fmapEitherM _ fr (Right b) = fr b >>= (return . Right) + +-- | Monadic version of 'any', aborts the computation at the first @True@ value +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM f xs = go xs + where + go [] = return False + go (x:xs) = do b <- f x + if b then return True + else go xs + +-- | Monad version of 'all', aborts the computation at the first @False@ value +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM f bs = go bs + where + go [] = return True + go (b:bs) = (f b) >>= (\bv -> if bv then go bs else return False) + +-- | Monadic version of or +orM :: Monad m => m Bool -> m Bool -> m Bool +orM m1 m2 = m1 >>= \x -> if x then return True else m2 + +-- | Monadic version of foldl that discards its result +foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () +foldlM_ = foldM_ + +-- | Monadic version of fmap specialised for Maybe +maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) +maybeMapM _ Nothing = return Nothing +maybeMapM m (Just x) = liftM Just $ m x + +-- | Monadic version of @when@, taking the condition in the monad +whenM :: Monad m => m Bool -> m () -> m () +whenM mb thing = do { b <- mb + ; when b thing } + +-- | Monadic version of @unless@, taking the condition in the monad +unlessM :: Monad m => m Bool -> m () -> m () +unlessM condM acc = do { cond <- condM + ; unless cond acc } + +-- | Like 'filterM', only it reverses the sense of the test. +filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterOutM p = + foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) diff --git a/GHC/Utils/Monad/State.hs b/GHC/Utils/Monad/State.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Monad/State.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.Utils.Monad.State where + +import GHC.Prelude + +newtype State s a = State { runState' :: s -> (# a, s #) } + deriving (Functor) + +instance Applicative (State s) where + pure x = State $ \s -> (# x, s #) + m <*> n = State $ \s -> case runState' m s of + (# f, s' #) -> case runState' n s' of + (# x, s'' #) -> (# f x, s'' #) + +instance Monad (State s) where + m >>= n = State $ \s -> case runState' m s of + (# r, s' #) -> runState' (n r) s' + +get :: State s s +get = State $ \s -> (# s, s #) + +gets :: (s -> a) -> State s a +gets f = State $ \s -> (# f s, s #) + +put :: s -> State s () +put s' = State $ \_ -> (# (), s' #) + +modify :: (s -> s) -> State s () +modify f = State $ \s -> (# (), f s #) + + +evalState :: State s a -> s -> a +evalState s i = case runState' s i of + (# a, _ #) -> a + + +execState :: State s a -> s -> s +execState s i = case runState' s i of + (# _, s' #) -> s' + + +runState :: State s a -> s -> (a, s) +runState s i = case runState' s i of + (# a, s' #) -> (a, s') diff --git a/GHC/Utils/Outputable.hs b/GHC/Utils/Outputable.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Outputable.hs @@ -0,0 +1,1306 @@ +{-# LANGUAGE LambdaCase #-} + +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-1998 +-} + +-- | This module defines classes and functions for pretty-printing. It also +-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. +-- +-- The interface to this module is very similar to the standard Hughes-PJ pretty printing +-- module, except that it exports a number of additional functions that are rarely used, +-- and works over the 'SDoc' type. +module GHC.Utils.Outputable ( + -- * Type classes + Outputable(..), OutputableBndr(..), + + -- * Pretty printing combinators + SDoc, runSDoc, initSDocContext, + docToSDoc, + interppSP, interpp'SP, + pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, + pprWithBars, + empty, isEmpty, nest, + char, + text, ftext, ptext, ztext, + int, intWithCommas, integer, word, float, double, rational, doublePrec, + parens, cparen, brackets, braces, quotes, quote, + doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, vbar, + arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow, + blankLine, forAllLit, bullet, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, hangNotEmpty, punctuate, ppWhen, ppUnless, + ppWhenOption, ppUnlessOption, + speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, itsOrTheir, + unicodeSyntax, + + coloured, keyword, + + -- * Converting 'SDoc' into strings and outputting it + printSDoc, printSDocLn, printForUser, + printForC, bufLeftRenderSDoc, + pprCode, mkCodeStyle, + showSDoc, showSDocUnsafe, showSDocOneLine, + showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, + showSDocUnqual, showPpr, + renderWithStyle, + + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsBytes, + + primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, + primInt64Suffix, primWord64Suffix, primIntSuffix, + + pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, + + pprFastFilePath, pprFilePathString, + + -- * Controlling the style in which output is printed + BindingSite(..), + + PprStyle(..), CodeStyle(..), PrintUnqualified(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + reallyAlwaysQualify, reallyAlwaysQualifyNames, + alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, + neverQualify, neverQualifyNames, neverQualifyModules, + alwaysQualifyPackages, neverQualifyPackages, + QualifyName(..), queryQual, + sdocWithDynFlags, sdocOption, + updSDocContext, + SDocContext (..), sdocWithContext, + getPprStyle, withPprStyle, setStyleColoured, + pprDeeper, pprDeeperList, pprSetDepth, + codeStyle, userStyle, dumpStyle, asmStyle, + qualName, qualModule, qualPackage, + mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, + mkUserStyle, cmdlineParserStyle, Depth(..), + withUserStyle, withErrStyle, + + ifPprDebug, whenPprDebug, getPprDebug, + + -- * Error handling and debugging utilities + pprPanic, pprSorry, assertPprPanic, pprPgmError, + pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace, + pprSTrace, pprTraceException, pprTraceM, pprTraceWithFlags, + trace, pgmError, panic, sorry, assertPanic, + pprDebugAndThen, callStackDoc, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Driver.Session + ( DynFlags, hasPprDebug, hasNoDebugOutput + , unsafeGlobalDynFlags, initSDocContext + ) +import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) +import {-# SOURCE #-} GHC.Unit.Module.Name( ModuleName ) +import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) + +import GHC.Utils.BufHandle (BufHandle) +import GHC.Data.FastString +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.Misc +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Utils.Ppr ( Doc, Mode(..) ) +import GHC.Utils.Panic +import GHC.Serialized +import GHC.LanguageExtensions (Extension) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char +import qualified Data.Map as M +import Data.Int +import qualified Data.IntMap as IM +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Word +import System.IO ( Handle ) +import System.FilePath +import Text.Printf +import Numeric (showFFloat) +import Data.Graph (SCC(..)) +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL + +import GHC.Fingerprint +import GHC.Show ( showMultiLineString ) +import GHC.Stack ( callStack, prettyCallStack ) +import Control.Monad.IO.Class +import GHC.Utils.Exception + +{- +************************************************************************ +* * +\subsection{The @PprStyle@ data type} +* * +************************************************************************ +-} + +data PprStyle + = PprUser PrintUnqualified Depth Coloured + -- Pretty-print in a way that will make sense to the + -- ordinary user; must be very close to Haskell + -- syntax, etc. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. + + | PprDump PrintUnqualified + -- For -ddump-foo; less verbose than in ppr-debug mode, but more than PprUser + -- Does not assume tidied code: non-external names + -- are printed with uniques. + + | PprCode CodeStyle + -- Print code; either C or assembler + +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle + +data Depth + = AllTheWay + | PartWay Int -- ^ 0 => stop + | DefaultDepth -- ^ Use 'sdocDefaultDepth' field as depth + +data Coloured + = Uncoloured + | Coloured + +-- ----------------------------------------------------------------------------- +-- Printing original names + +-- | When printing code that contains original names, we need to map the +-- original names back to something the user understands. This is the +-- purpose of the triple of functions that gets passed around +-- when rendering 'SDoc'. +data PrintUnqualified = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage +} + +-- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify +-- it. +type QueryQualifyName = Module -> OccName -> QualifyName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool + +-- | For a given package, we need to know whether to print it with +-- the component id to disambiguate it. +type QueryQualifyPackage = Unit -> Bool + +-- See Note [Printing original names] in GHC.Driver.Types +data QualifyName -- Given P:M.T + = NameUnqual -- It's in scope unqualified as "T" + -- OR nothing called "T" is in scope + + | NameQual ModuleName -- It's in scope qualified as "X.T" + + | NameNotInScope1 -- It's not in scope at all, but M.T is not bound + -- in the current scope, so we can refer to it as "M.T" + + | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in + -- the current scope, so we must refer to it as "P:M.T" + +instance Outputable QualifyName where + ppr NameUnqual = text "NameUnqual" + ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( + ppr NameNotInScope1 = text "NameNotInScope1" + ppr NameNotInScope2 = text "NameNotInScope2" + +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m _ = NameQual (moduleName m) + +neverQualifyNames :: QueryQualifyName +neverQualifyNames _ _ = NameUnqual + +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules _ = True + +neverQualifyModules :: QueryQualifyModule +neverQualifyModules _ = False + +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages + +defaultUserStyle :: PprStyle +defaultUserStyle = mkUserStyle neverQualify AllTheWay + +defaultDumpStyle :: PprStyle + -- Print without qualifiers to reduce verbosity, unless -dppr-debug +defaultDumpStyle = PprDump neverQualify + +mkDumpStyle :: PrintUnqualified -> PprStyle +mkDumpStyle print_unqual = PprDump print_unqual + +-- | Default style for error messages, when we don't know PrintUnqualified +-- It's a bit of a hack because it doesn't take into account what's in scope +-- Only used for desugarer warnings, and typechecker errors in interface sigs +defaultErrStyle :: PprStyle +defaultErrStyle = mkErrStyle neverQualify + +-- | Style for printing error messages +mkErrStyle :: PrintUnqualified -> PprStyle +mkErrStyle unqual = mkUserStyle unqual DefaultDepth + +cmdlineParserStyle :: PprStyle +cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay + +mkUserStyle :: PrintUnqualified -> Depth -> PprStyle +mkUserStyle unqual depth = PprUser unqual depth Uncoloured + +withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc +withUserStyle unqual depth doc = withPprStyle (PprUser unqual depth Uncoloured) doc + +withErrStyle :: PrintUnqualified -> SDoc -> SDoc +withErrStyle unqual doc = + withPprStyle (mkErrStyle unqual) doc + +setStyleColoured :: Bool -> PprStyle -> PprStyle +setStyleColoured col style = + case style of + PprUser q d _ -> PprUser q d c + _ -> style + where + c | col = Coloured + | otherwise = Uncoloured + +instance Outputable PprStyle where + ppr (PprUser {}) = text "user-style" + ppr (PprCode {}) = text "code-style" + ppr (PprDump {}) = text "dump-style" + +{- +Orthogonal to the above printing styles are (possibly) some +command-line flags that affect printing (often carried with the +style). The most likely ones are variations on how much type info is +shown. + +The following test decides whether or not we are actually generating +code (either C or assembly), or generating interface files. + +************************************************************************ +* * +\subsection{The @SDoc@ data type} +* * +************************************************************************ +-} + +-- | Represents a pretty-printable document. +-- +-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', +-- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the +-- abstraction layer. +newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } + +data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocColScheme :: !Col.Scheme + , sdocLastColour :: !Col.PprColour + -- ^ The most recently used colour. + -- This allows nesting colours. + , sdocShouldUseColor :: !Bool + , sdocDefaultDepth :: !Int + , sdocLineLength :: !Int + , sdocCanUseUnicode :: !Bool + -- ^ True if Unicode encoding is supported + -- and not disable by GHC_NO_UNICODE environment variable + , sdocHexWordLiterals :: !Bool + , sdocPprDebug :: !Bool + , sdocPrintUnicodeSyntax :: !Bool + , sdocPrintCaseAsLet :: !Bool + , sdocPrintTypecheckerElaboration :: !Bool + , sdocPrintAxiomIncomps :: !Bool + , sdocPrintExplicitKinds :: !Bool + , sdocPrintExplicitCoercions :: !Bool + , sdocPrintExplicitRuntimeReps :: !Bool + , sdocPrintExplicitForalls :: !Bool + , sdocPrintPotentialInstances :: !Bool + , sdocPrintEqualityRelations :: !Bool + , sdocSuppressTicks :: !Bool + , sdocSuppressTypeSignatures :: !Bool + , sdocSuppressTypeApplications :: !Bool + , sdocSuppressIdInfo :: !Bool + , sdocSuppressCoercions :: !Bool + , sdocSuppressUnfoldings :: !Bool + , sdocSuppressVarKinds :: !Bool + , sdocSuppressUniques :: !Bool + , sdocSuppressModulePrefixes :: !Bool + , sdocSuppressStgExts :: !Bool + , sdocErrorSpans :: !Bool + , sdocStarIsType :: !Bool + , sdocLinearTypes :: !Bool + , sdocImpredicativeTypes :: !Bool + , sdocPrintTypeAbbreviations :: !Bool + , sdocDynFlags :: DynFlags -- TODO: remove + } + +instance IsString SDoc where + fromString = text + +-- The lazy programmer's friend. +instance Outputable SDoc where + ppr = id + + +withPprStyle :: PprStyle -> SDoc -> SDoc +withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} + +pprDeeper :: SDoc -> SDoc +pprDeeper d = SDoc $ \ctx -> case sdocStyle ctx of + PprUser q depth c -> + let deeper 0 = Pretty.text "..." + deeper n = runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + in case depth of + DefaultDepth -> deeper (sdocDefaultDepth ctx) + PartWay n -> deeper n + AllTheWay -> runSDoc d ctx + _ -> runSDoc d ctx + + +-- | Truncate a list that is longer than the current depth. +pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc +pprDeeperList f ds + | null ds = f [] + | otherwise = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q depth c} + | DefaultDepth <- depth + = work (ctx { sdocStyle = PprUser q (PartWay (sdocDefaultDepth ctx)) c }) + | PartWay 0 <- depth + = Pretty.text "..." + | PartWay n <- depth + = let + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + in runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + work other_ctx = runSDoc (f ds) other_ctx + +pprSetDepth :: Depth -> SDoc -> SDoc +pprSetDepth depth doc = SDoc $ \ctx -> + case ctx of + SDC{sdocStyle=PprUser q _ c} -> + runSDoc doc ctx{sdocStyle = PprUser q depth c} + _ -> + runSDoc doc ctx + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc +sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx + +sdocWithContext :: (SDocContext -> SDoc) -> SDoc +sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx + +sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc +sdocOption f g = sdocWithContext (g . f) + +updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc +updSDocContext upd doc + = SDoc $ \ctx -> runSDoc doc (upd ctx) + +qualName :: PprStyle -> QueryQualifyName +qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ +qualName (PprDump q) mod occ = queryQualifyName q mod occ +qualName _other mod _ = NameQual (moduleName mod) + +qualModule :: PprStyle -> QueryQualifyModule +qualModule (PprUser q _ _) m = queryQualifyModule q m +qualModule (PprDump q) m = queryQualifyModule q m +qualModule _other _m = True + +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _ _) m = queryQualifyPackage q m +qualPackage (PprDump q) m = queryQualifyPackage q m +qualPackage _other _m = True + +queryQual :: PprStyle -> PrintUnqualified +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + +codeStyle :: PprStyle -> Bool +codeStyle (PprCode _) = True +codeStyle _ = False + +asmStyle :: PprStyle -> Bool +asmStyle (PprCode AsmStyle) = True +asmStyle _other = False + +dumpStyle :: PprStyle -> Bool +dumpStyle (PprDump {}) = True +dumpStyle _other = False + +userStyle :: PprStyle -> Bool +userStyle (PprUser {}) = True +userStyle _other = False + +-- | Indicate if -dppr-debug mode is enabled +getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx) + +-- | Says what to do with and without -dppr-debug +ifPprDebug :: SDoc -> SDoc -> SDoc +ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no + +-- | Says what to do with -dppr-debug; without, return empty +whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +whenPprDebug d = ifPprDebug d empty + +-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the +-- terminal doesn't get screwed up by the ANSI color codes if an exception +-- is thrown during pretty-printing. +printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDoc ctx mode handle doc = + Pretty.printDoc_ mode cols handle (runSDoc doc ctx) + `finally` + Pretty.printDoc_ mode cols handle + (runSDoc (coloured Col.colReset empty) ctx) + where + cols = sdocLineLength ctx + +-- | Like 'printSDoc' but appends an extra newline. +printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDocLn ctx mode handle doc = + printSDoc ctx mode handle (doc $$ text "") + +printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO () +printForUser dflags handle unqual depth doc + = printSDocLn ctx PageMode handle doc + where ctx = initSDocContext dflags (mkUserStyle unqual depth) + +-- | Like 'printSDocLn' but specialized with 'LeftMode' and +-- @'PprCode' 'CStyle'@. This is typically used to output C-- code. +printForC :: DynFlags -> Handle -> SDoc -> IO () +printForC dflags handle doc = + printSDocLn ctx LeftMode handle doc + where ctx = initSDocContext dflags (PprCode CStyle) + +-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that +-- outputs to a 'BufHandle'. +bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO () +bufLeftRenderSDoc ctx bufHandle doc = + Pretty.bufLeftRender bufHandle (runSDoc doc ctx) + +pprCode :: CodeStyle -> SDoc -> SDoc +pprCode cs d = withPprStyle (PprCode cs) d + +mkCodeStyle :: CodeStyle -> PprStyle +mkCodeStyle = PprCode + +-- Can't make SDoc an instance of Show because SDoc is just a function type +-- However, Doc *is* an instance of Show +-- showSDoc just blasts it out as a string +showSDoc :: DynFlags -> SDoc -> String +showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags defaultUserStyle) sdoc + +-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be +-- initialised yet. +showSDocUnsafe :: SDoc -> String +showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc + +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags thing = showSDoc dflags (ppr thing) + +showSDocUnqual :: DynFlags -> SDoc -> String +-- Only used by Haddock +showSDocUnqual dflags sdoc = showSDoc dflags sdoc + +showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +-- Allows caller to specify the PrintUnqualified to use +showSDocForUser dflags unqual doc + = renderWithStyle (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc + +showSDocDump :: DynFlags -> SDoc -> String +showSDocDump dflags d = renderWithStyle (initSDocContext dflags defaultDumpStyle) d + +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = renderWithStyle ctx d + where + ctx = (initSDocContext dflags defaultDumpStyle) + { sdocPprDebug = True + } + +renderWithStyle :: SDocContext -> SDoc -> String +renderWithStyle ctx sdoc + = let s = Pretty.style{ Pretty.mode = PageMode, + Pretty.lineLength = sdocLineLength ctx } + in Pretty.renderStyle s $ runSDoc sdoc ctx + +-- This shows an SDoc, but on one line only. It's cheaper than a full +-- showSDoc, designed for when we're getting results like "Foo.bar" +-- and "foo{uniq strictness}" so we don't want fancy layout anyway. +showSDocOneLine :: SDocContext -> SDoc -> String +showSDocOneLine ctx d + = let s = Pretty.style{ Pretty.mode = OneLineMode, + Pretty.lineLength = sdocLineLength ctx } in + Pretty.renderStyle s $ + runSDoc d ctx + +showSDocDumpOneLine :: DynFlags -> SDoc -> String +showSDocDumpOneLine dflags d + = let s = Pretty.style{ Pretty.mode = OneLineMode, + Pretty.lineLength = irrelevantNCols } in + Pretty.renderStyle s $ + runSDoc d (initSDocContext dflags defaultDumpStyle) + +irrelevantNCols :: Int +-- Used for OneLineMode and LeftMode when number of cols isn't used +irrelevantNCols = 1 + +isEmpty :: SDocContext -> SDoc -> Bool +isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) + +docToSDoc :: Doc -> SDoc +docToSDoc d = SDoc (\_ -> d) + +empty :: SDoc +char :: Char -> SDoc +text :: String -> SDoc +ftext :: FastString -> SDoc +ptext :: PtrString -> SDoc +ztext :: FastZString -> SDoc +int :: Int -> SDoc +integer :: Integer -> SDoc +word :: Integer -> SDoc +float :: Float -> SDoc +double :: Double -> SDoc +rational :: Rational -> SDoc + +empty = docToSDoc $ Pretty.empty +char c = docToSDoc $ Pretty.char c + +text s = docToSDoc $ Pretty.text s +{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire + +ftext s = docToSDoc $ Pretty.ftext s +ptext s = docToSDoc $ Pretty.ptext s +ztext s = docToSDoc $ Pretty.ztext s +int n = docToSDoc $ Pretty.int n +integer n = docToSDoc $ Pretty.integer n +float n = docToSDoc $ Pretty.float n +double n = docToSDoc $ Pretty.double n +rational n = docToSDoc $ Pretty.rational n + -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr +word n = sdocOption sdocHexWordLiterals $ \case + True -> docToSDoc $ Pretty.hex n + False -> docToSDoc $ Pretty.integer n + +-- | @doublePrec p n@ shows a floating point number @n@ with @p@ +-- digits of precision after the decimal point. +doublePrec :: Int -> Double -> SDoc +doublePrec p n = text (showFFloat (Just p) n "") + +parens, braces, brackets, quotes, quote, + doubleQuotes, angleBrackets :: SDoc -> SDoc + +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +angleBrackets d = char '<' <> d <> char '>' + +cparen :: Bool -> SDoc -> SDoc +cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d + +-- 'quotes' encloses something in single quotes... +-- but it omits them if the thing begins or ends in a single quote +-- so that we don't get `foo''. Instead we just have foo'. +quotes d = sdocOption sdocCanUseUnicode $ \case + True -> char '‘' <> d <> char '’' + False -> SDoc $ \sty -> + let pp_d = runSDoc d sty + str = show pp_d + in case (str, lastMaybe str) of + (_, Just '\'') -> pp_d + ('\'' : _, _) -> pp_d + _other -> Pretty.quotes pp_d + +semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc +arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc +lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc + +blankLine = docToSDoc $ Pretty.text "" +dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") +arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") +lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") +larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") +darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") +arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") +larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") +arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") +larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +semi = docToSDoc $ Pretty.semi +comma = docToSDoc $ Pretty.comma +colon = docToSDoc $ Pretty.colon +equals = docToSDoc $ Pretty.equals +space = docToSDoc $ Pretty.space +underscore = char '_' +dot = char '.' +vbar = char '|' +lparen = docToSDoc $ Pretty.lparen +rparen = docToSDoc $ Pretty.rparen +lbrack = docToSDoc $ Pretty.lbrack +rbrack = docToSDoc $ Pretty.rbrack +lbrace = docToSDoc $ Pretty.lbrace +rbrace = docToSDoc $ Pretty.rbrace + +mulArrow :: SDoc -> SDoc +mulArrow d = text "%" <> d <+> arrow + + +forAllLit :: SDoc +forAllLit = unicodeSyntax (char '∀') (text "forall") + +bullet :: SDoc +bullet = unicode (char '•') (char '*') + +unicodeSyntax :: SDoc -> SDoc -> SDoc +unicodeSyntax unicode plain = + sdocOption sdocCanUseUnicode $ \can_use_unicode -> + sdocOption sdocPrintUnicodeSyntax $ \print_unicode_syntax -> + if can_use_unicode && print_unicode_syntax + then unicode + else plain + +unicode :: SDoc -> SDoc -> SDoc +unicode unicode plain = sdocOption sdocCanUseUnicode $ \case + True -> unicode + False -> plain + +nest :: Int -> SDoc -> SDoc +-- ^ Indent 'SDoc' some specified amount +(<>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally without a gap +(<+>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally with a gap between them +($$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically; if there is +-- no vertical overlap it "dovetails" the two onto one line +($+$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically + +nest n d = SDoc $ Pretty.nest n . runSDoc d +(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) +(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) +($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) +($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) + +hcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally +hsep :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally with a space between each one +vcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' vertically with dovetailing +sep :: [SDoc] -> SDoc +-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits +cat :: [SDoc] -> SDoc +-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits +fsep :: [SDoc] -> SDoc +-- ^ A paragraph-fill combinator. It's much like sep, only it +-- keeps fitting things on one line until it can't fit any more. +fcat :: [SDoc] -> SDoc +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' + + +hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] +hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] +vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] +sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] +cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] +fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] +fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] + +hang :: SDoc -- ^ The header + -> Int -- ^ Amount to indent the hung body + -> SDoc -- ^ The hung body, indented and placed below the header + -> SDoc +hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) + +-- | This behaves like 'hang', but does not indent the second document +-- when the header is empty. +hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc +hangNotEmpty d1 n d2 = + SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) + +punctuate :: SDoc -- ^ The punctuation + -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [SDoc] -- ^ Punctuated list +punctuate _ [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen True doc = doc +ppWhen False _ = empty + +ppUnless True _ = empty +ppUnless False doc = doc + +ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppWhenOption f doc = sdocOption f $ \case + True -> doc + False -> empty + +ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppUnlessOption f doc = sdocOption f $ \case + True -> empty + False -> doc + +-- | Apply the given colour\/style for the argument. +-- +-- Only takes effect if colours are enabled. +coloured :: Col.PprColour -> SDoc -> SDoc +coloured col sdoc = sdocOption sdocShouldUseColor $ \case + True -> SDoc $ \case + ctx@SDC{ sdocLastColour = lastCol, sdocStyle = PprUser _ _ Coloured } -> + let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in + Pretty.zeroWidthText (Col.renderColour col) + Pretty.<> runSDoc sdoc ctx' + Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) + ctx -> runSDoc sdoc ctx + False -> sdoc + +keyword :: SDoc -> SDoc +keyword = coloured Col.colBold + +{- +************************************************************************ +* * +\subsection[Outputable-class]{The @Outputable@ class} +* * +************************************************************************ +-} + +-- | Class designating that some type has an 'SDoc' representation +class Outputable a where + ppr :: a -> SDoc + pprPrec :: Rational -> a -> SDoc + -- 0 binds least tightly + -- We use Rational because there is always a + -- Rational between any other two Rationals + + ppr = pprPrec 0 + pprPrec _ = ppr + +instance Outputable Char where + ppr c = text [c] + +instance Outputable Bool where + ppr True = text "True" + ppr False = text "False" + +instance Outputable Ordering where + ppr LT = text "LT" + ppr EQ = text "EQ" + ppr GT = text "GT" + +instance Outputable Int32 where + ppr n = integer $ fromIntegral n + +instance Outputable Int64 where + ppr n = integer $ fromIntegral n + +instance Outputable Int where + ppr n = int n + +instance Outputable Integer where + ppr n = integer n + +instance Outputable Word16 where + ppr n = integer $ fromIntegral n + +instance Outputable Word32 where + ppr n = integer $ fromIntegral n + +instance Outputable Word64 where + ppr n = integer $ fromIntegral n + +instance Outputable Word where + ppr n = integer $ fromIntegral n + +instance Outputable Float where + ppr f = float f + +instance Outputable Double where + ppr f = double f + +instance Outputable () where + ppr _ = text "()" + +instance (Outputable a) => Outputable [a] where + ppr xs = brackets (fsep (punctuate comma (map ppr xs))) + +instance (Outputable a) => Outputable (NonEmpty a) where + ppr = ppr . NEL.toList + +instance (Outputable a) => Outputable (Set a) where + ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) + +instance (Outputable a, Outputable b) => Outputable (a, b) where + ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) + +instance Outputable a => Outputable (Maybe a) where + ppr Nothing = text "Nothing" + ppr (Just x) = text "Just" <+> ppr x + +instance (Outputable a, Outputable b) => Outputable (Either a b) where + ppr (Left x) = text "Left" <+> ppr x + ppr (Right y) = text "Right" <+> ppr y + +-- ToDo: may not be used +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where + ppr (x,y,z) = + parens (sep [ppr x <> comma, + ppr y <> comma, + ppr z ]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d) => + Outputable (a, b, c, d) where + ppr (a,b,c,d) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => + Outputable (a, b, c, d, e) where + ppr (a,b,c,d,e) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + +instance Outputable FastString where + ppr fs = ftext fs -- Prints an unadorned string, + -- no double quotes or anything + +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where + ppr m = ppr (M.toList m) +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) + +instance Outputable a => Outputable (SCC a) where + ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) + ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) + +instance Outputable Serialized where + ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) + +instance Outputable Extension where + ppr = text . show + +{- +************************************************************************ +* * +\subsection{The @OutputableBndr@ class} +* * +************************************************************************ +-} + +-- | 'BindingSite' is used to tell the thing that prints binder what +-- language construct is binding the identifier. This can be used +-- to decide how much info to print. +-- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr" +data BindingSite + = LambdaBind -- ^ The x in (\x. e) + | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } + | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } + | LetBind -- ^ The x in (let x = rhs in e) + +-- | When we print a binder, we often want to print its type too. +-- The @OutputableBndr@ class encapsulates this idea. +class Outputable a => OutputableBndr a where + pprBndr :: BindingSite -> a -> SDoc + pprBndr _b x = ppr x + + pprPrefixOcc, pprInfixOcc :: a -> SDoc + -- Print an occurrence of the name, suitable either in the + -- prefix position of an application, thus (f a b) or ((+) x) + -- or infix position, thus (a `f` b) or (x + y) + + bndrIsJoin_maybe :: a -> Maybe Int + bndrIsJoin_maybe _ = Nothing + -- When pretty-printing we sometimes want to find + -- whether the binder is a join point. You might think + -- we could have a function of type (a->Var), but Var + -- isn't available yet, alas + +{- +************************************************************************ +* * +\subsection{Random printing helpers} +* * +************************************************************************ +-} + +-- We have 31-bit Chars and will simply use Show instances of Char and String. + +-- | Special combinator for showing character literals. +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) + +-- | Special combinator for showing string literals. +pprHsString :: FastString -> SDoc +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) + +-- | Special combinator for showing bytestring literals. +pprHsBytes :: ByteString -> SDoc +pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs + in vcat (map text (showMultiLineString escaped)) <> char '#' + where escape :: Word8 -> String + escape w = let c = chr (fromIntegral w) + in if isAscii c + then [c] + else '\\' : show w + +-- Postfix modifiers for unboxed literals. +-- See Note [Printing of literals in Core] in "GHC.Types.Literal". +primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc +primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc +primCharSuffix = char '#' +primFloatSuffix = char '#' +primIntSuffix = char '#' +primDoubleSuffix = text "##" +primWordSuffix = text "##" +primInt64Suffix = text "L#" +primWord64Suffix = text "L##" + +-- | Special combinator for showing unboxed literals. +pprPrimChar :: Char -> SDoc +pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc +pprPrimChar c = pprHsChar c <> primCharSuffix +pprPrimInt i = integer i <> primIntSuffix +pprPrimWord w = word w <> primWordSuffix +pprPrimInt64 i = integer i <> primInt64Suffix +pprPrimWord64 w = word w <> primWord64Suffix + +--------------------- +-- Put a name in parens if it's an operator +pprPrefixVar :: Bool -> SDoc -> SDoc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +-- Put a name in backquotes if it's not an operator +pprInfixVar :: Bool -> SDoc -> SDoc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = char '`' <> pp_v <> char '`' + +--------------------- +pprFastFilePath :: FastString -> SDoc +pprFastFilePath path = text $ normalise $ unpackFS path + +-- | Normalise, escape and render a string representing a path +-- +-- e.g. "c:\\whatever" +pprFilePathString :: FilePath -> SDoc +pprFilePathString path = doubleQuotes $ text (escape (normalise path)) + where + escape [] = [] + escape ('\\':xs) = '\\':'\\':escape xs + escape (x:xs) = x:escape xs + +{- +************************************************************************ +* * +\subsection{Other helper functions} +* * +************************************************************************ +-} + +pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- comma-separated and finally packed into a paragraph. +pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) + +pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- bar-separated and finally packed into a paragraph. +pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) + +-- | Returns the separated concatenation of the pretty printed things. +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = sep (map ppr xs) + +-- | Returns the comma-separated concatenation of the pretty printed things. +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = sep (punctuate comma (map ppr xs)) + +-- | Returns the comma-separated concatenation of the quoted pretty printed things. +-- +-- > [x,y,z] ==> `x', `y', `z' +pprQuotedList :: Outputable a => [a] -> SDoc +pprQuotedList = quotedList . map ppr + +quotedList :: [SDoc] -> SDoc +quotedList xs = fsep (punctuate comma (map quotes xs)) + +quotedListWithOr :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' or `z' +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) +quotedListWithOr xs = quotedList xs + +quotedListWithNor :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' nor `z' +quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) +quotedListWithNor xs = quotedList xs + +{- +************************************************************************ +* * +\subsection{Printing numbers verbally} +* * +************************************************************************ +-} + +intWithCommas :: Integral a => a -> SDoc +-- Prints a big integer with commas, eg 345,821 +intWithCommas n + | n < 0 = char '-' <> intWithCommas (-n) + | q == 0 = int (fromIntegral r) + | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) + where + (q,r) = n `quotRem` 1000 + zeroes | r >= 100 = empty + | r >= 10 = char '0' + | otherwise = text "00" + +-- | Converts an integer to a verbal index: +-- +-- > speakNth 1 = text "first" +-- > speakNth 5 = text "fifth" +-- > speakNth 21 = text "21st" +speakNth :: Int -> SDoc +speakNth 1 = text "first" +speakNth 2 = text "second" +speakNth 3 = text "third" +speakNth 4 = text "fourth" +speakNth 5 = text "fifth" +speakNth 6 = text "sixth" +speakNth n = hcat [ int n, text suffix ] + where + suffix | n <= 20 = "th" -- 11,12,13 are non-std + | last_dig == 1 = "st" + | last_dig == 2 = "nd" + | last_dig == 3 = "rd" + | otherwise = "th" + + last_dig = n `rem` 10 + +-- | Converts an integer to a verbal multiplicity: +-- +-- > speakN 0 = text "none" +-- > speakN 5 = text "five" +-- > speakN 10 = text "10" +speakN :: Int -> SDoc +speakN 0 = text "none" -- E.g. "he has none" +speakN 1 = text "one" -- E.g. "he has one" +speakN 2 = text "two" +speakN 3 = text "three" +speakN 4 = text "four" +speakN 5 = text "five" +speakN 6 = text "six" +speakN n = int n + +-- | Converts an integer and object description to a statement about the +-- multiplicity of those objects: +-- +-- > speakNOf 0 (text "melon") = text "no melons" +-- > speakNOf 1 (text "melon") = text "one melon" +-- > speakNOf 3 (text "melon") = text "three melons" +speakNOf :: Int -> SDoc -> SDoc +speakNOf 0 d = text "no" <+> d <> char 's' +speakNOf 1 d = text "one" <+> d -- E.g. "one argument" +speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" + +-- | Determines the pluralisation suffix appropriate for the length of a list: +-- +-- > plural [] = char 's' +-- > plural ["Hello"] = empty +-- > plural ["Hello", "World"] = char 's' +plural :: [a] -> SDoc +plural [_] = empty -- a bit frightening, but there you are +plural _ = char 's' + +-- | Determines the form of to be appropriate for the length of a list: +-- +-- > isOrAre [] = text "are" +-- > isOrAre ["Hello"] = text "is" +-- > isOrAre ["Hello", "World"] = text "are" +isOrAre :: [a] -> SDoc +isOrAre [_] = text "is" +isOrAre _ = text "are" + +-- | Determines the form of to do appropriate for the length of a list: +-- +-- > doOrDoes [] = text "do" +-- > doOrDoes ["Hello"] = text "does" +-- > doOrDoes ["Hello", "World"] = text "do" +doOrDoes :: [a] -> SDoc +doOrDoes [_] = text "does" +doOrDoes _ = text "do" + +-- | Determines the form of possessive appropriate for the length of a list: +-- +-- > itsOrTheir [x] = text "its" +-- > itsOrTheir [x,y] = text "their" +-- > itsOrTheir [] = text "their" -- probably avoid this +itsOrTheir :: [a] -> SDoc +itsOrTheir [_] = text "its" +itsOrTheir _ = text "their" + +{- +************************************************************************ +* * +\subsection{Error handling} +* * +************************************************************************ +-} + +callStackDoc :: HasCallStack => SDoc +callStackDoc = + hang (text "Call stack:") + 4 (vcat $ map text $ lines (prettyCallStack callStack)) + +pprPanic :: HasCallStack => String -> SDoc -> a +-- ^ Throw an exception saying "bug in GHC" +pprPanic s doc = panicDoc s (doc $$ callStackDoc) + +pprSorry :: String -> SDoc -> a +-- ^ Throw an exception saying "this isn't finished yet" +pprSorry = sorryDoc + + +pprPgmError :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) +pprPgmError = pgmErrorDoc + +pprTraceDebug :: String -> SDoc -> a -> a +pprTraceDebug str doc x + | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x + | otherwise = x + +-- | If debug output is on, show some 'SDoc' on the screen +pprTrace :: String -> SDoc -> a -> a +pprTrace str doc x = pprTraceWithFlags unsafeGlobalDynFlags str doc x + +-- | If debug output is on, show some 'SDoc' on the screen +pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a +pprTraceWithFlags dflags str doc x + | hasNoDebugOutput dflags = x + | otherwise = pprDebugAndThen dflags trace (text str) doc x + +pprTraceM :: Applicative f => String -> SDoc -> f () +pprTraceM str doc = pprTrace str doc (pure ()) + +-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@. +-- This allows you to print details from the returned value as well as from +-- ambient variables. +pprTraceWith :: String -> (a -> SDoc) -> a -> a +pprTraceWith desc f x = pprTrace desc (f x) x + +-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ +pprTraceIt :: Outputable a => String -> a -> a +pprTraceIt desc x = pprTraceWith desc ppr x + +-- | @pprTraceException desc x action@ runs action, printing a message +-- if it throws an exception. +pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a +pprTraceException heading doc = + handleGhcException $ \exc -> liftIO $ do + putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc]) + throwGhcExceptionIO exc + +-- | If debug output is on, show some 'SDoc' on the screen along +-- with a call stack when available. +pprSTrace :: HasCallStack => SDoc -> a -> a +pprSTrace doc = pprTrace "" (doc $$ callStackDoc) + +warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a +-- ^ Just warn about an assertion failure, recording the given file and line number. +-- Should typically be accessed with the WARN macros +warnPprTrace _ _ _ _ x | not debugIsOn = x +warnPprTrace _ _file _line _msg x + | hasNoDebugOutput unsafeGlobalDynFlags = x +warnPprTrace False _file _line _msg x = x +warnPprTrace True file line msg x + = pprDebugAndThen unsafeGlobalDynFlags trace heading + (msg $$ callStackDoc ) + x + where + heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] + +-- | Panic with an assertion failure, recording the given file and +-- line number. Should typically be accessed with the ASSERT family of macros +assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a +assertPprPanic _file _line msg + = pprPanic "ASSERT failed!" msg + +pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a +pprDebugAndThen dflags cont heading pretty_msg + = cont (showSDocDump dflags doc) + where + doc = sep [heading, nest 2 pretty_msg] diff --git a/GHC/Utils/Outputable.hs-boot b/GHC/Utils/Outputable.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Utils/Outputable.hs-boot @@ -0,0 +1,14 @@ +module GHC.Utils.Outputable where + +import GHC.Prelude +import GHC.Stack( HasCallStack ) + +data SDoc +data PprStyle +data SDocContext + +showSDocUnsafe :: SDoc -> String + +warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a + +text :: String -> SDoc diff --git a/GHC/Utils/Panic.hs b/GHC/Utils/Panic.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Panic.hs @@ -0,0 +1,260 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP Project, Glasgow University, 1992-2000 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} + +-- | Defines basic functions for printing error messages. +-- +-- It's hard to put these functions anywhere else without causing +-- some unnecessary loops in the module dependency graph. +module GHC.Utils.Panic ( + GhcException(..), showGhcException, + throwGhcException, throwGhcExceptionIO, + handleGhcException, + GHC.Utils.Panic.Plain.progName, + pgmError, + + panic, sorry, assertPanic, trace, + panicDoc, sorryDoc, pgmErrorDoc, + + cmdLineError, cmdLineErrorIO, + + Exception.Exception(..), showException, safeShowException, + try, tryMost, throwTo, + + withSignalHandlers, +) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Utils.Outputable (SDoc, showSDocUnsafe) +import GHC.Utils.Panic.Plain + +import GHC.Utils.Exception as Exception + +import Control.Monad.IO.Class +import qualified Control.Monad.Catch as MC +import Control.Concurrent +import Data.Typeable ( cast ) +import Debug.Trace ( trace ) +import System.IO.Unsafe + +#if !defined(mingw32_HOST_OS) +import System.Posix.Signals as S +#endif + +#if defined(mingw32_HOST_OS) +import GHC.ConsoleHandler as S +#endif + +import System.Mem.Weak ( deRefWeak ) + +-- | GHC's own exception type +-- error messages all take the form: +-- +-- @ +-- \: \ +-- @ +-- +-- If the location is on the command line, or in GHC itself, then +-- \="ghc". All of the error types below correspond to +-- a \ of "ghc", except for ProgramError (where the string is +-- assumed to contain a location already, so we don't print one). + +data GhcException + -- | Some other fatal signal (SIGHUP,SIGTERM) + = Signal Int + + -- | Prints the short usage msg after the error + | UsageError String + + -- | A problem with the command line arguments, but don't print usage. + | CmdLineError String + + -- | The 'impossible' happened. + | Panic String + | PprPanic String SDoc + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | Sorry String + | PprSorry String SDoc + + -- | An installation problem. + | InstallationError String + + -- | An error in the user's code, probably. + | ProgramError String + | PprProgramError String SDoc + +instance Exception GhcException where + fromException (SomeException e) + | Just ge <- cast e = Just ge + | Just pge <- cast e = Just $ + case pge of + PlainSignal n -> Signal n + PlainUsageError str -> UsageError str + PlainCmdLineError str -> CmdLineError str + PlainPanic str -> Panic str + PlainSorry str -> Sorry str + PlainInstallationError str -> InstallationError str + PlainProgramError str -> ProgramError str + | otherwise = Nothing + +instance Show GhcException where + showsPrec _ e@(ProgramError _) = showGhcException e + showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e + showsPrec _ e = showString progName . showString ": " . showGhcException e + +-- | Show an exception as a string. +showException :: Exception e => e -> String +showException = show + +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs + +-- | Append a description of the given exception to this string. +-- +-- Note that this uses 'GHC.Driver.Session.unsafeGlobalDynFlags', which may have some +-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. +-- If the error message to be printed includes a pretty-printer document +-- which forces one of these fields this call may bottom. +showGhcException :: GhcException -> ShowS +showGhcException = showPlainGhcException . \case + Signal n -> PlainSignal n + UsageError str -> PlainUsageError str + CmdLineError str -> PlainCmdLineError str + Panic str -> PlainPanic str + Sorry str -> PlainSorry str + InstallationError str -> PlainInstallationError str + ProgramError str -> PlainProgramError str + + PprPanic str sdoc -> PlainPanic $ + concat [str, "\n\n", showSDocUnsafe sdoc] + PprSorry str sdoc -> PlainProgramError $ + concat [str, "\n\n", showSDocUnsafe sdoc] + PprProgramError str sdoc -> PlainProgramError $ + concat [str, "\n\n", showSDocUnsafe sdoc] + +throwGhcException :: GhcException -> a +throwGhcException = Exception.throw + +throwGhcExceptionIO :: GhcException -> IO a +throwGhcExceptionIO = Exception.throwIO + +handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a +handleGhcException = MC.handle + +panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a +panicDoc x doc = throwGhcException (PprPanic x doc) +sorryDoc x doc = throwGhcException (PprSorry x doc) +pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) + +-- | Like try, but pass through UserInterrupt and Panic exceptions. +-- Used when we want soft failures when reading interface files, for example. +-- TODO: I'm not entirely sure if this is catching what we really want to catch +tryMost :: IO a -> IO (Either SomeException a) +tryMost action = do r <- try action + case r of + Left se -> + case fromException se of + -- Some GhcException's we rethrow, + Just (Signal _) -> throwIO se + Just (Panic _) -> throwIO se + -- others we return + Just _ -> return (Left se) + Nothing -> + case fromException se of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) + +-- | We use reference counting for signal handlers +{-# NOINLINE signalHandlersRefCount #-} +#if !defined(mingw32_HOST_OS) +signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler + ,S.Handler,S.Handler)) +#else +signalHandlersRefCount :: MVar (Word, Maybe S.Handler) +#endif +signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) + + +-- | Temporarily install standard signal handlers for catching ^C, which just +-- throw an exception in the current thread. +withSignalHandlers :: ExceptionMonad m => m a -> m a +withSignalHandlers act = do + main_thread <- liftIO myThreadId + wtid <- liftIO (mkWeakThreadId main_thread) + + let + interrupt = do + r <- deRefWeak wtid + case r of + Nothing -> return () + Just t -> throwTo t UserInterrupt + +#if !defined(mingw32_HOST_OS) + let installHandlers = do + let installHandler' a b = installHandler a b Nothing + hdlQUIT <- installHandler' sigQUIT (Catch interrupt) + hdlINT <- installHandler' sigINT (Catch interrupt) + -- see #3656; in the future we should install these automatically for + -- all Haskell programs in the same way that we install a ^C handler. + let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) + hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) + hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) + return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) + + let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do + _ <- installHandler sigQUIT hdlQUIT Nothing + _ <- installHandler sigINT hdlINT Nothing + _ <- installHandler sigHUP hdlHUP Nothing + _ <- installHandler sigTERM hdlTERM Nothing + return () +#else + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + let installHandlers = installHandler (Catch sig_handler) + let uninstallHandlers = installHandler -- directly install the old handler +#endif + + -- install signal handlers if necessary + let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (0,Nothing) -> do + hdls <- installHandlers + return (1,Just hdls) + (c,oldHandlers) -> return (c+1,oldHandlers) + + -- uninstall handlers if necessary + let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (1,Just hdls) -> do + _ <- uninstallHandlers hdls + return (0,Nothing) + (c,oldHandlers) -> return (c-1,oldHandlers) + + mayInstallHandlers + act `MC.finally` mayUninstallHandlers diff --git a/GHC/Utils/Panic/Plain.hs b/GHC/Utils/Panic/Plain.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Panic/Plain.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} + +-- | Defines a simple exception type and utilities to throw it. The +-- 'PlainGhcException' type is a subset of the 'GHC.Utils.Panic.GhcException' +-- type. It omits the exception constructors that involve +-- pretty-printing via 'GHC.Utils.Outputable.SDoc'. +-- +-- There are two reasons for this: +-- +-- 1. To avoid import cycles / use of boot files. "GHC.Utils.Outputable" has +-- many transitive dependencies. To throw exceptions from these +-- modules, the functions here can be used without introducing import +-- cycles. +-- +-- 2. To reduce the number of modules that need to be compiled to +-- object code when loading GHC into GHCi. See #13101 +module GHC.Utils.Panic.Plain + ( PlainGhcException(..) + , showPlainGhcException + + , panic, sorry, pgmError + , cmdLineError, cmdLineErrorIO + , assertPanic + + , progName + ) where + +#include "HsVersions.h" + +import GHC.Settings.Config +import GHC.Utils.Exception as Exception +import GHC.Stack +import GHC.Prelude +import System.Environment +import System.IO.Unsafe + +-- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits +-- the constructors that involve pretty-printing via +-- 'GHC.Utils.Outputable.SDoc'. Due to the implementation of 'fromException' +-- for 'GHC.Utils.Panic.GhcException', this type can be caught as a +-- 'GHC.Utils.Panic.GhcException'. +-- +-- Note that this should only be used for throwing exceptions, not for +-- catching, as 'GHC.Utils.Panic.GhcException' will not be converted to this +-- type when catching. +data PlainGhcException + -- | Some other fatal signal (SIGHUP,SIGTERM) + = PlainSignal Int + + -- | Prints the short usage msg after the error + | PlainUsageError String + + -- | A problem with the command line arguments, but don't print usage. + | PlainCmdLineError String + + -- | The 'impossible' happened. + | PlainPanic String + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | PlainSorry String + + -- | An installation problem. + | PlainInstallationError String + + -- | An error in the user's code, probably. + | PlainProgramError String + +instance Exception PlainGhcException + +instance Show PlainGhcException where + showsPrec _ e@(PlainProgramError _) = showPlainGhcException e + showsPrec _ e@(PlainCmdLineError _) = showString ": " . showPlainGhcException e + showsPrec _ e = showString progName . showString ": " . showPlainGhcException e + +-- | The name of this GHC. +progName :: String +progName = unsafePerformIO (getProgName) +{-# NOINLINE progName #-} + +-- | Short usage information to display when we are given the wrong cmd line arguments. +short_usage :: String +short_usage = "Usage: For basic information, try the `--help' option." + +-- | Append a description of the given exception to this string. +showPlainGhcException :: PlainGhcException -> ShowS +showPlainGhcException = + \case + PlainSignal n -> showString "signal: " . shows n + PlainUsageError str -> showString str . showChar '\n' . showString short_usage + PlainCmdLineError str -> showString str + PlainPanic s -> panicMsg (showString s) + PlainSorry s -> sorryMsg (showString s) + PlainInstallationError str -> showString str + PlainProgramError str -> showString str + where + sorryMsg :: ShowS -> ShowS + sorryMsg s = + showString "sorry! (unimplemented feature or known bug)\n" + . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") + . s . showString "\n" + + panicMsg :: ShowS -> ShowS + panicMsg s = + showString "panic! (the 'impossible' happened)\n" + . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") + . s . showString "\n\n" + . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" + +throwPlainGhcException :: PlainGhcException -> a +throwPlainGhcException = Exception.throw + +-- | Panics and asserts. +panic, sorry, pgmError :: String -> a +panic x = unsafeDupablePerformIO $ do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwPlainGhcException (PlainPanic x) + else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) + +sorry x = throwPlainGhcException (PlainSorry x) +pgmError x = throwPlainGhcException (PlainProgramError x) + +cmdLineError :: String -> a +cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO + +cmdLineErrorIO :: String -> IO a +cmdLineErrorIO x = do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwPlainGhcException (PlainCmdLineError x) + else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) + +-- | Throw a failed assertion exception for a given filename and line number. +assertPanic :: String -> Int -> a +assertPanic file line = + Exception.throw (Exception.AssertionFailed + ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) diff --git a/GHC/Utils/Ppr.hs b/GHC/Utils/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Ppr.hs @@ -0,0 +1,1105 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Utils.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei +-- Stability : stable +-- Portability : portable +-- +-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators +-- +-- Based on /The Design of a Pretty-printing Library/ +-- in Advanced Functional Programming, +-- Johan Jeuring and Erik Meijer (eds), LNCS 925 +-- +-- +----------------------------------------------------------------------------- + +{- +Note [Differences between libraries/pretty and compiler/GHC/Utils/Ppr.hs] + +For historical reasons, there are two different copies of `Pretty` in the GHC +source tree: + * `libraries/pretty` is a submodule containing + https://github.com/haskell/pretty. This is the `pretty` library as released + on hackage. It is used by several other libraries in the GHC source tree + (e.g. template-haskell and Cabal). + * `compiler/GHC/Utils/Ppr.hs` (this module). It is used by GHC only. + +There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and +https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy +of Pretty. + +Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following +major differences: + * GHC's copy uses `Faststring` for performance reasons. + * GHC's copy has received a backported bugfix for #12227, which was + released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", + https://github.com/haskell/pretty/pull/35). + +Other differences are minor. Both copies define some extra functions and +instances not defined in the other copy. To see all differences, do this in a +ghc git tree: + + $ cd libraries/pretty + $ git checkout v1.1.2.0 + $ cd - + $ vimdiff compiler/GHC/Utils/Ppr.hs \ + libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs + +For parity with `pretty-1.1.2.1`, the following two `pretty` commits would +have to be backported: + * "Resolve foldr-strictness stack overflow bug" + (307b8173f41cd776eae8f547267df6d72bff2d68) + * "Special-case reduce for horiz/vert" + (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) +This has not been done sofar, because these commits seem to cause more +allocation in the compiler (see thomie's comments in +https://github.com/haskell/pretty/pull/9). +-} + +module GHC.Utils.Ppr ( + + -- * The document type + Doc, TextDetails(..), + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ftext, ptext, ztext, sizedText, zeroWidthText, + int, integer, float, double, rational, hex, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, quote, doubleQuotes, + maybeParens, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, hangNotEmpty, punctuate, + + -- * Predicates on documents + isEmpty, + + -- * Rendering documents + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + Mode(..), + + -- ** General rendering + fullRender, txtPrinter, + + -- ** GHC-specific rendering + printDoc, printDoc_, + bufLeftRender -- performance hack + + ) where + +import GHC.Prelude hiding (error) + +import GHC.Utils.BufHandle +import GHC.Data.FastString +import GHC.Utils.Panic.Plain +import System.IO +import Numeric (showHex) + +--for a RULES +import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) +import GHC.Ptr ( Ptr(..) ) + +-- --------------------------------------------------------------------------- +-- The Doc calculus + +{- +Laws for $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +** because of law n6, t2 only holds if x doesn't +** start with `nest'. + + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k x <> nest k y + nest k (x $$ y) = nest k x $$ nest k y + nest k empty = empty + x <> nest k y = x <> y, if x non-empty + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following version of would +be neater: + +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) + +But it doesn't work, for if x=empty, we would have + + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +-} + +-- --------------------------------------------------------------------------- +-- Operator fixity + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ + + +-- --------------------------------------------------------------------------- +-- The Doc data type + +-- | The abstract type of documents. +-- A Doc represents a *set* of layouts. A Doc with +-- no occurrences of Union or NoDoc represents just one layout. +data Doc + = Empty -- empty + | NilAbove Doc -- text "" $$ x + | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x + | Nest {-# UNPACK #-} !Int Doc -- nest k x + | Union Doc Doc -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside Doc Bool Doc -- True <=> space between + | Above Doc Bool Doc -- True <=> never overlap + +{- +Here are the invariants: + +1) The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. + +2) The argument of @TextBeside@ is never @Nest@. + +3) The layouts of the two arguments of @Union@ both flatten to the same + string. + +4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +5) A @NoDoc@ may only appear on the first line of the left argument of an + union. Therefore, the right argument of an union can never be equivalent + to the empty set (@NoDoc@). + +6) An empty document is always represented by @Empty@. It can't be + hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +7) The first line of every layout in the left argument of @Union@ is + longer than the first line of any layout in the right argument. + (1) ensures that the left argument has a first line. In view of + (3), this invariant means that the right argument must have at + least two lines. + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) +-} + + +-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. +type RDoc = Doc + +-- | The TextDetails data type +-- +-- A TextDetails represents a fragment of text that will be +-- output at some point. +data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | PStr FastString -- a hashed string + | ZStr FastZString -- a z-encoded string + | LStr {-# UNPACK #-} !PtrString + -- a '\0'-terminated array of bytes + | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char + -- a repeated character (e.g., ' ') + +instance Show Doc where + showsPrec _ doc cont = fullRender (mode style) (lineLength style) + (ribbonsPerLine style) + txtPrinter cont doc + + +-- --------------------------------------------------------------------------- +-- Values and Predicates on GDocs and TextDetails + +-- | A document of height and width 1, containing a literal character. +char :: Char -> Doc +char c = textBeside_ (Chr c) 1 Empty + +-- | A document of height 1 containing a literal string. +-- 'text' satisfies the following laws: +-- +-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ +-- +-- * @'text' \"\" '<>' x = x@, if @x@ non-empty +-- +-- The side condition on the last law is necessary because @'text' \"\"@ +-- has height 1, while 'empty' has no height. +text :: String -> Doc +text s = textBeside_ (Str s) (length s) Empty +{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested + +-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the +-- intermediate packing/unpacking of the string. +{-# RULES "text/str" + forall a. text (unpackCString# a) = ptext (mkPtrString# a) + #-} +{-# RULES "text/unpackNBytes#" + forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) + #-} + +ftext :: FastString -> Doc +ftext s = textBeside_ (PStr s) (lengthFS s) Empty + +ptext :: PtrString -> Doc +ptext s = textBeside_ (LStr s) (lengthPS s) Empty + +ztext :: FastZString -> Doc +ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty + +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> Doc +sizedText l s = textBeside_ (Str s) l Empty + +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc +zeroWidthText = sizedText 0 + +-- | The empty document, with no height and no width. +-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere +-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. +empty :: Doc +empty = Empty + +-- | Returns 'True' if the document is empty +isEmpty :: Doc -> Bool +isEmpty Empty = True +isEmpty _ = False + +{- +Q: What is the reason for negative indentation (i.e. argument to indent + is < 0) ? + +A: +This indicates an error in the library client's code. +If we compose a <> b, and the first line of b is more indented than some +other lines of b, the law (<> eats nests) may cause the pretty +printer to produce an invalid layout: + +doc |0123345 +------------------ +d1 |a...| +d2 |...b| + |c...| + +d1<>d2 |ab..| + c|....| + +Consider a <> b, let `s' be the length of the last line of `a', `k' the +indentation of the first line of b, and `k0' the indentation of the +left-most line b_i of b. + +The produced layout will have negative indentation if `k - k0 > s', as +the first line of b will be put on the (s+1)th column, effectively +translating b horizontally by (k-s). Now if the i^th line of b has an +indentation k0 < (k-s), it is translated out-of-page, causing +`negative indentation'. +-} + + +semi :: Doc -- ^ A ';' character +comma :: Doc -- ^ A ',' character +colon :: Doc -- ^ A ':' character +space :: Doc -- ^ A space character +equals :: Doc -- ^ A '=' character +lparen :: Doc -- ^ A '(' character +rparen :: Doc -- ^ A ')' character +lbrack :: Doc -- ^ A '[' character +rbrack :: Doc -- ^ A ']' character +lbrace :: Doc -- ^ A '{' character +rbrace :: Doc -- ^ A '}' character +semi = char ';' +comma = char ',' +colon = char ':' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +spaceText, nlText :: TextDetails +spaceText = Chr ' ' +nlText = Chr '\n' + +int :: Int -> Doc -- ^ @int n = text (show n)@ +integer :: Integer -> Doc -- ^ @integer n = text (show n)@ +float :: Float -> Doc -- ^ @float n = text (show n)@ +double :: Double -> Doc -- ^ @double n = text (show n)@ +rational :: Rational -> Doc -- ^ @rational n = text (show n)@ +hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show n) +hex n = text ('0' : 'x' : padded) + where + str = showHex n "" + strLen = max 1 (length str) + len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) + padded = replicate (len - strLen) '0' ++ str + +parens :: Doc -> Doc -- ^ Wrap document in @(...)@ +brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ +braces :: Doc -> Doc -- ^ Wrap document in @{...}@ +quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quote :: Doc -> Doc +doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ +quotes p = char '`' <> p <> char '\'' +quote p = char '\'' <> p +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + +{- +Note [Print Hexadecimal Literals] + +Relevant discussions: + * Phabricator: https://phabricator.haskell.org/D4465 + * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 + +There is a flag `-dword-hex-literals` that causes literals of +type `Word#` or `Word64#` to be displayed in hexadecimal instead +of decimal when dumping GHC core. It also affects the presentation +of these in GHC's error messages. Additionally, the hexadecimal +encoding of these numbers is zero-padded so that its length is +a power of two. As an example of what this does, +consider the following haskell file `Literals.hs`: + + module Literals where + + alpha :: Int + alpha = 100 + 200 + + beta :: Word -> Word + beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 + +We get the following dumped core when we compile on a 64-bit +machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all +-dhex-word-literals literals.hs: + + ==================== Tidy Core ==================== + + ... omitted for brevity ... + + -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} + alpha + alpha = I# 300# + + -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} + beta + beta + = \ x_aYE -> + case x_aYE of { W# x#_a1v0 -> + W# + (plusWord# + (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) + 0x0202##) + } + +Notice that the word literals are in hexadecimals and that they have +been padded with zeroes so that their lengths are 16, 8, and 4, respectively. + +-} + +-- | Apply 'parens' to 'Doc' if boolean is true. +maybeParens :: Bool -> Doc -> Doc +maybeParens False = id +maybeParens True = parens + +-- --------------------------------------------------------------------------- +-- Structural operations on GDocs + +-- | Perform some simplification of a built up @GDoc@. +reduceDoc :: Doc -> RDoc +reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) +reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) +reduceDoc p = p + +-- | List version of '<>'. +hcat :: [Doc] -> Doc +hcat = reduceAB . foldr (beside_' False) empty + +-- | List version of '<+>'. +hsep :: [Doc] -> Doc +hsep = reduceAB . foldr (beside_' True) empty + +-- | List version of '$$'. +vcat :: [Doc] -> Doc +vcat = reduceAB . foldr (above_' False) empty + +-- | Nest (or indent) a document by a given number of positions +-- (which may also be negative). 'nest' satisfies the laws: +-- +-- * @'nest' 0 x = x@ +-- +-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ +-- +-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ +-- +-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ +-- +-- * @'nest' k 'empty' = 'empty'@ +-- +-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty +-- +-- The side condition on the last law is needed because +-- 'empty' is a left identity for '<>'. +nest :: Int -> Doc -> Doc +nest k p = mkNest k (reduceDoc p) + +-- | @hang d1 n d2 = sep [d1, nest n d2]@ +hang :: Doc -> Int -> Doc -> Doc +hang d1 n d2 = sep [d1, nest n d2] + +-- | Apply 'hang' to the arguments if the first 'Doc' is not empty. +hangNotEmpty :: Doc -> Int -> Doc -> Doc +hangNotEmpty d1 n d2 = if isEmpty d1 + then d2 + else hang d1 n d2 + +-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ +punctuate :: Doc -> [Doc] -> [Doc] +punctuate _ [] = [] +punctuate p (x:xs) = go x xs + where go y [] = [y] + go y (z:zs) = (y <> p) : go z zs + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int -> Doc -> Doc +mkNest k _ | k `seq` False = undefined +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty +mkNest 0 p = p +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion :: Doc -> Doc -> Doc +mkUnion Empty _ = Empty +mkUnion p q = p `union_` q + +beside_' :: Bool -> Doc -> Doc -> Doc +beside_' _ p Empty = p +beside_' g p q = Beside p g q + +above_' :: Bool -> Doc -> Doc -> Doc +above_' _ p Empty = p +above_' g p q = Above p g q + +reduceAB :: Doc -> Doc +reduceAB (Above Empty _ q) = q +reduceAB (Beside Empty _ q) = q +reduceAB doc = doc + +nilAbove_ :: RDoc -> RDoc +nilAbove_ = NilAbove + +-- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails -> Int -> RDoc -> RDoc +textBeside_ = TextBeside + +nest_ :: Int -> RDoc -> RDoc +nest_ = Nest + +union_ :: RDoc -> RDoc -> RDoc +union_ = Union + + +-- --------------------------------------------------------------------------- +-- Vertical composition @$$@ + +-- | Above, except that if the last line of the first argument stops +-- at least one position before the first line of the second begins, +-- these two lines are overlapped. For example: +-- +-- > text "hi" $$ nest 5 (text "there") +-- +-- lays out as +-- +-- > hi there +-- +-- rather than +-- +-- > hi +-- > there +-- +-- '$$' is associative, with identity 'empty', and also satisfies +-- +-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. +-- +($$) :: Doc -> Doc -> Doc +p $$ q = above_ p False q + +-- | Above, with no overlapping. +-- '$+$' is associative, with identity 'empty'. +($+$) :: Doc -> Doc -> Doc +p $+$ q = above_ p True q + +above_ :: Doc -> Bool -> Doc -> Doc +above_ p _ Empty = p +above_ Empty _ q = q +above_ p g q = Above p g q + +above :: Doc -> Bool -> RDoc -> RDoc +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p g q = aboveNest p g 0 (reduceDoc q) + +-- Specification: aboveNest p g k q = p $g$ (nest k q) +aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc +aboveNest _ _ k _ | k `seq` False = undefined +aboveNest NoDoc _ _ _ = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty _ k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + !k1 = k - sl + rest = case p of + Empty -> nilAboveNest g k1 q + _ -> aboveNest p g k1 q +aboveNest (Above {}) _ _ _ = error "aboveNest Above" +aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" + +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) +nilAboveNest :: Bool -> Int -> RDoc -> RDoc +nilAboveNest _ k _ | k `seq` False = undefined +nilAboveNest _ _ Empty = Empty + -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (RStr k ' ') k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) + + +-- --------------------------------------------------------------------------- +-- Horizontal composition @<>@ + +-- We intentionally avoid Data.Monoid.(<>) here due to interactions of +-- Data.Monoid.(<>) and (<+>). See +-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html + +-- | Beside. +-- '<>' is associative, with identity 'empty'. +(<>) :: Doc -> Doc -> Doc +p <> q = beside_ p False q + +-- | Beside, separated by space, unless one of the arguments is 'empty'. +-- '<+>' is associative, with identity 'empty'. +(<+>) :: Doc -> Doc -> Doc +p <+> q = beside_ p True q + +beside_ :: Doc -> Bool -> Doc -> Doc +beside_ p _ Empty = p +beside_ Empty _ q = q +beside_ p g q = Beside p g q + +-- Specification: beside g p q = p q +beside :: Doc -> Bool -> RDoc -> RDoc +beside NoDoc _ _ = NoDoc +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q +beside Empty _ q = q +beside (Nest k p) g q = nest_ k $! beside p g q +beside p@(Beside p1 g1 q1) g2 q2 + | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q +beside (NilAbove p) g q = nilAbove_ $! beside p g q +beside (TextBeside s sl p) g q = textBeside_ s sl rest + where + rest = case p of + Empty -> nilBeside g q + _ -> beside p g q + +-- Specification: text "" <> nilBeside g p +-- = text "" p +nilBeside :: Bool -> RDoc -> RDoc +nilBeside _ Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ spaceText 1 p + | otherwise = p + + +-- --------------------------------------------------------------------------- +-- Separate, @sep@ + +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +-- | Either 'hsep' or 'vcat'. +sep :: [Doc] -> Doc +sep = sepX True -- Separate with spaces + +-- | Either 'hcat' or 'vcat'. +cat :: [Doc] -> Doc +cat = sepX False -- Don't + +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) +sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc +sep1 _ _ k _ | k `seq` False = undefined +sep1 _ NoDoc _ _ = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` + aboveNest q False k (reduceDoc (vcat ys)) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 _ (NilAbove p) k ys = nilAbove_ + (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) +sep1 _ (Above {}) _ _ = error "sep1 Above" +sep1 _ (Beside {}) _ _ = error "sep1 Beside" + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests +sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc +sepNB g (Nest _ p) k ys + = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g Empty k ys + = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys +sepNB g p k ys + = sep1 g p k ys + + +-- --------------------------------------------------------------------------- +-- @fill@ + +-- | \"Paragraph fill\" version of 'cat'. +fcat :: [Doc] -> Doc +fcat = fill False + +-- | \"Paragraph fill\" version of 'sep'. +fsep :: [Doc] -> Doc +fsep = fill True + +-- Specification: +-- +-- fill g docs = fillIndent 0 docs +-- +-- fillIndent k [] = [] +-- fillIndent k [p] = p +-- fillIndent k (p1:p2:ps) = +-- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) +-- `Union` +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- +-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 +-- | otherwise = layout1 $+$ layout2 + +fill :: Bool -> [Doc] -> RDoc +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + +fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc +fill1 _ _ k _ | k `seq` False = undefined +fill1 _ NoDoc _ _ = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` + aboveNest q False k (fill g ys) +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) +fill1 _ (Above {}) _ _ = error "fill1 Above" +fill1 _ (Beside {}) _ _ = error "fill1 Beside" + +fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc +fillNB _ _ k _ | k `seq` False = undefined +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) +fillNB _ Empty _ [] = Empty +fillNB g Empty k (Empty:ys) = fillNB g Empty k ys +fillNB g Empty k (y:ys) = fillNBE g k y ys +fillNB g p k ys = fill1 g p k ys + + +fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc +fillNBE g k y ys + = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + `mkUnion` nilAboveNest False k (fill g (y:ys)) + where k' = if g then k - 1 else k + +elideNest :: Doc -> Doc +elideNest (Nest _ d) = d +elideNest d = d + +-- --------------------------------------------------------------------------- +-- Selecting the best layout + +best :: Int -- Line length + -> Int -- Ribbon length + -> RDoc + -> RDoc -- No unions in here! +best w0 r = get w0 + where + get :: Int -- (Remaining) width of line + -> Doc -> Doc + get w _ | w == 0 && False = undefined + get _ Empty = Empty + get _ NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ (Above {}) = error "best get Above" + get _ (Beside {}) = error "best get Beside" + + get1 :: Int -- (Remaining) width of line + -> Int -- Amount of first line already eaten up + -> Doc -- This is an argument to TextBeside => eat Nests + -> Doc -- No unions in here! + + get1 w _ _ | w == 0 && False = undefined + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) + get1 w sl (Nest _ p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + get1 _ _ (Above {}) = error "best get1 Above" + get1 _ _ (Beside {}) = error "best get1 Beside" + +nicest :: Int -> Int -> Doc -> Doc -> Doc +nicest !w !r = nicest1 w r 0 + +nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc +nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> Doc + -> Bool -- True if *first line* of Doc fits in space available +fits n _ | n < 0 = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n - sl) p +fits _ (Above {}) = error "fits Above" +fits _ (Beside {}) = error "fits Beside" +fits _ (Union {}) = error "fits Union" +fits _ (Nest {}) = error "fits Nest" + +-- | @first@ returns its first argument if it is non-empty, otherwise its second. +first :: Doc -> Doc -> Doc +first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused + | otherwise = q + +nonEmptySet :: Doc -> Bool +nonEmptySet NoDoc = False +nonEmptySet (_ `Union` _) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove _) = True +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet (Above {}) = error "nonEmptySet Above" +nonEmptySet (Beside {}) = error "nonEmptySet Beside" + +-- @oneLiner@ returns the one-line members of the given set of @GDoc@s. +oneLiner :: Doc -> Doc +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove _) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` _) = oneLiner p +oneLiner (Above {}) = error "oneLiner Above" +oneLiner (Beside {}) = error "oneLiner Beside" + + +-- --------------------------------------------------------------------------- +-- Rendering + +-- | A rendering style. +data Style + = Style { mode :: Mode -- ^ The rendering mode + , lineLength :: Int -- ^ Length of line, in chars + , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length + } + +-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). +style :: Style +style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } + +-- | Rendering mode. +data Mode = PageMode -- ^ Normal + | ZigZagMode -- ^ With zig-zag cuts + | LeftMode -- ^ No indentation, infinitely long lines + | OneLineMode -- ^ All on one line + +-- | Render the @Doc@ to a String using the given @Style@. +renderStyle :: Style -> Doc -> String +renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) + txtPrinter "" + +-- | Default TextDetails printer +txtPrinter :: TextDetails -> String -> String +txtPrinter (Chr c) s = c:s +txtPrinter (Str s1) s2 = s1 ++ s2 +txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 +txtPrinter (ZStr s1) s2 = zString s1 ++ s2 +txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 +txtPrinter (RStr n c) s2 = replicate n c ++ s2 + +-- | The general rendering interface. +fullRender :: Mode -- ^ Rendering mode + -> Int -- ^ Line length + -> Float -- ^ Ribbons per line + -> (TextDetails -> a -> a) -- ^ What to do with text + -> a -- ^ What to do at the end + -> Doc -- ^ The document + -> a -- ^ Result +fullRender OneLineMode _ _ txt end doc + = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc + = easyDisplay nlText first txt end (reduceDoc doc) + +fullRender m lineLen ribbons txt rest doc + = display m lineLen ribbonLen txt rest doc' + where + doc' = best bestLineLen ribbonLen (reduceDoc doc) + + bestLineLen, ribbonLen :: Int + ribbonLen = round (fromIntegral lineLen / ribbons) + bestLineLen = case m of + ZigZagMode -> maxBound + _ -> lineLen + +easyDisplay :: TextDetails + -> (Doc -> Doc -> Doc) + -> (TextDetails -> a -> a) + -> a + -> Doc + -> a +easyDisplay nlSpaceText choose txt end + = lay + where + lay NoDoc = error "easyDisplay: NoDoc" + lay (Union p q) = lay (choose p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nlSpaceText `txt` lay p + lay (TextBeside s _ p) = s `txt` lay p + lay (Above {}) = error "easyDisplay Above" + lay (Beside {}) = error "easyDisplay Beside" + +display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a +display m !page_width !ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k _ | k `seq` False = undefined + lay k (Nest k1 p) = lay (k + k1) p + lay _ Empty = end + lay k (NilAbove p) = nlText `txt` lay k p + lay k (TextBeside s sl p) + = case m of + ZigZagMode | k >= gap_width + -> nlText `txt` ( + Str (replicate shift '/') `txt` ( + nlText `txt` + lay1 (k - shift) s sl p )) + + | k < 0 + -> nlText `txt` ( + Str (replicate shift '\\') `txt` ( + nlText `txt` + lay1 (k + shift) s sl p )) + + _ -> lay1 k s sl p + lay _ (Above {}) = error "display lay Above" + lay _ (Beside {}) = error "display lay Beside" + lay _ NoDoc = error "display lay NoDoc" + lay _ (Union {}) = error "display lay Union" + + lay1 !k s !sl p = let !r = k + sl + in indent k (s `txt` lay2 r p) + + lay2 k _ | k `seq` False = undefined + lay2 k (NilAbove p) = nlText `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p + lay2 k (Nest _ p) = lay2 k p + lay2 _ Empty = end + lay2 _ (Above {}) = error "display lay2 Above" + lay2 _ (Beside {}) = error "display lay2 Beside" + lay2 _ NoDoc = error "display lay2 NoDoc" + lay2 _ (Union {}) = error "display lay2 Union" + + indent !n r = RStr n ' ' `txt` r + in + lay 0 doc + }} + +printDoc :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc adds a newline to the end +printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") + +printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc_ does not add a newline at the end, so that +-- successive calls can output stuff on the same line +-- Rather like putStr vs putStrLn +printDoc_ LeftMode _ hdl doc + = do { printLeftRender hdl doc; hFlush hdl } +printDoc_ mode pprCols hdl doc + = do { fullRender mode pprCols 1.5 put done doc ; + hFlush hdl } + where + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutStr hdl (unpackFS s) >> next + -- NB. not hPutFS, we want this to go through + -- the I/O library's encoding layer. (#3398) + put (ZStr s) next = hPutFZS hdl s >> next + put (LStr s) next = hPutPtrString hdl s >> next + put (RStr n c) next = hPutStr hdl (replicate n c) >> next + + done = return () -- hPutChar hdl '\n' + + -- some versions of hPutBuf will barf if the length is zero +hPutPtrString :: Handle -> PtrString -> IO () +hPutPtrString _handle (PtrString _ 0) = return () +hPutPtrString handle (PtrString a l) = hPutBuf handle a l + +-- Printing output in LeftMode is performance critical: it's used when +-- dumping C and assembly output, so we allow ourselves a few dirty +-- hacks: +-- +-- (1) we specialise fullRender for LeftMode with IO output. +-- +-- (2) we add a layer of buffering on top of Handles. Handles +-- don't perform well with lots of hPutChars, which is mostly +-- what we're doing here, because Handles have to be thread-safe +-- and async exception-safe. We only have a single thread and don't +-- care about exceptions, so we add a layer of fast buffering +-- over the Handle interface. + +printLeftRender :: Handle -> Doc -> IO () +printLeftRender hdl doc = do + b <- newBufHandle hdl + bufLeftRender b doc + bFlush b + +bufLeftRender :: BufHandle -> Doc -> IO () +bufLeftRender b doc = layLeft b (reduceDoc doc) + +layLeft :: BufHandle -> Doc -> IO () +layLeft b _ | b `seq` False = undefined -- make it strict in b +layLeft _ NoDoc = error "layLeft: NoDoc" +layLeft b (Union p q) = layLeft b $! first p q +layLeft b (Nest _ p) = layLeft b $! p +layLeft b Empty = bPutChar b '\n' +layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) +layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) + where + put b _ | b `seq` False = undefined + put b (Chr c) = bPutChar b c + put b (Str s) = bPutStr b s + put b (PStr s) = bPutFS b s + put b (ZStr s) = bPutFZS b s + put b (LStr s) = bPutPtrString b s + put b (RStr n c) = bPutReplicate b n c +layLeft _ _ = panic "layLeft: Unhandled case" + +-- Define error=panic, for easier comparison with libraries/pretty. +error :: String -> a +error = panic diff --git a/GHC/Utils/Ppr/Colour.hs b/GHC/Utils/Ppr/Colour.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Ppr/Colour.hs @@ -0,0 +1,101 @@ +module GHC.Utils.Ppr.Colour where +import GHC.Prelude + +import Data.Maybe (fromMaybe) +import GHC.Utils.Misc (OverridingBool(..), split) +import Data.Semigroup as Semi + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour { renderColour :: String } + +instance Semi.Semigroup PprColour where + PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) + +-- | Allow colours to be combined (e.g. bold + red); +-- In case of conflict, right side takes precedence. +instance Monoid PprColour where + mempty = PprColour mempty + mappend = (<>) + +renderColourAfresh :: PprColour -> String +renderColourAfresh c = renderColour (colReset `mappend` c) + +colCustom :: String -> PprColour +colCustom "" = mempty +colCustom s = PprColour ("\27[" ++ s ++ "m") + +colReset :: PprColour +colReset = colCustom "0" + +colBold :: PprColour +colBold = colCustom ";1" + +colBlackFg :: PprColour +colBlackFg = colCustom "30" + +colRedFg :: PprColour +colRedFg = colCustom "31" + +colGreenFg :: PprColour +colGreenFg = colCustom "32" + +colYellowFg :: PprColour +colYellowFg = colCustom "33" + +colBlueFg :: PprColour +colBlueFg = colCustom "34" + +colMagentaFg :: PprColour +colMagentaFg = colCustom "35" + +colCyanFg :: PprColour +colCyanFg = colCustom "36" + +colWhiteFg :: PprColour +colWhiteFg = colCustom "37" + +data Scheme = + Scheme + { sHeader :: PprColour + , sMessage :: PprColour + , sWarning :: PprColour + , sError :: PprColour + , sFatal :: PprColour + , sMargin :: PprColour + } + +defaultScheme :: Scheme +defaultScheme = + Scheme + { sHeader = mempty + , sMessage = colBold + , sWarning = colBold `mappend` colMagentaFg + , sError = colBold `mappend` colRedFg + , sFatal = colBold `mappend` colRedFg + , sMargin = colBold `mappend` colBlueFg + } + +-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ +-- environment variable). +parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) +parseScheme "always" (_, cs) = (Always, cs) +parseScheme "auto" (_, cs) = (Auto, cs) +parseScheme "never" (_, cs) = (Never, cs) +parseScheme input (b, cs) = + ( b + , Scheme + { sHeader = fromMaybe (sHeader cs) (lookup "header" table) + , sMessage = fromMaybe (sMessage cs) (lookup "message" table) + , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) + , sError = fromMaybe (sError cs) (lookup "error" table) + , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) + , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) + } + ) + where + table = do + w <- split ':' input + let (k, v') = break (== '=') w + case v' of + '=' : v -> return (k, colCustom v) + _ -> [] diff --git a/HsVersions.h b/HsVersions.h --- a/HsVersions.h +++ b/HsVersions.h @@ -15,25 +15,25 @@ #define GLOBAL_VAR(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.global (value); +name = GHC.Utils.Misc.global (value); #define GLOBAL_VAR_M(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.globalM (value); +name = GHC.Utils.Misc.globalM (value); #define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.sharedGlobal (value) (accessor); \ +name = GHC.Utils.Misc.sharedGlobal (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); #define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = Util.sharedGlobalM (value) (accessor); \ +name = GHC.Utils.Misc.sharedGlobalM (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); diff --git a/backpack/BkpSyn.hs b/backpack/BkpSyn.hs deleted file mode 100644 --- a/backpack/BkpSyn.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | This is the syntax for bkp files which are parsed in 'ghc --backpack' --- mode. This syntax is used purely for testing purposes. - -module BkpSyn ( - -- * Backpack abstract syntax - HsUnitId(..), - LHsUnitId, - HsModuleSubst, - LHsModuleSubst, - HsModuleId(..), - LHsModuleId, - HsComponentId(..), - LHsUnit, HsUnit(..), - LHsUnitDecl, HsUnitDecl(..), - IncludeDecl(..), - LRenaming, Renaming(..), - ) where - -import GhcPrelude - -import DriverPhases -import GHC.Hs -import SrcLoc -import Outputable -import Module -import PackageConfig - -{- -************************************************************************ -* * - User syntax -* * -************************************************************************ --} - -data HsComponentId = HsComponentId { - hsPackageName :: PackageName, - hsComponentId :: ComponentId - } - -instance Outputable HsComponentId where - ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn - -data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] -type LHsUnitId n = Located (HsUnitId n) - -type HsModuleSubst n = (Located ModuleName, LHsModuleId n) -type LHsModuleSubst n = Located (HsModuleSubst n) - -data HsModuleId n = HsModuleVar (Located ModuleName) - | HsModuleId (LHsUnitId n) (Located ModuleName) -type LHsModuleId n = Located (HsModuleId n) - --- | Top level @unit@ declaration in a Backpack file. -data HsUnit n = HsUnit { - hsunitName :: Located n, - hsunitBody :: [LHsUnitDecl n] - } -type LHsUnit n = Located (HsUnit n) - --- | A declaration in a package, e.g. a module or signature definition, --- or an include. -data HsUnitDecl n - = DeclD HscSource (Located ModuleName) (Maybe (Located (HsModule GhcPs))) - | IncludeD (IncludeDecl n) -type LHsUnitDecl n = Located (HsUnitDecl n) - --- | An include of another unit -data IncludeDecl n = IncludeDecl { - idUnitId :: LHsUnitId n, - idModRenaming :: Maybe [ LRenaming ], - -- | Is this a @dependency signature@ include? If so, - -- we don't compile this include when we instantiate this - -- unit (as there should not be any modules brought into - -- scope.) - idSignatureInclude :: Bool - } - --- | Rename a module from one name to another. The identity renaming --- means that the module should be brought into scope. -data Renaming = Renaming { renameFrom :: Located ModuleName - , renameTo :: Maybe (Located ModuleName) } -type LRenaming = Located Renaming diff --git a/backpack/DriverBkp.hs b/backpack/DriverBkp.hs deleted file mode 100644 --- a/backpack/DriverBkp.hs +++ /dev/null @@ -1,828 +0,0 @@ -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} - --- | This is the driver for the 'ghc --backpack' mode, which --- is a reimplementation of the "package manager" bits of --- Backpack directly in GHC. The basic method of operation --- is to compile packages and then directly insert them into --- GHC's in memory database. --- --- The compilation products of this mode aren't really suitable --- for Cabal, because GHC makes up component IDs for the things --- it builds and doesn't serialize out the database contents. --- But it's still handy for constructing tests. - -module DriverBkp (doBackpack) where - -#include "HsVersions.h" - -import GhcPrelude - --- In a separate module because it hooks into the parser. -import BkpSyn - -import GHC hiding (Failed, Succeeded) -import Packages -import Parser -import Lexer -import GhcMonad -import DynFlags -import TcRnMonad -import TcRnDriver -import Module -import HscTypes -import StringBuffer -import FastString -import ErrUtils -import SrcLoc -import HscMain -import UniqFM -import UniqDFM -import Outputable -import Maybes -import HeaderInfo -import MkIface -import GhcMake -import UniqDSet -import PrelNames -import BasicTypes hiding (SuccessFlag(..)) -import Finder -import Util - -import qualified GHC.LanguageExtensions as LangExt - -import Panic -import Data.List ( partition ) -import System.Exit -import Control.Monad -import System.FilePath -import Data.Version - --- for the unification -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map - --- | Entry point to compile a Backpack file. -doBackpack :: [FilePath] -> Ghc () -doBackpack [src_filename] = do - -- Apply options from file to dflags - dflags0 <- getDynFlags - let dflags1 = dflags0 - src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename - (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts - modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) - -- Cribbed from: preprocessFile / DriverPipeline - liftIO $ checkProcessArgsResult dflags unhandled_flags - liftIO $ handleFlagWarnings dflags warns - -- TODO: Preprocessing not implemented - - buf <- liftIO $ hGetStringBuffer src_filename - let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great - case unP parseBackpack (mkPState dflags buf loc) of - PFailed pst -> throwErrors (getErrorMessages pst dflags) - POk _ pkgname_bkp -> do - -- OK, so we have an LHsUnit PackageName, but we want an - -- LHsUnit HsComponentId. So let's rename it. - let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp - initBkpM src_filename bkp $ - forM_ (zip [1..] bkp) $ \(i, lunit) -> do - let comp_name = unLoc (hsunitName (unLoc lunit)) - msgTopPackage (i,length bkp) comp_name - innerBkpM $ do - let (cid, insts) = computeUnitId lunit - if null insts - then if cid == ComponentId (fsLit "main") - then compileExe lunit - else compileUnit cid [] - else typecheckUnit cid insts -doBackpack _ = - throwGhcException (CmdLineError "--backpack can only process a single file") - -computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)]) -computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) - where - cid = hsComponentId (unLoc (hsunitName unit)) - reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) - get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname - get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet - get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet - get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = - unitIdFreeHoles (convertHsUnitId hsuid) - --- | Tiny enum for all types of Backpack operations we may do. -data SessionType - -- | A compilation operation which will result in a - -- runnable executable being produced. - = ExeSession - -- | A type-checking operation which produces only - -- interface files, no object files. - | TcSession - -- | A compilation operation which produces both - -- interface files and object files. - | CompSession - deriving (Eq) - --- | Create a temporary Session to do some sort of type checking or --- compilation. -withBkpSession :: ComponentId - -> [(ModuleName, Module)] - -> [(UnitId, ModRenaming)] - -> SessionType -- what kind of session are we doing - -> BkpM a -- actual action to run - -> BkpM a -withBkpSession cid insts deps session_type do_this = do - dflags <- getDynFlags - let (ComponentId cid_fs) = cid - is_primary = False - uid_str = unpackFS (hashUnitId cid insts) - cid_str = unpackFS cid_fs - -- There are multiple units in a single Backpack file, so we - -- need to separate out the results in those cases. Right now, - -- we follow this hierarchy: - -- $outputdir/$compid --> typecheck results - -- $outputdir/$compid/$unitid --> compile results - key_base p | Just f <- p dflags = f - | otherwise = "." - sub_comp p | is_primary = p - | otherwise = p cid_str - outdir p | CompSession <- session_type - -- Special case when package is definite - , not (null insts) = sub_comp (key_base p) uid_str - | otherwise = sub_comp (key_base p) - withTempSession (overHscDynFlags (\dflags -> - -- If we're type-checking an indefinite package, we want to - -- turn on interface writing. However, if the user also - -- explicitly passed in `-fno-code`, we DON'T want to write - -- interfaces unless the user also asked for `-fwrite-interface`. - -- See Note [-fno-code mode] - (case session_type of - -- Make sure to write interfaces when we are type-checking - -- indefinite packages. - TcSession | hscTarget dflags /= HscNothing - -> flip gopt_set Opt_WriteInterface - | otherwise -> id - CompSession -> id - ExeSession -> id) $ - dflags { - hscTarget = case session_type of - TcSession -> HscNothing - _ -> hscTarget dflags, - thisUnitIdInsts_ = Just insts, - thisComponentId_ = Just cid, - thisInstalledUnitId = - case session_type of - TcSession -> newInstalledUnitId cid Nothing - -- No hash passed if no instances - _ | null insts -> newInstalledUnitId cid Nothing - | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)), - -- Setup all of the output directories according to our hierarchy - objectDir = Just (outdir objectDir), - hiDir = Just (outdir hiDir), - stubDir = Just (outdir stubDir), - -- Unset output-file for non exe builds - outputFile = if session_type == ExeSession - then outputFile dflags - else Nothing, - -- Clear the import path so we don't accidentally grab anything - importPaths = [], - -- Synthesized the flags - packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) - in ExposePackage - (showSDoc dflags - (text "-unit-id" <+> ppr uid <+> ppr rn)) - (UnitIdArg uid) rn) deps - } )) $ do - dflags <- getSessionDynFlags - -- pprTrace "flags" (ppr insts <> ppr deps) $ return () - -- Calls initPackages - _ <- setSessionDynFlags dflags - do_this - -withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a -withBkpExeSession deps do_this = do - withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this - -getSource :: ComponentId -> BkpM (LHsUnit HsComponentId) -getSource cid = do - bkp_env <- getBkpEnv - case Map.lookup cid (bkp_table bkp_env) of - Nothing -> pprPanic "missing needed dependency" (ppr cid) - Just lunit -> return lunit - -typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () -typecheckUnit cid insts = do - lunit <- getSource cid - buildUnit TcSession cid insts lunit - -compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () -compileUnit cid insts = do - -- Let everyone know we're building this unit ID - msgUnitId (newUnitId cid insts) - lunit <- getSource cid - buildUnit CompSession cid insts lunit - --- | Compute the dependencies with instantiations of a syntactic --- HsUnit; e.g., wherever you see @dependency p[A=]@ in a --- unit file, return the 'UnitId' corresponding to @p[A=]@. --- The @include_sigs@ parameter controls whether or not we also --- include @dependency signature@ declarations in this calculation. --- --- Invariant: this NEVER returns InstalledUnitId. -hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)] -hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) - where - get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) - | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)] - | otherwise = [] - where - go Nothing = ModRenaming True [] - go (Just lrns) = ModRenaming False (map convRn lrns) - where - convRn (L _ (Renaming (L _ from) Nothing)) = (from, from) - convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) - get_dep _ = [] - -buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () -buildUnit session cid insts lunit = do - -- NB: include signature dependencies ONLY when typechecking. - -- If we're compiling, it's not necessary to recursively - -- compile a signature since it isn't going to produce - -- any object files. - let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) - raw_deps = map fst deps_w_rns - dflags <- getDynFlags - -- The compilation dependencies are just the appropriately filled - -- in unit IDs which must be compiled before we can compile. - let hsubst = listToUFM insts - deps0 = map (renameHoleUnitId dflags hsubst) raw_deps - - -- Build dependencies OR make sure they make sense. BUT NOTE, - -- we can only check the ones that are fully filled; the rest - -- we have to defer until we've typechecked our local signature. - -- TODO: work this into GhcMake!! - forM_ (zip [1..] deps0) $ \(i, dep) -> - case session of - TcSession -> return () - _ -> compileInclude (length deps0) (i, dep) - - dflags <- getDynFlags - -- IMPROVE IT - let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0 - - mb_old_eps <- case session of - TcSession -> fmap Just getEpsGhc - _ -> return Nothing - - conf <- withBkpSession cid insts deps_w_rns session $ do - - dflags <- getDynFlags - mod_graph <- hsunitModuleGraph dflags (unLoc lunit) - -- pprTrace "mod_graph" (ppr mod_graph) $ return () - - msg <- mkBackpackMsg - ok <- load' LoadAllTargets (Just msg) mod_graph - when (failed ok) (liftIO $ exitWith (ExitFailure 1)) - - let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags - export_mod ms = (ms_mod_name ms, ms_mod ms) - -- Export everything! - mods = [ export_mod ms | ms <- mgModSummaries mod_graph - , ms_hsc_src ms == HsSrcFile ] - - -- Compile relevant only - hsc_env <- getSession - let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) - linkables = map (expectJust "bkp link" . hm_linkable) - . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) - $ home_mod_infos - getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables - - let compat_fs = (case cid of ComponentId fs -> fs) - compat_pn = PackageName compat_fs - - return InstalledPackageInfo { - -- Stub data - abiHash = "", - sourcePackageId = SourcePackageId compat_fs, - packageName = compat_pn, - packageVersion = makeVersion [0], - unitId = toInstalledUnitId (thisPackage dflags), - sourceLibName = Nothing, - componentId = cid, - instantiatedWith = insts, - -- Slight inefficiency here haha - exposedModules = map (\(m,n) -> (m,Just n)) mods, - hiddenModules = [], -- TODO: doc only - depends = case session of - -- Technically, we should state that we depend - -- on all the indefinite libraries we used to - -- typecheck this. However, this field isn't - -- really used for anything, so we leave it - -- blank for now. - TcSession -> [] - _ -> map (toInstalledUnitId . unwireUnitId dflags) - $ deps ++ [ moduleUnitId mod - | (_, mod) <- insts - , not (isHoleModule mod) ], - abiDepends = [], - ldOptions = case session of - TcSession -> [] - _ -> obj_files, - importDirs = [ hi_dir ], - exposed = False, - indefinite = case session of - TcSession -> True - _ -> False, - -- nope - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries = [], - libraryDynDirs = [], - libraryDirs = [], - frameworks = [], - frameworkDirs = [], - ccOptions = [], - includes = [], - includeDirs = [], - haddockInterfaces = [], - haddockHTMLs = [], - trusted = False - } - - - addPackage conf - case mb_old_eps of - Just old_eps -> updateEpsGhc_ (const old_eps) - _ -> return () - -compileExe :: LHsUnit HsComponentId -> BkpM () -compileExe lunit = do - msgUnitId mainUnitId - let deps_w_rns = hsunitDeps False (unLoc lunit) - deps = map fst deps_w_rns - -- no renaming necessary - forM_ (zip [1..] deps) $ \(i, dep) -> - compileInclude (length deps) (i, dep) - withBkpExeSession deps_w_rns $ do - dflags <- getDynFlags - mod_graph <- hsunitModuleGraph dflags (unLoc lunit) - msg <- mkBackpackMsg - ok <- load' LoadAllTargets (Just msg) mod_graph - when (failed ok) (liftIO $ exitWith (ExitFailure 1)) - -addPackage :: GhcMonad m => PackageConfig -> m () -addPackage pkg = do - dflags0 <- GHC.getSessionDynFlags - case pkgDatabase dflags0 of - Nothing -> panic "addPackage: called too early" - Just pkgs -> do let dflags = dflags0 { pkgDatabase = - Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) } - _ <- GHC.setSessionDynFlags dflags - -- By this time, the global ref has probably already - -- been forced, in which case doing this isn't actually - -- going to do you any good. - -- dflags <- GHC.getSessionDynFlags - -- liftIO $ setUnsafeGlobalDynFlags dflags - return () - --- Precondition: UnitId is NOT InstalledUnitId -compileInclude :: Int -> (Int, UnitId) -> BkpM () -compileInclude n (i, uid) = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - msgInclude (i, n) uid - -- Check if we've compiled it already - case lookupPackage dflags uid of - Nothing -> do - case splitUnitIdInsts uid of - (_, Just indef) -> - innerBkpM $ compileUnit (indefUnitIdComponentId indef) - (indefUnitIdInsts indef) - _ -> return () - Just _ -> return () - --- ---------------------------------------------------------------------------- --- Backpack monad - --- | Backpack monad is a 'GhcMonad' which also maintains a little extra state --- beyond the 'Session', c.f. 'BkpEnv'. -type BkpM = IOEnv BkpEnv - --- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv', --- because we are going to update the 'HscEnv' as we go. -data BkpEnv - = BkpEnv { - -- | The session - bkp_session :: Session, - -- | The filename of the bkp file we're compiling - bkp_filename :: FilePath, - -- | Table of source units which we know how to compile - bkp_table :: Map ComponentId (LHsUnit HsComponentId), - -- | When a package we are compiling includes another package - -- which has not been compiled, we bump the level and compile - -- that. - bkp_level :: Int - } - --- Blah, to get rid of the default instance for IOEnv --- TODO: just make a proper new monad for BkpM, rather than use IOEnv -instance {-# OVERLAPPING #-} HasDynFlags BkpM where - getDynFlags = fmap hsc_dflags getSession - -instance GhcMonad BkpM where - getSession = do - Session s <- fmap bkp_session getEnv - readMutVar s - setSession hsc_env = do - Session s <- fmap bkp_session getEnv - writeMutVar s hsc_env - --- | Get the current 'BkpEnv'. -getBkpEnv :: BkpM BkpEnv -getBkpEnv = getEnv - --- | Get the nesting level, when recursively compiling modules. -getBkpLevel :: BkpM Int -getBkpLevel = bkp_level `fmap` getBkpEnv - --- | Apply a function on 'DynFlags' on an 'HscEnv' -overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv -overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) } - --- | Run a 'BkpM' computation, with the nesting level bumped one. -innerBkpM :: BkpM a -> BkpM a -innerBkpM do_this = do - -- NB: withTempSession mutates, so we don't have to worry - -- about bkp_session being stale. - updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this - --- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot. -updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () -updateEpsGhc_ f = do - hsc_env <- getSession - liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ())) - --- | Get the EPS from a 'GhcMonad'. -getEpsGhc :: GhcMonad m => m ExternalPackageState -getEpsGhc = do - hsc_env <- getSession - liftIO $ readIORef (hsc_EPS hsc_env) - --- | Run 'BkpM' in 'Ghc'. -initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a -initBkpM file bkp m = do - reifyGhc $ \session -> do - let env = BkpEnv { - bkp_session = session, - bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], - bkp_filename = file, - bkp_level = 0 - } - runIOEnv env m - --- ---------------------------------------------------------------------------- --- Messaging - --- | Print a compilation progress message, but with indentation according --- to @level@ (for nested compilation). -backpackProgressMsg :: Int -> DynFlags -> String -> IO () -backpackProgressMsg level dflags msg = - compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg - --- | Creates a 'Messager' for Backpack compilation; this is basically --- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which --- handles indentation. -mkBackpackMsg :: BkpM Messager -mkBackpackMsg = do - level <- getBkpLevel - return $ \hsc_env mod_index recomp mod_summary -> - let dflags = hsc_dflags hsc_env - showMsg msg reason = - backpackProgressMsg level dflags $ - showModuleIndex mod_index ++ - msg ++ showModMsg dflags (hscTarget dflags) - (recompileRequired recomp) mod_summary - ++ reason - in case recomp of - MustCompile -> showMsg "Compiling " "" - UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" - | otherwise -> return () - RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") - --- | 'PprStyle' for Backpack messages; here we usually want the module to --- be qualified (so we can tell how it was instantiated.) But we try not --- to qualify packages so we can use simple names for them. -backpackStyle :: DynFlags -> PprStyle -backpackStyle dflags = - mkUserStyle dflags - (QueryQualify neverQualifyNames - alwaysQualifyModules - neverQualifyPackages) AllTheWay - --- | Message when we initially process a Backpack unit. -msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () -msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do - dflags <- getDynFlags - level <- getBkpLevel - liftIO . backpackProgressMsg level dflags - $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn - --- | Message when we instantiate a Backpack unit. -msgUnitId :: UnitId -> BkpM () -msgUnitId pk = do - dflags <- getDynFlags - level <- getBkpLevel - liftIO . backpackProgressMsg level dflags - $ "Instantiating " ++ renderWithStyle dflags (ppr pk) - (backpackStyle dflags) - --- | Message when we include a Backpack unit. -msgInclude :: (Int,Int) -> UnitId -> BkpM () -msgInclude (i,n) uid = do - dflags <- getDynFlags - level <- getBkpLevel - liftIO . backpackProgressMsg level dflags - $ showModuleIndex (i, n) ++ "Including " ++ - renderWithStyle dflags (ppr uid) (backpackStyle dflags) - --- ---------------------------------------------------------------------------- --- Conversion from PackageName to HsComponentId - -type PackageNameMap a = Map PackageName a - --- For now, something really simple, since we're not actually going --- to use this for anything -unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) -unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) - = (pn, HsComponentId pn (ComponentId fs)) - -packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId -packageNameMap units = Map.fromList (map unitDefines units) - -renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] -renameHsUnits dflags m units = map (fmap renameHsUnit) units - where - - renamePackageName :: PackageName -> HsComponentId - renamePackageName pn = - case Map.lookup pn m of - Nothing -> - case lookupPackageName dflags pn of - Nothing -> error "no package name" - Just cid -> HsComponentId pn cid - Just hscid -> hscid - - renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId - renameHsUnit u = - HsUnit { - hsunitName = fmap renamePackageName (hsunitName u), - hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u) - } - - renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId - renameHsUnitDecl (DeclD a b c) = DeclD a b c - renameHsUnitDecl (IncludeD idecl) = - IncludeD IncludeDecl { - idUnitId = fmap renameHsUnitId (idUnitId idecl), - idModRenaming = idModRenaming idecl, - idSignatureInclude = idSignatureInclude idecl - } - - renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId - renameHsUnitId (HsUnitId ln subst) - = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst) - - renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId - renameHsModuleSubst (lk, lm) - = (lk, fmap renameHsModuleId lm) - - renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId - renameHsModuleId (HsModuleVar lm) = HsModuleVar lm - renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm - -convertHsUnitId :: HsUnitId HsComponentId -> UnitId -convertHsUnitId (HsUnitId (L _ hscid) subst) - = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) - -convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) -convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) - -convertHsModuleId :: HsModuleId HsComponentId -> Module -convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname -convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname - - - -{- -************************************************************************ -* * - Module graph construction -* * -************************************************************************ --} - --- | This is our version of GhcMake.downsweep, but with a few modifications: --- --- 1. Every module is required to be mentioned, so we don't do any funny --- business with targets or recursively grabbing dependencies. (We --- could support this in principle). --- 2. We support inline modules, whose summary we have to synthesize ourself. --- --- We don't bother trying to support GhcMake for now, it's more trouble --- than it's worth for inline modules. -hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph -hsunitModuleGraph dflags unit = do - let decls = hsunitBody unit - pn = hsPackageName (unLoc (hsunitName unit)) - - -- 1. Create a HsSrcFile/HsigFile summary for every - -- explicitly mentioned module/signature. - let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do - Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod - get_decl _ = return Nothing - nodes <- catMaybes `fmap` mapM get_decl decls - - -- 2. For each hole which does not already have an hsig file, - -- create an "empty" hsig file to induce compilation for the - -- requirement. - let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) - | n <- nodes ] - req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) -> - let has_local = Map.member (mod_name, True) node_map - in if has_local - then return Nothing - else fmap Just $ summariseRequirement pn mod_name - - -- 3. Return the kaboodle - return $ mkModuleGraph $ nodes ++ req_nodes - -summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary -summariseRequirement pn mod_name = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - - let PackageName pn_fs = pn - location <- liftIO $ mkHomeModLocation2 dflags mod_name - (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" - - env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) - let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) - - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name - - return ModSummary { - ms_mod = mod, - ms_hsc_src = HsigFile, - ms_location = location, - ms_hs_date = time, - ms_obj_date = Nothing, - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp, - ms_srcimps = [], - ms_textual_imps = extra_sig_imports, - ms_parsed_mod = Just (HsParsedModule { - hpm_module = L loc (HsModule { - hsmodName = Just (L loc mod_name), - hsmodExports = Nothing, - hsmodImports = [], - hsmodDecls = [], - hsmodDeprecMessage = Nothing, - hsmodHaddockModHeader = Nothing - }), - hpm_src_files = [], - hpm_annotations = (Map.empty, Map.empty) - }), - ms_hspp_file = "", -- none, it came inline - ms_hspp_opts = dflags, - ms_hspp_buf = Nothing - } - -summariseDecl :: PackageName - -> HscSource - -> Located ModuleName - -> Maybe (Located (HsModule GhcPs)) - -> BkpM ModSummary -summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod -summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing - = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env - -- TODO: this looks for modules in the wrong place - r <- liftIO $ summariseModule hsc_env - Map.empty -- GHC API recomp not supported - (hscSourceToIsBoot hsc_src) - lmodname - True -- Target lets you disallow, but not here - Nothing -- GHC API buffer support not supported - [] -- No exclusions - case r of - Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) - Just (Left err) -> throwErrors err - Just (Right summary) -> return summary - --- | Up until now, GHC has assumed a single compilation target per source file. --- Backpack files with inline modules break this model, since a single file --- may generate multiple output files. How do we decide to name these files? --- Should there only be one output file? This function our current heuristic, --- which is we make a "fake" module and use that. -hsModuleToModSummary :: PackageName - -> HscSource - -> ModuleName - -> Located (HsModule GhcPs) - -> BkpM ModSummary -hsModuleToModSummary pn hsc_src modname - hsmod = do - let imps = hsmodImports (unLoc hsmod) - loc = getLoc hsmod - hsc_env <- getSession - -- Sort of the same deal as in DriverPipeline's getLocation - -- Use the PACKAGE NAME to find the location - let PackageName unit_fs = pn - dflags = hsc_dflags hsc_env - -- Unfortunately, we have to define a "fake" location in - -- order to appease the various code which uses the file - -- name to figure out where to put, e.g. object files. - -- To add insult to injury, we don't even actually use - -- these filenames to figure out where the hi files go. - -- A travesty! - location0 <- liftIO $ mkHomeModLocation2 dflags modname - (unpackFS unit_fs - moduleNameSlashes modname) - (case hsc_src of - HsigFile -> "hsig" - HsBootFile -> "hs-boot" - HsSrcFile -> "hs") - -- DANGEROUS: bootifying can POISON the module finder cache - let location = case hsc_src of - HsBootFile -> addBootSuffixLocnOut location0 - _ -> location0 - -- This duplicates a pile of logic in GhcMake - env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) - - -- Also copied from 'getImports' - let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports modname loc - implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) - - extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname - - let normal_imports = map convImport (implicit_imports ++ ordinary_imps) - required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports - - -- So that Finder can find it, even though it doesn't exist... - this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location - return ModSummary { - ms_mod = this_mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = (case hiDir dflags of - Nothing -> "" - Just d -> d) ".." moduleNameSlashes modname <.> "hi", - ms_hspp_opts = dflags, - ms_hspp_buf = Nothing, - ms_srcimps = map convImport src_idecls, - ms_textual_imps = normal_imports - -- We have to do something special here: - -- due to merging, requirements may end up with - -- extra imports - ++ extra_sig_imports - ++ required_by_imports, - -- This is our hack to get the parse tree to the right spot - ms_parsed_mod = Just (HsParsedModule { - hpm_module = hsmod, - hpm_src_files = [], -- TODO if we preprocessed it - hpm_annotations = (Map.empty, Map.empty) -- BOGUS - }), - ms_hs_date = time, - ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp - } - --- | Create a new, externally provided hashed unit id from --- a hash. -newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId -newInstalledUnitId (ComponentId cid_fs) (Just fs) - = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs) -newInstalledUnitId (ComponentId cid_fs) Nothing - = InstalledUnitId cid_fs diff --git a/backpack/NameShape.hs b/backpack/NameShape.hs deleted file mode 100644 --- a/backpack/NameShape.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE CPP #-} - -module NameShape( - NameShape(..), - emptyNameShape, - mkNameShape, - extendNameShape, - nameShapeExports, - substNameShape, - maybeSubstNameShape, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Outputable -import HscTypes -import Module -import UniqFM -import Avail -import FieldLabel - -import Name -import NameEnv -import TcRnMonad -import Util -import IfaceEnv - -import Control.Monad - --- Note [NameShape] --- ~~~~~~~~~~~~~~~~ --- When we write a declaration in a signature, e.g., data T, we --- ascribe to it a *name variable*, e.g., {m.T}. This --- name variable may be substituted with an actual original --- name when the signature is implemented (or even if we --- merge the signature with one which reexports this entity --- from another module). - --- When we instantiate a signature m with a module M, --- we also need to substitute over names. To do so, we must --- compute the *name substitution* induced by the *exports* --- of the module in question. A NameShape represents --- such a name substitution for a single module instantiation. --- The "shape" in the name comes from the fact that the computation --- of a name substitution is essentially the *shaping pass* from --- Backpack'14, but in a far more restricted form. - --- The name substitution for an export list is easy to explain. If we are --- filling the module variable , given an export N of the form --- M.n or {m'.n} (where n is an OccName), the induced name --- substitution is from {m.n} to N. So, for example, if we have --- A=impl:B, and the exports of impl:B are impl:B.f and --- impl:C.g, then our name substitution is {A.f} to impl:B.f --- and {A.g} to impl:C.g - - - - --- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes --- needs to refer to NameShape, and having TcRnTypes import --- NameShape (even by SOURCE) would cause a large number of --- modules to be pulled into the DynFlags cycle. -{- -data NameShape = NameShape { - ns_mod_name :: ModuleName, - ns_exports :: [AvailInfo], - ns_map :: OccEnv Name - } --} - --- NB: substitution functions need 'HscEnv' since they need the name cache --- to allocate new names if we change the 'Module' of a 'Name' - --- | Create an empty 'NameShape' (i.e., the renaming that --- would occur with an implementing module with no exports) --- for a specific hole @mod_name@. -emptyNameShape :: ModuleName -> NameShape -emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv - --- | Create a 'NameShape' corresponding to an implementing --- module for the hole @mod_name@ that exports a list of 'AvailInfo's. -mkNameShape :: ModuleName -> [AvailInfo] -> NameShape -mkNameShape mod_name as = - NameShape mod_name as $ mkOccEnv $ do - a <- as - n <- availName a : availNamesWithSelectors a - return (occName n, n) - --- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's --- with Backpack style mix-in linking. This is used solely when merging --- signatures together: we successively merge the exports of each --- signature until we have the final, full exports of the merged signature. --- --- What makes this operation nontrivial is what we are supposed to do when --- we want to merge in an export for M.T when we already have an existing --- export {H.T}. What should happen in this case is that {H.T} should be --- unified with @M.T@: we've determined a more *precise* identity for the --- export at 'OccName' @T@. --- --- Note that we don't do unrestricted unification: only name holes from --- @ns_mod_name ns@ are flexible. This is because we have a much more --- restricted notion of shaping than in Backpack'14: we do shaping --- *as* we do type-checking. Thus, once we shape a signature, its --- exports are *final* and we're not allowed to refine them further, -extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape) -extendNameShape hsc_env ns as = - case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of - Left err -> return (Left err) - Right nsubst -> do - as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns) - as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as - let new_avails = mergeAvails as1 as2 - return . Right $ ns { - ns_exports = new_avails, - -- TODO: stop repeatedly rebuilding the OccEnv - ns_map = mkOccEnv $ do - a <- new_avails - n <- availName a : availNames a - return (occName n, n) - } - --- | The export list associated with this 'NameShape' (i.e., what --- the exports of an implementing module which induces this 'NameShape' --- would be.) -nameShapeExports :: NameShape -> [AvailInfo] -nameShapeExports = ns_exports - --- | Given a 'Name', substitute it according to the 'NameShape' implied --- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module --- exports @M.T@. -substNameShape :: NameShape -> Name -> Name -substNameShape ns n | nameModule n == ns_module ns - , Just n' <- lookupOccEnv (ns_map ns) (occName n) - = n' - | otherwise - = n - --- | Like 'substNameShape', but returns @Nothing@ if no substitution --- works. -maybeSubstNameShape :: NameShape -> Name -> Maybe Name -maybeSubstNameShape ns n - | nameModule n == ns_module ns - = lookupOccEnv (ns_map ns) (occName n) - | otherwise - = Nothing - --- | The 'Module' of any 'Name's a 'NameShape' has action over. -ns_module :: NameShape -> Module -ns_module = mkHoleModule . ns_mod_name - -{- -************************************************************************ -* * - Name substitutions -* * -************************************************************************ --} - --- | Substitution on @{A.T}@. We enforce the invariant that the --- 'nameModule' of keys of this map have 'moduleUnitId' @hole@ --- (meaning that if we have a hole substitution, the keys of the map --- are never affected.) Alternatively, this is isomorphic to --- @Map ('ModuleName', 'OccName') 'Name'@. -type ShNameSubst = NameEnv Name - --- NB: In this module, we actually only ever construct 'ShNameSubst' --- at a single 'ModuleName'. But 'ShNameSubst' is more convenient to --- work with. - --- | Substitute names in a 'Name'. -substName :: ShNameSubst -> Name -> Name -substName env n | Just n' <- lookupNameEnv env n = n' - | otherwise = n - --- | Substitute names in an 'AvailInfo'. This has special behavior --- for type constructors, where it is sufficient to substitute the 'availName' --- to induce a substitution on 'availNames'. -substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo -substNameAvailInfo _ env (Avail n) = return (Avail (substName env n)) -substNameAvailInfo hsc_env env (AvailTC n ns fs) = - let mb_mod = fmap nameModule (lookupNameEnv env n) - in AvailTC (substName env n) - <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns - <*> mapM (setNameFieldSelector hsc_env mb_mod) fs - --- | Set the 'Module' of a 'FieldSelector' -setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel -setNameFieldSelector _ Nothing f = return f -setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do - sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel - return (FieldLabel l b sel') - -{- -************************************************************************ -* * - AvailInfo merging -* * -************************************************************************ --} - --- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have --- already been unified ('uAvailInfos'). -mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] -mergeAvails as1 as2 = - let mkNE as = mkNameEnv [(availName a, a) | a <- as] - in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2)) - -{- -************************************************************************ -* * - AvailInfo unification -* * -************************************************************************ --} - --- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@, --- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst -uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ - let mkOE as = listToUFM $ do a <- as - n <- availNames a - return (nameOccName n, a) - in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv - (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2))) - -- Edward: I have to say, this is pretty clever. - --- | Unify two 'AvailInfo's, given an existing substitution @subst@, --- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo - -> Either SDoc ShNameSubst -uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2 -uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2 -uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine" - <+> ppr a1 <+> text "with" <+> ppr a2 - <+> parens (text "one is a type, the other is a plain identifier") - --- | Unify two 'Name's, given an existing substitution @subst@, --- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst -uName flexi subst n1 n2 - | n1 == n2 = Right subst - | isFlexi n1 = uHoleName flexi subst n1 n2 - | isFlexi n2 = uHoleName flexi subst n2 n1 - | otherwise = Left (text "While merging export lists, could not unify" - <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra) - where - isFlexi n = isHoleName n && moduleName (nameModule n) == flexi - extra | isHoleName n1 || isHoleName n2 - = text "Neither name variable originates from the current signature." - | otherwise - = empty - --- | Unify a name @h@ which 'isHoleName' with another name, given an existing --- substitution @subst@, with only name holes from @flexi@ unifiable (all --- other name holes rigid.) -uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name - -> Either SDoc ShNameSubst -uHoleName flexi subst h n = - ASSERT( isHoleName h ) - case lookupNameEnv subst h of - Just n' -> uName flexi subst n' n - -- Do a quick check if the other name is substituted. - Nothing | Just n' <- lookupNameEnv subst n -> - ASSERT( isHoleName n ) uName flexi subst h n' - | otherwise -> - Right (extendNameEnv subst h n) diff --git a/backpack/RnModIface.hs b/backpack/RnModIface.hs deleted file mode 100644 --- a/backpack/RnModIface.hs +++ /dev/null @@ -1,743 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} - --- | This module implements interface renaming, which is --- used to rewrite interface files on the fly when we --- are doing indefinite typechecking and need instantiations --- of modules which do not necessarily exist yet. - -module RnModIface( - rnModIface, - rnModExports, - tcRnModIface, - tcRnModExports, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import SrcLoc -import Outputable -import HscTypes -import Module -import UniqFM -import Avail -import IfaceSyn -import FieldLabel -import Var -import ErrUtils - -import Name -import TcRnMonad -import Util -import Fingerprint -import BasicTypes - --- a bit vexing -import {-# SOURCE #-} LoadIface -import DynFlags - -import qualified Data.Traversable as T - -import Bag -import Data.IORef -import NameShape -import IfaceEnv - -tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a -tcRnMsgMaybe do_this = do - r <- liftIO $ do_this - case r of - Left errs -> do - addMessages (emptyBag, errs) - failM - Right x -> return x - -tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface -tcRnModIface x y z = do - hsc_env <- getTopEnv - tcRnMsgMaybe $ rnModIface hsc_env x y z - -tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo] -tcRnModExports x y = do - hsc_env <- getTopEnv - tcRnMsgMaybe $ rnModExports hsc_env x y - -failWithRn :: SDoc -> ShIfM a -failWithRn doc = do - errs_var <- fmap sh_if_errs getGblEnv - dflags <- getDynFlags - errs <- readTcRef errs_var - -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc) - failM - --- | What we have is a generalized ModIface, which corresponds to --- a module that looks like p[A=]:B. We need a *specific* ModIface, e.g. --- p[A=q():A]:B (or maybe even p[A=]:B) which we load --- up (either to merge it, or to just use during typechecking). --- --- Suppose we have: --- --- p[A=]:M ==> p[A=q():A]:M --- --- Substitute all occurrences of with q():A (renameHoleModule). --- Then, for any Name of form {A.T}, replace the Name with --- the Name according to the exports of the implementing module. --- This works even for p[A=]:M, since we just read in the --- exports of B.hi, which is assumed to be ready now. --- --- This function takes an optional 'NameShape', which can be used --- to further refine the identities in this interface: suppose --- we read a declaration for {H.T} but we actually know that this --- should be Foo.T; then we'll also rename this (this is used --- when loading an interface to merge it into a requirement.) -rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape - -> ModIface -> IO (Either ErrorMessages ModIface) -rnModIface hsc_env insts nsubst iface = do - initRnIface hsc_env iface insts nsubst $ do - mod <- rnModule (mi_module iface) - sig_of <- case mi_sig_of iface of - Nothing -> return Nothing - Just x -> fmap Just (rnModule x) - exports <- mapM rnAvailInfo (mi_exports iface) - decls <- mapM rnIfaceDecl' (mi_decls iface) - insts <- mapM rnIfaceClsInst (mi_insts iface) - fams <- mapM rnIfaceFamInst (mi_fam_insts iface) - deps <- rnDependencies (mi_deps iface) - -- TODO: - -- mi_rules - return iface { mi_module = mod - , mi_sig_of = sig_of - , mi_insts = insts - , mi_fam_insts = fams - , mi_exports = exports - , mi_decls = decls - , mi_deps = deps } - --- | Rename just the exports of a 'ModIface'. Useful when we're doing --- shaping prior to signature merging. -rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo]) -rnModExports hsc_env insts iface - = initRnIface hsc_env iface insts Nothing - $ mapM rnAvailInfo (mi_exports iface) - -rnDependencies :: Rename Dependencies -rnDependencies deps = do - orphs <- rnDepModules dep_orphs deps - finsts <- rnDepModules dep_finsts deps - return deps { dep_orphs = orphs, dep_finsts = finsts } - -rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module] -rnDepModules sel deps = do - hsc_env <- getTopEnv - hmap <- getHoleSubst - -- NB: It's not necessary to test if we're doing signature renaming, - -- because ModIface will never contain module reference for itself - -- in these dependencies. - fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do - dflags <- getDynFlags - -- For holes, its necessary to "see through" the instantiation - -- of the hole to get accurate family instance dependencies. - -- For example, if B imports , and is instantiated with - -- F, we must grab and include all of the dep_finsts from - -- F to have an accurate transitive dep_finsts list. - -- - -- However, we MUST NOT do this for regular modules. - -- First, for efficiency reasons, doing this - -- bloats the the dep_finsts list, because we *already* had - -- those modules in the list (it wasn't a hole module, after - -- all). But there's a second, more important correctness - -- consideration: we perform module renaming when running - -- --abi-hash. In this case, GHC's contract to the user is that - -- it will NOT go and read out interfaces of any dependencies - -- (https://github.com/haskell/cabal/issues/3633); the point of - -- --abi-hash is just to get a hash of the on-disk interfaces - -- for this *specific* package. If we go off and tug on the - -- interface for /everything/ in dep_finsts, we're gonna have a - -- bad time. (It's safe to do do this for hole modules, though, - -- because the hmap for --abi-hash is always trivial, so the - -- interface we request is local. Though, maybe we ought - -- not to do it in this case either...) - -- - -- This mistake was bug #15594. - let mod' = renameHoleModule dflags hmap mod - if isHoleModule mod - then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env - $ loadSysInterface (text "rnDepModule") mod' - return (mod' : sel (mi_deps iface)) - else return [mod'] - -{- -************************************************************************ -* * - ModIface substitution -* * -************************************************************************ --} - --- | Run a computation in the 'ShIfM' monad. -initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape - -> ShIfM a -> IO (Either ErrorMessages a) -initRnIface hsc_env iface insts nsubst do_this = do - errs_var <- newIORef emptyBag - let dflags = hsc_dflags hsc_env - hsubst = listToUFM insts - rn_mod = renameHoleModule dflags hsubst - env = ShIfEnv { - sh_if_module = rn_mod (mi_module iface), - sh_if_semantic_module = rn_mod (mi_semantic_module iface), - sh_if_hole_subst = listToUFM insts, - sh_if_shape = nsubst, - sh_if_errs = errs_var - } - -- Modeled off of 'initTc' - res <- initTcRnIf 'c' hsc_env env () $ tryM do_this - msgs <- readIORef errs_var - case res of - Left _ -> return (Left msgs) - Right r | not (isEmptyBag msgs) -> return (Left msgs) - | otherwise -> return (Right r) - --- | Environment for 'ShIfM' monads. -data ShIfEnv = ShIfEnv { - -- What we are renaming the ModIface to. It assumed that - -- the original mi_module of the ModIface is - -- @generalizeModule (mi_module iface)@. - sh_if_module :: Module, - -- The semantic module that we are renaming to - sh_if_semantic_module :: Module, - -- Cached hole substitution, e.g. - -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@ - sh_if_hole_subst :: ShHoleSubst, - -- An optional name substitution to be applied when renaming - -- the names in the interface. If this is 'Nothing', then - -- we just load the target interface and look at the export - -- list to determine the renaming. - sh_if_shape :: Maybe NameShape, - -- Mutable reference to keep track of errors (similar to 'tcl_errs') - sh_if_errs :: IORef ErrorMessages - } - -getHoleSubst :: ShIfM ShHoleSubst -getHoleSubst = fmap sh_if_hole_subst getGblEnv - -type ShIfM = TcRnIf ShIfEnv () -type Rename a = a -> ShIfM a - - -rnModule :: Rename Module -rnModule mod = do - hmap <- getHoleSubst - dflags <- getDynFlags - return (renameHoleModule dflags hmap mod) - -rnAvailInfo :: Rename AvailInfo -rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n -rnAvailInfo (AvailTC n ns fs) = do - -- Why don't we rnIfaceGlobal the availName itself? It may not - -- actually be exported by the module it putatively is from, in - -- which case we won't be able to tell what the name actually - -- is. But for the availNames they MUST be exported, so they - -- will rename fine. - ns' <- mapM rnIfaceGlobal ns - fs' <- mapM rnFieldLabel fs - case ns' ++ map flSelector fs' of - [] -> panic "rnAvailInfoEmpty AvailInfo" - (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do - n' <- setNameModule (Just (nameModule rep)) n - return (AvailTC n' ns' fs') - -rnFieldLabel :: Rename FieldLabel -rnFieldLabel (FieldLabel l b sel) = do - sel' <- rnIfaceGlobal sel - return (FieldLabel l b sel') - - - - --- | The key function. This gets called on every Name embedded --- inside a ModIface. Our job is to take a Name from some --- generalized unit ID p[A=, B=], and change --- it to the correct name for a (partially) instantiated unit --- ID, e.g. p[A=q[]:A, B=]. --- --- There are two important things to do: --- --- If a hole is substituted with a real module implementation, --- we need to look at that actual implementation to determine what --- the true identity of this name should be. We'll do this by --- loading that module's interface and looking at the mi_exports. --- --- However, there is one special exception: when we are loading --- the interface of a requirement. In this case, we may not have --- the "implementing" interface, because we are reading this --- interface precisely to "merge it in". --- --- External case: --- p[A=]:A (and thisUnitId is something else) --- We are loading this in order to determine B.hi! So --- don't load B.hi to find the exports. --- --- Local case: --- p[A=]:A (and thisUnitId is p[A=]) --- This should not happen, because the rename is not necessary --- in this case, but if it does we shouldn't load A.hi! --- --- Compare me with 'tcIfaceGlobal'! - --- In effect, this function needs compute the name substitution on the --- fly. What it has is the name that we would like to substitute. --- If the name is not a hole name {M.x} (e.g. isHoleModule) then --- no renaming can take place (although the inner hole structure must --- be updated to account for the hole module renaming.) -rnIfaceGlobal :: Name -> ShIfM Name -rnIfaceGlobal n = do - hsc_env <- getTopEnv - let dflags = hsc_dflags hsc_env - iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv - mb_nsubst <- fmap sh_if_shape getGblEnv - hmap <- getHoleSubst - let m = nameModule n - m' = renameHoleModule dflags hmap m - case () of - -- Did we encounter {A.T} while renaming p[A=]:A? If so, - -- do NOT assume B.hi is available. - -- In this case, rename {A.T} to {B.T} but don't look up exports. - _ | m' == iface_semantic_mod - , isHoleModule m' - -- NB: this could be Nothing for computeExports, we have - -- nothing to say. - -> do n' <- setNameModule (Just m') n - case mb_nsubst of - Nothing -> return n' - Just nsubst -> - case maybeSubstNameShape nsubst n' of - -- TODO: would love to have context - -- TODO: This will give an unpleasant message if n' - -- is a constructor; then we'll suggest adding T - -- but it won't work. - Nothing -> failWithRn $ vcat [ - text "The identifier" <+> ppr (occName n') <+> - text "does not exist in the local signature.", - parens (text "Try adding it to the export list of the hsig file.") - ] - Just n'' -> return n'' - -- Fastpath: we are renaming p[H=]:A.T, in which case the - -- export list is irrelevant. - | not (isHoleModule m) - -> setNameModule (Just m') n - -- The substitution was from to p[]:A. - -- But this does not mean {A.T} goes to p[]:A.T: - -- p[]:A may reexport T from somewhere else. Do the name - -- substitution. Furthermore, we need - -- to make sure we pick the accurate name NOW, - -- or we might accidentally reject a merge. - | otherwise - -> do -- Make sure we look up the local interface if substitution - -- went from to . - let m'' = if isHoleModule m' - -- Pull out the local guy!! - then mkModule (thisPackage dflags) (moduleName m') - else m' - iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env - $ loadSysInterface (text "rnIfaceGlobal") m'' - let nsubst = mkNameShape (moduleName m) (mi_exports iface) - case maybeSubstNameShape nsubst n of - Nothing -> failWithRn $ vcat [ - text "The identifier" <+> ppr (occName n) <+> - -- NB: report m' because it's more user-friendly - text "does not exist in the signature for" <+> ppr m', - parens (text "Try adding it to the export list in that hsig file.") - ] - Just n' -> return n' - --- | Rename an implicit name, e.g., a DFun or coercion axiom. --- Here is where we ensure that DFuns have the correct module as described in --- Note [rnIfaceNeverExported]. -rnIfaceNeverExported :: Name -> ShIfM Name -rnIfaceNeverExported name = do - hmap <- getHoleSubst - dflags <- getDynFlags - iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv - let m = renameHoleModule dflags hmap $ nameModule name - -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined. - MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) - setNameModule (Just m) name - --- Note [rnIfaceNeverExported] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- For the high-level overview, see --- Note [Handling never-exported TyThings under Backpack] --- --- When we see a reference to an entity that was defined in a signature, --- 'rnIfaceGlobal' relies on the identifier in question being part of the --- exports of the implementing 'ModIface', so that we can use the exports to --- decide how to rename the identifier. Unfortunately, references to 'DFun's --- and 'CoAxiom's will run into trouble under this strategy, because they are --- never exported. --- --- Let us consider first what should happen in the absence of promotion. In --- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside --- the signature *that is defining it* (as there are no Core terms in --- typechecked-only interface files, there's no way for a reference to occur --- besides from the defining 'ClsInst' or closed type family). Thus, --- it doesn't really matter what names we give the DFun/CoAxiom, as long --- as it's consistent between the declaration site and the use site. --- --- We have to make sure that these bogus names don't get propagated, --- but it is fine: see Note [Signature merging DFuns] for the fixups --- to the names we do before writing out the merged interface. --- (It's even easier for instantiation, since the DFuns all get --- dropped entirely; the instances are reexported implicitly.) --- --- Unfortunately, this strategy is not enough in the presence of promotion --- (see bug #13149), where modules which import the signature may make --- reference to their coercions. It's not altogether clear how to --- fix this case, but it is definitely a bug! - --- PILES AND PILES OF BOILERPLATE - --- | Rename an 'IfaceClsInst', with special handling for an associated --- dictionary function. -rnIfaceClsInst :: Rename IfaceClsInst -rnIfaceClsInst cls_inst = do - n <- rnIfaceGlobal (ifInstCls cls_inst) - tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst) - - dfun <- rnIfaceNeverExported (ifDFun cls_inst) - return cls_inst { ifInstCls = n - , ifInstTys = tys - , ifDFun = dfun - } - -rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon) -rnMaybeIfaceTyCon Nothing = return Nothing -rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc - -rnIfaceFamInst :: Rename IfaceFamInst -rnIfaceFamInst d = do - fam <- rnIfaceGlobal (ifFamInstFam d) - tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d) - axiom <- rnIfaceGlobal (ifFamInstAxiom d) - return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } - -rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl) -rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl - -rnIfaceDecl :: Rename IfaceDecl -rnIfaceDecl d@IfaceId{} = do - name <- case ifIdDetails d of - IfDFunId -> rnIfaceNeverExported (ifName d) - _ | isDefaultMethodOcc (occName (ifName d)) - -> rnIfaceNeverExported (ifName d) - -- Typeable bindings. See Note [Grand plan for Typeable]. - _ | isTypeableBindOcc (occName (ifName d)) - -> rnIfaceNeverExported (ifName d) - | otherwise -> rnIfaceGlobal (ifName d) - ty <- rnIfaceType (ifType d) - details <- rnIfaceIdDetails (ifIdDetails d) - info <- rnIfaceIdInfo (ifIdInfo d) - return d { ifName = name - , ifType = ty - , ifIdDetails = details - , ifIdInfo = info - } -rnIfaceDecl d@IfaceData{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - ctxt <- mapM rnIfaceType (ifCtxt d) - cons <- rnIfaceConDecls (ifCons d) - res_kind <- rnIfaceType (ifResKind d) - parent <- rnIfaceTyConParent (ifParent d) - return d { ifName = name - , ifBinders = binders - , ifCtxt = ctxt - , ifCons = cons - , ifResKind = res_kind - , ifParent = parent - } -rnIfaceDecl d@IfaceSynonym{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - syn_kind <- rnIfaceType (ifResKind d) - syn_rhs <- rnIfaceType (ifSynRhs d) - return d { ifName = name - , ifBinders = binders - , ifResKind = syn_kind - , ifSynRhs = syn_rhs - } -rnIfaceDecl d@IfaceFamily{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - fam_kind <- rnIfaceType (ifResKind d) - fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) - return d { ifName = name - , ifBinders = binders - , ifResKind = fam_kind - , ifFamFlav = fam_flav - } -rnIfaceDecl d@IfaceClass{} = do - name <- rnIfaceGlobal (ifName d) - binders <- mapM rnIfaceTyConBinder (ifBinders d) - body <- rnIfaceClassBody (ifBody d) - return d { ifName = name - , ifBinders = binders - , ifBody = body - } -rnIfaceDecl d@IfaceAxiom{} = do - name <- rnIfaceNeverExported (ifName d) - tycon <- rnIfaceTyCon (ifTyCon d) - ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) - return d { ifName = name - , ifTyCon = tycon - , ifAxBranches = ax_branches - } -rnIfaceDecl d@IfacePatSyn{} = do - name <- rnIfaceGlobal (ifName d) - let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b - pat_matcher <- rnPat (ifPatMatcher d) - pat_builder <- T.traverse rnPat (ifPatBuilder d) - pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d) - pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d) - pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d) - pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d) - pat_args <- mapM rnIfaceType (ifPatArgs d) - pat_ty <- rnIfaceType (ifPatTy d) - return d { ifName = name - , ifPatMatcher = pat_matcher - , ifPatBuilder = pat_builder - , ifPatUnivBndrs = pat_univ_bndrs - , ifPatExBndrs = pat_ex_bndrs - , ifPatProvCtxt = pat_prov_ctxt - , ifPatReqCtxt = pat_req_ctxt - , ifPatArgs = pat_args - , ifPatTy = pat_ty - } - -rnIfaceClassBody :: Rename IfaceClassBody -rnIfaceClassBody IfAbstractClass = return IfAbstractClass -rnIfaceClassBody d@IfConcreteClass{} = do - ctxt <- mapM rnIfaceType (ifClassCtxt d) - ats <- mapM rnIfaceAT (ifATs d) - sigs <- mapM rnIfaceClassOp (ifSigs d) - return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs } - -rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav -rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) - = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n - <*> mapM rnIfaceAxBranch axs) -rnIfaceFamTyConFlav flav = pure flav - -rnIfaceAT :: Rename IfaceAT -rnIfaceAT (IfaceAT decl mb_ty) - = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty - -rnIfaceTyConParent :: Rename IfaceTyConParent -rnIfaceTyConParent (IfDataInstance n tc args) - = IfDataInstance <$> rnIfaceGlobal n - <*> rnIfaceTyCon tc - <*> rnIfaceAppArgs args -rnIfaceTyConParent IfNoParent = pure IfNoParent - -rnIfaceConDecls :: Rename IfaceConDecls -rnIfaceConDecls (IfDataTyCon ds) - = IfDataTyCon <$> mapM rnIfaceConDecl ds -rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d -rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon - -rnIfaceConDecl :: Rename IfaceConDecl -rnIfaceConDecl d = do - con_name <- rnIfaceGlobal (ifConName d) - con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d) - con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d) - let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t - con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) - con_ctxt <- mapM rnIfaceType (ifConCtxt d) - con_arg_tys <- mapM rnIfaceType (ifConArgTys d) - con_fields <- mapM rnFieldLabel (ifConFields d) - let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co - rnIfaceBang bang = pure bang - con_stricts <- mapM rnIfaceBang (ifConStricts d) - return d { ifConName = con_name - , ifConExTCvs = con_ex_tvs - , ifConUserTvBinders = con_user_tvbs - , ifConEqSpec = con_eq_spec - , ifConCtxt = con_ctxt - , ifConArgTys = con_arg_tys - , ifConFields = con_fields - , ifConStricts = con_stricts - } - -rnIfaceClassOp :: Rename IfaceClassOp -rnIfaceClassOp (IfaceClassOp n ty dm) = - IfaceClassOp <$> rnIfaceGlobal n - <*> rnIfaceType ty - <*> rnMaybeDefMethSpec dm - -rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType)) -rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty -rnMaybeDefMethSpec mb = return mb - -rnIfaceAxBranch :: Rename IfaceAxBranch -rnIfaceAxBranch d = do - ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d) - lhs <- rnIfaceAppArgs (ifaxbLHS d) - rhs <- rnIfaceType (ifaxbRHS d) - return d { ifaxbTyVars = ty_vars - , ifaxbLHS = lhs - , ifaxbRHS = rhs } - -rnIfaceIdInfo :: Rename IfaceIdInfo -rnIfaceIdInfo NoInfo = pure NoInfo -rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is - -rnIfaceInfoItem :: Rename IfaceInfoItem -rnIfaceInfoItem (HsUnfold lb if_unf) - = HsUnfold lb <$> rnIfaceUnfolding if_unf -rnIfaceInfoItem i - = pure i - -rnIfaceUnfolding :: Rename IfaceUnfolding -rnIfaceUnfolding (IfCoreUnfold stable if_expr) - = IfCoreUnfold stable <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfCompulsory if_expr) - = IfCompulsory <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr) - = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfDFunUnfold bs ops) - = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops - -rnIfaceExpr :: Rename IfaceExpr -rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name) -rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl -rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty -rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co -rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args -rnIfaceExpr (IfaceLam lam_bndr expr) - = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr -rnIfaceExpr (IfaceApp fun arg) - = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg -rnIfaceExpr (IfaceCase scrut case_bndr alts) - = IfaceCase <$> rnIfaceExpr scrut - <*> pure case_bndr - <*> mapM rnIfaceAlt alts -rnIfaceExpr (IfaceECase scrut ty) - = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty -rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs) - <*> rnIfaceExpr body -rnIfaceExpr (IfaceLet (IfaceRec pairs) body) - = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) -> - (,) <$> rnIfaceLetBndr bndr - <*> rnIfaceExpr rhs) pairs) - <*> rnIfaceExpr body -rnIfaceExpr (IfaceCast expr co) - = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co -rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) -rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty -rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr - -rnIfaceBndrs :: Rename [IfaceBndr] -rnIfaceBndrs = mapM rnIfaceBndr - -rnIfaceBndr :: Rename IfaceBndr -rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty) -rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr - -rnIfaceTvBndr :: Rename IfaceTvBndr -rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind - -rnIfaceTyConBinder :: Rename IfaceTyConBinder -rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis - -rnIfaceAlt :: Rename IfaceAlt -rnIfaceAlt (conalt, names, rhs) - = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs - -rnIfaceConAlt :: Rename IfaceConAlt -rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ -rnIfaceConAlt alt = pure alt - -rnIfaceLetBndr :: Rename IfaceLetBndr -rnIfaceLetBndr (IfLetBndr fs ty info jpi) - = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi - -rnIfaceLamBndr :: Rename IfaceLamBndr -rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot - -rnIfaceMCo :: Rename IfaceMCoercion -rnIfaceMCo IfaceMRefl = pure IfaceMRefl -rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co - -rnIfaceCo :: Rename IfaceCoercion -rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty -rnIfaceCo (IfaceGReflCo role ty mco) - = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco -rnIfaceCo (IfaceFunCo role co1 co2) - = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceTyConAppCo role tc cos) - = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos -rnIfaceCo (IfaceAppCo co1 co2) - = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceForAllCo bndr co1 co2) - = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c) -rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl -rnIfaceCo (IfaceHoleCo lcl) = IfaceHoleCo <$> pure lcl -rnIfaceCo (IfaceAxiomInstCo n i cs) - = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs -rnIfaceCo (IfaceUnivCo s r t1 t2) - = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 -rnIfaceCo (IfaceSymCo c) - = IfaceSymCo <$> rnIfaceCo c -rnIfaceCo (IfaceTransCo c1 c2) - = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 -rnIfaceCo (IfaceInstCo c1 c2) - = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 -rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c -rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c -rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c -rnIfaceCo (IfaceAxiomRuleCo ax cos) - = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos -rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c - -rnIfaceTyCon :: Rename IfaceTyCon -rnIfaceTyCon (IfaceTyCon n info) - = IfaceTyCon <$> rnIfaceGlobal n <*> pure info - -rnIfaceExprs :: Rename [IfaceExpr] -rnIfaceExprs = mapM rnIfaceExpr - -rnIfaceIdDetails :: Rename IfaceIdDetails -rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b -rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b -rnIfaceIdDetails details = pure details - -rnIfaceType :: Rename IfaceType -rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) -rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) -rnIfaceType (IfaceAppTy t1 t2) - = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 -rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) -rnIfaceType (IfaceFunTy af t1 t2) - = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2 -rnIfaceType (IfaceTupleTy s i tks) - = IfaceTupleTy s i <$> rnIfaceAppArgs tks -rnIfaceType (IfaceTyConApp tc tks) - = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks -rnIfaceType (IfaceForAllTy tv t) - = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t -rnIfaceType (IfaceCoercionTy co) - = IfaceCoercionTy <$> rnIfaceCo co -rnIfaceType (IfaceCastTy ty co) - = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co - -rnIfaceForAllBndr :: Rename IfaceForAllBndr -rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis - -rnIfaceAppArgs :: Rename IfaceAppArgs -rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a - <*> rnIfaceAppArgs ts -rnIfaceAppArgs IA_Nil = pure IA_Nil diff --git a/basicTypes/Avail.hs b/basicTypes/Avail.hs deleted file mode 100644 --- a/basicTypes/Avail.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} --- --- (c) The University of Glasgow --- - -#include "HsVersions.h" - -module Avail ( - Avails, - AvailInfo(..), - avail, - availsToNameSet, - availsToNameSetWithSelectors, - availsToNameEnv, - availName, availNames, availNonFldNames, - availNamesWithSelectors, - availFlds, - availsNamesWithOccs, - availNamesWithOccs, - stableAvailCmp, - plusAvail, - trimAvail, - filterAvail, - filterAvails, - nubAvails - - - ) where - -import GhcPrelude - -import Name -import NameEnv -import NameSet - -import FieldLabel -import Binary -import ListSetOps -import Outputable -import Util - -import Data.Data ( Data ) -import Data.List ( find ) -import Data.Function - --- ----------------------------------------------------------------------------- --- The AvailInfo type - --- | Records what things are \"available\", i.e. in scope -data AvailInfo - - -- | An ordinary identifier in scope - = Avail Name - - -- | A type or class in scope - -- - -- The __AvailTC Invariant__: If the type or class is itself to be in scope, - -- it must be /first/ in this list. Thus, typically: - -- - -- > AvailTC Eq [Eq, ==, \/=] [] - | AvailTC - Name -- ^ The name of the type or class - [Name] -- ^ The available pieces of type or class, - -- excluding field selectors. - [FieldLabel] -- ^ The record fields of the type - -- (see Note [Representing fields in AvailInfo]). - - deriving ( Eq -- ^ Used when deciding if the interface has changed - , Data ) - --- | A collection of 'AvailInfo' - several things that are \"available\" -type Avails = [AvailInfo] - -{- -Note [Representing fields in AvailInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -XDuplicateRecordFields is disabled (the normal case), a -datatype like - - data T = MkT { foo :: Int } - -gives rise to the AvailInfo - - AvailTC T [T, MkT] [FieldLabel "foo" False foo] - -whereas if -XDuplicateRecordFields is enabled it gives - - AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] - -since the label does not match the selector name. - -The labels in a field list are not necessarily unique: -data families allow the same parent (the family tycon) to have -multiple distinct fields with the same label. For example, - - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool} - -gives rise to - - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" True $sel:foo:MkFBool ] - -Moreover, note that the flIsOverloaded flag need not be the same for -all the elements of the list. In the example above, this occurs if -the two data instances are defined in different modules, one with -`-XDuplicateRecordFields` enabled and one with it disabled. Thus it -is possible to have - - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" False foo ] - -If the two data instances are defined in different modules, both -without `-XDuplicateRecordFields`, it will be impossible to export -them from the same module (even with `-XDuplicateRecordfields` -enabled), because they would be represented identically. The -workaround here is to enable `-XDuplicateRecordFields` on the defining -modules. --} - --- | Compare lexicographically -stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering -stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 -stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = - (n `stableNameCmp` m) `thenCmp` - (cmpList stableNameCmp ns ms) `thenCmp` - (cmpList (stableNameCmp `on` flSelector) nfs mfs) -stableAvailCmp (AvailTC {}) (Avail {}) = GT - -avail :: Name -> AvailInfo -avail n = Avail n - --- ----------------------------------------------------------------------------- --- Operations on AvailInfo - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNames avail) - -availsToNameSetWithSelectors :: [AvailInfo] -> NameSet -availsToNameSetWithSelectors avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNamesWithSelectors avail) - -availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo -availsToNameEnv avails = foldr add emptyNameEnv avails - where add avail env = extendNameEnvList env - (zip (availNames avail) (repeat avail)) - --- | Just the main name made available, i.e. not the available pieces --- of type or class brought into scope by the 'GenAvailInfo' -availName :: AvailInfo -> Name -availName (Avail n) = n -availName (AvailTC n _ _) = n - --- | All names made available by the availability information (excluding overloaded selectors) -availNames :: AvailInfo -> [Name] -availNames (Avail n) = [n] -availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] - --- | All names made available by the availability information (including overloaded selectors) -availNamesWithSelectors :: AvailInfo -> [Name] -availNamesWithSelectors (Avail n) = [n] -availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs - --- | Names for non-fields made available by the availability information -availNonFldNames :: AvailInfo -> [Name] -availNonFldNames (Avail n) = [n] -availNonFldNames (AvailTC _ ns _) = ns - --- | Fields made available by the availability information -availFlds :: AvailInfo -> [FieldLabel] -availFlds (AvailTC _ _ fs) = fs -availFlds _ = [] - -availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] -availsNamesWithOccs = concatMap availNamesWithOccs - --- | 'Name's made available by the availability information, paired with --- the 'OccName' used to refer to each one. --- --- When @DuplicateRecordFields@ is in use, the 'Name' may be the --- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the --- 'OccName' will be the label of the field (e.g. @foo@). --- --- See Note [Representing fields in AvailInfo]. -availNamesWithOccs :: AvailInfo -> [(Name, OccName)] -availNamesWithOccs (Avail n) = [(n, nameOccName n)] -availNamesWithOccs (AvailTC _ ns fs) - = [ (n, nameOccName n) | n <- ns ] ++ - [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] - --- ----------------------------------------------------------------------------- --- Utility - -plusAvail :: AvailInfo -> AvailInfo -> AvailInfo -plusAvail a1 a2 - | debugIsOn && availName a1 /= availName a2 - = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) -plusAvail a1@(Avail {}) (Avail {}) = a1 -plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 -plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 -plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) - = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first - (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) - (fs1 `unionLists` fs2) - (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (fs1 `unionLists` fs2) - (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (fs1 `unionLists` fs2) - (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) - (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) - = AvailTC n1 ss1 (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) - = AvailTC n1 ss2 (fs1 `unionLists` fs2) -plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) - --- | trims an 'AvailInfo' to keep only a single name -trimAvail :: AvailInfo -> Name -> AvailInfo -trimAvail (Avail n) _ = Avail n -trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of - Just x -> AvailTC n [] [x] - Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] - --- | filters 'AvailInfo's by the given predicate -filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] -filterAvails keep avails = foldr (filterAvail keep) [] avails - --- | filters an 'AvailInfo' by the given predicate -filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] -filterAvail keep ie rest = - case ie of - Avail n | keep n -> ie : rest - | otherwise -> rest - AvailTC tc ns fs -> - let ns' = filter keep ns - fs' = filter (keep . flSelector) fs in - if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest - - --- | Combines 'AvailInfo's from the same family --- 'avails' may have several items with the same availName --- E.g import Ix( Ix(..), index ) --- will give Ix(Ix,index,range) and Ix(index) --- We want to combine these; addAvail does that -nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) - where - add env avail = extendNameEnv_C plusAvail env (availName avail) avail - --- ----------------------------------------------------------------------------- --- Printing - -instance Outputable AvailInfo where - ppr = pprAvail - -pprAvail :: AvailInfo -> SDoc -pprAvail (Avail n) - = ppr n -pprAvail (AvailTC n ns fs) - = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi - , fsep (punctuate comma (map (ppr . flLabel) fs))]) - -instance Binary AvailInfo where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac ad) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - ad <- get bh - return (AvailTC ab ac ad) diff --git a/basicTypes/BasicTypes.hs b/basicTypes/BasicTypes.hs deleted file mode 100644 --- a/basicTypes/BasicTypes.hs +++ /dev/null @@ -1,1678 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 - -\section[BasicTypes]{Miscellanous types} - -This module defines a miscellaneously collection of very simple -types that - -\begin{itemize} -\item have no other obvious home -\item don't depend on any other complicated types -\item are used in more than one "part" of the compiler -\end{itemize} --} - -{-# LANGUAGE DeriveDataTypeable #-} - -module BasicTypes( - Version, bumpVersion, initialVersion, - - LeftOrRight(..), - pickLR, - - ConTag, ConTagZ, fIRST_TAG, - - Arity, RepArity, JoinArity, - - Alignment, mkAlignment, alignmentOf, alignmentBytes, - - PromotionFlag(..), isPromoted, - FunctionOrData(..), - - WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), - - Fixity(..), FixityDirection(..), - defaultFixity, maxPrecedence, minPrecedence, - negateFixity, funTyFixity, - compareFixity, - LexicalFixity(..), - - RecFlag(..), isRec, isNonRec, boolToRecFlag, - Origin(..), isGenerated, - - RuleName, pprRuleName, - - TopLevelFlag(..), isTopLevel, isNotTopLevel, - - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, - - Boxity(..), isBoxed, - - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, - - TupleSort(..), tupleSortBoxity, boxityTupleSort, - tupleParens, - - sumParens, pprAlternative, - - -- ** The OneShotInfo type - OneShotInfo(..), - noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, - bestOneShot, worstOneShot, - - OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, - strongLoopBreaker, weakLoopBreaker, - - InsideLam, insideLam, notInsideLam, - BranchCount, oneBranch, - InterestingCxt, - TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, - isAlwaysTailCalled, - - EP(..), - - DefMethSpec(..), - SwapFlag(..), flipSwap, unSwap, isSwapped, - - CompilerPhase(..), PhaseNum, - - Activation(..), isActive, isActiveIn, competesWith, - isNeverActive, isAlwaysActive, isEarlyActive, - activeAfterInitial, activeDuringFinal, - - RuleMatchInfo(..), isConLike, isFunLike, - InlineSpec(..), noUserInlineSpec, - InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, - neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, - isInlinePragma, isInlinablePragma, isAnyInlinePragma, - inlinePragmaSpec, inlinePragmaSat, - inlinePragmaActivation, inlinePragmaRuleMatchInfo, - setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - pprInline, pprInlineDebug, - - SuccessFlag(..), succeeded, failed, successIf, - - IntegralLit(..), FractionalLit(..), - negateIntegralLit, negateFractionalLit, - mkIntegralLit, mkFractionalLit, - integralFractionalLit, - - SourceText(..), pprWithSourceText, - - IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, - - SpliceExplicitFlag(..), - - TypeOrKind(..), isTypeLevel, isKindLevel - ) where - -import GhcPrelude - -import FastString -import Outputable -import SrcLoc ( Located,unLoc ) -import Data.Data hiding (Fixity, Prefix, Infix) -import Data.Function (on) -import Data.Bits - -{- -************************************************************************ -* * - Binary choice -* * -************************************************************************ --} - -data LeftOrRight = CLeft | CRight - deriving( Eq, Data ) - -pickLR :: LeftOrRight -> (a,a) -> a -pickLR CLeft (l,_) = l -pickLR CRight (_,r) = r - -instance Outputable LeftOrRight where - ppr CLeft = text "Left" - ppr CRight = text "Right" - -{- -************************************************************************ -* * -\subsection[Arity]{Arity} -* * -************************************************************************ --} - --- | The number of value arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has arity 0 --- \x -> fib x has arity 1 --- See also Note [Definition of arity] in CoreArity -type Arity = Int - --- | Representation Arity --- --- The number of represented arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has representation arity 0 --- \x -> fib x has representation arity 1 --- \(# x, y #) -> fib (x + y) has representation arity 2 -type RepArity = Int - --- | The number of arguments that a join point takes. Unlike the arity of a --- function, this is a purely syntactic property and is fixed when the join --- point is created (or converted from a value). Both type and value arguments --- are counted. -type JoinArity = Int - -{- -************************************************************************ -* * - Constructor tags -* * -************************************************************************ --} - --- | Constructor Tag --- --- Type of the tags associated with each constructor possibility or superclass --- selector -type ConTag = Int - --- | A *zero-indexed* constructor tag -type ConTagZ = Int - -fIRST_TAG :: ConTag --- ^ Tags are allocated from here for real constructors --- or for superclass selectors -fIRST_TAG = 1 - -{- -************************************************************************ -* * -\subsection[Alignment]{Alignment} -* * -************************************************************************ --} - --- | A power-of-two alignment -newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) - --- Builds an alignment, throws on non power of 2 input. This is not --- ideal, but convenient for internal use and better then silently --- passing incorrect data. -mkAlignment :: Int -> Alignment -mkAlignment n - | n == 1 = Alignment 1 - | n == 2 = Alignment 2 - | n == 4 = Alignment 4 - | n == 8 = Alignment 8 - | n == 16 = Alignment 16 - | n == 32 = Alignment 32 - | n == 64 = Alignment 64 - | n == 128 = Alignment 128 - | n == 256 = Alignment 256 - | n == 512 = Alignment 512 - | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" - --- Calculates an alignment of a number. x is aligned at N bytes means --- the remainder from x / N is zero. Currently, interested in N <= 8, --- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX --- context. -alignmentOf :: Int -> Alignment -alignmentOf x = case x .&. 7 of - 0 -> Alignment 8 - 4 -> Alignment 4 - 2 -> Alignment 2 - _ -> Alignment 1 - -instance Outputable Alignment where - ppr (Alignment m) = ppr m -{- -************************************************************************ -* * - One-shot information -* * -************************************************************************ --} - --- | If the 'Id' is a lambda-bound variable then it may have lambda-bound --- variable info. Sometimes we know whether the lambda binding this variable --- is a \"one-shot\" lambda; that is, whether it is applied at most once. --- --- This information may be useful in optimisation, as computations may --- safely be floated inside such a lambda without risk of duplicating --- work. -data OneShotInfo - = NoOneShotInfo -- ^ No information - | OneShotLam -- ^ The lambda is applied at most once. - deriving (Eq) - --- | It is always safe to assume that an 'Id' has no lambda-bound variable information -noOneShotInfo :: OneShotInfo -noOneShotInfo = NoOneShotInfo - -isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool -isOneShotInfo OneShotLam = True -isOneShotInfo _ = False - -hasNoOneShotInfo NoOneShotInfo = True -hasNoOneShotInfo _ = False - -worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo -worstOneShot NoOneShotInfo _ = NoOneShotInfo -worstOneShot OneShotLam os = os - -bestOneShot NoOneShotInfo os = os -bestOneShot OneShotLam _ = OneShotLam - -pprOneShotInfo :: OneShotInfo -> SDoc -pprOneShotInfo NoOneShotInfo = empty -pprOneShotInfo OneShotLam = text "OneShot" - -instance Outputable OneShotInfo where - ppr = pprOneShotInfo - -{- -************************************************************************ -* * - Swap flag -* * -************************************************************************ --} - -data SwapFlag - = NotSwapped -- Args are: actual, expected - | IsSwapped -- Args are: expected, actual - -instance Outputable SwapFlag where - ppr IsSwapped = text "Is-swapped" - ppr NotSwapped = text "Not-swapped" - -flipSwap :: SwapFlag -> SwapFlag -flipSwap IsSwapped = NotSwapped -flipSwap NotSwapped = IsSwapped - -isSwapped :: SwapFlag -> Bool -isSwapped IsSwapped = True -isSwapped NotSwapped = False - -unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b -unSwap NotSwapped f a b = f a b -unSwap IsSwapped f a b = f b a - - -{- ********************************************************************* -* * - Promotion flag -* * -********************************************************************* -} - --- | Is a TyCon a promoted data constructor or just a normal type constructor? -data PromotionFlag - = NotPromoted - | IsPromoted - deriving ( Eq, Data ) - -isPromoted :: PromotionFlag -> Bool -isPromoted IsPromoted = True -isPromoted NotPromoted = False - - -{- -************************************************************************ -* * -\subsection[FunctionOrData]{FunctionOrData} -* * -************************************************************************ --} - -data FunctionOrData = IsFunction | IsData - deriving (Eq, Ord, Data) - -instance Outputable FunctionOrData where - ppr IsFunction = text "(function)" - ppr IsData = text "(data)" - -{- -************************************************************************ -* * -\subsection[Version]{Module and identifier version numbers} -* * -************************************************************************ --} - -type Version = Int - -bumpVersion :: Version -> Version -bumpVersion v = v+1 - -initialVersion :: Version -initialVersion = 1 - -{- -************************************************************************ -* * - Deprecations -* * -************************************************************************ --} - --- | A String Literal in the source, including its original raw format for use by --- source to source manipulation tools. -data StringLiteral = StringLiteral - { sl_st :: SourceText, -- literal raw source. - -- See not [Literal source text] - sl_fs :: FastString -- literal string value - } deriving Data - -instance Eq StringLiteral where - (StringLiteral _ a) == (StringLiteral _ b) = a == b - -instance Outputable StringLiteral where - ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) - --- | Warning Text --- --- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt (Located SourceText) - [Located StringLiteral] - | DeprecatedTxt (Located SourceText) - [Located StringLiteral] - deriving (Eq, Data) - -instance Outputable WarningTxt where - ppr (WarningTxt lsrc ws) - = case unLoc lsrc of - NoSourceText -> pp_ws ws - SourceText src -> text src <+> pp_ws ws <+> text "#-}" - - ppr (DeprecatedTxt lsrc ds) - = case unLoc lsrc of - NoSourceText -> pp_ws ds - SourceText src -> text src <+> pp_ws ds <+> text "#-}" - -pp_ws :: [Located StringLiteral] -> SDoc -pp_ws [l] = ppr $ unLoc l -pp_ws ws - = text "[" - <+> vcat (punctuate comma (map (ppr . unLoc) ws)) - <+> text "]" - - -pprWarningTxtForMsg :: WarningTxt -> SDoc -pprWarningTxtForMsg (WarningTxt _ ws) - = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) -pprWarningTxtForMsg (DeprecatedTxt _ ds) - = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) - -{- -************************************************************************ -* * - Rules -* * -************************************************************************ --} - -type RuleName = FastString - -pprRuleName :: RuleName -> SDoc -pprRuleName rn = doubleQuotes (ftext rn) - -{- -************************************************************************ -* * -\subsection[Fixity]{Fixity info} -* * -************************************************************************ --} - ------------------------- -data Fixity = Fixity SourceText Int FixityDirection - -- Note [Pragma source text] - deriving Data - -instance Outputable Fixity where - ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 - ------------------------- -data FixityDirection = InfixL | InfixR | InfixN - deriving (Eq, Data) - -instance Outputable FixityDirection where - ppr InfixL = text "infixl" - ppr InfixR = text "infixr" - ppr InfixN = text "infix" - ------------------------- -maxPrecedence, minPrecedence :: Int -maxPrecedence = 9 -minPrecedence = 0 - -defaultFixity :: Fixity -defaultFixity = Fixity NoSourceText maxPrecedence InfixL - -negateFixity, funTyFixity :: Fixity --- Wired-in fixities -negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 - -{- -Consider - -\begin{verbatim} - a `op1` b `op2` c -\end{verbatim} -@(compareFixity op1 op2)@ tells which way to arrange application, or -whether there's an error. --} - -compareFixity :: Fixity -> Fixity - -> (Bool, -- Error please - Bool) -- Associate to the right: a op1 (b op2 c) -compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) - = case prec1 `compare` prec2 of - GT -> left - LT -> right - EQ -> case (dir1, dir2) of - (InfixR, InfixR) -> right - (InfixL, InfixL) -> left - _ -> error_please - where - right = (False, True) - left = (False, False) - error_please = (True, False) - --- |Captures the fixity of declarations as they are parsed. This is not --- necessarily the same as the fixity declaration, as the normal fixity may be --- overridden using parens or backticks. -data LexicalFixity = Prefix | Infix deriving (Data,Eq) - -instance Outputable LexicalFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" - -{- -************************************************************************ -* * -\subsection[Top-level/local]{Top-level/not-top level flag} -* * -************************************************************************ --} - -data TopLevelFlag - = TopLevel - | NotTopLevel - -isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool - -isNotTopLevel NotTopLevel = True -isNotTopLevel TopLevel = False - -isTopLevel TopLevel = True -isTopLevel NotTopLevel = False - -instance Outputable TopLevelFlag where - ppr TopLevel = text "" - ppr NotTopLevel = text "" - -{- -************************************************************************ -* * - Boxity flag -* * -************************************************************************ --} - -data Boxity - = Boxed - | Unboxed - deriving( Eq, Data ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False - -instance Outputable Boxity where - ppr Boxed = text "Boxed" - ppr Unboxed = text "Unboxed" - -{- -************************************************************************ -* * - Recursive/Non-Recursive flag -* * -************************************************************************ --} - --- | Recursivity Flag -data RecFlag = Recursive - | NonRecursive - deriving( Eq, Data ) - -isRec :: RecFlag -> Bool -isRec Recursive = True -isRec NonRecursive = False - -isNonRec :: RecFlag -> Bool -isNonRec Recursive = False -isNonRec NonRecursive = True - -boolToRecFlag :: Bool -> RecFlag -boolToRecFlag True = Recursive -boolToRecFlag False = NonRecursive - -instance Outputable RecFlag where - ppr Recursive = text "Recursive" - ppr NonRecursive = text "NonRecursive" - -{- -************************************************************************ -* * - Code origin -* * -************************************************************************ --} - -data Origin = FromSource - | Generated - deriving( Eq, Data ) - -isGenerated :: Origin -> Bool -isGenerated Generated = True -isGenerated FromSource = False - -instance Outputable Origin where - ppr FromSource = text "FromSource" - ppr Generated = text "Generated" - -{- -************************************************************************ -* * - Instance overlap flag -* * -************************************************************************ --} - --- | The semantics allowed for overlapping instances for a particular --- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a --- explanation of the `isSafeOverlap` field. --- --- - 'ApiAnnotation.AnnKeywordId' : --- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or --- @'\{-\# OVERLAPPING'@ or --- @'\{-\# OVERLAPS'@ or --- @'\{-\# INCOHERENT'@, --- 'ApiAnnotation.AnnClose' @`\#-\}`@, - --- For details on above see note [Api annotations] in ApiAnnotation -data OverlapFlag = OverlapFlag - { overlapMode :: OverlapMode - , isSafeOverlap :: Bool - } deriving (Eq, Data) - -setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag -setOverlapModeMaybe f Nothing = f -setOverlapModeMaybe f (Just m) = f { overlapMode = m } - -hasIncoherentFlag :: OverlapMode -> Bool -hasIncoherentFlag mode = - case mode of - Incoherent _ -> True - _ -> False - -hasOverlappableFlag :: OverlapMode -> Bool -hasOverlappableFlag mode = - case mode of - Overlappable _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -hasOverlappingFlag :: OverlapMode -> Bool -hasOverlappingFlag mode = - case mode of - Overlapping _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -data OverlapMode -- See Note [Rules for instance lookup] in InstEnv - = NoOverlap SourceText - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - - | Overlapping SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - - | Overlaps SourceText - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent SourceText - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also note [Incoherent instances] in InstEnv - - deriving (Eq, Data) - - -instance Outputable OverlapFlag where - ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) - -instance Outputable OverlapMode where - ppr (NoOverlap _) = empty - ppr (Overlappable _) = text "[overlappable]" - ppr (Overlapping _) = text "[overlapping]" - ppr (Overlaps _) = text "[overlap ok]" - ppr (Incoherent _) = text "[incoherent]" - -pprSafeOverlap :: Bool -> SDoc -pprSafeOverlap True = text "[safe]" -pprSafeOverlap False = empty - -{- -************************************************************************ -* * - Precedence -* * -************************************************************************ --} - --- | A general-purpose pretty-printing precedence type. -newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) --- See Note [Precedence in types] - -topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec -topPrec = PprPrec 0 -- No parens -sigPrec = PprPrec 1 -- Explicit type signatures -funPrec = PprPrec 2 -- Function args; no parens for constructor apps - -- See [Type operator precedence] for why both - -- funPrec and opPrec exist. -opPrec = PprPrec 2 -- Infix operator -appPrec = PprPrec 3 -- Constructor args; no parens for atomic - -maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - -{- Note [Precedence in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Many pretty-printing functions have type - ppr_ty :: PprPrec -> Type -> SDoc - -The PprPrec gives the binding strength of the context. For example, in - T ty1 ty2 -we will pretty-print 'ty1' and 'ty2' with the call - (ppr_ty appPrec ty) -to indicate that the context is that of an argument of a TyConApp. - -We use this consistently for Type and HsType. - -Note [Type operator precedence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't keep the fixity of type operators in the operator. So the -pretty printer follows the following precedence order: - - TyConPrec Type constructor application - TyOpPrec/FunPrec Operator application and function arrow - -We have funPrec and opPrec to represent the precedence of function -arrow and type operators respectively, but currently we implement -funPrec == opPrec, so that we don't distinguish the two. Reason: -it's hard to parse a type like - a ~ b => c * d -> e - f - -By treating opPrec = funPrec we end up with more parens - (a ~ b) => (c * d) -> (e - f) - -But the two are different constructors of PprPrec so we could make -(->) bind more or less tightly if we wanted. --} - -{- -************************************************************************ -* * - Tuples -* * -************************************************************************ --} - -data TupleSort - = BoxedTuple - | UnboxedTuple - | ConstraintTuple - deriving( Eq, Data ) - -instance Outputable TupleSort where - ppr ts = text $ - case ts of - BoxedTuple -> "BoxedTuple" - UnboxedTuple -> "UnboxedTuple" - ConstraintTuple -> "ConstraintTuple" - -tupleSortBoxity :: TupleSort -> Boxity -tupleSortBoxity BoxedTuple = Boxed -tupleSortBoxity UnboxedTuple = Unboxed -tupleSortBoxity ConstraintTuple = Boxed - -boxityTupleSort :: Boxity -> TupleSort -boxityTupleSort Boxed = BoxedTuple -boxityTupleSort Unboxed = UnboxedTuple - -tupleParens :: TupleSort -> SDoc -> SDoc -tupleParens BoxedTuple p = parens p -tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") -tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) - (parens p) - -{- -************************************************************************ -* * - Sums -* * -************************************************************************ --} - -sumParens :: SDoc -> SDoc -sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") - --- | Pretty print an alternative in an unboxed sum e.g. "| a | |". -pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use - -> a -- ^ The things to be pretty printed - -> ConTag -- ^ Alternative (one-based) - -> Arity -- ^ Arity - -> SDoc -- ^ 'SDoc' where the alternative havs been pretty - -- printed and finally packed into a paragraph. -pprAlternative pp x alt arity = - fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) - -{- -************************************************************************ -* * -\subsection[Generic]{Generic flag} -* * -************************************************************************ - -This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedExpr's or Id's) -If we have a such a pair (EP from to), the idea is that 'from' and 'to' -represents functions of type - - from :: T -> Tring - to :: Tring -> T - -And we should have - - to (from x) = x - -T and Tring are arbitrary, but typically T is the 'main' type while -Tring is the 'representation' type. (This just helps us remember -whether to use 'from' or 'to'. --} - --- | Embedding Projection pair -data EP a = EP { fromEP :: a, -- :: T -> Tring - toEP :: a } -- :: Tring -> T - -{- -Embedding-projection pairs are used in several places: - -First of all, each type constructor has an EP associated with it, the -code in EP converts (datatype T) from T to Tring and back again. - -Secondly, when we are filling in Generic methods (in the typechecker, -tcMethodBinds), we are constructing bimaps by induction on the structure -of the type of the method signature. - - -************************************************************************ -* * -\subsection{Occurrence information} -* * -************************************************************************ - -This data type is used exclusively by the simplifier, but it appears in a -SubstResult, which is currently defined in VarEnv, which is pretty near -the base of the module hierarchy. So it seemed simpler to put the -defn of OccInfo here, safely at the bottom --} - --- | identifier Occurrence Information -data OccInfo - = ManyOccs { occ_tail :: !TailCallInfo } - -- ^ There are many occurrences, or unknown occurrences - - | IAmDead -- ^ Marks unused variables. Sometimes useful for - -- lambda and case-bound variables. - - | OneOcc { occ_in_lam :: !InsideLam - , occ_n_br :: {-# UNPACK #-} !BranchCount - , occ_int_cxt :: !InterestingCxt - , occ_tail :: !TailCallInfo } - -- ^ Occurs exactly once (per branch), not inside a rule - - -- | This identifier breaks a loop of mutually recursive functions. The field - -- marks whether it is only a loop breaker due to a reference in a rule - | IAmALoopBreaker { occ_rules_only :: !RulesOnly - , occ_tail :: !TailCallInfo } - -- Note [LoopBreaker OccInfo] - - deriving (Eq) - -type RulesOnly = Bool - -type BranchCount = Int - -- For OneOcc, the BranchCount says how many syntactic occurrences there are - -- At the moment we really only check for 1 or >1, but in principle - -- we could pay attention to how *many* occurences there are - -- (notably in postInlineUnconditionally). - -- But meanwhile, Ints are very efficiently represented. - -oneBranch :: BranchCount -oneBranch = 1 - -{- -Note [LoopBreaker OccInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - IAmALoopBreaker True <=> A "weak" or rules-only loop breaker - Do not preInlineUnconditionally - - IAmALoopBreaker False <=> A "strong" loop breaker - Do not inline at all - -See OccurAnal Note [Weak loop breakers] --} - -noOccInfo :: OccInfo -noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } - -isManyOccs :: OccInfo -> Bool -isManyOccs ManyOccs{} = True -isManyOccs _ = False - -seqOccInfo :: OccInfo -> () -seqOccInfo occ = occ `seq` () - ------------------ --- | Interesting Context -type InterestingCxt = Bool -- True <=> Function: is applied - -- Data value: scrutinised by a case with - -- at least one non-DEFAULT branch - ------------------ --- | Inside Lambda -type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda - -- Substituting a redex for this occurrence is - -- dangerous because it might duplicate work. -insideLam, notInsideLam :: InsideLam -insideLam = True -notInsideLam = False - ------------------ -data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] - | NoTailCallInfo - deriving (Eq) - -tailCallInfo :: OccInfo -> TailCallInfo -tailCallInfo IAmDead = NoTailCallInfo -tailCallInfo other = occ_tail other - -zapOccTailCallInfo :: OccInfo -> OccInfo -zapOccTailCallInfo IAmDead = IAmDead -zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } - -isAlwaysTailCalled :: OccInfo -> Bool -isAlwaysTailCalled occ - = case tailCallInfo occ of AlwaysTailCalled{} -> True - NoTailCallInfo -> False - -instance Outputable TailCallInfo where - ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] - ppr _ = empty - ------------------ -strongLoopBreaker, weakLoopBreaker :: OccInfo -strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo -weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo - -isWeakLoopBreaker :: OccInfo -> Bool -isWeakLoopBreaker (IAmALoopBreaker{}) = True -isWeakLoopBreaker _ = False - -isStrongLoopBreaker :: OccInfo -> Bool -isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True - -- Loop-breaker that breaks a non-rule cycle -isStrongLoopBreaker _ = False - -isDeadOcc :: OccInfo -> Bool -isDeadOcc IAmDead = True -isDeadOcc _ = False - -isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc {}) = True -isOneOcc _ = False - -zapFragileOcc :: OccInfo -> OccInfo --- Keep only the most robust data: deadness, loop-breaker-hood -zapFragileOcc (OneOcc {}) = noOccInfo -zapFragileOcc occ = zapOccTailCallInfo occ - -instance Outputable OccInfo where - -- only used for debugging; never parsed. KSW 1999-07 - ppr (ManyOccs tails) = pprShortTailCallInfo tails - ppr IAmDead = text "Dead" - ppr (IAmALoopBreaker rule_only tails) - = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails - where - pp_ro | rule_only = char '!' - | otherwise = empty - ppr (OneOcc inside_lam one_branch int_cxt tail_info) - = text "Once" <> pp_lam <> ppr one_branch <> pp_args <> pp_tail - where - pp_lam | inside_lam = char 'L' - | otherwise = empty - pp_args | int_cxt = char '!' - | otherwise = empty - pp_tail = pprShortTailCallInfo tail_info - -pprShortTailCallInfo :: TailCallInfo -> SDoc -pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) -pprShortTailCallInfo NoTailCallInfo = empty - -{- -Note [TailCallInfo] -~~~~~~~~~~~~~~~~~~~ -The occurrence analyser determines what can be made into a join point, but it -doesn't change the binder into a JoinId because then it would be inconsistent -with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to -change the IdDetails. - -The AlwaysTailCalled marker actually means slightly more than simply that the -function is always tail-called. See Note [Invariants on join points]. - -This info is quite fragile and should not be relied upon unless the occurrence -analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of -the join-point-hood of a binder; a join id itself will not be marked -AlwaysTailCalled. - -Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that -being tail-called would mean that the variable could only appear once per branch -(thus getting a `OneOcc { }` occurrence info), but a join -point can also be invoked from other join points, not just from case branches: - - let j1 x = ... - j2 y = ... j1 z {- tail call -} ... - in case w of - A -> j1 v - B -> j2 u - C -> j2 q - -Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get -ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`. - -************************************************************************ -* * - Default method specification -* * -************************************************************************ - -The DefMethSpec enumeration just indicates what sort of default method -is used for a class. It is generated from source code, and present in -interface files; it is converted to Class.DefMethInfo before begin put in a -Class object. --} - --- | Default Method Specification -data DefMethSpec ty - = VanillaDM -- Default method given with polymorphic code - | GenericDM ty -- Default method given with code of this type - -instance Outputable (DefMethSpec ty) where - ppr VanillaDM = text "{- Has default method -}" - ppr (GenericDM {}) = text "{- Has generic default method -}" - -{- -************************************************************************ -* * -\subsection{Success flag} -* * -************************************************************************ --} - -data SuccessFlag = Succeeded | Failed - -instance Outputable SuccessFlag where - ppr Succeeded = text "Succeeded" - ppr Failed = text "Failed" - -successIf :: Bool -> SuccessFlag -successIf True = Succeeded -successIf False = Failed - -succeeded, failed :: SuccessFlag -> Bool -succeeded Succeeded = True -succeeded Failed = False - -failed Succeeded = False -failed Failed = True - -{- -************************************************************************ -* * -\subsection{Source Text} -* * -************************************************************************ -Keeping Source Text for source to source conversions - -Note [Pragma source text] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer does a case-insensitive match for pragmas, as well as -accepting both UK and US spelling variants. - -So - - {-# SPECIALISE #-} - {-# SPECIALIZE #-} - {-# Specialize #-} - -will all generate ITspec_prag token for the start of the pragma. - -In order to be able to do source to source conversions, the original -source text for the token needs to be preserved, hence the -`SourceText` field. - -So the lexer will then generate - - ITspec_prag "{ -# SPECIALISE" - ITspec_prag "{ -# SPECIALIZE" - ITspec_prag "{ -# Specialize" - -for the cases above. - [without the space between '{' and '-', otherwise this comment won't parse] - - -Note [Literal source text] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer/parser converts literals from their original source text -versions to an appropriate internal representation. This is a problem -for tools doing source to source conversions, so the original source -text is stored in literals where this can occur. - -Motivating examples for HsLit - - HsChar '\n' == '\x20` - HsCharPrim '\x41`# == `A` - HsString "\x20\x41" == " A" - HsStringPrim "\x20"# == " "# - HsInt 001 == 1 - HsIntPrim 002# == 2# - HsWordPrim 003## == 3## - HsInt64Prim 004## == 4## - HsWord64Prim 005## == 5## - HsInteger 006 == 6 - -For OverLitVal - - HsIntegral 003 == 0x003 - HsIsString "\x41nd" == "And" --} - - -- Note [Literal source text],[Pragma source text] -data SourceText = SourceText String - | NoSourceText -- ^ For when code is generated, e.g. TH, - -- deriving. The pretty printer will then make - -- its own representation of the item. - deriving (Data, Show, Eq ) - -instance Outputable SourceText where - ppr (SourceText s) = text "SourceText" <+> text s - ppr NoSourceText = text "NoSourceText" - --- | Special combinator for showing string literals. -pprWithSourceText :: SourceText -> SDoc -> SDoc -pprWithSourceText NoSourceText d = d -pprWithSourceText (SourceText src) _ = text src - -{- -************************************************************************ -* * -\subsection{Activation} -* * -************************************************************************ - -When a rule or inlining is active --} - --- | Phase Number -type PhaseNum = Int -- Compilation phase - -- Phases decrease towards zero - -- Zero is the last phase - -data CompilerPhase - = Phase PhaseNum - | InitialPhase -- The first phase -- number = infinity! - -instance Outputable CompilerPhase where - ppr (Phase n) = int n - ppr InitialPhase = text "InitialPhase" - -activeAfterInitial :: Activation --- Active in the first phase after the initial phase --- Currently we have just phases [2,1,0] -activeAfterInitial = ActiveAfter NoSourceText 2 - -activeDuringFinal :: Activation --- Active in the final simplification phase (which is repeated) -activeDuringFinal = ActiveAfter NoSourceText 0 - --- See note [Pragma source text] -data Activation = NeverActive - | AlwaysActive - | ActiveBefore SourceText PhaseNum - -- Active only *strictly before* this phase - | ActiveAfter SourceText PhaseNum - -- Active in this phase and later - deriving( Eq, Data ) - -- Eq used in comparing rules in GHC.Hs.Decls - --- | Rule Match Information -data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] - | FunLike - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -data InlinePragma -- Note [InlinePragma] - = InlinePragma - { inl_src :: SourceText -- Note [Pragma source text] - , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] - - , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n - -- explicit (non-type, non-dictionary) args - -- That is, inl_sat describes the number of *source-code* - -- arguments the thing must be applied to. We add on the - -- number of implicit, dictionary arguments when making - -- the Unfolding, and don't look at inl_sat further - - , inl_act :: Activation -- Says during which phases inlining is allowed - -- See Note [inl_inline and inl_act] - - , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? - } deriving( Eq, Data ) - --- | Inline Specification -data InlineSpec -- What the user's INLINE pragma looked like - = Inline -- User wrote INLINE - | Inlinable -- User wrote INLINABLE - | NoInline -- User wrote NOINLINE - | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE - -- e.g. in `defaultInlinePragma` or when created by CSE - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -{- Note [InlinePragma] -~~~~~~~~~~~~~~~~~~~~~~ -This data type mirrors what you can write in an INLINE or NOINLINE pragma in -the source program. - -If you write nothing at all, you get defaultInlinePragma: - inl_inline = NoUserInline - inl_act = AlwaysActive - inl_rule = FunLike - -It's not possible to get that combination by *writing* something, so -if an Id has defaultInlinePragma it means the user didn't specify anything. - -If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. - -If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair - -Note [inl_inline and inl_act] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* inl_inline says what the user wrote: did she say INLINE, NOINLINE, - INLINABLE, or nothing at all - -* inl_act says in what phases the unfolding is active or inactive - E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 - If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 - If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 - So note that inl_act does not say what pragma you wrote: it just - expresses its consequences - -* inl_act just says when the unfolding is active; it doesn't say what - to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, - but in addition f will get a "stable unfolding" with UnfoldingGuidance - that tells the inliner to be pretty eager about it. - -Note [CONLIKE pragma] -~~~~~~~~~~~~~~~~~~~~~ -The ConLike constructor of a RuleMatchInfo is aimed at the following. -Consider first - {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} - g b bs = let x = b:bs in ..x...x...(r x)... -Now, the rule applies to the (r x) term, because GHC "looks through" -the definition of 'x' to see that it is (b:bs). - -Now consider - {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} - g v = let x = f v in ..x...x...(r x)... -Normally the (r x) would *not* match the rule, because GHC would be -scared about duplicating the redex (f v), so it does not "look -through" the bindings. - -However the CONLIKE modifier says to treat 'f' like a constructor in -this situation, and "look through" the unfolding for x. So (r x) -fires, yielding (f (v+1)). - -This is all controlled with a user-visible pragma: - {-# NOINLINE CONLIKE [1] f #-} - -The main effects of CONLIKE are: - - - The occurrence analyser (OccAnal) and simplifier (Simplify) treat - CONLIKE thing like constructors, by ANF-ing them - - - New function CoreUtils.exprIsExpandable is like exprIsCheap, but - additionally spots applications of CONLIKE functions - - - A CoreUnfolding has a field that caches exprIsExpandable - - - The rule matcher consults this field. See - Note [Expanding variables] in Rules.hs. --} - -isConLike :: RuleMatchInfo -> Bool -isConLike ConLike = True -isConLike _ = False - -isFunLike :: RuleMatchInfo -> Bool -isFunLike FunLike = True -isFunLike _ = False - -noUserInlineSpec :: InlineSpec -> Bool -noUserInlineSpec NoUserInline = True -noUserInlineSpec _ = False - -defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma - :: InlinePragma -defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_act = AlwaysActive - , inl_rule = FunLike - , inl_inline = NoUserInline - , inl_sat = Nothing } - -alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } -neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } - -inlinePragmaSpec :: InlinePragma -> InlineSpec -inlinePragmaSpec = inl_inline - --- A DFun has an always-active inline activation so that --- exprIsConApp_maybe can "see" its unfolding --- (However, its actual Unfolding is a DFunUnfolding, which is --- never inlined other than via exprIsConApp_maybe.) -dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive - , inl_rule = ConLike } - -isDefaultInlinePragma :: InlinePragma -> Bool -isDefaultInlinePragma (InlinePragma { inl_act = activation - , inl_rule = match_info - , inl_inline = inline }) - = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info - -isInlinePragma :: InlinePragma -> Bool -isInlinePragma prag = case inl_inline prag of - Inline -> True - _ -> False - -isInlinablePragma :: InlinePragma -> Bool -isInlinablePragma prag = case inl_inline prag of - Inlinable -> True - _ -> False - -isAnyInlinePragma :: InlinePragma -> Bool --- INLINE or INLINABLE -isAnyInlinePragma prag = case inl_inline prag of - Inline -> True - Inlinable -> True - _ -> False - -inlinePragmaSat :: InlinePragma -> Maybe Arity -inlinePragmaSat = inl_sat - -inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation - -inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info - -setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation prag activation = prag { inl_act = activation } - -setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } - -instance Outputable Activation where - ppr AlwaysActive = empty - ppr NeverActive = brackets (text "~") - ppr (ActiveBefore _ n) = brackets (char '~' <> int n) - ppr (ActiveAfter _ n) = brackets (int n) - -instance Outputable RuleMatchInfo where - ppr ConLike = text "CONLIKE" - ppr FunLike = text "FUNLIKE" - -instance Outputable InlineSpec where - ppr Inline = text "INLINE" - ppr NoInline = text "NOINLINE" - ppr Inlinable = text "INLINABLE" - ppr NoUserInline = text "NOUSERINLINE" -- what is better? - -instance Outputable InlinePragma where - ppr = pprInline - -pprInline :: InlinePragma -> SDoc -pprInline = pprInline' True - -pprInlineDebug :: InlinePragma -> SDoc -pprInlineDebug = pprInline' False - -pprInline' :: Bool -- True <=> do not display the inl_inline field - -> InlinePragma - -> SDoc -pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation - , inl_rule = info, inl_sat = mb_arity }) - = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info - where - pp_inl x = if emptyInline then empty else ppr x - - pp_act Inline AlwaysActive = empty - pp_act NoInline NeverActive = empty - pp_act _ act = ppr act - - pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) - | otherwise = empty - pp_info | isFunLike info = empty - | otherwise = ppr info - -isActive :: CompilerPhase -> Activation -> Bool -isActive InitialPhase AlwaysActive = True -isActive InitialPhase (ActiveBefore {}) = True -isActive InitialPhase _ = False -isActive (Phase p) act = isActiveIn p act - -isActiveIn :: PhaseNum -> Activation -> Bool -isActiveIn _ NeverActive = False -isActiveIn _ AlwaysActive = True -isActiveIn p (ActiveAfter _ n) = p <= n -isActiveIn p (ActiveBefore _ n) = p > n - -competesWith :: Activation -> Activation -> Bool --- See Note [Activation competition] -competesWith NeverActive _ = False -competesWith _ NeverActive = False -competesWith AlwaysActive _ = True - -competesWith (ActiveBefore {}) AlwaysActive = True -competesWith (ActiveBefore {}) (ActiveBefore {}) = True -competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b - -competesWith (ActiveAfter {}) AlwaysActive = False -competesWith (ActiveAfter {}) (ActiveBefore {}) = False -competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b - -{- Note [Competing activations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes a RULE and an inlining may compete, or two RULES. -See Note [Rules and inlining/other rules] in Desugar. - -We say that act1 "competes with" act2 iff - act1 is active in the phase when act2 *becomes* active -NB: remember that phases count *down*: 2, 1, 0! - -It's too conservative to ensure that the two are never simultaneously -active. For example, a rule might be always active, and an inlining -might switch on in phase 2. We could switch off the rule, but it does -no harm. --} - -isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool -isNeverActive NeverActive = True -isNeverActive _ = False - -isAlwaysActive AlwaysActive = True -isAlwaysActive _ = False - -isEarlyActive AlwaysActive = True -isEarlyActive (ActiveBefore {}) = True -isEarlyActive _ = False - --- | Integral Literal --- --- Used (instead of Integer) to represent negative zegative zero which is --- required for NegativeLiterals extension to correctly parse `-0::Double` --- as negative zero. See also #13211. -data IntegralLit - = IL { il_text :: SourceText - , il_neg :: Bool -- See Note [Negative zero] - , il_value :: Integer - } - deriving (Data, Show) - -mkIntegralLit :: Integral a => a -> IntegralLit -mkIntegralLit i = IL { il_text = SourceText (show i_integer) - , il_neg = i < 0 - , il_value = i_integer } - where - i_integer :: Integer - i_integer = toInteger i - -negateIntegralLit :: IntegralLit -> IntegralLit -negateIntegralLit (IL text neg value) - = case text of - SourceText ('-':src) -> IL (SourceText src) False (negate value) - SourceText src -> IL (SourceText ('-':src)) True (negate value) - NoSourceText -> IL NoSourceText (not neg) (negate value) - --- | Fractional Literal --- --- Used (instead of Rational) to represent exactly the floating point literal that we --- encountered in the user's source program. This allows us to pretty-print exactly what --- the user wrote, which is important e.g. for floating point numbers that can't represented --- as Doubles (we used to via Double for pretty-printing). See also #2245. -data FractionalLit - = FL { fl_text :: SourceText -- How the value was written in the source - , fl_neg :: Bool -- See Note [Negative zero] - , fl_value :: Rational -- Numeric value of the literal - } - deriving (Data, Show) - -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on - -mkFractionalLit :: Real a => a -> FractionalLit -mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) - -- Converting to a Double here may technically lose - -- precision (see #15502). We could alternatively - -- convert to a Rational for the most accuracy, but - -- it would cause Floats and Doubles to be displayed - -- strangely, so we opt not to do this. (In contrast - -- to mkIntegralLit, where we always convert to an - -- Integer for the highest accuracy.) - , fl_neg = r < 0 - , fl_value = toRational r } - -negateFractionalLit :: FractionalLit -> FractionalLit -negateFractionalLit (FL text neg value) - = case text of - SourceText ('-':src) -> FL (SourceText src) False value - SourceText src -> FL (SourceText ('-':src)) True value - NoSourceText -> FL NoSourceText (not neg) (negate value) - -integralFractionalLit :: Bool -> Integer -> FractionalLit -integralFractionalLit neg i = FL { fl_text = SourceText (show i), - fl_neg = neg, - fl_value = fromInteger i } - --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module MatchLit) - -instance Eq IntegralLit where - (==) = (==) `on` il_value - -instance Ord IntegralLit where - compare = compare `on` il_value - -instance Outputable IntegralLit where - ppr (IL (SourceText src) _ _) = text src - ppr (IL NoSourceText _ value) = text (show value) - -instance Eq FractionalLit where - (==) = (==) `on` fl_value - -instance Ord FractionalLit where - compare = compare `on` fl_value - -instance Outputable FractionalLit where - ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) - -{- -************************************************************************ -* * - IntWithInf -* * -************************************************************************ - -Represents an integer or positive infinity - --} - --- | An integer or infinity -data IntWithInf = Int {-# UNPACK #-} !Int - | Infinity - deriving Eq - --- | A representation of infinity -infinity :: IntWithInf -infinity = Infinity - -instance Ord IntWithInf where - compare Infinity Infinity = EQ - compare (Int _) Infinity = LT - compare Infinity (Int _) = GT - compare (Int a) (Int b) = a `compare` b - -instance Outputable IntWithInf where - ppr Infinity = char '∞' - ppr (Int n) = int n - -instance Num IntWithInf where - (+) = plusWithInf - (*) = mulWithInf - - abs Infinity = Infinity - abs (Int n) = Int (abs n) - - signum Infinity = Int 1 - signum (Int n) = Int (signum n) - - fromInteger = Int . fromInteger - - (-) = panic "subtracting IntWithInfs" - -intGtLimit :: Int -> IntWithInf -> Bool -intGtLimit _ Infinity = False -intGtLimit n (Int m) = n > m - --- | Add two 'IntWithInf's -plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf -plusWithInf Infinity _ = Infinity -plusWithInf _ Infinity = Infinity -plusWithInf (Int a) (Int b) = Int (a + b) - --- | Multiply two 'IntWithInf's -mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf -mulWithInf Infinity _ = Infinity -mulWithInf _ Infinity = Infinity -mulWithInf (Int a) (Int b) = Int (a * b) - --- | Turn a positive number into an 'IntWithInf', where 0 represents infinity -treatZeroAsInf :: Int -> IntWithInf -treatZeroAsInf 0 = Infinity -treatZeroAsInf n = Int n - --- | Inject any integer into an 'IntWithInf' -mkIntWithInf :: Int -> IntWithInf -mkIntWithInf = Int - -data SpliceExplicitFlag - = ExplicitSplice | -- ^ <=> $(f x y) - ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression - deriving Data - -{- ********************************************************************* -* * - Types vs Kinds -* * -********************************************************************* -} - --- | Flag to see whether we're type-checking terms or kind-checking types -data TypeOrKind = TypeLevel | KindLevel - deriving Eq - -instance Outputable TypeOrKind where - ppr TypeLevel = text "TypeLevel" - ppr KindLevel = text "KindLevel" - -isTypeLevel :: TypeOrKind -> Bool -isTypeLevel TypeLevel = True -isTypeLevel KindLevel = False - -isKindLevel :: TypeOrKind -> Bool -isKindLevel TypeLevel = False -isKindLevel KindLevel = True diff --git a/basicTypes/ConLike.hs b/basicTypes/ConLike.hs deleted file mode 100644 --- a/basicTypes/ConLike.hs +++ /dev/null @@ -1,196 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[ConLike]{@ConLike@: Constructor-like things} --} - -{-# LANGUAGE CPP #-} - -module ConLike ( - ConLike(..) - , conLikeArity - , conLikeFieldLabels - , conLikeInstOrigArgTys - , conLikeExTyCoVars - , conLikeName - , conLikeStupidTheta - , conLikeWrapId_maybe - , conLikeImplBangs - , conLikeFullSig - , conLikeResTy - , conLikeFieldType - , conLikesWithFields - , conLikeIsInfix - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DataCon -import PatSyn -import Outputable -import Unique -import Util -import Name -import BasicTypes -import TyCoRep (Type, ThetaType) -import Var -import Type (mkTyConApp) - -import qualified Data.Data as Data - -{- -************************************************************************ -* * -\subsection{Constructor-like things} -* * -************************************************************************ --} - --- | A constructor-like thing -data ConLike = RealDataCon DataCon - | PatSynCon PatSyn - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq ConLike where - (==) = eqConLike - -eqConLike :: ConLike -> ConLike -> Bool -eqConLike x y = getUnique x == getUnique y - --- There used to be an Ord ConLike instance here that used Unique for ordering. --- It was intentionally removed to prevent determinism problems. --- See Note [Unique Determinism] in Unique. - -instance Uniquable ConLike where - getUnique (RealDataCon dc) = getUnique dc - getUnique (PatSynCon ps) = getUnique ps - -instance NamedThing ConLike where - getName (RealDataCon dc) = getName dc - getName (PatSynCon ps) = getName ps - -instance Outputable ConLike where - ppr (RealDataCon dc) = ppr dc - ppr (PatSynCon ps) = ppr ps - -instance OutputableBndr ConLike where - pprInfixOcc (RealDataCon dc) = pprInfixOcc dc - pprInfixOcc (PatSynCon ps) = pprInfixOcc ps - pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc - pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps - -instance Data.Data ConLike where - -- don't traverse? - toConstr _ = abstractConstr "ConLike" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ConLike" - --- | Number of arguments -conLikeArity :: ConLike -> Arity -conLikeArity (RealDataCon data_con) = dataConSourceArity data_con -conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn - --- | Names of fields used for selectors -conLikeFieldLabels :: ConLike -> [FieldLabel] -conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con -conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn - --- | Returns just the instantiated /value/ argument types of a 'ConLike', --- (excluding dictionary args) -conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] -conLikeInstOrigArgTys (RealDataCon data_con) tys = - dataConInstOrigArgTys data_con tys -conLikeInstOrigArgTys (PatSynCon pat_syn) tys = - patSynInstArgTys pat_syn tys - --- | Existentially quantified type/coercion variables -conLikeExTyCoVars :: ConLike -> [TyCoVar] -conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 -conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 - -conLikeName :: ConLike -> Name -conLikeName (RealDataCon data_con) = dataConName data_con -conLikeName (PatSynCon pat_syn) = patSynName pat_syn - --- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: --- --- > data Eq a => T a = ... --- It is empty for `PatSynCon` as they do not allow such contexts. -conLikeStupidTheta :: ConLike -> ThetaType -conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con -conLikeStupidTheta (PatSynCon {}) = [] - --- | Returns the `Id` of the wrapper. This is also known as the builder in --- some contexts. The value is Nothing only in the case of unidirectional --- pattern synonyms. -conLikeWrapId_maybe :: ConLike -> Maybe Id -conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con -conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn - --- | Returns the strictness information for each constructor -conLikeImplBangs :: ConLike -> [HsImplBang] -conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con -conLikeImplBangs (PatSynCon pat_syn) = - replicate (patSynArity pat_syn) HsLazy - --- | Returns the type of the whole pattern -conLikeResTy :: ConLike -> [Type] -> Type -conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys -conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys - --- | The \"full signature\" of the 'ConLike' returns, in order: --- --- 1) The universally quantified type variables --- --- 2) The existentially quantified type/coercion variables --- --- 3) The equality specification --- --- 4) The provided theta (the constraints provided by a match) --- --- 5) The required theta (the constraints required for a match) --- --- 6) The original argument types (i.e. before --- any change of the representation of the type) --- --- 7) The original result type -conLikeFullSig :: ConLike - -> ([TyVar], [TyCoVar], [EqSpec] - -- Why tyvars for universal but tycovars for existential? - -- See Note [Existential coercion variables] in DataCon - , ThetaType, ThetaType, [Type], Type) -conLikeFullSig (RealDataCon con) = - let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con - -- Required theta is empty as normal data cons require no additional - -- constraints for a match - in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) -conLikeFullSig (PatSynCon pat_syn) = - let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn - -- eqSpec is empty - in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) - --- | Extract the type for any given labelled field of the 'ConLike' -conLikeFieldType :: ConLike -> FieldLabelString -> Type -conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label -conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label - - --- | The ConLikes that have *all* the given fields -conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] -conLikesWithFields con_likes lbls = filter has_flds con_likes - where has_flds dc = all (has_fld dc) lbls - has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) - -conLikeIsInfix :: ConLike -> Bool -conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc -conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/basicTypes/ConLike.hs-boot b/basicTypes/ConLike.hs-boot deleted file mode 100644 --- a/basicTypes/ConLike.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module ConLike where -import {-# SOURCE #-} DataCon (DataCon) -import {-# SOURCE #-} PatSyn (PatSyn) -import Name ( Name ) - -data ConLike = RealDataCon DataCon - | PatSynCon PatSyn - -conLikeName :: ConLike -> Name diff --git a/basicTypes/DataCon.hs b/basicTypes/DataCon.hs deleted file mode 100644 --- a/basicTypes/DataCon.hs +++ /dev/null @@ -1,1516 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[DataCon]{@DataCon@: Data Constructors} --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module DataCon ( - -- * Main data types - DataCon, DataConRep(..), - SrcStrictness(..), SrcUnpackedness(..), - HsSrcBang(..), HsImplBang(..), - StrictnessMark(..), - ConTag, - - -- ** Equality specs - EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, - eqSpecPair, eqSpecPreds, - substEqSpec, filterEqSpec, - - -- ** Field labels - FieldLbl(..), FieldLabel, FieldLabelString, - - -- ** Type construction - mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG, - - -- ** Type deconstruction - dataConRepType, dataConSig, dataConInstSig, dataConFullSig, - dataConName, dataConIdentity, dataConTag, dataConTagZ, - dataConTyCon, dataConOrigTyCon, - dataConUserType, - dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, - dataConUserTyVars, dataConUserTyVarBinders, - dataConEqSpec, dataConTheta, - dataConStupidTheta, - dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, - dataConInstOrigArgTys, dataConRepArgTys, - dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, - dataConSrcBangs, - dataConSourceArity, dataConRepArity, - dataConIsInfix, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, - dataConImplicitTyThings, - dataConRepStrictness, dataConImplBangs, dataConBoxer, - - splitDataProductType_maybe, - - -- ** Predicates on DataCons - isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, - isUnboxedSumCon, - isVanillaDataCon, classDataCon, dataConCannotMatch, - dataConUserTyVarsArePermuted, - isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, - specialPromotedDc, - - -- ** Promotion related functions - promoteDataCon - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} MkId( DataConBoxer ) -import Type -import ForeignCall ( CType ) -import Coercion -import Unify -import TyCon -import FieldLabel -import Class -import Name -import PrelNames -import Predicate -import Var -import VarSet( emptyVarSet ) -import Outputable -import Util -import BasicTypes -import FastString -import Module -import Binary -import UniqSet -import Unique( mkAlphaTyVarUnique ) - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Builder as BSB -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Data as Data -import Data.Char -import Data.List( find ) - -{- -Data constructor representation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following Haskell data type declaration - - data T = T !Int ![Int] - -Using the strictness annotations, GHC will represent this as - - data T = T Int# [Int] - -That is, the Int has been unboxed. Furthermore, the Haskell source construction - - T e1 e2 - -is translated to - - case e1 of { I# x -> - case e2 of { r -> - T x r }} - -That is, the first argument is unboxed, and the second is evaluated. Finally, -pattern matching is translated too: - - case e of { T a b -> ... } - -becomes - - case e of { T a' b -> let a = I# a' in ... } - -To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. - - -Note [Data Constructor Naming] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each data constructor C has two, and possibly up to four, Names associated with it: - - OccName Name space Name of Notes - --------------------------------------------------------------------------- - The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) - The "worker data con" C VarName Id The worker - The "wrapper data con" $WC VarName Id The wrapper - The "newtype coercion" :CoT TcClsName TyCon - -EVERY data constructor (incl for newtypes) has the former two (the -data con itself, and its worker. But only some data constructors have a -wrapper (see Note [The need for a wrapper]). - -Each of these three has a distinct Unique. The "data con itself" name -appears in the output of the renamer, and names the Haskell-source -data constructor. The type checker translates it into either the wrapper Id -(if it exists) or worker Id (otherwise). - -The data con has one or two Ids associated with it: - -The "worker Id", is the actual data constructor. -* Every data constructor (newtype or data type) has a worker - -* The worker is very like a primop, in that it has no binding. - -* For a *data* type, the worker *is* the data constructor; - it has no unfolding - -* For a *newtype*, the worker has a compulsory unfolding which - does a cast, e.g. - newtype T = MkT Int - The worker for MkT has unfolding - \\(x:Int). x `cast` sym CoT - Here CoT is the type constructor, witnessing the FC axiom - axiom CoT : T = Int - -The "wrapper Id", \$WC, goes as follows - -* Its type is exactly what it looks like in the source program. - -* It is an ordinary function, and it gets a top-level binding - like any other function. - -* The wrapper Id isn't generated for a data type if there is - nothing for the wrapper to do. That is, if its defn would be - \$wC = C - -Note [Data constructor workers and wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Algebraic data types - - Always have a worker, with no unfolding - - May or may not have a wrapper; see Note [The need for a wrapper] - -* Newtypes - - Always have a worker, which has a compulsory unfolding (just a cast) - - May or may not have a wrapper; see Note [The need for a wrapper] - -* INVARIANT: the dictionary constructor for a class - never has a wrapper. - -* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments - -* The wrapper (if it exists) takes dcOrigArgTys as its arguments - The worker takes dataConRepArgTys as its arguments - If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys - -* The 'NoDataConRep' case of DataConRep is important. Not only is it - efficient, but it also ensures that the wrapper is replaced by the - worker (because it *is* the worker) even when there are no - args. E.g. in - f (:) x - the (:) *is* the worker. This is really important in rule matching, - (We could match on the wrappers, but that makes it less likely that - rules will match when we bring bits of unfoldings together.) - -Note [The need for a wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why might the wrapper have anything to do? The full story is -in wrapper_reqd in MkId.mkDataConRep. - -* Unboxing strict fields (with -funbox-strict-fields) - data T = MkT !(Int,Int) - \$wMkT :: (Int,Int) -> T - \$wMkT (x,y) = MkT x y - Notice that the worker has two fields where the wapper has - just one. That is, the worker has type - MkT :: Int -> Int -> T - -* Equality constraints for GADTs - data T a where { MkT :: a -> T [a] } - - The worker gets a type with explicit equality - constraints, thus: - MkT :: forall a b. (a=[b]) => b -> T a - - The wrapper has the programmer-specified type: - \$wMkT :: a -> T [a] - \$wMkT a x = MkT [a] a [a] x - The third argument is a coercion - [a] :: [a]~[a] - -* Data family instances may do a cast on the result - -* Type variables may be permuted; see MkId - Note [Data con wrappers and GADT syntax] - - -Note [The stupid context] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Data types can have a context: - - data (Eq a, Ord b) => T a b = T1 a b | T2 a - -and that makes the constructors have a context too -(notice that T2's context is "thinned"): - - T1 :: (Eq a, Ord b) => a -> b -> T a b - T2 :: (Eq a) => a -> T a b - -Furthermore, this context pops up when pattern matching -(though GHC hasn't implemented this, but it is in H98, and -I've fixed GHC so that it now does): - - f (T2 x) = x -gets inferred type - f :: Eq a => T a b -> a - -I say the context is "stupid" because the dictionaries passed -are immediately discarded -- they do nothing and have no benefit. -It's a flaw in the language. - - Up to now [March 2002] I have put this stupid context into the - type of the "wrapper" constructors functions, T1 and T2, but - that turned out to be jolly inconvenient for generics, and - record update, and other functions that build values of type T - (because they don't have suitable dictionaries available). - - So now I've taken the stupid context out. I simply deal with - it separately in the type checker on occurrences of a - constructor, either in an expression or in a pattern. - - [May 2003: actually I think this decision could easily be - reversed now, and probably should be. Generics could be - disabled for types with a stupid context; record updates now - (H98) needs the context too; etc. It's an unforced change, so - I'm leaving it for now --- but it does seem odd that the - wrapper doesn't include the stupid context.] - -[July 04] With the advent of generalised data types, it's less obvious -what the "stupid context" is. Consider - C :: forall a. Ord a => a -> a -> T (Foo a) -Does the C constructor in Core contain the Ord dictionary? Yes, it must: - - f :: T b -> Ordering - f = /\b. \x:T b. - case x of - C a (d:Ord a) (p:a) (q:a) -> compare d p q - -Note that (Foo a) might not be an instance of Ord. - -************************************************************************ -* * -\subsection{Data constructors} -* * -************************************************************************ --} - --- | A data constructor --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' - --- For details on above see note [Api annotations] in ApiAnnotation -data DataCon - = MkData { - dcName :: Name, -- This is the name of the *source data con* - -- (see "Note [Data Constructor Naming]" above) - dcUnique :: Unique, -- Cached from Name - dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's - - -- Running example: - -- - -- *** As declared by the user - -- data T a b c where - -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c - - -- *** As represented internally - -- data T a b c where - -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) - -- => x -> y -> T a b c - -- - -- The next six fields express the type of the constructor, in pieces - -- e.g. - -- - -- dcUnivTyVars = [a,b,c] - -- dcExTyCoVars = [x,y] - -- dcUserTyVarBinders = [c,y,x,b] - -- dcEqSpec = [a~(x,y)] - -- dcOtherTheta = [x~y, Ord x] - -- dcOrigArgTys = [x,y] - -- dcRepTyCon = T - - -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE - -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, - -- vanilla datacons guaranteed to have the same type variables as their - -- parent TyCon, but that seems ugly.) They can be different in the case - -- where a GADT constructor uses different names for the universal - -- tyvars than does the tycon. For example: - -- - -- data H a where - -- MkH :: b -> H b - -- - -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH - -- will be [b]. - - dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor - -- Its type is of form - -- forall a1..an . t1 -> ... tm -> T a1..an - -- No existentials, no coercions, nothing. - -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] - -- NB 1: newtypes always have a vanilla data con - -- NB 2: a vanilla constructor can still be declared in GADT-style - -- syntax, provided its type looks like the above. - -- The declaration format is held in the TyCon (algTcGadtSyntax) - - -- Universally-quantified type vars [a,b,c] - -- INVARIANT: length matches arity of the dcRepTyCon - -- INVARIANT: result type of data con worker is exactly (T a b c) - -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with - -- the tyConTyVars of the parent TyCon - dcUnivTyVars :: [TyVar], - - -- Existentially-quantified type and coercion vars [x,y] - -- For an example involving coercion variables, - -- Why tycovars? See Note [Existential coercion variables] - dcExTyCoVars :: [TyCoVar], - - -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames - -- Reason: less confusing, and easier to generate IfaceSyn - - -- The type/coercion vars in the order the user wrote them [c,y,x,b] - -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set - -- of tyvars (*not* covars) of dcExTyCoVars unioned with the - -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec - -- See Note [DataCon user type variable binders] - dcUserTyVarBinders :: [TyVarBinder], - - dcEqSpec :: [EqSpec], -- Equalities derived from the result type, - -- _as written by the programmer_. - -- Only non-dependent GADT equalities (dependent - -- GADT equalities are in the covars of - -- dcExTyCoVars). - - -- This field allows us to move conveniently between the two ways - -- of representing a GADT constructor's type: - -- MkT :: forall a b. (a ~ [b]) => b -> T a - -- MkT :: forall b. b -> T [b] - -- Each equality is of the form (a ~ ty), where 'a' is one of - -- the universally quantified type variables - - -- The next two fields give the type context of the data constructor - -- (aside from the GADT constraints, - -- which are given by the dcExpSpec) - -- In GADT form, this is *exactly* what the programmer writes, even if - -- the context constrains only universally quantified variables - -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b - dcOtherTheta :: ThetaType, -- The other constraints in the data con's type - -- other than those in the dcEqSpec - - dcStupidTheta :: ThetaType, -- The context of the data type declaration - -- data Eq a => T a = ... - -- or, rather, a "thinned" version thereof - -- "Thinned", because the Report says - -- to eliminate any constraints that don't mention - -- tyvars free in the arg types for this constructor - -- - -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars - -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon - -- - -- "Stupid", because the dictionaries aren't used for anything. - -- Indeed, [as of March 02] they are no longer in the type of - -- the wrapper Id, because that makes it harder to use the wrap-id - -- to rebuild values after record selection or in generics. - - dcOrigArgTys :: [Type], -- Original argument types - -- (before unboxing and flattening of strict fields) - dcOrigResTy :: Type, -- Original result type, as seen by the user - -- NB: for a data instance, the original user result type may - -- differ from the DataCon's representation TyCon. Example - -- data instance T [a] where MkT :: a -> T [a] - -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 - - -- Now the strictness annotations and field labels of the constructor - dcSrcBangs :: [HsSrcBang], - -- See Note [Bangs on data constructor arguments] - -- - -- The [HsSrcBang] as written by the programmer. - -- - -- Matches 1-1 with dcOrigArgTys - -- Hence length = dataConSourceArity dataCon - - dcFields :: [FieldLabel], - -- Field labels for this constructor, in the - -- same order as the dcOrigArgTys; - -- length = 0 (if not a record) or dataConSourceArity. - - -- The curried worker function that corresponds to the constructor: - -- It doesn't have an unfolding; the code generator saturates these Ids - -- and allocates a real constructor when it finds one. - dcWorkId :: Id, - - -- Constructor representation - dcRep :: DataConRep, - - -- Cached; see Note [DataCon arities] - -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) - -- INVARIANT: dcSourceArity == length dcOrigArgTys - dcRepArity :: Arity, - dcSourceArity :: Arity, - - -- Result type of constructor is T t1..tn - dcRepTyCon :: TyCon, -- Result tycon, T - - dcRepType :: Type, -- Type of the constructor - -- forall a x y. (a~(x,y), x~y, Ord x) => - -- x -> y -> T a - -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) - -- Notice that the existential type parameters come *second*. - -- Reason: in a case expression we may find: - -- case (e :: T t) of - -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... - -- It's convenient to apply the rep-type of MkT to 't', to get - -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t - -- and use that to check the pattern. Mind you, this is really only - -- used in CoreLint. - - - dcInfix :: Bool, -- True <=> declared infix - -- Used for Template Haskell and 'deriving' only - -- The actual fixity is stored elsewhere - - dcPromoted :: TyCon -- The promoted TyCon - -- See Note [Promoted data constructors] in TyCon - } - - -{- Note [TyVarBinders in DataCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the TyVarBinders in a DataCon and PatSyn: - - * Each argument flag is Inferred or Specified. - None are Required. (A DataCon is a term-level function; see - Note [No Required TyCoBinder in terms] in TyCoRep.) - -Why do we need the TyVarBinders, rather than just the TyVars? So that -we can construct the right type for the DataCon with its foralls -attributed the correct visibility. That in turn governs whether you -can use visible type application at a call of the data constructor. - -See also [DataCon user type variable binders] for an extended discussion on the -order in which TyVarBinders appear in a DataCon. - -Note [Existential coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For now (Aug 2018) we can't write coercion quantifications in source Haskell, but -we can in Core. Consider having: - - data T :: forall k. k -> k -> Constraint where - MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) - => T k a b - - dcUnivTyVars = [k,a,b] - dcExTyCoVars = [k',c,co] - dcUserTyVarBinders = [k,a,k',c] - dcEqSpec = [b~(c|>co)] - dcOtherTheta = [] - dcOrigArgTys = [] - dcRepTyCon = T - - Function call 'dataConKindEqSpec' returns [k'~k] - -Note [DataCon arities] -~~~~~~~~~~~~~~~~~~~~~~ -dcSourceArity does not take constraints into account, -but dcRepArity does. For example: - MkT :: Ord a => a -> T a - dcSourceArity = 1 - dcRepArity = 2 - -Note [DataCon user type variable binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In System FC, data constructor type signatures always quantify over all of -their universal type variables, followed by their existential type variables. -Normally, this isn't a problem, as most datatypes naturally quantify their type -variables in this order anyway. For example: - - data T a b = forall c. MkT b c - -Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, -where k, a, and b are universal and c is existential. (The inferred variable k -isn't available for TypeApplications, hence why it's in braces.) This is a -perfectly reasonable order to use, as the syntax of H98-style datatypes -(+ ExistentialQuantification) suggests it. - -Things become more complicated when GADT syntax enters the picture. Consider -this example: - - data X a where - MkX :: forall b a. b -> Proxy a -> X a - -If we adopt the earlier approach of quantifying all the universal variables -followed by all the existential ones, GHC would come up with this type -signature for MkX: - - MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a - -But this is not what we want at all! After all, if a user were to use -TypeApplications on MkX, they would expect to instantiate `b` before `a`, -as that's the order in which they were written in the `forall`. (See #11721.) -Instead, we'd like GHC to come up with this type signature: - - MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a - -In fact, even if we left off the explicit forall: - - data X a where - MkX :: b -> Proxy a -> X a - -Then a user should still expect `b` to be quantified before `a`, since -according to the rules of TypeApplications, in the absence of `forall` GHC -performs a stable topological sort on the type variables in the user-written -type signature, which would place `b` before `a`. - -But as noted above, enacting this behavior is not entirely trivial, as System -FC demands the variables go in universal-then-existential order under the hood. -Our solution is thus to equip DataCon with two different sets of type -variables: - -* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential - type/coercion variables, respectively. Their order is irrelevant for the - purposes of TypeApplications, and as a consequence, they do not come equipped - with visibilities (that is, they are TyVars/TyCoVars instead of - TyCoVarBinders). -* dcUserTyVarBinders, for the type variables binders in the order in which they - originally arose in the user-written type signature. Their order *does* matter - for TypeApplications, so they are full TyVarBinders, complete with - visibilities. - -This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders -consists precisely of: - -* The set of tyvars in dcUnivTyVars whose type variables do not appear in - dcEqSpec, unioned with: -* The set of tyvars (*not* covars) in dcExTyCoVars - No covars here because because they're not user-written - -The word "set" is used above because the order in which the tyvars appear in -dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or -dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of -(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the -ordering, they in fact share the same type variables (with the same Uniques). We -sometimes refer to this as "the dcUserTyVarBinders invariant". - -dcUserTyVarBinders, as the name suggests, is the one that users will see most of -the time. It's used when computing the type signature of a data constructor (see -dataConUserType), and as a result, it's what matters from a TypeApplications -perspective. --} - --- | Data Constructor Representation --- See Note [Data constructor workers and wrappers] -data DataConRep - = -- NoDataConRep means that the data con has no wrapper - NoDataConRep - - -- DCR means that the data con has a wrapper - | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, - -- and constructs the representation - - , dcr_boxer :: DataConBoxer - - , dcr_arg_tys :: [Type] -- Final, representation argument types, - -- after unboxing and flattening, - -- and *including* all evidence args - - , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] in MkId.hs - - , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) - -- about the original arguments; 1-1 with orig_arg_tys - -- See Note [Bangs on data constructor arguments] - - } - -------------------------- - --- | Haskell Source Bang --- --- Bangs on data constructor arguments as the user wrote them in the --- source code. --- --- @(HsSrcBang _ SrcUnpack SrcLazy)@ and --- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we --- emit a warning (in checkValidDataCon) and treat it like --- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ -data HsSrcBang = - HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes - SrcUnpackedness - SrcStrictness - deriving Data.Data - --- | Haskell Implementation Bang --- --- Bangs of data constructor arguments as generated by the compiler --- after consulting HsSrcBang, flags, etc. -data HsImplBang - = HsLazy -- ^ Lazy field, or one with an unlifted type - | HsStrict -- ^ Strict but not unpacked field - | HsUnpack (Maybe Coercion) - -- ^ Strict and unpacked field - -- co :: arg-ty ~ product-ty HsBang - deriving Data.Data - --- | Source Strictness --- --- What strictness annotation the user wrote -data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - deriving (Eq, Data.Data) - --- | Source Unpackedness --- --- What unpackedness the user requested -data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - deriving (Eq, Data.Data) - - - -------------------------- --- StrictnessMark is internal only, used to indicate strictness --- of the DataCon *worker* fields -data StrictnessMark = MarkedStrict | NotMarkedStrict - --- | An 'EqSpec' is a tyvar/type pair representing an equality made in --- rejigging a GADT constructor -data EqSpec = EqSpec TyVar - Type - --- | Make a non-dependent 'EqSpec' -mkEqSpec :: TyVar -> Type -> EqSpec -mkEqSpec tv ty = EqSpec tv ty - -eqSpecTyVar :: EqSpec -> TyVar -eqSpecTyVar (EqSpec tv _) = tv - -eqSpecType :: EqSpec -> Type -eqSpecType (EqSpec _ ty) = ty - -eqSpecPair :: EqSpec -> (TyVar, Type) -eqSpecPair (EqSpec tv ty) = (tv, ty) - -eqSpecPreds :: [EqSpec] -> ThetaType -eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty - | EqSpec tv ty <- spec ] - --- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec --- is mapped in the substitution, it is mapped to a type variable, not --- a full type. -substEqSpec :: TCvSubst -> EqSpec -> EqSpec -substEqSpec subst (EqSpec tv ty) - = EqSpec tv' (substTy subst ty) - where - tv' = getTyVar "substEqSpec" (substTyVar subst tv) - --- | Filter out any 'TyVar's mentioned in an 'EqSpec'. -filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] -filterEqSpec eq_spec - = filter not_in_eq_spec - where - not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec - -instance Outputable EqSpec where - ppr (EqSpec tv ty) = ppr (tv, ty) - -{- Note [Bangs on data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT !Int {-# UNPACK #-} !Int Bool - -When compiling the module, GHC will decide how to represent -MkT, depending on the optimisation level, and settings of -flags like -funbox-small-strict-fields. - -Terminology: - * HsSrcBang: What the user wrote - Constructors: HsSrcBang - - * HsImplBang: What GHC decided - Constructors: HsLazy, HsStrict, HsUnpack - -* If T was defined in this module, MkT's dcSrcBangs field - records the [HsSrcBang] of what the user wrote; in the example - [ HsSrcBang _ NoSrcUnpack SrcStrict - , HsSrcBang _ SrcUnpack SrcStrict - , HsSrcBang _ NoSrcUnpack NoSrcStrictness] - -* However, if T was defined in an imported module, the importing module - must follow the decisions made in the original module, regardless of - the flag settings in the importing module. - Also see Note [Bangs on imported data constructors] in MkId - -* The dcr_bangs field of the dcRep field records the [HsImplBang] - If T was defined in this module, Without -O the dcr_bangs might be - [HsStrict, HsStrict, HsLazy] - With -O it might be - [HsStrict, HsUnpack _, HsLazy] - With -funbox-small-strict-fields it might be - [HsUnpack, HsUnpack _, HsLazy] - With -XStrictData it might be - [HsStrict, HsUnpack _, HsStrict] - -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -Here's an example illustrating both: - data Ord a => T a = MkT Int! a -Here - T :: Ord a => Int -> a -> T a -but the rep type is - Trep :: Int# -> a -> T a -Actually, the unboxed part isn't implemented yet! - - - -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq DataCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable DataCon where - getUnique = dcUnique - -instance NamedThing DataCon where - getName = dcName - -instance Outputable DataCon where - ppr con = ppr (dataConName con) - -instance OutputableBndr DataCon where - pprInfixOcc con = pprInfixName (dataConName con) - pprPrefixOcc con = pprPrefixName (dataConName con) - -instance Data.Data DataCon where - -- don't traverse? - toConstr _ = abstractConstr "DataCon" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "DataCon" - -instance Outputable HsSrcBang where - ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark - -instance Outputable HsImplBang where - ppr HsLazy = text "Lazy" - ppr (HsUnpack Nothing) = text "Unpacked" - ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) - ppr HsStrict = text "StrictNotUnpacked" - -instance Outputable SrcStrictness where - ppr SrcLazy = char '~' - ppr SrcStrict = char '!' - ppr NoSrcStrict = empty - -instance Outputable SrcUnpackedness where - ppr SrcUnpack = text "{-# UNPACK #-}" - ppr SrcNoUnpack = text "{-# NOUNPACK #-}" - ppr NoSrcUnpack = empty - -instance Outputable StrictnessMark where - ppr MarkedStrict = text "!" - ppr NotMarkedStrict = empty - -instance Binary SrcStrictness where - put_ bh SrcLazy = putByte bh 0 - put_ bh SrcStrict = putByte bh 1 - put_ bh NoSrcStrict = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcLazy - 1 -> return SrcStrict - _ -> return NoSrcStrict - -instance Binary SrcUnpackedness where - put_ bh SrcNoUnpack = putByte bh 0 - put_ bh SrcUnpack = putByte bh 1 - put_ bh NoSrcUnpack = putByte bh 2 - - get bh = - do h <- getByte bh - case h of - 0 -> return SrcNoUnpack - 1 -> return SrcUnpack - _ -> return NoSrcUnpack - --- | Compare strictness annotations -eqHsBang :: HsImplBang -> HsImplBang -> Bool -eqHsBang HsLazy HsLazy = True -eqHsBang HsStrict HsStrict = True -eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True -eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) - = eqType (coercionType c1) (coercionType c2) -eqHsBang _ _ = False - -isBanged :: HsImplBang -> Bool -isBanged (HsUnpack {}) = True -isBanged (HsStrict {}) = True -isBanged HsLazy = False - -isSrcStrict :: SrcStrictness -> Bool -isSrcStrict SrcStrict = True -isSrcStrict _ = False - -isSrcUnpacked :: SrcUnpackedness -> Bool -isSrcUnpacked SrcUnpack = True -isSrcUnpacked _ = False - -isMarkedStrict :: StrictnessMark -> Bool -isMarkedStrict NotMarkedStrict = False -isMarkedStrict _ = True -- All others are strict - -{- ********************************************************************* -* * -\subsection{Construction} -* * -********************************************************************* -} - --- | Build a new data constructor -mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVar] -- ^ Universals. - -> [TyCoVar] -- ^ Existentials. - -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. - -- These must be Inferred/Specified. - -- See @Note [TyVarBinders in DataCons]@ - -> [EqSpec] -- ^ GADT equalities - -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper - -> [KnotTied Type] -- ^ Original argument types - -> KnotTied Type -- ^ Original result type - -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' - -> KnotTied TyCon -- ^ Representation type constructor - -> ConTag -- ^ Constructor tag - -> ThetaType -- ^ The "stupid theta", context of the data - -- declaration e.g. @data Eq a => T a ...@ - -> Id -- ^ Worker Id - -> DataConRep -- ^ Representation - -> DataCon - -- Can get the tag from the TyCon - -mkDataCon name declared_infix prom_info - arg_stricts -- Must match orig_arg_tys 1-1 - fields - univ_tvs ex_tvs user_tvbs - eq_spec theta - orig_arg_tys orig_res_ty rep_info rep_tycon tag - stupid_theta work_id rep --- Warning: mkDataCon is not a good place to check certain invariants. --- If the programmer writes the wrong result type in the decl, thus: --- data T a where { MkT :: S } --- then it's possible that the univ_tvs may hit an assertion failure --- if you pull on univ_tvs. This case is checked by checkValidDataCon, --- so the error is detected properly... it's just that assertions here --- are a little dodgy. - - = con - where - is_vanilla = null ex_tvs && null eq_spec && null theta - - con = MkData {dcName = name, dcUnique = nameUnique name, - dcVanilla = is_vanilla, dcInfix = declared_infix, - dcUnivTyVars = univ_tvs, - dcExTyCoVars = ex_tvs, - dcUserTyVarBinders = user_tvbs, - dcEqSpec = eq_spec, - dcOtherTheta = theta, - dcStupidTheta = stupid_theta, - dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, - dcRepTyCon = rep_tycon, - dcSrcBangs = arg_stricts, - dcFields = fields, dcTag = tag, dcRepType = rep_ty, - dcWorkId = work_id, - dcRep = rep, - dcSourceArity = length orig_arg_tys, - dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, - dcPromoted = promoted } - - -- The 'arg_stricts' passed to mkDataCon are simply those for the - -- source-language arguments. We add extra ones for the - -- dictionary arguments right here. - - rep_arg_tys = dataConRepArgTys con - - rep_ty = - case rep of - -- If the DataCon has no wrapper, then the worker's type *is* the - -- user-facing type, so we can simply use dataConUserType. - NoDataConRep -> dataConUserType con - -- If the DataCon has a wrapper, then the worker's type is never seen - -- by the user. The visibilities we pick do not matter here. - DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ - mkVisFunTys rep_arg_tys $ - mkTyConApp rep_tycon (mkTyVarTys univ_tvs) - - -- See Note [Promoted data constructors] in TyCon - prom_tv_bndrs = [ mkNamedTyConBinder vis tv - | Bndr tv vis <- user_tvbs ] - - fresh_names = freshNames (map getName user_tvbs) - -- fresh_names: make sure that the "anonymous" tyvars don't - -- clash in name or unique with the universal/existential ones. - -- Tiresome! And unnecessary because these tyvars are never looked at - prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) - {- Invisible -} | (n,t) <- fresh_names `zip` theta ] - prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) - {- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ] - prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs - prom_res_kind = orig_res_ty - promoted = mkPromotedDataCon con name prom_info prom_bndrs - prom_res_kind roles rep_info - - roles = map (\tv -> if isTyVar tv then Nominal else Phantom) - (univ_tvs ++ ex_tvs) - ++ map (const Representational) (theta ++ orig_arg_tys) - -freshNames :: [Name] -> [Name] --- Make an infinite list of Names whose Uniques and OccNames --- differ from those in the 'avoid' list -freshNames avoids - = [ mkSystemName uniq occ - | n <- [0..] - , let uniq = mkAlphaTyVarUnique n - occ = mkTyVarOccFS (mkFastString ('x' : show n)) - - , not (uniq `elementOfUniqSet` avoid_uniqs) - , not (occ `elemOccSet` avoid_occs) ] - - where - avoid_uniqs :: UniqSet Unique - avoid_uniqs = mkUniqSet (map getUnique avoids) - - avoid_occs :: OccSet - avoid_occs = mkOccSet (map getOccName avoids) - --- | The 'Name' of the 'DataCon', giving it a unique, rooted identification -dataConName :: DataCon -> Name -dataConName = dcName - --- | The tag used for ordering 'DataCon's -dataConTag :: DataCon -> ConTag -dataConTag = dcTag - -dataConTagZ :: DataCon -> ConTagZ -dataConTagZ con = dataConTag con - fIRST_TAG - --- | The type constructor that we are building via this data constructor -dataConTyCon :: DataCon -> TyCon -dataConTyCon = dcRepTyCon - --- | The original type constructor used in the definition of this data --- constructor. In case of a data family instance, that will be the family --- type constructor. -dataConOrigTyCon :: DataCon -> TyCon -dataConOrigTyCon dc - | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc - | otherwise = dcRepTyCon dc - --- | The representation type of the data constructor, i.e. the sort --- type that will represent values of this type at runtime -dataConRepType :: DataCon -> Type -dataConRepType = dcRepType - --- | Should the 'DataCon' be presented infix? -dataConIsInfix :: DataCon -> Bool -dataConIsInfix = dcInfix - --- | The universally-quantified type variables of the constructor -dataConUnivTyVars :: DataCon -> [TyVar] -dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs - --- | The existentially-quantified type/coercion variables of the constructor --- including dependent (kind-) GADT equalities -dataConExTyCoVars :: DataCon -> [TyCoVar] -dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs - --- | Both the universal and existential type/coercion variables of the constructor -dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] -dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) - = univ_tvs ++ ex_tvs - --- See Note [DataCon user type variable binders] --- | The type variables of the constructor, in the order the user wrote them -dataConUserTyVars :: DataCon -> [TyVar] -dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs - --- See Note [DataCon user type variable binders] --- | 'TyCoVarBinder's for the type variables of the constructor, in the order the --- user wrote them -dataConUserTyVarBinders :: DataCon -> [TyVarBinder] -dataConUserTyVarBinders = dcUserTyVarBinders - --- | Equalities derived from the result type of the data constructor, as written --- by the programmer in any GADT declaration. This includes *all* GADT-like --- equalities, including those written in by hand by the programmer. -dataConEqSpec :: DataCon -> [EqSpec] -dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = dataConKindEqSpec con - ++ eq_spec ++ - [ spec -- heterogeneous equality - | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` heqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] ++ - [ spec -- homogeneous equality - | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` eqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] - --- | Dependent (kind-level) equalities in a constructor. --- There are extracted from the existential variables. --- See Note [Existential coercion variables] -dataConKindEqSpec :: DataCon -> [EqSpec] -dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) - -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), - -- which are frequently used functions. - -- For now (Aug 2018) this function always return empty set as we don't really - -- have coercion variables. - -- In the future when we do, we might want to cache this information in DataCon - -- so it won't be computed every time when aforementioned functions are called. - = [ EqSpec tv ty - | cv <- ex_tcvs - , isCoVar cv - , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv - tv = getTyVar "dataConKindEqSpec" ty1 - ] - --- | The *full* constraints on the constructor type, including dependent GADT --- equalities. -dataConTheta :: DataCon -> ThetaType -dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta - --- | Get the Id of the 'DataCon' worker: a function that is the "actual" --- constructor and has no top level binding in the program. The type may --- be different from the obvious one written in the source program. Panics --- if there is no such 'Id' for this 'DataCon' -dataConWorkId :: DataCon -> Id -dataConWorkId dc = dcWorkId dc - --- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" --- constructor so it has the type visible in the source program: c.f. --- 'dataConWorkId'. --- Returns Nothing if there is no wrapper, which occurs for an algebraic data --- constructor and also for a newtype (whose constructor is inlined --- compulsorily) -dataConWrapId_maybe :: DataCon -> Maybe Id -dataConWrapId_maybe dc = case dcRep dc of - NoDataConRep -> Nothing - DCR { dcr_wrap_id = wrap_id } -> Just wrap_id - --- | Returns an Id which looks like the Haskell-source constructor by using --- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to --- the worker (see 'dataConWorkId') -dataConWrapId :: DataCon -> Id -dataConWrapId dc = case dcRep dc of - NoDataConRep-> dcWorkId dc -- worker=wrapper - DCR { dcr_wrap_id = wrap_id } -> wrap_id - --- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, --- the union of the 'dataConWorkId' and the 'dataConWrapId' -dataConImplicitTyThings :: DataCon -> [TyThing] -dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) - = [AnId work] ++ wrap_ids - where - wrap_ids = case rep of - NoDataConRep -> [] - DCR { dcr_wrap_id = wrap } -> [AnId wrap] - --- | The labels for the fields of this particular 'DataCon' -dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels = dcFields - --- | Extract the type for any given labelled field of the 'DataCon' -dataConFieldType :: DataCon -> FieldLabelString -> Type -dataConFieldType con label = case dataConFieldType_maybe con label of - Just (_, ty) -> ty - Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) - --- | Extract the label and type for any given labelled field of the --- 'DataCon', or return 'Nothing' if the field does not belong to it -dataConFieldType_maybe :: DataCon -> FieldLabelString - -> Maybe (FieldLabel, Type) -dataConFieldType_maybe con label - = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) - --- | Strictness/unpack annotations, from user; or, for imported --- DataCons, from the interface file --- The list is in one-to-one correspondence with the arity of the 'DataCon' - -dataConSrcBangs :: DataCon -> [HsSrcBang] -dataConSrcBangs = dcSrcBangs - --- | Source-level arity of the data constructor -dataConSourceArity :: DataCon -> Arity -dataConSourceArity (MkData { dcSourceArity = arity }) = arity - --- | Gives the number of actual fields in the /representation/ of the --- data constructor. This may be more than appear in the source code; --- the extra ones are the existentially quantified dictionaries -dataConRepArity :: DataCon -> Arity -dataConRepArity (MkData { dcRepArity = arity }) = arity - --- | Return whether there are any argument types for this 'DataCon's original source type --- See Note [DataCon arities] -isNullarySrcDataCon :: DataCon -> Bool -isNullarySrcDataCon dc = dataConSourceArity dc == 0 - --- | Return whether there are any argument types for this 'DataCon's runtime representation type --- See Note [DataCon arities] -isNullaryRepDataCon :: DataCon -> Bool -isNullaryRepDataCon dc = dataConRepArity dc == 0 - -dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = case dcRep dc of - NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] - DCR { dcr_stricts = strs } -> strs - -dataConImplBangs :: DataCon -> [HsImplBang] --- The implementation decisions about the strictness/unpack of each --- source program argument to the data constructor -dataConImplBangs dc - = case dcRep dc of - NoDataConRep -> replicate (dcSourceArity dc) HsLazy - DCR { dcr_bangs = bangs } -> bangs - -dataConBoxer :: DataCon -> Maybe DataConBoxer -dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer -dataConBoxer _ = Nothing - --- | The \"signature\" of the 'DataCon' returns, in order: --- --- 1) The result of 'dataConUnivAndExTyCoVars', --- --- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, --- implicit parameter - whatever), including dependent GADT equalities. --- Dependent GADT equalities are *also* listed in return value (1), so be --- careful! --- --- 3) The type arguments to the constructor --- --- 4) The /original/ result type of the 'DataCon' -dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type) -dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (dataConUnivAndExTyCoVars con, dataConTheta con, arg_tys, res_ty) - -dataConInstSig - :: DataCon - -> [Type] -- Instantiate the *universal* tyvars with these types - -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials - -- theta and arg tys --- ^ Instantiate the universal tyvars of a data con, --- returning --- ( instantiated existentials --- , instantiated constraints including dependent GADT equalities --- which are *also* listed in the instantiated existentials --- , instantiated args) -dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs - , dcOrigArgTys = arg_tys }) - univ_tys - = ( ex_tvs' - , substTheta subst (dataConTheta con) - , substTys subst arg_tys) - where - univ_subst = zipTvSubst univ_tvs univ_tys - (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs - - --- | The \"full signature\" of the 'DataCon' returns, in order: --- --- 1) The result of 'dataConUnivTyVars' --- --- 2) The result of 'dataConExTyCoVars' --- --- 3) The non-dependent GADT equalities. --- Dependent GADT equalities are implied by coercion variables in --- return value (2). --- --- 4) The other constraints of the data constructor type, excluding GADT --- equalities --- --- 5) The original argument types to the 'DataCon' (i.e. before --- any change of the representation of the type) --- --- 6) The original result type of the 'DataCon' -dataConFullSig :: DataCon - -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) -dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, - dcEqSpec = eq_spec, dcOtherTheta = theta, - dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) - -dataConOrigResTy :: DataCon -> Type -dataConOrigResTy dc = dcOrigResTy dc - --- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: --- --- > data Eq a => T a = ... -dataConStupidTheta :: DataCon -> ThetaType -dataConStupidTheta dc = dcStupidTheta dc - -dataConUserType :: DataCon -> Type --- ^ The user-declared type of the data constructor --- in the nice-to-read form: --- --- > T :: forall a b. a -> b -> T [a] --- --- rather than: --- --- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c --- --- The type variables are quantified in the order that the user wrote them. --- See @Note [DataCon user type variable binders]@. --- --- NB: If the constructor is part of a data instance, the result type --- mentions the family tycon, not the internal one. -dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, - dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) - = mkForAllTys user_tvbs $ - mkInvisFunTys theta $ - mkVisFunTys arg_tys $ - res_ty - --- | Finds the instantiated types of the arguments required to construct a --- 'DataCon' representation --- NB: these INCLUDE any dictionary args --- but EXCLUDE the data-declaration context, which is discarded --- It's all post-flattening etc; this is a representation type -dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints - -- However, it can have a dcTheta (notably it can be a - -- class dictionary, with superclasses) - -> [Type] -- ^ Instantiated at these types - -> [Type] -dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, - dcExTyCoVars = ex_tvs}) inst_tys - = ASSERT2( univ_tvs `equalLength` inst_tys - , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) - ASSERT2( null ex_tvs, ppr dc ) - map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) - --- | Returns just the instantiated /value/ argument types of a 'DataCon', --- (excluding dictionary args) -dataConInstOrigArgTys - :: DataCon -- Works for any DataCon - -> [Type] -- Includes existential tyvar args, but NOT - -- equality constraints or dicts - -> [Type] --- For vanilla datacons, it's all quite straightforward --- But for the call in MatchCon, we really do want just the value args -dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyCoVars = ex_tvs}) inst_tys - = ASSERT2( tyvars `equalLength` inst_tys - , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTy subst) arg_tys - where - tyvars = univ_tvs ++ ex_tvs - subst = zipTCvSubst tyvars inst_tys - --- | Returns the argument types of the wrapper, excluding all dictionary arguments --- and without substituting for any type variables -dataConOrigArgTys :: DataCon -> [Type] -dataConOrigArgTys dc = dcOrigArgTys dc - --- | Returns the arg types of the worker, including *all* non-dependent --- evidence, after any flattening has been done and without substituting for --- any type variables -dataConRepArgTys :: DataCon -> [Type] -dataConRepArgTys (MkData { dcRep = rep - , dcEqSpec = eq_spec - , dcOtherTheta = theta - , dcOrigArgTys = orig_arg_tys }) - = case rep of - NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys - DCR { dcr_arg_tys = arg_tys } -> arg_tys - --- | The string @package:module.name@ identifying a constructor, which is attached --- to its info table and used by the GHCi debugger and the heap profiler -dataConIdentity :: DataCon -> ByteString --- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. -dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat - [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod)) - , BSB.int8 $ fromIntegral (ord ':') - , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod)) - , BSB.int8 $ fromIntegral (ord '.') - , BSB.byteString $ bytesFS (occNameFS (nameOccName name)) - ] - where name = dataConName dc - mod = ASSERT( isExternalName name ) nameModule name - -isTupleDataCon :: DataCon -> Bool -isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc - -isUnboxedTupleCon :: DataCon -> Bool -isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc - -isUnboxedSumCon :: DataCon -> Bool -isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc - --- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors -isVanillaDataCon :: DataCon -> Bool -isVanillaDataCon dc = dcVanilla dc - --- | Should this DataCon be allowed in a type even without -XDataKinds? --- Currently, only Lifted & Unlifted -specialPromotedDc :: DataCon -> Bool -specialPromotedDc = isKindTyCon . dataConTyCon - -classDataCon :: Class -> DataCon -classDataCon clas = case tyConDataCons (classTyCon clas) of - (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr - [] -> panic "classDataCon" - -dataConCannotMatch :: [Type] -> DataCon -> Bool --- Returns True iff the data con *definitely cannot* match a --- scrutinee of type (T tys) --- where T is the dcRepTyCon for the data con -dataConCannotMatch tys con - | null inst_theta = False -- Common - | all isTyVarTy tys = False -- Also common - | otherwise = typesCantMatch (concatMap predEqs inst_theta) - where - (_, inst_theta, _) = dataConInstSig con tys - - -- TODO: could gather equalities from superclasses too - predEqs pred = case classifyPredType pred of - EqPred NomEq ty1 ty2 -> [(ty1, ty2)] - ClassPred eq args - | eq `hasKey` eqTyConKey - , [_, ty1, ty2] <- args -> [(ty1, ty2)] - | eq `hasKey` heqTyConKey - , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] - _ -> [] - --- | Were the type variables of the data con written in a different order --- than the regular order (universal tyvars followed by existential tyvars)? --- --- This is not a cheap test, so we minimize its use in GHC as much as possible. --- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in --- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once --- during a data constructor's lifetime. - --- See Note [DataCon user type variable binders], as well as --- Note [Data con wrappers and GADT syntax] for an explanation of what --- mkDataConRep is doing with this function. -dataConUserTyVarsArePermuted :: DataCon -> Bool -dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs - , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec - , dcUserTyVarBinders = user_tvbs }) = - (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs - -{- -%************************************************************************ -%* * - Promoting of data types to the kind level -* * -************************************************************************ - --} - -promoteDataCon :: DataCon -> TyCon -promoteDataCon (MkData { dcPromoted = tc }) = tc - -{- -************************************************************************ -* * -\subsection{Splitting products} -* * -************************************************************************ --} - --- | Extract the type constructor, type argument, data constructor and it's --- /representation/ argument types from a type if it is a product type. --- --- Precisely, we return @Just@ for any type that is all of: --- --- * Concrete (i.e. constructors visible) --- --- * Single-constructor --- --- * Not existentially quantified --- --- Whether the type is a @data@ type or a @newtype@ -splitDataProductType_maybe - :: Type -- ^ A product type, perhaps - -> Maybe (TyCon, -- The type constructor - [Type], -- Type args of the tycon - DataCon, -- The data constructor - [Type]) -- Its /representation/ arg types - - -- Rejecting existentials is conservative. Maybe some things - -- could be made to work with them, but I'm not going to sweat - -- it through till someone finds it's important. - -splitDataProductType_maybe ty - | Just (tycon, ty_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tycon - = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Building an algebraic data type -* * -************************************************************************ - -buildAlgTyCon is here because it is called from TysWiredIn, which can -depend on this module, but not on BuildTyCl. --} - -buildAlgTyCon :: Name - -> [TyVar] -- ^ Kind variables and type variables - -> [Role] - -> Maybe CType - -> ThetaType -- ^ Stupid theta - -> AlgTyConRhs - -> Bool -- ^ True <=> was declared in GADT syntax - -> AlgTyConFlav - -> TyCon - -buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs - gadt_syn parent - = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta - rhs parent gadt_syn - where - binders = mkTyConBindersPreferAnon ktvs emptyVarSet - -buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> KnotTied Type -> TyCon -buildSynTyCon name binders res_kind roles rhs - = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free - where - is_tau = isTauTy rhs - is_fam_free = isFamFreeTy rhs diff --git a/basicTypes/DataCon.hs-boot b/basicTypes/DataCon.hs-boot deleted file mode 100644 --- a/basicTypes/DataCon.hs-boot +++ /dev/null @@ -1,34 +0,0 @@ -module DataCon where - -import GhcPrelude -import Var( TyVar, TyCoVar, TyVarBinder ) -import Name( Name, NamedThing ) -import {-# SOURCE #-} TyCon( TyCon ) -import FieldLabel ( FieldLabel ) -import Unique ( Uniquable ) -import Outputable ( Outputable, OutputableBndr ) -import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep ( Type, ThetaType ) - -data DataCon -data DataConRep -data EqSpec - -dataConName :: DataCon -> Name -dataConTyCon :: DataCon -> TyCon -dataConExTyCoVars :: DataCon -> [TyCoVar] -dataConUserTyVars :: DataCon -> [TyVar] -dataConUserTyVarBinders :: DataCon -> [TyVarBinder] -dataConSourceArity :: DataCon -> Arity -dataConFieldLabels :: DataCon -> [FieldLabel] -dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] -dataConStupidTheta :: DataCon -> ThetaType -dataConFullSig :: DataCon - -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) -isUnboxedSumCon :: DataCon -> Bool - -instance Eq DataCon -instance Uniquable DataCon -instance NamedThing DataCon -instance Outputable DataCon -instance OutputableBndr DataCon diff --git a/basicTypes/Demand.hs b/basicTypes/Demand.hs deleted file mode 100644 --- a/basicTypes/Demand.hs +++ /dev/null @@ -1,2103 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Demand]{@Demand@: A decoupled implementation of a demand domain} --} - -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} - -module Demand ( - StrDmd, UseDmd(..), Count, - - Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, - mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, - toCleanDmd, - absDmd, topDmd, botDmd, seqDmd, - lubDmd, bothDmd, - lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, - isTopDmd, isAbsDmd, isSeqDmd, - peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, - addCaseBndrDmd, - - DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, - nopDmdType, botDmdType, mkDmdType, - addDemand, ensureArgs, - BothDmdArg, mkBothDmdArg, toBothDmdArg, - - DmdEnv, emptyDmdEnv, - peelFV, findIdDemand, - - DmdResult, CPRResult, - isBotRes, isTopRes, - topRes, botRes, cprProdRes, - vanillaCprProdRes, cprSumRes, - appIsBottom, isBottomingSig, pprIfaceStrictSig, - trimCPRInfo, returnsCPR_maybe, - StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, - nopSig, botSig, cprProdSig, - isTopSig, hasDemandEnvSig, - splitStrictSig, strictSigDmdEnv, - increaseStrictSigArity, etaExpandStrictSig, - - seqDemand, seqDemandList, seqDmdType, seqStrictSig, - - evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, - splitDmdTy, splitFVs, - deferAfterIO, - postProcessUnsat, postProcessDmdType, - - splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, - mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, - dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, - TypeShape(..), peelTsFuns, trimToType, - - useCount, isUsedOnce, reuseEnv, - killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig, - zapUsedOnceDemand, zapUsedOnceSig, - strictifyDictDmd, strictifyDmd - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import Outputable -import Var ( Var ) -import VarEnv -import UniqFM -import Util -import BasicTypes -import Binary -import Maybes ( orElse ) - -import Type ( Type ) -import TyCon ( isNewTyCon, isClassTyCon ) -import DataCon ( splitDataProductType_maybe ) - -{- -************************************************************************ -* * - Joint domain for Strictness and Absence -* * -************************************************************************ --} - -data JointDmd s u = JD { sd :: s, ud :: u } - deriving ( Eq, Show ) - -getStrDmd :: JointDmd s u -> s -getStrDmd = sd - -getUseDmd :: JointDmd s u -> u -getUseDmd = ud - --- Pretty-printing -instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where - ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) - --- Well-formedness preserving constructors for the joint domain -mkJointDmd :: s -> u -> JointDmd s u -mkJointDmd s u = JD { sd = s, ud = u } - -mkJointDmds :: [s] -> [u] -> [JointDmd s u] -mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as - - -{- -************************************************************************ -* * - Strictness domain -* * -************************************************************************ - - Lazy - | - HeadStr - / \ - SCall SProd - \ / - HyperStr - -Note [Exceptions and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to smart about catching exceptions, but we aren't anymore. -See #14998 for the way it's resolved at the moment. - -Here's a historic breakdown: - -Apparently, exception handling prim-ops didn't use to have any special -strictness signatures, thus defaulting to topSig, which assumes they use their -arguments lazily. Joachim was the first to realise that we could provide richer -information. Thus, in 0558911f91c (Dec 13), he added signatures to -primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call -their argument, which is useful information for usage analysis. Still with a -'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. - -In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a -'strictApply1Dmd' leads to substantial performance gains. That was at the cost -of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in -28638dfe79e (Dec 15). - -Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, -Ben opened #11222. Simon made the demand analyser "understand catch" in -9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call -its argument strictly, but also swallow any thrown exceptions in -'postProcessDmdResult'. This was realized by extending the 'Str' constructor of -'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and -adding a 'ThrowsExn' constructor to the 'Termination' lattice as an element -between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, -so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). - -This left the other variants like 'catchRetry#' having 'catchArgDmd', which is -where #14998 picked up. Item 1 was concerned with measuring the impact of also -making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that -there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 -(Apr 18). There was a lot of dead code resulting from that change, that we -removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and -removed any code that was dealing with the peculiarities. - -Where did the speed-ups vanish to? In #14998, item 3 established that -turning 'catch#' strict in its first argument didn't bring back any of the -alleged performance benefits. Item 2 of that ticket finally found out that it -was entirely due to 'catchException's new (since #11555) definition, which -was simply - - catchException !io handler = catch io handler - -While 'catchException' is arguably the saner semantics for 'catch', it is an -internal helper function in "GHC.IO". Its use in -"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: -Remove the bang and you find the regressions we originally wanted to avoid with -'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". - -So history keeps telling us that the only possibly correct strictness annotation -for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really -is not strict in its argument: Just try this in GHCi - - :set -XScopedTypeVariables - import Control.Exception - catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") - -Any analysis that assumes otherwise will be broken in some way or another -(beyond `-fno-pendantic-bottoms`). --} - --- | Vanilla strictness domain -data StrDmd - = HyperStr -- ^ Hyper-strict (bottom of the lattice). - -- See Note [HyperStr and Use demands] - - | SCall StrDmd -- ^ Call demand - -- Used only for values of function type - - | SProd [ArgStr] -- ^ Product - -- Used only for values of product type - -- Invariant: not all components are HyperStr (use HyperStr) - -- not all components are Lazy (use HeadStr) - - | HeadStr -- ^ Head-Strict - -- A polymorphic demand: used for values of all types, - -- including a type variable - - deriving ( Eq, Show ) - --- | Strictness of a function argument. -type ArgStr = Str StrDmd - --- | Strictness demand. -data Str s = Lazy -- ^ Lazy (top of the lattice) - | Str s -- ^ Strict - deriving ( Eq, Show ) - --- Well-formedness preserving constructors for the Strictness domain -strBot, strTop :: ArgStr -strBot = Str HyperStr -strTop = Lazy - -mkSCall :: StrDmd -> StrDmd -mkSCall HyperStr = HyperStr -mkSCall s = SCall s - -mkSProd :: [ArgStr] -> StrDmd -mkSProd sx - | any isHyperStr sx = HyperStr - | all isLazy sx = HeadStr - | otherwise = SProd sx - -isLazy :: ArgStr -> Bool -isLazy Lazy = True -isLazy (Str {}) = False - -isHyperStr :: ArgStr -> Bool -isHyperStr (Str HyperStr) = True -isHyperStr _ = False - --- Pretty-printing -instance Outputable StrDmd where - ppr HyperStr = char 'B' - ppr (SCall s) = char 'C' <> parens (ppr s) - ppr HeadStr = char 'S' - ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) - -instance Outputable ArgStr where - ppr (Str s) = ppr s - ppr Lazy = char 'L' - -lubArgStr :: ArgStr -> ArgStr -> ArgStr -lubArgStr Lazy _ = Lazy -lubArgStr _ Lazy = Lazy -lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) - -lubStr :: StrDmd -> StrDmd -> StrDmd -lubStr HyperStr s = s -lubStr (SCall s1) HyperStr = SCall s1 -lubStr (SCall _) HeadStr = HeadStr -lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) -lubStr (SCall _) (SProd _) = HeadStr -lubStr (SProd sx) HyperStr = SProd sx -lubStr (SProd _) HeadStr = HeadStr -lubStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) - | otherwise = HeadStr -lubStr (SProd _) (SCall _) = HeadStr -lubStr HeadStr _ = HeadStr - -bothArgStr :: ArgStr -> ArgStr -> ArgStr -bothArgStr Lazy s = s -bothArgStr s Lazy = s -bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) - -bothStr :: StrDmd -> StrDmd -> StrDmd -bothStr HyperStr _ = HyperStr -bothStr HeadStr s = s -bothStr (SCall _) HyperStr = HyperStr -bothStr (SCall s1) HeadStr = SCall s1 -bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) -bothStr (SCall _) (SProd _) = HyperStr -- Weird - -bothStr (SProd _) HyperStr = HyperStr -bothStr (SProd s1) HeadStr = SProd s1 -bothStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) - | otherwise = HyperStr -- Weird -bothStr (SProd _) (SCall _) = HyperStr - --- utility functions to deal with memory leaks -seqStrDmd :: StrDmd -> () -seqStrDmd (SProd ds) = seqStrDmdList ds -seqStrDmd (SCall s) = seqStrDmd s -seqStrDmd _ = () - -seqStrDmdList :: [ArgStr] -> () -seqStrDmdList [] = () -seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds - -seqArgStr :: ArgStr -> () -seqArgStr Lazy = () -seqArgStr (Str s) = seqStrDmd s - --- Splitting polymorphic demands -splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] -splitArgStrProdDmd n Lazy = Just (replicate n Lazy) -splitArgStrProdDmd n (Str s) = splitStrProdDmd n s - -splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] -splitStrProdDmd n HyperStr = Just (replicate n strBot) -splitStrProdDmd n HeadStr = Just (replicate n strTop) -splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), - text "splitStrProdDmd" $$ ppr n $$ ppr ds ) - Just ds -splitStrProdDmd _ (SCall {}) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) - -{- -************************************************************************ -* * - Absence domain -* * -************************************************************************ - - Used - / \ - UCall UProd - \ / - UHead - | - Count x - - | - Abs --} - --- | Domain for genuine usage -data UseDmd - = UCall Count UseDmd -- ^ Call demand for absence. - -- Used only for values of function type - - | UProd [ArgUse] -- ^ Product. - -- Used only for values of product type - -- See Note [Don't optimise UProd(Used) to Used] - -- - -- Invariant: Not all components are Abs - -- (in that case, use UHead) - - | UHead -- ^ May be used but its sub-components are - -- definitely *not* used. For product types, UHead - -- is equivalent to U(AAA); see mkUProd. - -- - -- UHead is needed only to express the demand - -- of 'seq' and 'case' which are polymorphic; - -- i.e. the scrutinised value is of type 'a' - -- rather than a product type. That's why we - -- can't use UProd [A,A,A] - -- - -- Since (UCall _ Abs) is ill-typed, UHead doesn't - -- make sense for lambdas - - | Used -- ^ May be used and its sub-components may be used. - -- (top of the lattice) - deriving ( Eq, Show ) - --- Extended usage demand for absence and counting -type ArgUse = Use UseDmd - -data Use u - = Abs -- Definitely unused - -- Bottom of the lattice - - | Use Count u -- May be used with some cardinality - deriving ( Eq, Show ) - --- | Abstract counting of usages -data Count = One | Many - deriving ( Eq, Show ) - --- Pretty-printing -instance Outputable ArgUse where - ppr Abs = char 'A' - ppr (Use Many a) = ppr a - ppr (Use One a) = char '1' <> char '*' <> ppr a - -instance Outputable UseDmd where - ppr Used = char 'U' - ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) - ppr UHead = char 'H' - ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) - -instance Outputable Count where - ppr One = char '1' - ppr Many = text "" - -useBot, useTop :: ArgUse -useBot = Abs -useTop = Use Many Used - -mkUCall :: Count -> UseDmd -> UseDmd ---mkUCall c Used = Used c -mkUCall c a = UCall c a - -mkUProd :: [ArgUse] -> UseDmd -mkUProd ux - | all (== Abs) ux = UHead - | otherwise = UProd ux - -lubCount :: Count -> Count -> Count -lubCount _ Many = Many -lubCount Many _ = Many -lubCount x _ = x - -lubArgUse :: ArgUse -> ArgUse -> ArgUse -lubArgUse Abs x = x -lubArgUse x Abs = x -lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) - -lubUse :: UseDmd -> UseDmd -> UseDmd -lubUse UHead u = u -lubUse (UCall c u) UHead = UCall c u -lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) -lubUse (UCall _ _) _ = Used -lubUse (UProd ux) UHead = UProd ux -lubUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 - | otherwise = Used -lubUse (UProd {}) (UCall {}) = Used --- lubUse (UProd {}) Used = Used -lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) -lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) -lubUse Used _ = Used -- Note [Used should win] - --- `both` is different from `lub` in its treatment of counting; if --- `both` is computed for two used, the result always has --- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). --- Also, x `bothUse` x /= x (for anything but Abs). - -bothArgUse :: ArgUse -> ArgUse -> ArgUse -bothArgUse Abs x = x -bothArgUse x Abs = x -bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) - - -bothUse :: UseDmd -> UseDmd -> UseDmd -bothUse UHead u = u -bothUse (UCall c u) UHead = UCall c u - --- Exciting special treatment of inner demand for call demands: --- use `lubUse` instead of `bothUse`! -bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) - -bothUse (UCall {}) _ = Used -bothUse (UProd ux) UHead = UProd ux -bothUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 - | otherwise = Used -bothUse (UProd {}) (UCall {}) = Used --- bothUse (UProd {}) Used = Used -- Note [Used should win] -bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) -bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) -bothUse Used _ = Used -- Note [Used should win] - -peelUseCall :: UseDmd -> Maybe (Count, UseDmd) -peelUseCall (UCall c u) = Just (c,u) -peelUseCall _ = Nothing - -addCaseBndrDmd :: Demand -- On the case binder - -> [Demand] -- On the components of the constructor - -> [Demand] -- Final demands for the components of the constructor --- See Note [Demand on case-alternative binders] -addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds - = case mu of - Abs -> alt_dmds - Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) - where - Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call - Just us = splitUseProdDmd arity u -- Ditto - where - arity = length alt_dmds - -{- Note [Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand on a binder in a case alternative comes - (a) From the demand on the binder itself - (b) From the demand on the case binder -Forgetting (b) led directly to #10148. - -Example. Source code: - f x@(p,_) = if p then foo x else True - - foo (p,True) = True - foo (p,q) = foo (q,p) - -After strictness analysis: - f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> - case x_an1 - of wild_X7 [Dmd=] - { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> - case p_an2 of _ { - False -> GHC.Types.True; - True -> foo wild_X7 } - -It's true that ds_dnz is *itself* absent, but the use of wild_X7 means -that it is very much alive and demanded. See #10148 for how the -consequences play out. - -This is needed even for non-product types, in case the case-binder -is used but the components of the case alternative are not. - -Note [Don't optimise UProd(Used) to Used] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These two UseDmds: - UProd [Used, Used] and Used -are semantically equivalent, but we do not turn the former into -the latter, for a regrettable-subtle reason. Suppose we did. -then - f (x,y) = (y,x) -would get - StrDmd = Str = SProd [Lazy, Lazy] - UseDmd = Used = UProd [Used, Used] -But with the joint demand of doesn't convey any clue -that there is a product involved, and so the worthSplittingFun -will not fire. (We'd need to use the type as well to make it fire.) -Moreover, consider - g h p@(_,_) = h p -This too would get , but this time there really isn't any -point in w/w since the components of the pair are not used at all. - -So the solution is: don't aggressively collapse UProd [Used,Used] to -Used; intead leave it as-is. In effect we are using the UseDmd to do a -little bit of boxity analysis. Not very nice. - -Note [Used should win] -~~~~~~~~~~~~~~~~~~~~~~ -Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. -Why? Because Used carries the implication the whole thing is used, -box and all, so we don't want to w/w it. If we use it both boxed and -unboxed, then we are definitely using the box, and so we are quite -likely to pay a reboxing cost. So we make Used win here. - -Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer - -Baseline: (A) Not making Used win (UProd wins) -Compare with: (B) making Used win for lub and both - - Min -0.3% -5.6% -10.7% -11.0% -33.3% - Max +0.3% +45.6% +11.5% +11.5% +6.9% - Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% - -Baseline: (B) Making Used win for both lub and both -Compare with: (C) making Used win for both, but UProd win for lub - - Min -0.1% -0.3% -7.9% -8.0% -6.5% - Max +0.1% +1.0% +21.0% +21.0% +0.5% - Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% --} - --- If a demand is used multiple times (i.e. reused), than any use-once --- mentioned there, that is not protected by a UCall, can happen many times. -markReusedDmd :: ArgUse -> ArgUse -markReusedDmd Abs = Abs -markReusedDmd (Use _ a) = Use Many (markReused a) - -markReused :: UseDmd -> UseDmd -markReused (UCall _ u) = UCall Many u -- No need to recurse here -markReused (UProd ux) = UProd (map markReusedDmd ux) -markReused u = u - -isUsedMU :: ArgUse -> Bool --- True <=> markReusedDmd d = d -isUsedMU Abs = True -isUsedMU (Use One _) = False -isUsedMU (Use Many u) = isUsedU u - -isUsedU :: UseDmd -> Bool --- True <=> markReused d = d -isUsedU Used = True -isUsedU UHead = True -isUsedU (UProd us) = all isUsedMU us -isUsedU (UCall One _) = False -isUsedU (UCall Many _) = True -- No need to recurse - --- Squashing usage demand demands -seqUseDmd :: UseDmd -> () -seqUseDmd (UProd ds) = seqArgUseList ds -seqUseDmd (UCall c d) = c `seq` seqUseDmd d -seqUseDmd _ = () - -seqArgUseList :: [ArgUse] -> () -seqArgUseList [] = () -seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds - -seqArgUse :: ArgUse -> () -seqArgUse (Use c u) = c `seq` seqUseDmd u -seqArgUse _ = () - --- Splitting polymorphic Maybe-Used demands -splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] -splitUseProdDmd n Used = Just (replicate n useTop) -splitUseProdDmd n UHead = Just (replicate n Abs) -splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), - text "splitUseProdDmd" $$ ppr n - $$ ppr ds ) - Just ds -splitUseProdDmd _ (UCall _ _) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) - -useCount :: Use u -> Count -useCount Abs = One -useCount (Use One _) = One -useCount _ = Many - - -{- -************************************************************************ -* * - Clean demand for Strictness and Usage -* * -************************************************************************ - -This domain differst from JointDemand in the sence that pure absence -is taken away, i.e., we deal *only* with non-absent demands. - -Note [Strict demands] -~~~~~~~~~~~~~~~~~~~~~ -isStrictDmd returns true only of demands that are - both strict - and used -In particular, it is False for , which can and does -arise in, say (#7319) - f x = raise# -Then 'x' is not used, so f gets strictness -> . -Now the w/w generates - fx = let x = absentError "unused" - in raise -At this point we really don't want to convert to - fx = case absentError "unused" of x -> raise -Since the program is going to diverge, this swaps one error for another, -but it's really a bad idea to *ever* evaluate an absent argument. -In #7319 we get - T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] - -Note [Dealing with call demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Call demands are constructed and deconstructed coherently for -strictness and absence. For instance, the strictness signature for the -following function - -f :: (Int -> (Int, Int)) -> (Int, Bool) -f g = (snd (g 3), True) - -should be: m --} - -type CleanDemand = JointDmd StrDmd UseDmd - -- A demand that is at least head-strict - -bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand -bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) - = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } - -mkHeadStrict :: CleanDemand -> CleanDemand -mkHeadStrict cd = cd { sd = HeadStr } - -mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand -mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } -mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } - -evalDmd :: Demand --- Evaluated strictly, and used arbitrarily deeply -evalDmd = JD { sd = Str HeadStr, ud = useTop } - -mkProdDmd :: [Demand] -> CleanDemand -mkProdDmd dx - = JD { sd = mkSProd $ map getStrDmd dx - , ud = mkUProd $ map getUseDmd dx } - --- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. -mkCallDmd :: CleanDemand -> CleanDemand -mkCallDmd (JD {sd = d, ud = u}) - = JD { sd = mkSCall d, ud = mkUCall One u } - --- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. -mkCallDmds :: Arity -> CleanDemand -> CleanDemand -mkCallDmds arity cd = iterate mkCallDmd cd !! arity - --- See Note [Demand on the worker] in WorkWrap -mkWorkerDemand :: Int -> Demand -mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } - where go 0 = Used - go n = mkUCall One $ go (n-1) - -cleanEvalDmd :: CleanDemand -cleanEvalDmd = JD { sd = HeadStr, ud = Used } - -cleanEvalProdDmd :: Arity -> CleanDemand -cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } - - -{- -************************************************************************ -* * - Demand: combining stricness and usage -* * -************************************************************************ --} - -type Demand = JointDmd ArgStr ArgUse - -lubDmd :: Demand -> Demand -> Demand -lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `lubArgStr` s2 - , ud = a1 `lubArgUse` a2 } - -bothDmd :: Demand -> Demand -> Demand -bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `bothArgStr` s2 - , ud = a1 `bothArgUse` a2 } - -lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand - -strictApply1Dmd = JD { sd = Str (SCall HeadStr) - , ud = Use Many (UCall One Used) } - -lazyApply1Dmd = JD { sd = Lazy - , ud = Use One (UCall One Used) } - --- Second argument of catch#: --- uses its arg at most once, applies it once --- but is lazy (might not be called at all) -lazyApply2Dmd = JD { sd = Lazy - , ud = Use One (UCall One (UCall One Used)) } - -absDmd :: Demand -absDmd = JD { sd = Lazy, ud = Abs } - -topDmd :: Demand -topDmd = JD { sd = Lazy, ud = useTop } - -botDmd :: Demand -botDmd = JD { sd = strBot, ud = useBot } - -seqDmd :: Demand -seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } - -oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) -oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } -oneifyDmd jd = jd - -isTopDmd :: Demand -> Bool --- Used to suppress pretty-printing of an uninformative demand -isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True -isTopDmd _ = False - -isAbsDmd :: JointDmd (Str s) (Use u) -> Bool -isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr -isAbsDmd _ = False -- for a bottom demand - -isSeqDmd :: Demand -> Bool -isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True -isSeqDmd _ = False - -isUsedOnce :: JointDmd (Str s) (Use u) -> Bool -isUsedOnce (JD { ud = a }) = case useCount a of - One -> True - Many -> False - --- More utility functions for strictness -seqDemand :: Demand -> () -seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u - -seqDemandList :: [Demand] -> () -seqDemandList [] = () -seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds - -isStrictDmd :: JointDmd (Str s) (Use u) -> Bool --- See Note [Strict demands] -isStrictDmd (JD {ud = Abs}) = False -isStrictDmd (JD {sd = Lazy}) = False -isStrictDmd _ = True - -isWeakDmd :: Demand -> Bool -isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a - -cleanUseDmd_maybe :: Demand -> Maybe UseDmd -cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u -cleanUseDmd_maybe _ = Nothing - -splitFVs :: Bool -- Thunk - -> DmdEnv -> (DmdEnv, DmdEnv) -splitFVs is_thunk rhs_fvs - | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs - -- It's OK to use nonDetFoldUFM_Directly because we - -- immediately forget the ordering by putting the elements - -- in the envs again - | otherwise = partitionVarEnv isWeakDmd rhs_fvs - where - add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) - | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) - | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) - , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) - -data TypeShape = TsFun TypeShape - | TsProd [TypeShape] - | TsUnk - -instance Outputable TypeShape where - ppr TsUnk = text "TsUnk" - ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) - ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) - --- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and --- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise. -peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape -peelTsFuns 0 ts = Just ts -peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts -peelTsFuns _ _ = Nothing - -trimToType :: Demand -> TypeShape -> Demand --- See Note [Trimming a demand to a type] -trimToType (JD { sd = ms, ud = mu }) ts - = JD (go_ms ms ts) (go_mu mu ts) - where - go_ms :: ArgStr -> TypeShape -> ArgStr - go_ms Lazy _ = Lazy - go_ms (Str s) ts = Str (go_s s ts) - - go_s :: StrDmd -> TypeShape -> StrDmd - go_s HyperStr _ = HyperStr - go_s (SCall s) (TsFun ts) = SCall (go_s s ts) - go_s (SProd mss) (TsProd tss) - | equalLength mss tss = SProd (zipWith go_ms mss tss) - go_s _ _ = HeadStr - - go_mu :: ArgUse -> TypeShape -> ArgUse - go_mu Abs _ = Abs - go_mu (Use c u) ts = Use c (go_u u ts) - - go_u :: UseDmd -> TypeShape -> UseDmd - go_u UHead _ = UHead - go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) - go_u (UProd mus) (TsProd tss) - | equalLength mus tss = UProd (zipWith go_mu mus tss) - go_u _ _ = Used - -{- -Note [Trimming a demand to a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f :: a -> Bool - f x = case ... of - A g1 -> case (x |> g1) of (p,q) -> ... - B -> error "urk" - -where A,B are the constructors of a GADT. We'll get a U(U,U) demand -on x from the A branch, but that's a stupid demand for x itself, which -has type 'a'. Indeed we get ASSERTs going off (notably in -splitUseProdDmd, #8569). - -Bottom line: we really don't want to have a binder whose demand is more -deeply-nested than its type. There are various ways to tackle this. -When processing (x |> g1), we could "trim" the incoming demand U(U,U) -to match x's type. But I'm currently doing so just at the moment when -we pin a demand on a binder, in DmdAnal.findBndrDmd. - - -Note [Threshold demands] -~~~~~~~~~~~~~~~~~~~~~~~~ -Threshold usage demand is generated to figure out if -cardinality-instrumented demands of a binding's free variables should -be unleashed. See also [Aggregated demand for cardinality]. - -Note [Replicating polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some demands can be considered as polymorphic. Generally, it is -applicable to such beasts as tops, bottoms as well as Head-Used and -Head-stricts demands. For instance, - -S ~ S(L, ..., L) - -Also, when top or bottom is occurred as a result demand, it in fact -can be expanded to saturate a callee's arity. --} - -splitProdDmd_maybe :: Demand -> Maybe [Demand] --- Split a product into its components, iff there is any --- useful information to be extracted thereby --- The demand is not necessarily strict! -splitProdDmd_maybe (JD { sd = s, ud = u }) - = case (s,u) of - (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u - -> Just (mkJointDmds sx ux) - (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s - -> Just (mkJointDmds sx ux) - (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) - _ -> Nothing - -{- -************************************************************************ -* * - Demand results -* * -************************************************************************ - - -DmdResult: Dunno CPRResult - / - Diverges - - -CPRResult: NoCPR - / \ - RetProd RetSum ConTag - - -Product constructors return (Dunno (RetProd rs)) -In a fixpoint iteration, start from Diverges -We have lubs, but not glbs; but that is ok. --} - ------------------------------------------------------------------------- --- Constructed Product Result ------------------------------------------------------------------------- - -data Termination r - = Diverges -- Definitely diverges - | Dunno r -- Might diverge or converge - deriving( Eq, Show ) - --- At this point, Termination is just the 'Lifted' lattice over 'r' --- (https://hackage.haskell.org/package/lattices/docs/Algebra-Lattice-Lifted.html) - -type DmdResult = Termination CPRResult - -data CPRResult = NoCPR -- Top of the lattice - | RetProd -- Returns a constructor from a product type - | RetSum ConTag -- Returns a constructor from a data type - deriving( Eq, Show ) - -lubCPR :: CPRResult -> CPRResult -> CPRResult -lubCPR (RetSum t1) (RetSum t2) - | t1 == t2 = RetSum t1 -lubCPR RetProd RetProd = RetProd -lubCPR _ _ = NoCPR - -lubDmdResult :: DmdResult -> DmdResult -> DmdResult -lubDmdResult Diverges r = r -lubDmdResult r Diverges = r -lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2) --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -bothDmdResult :: DmdResult -> Termination () -> DmdResult --- See Note [Asymmetry of 'both' for DmdType and DmdResult] -bothDmdResult _ Diverges = Diverges -bothDmdResult r (Dunno {}) = r --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -instance Outputable r => Outputable (Termination r) where - ppr Diverges = char 'b' - ppr (Dunno c) = ppr c - -instance Outputable CPRResult where - ppr NoCPR = empty - ppr (RetSum n) = char 'm' <> int n - ppr RetProd = char 'm' - -seqDmdResult :: DmdResult -> () -seqDmdResult Diverges = () -seqDmdResult (Dunno c) = seqCPRResult c - -seqCPRResult :: CPRResult -> () -seqCPRResult NoCPR = () -seqCPRResult (RetSum n) = n `seq` () -seqCPRResult RetProd = () - - ------------------------------------------------------------------------- --- Combined demand result -- ------------------------------------------------------------------------- - --- [cprRes] lets us switch off CPR analysis --- by making sure that everything uses TopRes -topRes, botRes :: DmdResult -topRes = Dunno NoCPR -botRes = Diverges - -cprSumRes :: ConTag -> DmdResult -cprSumRes tag = Dunno $ RetSum tag - -cprProdRes :: [DmdType] -> DmdResult -cprProdRes _arg_tys = Dunno $ RetProd - -vanillaCprProdRes :: Arity -> DmdResult -vanillaCprProdRes _arity = Dunno $ RetProd - -isTopRes :: DmdResult -> Bool -isTopRes (Dunno NoCPR) = True -isTopRes _ = False - --- | True if the result diverges or throws an exception -isBotRes :: DmdResult -> Bool -isBotRes Diverges = True -isBotRes (Dunno {}) = False - -trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult -trimCPRInfo trim_all trim_sums res - = trimR res - where - trimR (Dunno c) = Dunno (trimC c) - trimR res = res - - trimC (RetSum n) | trim_all || trim_sums = NoCPR - | otherwise = RetSum n - trimC RetProd | trim_all = NoCPR - | otherwise = RetProd - trimC NoCPR = NoCPR - -returnsCPR_maybe :: DmdResult -> Maybe ConTag -returnsCPR_maybe (Dunno c) = retCPR_maybe c -returnsCPR_maybe _ = Nothing - -retCPR_maybe :: CPRResult -> Maybe ConTag -retCPR_maybe (RetSum t) = Just t -retCPR_maybe RetProd = Just fIRST_TAG -retCPR_maybe NoCPR = Nothing - --- See Notes [Default demand on free variables] --- and [defaultDmd vs. resTypeArgDmd] -defaultDmd :: Termination r -> Demand -defaultDmd (Dunno {}) = absDmd -defaultDmd _ = botDmd -- Diverges - -resTypeArgDmd :: Termination r -> Demand --- TopRes and BotRes are polymorphic, so that --- BotRes === (Bot -> BotRes) === ... --- TopRes === (Top -> TopRes) === ... --- This function makes that concrete --- Also see Note [defaultDmd vs. resTypeArgDmd] -resTypeArgDmd (Dunno _) = topDmd -resTypeArgDmd _ = botDmd -- Diverges - -{- -Note [defaultDmd and resTypeArgDmd] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -These functions are similar: They express the demand on something not -explicitly mentioned in the environment resp. the argument list. Yet they are -different: - * Variables not mentioned in the free variables environment are definitely - unused, so we can use absDmd there. - * Further arguments *can* be used, of course. Hence topDmd is used. - - -************************************************************************ -* * - Demand environments and types -* * -************************************************************************ --} - -type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] - -data DmdType = DmdType - DmdEnv -- Demand on explicitly-mentioned - -- free variables - [Demand] -- Demand on arguments - DmdResult -- See [Nature of result demand] - -{- -Note [Nature of result demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A DmdResult contains information about termination (currently distinguishing -definite divergence and no information; it is possible to include definite -convergence here), and CPR information about the result. - -The semantics of this depends on whether we are looking at a DmdType, i.e. the -demand put on by an expression _under a specific incoming demand_ on its -environment, or at a StrictSig describing a demand transformer. - -For a - * DmdType, the termination information is true given the demand it was - generated with, while for - * a StrictSig it holds after applying enough arguments. - -The CPR information, though, is valid after the number of arguments mentioned -in the type is given. Therefore, when forgetting the demand on arguments, as in -dmdAnalRhs, this needs to be considere (via removeDmdTyArgs). - -Consider - b2 x y = x `seq` y `seq` error (show x) -this has a strictness signature of - b -meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but -for "b2 1 2 `seq` ()" we get definite divergence. - -For comparison, - b1 x = x `seq` error (show x) -has a strictness signature of - b -and "b1 1 `seq` ()" is known to terminate. - -Now consider a function h with signature "", and the expression - e1 = h b1 -now h puts a demand of onto its argument, and the demand transformer -turns it into - b -Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not -diverge, and we do not anything being passed to b. - -Note [Asymmetry of 'both' for DmdType and DmdResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'both' for DmdTypes is *asymmetrical*, because there is only one -result! For example, given (e1 e2), we get a DmdType dt1 for e1, use -its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). -Similarly with - case e of { p -> rhs } -we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then -compute (dt_rhs `bothType` dt_scrut). - -We - 1. combine the information on the free variables, - 2. take the demand on arguments from the first argument - 3. combine the termination results, but - 4. take CPR info from the first argument. - -3 and 4 are implementd in bothDmdResult. --} - --- Equality needed for fixpoints in DmdAnal -instance Eq DmdType where - (==) (DmdType fv1 ds1 res1) - (DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 - -- It's OK to use nonDetUFMToList here because we're testing for - -- equality and even though the lists will be in some arbitrary - -- Unique order, it is the same order for both - && ds1 == ds2 && res1 == res2 - -lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 - = DmdType lub_fv lub_ds lub_res - where - n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1 r1) = ensureArgs n d1 - (DmdType fv2 ds2 r2) = ensureArgs n d2 - - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) - lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_res = lubDmdResult r1 r2 - -{- -Note [The need for BothDmdArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, the right argument to bothDmdType, as well as the return value of -dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs -to know about the free variables and termination information, but nothing about -the demand put on arguments, nor cpr information. So we make that explicit by -only passing the relevant information. --} - -type BothDmdArg = (DmdEnv, Termination ()) - -mkBothDmdArg :: DmdEnv -> BothDmdArg -mkBothDmdArg env = (env, Dunno ()) - -toBothDmdArg :: DmdType -> BothDmdArg -toBothDmdArg (DmdType fv _ r) = (fv, go r) - where - go (Dunno {}) = Dunno () - go Diverges = Diverges - -bothDmdType :: DmdType -> BothDmdArg -> DmdType -bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'both' for DmdType and DmdResult] - -- 'both' takes the argument/result info from its *first* arg, - -- using its second arg just for its free-var info. - = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) - ds1 - (r1 `bothDmdResult` t2) - -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [hcat (map ppr ds) <> ppr res, - if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts))] - where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = nonDetUFMToList fv - -- It's OK to use nonDetUFMToList here because we only do it for - -- pretty printing - -emptyDmdEnv :: VarEnv Demand -emptyDmdEnv = emptyVarEnv - --- nopDmdType is the demand of doing nothing --- (lazy, absent, no CPR information, no termination information). --- Note that it is ''not'' the top of the lattice (which would be "may use everything"), --- so it is (no longer) called topDmd -nopDmdType, botDmdType :: DmdType -nopDmdType = DmdType emptyDmdEnv [] topRes -botDmdType = DmdType emptyDmdEnv [] botRes - -cprProdDmdType :: Arity -> DmdType -cprProdDmdType arity - = DmdType emptyDmdEnv [] (vanillaCprProdRes arity) - -isTopDmdType :: DmdType -> Bool -isTopDmdType (DmdType env [] res) - | isTopRes res && isEmptyVarEnv env = True -isTopDmdType _ = False - -mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType -mkDmdType fv ds res = DmdType fv ds res - -dmdTypeDepth :: DmdType -> Arity -dmdTypeDepth (DmdType _ ds _) = length ds - --- | This makes sure we can use the demand type with n arguments. --- It extends the argument list with the correct resTypeArgDmd. --- It also adjusts the DmdResult: Divergence survives additional arguments, --- CPR information does not (and definite converge also would not). -ensureArgs :: Arity -> DmdType -> DmdType -ensureArgs n d | n == depth = d - | otherwise = DmdType fv ds' r' - where depth = dmdTypeDepth d - DmdType fv ds r = d - - ds' = take n (ds ++ repeat (resTypeArgDmd r)) - r' = case r of -- See [Nature of result demand] - Dunno _ -> topRes - _ -> r - - -seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds res) = - seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` () - -seqDmdEnv :: DmdEnv -> () -seqDmdEnv env = seqEltsUFM seqDemandList env - -splitDmdTy :: DmdType -> (Demand, DmdType) --- Split off one function argument --- We already have a suitable demand on all --- free vars, so no need to add more! -splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) - --- When e is evaluated after executing an IO action, and d is e's demand, then --- what of this demand should we consider, given that the IO action can cleanly --- exit? --- * We have to kill all strictness demands (i.e. lub with a lazy demand) --- * We can keep usage information (i.e. lub with an absent demand) --- * We have to kill definite divergence --- * We can keep CPR information. --- See Note [IO hack in the demand analyser] in DmdAnal -deferAfterIO :: DmdType -> DmdType -deferAfterIO d@(DmdType _ _ res) = - case d `lubDmdType` nopDmdType of - DmdType fv ds _ -> DmdType fv ds (defer_res res) - where - defer_res r@(Dunno {}) = r - defer_res _ = topRes -- Diverges - -strictenDmd :: Demand -> Demand -strictenDmd (JD { sd = s, ud = u}) - = JD { sd = poke_s s, ud = poke_u u } - where - poke_s Lazy = Str HeadStr - poke_s s = s - poke_u Abs = useTop - poke_u u = u - --- Deferring and peeling - -type DmdShell -- Describes the "outer shell" - -- of a Demand - = JointDmd (Str ()) (Use ()) - -toCleanDmd :: Demand -> (DmdShell, CleanDemand) --- Splits a Demand into its "shell" and the inner "clean demand" -toCleanDmd (JD { sd = s, ud = u }) - = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) - -- See Note [Analyzing with lazy demand and lambdas] - -- See Note [Analysing with absent demand] - where - (ss, s') = case s of - Str s' -> (Str (), s') - Lazy -> (Lazy, HeadStr) - - (us, u') = case u of - Use c u' -> (Use c (), u') - Abs -> (Abs, Used) - --- This is used in dmdAnalStar when post-processing --- a function's argument demand. So we only care about what --- does to free variables, and whether it terminates. --- see Note [The need for BothDmdArg] -postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg -postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) - = (postProcessDmdEnv du fv, term_info) - where - term_info = case postProcessDmdResult ss res_ty of - Dunno _ -> Dunno () - Diverges -> Diverges - -postProcessDmdResult :: Str () -> DmdResult -> DmdResult -postProcessDmdResult Lazy _ = topRes -postProcessDmdResult _ res = res - -postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv -postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env - | Abs <- us = emptyDmdEnv - -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild - -- of the environment. Be careful, bad things will happen if this doesn't - -- match postProcessDmd (see #13977). - | Str _ <- ss - , Use One _ <- us = env - | otherwise = mapVarEnv (postProcessDmd ds) env - -- For the Absent case just discard all usage information - -- We only processed the thing at all to analyse the body - -- See Note [Always analyse in virgin pass] - -reuseEnv :: DmdEnv -> DmdEnv -reuseEnv = mapVarEnv (postProcessDmd - (JD { sd = Str (), ud = Use Many () })) - -postProcessUnsat :: DmdShell -> DmdType -> DmdType -postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) - = DmdType (postProcessDmdEnv ds fv) - (map (postProcessDmd ds) args) - (postProcessDmdResult ss res_ty) - -postProcessDmd :: DmdShell -> Demand -> Demand -postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) - = JD { sd = s', ud = a' } - where - s' = case ss of - Lazy -> Lazy - Str _ -> s - a' = case us of - Abs -> Abs - Use Many _ -> markReusedDmd a - Use One _ -> a - --- Peels one call level from the demand, and also returns --- whether it was unsaturated (separately for strictness and usage) -peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) --- Exploiting the fact that --- on the strictness side C(B) = B --- and on the usage side C(U) = U -peelCallDmd (JD {sd = s, ud = u}) - = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) - where - (s', ss) = case s of - SCall s' -> (s', Str ()) - HyperStr -> (HyperStr, Str ()) - _ -> (HeadStr, Lazy) - (u', us) = case u of - UCall c u' -> (u', Use c ()) - _ -> (Used, Use Many ()) - -- The _ cases for usage includes UHead which seems a bit wrong - -- because the body isn't used at all! - -- c.f. the Abs case in toCleanDmd - --- Peels that multiple nestings of calls clean demand and also returns --- whether it was unsaturated (separately for strictness and usage --- see Note [Demands from unsaturated function calls] -peelManyCalls :: Int -> CleanDemand -> DmdShell -peelManyCalls n (JD { sd = str, ud = abs }) - = JD { sd = go_str n str, ud = go_abs n abs } - where - go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer - go_str 0 _ = Str () - go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) - go_str n (SCall d') = go_str (n-1) d' - go_str _ _ = Lazy - - go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least - go_abs 0 _ = Use One () -- one UCall Many in the demand - go_abs n (UCall One d') = go_abs (n-1) d' - go_abs _ _ = Use Many () - -{- -Note [Demands from unsaturated function calls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a demand transformer d1 -> d2 -> r for f. -If a sufficiently detailed demand is fed into this transformer, -e.g arising from "f x1 x2" in a strict, use-once context, -then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for -the free variable environment) and furthermore the result information r is the -one we want to use. - -An anonymous lambda is also an unsaturated function all (needs one argument, -none given), so this applies to that case as well. - -But the demand fed into f might be less than . There are a few cases: - * Not enough demand on the strictness side: - - In that case, we need to zap all strictness in the demand on arguments and - free variables. - - Furthermore, we remove CPR information. It could be left, but given the incoming - demand is not enough to evaluate so far we just do not bother. - - And finally termination information: If r says that f diverges for sure, - then this holds when the demand guarantees that two arguments are going to - be passed. If the demand is lower, we may just as well converge. - If we were tracking definite convegence, than that would still hold under - a weaker demand than expected by the demand transformer. - * Not enough demand from the usage side: The missing usage can be expanded - using UCall Many, therefore this is subsumed by the third case: - * At least one of the uses has a cardinality of Many. - - Even if f puts a One demand on any of its argument or free variables, if - we call f multiple times, we may evaluate this argument or free variable - multiple times. So forget about any occurrence of "One" in the demand. - -In dmdTransformSig, we call peelManyCalls to find out if we are in any of these -cases, and then call postProcessUnsat to reduce the demand appropriately. - -Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use -peelCallDmd, which peels only one level, but also returns the demand put on the -body of the function. --} - -peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds res, dmd) - where - fv' = fv `delVarEnv` id - -- See Note [Default demand on free variables] - dmd = lookupVarEnv fv id `orElse` defaultDmd res - -addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res - -findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _ res) id - = lookupVarEnv fv id `orElse` defaultDmd res - -{- -Note [Default demand on free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the variable is not mentioned in the environment of a demand type, -its demand is taken to be a result demand of the type. - For the stricness component, - if the result demand is a Diverges, then we use HyperStr - else we use Lazy - For the usage component, we use Absent. -So we use either absDmd or botDmd. - -Also note the equations for lubDmdResult (resp. bothDmdResult) noted there. - -Note [Always analyse in virgin pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tricky point: make sure that we analyse in the 'virgin' pass. Consider - rec { f acc x True = f (...rec { g y = ...g... }...) - f acc x False = acc } -In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. -That might mean that we analyse the sub-expression containing the -E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* -E, but just returned botType. - -Then in the *next* (non-virgin) iteration for 'f', we might analyse E -in a weaker demand, and that will trigger doing a fixpoint iteration -for g. But *because it's not the virgin pass* we won't start g's -iteration at bottom. Disaster. (This happened in $sfibToList' of -nofib/spectral/fibheaps.) - -So in the virgin pass we make sure that we do analyse the expression -at least once, to initialise its signatures. - -Note [Analyzing with lazy demand and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The insight for analyzing lambdas follows from the fact that for -strictness S = C(L). This polymorphic expansion is critical for -cardinality analysis of the following example: - -{-# NOINLINE build #-} -build g = (g (:) [], g (:) []) - -h c z = build (\x -> - let z1 = z ++ z - in if c - then \y -> x (y ++ z1) - else \y -> x (z1 ++ y)) - -One can see that `build` assigns to `g` demand . -Therefore, when analyzing the lambda `(\x -> ...)`, we -expect each lambda \y -> ... to be annotated as "one-shot" -one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a -demand . - -This is achieved by, first, converting the lazy demand L into the -strict S by the second clause of the analysis. - -Note [Analysing with absent demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we analyse an expression with demand . The "A" means -"absent", so this expression will never be needed. What should happen? -There are several wrinkles: - -* We *do* want to analyse the expression regardless. - Reason: Note [Always analyse in virgin pass] - - But we can post-process the results to ignore all the usage - demands coming back. This is done by postProcessDmdType. - -* In a previous incarnation of GHC we needed to be extra careful in the - case of an *unlifted type*, because unlifted values are evaluated - even if they are not used. Example (see #9254): - f :: (() -> (# Int#, () #)) -> () - -- Strictness signature is - -- - -- I.e. calls k, but discards first component of result - f k = case k () of (# _, r #) -> r - - g :: Int -> () - g y = f (\n -> (# case y of I# y2 -> y2, n #)) - - Here f's strictness signature says (correctly) that it calls its - argument function and ignores the first component of its result. - This is correct in the sense that it'd be fine to (say) modify the - function so that always returned 0# in the first component. - - But in function g, we *will* evaluate the 'case y of ...', because - it has type Int#. So 'y' will be evaluated. So we must record this - usage of 'y', else 'g' will say 'y' is absent, and will w/w so that - 'y' is bound to an aBSENT_ERROR thunk. - - However, the argument of toCleanDmd always satisfies the let/app - invariant; so if it is unlifted it is also okForSpeculation, and so - can be evaluated in a short finite time -- and that rules out nasty - cases like the one above. (I'm not quite sure why this was a - problem in an earlier version of GHC, but it isn't now.) - - -************************************************************************ -* * - Demand signatures -* * -************************************************************************ - -In a let-bound Id we record its strictness info. -In principle, this strictness info is a demand transformer, mapping -a demand on the Id into a DmdType, which gives - a) the free vars of the Id's value - b) the Id's arguments - c) an indication of the result of applying - the Id to its arguments - -However, in fact we store in the Id an extremely emascuated demand -transfomer, namely - - a single DmdType -(Nevertheless we dignify StrictSig as a distinct type.) - -This DmdType gives the demands unleashed by the Id when it is applied -to as many arguments as are given in by the arg demands in the DmdType. -Also see Note [Nature of result demand] for the meaning of a DmdResult in a -strictness signature. - -If an Id is applied to less arguments than its arity, it means that -the demand on the function at a call site is weaker than the vanilla -call demand, used for signature inference. Therefore we place a top -demand on all arguments. Otherwise, the demand is specified by Id's -signature. - -For example, the demand transformer described by the demand signature - StrictSig (DmdType {x -> } m) -says that when the function is applied to two arguments, it -unleashes demand on the free var x, on the first arg, -and on the second, then returning a constructor. - -If this same function is applied to one arg, all we can say is that it -uses x with , and its arg with demand . - -Note [Understanding DmdType and StrictSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand types are sound approximations of an expression's semantics relative to -the incoming demand we put the expression under. Consider the following -expression: - - \x y -> x `seq` (y, 2*x) - -Here is a table with demand types resulting from different incoming demands we -put that expression under. Note the monotonicity; a stronger incoming demand -yields a more precise demand type: - - incoming demand | demand type - ---------------------------------------------------- - | {} - | {} - | {} - -Note that in the first example, the depth of the demand type was *higher* than -the arity of the incoming call demand due to the anonymous lambda. -The converse is also possible and happens when we unleash demand signatures. -In @f x y@, the incoming call demand on f has arity 2. But if all we have is a -demand signature with depth 1 for @f@ (which we can safely unleash, see below), -the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. - -So: Demand types are elicited by putting an expression under an incoming (call) -demand, the arity of which can be lower or higher than the depth of the -resulting demand type. -In contrast, a demand signature summarises a function's semantics *without* -immediately specifying the incoming demand it was produced under. Despite StrSig -being a newtype wrapper around DmdType, it actually encodes two things: - - * The threshold (i.e., minimum arity) to unleash the signature - * A demand type that is sound to unleash when the minimum arity requirement is - met. - -Here comes the subtle part: The threshold is encoded in the wrapped demand -type's depth! So in mkStrictSigForArity we make sure to trim the list of -argument demands to the given threshold arity. Call sites will make sure that -this corresponds to the arity of the call demand that elicited the wrapped -demand type. See also Note [What are demand signatures?] in DmdAnal. - -Besides trimming argument demands, mkStrictSigForArity will also trim CPR -information if necessary. --} - --- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe --- to unleash. Better construct this through 'mkStrictSigForArity'. --- See Note [Understanding DmdType and StrictSig] -newtype StrictSig = StrictSig DmdType - deriving( Eq ) - -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty - --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig :: StrictSig -> SDoc -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res - --- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] -mkStrictSigForArity :: Arity -> DmdType -> StrictSig -mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) - -mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig -mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) - -splitStrictSig :: StrictSig -> ([Demand], DmdResult) -splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) - -increaseStrictSigArity :: Int -> StrictSig -> StrictSig --- ^ Add extra arguments to a strictness signature. --- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument --- demands and leaves CPR info intact. -increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) - | isTopDmdType dmd_ty = sig - | arity_increase == 0 = sig - | arity_increase < 0 = WARN( True, text "increaseStrictSigArity:" - <+> text "negative arity increase" - <+> ppr arity_increase ) - nopSig - | otherwise = StrictSig (DmdType env dmds' res) - where - dmds' = replicate arity_increase topDmd ++ dmds - -etaExpandStrictSig :: Arity -> StrictSig -> StrictSig --- ^ We are expanding (\x y. e) to (\x y z. e z). --- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if --- necessary, potentially destroying the signature's CPR property. -etaExpandStrictSig arity (StrictSig dmd_ty) - | arity < dmdTypeDepth dmd_ty - -- an arity decrease must zap the whole signature, because it was possibly - -- computed for a higher incoming call demand. - = nopSig - | otherwise - = StrictSig $ ensureArgs arity dmd_ty - -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty - -hasDemandEnvSig :: StrictSig -> Bool -hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) - -strictSigDmdEnv :: StrictSig -> DmdEnv -strictSigDmdEnv (StrictSig (DmdType env _ _)) = env - --- | True if the signature diverges or throws an exception -isBottomingSig :: StrictSig -> Bool -isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res - -nopSig, botSig :: StrictSig -nopSig = StrictSig nopDmdType -botSig = StrictSig botDmdType - -cprProdSig :: Arity -> StrictSig -cprProdSig arity = StrictSig (cprProdDmdType arity) - -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty - -dmdTransformSig :: StrictSig -> CleanDemand -> DmdType --- (dmdTransformSig fun_sig dmd) considers a call to a function whose --- signature is fun_sig, with demand dmd. We return the demand --- that the function places on its context (eg its args) -dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd - = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty - -- see Note [Demands from unsaturated function calls] - -dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType --- Same as dmdTransformSig but for a data constructor (worker), --- which has a special kind of demand transformer. --- If the constructor is saturated, we feed the demand on --- the result into the constructor arguments. -dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) - (JD { sd = str, ud = abs }) - | Just str_dmds <- go_str arity str - , Just abs_dmds <- go_abs arity abs - = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res - -- Must remember whether it's a product, hence con_res, not TopRes - - | otherwise -- Not saturated - = nopDmdType - where - go_str 0 dmd = splitStrProdDmd arity dmd - go_str n (SCall s') = go_str (n-1) s' - go_str n HyperStr = go_str (n-1) HyperStr - go_str _ _ = Nothing - - go_abs 0 dmd = splitUseProdDmd arity dmd - go_abs n (UCall One u') = go_abs (n-1) u' - go_abs _ _ = Nothing - -dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType --- Like dmdTransformDataConSig, we have a special demand transformer --- for dictionary selectors. If the selector is saturated (ie has one --- argument: the dictionary), we feed the demand on the result into --- the indicated dictionary component. -dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd - | (cd',defer_use) <- peelCallDmd cd - , Just jds <- splitProdDmd_maybe dict_dmd - = postProcessUnsat defer_use $ - DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes - | otherwise - = nopDmdType -- See Note [Demand transformer for a dictionary selector] - where - enhance cd old | isAbsDmd old = old - | otherwise = mkOnceUsedDmd cd -- This is the one! - -dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" - -{- -Note [Demand transformer for a dictionary selector] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' -into the appropriate field of the dictionary. What *is* the appropriate field? -We just look at the strictness signature of the class op, which will be -something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. - -For single-method classes, which are represented by newtypes the signature -of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. -That's fine: if we are doing strictness analysis we are also doing inlining, -so we'll have inlined 'op' into a cast. So we can bale out in a conservative -way, returning nopDmdType. - -It is (just.. #8329) possible to be running strictness analysis *without* -having inlined class ops from single-method classes. Suppose you are using -ghc --make; and the first module has a local -O0 flag. So you may load a class -without interface pragmas, ie (currently) without an unfolding for the class -ops. Now if a subsequent module in the --make sweep has a local -O flag -you might do strictness analysis, but there is no inlining for the class op. -This is weird, so I'm not worried about whether this optimises brilliantly; but -it should not fall over. --} - -argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] --- See Note [Computing one-shot info] -argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args - | unsaturated_call = [] - | otherwise = go arg_ds - where - unsaturated_call = arg_ds `lengthExceeds` n_val_args - - go [] = [] - go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds - - -- Avoid list tail like [ [], [], [] ] - cons [] [] = [] - cons a as = a:as - --- saturatedByOneShots n C1(C1(...)) = True, --- <=> --- there are at least n nested C1(..) calls --- See Note [Demand on the worker] in WorkWrap -saturatedByOneShots :: Int -> Demand -> Bool -saturatedByOneShots n (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go n arg_usg - _ -> False - where - go 0 _ = True - go n (UCall One u) = go (n-1) u - go _ _ = False - -argOneShots :: Demand -- depending on saturation - -> [OneShotInfo] -argOneShots (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go arg_usg - _ -> [] - where - go (UCall One u) = OneShotLam : go u - go (UCall Many u) = NoOneShotInfo : go u - go _ = [] - -{- Note [Computing one-shot info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a call - f (\pqr. e1) (\xyz. e2) e3 -where f has usage signature - C1(C(C1(U))) C1(U) U -Then argsOneShots returns a [[OneShotInfo]] of - [[OneShot,NoOneShotInfo,OneShot], [OneShot]] -The occurrence analyser propagates this one-shot infor to the -binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. --} - --- | Returns true if an application to n args --- would diverge or throw an exception --- See Note [Unsaturated applications] -appIsBottom :: StrictSig -> Int -> Bool -appIsBottom (StrictSig (DmdType _ ds res)) n - | isBotRes res = not $ lengthExceeds ds n -appIsBottom _ _ = False - -{- -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a function having bottom as its demand result is applied to a less -number of arguments than its syntactic arity, we cannot say for sure -that it is going to diverge. This is the reason why we use the -function appIsBottom, which, given a strictness signature and a number -of arguments, says conservatively if the function is going to diverge -or not. - -Zap absence or one-shot information, under control of flags - -Note [Killing usage information] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The flags -fkill-one-shot and -fkill-absence let you switch off the generation -of absence or one-shot information altogether. This is only used for performance -tests, to see how important they are. --} - -zapUsageEnvSig :: StrictSig -> StrictSig --- Remove the usage environment from the demand -zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r - -zapUsageDemand :: Demand -> Demand --- Remove the usage info, but not the strictness info, from the demand -zapUsageDemand = kill_usage $ KillFlags - { kf_abs = True - , kf_used_once = True - , kf_called_once = True - } - --- | Remove all 1* information (but not C1 information) from the demand -zapUsedOnceDemand :: Demand -> Demand -zapUsedOnceDemand = kill_usage $ KillFlags - { kf_abs = False - , kf_used_once = True - , kf_called_once = False - } - --- | Remove all 1* information (but not C1 information) from the strictness --- signature -zapUsedOnceSig :: StrictSig -> StrictSig -zapUsedOnceSig (StrictSig (DmdType env ds r)) - = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) - -killUsageDemand :: DynFlags -> Demand -> Demand --- See Note [Killing usage information] -killUsageDemand dflags dmd - | Just kfs <- killFlags dflags = kill_usage kfs dmd - | otherwise = dmd - -killUsageSig :: DynFlags -> StrictSig -> StrictSig --- See Note [Killing usage information] -killUsageSig dflags sig@(StrictSig (DmdType env ds r)) - | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r) - | otherwise = sig - -data KillFlags = KillFlags - { kf_abs :: Bool - , kf_used_once :: Bool - , kf_called_once :: Bool - } - -killFlags :: DynFlags -> Maybe KillFlags --- See Note [Killing usage information] -killFlags dflags - | not kf_abs && not kf_used_once = Nothing - | otherwise = Just (KillFlags {..}) - where - kf_abs = gopt Opt_KillAbsence dflags - kf_used_once = gopt Opt_KillOneShot dflags - kf_called_once = kf_used_once - -kill_usage :: KillFlags -> Demand -> Demand -kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} - -zap_musg :: KillFlags -> ArgUse -> ArgUse -zap_musg kfs Abs - | kf_abs kfs = useTop - | otherwise = Abs -zap_musg kfs (Use c u) - | kf_used_once kfs = Use Many (zap_usg kfs u) - | otherwise = Use c (zap_usg kfs u) - -zap_usg :: KillFlags -> UseDmd -> UseDmd -zap_usg kfs (UCall c u) - | kf_called_once kfs = UCall Many (zap_usg kfs u) - | otherwise = UCall c (zap_usg kfs u) -zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) -zap_usg _ u = u - --- If the argument is a used non-newtype dictionary, give it strict --- demand. Also split the product type & demand and recur in order to --- similarly strictify the argument's contained used non-newtype --- superclass dictionaries. We use the demand as our recursive measure --- to guarantee termination. -strictifyDictDmd :: Type -> Demand -> Demand -strictifyDictDmd ty dmd = case getUseDmd dmd of - Use n _ | - Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) - <- splitDataProductType_maybe ty, - not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary - -> seqDmd `bothDmd` -- main idea: ensure it's strict - case splitProdDmd_maybe dmd of - -- superclass cycles should not be a problem, since the demand we are - -- consuming would also have to be infinite in order for us to diverge - Nothing -> dmd -- no components have interesting demand, so stop - -- looking for superclass dicts - Just dmds - | all (not . isAbsDmd) dmds -> evalDmd - -- abstract to strict w/ arbitrary component use, since this - -- smells like reboxing; results in CBV boxed - -- - -- TODO revisit this if we ever do boxity analysis - | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of - JD {sd = s,ud = a} -> JD (Str s) (Use n a) - -- TODO could optimize with an aborting variant of zipWith since - -- the superclass dicts are always a prefix - _ -> dmd -- unused or not a dictionary - -strictifyDmd :: Demand -> Demand -strictifyDmd dmd@(JD { sd = str }) - = dmd { sd = str `bothArgStr` Str HeadStr } - -{- -Note [HyperStr and Use demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The information "HyperStr" needs to be in the strictness signature, and not in -the demand signature, because we still want to know about the demand on things. Consider - - f (x,y) True = error (show x) - f (x,y) False = x+1 - -The signature of f should be m. If we were not -distinguishing the uses on x and y in the True case, we could either not figure -out how deeply we can unpack x, or that we do not have to pass y. - - -************************************************************************ -* * - Serialisation -* * -************************************************************************ --} - -instance Binary StrDmd where - put_ bh HyperStr = do putByte bh 0 - put_ bh HeadStr = do putByte bh 1 - put_ bh (SCall s) = do putByte bh 2 - put_ bh s - put_ bh (SProd sx) = do putByte bh 3 - put_ bh sx - get bh = do - h <- getByte bh - case h of - 0 -> do return HyperStr - 1 -> do return HeadStr - 2 -> do s <- get bh - return (SCall s) - _ -> do sx <- get bh - return (SProd sx) - -instance Binary ArgStr where - put_ bh Lazy = do - putByte bh 0 - put_ bh (Str s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return Lazy - _ -> do s <- get bh - return $ Str s - -instance Binary Count where - put_ bh One = do putByte bh 0 - put_ bh Many = do putByte bh 1 - - get bh = do h <- getByte bh - case h of - 0 -> return One - _ -> return Many - -instance Binary ArgUse where - put_ bh Abs = do - putByte bh 0 - put_ bh (Use c u) = do - putByte bh 1 - put_ bh c - put_ bh u - - get bh = do - h <- getByte bh - case h of - 0 -> return Abs - _ -> do c <- get bh - u <- get bh - return $ Use c u - -instance Binary UseDmd where - put_ bh Used = do - putByte bh 0 - put_ bh UHead = do - putByte bh 1 - put_ bh (UCall c u) = do - putByte bh 2 - put_ bh c - put_ bh u - put_ bh (UProd ux) = do - putByte bh 3 - put_ bh ux - - get bh = do - h <- getByte bh - case h of - 0 -> return $ Used - 1 -> return $ UHead - 2 -> do c <- get bh - u <- get bh - return (UCall c u) - _ -> do ux <- get bh - return (UProd ux) - -instance (Binary s, Binary u) => Binary (JointDmd s u) where - put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y - get bh = do - x <- get bh - y <- get bh - return $ JD { sd = x, ud = y } - -instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) - -instance Binary DmdType where - -- Ignore DmdEnv when spitting out the DmdType - put_ bh (DmdType _ ds dr) - = do put_ bh ds - put_ bh dr - get bh - = do ds <- get bh - dr <- get bh - return (DmdType emptyDmdEnv ds dr) - -instance Binary DmdResult where - put_ bh (Dunno c) = do { putByte bh 0; put_ bh c } - put_ bh Diverges = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> do { c <- get bh; return (Dunno c) } - _ -> return Diverges } - -instance Binary CPRResult where - put_ bh (RetSum n) = do { putByte bh 0; put_ bh n } - put_ bh RetProd = putByte bh 1 - put_ bh NoCPR = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; return (RetSum n) } - 1 -> return RetProd - _ -> return NoCPR diff --git a/basicTypes/FieldLabel.hs b/basicTypes/FieldLabel.hs deleted file mode 100644 --- a/basicTypes/FieldLabel.hs +++ /dev/null @@ -1,130 +0,0 @@ -{- -% -% (c) Adam Gundry 2013-2015 -% - -This module defines the representation of FieldLabels as stored in -TyCons. As well as a selector name, these have some extra structure -to support the DuplicateRecordFields extension. - -In the normal case (with NoDuplicateRecordFields), a datatype like - - data T = MkT { foo :: Int } - -has - - FieldLabel { flLabel = "foo" - , flIsOverloaded = False - , flSelector = foo }. - -In particular, the Name of the selector has the same string -representation as the label. If DuplicateRecordFields -is enabled, however, the same declaration instead gives - - FieldLabel { flLabel = "foo" - , flIsOverloaded = True - , flSelector = $sel:foo:MkT }. - -Now the name of the selector ($sel:foo:MkT) does not match the label of -the field (foo). We must be careful not to show the selector name to -the user! The point of mangling the selector name is to allow a -module to define the same field label in different datatypes: - - data T = MkT { foo :: Int } - data U = MkU { foo :: Bool } - -Now there will be two FieldLabel values for 'foo', one in T and one in -U. They share the same label (FieldLabelString), but the selector -functions differ. - -See also Note [Representing fields in AvailInfo] in Avail. - -Note [Why selector names include data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -As explained above, a selector name includes the name of the first -data constructor in the type, so that the same label can appear -multiple times in the same module. (This is irrespective of whether -the first constructor has that field, for simplicity.) - -We use a data constructor name, rather than the type constructor name, -because data family instances do not have a representation type -constructor name generated until relatively late in the typechecking -process. - -Of course, datatypes with no constructors cannot have any fields. - --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} - -module FieldLabel ( FieldLabelString - , FieldLabelEnv - , FieldLbl(..) - , FieldLabel - , mkFieldLabelOccs - ) where - -import GhcPrelude - -import OccName -import Name - -import FastString -import FastStringEnv -import Outputable -import Binary - -import Data.Data - --- | Field labels are just represented as strings; --- they are not necessarily unique (even within a module) -type FieldLabelString = FastString - --- | A map from labels to all the auxiliary information -type FieldLabelEnv = DFastStringEnv FieldLabel - - -type FieldLabel = FieldLbl Name - --- | Fields in an algebraic record type -data FieldLbl a = FieldLabel { - flLabel :: FieldLabelString, -- ^ User-visible label of the field - flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on - -- in the defining module for this datatype? - flSelector :: a -- ^ Record selector function - } - deriving (Eq, Functor, Foldable, Traversable) -deriving instance Data a => Data (FieldLbl a) - -instance Outputable a => Outputable (FieldLbl a) where - ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) - -instance Binary a => Binary (FieldLbl a) where - put_ bh (FieldLabel aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - ad <- get bh - return (FieldLabel ab ac ad) - - --- | Record selector OccNames are built from the underlying field name --- and the name of the first data constructor of the type, to support --- duplicate record field names. --- See Note [Why selector names include data constructors]. -mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName -mkFieldLabelOccs lbl dc is_overloaded - = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = sel_occ } - where - str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc - sel_occ | is_overloaded = mkRecFldSelOcc str - | otherwise = mkVarOccFS lbl diff --git a/basicTypes/Id.hs b/basicTypes/Id.hs deleted file mode 100644 --- a/basicTypes/Id.hs +++ /dev/null @@ -1,966 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Id]{@Ids@: Value and constructor identifiers} --} - -{-# LANGUAGE CPP #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional --- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that --- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either --- be global or local, see "Var#globalvslocal" --- --- * 'Var.Var': see "Var#name_types" - -module Id ( - -- * The main types - Var, Id, isId, - - -- * In and Out variants - InVar, InId, - OutVar, OutId, - - -- ** Simple construction - mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, - mkLocalIdOrCoVarWithInfo, - mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, - mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, - mkUserLocal, mkUserLocalOrCoVar, - mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, - - -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, - recordSelectorTyCon, - - -- ** Modifying an Id - setIdName, setIdUnique, Id.setIdType, - setIdExported, setIdNotExported, - globaliseId, localiseId, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, - zapIdUsedOnceInfo, zapIdTailCallInfo, - zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, - transferPolyIdInfo, - - -- ** Predicates on Ids - isImplicitId, isDeadBinder, - isStrictId, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, isNaughtyRecordSelector, - isPatSynRecordSelector, - isDataConRecordSelector, - isClassOpId_maybe, isDFunId, - isPrimOpId, isPrimOpId_maybe, - isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, - isDataConWrapId, isDataConWrapId_maybe, - isDataConId_maybe, - idDataCon, - isConLikeId, isBottomingId, idIsFrom, - hasNoBinding, - - -- ** Join variables - JoinId, isJoinId, isJoinId_maybe, idJoinArity, - asJoinId, asJoinId_maybe, zapJoinId, - - -- ** Inline pragma stuff - idInlinePragma, setInlinePragma, modifyInlinePragma, - idInlineActivation, setInlineActivation, idRuleMatchInfo, - - -- ** One-shot lambdas - isOneShotBndr, isProbablyOneShotLambda, - setOneShotLambda, clearOneShotLambda, - updOneShotInfo, setIdOneShotInfo, - isStateHackType, stateHackOneShot, typeOneShot, - - -- ** Reading 'IdInfo' fields - idArity, - idCallArity, idFunRepArity, - idUnfolding, realIdUnfolding, - idSpecialisation, idCoreRules, idHasRules, - idCafInfo, - idOneShotInfo, idStateHackOneShotInfo, - idOccInfo, - isNeverLevPolyId, - - -- ** Writing 'IdInfo' fields - setIdUnfolding, setCaseBndrEvald, - setIdArity, - setIdCallArity, - - setIdSpecialisation, - setIdCafInfo, - setIdOccInfo, zapIdOccInfo, - - setIdDemandInfo, - setIdStrictness, - - idDemandInfo, - idStrictness, - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, - isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) - -import IdInfo -import BasicTypes - --- Imported and re-exported -import Var( Id, CoVar, JoinId, - InId, InVar, - OutId, OutVar, - idInfo, idDetails, setIdDetails, globaliseId, varType, - isId, isLocalId, isGlobalId, isExportedId ) -import qualified Var - -import Type -import RepType -import TysPrim -import DataCon -import Demand -import Name -import Module -import Class -import {-# SOURCE #-} PrimOp (PrimOp) -import ForeignCall -import Maybes -import SrcLoc -import Outputable -import Unique -import UniqSupply -import FastString -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setIdUnfolding`, - `setIdArity`, - `setIdCallArity`, - `setIdOccInfo`, - `setIdOneShotInfo`, - - `setIdSpecialisation`, - `setInlinePragma`, - `setInlineActivation`, - `idCafInfo`, - - `setIdDemandInfo`, - `setIdStrictness`, - - `asJoinId`, - `asJoinId_maybe` - -{- -************************************************************************ -* * -\subsection{Basic Id manipulation} -* * -************************************************************************ --} - -idName :: Id -> Name -idName = Var.varName - -idUnique :: Id -> Unique -idUnique = Var.varUnique - -idType :: Id -> Kind -idType = Var.varType - -setIdName :: Id -> Name -> Id -setIdName = Var.setVarName - -setIdUnique :: Id -> Unique -> Id -setIdUnique = Var.setVarUnique - --- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and --- reduce space usage -setIdType :: Id -> Type -> Id -setIdType id ty = seqType ty `seq` Var.setVarType id ty - -setIdExported :: Id -> Id -setIdExported = Var.setIdExported - -setIdNotExported :: Id -> Id -setIdNotExported = Var.setIdNotExported - -localiseId :: Id -> Id --- Make an Id with the same unique and type as the --- incoming Id, but with an *Internal* Name and *LocalId* flavour -localiseId id - | ASSERT( isId id ) isLocalId id && isInternalName name - = id - | otherwise - = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) - where - name = idName id - -lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo = Var.lazySetIdInfo - -setIdInfo :: Id -> IdInfo -> Id -setIdInfo id info = info `seq` (lazySetIdInfo id info) - -- Try to avoid space leaks by seq'ing - -modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id -modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) - --- maybeModifyIdInfo tries to avoid unnecessary thrashing -maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id -maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info -maybeModifyIdInfo Nothing id = id - -{- -************************************************************************ -* * -\subsection{Simple Id construction} -* * -************************************************************************ - -Absolutely all Ids are made by mkId. It is just like Var.mkId, -but in addition it pins free-tyvar-info onto the Id's type, -where it can easily be found. - -Note [Free type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we cached the free type variables of the type of an Id -at the root of the type in a TyNote. The idea was to avoid repeating -the free-type-variable calculation. But it turned out to slow down -the compiler overall. I don't quite know why; perhaps finding free -type variables of an Id isn't all that common whereas applying a -substitution (which changes the free type variables) is more common. -Anyway, we removed it in March 2008. --} - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalId = Var.mkGlobalVar - --- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id -mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo - --- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkLocalId :: Name -> Type -> Id -mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo - -- It's tempting to ASSERT( not (isCoVarType ty) ), but don't. Sometimes, - -- the type is a panic. (Search invented_id) - --- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar -mkLocalCoVar name ty - = ASSERT( isCoVarType ty ) - Var.mkLocalVar CoVarId name ty vanillaIdInfo - --- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Type -> Id -mkLocalIdOrCoVar name ty - | isCoVarType ty = mkLocalCoVar name ty - | otherwise = mkLocalId name ty - --- | Make a local id, with the IdDetails set to CoVarId if the type indicates --- so. -mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id -mkLocalIdOrCoVarWithInfo name ty info - = Var.mkLocalVar details name ty info - where - details | isCoVarType ty = CoVarId - | otherwise = VanillaId - - -- proper ids only; no covars! -mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id -mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info - -- Note [Free type variables] - --- | Create a local 'Id' that is marked as exported. --- This prevents things attached to it from being removed as dead code. --- See Note [Exported LocalIds] -mkExportedLocalId :: IdDetails -> Name -> Type -> Id -mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo - -- Note [Free type variables] - -mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo - -- Note [Free type variables] - - --- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") --- that are created by the compiler out of thin air -mkSysLocal :: FastString -> Unique -> Type -> Id -mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkSystemVarName uniq fs) ty - --- | Like 'mkSysLocal', but checks to see if we have a covar type -mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id -mkSysLocalOrCoVar fs uniq ty - = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty - -mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) - -mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalOrCoVarM fs ty - = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) - --- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize -mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkInternalName uniq occ loc) ty - --- | Like 'mkUserLocal', but checks if we have a coercion type -mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocalOrCoVar occ uniq ty loc - = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty - -{- -Make some local @Ids@ for a template @CoreExpr@. These have bogus -@Uniques@, but that's OK because the templates are supposed to be -instantiated before use. --} - --- | Workers get local names. "CoreTidy" will externalise these if necessary -mkWorkerId :: Unique -> Id -> Type -> Id -mkWorkerId uniq unwrkr ty - = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty - --- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings -mkTemplateLocal :: Int -> Type -> Id -mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty - --- | Create a template local for a series of types -mkTemplateLocals :: [Type] -> [Id] -mkTemplateLocals = mkTemplateLocalsNum 1 - --- | Create a template local for a series of type, but start from a specified template local -mkTemplateLocalsNum :: Int -> [Type] -> [Id] -mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys - -{- Note [Exported LocalIds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use mkExportedLocalId for things like - - Dictionary functions (DFunId) - - Wrapper and matcher Ids for pattern synonyms - - Default methods for classes - - Pattern-synonym matcher and builder Ids - - etc - -They marked as "exported" in the sense that they should be kept alive -even if apparently unused in other bindings, and not dropped as dead -code by the occurrence analyser. (But "exported" here does not mean -"brought into lexical scope by an import declaration". Indeed these -things are always internal Ids that the user never sees.) - -It's very important that they are *LocalIds*, not GlobalIds, for lots -of reasons: - - * We want to treat them as free variables for the purpose of - dependency analysis (e.g. CoreFVs.exprFreeVars). - - * Look them up in the current substitution when we come across - occurrences of them (in Subst.lookupIdSubst). Lacking this we - can get an out-of-date unfolding, which can in turn make the - simplifier go into an infinite loop (#9857) - - * Ensure that for dfuns that the specialiser does not float dict uses - above their defns, which would prevent good simplifications happening. - - * The strictness analyser treats a occurrence of a GlobalId as - imported and assumes it contains strictness in its IdInfo, which - isn't true if the thing is bound in the same module as the - occurrence. - -In CoreTidy we must make all these LocalIds into GlobalIds, so that in -importing modules (in --make mode) we treat them as properly global. -That is what is happening in, say tidy_insts in TidyPgm. - -************************************************************************ -* * -\subsection{Special Ids} -* * -************************************************************************ --} - --- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. -recordSelectorTyCon :: Id -> RecSelParent -recordSelectorTyCon id - = case Var.idDetails id of - RecSelId { sel_tycon = parent } -> parent - _ -> panic "recordSelectorTyCon" - - -isRecordSelector :: Id -> Bool -isNaughtyRecordSelector :: Id -> Bool -isPatSynRecordSelector :: Id -> Bool -isDataConRecordSelector :: Id -> Bool -isPrimOpId :: Id -> Bool -isFCallId :: Id -> Bool -isDataConWorkId :: Id -> Bool -isDataConWrapId :: Id -> Bool -isDFunId :: Id -> Bool - -isClassOpId_maybe :: Id -> Maybe Class -isPrimOpId_maybe :: Id -> Maybe PrimOp -isFCallId_maybe :: Id -> Maybe ForeignCall -isDataConWorkId_maybe :: Id -> Maybe DataCon -isDataConWrapId_maybe :: Id -> Maybe DataCon - -isRecordSelector id = case Var.idDetails id of - RecSelId {} -> True - _ -> False - -isDataConRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelData _} -> True - _ -> False - -isPatSynRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelPatSyn _} -> True - _ -> False - -isNaughtyRecordSelector id = case Var.idDetails id of - RecSelId { sel_naughty = n } -> n - _ -> False - -isClassOpId_maybe id = case Var.idDetails id of - ClassOpId cls -> Just cls - _other -> Nothing - -isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False - -isDFunId id = case Var.idDetails id of - DFunId {} -> True - _ -> False - -isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing - -isFCallId id = case Var.idDetails id of - FCallId _ -> True - _ -> False - -isFCallId_maybe id = case Var.idDetails id of - FCallId call -> Just call - _ -> Nothing - -isDataConWorkId id = case Var.idDetails id of - DataConWorkId _ -> True - _ -> False - -isDataConWorkId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - _ -> Nothing - -isDataConWrapId id = case Var.idDetails id of - DataConWrapId _ -> True - _ -> False - -isDataConWrapId_maybe id = case Var.idDetails id of - DataConWrapId con -> Just con - _ -> Nothing - -isDataConId_maybe :: Id -> Maybe DataCon -isDataConId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - DataConWrapId con -> Just con - _ -> Nothing - -isJoinId :: Var -> Bool --- It is convenient in SetLevels.lvlMFE to apply isJoinId --- to the free vars of an expression, so it's convenient --- if it returns False for type variables -isJoinId id - | isId id = case Var.idDetails id of - JoinId {} -> True - _ -> False - | otherwise = False - -isJoinId_maybe :: Var -> Maybe JoinArity -isJoinId_maybe id - | isId id = ASSERT2( isId id, ppr id ) - case Var.idDetails id of - JoinId arity -> Just arity - _ -> Nothing - | otherwise = Nothing - -idDataCon :: Id -> DataCon --- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. --- --- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker -idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) - -hasNoBinding :: Id -> Bool --- ^ Returns @True@ of an 'Id' which may not have a --- binding, even though it is defined in this module. - --- Data constructor workers used to be things of this kind, but --- they aren't any more. Instead, we inject a binding for --- them at the CorePrep stage. --- --- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs. --- for the history of this. --- --- Note that CorePrep currently eta expands things no-binding things and this --- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things --- in CorePrep] in CorePrep for details. --- --- EXCEPT: unboxed tuples, which definitely have no binding -hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs - FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc - _ -> isCompulsoryUnfolding (idUnfolding id) - -- See Note [Levity-polymorphic Ids] - -isImplicitId :: Id -> Bool --- ^ 'isImplicitId' tells whether an 'Id's info is implied by other --- declarations, so we don't need to put its signature in an interface --- file, even if it's mentioned in some other interface unfolding. -isImplicitId id - = case Var.idDetails id of - FCallId {} -> True - ClassOpId {} -> True - PrimOpId {} -> True - DataConWorkId {} -> True - DataConWrapId {} -> True - -- These are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file. - -- The dfun id is not an implicit Id; it must *not* be omitted, because - -- it carries version info for the instance decl - _ -> False - -idIsFrom :: Module -> Id -> Bool -idIsFrom mod id = nameIsLocalOrFrom mod (idName id) - -{- Note [Levity-polymorphic Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some levity-polymorphic Ids must be applied and and inlined, not left -un-saturated. Example: - unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b - -This has a compulsory unfolding because we can't lambda-bind those -arguments. But the compulsory unfolding may leave levity-polymorphic -lambdas if it is not applied to enough arguments; e.g. (#14561) - bad :: forall (a :: TYPE r). a -> a - bad = unsafeCoerce# - -The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop. -And we want that magic to apply to levity-polymorphic compulsory-inline things. -The easiest way to do this is for hasNoBinding to return True of all things -that have compulsory unfolding. Some Ids with a compulsory unfolding also -have a binding, but it does not harm to say they don't here, and its a very -simple way to fix #14561. --} - -isDeadBinder :: Id -> Bool -isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) - | otherwise = False -- TyVars count as not dead - -{- -************************************************************************ -* * - Join variables -* * -************************************************************************ --} - -idJoinArity :: JoinId -> JoinArity -idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) - -asJoinId :: Id -> JoinArity -> JoinId -asJoinId id arity = WARN(not (isLocalId id), - text "global id being marked as join var:" <+> ppr id) - WARN(not (is_vanilla_or_join id), - ppr id <+> pprIdDetails (idDetails id)) - id `setIdDetails` JoinId arity - where - is_vanilla_or_join id = case Var.idDetails id of - VanillaId -> True - JoinId {} -> True - _ -> False - -zapJoinId :: Id -> Id --- May be a regular id already -zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) - -- Core Lint may complain if still marked - -- as AlwaysTailCalled - | otherwise = jid - -asJoinId_maybe :: Id -> Maybe JoinArity -> Id -asJoinId_maybe id (Just arity) = asJoinId id arity -asJoinId_maybe id Nothing = zapJoinId id - -{- -************************************************************************ -* * -\subsection{IdInfo stuff} -* * -************************************************************************ --} - - --------------------------------- - -- ARITY -idArity :: Id -> Arity -idArity id = arityInfo (idInfo id) - -setIdArity :: Id -> Arity -> Id -setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id - -idCallArity :: Id -> Arity -idCallArity id = callArityInfo (idInfo id) - -setIdCallArity :: Id -> Arity -> Id -setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id - -idFunRepArity :: Id -> RepArity -idFunRepArity x = countFunRepArgs (idArity x) (idType x) - --- | Returns true if an application to n args would diverge -isBottomingId :: Var -> Bool -isBottomingId v - | isId v = isBottomingSig (idStrictness v) - | otherwise = False - --- | Accesses the 'Id''s 'strictnessInfo'. -idStrictness :: Id -> StrictSig -idStrictness id = strictnessInfo (idInfo id) - -setIdStrictness :: Id -> StrictSig -> Id -setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id - -zapIdStrictness :: Id -> Id -zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id - --- | This predicate says whether the 'Id' has a strict demand placed on it or --- has a type such that it can always be evaluated strictly (i.e an --- unlifted type, as of GHC 7.6). We need to --- check separately whether the 'Id' has a so-called \"strict type\" because if --- the demand for the given @id@ hasn't been computed yet but @id@ has a strict --- type, we still want @isStrictId id@ to be @True@. -isStrictId :: Id -> Bool -isStrictId id - = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - not (isJoinId id) && ( - (isStrictType (idType id)) || - -- Take the best of both strictnesses - old and new - (isStrictDmd (idDemandInfo id)) - ) - - --------------------------------- - -- UNFOLDING -idUnfolding :: Id -> Unfolding --- Do not expose the unfolding of a loop breaker! -idUnfolding id - | isStrongLoopBreaker (occInfo info) = NoUnfolding - | otherwise = unfoldingInfo info - where - info = idInfo id - -realIdUnfolding :: Id -> Unfolding --- Expose the unfolding if there is one, including for loop breakers -realIdUnfolding id = unfoldingInfo (idInfo id) - -setIdUnfolding :: Id -> Unfolding -> Id -setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id - -idDemandInfo :: Id -> Demand -idDemandInfo id = demandInfo (idInfo id) - -setIdDemandInfo :: Id -> Demand -> Id -setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id - -setCaseBndrEvald :: StrictnessMark -> Id -> Id --- Used for variables bound by a case expressions, both the case-binder --- itself, and any pattern-bound variables that are argument of a --- strict constructor. It just marks the variable as already-evaluated, --- so that (for example) a subsequent 'seq' can be dropped -setCaseBndrEvald str id - | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding - | otherwise = id - - --------------------------------- - -- SPECIALISATION - --- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs - -idSpecialisation :: Id -> RuleInfo -idSpecialisation id = ruleInfo (idInfo id) - -idCoreRules :: Id -> [CoreRule] -idCoreRules id = ruleInfoRules (idSpecialisation id) - -idHasRules :: Id -> Bool -idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) - -setIdSpecialisation :: Id -> RuleInfo -> Id -setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id - - --------------------------------- - -- CAF INFO -idCafInfo :: Id -> CafInfo -idCafInfo id = cafInfo (idInfo id) - -setIdCafInfo :: Id -> CafInfo -> Id -setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id - - --------------------------------- - -- Occurrence INFO -idOccInfo :: Id -> OccInfo -idOccInfo id = occInfo (idInfo id) - -setIdOccInfo :: Id -> OccInfo -> Id -setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id - -zapIdOccInfo :: Id -> Id -zapIdOccInfo b = b `setIdOccInfo` noOccInfo - -{- - --------------------------------- - -- INLINING -The inline pragma tells us to be very keen to inline this Id, but it's still -OK not to if optimisation is switched off. --} - -idInlinePragma :: Id -> InlinePragma -idInlinePragma id = inlinePragInfo (idInfo id) - -setInlinePragma :: Id -> InlinePragma -> Id -setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id - -modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id -modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id - -idInlineActivation :: Id -> Activation -idInlineActivation id = inlinePragmaActivation (idInlinePragma id) - -setInlineActivation :: Id -> Activation -> Id -setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) - -idRuleMatchInfo :: Id -> RuleMatchInfo -idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) - -isConLikeId :: Id -> Bool -isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) - -{- - --------------------------------- - -- ONE-SHOT LAMBDAS --} - -idOneShotInfo :: Id -> OneShotInfo -idOneShotInfo id = oneShotInfo (idInfo id) - --- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account --- See Note [The state-transformer hack] in CoreArity -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = stateHackOneShot - | otherwise = idOneShotInfo id - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- This one is the "business end", called externally. --- It works on type variables as well as Ids, returning True --- Its main purpose is to encapsulate the Horrible State Hack --- See Note [The state-transformer hack] in CoreArity -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - --- | Should we apply the state hack to values of this 'Type'? -stateHackOneShot :: OneShotInfo -stateHackOneShot = OneShotLam - -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = stateHackOneShot - | otherwise = NoOneShotInfo - -isStateHackType :: Type -> Bool -isStateHackType ty - | hasNoStateHack unsafeGlobalDynFlags - = False - | otherwise - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.hs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - -isProbablyOneShotLambda :: Id -> Bool -isProbablyOneShotLambda id = case idStateHackOneShotInfo id of - OneShotLam -> True - NoOneShotInfo -> False - -setOneShotLambda :: Id -> Id -setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id - -clearOneShotLambda :: Id -> Id -clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id - -setIdOneShotInfo :: Id -> OneShotInfo -> Id -setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id - -updOneShotInfo :: Id -> OneShotInfo -> Id --- Combine the info in the Id with new info -updOneShotInfo id one_shot - | do_upd = setIdOneShotInfo id one_shot - | otherwise = id - where - do_upd = case (idOneShotInfo id, one_shot) of - (NoOneShotInfo, _) -> True - (OneShotLam, _) -> False - --- The OneShotLambda functions simply fiddle with the IdInfo flag --- But watch out: this may change the type of something else --- f = \x -> e --- If we change the one-shot-ness of x, f's type changes - -zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id -zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id - -zapLamIdInfo :: Id -> Id -zapLamIdInfo = zapInfo zapLamInfo - -zapFragileIdInfo :: Id -> Id -zapFragileIdInfo = zapInfo zapFragileInfo - -zapIdDemandInfo :: Id -> Id -zapIdDemandInfo = zapInfo zapDemandInfo - -zapIdUsageInfo :: Id -> Id -zapIdUsageInfo = zapInfo zapUsageInfo - -zapIdUsageEnvInfo :: Id -> Id -zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo - -zapIdUsedOnceInfo :: Id -> Id -zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo - -zapIdTailCallInfo :: Id -> Id -zapIdTailCallInfo = zapInfo zapTailCallInfo - -zapStableUnfolding :: Id -> Id -zapStableUnfolding id - | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding - | otherwise = id - -{- -Note [transferPolyIdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This transfer is used in three places: - FloatOut (long-distance let-floating) - SimplUtils.abstractFloats (short-distance let-floating) - StgLiftLams (selectively lambda-lift local functions to top-level) - -Consider the short-distance let-floating: - - f = /\a. let g = rhs in ... - -Then if we float thus - - g' = /\a. rhs - f = /\a. ...[g' a/g].... - -we *do not* want to lose g's - * strictness information - * arity - * inline pragma (though that is bit more debatable) - * occurrence info - -Mostly this is just an optimisation, but it's *vital* to -transfer the occurrence info. Consider - - NonRec { f = /\a. let Rec { g* = ..g.. } in ... } - -where the '*' means 'LoopBreaker'. Then if we float we must get - - Rec { g'* = /\a. ...(g' a)... } - NonRec { f = /\a. ...[g' a/g]....} - -where g' is also marked as LoopBreaker. If not, terrible things -can happen if we re-simplify the binding (and the Simplifier does -sometimes simplify a term twice); see #4345. - -It's not so simple to retain - * worker info - * rules -so we simply discard those. Sooner or later this may bite us. - -If we abstract wrt one or more *value* binders, we must modify the -arity and strictness info before transferring it. E.g. - f = \x. e ---> - g' = \y. \x. e - + substitute (g' y) for g -Notice that g' has an arity one more than the original g --} - -transferPolyIdInfo :: Id -- Original Id - -> [Var] -- Abstract wrt these variables - -> Id -- New Id - -> Id -transferPolyIdInfo old_id abstract_wrt new_id - = modifyIdInfo transfer new_id - where - arity_increase = count isId abstract_wrt -- Arity increases by the - -- number of value binders - - old_info = idInfo old_id - old_arity = arityInfo old_info - old_inline_prag = inlinePragInfo old_info - old_occ_info = occInfo old_info - new_arity = old_arity + arity_increase - new_occ_info = zapOccTailCallInfo old_occ_info - - old_strictness = strictnessInfo old_info - new_strictness = increaseStrictSigArity arity_increase old_strictness - - transfer new_info = new_info `setArityInfo` new_arity - `setInlinePragInfo` old_inline_prag - `setOccInfo` new_occ_info - `setStrictnessInfo` new_strictness - -isNeverLevPolyId :: Id -> Bool -isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/basicTypes/IdInfo.hs b/basicTypes/IdInfo.hs deleted file mode 100644 --- a/basicTypes/IdInfo.hs +++ /dev/null @@ -1,641 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} - -(And a pretty good illustration of quite a few things wrong with -Haskell. [WDP 94/11]) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module IdInfo ( - -- * The IdDetails type - IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, - JoinArity, isJoinIdDetails_maybe, - RecSelParent(..), - - -- * The IdInfo type - IdInfo, -- Abstract - vanillaIdInfo, noCafIdInfo, - - -- ** The OneShotInfo type - OneShotInfo(..), - oneShotInfo, noOneShotInfo, hasNoOneShotInfo, - setOneShotInfo, - - -- ** Zapping various forms of Info - zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, - zapTailCallInfo, zapCallArityInfo, zapUnfolding, - - -- ** The ArityInfo type - ArityInfo, - unknownArity, - arityInfo, setArityInfo, ppArityInfo, - - callArityInfo, setCallArityInfo, - - -- ** Demand and strictness Info - strictnessInfo, setStrictnessInfo, - demandInfo, setDemandInfo, pprStrictness, - - -- ** Unfolding Info - unfoldingInfo, setUnfoldingInfo, - - -- ** The InlinePragInfo type - InlinePragInfo, - inlinePragInfo, setInlinePragInfo, - - -- ** The OccInfo type - OccInfo(..), - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, - occInfo, setOccInfo, - - InsideLam, BranchCount, - insideLam, notInsideLam, oneBranch, - - TailCallInfo(..), - tailCallInfo, isAlwaysTailCalled, - - -- ** The RuleInfo type - RuleInfo(..), - emptyRuleInfo, - isEmptyRuleInfo, ruleInfoFreeVars, - ruleInfoRules, setRuleInfoHead, - ruleInfo, setRuleInfo, - - -- ** The CAFInfo type - CafInfo(..), - ppCafInfo, mayHaveCafRefs, - cafInfo, setCafInfo, - - -- ** Tick-box Info - TickBoxOp(..), TickBoxId, - - -- ** Levity info - LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, - isNeverLevPolyIdInfo - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn - -import Class -import {-# SOURCE #-} PrimOp (PrimOp) -import Name -import VarSet -import BasicTypes -import DataCon -import TyCon -import PatSyn -import Type -import ForeignCall -import Outputable -import Module -import Demand -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setRuleInfo`, - `setArityInfo`, - `setInlinePragInfo`, - `setUnfoldingInfo`, - `setOneShotInfo`, - `setOccInfo`, - `setCafInfo`, - `setStrictnessInfo`, - `setDemandInfo`, - `setNeverLevPoly`, - `setLevityInfoWithType` - -{- -************************************************************************ -* * - IdDetails -* * -************************************************************************ --} - --- | Identifier Details --- --- The 'IdDetails' of an 'Id' give stable, and necessary, --- information about the Id. -data IdDetails - = VanillaId - - -- | The 'Id' for a record selector - | RecSelId - { sel_tycon :: RecSelParent - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: - -- data T = forall a. MkT { x :: a } - } -- See Note [Naughty record selectors] in TcTyClsDecls - - | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ - | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ - - -- [the only reasons we need to know is so that - -- a) to support isImplicitId - -- b) when desugaring a RecordCon we can get - -- from the Id back to the data con] - | ClassOpId Class -- ^ The 'Id' is a superclass selector, - -- or class operation of a class - - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator - | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. - -- Type will be simple: no type families, newtypes, etc - - | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - - | DFunId Bool -- ^ A dictionary function. - -- Bool = True <=> the class has only one method, so may be - -- implemented with a newtype, so it might be bad - -- to be strict on this dictionary - - | CoVarId -- ^ A coercion variable - -- This only covers /un-lifted/ coercions, of type - -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants - | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments - -- Note [Join points] in CoreSyn - --- | Recursive Selector Parent -data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq - -- Either `TyCon` or `PatSyn` depending - -- on the origin of the record selector. - -- For a data type family, this is the - -- /instance/ 'TyCon' not the family 'TyCon' - -instance Outputable RecSelParent where - ppr p = case p of - RecSelData ty_con -> ppr ty_con - RecSelPatSyn ps -> ppr ps - --- | Just a synonym for 'CoVarId'. Written separately so it can be --- exported in the hs-boot file. -coVarDetails :: IdDetails -coVarDetails = CoVarId - --- | Check if an 'IdDetails' says 'CoVarId'. -isCoVarDetails :: IdDetails -> Bool -isCoVarDetails CoVarId = True -isCoVarDetails _ = False - -isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity -isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity -isJoinIdDetails_maybe _ = Nothing - -instance Outputable IdDetails where - ppr = pprIdDetails - -pprIdDetails :: IdDetails -> SDoc -pprIdDetails VanillaId = empty -pprIdDetails other = brackets (pp other) - where - pp VanillaId = panic "pprIdDetails" - pp (DataConWorkId _) = text "DataCon" - pp (DataConWrapId _) = text "DataConWrapper" - pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" - pp (FCallId _) = text "ForeignCall" - pp (TickBoxOpId _) = text "TickBoxOp" - pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") - pp (RecSelId { sel_naughty = is_naughty }) - = brackets $ text "RecSel" <> - ppWhen is_naughty (text "(naughty)") - pp CoVarId = text "CoVarId" - pp (JoinId arity) = text "JoinId" <> parens (int arity) - -{- -************************************************************************ -* * -\subsection{The main IdInfo type} -* * -************************************************************************ --} - --- | Identifier Information --- --- An 'IdInfo' gives /optional/ information about an 'Id'. If --- present it never lies, but it may not be present, in which case there --- is always a conservative assumption which can be made. --- --- Two 'Id's may have different info even though they have the same --- 'Unique' (and are hence the same 'Id'); for example, one might lack --- the properties attached to the other. --- --- Most of the 'IdInfo' gives information about the value, or definition, of --- the 'Id', independent of its usage. Exceptions to this --- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. --- --- Performance note: when we update 'IdInfo', we have to reallocate this --- entire record, so it is a good idea not to let this data structure get --- too big. -data IdInfo - = IdInfo { - arityInfo :: !ArityInfo, - -- ^ 'Id' arity, as computed by 'CoreArity'. Specifies how many - -- arguments this 'Id' has to be applied to before it doesn any - -- meaningful work. - ruleInfo :: RuleInfo, - -- ^ Specialisations of the 'Id's function which exist. - -- See Note [Specialisations and RULES in IdInfo] - unfoldingInfo :: Unfolding, - -- ^ The 'Id's unfolding - cafInfo :: CafInfo, - -- ^ 'Id' CAF info - oneShotInfo :: OneShotInfo, - -- ^ Info about a lambda-bound variable, if the 'Id' is one - inlinePragInfo :: InlinePragma, - -- ^ Any inline pragma atached to the 'Id' - occInfo :: OccInfo, - -- ^ How the 'Id' occurs in the program - strictnessInfo :: StrictSig, - -- ^ A strictness signature. Digests how a function uses its arguments - -- if applied to at least 'arityInfo' arguments. - demandInfo :: Demand, - -- ^ ID demand information - callArityInfo :: !ArityInfo, - -- ^ How this is called. This is the number of arguments to which a - -- binding can be eta-expanded without losing any sharing. - -- n <=> all calls have at least n arguments - levityInfo :: LevityInfo - -- ^ when applied, will this Id ever have a levity-polymorphic type? - } - --- Setters - -setRuleInfo :: IdInfo -> RuleInfo -> IdInfo -setRuleInfo info sp = sp `seq` info { ruleInfo = sp } -setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo -setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } -setOccInfo :: IdInfo -> OccInfo -> IdInfo -setOccInfo info oc = oc `seq` info { occInfo = oc } - -- Try to avoid space leaks by seq'ing - -setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo -setUnfoldingInfo info uf - = -- We don't seq the unfolding, as we generate intermediate - -- unfoldings which are just thrown away, so evaluating them is a - -- waste of time. - -- seqUnfolding uf `seq` - info { unfoldingInfo = uf } - -setArityInfo :: IdInfo -> ArityInfo -> IdInfo -setArityInfo info ar = info { arityInfo = ar } -setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo -setCallArityInfo info ar = info { callArityInfo = ar } -setCafInfo :: IdInfo -> CafInfo -> IdInfo -setCafInfo info caf = info { cafInfo = caf } - -setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo -setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } - -setDemandInfo :: IdInfo -> Demand -> IdInfo -setDemandInfo info dd = dd `seq` info { demandInfo = dd } - -setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo -setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } - --- | Basic 'IdInfo' that carries no useful information whatsoever -vanillaIdInfo :: IdInfo -vanillaIdInfo - = IdInfo { - cafInfo = vanillaCafInfo, - arityInfo = unknownArity, - ruleInfo = emptyRuleInfo, - unfoldingInfo = noUnfolding, - oneShotInfo = NoOneShotInfo, - inlinePragInfo = defaultInlinePragma, - occInfo = noOccInfo, - demandInfo = topDmd, - strictnessInfo = nopSig, - callArityInfo = unknownArity, - levityInfo = NoLevityInfo - } - --- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references -noCafIdInfo :: IdInfo -noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs - -- Used for built-in type Ids in MkId. - -{- -************************************************************************ -* * -\subsection[arity-IdInfo]{Arity info about an @Id@} -* * -************************************************************************ - -For locally-defined Ids, the code generator maintains its own notion -of their arities; so it should not be asking... (but other things -besides the code-generator need arity info!) --} - --- | Arity Information --- --- An 'ArityInfo' of @n@ tells us that partial application of this --- 'Id' to up to @n-1@ value arguments does essentially no work. --- --- That is not necessarily the same as saying that it has @n@ leading --- lambdas, because coerces may get in the way. --- --- The arity might increase later in the compilation process, if --- an extra lambda floats up to the binding site. -type ArityInfo = Arity - --- | It is always safe to assume that an 'Id' has an arity of 0 -unknownArity :: Arity -unknownArity = 0 - -ppArityInfo :: Int -> SDoc -ppArityInfo 0 = empty -ppArityInfo n = hsep [text "Arity", int n] - -{- -************************************************************************ -* * -\subsection{Inline-pragma information} -* * -************************************************************************ --} - --- | Inline Pragma Information --- --- Tells when the inlining is active. --- When it is active the thing may be inlined, depending on how --- big it is. --- --- If there was an @INLINE@ pragma, then as a separate matter, the --- RHS will have been made to look small with a Core inline 'Note' --- --- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves --- entirely as a way to inhibit inlining until we want it -type InlinePragInfo = InlinePragma - -{- -************************************************************************ -* * - Strictness -* * -************************************************************************ --} - -pprStrictness :: StrictSig -> SDoc -pprStrictness sig = ppr sig - -{- -************************************************************************ -* * - RuleInfo -* * -************************************************************************ - -Note [Specialisations and RULES in IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, a GlobalId has an *empty* RuleInfo. All their -RULES are contained in the globally-built rule-base. In principle, -one could attach the to M.f the RULES for M.f that are defined in M. -But we don't do that for instance declarations and so we just treat -them all uniformly. - -The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is -jsut for convenience really. - -However, LocalIds may have non-empty RuleInfo. We treat them -differently because: - a) they might be nested, in which case a global table won't work - b) the RULE might mention free variables, which we use to keep things alive - -In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off -and put in the global list. --} - --- | Rule Information --- --- Records the specializations of this 'Id' that we know about --- in the form of rewrite 'CoreRule's that target them -data RuleInfo - = RuleInfo - [CoreRule] - DVarSet -- Locally-defined free vars of *both* LHS and RHS - -- of rules. I don't think it needs to include the - -- ru_fn though. - -- Note [Rule dependency info] in OccurAnal - --- | Assume that no specilizations exist: always safe -emptyRuleInfo :: RuleInfo -emptyRuleInfo = RuleInfo [] emptyDVarSet - -isEmptyRuleInfo :: RuleInfo -> Bool -isEmptyRuleInfo (RuleInfo rs _) = null rs - --- | Retrieve the locally-defined free variables of both the left and --- right hand sides of the specialization rules -ruleInfoFreeVars :: RuleInfo -> DVarSet -ruleInfoFreeVars (RuleInfo _ fvs) = fvs - -ruleInfoRules :: RuleInfo -> [CoreRule] -ruleInfoRules (RuleInfo rules _) = rules - --- | Change the name of the function the rule is keyed on on all of the 'CoreRule's -setRuleInfoHead :: Name -> RuleInfo -> RuleInfo -setRuleInfoHead fn (RuleInfo rules fvs) - = RuleInfo (map (setRuleIdName fn) rules) fvs - -{- -************************************************************************ -* * -\subsection[CG-IdInfo]{Code generator-related information} -* * -************************************************************************ --} - --- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). - --- | Constant applicative form Information --- --- Records whether an 'Id' makes Constant Applicative Form references -data CafInfo - = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: - -- - -- 1. A function or static constructor - -- that refers to one or more CAFs, or - -- - -- 2. A real live CAF - - | NoCafRefs -- ^ A function or static constructor - -- that refers to no CAFs. - deriving (Eq, Ord) - --- | Assumes that the 'Id' has CAF references: definitely safe -vanillaCafInfo :: CafInfo -vanillaCafInfo = MayHaveCafRefs - -mayHaveCafRefs :: CafInfo -> Bool -mayHaveCafRefs MayHaveCafRefs = True -mayHaveCafRefs _ = False - -instance Outputable CafInfo where - ppr = ppCafInfo - -ppCafInfo :: CafInfo -> SDoc -ppCafInfo NoCafRefs = text "NoCafRefs" -ppCafInfo MayHaveCafRefs = empty - -{- -************************************************************************ -* * -\subsection{Bulk operations on IdInfo} -* * -************************************************************************ --} - --- | This is used to remove information on lambda binders that we have --- setup as part of a lambda group, assuming they will be applied all at once, --- but turn out to be part of an unsaturated lambda as in e.g: --- --- > (\x1. \x2. e) arg1 -zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) - | is_safe_occ occ && is_safe_dmd demand - = Nothing - | otherwise - = Just (info {occInfo = safe_occ, demandInfo = topDmd}) - where - -- The "unsafe" occ info is the ones that say I'm not in a lambda - -- because that might not be true for an unsaturated lambda - is_safe_occ occ | isAlwaysTailCalled occ = False - is_safe_occ (OneOcc { occ_in_lam = in_lam }) = in_lam - is_safe_occ _other = True - - safe_occ = case occ of - OneOcc{} -> occ { occ_in_lam = True - , occ_tail = NoTailCallInfo } - IAmALoopBreaker{} - -> occ { occ_tail = NoTailCallInfo } - _other -> occ - - is_safe_dmd dmd = not (isStrictDmd dmd) - --- | Remove all demand info on the 'IdInfo' -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info = Just (info {demandInfo = topDmd}) - --- | Remove usage (but not strictness) info on the 'IdInfo' -zapUsageInfo :: IdInfo -> Maybe IdInfo -zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) - --- | Remove usage environment info from the strictness signature on the 'IdInfo' -zapUsageEnvInfo :: IdInfo -> Maybe IdInfo -zapUsageEnvInfo info - | hasDemandEnvSig (strictnessInfo info) - = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) - | otherwise - = Nothing - -zapUsedOnceInfo :: IdInfo -> Maybe IdInfo -zapUsedOnceInfo info - = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) - , demandInfo = zapUsedOnceDemand (demandInfo info) } - -zapFragileInfo :: IdInfo -> Maybe IdInfo --- ^ Zap info that depends on free variables -zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) - = new_unf `seq` -- The unfolding field is not (currently) strict, so we - -- force it here to avoid a (zapFragileUnfolding unf) thunk - -- which might leak space - Just (info `setRuleInfo` emptyRuleInfo - `setUnfoldingInfo` new_unf - `setOccInfo` zapFragileOcc occ) - where - new_unf = zapFragileUnfolding unf - -zapFragileUnfolding :: Unfolding -> Unfolding -zapFragileUnfolding unf - | isFragileUnfolding unf = noUnfolding - | otherwise = unf - -zapUnfolding :: Unfolding -> Unfolding --- Squash all unfolding info, preserving only evaluated-ness -zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding - | otherwise = noUnfolding - -zapTailCallInfo :: IdInfo -> Maybe IdInfo -zapTailCallInfo info - = case occInfo info of - occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) - | otherwise -> Nothing - where - safe_occ = occ { occ_tail = NoTailCallInfo } - -zapCallArityInfo :: IdInfo -> IdInfo -zapCallArityInfo info = setCallArityInfo info 0 - -{- -************************************************************************ -* * -\subsection{TickBoxOp} -* * -************************************************************************ --} - -type TickBoxId = Int - --- | Tick box for Hpc-style coverage -data TickBoxOp - = TickBox Module {-# UNPACK #-} !TickBoxId - -instance Outputable TickBoxOp where - ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) - -{- -************************************************************************ -* * - Levity -* * -************************************************************************ - -Note [Levity info] -~~~~~~~~~~~~~~~~~~ - -Ids store whether or not they can be levity-polymorphic at any amount -of saturation. This is helpful in optimizing the levity-polymorphism check -done in the desugarer, where we can usually learn that something is not -levity-polymorphic without actually figuring out its type. See -isExprLevPoly in CoreUtils for where this info is used. Storing -this is required to prevent perf/compiler/T5631 from blowing up. - --} - --- See Note [Levity info] -data LevityInfo = NoLevityInfo -- always safe - | NeverLevityPolymorphic - deriving Eq - -instance Outputable LevityInfo where - ppr NoLevityInfo = text "NoLevityInfo" - ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" - --- | Marks an IdInfo describing an Id that is never levity polymorphic (even when --- applied). The Type is only there for checking that it's really never levity --- polymorphic -setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo -setNeverLevPoly info ty - = ASSERT2( not (resultIsLevPoly ty), ppr ty ) - info { levityInfo = NeverLevityPolymorphic } - -setLevityInfoWithType :: IdInfo -> Type -> IdInfo -setLevityInfoWithType info ty - | not (resultIsLevPoly ty) - = info { levityInfo = NeverLevityPolymorphic } - | otherwise - = info - -isNeverLevPolyIdInfo :: IdInfo -> Bool -isNeverLevPolyIdInfo info - | NeverLevityPolymorphic <- levityInfo info = True - | otherwise = False diff --git a/basicTypes/IdInfo.hs-boot b/basicTypes/IdInfo.hs-boot deleted file mode 100644 --- a/basicTypes/IdInfo.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -module IdInfo where -import GhcPrelude -import Outputable -data IdInfo -data IdDetails - -vanillaIdInfo :: IdInfo -coVarDetails :: IdDetails -isCoVarDetails :: IdDetails -> Bool -pprIdDetails :: IdDetails -> SDoc - diff --git a/basicTypes/Lexeme.hs b/basicTypes/Lexeme.hs deleted file mode 100644 --- a/basicTypes/Lexeme.hs +++ /dev/null @@ -1,240 +0,0 @@ --- (c) The GHC Team --- --- Functions to evaluate whether or not a string is a valid identifier. --- There is considerable overlap between the logic here and the logic --- in Lexer.x, but sadly there seems to be no way to merge them. - -module Lexeme ( - -- * Lexical characteristics of Haskell names - - -- | Use these functions to figure what kind of name a 'FastString' - -- represents; these functions do /not/ check that the identifier - -- is valid. - - isLexCon, isLexVar, isLexId, isLexSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym, - startsVarSym, startsVarId, startsConSym, startsConId, - - -- * Validating identifiers - - -- | These functions (working over plain old 'String's) check - -- to make sure that the identifier is valid. - okVarOcc, okConOcc, okTcOcc, - okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc - - -- Some of the exports above are not used within GHC, but may - -- be of value to GHC API users. - - ) where - -import GhcPrelude - -import FastString - -import Data.Char -import qualified Data.Set as Set - -import GHC.Lexeme - -{- - -************************************************************************ -* * - Lexical categories -* * -************************************************************************ - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. - -Note [Classification of generated names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Some names generated for internal use can show up in debugging output, -e.g. when using -ddump-simpl. These generated names start with a $ -but should still be pretty-printed using prefix notation. We make sure -this is the case in isLexVarSym by only classifying a name as a symbol -if all its characters are symbols, not just its first one. --} - -isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool -isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- -isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == (fsLit "[]") = True - | otherwise = startsConId (headFS cs) - -isLexVarId cs -- Ordinary prefix identifiers - | nullFS cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) - -isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == (fsLit "->") = True - | otherwise = startsConSym (headFS cs) - -isLexVarSym fs -- Infix identifiers e.g. "+" - | fs == (fsLit "~R#") = True - | otherwise - = case (if nullFS fs then [] else unpackFS fs) of - [] -> False - (c:cs) -> startsVarSym c && all isVarSymChar cs - -- See Note [Classification of generated names] - -{- - -************************************************************************ -* * - Detecting valid names for Template Haskell -* * -************************************************************************ - --} - ----------------------- --- External interface ----------------------- - --- | Is this an acceptable variable name? -okVarOcc :: String -> Bool -okVarOcc str@(c:_) - | startsVarId c - = okVarIdOcc str - | startsVarSym c - = okVarSymOcc str -okVarOcc _ = False - --- | Is this an acceptable constructor name? -okConOcc :: String -> Bool -okConOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | str == "[]" - = True -okConOcc _ = False - --- | Is this an acceptable type name? -okTcOcc :: String -> Bool -okTcOcc "[]" = True -okTcOcc "->" = True -okTcOcc "~" = True -okTcOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | startsVarSym c - = okVarSymOcc str -okTcOcc _ = False - --- | Is this an acceptable alphanumeric variable name, assuming it starts --- with an acceptable letter? -okVarIdOcc :: String -> Bool -okVarIdOcc str = okIdOcc str && - -- admit "_" as a valid identifier. Required to support typed - -- holes in Template Haskell. See #10267 - (str == "_" || not (str `Set.member` reservedIds)) - --- | Is this an acceptable symbolic variable name, assuming it starts --- with an acceptable character? -okVarSymOcc :: String -> Bool -okVarSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) && - not (isDashes str) - --- | Is this an acceptable alphanumeric constructor name, assuming it --- starts with an acceptable letter? -okConIdOcc :: String -> Bool -okConIdOcc str = okIdOcc str || - is_tuple_name1 True str || - -- Is it a boxed tuple... - is_tuple_name1 False str || - -- ...or an unboxed tuple (#12407)... - is_sum_name1 str - -- ...or an unboxed sum (#12514)? - where - -- check for tuple name, starting at the beginning - is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest - is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest - is_tuple_name1 _ _ = False - - -- check for tuple tail - is_tuple_name2 True ")" = True - is_tuple_name2 False "#)" = True - is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest - is_tuple_name2 boxed (ws : rest) - | isSpace ws = is_tuple_name2 boxed rest - is_tuple_name2 _ _ = False - - -- check for sum name, starting at the beginning - is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest - is_sum_name1 _ = False - - -- check for sum tail, only allowing at most one underscore - is_sum_name2 _ "#)" = True - is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest - is_sum_name2 False ('_' : rest) = is_sum_name2 True rest - is_sum_name2 underscore (ws : rest) - | isSpace ws = is_sum_name2 underscore rest - is_sum_name2 _ _ = False - --- | Is this an acceptable symbolic constructor name, assuming it --- starts with an acceptable character? -okConSymOcc :: String -> Bool -okConSymOcc ":" = True -okConSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) - ----------------------- --- Internal functions ----------------------- - --- | Is this string an acceptable id, possibly with a suffix of hashes, --- but not worrying about case or clashing with reserved words? -okIdOcc :: String -> Bool -okIdOcc str - = let hashes = dropWhile okIdChar str in - all (== '#') hashes -- -XMagicHash allows a suffix of hashes - -- of course, `all` says "True" to an empty list - --- | Is this character acceptable in an identifier (after the first letter)? --- See alexGetByte in Lexer.x -okIdChar :: Char -> Bool -okIdChar c = case generalCategory c of - UppercaseLetter -> True - LowercaseLetter -> True - TitlecaseLetter -> True - ModifierLetter -> True -- See #10196 - OtherLetter -> True -- See #1103 - NonSpacingMark -> True -- See #7650 - DecimalNumber -> True - OtherNumber -> True -- See #4373 - _ -> c == '\'' || c == '_' - --- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. -reservedIds :: Set.Set String -reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" - , "do", "else", "foreign", "if", "import", "in" - , "infix", "infixl", "infixr", "instance", "let" - , "module", "newtype", "of", "then", "type", "where" - , "_" ] - --- | All reserved operators. Taken from section 2.4 of the 2010 Report. -reservedOps :: Set.Set String -reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" - , "@", "~", "=>" ] - --- | Does this string contain only dashes and has at least 2 of them? -isDashes :: String -> Bool -isDashes ('-' : '-' : rest) = all (== '-') rest -isDashes _ = False diff --git a/basicTypes/Literal.hs b/basicTypes/Literal.hs deleted file mode 100644 --- a/basicTypes/Literal.hs +++ /dev/null @@ -1,850 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[Literal]{@Literal@: literals} --} - -{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} - -module Literal - ( - -- * Main data type - Literal(..) -- Exported to ParseIface - , LitNumType(..) - - -- ** Creating Literals - , mkLitInt, mkLitIntWrap, mkLitIntWrapC - , mkLitWord, mkLitWordWrap, mkLitWordWrapC - , mkLitInt64, mkLitInt64Wrap - , mkLitWord64, mkLitWord64Wrap - , mkLitFloat, mkLitDouble - , mkLitChar, mkLitString - , mkLitInteger, mkLitNatural - , mkLitNumber, mkLitNumberWrap - - -- ** Operations on Literals - , literalType - , absentLiteralOf - , pprLiteral - , litNumIsSigned - , litNumCheckRange - - -- ** Predicates on Literals and their contents - , litIsDupable, litIsTrivial, litIsLifted - , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange - , isZeroLit - , litFitsInChar - , litValue, isLitValue, isLitValue_maybe, mapLitValue - - -- ** Coercions - , word2IntLit, int2WordLit - , narrowLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TysPrim -import PrelNames -import Type -import TyCon -import Outputable -import FastString -import BasicTypes -import Binary -import Constants -import DynFlags -import GHC.Platform -import UniqFM -import Util - -import Data.ByteString (ByteString) -import Data.Int -import Data.Word -import Data.Char -import Data.Maybe ( isJust ) -import Data.Data ( Data ) -import Data.Proxy -import Numeric ( fromRat ) - -{- -************************************************************************ -* * -\subsection{Literals} -* * -************************************************************************ --} - --- | So-called 'Literal's are one of: --- --- * An unboxed numeric literal or floating-point literal which is presumed --- to be surrounded by appropriate constructors (@Int#@, etc.), so that --- the overall thing makes sense. --- --- We maintain the invariant that the 'Integer' in the 'LitNumber' --- constructor is actually in the (possibly target-dependent) range. --- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying --- the target machine's wrapping semantics. Use these in situations --- where you know the wrapping semantics are correct. --- --- * The literal derived from the label mentioned in a \"foreign label\" --- declaration ('LitLabel') --- --- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' --- (i.e. 'MutVar#') when the the value is never used. --- --- * A character --- * A string --- * The NULL pointer --- -data Literal - = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with - -- 'mkLitChar' - - | LitNumber !LitNumType !Integer Type - -- ^ Any numeric literal that can be - -- internally represented with an Integer. - -- See Note [Types of LitNumbers] below for the - -- Type field. - - | LitString ByteString -- ^ A string-literal: stored and emitted - -- UTF-8 encoded, we'll arrange to decode it - -- at runtime. Also emitted with a @\'\\0\'@ - -- terminator. Create with 'mkLitString' - - | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value - -- that can be represented as a Literal. Create - -- with 'nullAddrLit' - - | LitRubbish -- ^ A nonsense value, used when an unlifted - -- binding is absent and has type - -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. - -- May be lowered by code-gen to any possible - -- value. Also see Note [Rubbish literals] - - | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' - | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' - - | LitLabel FastString (Maybe Int) FunctionOrData - -- ^ A label literal. Parameters: - -- - -- 1) The name of the symbol mentioned in the - -- declaration - -- - -- 2) The size (in bytes) of the arguments - -- the label expects. Only applicable with - -- @stdcall@ labels. @Just x@ => @\@ will - -- be appended to label name when emitting - -- assembly. - -- - -- 3) Flag indicating whether the symbol - -- references a function or a data - deriving Data - --- | Numeric literal type -data LitNumType - = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) - | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) - | LitNumInt -- ^ @Int#@ - according to target machine - | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits - | LitNumWord -- ^ @Word#@ - according to target machine - | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits - deriving (Data,Enum,Eq,Ord) - --- | Indicate if a numeric literal type supports negative numbers -litNumIsSigned :: LitNumType -> Bool -litNumIsSigned nt = case nt of - LitNumInteger -> True - LitNumNatural -> False - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> False - LitNumWord64 -> False - -{- -Note [Integer literals] -~~~~~~~~~~~~~~~~~~~~~~~ -An Integer literal is represented using, well, an Integer, to make it -easier to write RULEs for them. They also contain the Integer type, so -that e.g. literalType can return the right Type for them. - -They only get converted into real Core, - mkInteger [c1, c2, .., cn] -during the CorePrep phase, although TidyPgm looks ahead at what the -core will be, so that it can see whether it involves CAFs. - -When we initally build an Integer literal, notably when -deserialising it from an interface file (see the Binary instance -below), we don't have convenient access to the mkInteger Id. So we -just use an error thunk, and fill in the real Id when we do tcIfaceLit -in TcIface. - -Note [Natural literals] -~~~~~~~~~~~~~~~~~~~~~~~ -Similar to Integer literals. - -Note [String literals] -~~~~~~~~~~~~~~~~~~~~~~ - -String literals are UTF-8 encoded and stored into ByteStrings in the following -ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals -with the BytesPrimL constructor (see #14741). - -It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite -bad for performance with large strings (see #16198 and #14741). - -To include string literals into output objects, the assembler code generator has -to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] -for more details. - --} - -instance Binary LitNumType where - put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) - get bh = do - h <- getByte bh - return (toEnum (fromIntegral h)) - -instance Binary Literal where - put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa - put_ bh (LitString ab) = do putByte bh 1; put_ bh ab - put_ bh (LitNullAddr) = do putByte bh 2 - put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah - put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai - put_ bh (LitLabel aj mb fod) - = do putByte bh 5 - put_ bh aj - put_ bh mb - put_ bh fod - put_ bh (LitNumber nt i _) - = do putByte bh 6 - put_ bh nt - put_ bh i - put_ bh (LitRubbish) = do putByte bh 7 - get bh = do - h <- getByte bh - case h of - 0 -> do - aa <- get bh - return (LitChar aa) - 1 -> do - ab <- get bh - return (LitString ab) - 2 -> do - return (LitNullAddr) - 3 -> do - ah <- get bh - return (LitFloat ah) - 4 -> do - ai <- get bh - return (LitDouble ai) - 5 -> do - aj <- get bh - mb <- get bh - fod <- get bh - return (LitLabel aj mb fod) - 6 -> do - nt <- get bh - i <- get bh - -- Note [Types of LitNumbers] - let t = case nt of - LitNumInt -> intPrimTy - LitNumInt64 -> int64PrimTy - LitNumWord -> wordPrimTy - LitNumWord64 -> word64PrimTy - -- See Note [Integer literals] - LitNumInteger -> - panic "Evaluated the place holder for mkInteger" - -- and Note [Natural literals] - LitNumNatural -> - panic "Evaluated the place holder for mkNatural" - return (LitNumber nt i t) - _ -> do - return (LitRubbish) - -instance Outputable Literal where - ppr = pprLiteral id - -instance Eq Literal where - a == b = compare a b == EQ - --- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in --- 'TrieMap.CoreMap'. -instance Ord Literal where - compare = cmpLit - -{- - Construction - ~~~~~~~~~~~~ --} - -{- Note [Word/Int underflow/overflow] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and -unsigned integral types): "All arithmetic is performed modulo 2^n, where n is -the number of bits in the type." - -GHC stores Word# and Int# constant values as Integer. Core optimizations such -as constant folding must ensure that the Integer value remains in the valid -target Word/Int range (see #13172). The following functions are used to -ensure this. - -Note that we *don't* warn the user about overflow. It's not done at runtime -either, and compilation of completely harmless things like - ((124076834 :: Word32) + (2147483647 :: Word32)) -doesn't yield a warning. Instead we simply squash the value into the *target* -Int/Word range. --} - --- | Wrap a literal number according to its type -wrapLitNumber :: DynFlags -> Literal -> Literal -wrapLitNumber dflags v@(LitNumber nt i t) = case nt of - LitNumInt -> case platformWordSize (targetPlatform dflags) of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord -> case platformWordSize (targetPlatform dflags) of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - LitNumInteger -> v - LitNumNatural -> v -wrapLitNumber _ x = x - --- | Create a numeric 'Literal' of the given type -mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal -mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t) - --- | Check that a given number is in the range of a numeric literal -litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool -litNumCheckRange dflags nt i = case nt of - LitNumInt -> inIntRange dflags i - LitNumWord -> inWordRange dflags i - LitNumInt64 -> inInt64Range i - LitNumWord64 -> inWord64Range i - LitNumNatural -> i >= 0 - LitNumInteger -> True - --- | Create a numeric 'Literal' of the given type -mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal -mkLitNumber dflags nt i t = - ASSERT2(litNumCheckRange dflags nt i, integer i) - (LitNumber nt i t) - --- | Creates a 'Literal' of type @Int#@ -mkLitInt :: DynFlags -> Integer -> Literal -mkLitInt dflags x = ASSERT2( inIntRange dflags x, integer x ) - (mkLitIntUnchecked x) - --- | Creates a 'Literal' of type @Int#@. --- If the argument is out of the (target-dependent) range, it is wrapped. --- See Note [Word/Int underflow/overflow] -mkLitIntWrap :: DynFlags -> Integer -> Literal -mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i - --- | Creates a 'Literal' of type @Int#@ without checking its range. -mkLitIntUnchecked :: Integer -> Literal -mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy - --- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating --- overflow. That is, if the argument is out of the (target-dependent) range --- the argument is wrapped and the overflow flag will be set. --- See Note [Word/Int underflow/overflow] -mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkLitIntWrapC dflags i = (n, i /= i') - where - n@(LitNumber _ i' _) = mkLitIntWrap dflags i - --- | Creates a 'Literal' of type @Word#@ -mkLitWord :: DynFlags -> Integer -> Literal -mkLitWord dflags x = ASSERT2( inWordRange dflags x, integer x ) - (mkLitWordUnchecked x) - --- | Creates a 'Literal' of type @Word#@. --- If the argument is out of the (target-dependent) range, it is wrapped. --- See Note [Word/Int underflow/overflow] -mkLitWordWrap :: DynFlags -> Integer -> Literal -mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i - --- | Creates a 'Literal' of type @Word#@ without checking its range. -mkLitWordUnchecked :: Integer -> Literal -mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy - --- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating --- carry. That is, if the argument is out of the (target-dependent) range --- the argument is wrapped and the carry flag will be set. --- See Note [Word/Int underflow/overflow] -mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkLitWordWrapC dflags i = (n, i /= i') - where - n@(LitNumber _ i' _) = mkLitWordWrap dflags i - --- | Creates a 'Literal' of type @Int64#@ -mkLitInt64 :: Integer -> Literal -mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) - --- | Creates a 'Literal' of type @Int64#@. --- If the argument is out of the range, it is wrapped. -mkLitInt64Wrap :: DynFlags -> Integer -> Literal -mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i - --- | Creates a 'Literal' of type @Int64#@ without checking its range. -mkLitInt64Unchecked :: Integer -> Literal -mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy - --- | Creates a 'Literal' of type @Word64#@ -mkLitWord64 :: Integer -> Literal -mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) - --- | Creates a 'Literal' of type @Word64#@. --- If the argument is out of the range, it is wrapped. -mkLitWord64Wrap :: DynFlags -> Integer -> Literal -mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i - --- | Creates a 'Literal' of type @Word64#@ without checking its range. -mkLitWord64Unchecked :: Integer -> Literal -mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy - --- | Creates a 'Literal' of type @Float#@ -mkLitFloat :: Rational -> Literal -mkLitFloat = LitFloat - --- | Creates a 'Literal' of type @Double#@ -mkLitDouble :: Rational -> Literal -mkLitDouble = LitDouble - --- | Creates a 'Literal' of type @Char#@ -mkLitChar :: Char -> Literal -mkLitChar = LitChar - --- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to --- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ -mkLitString :: String -> Literal --- stored UTF-8 encoded -mkLitString s = LitString (bytesFS $ mkFastString s) - -mkLitInteger :: Integer -> Type -> Literal -mkLitInteger x ty = LitNumber LitNumInteger x ty - -mkLitNatural :: Integer -> Type -> Literal -mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) - (LitNumber LitNumNatural x ty) - -inIntRange, inWordRange :: DynFlags -> Integer -> Bool -inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags -inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags - -inNaturalRange :: Integer -> Bool -inNaturalRange x = x >= 0 - -inInt64Range, inWord64Range :: Integer -> Bool -inInt64Range x = x >= toInteger (minBound :: Int64) && - x <= toInteger (maxBound :: Int64) -inWord64Range x = x >= toInteger (minBound :: Word64) && - x <= toInteger (maxBound :: Word64) - -inCharRange :: Char -> Bool -inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR - --- | Tests whether the literal represents a zero of whatever type it is -isZeroLit :: Literal -> Bool -isZeroLit (LitNumber _ 0 _) = True -isZeroLit (LitFloat 0) = True -isZeroLit (LitDouble 0) = True -isZeroLit _ = False - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. -litValue :: Literal -> Integer -litValue l = case isLitValue_maybe l of - Just x -> x - Nothing -> pprPanic "litValue" (ppr l) - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char' and numbers. -isLitValue_maybe :: Literal -> Maybe Integer -isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c -isLitValue_maybe (LitNumber _ i _) = Just i -isLitValue_maybe _ = Nothing - --- | Apply a function to the 'Integer' contained in the 'Literal', for when that --- makes sense, e.g. for 'Char' and numbers. --- For fixed-size integral literals, the result will be wrapped in accordance --- with the semantics of the target type. --- See Note [Word/Int underflow/overflow] -mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal -mapLitValue _ f (LitChar c) = mkLitChar (fchar c) - where fchar = chr . fromInteger . f . toInteger . ord -mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags - (LitNumber nt (f i) t) -mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) - --- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', --- 'Int', 'Word', 'LitInteger' and 'LitNatural'. -isLitValue :: Literal -> Bool -isLitValue = isJust . isLitValue_maybe - -{- - Coercions - ~~~~~~~~~ --} - -narrow8IntLit, narrow16IntLit, narrow32IntLit, - narrow8WordLit, narrow16WordLit, narrow32WordLit, - char2IntLit, int2CharLit, - float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, - float2DoubleLit, double2FloatLit - :: Literal -> Literal - -word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal -word2IntLit dflags (LitNumber LitNumWord w _) - -- Map Word range [max_int+1, max_word] - -- to Int range [min_int , -1] - -- Range [0,max_int] has the same representation with both Int and Word - | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1) - | otherwise = mkLitInt dflags w -word2IntLit _ l = pprPanic "word2IntLit" (ppr l) - -int2WordLit dflags (LitNumber LitNumInt i _) - -- Map Int range [min_int , -1] - -- to Word range [max_int+1, max_word] - -- Range [0,max_int] has the same representation with both Int and Word - | i < 0 = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i) - | otherwise = mkLitWord dflags i -int2WordLit _ l = pprPanic "int2WordLit" (ppr l) - --- | Narrow a literal number (unchecked result range) -narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal -narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t -narrowLit _ l = pprPanic "narrowLit" (ppr l) - -narrow8IntLit = narrowLit (Proxy :: Proxy Int8) -narrow16IntLit = narrowLit (Proxy :: Proxy Int16) -narrow32IntLit = narrowLit (Proxy :: Proxy Int32) -narrow8WordLit = narrowLit (Proxy :: Proxy Word8) -narrow16WordLit = narrowLit (Proxy :: Proxy Word16) -narrow32WordLit = narrowLit (Proxy :: Proxy Word32) - -char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) -char2IntLit l = pprPanic "char2IntLit" (ppr l) -int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) -int2CharLit l = pprPanic "int2CharLit" (ppr l) - -float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) -float2IntLit l = pprPanic "float2IntLit" (ppr l) -int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) -int2FloatLit l = pprPanic "int2FloatLit" (ppr l) - -double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) -double2IntLit l = pprPanic "double2IntLit" (ppr l) -int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) -int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) - -float2DoubleLit (LitFloat f) = LitDouble f -float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) -double2FloatLit (LitDouble d) = LitFloat d -double2FloatLit l = pprPanic "double2FloatLit" (ppr l) - -nullAddrLit :: Literal -nullAddrLit = LitNullAddr - --- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. -rubbishLit :: Literal -rubbishLit = LitRubbish - -{- - Predicates - ~~~~~~~~~~ --} - --- | True if there is absolutely no penalty to duplicating the literal. --- False principally of strings. --- --- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would --- blow up code sizes. Not only this, it's also unsafe. --- --- Consider a program that wants to traverse a string. One way it might do this --- is to first compute the Addr# pointing to the end of the string, and then, --- starting from the beginning, bump a pointer using eqAddr# to determine the --- end. For instance, --- --- @ --- -- Given pointers to the start and end of a string, count how many zeros --- -- the string contains. --- countZeros :: Addr# -> Addr# -> -> Int --- countZeros start end = go start 0 --- where --- go off n --- | off `addrEq#` end = n --- | otherwise = go (off `plusAddr#` 1) n' --- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 --- | otherwise = n --- @ --- --- Consider what happens if we considered strings to be trivial (and therefore --- duplicable) and emitted a call like @countZeros "hello"# ("hello"# --- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same --- string, meaning that an iteration like the above would blow up terribly. --- This is what happened in #12757. --- --- Ultimately the solution here is to make primitive strings a bit more --- structured, ensuring that the compiler can't inline in ways that will break --- user code. One approach to this is described in #8472. -litIsTrivial :: Literal -> Bool --- c.f. CoreUtils.exprIsTrivial -litIsTrivial (LitString _) = False -litIsTrivial (LitNumber nt _ _) = case nt of - LitNumInteger -> False - LitNumNatural -> False - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> True - LitNumWord64 -> True -litIsTrivial _ = True - --- | True if code space does not go bad if we duplicate this literal -litIsDupable :: DynFlags -> Literal -> Bool --- c.f. CoreUtils.exprIsDupable -litIsDupable _ (LitString _) = False -litIsDupable dflags (LitNumber nt i _) = case nt of - LitNumInteger -> inIntRange dflags i - LitNumNatural -> inIntRange dflags i - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> True - LitNumWord64 -> True -litIsDupable _ _ = True - -litFitsInChar :: Literal -> Bool -litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) - && i <= toInteger (ord maxBound) -litFitsInChar _ = False - -litIsLifted :: Literal -> Bool -litIsLifted (LitNumber nt _ _) = case nt of - LitNumInteger -> True - LitNumNatural -> True - LitNumInt -> False - LitNumInt64 -> False - LitNumWord -> False - LitNumWord64 -> False -litIsLifted _ = False - -{- - Types - ~~~~~ - -Note [Types of LitNumbers] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A LitNumber's type is always known from its LitNumType: - - LitNumInteger -> Integer - LitNumNatural -> Natural - LitNumInt -> Int# (intPrimTy) - LitNumInt64 -> Int64# (int64PrimTy) - LitNumWord -> Word# (wordPrimTy) - LitNumWord64 -> Word64# (word64PrimTy) - -The reason why we have a Type field is because Integer and Natural types live -outside of GHC (in the libraries), so we have to get the actual Type via -lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites -of literalType, so we do that when creating these literals, and literalType -simply reads the field. - -(But see also Note [Integer literals] and Note [Natural literals]) --} - --- | Find the Haskell 'Type' the literal occupies -literalType :: Literal -> Type -literalType LitNullAddr = addrPrimTy -literalType (LitChar _) = charPrimTy -literalType (LitString _) = addrPrimTy -literalType (LitFloat _) = floatPrimTy -literalType (LitDouble _) = doublePrimTy -literalType (LitLabel _ _ _) = addrPrimTy -literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] -literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) - where - a = alphaTyVarUnliftedRep - -absentLiteralOf :: TyCon -> Maybe Literal --- Return a literal of the appropriate primitive --- TyCon, to use as a placeholder when it doesn't matter --- Rubbish literals are handled in WwLib, because --- 1. Looking at the TyCon is not enough, we need the actual type --- 2. This would need to return a type application to a literal -absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) - -absent_lits :: UniqFM Literal -absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) - , (charPrimTyConKey, LitChar 'x') - , (intPrimTyConKey, mkLitIntUnchecked 0) - , (int64PrimTyConKey, mkLitInt64Unchecked 0) - , (wordPrimTyConKey, mkLitWordUnchecked 0) - , (word64PrimTyConKey, mkLitWord64Unchecked 0) - , (floatPrimTyConKey, LitFloat 0) - , (doublePrimTyConKey, LitDouble 0) - ] - -{- - Comparison - ~~~~~~~~~~ --} - -cmpLit :: Literal -> Literal -> Ordering -cmpLit (LitChar a) (LitChar b) = a `compare` b -cmpLit (LitString a) (LitString b) = a `compare` b -cmpLit (LitNullAddr) (LitNullAddr) = EQ -cmpLit (LitFloat a) (LitFloat b) = a `compare` b -cmpLit (LitDouble a) (LitDouble b) = a `compare` b -cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b -cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) - | nt1 == nt2 = a `compare` b - | otherwise = nt1 `compare` nt2 -cmpLit (LitRubbish) (LitRubbish) = EQ -cmpLit lit1 lit2 - | litTag lit1 < litTag lit2 = LT - | otherwise = GT - -litTag :: Literal -> Int -litTag (LitChar _) = 1 -litTag (LitString _) = 2 -litTag (LitNullAddr) = 3 -litTag (LitFloat _) = 4 -litTag (LitDouble _) = 5 -litTag (LitLabel _ _ _) = 6 -litTag (LitNumber {}) = 7 -litTag (LitRubbish) = 8 - -{- - Printing - ~~~~~~~~ -* See Note [Printing of literals in Core] --} - -pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc -pprLiteral _ (LitChar c) = pprPrimChar c -pprLiteral _ (LitString s) = pprHsBytes s -pprLiteral _ (LitNullAddr) = text "__NULL" -pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix -pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix -pprLiteral add_par (LitNumber nt i _) - = case nt of - LitNumInteger -> pprIntegerVal add_par i - LitNumNatural -> pprIntegerVal add_par i - LitNumInt -> pprPrimInt i - LitNumInt64 -> pprPrimInt64 i - LitNumWord -> pprPrimWord i - LitNumWord64 -> pprPrimWord64 i -pprLiteral add_par (LitLabel l mb fod) = - add_par (text "__label" <+> b <+> ppr fod) - where b = case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -pprLiteral _ (LitRubbish) = text "__RUBBISH" - -pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc --- See Note [Printing of literals in Core]. -pprIntegerVal add_par i | i < 0 = add_par (integer i) - | otherwise = integer i - -{- -Note [Printing of literals in Core] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function `add_par` is used to wrap parenthesis around negative integers -(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring -an atomic thing (for example function application). - -Although not all Core literals would be valid Haskell, we are trying to stay -as close as possible to Haskell syntax in the printing of Core, to make it -easier for a Haskell user to read Core. - -To that end: - * We do print parenthesis around negative `LitInteger`, because we print - `LitInteger` using plain number literals (no prefix or suffix), and plain - number literals in Haskell require parenthesis in contexts like function - application (i.e. `1 - -1` is not valid Haskell). - - * We don't print parenthesis around other (negative) literals, because they - aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's - parser). - -Literal Output Output if context requires - an atom (if different) -------- ------- ---------------------- -LitChar 'a'# -LitString "aaa"# -LitNullAddr "__NULL" -LitInt -1# -LitInt64 -1L# -LitWord 1## -LitWord64 1L## -LitFloat -1.0# -LitDouble -1.0## -LitInteger -1 (-1) -LitLabel "__label" ... ("__label" ...) -LitRubbish "__RUBBISH" - -Note [Rubbish literals] -~~~~~~~~~~~~~~~~~~~~~~~ -During worker/wrapper after demand analysis, where an argument -is unused (absent) we do the following w/w split (supposing that -y is absent): - - f x y z = e -===> - f x y z = $wf x z - $wf x z = let y = - in e - -Usually the binding for y is ultimately optimised away, and -even if not it should never be evaluated -- but that's the -way the w/w split starts off. - -What is ? -* For lifted values can be a call to 'error'. -* For primitive types like Int# or Word# we can use any random - value of that type. -* But what about /unlifted/ but /boxed/ types like MutVar# or - Array#? We need a literal value of that type. - -That is 'LitRubbish'. Since we need a rubbish literal for -many boxed, unlifted types, we say that LitRubbish has type - LitRubbish :: forall (a :: TYPE UnliftedRep). a - -So we might see a w/w split like - $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) - in e - -Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted -heap pointers. - -Here are the moving parts: - -* We define LitRubbish as a constructor in Literal.Literal - -* It is given its polymoprhic type by Literal.literalType - -* WwLib.mk_absent_let introduces a LitRubbish for absent - arguments of boxed, unlifted type. - -* In CoreToSTG we convert (RubishLit @t) to just (). STG is - untyped, so it doesn't matter that it points to a lifted - value. The important thing is that it is a heap pointer, - which the garbage collector can follow if it encounters it. - - We considered maintaining LitRubbish in STG, and lowering - it in the code genreators, but it seems simpler to do it - once and for all in CoreToSTG. - - In ByteCodeAsm we just lower it as a 0 literal, because - it's all boxed and lifted to the host GC anyway. --} diff --git a/basicTypes/MkId.hs b/basicTypes/MkId.hs deleted file mode 100644 --- a/basicTypes/MkId.hs +++ /dev/null @@ -1,1734 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - - -This module contains definitions for the IdInfo for things that -have a standard form, namely: - -- data constructors -- record selectors -- method and superclass selectors -- primitive operations --} - -{-# LANGUAGE CPP #-} - -module MkId ( - mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, - - mkPrimOpId, mkFCallId, - - unwrapNewTypeBody, wrapFamInstBody, - DataConBoxer(..), mkDataConRep, mkDataConWorkId, - - -- And some particular Ids; see below for why they are wired in - wiredInIds, ghcPrimIds, - unsafeCoerceName, unsafeCoerceId, realWorldPrimId, - voidPrimId, voidArgId, - nullAddrId, seqId, lazyId, lazyIdKey, - coercionTokenId, magicDictId, coerceId, - proxyHashId, noinlineId, noinlineIdName, - coerceName, - - -- Re-export error Ids - module PrelRules - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Rules -import TysPrim -import TysWiredIn -import PrelRules -import Type -import FamInstEnv -import Coercion -import TcType -import MkCore -import CoreUtils ( mkCast, mkDefaultCase ) -import CoreUnfold -import Literal -import TyCon -import Class -import NameSet -import Name -import PrimOp -import ForeignCall -import DataCon -import Id -import IdInfo -import Demand -import CoreSyn -import Unique -import UniqSupply -import PrelNames -import BasicTypes hiding ( SuccessFlag(..) ) -import Util -import Pair -import DynFlags -import Outputable -import FastString -import ListSetOps -import Var (VarBndr(Bndr)) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Maybe ( maybeToList ) - -{- -************************************************************************ -* * -\subsection{Wired in Ids} -* * -************************************************************************ - -Note [Wired-in Ids] -~~~~~~~~~~~~~~~~~~~ -A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') -rather than by looking it up its name in some environment or fetching -it from an interface file. - -There are several reasons why an Id might appear in the wiredInIds: - -* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] - -* magicIds: see Note [magicIds] - -* errorIds, defined in coreSyn/MkCore.hs. - These error functions (e.g. rUNTIME_ERROR_ID) are wired in - because the desugarer generates code that mentions them directly - -In all cases except ghcPrimIds, there is a definition site in a -library module, which may be called (e.g. in higher order situations); -but the wired-in version means that the details are never read from -that module's interface file; instead, the full definition is right -here. - -Note [ghcPrimIds (aka pseudoops)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ghcPrimIds - - * Are exported from GHC.Prim - - * Can't be defined in Haskell, and hence no Haskell binding site, - but have perfectly reasonable unfoldings in Core - - * Either have a CompulsoryUnfolding (hence always inlined), or - of an EvaldUnfolding and void representation (e.g. void#) - - * Are (or should be) defined in primops.txt.pp as 'pseudoop' - Reason: that's how we generate documentation for them - -Note [magicIds] -~~~~~~~~~~~~~~~ -The magicIds - - * Are exported from GHC.Magic - - * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). - This definition at least generates Haddock documentation for them. - - * May or may not have a CompulsoryUnfolding. - - * But have some special behaviour that can't be done via an - unfolding from an interface file --} - -wiredInIds :: [Id] -wiredInIds - = magicIds - ++ ghcPrimIds - ++ errorIds -- Defined in MkCore - -magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId] - -ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] -ghcPrimIds - = [ realWorldPrimId - , voidPrimId - , unsafeCoerceId - , nullAddrId - , seqId - , magicDictId - , coerceId - , proxyHashId - ] - -{- -************************************************************************ -* * -\subsection{Data constructors} -* * -************************************************************************ - -The wrapper for a constructor is an ordinary top-level binding that evaluates -any strict args, unboxes any args that are going to be flattened, and calls -the worker. - -We're going to build a constructor that looks like: - - data (Data a, C b) => T a b = T1 !a !Int b - - T1 = /\ a b -> - \d1::Data a, d2::C b -> - \p q r -> case p of { p -> - case q of { q -> - Con T1 [a,b] [p,q,r]}} - -Notice that - -* d2 is thrown away --- a context in a data decl is used to make sure - one *could* construct dictionaries at the site the constructor - is used, but the dictionary isn't actually used. - -* We have to check that we can construct Data dictionaries for - the types a and Int. Once we've done that we can throw d1 away too. - -* We use (case p of q -> ...) to evaluate p, rather than "seq" because - all that matters is that the arguments are evaluated. "seq" is - very careful to preserve evaluation order, which we don't need - to be here. - - You might think that we could simply give constructors some strictness - info, like PrimOps, and let CoreToStg do the let-to-case transformation. - But we don't do that because in the case of primops and functions strictness - is a *property* not a *requirement*. In the case of constructors we need to - do something active to evaluate the argument. - - Making an explicit case expression allows the simplifier to eliminate - it in the (common) case where the constructor arg is already evaluated. - -Note [Wrappers for data instance tycons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of data instances, the wrapper also applies the coercion turning -the representation type into the family instance type to cast the result of -the wrapper. For example, consider the declarations - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -The tycon to which the datacon MapPair belongs gets a unique internal -name of the form :R123Map, and we call it the representation tycon. -In contrast, Map is the family tycon (accessible via -tyConFamInst_maybe). A coercion allows you to move between -representation and family type. It is accessible from :R123Map via -tyConFamilyCoercion_maybe and has kind - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -The wrapper and worker of MapPair get the types - - -- Wrapper - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) - - -- Worker - MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -This coercion is conditionally applied by wrapFamInstBody. - -It's a bit more complicated if the data instance is a GADT as well! - - data instance T [a] where - T1 :: forall b. b -> T [Maybe b] - -Hence we translate to - - -- Wrapper - $WT1 :: forall b. b -> T [Maybe b] - $WT1 b v = T1 (Maybe b) b (Maybe b) v - `cast` sym (Co7T (Maybe b)) - - -- Worker - T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c - - -- Coercion from family type to representation type - Co7T a :: T [a] ~ :R7T a - -Newtype instances through an additional wrinkle into the mix. Consider the -following example (adapted from #15318, comment:2): - - data family T a - newtype instance T [a] = MkT [a] - -Within the newtype instance, there are three distinct types at play: - -1. The newtype's underlying type, [a]. -2. The instance's representation type, TList a (where TList is the - representation tycon). -3. The family type, T [a]. - -We need two coercions in order to cast from (1) to (3): - -(a) A newtype coercion axiom: - - axiom coTList a :: TList a ~ [a] - - (Where TList is the representation tycon of the newtype instance.) - -(b) A data family instance coercion axiom: - - axiom coT a :: T [a] ~ TList a - -When we translate the newtype instance to Core, we obtain: - - -- Wrapper - $WMkT :: forall a. [a] -> T [a] - $WMkT a x = MkT a x |> Sym (coT a) - - -- Worker - MkT :: forall a. [a] -> TList [a] - MkT a x = x |> Sym (coTList a) - -Unlike for data instances, the worker for a newtype instance is actually an -executable function which expands to a cast, but otherwise, the general -strategy is essentially the same as for data instances. Also note that we have -a wrapper, which is unusual for a newtype, but we make GHC produce one anyway -for symmetry with the way data instances are handled. - -Note [Newtype datacons] -~~~~~~~~~~~~~~~~~~~~~~~ -The "data constructor" for a newtype should always be vanilla. At one -point this wasn't true, because the newtype arising from - class C a => D a -looked like - newtype T:D a = D:D (C a) -so the data constructor for T:C had a single argument, namely the -predicate (C a). But now we treat that as an ordinary argument, not -part of the theta-type, so all is well. - -Note [Newtype workers] -~~~~~~~~~~~~~~~~~~~~~~ -A newtype does not really have a worker. Instead, newtype constructors -just unfold into a cast. But we need *something* for, say, MkAge to refer -to. So, we do this: - -* The Id used as the newtype worker will have a compulsory unfolding to - a cast. See Note [Compulsory newtype unfolding] - -* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, - as those have special treatment in the back end. - -* There is no top-level binding, because the compulsory unfolding - means that it will be inlined (to a cast) at every call site. - -We probably should have a NewtypeWorkId, but these Ids disappear as soon as -we desugar anyway, so it seems a step too far. - -Note [Compulsory newtype unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Newtype wrappers, just like workers, have compulsory unfoldings. -This is needed so that two optimizations involving newtypes have the same -effect whether a wrapper is present or not: - -(1) Case-of-known constructor. - See Note [beta-reduction in exprIsConApp_maybe]. - -(2) Matching against the map/coerce RULE. Suppose we have the RULE - - {-# RULE "map/coerce" map coerce = ... #-} - - As described in Note [Getting the map/coerce RULE to work], - the occurrence of 'coerce' is transformed into: - - {-# RULE "map/coerce" forall (c :: T1 ~R# T2). - map ((\v -> v) `cast` c) = ... #-} - - We'd like 'map Age' to match the LHS. For this to happen, Age - must be unfolded, otherwise we'll be stuck. This is tested in T16208. - -It also allows for the posssibility of levity polymorphic newtypes -with wrappers (with -XUnliftedNewtypes): - - newtype N (a :: TYPE r) = MkN a - -With -XUnliftedNewtypes, this is allowed -- even though MkN is levity- -polymorphic. It's OK because MkN evaporates in the compiled code, becoming -just a cast. That is, it has a compulsory unfolding. As long as its -argument is not levity-polymorphic (which it can't be, according to -Note [Levity polymorphism invariants] in CoreSyn), and it's saturated, -no levity-polymorphic code ends up in the code generator. The saturation -condition is effectively checked by Note [Detecting forced eta expansion] -in DsExpr. - -However, if we make a *wrapper* for a newtype, we get into trouble. -The saturation condition is no longer checked (because hasNoBinding -returns False) and indeed we generate a forbidden levity-polymorphic -binding. - -The solution is simple, though: just make the newtype wrappers -as ephemeral as the newtype workers. In other words, give the wrappers -compulsory unfoldings and no bindings. The compulsory unfolding is given -in wrap_unf in mkDataConRep, and the lack of a binding happens in -TidyPgm.getTyConImplicitBinds, where we say that a newtype has no implicit -bindings. - -************************************************************************ -* * -\subsection{Dictionary selectors} -* * -************************************************************************ - -Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. - -Dictionary selectors may get nested forall-types. Thus: - - class Foo a where - op :: forall b. Ord b => a -> b -> b - -Then the top-level type for op is - - op :: forall a. Foo a => - forall b. Ord b => - a -> b -> b - --} - -mkDictSelId :: Name -- Name of one of the *value* selectors - -- (dictionary superclass or method) - -> Class -> Id -mkDictSelId name clas - = mkGlobalId (ClassOpId clas) name sel_ty info - where - tycon = classTyCon clas - sel_names = map idName (classAllSelIds clas) - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUserTyVarBinders data_con - n_ty_args = length tyvars - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name - - sel_ty = mkForAllTys tyvars $ - mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ - getNth arg_tys val_index - - base_info = noCafIdInfo - `setArityInfo` 1 - `setStrictnessInfo` strict_sig - `setLevityInfoWithType` sel_ty - - info | new_tycon - = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - (mkDictSelRhs clas val_index) - -- See Note [Single-method classes] in TcInstDcls - -- for why alwaysInlinePragma - - | otherwise - = base_info `setRuleInfo` mkRuleInfo [rule] - -- Add a magic BuiltinRule, but no unfolding - -- so that the rule is always available to fire. - -- See Note [ClassOp/DFun selection] in TcInstDcls - - -- This is the built-in rule that goes - -- op (dfT d1 d2) ---> opT d1 d2 - rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` - occNameFS (getOccName name) - , ru_fn = name - , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args } - - -- The strictness signature is of the form U(AAAVAAAA) -> T - -- where the V depends on which item we are selecting - -- It's worth giving one, so that absence info etc is generated - -- even if the selector isn't inlined - - strict_sig = mkClosedStrictSig [arg_dmd] topRes - arg_dmd | new_tycon = evalDmd - | otherwise = mkManyUsedDmd $ - mkProdDmd [ if name == sel_name then evalDmd else absDmd - | sel_name <- sel_names ] - -mkDictSelRhs :: Class - -> Int -- 0-indexed selector among (superclasses ++ methods) - -> CoreExpr -mkDictSelRhs clas val_index - = mkLams tyvars (Lam dict_id rhs_body) - where - tycon = classTyCon clas - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - - the_arg_id = getNth arg_ids val_index - pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 pred - arg_ids = mkTemplateLocalsNum 2 arg_tys - - rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) - (Var dict_id) - | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) - arg_ids (varToCoreExpr the_arg_id) - -- varToCoreExpr needed for equality superclass selectors - -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } - -dictSelRule :: Int -> Arity -> RuleFun --- Tries to persuade the argument to look like a constructor --- application, using exprIsConApp_maybe, and then selects --- from it --- sel_i t1..tk (D t1..tk op1 ... opm) = opi --- -dictSelRule val_index n_ty_args _ id_unf _ args - | (dict_arg : _) <- drop n_ty_args args - , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - = Just (wrapFloats floats $ getNth con_args val_index) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Data constructors -* * -************************************************************************ --} - -mkDataConWorkId :: Name -> DataCon -> Id -mkDataConWorkId wkr_name data_con - | isNewTyCon tycon - = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info - -- See Note [Newtype workers] - - | otherwise - = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info - - where - tycon = dataConTyCon data_con -- The representation TyCon - wkr_ty = dataConRepType data_con - - ----------- Workers for data types -------------- - alg_wkr_info = noCafIdInfo - `setArityInfo` wkr_arity - `setStrictnessInfo` wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, - -- even if arity = 0 - `setLevityInfoWithType` wkr_ty - -- NB: unboxed tuples have workers, so we can't use - -- setNeverLevPoly - - wkr_arity = dataConRepArity data_con - wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) - -- Note [Data-con worker strictness] - -- Notice that we do *not* say the worker Id is strict - -- even if the data constructor is declared strict - -- e.g. data T = MkT !(Int,Int) - -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has - -- case expressions that do the evals) but the *worker* MkT itself is - -- not. If we pretend it is strict then when we see - -- case x of y -> MkT y - -- the simplifier thinks that y is "sure to be evaluated" (because - -- the worker MkT is strict) and drops the case. No, the workerId - -- MkT is not strict. - -- - -- However, the worker does have StrictnessMarks. When the simplifier - -- sees a pattern - -- case e of MkT x -> ... - -- it uses the dataConRepStrictness of MkT to mark x as evaluated; - -- but that's fine... dataConRepStrictness comes from the data con - -- not from the worker Id. - - ----------- Workers for newtypes -------------- - univ_tvs = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys - nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` 1 -- Arity 1 - `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` newtype_unf - `setLevityInfoWithType` wkr_ty - id_arg1 = mkTemplateLocal 1 (head arg_tys) - res_ty_args = mkTyCoVarTys univ_tvs - newtype_unf = ASSERT2( isVanillaDataCon data_con && - isSingleton arg_tys - , ppr data_con ) - -- Note [Newtype datacons] - mkCompulsoryUnfolding $ - mkLams univ_tvs $ Lam id_arg1 $ - wrapNewTypeBody tycon res_ty_args (Var id_arg1) - -dataConCPR :: DataCon -> DmdResult -dataConCPR con - | isDataTyCon tycon -- Real data types only; that is, - -- not unboxed tuples or newtypes - , null (dataConExTyCoVars con) -- No existentials - , wkr_arity > 0 - , wkr_arity <= mAX_CPR_SIZE - = if is_prod then vanillaCprProdRes (dataConRepArity con) - else cprSumRes (dataConTag con) - | otherwise - = topRes - where - is_prod = isProductTyCon tycon - tycon = dataConTyCon con - wkr_arity = dataConRepArity con - - mAX_CPR_SIZE :: Arity - mAX_CPR_SIZE = 10 - -- We do not treat very big tuples as CPR-ish: - -- a) for a start we get into trouble because there aren't - -- "enough" unboxed tuple types (a tiresome restriction, - -- but hard to fix), - -- b) more importantly, big unboxed tuples get returned mainly - -- on the stack, and are often then allocated in the heap - -- by the caller. So doing CPR for them may in fact make - -- things worse. - -{- -------------------------------------------------- --- Data constructor representation --- --- This is where we decide how to wrap/unwrap the --- constructor fields --- --------------------------------------------------- --} - -type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) - -- Unbox: bind rep vars by decomposing src var - -data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) - -- Box: build src arg using these rep vars - --- | Data Constructor Boxer -newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) - -- Bind these src-level vars, returning the - -- rep-level vars to bind in the pattern - -{- -Note [Inline partially-applied constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We allow the wrapper to inline when partially applied to avoid -boxing values unnecessarily. For example, consider - - data Foo a = Foo !Int a - - instance Traversable Foo where - traverse f (Foo i a) = Foo i <$> f a - -This desugars to - - traverse f foo = case foo of - Foo i# a -> let i = I# i# - in map ($WFoo i) (f a) - -If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. -But if we inline the wrapper, we get - - map (\a. case i of I# i# a -> Foo i# a) (f a) - -and now case-of-known-constructor eliminates the redundant allocation. - --} - -mkDataConRep :: DynFlags - -> FamInstEnvs - -> Name - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] - -> DataCon - -> UniqSM DataConRep -mkDataConRep dflags fam_envs wrap_name mb_bangs data_con - | not wrapper_reqd - = return NoDataConRep - - | otherwise - = do { wrap_args <- mapM newLocal wrap_arg_tys - ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) - initial_wrap_app - - ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info - wrap_info = noCafIdInfo - `setArityInfo` wrap_arity - -- It's important to specify the arity, so that partial - -- applications are treated as values - `setInlinePragInfo` wrap_prag - `setUnfoldingInfo` wrap_unf - `setStrictnessInfo` wrap_sig - -- We need to get the CAF info right here because TidyPgm - -- does not tidy the IdInfo of implicit bindings (like the wrapper) - -- so it not make sure that the CAF info is sane - `setLevityInfoWithType` wrap_ty - - wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con) - - wrap_arg_dmds = - replicate (length theta) topDmd ++ map mk_dmd arg_ibangs - -- Don't forget the dictionary arguments when building - -- the strictness signature (#14290). - - mk_dmd str | isBanged str = evalDmd - | otherwise = topDmd - - wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` - activeDuringFinal - -- See Note [Activation for data constructor wrappers] - - -- The wrapper will usually be inlined (see wrap_unf), so its - -- strictness and CPR info is usually irrelevant. But this is - -- not always the case; GHC may choose not to inline it. In - -- particular, the wrapper constructor is not inlined inside - -- an INLINE rhs or when it is not applied to any arguments. - -- See Note [Inline partially-applied constructor wrappers] - -- Passing Nothing here allows the wrapper to inline when - -- unsaturated. - wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs - -- See Note [Compulsory newtype unfolding] - | otherwise = mkInlineUnfolding wrap_rhs - wrap_rhs = mkLams wrap_tvs $ - mkLams wrap_args $ - wrapFamInstBody tycon res_ty_args $ - wrap_body - - ; return (DCR { dcr_wrap_id = wrap_id - , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - -- For newtypes, dcr_bangs is always [HsLazy]. - -- See Note [HsImplBangs for newtypes]. - , dcr_bangs = arg_ibangs }) } - - where - (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) - = dataConFullSig data_con - wrap_tvs = dataConUserTyVars data_con - res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs - - tycon = dataConTyCon data_con -- The representation TyCon (not family) - wrap_ty = dataConUserType data_con - ev_tys = eqSpecPreds eq_spec ++ theta - all_arg_tys = ev_tys ++ orig_arg_tys - ev_ibangs = map (const HsLazy) ev_tys - orig_bangs = dataConSrcBangs data_con - - wrap_arg_tys = theta ++ orig_arg_tys - wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys - -- The wrap_args are the arguments *other than* the eq_spec - -- Because we are going to apply the eq_spec args manually in the - -- wrapper - - new_tycon = isNewTyCon tycon - arg_ibangs - | new_tycon - = ASSERT( isSingleton orig_arg_tys ) - [HsLazy] -- See Note [HsImplBangs for newtypes] - | otherwise - = case mb_bangs of - Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) - orig_arg_tys orig_bangs - Just bangs -> bangs - - (rep_tys_w_strs, wrappers) - = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) - - (unboxers, boxers) = unzip wrappers - (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) - - wrapper_reqd = - (not new_tycon - -- (Most) newtypes have only a worker, with the exception - -- of some newtypes written with GADT syntax. See below. - && (any isBanged (ev_ibangs ++ arg_ibangs) - -- Some forcing/unboxing (includes eq_spec) - || (not $ null eq_spec))) -- GADT - || isFamInstTyCon tycon -- Cast result - || dataConUserTyVarsArePermuted data_con - -- If the data type was written with GADT syntax and - -- orders the type variables differently from what the - -- worker expects, it needs a data con wrapper to reorder - -- the type variables. - -- See Note [Data con wrappers and GADT syntax]. - - initial_wrap_app = Var (dataConWorkId data_con) - `mkTyApps` res_ty_args - `mkVarApps` ex_tvs - `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec - - mk_boxer :: [Boxer] -> DataConBoxer - mk_boxer boxers = DCB (\ ty_args src_vars -> - do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars - subst1 = zipTvSubst univ_tvs ty_args - subst2 = extendTCvSubstList subst1 ex_tvs - (mkTyCoVarTys ex_vars) - ; (rep_ids, binds) <- go subst2 boxers term_vars - ; return (ex_vars ++ rep_ids, binds) } ) - - go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) - go subst (UnitBox : boxers) (src_var : src_vars) - = do { (rep_ids2, binds) <- go subst boxers src_vars - ; return (src_var : rep_ids2, binds) } - go subst (Boxer boxer : boxers) (src_var : src_vars) - = do { (rep_ids1, arg) <- boxer subst - ; (rep_ids2, binds) <- go subst boxers src_vars - ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } - go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) - - mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr - mk_rep_app [] con_app - = return con_app - mk_rep_app ((wrap_arg, unboxer) : prs) con_app - = do { (rep_ids, unbox_fn) <- unboxer wrap_arg - ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) - ; return (unbox_fn expr) } - -{- Note [Activation for data constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Activation on a data constructor wrapper allows it to inline only in Phase -0. This way rules have a chance to fire if they mention a data constructor on -the left - RULE "foo" f (K a b) = ... -Since the LHS of rules are simplified with InitialPhase, we won't -inline the wrapper on the LHS either. - -On the other hand, this means that exprIsConApp_maybe must be able to deal -with wrappers so that case-of-constructor is not delayed; see -Note [exprIsConApp_maybe on data constructors with wrappers] for details. - -It used to activate in phases 2 (afterInitial) and later, but it makes it -awkward to write a RULE[1] with a constructor on the left: it would work if a -constructor has no wrapper, but whether a constructor has a wrapper depends, for -instance, on the order of type argument of that constructors. Therefore changing -the order of type argument could make previously working RULEs fail. - -See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . - - -Note [Bangs on imported data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs -from imported modules. - -- Nothing <=> use HsSrcBangs -- Just bangs <=> use HsImplBangs - -For imported types we can't work it all out from the HsSrcBangs, -because we want to be very sure to follow what the original module -(where the data type was declared) decided, and that depends on what -flags were enabled when it was compiled. So we record the decisions in -the interface file. - -The HsImplBangs passed are in 1-1 correspondence with the -dataConOrigArgTys of the DataCon. - -Note [Data con wrappers and unlifted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT !Int# - -We certainly do not want to make a wrapper - $WMkT x = case x of y { DEFAULT -> MkT y } - -For a start, it's still to generate a no-op. But worse, since wrappers -are currently injected at TidyCore, we don't even optimise it away! -So the stupid case expression stays there. This actually happened for -the Integer data type (see #1600 comment:66)! - -Note [Data con wrappers and GADT syntax] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these two very similar data types: - - data T1 a b = MkT1 b - - data T2 a b where - MkT2 :: forall b a. b -> T2 a b - -Despite their similar appearance, T2 will have a data con wrapper but T1 will -not. What sets them apart? The types of their constructors, which are: - - MkT1 :: forall a b. b -> T1 a b - MkT2 :: forall b a. b -> T2 a b - -MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` -would normally appear. See Note [DataCon user type variable binders] in DataCon -for further discussion on this topic. - -The worker data cons for T1 and T2, however, both have types such that `a` is -expected to come before `b` as arguments. Because MkT2 permutes this order, it -needs a data con wrapper to swizzle around the type variables to be in the -order the worker expects. - -A somewhat surprising consequence of this is that *newtypes* can have data con -wrappers! After all, a newtype can also be written with GADT syntax: - - newtype T3 a b where - MkT3 :: forall b a. b -> T3 a b - -Again, this needs a wrapper data con to reorder the type variables. It does -mean that this newtype constructor requires another level of indirection when -being called, but the inliner should make swift work of that. - -Note [HsImplBangs for newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the time, we use the dataConSrctoImplBang function to decide what -strictness/unpackedness to use for the fields of a data type constructor. But -there is an exception to this rule: newtype constructors. You might not think -that newtypes would pose a challenge, since newtypes are seemingly forbidden -from having strictness annotations in the first place. But consider this -(from #16141): - - {-# LANGUAGE StrictData #-} - {-# OPTIONS_GHC -O #-} - newtype T a b where - MkT :: forall b a. Int -> T a b - -Because StrictData (plus optimization) is enabled, invoking -dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! -This would be disastrous, since the wrapper for `MkT` uses a coercion involving -Int, not Int#. - -Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the -case of a newtype constructor, we simply hardcode its dcr_bangs field to -[HsLazy]. --} - -------------------------- -newLocal :: Type -> UniqSM Var -newLocal ty = do { uniq <- getUniqueM - ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } - --- | Unpack/Strictness decisions from source module. --- --- This function should only ever be invoked for data constructor fields, and --- never on the field of a newtype constructor. --- See @Note [HsImplBangs for newtypes]@. -dataConSrcToImplBang - :: DynFlags - -> FamInstEnvs - -> Type - -> HsSrcBang - -> HsImplBang - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk NoSrcStrict) - | xopt LangExt.StrictData dflags -- StrictData => strict field - = dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk SrcStrict) - | otherwise -- no StrictData => lazy field - = HsLazy - -dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) - = HsLazy - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang _ unpk_prag SrcStrict) - | isUnliftedType arg_ty - = HsLazy -- For !Int#, say, use HsLazy - -- See Note [Data con wrappers and unlifted types] - - | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas - -- Don't unpack if we aren't optimising; rather arbitrarily, - -- we use -fomit-iface-pragmas as the indication - , let mb_co = topNormaliseType_maybe fam_envs arg_ty - -- Unwrap type families and newtypes - arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } - , isUnpackableType dflags fam_envs arg_ty' - , (rep_tys, _) <- dataConArgUnpack arg_ty' - , case unpk_prag of - NoSrcUnpack -> - gopt Opt_UnboxStrictFields dflags - || (gopt Opt_UnboxSmallStrictFields dflags - && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] - srcUnpack -> isSrcUnpacked srcUnpack - = case mb_co of - Nothing -> HsUnpack Nothing - Just (co,_) -> HsUnpack (Just co) - - | otherwise -- Record the strict-but-no-unpack decision - = HsStrict - - --- | Wrappers/Workers and representation following Unpack/Strictness --- decisions -dataConArgRep - :: Type - -> HsImplBang - -> ([(Type,StrictnessMark)] -- Rep types - ,(Unboxer,Boxer)) - -dataConArgRep arg_ty HsLazy - = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) - -dataConArgRep arg_ty HsStrict - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) - -dataConArgRep arg_ty (HsUnpack Nothing) - | (rep_tys, wrappers) <- dataConArgUnpack arg_ty - = (rep_tys, wrappers) - -dataConArgRep _ (HsUnpack (Just co)) - | let co_rep_ty = pSnd (coercionKind co) - , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty - = (rep_tys, wrapCo co co_rep_ty wrappers) - - -------------------------- -wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) -wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty - = (unboxer, boxer) - where - unboxer arg_id = do { rep_id <- newLocal rep_ty - ; (rep_ids, rep_fn) <- unbox_rep rep_id - ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) - ; return (rep_ids, Let co_bind . rep_fn) } - boxer = Boxer $ \ subst -> - do { (rep_ids, rep_expr) - <- case box_rep of - UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) - ; return ([rep_id], Var rep_id) } - Boxer boxer -> boxer subst - ; let sco = substCoUnchecked subst co - ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } - ------------------------- -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], mkDefaultCase (Var v) v) - -unitUnboxer :: Unboxer -unitUnboxer v = return ([v], \e -> e) - -unitBoxer :: Boxer -unitBoxer = UnitBox - -------------------------- -dataConArgUnpack - :: Type - -> ( [(Type, StrictnessMark)] -- Rep types - , (Unboxer, Boxer) ) - -dataConArgUnpack arg_ty - | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty - , Just con <- tyConSingleAlgDataCon_maybe tc - -- NB: check for an *algebraic* data type - -- A recursive newtype might mean that - -- 'arg_ty' is a newtype - , let rep_tys = dataConInstArgTys con tc_args - = ASSERT( null (dataConExTyCoVars con) ) - -- Note [Unpacking GADTs and existentials] - ( rep_tys `zip` dataConRepStrictness con - ,( \ arg_id -> - do { rep_ids <- mapM newLocal rep_tys - ; let unbox_fn body - = mkSingleAltCase (Var arg_id) arg_id - (DataAlt con) rep_ids body - ; return (rep_ids, unbox_fn) } - , Boxer $ \ subst -> - do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys - ; return (rep_ids, Var (dataConWorkId con) - `mkTyApps` (substTysUnchecked subst tc_args) - `mkVarApps` rep_ids ) } ) ) - | otherwise - = pprPanic "dataConArgUnpack" (ppr arg_ty) - -- An interface file specified Unpacked, but we couldn't unpack it - -isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool --- True if we can unpack the UNPACK the argument type --- See Note [Recursive unboxing] --- We look "deeply" inside rather than relying on the DataCons --- we encounter on the way, because otherwise we might well --- end up relying on ourselves! -isUnpackableType dflags fam_envs ty - | Just data_con <- unpackable_type ty - = ok_con_args emptyNameSet data_con - | otherwise - = False - where - ok_con_args dcs con - | dc_name `elemNameSet` dcs - = False - | otherwise - = all (ok_arg dcs') - (dataConOrigArgTys con `zip` dataConSrcBangs con) - -- NB: dataConSrcBangs gives the *user* request; - -- We'd get a black hole if we used dataConImplBangs - where - dc_name = getName con - dcs' = dcs `extendNameSet` dc_name - - ok_arg dcs (ty, bang) - = not (attempt_unpack bang) || ok_ty dcs norm_ty - where - norm_ty = topNormaliseType fam_envs ty - - ok_ty dcs ty - | Just data_con <- unpackable_type ty - = ok_con_args dcs data_con - | otherwise - = True -- NB True here, in contrast to False at top level - - attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags - attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) - = True - attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) - = True -- Be conservative - attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags -- Be conservative - attempt_unpack _ = False - - unpackable_type :: Type -> Maybe DataCon - -- Works just on a single level - unpackable_type ty - | Just (tc, _) <- splitTyConApp_maybe ty - , Just data_con <- tyConSingleAlgDataCon_maybe tc - , null (dataConExTyCoVars data_con) - -- See Note [Unpacking GADTs and existentials] - = Just data_con - | otherwise - = Nothing - -{- -Note [Unpacking GADTs and existentials] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is nothing stopping us unpacking a data type with equality -components, like - data Equal a b where - Equal :: Equal a a - -And it'd be fine to unpack a product type with existential components -too, but that would require a bit more plumbing, so currently we don't. - -So for now we require: null (dataConExTyCoVars data_con) -See #14978 - -Note [Unpack one-wide fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The flag UnboxSmallStrictFields ensures that any field that can -(safely) be unboxed to a word-sized unboxed field, should be so unboxed. -For example: - - data A = A Int# - newtype B = B A - data C = C !B - data D = D !C - data E = E !() - data F = F !D - data G = G !F !F - -All of these should have an Int# as their representation, except -G which should have two Int#s. - -However - - data T = T !(S Int) - data S = S !a - -Here we can represent T with an Int#. - -Note [Recursive unboxing] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data R = MkR {-# UNPACK #-} !S Int - data S = MkS {-# UNPACK #-} !Int -The representation arguments of MkR are the *representation* arguments -of S (plus Int); the rep args of MkS are Int#. This is all fine. - -But be careful not to try to unbox this! - data T = MkT {-# UNPACK #-} !T Int -Because then we'd get an infinite number of arguments. - -Here is a more complicated case: - data S = MkS {-# UNPACK #-} !T Int - data T = MkT {-# UNPACK #-} !S Int -Each of S and T must decide independently whether to unpack -and they had better not both say yes. So they must both say no. - -Also behave conservatively when there is no UNPACK pragma - data T = MkS !T Int -with -funbox-strict-fields or -funbox-small-strict-fields -we need to behave as if there was an UNPACK pragma there. - -But it's the *argument* type that matters. This is fine: - data S = MkS S !Int -because Int is non-recursive. - -************************************************************************ -* * - Wrapping and unwrapping newtypes and type families -* * -************************************************************************ --} - -wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr --- The wrapper for the data constructor for a newtype looks like this: --- newtype T a = MkT (a,Int) --- MkT :: forall a. (a,Int) -> T a --- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) --- where CoT is the coercion TyCon associated with the newtype --- --- The call (wrapNewTypeBody T [a] e) returns the --- body of the wrapper, namely --- e `cast` (CoT [a]) --- --- If a coercion constructor is provided in the newtype, then we use --- it, otherwise the wrap/unwrap are both no-ops - -wrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkSymCo co) - where - co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] - --- When unwrapping, we do *not* apply any family coercion, because this will --- be done via a CoPat by the type checker. We have to do it this way as --- computing the right type arguments for the coercion requires more than just --- a spliting operation (cf, TcPat.tcConPat). - -unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -unwrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) - --- If the type constructor is a representation type of a data instance, wrap --- the expression into a cast adjusting the expression type, which is an --- instance of the representation type, to the corresponding instance of the --- family instance type. --- See Note [Wrappers for data instance tycons] -wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -wrapFamInstBody tycon args body - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) - | otherwise - = body - -{- -************************************************************************ -* * -\subsection{Primitive operations} -* * -************************************************************************ --} - -mkPrimOpId :: PrimOp -> Id -mkPrimOpId prim_op - = id - where - (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op - ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) - name = mkWiredInName gHC_PRIM (primOpOcc prim_op) - (mkPrimOpIdUnique (primOpTag prim_op)) - (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op) name ty info - - info = noCafIdInfo - `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setInlinePragInfo` neverInlinePragma - `setLevityInfoWithType` res_ty - -- We give PrimOps a NOINLINE pragma so that we don't - -- get silly warnings from Desugar.dsRule (the inline_shadows_rule - -- test) about a RULE conflicting with a possible inlining - -- cf #7287 - --- For each ccall we manufacture a separate CCallOpId, giving it --- a fresh unique, a type that is correct for this particular ccall, --- and a CCall structure that gives the correct details about calling --- convention etc. --- --- The *name* of this Id is a local name whose OccName gives the full --- details of the ccall, type and all. This means that the interface --- file reader can reconstruct a suitable Id - -mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id -mkFCallId dflags uniq fcall ty - = ASSERT( noFreeVarsOfType ty ) - -- A CCallOpId should have no free type variables; - -- when doing substitutions won't substitute over it - mkGlobalId (FCallId fcall) name ty info - where - occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) - -- The "occurrence name" of a ccall is the full info about the - -- ccall; it is encoded, but may have embedded spaces etc! - - name = mkFCallName uniq occ_str - - info = noCafIdInfo - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setLevityInfoWithType` ty - - (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyCoBinder bndrs - strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes - -- the call does not claim to be strict in its arguments, since they - -- may be lifted (foreign import prim) and the called code doesn't - -- necessarily force them. See #11076. -{- -************************************************************************ -* * -\subsection{DictFuns and default methods} -* * -************************************************************************ - -Note [Dict funs and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dict funs and default methods are *not* ImplicitIds. Their definition -involves user-written code, so we can't figure out their strictness etc -based on fixed info, as we can for constructors and record selectors (say). - -NB: See also Note [Exported LocalIds] in Id --} - -mkDictFunId :: Name -- Name to use for the dict fun; - -> [TyVar] - -> ThetaType - -> Class - -> [Type] - -> Id --- Implements the DFun Superclass Invariant (see TcInstDcls) --- See Note [Dict funs and default methods] - -mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalId (DFunId is_nt) - dfun_name - dfun_ty - where - is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkDictFunTy tvs theta clas tys - -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type -mkDictFunTy tvs theta clas tys - = mkSpecSigmaTy tvs theta (mkClassPred clas tys) - -{- -************************************************************************ -* * -\subsection{Un-definable} -* * -************************************************************************ - -These Ids can't be defined in Haskell. They could be defined in -unfoldings in the wired-in GHC.Prim interface file, but we'd have to -ensure that they were definitely, definitely inlined, because there is -no curried identifier for them. That's what mkCompulsoryUnfolding -does. If we had a way to get a compulsory unfolding from an interface -file, we could do that, but we don't right now. - -unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that -just gets expanded into a type coercion wherever it occurs. Hence we -add it as a built-in Id with an unfolding here. - -The type variables we use here are "open" type variables: this means -they can unify with both unlifted and lifted types. Hence we provide -another gun with which to shoot yourself in the foot. --} - -unsafeCoerceName, nullAddrName, seqName, - realWorldName, voidPrimIdName, coercionTokenName, - magicDictName, coerceName, proxyName :: Name -unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId -nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId -seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId -realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId -voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId -coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId -magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId -coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId -proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId - -lazyIdName, oneShotName, noinlineIdName :: Name -lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId -oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId - ------------------------------------------------- -proxyHashId :: Id -proxyHashId - = pcMiscPrelId proxyName ty - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` ty ) - where - -- proxy# :: forall {k} (a:k). Proxy# k a - -- - -- The visibility of the `k` binder is Inferred to match the type of the - -- Proxy data constructor (#16293). - [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id - kv_ty = mkTyVarTy kv - tv_ty = mkTyVarTy tv - ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty - ------------------------------------------------- -unsafeCoerceId :: Id -unsafeCoerceId - = pcMiscPrelId unsafeCoerceName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - - -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - -- (a :: TYPE r1) (b :: TYPE r2). - -- a -> b - bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy] - (\ks -> map tYPE ks) - - [_, _, a, b] = mkTyVarTys bndrs - - ty = mkSpecForAllTys bndrs (mkVisFunTy a b) - - [x] = mkTemplateLocals [a] - rhs = mkLams (bndrs ++ [x]) $ - Cast (Var x) (mkUnsafeCo Representational a b) - ------------------------------------------------- -nullAddrId :: Id --- nullAddr# :: Addr# --- The reason it is here is because we don't provide --- a way to write this literal in Haskell. -nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) - `setNeverLevPoly` addrPrimTy - ------------------------------------------------- -seqId :: Id -- See Note [seqId magic] -seqId = pcMiscPrelId seqName ty info - where - info = noCafIdInfo `setInlinePragInfo` inline_prag - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - - inline_prag - = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter - NoSourceText 0 - -- Make 'seq' not inline-always, so that simpleOptExpr - -- (see CoreSubst.simple_app) won't inline 'seq' on the - -- LHS of rules. That way we can have rules for 'seq'; - -- see Note [seqId magic] - - -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b - ty = - mkInvForAllTy runtimeRep2TyVar - $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] - $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) - - [x,y] = mkTemplateLocals [alphaTy, openBetaTy] - rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ - Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] - ------------------------------------------------- -lazyId :: Id -- See Note [lazyId magic] -lazyId = pcMiscPrelId lazyIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) - -noinlineId :: Id -- See Note [noinlineId magic] -noinlineId = pcMiscPrelId noinlineIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) - -oneShotId :: Id -- See Note [The oneShot function] -oneShotId = pcMiscPrelId oneShotName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar ] - (mkVisFunTy fun_ty fun_ty) - fun_ty = mkVisFunTy openAlphaTy openBetaTy - [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] - x' = setOneShotLambda x -- Here is the magic bit! - rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar - , body, x'] $ - Var body `App` Var x - --------------------------------------------------------------------------------- -magicDictId :: Id -- See Note [magicDictId magic] -magicDictId = pcMiscPrelId magicDictName ty info - where - info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] alphaTy - --------------------------------------------------------------------------------- - -coerceId :: Id -coerceId = pcMiscPrelId coerceName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] - ty = mkForAllTys [ Bndr rv Inferred - , Bndr av Specified - , Bndr bv Specified - ] $ - mkInvisFunTy eqRTy $ - mkVisFunTy a b - - bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy - (\r -> [tYPE r, tYPE r]) - - [r, a, b] = mkTyVarTys bndrs - - [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] - rhs = mkLams (bndrs ++ [eqR, x]) $ - mkWildCase (Var eqR) eqRTy b $ - [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] - -{- -Note [Unsafe coerce magic] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We define a *primitive* - GHC.Prim.unsafeCoerce# -and then in the base library we define the ordinary function - Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b - unsafeCoerce x = unsafeCoerce# x - -Notice that unsafeCoerce has a civilized (albeit still dangerous) -polymorphic type, whose type args have kind *. So you can't use it on -unboxed values (unsafeCoerce 3#). - -In contrast unsafeCoerce# is even more dangerous because you *can* use -it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is - forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b - -Note [seqId magic] -~~~~~~~~~~~~~~~~~~ -'GHC.Prim.seq' is special in several ways. - -a) Its fixity is set in LoadIface.ghcPrimIface - -b) It has quite a bit of desugaring magic. - See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3) - -c) There is some special rule handing: Note [User-defined RULES for seq] - -Historical note: - In TcExpr we used to need a special typing rule for 'seq', to handle calls - whose second argument had an unboxed type, e.g. x `seq` 3# - - However, with levity polymorphism we can now give seq the type seq :: - forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this - case without special treatment in the typechecker. - -Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Roman found situations where he had - case (f n) of _ -> e -where he knew that f (which was strict in n) would terminate if n did. -Notice that the result of (f n) is discarded. So it makes sense to -transform to - case n of _ -> e - -Rather than attempt some general analysis to support this, I've added -enough support that you can do this using a rewrite rule: - - RULE "f/seq" forall n. seq (f n) = seq n - -You write that rule. When GHC sees a case expression that discards -its result, it mentally transforms it to a call to 'seq' and looks for -a RULE. (This is done in Simplify.trySeqRules.) As usual, the -correctness of the rule is up to you. - -VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. -If we wrote - RULE "f/seq" forall n e. seq (f n) e = seq n e -with rule arity 2, then two bad things would happen: - - - The magical desugaring done in Note [seqId magic] item (b) - for saturated application of 'seq' would turn the LHS into - a case expression! - - - The code in Simplify.rebuildCase would need to actually supply - the value argument, which turns out to be awkward. - -See also: Note [User-defined RULES for seq] in Simplify. - - -Note [lazyId magic] -~~~~~~~~~~~~~~~~~~~ -lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) - -'lazy' is used to make sure that a sub-expression, and its free variables, -are truly used call-by-need, with no code motion. Key examples: - -* pseq: pseq a b = a `seq` lazy b - We want to make sure that the free vars of 'b' are not evaluated - before 'a', even though the expression is plainly strict in 'b'. - -* catch: catch a b = catch# (lazy a) b - Again, it's clear that 'a' will be evaluated strictly (and indeed - applied to a state token) but we want to make sure that any exceptions - arising from the evaluation of 'a' are caught by the catch (see - #11555). - -Implementing 'lazy' is a bit tricky: - -* It must not have a strictness signature: by being a built-in Id, - all the info about lazyId comes from here, not from GHC.Base.hi. - This is important, because the strictness analyser will spot it as - strict! - -* It must not have an unfolding: it gets "inlined" by a HACK in - CorePrep. It's very important to do this inlining *after* unfoldings - are exposed in the interface file. Otherwise, the unfolding for - (say) pseq in the interface file will not mention 'lazy', so if we - inline 'pseq' we'll totally miss the very thing that 'lazy' was - there for in the first place. See #3259 for a real world - example. - -* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must - avoid using call by value here: - case e of r -> catch# r b - Avoiding that is the whole point of 'lazy'. So in CorePrep (which - generate the 'case' expression for a call-by-value call) we must - spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' - instead. - -* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it - appears un-applied, we'll end up just calling it. - -Note [noinlineId magic] -~~~~~~~~~~~~~~~~~~~~~~~ -noinline :: forall a. a -> a - -'noinline' is used to make sure that a function f is never inlined, -e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE -could be used to achieve this effect; however, this has the unfortunate -result of leaving a (useless) call to noinline at runtime. So we have -a little bit of magic to optimize away 'noinline' after we are done -running the simplifier. - -'noinline' needs to be wired-in because it gets inserted automatically -when we serialize an expression to the interface format. See -Note [Inlining and hs-boot files] in ToIface - -Note that noinline as currently implemented can hide some simplifications since -it hides strictness from the demand analyser. Specifically, the demand analyser -will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' -specifies that it is strict in its argument. We considered fixing this this by adding a -special case to the demand analyser to address #16588. However, the special -case seemed like a large and expensive hammer to address a rare case and -consequently we rather opted to use a more minimal solution. - -Note [The oneShot function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the context of making left-folds fuse somewhat okish (see ticket #7994 -and Note [Left folds via right fold]) it was determined that it would be useful -if library authors could explicitly tell the compiler that a certain lambda is -called at most once. The oneShot function allows that. - -'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted -types as well (#10744); e.g. - oneShot (\x:Int# -> x +# 1#) - -Like most magic functions it has a compulsory unfolding, so there is no need -for a real definition somewhere. We have one in GHC.Magic for the convenience -of putting the documentation there. - -It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: - -A typical call looks like - oneShot (\y. e) -after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get - (\f \x[oneshot]. f x) (\y. e) - --> \x[oneshot]. ((\y.e) x) - --> \x[oneshot] e[x/y] -which is what we want. - -It is only effective if the one-shot info survives as long as possible; in -particular it must make it into the interface in unfoldings. See Note [Preserve -OneShotInfo] in CoreTidy. - -Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. - - -Note [magicDictId magic] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The identifier `magicDict` is just a place-holder, which is used to -implement a primitive that we cannot define in Haskell but we can write -in Core. It is declared with a place-holder type: - - magicDict :: forall a. a - -The intention is that the identifier will be used in a very specific way, -to create dictionaries for classes with a single method. Consider a class -like this: - - class C a where - f :: T a - -We are going to use `magicDict`, in conjunction with a built-in Prelude -rule, to cast values of type `T a` into dictionaries for `C a`. To do -this, we define a function like this in the library: - - data WrapC a b = WrapC (C a => Proxy a -> b) - - withT :: (C a => Proxy a -> b) - -> T a -> Proxy a -> b - withT f x y = magicDict (WrapC f) x y - -The purpose of `WrapC` is to avoid having `f` instantiated. -Also, it avoids impredicativity, because `magicDict`'s type -cannot be instantiated with a forall. The field of `WrapC` contains -a `Proxy` parameter which is used to link the type of the constraint, -`C a`, with the type of the `Wrap` value being made. - -Next, we add a built-in Prelude rule (see prelude/PrelRules.hs), -which will replace the RHS of this definition with the appropriate -definition in Core. The rewrite rule works as follows: - - magicDict @t (wrap @a @b f) x y -----> - f (x `cast` co a) y - -The `co` coercion is the newtype-coercion extracted from the type-class. -The type class is obtain by looking at the type of wrap. - - -------------------------------------------------------------- -@realWorld#@ used to be a magic literal, \tr{void#}. If things get -nasty as-is, change it back to a literal (@Literal@). - -voidArgId is a Local Id used simply as an argument in functions -where we just want an arg to avoid having a thunk of unlifted type. -E.g. - x = \ void :: Void# -> (# p, q #) - -This comes up in strictness analysis - -Note [evaldUnfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The evaldUnfolding makes it look that some primitive value is -evaluated, which in turn makes Simplify.interestingArg return True, -which in turn makes INLINE things applied to said value likely to be -inlined. --} - -realWorldPrimId :: Id -- :: State# RealWorld -realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverLevPoly` realWorldStatePrimTy) - -voidPrimId :: Id -- Global constant :: Void# -voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` voidPrimTy) - -voidArgId :: Id -- Local lambda-bound :: Void# -voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy - -coercionTokenId :: Id -- :: () ~ () -coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs - = pcMiscPrelId coercionTokenName - (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) - noCafIdInfo - -pcMiscPrelId :: Name -> Type -> IdInfo -> Id -pcMiscPrelId name ty info - = mkVanillaGlobalWithInfo name ty info - -- We lie and say the thing is imported; otherwise, we get into - -- a mess with dependency analysis; e.g., core2stg may heave in - -- random calls to GHCbase.unpackPS__. If GHCbase is the module - -- being compiled, then it's just a matter of luck if the definition - -- will be in "the right place" to be in scope. diff --git a/basicTypes/MkId.hs-boot b/basicTypes/MkId.hs-boot deleted file mode 100644 --- a/basicTypes/MkId.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -module MkId where -import Name( Name ) -import Var( Id ) -import Class( Class ) -import {-# SOURCE #-} DataCon( DataCon ) -import {-# SOURCE #-} PrimOp( PrimOp ) - -data DataConBoxer - -mkDataConWorkId :: Name -> DataCon -> Id -mkDictSelId :: Name -> Class -> Id - -mkPrimOpId :: PrimOp -> Id - -magicDictId :: Id diff --git a/basicTypes/Module.hs b/basicTypes/Module.hs deleted file mode 100644 --- a/basicTypes/Module.hs +++ /dev/null @@ -1,1309 +0,0 @@ -{- -(c) The University of Glasgow, 2004-2006 - - -Module -~~~~~~~~~~ -Simply the name of a module, represented as a FastString. -These are Uniquable, hence we can build Maps with Modules as -the keys. --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Module - ( - -- * The ModuleName type - ModuleName, - pprModuleName, - moduleNameFS, - moduleNameString, - moduleNameSlashes, moduleNameColons, - moduleStableString, - moduleFreeHoles, - moduleIsDefinite, - mkModuleName, - mkModuleNameFS, - stableModuleNameCmp, - - -- * The UnitId type - ComponentId(..), - UnitId(..), - unitIdFS, - unitIdKey, - IndefUnitId(..), - IndefModule(..), - indefUnitIdToUnitId, - indefModuleToModule, - InstalledUnitId(..), - toInstalledUnitId, - ShHoleSubst, - - unitIdIsDefinite, - unitIdString, - unitIdFreeHoles, - - newUnitId, - newIndefUnitId, - newSimpleUnitId, - hashUnitId, - fsToUnitId, - stringToUnitId, - stableUnitIdCmp, - - -- * HOLE renaming - renameHoleUnitId, - renameHoleModule, - renameHoleUnitId', - renameHoleModule', - - -- * Generalization - splitModuleInsts, - splitUnitIdInsts, - generalizeIndefUnitId, - generalizeIndefModule, - - -- * Parsers - parseModuleName, - parseUnitId, - parseComponentId, - parseModuleId, - parseModSubst, - - -- * Wired-in UnitIds - -- $wired_in_packages - primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - mainUnitId, - thisGhcUnitId, - isHoleModule, - interactiveUnitId, isInteractiveModule, - wiredInUnitIds, - - -- * The Module type - Module(Module), - moduleUnitId, moduleName, - pprModule, - mkModule, - mkHoleModule, - stableModuleCmp, - HasModule(..), - ContainsModule(..), - - -- * Installed unit ids and modules - InstalledModule(..), - InstalledModuleEnv, - installedModuleEq, - installedUnitIdEq, - installedUnitIdString, - fsToInstalledUnitId, - componentIdToInstalledUnitId, - stringToInstalledUnitId, - emptyInstalledModuleEnv, - lookupInstalledModuleEnv, - extendInstalledModuleEnv, - filterInstalledModuleEnv, - delInstalledModuleEnv, - DefUnitId(..), - - -- * The ModuleLocation type - ModLocation(..), - addBootSuffix, removeBootSuffix, addBootSuffix_maybe, - addBootSuffixLocn, addBootSuffixLocnOut, - - -- * Module mappings - ModuleEnv, - elemModuleEnv, extendModuleEnv, extendModuleEnvList, - extendModuleEnvList_C, plusModuleEnv_C, - delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, - lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, - moduleEnvKeys, moduleEnvElts, moduleEnvToList, - unitModuleEnv, isEmptyModuleEnv, - extendModuleEnvWith, filterModuleEnv, - - -- * ModuleName mappings - ModuleNameEnv, DModuleNameEnv, - - -- * Sets of Modules - ModuleSet, - emptyModuleSet, mkModuleSet, moduleSetElts, - extendModuleSet, extendModuleSetList, delModuleSet, - elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet, - unitModuleSet - ) where - -import GhcPrelude - -import Outputable -import Unique -import UniqFM -import UniqDFM -import UniqDSet -import FastString -import Binary -import Util -import Data.List (sortBy, sort) -import Data.Ord -import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) -import Fingerprint - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS.Char8 -import Encoding - -import qualified Text.ParserCombinators.ReadP as Parse -import Text.ParserCombinators.ReadP (ReadP, (<++)) -import Data.Char (isAlphaNum) -import Control.DeepSeq -import Data.Coerce -import Data.Data -import Data.Function -import Data.Map (Map) -import Data.Set (Set) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified FiniteMap as Map -import System.FilePath - -import {-# SOURCE #-} DynFlags (DynFlags) -import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId) - --- Note [The identifier lexicon] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Unit IDs, installed package IDs, ABI hashes, package names, --- versions, there are a *lot* of different identifiers for closely --- related things. What do they all mean? Here's what. (See also --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) --- --- THE IMPORTANT ONES --- --- ComponentId: An opaque identifier provided by Cabal, which should --- uniquely identify such things as the package name, the package --- version, the name of the component, the hash of the source code --- tarball, the selected Cabal flags, GHC flags, direct dependencies of --- the component. These are very similar to InstalledPackageId, but --- an 'InstalledPackageId' implies that it identifies a package, while --- a package may install multiple components with different --- 'ComponentId's. --- - Same as Distribution.Package.ComponentId --- --- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names --- (ModuleName) to Modules. This is how the compiler identifies instantiated --- components, and also is the main identifier by which GHC identifies things. --- - When Backpack is not being used, UnitId = ComponentId. --- this means a useful fiction for end-users is that there are --- only ever ComponentIds, and some ComponentIds happen to have --- more information (UnitIds). --- - Same as Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - The same as PackageKey in GHC 7.10 (we renamed it because --- they don't necessarily identify packages anymore.) --- - Same as -this-package-key/-package-name flags --- - An InstalledUnitId corresponds to an actual package which --- we have installed on disk. It could be definite or indefinite, --- but if it's indefinite, it has nothing instantiated (we --- never install partially instantiated units.) --- --- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how --- the compiler identifies modules (e.g. a Name is a Module + OccName) --- - Same as Language.Haskell.TH.Syntax:Module --- --- THE LESS IMPORTANT ONES --- --- PackageName: The "name" field in a Cabal file, something like "lens". --- - Same as Distribution.Package.PackageName --- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - DIFFERENT FROM -package-name flag --- - DIFFERENT FROM the 'name' field in an installed package --- information. This field could more accurately be described --- as a munged package name: when it's for the main library --- it is the same as the package name, but if it's an internal --- library it's a munged combination of the package name and --- the component name. --- --- LEGACY ONES --- --- InstalledPackageId: This is what we used to call ComponentId. --- It's a still pretty useful concept for packages that have only --- one library; in that case the logical InstalledPackageId = --- ComponentId. Also, the Cabal nix-local-build continues to --- compute an InstalledPackageId which is then forcibly used --- for all components in a package. This means that if a dependency --- from one component in a package changes, the InstalledPackageId --- changes: you don't get as fine-grained dependency tracking, --- but it means your builds are hermetic. Eventually, Cabal will --- deal completely in components and we can get rid of this. --- --- PackageKey: This is what we used to call UnitId. We ditched --- "Package" from the name when we realized that you might want to --- assign different "PackageKeys" to components from the same package. --- (For a brief, non-released period of time, we also called these --- UnitKeys). - -{- -************************************************************************ -* * -\subsection{Module locations} -* * -************************************************************************ --} - --- | Module Location --- --- Where a module lives on the file system: the actual locations --- of the .hs, .hi and .o files, if we have them -data ModLocation - = ModLocation { - ml_hs_file :: Maybe FilePath, - -- The source file, if we have one. Package modules - -- probably don't have source files. - - ml_hi_file :: FilePath, - -- Where the .hi file is, whether or not it exists - -- yet. Always of form foo.hi, even if there is an - -- hi-boot file (we add the -boot suffix later) - - ml_obj_file :: FilePath, - -- Where the .o file is, whether or not it exists yet. - -- (might not exist either because the module hasn't - -- been compiled yet, or because it is part of a - -- package with a .a file) - ml_hie_file :: FilePath - } deriving Show - -instance Outputable ModLocation where - ppr = text . show - -{- -For a module in another package, the hs_file and obj_file -components of ModLocation are undefined. - -The locations specified by a ModLocation may or may not -correspond to actual files yet: for example, even if the object -file doesn't exist, the ModLocation still contains the path to -where the object file will reside if/when it is created. --} - -addBootSuffix :: FilePath -> FilePath --- ^ Add the @-boot@ suffix to .hs, .hi and .o files -addBootSuffix path = path ++ "-boot" - --- | Remove the @-boot@ suffix to .hs, .hi and .o files -removeBootSuffix :: FilePath -> FilePath -removeBootSuffix "-boot" = [] -removeBootSuffix (x:xs) = x : removeBootSuffix xs -removeBootSuffix [] = error "removeBootSuffix: no -boot suffix" - -addBootSuffix_maybe :: Bool -> FilePath -> FilePath --- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ -addBootSuffix_maybe is_boot path - | is_boot = addBootSuffix path - | otherwise = path - -addBootSuffixLocn :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all file paths associated with the module -addBootSuffixLocn locn - = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) - , ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } - -addBootSuffixLocnOut :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all output file paths associated with the --- module, not including the input file itself -addBootSuffixLocnOut locn - = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } - -{- -************************************************************************ -* * -\subsection{The name of a module} -* * -************************************************************************ --} - --- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString - -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm - -instance Eq ModuleName where - nm1 == nm2 = getUnique nm1 == getUnique nm2 - -instance Ord ModuleName where - nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 - -instance Outputable ModuleName where - ppr = pprModuleName - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - -instance BinaryStringRep ModuleName where - fromStringRep = mkModuleNameFS . mkFastStringByteString - toStringRep = bytesFS . moduleNameFS - -instance Data ModuleName where - -- don't traverse? - toConstr _ = abstractConstr "ModuleName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ModuleName" - -instance NFData ModuleName where - rnf x = x `seq` () - -stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering --- ^ Compares module names lexically, rather than by their 'Unique's -stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS nm) - else ftext nm - -moduleNameFS :: ModuleName -> FastString -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> String -moduleNameString (ModuleName mod) = unpackFS mod - --- | Get a string representation of a 'Module' that's unique and stable --- across recompilations. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" -moduleStableString :: Module -> String -moduleStableString Module{..} = - "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName - -mkModuleName :: String -> ModuleName -mkModuleName s = ModuleName (mkFastString s) - -mkModuleNameFS :: FastString -> ModuleName -mkModuleNameFS s = ModuleName s - --- |Returns the string version of the module name, with dots replaced by slashes. --- -moduleNameSlashes :: ModuleName -> String -moduleNameSlashes = dots_to_slashes . moduleNameString - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- |Returns the string version of the module name, with dots replaced by colons. --- -moduleNameColons :: ModuleName -> String -moduleNameColons = dots_to_colons . moduleNameString - where dots_to_colons = map (\c -> if c == '.' then ':' else c) - -{- -************************************************************************ -* * -\subsection{A fully qualified module} -* * -************************************************************************ --} - --- | A Module is a pair of a 'UnitId' and a 'ModuleName'. --- --- Module variables (i.e. @@) which can be instantiated to a --- specific module at some later point in time are represented --- with 'moduleUnitId' set to 'holeUnitId' (this allows us to --- avoid having to make 'moduleUnitId' a partial operation.) --- -data Module = Module { - moduleUnitId :: !UnitId, -- pkg-1.0 - moduleName :: !ModuleName -- A.B.C - } - deriving (Eq, Ord) - --- | Calculate the free holes of a 'Module'. If this set is non-empty, --- this module was defined in an indefinite library that had required --- signatures. --- --- If a module has free holes, that means that substitutions can operate on it; --- if it has no free holes, substituting over a module has no effect. -moduleFreeHoles :: Module -> UniqDSet ModuleName -moduleFreeHoles m - | isHoleModule m = unitUniqDSet (moduleName m) - | otherwise = unitIdFreeHoles (moduleUnitId m) - --- | A 'Module' is definite if it has no free holes. -moduleIsDefinite :: Module -> Bool -moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles - --- | Create a module variable at some 'ModuleName'. --- See Note [Representation of module/name variables] -mkHoleModule :: ModuleName -> Module -mkHoleModule = mkModule holeUnitId - -instance Uniquable Module where - getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) - -instance Outputable Module where - ppr = pprModule - -instance Binary Module where - put_ bh (Module p n) = put_ bh p >> put_ bh n - get bh = do p <- get bh; n <- get bh; return (Module p n) - -instance Data Module where - -- don't traverse? - toConstr _ = abstractConstr "Module" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Module" - -instance NFData Module where - rnf x = x `seq` () - --- | This gives a stable ordering, as opposed to the Ord instance which --- gives an ordering based on the 'Unique's of the components, which may --- not be stable from run to run of the compiler. -stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitIdCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) - -mkModule :: UnitId -> ModuleName -> Module -mkModule = Module - -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = getPprStyle doc - where - doc sty - | codeStyle sty = - (if p == mainUnitId - then empty -- never qualify the main package in code - else ztext (zEncodeFS (unitIdFS p)) <> char '_') - <> pprModuleName n - | qualModule sty mod = - if isHoleModule mod - then angleBrackets (pprModuleName n) - else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n - | otherwise = - pprModuleName n - -class ContainsModule t where - extractModule :: t -> Module - -class HasModule m where - getModule :: m Module - -instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where - fromDbModule (DbModule uid mod_name) = mkModule uid mod_name - fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name - fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts - fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) - -- GHC never writes to the database, so it's not needed - toDbModule = error "toDbModule: not implemented" - toDbUnitId = error "toDbUnitId: not implemented" - -{- -************************************************************************ -* * -\subsection{ComponentId} -* * -************************************************************************ --} - --- | A 'ComponentId' consists of the package name, package version, component --- ID, the transitive dependencies of the component, and other information to --- uniquely identify the source code and build configuration of a component. --- --- This used to be known as an 'InstalledPackageId', but a package can contain --- multiple components and a 'ComponentId' uniquely identifies a component --- within a package. When a package only has one component, the 'ComponentId' --- coincides with the 'InstalledPackageId' -newtype ComponentId = ComponentId FastString deriving (Eq, Ord) - -instance BinaryStringRep ComponentId where - fromStringRep = ComponentId . mkFastStringByteString - toStringRep (ComponentId s) = bytesFS s - -instance Uniquable ComponentId where - getUnique (ComponentId n) = getUnique n - -instance Outputable ComponentId where - ppr cid@(ComponentId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case componentIdString dflags cid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -{- -************************************************************************ -* * -\subsection{UnitId} -* * -************************************************************************ --} - --- | A unit identifier identifies a (possibly partially) instantiated --- library. It is primarily used as part of 'Module', which in turn --- is used in 'Name', which is used to give names to entities when --- typechecking. --- --- There are two possible forms for a 'UnitId'. It can be a --- 'DefiniteUnitId', in which case we just have a string that uniquely --- identifies some fully compiled, installed library we have on disk. --- However, when we are typechecking a library with missing holes, --- we may need to instantiate a library on the fly (in which case --- we don't have any on-disk representation.) In that case, you --- have an 'IndefiniteUnitId', which explicitly records the --- instantiation, so that we can substitute over it. -data UnitId - = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId - | DefiniteUnitId {-# UNPACK #-} !DefUnitId - -unitIdFS :: UnitId -> FastString -unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x -unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x - -unitIdKey :: UnitId -> Unique -unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x -unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x - --- | A unit identifier which identifies an indefinite --- library (with holes) that has been *on-the-fly* instantiated --- with a substitution 'indefUnitIdInsts'. In fact, an indefinite --- unit identifier could have no holes, but we haven't gotten --- around to compiling the actual library yet. --- --- An indefinite unit identifier pretty-prints to something like --- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the --- brackets enclose the module substitution). -data IndefUnitId - = IndefUnitId { - -- | A private, uniquely identifying representation of - -- a UnitId. This string is completely private to GHC - -- and is just used to get a unique; in particular, we don't use it for - -- symbols (indefinite libraries are not compiled). - indefUnitIdFS :: FastString, - -- | Cached unique of 'unitIdFS'. - indefUnitIdKey :: Unique, - -- | The component identity of the indefinite library that - -- is being instantiated. - indefUnitIdComponentId :: !ComponentId, - -- | The sorted (by 'ModuleName') instantiations of this library. - indefUnitIdInsts :: ![(ModuleName, Module)], - -- | A cache of the free module variables of 'unitIdInsts'. - -- This lets us efficiently tell if a 'UnitId' has been - -- fully instantiated (free module variables are empty) - -- and whether or not a substitution can have any effect. - indefUnitIdFreeHoles :: UniqDSet ModuleName - } - -instance Eq IndefUnitId where - u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 - -instance Ord IndefUnitId where - u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 - -instance Binary IndefUnitId where - put_ bh indef = do - put_ bh (indefUnitIdComponentId indef) - put_ bh (indefUnitIdInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = hashUnitId cid insts - return IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - --- | Create a new 'IndefUnitId' given an explicit module substitution. -newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId -newIndefUnitId cid insts = - IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = sorted_insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - where - fs = hashUnitId cid sorted_insts - sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts - --- | Injects an 'IndefUnitId' (indefinite library which --- was on-the-fly instantiated) to a 'UnitId' (either --- an indefinite or definite library). -indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId -indefUnitIdToUnitId dflags iuid = - -- NB: suppose that we want to compare the indefinite - -- unit id p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- IndefiniteUnitId, they won't compare equal; only - -- after improvement will the equality hold. - improveUnitId (getPackageConfigMap dflags) $ - IndefiniteUnitId iuid - -data IndefModule = IndefModule { - indefModuleUnitId :: IndefUnitId, - indefModuleName :: ModuleName - } deriving (Eq, Ord) - -instance Outputable IndefModule where - ppr (IndefModule uid m) = - ppr uid <> char ':' <> ppr m - --- | Injects an 'IndefModule' to 'Module' (see also --- 'indefUnitIdToUnitId'. -indefModuleToModule :: DynFlags -> IndefModule -> Module -indefModuleToModule dflags (IndefModule iuid mod_name) = - mkModule (indefUnitIdToUnitId dflags iuid) mod_name - --- | An installed unit identifier identifies a library which has --- been installed to the package database. These strings are --- provided to us via the @-this-unit-id@ flag. The library --- in question may be definite or indefinite; if it is indefinite, --- none of the holes have been filled (we never install partially --- instantiated libraries.) Put another way, an installed unit id --- is either fully instantiated, or not instantiated at all. --- --- Installed unit identifiers look something like @p+af23SAj2dZ219@, --- or maybe just @p@ if they don't use Backpack. -newtype InstalledUnitId = - InstalledUnitId { - -- | The full hashed unit identifier, including the component id - -- and the hash. - installedUnitIdFS :: FastString - } - -instance Binary InstalledUnitId where - put_ bh (InstalledUnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (InstalledUnitId fs) - -instance BinaryStringRep InstalledUnitId where - fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) - -- GHC doesn't write to database - toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" - -instance Eq InstalledUnitId where - uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 - -instance Ord InstalledUnitId where - u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 - -instance Uniquable InstalledUnitId where - getUnique = installedUnitIdKey - -instance Outputable InstalledUnitId where - ppr uid@(InstalledUnitId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case displayInstalledUnitId dflags uid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -installedUnitIdKey :: InstalledUnitId -> Unique -installedUnitIdKey = getUnique . installedUnitIdFS - --- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. -toInstalledUnitId :: UnitId -> InstalledUnitId -toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid -toInstalledUnitId (IndefiniteUnitId indef) = - componentIdToInstalledUnitId (indefUnitIdComponentId indef) - -installedUnitIdString :: InstalledUnitId -> String -installedUnitIdString = unpackFS . installedUnitIdFS - -instance Outputable IndefUnitId where - ppr uid = - -- getPprStyle $ \sty -> - ppr cid <> - (if not (null insts) -- pprIf - then - brackets (hcat - (punctuate comma $ - [ ppr modname <> text "=" <> ppr m - | (modname, m) <- insts])) - else empty) - where - cid = indefUnitIdComponentId uid - insts = indefUnitIdInsts uid - --- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. -data InstalledModule = InstalledModule { - installedModuleUnitId :: !InstalledUnitId, - installedModuleName :: !ModuleName - } - deriving (Eq, Ord) - -instance Outputable InstalledModule where - ppr (InstalledModule p n) = - ppr p <> char ':' <> pprModuleName n - -fsToInstalledUnitId :: FastString -> InstalledUnitId -fsToInstalledUnitId fs = InstalledUnitId fs - -componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId -componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs - -stringToInstalledUnitId :: String -> InstalledUnitId -stringToInstalledUnitId = fsToInstalledUnitId . mkFastString - --- | Test if a 'Module' corresponds to a given 'InstalledModule', --- modulo instantiation. -installedModuleEq :: InstalledModule -> Module -> Bool -installedModuleEq imod mod = - fst (splitModuleInsts mod) == imod - --- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', --- modulo instantiation. -installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool -installedUnitIdEq iuid uid = - fst (splitUnitIdInsts uid) == iuid - --- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that --- it only refers to a definite library; i.e., one we have generated --- code for. -newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } - deriving (Eq, Ord) - -instance Outputable DefUnitId where - ppr (DefUnitId uid) = ppr uid - -instance Binary DefUnitId where - put_ bh (DefUnitId uid) = put_ bh uid - get bh = do uid <- get bh; return (DefUnitId uid) - --- | A map keyed off of 'InstalledModule' -newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) - -emptyInstalledModuleEnv :: InstalledModuleEnv a -emptyInstalledModuleEnv = InstalledModuleEnv Map.empty - -lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a -lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e - -extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a -extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) - -filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a -filterInstalledModuleEnv f (InstalledModuleEnv e) = - InstalledModuleEnv (Map.filterWithKey f e) - -delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a -delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) - --- Note [UnitId to InstalledUnitId improvement] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Just because a UnitId is definite (has no holes) doesn't --- mean it's necessarily a InstalledUnitId; it could just be --- that over the course of renaming UnitIds on the fly --- while typechecking an indefinite library, we --- ended up with a fully instantiated unit id with no hash, --- since we haven't built it yet. This is fine. --- --- However, if there is a hashed unit id for this instantiation --- in the package database, we *better use it*, because --- that hashed unit id may be lurking in another interface, --- and chaos will ensue if we attempt to compare the two --- (the unitIdFS for a UnitId never corresponds to a Cabal-provided --- hash of a compiled instantiated library). --- --- There is one last niggle: improvement based on the package database means --- that we might end up developing on a package that is not transitively --- depended upon by the packages the user specified directly via command line --- flags. This could lead to strange and difficult to understand bugs if those --- instantiations are out of date. The solution is to only improve a --- unit id if the new unit id is part of the 'preloadClosure'; i.e., the --- closure of all the packages which were explicitly specified. - --- | Retrieve the set of free holes of a 'UnitId'. -unitIdFreeHoles :: UnitId -> UniqDSet ModuleName -unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x --- Hashed unit ids are always fully instantiated -unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet - -instance Show UnitId where - show = unitIdString - --- | A 'UnitId' is definite if it has no free holes. -unitIdIsDefinite :: UnitId -> Bool -unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles - --- | Generate a uniquely identifying 'FastString' for a unit --- identifier. This is a one-way function. You can rely on one special --- property: if a unit identifier is in most general form, its 'FastString' --- coincides with its 'ComponentId'. This hash is completely internal --- to GHC and is not used for symbol names or file paths. -hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString -hashUnitId cid sorted_holes = - mkFastStringByteString - . fingerprintUnitId (toStringRep cid) - $ rawHashUnitId sorted_holes - --- | Generate a hash for a sorted module substitution. -rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint -rawHashUnitId sorted_holes = - fingerprintByteString - . BS.concat $ do - (m, b) <- sorted_holes - [ toStringRep m, BS.Char8.singleton ' ', - bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', - toStringRep (moduleName b), BS.Char8.singleton '\n'] - -fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString -fingerprintUnitId prefix (Fingerprint a b) - = BS.concat - $ [ prefix - , BS.Char8.singleton '-' - , BS.Char8.pack (toBase62Padded a) - , BS.Char8.pack (toBase62Padded b) ] - --- | Create a new, un-hashed unit identifier. -newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId -newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... -newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts - -pprUnitId :: UnitId -> SDoc -pprUnitId (DefiniteUnitId uid) = ppr uid -pprUnitId (IndefiniteUnitId uid) = ppr uid - -instance Eq UnitId where - uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 - -instance Uniquable UnitId where - getUnique = unitIdKey - -instance Ord UnitId where - nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 - -instance Data UnitId where - -- don't traverse? - toConstr _ = abstractConstr "UnitId" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "UnitId" - -instance NFData UnitId where - rnf x = x `seq` () - -stableUnitIdCmp :: UnitId -> UnitId -> Ordering --- ^ Compares package ids lexically, rather than by their 'Unique's -stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 - -instance Outputable UnitId where - ppr pk = pprUnitId pk - --- Performance: would prefer to have a NameCache like thing -instance Binary UnitId where - put_ bh (DefiniteUnitId def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (IndefiniteUnitId indef_uid) = do - putByte bh 1 - put_ bh indef_uid - get bh = do b <- getByte bh - case b of - 0 -> fmap DefiniteUnitId (get bh) - _ -> fmap IndefiniteUnitId (get bh) - -instance Binary ComponentId where - put_ bh (ComponentId fs) = put_ bh fs - get bh = do { fs <- get bh; return (ComponentId fs) } - --- | Create a new simple unit identifier (no holes) from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId (ComponentId fs) = fsToUnitId fs - --- | Create a new simple unit identifier from a 'FastString'. Internally, --- this is primarily used to specify wired-in unit identifiers. -fsToUnitId :: FastString -> UnitId -fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId - -stringToUnitId :: String -> UnitId -stringToUnitId = fsToUnitId . mkFastString - -unitIdString :: UnitId -> String -unitIdString = unpackFS . unitIdFS - -{- -************************************************************************ -* * - Hole substitutions -* * -************************************************************************ --} - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module - --- | Substitutes holes in a 'Module'. NOT suitable for being called --- directly on a 'nameModule', see Note [Representation of module/name variable]. --- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; --- similarly, @@ maps to @q():A@. -renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module -renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags) - --- | Substitutes holes in a 'UnitId', suitable for renaming when --- an include occurs; see Note [Representation of module/name variable]. --- --- @p[A=]@ maps to @p[A=]@ with @A=@. -renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags) - --- | Like 'renameHoleModule', but requires only 'PackageConfigMap' --- so it can be used by "Packages". -renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = , that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap' --- so it can be used by "Packages". -renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId' pkg_map env uid = - case uid of - (IndefiniteUnitId - IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts - , indefUnitIdFreeHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) - then uid - -- Functorially apply the substitution to the instantiation, - -- then check the 'PackageConfigMap' to see if there is - -- a compiled version of this 'UnitId' we can improve to. - -- See Note [UnitId to InstalledUnitId] improvement - else improveUnitId pkg_map $ - newUnitId cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - --- | Given a possibly on-the-fly instantiated module, split it into --- a 'Module' that we definitely can find on-disk, as well as an --- instantiation if we need to instantiate it on the fly. If the --- instantiation is @Nothing@ no on-the-fly renaming is needed. -splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) -splitModuleInsts m = - let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) - in (InstalledModule uid (moduleName m), - fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) - --- | See 'splitModuleInsts'. -splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) -splitUnitIdInsts (IndefiniteUnitId iuid) = - (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) -splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) - -generalizeIndefUnitId :: IndefUnitId -> IndefUnitId -generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts } = - newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) - -generalizeIndefModule :: IndefModule -> IndefModule -generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n - -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") - -parseUnitId :: ReadP UnitId -parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId - where - parseFullUnitId = do - cid <- parseComponentId - insts <- parseModSubst - return (newUnitId cid insts) - parseDefiniteUnitId = do - s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") - return (stringToUnitId s) - parseSimpleUnitId = do - cid <- parseComponentId - return (newSimpleUnitId cid) - -parseComponentId :: ReadP ComponentId -parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -parseModuleId :: ReadP Module -parseModuleId = parseModuleVar <++ parseModule - where - parseModuleVar = do - _ <- Parse.char '<' - modname <- parseModuleName - _ <- Parse.char '>' - return (mkHoleModule modname) - parseModule = do - uid <- parseUnitId - _ <- Parse.char ':' - modname <- parseModuleName - return (mkModule uid modname) - -parseModSubst :: ReadP [(ModuleName, Module)] -parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') - . flip Parse.sepBy (Parse.char ',') - $ do k <- parseModuleName - _ <- Parse.char '=' - v <- parseModuleId - return (k, v) - - -{- -Note [Wired-in packages] -~~~~~~~~~~~~~~~~~~~~~~~~ - -Certain packages are known to the compiler, in that we know about certain -entities that reside in these packages, and the compiler needs to -declare static Modules and Names that refer to these packages. Hence -the wired-in packages can't include version numbers in their package UnitId, -since we don't want to bake the version numbers of these packages into GHC. - -So here's the plan. Wired-in packages are still versioned as -normal in the packages database, and you can still have multiple -versions of them installed. To the user, everything looks normal. - -However, for each invocation of GHC, only a single instance of each wired-in -package will be recognised (the desired one is selected via -@-package@\/@-hide-package@), and GHC will internall pretend that it has the -*unversioned* 'UnitId', including in .hi files and object file symbols. - -Unselected versions of wired-in packages will be ignored, as will any other -package that depends directly or indirectly on it (much as if you -had used @-ignore-package@). - -The affected packages are compiled with, e.g., @-this-unit-id base@, so that -the symbols in the object files have the unversioned unit id in their name. - -Make sure you change 'Packages.findWiredInPackages' if you add an entry here. - -For `integer-gmp`/`integer-simple` we also change the base name to -`integer-wired-in`, but this is fundamentally no different. -See Note [The integer library] in PrelNames. --} - -integerUnitId, primUnitId, - baseUnitId, rtsUnitId, - thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId -primUnitId = fsToUnitId (fsLit "ghc-prim") -integerUnitId = fsToUnitId (fsLit "integer-wired-in") - -- See Note [The integer library] in PrelNames -baseUnitId = fsToUnitId (fsLit "base") -rtsUnitId = fsToUnitId (fsLit "rts") -thUnitId = fsToUnitId (fsLit "template-haskell") -thisGhcUnitId = fsToUnitId (fsLit "ghc") -interactiveUnitId = fsToUnitId (fsLit "interactive") - --- | This is the package Id for the current program. It is the default --- package Id if you don't specify a package name. We don't add this prefix --- to symbol names, since there can be only one main package per program. -mainUnitId = fsToUnitId (fsLit "main") - --- | This is a fake package id used to provide identities to any un-implemented --- signatures. The set of hole identities is global over an entire compilation. --- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. --- See Note [Representation of module/name variables] -holeUnitId :: UnitId -holeUnitId = fsToUnitId (fsLit "hole") - -isInteractiveModule :: Module -> Bool -isInteractiveModule mod = moduleUnitId mod == interactiveUnitId - --- Note [Representation of module/name variables] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In our ICFP'16, we use to represent module holes, and {A.T} to represent --- name holes. This could have been represented by adding some new cases --- to the core data types, but this would have made the existing 'nameModule' --- and 'moduleUnitId' partial, which would have required a lot of modifications --- to existing code. --- --- Instead, we adopted the following encoding scheme: --- --- ===> hole:A --- {A.T} ===> hole:A.T --- --- This encoding is quite convenient, but it is also a bit dangerous too, --- because if you have a 'hole:A' you need to know if it's actually a --- 'Module' or just a module stored in a 'Name'; these two cases must be --- treated differently when doing substitutions. 'renameHoleModule' --- and 'renameHoleUnitId' assume they are NOT operating on a --- 'Name'; 'NameShape' handles name substitutions exclusively. - -isHoleModule :: Module -> Bool -isHoleModule mod = moduleUnitId mod == holeUnitId - -wiredInUnitIds :: [UnitId] -wiredInUnitIds = [ primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - thisGhcUnitId ] - -{- -************************************************************************ -* * -\subsection{@ModuleEnv@s} -* * -************************************************************************ --} - --- | A map keyed off of 'Module's -newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) - -{- -Note [ModuleEnv performance and determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To prevent accidental reintroduction of nondeterminism the Ord instance -for Module was changed to not depend on Unique ordering and to use the -lexicographic order. This is potentially expensive, but when measured -there was no difference in performance. - -To be on the safe side and not pessimize ModuleEnv uses nondeterministic -ordering on Module and normalizes by doing the lexicographic sort when -turning the env to a list. -See Note [Unique Determinism] for more information about the source of -nondeterminismand and Note [Deterministic UniqFM] for explanation of why -it matters for maps. --} - -newtype NDModule = NDModule { unNDModule :: Module } - deriving Eq - -- A wrapper for Module with faster nondeterministic Ord. - -- Don't export, See [ModuleEnv performance and determinism] - -instance Ord NDModule where - compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = - (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` - (getUnique n1 `nonDetCmpUnique` getUnique n2) - -filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a -filterModuleEnv f (ModuleEnv e) = - ModuleEnv (Map.filterWithKey (f . unNDModule) e) - -elemModuleEnv :: Module -> ModuleEnv a -> Bool -elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e - -extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) - -extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a - -> ModuleEnv a -extendModuleEnvWith f (ModuleEnv e) m x = - ModuleEnv (Map.insertWith f (NDModule m) x e) - -extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList (ModuleEnv e) xs = - ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) - -extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] - -> ModuleEnv a -extendModuleEnvList_C f (ModuleEnv e) xs = - ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) - -plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = - ModuleEnv (Map.unionWith f e1 e2) - -delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a -delModuleEnvList (ModuleEnv e) ms = - ModuleEnv (Map.deleteList (map NDModule ms) e) - -delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a -delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) - -plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) - -lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e - -lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a -lookupWithDefaultModuleEnv (ModuleEnv e) x m = - Map.findWithDefault x (NDModule m) e - -mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) - -mkModuleEnv :: [(Module, a)] -> ModuleEnv a -mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) - -emptyModuleEnv :: ModuleEnv a -emptyModuleEnv = ModuleEnv Map.empty - -moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvElts :: ModuleEnv a -> [a] -moduleEnvElts e = map snd $ moduleEnvToList e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvToList :: ModuleEnv a -> [(Module, a)] -moduleEnvToList (ModuleEnv e) = - sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] - -- See Note [ModuleEnv performance and determinism] - -unitModuleEnv :: Module -> a -> ModuleEnv a -unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) - -isEmptyModuleEnv :: ModuleEnv a -> Bool -isEmptyModuleEnv (ModuleEnv e) = Map.null e - --- | A set of 'Module's -type ModuleSet = Set NDModule - -mkModuleSet :: [Module] -> ModuleSet -mkModuleSet = Set.fromList . coerce - -extendModuleSet :: ModuleSet -> Module -> ModuleSet -extendModuleSet s m = Set.insert (NDModule m) s - -extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet -extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms - -emptyModuleSet :: ModuleSet -emptyModuleSet = Set.empty - -moduleSetElts :: ModuleSet -> [Module] -moduleSetElts = sort . coerce . Set.toList - -elemModuleSet :: Module -> ModuleSet -> Bool -elemModuleSet = Set.member . coerce - -intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -intersectModuleSet = coerce Set.intersection - -minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -minusModuleSet = coerce Set.difference - -delModuleSet :: ModuleSet -> Module -> ModuleSet -delModuleSet = coerce (flip Set.delete) - -unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -unionModuleSet = coerce Set.union - -unitModuleSet :: Module -> ModuleSet -unitModuleSet = coerce Set.singleton - -{- -A ModuleName has a Unique, so we can build mappings of these using -UniqFM. --} - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) -type ModuleNameEnv elt = UniqFM elt - - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) --- Has deterministic folds and can be deterministically converted to a list -type DModuleNameEnv elt = UniqDFM elt diff --git a/basicTypes/Module.hs-boot b/basicTypes/Module.hs-boot deleted file mode 100644 --- a/basicTypes/Module.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module Module where - -import GhcPrelude -import FastString - -data Module -data ModuleName -data UnitId -data InstalledUnitId -newtype ComponentId = ComponentId FastString - -moduleName :: Module -> ModuleName -moduleUnitId :: Module -> UnitId -unitIdString :: UnitId -> String diff --git a/basicTypes/Name.hs b/basicTypes/Name.hs deleted file mode 100644 --- a/basicTypes/Name.hs +++ /dev/null @@ -1,703 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Name]{@Name@: to transmit name info from renamer to typechecker} --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They --- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have --- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names --- also contain information about where they originated from, see "Name#name_sorts" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" --- --- #name_sorts# --- Names are one of: --- --- * External, if they name things declared in other modules. Some external --- Names are wired in, i.e. they name primitives defined in the compiler itself --- --- * Internal, if they name things in the module being compiled. Some internal --- Names are system names, if they are names manufactured by the compiler - -module Name ( - -- * The main types - Name, -- Abstract - BuiltInSyntax(..), - - -- ** Creating 'Name's - mkSystemName, mkSystemNameAt, - mkInternalName, mkClonedInternalName, mkDerivedInternalName, - mkSystemVarName, mkSysTvName, - mkFCallName, - mkExternalName, mkWiredInName, - - -- ** Manipulating and deconstructing 'Name's - nameUnique, setNameUnique, - nameOccName, nameNameSpace, nameModule, nameModule_maybe, - setNameLoc, - tidyNameOcc, - localiseName, - - nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, - - -- ** Predicates on 'Name's - isSystemName, isInternalName, isExternalName, - isTyVarName, isTyConName, isDataConName, - isValName, isVarName, - isWiredInName, isBuiltInSyntax, - isHoleName, - wiredInNameTyThing_maybe, - nameIsLocalOrFrom, nameIsHomePackage, - nameIsHomePackageImport, nameIsFromExternalPackage, - stableNameCmp, - - -- * Class 'NamedThing' and overloaded friends - NamedThing(..), - getSrcLoc, getSrcSpan, getOccString, getOccFS, - - pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, - nameStableString, - - -- Re-export the OccName stuff - module OccName - ) where - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep( TyThing ) - -import OccName -import Module -import SrcLoc -import Unique -import Util -import Maybes -import Binary -import DynFlags -import FastString -import Outputable - -import Control.DeepSeq -import Data.Data - -{- -************************************************************************ -* * -\subsection[Name-datatype]{The @Name@ datatype, and name construction} -* * -************************************************************************ --} - --- | A unique, unambiguous name for something, containing information about where --- that thing originated. -data Name = Name { - n_sort :: NameSort, -- What sort of name it is - n_occ :: !OccName, -- Its occurrence name - n_uniq :: {-# UNPACK #-} !Unique, - n_loc :: !SrcSpan -- Definition site - } - --- NOTE: we make the n_loc field strict to eliminate some potential --- (and real!) space leaks, due to the fact that we don't look at --- the SrcLoc in a Name all that often. - --- See Note [About the NameSorts] -data NameSort - = External Module - - | WiredIn Module TyThing BuiltInSyntax - -- A variant of External, for wired-in things - - | Internal -- A user-defined Id or TyVar - -- defined in the module being compiled - - | System -- A system-defined Id or TyVar. Typically the - -- OccName is very uninformative (like 's') - -instance Outputable NameSort where - ppr (External _) = text "external" - ppr (WiredIn _ _ _) = text "wired-in" - ppr Internal = text "internal" - ppr System = text "system" - -instance NFData Name where - rnf Name{..} = rnf n_sort - -instance NFData NameSort where - rnf (External m) = rnf m - rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () - -- XXX this is a *lie*, we're not going to rnf the TyThing, but - -- since the TyThings for WiredIn Names are all static they can't - -- be hiding space leaks or errors. - rnf Internal = () - rnf System = () - --- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, --- which have special syntactic forms. They aren't in scope --- as such. -data BuiltInSyntax = BuiltInSyntax | UserSyntax - -{- -Note [About the NameSorts] - -1. Initially, top-level Ids (including locally-defined ones) get External names, - and all other local Ids get Internal names - -2. In any invocation of GHC, an External Name for "M.x" has one and only one - unique. This unique association is ensured via the Name Cache; - see Note [The Name Cache] in IfaceEnv. - -3. Things with a External name are given C static labels, so they finally - appear in the .o file's symbol table. They appear in the symbol table - in the form M.n. If originally-local things have this property they - must be made @External@ first. - -4. In the tidy-core phase, a External that is not visible to an importer - is changed to Internal, and a Internal that is visible is changed to External - -5. A System Name differs in the following ways: - a) has unique attached when printing dumps - b) unifier eliminates sys tyvars in favour of user provs where possible - - Before anything gets printed in interface files or output code, it's - fed through a 'tidy' processor, which zaps the OccNames to have - unique names; and converts all sys-locals to user locals - If any desugarer sys-locals have survived that far, they get changed to - "ds1", "ds2", etc. - -Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) - -Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, - not read from an interface file. - E.g. Bool, True, Int, Float, and many others - -All built-in syntax is for wired-in things. --} - -instance HasOccName Name where - occName = nameOccName - -nameUnique :: Name -> Unique -nameOccName :: Name -> OccName -nameNameSpace :: Name -> NameSpace -nameModule :: HasDebugCallStack => Name -> Module -nameSrcLoc :: Name -> SrcLoc -nameSrcSpan :: Name -> SrcSpan - -nameUnique name = n_uniq name -nameOccName name = n_occ name -nameNameSpace name = occNameSpace (n_occ name) -nameSrcLoc name = srcSpanStart (n_loc name) -nameSrcSpan name = n_loc name - -type instance SrcSpanLess Name = Name -instance HasSrcSpan Name where - composeSrcSpan (L sp n) = n {n_loc = sp} - decomposeSrcSpan n = L (n_loc n) n - - -{- -************************************************************************ -* * -\subsection{Predicates on names} -* * -************************************************************************ --} - -isInternalName :: Name -> Bool -isExternalName :: Name -> Bool -isSystemName :: Name -> Bool -isWiredInName :: Name -> Bool - -isWiredInName (Name {n_sort = WiredIn _ _ _}) = True -isWiredInName _ = False - -wiredInNameTyThing_maybe :: Name -> Maybe TyThing -wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing -wiredInNameTyThing_maybe _ = Nothing - -isBuiltInSyntax :: Name -> Bool -isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True -isBuiltInSyntax _ = False - -isExternalName (Name {n_sort = External _}) = True -isExternalName (Name {n_sort = WiredIn _ _ _}) = True -isExternalName _ = False - -isInternalName name = not (isExternalName name) - -isHoleName :: Name -> Bool -isHoleName = isHoleModule . nameModule - -nameModule name = - nameModule_maybe name `orElse` - pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) - -nameModule_maybe :: Name -> Maybe Module -nameModule_maybe (Name { n_sort = External mod}) = Just mod -nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod -nameModule_maybe _ = Nothing - -nameIsLocalOrFrom :: Module -> Name -> Bool --- ^ Returns True if the name is --- (a) Internal --- (b) External but from the specified module --- (c) External but from the 'interactive' package --- --- The key idea is that --- False means: the entity is defined in some other module --- you can find the details (type, fixity, instances) --- in some interface file --- those details will be stored in the EPT or HPT --- --- True means: the entity is defined in this module or earlier in --- the GHCi session --- you can find details (type, fixity, instances) in the --- TcGblEnv or TcLclEnv --- --- The isInteractiveModule part is because successive interactions of a GHCi session --- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come --- from the magic 'interactive' package; and all the details are kept in the --- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. --- See Note [The interactive package] in HscTypes - -nameIsLocalOrFrom from name - | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod - | otherwise = True - -nameIsHomePackage :: Module -> Name -> Bool --- True if the Name is defined in module of this package -nameIsHomePackage this_mod - = \nm -> case n_sort nm of - External nm_mod -> moduleUnitId nm_mod == this_pkg - WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg - Internal -> True - System -> False - where - this_pkg = moduleUnitId this_mod - -nameIsHomePackageImport :: Module -> Name -> Bool --- True if the Name is defined in module of this package --- /other than/ the this_mod -nameIsHomePackageImport this_mod - = \nm -> case nameModule_maybe nm of - Nothing -> False - Just nm_mod -> nm_mod /= this_mod - && moduleUnitId nm_mod == this_pkg - where - this_pkg = moduleUnitId this_mod - --- | Returns True if the Name comes from some other package: neither this --- package nor the interactive package. -nameIsFromExternalPackage :: UnitId -> Name -> Bool -nameIsFromExternalPackage this_pkg name - | Just mod <- nameModule_maybe name - , moduleUnitId mod /= this_pkg -- Not this package - , not (isInteractiveModule mod) -- Not the 'interactive' package - = True - | otherwise - = False - -isTyVarName :: Name -> Bool -isTyVarName name = isTvOcc (nameOccName name) - -isTyConName :: Name -> Bool -isTyConName name = isTcOcc (nameOccName name) - -isDataConName :: Name -> Bool -isDataConName name = isDataOcc (nameOccName name) - -isValName :: Name -> Bool -isValName name = isValOcc (nameOccName name) - -isVarName :: Name -> Bool -isVarName = isVarOcc . nameOccName - -isSystemName (Name {n_sort = System}) = True -isSystemName _ = False - -{- -************************************************************************ -* * -\subsection{Making names} -* * -************************************************************************ --} - --- | Create a name which is (for now at least) local to the current module and hence --- does not need a 'Module' to disambiguate it from other 'Name's -mkInternalName :: Unique -> OccName -> SrcSpan -> Name -mkInternalName uniq occ loc = Name { n_uniq = uniq - , n_sort = Internal - , n_occ = occ - , n_loc = loc } - -- NB: You might worry that after lots of huffing and - -- puffing we might end up with two local names with distinct - -- uniques, but the same OccName. Indeed we can, but that's ok - -- * the insides of the compiler don't care: they use the Unique - -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the - -- uniques if you get confused - -- * for interface files we tidyCore first, which makes - -- the OccNames distinct when they need to be - -mkClonedInternalName :: Unique -> Name -> Name -mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = uniq, n_sort = Internal - , n_occ = occ, n_loc = loc } - -mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name -mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = uniq, n_sort = Internal - , n_occ = derive_occ occ, n_loc = loc } - --- | Create a name which definitely originates in the given module -mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name --- WATCH OUT! External Names should be in the Name Cache --- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName --- with some fresh unique without populating the Name Cache -mkExternalName uniq mod occ loc - = Name { n_uniq = uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } - --- | Create a name which is actually defined by the compiler itself -mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name -mkWiredInName mod occ uniq thing built_in - = Name { n_uniq = uniq, - n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcSpan } - --- | Create a name brought into being by the compiler -mkSystemName :: Unique -> OccName -> Name -mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan - -mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name -mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System - , n_occ = occ, n_loc = loc } - -mkSystemVarName :: Unique -> FastString -> Name -mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) - -mkSysTvName :: Unique -> FastString -> Name -mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) - --- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name -mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan - -- The encoded string completely describes the ccall - --- When we renumber/rename things, we need to be --- able to change a Name's Unique to match the cached --- one in the thing it's the name of. If you know what I mean. -setNameUnique :: Name -> Unique -> Name -setNameUnique name uniq = name {n_uniq = uniq} - --- This is used for hsigs: we want to use the name of the originally exported --- entity, but edit the location to refer to the reexport site -setNameLoc :: Name -> SrcSpan -> Name -setNameLoc name loc = name {n_loc = loc} - -tidyNameOcc :: Name -> OccName -> Name --- We set the OccName of a Name when tidying --- In doing so, we change System --> Internal, so that when we print --- it we don't get the unique by default. It's tidy now! -tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} -tidyNameOcc name occ = name { n_occ = occ } - --- | Make the 'Name' into an internal name, regardless of what it was to begin with -localiseName :: Name -> Name -localiseName n = n { n_sort = Internal } - -{- -************************************************************************ -* * -\subsection{Hashing and comparison} -* * -************************************************************************ --} - -cmpName :: Name -> Name -> Ordering -cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 - --- | Compare Names lexicographically --- This only works for Names that originate in the source code or have been --- tidied. -stableNameCmp :: Name -> Name -> Ordering -stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) - (Name { n_sort = s2, n_occ = occ2 }) - = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) - -- The ordinary compare on OccNames is lexicographic - where - -- Later constructors are bigger - sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 - sort_cmp (External {}) _ = LT - sort_cmp (WiredIn {}) (External {}) = GT - sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 - sort_cmp (WiredIn {}) _ = LT - sort_cmp Internal (External {}) = GT - sort_cmp Internal (WiredIn {}) = GT - sort_cmp Internal Internal = EQ - sort_cmp Internal System = LT - sort_cmp System System = EQ - sort_cmp System _ = GT - -{- -************************************************************************ -* * -\subsection[Name-instances]{Instance declarations} -* * -************************************************************************ --} - --- | The same comments as for `Name`'s `Ord` instance apply. -instance Eq Name where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - --- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which --- means that the ordering is not stable across deserialization or rebuilds. --- --- See `nonDetCmpUnique` for further information, and trac #15240 for a bug --- caused by improper use of this instance. - --- For a deterministic lexicographic ordering, use `stableNameCmp`. -instance Ord Name where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpName a b - -instance Uniquable Name where - getUnique = nameUnique - -instance NamedThing Name where - getName n = n - -instance Data Name where - -- don't traverse? - toConstr _ = abstractConstr "Name" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Name" - -{- -************************************************************************ -* * -\subsection{Binary} -* * -************************************************************************ --} - --- | Assumes that the 'Name' is a non-binding one. See --- 'IfaceSyn.putIfaceTopBndr' and 'IfaceSyn.getIfaceTopBndr' for serializing --- binding 'Name's. See 'UserData' for the rationale for this distinction. -instance Binary Name where - put_ bh name = - case getUserData bh of - UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name - - get bh = - case getUserData bh of - UserData { ud_get_name = get_name } -> get_name bh - -{- -************************************************************************ -* * -\subsection{Pretty printing} -* * -************************************************************************ --} - -instance Outputable Name where - ppr name = pprName name - -instance OutputableBndr Name where - pprBndr _ name = pprName name - pprInfixOcc = pprInfixName - pprPrefixOcc = pprPrefixName - -pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = getPprStyle $ \ sty -> - case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin - External mod -> pprExternal sty uniq mod occ False UserSyntax - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ - --- | Print the string of Name unqualifiedly directly. -pprNameUnqualified :: Name -> SDoc -pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ - -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? - | debugStyle sty = pp_mod <> ppr_occ_name occ - <> braces (hsep [if is_wired then text "(w)" else empty, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = - if isHoleModule mod - then case qualName sty mod occ of - NameUnqual -> ppr_occ_name occ - _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) - else pprModulePrefix sty mod occ <> ppr_occ_name occ - where - pp_mod = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressModulePrefixes dflags - then empty - else ppr mod <> dot - -pprInternal :: PprStyle -> Unique -> OccName -> SDoc -pprInternal sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - -- For debug dumps, we're not necessarily dumping - -- tidied code, so we need to print the uniques. - | otherwise = ppr_occ_name occ -- User style - --- Like Internal, except that we only omit the unique in Iface style -pprSystem :: PprStyle -> Unique -> OccName -> SDoc -pprSystem sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - <> braces (pprNameSpaceBrief (occNameSpace occ)) - | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq - -- If the tidy phase hasn't run, the OccName - -- is unlikely to be informative (like 's'), - -- so print the unique - - -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc --- Print the "M." part of a name, based on whether it's in scope or not --- See Note [Printing original names] in HscTypes -pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressModulePrefixes dflags - then empty - else - case qualName sty mod occ of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope either - NameUnqual -> empty -- In scope unqualified - -pprUnique :: Unique -> SDoc --- Print a unique unless we are suppressing them -pprUnique uniq - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressUniques dflags) $ - pprUniqueAlways uniq - -ppr_underscore_unique :: Unique -> SDoc --- Print an underscore separating the name from its unique --- But suppress it if we aren't printing the uniques anyway -ppr_underscore_unique uniq - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressUniques dflags) $ - char '_' <> pprUniqueAlways uniq - -ppr_occ_name :: OccName -> SDoc -ppr_occ_name occ = ftext (occNameFS occ) - -- Don't use pprOccName; instead, just print the string of the OccName; - -- we print the namespace in the debug stuff above - --- In code style, we Z-encode the strings. The results of Z-encoding each FastString are --- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: OccName -> SDoc -ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) - --- Prints (if mod information is available) "Defined at " or --- "Defined in " information for a Name. -pprDefinedAt :: Name -> SDoc -pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name - -pprNameDefnLoc :: Name -> SDoc --- Prints "at " or --- or "in " depending on what info is available -pprNameDefnLoc name - = case nameSrcLoc name of - -- nameSrcLoc rather than nameSrcSpan - -- It seems less cluttered to show a location - -- rather than a span for the definition point - RealSrcLoc s -> text "at" <+> ppr s - UnhelpfulLoc s - | isInternalName name || isSystemName name - -> text "at" <+> ftext s - | otherwise - -> text "in" <+> quotes (ppr (nameModule name)) - - --- | Get a string representation of a 'Name' that's unique and stable --- across recompilations. Used for deterministic generation of binds for --- derived instances. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" -nameStableString :: Name -> String -nameStableString Name{..} = - nameSortStableString n_sort ++ "$" ++ occNameString n_occ - -nameSortStableString :: NameSort -> String -nameSortStableString System = "$_sys" -nameSortStableString Internal = "$_in" -nameSortStableString (External mod) = moduleStableString mod -nameSortStableString (WiredIn mod _ _) = moduleStableString mod - -{- -************************************************************************ -* * -\subsection{Overloaded functions related to Names} -* * -************************************************************************ --} - --- | A class allowing convenient access to the 'Name' of various datatypes -class NamedThing a where - getOccName :: a -> OccName - getName :: a -> Name - - getOccName n = nameOccName (getName n) -- Default method - -instance NamedThing e => NamedThing (Located e) where - getName = getName . unLoc - -getSrcLoc :: NamedThing a => a -> SrcLoc -getSrcSpan :: NamedThing a => a -> SrcSpan -getOccString :: NamedThing a => a -> String -getOccFS :: NamedThing a => a -> FastString - -getSrcLoc = nameSrcLoc . getName -getSrcSpan = nameSrcSpan . getName -getOccString = occNameString . getOccName -getOccFS = occNameFS . getOccName - -pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc --- See Outputable.pprPrefixVar, pprInfixVar; --- add parens or back-quotes as appropriate -pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) - -pprPrefixName :: NamedThing a => a -> SDoc -pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) - where - name = getName thing diff --git a/basicTypes/Name.hs-boot b/basicTypes/Name.hs-boot deleted file mode 100644 --- a/basicTypes/Name.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Name where - -import GhcPrelude () - -data Name diff --git a/basicTypes/NameCache.hs b/basicTypes/NameCache.hs deleted file mode 100644 --- a/basicTypes/NameCache.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - --- | The Name Cache -module NameCache - ( lookupOrigNameCache - , extendOrigNameCache - , extendNameCache - , initNameCache - , NameCache(..), OrigNameCache - ) where - -import GhcPrelude - -import Module -import Name -import UniqSupply -import TysWiredIn -import Util -import Outputable -import PrelNames - -#include "HsVersions.h" - -{- - -Note [The Name Cache] -~~~~~~~~~~~~~~~~~~~~~ -The Name Cache makes sure that, during any invocation of GHC, each -External Name "M.x" has one, and only one globally-agreed Unique. - -* The first time we come across M.x we make up a Unique and record that - association in the Name Cache. - -* When we come across "M.x" again, we look it up in the Name Cache, - and get a hit. - -The functions newGlobalBinder, allocateGlobalBinder do the main work. -When you make an External name, you should probably be calling one -of them. - - -Note [Built-in syntax and the OrigNameCache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower -their cost we use two tricks, - - a. We specially encode tuple and sum Names in interface files' symbol tables - to avoid having to look up their names while loading interface files. - Namely these names are encoded as by their Uniques. We know how to get from - a Unique back to the Name which it represents via the mapping defined in - the SumTupleUniques module. See Note [Symbol table representation of names] - in BinIface and for details. - - b. We don't include them in the Orig name cache but instead parse their - OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with - them. - -Why is the second measure necessary? Good question; afterall, 1) the parser -emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never -needs to looked-up during interface loading due to (a). It turns out that there -are two reasons why we might look up an Orig RdrName for built-in syntax, - - * If you use setRdrNameSpace on an Exact RdrName it may be - turned into an Orig RdrName. - - * Template Haskell turns a BuiltInSyntax Name into a TH.NameG - (DsMeta.globalVar), and parses a NameG into an Orig RdrName - (Convert.thRdrName). So, e.g. $(do { reify '(,); ... }) will - go this route (#8954). - --} - --- | Per-module cache of original 'OccName's given 'Name's -type OrigNameCache = ModuleEnv (OccEnv Name) - -lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE - , Just name <- isBuiltInOcc_maybe occ - = -- See Note [Known-key names], 3(c) in PrelNames - -- Special case for tuples; there are too many - -- of them to pre-populate the original-name cache - Just name - - | otherwise - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just occ_env -> lookupOccEnv occ_env occ - -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache -extendOrigNameCache nc name - = ASSERT2( isExternalName name, ppr name ) - extendNameCache nc (nameModule name) (nameOccName name) name - -extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extendNameCache nc mod occ name - = extendModuleEnvWith combine nc mod (unitOccEnv occ name) - where - combine _ occ_env = extendOccEnv occ_env occ name - --- | The NameCache makes sure that there is just one Unique assigned for --- each original name; i.e. (module-name, occ-name) pair and provides --- something of a lookup mechanism for those names. -data NameCache - = NameCache { nsUniqs :: !UniqSupply, - -- ^ Supply of uniques - nsNames :: !OrigNameCache - -- ^ Ensures that one original name gets one unique - } - --- | Return a function to atomically update the name cache. -initNameCache :: UniqSupply -> [Name] -> NameCache -initNameCache us names - = NameCache { nsUniqs = us, - nsNames = initOrigNames names } - -initOrigNames :: [Name] -> OrigNameCache -initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/basicTypes/NameEnv.hs b/basicTypes/NameEnv.hs deleted file mode 100644 --- a/basicTypes/NameEnv.hs +++ /dev/null @@ -1,169 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[NameEnv]{@NameEnv@: name environments} --} - -{-# LANGUAGE CPP #-} -module NameEnv ( - -- * Var, Id and TyVar environments (maps) - NameEnv, - - -- ** Manipulating these environments - mkNameEnv, mkNameEnvWith, - emptyNameEnv, isEmptyNameEnv, - unitNameEnv, nameEnvElts, - extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, - extendNameEnvList, extendNameEnvList_C, - filterNameEnv, anyNameEnv, - plusNameEnv, plusNameEnv_C, alterNameEnv, - lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, - elemNameEnv, mapNameEnv, disjointNameEnv, - - DNameEnv, - - emptyDNameEnv, - lookupDNameEnv, - delFromDNameEnv, filterDNameEnv, - mapDNameEnv, - adjustDNameEnv, alterDNameEnv, extendDNameEnv, - -- ** Dependency analysis - depAnal - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Digraph -import Name -import UniqFM -import UniqDFM -import Maybes - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - -{- -Note [depAnal determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -depAnal is deterministic provided it gets the nodes in a deterministic order. -The order of lists that get_defs and get_uses return doesn't matter, as these -are only used to construct the edges, and stronglyConnCompFromEdgedVertices is -deterministic even when the edges are not in deterministic order as explained -in Note [Deterministic SCC] in Digraph. --} - -depAnal :: (node -> [Name]) -- Defs - -> (node -> [Name]) -- Uses - -> [node] - -> [SCC node] --- Perform dependency analysis on a group of definitions, --- where each definition may define more than one Name --- --- The get_defs and get_uses functions are called only once per node -depAnal get_defs get_uses nodes - = stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes) - where - keyed_nodes = nodes `zip` [(1::Int)..] - mk_node (node, key) = - DigraphNode node key (mapMaybe (lookupNameEnv key_map) (get_uses node)) - - key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it - key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - --- | Name Environment -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -isEmptyNameEnv :: NameEnv a -> Bool -mkNameEnv :: [(Name,a)] -> NameEnv a -mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a -nameEnvElts :: NameEnv a -> [a] -alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a -extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b -extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a -extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -lookupNameEnv_NF :: NameEnv a -> Name -> a -filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt -anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool -mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 -disjointNameEnv :: NameEnv a -> NameEnv a -> Bool - -nameEnvElts x = eltsUFM x -emptyNameEnv = emptyUFM -isEmptyNameEnv = isNullUFM -unitNameEnv x y = unitUFM x y -extendNameEnv x y z = addToUFM x y z -extendNameEnvList x l = addListToUFM x l -lookupNameEnv x y = lookupUFM x y -alterNameEnv = alterUFM -mkNameEnv l = listToUFM l -mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) -elemNameEnv x y = elemUFM x y -plusNameEnv x y = plusUFM x y -plusNameEnv_C f x y = plusUFM_C f x y -extendNameEnv_C f x y z = addToUFM_C f x y z -mapNameEnv f x = mapUFM f x -extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b -extendNameEnvList_C x y z = addListToUFM_C x y z -delFromNameEnv x y = delFromUFM x y -delListFromNameEnv x y = delListFromUFM x y -filterNameEnv x y = filterUFM x y -anyNameEnv f x = foldUFM ((||) . f) False x -disjointNameEnv x y = isNullUFM (intersectUFM x y) - -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) - --- | Deterministic Name Environment --- --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DNameEnv. -type DNameEnv a = UniqDFM a - -emptyDNameEnv :: DNameEnv a -emptyDNameEnv = emptyUDFM - -lookupDNameEnv :: DNameEnv a -> Name -> Maybe a -lookupDNameEnv = lookupUDFM - -delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a -delFromDNameEnv = delFromUDFM - -filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a -filterDNameEnv = filterUDFM - -mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b -mapDNameEnv = mapUDFM - -adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a -adjustDNameEnv = adjustUDFM - -alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a -alterDNameEnv = alterUDFM - -extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a -extendDNameEnv = addToUDFM diff --git a/basicTypes/NameSet.hs b/basicTypes/NameSet.hs deleted file mode 100644 --- a/basicTypes/NameSet.hs +++ /dev/null @@ -1,215 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 --} - -{-# LANGUAGE CPP #-} -module NameSet ( - -- * Names set type - NameSet, - - -- ** Manipulating these sets - emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, - minusNameSet, elemNameSet, extendNameSet, extendNameSetList, - delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, - intersectsNameSet, intersectNameSet, - nameSetAny, nameSetAll, nameSetElemsStable, - - -- * Free variables - FreeVars, - - -- ** Manipulating sets of free variables - isEmptyFVs, emptyFVs, plusFVs, plusFV, - mkFVs, addOneFV, unitFV, delFV, delFVs, - intersectFVs, - - -- * Defs and uses - Defs, Uses, DefUse, DefUses, - - -- ** Manipulating defs and uses - emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses, allUses - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Name -import OrdList -import UniqSet -import Data.List (sortBy) - -{- -************************************************************************ -* * -\subsection[Sets of names} -* * -************************************************************************ --} - -type NameSet = UniqSet Name - -emptyNameSet :: NameSet -unitNameSet :: Name -> NameSet -extendNameSetList :: NameSet -> [Name] -> NameSet -extendNameSet :: NameSet -> Name -> NameSet -mkNameSet :: [Name] -> NameSet -unionNameSet :: NameSet -> NameSet -> NameSet -unionNameSets :: [NameSet] -> NameSet -minusNameSet :: NameSet -> NameSet -> NameSet -elemNameSet :: Name -> NameSet -> Bool -isEmptyNameSet :: NameSet -> Bool -delFromNameSet :: NameSet -> Name -> NameSet -delListFromNameSet :: NameSet -> [Name] -> NameSet -filterNameSet :: (Name -> Bool) -> NameSet -> NameSet -intersectNameSet :: NameSet -> NameSet -> NameSet -intersectsNameSet :: NameSet -> NameSet -> Bool --- ^ True if there is a non-empty intersection. --- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty - -isEmptyNameSet = isEmptyUniqSet -emptyNameSet = emptyUniqSet -unitNameSet = unitUniqSet -mkNameSet = mkUniqSet -extendNameSetList = addListToUniqSet -extendNameSet = addOneToUniqSet -unionNameSet = unionUniqSets -unionNameSets = unionManyUniqSets -minusNameSet = minusUniqSet -elemNameSet = elementOfUniqSet -delFromNameSet = delOneFromUniqSet -filterNameSet = filterUniqSet -intersectNameSet = intersectUniqSets - -delListFromNameSet set ns = foldl' delFromNameSet set ns - -intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) - -nameSetAny :: (Name -> Bool) -> NameSet -> Bool -nameSetAny = uniqSetAny - -nameSetAll :: (Name -> Bool) -> NameSet -> Bool -nameSetAll = uniqSetAll - --- | Get the elements of a NameSet with some stable ordering. --- This only works for Names that originate in the source code or have been --- tidied. --- See Note [Deterministic UniqFM] to learn about nondeterminism -nameSetElemsStable :: NameSet -> [Name] -nameSetElemsStable ns = - sortBy stableNameCmp $ nonDetEltsUniqSet ns - -- It's OK to use nonDetEltsUniqSet here because we immediately sort - -- with stableNameCmp - -{- -************************************************************************ -* * -\subsection{Free variables} -* * -************************************************************************ - -These synonyms are useful when we are thinking of free variables --} - -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars -mkFVs :: [Name] -> FreeVars -delFV :: Name -> FreeVars -> FreeVars -delFVs :: [Name] -> FreeVars -> FreeVars -intersectFVs :: FreeVars -> FreeVars -> FreeVars - -isEmptyFVs :: NameSet -> Bool -isEmptyFVs = isEmptyNameSet -emptyFVs = emptyNameSet -plusFVs = unionNameSets -plusFV = unionNameSet -mkFVs = mkNameSet -addOneFV = extendNameSet -unitFV = unitNameSet -delFV n s = delFromNameSet s n -delFVs ns s = delListFromNameSet s ns -intersectFVs = intersectNameSet - -{- -************************************************************************ -* * - Defs and uses -* * -************************************************************************ --} - --- | A set of names that are defined somewhere -type Defs = NameSet - --- | A set of names that are used somewhere -type Uses = NameSet - --- | @(Just ds, us) =>@ The use of any member of the @ds@ --- implies that all the @us@ are used too. --- Also, @us@ may mention @ds@. --- --- @Nothing =>@ Nothing is defined in this group, but --- nevertheless all the uses are essential. --- Used for instance declarations, for example -type DefUse = (Maybe Defs, Uses) - --- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' --- In a single (def, use) pair, the defs also scope over the uses -type DefUses = OrdList DefUse - -emptyDUs :: DefUses -emptyDUs = nilOL - -usesOnly :: Uses -> DefUses -usesOnly uses = unitOL (Nothing, uses) - -mkDUs :: [(Defs,Uses)] -> DefUses -mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] - -plusDU :: DefUses -> DefUses -> DefUses -plusDU = appOL - -duDefs :: DefUses -> Defs -duDefs dus = foldr get emptyNameSet dus - where - get (Nothing, _u1) d2 = d2 - get (Just d1, _u1) d2 = d1 `unionNameSet` d2 - -allUses :: DefUses -> Uses --- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned -allUses dus = foldr get emptyNameSet dus - where - get (_d1, u1) u2 = u1 `unionNameSet` u2 - -duUses :: DefUses -> Uses --- ^ Collect all 'Uses', regardless of whether the group is itself used, --- but remove 'Defs' on the way -duUses dus = foldr get emptyNameSet dus - where - get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) - `minusNameSet` defs - -findUses :: DefUses -> Uses -> Uses --- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. --- The result is a superset of the input 'Uses'; and includes things defined --- in the input 'DefUses' (but only if they are used) -findUses dus uses - = foldr get uses dus - where - get (Nothing, rhs_uses) uses - = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses - | defs `intersectsNameSet` uses -- Used - || nameSetAny (startsWithUnderscore . nameOccName) defs - -- At least one starts with an "_", - -- so treat the group as used - = rhs_uses `unionNameSet` uses - | otherwise -- No def is used - = uses diff --git a/basicTypes/OccName.hs b/basicTypes/OccName.hs deleted file mode 100644 --- a/basicTypes/OccName.hs +++ /dev/null @@ -1,925 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName' represents names as strings with just a little more information: --- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or --- data constructors --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module OccName ( - -- * The 'NameSpace' type - NameSpace, -- Abstract - - nameSpacesRelated, - - -- ** Construction - -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, - tvName, srcDataName, - - -- ** Pretty Printing - pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, - - -- * The 'OccName' type - OccName, -- Abstract, instance of Outputable - pprOccName, - - -- ** Construction - mkOccName, mkOccNameFS, - mkVarOcc, mkVarOccFS, - mkDataOcc, mkDataOccFS, - mkTyVarOcc, mkTyVarOccFS, - mkTcOcc, mkTcOccFS, - mkClsOcc, mkClsOccFS, - mkDFunOcc, - setOccNameSpace, - demoteOccName, - HasOccName(..), - - -- ** Derived 'OccName's - isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, - mkNewTyCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, - mkSuperDictSelOcc, mkSuperDictAuxOcc, - mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, - mkInstTyCoOcc, mkEqPredCoOcc, - mkRecFldSelOcc, - mkTyConRepOcc, - - -- ** Deconstruction - occNameFS, occNameString, occNameSpace, - - isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - parenSymOcc, startsWithUnderscore, - - isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, - - -- * The 'OccEnv' type - OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, - occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, - alterOccEnv, pprOccEnv, - - -- * The 'OccSet' type - OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, - extendOccSetList, - unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, - isEmptyOccSet, intersectOccSet, intersectsOccSet, - filterOccSet, - - -- * Tidying up - TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, - tidyOccName, avoidClashesOccEnv, - - -- FsEnv - FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv - ) where - -import GhcPrelude - -import Util -import Unique -import DynFlags -import UniqFM -import UniqSet -import FastString -import FastStringEnv -import Outputable -import Lexeme -import Binary -import Control.DeepSeq -import Data.Char -import Data.Data - -{- -************************************************************************ -* * -\subsection{Name space} -* * -************************************************************************ --} - -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord ) - --- Note [Data Constructors] --- see also: Note [Data Constructor Naming] in DataCon.hs --- --- $real_vs_source_data_constructors --- There are two forms of data constructor: --- --- [Source data constructors] The data constructors mentioned in Haskell source code --- --- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type --- --- For example: --- --- > data T = T !(Int, Int) --- --- The source datacon has type @(Int, Int) -> T@ --- The real datacon has type @Int -> Int -> T@ --- --- GHC chooses a representation based on the strictness etc. - -tcName, clsName, tcClsName :: NameSpace -dataName, srcDataName :: NameSpace -tvName, varName :: NameSpace - --- Though type constructors and classes are in the same name space now, --- the NameSpace type is abstract, so we can easily separate them later -tcName = TcClsName -- Type constructors -clsName = TcClsName -- Classes -tcClsName = TcClsName -- Not sure which! - -dataName = DataName -srcDataName = DataName -- Haskell-source data constructors should be - -- in the Data name space - -tvName = TvName -varName = VarName - -isDataConNameSpace :: NameSpace -> Bool -isDataConNameSpace DataName = True -isDataConNameSpace _ = False - -isTcClsNameSpace :: NameSpace -> Bool -isTcClsNameSpace TcClsName = True -isTcClsNameSpace _ = False - -isTvNameSpace :: NameSpace -> Bool -isTvNameSpace TvName = True -isTvNameSpace _ = False - -isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors -isVarNameSpace TvName = True -isVarNameSpace VarName = True -isVarNameSpace _ = False - -isValNameSpace :: NameSpace -> Bool -isValNameSpace DataName = True -isValNameSpace VarName = True -isValNameSpace _ = False - -pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = text "data constructor" -pprNameSpace VarName = text "variable" -pprNameSpace TvName = text "type variable" -pprNameSpace TcClsName = text "type constructor or class" - -pprNonVarNameSpace :: NameSpace -> SDoc -pprNonVarNameSpace VarName = empty -pprNonVarNameSpace ns = pprNameSpace ns - -pprNameSpaceBrief :: NameSpace -> SDoc -pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = text "tv" -pprNameSpaceBrief TcClsName = text "tc" - --- demoteNameSpace lowers the NameSpace if possible. We can not know --- in advance, since a TvName can appear in an HsTyVar. --- See Note [Demotion] in RnEnv -demoteNameSpace :: NameSpace -> Maybe NameSpace -demoteNameSpace VarName = Nothing -demoteNameSpace DataName = Nothing -demoteNameSpace TvName = Nothing -demoteNameSpace TcClsName = Just DataName - -{- -************************************************************************ -* * -\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} -* * -************************************************************************ --} - --- | Occurrence Name --- --- In this context that means: --- "classified (i.e. as a type name, value name, etc) but not qualified --- and not yet resolved" -data OccName = OccName - { occNameSpace :: !NameSpace - , occNameFS :: !FastString - } - -instance Eq OccName where - (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 - -instance Ord OccName where - -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) - -instance Data OccName where - -- don't traverse? - toConstr _ = abstractConstr "OccName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "OccName" - -instance HasOccName OccName where - occName = id - -instance NFData OccName where - rnf x = x `seq` () - -{- -************************************************************************ -* * -\subsection{Printing} -* * -************************************************************************ --} - -instance Outputable OccName where - ppr = pprOccName - -instance OutputableBndr OccName where - pprBndr _ = ppr - pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) - pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) - -pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS occ) - else pp_occ <> pp_debug sty - where - pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) - | otherwise = empty - - pp_occ = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressUniques dflags - then text (strip_th_unique (unpackFS occ)) - else ftext occ - - -- See Note [Suppressing uniques in OccNames] - strip_th_unique ('[' : c : _) | isAlphaNum c = [] - strip_th_unique (c : cs) = c : strip_th_unique cs - strip_th_unique [] = [] - -{- -Note [Suppressing uniques in OccNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is a hack to de-wobblify the OccNames that contain uniques from -Template Haskell that have been turned into a string in the OccName. -See Note [Unique OccNames from Template Haskell] in Convert.hs - -************************************************************************ -* * -\subsection{Construction} -* * -************************************************************************ --} - -mkOccName :: NameSpace -> String -> OccName -mkOccName occ_sp str = OccName occ_sp (mkFastString str) - -mkOccNameFS :: NameSpace -> FastString -> OccName -mkOccNameFS occ_sp fs = OccName occ_sp fs - -mkVarOcc :: String -> OccName -mkVarOcc s = mkOccName varName s - -mkVarOccFS :: FastString -> OccName -mkVarOccFS fs = mkOccNameFS varName fs - -mkDataOcc :: String -> OccName -mkDataOcc = mkOccName dataName - -mkDataOccFS :: FastString -> OccName -mkDataOccFS = mkOccNameFS dataName - -mkTyVarOcc :: String -> OccName -mkTyVarOcc = mkOccName tvName - -mkTyVarOccFS :: FastString -> OccName -mkTyVarOccFS fs = mkOccNameFS tvName fs - -mkTcOcc :: String -> OccName -mkTcOcc = mkOccName tcName - -mkTcOccFS :: FastString -> OccName -mkTcOccFS = mkOccNameFS tcName - -mkClsOcc :: String -> OccName -mkClsOcc = mkOccName clsName - -mkClsOccFS :: FastString -> OccName -mkClsOccFS = mkOccNameFS clsName - --- demoteOccName lowers the Namespace of OccName. --- see Note [Demotion] -demoteOccName :: OccName -> Maybe OccName -demoteOccName (OccName space name) = do - space' <- demoteNameSpace space - return $ OccName space' name - --- Name spaces are related if there is a chance to mean the one when one writes --- the other, i.e. variables <-> data constructors and type variables <-> type constructors -nameSpacesRelated :: NameSpace -> NameSpace -> Bool -nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 - -otherNameSpace :: NameSpace -> NameSpace -otherNameSpace VarName = DataName -otherNameSpace DataName = VarName -otherNameSpace TvName = TcClsName -otherNameSpace TcClsName = TvName - - - -{- | Other names in the compiler add additional information to an OccName. -This class provides a consistent way to access the underlying OccName. -} -class HasOccName name where - occName :: name -> OccName - -{- -************************************************************************ -* * - Environments -* * -************************************************************************ - -OccEnvs are used mainly for the envts in ModIfaces. - -Note [The Unique of an OccName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, and indeed FastStrings are allocated keys -sequentially starting at 0. - -So we can make a Unique using - mkUnique ns key :: Unique -where 'ns' is a Char representing the name space. This in turn makes it -easy to build an OccEnv. --} - -instance Uniquable OccName where - -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs - getUnique (OccName DataName fs) = mkDataOccUnique fs - getUnique (OccName TvName fs) = mkTvOccUnique fs - getUnique (OccName TcClsName fs) = mkTcOccUnique fs - -newtype OccEnv a = A (UniqFM a) - deriving Data - -emptyOccEnv :: OccEnv a -unitOccEnv :: OccName -> a -> OccEnv a -extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a -extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a -lookupOccEnv :: OccEnv a -> OccName -> Maybe a -mkOccEnv :: [(OccName,a)] -> OccEnv a -mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a -elemOccEnv :: OccName -> OccEnv a -> Bool -foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b -occEnvElts :: OccEnv a -> [a] -extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a -extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b -plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a -plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a -mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b -delFromOccEnv :: OccEnv a -> OccName -> OccEnv a -delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a -filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt -alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt - -emptyOccEnv = A emptyUFM -unitOccEnv x y = A $ unitUFM x y -extendOccEnv (A x) y z = A $ addToUFM x y z -extendOccEnvList (A x) l = A $ addListToUFM x l -lookupOccEnv (A x) y = lookupUFM x y -mkOccEnv l = A $ listToUFM l -elemOccEnv x (A y) = elemUFM x y -foldOccEnv a b (A c) = foldUFM a b c -occEnvElts (A x) = eltsUFM x -plusOccEnv (A x) (A y) = A $ plusUFM x y -plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z -extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z -mapOccEnv f (A x) = A $ mapUFM f x -mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l -delFromOccEnv (A x) y = A $ delFromUFM x y -delListFromOccEnv (A x) y = A $ delListFromUFM x y -filterOccEnv x (A y) = A $ filterUFM x y -alterOccEnv fn (A y) k = A $ alterUFM fn y k - -instance Outputable a => Outputable (OccEnv a) where - ppr x = pprOccEnv ppr x - -pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc -pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env - -type OccSet = UniqSet OccName - -emptyOccSet :: OccSet -unitOccSet :: OccName -> OccSet -mkOccSet :: [OccName] -> OccSet -extendOccSet :: OccSet -> OccName -> OccSet -extendOccSetList :: OccSet -> [OccName] -> OccSet -unionOccSets :: OccSet -> OccSet -> OccSet -unionManyOccSets :: [OccSet] -> OccSet -minusOccSet :: OccSet -> OccSet -> OccSet -elemOccSet :: OccName -> OccSet -> Bool -isEmptyOccSet :: OccSet -> Bool -intersectOccSet :: OccSet -> OccSet -> OccSet -intersectsOccSet :: OccSet -> OccSet -> Bool -filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet - -emptyOccSet = emptyUniqSet -unitOccSet = unitUniqSet -mkOccSet = mkUniqSet -extendOccSet = addOneToUniqSet -extendOccSetList = addListToUniqSet -unionOccSets = unionUniqSets -unionManyOccSets = unionManyUniqSets -minusOccSet = minusUniqSet -elemOccSet = elementOfUniqSet -isEmptyOccSet = isEmptyUniqSet -intersectOccSet = intersectUniqSets -intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) -filterOccSet = filterUniqSet - -{- -************************************************************************ -* * -\subsection{Predicates and taking them apart} -* * -************************************************************************ --} - -occNameString :: OccName -> String -occNameString (OccName _ s) = unpackFS s - -setOccNameSpace :: NameSpace -> OccName -> OccName -setOccNameSpace sp (OccName _ occ) = OccName sp occ - -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool - -isVarOcc (OccName VarName _) = True -isVarOcc _ = False - -isTvOcc (OccName TvName _) = True -isTvOcc _ = False - -isTcOcc (OccName TcClsName _) = True -isTcOcc _ = False - --- | /Value/ 'OccNames's are those that are either in --- the variable or data constructor namespaces -isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True -isValOcc (OccName DataName _) = True -isValOcc _ = False - -isDataOcc (OccName DataName _) = True -isDataOcc _ = False - --- | Test if the 'OccName' is a data constructor that starts with --- a symbol (e.g. @:@, or @[]@) -isDataSymOcc :: OccName -> Bool -isDataSymOcc (OccName DataName s) = isLexConSym s -isDataSymOcc _ = False --- Pretty inefficient! - --- | Test if the 'OccName' is that for any operator (whether --- it is a data constructor or variable or whatever) -isSymOcc :: OccName -> Bool -isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexSym s -isSymOcc (OccName VarName s) = isLexSym s -isSymOcc (OccName TvName s) = isLexSym s --- Pretty inefficient! - -parenSymOcc :: OccName -> SDoc -> SDoc --- ^ Wrap parens around an operator -parenSymOcc occ doc | isSymOcc occ = parens doc - | otherwise = doc - -startsWithUnderscore :: OccName -> Bool --- ^ Haskell 98 encourages compilers to suppress warnings about unsed --- names in a pattern if they start with @_@: this implements that test -startsWithUnderscore occ = headFS (occNameFS occ) == '_' - -{- -************************************************************************ -* * -\subsection{Making system names} -* * -************************************************************************ - -Here's our convention for splitting up the interface file name space: - - d... dictionary identifiers - (local variables, so no name-clash worries) - -All of these other OccNames contain a mixture of alphabetic -and symbolic characters, and hence cannot possibly clash with -a user-written type or function name - - $f... Dict-fun identifiers (from inst decls) - $dmop Default method for 'op' - $pnC n'th superclass selector for class C - $wf Worker for function 'f' - $sf.. Specialised version of f - D:C Data constructor for dictionary for class C - NTCo:T Coercion connecting newtype T with its representation type - TFCo:R Coercion connecting a data family to its representation type R - -In encoded form these appear as Zdfxxx etc - - :... keywords (export:, letrec: etc.) ---- I THINK THIS IS WRONG! - -This knowledge is encoded in the following functions. - -@mk_deriv@ generates an @OccName@ from the prefix and a string. -NB: The string must already be encoded! --} - --- | Build an 'OccName' derived from another 'OccName'. --- --- Note that the pieces of the name are passed in as a @[FastString]@ so that --- the whole name can be constructed with a single 'concatFS', minimizing --- unnecessary intermediate allocations. -mk_deriv :: NameSpace - -> FastString -- ^ A prefix which distinguishes one sort of - -- derived name from another - -> [FastString] -- ^ The name we are deriving from in pieces which - -- will be concatenated. - -> OccName -mk_deriv occ_sp sys_prefix str = - mkOccNameFS occ_sp (concatFS $ sys_prefix : str) - -isDerivedOccName :: OccName -> Bool --- ^ Test for definitions internally generated by GHC. This predicte --- is used to suppress printing of internal definitions in some debug prints -isDerivedOccName occ = - case occNameString occ of - '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo - c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions - _other -> False - -isDefaultMethodOcc :: OccName -> Bool -isDefaultMethodOcc occ = - case occNameString occ of - '$':'d':'m':_ -> True - _ -> False - --- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? --- This is needed as these bindings are renamed differently. --- See Note [Grand plan for Typeable] in TcTypeable. -isTypeableBindOcc :: OccName -> Bool -isTypeableBindOcc occ = - case occNameString occ of - '$':'t':'c':_ -> True -- mkTyConRepOcc - '$':'t':'r':_ -> True -- Module binding - _ -> False - -mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, - mkClassDataConOcc, mkDictOcc, - mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkTyConRepOcc - :: OccName -> OccName - --- These derived variables have a prefix that no Haskell value could have -mkDataConWrapperOcc = mk_simple_deriv varName "$W" -mkWorkerOcc = mk_simple_deriv varName "$w" -mkMatcherOcc = mk_simple_deriv varName "$m" -mkBuilderOcc = mk_simple_deriv varName "$b" -mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkClassOpAuxOcc = mk_simple_deriv varName "$c" -mkDictOcc = mk_simple_deriv varName "$d" -mkIPOcc = mk_simple_deriv varName "$i" -mkSpecOcc = mk_simple_deriv varName "$s" -mkForeignExportOcc = mk_simple_deriv varName "$f" -mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible -mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class -mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" - --- Used in derived instances -mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" -mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" -mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" - --- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable -mkTyConRepOcc occ = mk_simple_deriv varName prefix occ - where - prefix | isDataOcc occ = "$tc'" - | otherwise = "$tc" - --- Generic deriving mechanism -mkGenR = mk_simple_deriv tcName "Rep_" -mkGen1R = mk_simple_deriv tcName "Rep1_" - --- Overloaded record field selectors -mkRecFldSelOcc :: String -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] - -mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName -mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] - --- Data constructor workers are made by setting the name space --- of the data constructor OccName (which should be a DataName) --- to VarName -mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ - -mkSuperDictAuxOcc :: Int -> OccName -> OccName -mkSuperDictAuxOcc index cls_tc_occ - = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] - -mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 - -> OccName -- ^ Class, e.g. @Ord@ - -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ -mkSuperDictSelOcc index cls_tc_occ - = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] - -mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' - -> OccName -- ^ Local name, e.g. @sat@ - -> OccName -- ^ Nice unique version, e.g. @$L23sat@ -mkLocalOcc uniq occ - = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] - -- The Unique might print with characters - -- that need encoding (e.g. 'z'!) - --- | Derive a name for the representation type constructor of a --- @data@\/@newtype@ instance. -mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ @R:Map@ -mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) - -mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. - -- Only used in debug mode, for extra clarity - -> Bool -- ^ Is this a hs-boot instance DFun? - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ - --- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real --- thing when we compile the mother module. Reason: we don't know exactly --- what the mother module will call it. - -mkDFunOcc info_str is_boot set - = chooseUniqueOcc VarName (prefix ++ info_str) set - where - prefix | is_boot = "$fx" - | otherwise = "$f" - -mkDataTOcc, mkDataCOcc - :: OccName -- ^ TyCon or data con string - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ --- data T = MkT ... deriving( Data ) needs definitions for --- $tT :: Data.Generics.Basics.DataType --- $cMkT :: Data.Generics.Basics.Constr -mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) -mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) - -{- -Sometimes we need to pick an OccName that has not already been used, -given a set of in-use OccNames. --} - -chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName -chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) - where - loop occ n - | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) - | otherwise = occ - -{- -We used to add a '$m' to indicate a method, but that gives rise to bad -error messages from the type checker when we print the function name or pattern -of an instance-decl binding. Why? Because the binding is zapped -to use the method name in place of the selector name. -(See TcClassDcl.tcMethodBind) - -The way it is now, -ddump-xx output may look confusing, but -you can always say -dppr-debug to get the uniques. - -However, we *do* have to zap the first character to be lower case, -because overloaded constructors (blarg) generate methods too. -And convert to VarName space - -e.g. a call to constructor MkFoo where - data (Ord a) => Foo a = MkFoo a - -If this is necessary, we do it by prefixing '$m'. These -guys never show up in error messages. What a hack. --} - -mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName _) = occ -mkMethodOcc occ = mk_simple_deriv varName "$m" occ - -{- -************************************************************************ -* * -\subsection{Tidying them up} -* * -************************************************************************ - -Before we print chunks of code we like to rename it so that -we don't have to print lots of silly uniques in it. But we mustn't -accidentally introduce name clashes! So the idea is that we leave the -OccName alone unless it accidentally clashes with one that is already -in scope; if so, we tack on '1' at the end and try again, then '2', and -so on till we find a unique one. - -There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' -because that isn't a single lexeme. So we encode it to 'lle' and *then* -tack on the '1', if necessary. - -Note [TidyOccEnv] -~~~~~~~~~~~~~~~~~ -type TidyOccEnv = UniqFM Int - -* Domain = The OccName's FastString. These FastStrings are "taken"; - make sure that we don't re-use - -* Int, n = A plausible starting point for new guesses - There is no guarantee that "FSn" is available; - you must look that up in the TidyOccEnv. But - it's a good place to start looking. - -* When looking for a renaming for "foo2" we strip off the "2" and start - with "foo". Otherwise if we tidy twice we get silly names like foo23. - - However, if it started with digits at the end, we always make a name - with digits at the end, rather than shortening "foo2" to just "foo", - even if "foo" is unused. Reasons: - - Plain "foo" might be used later - - We use trailing digits to subtly indicate a unification variable - in typechecker error message; see TypeRep.tidyTyVarBndr - -We have to take care though! Consider a machine-generated module (#10370) - module Foo where - a1 = e1 - a2 = e2 - ... - a2000 = e2000 -Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, -we have to do a linear search to find a free one, "a2001". That might just be -acceptable once. But if we now come across "a8" again, we don't want to repeat -that search. - -So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for -starting the search; and we make sure to update the starting point for "a" -after we allocate a new one. - - -Note [Tidying multiple names at once] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider - - > :t (id,id,id) - -Every id contributes a type variable to the type signature, and all of them are -"a". If we tidy them one by one, we get - - (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) - -which is a bit unfortunate, as it unfairly renames only one of them. What we -would like to see is - - (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) - -To achieve this, the function avoidClashesOccEnv can be used to prepare the -TidyEnv, by “blocking” every name that occurs twice in the map. This way, none -of the "a"s will get the privilege of keeping this name, and all of them will -get a suitable number by tidyOccName. - -This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs -for an example where this is used. - -This is #12382. - --} - -type TidyOccEnv = UniqFM Int -- The in-scope OccNames - -- See Note [TidyOccEnv] - -emptyTidyOccEnv :: TidyOccEnv -emptyTidyOccEnv = emptyUFM - -initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl' add emptyUFM - where - add env (OccName _ fs) = addToUFM env fs 1 - --- see Note [Tidying multiple names at once] -avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv -avoidClashesOccEnv env occs = go env emptyUFM occs - where - go env _ [] = env - go env seenOnce ((OccName _ fs):occs) - | fs `elemUFM` env = go env seenOnce occs - | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs - | otherwise = go env (addToUFM seenOnce fs ()) occs - -tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) -tidyOccName env occ@(OccName occ_sp fs) - | not (fs `elemUFM` env) - = -- Desired OccName is free, so use it, - -- and record in 'env' that it's no longer available - (addToUFM env fs 1, occ) - - | otherwise - = case lookupUFM env base1 of - Nothing -> (addToUFM env base1 2, OccName occ_sp base1) - Just n -> find 1 n - where - base :: String -- Drop trailing digits (see Note [TidyOccEnv]) - base = dropWhileEndLE isDigit (unpackFS fs) - base1 = mkFastString (base ++ "1") - - find !k !n - = case lookupUFM env new_fs of - Just {} -> find (k+1 :: Int) (n+k) - -- By using n+k, the n argument to find goes - -- 1, add 1, add 2, add 3, etc which - -- moves at quadratic speed through a dense patch - - Nothing -> (new_env, OccName occ_sp new_fs) - where - new_fs = mkFastString (base ++ show n) - new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) - -- Update: base1, so that next time we'll start where we left off - -- new_fs, so that we know it is taken - -- If they are the same (n==1), the former wins - -- See Note [TidyOccEnv] - - -{- -************************************************************************ -* * - Binary instance - Here rather than BinIface because OccName is abstract -* * -************************************************************************ --} - -instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 - put_ bh DataName = do - putByte bh 1 - put_ bh TvName = do - putByte bh 2 - put_ bh TcClsName = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName - -instance Binary OccName where - put_ bh (OccName aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (OccName aa ab) diff --git a/basicTypes/OccName.hs-boot b/basicTypes/OccName.hs-boot deleted file mode 100644 --- a/basicTypes/OccName.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module OccName where - -import GhcPrelude () - -data OccName diff --git a/basicTypes/PatSyn.hs b/basicTypes/PatSyn.hs deleted file mode 100644 --- a/basicTypes/PatSyn.hs +++ /dev/null @@ -1,484 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[PatSyn]{@PatSyn@: Pattern synonyms} --} - -{-# LANGUAGE CPP #-} - -module PatSyn ( - -- * Main data types - PatSyn, mkPatSyn, - - -- ** Type deconstruction - patSynName, patSynArity, patSynIsInfix, - patSynArgs, - patSynMatcher, patSynBuilder, - patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, - patSynInstArgTys, patSynInstResTy, patSynFieldLabels, - patSynFieldType, - - updatePatSynIds, pprPatSynType - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Type -import TyCoPpr -import Name -import Outputable -import Unique -import Util -import BasicTypes -import Var -import FieldLabel - -import qualified Data.Data as Data -import Data.Function -import Data.List (find) - -{- -************************************************************************ -* * -\subsection{Pattern synonyms} -* * -************************************************************************ --} - --- | Pattern Synonym --- --- See Note [Pattern synonym representation] --- See Note [Pattern synonym signature contexts] -data PatSyn - = MkPatSyn { - psName :: Name, - psUnique :: Unique, -- Cached from Name - - psArgs :: [Type], - psArity :: Arity, -- == length psArgs - psInfix :: Bool, -- True <=> declared infix - psFieldLabels :: [FieldLabel], -- List of fields for a - -- record pattern synonym - -- INVARIANT: either empty if no - -- record pat syn or same length as - -- psArgs - - -- Universally-quantified type variables - psUnivTyVars :: [TyVarBinder], - - -- Required dictionaries (may mention psUnivTyVars) - psReqTheta :: ThetaType, - - -- Existentially-quantified type vars - psExTyVars :: [TyVarBinder], - - -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) - psProvTheta :: ThetaType, - - -- Result type - psResultTy :: Type, -- Mentions only psUnivTyVars - -- See Note [Pattern synonym result type] - - -- See Note [Matchers and builders for pattern synonyms] - psMatcher :: (Id, Bool), - -- Matcher function. - -- If Bool is True then prov_theta and arg_tys are empty - -- and type is - -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. Void# -> r) - -- -> (Void# -> r) - -- -> r - -- - -- Otherwise type is - -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. prov_theta => arg_tys -> r) - -- -> (Void# -> r) - -- -> r - - psBuilder :: Maybe (Id, Bool) - -- Nothing => uni-directional pattern synonym - -- Just (builder, is_unlifted) => bi-directional - -- Builder function, of type - -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) - -- => arg_tys -> res_ty - -- See Note [Builder for pattern synonyms with unboxed type] - } - -{- Note [Pattern synonym signature contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a pattern synonym signature we write - pattern P :: req => prov => t1 -> ... tn -> res_ty - -Note that the "required" context comes first, then the "provided" -context. Moreover, the "required" context must not mention -existentially-bound type variables; that is, ones not mentioned in -res_ty. See lots of discussion in #10928. - -If there is no "provided" context, you can omit it; but you -can't omit the "required" part (unless you omit both). - -Example 1: - pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) - pattern P1 x = Just (3,x) - - We require (Num a, Eq a) to match the 3; there is no provided - context. - -Example 2: - data T2 where - MkT2 :: (Num a, Eq a) => a -> a -> T2 - - pattern P2 :: () => (Num a, Eq a) => a -> T2 - pattern P2 x = MkT2 3 x - - When we match against P2 we get a Num dictionary provided. - We can use that to check the match against 3. - -Example 3: - pattern P3 :: Eq a => a -> b -> T3 b - - This signature is illegal because the (Eq a) is a required - constraint, but it mentions the existentially-bound variable 'a'. - You can see it's existential because it doesn't appear in the - result type (T3 b). - -Note [Pattern synonym result type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b = MkT b a - - pattern P :: a -> T [a] Bool - pattern P x = MkT True [x] - -P's psResultTy is (T a Bool), and it really only matches values of -type (T [a] Bool). For example, this is ill-typed - - f :: T p q -> String - f (P x) = "urk" - -This is different to the situation with GADTs: - - data S a where - MkS :: Int -> S Bool - -Now MkS (and pattern synonyms coming from MkS) can match a -value of type (S a), not just (S Bool); we get type refinement. - -That in turn means that if you have a pattern - - P x :: T [ty] Bool - -it's not entirely straightforward to work out the instantiation of -P's universal tyvars. You have to /match/ - the type of the pattern, (T [ty] Bool) -against - the psResultTy for the pattern synonym, T [a] Bool -to get the instantiation a := ty. - -This is very unlike DataCons, where univ tyvars match 1-1 the -arguments of the TyCon. - -Side note: I (SG) get the impression that instantiated return types should -generate a *required* constraint for pattern synonyms, rather than a *provided* -constraint like it's the case for GADTs. For example, I'd expect these -declarations to have identical semantics: - - pattern Just42 :: Maybe Int - pattern Just42 = Just 42 - - pattern Just'42 :: (a ~ Int) => Maybe a - pattern Just'42 = Just 42 - -The latter generates the proper required constraint, the former does not. -Also rather different to GADTs is the fact that Just42 doesn't have any -universally quantified type variables, whereas Just'42 or MkS above has. - -Note [Pattern synonym representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym declaration - - pattern P x = MkT [x] (Just 42) - -where - data T a where - MkT :: (Show a, Ord b) => [b] -> a -> T a - -so pattern P has type - - b -> T (Maybe t) - -with the following typeclass constraints: - - requires: (Eq t, Num t) - provides: (Show (Maybe t), Ord b) - -In this case, the fields of MkPatSyn will be set as follows: - - psArgs = [b] - psArity = 1 - psInfix = False - - psUnivTyVars = [t] - psExTyVars = [b] - psProvTheta = (Show (Maybe t), Ord b) - psReqTheta = (Eq t, Num t) - psResultTy = T (Maybe t) - -Note [Matchers and builders for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For each pattern synonym P, we generate - - * a "matcher" function, used to desugar uses of P in patterns, - which implements pattern matching - - * A "builder" function (for bidirectional pattern synonyms only), - used to desugar uses of P in expressions, which constructs P-values. - -For the above example, the matcher function has type: - - $mP :: forall (r :: ?) t. (Eq t, Num t) - => T (Maybe t) - -> (forall b. (Show (Maybe t), Ord b) => b -> r) - -> (Void# -> r) - -> r - -with the following implementation: - - $mP @r @t $dEq $dNum scrut cont fail - = case scrut of - MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x - _ -> fail Void# - -Notice that the return type 'r' has an open kind, so that it can -be instantiated by an unboxed type; for example where we see - f (P x) = 3# - -The extra Void# argument for the failure continuation is needed so that -it is lazy even when the result type is unboxed. - -For the same reason, if the pattern has no arguments, an extra Void# -argument is added to the success continuation as well. - -For *bidirectional* pattern synonyms, we also generate a "builder" -function which implements the pattern synonym in an expression -context. For our running example, it will be: - - $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) - => b -> T (Maybe t) - $bP x = MkT [x] (Just 42) - -NB: the existential/universal and required/provided split does not -apply to the builder since you are only putting stuff in, not getting -stuff out. - -Injectivity of bidirectional pattern synonyms is checked in -tcPatToExpr which walks the pattern and returns its corresponding -expression when available. - -Note [Builder for pattern synonyms with unboxed type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For bidirectional pattern synonyms that have no arguments and have an -unboxed type, we add an extra Void# argument to the builder, else it -would be a top-level declaration with an unboxed type. - - pattern P = 0# - - $bP :: Void# -> Int# - $bP _ = 0# - -This means that when typechecking an occurrence of P in an expression, -we must remember that the builder has this void argument. This is -done by TcPatSyn.patSynBuilderOcc. - -Note [Pattern synonyms and the data type Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type of a pattern synonym is of the form (See Note -[Pattern synonym signatures] in TcSigs): - - forall univ_tvs. req => forall ex_tvs. prov => ... - -We cannot in general represent this by a value of type Type: - - - if ex_tvs is empty, then req and prov cannot be distinguished from - each other - - if req is empty, then univ_tvs and ex_tvs cannot be distinguished - from each other, and moreover, prov is seen as the "required" context - (as it is the only context) - - -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq PatSyn where - (==) = (==) `on` getUnique - (/=) = (/=) `on` getUnique - -instance Uniquable PatSyn where - getUnique = psUnique - -instance NamedThing PatSyn where - getName = patSynName - -instance Outputable PatSyn where - ppr = ppr . getName - -instance OutputableBndr PatSyn where - pprInfixOcc = pprInfixName . getName - pprPrefixOcc = pprPrefixName . getName - -instance Data.Data PatSyn where - -- don't traverse? - toConstr _ = abstractConstr "PatSyn" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "PatSyn" - -{- -************************************************************************ -* * -\subsection{Construction} -* * -************************************************************************ --} - --- | Build a new pattern synonym -mkPatSyn :: Name - -> Bool -- ^ Is the pattern synonym declared infix? - -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type - -- variables and required dicts - -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type - -- variables and provided dicts - -> [Type] -- ^ Original arguments - -> Type -- ^ Original result type - -> (Id, Bool) -- ^ Name of matcher - -> Maybe (Id, Bool) -- ^ Name of builder - -> [FieldLabel] -- ^ Names of fields for - -- a record pattern synonym - -> PatSyn - -- NB: The univ and ex vars are both in TyBinder form and TyVar form for - -- convenience. All the TyBinders should be Named! -mkPatSyn name declared_infix - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - orig_args - orig_res_ty - matcher builder field_labels - = MkPatSyn {psName = name, psUnique = getUnique name, - psUnivTyVars = univ_tvs, - psExTyVars = ex_tvs, - psProvTheta = prov_theta, psReqTheta = req_theta, - psInfix = declared_infix, - psArgs = orig_args, - psArity = length orig_args, - psResultTy = orig_res_ty, - psMatcher = matcher, - psBuilder = builder, - psFieldLabels = field_labels - } - --- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification -patSynName :: PatSyn -> Name -patSynName = psName - --- | Should the 'PatSyn' be presented infix? -patSynIsInfix :: PatSyn -> Bool -patSynIsInfix = psInfix - --- | Arity of the pattern synonym -patSynArity :: PatSyn -> Arity -patSynArity = psArity - -patSynArgs :: PatSyn -> [Type] -patSynArgs = psArgs - -patSynFieldLabels :: PatSyn -> [FieldLabel] -patSynFieldLabels = psFieldLabels - --- | Extract the type for any given labelled field of the 'DataCon' -patSynFieldType :: PatSyn -> FieldLabelString -> Type -patSynFieldType ps label - = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of - Just (_, ty) -> ty - Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) - -patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] -patSynUnivTyVarBinders = psUnivTyVars - -patSynExTyVars :: PatSyn -> [TyVar] -patSynExTyVars ps = binderVars (psExTyVars ps) - -patSynExTyVarBinders :: PatSyn -> [TyVarBinder] -patSynExTyVarBinders = psExTyVars - -patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs - , psProvTheta = prov, psReqTheta = req - , psArgs = arg_tys, psResultTy = res_ty }) - = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) - -patSynMatcher :: PatSyn -> (Id,Bool) -patSynMatcher = psMatcher - -patSynBuilder :: PatSyn -> Maybe (Id, Bool) -patSynBuilder = psBuilder - -updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn -updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) - = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } - where - tidy_pr (id, dummy) = (tidy_fn id, dummy) - -patSynInstArgTys :: PatSyn -> [Type] -> [Type] --- Return the types of the argument patterns --- e.g. data D a = forall b. MkD a b (b->a) --- pattern P f x y = MkD (x,True) y f --- D :: forall a. forall b. a -> b -> (b->a) -> D a --- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c --- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] --- NB: the inst_tys should be both universal and existential -patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs - , psExTyVars = ex_tvs, psArgs = arg_tys }) - inst_tys - = ASSERT2( tyvars `equalLength` inst_tys - , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = binderVars (univ_tvs ++ ex_tvs) - -patSynInstResTy :: PatSyn -> [Type] -> Type --- Return the type of whole pattern --- E.g. pattern P x y = Just (x,x,y) --- P :: a -> b -> Just (a,a,b) --- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) --- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars -patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs - , psResultTy = res_ty }) - inst_tys - = ASSERT2( univ_tvs `equalLength` inst_tys - , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) - substTyWith (binderVars univ_tvs) inst_tys res_ty - --- | Print the type of a pattern synonym. The foralls are printed explicitly -pprPatSynType :: PatSyn -> SDoc -pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta - , psExTyVars = ex_tvs, psProvTheta = prov_theta - , psArgs = orig_args, psResultTy = orig_res_ty }) - = sep [ pprForAll univ_tvs - , pprThetaArrowTy req_theta - , ppWhen insert_empty_ctxt $ parens empty <+> darrow - , pprType sigma_ty ] - where - sigma_ty = mkForAllTys ex_tvs $ - mkInvisFunTys prov_theta $ - mkVisFunTys orig_args orig_res_ty - insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/basicTypes/PatSyn.hs-boot b/basicTypes/PatSyn.hs-boot deleted file mode 100644 --- a/basicTypes/PatSyn.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ -module PatSyn where - -import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep (Type) -import Var (TyVar) -import Name (Name) - -data PatSyn - -patSynArity :: PatSyn -> Arity -patSynInstArgTys :: PatSyn -> [Type] -> [Type] -patSynExTyVars :: PatSyn -> [TyVar] -patSynName :: PatSyn -> Name diff --git a/basicTypes/Predicate.hs b/basicTypes/Predicate.hs deleted file mode 100644 --- a/basicTypes/Predicate.hs +++ /dev/null @@ -1,228 +0,0 @@ -{- - -Describes predicates as they are considered by the solver. - --} - -module Predicate ( - Pred(..), classifyPredType, - isPredTy, isEvVarType, - - -- Equality predicates - EqRel(..), eqRelRole, - isEqPrimPred, isEqPred, - getEqPredTys, getEqPredTys_maybe, getEqPredRole, - predTypeEqRel, - mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, - mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, - - -- Class predicates - mkClassPred, isDictTy, - isClassPred, isEqPredClass, isCTupleClass, - getClassPredTys, getClassPredTys_maybe, - - -- Implicit parameters - isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred, - - -- Evidence variables - DictId, isEvVar, isDictId - ) where - -import GhcPrelude - -import Type -import Class -import TyCon -import Var -import Coercion - -import PrelNames - -import FastString -import Outputable -import Util - -import Control.Monad ( guard ) - --- | A predicate in the solver. The solver tries to prove Wanted predicates --- from Given ones. -data Pred - = ClassPred Class [Type] - | EqPred EqRel Type Type - | IrredPred PredType - | ForAllPred [TyCoVarBinder] [PredType] PredType - -- ForAllPred: see Note [Quantified constraints] in TcCanonical - -- NB: There is no TuplePred case - -- Tuple predicates like (Eq a, Ord b) are just treated - -- as ClassPred, as if we had a tuple class with two superclasses - -- class (c1, c2) => (%,%) c1 c2 - -classifyPredType :: PredType -> Pred -classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of - Just (tc, [_, _, ty1, ty2]) - | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 - | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 - - Just (tc, tys) - | Just clas <- tyConClass_maybe tc - -> ClassPred clas tys - - _ | (tvs, rho) <- splitForAllVarBndrs ev_ty - , (theta, pred) <- splitFunTys rho - , not (null tvs && null theta) - -> ForAllPred tvs theta pred - - | otherwise - -> IrredPred ev_ty - --- --------------------- Dictionary types --------------------------------- - -mkClassPred :: Class -> [Type] -> PredType -mkClassPred clas tys = mkTyConApp (classTyCon clas) tys - -isDictTy :: Type -> Bool -isDictTy = isClassPred - -getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) -getClassPredTys ty = case getClassPredTys_maybe ty of - Just (clas, tys) -> (clas, tys) - Nothing -> pprPanic "getClassPredTys" (ppr ty) - -getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) -getClassPredTys_maybe ty = case splitTyConApp_maybe ty of - Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) - _ -> Nothing - --- --------------------- Equality predicates --------------------------------- - --- | A choice of equality relation. This is separate from the type 'Role' --- because 'Phantom' does not define a (non-trivial) equality relation. -data EqRel = NomEq | ReprEq - deriving (Eq, Ord) - -instance Outputable EqRel where - ppr NomEq = text "nominal equality" - ppr ReprEq = text "representational equality" - -eqRelRole :: EqRel -> Role -eqRelRole NomEq = Nominal -eqRelRole ReprEq = Representational - -getEqPredTys :: PredType -> (Type, Type) -getEqPredTys ty - = case splitTyConApp_maybe ty of - Just (tc, [_, _, ty1, ty2]) - | tc `hasKey` eqPrimTyConKey - || tc `hasKey` eqReprPrimTyConKey - -> (ty1, ty2) - _ -> pprPanic "getEqPredTys" (ppr ty) - -getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) -getEqPredTys_maybe ty - = case splitTyConApp_maybe ty of - Just (tc, [_, _, ty1, ty2]) - | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) - | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) - _ -> Nothing - -getEqPredRole :: PredType -> Role -getEqPredRole ty = eqRelRole (predTypeEqRel ty) - --- | Get the equality relation relevant for a pred type. -predTypeEqRel :: PredType -> EqRel -predTypeEqRel ty - | Just (tc, _) <- splitTyConApp_maybe ty - , tc `hasKey` eqReprPrimTyConKey - = ReprEq - | otherwise - = NomEq - -{------------------------------------------- -Predicates on PredType ---------------------------------------------} - -{- -Note [Evidence for quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The superclass mechanism in TcCanonical.makeSuperClasses risks -taking a quantified constraint like - (forall a. C a => a ~ b) -and generate superclass evidence - (forall a. C a => a ~# b) - -This is a funny thing: neither isPredTy nor isCoVarType are true -of it. So we are careful not to generate it in the first place: -see Note [Equality superclasses in quantified constraints] -in TcCanonical. --} - -isEvVarType :: Type -> Bool --- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b) --- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2) --- See Note [Types for coercions, predicates, and evidence] in TyCoRep --- See Note [Evidence for quantified constraints] -isEvVarType ty = isCoVarType ty || isPredTy ty - -isEqPredClass :: Class -> Bool --- True of (~) and (~~) -isEqPredClass cls = cls `hasKey` eqTyConKey - || cls `hasKey` heqTyConKey - -isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool -isClassPred ty = case tyConAppTyCon_maybe ty of - Just tyCon | isClassTyCon tyCon -> True - _ -> False - -isEqPred ty -- True of (a ~ b) and (a ~~ b) - -- ToDo: should we check saturation? - | Just tc <- tyConAppTyCon_maybe ty - , Just cls <- tyConClass_maybe tc - = isEqPredClass cls - | otherwise - = False - -isEqPrimPred ty = isCoVarType ty - -- True of (a ~# b) (a ~R# b) - -isIPPred ty = case tyConAppTyCon_maybe ty of - Just tc -> isIPTyCon tc - _ -> False - -isIPTyCon :: TyCon -> Bool -isIPTyCon tc = tc `hasKey` ipClassKey - -- Class and its corresponding TyCon have the same Unique - -isIPClass :: Class -> Bool -isIPClass cls = cls `hasKey` ipClassKey - -isCTupleClass :: Class -> Bool -isCTupleClass cls = isTupleTyCon (classTyCon cls) - -isIPPred_maybe :: Type -> Maybe (FastString, Type) -isIPPred_maybe ty = - do (tc,[t1,t2]) <- splitTyConApp_maybe ty - guard (isIPTyCon tc) - x <- isStrLitTy t1 - return (x,t2) - -hasIPPred :: PredType -> Bool -hasIPPred pred - = case classifyPredType pred of - ClassPred cls tys - | isIPClass cls -> True - | isCTupleClass cls -> any hasIPPred tys - _other -> False - -{- -************************************************************************ -* * - Evidence variables -* * -************************************************************************ --} - -isEvVar :: Var -> Bool -isEvVar var = isEvVarType (varType var) - -isDictId :: Id -> Bool -isDictId id = isDictTy (varType id) diff --git a/basicTypes/RdrName.hs b/basicTypes/RdrName.hs deleted file mode 100644 --- a/basicTypes/RdrName.hs +++ /dev/null @@ -1,1412 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName' is the type of names that come directly from the parser. They --- have not yet had their scoping and binding resolved by the renamer and can be --- thought of to a first approximation as an 'OccName.OccName' with an optional module --- qualifier --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module RdrName ( - -- * The main type - RdrName(..), -- Constructors exported only to BinIface - - -- ** Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, - - -- ** Destruction - rdrNameOcc, rdrNameSpace, demoteRdrName, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - - -- * Local mapping of 'RdrName' to 'Name.Name' - LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, - elemLocalRdrEnv, inLocalRdrEnvScope, - localRdrEnvElts, delLocalRdrEnvList, - - -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, - pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, - lookupGRE_Name_OccName, - getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, - - -- * GlobalRdrElts - gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, - greRdrNames, greSrcSpan, greQualModName, - gresToAvailInfo, - - -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel, - unQualOK, qualSpecOK, unQualSpecOK, - pprNameProvenance, - Parent(..), greParent_maybe, - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport, - - -- * Utils for StarIsType - starInfo - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Module -import Name -import Avail -import NameSet -import Maybes -import SrcLoc -import FastString -import FieldLabel -import Outputable -import Unique -import UniqFM -import UniqSet -import Util -import NameEnv - -import Data.Data -import Data.List( sortBy ) - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `bar` --- > ( ~ ) --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', --- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, --- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, --- 'ApiAnnotation.AnnBackquote' @'`'@, --- 'ApiAnnotation.AnnVal' --- 'ApiAnnotation.AnnTilde', - --- For details on above see note [Api annotations] in ApiAnnotation -data RdrName - = Unqual OccName - -- ^ Unqualified name - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Simple functions} -* * -************************************************************************ --} - -instance HasOccName RdrName where - occName = rdrNameOcc - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrNameSpace :: RdrName -> NameSpace -rdrNameSpace = occNameSpace . rdrNameOcc - --- demoteRdrName lowers the NameSpace of RdrName. --- see Note [Demotion] in OccName -demoteRdrName :: RdrName -> Maybe RdrName -demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) -demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) -demoteRdrName (Orig _ _) = panic "demoteRdrName" -demoteRdrName (Exact _) = panic "demoteRdrName" - - -- These two are the basic constructors -mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = Unqual occ - -mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = Qual mod occ - -mkOrig :: Module -> OccName -> RdrName -mkOrig mod occ = Orig mod occ - ---------------- - -- These two are used when parsing source files - -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> FastString -> RdrName -mkUnqual sp n = Unqual (mkOccNameFS sp n) - -mkVarUnqual :: FastString -> RdrName -mkVarUnqual n = Unqual (mkVarOccFS n) - --- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and --- the 'OccName' are taken from the first and second elements of the tuple respectively -mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) - -getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = nameRdrName (getName name) - -nameRdrName :: Name -> RdrName -nameRdrName name = Exact name --- Keep the Name even for Internal names, so that the --- unique is still there for debug printing, particularly --- of Types (which are converted to IfaceTypes before printing) - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -isRdrDataCon :: RdrName -> Bool -isRdrTyVar :: RdrName -> Bool -isRdrTc :: RdrName -> Bool - -isRdrDataCon rn = isDataOcc (rdrNameOcc rn) -isRdrTyVar rn = isTvOcc (rdrNameOcc rn) -isRdrTc rn = isTcOcc (rdrNameOcc rn) - -isSrcRdrName :: RdrName -> Bool -isSrcRdrName (Unqual _) = True -isSrcRdrName (Qual _ _) = True -isSrcRdrName _ = False - -isUnqual :: RdrName -> Bool -isUnqual (Unqual _) = True -isUnqual _ = False - -isQual :: RdrName -> Bool -isQual (Qual _ _) = True -isQual _ = False - -isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) -isQual_maybe (Qual m n) = Just (m,n) -isQual_maybe _ = Nothing - -isOrig :: RdrName -> Bool -isOrig (Orig _ _) = True -isOrig _ = False - -isOrig_maybe :: RdrName -> Maybe (Module, OccName) -isOrig_maybe (Orig m n) = Just (m,n) -isOrig_maybe _ = Nothing - -isExact :: RdrName -> Bool -isExact (Exact _) = True -isExact _ = False - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Orig _ _) _ = GT - -{- -************************************************************************ -* * - LocalRdrEnv -* * -************************************************************************ --} - --- | Local Reader Environment --- --- This environment is used to store local bindings --- (@let@, @where@, lambda, @case@). --- It is keyed by OccName, because we never use it for qualified names --- We keep the current mapping, *and* the set of all Names in scope --- Reason: see Note [Splicing Exact names] in RnEnv -data LocalRdrEnv = LRE { lre_env :: OccEnv Name - , lre_in_scope :: NameSet } - -instance Outputable LocalRdrEnv where - ppr (LRE {lre_env = env, lre_in_scope = ns}) - = hang (text "LocalRdrEnv {") - 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env - , text "in_scope =" - <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) - ] <+> char '}') - where - ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name - -- So we can see if the keys line up correctly - -emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv - , lre_in_scope = emptyNameSet } - -extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv --- The Name should be a non-top-level thing -extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name - = WARN( isExternalName name, ppr name ) - lre { lre_env = extendOccEnv env (nameOccName name) name - , lre_in_scope = extendNameSet ns name } - -extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names - = WARN( any isExternalName names, ppr names ) - lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] - , lre_in_scope = extendNameSetList ns names } - -lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr - | Unqual occ <- rdr - = lookupOccEnv env occ - - -- See Note [Local bindings with Exact Names] - | Exact name <- rdr - , name `elemNameSet` ns - = Just name - - | otherwise - = Nothing - -lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ - -elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) - = case rdr_name of - Unqual occ -> occ `elemOccEnv` env - Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] - Qual {} -> False - Orig {} -> False - -localRdrEnvElts :: LocalRdrEnv -> [Name] -localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env - -inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool --- This is the point of the NameSet -inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns - -delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv -delLocalRdrEnvList lre@(LRE { lre_env = env }) occs - = lre { lre_env = delListFromOccEnv env occs } - -{- -Note [Local bindings with Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Template Haskell we can make local bindings that have Exact Names. -Computing shadowing etc may use elemLocalRdrEnv (at least it certainly -does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult -the in-scope-name-set. - - -************************************************************************ -* * - GlobalRdrEnv -* * -************************************************************************ --} - --- | Global Reader Environment -type GlobalRdrEnv = OccEnv [GlobalRdrElt] --- ^ Keyed by 'OccName'; when looking up a qualified name --- we look up the 'OccName' part, and then check the 'Provenance' --- to see if the appropriate qualification is valid. This --- saves routinely doubling the size of the env by adding both --- qualified and unqualified names to the domain. --- --- The list in the codomain is required because there may be name clashes --- These only get reported on lookup, not on construction --- --- INVARIANT 1: All the members of the list have distinct --- 'gre_name' fields; that is, no duplicate Names --- --- INVARIANT 2: Imported provenance => Name is an ExternalName --- However LocalDefs can have an InternalName. This --- happens only when type-checking a [d| ... |] Template --- Haskell quotation; see this note in RnNames --- Note [Top-level Names in Template Haskell decl quotes] --- --- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then --- greOccName gre = occ --- --- NB: greOccName gre is usually the same as --- nameOccName (gre_name gre), but not always in the --- case of record seectors; see greOccName - --- | Global Reader Element --- --- An element of the 'GlobalRdrEnv' -data GlobalRdrElt - = GRE { gre_name :: Name - , gre_par :: Parent - , gre_lcl :: Bool -- ^ True <=> the thing was defined locally - , gre_imp :: [ImportSpec] -- ^ In scope through these imports - } deriving (Data, Eq) - -- INVARIANT: either gre_lcl = True or gre_imp is non-empty - -- See Note [GlobalRdrElt provenance] - --- | The children of a Name are the things that are abbreviated by the ".." --- notation in export lists. See Note [Parents] -data Parent = NoParent - | ParentIs { par_is :: Name } - | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } - -- ^ See Note [Parents for record fields] - deriving (Eq, Data) - -instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = text "parent:" <> ppr n - ppr (FldParent n f) = text "fldparent:" - <> ppr n <> colon <> ppr f - -plusParent :: Parent -> Parent -> Parent --- See Note [Combining parents] -plusParent p1@(ParentIs _) p2 = hasParent p1 p2 -plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 -plusParent p1 p2@(ParentIs _) = hasParent p2 p1 -plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 -plusParent _ _ = NoParent - -hasParent :: Parent -> Parent -> Parent -#if defined(DEBUG) -hasParent p NoParent = p -hasParent p p' - | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree -#endif -hasParent p _ = p - - -{- Note [GlobalRdrElt provenance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", -i.e. how the Name came to be in scope. It can be in scope two ways: - - gre_lcl = True: it is bound in this module - - gre_imp: a list of all the imports that brought it into scope - -It's an INVARIANT that you have one or the other; that is, either -gre_lcl is True, or gre_imp is non-empty. - -It is just possible to have *both* if there is a module loop: a Name -is defined locally in A, and also brought into scope by importing a -module that SOURCE-imported A. Exapmle (#7672): - - A.hs-boot module A where - data T - - B.hs module B(Decl.T) where - import {-# SOURCE #-} qualified A as Decl - - A.hs module A where - import qualified B - data T = Z | S B.T - -In A.hs, 'T' is locally bound, *and* imported as B.T. - -Note [Parents] -~~~~~~~~~~~~~~~~~ - Parent Children -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - data T Data constructors - Record-field ids - - data family T Data constructors and record-field ids - of all visible data instances of T - - class C Class operations - Associated type constructors - -~~~~~~~~~~~~~~~~~~~~~~~~~ - Constructor Meaning - ~~~~~~~~~~~~~~~~~~~~~~~~ - NoParent Can not be bundled with a type constructor. - ParentIs n Can be bundled with the type constructor corresponding to - n. - FldParent See Note [Parents for record fields] - - - - -Note [Parents for record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record fields, in addition to the Name of the type constructor -(stored in par_is), we use FldParent to store the field label. This -extra information is used for identifying overloaded record fields -during renaming. - -In a definition arising from a normal module (without --XDuplicateRecordFields), par_lbl will be Nothing, meaning that the -field's label is the same as the OccName of the selector's Name. The -GlobalRdrEnv will contain an entry like this: - - "x" |-> GRE x (FldParent T Nothing) LocalDef - -When -XDuplicateRecordFields is enabled for the module that contains -T, the selector's Name will be mangled (see comments in FieldLabel). -Thus we store the actual field label in par_lbl, and the GlobalRdrEnv -entry looks like this: - - "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef - -Note that the OccName used when adding a GRE to the environment -(greOccName) now depends on the parent field: for FldParent it is the -field label, if present, rather than the selector name. - -~~ - -Record pattern synonym selectors are treated differently. Their parent -information is `NoParent` in the module in which they are defined. This is because -a pattern synonym `P` has no parent constructor either. - -However, if `f` is bundled with a type constructor `T` then whenever `f` is -imported the parent will use the `Parent` constructor so the parent of `f` is -now `T`. - - -Note [Combining parents] -~~~~~~~~~~~~~~~~~~~~~~~~ -With an associated type we might have - module M where - class C a where - data T a - op :: T a -> a - instance C Int where - data T Int = TInt - instance C Bool where - data T Bool = TBool - -Then: C is the parent of T - T is the parent of TInt and TBool -So: in an export list - C(..) is short for C( op, T ) - T(..) is short for T( TInt, TBool ) - -Module M exports everything, so its exports will be - AvailTC C [C,T,op] - AvailTC T [T,TInt,TBool] -On import we convert to GlobalRdrElt and then combine -those. For T that will mean we have - one GRE with Parent C - one GRE with NoParent -That's why plusParent picks the "best" case. --} - --- | make a 'GlobalRdrEnv' where all the elements point to the same --- Provenance (useful for "hiding" imports, or imports with no details). -gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] --- prov = Nothing => locally bound --- Just spec => imported as described by spec -gresFromAvails prov avails - = concatMap (gresFromAvail (const prov)) avails - -localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] --- Turn an Avail into a list of LocalDef GlobalRdrElts -localGREsFromAvail = gresFromAvail (const Nothing) - -gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] -gresFromAvail prov_fn avail - = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) - where - mk_gre n - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = False, gre_imp = [is] } - - mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = n }) - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = False, gre_imp = [is] } - where - mb_lbl | is_overloaded = Just lbl - | otherwise = Nothing - - -greQualModName :: GlobalRdrElt -> ModuleName --- Get a suitable module qualifier for the GRE --- (used in mkPrintUnqualified) --- Prerecondition: the gre_name is always External -greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - | lcl, Just mod <- nameModule_maybe name = moduleName mod - | (is:_) <- iss = is_as (is_decl is) - | otherwise = pprPanic "greQualModName" (ppr gre) - -greRdrNames :: GlobalRdrElt -> [RdrName] -greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } - = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) - where - occ = greOccName gre - unqual = Unqual occ - do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ - --- the SrcSpan that pprNameProvenance prints out depends on whether --- the Name is defined locally or not: for a local definition the --- definition site is used, otherwise the location of the import --- declaration. We want to sort the export locations in --- exportClashErr by this SrcSpan, we need to extract it: -greSrcSpan :: GlobalRdrElt -> SrcSpan -greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) - | lcl = nameSrcSpan name - | (is:_) <- iss = is_dloc (is_decl is) - | otherwise = pprPanic "greSrcSpan" (ppr gre) - -mkParent :: Name -> AvailInfo -> Parent -mkParent _ (Avail _) = NoParent -mkParent n (AvailTC m _ _) | n == m = NoParent - | otherwise = ParentIs m - -greParent_maybe :: GlobalRdrElt -> Maybe Name -greParent_maybe gre = case gre_par gre of - NoParent -> Nothing - ParentIs n -> Just n - FldParent n _ -> Just n - --- | Takes a list of distinct GREs and folds them --- into AvailInfos. This is more efficient than mapping each individual --- GRE to an AvailInfo and the folding using `plusAvail` but needs the --- uniqueness assumption. -gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] -gresToAvailInfo gres - = nameEnvElts avail_env - where - avail_env :: NameEnv AvailInfo -- Keyed by the parent - (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres - - add :: (NameEnv AvailInfo, NameSet) - -> GlobalRdrElt - -> (NameEnv AvailInfo, NameSet) - add (env, done) gre - | name `elemNameSet` done - = (env, done) -- Don't insert twice into the AvailInfo - | otherwise - = ( extendNameEnv_Acc comb availFromGRE env key gre - , done `extendNameSet` name ) - where - name = gre_name gre - key = case greParent_maybe gre of - Just parent -> parent - Nothing -> gre_name gre - - -- We want to insert the child `k` into a list of children but - -- need to maintain the invariant that the parent is first. - -- - -- We also use the invariant that `k` is not already in `ns`. - insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] - insertChildIntoChildren _ [] k = [k] - insertChildIntoChildren p (n:ns) k - | p == k = k:n:ns - | otherwise = n:k:ns - - comb :: GlobalRdrElt -> AvailInfo -> AvailInfo - comb _ (Avail n) = Avail n -- Duplicated name, should not happen - comb gre (AvailTC m ns fls) - = case gre_par gre of - NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens - ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls - FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) - -availFromGRE :: GlobalRdrElt -> AvailInfo -availFromGRE (GRE { gre_name = me, gre_par = parent }) - = case parent of - ParentIs p -> AvailTC p [me] [] - NoParent | isTyConName me -> AvailTC me [me] [] - | otherwise -> avail me - FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] - -mkFieldLabel :: Name -> Maybe FastString -> FieldLabel -mkFieldLabel me mb_lbl = - case mb_lbl of - Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) - , flIsOverloaded = False - , flSelector = me } - Just lbl -> FieldLabel { flLabel = lbl - , flIsOverloaded = True - , flSelector = me } - -emptyGlobalRdrEnv :: GlobalRdrEnv -emptyGlobalRdrEnv = emptyOccEnv - -globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] -globalRdrEnvElts env = foldOccEnv (++) [] env - -instance Outputable GlobalRdrElt where - ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) - 2 (pprNameProvenance gre) - -pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc -pprGlobalRdrEnv locals_only env - = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) - <+> lbrace - , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] - <+> rbrace) ] - where - remove_locals gres | locals_only = filter isLocalGRE gres - | otherwise = gres - pp [] = empty - pp gres = hang (ppr occ - <+> parens (text "unique" <+> ppr (getUnique occ)) - <> colon) - 2 (vcat (map ppr gres)) - where - occ = nameOccName (gre_name (head gres)) - -lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres - -greOccName :: GlobalRdrElt -> OccName -greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl -greOccName gre = nameOccName (gre_name gre) - -lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] -lookupGRE_RdrName rdr_name env - = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres - -lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_Name env name - = lookupGRE_Name_OccName env name (nameOccName name) - -lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt --- ^ Look for a particular record field selector in the environment, where the --- selector name and field label may be different: the GlobalRdrEnv is keyed on --- the label. See Note [Parents for record fields] for why this happens. -lookupGRE_FieldLabel env fl - = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) - -lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' --- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and --- Note [Parents for record fields]. -lookupGRE_Name_OccName env name occ - = case [ gre | gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] of - [] -> Nothing - [gre] -> Just gre - gres -> pprPanic "lookupGRE_Name_OccName" - (ppr name $$ ppr occ $$ ppr gres) - -- See INVARIANT 1 on GlobalRdrEnv - - -getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] --- Returns all the qualifiers by which 'x' is in scope --- Nothing means "the unqualified version is in scope" --- [] means the thing is not in scope at all -getGRE_NameQualifier_maybes env name - = case lookupGRE_Name env name of - Just gre -> [qualifier_maybe gre] - Nothing -> [] - where - qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) - | lcl = Nothing - | otherwise = Just $ map (is_as . is_decl) iss - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_lcl = lcl }) = lcl - -isRecFldGRE :: GlobalRdrElt -> Bool -isRecFldGRE (GRE {gre_par = FldParent{}}) = True -isRecFldGRE _ = False - -isOverloadedRecFldGRE :: GlobalRdrElt -> Bool --- ^ Is this a record field defined with DuplicateRecordFields? --- (See Note [Parents for record fields]) -isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True -isOverloadedRecFldGRE _ = False - --- Returns the field label of this GRE, if it has one -greLabel :: GlobalRdrElt -> Maybe FieldLabelString -greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl -greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) -greLabel _ = Nothing - -unQualOK :: GlobalRdrElt -> Bool --- ^ Test if an unqualified version of this thing would be in scope -unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) - | lcl = True - | otherwise = any unQualSpecOK iss - -{- Note [GRE filtering] -~~~~~~~~~~~~~~~~~~~~~~~ -(pickGREs rdr gres) takes a list of GREs which have the same OccName -as 'rdr', say "x". It does two things: - -(a) filters the GREs to a subset that are in scope - * Qualified, as 'M.x' if want_qual is Qual M _ - * Unqualified, as 'x' if want_unqual is Unqual _ - -(b) for that subset, filter the provenance field (gre_lcl and gre_imp) - to ones that brought it into scope qualified or unqualified resp. - -Example: - module A ( f ) where - import qualified Foo( f ) - import Baz( f ) - f = undefined - -Let's suppose that Foo.f and Baz.f are the same entity really, but the local -'f' is different, so there will be two GREs matching "f": - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] - -The use of "f" in the export list is ambiguous because it's in scope -from the local def and the import Baz(f); but *not* the import qualified Foo. -pickGREs returns two GRE - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Bar ] - -Now the "ambiguous occurrence" message can correctly report how the -ambiguity arises. --} - -pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] --- ^ Takes a list of GREs which have the right OccName 'x' --- Pick those GREs that are in scope --- * Qualified, as 'M.x' if want_qual is Qual M _ --- * Unqualified, as 'x' if want_unqual is Unqual _ --- --- Return each such GRE, with its ImportSpecs filtered, to reflect --- how it is in scope qualified or unqualified respectively. --- See Note [GRE filtering] -pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres -pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres -pickGREs _ _ = [] -- I don't think this actually happens - -pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt -pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - | not lcl, null iss' = Nothing - | otherwise = Just (gre { gre_imp = iss' }) - where - iss' = filter unQualSpecOK iss - -pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt -pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) - | not lcl', null iss' = Nothing - | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) - where - iss' = filter (qualSpecOK mod) iss - lcl' = lcl && name_is_from mod n - - name_is_from :: ModuleName -> Name -> Bool - name_is_from mod name = case nameModule_maybe name of - Just n_mod -> moduleName n_mod == mod - Nothing -> False - -pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] --- ^ Pick GREs that are in scope *both* qualified *and* unqualified --- Return each GRE that is, as a pair --- (qual_gre, unqual_gre) --- These two GREs are the original GRE with imports filtered to express how --- it is in scope qualified an unqualified respectively --- --- Used only for the 'module M' item in export list; --- see RnNames.exports_from_avail -pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres - -pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) -pickBothGRE mod gre@(GRE { gre_name = n }) - | isBuiltInSyntax n = Nothing - | Just gre1 <- pickQualGRE mod gre - , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) - | otherwise = Nothing - where - -- isBuiltInSyntax filter out names for built-in syntax They - -- just clutter up the environment (esp tuples), and the - -- parser will generate Exact RdrNames for them, so the - -- cluttered envt is no use. Really, it's only useful for - -- GHC.Base and GHC.Tuple. - --- Building GlobalRdrEnvs - -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 - -mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv -mkGlobalRdrEnv gres - = foldr add emptyGlobalRdrEnv gres - where - add gre env = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) - gre - -insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] -insertGRE new_g [] = [new_g] -insertGRE new_g (old_g : old_gs) - | gre_name new_g == gre_name old_g - = new_g `plusGRE` old_g : old_gs - | otherwise - = old_g : insertGRE new_g old_gs - -plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt --- Used when the gre_name fields match -plusGRE g1 g2 - = GRE { gre_name = gre_name g1 - , gre_lcl = gre_lcl g1 || gre_lcl g2 - , gre_imp = gre_imp g1 ++ gre_imp g2 - , gre_par = gre_par g1 `plusParent` gre_par g2 } - -transformGREs :: (GlobalRdrElt -> GlobalRdrElt) - -> [OccName] - -> GlobalRdrEnv -> GlobalRdrEnv --- ^ Apply a transformation function to the GREs for these OccNames -transformGREs trans_gre occs rdr_env - = foldr trans rdr_env occs - where - trans occ env - = case lookupOccEnv env occ of - Just gres -> extendOccEnv env occ (map trans_gre gres) - Nothing -> env - -extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre - = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) gre - -shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv -shadowNames = foldl' shadowName - -{- Note [GlobalRdrEnv shadowing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before adding new names to the GlobalRdrEnv we nuke some existing entries; -this is "shadowing". The actual work is done by RdrEnv.shadowName. -Suppose - env' = shadowName env M.f - -Then: - * Looking up (Unqual f) in env' should succeed, returning M.f, - even if env contains existing unqualified bindings for f. - They are shadowed - - * Looking up (Qual M.f) in env' should succeed, returning M.f - - * Looking up (Qual X.f) in env', where X /= M, should be the same as - looking up (Qual X.f) in env. - That is, shadowName does /not/ delete earlier qualified bindings - -There are two reasons for shadowing: - -* The GHCi REPL - - - Ids bought into scope on the command line (eg let x = True) have - External Names, like Ghci4.x. We want a new binding for 'x' (say) - to override the existing binding for 'x'. Example: - - ghci> :load M -- Brings `x` and `M.x` into scope - ghci> x - ghci> "Hello" - ghci> M.x - ghci> "hello" - ghci> let x = True -- Shadows `x` - ghci> x -- The locally bound `x` - -- NOT an ambiguous reference - ghci> True - ghci> M.x -- M.x is still in scope! - ghci> "Hello" - So when we add `x = True` we must not delete the `M.x` from the - `GlobalRdrEnv`; rather we just want to make it "qualified only"; - hence the `mk_fake-imp_spec` in `shadowName`. See also Note - [Interactively-bound Ids in GHCi] in HscTypes - - - Data types also have External Names, like Ghci4.T; but we still want - 'T' to mean the newly-declared 'T', not an old one. - -* Nested Template Haskell declaration brackets - See Note [Top-level Names in Template Haskell decl quotes] in RnNames - - Consider a TH decl quote: - module M where - f x = h [d| f = ...f...M.f... |] - We must shadow the outer unqualified binding of 'f', else we'll get - a complaint when extending the GlobalRdrEnv, saying that there are - two bindings for 'f'. There are several tricky points: - - - This shadowing applies even if the binding for 'f' is in a - where-clause, and hence is in the *local* RdrEnv not the *global* - RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. - - - The External Name M.f from the enclosing module must certainly - still be available. So we don't nuke it entirely; we just make - it seem like qualified import. - - - We only shadow *External* names (which come from the main module), - or from earlier GHCi commands. Do not shadow *Internal* names - because in the bracket - [d| class C a where f :: a - f = 4 |] - rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the - class decl, and *separately* extend the envt with the value binding. - At that stage, the class op 'f' will have an Internal name. --} - -shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv --- Remove certain old GREs that share the same OccName as this new Name. --- See Note [GlobalRdrEnv shadowing] for details -shadowName env name - = alterOccEnv (fmap alter_fn) env (nameOccName name) - where - alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] - alter_fn gres = mapMaybe (shadow_with name) gres - - shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt - shadow_with new_name - old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) - = case nameModule_maybe old_name of - Nothing -> Just old_gre -- Old name is Internal; do not shadow - Just old_mod - | Just new_mod <- nameModule_maybe new_name - , new_mod == old_mod -- Old name same as new name; shadow completely - -> Nothing - - | null iss' -- Nothing remains - -> Nothing - - | otherwise - -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) - - where - iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss - lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] - | otherwise = [] - - mk_fake_imp_spec old_name old_mod -- Urgh! - = ImpSpec id_spec ImpAll - where - old_mod_name = moduleName old_mod - id_spec = ImpDeclSpec { is_mod = old_mod_name - , is_as = old_mod_name - , is_qual = True - , is_dloc = nameSrcSpan old_name } - - shadow_is :: Name -> ImportSpec -> Maybe ImportSpec - shadow_is new_name is@(ImpSpec { is_decl = id_spec }) - | Just new_mod <- nameModule_maybe new_name - , is_as id_spec == moduleName new_mod - = Nothing -- Shadow both qualified and unqualified - | otherwise -- Shadow unqualified only - = Just (is { is_decl = id_spec { is_qual = True } }) - - -{- -************************************************************************ -* * - ImportSpec -* * -************************************************************************ --} - --- | Import Specification --- --- The 'ImportSpec' of something says how it came to be imported --- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } - deriving( Eq, Ord, Data ) - --- | Import Declaration Specification --- --- Describes a particular import declaration and is --- shared among all the 'Provenance's for that decl -data ImpDeclSpec - = ImpDeclSpec { - is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ - -- Note the @Muggle@ may well not be - -- the defining module for this thing! - - -- TODO: either should be Module, or there - -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration - } deriving Data - --- | Import Item Specification --- --- Describes import info a particular Name -data ImpItemSpec - = ImpAll -- ^ The import had no import list, - -- or had a hiding list - - | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item - } -- ^ The import had an import list. - -- The 'is_explicit' field is @True@ iff the thing was named - -- /explicitly/ in the import specs rather - -- than being imported as part of a "..." group. Consider: - -- - -- > import C( T(..) ) - -- - -- Here the constructors of @T@ are not named explicitly; - -- only @T@ is named explicitly. - deriving Data - -instance Eq ImpDeclSpec where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord ImpDeclSpec where - compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` - (is_dloc is1 `compare` is_dloc is2) - -instance Eq ImpItemSpec where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord ImpItemSpec where - compare is1 is2 = - case (is1, is2) of - (ImpAll, ImpAll) -> EQ - (ImpAll, _) -> GT - (_, ImpAll) -> LT - (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2 - - -bestImport :: [ImportSpec] -> ImportSpec --- See Note [Choosing the best import declaration] -bestImport iss - = case sortBy best iss of - (is:_) -> is - [] -> pprPanic "bestImport" (ppr iss) - where - best :: ImportSpec -> ImportSpec -> Ordering - -- Less means better - -- Unqualified always wins over qualified; then - -- import-all wins over import-some; then - -- earlier declaration wins over later - best (ImpSpec { is_item = item1, is_decl = d1 }) - (ImpSpec { is_item = item2, is_decl = d2 }) - = (is_qual d1 `compare` is_qual d2) `thenCmp` - (best_item item1 item2) `thenCmp` - (is_dloc d1 `compare` is_dloc d2) - - best_item :: ImpItemSpec -> ImpItemSpec -> Ordering - best_item ImpAll ImpAll = EQ - best_item ImpAll (ImpSome {}) = LT - best_item (ImpSome {}) ImpAll = GT - best_item (ImpSome { is_explicit = e1 }) - (ImpSome { is_explicit = e2 }) = e1 `compare` e2 - -- False < True, so if e1 is explicit and e2 is not, we get GT - -{- Note [Choosing the best import declaration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reporting unused import declarations we use the following rules. - (see [wiki:commentary/compiler/unused-imports]) - -Say that an import-item is either - * an entire import-all decl (eg import Foo), or - * a particular item in an import list (eg import Foo( ..., x, ...)). -The general idea is that for each /occurrence/ of an imported name, we will -attribute that use to one import-item. Once we have processed all the -occurrences, any import items with no uses attributed to them are unused, -and are warned about. More precisely: - -1. For every RdrName in the program text, find its GlobalRdrElt. - -2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one - the "chosen import-item", and mark it "used". This is done - by 'bestImport' - -3. After processing all the RdrNames, bleat about any - import-items that are unused. - This is done in RnNames.warnUnusedImportDecls. - -The function 'bestImport' returns the dominant import among the -ImportSpecs it is given, implementing Step 2. We say import-item A -dominates import-item B if we choose A over B. In general, we try to -choose the import that is most likely to render other imports -unnecessary. Here is the dominance relationship we choose: - - a) import Foo dominates import qualified Foo. - - b) import Foo dominates import Foo(x). - - c) Otherwise choose the textually first one. - -Rationale for (a). Consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + x - -The unqualified 'x' can only come from import #2. The qualified 'M.x' -could come from either, but bestImport picks import #2, because it is -more likely to be useful in other imports, as indeed it is in this -case (see #5211 for a concrete example). - -But the rules are not perfect; consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + M.y - -The M.x will use import #2, but M.y can only use import #1. --} - - -unQualSpecOK :: ImportSpec -> Bool --- ^ Is in scope unqualified? -unQualSpecOK is = not (is_qual (is_decl is)) - -qualSpecOK :: ModuleName -> ImportSpec -> Bool --- ^ Is in scope qualified with the given module? -qualSpecOK mod is = mod == is_as (is_decl is) - -importSpecLoc :: ImportSpec -> SrcSpan -importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl -importSpecLoc (ImpSpec _ item) = is_iloc item - -importSpecModule :: ImportSpec -> ModuleName -importSpecModule is = is_mod (is_decl is) - -isExplicitItem :: ImpItemSpec -> Bool -isExplicitItem ImpAll = False -isExplicitItem (ImpSome {is_explicit = exp}) = exp - -pprNameProvenance :: GlobalRdrElt -> SDoc --- ^ Print out one place where the name was define/imported --- (With -dppr-debug, print them all) -pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - = ifPprDebug (vcat pp_provs) - (head pp_provs) - where - pp_provs = pp_lcl ++ map pp_is iss - pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] - else [] - pp_is is = sep [ppr is, ppr_defn_site is name] - --- If we know the exact definition point (which we may do with GHCi) --- then show that too. But not if it's just "imported from X". -ppr_defn_site :: ImportSpec -> Name -> SDoc -ppr_defn_site imp_spec name - | same_module && not (isGoodSrcSpan loc) - = empty -- Nothing interesting to say - | otherwise - = parens $ hang (text "and originally defined" <+> pp_mod) - 2 (pprLoc loc) - where - loc = nameSrcSpan name - defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - same_module = importSpecModule imp_spec == moduleName defining_mod - pp_mod | same_module = empty - | otherwise = text "in" <+> quotes (ppr defining_mod) - - -instance Outputable ImportSpec where - ppr imp_spec - = text "imported" <+> qual - <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) - <+> pprLoc (importSpecLoc imp_spec) - where - qual | is_qual (is_decl imp_spec) = text "qualified" - | otherwise = empty - -pprLoc :: SrcSpan -> SDoc -pprLoc (RealSrcSpan s) = text "at" <+> ppr s -pprLoc (UnhelpfulSpan {}) = empty - --- | Display info about the treatment of '*' under NoStarIsType. --- --- With StarIsType, three properties of '*' hold: --- --- (a) it is not an infix operator --- (b) it is always in scope --- (c) it is a synonym for Data.Kind.Type --- --- However, the user might not know that he's working on a module with --- NoStarIsType and write code that still assumes (a), (b), and (c), which --- actually do not hold in that module. --- --- Violation of (a) shows up in the parser. For instance, in the following --- examples, we have '*' not applied to enough arguments: --- --- data A :: * --- data F :: * -> * --- --- Violation of (b) or (c) show up in the renamer and the typechecker --- respectively. For instance: --- --- type K = Either * Bool --- --- This will parse differently depending on whether StarIsType is enabled, --- but it will parse nonetheless. With NoStarIsType it is parsed as a type --- operator, thus we have ((*) Either Bool). Now there are two cases to --- consider: --- --- 1. There is no definition of (*) in scope. In this case the renamer will --- fail to look it up. This is a violation of assumption (b). --- --- 2. There is a definition of the (*) type operator in scope (for example --- coming from GHC.TypeNats). In this case the user will get a kind --- mismatch error. This is a violation of assumption (c). --- --- The user might unknowingly be working on a module with NoStarIsType --- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a --- hint whenever an assumption about '*' is violated. Unfortunately, it is --- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). --- --- 'starInfo' generates an appropriate hint to the user depending on the --- extensions enabled in the module and the name that triggered the error. --- That is, if we have NoStarIsType and the error is related to '*' or its --- Unicode variant, the resulting SDoc will contain a helpful suggestion. --- Otherwise it is empty. --- -starInfo :: Bool -> RdrName -> SDoc -starInfo star_is_type rdr_name = - -- One might ask: if can use sdocWithDynFlags here, why bother to take - -- star_is_type as input? Why not refactor? - -- - -- The reason is that sdocWithDynFlags would provide DynFlags that are active - -- in the module that tries to load the problematic definition, not - -- in the module that is being loaded. - -- - -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint - -- must be displayed even if we load this definition from a module (or GHCi) - -- with StarIsType enabled! - -- - if isUnqualStar && not star_is_type - then text "With NoStarIsType, " <> - quotes (ppr rdr_name) <> - text " is treated as a regular type operator. " - $$ - text "Did you mean to use " <> quotes (text "Type") <> - text " from Data.Kind instead?" - else empty - where - -- Does rdr_name look like the user might have meant the '*' kind by it? - -- We focus on unqualified stars specifically, because qualified stars are - -- treated as type operators even under StarIsType. - isUnqualStar - | Unqual occName <- rdr_name - = let fs = occNameFS occName - in fs == fsLit "*" || fs == fsLit "★" - | otherwise = False diff --git a/basicTypes/SrcLoc.hs b/basicTypes/SrcLoc.hs deleted file mode 100644 --- a/basicTypes/SrcLoc.hs +++ /dev/null @@ -1,696 +0,0 @@ --- (c) The University of Glasgow, 1992-2006 - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} - - --- | This module contains types that relate to the positions of things --- in source files, and allow tagging of those things with locations -module SrcLoc ( - -- * SrcLoc - RealSrcLoc, -- Abstract - SrcLoc(..), - - -- ** Constructing SrcLoc - mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, - - noSrcLoc, -- "I'm sorry, I haven't a clue" - generatedSrcLoc, -- Code generated within the compiler - interactiveSrcLoc, -- Code from an interactive session - - advanceSrcLoc, - - -- ** Unsafely deconstructing SrcLoc - -- These are dubious exports, because they crash on some inputs - srcLocFile, -- return the file name part - srcLocLine, -- return the line part - srcLocCol, -- return the column part - - -- * SrcSpan - RealSrcSpan, -- Abstract - SrcSpan(..), - - -- ** Constructing SrcSpan - mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, - noSrcSpan, - wiredInSrcSpan, -- Something wired into the compiler - interactiveSrcSpan, - srcLocSpan, realSrcLocSpan, - combineSrcSpans, - srcSpanFirstCharacter, - - -- ** Deconstructing SrcSpan - srcSpanStart, srcSpanEnd, - realSrcSpanStart, realSrcSpanEnd, - srcSpanFileName_maybe, - pprUserRealSpan, - - -- ** Unsafely deconstructing SrcSpan - -- These are dubious exports, because they crash on some inputs - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Predicates on SrcSpan - isGoodSrcSpan, isOneLineSpan, - containsSpan, - - -- * Located - Located, - RealLocated, - GenLocated(..), - - -- ** Constructing Located - noLoc, - mkGeneralLocated, - - -- ** Deconstructing Located - getLoc, unLoc, - unRealSrcSpan, getRealSrcSpan, - - -- ** Modifying Located - mapLoc, - - -- ** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, sortLocated, - - -- ** HasSrcSpan - HasSrcSpan(..), SrcSpanLess, dL, cL, - pattern LL, onHasSrcSpan, liftL - ) where - -import GhcPrelude - -import Util -import Json -import Outputable -import FastString - -import Control.DeepSeq -import Data.Bits -import Data.Data -import Data.List (sortBy, intercalate) -import Data.Ord - -{- -************************************************************************ -* * -\subsection[SrcLoc-SrcLocations]{Source-location information} -* * -************************************************************************ - -We keep information about the {\em definition} point for each entity; -this is the obvious stuff: --} - --- | Real Source Location --- --- Represents a single point within a file -data RealSrcLoc - = SrcLoc FastString -- A precise location (file name) - {-# UNPACK #-} !Int -- line number, begins at 1 - {-# UNPACK #-} !Int -- column number, begins at 1 - deriving (Eq, Ord) - --- | Source Location -data SrcLoc - = RealSrcLoc {-# UNPACK #-}!RealSrcLoc - | UnhelpfulLoc FastString -- Just a general indication - deriving (Eq, Ord, Show) - -{- -************************************************************************ -* * -\subsection[SrcLoc-access-fns]{Access functions} -* * -************************************************************************ --} - -mkSrcLoc :: FastString -> Int -> Int -> SrcLoc -mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) - -mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc -mkRealSrcLoc x line col = SrcLoc x line col - --- | Built-in "bad" 'SrcLoc' values for particular locations -noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc -noSrcLoc = UnhelpfulLoc (fsLit "") -generatedSrcLoc = UnhelpfulLoc (fsLit "") -interactiveSrcLoc = UnhelpfulLoc (fsLit "") - --- | Creates a "bad" 'SrcLoc' that has no detailed information about its location -mkGeneralSrcLoc :: FastString -> SrcLoc -mkGeneralSrcLoc = UnhelpfulLoc - --- | Gives the filename of the 'RealSrcLoc' -srcLocFile :: RealSrcLoc -> FastString -srcLocFile (SrcLoc fname _ _) = fname - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocLine :: RealSrcLoc -> Int -srcLocLine (SrcLoc _ l _) = l - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocCol :: RealSrcLoc -> Int -srcLocCol (SrcLoc _ _ c) = c - --- | Move the 'SrcLoc' down by one line if the character is a newline, --- to the next 8-char tabstop if it is a tab, and across by one --- character in any other case -advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc -advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 -advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) - `shiftL` 3) + 1) -advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) - -{- -************************************************************************ -* * -\subsection[SrcLoc-instances]{Instance declarations for various names} -* * -************************************************************************ --} - -sortLocated :: HasSrcSpan a => [a] -> [a] -sortLocated things = sortBy (comparing getLoc) things - -instance Outputable RealSrcLoc where - ppr (SrcLoc src_path src_line src_col) - = hcat [ pprFastFilePath src_path <> colon - , int src_line <> colon - , int src_col ] - --- I don't know why there is this style-based difference --- if userStyle sty || debugStyle sty then --- hcat [ pprFastFilePath src_path, char ':', --- int src_line, --- char ':', int src_col --- ] --- else --- hcat [text "{-# LINE ", int src_line, space, --- char '\"', pprFastFilePath src_path, text " #-}"] - -instance Outputable SrcLoc where - ppr (RealSrcLoc l) = ppr l - ppr (UnhelpfulLoc s) = ftext s - -instance Data RealSrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "RealSrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "RealSrcSpan" - -instance Data SrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "SrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "SrcSpan" - -{- -************************************************************************ -* * -\subsection[SrcSpan]{Source Spans} -* * -************************************************************************ --} - -{- | -A 'RealSrcSpan' delimits a portion of a text file. It could be represented -by a pair of (line,column) coordinates, but in fact we optimise -slightly by using more compact representations for single-line and -zero-length spans, both of which are quite common. - -The end position is defined to be the column /after/ the end of the -span. That is, a span of (1,1)-(1,2) is one character long, and a -span of (1,1)-(1,1) is zero characters long. --} - --- | Real Source Span -data RealSrcSpan - = RealSrcSpan' - { srcSpanFile :: !FastString, - srcSpanSLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanELine :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } - deriving Eq - --- | Source Span --- --- A 'SrcSpan' identifies either a specific portion of a text file --- or a human-readable description of a location. -data SrcSpan = - RealSrcSpan !RealSrcSpan - | UnhelpfulSpan !FastString -- Just a general indication - -- also used to indicate an empty span - - deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we - -- derive Show for Token - -instance ToJson SrcSpan where - json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] - json (RealSrcSpan rss) = json rss - -instance ToJson RealSrcSpan where - json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) - , ("startLine", JSInt srcSpanSLine) - , ("startCol", JSInt srcSpanSCol) - , ("endLine", JSInt srcSpanELine) - , ("endCol", JSInt srcSpanECol) - ] - -instance NFData SrcSpan where - rnf x = x `seq` () - --- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan -noSrcSpan = UnhelpfulSpan (fsLit "") -wiredInSrcSpan = UnhelpfulSpan (fsLit "") -interactiveSrcSpan = UnhelpfulSpan (fsLit "") - --- | Create a "bad" 'SrcSpan' that has not location information -mkGeneralSrcSpan :: FastString -> SrcSpan -mkGeneralSrcSpan = UnhelpfulSpan - --- | Create a 'SrcSpan' corresponding to a single point -srcLocSpan :: SrcLoc -> SrcSpan -srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str -srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l) - -realSrcLocSpan :: RealSrcLoc -> RealSrcSpan -realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col - --- | Create a 'SrcSpan' between two points in a file -mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan -mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 - where - line1 = srcLocLine loc1 - line2 = srcLocLine loc2 - col1 = srcLocCol loc1 - col2 = srcLocCol loc2 - file = srcLocFile loc1 - --- | 'True' if the span is known to straddle only one line. -isOneLineRealSpan :: RealSrcSpan -> Bool -isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) - = line1 == line2 - --- | 'True' if the span is a single point -isPointRealSpan :: RealSrcSpan -> Bool -isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) - = line1 == line2 && col1 == col2 - --- | Create a 'SrcSpan' between two points in a file -mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan -mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str -mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str -mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) - = RealSrcSpan (mkRealSrcSpan loc1 loc2) - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Returns UnhelpfulSpan if the files differ. -combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful -combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) - | srcSpanFile span1 == srcSpanFile span2 - = RealSrcSpan (combineRealSrcSpans span1 span2) - | otherwise = UnhelpfulSpan (fsLit "") - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Assumes the "file" part is the same in both inputs -combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan -combineRealSrcSpans span1 span2 - = RealSrcSpan' file line_start col_start line_end col_end - where - (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) - (srcSpanStartLine span2, srcSpanStartCol span2) - (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) - (srcSpanEndLine span2, srcSpanEndCol span2) - file = srcSpanFile span1 - --- | Convert a SrcSpan into one that represents only its first character -srcSpanFirstCharacter :: SrcSpan -> SrcSpan -srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l -srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 - where - loc1@(SrcLoc f l c) = realSrcSpanStart span - loc2 = SrcLoc f l (c+1) - -{- -************************************************************************ -* * -\subsection[SrcSpan-predicates]{Predicates} -* * -************************************************************************ --} - --- | Test if a 'SrcSpan' is "good", i.e. has precise location information -isGoodSrcSpan :: SrcSpan -> Bool -isGoodSrcSpan (RealSrcSpan _) = True -isGoodSrcSpan (UnhelpfulSpan _) = False - -isOneLineSpan :: SrcSpan -> Bool --- ^ True if the span is known to straddle only one line. --- For "bad" 'SrcSpan', it returns False -isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s -isOneLineSpan (UnhelpfulSpan _) = False - --- | Tests whether the first span "contains" the other span, meaning --- that it covers at least as much source code. True where spans are equal. -containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool -containsSpan s1 s2 - = (srcSpanStartLine s1, srcSpanStartCol s1) - <= (srcSpanStartLine s2, srcSpanStartCol s2) - && (srcSpanEndLine s1, srcSpanEndCol s1) - >= (srcSpanEndLine s2, srcSpanEndCol s2) - && (srcSpanFile s1 == srcSpanFile s2) - -- We check file equality last because it is (presumably?) least - -- likely to fail. -{- -%************************************************************************ -%* * -\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} -* * -************************************************************************ --} - -srcSpanStartLine :: RealSrcSpan -> Int -srcSpanEndLine :: RealSrcSpan -> Int -srcSpanStartCol :: RealSrcSpan -> Int -srcSpanEndCol :: RealSrcSpan -> Int - -srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l -srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l -srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l -srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c - -{- -************************************************************************ -* * -\subsection[SrcSpan-access-fns]{Access functions} -* * -************************************************************************ --} - --- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanStart :: SrcSpan -> SrcLoc -srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) - --- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanEnd :: SrcSpan -> SrcLoc -srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) - -realSrcSpanStart :: RealSrcSpan -> RealSrcLoc -realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) - (srcSpanStartLine s) - (srcSpanStartCol s) - -realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc -realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) - (srcSpanEndLine s) - (srcSpanEndCol s) - --- | Obtains the filename for a 'SrcSpan' if it is "good" -srcSpanFileName_maybe :: SrcSpan -> Maybe FastString -srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s) -srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing - -{- -************************************************************************ -* * -\subsection[SrcSpan-instances]{Instances} -* * -************************************************************************ --} - --- We want to order RealSrcSpans first by the start point, then by the --- end point. -instance Ord RealSrcSpan where - a `compare` b = - (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` - (realSrcSpanEnd a `compare` realSrcSpanEnd b) - -instance Show RealSrcLoc where - show (SrcLoc filename row col) - = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col - --- Show is used by Lexer.x, because we derive Show for Token -instance Show RealSrcSpan where - show span@(RealSrcSpan' file sl sc el ec) - | isPointRealSpan span - = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) - - | isOneLineRealSpan span - = "SrcSpanOneLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,ec]) - - | otherwise - = "SrcSpanMultiLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,el,ec]) - - -instance Outputable RealSrcSpan where - ppr span = pprUserRealSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- text (showUserRealSpan True span) --- else --- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, --- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] - -instance Outputable SrcSpan where - ppr span = pprUserSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- pprUserSpan True span --- else --- case span of --- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" --- RealSrcSpan s -> ppr s - -pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan _ (UnhelpfulSpan s) = ftext s -pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s - -pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc -pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) - | isPointRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int col ] - -pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) - | isOneLineRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int scol - , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] - -- For single-character or point spans, we just - -- output the starting column number - -pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , parens (int sline <> comma <> int scol) - , char '-' - , parens (int eline <> comma <> int ecol') ] - where - ecol' = if ecol == 0 then ecol else ecol - 1 - -{- -************************************************************************ -* * -\subsection[Located]{Attaching SrcSpans to things} -* * -************************************************************************ --} - --- | We attach SrcSpans to lots of things, so let's have a datatype for it. -data GenLocated l e = L l e - deriving (Eq, Ord, Data, Functor, Foldable, Traversable) - -type Located = GenLocated SrcSpan -type RealLocated = GenLocated RealSrcSpan - -mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b -mapLoc = fmap - -unLoc :: HasSrcSpan a => a -> SrcSpanLess a -unLoc (dL->L _ e) = e - -getLoc :: HasSrcSpan a => a -> SrcSpan -getLoc (dL->L l _) = l - -noLoc :: HasSrcSpan a => SrcSpanLess a -> a -noLoc e = cL noSrcSpan e - -mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e -mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e - -combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan -combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) - --- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> SrcSpanLess c -> c -addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c - --- not clear whether to add a general Eq instance, but this is useful sometimes: - --- | Tests whether the two located things are equal -eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool -eqLocated a b = unLoc a == unLoc b - --- not clear whether to add a general Ord instance, but this is useful sometimes: - --- | Tests the ordering of the two located things -cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering -cmpLocated a b = unLoc a `compare` unLoc b - -instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where - ppr (L l e) = -- TODO: We can't do this since Located was refactored into - -- GenLocated: - -- Print spans without the file name etc - -- ifPprDebug (braces (pprUserSpan False l)) - whenPprDebug (braces (ppr l)) - $$ ppr e - -{- -************************************************************************ -* * -\subsection{Ordering SrcSpans for InteractiveUI} -* * -************************************************************************ --} - --- | Alternative strategies for ordering 'SrcSpan's -leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering -rightmost = flip compare -leftmost_smallest = compare -leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) - `thenCmp` - (srcSpanEnd b `compare` srcSpanEnd a) - --- | Determines whether a span encloses a given line and column index -spans :: SrcSpan -> (Int, Int) -> Bool -spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" -spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span - where loc = mkRealSrcLoc (srcSpanFile span) l c - --- | Determines whether a span is enclosed by another one -isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other - -> SrcSpan -- ^ The span it may be enclosed by - -> Bool -isSubspanOf src parent - | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False - | otherwise = srcSpanStart parent <= srcSpanStart src && - srcSpanEnd parent >= srcSpanEnd src - - -{- -************************************************************************ -* * -\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans} -* * -************************************************************************ --} - -{- -Note [HasSrcSpan Typeclass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To be able to uniformly set/get source location spans (of `SrcSpan`) in -syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`. -More details can be found at the following wiki page - ImplementingTreesThatGrow/HandlingSourceLocations - -For most syntactic entities, the source location spans are stored in -a syntactic entity by a wapper constuctor (introduced by TTG's -new constructor extension), e.g., by `NewPat (WrapperPat sp pat)` -for a source location span `sp` and a pattern `pat`. --} - --- | Determines the type of undecorated syntactic entities --- For most syntactic entities `E`, where source location spans are --- introduced by a wrapper construtor of the same syntactic entity, --- we have `SrcSpanLess E = E`. --- However, some syntactic entities have a different type compared to --- a syntactic entity `e :: E` may have the type `Located E` when --- decorated by wrapping it with `L sp e` for a source span `sp`. -type family SrcSpanLess a - --- | A typeclass to set/get SrcSpans -class HasSrcSpan a where - -- | Composes a `SrcSpan` decoration with an undecorated syntactic - -- entity to form its decorated variant - composeSrcSpan :: Located (SrcSpanLess a) -> a - - -- | Decomposes a decorated syntactic entity into its `SrcSpan` - -- decoration and its undecorated variant - decomposeSrcSpan :: a -> Located (SrcSpanLess a) - {- laws: - composeSrcSpan . decomposeSrcSpan = id - decomposeSrcSpan . composeSrcSpan = id - - in other words, `HasSrcSpan` defines an iso relation between - a `SrcSpan`-decorated syntactic entity and its undecorated variant - (together with the `SrcSpan`). - -} - -type instance SrcSpanLess (GenLocated l e) = e -instance HasSrcSpan (Located a) where - composeSrcSpan = id - decomposeSrcSpan = id - - --- | An abbreviated form of decomposeSrcSpan, --- mainly to be used in ViewPatterns -dL :: HasSrcSpan a => a -> Located (SrcSpanLess a) -dL = decomposeSrcSpan - --- | An abbreviated form of composeSrcSpan, --- mainly to replace the hardcoded `L` -cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -cL sp e = composeSrcSpan (L sp e) - --- | A Pattern Synonym to Set/Get SrcSpans -pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -pattern LL sp e <- (dL->L sp e) - where - LL sp e = cL sp e - --- | Lifts a function of undecorated entities to one of decorated ones -onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) => - (SrcSpanLess a -> SrcSpanLess b) -> a -> b -onHasSrcSpan f (dL->L l e) = cL l (f e) - -liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) => - (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b -liftL f (dL->L loc a) = do - a' <- f a - return $ cL loc a' - - -getRealSrcSpan :: RealLocated a -> RealSrcSpan -getRealSrcSpan (L l _) = l - -unRealSrcSpan :: RealLocated a -> a -unRealSrcSpan (L _ e) = e diff --git a/basicTypes/UniqSupply.hs b/basicTypes/UniqSupply.hs deleted file mode 100644 --- a/basicTypes/UniqSupply.hs +++ /dev/null @@ -1,224 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} - -#if !defined(GHC_LOADED_INTO_GHCI) -{-# LANGUAGE UnboxedTuples #-} -#endif - -module UniqSupply ( - -- * Main data type - UniqSupply, -- Abstractly - - -- ** Operations on supplies - uniqFromSupply, uniqsFromSupply, -- basic ops - takeUniqFromSupply, uniqFromMask, - - mkSplitUniqSupply, - splitUniqSupply, listSplitUniqSupply, - - -- * Unique supply monad and its abstraction - UniqSM, MonadUnique(..), - - -- ** Operations on the monad - initUs, initUs_, - - -- * Set supply strategy - initUniqSupply - ) where - -import GhcPrelude - -import Unique -import PlainPanic (panic) - -import GHC.IO - -import MonadUtils -import Control.Monad -import Data.Bits -import Data.Char -import Control.Monad.Fail as Fail - -#include "Unique.h" - -{- -************************************************************************ -* * -\subsection{Splittable Unique supply: @UniqSupply@} -* * -************************************************************************ --} - --- | Unique Supply --- --- A value of type 'UniqSupply' is unique, and it can --- supply /one/ distinct 'Unique'. Also, from the supply, one can --- also manufacture an arbitrary number of further 'UniqueSupply' values, --- which will be distinct from the first and from all others. -data UniqSupply - = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this - UniqSupply UniqSupply - -- when split => these two supplies - -mkSplitUniqSupply :: Char -> IO UniqSupply --- ^ Create a unique supply out of thin air. The character given must --- be distinct from those of all calls to this function in the compiler --- for the values generated to be truly unique. - -splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) --- ^ Build two 'UniqSupply' from a single one, each of which --- can supply its own 'Unique'. -listSplitUniqSupply :: UniqSupply -> [UniqSupply] --- ^ Create an infinite list of 'UniqSupply' from a single one -uniqFromSupply :: UniqSupply -> Unique --- ^ Obtain the 'Unique' from this particular 'UniqSupply' -uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite --- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply -takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) --- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply - -uniqFromMask :: Char -> IO Unique -uniqFromMask mask - = do { uqNum <- genSym - ; return $! mkUnique mask uqNum } - -mkSplitUniqSupply c - = case ord c `shiftL` uNIQUE_BITS of - !mask -> let - -- here comes THE MAGIC: - - -- This is one of the most hammered bits in the whole compiler - mk_supply - -- NB: Use unsafeInterleaveIO for thread-safety. - = unsafeInterleaveIO ( - genSym >>= \ u -> - mk_supply >>= \ s1 -> - mk_supply >>= \ s2 -> - return (MkSplitUniqSupply (mask .|. u) s1 s2) - ) - in - mk_supply - -foreign import ccall unsafe "genSym" genSym :: IO Int -foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO () - -splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) -listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 - -uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n -uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 -takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) - -{- -************************************************************************ -* * -\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} -* * -************************************************************************ --} - --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - -type UniqResult result = (# result, UniqSupply #) - -pattern UniqResult :: a -> b -> (# a, b #) -pattern UniqResult x y = (# x, y #) -{-# COMPLETE UniqResult #-} - -#else - -data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply - deriving (Functor) - -#endif - --- | A monad which just gives the ability to obtain 'Unique's -newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } - deriving (Functor) - -instance Monad UniqSM where - (>>=) = thenUs - (>>) = (*>) - -instance Applicative UniqSM where - pure = returnUs - (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of - UniqResult ff us1 -> case x us1 of - UniqResult xx us2 -> UniqResult (ff xx) us2 - (*>) = thenUs_ - --- TODO: try to get rid of this instance -instance Fail.MonadFail UniqSM where - fail = panic - --- | Run the 'UniqSM' action, returning the final 'UniqSupply' -initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) -initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } - --- | Run the 'UniqSM' action, discarding the final 'UniqSupply' -initUs_ :: UniqSupply -> UniqSM a -> a -initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } - -{-# INLINE thenUs #-} -{-# INLINE returnUs #-} -{-# INLINE splitUniqSupply #-} - --- @thenUs@ is where we split the @UniqSupply@. - -liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) -liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) - -instance MonadFix UniqSM where - mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) - -thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -thenUs (USM expr) cont - = USM (\us0 -> case (expr us0) of - UniqResult result us1 -> unUSM (cont result) us1) - -thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b -thenUs_ (USM expr) (USM cont) - = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) - -returnUs :: a -> UniqSM a -returnUs result = USM (\us -> UniqResult result us) - -getUs :: UniqSM UniqSupply -getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) - --- | A monad for generating unique identifiers -class Monad m => MonadUnique m where - -- | Get a new UniqueSupply - getUniqueSupplyM :: m UniqSupply - -- | Get a new unique identifier - getUniqueM :: m Unique - -- | Get an infinite list of new unique identifiers - getUniquesM :: m [Unique] - - -- This default definition of getUniqueM, while correct, is not as - -- efficient as it could be since it needlessly generates and throws away - -- an extra Unique. For your instances consider providing an explicit - -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. - getUniqueM = liftM uniqFromSupply getUniqueSupplyM - getUniquesM = liftM uniqsFromSupply getUniqueSupplyM - -instance MonadUnique UniqSM where - getUniqueSupplyM = getUs - getUniqueM = getUniqueUs - getUniquesM = getUniquesUs - -getUniqueUs :: UniqSM Unique -getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of - (u,us1) -> UniqResult u us1) - -getUniquesUs :: UniqSM [Unique] -getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of - (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) diff --git a/basicTypes/Unique.hs b/basicTypes/Unique.hs deleted file mode 100644 --- a/basicTypes/Unique.hs +++ /dev/null @@ -1,445 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -@Uniques@ are used to distinguish entities in the compiler (@Ids@, -@Classes@, etc.) from each other. Thus, @Uniques@ are the basic -comparison key in the compiler. - -If there is any single operation that needs to be fast, it is @Unique@ - -comparison. Unsurprisingly, there is quite a bit of huff-and-puff -directed to that end. - -Some of the other hair in this code is to be able to use a -``splittable @UniqueSupply@'' if requested/possible (not standard -Haskell). --} - -{-# LANGUAGE CPP, BangPatterns, MagicHash #-} - -module Unique ( - -- * Main data types - Unique, Uniquable(..), - uNIQUE_BITS, - - -- ** Constructors, destructors and operations on 'Unique's - hasKey, - - pprUniqueAlways, - - mkUniqueGrimily, -- Used in UniqSupply only! - getKey, -- Used in Var, UniqFM, Name only! - mkUnique, unpkUnique, -- Used in BinIface only - eqUnique, ltUnique, - - deriveUnique, -- Ditto - newTagUnique, -- Used in CgCase - initTyVarUnique, - initExitJoinUnique, - nonDetCmpUnique, - isValidKnownKeyUnique, -- Used in PrelInfo.knownKeyNamesOkay - - -- ** Making built-in uniques - - -- now all the built-in Uniques (and functions to make them) - -- [the Oh-So-Wonderful Haskell module system wins again...] - mkAlphaTyVarUnique, - mkPrimOpIdUnique, mkPrimOpWrapperUnique, - mkPreludeMiscIdUnique, mkPreludeDataConUnique, - mkPreludeTyConUnique, mkPreludeClassUnique, - mkCoVarUnique, - - mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, - mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, - mkCostCentreUnique, - - mkBuiltinUnique, - mkPseudoUniqueD, - mkPseudoUniqueE, - mkPseudoUniqueH, - - -- ** Deriving uniques - -- *** From TyCon name uniques - tyConRepNameUnique, - -- *** From DataCon name uniques - dataConWorkerUnique, dataConTyRepNameUnique - ) where - -#include "HsVersions.h" -#include "Unique.h" - -import GhcPrelude - -import BasicTypes -import FastString -import Outputable -import Util - --- just for implementing a fast [0,61) -> Char function -import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) - -import Data.Char ( chr, ord ) -import Data.Bits - -{- -************************************************************************ -* * -\subsection[Unique-type]{@Unique@ type and operations} -* * -************************************************************************ - -The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. -Fast comparison is everything on @Uniques@: --} - --- | Unique identifier. --- --- The type of unique identifiers that are used in many places in GHC --- for fast ordering and equality tests. You should generate these with --- the functions from the 'UniqSupply' module --- --- These are sometimes also referred to as \"keys\" in comments in GHC. -newtype Unique = MkUnique Int - -{-# INLINE uNIQUE_BITS #-} -uNIQUE_BITS :: Int -uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS - -{- -Now come the functions which construct uniques from their pieces, and vice versa. -The stuff about unique *supplies* is handled further down this module. --} - -unpkUnique :: Unique -> (Char, Int) -- The reverse - -mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply -getKey :: Unique -> Int -- for Var - -incrUnique :: Unique -> Unique -stepUnique :: Unique -> Int -> Unique -deriveUnique :: Unique -> Int -> Unique -newTagUnique :: Unique -> Char -> Unique - -mkUniqueGrimily = MkUnique - -{-# INLINE getKey #-} -getKey (MkUnique x) = x - -incrUnique (MkUnique i) = MkUnique (i + 1) -stepUnique (MkUnique i) n = MkUnique (i + n) - --- deriveUnique uses an 'X' tag so that it won't clash with --- any of the uniques produced any other way --- SPJ says: this looks terribly smelly to me! -deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta) - --- newTagUnique changes the "domain" of a unique to a different char -newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u - --- | How many bits are devoted to the unique index (as opposed to the class --- character). -uniqueMask :: Int -uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 - --- pop the Char in the top 8 bits of the Unique(Supply) - --- No 64-bit bugs here, as long as we have at least 32 bits. --JSM - --- and as long as the Char fits in 8 bits, which we assume anyway! - -mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces --- NOT EXPORTED, so that we can see all the Chars that --- are used in this one module -mkUnique c i - = MkUnique (tag .|. bits) - where - tag = ord c `shiftL` uNIQUE_BITS - bits = i .&. uniqueMask - -unpkUnique (MkUnique u) - = let - -- as long as the Char may have its eighth bit set, we - -- really do need the logical right-shift here! - tag = chr (u `shiftR` uNIQUE_BITS) - i = u .&. uniqueMask - in - (tag, i) - --- | The interface file symbol-table encoding assumes that known-key uniques fit --- in 30-bits; verify this. --- --- See Note [Symbol table representation of names] in BinIface for details. -isValidKnownKeyUnique :: Unique -> Bool -isValidKnownKeyUnique u = - case unpkUnique u of - (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) - -{- -************************************************************************ -* * -\subsection[Uniquable-class]{The @Uniquable@ class} -* * -************************************************************************ --} - --- | Class of things that we can obtain a 'Unique' from -class Uniquable a where - getUnique :: a -> Unique - -hasKey :: Uniquable a => a -> Unique -> Bool -x `hasKey` k = getUnique x == k - -instance Uniquable FastString where - getUnique fs = mkUniqueGrimily (uniqueOfFS fs) - -instance Uniquable Int where - getUnique i = mkUniqueGrimily i - -{- -************************************************************************ -* * -\subsection[Unique-instances]{Instance declarations for @Unique@} -* * -************************************************************************ - -And the whole point (besides uniqueness) is fast equality. We don't -use `deriving' because we want {\em precise} control of ordering -(equality on @Uniques@ is v common). --} - --- Note [Unique Determinism] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- The order of allocated @Uniques@ is not stable across rebuilds. --- The main reason for that is that typechecking interface files pulls --- @Uniques@ from @UniqSupply@ and the interface file for the module being --- currently compiled can, but doesn't have to exist. --- --- It gets more complicated if you take into account that the interface --- files are loaded lazily and that building multiple files at once has to --- work for any subset of interface files present. When you add parallelism --- this makes @Uniques@ hopelessly random. --- --- As such, to get deterministic builds, the order of the allocated --- @Uniques@ should not affect the final result. --- see also wiki/deterministic-builds --- --- Note [Unique Determinism and code generation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The goal of the deterministic builds (wiki/deterministic-builds, #4012) --- is to get ABI compatible binaries given the same inputs and environment. --- The motivation behind that is that if the ABI doesn't change the --- binaries can be safely reused. --- Note that this is weaker than bit-for-bit identical binaries and getting --- bit-for-bit identical binaries is not a goal for now. --- This means that we don't care about nondeterminism that happens after --- the interface files are created, in particular we don't care about --- register allocation and code generation. --- To track progress on bit-for-bit determinism see #12262. - -eqUnique :: Unique -> Unique -> Bool -eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 - -ltUnique :: Unique -> Unique -> Bool -ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 - --- Provided here to make it explicit at the call-site that it can --- introduce non-determinism. --- See Note [Unique Determinism] --- See Note [No Ord for Unique] -nonDetCmpUnique :: Unique -> Unique -> Ordering -nonDetCmpUnique (MkUnique u1) (MkUnique u2) - = if u1 == u2 then EQ else if u1 < u2 then LT else GT - -{- -Note [No Ord for Unique] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Unique Determinism] the relative order of Uniques -is nondeterministic. To prevent from accidental use the Ord Unique -instance has been removed. -This makes it easier to maintain deterministic builds, but comes with some -drawbacks. -The biggest drawback is that Maps keyed by Uniques can't directly be used. -The alternatives are: - - 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which - 2) Create a newtype wrapper based on Unique ordering where nondeterminism - is controlled. See Module.ModuleEnv - 3) Change the algorithm to use nonDetCmpUnique and document why it's still - deterministic - 4) Use TrieMap as done in CmmCommonBlockElim.groupByLabel --} - -instance Eq Unique where - a == b = eqUnique a b - a /= b = not (eqUnique a b) - -instance Uniquable Unique where - getUnique u = u - --- We do sometimes make strings with @Uniques@ in them: - -showUnique :: Unique -> String -showUnique uniq - = case unpkUnique uniq of - (tag, u) -> finish_show tag u (iToBase62 u) - -finish_show :: Char -> Int -> String -> String -finish_show 't' u _pp_u | u < 26 - = -- Special case to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - [chr (ord 'a' + u)] -finish_show tag _ pp_u = tag : pp_u - -pprUniqueAlways :: Unique -> SDoc --- The "always" means regardless of -dsuppress-uniques --- It replaces the old pprUnique to remind callers that --- they should consider whether they want to consult --- Opt_SuppressUniques -pprUniqueAlways u - = text (showUnique u) - -instance Outputable Unique where - ppr = pprUniqueAlways - -instance Show Unique where - show uniq = showUnique uniq - -{- -************************************************************************ -* * -\subsection[Utils-base62]{Base-62 numbers} -* * -************************************************************************ - -A character-stingy way to read/write numbers (notably Uniques). -The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. -Code stolen from Lennart. --} - -iToBase62 :: Int -> String -iToBase62 n_ - = ASSERT(n_ >= 0) go n_ "" - where - go n cs | n < 62 - = let !c = chooseChar62 n in c : cs - | otherwise - = go q (c : cs) where (!q, r) = quotRem n 62 - !c = chooseChar62 r - - chooseChar62 :: Int -> Char - {-# INLINE chooseChar62 #-} - chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) - chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# - -{- -************************************************************************ -* * -\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} -* * -************************************************************************ - -Allocation of unique supply characters: - v,t,u : for renumbering value-, type- and usage- vars. - B: builtin - C-E: pseudo uniques (used in native-code generator) - X: uniques derived by deriveUnique - _: unifiable tyvars (above) - 0-9: prelude things below - (no numbers left any more..) - :: (prelude) parallel array data constructors - - other a-z: lower case chars for unique supplies. Used so far: - - d desugarer - f AbsC flattener - g SimplStg - k constraint tuple tycons - m constraint tuple datacons - n Native codegen - r Hsc name cache - s simplifier - z anonymous sums --} - -mkAlphaTyVarUnique :: Int -> Unique -mkPreludeClassUnique :: Int -> Unique -mkPreludeTyConUnique :: Int -> Unique -mkPreludeDataConUnique :: Arity -> Unique -mkPrimOpIdUnique :: Int -> Unique --- See Note [Primop wrappers] in PrimOp.hs. -mkPrimOpWrapperUnique :: Int -> Unique -mkPreludeMiscIdUnique :: Int -> Unique -mkCoVarUnique :: Int -> Unique - -mkAlphaTyVarUnique i = mkUnique '1' i -mkCoVarUnique i = mkUnique 'g' i -mkPreludeClassUnique i = mkUnique '2' i - --------------------------------------------------- --- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon -mkPreludeTyConUnique i = mkUnique '3' (2*i) - -tyConRepNameUnique :: Unique -> Unique -tyConRepNameUnique u = incrUnique u - --- Data constructor keys occupy *two* slots. The first is used for the --- data constructor itself and its wrapper function (the function that --- evaluates arguments as necessary and calls the worker). The second is --- used for the worker function (the function that builds the constructor --- representation). - --------------------------------------------------- --- Wired-in data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon --- Prelude data constructors are too simple to need wrappers. - -mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic - --------------------------------------------------- -dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique -dataConWorkerUnique u = incrUnique u -dataConTyRepNameUnique u = stepUnique u 2 - --------------------------------------------------- -mkPrimOpIdUnique op = mkUnique '9' (2*op) -mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) -mkPreludeMiscIdUnique i = mkUnique '0' i - --- The "tyvar uniques" print specially nicely: a, b, c, etc. --- See pprUnique for details - -initTyVarUnique :: Unique -initTyVarUnique = mkUnique 't' 0 - -mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, - mkBuiltinUnique :: Int -> Unique - -mkBuiltinUnique i = mkUnique 'B' i -mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs -mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs -mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs - -mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique -mkRegSingleUnique = mkUnique 'R' -mkRegSubUnique = mkUnique 'S' -mkRegPairUnique = mkUnique 'P' -mkRegClassUnique = mkUnique 'L' - -mkCostCentreUnique :: Int -> Unique -mkCostCentreUnique = mkUnique 'C' - -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique --- See Note [The Unique of an OccName] in OccName -mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) -mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) -mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) -mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) - -initExitJoinUnique :: Unique -initExitJoinUnique = mkUnique 's' 0 diff --git a/basicTypes/Var.hs b/basicTypes/Var.hs deleted file mode 100644 --- a/basicTypes/Var.hs +++ /dev/null @@ -1,762 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{@Vars@: Variables} --} - -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally --- potentially contain type variables, which have a 'TyCoRep.Kind' --- rather than a 'TyCoRep.Type' and only contain some extra --- details during typechecking. --- --- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" --- --- #globalvslocal# --- Global 'Id's and 'Var's are those that are imported or correspond --- to a data constructor, primitive operation, or record selectors. --- Local 'Id's and 'Var's are those bound within an expression --- (e.g. by a lambda) or at the top level of the module being compiled. - -module Var ( - -- * The main data type and synonyms - Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, - TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, - - -- * In and Out variants - InVar, InCoVar, InId, InTyVar, - OutVar, OutCoVar, OutId, OutTyVar, - - -- ** Taking 'Var's apart - varName, varUnique, varType, - - -- ** Modifying 'Var's - setVarName, setVarUnique, setVarType, updateVarType, - updateVarTypeM, - - -- ** Constructing, taking apart, modifying 'Id's - mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, - idInfo, idDetails, - lazySetIdInfo, setIdDetails, globaliseId, - setIdExported, setIdNotExported, - - -- ** Predicates - isId, isTyVar, isTcTyVar, - isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, - isGlobalId, isExportedId, - mustHaveLocalBinding, - - -- * ArgFlags - ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, - AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, - - -- * TyVar's - VarBndr(..), TyCoVarBinder, TyVarBinder, - binderVar, binderVars, binderArgFlag, binderType, - mkTyCoVarBinder, mkTyCoVarBinders, - mkTyVarBinder, mkTyVarBinders, - isTyVarBinder, - - -- ** Constructing TyVar's - mkTyVar, mkTcTyVar, - - -- ** Taking 'TyVar's apart - tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, - - -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, - updateTyVarKindM, - - nonDetCmpVar - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep( Type, Kind ) -import {-# SOURCE #-} TyCoPpr( pprKind ) -import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, - vanillaIdInfo, pprIdDetails ) - -import Name hiding (varName) -import Unique ( Uniquable, Unique, getKey, getUnique - , mkUniqueGrimily, nonDetCmpUnique ) -import Util -import Binary -import DynFlags -import Outputable - -import Data.Data - -{- -************************************************************************ -* * - Synonyms -* * -************************************************************************ --- These synonyms are here and not in Id because otherwise we need a very --- large number of SOURCE imports of Id.hs :-( --} - --- | Identifier -type Id = Var -- A term-level identifier - -- predicate: isId - --- | Coercion Variable -type CoVar = Id -- See Note [Evidence: EvIds and CoVars] - -- predicate: isCoVar - --- | -type NcId = Id -- A term-level (value) variable that is - -- /not/ an (unlifted) coercion - -- predicate: isNonCoVarId - --- | Type or kind Variable -type TyVar = Var -- Type *or* kind variable (historical) - --- | Type or Kind Variable -type TKVar = Var -- Type *or* kind variable (historical) - --- | Type variable that might be a metavariable -type TcTyVar = Var - --- | Type Variable -type TypeVar = Var -- Definitely a type variable - --- | Kind Variable -type KindVar = Var -- Definitely a kind variable - -- See Note [Kind and type variables] - --- See Note [Evidence: EvIds and CoVars] --- | Evidence Identifier -type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar - --- | Evidence Variable -type EvVar = EvId -- ...historical name for EvId - --- | Dictionary Function Identifier -type DFunId = Id -- A dictionary function - --- | Dictionary Identifier -type DictId = EvId -- A dictionary variable - --- | Implicit parameter Identifier -type IpId = EvId -- A term-level implicit parameter - --- | Equality Variable -type EqVar = EvId -- Boxed equality evidence -type JoinId = Id -- A join variable - --- | Type or Coercion Variable -type TyCoVar = Id -- Type, *or* coercion variable - -- predicate: isTyCoVar - - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the substitution has been applied -} - -type InVar = Var -type InTyVar = TyVar -type InCoVar = CoVar -type InId = Id -type OutVar = Var -type OutTyVar = TyVar -type OutCoVar = CoVar -type OutId = Id - - - -{- Note [Evidence: EvIds and CoVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* An EvId (evidence Id) is a term-level evidence variable - (dictionary, implicit parameter, or equality). Could be boxed or unboxed. - -* DictId, IpId, and EqVar are synonyms when we know what kind of - evidence we are talking about. For example, an EqVar has type (t1 ~ t2). - -* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) - -Note [Kind and type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before kind polymorphism, TyVar were used to mean type variables. Now -they are used to mean kind *or* type variables. KindVar is used when we -know for sure that it is a kind variable. In future, we might want to -go over the whole compiler code to use: - - TKVar to mean kind or type variables - - TypeVar to mean type variables only - - KindVar to mean kind variables - - -************************************************************************ -* * -\subsection{The main data type declarations} -* * -************************************************************************ - - -Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a -@Type@, and an @IdInfo@ (non-essential info about it, e.g., -strictness). The essential info about different kinds of @Vars@ is -in its @VarDetails@. --} - --- | Variable --- --- Essentially a typed 'Name', that may also contain some additional information --- about the 'Var' and its use sites. -data Var - = TyVar { -- Type and kind variables - -- see Note [Kind and type variables] - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - -- ^ Key for fast comparison - -- Identical to the Unique in the name, - -- cached here for speed - varType :: Kind -- ^ The type or kind of the 'Var' in question - } - - | TcTyVar { -- Used only during type inference - -- Used for kind variables during - -- inference, as well - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Kind, - tc_tv_details :: TcTyVarDetails - } - - | Id { - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Type, - idScope :: IdScope, - id_details :: IdDetails, -- Stable, doesn't change - id_info :: IdInfo } -- Unstable, updated by simplifier - --- | Identifier Scope -data IdScope -- See Note [GlobalId/LocalId] - = GlobalId - | LocalId ExportFlag - -data ExportFlag -- See Note [ExportFlag on binders] - = NotExported -- ^ Not exported: may be discarded as dead code. - | Exported -- ^ Exported: kept alive - -{- Note [ExportFlag on binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An ExportFlag of "Exported" on a top-level binder says "keep this -binding alive; do not drop it as dead code". This transitively -keeps alive all the other top-level bindings that this binding refers -to. This property is persisted all the way down the pipeline, so that -the binding will be compiled all the way to object code, and its -symbols will appear in the linker symbol table. - -However, note that this use of "exported" is quite different to the -export list on a Haskell module. Setting the ExportFlag on an Id does -/not/ mean that if you import the module (in Haskell source code) you -will see this Id. Of course, things that appear in the export list -of the source Haskell module do indeed have their ExportFlag set. -But many other things, such as dictionary functions, are kept alive -by having their ExportFlag set, even though they are not exported -in the source-code sense. - -We should probably use a different term for ExportFlag, like -KeepAlive. - -Note [GlobalId/LocalId] -~~~~~~~~~~~~~~~~~~~~~~~ -A GlobalId is - * always a constant (top-level) - * imported, or data constructor, or primop, or record selector - * has a Unique that is globally unique across the whole - GHC invocation (a single invocation may compile multiple modules) - * never treated as a candidate by the free-variable finder; - it's a constant! - -A LocalId is - * bound within an expression (lambda, case, local let(rec)) - * or defined at top level in the module being compiled - * always treated as a candidate by the free-variable finder - -After CoreTidy, top-level LocalIds are turned into GlobalIds --} - -instance Outputable Var where - ppr var = sdocWithDynFlags $ \dflags -> - getPprStyle $ \ppr_style -> - if | debugStyle ppr_style && (not (gopt Opt_SuppressVarKinds dflags)) - -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> - dcolon <+> pprKind (tyVarKind var)) - | otherwise - -> ppr (varName var) <> ppr_debug var ppr_style - -ppr_debug :: Var -> PprStyle -> SDoc -ppr_debug (TyVar {}) sty - | debugStyle sty = brackets (text "tv") -ppr_debug (TcTyVar {tc_tv_details = d}) sty - | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) -ppr_debug (Id { idScope = s, id_details = d }) sty - | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) -ppr_debug _ _ = empty - -ppr_id_scope :: IdScope -> SDoc -ppr_id_scope GlobalId = text "gid" -ppr_id_scope (LocalId Exported) = text "lidx" -ppr_id_scope (LocalId NotExported) = text "lid" - -instance NamedThing Var where - getName = varName - -instance Uniquable Var where - getUnique = varUnique - -instance Eq Var where - a == b = realUnique a == realUnique b - -instance Ord Var where - a <= b = realUnique a <= realUnique b - a < b = realUnique a < realUnique b - a >= b = realUnique a >= realUnique b - a > b = realUnique a > realUnique b - a `compare` b = a `nonDetCmpVar` b - --- | Compare Vars by their Uniques. --- This is what Ord Var does, provided here to make it explicit at the --- call-site that it can introduce non-determinism. --- See Note [Unique Determinism] -nonDetCmpVar :: Var -> Var -> Ordering -nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b - -instance Data Var where - -- don't traverse? - toConstr _ = abstractConstr "Var" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Var" - -instance HasOccName Var where - occName = nameOccName . varName - -varUnique :: Var -> Unique -varUnique var = mkUniqueGrimily (realUnique var) - -setVarUnique :: Var -> Unique -> Var -setVarUnique var uniq - = var { realUnique = getKey uniq, - varName = setNameUnique (varName var) uniq } - -setVarName :: Var -> Name -> Var -setVarName var new_name - = var { realUnique = getKey (getUnique new_name), - varName = new_name } - -setVarType :: Id -> Type -> Id -setVarType id ty = id { varType = ty } - -updateVarType :: (Type -> Type) -> Id -> Id -updateVarType f id = id { varType = f (varType id) } - -updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id -updateVarTypeM f id = do { ty' <- f (varType id) - ; return (id { varType = ty' }) } - -{- ********************************************************************* -* * -* ArgFlag -* * -********************************************************************* -} - --- | Argument Flag --- --- Is something required to appear in source Haskell ('Required'), --- permitted by request ('Specified') (visible type application), or --- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep -data ArgFlag = Inferred | Specified | Required - deriving (Eq, Ord, Data) - -- (<) on ArgFlag means "is less visible than" - --- | Does this 'ArgFlag' classify an argument that is written in Haskell? -isVisibleArgFlag :: ArgFlag -> Bool -isVisibleArgFlag Required = True -isVisibleArgFlag _ = False - --- | Does this 'ArgFlag' classify an argument that is not written in Haskell? -isInvisibleArgFlag :: ArgFlag -> Bool -isInvisibleArgFlag = not . isVisibleArgFlag - --- | Do these denote the same level of visibility? 'Required' --- arguments are visible, others are not. So this function --- equates 'Specified' and 'Inferred'. Used for printing. -sameVis :: ArgFlag -> ArgFlag -> Bool -sameVis Required Required = True -sameVis Required _ = False -sameVis _ Required = False -sameVis _ _ = True - -instance Outputable ArgFlag where - ppr Required = text "[req]" - ppr Specified = text "[spec]" - ppr Inferred = text "[infrd]" - -instance Binary ArgFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Required - 1 -> return Specified - _ -> return Inferred - --- | The non-dependent version of 'ArgFlag'. - --- Appears here partly so that it's together with its friend ArgFlag, --- but also because it is used in IfaceType, rather early in the --- compilation chain --- See Note [AnonArgFlag vs. ForallVisFlag] -data AnonArgFlag - = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. - -- The argument is visible in source code. - | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. - -- The argument is invisible in source code. - deriving (Eq, Ord, Data) - -instance Outputable AnonArgFlag where - ppr VisArg = text "[vis]" - ppr InvisArg = text "[invis]" - -instance Binary AnonArgFlag where - put_ bh VisArg = putByte bh 0 - put_ bh InvisArg = putByte bh 1 - - get bh = do - h <- getByte bh - case h of - 0 -> return VisArg - _ -> return InvisArg - --- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible --- (e.g., @forall a b -> {...}@, with an arrow)? - --- See Note [AnonArgFlag vs. ForallVisFlag] -data ForallVisFlag - = ForallVis -- ^ A visible @forall@ (with an arrow) - | ForallInvis -- ^ An invisible @forall@ (with a dot) - deriving (Eq, Ord, Data) - -instance Outputable ForallVisFlag where - ppr f = text $ case f of - ForallVis -> "ForallVis" - ForallInvis -> "ForallInvis" - --- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'. -argToForallVisFlag :: ArgFlag -> ForallVisFlag -argToForallVisFlag Required = ForallVis -argToForallVisFlag Specified = ForallInvis -argToForallVisFlag Inferred = ForallInvis - -{- -Note [AnonArgFlag vs. ForallVisFlag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The AnonArgFlag and ForallVisFlag data types are quite similar at a first -glance: - - data AnonArgFlag = VisArg | InvisArg - data ForallVisFlag = ForallVis | ForallInvis - -Both data types keep track of visibility of some sort. AnonArgFlag tracks -whether a FunTy has a visible argument (->) or an invisible predicate argument -(=>). ForallVisFlag tracks whether a `forall` quantifier is visible -(forall a -> {...}) or invisible (forall a. {...}). - -Given their similarities, it's tempting to want to combine these two data types -into one, but they actually represent distinct concepts. AnonArgFlag reflects a -property of *Core* types, whereas ForallVisFlag reflects a property of the GHC -AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag -is all about surface syntax. Therefore, they are kept as separate data types. --} - -{- ********************************************************************* -* * -* VarBndr, TyCoVarBinder -* * -********************************************************************* -} - --- Variable Binder --- --- VarBndr is polymorphic in both var and visibility fields. --- Currently there are six different uses of 'VarBndr': --- * Var.TyVarBinder = VarBndr TyVar ArgFlag --- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag --- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis --- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis --- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag --- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -data VarBndr var argf = Bndr var argf - deriving( Data ) - --- | Variable Binder --- --- A 'TyCoVarBinder' is the binder of a ForAllTy --- It's convenient to define this synonym here rather its natural --- home in TyCoRep, because it's used in DataCon.hs-boot --- --- A 'TyVarBinder' is a binder with only TyVar -type TyCoVarBinder = VarBndr TyCoVar ArgFlag -type TyVarBinder = VarBndr TyVar ArgFlag - -binderVar :: VarBndr tv argf -> tv -binderVar (Bndr v _) = v - -binderVars :: [VarBndr tv argf] -> [tv] -binderVars tvbs = map binderVar tvbs - -binderArgFlag :: VarBndr tv argf -> argf -binderArgFlag (Bndr _ argf) = argf - -binderType :: VarBndr TyCoVar argf -> Type -binderType (Bndr tv _) = varType tv - --- | Make a named binder -mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder -mkTyCoVarBinder vis var = Bndr var vis - --- | Make a named binder --- 'var' should be a type variable -mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder -mkTyVarBinder vis var - = ASSERT( isTyVar var ) - Bndr var vis - --- | Make many named binders -mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] -mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) - --- | Make many named binders --- Input vars should be type variables -mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] -mkTyVarBinders vis = map (mkTyVarBinder vis) - -isTyVarBinder :: TyCoVarBinder -> Bool -isTyVarBinder (Bndr v _) = isTyVar v - -instance Outputable tv => Outputable (VarBndr tv ArgFlag) where - ppr (Bndr v Required) = ppr v - ppr (Bndr v Specified) = char '@' <> ppr v - ppr (Bndr v Inferred) = braces (ppr v) - -instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where - put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } - - get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } - -instance NamedThing tv => NamedThing (VarBndr tv flag) where - getName (Bndr tv _) = getName tv - -{- -************************************************************************ -* * -* Type and kind variables * -* * -************************************************************************ --} - -tyVarName :: TyVar -> Name -tyVarName = varName - -tyVarKind :: TyVar -> Kind -tyVarKind = varType - -setTyVarUnique :: TyVar -> Unique -> TyVar -setTyVarUnique = setVarUnique - -setTyVarName :: TyVar -> Name -> TyVar -setTyVarName = setVarName - -setTyVarKind :: TyVar -> Kind -> TyVar -setTyVarKind tv k = tv {varType = k} - -updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar -updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} - -updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar -updateTyVarKindM update tv - = do { k' <- update (tyVarKind tv) - ; return $ tv {varType = k'} } - -mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = TyVar { varName = name - , realUnique = getKey (nameUnique name) - , varType = kind - } - -mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar -mkTcTyVar name kind details - = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' - TcTyVar { varName = name, - realUnique = getKey (nameUnique name), - varType = kind, - tc_tv_details = details - } - -tcTyVarDetails :: TyVar -> TcTyVarDetails --- See Note [TcTyVars in the typechecker] in TcType -tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details -tcTyVarDetails (TyVar {}) = vanillaSkolemTv -tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) - -setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar -setTcTyVarDetails tv details = tv { tc_tv_details = details } - -{- -%************************************************************************ -%* * -\subsection{Ids} -* * -************************************************************************ --} - -idInfo :: HasDebugCallStack => Id -> IdInfo -idInfo (Id { id_info = info }) = info -idInfo other = pprPanic "idInfo" (ppr other) - -idDetails :: Id -> IdDetails -idDetails (Id { id_details = details }) = details -idDetails other = pprPanic "idDetails" (ppr other) - --- The next three have a 'Var' suffix even though they always build --- Ids, because Id.hs uses 'mkGlobalId' etc with different types -mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalVar details name ty info - = mk_id name ty GlobalId details info - -mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkLocalVar details name ty info - = mk_id name ty (LocalId NotExported) details info - -mkCoVar :: Name -> Type -> CoVar --- Coercion variables have no IdInfo -mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo - --- | Exported 'Var's will not be removed as dead code -mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkExportedLocalVar details name ty info - = mk_id name ty (LocalId Exported) details info - -mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id -mk_id name ty scope details info - = Id { varName = name, - realUnique = getKey (nameUnique name), - varType = ty, - idScope = scope, - id_details = details, - id_info = info } - -------------------- -lazySetIdInfo :: Id -> IdInfo -> Var -lazySetIdInfo id info = id { id_info = info } - -setIdDetails :: Id -> IdDetails -> Id -setIdDetails id details = id { id_details = details } - -globaliseId :: Id -> Id --- ^ If it's a local, make it global -globaliseId id = id { idScope = GlobalId } - -setIdExported :: Id -> Id --- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors --- and class operations, which are born as global 'Id's and automatically exported -setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } -setIdExported id@(Id { idScope = GlobalId }) = id -setIdExported tv = pprPanic "setIdExported" (ppr tv) - -setIdNotExported :: Id -> Id --- ^ We can only do this to LocalIds -setIdNotExported id = ASSERT( isLocalId id ) - id { idScope = LocalId NotExported } - -{- -************************************************************************ -* * -\subsection{Predicates over variables} -* * -************************************************************************ --} - --- | Is this a type-level (i.e., computationally irrelevant, thus erasable) --- variable? Satisfies @isTyVar = not . isId@. -isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar -isTyVar (TyVar {}) = True -isTyVar (TcTyVar {}) = True -isTyVar _ = False - -isTcTyVar :: Var -> Bool -- True of TcTyVar only -isTcTyVar (TcTyVar {}) = True -isTcTyVar _ = False - -isTyCoVar :: Var -> Bool -isTyCoVar v = isTyVar v || isCoVar v - --- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? --- Satisfies @isId = not . isTyVar@. -isId :: Var -> Bool -isId (Id {}) = True -isId _ = False - --- | Is this a coercion variable? --- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. -isCoVar :: Var -> Bool -isCoVar (Id { id_details = details }) = isCoVarDetails details -isCoVar _ = False - --- | Is this a term variable ('Id') that is /not/ a coercion variable? --- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. -isNonCoVarId :: Var -> Bool -isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) -isNonCoVarId _ = False - -isLocalId :: Var -> Bool -isLocalId (Id { idScope = LocalId _ }) = True -isLocalId _ = False - --- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's --- These are the variables that we need to pay attention to when finding free --- variables, or doing dependency analysis. -isLocalVar :: Var -> Bool -isLocalVar v = not (isGlobalId v) - -isGlobalId :: Var -> Bool -isGlobalId (Id { idScope = GlobalId }) = True -isGlobalId _ = False - --- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's --- that must have a binding in this module. The converse --- is not quite right: there are some global 'Id's that must have --- bindings, such as record selectors. But that doesn't matter, --- because it's only used for assertions -mustHaveLocalBinding :: Var -> Bool -mustHaveLocalBinding var = isLocalVar var - --- | 'isExportedIdVar' means \"don't throw this away\" -isExportedId :: Var -> Bool -isExportedId (Id { idScope = GlobalId }) = True -isExportedId (Id { idScope = LocalId Exported}) = True -isExportedId _ = False diff --git a/basicTypes/Var.hs-boot b/basicTypes/Var.hs-boot deleted file mode 100644 --- a/basicTypes/Var.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ --- Var.hs-boot is Imported (only) by TyCoRep.hs-boot -module Var where - -import GhcPrelude () - -- We compile this module with -XNoImplicitPrelude (for some - -- reason), so if there are no imports it does not seem to - -- depend on anything. But it does! We must, for example, - -- compile GHC.Types in the ghc-prim library first. - -- So this otherwise-unnecessary import tells the build system - -- that this module depends on GhcPrelude, which ensures - -- that GHC.Type is built first. - -data ArgFlag -data AnonArgFlag -data Var diff --git a/basicTypes/VarEnv.hs b/basicTypes/VarEnv.hs deleted file mode 100644 --- a/basicTypes/VarEnv.hs +++ /dev/null @@ -1,609 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module VarEnv ( - -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, - - -- ** Manipulating these environments - emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, - elemVarEnv, disjointVarEnv, - extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, - extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, - plusVarEnvList, alterVarEnv, - delVarEnvList, delVarEnv, delVarEnv_Directly, - minusVarEnv, intersectsVarEnv, - lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, - mapVarEnv, zipVarEnv, - modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, - elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv, filterVarEnv_Directly, restrictVarEnv, - partitionVarEnv, - - -- * Deterministic Var environments (maps) - DVarEnv, DIdEnv, DTyVarEnv, - - -- ** Manipulating these environments - emptyDVarEnv, mkDVarEnv, - dVarEnvElts, - extendDVarEnv, extendDVarEnv_C, - extendDVarEnvList, - lookupDVarEnv, elemDVarEnv, - isEmptyDVarEnv, foldDVarEnv, - mapDVarEnv, filterDVarEnv, - modifyDVarEnv, - alterDVarEnv, - plusDVarEnv, plusDVarEnv_C, - unitDVarEnv, - delDVarEnv, - delDVarEnvList, - minusDVarEnv, - partitionDVarEnv, - anyDVarEnv, - - -- * The InScopeSet type - InScopeSet, - - -- ** Operations on InScopeSets - emptyInScopeSet, mkInScopeSet, delInScopeSet, - extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - getInScopeVars, lookupInScope, lookupInScope_Directly, - unionInScope, elemInScopeSet, uniqAway, - varSetInScope, - - -- * The RnEnv2 type - RnEnv2, - - -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, - rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, - delBndrL, delBndrR, delBndrsL, delBndrsR, - addRnInScopeSet, - rnEtaL, rnEtaR, - rnInScope, rnInScopeSet, lookupRnInScope, - rnEnvL, rnEnvR, - - -- * TidyEnv and its operation - TidyEnv, - emptyTidyEnv, mkEmptyTidyEnv - ) where - -import GhcPrelude - -import OccName -import Var -import VarSet -import UniqSet -import UniqFM -import UniqDFM -import Unique -import Util -import Maybes -import Outputable - -{- -************************************************************************ -* * - In-scope sets -* * -************************************************************************ --} - --- | A set of variables that are in scope at some point --- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides --- the motivation for this abstraction. -data InScopeSet = InScope VarSet {-# UNPACK #-} !Int - -- Note [Lookups in in-scope set] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- We store a VarSet here, but we use this for lookups rather than just - -- membership tests. Typically the InScopeSet contains the canonical - -- version of the variable (e.g. with an informative unfolding), so this - -- lookup is useful (see, for instance, Note [In-scope set as a - -- substitution]). - -- - -- The Int is a kind of hash-value used by uniqAway - -- For example, it might be the size of the set - -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway - -instance Outputable InScopeSet where - ppr (InScope s _) = - text "InScope" <+> - braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) - -- It's OK to use nonDetEltsUniqSet here because it's - -- only for pretty printing - -- In-scope sets get big, and with -dppr-debug - -- the output is overwhelming - -emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet 1 - -getInScopeVars :: InScopeSet -> VarSet -getInScopeVars (InScope vs _) = vs - -mkInScopeSet :: VarSet -> InScopeSet -mkInScopeSet in_scope = InScope in_scope 1 - -extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope n) v - = InScope (extendVarSet in_scope v) (n + 1) - -extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet -extendInScopeSetList (InScope in_scope n) vs - = InScope (foldl' (\s v -> extendVarSet s v) in_scope vs) - (n + length vs) - -extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet -extendInScopeSetSet (InScope in_scope n) vs - = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs) - -delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n - -elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope - --- | Look up a variable the 'InScopeSet'. This lets you map from --- the variable's identity (unique) to its full value. -lookupInScope :: InScopeSet -> Var -> Maybe Var -lookupInScope (InScope in_scope _) v = lookupVarSet in_scope v - -lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var -lookupInScope_Directly (InScope in_scope _) uniq - = lookupVarSet_Directly in_scope uniq - -unionInScope :: InScopeSet -> InScopeSet -> InScopeSet -unionInScope (InScope s1 _) (InScope s2 n2) - = InScope (s1 `unionVarSet` s2) n2 - -varSetInScope :: VarSet -> InScopeSet -> Bool -varSetInScope vars (InScope s1 _) = vars `subVarSet` s1 - --- | @uniqAway in_scope v@ finds a unique that is not used in the --- in-scope set, and gives that to v. -uniqAway :: InScopeSet -> Var -> Var --- It starts with v's current unique, of course, in the hope that it won't --- have to change, and thereafter uses a combination of that and the hash-code --- found in the in-scope set -uniqAway in_scope var - | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one - | otherwise = var -- Nothing to do - -uniqAway' :: InScopeSet -> Var -> Var --- This one *always* makes up a new variable -uniqAway' (InScope set n) var - = try 1 - where - orig_unique = getUnique var - try k - | debugIsOn && (k > 1000) - = pprPanic "uniqAway loop:" msg - | uniq `elemVarSetByKey` set = try (k + 1) - | k > 3 - = pprTraceDebug "uniqAway:" msg - setVarUnique var uniq - | otherwise = setVarUnique var uniq - where - msg = ppr k <+> text "tries" <+> ppr var <+> int n - uniq = deriveUnique orig_unique (n * k) - -{- -************************************************************************ -* * - Dual renaming -* * -************************************************************************ --} - --- | Rename Environment 2 --- --- When we are comparing (or matching) types or terms, we are faced with --- \"going under\" corresponding binders. E.g. when comparing: --- --- > \x. e1 ~ \y. e2 --- --- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of --- things we must be careful of. In particular, @x@ might be free in @e2@, or --- y in @e1@. So the idea is that we come up with a fresh binder that is free --- in neither, and rename @x@ and @y@ respectively. That means we must maintain: --- --- 1. A renaming for the left-hand expression --- --- 2. A renaming for the right-hand expressions --- --- 3. An in-scope set --- --- Furthermore, when matching, we want to be able to have an 'occurs check', --- to prevent: --- --- > \x. f ~ \y. y --- --- matching with [@f@ -> @y@]. So for each expression we want to know that set of --- locally-bound variables. That is precisely the domain of the mappings 1. --- and 2., but we must ensure that we always extend the mappings as we go in. --- --- All of this information is bundled up in the 'RnEnv2' -data RnEnv2 - = RV2 { envL :: VarEnv Var -- Renaming for Left term - , envR :: VarEnv Var -- Renaming for Right term - , in_scope :: InScopeSet } -- In scope in left or right terms - --- The renamings envL and envR are *guaranteed* to contain a binding --- for every variable bound as we go into the term, even if it is not --- renamed. That way we can ask what variables are locally bound --- (inRnEnvL, inRnEnvR) - -mkRnEnv2 :: InScopeSet -> RnEnv2 -mkRnEnv2 vars = RV2 { envL = emptyVarEnv - , envR = emptyVarEnv - , in_scope = vars } - -addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 -addRnInScopeSet env vs - | isEmptyVarSet vs = env - | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } - -rnInScope :: Var -> RnEnv2 -> Bool -rnInScope x env = x `elemInScopeSet` in_scope env - -rnInScopeSet :: RnEnv2 -> InScopeSet -rnInScopeSet = in_scope - --- | Retrieve the left mapping -rnEnvL :: RnEnv2 -> VarEnv Var -rnEnvL = envL - --- | Retrieve the right mapping -rnEnvR :: RnEnv2 -> VarEnv Var -rnEnvR = envR - -rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 --- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length -rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR - -rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 --- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, --- and binder @bR@ in the Right term. --- It finds a new binder, @new_b@, --- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ -rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR - -rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but returns the new variable as well as the --- new environment -rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR - = (RV2 { envL = extendVarEnv envL bL new_b -- See Note - , envR = extendVarEnv envR bR new_b -- [Rebinding] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - -- Find a new binder not in scope in either term - new_b | not (bL `elemInScopeSet` in_scope) = bL - | not (bR `elemInScopeSet` in_scope) = bR - | otherwise = uniqAway' in_scope bL - - -- Note [Rebinding] - -- If the new var is the same as the old one, note that - -- the extendVarEnv *deletes* any current renaming - -- E.g. (\x. \x. ...) ~ (\y. \z. ...) - -- - -- Inside \x \y { [x->y], [y->y], {y} } - -- \x \z { [x->x], [y->y, z->x], {y,x} } - -rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the left --- side only. -rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = envR - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the right --- side only. -rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envR = extendVarEnv envR bR new_b - , envL = envL - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndrL' but used for eta expansion --- See Note [Eta expansion] -rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used for eta expansion --- See Note [Eta expansion] -rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] - , envR = extendVarEnv envR bR new_b - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 -delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } -delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } - -delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 -delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } -delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } - -rnOccL, rnOccR :: RnEnv2 -> Var -> Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v -rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v - -rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v -rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v - -inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool --- ^ Tells whether a variable is locally bound -inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env -inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env - -lookupRnInScope :: RnEnv2 -> Var -> Var -lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v - -nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 --- ^ Wipe the left or right side renaming -nukeRnEnvL env = env { envL = emptyVarEnv } -nukeRnEnvR env = env { envR = emptyVarEnv } - -rnSwap :: RnEnv2 -> RnEnv2 --- ^ swap the meaning of left and right -rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) - = RV2 { envL = envR, envR = envL, in_scope = in_scope } - -{- -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~ -When matching - (\x.M) ~ N -we rename x to x' with, where x' is not in scope in -either term. Then we want to behave as if we'd seen - (\x'.M) ~ (\x'.N x') -Since x' isn't in scope in N, the form (\x'. N x') doesn't -capture any variables in N. But we must nevertheless extend -the envR with a binding [x' -> x'], to support the occurs check. -For example, if we don't do this, we can get silly matches like - forall a. (\y.a) ~ v -succeeding with [a -> v y], which is bogus of course. - - -************************************************************************ -* * - Tidying -* * -************************************************************************ --} - --- | Tidy Environment --- --- When tidying up print names, we keep a mapping of in-scope occ-names --- (the 'TidyOccEnv') and a Var-to-Var of the current renamings -type TidyEnv = (TidyOccEnv, VarEnv Var) - -emptyTidyEnv :: TidyEnv -emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) - -mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv -mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) - -{- -************************************************************************ -* * -\subsection{@VarEnv@s} -* * -************************************************************************ --} - --- | Variable Environment -type VarEnv elt = UniqFM elt - --- | Identifier Environment -type IdEnv elt = VarEnv elt - --- | Type Variable Environment -type TyVarEnv elt = VarEnv elt - --- | Type or Coercion Variable Environment -type TyCoVarEnv elt = VarEnv elt - --- | Coercion Variable Environment -type CoVarEnv elt = VarEnv elt - -emptyVarEnv :: VarEnv a -mkVarEnv :: [(Var, a)] -> VarEnv a -mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a -zipVarEnv :: [Var] -> [a] -> VarEnv a -unitVarEnv :: Var -> a -> VarEnv a -alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a -extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b -extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a -plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a -plusVarEnvList :: [VarEnv a] -> VarEnv a -extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a - -lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a -filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a -delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a -partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) -restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a -delVarEnvList :: VarEnv a -> [Var] -> VarEnv a -delVarEnv :: VarEnv a -> Var -> VarEnv a -minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a -intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool -plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a -plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a -plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a -mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b -modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a - -isEmptyVarEnv :: VarEnv a -> Bool -lookupVarEnv :: VarEnv a -> Var -> Maybe a -filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a -lookupVarEnv_NF :: VarEnv a -> Var -> a -lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a -elemVarEnv :: Var -> VarEnv a -> Bool -elemVarEnvByKey :: Unique -> VarEnv a -> Bool -disjointVarEnv :: VarEnv a -> VarEnv a -> Bool - -elemVarEnv = elemUFM -elemVarEnvByKey = elemUFM_Directly -disjointVarEnv = disjointUFM -alterVarEnv = alterUFM -extendVarEnv = addToUFM -extendVarEnv_C = addToUFM_C -extendVarEnv_Acc = addToUFM_Acc -extendVarEnv_Directly = addToUFM_Directly -extendVarEnvList = addListToUFM -plusVarEnv_C = plusUFM_C -plusVarEnv_CD = plusUFM_CD -plusMaybeVarEnv_C = plusMaybeUFM_C -delVarEnvList = delListFromUFM -delVarEnv = delFromUFM -minusVarEnv = minusUFM -intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) -plusVarEnv = plusUFM -plusVarEnvList = plusUFMList -lookupVarEnv = lookupUFM -filterVarEnv = filterUFM -lookupWithDefaultVarEnv = lookupWithDefaultUFM -mapVarEnv = mapUFM -mkVarEnv = listToUFM -mkVarEnv_Directly= listToUFM_Directly -emptyVarEnv = emptyUFM -unitVarEnv = unitUFM -isEmptyVarEnv = isNullUFM -lookupVarEnv_Directly = lookupUFM_Directly -filterVarEnv_Directly = filterUFM_Directly -delVarEnv_Directly = delFromUFM_Directly -partitionVarEnv = partitionUFM - -restrictVarEnv env vs = filterVarEnv_Directly keep env - where - keep u _ = u `elemVarSetByKey` vs - -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) -lookupVarEnv_NF env id = case lookupVarEnv env id of - Just xx -> xx - Nothing -> panic "lookupVarEnv_NF: Nothing" - -{- -@modifyVarEnv@: Look up a thing in the VarEnv, -then mash it with the modify function, and put it back. --} - -modifyVarEnv mangle_fn env key - = case (lookupVarEnv env key) of - Nothing -> env - Just xx -> extendVarEnv env key (mangle_fn xx) - -modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a -modifyVarEnv_Directly mangle_fn env key - = case (lookupUFM_Directly env key) of - Nothing -> env - Just xx -> addToUFM_Directly env key (mangle_fn xx) - --- Deterministic VarEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarEnv. - --- | Deterministic Variable Environment -type DVarEnv elt = UniqDFM elt - --- | Deterministic Identifier Environment -type DIdEnv elt = DVarEnv elt - --- | Deterministic Type Variable Environment -type DTyVarEnv elt = DVarEnv elt - -emptyDVarEnv :: DVarEnv a -emptyDVarEnv = emptyUDFM - -dVarEnvElts :: DVarEnv a -> [a] -dVarEnvElts = eltsUDFM - -mkDVarEnv :: [(Var, a)] -> DVarEnv a -mkDVarEnv = listToUDFM - -extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv = addToUDFM - -minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a -minusDVarEnv = minusUDFM - -lookupDVarEnv :: DVarEnv a -> Var -> Maybe a -lookupDVarEnv = lookupUDFM - -foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b -foldDVarEnv = foldUDFM - -mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b -mapDVarEnv = mapUDFM - -filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a -filterDVarEnv = filterUDFM - -alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a -alterDVarEnv = alterUDFM - -plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv = plusUDFM - -plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv_C = plusUDFM_C - -unitDVarEnv :: Var -> a -> DVarEnv a -unitDVarEnv = unitUDFM - -delDVarEnv :: DVarEnv a -> Var -> DVarEnv a -delDVarEnv = delFromUDFM - -delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a -delDVarEnvList = delListFromUDFM - -isEmptyDVarEnv :: DVarEnv a -> Bool -isEmptyDVarEnv = isNullUDFM - -elemDVarEnv :: Var -> DVarEnv a -> Bool -elemDVarEnv = elemUDFM - -extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv_C = addToUDFM_C - -modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a -modifyDVarEnv mangle_fn env key - = case (lookupDVarEnv env key) of - Nothing -> env - Just xx -> extendDVarEnv env key (mangle_fn xx) - -partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) -partitionDVarEnv = partitionUDFM - -extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a -extendDVarEnvList = addListToUDFM - -anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool -anyDVarEnv = anyUDFM diff --git a/basicTypes/VarSet.hs b/basicTypes/VarSet.hs deleted file mode 100644 --- a/basicTypes/VarSet.hs +++ /dev/null @@ -1,350 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} - -module VarSet ( - -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, - - -- ** Manipulating these sets - emptyVarSet, unitVarSet, mkVarSet, - extendVarSet, extendVarSetList, - elemVarSet, subVarSet, - unionVarSet, unionVarSets, mapUnionVarSet, - intersectVarSet, intersectsVarSet, disjointVarSet, - isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, - minusVarSet, filterVarSet, mapVarSet, - anyVarSet, allVarSet, - transCloVarSet, fixVarSet, - lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, - sizeVarSet, seqVarSet, - elemVarSetByKey, partitionVarSet, - pluralVarSet, pprVarSet, - - -- * Deterministic Var set types - DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, - - -- ** Manipulating these sets - emptyDVarSet, unitDVarSet, mkDVarSet, - extendDVarSet, extendDVarSetList, - elemDVarSet, dVarSetElems, subDVarSet, - unionDVarSet, unionDVarSets, mapUnionDVarSet, - intersectDVarSet, dVarSetIntersectVarSet, - intersectsDVarSet, disjointDVarSet, - isEmptyDVarSet, delDVarSet, delDVarSetList, - minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet, - dVarSetMinusVarSet, anyDVarSet, allDVarSet, - transCloDVarSet, - sizeDVarSet, seqDVarSet, - partitionDVarSet, - dVarSetToVarSet, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Var ( Var, TyVar, CoVar, TyCoVar, Id ) -import Unique -import Name ( Name ) -import UniqSet -import UniqDSet -import UniqFM( disjointUFM, pluralUFM, pprUFM ) -import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) -import Outputable (SDoc) - --- | A non-deterministic Variable Set --- --- A non-deterministic set of variables. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not --- deterministic and why it matters. Use DVarSet if the set eventually --- gets converted into a list or folded over in a way where the order --- changes the generated code, for example when abstracting variables. -type VarSet = UniqSet Var - --- | Identifier Set -type IdSet = UniqSet Id - --- | Type Variable Set -type TyVarSet = UniqSet TyVar - --- | Coercion Variable Set -type CoVarSet = UniqSet CoVar - --- | Type or Coercion Variable Set -type TyCoVarSet = UniqSet TyCoVar - -emptyVarSet :: VarSet -intersectVarSet :: VarSet -> VarSet -> VarSet -unionVarSet :: VarSet -> VarSet -> VarSet -unionVarSets :: [VarSet] -> VarSet - -mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet --- ^ map the function over the list, and union the results - -unitVarSet :: Var -> VarSet -extendVarSet :: VarSet -> Var -> VarSet -extendVarSetList:: VarSet -> [Var] -> VarSet -elemVarSet :: Var -> VarSet -> Bool -delVarSet :: VarSet -> Var -> VarSet -delVarSetList :: VarSet -> [Var] -> VarSet -minusVarSet :: VarSet -> VarSet -> VarSet -isEmptyVarSet :: VarSet -> Bool -mkVarSet :: [Var] -> VarSet -lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var -lookupVarSet :: VarSet -> Var -> Maybe Var - -- Returns the set element, which may be - -- (==) to the argument, but not the same as -lookupVarSetByName :: VarSet -> Name -> Maybe Var -sizeVarSet :: VarSet -> Int -filterVarSet :: (Var -> Bool) -> VarSet -> VarSet - -delVarSetByKey :: VarSet -> Unique -> VarSet -elemVarSetByKey :: Unique -> VarSet -> Bool -partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) - -emptyVarSet = emptyUniqSet -unitVarSet = unitUniqSet -extendVarSet = addOneToUniqSet -extendVarSetList= addListToUniqSet -intersectVarSet = intersectUniqSets - -intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection -disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection -subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second - -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; - -- ditto disjointVarSet, subVarSet - -unionVarSet = unionUniqSets -unionVarSets = unionManyUniqSets -elemVarSet = elementOfUniqSet -minusVarSet = minusUniqSet -delVarSet = delOneFromUniqSet -delVarSetList = delListFromUniqSet -isEmptyVarSet = isEmptyUniqSet -mkVarSet = mkUniqSet -lookupVarSet_Directly = lookupUniqSet_Directly -lookupVarSet = lookupUniqSet -lookupVarSetByName = lookupUniqSet -sizeVarSet = sizeUniqSet -filterVarSet = filterUniqSet -delVarSetByKey = delOneFromUniqSet_Directly -elemVarSetByKey = elemUniqSet_Directly -partitionVarSet = partitionUniqSet - -mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs - --- See comments with type signatures -intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) -disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) -subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) - -anyVarSet :: (Var -> Bool) -> VarSet -> Bool -anyVarSet = uniqSetAny - -allVarSet :: (Var -> Bool) -> VarSet -> Bool -allVarSet = uniqSetAll - -mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b -mapVarSet = mapUniqSet - -fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set - -> VarSet -> VarSet --- (fixVarSet f s) repeatedly applies f to the set s, --- until it reaches a fixed point. -fixVarSet fn vars - | new_vars `subVarSet` vars = vars - | otherwise = fixVarSet fn new_vars - where - new_vars = fn vars - -transCloVarSet :: (VarSet -> VarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> VarSet -> VarSet --- (transCloVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 --- Use fixVarSet if the function needs to see the whole set all at once -transCloVarSet fn seeds - = go seeds seeds - where - go :: VarSet -- Accumulating result - -> VarSet -- Work-list; un-processed subset of accumulating result - -> VarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyVarSet new_vs = acc - | otherwise = go (acc `unionVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusVarSet` acc - -seqVarSet :: VarSet -> () -seqVarSet s = sizeVarSet s `seq` () - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralVarSet :: VarSet -> SDoc -pluralVarSet = pluralUFM . getUniqSet - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. --- Passing a list to the pretty-printing function allows the caller --- to decide on the order of Vars (eg. toposort them) without them having --- to use nonDetEltsUFM at the call site. This prevents from let-binding --- non-deterministically ordered lists and reusing them where determinism --- matters. -pprVarSet :: VarSet -- ^ The things to be pretty printed - -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the - -- elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprVarSet = pprUFM . getUniqSet - --- Deterministic VarSet --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarSet. - --- | Deterministic Variable Set -type DVarSet = UniqDSet Var - --- | Deterministic Identifier Set -type DIdSet = UniqDSet Id - --- | Deterministic Type Variable Set -type DTyVarSet = UniqDSet TyVar - --- | Deterministic Type or Coercion Variable Set -type DTyCoVarSet = UniqDSet TyCoVar - -emptyDVarSet :: DVarSet -emptyDVarSet = emptyUniqDSet - -unitDVarSet :: Var -> DVarSet -unitDVarSet = unitUniqDSet - -mkDVarSet :: [Var] -> DVarSet -mkDVarSet = mkUniqDSet - --- The new element always goes to the right of existing ones. -extendDVarSet :: DVarSet -> Var -> DVarSet -extendDVarSet = addOneToUniqDSet - -elemDVarSet :: Var -> DVarSet -> Bool -elemDVarSet = elementOfUniqDSet - -dVarSetElems :: DVarSet -> [Var] -dVarSetElems = uniqDSetToList - -subDVarSet :: DVarSet -> DVarSet -> Bool -subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) - -unionDVarSet :: DVarSet -> DVarSet -> DVarSet -unionDVarSet = unionUniqDSets - -unionDVarSets :: [DVarSet] -> DVarSet -unionDVarSets = unionManyUniqDSets - --- | Map the function over the list, and union the results -mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet -mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs - -intersectDVarSet :: DVarSet -> DVarSet -> DVarSet -intersectDVarSet = intersectUniqDSets - -dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet -dVarSetIntersectVarSet = uniqDSetIntersectUniqSet - --- | True if empty intersection -disjointDVarSet :: DVarSet -> DVarSet -> Bool -disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) - --- | True if non-empty intersection -intersectsDVarSet :: DVarSet -> DVarSet -> Bool -intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) - -isEmptyDVarSet :: DVarSet -> Bool -isEmptyDVarSet = isEmptyUniqDSet - -delDVarSet :: DVarSet -> Var -> DVarSet -delDVarSet = delOneFromUniqDSet - -minusDVarSet :: DVarSet -> DVarSet -> DVarSet -minusDVarSet = minusUniqDSet - -dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet -dVarSetMinusVarSet = uniqDSetMinusUniqSet - -foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a -foldDVarSet = foldUniqDSet - -anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool -anyDVarSet p = anyUDFM p . getUniqDSet - -allDVarSet :: (Var -> Bool) -> DVarSet -> Bool -allDVarSet p = allUDFM p . getUniqDSet - -mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b -mapDVarSet = mapUniqDSet - -filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet -filterDVarSet = filterUniqDSet - -sizeDVarSet :: DVarSet -> Int -sizeDVarSet = sizeUniqDSet - --- | Partition DVarSet according to the predicate given -partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) -partitionDVarSet = partitionUniqDSet - --- | Delete a list of variables from DVarSet -delDVarSetList :: DVarSet -> [Var] -> DVarSet -delDVarSetList = delListFromUniqDSet - -seqDVarSet :: DVarSet -> () -seqDVarSet s = sizeDVarSet s `seq` () - --- | Add a list of variables to DVarSet -extendDVarSetList :: DVarSet -> [Var] -> DVarSet -extendDVarSetList = addListToUniqDSet - --- | Convert a DVarSet to a VarSet by forgeting the order of insertion -dVarSetToVarSet :: DVarSet -> VarSet -dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet - --- | transCloVarSet for DVarSet -transCloDVarSet :: (DVarSet -> DVarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> DVarSet -> DVarSet --- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 -transCloDVarSet fn seeds - = go seeds seeds - where - go :: DVarSet -- Accumulating result - -> DVarSet -- Work-list; un-processed subset of accumulating result - -> DVarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyDVarSet new_vs = acc - | otherwise = go (acc `unionDVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusDVarSet` acc diff --git a/cbits/cutils.c b/cbits/cutils.c new file mode 100644 --- /dev/null +++ b/cbits/cutils.c @@ -0,0 +1,24 @@ +/* +These utility routines are used various +places in the GHC library. +*/ + +#include + +#include + +void +enableTimingStats( void ) /* called from the driver */ +{ + RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; +} + +void +setHeapSize( HsInt size ) +{ + RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; + if (RtsFlags.GcFlags.maxHeapSize != 0 && + RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { + RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; + } +} diff --git a/cbits/keepCAFsForGHCi.c b/cbits/keepCAFsForGHCi.c new file mode 100644 --- /dev/null +++ b/cbits/keepCAFsForGHCi.c @@ -0,0 +1,15 @@ +#include + +// This file is only included in the dynamic library. +// It contains an __attribute__((constructor)) function (run prior to main()) +// which sets the keepCAFs flag in the RTS, before any Haskell code is run. +// This is required so that GHCi can use dynamic libraries instead of HSxyz.o +// files. + +static void keepCAFsForGHCi(void) __attribute__((constructor)); + +static void keepCAFsForGHCi(void) +{ + keepCAFs = 1; +} + diff --git a/cmm/Bitmap.hs b/cmm/Bitmap.hs deleted file mode 100644 --- a/cmm/Bitmap.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- --- (c) The University of Glasgow 2003-2006 --- - --- Functions for constructing bitmaps, which are used in various --- places in generated code (stack frame liveness masks, function --- argument liveness masks, SRT bitmaps). - -module Bitmap ( - Bitmap, mkBitmap, - intsToBitmap, intsToReverseBitmap, - mAX_SMALL_BITMAP_SIZE, - seqBitmap, - ) where - -import GhcPrelude - -import SMRep -import DynFlags -import Util - -import Data.Bits - -{-| -A bitmap represented by a sequence of 'StgWord's on the /target/ -architecture. These are used for bitmaps in info tables and other -generated code which need to be emitted as sequences of StgWords. --} -type Bitmap = [StgWord] - --- | Make a bitmap from a sequence of bits -mkBitmap :: DynFlags -> [Bool] -> Bitmap -mkBitmap _ [] = [] -mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest - where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff - -chunkToBitmap :: DynFlags -> [Bool] -> StgWord -chunkToBitmap dflags chunk = - foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ] - where - oneAt :: Int -> StgWord - oneAt i = toStgWord dflags 1 `shiftL` i - --- | Make a bitmap where the slots specified are the /ones/ in the bitmap. --- eg. @[0,1,3], size 4 ==> 0xb@. --- --- The list of @Int@s /must/ be already sorted. -intsToBitmap :: DynFlags - -> Int -- ^ size in bits - -> [Int] -- ^ sorted indices of ones - -> Bitmap -intsToBitmap dflags size = go 0 - where - word_sz = wORD_SIZE_IN_BITS dflags - oneAt :: Int -> StgWord - oneAt i = toStgWord dflags 1 `shiftL` i - - -- It is important that we maintain strictness here. - -- See Note [Strictness when building Bitmaps]. - go :: Int -> [Int] -> Bitmap - go !pos slots - | size <= pos = [] - | otherwise = - (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) : - go (pos + word_sz) rest - where - (these,rest) = span (< (pos + word_sz)) slots - --- | Make a bitmap where the slots specified are the /zeros/ in the bitmap. --- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero, --- just to make the bitmap easier to read). --- --- The list of @Int@s /must/ be already sorted and duplicate-free. -intsToReverseBitmap :: DynFlags - -> Int -- ^ size in bits - -> [Int] -- ^ sorted indices of zeros free of duplicates - -> Bitmap -intsToReverseBitmap dflags size = go 0 - where - word_sz = wORD_SIZE_IN_BITS dflags - oneAt :: Int -> StgWord - oneAt i = toStgWord dflags 1 `shiftL` i - - -- It is important that we maintain strictness here. - -- See Note [Strictness when building Bitmaps]. - go :: Int -> [Int] -> Bitmap - go !pos slots - | size <= pos = [] - | otherwise = - (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) : - go (pos + word_sz) rest - where - (these,rest) = span (< (pos + word_sz)) slots - remain = size - pos - init - | remain >= word_sz = -1 - | otherwise = (1 `shiftL` remain) - 1 - -{- - -Note [Strictness when building Bitmaps] -======================================== - -One of the places where @Bitmap@ is used is in in building Static Reference -Tables (SRTs) (in @CmmBuildInfoTables.procpointSRT@). In #7450 it was noticed -that some test cases (particularly those whose C-- have large numbers of CAFs) -produced large quantities of allocations from this function. - -The source traced back to 'intsToBitmap', which was lazily subtracting the word -size from the elements of the tail of the @slots@ list and recursively invoking -itself with the result. This resulted in large numbers of subtraction thunks -being built up. Here we take care to avoid passing new thunks to the recursive -call. Instead we pass the unmodified tail along with an explicit position -accumulator, which get subtracted in the fold when we compute the Word. - --} - -{- | -Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h. -Some kinds of bitmap pack a size\/bitmap into a single word if -possible, or fall back to an external pointer when the bitmap is too -large. This value represents the largest size of bitmap that can be -packed into a single word. --} -mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int -mAX_SMALL_BITMAP_SIZE dflags - | wORD_SIZE dflags == 4 = 27 - | otherwise = 58 - -seqBitmap :: Bitmap -> a -> a -seqBitmap = seqList - diff --git a/cmm/BlockId.hs b/cmm/BlockId.hs deleted file mode 100644 --- a/cmm/BlockId.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- BlockId module should probably go away completely, being superseded by Label -} -module BlockId - ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet - , newBlockId - , blockLbl, infoTblLbl - ) where - -import GhcPrelude - -import CLabel -import IdInfo -import Name -import Unique -import UniqSupply - -import Hoopl.Label (Label, mkHooplLabel) - ----------------------------------------------------------------- ---- Block Ids, their environments, and their sets - -{- Note [Unique BlockId] -~~~~~~~~~~~~~~~~~~~~~~~~ -Although a 'BlockId' is a local label, for reasons of implementation, -'BlockId's must be unique within an entire compilation unit. The reason -is that each local label is mapped to an assembly-language label, and in -most assembly languages allow, a label is visible throughout the entire -compilation unit in which it appears. --} - -type BlockId = Label - -mkBlockId :: Unique -> BlockId -mkBlockId unique = mkHooplLabel $ getKey unique - -newBlockId :: MonadUnique m => m BlockId -newBlockId = mkBlockId <$> getUniqueM - -blockLbl :: BlockId -> CLabel -blockLbl label = mkLocalBlockLabel (getUnique label) - -infoTblLbl :: BlockId -> CLabel -infoTblLbl label - = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs diff --git a/cmm/BlockId.hs-boot b/cmm/BlockId.hs-boot deleted file mode 100644 --- a/cmm/BlockId.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module BlockId (BlockId, mkBlockId) where - -import Hoopl.Label (Label) -import Unique (Unique) - -type BlockId = Label - -mkBlockId :: Unique -> BlockId diff --git a/cmm/CLabel.hs b/cmm/CLabel.hs deleted file mode 100644 --- a/cmm/CLabel.hs +++ /dev/null @@ -1,1603 +0,0 @@ ------------------------------------------------------------------------------ --- --- Object-file symbols (called CLabel for histerical raisins). --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE CPP #-} - -module CLabel ( - CLabel, -- abstract type - NeedExternDecl (..), - ForeignLabelSource(..), - pprDebugCLabel, - - mkClosureLabel, - mkSRTLabel, - mkInfoTableLabel, - mkEntryLabel, - mkRednCountsLabel, - mkConInfoTableLabel, - mkApEntryLabel, - mkApInfoTableLabel, - mkClosureTableLabel, - mkBytesLabel, - - mkLocalBlockLabel, - mkLocalClosureLabel, - mkLocalInfoTableLabel, - mkLocalClosureTableLabel, - - mkBlockInfoTableLabel, - - mkBitmapLabel, - mkStringLitLabel, - - mkAsmTempLabel, - mkAsmTempDerivedLabel, - mkAsmTempEndLabel, - mkAsmTempDieLabel, - - mkDirty_MUT_VAR_Label, - mkNonmovingWriteBarrierEnabledLabel, - mkUpdInfoLabel, - mkBHUpdInfoLabel, - mkIndStaticInfoLabel, - mkMainCapabilityLabel, - mkMAP_FROZEN_CLEAN_infoLabel, - mkMAP_FROZEN_DIRTY_infoLabel, - mkMAP_DIRTY_infoLabel, - mkSMAP_FROZEN_CLEAN_infoLabel, - mkSMAP_FROZEN_DIRTY_infoLabel, - mkSMAP_DIRTY_infoLabel, - mkBadAlignmentLabel, - mkArrWords_infoLabel, - mkSRTInfoLabel, - - mkTopTickyCtrLabel, - mkCAFBlackHoleInfoTableLabel, - mkRtsPrimOpLabel, - mkRtsSlowFastTickyCtrLabel, - - mkSelectorInfoLabel, - mkSelectorEntryLabel, - - mkCmmInfoLabel, - mkCmmEntryLabel, - mkCmmRetInfoLabel, - mkCmmRetLabel, - mkCmmCodeLabel, - mkCmmDataLabel, - mkRtsCmmDataLabel, - mkCmmClosureLabel, - - mkRtsApFastLabel, - - mkPrimCallLabel, - - mkForeignLabel, - addLabelSize, - - foreignLabelStdcallInfo, - isBytesLabel, - isForeignLabel, - isSomeRODataLabel, - isStaticClosureLabel, - mkCCLabel, mkCCSLabel, - - DynamicLinkerLabelInfo(..), - mkDynamicLinkerLabel, - dynamicLinkerLabelInfo, - - mkPicBaseLabel, - mkDeadStripPreventer, - - mkHpcTicksLabel, - - -- * Predicates - hasCAF, - needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel, - isMathFun, - isCFunctionLabel, isGcPtrLabel, labelDynamic, - isLocalCLabel, mayRedirectTo, - - -- * Conversions - toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName, - - pprCLabel, - isInfoTableLabel, - isConInfoTableLabel - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import IdInfo -import BasicTypes -import {-# SOURCE #-} BlockId (BlockId, mkBlockId) -import Packages -import Module -import Name -import Unique -import PrimOp -import CostCentre -import Outputable -import FastString -import DynFlags -import GHC.Platform -import UniqSet -import Util -import PprCore ( {- instances -} ) - --- ----------------------------------------------------------------------------- --- The CLabel type - -{- | - 'CLabel' is an abstract type that supports the following operations: - - - Pretty printing - - - In a C file, does it need to be declared before use? (i.e. is it - guaranteed to be already in scope in the places we need to refer to it?) - - - If it needs to be declared, what type (code or data) should it be - declared to have? - - - Is it visible outside this object file or not? - - - Is it "dynamic" (see details below) - - - Eq and Ord, so that we can make sets of CLabels (currently only - used in outputting C as far as I can tell, to avoid generating - more than one declaration for any given label). - - - Converting an info table label into an entry label. - - CLabel usage is a bit messy in GHC as they are used in a number of different - contexts: - - - By the C-- AST to identify labels - - - By the unregisterised C code generator ("PprC") for naming functions (hence - the name 'CLabel') - - - By the native and LLVM code generators to identify labels - - For extra fun, each of these uses a slightly different subset of constructors - (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and - LLVM backends). - - In general, we use 'IdLabel' to represent Haskell things early in the - pipeline. However, later optimization passes will often represent blocks they - create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the - label. --} - -data CLabel - = -- | A label related to the definition of a particular Id or Con in a .hs file. - IdLabel - Name - CafInfo - IdLabelInfo -- ^ encodes the suffix of the label - - -- | A label from a .cmm file that is not associated with a .hs level Id. - | CmmLabel - UnitId -- ^ what package the label belongs to. - NeedExternDecl -- ^ does the label need an "extern .." declaration - FastString -- ^ identifier giving the prefix of the label - CmmLabelInfo -- ^ encodes the suffix of the label - - -- | A label with a baked-in \/ algorithmically generated name that definitely - -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so - -- If it doesn't have an algorithmically generated name then use a CmmLabel - -- instead and give it an appropriate UnitId argument. - | RtsLabel - RtsLabelInfo - - -- | A label associated with a block. These aren't visible outside of the - -- compilation unit in which they are defined. These are generally used to - -- name blocks produced by Cmm-to-Cmm passes and the native code generator, - -- where we don't have a 'Name' to associate the label to and therefore can't - -- use 'IdLabel'. - | LocalBlockLabel - {-# UNPACK #-} !Unique - - -- | A 'C' (or otherwise foreign) label. - -- - | ForeignLabel - FastString -- ^ name of the imported label. - - (Maybe Int) -- ^ possible '@n' suffix for stdcall functions - -- When generating C, the '@n' suffix is omitted, but when - -- generating assembler we must add it to the label. - - ForeignLabelSource -- ^ what package the foreign label is in. - - FunctionOrData - - -- | Local temporary label used for native (or LLVM) code generation; must not - -- appear outside of these contexts. Use primarily for debug information - | AsmTempLabel - {-# UNPACK #-} !Unique - - -- | A label \"derived\" from another 'CLabel' by the addition of a suffix. - -- Must not occur outside of the NCG or LLVM code generators. - | AsmTempDerivedLabel - CLabel - FastString -- ^ suffix - - | StringLitLabel - {-# UNPACK #-} !Unique - - | CC_Label CostCentre - | CCS_Label CostCentreStack - - - -- | These labels are generated and used inside the NCG only. - -- They are special variants of a label used for dynamic linking - -- see module PositionIndependentCode for details. - | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel - - -- | This label is generated and used inside the NCG only. - -- It is used as a base for PIC calculations on some platforms. - -- It takes the form of a local numeric assembler label '1'; and - -- is pretty-printed as 1b, referring to the previous definition - -- of 1: in the assembler source file. - | PicBaseLabel - - -- | A label before an info table to prevent excessive dead-stripping on darwin - | DeadStripPreventer CLabel - - - -- | Per-module table of tick locations - | HpcTicksLabel Module - - -- | Static reference table - | SRTLabel - {-# UNPACK #-} !Unique - - -- | A bitmap (function or case return) - | LargeBitmapLabel - {-# UNPACK #-} !Unique - - deriving Eq - --- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the --- label (e.g. "extern StgWordArray(foo)"). The type is fixed to StgWordArray. --- --- Symbols from the RTS don't need "extern" declarations because they are --- exposed via "includes/Stg.h" with the appropriate type. See 'needsCDecl'. --- --- The fixed StgWordArray type led to "conflicting types" issues with user --- provided Cmm files (not in the RTS) that declare data of another type (#15467 --- and test for #17920). Hence the Cmm parser considers that labels in data --- sections don't need the "extern" declaration (just add one explicitly if you --- need it). --- --- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes --- for why extern declaration are needed at all. -newtype NeedExternDecl - = NeedExternDecl Bool - deriving (Ord,Eq) - --- This is laborious, but necessary. We can't derive Ord because --- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the --- implementation. See Note [No Ord for Unique] --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] -instance Ord CLabel where - compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 - compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 `thenCmp` - compare d1 d2 - compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 - compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2 - compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 `thenCmp` - compare d1 d2 - compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 - compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = - compare a1 a2 `thenCmp` - compare b1 b2 - compare (StringLitLabel u1) (StringLitLabel u2) = - nonDetCmpUnique u1 u2 - compare (CC_Label a1) (CC_Label a2) = - compare a1 a2 - compare (CCS_Label a1) (CCS_Label a2) = - compare a1 a2 - compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) = - compare a1 a2 `thenCmp` - compare b1 b2 - compare PicBaseLabel PicBaseLabel = EQ - compare (DeadStripPreventer a1) (DeadStripPreventer a2) = - compare a1 a2 - compare (HpcTicksLabel a1) (HpcTicksLabel a2) = - compare a1 a2 - compare (SRTLabel u1) (SRTLabel u2) = - nonDetCmpUnique u1 u2 - compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) = - nonDetCmpUnique u1 u2 - compare IdLabel{} _ = LT - compare _ IdLabel{} = GT - compare CmmLabel{} _ = LT - compare _ CmmLabel{} = GT - compare RtsLabel{} _ = LT - compare _ RtsLabel{} = GT - compare LocalBlockLabel{} _ = LT - compare _ LocalBlockLabel{} = GT - compare ForeignLabel{} _ = LT - compare _ ForeignLabel{} = GT - compare AsmTempLabel{} _ = LT - compare _ AsmTempLabel{} = GT - compare AsmTempDerivedLabel{} _ = LT - compare _ AsmTempDerivedLabel{} = GT - compare StringLitLabel{} _ = LT - compare _ StringLitLabel{} = GT - compare CC_Label{} _ = LT - compare _ CC_Label{} = GT - compare CCS_Label{} _ = LT - compare _ CCS_Label{} = GT - compare DynamicLinkerLabel{} _ = LT - compare _ DynamicLinkerLabel{} = GT - compare PicBaseLabel{} _ = LT - compare _ PicBaseLabel{} = GT - compare DeadStripPreventer{} _ = LT - compare _ DeadStripPreventer{} = GT - compare HpcTicksLabel{} _ = LT - compare _ HpcTicksLabel{} = GT - compare SRTLabel{} _ = LT - compare _ SRTLabel{} = GT - --- | Record where a foreign label is stored. -data ForeignLabelSource - - -- | Label is in a named package - = ForeignLabelInPackage UnitId - - -- | Label is in some external, system package that doesn't also - -- contain compiled Haskell code, and is not associated with any .hi files. - -- We don't have to worry about Haskell code being inlined from - -- external packages. It is safe to treat the RTS package as "external". - | ForeignLabelInExternalPackage - - -- | Label is in the package currenly being compiled. - -- This is only used for creating hacky tmp labels during code generation. - -- Don't use it in any code that might be inlined across a package boundary - -- (ie, core code) else the information will be wrong relative to the - -- destination module. - | ForeignLabelInThisPackage - - deriving (Eq, Ord) - - --- | For debugging problems with the CLabel representation. --- We can't make a Show instance for CLabel because lots of its components don't have instances. --- The regular Outputable instance only shows the label name, and not its other info. --- -pprDebugCLabel :: CLabel -> SDoc -pprDebugCLabel lbl - = case lbl of - IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel" - <> whenPprDebug (text ":" <> text (show info))) - CmmLabel pkg _ext _name _info - -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) - - RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") - - ForeignLabel _name mSuffix src funOrData - -> ppr lbl <> (parens $ text "ForeignLabel" - <+> ppr mSuffix - <+> ppr src - <+> ppr funOrData) - - _ -> ppr lbl <> (parens $ text "other CLabel") - - -data IdLabelInfo - = Closure -- ^ Label for closure - | InfoTable -- ^ Info tables for closures; always read-only - | Entry -- ^ Entry point - | Slow -- ^ Slow entry point - - | LocalInfoTable -- ^ Like InfoTable but not externally visible - | LocalEntry -- ^ Like Entry but not externally visible - - | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id - - | ConEntry -- ^ Constructor entry point - | ConInfoTable -- ^ Corresponding info table - - | ClosureTable -- ^ Table of closures for Enum tycons - - | Bytes -- ^ Content of a string literal. See - -- Note [Bytes label]. - | BlockInfoTable -- ^ Like LocalInfoTable but for a proc-point block - -- instead of a closure entry-point. - -- See Note [Proc-point local block entry-point]. - - deriving (Eq, Ord, Show) - - -data RtsLabelInfo - = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks - | RtsSelectorEntry Bool{-updatable-} Int{-offset-} - - | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks - | RtsApEntry Bool{-updatable-} Int{-arity-} - - | RtsPrimOp PrimOp - | RtsApFast FastString -- ^ _fast versions of generic apply - | RtsSlowFastTickyCtr String - - deriving (Eq, Ord) - -- NOTE: Eq on PtrString compares the pointer only, so this isn't - -- a real equality. - - --- | What type of Cmm label we're dealing with. --- Determines the suffix appended to the name when a CLabel.CmmLabel --- is pretty printed. -data CmmLabelInfo - = CmmInfo -- ^ misc rts info tables, suffix _info - | CmmEntry -- ^ misc rts entry points, suffix _entry - | CmmRetInfo -- ^ misc rts ret info tables, suffix _info - | CmmRet -- ^ misc rts return points, suffix _ret - | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure - | CmmCode -- ^ misc rts code - | CmmClosure -- ^ closures eg CHARLIKE_closure - | CmmPrimCall -- ^ a prim call to some hand written Cmm code - deriving (Eq, Ord) - -data DynamicLinkerLabelInfo - = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt - | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo - | GotSymbolPtr -- ELF: foo@got - | GotSymbolOffset -- ELF: foo@gotoff - - deriving (Eq, Ord) - - --- ----------------------------------------------------------------------------- --- Constructing CLabels --- ----------------------------------------------------------------------------- - --- Constructing IdLabels --- These are always local: - -mkSRTLabel :: Unique -> CLabel -mkSRTLabel u = SRTLabel u - -mkRednCountsLabel :: Name -> CLabel -mkRednCountsLabel name = - IdLabel name NoCafRefs RednCounts -- Note [ticky for LNE] - --- These have local & (possibly) external variants: -mkLocalClosureLabel :: Name -> CafInfo -> CLabel -mkLocalInfoTableLabel :: Name -> CafInfo -> CLabel -mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel -mkLocalClosureLabel name c = IdLabel name c Closure -mkLocalInfoTableLabel name c = IdLabel name c LocalInfoTable -mkLocalClosureTableLabel name c = IdLabel name c ClosureTable - -mkClosureLabel :: Name -> CafInfo -> CLabel -mkInfoTableLabel :: Name -> CafInfo -> CLabel -mkEntryLabel :: Name -> CafInfo -> CLabel -mkClosureTableLabel :: Name -> CafInfo -> CLabel -mkConInfoTableLabel :: Name -> CafInfo -> CLabel -mkBytesLabel :: Name -> CLabel -mkClosureLabel name c = IdLabel name c Closure -mkInfoTableLabel name c = IdLabel name c InfoTable -mkEntryLabel name c = IdLabel name c Entry -mkClosureTableLabel name c = IdLabel name c ClosureTable -mkConInfoTableLabel name c = IdLabel name c ConInfoTable -mkBytesLabel name = IdLabel name NoCafRefs Bytes - -mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel -mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable - -- See Note [Proc-point local block entry-point]. - --- Constructing Cmm Labels -mkDirty_MUT_VAR_Label, - mkNonmovingWriteBarrierEnabledLabel, - mkUpdInfoLabel, - mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, - mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, - mkMAP_DIRTY_infoLabel, - mkArrWords_infoLabel, - mkTopTickyCtrLabel, - mkCAFBlackHoleInfoTableLabel, - mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, - mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel -mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction -mkNonmovingWriteBarrierEnabledLabel - = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData -mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo -mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo -mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo -mkMainCapabilityLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability") CmmData -mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo -mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo -mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo -mkTopTickyCtrLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct") CmmData -mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE") CmmInfo -mkArrWords_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS") CmmInfo -mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo -mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo -mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo -mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry - -mkSRTInfoLabel :: Int -> CLabel -mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo - where - lbl = - case n of - 1 -> fsLit "stg_SRT_1" - 2 -> fsLit "stg_SRT_2" - 3 -> fsLit "stg_SRT_3" - 4 -> fsLit "stg_SRT_4" - 5 -> fsLit "stg_SRT_5" - 6 -> fsLit "stg_SRT_6" - 7 -> fsLit "stg_SRT_7" - 8 -> fsLit "stg_SRT_8" - 9 -> fsLit "stg_SRT_9" - 10 -> fsLit "stg_SRT_10" - 11 -> fsLit "stg_SRT_11" - 12 -> fsLit "stg_SRT_12" - 13 -> fsLit "stg_SRT_13" - 14 -> fsLit "stg_SRT_14" - 15 -> fsLit "stg_SRT_15" - 16 -> fsLit "stg_SRT_16" - _ -> panic "mkSRTInfoLabel" - ------ -mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, - mkCmmCodeLabel, mkCmmClosureLabel - :: UnitId -> FastString -> CLabel - -mkCmmDataLabel :: UnitId -> NeedExternDecl -> FastString -> CLabel -mkRtsCmmDataLabel :: FastString -> CLabel - -mkCmmInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmInfo -mkCmmEntryLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmEntry -mkCmmRetInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo -mkCmmRetLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRet -mkCmmCodeLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmCode -mkCmmClosureLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmClosure -mkCmmDataLabel pkg ext str = CmmLabel pkg ext str CmmData -mkRtsCmmDataLabel str = CmmLabel rtsUnitId (NeedExternDecl False) str CmmData - -- RTS symbols don't need "GHC.CmmToC" to - -- generate \"extern\" declaration (they are - -- exposed via includes/Stg.h) - -mkLocalBlockLabel :: Unique -> CLabel -mkLocalBlockLabel u = LocalBlockLabel u - --- Constructing RtsLabels -mkRtsPrimOpLabel :: PrimOp -> CLabel -mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) - -mkSelectorInfoLabel :: Bool -> Int -> CLabel -mkSelectorEntryLabel :: Bool -> Int -> CLabel -mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) -mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) - -mkApInfoTableLabel :: Bool -> Int -> CLabel -mkApEntryLabel :: Bool -> Int -> CLabel -mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) -mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) - - --- A call to some primitive hand written Cmm code -mkPrimCallLabel :: PrimCall -> CLabel -mkPrimCallLabel (PrimCall str pkg) - = CmmLabel pkg (NeedExternDecl True) str CmmPrimCall - - --- Constructing ForeignLabels - --- | Make a foreign label -mkForeignLabel - :: FastString -- name - -> Maybe Int -- size prefix - -> ForeignLabelSource -- what package it's in - -> FunctionOrData - -> CLabel - -mkForeignLabel = ForeignLabel - - --- | Update the label size field in a ForeignLabel -addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ src fod) sz - = ForeignLabel str (Just sz) src fod -addLabelSize label _ - = label - --- | Whether label is a top-level string literal -isBytesLabel :: CLabel -> Bool -isBytesLabel (IdLabel _ _ Bytes) = True -isBytesLabel _lbl = False - --- | Whether label is a non-haskell label (defined in C code) -isForeignLabel :: CLabel -> Bool -isForeignLabel (ForeignLabel _ _ _ _) = True -isForeignLabel _lbl = False - --- | Whether label is a static closure label (can come from haskell or cmm) -isStaticClosureLabel :: CLabel -> Bool --- Closure defined in haskell (.hs) -isStaticClosureLabel (IdLabel _ _ Closure) = True --- Closure defined in cmm -isStaticClosureLabel (CmmLabel _ _ _ CmmClosure) = True -isStaticClosureLabel _lbl = False - --- | Whether label is a .rodata label -isSomeRODataLabel :: CLabel -> Bool --- info table defined in haskell (.hs) -isSomeRODataLabel (IdLabel _ _ ClosureTable) = True -isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True -isSomeRODataLabel (IdLabel _ _ InfoTable) = True -isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True -isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True --- info table defined in cmm (.cmm) -isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True -isSomeRODataLabel _lbl = False - --- | Whether label is points to some kind of info table -isInfoTableLabel :: CLabel -> Bool -isInfoTableLabel (IdLabel _ _ InfoTable) = True -isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True -isInfoTableLabel (IdLabel _ _ ConInfoTable) = True -isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True -isInfoTableLabel _ = False - --- | Whether label is points to constructor info table -isConInfoTableLabel :: CLabel -> Bool -isConInfoTableLabel (IdLabel _ _ ConInfoTable) = True -isConInfoTableLabel _ = False - --- | Get the label size field from a ForeignLabel -foreignLabelStdcallInfo :: CLabel -> Maybe Int -foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info -foreignLabelStdcallInfo _lbl = Nothing - - --- Constructing Large*Labels -mkBitmapLabel :: Unique -> CLabel -mkBitmapLabel uniq = LargeBitmapLabel uniq - --- Constructing Cost Center Labels -mkCCLabel :: CostCentre -> CLabel -mkCCSLabel :: CostCentreStack -> CLabel -mkCCLabel cc = CC_Label cc -mkCCSLabel ccs = CCS_Label ccs - -mkRtsApFastLabel :: FastString -> CLabel -mkRtsApFastLabel str = RtsLabel (RtsApFast str) - -mkRtsSlowFastTickyCtrLabel :: String -> CLabel -mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat) - - --- Constructing Code Coverage Labels -mkHpcTicksLabel :: Module -> CLabel -mkHpcTicksLabel = HpcTicksLabel - - --- Constructing labels used for dynamic linking -mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel -mkDynamicLinkerLabel = DynamicLinkerLabel - -dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) -dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) -dynamicLinkerLabelInfo _ = Nothing - -mkPicBaseLabel :: CLabel -mkPicBaseLabel = PicBaseLabel - - --- Constructing miscellaneous other labels -mkDeadStripPreventer :: CLabel -> CLabel -mkDeadStripPreventer lbl = DeadStripPreventer lbl - -mkStringLitLabel :: Unique -> CLabel -mkStringLitLabel = StringLitLabel - -mkAsmTempLabel :: Uniquable a => a -> CLabel -mkAsmTempLabel a = AsmTempLabel (getUnique a) - -mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel -mkAsmTempDerivedLabel = AsmTempDerivedLabel - -mkAsmTempEndLabel :: CLabel -> CLabel -mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end") - --- | Construct a label for a DWARF Debug Information Entity (DIE) --- describing another symbol. -mkAsmTempDieLabel :: CLabel -> CLabel -mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die") - --- ----------------------------------------------------------------------------- --- Convert between different kinds of label - -toClosureLbl :: CLabel -> CLabel -toClosureLbl (IdLabel n c _) = IdLabel n c Closure -toClosureLbl (CmmLabel m ext str _) = CmmLabel m ext str CmmClosure -toClosureLbl l = pprPanic "toClosureLbl" (ppr l) - -toSlowEntryLbl :: CLabel -> CLabel -toSlowEntryLbl (IdLabel n _ BlockInfoTable) - = pprPanic "toSlowEntryLbl" (ppr n) -toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow -toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l) - -toEntryLbl :: CLabel -> CLabel -toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry -toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -toEntryLbl (IdLabel n _ BlockInfoTable) = mkLocalBlockLabel (nameUnique n) - -- See Note [Proc-point local block entry-point]. -toEntryLbl (IdLabel n c _) = IdLabel n c Entry -toEntryLbl (CmmLabel m ext str CmmInfo) = CmmLabel m ext str CmmEntry -toEntryLbl (CmmLabel m ext str CmmRetInfo) = CmmLabel m ext str CmmRet -toEntryLbl l = pprPanic "toEntryLbl" (ppr l) - -toInfoLbl :: CLabel -> CLabel -toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable -toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable -toInfoLbl (CmmLabel m ext str CmmEntry)= CmmLabel m ext str CmmInfo -toInfoLbl (CmmLabel m ext str CmmRet) = CmmLabel m ext str CmmRetInfo -toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l) - -hasHaskellName :: CLabel -> Maybe Name -hasHaskellName (IdLabel n _ _) = Just n -hasHaskellName _ = Nothing - --- ----------------------------------------------------------------------------- --- Does a CLabel's referent itself refer to a CAF? -hasCAF :: CLabel -> Bool -hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE] -hasCAF (IdLabel _ MayHaveCafRefs _) = True -hasCAF _ = False - --- Note [ticky for LNE] --- ~~~~~~~~~~~~~~~~~~~~~ - --- Until 14 Feb 2013, every ticky counter was associated with a --- closure. Thus, ticky labels used IdLabel. It is odd that --- CmmBuildInfoTables.cafTransfers would consider such a ticky label --- reason to add the name to the CAFEnv (and thus eventually the SRT), --- but it was harmless because the ticky was only used if the closure --- was also. --- --- Since we now have ticky counters for LNEs, it is no longer the case --- that every ticky counter has an actual closure. So I changed the --- generation of ticky counters' CLabels to not result in their --- associated id ending up in the SRT. --- --- NB IdLabel is still appropriate for ticky ids (as opposed to --- CmmLabel) because the LNE's counter is still related to an .hs Id, --- that Id just isn't for a proper closure. - --- ----------------------------------------------------------------------------- --- Does a CLabel need declaring before use or not? --- --- See wiki:commentary/compiler/backends/ppr-c#prototypes - -needsCDecl :: CLabel -> Bool - -- False <=> it's pre-declared; don't bother - -- don't bother declaring Bitmap labels, we always make sure - -- they are defined before use. -needsCDecl (SRTLabel _) = True -needsCDecl (LargeBitmapLabel _) = False -needsCDecl (IdLabel _ _ _) = True -needsCDecl (LocalBlockLabel _) = True - -needsCDecl (StringLitLabel _) = False -needsCDecl (AsmTempLabel _) = False -needsCDecl (AsmTempDerivedLabel _ _) = False -needsCDecl (RtsLabel _) = False - -needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _) - -- local labels mustn't have it - | not external = False - - -- Prototypes for labels defined in the runtime system are imported - -- into HC files via includes/Stg.h. - | pkgId == rtsUnitId = False - - -- For other labels we inline one into the HC file directly. - | otherwise = True - -needsCDecl l@(ForeignLabel{}) = not (isMathFun l) -needsCDecl (CC_Label _) = True -needsCDecl (CCS_Label _) = True -needsCDecl (HpcTicksLabel _) = True -needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel" -needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel" -needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer" - --- | If a label is a local block label then return just its 'BlockId', otherwise --- 'Nothing'. -maybeLocalBlockLabel :: CLabel -> Maybe BlockId -maybeLocalBlockLabel (LocalBlockLabel uq) = Just $ mkBlockId uq -maybeLocalBlockLabel _ = Nothing - - --- | Check whether a label corresponds to a C function that has --- a prototype in a system header somehere, or is built-in --- to the C compiler. For these labels we avoid generating our --- own C prototypes. -isMathFun :: CLabel -> Bool -isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs -isMathFun _ = False - -math_funs :: UniqSet FastString -math_funs = mkUniqSet [ - -- _ISOC99_SOURCE - (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"), - (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"), - (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"), - (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"), - (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"), - (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"), - (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"), - (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"), - (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"), - (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"), - (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"), - (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"), - (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"), - (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"), - (fsLit "exp"), (fsLit "expf"), (fsLit "expl"), - (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"), - (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"), - (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"), - (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"), - (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"), - (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"), - (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"), - (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"), - (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"), - (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"), - (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"), - (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"), - (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"), - (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"), - (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"), - (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"), - (fsLit "log"), (fsLit "logf"), (fsLit "logl"), - (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"), - (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"), - (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"), - (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"), - (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"), - (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"), - (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"), - (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"), - (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"), - (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"), - (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"), - (fsLit "pow"), (fsLit "powf"), (fsLit "powl"), - (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"), - (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"), - (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"), - (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"), - (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"), - (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"), - (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"), - (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"), - (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"), - (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"), - (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"), - (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"), - (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"), - -- ISO C 99 also defines these function-like macros in math.h: - -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater, - -- isgreaterequal, isless, islessequal, islessgreater, isunordered - - -- additional symbols from _BSD_SOURCE - (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"), - (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"), - (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"), - (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"), - (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"), - (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"), - (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"), - (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"), - (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"), - (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"), - (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"), - (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"), - (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"), - (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl"), - - -- These functions are described in IEEE Std 754-2008 - - -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661 - (fsLit "nextup"), (fsLit "nextupf"), (fsLit "nextupl"), - (fsLit "nextdown"), (fsLit "nextdownf"), (fsLit "nextdownl") - ] - --- ----------------------------------------------------------------------------- --- | Is a CLabel visible outside this object file or not? --- From the point of view of the code generator, a name is --- externally visible if it has to be declared as exported --- in the .o file's symbol table; that is, made non-static. -externallyVisibleCLabel :: CLabel -> Bool -- not C "static" -externallyVisibleCLabel (StringLitLabel _) = False -externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False -externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (LocalBlockLabel _) = False -externallyVisibleCLabel (CmmLabel _ _ _ _) = True -externallyVisibleCLabel (ForeignLabel{}) = True -externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info -externallyVisibleCLabel (CC_Label _) = True -externallyVisibleCLabel (CCS_Label _) = True -externallyVisibleCLabel (DynamicLinkerLabel _ _) = False -externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel (LargeBitmapLabel _) = False -externallyVisibleCLabel (SRTLabel _) = False -externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" -externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" - -externallyVisibleIdLabel :: IdLabelInfo -> Bool -externallyVisibleIdLabel LocalInfoTable = False -externallyVisibleIdLabel LocalEntry = False -externallyVisibleIdLabel BlockInfoTable = False -externallyVisibleIdLabel _ = True - --- ----------------------------------------------------------------------------- --- Finding the "type" of a CLabel - --- For generating correct types in label declarations: - -data CLabelType - = CodeLabel -- Address of some executable instructions - | DataLabel -- Address of data, not a GC ptr - | GcPtrLabel -- Address of a (presumably static) GC object - -isCFunctionLabel :: CLabel -> Bool -isCFunctionLabel lbl = case labelType lbl of - CodeLabel -> True - _other -> False - -isGcPtrLabel :: CLabel -> Bool -isGcPtrLabel lbl = case labelType lbl of - GcPtrLabel -> True - _other -> False - - --- | Work out the general type of data at the address of this label --- whether it be code, data, or static GC object. -labelType :: CLabel -> CLabelType -labelType (IdLabel _ _ info) = idInfoLabelType info -labelType (CmmLabel _ _ _ CmmData) = DataLabel -labelType (CmmLabel _ _ _ CmmClosure) = GcPtrLabel -labelType (CmmLabel _ _ _ CmmCode) = CodeLabel -labelType (CmmLabel _ _ _ CmmInfo) = DataLabel -labelType (CmmLabel _ _ _ CmmEntry) = CodeLabel -labelType (CmmLabel _ _ _ CmmPrimCall) = CodeLabel -labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel -labelType (CmmLabel _ _ _ CmmRet) = CodeLabel -labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel -labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel -labelType (RtsLabel (RtsApFast _)) = CodeLabel -labelType (RtsLabel _) = DataLabel -labelType (LocalBlockLabel _) = CodeLabel -labelType (SRTLabel _) = DataLabel -labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel -labelType (ForeignLabel _ _ _ IsData) = DataLabel -labelType (AsmTempLabel _) = panic "labelType(AsmTempLabel)" -labelType (AsmTempDerivedLabel _ _) = panic "labelType(AsmTempDerivedLabel)" -labelType (StringLitLabel _) = DataLabel -labelType (CC_Label _) = DataLabel -labelType (CCS_Label _) = DataLabel -labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right? -labelType PicBaseLabel = DataLabel -labelType (DeadStripPreventer _) = DataLabel -labelType (HpcTicksLabel _) = DataLabel -labelType (LargeBitmapLabel _) = DataLabel - -idInfoLabelType :: IdLabelInfo -> CLabelType -idInfoLabelType info = - case info of - InfoTable -> DataLabel - LocalInfoTable -> DataLabel - BlockInfoTable -> DataLabel - Closure -> GcPtrLabel - ConInfoTable -> DataLabel - ClosureTable -> DataLabel - RednCounts -> DataLabel - Bytes -> DataLabel - _ -> CodeLabel - - --- ----------------------------------------------------------------------------- - --- | Is a 'CLabel' defined in the current module being compiled? --- --- Sometimes we can optimise references within a compilation unit in ways that --- we couldn't for inter-module references. This provides a conservative --- estimate of whether a 'CLabel' lives in the current module. -isLocalCLabel :: Module -> CLabel -> Bool -isLocalCLabel this_mod lbl = - case lbl of - IdLabel name _ _ - | isInternalName name -> True - | otherwise -> nameModule name == this_mod - LocalBlockLabel _ -> True - _ -> False - --- ----------------------------------------------------------------------------- - --- | Does a 'CLabel' need dynamic linkage? --- --- When referring to data in code, we need to know whether --- that data resides in a DLL or not. [Win32 only.] --- @labelDynamic@ returns @True@ if the label is located --- in a DLL, be it a data reference or not. -labelDynamic :: DynFlags -> Module -> CLabel -> Bool -labelDynamic dflags this_mod lbl = - case lbl of - -- is the RTS in a DLL or not? - RtsLabel _ -> - externalDynamicRefs && (this_pkg /= rtsUnitId) - - IdLabel n _ _ -> - isDllName dflags this_mod n - - -- When compiling in the "dyn" way, each package is to be linked into - -- its own shared library. - CmmLabel pkg _ _ _ - | os == OSMinGW32 -> - externalDynamicRefs && (this_pkg /= pkg) - | otherwise -> - gopt Opt_ExternalDynamicRefs dflags - - LocalBlockLabel _ -> False - - ForeignLabel _ _ source _ -> - if os == OSMinGW32 - then case source of - -- Foreign label is in some un-named foreign package (or DLL). - ForeignLabelInExternalPackage -> True - - -- Foreign label is linked into the same package as the - -- source file currently being compiled. - ForeignLabelInThisPackage -> False - - -- Foreign label is in some named package. - -- When compiling in the "dyn" way, each package is to be - -- linked into its own DLL. - ForeignLabelInPackage pkgId -> - externalDynamicRefs && (this_pkg /= pkgId) - - else -- On Mac OS X and on ELF platforms, false positives are OK, - -- so we claim that all foreign imports come from dynamic - -- libraries - True - - CC_Label cc -> - externalDynamicRefs && not (ccFromThisModule cc this_mod) - - -- CCS_Label always contains a CostCentre defined in the current module - CCS_Label _ -> False - - HpcTicksLabel m -> - externalDynamicRefs && this_mod /= m - - -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. - _ -> False - where - externalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags - os = platformOS (targetPlatform dflags) - this_pkg = moduleUnitId this_mod - - ------------------------------------------------------------------------------ --- Printing out CLabels. - -{- -Convention: - - _ - -where is _ for external names and for -internal names. is one of the following: - - info Info table - srt Static reference table - entry Entry code (function, closure) - slow Slow entry code (if any) - ret Direct return address - vtbl Vector table - _alt Case alternative (tag n) - dflt Default case alternative - btm Large bitmap vector - closure Static closure - con_entry Dynamic Constructor entry code - con_info Dynamic Constructor info table - static_entry Static Constructor entry code - static_info Static Constructor info table - sel_info Selector info table - sel_entry Selector entry code - cc Cost centre - ccs Cost centre stack - -Many of these distinctions are only for documentation reasons. For -example, _ret is only distinguished from _entry to make it easy to -tell whether a code fragment is a return point or a closure/function -entry. - -Note [Closure and info labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a function 'foo, we have: - foo_info : Points to the info table describing foo's closure - (and entry code for foo with tables next to code) - foo_closure : Static (no-free-var) closure only: - points to the statically-allocated closure - -For a data constructor (such as Just or Nothing), we have: - Just_con_info: Info table for the data constructor itself - the first word of a heap-allocated Just - Just_info: Info table for the *worker function*, an - ordinary Haskell function of arity 1 that - allocates a (Just x) box: - Just = \x -> Just x - Just_closure: The closure for this worker - - Nothing_closure: a statically allocated closure for Nothing - Nothing_static_info: info table for Nothing_closure - -All these must be exported symbol, EXCEPT Just_info. We don't need to -export this because in other modules we either have - * A reference to 'Just'; use Just_closure - * A saturated call 'Just x'; allocate using Just_con_info -Not exporting these Just_info labels reduces the number of symbols -somewhat. - -Note [Bytes label] -~~~~~~~~~~~~~~~~~~ -For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which -points to a static data block containing the content of the literal. - -Note [Proc-point local block entry-points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A label for a proc-point local block entry-point has no "_entry" suffix. With -`infoTblLbl` we derive an info table label from a proc-point block ID. If -we convert such an info table label into an entry label we must produce -the label without an "_entry" suffix. So an info table label records -the fact that it was derived from a block ID in `IdLabelInfo` as -`BlockInfoTable`. - -The info table label and the local block label are both local labels -and are not externally visible. --} - -instance Outputable CLabel where - ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c - -pprCLabel :: DynFlags -> CLabel -> SDoc - -pprCLabel _ (LocalBlockLabel u) - = tempLabelPrefixOrUnderscore <> pprUniqueAlways u - -pprCLabel dynFlags (AsmTempLabel u) - | not (platformUnregisterised $ targetPlatform dynFlags) - = tempLabelPrefixOrUnderscore <> pprUniqueAlways u - -pprCLabel dynFlags (AsmTempDerivedLabel l suf) - | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags - = ptext (asmTempLabelPrefix $ targetPlatform dynFlags) - <> case l of AsmTempLabel u -> pprUniqueAlways u - LocalBlockLabel u -> pprUniqueAlways u - _other -> pprCLabel dynFlags l - <> ftext suf - -pprCLabel dynFlags (DynamicLinkerLabel info lbl) - | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags - = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl - -pprCLabel dynFlags PicBaseLabel - | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags - = text "1b" - -pprCLabel dynFlags (DeadStripPreventer lbl) - | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags - = - {- - `lbl` can be temp one but we need to ensure that dsp label will stay - in the final binary so we prepend non-temp prefix ("dsp_") and - optional `_` (underscore) because this is how you mark non-temp symbols - on some platforms (Darwin) - -} - maybe_underscore dynFlags $ text "dsp_" - <> pprCLabel dynFlags lbl <> text "_dsp" - -pprCLabel dynFlags (StringLitLabel u) - | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags - = pprUniqueAlways u <> ptext (sLit "_str") - -pprCLabel dynFlags lbl - = getPprStyle $ \ sty -> - if platformMisc_ghcWithNativeCodeGen (platformMisc dynFlags) && asmStyle sty - then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl - else pprCLbl lbl - -maybe_underscore :: DynFlags -> SDoc -> SDoc -maybe_underscore dynFlags doc = - if platformMisc_leadingUnderscore $ platformMisc dynFlags - then pp_cSEP <> doc - else doc - -pprAsmCLbl :: Platform -> CLabel -> SDoc -pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _) - | platformOS platform == OSMinGW32 - -- In asm mode, we need to put the suffix on a stdcall ForeignLabel. - -- (The C compiler does this itself). - = ftext fs <> char '@' <> int sz -pprAsmCLbl _ lbl - = pprCLbl lbl - -pprCLbl :: CLabel -> SDoc -pprCLbl (StringLitLabel u) - = pprUniqueAlways u <> text "_str" - -pprCLbl (SRTLabel u) - = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt" - -pprCLbl (LargeBitmapLabel u) = - tempLabelPrefixOrUnderscore - <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm" --- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') --- until that gets resolved we'll just force them to start --- with a letter so the label will be legal assembly code. - - -pprCLbl (CmmLabel _ _ str CmmCode) = ftext str -pprCLbl (CmmLabel _ _ str CmmData) = ftext str -pprCLbl (CmmLabel _ _ str CmmPrimCall) = ftext str - -pprCLbl (LocalBlockLabel u) = - tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u - -pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> text "_fast" - -pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) - = sdocWithDynFlags $ \dflags -> - ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) - hcat [text "stg_sel_", text (show offset), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = sdocWithDynFlags $ \dflags -> - ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) - hcat [text "stg_sel_", text (show offset), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) - ] - -pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity)) - = sdocWithDynFlags $ \dflags -> - ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) - hcat [text "stg_ap_", text (show arity), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) - = sdocWithDynFlags $ \dflags -> - ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) - hcat [text "stg_ap_", text (show arity), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) - ] - -pprCLbl (CmmLabel _ _ fs CmmInfo) - = ftext fs <> text "_info" - -pprCLbl (CmmLabel _ _ fs CmmEntry) - = ftext fs <> text "_entry" - -pprCLbl (CmmLabel _ _ fs CmmRetInfo) - = ftext fs <> text "_info" - -pprCLbl (CmmLabel _ _ fs CmmRet) - = ftext fs <> text "_ret" - -pprCLbl (CmmLabel _ _ fs CmmClosure) - = ftext fs <> text "_closure" - -pprCLbl (RtsLabel (RtsPrimOp primop)) - = text "stg_" <> ppr primop - -pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat)) - = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr") - -pprCLbl (ForeignLabel str _ _ _) - = ftext str - -pprCLbl (IdLabel name _cafs flavor) = - internalNamePrefix name <> ppr name <> ppIdFlavor flavor - -pprCLbl (CC_Label cc) = ppr cc -pprCLbl (CCS_Label ccs) = ppr ccs - -pprCLbl (HpcTicksLabel mod) - = text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc") - -pprCLbl (AsmTempLabel {}) = panic "pprCLbl AsmTempLabel" -pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel" -pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel" -pprCLbl (PicBaseLabel {}) = panic "pprCLbl PicBaseLabel" -pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer" - -ppIdFlavor :: IdLabelInfo -> SDoc -ppIdFlavor x = pp_cSEP <> text - (case x of - Closure -> "closure" - InfoTable -> "info" - LocalInfoTable -> "info" - Entry -> "entry" - LocalEntry -> "entry" - Slow -> "slow" - RednCounts -> "ct" - ConEntry -> "con_entry" - ConInfoTable -> "con_info" - ClosureTable -> "closure_tbl" - Bytes -> "bytes" - BlockInfoTable -> "info" - ) - - -pp_cSEP :: SDoc -pp_cSEP = char '_' - - -instance Outputable ForeignLabelSource where - ppr fs - = case fs of - ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId - ForeignLabelInThisPackage -> parens $ text "this package" - ForeignLabelInExternalPackage -> parens $ text "external package" - -internalNamePrefix :: Name -> SDoc -internalNamePrefix name = getPprStyle $ \ sty -> - if asmStyle sty && isRandomGenerated then - sdocWithPlatform $ \platform -> - ptext (asmTempLabelPrefix platform) - else - empty - where - isRandomGenerated = not $ isExternalName name - -tempLabelPrefixOrUnderscore :: SDoc -tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform -> - getPprStyle $ \ sty -> - if asmStyle sty then - ptext (asmTempLabelPrefix platform) - else - char '_' - --- ----------------------------------------------------------------------------- --- Machine-dependent knowledge about labels. - -asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels -asmTempLabelPrefix platform = case platformOS platform of - OSDarwin -> sLit "L" - OSAIX -> sLit "__L" -- follow IBM XL C's convention - _ -> sLit ".L" - -pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc -pprDynamicLinkerAsmLabel platform dllInfo lbl = - case platformOS platform of - OSDarwin - | platformArch platform == ArchX86_64 -> - case dllInfo of - CodeStub -> char 'L' <> ppr lbl <> text "$stub" - SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" - GotSymbolPtr -> ppr lbl <> text "@GOTPCREL" - GotSymbolOffset -> ppr lbl - | otherwise -> - case dllInfo of - CodeStub -> char 'L' <> ppr lbl <> text "$stub" - SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" - _ -> panic "pprDynamicLinkerAsmLabel" - - OSAIX -> - case dllInfo of - SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention - _ -> panic "pprDynamicLinkerAsmLabel" - - _ | osElfTarget (platformOS platform) -> elfLabel - - OSMinGW32 -> - case dllInfo of - SymbolPtr -> text "__imp_" <> ppr lbl - _ -> panic "pprDynamicLinkerAsmLabel" - - _ -> panic "pprDynamicLinkerAsmLabel" - where - elfLabel - | platformArch platform == ArchPPC - = case dllInfo of - CodeStub -> -- See Note [.LCTOC1 in PPC PIC code] - ppr lbl <> text "+32768@plt" - SymbolPtr -> text ".LC_" <> ppr lbl - _ -> panic "pprDynamicLinkerAsmLabel" - - | platformArch platform == ArchX86_64 - = case dllInfo of - CodeStub -> ppr lbl <> text "@plt" - GotSymbolPtr -> ppr lbl <> text "@gotpcrel" - GotSymbolOffset -> ppr lbl - SymbolPtr -> text ".LC_" <> ppr lbl - - | platformArch platform == ArchPPC_64 ELF_V1 - || platformArch platform == ArchPPC_64 ELF_V2 - = case dllInfo of - GotSymbolPtr -> text ".LC_" <> ppr lbl - <> text "@toc" - GotSymbolOffset -> ppr lbl - SymbolPtr -> text ".LC_" <> ppr lbl - _ -> panic "pprDynamicLinkerAsmLabel" - - | otherwise - = case dllInfo of - CodeStub -> ppr lbl <> text "@plt" - SymbolPtr -> text ".LC_" <> ppr lbl - GotSymbolPtr -> ppr lbl <> text "@got" - GotSymbolOffset -> ppr lbl <> text "@gotoff" - --- Figure out whether `symbol` may serve as an alias --- to `target` within one compilation unit. --- --- This is true if any of these holds: --- * `target` is a module-internal haskell name. --- * `target` is an exported name, but comes from the same --- module as `symbol` --- --- These are sufficient conditions for establishing e.g. a --- GNU assembly alias ('.equiv' directive). Sadly, there is --- no such thing as an alias to an imported symbol (conf. --- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/) --- See note [emit-time elimination of static indirections]. --- --- Precondition is that both labels represent the --- same semantic value. - -mayRedirectTo :: CLabel -> CLabel -> Bool -mayRedirectTo symbol target - | Just nam <- haskellName - , staticClosureLabel - , isExternalName nam - , Just mod <- nameModule_maybe nam - , Just anam <- hasHaskellName symbol - , Just amod <- nameModule_maybe anam - = amod == mod - - | Just nam <- haskellName - , staticClosureLabel - , isInternalName nam - = True - - | otherwise = False - where staticClosureLabel = isStaticClosureLabel target - haskellName = hasHaskellName target - - -{- -Note [emit-time elimination of static indirections] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in #15155, certain static values are repesentationally -equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers). - - newtype A = A Int - {-# NOINLINE a #-} - a = A 42 - -a1_rYB :: Int -[GblId, Caf=NoCafRefs, Unf=OtherCon []] -a1_rYB = GHC.Types.I# 42# - -a [InlPrag=NOINLINE] :: A -[GblId, Unf=OtherCon []] -a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A) - -Formerly we created static indirections for these (IND_STATIC), which -consist of a statically allocated forwarding closure that contains -the (possibly tagged) indirectee. (See CMM/assembly below.) -This approach is suboptimal for two reasons: - (a) they occupy extra space, - (b) they need to be entered in order to obtain the indirectee, - thus they cannot be tagged. - -Fortunately there is a common case where static indirections can be -eliminated while emitting assembly (native or LLVM), viz. when the -indirectee is in the same module (object file) as the symbol that -points to it. In this case an assembly-level identification can -be created ('.equiv' directive), and as such the same object will -be assigned two names in the symbol table. Any of the identified -symbols can be referenced by a tagged pointer. - -Currently the 'mayRedirectTo' predicate will -give a clue whether a label can be equated with another, already -emitted, label (which can in turn be an alias). The general mechanics -is that we identify data (IND_STATIC closures) that are amenable -to aliasing while pretty-printing of assembly output, and emit the -'.equiv' directive instead of static data in such a case. - -Here is a sketch how the output is massaged: - - Consider -newtype A = A Int -{-# NOINLINE a #-} -a = A 42 -- I# 42# is the indirectee - -- 'a' is exported - - results in STG - -a1_rXq :: GHC.Types.Int -[GblId, Caf=NoCafRefs, Unf=OtherCon []] = - CCS_DONT_CARE GHC.Types.I#! [42#]; - -T15155.a [InlPrag=NOINLINE] :: T15155.A -[GblId, Unf=OtherCon []] = - CAF_ccs \ u [] a1_rXq; - - and CMM - -[section ""data" . a1_rXq_closure" { - a1_rXq_closure: - const GHC.Types.I#_con_info; - const 42; - }] - -[section ""data" . T15155.a_closure" { - T15155.a_closure: - const stg_IND_STATIC_info; - const a1_rXq_closure+1; - const 0; - const 0; - }] - -The emitted assembly is - -#### INDIRECTEE -a1_rXq_closure: -- module local haskell value - .quad GHC.Types.I#_con_info -- an Int - .quad 42 - -#### BEFORE -.globl T15155.a_closure -- exported newtype wrapped value -T15155.a_closure: - .quad stg_IND_STATIC_info -- the closure info - .quad a1_rXq_closure+1 -- indirectee ('+1' being the tag) - .quad 0 - .quad 0 - -#### AFTER -.globl T15155.a_closure -- exported newtype wrapped value -.equiv a1_rXq_closure,T15155.a_closure -- both are shared - -The transformation is performed because - T15155.a_closure `mayRedirectTo` a1_rXq_closure+1 -returns True. --} diff --git a/cmm/Cmm.hs b/cmm/Cmm.hs deleted file mode 100644 --- a/cmm/Cmm.hs +++ /dev/null @@ -1,247 +0,0 @@ --- Cmm representations using Hoopl's Graph CmmNode e x. -{-# LANGUAGE GADTs #-} - -module Cmm ( - -- * Cmm top-level datatypes - CmmProgram, CmmGroup, GenCmmGroup, - CmmDecl, GenCmmDecl(..), - CmmGraph, GenCmmGraph(..), - CmmBlock, - RawCmmDecl, RawCmmGroup, - Section(..), SectionType(..), CmmStatics(..), CmmStatic(..), - SectionProtection(..), sectionProtection, - - -- ** Blocks containing lists - GenBasicBlock(..), blockId, - ListGraph(..), pprBBlock, - - -- * Info Tables - CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable, - ClosureTypeInfo(..), - ProfilingInfo(..), ConstrDescription, - - -- * Statements, expressions and types - module CmmNode, - module CmmExpr, - ) where - -import GhcPrelude - -import Id -import CostCentre -import CLabel -import BlockId -import CmmNode -import SMRep -import CmmExpr -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Graph -import Hoopl.Label -import Outputable -import Data.ByteString (ByteString) - ------------------------------------------------------------------------------ --- Cmm, GenCmm ------------------------------------------------------------------------------ - --- A CmmProgram is a list of CmmGroups --- A CmmGroup is a list of top-level declarations - --- When object-splitting is on, each group is compiled into a separate --- .o file. So typically we put closely related stuff in a CmmGroup. --- Section-splitting follows suit and makes one .text subsection for each --- CmmGroup. - -type CmmProgram = [CmmGroup] - -type GenCmmGroup d h g = [GenCmmDecl d h g] -type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph -type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph - ------------------------------------------------------------------------------ --- CmmDecl, GenCmmDecl ------------------------------------------------------------------------------ - --- GenCmmDecl is abstracted over --- d, the type of static data elements in CmmData --- h, the static info preceding the code of a CmmProc --- g, the control-flow graph of a CmmProc --- --- We expect there to be two main instances of this type: --- (a) C--, i.e. populated with various C-- constructs --- (b) Native code, populated with data/instructions - --- | A top-level chunk, abstracted over the type of the contents of --- the basic blocks (Cmm or instructions are the likely instantiations). -data GenCmmDecl d h g - = CmmProc -- A procedure - h -- Extra header such as the info table - CLabel -- Entry label - [GlobalReg] -- Registers live on entry. Note that the set of live - -- registers will be correct in generated C-- code, but - -- not in hand-written C-- code. However, - -- splitAtProcPoints calculates correct liveness - -- information for CmmProcs. - g -- Control-flow graph for the procedure's code - - | CmmData -- Static data - Section - d - -type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph - -type RawCmmDecl - = GenCmmDecl - CmmStatics - (LabelMap CmmStatics) - CmmGraph - ------------------------------------------------------------------------------ --- Graphs ------------------------------------------------------------------------------ - -type CmmGraph = GenCmmGraph CmmNode -data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } -type CmmBlock = Block CmmNode C C - ------------------------------------------------------------------------------ --- Info Tables ------------------------------------------------------------------------------ - --- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains --- the extra info (beyond the executable code) that belongs to that CmmDecl. -data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable - , stack_info :: CmmStackInfo } - -topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable -topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) -topInfoTable _ = Nothing - -data CmmStackInfo - = StackInfo { - arg_space :: ByteOff, - -- number of bytes of arguments on the stack on entry to the - -- the proc. This is filled in by GHC.StgToCmm.codeGen, and - -- used by the stack allocator later. - updfr_space :: Maybe ByteOff, - -- XXX: this never contains anything useful, but it should. - -- See comment in CmmLayoutStack. - do_layout :: Bool - -- Do automatic stack layout for this proc. This is - -- True for all code generated by the code generator, - -- but is occasionally False for hand-written Cmm where - -- we want to do the stack manipulation manually. - } - --- | Info table as a haskell data type -data CmmInfoTable - = CmmInfoTable { - cit_lbl :: CLabel, -- Info table label - cit_rep :: SMRep, - cit_prof :: ProfilingInfo, - cit_srt :: Maybe CLabel, -- empty, or a closure address - cit_clo :: Maybe (Id, CostCentreStack) - -- Just (id,ccs) <=> build a static closure later - -- Nothing <=> don't build a static closure - -- - -- Static closures for FUNs and THUNKs are *not* generated by - -- the code generator, because we might want to add SRT - -- entries to them later (for FUNs at least; THUNKs are - -- treated the same for consistency). See Note [SRTs] in - -- CmmBuildInfoTables, in particular the [FUN] optimisation. - -- - -- This is strictly speaking not a part of the info table that - -- will be finally generated, but it's the only convenient - -- place to convey this information from the code generator to - -- where we build the static closures in - -- CmmBuildInfoTables.doSRTs. - } - -data ProfilingInfo - = NoProfilingInfo - | ProfilingInfo ByteString ByteString -- closure_type, closure_desc - ------------------------------------------------------------------------------ --- Static Data ------------------------------------------------------------------------------ - -data SectionType - = Text - | Data - | ReadOnlyData - | RelocatableReadOnlyData - | UninitialisedData - | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned - | CString - | OtherSection String - deriving (Show) - -data SectionProtection - = ReadWriteSection - | ReadOnlySection - | WriteProtectedSection -- See Note [Relocatable Read-Only Data] - deriving (Eq) - --- | Should a data in this section be considered constant at runtime -sectionProtection :: Section -> SectionProtection -sectionProtection (Section t _) = case t of - Text -> ReadOnlySection - ReadOnlyData -> ReadOnlySection - RelocatableReadOnlyData -> WriteProtectedSection - ReadOnlyData16 -> ReadOnlySection - CString -> ReadOnlySection - Data -> ReadWriteSection - UninitialisedData -> ReadWriteSection - (OtherSection _) -> ReadWriteSection - -{- -Note [Relocatable Read-Only Data] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Relocatable data are only read-only after relocation at the start of the -program. They should be writable from the source code until then. Failure to -do so would end up in segfaults at execution when using linkers that do not -enforce writability of those sections, such as the gold linker. --} - -data Section = Section SectionType CLabel - -data CmmStatic - = CmmStaticLit CmmLit - -- a literal value, size given by cmmLitRep of the literal. - | CmmUninitialised Int - -- uninitialised data, N bytes long - | CmmString ByteString - -- string of 8-bit values only, not zero terminated. - -data CmmStatics - = Statics - CLabel -- Label of statics - [CmmStatic] -- The static data itself - --- ----------------------------------------------------------------------------- --- Basic blocks consisting of lists - --- These are used by the LLVM and NCG backends, when populating Cmm --- with lists of instructions. - -data GenBasicBlock i = BasicBlock BlockId [i] - --- | The branch block id is that of the first block in --- the branch, which is that branch's entry point -blockId :: GenBasicBlock i -> BlockId -blockId (BasicBlock blk_id _ ) = blk_id - -newtype ListGraph i = ListGraph [GenBasicBlock i] - -instance Outputable instr => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) - -instance Outputable instr => Outputable (GenBasicBlock instr) where - ppr = pprBBlock - -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) - diff --git a/cmm/CmmBuildInfoTables.hs b/cmm/CmmBuildInfoTables.hs deleted file mode 100644 --- a/cmm/CmmBuildInfoTables.hs +++ /dev/null @@ -1,892 +0,0 @@ -{-# LANGUAGE GADTs, BangPatterns, RecordWildCards, - GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-} - -module CmmBuildInfoTables - ( CAFSet, CAFEnv, cafAnal - , doSRTs, ModuleSRTInfo, emptySRT - ) where - -import GhcPrelude hiding (succ) - -import Id -import BlockId -import Hoopl.Block -import Hoopl.Graph -import Hoopl.Label -import Hoopl.Collections -import Hoopl.Dataflow -import Module -import GHC.Platform -import Digraph -import CLabel -import Cmm -import CmmUtils -import DynFlags -import Maybes -import Outputable -import SMRep -import UniqSupply -import CostCentre -import GHC.StgToCmm.Heap - -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Tuple -import Control.Monad.Trans.State -import Control.Monad.Trans.Class - - -{- Note [SRTs] - -SRTs are the mechanism by which the garbage collector can determine -the live CAFs in the program. - -Representation -^^^^^^^^^^^^^^ - -+------+ -| info | -| | +-----+---+---+---+ -| -------->|SRT_2| | | | | 0 | -|------| +-----+-|-+-|-+---+ -| | | | -| code | | | -| | v v - -An SRT is simply an object in the program's data segment. It has the -same representation as a static constructor. There are 16 -pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info, -representing SRT objects with 1-16 pointers, respectively. - -The entries of an SRT object point to static closures, which are either -- FUN_STATIC, THUNK_STATIC or CONSTR -- Another SRT (actually just a CONSTR) - -The final field of the SRT is the static link field, used by the -garbage collector to chain together static closures that it visits and -to determine whether a static closure has been visited or not. (see -Note [STATIC_LINK fields]) - -By traversing the transitive closure of an SRT, the GC will reach all -of the CAFs that are reachable from the code associated with this SRT. - -If we need to create an SRT with more than 16 entries, we build a -chain of SRT objects with all but the last having 16 entries. - -+-----+---+- -+---+---+ -|SRT16| | | | | | 0 | -+-----+-|-+- -+-|-+---+ - | | - v v - +----+---+---+---+ - |SRT2| | | | | 0 | - +----+-|-+-|-+---+ - | | - | | - v v - -Referring to an SRT from the info table -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -The following things have SRTs: - -- Static functions (FUN) -- Static thunks (THUNK), ie. CAFs -- Continuations (RET_SMALL, etc.) - -In each case, the info table points to the SRT. - -- info->srt is zero if there's no SRT, otherwise: -- info->srt == 1 and info->f.srt_offset points to the SRT - -e.g. for a FUN with an SRT: - -StgFunInfoTable +------+ - info->f.srt_offset | ------------> offset to SRT object -StgStdInfoTable +------+ - info->layout.ptrs | ... | - info->layout.nptrs | ... | - info->srt | 1 | - info->type | ... | - |------| - -On x86_64, we optimise the info table representation further. The -offset to the SRT can be stored in 32 bits (all code lives within a -2GB region in x86_64's small memory model), so we can save a word in -the info table by storing the srt_offset in the srt field, which is -half a word. - -On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169): - -- info->srt is zero if there's no SRT, otherwise: -- info->srt is an offset from the info pointer to the SRT object - -StgStdInfoTable +------+ - info->layout.ptrs | | - info->layout.nptrs | | - info->srt | ------------> offset to SRT object - |------| - - -EXAMPLE -^^^^^^^ - -f = \x. ... g ... - where - g = \y. ... h ... c1 ... - h = \z. ... c2 ... - -c1 & c2 are CAFs - -g and h are local functions, but they have no static closures. When -we generate code for f, we start with a CmmGroup of four CmmDecls: - - [ f_closure, f_entry, g_entry, h_entry ] - -we process each CmmDecl separately in cpsTop, giving us a list of -CmmDecls. e.g. for f_entry, we might end up with - - [ f_entry, f1_ret, f2_proc ] - -where f1_ret is a return point, and f2_proc is a proc-point. We have -a CAFSet for each of these CmmDecls, let's suppose they are - - [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ] - [ g_entry{h_info, c1_closure} ] - [ h_entry{c2_closure} ] - -Next, we make an SRT for each of these functions: - - f_srt : [g_info] - g_srt : [h_info, c1_closure] - h_srt : [c2_closure] - -Now, for g_info and h_info, we want to refer to the SRTs for g and h -respectively, which we'll label g_srt and h_srt: - - f_srt : [g_srt] - g_srt : [h_srt, c1_closure] - h_srt : [c2_closure] - -Now, when an SRT has a single entry, we don't actually generate an SRT -closure for it, instead we just replace references to it with its -single element. So, since h_srt == c2_closure, we have - - f_srt : [g_srt] - g_srt : [c2_closure, c1_closure] - h_srt : [c2_closure] - -and the only SRT closure we generate is - - g_srt = SRT_2 [c2_closure, c1_closure] - - -Optimisations -^^^^^^^^^^^^^ - -To reduce the code size overhead and the cost of traversing SRTs in -the GC, we want to simplify SRTs where possible. We therefore apply -the following optimisations. Each has a [keyword]; search for the -keyword in the code below to see where the optimisation is -implemented. - -1. [Inline] we never create an SRT with a single entry, instead we - point to the single entry directly from the info table. - - i.e. instead of - - +------+ - | info | - | | +-----+---+---+ - | -------->|SRT_1| | | 0 | - |------| +-----+-|-+---+ - | | | - | code | | - | | v - C - - we can point directly to the closure: - - +------+ - | info | - | | - | -------->C - |------| - | | - | code | - | | - - - Furthermore, the SRT for any code that refers to this info table - can point directly to C. - - The exception to this is when we're doing dynamic linking. In that - case, if the closure is not locally defined then we can't point to - it directly from the info table, because this is the text section - which cannot contain runtime relocations. In this case we skip this - optimisation and generate the singleton SRT, becase SRTs are in the - data section and *can* have relocatable references. - -2. [FUN] A static function closure can also be an SRT, we simply put - the SRT entries as fields in the static closure. This makes a lot - of sense: the static references are just like the free variables of - the FUN closure. - - i.e. instead of - - f_closure: - +-----+---+ - | | | 0 | - +- |--+---+ - | +------+ - | | info | f_srt: - | | | +-----+---+---+---+ - | | -------->|SRT_2| | | | + 0 | - `----------->|------| +-----+-|-+-|-+---+ - | | | | - | code | | | - | | v v - - - We can generate: - - f_closure: - +-----+---+---+---+ - | | | | | | | 0 | - +- |--+-|-+-|-+---+ - | | | +------+ - | v v | info | - | | | - | | 0 | - `----------->|------| - | | - | code | - | | - - - (note: we can't do this for THUNKs, because the thunk gets - overwritten when it is entered, so we wouldn't be able to share - this SRT with other info tables that want to refer to it (see - [Common] below). FUNs are immutable so don't have this problem.) - -3. [Common] Identical SRTs can be commoned up. - -4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also - refers to C (perhaps transitively), then we can omit the reference - to C from A. - - -Note that there are many other optimisations that we could do, but -aren't implemented. In general, we could omit any reference from an -SRT if everything reachable from it is also reachable from the other -fields in the SRT. Our [Filter] optimisation is a special case of -this. - -Another opportunity we don't exploit is this: - -A = {X,Y,Z} -B = {Y,Z} -C = {X,B} - -Here we could use C = {A} and therefore [Inline] C = A. --} - --- --------------------------------------------------------------------- -{- Note [Invalid optimisation: shortcutting] - -You might think that if we have something like - -A's SRT = {B} -B's SRT = {X} - -that we could replace the reference to B in A's SRT with X. - -A's SRT = {X} -B's SRT = {X} - -and thereby perhaps save a little work at runtime, because we don't -have to visit B. - -But this is NOT valid. - -Consider these cases: - -0. B can't be a constructor, because constructors don't have SRTs - -1. B is a CAF. This is the easy one. Obviously we want A's SRT to - point to B, so that it keeps B alive. - -2. B is a function. This is the tricky one. The reason we can't -shortcut in this case is that we aren't allowed to resurrect static -objects. - -== How does this cause a problem? == - -The particular case that cropped up when we tried this was #15544. -- A is a thunk -- B is a static function -- X is a CAF -- suppose we GC when A is alive, and B is not otherwise reachable. -- B is "collected", meaning that it doesn't make it onto the static - objects list during this GC, but nothing bad happens yet. -- Next, suppose we enter A, and then call B. (remember that A refers to B) - At the entry point to B, we GC. This puts B on the stack, as part of the - RET_FUN stack frame that gets pushed when we GC at a function entry point. -- This GC will now reach B -- But because B was previous "collected", it breaks the assumption - that static objects are never resurrected. See Note [STATIC_LINK - fields] in rts/sm/Storage.h for why this is bad. -- In practice, the GC thinks that B has already been visited, and so - doesn't visit X, and catastrophe ensues. - -== Isn't this caused by the RET_FUN business? == - -Maybe, but could you prove that RET_FUN is the only way that -resurrection can occur? - -So, no shortcutting. --} - --- --------------------------------------------------------------------- --- Label types - --- Labels that come from cafAnal can be: --- - _closure labels for static functions or CAFs --- - _info labels for dynamic functions, thunks, or continuations --- - _entry labels for functions or thunks --- --- Meanwhile the labels on top-level blocks are _entry labels. --- --- To put everything in the same namespace we convert all labels to --- closure labels using toClosureLbl. Note that some of these --- labels will not actually exist; that's ok because we're going to --- map them to SRTEntry later, which ranges over labels that do exist. --- -newtype CAFLabel = CAFLabel CLabel - deriving (Eq,Ord,Outputable) - -type CAFSet = Set CAFLabel -type CAFEnv = LabelMap CAFSet - -mkCAFLabel :: CLabel -> CAFLabel -mkCAFLabel lbl = CAFLabel (toClosureLbl lbl) - --- This is a label that we can put in an SRT. It *must* be a closure label, --- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR. -newtype SRTEntry = SRTEntry CLabel - deriving (Eq, Ord, Outputable) - --- --------------------------------------------------------------------- --- CAF analysis - --- | --- For each code block: --- - collect the references reachable from this code block to FUN, --- THUNK or RET labels for which hasCAF == True --- --- This gives us a `CAFEnv`: a mapping from code block to sets of labels --- -cafAnal - :: LabelSet -- The blocks representing continuations, ie. those - -- that will get RET info tables. These labels will - -- get their own SRTs, so we don't aggregate CAFs from - -- references to these labels, we just use the label. - -> CLabel -- The top label of the proc - -> CmmGraph - -> CAFEnv -cafAnal contLbls topLbl cmmGraph = - analyzeCmmBwd cafLattice - (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty - - -cafLattice :: DataflowLattice CAFSet -cafLattice = DataflowLattice Set.empty add - where - add (OldFact old) (NewFact new) = - let !new' = old `Set.union` new - in changedIf (Set.size new' > Set.size old) new' - - -cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet -cafTransfers contLbls entry topLbl - (BlockCC eNode middle xNode) fBase = - let joined = cafsInNode xNode $! live' - !result = foldNodesBwdOO cafsInNode middle joined - - facts = mapMaybe successorFact (successors xNode) - live' = joinFacts cafLattice facts - - successorFact s - -- If this is a loop back to the entry, we can refer to the - -- entry label. - | s == entry = Just (add topLbl Set.empty) - -- If this is a continuation, we want to refer to the - -- SRT for the continuation's info table - | s `setMember` contLbls - = Just (Set.singleton (mkCAFLabel (infoTblLbl s))) - -- Otherwise, takes the CAF references from the destination - | otherwise - = lookupFact s fBase - - cafsInNode :: CmmNode e x -> CAFSet -> CAFSet - cafsInNode node set = foldExpDeep addCaf node set - - addCaf expr !set = - case expr of - CmmLit (CmmLabel c) -> add c set - CmmLit (CmmLabelOff c _) -> add c set - CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set - _ -> set - add l s | hasCAF l = Set.insert (mkCAFLabel l) s - | otherwise = s - - in mapSingleton (entryLabel eNode) result - - --- ----------------------------------------------------------------------------- --- ModuleSRTInfo - -data ModuleSRTInfo = ModuleSRTInfo - { thisModule :: Module - -- ^ Current module being compiled. Required for calling labelDynamic. - , dedupSRTs :: Map (Set SRTEntry) SRTEntry - -- ^ previous SRTs we've emitted, so we can de-duplicate. - -- Used to implement the [Common] optimisation. - , flatSRTs :: Map SRTEntry (Set SRTEntry) - -- ^ The reverse mapping, so that we can remove redundant - -- entries. e.g. if we have an SRT [a,b,c], and we know that b - -- points to [c,d], we can omit c and emit [a,b]. - -- Used to implement the [Filter] optimisation. - } -instance Outputable ModuleSRTInfo where - ppr ModuleSRTInfo{..} = - text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs - -emptySRT :: Module -> ModuleSRTInfo -emptySRT mod = - ModuleSRTInfo - { thisModule = mod - , dedupSRTs = Map.empty - , flatSRTs = Map.empty } - --- ----------------------------------------------------------------------------- --- Constructing SRTs - -{- Implementation notes - -- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable - -- The entry in info_tbls corresponding to g_entry is the closure info - table, the rest are continuations. - -- Each entry in info_tbls possibly needs an SRT. We need to make a - label for each of these. - -- We get the CAFSet for each entry from the CAFEnv - --} - --- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl, --- where the label is --- - the info label for a continuation or dynamic closure --- - the closure label for a top-level function (not a CAF) -getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)] -getLabelledBlocks (CmmData _ _) = [] -getLabelledBlocks (CmmProc top_info _ _ _) = - [ (blockId, mkCAFLabel (cit_lbl info)) - | (blockId, info) <- mapToList (info_tbls top_info) - , let rep = cit_rep info - , not (isStaticRep rep) || not (isThunkRep rep) - ] - - --- | Put the labelled blocks that we will be annotating with SRTs into --- dependency order. This is so that we can process them one at a --- time, resolving references to earlier blocks to point to their --- SRTs. CAFs themselves are not included here; see getCAFs below. -depAnalSRTs - :: CAFEnv - -> [CmmDecl] - -> [SCC (Label, CAFLabel, Set CAFLabel)] -depAnalSRTs cafEnv decls = - srtTrace "depAnalSRTs" (ppr graph) graph - where - labelledBlocks = concatMap getLabelledBlocks decls - labelToBlock = Map.fromList (map swap labelledBlocks) - graph = stronglyConnCompFromEdgedVerticesOrd - [ let cafs' = Set.delete lbl cafs in - DigraphNode (l,lbl,cafs') l - (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs')) - | (l, lbl) <- labelledBlocks - , Just cafs <- [mapLookup l cafEnv] ] - - --- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF. --- These are treated differently from other labelled blocks: --- - we never shortcut a reference to a CAF to the contents of its --- SRT, since the point of SRTs is to keep CAFs alive. --- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. --- instead we generate their SRTs after everything else. -getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)] -getCAFs cafEnv decls = - [ (g_entry g, mkCAFLabel topLbl, cafs) - | CmmProc top_info topLbl _ g <- decls - , Just info <- [mapLookup (g_entry g) (info_tbls top_info)] - , let rep = cit_rep info - , isStaticRep rep && isThunkRep rep - , Just cafs <- [mapLookup (g_entry g) cafEnv] - ] - - --- | Get the list of blocks that correspond to the entry points for --- FUN_STATIC closures. These are the blocks for which if we have an --- SRT we can merge it with the static closure. [FUN] -getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)] -getStaticFuns decls = - [ (g_entry g, lbl) - | CmmProc top_info _ _ g <- decls - , Just info <- [mapLookup (g_entry g) (info_tbls top_info)] - , Just (id, _) <- [cit_clo info] - , let rep = cit_rep info - , isStaticRep rep && isFunRep rep - , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id) - ] - - --- | Maps labels from 'cafAnal' to the final CLabel that will appear --- in the SRT. --- - closures with singleton SRTs resolve to their single entry --- - closures with larger SRTs map to the label for that SRT --- - CAFs must not map to anything! --- - if a labels maps to Nothing, we found that this label's SRT --- is empty, so we don't need to refer to it from other SRTs. -type SRTMap = Map CAFLabel (Maybe SRTEntry) - --- | resolve a CAFLabel to its SRTEntry using the SRTMap -resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry -resolveCAF srtMap lbl@(CAFLabel l) = - Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap - - --- | Attach SRTs to all info tables in the CmmDecls, and add SRT --- declarations to the ModuleSRTInfo. --- -doSRTs - :: DynFlags - -> ModuleSRTInfo - -> [(CAFEnv, [CmmDecl])] - -> IO (ModuleSRTInfo, [CmmDecl]) - -doSRTs dflags moduleSRTInfo tops = do - us <- mkSplitUniqSupply 'u' - - -- Ignore the original grouping of decls, and combine all the - -- CAFEnvs into a single CAFEnv. - let (cafEnvs, declss) = unzip tops - cafEnv = mapUnions cafEnvs - decls = concat declss - staticFuns = mapFromList (getStaticFuns decls) - - -- Put the decls in dependency order. Why? So that we can implement - -- [Inline] and [Filter]. If we need to refer to an SRT that has - -- a single entry, we use the entry itself, which means that we - -- don't need to generate the singleton SRT in the first place. But - -- to do this we need to process blocks before things that depend on - -- them. - let - sccs = depAnalSRTs cafEnv decls - cafsWithSRTs = getCAFs cafEnv decls - - -- On each strongly-connected group of decls, construct the SRT - -- closures and the SRT fields for info tables. - let result :: - [ ( [CmmDecl] -- generated SRTs - , [(Label, CLabel)] -- SRT fields for info tables - , [(Label, [SRTEntry])] -- SRTs to attach to static functions - ) ] - ((result, _srtMap), moduleSRTInfo') = - initUs_ us $ - flip runStateT moduleSRTInfo $ - flip runStateT Map.empty $ do - nonCAFs <- mapM (doSCC dflags staticFuns) sccs - cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> - oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs - return (nonCAFs ++ cAFs) - - (declss, pairs, funSRTs) = unzip3 result - - -- Next, update the info tables with the SRTs - let - srtFieldMap = mapFromList (concat pairs) - funSRTMap = mapFromList (concat funSRTs) - decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls - - return (moduleSRTInfo', concat declss ++ decls') - - --- | Build the SRT for a strongly-connected component of blocks -doSCC - :: DynFlags - -> LabelMap CLabel -- which blocks are static function entry points - -> SCC (Label, CAFLabel, Set CAFLabel) - -> StateT SRTMap - (StateT ModuleSRTInfo UniqSM) - ( [CmmDecl] -- generated SRTs - , [(Label, CLabel)] -- SRT fields for info tables - , [(Label, [SRTEntry])] -- SRTs to attach to static functions - ) - -doSCC dflags staticFuns (AcyclicSCC (l, cafLbl, cafs)) = - oneSRT dflags staticFuns [l] [cafLbl] False cafs - -doSCC dflags staticFuns (CyclicSCC nodes) = do - -- build a single SRT for the whole cycle, see Note [recursive SRTs] - let (blockids, lbls, cafsets) = unzip3 nodes - cafs = Set.unions cafsets - oneSRT dflags staticFuns blockids lbls False cafs - - -{- Note [recursive SRTs] - -If the dependency analyser has found us a recursive group of -declarations, then we build a single SRT for the whole group, on the -grounds that everything in the group is reachable from everything -else, so we lose nothing by having a single SRT. - -However, there are a couple of wrinkles to be aware of. - -* The Set CAFLabel for this SRT will contain labels in the group -itself. The SRTMap will therefore not contain entries for these labels -yet, so we can't turn them into SRTEntries using resolveCAF. BUT we -can just remove recursive references from the Set CAFLabel before -generating the SRT - the SRT will still contain all the CAFLabels that -we need to refer to from this group's SRT. - -* That is, EXCEPT for static function closures. For the same reason -described in Note [Invalid optimisation: shortcutting], we cannot omit -references to static function closures. - - But, since we will merge the SRT with one of the static function - closures (see [FUN]), we can omit references to *that* static - function closure from the SRT. --} - --- | Build an SRT for a set of blocks -oneSRT - :: DynFlags - -> LabelMap CLabel -- which blocks are static function entry points - -> [Label] -- blocks in this set - -> [CAFLabel] -- labels for those blocks - -> Bool -- True <=> this SRT is for a CAF - -> Set CAFLabel -- SRT for this set - -> StateT SRTMap - (StateT ModuleSRTInfo UniqSM) - ( [CmmDecl] -- SRT objects we built - , [(Label, CLabel)] -- SRT fields for these blocks' itbls - , [(Label, [SRTEntry])] -- SRTs to attach to static functions - ) - -oneSRT dflags staticFuns blockids lbls isCAF cafs = do - srtMap <- get - topSRT <- lift get - let - -- Can we merge this SRT with a FUN_STATIC closure? - (maybeFunClosure, otherFunLabels) = - case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of - [] -> (Nothing, []) - ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs) - - -- Remove recursive references from the SRT, except for (all but - -- one of the) static functions. See Note [recursive SRTs]. - nonRec = cafs `Set.difference` - (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels) - - -- First resolve all the CAFLabels to SRTEntries - -- Implements the [Inline] optimisation. - resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec) - - -- The set of all SRTEntries in SRTs that we refer to from here. - allBelow = - Set.unions [ lbls | caf <- resolved - , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ] - - -- Remove SRTEntries that are also in an SRT that we refer to. - -- Implements the [Filter] optimisation. - filtered = Set.difference (Set.fromList resolved) allBelow - - srtTrace "oneSRT:" - (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return () - - let - isStaticFun = isJust maybeFunClosure - - -- For a label without a closure (e.g. a continuation), we must - -- update the SRTMap for the label to point to a closure. It's - -- important that we don't do this for static functions or CAFs, - -- see Note [Invalid optimisation: shortcutting]. - updateSRTMap srtEntry = - when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do - let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls] - put (Map.union newSRTMap srtMap) - - this_mod = thisModule topSRT - - case Set.toList filtered of - [] -> do - srtTrace "oneSRT: empty" (ppr lbls) $ return () - updateSRTMap Nothing - return ([], [], []) - - -- [Inline] - when we have only one entry there is no need to - -- build an SRT object at all, instead we put the singleton SRT - -- entry in the info table. - [one@(SRTEntry lbl)] - | -- Info tables refer to SRTs by offset (as noted in the section - -- "Referring to an SRT from the info table" of Note [SRTs]). However, - -- when dynamic linking is used we cannot guarantee that the offset - -- between the SRT and the info table will fit in the offset field. - -- Consequently we build a singleton SRT in in this case. - not (labelDynamic dflags this_mod lbl) - - -- MachO relocations can't express offsets between compilation units at - -- all, so we are always forced to build a singleton SRT in this case. - && (not (osMachOTarget $ platformOS $ targetPlatform dflags) - || isLocalCLabel this_mod lbl) -> do - - -- If we have a static function closure, then it becomes the - -- SRT object, and everything else points to it. (the only way - -- we could have multiple labels here is if this is a - -- recursive group, see Note [recursive SRTs]) - case maybeFunClosure of - Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, []) - where - withLabels = - [ (b, if b == staticFunBlock then lbl else staticFunLbl) - | b <- blockids ] - Nothing -> do - updateSRTMap (Just one) - return ([], map (,lbl) blockids, []) - - cafList -> - -- Check whether an SRT with the same entries has been emitted already. - -- Implements the [Common] optimisation. - case Map.lookup filtered (dedupSRTs topSRT) of - Just srtEntry@(SRTEntry srtLbl) -> do - srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return () - updateSRTMap (Just srtEntry) - return ([], map (,srtLbl) blockids, []) - Nothing -> do - -- No duplicates: we have to build a new SRT object - srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return () - (decls, funSRTs, srtEntry) <- - case maybeFunClosure of - Just (fun,block) -> - return ( [], [(block, cafList)], SRTEntry fun ) - Nothing -> do - (decls, entry) <- lift . lift $ buildSRTChain dflags cafList - return (decls, [], entry) - updateSRTMap (Just srtEntry) - let allBelowThis = Set.union allBelow filtered - oldFlatSRTs = flatSRTs topSRT - newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs - newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) - lift (put (topSRT { dedupSRTs = newDedupSRTs - , flatSRTs = newFlatSRTs })) - let SRTEntry lbl = srtEntry - return (decls, map (,lbl) blockids, funSRTs) - - --- | build a static SRT object (or a chain of objects) from a list of --- SRTEntries. -buildSRTChain - :: DynFlags - -> [SRTEntry] - -> UniqSM - ( [CmmDecl] -- The SRT object(s) - , SRTEntry -- label to use in the info table - ) -buildSRTChain _ [] = panic "buildSRT: empty" -buildSRTChain dflags cafSet = - case splitAt mAX_SRT_SIZE cafSet of - (these, []) -> do - (decl,lbl) <- buildSRT dflags these - return ([decl], lbl) - (these,those) -> do - (rest, rest_lbl) <- buildSRTChain dflags (head these : those) - (decl,lbl) <- buildSRT dflags (rest_lbl : tail these) - return (decl:rest, lbl) - where - mAX_SRT_SIZE = 16 - - -buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry) -buildSRT dflags refs = do - id <- getUniqueM - let - lbl = mkSRTLabel id - srt_n_info = mkSRTInfoLabel (length refs) - fields = - mkStaticClosure dflags srt_n_info dontCareCCS - [ CmmLabel lbl | SRTEntry lbl <- refs ] - [] -- no padding - [mkIntCLit dflags 0] -- link field - [] -- no saved info - return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) - - --- | Update info tables with references to their SRTs. Also generate --- static closures, splicing in SRT fields as necessary. -updInfoSRTs - :: DynFlags - -> LabelMap CLabel -- SRT labels for each block - -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures - -> CmmDecl - -> [CmmDecl] - -updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) - | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] - | otherwise = [ proc ] - where - proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g - newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info) - updInfoTbl l info_tbl - | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf - | otherwise = info_tbl { cit_srt = mapLookup l srt_env } - - -- Generate static closures [FUN]. Note that this also generates - -- static closures for thunks (CAFs), because it's easier to treat - -- them uniformly in the code generator. - maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl) - maybeStaticClosure - | Just info_tbl@CmmInfoTable{..} <- - mapLookup (g_entry g) (info_tbls top_info) - , Just (id, ccs) <- cit_clo - , isStaticRep cit_rep = - let - (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of - Nothing -> - -- if we don't add SRT entries to this closure, then we - -- want to set the srt field in its info table as usual - (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, []) - Just srtEntries -> srtTrace "maybeStaticFun" (ppr res) - (info_tbl { cit_rep = new_rep }, res) - where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] - fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id) - srtEntries - new_rep = case cit_rep of - HeapRep sta ptrs nptrs ty -> - HeapRep sta (ptrs + length srtEntries) nptrs ty - _other -> panic "maybeStaticFun" - lbl = mkLocalClosureLabel (idName id) (idCafInfo id) - in - Just (newInfo, mkDataLits (Section Data lbl) lbl fields) - | otherwise = Nothing - -updInfoSRTs _ _ _ t = [t] - - -srtTrace :: String -> SDoc -> b -> b --- srtTrace = pprTrace -srtTrace _ _ b = b diff --git a/cmm/CmmCallConv.hs b/cmm/CmmCallConv.hs deleted file mode 100644 --- a/cmm/CmmCallConv.hs +++ /dev/null @@ -1,217 +0,0 @@ -module CmmCallConv ( - ParamLocation(..), - assignArgumentsPos, - assignStack, - realArgRegsCover -) where - -import GhcPrelude - -import CmmExpr -import SMRep -import Cmm (Convention(..)) -import PprCmm () -- For Outputable instances - -import DynFlags -import GHC.Platform -import Outputable - --- Calculate the 'GlobalReg' or stack locations for function call --- parameters as used by the Cmm calling convention. - -data ParamLocation - = RegisterParam GlobalReg - | StackParam ByteOff - -instance Outputable ParamLocation where - ppr (RegisterParam g) = ppr g - ppr (StackParam p) = ppr p - --- | --- Given a list of arguments, and a function that tells their types, --- return a list showing where each argument is passed --- -assignArgumentsPos :: DynFlags - -> ByteOff -- stack offset to start with - -> Convention - -> (a -> CmmType) -- how to get a type from an arg - -> [a] -- args - -> ( - ByteOff -- bytes of stack args - , [(a, ParamLocation)] -- args and locations - ) - -assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) - where - regs = case (reps, conv) of - (_, NativeNodeCall) -> getRegsWithNode dflags - (_, NativeDirectCall) -> getRegsWithoutNode dflags - ([_], NativeReturn) -> allRegs dflags - (_, NativeReturn) -> getRegsWithNode dflags - -- GC calling convention *must* put values in registers - (_, GC) -> allRegs dflags - (_, Slow) -> nodeOnly - -- The calling conventions first assign arguments to registers, - -- then switch to the stack when we first run out of registers - -- (even if there are still available registers for args of a - -- different type). When returning an unboxed tuple, we also - -- separate the stack arguments by pointerhood. - (reg_assts, stk_args) = assign_regs [] reps regs - (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args - assignments = reg_assts ++ stk_assts - - assign_regs assts [] _ = (assts, []) - assign_regs assts (r:rs) regs | isVecType ty = vec - | isFloatType ty = float - | otherwise = int - where vec = case (w, regs) of - (W128, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) - (W256, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) - (W512, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) - _ -> (assts, (r:rs)) - float = case (w, regs) of - (W32, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) - (W32, (vs, f:fs, ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam f, (vs, fs, ds, ls, ss)) - (W64, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) - (W64, (vs, fs, d:ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss)) - _ -> (assts, (r:rs)) - int = case (w, regs) of - (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags) - -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) - (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags) - -> k (RegisterParam l, (vs, fs, ds, ls, ss)) - _ -> (assts, (r:rs)) - k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' - ty = arg_ty r - w = typeWidth ty - gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr - passFloatInXmm = passFloatArgsInXmm dflags - -passFloatArgsInXmm :: DynFlags -> Bool -passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> True - ArchX86 -> False - _ -> False - --- We used to spill vector registers to the stack since the LLVM backend didn't --- support vector registers in its calling convention. However, this has now --- been fixed. This function remains only as a convenient way to re-enable --- spilling when debugging code generation. -passVectorInReg :: Width -> DynFlags -> Bool -passVectorInReg _ _ = True - -assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] - -> ( - ByteOff -- bytes of stack args - , [(a, ParamLocation)] -- args and locations - ) -assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args) - where - assign_stk offset assts [] = (offset, assts) - assign_stk offset assts (r:rs) - = assign_stk off' ((r, StackParam off') : assts) rs - where w = typeWidth (arg_ty r) - off' = offset + size - -- Stack arguments always take a whole number of words, we never - -- pack them unlike constructor fields. - size = roundUpToWords dflags (widthInBytes w) - ------------------------------------------------------------------------------ --- Local information about the registers available - -type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. - , [GlobalReg] -- floats - , [GlobalReg] -- doubles - , [GlobalReg] -- longs (int64 and word64) - , [Int] -- XMM (floats and doubles) - ) - --- Vanilla registers can contain pointers, Ints, Chars. --- Floats and doubles have separate register supplies. --- --- We take these register supplies from the *real* registers, i.e. those --- that are guaranteed to map to machine registers. - -getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs -getRegsWithoutNode dflags = - ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) - , realFloatRegs dflags - , realDoubleRegs dflags - , realLongRegs dflags - , realXmmRegNos dflags) - --- getRegsWithNode uses R1/node even if it isn't a register -getRegsWithNode dflags = - ( if null (realVanillaRegs dflags) - then [VanillaReg 1] - else realVanillaRegs dflags - , realFloatRegs dflags - , realDoubleRegs dflags - , realLongRegs dflags - , realXmmRegNos dflags) - -allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] -allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] -allXmmRegs :: DynFlags -> [Int] - -allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) -allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) -allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) -allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) -allXmmRegs dflags = regList (mAX_XMM_REG dflags) - -realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] -realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] -realXmmRegNos :: DynFlags -> [Int] - -realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags) -realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) -realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) -realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) - -realXmmRegNos dflags - | isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags) - | otherwise = [] - -regList :: Int -> [Int] -regList n = [1 .. n] - -allRegs :: DynFlags -> AvailRegs -allRegs dflags = (allVanillaRegs dflags, - allFloatRegs dflags, - allDoubleRegs dflags, - allLongRegs dflags, - allXmmRegs dflags) - -nodeOnly :: AvailRegs -nodeOnly = ([VanillaReg 1], [], [], [], []) - --- This returns the set of global registers that *cover* the machine registers --- used for argument passing. On platforms where registers can overlap---right --- now just x86-64, where Float and Double registers overlap---passing this set --- of registers is guaranteed to preserve the contents of all live registers. We --- only use this functionality in hand-written C-- code in the RTS. -realArgRegsCover :: DynFlags -> [GlobalReg] -realArgRegsCover dflags - | passFloatArgsInXmm dflags - = map ($VGcPtr) (realVanillaRegs dflags) ++ - realLongRegs dflags ++ - realDoubleRegs dflags -- we only need to save the low Double part of XMM registers. - -- Moreover, the NCG can't load/store full XMM - -- registers for now... - - | otherwise - = map ($VGcPtr) (realVanillaRegs dflags) ++ - realFloatRegs dflags ++ - realDoubleRegs dflags ++ - realLongRegs dflags - -- we don't save XMM registers if they are not used for parameter passing diff --git a/cmm/CmmCommonBlockElim.hs b/cmm/CmmCommonBlockElim.hs deleted file mode 100644 --- a/cmm/CmmCommonBlockElim.hs +++ /dev/null @@ -1,320 +0,0 @@ -{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-} - -module CmmCommonBlockElim - ( elimCommonBlocks - ) -where - - -import GhcPrelude hiding (iterate, succ, unzip, zip) - -import BlockId -import Cmm -import CmmUtils -import CmmSwitch (eqSwitchTargetWith) -import CmmContFlowOpt - -import Hoopl.Block -import Hoopl.Graph -import Hoopl.Label -import Hoopl.Collections -import Data.Bits -import Data.Maybe (mapMaybe) -import qualified Data.List as List -import Data.Word -import qualified Data.Map as M -import Outputable -import qualified TrieMap as TM -import UniqFM -import Unique -import Control.Arrow (first, second) - --- ----------------------------------------------------------------------------- --- Eliminate common blocks - --- If two blocks are identical except for the label on the first node, --- then we can eliminate one of the blocks. To ensure that the semantics --- of the program are preserved, we have to rewrite each predecessor of the --- eliminated block to proceed with the block we keep. - --- The algorithm iterates over the blocks in the graph, --- checking whether it has seen another block that is equal modulo labels. --- If so, then it adds an entry in a map indicating that the new block --- is made redundant by the old block. --- Otherwise, it is added to the useful blocks. - --- To avoid comparing every block with every other block repeatedly, we group --- them by --- * a hash of the block, ignoring labels (explained below) --- * the list of outgoing labels --- The hash is invariant under relabeling, so we only ever compare within --- the same group of blocks. --- --- The list of outgoing labels is updated as we merge blocks (that is why they --- are not included in the hash, which we want to calculate only once). --- --- All in all, two blocks should never be compared if they have different --- hashes, and at most once otherwise. Previously, we were slower, and people --- rightfully complained: #10397 - --- TODO: Use optimization fuel -elimCommonBlocks :: CmmGraph -> CmmGraph -elimCommonBlocks g = replaceLabels env $ copyTicks env g - where - env = iterate mapEmpty blocks_with_key - -- The order of blocks doesn't matter here. While we could use - -- revPostorder which drops unreachable blocks this is done in - -- ContFlowOpt already which runs before this pass. So we use - -- toBlockList since it is faster. - groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]] - blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] - --- Invariant: The blocks in the list are pairwise distinct --- (so avoid comparing them again) -type DistinctBlocks = [CmmBlock] -type Key = [Label] -type Subst = LabelMap BlockId - --- The outer list groups by hash. We retain this grouping throughout. -iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst -iterate subst blocks - | mapNull new_substs = subst - | otherwise = iterate subst' updated_blocks - where - grouped_blocks :: [[(Key, [DistinctBlocks])]] - grouped_blocks = map groupByLabel blocks - - merged_blocks :: [[(Key, DistinctBlocks)]] - (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks - where - go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db)) - where - (new_subst2, db) = mergeBlockList subst dbs - - subst' = subst `mapUnion` new_substs - updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks - --- Combine two lists of blocks. --- While they are internally distinct they can still share common blocks. -mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks) -mergeBlocks subst existing new = go new - where - go [] = (mapEmpty, existing) - go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of - -- This block is a duplicate. Drop it, and add it to the substitution - Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs - -- This block is not a duplicate, keep it. - Nothing -> second (b:) $ go bs - -mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks) -mergeBlockList _ [] = pprPanic "mergeBlockList" empty -mergeBlockList subst (b:bs) = go mapEmpty b bs - where - go !new_subst1 b [] = (new_subst1, b) - go !new_subst1 b1 (b2:bs) = go new_subst b bs - where - (new_subst2, b) = mergeBlocks subst b1 b2 - new_subst = new_subst1 `mapUnion` new_subst2 - - --- ----------------------------------------------------------------------------- --- Hashing and equality on blocks - --- Below here is mostly boilerplate: hashing blocks ignoring labels, --- and comparing blocks modulo a label mapping. - --- To speed up comparisons, we hash each basic block modulo jump labels. --- The hashing is a bit arbitrary (the numbers are completely arbitrary), --- but it should be fast and good enough. - --- We want to get as many small buckets as possible, as comparing blocks is --- expensive. So include as much as possible in the hash. Ideally everything --- that is compared with (==) in eqBlockBodyWith. - -type HashCode = Int - -hash_block :: CmmBlock -> HashCode -hash_block block = - fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) - -- UniqFM doesn't like negative Ints - where hash_fst _ h = h - hash_mid m h = hash_node m + h `shiftL` 1 - hash_lst m h = hash_node m + h `shiftL` 1 - - hash_node :: CmmNode O x -> Word32 - hash_node n | dont_care n = 0 -- don't care - hash_node (CmmAssign r e) = hash_reg r + hash_e e - hash_node (CmmStore e e') = hash_e e + hash_e e' - hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as - hash_node (CmmBranch _) = 23 -- NB. ignore the label - hash_node (CmmCondBranch p _ _ _) = hash_e p - hash_node (CmmCall e _ _ _ _ _) = hash_e e - hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t - hash_node (CmmSwitch e _) = hash_e e - hash_node _ = error "hash_node: unknown Cmm node!" - - hash_reg :: CmmReg -> Word32 - hash_reg (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397 - hash_reg (CmmGlobal _) = 19 - - hash_e :: CmmExpr -> Word32 - hash_e (CmmLit l) = hash_lit l - hash_e (CmmLoad e _) = 67 + hash_e e - hash_e (CmmReg r) = hash_reg r - hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check - hash_e (CmmRegOff r i) = hash_reg r + cvt i - hash_e (CmmStackSlot _ _) = 13 - - hash_lit :: CmmLit -> Word32 - hash_lit (CmmInt i _) = fromInteger i - hash_lit (CmmFloat r _) = truncate r - hash_lit (CmmVec ls) = hash_list hash_lit ls - hash_lit (CmmLabel _) = 119 -- ugh - hash_lit (CmmLabelOff _ i) = cvt $ 199 + i - hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i - hash_lit (CmmBlock _) = 191 -- ugh - hash_lit (CmmHighStackMark) = cvt 313 - - hash_tgt (ForeignTarget e _) = hash_e e - hash_tgt (PrimTarget _) = 31 -- lots of these - - hash_list f = foldl' (\z x -> f x + z) (0::Word32) - - cvt = fromInteger . toInteger - - hash_unique :: Uniquable a => a -> Word32 - hash_unique = cvt . getKey . getUnique - --- | Ignore these node types for equality -dont_care :: CmmNode O x -> Bool -dont_care CmmComment {} = True -dont_care CmmTick {} = True -dont_care CmmUnwind {} = True -dont_care _other = False - --- Utilities: equality and substitution on the graph. - --- Given a map ``subst'' from BlockID -> BlockID, we define equality. -eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool -eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' -lookupBid :: LabelMap BlockId -> BlockId -> BlockId -lookupBid subst bid = case mapLookup bid subst of - Just bid -> lookupBid subst bid - Nothing -> bid - --- Middle nodes and expressions can contain BlockIds, in particular in --- CmmStackSlot and CmmBlock, so we have to use a special equality for --- these. --- -eqMiddleWith :: (BlockId -> BlockId -> Bool) - -> CmmNode O O -> CmmNode O O -> Bool -eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2) - = r1 == r2 && eqExprWith eqBid e1 e2 -eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2) - = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 -eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) - (CmmUnsafeForeignCall t2 r2 a2) - = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2 -eqMiddleWith _ _ _ = False - -eqExprWith :: (BlockId -> BlockId -> Bool) - -> CmmExpr -> CmmExpr -> Bool -eqExprWith eqBid = eq - where - CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2 - CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2 - CmmReg r1 `eq` CmmReg r2 = r1==r2 - CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2 - CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 - _e1 `eq` _e2 = False - - xs `eqs` ys = eqListWith eq xs ys - - eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 - eqLit l1 l2 = l1 == l2 - - eqArea Old Old = True - eqArea (Young id1) (Young id2) = eqBid id1 id2 - eqArea _ _ = False - --- Equality on the body of a block, modulo a function mapping block --- IDs to block IDs. -eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool -eqBlockBodyWith eqBid block block' - {- - | equal = pprTrace "equal" (vcat [ppr block, ppr block']) True - | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False - -} - = equal - where (_,m,l) = blockSplit block - nodes = filter (not . dont_care) (blockToList m) - (_,m',l') = blockSplit block' - nodes' = filter (not . dont_care) (blockToList m') - - equal = eqListWith (eqMiddleWith eqBid) nodes nodes' && - eqLastWith eqBid l l' - - -eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool -eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 -eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) = - c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2 -eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) = - t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 -eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) = - e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2 -eqLastWith _ _ _ = False - -eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool -eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' -eqMaybeWith _ Nothing Nothing = True -eqMaybeWith _ _ _ = False - -eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool -eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs -eqListWith _ [] [] = True -eqListWith _ _ _ = False - --- | Given a block map, ensure that all "target" blocks are covered by --- the same ticks as the respective "source" blocks. This not only --- means copying ticks, but also adjusting tick scopes where --- necessary. -copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph -copyTicks env g - | mapNull env = g - | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap - where -- Reverse block merge map - blockMap = toBlockMap g - revEnv = mapFoldlWithKey insertRev M.empty env - insertRev m k x = M.insertWith (const (k:)) x [k] m - -- Copy ticks and scopes into the given block - copyTo block = case M.lookup (entryLabel block) revEnv of - Nothing -> block - Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls - copy from to = - let ticks = blockTicks from - CmmEntry _ scp0 = firstNode from - (CmmEntry lbl scp1, code) = blockSplitHead to - in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead` - foldr blockCons code (map CmmTick ticks) - --- Group by [Label] --- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap. -groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])] -groupByLabel = - go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks])) - where - go !m [] = TM.foldTM (:) m [] - go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries - where --k' = map (getKey . getUnique) k - adjust Nothing = Just (k,[v]) - adjust (Just (_,vs)) = Just (k,v:vs) - -groupByInt :: (a -> Int) -> [a] -> [[a]] -groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs - -- See Note [Unique Determinism and code generation] - where - go m x = alterUFM addEntry m (f x) - where - addEntry xs = Just $! maybe [x] (x:) xs diff --git a/cmm/CmmContFlowOpt.hs b/cmm/CmmContFlowOpt.hs deleted file mode 100644 --- a/cmm/CmmContFlowOpt.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -module CmmContFlowOpt - ( cmmCfgOpts - , cmmCfgOptsProc - , removeUnreachableBlocksProc - , replaceLabels - ) -where - -import GhcPrelude hiding (succ, unzip, zip) - -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Graph -import Hoopl.Label -import BlockId -import Cmm -import CmmUtils -import CmmSwitch (mapSwitchTargets, switchTargetsToList) -import Maybes -import Panic -import Util - -import Control.Monad - - --- Note [What is shortcutting] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider this Cmm code: --- --- L1: ... --- goto L2; --- L2: goto L3; --- L3: ... --- --- Here L2 is an empty block and contains only an unconditional branch --- to L3. In this situation any block that jumps to L2 can jump --- directly to L3: --- --- L1: ... --- goto L3; --- L2: goto L3; --- L3: ... --- --- In this situation we say that we shortcut L2 to L3. One of --- consequences of shortcutting is that some blocks of code may become --- unreachable (in the example above this is true for L2). - - --- Note [Control-flow optimisations] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This optimisation does three things: --- --- - If a block finishes in an unconditional branch to another block --- and that is the only jump to that block we concatenate the --- destination block at the end of the current one. --- --- - If a block finishes in a call whose continuation block is a --- goto, then we can shortcut the destination, making the --- continuation block the destination of the goto - but see Note --- [Shortcut call returns]. --- --- - For any block that is not a call we try to shortcut the --- destination(s). Additionally, if a block ends with a --- conditional branch we try to invert the condition. --- --- Blocks are processed using postorder DFS traversal. A side effect --- of determining traversal order with a graph search is elimination --- of any blocks that are unreachable. --- --- Transformations are improved by working from the end of the graph --- towards the beginning, because we may be able to perform many --- shortcuts in one go. - - --- Note [Shortcut call returns] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We are going to maintain the "current" graph (LabelMap CmmBlock) as --- we go, and also a mapping from BlockId to BlockId, representing --- continuation labels that we have renamed. This latter mapping is --- important because we might shortcut a CmmCall continuation. For --- example: --- --- Sp[0] = L --- call g returns to L --- L: goto M --- M: ... --- --- So when we shortcut the L block, we need to replace not only --- the continuation of the call, but also references to L in the --- code (e.g. the assignment Sp[0] = L): --- --- Sp[0] = M --- call g returns to M --- M: ... --- --- So we keep track of which labels we have renamed and apply the mapping --- at the end with replaceLabels. - - --- Note [Shortcut call returns and proc-points] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider this code that you might get from a recursive --- let-no-escape: --- --- goto L1 --- L1: --- if (Hp > HpLim) then L2 else L3 --- L2: --- call stg_gc_noregs returns to L4 --- L4: --- goto L1 --- L3: --- ... --- goto L1 --- --- Then the control-flow optimiser shortcuts L4. But that turns L1 --- into the call-return proc point, and every iteration of the loop --- has to shuffle variables to and from the stack. So we must *not* --- shortcut L4. --- --- Moreover not shortcutting call returns is probably fine. If L4 can --- concat with its branch target then it will still do so. And we --- save some compile time because we don't have to traverse all the --- code in replaceLabels. --- --- However, we probably do want to do this if we are splitting proc --- points, because L1 will be a proc-point anyway, so merging it with --- L4 reduces the number of proc points. Unfortunately recursive --- let-no-escapes won't generate very good code with proc-point --- splitting on - we should probably compile them to explicitly use --- the native calling convention instead. - -cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph -cmmCfgOpts split g = fst (blockConcat split g) - -cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl -cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' - where (g', env) = blockConcat split g - info' = info{ info_tbls = new_info_tbls } - new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) - - -- If we changed any labels, then we have to update the info tables - -- too, except for the top-level info table because that might be - -- referred to by other procs. - upd_info (k,info) - | Just k' <- mapLookup k env - = (k', if k' == g_entry g' - then info - else info{ cit_lbl = infoTblLbl k' }) - | otherwise - = (k,info) -cmmCfgOptsProc _ top = top - - -blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId) -blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } - = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map') - where - -- We might be able to shortcut the entry BlockId itself. - -- Remember to update the shortcut_map, since we also have to - -- update the info_tbls mapping now. - (new_entry, shortcut_map') - | Just entry_blk <- mapLookup entry_id new_blocks - , Just dest <- canShortcut entry_blk - = (dest, mapInsert entry_id dest shortcut_map) - | otherwise - = (entry_id, shortcut_map) - - -- blocks are sorted in reverse postorder, but we want to go from the exit - -- towards beginning, so we use foldr below. - blocks = revPostorder g - blockmap = foldl' (flip addBlock) emptyBody blocks - - -- Accumulator contains three components: - -- * map of blocks in a graph - -- * map of shortcut labels. See Note [Shortcut call returns] - -- * map containing number of predecessors for each block. We discard - -- it after we process all blocks. - (new_blocks, shortcut_map, _) = - foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks - - -- Map of predecessors for initial graph. We increase number of - -- predecessors for entry block by one to denote that it is - -- target of a jump, even if no block in the current graph jumps - -- to it. - initialBackEdges = incPreds entry_id (predMap blocks) - - maybe_concat :: CmmBlock - -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) - -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int) - maybe_concat block (!blocks, !shortcut_map, !backEdges) - -- If: - -- (1) current block ends with unconditional branch to b' and - -- (2) it has exactly one predecessor (namely, current block) - -- - -- Then: - -- (1) append b' block at the end of current block - -- (2) remove b' from the map of blocks - -- (3) remove information about b' from predecessors map - -- - -- Since we know that the block has only one predecessor we call - -- mapDelete directly instead of calling decPreds. - -- - -- Note that we always maintain an up-to-date list of predecessors, so - -- we can ignore the contents of shortcut_map - | CmmBranch b' <- last - , hasOnePredecessor b' - , Just blk' <- mapLookup b' blocks - = let bid' = entryLabel blk' - in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks - , shortcut_map - , mapDelete b' backEdges ) - - -- If: - -- (1) we are splitting proc points (see Note - -- [Shortcut call returns and proc-points]) and - -- (2) current block is a CmmCall or CmmForeignCall with - -- continuation b' and - -- (3) we can shortcut that continuation to dest - -- Then: - -- (1) we change continuation to point to b' - -- (2) create mapping from b' to dest - -- (3) increase number of predecessors of dest by 1 - -- (4) decrease number of predecessors of b' by 1 - -- - -- Later we will use replaceLabels to substitute all occurrences of b' - -- with dest. - | splitting_procs - , Just b' <- callContinuation_maybe last - , Just blk' <- mapLookup b' blocks - , Just dest <- canShortcut blk' - = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks - , mapInsert b' dest shortcut_map - , decPreds b' $ incPreds dest backEdges ) - - -- If: - -- (1) a block does not end with a call - -- Then: - -- (1) if it ends with a conditional attempt to invert the - -- conditional - -- (2) attempt to shortcut all destination blocks - -- (3) if new successors of a block are different from the old ones - -- update the of predecessors accordingly - -- - -- A special case of this is a situation when a block ends with an - -- unconditional jump to a block that can be shortcut. - | Nothing <- callContinuation_maybe last - = let oldSuccs = successors last - newSuccs = successors rewrite_last - in ( mapInsert bid (blockJoinTail head rewrite_last) blocks - , shortcut_map - , if oldSuccs == newSuccs - then backEdges - else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs ) - - -- Otherwise don't do anything - | otherwise - = ( blocks, shortcut_map, backEdges ) - where - (head, last) = blockSplitTail block - bid = entryLabel block - - -- Changes continuation of a call to a specified label - update_cont dest = - case last of - CmmCall{} -> last { cml_cont = Just dest } - CmmForeignCall{} -> last { succ = dest } - _ -> panic "Can't shortcut continuation." - - -- Attempts to shortcut successors of last node - shortcut_last = mapSuccessors shortcut last - where - shortcut l = - case mapLookup l blocks of - Just b | Just dest <- canShortcut b -> dest - _otherwise -> l - - rewrite_last - -- Sometimes we can get rid of the conditional completely. - | CmmCondBranch _cond t f _l <- shortcut_last - , t == f - = CmmBranch t - - -- See Note [Invert Cmm conditionals] - | CmmCondBranch cond t f l <- shortcut_last - , hasOnePredecessor t -- inverting will make t a fallthrough - , likelyTrue l || (numPreds f > 1) - , Just cond' <- maybeInvertCmmExpr cond - = CmmCondBranch cond' f t (invertLikeliness l) - - -- If all jump destinations of a switch go to the - -- same target eliminate the switch. - | CmmSwitch _expr targets <- shortcut_last - , (t:ts) <- switchTargetsToList targets - , all (== t) ts - = CmmBranch t - - | otherwise - = shortcut_last - - likelyTrue (Just True) = True - likelyTrue _ = False - - invertLikeliness :: Maybe Bool -> Maybe Bool - invertLikeliness = fmap not - - -- Number of predecessors for a block - numPreds bid = mapLookup bid backEdges `orElse` 0 - - hasOnePredecessor b = numPreds b == 1 - -{- - Note [Invert Cmm conditionals] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The native code generator always produces jumps to the true branch. - Falling through to the false branch is however faster. So we try to - arrange for that to happen. - This means we invert the condition if: - * The likely path will become a fallthrough. - * We can't guarantee a fallthrough for the false branch but for the - true branch. - - In some cases it's faster to avoid inverting when the false branch is likely. - However determining when that is the case is neither easy nor cheap so for - now we always invert as this produces smaller binaries and code that is - equally fast on average. (On an i7-6700K) - - TODO: - There is also the edge case when both branches have multiple predecessors. - In this case we could assume that we will end up with a jump for BOTH - branches. In this case it might be best to put the likely path in the true - branch especially if there are large numbers of predecessors as this saves - us the jump thats not taken. However I haven't tested this and as of early - 2018 we almost never generate cmm where this would apply. --} - --- Functions for incrementing and decrementing number of predecessors. If --- decrementing would set the predecessor count to 0, we remove entry from the --- map. --- Invariant: if a block has no predecessors it should be dropped from the --- graph because it is unreachable. maybe_concat is constructed to maintain --- that invariant, but calling replaceLabels may introduce unreachable blocks. --- We rely on subsequent passes in the Cmm pipeline to remove unreachable --- blocks. -incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int -incPreds bid edges = mapInsertWith (+) bid 1 edges -decPreds bid edges = case mapLookup bid edges of - Just preds | preds > 1 -> mapInsert bid (preds - 1) edges - Just _ -> mapDelete bid edges - _ -> edges - - --- Checks if a block consists only of "goto dest". If it does than we return --- "Just dest" label. See Note [What is shortcutting] -canShortcut :: CmmBlock -> Maybe BlockId -canShortcut block - | (_, middle, CmmBranch dest) <- blockSplit block - , all dont_care $ blockToList middle - = Just dest - | otherwise - = Nothing - where dont_care CmmComment{} = True - dont_care CmmTick{} = True - dont_care _other = False - --- Concatenates two blocks. First one is assumed to be open on exit, the second --- is assumed to be closed on entry (i.e. it has a label attached to it, which --- the splice function removes by calling snd on result of blockSplitHead). -splice :: Block CmmNode C O -> CmmBlock -> CmmBlock -splice head rest = entry `blockJoinHead` code0 `blockAppend` code1 - where (CmmEntry lbl sc0, code0) = blockSplitHead head - (CmmEntry _ sc1, code1) = blockSplitHead rest - entry = CmmEntry lbl (combineTickScopes sc0 sc1) - --- If node is a call with continuation call return Just label of that --- continuation. Otherwise return Nothing. -callContinuation_maybe :: CmmNode O C -> Maybe BlockId -callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b -callContinuation_maybe (CmmForeignCall { succ = b }) = Just b -callContinuation_maybe _ = Nothing - - --- Map over the CmmGraph, replacing each label with its mapping in the --- supplied LabelMap. -replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph -replaceLabels env g - | mapNull env = g - | otherwise = replace_eid $ mapGraphNodes1 txnode g - where - replace_eid g = g {g_entry = lookup (g_entry g)} - lookup id = mapLookup id env `orElse` id - - txnode :: CmmNode e x -> CmmNode e x - txnode (CmmBranch bid) = CmmBranch (lookup bid) - txnode (CmmCondBranch p t f l) = - mkCmmCondBranch (exp p) (lookup t) (lookup f) l - txnode (CmmSwitch e ids) = - CmmSwitch (exp e) (mapSwitchTargets lookup ids) - txnode (CmmCall t k rg a res r) = - CmmCall (exp t) (liftM lookup k) rg a res r - txnode fc@CmmForeignCall{} = - fc{ args = map exp (args fc), succ = lookup (succ fc) } - txnode other = mapExpDeep exp other - - exp :: CmmExpr -> CmmExpr - exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) - exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i - exp e = e - -mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C -mkCmmCondBranch p t f l = - if t == f then CmmBranch t else CmmCondBranch p t f l - --- Build a map from a block to its set of predecessors. -predMap :: [CmmBlock] -> LabelMap Int -predMap blocks = foldr add_preds mapEmpty blocks - where - add_preds block env = foldr add env (successors block) - where add lbl env = mapInsertWith (+) lbl 1 env - --- Removing unreachable blocks -removeUnreachableBlocksProc :: CmmDecl -> CmmDecl -removeUnreachableBlocksProc proc@(CmmProc info lbl live g) - | used_blocks `lengthLessThan` mapSize (toBlockMap g) - = CmmProc info' lbl live g' - | otherwise - = proc - where - g' = ofBlockList (g_entry g) used_blocks - info' = info { info_tbls = keep_used (info_tbls info) } - -- Remove any info_tbls for unreachable - - keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable - keep_used bs = mapFoldlWithKey keep mapEmpty bs - - keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable - keep env l i | l `setMember` used_lbls = mapInsert l i env - | otherwise = env - - used_blocks :: [CmmBlock] - used_blocks = revPostorder g - - used_lbls :: LabelSet - used_lbls = setFromList $ map entryLabel used_blocks diff --git a/cmm/CmmExpr.hs b/cmm/CmmExpr.hs deleted file mode 100644 --- a/cmm/CmmExpr.hs +++ /dev/null @@ -1,619 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - -module CmmExpr - ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr - , CmmReg(..), cmmRegType, cmmRegWidth - , CmmLit(..), cmmLitType - , LocalReg(..), localRegType - , GlobalReg(..), isArgReg, globalRegType - , spReg, hpReg, spLimReg, hpLimReg, nodeReg - , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg - , node, baseReg - , VGcPtr(..) - - , DefinerOfRegs, UserOfRegs - , foldRegsDefd, foldRegsUsed - , foldLocalRegsDefd, foldLocalRegsUsed - - , RegSet, LocalRegSet, GlobalRegSet - , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet - , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet - , regSetToList - - , Area(..) - , module CmmMachOp - , module CmmType - ) -where - -import GhcPrelude - -import BlockId -import CLabel -import CmmMachOp -import CmmType -import DynFlags -import Outputable (panic) -import Unique - -import Data.Set (Set) -import qualified Data.Set as Set - -import BasicTypes (Alignment, mkAlignment, alignmentOf) - ------------------------------------------------------------------------------ --- CmmExpr --- An expression. Expressions have no side effects. ------------------------------------------------------------------------------ - -data CmmExpr - = CmmLit CmmLit -- Literal - | CmmLoad !CmmExpr !CmmType -- Read memory location - | CmmReg !CmmReg -- Contents of register - | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) - | CmmStackSlot Area {-# UNPACK #-} !Int - -- addressing expression of a stack slot - -- See Note [CmmStackSlot aliasing] - | CmmRegOff !CmmReg Int - -- CmmRegOff reg i - -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] - -- where rep = typeWidth (cmmRegType reg) - -instance Eq CmmExpr where -- Equality ignores the types - CmmLit l1 == CmmLit l2 = l1==l2 - CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 - CmmReg r1 == CmmReg r2 = r1==r2 - CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 - CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 - _e1 == _e2 = False - -data CmmReg - = CmmLocal {-# UNPACK #-} !LocalReg - | CmmGlobal GlobalReg - deriving( Eq, Ord ) - --- | A stack area is either the stack slot where a variable is spilled --- or the stack space where function arguments and results are passed. -data Area - = Old -- See Note [Old Area] - | Young {-# UNPACK #-} !BlockId -- Invariant: must be a continuation BlockId - -- See Note [Continuation BlockId] in CmmNode. - deriving (Eq, Ord) - -{- Note [Old Area] -~~~~~~~~~~~~~~~~~~ -There is a single call area 'Old', allocated at the extreme old -end of the stack frame (ie just younger than the return address) -which holds: - * incoming (overflow) parameters, - * outgoing (overflow) parameter to tail calls, - * outgoing (overflow) result values - * the update frame (if any) - -Its size is the max of all these requirements. On entry, the stack -pointer will point to the youngest incoming parameter, which is not -necessarily at the young end of the Old area. - -End of note -} - - -{- Note [CmmStackSlot aliasing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When do two CmmStackSlots alias? - - - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M - - T[old+N] aliases with U[old+M] only if the areas actually overlap - -Or more informally, different Areas may overlap with each other. - -An alternative semantics, that we previously had, was that different -Areas do not overlap. The problem that lead to redefining the -semantics of stack areas is described below. - -e.g. if we had - - x = Sp[old + 8] - y = Sp[old + 16] - - Sp[young(L) + 8] = L - Sp[young(L) + 16] = y - Sp[young(L) + 24] = x - call f() returns to L - -if areas semantically do not overlap, then we might optimise this to - - Sp[young(L) + 8] = L - Sp[young(L) + 16] = Sp[old + 8] - Sp[young(L) + 24] = Sp[old + 16] - call f() returns to L - -and now young(L) cannot be allocated at the same place as old, and we -are doomed to use more stack. - - - old+8 conflicts with young(L)+8 - - old+16 conflicts with young(L)+16 and young(L)+8 - -so young(L)+8 == old+24 and we get - - Sp[-8] = L - Sp[-16] = Sp[8] - Sp[-24] = Sp[0] - Sp -= 24 - call f() returns to L - -However, if areas are defined to be "possibly overlapping" in the -semantics, then we cannot commute any loads/stores of old with -young(L), and we will be able to re-use both old+8 and old+16 for -young(L). - - x = Sp[8] - y = Sp[0] - - Sp[8] = L - Sp[0] = y - Sp[-8] = x - Sp = Sp - 8 - call f() returns to L - -Now, the assignments of y go away, - - x = Sp[8] - Sp[8] = L - Sp[-8] = x - Sp = Sp - 8 - call f() returns to L --} - -data CmmLit - = CmmInt !Integer Width - -- Interpretation: the 2's complement representation of the value - -- is truncated to the specified size. This is easier than trying - -- to keep the value within range, because we don't know whether - -- it will be used as a signed or unsigned value (the CmmType doesn't - -- distinguish between signed & unsigned). - | CmmFloat Rational Width - | CmmVec [CmmLit] -- Vector literal - | CmmLabel CLabel -- Address of label - | CmmLabelOff CLabel Int -- Address of label + byte offset - - -- Due to limitations in the C backend, the following - -- MUST ONLY be used inside the info table indicated by label2 - -- (label2 must be the info label), and label1 must be an - -- SRT, a slow entrypoint or a large bitmap (see the Mangler) - -- Don't use it at all unless tablesNextToCode. - -- It is also used inside the NCG during when generating - -- position-independent code. - | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset - -- In an expression, the width just has the effect of MO_SS_Conv - -- from wordWidth to the desired width. - -- - -- In a static literal, the supported Widths depend on the - -- architecture: wordWidth is supported on all - -- architectures. Additionally W32 is supported on x86_64 when - -- using the small memory model. - - | CmmBlock {-# UNPACK #-} !BlockId -- Code label - -- Invariant: must be a continuation BlockId - -- See Note [Continuation BlockId] in CmmNode. - - | CmmHighStackMark -- A late-bound constant that stands for the max - -- #bytes of stack space used during a procedure. - -- During the stack-layout pass, CmmHighStackMark - -- is replaced by a CmmInt for the actual number - -- of bytes used - deriving Eq - -cmmExprType :: DynFlags -> CmmExpr -> CmmType -cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit -cmmExprType _ (CmmLoad _ rep) = rep -cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg -cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args) -cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg -cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address --- Careful though: what is stored at the stack slot may be bigger than --- an address - -cmmLitType :: DynFlags -> CmmLit -> CmmType -cmmLitType _ (CmmInt _ width) = cmmBits width -cmmLitType _ (CmmFloat _ width) = cmmFloat width -cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []" -cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l - in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls) - then cmmVec (1+length ls) ty - else panic "cmmLitType: CmmVec" -cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl -cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl -cmmLitType _ (CmmLabelDiffOff _ _ _ width) = cmmBits width -cmmLitType dflags (CmmBlock _) = bWord dflags -cmmLitType dflags (CmmHighStackMark) = bWord dflags - -cmmLabelType :: DynFlags -> CLabel -> CmmType -cmmLabelType dflags lbl - | isGcPtrLabel lbl = gcWord dflags - | otherwise = bWord dflags - -cmmExprWidth :: DynFlags -> CmmExpr -> Width -cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) - --- | Returns an alignment in bytes of a CmmExpr when it's a statically --- known integer constant, otherwise returns an alignment of 1 byte. --- The caller is responsible for using with a sensible CmmExpr --- argument. -cmmExprAlignment :: CmmExpr -> Alignment -cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff) -cmmExprAlignment _ = mkAlignment 1 --------- ---- Negation for conditional branches - -maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr -maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op - return (CmmMachOp op' args) -maybeInvertCmmExpr _ = Nothing - ------------------------------------------------------------------------------ --- Local registers ------------------------------------------------------------------------------ - -data LocalReg - = LocalReg {-# UNPACK #-} !Unique CmmType - -- ^ Parameters: - -- 1. Identifier - -- 2. Type - -instance Eq LocalReg where - (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 - --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] --- See Note [No Ord for Unique] -instance Ord LocalReg where - compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 - -instance Uniquable LocalReg where - getUnique (LocalReg uniq _) = uniq - -cmmRegType :: DynFlags -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg - -cmmRegWidth :: DynFlags -> CmmReg -> Width -cmmRegWidth dflags = typeWidth . cmmRegType dflags - -localRegType :: LocalReg -> CmmType -localRegType (LocalReg _ rep) = rep - ------------------------------------------------------------------------------ --- Register-use information for expressions and other types ------------------------------------------------------------------------------ - --- | Sets of registers - --- These are used for dataflow facts, and a common operation is taking --- the union of two RegSets and then asking whether the union is the --- same as one of the inputs. UniqSet isn't good here, because --- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary --- Sets. - -type RegSet r = Set r -type LocalRegSet = RegSet LocalReg -type GlobalRegSet = RegSet GlobalReg - -emptyRegSet :: RegSet r -nullRegSet :: RegSet r -> Bool -elemRegSet :: Ord r => r -> RegSet r -> Bool -extendRegSet :: Ord r => RegSet r -> r -> RegSet r -deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r -mkRegSet :: Ord r => [r] -> RegSet r -minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r -sizeRegSet :: RegSet r -> Int -regSetToList :: RegSet r -> [r] - -emptyRegSet = Set.empty -nullRegSet = Set.null -elemRegSet = Set.member -extendRegSet = flip Set.insert -deleteFromRegSet = flip Set.delete -mkRegSet = Set.fromList -minusRegSet = Set.difference -plusRegSet = Set.union -timesRegSet = Set.intersection -sizeRegSet = Set.size -regSetToList = Set.toList - -class Ord r => UserOfRegs r a where - foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b - -foldLocalRegsUsed :: UserOfRegs LocalReg a - => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b -foldLocalRegsUsed = foldRegsUsed - -class Ord r => DefinerOfRegs r a where - foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b - -foldLocalRegsDefd :: DefinerOfRegs LocalReg a - => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b -foldLocalRegsDefd = foldRegsDefd - -instance UserOfRegs LocalReg CmmReg where - foldRegsUsed _ f z (CmmLocal reg) = f z reg - foldRegsUsed _ _ z (CmmGlobal _) = z - -instance DefinerOfRegs LocalReg CmmReg where - foldRegsDefd _ f z (CmmLocal reg) = f z reg - foldRegsDefd _ _ z (CmmGlobal _) = z - -instance UserOfRegs GlobalReg CmmReg where - foldRegsUsed _ _ z (CmmLocal _) = z - foldRegsUsed _ f z (CmmGlobal reg) = f z reg - -instance DefinerOfRegs GlobalReg CmmReg where - foldRegsDefd _ _ z (CmmLocal _) = z - foldRegsDefd _ f z (CmmGlobal reg) = f z reg - -instance Ord r => UserOfRegs r r where - foldRegsUsed _ f z r = f z r - -instance Ord r => DefinerOfRegs r r where - foldRegsDefd _ f z r = f z r - -instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - -- The (Ord r) in the context is necessary here - -- See Note [Recursive superclasses] in TcInstDcls - foldRegsUsed dflags f !z e = expr z e - where expr z (CmmLit _) = z - expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr - expr z (CmmReg r) = foldRegsUsed dflags f z r - expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs - expr z (CmmRegOff r _) = foldRegsUsed dflags f z r - expr z (CmmStackSlot _ _) = z - -instance UserOfRegs r a => UserOfRegs r [a] where - foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as - {-# INLINABLE foldRegsUsed #-} - -instance DefinerOfRegs r a => DefinerOfRegs r [a] where - foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as - {-# INLINABLE foldRegsDefd #-} - ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ - -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ -{- -Note [Overlapping global registers] - -The backend might not faithfully implement the abstraction of the STG -machine with independent registers for different values of type -GlobalReg. Specifically, certain pairs of registers (r1, r2) may -overlap in the sense that a store to r1 invalidates the value in r2, -and vice versa. - -Currently this occurs only on the x86_64 architecture where FloatReg n -and DoubleReg n are assigned the same microarchitectural register, in -order to allow functions to receive more Float# or Double# arguments -in registers (as opposed to on the stack). - -There are no specific rules about which registers might overlap with -which other registers, but presumably it's safe to assume that nothing -will overlap with special registers like Sp or BaseReg. - -Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap -on a particular platform. The instance Eq GlobalReg is syntactic -equality of STG registers and does not take overlap into -account. However it is still used in UserOfRegs/DefinerOfRegs and -there are likely still bugs there, beware! --} - -data GlobalReg - -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - VGcPtr - - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number - - | XmmReg -- 128-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - | YmmReg -- 256-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - | ZmmReg -- 512-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register - | CCCS -- Current cost-centre stack - | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure - - -- We keep the address of some commonly-called - -- functions in the register table, to keep code - -- size down: - | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun - - -- Base offset for the register table, used for accessing registers - -- which do not have real registers assigned to them. This register - -- will only appear after we have expanded GlobalReg into memory accesses - -- (where necessary) in the native code generator. - | BaseReg - - -- The register used by the platform for the C stack pointer. This is - -- a break in the STG abstraction used exclusively to setup stack unwinding - -- information. - | MachSp - - -- The is a dummy register used to indicate to the stack unwinder where - -- a routine would return to. - | UnwindReturnReg - - -- Base Register for PIC (position-independent code) calculations - -- Only used inside the native code generator. It's exact meaning differs - -- from platform to platform (see module PositionIndependentCode). - | PicBaseReg - - deriving( Show ) - -instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes - FloatReg i == FloatReg j = i==j - DoubleReg i == DoubleReg j = i==j - LongReg i == LongReg j = i==j - -- NOTE: XMM, YMM, ZMM registers actually are the same registers - -- at least with respect to store at YMM i and then read from XMM i - -- and similarly for ZMM etc. - XmmReg i == XmmReg j = i==j - YmmReg i == YmmReg j = i==j - ZmmReg i == ZmmReg j = i==j - Sp == Sp = True - SpLim == SpLim = True - Hp == Hp = True - HpLim == HpLim = True - CCCS == CCCS = True - CurrentTSO == CurrentTSO = True - CurrentNursery == CurrentNursery = True - HpAlloc == HpAlloc = True - EagerBlackholeInfo == EagerBlackholeInfo = True - GCEnter1 == GCEnter1 = True - GCFun == GCFun = True - BaseReg == BaseReg = True - MachSp == MachSp = True - UnwindReturnReg == UnwindReturnReg = True - PicBaseReg == PicBaseReg = True - _r1 == _r2 = False - -instance Ord GlobalReg where - compare (VanillaReg i _) (VanillaReg j _) = compare i j - -- Ignore type when seeking clashes - compare (FloatReg i) (FloatReg j) = compare i j - compare (DoubleReg i) (DoubleReg j) = compare i j - compare (LongReg i) (LongReg j) = compare i j - compare (XmmReg i) (XmmReg j) = compare i j - compare (YmmReg i) (YmmReg j) = compare i j - compare (ZmmReg i) (ZmmReg j) = compare i j - compare Sp Sp = EQ - compare SpLim SpLim = EQ - compare Hp Hp = EQ - compare HpLim HpLim = EQ - compare CCCS CCCS = EQ - compare CurrentTSO CurrentTSO = EQ - compare CurrentNursery CurrentNursery = EQ - compare HpAlloc HpAlloc = EQ - compare EagerBlackholeInfo EagerBlackholeInfo = EQ - compare GCEnter1 GCEnter1 = EQ - compare GCFun GCFun = EQ - compare BaseReg BaseReg = EQ - compare MachSp MachSp = EQ - compare UnwindReturnReg UnwindReturnReg = EQ - compare PicBaseReg PicBaseReg = EQ - compare (VanillaReg _ _) _ = LT - compare _ (VanillaReg _ _) = GT - compare (FloatReg _) _ = LT - compare _ (FloatReg _) = GT - compare (DoubleReg _) _ = LT - compare _ (DoubleReg _) = GT - compare (LongReg _) _ = LT - compare _ (LongReg _) = GT - compare (XmmReg _) _ = LT - compare _ (XmmReg _) = GT - compare (YmmReg _) _ = LT - compare _ (YmmReg _) = GT - compare (ZmmReg _) _ = LT - compare _ (ZmmReg _) = GT - compare Sp _ = LT - compare _ Sp = GT - compare SpLim _ = LT - compare _ SpLim = GT - compare Hp _ = LT - compare _ Hp = GT - compare HpLim _ = LT - compare _ HpLim = GT - compare CCCS _ = LT - compare _ CCCS = GT - compare CurrentTSO _ = LT - compare _ CurrentTSO = GT - compare CurrentNursery _ = LT - compare _ CurrentNursery = GT - compare HpAlloc _ = LT - compare _ HpAlloc = GT - compare GCEnter1 _ = LT - compare _ GCEnter1 = GT - compare GCFun _ = LT - compare _ GCFun = GT - compare BaseReg _ = LT - compare _ BaseReg = GT - compare MachSp _ = LT - compare _ MachSp = GT - compare UnwindReturnReg _ = LT - compare _ UnwindReturnReg = GT - compare EagerBlackholeInfo _ = LT - compare _ EagerBlackholeInfo = GT - --- convenient aliases -baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, - currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg -baseReg = CmmGlobal BaseReg -spReg = CmmGlobal Sp -hpReg = CmmGlobal Hp -hpLimReg = CmmGlobal HpLim -spLimReg = CmmGlobal SpLim -nodeReg = CmmGlobal node -currentTSOReg = CmmGlobal CurrentTSO -currentNurseryReg = CmmGlobal CurrentNursery -hpAllocReg = CmmGlobal HpAlloc -cccsReg = CmmGlobal CCCS - -node :: GlobalReg -node = VanillaReg 1 VGcPtr - -globalRegType :: DynFlags -> GlobalReg -> CmmType -globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags -globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags -globalRegType _ (FloatReg _) = cmmFloat W32 -globalRegType _ (DoubleReg _) = cmmFloat W64 -globalRegType _ (LongReg _) = cmmBits W64 --- TODO: improve the internal model of SIMD/vectorized registers --- the right design SHOULd improve handling of float and double code too. --- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim -globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32) -globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32) -globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32) - -globalRegType dflags Hp = gcWord dflags - -- The initialiser for all - -- dynamically allocated closures -globalRegType dflags _ = bWord dflags - -isArgReg :: GlobalReg -> Bool -isArgReg (VanillaReg {}) = True -isArgReg (FloatReg {}) = True -isArgReg (DoubleReg {}) = True -isArgReg (LongReg {}) = True -isArgReg (XmmReg {}) = True -isArgReg (YmmReg {}) = True -isArgReg (ZmmReg {}) = True -isArgReg _ = False diff --git a/cmm/CmmImplementSwitchPlans.hs b/cmm/CmmImplementSwitchPlans.hs deleted file mode 100644 --- a/cmm/CmmImplementSwitchPlans.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE GADTs #-} -module CmmImplementSwitchPlans - ( cmmImplementSwitchPlans - ) -where - -import GhcPrelude - -import Hoopl.Block -import BlockId -import Cmm -import CmmUtils -import CmmSwitch -import UniqSupply -import DynFlags - --- --- This module replaces Switch statements as generated by the Stg -> Cmm --- transformation, which might be huge and sparse and hence unsuitable for --- assembly code, by proper constructs (if-then-else trees, dense jump tables). --- --- The actual, abstract strategy is determined by createSwitchPlan in --- CmmSwitch and returned as a SwitchPlan; here is just the implementation in --- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch. --- --- This division into different modules is both to clearly separate concerns, --- but also because createSwitchPlan needs access to the constructors of --- SwitchTargets, a data type exported abstractly by CmmSwitch. --- - --- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for --- code generation. -cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph -cmmImplementSwitchPlans dflags g - -- Switch generation done by backend (LLVM/C) - | targetSupportsSwitch (hscTarget dflags) = return g - | otherwise = do - blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g) - return $ ofBlockList (g_entry g) blocks' - -visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock] -visitSwitches dflags block - | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block - = do - let plan = createSwitchPlan ids - -- See Note [Floating switch expressions] - (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr - - (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan - - let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail - - return $ block' : newBlocks - - | otherwise - = return [block] - --- Note [Floating switch expressions] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- When we translate a sparse switch into a search tree we would like --- to compute the value we compare against only once. - --- For this purpose we assign the switch expression to a local register --- and then use this register when constructing the actual binary tree. - --- This is important as the expression could contain expensive code like --- memory loads or divisions which we REALLY don't want to duplicate. - --- This happened in parts of the handwritten RTS Cmm code. See also #16933 - --- See Note [Floating switch expressions] -floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr) -floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg) -floatSwitchExpr dflags expr = do - (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM - return (BMiddle assign, expr') - - --- Implementing a switch plan (returning a tail block) -implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock]) -implementSwitchPlan dflags scope expr = go - where - go (Unconditionally l) - = return (emptyBlock `blockJoinTail` CmmBranch l, []) - go (JumpTable ids) - = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, []) - go (IfLT signed i ids1 ids2) - = do - (bid1, newBlocks1) <- go' ids1 - (bid2, newBlocks2) <- go' ids2 - - let lt | signed = cmmSLtWord - | otherwise = cmmULtWord - scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i - lastNode = CmmCondBranch scrut bid1 bid2 Nothing - lastBlock = emptyBlock `blockJoinTail` lastNode - return (lastBlock, newBlocks1++newBlocks2) - go (IfEqual i l ids2) - = do - (bid2, newBlocks2) <- go' ids2 - - let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i - lastNode = CmmCondBranch scrut bid2 l Nothing - lastBlock = emptyBlock `blockJoinTail` lastNode - return (lastBlock, newBlocks2) - - -- Same but returning a label to branch to - go' (Unconditionally l) - = return (l, []) - go' p - = do - bid <- mkBlockId `fmap` getUniqueM - (last, newBlocks) <- go p - let block = CmmEntry bid scope `blockJoinHead` last - return (bid, block: newBlocks) diff --git a/cmm/CmmInfo.hs b/cmm/CmmInfo.hs deleted file mode 100644 --- a/cmm/CmmInfo.hs +++ /dev/null @@ -1,593 +0,0 @@ -{-# LANGUAGE CPP #-} -module CmmInfo ( - mkEmptyContInfoTable, - cmmToRawCmm, - mkInfoTable, - srtEscape, - - -- info table accessors - closureInfoPtr, - entryCode, - getConstrTag, - cmmGetClosureType, - infoTable, - infoTableConstrTag, - infoTableSrtBitmap, - infoTableClosureType, - infoTablePtrs, - infoTableNonPtrs, - funInfoTable, - funInfoArity, - - -- info table sizes and offsets - stdInfoTableSizeW, - fixedInfoTableSizeW, - profInfoTableSizeW, - maxStdInfoTableSizeW, - maxRetInfoTableSizeW, - stdInfoTableSizeB, - conInfoTableSizeB, - stdSrtBitmapOffset, - stdClosureTypeOffset, - stdPtrsOffset, stdNonPtrsOffset, -) where - -#include "HsVersions.h" - -import GhcPrelude - -import Cmm -import CmmUtils -import CLabel -import SMRep -import Bitmap -import Stream (Stream) -import qualified Stream -import Hoopl.Collections - -import GHC.Platform -import Maybes -import DynFlags -import ErrUtils (withTimingSilent) -import Panic -import UniqSupply -import MonadUtils -import Util -import Outputable - -import Data.ByteString (ByteString) -import Data.Bits - --- When we split at proc points, we need an empty info table. -mkEmptyContInfoTable :: CLabel -> CmmInfoTable -mkEmptyContInfoTable info_lbl - = CmmInfoTable { cit_lbl = info_lbl - , cit_rep = mkStackRep [] - , cit_prof = NoProfilingInfo - , cit_srt = Nothing - , cit_clo = Nothing } - -cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a - -> IO (Stream IO RawCmmGroup a) -cmmToRawCmm dflags cmms - = do { uniqs <- mkSplitUniqSupply 'i' - ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl]) - do_one uniqs cmm = - -- NB. strictness fixes a space leak. DO NOT REMOVE. - withTimingSilent dflags (text "Cmm -> Raw Cmm") - forceRes $ - case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of - (b,uniqs') -> return (uniqs',b) - ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms) - } - - where forceRes (uniqs, rawcmms) = - uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms - --- Make a concrete info table, represented as a list of CmmStatic --- (it can't be simply a list of Word, because the SRT field is --- represented by a label+offset expression). --- --- With tablesNextToCode, the layout is --- --- --- --- --- Without tablesNextToCode, the layout of an info table is --- --- --- --- --- See includes/rts/storage/InfoTables.h --- --- For return-points these are as follows --- --- Tables next to code: --- --- --- --- ret-addr --> --- --- Not tables-next-to-code: --- --- ret-addr --> --- --- --- --- * The SRT slot is only there if there is SRT info to record - -mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] -mkInfoTable _ (CmmData sec dat) - = return [CmmData sec dat] - -mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) - -- - -- in the non-tables-next-to-code case, procs can have at most a - -- single info table associated with the entry label of the proc. - -- - | not (tablesNextToCode dflags) - = case topInfoTable proc of -- must be at most one - -- no info table - Nothing -> - return [CmmProc mapEmpty entry_lbl live blocks] - - Just info@CmmInfoTable { cit_lbl = info_lbl } -> do - (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags info Nothing - let - rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits - -- - -- Separately emit info table (with the function entry - -- point as first entry) and the entry code - -- - return (top_decls ++ - [CmmProc mapEmpty entry_lbl live blocks, - mkRODataLits info_lbl - (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) - - -- - -- With tables-next-to-code, we can have many info tables, - -- associated with some of the BlockIds of the proc. For each info - -- table we need to turn it into CmmStatics, and collect any new - -- CmmDecls that arise from doing so. - -- - | otherwise - = do - (top_declss, raw_infos) <- - unzip `fmap` mapM do_one_info (mapToList (info_tbls infos)) - return (concat top_declss ++ - [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) - - where - do_one_info (lbl,itbl) = do - (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags itbl Nothing - let - info_lbl = cit_lbl itbl - rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info - rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits - -- - return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $ - reverse rel_extra_bits ++ rel_std_info)) - ------------------------------------------------------ -type InfoTableContents = ( [CmmLit] -- The standard part - , [CmmLit] ) -- The "extra bits" --- These Lits have *not* had mkRelativeTo applied to them - -mkInfoTableContents :: DynFlags - -> CmmInfoTable - -> Maybe Int -- Override default RTS type tag? - -> UniqSM ([RawCmmDecl], -- Auxiliary top decls - InfoTableContents) -- Info tbl + extra bits - -mkInfoTableContents dflags - info@(CmmInfoTable { cit_lbl = info_lbl - , cit_rep = smrep - , cit_prof = prof - , cit_srt = srt }) - mb_rts_tag - | RTSRep rts_tag rep <- smrep - = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) - -- Completely override the rts_tag that mkInfoTableContents would - -- otherwise compute, with the rts_tag stored in the RTSRep - -- (which in turn came from a handwritten .cmm file) - - | StackRep frame <- smrep - = do { (prof_lits, prof_data) <- mkProfLits dflags prof - ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt - ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame - ; let - std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit - rts_tag | Just tag <- mb_rts_tag = tag - | null liveness_data = rET_SMALL -- Fits in extra_bits - | otherwise = rET_BIG -- Does not; extra_bits is - -- a label - ; return (prof_data ++ liveness_data, (std_info, srt_label)) } - - | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packIntsCLit dflags ptrs nonptrs - ; (prof_lits, prof_data) <- mkProfLits dflags prof - ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt - ; (mb_srt_field, mb_layout, extra_bits, ct_data) - <- mk_pieces closure_type srt_label - ; let std_info = mkStdInfoTable dflags prof_lits - (mb_rts_tag `orElse` rtsClosureType smrep) - (mb_srt_field `orElse` srt_bitmap) - (mb_layout `orElse` layout) - ; return (prof_data ++ ct_data, (std_info, extra_bits)) } - where - mk_pieces :: ClosureTypeInfo -> [CmmLit] - -> UniqSM ( Maybe CmmLit -- Override the SRT field with this - , Maybe CmmLit -- Override the layout field with this - , [CmmLit] -- "Extra bits" for info table - , [RawCmmDecl]) -- Auxiliary data decls - mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor - = do { (descr_lit, decl) <- newStringLit con_descr - ; return ( Just (CmmInt (fromIntegral con_tag) - (halfWordWidth dflags)) - , Nothing, [descr_lit], [decl]) } - - mk_pieces Thunk srt_label - = return (Nothing, Nothing, srt_label, []) - - mk_pieces (ThunkSelector offset) _no_srt - = return (Just (CmmInt 0 (halfWordWidth dflags)), - Just (mkWordCLit dflags (fromIntegral offset)), [], []) - -- Layout known (one free var); we use the layout field for offset - - mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label - ; return (Nothing, Nothing, extra_bits, []) } - - mk_pieces (Fun arity (ArgGen arg_bits)) srt_label - = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits - ; let fun_type | null liveness_data = aRG_GEN - | otherwise = aRG_GEN_BIG - extra_bits = [ packIntsCLit dflags fun_type arity ] - ++ (if inlineSRT dflags then [] else [ srt_lit ]) - ++ [ liveness_lit, slow_entry ] - ; return (Nothing, Nothing, extra_bits, liveness_data) } - where - slow_entry = CmmLabel (toSlowEntryLbl info_lbl) - srt_lit = case srt_label of - [] -> mkIntCLit dflags 0 - (lit:_rest) -> ASSERT( null _rest ) lit - - mk_pieces other _ = pprPanic "mk_pieces" (ppr other) - -mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier - -packIntsCLit :: DynFlags -> Int -> Int -> CmmLit -packIntsCLit dflags a b = packHalfWordsCLit dflags - (toStgHalfWord dflags (fromIntegral a)) - (toStgHalfWord dflags (fromIntegral b)) - - -mkSRTLit :: DynFlags - -> CLabel - -> Maybe CLabel - -> ([CmmLit], -- srt_label, if any - CmmLit) -- srt_bitmap -mkSRTLit dflags info_lbl (Just lbl) - | inlineSRT dflags - = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags)) -mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth dflags)) -mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags)) - - --- | Is the SRT offset field inline in the info table on this platform? --- --- See the section "Referring to an SRT from the info table" in --- Note [SRTs] in CmmBuildInfoTables.hs -inlineSRT :: DynFlags -> Bool -inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64 - && tablesNextToCode dflags - -------------------------------------------------------------------------- --- --- Lay out the info table and handle relative offsets --- -------------------------------------------------------------------------- - --- This function takes --- * the standard info table portion (StgInfoTable) --- * the "extra bits" (StgFunInfoExtraRev etc.) --- * the entry label --- * the code --- and lays them out in memory, producing a list of RawCmmDecl - -------------------------------------------------------------------------- --- --- Position independent code --- -------------------------------------------------------------------------- --- In order to support position independent code, we mustn't put absolute --- references into read-only space. Info tables in the tablesNextToCode --- case must be in .text, which is read-only, so we doctor the CmmLits --- to use relative offsets instead. - --- Note that this is done even when the -fPIC flag is not specified, --- as we want to keep binary compatibility between PIC and non-PIC. - -makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit - -makeRelativeRefTo dflags info_lbl (CmmLabel lbl) - | tablesNextToCode dflags - = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags) -makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off) - | tablesNextToCode dflags - = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags) -makeRelativeRefTo _ _ lit = lit - - -------------------------------------------------------------------------- --- --- Build a liveness mask for the stack layout --- -------------------------------------------------------------------------- - --- There are four kinds of things on the stack: --- --- - pointer variables (bound in the environment) --- - non-pointer variables (bound in the environment) --- - free slots (recorded in the stack free list) --- - non-pointer data slots (recorded in the stack free list) --- --- The first two are represented with a 'Just' of a 'LocalReg'. --- The last two with one or more 'Nothing' constructors. --- Each 'Nothing' represents one used word. --- --- The head of the stack layout is the top of the stack and --- the least-significant bit. - -mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) - -- ^ Returns: - -- 1. The bitmap (literal value or label) - -- 2. Large bitmap CmmData if needed - -mkLivenessBits dflags liveness - | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word - = do { uniq <- getUniqueM - ; let bitmap_lbl = mkBitmapLabel uniq - ; return (CmmLabel bitmap_lbl, - [mkRODataLits bitmap_lbl lits]) } - - | otherwise -- Fits in one word - = return (mkStgWordCLit dflags bitmap_word, []) - where - n_bits = length liveness - - bitmap :: Bitmap - bitmap = mkBitmap dflags liveness - - small_bitmap = case bitmap of - [] -> toStgWord dflags 0 - [b] -> b - _ -> panic "mkLiveness" - bitmap_word = toStgWord dflags (fromIntegral n_bits) - .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) - - lits = mkWordCLit dflags (fromIntegral n_bits) - : map (mkStgWordCLit dflags) bitmap - -- The first word is the size. The structure must match - -- StgLargeBitmap in includes/rts/storage/InfoTable.h - -------------------------------------------------------------------------- --- --- Generating a standard info table --- -------------------------------------------------------------------------- - --- The standard bits of an info table. This part of the info table --- corresponds to the StgInfoTable type defined in --- includes/rts/storage/InfoTables.h. --- --- Its shape varies with ticky/profiling/tables next to code etc --- so we can't use constant offsets from Constants - -mkStdInfoTable - :: DynFlags - -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) - -> Int -- Closure RTS tag - -> CmmLit -- SRT length - -> CmmLit -- layout field - -> [CmmLit] - -mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit - = -- Parallel revertible-black hole field - prof_info - -- Ticky info (none at present) - -- Debug info (none at present) - ++ [layout_lit, tag, srt] - - where - prof_info - | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] - | otherwise = [] - - tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags) - -------------------------------------------------------------------------- --- --- Making string literals --- -------------------------------------------------------------------------- - -mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) -mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), []) -mkProfLits _ (ProfilingInfo td cd) - = do { (td_lit, td_decl) <- newStringLit td - ; (cd_lit, cd_decl) <- newStringLit cd - ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } - -newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt) -newStringLit bytes - = do { uniq <- getUniqueM - ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) } - - --- Misc utils - --- | Value of the srt field of an info table when using an StgLargeSRT -srtEscape :: DynFlags -> StgHalfWord -srtEscape dflags = toStgHalfWord dflags (-1) - -------------------------------------------------------------------------- --- --- Accessing fields of an info table --- -------------------------------------------------------------------------- - --- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is --- enabled. -wordAligned :: DynFlags -> CmmExpr -> CmmExpr -wordAligned dflags e - | gopt Opt_AlignmentSanitisation dflags - = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e] - | otherwise - = e - -closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer and returns the info table pointer -closureInfoPtr dflags e = - CmmLoad (wordAligned dflags e) (bWord dflags) - -entryCode :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info pointer (the first word of a closure) --- and returns its entry code -entryCode dflags e - | tablesNextToCode dflags = e - | otherwise = CmmLoad e (bWord dflags) - -getConstrTag :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer, and return the *zero-indexed* --- constructor tag obtained from the info table --- This lives in the SRT field of the info table --- (constructors don't need SRTs). -getConstrTag dflags closure_ptr - = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] - where - info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) - -cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer, and return the closure type --- obtained from the info table -cmmGetClosureType dflags closure_ptr - = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] - where - info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) - -infoTable :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info pointer (the first word of a closure) --- and returns a pointer to the first word of the standard-form --- info table, excluding the entry-code word (if present) -infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer - -infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the constr tag --- field of the info table (same as the srt_bitmap field) -infoTableConstrTag = infoTableSrtBitmap - -infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the srt_bitmap --- field of the info table -infoTableSrtBitmap dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) - -infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the closure type --- field of the info table. -infoTableClosureType dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) - -infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr -infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) - -infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr -infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) - -funInfoTable :: DynFlags -> CmmExpr -> CmmExpr --- Takes the info pointer of a function, --- and returns a pointer to the first word of the StgFunInfoExtra struct --- in the info table. -funInfoTable dflags info_ptr - | tablesNextToCode dflags - = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) - | otherwise - = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) - -- Past the entry code pointer - --- Takes the info pointer of a function, returns the function's arity -funInfoArity :: DynFlags -> CmmExpr -> CmmExpr -funInfoArity dflags iptr - = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes)) - where - fun_info = funInfoTable dflags iptr - rep = cmmBits (widthFromBytes rep_bytes) - - (rep_bytes, offset) - | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc - , oFFSET_StgFunInfoExtraRev_arity dflags ) - | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc - , oFFSET_StgFunInfoExtraFwd_arity dflags ) - - pc = platformConstants dflags - ------------------------------------------------------------------------------ --- --- Info table sizes & offsets --- ------------------------------------------------------------------------------ - -stdInfoTableSizeW :: DynFlags -> WordOff --- The size of a standard info table varies with profiling/ticky etc, --- so we can't get it from Constants --- It must vary in sync with mkStdInfoTable -stdInfoTableSizeW dflags - = fixedInfoTableSizeW - + if gopt Opt_SccProfilingOn dflags - then profInfoTableSizeW - else 0 - -fixedInfoTableSizeW :: WordOff -fixedInfoTableSizeW = 2 -- layout, type - -profInfoTableSizeW :: WordOff -profInfoTableSizeW = 2 - -maxStdInfoTableSizeW :: WordOff -maxStdInfoTableSizeW = - 1 {- entry, when !tablesNextToCode -} - + fixedInfoTableSizeW - + profInfoTableSizeW - -maxRetInfoTableSizeW :: WordOff -maxRetInfoTableSizeW = - maxStdInfoTableSizeW - + 1 {- srt label -} - -stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags - -stdSrtBitmapOffset :: DynFlags -> ByteOff --- Byte offset of the SRT bitmap half-word which is --- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags - -stdClosureTypeOffset :: DynFlags -> ByteOff --- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags - -stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags - -conInfoTableSizeB :: DynFlags -> Int -conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags diff --git a/cmm/CmmLayoutStack.hs b/cmm/CmmLayoutStack.hs deleted file mode 100644 --- a/cmm/CmmLayoutStack.hs +++ /dev/null @@ -1,1239 +0,0 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-} -module CmmLayoutStack ( - cmmLayoutStack, setInfoTableStackMap - ) where - -import GhcPrelude hiding ((<*>)) - -import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation -import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation - -import BasicTypes -import Cmm -import CmmInfo -import BlockId -import CLabel -import CmmUtils -import MkGraph -import ForeignCall -import CmmLive -import CmmProcPoint -import SMRep -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Dataflow -import Hoopl.Graph -import Hoopl.Label -import UniqSupply -import Maybes -import UniqFM -import Util - -import DynFlags -import FastString -import Outputable hiding ( isEmpty ) -import qualified Data.Set as Set -import Control.Monad.Fix -import Data.Array as Array -import Data.Bits -import Data.List (nub) -import TyCon (PrimRep (..)) - -{- Note [Stack Layout] - -The job of this pass is to - - - replace references to abstract stack Areas with fixed offsets from Sp. - - - replace the CmmHighStackMark constant used in the stack check with - the maximum stack usage of the proc. - - - save any variables that are live across a call, and reload them as - necessary. - -Before stack allocation, local variables remain live across native -calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local -variables are clobbered by native calls. - -We want to do stack allocation so that as far as possible - - stack use is minimized, and - - unnecessary stack saves and loads are avoided. - -The algorithm we use is a variant of linear-scan register allocation, -where the stack is our register file. - -We proceed in two passes, see Note [Two pass approach] for why they are not easy -to merge into one. - -Pass 1: - - - First, we do a liveness analysis, which annotates every block with - the variables live on entry to the block. - - - We traverse blocks in reverse postorder DFS; that is, we visit at - least one predecessor of a block before the block itself. The - stack layout flowing from the predecessor of the block will - determine the stack layout on entry to the block. - - - We maintain a data structure - - Map Label StackMap - - which describes the contents of the stack and the stack pointer on - entry to each block that is a successor of a block that we have - visited. - - - For each block we visit: - - - Look up the StackMap for this block. - - - If this block is a proc point (or a call continuation, if we aren't - splitting proc points), we need to reload all the live variables from the - stack - but this is done in Pass 2, which calculates more precise liveness - information (see description of Pass 2). - - - Walk forwards through the instructions: - - At an assignment x = Sp[loc] - - Record the fact that Sp[loc] contains x, so that we won't - need to save x if it ever needs to be spilled. - - At an assignment x = E - - If x was previously on the stack, it isn't any more - - At the last node, if it is a call or a jump to a proc point - - Lay out the stack frame for the call (see setupStackFrame) - - emit instructions to save all the live variables - - Remember the StackMaps for all the successors - - emit an instruction to adjust Sp - - If the last node is a branch, then the current StackMap is the - StackMap for the successors. - - - Manifest Sp: replace references to stack areas in this block - with real Sp offsets. We cannot do this until we have laid out - the stack area for the successors above. - - In this phase we also eliminate redundant stores to the stack; - see elimStackStores. - - - There is one important gotcha: sometimes we'll encounter a control - transfer to a block that we've already processed (a join point), - and in that case we might need to rearrange the stack to match - what the block is expecting. (exactly the same as in linear-scan - register allocation, except here we have the luxury of an infinite - supply of temporary variables). - - - Finally, we update the magic CmmHighStackMark constant with the - stack usage of the function, and eliminate the whole stack check - if there was no stack use. (in fact this is done as part of the - main traversal, by feeding the high-water-mark output back in as - an input. I hate cyclic programming, but it's just too convenient - sometimes.) - - There are plenty of tricky details: update frames, proc points, return - addresses, foreign calls, and some ad-hoc optimisations that are - convenient to do here and effective in common cases. Comments in the - code below explain these. - -Pass 2: - -- Calculate live registers, but taking into account that nothing is live at the - entry to a proc point. - -- At each proc point and call continuation insert reloads of live registers from - the stack (they were saved by Pass 1). - - -Note [Two pass approach] - -The main reason for Pass 2 is being able to insert only the reloads that are -needed and the fact that the two passes need different liveness information. -Let's consider an example: - - ..... - \ / - D <- proc point - / \ - E F - \ / - G <- proc point - | - X - -Pass 1 needs liveness assuming that local variables are preserved across calls. -This is important because it needs to save any local registers to the stack -(e.g., if register a is used in block X, it must be saved before any native -call). -However, for Pass 2, where we want to reload registers from stack (in a proc -point), this is overly conservative and would lead us to generate reloads in D -for things used in X, even though we're going to generate reloads in G anyway -(since it's also a proc point). -So Pass 2 calculates liveness knowing that nothing is live at the entry to a -proc point. This means that in D we only need to reload things used in E or F. -This can be quite important, for an extreme example see testcase for #3294. - -Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1 -is a forward one. Furthermore, Pass 1 is creating code that uses local registers -(saving them before a call), which the liveness analysis for Pass 2 must see to -be correct. - --} - - --- All stack locations are expressed as positive byte offsets from the --- "base", which is defined to be the address above the return address --- on the stack on entry to this CmmProc. --- --- Lower addresses have higher StackLocs. --- -type StackLoc = ByteOff - -{- - A StackMap describes the stack at any given point. At a continuation - it has a particular layout, like this: - - | | <- base - |-------------| - | ret0 | <- base + 8 - |-------------| - . upd frame . <- base + sm_ret_off - |-------------| - | | - . vars . - . (live/dead) . - | | <- base + sm_sp - sm_args - |-------------| - | ret1 | - . ret vals . <- base + sm_sp (<--- Sp points here) - |-------------| - -Why do we include the final return address (ret0) in our stack map? I -have absolutely no idea, but it seems to be done that way consistently -in the rest of the code generator, so I played along here. --SDM - -Note that we will be constructing an info table for the continuation -(ret1), which needs to describe the stack down to, but not including, -the update frame (or ret0, if there is no update frame). --} - -data StackMap = StackMap - { sm_sp :: StackLoc - -- ^ the offset of Sp relative to the base on entry - -- to this block. - , sm_args :: ByteOff - -- ^ the number of bytes of arguments in the area for this block - -- Defn: the offset of young(L) relative to the base is given by - -- (sm_sp - sm_args) of the StackMap for block L. - , sm_ret_off :: ByteOff - -- ^ Number of words of stack that we do not describe with an info - -- table, because it contains an update frame. - , sm_regs :: UniqFM (LocalReg,StackLoc) - -- ^ regs on the stack - } - -instance Outputable StackMap where - ppr StackMap{..} = - text "Sp = " <> int sm_sp $$ - text "sm_args = " <> int sm_args $$ - text "sm_ret_off = " <> int sm_ret_off $$ - text "sm_regs = " <> pprUFM sm_regs ppr - - -cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph - -> UniqSM (CmmGraph, LabelMap StackMap) -cmmLayoutStack dflags procpoints entry_args - graph@(CmmGraph { g_entry = entry }) - = do - -- We need liveness info. Dead assignments are removed later - -- by the sinking pass. - let liveness = cmmLocalLiveness dflags graph - blocks = revPostorder graph - - (final_stackmaps, _final_high_sp, new_blocks) <- - mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> - layout dflags procpoints liveness entry entry_args - rec_stackmaps rec_high_sp blocks - - blocks_with_reloads <- - insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks - new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads - return (ofBlockList entry new_blocks', final_stackmaps) - --- ----------------------------------------------------------------------------- --- Pass 1 --- ----------------------------------------------------------------------------- - -layout :: DynFlags - -> LabelSet -- proc points - -> LabelMap CmmLocalLive -- liveness - -> BlockId -- entry - -> ByteOff -- stack args on entry - - -> LabelMap StackMap -- [final] stack maps - -> ByteOff -- [final] Sp high water mark - - -> [CmmBlock] -- [in] blocks - - -> UniqSM - ( LabelMap StackMap -- [out] stack maps - , ByteOff -- [out] Sp high water mark - , [CmmBlock] -- [out] new blocks - ) - -layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks - = go blocks init_stackmap entry_args [] - where - (updfr, cont_info) = collectContInfo blocks - - init_stackmap = mapSingleton entry StackMap{ sm_sp = entry_args - , sm_args = entry_args - , sm_ret_off = updfr - , sm_regs = emptyUFM - } - - go [] acc_stackmaps acc_hwm acc_blocks - = return (acc_stackmaps, acc_hwm, acc_blocks) - - go (b0 : bs) acc_stackmaps acc_hwm acc_blocks - = do - let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0 - - let stack0@StackMap { sm_sp = sp0 } - = mapFindWithDefault - (pprPanic "no stack map for" (ppr entry_lbl)) - entry_lbl acc_stackmaps - - -- (a) Update the stack map to include the effects of - -- assignments in this block - let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0 - - -- (b) Look at the last node and if we are making a call or - -- jumping to a proc point, we must save the live - -- variables, adjust Sp, and construct the StackMaps for - -- each of the successor blocks. See handleLastNode for - -- details. - (middle1, sp_off, last1, fixup_blocks, out) - <- handleLastNode dflags procpoints liveness cont_info - acc_stackmaps stack1 tscope middle0 last0 - - -- (c) Manifest Sp: run over the nodes in the block and replace - -- CmmStackSlot with CmmLoad from Sp with a concrete offset. - -- - -- our block: - -- middle0 -- the original middle nodes - -- middle1 -- live variable saves from handleLastNode - -- Sp = Sp + sp_off -- Sp adjustment goes here - -- last1 -- the last node - -- - let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1 - - let final_blocks = - manifestSp dflags final_stackmaps stack0 sp0 final_sp_high - entry0 middle_pre sp_off last1 fixup_blocks - - let acc_stackmaps' = mapUnion acc_stackmaps out - - -- If this block jumps to the GC, then we do not take its - -- stack usage into account for the high-water mark. - -- Otherwise, if the only stack usage is in the stack-check - -- failure block itself, we will do a redundant stack - -- check. The stack has a buffer designed to accommodate - -- the largest amount of stack needed for calling the GC. - -- - this_sp_hwm | isGcJump last0 = 0 - | otherwise = sp0 - sp_off - - hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out)) - - go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) - - --- ----------------------------------------------------------------------------- - --- Not foolproof, but GCFun is the culprit we most want to catch -isGcJump :: CmmNode O C -> Bool -isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) }) - = l == GCFun || l == GCEnter1 -isGcJump _something_else = False - --- ----------------------------------------------------------------------------- - --- This doesn't seem right somehow. We need to find out whether this --- proc will push some update frame material at some point, so that we --- can avoid using that area of the stack for spilling. The --- updfr_space field of the CmmProc *should* tell us, but it doesn't --- (I think maybe it gets filled in later when we do proc-point --- splitting). --- --- So we'll just take the max of all the cml_ret_offs. This could be --- unnecessarily pessimistic, but probably not in the code we --- generate. - -collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff) -collectContInfo blocks - = (maximum ret_offs, mapFromList (catMaybes mb_argss)) - where - (mb_argss, ret_offs) = mapAndUnzip get_cont blocks - - get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff) - get_cont b = - case lastNode b of - CmmCall { cml_cont = Just l, .. } - -> (Just (l, cml_ret_args), cml_ret_off) - CmmForeignCall { .. } - -> (Just (succ, ret_args), ret_off) - _other -> (Nothing, 0) - - --- ----------------------------------------------------------------------------- --- Updating the StackMap from middle nodes - --- Look for loads from stack slots, and update the StackMap. This is --- purely for optimisation reasons, so that we can avoid saving a --- variable back to a different stack slot if it is already on the --- stack. --- --- This happens a lot: for example when function arguments are passed --- on the stack and need to be immediately saved across a call, we --- want to just leave them where they are on the stack. --- -procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap -procMiddle stackmaps node sm - = case node of - CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _) - -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) } - where loc = getStackLoc area off stackmaps - CmmAssign (CmmLocal r) _other - -> sm { sm_regs = delFromUFM (sm_regs sm) r } - _other - -> sm - -getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc -getStackLoc Old n _ = n -getStackLoc (Young l) n stackmaps = - case mapLookup l stackmaps of - Nothing -> pprPanic "getStackLoc" (ppr l) - Just sm -> sm_sp sm - sm_args sm + n - - --- ----------------------------------------------------------------------------- --- Handling stack allocation for a last node - --- We take a single last node and turn it into: --- --- C1 (some statements) --- Sp = Sp + N --- C2 (some more statements) --- call f() -- the actual last node --- --- plus possibly some more blocks (we may have to add some fixup code --- between the last node and the continuation). --- --- C1: is the code for saving the variables across this last node onto --- the stack, if the continuation is a call or jumps to a proc point. --- --- C2: if the last node is a safe foreign call, we have to inject some --- extra code that goes *after* the Sp adjustment. - -handleLastNode - :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff - -> LabelMap StackMap -> StackMap -> CmmTickScope - -> Block CmmNode O O - -> CmmNode O C - -> UniqSM - ( [CmmNode O O] -- nodes to go *before* the Sp adjustment - , ByteOff -- amount to adjust Sp - , CmmNode O C -- new last node - , [CmmBlock] -- new blocks - , LabelMap StackMap -- stackmaps for the continuations - ) - -handleLastNode dflags procpoints liveness cont_info stackmaps - stack0@StackMap { sm_sp = sp0 } tscp middle last - = case last of - -- At each return / tail call, - -- adjust Sp to point to the last argument pushed, which - -- is cml_args, after popping any other junk from the stack. - CmmCall{ cml_cont = Nothing, .. } -> do - let sp_off = sp0 - cml_args - return ([], sp_off, last, [], mapEmpty) - - -- At each CmmCall with a continuation: - CmmCall{ cml_cont = Just cont_lbl, .. } -> - return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off - - CmmForeignCall{ succ = cont_lbl, .. } -> do - return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off - -- one word of args: the return address - - CmmBranch {} -> handleBranches - CmmCondBranch {} -> handleBranches - CmmSwitch {} -> handleBranches - - where - -- Calls and ForeignCalls are handled the same way: - lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff - -> ( [CmmNode O O] - , ByteOff - , CmmNode O C - , [CmmBlock] - , LabelMap StackMap - ) - lastCall lbl cml_args cml_ret_args cml_ret_off - = ( assignments - , spOffsetForCall sp0 cont_stack cml_args - , last - , [] -- no new blocks - , mapSingleton lbl cont_stack ) - where - (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off - - - prepareStack lbl cml_ret_args cml_ret_off - | Just cont_stack <- mapLookup lbl stackmaps - -- If we have already seen this continuation before, then - -- we just have to make the stack look the same: - = (fixupStack stack0 cont_stack, cont_stack) - -- Otherwise, we have to allocate the stack frame - | otherwise - = (save_assignments, new_cont_stack) - where - (new_cont_stack, save_assignments) - = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0 - - - -- For other last nodes (branches), if any of the targets is a - -- proc point, we have to set up the stack to match what the proc - -- point is expecting. - -- - handleBranches :: UniqSM ( [CmmNode O O] - , ByteOff - , CmmNode O C - , [CmmBlock] - , LabelMap StackMap ) - - handleBranches - -- Note [diamond proc point] - | Just l <- futureContinuation middle - , (nub $ filter (`setMember` procpoints) $ successors last) == [l] - = do - let cont_args = mapFindWithDefault 0 l cont_info - (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0) - out = mapFromList [ (l', cont_stack) - | l' <- successors last ] - return ( assigs - , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags) - , last - , [] - , out) - - | otherwise = do - pps <- mapM handleBranch (successors last) - let lbl_map :: LabelMap Label - lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ] - fix_lbl l = mapFindWithDefault l l lbl_map - return ( [] - , 0 - , mapSuccessors fix_lbl last - , concat [ blk | (_,_,_,blk) <- pps ] - , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] ) - - -- For each successor of this block - handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock]) - handleBranch l - -- (a) if the successor already has a stackmap, we need to - -- shuffle the current stack to make it look the same. - -- We have to insert a new block to make this happen. - | Just stack2 <- mapLookup l stackmaps - = do - let assigs = fixupStack stack0 stack2 - (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs - return (l, tmp_lbl, stack2, block) - - -- (b) if the successor is a proc point, save everything - -- on the stack. - | l `setMember` procpoints - = do - let cont_args = mapFindWithDefault 0 l cont_info - (stack2, assigs) = - setupStackFrame dflags l liveness (sm_ret_off stack0) - cont_args stack0 - (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs - return (l, tmp_lbl, stack2, block) - - -- (c) otherwise, the current StackMap is the StackMap for - -- the continuation. But we must remember to remove any - -- variables from the StackMap that are *not* live at - -- the destination, because this StackMap might be used - -- by fixupStack if this is a join point. - | otherwise = return (l, l, stack1, []) - where live = mapFindWithDefault (panic "handleBranch") l liveness - stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) } - is_live (r,_) = r `elemRegSet` live - - -makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap - -> CmmTickScope -> [CmmNode O O] - -> UniqSM (Label, [CmmBlock]) -makeFixupBlock dflags sp0 l stack tscope assigs - | null assigs && sp0 == sm_sp stack = return (l, []) - | otherwise = do - tmp_lbl <- newBlockId - let sp_off = sp0 - sm_sp stack - block = blockJoin (CmmEntry tmp_lbl tscope) - ( maybeAddSpAdj dflags sp0 sp_off - $ blockFromList assigs ) - (CmmBranch l) - return (tmp_lbl, [block]) - - --- Sp is currently pointing to current_sp, --- we want it to point to --- (sm_sp cont_stack - sm_args cont_stack + args) --- so the difference is --- sp0 - (sm_sp cont_stack - sm_args cont_stack + args) -spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff -spOffsetForCall current_sp cont_stack args - = current_sp - (sm_sp cont_stack - sm_args cont_stack + args) - - --- | create a sequence of assignments to establish the new StackMap, --- given the old StackMap. -fixupStack :: StackMap -> StackMap -> [CmmNode O O] -fixupStack old_stack new_stack = concatMap move new_locs - where - old_map = sm_regs old_stack - new_locs = stackSlotRegs new_stack - - move (r,n) - | Just (_,m) <- lookupUFM old_map r, n == m = [] - | otherwise = [CmmStore (CmmStackSlot Old n) - (CmmReg (CmmLocal r))] - - - -setupStackFrame - :: DynFlags - -> BlockId -- label of continuation - -> LabelMap CmmLocalLive -- liveness - -> ByteOff -- updfr - -> ByteOff -- bytes of return values on stack - -> StackMap -- current StackMap - -> (StackMap, [CmmNode O O]) - -setupStackFrame dflags lbl liveness updfr_off ret_args stack0 - = (cont_stack, assignments) - where - -- get the set of LocalRegs live in the continuation - live = mapFindWithDefault Set.empty lbl liveness - - -- the stack from the base to updfr_off is off-limits. - -- our new stack frame contains: - -- * saved live variables - -- * the return address [young(C) + 8] - -- * the args for the call, - -- which are replaced by the return values at the return - -- point. - - -- everything up to updfr_off is off-limits - -- stack1 contains updfr_off, plus everything we need to save - (stack1, assignments) = allocate dflags updfr_off live stack0 - - -- And the Sp at the continuation is: - -- sm_sp stack1 + ret_args - cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args - , sm_args = ret_args - , sm_ret_off = updfr_off - } - - --- ----------------------------------------------------------------------------- --- Note [diamond proc point] --- --- This special case looks for the pattern we get from a typical --- tagged case expression: --- --- Sp[young(L1)] = L1 --- if (R1 & 7) != 0 goto L1 else goto L2 --- L2: --- call [R1] returns to L1 --- L1: live: {y} --- x = R1 --- --- If we let the generic case handle this, we get --- --- Sp[-16] = L1 --- if (R1 & 7) != 0 goto L1a else goto L2 --- L2: --- Sp[-8] = y --- Sp = Sp - 16 --- call [R1] returns to L1 --- L1a: --- Sp[-8] = y --- Sp = Sp - 16 --- goto L1 --- L1: --- x = R1 --- --- The code for saving the live vars is duplicated in each branch, and --- furthermore there is an extra jump in the fast path (assuming L1 is --- a proc point, which it probably is if there is a heap check). --- --- So to fix this we want to set up the stack frame before the --- conditional jump. How do we know when to do this, and when it is --- safe? The basic idea is, when we see the assignment --- --- Sp[young(L)] = L --- --- we know that --- * we are definitely heading for L --- * there can be no more reads from another stack area, because young(L) --- overlaps with it. --- --- We don't necessarily know that everything live at L is live now --- (some might be assigned between here and the jump to L). So we --- simplify and only do the optimisation when we see --- --- (1) a block containing an assignment of a return address L --- (2) ending in a branch where one (and only) continuation goes to L, --- and no other continuations go to proc points. --- --- then we allocate the stack frame for L at the end of the block, --- before the branch. --- --- We could generalise (2), but that would make it a bit more --- complicated to handle, and this currently catches the common case. - -futureContinuation :: Block CmmNode O O -> Maybe BlockId -futureContinuation middle = foldBlockNodesB f middle Nothing - where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId - f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _ - = Just l - f _ r = r - --- ----------------------------------------------------------------------------- --- Saving live registers - --- | Given a set of live registers and a StackMap, save all the registers --- on the stack and return the new StackMap and the assignments to do --- the saving. --- -allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap - -> (StackMap, [CmmNode O O]) -allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 - , sm_regs = regs0 } - = - -- we only have to save regs that are not already in a slot - let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live) - regs1 = filterUFM (\(r,_) -> elemRegSet r live) regs0 - in - - -- make a map of the stack - let stack = reverse $ Array.elems $ - accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $ - ret_words ++ live_words - where ret_words = - [ (x, Occupied) - | x <- [ 1 .. toWords dflags ret_off] ] - live_words = - [ (toWords dflags x, Occupied) - | (r,off) <- nonDetEltsUFM regs1, - -- See Note [Unique Determinism and code generation] - let w = localRegBytes dflags r, - x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ] - in - - -- Pass over the stack: find slots to save all the new live variables, - -- choosing the oldest slots first (hence a foldr). - let - save slot ([], stack, n, assigs, regs) -- no more regs to save - = ([], slot:stack, plusW dflags n 1, assigs, regs) - save slot (to_save, stack, n, assigs, regs) - = case slot of - Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs) - Empty - | Just (stack', r, to_save') <- - select_save to_save (slot:stack) - -> let assig = CmmStore (CmmStackSlot Old n') - (CmmReg (CmmLocal r)) - n' = plusW dflags n 1 - in - (to_save', stack', n', assig : assigs, (r,(r,n')):regs) - - | otherwise - -> (to_save, slot:stack, plusW dflags n 1, assigs, regs) - - -- we should do better here: right now we'll fit the smallest first, - -- but it would make more sense to fit the biggest first. - select_save :: [LocalReg] -> [StackSlot] - -> Maybe ([StackSlot], LocalReg, [LocalReg]) - select_save regs stack = go regs [] - where go [] _no_fit = Nothing - go (r:rs) no_fit - | Just rest <- dropEmpty words stack - = Just (replicate words Occupied ++ rest, r, rs++no_fit) - | otherwise - = go rs (r:no_fit) - where words = localRegWords dflags r - - -- fill in empty slots as much as possible - (still_to_save, save_stack, n, save_assigs, save_regs) - = foldr save (to_save, [], 0, [], []) stack - - -- push any remaining live vars on the stack - (push_sp, push_assigs, push_regs) - = foldr push (n, [], []) still_to_save - where - push r (n, assigs, regs) - = (n', assig : assigs, (r,(r,n')) : regs) - where - n' = n + localRegBytes dflags r - assig = CmmStore (CmmStackSlot Old n') - (CmmReg (CmmLocal r)) - - trim_sp - | not (null push_regs) = push_sp - | otherwise - = plusW dflags n (- length (takeWhile isEmpty save_stack)) - - final_regs = regs1 `addListToUFM` push_regs - `addListToUFM` save_regs - - in - -- XXX should be an assert - if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else - - if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else - - ( stackmap { sm_regs = final_regs , sm_sp = trim_sp } - , push_assigs ++ save_assigs ) - - --- ----------------------------------------------------------------------------- --- Manifesting Sp - --- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp. The --- block looks like this: --- --- middle_pre -- the middle nodes --- Sp = Sp + sp_off -- Sp adjustment goes here --- last -- the last node --- --- And we have some extra blocks too (that don't contain Sp adjustments) --- --- The adjustment for middle_pre will be different from that for --- middle_post, because the Sp adjustment intervenes. --- -manifestSp - :: DynFlags - -> LabelMap StackMap -- StackMaps for other blocks - -> StackMap -- StackMap for this block - -> ByteOff -- Sp on entry to the block - -> ByteOff -- SpHigh - -> CmmNode C O -- first node - -> [CmmNode O O] -- middle - -> ByteOff -- sp_off - -> CmmNode O C -- last node - -> [CmmBlock] -- new blocks - -> [CmmBlock] -- final blocks with Sp manifest - -manifestSp dflags stackmaps stack0 sp0 sp_high - first middle_pre sp_off last fixup_blocks - = final_block : fixup_blocks' - where - area_off = getAreaOff stackmaps - - adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x - adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off) - adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off) - - final_middle = maybeAddSpAdj dflags sp0 sp_off - . blockFromList - . map adj_pre_sp - . elimStackStores stack0 stackmaps area_off - $ middle_pre - final_last = optStackCheck (adj_post_sp last) - - final_block = blockJoin first final_middle final_last - - fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks - -getAreaOff :: LabelMap StackMap -> (Area -> StackLoc) -getAreaOff _ Old = 0 -getAreaOff stackmaps (Young l) = - case mapLookup l stackmaps of - Just sm -> sm_sp sm - sm_args sm - Nothing -> pprPanic "getAreaOff" (ppr l) - - -maybeAddSpAdj - :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O -maybeAddSpAdj dflags sp0 sp_off block = - add_initial_unwind $ add_adj_unwind $ adj block - where - adj block - | sp_off /= 0 - = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off) - | otherwise = block - -- Add unwind pseudo-instruction at the beginning of each block to - -- document Sp level for debugging - add_initial_unwind block - | debugLevel dflags > 0 - = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block - | otherwise - = block - where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags) - - -- Add unwind pseudo-instruction right after the Sp adjustment - -- if there is one. - add_adj_unwind block - | debugLevel dflags > 0 - , sp_off /= 0 - = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] - | otherwise - = block - where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off) - -{- Note [SP old/young offsets] - -Sp(L) is the Sp offset on entry to block L relative to the base of the -OLD area. - -SpArgs(L) is the size of the young area for L, i.e. the number of -arguments. - - - in block L, each reference to [old + N] turns into - [Sp + Sp(L) - N] - - - in block L, each reference to [young(L') + N] turns into - [Sp + Sp(L) - Sp(L') + SpArgs(L') - N] - - - be careful with the last node of each block: Sp has already been adjusted - to be Sp + Sp(L) - Sp(L') --} - -areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr - -areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) - = cmmOffset dflags spExpr (sp_old - area_off area - n) - -- Replace (CmmStackSlot area n) with an offset from Sp - -areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) - = mkIntExpr dflags sp_hwm - -- Replace CmmHighStackMark with the number of bytes of stack used, - -- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap - -areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args) - | falseStackCheck args - = zeroExpr dflags -areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args) - | falseStackCheck args - = mkIntExpr dflags 1 - -- Replace a stack-overflow test that cannot fail with a no-op - -- See Note [Always false stack check] - -areaToSp _ _ _ _ other = other - --- | Determine whether a stack check cannot fail. -falseStackCheck :: [CmmExpr] -> Bool -falseStackCheck [ CmmMachOp (MO_Sub _) - [ CmmRegOff (CmmGlobal Sp) x_off - , CmmLit (CmmInt y_lit _)] - , CmmReg (CmmGlobal SpLim)] - = fromIntegral x_off >= y_lit -falseStackCheck _ = False - --- Note [Always false stack check] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We can optimise stack checks of the form --- --- if ((Sp + x) - y < SpLim) then .. else .. --- --- where are non-negative integer byte offsets. Since we know that --- SpLim <= Sp (remember the stack grows downwards), this test must --- yield False if (x >= y), so we can rewrite the comparison to False. --- A subsequent sinking pass will later drop the dead code. --- Optimising this away depends on knowing that SpLim <= Sp, so it is --- really the job of the stack layout algorithm, hence we do it now. --- --- The control flow optimiser may negate a conditional to increase --- the likelihood of a fallthrough if the branch is not taken. But --- not every conditional is inverted as the control flow optimiser --- places some requirements on the predecessors of both branch targets. --- So we better look for the inverted comparison too. - -optStackCheck :: CmmNode O C -> CmmNode O C -optStackCheck n = -- Note [Always false stack check] - case n of - CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false - CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true - other -> other - - --- ----------------------------------------------------------------------------- - --- | Eliminate stores of the form --- --- Sp[area+n] = r --- --- when we know that r is already in the same slot as Sp[area+n]. We --- could do this in a later optimisation pass, but that would involve --- a separate analysis and we already have the information to hand --- here. It helps clean up some extra stack stores in common cases. --- --- Note that we may have to modify the StackMap as we walk through the --- code using procMiddle, since an assignment to a variable in the --- StackMap will invalidate its mapping there. --- -elimStackStores :: StackMap - -> LabelMap StackMap - -> (Area -> ByteOff) - -> [CmmNode O O] - -> [CmmNode O O] -elimStackStores stackmap stackmaps area_off nodes - = go stackmap nodes - where - go _stackmap [] = [] - go stackmap (n:ns) - = case n of - CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) - | Just (_,off) <- lookupUFM (sm_regs stackmap) r - , area_off area + m == off - -> go stackmap ns - _otherwise - -> n : go (procMiddle stackmaps n stackmap) ns - - --- ----------------------------------------------------------------------------- --- Update info tables to include stack liveness - - -setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl -setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g) - = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g - where - fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = - info_tbl { cit_rep = StackRep (get_liveness lbl) } - fix_info _ other = other - - get_liveness :: BlockId -> Liveness - get_liveness lbl - = case mapLookup lbl stackmaps of - Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls) - Just sm -> stackMapToLiveness dflags sm - -setInfoTableStackMap _ _ d = d - - -stackMapToLiveness :: DynFlags -> StackMap -> Liveness -stackMapToLiveness dflags StackMap{..} = - reverse $ Array.elems $ - accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1, - toWords dflags (sm_sp - sm_args)) live_words - where - live_words = [ (toWords dflags off, False) - | (r,off) <- nonDetEltsUFM sm_regs - , isGcPtrType (localRegType r) ] - -- See Note [Unique Determinism and code generation] - --- ----------------------------------------------------------------------------- --- Pass 2 --- ----------------------------------------------------------------------------- - -insertReloadsAsNeeded - :: DynFlags - -> ProcPointSet - -> LabelMap StackMap - -> BlockId - -> [CmmBlock] - -> UniqSM [CmmBlock] -insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do - toBlockList . fst <$> - rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty - where - rewriteCC :: RewriteFun CmmLocalLive - rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do - let entry_label = entryLabel e_node - stackmap = case mapLookup entry_label final_stackmaps of - Just sm -> sm - Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap" - - -- Merge the liveness from successor blocks and analyse the last - -- node. - joined = gen_kill dflags x_node $! - joinOutFacts liveLattice x_node fact_base0 - -- What is live at the start of middle0. - live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined - - -- If this is a procpoint we need to add the reloads, but only if - -- they're actually live. Furthermore, nothing is live at the entry - -- to a proc point. - (middle1, live_with_reloads) - | entry_label `setMember` procpoints - = let reloads = insertReloads dflags stackmap live_at_middle0 - in (foldr blockCons middle0 reloads, emptyRegSet) - | otherwise - = (middle0, live_at_middle0) - - -- Final liveness for this block. - !fact_base2 = mapSingleton entry_label live_with_reloads - - return (BlockCC e_node middle1 x_node, fact_base2) - -insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O] -insertReloads dflags stackmap live = - [ CmmAssign (CmmLocal reg) - -- This cmmOffset basically corresponds to manifesting - -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] - (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off)) - (localRegType reg)) - | (reg, reg_off) <- stackSlotRegs stackmap - , reg `elemRegSet` live - ] - where - sp_off = sm_sp stackmap - --- ----------------------------------------------------------------------------- --- Lowering safe foreign calls - -{- -Note [Lower safe foreign calls] - -We start with - - Sp[young(L1)] = L1 - ,----------------------- - | r1 = foo(x,y,z) returns to L1 - '----------------------- - L1: - R1 = r1 -- copyIn, inserted by mkSafeCall - ... - -the stack layout algorithm will arrange to save and reload everything -live across the call. Our job now is to expand the call so we get - - Sp[young(L1)] = L1 - ,----------------------- - | SAVE_THREAD_STATE() - | token = suspendThread(BaseReg, interruptible) - | r = foo(x,y,z) - | BaseReg = resumeThread(token) - | LOAD_THREAD_STATE() - | R1 = r -- copyOut - | jump Sp[0] - '----------------------- - L1: - r = R1 -- copyIn, inserted by mkSafeCall - ... - -Note the copyOut, which saves the results in the places that L1 is -expecting them (see Note [safe foreign call convention]). Note also -that safe foreign call is replace by an unsafe one in the Cmm graph. --} - -lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock -lowerSafeForeignCall dflags block - | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block - = do - -- Both 'id' and 'new_base' are KindNonPtr because they're - -- RTS-only objects and are not subject to garbage collection - id <- newTemp (bWord dflags) - new_base <- newTemp (cmmRegType dflags baseReg) - let (caller_save, caller_load) = callerSaveVolatileRegs dflags - save_state_code <- saveThreadState dflags - load_state_code <- loadThreadState dflags - let suspend = save_state_code <*> - caller_save <*> - mkMiddle (callSuspendThread dflags id intrbl) - midCall = mkUnsafeCall tgt res args - resume = mkMiddle (callResumeThread new_base id) <*> - -- Assign the result to BaseReg: we - -- might now have a different Capability! - mkAssign baseReg (CmmReg (CmmLocal new_base)) <*> - caller_load <*> - load_state_code - - (_, regs, copyout) = - copyOutOflow dflags NativeReturn Jump (Young succ) - (map (CmmReg . CmmLocal) res) - ret_off [] - - -- NB. after resumeThread returns, the top-of-stack probably contains - -- the stack frame for succ, but it might not: if the current thread - -- received an exception during the call, then the stack might be - -- different. Hence we continue by jumping to the top stack frame, - -- not by jumping to succ. - jump = CmmCall { cml_target = entryCode dflags $ - CmmLoad spExpr (bWord dflags) - , cml_cont = Just succ - , cml_args_regs = regs - , cml_args = widthInBytes (wordWidth dflags) - , cml_ret_args = ret_args - , cml_ret_off = ret_off } - - graph' <- lgraphOfAGraph ( suspend <*> - midCall <*> - resume <*> - copyout <*> - mkLast jump, tscp) - - case toBlockList graph' of - [one] -> let (_, middle', last) = blockSplit one - in return (blockJoin entry (middle `blockAppend` middle') last) - _ -> panic "lowerSafeForeignCall0" - - -- Block doesn't end in a safe foreign call: - | otherwise = return block - - -foreignLbl :: FastString -> CmmExpr -foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction)) - --- void * suspendThread (StgRegTable *, bool interruptible); -callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O -callSuspendThread dflags id intrbl = - CmmUnsafeForeignCall - (ForeignTarget (foreignLbl (fsLit "suspendThread")) - (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn AddrRep [AddrRep, Word32Rep])) - [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)] - --- StgRegTable * resumeThread (void *); -callResumeThread :: LocalReg -> LocalReg -> CmmNode O O -callResumeThread new_base id = - CmmUnsafeForeignCall - (ForeignTarget (foreignLbl (fsLit "resumeThread")) - (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn AddrRep [AddrRep])) - [new_base] [CmmReg (CmmLocal id)] - --- ----------------------------------------------------------------------------- - -plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff -plusW dflags b w = b + w * wORD_SIZE dflags - -data StackSlot = Occupied | Empty - -- Occupied: a return address or part of an update frame - -instance Outputable StackSlot where - ppr Occupied = text "XXX" - ppr Empty = text "---" - -dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] -dropEmpty 0 ss = Just ss -dropEmpty n (Empty : ss) = dropEmpty (n-1) ss -dropEmpty _ _ = Nothing - -isEmpty :: StackSlot -> Bool -isEmpty Empty = True -isEmpty _ = False - -localRegBytes :: DynFlags -> LocalReg -> ByteOff -localRegBytes dflags r - = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r))) - -localRegWords :: DynFlags -> LocalReg -> WordOff -localRegWords dflags = toWords dflags . localRegBytes dflags - -toWords :: DynFlags -> ByteOff -> WordOff -toWords dflags x = x `quot` wORD_SIZE dflags - - -stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)] -stackSlotRegs sm = nonDetEltsUFM (sm_regs sm) - -- See Note [Unique Determinism and code generation] diff --git a/cmm/CmmLex.x b/cmm/CmmLex.x deleted file mode 100644 --- a/cmm/CmmLex.x +++ /dev/null @@ -1,368 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow, 2004-2006 --- --- Lexer for concrete Cmm. We try to stay close to the C-- spec, but there --- are a few minor differences: --- --- * extra keywords for our macros, and float32/float64 types --- * global registers (Sp,Hp, etc.) --- ------------------------------------------------------------------------------ - -{ -module CmmLex ( - CmmToken(..), cmmlex, - ) where - -import GhcPrelude - -import CmmExpr - -import Lexer -import CmmMonad -import SrcLoc -import UniqFM -import StringBuffer -import FastString -import Ctype -import Util ---import TRACE - -import Data.Word -import Data.Char -} - -$whitechar = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space -$white_no_nl = $whitechar # \n - -$ascdigit = 0-9 -$unidigit = \x01 -- Trick Alex into handling Unicode. See alexGetChar. -$digit = [$ascdigit $unidigit] -$octit = 0-7 -$hexit = [$digit A-F a-f] - -$unilarge = \x03 -- Trick Alex into handling Unicode. See alexGetChar. -$asclarge = [A-Z \xc0-\xd6 \xd8-\xde] -$large = [$asclarge $unilarge] - -$unismall = \x04 -- Trick Alex into handling Unicode. See alexGetChar. -$ascsmall = [a-z \xdf-\xf6 \xf8-\xff] -$small = [$ascsmall $unismall \_] - -$namebegin = [$large $small \. \$ \@] -$namechar = [$namebegin $digit] - -@decimal = $digit+ -@octal = $octit+ -@hexadecimal = $hexit+ -@exponent = [eE] [\-\+]? @decimal - -@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent - -@escape = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3}) -@strchar = ($printable # [\"\\]) | @escape - -cmm :- - -$white_no_nl+ ; -^\# pragma .* \n ; -- Apple GCC 3.3 CPP generates pragmas in its output - -^\# (line)? { begin line_prag } - --- single-line line pragmas, of the form --- # "" \n - $digit+ { setLine line_prag1 } - \" [^\"]* \" { setFile line_prag2 } - .* { pop } - -<0> { - \n ; - - [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } - - ".." { kw CmmT_DotDot } - "::" { kw CmmT_DoubleColon } - ">>" { kw CmmT_Shr } - "<<" { kw CmmT_Shl } - ">=" { kw CmmT_Ge } - "<=" { kw CmmT_Le } - "==" { kw CmmT_Eq } - "!=" { kw CmmT_Ne } - "&&" { kw CmmT_BoolAnd } - "||" { kw CmmT_BoolOr } - - "True" { kw CmmT_True } - "False" { kw CmmT_False } - "likely" { kw CmmT_likely} - - P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } - R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } - F@decimal { global_regN FloatReg } - D@decimal { global_regN DoubleReg } - L@decimal { global_regN LongReg } - Sp { global_reg Sp } - SpLim { global_reg SpLim } - Hp { global_reg Hp } - HpLim { global_reg HpLim } - CCCS { global_reg CCCS } - CurrentTSO { global_reg CurrentTSO } - CurrentNursery { global_reg CurrentNursery } - HpAlloc { global_reg HpAlloc } - BaseReg { global_reg BaseReg } - MachSp { global_reg MachSp } - UnwindReturnReg { global_reg UnwindReturnReg } - - $namebegin $namechar* { name } - - 0 @octal { tok_octal } - @decimal { tok_decimal } - 0[xX] @hexadecimal { tok_hexadecimal } - @floating_point { strtoken tok_float } - - \" @strchar* \" { strtoken tok_string } -} - -{ -data CmmToken - = CmmT_SpecChar Char - | CmmT_DotDot - | CmmT_DoubleColon - | CmmT_Shr - | CmmT_Shl - | CmmT_Ge - | CmmT_Le - | CmmT_Eq - | CmmT_Ne - | CmmT_BoolAnd - | CmmT_BoolOr - | CmmT_CLOSURE - | CmmT_INFO_TABLE - | CmmT_INFO_TABLE_RET - | CmmT_INFO_TABLE_FUN - | CmmT_INFO_TABLE_CONSTR - | CmmT_INFO_TABLE_SELECTOR - | CmmT_else - | CmmT_export - | CmmT_section - | CmmT_goto - | CmmT_if - | CmmT_call - | CmmT_jump - | CmmT_foreign - | CmmT_never - | CmmT_prim - | CmmT_reserve - | CmmT_return - | CmmT_returns - | CmmT_import - | CmmT_switch - | CmmT_case - | CmmT_default - | CmmT_push - | CmmT_unwind - | CmmT_bits8 - | CmmT_bits16 - | CmmT_bits32 - | CmmT_bits64 - | CmmT_bits128 - | CmmT_bits256 - | CmmT_bits512 - | CmmT_float32 - | CmmT_float64 - | CmmT_gcptr - | CmmT_GlobalReg GlobalReg - | CmmT_Name FastString - | CmmT_String String - | CmmT_Int Integer - | CmmT_Float Rational - | CmmT_EOF - | CmmT_False - | CmmT_True - | CmmT_likely - deriving (Show) - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken) - -begin :: Int -> Action -begin code _span _str _len = do liftP (pushLexState code); lexToken - -pop :: Action -pop _span _buf _len = liftP popLexState >> lexToken - -special_char :: Action -special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) - -kw :: CmmToken -> Action -kw tok span _buf _len = return (L span tok) - -global_regN :: (Int -> GlobalReg) -> Action -global_regN con span buf len - = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) - where buf' = stepOn buf - n = parseUnsignedInteger buf' (len-1) 10 octDecDigit - -global_reg :: GlobalReg -> Action -global_reg r span _buf _len = return (L span (CmmT_GlobalReg r)) - -strtoken :: (String -> CmmToken) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -name :: Action -name span buf len = - case lookupUFM reservedWordsFM fs of - Just tok -> return (L span tok) - Nothing -> return (L span (CmmT_Name fs)) - where - fs = lexemeToFastString buf len - -reservedWordsFM = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "CLOSURE", CmmT_CLOSURE ), - ( "INFO_TABLE", CmmT_INFO_TABLE ), - ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), - ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), - ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), - ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), - ( "else", CmmT_else ), - ( "export", CmmT_export ), - ( "section", CmmT_section ), - ( "goto", CmmT_goto ), - ( "if", CmmT_if ), - ( "call", CmmT_call ), - ( "jump", CmmT_jump ), - ( "foreign", CmmT_foreign ), - ( "never", CmmT_never ), - ( "prim", CmmT_prim ), - ( "reserve", CmmT_reserve ), - ( "return", CmmT_return ), - ( "returns", CmmT_returns ), - ( "import", CmmT_import ), - ( "switch", CmmT_switch ), - ( "case", CmmT_case ), - ( "default", CmmT_default ), - ( "push", CmmT_push ), - ( "unwind", CmmT_unwind ), - ( "bits8", CmmT_bits8 ), - ( "bits16", CmmT_bits16 ), - ( "bits32", CmmT_bits32 ), - ( "bits64", CmmT_bits64 ), - ( "bits128", CmmT_bits128 ), - ( "bits256", CmmT_bits256 ), - ( "bits512", CmmT_bits512 ), - ( "float32", CmmT_float32 ), - ( "float64", CmmT_float64 ), --- New forms - ( "b8", CmmT_bits8 ), - ( "b16", CmmT_bits16 ), - ( "b32", CmmT_bits32 ), - ( "b64", CmmT_bits64 ), - ( "b128", CmmT_bits128 ), - ( "b256", CmmT_bits256 ), - ( "b512", CmmT_bits512 ), - ( "f32", CmmT_float32 ), - ( "f64", CmmT_float64 ), - ( "gcptr", CmmT_gcptr ), - ( "likely", CmmT_likely), - ( "True", CmmT_True ), - ( "False", CmmT_False ) - ] - -tok_decimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) - -tok_octal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) - -tok_hexadecimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) - -tok_float str = CmmT_Float $! readRational str - -tok_string str = CmmT_String (read str) - -- urk, not quite right, but it'll do for now - --- ----------------------------------------------------------------------------- --- Line pragmas - -setLine :: Int -> Action -setLine code span buf len = do - let line = parseUnsignedInteger buf len 10 octDecDigit - liftP $ do - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line - -- trace ("setLine " ++ show line) $ do - popLexState >> pushLexState code - lexToken - -setFile :: Int -> Action -setFile code span buf len = do - let file = lexemeToFastString (stepOn buf) (len-2) - liftP $ do - setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - popLexState >> pushLexState code - lexToken - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -cmmlex :: (Located CmmToken -> PD a) -> PD a -cmmlex cont = do - (L span tok) <- lexToken - --trace ("token: " ++ show tok) $ do - cont (L (RealSrcSpan span) tok) - -lexToken :: PD (RealLocated CmmToken) -lexToken = do - inp@(loc1,buf) <- getInput - sc <- liftP getLexState - case alexScan inp sc of - AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 - liftP (setLastToken span 0) - return (L span CmmT_EOF) - AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error" - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(end,_buf2) len t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - span `seq` liftP (setLastToken span len) - t span buf len - --- ----------------------------------------------------------------------------- --- Monad stuff - --- Stuff that Alex needs to know about our input type: -type AlexInput = (RealSrcLoc,StringBuffer) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (_,s) = prevChar s '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (loc,s) - | atEnd s = Nothing - | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) - where c = currentChar s - b = fromIntegral $ ord $ c - loc' = advanceSrcLoc loc c - s' = stepOn s - -getInput :: PD AlexInput -getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b) - -setInput :: AlexInput -> PD () -setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } () -} diff --git a/cmm/CmmLint.hs b/cmm/CmmLint.hs deleted file mode 100644 --- a/cmm/CmmLint.hs +++ /dev/null @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2011 --- --- CmmLint: checking the correctness of Cmm statements and expressions --- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GADTs #-} -module CmmLint ( - cmmLint, cmmLintGraph - ) where - -import GhcPrelude - -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Graph -import Hoopl.Label -import Cmm -import CmmUtils -import CmmLive -import CmmSwitch (switchTargetsToList) -import PprCmm () -- For Outputable instances -import Outputable -import DynFlags - -import Control.Monad (ap) - --- Things to check: --- - invariant on CmmBlock in CmmExpr (see comment there) --- - check for branches to blocks that don't exist --- - check types - --- ----------------------------------------------------------------------------- --- Exported entry points: - -cmmLint :: (Outputable d, Outputable h) - => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops - -cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc -cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g - -runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint dflags l p = - case unCL (l p) dflags of - Left err -> Just (vcat [text "Cmm lint error:", - nest 2 err, - text "Program was:", - nest 2 (ppr p)]) - Right _ -> Nothing - -lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl _ g) - = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g -lintCmmDecl _ (CmmData {}) - = return () - - -lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint () -lintCmmGraph dflags g = - cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks - -- cmmLiveness throws an error if there are registers - -- live on entry to the graph (i.e. undefined - -- variables) - where - blocks = toBlockList g - labels = setFromList (map entryLabel blocks) - - -lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint () -lintCmmBlock labels block - = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do - let (_, middle, last) = blockSplit block - mapM_ lintCmmMiddle (blockToList middle) - lintCmmLast labels last - --- ----------------------------------------------------------------------------- --- lintCmmExpr - --- Checks whether a CmmExpr is "type-correct", and check for obvious-looking --- byte/word mismatches. - -lintCmmExpr :: CmmExpr -> CmmLint CmmType -lintCmmExpr (CmmLoad expr rep) = do - _ <- lintCmmExpr expr - -- Disabled, if we have the inlining phase before the lint phase, - -- we can have funny offsets due to pointer tagging. -- EZY - -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ - -- cmmCheckWordAddress expr - return rep -lintCmmExpr expr@(CmmMachOp op args) = do - dflags <- getDynFlags - tys <- mapM lintCmmExpr args - if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op - then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) -lintCmmExpr (CmmRegOff reg offset) - = do dflags <- getDynFlags - let rep = typeWidth (cmmRegType dflags reg) - lintCmmExpr (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) -lintCmmExpr expr = - do dflags <- getDynFlags - return (cmmExprType dflags expr) - --- Check for some common byte/word mismatches (eg. Sp + 1) -cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType -cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys - = cmmCheckMachOp op [reg, lit] tys -cmmCheckMachOp op _ tys - = do dflags <- getDynFlags - return (machOpResultType dflags op tys) - -{- -isOffsetOp :: MachOp -> Bool -isOffsetOp (MO_Add _) = True -isOffsetOp (MO_Sub _) = True -isOffsetOp _ = False - --- This expression should be an address from which a word can be loaded: --- check for funny-looking sub-word offsets. -_cmmCheckWordAddress :: CmmExpr -> CmmLint () -_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress _ - = return () - --- No warnings for unaligned arithmetic with the node register, --- which is used to extract fields from tagged constructor closures. -notNodeReg :: CmmExpr -> Bool -notNodeReg (CmmReg reg) | reg == nodeReg = False -notNodeReg _ = True --} - -lintCmmMiddle :: CmmNode O O -> CmmLint () -lintCmmMiddle node = case node of - CmmComment _ -> return () - CmmTick _ -> return () - CmmUnwind{} -> return () - - CmmAssign reg expr -> do - dflags <- getDynFlags - erep <- lintCmmExpr expr - let reg_ty = cmmRegType dflags reg - if (erep `cmmEqType_ignoring_ptrhood` reg_ty) - then return () - else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty - - CmmStore l r -> do - _ <- lintCmmExpr l - _ <- lintCmmExpr r - return () - - CmmUnsafeForeignCall target _formals actuals -> do - lintTarget target - mapM_ lintCmmExpr actuals - - -lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint () -lintCmmLast labels node = case node of - CmmBranch id -> checkTarget id - - CmmCondBranch e t f _ -> do - dflags <- getDynFlags - mapM_ checkTarget [t,f] - _ <- lintCmmExpr e - checkCond dflags e - - CmmSwitch e ids -> do - dflags <- getDynFlags - mapM_ checkTarget $ switchTargetsToList ids - erep <- lintCmmExpr e - if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) - then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> - ppr e <> text " :: " <> ppr erep) - - CmmCall { cml_target = target, cml_cont = cont } -> do - _ <- lintCmmExpr target - maybe (return ()) checkTarget cont - - CmmForeignCall tgt _ args succ _ _ _ -> do - lintTarget tgt - mapM_ lintCmmExpr args - checkTarget succ - where - checkTarget id - | setMember id labels = return () - | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) - - -lintTarget :: ForeignTarget -> CmmLint () -lintTarget (ForeignTarget e _) = lintCmmExpr e >> return () -lintTarget (PrimTarget {}) = return () - - -checkCond :: DynFlags -> CmmExpr -> CmmLint () -checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values -checkCond _ expr - = cmmLintErr (hang (text "expression is not a conditional:") 2 - (ppr expr)) - --- ----------------------------------------------------------------------------- --- CmmLint monad - --- just a basic error monad: - -newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } - deriving (Functor) - -instance Applicative CmmLint where - pure a = CmmLint (\_ -> Right a) - (<*>) = ap - -instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ \dflags -> - case m dflags of - Left e -> Left e - Right a -> unCL (k a) dflags - -instance HasDynFlags CmmLint where - getDynFlags = CmmLint (\dflags -> Right dflags) - -cmmLintErr :: SDoc -> CmmLint a -cmmLintErr msg = CmmLint (\_ -> Left msg) - -addLintInfo :: SDoc -> CmmLint a -> CmmLint a -addLintInfo info thing = CmmLint $ \dflags -> - case unCL thing dflags of - Left err -> Left (hang info 2 err) - Right a -> Right a - -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep - = cmmLintErr (text "in MachOp application: " $$ - nest 2 (ppr expr) $$ - (text "op is expecting: " <+> ppr opExpectsRep) $$ - (text "arguments provide: " <+> ppr argsRep)) - -cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a -cmmLintAssignErr stmt e_ty r_ty - = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [ppr stmt, - text "Reg ty:" <+> ppr r_ty, - text "Rhs ty:" <+> ppr e_ty])) - - -{- -cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a -cmmLintDubiousWordOffset expr - = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (ppr expr)) --} - diff --git a/cmm/CmmLive.hs b/cmm/CmmLive.hs deleted file mode 100644 --- a/cmm/CmmLive.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module CmmLive - ( CmmLocalLive - , cmmLocalLiveness - , cmmGlobalLiveness - , liveLattice - , gen_kill - ) -where - -import GhcPrelude - -import DynFlags -import BlockId -import Cmm -import PprCmmExpr () -- For Outputable instances -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Dataflow -import Hoopl.Label - -import Maybes -import Outputable - ------------------------------------------------------------------------------ --- Calculating what variables are live on entry to a basic block ------------------------------------------------------------------------------ - --- | The variables live on entry to a block -type CmmLive r = RegSet r -type CmmLocalLive = CmmLive LocalReg - --- | The dataflow lattice -liveLattice :: Ord r => DataflowLattice (CmmLive r) -{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-} -{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-} -liveLattice = DataflowLattice emptyRegSet add - where - add (OldFact old) (NewFact new) = - let !join = plusRegSet old new - in changedIf (sizeRegSet join > sizeRegSet old) join - --- | A mapping from block labels to the variables live on entry -type BlockEntryLiveness r = LabelMap (CmmLive r) - ------------------------------------------------------------------------------ --- | Calculated liveness info for a CmmGraph ------------------------------------------------------------------------------ - -cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg -cmmLocalLiveness dflags graph = - check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty - where - entry = g_entry graph - check facts = - noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts - -cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg -cmmGlobalLiveness dflags graph = - analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty - --- | On entry to the procedure, there had better not be any LocalReg's live-in. -noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a -noLiveOnEntry bid in_fact x = - if nullRegSet in_fact then x - else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) - -gen_kill - :: (DefinerOfRegs r n, UserOfRegs r n) - => DynFlags -> n -> CmmLive r -> CmmLive r -gen_kill dflags node set = - let !afterKill = foldRegsDefd dflags deleteFromRegSet set node - in foldRegsUsed dflags extendRegSet afterKill node -{-# INLINE gen_kill #-} - -xferLive - :: forall r. - ( UserOfRegs r (CmmNode O O) - , DefinerOfRegs r (CmmNode O O) - , UserOfRegs r (CmmNode O C) - , DefinerOfRegs r (CmmNode O C) - ) - => DynFlags -> TransferFun (CmmLive r) -xferLive dflags (BlockCC eNode middle xNode) fBase = - let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase - !result = foldNodesBwdOO (gen_kill dflags) middle joined - in mapSingleton (entryLabel eNode) result -{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-} -{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-} diff --git a/cmm/CmmMachOp.hs b/cmm/CmmMachOp.hs deleted file mode 100644 --- a/cmm/CmmMachOp.hs +++ /dev/null @@ -1,752 +0,0 @@ -module CmmMachOp - ( MachOp(..) - , pprMachOp, isCommutableMachOp, isAssociativeMachOp - , isComparisonMachOp, maybeIntComparison, machOpResultType - , machOpArgReps, maybeInvertComparison, isFloatComparison - - -- MachOp builders - , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot - , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem - , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe - , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot - , mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord - , mo_u_32ToWord, mo_s_32ToWord - , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 - - -- CallishMachOp - , CallishMachOp(..), callishMachOpHints, callishMachOpReps - , pprCallishMachOp - , machOpMemcpyishAlign - - -- Atomic read-modify-write - , AtomicMachOp(..) - ) -where - -import GhcPrelude - -import CmmType -import Outputable -import DynFlags - -import TyCon (PrimRep (..)) - ------------------------------------------------------------------------------ --- MachOp ------------------------------------------------------------------------------ - -{- | -Machine-level primops; ones which we can reasonably delegate to the -native code generators to handle. - -Most operations are parameterised by the 'Width' that they operate on. -Some operations have separate signed and unsigned versions, and float -and integer versions. - -Note that there are variety of places in the native code generator where we -assume that the code produced for a MachOp does not introduce new blocks. --} - -data MachOp - -- Integer operations (insensitive to signed/unsigned) - = MO_Add Width - | MO_Sub Width - | MO_Eq Width - | MO_Ne Width - | MO_Mul Width -- low word of multiply - - -- Signed multiply/divide - | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows - | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) - | MO_S_Rem Width -- signed % (same semantics as IntRemOp) - | MO_S_Neg Width -- unary - - - -- Unsigned multiply/divide - | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows - | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) - | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) - - -- Signed comparisons - | MO_S_Ge Width - | MO_S_Le Width - | MO_S_Gt Width - | MO_S_Lt Width - - -- Unsigned comparisons - | MO_U_Ge Width - | MO_U_Le Width - | MO_U_Gt Width - | MO_U_Lt Width - - -- Floating point arithmetic - | MO_F_Add Width - | MO_F_Sub Width - | MO_F_Neg Width -- unary - - | MO_F_Mul Width - | MO_F_Quot Width - - -- Floating point comparison - | MO_F_Eq Width - | MO_F_Ne Width - | MO_F_Ge Width - | MO_F_Le Width - | MO_F_Gt Width - | MO_F_Lt Width - - -- Bitwise operations. Not all of these may be supported - -- at all sizes, and only integral Widths are valid. - | MO_And Width - | MO_Or Width - | MO_Xor Width - | MO_Not Width - | MO_Shl Width - | MO_U_Shr Width -- unsigned shift right - | MO_S_Shr Width -- signed shift right - - -- Conversions. Some of these will be NOPs. - -- Floating-point conversions use the signed variant. - | MO_SF_Conv Width Width -- Signed int -> Float - | MO_FS_Conv Width Width -- Float -> Signed int - | MO_SS_Conv Width Width -- Signed int -> Signed int - | MO_UU_Conv Width Width -- unsigned int -> unsigned int - | MO_XX_Conv Width Width -- int -> int; puts no requirements on the - -- contents of upper bits when extending; - -- narrowing is simply truncation; the only - -- expectation is that we can recover the - -- original value by applying the opposite - -- MO_XX_Conv, e.g., - -- MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x) - -- is equivalent to just x. - | MO_FF_Conv Width Width -- Float -> Float - - -- Vector element insertion and extraction operations - | MO_V_Insert Length Width -- Insert scalar into vector - | MO_V_Extract Length Width -- Extract scalar from vector - - -- Integer vector operations - | MO_V_Add Length Width - | MO_V_Sub Length Width - | MO_V_Mul Length Width - - -- Signed vector multiply/divide - | MO_VS_Quot Length Width - | MO_VS_Rem Length Width - | MO_VS_Neg Length Width - - -- Unsigned vector multiply/divide - | MO_VU_Quot Length Width - | MO_VU_Rem Length Width - - -- Floting point vector element insertion and extraction operations - | MO_VF_Insert Length Width -- Insert scalar into vector - | MO_VF_Extract Length Width -- Extract scalar from vector - - -- Floating point vector operations - | MO_VF_Add Length Width - | MO_VF_Sub Length Width - | MO_VF_Neg Length Width -- unary negation - | MO_VF_Mul Length Width - | MO_VF_Quot Length Width - - -- Alignment check (for -falignment-sanitisation) - | MO_AlignmentCheck Int Width - deriving (Eq, Show) - -pprMachOp :: MachOp -> SDoc -pprMachOp mo = text (show mo) - - - --- ----------------------------------------------------------------------------- --- Some common MachReps - --- A 'wordRep' is a machine word on the target architecture --- Specifically, it is the size of an Int#, Word#, Addr# --- and the unit of allocation on the stack and the heap --- Any pointer is also guaranteed to be a wordRep. - -mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot - , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem - , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe - , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord - , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 - :: DynFlags -> MachOp - -mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_32To8, mo_32To16 - :: MachOp - -mo_wordAdd dflags = MO_Add (wordWidth dflags) -mo_wordSub dflags = MO_Sub (wordWidth dflags) -mo_wordEq dflags = MO_Eq (wordWidth dflags) -mo_wordNe dflags = MO_Ne (wordWidth dflags) -mo_wordMul dflags = MO_Mul (wordWidth dflags) -mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags) -mo_wordSRem dflags = MO_S_Rem (wordWidth dflags) -mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags) -mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags) -mo_wordURem dflags = MO_U_Rem (wordWidth dflags) - -mo_wordSGe dflags = MO_S_Ge (wordWidth dflags) -mo_wordSLe dflags = MO_S_Le (wordWidth dflags) -mo_wordSGt dflags = MO_S_Gt (wordWidth dflags) -mo_wordSLt dflags = MO_S_Lt (wordWidth dflags) - -mo_wordUGe dflags = MO_U_Ge (wordWidth dflags) -mo_wordULe dflags = MO_U_Le (wordWidth dflags) -mo_wordUGt dflags = MO_U_Gt (wordWidth dflags) -mo_wordULt dflags = MO_U_Lt (wordWidth dflags) - -mo_wordAnd dflags = MO_And (wordWidth dflags) -mo_wordOr dflags = MO_Or (wordWidth dflags) -mo_wordXor dflags = MO_Xor (wordWidth dflags) -mo_wordNot dflags = MO_Not (wordWidth dflags) -mo_wordShl dflags = MO_Shl (wordWidth dflags) -mo_wordSShr dflags = MO_S_Shr (wordWidth dflags) -mo_wordUShr dflags = MO_U_Shr (wordWidth dflags) - -mo_u_8To32 = MO_UU_Conv W8 W32 -mo_s_8To32 = MO_SS_Conv W8 W32 -mo_u_16To32 = MO_UU_Conv W16 W32 -mo_s_16To32 = MO_SS_Conv W16 W32 - -mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags) -mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags) -mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags) -mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags) -mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags) -mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags) - -mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8 -mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16 -mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32 -mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64 - -mo_32To8 = MO_UU_Conv W32 W8 -mo_32To16 = MO_UU_Conv W32 W16 - - --- ---------------------------------------------------------------------------- --- isCommutableMachOp - -{- | -Returns 'True' if the MachOp has commutable arguments. This is used -in the platform-independent Cmm optimisations. - -If in doubt, return 'False'. This generates worse code on the -native routes, but is otherwise harmless. --} -isCommutableMachOp :: MachOp -> Bool -isCommutableMachOp mop = - case mop of - MO_Add _ -> True - MO_Eq _ -> True - MO_Ne _ -> True - MO_Mul _ -> True - MO_S_MulMayOflo _ -> True - MO_U_MulMayOflo _ -> True - MO_And _ -> True - MO_Or _ -> True - MO_Xor _ -> True - MO_F_Add _ -> True - MO_F_Mul _ -> True - _other -> False - --- ---------------------------------------------------------------------------- --- isAssociativeMachOp - -{- | -Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@) -This is used in the platform-independent Cmm optimisations. - -If in doubt, return 'False'. This generates worse code on the -native routes, but is otherwise harmless. --} -isAssociativeMachOp :: MachOp -> Bool -isAssociativeMachOp mop = - case mop of - MO_Add {} -> True -- NB: does not include - MO_Mul {} -> True -- floatint point! - MO_And {} -> True - MO_Or {} -> True - MO_Xor {} -> True - _other -> False - - --- ---------------------------------------------------------------------------- --- isComparisonMachOp - -{- | -Returns 'True' if the MachOp is a comparison. - -If in doubt, return False. This generates worse code on the -native routes, but is otherwise harmless. --} -isComparisonMachOp :: MachOp -> Bool -isComparisonMachOp mop = - case mop of - MO_Eq _ -> True - MO_Ne _ -> True - MO_S_Ge _ -> True - MO_S_Le _ -> True - MO_S_Gt _ -> True - MO_S_Lt _ -> True - MO_U_Ge _ -> True - MO_U_Le _ -> True - MO_U_Gt _ -> True - MO_U_Lt _ -> True - MO_F_Eq {} -> True - MO_F_Ne {} -> True - MO_F_Ge {} -> True - MO_F_Le {} -> True - MO_F_Gt {} -> True - MO_F_Lt {} -> True - _other -> False - -{- | -Returns @Just w@ if the operation is an integer comparison with width -@w@, or @Nothing@ otherwise. --} -maybeIntComparison :: MachOp -> Maybe Width -maybeIntComparison mop = - case mop of - MO_Eq w -> Just w - MO_Ne w -> Just w - MO_S_Ge w -> Just w - MO_S_Le w -> Just w - MO_S_Gt w -> Just w - MO_S_Lt w -> Just w - MO_U_Ge w -> Just w - MO_U_Le w -> Just w - MO_U_Gt w -> Just w - MO_U_Lt w -> Just w - _ -> Nothing - -isFloatComparison :: MachOp -> Bool -isFloatComparison mop = - case mop of - MO_F_Eq {} -> True - MO_F_Ne {} -> True - MO_F_Ge {} -> True - MO_F_Le {} -> True - MO_F_Gt {} -> True - MO_F_Lt {} -> True - _other -> False - --- ----------------------------------------------------------------------------- --- Inverting conditions - --- Sometimes it's useful to be able to invert the sense of a --- condition. Not all conditional tests are invertible: in --- particular, floating point conditionals cannot be inverted, because --- there exist floating-point values which return False for both senses --- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). - -maybeInvertComparison :: MachOp -> Maybe MachOp -maybeInvertComparison op - = case op of -- None of these Just cases include floating point - MO_Eq r -> Just (MO_Ne r) - MO_Ne r -> Just (MO_Eq r) - MO_U_Lt r -> Just (MO_U_Ge r) - MO_U_Gt r -> Just (MO_U_Le r) - MO_U_Le r -> Just (MO_U_Gt r) - MO_U_Ge r -> Just (MO_U_Lt r) - MO_S_Lt r -> Just (MO_S_Ge r) - MO_S_Gt r -> Just (MO_S_Le r) - MO_S_Le r -> Just (MO_S_Gt r) - MO_S_Ge r -> Just (MO_S_Lt r) - _other -> Nothing - --- ---------------------------------------------------------------------------- --- machOpResultType - -{- | -Returns the MachRep of the result of a MachOp. --} -machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType -machOpResultType dflags mop tys = - case mop of - MO_Add {} -> ty1 -- Preserve GC-ptr-hood - MO_Sub {} -> ty1 -- of first arg - MO_Mul r -> cmmBits r - MO_S_MulMayOflo r -> cmmBits r - MO_S_Quot r -> cmmBits r - MO_S_Rem r -> cmmBits r - MO_S_Neg r -> cmmBits r - MO_U_MulMayOflo r -> cmmBits r - MO_U_Quot r -> cmmBits r - MO_U_Rem r -> cmmBits r - - MO_Eq {} -> comparisonResultRep dflags - MO_Ne {} -> comparisonResultRep dflags - MO_S_Ge {} -> comparisonResultRep dflags - MO_S_Le {} -> comparisonResultRep dflags - MO_S_Gt {} -> comparisonResultRep dflags - MO_S_Lt {} -> comparisonResultRep dflags - - MO_U_Ge {} -> comparisonResultRep dflags - MO_U_Le {} -> comparisonResultRep dflags - MO_U_Gt {} -> comparisonResultRep dflags - MO_U_Lt {} -> comparisonResultRep dflags - - MO_F_Add r -> cmmFloat r - MO_F_Sub r -> cmmFloat r - MO_F_Mul r -> cmmFloat r - MO_F_Quot r -> cmmFloat r - MO_F_Neg r -> cmmFloat r - MO_F_Eq {} -> comparisonResultRep dflags - MO_F_Ne {} -> comparisonResultRep dflags - MO_F_Ge {} -> comparisonResultRep dflags - MO_F_Le {} -> comparisonResultRep dflags - MO_F_Gt {} -> comparisonResultRep dflags - MO_F_Lt {} -> comparisonResultRep dflags - - MO_And {} -> ty1 -- Used for pointer masking - MO_Or {} -> ty1 - MO_Xor {} -> ty1 - MO_Not r -> cmmBits r - MO_Shl r -> cmmBits r - MO_U_Shr r -> cmmBits r - MO_S_Shr r -> cmmBits r - - MO_SS_Conv _ to -> cmmBits to - MO_UU_Conv _ to -> cmmBits to - MO_XX_Conv _ to -> cmmBits to - MO_FS_Conv _ to -> cmmBits to - MO_SF_Conv _ to -> cmmFloat to - MO_FF_Conv _ to -> cmmFloat to - - MO_V_Insert l w -> cmmVec l (cmmBits w) - MO_V_Extract _ w -> cmmBits w - - MO_V_Add l w -> cmmVec l (cmmBits w) - MO_V_Sub l w -> cmmVec l (cmmBits w) - MO_V_Mul l w -> cmmVec l (cmmBits w) - - MO_VS_Quot l w -> cmmVec l (cmmBits w) - MO_VS_Rem l w -> cmmVec l (cmmBits w) - MO_VS_Neg l w -> cmmVec l (cmmBits w) - - MO_VU_Quot l w -> cmmVec l (cmmBits w) - MO_VU_Rem l w -> cmmVec l (cmmBits w) - - MO_VF_Insert l w -> cmmVec l (cmmFloat w) - MO_VF_Extract _ w -> cmmFloat w - - MO_VF_Add l w -> cmmVec l (cmmFloat w) - MO_VF_Sub l w -> cmmVec l (cmmFloat w) - MO_VF_Mul l w -> cmmVec l (cmmFloat w) - MO_VF_Quot l w -> cmmVec l (cmmFloat w) - MO_VF_Neg l w -> cmmVec l (cmmFloat w) - - MO_AlignmentCheck _ _ -> ty1 - where - (ty1:_) = tys - -comparisonResultRep :: DynFlags -> CmmType -comparisonResultRep = bWord -- is it? - - --- ----------------------------------------------------------------------------- --- machOpArgReps - --- | This function is used for debugging only: we can check whether an --- application of a MachOp is "type-correct" by checking that the MachReps of --- its arguments are the same as the MachOp expects. This is used when --- linting a CmmExpr. - -machOpArgReps :: DynFlags -> MachOp -> [Width] -machOpArgReps dflags op = - case op of - MO_Add r -> [r,r] - MO_Sub r -> [r,r] - MO_Eq r -> [r,r] - MO_Ne r -> [r,r] - MO_Mul r -> [r,r] - MO_S_MulMayOflo r -> [r,r] - MO_S_Quot r -> [r,r] - MO_S_Rem r -> [r,r] - MO_S_Neg r -> [r] - MO_U_MulMayOflo r -> [r,r] - MO_U_Quot r -> [r,r] - MO_U_Rem r -> [r,r] - - MO_S_Ge r -> [r,r] - MO_S_Le r -> [r,r] - MO_S_Gt r -> [r,r] - MO_S_Lt r -> [r,r] - - MO_U_Ge r -> [r,r] - MO_U_Le r -> [r,r] - MO_U_Gt r -> [r,r] - MO_U_Lt r -> [r,r] - - MO_F_Add r -> [r,r] - MO_F_Sub r -> [r,r] - MO_F_Mul r -> [r,r] - MO_F_Quot r -> [r,r] - MO_F_Neg r -> [r] - MO_F_Eq r -> [r,r] - MO_F_Ne r -> [r,r] - MO_F_Ge r -> [r,r] - MO_F_Le r -> [r,r] - MO_F_Gt r -> [r,r] - MO_F_Lt r -> [r,r] - - MO_And r -> [r,r] - MO_Or r -> [r,r] - MO_Xor r -> [r,r] - MO_Not r -> [r] - MO_Shl r -> [r, wordWidth dflags] - MO_U_Shr r -> [r, wordWidth dflags] - MO_S_Shr r -> [r, wordWidth dflags] - - MO_SS_Conv from _ -> [from] - MO_UU_Conv from _ -> [from] - MO_XX_Conv from _ -> [from] - MO_SF_Conv from _ -> [from] - MO_FS_Conv from _ -> [from] - MO_FF_Conv from _ -> [from] - - MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags] - MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth dflags] - - MO_V_Add _ r -> [r,r] - MO_V_Sub _ r -> [r,r] - MO_V_Mul _ r -> [r,r] - - MO_VS_Quot _ r -> [r,r] - MO_VS_Rem _ r -> [r,r] - MO_VS_Neg _ r -> [r] - - MO_VU_Quot _ r -> [r,r] - MO_VU_Rem _ r -> [r,r] - - MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags] - MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags] - - MO_VF_Add _ r -> [r,r] - MO_VF_Sub _ r -> [r,r] - MO_VF_Mul _ r -> [r,r] - MO_VF_Quot _ r -> [r,r] - MO_VF_Neg _ r -> [r] - - MO_AlignmentCheck _ r -> [r] - ------------------------------------------------------------------------------ --- CallishMachOp ------------------------------------------------------------------------------ - --- CallishMachOps tend to be implemented by foreign calls in some backends, --- so we separate them out. In Cmm, these can only occur in a --- statement position, in contrast to an ordinary MachOp which can occur --- anywhere in an expression. -data CallishMachOp - = MO_F64_Pwr - | MO_F64_Sin - | MO_F64_Cos - | MO_F64_Tan - | MO_F64_Sinh - | MO_F64_Cosh - | MO_F64_Tanh - | MO_F64_Asin - | MO_F64_Acos - | MO_F64_Atan - | MO_F64_Asinh - | MO_F64_Acosh - | MO_F64_Atanh - | MO_F64_Log - | MO_F64_Log1P - | MO_F64_Exp - | MO_F64_ExpM1 - | MO_F64_Fabs - | MO_F64_Sqrt - | MO_F32_Pwr - | MO_F32_Sin - | MO_F32_Cos - | MO_F32_Tan - | MO_F32_Sinh - | MO_F32_Cosh - | MO_F32_Tanh - | MO_F32_Asin - | MO_F32_Acos - | MO_F32_Atan - | MO_F32_Asinh - | MO_F32_Acosh - | MO_F32_Atanh - | MO_F32_Log - | MO_F32_Log1P - | MO_F32_Exp - | MO_F32_ExpM1 - | MO_F32_Fabs - | MO_F32_Sqrt - - | MO_UF_Conv Width - - | MO_S_QuotRem Width - | MO_U_QuotRem Width - | MO_U_QuotRem2 Width - | MO_Add2 Width - | MO_AddWordC Width - | MO_SubWordC Width - | MO_AddIntC Width - | MO_SubIntC Width - | MO_U_Mul2 Width - - | MO_ReadBarrier - | MO_WriteBarrier - | MO_Touch -- Keep variables live (when using interior pointers) - - -- Prefetch - | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not - -- program behavior. - -- the Int can be 0-3. Needs to be known at compile time - -- to interact with code generation correctly. - -- TODO: add support for prefetch WRITES, - -- currently only exposes prefetch reads, which - -- would the majority of use cases in ghc anyways - - - -- These three MachOps are parameterised by the known alignment - -- of the destination and source (for memcpy/memmove) pointers. - -- This information may be used for optimisation in backends. - | MO_Memcpy Int - | MO_Memset Int - | MO_Memmove Int - | MO_Memcmp Int - - | MO_PopCnt Width - | MO_Pdep Width - | MO_Pext Width - | MO_Clz Width - | MO_Ctz Width - - | MO_BSwap Width - | MO_BRev Width - - -- Atomic read-modify-write. - | MO_AtomicRMW Width AtomicMachOp - | MO_AtomicRead Width - | MO_AtomicWrite Width - | MO_Cmpxchg Width - deriving (Eq, Show) - --- | The operation to perform atomically. -data AtomicMachOp = - AMO_Add - | AMO_Sub - | AMO_And - | AMO_Nand - | AMO_Or - | AMO_Xor - deriving (Eq, Show) - -pprCallishMachOp :: CallishMachOp -> SDoc -pprCallishMachOp mo = text (show mo) - -callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint]) -callishMachOpHints op = case op of - -- void * memcpy(void *restrict dst, const void *restrict src, size_t n); - MO_Memcpy _ -> ([], [AddrHint, AddrHint, NoHint]) - -- void * memset(void *b, int c, size_t len); - MO_Memset _ -> ([], [AddrHint, SignedHint, NoHint]) - -- void * memmove(void *dst, const void *src, size_t len); - MO_Memmove _ -> ([], [AddrHint, AddrHint, NoHint]) - -- int memcmp(const void *s1, const void *s2, size_t n); - MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint]) - _ -> ([],[]) - -- empty lists indicate NoHint - --- be very careful when setting signatures. --- C int's need to be Int32Rep. Not IntRep, IntRep is --- GHC's always Word sized int. Ideally we'd have some --- CIntRep, but we don't. -callishMachOpReps :: CallishMachOp -> (PrimRep, [PrimRep]) -callishMachOpReps op = case op of - MO_Memcpy _ -> (AddrRep, [AddrRep, AddrRep, WordRep]) - MO_Memset _ -> (AddrRep, [AddrRep, Int32Rep, WordRep]) - MO_Memmove _ -> (AddrRep, [AddrRep, AddrRep, WordRep]) - MO_Memcmp _ -> (Int32Rep, [AddrRep, AddrRep, WordRep]) - - MO_F64_Pwr -> (DoubleRep, [DoubleRep, DoubleRep]) - - MO_F64_Sin -> (DoubleRep, [DoubleRep]) - MO_F64_Cos -> (DoubleRep, [DoubleRep]) - MO_F64_Tan -> (DoubleRep, [DoubleRep]) - - MO_F64_Sinh -> (DoubleRep, [DoubleRep]) - MO_F64_Cosh -> (DoubleRep, [DoubleRep]) - MO_F64_Tanh -> (DoubleRep, [DoubleRep]) - - MO_F64_Asin -> (DoubleRep, [DoubleRep]) - MO_F64_Acos -> (DoubleRep, [DoubleRep]) - MO_F64_Atan -> (DoubleRep, [DoubleRep]) - - MO_F64_Asinh -> (DoubleRep, [DoubleRep]) - MO_F64_Acosh -> (DoubleRep, [DoubleRep]) - MO_F64_Atanh -> (DoubleRep, [DoubleRep]) - - MO_F64_Log -> (DoubleRep, [DoubleRep]) - MO_F64_Log1P -> (DoubleRep, [DoubleRep]) - MO_F64_Exp -> (DoubleRep, [DoubleRep]) - MO_F64_ExpM1 -> (DoubleRep, [DoubleRep]) - - MO_F64_Fabs -> (DoubleRep, [DoubleRep]) - MO_F64_Sqrt -> (DoubleRep, [DoubleRep]) - - MO_F32_Pwr -> (FloatRep, [FloatRep, FloatRep]) - - MO_F32_Sin -> (FloatRep, [FloatRep]) - MO_F32_Cos -> (FloatRep, [FloatRep]) - MO_F32_Tan -> (FloatRep, [FloatRep]) - - MO_F32_Sinh -> (FloatRep, [FloatRep]) - MO_F32_Cosh -> (FloatRep, [FloatRep]) - MO_F32_Tanh -> (FloatRep, [FloatRep]) - - MO_F32_Asin -> (FloatRep, [FloatRep]) - MO_F32_Acos -> (FloatRep, [FloatRep]) - MO_F32_Atan -> (FloatRep, [FloatRep]) - - MO_F32_Asinh -> (FloatRep, [FloatRep]) - MO_F32_Acosh -> (FloatRep, [FloatRep]) - MO_F32_Atanh -> (FloatRep, [FloatRep]) - - MO_F32_Log -> (FloatRep, [FloatRep]) - MO_F32_Log1P -> (FloatRep, [FloatRep]) - MO_F32_Exp -> (FloatRep, [FloatRep]) - MO_F32_ExpM1 -> (FloatRep, [FloatRep]) - - MO_F32_Fabs -> (FloatRep, [FloatRep]) - MO_F32_Sqrt -> (FloatRep, [FloatRep]) - - MO_PopCnt W8 -> (Word8Rep, [Word8Rep]) - MO_PopCnt W16 -> (Word16Rep, [Word16Rep]) - MO_PopCnt W32 -> (Word32Rep, [Word32Rep]) - MO_PopCnt W64 -> (Word64Rep, [Word64Rep]) - - MO_BSwap W8 -> (Word8Rep, [Word8Rep]) - MO_BSwap W16 -> (Word16Rep, [Word16Rep]) - MO_BSwap W32 -> (Word32Rep, [Word32Rep]) - MO_BSwap W64 -> (Word64Rep, [Word64Rep]) - - MO_BRev W8 -> (Word8Rep, [Word8Rep]) - MO_BRev W16 -> (Word16Rep, [Word16Rep]) - MO_BRev W32 -> (Word32Rep, [Word32Rep]) - MO_BRev W64 -> (Word64Rep, [Word64Rep]) - - _ -> (VoidRep, []) - --- | The alignment of a 'memcpy'-ish operation. -machOpMemcpyishAlign :: CallishMachOp -> Maybe Int -machOpMemcpyishAlign op = case op of - MO_Memcpy align -> Just align - MO_Memset align -> Just align - MO_Memmove align -> Just align - MO_Memcmp align -> Just align - _ -> Nothing diff --git a/cmm/CmmMonad.hs b/cmm/CmmMonad.hs deleted file mode 100644 --- a/cmm/CmmMonad.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- A Parser monad with access to the 'DynFlags'. --- --- The 'P' monad only has access to the subset of of 'DynFlags' --- required for parsing Haskell. - --- The parser for C-- requires access to a lot more of the 'DynFlags', --- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance. ------------------------------------------------------------------------------ -module CmmMonad ( - PD(..) - , liftP - ) where - -import GhcPrelude - -import Control.Monad -import qualified Control.Monad.Fail as MonadFail - -import DynFlags -import Lexer - -newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a } - -instance Functor PD where - fmap = liftM - -instance Applicative PD where - pure = returnPD - (<*>) = ap - -instance Monad PD where - (>>=) = thenPD -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - -instance MonadFail.MonadFail PD where - fail = failPD - -liftP :: P a -> PD a -liftP (P f) = PD $ \_ s -> f s - -returnPD :: a -> PD a -returnPD = liftP . return - -thenPD :: PD a -> (a -> PD b) -> PD b -(PD m) `thenPD` k = PD $ \d s -> - case m d s of - POk s1 a -> unPD (k a) d s1 - PFailed s1 -> PFailed s1 - -failPD :: String -> PD a -failPD = liftP . fail - -instance HasDynFlags PD where - getDynFlags = PD $ \d s -> POk s d diff --git a/cmm/CmmNode.hs b/cmm/CmmNode.hs deleted file mode 100644 --- a/cmm/CmmNode.hs +++ /dev/null @@ -1,752 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- CmmNode type for representation using Hoopl graphs. - -module CmmNode ( - CmmNode(..), CmmFormal, CmmActual, CmmTickish, - UpdFrameOffset, Convention(..), - ForeignConvention(..), ForeignTarget(..), foreignTargetHints, foreignTargetReps, - CmmReturnInfo(..), - mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, - mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors, - - -- * Tick scopes - CmmTickScope(..), isTickSubScope, combineTickScopes, - ) where - -import GhcPrelude hiding (succ) - -import GHC.Platform.Regs -import CmmExpr -import CmmSwitch -import DynFlags -import FastString -import ForeignCall -import Outputable -import SMRep -import CoreSyn (Tickish) -import qualified Unique as U - -import Hoopl.Block -import Hoopl.Graph -import Hoopl.Collections -import Hoopl.Label -import Data.Maybe -import Data.List (tails,sortBy) -import Unique (nonDetCmpUnique) -import Util - -import TyCon (PrimRep) - ------------------------- --- CmmNode - -#define ULabel {-# UNPACK #-} !Label - -data CmmNode e x where - CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O - - CmmComment :: FastString -> CmmNode O O - - -- Tick annotation, covering Cmm code in our tick scope. We only - -- expect non-code @Tickish@ at this point (e.g. @SourceNote@). - -- See Note [CmmTick scoping details] - CmmTick :: !CmmTickish -> CmmNode O O - - -- Unwind pseudo-instruction, encoding stack unwinding - -- instructions for a debugger. This describes how to reconstruct - -- the "old" value of a register if we want to navigate the stack - -- up one frame. Having unwind information for @Sp@ will allow the - -- debugger to "walk" the stack. - -- - -- See Note [What is this unwinding business?] in Debug - CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O - - CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O - -- Assign to register - - CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O - -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. - - CmmUnsafeForeignCall :: -- An unsafe foreign call; - -- see Note [Foreign calls] - -- Like a "fat machine instruction"; can occur - -- in the middle of a block - ForeignTarget -> -- call target - [CmmFormal] -> -- zero or more results - [CmmActual] -> -- zero or more arguments - CmmNode O O - -- Semantics: clobbers any GlobalRegs for which callerSaves r == True - -- See Note [Unsafe foreign calls clobber caller-save registers] - -- - -- Invariant: the arguments and the ForeignTarget must not - -- mention any registers for which GHC.Platform.callerSaves - -- is True. See Note [Register Parameter Passing]. - - CmmBranch :: ULabel -> CmmNode O C - -- Goto another block in the same procedure - - CmmCondBranch :: { -- conditional branch - cml_pred :: CmmExpr, - cml_true, cml_false :: ULabel, - cml_likely :: Maybe Bool -- likely result of the conditional, - -- if known - } -> CmmNode O C - - CmmSwitch - :: CmmExpr -- Scrutinee, of some integral type - -> SwitchTargets -- Cases. See [Note SwitchTargets] - -> CmmNode O C - - CmmCall :: { -- A native call or tail call - cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! - - cml_cont :: Maybe Label, - -- Label of continuation (Nothing for return or tail call) - -- - -- Note [Continuation BlockIds]: these BlockIds are called - -- Continuation BlockIds, and are the only BlockIds that can - -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or - -- (CmmStackSlot (Young b) _). - - cml_args_regs :: [GlobalReg], - -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed - -- to the call. This is essential information for the - -- native code generator's register allocator; without - -- knowing which GlobalRegs are live it has to assume that - -- they are all live. This list should only include - -- GlobalRegs that are mapped to real machine registers on - -- the target platform. - - cml_args :: ByteOff, - -- Byte offset, from the *old* end of the Area associated with - -- the Label (if cml_cont = Nothing, then Old area), of - -- youngest outgoing arg. Set the stack pointer to this before - -- transferring control. - -- (NB: an update frame might also have been stored in the Old - -- area, but it'll be in an older part than the args.) - - cml_ret_args :: ByteOff, - -- For calls *only*, the byte offset for youngest returned value - -- This is really needed at the *return* point rather than here - -- at the call, but in practice it's convenient to record it here. - - cml_ret_off :: ByteOff - -- For calls *only*, the byte offset of the base of the frame that - -- must be described by the info table for the return point. - -- The older words are an update frames, which have their own - -- info-table and layout information - - -- From a liveness point of view, the stack words older than - -- cml_ret_off are treated as live, even if the sequel of - -- the call goes into a loop. - } -> CmmNode O C - - CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] - -- Always the last node of a block - tgt :: ForeignTarget, -- call target and convention - res :: [CmmFormal], -- zero or more results - args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] - succ :: ULabel, -- Label of continuation - ret_args :: ByteOff, -- same as cml_ret_args - ret_off :: ByteOff, -- same as cml_ret_off - intrbl:: Bool -- whether or not the call is interruptible - } -> CmmNode O C - -{- Note [Foreign calls] -~~~~~~~~~~~~~~~~~~~~~~~ -A CmmUnsafeForeignCall is used for *unsafe* foreign calls; -a CmmForeignCall call is used for *safe* foreign calls. - -Unsafe ones are mostly easy: think of them as a "fat machine -instruction". In particular, they do *not* kill all live registers, -just the registers they return to (there was a bit of code in GHC that -conservatively assumed otherwise.) However, see [Register parameter passing]. - -Safe ones are trickier. A safe foreign call - r = f(x) -ultimately expands to - push "return address" -- Never used to return to; - -- just points an info table - save registers into TSO - call suspendThread - r = f(x) -- Make the call - call resumeThread - restore registers - pop "return address" -We cannot "lower" a safe foreign call to this sequence of Cmms, because -after we've saved Sp all the Cmm optimiser's assumptions are broken. - -Note that a safe foreign call needs an info table. - -So Safe Foreign Calls must remain as last nodes until the stack is -made manifest in CmmLayoutStack, where they are lowered into the above -sequence. --} - -{- Note [Unsafe foreign calls clobber caller-save registers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A foreign call is defined to clobber any GlobalRegs that are mapped to -caller-saves machine registers (according to the prevailing C ABI). -GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves. - -This is a design choice that makes it easier to generate code later. -We could instead choose to say that foreign calls do *not* clobber -caller-saves regs, but then we would have to figure out which regs -were live across the call later and insert some saves/restores. - -Furthermore when we generate code we never have any GlobalRegs live -across a call, because they are always copied-in to LocalRegs and -copied-out again before making a call/jump. So all we have to do is -avoid any code motion that would make a caller-saves GlobalReg live -across a foreign call during subsequent optimisations. --} - -{- Note [Register parameter passing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On certain architectures, some registers are utilized for parameter -passing in the C calling convention. For example, in x86-64 Linux -convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for -argument passing. These are registers R3-R6, which our generated -code may also be using; as a result, it's necessary to save these -values before doing a foreign call. This is done during initial -code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils. However, -one result of doing this is that the contents of these registers -may mysteriously change if referenced inside the arguments. This -is dangerous, so you'll need to disable inlining much in the same -way is done in cmm/CmmOpt.hs currently. We should fix this! --} - ---------------------------------------------- --- Eq instance of CmmNode - -deriving instance Eq (CmmNode e x) - ----------------------------------------------- --- Hoopl instances of CmmNode - -instance NonLocal CmmNode where - entryLabel (CmmEntry l _) = l - - successors (CmmBranch l) = [l] - successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint - successors (CmmSwitch _ ids) = switchTargetsToList ids - successors (CmmCall {cml_cont=l}) = maybeToList l - successors (CmmForeignCall {succ=l}) = [l] - - --------------------------------------------------- --- Various helper types - -type CmmActual = CmmExpr -type CmmFormal = LocalReg - -type UpdFrameOffset = ByteOff - --- | A convention maps a list of values (function arguments or return --- values) to registers or stack locations. -data Convention - = NativeDirectCall - -- ^ top-level Haskell functions use @NativeDirectCall@, which - -- maps arguments to registers starting with R2, according to - -- how many registers are available on the platform. This - -- convention ignores R1, because for a top-level function call - -- the function closure is implicit, and doesn't need to be passed. - | NativeNodeCall - -- ^ non-top-level Haskell functions, which pass the address of - -- the function closure in R1 (regardless of whether R1 is a - -- real register or not), and the rest of the arguments in - -- registers or on the stack. - | NativeReturn - -- ^ a native return. The convention for returns depends on - -- how many values are returned: for just one value returned, - -- the appropriate register is used (R1, F1, etc.). regardless - -- of whether it is a real register or not. For multiple - -- values returned, they are mapped to registers or the stack. - | Slow - -- ^ Slow entry points: all args pushed on the stack - | GC - -- ^ Entry to the garbage collector: uses the node reg! - -- (TODO: I don't think we need this --SDM) - deriving( Eq ) - - --------------------------------------------------- --- Note [ForeignConvention PrimRep Carry] --- --- With the advert of aarch64-darwin, a new AAPCS was brought into mainstream. --- This AAPCS requires us to pack arguments in excess of registers by their --- size on the stack as well as extends values as necessary. --- --- GHC's internal represetnation of values ends up being either Words or Ints, --- both of which are assumed to be Word size[1]. Thus in the CodeGen there is no --- way to recover the origial size of arguments. --- --- In GHC 9.2 this has been rectified in !4390 (commit 3e3555cc); however for --- GHCs before 9.2 to support aarch64-darwin, we need a more lightweight solution. --- Thus we inject the PrimRep signature during the desugar phase into the --- ForeignConvention and carry it through to the CodeGen where we can inspect --- it and produce the correct ABI calls. --- --- See https://developer.apple.com/documentation/xcode/writing_arm64_code_for_apple_platforms --- --- [1]: Int8 = I8# Int#, Word8 = W8# Word# - -data ForeignConvention - = ForeignConvention - CCallConv -- Which foreign-call convention - [ForeignHint] -- Extra info about the args - [ForeignHint] -- Extra info about the result - CmmReturnInfo - PrimRep -- return prim rep - [PrimRep] -- argument prim reps - deriving Eq - -data CmmReturnInfo - = CmmMayReturn - | CmmNeverReturns - deriving ( Eq ) - -data ForeignTarget -- The target of a foreign call - = ForeignTarget -- A foreign procedure - CmmExpr -- Its address - ForeignConvention -- Its calling convention - | PrimTarget -- A possibly-side-effecting machine operation - CallishMachOp -- Which one - deriving Eq - -foreignTargetReps :: HasCallStack => ForeignTarget -> (PrimRep, [PrimRep]) -foreignTargetReps (ForeignTarget _ (ForeignConvention _ _ _ _ rr ras)) = (rr, ras) -foreignTargetReps (PrimTarget op) = callishMachOpReps op - -foreignTargetHints :: HasCallStack => ForeignTarget -> ([ForeignHint], [ForeignHint]) -foreignTargetHints target - = ( res_hints ++ repeat NoHint - , arg_hints ++ repeat NoHint ) - where - (res_hints, arg_hints) = - case target of - PrimTarget op -> callishMachOpHints op - ForeignTarget _ (ForeignConvention _ arg_hints res_hints _ _ _) -> - (res_hints, arg_hints) - --------------------------------------------------- --- Instances of register and slot users / definers - -instance UserOfRegs LocalReg (CmmNode e x) where - foldRegsUsed dflags f !z n = case n of - CmmAssign _ expr -> fold f z expr - CmmStore addr rval -> fold f (fold f z addr) rval - CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args - CmmCondBranch expr _ _ _ -> fold f z expr - CmmSwitch expr _ -> fold f z expr - CmmCall {cml_target=tgt} -> fold f z tgt - CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args - _ -> z - where fold :: forall a b. UserOfRegs LocalReg a - => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed dflags f z n - -instance UserOfRegs GlobalReg (CmmNode e x) where - foldRegsUsed dflags f !z n = case n of - CmmAssign _ expr -> fold f z expr - CmmStore addr rval -> fold f (fold f z addr) rval - CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args - CmmCondBranch expr _ _ _ -> fold f z expr - CmmSwitch expr _ -> fold f z expr - CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt - CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args - _ -> z - where fold :: forall a b. UserOfRegs GlobalReg a - => (b -> GlobalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed dflags f z n - -instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where - -- The (Ord r) in the context is necessary here - -- See Note [Recursive superclasses] in TcInstDcls - foldRegsUsed _ _ !z (PrimTarget _) = z - foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e - -instance DefinerOfRegs LocalReg (CmmNode e x) where - foldRegsDefd dflags f !z n = case n of - CmmAssign lhs _ -> fold f z lhs - CmmUnsafeForeignCall _ fs _ -> fold f z fs - CmmForeignCall {res=res} -> fold f z res - _ -> z - where fold :: forall a b. DefinerOfRegs LocalReg a - => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd dflags f z n - -instance DefinerOfRegs GlobalReg (CmmNode e x) where - foldRegsDefd dflags f !z n = case n of - CmmAssign lhs _ -> fold f z lhs - CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) - CmmCall {} -> fold f z activeRegs - CmmForeignCall {} -> fold f z activeRegs - -- See Note [Safe foreign calls clobber STG registers] - _ -> z - where fold :: forall a b. DefinerOfRegs GlobalReg a - => (b -> GlobalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd dflags f z n - - platform = targetPlatform dflags - activeRegs = activeStgRegs platform - activeCallerSavesRegs = filter (callerSaves platform) activeRegs - - foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns _ _)) = [] - foreignTargetRegs _ = activeCallerSavesRegs - --- Note [Safe foreign calls clobber STG registers] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- During stack layout phase every safe foreign call is expanded into a block --- that contains unsafe foreign call (instead of safe foreign call) and ends --- with a normal call (See Note [Foreign calls]). This means that we must --- treat safe foreign call as if it was a normal call (because eventually it --- will be). This is important if we try to run sinking pass before stack --- layout phase. Consider this example of what might go wrong (this is cmm --- code from stablename001 test). Here is code after common block elimination --- (before stack layout): --- --- c1q6: --- _s1pf::P64 = R1; --- _c1q8::I64 = performMajorGC; --- I64[(young + 8)] = c1q9; --- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...) --- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; --- c1q9: --- I64[(young + 8)] = c1qb; --- R1 = _s1pc::P64; --- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; --- --- If we run sinking pass now (still before stack layout) we will get this: --- --- c1q6: --- I64[(young + 8)] = c1q9; --- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...) --- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; --- c1q9: --- I64[(young + 8)] = c1qb; --- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call --- R1 = _s1pc::P64; --- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; --- --- Notice that _s1pf was sunk past a foreign call. When we run stack layout --- safe call to performMajorGC will be turned into: --- --- c1q6: --- _s1pc::P64 = P64[Sp + 8]; --- I64[Sp - 8] = c1q9; --- Sp = Sp - 8; --- I64[I64[CurrentTSO + 24] + 16] = Sp; --- P64[CurrentNursery + 8] = Hp + 8; --- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,] --- result hints: [PtrHint] suspendThread(BaseReg, 0); --- call "ccall" arg hints: [] result hints: [] performMajorGC(); --- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint] --- result hints: [PtrHint] resumeThread(_u1qI::I64); --- BaseReg = _u1qJ::I64; --- _u1qK::P64 = CurrentTSO; --- _u1qL::P64 = I64[_u1qK::P64 + 24]; --- Sp = I64[_u1qL::P64 + 16]; --- SpLim = _u1qL::P64 + 192; --- HpAlloc = 0; --- Hp = I64[CurrentNursery + 8] - 8; --- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1); --- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8; --- c1q9: --- I64[(young + 8)] = c1qb; --- _s1pf::P64 = R1; <------ INCORRECT! --- R1 = _s1pc::P64; --- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; --- --- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that --- call is clearly incorrect. This is what would happen if we assumed that --- safe foreign call has the same semantics as unsafe foreign call. To prevent --- this we need to treat safe foreign call as if was normal call. - ------------------------------------ --- mapping Expr in CmmNode - -mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget -mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c -mapForeignTarget _ m@(PrimTarget _) = m - -wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr --- Take a transformer on expressions and apply it recursively. --- (wrapRecExp f e) first recursively applies itself to sub-expressions of e --- then uses f to rewrite the resulting expression -wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) -wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) -wrapRecExp f e = f e - -mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x -mapExp _ f@(CmmEntry{}) = f -mapExp _ m@(CmmComment _) = m -mapExp _ m@(CmmTick _) = m -mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap (fmap f)) regs) -mapExp f (CmmAssign r e) = CmmAssign r (f e) -mapExp f (CmmStore addr e) = CmmStore (f addr) (f e) -mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) -mapExp _ l@(CmmBranch _) = l -mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l -mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids -mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt} -mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl - -mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x -mapExpDeep f = mapExp $ wrapRecExp f - ------------------------------------------------------------------------- --- mapping Expr in CmmNode, but not performing allocation if no changes - -mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget -mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e -mapForeignTargetM _ (PrimTarget _) = Nothing - -wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) --- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e --- then gives f a chance to rewrite the resulting expression -wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) -wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr) -wrapRecExpM f e = f e - -mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) -mapExpM _ (CmmEntry{}) = Nothing -mapExpM _ (CmmComment _) = Nothing -mapExpM _ (CmmTick _) = Nothing -mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs -mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e -mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e] -mapExpM _ (CmmBranch _) = Nothing -mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e -mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e -mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt -mapExpM f (CmmUnsafeForeignCall tgt fs as) - = case mapForeignTargetM f tgt of - Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) - Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as -mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) - = case mapForeignTargetM f tgt of - Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl) - Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as - --- share as much as possible -mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] -mapListM f xs = let (b, r) = mapListT f xs - in if b then Just r else Nothing - -mapListJ :: (a -> Maybe a) -> [a] -> [a] -mapListJ f xs = snd (mapListT f xs) - -mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a]) -mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs)) - where g (_, y, Nothing) (True, ys) = (True, y:ys) - g (_, _, Just y) (True, ys) = (True, y:ys) - g (ys', _, Nothing) (False, _) = (False, ys') - g (_, _, Just y) (False, ys) = (True, y:ys) - -mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) -mapExpDeepM f = mapExpM $ wrapRecExpM f - ------------------------------------ --- folding Expr in CmmNode - -foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z -foldExpForeignTarget exp (ForeignTarget e _) z = exp e z -foldExpForeignTarget _ (PrimTarget _) z = z - --- Take a folder on expressions and apply it recursively. --- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad --- itself, delegating all the other CmmExpr forms to 'f'. -wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z -wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es -wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z) -wrapRecExpf f e z = f e z - -foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z -foldExp _ (CmmEntry {}) z = z -foldExp _ (CmmComment {}) z = z -foldExp _ (CmmTick {}) z = z -foldExp f (CmmUnwind xs) z = foldr (maybe id f) z (map snd xs) -foldExp f (CmmAssign _ e) z = f e z -foldExp f (CmmStore addr e) z = f addr $ f e z -foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as -foldExp _ (CmmBranch _) z = z -foldExp f (CmmCondBranch e _ _ _) z = f e z -foldExp f (CmmSwitch e _) z = f e z -foldExp f (CmmCall {cml_target=tgt}) z = f tgt z -foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args - -foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z -foldExpDeep f = foldExp (wrapRecExpf f) - --- ----------------------------------------------------------------------------- - -mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C -mapSuccessors f (CmmBranch bid) = CmmBranch (f bid) -mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l -mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids) -mapSuccessors _ n = n - -mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C - -> (CmmNode O C, [a]) -mapCollectSuccessors f (CmmBranch bid) - = let (bid', acc) = f bid in (CmmBranch bid', [acc]) -mapCollectSuccessors f (CmmCondBranch p y n l) - = let (bidt, acct) = f y - (bidf, accf) = f n - in (CmmCondBranch p bidt bidf l, [accf, acct]) -mapCollectSuccessors f (CmmSwitch e ids) - = let lbls = switchTargetsToList ids :: [Label] - lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a) - in ( CmmSwitch e - (mapSwitchTargets - (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids) - , map snd (mapElems lblMap) - ) -mapCollectSuccessors _ n = (n, []) - --- ----------------------------------------------------------------------------- - --- | Tickish in Cmm context (annotations only) -type CmmTickish = Tickish () - --- | Tick scope identifier, allowing us to reason about what --- annotations in a Cmm block should scope over. We especially take --- care to allow optimisations to reorganise blocks without losing --- tick association in the process. -data CmmTickScope - = GlobalScope - -- ^ The global scope is the "root" of the scope graph. Every - -- scope is a sub-scope of the global scope. It doesn't make sense - -- to add ticks to this scope. On the other hand, this means that - -- setting this scope on a block means no ticks apply to it. - - | SubScope !U.Unique CmmTickScope - -- ^ Constructs a new sub-scope to an existing scope. This allows - -- us to translate Core-style scoping rules (see @tickishScoped@) - -- into the Cmm world. Suppose the following code: - -- - -- tick<1> case ... of - -- A -> tick<2> ... - -- B -> tick<3> ... - -- - -- We want the top-level tick annotation to apply to blocks - -- generated for the A and B alternatives. We can achieve that by - -- generating tick<1> into a block with scope a, while the code - -- for alternatives A and B gets generated into sub-scopes a/b and - -- a/c respectively. - - | CombinedScope CmmTickScope CmmTickScope - -- ^ A combined scope scopes over everything that the two given - -- scopes cover. It is therefore a sub-scope of either scope. This - -- is required for optimisations. Consider common block elimination: - -- - -- A -> tick<2> case ... of - -- C -> [common] - -- B -> tick<3> case ... of - -- D -> [common] - -- - -- We will generate code for the C and D alternatives, and figure - -- out afterwards that it's actually common code. Scoping rules - -- dictate that the resulting common block needs to be covered by - -- both tick<2> and tick<3>, therefore we need to construct a - -- scope that is a child to *both* scope. Now we can do that - if - -- we assign the scopes a/c and b/d to the common-ed up blocks, - -- the new block could have a combined tick scope a/c+b/d, which - -- both tick<2> and tick<3> apply to. - --- Note [CmmTick scoping details]: --- --- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the --- same block. Note that as a result of this, optimisations making --- tick scopes more specific can *reduce* the amount of code a tick --- scopes over. Fixing this would require a separate @CmmTickScope@ --- field for @CmmTick@. Right now we do not do this simply because I --- couldn't find an example where it actually mattered -- multiple --- blocks within the same scope generally jump to each other, which --- prevents common block elimination from happening in the first --- place. But this is no strong reason, so if Cmm optimisations become --- more involved in future this might have to be revisited. - --- | Output all scope paths. -scopeToPaths :: CmmTickScope -> [[U.Unique]] -scopeToPaths GlobalScope = [[]] -scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s) -scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2 - --- | Returns the head uniques of the scopes. This is based on the --- assumption that the @Unique@ of @SubScope@ identifies the --- underlying super-scope. Used for efficient equality and comparison, --- see below. -scopeUniques :: CmmTickScope -> [U.Unique] -scopeUniques GlobalScope = [] -scopeUniques (SubScope u _) = [u] -scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2 - --- Equality and order is based on the head uniques defined above. We --- take care to short-cut the (extremly) common cases. -instance Eq CmmTickScope where - GlobalScope == GlobalScope = True - GlobalScope == _ = False - _ == GlobalScope = False - (SubScope u _) == (SubScope u' _) = u == u' - (SubScope _ _) == _ = False - _ == (SubScope _ _) = False - scope == scope' = - sortBy nonDetCmpUnique (scopeUniques scope) == - sortBy nonDetCmpUnique (scopeUniques scope') - -- This is still deterministic because - -- the order is the same for equal lists - --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] --- See Note [No Ord for Unique] -instance Ord CmmTickScope where - compare GlobalScope GlobalScope = EQ - compare GlobalScope _ = LT - compare _ GlobalScope = GT - compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u' - compare scope scope' = cmpList nonDetCmpUnique - (sortBy nonDetCmpUnique $ scopeUniques scope) - (sortBy nonDetCmpUnique $ scopeUniques scope') - -instance Outputable CmmTickScope where - ppr GlobalScope = text "global" - ppr (SubScope us GlobalScope) - = ppr us - ppr (SubScope us s) = ppr s <> char '/' <> ppr us - ppr combined = parens $ hcat $ punctuate (char '+') $ - map (hcat . punctuate (char '/') . map ppr . reverse) $ - scopeToPaths combined - --- | Checks whether two tick scopes are sub-scopes of each other. True --- if the two scopes are equal. -isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool -isTickSubScope = cmp - where cmp _ GlobalScope = True - cmp GlobalScope _ = False - cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s' - cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2' - cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s' - --- | Combine two tick scopes. The new scope should be sub-scope of --- both parameters. We simplfy automatically if one tick scope is a --- sub-scope of the other already. -combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope -combineTickScopes s1 s2 - | s1 `isTickSubScope` s2 = s1 - | s2 `isTickSubScope` s1 = s2 - | otherwise = CombinedScope s1 s2 diff --git a/cmm/CmmOpt.hs b/cmm/CmmOpt.hs deleted file mode 100644 --- a/cmm/CmmOpt.hs +++ /dev/null @@ -1,423 +0,0 @@ ------------------------------------------------------------------------------ --- --- Cmm optimisation --- --- (c) The University of Glasgow 2006 --- ------------------------------------------------------------------------------ - -module CmmOpt ( - constantFoldNode, - constantFoldExpr, - cmmMachOpFold, - cmmMachOpFoldM - ) where - -import GhcPrelude - -import CmmUtils -import Cmm -import DynFlags -import Util - -import Outputable -import GHC.Platform - -import Data.Bits -import Data.Maybe - - -constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x -constantFoldNode dflags = mapExp (constantFoldExpr dflags) - -constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr -constantFoldExpr dflags = wrapRecExp f - where f (CmmMachOp op args) = cmmMachOpFold dflags op args - f (CmmRegOff r 0) = CmmReg r - f e = e - --- ----------------------------------------------------------------------------- --- MachOp constant folder - --- Now, try to constant-fold the MachOps. The arguments have already --- been optimized and folded. - -cmmMachOpFold - :: DynFlags - -> MachOp -- The operation from an CmmMachOp - -> [CmmExpr] -- The optimized arguments - -> CmmExpr - -cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args) - --- Returns Nothing if no changes, useful for Hoopl, also reduces --- allocation! -cmmMachOpFoldM - :: DynFlags - -> MachOp - -> [CmmExpr] - -> Maybe CmmExpr - -cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)] - = Just $ case op of - MO_S_Neg _ -> CmmLit (CmmInt (-x) rep) - MO_Not _ -> CmmLit (CmmInt (complement x) rep) - - -- these are interesting: we must first narrow to the - -- "from" type, in order to truncate to the correct size. - -- The final narrow/widen to the destination type - -- is implicit in the CmmLit. - MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to) - MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) - MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) - - _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op - - --- Eliminate conversion NOPs -cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x -cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x - --- Eliminate nested conversions where possible -cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]] - | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, - Just (_, rep3,signed2) <- isIntConversion conv_outer - = case () of - -- widen then narrow to the same size is a nop - _ | rep1 < rep2 && rep1 == rep3 -> Just x - -- Widen then narrow to different size: collapse to single conversion - -- but remember to use the signedness from the widening, just in case - -- the final conversion is a widen. - | rep1 < rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] - -- Nested widenings: collapse if the signedness is the same - | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> - Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] - -- Nested narrowings: collapse - | rep1 > rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x] - | otherwise -> - Nothing - where - isIntConversion (MO_UU_Conv rep1 rep2) - = Just (rep1,rep2,False) - isIntConversion (MO_SS_Conv rep1 rep2) - = Just (rep1,rep2,True) - isIntConversion _ = Nothing - - intconv True = MO_SS_Conv - intconv False = MO_UU_Conv - --- ToDo: a narrow of a load can be collapsed into a narrow load, right? --- but what if the architecture only supports word-sized loads, should --- we do the transformation anyway? - -cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] - = case mop of - -- for comparisons: don't forget to narrow the arguments before - -- comparing, since they might be out of range. - MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags)) - MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags)) - - MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags)) - MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags)) - MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags)) - MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags)) - - MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags)) - MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags)) - MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags)) - MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags)) - - MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) - MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) - MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r) - MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r) - MO_U_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem` y_u) r) - MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r) - MO_S_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r) - - MO_And r -> Just $ CmmLit (CmmInt (x .&. y) r) - MO_Or r -> Just $ CmmLit (CmmInt (x .|. y) r) - MO_Xor r -> Just $ CmmLit (CmmInt (x `xor` y) r) - - MO_Shl r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r) - MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) - MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r) - - _ -> Nothing - - where - x_u = narrowU xrep x - y_u = narrowU xrep y - x_s = narrowS xrep x - y_s = narrowS xrep y - - --- When possible, shift the constants to the right-hand side, so that we --- can match for strength reductions. Note that the code generator will --- also assume that constants have been shifted to the right when --- possible. - -cmmMachOpFoldM dflags op [x@(CmmLit _), y] - | not (isLit y) && isCommutableMachOp op - = Just (cmmMachOpFold dflags op [y, x]) - --- Turn (a+b)+c into a+(b+c) where possible. Because literals are --- moved to the right, it is more likely that we will find --- opportunities for constant folding when the expression is --- right-associated. --- --- ToDo: this appears to introduce a quadratic behaviour due to the --- nested cmmMachOpFold. Can we fix this? --- --- Why do we check isLit arg1? If arg1 is a lit, it means that arg2 --- is also a lit (otherwise arg1 would be on the right). If we --- put arg1 on the left of the rearranged expression, we'll get into a --- loop: (x1+x2)+x3 => x1+(x2+x3) => (x2+x3)+x1 => x2+(x3+x1) ... --- --- Also don't do it if arg1 is PicBaseReg, so that we don't separate the --- PicBaseReg from the corresponding label (or label difference). --- -cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3] - | mop2 `associates_with` mop1 - && not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]]) - where - MO_Add{} `associates_with` MO_Sub{} = True - mop1 `associates_with` mop2 = - mop1 == mop2 && isAssociativeMachOp mop1 - --- special case: (a - b) + c ==> a + (c - b) -cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] - | not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]]) - --- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N) --- --- this is better because lit+N is a single link-time constant (e.g. a --- CmmLabelOff), so the right-hand expression needs only one --- instruction, whereas the left needs two. This happens when pointer --- tagging gives us label+offset, and PIC turns the label into --- PicBaseReg + label. --- -cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit] - , CmmLit (CmmInt n rep) ] - | isPicReg pic - = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] - where off = fromIntegral (narrowS rep n) - --- Make a RegOff if we can -cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (fromIntegral (narrowS rep n)) -cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n)) -cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n)) -cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n)) - --- Fold label(+/-)offset into a CmmLit where possible - -cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] - = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) -cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] - = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) -cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] - = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) - - --- Comparison of literal with widened operand: perform the comparison --- at the smaller width, as long as the literal is within range. - --- We can't do the reverse trick, when the operand is narrowed: --- narrowing throws away bits from the operand, there's no way to do --- the same comparison at the larger size. - -cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] - | -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try - platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64], - -- if the operand is widened: - Just (rep, signed, narrow_fn) <- maybe_conversion conv, - -- and this is a comparison operation: - Just narrow_cmp <- maybe_comparison cmp rep signed, - -- and the literal fits in the smaller size: - i == narrow_fn rep i - -- then we can do the comparison at the smaller size - = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)]) - where - maybe_conversion (MO_UU_Conv from to) - | to > from - = Just (from, False, narrowU) - maybe_conversion (MO_SS_Conv from to) - | to > from - = Just (from, True, narrowS) - - -- don't attempt to apply this optimisation when the source - -- is a float; see #1916 - maybe_conversion _ = Nothing - - -- careful (#2080): if the original comparison was signed, but - -- we were doing an unsigned widen, then we must do an - -- unsigned comparison at the smaller size. - maybe_comparison (MO_U_Gt _) rep _ = Just (MO_U_Gt rep) - maybe_comparison (MO_U_Ge _) rep _ = Just (MO_U_Ge rep) - maybe_comparison (MO_U_Lt _) rep _ = Just (MO_U_Lt rep) - maybe_comparison (MO_U_Le _) rep _ = Just (MO_U_Le rep) - maybe_comparison (MO_Eq _) rep _ = Just (MO_Eq rep) - maybe_comparison (MO_S_Gt _) rep True = Just (MO_S_Gt rep) - maybe_comparison (MO_S_Ge _) rep True = Just (MO_S_Ge rep) - maybe_comparison (MO_S_Lt _) rep True = Just (MO_S_Lt rep) - maybe_comparison (MO_S_Le _) rep True = Just (MO_S_Le rep) - maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep) - maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep) - maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep) - maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep) - maybe_comparison _ _ _ = Nothing - --- We can often do something with constants of 0 and 1 ... --- See Note [Comparison operators] - -cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))] - = case mop of - -- Arithmetic - MO_Add _ -> Just x -- x + 0 = x - MO_Sub _ -> Just x -- x - 0 = x - MO_Mul _ -> Just y -- x * 0 = 0 - - -- Logical operations - MO_And _ -> Just y -- x & 0 = 0 - MO_Or _ -> Just x -- x | 0 = x - MO_Xor _ -> Just x -- x `xor` 0 = x - - -- Shifts - MO_Shl _ -> Just x -- x << 0 = x - MO_S_Shr _ -> Just x -- ditto shift-right - MO_U_Shr _ -> Just x - - -- Comparisons; these ones are trickier - -- See Note [Comparison operators] - MO_Ne _ | isComparisonExpr x -> Just x -- (x > y) != 0 = x > y - MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x > y) == 0 = x <= y - MO_U_Gt _ | isComparisonExpr x -> Just x -- (x > y) > 0 = x > y - MO_S_Gt _ | isComparisonExpr x -> Just x -- ditto - MO_U_Lt _ | isComparisonExpr x -> Just zero -- (x > y) < 0 = 0 - MO_S_Lt _ | isComparisonExpr x -> Just zero - MO_U_Ge _ | isComparisonExpr x -> Just one -- (x > y) >= 0 = 1 - MO_S_Ge _ | isComparisonExpr x -> Just one - - MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x > y) <= 0 = x <= y - MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' - _ -> Nothing - where - zero = CmmLit (CmmInt 0 (wordWidth dflags)) - one = CmmLit (CmmInt 1 (wordWidth dflags)) - -cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))] - = case mop of - -- Arithmetic: x*1 = x, etc - MO_Mul _ -> Just x - MO_S_Quot _ -> Just x - MO_U_Quot _ -> Just x - MO_S_Rem _ -> Just $ CmmLit (CmmInt 0 rep) - MO_U_Rem _ -> Just $ CmmLit (CmmInt 0 rep) - - -- Comparisons; trickier - -- See Note [Comparison operators] - MO_Ne _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x>y) != 1 = x<=y - MO_Eq _ | isComparisonExpr x -> Just x -- (x>y) == 1 = x>y - MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- (x>y) < 1 = x<=y - MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' -- ditto - MO_U_Gt _ | isComparisonExpr x -> Just zero -- (x>y) > 1 = 0 - MO_S_Gt _ | isComparisonExpr x -> Just zero - MO_U_Le _ | isComparisonExpr x -> Just one -- (x>y) <= 1 = 1 - MO_S_Le _ | isComparisonExpr x -> Just one - MO_U_Ge _ | isComparisonExpr x -> Just x -- (x>y) >= 1 = x>y - MO_S_Ge _ | isComparisonExpr x -> Just x - _ -> Nothing - where - zero = CmmLit (CmmInt 0 (wordWidth dflags)) - one = CmmLit (CmmInt 1 (wordWidth dflags)) - --- Now look for multiplication/division by powers of 2 (integers). - -cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))] - = case mop of - MO_Mul rep - | Just p <- exactLog2 n -> - Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) - MO_U_Quot rep - | Just p <- exactLog2 n -> - Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) - MO_U_Rem rep - | Just _ <- exactLog2 n -> - Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)]) - MO_S_Quot rep - | Just p <- exactLog2 n, - CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require - -- it is a reg. FIXME: remove this restriction. - Just (cmmMachOpFold dflags (MO_S_Shr rep) - [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)]) - MO_S_Rem rep - | Just p <- exactLog2 n, - CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require - -- it is a reg. FIXME: remove this restriction. - -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p). - -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot) - -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation. - Just (cmmMachOpFold dflags (MO_Sub rep) - [x, cmmMachOpFold dflags (MO_And rep) - [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]]) - _ -> Nothing - where - -- In contrast with unsigned integers, for signed ones - -- shift right is not the same as quot, because it rounds - -- to minus infinity, whereas quot rounds toward zero. - -- To fix this up, we add one less than the divisor to the - -- dividend if it is a negative number. - -- - -- to avoid a test/jump, we use the following sequence: - -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) - -- x2 = y & (divisor-1) - -- result = x + x2 - -- this could be done a bit more simply using conditional moves, - -- but we're processor independent here. - -- - -- we optimise the divide by 2 case slightly, generating - -- x1 = x >> word_size-1 (unsigned) - -- return = x + x1 - signedQuotRemHelper :: Width -> Integer -> CmmExpr - signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2] - where - bits = fromIntegral (widthInBits rep) - 1 - shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep - x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] - x2 = if p == 1 then x1 else - CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] - --- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x --- Unfortunately this needs a unique supply because x might not be a --- register. See #2253 (program 6) for an example. - - --- Anything else is just too hard. - -cmmMachOpFoldM _ _ _ = Nothing - -{- Note [Comparison operators] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - CmmCondBranch ((x>#y) == 1) t f -we really want to convert to - CmmCondBranch (x>#y) t f - -That's what the constant-folding operations on comparison operators do above. --} - - --- ----------------------------------------------------------------------------- --- Utils - -isPicReg :: CmmExpr -> Bool -isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True -isPicReg _ = False diff --git a/cmm/CmmParse.y b/cmm/CmmParse.y deleted file mode 100644 --- a/cmm/CmmParse.y +++ /dev/null @@ -1,1468 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow, 2004-2012 --- --- Parser for concrete Cmm. --- ------------------------------------------------------------------------------ - -{- ----------------------------------------------------------------------------- -Note [Syntax of .cmm files] - -NOTE: You are very much on your own in .cmm. There is very little -error checking at all: - - * Type errors are detected by the (optional) -dcmm-lint pass, if you - don't turn this on then a type error will likely result in a panic - from the native code generator. - - * Passing the wrong number of arguments or arguments of the wrong - type is not detected. - -There are two ways to write .cmm code: - - (1) High-level Cmm code delegates the stack handling to GHC, and - never explicitly mentions Sp or registers. - - (2) Low-level Cmm manages the stack itself, and must know about - calling conventions. - -Whether you want high-level or low-level Cmm is indicated by the -presence of an argument list on a procedure. For example: - -foo ( gcptr a, bits32 b ) -{ - // this is high-level cmm code - - if (b > 0) { - // we can make tail calls passing arguments: - jump stg_ap_0_fast(a); - } - - push (stg_upd_frame_info, a) { - // stack frames can be explicitly pushed - - (x,y) = call wibble(a,b,3,4); - // calls pass arguments and return results using the native - // Haskell calling convention. The code generator will automatically - // construct a stack frame and an info table for the continuation. - - return (x,y); - // we can return multiple values from the current proc - } -} - -bar -{ - // this is low-level cmm code, indicated by the fact that we did not - // put an argument list on bar. - - x = R1; // the calling convention is explicit: better be careful - // that this works on all platforms! - - jump %ENTRY_CODE(Sp(0)) -} - -Here is a list of rules for high-level and low-level code. If you -break the rules, you get a panic (for using a high-level construct in -a low-level proc), or wrong code (when using low-level code in a -high-level proc). This stuff isn't checked! (TODO!) - -High-level only: - - - tail-calls with arguments, e.g. - jump stg_fun (arg1, arg2); - - - function calls: - (ret1,ret2) = call stg_fun (arg1, arg2); - - This makes a call with the NativeNodeCall convention, and the - values are returned to the following code using the NativeReturn - convention. - - - returning: - return (ret1, ret2) - - These use the NativeReturn convention to return zero or more - results to the caller. - - - pushing stack frames: - push (info_ptr, field1, ..., fieldN) { ... statements ... } - - - reserving temporary stack space: - - reserve N = x { ... } - - this reserves an area of size N (words) on the top of the stack, - and binds its address to x (a local register). Typically this is - used for allocating temporary storage for passing to foreign - functions. - - Note that if you make any native calls or invoke the GC in the - scope of the reserve block, you are responsible for ensuring that - the stack you reserved is laid out correctly with an info table. - -Low-level only: - - - References to Sp, R1-R8, F1-F4 etc. - - NB. foreign calls may clobber the argument registers R1-R8, F1-F4 - etc., so ensure they are saved into variables around foreign - calls. - - - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp - directly. - -Both high-level and low-level code can use a raw tail-call: - - jump stg_fun [R1,R2] - -NB. you *must* specify the list of GlobalRegs that are passed via a -jump, otherwise the register allocator will assume that all the -GlobalRegs are dead at the jump. - - -Calling Conventions -------------------- - -High-level procedures use the NativeNode calling convention, or the -NativeReturn convention if the 'return' keyword is used (see Stack -Frames below). - -Low-level procedures implement their own calling convention, so it can -be anything at all. - -If a low-level procedure implements the NativeNode calling convention, -then it can be called by high-level code using an ordinary function -call. In general this is hard to arrange because the calling -convention depends on the number of physical registers available for -parameter passing, but there are two cases where the calling -convention is platform-independent: - - - Zero arguments. - - - One argument of pointer or non-pointer word type; this is always - passed in R1 according to the NativeNode convention. - - - Returning a single value; these conventions are fixed and platform - independent. - - -Stack Frames ------------- - -A stack frame is written like this: - -INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN ) - return ( arg1, ..., argM ) -{ - ... code ... -} - -where field1 ... fieldN are the fields of the stack frame (with types) -arg1...argN are the values returned to the stack frame (with types). -The return values are assumed to be passed according to the -NativeReturn convention. - -On entry to the code, the stack frame looks like: - - |----------| - | fieldN | - | ... | - | field1 | - |----------| - | info_ptr | - |----------| - | argN | - | ... | <- Sp - -and some of the args may be in registers. - -We prepend the code by a copyIn of the args, and assign all the stack -frame fields to their formals. The initial "arg offset" for stack -layout purposes consists of the whole stack frame plus any args that -might be on the stack. - -A tail-call may pass a stack frame to the callee using the following -syntax: - -jump f (info_ptr, field1,..,fieldN) (arg1,..,argN) - -where info_ptr and field1..fieldN describe the stack frame, and -arg1..argN are the arguments passed to f using the NativeNodeCall -convention. Note if a field is longer than a word (e.g. a D_ on -a 32-bit machine) then the call will push as many words as -necessary to the stack to accommodate it (e.g. 2). - - ------------------------------------------------------------------------------ -} - -{ -{-# LANGUAGE TupleSections #-} - -module CmmParse ( parseCmmFile ) where - -import GhcPrelude -import qualified Prelude -- for happy-generated code - -import GHC.StgToCmm.ExtCode -import CmmCallConv -import GHC.StgToCmm.Prof -import GHC.StgToCmm.Heap -import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit - , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff - , getUpdFrameOff ) -import qualified GHC.StgToCmm.Monad as F -import GHC.StgToCmm.Utils -import GHC.StgToCmm.Foreign -import GHC.StgToCmm.Expr -import GHC.StgToCmm.Closure -import GHC.StgToCmm.Layout hiding (ArgRep(..)) -import GHC.StgToCmm.Ticky -import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame ) -import CoreSyn ( Tickish(SourceNote) ) - -import CmmOpt -import MkGraph -import Cmm -import CmmUtils -import CmmSwitch ( mkSwitchTargets ) -import CmmInfo -import BlockId -import CmmLex -import CLabel -import SMRep -import Lexer -import CmmMonad - -import CostCentre -import ForeignCall -import Module -import GHC.Platform -import Literal -import Unique -import UniqFM -import SrcLoc -import DynFlags -import ErrUtils -import StringBuffer -import FastString -import Panic -import Constants -import Outputable -import BasicTypes -import Bag ( emptyBag, unitBag ) -import Var - -import Control.Monad -import Data.Array -import Data.Char ( ord ) -import System.Exit -import Data.Maybe -import qualified Data.Map as M -import qualified Data.ByteString.Char8 as BS8 - -import TyCon (PrimRep(..)) - -#include "HsVersions.h" -} - -%expect 0 - -%token - ':' { L _ (CmmT_SpecChar ':') } - ';' { L _ (CmmT_SpecChar ';') } - '{' { L _ (CmmT_SpecChar '{') } - '}' { L _ (CmmT_SpecChar '}') } - '[' { L _ (CmmT_SpecChar '[') } - ']' { L _ (CmmT_SpecChar ']') } - '(' { L _ (CmmT_SpecChar '(') } - ')' { L _ (CmmT_SpecChar ')') } - '=' { L _ (CmmT_SpecChar '=') } - '`' { L _ (CmmT_SpecChar '`') } - '~' { L _ (CmmT_SpecChar '~') } - '/' { L _ (CmmT_SpecChar '/') } - '*' { L _ (CmmT_SpecChar '*') } - '%' { L _ (CmmT_SpecChar '%') } - '-' { L _ (CmmT_SpecChar '-') } - '+' { L _ (CmmT_SpecChar '+') } - '&' { L _ (CmmT_SpecChar '&') } - '^' { L _ (CmmT_SpecChar '^') } - '|' { L _ (CmmT_SpecChar '|') } - '>' { L _ (CmmT_SpecChar '>') } - '<' { L _ (CmmT_SpecChar '<') } - ',' { L _ (CmmT_SpecChar ',') } - '!' { L _ (CmmT_SpecChar '!') } - - '..' { L _ (CmmT_DotDot) } - '::' { L _ (CmmT_DoubleColon) } - '>>' { L _ (CmmT_Shr) } - '<<' { L _ (CmmT_Shl) } - '>=' { L _ (CmmT_Ge) } - '<=' { L _ (CmmT_Le) } - '==' { L _ (CmmT_Eq) } - '!=' { L _ (CmmT_Ne) } - '&&' { L _ (CmmT_BoolAnd) } - '||' { L _ (CmmT_BoolOr) } - - 'True' { L _ (CmmT_True ) } - 'False' { L _ (CmmT_False) } - 'likely'{ L _ (CmmT_likely)} - - 'CLOSURE' { L _ (CmmT_CLOSURE) } - 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } - 'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) } - 'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) } - 'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) } - 'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) } - 'else' { L _ (CmmT_else) } - 'export' { L _ (CmmT_export) } - 'section' { L _ (CmmT_section) } - 'goto' { L _ (CmmT_goto) } - 'if' { L _ (CmmT_if) } - 'call' { L _ (CmmT_call) } - 'jump' { L _ (CmmT_jump) } - 'foreign' { L _ (CmmT_foreign) } - 'never' { L _ (CmmT_never) } - 'prim' { L _ (CmmT_prim) } - 'reserve' { L _ (CmmT_reserve) } - 'return' { L _ (CmmT_return) } - 'returns' { L _ (CmmT_returns) } - 'import' { L _ (CmmT_import) } - 'switch' { L _ (CmmT_switch) } - 'case' { L _ (CmmT_case) } - 'default' { L _ (CmmT_default) } - 'push' { L _ (CmmT_push) } - 'unwind' { L _ (CmmT_unwind) } - 'bits8' { L _ (CmmT_bits8) } - 'bits16' { L _ (CmmT_bits16) } - 'bits32' { L _ (CmmT_bits32) } - 'bits64' { L _ (CmmT_bits64) } - 'bits128' { L _ (CmmT_bits128) } - 'bits256' { L _ (CmmT_bits256) } - 'bits512' { L _ (CmmT_bits512) } - 'float32' { L _ (CmmT_float32) } - 'float64' { L _ (CmmT_float64) } - 'gcptr' { L _ (CmmT_gcptr) } - - GLOBALREG { L _ (CmmT_GlobalReg $$) } - NAME { L _ (CmmT_Name $$) } - STRING { L _ (CmmT_String $$) } - INT { L _ (CmmT_Int $$) } - FLOAT { L _ (CmmT_Float $$) } - -%monad { PD } { >>= } { return } -%lexer { cmmlex } { L _ CmmT_EOF } -%name cmmParse cmm -%tokentype { Located CmmToken } - --- C-- operator precedences, taken from the C-- spec -%right '||' -- non-std extension, called %disjoin in C-- -%right '&&' -- non-std extension, called %conjoin in C-- -%right '!' -%nonassoc '>=' '>' '<=' '<' '!=' '==' -%left '|' -%left '^' -%left '&' -%left '>>' '<<' -%left '-' '+' -%left '/' '*' '%' -%right '~' - -%% - -cmm :: { CmmParse () } - : {- empty -} { return () } - | cmmtop cmm { do $1; $2 } - -cmmtop :: { CmmParse () } - : cmmproc { $1 } - | cmmdata { $1 } - | decl { $1 } - | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' - {% liftP . withThisPackage $ \pkg -> - do lits <- sequence $6; - staticClosure pkg $3 $5 (map getLit lits) } - --- The only static closures in the RTS are dummy closures like --- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need --- to provide the full generality of static closures here. --- In particular: --- * CCS can always be CCS_DONT_CARE --- * closure is always extern --- * payload is always empty --- * we can derive closure and info table labels from a single NAME - -cmmdata :: { CmmParse () } - : 'section' STRING '{' data_label statics '}' - { do lbl <- $4; - ss <- sequence $5; - code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) } - -data_label :: { CmmParse CLabel } - : NAME ':' - {% liftP . withThisPackage $ \pkg -> - return (mkCmmDataLabel pkg (NeedExternDecl False) $1) } - -statics :: { [CmmParse [CmmStatic]] } - : {- empty -} { [] } - | static statics { $1 : $2 } - -static :: { CmmParse [CmmStatic] } - : type expr ';' { do e <- $2; - return [CmmStaticLit (getLit e)] } - | type ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1))] } - | 'bits8' '[' ']' STRING ';' { return [mkString $4] } - | 'bits8' '[' INT ']' ';' { return [CmmUninitialised - (fromIntegral $3)] } - | typenot8 '[' INT ']' ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1) * - fromIntegral $3)] } - | 'CLOSURE' '(' NAME lits ')' - { do { lits <- sequence $4 - ; dflags <- getDynFlags - ; return $ map CmmStaticLit $ - mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) - -- mkForeignLabel because these are only used - -- for CHARLIKE and INTLIKE closures in the RTS. - dontCareCCS (map getLit lits) [] [] [] } } - -- arrays of closures required for the CHARLIKE & INTLIKE arrays - -lits :: { [CmmParse CmmExpr] } - : {- empty -} { [] } - | ',' expr lits { $2 : $3 } - -cmmproc :: { CmmParse () } - : info maybe_conv maybe_formals maybe_body - { do ((entry_ret_label, info, stk_formals, formals), agraph) <- - getCodeScoped $ loopDecls $ do { - (entry_ret_label, info, stk_formals) <- $1; - dflags <- getDynFlags; - formals <- sequence (fromMaybe [] $3); - withName (showSDoc dflags (ppr entry_ret_label)) - $4; - return (entry_ret_label, info, stk_formals, formals) } - let do_layout = isJust $3 - code (emitProcWithStackFrame $2 info - entry_ret_label stk_formals formals agraph - do_layout ) } - -maybe_conv :: { Convention } - : {- empty -} { NativeNodeCall } - | 'return' { NativeReturn } - -maybe_body :: { CmmParse () } - : ';' { return () } - | '{' body '}' { withSourceNote $1 $3 $2 } - -info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } - : NAME - {% liftP . withThisPackage $ \pkg -> - do newFunctionName $1 pkg - return (mkCmmCodeLabel pkg $1, Nothing, []) } - - - | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' - -- ptrs, nptrs, closure type, description, type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $11 $13 - rep = mkRTSRep (fromIntegral $9) $ - mkHeapRep dflags False (fromIntegral $5) - (fromIntegral $7) Thunk - -- not really Thunk, but that makes the info table - -- we want. - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []) } - - | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' - -- ptrs, nptrs, closure type, description, type, fun type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $11 $13 - ty = Fun 0 (ArgSpec (fromIntegral $15)) - -- Arity zero, arg_type $15 - rep = mkRTSRep (fromIntegral $9) $ - mkHeapRep dflags False (fromIntegral $5) - (fromIntegral $7) ty - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []) } - -- we leave most of the fields zero here. This is only used - -- to generate the BCO info table in the RTS at the moment. - - | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' - -- ptrs, nptrs, tag, closure type, description, type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $13 $15 - ty = Constr (fromIntegral $9) -- Tag - (BS8.pack $13) - rep = mkRTSRep (fromIntegral $11) $ - mkHeapRep dflags False (fromIntegral $5) - (fromIntegral $7) ty - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing }, - []) } - - -- If profiling is on, this string gets duplicated, - -- but that's the way the old code did it we can fix it some other time. - - | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' - -- selector, closure type, description, type - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - let prof = profilingInfo dflags $9 $11 - ty = ThunkSelector (fromIntegral $5) - rep = mkRTSRep (fromIntegral $7) $ - mkHeapRep dflags False 0 0 ty - return (mkCmmEntryLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' INT ')' - -- closure type (no live regs) - {% liftP . withThisPackage $ \pkg -> - do let prof = NoProfilingInfo - rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] - return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' - -- closure type, live regs - {% liftP . withThisPackage $ \pkg -> - do dflags <- getDynFlags - live <- sequence $7 - let prof = NoProfilingInfo - -- drop one for the info pointer - bitmap = mkLiveness dflags (drop 1 live) - rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap - return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - live) } - -body :: { CmmParse () } - : {- empty -} { return () } - | decl body { do $1; $2 } - | stmt body { do $1; $2 } - -decl :: { CmmParse () } - : type names ';' { mapM_ (newLocal $1) $2 } - | 'import' importNames ';' { mapM_ newImport $2 } - | 'export' names ';' { return () } -- ignore exports - - --- an imported function name, with optional packageId -importNames - :: { [(FastString, CLabel)] } - : importName { [$1] } - | importName ',' importNames { $1 : $3 } - -importName - :: { (FastString, CLabel) } - - -- A label imported without an explicit packageId. - -- These are taken to come frome some foreign, unnamed package. - : NAME - { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } - - -- as previous 'NAME', but 'IsData' - | 'CLOSURE' NAME - { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) } - - -- A label imported with an explicit packageId. - | STRING NAME - { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) } - - -names :: { [FastString] } - : NAME { [$1] } - | NAME ',' names { $1 : $3 } - -stmt :: { CmmParse () } - : ';' { return () } - - | NAME ':' - { do l <- newLabel $1; emitLabel l } - - - - | lreg '=' expr ';' - { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) } - | type '[' expr ']' '=' expr ';' - { withSourceNote $2 $7 (doStore $1 $3 $6) } - - -- Gah! We really want to say "foreign_results" but that causes - -- a shift/reduce conflict with assignment. We either - -- we expand out the no-result and single result cases or - -- we tweak the syntax to avoid the conflict. The later - -- option is taken here because the other way would require - -- multiple levels of expanding and get unwieldy. - | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';' - {% foreignCall $3 $1 $4 $6 $8 $9 } - | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';' - {% primCall $1 $4 $6 } - -- stmt-level macros, stealing syntax from ordinary C-- function calls. - -- Perhaps we ought to use the %%-form? - | NAME '(' exprs0 ')' ';' - {% stmtMacro $1 $3 } - | 'switch' maybe_range expr '{' arms default '}' - { do as <- sequence $5; doSwitch $2 $3 as $6 } - | 'goto' NAME ';' - { do l <- lookupLabel $2; emit (mkBranch l) } - | 'return' '(' exprs0 ')' ';' - { doReturn $3 } - | 'jump' expr vols ';' - { doRawJump $2 $3 } - | 'jump' expr '(' exprs0 ')' ';' - { doJumpWithStack $2 [] $4 } - | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';' - { doJumpWithStack $2 $4 $7 } - | 'call' expr '(' exprs0 ')' ';' - { doCall $2 [] $4 } - | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';' - { doCall $6 $2 $8 } - | 'if' bool_expr cond_likely 'goto' NAME - { do l <- lookupLabel $5; cmmRawIf $2 l $3 } - | 'if' bool_expr cond_likely '{' body '}' else - { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 } - | 'push' '(' exprs0 ')' maybe_body - { pushStackFrame $3 $5 } - | 'reserve' expr '=' lreg maybe_body - { reserveStackFrame $2 $4 $5 } - | 'unwind' unwind_regs ';' - { $2 >>= code . emitUnwind } - -unwind_regs - :: { CmmParse [(GlobalReg, Maybe CmmExpr)] } - : GLOBALREG '=' expr_or_unknown ',' unwind_regs - { do e <- $3; rest <- $5; return (($1, e) : rest) } - | GLOBALREG '=' expr_or_unknown - { do e <- $3; return [($1, e)] } - --- | Used by unwind to indicate unknown unwinding values. -expr_or_unknown - :: { CmmParse (Maybe CmmExpr) } - : 'return' - { do return Nothing } - | expr - { do e <- $1; return (Just e) } - -foreignLabel :: { CmmParse CmmExpr } - : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) } - -opt_never_returns :: { CmmReturnInfo } - : { CmmMayReturn } - | 'never' 'returns' { CmmNeverReturns } - -bool_expr :: { CmmParse BoolExpr } - : bool_op { $1 } - | expr { do e <- $1; return (BoolTest e) } - -bool_op :: { CmmParse BoolExpr } - : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; - return (BoolAnd e1 e2) } - | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; - return (BoolOr e1 e2) } - | '!' bool_expr { do e <- $2; return (BoolNot e) } - | '(' bool_op ')' { $2 } - -safety :: { Safety } - : {- empty -} { PlayRisky } - | STRING {% parseSafety $1 } - -vols :: { [GlobalReg] } - : '[' ']' { [] } - | '[' '*' ']' {% do df <- getDynFlags - ; return (realArgRegsCover df) } - -- All of them. See comment attached - -- to realArgRegsCover - | '[' globals ']' { $2 } - -globals :: { [GlobalReg] } - : GLOBALREG { [$1] } - | GLOBALREG ',' globals { $1 : $3 } - -maybe_range :: { Maybe (Integer,Integer) } - : '[' INT '..' INT ']' { Just ($2, $4) } - | {- empty -} { Nothing } - -arms :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] } - : {- empty -} { [] } - | arm arms { $1 : $2 } - -arm :: { CmmParse ([Integer],Either BlockId (CmmParse ())) } - : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } - -arm_body :: { CmmParse (Either BlockId (CmmParse ())) } - : '{' body '}' { return (Right (withSourceNote $1 $3 $2)) } - | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } - -ints :: { [Integer] } - : INT { [ $1 ] } - | INT ',' ints { $1 : $3 } - -default :: { Maybe (CmmParse ()) } - : 'default' ':' '{' body '}' { Just (withSourceNote $3 $5 $4) } - -- taking a few liberties with the C-- syntax here; C-- doesn't have - -- 'default' branches - | {- empty -} { Nothing } - --- Note: OldCmm doesn't support a first class 'else' statement, though --- CmmNode does. -else :: { CmmParse () } - : {- empty -} { return () } - | 'else' '{' body '}' { withSourceNote $2 $4 $3 } - -cond_likely :: { Maybe Bool } - : '(' 'likely' ':' 'True' ')' { Just True } - | '(' 'likely' ':' 'False' ')' { Just False } - | {- empty -} { Nothing } - - --- we have to write this out longhand so that Happy's precedence rules --- can kick in. -expr :: { CmmParse CmmExpr } - : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] } - | expr '*' expr { mkMachOp MO_Mul [$1,$3] } - | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] } - | expr '-' expr { mkMachOp MO_Sub [$1,$3] } - | expr '+' expr { mkMachOp MO_Add [$1,$3] } - | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] } - | expr '<<' expr { mkMachOp MO_Shl [$1,$3] } - | expr '&' expr { mkMachOp MO_And [$1,$3] } - | expr '^' expr { mkMachOp MO_Xor [$1,$3] } - | expr '|' expr { mkMachOp MO_Or [$1,$3] } - | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] } - | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] } - | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] } - | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] } - | expr '!=' expr { mkMachOp MO_Ne [$1,$3] } - | expr '==' expr { mkMachOp MO_Eq [$1,$3] } - | '~' expr { mkMachOp MO_Not [$2] } - | '-' expr { mkMachOp MO_S_Neg [$2] } - | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ; - return (mkMachOp mo [$1,$5]) } } - | expr0 { $1 } - -expr0 :: { CmmParse CmmExpr } - : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } - | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } - | STRING { do s <- code (newStringCLit $1); - return (CmmLit s) } - | reg { $1 } - | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } - | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } - | '(' expr ')' { $2 } - - --- leaving out the type of a literal gives you the native word size in C-- -maybe_ty :: { CmmType } - : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags } - | '::' type { $2 } - -cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] } - : {- empty -} { [] } - | cmm_hint_exprs { $1 } - -cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] } - : cmm_hint_expr { [$1] } - | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } - -cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) } - : expr { do e <- $1; - return (e, inferCmmHint e) } - | expr STRING {% do h <- parseCmmHint $2; - return $ do - e <- $1; return (e, h) } - -exprs0 :: { [CmmParse CmmExpr] } - : {- empty -} { [] } - | exprs { $1 } - -exprs :: { [CmmParse CmmExpr] } - : expr { [ $1 ] } - | expr ',' exprs { $1 : $3 } - -reg :: { CmmParse CmmExpr } - : NAME { lookupName $1 } - | GLOBALREG { return (CmmReg (CmmGlobal $1)) } - -foreign_results :: { [CmmParse (LocalReg, ForeignHint)] } - : {- empty -} { [] } - | '(' foreign_formals ')' '=' { $2 } - -foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] } - : foreign_formal { [$1] } - | foreign_formal ',' { [$1] } - | foreign_formal ',' foreign_formals { $1 : $3 } - -foreign_formal :: { CmmParse (LocalReg, ForeignHint) } - : local_lreg { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) } - | STRING local_lreg {% do h <- parseCmmHint $1; - return $ do - e <- $2; return (e,h) } - -local_lreg :: { CmmParse LocalReg } - : NAME { do e <- lookupName $1; - return $ - case e of - CmmReg (CmmLocal r) -> r - other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } - -lreg :: { CmmParse CmmReg } - : NAME { do e <- lookupName $1; - return $ - case e of - CmmReg r -> r - other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } - | GLOBALREG { return (CmmGlobal $1) } - -maybe_formals :: { Maybe [CmmParse LocalReg] } - : {- empty -} { Nothing } - | '(' formals0 ')' { Just $2 } - -formals0 :: { [CmmParse LocalReg] } - : {- empty -} { [] } - | formals { $1 } - -formals :: { [CmmParse LocalReg] } - : formal ',' { [$1] } - | formal { [$1] } - | formal ',' formals { $1 : $3 } - -formal :: { CmmParse LocalReg } - : type NAME { newLocal $1 $2 } - -type :: { CmmType } - : 'bits8' { b8 } - | typenot8 { $1 } - -typenot8 :: { CmmType } - : 'bits16' { b16 } - | 'bits32' { b32 } - | 'bits64' { b64 } - | 'bits128' { b128 } - | 'bits256' { b256 } - | 'bits512' { b512 } - | 'float32' { f32 } - | 'float64' { f64 } - | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags } - -{ -section :: String -> SectionType -section "text" = Text -section "data" = Data -section "rodata" = ReadOnlyData -section "relrodata" = RelocatableReadOnlyData -section "bss" = UninitialisedData -section s = OtherSection s - -mkString :: String -> CmmStatic -mkString s = CmmString (BS8.pack s) - --- | --- Given an info table, decide what the entry convention for the proc --- is. That is, for an INFO_TABLE_RET we want the return convention, --- otherwise it is a NativeNodeCall. --- -infoConv :: Maybe CmmInfoTable -> Convention -infoConv Nothing = NativeNodeCall -infoConv (Just info) - | isStackRep (cit_rep info) = NativeReturn - | otherwise = NativeNodeCall - --- mkMachOp infers the type of the MachOp from the type of its first --- argument. We assume that this is correct: for MachOps that don't have --- symmetrical args (e.g. shift ops), the first arg determines the type of --- the op. -mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr -mkMachOp fn args = do - dflags <- getDynFlags - arg_exprs <- sequence args - return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs) - -getLit :: CmmExpr -> CmmLit -getLit (CmmLit l) = l -getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r -getLit _ = panic "invalid literal" -- TODO messy failure - -nameToMachOp :: FastString -> PD (Width -> MachOp) -nameToMachOp name = - case lookupUFM machOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just m -> return m - -exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) -exprOp name args_code = do - dflags <- getDynFlags - case lookupUFM (exprMacros dflags) name of - Just f -> return $ do - args <- sequence args_code - return (f args) - Nothing -> do - mo <- nameToMachOp name - return $ mkMachOp mo args_code - -exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) -exprMacros dflags = listToUFM [ - ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), - ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), - ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), - ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), - ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), - ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) - ] - --- we understand a subset of C-- primitives: -machOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "add", MO_Add ), - ( "sub", MO_Sub ), - ( "eq", MO_Eq ), - ( "ne", MO_Ne ), - ( "mul", MO_Mul ), - ( "neg", MO_S_Neg ), - ( "quot", MO_S_Quot ), - ( "rem", MO_S_Rem ), - ( "divu", MO_U_Quot ), - ( "modu", MO_U_Rem ), - - ( "ge", MO_S_Ge ), - ( "le", MO_S_Le ), - ( "gt", MO_S_Gt ), - ( "lt", MO_S_Lt ), - - ( "geu", MO_U_Ge ), - ( "leu", MO_U_Le ), - ( "gtu", MO_U_Gt ), - ( "ltu", MO_U_Lt ), - - ( "and", MO_And ), - ( "or", MO_Or ), - ( "xor", MO_Xor ), - ( "com", MO_Not ), - ( "shl", MO_Shl ), - ( "shrl", MO_U_Shr ), - ( "shra", MO_S_Shr ), - - ( "fadd", MO_F_Add ), - ( "fsub", MO_F_Sub ), - ( "fneg", MO_F_Neg ), - ( "fmul", MO_F_Mul ), - ( "fquot", MO_F_Quot ), - - ( "feq", MO_F_Eq ), - ( "fne", MO_F_Ne ), - ( "fge", MO_F_Ge ), - ( "fle", MO_F_Le ), - ( "fgt", MO_F_Gt ), - ( "flt", MO_F_Lt ), - - ( "lobits8", flip MO_UU_Conv W8 ), - ( "lobits16", flip MO_UU_Conv W16 ), - ( "lobits32", flip MO_UU_Conv W32 ), - ( "lobits64", flip MO_UU_Conv W64 ), - - ( "zx16", flip MO_UU_Conv W16 ), - ( "zx32", flip MO_UU_Conv W32 ), - ( "zx64", flip MO_UU_Conv W64 ), - - ( "sx16", flip MO_SS_Conv W16 ), - ( "sx32", flip MO_SS_Conv W32 ), - ( "sx64", flip MO_SS_Conv W64 ), - - ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode - ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode - ( "f2i8", flip MO_FS_Conv W8 ), - ( "f2i16", flip MO_FS_Conv W16 ), - ( "f2i32", flip MO_FS_Conv W32 ), - ( "f2i64", flip MO_FS_Conv W64 ), - ( "i2f32", flip MO_SF_Conv W32 ), - ( "i2f64", flip MO_SF_Conv W64 ) - ] - -callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) -callishMachOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "read_barrier", (MO_ReadBarrier,)), - ( "write_barrier", (MO_WriteBarrier,)), - ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), - ( "memset", memcpyLikeTweakArgs MO_Memset ), - ( "memmove", memcpyLikeTweakArgs MO_Memmove ), - ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), - - ("prefetch0", (MO_Prefetch_Data 0,)), - ("prefetch1", (MO_Prefetch_Data 1,)), - ("prefetch2", (MO_Prefetch_Data 2,)), - ("prefetch3", (MO_Prefetch_Data 3,)), - - ( "popcnt8", (MO_PopCnt W8,)), - ( "popcnt16", (MO_PopCnt W16,)), - ( "popcnt32", (MO_PopCnt W32,)), - ( "popcnt64", (MO_PopCnt W64,)), - - ( "pdep8", (MO_Pdep W8,)), - ( "pdep16", (MO_Pdep W16,)), - ( "pdep32", (MO_Pdep W32,)), - ( "pdep64", (MO_Pdep W64,)), - - ( "pext8", (MO_Pext W8,)), - ( "pext16", (MO_Pext W16,)), - ( "pext32", (MO_Pext W32,)), - ( "pext64", (MO_Pext W64,)), - - ( "cmpxchg8", (MO_Cmpxchg W8,)), - ( "cmpxchg16", (MO_Cmpxchg W16,)), - ( "cmpxchg32", (MO_Cmpxchg W32,)), - ( "cmpxchg64", (MO_Cmpxchg W64,)) - - -- ToDo: the rest, maybe - -- edit: which rest? - -- also: how do we tell CMM Lint how to type check callish macops? - ] - where - memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) - memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" - memcpyLikeTweakArgs op args@(_:_) = - (op align, args') - where - args' = init args - align = case last args of - CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger - e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e) - -- The alignment of memcpy-ish operations must be a - -- compile-time constant. We verify this here, passing it around - -- in the MO_* constructor. In order to do this, however, we - -- must intercept the arguments in primCall. - -parseSafety :: String -> PD Safety -parseSafety "safe" = return PlaySafe -parseSafety "unsafe" = return PlayRisky -parseSafety "interruptible" = return PlayInterruptible -parseSafety str = fail ("unrecognised safety: " ++ str) - -parseCmmHint :: String -> PD ForeignHint -parseCmmHint "ptr" = return AddrHint -parseCmmHint "signed" = return SignedHint -parseCmmHint str = fail ("unrecognised hint: " ++ str) - --- labels are always pointers, so we might as well infer the hint -inferCmmHint :: CmmExpr -> ForeignHint -inferCmmHint (CmmLit (CmmLabel _)) = AddrHint -inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint -inferCmmHint _ = NoHint - -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True -isPtrGlobalReg CCCS = True -isPtrGlobalReg CurrentTSO = True -isPtrGlobalReg CurrentNursery = True -isPtrGlobalReg (VanillaReg _ VGcPtr) = True -isPtrGlobalReg _ = False - -happyError :: PD a -happyError = PD $ \_ s -> unP srcParseFail s - --- ----------------------------------------------------------------------------- --- Statement-level macros - -stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) -stmtMacro fun args_code = do - case lookupUFM stmtMacros fun of - Nothing -> fail ("unknown macro: " ++ unpackFS fun) - Just fcode -> return $ do - args <- sequence args_code - code (fcode args) - -stmtMacros :: UniqFM ([CmmExpr] -> FCode ()) -stmtMacros = listToUFM [ - ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), - ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), - - ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), - ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), - - -- completely generic heap and stack checks, for use in high-level cmm. - ( fsLit "HP_CHK_GEN", \[bytes] -> - heapStackCheckGen Nothing (Just bytes) ), - ( fsLit "STK_CHK_GEN", \[] -> - heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), - - -- A stack check for a fixed amount of stack. Sounds a bit strange, but - -- we use the stack for a bit of temporary storage in a couple of primops - ( fsLit "STK_CHK_GEN_N", \[bytes] -> - heapStackCheckGen (Just bytes) Nothing ), - - -- A stack check on entry to a thunk, where the argument is the thunk pointer. - ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), - - ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), - ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), - - ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ), - ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ), - - ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), - ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), - - ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), - ( fsLit "SET_HDR", \[ptr,info,ccs] -> - emitSetDynHdr ptr info ccs ), - ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> - tickyAllocPrim hdr goods slop ), - ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> - tickyAllocPAP goods slop ), - ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> - tickyAllocThunk goods slop ), - ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) - ] - -emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () -emitPushUpdateFrame sp e = do - dflags <- getDynFlags - emitUpdateFrame dflags sp mkUpdInfoLabel e - -pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () -pushStackFrame fields body = do - dflags <- getDynFlags - exprs <- sequence fields - updfr_off <- getUpdFrameOff - let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old - [] updfr_off exprs - emit g - withUpdFrameOff new_updfr_off body - -reserveStackFrame - :: CmmParse CmmExpr - -> CmmParse CmmReg - -> CmmParse () - -> CmmParse () -reserveStackFrame psize preg body = do - dflags <- getDynFlags - old_updfr_off <- getUpdFrameOff - reg <- preg - esize <- psize - let size = case constantFoldExpr dflags esize of - CmmLit (CmmInt n _) -> n - _other -> pprPanic "CmmParse: not a compile-time integer: " - (ppr esize) - let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size - emitAssign reg (CmmStackSlot Old frame) - withUpdFrameOff frame body - -profilingInfo dflags desc_str ty_str - = if not (gopt Opt_SccProfilingOn dflags) - then NoProfilingInfo - else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) - -staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () -staticClosure pkg cl_label info payload - = do dflags <- getDynFlags - let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] - code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits - -foreignCall - :: String - -> [CmmParse (LocalReg, ForeignHint)] - -> CmmParse CmmExpr - -> [CmmParse (CmmExpr, ForeignHint)] - -> Safety - -> CmmReturnInfo - -> PD (CmmParse ()) -foreignCall conv_string results_code expr_code args_code safety ret - = do conv <- case conv_string of - "C" -> return CCallConv - "stdcall" -> return StdCallConv - _ -> fail ("unknown calling convention: " ++ conv_string) - return $ do - dflags <- getDynFlags - results <- sequence results_code - expr <- expr_code - args <- sequence args_code - let - expr' = adjCallTarget dflags conv expr args - (arg_exprs, arg_hints) = unzip args - (res_regs, res_hints) = unzip results - res_cmm_tys = zip (map localRegType res_regs) res_hints - arg_cmm_tys = zip (map (cmmExprType dflags) arg_exprs) arg_hints - res_rep :: (CmmType, ForeignHint) -> PrimRep - res_rep (_, AddrHint) = AddrRep - res_rep (t, _) | isGcPtrType t = Word64Rep - res_rep (t, SignedHint) | t `cmmEqType` b8 = Int8Rep - res_rep (t, SignedHint) | t `cmmEqType` b16 = Int16Rep - res_rep (t, SignedHint) | t `cmmEqType` b32 = Int32Rep - res_rep (t, SignedHint) | t `cmmEqType` b64 = Int64Rep - res_rep (t, NoHint) | t `cmmEqType` b8 = Word8Rep - res_rep (t, NoHint) | t `cmmEqType` b16 = Word16Rep - res_rep (t, NoHint) | t `cmmEqType` b32 = Word32Rep - res_rep (t, NoHint) | t `cmmEqType` b64 = Word64Rep - res_rep (t, _) | t `cmmEqType` f32 = FloatRep - res_rep (t, _) | t `cmmEqType` f64 = DoubleRep - - ret_rep = case (map res_rep res_cmm_tys) of - [] -> VoidRep - [r] -> r - x -> (panic $ show x) - fc = ForeignConvention conv arg_hints res_hints ret ret_rep (map res_rep arg_cmm_tys) - target = ForeignTarget expr' fc - _ <- code $ emitForeignCall safety res_regs target arg_exprs - return () - - -doReturn :: [CmmParse CmmExpr] -> CmmParse () -doReturn exprs_code = do - dflags <- getDynFlags - exprs <- sequence exprs_code - updfr_off <- getUpdFrameOff - emit (mkReturnSimple dflags exprs updfr_off) - -mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkReturnSimple dflags actuals updfr_off = - mkReturn dflags e actuals updfr_off - where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) - (gcWord dflags)) - -doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () -doRawJump expr_code vols = do - dflags <- getDynFlags - expr <- expr_code - updfr_off <- getUpdFrameOff - emit (mkRawJump dflags expr updfr_off vols) - -doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] - -> [CmmParse CmmExpr] -> CmmParse () -doJumpWithStack expr_code stk_code args_code = do - dflags <- getDynFlags - expr <- expr_code - stk_args <- sequence stk_code - args <- sequence args_code - updfr_off <- getUpdFrameOff - emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args) - -doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] - -> CmmParse () -doCall expr_code res_code args_code = do - dflags <- getDynFlags - expr <- expr_code - args <- sequence args_code - ress <- sequence res_code - updfr_off <- getUpdFrameOff - c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] - emit c - -adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] - -> CmmExpr --- On Windows, we have to add the '@N' suffix to the label when making --- a call with the stdcall calling convention. -adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args - | platformOS (targetPlatform dflags) == OSMinGW32 - = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) - -- c.f. CgForeignCall.emitForeignCall -adjCallTarget _ _ expr _ - = expr - -primCall - :: [CmmParse (CmmFormal, ForeignHint)] - -> FastString - -> [CmmParse CmmExpr] - -> PD (CmmParse ()) -primCall results_code name args_code - = case lookupUFM callishMachOps name of - Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just f -> return $ do - results <- sequence results_code - args <- sequence args_code - let (p, args') = f args - code (emitPrimCall (map fst results) p args') - -doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () -doStore rep addr_code val_code - = do dflags <- getDynFlags - addr <- addr_code - val <- val_code - -- if the specified store type does not match the type of the expr - -- on the rhs, then we insert a coercion that will cause the type - -- mismatch to be flagged by cmm-lint. If we don't do this, then - -- the store will happen at the wrong type, and the error will not - -- be noticed. - let val_width = typeWidth (cmmExprType dflags val) - rep_width = typeWidth rep - let coerce_val - | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] - | otherwise = val - emitStore addr coerce_val - --- ----------------------------------------------------------------------------- --- If-then-else and boolean expressions - -data BoolExpr - = BoolExpr `BoolAnd` BoolExpr - | BoolExpr `BoolOr` BoolExpr - | BoolNot BoolExpr - | BoolTest CmmExpr - --- ToDo: smart constructors which simplify the boolean expression. - -cmmIfThenElse cond then_part else_part likely = do - then_id <- newBlockId - join_id <- newBlockId - c <- cond - emitCond c then_id likely - else_part - emit (mkBranch join_id) - emitLabel then_id - then_part - -- fall through to join - emitLabel join_id - -cmmRawIf cond then_id likely = do - c <- cond - emitCond c then_id likely - --- 'emitCond cond true_id' emits code to test whether the cond is true, --- branching to true_id if so, and falling through otherwise. -emitCond (BoolTest e) then_id likely = do - else_id <- newBlockId - emit (mkCbranch e then_id else_id likely) - emitLabel else_id -emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely - | Just op' <- maybeInvertComparison op - = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely) -emitCond (BoolNot e) then_id likely = do - else_id <- newBlockId - emitCond e else_id likely - emit (mkBranch then_id) - emitLabel else_id -emitCond (e1 `BoolOr` e2) then_id likely = do - emitCond e1 then_id likely - emitCond e2 then_id likely -emitCond (e1 `BoolAnd` e2) then_id likely = do - -- we'd like to invert one of the conditionals here to avoid an - -- extra branch instruction, but we can't use maybeInvertComparison - -- here because we can't look too closely at the expression since - -- we're in a loop. - and_id <- newBlockId - else_id <- newBlockId - emitCond e1 and_id likely - emit (mkBranch else_id) - emitLabel and_id - emitCond e2 then_id likely - emitLabel else_id - --- ----------------------------------------------------------------------------- --- Source code notes - --- | Generate a source note spanning from "a" to "b" (inclusive), then --- proceed with parsing. This allows debugging tools to reason about --- locations in Cmm code. -withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c -withSourceNote a b parse = do - name <- getName - case combineSrcSpans (getLoc a) (getLoc b) of - RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse - _other -> parse - --- ----------------------------------------------------------------------------- --- Table jumps - --- We use a simplified form of C-- switch statements for now. A --- switch statement always compiles to a table jump. Each arm can --- specify a list of values (not ranges), and there can be a single --- default branch. The range of the table is given either by the --- optional range on the switch (eg. switch [0..7] {...}), or by --- the minimum/maximum values from the branches. - -doSwitch :: Maybe (Integer,Integer) - -> CmmParse CmmExpr - -> [([Integer],Either BlockId (CmmParse ()))] - -> Maybe (CmmParse ()) -> CmmParse () -doSwitch mb_range scrut arms deflt - = do - -- Compile code for the default branch - dflt_entry <- - case deflt of - Nothing -> return Nothing - Just e -> do b <- forkLabelledCode e; return (Just b) - - -- Compile each case branch - table_entries <- mapM emitArm arms - let table = M.fromList (concat table_entries) - - dflags <- getDynFlags - let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range - - expr <- scrut - -- ToDo: check for out of range and jump to default if necessary - emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table) - where - emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)] - emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] - emitArm (ints,Right code) = do - blockid <- forkLabelledCode code - return [ (i,blockid) | i <- ints ] - -forkLabelledCode :: CmmParse () -> CmmParse BlockId -forkLabelledCode p = do - (_,ag) <- getCodeScoped p - l <- newBlockId - emitOutOfLine l ag - return l - --- ----------------------------------------------------------------------------- --- Putting it all together - --- The initial environment: we define some constants that the compiler --- knows about here. -initEnv :: DynFlags -> Env -initEnv dflags = listToUFM [ - ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )), - ( fsLit "SIZEOF_StgInfoTable", - VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) - ] - -parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) -parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do - buf <- hGetStringBuffer filename - let - init_loc = mkRealSrcLoc (mkFastString filename) 1 1 - init_state = (mkPState dflags buf init_loc) { lex_state = [0] } - -- reset the lex_state: the Lexer monad leaves some stuff - -- in there we don't want. - case unPD cmmParse dflags init_state of - PFailed pst -> - return (getMessages pst dflags, Nothing) - POk pst code -> do - st <- initC - let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return () - (cmm,_) = runC dflags no_module st fcode - let ms = getMessages pst dflags - if (errorsFound dflags ms) - then return (ms, Nothing) - else return (ms, Just cmm) - where - no_module = panic "parseCmmFile: no module" -} diff --git a/cmm/CmmPipeline.hs b/cmm/CmmPipeline.hs deleted file mode 100644 --- a/cmm/CmmPipeline.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module CmmPipeline ( - -- | Converts C-- with an implicit stack and native C-- calls into - -- optimized, CPS converted and native-call-less C--. The latter - -- C-- can be used to generate assembly. - cmmPipeline -) where - -import GhcPrelude - -import Cmm -import CmmLint -import CmmBuildInfoTables -import CmmCommonBlockElim -import CmmImplementSwitchPlans -import CmmProcPoint -import CmmContFlowOpt -import CmmLayoutStack -import CmmSink -import Hoopl.Collections - -import UniqSupply -import DynFlags -import ErrUtils -import HscTypes -import Control.Monad -import Outputable -import GHC.Platform - ------------------------------------------------------------------------------ --- | Top level driver for C-- pipeline ------------------------------------------------------------------------------ - -cmmPipeline - :: HscEnv -- Compilation env including - -- dynamic flags: -dcmm-lint -ddump-cmm-cps - -> ModuleSRTInfo -- Info about SRTs generated so far - -> CmmGroup -- Input C-- with Procedures - -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- - -cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ - do let dflags = hsc_dflags hsc_env - - tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog - - (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops - dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms) - - return (srtInfo, cmms) - - where forceRes (info, group) = - info `seq` foldr (\decl r -> decl `seq` r) () group - - dflags = hsc_dflags hsc_env - -cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) -cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) -cpsTop hsc_env proc = - do - ----------- Control-flow optimisations ---------------------------------- - - -- The first round of control-flow optimisation speeds up the - -- later passes by removing lots of empty blocks, so we do it - -- even when optimisation isn't turned on. - -- - CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} - return $ cmmCfgOptsProc splitting_proc_points proc - dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - - let !TopInfo {stack_info=StackInfo { arg_space = entry_off - , do_layout = do_layout }} = h - - ----------- Eliminate common blocks ------------------------------------- - g <- {-# SCC "elimCommonBlocks" #-} - condPass Opt_CmmElimCommonBlocks elimCommonBlocks g - Opt_D_dump_cmm_cbe "Post common block elimination" - - -- Any work storing block Labels must be performed _after_ - -- elimCommonBlocks - - ----------- Implement switches ------------------------------------------ - g <- {-# SCC "createSwitchPlans" #-} - runUniqSM $ cmmImplementSwitchPlans dflags g - dump Opt_D_dump_cmm_switch "Post switch plan" g - - ----------- Proc points ------------------------------------------------- - let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g - proc_points <- - if splitting_proc_points - then do - pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ - minimalProcPointSet (targetPlatform dflags) call_pps g - dumpWith dflags Opt_D_dump_cmm_proc "Proc points" - (ppr l $$ ppr pp $$ ppr g) - return pp - else - return call_pps - - ----------- Layout the stack and manifest Sp ---------------------------- - (g, stackmaps) <- - {-# SCC "layoutStack" #-} - if do_layout - then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g - else return (g, mapEmpty) - dump Opt_D_dump_cmm_sp "Layout Stack" g - - ----------- Sink and inline assignments -------------------------------- - g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] - condPass Opt_CmmSink (cmmSink dflags) g - Opt_D_dump_cmm_sink "Sink assignments" - - ------------- CAF analysis ---------------------------------------------- - let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g - dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv) - - g <- if splitting_proc_points - then do - ------------- Split into separate procedures ----------------------- - let pp_map = {-# SCC "procPointAnalysis" #-} - procPointAnalysis proc_points g - dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $ - ppr pp_map - g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ - splitAtProcPoints dflags l call_pps proc_points pp_map - (CmmProc h l v g) - dumps Opt_D_dump_cmm_split "Post splitting" g - return g - else do - -- attach info tables to return points - return $ [attachContInfoTables call_pps (CmmProc h l v g)] - - ------------- Populate info tables with stack info ----------------- - g <- {-# SCC "setInfoTableStackMap" #-} - return $ map (setInfoTableStackMap dflags stackmaps) g - dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g - - ----------- Control-flow optimisations ----------------------------- - g <- {-# SCC "cmmCfgOpts(2)" #-} - return $ if optLevel dflags >= 1 - then map (cmmCfgOptsProc splitting_proc_points) g - else g - g <- return (map removeUnreachableBlocksProc g) - -- See Note [unreachable blocks] - dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - - return (cafEnv, g) - - where dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - dump = dumpGraph dflags - - dumps flag name - = mapM_ (dumpWith dflags flag name . ppr) - - condPass flag pass g dumpflag dumpname = - if gopt flag dflags - then do - g <- return $ pass g - dump dumpflag dumpname g - return g - else return g - - -- we don't need to split proc points for the NCG, unless - -- tablesNextToCode is off. The latter is because we have no - -- label to put on info tables for basic blocks that are not - -- the entry point. - splitting_proc_points = hscTarget dflags /= HscAsm - || not (tablesNextToCode dflags) - || -- Note [inconsistent-pic-reg] - usingInconsistentPicReg - usingInconsistentPicReg - = case (platformArch platform, platformOS platform, positionIndependent dflags) - of (ArchX86, OSDarwin, pic) -> pic - _ -> False - --- Note [Sinking after stack layout] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- In the past we considered running sinking pass also before stack --- layout, but after making some measurements we realized that: --- --- a) running sinking only before stack layout produces slower --- code than running sinking only before stack layout --- --- b) running sinking both before and after stack layout produces --- code that has the same performance as when running sinking --- only after stack layout. --- --- In other words sinking before stack layout doesn't buy as anything. --- --- An interesting question is "why is it better to run sinking after --- stack layout"? It seems that the major reason are stores and loads --- generated by stack layout. Consider this code before stack layout: --- --- c1E: --- _c1C::P64 = R3; --- _c1B::P64 = R2; --- _c1A::P64 = R1; --- I64[(young + 8)] = c1D; --- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; --- c1D: --- R3 = _c1C::P64; --- R2 = _c1B::P64; --- R1 = _c1A::P64; --- call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8; --- --- Stack layout pass will save all local variables live across a call --- (_c1C, _c1B and _c1A in this example) on the stack just before --- making a call and reload them from the stack after returning from a --- call: --- --- c1E: --- _c1C::P64 = R3; --- _c1B::P64 = R2; --- _c1A::P64 = R1; --- I64[Sp - 32] = c1D; --- P64[Sp - 24] = _c1A::P64; --- P64[Sp - 16] = _c1B::P64; --- P64[Sp - 8] = _c1C::P64; --- Sp = Sp - 32; --- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; --- c1D: --- _c1A::P64 = P64[Sp + 8]; --- _c1B::P64 = P64[Sp + 16]; --- _c1C::P64 = P64[Sp + 24]; --- R3 = _c1C::P64; --- R2 = _c1B::P64; --- R1 = _c1A::P64; --- Sp = Sp + 32; --- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; --- --- If we don't run sinking pass after stack layout we are basically --- left with such code. However, running sinking on this code can lead --- to significant improvements: --- --- c1E: --- I64[Sp - 32] = c1D; --- P64[Sp - 24] = R1; --- P64[Sp - 16] = R2; --- P64[Sp - 8] = R3; --- Sp = Sp - 32; --- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; --- c1D: --- R3 = P64[Sp + 24]; --- R2 = P64[Sp + 16]; --- R1 = P64[Sp + 8]; --- Sp = Sp + 32; --- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; --- --- Now we only have 9 assignments instead of 15. --- --- There is one case when running sinking before stack layout could --- be beneficial. Consider this: --- --- L1: --- x = y --- call f() returns L2 --- L2: ...x...y... --- --- Since both x and y are live across a call to f, they will be stored --- on the stack during stack layout and restored after the call: --- --- L1: --- x = y --- P64[Sp - 24] = L2 --- P64[Sp - 16] = x --- P64[Sp - 8] = y --- Sp = Sp - 24 --- call f() returns L2 --- L2: --- y = P64[Sp + 16] --- x = P64[Sp + 8] --- Sp = Sp + 24 --- ...x...y... --- --- However, if we run sinking before stack layout we would propagate x --- to its usage place (both x and y must be local register for this to --- be possible - global registers cannot be floated past a call): --- --- L1: --- x = y --- call f() returns L2 --- L2: ...y...y... --- --- Thus making x dead at the call to f(). If we ran stack layout now --- we would generate less stores and loads: --- --- L1: --- x = y --- P64[Sp - 16] = L2 --- P64[Sp - 8] = y --- Sp = Sp - 16 --- call f() returns L2 --- L2: --- y = P64[Sp + 8] --- Sp = Sp + 16 --- ...y...y... --- --- But since we don't see any benefits from running sinking befroe stack --- layout, this situation probably doesn't arise too often in practice. --- - -{- Note [inconsistent-pic-reg] - -On x86/Darwin, PIC is implemented by inserting a sequence like - - call 1f - 1: popl %reg - -at the proc entry point, and then referring to labels as offsets from -%reg. If we don't split proc points, then we could have many entry -points in a proc that would need this sequence, and each entry point -would then get a different value for %reg. If there are any join -points, then at the join point we don't have a consistent value for -%reg, so we don't know how to refer to labels. - -Hence, on x86/Darwin, we have to split proc points, and then each proc -point will get its own PIC initialisation sequence. - -This isn't an issue on x86/ELF, where the sequence is - - call 1f - 1: popl %reg - addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg - -so %reg always has a consistent value: the address of -_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. - --} - -{- Note [unreachable blocks] - -The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. These aren't necessarily a problem, but -removing them is good because it might save time in the native code -generator later. - --} - -runUniqSM :: UniqSM a -> IO a -runUniqSM m = do - us <- mkSplitUniqSupply 'u' - return (initUs_ us m) - - -dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph dflags flag name g = do - when (gopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith dflags flag name (ppr g) - where - do_lint g = case cmmLintGraph dflags g of - Just err -> do { fatalErrorMsg dflags err - ; ghcExit dflags 1 - } - Nothing -> return () - -dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpWith dflags flag txt sdoc = do - dumpIfSet_dyn dflags flag txt sdoc - when (not (dopt flag dflags)) $ - -- If `-ddump-cmm-verbose -ddump-to-file` is specified, - -- dump each Cmm pipeline stage output to a separate file. #16930 - when (dopt Opt_D_dump_cmm_verbose dflags) - $ dumpSDoc dflags alwaysQualify flag txt sdoc - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt sdoc diff --git a/cmm/CmmProcPoint.hs b/cmm/CmmProcPoint.hs deleted file mode 100644 --- a/cmm/CmmProcPoint.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-} - -module CmmProcPoint - ( ProcPointSet, Status(..) - , callProcPoints, minimalProcPointSet - , splitAtProcPoints, procPointAnalysis - , attachContInfoTables - ) -where - -import GhcPrelude hiding (last, unzip, succ, zip) - -import DynFlags -import BlockId -import CLabel -import Cmm -import PprCmm () -- For Outputable instances -import CmmUtils -import CmmInfo -import CmmLive -import CmmSwitch -import Data.List (sortBy) -import Maybes -import Control.Monad -import Outputable -import GHC.Platform -import UniqSupply -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Dataflow -import Hoopl.Graph -import Hoopl.Label - --- Compute a minimal set of proc points for a control-flow graph. - --- Determine a protocol for each proc point (which live variables will --- be passed as arguments and which will be on the stack). - -{- -A proc point is a basic block that, after CPS transformation, will -start a new function. The entry block of the original function is a -proc point, as is the continuation of each function call. -A third kind of proc point arises if we want to avoid copying code. -Suppose we have code like the following: - - f() { - if (...) { ..1..; call foo(); ..2..} - else { ..3..; call bar(); ..4..} - x = y + z; - return x; - } - -The statement 'x = y + z' can be reached from two different proc -points: the continuations of foo() and bar(). We would prefer not to -put a copy in each continuation; instead we would like 'x = y + z' to -be the start of a new procedure to which the continuations can jump: - - f_cps () { - if (...) { ..1..; push k_foo; jump foo_cps(); } - else { ..3..; push k_bar; jump bar_cps(); } - } - k_foo() { ..2..; jump k_join(y, z); } - k_bar() { ..4..; jump k_join(y, z); } - k_join(y, z) { x = y + z; return x; } - -You might think then that a criterion to make a node a proc point is -that it is directly reached by two distinct proc points. (Note -[Direct reachability].) But this criterion is a bit too simple; for -example, 'return x' is also reached by two proc points, yet there is -no point in pulling it out of k_join. A good criterion would be to -say that a node should be made a proc point if it is reached by a set -of proc points that is different than its immediate dominator. NR -believes this criterion can be shown to produce a minimum set of proc -points, and given a dominator tree, the proc points can be chosen in -time linear in the number of blocks. Lacking a dominator analysis, -however, we turn instead to an iterative solution, starting with no -proc points and adding them according to these rules: - - 1. The entry block is a proc point. - 2. The continuation of a call is a proc point. - 3. A node is a proc point if it is directly reached by more proc - points than one of its predecessors. - -Because we don't understand the problem very well, we apply rule 3 at -most once per iteration, then recompute the reachability information. -(See Note [No simple dataflow].) The choice of the new proc point is -arbitrary, and I don't know if the choice affects the final solution, -so I don't know if the number of proc points chosen is the -minimum---but the set will be minimal. - - - -Note [Proc-point analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Given a specified set of proc-points (a set of block-ids), "proc-point -analysis" figures out, for every block, which proc-point it belongs to. -All the blocks belonging to proc-point P will constitute a single -top-level C procedure. - -A non-proc-point block B "belongs to" a proc-point P iff B is -reachable from P without going through another proc-point. - -Invariant: a block B should belong to at most one proc-point; if it -belongs to two, that's a bug. - -Note [Non-existing proc-points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -On some architectures it might happen that the list of proc-points -computed before stack layout pass will be invalidated by the stack -layout. This will happen if stack layout removes from the graph -blocks that were determined to be proc-points. Later on in the pipeline -we use list of proc-points to perform [Proc-point analysis], but -if a proc-point does not exist anymore then we will get compiler panic. -See #8205. --} - -type ProcPointSet = LabelSet - -data Status - = ReachedBy ProcPointSet -- set of proc points that directly reach the block - | ProcPoint -- this block is itself a proc point - -instance Outputable Status where - ppr (ReachedBy ps) - | setNull ps = text "" - | otherwise = text "reached by" <+> - (hsep $ punctuate comma $ map ppr $ setElems ps) - ppr ProcPoint = text "" - --------------------------------------------------- --- Proc point analysis - --- Once you know what the proc-points are, figure out --- what proc-points each block is reachable from --- See Note [Proc-point analysis] -procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status -procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) = - analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints - where - initProcPoints = - mkFactBase - procPointLattice - [ (id, ProcPoint) - | id <- setElems procPoints - -- See Note [Non-existing proc-points] - , id `setMember` labelsInGraph - ] - labelsInGraph = labelsDefined graph - -procPointTransfer :: TransferFun Status -procPointTransfer block facts = - let label = entryLabel block - !fact = case getFact procPointLattice label facts of - ProcPoint -> ReachedBy $! setSingleton label - f -> f - result = map (\id -> (id, fact)) (successors block) - in mkFactBase procPointLattice result - -procPointLattice :: DataflowLattice Status -procPointLattice = DataflowLattice unreached add_to - where - unreached = ReachedBy setEmpty - add_to (OldFact ProcPoint) _ = NotChanged ProcPoint - add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case - add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) - | setSize union > setSize p = Changed (ReachedBy union) - | otherwise = NotChanged (ReachedBy p) - where - union = setUnion p' p - ----------------------------------------------------------------------- - --- It is worth distinguishing two sets of proc points: those that are --- induced by calls in the original graph and those that are --- introduced because they're reachable from multiple proc points. --- --- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. -callProcPoints :: CmmGraph -> ProcPointSet -callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g - where add :: LabelSet -> CmmBlock -> LabelSet - add set b = case lastNode b of - CmmCall {cml_cont = Just k} -> setInsert k set - CmmForeignCall {succ=k} -> setInsert k set - _ -> set - -minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph - -> UniqSM ProcPointSet --- Given the set of successors of calls (which must be proc-points) --- figure out the minimal set of necessary proc-points -minimalProcPointSet platform callProcPoints g - = extendPPSet platform g (revPostorder g) callProcPoints - -extendPPSet - :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet -extendPPSet platform g blocks procPoints = - let env = procPointAnalysis procPoints g - add pps block = let id = entryLabel block - in case mapLookup id env of - Just ProcPoint -> setInsert id pps - _ -> pps - procPoints' = foldlGraphBlocks add setEmpty g - newPoints = mapMaybe ppSuccessor blocks - newPoint = listToMaybe newPoints - ppSuccessor b = - let nreached id = case mapLookup id env `orElse` - pprPanic "no ppt" (ppr id <+> ppr b) of - ProcPoint -> 1 - ReachedBy ps -> setSize ps - block_procpoints = nreached (entryLabel b) - -- | Looking for a successor of b that is reached by - -- more proc points than b and is not already a proc - -- point. If found, it can become a proc point. - newId succ_id = not (setMember succ_id procPoints') && - nreached succ_id > block_procpoints - in listToMaybe $ filter newId $ successors b - - in case newPoint of - Just id -> - if setMember id procPoints' - then panic "added old proc pt" - else extendPPSet platform g blocks (setInsert id procPoints') - Nothing -> return procPoints' - - --- At this point, we have found a set of procpoints, each of which should be --- the entry point of a procedure. --- Now, we create the procedure for each proc point, --- which requires that we: --- 1. build a map from proc points to the blocks reachable from the proc point --- 2. turn each branch to a proc point into a jump --- 3. turn calls and returns into jumps --- 4. build info tables for the procedures -- and update the info table for --- the SRTs in the entry procedure as well. --- Input invariant: A block should only be reachable from a single ProcPoint. --- ToDo: use the _ret naming convention that the old code generator --- used. -- EZY -splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> - CmmDecl -> UniqSM [CmmDecl] -splitAtProcPoints dflags entry_label callPPs procPoints procMap - (CmmProc (TopInfo {info_tbls = info_tbls}) - top_l _ g@(CmmGraph {g_entry=entry})) = - do -- Build a map from procpoints to the blocks they reach - let add_block - :: LabelMap (LabelMap CmmBlock) - -> CmmBlock - -> LabelMap (LabelMap CmmBlock) - add_block graphEnv b = - case mapLookup bid procMap of - Just ProcPoint -> add graphEnv bid bid b - Just (ReachedBy set) -> - case setElems set of - [] -> graphEnv - [id] -> add graphEnv id bid b - _ -> panic "Each block should be reachable from only one ProcPoint" - Nothing -> graphEnv - where bid = entryLabel b - add graphEnv procId bid b = mapInsert procId graph' graphEnv - where graph = mapLookup procId graphEnv `orElse` mapEmpty - graph' = mapInsert bid b graph - - let liveness = cmmGlobalLiveness dflags g - let ppLiveness pp = filter isArgReg $ - regSetToList $ - expectJust "ppLiveness" $ mapLookup pp liveness - - graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g - - -- Build a map from proc point BlockId to pairs of: - -- * Labels for their new procedures - -- * Labels for the info tables of their new procedures (only if - -- the proc point is a callPP) - -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = mapInsert pp lbls map - where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) - | otherwise = (block_lbl, guard (setMember pp callPPs) >> - Just info_table_lbl) - where block_lbl = blockLbl pp - info_table_lbl = infoTblLbl pp - - procLabels :: LabelMap (CLabel, Maybe CLabel) - procLabels = foldl' add_label mapEmpty - (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) - - -- In each new graph, add blocks jumping off to the new procedures, - -- and replace branches to procpoints with branches to the jump-off blocks - let add_jump_block - :: (LabelMap Label, [CmmBlock]) - -> (Label, CLabel) - -> UniqSM (LabelMap Label, [CmmBlock]) - add_jump_block (env, bs) (pp, l) = - do bid <- liftM mkBlockId getUniqueM - let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump - live = ppLiveness pp - jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 - return (mapInsert pp bid env, b : bs) - - add_jumps - :: LabelMap CmmGraph - -> (Label, LabelMap CmmBlock) - -> UniqSM (LabelMap CmmGraph) - add_jumps newGraphEnv (ppId, blockEnv) = - do let needed_jumps = -- find which procpoints we currently branch to - mapFoldr add_if_branch_to_pp [] blockEnv - add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] - add_if_branch_to_pp block rst = - case lastNode block of - CmmBranch id -> add_if_pp id rst - CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst) - CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids - _ -> rst - - -- when jumping to a PP that has an info table, if - -- tablesNextToCode is off we must jump to the entry - -- label instead. - jump_label (Just info_lbl) _ - | tablesNextToCode dflags = info_lbl - | otherwise = toEntryLbl info_lbl - jump_label Nothing block_lbl = block_lbl - - add_if_pp id rst = case mapLookup id procLabels of - Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst - Nothing -> rst - (jumpEnv, jumpBlocks) <- - foldM add_jump_block (mapEmpty, []) needed_jumps - -- update the entry block - let b = expectJust "block in env" $ mapLookup ppId blockEnv - blockEnv' = mapInsert ppId b blockEnv - -- replace branches to procpoints with branches to jumps - blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' - -- add the jump blocks to the graph - blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks - let g' = ofBlockMap ppId blockEnv''' - -- pprTrace "g' pre jumps" (ppr g') $ do - return (mapInsert ppId g' newGraphEnv) - - graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv - - let to_proc (bid, g) - | bid == entry - = CmmProc (TopInfo {info_tbls = info_tbls, - stack_info = stack_info}) - top_l live g' - | otherwise - = case expectJust "pp label" $ mapLookup bid procLabels of - (lbl, Just info_lbl) - -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) - , stack_info=stack_info}) - lbl live g' - (lbl, Nothing) - -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) - lbl live g' - where - g' = replacePPIds g - live = ppLiveness (g_entry g') - stack_info = StackInfo { arg_space = 0 - , updfr_space = Nothing - , do_layout = True } - -- cannot use panic, this is printed by -ddump-cmm - - -- References to procpoint IDs can now be replaced with the - -- infotable's label - replacePPIds g = {-# SCC "replacePPIds" #-} - mapGraphNodes (id, mapExp repl, mapExp repl) g - where repl e@(CmmLit (CmmBlock bid)) = - case mapLookup bid procLabels of - Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) - _ -> e - repl e = e - - -- The C back end expects to see return continuations before the - -- call sites. Here, we sort them in reverse order -- it gets - -- reversed later. - let (_, block_order) = - foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) - (revPostorder g) - add_block_num (i, map) block = - (i + 1, mapInsert (entryLabel block) i map) - sort_fn (bid, _) (bid', _) = - compare (expectJust "block_order" $ mapLookup bid block_order) - (expectJust "block_order" $ mapLookup bid' block_order) - procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv - return -- pprTrace "procLabels" (ppr procLabels) - -- pprTrace "splitting graphs" (ppr procs) - procs -splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] - --- Only called from CmmProcPoint.splitAtProcPoints. NB. does a --- recursive lookup, see comment below. -replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph -replaceBranches env cmmg - = {-# SCC "replaceBranches" #-} - ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg - where - f block = replaceLastNode block $ last (lastNode block) - - last :: CmmNode O C -> CmmNode O C - last (CmmBranch id) = CmmBranch (lookup id) - last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l - last (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets lookup ids) - last l@(CmmCall {}) = l { cml_cont = Nothing } - -- NB. remove the continuation of a CmmCall, since this - -- label will now be in a different CmmProc. Not only - -- is this tidier, it stops CmmLint from complaining. - last l@(CmmForeignCall {}) = l - lookup id = fmap lookup (mapLookup id env) `orElse` id - -- XXX: this is a recursive lookup, it follows chains - -- until the lookup returns Nothing, at which point we - -- return the last BlockId - --- -------------------------------------------------------------- --- Not splitting proc points: add info tables for continuations - -attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl -attachContInfoTables call_proc_points (CmmProc top_info top_l live g) - = CmmProc top_info{info_tbls = info_tbls'} top_l live g - where - info_tbls' = mapUnion (info_tbls top_info) $ - mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) - | l <- setElems call_proc_points - , l /= g_entry g ] -attachContInfoTables _ other_decl - = other_decl - ----------------------------------------------------------------- - -{- -Note [Direct reachability] - -Block B is directly reachable from proc point P iff control can flow -from P to B without passing through an intervening proc point. --} - ----------------------------------------------------------------- - -{- -Note [No simple dataflow] - -Sadly, it seems impossible to compute the proc points using a single -dataflow pass. One might attempt to use this simple lattice: - - data Location = Unknown - | InProc BlockId -- node is in procedure headed by the named proc point - | ProcPoint -- node is itself a proc point - -At a join, a node in two different blocks becomes a proc point. -The difficulty is that the change of information during iterative -computation may promote a node prematurely. Here's a program that -illustrates the difficulty: - - f () { - entry: - .... - L1: - if (...) { ... } - else { ... } - - L2: if (...) { g(); goto L1; } - return x + y; - } - -The only proc-point needed (besides the entry) is L1. But in an -iterative analysis, consider what happens to L2. On the first pass -through, it rises from Unknown to 'InProc entry', but when L1 is -promoted to a proc point (because it's the successor of g()), L1's -successors will be promoted to 'InProc L1'. The problem hits when the -new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. -The join operation makes it a proc point when in fact it needn't be, -because its immediate dominator L1 is already a proc point and there -are no other proc points that directly reach L2. --} - - - -{- Note [Separate Adams optimization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It may be worthwhile to attempt the Adams optimization by rewriting -the graph before the assignment of proc-point protocols. Here are a -couple of rules: - - g() returns to k; g() returns to L; - k: CopyIn c ress; goto L: - ... ==> ... - L: // no CopyIn node here L: CopyIn c ress; - - -And when c == c' and ress == ress', this also: - - g() returns to k; g() returns to L; - k: CopyIn c ress; goto L: - ... ==> ... - L: CopyIn c' ress' L: CopyIn c' ress' ; - -In both cases the goal is to eliminate k. --} diff --git a/cmm/CmmSink.hs b/cmm/CmmSink.hs deleted file mode 100644 --- a/cmm/CmmSink.hs +++ /dev/null @@ -1,854 +0,0 @@ -{-# LANGUAGE GADTs #-} -module CmmSink ( - cmmSink - ) where - -import GhcPrelude - -import Cmm -import CmmOpt -import CmmLive -import CmmUtils -import Hoopl.Block -import Hoopl.Label -import Hoopl.Collections -import Hoopl.Graph -import GHC.Platform.Regs -import GHC.Platform (isARM, platformArch) - -import DynFlags -import Unique -import UniqFM - -import qualified Data.IntSet as IntSet -import Data.List (partition) -import qualified Data.Set as Set -import Data.Maybe - --- Compact sets for membership tests of local variables. - -type LRegSet = IntSet.IntSet - -emptyLRegSet :: LRegSet -emptyLRegSet = IntSet.empty - -nullLRegSet :: LRegSet -> Bool -nullLRegSet = IntSet.null - -insertLRegSet :: LocalReg -> LRegSet -> LRegSet -insertLRegSet l = IntSet.insert (getKey (getUnique l)) - -elemLRegSet :: LocalReg -> LRegSet -> Bool -elemLRegSet l = IntSet.member (getKey (getUnique l)) - --- ----------------------------------------------------------------------------- --- Sinking and inlining - --- This is an optimisation pass that --- (a) moves assignments closer to their uses, to reduce register pressure --- (b) pushes assignments into a single branch of a conditional if possible --- (c) inlines assignments to registers that are mentioned only once --- (d) discards dead assignments --- --- This tightens up lots of register-heavy code. It is particularly --- helpful in the Cmm generated by the Stg->Cmm code generator, in --- which every function starts with a copyIn sequence like: --- --- x1 = R1 --- x2 = Sp[8] --- x3 = Sp[16] --- if (Sp - 32 < SpLim) then L1 else L2 --- --- we really want to push the x1..x3 assignments into the L2 branch. --- --- Algorithm: --- --- * Start by doing liveness analysis. --- --- * Keep a list of assignments A; earlier ones may refer to later ones. --- Currently we only sink assignments to local registers, because we don't --- have liveness information about global registers. --- --- * Walk forwards through the graph, look at each node N: --- --- * If it is a dead assignment, i.e. assignment to a register that is --- not used after N, discard it. --- --- * Try to inline based on current list of assignments --- * If any assignments in A (1) occur only once in N, and (2) are --- not live after N, inline the assignment and remove it --- from A. --- --- * If an assignment in A is cheap (RHS is local register), then --- inline the assignment and keep it in A in case it is used afterwards. --- --- * Otherwise don't inline. --- --- * If N is assignment to a local register pick up the assignment --- and add it to A. --- --- * If N is not an assignment to a local register: --- * remove any assignments from A that conflict with N, and --- place them before N in the current block. We call this --- "dropping" the assignments. --- --- * An assignment conflicts with N if it: --- - assigns to a register mentioned in N --- - mentions a register assigned by N --- - reads from memory written by N --- * do this recursively, dropping dependent assignments --- --- * At an exit node: --- * drop any assignments that are live on more than one successor --- and are not trivial --- * if any successor has more than one predecessor (a join-point), --- drop everything live in that successor. Since we only propagate --- assignments that are not dead at the successor, we will therefore --- eliminate all assignments dead at this point. Thus analysis of a --- join-point will always begin with an empty list of assignments. --- --- --- As a result of above algorithm, sinking deletes some dead assignments --- (transitively, even). This isn't as good as removeDeadAssignments, --- but it's much cheaper. - --- ----------------------------------------------------------------------------- --- things that we aren't optimising very well yet. --- --- ----------- --- (1) From GHC's FastString.hashStr: --- --- s2ay: --- if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp; --- c2gn: --- R1 = _s2au::I64; --- call (I64[Sp])(R1) args: 8, res: 0, upd: 8; --- c2gp: --- _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128, --- 4091); --- _s2an::I64 = _s2an::I64 + 1; --- _s2au::I64 = _s2cO::I64; --- goto s2ay; --- --- a nice loop, but we didn't eliminate the silly assignment at the end. --- See Note [dependent assignments], which would probably fix this. --- This is #8336. --- --- ----------- --- (2) From stg_atomically_frame in PrimOps.cmm --- --- We have a diamond control flow: --- --- x = ... --- | --- / \ --- A B --- \ / --- | --- use of x --- --- Now x won't be sunk down to its use, because we won't push it into --- both branches of the conditional. We certainly do have to check --- that we can sink it past all the code in both A and B, but having --- discovered that, we could sink it to its use. --- - --- ----------------------------------------------------------------------------- - -type Assignment = (LocalReg, CmmExpr, AbsMem) - -- Assignment caches AbsMem, an abstraction of the memory read by - -- the RHS of the assignment. - -type Assignments = [Assignment] - -- A sequence of assignments; kept in *reverse* order - -- So the list [ x=e1, y=e2 ] means the sequence of assignments - -- y = e2 - -- x = e1 - -cmmSink :: DynFlags -> CmmGraph -> CmmGraph -cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks - where - liveness = cmmLocalLiveness dflags graph - getLive l = mapFindWithDefault Set.empty l liveness - - blocks = revPostorder graph - - join_pts = findJoinPoints blocks - - sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock] - sink _ [] = [] - sink sunk (b:bs) = - -- pprTrace "sink" (ppr lbl) $ - blockJoin first final_middle final_last : sink sunk' bs - where - lbl = entryLabel b - (first, middle, last) = blockSplit b - - succs = successors last - - -- Annotate the middle nodes with the registers live *after* - -- the node. This will help us decide whether we can inline - -- an assignment in the current node or not. - live = Set.unions (map getLive succs) - live_middle = gen_kill dflags last live - ann_middles = annotate dflags live_middle (blockToList middle) - - -- Now sink and inline in this block - (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) - fold_last = constantFoldNode dflags last - (final_last, assigs') = tryToInline dflags live fold_last assigs - - -- We cannot sink into join points (successors with more than - -- one predecessor), so identify the join points and the set - -- of registers live in them. - (joins, nonjoins) = partition (`mapMember` join_pts) succs - live_in_joins = Set.unions (map getLive joins) - - -- We do not want to sink an assignment into multiple branches, - -- so identify the set of registers live in multiple successors. - -- This is made more complicated because when we sink an assignment - -- into one branch, this might change the set of registers that are - -- now live in multiple branches. - init_live_sets = map getLive nonjoins - live_in_multi live_sets r = - case filter (Set.member r) live_sets of - (_one:_two:_) -> True - _ -> False - - -- Now, drop any assignments that we will not sink any further. - (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs' - - drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') - where - should_drop = conflicts dflags a final_last - || not (isTrivial dflags rhs) && live_in_multi live_sets r - || r `Set.member` live_in_joins - - live_sets' | should_drop = live_sets - | otherwise = map upd live_sets - - upd set | r `Set.member` set = set `Set.union` live_rhs - | otherwise = set - - live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs - - final_middle = foldl' blockSnoc middle' dropped_last - - sunk' = mapUnion sunk $ - mapFromList [ (l, filterAssignments dflags (getLive l) assigs'') - | l <- succs ] - -{- TODO: enable this later, when we have some good tests in place to - measure the effect and tune it. - --- small: an expression we don't mind duplicating -isSmall :: CmmExpr -> Bool -isSmall (CmmReg (CmmLocal _)) = True -- -isSmall (CmmLit _) = True -isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y -isSmall (CmmRegOff (CmmLocal _) _) = True -isSmall _ = False --} - --- --- We allow duplication of trivial expressions: registers (both local and --- global) and literals. --- -isTrivial :: DynFlags -> CmmExpr -> Bool -isTrivial _ (CmmReg (CmmLocal _)) = True -isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] - if isARM (platformArch (targetPlatform dflags)) - then True -- CodeGen.Platform.ARM does not have globalRegMaybe - else isJust (globalRegMaybe (targetPlatform dflags) r) - -- GlobalRegs that are loads from BaseReg are not trivial -isTrivial _ (CmmLit _) = True -isTrivial _ _ = False - --- --- annotate each node with the set of registers live *after* the node --- -annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] -annotate dflags live nodes = snd $ foldr ann (live,[]) nodes - where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes) - --- --- Find the blocks that have multiple successors (join points) --- -findJoinPoints :: [CmmBlock] -> LabelMap Int -findJoinPoints blocks = mapFilter (>1) succ_counts - where - all_succs = concatMap successors blocks - - succ_counts :: LabelMap Int - succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs - --- --- filter the list of assignments to remove any assignments that --- are not live in a continuation. --- -filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments -filterAssignments dflags live assigs = reverse (go assigs []) - where go [] kept = kept - go (a@(r,_,_):as) kept | needed = go as (a:kept) - | otherwise = go as kept - where - needed = r `Set.member` live - || any (conflicts dflags a) (map toNode kept) - -- Note that we must keep assignments that are - -- referred to by other assignments we have - -- already kept. - --- ----------------------------------------------------------------------------- --- Walk through the nodes of a block, sinking and inlining assignments --- as we go. --- --- On input we pass in a: --- * list of nodes in the block --- * a list of assignments that appeared *before* this block and --- that are being sunk. --- --- On output we get: --- * a new block --- * a list of assignments that will be placed *after* that block. --- - -walk :: DynFlags - -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with - -- the set of registers live *after* - -- this node. - - -> Assignments -- The current list of - -- assignments we are sinking. - -- Earlier assignments may refer - -- to later ones. - - -> ( Block CmmNode O O -- The new block - , Assignments -- Assignments to sink further - ) - -walk dflags nodes assigs = go nodes emptyBlock assigs - where - go [] block as = (block, as) - go ((live,node):ns) block as - | shouldDiscard node live = go ns block as - -- discard dead assignment - | Just a <- shouldSink dflags node2 = go ns block (a : as1) - | otherwise = go ns block' as' - where - node1 = constantFoldNode dflags node - - (node2, as1) = tryToInline dflags live node1 as - - (dropped, as') = dropAssignmentsSimple dflags - (\a -> conflicts dflags a node2) as1 - - block' = foldl' blockSnoc block dropped `blockSnoc` node2 - - --- --- Heuristic to decide whether to pick up and sink an assignment --- Currently we pick up all assignments to local registers. It might --- be profitable to sink assignments to global regs too, but the --- liveness analysis doesn't track those (yet) so we can't. --- -shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment -shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e) - where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e -shouldSink _ _other = Nothing - --- --- discard dead assignments. This doesn't do as good a job as --- removeDeadAssignments, because it would need multiple passes --- to get all the dead code, but it catches the common case of --- superfluous reloads from the stack that the stack allocator --- leaves behind. --- --- Also we catch "r = r" here. You might think it would fall --- out of inlining, but the inliner will see that r is live --- after the instruction and choose not to inline r in the rhs. --- -shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool -shouldDiscard node live - = case node of - CmmAssign r (CmmReg r') | r == r' -> True - CmmAssign (CmmLocal r) _ -> not (r `Set.member` live) - _otherwise -> False - - -toNode :: Assignment -> CmmNode O O -toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs - -dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments - -> ([CmmNode O O], Assignments) -dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) () - -dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments - -> ([CmmNode O O], Assignments) -dropAssignments dflags should_drop state assigs - = (dropped, reverse kept) - where - (dropped,kept) = go state assigs [] [] - - go _ [] dropped kept = (dropped, kept) - go state (assig : rest) dropped kept - | conflict = go state' rest (toNode assig : dropped) kept - | otherwise = go state' rest dropped (assig:kept) - where - (dropit, state') = should_drop assig state - conflict = dropit || any (conflicts dflags assig) dropped - - --- ----------------------------------------------------------------------------- --- Try to inline assignments into a node. --- This also does constant folding for primpops, since --- inlining opens up opportunities for doing so. - -tryToInline - :: DynFlags - -> LocalRegSet -- set of registers live after this - -- node. We cannot inline anything - -- that is live after the node, unless - -- it is small enough to duplicate. - -> CmmNode O x -- The node to inline into - -> Assignments -- Assignments to inline - -> ( - CmmNode O x -- New node - , Assignments -- Remaining assignments - ) - -tryToInline dflags live node assigs = go usages node emptyLRegSet assigs - where - usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used - usages = foldLocalRegsUsed dflags addUsage emptyUFM node - - go _usages node _skipped [] = (node, []) - - go usages node skipped (a@(l,rhs,_) : rest) - | cannot_inline = dont_inline - | occurs_none = discard -- Note [discard during inlining] - | occurs_once = inline_and_discard - | isTrivial dflags rhs = inline_and_keep - | otherwise = dont_inline - where - inline_and_discard = go usages' inl_node skipped rest - where usages' = foldLocalRegsUsed dflags addUsage usages rhs - - discard = go usages node skipped rest - - dont_inline = keep node -- don't inline the assignment, keep it - inline_and_keep = keep inl_node -- inline the assignment, keep it - - keep node' = (final_node, a : rest') - where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest - usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) - usages rhs - -- we must not inline anything that is mentioned in the RHS - -- of a binding that we have already skipped, so we set the - -- usages of the regs on the RHS to 2. - - cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments] - || l `elemLRegSet` skipped - || not (okToInline dflags rhs node) - - l_usages = lookupUFM usages l - l_live = l `elemRegSet` live - - occurs_once = not l_live && l_usages == Just 1 - occurs_none = not l_live && l_usages == Nothing - - inl_node = improveConditional (mapExpDeep inl_exp node) - - inl_exp :: CmmExpr -> CmmExpr - -- inl_exp is where the inlining actually takes place! - inl_exp (CmmReg (CmmLocal l')) | l == l' = rhs - inl_exp (CmmRegOff (CmmLocal l') off) | l == l' - = cmmOffset dflags rhs off - -- re-constant fold after inlining - inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args - inl_exp other = other - - -{- Note [improveConditional] - -cmmMachOpFold tries to simplify conditionals to turn things like - (a == b) != 1 -into - (a != b) -but there's one case it can't handle: when the comparison is over -floating-point values, we can't invert it, because floating-point -comparisons aren't invertible (because of NaNs). - -But we *can* optimise this conditional by swapping the true and false -branches. Given - CmmCondBranch ((a >## b) != 1) t f -we can turn it into - CmmCondBranch (a >## b) f t - -So here we catch conditionals that weren't optimised by cmmMachOpFold, -and apply above transformation to eliminate the comparison against 1. - -It's tempting to just turn every != into == and then let cmmMachOpFold -do its thing, but that risks changing a nice fall-through conditional -into one that requires two jumps. (see swapcond_last in -CmmContFlowOpt), so instead we carefully look for just the cases where -we can eliminate a comparison. --} -improveConditional :: CmmNode O x -> CmmNode O x -improveConditional - (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l) - | neLike mop, isComparisonExpr x - = CmmCondBranch x f t (fmap not l) - where - neLike (MO_Ne _) = True - neLike (MO_U_Lt _) = True -- (x LocalReg -> UniqFM Int -addUsage m r = addToUFM_C (+) m r 1 - -regsUsedIn :: LRegSet -> CmmExpr -> Bool -regsUsedIn ls _ | nullLRegSet ls = False -regsUsedIn ls e = wrapRecExpf f e False - where f (CmmReg (CmmLocal l)) _ | l `elemLRegSet` ls = True - f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True - f _ z = z - --- we don't inline into CmmUnsafeForeignCall if the expression refers --- to global registers. This is a HACK to avoid global registers --- clashing with C argument-passing registers, really the back-end --- ought to be able to handle it properly, but currently neither PprC --- nor the NCG can do it. See Note [Register parameter passing] --- See also GHC.StgToCmm.Foreign.load_args_into_temps. -okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -okToInline dflags expr node@(CmmUnsafeForeignCall{}) = - not (globalRegistersConflict dflags expr node) -okToInline _ _ _ = True - --- ----------------------------------------------------------------------------- - --- | @conflicts (r,e) node@ is @False@ if and only if the assignment --- @r = e@ can be safely commuted past statement @node@. -conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool -conflicts dflags (r, rhs, addr) node - - -- (1) node defines registers used by rhs of assignment. This catches - -- assignments and all three kinds of calls. See Note [Sinking and calls] - | globalRegistersConflict dflags rhs node = True - | localRegistersConflict dflags rhs node = True - - -- (2) node uses register defined by assignment - | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True - - -- (3) a store to an address conflicts with a read of the same memory - | CmmStore addr' e <- node - , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True - - -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively - | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True - | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - - -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] - | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True - - -- (6) native calls clobber any memory - | CmmCall{} <- node, memConflicts addr AnyMem = True - - -- (7) otherwise, no conflict - | otherwise = False - --- Returns True if node defines any global registers that are used in the --- Cmm expression -globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -globalRegistersConflict dflags expr node = - foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr) - False node - --- Returns True if node defines any local registers that are used in the --- Cmm expression -localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -localRegistersConflict dflags expr node = - foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal r) expr) - False node - --- Note [Sinking and calls] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) --- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after --- stack layout (see Note [Sinking after stack layout]) which leads to two --- invariants related to calls: --- --- a) during stack layout phase all safe foreign calls are turned into --- unsafe foreign calls (see Note [Lower safe foreign calls]). This --- means that we will never encounter CmmForeignCall node when running --- sinking after stack layout --- --- b) stack layout saves all variables live across a call on the stack --- just before making a call (remember we are not sinking assignments to --- stack): --- --- L1: --- x = R1 --- P64[Sp - 16] = L2 --- P64[Sp - 8] = x --- Sp = Sp - 16 --- call f() returns L2 --- L2: --- --- We will attempt to sink { x = R1 } but we will detect conflict with --- { P64[Sp - 8] = x } and hence we will drop { x = R1 } without even --- checking whether it conflicts with { call f() }. In this way we will --- never need to check any assignment conflicts with CmmCall. Remember --- that we still need to check for potential memory conflicts. --- --- So the result is that we only need to worry about CmmUnsafeForeignCall nodes --- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]). --- This assumption holds only when we do sinking after stack layout. If we run --- it before stack layout we need to check for possible conflicts with all three --- kinds of calls. Our `conflicts` function does that by using a generic --- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and --- UserOfRegs typeclasses. --- - --- An abstraction of memory read or written. -data AbsMem - = NoMem -- no memory accessed - | AnyMem -- arbitrary memory - | HeapMem -- definitely heap memory - | StackMem -- definitely stack memory - | SpMem -- [Sp+n] - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - --- Having SpMem is important because it lets us float loads from Sp --- past stores to Sp as long as they don't overlap, and this helps to --- unravel some long sequences of --- x1 = [Sp + 8] --- x2 = [Sp + 16] --- ... --- [Sp + 8] = xi --- [Sp + 16] = xj --- --- Note that SpMem is invalidated if Sp is changed, but the definition --- of 'conflicts' above handles that. - --- ToDo: this won't currently fix the following commonly occurring code: --- x1 = [R1 + 8] --- x2 = [R1 + 16] --- .. --- [Hp - 8] = x1 --- [Hp - 16] = x2 --- .. - --- because [R1 + 8] and [Hp - 8] are both HeapMem. We know that --- assignments to [Hp + n] do not conflict with any other heap memory, --- but this is tricky to nail down. What if we had --- --- x = Hp + n --- [x] = ... --- --- the store to [x] should be "new heap", not "old heap". --- Furthermore, you could imagine that if we started inlining --- functions in Cmm then there might well be reads of heap memory --- that was written in the same basic block. To take advantage of --- non-aliasing of heap memory we will have to be more clever. - --- Note [Foreign calls clobber heap] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- It is tempting to say that foreign calls clobber only --- non-heap/stack memory, but unfortunately we break this invariant in --- the RTS. For example, in stg_catch_retry_frame we call --- stmCommitNestedTransaction() which modifies the contents of the --- TRec it is passed (this actually caused incorrect code to be --- generated). --- --- Since the invariant is true for the majority of foreign calls, --- perhaps we ought to have a special annotation for calls that can --- modify heap/stack memory. For now we just use the conservative --- definition here. --- --- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and --- therefore we should never float any memory operations across one of --- these calls. - - -bothMems :: AbsMem -> AbsMem -> AbsMem -bothMems NoMem x = x -bothMems x NoMem = x -bothMems HeapMem HeapMem = HeapMem -bothMems StackMem StackMem = StackMem -bothMems (SpMem o1 w1) (SpMem o2 w2) - | o1 == o2 = SpMem o1 (max w1 w2) - | otherwise = StackMem -bothMems SpMem{} StackMem = StackMem -bothMems StackMem SpMem{} = StackMem -bothMems _ _ = AnyMem - -memConflicts :: AbsMem -> AbsMem -> Bool -memConflicts NoMem _ = False -memConflicts _ NoMem = False -memConflicts HeapMem StackMem = False -memConflicts StackMem HeapMem = False -memConflicts SpMem{} HeapMem = False -memConflicts HeapMem SpMem{} = False -memConflicts (SpMem o1 w1) (SpMem o2 w2) - | o1 < o2 = o1 + w1 > o2 - | otherwise = o2 + w2 > o1 -memConflicts _ _ = True - -exprMem :: DynFlags -> CmmExpr -> AbsMem -exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr) -exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es) -exprMem _ _ = NoMem - -loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem -loadAddr dflags e w = - case e of - CmmReg r -> regAddr dflags r 0 w - CmmRegOff r i -> regAddr dflags r i w - _other | regUsedIn dflags spReg e -> StackMem - | otherwise -> AnyMem - -regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem -regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) -regAddr _ (CmmGlobal Hp) _ _ = HeapMem -regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps -regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself -regAddr _ _ _ _ = AnyMem - -{- -Note [Inline GlobalRegs?] - -Should we freely inline GlobalRegs? - -Actually it doesn't make a huge amount of difference either way, so we -*do* currently treat GlobalRegs as "trivial" and inline them -everywhere, but for what it's worth, here is what I discovered when I -(SimonM) looked into this: - -Common sense says we should not inline GlobalRegs, because when we -have - - x = R1 - -the register allocator will coalesce this assignment, generating no -code, and simply record the fact that x is bound to $rbx (or -whatever). Furthermore, if we were to sink this assignment, then the -range of code over which R1 is live increases, and the range of code -over which x is live decreases. All things being equal, it is better -for x to be live than R1, because R1 is a fixed register whereas x can -live in any register. So we should neither sink nor inline 'x = R1'. - -However, not inlining GlobalRegs can have surprising -consequences. e.g. (cgrun020) - - c3EN: - _s3DB::P64 = R1; - _c3ES::P64 = _s3DB::P64 & 7; - if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV; - c3EU: - _s3DD::P64 = P64[_s3DB::P64 + 6]; - _s3DE::P64 = P64[_s3DB::P64 + 14]; - I64[Sp - 8] = c3F0; - R1 = _s3DE::P64; - P64[Sp] = _s3DD::P64; - -inlining the GlobalReg gives: - - c3EN: - if (R1 & 7 >= 2) goto c3EU; else goto c3EV; - c3EU: - I64[Sp - 8] = c3F0; - _s3DD::P64 = P64[R1 + 6]; - R1 = P64[R1 + 14]; - P64[Sp] = _s3DD::P64; - -but if we don't inline the GlobalReg, instead we get: - - _s3DB::P64 = R1; - if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV; - c3EU: - I64[Sp - 8] = c3F0; - R1 = P64[_s3DB::P64 + 14]; - P64[Sp] = P64[_s3DB::P64 + 6]; - -This looks better - we managed to inline _s3DD - but in fact it -generates an extra reg-reg move: - -.Lc3EU: - movq $c3F0_info,-8(%rbp) - movq %rbx,%rax - movq 14(%rbx),%rbx - movq 6(%rax),%rax - movq %rax,(%rbp) - -because _s3DB is now live across the R1 assignment, we lost the -benefit of coalescing. - -Who is at fault here? Perhaps if we knew that _s3DB was an alias for -R1, then we would not sink a reference to _s3DB past the R1 -assignment. Or perhaps we *should* do that - we might gain by sinking -it, despite losing the coalescing opportunity. - -Sometimes not inlining global registers wins by virtue of the rule -about not inlining into arguments of a foreign call, e.g. (T7163) this -is what happens when we inlined F1: - - _s3L2::F32 = F1; - _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32); - (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(_c3O3::F32); - -but if we don't inline F1: - - (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(%MO_F_Mul_W32(_s3L2::F32, - 10.0 :: W32)); --} diff --git a/cmm/CmmSwitch.hs b/cmm/CmmSwitch.hs deleted file mode 100644 --- a/cmm/CmmSwitch.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE GADTs #-} -module CmmSwitch ( - SwitchTargets, - mkSwitchTargets, - switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned, - mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough, - switchTargetsToList, eqSwitchTargetWith, - - SwitchPlan(..), - targetSupportsSwitch, - createSwitchPlan, - ) where - -import GhcPrelude - -import Outputable -import DynFlags -import Hoopl.Label (Label) - -import Data.Maybe -import Data.List (groupBy) -import Data.Function (on) -import qualified Data.Map as M - --- Note [Cmm Switches, the general plan] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Compiling a high-level switch statement, as it comes out of a STG case --- expression, for example, allows for a surprising amount of design decisions. --- Therefore, we cleanly separated this from the Stg → Cmm transformation, as --- well as from the actual code generation. --- --- The overall plan is: --- * The Stg → Cmm transformation creates a single `SwitchTargets` in --- emitSwitch and emitCmmLitSwitch in GHC.StgToCmm/Utils.hs. --- At this stage, they are unsuitable for code generation. --- * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these --- switch statements with code that is suitable for code generation, i.e. --- a nice balanced tree of decisions with dense jump tables in the leafs. --- The actual planning of this tree is performed in pure code in createSwitchPlan --- in this module. See Note [createSwitchPlan]. --- * The actual code generation will not do any further processing and --- implement each CmmSwitch with a jump tables. --- --- When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch --- statements alone, as we can turn a SwitchTargets value into a nice --- switch-statement in LLVM resp. C, and leave the rest to the compiler. --- --- See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are --- separated. - ------------------------------------------------------------------------------ --- Note [Magic Constants in CmmSwitch] --- --- There are a lot of heuristics here that depend on magic values where it is --- hard to determine the "best" value (for whatever that means). These are the --- magic values: - --- | Number of consecutive default values allowed in a jump table. If there are --- more of them, the jump tables are split. --- --- Currently 7, as it costs 7 words of additional code when a jump table is --- split (at least on x64, determined experimentally). -maxJumpTableHole :: Integer -maxJumpTableHole = 7 - --- | Minimum size of a jump table. If the number is smaller, the switch is --- implemented using conditionals. --- Currently 5, because an if-then-else tree of 4 values is nice and compact. -minJumpTableSize :: Int -minJumpTableSize = 5 - --- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset]. -minJumpTableOffset :: Integer -minJumpTableOffset = 2 - - ------------------------------------------------------------------------------ --- Switch Targets - --- Note [SwitchTargets]: --- ~~~~~~~~~~~~~~~~~~~~~ --- --- The branches of a switch are stored in a SwitchTargets, which consists of an --- (optional) default jump target, and a map from values to jump targets. --- --- If the default jump target is absent, the behaviour of the switch outside the --- values of the map is undefined. --- --- We use an Integer for the keys the map so that it can be used in switches on --- unsigned as well as signed integers. --- --- The map may be empty (we prune out-of-range branches here, so it could be us --- emptying it). --- --- Before code generation, the table needs to be brought into a form where all --- entries are non-negative, so that it can be compiled into a jump table. --- See switchTargetsToTable. - - --- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch' --- value, and knows whether the value is signed, the possible range, an --- optional default value and a map from values to jump labels. -data SwitchTargets = - SwitchTargets - Bool -- Signed values - (Integer, Integer) -- Range - (Maybe Label) -- Default value - (M.Map Integer Label) -- The branches - deriving (Show, Eq) - --- | The smart constructor mkSwitchTargets normalises the map a bit: --- * No entries outside the range --- * No entries equal to the default --- * No default if all elements have explicit values -mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets -mkSwitchTargets signed range@(lo,hi) mbdef ids - = SwitchTargets signed range mbdef' ids' - where - ids' = dropDefault $ restrict ids - mbdef' | defaultNeeded = mbdef - | otherwise = Nothing - - -- Drop entries outside the range, if there is a range - restrict = restrictMap (lo,hi) - - -- Drop entries that equal the default, if there is a default - dropDefault | Just l <- mbdef = M.filter (/= l) - | otherwise = id - - -- Check if the default is still needed - defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1 - - --- | Changes all labels mentioned in the SwitchTargets value -mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets -mapSwitchTargets f (SwitchTargets signed range mbdef branches) - = SwitchTargets signed range (fmap f mbdef) (fmap f branches) - --- | Returns the list of non-default branches of the SwitchTargets value -switchTargetsCases :: SwitchTargets -> [(Integer, Label)] -switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches - --- | Return the default label of the SwitchTargets value -switchTargetsDefault :: SwitchTargets -> Maybe Label -switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef - --- | Return the range of the SwitchTargets value -switchTargetsRange :: SwitchTargets -> (Integer, Integer) -switchTargetsRange (SwitchTargets _ range _ _) = range - --- | Return whether this is used for a signed value -switchTargetsSigned :: SwitchTargets -> Bool -switchTargetsSigned (SwitchTargets signed _ _ _) = signed - --- | switchTargetsToTable creates a dense jump table, usable for code generation. --- --- Also returns an offset to add to the value; the list is 0-based on the --- result of that addition. --- --- The conversion from Integer to Int is a bit of a wart, as the actual --- scrutinee might be an unsigned word, but it just works, due to wrap-around --- arithmetic (as verified by the CmmSwitchTest test case). -switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label]) -switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches) - = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ]) - where - labelFor i = case M.lookup i branches of Just l -> Just l - Nothing -> mbdef - start | lo >= 0 && lo < minJumpTableOffset = 0 -- See Note [Jump Table Offset] - | otherwise = lo - --- Note [Jump Table Offset] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Usually, the code for a jump table starting at x will first subtract x from --- the value, to avoid a large amount of empty entries. But if x is very small, --- the extra entries are no worse than the subtraction in terms of code size, and --- not having to do the subtraction is quicker. --- --- I.e. instead of --- _u20N: --- leaq -1(%r14),%rax --- jmp *_n20R(,%rax,8) --- _n20R: --- .quad _c20p --- .quad _c20q --- do --- _u20N: --- jmp *_n20Q(,%r14,8) --- --- _n20Q: --- .quad 0 --- .quad _c20p --- .quad _c20q --- .quad _c20r - --- | The list of all labels occuring in the SwitchTargets value. -switchTargetsToList :: SwitchTargets -> [Label] -switchTargetsToList (SwitchTargets _ _ mbdef branches) - = maybeToList mbdef ++ M.elems branches - --- | Groups cases with equal targets, suitable for pretty-printing to a --- c-like switch statement with fall-through semantics. -switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label) -switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef) - where - groups = map (\xs -> (map fst xs, snd (head xs))) $ - groupBy ((==) `on` snd) $ - M.toList branches - --- | Custom equality helper, needed for "CmmCommonBlockElim" -eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool -eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) = - signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2) - where - goMB Nothing Nothing = True - goMB (Just l1) (Just l2) = l1 `eq` l2 - goMB _ _ = False - goList [] [] = True - goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2 - goList _ _ = False - ------------------------------------------------------------------------------ --- Code generation for Switches - - --- | A SwitchPlan abstractly describes how a Switch statement ought to be --- implemented. See Note [createSwitchPlan] -data SwitchPlan - = Unconditionally Label - | IfEqual Integer Label SwitchPlan - | IfLT Bool Integer SwitchPlan SwitchPlan - | JumpTable SwitchTargets - deriving Show --- --- Note [createSwitchPlan] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- --- A SwitchPlan describes how a Switch statement is to be broken down into --- smaller pieces suitable for code generation. --- --- createSwitchPlan creates such a switch plan, in these steps: --- 1. It splits the switch statement at segments of non-default values that --- are too large. See splitAtHoles and Note [Magic Constants in CmmSwitch] --- 2. Too small jump tables should be avoided, so we break up smaller pieces --- in breakTooSmall. --- 3. We fill in the segments between those pieces with a jump to the default --- label (if there is one), returning a SeparatedList in mkFlatSwitchPlan --- 4. We find and replace two less-than branches by a single equal-to-test in --- findSingleValues --- 5. The thus collected pieces are assembled to a balanced binary tree. - -{- - Note [Two alts + default] - ~~~~~~~~~~~~~~~~~~~~~~~~~ - -Discussion and a bit more info at #14644 - -When dealing with a switch of the form: -switch(e) { - case 1: goto l1; - case 3000: goto l2; - default: goto ldef; -} - -If we treat it as a sparse jump table we would generate: - -if (e > 3000) //Check if value is outside of the jump table. - goto ldef; -else { - if (e < 3000) { //Compare to upper value - if(e != 1) //Compare to remaining value - goto ldef; - else - goto l2; - } - else - goto l1; -} - -Instead we special case this to : - -if (e==1) goto l1; -else if (e==3000) goto l2; -else goto l3; - -This means we have: -* Less comparisons for: 1,<3000 -* Unchanged for 3000 -* One more for >3000 - -This improves code in a few ways: -* One comparison less means smaller code which helps with cache. -* It exchanges a taken jump for two jumps no taken in the >range case. - Jumps not taken are cheaper (See Agner guides) making this about as fast. -* For all other cases the first range check is removed making it faster. - -The end result is that the change is not measurably slower for the case ->3000 and faster for the other cases. - -This makes running this kind of match in an inner loop cheaper by 10-20% -depending on the data. -In nofib this improves wheel-sieve1 by 4-9% depending on problem -size. - -We could also add a second conditional jump after the comparison to -keep the range check like this: - cmp 3000, rArgument - jg - je -While this is fairly cheap it made no big difference for the >3000 case -and slowed down all other cases making it not worthwhile. --} - - --- | Does the target support switch out of the box? Then leave this to the --- target! -targetSupportsSwitch :: HscTarget -> Bool -targetSupportsSwitch HscC = True -targetSupportsSwitch HscLlvm = True -targetSupportsSwitch _ = False - --- | This function creates a SwitchPlan from a SwitchTargets value, breaking it --- down into smaller pieces suitable for code generation. -createSwitchPlan :: SwitchTargets -> SwitchPlan --- Lets do the common case of a singleton map quicky and efficiently (#10677) -createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m) - | [(x, l)] <- M.toList m - = IfEqual x l (Unconditionally defLabel) --- And another common case, matching "booleans" -createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m) - | [(x1, l1), (_x2,l2)] <- M.toAscList m - --Checking If |range| = 2 is enough if we have two unique literals - , hi - lo == 1 - = IfEqual x1 l1 (Unconditionally l2) --- See Note [Two alts + default] -createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m) - | [(x1, l1), (x2,l2)] <- M.toAscList m - = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel)) -createSwitchPlan (SwitchTargets signed range mbdef m) = - -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $ - plan - where - pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m - flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces - plan = buildTree signed $ flatPlan - - ---- ---- Step 1: Splitting at large holes ---- -splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a] -splitAtHoles _ m | M.null m = [] -splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles - where - holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m)) - nonHoles = reassocTuples lo holes hi - - (lo,_) = M.findMin m - (hi,_) = M.findMax m - ---- ---- Step 2: Avoid small jump tables ---- --- We do not want jump tables below a certain size. This breaks them up --- (into singleton maps, for now). -breakTooSmall :: M.Map Integer a -> [M.Map Integer a] -breakTooSmall m - | M.size m > minJumpTableSize = [m] - | otherwise = [M.singleton k v | (k,v) <- M.toList m] - ---- ---- Step 3: Fill in the blanks ---- - --- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every --- two entries, dividing the range. --- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if --- the expression is < n, and plan2 otherwise. - -type FlatSwitchPlan = SeparatedList Integer SwitchPlan - -mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan - --- If we have no default (i.e. undefined where there is no entry), we can --- branch at the minimum of each map -mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty -mkFlatSwitchPlan signed Nothing _ (m:ms) - = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ]) - --- If we have a default, we have to interleave segments that jump --- to the default between the maps -mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps) - where - go (lo,hi) [] - | lo > hi = [] - | otherwise = [(lo, Unconditionally l)] - go (lo,hi) (m:ms) - | lo < min - = (lo, Unconditionally l) : go (min,hi) (m:ms) - | lo == min - = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms - | otherwise - = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min) - where - min = fst (M.findMin m) - max = fst (M.findMax m) - - -mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan -mkLeafPlan signed mbdef m - | [(_,l)] <- M.toList m -- singleton map - = Unconditionally l - | otherwise - = JumpTable $ mkSwitchTargets signed (min,max) mbdef m - where - min = fst (M.findMin m) - max = fst (M.findMax m) - ---- ---- Step 4: Reduce the number of branches using == ---- - --- A sequence of three unconditional jumps, with the outer two pointing to the --- same value and the bounds off by exactly one can be improved -findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan -findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs) - | l == l3 && i + 1 == i' - = findSingleValues (IfEqual i l2 (Unconditionally l), xs) -findSingleValues (p, (i,p'):xs) - = (p,i) `consSL` findSingleValues (p', xs) -findSingleValues (p, []) - = (p, []) - ---- ---- Step 5: Actually build the tree ---- - --- Build a balanced tree from a separated list -buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan -buildTree _ (p,[]) = p -buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2) - where - (sl1, m, sl2) = divideSL sl - - - --- --- Utility data type: Non-empty lists with extra markers in between each --- element: --- - -type SeparatedList b a = (a, [(b,a)]) - -consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a -consSL (a, b) (a', xs) = (a, (b,a'):xs) - -divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a) -divideSL (_,[]) = error "divideSL: Singleton SeparatedList" -divideSL (p,xs) = ((p, xs1), m, (p', xs2)) - where - (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs - --- --- Other Utilities --- - -restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b -restrictMap (lo,hi) m = mid - where (_, mid_hi) = M.split (lo-1) m - (mid, _) = M.split (hi+1) mid_hi - --- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)] -reassocTuples :: a -> [(a,a)] -> a -> [(a,a)] -reassocTuples initial [] last - = [(initial,last)] -reassocTuples initial ((a,b):tuples) last - = (initial,a) : reassocTuples b tuples last - --- Note [CmmSwitch vs. CmmImplementSwitchPlans] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- I (Joachim) separated the two somewhat closely related modules --- --- - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy --- for implementing a Cmm switch (createSwitchPlan), and --- - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification, --- --- for these reasons: --- --- * CmmSwitch is very low in the dependency tree, i.e. does not depend on any --- GHC specific modules at all (with the exception of Output and Hoople --- (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very --- high in the dependency tree. --- * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but --- used in CmmNodes. --- * Because CmmSwitch is low in the dependency tree, the separation allows --- for more parallelism when building GHC. --- * The interaction between the modules is very explicit and easy to --- understand, due to the small and simple interface. diff --git a/cmm/CmmType.hs b/cmm/CmmType.hs deleted file mode 100644 --- a/cmm/CmmType.hs +++ /dev/null @@ -1,439 +0,0 @@ -module CmmType - ( CmmType -- Abstract - , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord - , cInt - , cmmBits, cmmFloat - , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood - , isFloatType, isGcPtrType, isBitsType - , isWord32, isWord64, isFloat64, isFloat32 - - , Width(..) - , widthInBits, widthInBytes, widthInLog, widthFromBytes - , wordWidth, halfWordWidth, cIntWidth - , halfWordMask - , narrowU, narrowS - , rEP_CostCentreStack_mem_alloc - , rEP_CostCentreStack_scc_count - , rEP_StgEntCounter_allocs - , rEP_StgEntCounter_allocd - - , ForeignHint(..) - - , Length - , vec, vec2, vec4, vec8, vec16 - , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 - , cmmVec - , vecLength, vecElemType - , isVecType - ) -where - - -import GhcPrelude - -import DynFlags -import FastString -import Outputable - -import Data.Word -import Data.Int - ------------------------------------------------------------------------------ --- CmmType ------------------------------------------------------------------------------ - - -- NOTE: CmmType is an abstract type, not exported from this - -- module so you can easily change its representation - -- - -- However Width is exported in a concrete way, - -- and is used extensively in pattern-matching - -data CmmType -- The important one! - = CmmType CmmCat Width - -data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - | VecCat Length CmmCat -- Vector - deriving( Eq ) - -- See Note [Signed vs unsigned] at the end - -instance Outputable CmmType where - ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) - -instance Outputable CmmCat where - ppr FloatCat = text "F" - ppr GcPtrCat = text "P" - ppr BitsCat = text "I" - ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" - --- Why is CmmType stratified? For native code generation, --- most of the time you just want to know what sort of register --- to put the thing in, and for this you need to know how --- many bits thing has, and whether it goes in a floating-point --- register. By contrast, the distinction between GcPtr and --- GcNonPtr is of interest to only a few parts of the code generator. - --------- Equality on CmmType -------------- --- CmmType is *not* an instance of Eq; sometimes we care about the --- Gc/NonGc distinction, and sometimes we don't --- So we use an explicit function to force you to think about it -cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality -cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 - -cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool - -- This equality is temporary; used in CmmLint - -- but the RTS files are not yet well-typed wrt pointers -cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) - = c1 `weak_eq` c2 && w1==w2 - where - weak_eq :: CmmCat -> CmmCat -> Bool - FloatCat `weak_eq` FloatCat = True - FloatCat `weak_eq` _other = False - _other `weak_eq` FloatCat = False - (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2 - && cat1 `weak_eq` cat2 - (VecCat {}) `weak_eq` _other = False - _other `weak_eq` (VecCat {}) = False - _word1 `weak_eq` _word2 = True -- Ignores GcPtr - ---- Simple operations on CmmType ----- -typeWidth :: CmmType -> Width -typeWidth (CmmType _ w) = w - -cmmBits, cmmFloat :: Width -> CmmType -cmmBits = CmmType BitsCat -cmmFloat = CmmType FloatCat - --------- Common CmmTypes ------------ --- Floats and words of specific widths -b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType -b8 = cmmBits W8 -b16 = cmmBits W16 -b32 = cmmBits W32 -b64 = cmmBits W64 -b128 = cmmBits W128 -b256 = cmmBits W256 -b512 = cmmBits W512 -f32 = cmmFloat W32 -f64 = cmmFloat W64 - --- CmmTypes of native word widths -bWord :: DynFlags -> CmmType -bWord dflags = cmmBits (wordWidth dflags) - -bHalfWord :: DynFlags -> CmmType -bHalfWord dflags = cmmBits (halfWordWidth dflags) - -gcWord :: DynFlags -> CmmType -gcWord dflags = CmmType GcPtrCat (wordWidth dflags) - -cInt :: DynFlags -> CmmType -cInt dflags = cmmBits (cIntWidth dflags) - ------------- Predicates ---------------- -isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool -isFloatType (CmmType FloatCat _) = True -isFloatType _other = False - -isGcPtrType (CmmType GcPtrCat _) = True -isGcPtrType _other = False - -isBitsType (CmmType BitsCat _) = True -isBitsType _ = False - -isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool --- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) --- isFloat32 and 64 are obvious - -isWord64 (CmmType BitsCat W64) = True -isWord64 (CmmType GcPtrCat W64) = True -isWord64 _other = False - -isWord32 (CmmType BitsCat W32) = True -isWord32 (CmmType GcPtrCat W32) = True -isWord32 _other = False - -isFloat32 (CmmType FloatCat W32) = True -isFloat32 _other = False - -isFloat64 (CmmType FloatCat W64) = True -isFloat64 _other = False - ------------------------------------------------------------------------------ --- Width ------------------------------------------------------------------------------ - -data Width = W8 | W16 | W32 | W64 - | W128 - | W256 - | W512 - deriving (Eq, Ord, Show) - -instance Outputable Width where - ppr rep = ptext (mrStr rep) - -mrStr :: Width -> PtrString -mrStr W8 = sLit("W8") -mrStr W16 = sLit("W16") -mrStr W32 = sLit("W32") -mrStr W64 = sLit("W64") -mrStr W128 = sLit("W128") -mrStr W256 = sLit("W256") -mrStr W512 = sLit("W512") - - - --------- Common Widths ------------ -wordWidth :: DynFlags -> Width -wordWidth dflags - | wORD_SIZE dflags == 4 = W32 - | wORD_SIZE dflags == 8 = W64 - | otherwise = panic "MachOp.wordRep: Unknown word size" - -halfWordWidth :: DynFlags -> Width -halfWordWidth dflags - | wORD_SIZE dflags == 4 = W16 - | wORD_SIZE dflags == 8 = W32 - | otherwise = panic "MachOp.halfWordRep: Unknown word size" - -halfWordMask :: DynFlags -> Integer -halfWordMask dflags - | wORD_SIZE dflags == 4 = 0xFFFF - | wORD_SIZE dflags == 8 = 0xFFFFFFFF - | otherwise = panic "MachOp.halfWordMask: Unknown word size" - --- cIntRep is the Width for a C-language 'int' -cIntWidth :: DynFlags -> Width -cIntWidth dflags = case cINT_SIZE dflags of - 4 -> W32 - 8 -> W64 - s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) - -widthInBits :: Width -> Int -widthInBits W8 = 8 -widthInBits W16 = 16 -widthInBits W32 = 32 -widthInBits W64 = 64 -widthInBits W128 = 128 -widthInBits W256 = 256 -widthInBits W512 = 512 - - -widthInBytes :: Width -> Int -widthInBytes W8 = 1 -widthInBytes W16 = 2 -widthInBytes W32 = 4 -widthInBytes W64 = 8 -widthInBytes W128 = 16 -widthInBytes W256 = 32 -widthInBytes W512 = 64 - - -widthFromBytes :: Int -> Width -widthFromBytes 1 = W8 -widthFromBytes 2 = W16 -widthFromBytes 4 = W32 -widthFromBytes 8 = W64 -widthFromBytes 16 = W128 -widthFromBytes 32 = W256 -widthFromBytes 64 = W512 - -widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) - --- log_2 of the width in bytes, useful for generating shifts. -widthInLog :: Width -> Int -widthInLog W8 = 0 -widthInLog W16 = 1 -widthInLog W32 = 2 -widthInLog W64 = 3 -widthInLog W128 = 4 -widthInLog W256 = 5 -widthInLog W512 = 6 - - --- widening / narrowing - -narrowU :: Width -> Integer -> Integer -narrowU W8 x = fromIntegral (fromIntegral x :: Word8) -narrowU W16 x = fromIntegral (fromIntegral x :: Word16) -narrowU W32 x = fromIntegral (fromIntegral x :: Word32) -narrowU W64 x = fromIntegral (fromIntegral x :: Word64) -narrowU _ _ = panic "narrowTo" - -narrowS :: Width -> Integer -> Integer -narrowS W8 x = fromIntegral (fromIntegral x :: Int8) -narrowS W16 x = fromIntegral (fromIntegral x :: Int16) -narrowS W32 x = fromIntegral (fromIntegral x :: Int32) -narrowS W64 x = fromIntegral (fromIntegral x :: Int64) -narrowS _ _ = panic "narrowTo" - ------------------------------------------------------------------------------ --- SIMD ------------------------------------------------------------------------------ - -type Length = Int - -vec :: Length -> CmmType -> CmmType -vec l (CmmType cat w) = CmmType (VecCat l cat) vecw - where - vecw :: Width - vecw = widthFromBytes (l*widthInBytes w) - -vec2, vec4, vec8, vec16 :: CmmType -> CmmType -vec2 = vec 2 -vec4 = vec 4 -vec8 = vec 8 -vec16 = vec 16 - -vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType -vec2f64 = vec 2 f64 -vec2b64 = vec 2 b64 -vec4f32 = vec 4 f32 -vec4b32 = vec 4 b32 -vec8b16 = vec 8 b16 -vec16b8 = vec 16 b8 - -cmmVec :: Int -> CmmType -> CmmType -cmmVec n (CmmType cat w) = - CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w)) - -vecLength :: CmmType -> Length -vecLength (CmmType (VecCat l _) _) = l -vecLength _ = panic "vecLength: not a vector" - -vecElemType :: CmmType -> CmmType -vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw - where - scalw :: Width - scalw = widthFromBytes (widthInBytes w `div` l) -vecElemType _ = panic "vecElemType: not a vector" - -isVecType :: CmmType -> Bool -isVecType (CmmType (VecCat {}) _) = True -isVecType _ = False - -------------------------------------------------------------------------- --- Hints - --- Hints are extra type information we attach to the arguments and --- results of a foreign call, where more type information is sometimes --- needed by the ABI to make the correct kind of call. - -data ForeignHint - = NoHint | AddrHint | SignedHint - deriving( Eq ) - -- Used to give extra per-argument or per-result - -- information needed by foreign calling conventions - -------------------------------------------------------------------------- - --- These don't really belong here, but I don't know where is best to --- put them. - -rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType -rEP_CostCentreStack_mem_alloc dflags - = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) - where pc = platformConstants dflags - -rEP_CostCentreStack_scc_count :: DynFlags -> CmmType -rEP_CostCentreStack_scc_count dflags - = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) - where pc = platformConstants dflags - -rEP_StgEntCounter_allocs :: DynFlags -> CmmType -rEP_StgEntCounter_allocs dflags - = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) - where pc = platformConstants dflags - -rEP_StgEntCounter_allocd :: DynFlags -> CmmType -rEP_StgEntCounter_allocd dflags - = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc)) - where pc = platformConstants dflags - -------------------------------------------------------------------------- -{- Note [Signed vs unsigned] - ~~~~~~~~~~~~~~~~~~~~~~~~~ -Should a CmmType include a signed vs. unsigned distinction? - -This is very much like a "hint" in C-- terminology: it isn't necessary -in order to generate correct code, but it might be useful in that the -compiler can generate better code if it has access to higher-level -hints about data. This is important at call boundaries, because the -definition of a function is not visible at all of its call sites, so -the compiler cannot infer the hints. - -Here in Cmm, we're taking a slightly different approach. We include -the int vs. float hint in the CmmType, because (a) the majority of -platforms have a strong distinction between float and int registers, -and (b) we don't want to do any heavyweight hint-inference in the -native code backend in order to get good code. We're treating the -hint more like a type: our Cmm is always completely consistent with -respect to hints. All coercions between float and int are explicit. - -What about the signed vs. unsigned hint? This information might be -useful if we want to keep sub-word-sized values in word-size -registers, which we must do if we only have word-sized registers. - -On such a system, there are two straightforward conventions for -representing sub-word-sized values: - -(a) Leave the upper bits undefined. Comparison operations must - sign- or zero-extend both operands before comparing them, - depending on whether the comparison is signed or unsigned. - -(b) Always keep the values sign- or zero-extended as appropriate. - Arithmetic operations must narrow the result to the appropriate - size. - -A clever compiler might not use either (a) or (b) exclusively, instead -it would attempt to minimize the coercions by analysis: the same kind -of analysis that propagates hints around. In Cmm we don't want to -have to do this, so we plump for having richer types and keeping the -type information consistent. - -If signed/unsigned hints are missing from CmmType, then the only -choice we have is (a), because we don't know whether the result of an -operation should be sign- or zero-extended. - -Many architectures have extending load operations, which work well -with (b). To make use of them with (a), you need to know whether the -value is going to be sign- or zero-extended by an enclosing comparison -(for example), which involves knowing above the context. This is -doable but more complex. - -Further complicating the issue is foreign calls: a foreign calling -convention can specify that signed 8-bit quantities are passed as -sign-extended 32 bit quantities, for example (this is the case on the -PowerPC). So we *do* need sign information on foreign call arguments. - -Pros for adding signed vs. unsigned to CmmType: - - - It would let us use convention (b) above, and get easier - code generation for extending loads. - - - Less information required on foreign calls. - - - MachOp type would be simpler - -Cons: - - - More complexity - - - What is the CmmType for a VanillaReg? Currently it is - always wordRep, but now we have to decide whether it is - signed or unsigned. The same VanillaReg can thus have - different CmmType in different parts of the program. - - - Extra coercions cluttering up expressions. - -Currently for GHC, the foreign call point is moot, because we do our -own promotion of sub-word-sized values to word-sized values. The Int8 -type is represented by an Int# which is kept sign-extended at all times -(this is slightly naughty, because we're making assumptions about the -C calling convention rather early on in the compiler). However, given -this, the cons outweigh the pros. - --} - diff --git a/cmm/CmmUtils.hs b/cmm/CmmUtils.hs deleted file mode 100644 --- a/cmm/CmmUtils.hs +++ /dev/null @@ -1,601 +0,0 @@ -{-# LANGUAGE GADTs, RankNTypes #-} -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- --- Cmm utilities. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module CmmUtils( - -- CmmType - primRepCmmType, slotCmmType, - typeCmmType, typeForeignHint, primRepForeignHint, - - -- CmmLit - zeroCLit, mkIntCLit, - mkWordCLit, packHalfWordsCLit, - mkByteStringCLit, - mkDataLits, mkRODataLits, - mkStgWordCLit, - - -- CmmExpr - mkIntExpr, zeroExpr, - mkLblExpr, - cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, - cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, - cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, - cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, - cmmNegate, - cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, - cmmSLtWord, - cmmNeWord, cmmEqWord, - cmmOrWord, cmmAndWord, - cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord, - cmmToWord, - - cmmMkAssign, - - isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr, - - baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, - currentTSOExpr, currentNurseryExpr, cccsExpr, - - -- Statics - blankWord, - - -- Tagging - cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, - cmmConstrTag1, - - -- Overlap and usage - regsOverlap, regUsedIn, - - -- Liveness and bitmaps - mkLiveness, - - -- * Operations that probably don't belong here - modifyGraph, - - ofBlockMap, toBlockMap, - ofBlockList, toBlockList, bodyToBlockList, - toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, - foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1, - - -- * Ticks - blockTicks - ) where - -import GhcPrelude - -import TyCon ( PrimRep(..), PrimElemRep(..) ) -import RepType ( UnaryType, SlotTy (..), typePrimRep1 ) - -import SMRep -import Cmm -import BlockId -import CLabel -import Outputable -import DynFlags -import Unique -import GHC.Platform.Regs - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Bits -import Hoopl.Graph -import Hoopl.Label -import Hoopl.Block -import Hoopl.Collections - ---------------------------------------------------- --- --- CmmTypes --- ---------------------------------------------------- - -primRepCmmType :: DynFlags -> PrimRep -> CmmType -primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep" -primRepCmmType dflags LiftedRep = gcWord dflags -primRepCmmType dflags UnliftedRep = gcWord dflags -primRepCmmType dflags IntRep = bWord dflags -primRepCmmType dflags WordRep = bWord dflags -primRepCmmType _ Int8Rep = b8 -primRepCmmType _ Word8Rep = b8 -primRepCmmType _ Int16Rep = b16 -primRepCmmType _ Word16Rep = b16 -primRepCmmType _ Int32Rep = b32 -primRepCmmType _ Word32Rep = b32 -primRepCmmType _ Int64Rep = b64 -primRepCmmType _ Word64Rep = b64 -primRepCmmType dflags AddrRep = bWord dflags -primRepCmmType _ FloatRep = f32 -primRepCmmType _ DoubleRep = f64 -primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep) - -slotCmmType :: DynFlags -> SlotTy -> CmmType -slotCmmType dflags PtrLiftedSlot = gcWord dflags -slotCmmType dflags PtrUnliftedSlot = gcWord dflags -slotCmmType dflags WordSlot = bWord dflags -slotCmmType _ Word64Slot = b64 -slotCmmType _ FloatSlot = f32 -slotCmmType _ DoubleSlot = f64 - -primElemRepCmmType :: PrimElemRep -> CmmType -primElemRepCmmType Int8ElemRep = b8 -primElemRepCmmType Int16ElemRep = b16 -primElemRepCmmType Int32ElemRep = b32 -primElemRepCmmType Int64ElemRep = b64 -primElemRepCmmType Word8ElemRep = b8 -primElemRepCmmType Word16ElemRep = b16 -primElemRepCmmType Word32ElemRep = b32 -primElemRepCmmType Word64ElemRep = b64 -primElemRepCmmType FloatElemRep = f32 -primElemRepCmmType DoubleElemRep = f64 - -typeCmmType :: DynFlags -> UnaryType -> CmmType -typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty) - -primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" -primRepForeignHint LiftedRep = AddrHint -primRepForeignHint UnliftedRep = AddrHint -primRepForeignHint IntRep = SignedHint -primRepForeignHint Int8Rep = SignedHint -primRepForeignHint Int16Rep = SignedHint -primRepForeignHint Int32Rep = SignedHint -primRepForeignHint Int64Rep = SignedHint -primRepForeignHint WordRep = NoHint -primRepForeignHint Word8Rep = NoHint -primRepForeignHint Word16Rep = NoHint -primRepForeignHint Word32Rep = NoHint -primRepForeignHint Word64Rep = NoHint -primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg -primRepForeignHint FloatRep = NoHint -primRepForeignHint DoubleRep = NoHint -primRepForeignHint (VecRep {}) = NoHint - -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 - ---------------------------------------------------- --- --- CmmLit --- ---------------------------------------------------- - --- XXX: should really be Integer, since Int doesn't necessarily cover --- the full range of target Ints. -mkIntCLit :: DynFlags -> Int -> CmmLit -mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags) - -mkIntExpr :: DynFlags -> Int -> CmmExpr -mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i - -zeroCLit :: DynFlags -> CmmLit -zeroCLit dflags = CmmInt 0 (wordWidth dflags) - -zeroExpr :: DynFlags -> CmmExpr -zeroExpr dflags = CmmLit (zeroCLit dflags) - -mkWordCLit :: DynFlags -> Integer -> CmmLit -mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) - -mkByteStringCLit - :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) --- We have to make a top-level decl for the string, --- and return a literal pointing to it -mkByteStringCLit lbl bytes - = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes]) - where - -- This can not happen for String literals (as there \NUL is replaced by - -- C0 80). However, it can happen with Addr# literals. - sec = if 0 `BS.elem` bytes then ReadOnlyData else CString - -mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt --- Build a data-segment data block -mkDataLits section lbl lits - = CmmData section (Statics lbl $ map CmmStaticLit lits) - -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt --- Build a read-only data block -mkRODataLits lbl lits - = mkDataLits section lbl lits - where - section | any needsRelocation lits = Section RelocatableReadOnlyData lbl - | otherwise = Section ReadOnlyData lbl - needsRelocation (CmmLabel _) = True - needsRelocation (CmmLabelOff _ _) = True - needsRelocation _ = False - -mkStgWordCLit :: DynFlags -> StgWord -> CmmLit -mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags) - -packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit --- Make a single word literal in which the lower_half_word is --- at the lower address, and the upper_half_word is at the --- higher address --- ToDo: consider using half-word lits instead --- but be careful: that's vulnerable when reversed -packHalfWordsCLit dflags lower_half_word upper_half_word - = if wORDS_BIGENDIAN dflags - then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u) - else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags)) - where l = fromStgHalfWord lower_half_word - u = fromStgHalfWord upper_half_word - ---------------------------------------------------- --- --- CmmExpr --- ---------------------------------------------------- - -mkLblExpr :: CLabel -> CmmExpr -mkLblExpr lbl = CmmLit (CmmLabel lbl) - -cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr --- assumes base and offset have the same CmmType -cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n) -cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off] - -cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr -cmmOffset _ e 0 = e -cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off -cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) -cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) -cmmOffset _ (CmmStackSlot area off) byte_off - = CmmStackSlot area (off - byte_off) - -- note stack area offsets increase towards lower addresses -cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 - = CmmMachOp (MO_Add rep) - [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] -cmmOffset dflags expr byte_off - = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)] - where - width = cmmExprWidth dflags expr - --- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. -cmmRegOff :: CmmReg -> Int -> CmmExpr -cmmRegOff reg 0 = CmmReg reg -cmmRegOff reg byte_off = CmmRegOff reg byte_off - -cmmOffsetLit :: CmmLit -> Int -> CmmLit -cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off -cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) -cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off - = CmmLabelDiffOff l1 l2 (m+byte_off) w -cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep -cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) - -cmmLabelOff :: CLabel -> Int -> CmmLit --- Smart constructor for CmmLabelOff -cmmLabelOff lbl 0 = CmmLabel lbl -cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off - --- | Useful for creating an index into an array, with a statically known offset. --- The type is the element type; used for making the multiplier -cmmIndex :: DynFlags - -> Width -- Width w - -> CmmExpr -- Address of vector of items of width w - -> Int -- Which element of the vector (0 based) - -> CmmExpr -- Address of i'th element -cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width) - --- | Useful for creating an index into an array, with an unknown offset. -cmmIndexExpr :: DynFlags - -> Width -- Width w - -> CmmExpr -- Address of vector of items of width w - -> CmmExpr -- Which element of the vector (0 based) - -> CmmExpr -- Address of i'th element -cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n) -cmmIndexExpr dflags width base idx = - cmmOffsetExpr dflags base byte_off - where - idx_w = cmmExprWidth dflags idx - byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)] - -cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr -cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty - --- The "B" variants take byte offsets -cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr -cmmRegOffB = cmmRegOff - -cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr -cmmOffsetB = cmmOffset - -cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -cmmOffsetExprB = cmmOffsetExpr - -cmmLabelOffB :: CLabel -> ByteOff -> CmmLit -cmmLabelOffB = cmmLabelOff - -cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit -cmmOffsetLitB = cmmOffsetLit - ------------------------ --- The "W" variants take word offsets - -cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr --- The second arg is a *word* offset; need to change it to bytes -cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n) -cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off - -cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr -cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n) - -cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr -cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off) - -cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit -cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off) - -cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit -cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off) - -cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr -cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty - ------------------------ -cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, - cmmSLtWord, - cmmNeWord, cmmEqWord, - cmmOrWord, cmmAndWord, - cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord - :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2] -cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2] -cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2] -cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2] -cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2] -cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2] -cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2] -cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2] -cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2] -cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2] -cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2] -cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2] -cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2] - -cmmNegate :: DynFlags -> CmmExpr -> CmmExpr -cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) -cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e] - -blankWord :: DynFlags -> CmmStatic -blankWord dflags = CmmUninitialised (wORD_SIZE dflags) - -cmmToWord :: DynFlags -> CmmExpr -> CmmExpr -cmmToWord dflags e - | w == word = e - | otherwise = CmmMachOp (MO_UU_Conv w word) [e] - where - w = cmmExprWidth dflags e - word = wordWidth dflags - -cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr) -cmmMkAssign dflags expr uq = - let !ty = cmmExprType dflags expr - reg = (CmmLocal (LocalReg uq ty)) - in (CmmAssign reg expr, CmmReg reg) - - ---------------------------------------------------- --- --- CmmExpr predicates --- ---------------------------------------------------- - -isTrivialCmmExpr :: CmmExpr -> Bool -isTrivialCmmExpr (CmmLoad _ _) = False -isTrivialCmmExpr (CmmMachOp _ _) = False -isTrivialCmmExpr (CmmLit _) = True -isTrivialCmmExpr (CmmReg _) = True -isTrivialCmmExpr (CmmRegOff _ _) = True -isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" - -hasNoGlobalRegs :: CmmExpr -> Bool -hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e -hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es -hasNoGlobalRegs (CmmLit _) = True -hasNoGlobalRegs (CmmReg (CmmLocal _)) = True -hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True -hasNoGlobalRegs _ = False - -isLit :: CmmExpr -> Bool -isLit (CmmLit _) = True -isLit _ = False - -isComparisonExpr :: CmmExpr -> Bool -isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op -isComparisonExpr _ = False - ---------------------------------------------------- --- --- Tagging --- ---------------------------------------------------- - --- Tag bits mask -cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr -cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags) -cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags)) - --- Used to untag a possibly tagged pointer --- A static label need not be untagged -cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr -cmmUntag _ e@(CmmLit (CmmLabel _)) = e --- Default case -cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags) - --- Test if a closure pointer is untagged -cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags) - --- Get constructor tag, but one based. -cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags) - - ------------------------------------------------------------------------------ --- Overlap and usage - --- | Returns True if the two STG registers overlap on the specified --- platform, in the sense that writing to one will clobber the --- other. This includes the case that the two registers are the same --- STG register. See Note [Overlapping global registers] for details. -regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool -regsOverlap dflags (CmmGlobal g) (CmmGlobal g') - | Just real <- globalRegMaybe (targetPlatform dflags) g, - Just real' <- globalRegMaybe (targetPlatform dflags) g', - real == real' - = True -regsOverlap _ reg reg' = reg == reg' - --- | Returns True if the STG register is used by the expression, in --- the sense that a store to the register might affect the value of --- the expression. --- --- We must check for overlapping registers and not just equal --- registers here, otherwise CmmSink may incorrectly reorder --- assignments that conflict due to overlap. See #10521 and Note --- [Overlapping global registers]. -regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool -regUsedIn dflags = regUsedIn_ where - _ `regUsedIn_` CmmLit _ = False - reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e - reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg' - reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg' - reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es - _ `regUsedIn_` CmmStackSlot _ _ = False - --------------------------------------------- --- --- mkLiveness --- ---------------------------------------------- - -mkLiveness :: DynFlags -> [LocalReg] -> Liveness -mkLiveness _ [] = [] -mkLiveness dflags (reg:regs) - = bits ++ mkLiveness dflags regs - where - sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1) - `quot` wORD_SIZE dflags - -- number of words, rounded up - bits = replicate sizeW is_non_ptr -- True <=> Non Ptr - - is_non_ptr = not $ isGcPtrType (localRegType reg) - - --- ============================================== - --- ============================================== - --- ============================================== - - ---------------------------------------------------- --- --- Manipulating CmmGraphs --- ---------------------------------------------------- - -modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' -modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} - -toBlockMap :: CmmGraph -> LabelMap CmmBlock -toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body - -ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph -ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} - -toBlockList :: CmmGraph -> [CmmBlock] -toBlockList g = mapElems $ toBlockMap g - --- | like 'toBlockList', but the entry block always comes first -toBlockListEntryFirst :: CmmGraph -> [CmmBlock] -toBlockListEntryFirst g - | mapNull m = [] - | otherwise = entry_block : others - where - m = toBlockMap g - entry_id = g_entry g - Just entry_block = mapLookup entry_id m - others = filter ((/= entry_id) . entryLabel) (mapElems m) - --- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks --- so that the false case of a conditional jumps to the next block in the output --- list of blocks. This matches the way OldCmm blocks were output since in --- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches --- have both true and false successors. Block ordering can make a big difference --- in performance in the LLVM backend. Note that we rely crucially on the order --- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode --- defined in cmm/CmmNode.hs. -GBM -toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] -toBlockListEntryFirstFalseFallthrough g - | mapNull m = [] - | otherwise = dfs setEmpty [entry_block] - where - m = toBlockMap g - entry_id = g_entry g - Just entry_block = mapLookup entry_id m - - dfs :: LabelSet -> [CmmBlock] -> [CmmBlock] - dfs _ [] = [] - dfs visited (block:bs) - | id `setMember` visited = dfs visited bs - | otherwise = block : dfs (setInsert id visited) bs' - where id = entryLabel block - bs' = foldr add_id bs (successors block) - add_id id bs = case mapLookup id m of - Just b -> b : bs - Nothing -> bs - -ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph -ofBlockList entry blocks = CmmGraph { g_entry = entry - , g_graph = GMany NothingO body NothingO } - where body = foldr addBlock emptyBody blocks - -bodyToBlockList :: Body CmmNode -> [CmmBlock] -bodyToBlockList body = mapElems body - -mapGraphNodes :: ( CmmNode C O -> CmmNode C O - , CmmNode O O -> CmmNode O O - , CmmNode O C -> CmmNode O C) - -> CmmGraph -> CmmGraph -mapGraphNodes funs@(mf,_,_) g = - ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $ - mapMap (mapBlock3' funs) $ toBlockMap g - -mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph -mapGraphNodes1 f = modifyGraph (mapGraph f) - - -foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a -foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g - -revPostorder :: CmmGraph -> [CmmBlock] -revPostorder g = {-# SCC "revPostorder" #-} - revPostorderFrom (toBlockMap g) (g_entry g) - -------------------------------------------------- --- Tick utilities - --- | Extract all tick annotations from the given block -blockTicks :: Block CmmNode C C -> [CmmTickish] -blockTicks b = reverse $ foldBlockNodesF goStmt b [] - where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish] - goStmt (CmmTick t) ts = t:ts - goStmt _other ts = ts - - --- ----------------------------------------------------------------------------- --- Access to common global registers - -baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, - spLimExpr, hpLimExpr, cccsExpr :: CmmExpr -baseExpr = CmmReg baseReg -spExpr = CmmReg spReg -spLimExpr = CmmReg spLimReg -hpExpr = CmmReg hpReg -hpLimExpr = CmmReg hpLimReg -currentTSOExpr = CmmReg currentTSOReg -currentNurseryExpr = CmmReg currentNurseryReg -cccsExpr = CmmReg cccsReg diff --git a/cmm/Debug.hs b/cmm/Debug.hs deleted file mode 100644 --- a/cmm/Debug.hs +++ /dev/null @@ -1,546 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} - ------------------------------------------------------------------------------ --- --- Debugging data --- --- Association of debug data on the Cmm level, with methods to encode it in --- event log format for later inclusion in profiling event logs. --- ------------------------------------------------------------------------------ - -module Debug ( - - DebugBlock(..), - cmmDebugGen, - cmmDebugLabels, - cmmDebugLink, - debugToMap, - - -- * Unwinding information - UnwindTable, UnwindPoint(..), - UnwindExpr(..), toUnwindExpr - ) where - -import GhcPrelude - -import BlockId -import CLabel -import Cmm -import CmmUtils -import CoreSyn -import FastString ( nilFS, mkFastString ) -import Module -import Outputable -import PprCmmExpr ( pprExpr ) -import SrcLoc -import Util ( seqList ) - -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Graph -import Hoopl.Label - -import Data.Maybe -import Data.List ( minimumBy, nubBy ) -import Data.Ord ( comparing ) -import qualified Data.Map as Map -import Data.Either ( partitionEithers ) - --- | Debug information about a block of code. Ticks scope over nested --- blocks. -data DebugBlock = - DebugBlock - { dblProcedure :: !Label -- ^ Entry label of containing proc - , dblLabel :: !Label -- ^ Hoopl label - , dblCLabel :: !CLabel -- ^ Output label - , dblHasInfoTbl :: !Bool -- ^ Has an info table? - , dblParent :: !(Maybe DebugBlock) - -- ^ The parent of this proc. See Note [Splitting DebugBlocks] - , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block - , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block - , dblPosition :: !(Maybe Int) -- ^ Output position relative to - -- other blocks. @Nothing@ means - -- the block was optimized out - , dblUnwind :: [UnwindPoint] - , dblBlocks :: ![DebugBlock] -- ^ Nested blocks - } - -instance Outputable DebugBlock where - ppr blk = (if | dblProcedure blk == dblLabel blk - -> text "proc" - | dblHasInfoTbl blk - -> text "pp-blk" - | otherwise - -> text "blk") <+> - ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+> - (maybe empty ppr (dblSourceTick blk)) <+> - (maybe (text "removed") ((text "pos " <>) . ppr) - (dblPosition blk)) <+> - (ppr (dblUnwind blk)) $+$ - (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk))) - --- | Intermediate data structure holding debug-relevant context information --- about a block. -type BlockContext = (CmmBlock, RawCmmDecl) - --- | Extract debug data from a group of procedures. We will prefer --- source notes that come from the given module (presumably the module --- that we are currently compiling). -cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock] -cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes - where - blockCtxs :: Map.Map CmmTickScope [BlockContext] - blockCtxs = blockContexts decls - - -- Analyse tick scope structure: Each one is either a top-level - -- tick scope, or the child of another. - (topScopes, childScopes) - = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs - findP tsc GlobalScope = Left tsc -- top scope - findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc) - | otherwise = findP tsc scp' - where -- Note that we only following the left parent of - -- combined scopes. This loses us ticks, which we will - -- recover by copying ticks below. - scp' | SubScope _ scp' <- scp = scp' - | CombinedScope scp' _ <- scp = scp' - | otherwise = panic "findP impossible" - - scopeMap = foldr (uncurry insertMulti) Map.empty childScopes - - -- This allows us to recover ticks that we lost by flattening - -- the graph. Basically, if the parent is A but the child is - -- CBA, we know that there is no BA, because it would have taken - -- priority - but there might be a B scope, with ticks that - -- would not be associated with our child anymore. Note however - -- that there might be other childs (DB), which we have to - -- filter out. - -- - -- We expect this to be called rarely, which is why we are not - -- trying too hard to be efficient here. In many cases we won't - -- have to construct blockCtxsU in the first place. - ticksToCopy :: CmmTickScope -> [CmmTickish] - ticksToCopy (CombinedScope scp s) = go s - where go s | scp `isTickSubScope` s = [] -- done - | SubScope _ s' <- s = ticks ++ go s' - | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2 - | otherwise = panic "ticksToCopy impossible" - where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs - ticksToCopy _ = [] - bCtxsTicks = concatMap (blockTicks . fst) - - -- Finding the "best" source tick is somewhat arbitrary -- we - -- select the first source span, while preferring source ticks - -- from the same source file. Furthermore, dumps take priority - -- (if we generated one, we probably want debug information to - -- refer to it). - bestSrcTick = minimumBy (comparing rangeRating) - rangeRating (SourceNote span _) - | srcSpanFile span == thisFile = 1 - | otherwise = 2 :: Int - rangeRating note = pprPanic "rangeRating" (ppr note) - thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc - - -- Returns block tree for this scope as well as all nested - -- scopes. Note that if there are multiple blocks in the (exact) - -- same scope we elect one as the "branch" node and add the rest - -- as children. - blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock - blocksForScope cstick scope = mkBlock True (head bctxs) - where bctxs = fromJust $ Map.lookup scope blockCtxs - nested = fromMaybe [] $ Map.lookup scope scopeMap - childs = map (mkBlock False) (tail bctxs) ++ - map (blocksForScope stick) nested - - mkBlock :: Bool -> BlockContext -> DebugBlock - mkBlock top (block, prc) - = DebugBlock { dblProcedure = g_entry graph - , dblLabel = label - , dblCLabel = case info of - Just (Statics infoLbl _) -> infoLbl - Nothing - | g_entry graph == label -> entryLbl - | otherwise -> blockLbl label - , dblHasInfoTbl = isJust info - , dblParent = Nothing - , dblTicks = ticks - , dblPosition = Nothing -- see cmmDebugLink - , dblSourceTick = stick - , dblBlocks = blocks - , dblUnwind = [] - } - where (CmmProc infos entryLbl _ graph) = prc - label = entryLabel block - info = mapLookup label infos - blocks | top = seqList childs childs - | otherwise = [] - - -- A source tick scopes over all nested blocks. However - -- their source ticks might take priority. - isSourceTick SourceNote {} = True - isSourceTick _ = False - -- Collect ticks from all blocks inside the tick scope. - -- We attempt to filter out duplicates while we're at it. - ticks = nubBy (flip tickishContains) $ - bCtxsTicks bctxs ++ ticksToCopy scope - stick = case filter isSourceTick ticks of - [] -> cstick - sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick) - --- | Build a map of blocks sorted by their tick scopes --- --- This involves a pre-order traversal, as we want blocks in rough --- control flow order (so ticks have a chance to be sorted in the --- right order). -blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext] -blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls - where walkProc :: RawCmmDecl - -> Map.Map CmmTickScope [BlockContext] - -> Map.Map CmmTickScope [BlockContext] - walkProc CmmData{} m = m - walkProc prc@(CmmProc _ _ _ graph) m - | mapNull blocks = m - | otherwise = snd $ walkBlock prc entry (emptyLbls, m) - where blocks = toBlockMap graph - entry = [mapFind (g_entry graph) blocks] - emptyLbls = setEmpty :: LabelSet - - walkBlock :: RawCmmDecl -> [Block CmmNode C C] - -> (LabelSet, Map.Map CmmTickScope [BlockContext]) - -> (LabelSet, Map.Map CmmTickScope [BlockContext]) - walkBlock _ [] c = c - walkBlock prc (block:blocks) (visited, m) - | lbl `setMember` visited - = walkBlock prc blocks (visited, m) - | otherwise - = walkBlock prc blocks $ - walkBlock prc succs - (lbl `setInsert` visited, - insertMulti scope (block, prc) m) - where CmmEntry lbl scope = firstNode block - (CmmProc _ _ _ graph) = prc - succs = map (flip mapFind (toBlockMap graph)) - (successors (lastNode block)) - mapFind = mapFindWithDefault (error "contextTree: block not found!") - -insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] -insertMulti k v = Map.insertWith (const (v:)) k [v] - -cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] -cmmDebugLabels isMeta nats = seqList lbls lbls - where -- Find order in which procedures will be generated by the - -- back-end (that actually matters for DWARF generation). - -- - -- Note that we might encounter blocks that are missing or only - -- consist of meta instructions -- we will declare them missing, - -- which will skip debug data generation without messing up the - -- block hierarchy. - lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats - getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs - getBlocks _other = [] - allMeta (BasicBlock _ instrs) = all isMeta instrs - --- | Sets position and unwind table fields in the debug block tree according to --- native generated code. -cmmDebugLink :: [Label] -> LabelMap [UnwindPoint] - -> [DebugBlock] -> [DebugBlock] -cmmDebugLink labels unwindPts blocks = map link blocks - where blockPos :: LabelMap Int - blockPos = mapFromList $ flip zip [0..] labels - link block = block { dblPosition = mapLookup (dblLabel block) blockPos - , dblBlocks = map link (dblBlocks block) - , dblUnwind = fromMaybe mempty - $ mapLookup (dblLabel block) unwindPts - } - --- | Converts debug blocks into a label map for easier lookups -debugToMap :: [DebugBlock] -> LabelMap DebugBlock -debugToMap = mapUnions . map go - where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b) - -{- -Note [What is this unwinding business?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Unwinding tables are a variety of debugging information used by debugging tools -to reconstruct the execution history of a program at runtime. These tables -consist of sets of "instructions", one set for every instruction in the program, -which describe how to reconstruct the state of the machine at the point where -the current procedure was called. For instance, consider the following annotated -pseudo-code, - - a_fun: - add rsp, 8 -- unwind: rsp = rsp - 8 - mov rax, 1 -- unwind: rax = unknown - call another_block - sub rsp, 8 -- unwind: rsp = rsp - -We see that attached to each instruction there is an "unwind" annotation, which -provides a relationship between each updated register and its value at the -time of entry to a_fun. This is the sort of information that allows gdb to give -you a stack backtrace given the execution state of your program. This -unwinding information is captured in various ways by various debug information -formats; in the case of DWARF (the only format supported by GHC) it is known as -Call Frame Information (CFI) and can be found in the .debug.frames section of -your object files. - -Currently we only bother to produce unwinding information for registers which -are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp -(which is the STG stack pointer) and $rsp (the C stack pointer). - -Let's consider how GHC would annotate a C-- program with unwinding information -with a typical C-- procedure as would come from the STG-to-Cmm code generator, - - entry() - { c2fe: - v :: P64 = R2; - if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; - c2ff: - R2 = v :: P64; - R1 = test_closure; - call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; - c2fg: - I64[Sp - 8] = c2dD; - R1 = v :: P64; - Sp = Sp - 8; // Sp updated here - if (R1 & 7 != 0) goto c2dD; else goto c2dE; - c2dE: - call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; - c2dD: - w :: P64 = R1; - Hp = Hp + 48; - if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; - ... - }, - -Let's consider how this procedure will be decorated with unwind information -(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the -value of Sp is no different from what it was at its call site. Therefore we will -add an `unwind` statement saying this at the beginning of its unwind-annotated -code, - - entry() - { c2fe: - unwind Sp = Just Sp + 0; - v :: P64 = R2; - if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg; - -After c2fe we may pass to either c2ff or c2fg; let's first consider the -former. In this case there is nothing in particular that we need to do other -than reiterate what we already know about Sp, - - c2ff: - unwind Sp = Just Sp + 0; - R2 = v :: P64; - R1 = test_closure; - call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; - -In contrast, c2fg updates Sp midway through its body. To ensure that unwinding -can happen correctly after this point we must include an unwind statement there, -in addition to the usual beginning-of-block statement, - - c2fg: - unwind Sp = Just Sp + 0; - I64[Sp - 8] = c2dD; - R1 = v :: P64; - Sp = Sp - 8; - unwind Sp = Just Sp + 8; - if (R1 & 7 != 0) goto c2dD; else goto c2dE; - -The remaining blocks are simple, - - c2dE: - unwind Sp = Just Sp + 8; - call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8; - c2dD: - unwind Sp = Just Sp + 8; - w :: P64 = R1; - Hp = Hp + 48; - if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi; - ... - }, - - -The flow of unwinding information through the compiler is a bit convoluted: - - * C-- begins life in StgToCmm without any unwind information. This is because we - haven't actually done any register assignment or stack layout yet, so there - is no need for unwind information. - - * CmmLayoutStack figures out how to layout each procedure's stack, and produces - appropriate unwinding nodes for each adjustment of the STG Sp register. - - * The unwind nodes are carried through the sinking pass. Currently this is - guaranteed not to invalidate unwind information since it won't touch stores - to Sp, but this will need revisiting if CmmSink gets smarter in the future. - - * Eventually we make it to the native code generator backend which can then - preserve the unwind nodes in its machine-specific instructions. In so doing - the backend can also modify or add unwinding information; this is necessary, - for instance, in the case of x86-64, where adjustment of $rsp may be - necessary during calls to native foreign code due to the native calling - convention. - - * The NCG then retrieves the final unwinding table for each block from the - backend with extractUnwindPoints. - - * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen - - * These DebugBlocks are then converted to, e.g., DWARF unwinding tables - (by the Dwarf module) and emitted in the final object. - -See also: - Note [Unwinding information in the NCG] in AsmCodeGen, - Note [Unwind pseudo-instruction in Cmm], - Note [Debugging DWARF unwinding info]. - - -Note [Debugging DWARF unwinding info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For debugging generated unwinding info I've found it most useful to dump the -disassembled binary with objdump -D and dump the debug info with -readelf --debug-dump=frames-interp. - -You should get something like this: - - 0000000000000010 : - 10: 48 83 c5 18 add $0x18,%rbp - 14: ff 65 00 jmpq *0x0(%rbp) - -and: - - Contents of the .debug_frame section: - - 00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16 - LOC CFA rbp rsp ra - 0000000000000000 rbp+0 v+0 s c+0 - - 00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017 - LOC CFA rbp rsp ra - 000000000000000f rbp+0 v+0 s c+0 - 000000000000000f rbp+24 v+0 s c+0 - -To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in -Appendix 5 (page 101 of the pdf) and more details in the relevant section. - -The key thing to keep in mind is that the value at LOC is the value from -*before* the instruction at LOC executes. In other words it answers the -question: if my $rip is at LOC, how do I get the relevant values given the -values obtained through unwinding so far. - -If the readelf --debug-dump=frames-interp output looks wrong, it may also be -useful to look at readelf --debug-dump=frames, which is closer to the -information that GHC generated. - -It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm --ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm] -explains how to interpret it. - -Inside gdb there are a couple useful commands for inspecting frames. -For example: - - gdb> info frame - -It shows the values of registers obtained through unwinding. - -Another useful thing to try when debugging the DWARF unwinding is to enable -extra debugging output in GDB: - - gdb> set debug frame 1 - -This makes GDB produce a trace of its internal workings. Having gone this far, -it's just a tiny step to run GDB in GDB. Make sure you install debugging -symbols for gdb if you obtain it through a package manager. - -Keep in mind that the current release of GDB has an instruction pointer handling -heuristic that works well for C-like languages, but doesn't always work for -Haskell. See Note [Info Offset] in Dwarf.Types for more details. - -Note [Unwind pseudo-instruction in Cmm] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't -generate any assembly, but controls what DWARF unwinding information gets -generated. - -It's important to understand what ranges of code the unwind pseudo-instruction -refers to. -For a sequence of CmmNodes like: - - A // starts at addr X and ends at addr Y-1 - unwind Sp = Just Sp + 16; - B // starts at addr Y and ends at addr Z - -the unwind statement reflects the state after A has executed, but before B -has executed. If you consult the Note [Debugging DWARF unwinding info], the -LOC this information will end up in is Y. --} - --- | A label associated with an 'UnwindTable' -data UnwindPoint = UnwindPoint !CLabel !UnwindTable - -instance Outputable UnwindPoint where - ppr (UnwindPoint lbl uws) = - braces $ ppr lbl<>colon - <+> hsep (punctuate comma $ map pprUw $ Map.toList uws) - where - pprUw (g, expr) = ppr g <> char '=' <> ppr expr - --- | Maps registers to expressions that yield their "old" values --- further up the stack. Most interesting for the stack pointer @Sp@, --- but might be useful to document saved registers, too. Note that a --- register's value will be 'Nothing' when the register's previous --- value cannot be reconstructed. -type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr) - --- | Expressions, used for unwind information -data UnwindExpr = UwConst !Int -- ^ literal value - | UwReg !GlobalReg !Int -- ^ register plus offset - | UwDeref UnwindExpr -- ^ pointer dereferencing - | UwLabel CLabel - | UwPlus UnwindExpr UnwindExpr - | UwMinus UnwindExpr UnwindExpr - | UwTimes UnwindExpr UnwindExpr - deriving (Eq) - -instance Outputable UnwindExpr where - pprPrec _ (UwConst i) = ppr i - pprPrec _ (UwReg g 0) = ppr g - pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x)) - pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e - pprPrec _ (UwLabel l) = pprPrec 3 l - pprPrec p (UwPlus e0 e1) | p <= 0 - = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1 - pprPrec p (UwMinus e0 e1) | p <= 0 - = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1 - pprPrec p (UwTimes e0 e1) | p <= 1 - = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1 - pprPrec _ other = parens (pprPrec 0 other) - --- | Conversion of Cmm expressions to unwind expressions. We check for --- unsupported operator usages and simplify the expression as far as --- possible. -toUnwindExpr :: CmmExpr -> UnwindExpr -toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i) -toUnwindExpr (CmmLit (CmmLabel l)) = UwLabel l -toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i -toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0 -toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e) -toUnwindExpr e@(CmmMachOp op [e1, e2]) = - case (op, toUnwindExpr e1, toUnwindExpr e2) of - (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y) - (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y) - (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y) - (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y) - (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y) - (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y) - (MO_Add{}, u1, u2 ) -> UwPlus u1 u2 - (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 - (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 - _otherwise -> pprPanic "Unsupported operator in unwind expression!" - (pprExpr e) -toUnwindExpr e - = pprPanic "Unsupported unwind expression!" (ppr e) diff --git a/cmm/Hoopl/Block.hs b/cmm/Hoopl/Block.hs deleted file mode 100644 --- a/cmm/Hoopl/Block.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -module Hoopl.Block - ( Extensibility (..) - , O - , C - , MaybeO(..) - , IndexedCO - , Block(..) - , blockAppend - , blockCons - , blockFromList - , blockJoin - , blockJoinHead - , blockJoinTail - , blockSnoc - , blockSplit - , blockSplitHead - , blockSplitTail - , blockToList - , emptyBlock - , firstNode - , foldBlockNodesB - , foldBlockNodesB3 - , foldBlockNodesF - , isEmptyBlock - , lastNode - , mapBlock - , mapBlock' - , mapBlock3' - , replaceFirstNode - , replaceLastNode - ) where - -import GhcPrelude - --- ----------------------------------------------------------------------------- --- Shapes: Open and Closed - --- | Used at the type level to indicate "open" vs "closed" structure. -data Extensibility - -- | An "open" structure with a unique, unnamed control-flow edge flowing in - -- or out. "Fallthrough" and concatenation are permitted at an open point. - = Open - -- | A "closed" structure which supports control transfer only through the use - -- of named labels---no "fallthrough" is permitted. The number of control-flow - -- edges is unconstrained. - | Closed - -type O = 'Open -type C = 'Closed - --- | Either type indexed by closed/open using type families -type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k -type instance IndexedCO C a _b = a -type instance IndexedCO O _a b = b - --- | Maybe type indexed by open/closed -data MaybeO ex t where - JustO :: t -> MaybeO O t - NothingO :: MaybeO C t - --- | Maybe type indexed by closed/open -data MaybeC ex t where - JustC :: t -> MaybeC C t - NothingC :: MaybeC O t - -deriving instance Functor (MaybeO ex) -deriving instance Functor (MaybeC ex) - --- ----------------------------------------------------------------------------- --- The Block type - --- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). --- Open at the entry means single entry, mutatis mutandis for exit. --- A closed/closed block is a /basic/ block and can't be extended further. --- Clients should avoid manipulating blocks and should stick to either nodes --- or graphs. -data Block n e x where - BlockCO :: n C O -> Block n O O -> Block n C O - BlockCC :: n C O -> Block n O O -> n O C -> Block n C C - BlockOC :: Block n O O -> n O C -> Block n O C - - BNil :: Block n O O - BMiddle :: n O O -> Block n O O - BCat :: Block n O O -> Block n O O -> Block n O O - BSnoc :: Block n O O -> n O O -> Block n O O - BCons :: n O O -> Block n O O -> Block n O O - - --- ----------------------------------------------------------------------------- --- Simple operations on Blocks - --- Predicates - -isEmptyBlock :: Block n e x -> Bool -isEmptyBlock BNil = True -isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r -isEmptyBlock _ = False - - --- Building - -emptyBlock :: Block n O O -emptyBlock = BNil - -blockCons :: n O O -> Block n O x -> Block n O x -blockCons n b = case b of - BlockOC b l -> (BlockOC $! (n `blockCons` b)) l - BNil{} -> BMiddle n - BMiddle{} -> n `BCons` b - BCat{} -> n `BCons` b - BSnoc{} -> n `BCons` b - BCons{} -> n `BCons` b - -blockSnoc :: Block n e O -> n O O -> Block n e O -blockSnoc b n = case b of - BlockCO f b -> BlockCO f $! (b `blockSnoc` n) - BNil{} -> BMiddle n - BMiddle{} -> b `BSnoc` n - BCat{} -> b `BSnoc` n - BSnoc{} -> b `BSnoc` n - BCons{} -> b `BSnoc` n - -blockJoinHead :: n C O -> Block n O x -> Block n C x -blockJoinHead f (BlockOC b l) = BlockCC f b l -blockJoinHead f b = BlockCO f BNil `cat` b - -blockJoinTail :: Block n e O -> n O C -> Block n e C -blockJoinTail (BlockCO f b) t = BlockCC f b t -blockJoinTail b t = b `cat` BlockOC BNil t - -blockJoin :: n C O -> Block n O O -> n O C -> Block n C C -blockJoin f b t = BlockCC f b t - -blockAppend :: Block n e O -> Block n O x -> Block n e x -blockAppend = cat - - --- Taking apart - -firstNode :: Block n C x -> n C O -firstNode (BlockCO n _) = n -firstNode (BlockCC n _ _) = n - -lastNode :: Block n x C -> n O C -lastNode (BlockOC _ n) = n -lastNode (BlockCC _ _ n) = n - -blockSplitHead :: Block n C x -> (n C O, Block n O x) -blockSplitHead (BlockCO n b) = (n, b) -blockSplitHead (BlockCC n b t) = (n, BlockOC b t) - -blockSplitTail :: Block n e C -> (Block n e O, n O C) -blockSplitTail (BlockOC b n) = (b, n) -blockSplitTail (BlockCC f b t) = (BlockCO f b, t) - --- | Split a closed block into its entry node, open middle block, and --- exit node. -blockSplit :: Block n C C -> (n C O, Block n O O, n O C) -blockSplit (BlockCC f b t) = (f, b, t) - -blockToList :: Block n O O -> [n O O] -blockToList b = go b [] - where go :: Block n O O -> [n O O] -> [n O O] - go BNil r = r - go (BMiddle n) r = n : r - go (BCat b1 b2) r = go b1 $! go b2 r - go (BSnoc b1 n) r = go b1 (n:r) - go (BCons n b1) r = n : go b1 r - -blockFromList :: [n O O] -> Block n O O -blockFromList = foldr BCons BNil - --- Modifying - -replaceFirstNode :: Block n C x -> n C O -> Block n C x -replaceFirstNode (BlockCO _ b) f = BlockCO f b -replaceFirstNode (BlockCC _ b n) f = BlockCC f b n - -replaceLastNode :: Block n x C -> n O C -> Block n x C -replaceLastNode (BlockOC b _) n = BlockOC b n -replaceLastNode (BlockCC l b _) n = BlockCC l b n - --- ----------------------------------------------------------------------------- --- General concatenation - -cat :: Block n e O -> Block n O x -> Block n e x -cat x y = case x of - BNil -> y - - BlockCO l b1 -> case y of - BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n - BNil -> x - BMiddle _ -> BlockCO l $! (b1 `cat` y) - BCat{} -> BlockCO l $! (b1 `cat` y) - BSnoc{} -> BlockCO l $! (b1 `cat` y) - BCons{} -> BlockCO l $! (b1 `cat` y) - - BMiddle n -> case y of - BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 - BNil -> x - BMiddle{} -> BCons n y - BCat{} -> BCons n y - BSnoc{} -> BCons n y - BCons{} -> BCons n y - - BCat{} -> case y of - BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2 - BNil -> x - BMiddle n -> BSnoc x n - BCat{} -> BCat x y - BSnoc{} -> BCat x y - BCons{} -> BCat x y - - BSnoc{} -> case y of - BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 - BNil -> x - BMiddle n -> BSnoc x n - BCat{} -> BCat x y - BSnoc{} -> BCat x y - BCons{} -> BCat x y - - - BCons{} -> case y of - BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 - BNil -> x - BMiddle n -> BSnoc x n - BCat{} -> BCat x y - BSnoc{} -> BCat x y - BCons{} -> BCat x y - - --- ----------------------------------------------------------------------------- --- Mapping - --- | map a function over the nodes of a 'Block' -mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x -mapBlock f (BlockCO n b ) = BlockCO (f n) (mapBlock f b) -mapBlock f (BlockOC b n) = BlockOC (mapBlock f b) (f n) -mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m) -mapBlock _ BNil = BNil -mapBlock f (BMiddle n) = BMiddle (f n) -mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2) -mapBlock f (BSnoc b n) = BSnoc (mapBlock f b) (f n) -mapBlock f (BCons n b) = BCons (f n) (mapBlock f b) - --- | A strict 'mapBlock' -mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x) -mapBlock' f = mapBlock3' (f, f, f) - --- | map over a block, with different functions to apply to first nodes, --- middle nodes and last nodes respectively. The map is strict. --- -mapBlock3' :: forall n n' e x . - ( n C O -> n' C O - , n O O -> n' O O, - n O C -> n' O C) - -> Block n e x -> Block n' e x -mapBlock3' (f, m, l) b = go b - where go :: forall e x . Block n e x -> Block n' e x - go (BlockOC b y) = (BlockOC $! go b) $! l y - go (BlockCO x b) = (BlockCO $! f x) $! (go b) - go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y) - go BNil = BNil - go (BMiddle n) = BMiddle $! m n - go (BCat x y) = (BCat $! go x) $! (go y) - go (BSnoc x n) = (BSnoc $! go x) $! (m n) - go (BCons n x) = (BCons $! m n) $! (go x) - --- ----------------------------------------------------------------------------- --- Folding - - --- | Fold a function over every node in a block, forward or backward. --- The fold function must be polymorphic in the shape of the nodes. -foldBlockNodesF3 :: forall n a b c . - ( n C O -> a -> b - , n O O -> b -> b - , n O C -> b -> c) - -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) -foldBlockNodesF :: forall n a . - (forall e x . n e x -> a -> a) - -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) -foldBlockNodesB3 :: forall n a b c . - ( n C O -> b -> c - , n O O -> b -> b - , n O C -> a -> b) - -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) -foldBlockNodesB :: forall n a . - (forall e x . n e x -> a -> a) - -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) - -foldBlockNodesF3 (ff, fm, fl) = block - where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b - block (BlockCO f b ) = ff f `cat` block b - block (BlockCC f b l) = ff f `cat` block b `cat` fl l - block (BlockOC b l) = block b `cat` fl l - block BNil = id - block (BMiddle node) = fm node - block (b1 `BCat` b2) = block b1 `cat` block b2 - block (b1 `BSnoc` n) = block b1 `cat` fm n - block (n `BCons` b2) = fm n `cat` block b2 - cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c - cat f f' = f' . f - -foldBlockNodesF f = foldBlockNodesF3 (f, f, f) - -foldBlockNodesB3 (ff, fm, fl) = block - where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b - block (BlockCO f b ) = ff f `cat` block b - block (BlockCC f b l) = ff f `cat` block b `cat` fl l - block (BlockOC b l) = block b `cat` fl l - block BNil = id - block (BMiddle node) = fm node - block (b1 `BCat` b2) = block b1 `cat` block b2 - block (b1 `BSnoc` n) = block b1 `cat` fm n - block (n `BCons` b2) = fm n `cat` block b2 - cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c - cat f f' = f . f' - -foldBlockNodesB f = foldBlockNodesB3 (f, f, f) - diff --git a/cmm/Hoopl/Collections.hs b/cmm/Hoopl/Collections.hs deleted file mode 100644 --- a/cmm/Hoopl/Collections.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Hoopl.Collections - ( IsSet(..) - , setInsertList, setDeleteList, setUnions - , IsMap(..) - , mapInsertList, mapDeleteList, mapUnions - , UniqueMap, UniqueSet - ) where - -import GhcPrelude - -import qualified Data.IntMap.Strict as M -import qualified Data.IntSet as S - -import Data.List (foldl1') - -class IsSet set where - type ElemOf set - - setNull :: set -> Bool - setSize :: set -> Int - setMember :: ElemOf set -> set -> Bool - - setEmpty :: set - setSingleton :: ElemOf set -> set - setInsert :: ElemOf set -> set -> set - setDelete :: ElemOf set -> set -> set - - setUnion :: set -> set -> set - setDifference :: set -> set -> set - setIntersection :: set -> set -> set - setIsSubsetOf :: set -> set -> Bool - setFilter :: (ElemOf set -> Bool) -> set -> set - - setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b - setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b - - setElems :: set -> [ElemOf set] - setFromList :: [ElemOf set] -> set - --- Helper functions for IsSet class -setInsertList :: IsSet set => [ElemOf set] -> set -> set -setInsertList keys set = foldl' (flip setInsert) set keys - -setDeleteList :: IsSet set => [ElemOf set] -> set -> set -setDeleteList keys set = foldl' (flip setDelete) set keys - -setUnions :: IsSet set => [set] -> set -setUnions [] = setEmpty -setUnions sets = foldl1' setUnion sets - - -class IsMap map where - type KeyOf map - - mapNull :: map a -> Bool - mapSize :: map a -> Int - mapMember :: KeyOf map -> map a -> Bool - mapLookup :: KeyOf map -> map a -> Maybe a - mapFindWithDefault :: a -> KeyOf map -> map a -> a - - mapEmpty :: map a - mapSingleton :: KeyOf map -> a -> map a - mapInsert :: KeyOf map -> a -> map a -> map a - mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a - mapDelete :: KeyOf map -> map a -> map a - mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a - mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a - - mapUnion :: map a -> map a -> map a - mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a - mapDifference :: map a -> map a -> map a - mapIntersection :: map a -> map a -> map a - mapIsSubmapOf :: Eq a => map a -> map a -> Bool - - mapMap :: (a -> b) -> map a -> map b - mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b - mapFoldl :: (b -> a -> b) -> b -> map a -> b - mapFoldr :: (a -> b -> b) -> b -> map a -> b - mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b - mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m - mapFilter :: (a -> Bool) -> map a -> map a - mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a - - - mapElems :: map a -> [a] - mapKeys :: map a -> [KeyOf map] - mapToList :: map a -> [(KeyOf map, a)] - mapFromList :: [(KeyOf map, a)] -> map a - mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a - --- Helper functions for IsMap class -mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a -mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs - -mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a -mapDeleteList keys map = foldl' (flip mapDelete) map keys - -mapUnions :: IsMap map => [map a] -> map a -mapUnions [] = mapEmpty -mapUnions maps = foldl1' mapUnion maps - ------------------------------------------------------------------------------ --- Basic instances ------------------------------------------------------------------------------ - -newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid) - -instance IsSet UniqueSet where - type ElemOf UniqueSet = Int - - setNull (US s) = S.null s - setSize (US s) = S.size s - setMember k (US s) = S.member k s - - setEmpty = US S.empty - setSingleton k = US (S.singleton k) - setInsert k (US s) = US (S.insert k s) - setDelete k (US s) = US (S.delete k s) - - setUnion (US x) (US y) = US (S.union x y) - setDifference (US x) (US y) = US (S.difference x y) - setIntersection (US x) (US y) = US (S.intersection x y) - setIsSubsetOf (US x) (US y) = S.isSubsetOf x y - setFilter f (US s) = US (S.filter f s) - - setFoldl k z (US s) = S.foldl' k z s - setFoldr k z (US s) = S.foldr k z s - - setElems (US s) = S.elems s - setFromList ks = US (S.fromList ks) - -newtype UniqueMap v = UM (M.IntMap v) - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -instance IsMap UniqueMap where - type KeyOf UniqueMap = Int - - mapNull (UM m) = M.null m - mapSize (UM m) = M.size m - mapMember k (UM m) = M.member k m - mapLookup k (UM m) = M.lookup k m - mapFindWithDefault def k (UM m) = M.findWithDefault def k m - - mapEmpty = UM M.empty - mapSingleton k v = UM (M.singleton k v) - mapInsert k v (UM m) = UM (M.insert k v m) - mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) - mapDelete k (UM m) = UM (M.delete k m) - mapAlter f k (UM m) = UM (M.alter f k m) - mapAdjust f k (UM m) = UM (M.adjust f k m) - - mapUnion (UM x) (UM y) = UM (M.union x y) - mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y) - mapDifference (UM x) (UM y) = UM (M.difference x y) - mapIntersection (UM x) (UM y) = UM (M.intersection x y) - mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y - - mapMap f (UM m) = UM (M.map f m) - mapMapWithKey f (UM m) = UM (M.mapWithKey f m) - mapFoldl k z (UM m) = M.foldl' k z m - mapFoldr k z (UM m) = M.foldr k z m - mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m - mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m - mapFilter f (UM m) = UM (M.filter f m) - mapFilterWithKey f (UM m) = UM (M.filterWithKey f m) - - mapElems (UM m) = M.elems m - mapKeys (UM m) = M.keys m - mapToList (UM m) = M.toList m - mapFromList assocs = UM (M.fromList assocs) - mapFromListWith f assocs = UM (M.fromListWith f assocs) diff --git a/cmm/Hoopl/Dataflow.hs b/cmm/Hoopl/Dataflow.hs deleted file mode 100644 --- a/cmm/Hoopl/Dataflow.hs +++ /dev/null @@ -1,441 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- --- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, --- and Norman Ramsey --- --- Modifications copyright (c) The University of Glasgow 2012 --- --- This module is a specialised and optimised version of --- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is --- specialised to the UniqSM monad. --- - -module Hoopl.Dataflow - ( C, O, Block - , lastNode, entryLabel - , foldNodesBwdOO - , foldRewriteNodesBwdOO - , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..) - , TransferFun, RewriteFun - , Fact, FactBase - , getFact, mkFactBase - , analyzeCmmFwd, analyzeCmmBwd - , rewriteCmmBwd - , changedIf - , joinOutFacts - , joinFacts - ) -where - -import GhcPrelude - -import Cmm -import UniqSupply - -import Data.Array -import Data.Maybe -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - -import Hoopl.Block -import Hoopl.Graph -import Hoopl.Collections -import Hoopl.Label - -type family Fact (x :: Extensibility) f :: * -type instance Fact C f = FactBase f -type instance Fact O f = f - -newtype OldFact a = OldFact a - -newtype NewFact a = NewFact a - --- | The result of joining OldFact and NewFact. -data JoinedFact a - = Changed !a -- ^ Result is different than OldFact. - | NotChanged !a -- ^ Result is the same as OldFact. - -getJoined :: JoinedFact a -> a -getJoined (Changed a) = a -getJoined (NotChanged a) = a - -changedIf :: Bool -> a -> JoinedFact a -changedIf True = Changed -changedIf False = NotChanged - -type JoinFun a = OldFact a -> NewFact a -> JoinedFact a - -data DataflowLattice a = DataflowLattice - { fact_bot :: a - , fact_join :: JoinFun a - } - -data Direction = Fwd | Bwd - -type TransferFun f = CmmBlock -> FactBase f -> FactBase f - --- | Function for rewrtiting and analysis combined. To be used with --- @rewriteCmm@. --- --- Currently set to work with @UniqSM@ monad, but we could probably abstract --- that away (if we do that, we might want to specialize the fixpoint algorithms --- to the particular monads through SPECIALIZE). -type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f) - -analyzeCmmBwd, analyzeCmmFwd - :: DataflowLattice f - -> TransferFun f - -> CmmGraph - -> FactBase f - -> FactBase f -analyzeCmmBwd = analyzeCmm Bwd -analyzeCmmFwd = analyzeCmm Fwd - -analyzeCmm - :: Direction - -> DataflowLattice f - -> TransferFun f - -> CmmGraph - -> FactBase f - -> FactBase f -analyzeCmm dir lattice transfer cmmGraph initFact = - {-# SCC analyzeCmm #-} - let entry = g_entry cmmGraph - hooplGraph = g_graph cmmGraph - blockMap = - case hooplGraph of - GMany NothingO bm NothingO -> bm - in fixpointAnalysis dir lattice transfer entry blockMap initFact - --- Fixpoint algorithm. -fixpointAnalysis - :: forall f. - Direction - -> DataflowLattice f - -> TransferFun f - -> Label - -> LabelMap CmmBlock - -> FactBase f - -> FactBase f -fixpointAnalysis direction lattice do_block entry blockmap = loop start - where - -- Sorting the blocks helps to minimize the number of times we need to - -- process blocks. For instance, for forward analysis we want to look at - -- blocks in reverse postorder. Also, see comments for sortBlocks. - blocks = sortBlocks direction entry blockmap - num_blocks = length blocks - block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks - start = {-# SCC "start" #-} IntSet.fromDistinctAscList - [0 .. num_blocks - 1] - dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks - join = fact_join lattice - - loop - :: IntHeap -- ^ Worklist, i.e., blocks to process - -> FactBase f -- ^ Current result (increases monotonically) - -> FactBase f - loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo = - let block = block_arr ! index - out_facts = {-# SCC "do_block" #-} do_block block fbase1 - -- For each of the outgoing edges, we join it with the current - -- information in fbase1 and (if something changed) we update it - -- and add the affected blocks to the worklist. - (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-} - mapFoldlWithKey - (updateFact join dep_blocks) (todo1, fbase1) out_facts - in loop todo2 fbase2 - loop _ !fbase1 = fbase1 - -rewriteCmmBwd - :: DataflowLattice f - -> RewriteFun f - -> CmmGraph - -> FactBase f - -> UniqSM (CmmGraph, FactBase f) -rewriteCmmBwd = rewriteCmm Bwd - -rewriteCmm - :: Direction - -> DataflowLattice f - -> RewriteFun f - -> CmmGraph - -> FactBase f - -> UniqSM (CmmGraph, FactBase f) -rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do - let entry = g_entry cmmGraph - hooplGraph = g_graph cmmGraph - blockMap1 = - case hooplGraph of - GMany NothingO bm NothingO -> bm - (blockMap2, facts) <- - fixpointRewrite dir lattice rwFun entry blockMap1 initFact - return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts) - -fixpointRewrite - :: forall f. - Direction - -> DataflowLattice f - -> RewriteFun f - -> Label - -> LabelMap CmmBlock - -> FactBase f - -> UniqSM (LabelMap CmmBlock, FactBase f) -fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap - where - -- Sorting the blocks helps to minimize the number of times we need to - -- process blocks. For instance, for forward analysis we want to look at - -- blocks in reverse postorder. Also, see comments for sortBlocks. - blocks = sortBlocks dir entry blockmap - num_blocks = length blocks - block_arr = {-# SCC "block_arr_rewrite" #-} - listArray (0, num_blocks - 1) blocks - start = {-# SCC "start_rewrite" #-} - IntSet.fromDistinctAscList [0 .. num_blocks - 1] - dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks - join = fact_join lattice - - loop - :: IntHeap -- ^ Worklist, i.e., blocks to process - -> LabelMap CmmBlock -- ^ Rewritten blocks. - -> FactBase f -- ^ Current facts. - -> UniqSM (LabelMap CmmBlock, FactBase f) - loop todo !blocks1 !fbase1 - | Just (index, todo1) <- IntSet.minView todo = do - -- Note that we use the *original* block here. This is important. - -- We're optimistically rewriting blocks even before reaching the fixed - -- point, which means that the rewrite might be incorrect. So if the - -- facts change, we need to rewrite the original block again (taking - -- into account the new facts). - let block = block_arr ! index - (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-} - do_block block fbase1 - let blocks2 = mapInsert (entryLabel new_block) new_block blocks1 - (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-} - mapFoldlWithKey - (updateFact join dep_blocks) (todo1, fbase1) out_facts - loop todo2 blocks2 fbase2 - loop _ !blocks1 !fbase1 = return (blocks1, fbase1) - - -{- -Note [Unreachable blocks] -~~~~~~~~~~~~~~~~~~~~~~~~~ -A block that is not in the domain of tfb_fbase is "currently unreachable". -A currently-unreachable block is not even analyzed. Reason: consider -constant prop and this graph, with entry point L1: - L1: x:=3; goto L4 - L2: x:=4; goto L4 - L4: if x>3 goto L2 else goto L5 -Here L2 is actually unreachable, but if we process it with bottom input fact, -we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. - -* If a currently-unreachable block is not analyzed, then its rewritten - graph will not be accumulated in tfb_rg. And that is good: - unreachable blocks simply do not appear in the output. - -* Note that clients must be careful to provide a fact (even if bottom) - for each entry point. Otherwise useful blocks may be garbage collected. - -* Note that updateFact must set the change-flag if a label goes from - not-in-fbase to in-fbase, even if its fact is bottom. In effect the - real fact lattice is - UNR - bottom - the points above bottom - -* Even if the fact is going from UNR to bottom, we still call the - client's fact_join function because it might give the client - some useful debugging information. - -* All of this only applies for *forward* ixpoints. For the backward - case we must treat every block as reachable; it might finish with a - 'return', and therefore have no successors, for example. --} - - ------------------------------------------------------------------------------ --- Pieces that are shared by fixpoint and fixpoint_anal ------------------------------------------------------------------------------ - --- | Sort the blocks into the right order for analysis. This means reverse --- postorder for a forward analysis. For the backward one, we simply reverse --- that (see Note [Backward vs forward analysis]). -sortBlocks - :: NonLocal n - => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C] -sortBlocks direction entry blockmap = - case direction of - Fwd -> fwd - Bwd -> reverse fwd - where - fwd = revPostorderFrom blockmap entry - --- Note [Backward vs forward analysis] --- --- The forward and backward cases are not dual. In the forward case, the entry --- points are known, and one simply traverses the body blocks from those points. --- In the backward case, something is known about the exit points, but a --- backward analysis must also include reachable blocks that don't reach the --- exit, as in a procedure that loops forever and has side effects.) --- For instance, let E be the entry and X the exit blocks (arrows indicate --- control flow) --- E -> X --- E -> B --- B -> C --- C -> B --- We do need to include B and C even though they're unreachable in the --- *reverse* graph (that we could use for backward analysis): --- E <- X --- E <- B --- B <- C --- C <- B --- So when sorting the blocks for the backward analysis, we simply take the --- reverse of what is used for the forward one. - - --- | Construct a mapping from a @Label@ to the block indexes that should be --- re-analyzed if the facts at that @Label@ change. --- --- Note that we're considering here the entry point of the block, so if the --- facts change at the entry: --- * for a backward analysis we need to re-analyze all the predecessors, but --- * for a forward analysis, we only need to re-analyze the current block --- (and that will in turn propagate facts into its successors). -mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet -mkDepBlocks Fwd blocks = go blocks 0 mapEmpty - where - go [] !_ !dep_map = dep_map - go (b:bs) !n !dep_map = - go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map -mkDepBlocks Bwd blocks = go blocks 0 mapEmpty - where - go [] !_ !dep_map = dep_map - go (b:bs) !n !dep_map = - let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m - in go bs (n + 1) $ foldl' insert dep_map (successors b) - --- | After some new facts have been generated by analysing a block, we --- fold this function over them to generate (a) a list of block --- indices to (re-)analyse, and (b) the new FactBase. -updateFact - :: JoinFun f - -> LabelMap IntSet - -> (IntHeap, FactBase f) - -> Label - -> f -- out fact - -> (IntHeap, FactBase f) -updateFact fact_join dep_blocks (todo, fbase) lbl new_fact - = case lookupFact lbl fbase of - Nothing -> - -- Note [No old fact] - let !z = mapInsert lbl new_fact fbase in (changed, z) - Just old_fact -> - case fact_join (OldFact old_fact) (NewFact new_fact) of - (NotChanged _) -> (todo, fbase) - (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z) - where - changed = todo `IntSet.union` - mapFindWithDefault IntSet.empty lbl dep_blocks - -{- -Note [No old fact] - -We know that the new_fact is >= _|_, so we don't need to join. However, -if the new fact is also _|_, and we have already analysed its block, -we don't need to record a change. So there's a tradeoff here. It turns -out that always recording a change is faster. --} - ----------------------------------------------------------------- --- Utilities ----------------------------------------------------------------- - --- Fact lookup: the fact `orelse` bottom -getFact :: DataflowLattice f -> Label -> FactBase f -> f -getFact lat l fb = case lookupFact l fb of Just f -> f - Nothing -> fact_bot lat - --- | Returns the result of joining the facts from all the successors of the --- provided node or block. -joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f -joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts - where - join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) - facts = - [ fromJust fact - | s <- successors nonLocal - , let fact = lookupFact s fact_base - , isJust fact - ] - -joinFacts :: DataflowLattice f -> [f] -> f -joinFacts lattice facts = foldl' join (fact_bot lattice) facts - where - join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) - --- | Returns the joined facts for each label. -mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f -mkFactBase lattice = foldl' add mapEmpty - where - join = fact_join lattice - - add result (l, f1) = - let !newFact = - case mapLookup l result of - Nothing -> f1 - Just f2 -> getJoined $ join (OldFact f1) (NewFact f2) - in mapInsert l newFact result - --- | Folds backward over all nodes of an open-open block. --- Strict in the accumulator. -foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f -foldNodesBwdOO funOO = go - where - go (BCat b1 b2) f = go b1 $! go b2 f - go (BSnoc h n) f = go h $! funOO n f - go (BCons n t) f = funOO n $! go t f - go (BMiddle n) f = funOO n f - go BNil f = f -{-# INLINABLE foldNodesBwdOO #-} - --- | Folds backward over all the nodes of an open-open block and allows --- rewriting them. The accumulator is both the block of nodes and @f@ (usually --- dataflow facts). --- Strict in both accumulated parts. -foldRewriteNodesBwdOO - :: forall f. - (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)) - -> Block CmmNode O O - -> f - -> UniqSM (Block CmmNode O O, f) -foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts - where - go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1 - go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1 - go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1 - go (BMiddle node) !fact1 = rewriteOO node fact1 - go BNil !fact = return (BNil, fact) - - comp rew1 rew2 = \f1 -> do - (b, f2) <- rew2 f1 - (a, !f3) <- rew1 f2 - let !c = joinBlocksOO a b - return (c, f3) - {-# INLINE comp #-} -{-# INLINABLE foldRewriteNodesBwdOO #-} - -joinBlocksOO :: Block n O O -> Block n O O -> Block n O O -joinBlocksOO BNil b = b -joinBlocksOO b BNil = b -joinBlocksOO (BMiddle n) b = blockCons n b -joinBlocksOO b (BMiddle n) = blockSnoc b n -joinBlocksOO b1 b2 = BCat b1 b2 - -type IntHeap = IntSet diff --git a/cmm/Hoopl/Graph.hs b/cmm/Hoopl/Graph.hs deleted file mode 100644 --- a/cmm/Hoopl/Graph.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Hoopl.Graph - ( Body - , Graph - , Graph'(..) - , NonLocal(..) - , addBlock - , bodyList - , emptyBody - , labelsDefined - , mapGraph - , mapGraphBlocks - , revPostorderFrom - ) where - - -import GhcPrelude -import Util - -import Hoopl.Label -import Hoopl.Block -import Hoopl.Collections - --- | A (possibly empty) collection of closed/closed blocks -type Body n = LabelMap (Block n C C) - --- | @Body@ abstracted over @block@ -type Body' block (n :: Extensibility -> Extensibility -> *) = LabelMap (block n C C) - -------------------------------- --- | Gives access to the anchor points for --- nonlocal edges as well as the edges themselves -class NonLocal thing where - entryLabel :: thing C x -> Label -- ^ The label of a first node or block - successors :: thing e C -> [Label] -- ^ Gives control-flow successors - -instance NonLocal n => NonLocal (Block n) where - entryLabel (BlockCO f _) = entryLabel f - entryLabel (BlockCC f _ _) = entryLabel f - - successors (BlockOC _ n) = successors n - successors (BlockCC _ _ n) = successors n - - -emptyBody :: Body' block n -emptyBody = mapEmpty - -bodyList :: Body' block n -> [(Label,block n C C)] -bodyList body = mapToList body - -addBlock - :: (NonLocal block, HasDebugCallStack) - => block C C -> LabelMap (block C C) -> LabelMap (block C C) -addBlock block body = mapAlter add lbl body - where - lbl = entryLabel block - add Nothing = Just block - add _ = error $ "duplicate label " ++ show lbl ++ " in graph" - - --- --------------------------------------------------------------------------- --- Graph - --- | A control-flow graph, which may take any of four shapes (O/O, --- O/C, C/O, C/C). A graph open at the entry has a single, --- distinguished, anonymous entry point; if a graph is closed at the --- entry, its entry point(s) are supplied by a context. -type Graph = Graph' Block - --- | @Graph'@ is abstracted over the block type, so that we can build --- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow --- needs this). -data Graph' block (n :: Extensibility -> Extensibility -> *) e x where - GNil :: Graph' block n O O - GUnit :: block n O O -> Graph' block n O O - GMany :: MaybeO e (block n O C) - -> Body' block n - -> MaybeO x (block n C O) - -> Graph' block n e x - - --- ----------------------------------------------------------------------------- --- Mapping over graphs - --- | Maps over all nodes in a graph. -mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x -mapGraph f = mapGraphBlocks (mapBlock f) - --- | Function 'mapGraphBlocks' enables a change of representation of blocks, --- nodes, or both. It lifts a polymorphic block transform into a polymorphic --- graph transform. When the block representation stabilizes, a similar --- function should be provided for blocks. -mapGraphBlocks :: forall block n block' n' e x . - (forall e x . block n e x -> block' n' e x) - -> (Graph' block n e x -> Graph' block' n' e x) - -mapGraphBlocks f = map - where map :: Graph' block n e x -> Graph' block' n' e x - map GNil = GNil - map (GUnit b) = GUnit (f b) - map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) - --- ----------------------------------------------------------------------------- --- Extracting Labels from graphs - -labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x - -> LabelSet -labelsDefined GNil = setEmpty -labelsDefined (GUnit{}) = setEmpty -labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body - where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet - addEntry labels label _ = setInsert label labels - exitLabel :: MaybeO x (block n C O) -> LabelSet - exitLabel NothingO = setEmpty - exitLabel (JustO b) = setSingleton (entryLabel b) - - ----------------------------------------------------------------- - --- | Returns a list of blocks reachable from the provided Labels in the reverse --- postorder. --- --- This is the most important traversal over this data structure. It drops --- unreachable code and puts blocks in an order that is good for solving forward --- dataflow problems quickly. The reverse order is good for solving backward --- dataflow problems quickly. The forward order is also reasonably good for --- emitting instructions, except that it will not usually exploit Forrest --- Baskett's trick of eliminating the unconditional branch from a loop. For --- that you would need a more serious analysis, probably based on dominators, to --- identify loop headers. --- --- For forward analyses we want reverse postorder visitation, consider: --- @ --- A -> [B,C] --- B -> D --- C -> D --- @ --- Postorder: [D, C, B, A] (or [D, B, C, A]) --- Reverse postorder: [A, B, C, D] (or [A, C, B, D]) --- This matters for, e.g., forward analysis, because we want to analyze *both* --- B and C before we analyze D. -revPostorderFrom - :: forall block. (NonLocal block) - => LabelMap (block C C) -> Label -> [block C C] -revPostorderFrom graph start = go start_worklist setEmpty [] - where - start_worklist = lookup_for_descend start Nil - - -- To compute the postorder we need to "visit" a block (mark as done) - -- *after* visiting all its successors. So we need to know whether we - -- already processed all successors of each block (and @NonLocal@ allows - -- arbitrary many successors). So we use an explicit stack with an extra bit - -- of information: - -- * @ConsTodo@ means to explore the block if it wasn't visited before - -- * @ConsMark@ means that all successors were already done and we can add - -- the block to the result. - -- - -- NOTE: We add blocks to the result list in postorder, but we *prepend* - -- them (i.e., we use @(:)@), which means that the final list is in reverse - -- postorder. - go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C] - go Nil !_ !result = result - go (ConsMark block rest) !wip_or_done !result = - go rest wip_or_done (block : result) - go (ConsTodo block rest) !wip_or_done !result - | entryLabel block `setMember` wip_or_done = go rest wip_or_done result - | otherwise = - let new_worklist = - foldr lookup_for_descend - (ConsMark block rest) - (successors block) - in go new_worklist (setInsert (entryLabel block) wip_or_done) result - - lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C) - lookup_for_descend label wl - | Just b <- mapLookup label graph = ConsTodo b wl - | otherwise = - error $ "Label that doesn't have a block?! " ++ show label - -data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil diff --git a/cmm/Hoopl/Label.hs b/cmm/Hoopl/Label.hs deleted file mode 100644 --- a/cmm/Hoopl/Label.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Hoopl.Label - ( Label - , LabelMap - , LabelSet - , FactBase - , lookupFact - , mkHooplLabel - ) where - -import GhcPrelude - -import Outputable - --- TODO: This should really just use GHC's Unique and Uniq{Set,FM} -import Hoopl.Collections - -import Unique (Uniquable(..)) -import TrieMap - - ------------------------------------------------------------------------------ --- Label ------------------------------------------------------------------------------ - -newtype Label = Label { lblToUnique :: Int } - deriving (Eq, Ord) - -mkHooplLabel :: Int -> Label -mkHooplLabel = Label - -instance Show Label where - show (Label n) = "L" ++ show n - -instance Uniquable Label where - getUnique label = getUnique (lblToUnique label) - -instance Outputable Label where - ppr label = ppr (getUnique label) - ------------------------------------------------------------------------------ --- LabelSet - -newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup) - -instance IsSet LabelSet where - type ElemOf LabelSet = Label - - setNull (LS s) = setNull s - setSize (LS s) = setSize s - setMember (Label k) (LS s) = setMember k s - - setEmpty = LS setEmpty - setSingleton (Label k) = LS (setSingleton k) - setInsert (Label k) (LS s) = LS (setInsert k s) - setDelete (Label k) (LS s) = LS (setDelete k s) - - setUnion (LS x) (LS y) = LS (setUnion x y) - setDifference (LS x) (LS y) = LS (setDifference x y) - setIntersection (LS x) (LS y) = LS (setIntersection x y) - setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y - setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s) - setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s - setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s - - setElems (LS s) = map mkHooplLabel (setElems s) - setFromList ks = LS (setFromList (map lblToUnique ks)) - ------------------------------------------------------------------------------ --- LabelMap - -newtype LabelMap v = LM (UniqueMap v) - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -instance IsMap LabelMap where - type KeyOf LabelMap = Label - - mapNull (LM m) = mapNull m - mapSize (LM m) = mapSize m - mapMember (Label k) (LM m) = mapMember k m - mapLookup (Label k) (LM m) = mapLookup k m - mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m - - mapEmpty = LM mapEmpty - mapSingleton (Label k) v = LM (mapSingleton k v) - mapInsert (Label k) v (LM m) = LM (mapInsert k v m) - mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m) - mapDelete (Label k) (LM m) = LM (mapDelete k m) - mapAlter f (Label k) (LM m) = LM (mapAlter f k m) - mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m) - - mapUnion (LM x) (LM y) = LM (mapUnion x y) - mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y) - mapDifference (LM x) (LM y) = LM (mapDifference x y) - mapIntersection (LM x) (LM y) = LM (mapIntersection x y) - mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y - - mapMap f (LM m) = LM (mapMap f m) - mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m) - mapFoldl k z (LM m) = mapFoldl k z m - mapFoldr k z (LM m) = mapFoldr k z m - mapFoldlWithKey k z (LM m) = - mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m - mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m - mapFilter f (LM m) = LM (mapFilter f m) - mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m) - - mapElems (LM m) = mapElems m - mapKeys (LM m) = map mkHooplLabel (mapKeys m) - mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m] - mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs]) - mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) - ------------------------------------------------------------------------------ --- Instances - -instance Outputable LabelSet where - ppr = ppr . setElems - -instance Outputable a => Outputable (LabelMap a) where - ppr = ppr . mapToList - -instance TrieMap LabelMap where - type Key LabelMap = Label - emptyTM = mapEmpty - lookupTM k m = mapLookup k m - alterTM k f m = mapAlter f k m - foldTM k m z = mapFoldr k z m - mapTM f m = mapMap f m - ------------------------------------------------------------------------------ --- FactBase - -type FactBase f = LabelMap f - -lookupFact :: Label -> FactBase f -> Maybe f -lookupFact = mapLookup diff --git a/cmm/MkGraph.hs b/cmm/MkGraph.hs deleted file mode 100644 --- a/cmm/MkGraph.hs +++ /dev/null @@ -1,484 +0,0 @@ -{-# LANGUAGE BangPatterns, GADTs #-} - -module MkGraph - ( CmmAGraph, CmmAGraphScoped, CgStmt(..) - , (<*>), catAGraphs - , mkLabel, mkMiddle, mkLast, outOfLine - , lgraphOfAGraph, labelAGraph - - , stackStubExpr - , mkNop, mkAssign, mkStore - , mkUnsafeCall, mkFinalCall, mkCallReturnsTo - , mkJumpReturnsTo - , mkJump, mkJumpExtra - , mkRawJump - , mkCbranch, mkSwitch - , mkReturn, mkComment, mkCallEntry, mkBranch - , mkUnwind - , copyInOflow, copyOutOflow - , noExtraStack - , toCall, Transfer(..) - ) -where - -import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>) - -import BlockId -import Cmm -import CmmCallConv -import CmmSwitch (SwitchTargets) - -import Hoopl.Block -import Hoopl.Graph -import Hoopl.Label -import DynFlags -import FastString -import ForeignCall -import OrdList -import SMRep (ByteOff) -import UniqSupply -import Util -import Panic - - ------------------------------------------------------------------------------ --- Building Graphs - - --- | CmmAGraph is a chunk of code consisting of: --- --- * ordinary statements (assignments, stores etc.) --- * jumps --- * labels --- * out-of-line labelled blocks --- --- The semantics is that control falls through labels and out-of-line --- blocks. Everything after a jump up to the next label is by --- definition unreachable code, and will be discarded. --- --- Two CmmAGraphs can be stuck together with <*>, with the meaning that --- control flows from the first to the second. --- --- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends) --- by providing a label for the entry point and a tick scope; see --- 'labelAGraph'. -type CmmAGraph = OrdList CgStmt --- | Unlabeled graph with tick scope -type CmmAGraphScoped = (CmmAGraph, CmmTickScope) - -data CgStmt - = CgLabel BlockId CmmTickScope - | CgStmt (CmmNode O O) - | CgLast (CmmNode O C) - | CgFork BlockId CmmAGraph CmmTickScope - -flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph -flattenCmmAGraph id (stmts_t, tscope) = - CmmGraph { g_entry = id, - g_graph = GMany NothingO body NothingO } - where - body = foldr addBlock emptyBody $ flatten id stmts_t tscope [] - - -- - -- flatten: given an entry label and a CmmAGraph, make a list of blocks. - -- - -- NB. avoid the quadratic-append trap by passing in the tail of the - -- list. This is important for Very Long Functions (e.g. in T783). - -- - flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C] - -> [Block CmmNode C C] - flatten id g tscope blocks - = flatten1 (fromOL g) block' blocks - where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock - -- - -- flatten0: we are outside a block at this point: any code before - -- the first label is unreachable, so just drop it. - -- - flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] - flatten0 [] blocks = blocks - - flatten0 (CgLabel id tscope : stmts) blocks - = flatten1 stmts block blocks - where !block = blockJoinHead (CmmEntry id tscope) emptyBlock - - flatten0 (CgFork fork_id stmts_t tscope : rest) blocks - = flatten fork_id stmts_t tscope $ flatten0 rest blocks - - flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks - flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks - - -- - -- flatten1: we have a partial block, collect statements until the - -- next last node to make a block, then call flatten0 to get the rest - -- of the blocks - -- - flatten1 :: [CgStmt] -> Block CmmNode C O - -> [Block CmmNode C C] -> [Block CmmNode C C] - - -- The current block falls through to the end of a function or fork: - -- this code should not be reachable, but it may be referenced by - -- other code that is not reachable. We'll remove it later with - -- dead-code analysis, but for now we have to keep the graph - -- well-formed, so we terminate the block with a branch to the - -- beginning of the current block. - flatten1 [] block blocks - = blockJoinTail block (CmmBranch (entryLabel block)) : blocks - - flatten1 (CgLast stmt : stmts) block blocks - = block' : flatten0 stmts blocks - where !block' = blockJoinTail block stmt - - flatten1 (CgStmt stmt : stmts) block blocks - = flatten1 stmts block' blocks - where !block' = blockSnoc block stmt - - flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks - = flatten fork_id stmts_t tscope $ flatten1 rest block blocks - - -- a label here means that we should start a new block, and the - -- current block should fall through to the new block. - flatten1 (CgLabel id tscp : stmts) block blocks - = blockJoinTail block (CmmBranch id) : - flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks - - - ----------- AGraph manipulation - -(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph -(<*>) = appOL - -catAGraphs :: [CmmAGraph] -> CmmAGraph -catAGraphs = concatOL - --- | creates a sequence "goto id; id:" as an AGraph -mkLabel :: BlockId -> CmmTickScope -> CmmAGraph -mkLabel bid scp = unitOL (CgLabel bid scp) - --- | creates an open AGraph from a given node -mkMiddle :: CmmNode O O -> CmmAGraph -mkMiddle middle = unitOL (CgStmt middle) - --- | creates a closed AGraph from a given node -mkLast :: CmmNode O C -> CmmAGraph -mkLast last = unitOL (CgLast last) - --- | A labelled code block; should end in a last node -outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph -outOfLine l (c,s) = unitOL (CgFork l c s) - --- | allocate a fresh label for the entry point -lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph -lgraphOfAGraph g = do - u <- getUniqueM - return (labelAGraph (mkBlockId u) g) - --- | use the given BlockId as the label of the entry point -labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph -labelAGraph lbl ag = flattenCmmAGraph lbl ag - ----------- No-ops -mkNop :: CmmAGraph -mkNop = nilOL - -mkComment :: FastString -> CmmAGraph -mkComment fs - -- SDM: generating all those comments takes time, this saved about 4% for me - | debugIsOn = mkMiddle $ CmmComment fs - | otherwise = nilOL - ----------- Assignment and store -mkAssign :: CmmReg -> CmmExpr -> CmmAGraph -mkAssign l (CmmReg r) | l == r = mkNop -mkAssign l r = mkMiddle $ CmmAssign l r - -mkStore :: CmmExpr -> CmmExpr -> CmmAGraph -mkStore l r = mkMiddle $ CmmStore l r - ----------- Control transfer -mkJump :: DynFlags -> Convention -> CmmExpr - -> [CmmExpr] - -> UpdFrameOffset - -> CmmAGraph -mkJump dflags conv e actuals updfr_off = - lastWithArgs dflags Jump Old conv actuals updfr_off $ - toCall e Nothing updfr_off 0 - --- | A jump where the caller says what the live GlobalRegs are. Used --- for low-level hand-written Cmm. -mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg] - -> CmmAGraph -mkRawJump dflags e updfr_off vols = - lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $ - \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols - - -mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr] - -> UpdFrameOffset -> [CmmExpr] - -> CmmAGraph -mkJumpExtra dflags conv e actuals updfr_off extra_stack = - lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $ - toCall e Nothing updfr_off 0 - -mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph -mkCbranch pred ifso ifnot likely = - mkLast (CmmCondBranch pred ifso ifnot likely) - -mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph -mkSwitch e tbl = mkLast $ CmmSwitch e tbl - -mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset - -> CmmAGraph -mkReturn dflags e actuals updfr_off = - lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ - toCall e Nothing updfr_off 0 - -mkBranch :: BlockId -> CmmAGraph -mkBranch bid = mkLast (CmmBranch bid) - -mkFinalCall :: DynFlags - -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset - -> CmmAGraph -mkFinalCall dflags f _ actuals updfr_off = - lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $ - toCall f Nothing updfr_off 0 - -mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] - -> BlockId - -> ByteOff - -> UpdFrameOffset - -> [CmmExpr] - -> CmmAGraph -mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do - lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals - updfr_off extra_stack $ - toCall f (Just ret_lbl) updfr_off ret_off - --- Like mkCallReturnsTo, but does not push the return address (it is assumed to be --- already on the stack). -mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] - -> BlockId - -> ByteOff - -> UpdFrameOffset - -> CmmAGraph -mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do - lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $ - toCall f (Just ret_lbl) updfr_off ret_off - -mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph -mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as - --- | Construct a 'CmmUnwind' node for the given register and unwinding --- expression. -mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph -mkUnwind r e = mkMiddle $ CmmUnwind [(r, Just e)] - --------------------------------------------------------------------------- - - - - --- Why are we inserting extra blocks that simply branch to the successors? --- Because in addition to the branch instruction, @mkBranch@ will insert --- a necessary adjustment to the stack pointer. - - --- For debugging purposes, we can stub out dead stack slots: -stackStubExpr :: Width -> CmmExpr -stackStubExpr w = CmmLit (CmmInt 0 w) - --- When we copy in parameters, we usually want to put overflow --- parameters on the stack, but sometimes we want to pass the --- variables in their spill slots. Therefore, for copying arguments --- and results, we provide different functions to pass the arguments --- in an overflow area and to pass them in spill slots. -copyInOflow :: DynFlags -> Convention -> Area - -> [CmmFormal] - -> [CmmFormal] - -> (Int, [GlobalReg], CmmAGraph) - -copyInOflow dflags conv area formals extra_stk - = (offset, gregs, catAGraphs $ map mkMiddle nodes) - where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk - --- Return the number of bytes used for copying arguments, as well as the --- instructions to copy the arguments. -copyIn :: DynFlags -> Convention -> Area - -> [CmmFormal] - -> [CmmFormal] - -> (ByteOff, [GlobalReg], [CmmNode O O]) -copyIn dflags conv area formals extra_stk - = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) - where - -- See Note [Width of parameters] - ci (reg, RegisterParam r@(VanillaReg {})) = - let local = CmmLocal reg - global = CmmReg (CmmGlobal r) - width = cmmRegWidth dflags local - expr - | width == wordWidth dflags = global - | width < wordWidth dflags = - CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global] - | otherwise = panic "Parameter width greater than word width" - - in CmmAssign local expr - - -- Non VanillaRegs - ci (reg, RegisterParam r) = - CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) - - ci (reg, StackParam off) - | isBitsType $ localRegType reg - , typeWidth (localRegType reg) < wordWidth dflags = - let - stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags)) - local = CmmLocal reg - width = cmmRegWidth dflags local - expr = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot] - in CmmAssign local expr - - | otherwise = - CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) - where ty = localRegType reg - - init_offset = widthInBytes (wordWidth dflags) -- infotable - - (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk - - (stk_size, args) = assignArgumentsPos dflags stk_off conv - localRegType formals - --- Factoring out the common parts of the copyout functions yielded something --- more complicated: - -data Transfer = Call | JumpRet | Jump | Ret deriving Eq - -copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr] - -> UpdFrameOffset - -> [CmmExpr] -- extra stack args - -> (Int, [GlobalReg], CmmAGraph) - --- Generate code to move the actual parameters into the locations --- required by the calling convention. This includes a store for the --- return address. --- --- The argument layout function ignores the pointer to the info table, --- so we slot that in here. When copying-out to a young area, we set --- the info table for return and adjust the offsets of the other --- parameters. If this is a call instruction, we adjust the offsets --- of the other parameters. -copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff - = (stk_size, regs, graph) - where - (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) - - -- See Note [Width of parameters] - co (v, RegisterParam r@(VanillaReg {})) (rs, ms) = - let width = cmmExprWidth dflags v - value - | width == wordWidth dflags = v - | width < wordWidth dflags = - CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v] - | otherwise = panic "Parameter width greater than word width" - - in (r:rs, mkAssign (CmmGlobal r) value <*> ms) - - -- Non VanillaRegs - co (v, RegisterParam r) (rs, ms) = - (r:rs, mkAssign (CmmGlobal r) v <*> ms) - - -- See Note [Width of parameters] - co (v, StackParam off) (rs, ms) - = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) - - width v = cmmExprWidth dflags v - value v - | isBitsType $ cmmExprType dflags v - , width v < wordWidth dflags = - CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v] - | otherwise = v - - (setRA, init_offset) = - case area of - Young id -> -- Generate a store instruction for - -- the return address if making a call - case transfer of - Call -> - ([(CmmLit (CmmBlock id), StackParam init_offset)], - widthInBytes (wordWidth dflags)) - JumpRet -> - ([], - widthInBytes (wordWidth dflags)) - _other -> - ([], 0) - Old -> ([], updfr_off) - - (extra_stack_off, stack_params) = - assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff - - args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it - (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv - (cmmExprType dflags) actuals - - --- Note [Width of parameters] --- --- Consider passing a small (< word width) primitive like Int8# to a function. --- It's actually non-trivial to do this without extending/narrowing: --- * Global registers are considered to have native word width (i.e., 64-bits on --- x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a --- global register. --- * Same problem exists with LLVM IR. --- * Lowering gets harder since on x86-32 not every register exposes its lower --- 8 bits (e.g., for %eax we can use %al, but there isn't a corresponding --- 8-bit register for %edi). So we would either need to extend/narrow anyway, --- or complicate the calling convention. --- * Passing a small integer in a stack slot, which has native word width, --- requires extending to word width when writing to the stack and narrowing --- when reading off the stack (see #16258). --- So instead, we always extend every parameter smaller than native word width --- in copyOutOflow and then truncate it back to the expected width in copyIn. --- Note that we do this in cmm using MO_XX_Conv to avoid requiring --- zero-/sign-extending - it's up to a backend to handle this in a most --- efficient way (e.g., a simple register move or a smaller size store). --- This convention (of ignoring the upper bits) is different from some C ABIs, --- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters. --- --- There was some discussion about this on this PR: --- https://github.com/ghc-proposals/ghc-proposals/pull/74 - - -mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] - -> (Int, [GlobalReg], CmmAGraph) -mkCallEntry dflags conv formals extra_stk - = copyInOflow dflags conv Old formals extra_stk - -lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr] - -> UpdFrameOffset - -> (ByteOff -> [GlobalReg] -> CmmAGraph) - -> CmmAGraph -lastWithArgs dflags transfer area conv actuals updfr_off last = - lastWithArgsAndExtraStack dflags transfer area conv actuals - updfr_off noExtraStack last - -lastWithArgsAndExtraStack :: DynFlags - -> Transfer -> Area -> Convention -> [CmmExpr] - -> UpdFrameOffset -> [CmmExpr] - -> (ByteOff -> [GlobalReg] -> CmmAGraph) - -> CmmAGraph -lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off - extra_stack last = - copies <*> last outArgs regs - where - (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals - updfr_off extra_stack - - -noExtraStack :: [CmmExpr] -noExtraStack = [] - -toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff - -> ByteOff -> [GlobalReg] - -> CmmAGraph -toCall e cont updfr_off res_space arg_space regs = - mkLast $ CmmCall e cont regs arg_space res_space updfr_off diff --git a/cmm/PprC.hs b/cmm/PprC.hs deleted file mode 100644 --- a/cmm/PprC.hs +++ /dev/null @@ -1,1384 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-} - ------------------------------------------------------------------------------ --- --- Pretty-printing of Cmm as C, suitable for feeding gcc --- --- (c) The University of Glasgow 2004-2006 --- --- Print Cmm as real C, for -fvia-C --- --- See wiki:commentary/compiler/backends/ppr-c --- --- This is simpler than the old PprAbsC, because Cmm is "macro-expanded" --- relative to the old AbstractC, and many oddities/decorations have --- disappeared from the data type. --- --- This code generator is only supported in unregisterised mode. --- ------------------------------------------------------------------------------ - -module PprC ( - writeC - ) where - -#include "HsVersions.h" - --- Cmm stuff -import GhcPrelude - -import BlockId -import CLabel -import ForeignCall -import Cmm hiding (pprBBlock) -import PprCmm () -- For Outputable instances -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Graph -import CmmUtils -import CmmSwitch - --- Utils -import CPrim -import DynFlags -import FastString -import Outputable -import GHC.Platform -import UniqSet -import UniqFM -import Unique -import Util - --- The rest -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Control.Monad.ST -import Data.Bits -import Data.Char -import Data.List (intersperse) -import Data.Map (Map) -import Data.Word -import System.IO -import qualified Data.Map as Map -import Control.Monad (ap) -import qualified Data.Array.Unsafe as U ( castSTUArray ) -import Data.Array.ST - --- -------------------------------------------------------------------------- --- Top level - -writeC :: DynFlags -> Handle -> RawCmmGroup -> IO () -writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine) - --- -------------------------------------------------------------------------- --- Now do some real work --- --- for fun, we could call cmmToCmm over the tops... --- - -pprC :: RawCmmGroup -> SDoc -pprC tops = vcat $ intersperse blankLine $ map pprTop tops - --- --- top level procs --- -pprTop :: RawCmmDecl -> SDoc -pprTop (CmmProc infos clbl _in_live_regs graph) = - - (case mapLookup (g_entry graph) infos of - Nothing -> empty - Just (Statics info_clbl info_dat) -> - pprDataExterns info_dat $$ - pprWordArray info_is_in_rodata info_clbl info_dat) $$ - (vcat [ - blankLine, - extern_decls, - (if (externallyVisibleCLabel clbl) - then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, - nest 8 temp_decls, - vcat (map pprBBlock blocks), - rbrace ] - ) - where - -- info tables are always in .rodata - info_is_in_rodata = True - blocks = toBlockListEntryFirst graph - (temp_decls, extern_decls) = pprTempAndExternDecls blocks - - --- Chunks of static data. - --- We only handle (a) arrays of word-sized things and (b) strings. - -pprTop (CmmData section (Statics lbl [CmmString str])) = - pprExternDecl lbl $$ - hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, - text "[] = ", pprStringInCStyle str, semi - ] - -pprTop (CmmData section (Statics lbl [CmmUninitialised size])) = - pprExternDecl lbl $$ - hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, - brackets (int size), semi - ] - -pprTop (CmmData section (Statics lbl lits)) = - pprDataExterns lits $$ - pprWordArray (isSecConstant section) lbl lits - -isSecConstant :: Section -> Bool -isSecConstant section = case sectionProtection section of - ReadOnlySection -> True - WriteProtectedSection -> True - _ -> False --- -------------------------------------------------------------------------- --- BasicBlocks are self-contained entities: they always end in a jump. --- --- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn --- as many jumps as possible into fall throughs. --- - -pprBBlock :: CmmBlock -> SDoc -pprBBlock block = - nest 4 (pprBlockId (entryLabel block) <> colon) $$ - nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last) - where - (_, nodes, last) = blockSplit block - --- -------------------------------------------------------------------------- --- Info tables. Just arrays of words. --- See codeGen/ClosureInfo, and nativeGen/PprMach - -pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc -pprWordArray is_ro lbl ds - = sdocWithDynFlags $ \dflags -> - -- TODO: align closures only - pprExternDecl lbl $$ - hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord" - , space, ppr lbl, text "[]" - -- See Note [StgWord alignment] - , pprAlignment (wordWidth dflags) - , text "= {" ] - $$ nest 8 (commafy (pprStatics dflags ds)) - $$ text "};" - -pprAlignment :: Width -> SDoc -pprAlignment words = - text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))" - --- Note [StgWord alignment] --- C codegen builds static closures as StgWord C arrays (pprWordArray). --- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume --- pointers to 'StgClosure' are aligned at pointer size boundary: --- 4 byte boundary on 32 systems --- and 8 bytes on 64-bit systems --- see TAG_MASK and TAG_BITS definition and usage. --- --- It's a reasonable assumption also known as natural alignment. --- Although some architectures have different alignment rules. --- One of known exceptions is m68k (#11395, comment:16) where: --- __alignof__(StgWord) == 2, sizeof(StgWord) == 4 --- --- Thus we explicitly increase alignment by using --- __attribute__((aligned(4))) --- declaration. - --- --- has to be static, if it isn't globally visible --- -pprLocalness :: CLabel -> SDoc -pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static " - | otherwise = empty - -pprConstness :: Bool -> SDoc -pprConstness is_ro | is_ro = text "const " - | otherwise = empty - --- -------------------------------------------------------------------------- --- Statements. --- - -pprStmt :: CmmNode e x -> SDoc - -pprStmt stmt = - sdocWithDynFlags $ \dflags -> - case stmt of - CmmEntry{} -> empty - CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/") - -- XXX if the string contains "*/", we need to fix it - -- XXX we probably want to emit these comments when - -- some debugging option is on. They can get quite - -- large. - - CmmTick _ -> empty - CmmUnwind{} -> empty - - CmmAssign dest src -> pprAssign dflags dest src - - CmmStore dest src - | typeWidth rep == W64 && wordWidth dflags /= W64 - -> (if isFloatType rep then text "ASSIGN_DBL" - else ptext (sLit ("ASSIGN_Word64"))) <> - parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi - - | otherwise - -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] - where - rep = cmmExprType dflags src - - CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> - fnCall - where - (res_hints, arg_hints) = foreignTargetHints target - hresults = zip results res_hints - hargs = zip args arg_hints - - ForeignConvention cconv _ _ ret _ _ = conv - - cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) - - -- See wiki:commentary/compiler/backends/ppr-c#prototypes - fnCall = - case fn of - CmmLit (CmmLabel lbl) - | StdCallConv <- cconv -> - pprCall (ppr lbl) cconv hresults hargs - -- stdcall functions must be declared with - -- a function type, otherwise the C compiler - -- doesn't add the @n suffix to the label. We - -- can't add the @n suffix ourselves, because - -- it isn't valid C. - | CmmNeverReturns <- ret -> - pprCall cast_fn cconv hresults hargs <> semi - | not (isMathFun lbl) -> - pprForeignCall (ppr lbl) cconv hresults hargs - _ -> - pprCall cast_fn cconv hresults hargs <> semi - -- for a dynamic call, no declaration is necessary. - - CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty - CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty - - CmmUnsafeForeignCall target@(PrimTarget op) results args -> - fn_call - where - cconv = CCallConv - fn = pprCallishMachOp_for_C op - - (res_hints, arg_hints) = foreignTargetHints target - hresults = zip results res_hints - hargs = zip args arg_hints - - fn_call - -- The mem primops carry an extra alignment arg. - -- We could maybe emit an alignment directive using this info. - -- We also need to cast mem primops to prevent conflicts with GCC - -- builtins (see bug #5967). - | Just _align <- machOpMemcpyishAlign op - = (text ";EFF_(" <> fn <> char ')' <> semi) $$ - pprForeignCall fn cconv hresults hargs - | otherwise - = pprCall fn cconv hresults hargs - - CmmBranch ident -> pprBranch ident - CmmCondBranch expr yes no _ -> pprCondBranch expr yes no - CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi - CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> - pprSwitch dflags arg ids - - _other -> pprPanic "PprC.pprStmt" (ppr stmt) - -type Hinted a = (a, ForeignHint) - -pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] - -> SDoc -pprForeignCall fn cconv results args = fn_call - where - fn_call = braces ( - pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi - $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi - $$ pprCall (text "ghcFunPtr") cconv results args <> semi - ) - cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) - -pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprCFunType ppr_fn cconv ress args - = sdocWithDynFlags $ \dflags -> - let res_type [] = text "void" - res_type [(one, hint)] = machRepHintCType (localRegType one) hint - res_type _ = panic "pprCFunType: only void or 1 return value supported" - - arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint - in res_type ress <+> - parens (ccallConvAttribute cconv <> ppr_fn) <> - parens (commafy (map arg_type args)) - --- --------------------------------------------------------------------- --- unconditional branches -pprBranch :: BlockId -> SDoc -pprBranch ident = text "goto" <+> pprBlockId ident <> semi - - --- --------------------------------------------------------------------- --- conditional branches to local labels -pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc -pprCondBranch expr yes no - = hsep [ text "if" , parens(pprExpr expr) , - text "goto", pprBlockId yes <> semi, - text "else goto", pprBlockId no <> semi ] - --- --------------------------------------------------------------------- --- a local table branch --- --- we find the fall-through cases --- -pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc -pprSwitch dflags e ids - = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace) - 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace - where - (pairs, mbdef) = switchTargetsFallThrough ids - - -- fall through case - caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix - where - do_fallthrough ix = - hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , - text "/* fall through */" ] - - final_branch ix = - hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , - text "goto" , (pprBlockId ident) <> semi ] - - caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" - - def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi - | otherwise = empty - --- --------------------------------------------------------------------- --- Expressions. --- - --- C Types: the invariant is that the C expression generated by --- --- pprExpr e --- --- has a type in C which is also given by --- --- machRepCType (cmmExprType e) --- --- (similar invariants apply to the rest of the pretty printer). - -pprExpr :: CmmExpr -> SDoc -pprExpr e = case e of - CmmLit lit -> pprLit lit - - - CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty - CmmReg reg -> pprCastReg reg - CmmRegOff reg 0 -> pprCastReg reg - - -- CmmRegOff is an alias of MO_Add - CmmRegOff reg i -> sdocWithDynFlags $ \dflags -> - pprCastReg reg <> char '+' <> - pprHexVal (fromIntegral i) (wordWidth dflags) - - CmmMachOp mop args -> pprMachOpApp mop args - - CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" - - -pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc -pprLoad dflags e ty - | width == W64, wordWidth dflags /= W64 - = (if isFloatType ty then text "PK_DBL" - else text "PK_Word64") - <> parens (mkP_ <> pprExpr1 e) - - | otherwise - = case e of - CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) - -> char '*' <> pprAsPtrReg r - - CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) - -> char '*' <> pprAsPtrReg r - - CmmRegOff r off | isPtrReg r && width == wordWidth dflags - , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty) - -- ToDo: check that the offset is a word multiple? - -- (For tagging to work, I had to avoid unaligned loads. --ARY) - -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags)) - - _other -> cLoad e ty - where - width = typeWidth ty - -pprExpr1 :: CmmExpr -> SDoc -pprExpr1 (CmmLit lit) = pprLit1 lit -pprExpr1 e@(CmmReg _reg) = pprExpr e -pprExpr1 other = parens (pprExpr other) - --- -------------------------------------------------------------------------- --- MachOp applications - -pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc - -pprMachOpApp op args - | isMulMayOfloOp op - = text "mulIntMayOflo" <> parens (commafy (map pprExpr args)) - where isMulMayOfloOp (MO_U_MulMayOflo _) = True - isMulMayOfloOp (MO_S_MulMayOflo _) = True - isMulMayOfloOp _ = False - -pprMachOpApp mop args - | Just ty <- machOpNeedsCast mop - = ty <> parens (pprMachOpApp' mop args) - | otherwise - = pprMachOpApp' mop args - --- Comparisons in C have type 'int', but we want type W_ (this is what --- resultRepOfMachOp says). The other C operations inherit their type --- from their operands, so no casting is required. -machOpNeedsCast :: MachOp -> Maybe SDoc -machOpNeedsCast mop - | isComparisonMachOp mop = Just mkW_ - | otherwise = Nothing - -pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc -pprMachOpApp' mop args - = case args of - -- dyadic - [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y - - -- unary - [x] -> pprMachOp_for_C mop <> parens (pprArg x) - - _ -> panic "PprC.pprMachOp : machop with wrong number of args" - - where - -- Cast needed for signed integer ops - pprArg e | signedOp mop = sdocWithDynFlags $ \dflags -> - cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e - | needsFCasts mop = sdocWithDynFlags $ \dflags -> - cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e - | otherwise = pprExpr1 e - needsFCasts (MO_F_Eq _) = False - needsFCasts (MO_F_Ne _) = False - needsFCasts (MO_F_Neg _) = True - needsFCasts (MO_F_Quot _) = True - needsFCasts mop = floatComparison mop - --- -------------------------------------------------------------------------- --- Literals - -pprLit :: CmmLit -> SDoc -pprLit lit = case lit of - CmmInt i rep -> pprHexVal i rep - - CmmFloat f w -> parens (machRep_F_CType w) <> str - where d = fromRational f :: Double - str | isInfinite d && d < 0 = text "-INFINITY" - | isInfinite d = text "INFINITY" - | isNaN d = text "NAN" - | otherwise = text (show d) - -- these constants come from - -- see #1861 - - CmmVec {} -> panic "PprC printing vector literal" - - CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid) - CmmHighStackMark -> panic "PprC printing high stack mark" - CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl - CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i - CmmLabelDiffOff clbl1 _ i _ -- non-word widths not supported via C - -- WARNING: - -- * the lit must occur in the info table clbl2 - -- * clbl1 must be an SRT, a slow entry point or a large bitmap - -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i - - where - pprCLabelAddr lbl = char '&' <> ppr lbl - -pprLit1 :: CmmLit -> SDoc -pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit) -pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit) -pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit) -pprLit1 other = pprLit other - --- --------------------------------------------------------------------------- --- Static data - -pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] -pprStatics _ [] = [] -pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest) - -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding - | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' - -- adjacent floats aren't padded but combined into a single word - | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest - = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest' - | wORD_SIZE dflags == 4 - = pprLit1 (floatToWord dflags f) : pprStatics dflags rest - | otherwise - = pprPanic "pprStatics: float" (vcat (map ppr' rest)) - where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags -> - ppr (cmmLitType dflags l) - ppr' _other = text "bad static!" -pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) - = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest - -pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) - | wordWidth dflags == W32 - = if wORDS_BIGENDIAN dflags - then pprStatics dflags (CmmStaticLit (CmmInt q W32) : - CmmStaticLit (CmmInt r W32) : rest) - else pprStatics dflags (CmmStaticLit (CmmInt r W32) : - CmmStaticLit (CmmInt q W32) : rest) - where r = i .&. 0xffffffff - q = i `shiftR` 32 -pprStatics dflags (CmmStaticLit (CmmInt a W32) : - CmmStaticLit (CmmInt b W32) : rest) - | wordWidth dflags == W64 - = if wORDS_BIGENDIAN dflags - then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : - rest) - else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : - rest) -pprStatics dflags (CmmStaticLit (CmmInt a W16) : - CmmStaticLit (CmmInt b W16) : rest) - | wordWidth dflags == W32 - = if wORDS_BIGENDIAN dflags - then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : - rest) - else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : - rest) -pprStatics dflags (CmmStaticLit (CmmInt _ w) : _) - | w /= wordWidth dflags - = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w) -pprStatics dflags (CmmStaticLit lit : rest) - = pprLit1 lit : pprStatics dflags rest -pprStatics _ (other : _) - = pprPanic "pprStatics: other" (pprStatic other) - -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of - - CmmStaticLit lit -> nest 4 (pprLit lit) - CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) - - -- these should be inlined, like the old .hc - CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s')) - - --- --------------------------------------------------------------------------- --- Block Ids - -pprBlockId :: BlockId -> SDoc -pprBlockId b = char '_' <> ppr (getUnique b) - --- -------------------------------------------------------------------------- --- Print a MachOp in a way suitable for emitting via C. --- - -pprMachOp_for_C :: MachOp -> SDoc - -pprMachOp_for_C mop = case mop of - - -- Integer operations - MO_Add _ -> char '+' - MO_Sub _ -> char '-' - MO_Eq _ -> text "==" - MO_Ne _ -> text "!=" - MO_Mul _ -> char '*' - - MO_S_Quot _ -> char '/' - MO_S_Rem _ -> char '%' - MO_S_Neg _ -> char '-' - - MO_U_Quot _ -> char '/' - MO_U_Rem _ -> char '%' - - -- & Floating-point operations - MO_F_Add _ -> char '+' - MO_F_Sub _ -> char '-' - MO_F_Neg _ -> char '-' - MO_F_Mul _ -> char '*' - MO_F_Quot _ -> char '/' - - -- Signed comparisons - MO_S_Ge _ -> text ">=" - MO_S_Le _ -> text "<=" - MO_S_Gt _ -> char '>' - MO_S_Lt _ -> char '<' - - -- & Unsigned comparisons - MO_U_Ge _ -> text ">=" - MO_U_Le _ -> text "<=" - MO_U_Gt _ -> char '>' - MO_U_Lt _ -> char '<' - - -- & Floating-point comparisons - MO_F_Eq _ -> text "==" - MO_F_Ne _ -> text "!=" - MO_F_Ge _ -> text ">=" - MO_F_Le _ -> text "<=" - MO_F_Gt _ -> char '>' - MO_F_Lt _ -> char '<' - - -- Bitwise operations. Not all of these may be supported at all - -- sizes, and only integral MachReps are valid. - MO_And _ -> char '&' - MO_Or _ -> char '|' - MO_Xor _ -> char '^' - MO_Not _ -> char '~' - MO_Shl _ -> text "<<" - MO_U_Shr _ -> text ">>" -- unsigned shift right - MO_S_Shr _ -> text ">>" -- signed shift right - --- Conversions. Some of these will be NOPs, but never those that convert --- between ints and floats. --- Floating-point conversions use the signed variant. --- We won't know to generate (void*) casts here, but maybe from --- context elsewhere - --- noop casts - MO_UU_Conv from to | from == to -> empty - MO_UU_Conv _from to -> parens (machRep_U_CType to) - - MO_SS_Conv from to | from == to -> empty - MO_SS_Conv _from to -> parens (machRep_S_CType to) - - MO_XX_Conv from to | from == to -> empty - MO_XX_Conv _from to -> parens (machRep_U_CType to) - - MO_FF_Conv from to | from == to -> empty - MO_FF_Conv _from to -> parens (machRep_F_CType to) - - MO_SF_Conv _from to -> parens (machRep_F_CType to) - MO_FS_Conv _from to -> parens (machRep_S_CType to) - - MO_S_MulMayOflo _ -> pprTrace "offending mop:" - (text "MO_S_MulMayOflo") - (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" - ++ " should have been handled earlier!") - MO_U_MulMayOflo _ -> pprTrace "offending mop:" - (text "MO_U_MulMayOflo") - (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo" - ++ " should have been handled earlier!") - - MO_V_Insert {} -> pprTrace "offending mop:" - (text "MO_V_Insert") - (panic $ "PprC.pprMachOp_for_C: MO_V_Insert" - ++ " should have been handled earlier!") - MO_V_Extract {} -> pprTrace "offending mop:" - (text "MO_V_Extract") - (panic $ "PprC.pprMachOp_for_C: MO_V_Extract" - ++ " should have been handled earlier!") - - MO_V_Add {} -> pprTrace "offending mop:" - (text "MO_V_Add") - (panic $ "PprC.pprMachOp_for_C: MO_V_Add" - ++ " should have been handled earlier!") - MO_V_Sub {} -> pprTrace "offending mop:" - (text "MO_V_Sub") - (panic $ "PprC.pprMachOp_for_C: MO_V_Sub" - ++ " should have been handled earlier!") - MO_V_Mul {} -> pprTrace "offending mop:" - (text "MO_V_Mul") - (panic $ "PprC.pprMachOp_for_C: MO_V_Mul" - ++ " should have been handled earlier!") - - MO_VS_Quot {} -> pprTrace "offending mop:" - (text "MO_VS_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot" - ++ " should have been handled earlier!") - MO_VS_Rem {} -> pprTrace "offending mop:" - (text "MO_VS_Rem") - (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem" - ++ " should have been handled earlier!") - MO_VS_Neg {} -> pprTrace "offending mop:" - (text "MO_VS_Neg") - (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg" - ++ " should have been handled earlier!") - - MO_VU_Quot {} -> pprTrace "offending mop:" - (text "MO_VU_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot" - ++ " should have been handled earlier!") - MO_VU_Rem {} -> pprTrace "offending mop:" - (text "MO_VU_Rem") - (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" - ++ " should have been handled earlier!") - - MO_VF_Insert {} -> pprTrace "offending mop:" - (text "MO_VF_Insert") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" - ++ " should have been handled earlier!") - MO_VF_Extract {} -> pprTrace "offending mop:" - (text "MO_VF_Extract") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract" - ++ " should have been handled earlier!") - - MO_VF_Add {} -> pprTrace "offending mop:" - (text "MO_VF_Add") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Add" - ++ " should have been handled earlier!") - MO_VF_Sub {} -> pprTrace "offending mop:" - (text "MO_VF_Sub") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub" - ++ " should have been handled earlier!") - MO_VF_Neg {} -> pprTrace "offending mop:" - (text "MO_VF_Neg") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg" - ++ " should have been handled earlier!") - MO_VF_Mul {} -> pprTrace "offending mop:" - (text "MO_VF_Mul") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul" - ++ " should have been handled earlier!") - MO_VF_Quot {} -> pprTrace "offending mop:" - (text "MO_VF_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot" - ++ " should have been handled earlier!") - - MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend" - -signedOp :: MachOp -> Bool -- Argument type(s) are signed ints -signedOp (MO_S_Quot _) = True -signedOp (MO_S_Rem _) = True -signedOp (MO_S_Neg _) = True -signedOp (MO_S_Ge _) = True -signedOp (MO_S_Le _) = True -signedOp (MO_S_Gt _) = True -signedOp (MO_S_Lt _) = True -signedOp (MO_S_Shr _) = True -signedOp (MO_SS_Conv _ _) = True -signedOp (MO_SF_Conv _ _) = True -signedOp _ = False - -floatComparison :: MachOp -> Bool -- comparison between float args -floatComparison (MO_F_Eq _) = True -floatComparison (MO_F_Ne _) = True -floatComparison (MO_F_Ge _) = True -floatComparison (MO_F_Le _) = True -floatComparison (MO_F_Gt _) = True -floatComparison (MO_F_Lt _) = True -floatComparison _ = False - --- --------------------------------------------------------------------- --- tend to be implemented by foreign calls - -pprCallishMachOp_for_C :: CallishMachOp -> SDoc - -pprCallishMachOp_for_C mop - = case mop of - MO_F64_Pwr -> text "pow" - MO_F64_Sin -> text "sin" - MO_F64_Cos -> text "cos" - MO_F64_Tan -> text "tan" - MO_F64_Sinh -> text "sinh" - MO_F64_Cosh -> text "cosh" - MO_F64_Tanh -> text "tanh" - MO_F64_Asin -> text "asin" - MO_F64_Acos -> text "acos" - MO_F64_Atanh -> text "atanh" - MO_F64_Asinh -> text "asinh" - MO_F64_Acosh -> text "acosh" - MO_F64_Atan -> text "atan" - MO_F64_Log -> text "log" - MO_F64_Log1P -> text "log1p" - MO_F64_Exp -> text "exp" - MO_F64_ExpM1 -> text "expm1" - MO_F64_Sqrt -> text "sqrt" - MO_F64_Fabs -> text "fabs" - MO_F32_Pwr -> text "powf" - MO_F32_Sin -> text "sinf" - MO_F32_Cos -> text "cosf" - MO_F32_Tan -> text "tanf" - MO_F32_Sinh -> text "sinhf" - MO_F32_Cosh -> text "coshf" - MO_F32_Tanh -> text "tanhf" - MO_F32_Asin -> text "asinf" - MO_F32_Acos -> text "acosf" - MO_F32_Atan -> text "atanf" - MO_F32_Asinh -> text "asinhf" - MO_F32_Acosh -> text "acoshf" - MO_F32_Atanh -> text "atanhf" - MO_F32_Log -> text "logf" - MO_F32_Log1P -> text "log1pf" - MO_F32_Exp -> text "expf" - MO_F32_ExpM1 -> text "expm1f" - MO_F32_Sqrt -> text "sqrtf" - MO_F32_Fabs -> text "fabsf" - MO_ReadBarrier -> text "load_load_barrier" - MO_WriteBarrier -> text "write_barrier" - MO_Memcpy _ -> text "memcpy" - MO_Memset _ -> text "memset" - MO_Memmove _ -> text "memmove" - MO_Memcmp _ -> text "memcmp" - (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) - (MO_BRev w) -> ptext (sLit $ bRevLabel w) - (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) - (MO_Pext w) -> ptext (sLit $ pextLabel w) - (MO_Pdep w) -> ptext (sLit $ pdepLabel w) - (MO_Clz w) -> ptext (sLit $ clzLabel w) - (MO_Ctz w) -> ptext (sLit $ ctzLabel w) - (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) - (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) - (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) - (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) - (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddWordC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _ ) -> unsupported - --- we could support prefetch via "__builtin_prefetch" - --- Not adding it for now - where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop - ++ " not supported!") - --- --------------------------------------------------------------------- --- Useful #defines --- - -mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc - -mkJMP_ i = text "JMP_" <> parens i -mkFN_ i = text "FN_" <> parens i -- externally visible function -mkIF_ i = text "IF_" <> parens i -- locally visible - --- from includes/Stg.h --- -mkC_,mkW_,mkP_ :: SDoc - -mkC_ = text "(C_)" -- StgChar -mkW_ = text "(W_)" -- StgWord -mkP_ = text "(P_)" -- StgWord* - --- --------------------------------------------------------------------- --- --- Assignments --- --- Generating assignments is what we're all about, here --- -pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc - --- dest is a reg, rhs is a reg -pprAssign _ r1 (CmmReg r2) - | isPtrReg r1 && isPtrReg r2 - = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] - --- dest is a reg, rhs is a CmmRegOff -pprAssign dflags r1 (CmmRegOff r2 off) - | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0) - = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] - where - off1 = off `shiftR` wordShift dflags - - (op,off') | off >= 0 = (char '+', off1) - | otherwise = (char '-', -off1) - --- dest is a reg, rhs is anything. --- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting --- the lvalue elicits a warning from new GCC versions (3.4+). -pprAssign _ r1 r2 - | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2) - | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) - | otherwise = mkAssign (pprExpr r2) - where mkAssign x = if r1 == CmmGlobal BaseReg - then text "ASSIGN_BaseReg" <> parens x <> semi - else pprReg r1 <> text " = " <> x <> semi - --- --------------------------------------------------------------------- --- Registers - -pprCastReg :: CmmReg -> SDoc -pprCastReg reg - | isStrangeTypeReg reg = mkW_ <> pprReg reg - | otherwise = pprReg reg - --- True if (pprReg reg) will give an expression with type StgPtr. We --- need to take care with pointer arithmetic on registers with type --- StgPtr. -isFixedPtrReg :: CmmReg -> Bool -isFixedPtrReg (CmmLocal _) = False -isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r - --- True if (pprAsPtrReg reg) will give an expression with type StgPtr --- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. --- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; --- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. -isPtrReg :: CmmReg -> Bool -isPtrReg (CmmLocal _) = False -isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg - --- True if this global reg has type StgPtr -isFixedPtrGlobalReg :: GlobalReg -> Bool -isFixedPtrGlobalReg Sp = True -isFixedPtrGlobalReg Hp = True -isFixedPtrGlobalReg HpLim = True -isFixedPtrGlobalReg SpLim = True -isFixedPtrGlobalReg _ = False - --- True if in C this register doesn't have the type given by --- (machRepCType (cmmRegType reg)), so it has to be cast. -isStrangeTypeReg :: CmmReg -> Bool -isStrangeTypeReg (CmmLocal _) = False -isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g - -isStrangeTypeGlobal :: GlobalReg -> Bool -isStrangeTypeGlobal CCCS = True -isStrangeTypeGlobal CurrentTSO = True -isStrangeTypeGlobal CurrentNursery = True -isStrangeTypeGlobal BaseReg = True -isStrangeTypeGlobal r = isFixedPtrGlobalReg r - -strangeRegType :: CmmReg -> Maybe SDoc -strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *") -strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *") -strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *") -strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *") -strangeRegType _ = Nothing - --- pprReg just prints the register name. --- -pprReg :: CmmReg -> SDoc -pprReg r = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - -pprAsPtrReg :: CmmReg -> SDoc -pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) - = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p" -pprAsPtrReg other_reg = pprReg other_reg - -pprGlobalReg :: GlobalReg -> SDoc -pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n <> text ".w" - -- pprGlobalReg prints a VanillaReg as a .w regardless - -- Example: R1.w = R1.w & (-0x8UL); - -- JMP_(*R1.p); - FloatReg n -> char 'F' <> int n - DoubleReg n -> char 'D' <> int n - LongReg n -> char 'L' <> int n - Sp -> text "Sp" - SpLim -> text "SpLim" - Hp -> text "Hp" - HpLim -> text "HpLim" - CCCS -> text "CCCS" - CurrentTSO -> text "CurrentTSO" - CurrentNursery -> text "CurrentNursery" - HpAlloc -> text "HpAlloc" - BaseReg -> text "BaseReg" - EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" - GCEnter1 -> text "stg_gc_enter_1" - GCFun -> text "stg_gc_fun" - other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other - -pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq - --- ----------------------------------------------------------------------------- --- Foreign Calls - -pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprCall ppr_fn cconv results args - | not (is_cishCC cconv) - = panic $ "pprCall: unknown calling convention" - - | otherwise - = - ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi - where - ppr_assign [] rhs = rhs - ppr_assign [(one,hint)] rhs - = pprLocalReg one <> text " = " - <> pprUnHint hint (localRegType one) <> rhs - ppr_assign _other _rhs = panic "pprCall: multiple results" - - pprArg (expr, AddrHint) - = cCast (text "void *") expr - -- see comment by machRepHintCType below - pprArg (expr, SignedHint) - = sdocWithDynFlags $ \dflags -> - cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr - pprArg (expr, _other) - = pprExpr expr - - pprUnHint AddrHint rep = parens (machRepCType rep) - pprUnHint SignedHint rep = parens (machRepCType rep) - pprUnHint _ _ = empty - --- Currently we only have these two calling conventions, but this might --- change in the future... -is_cishCC :: CCallConv -> Bool -is_cishCC CCallConv = True -is_cishCC CApiConv = True -is_cishCC StdCallConv = True -is_cishCC PrimCallConv = False -is_cishCC JavaScriptCallConv = False - --- --------------------------------------------------------------------- --- Find and print local and external declarations for a list of --- Cmm statements. --- -pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) -pprTempAndExternDecls stmts - = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl), - vcat (map pprExternDecl (Map.keys lbls))) - where (temps, lbls) = runTE (mapM_ te_BB stmts) - -pprDataExterns :: [CmmStatic] -> SDoc -pprDataExterns statics - = vcat (map pprExternDecl (Map.keys lbls)) - where (_, lbls) = runTE (mapM_ te_Static statics) - -pprTempDecl :: LocalReg -> SDoc -pprTempDecl l@(LocalReg _ rep) - = hcat [ machRepCType rep, space, pprLocalReg l, semi ] - -pprExternDecl :: CLabel -> SDoc -pprExternDecl lbl - -- do not print anything for "known external" things - | not (needsCDecl lbl) = empty - | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz - | otherwise = - hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");" - -- occasionally useful to see label type - -- , text "/* ", pprDebugCLabel lbl, text " */" - ] - where - label_type lbl | isBytesLabel lbl = text "B_" - | isForeignLabel lbl && isCFunctionLabel lbl - = text "FF_" - | isCFunctionLabel lbl = text "F_" - | isStaticClosureLabel lbl = text "C_" - -- generic .rodata labels - | isSomeRODataLabel lbl = text "RO_" - -- generic .data labels (common case) - | otherwise = text "RW_" - - visibility - | externallyVisibleCLabel lbl = char 'E' - | otherwise = char 'I' - - -- If the label we want to refer to is a stdcall function (on Windows) then - -- we must generate an appropriate prototype for it, so that the C compiler will - -- add the @n suffix to the label (#2276) - stdcall_decl sz = sdocWithDynFlags $ \dflags -> - text "extern __attribute__((stdcall)) void " <> ppr lbl - <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags)))) - <> semi - -type TEState = (UniqSet LocalReg, Map CLabel ()) -newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor) - -instance Applicative TE where - pure a = TE $ \s -> (a, s) - (<*>) = ap - -instance Monad TE where - TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s' - -te_lbl :: CLabel -> TE () -te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) - -te_temp :: LocalReg -> TE () -te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) - -runTE :: TE () -> TEState -runTE (TE m) = snd (m (emptyUniqSet, Map.empty)) - -te_Static :: CmmStatic -> TE () -te_Static (CmmStaticLit lit) = te_Lit lit -te_Static _ = return () - -te_BB :: CmmBlock -> TE () -te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last - where (_, mid, last) = blockSplit block - -te_Lit :: CmmLit -> TE () -te_Lit (CmmLabel l) = te_lbl l -te_Lit (CmmLabelOff l _) = te_lbl l -te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1 -te_Lit _ = return () - -te_Stmt :: CmmNode e x -> TE () -te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e -te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmUnsafeForeignCall target rs es) - = do te_Target target - mapM_ te_temp rs - mapM_ te_Expr es -te_Stmt (CmmCondBranch e _ _ _) = te_Expr e -te_Stmt (CmmSwitch e _) = te_Expr e -te_Stmt (CmmCall { cml_target = e }) = te_Expr e -te_Stmt _ = return () - -te_Target :: ForeignTarget -> TE () -te_Target (ForeignTarget e _) = te_Expr e -te_Target (PrimTarget{}) = return () - -te_Expr :: CmmExpr -> TE () -te_Expr (CmmLit lit) = te_Lit lit -te_Expr (CmmLoad e _) = te_Expr e -te_Expr (CmmReg r) = te_Reg r -te_Expr (CmmMachOp _ es) = mapM_ te_Expr es -te_Expr (CmmRegOff r _) = te_Reg r -te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!" - -te_Reg :: CmmReg -> TE () -te_Reg (CmmLocal l) = te_temp l -te_Reg _ = return () - - --- --------------------------------------------------------------------- --- C types for MachReps - -cCast :: SDoc -> CmmExpr -> SDoc -cCast ty expr = parens ty <> pprExpr1 expr - -cLoad :: CmmExpr -> CmmType -> SDoc -cLoad expr rep - = sdocWithPlatform $ \platform -> - if bewareLoadStoreAlignment (platformArch platform) - then let decl = machRepCType rep <+> text "x" <> semi - struct = text "struct" <+> braces (decl) - packed_attr = text "__attribute__((packed))" - cast = parens (struct <+> packed_attr <> char '*') - in parens (cast <+> pprExpr1 expr) <> text "->x" - else char '*' <> parens (cCast (machRepPtrCType rep) expr) - where -- On these platforms, unaligned loads are known to cause problems - bewareLoadStoreAlignment ArchAlpha = True - bewareLoadStoreAlignment ArchMipseb = True - bewareLoadStoreAlignment ArchMipsel = True - bewareLoadStoreAlignment (ArchARM {}) = True - bewareLoadStoreAlignment ArchAArch64 = True - bewareLoadStoreAlignment ArchSPARC = True - bewareLoadStoreAlignment ArchSPARC64 = True - -- Pessimistically assume that they will also cause problems - -- on unknown arches - bewareLoadStoreAlignment ArchUnknown = True - bewareLoadStoreAlignment _ = False - -isCmmWordType :: DynFlags -> CmmType -> Bool --- True of GcPtrReg/NonGcReg of native word size -isCmmWordType dflags ty = not (isFloatType ty) - && typeWidth ty == wordWidth dflags - --- This is for finding the types of foreign call arguments. For a pointer --- argument, we always cast the argument to (void *), to avoid warnings from --- the C compiler. -machRepHintCType :: CmmType -> ForeignHint -> SDoc -machRepHintCType _ AddrHint = text "void *" -machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) -machRepHintCType rep _other = machRepCType rep - -machRepPtrCType :: CmmType -> SDoc -machRepPtrCType r - = sdocWithDynFlags $ \dflags -> - if isCmmWordType dflags r then text "P_" - else machRepCType r <> char '*' - -machRepCType :: CmmType -> SDoc -machRepCType ty | isFloatType ty = machRep_F_CType w - | otherwise = machRep_U_CType w - where - w = typeWidth ty - -machRep_F_CType :: Width -> SDoc -machRep_F_CType W32 = text "StgFloat" -- ToDo: correct? -machRep_F_CType W64 = text "StgDouble" -machRep_F_CType _ = panic "machRep_F_CType" - -machRep_U_CType :: Width -> SDoc -machRep_U_CType w - = sdocWithDynFlags $ \dflags -> - case w of - _ | w == wordWidth dflags -> text "W_" - W8 -> text "StgWord8" - W16 -> text "StgWord16" - W32 -> text "StgWord32" - W64 -> text "StgWord64" - _ -> panic "machRep_U_CType" - -machRep_S_CType :: Width -> SDoc -machRep_S_CType w - = sdocWithDynFlags $ \dflags -> - case w of - _ | w == wordWidth dflags -> text "I_" - W8 -> text "StgInt8" - W16 -> text "StgInt16" - W32 -> text "StgInt32" - W64 -> text "StgInt64" - _ -> panic "machRep_S_CType" - - --- --------------------------------------------------------------------- --- print strings as valid C strings - -pprStringInCStyle :: ByteString -> SDoc -pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s))) - --- --------------------------------------------------------------------------- --- Initialising static objects with floating-point numbers. We can't --- just emit the floating point number, because C will cast it to an int --- by rounding it. We want the actual bit-representation of the float. --- --- Consider a concrete C example: --- double d = 2.5e-10; --- float f = 2.5e-10f; --- --- int * i2 = &d; printf ("i2: %08X %08X\n", i2[0], i2[1]); --- long long * l = &d; printf (" l: %016llX\n", l[0]); --- int * i = &f; printf (" i: %08X\n", i[0]); --- Result on 64-bit LE (x86_64): --- i2: E826D695 3DF12E0B --- l: 3DF12E0BE826D695 --- i: 2F89705F --- Result on 32-bit BE (m68k): --- i2: 3DF12E0B E826D695 --- l: 3DF12E0BE826D695 --- i: 2F89705F --- --- The trick here is to notice that binary representation does not --- change much: only Word32 values get swapped on LE hosts / targets. - --- This is a hack to turn the floating point numbers into ints that we --- can safely initialise to static locations. - -castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32) -castFloatToWord32Array = U.castSTUArray - -castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64) -castDoubleToWord64Array = U.castSTUArray - -floatToWord :: DynFlags -> Rational -> CmmLit -floatToWord dflags r - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 (fromRational r) - arr' <- castFloatToWord32Array arr - w32 <- readArray arr' 0 - return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags)) - ) - where wo | wordWidth dflags == W64 - , wORDS_BIGENDIAN dflags = 32 - | otherwise = 0 - -floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit -floatPairToWord dflags r1 r2 - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 (fromRational r1) - writeArray arr 1 (fromRational r2) - arr' <- castFloatToWord32Array arr - w32_1 <- readArray arr' 0 - w32_2 <- readArray arr' 1 - return (pprWord32Pair w32_1 w32_2) - ) - where pprWord32Pair w32_1 w32_2 - | wORDS_BIGENDIAN dflags = - CmmInt ((shiftL i1 32) .|. i2) W64 - | otherwise = - CmmInt ((shiftL i2 32) .|. i1) W64 - where i1 = toInteger w32_1 - i2 = toInteger w32_2 - -doubleToWords :: DynFlags -> Rational -> [CmmLit] -doubleToWords dflags r - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 (fromRational r) - arr' <- castDoubleToWord64Array arr - w64 <- readArray arr' 0 - return (pprWord64 w64) - ) - where targetWidth = wordWidth dflags - targetBE = wORDS_BIGENDIAN dflags - pprWord64 w64 - | targetWidth == W64 = - [ CmmInt (toInteger w64) targetWidth ] - | targetWidth == W32 = - [ CmmInt (toInteger targetW1) targetWidth - , CmmInt (toInteger targetW2) targetWidth - ] - | otherwise = panic "doubleToWords.pprWord64" - where (targetW1, targetW2) - | targetBE = (wHi, wLo) - | otherwise = (wLo, wHi) - wHi = w64 `shiftR` 32 - wLo = w64 .&. 0xFFFFffff - --- --------------------------------------------------------------------------- --- Utils - -wordShift :: DynFlags -> Int -wordShift dflags = widthInLog (wordWidth dflags) - -commafy :: [SDoc] -> SDoc -commafy xs = hsep $ punctuate comma xs - --- Print in C hex format: 0x13fa -pprHexVal :: Integer -> Width -> SDoc -pprHexVal w rep - | w < 0 = parens (char '-' <> - text "0x" <> intToDoc (-w) <> repsuffix rep) - | otherwise = text "0x" <> intToDoc w <> repsuffix rep - where - -- type suffix for literals: - -- Integer literals are unsigned in Cmm/C. We explicitly cast to - -- signed values for doing signed operations, but at all other - -- times values are unsigned. This also helps eliminate occasional - -- warnings about integer overflow from gcc. - - repsuffix W64 = sdocWithDynFlags $ \dflags -> - if cINT_SIZE dflags == 8 then char 'U' - else if cLONG_SIZE dflags == 8 then text "UL" - else if cLONG_LONG_SIZE dflags == 8 then text "ULL" - else panic "pprHexVal: Can't find a 64-bit type" - repsuffix _ = char 'U' - - intToDoc :: Integer -> SDoc - intToDoc i = case truncInt i of - 0 -> char '0' - v -> go v - - -- We need to truncate value as Cmm backend does not drop - -- redundant bits to ease handling of negative values. - -- Thus the following Cmm code on 64-bit arch, like amd64: - -- CInt v; - -- v = {something}; - -- if (v == %lobits32(-1)) { ... - -- leads to the following C code: - -- StgWord64 v = (StgWord32)({something}); - -- if (v == 0xFFFFffffFFFFffffU) { ... - -- Such code is incorrect as it promotes both operands to StgWord64 - -- and the whole condition is always false. - truncInt :: Integer -> Integer - truncInt i = - case rep of - W8 -> i `rem` (2^(8 :: Int)) - W16 -> i `rem` (2^(16 :: Int)) - W32 -> i `rem` (2^(32 :: Int)) - W64 -> i `rem` (2^(64 :: Int)) - _ -> panic ("pprHexVal/truncInt: C backend can't encode " - ++ show rep ++ " literals") - - go 0 = empty - go w' = go q <> dig - where - (q,r) = w' `quotRem` 16 - dig | r < 10 = char (chr (fromInteger r + ord '0')) - | otherwise = char (chr (fromInteger r - 10 + ord 'a')) diff --git a/cmm/PprCmm.hs b/cmm/PprCmm.hs deleted file mode 100644 --- a/cmm/PprCmm.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- --- --- Pretty-printing of Cmm as (a superset of) C-- --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ --- --- This is where we walk over CmmNode emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs - -module PprCmm - ( module PprCmmDecl - , module PprCmmExpr - ) -where - -import GhcPrelude hiding (succ) - -import CLabel -import Cmm -import CmmUtils -import CmmSwitch -import DynFlags -import FastString -import Outputable -import PprCmmDecl -import PprCmmExpr -import Util - -import BasicTypes -import Hoopl.Block -import Hoopl.Graph - -------------------------------------------------- --- Outputable instances - -instance Outputable CmmStackInfo where - ppr = pprStackInfo - -instance Outputable CmmTopInfo where - ppr = pprTopInfo - - -instance Outputable (CmmNode e x) where - ppr = pprNode - -instance Outputable Convention where - ppr = pprConvention - -instance Outputable ForeignConvention where - ppr = pprForeignConvention - -instance Outputable ForeignTarget where - ppr = pprForeignTarget - -instance Outputable CmmReturnInfo where - ppr = pprReturnInfo - -instance Outputable (Block CmmNode C C) where - ppr = pprBlock -instance Outputable (Block CmmNode C O) where - ppr = pprBlock -instance Outputable (Block CmmNode O C) where - ppr = pprBlock -instance Outputable (Block CmmNode O O) where - ppr = pprBlock - -instance Outputable (Graph CmmNode e x) where - ppr = pprGraph - -instance Outputable CmmGraph where - ppr = pprCmmGraph - ----------------------------------------------------------- --- Outputting types Cmm contains - -pprStackInfo :: CmmStackInfo -> SDoc -pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = - text "arg_space: " <> ppr arg_space <+> - text "updfr_space: " <> ppr updfr_space - -pprTopInfo :: CmmTopInfo -> SDoc -pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = - vcat [text "info_tbls: " <> ppr info_tbl, - text "stack_info: " <> ppr stack_info] - ----------------------------------------------------------- --- Outputting blocks and graphs - -pprBlock :: IndexedCO x SDoc SDoc ~ SDoc - => Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock block - = foldBlockNodesB3 ( ($$) . ppr - , ($$) . (nest 4) . ppr - , ($$) . (nest 4) . ppr - ) - block - empty - -pprGraph :: Graph CmmNode e x -> SDoc -pprGraph GNil = empty -pprGraph (GUnit block) = ppr block -pprGraph (GMany entry body exit) - = text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) - $$ text "}" - where pprMaybeO :: Outputable (Block CmmNode e x) - => MaybeO ex (Block CmmNode e x) -> SDoc - pprMaybeO NothingO = empty - pprMaybeO (JustO block) = ppr block - -pprCmmGraph :: CmmGraph -> SDoc -pprCmmGraph g - = text "{" <> text "offset" - $$ nest 2 (vcat $ map ppr blocks) - $$ text "}" - where blocks = revPostorder g - -- revPostorder has the side-effect of discarding unreachable code, - -- so pretty-printed Cmm will omit any unreachable blocks. This can - -- sometimes be confusing. - ---------------------------------------------- --- Outputting CmmNode and types which it contains - -pprConvention :: Convention -> SDoc -pprConvention (NativeNodeCall {}) = text "" -pprConvention (NativeDirectCall {}) = text "" -pprConvention (NativeReturn {}) = text "" -pprConvention Slow = text "" -pprConvention GC = text "" - -pprForeignConvention :: ForeignConvention -> SDoc -pprForeignConvention (ForeignConvention c args res ret _ _) = - doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret - -pprReturnInfo :: CmmReturnInfo -> SDoc -pprReturnInfo CmmMayReturn = empty -pprReturnInfo CmmNeverReturns = text "never returns" - -pprForeignTarget :: ForeignTarget -> SDoc -pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn - where - ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = ppr t - ppr_target fn' = parens (ppr fn') - -pprForeignTarget (PrimTarget op) - -- HACK: We're just using a ForeignLabel to get this printed, the label - -- might not really be foreign. - = ppr - (CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction)) - -pprNode :: CmmNode e x -> SDoc -pprNode node = pp_node <+> pp_debug - where - pp_node :: SDoc - pp_node = sdocWithDynFlags $ \dflags -> case node of - -- label: - CmmEntry id tscope -> lbl <> colon <+> - (sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope)) - where - lbl = if gopt Opt_SuppressUniques dflags - then text "_lbl_" - else ppr id - - -- // text - CmmComment s -> text "//" <+> ftext s - - -- //tick bla<...> - CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $ - text "//tick" <+> ppr t - - -- unwind reg = expr; - CmmUnwind regs -> - text "unwind " - <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi - - -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi - - -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - where - rep = sdocWithDynFlags $ \dflags -> - ppr ( cmmExprType dflags expr ) - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - CmmUnsafeForeignCall target results args -> - hsep [ ppUnless (null results) $ - parens (commafy $ map ppr results) <+> equals, - text "call", - ppr target <> parens (commafy $ map ppr args) <> semi] - - -- goto label; - CmmBranch ident -> text "goto" <+> ppr ident <> semi - - -- if (expr) goto t; else goto f; - CmmCondBranch expr t f l -> - hsep [ text "if" - , parens(ppr expr) - , case l of - Nothing -> empty - Just b -> parens (text "likely:" <+> ppr b) - , text "goto" - , ppr t <> semi - , text "else goto" - , ppr f <> semi - ] - - CmmSwitch expr ids -> - hang (hsep [ text "switch" - , range - , if isTrivialCmmExpr expr - then ppr expr - else parens (ppr expr) - , text "{" - ]) - 4 (vcat (map ppCase cases) $$ def) $$ rbrace - where - (cases, mbdef) = switchTargetsFallThrough ids - ppCase (is,l) = hsep - [ text "case" - , commafy $ map integer is - , text ": goto" - , ppr l <> semi - ] - def | Just l <- mbdef = hsep - [ text "default:" - , braces (text "goto" <+> ppr l <> semi) - ] - | otherwise = empty - - range = brackets $ hsep [integer lo, text "..", integer hi] - where (lo,hi) = switchTargetsRange ids - - CmmCall tgt k regs out res updfr_off -> - hcat [ text "call", space - , pprFun tgt, parens (interpp'SP regs), space - , returns <+> - text "args: " <> ppr out <> comma <+> - text "res: " <> ppr res <> comma <+> - text "upd: " <> ppr updfr_off - , semi ] - where pprFun f@(CmmLit _) = ppr f - pprFun f = parens (ppr f) - - returns - | Just r <- k = text "returns to" <+> ppr r <> comma - | otherwise = empty - - CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> - hcat $ if i then [text "interruptible", space] else [] ++ - [ text "foreign call", space - , ppr t, text "(...)", space - , text "returns to" <+> ppr s - <+> text "args:" <+> parens (ppr as) - <+> text "ress:" <+> parens (ppr rs) - , text "ret_args:" <+> ppr a - , text "ret_off:" <+> ppr u - , semi ] - - pp_debug :: SDoc - pp_debug = - if not debugIsOn then empty - else case node of - CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" - CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" - CmmTick {} -> empty - CmmUnwind {} -> text " // CmmUnwind" - CmmAssign {} -> text " // CmmAssign" - CmmStore {} -> text " // CmmStore" - CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" - CmmBranch {} -> text " // CmmBranch" - CmmCondBranch {} -> text " // CmmCondBranch" - CmmSwitch {} -> text " // CmmSwitch" - CmmCall {} -> text " // CmmCall" - CmmForeignCall {} -> text " // CmmForeignCall" - - commafy :: [SDoc] -> SDoc - commafy xs = hsep $ punctuate comma xs diff --git a/cmm/PprCmmDecl.hs b/cmm/PprCmmDecl.hs deleted file mode 100644 --- a/cmm/PprCmmDecl.hs +++ /dev/null @@ -1,169 +0,0 @@ ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PprCmmDecl - ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic - ) -where - -import GhcPrelude - -import PprCmmExpr -import Cmm - -import DynFlags -import Outputable -import FastString - -import Data.List -import System.IO - -import qualified Data.ByteString as BS - - -pprCmms :: (Outputable info, Outputable g) - => [GenCmmGroup CmmStatics info g] -> SDoc -pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) - where - separator = space $$ text "-------------------" $$ space - -writeCmms :: (Outputable info, Outputable g) - => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () -writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms) - ------------------------------------------------------------------------------ - -instance (Outputable d, Outputable info, Outputable i) - => Outputable (GenCmmDecl d info i) where - ppr t = pprTop t - -instance Outputable CmmStatics where - ppr = pprStatics - -instance Outputable CmmStatic where - ppr = pprStatic - -instance Outputable CmmInfoTable where - ppr = pprInfoTable - - ------------------------------------------------------------------------------ - -pprCmmGroup :: (Outputable d, Outputable info, Outputable g) - => GenCmmGroup d info g -> SDoc -pprCmmGroup tops - = vcat $ intersperse blankLine $ map pprTop tops - --- -------------------------------------------------------------------------- --- Top level `procedure' blocks. --- -pprTop :: (Outputable d, Outputable info, Outputable i) - => GenCmmDecl d info i -> SDoc - -pprTop (CmmProc info lbl live graph) - - = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live - , nest 8 $ lbrace <+> ppr info $$ rbrace - , nest 4 $ ppr graph - , rbrace ] - --- -------------------------------------------------------------------------- --- We follow [1], 4.5 --- --- section "data" { ... } --- -pprTop (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (ppr ds)) - $$ rbrace - --- -------------------------------------------------------------------------- --- Info tables. - -pprInfoTable :: CmmInfoTable -> SDoc -pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep - , cit_prof = prof_info - , cit_srt = srt }) - = vcat [ text "label: " <> ppr lbl - , text "rep: " <> ppr rep - , case prof_info of - NoProfilingInfo -> empty - ProfilingInfo ct cd -> - vcat [ text "type: " <> text (show (BS.unpack ct)) - , text "desc: " <> text (show (BS.unpack cd)) ] - , text "srt: " <> ppr srt ] - -instance Outputable ForeignHint where - ppr NoHint = empty - ppr SignedHint = quotes(text "signed") --- ppr AddrHint = quotes(text "address") --- Temp Jan08 - ppr AddrHint = (text "PtrHint") - --- -------------------------------------------------------------------------- --- Static data. --- Strings are printed as C strings, and we print them as I8[], --- following C-- --- -pprStatics :: CmmStatics -> SDoc -pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) - -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of - CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit lit <> semi - CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) - CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') - --- -------------------------------------------------------------------------- --- data sections --- -pprSection :: Section -> SDoc -pprSection (Section t suffix) = - section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix) - where - section = text "section" - -pprSectionType :: SectionType -> SDoc -pprSectionType s = doubleQuotes (ptext t) - where - t = case s of - Text -> sLit "text" - Data -> sLit "data" - ReadOnlyData -> sLit "readonly" - ReadOnlyData16 -> sLit "readonly16" - RelocatableReadOnlyData - -> sLit "relreadonly" - UninitialisedData -> sLit "uninitialised" - CString -> sLit "cstring" - OtherSection s' -> sLit s' -- Not actually a literal though. diff --git a/cmm/PprCmmExpr.hs b/cmm/PprCmmExpr.hs deleted file mode 100644 --- a/cmm/PprCmmExpr.hs +++ /dev/null @@ -1,286 +0,0 @@ ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PprCmmExpr - ( pprExpr, pprLit - ) -where - -import GhcPrelude - -import CmmExpr - -import Outputable -import DynFlags - -import Data.Maybe -import Numeric ( fromRat ) - ------------------------------------------------------------------------------ - -instance Outputable CmmExpr where - ppr e = pprExpr e - -instance Outputable CmmReg where - ppr e = pprReg e - -instance Outputable CmmLit where - ppr l = pprLit l - -instance Outputable LocalReg where - ppr e = pprLocalReg e - -instance Outputable Area where - ppr e = pprArea e - -instance Outputable GlobalReg where - ppr e = pprGlobalReg e - --- -------------------------------------------------------------------------- --- Expressions --- - -pprExpr :: CmmExpr -> SDoc -pprExpr e - = sdocWithDynFlags $ \dflags -> - case e of - CmmRegOff reg i -> - pprExpr (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType dflags reg) - CmmLit lit -> pprLit lit - _other -> pprExpr1 e - --- Here's the precedence table from CmmParse.y: --- %nonassoc '>=' '>' '<=' '<' '!=' '==' --- %left '|' --- %left '^' --- %left '&' --- %left '>>' '<<' --- %left '-' '+' --- %left '/' '*' '%' --- %right '~' - --- We just cope with the common operators for now, the rest will get --- a default conservative behaviour. - --- %nonassoc '>=' '>' '<=' '<' '!=' '==' -pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc -pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op - = pprExpr7 x <+> doc <+> pprExpr7 y -pprExpr1 e = pprExpr7 e - -infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - -infixMachOp1 (MO_Eq _) = Just (text "==") -infixMachOp1 (MO_Ne _) = Just (text "!=") -infixMachOp1 (MO_Shl _) = Just (text "<<") -infixMachOp1 (MO_U_Shr _) = Just (text ">>") -infixMachOp1 (MO_U_Ge _) = Just (text ">=") -infixMachOp1 (MO_U_Le _) = Just (text "<=") -infixMachOp1 (MO_U_Gt _) = Just (char '>') -infixMachOp1 (MO_U_Lt _) = Just (char '<') -infixMachOp1 _ = Nothing - --- %left '-' '+' -pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 - = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) -pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op - = pprExpr7 x <+> doc <+> pprExpr8 y -pprExpr7 e = pprExpr8 e - -infixMachOp7 (MO_Add _) = Just (char '+') -infixMachOp7 (MO_Sub _) = Just (char '-') -infixMachOp7 _ = Nothing - --- %left '/' '*' '%' -pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op - = pprExpr8 x <+> doc <+> pprExpr9 y -pprExpr8 e = pprExpr9 e - -infixMachOp8 (MO_U_Quot _) = Just (char '/') -infixMachOp8 (MO_Mul _) = Just (char '*') -infixMachOp8 (MO_U_Rem _) = Just (char '%') -infixMachOp8 _ = Nothing - -pprExpr9 :: CmmExpr -> SDoc -pprExpr9 e = - case e of - CmmLit lit -> pprLit1 lit - CmmLoad expr rep -> ppr rep <> brackets (ppr expr) - CmmReg reg -> ppr reg - CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) - CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) - CmmMachOp mop args -> genMachOp mop args - -genMachOp :: MachOp -> [CmmExpr] -> SDoc -genMachOp mop args - | Just doc <- infixMachOp mop = case args of - -- dyadic - [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y - - -- unary - [x] -> doc <> pprExpr9 x - - _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" - (pprMachOp mop <+> - parens (hcat $ punctuate comma (map pprExpr args))) - empty - - | isJust (infixMachOp1 mop) - || isJust (infixMachOp7 mop) - || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) - - | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args)) - where ppr_op = text (map (\c -> if c == ' ' then '_' else c) - (show mop)) - -- replace spaces in (show mop) with underscores, - --- --- Unsigned ops on the word size of the machine get nice symbols. --- All else get dumped in their ugly format. --- -infixMachOp :: MachOp -> Maybe SDoc -infixMachOp mop - = case mop of - MO_And _ -> Just $ char '&' - MO_Or _ -> Just $ char '|' - MO_Xor _ -> Just $ char '^' - MO_Not _ -> Just $ char '~' - MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) - _ -> Nothing - --- -------------------------------------------------------------------------- --- Literals. --- To minimise line noise we adopt the convention that if the literal --- has the natural machine word size, we do not append the type --- -pprLit :: CmmLit -> SDoc -pprLit lit = sdocWithDynFlags $ \dflags -> - case lit of - CmmInt i rep -> - hcat [ (if i < 0 then parens else id)(integer i) - , ppUnless (rep == wordWidth dflags) $ - space <> dcolon <+> ppr rep ] - - CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] - CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>' - CmmLabel clbl -> ppr clbl - CmmLabelOff clbl i -> ppr clbl <> ppr_offset i - CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-' - <> ppr clbl2 <> ppr_offset i - CmmBlock id -> ppr id - CmmHighStackMark -> text "" - -pprLit1 :: CmmLit -> SDoc -pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) -pprLit1 lit = pprLit lit - -ppr_offset :: Int -> SDoc -ppr_offset i - | i==0 = empty - | i>=0 = char '+' <> int i - | otherwise = char '-' <> int (-i) - --- -------------------------------------------------------------------------- --- Registers, whether local (temps) or global --- -pprReg :: CmmReg -> SDoc -pprReg r - = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - --- --- We only print the type of the local reg if it isn't wordRep --- -pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags -> --- = ppr rep <> char '_' <> ppr uniq --- Temp Jan08 - char '_' <> pprUnique dflags uniq <> - (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh - then dcolon <> ptr <> ppr rep - else dcolon <> ptr <> ppr rep) - where - pprUnique dflags unique = - if gopt Opt_SuppressUniques dflags - then text "_locVar_" - else ppr unique - ptr = empty - --if isGcPtrType rep - -- then doubleQuotes (text "ptr") - -- else empty - --- Stack areas -pprArea :: Area -> SDoc -pprArea Old = text "old" -pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] - --- needs to be kept in syn with CmmExpr.hs.GlobalReg --- -pprGlobalReg :: GlobalReg -> SDoc -pprGlobalReg gr - = case gr of - VanillaReg n _ -> char 'R' <> int n --- Temp Jan08 --- VanillaReg n VNonGcPtr -> char 'R' <> int n --- VanillaReg n VGcPtr -> char 'P' <> int n - FloatReg n -> char 'F' <> int n - DoubleReg n -> char 'D' <> int n - LongReg n -> char 'L' <> int n - XmmReg n -> text "XMM" <> int n - YmmReg n -> text "YMM" <> int n - ZmmReg n -> text "ZMM" <> int n - Sp -> text "Sp" - SpLim -> text "SpLim" - Hp -> text "Hp" - HpLim -> text "HpLim" - MachSp -> text "MachSp" - UnwindReturnReg-> text "UnwindReturnReg" - CCCS -> text "CCCS" - CurrentTSO -> text "CurrentTSO" - CurrentNursery -> text "CurrentNursery" - HpAlloc -> text "HpAlloc" - EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" - GCEnter1 -> text "stg_gc_enter_1" - GCFun -> text "stg_gc_fun" - BaseReg -> text "BaseReg" - PicBaseReg -> text "PicBaseReg" - ------------------------------------------------------------------------------ - -commafy :: [SDoc] -> SDoc -commafy xs = fsep $ punctuate comma xs diff --git a/cmm/SMRep.hs b/cmm/SMRep.hs deleted file mode 100644 --- a/cmm/SMRep.hs +++ /dev/null @@ -1,563 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- --- Storage manager representation of closures - -{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} - -module SMRep ( - -- * Words and bytes - WordOff, ByteOff, - wordsToBytes, bytesToWordsRoundUp, - roundUpToWords, roundUpTo, - - StgWord, fromStgWord, toStgWord, - StgHalfWord, fromStgHalfWord, toStgHalfWord, - halfWordSize, halfWordSizeInBits, - - -- * Closure repesentation - SMRep(..), -- CmmInfo sees the rep; no one else does - IsStatic, - ClosureTypeInfo(..), ArgDescr(..), Liveness, - ConstrDescription, - - -- ** Construction - mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, - smallArrPtrsRep, arrWordsRep, - - -- ** Predicates - isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, - isStackRep, - - -- ** Size-related things - heapClosureSizeW, - fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, - arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, - smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW, - fixedHdrSize, - - -- ** RTS closure types - rtsClosureType, rET_SMALL, rET_BIG, - aRG_GEN, aRG_GEN_BIG, - - -- ** Arrays - card, cardRoundUp, cardTableSizeB, cardTableSizeW - ) where - -import GhcPrelude - -import BasicTypes( ConTagZ ) -import DynFlags -import Outputable -import GHC.Platform -import FastString - -import Data.Word -import Data.Bits -import Data.ByteString (ByteString) - -{- -************************************************************************ -* * - Words and bytes -* * -************************************************************************ --} - --- | Word offset, or word count -type WordOff = Int - --- | Byte offset, or byte count -type ByteOff = Int - --- | Round up the given byte count to the next byte count that's a --- multiple of the machine's word size. -roundUpToWords :: DynFlags -> ByteOff -> ByteOff -roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags) - --- | Round up @base@ to a multiple of @size@. -roundUpTo :: ByteOff -> ByteOff -> ByteOff -roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1)) - --- | Convert the given number of words to a number of bytes. --- --- This function morally has type @WordOff -> ByteOff@, but uses @Num --- a@ to allow for overloading. -wordsToBytes :: Num a => DynFlags -> a -> a -wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n -{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-} - --- | First round the given byte count up to a multiple of the --- machine's word size and then convert the result to words. -bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff -bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size - where word_size = wORD_SIZE dflags --- StgWord is a type representing an StgWord on the target platform. --- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform -newtype StgWord = StgWord Word64 - deriving (Eq, Bits) - -fromStgWord :: StgWord -> Integer -fromStgWord (StgWord i) = toInteger i - -toStgWord :: DynFlags -> Integer -> StgWord -toStgWord dflags i - = case platformWordSize (targetPlatform dflags) of - -- These conversions mean that things like toStgWord (-1) - -- do the right thing - PW4 -> StgWord (fromIntegral (fromInteger i :: Word32)) - PW8 -> StgWord (fromInteger i) - -instance Outputable StgWord where - ppr (StgWord i) = integer (toInteger i) - --- - --- A Word32 is large enough to hold half a Word for either a 32bit or --- 64bit platform -newtype StgHalfWord = StgHalfWord Word32 - deriving Eq - -fromStgHalfWord :: StgHalfWord -> Integer -fromStgHalfWord (StgHalfWord w) = toInteger w - -toStgHalfWord :: DynFlags -> Integer -> StgHalfWord -toStgHalfWord dflags i - = case platformWordSize (targetPlatform dflags) of - -- These conversions mean that things like toStgHalfWord (-1) - -- do the right thing - PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) - PW8 -> StgHalfWord (fromInteger i :: Word32) - -instance Outputable StgHalfWord where - ppr (StgHalfWord w) = integer (toInteger w) - --- | Half word size in bytes -halfWordSize :: DynFlags -> ByteOff -halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2 - -halfWordSizeInBits :: DynFlags -> Int -halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2 - -{- -************************************************************************ -* * -\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} -* * -************************************************************************ --} - --- | A description of the layout of a closure. Corresponds directly --- to the closure types in includes/rts/storage/ClosureTypes.h. -data SMRep - = HeapRep -- GC routines consult sizes in info tbl - IsStatic - !WordOff -- # ptr words - !WordOff -- # non-ptr words INCLUDING SLOP (see mkHeapRep below) - ClosureTypeInfo -- type-specific info - - | ArrayPtrsRep - !WordOff -- # ptr words - !WordOff -- # card table words - - | SmallArrayPtrsRep - !WordOff -- # ptr words - - | ArrayWordsRep - !WordOff -- # bytes expressed in words, rounded up - - | StackRep -- Stack frame (RET_SMALL or RET_BIG) - Liveness - - | RTSRep -- The RTS needs to declare info tables with specific - Int -- type tags, so this form lets us override the default - SMRep -- tag for an SMRep. - --- | True <=> This is a static closure. Affects how we garbage-collect it. --- Static closure have an extra static link field at the end. --- Constructors do not have a static variant; see Note [static constructors] -type IsStatic = Bool - --- From an SMRep you can get to the closure type defined in --- includes/rts/storage/ClosureTypes.h. Described by the function --- rtsClosureType below. - -data ClosureTypeInfo - = Constr ConTagZ ConstrDescription - | Fun FunArity ArgDescr - | Thunk - | ThunkSelector SelectorOffset - | BlackHole - | IndStatic - -type ConstrDescription = ByteString -- result of dataConIdentity -type FunArity = Int -type SelectorOffset = Int - -------------------------- --- We represent liveness bitmaps as a Bitmap (whose internal --- representation really is a bitmap). These are pinned onto case return --- vectors to indicate the state of the stack for the garbage collector. --- --- In the compiled program, liveness bitmaps that fit inside a single --- word (StgWord) are stored as a single word, while larger bitmaps are --- stored as a pointer to an array of words. - -type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead - -- False <=> ptr - -------------------------- --- An ArgDescr describes the argument pattern of a function - -data ArgDescr - = ArgSpec -- Fits one of the standard patterns - !Int -- RTS type identifier ARG_P, ARG_N, ... - - | ArgGen -- General case - Liveness -- Details about the arguments - - ------------------------------------------------------------------------------ --- Construction - -mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo - -> SMRep -mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info - = HeapRep is_static - ptr_wds - (nonptr_wds + slop_wds) - cl_type_info - where - slop_wds - | is_static = 0 - | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) - - hdr_size = closureTypeHdrSize dflags cl_type_info - payload_size = ptr_wds + nonptr_wds - -mkRTSRep :: Int -> SMRep -> SMRep -mkRTSRep = RTSRep - -mkStackRep :: [Bool] -> SMRep -mkStackRep liveness = StackRep liveness - -blackHoleRep :: SMRep -blackHoleRep = HeapRep False 0 0 BlackHole - -indStaticRep :: SMRep -indStaticRep = HeapRep True 1 0 IndStatic - -arrPtrsRep :: DynFlags -> WordOff -> SMRep -arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) - -smallArrPtrsRep :: WordOff -> SMRep -smallArrPtrsRep elems = SmallArrayPtrsRep elems - -arrWordsRep :: DynFlags -> ByteOff -> SMRep -arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes) - ------------------------------------------------------------------------------ --- Predicates - -isStaticRep :: SMRep -> IsStatic -isStaticRep (HeapRep is_static _ _ _) = is_static -isStaticRep (RTSRep _ rep) = isStaticRep rep -isStaticRep _ = False - -isStackRep :: SMRep -> Bool -isStackRep StackRep{} = True -isStackRep (RTSRep _ rep) = isStackRep rep -isStackRep _ = False - -isConRep :: SMRep -> Bool -isConRep (HeapRep _ _ _ Constr{}) = True -isConRep _ = False - -isThunkRep :: SMRep -> Bool -isThunkRep (HeapRep _ _ _ Thunk) = True -isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True -isThunkRep (HeapRep _ _ _ BlackHole) = True -isThunkRep (HeapRep _ _ _ IndStatic) = True -isThunkRep _ = False - -isFunRep :: SMRep -> Bool -isFunRep (HeapRep _ _ _ Fun{}) = True -isFunRep _ = False - -isStaticNoCafCon :: SMRep -> Bool --- This should line up exactly with CONSTR_NOCAF below --- See Note [Static NoCaf constructors] -isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True -isStaticNoCafCon _ = False - - ------------------------------------------------------------------------------ --- Size-related things - -fixedHdrSize :: DynFlags -> ByteOff -fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags) - --- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) -fixedHdrSizeW :: DynFlags -> WordOff -fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags - --- | Size of the profiling part of a closure header --- (StgProfHeader in includes/rts/storage/Closures.h) -profHdrSize :: DynFlags -> WordOff -profHdrSize dflags - | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags - | otherwise = 0 - --- | The garbage collector requires that every closure is at least as --- big as this. -minClosureSize :: DynFlags -> WordOff -minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags - -arrWordsHdrSize :: DynFlags -> ByteOff -arrWordsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags - -arrWordsHdrSizeW :: DynFlags -> WordOff -arrWordsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags) - -arrPtrsHdrSize :: DynFlags -> ByteOff -arrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags - -arrPtrsHdrSizeW :: DynFlags -> WordOff -arrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) - -smallArrPtrsHdrSize :: DynFlags -> ByteOff -smallArrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags - -smallArrPtrsHdrSizeW :: DynFlags -> WordOff -smallArrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) - --- Thunks have an extra header word on SMP, so the update doesn't --- splat the payload. -thunkHdrSize :: DynFlags -> WordOff -thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr - where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags - -hdrSize :: DynFlags -> SMRep -> ByteOff -hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep) - -hdrSizeW :: DynFlags -> SMRep -> WordOff -hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty -hdrSizeW dflags (ArrayPtrsRep _ _) = arrPtrsHdrSizeW dflags -hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags -hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags -hdrSizeW _ _ = panic "SMRep.hdrSizeW" - -nonHdrSize :: DynFlags -> SMRep -> ByteOff -nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep) - -nonHdrSizeW :: SMRep -> WordOff -nonHdrSizeW (HeapRep _ p np _) = p + np -nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct -nonHdrSizeW (SmallArrayPtrsRep elems) = elems -nonHdrSizeW (ArrayWordsRep words) = words -nonHdrSizeW (StackRep bs) = length bs -nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep - --- | The total size of the closure, in words. -heapClosureSizeW :: DynFlags -> SMRep -> WordOff -heapClosureSizeW dflags (HeapRep _ p np ty) - = closureTypeHdrSize dflags ty + p + np -heapClosureSizeW dflags (ArrayPtrsRep elems ct) - = arrPtrsHdrSizeW dflags + elems + ct -heapClosureSizeW dflags (SmallArrayPtrsRep elems) - = smallArrPtrsHdrSizeW dflags + elems -heapClosureSizeW dflags (ArrayWordsRep words) - = arrWordsHdrSizeW dflags + words -heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" - -closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff -closureTypeHdrSize dflags ty = case ty of - Thunk -> thunkHdrSize dflags - ThunkSelector{} -> thunkHdrSize dflags - BlackHole -> thunkHdrSize dflags - IndStatic -> thunkHdrSize dflags - _ -> fixedHdrSizeW dflags - -- All thunks use thunkHdrSize, even if they are non-updatable. - -- this is because we don't have separate closure types for - -- updatable vs. non-updatable thunks, so the GC can't tell the - -- difference. If we ever have significant numbers of non- - -- updatable thunks, it might be worth fixing this. - --- --------------------------------------------------------------------------- --- Arrays - --- | The byte offset into the card table of the card for a given element -card :: DynFlags -> Int -> Int -card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags - --- | Convert a number of elements to a number of cards, rounding up -cardRoundUp :: DynFlags -> Int -> Int -cardRoundUp dflags i = - card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)) - --- | The size of a card table, in bytes -cardTableSizeB :: DynFlags -> Int -> ByteOff -cardTableSizeB dflags elems = cardRoundUp dflags elems - --- | The size of a card table, in words -cardTableSizeW :: DynFlags -> Int -> WordOff -cardTableSizeW dflags elems = - bytesToWordsRoundUp dflags (cardTableSizeB dflags elems) - ------------------------------------------------------------------------------ --- deriving the RTS closure type from an SMRep - -#include "../includes/rts/storage/ClosureTypes.h" -#include "../includes/rts/storage/FunTypes.h" --- Defines CONSTR, CONSTR_1_0 etc - --- | Derives the RTS closure type from an 'SMRep' -rtsClosureType :: SMRep -> Int -rtsClosureType rep - = case rep of - RTSRep ty _ -> ty - - -- See Note [static constructors] - HeapRep _ 1 0 Constr{} -> CONSTR_1_0 - HeapRep _ 0 1 Constr{} -> CONSTR_0_1 - HeapRep _ 2 0 Constr{} -> CONSTR_2_0 - HeapRep _ 1 1 Constr{} -> CONSTR_1_1 - HeapRep _ 0 2 Constr{} -> CONSTR_0_2 - HeapRep _ 0 _ Constr{} -> CONSTR_NOCAF - -- See Note [Static NoCaf constructors] - HeapRep _ _ _ Constr{} -> CONSTR - - HeapRep False 1 0 Fun{} -> FUN_1_0 - HeapRep False 0 1 Fun{} -> FUN_0_1 - HeapRep False 2 0 Fun{} -> FUN_2_0 - HeapRep False 1 1 Fun{} -> FUN_1_1 - HeapRep False 0 2 Fun{} -> FUN_0_2 - HeapRep False _ _ Fun{} -> FUN - - HeapRep False 1 0 Thunk -> THUNK_1_0 - HeapRep False 0 1 Thunk -> THUNK_0_1 - HeapRep False 2 0 Thunk -> THUNK_2_0 - HeapRep False 1 1 Thunk -> THUNK_1_1 - HeapRep False 0 2 Thunk -> THUNK_0_2 - HeapRep False _ _ Thunk -> THUNK - - HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR - - HeapRep True _ _ Fun{} -> FUN_STATIC - HeapRep True _ _ Thunk -> THUNK_STATIC - HeapRep False _ _ BlackHole -> BLACKHOLE - HeapRep False _ _ IndStatic -> IND_STATIC - - _ -> panic "rtsClosureType" - --- We export these ones -rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int -rET_SMALL = RET_SMALL -rET_BIG = RET_BIG -aRG_GEN = ARG_GEN -aRG_GEN_BIG = ARG_GEN_BIG - -{- -Note [static constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We used to have a CONSTR_STATIC closure type, and each constructor had -two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with -CONSTR_STATIC. - -This distinction was removed, because when copying a data structure -into a compact region, we must copy static constructors into the -compact region too. If we didn't do this, we would need to track the -references from the compact region out to the static constructors, -because they might (indirectly) refer to CAFs. - -Since static constructors will be copied to the heap, if we wanted to -use different info tables for static and dynamic constructors, we -would have to switch the info pointer when copying the constructor -into the compact region, which means we would need an extra field of -the static info table to point to the dynamic one. - -However, since the distinction between static and dynamic closure -types is never actually needed (other than for assertions), we can -just drop the distinction and use the same info table for both. - -The GC *does* need to distinguish between static and dynamic closures, -but it does this using the HEAP_ALLOCED() macro which checks whether -the address of the closure resides within the dynamic heap. -HEAP_ALLOCED() doesn't read the closure's info table. - -Note [Static NoCaf constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we know that a top-level binding 'x' is not Caffy (ie no CAFs are -reachable from 'x'), then a statically allocated constructor (Just x) -is also not Caffy, and the garbage collector need not follow its -argument fields. Exploiting this would require two static info tables -for Just, for the two cases where the argument was Caffy or non-Caffy. - -Currently we don't do this; instead we treat nullary constructors -as non-Caffy, and the others as potentially Caffy. - - -************************************************************************ -* * - Pretty printing of SMRep and friends -* * -************************************************************************ --} - -instance Outputable ClosureTypeInfo where - ppr = pprTypeInfo - -instance Outputable SMRep where - ppr (HeapRep static ps nps tyinfo) - = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) - where - header = text "HeapRep" - <+> if static then text "static" else empty - <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps - pp_n :: String -> Int -> SDoc - pp_n _ 0 = empty - pp_n s n = int n <+> text s - - ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size - - ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size - - ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words - - ppr (StackRep bs) = text "StackRep" <+> ppr bs - - ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep - -instance Outputable ArgDescr where - ppr (ArgSpec n) = text "ArgSpec" <+> ppr n - ppr (ArgGen ls) = text "ArgGen" <+> ppr ls - -pprTypeInfo :: ClosureTypeInfo -> SDoc -pprTypeInfo (Constr tag descr) - = text "Con" <+> - braces (sep [ text "tag:" <+> ppr tag - , text "descr:" <> text (show descr) ]) - -pprTypeInfo (Fun arity args) - = text "Fun" <+> - braces (sep [ text "arity:" <+> ppr arity - , ptext (sLit ("fun_type:")) <+> ppr args ]) - -pprTypeInfo (ThunkSelector offset) - = text "ThunkSel" <+> ppr offset - -pprTypeInfo Thunk = text "Thunk" -pprTypeInfo BlackHole = text "BlackHole" -pprTypeInfo IndStatic = text "IndStatic" diff --git a/coreSyn/CoreArity.hs b/coreSyn/CoreArity.hs deleted file mode 100644 --- a/coreSyn/CoreArity.hs +++ /dev/null @@ -1,1194 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - - Arity and eta expansion --} - -{-# LANGUAGE CPP #-} - --- | Arity and eta expansion -module CoreArity ( - manifestArity, joinRhsArity, exprArity, typeArity, - exprEtaExpandArity, findRhsArity, etaExpand, - etaExpandToJoinPoint, etaExpandToJoinPointRule, - exprBotStrictness_maybe - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreFVs -import CoreUtils -import CoreSubst -import Demand -import Var -import VarEnv -import Id -import Type -import TyCon ( initRecTc, checkRecTc ) -import Predicate ( isDictTy ) -import Coercion -import BasicTypes -import Unique -import DynFlags ( DynFlags, GeneralFlag(..), gopt ) -import Outputable -import FastString -import Pair -import Util ( debugIsOn ) - -{- -************************************************************************ -* * - manifestArity and exprArity -* * -************************************************************************ - -exprArity is a cheap-and-cheerful version of exprEtaExpandArity. -It tells how many things the expression can be applied to before doing -any work. It doesn't look inside cases, lets, etc. The idea is that -exprEtaExpandArity will do the hard work, leaving something that's easy -for exprArity to grapple with. In particular, Simplify uses exprArity to -compute the ArityInfo for the Id. - -Originally I thought that it was enough just to look for top-level lambdas, but -it isn't. I've seen this - - foo = PrelBase.timesInt - -We want foo to get arity 2 even though the eta-expander will leave it -unchanged, in the expectation that it'll be inlined. But occasionally it -isn't, because foo is blacklisted (used in a rule). - -Similarly, see the ok_note check in exprEtaExpandArity. So - f = __inline_me (\x -> e) -won't be eta-expanded. - -And in any case it seems more robust to have exprArity be a bit more intelligent. -But note that (\x y z -> f x y z) -should have arity 3, regardless of f's arity. --} - -manifestArity :: CoreExpr -> Arity --- ^ manifestArity sees how many leading value lambdas there are, --- after looking through casts -manifestArity (Lam v e) | isId v = 1 + manifestArity e - | otherwise = manifestArity e -manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e -manifestArity (Cast e _) = manifestArity e -manifestArity _ = 0 - -joinRhsArity :: CoreExpr -> JoinArity --- Join points are supposed to have manifestly-visible --- lambdas at the top: no ticks, no casts, nothing --- Moreover, type lambdas count in JoinArity -joinRhsArity (Lam _ e) = 1 + joinRhsArity e -joinRhsArity _ = 0 - - ---------------- -exprArity :: CoreExpr -> Arity --- ^ An approximate, fast, version of 'exprEtaExpandArity' -exprArity e = go e - where - go (Var v) = idArity v - go (Lam x e) | isId x = go e + 1 - | otherwise = go e - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co)) - -- Note [exprArity invariant] - go (App e (Type _)) = go e - go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 - -- See Note [exprArity for applications] - -- NB: coercions count as a value argument - - go _ = 0 - - trim_arity :: Arity -> Type -> Arity - trim_arity arity ty = arity `min` length (typeArity ty) - ---------------- -typeArity :: Type -> [OneShotInfo] --- How many value arrows are visible in the type? --- We look through foralls, and newtypes --- See Note [exprArity invariant] -typeArity ty - = go initRecTc ty - where - go rec_nts ty - | Just (_, ty') <- splitForAllTy_maybe ty - = go rec_nts ty' - - | Just (arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res - - | Just (tc,tys) <- splitTyConApp_maybe ty - , Just (ty', _) <- instNewTyCon_maybe tc tys - , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] - -- in TyCon --- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes --- -- See Note [Newtype classes and eta expansion] --- (no longer required) - = go rec_nts' ty' - -- Important to look through non-recursive newtypes, so that, eg - -- (f x) where f has arity 2, f :: Int -> IO () - -- Here we want to get arity 1 for the result! - -- - -- AND through a layer of recursive newtypes - -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) - - | otherwise - = [] - ---------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) --- A cheap and cheerful function that identifies bottoming functions --- and gives them a suitable strictness signatures. It's used during --- float-out -exprBotStrictness_maybe e - = case getBotArity (arityType env e) of - Nothing -> Nothing - Just ar -> Just (ar, sig ar) - where - env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } - sig ar = mkClosedStrictSig (replicate ar topDmd) botRes - -{- -Note [exprArity invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprArity has the following invariants: - - (1) If typeArity (exprType e) = n, - then manifestArity (etaExpand e n) = n - - That is, etaExpand can always expand as much as typeArity says - So the case analysis in etaExpand and in typeArity must match - - (2) exprArity e <= typeArity (exprType e) - - (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n - - That is, if exprArity says "the arity is n" then etaExpand really - can get "n" manifest lambdas to the top. - -Why is this important? Because - - In TidyPgm we use exprArity to fix the *final arity* of - each top-level Id, and in - - In CorePrep we use etaExpand on each rhs, so that the visible lambdas - actually match that arity, which in turn means - that the StgRhs has the right number of lambdas - -An alternative would be to do the eta-expansion in TidyPgm, at least -for top-level bindings, in which case we would not need the trim_arity -in exprArity. That is a less local change, so I'm going to leave it for today! - -Note [Newtype classes and eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NB: this nasty special case is no longer required, because - for newtype classes we don't use the class-op rule mechanism - at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013 - --------- Old out of date comments, just for interest ----------- -We have to be careful when eta-expanding through newtypes. In general -it's a good idea, but annoyingly it interacts badly with the class-op -rule mechanism. Consider - - class C a where { op :: a -> a } - instance C b => C [b] where - op x = ... - -These translate to - - co :: forall a. (a->a) ~ C a - - $copList :: C b -> [b] -> [b] - $copList d x = ... - - $dfList :: C b -> C [b] - {-# DFunUnfolding = [$copList] #-} - $dfList d = $copList d |> co@[b] - -Now suppose we have: - - dCInt :: C Int - - blah :: [Int] -> [Int] - blah = op ($dfList dCInt) - -Now we want the built-in op/$dfList rule will fire to give - blah = $copList dCInt - -But with eta-expansion 'blah' might (and in #3772, which is -slightly more complicated, does) turn into - - blah = op (\eta. ($dfList dCInt |> sym co) eta) - -and now it is *much* harder for the op/$dfList rule to fire, because -exprIsConApp_maybe won't hold of the argument to op. I considered -trying to *make* it hold, but it's tricky and I gave up. - -The test simplCore/should_compile/T3722 is an excellent example. --------- End of old out of date comments, just for interest ----------- - - -Note [exprArity for applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come to an application we check that the arg is trivial. - eg f (fac x) does not have arity 2, - even if f has arity 3! - -* We require that is trivial rather merely cheap. Suppose f has arity 2. - Then f (Just y) - has arity 0, because if we gave it arity 1 and then inlined f we'd get - let v = Just y in \w. - which has arity 0. And we try to maintain the invariant that we don't - have arity decreases. - -* The `max 0` is important! (\x y -> f x) has arity 2, even if f is - unknown, hence arity 0 - - -************************************************************************ -* * - Computing the "arity" of an expression -* * -************************************************************************ - -Note [Definition of arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "arity" of an expression 'e' is n if - applying 'e' to *fewer* than n *value* arguments - converges rapidly - -Or, to put it another way - - there is no work lost in duplicating the partial - application (e x1 .. x(n-1)) - -In the divegent case, no work is lost by duplicating because if the thing -is evaluated once, that's the end of the program. - -Or, to put it another way, in any context C - - C[ (\x1 .. xn. e x1 .. xn) ] - is as efficient as - C[ e ] - -It's all a bit more subtle than it looks: - -Note [One-shot lambdas] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider one-shot lambdas - let x = expensive in \y z -> E -We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. - -Note [Dealing with bottom] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Big Deal with computing arities is expressions like - - f = \x -> case x of - True -> \s -> e1 - False -> \s -> e2 - -This happens all the time when f :: Bool -> IO () -In this case we do eta-expand, in order to get that \s to the -top, and give f arity 2. - -This isn't really right in the presence of seq. Consider - (f bot) `seq` 1 - -This should diverge! But if we eta-expand, it won't. We ignore this -"problem" (unless -fpedantic-bottoms is on), because being scrupulous -would lose an important transformation for many programs. (See -#5587 for an example.) - -Consider also - f = \x -> error "foo" -Here, arity 1 is fine. But if it is - f = \x -> case x of - True -> error "foo" - False -> \y -> x+y -then we want to get arity 2. Technically, this isn't quite right, because - (f True) `seq` 1 -should diverge, but it'll converge if we eta-expand f. Nevertheless, we -do so; it improves some programs significantly, and increasing convergence -isn't a bad thing. Hence the ABot/ATop in ArityType. - -So these two transformations aren't always the Right Thing, and we -have several tickets reporting unexpected behaviour resulting from -this transformation. So we try to limit it as much as possible: - - (1) Do NOT move a lambda outside a known-bottom case expression - case undefined of { (a,b) -> \y -> e } - This showed up in #5557 - - (2) Do NOT move a lambda outside a case if all the branches of - the case are known to return bottom. - case x of { (a,b) -> \y -> error "urk" } - This case is less important, but the idea is that if the fn is - going to diverge eventually anyway then getting the best arity - isn't an issue, so we might as well play safe - - (3) Do NOT move a lambda outside a case unless - (a) The scrutinee is ok-for-speculation, or - (b) more liberally: the scrutinee is cheap (e.g. a variable), and - -fpedantic-bottoms is not enforced (see #2915 for an example) - -Of course both (1) and (2) are readily defeated by disguising the bottoms. - -4. Note [Newtype arity] -~~~~~~~~~~~~~~~~~~~~~~~~ -Non-recursive newtypes are transparent, and should not get in the way. -We do (currently) eta-expand recursive newtypes too. So if we have, say - - newtype T = MkT ([T] -> Int) - -Suppose we have - e = coerce T f -where f has arity 1. Then: etaExpandArity e = 1; -that is, etaExpandArity looks through the coerce. - -When we eta-expand e to arity 1: eta_expand 1 e T -we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - - HOWEVER, note that if you use coerce bogusly you can ge - coerce Int negate - And since negate has arity 2, you might try to eta expand. But you can't - decopose Int to a function type. Hence the final case in eta_expand. - -Note [The state-transformer hack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - f = e -where e has arity n. Then, if we know from the context that f has -a usage type like - t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... -then we can expand the arity to m. This usage type says that -any application (x e1 .. en) will be applied to uniquely to (m-n) more args -Consider f = \x. let y = - in case x of - True -> foo - False -> \(s:RealWorld) -> e -where foo has arity 1. Then we want the state hack to -apply to foo too, so we can eta expand the case. - -Then we expect that if f is applied to one arg, it'll be applied to two -(that's the hack -- we don't really know, and sometimes it's false) -See also Id.isOneShotBndr. - -Note [State hack and bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a terrible idea to use the state hack on a bottoming function. -Here's what happens (#2861): - - f :: String -> IO T - f = \p. error "..." - -Eta-expand, using the state hack: - - f = \p. (\s. ((error "...") |> g1) s) |> g2 - g1 :: IO T ~ (S -> (S,T)) - g2 :: (S -> (S,T)) ~ IO T - -Extrude the g2 - - f' = \p. \s. ((error "...") |> g1) s - f = f' |> (String -> g2) - -Discard args for bottomming function - - f' = \p. \s. ((error "...") |> g1 |> g3 - g3 :: (S -> (S,T)) ~ (S,T) - -Extrude g1.g3 - - f'' = \p. \s. (error "...") - f' = f'' |> (String -> S -> g1.g3) - -And now we can repeat the whole loop. Aargh! The bug is in applying the -state hack to a function which then swallows the argument. - -This arose in another guise in #3959. Here we had - - catch# (throw exn >> return ()) - -Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. -After inlining (>>) we get - - catch# (\_. throw {IO ()} exn) - -We must *not* eta-expand to - - catch# (\_ _. throw {...} exn) - -because 'catch#' expects to get a (# _,_ #) after applying its argument to -a State#, not another function! - -In short, we use the state hack to allow us to push let inside a lambda, -but not to introduce a new lambda. - - -Note [ArityType] -~~~~~~~~~~~~~~~~ -ArityType is the result of a compositional analysis on expressions, -from which we can decide the real arity of the expression (extracted -with function exprEtaExpandArity). - -Here is what the fields mean. If an arbitrary expression 'f' has -ArityType 'at', then - - * If at = ABot n, then (f x1..xn) definitely diverges. Partial - applications to fewer than n args may *or may not* diverge. - - We allow ourselves to eta-expand bottoming functions, even - if doing so may lose some `seq` sharing, - let x = in \y. error (g x y) - ==> \y. let x = in error (g x y) - - * If at = ATop as, and n=length as, - then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, - assuming the calls of f respect the one-shot-ness of - its definition. - - NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f' - can have ArityType as ATop, with length as > 0, only if e1 e2 are - themselves. - - * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely - really functions, or bottom, but *not* casts from a data type, in - at least one case branch. (If it's a function in one case branch but - an unsafe cast from a data type in another, the program is bogus.) - So eta expansion is dynamically ok; see Note [State hack and - bottoming functions], the part about catch# - -Example: - f = \x\y. let v = in - \s(one-shot) \t(one-shot). blah - 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot] - The one-shot-ness means we can, in effect, push that - 'let' inside the \st. - - -Suppose f = \xy. x+y -Then f :: AT [False,False] ATop - f v :: AT [False] ATop - f :: AT [] ATop - --------------------- Main arity code ---------------------------- --} - --- See Note [ArityType] -data ArityType = ATop [OneShotInfo] | ABot Arity - -- There is always an explicit lambda - -- to justify the [OneShot], or the Arity - -instance Outputable ArityType where - ppr (ATop os) = text "ATop" <> parens (ppr (length os)) - ppr (ABot n) = text "ABot" <> parens (ppr n) - -vanillaArityType :: ArityType -vanillaArityType = ATop [] -- Totally uninformative - --- ^ The Arity returned is the number of value args the --- expression can be applied to without doing much work -exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity --- exprEtaExpandArity is used when eta expanding --- e ==> \xy -> e x y -exprEtaExpandArity dflags e - = case (arityType env e) of - ATop oss -> length oss - ABot n -> n - where - env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp - , ae_ped_bot = gopt Opt_PedanticBottoms dflags } - -getBotArity :: ArityType -> Maybe Arity --- Arity of a divergent function -getBotArity (ABot n) = Just n -getBotArity _ = Nothing - -mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun -mk_cheap_fn dflags cheap_app - | not (gopt Opt_DictsCheap dflags) - = \e _ -> exprIsCheapX cheap_app e - | otherwise - = \e mb_ty -> exprIsCheapX cheap_app e - || case mb_ty of - Nothing -> False - Just ty -> isDictTy ty - - ----------------------- -findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool) --- This implements the fixpoint loop for arity analysis --- See Note [Arity analysis] --- If findRhsArity e = (n, is_bot) then --- (a) any application of e to (\x1..xn. e x1 .. xn) --- (b) if is_bot=True, then e applied to n args is guaranteed bottom -findRhsArity dflags bndr rhs old_arity - = go (get_arity init_cheap_app) - -- We always call exprEtaExpandArity once, but usually - -- that produces a result equal to old_arity, and then - -- we stop right away (since arities should not decrease) - -- Result: the common case is that there is just one iteration - where - is_lam = has_lam rhs - - has_lam (Tick _ e) = has_lam e - has_lam (Lam b e) = isId b || has_lam e - has_lam _ = False - - init_cheap_app :: CheapAppFun - init_cheap_app fn n_val_args - | fn == bndr = True -- On the first pass, this binder gets infinite arity - | otherwise = isCheapApp fn n_val_args - - go :: (Arity, Bool) -> (Arity, Bool) - go cur_info@(cur_arity, _) - | cur_arity <= old_arity = cur_info - | new_arity == cur_arity = cur_info - | otherwise = ASSERT( new_arity < cur_arity ) -#if defined(DEBUG) - pprTrace "Exciting arity" - (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity - , ppr rhs]) -#endif - go new_info - where - new_info@(new_arity, _) = get_arity cheap_app - - cheap_app :: CheapAppFun - cheap_app fn n_val_args - | fn == bndr = n_val_args < cur_arity - | otherwise = isCheapApp fn n_val_args - - get_arity :: CheapAppFun -> (Arity, Bool) - get_arity cheap_app - = case (arityType env rhs) of - ABot n -> (n, True) - ATop (os:oss) | isOneShotInfo os || is_lam - -> (1 + length oss, False) -- Don't expand PAPs/thunks - ATop _ -> (0, False) -- Note [Eta expanding thunks] - where - env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app - , ae_ped_bot = gopt Opt_PedanticBottoms dflags } - -{- -Note [Arity analysis] -~~~~~~~~~~~~~~~~~~~~~ -The motivating example for arity analysis is this: - - f = \x. let g = f (x+1) - in \y. ...g... - -What arity does f have? Really it should have arity 2, but a naive -look at the RHS won't see that. You need a fixpoint analysis which -says it has arity "infinity" the first time round. - -This example happens a lot; it first showed up in Andy Gill's thesis, -fifteen years ago! It also shows up in the code for 'rnf' on lists -in #4138. - -The analysis is easy to achieve because exprEtaExpandArity takes an -argument - type CheapFun = CoreExpr -> Maybe Type -> Bool -used to decide if an expression is cheap enough to push inside a -lambda. And exprIsCheapX in turn takes an argument - type CheapAppFun = Id -> Int -> Bool -which tells when an application is cheap. This makes it easy to -write the analysis loop. - -The analysis is cheap-and-cheerful because it doesn't deal with -mutual recursion. But the self-recursive case is the important one. - - -Note [Eta expanding through dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the experimental -fdicts-cheap flag is on, we eta-expand through -dictionary bindings. This improves arities. Thereby, it also -means that full laziness is less prone to floating out the -application of a function to its dictionary arguments, which -can thereby lose opportunities for fusion. Example: - foo :: Ord a => a -> ... - foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... - -- So foo has arity 1 - - f = \x. foo dInt $ bar x - -The (foo DInt) is floated out, and makes ineffective a RULE - foo (bar x) = ... - -One could go further and make exprIsCheap reply True to any -dictionary-typed expression, but that's more work. - -Note [Eta expanding thunks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't eta-expand - * Trivial RHSs x = y - * PAPs x = map g - * Thunks f = case y of p -> \x -> blah - -When we see - f = case y of p -> \x -> blah -should we eta-expand it? Well, if 'x' is a one-shot state token -then 'yes' because 'f' will only be applied once. But otherwise -we (conservatively) say no. My main reason is to avoid expanding -PAPSs - f = g d ==> f = \x. g d x -because that might in turn make g inline (if it has an inline pragma), -which we might not want. After all, INLINE pragmas say "inline only -when saturated" so we don't want to be too gung-ho about saturating! --} - -arityLam :: Id -> ArityType -> ArityType -arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as) -arityLam _ (ABot n) = ABot (n+1) - -floatIn :: Bool -> ArityType -> ArityType --- We have something like (let x = E in b), --- where b has the given arity type. -floatIn _ (ABot n) = ABot n -floatIn True (ATop as) = ATop as -floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as) - -- If E is not cheap, keep arity only for one-shots - -arityApp :: ArityType -> Bool -> ArityType --- Processing (fun arg) where at is the ArityType of fun, --- Knock off an argument and behave like 'let' -arityApp (ABot 0) _ = ABot 0 -arityApp (ABot n) _ = ABot (n-1) -arityApp (ATop []) _ = ATop [] -arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as) - -andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case' -andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max] -andArityType (ATop as) (ABot _) = ATop as -andArityType (ABot _) (ATop bs) = ATop bs -andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) - where -- See Note [Combining case branches] - combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs - combine [] bs = takeWhile isOneShotInfo bs - combine as [] = takeWhile isOneShotInfo as - -{- Note [ABot branches: use max] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider case x of - True -> \x. error "urk" - False -> \xy. error "urk2" - -Remember: ABot n means "if you apply to n args, it'll definitely diverge". -So we need (ABot 2) for the whole thing, the /max/ of the ABot arities. - -Note [Combining case branches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - go = \x. let z = go e0 - go2 = \x. case x of - True -> z - False -> \s(one-shot). e1 - in go2 x -We *really* want to eta-expand go and go2. -When combining the branches of the case we have - ATop [] `andAT` ATop [OneShotLam] -and we want to get ATop [OneShotLam]. But if the inner -lambda wasn't one-shot we don't want to do this. -(We need a proper arity analysis to justify that.) - -So we combine the best of the two branches, on the (slightly dodgy) -basis that if we know one branch is one-shot, then they all must be. - -Note [Arity trimming] -~~~~~~~~~~~~~~~~~~~~~ -Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and -F is some type family. - -Because of Note [exprArity invariant], item (2), we must return with arity at -most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of -calling arityType on (\x y. blah). Failing to do so, and hence breaking the -exprArity invariant, led to #5441. - -How to trim? For ATop, it's easy. But we must take great care with ABot. -Suppose the expression was (\x y. error "urk"), we'll get (ABot 2). We -absolutely must not trim that to (ABot 1), because that claims that -((\x y. error "urk") |> co) diverges when given one argument, which it -absolutely does not. And Bad Things happen if we think something returns bottom -when it doesn't (#16066). - -So, do not reduce the 'n' in (ABot n); rather, switch (conservatively) to ATop. - -Historical note: long ago, we unconditionally switched to ATop when we -encountered a cast, but that is far too conservative: see #5475 --} - ---------------------------- -type CheapFun = CoreExpr -> Maybe Type -> Bool - -- How to decide if an expression is cheap - -- If the Maybe is Just, the type is the type - -- of the expression; Nothing means "don't know" - -data ArityEnv - = AE { ae_cheap_fn :: CheapFun - , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms - } - -arityType :: ArityEnv -> CoreExpr -> ArityType - -arityType env (Cast e co) - = case arityType env e of - ATop os -> ATop (take co_arity os) - -- See Note [Arity trimming] - ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo) - | otherwise -> ABot n - where - co_arity = length (typeArity (pSnd (coercionKind co))) - -- See Note [exprArity invariant] (2); must be true of - -- arityType too, since that is how we compute the arity - -- of variables, and they in turn affect result of exprArity - -- #5441 is a nice demo - -- However, do make sure that ATop -> ATop and ABot -> ABot! - -- Casts don't affect that part. Getting this wrong provoked #5475 - -arityType _ (Var v) - | strict_sig <- idStrictness v - , not $ isTopSig strict_sig - , (ds, res) <- splitStrictSig strict_sig - , let arity = length ds - = if isBotRes res then ABot arity - else ATop (take arity one_shots) - | otherwise - = ATop (take (idArity v) one_shots) - where - one_shots :: [OneShotInfo] -- One-shot-ness derived from the type - one_shots = typeArity (idType v) - - -- Lambdas; increase arity -arityType env (Lam x e) - | isId x = arityLam x (arityType env e) - | otherwise = arityType env e - - -- Applications; decrease arity, except for types -arityType env (App fun (Type _)) - = arityType env fun -arityType env (App fun arg ) - = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing) - - -- Case/Let; keep arity if either the expression is cheap - -- or it's a 1-shot lambda - -- The former is not really right for Haskell - -- f x = case x of { (a,b) -> \y. e } - -- ===> - -- f x y = case x of { (a,b) -> e } - -- The difference is observable using 'seq' - -- -arityType env (Case scrut _ _ alts) - | exprIsBottom scrut || null alts - = ABot 0 -- Do not eta expand - -- See Note [Dealing with bottom (1)] - | otherwise - = case alts_type of - ABot n | n>0 -> ATop [] -- Don't eta expand - | otherwise -> ABot 0 -- if RHS is bottomming - -- See Note [Dealing with bottom (2)] - - ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)] - , ae_cheap_fn env scrut Nothing -> ATop as - | exprOkForSpeculation scrut -> ATop as - | otherwise -> ATop (takeWhile isOneShotInfo as) - where - alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] - -arityType env (Let b e) - = floatIn (cheap_bind b) (arityType env e) - where - cheap_bind (NonRec b e) = is_cheap (b,e) - cheap_bind (Rec prs) = all is_cheap prs - is_cheap (b,e) = ae_cheap_fn env e (Just (idType b)) - -arityType env (Tick t e) - | not (tickishIsCode t) = arityType env e - -arityType _ _ = vanillaArityType - -{- -%************************************************************************ -%* * - The main eta-expander -%* * -%************************************************************************ - -We go for: - f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym - (n >= 0) - -where (in both cases) - - * The xi can include type variables - - * The yi are all value variables - - * N is a NORMAL FORM (i.e. no redexes anywhere) - wanting a suitable number of extra args. - -The biggest reason for doing this is for cases like - - f = \x -> case x of - True -> \y -> e1 - False -> \y -> e2 - -Here we want to get the lambdas together. A good example is the nofib -program fibheaps, which gets 25% more allocation if you don't do this -eta-expansion. - -We may have to sandwich some coerces between the lambdas -to make the types work. exprEtaExpandArity looks through coerces -when computing arity; and etaExpand adds the coerces as necessary when -actually computing the expansion. - -Note [No crap in eta-expanded code] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The eta expander is careful not to introduce "crap". In particular, -given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it -returns a CoreExpr satisfying the same invariant. See Note [Eta -expansion and the CorePrep invariants] in CorePrep. - -This means the eta-expander has to do a bit of on-the-fly -simplification but it's not too hard. The alernative, of relying on -a subsequent clean-up phase of the Simplifier to de-crapify the result, -means you can't really use it in CorePrep, which is painful. - -Note [Eta expansion for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The no-crap rule is very tiresome to guarantee when -we have join points. Consider eta-expanding - let j :: Int -> Int -> Bool - j x = e - in b - -The simple way is - \(y::Int). (let j x = e in b) y - -The no-crap way is - \(y::Int). let j' :: Int -> Bool - j' x = e y - in b[j'/j] y -where I have written to stress that j's type has -changed. Note that (of course!) we have to push the application -inside the RHS of the join as well as into the body. AND if j -has an unfolding we have to push it into there too. AND j might -be recursive... - -So for now I'm abandoning the no-crap rule in this case. I think -that for the use in CorePrep it really doesn't matter; and if -it does, then CoreToStg.myCollectArgs will fall over. - -(Moreover, I think that casts can make the no-crap rule fail too.) - -Note [Eta expansion and SCCs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that SCCs are not treated specially by etaExpand. If we have - etaExpand 2 (\x -> scc "foo" e) - = (\xy -> (scc "foo" e) y) -So the costs of evaluating 'e' (not 'e y') are attributed to "foo" - -Note [Eta expansion and source notes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CorePrep puts floatable ticks outside of value applications, but not -type applications. As a result we might be trying to eta-expand an -expression like - - (src<...> v) @a - -which we want to lead to code like - - \x -> src<...> v @a x - -This means that we need to look through type applications and be ready -to re-add floats on the top. - --} - --- | @etaExpand n e@ returns an expression with --- the same meaning as @e@, but with arity @n@. --- --- Given: --- --- > e' = etaExpand n e --- --- We should have that: --- --- > ty = exprType e = exprType e' -etaExpand :: Arity -- ^ Result should have this number of value args - -> CoreExpr -- ^ Expression to expand - -> CoreExpr --- etaExpand arity e = res --- Then 'res' has at least 'arity' lambdas at the top --- --- etaExpand deals with for-alls. For example: --- etaExpand 1 E --- where E :: forall a. a -> a --- would return --- (/\b. \y::a -> E b y) --- --- It deals with coerces too, though they are now rare --- so perhaps the extra code isn't worth it - -etaExpand n orig_expr - = go n orig_expr - where - -- Strip off existing lambdas and casts - -- Note [Eta expansion and SCCs] - go 0 expr = expr - go n (Lam v body) | isTyVar v = Lam v (go n body) - | otherwise = Lam v (go (n-1) body) - go n (Cast expr co) = Cast (go n expr) co - go n expr - = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ - retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas) - where - in_scope = mkInScopeSet (exprFreeVars expr) - (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) - subst' = mkEmptySubst in_scope' - - -- Find ticks behind type apps. - -- See Note [Eta expansion and source notes] - (expr', args) = collectArgs expr - (ticks, expr'') = stripTicksTop tickishFloatable expr' - sexpr = foldl' App expr'' args - retick expr = foldr mkTick expr ticks - - -- Abstraction Application --------------- -data EtaInfo = EtaVar Var -- /\a. [] [] a - -- \x. [] [] x - | EtaCo Coercion -- [] |> sym co [] |> co - -instance Outputable EtaInfo where - ppr (EtaVar v) = text "EtaVar" <+> ppr v - ppr (EtaCo co) = text "EtaCo" <+> ppr co - -pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] -pushCoercion co1 (EtaCo co2 : eis) - | isReflCo co = eis - | otherwise = EtaCo co : eis - where - co = co1 `mkTransCo` co2 - -pushCoercion co eis = EtaCo co : eis - --------------- -etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr -etaInfoAbs [] expr = expr -etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) -etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) - --------------- -etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr --- (etaInfoApp s e eis) returns something equivalent to --- ((substExpr s e) `appliedto` eis) - -etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) - = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis - -etaInfoApp subst (Cast e co1) eis - = etaInfoApp subst e (pushCoercion co' eis) - where - co' = CoreSubst.substCo subst co1 - -etaInfoApp subst (Case e b ty alts) eis - = Case (subst_expr subst e) b1 ty' alts' - where - (subst1, b1) = substBndr subst b - alts' = map subst_alt alts - ty' = etaInfoAppTy (CoreSubst.substTy subst ty) eis - subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) - where - (subst2,bs') = substBndrs subst1 bs - -etaInfoApp subst (Let b e) eis - | not (isJoinBind b) - -- See Note [Eta expansion for join points] - = Let b' (etaInfoApp subst' e eis) - where - (subst', b') = substBindSC subst b - -etaInfoApp subst (Tick t e) eis - = Tick (substTickish subst t) (etaInfoApp subst e eis) - -etaInfoApp subst expr _ - | (Var fun, _) <- collectArgs expr - , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun - , isJoinId fun' - = subst_expr subst expr - -etaInfoApp subst e eis - = go (subst_expr subst e) eis - where - go e [] = e - go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis - go e (EtaCo co : eis) = go (Cast e co) eis - - --------------- -etaInfoAppTy :: Type -> [EtaInfo] -> Type --- If e :: ty --- then etaInfoApp e eis :: etaInfoApp ty eis -etaInfoAppTy ty [] = ty -etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis -etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (pSnd (coercionKind co)) eis - --------------- -mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type - -> (InScopeSet, [EtaInfo]) - -- EtaInfo contains fresh variables, - -- not free in the incoming CoreExpr - -- Outgoing InScopeSet includes the EtaInfo vars - -- and the original free vars - -mkEtaWW orig_n orig_expr in_scope orig_ty - = go orig_n empty_subst orig_ty [] - where - empty_subst = mkEmptyTCvSubst in_scope - - go :: Arity -- Number of value args to expand to - -> TCvSubst -> Type -- We are really looking at subst(ty) - -> [EtaInfo] -- Accumulating parameter - -> (InScopeSet, [EtaInfo]) - go n subst ty eis -- See Note [exprArity invariant] - - ----------- Done! No more expansion needed - | n == 0 - = (getTCvInScope subst, reverse eis) - - ----------- Forall types (forall a. ty) - | Just (tcv,ty') <- splitForAllTy_maybe ty - , let (subst', tcv') = Type.substVarBndr subst tcv - = let ((n_subst, n_tcv), n_n) - -- We want to have at least 'n' lambdas at the top. - -- If tcv is a tyvar, it corresponds to one Lambda (/\). - -- And we won't reduce n. - -- If tcv is a covar, we could eta-expand the expr with one - -- lambda \co:ty. e co. In this case we generate a new variable - -- of the coercion type, update the scope, and reduce n by 1. - | isTyVar tcv = ((subst', tcv'), n) - | otherwise = (freshEtaId n subst' (varType tcv'), n-1) - -- Avoid free vars of the original expression - in go n_n n_subst ty' (EtaVar n_tcv : eis) - - ----------- Function types (t1 -> t2) - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , not (isTypeLevPoly arg_ty) - -- See Note [Levity polymorphism invariants] in CoreSyn - -- See also test case typecheck/should_run/EtaExpandLevPoly - - , let (subst', eta_id') = freshEtaId n subst arg_ty - -- Avoid free vars of the original expression - = go (n-1) subst' res_ty (EtaVar eta_id' : eis) - - ----------- Newtypes - -- Given this: - -- newtype T = MkT ([T] -> Int) - -- Consider eta-expanding this - -- eta_expand 1 e T - -- We want to get - -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - | Just (co, ty') <- topNormaliseNewType_maybe ty - , let co' = Coercion.substCo subst co - -- Remember to apply the substitution to co (#16979) - -- (or we could have applied to ty, but then - -- we'd have had to zap it for the recursive call) - = go n subst ty' (pushCoercion co' eis) - - | otherwise -- We have an expression of arity > 0, - -- but its type isn't a function, or a binder - -- is levity-polymorphic - = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) - (getTCvInScope subst, reverse eis) - -- This *can* legitmately happen: - -- e.g. coerce Int (\x. x) Essentially the programmer is - -- playing fast and loose with types (Happy does this a lot). - -- So we simply decline to eta-expand. Otherwise we'd end up - -- with an explicit lambda having a non-function type - - - --------------- --- Don't use short-cutting substitution - we may be changing the types of join --- points, so applying the in-scope set is necessary --- TODO Check if we actually *are* changing any join points' types - -subst_expr :: Subst -> CoreExpr -> CoreExpr -subst_expr = substExpr (text "CoreArity:substExpr") - - --------------- - --- | Split an expression into the given number of binders and a body, --- eta-expanding if necessary. Counts value *and* type binders. -etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) -etaExpandToJoinPoint join_arity expr - = go join_arity [] expr - where - go 0 rev_bs e = (reverse rev_bs, e) - go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e - go n rev_bs e = case etaBodyForJoinPoint n e of - (bs, e') -> (reverse rev_bs ++ bs, e') - -etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule -etaExpandToJoinPointRule _ rule@(BuiltinRule {}) - = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule])) - -- How did a local binding get a built-in rule anyway? Probably a plugin. - rule -etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs - , ru_args = args }) - | need_args == 0 - = rule - | need_args < 0 - = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) - | otherwise - = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args - , ru_rhs = new_rhs } - where - need_args = join_arity - length args - (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs - new_args = varsToCoreExprs new_bndrs - --- Adds as many binders as asked for; assumes expr is not a lambda -etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) -etaBodyForJoinPoint need_args body - = go need_args (exprType body) (init_subst body) [] body - where - go 0 _ _ rev_bs e - = (reverse rev_bs, e) - go n ty subst rev_bs e - | Just (tv, res_ty) <- splitForAllTy_maybe ty - , let (subst', tv') = Type.substVarBndr subst tv - = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , let (subst', b) = freshEtaId n subst arg_ty - = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) - | otherwise - = pprPanic "etaBodyForJoinPoint" $ int need_args $$ - ppr body $$ ppr (exprType body) - - init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) - --------------- -freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id) --- Make a fresh Id, with specified type (after applying substitution) --- It should be "fresh" in the sense that it's not in the in-scope set --- of the TvSubstEnv; and it should itself then be added to the in-scope --- set of the TvSubstEnv --- --- The Int is just a reasonable starting point for generating a unique; --- it does not necessarily have to be unique itself. -freshEtaId n subst ty - = (subst', eta_id') - where - ty' = Type.substTyUnchecked subst ty - eta_id' = uniqAway (getTCvInScope subst) $ - mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' - subst' = extendTCvInScope subst eta_id' diff --git a/coreSyn/CoreFVs.hs b/coreSyn/CoreFVs.hs deleted file mode 100644 --- a/coreSyn/CoreFVs.hs +++ /dev/null @@ -1,778 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Taken quite directly from the Peyton Jones/Lester paper. --} - -{-# LANGUAGE CPP #-} - --- | A module concerned with finding the free variables of an expression. -module CoreFVs ( - -- * Free variables of expressions and binding groups - exprFreeVars, - exprFreeVarsDSet, - exprFreeVarsList, - exprFreeIds, - exprFreeIdsDSet, - exprFreeIdsList, - exprsFreeIdsDSet, - exprsFreeIdsList, - exprsFreeVars, - exprsFreeVarsList, - bindFreeVars, - - -- * Selective free variables of expressions - InterestingVarFun, - exprSomeFreeVars, exprsSomeFreeVars, - exprSomeFreeVarsList, exprsSomeFreeVarsList, - - -- * Free variables of Rules, Vars and Ids - varTypeTyCoVars, - varTypeTyCoFVs, - idUnfoldingVars, idFreeVars, dIdFreeVars, - bndrRuleAndUnfoldingVarsDSet, - idFVs, - idRuleVars, idRuleRhsVars, stableUnfoldingVars, - ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, - rulesFreeVarsDSet, - ruleLhsFreeIds, ruleLhsFreeIdsList, - - expr_fvs, - - -- * Orphan names - orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, - orphNamesOfTypes, orphNamesOfCoCon, - exprsOrphNames, orphNamesOfFamInst, - - -- * Core syntax tree annotation with free variables - FVAnn, -- annotation, abstract - CoreExprWithFVs, -- = AnnExpr Id FVAnn - CoreExprWithFVs', -- = AnnExpr' Id FVAnn - CoreBindWithFVs, -- = AnnBind Id FVAnn - CoreAltWithFVs, -- = AnnAlt Id FVAnn - freeVars, -- CoreExpr -> CoreExprWithFVs - freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs) - freeVarsOf, -- CoreExprWithFVs -> DIdSet - freeVarsOfAnn - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import Id -import IdInfo -import NameSet -import UniqSet -import Unique (Uniquable (..)) -import Name -import VarSet -import Var -import Type -import TyCoRep -import TyCoFVs -import TyCon -import CoAxiom -import FamInstEnv -import TysPrim( funTyConName ) -import Maybes( orElse ) -import Util -import BasicTypes( Activation ) -import Outputable -import FV - -{- -************************************************************************ -* * -\section{Finding the free variables of an expression} -* * -************************************************************************ - -This function simply finds the free variables of an expression. -So far as type variables are concerned, it only finds tyvars that are - - * free in type arguments, - * free in the type of a binder, - -but not those that are free in the type of variable occurrence. --} - --- | Find all locally-defined free Ids or type variables in an expression --- returning a non-deterministic set. -exprFreeVars :: CoreExpr -> VarSet -exprFreeVars = fvVarSet . exprFVs - --- | Find all locally-defined free Ids or type variables in an expression --- returning a composable FV computation. See Note [FV naming conventions] in FV --- for why export it. -exprFVs :: CoreExpr -> FV -exprFVs = filterFV isLocalVar . expr_fvs - --- | Find all locally-defined free Ids or type variables in an expression --- returning a deterministic set. -exprFreeVarsDSet :: CoreExpr -> DVarSet -exprFreeVarsDSet = fvDVarSet . exprFVs - --- | Find all locally-defined free Ids or type variables in an expression --- returning a deterministically ordered list. -exprFreeVarsList :: CoreExpr -> [Var] -exprFreeVarsList = fvVarList . exprFVs - --- | Find all locally-defined free Ids in an expression -exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids -exprFreeIds = exprSomeFreeVars isLocalId - --- | Find all locally-defined free Ids in an expression --- returning a deterministic set. -exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids -exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId - --- | Find all locally-defined free Ids in an expression --- returning a deterministically ordered list. -exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids -exprFreeIdsList = exprSomeFreeVarsList isLocalId - --- | Find all locally-defined free Ids in several expressions --- returning a deterministic set. -exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids -exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId - --- | Find all locally-defined free Ids in several expressions --- returning a deterministically ordered list. -exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids -exprsFreeIdsList = exprsSomeFreeVarsList isLocalId - --- | Find all locally-defined free Ids or type variables in several expressions --- returning a non-deterministic set. -exprsFreeVars :: [CoreExpr] -> VarSet -exprsFreeVars = fvVarSet . exprsFVs - --- | Find all locally-defined free Ids or type variables in several expressions --- returning a composable FV computation. See Note [FV naming conventions] in FV --- for why export it. -exprsFVs :: [CoreExpr] -> FV -exprsFVs exprs = mapUnionFV exprFVs exprs - --- | Find all locally-defined free Ids or type variables in several expressions --- returning a deterministically ordered list. -exprsFreeVarsList :: [CoreExpr] -> [Var] -exprsFreeVarsList = fvVarList . exprsFVs - --- | Find all locally defined free Ids in a binding group -bindFreeVars :: CoreBind -> VarSet -bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) -bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ - addBndrs (map fst prs) - (mapUnionFV rhs_fvs prs) - --- | Finds free variables in an expression selected by a predicate -exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> CoreExpr - -> VarSet -exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e - --- | Finds free variables in an expression selected by a predicate --- returning a deterministically ordered list. -exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> CoreExpr - -> [Var] -exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e - --- | Finds free variables in an expression selected by a predicate --- returning a deterministic set. -exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> CoreExpr - -> DVarSet -exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e - --- | Finds free variables in several expressions selected by a predicate -exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting - -> [CoreExpr] - -> VarSet -exprsSomeFreeVars fv_cand es = - fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es - --- | Finds free variables in several expressions selected by a predicate --- returning a deterministically ordered list. -exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting - -> [CoreExpr] - -> [Var] -exprsSomeFreeVarsList fv_cand es = - fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es - --- | Finds free variables in several expressions selected by a predicate --- returning a deterministic set. -exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> [CoreExpr] - -> DVarSet -exprsSomeFreeVarsDSet fv_cand e = - fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e - --- Comment about obselete code --- We used to gather the free variables the RULES at a variable occurrence --- with the following cryptic comment: --- "At a variable occurrence, add in any free variables of its rule rhss --- Curiously, we gather the Id's free *type* variables from its binding --- site, but its free *rule-rhs* variables from its usage sites. This --- is a little weird. The reason is that the former is more efficient, --- but the latter is more fine grained, and a makes a difference when --- a variable mentions itself one of its own rule RHSs" --- Not only is this "weird", but it's also pretty bad because it can make --- a function seem more recursive than it is. Suppose --- f = ...g... --- g = ... --- RULE g x = ...f... --- Then f is not mentioned in its own RHS, and needn't be a loop breaker --- (though g may be). But if we collect the rule fvs from g's occurrence, --- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB --- code in GHC.Enum.) --- --- Anyway, it seems plain wrong. The RULE is like an extra RHS for the --- function, so its free variables belong at the definition site. --- --- Deleted code looked like --- foldVarSet add_rule_var var_itself_set (idRuleVars var) --- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var --- | otherwise = set --- SLPJ Feb06 - -addBndr :: CoreBndr -> FV -> FV -addBndr bndr fv fv_cand in_scope acc - = (varTypeTyCoFVs bndr `unionFV` - -- Include type variables in the binder's type - -- (not just Ids; coercion variables too!) - FV.delFV bndr fv) fv_cand in_scope acc - -addBndrs :: [CoreBndr] -> FV -> FV -addBndrs bndrs fv = foldr addBndr fv bndrs - -expr_fvs :: CoreExpr -> FV -expr_fvs (Type ty) fv_cand in_scope acc = - tyCoFVsOfType ty fv_cand in_scope acc -expr_fvs (Coercion co) fv_cand in_scope acc = - tyCoFVsOfCo co fv_cand in_scope acc -expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc -expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -expr_fvs (Tick t expr) fv_cand in_scope acc = - (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc -expr_fvs (App fun arg) fv_cand in_scope acc = - (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc -expr_fvs (Lam bndr body) fv_cand in_scope acc = - addBndr bndr (expr_fvs body) fv_cand in_scope acc -expr_fvs (Cast expr co) fv_cand in_scope acc = - (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc - -expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc - = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr - (mapUnionFV alt_fvs alts)) fv_cand in_scope acc - where - alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) - -expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc - = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) - fv_cand in_scope acc - -expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc - = addBndrs (map fst pairs) - (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) - fv_cand in_scope acc - ---------- -rhs_fvs :: (Id, CoreExpr) -> FV -rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` - bndrRuleAndUnfoldingFVs bndr - -- Treat any RULES as extra RHSs of the binding - ---------- -exprs_fvs :: [CoreExpr] -> FV -exprs_fvs exprs = mapUnionFV expr_fvs exprs - -tickish_fvs :: Tickish Id -> FV -tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids -tickish_fvs _ = emptyFV - -{- -************************************************************************ -* * -\section{Free names} -* * -************************************************************************ --} - --- | Finds the free /external/ names of an expression, notably --- including the names of type constructors (which of course do not show --- up in 'exprFreeVars'). -exprOrphNames :: CoreExpr -> NameSet --- There's no need to delete local binders, because they will all --- be /internal/ names. -exprOrphNames e - = go e - where - go (Var v) - | isExternalName n = unitNameSet n - | otherwise = emptyNameSet - where n = idName v - go (Lit _) = emptyNameSet - go (Type ty) = orphNamesOfType ty -- Don't need free tyvars - go (Coercion co) = orphNamesOfCo co - go (App e1 e2) = go e1 `unionNameSet` go e2 - go (Lam v e) = go e `delFromNameSet` idName v - go (Tick _ e) = go e - go (Cast e co) = go e `unionNameSet` orphNamesOfCo co - go (Let (NonRec _ r) e) = go e `unionNameSet` go r - go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e - go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty - `unionNameSet` unionNameSets (map go_alt as) - - go_alt (_,_,r) = go r - --- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details -exprsOrphNames :: [CoreExpr] -> NameSet -exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es - - -{- ********************************************************************** -%* * - orphNamesXXX - -%* * -%********************************************************************* -} - -orphNamesOfTyCon :: TyCon -> NameSet -orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of - Nothing -> emptyNameSet - Just cls -> unitNameSet (getName cls) - -orphNamesOfType :: Type -> NameSet -orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' - -- Look through type synonyms (#4912) -orphNamesOfType (TyVarTy _) = emptyNameSet -orphNamesOfType (LitTy {}) = emptyNameSet -orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon - `unionNameSet` orphNamesOfTypes tys -orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) - `unionNameSet` orphNamesOfType res -orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See #8535 - `unionNameSet` orphNamesOfType arg - `unionNameSet` orphNamesOfType res -orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg -orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co -orphNamesOfType (CoercionTy co) = orphNamesOfCo co - -orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet -orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet - -orphNamesOfTypes :: [Type] -> NameSet -orphNamesOfTypes = orphNamesOfThings orphNamesOfType - -orphNamesOfMCo :: MCoercion -> NameSet -orphNamesOfMCo MRefl = emptyNameSet -orphNamesOfMCo (MCo co) = orphNamesOfCo co - -orphNamesOfCo :: Coercion -> NameSet -orphNamesOfCo (Refl ty) = orphNamesOfType ty -orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco -orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (ForAllCo _ kind_co co) - = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co -orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (CoVarCo _) = emptyNameSet -orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 -orphNamesOfCo (SymCo co) = orphNamesOfCo co -orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co -orphNamesOfCo (LRCo _ co) = orphNamesOfCo co -orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg -orphNamesOfCo (KindCo co) = orphNamesOfCo co -orphNamesOfCo (SubCo co) = orphNamesOfCo co -orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs -orphNamesOfCo (HoleCo _) = emptyNameSet - -orphNamesOfProv :: UnivCoProvenance -> NameSet -orphNamesOfProv UnsafeCoerceProv = emptyNameSet -orphNamesOfProv (PhantomProv co) = orphNamesOfCo co -orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co -orphNamesOfProv (PluginProv _) = emptyNameSet - -orphNamesOfCos :: [Coercion] -> NameSet -orphNamesOfCos = orphNamesOfThings orphNamesOfCo - -orphNamesOfCoCon :: CoAxiom br -> NameSet -orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches - -orphNamesOfAxiom :: CoAxiom br -> NameSet -orphNamesOfAxiom axiom - = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) - `extendNameSet` getName (coAxiomTyCon axiom) - -orphNamesOfCoAxBranches :: Branches br -> NameSet -orphNamesOfCoAxBranches - = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches - -orphNamesOfCoAxBranch :: CoAxBranch -> NameSet -orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) - = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs - --- | orphNamesOfAxiom collects the names of the concrete types and --- type constructors that make up the LHS of a type family instance, --- including the family name itself. --- --- For instance, given `type family Foo a b`: --- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] --- --- Used in the implementation of ":info" in GHCi. -orphNamesOfFamInst :: FamInst -> NameSet -orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) - -{- -************************************************************************ -* * -\section[freevars-everywhere]{Attaching free variables to every sub-expression} -* * -************************************************************************ --} - --- | Those variables free in the right hand side of a rule returned as a --- non-deterministic set -ruleRhsFreeVars :: CoreRule -> VarSet -ruleRhsFreeVars (BuiltinRule {}) = noFVs -ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) - = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) - -- See Note [Rule free var hack] - --- | Those variables free in the both the left right hand sides of a rule --- returned as a non-deterministic set -ruleFreeVars :: CoreRule -> VarSet -ruleFreeVars = fvVarSet . ruleFVs - --- | Those variables free in the both the left right hand sides of a rule --- returned as FV computation -ruleFVs :: CoreRule -> FV -ruleFVs (BuiltinRule {}) = emptyFV -ruleFVs (Rule { ru_fn = _do_not_include - -- See Note [Rule free var hack] - , ru_bndrs = bndrs - , ru_rhs = rhs, ru_args = args }) - = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) - --- | Those variables free in the both the left right hand sides of rules --- returned as FV computation -rulesFVs :: [CoreRule] -> FV -rulesFVs = mapUnionFV ruleFVs - --- | Those variables free in the both the left right hand sides of rules --- returned as a deterministic set -rulesFreeVarsDSet :: [CoreRule] -> DVarSet -rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules - -idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet --- Just the variables free on the *rhs* of a rule -idRuleRhsVars is_active id - = mapUnionVarSet get_fvs (idCoreRules id) - where - get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs - , ru_rhs = rhs, ru_act = act }) - | is_active act - -- See Note [Finding rule RHS free vars] in OccAnal.hs - = delOneFromUniqSet_Directly fvs (getUnique fn) - -- Note [Rule free var hack] - where - fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) - get_fvs _ = noFVs - --- | Those variables free in the right hand side of several rules -rulesFreeVars :: [CoreRule] -> VarSet -rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules - -ruleLhsFreeIds :: CoreRule -> VarSet --- ^ This finds all locally-defined free Ids on the left hand side of a rule --- and returns them as a non-deterministic set -ruleLhsFreeIds = fvVarSet . ruleLhsFVIds - -ruleLhsFreeIdsList :: CoreRule -> [Var] --- ^ This finds all locally-defined free Ids on the left hand side of a rule --- and returns them as a determinisitcally ordered list -ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds - -ruleLhsFVIds :: CoreRule -> FV --- ^ This finds all locally-defined free Ids on the left hand side of a rule --- and returns an FV computation -ruleLhsFVIds (BuiltinRule {}) = emptyFV -ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args }) - = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args) - -{- -Note [Rule free var hack] (Not a hack any more) -~~~~~~~~~~~~~~~~~~~~~~~~~ -We used not to include the Id in its own rhs free-var set. -Otherwise the occurrence analyser makes bindings recursive: - f x y = x+y - RULE: f (f x y) z ==> f x (f y z) -However, the occurrence analyser distinguishes "non-rule loop breakers" -from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will -put this 'f' in a Rec block, but will mark the binding as a non-rule loop -breaker, which is perfectly inlinable. --} - -{- -************************************************************************ -* * -\section[freevars-everywhere]{Attaching free variables to every sub-expression} -* * -************************************************************************ - -The free variable pass annotates every node in the expression with its -NON-GLOBAL free variables and type variables. --} - -type FVAnn = DVarSet -- See Note [The FVAnn invariant] - -{- Note [The FVAnn invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariant: a FVAnn, say S, is closed: - That is: if v is in S, - then freevars( v's type/kind ) is also in S --} - --- | Every node in a binding group annotated with its --- (non-global) free variables, both Ids and TyVars, and type. -type CoreBindWithFVs = AnnBind Id FVAnn - --- | Every node in an expression annotated with its --- (non-global) free variables, both Ids and TyVars, and type. --- NB: see Note [The FVAnn invariant] -type CoreExprWithFVs = AnnExpr Id FVAnn -type CoreExprWithFVs' = AnnExpr' Id FVAnn - --- | Every node in an expression annotated with its --- (non-global) free variables, both Ids and TyVars, and type. -type CoreAltWithFVs = AnnAlt Id FVAnn - -freeVarsOf :: CoreExprWithFVs -> DIdSet --- ^ Inverse function to 'freeVars' -freeVarsOf (fvs, _) = fvs - --- | Extract the vars reported in a FVAnn -freeVarsOfAnn :: FVAnn -> DIdSet -freeVarsOfAnn fvs = fvs - -noFVs :: VarSet -noFVs = emptyVarSet - -aFreeVar :: Var -> DVarSet -aFreeVar = unitDVarSet - -unionFVs :: DVarSet -> DVarSet -> DVarSet -unionFVs = unionDVarSet - -unionFVss :: [DVarSet] -> DVarSet -unionFVss = unionDVarSets - -delBindersFV :: [Var] -> DVarSet -> DVarSet -delBindersFV bs fvs = foldr delBinderFV fvs bs - -delBinderFV :: Var -> DVarSet -> DVarSet --- This way round, so we can do it multiple times using foldr - --- (b `delBinderFV` s) --- * removes the binder b from the free variable set s, --- * AND *adds* to s the free variables of b's type --- --- This is really important for some lambdas: --- In (\x::a -> x) the only mention of "a" is in the binder. --- --- Also in --- let x::a = b in ... --- we should really note that "a" is free in this expression. --- It'll be pinned inside the /\a by the binding for b, but --- it seems cleaner to make sure that a is in the free-var set --- when it is mentioned. --- --- This also shows up in recursive bindings. Consider: --- /\a -> letrec x::a = x in E --- Now, there are no explicit free type variables in the RHS of x, --- but nevertheless "a" is free in its definition. So we add in --- the free tyvars of the types of the binders, and include these in the --- free vars of the group, attached to the top level of each RHS. --- --- This actually happened in the defn of errorIO in IOBase.hs: --- errorIO (ST io) = case (errorIO# io) of --- _ -> bottom --- where --- bottom = bottom -- Never evaluated - -delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b - -- Include coercion variables too! - -varTypeTyCoVars :: Var -> TyCoVarSet --- Find the type/kind variables free in the type of the id/tyvar -varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var - -dVarTypeTyCoVars :: Var -> DTyCoVarSet --- Find the type/kind/coercion variables free in the type of the id/tyvar -dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var - -varTypeTyCoFVs :: Var -> FV -varTypeTyCoFVs var = tyCoFVsOfType (varType var) - -idFreeVars :: Id -> VarSet -idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id - -dIdFreeVars :: Id -> DVarSet -dIdFreeVars id = fvDVarSet $ idFVs id - -idFVs :: Id -> FV --- Type variables, rule variables, and inline variables -idFVs id = ASSERT( isId id) - varTypeTyCoFVs id `unionFV` - bndrRuleAndUnfoldingFVs id - -bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet -bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id - -bndrRuleAndUnfoldingFVs :: Id -> FV -bndrRuleAndUnfoldingFVs id - | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id - | otherwise = emptyFV - -idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars -idRuleVars id = fvVarSet $ idRuleFVs id - -idRuleFVs :: Id -> FV -idRuleFVs id = ASSERT( isId id) - FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) - -idUnfoldingVars :: Id -> VarSet --- Produce free vars for an unfolding, but NOT for an ordinary --- (non-inline) unfolding, since it is a dup of the rhs --- and we'll get exponential behaviour if we look at both unf and rhs! --- But do look at the *real* unfolding, even for loop breakers, else --- we might get out-of-scope variables -idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id - -idUnfoldingFVs :: Id -> FV -idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV - -stableUnfoldingVars :: Unfolding -> Maybe VarSet -stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf - -stableUnfoldingFVs :: Unfolding -> Maybe FV -stableUnfoldingFVs unf - = case unf of - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isStableSource src - -> Just (filterFV isLocalVar $ expr_fvs rhs) - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args) - -- DFuns are top level, so no fvs from types of bndrs - _other -> Nothing - - -{- -************************************************************************ -* * -\subsection{Free variables (and types)} -* * -************************************************************************ --} - -freeVarsBind :: CoreBind - -> DVarSet -- Free vars of scope of binding - -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope -freeVarsBind (NonRec binder rhs) body_fvs - = ( AnnNonRec binder rhs2 - , freeVarsOf rhs2 `unionFVs` body_fvs2 - `unionFVs` bndrRuleAndUnfoldingVarsDSet binder ) - where - rhs2 = freeVars rhs - body_fvs2 = binder `delBinderFV` body_fvs - -freeVarsBind (Rec binds) body_fvs - = ( AnnRec (binders `zip` rhss2) - , delBindersFV binders all_fvs ) - where - (binders, rhss) = unzip binds - rhss2 = map freeVars rhss - rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 - binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders - -- See Note [The FVAnn invariant] - all_fvs = rhs_body_fvs `unionFVs` binders_fvs - -- The "delBinderFV" happens after adding the idSpecVars, - -- since the latter may add some of the binders as fvs - -freeVars :: CoreExpr -> CoreExprWithFVs --- ^ Annotate a 'CoreExpr' with its (non-global) free type --- and value variables at every tree node. -freeVars = go - where - go :: CoreExpr -> CoreExprWithFVs - go (Var v) - | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v) - | otherwise = (emptyDVarSet, AnnVar v) - where - ty_fvs = dVarTypeTyCoVars v - -- See Note [The FVAnn invariant] - - go (Lit lit) = (emptyDVarSet, AnnLit lit) - go (Lam b body) - = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs) - , AnnLam b body' ) - where - body'@(body_fvs, _) = go body - b_ty = idType b - b_fvs = tyCoVarsOfTypeDSet b_ty - -- See Note [The FVAnn invariant] - - go (App fun arg) - = ( freeVarsOf fun' `unionFVs` freeVarsOf arg' - , AnnApp fun' arg' ) - where - fun' = go fun - arg' = go arg - - go (Case scrut bndr ty alts) - = ( (bndr `delBinderFV` alts_fvs) - `unionFVs` freeVarsOf scrut2 - `unionFVs` tyCoVarsOfTypeDSet ty - -- Don't need to look at (idType bndr) - -- because that's redundant with scrut - , AnnCase scrut2 bndr ty alts2 ) - where - scrut2 = go scrut - - (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts - alts_fvs = unionFVss alts_fvs_s - - fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), - (con, args, rhs2)) - where - rhs2 = go rhs - - go (Let bind body) - = (bind_fvs, AnnLet bind2 body2) - where - (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2) - body2 = go body - - go (Cast expr co) - = ( freeVarsOf expr2 `unionFVs` cfvs - , AnnCast expr2 (cfvs, co) ) - where - expr2 = go expr - cfvs = tyCoVarsOfCoDSet co - - go (Tick tickish expr) - = ( tickishFVs tickish `unionFVs` freeVarsOf expr2 - , AnnTick tickish expr2 ) - where - expr2 = go expr - tickishFVs (Breakpoint _ ids) = mkDVarSet ids - tickishFVs _ = emptyDVarSet - - go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) - go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) diff --git a/coreSyn/CoreLint.hs b/coreSyn/CoreLint.hs deleted file mode 100644 --- a/coreSyn/CoreLint.hs +++ /dev/null @@ -1,2797 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - -A ``lint'' pass to check for Core correctness. -See Note [Core Lint guarantee]. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module CoreLint ( - lintCoreBindings, lintUnfolding, - lintPassResult, lintInteractiveExpr, lintExpr, - lintAnnots, lintTypes, - - -- ** Debug output - endPass, endPassIO, - dumpPassResult, - CoreLint.dumpIfSet, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreFVs -import CoreUtils -import CoreStats ( coreBindsStats ) -import CoreMonad -import Bag -import Literal -import DataCon -import TysWiredIn -import TysPrim -import TcType ( isFloatingTy ) -import Var -import VarEnv -import VarSet -import Name -import Id -import IdInfo -import PprCore -import ErrUtils -import Coercion -import SrcLoc -import Type -import RepType -import TyCoRep -- checks validity of types/coercions -import TyCoSubst -import TyCoFVs -import TyCoPpr ( pprTyVar ) -import TyCon -import CoAxiom -import BasicTypes -import ErrUtils as Err -import ListSetOps -import PrelNames -import Outputable -import FastString -import Util -import InstEnv ( instanceDFunId ) -import OptCoercion ( checkAxInstCo ) -import CoreArity ( typeArity ) -import Demand ( splitStrictSig, isBotRes ) - -import HscTypes -import DynFlags -import Control.Monad -import qualified Control.Monad.Fail as MonadFail -import MonadUtils -import Data.Foldable ( toList ) -import Data.List.NonEmpty ( NonEmpty ) -import Data.Maybe -import Pair -import qualified GHC.LanguageExtensions as LangExt - -{- -Note [Core Lint guarantee] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Core Lint is the type-checker for Core. Using it, we get the following guarantee: - -If all of: -1. Core Lint passes, -2. there are no unsafe coercions (i.e. UnsafeCoerceProv), -3. all plugin-supplied coercions (i.e. PluginProv) are valid, and -4. all case-matches are complete -then running the compiled program will not seg-fault, assuming no bugs downstream -(e.g. in the code generator). This guarantee is quite powerful, in that it allows us -to decouple the safety of the resulting program from the type inference algorithm. - -However, do note point (4) above. Core Lint does not check for incomplete case-matches; -see Note [Case expression invariants] in CoreSyn, invariant (4). As explained there, -an incomplete case-match might slip by Core Lint and cause trouble at runtime. - -Note [GHC Formalism] -~~~~~~~~~~~~~~~~~~~~ -This file implements the type-checking algorithm for System FC, the "official" -name of the Core language. Type safety of FC is heart of the claim that -executables produced by GHC do not have segmentation faults. Thus, it is -useful to be able to reason about System FC independently of reading the code. -To this purpose, there is a document core-spec.pdf built in docs/core-spec that -contains a formalism of the types and functions dealt with here. If you change -just about anything in this file or you change other types/functions throughout -the Core language (all signposted to this note), you should update that -formalism. See docs/core-spec/README for more info about how to do so. - -Note [check vs lint] -~~~~~~~~~~~~~~~~~~~~ -This file implements both a type checking algorithm and also general sanity -checking. For example, the "sanity checking" checks for TyConApp on the left -of an AppTy, which should never happen. These sanity checks don't really -affect any notion of type soundness. Yet, it is convenient to do the sanity -checks at the same time as the type checks. So, we use the following naming -convention: - -- Functions that begin with 'lint'... are involved in type checking. These - functions might also do some sanity checking. - -- Functions that begin with 'check'... are *not* involved in type checking. - They exist only for sanity checking. - -Issues surrounding variable naming, shadowing, and such are considered *not* -to be part of type checking, as the formalism omits these details. - -Summary of checks -~~~~~~~~~~~~~~~~~ -Checks that a set of core bindings is well-formed. The PprStyle and String -just control what we print in the event of an error. The Bool value -indicates whether we have done any specialisation yet (in which case we do -some extra checks). - -We check for - (a) type errors - (b) Out-of-scope type variables - (c) Out-of-scope local variables - (d) Ill-kinded types - (e) Incorrect unsafe coercions - -If we have done specialisation the we check that there are - (a) No top-level bindings of primitive (unboxed type) - -Outstanding issues: - - -- Things are *not* OK if: - -- - -- * Unsaturated type app before specialisation has been done; - -- - -- * Oversaturated type app after specialisation (eta reduction - -- may well be happening...); - - -Note [Linting function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Representation of function types], all saturated -applications of funTyCon are represented with the FunTy constructor. We check -this invariant in lintType. - -Note [Linting type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Int in -That is, use a type let. See Note [Type let] in CoreSyn. - -However, when linting we need to remember that a=Int, else we might -reject a correct program. So we carry a type substitution (in this example -[a -> Int]) and apply this substitution before comparing types. The functin - lintInTy :: Type -> LintM (Type, Kind) -returns a substituted type. - -When we encounter a binder (like x::a) we must apply the substitution -to the type of the binding variable. lintBinders does this. - -For Ids, the type-substituted Id is added to the in_scope set (which -itself is part of the TCvSubst we are carrying down), and when we -find an occurrence of an Id, we fetch it from the in-scope set. - -Note [Bad unsafe coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions -Linter introduces additional rules that checks improper coercion between -different types, called bad coercions. Following coercions are forbidden: - - (a) coercions between boxed and unboxed values; - (b) coercions between unlifted values of the different sizes, here - active size is checked, i.e. size of the actual value but not - the space allocated for value; - (c) coercions between floating and integral boxed values, this check - is not yet supported for unboxed tuples, as no semantics were - specified for that; - (d) coercions from / to vector type - (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be - coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules - (a-e) holds. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -We check the rules listed in Note [Invariants on join points] in CoreSyn. The -only one that causes any difficulty is the first: All occurrences must be tail -calls. To this end, along with the in-scope set, we remember in le_joins the -subset of in-scope Ids that are valid join ids. For example: - - join j x = ... in - case e of - A -> jump j y -- good - B -> case (jump j z) of -- BAD - C -> join h = jump j w in ... -- good - D -> let x = jump j v in ... -- BAD - -A join point remains valid in case branches, so when checking the A -branch, j is still valid. When we check the scrutinee of the inner -case, however, we set le_joins to empty, and catch the -error. Similarly, join points can occur free in RHSes of other join -points but not the RHSes of value bindings (thunks and functions). - -************************************************************************ -* * - Beginning and ending passes -* * -************************************************************************ - -These functions are not CoreM monad stuff, but they probably ought to -be, and it makes a convenient place for them. They print out stuff -before and after core passes, and do Core Lint when necessary. --} - -endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () -endPass pass binds rules - = do { hsc_env <- getHscEnv - ; print_unqual <- getPrintUnqualified - ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } - -endPassIO :: HscEnv -> PrintUnqualified - -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () --- Used by the IO-is CorePrep too -endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult dflags print_unqual mb_flag - (ppr pass) (pprPassDetails pass) binds rules - ; lintPassResult hsc_env pass binds } - where - dflags = hsc_dflags hsc_env - mb_flag = case coreDumpFlag pass of - Just flag | dopt flag dflags -> Just flag - | dopt Opt_D_verbose_core2core dflags -> Just flag - _ -> Nothing - -dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () -dumpIfSet dflags dump_me pass extra_info doc - = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc - -dumpPassResult :: DynFlags - -> PrintUnqualified - -> Maybe DumpFlag -- Just df => show details in a file whose - -- name is specified by df - -> SDoc -- Header - -> SDoc -- Extra info to appear after header - -> CoreProgram -> [CoreRule] - -> IO () -dumpPassResult dflags unqual mb_flag hdr extra_info binds rules - = do { forM_ mb_flag $ \flag -> - Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc - - -- Report result size - -- This has the side effect of forcing the intermediate to be evaluated - -- if it's not already forced by a -ddump flag. - ; Err.debugTraceMsg dflags 2 size_doc - } - - where - size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] - - dump_doc = vcat [ nest 2 extra_info - , size_doc - , blankLine - , pprCoreBindingsWithSize binds - , ppUnless (null rules) pp_rules ] - pp_rules = vcat [ blankLine - , text "------ Local rules for imported ids --------" - , pprRules rules ] - -coreDumpFlag :: CoreToDo -> Maybe DumpFlag -coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity -coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify -coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal -coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper -coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec -coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec -coreDumpFlag CoreCSE = Just Opt_D_dump_cse -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt -coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep -coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal - -coreDumpFlag CoreDoPrintCore = Nothing -coreDumpFlag (CoreDoRuleCheck {}) = Nothing -coreDumpFlag CoreDoNothing = Nothing -coreDumpFlag (CoreDoPasses {}) = Nothing - -{- -************************************************************************ -* * - Top-level interfaces -* * -************************************************************************ --} - -lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () -lintPassResult hsc_env pass binds - | not (gopt Opt_DoCoreLinting dflags) - = return () - | otherwise - = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds - ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults dflags pass warns errs binds } - where - dflags = hsc_dflags hsc_env - -displayLintResults :: DynFlags -> CoreToDo - -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram - -> IO () -displayLintResults dflags pass warns errs binds - | not (isEmptyBag errs) - = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs - , text "*** Offending Program ***" - , pprCoreBindings binds - , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } - - | not (isEmptyBag warns) - , not (hasNoDebugOutput dflags) - , showLintWarnings pass - -- If the Core linter encounters an error, output to stderr instead of - -- stdout (#13342) - = putLogMsg dflags NoReason Err.SevInfo noSrcSpan - (defaultDumpStyle dflags) - (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) - - | otherwise = return () - where - -lint_banner :: String -> SDoc -> SDoc -lint_banner string pass = text "*** Core Lint" <+> text string - <+> text ": in result of" <+> pass - <+> text "***" - -showLintWarnings :: CoreToDo -> Bool --- Disable Lint warnings on the first simplifier pass, because --- there may be some INLINE knots still tied, which is tiresomely noisy -showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False -showLintWarnings _ = True - -lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () -lintInteractiveExpr what hsc_env expr - | not (gopt Opt_DoCoreLinting dflags) - = return () - | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr - = do { display_lint_err err - ; Err.ghcExit dflags 1 } - | otherwise - = return () - where - dflags = hsc_dflags hsc_env - - display_lint_err err - = do { putLogMsg dflags NoReason Err.SevDump - noSrcSpan (defaultDumpStyle dflags) - (vcat [ lint_banner "errors" (text what) - , err - , text "*** Offending Program ***" - , pprCoreExpr expr - , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } - -interactiveInScope :: HscEnv -> [Var] --- In GHCi we may lint expressions, or bindings arising from 'deriving' --- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes). --- So we have to tell Lint about them, lest it reports them as out of scope. --- --- We do this by find local-named things that may appear free in interactive --- context. This function is pretty revolting and quite possibly not quite right. --- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty --- so this is a (cheap) no-op. --- --- See #8215 for an example -interactiveInScope hsc_env - = tyvars ++ ids - where - -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr - ictxt = hsc_IC hsc_env - (cls_insts, _fam_insts) = ic_instances ictxt - te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) - ids = typeEnvIds te - tyvars = tyCoVarsOfTypesList $ map idType ids - -- Why the type variables? How can the top level envt have free tyvars? - -- I think it's because of the GHCi debugger, which can bind variables - -- f :: [t] -> [t] - -- where t is a RuntimeUnk (see TcType) - --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) --- Returns (warnings, errors) --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreBindings dflags pass local_in_scope binds - = initL dflags flags in_scope_set $ - addLoc TopLevelBindings $ - lintLetBndrs TopLevel binders $ - -- Put all the top-level binders in scope at the start - -- This is because transformation rules can bring something - -- into use 'unexpectedly' - do { checkL (null dups) (dupVars dups) - ; checkL (null ext_dups) (dupExtVars ext_dups) - ; mapM lint_bind binds } - where - in_scope_set = mkInScopeSet (mkVarSet local_in_scope) - - flags = defaultLintFlags - { lf_check_global_ids = check_globals - , lf_check_inline_loop_breakers = check_lbs - , lf_check_static_ptrs = check_static_ptrs } - - -- See Note [Checking for global Ids] - check_globals = case pass of - CoreTidy -> False - CorePrep -> False - _ -> True - - -- See Note [Checking for INLINE loop breakers] - check_lbs = case pass of - CoreDesugar -> False - CoreDesugarOpt -> False - _ -> True - - -- See Note [Checking StaticPtrs] - check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere - | otherwise = case pass of - CoreDoFloatOutwards _ -> AllowAtTopLevel - CoreTidy -> RejectEverywhere - CorePrep -> AllowAtTopLevel - _ -> AllowAnywhere - - binders = bindersOfBinds binds - (_, dups) = removeDups compare binders - - -- dups_ext checks for names with different uniques - -- but but the same External name M.n. We don't - -- allow this at top level: - -- M.n{r3} = ... - -- M.n{r29} = ... - -- because they both get the same linker symbol - ext_dups = snd (removeDups ord_ext (map Var.varName binders)) - ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 - , Just m2 <- nameModule_maybe n2 - = compare (m1, nameOccName n1) (m2, nameOccName n2) - | otherwise = LT - - -- If you edit this function, you may need to update the GHC formalism - -- See Note [GHC Formalism] - lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs - lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) - -{- -************************************************************************ -* * -\subsection[lintUnfolding]{lintUnfolding} -* * -************************************************************************ - -Note [Linting Unfoldings from Interfaces] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We use this to check all top-level unfoldings that come in from interfaces -(it is very painful to catch errors otherwise). - -We do not need to call lintUnfolding on unfoldings that are nested within -top-level unfoldings; they are linted when we lint the top-level unfolding; -hence the `TopLevelFlag` on `tcPragExpr` in TcIface. - --} - -lintUnfolding :: DynFlags - -> SrcLoc - -> VarSet -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintUnfolding dflags locn vars expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - in_scope = mkInScopeSet vars - (_warns, errs) = initL dflags defaultLintFlags in_scope linter - linter = addLoc (ImportedUnfolding locn) $ - lintCoreExpr expr - -lintExpr :: DynFlags - -> [Var] -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintExpr dflags vars expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - in_scope = mkInScopeSet (mkVarSet vars) - (_warns, errs) = initL dflags defaultLintFlags in_scope linter - linter = addLoc TopLevelBindings $ - lintCoreExpr expr - -{- -************************************************************************ -* * -\subsection[lintCoreBinding]{lintCoreBinding} -* * -************************************************************************ - -Check a core binding, returning the list of variables bound. --} - -lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintSingleBinding top_lvl_flag rec_flag (binder,rhs) - = addLoc (RhsOf binder) $ - -- Check the rhs - do { ty <- lintRhs binder rhs - ; binder_ty <- applySubstTy (idType binder) - ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty) - - -- If the binding is for a CoVar, the RHS should be (Coercion co) - -- See Note [CoreSyn type and coercion invariant] in CoreSyn - ; checkL (not (isCoVar binder) || isCoArg rhs) - (mkLetErr binder rhs) - - -- Check that it's not levity-polymorphic - -- Do this first, because otherwise isUnliftedType panics - -- Annoyingly, this duplicates the test in lintIdBdr, - -- because for non-rec lets we call lintSingleBinding first - ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty)) - (badBndrTyMsg binder (text "levity-polymorphic")) - - -- Check the let/app invariant - -- See Note [CoreSyn let/app invariant] in CoreSyn - ; checkL ( isJoinId binder - || not (isUnliftedType binder_ty) - || (isNonRec rec_flag && exprOkForSpeculation rhs) - || exprIsTickedString rhs) - (badBndrTyMsg binder (text "unlifted")) - - -- Check that if the binder is top-level or recursive, it's not - -- demanded. Primitive string literals are exempt as there is no - -- computation to perform, see Note [CoreSyn top-level string literals]. - ; checkL (not (isStrictId binder) - || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)) - || exprIsTickedString rhs) - (mkStrictMsg binder) - - -- Check that if the binder is at the top level and has type Addr#, - -- that it is a string literal, see - -- Note [CoreSyn top-level string literals]. - ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy) - || exprIsTickedString rhs) - (mkTopNonLitStrMsg binder) - - ; flags <- getLintFlags - - -- Check that a join-point binder has a valid type - -- NB: lintIdBinder has checked that it is not top-level bound - ; case isJoinId_maybe binder of - Nothing -> return () - Just arity -> checkL (isValidJoinPointType arity binder_ty) - (mkInvalidJoinPointMsg binder binder_ty) - - ; when (lf_check_inline_loop_breakers flags - && isStableUnfolding (realIdUnfolding binder) - && isStrongLoopBreaker (idOccInfo binder) - && isInlinePragma (idInlinePragma binder)) - (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) - -- Only non-rule loop breakers inhibit inlining - - -- We used to check that the dmdTypeDepth of a demand signature never - -- exceeds idArity, but that is an unnecessary complication, see - -- Note [idArity varies independently of dmdTypeDepth] in DmdAnal - - -- Check that the binder's arity is within the bounds imposed by - -- the type and the strictness signature. See Note [exprArity invariant] - -- and Note [Trimming arity] - ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds typeArity" <+> - ppr (length (typeArity (idType binder))) <> colon <+> - ppr binder) - - ; case splitStrictSig (idStrictness binder) of - (demands, result_info) | isBotRes result_info -> - checkL (demands `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds arity imposed by the strictness signature" <+> - ppr (idStrictness binder) <> colon <+> - ppr binder) - _ -> return () - - ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) - - ; addLoc (UnfoldingOf binder) $ - lintIdUnfolding binder binder_ty (idUnfolding binder) } - - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. - --- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' --- in that it doesn't reject occurrences of the function 'makeStatic' when they --- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and --- for join points, it skips the outer lambdas that take arguments to the --- join point. --- --- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM OutType -lintRhs bndr rhs - | Just arity <- isJoinId_maybe bndr - = lint_join_lams arity arity True rhs - | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = lint_join_lams arity arity False rhs - where - lint_join_lams 0 _ _ rhs - = lintCoreExpr rhs - - lint_join_lams n tot enforce (Lam var expr) - = addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lint_join_lams (n-1) tot enforce expr - ; return $ mkLamType var' body_ty } - - lint_join_lams n tot True _other - = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs - lint_join_lams _ _ False rhs - = markAllJoinsBad $ lintCoreExpr rhs - -- Future join point, not yet eta-expanded - -- Body is not a tail position - --- Allow applications of the data constructor @StaticPtr@ at the top --- but produce errors otherwise. -lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go - where - -- Allow occurrences of 'makeStatic' at the top-level but produce errors - -- otherwise. - go AllowAtTopLevel - | (binders0, rhs') <- collectTyBinders rhs - , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' - = markAllJoinsBad $ - foldr - -- imitate @lintCoreExpr (Lam ...)@ - (\var loopBinders -> - addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \var' -> - do { body_ty <- loopBinders - ; return $ mkLamType var' body_ty } - ) - -- imitate @lintCoreExpr (App ...)@ - (do fun_ty <- lintCoreExpr fun - lintCoreArgs fun_ty [Type t, info, e] - ) - binders0 - go _ = markAllJoinsBad $ lintCoreExpr rhs - -lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () -lintIdUnfolding bndr bndr_ty uf - | isStableUnfolding uf - , Just rhs <- maybeUnfoldingTemplate uf - = do { ty <- lintRhs bndr rhs - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars - -{- -Note [Checking for INLINE loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very suspicious if a strong loop breaker is marked INLINE. - -However, the desugarer generates instance methods with INLINE pragmas -that form a mutually recursive group. Only after a round of -simplification are they unravelled. So we suppress the test for -the desugarer. - -************************************************************************ -* * -\subsection[lintCoreExpr]{lintCoreExpr} -* * -************************************************************************ --} - --- For OutType, OutKind, the substitution has been applied, --- but has not been linted yet - -type LintedType = Type -- Substitution applied, and type is linted -type LintedKind = Kind - -lintCoreExpr :: CoreExpr -> LintM OutType --- The returned type has the substitution from the monad --- already applied to it: --- lintCoreExpr e subst = exprType (subst e) --- --- The returned "type" can be a kind, if the expression is (Type ty) - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreExpr (Var var) - = lintVarOcc var 0 - -lintCoreExpr (Lit lit) - = return (literalType lit) - -lintCoreExpr (Cast expr co) - = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr - ; co' <- applySubstCo co - ; (_, k2, from_ty, to_ty, r) <- lintCoercion co' - ; checkValueKind k2 (text "target of cast" <+> quotes (ppr co)) - ; lintRole co' Representational r - ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) - ; return to_ty } - -lintCoreExpr (Tick tickish expr) - = do case tickish of - Breakpoint _ ids -> forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - _ -> return () - markAllJoinsBadIf block_joins $ lintCoreExpr expr - where - block_joins = not (tickish `tickishScopesLike` SoftScope) - -- TODO Consider whether this is the correct rule. It is consistent with - -- the simplifier's behaviour - cost-centre-scoped ticks become part of - -- the continuation, and thus they behave like part of an evaluation - -- context, but soft-scoped and non-scoped ticks simply wrap the result - -- (see Simplify.simplTick). - -lintCoreExpr (Let (NonRec tv (Type ty)) body) - | isTyVar tv - = -- See Note [Linting type lets] - do { ty' <- applySubstTy ty - ; lintTyBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ lintTyKind tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; extendSubstL tv ty' $ - addLoc (BodyOfLetRec [tv]) $ - lintCoreExpr body } } - -lintCoreExpr (Let (NonRec bndr rhs) body) - | isId bndr - = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) - ; addLoc (BodyOfLetRec [bndr]) - (lintBinder LetBind bndr $ \_ -> - addGoodJoins [bndr] $ - lintCoreExpr body) } - - | otherwise - = failWithL (mkLetErr bndr rhs) -- Not quite accurate - -lintCoreExpr e@(Let (Rec pairs) body) - = lintLetBndrs NotTopLevel bndrs $ - addGoodJoins bndrs $ - do { -- Check that the list of pairs is non-empty - checkL (not (null pairs)) (emptyRec e) - - -- Check that there are no duplicated binders - ; checkL (null dups) (dupVars dups) - - -- Check that either all the binders are joins, or none - ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ - mkInconsistentRecMsg bndrs - - ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs - ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } - where - bndrs = map fst pairs - (_, dups) = removeDups compare bndrs - -lintCoreExpr e@(App _ _) - = do { fun_ty <- lintCoreFun fun (length args) - ; lintCoreArgs fun_ty args } - where - (fun, args) = collectArgs e - -lintCoreExpr (Lam var expr) - = addLoc (LambdaBodyOf var) $ - markAllJoinsBad $ - lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lintCoreExpr expr - ; return $ mkLamType var' body_ty } - -lintCoreExpr (Case scrut var alt_ty alts) - = lintCaseExpr scrut var alt_ty alts - --- This case can't happen; linting types in expressions gets routed through --- lintCoreArgs -lintCoreExpr (Type ty) - = failWithL (text "Type found as expression" <+> ppr ty) - -lintCoreExpr (Coercion co) - = do { (k1, k2, ty1, ty2, role) <- lintInCo co - ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) } - ----------------------- -lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed - -> LintM Type -- returns type of the *variable* -lintVarOcc var nargs - = do { checkL (isNonCoVarId var) - (text "Non term variable" <+> ppr var) - -- See CoreSyn Note [Variable occurrences in Core] - - -- Cneck that the type of the occurrence is the same - -- as the type of the binding site - ; ty <- applySubstTy (idType var) - ; var' <- lookupIdInScope var - ; let ty' = idType var' - ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty - - -- Check for a nested occurrence of the StaticPtr constructor. - -- See Note [Checking StaticPtrs]. - ; lf <- getLintFlags - ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ - checkL (idName var /= makeStaticName) $ - text "Found makeStatic nested in an expression" - - ; checkDeadIdOcc var - ; checkJoinOcc var nargs - - ; return (idType var') } - -lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM Type -- Returns type of the *function* -lintCoreFun (Var var) nargs - = lintVarOcc var nargs - -lintCoreFun (Lam var body) nargs - -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see - -- Note [Beta redexes] - | nargs /= 0 - = addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lintCoreFun body (nargs - 1) - ; return $ mkLamType var' body_ty } - -lintCoreFun expr nargs - = markAllJoinsBadIf (nargs /= 0) $ - -- See Note [Join points are less general than the paper] - lintCoreExpr expr - ------------------- -checkDeadIdOcc :: Id -> LintM () --- Occurrences of an Id should never be dead.... --- except when we are checking a case pattern -checkDeadIdOcc id - | isDeadOcc (idOccInfo id) - = do { in_case <- inCasePat - ; checkL in_case - (text "Occurrence of a dead Id" <+> ppr id) } - | otherwise - = return () - ------------------- -checkJoinOcc :: Id -> JoinArity -> LintM () --- Check that if the occurrence is a JoinId, then so is the --- binding site, and it's a valid join Id -checkJoinOcc var n_args - | Just join_arity_occ <- isJoinId_maybe var - = do { mb_join_arity_bndr <- lookupJoinId var - ; case mb_join_arity_bndr of { - Nothing -> -- Binder is not a join point - addErrL (invalidJoinOcc var) ; - - Just join_arity_bndr -> - - do { checkL (join_arity_bndr == join_arity_occ) $ - -- Arity differs at binding site and occurrence - mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ - - ; checkL (n_args == join_arity_occ) $ - -- Arity doesn't match #args - mkBadJumpMsg var join_arity_occ n_args } } } - - | otherwise - = return () - -{- -Note [No alternatives lint check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case expressions with no alternatives are odd beasts, and it would seem -like they would worth be looking at in the linter (cf #10180). We -used to check two things: - -* exprIsHNF is false: it would *seem* to be terribly wrong if - the scrutinee was already in head normal form. - -* exprIsBottom is true: we should be able to see why GHC believes the - scrutinee is diverging for sure. - -It was already known that the second test was not entirely reliable. -Unfortunately (#13990), the first test turned out not to be reliable -either. Getting the checks right turns out to be somewhat complicated. - -For example, suppose we have (comment 8) - - data T a where - TInt :: T Int - - absurdTBool :: T Bool -> a - absurdTBool v = case v of - - data Foo = Foo !(T Bool) - - absurdFoo :: Foo -> a - absurdFoo (Foo x) = absurdTBool x - -GHC initially accepts the empty case because of the GADT conditions. But then -we inline absurdTBool, getting - - absurdFoo (Foo x) = case x of - -x is in normal form (because the Foo constructor is strict) but the -case is empty. To avoid this problem, GHC would have to recognize -that matching on Foo x is already absurd, which is not so easy. - -More generally, we don't really know all the ways that GHC can -lose track of why an expression is bottom, so we shouldn't make too -much fuss when that happens. - - -Note [Beta redexes] -~~~~~~~~~~~~~~~~~~~ -Consider: - - join j @x y z = ... in - (\@x y z -> jump j @x y z) @t e1 e2 - -This is clearly ill-typed, since the jump is inside both an application and a -lambda, either of which is enough to disqualify it as a tail call (see Note -[Invariants on join points] in CoreSyn). However, strictly from a -lambda-calculus perspective, the term doesn't go wrong---after the two beta -reductions, the jump *is* a tail call and everything is fine. - -Why would we want to allow this when we have let? One reason is that a compound -beta redex (that is, one with more than one argument) has different scoping -rules: naively reducing the above example using lets will capture any free -occurrence of y in e2. More fundamentally, type lets are tricky; many passes, -such as Float Out, tacitly assume that the incoming program's type lets have -all been dealt with by the simplifier. Thus we don't want to let-bind any types -in, say, CoreSubst.simpleOptPgm, which in some circumstances can run immediately -before Float Out. - -All that said, currently CoreSubst.simpleOptPgm is the only thing using this -loophole, doing so to avoid re-traversing large functions (beta-reducing a type -lambda without introducing a type let requires a substitution). TODO: Improve -simpleOptPgm so that we can forget all this ever happened. - -************************************************************************ -* * -\subsection[lintCoreArgs]{lintCoreArgs} -* * -************************************************************************ - -The basic version of these functions checks that the argument is a -subtype of the required type, as one would expect. --} - - -lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType -lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args - -lintCoreArg :: OutType -> CoreArg -> LintM OutType -lintCoreArg fun_ty (Type arg_ty) - = do { checkL (not (isCoercionTy arg_ty)) - (text "Unnecessary coercion-to-type injection:" - <+> ppr arg_ty) - ; arg_ty' <- applySubstTy arg_ty - ; lintTyApp fun_ty arg_ty' } - -lintCoreArg fun_ty arg - = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg - -- See Note [Levity polymorphism invariants] in CoreSyn - ; lintL (not (isTypeLevPoly arg_ty)) - (text "Levity-polymorphic argument:" <+> - (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) - -- check for levity polymorphism first, because otherwise isUnliftedType panics - - ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) - (mkLetAppMsg arg) - ; lintValApp arg fun_ty arg_ty } - ------------------ -lintAltBinders :: OutType -- Scrutinee type - -> OutType -- Constructor type - -> [OutVar] -- Binders - -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintAltBinders scrut_ty con_ty [] - = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) -lintAltBinders scrut_ty con_ty (bndr:bndrs) - | isTyVar bndr - = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } - | otherwise - = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } - ------------------ -lintTyApp :: OutType -> OutType -> LintM OutType -lintTyApp fun_ty arg_ty - | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty - = do { lintTyKind tv arg_ty - ; in_scope <- getInScope - -- substTy needs the set of tyvars in scope to avoid generating - -- uniques that are already in scope. - -- See Note [The substitution invariant] in TyCoSubst - ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } - - | otherwise - = failWithL (mkTyAppMsg fun_ty arg_ty) - ------------------ -lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType -lintValApp arg fun_ty arg_ty - | Just (arg,res) <- splitFunTy_maybe fun_ty - = do { ensureEqTys arg arg_ty err1 - ; return res } - | otherwise - = failWithL err2 - where - err1 = mkAppMsg fun_ty arg_ty arg - err2 = mkNonFunAppMsg fun_ty arg_ty arg - -lintTyKind :: OutTyVar -> OutType -> LintM () --- Both args have had substitution applied - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintTyKind tyvar arg_ty - -- Arg type might be boxed for a function with an uncommitted - -- tyvar; notably this is used so that we can give - -- error :: forall a:*. String -> a - -- and then apply it to both boxed and unboxed types. - = do { arg_kind <- lintType arg_ty - ; unless (arg_kind `eqType` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) } - where - tyvar_kind = tyVarKind tyvar - -{- -************************************************************************ -* * -\subsection[lintCoreAlts]{lintCoreAlts} -* * -************************************************************************ --} - -lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM OutType -lintCaseExpr scrut var alt_ty alts = - do { let e = Case scrut var alt_ty alts -- Just for error messages - - -- Check the scrutinee - ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut - -- See Note [Join points are less general than the paper] - -- in CoreSyn - - ; (alt_ty, _) <- addLoc (CaseTy scrut) $ - lintInTy alt_ty - ; (var_ty, _) <- addLoc (IdTy var) $ - lintInTy (idType var) - - -- We used to try to check whether a case expression with no - -- alternatives was legitimate, but this didn't work. - -- See Note [No alternatives lint check] for details. - - -- Check that the scrutinee is not a floating-point type - -- if there are any literal alternatives - -- See CoreSyn Note [Case expression invariants] item (5) - -- See Note [Rules for floating-point comparisons] in PrelRules - ; let isLitPat (LitAlt _, _ , _) = True - isLitPat _ = False - ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) - (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ - "expression with literal pattern in case " ++ - "analysis (see #9238).") - $$ text "scrut" <+> ppr scrut) - - ; case tyConAppTyCon_maybe (idType var) of - Just tycon - | debugIsOn - , isAlgTyCon tycon - , not (isAbstractTyCon tycon) - , null (tyConDataCons tycon) - , not (exprIsBottom scrut) - -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) - -- This can legitimately happen for type families - $ return () - _otherwise -> return () - - -- Don't use lintIdBndr on var, because unboxed tuple is legitimate - - ; subst <- getTCvSubst - ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - -- See CoreSyn Note [Case expression invariants] item (7) - - ; lintBinder CaseBind var $ \_ -> - do { -- Check the alternatives - mapM_ (lintCoreAlt scrut_ty alt_ty) alts - ; checkCaseAlts e scrut_ty alts - ; return alt_ty } } - -checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () --- a) Check that the alts are non-empty --- b1) Check that the DEFAULT comes first, if it exists --- b2) Check that the others are in increasing order --- c) Check that there's a default for infinite types --- NB: Algebraic cases are not necessarily exhaustive, because --- the simplifier correctly eliminates case that can't --- possibly match. - -checkCaseAlts e ty alts = - do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) - -- See CoreSyn Note [Case expression invariants] item (2) - - ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) - -- See CoreSyn Note [Case expression invariants] item (3) - - -- For types Int#, Word# with an infinite (well, large!) number of - -- possible values, there should usually be a DEFAULT case - -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to - -- have *no* case alternatives. - -- In effect, this is a kind of partial test. I suppose it's possible - -- that we might *know* that 'x' was 1 or 2, in which case - -- case x of { 1 -> e1; 2 -> e2 } - -- would be fine. - ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) - (nonExhaustiveAltsMsg e) } - where - (con_alts, maybe_deflt) = findDefault alts - - -- Check that successive alternatives have strictly increasing tags - increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest - increasing_tag _ = True - - non_deflt (DEFAULT, _, _) = False - non_deflt _ = True - - is_infinite_ty = case tyConAppTyCon_maybe ty of - Nothing -> False - Just tycon -> isPrimTyCon tycon - -lintAltExpr :: CoreExpr -> OutType -> LintM () -lintAltExpr expr ann_ty - = do { actual_ty <- lintCoreExpr expr - ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } - -- See CoreSyn Note [Case expression invariants] item (6) - -lintCoreAlt :: OutType -- Type of scrutinee - -> OutType -- Type of the alternative - -> CoreAlt - -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = - do { lintL (null args) (mkDefaultArgsMsg args) - ; lintAltExpr rhs alt_ty } - -lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) - | litIsLifted lit - = failWithL integerScrutinisedMsg - | otherwise - = do { lintL (null args) (mkDefaultArgsMsg args) - ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; lintAltExpr rhs alt_ty } - where - lit_ty = literalType lit - -lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) - | isNewTyCon (dataConTyCon con) - = addErrL (mkNewTyDataConAltMsg scrut_ty alt) - | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty - = addLoc (CaseAlt alt) $ do - { -- First instantiate the universally quantified - -- type variables of the data constructor - -- We've already check - lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) - ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys - - -- And now bring the new binders into scope - ; lintBinders CasePatBind args $ \ args' -> do - { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') - ; lintAltExpr rhs alt_ty } } - - | otherwise -- Scrut-ty is wrong shape - = addErrL (mkBadAltMsg scrut_ty alt) - -{- -************************************************************************ -* * -\subsection[lint-types]{Types} -* * -************************************************************************ --} - --- When we lint binders, we (one at a time and in order): --- 1. Lint var types or kinds (possibly substituting) --- 2. Add the binder to the in scope set, and if its a coercion var, --- we may extend the substitution to reflect its (possibly) new kind -lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a -lintBinders _ [] linterF = linterF [] -lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> - lintBinders site vars $ \ vars' -> - linterF (var':vars') - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a -lintBinder site var linterF - | isTyVar var = lintTyBndr var linterF - | isCoVar var = lintCoBndr var linterF - | otherwise = lintIdBndr NotTopLevel site var linterF - -lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a -lintTyBndr tv thing_inside - = do { subst <- getTCvSubst - ; let (subst', tv') = substTyVarBndr subst tv - ; lintKind (varType tv') - ; updateTCvSubst subst' (thing_inside tv') } - -lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a -lintCoBndr cv thing_inside - = do { subst <- getTCvSubst - ; let (subst', cv') = substCoVarBndr subst cv - ; lintKind (varType cv') - ; lintL (isCoVarType (varType cv')) - (text "CoVar with non-coercion type:" <+> pprTyVar cv) - ; updateTCvSubst subst' (thing_inside cv') } - -lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a -lintLetBndrs top_lvl ids linterF - = go ids - where - go [] = linterF - go (id:ids) = lintIdBndr top_lvl LetBind id $ \_ -> - go ids - -lintIdBndr :: TopLevelFlag -> BindingSite - -> InVar -> (OutVar -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument --- ToDo: lint its rules -lintIdBndr top_lvl bind_site id linterF - = ASSERT2( isId id, ppr id ) - do { flags <- getLintFlags - ; checkL (not (lf_check_global_ids flags) || isLocalId id) - (text "Non-local Id binder" <+> ppr id) - -- See Note [Checking for global Ids] - - -- Check that if the binder is nested, it is not marked as exported - ; checkL (not (isExportedId id) || is_top_lvl) - (mkNonTopExportedMsg id) - - -- Check that if the binder is nested, it does not have an external name - ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) - (mkNonTopExternalNameMsg id) - - ; (ty, k) <- addLoc (IdTy id) $ - lintInTy (idType id) - - -- See Note [Levity polymorphism invariants] in CoreSyn - ; lintL (isJoinId id || not (isKindLevPoly k)) - (text "Levity-polymorphic binder:" <+> - (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k))) - - -- Check that a join-id is a not-top-level let-binding - ; when (isJoinId id) $ - checkL (not is_top_lvl && is_let_bind) $ - mkBadJoinBindMsg id - - -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); - -- if so, it should be a CoVar, and checked by lintCoVarBndr - ; lintL (not (isCoVarType ty)) - (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr ty) - - ; let id' = setIdType id ty - ; addInScopeVar id' $ (linterF id') } - where - is_top_lvl = isTopLevel top_lvl - is_let_bind = case bind_site of - LetBind -> True - _ -> False - -{- -%************************************************************************ -%* * - Types -%* * -%************************************************************************ --} - -lintTypes :: DynFlags - -> [TyCoVar] -- Treat these as in scope - -> [Type] - -> Maybe MsgDoc -- Nothing => OK -lintTypes dflags vars tys - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - in_scope = emptyInScopeSet - (_warns, errs) = initL dflags defaultLintFlags in_scope linter - linter = lintBinders LambdaBind vars $ \_ -> - mapM_ lintInTy tys - -lintInTy :: InType -> LintM (LintedType, LintedKind) --- Types only, not kinds --- Check the type, and apply the substitution to it --- See Note [Linting type lets] -lintInTy ty - = addLoc (InType ty) $ - do { ty' <- applySubstTy ty - ; k <- lintType ty' - ; lintKind k -- The kind returned by lintType is already - -- a LintedKind but we also want to check that - -- k :: *, which lintKind does - ; return (ty', k) } - -checkTyCon :: TyCon -> LintM () -checkTyCon tc - = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) - -------------------- -lintType :: OutType -> LintM LintedKind --- The returned Kind has itself been linted - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintType (TyVarTy tv) - = do { checkL (isTyVar tv) (mkBadTyVarMsg tv) - ; lintTyCoVarInScope tv - ; return (tyVarKind tv) } - -- We checked its kind when we added it to the envt - -lintType ty@(AppTy t1 t2) - | TyConApp {} <- t1 - = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty - | otherwise - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lint_ty_app ty k1 [(t2,k2)] } - -lintType ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags - ; lintTySynFamApp report_unsat ty tc tys } - - | isFunTyCon tc - , tys `lengthIs` 4 - -- We should never see a saturated application of funTyCon; such - -- applications should be represented with the FunTy constructor. - -- See Note [Linting function types] and - -- Note [Representation of function types]. - = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty)) - - | otherwise -- Data types, data families, primitive types - = do { checkTyCon tc - ; ks <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - --- arrows can related *unlifted* kinds, so this has to be separate from --- a dependent forall. -lintType ty@(FunTy _ t1 t2) - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } - -lintType t@(ForAllTy (Bndr tv _vis) ty) - -- forall over types - | isTyVar tv - = lintTyBndr tv $ \tv' -> - do { k <- lintType ty - ; checkValueKind k (text "the body of forall:" <+> ppr t) - ; case occCheckExpand [tv'] k of -- See Note [Stupid type synonyms] - Just k' -> return k' - Nothing -> failWithL (hang (text "Variable escape in forall:") - 2 (vcat [ text "type:" <+> ppr t - , text "kind:" <+> ppr k ])) - } - -lintType t@(ForAllTy (Bndr cv _vis) ty) - -- forall over coercions - = do { lintL (isCoVar cv) - (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t) - ; lintL (cv `elemVarSet` tyCoVarsOfType ty) - (text "Covar does not occur in the body:" <+> ppr t) - ; lintCoBndr cv $ \_ -> - do { k <- lintType ty - ; checkValueKind k (text "the body of forall:" <+> ppr t) - ; return liftedTypeKind - -- We don't check variable escape here. Namely, k could refer to cv' - -- See Note [NthCo and newtypes] in TyCoRep - }} - -lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) - -lintType (CastTy ty co) - = do { k1 <- lintType ty - ; (k1', k2) <- lintStarCoercion co - ; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1) - ; return k2 } - -lintType (CoercionTy co) - = do { (k1, k2, ty1, ty2, r) <- lintCoercion co - ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 } - -{- Note [Stupid type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14939) - type Alg cls ob = ob - f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b - -Here 'cls' appears free in b's kind, which would usually be illegal -(because in (forall a. ty), ty's kind should not mention 'a'). But -#in this case (Alg cls *) = *, so all is well. Currently we allow -this, and make Lint expand synonyms where necessary to make it so. - -c.f. TcUnify.occCheckExpand and CoreUtils.coreAltsType which deal -with the same problem. A single systematic solution eludes me. --} - ------------------ -lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM LintedKind --- The TyCon is a type synonym or a type family (not a data family) --- See Note [Linting type synonym applications] --- c.f. TcValidity.check_syn_tc_app -lintTySynFamApp report_unsat ty tc tys - | report_unsat -- Report unsaturated only if report_unsat is on - , tys `lengthLessThan` tyConArity tc - = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) - - -- Deal with type synonyms - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { -- Kind-check the argument types, but without reporting - -- un-saturated type families/synonyms - ks <- setReportUnsat False (mapM lintType tys) - - ; when report_unsat $ - do { _ <- lintType expanded_ty - ; return () } - - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - - -- Otherwise this must be a type family - | otherwise - = do { ks <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - ------------------ -lintKind :: OutKind -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintKind k = do { sk <- lintType k - ; unless (classifiesTypeWithValues sk) - (addErrL (hang (text "Ill-kinded kind:" <+> ppr k) - 2 (text "has kind:" <+> ppr sk))) } - ------------------ --- Confirms that a type is really *, #, Constraint etc -checkValueKind :: OutKind -> SDoc -> LintM () -checkValueKind k doc - = lintL (classifiesTypeWithValues k) - (text "Non-*-like kind when *-like expected:" <+> ppr k $$ - text "when checking" <+> doc) - ------------------ -lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 - -- or lintarrow "coercion `blah'" k1 k2 - = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) - ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) - ; return liftedTypeKind } - where - msg ar k - = vcat [ hang (text "Ill-kinded" <+> ar) - 2 (text "in" <+> what) - , what <+> text "kind:" <+> ppr k ] - ------------------ -lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_ty_app ty k tys - = lint_app (text "type" <+> quotes (ppr ty)) k tys - ----------------- -lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_co_app ty k tys - = lint_app (text "coercion" <+> quotes (ppr ty)) k tys - ----------------- -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = text "Negative type literal:" <+> integer n -lintTyLit (StrTyLit _) = return () - -lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind --- (lint_app d fun_kind arg_tys) --- We have an application (f arg_ty1 .. arg_tyn), --- where f :: fun_kind --- Takes care of linting the OutTypes - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lint_app doc kfn kas - = do { in_scope <- getInScope - -- We need the in_scope set to satisfy the invariant in - -- Note [The substitution invariant] in TyCoSubst - ; foldlM (go_app in_scope) kfn kas } - where - fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg kinds =" <+> ppr kas) - , extra ] - - go_app in_scope kfn tka - | Just kfn' <- coreView kfn - = go_app in_scope kfn' tka - - go_app _ (FunTy _ kfa kfb) tka@(_,ka) - = do { unless (ka `eqType` kfa) $ - addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka))) - ; return kfb } - - go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka) - = do { let kv_kind = varType kv - ; unless (ka `eqType` kv_kind) $ - addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka))) - ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } - - go_app _ kfn ka - = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka))) - -{- ********************************************************************* -* * - Linting rules -* * -********************************************************************* -} - -lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () -lintCoreRule _ _ (BuiltinRule {}) - = return () -- Don't bother - -lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs - , ru_args = args, ru_rhs = rhs }) - = lintBinders LambdaBind bndrs $ \ _ -> - do { lhs_ty <- lintCoreArgs fun_ty args - ; rhs_ty <- case isJoinId_maybe fun of - Just join_arity - -> do { checkL (args `lengthIs` join_arity) $ - mkBadJoinPointRuleMsg fun join_arity rule - -- See Note [Rules for join points] - ; lintCoreExpr rhs } - _ -> markAllJoinsBad $ lintCoreExpr rhs - ; ensureEqTys lhs_ty rhs_ty $ - (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty - , text "rhs type:" <+> ppr rhs_ty - , text "fun_ty:" <+> ppr fun_ty ]) - ; let bad_bndrs = filter is_bad_bndr bndrs - - ; checkL (null bad_bndrs) - (rule_doc <+> text "unbound" <+> ppr bad_bndrs) - -- See Note [Linting rules] - } - where - rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon - - lhs_fvs = exprsFreeVars args - rhs_fvs = exprFreeVars rhs - - is_bad_bndr :: Var -> Bool - -- See Note [Unbound RULE binders] in Rules - is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) - && bndr `elemVarSet` rhs_fvs - && isNothing (isReflCoVar_maybe bndr) - - -{- Note [Linting rules] -~~~~~~~~~~~~~~~~~~~~~~~ -It's very bad if simplifying a rule means that one of the template -variables (ru_bndrs) that /is/ mentioned on the RHS becomes -not-mentioned in the LHS (ru_args). How can that happen? Well, in -#10602, SpecConstr stupidly constructed a rule like - - forall x,c1,c2. - f (x |> c1 |> c2) = .... - -But simplExpr collapses those coercions into one. (Indeed in -#10602, it collapsed to the identity and was removed altogether.) - -We don't have a great story for what to do here, but at least -this check will nail it. - -NB (#11643): it's possible that a variable listed in the -binders becomes not-mentioned on both LHS and RHS. Here's a silly -example: - RULE forall x y. f (g x y) = g (x+1) (y-1) -And suppose worker/wrapper decides that 'x' is Absent. Then -we'll end up with - RULE forall x y. f ($gw y) = $gw (x+1) -This seems sufficiently obscure that there isn't enough payoff to -try to trim the forall'd binder list. - -Note [Rules for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A join point cannot be partially applied. However, the left-hand side of a rule -for a join point is effectively a *pattern*, not a piece of code, so there's an -argument to be made for allowing a situation like this: - - join $sj :: Int -> Int -> String - $sj n m = ... - j :: forall a. Eq a => a -> a -> String - {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} - j @a $dEq x y = ... - -Applying this rule can't turn a well-typed program into an ill-typed one, so -conceivably we could allow it. But we can always eta-expand such an -"undersaturated" rule (see 'CoreArity.etaExpandToJoinPointRule'), and in fact -the simplifier would have to in order to deal with the RHS. So we take a -conservative view and don't allow undersaturated rules for join points. See -Note [Rules and join points] in OccurAnal for further discussion. --} - -{- -************************************************************************ -* * - Linting coercions -* * -************************************************************************ --} - -lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) --- Check the coercion, and apply the substitution to it --- See Note [Linting type lets] -lintInCo co - = addLoc (InCo co) $ - do { co' <- applySubstCo co - ; lintCoercion co' } - --- lints a coercion, confirming that its lh kind and its rh kind are both * --- also ensures that the role is Nominal -lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType) -lintStarCoercion g - = do { (k1, k2, t1, t2, r) <- lintCoercion g - ; checkValueKind k1 (text "the kind of the left type in" <+> ppr g) - ; checkValueKind k2 (text "the kind of the right type in" <+> ppr g) - ; lintRole g Nominal r - ; return (t1, t2) } - -lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) --- Check the kind of a coercion term, returning the kind --- Post-condition: the returned OutTypes are lint-free --- --- If lintCoercion co = (k1, k2, s1, s2, r) --- then co :: s1 ~r s2 --- s1 :: k1 --- s2 :: k2 - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoercion (Refl ty) - = do { k <- lintType ty - ; return (k, k, ty, ty, Nominal) } - -lintCoercion (GRefl r ty MRefl) - = do { k <- lintType ty - ; return (k, k, ty, ty, r) } - -lintCoercion (GRefl r ty (MCo co)) - = do { k <- lintType ty - ; (_, _, k1, k2, r') <- lintCoercion co - ; ensureEqTys k k1 - (hang (text "GRefl coercion kind mis-match:" <+> ppr co) - 2 (vcat [ppr ty, ppr k, ppr k1])) - ; lintRole co Nominal r' - ; return (k1, k2, ty, mkCastTy ty co, r) } - -lintCoercion co@(TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_rep1,_rep2,_co1,_co2] <- cos - = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) - } -- All saturated TyConAppCos should be FunCos - - | Just {} <- synTyConDefn_maybe tc - = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) - - | otherwise - = do { checkTyCon tc - ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos - ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's) - ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks) - ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs - ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) } - -lintCoercion co@(AppCo co1 co2) - | TyConAppCo {} <- co1 - = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) - | Just (TyConApp {}, _) <- isReflCo_maybe co1 - = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) - | otherwise - = do { (k1, k2, s1, s2, r1) <- lintCoercion co1 - ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2 - ; k3 <- lint_co_app co k1 [(t1,k'1)] - ; k4 <- lint_co_app co k2 [(t2,k'2)] - ; if r1 == Phantom - then lintL (r2 == Phantom || r2 == Nominal) - (text "Second argument in AppCo cannot be R:" $$ - ppr co) - else lintRole co Nominal r2 - ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) } - ----------- -lintCoercion (ForAllCo tv1 kind_co co) - -- forall over types - | isTyVar tv1 - = do { (_, k2) <- lintStarCoercion kind_co - ; let tv2 = setTyVarKind tv1 k2 - ; addInScopeVar tv1 $ - do { - ; (k3, k4, t1, t2, r) <- lintCoercion co - ; in_scope <- getInScope - ; let tyl = mkInvForAllTy tv1 t1 - subst = mkTvSubst in_scope $ - -- We need both the free vars of the `t2` and the - -- free vars of the range of the substitution in - -- scope. All the free vars of `t2` and `kind_co` should - -- already be in `in_scope`, because they've been - -- linted and `tv2` has the same unique as `tv1`. - -- See Note [The substitution invariant] in TyCoSubst. - unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co) - tyr = mkInvForAllTy tv2 $ - substTy subst t2 - ; return (k3, k4, tyl, tyr, r) } } - -lintCoercion (ForAllCo cv1 kind_co co) - -- forall over coercions - = ASSERT( isCoVar cv1 ) - do { lintL (almostDevoidCoVarOfCo cv1 co) - (text "Covar can only appear in Refl and GRefl: " <+> ppr co) - ; (_, k2) <- lintStarCoercion kind_co - ; let cv2 = setVarType cv1 k2 - ; addInScopeVar cv1 $ - do { - ; (k3, k4, t1, t2, r) <- lintCoercion co - ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co) - ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co) - -- See Note [Weird typing rule for ForAllTy] in Type - ; in_scope <- getInScope - ; let tyl = mkTyCoInvForAllTy cv1 t1 - r2 = coVarRole cv1 - kind_co' = downgradeRole r2 Nominal kind_co - eta1 = mkNthCo r2 2 kind_co' - eta2 = mkNthCo r2 3 kind_co' - subst = mkCvSubst in_scope $ - -- We need both the free vars of the `t2` and the - -- free vars of the range of the substitution in - -- scope. All the free vars of `t2` and `kind_co` should - -- already be in `in_scope`, because they've been - -- linted and `cv2` has the same unique as `cv1`. - -- See Note [The substitution invariant] in TyCoSubst. - unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2) - `mkTransCo` (mkSymCo eta2)) - tyr = mkTyCoInvForAllTy cv2 $ - substTy subst t2 - ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } } - -- See Note [Weird typing rule for ForAllTy] in Type - -lintCoercion co@(FunCo r co1 co2) - = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 - ; (k2,k'2,s2,t2,r2) <- lintCoercion co2 - ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2 - ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2 - ; lintRole co1 r r1 - ; lintRole co2 r r2 - ; return (k, k', mkVisFunTy s1 s2, mkVisFunTy t1 t2, r) } - -lintCoercion (CoVarCo cv) - | not (isCoVar cv) - = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) - 2 (text "With offending type:" <+> ppr (varType cv))) - | otherwise - = do { lintTyCoVarInScope cv - ; cv' <- lookupIdInScope cv - ; lintUnliftedCoVar cv - ; return $ coVarKindsTypesRole cv' } - --- See Note [Bad unsafe coercion] -lintCoercion co@(UnivCo prov r ty1 ty2) - = do { k1 <- lintType ty1 - ; k2 <- lintType ty2 - ; case prov of - UnsafeCoerceProv -> return () -- no extra checks - - PhantomProv kco -> do { lintRole co Phantom r - ; check_kinds kco k1 k2 } - - ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $ - mkBadProofIrrelMsg ty1 co - ; lintL (isCoercionTy ty2) $ - mkBadProofIrrelMsg ty2 co - ; check_kinds kco k1 k2 } - - PluginProv _ -> return () -- no extra checks - - ; when (r /= Phantom && classifiesTypeWithValues k1 - && classifiesTypeWithValues k2) - (checkTypes ty1 ty2) - ; return (k1, k2, ty1, ty2, r) } - where - report s = hang (text $ "Unsafe coercion: " ++ s) - 2 (vcat [ text "From:" <+> ppr ty1 - , text " To:" <+> ppr ty2]) - isUnBoxed :: PrimRep -> Bool - isUnBoxed = not . isGcPtrRep - - -- see #9122 for discussion of these checks - checkTypes t1 t2 - = do { checkWarnL (not lev_poly1) - (report "left-hand type is levity-polymorphic") - ; checkWarnL (not lev_poly2) - (report "right-hand type is levity-polymorphic") - ; when (not (lev_poly1 || lev_poly2)) $ - do { checkWarnL (reps1 `equalLength` reps2) - (report "between values with different # of reps") - ; zipWithM_ validateCoercion reps1 reps2 }} - where - lev_poly1 = isTypeLevPoly t1 - lev_poly2 = isTypeLevPoly t2 - - -- don't look at these unless lev_poly1/2 are False - -- Otherwise, we get #13458 - reps1 = typePrimRep t1 - reps2 = typePrimRep t2 - - validateCoercion :: PrimRep -> PrimRep -> LintM () - validateCoercion rep1 rep2 - = do { dflags <- getDynFlags - ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) - (report "between unboxed and boxed value") - ; checkWarnL (TyCon.primRepSizeB dflags rep1 - == TyCon.primRepSizeB dflags rep2) - (report "between unboxed values of different size") - ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) - (TyCon.primRepIsFloat rep2) - ; case fl of - Nothing -> addWarnL (report "between vector types") - Just False -> addWarnL (report "between float and integral values") - _ -> return () - } - - check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco - ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) - ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } - - -lintCoercion (SymCo co) - = do { (k1, k2, ty1, ty2, r) <- lintCoercion co - ; return (k2, k1, ty2, ty1, r) } - -lintCoercion co@(TransCo co1 co2) - = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1 - ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2 - ; ensureEqTys ty1b ty2a - (hang (text "Trans coercion mis-match:" <+> ppr co) - 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; lintRole co r1 r2 - ; return (k1a, k2b, ty1a, ty2b, r1) } - -lintCoercion the_co@(NthCo r0 n co) - = do { (_, _, s, t, r) <- lintCoercion co - ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of - { (Just (tcv_s, _ty_s), Just (tcv_t, _ty_t)) - -- works for both tyvar and covar - | n == 0 - , (isForAllTy_ty s && isForAllTy_ty t) - || (isForAllTy_co s && isForAllTy_co t) - -> do { lintRole the_co Nominal r0 - ; return (ks, kt, ts, tt, r0) } - where - ts = varType tcv_s - tt = varType tcv_t - ks = typeKind ts - kt = typeKind tt - - ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of - { (Just (tc_s, tys_s), Just (tc_t, tys_t)) - | tc_s == tc_t - , isInjectiveTyCon tc_s r - -- see Note [NthCo and newtypes] in TyCoRep - , tys_s `equalLength` tys_t - , tys_s `lengthExceeds` n - -> do { lintRole the_co tr r0 - ; return (ks, kt, ts, tt, r0) } - where - ts = getNth tys_s n - tt = getNth tys_t n - tr = nthRole r tc_s n - ks = typeKind ts - kt = typeKind tt - - ; _ -> failWithL (hang (text "Bad getNth:") - 2 (ppr the_co $$ ppr s $$ ppr t)) }}} - -lintCoercion the_co@(LRCo lr co) - = do { (_,_,s,t,r) <- lintCoercion co - ; lintRole co Nominal r - ; case (splitAppTy_maybe s, splitAppTy_maybe t) of - (Just s_pr, Just t_pr) - -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal) - where - s_pick = pickLR lr s_pr - t_pick = pickLR lr t_pr - ks_pick = typeKind s_pick - kt_pick = typeKind t_pick - - _ -> failWithL (hang (text "Bad LRCo:") - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion (InstCo co arg) - = do { (k3, k4, t1',t2', r) <- lintCoercion co - ; (k1',k2',s1,s2, r') <- lintCoercion arg - ; lintRole arg Nominal r' - ; in_scope <- getInScope - ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of - -- forall over tvar - { (Just (tv1,t1), Just (tv2,t2)) - | k1' `eqType` tyVarKind tv1 - , k2' `eqType` tyVarKind tv2 - -> return (k3, k4, - substTyWithInScope in_scope [tv1] [s1] t1, - substTyWithInScope in_scope [tv2] [s2] t2, r) - | otherwise - -> failWithL (text "Kind mis-match in inst coercion") - ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of - -- forall over covar - { (Just (cv1, t1), Just (cv2, t2)) - | k1' `eqType` varType cv1 - , k2' `eqType` varType cv2 - , CoercionTy s1' <- s1 - , CoercionTy s2' <- s2 - -> do { return $ - (liftedTypeKind, liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in Type - , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1 - , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2 - , r) } - | otherwise - -> failWithL (text "Kind mis-match in inst coercion") - ; _ -> failWithL (text "Bad argument of inst") }}} - -lintCoercion co@(AxiomInstCo con ind cos) - = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) - (bad_ax (text "index out of range")) - ; let CoAxBranch { cab_tvs = ktvs - , cab_cvs = cvs - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomNthBranch con ind - ; unless (cos `equalLength` (ktvs ++ cvs)) $ - bad_ax (text "lengths") - ; subst <- getTCvSubst - ; let empty_subst = zapTCvSubst subst - ; (subst_l, subst_r) <- foldlM check_ki - (empty_subst, empty_subst) - (zip3 (ktvs ++ cvs) roles cos) - ; let lhs' = substTys subst_l lhs - rhs' = substTy subst_r rhs - fam_tc = coAxiomTyCon con - ; case checkAxInstCo co of - Just bad_branch -> bad_ax $ text "inconsistent with" <+> - pprCoAxBranch fam_tc bad_branch - Nothing -> return () - ; let s2 = mkTyConApp fam_tc lhs' - ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) } - where - bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) - 2 (ppr co)) - - check_ki (subst_l, subst_r) (ktv, role, arg) - = do { (k', k'', s', t', r) <- lintCoercion arg - ; lintRole arg role r - ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) - ktv_kind_r = substTy subst_r (tyVarKind ktv) - ; unless (k' `eqType` ktv_kind_l) - (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] )) - ; unless (k'' `eqType` ktv_kind_r) - (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] )) - ; return (extendTCvSubst subst_l ktv s', - extendTCvSubst subst_r ktv t') } - -lintCoercion (KindCo co) - = do { (k1, k2, _, _, _) <- lintCoercion co - ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) } - -lintCoercion (SubCo co') - = do { (k1,k2,s,t,r) <- lintCoercion co' - ; lintRole co' Nominal r - ; return (k1,k2,s,t,Representational) } - -lintCoercion this@(AxiomRuleCo co cs) - = do { eqs <- mapM lintCoercion cs - ; lintRoles 0 (coaxrAsmpRoles co) eqs - ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of - Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] - Just (Pair l r) -> - return (typeKind l, typeKind r, l, r, coaxrRole co) } - where - err m xs = failWithL $ - hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs) - - lintRoles n (e : es) ((_,_,_,_,r) : rs) - | e == r = lintRoles (n+1) es rs - | otherwise = err "Argument roles mismatch" - [ text "In argument:" <+> int (n+1) - , text "Expected:" <+> ppr e - , text "Found:" <+> ppr r ] - lintRoles _ [] [] = return () - lintRoles n [] rs = err "Too many coercion arguments" - [ text "Expected:" <+> int n - , text "Provided:" <+> int (n + length rs) ] - - lintRoles n es [] = err "Not enough coercion arguments" - [ text "Expected:" <+> int (n + length es) - , text "Provided:" <+> int n ] - -lintCoercion (HoleCo h) - = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h - ; lintCoercion (CoVarCo (coHoleCoVar h)) } - - ----------- -lintUnliftedCoVar :: CoVar -> LintM () -lintUnliftedCoVar cv - = when (not (isUnliftedType (coVarKind cv))) $ - failWithL (text "Bad lifted equality:" <+> ppr cv - <+> dcolon <+> ppr (coVarKind cv)) - -{- -************************************************************************ -* * -\subsection[lint-monad]{The Lint monad} -* * -************************************************************************ --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] -data LintEnv - = LE { le_flags :: LintFlags -- Linting the result of this pass - , le_loc :: [LintLocInfo] -- Locations - - , le_subst :: TCvSubst -- Current type substitution - -- We also use le_subst to keep track of - -- /all variables/ in scope, both Ids and TyVars - - , le_joins :: IdSet -- Join points in scope that are valid - -- A subset of the InScopeSet in le_subst - -- See Note [Join points] - - , le_dynflags :: DynFlags -- DynamicFlags - } - -data LintFlags - = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] - , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] - , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] - , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] - } - --- See Note [Checking StaticPtrs] -data StaticPtrCheck - = AllowAnywhere - -- ^ Allow 'makeStatic' to occur anywhere. - | AllowAtTopLevel - -- ^ Allow 'makeStatic' calls at the top-level only. - | RejectEverywhere - -- ^ Reject any 'makeStatic' occurrence. - deriving Eq - -defaultLintFlags :: LintFlags -defaultLintFlags = LF { lf_check_global_ids = False - , lf_check_inline_loop_breakers = True - , lf_check_static_ptrs = AllowAnywhere - , lf_report_unsat_syns = True - } - -newtype LintM a = - LintM { unLintM :: - LintEnv -> - WarnsAndErrs -> -- Warning and error messages so far - (Maybe a, WarnsAndErrs) } -- Result and messages (if any) - deriving (Functor) - -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) - -{- Note [Checking for global Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before CoreTidy, all locally-bound Ids must be LocalIds, even -top-level ones. See Note [Exported LocalIds] and #9857. - -Note [Checking StaticPtrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in StaticPtrTable for an overview. - -Every occurrence of the function 'makeStatic' should be moved to the -top level by the FloatOut pass. It's vital that we don't have nested -'makeStatic' occurrences after CorePrep, because we populate the Static -Pointer Table from the top-level bindings. See SimplCore Note [Grand -plan for static forms]. - -The linter checks that no occurrence is left behind, nested within an -expression. The check is enabled only after the FloatOut, CorePrep, -and CoreTidy passes and only if the module uses the StaticPointers -language extension. Checking more often doesn't help since the condition -doesn't hold until after the first FloatOut pass. - -Note [Type substitution] -~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we need a type substitution? Consider - /\(a:*). \(x:a). /\(a:*). id a x -This is ill typed, because (renaming variables) it is really - /\(a:*). \(x:a). /\(b:*). id b x -Hence, when checking an application, we can't naively compare x's type -(at its binding site) with its expected type (at a use site). So we -rename type binders as we go, maintaining a substitution. - -The same substitution also supports let-type, current expressed as - (/\(a:*). body) ty -Here we substitute 'ty' for 'a' in 'body', on the fly. - -Note [Linting type synonym applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting a type-synonym, or type-family, application - S ty1 .. tyn -we behave as follows (#15057, #T15664): - -* If lf_report_unsat_syns = True, and S has arity < n, - complain about an unsaturated type synonym or type family - -* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. - - Reason: catch out of scope variables or other ill-kinded gubbins, - even if S discards that argument entirely. E.g. (#15012): - type FakeOut a = Int - type family TF a - type instance TF Int = FakeOut a - Here 'a' is out of scope; but if we expand FakeOut, we conceal - that out-of-scope error. - - Reason for switching off lf_report_unsat_syns: with - LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they - are saturated when the type is expanded. Example - type T f = f Int - type S a = a -> a - type Z = T S - In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. - -* If lf_report_unsat_syns is on, expand the synonym application and - lint the result. Reason: want to check that synonyms are saturated - when the type is expanded. --} - -instance Applicative LintM where - pure x = LintM $ \ _ errs -> (Just x, errs) - (<*>) = ap - -instance Monad LintM where -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - m >>= k = LintM (\ env errs -> - let (res, errs') = unLintM m env errs in - case res of - Just r -> unLintM (k r) env errs' - Nothing -> (Nothing, errs')) - -instance MonadFail.MonadFail LintM where - fail err = failWithL (text err) - -instance HasDynFlags LintM where - getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) - -data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf Id -- The lambda-binder - | UnfoldingOf Id -- Unfolding of a binder - | BodyOfLetRec [Id] -- One of the binders - | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- The *pattern* of the case alternative - | CaseTy CoreExpr -- The type field of a case expression - -- with this scrutinee - | IdTy Id -- The type field of an Id binder - | AnExpr CoreExpr -- Some expression - | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) - | TopLevelBindings - | InType Type -- Inside a type - | InCo Coercion -- Inside a coercion - -initL :: DynFlags -> LintFlags -> InScopeSet - -> LintM a -> WarnsAndErrs -- Warnings and errors -initL dflags flags in_scope m - = case unLintM m env (emptyBag, emptyBag) of - (Just _, errs) -> errs - (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs - | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ - "without reporting an error message") empty - where - env = LE { le_flags = flags - , le_subst = mkEmptyTCvSubst in_scope - , le_joins = emptyVarSet - , le_loc = [] - , le_dynflags = dflags } - -setReportUnsat :: Bool -> LintM a -> LintM a --- Switch off lf_report_unsat_syns -setReportUnsat ru thing_inside - = LintM $ \ env errs -> - let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } - in unLintM thing_inside env' errs - -getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) - -checkL :: Bool -> MsgDoc -> LintM () -checkL True _ = return () -checkL False msg = failWithL msg - --- like checkL, but relevant to type checking -lintL :: Bool -> MsgDoc -> LintM () -lintL = checkL - -checkWarnL :: Bool -> MsgDoc -> LintM () -checkWarnL True _ = return () -checkWarnL False msg = addWarnL msg - -failWithL :: MsgDoc -> LintM a -failWithL msg = LintM $ \ env (warns,errs) -> - (Nothing, (warns, addMsg True env errs msg)) - -addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \ env (warns,errs) -> - (Just (), (warns, addMsg True env errs msg)) - -addWarnL :: MsgDoc -> LintM () -addWarnL msg = LintM $ \ env (warns,errs) -> - (Just (), (addMsg False env warns msg, errs)) - -addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc -addMsg is_error env msgs msg - = ASSERT( notNull loc_msgs ) - msgs `snocBag` mk_msg msg - where - loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first - loc_msgs = map dumpLoc (le_loc env) - - cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs - , text "Substitution:" <+> ppr (le_subst env) ] - context | is_error = cxt_doc - | otherwise = whenPprDebug cxt_doc - -- Print voluminous info for Lint errors - -- but not for warnings - - msg_span = case [ span | (loc,_) <- loc_msgs - , let span = srcLocSpan loc - , isGoodSrcSpan span ] of - [] -> noSrcSpan - (s:_) -> s - mk_msg msg = mkLocMessage SevWarning msg_span - (msg $$ context) - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m - = LintM $ \ env errs -> - unLintM m (env { le_loc = extra_loc : le_loc env }) errs - -inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) - where - is_case_pat (LE { le_loc = CasePat {} : _ }) = True - is_case_pat _other = False - -addInScopeVar :: Var -> LintM a -> LintM a -addInScopeVar var m - = LintM $ \ env errs -> - unLintM m (env { le_subst = extendTCvInScope (le_subst env) var - , le_joins = delVarSet (le_joins env) var - }) errs - -extendSubstL :: TyVar -> Type -> LintM a -> LintM a -extendSubstL tv ty m - = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs - -updateTCvSubst :: TCvSubst -> LintM a -> LintM a -updateTCvSubst subst' m - = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs - -markAllJoinsBad :: LintM a -> LintM a -markAllJoinsBad m - = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs - -markAllJoinsBadIf :: Bool -> LintM a -> LintM a -markAllJoinsBadIf True m = markAllJoinsBad m -markAllJoinsBadIf False m = m - -addGoodJoins :: [Var] -> LintM a -> LintM a -addGoodJoins vars thing_inside - = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs - where - add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids } - join_ids = filter isJoinId vars - -getValidJoins :: LintM IdSet -getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) - -getTCvSubst :: LintM TCvSubst -getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) - -applySubstTy :: InType -> LintM OutType -applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) } - -applySubstCo :: InCoercion -> LintM OutCoercion -applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) } - -lookupIdInScope :: Id -> LintM Id -lookupIdInScope id_occ - = do { subst <- getTCvSubst - ; case lookupInScope (getTCvInScope subst) id_occ of - Just id_bnd -> do { checkL (not (bad_global id_bnd)) global_in_scope - ; return id_bnd } - Nothing -> do { checkL (not is_local) local_out_of_scope - ; return id_occ } } - where - is_local = mustHaveLocalBinding id_occ - local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ - global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId") - 2 (pprBndr LetBind id_occ) - bad_global id_bnd = isGlobalId id_occ - && isLocalId id_bnd - && not (isWiredInName (idName id_occ)) - -- 'bad_global' checks for the case where an /occurrence/ is - -- a GlobalId, but there is an enclosing binding fora a LocalId. - -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, - -- but GHCi adds GlobalIds from the interactive context. These - -- are fine; hence the test (isLocalId id == isLocalId v) - -- NB: when compiling Control.Exception.Base, things like absentError - -- are defined locally, but appear in expressions as (global) - -- wired-in Ids after worker/wrapper - -- So we simply disable the test in this case - -lookupJoinId :: Id -> LintM (Maybe JoinArity) --- Look up an Id which should be a join point, valid here --- If so, return its arity, if not return Nothing -lookupJoinId id - = do { join_set <- getValidJoins - ; case lookupVarSet join_set id of - Just id' -> return (isJoinId_maybe id') - Nothing -> return Nothing } - -lintTyCoVarInScope :: TyCoVar -> LintM () -lintTyCoVarInScope var - = do { subst <- getTCvSubst - ; lintL (var `isInScope` subst) - (hang (text "The variable" <+> pprBndr LetBind var) - 2 (text "is out of scope")) } - -ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () --- check ty2 is subtype of ty1 (ie, has same structure but usage --- annotations need only be consistent, not equal) --- Assumes ty1,ty2 are have already had the substitution applied -ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg - -lintRole :: Outputable thing - => thing -- where the role appeared - -> Role -- expected - -> Role -- actual - -> LintM () -lintRole co r1 r2 - = lintL (r1 == r2) - (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> - text "got" <+> ppr r2 $$ - text "in" <+> ppr co) - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) - -dumpLoc (RhsOf v) - = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) - -dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) - -dumpLoc (UnfoldingOf b) - = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) - -dumpLoc (BodyOfLetRec []) - = (noSrcLoc, text "In body of a letrec with no binders") - -dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs) - -dumpLoc (AnExpr e) - = (noSrcLoc, text "In the expression:" <+> ppr e) - -dumpLoc (CaseAlt (con, args, _)) - = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CasePat (con, args, _)) - = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CaseTy scrut) - = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") - 2 (ppr scrut)) - -dumpLoc (IdTy b) - = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) - -dumpLoc (ImportedUnfolding locn) - = (locn, text "In an imported unfolding") -dumpLoc TopLevelBindings - = (noSrcLoc, Outputable.empty) -dumpLoc (InType ty) - = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) -dumpLoc (InCo co) - = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) - -pp_binders :: [Var] -> SDoc -pp_binders bs = sep (punctuate comma (map pp_binder bs)) - -pp_binder :: Var -> SDoc -pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] - | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] - ------------------------------------------------------- --- Messages for case expressions - -mkDefaultArgsMsg :: [Var] -> MsgDoc -mkDefaultArgsMsg args - = hang (text "DEFAULT case with binders") - 4 (ppr args) - -mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc -mkCaseAltMsg e ty1 ty2 - = hang (text "Type of case alternatives not the same as the annotation on case:") - 4 (vcat [ text "Actual type:" <+> ppr ty1, - text "Annotation on case:" <+> ppr ty2, - text "Alt Rhs:" <+> ppr e ]) - -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc -mkScrutMsg var var_ty scrut_ty subst - = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, - text "Result binder type:" <+> ppr var_ty,--(idType var), - text "Scrutinee type:" <+> ppr scrut_ty, - hsep [text "Current TCv subst", ppr subst]] - -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc -mkNonDefltMsg e - = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) -mkNonIncreasingAltsMsg e - = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) - -nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc -nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) - -mkBadConMsg :: TyCon -> DataCon -> MsgDoc -mkBadConMsg tycon datacon - = vcat [ - text "In a case alternative, data constructor isn't in scrutinee type:", - text "Scrutinee type constructor:" <+> ppr tycon, - text "Data con:" <+> ppr datacon - ] - -mkBadPatMsg :: Type -> Type -> MsgDoc -mkBadPatMsg con_result_ty scrut_ty - = vcat [ - text "In a case alternative, pattern result type doesn't match scrutinee type:", - text "Pattern result type:" <+> ppr con_result_ty, - text "Scrutinee type:" <+> ppr scrut_ty - ] - -integerScrutinisedMsg :: MsgDoc -integerScrutinisedMsg - = text "In a LitAlt, the literal is lifted (probably Integer)" - -mkBadAltMsg :: Type -> CoreAlt -> MsgDoc -mkBadAltMsg scrut_ty alt - = vcat [ text "Data alternative when scrutinee is not a tycon application", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - -mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc -mkNewTyDataConAltMsg scrut_ty alt - = vcat [ text "Data alternative for newtype datacon", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - - ------------------------------------------------------- --- Other error messages - -mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc -mkAppMsg fun_ty arg_ty arg - = vcat [text "Argument value doesn't match argument type:", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc -mkNonFunAppMsg fun_ty arg_ty arg - = vcat [text "Non-function type in function position", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkLetErr :: TyVar -> CoreExpr -> MsgDoc -mkLetErr bndr rhs - = vcat [text "Bad `let' binding:", - hang (text "Variable:") - 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), - hang (text "Rhs:") - 4 (ppr rhs)] - -mkTyAppMsg :: Type -> Type -> MsgDoc -mkTyAppMsg ty arg_ty - = vcat [text "Illegal type application:", - hang (text "Exp type:") - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -emptyRec :: CoreExpr -> MsgDoc -emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) - -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc -mkRhsMsg binder what ty - = vcat - [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, - ppr binder], - hsep [text "Binder's type:", ppr (idType binder)], - hsep [text "Rhs type:", ppr ty]] - -mkLetAppMsg :: CoreExpr -> MsgDoc -mkLetAppMsg e - = hang (text "This argument does not satisfy the let/app invariant:") - 2 (ppr e) - -badBndrTyMsg :: Id -> SDoc -> MsgDoc -badBndrTyMsg binder what - = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder - , text "Binder's type:" <+> ppr (idType binder) ] - -mkStrictMsg :: Id -> MsgDoc -mkStrictMsg binder - = vcat [hsep [text "Recursive or top-level binder has strict demand info:", - ppr binder], - hsep [text "Binder's demand info:", ppr (idDemandInfo binder)] - ] - -mkNonTopExportedMsg :: Id -> MsgDoc -mkNonTopExportedMsg binder - = hsep [text "Non-top-level binder is marked as exported:", ppr binder] - -mkNonTopExternalNameMsg :: Id -> MsgDoc -mkNonTopExternalNameMsg binder - = hsep [text "Non-top-level binder has an external name:", ppr binder] - -mkTopNonLitStrMsg :: Id -> MsgDoc -mkTopNonLitStrMsg binder - = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] - -mkKindErrMsg :: TyVar -> Type -> MsgDoc -mkKindErrMsg tyvar arg_ty - = vcat [text "Kinds don't match in type application:", - hang (text "Type variable:") - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc -mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) - -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc -mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) - -mk_cast_err :: String -- ^ What sort of casted thing this is - -- (\"expression\" or \"type\"). - -> String -- ^ What sort of coercion is being used - -- (\"type\" or \"kind\"). - -> SDoc -- ^ The thing being casted. - -> Coercion -> Type -> Type -> MsgDoc -mk_cast_err thing_str co_str pp_thing co from_ty thing_ty - = vcat [from_msg <+> text "of Cast differs from" <+> co_msg - <+> text "of" <+> enclosed_msg, - from_msg <> colon <+> ppr from_ty, - text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon - <+> ppr thing_ty, - text "Actual" <+> enclosed_msg <> colon <+> pp_thing, - text "Coercion used in cast:" <+> ppr co - ] - where - co_msg, from_msg, enclosed_msg :: SDoc - co_msg = text co_str - from_msg = text "From-" <> co_msg - enclosed_msg = text "enclosed" <+> text thing_str - -mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc -mkBadUnivCoMsg lr co - = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> - text "side of a UnivCo:" <+> ppr co - -mkBadProofIrrelMsg :: Type -> Coercion -> SDoc -mkBadProofIrrelMsg ty co - = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") - 2 (vcat [ text "type:" <+> ppr ty - , text "co:" <+> ppr co ]) - -mkBadTyVarMsg :: Var -> SDoc -mkBadTyVarMsg tv - = text "Non-tyvar used in TyVarTy:" - <+> ppr tv <+> dcolon <+> ppr (varType tv) - -mkBadJoinBindMsg :: Var -> SDoc -mkBadJoinBindMsg var - = vcat [ text "Bad join point binding:" <+> ppr var - , text "Join points can be bound only by a non-top-level let" ] - -mkInvalidJoinPointMsg :: Var -> Type -> SDoc -mkInvalidJoinPointMsg var ty - = hang (text "Join point has invalid type:") - 2 (ppr var <+> dcolon <+> ppr ty) - -mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc -mkBadJoinArityMsg var ar nlams rhs - = vcat [ text "Join point has too few lambdas", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of lambdas:" <+> ppr nlams, - text "Rhs = " <+> ppr rhs - ] - -invalidJoinOcc :: Var -> SDoc -invalidJoinOcc var - = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var - , text "The binder is either not a join point, or not valid here" ] - -mkBadJumpMsg :: Var -> Int -> Int -> SDoc -mkBadJumpMsg var ar nargs - = vcat [ text "Join point invoked with wrong number of arguments", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of arguments:" <+> int nargs ] - -mkInconsistentRecMsg :: [Var] -> SDoc -mkInconsistentRecMsg bndrs - = vcat [ text "Recursive let binders mix values and join points", - text "Binders:" <+> hsep (map ppr_with_details bndrs) ] - where - ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) - -mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc -mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ - = vcat [ text "Mismatch in join point arity between binder and occurrence" - , text "Var:" <+> ppr bndr - , text "Arity at binding site:" <+> ppr join_arity_bndr - , text "Arity at occurrence: " <+> ppr join_arity_occ ] - -mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc -mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty - = vcat [ text "Mismatch in type between binder and occurrence" - , text "Var:" <+> ppr bndr - , text "Binder type:" <+> ppr bndr_ty - , text "Occurrence type:" <+> ppr var_ty - , text " Before subst:" <+> ppr (idType var) ] - -mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc -mkBadJoinPointRuleMsg bndr join_arity rule - = vcat [ text "Join point has rule with wrong number of arguments" - , text "Var:" <+> ppr bndr - , text "Join arity:" <+> ppr join_arity - , text "Rule:" <+> ppr rule ] - -pprLeftOrRight :: LeftOrRight -> MsgDoc -pprLeftOrRight CLeft = text "left" -pprLeftOrRight CRight = text "right" - -dupVars :: [NonEmpty Var] -> MsgDoc -dupVars vars - = hang (text "Duplicate variables brought into scope") - 2 (ppr (map toList vars)) - -dupExtVars :: [NonEmpty Name] -> MsgDoc -dupExtVars vars - = hang (text "Duplicate top-level variables with the same qualified name") - 2 (ppr (map toList vars)) - -{- -************************************************************************ -* * -\subsection{Annotation Linting} -* * -************************************************************************ --} - --- | This checks whether a pass correctly looks through debug --- annotations (@SourceNote@). This works a bit different from other --- consistency checks: We check this by running the given task twice, --- noting all differences between the results. -lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -lintAnnots pname pass guts = do - -- Run the pass as we normally would - dflags <- getDynFlags - when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass dflags "Annotation linting - first run" - nguts <- pass guts - -- If appropriate re-run it without debug annotations to make sure - -- that they made no difference. - when (gopt Opt_DoAnnotationLinting dflags) $ do - liftIO $ Err.showPass dflags "Annotation linting - second run" - nguts' <- withoutAnnots pass guts - -- Finally compare the resulting bindings - liftIO $ Err.showPass dflags "Annotation linting - comparison" - let binds = flattenBinds $ mg_binds nguts - binds' = flattenBinds $ mg_binds nguts' - (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' - when (not (null diffs)) $ CoreMonad.putMsg $ vcat - [ lint_banner "warning" pname - , text "Core changes with annotations:" - , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs - ] - -- Return actual new guts - return nguts - --- | Run the given pass without annotations. This means that we both --- set the debugLevel setting to 0 in the environment as well as all --- annotations from incoming modules. -withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -withoutAnnots pass guts = do - -- Remove debug flag from environment. - dflags <- getDynFlags - let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} } - withoutFlag corem = - -- TODO: supply tag here as well ? - liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> - getUniqMask <*> getModule <*> - getVisibleOrphanMods <*> - getPrintUnqualified <*> getSrcSpanM <*> - pure corem - -- Nuke existing ticks in module. - -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes - -- them in absence of debugLevel > 0. - let nukeTicks = stripTicksE (not . tickishIsCode) - nukeAnnotsBind :: CoreBind -> CoreBind - nukeAnnotsBind bind = case bind of - Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs - NonRec b e -> NonRec b $ nukeTicks e - nukeAnnotsMod mg@ModGuts{mg_binds=binds} - = mg{mg_binds = map nukeAnnotsBind binds} - -- Perform pass with all changes applied - fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/coreSyn/CoreMap.hs b/coreSyn/CoreMap.hs deleted file mode 100644 --- a/coreSyn/CoreMap.hs +++ /dev/null @@ -1,803 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module CoreMap( - -- * Maps over Core expressions - CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, - -- * Maps over 'Type's - TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, - LooseTypeMap, - -- ** With explicit scoping - CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope, - mkDeBruijnContext, - -- * Maps over 'Maybe' values - MaybeMap, - -- * Maps over 'List' values - ListMap, - -- * Maps over 'Literal's - LiteralMap, - -- * Map for compressing leaves. See Note [Compressed TrieMap] - GenMap, - -- * 'TrieMap' class - TrieMap(..), insertTM, deleteTM, - lkDFreeVar, xtDFreeVar, - lkDNamed, xtDNamed, - (>.>), (|>), (|>>), - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TrieMap -import CoreSyn -import Coercion -import Name -import Type -import TyCoRep -import Var -import FastString(FastString) -import Util - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import VarEnv -import NameEnv -import Outputable -import Control.Monad( (>=>) ) - -{- -This module implements TrieMaps over Core related data structures -like CoreExpr or Type. It is built on the Tries from the TrieMap -module. - -The code is very regular and boilerplate-like, but there is -some neat handling of *binders*. In effect they are deBruijn -numbered on the fly. - - --} - ----------------------- --- Recall that --- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c - --- NB: Be careful about RULES and type families (#5821). So we should make sure --- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) - --- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not --- known when defining GenMap so we can only specialize them here. - -{-# SPECIALIZE lkG :: Key TypeMapX -> TypeMapG a -> Maybe a #-} -{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-} -{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} - - -{-# SPECIALIZE xtG :: Key TypeMapX -> XT a -> TypeMapG a -> TypeMapG a #-} -{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-} -{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} - -{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a -> TypeMapG b #-} -{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-} -{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} - -{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a -> b -> b #-} -{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-} -{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} - - -{- -************************************************************************ -* * - CoreMap -* * -************************************************************************ --} - -lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a -lkDNamed n env = lookupDNameEnv env (getName n) - -xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a -xtDNamed tc f m = alterDNameEnv f m (getName tc) - - -{- -Note [Binders] -~~~~~~~~~~~~~~ - * In general we check binders as late as possible because types are - less likely to differ than expression structure. That's why - cm_lam :: CoreMapG (TypeMapG a) - rather than - cm_lam :: TypeMapG (CoreMapG a) - - * We don't need to look at the type of some binders, notably - - the case binder in (Case _ b _ _) - - the binders in an alternative - because they are totally fixed by the context - -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* For a key (Case e b ty (alt:alts)) we don't need to look the return type - 'ty', because every alternative has that type. - -* For a key (Case e b ty []) we MUST look at the return type 'ty', because - otherwise (Case (error () "urk") _ Int []) would compare equal to - (Case (error () "urk") _ Bool []) - which is utterly wrong (#6097) - -We could compare the return type regardless, but the wildly common case -is that it's unnecessary, so we have two fields (cm_case and cm_ecase) -for the two possibilities. Only cm_ecase looks at the type. - -See also Note [Empty case alternatives] in CoreSyn. --} - --- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this --- is the type you want. -newtype CoreMap a = CoreMap (CoreMapG a) - -instance TrieMap CoreMap where - type Key CoreMap = CoreExpr - emptyTM = CoreMap emptyTM - lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m - alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) - foldTM k (CoreMap m) = foldTM k m - mapTM f (CoreMap m) = CoreMap (mapTM f m) - --- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended --- key makes it suitable for recursive traversal, since it can track binders, --- but it is strictly internal to this module. If you are including a 'CoreMap' --- inside another 'TrieMap', this is the type you want. -type CoreMapG = GenMap CoreMapX - --- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without --- the 'GenMap' optimization. -data CoreMapX a - = CM { cm_var :: VarMap a - , cm_lit :: LiteralMap a - , cm_co :: CoercionMapG a - , cm_type :: TypeMapG a - , cm_cast :: CoreMapG (CoercionMapG a) - , cm_tick :: CoreMapG (TickishMap a) - , cm_app :: CoreMapG (CoreMapG a) - , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] - , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) - , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) - , cm_case :: CoreMapG (ListMap AltMap a) - , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] - } - -instance Eq (DeBruijn CoreExpr) where - D env1 e1 == D env2 e2 = go e1 e2 where - go (Var v1) (Var v2) = case (lookupCME env1 v1, lookupCME env2 v2) of - (Just b1, Just b2) -> b1 == b2 - (Nothing, Nothing) -> v1 == v2 - _ -> False - go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = D env1 t1 == D env2 t2 - go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 - go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 - go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 - -- This seems a bit dodgy, see 'eqTickish' - go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 - - go (Lam b1 e1) (Lam b2 e2) - = D env1 (varType b1) == D env2 (varType b2) - && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 - - go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) - = go r1 r2 - && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 - - go (Let (Rec ps1) e1) (Let (Rec ps2) e2) - = equalLength ps1 ps2 - && D env1' rs1 == D env2' rs2 - && D env1' e1 == D env2' e2 - where - (bs1,rs1) = unzip ps1 - (bs2,rs2) = unzip ps2 - env1' = extendCMEs env1 bs1 - env2' = extendCMEs env2 bs2 - - go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | null a1 -- See Note [Empty case alternatives] - = null a2 && go e1 e2 && D env1 t1 == D env2 t2 - | otherwise - = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 - - go _ _ = False - -emptyE :: CoreMapX a -emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM - , cm_co = emptyTM, cm_type = emptyTM - , cm_cast = emptyTM, cm_app = emptyTM - , cm_lam = emptyTM, cm_letn = emptyTM - , cm_letr = emptyTM, cm_case = emptyTM - , cm_ecase = emptyTM, cm_tick = emptyTM } - -instance TrieMap CoreMapX where - type Key CoreMapX = DeBruijn CoreExpr - emptyTM = emptyE - lookupTM = lkE - alterTM = xtE - foldTM = fdE - mapTM = mapE - --------------------------- -mapE :: (a->b) -> CoreMapX a -> CoreMapX b -mapE f (CM { cm_var = cvar, cm_lit = clit - , cm_co = cco, cm_type = ctype - , cm_cast = ccast , cm_app = capp - , cm_lam = clam, cm_letn = cletn - , cm_letr = cletr, cm_case = ccase - , cm_ecase = cecase, cm_tick = ctick }) - = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit - , cm_co = mapTM f cco, cm_type = mapTM f ctype - , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp - , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn - , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase - , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } - --------------------------- -lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a -lookupCoreMap cm e = lookupTM e cm - -extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a -extendCoreMap m e v = alterTM e (\_ -> Just v) m - -foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b -foldCoreMap k z m = foldTM k m z - -emptyCoreMap :: CoreMap a -emptyCoreMap = emptyTM - -instance Outputable a => Outputable (CoreMap a) where - ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) - -------------------------- -fdE :: (a -> b -> b) -> CoreMapX a -> b -> b -fdE k m - = foldTM k (cm_var m) - . foldTM k (cm_lit m) - . foldTM k (cm_co m) - . foldTM k (cm_type m) - . foldTM (foldTM k) (cm_cast m) - . foldTM (foldTM k) (cm_tick m) - . foldTM (foldTM k) (cm_app m) - . foldTM (foldTM k) (cm_lam m) - . foldTM (foldTM (foldTM k)) (cm_letn m) - . foldTM (foldTM (foldTM k)) (cm_letr m) - . foldTM (foldTM k) (cm_case m) - . foldTM (foldTM k) (cm_ecase m) - --- lkE: lookup in trie for expressions -lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a -lkE (D env expr) cm = go expr cm - where - go (Var v) = cm_var >.> lkVar env v - go (Lit l) = cm_lit >.> lookupTM l - go (Type t) = cm_type >.> lkG (D env t) - go (Coercion c) = cm_co >.> lkG (D env c) - go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) - go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish - go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) - go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) - >=> lkBndr env v - go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) - >=> lkG (D (extendCME env b) e) >=> lkBndr env b - go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs - env1 = extendCMEs env bndrs - in cm_letr - >.> lkList (lkG . D env1) rhss - >=> lkG (D env1 e) - >=> lkList (lkBndr env1) bndrs - go (Case e b ty as) -- See Note [Empty case alternatives] - | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) - | otherwise = cm_case >.> lkG (D env e) - >=> lkList (lkA (extendCME env b)) as - -xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a -xtE (D env (Var v)) f m = m { cm_var = cm_var m - |> xtVar env v f } -xtE (D env (Type t)) f m = m { cm_type = cm_type m - |> xtG (D env t) f } -xtE (D env (Coercion c)) f m = m { cm_co = cm_co m - |> xtG (D env c) f } -xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } -xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) - |>> xtG (D env c) f } -xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) - |>> xtTickish t f } -xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) - |>> xtG (D env e1) f } -xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m - |> xtG (D (extendCME env v) e) - |>> xtBndr env v f } -xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m - |> xtG (D (extendCME env b) e) - |>> xtG (D env r) - |>> xtBndr env b f } -xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = - let (bndrs,rhss) = unzip prs - env1 = extendCMEs env bndrs - in cm_letr m - |> xtList (xtG . D env1) rhss - |>> xtG (D env1 e) - |>> xtList (xtBndr env1) - bndrs f } -xtE (D env (Case e b ty as)) f m - | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) - |>> xtG (D env ty) f } - | otherwise = m { cm_case = cm_case m |> xtG (D env e) - |>> let env1 = extendCME env b - in xtList (xtA env1) as f } - --- TODO: this seems a bit dodgy, see 'eqTickish' -type TickishMap a = Map.Map (Tickish Id) a -lkTickish :: Tickish Id -> TickishMap a -> Maybe a -lkTickish = lookupTM - -xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a -xtTickish = alterTM - ------------------------- -data AltMap a -- A single alternative - = AM { am_deflt :: CoreMapG a - , am_data :: DNameEnv (CoreMapG a) - , am_lit :: LiteralMap (CoreMapG a) } - -instance TrieMap AltMap where - type Key AltMap = CoreAlt - emptyTM = AM { am_deflt = emptyTM - , am_data = emptyDNameEnv - , am_lit = emptyTM } - lookupTM = lkA emptyCME - alterTM = xtA emptyCME - foldTM = fdA - mapTM = mapA - -instance Eq (DeBruijn CoreAlt) where - D env1 a1 == D env2 a2 = go a1 a2 where - go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) - = D env1 rhs1 == D env2 rhs2 - go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) - = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 - go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2) - = dc1 == dc2 && - D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 - go _ _ = False - -mapA :: (a->b) -> AltMap a -> AltMap b -mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) - = AM { am_deflt = mapTM f adeflt - , am_data = mapTM (mapTM f) adata - , am_lit = mapTM (mapTM f) alit } - -lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) -lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) -lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc - >=> lkG (D (extendCMEs env bs) rhs) - -xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a -xtA env (DEFAULT, _, rhs) f m = - m { am_deflt = am_deflt m |> xtG (D env rhs) f } -xtA env (LitAlt l, _, rhs) f m = - m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } -xtA env (DataAlt d, bs, rhs) f m = - m { am_data = am_data m |> xtDNamed d - |>> xtG (D (extendCMEs env bs) rhs) f } - -fdA :: (a -> b -> b) -> AltMap a -> b -> b -fdA k m = foldTM k (am_deflt m) - . foldTM (foldTM k) (am_data m) - . foldTM (foldTM k) (am_lit m) - -{- -************************************************************************ -* * - Coercions -* * -************************************************************************ --} - --- We should really never care about the contents of a coercion. Instead, --- just look up the coercion's type. -newtype CoercionMap a = CoercionMap (CoercionMapG a) - -instance TrieMap CoercionMap where - type Key CoercionMap = Coercion - emptyTM = CoercionMap emptyTM - lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m - alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) - foldTM k (CoercionMap m) = foldTM k m - mapTM f (CoercionMap m) = CoercionMap (mapTM f m) - -type CoercionMapG = GenMap CoercionMapX -newtype CoercionMapX a = CoercionMapX (TypeMapX a) - -instance TrieMap CoercionMapX where - type Key CoercionMapX = DeBruijn Coercion - emptyTM = CoercionMapX emptyTM - lookupTM = lkC - alterTM = xtC - foldTM f (CoercionMapX core_tm) = foldTM f core_tm - mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) - -instance Eq (DeBruijn Coercion) where - D env1 co1 == D env2 co2 - = D env1 (coercionType co1) == - D env2 (coercionType co2) - -lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a -lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) - core_tm - -xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a -xtC (D env co) f (CoercionMapX m) - = CoercionMapX (xtT (D env $ coercionType co) f m) - -{- -************************************************************************ -* * - Types -* * -************************************************************************ --} - --- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended --- key makes it suitable for recursive traversal, since it can track binders, --- but it is strictly internal to this module. If you are including a 'TypeMap' --- inside another 'TrieMap', this is the type you want. Note that this --- lookup does not do a kind-check. Thus, all keys in this map must have --- the same kind. Also note that this map respects the distinction between --- @Type@ and @Constraint@, despite the fact that they are equivalent type --- synonyms in Core. -type TypeMapG = GenMap TypeMapX - --- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the --- 'GenMap' optimization. -data TypeMapX a - = TM { tm_var :: VarMap a - , tm_app :: TypeMapG (TypeMapG a) - , tm_tycon :: DNameEnv a - , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] - , tm_tylit :: TyLitMap a - , tm_coerce :: Maybe a - } - -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type - --- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the --- last one? See Note [Equality on AppTys] in Type --- --- Note, however, that we keep Constraint and Type apart here, despite the fact --- that they are both synonyms of TYPE 'LiftedRep (see #11715). -trieMapView :: Type -> Maybe Type -trieMapView ty - -- First check for TyConApps that need to be expanded to - -- AppTy chains. - | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty - = Just $ foldl' AppTy (TyConApp tc []) tys - - -- Then resolve any remaining nullary synonyms. - | Just ty' <- tcView ty = Just ty' -trieMapView _ = Nothing - -instance TrieMap TypeMapX where - type Key TypeMapX = DeBruijn Type - emptyTM = emptyT - lookupTM = lkT - alterTM = xtT - foldTM = fdT - mapTM = mapT - -instance Eq (DeBruijn Type) where - env_t@(D env t) == env_t'@(D env' t') - | Just new_t <- tcView t = D env new_t == env_t' - | Just new_t' <- tcView t' = env_t == D env' new_t' - | otherwise - = case (t, t') of - (CastTy t1 _, _) -> D env t1 == D env t' - (_, CastTy t1' _) -> D env t == D env t1' - - (TyVarTy v, TyVarTy v') - -> case (lookupCME env v, lookupCME env' v') of - (Just bv, Just bv') -> bv == bv' - (Nothing, Nothing) -> v == v' - _ -> False - -- See Note [Equality on AppTys] in Type - (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (FunTy _ t1 t2, FunTy _ t1' t2') - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (TyConApp tc tys, TyConApp tc' tys') - -> tc == tc' && D env tys == D env' tys' - (LitTy l, LitTy l') - -> l == l' - (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty') - -> D env (varType tv) == D env' (varType tv') && - D (extendCME env tv) ty == D (extendCME env' tv') ty' - (CoercionTy {}, CoercionTy {}) - -> True - _ -> False - -instance {-# OVERLAPPING #-} - Outputable a => Outputable (TypeMapG a) where - ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) - -emptyT :: TypeMapX a -emptyT = TM { tm_var = emptyTM - , tm_app = emptyTM - , tm_tycon = emptyDNameEnv - , tm_forall = emptyTM - , tm_tylit = emptyTyLitMap - , tm_coerce = Nothing } - -mapT :: (a->b) -> TypeMapX a -> TypeMapX b -mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon - , tm_forall = tforall, tm_tylit = tlit - , tm_coerce = tcoerce }) - = TM { tm_var = mapTM f tvar - , tm_app = mapTM (mapTM f) tapp - , tm_tycon = mapTM f ttycon - , tm_forall = mapTM (mapTM f) tforall - , tm_tylit = mapTM f tlit - , tm_coerce = fmap f tcoerce } - ------------------ -lkT :: DeBruijn Type -> TypeMapX a -> Maybe a -lkT (D env ty) m = go ty m - where - go ty | Just ty' <- trieMapView ty = go ty' - go (TyVarTy v) = tm_var >.> lkVar env v - go (AppTy t1 t2) = tm_app >.> lkG (D env t1) - >=> lkG (D env t2) - go (TyConApp tc []) = tm_tycon >.> lkDNamed tc - go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) - go (LitTy l) = tm_tylit >.> lkTyLit l - go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) - >=> lkBndr env tv - go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) - go (CastTy t _) = go t - go (CoercionTy {}) = tm_coerce - ------------------ -xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a -xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m - -xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } -xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) - |>> xtG (D env t2) f } -xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } -xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } -xtT (D env (CastTy t _)) f m = xtT (D env t) f m -xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } -xtT (D env (ForAllTy (Bndr tv _) ty)) f m - = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) - |>> xtBndr env tv f } -xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) -xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) - -fdT :: (a -> b -> b) -> TypeMapX a -> b -> b -fdT k m = foldTM k (tm_var m) - . foldTM (foldTM k) (tm_app m) - . foldTM k (tm_tycon m) - . foldTM (foldTM k) (tm_forall m) - . foldTyLit k (tm_tylit m) - . foldMaybe k (tm_coerce m) - ------------------------- -data TyLitMap a = TLM { tlm_number :: Map.Map Integer a - , tlm_string :: Map.Map FastString a - } - -instance TrieMap TyLitMap where - type Key TyLitMap = TyLit - emptyTM = emptyTyLitMap - lookupTM = lkTyLit - alterTM = xtTyLit - foldTM = foldTyLit - mapTM = mapTyLit - -emptyTyLitMap :: TyLitMap a -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } - -mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b -mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) - = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts } - -lkTyLit :: TyLit -> TyLitMap a -> Maybe a -lkTyLit l = - case l of - NumTyLit n -> tlm_number >.> Map.lookup n - StrTyLit n -> tlm_string >.> Map.lookup n - -xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a -xtTyLit l f m = - case l of - NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } - StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } - -foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b -foldTyLit l m = flip (Map.foldr l) (tlm_string m) - . flip (Map.foldr l) (tlm_number m) - -------------------------------------------------- --- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this --- is the type you want. The keys in this map may have different kinds. -newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) - -lkTT :: DeBruijn Type -> TypeMap a -> Maybe a -lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m - >>= lkG (D env ty) - -xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a -xtTT (D env ty) f (TypeMap m) - = TypeMap (m |> xtG (D env $ typeKind ty) - |>> xtG (D env ty) f) - --- Below are some client-oriented functions which operate on 'TypeMap'. - -instance TrieMap TypeMap where - type Key TypeMap = Type - emptyTM = TypeMap emptyTM - lookupTM k m = lkTT (deBruijnize k) m - alterTM k f m = xtTT (deBruijnize k) f m - foldTM k (TypeMap m) = foldTM (foldTM k) m - mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) - -foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b -foldTypeMap k z m = foldTM k m z - -emptyTypeMap :: TypeMap a -emptyTypeMap = emptyTM - -lookupTypeMap :: TypeMap a -> Type -> Maybe a -lookupTypeMap cm t = lookupTM t cm - -extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a -extendTypeMap m t v = alterTM t (const (Just v)) m - -lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a -lookupTypeMapWithScope m cm t = lkTT (D cm t) m - --- | Extend a 'TypeMap' with a type in the given context. --- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to --- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over --- multiple insertions. -extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a -extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m - --- | Construct a deBruijn environment with the given variables in scope. --- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@ -mkDeBruijnContext :: [Var] -> CmEnv -mkDeBruijnContext = extendCMEs emptyCME - --- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), --- you'll find entries inserted under (t), even if (g) is non-reflexive. -newtype LooseTypeMap a - = LooseTypeMap (TypeMapG a) - -instance TrieMap LooseTypeMap where - type Key LooseTypeMap = Type - emptyTM = LooseTypeMap emptyTM - lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m - alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) - foldTM f (LooseTypeMap m) = foldTM f m - mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) - -{- -************************************************************************ -* * - Variables -* * -************************************************************************ --} - -type BoundVar = Int -- Bound variables are deBruijn numbered -type BoundVarMap a = IntMap.IntMap a - -data CmEnv = CME { cme_next :: !BoundVar - , cme_env :: VarEnv BoundVar } - -emptyCME :: CmEnv -emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } - -extendCME :: CmEnv -> Var -> CmEnv -extendCME (CME { cme_next = bv, cme_env = env }) v - = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } - -extendCMEs :: CmEnv -> [Var] -> CmEnv -extendCMEs env vs = foldl' extendCME env vs - -lookupCME :: CmEnv -> Var -> Maybe BoundVar -lookupCME (CME { cme_env = env }) v = lookupVarEnv env v - --- | @DeBruijn a@ represents @a@ modulo alpha-renaming. This is achieved --- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn --- numbering. This allows us to define an 'Eq' instance for @DeBruijn a@, even --- if this was not (easily) possible for @a@. Note: we purposely don't --- export the constructor. Make a helper function if you find yourself --- needing it. -data DeBruijn a = D CmEnv a - --- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no --- bound binders (an empty 'CmEnv'). This is usually what you want if there --- isn't already a 'CmEnv' in scope. -deBruijnize :: a -> DeBruijn a -deBruijnize = D emptyCME - -instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where - D _ [] == D _ [] = True - D env (x:xs) == D env' (x':xs') = D env x == D env' x' && - D env xs == D env' xs' - _ == _ = False - ---------- Variable binders ------------- - --- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between --- binding forms whose binders have different types. For example, --- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should --- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: --- we can disambiguate this by matching on the type (or kind, if this --- a binder in a type) of the binder. -type BndrMap = TypeMapG - --- Note [Binders] --- ~~~~~~~~~~~~~~ --- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all --- of these data types have binding forms. - -lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a -lkBndr env v m = lkG (D env (varType v)) m - -xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a -xtBndr env v f = xtG (D env (varType v)) f - ---------- Variable occurrence ------------- -data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable - , vm_fvar :: DVarEnv a } -- Free variable - -instance TrieMap VarMap where - type Key VarMap = Var - emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } - lookupTM = lkVar emptyCME - alterTM = xtVar emptyCME - foldTM = fdVar - mapTM = mapVar - -mapVar :: (a->b) -> VarMap a -> VarMap b -mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) - = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } - -lkVar :: CmEnv -> Var -> VarMap a -> Maybe a -lkVar env v - | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv - | otherwise = vm_fvar >.> lkDFreeVar v - -xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a -xtVar env v f m - | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f } - | otherwise = m { vm_fvar = vm_fvar m |> xtDFreeVar v f } - -fdVar :: (a -> b -> b) -> VarMap a -> b -> b -fdVar k m = foldTM k (vm_bvar m) - . foldTM k (vm_fvar m) - -lkDFreeVar :: Var -> DVarEnv a -> Maybe a -lkDFreeVar var env = lookupDVarEnv env var - -xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a -xtDFreeVar v f m = alterDVarEnv f m v diff --git a/coreSyn/CoreOpt.hs b/coreSyn/CoreOpt.hs deleted file mode 100644 --- a/coreSyn/CoreOpt.hs +++ /dev/null @@ -1,1474 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -module CoreOpt ( - -- ** Simple expression optimiser - simpleOptPgm, simpleOptExpr, simpleOptExprWith, - - -- ** Join points - joinPointBinding_maybe, joinPointBindings_maybe, - - -- ** Predicates on expressions - exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, - - -- ** Coercions and casts - pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreArity( etaExpandToJoinPoint ) - -import CoreSyn -import CoreSubst -import CoreUtils -import CoreFVs -import {-#SOURCE #-} CoreUnfold ( mkUnfolding ) -import MkCore ( FloatBind(..) ) -import PprCore ( pprCoreBindings, pprRules ) -import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) -import Literal ( Literal(LitString) ) -import Id -import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) -import Var ( isNonCoVarId ) -import VarSet -import VarEnv -import DataCon -import Demand( etaExpandStrictSig ) -import OptCoercion ( optCoercion ) -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) -import TyCon ( tyConArity ) -import TysWiredIn -import PrelNames -import BasicTypes -import Module ( Module ) -import ErrUtils -import DynFlags -import Outputable -import Pair -import Util -import Maybes ( orElse ) -import FastString -import Data.List -import qualified Data.ByteString as BS - -{- -************************************************************************ -* * - The Simple Optimiser -* * -************************************************************************ - -Note [The simple optimiser] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The simple optimiser is a lightweight, pure (non-monadic) function -that rapidly does a lot of simple optimisations, including - - - inlining things that occur just once, - or whose RHS turns out to be trivial - - beta reduction - - case of known constructor - - dead code elimination - -It does NOT do any call-site inlining; it only inlines a function if -it can do so unconditionally, dropping the binding. It thereby -guarantees to leave no un-reduced beta-redexes. - -It is careful to follow the guidance of "Secrets of the GHC inliner", -and in particular the pre-inline-unconditionally and -post-inline-unconditionally story, to do effective beta reduction on -functions called precisely once, without repeatedly optimising the same -expression. In fact, the simple optimiser is a good example of this -little dance in action; the full Simplifier is a lot more complicated. - --} - -simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr --- See Note [The simple optimiser] --- Do simple optimisation on an expression --- The optimisation is very straightforward: just --- inline non-recursive bindings that are used only once, --- or where the RHS is trivial --- --- We also inline bindings that bind a Eq# box: see --- See Note [Getting the map/coerce RULE to work]. --- --- Also we convert functions to join points where possible (as --- the occurrence analyser does most of the work anyway). --- --- The result is NOT guaranteed occurrence-analysed, because --- in (let x = y in ....) we substitute for x; so y's occ-info --- may change radically - -simpleOptExpr dflags expr - = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) - simpleOptExprWith dflags init_subst expr - where - init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) - -- It's potentially important to make a proper in-scope set - -- Consider let x = ..y.. in \y. ...x... - -- Then we should remember to clone y before substituting - -- for x. It's very unlikely to occur, because we probably - -- won't *be* substituting for x if it occurs inside a - -- lambda. - -- - -- It's a bit painful to call exprFreeVars, because it makes - -- three passes instead of two (occ-anal, and go) - -simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr --- See Note [The simple optimiser] -simpleOptExprWith dflags subst expr - = simple_opt_expr init_env (occurAnalyseExpr expr) - where - init_env = SOE { soe_dflags = dflags - , soe_inl = emptyVarEnv - , soe_subst = subst } - ----------------------- -simpleOptPgm :: DynFlags -> Module - -> CoreProgram -> [CoreRule] - -> IO (CoreProgram, [CoreRule]) --- See Note [The simple optimiser] -simpleOptPgm dflags this_mod binds rules - = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings occ_anald_binds $$ pprRules rules ); - - ; return (reverse binds', rules') } - where - occ_anald_binds = occurAnalysePgm this_mod - (\_ -> True) {- All unfoldings active -} - (\_ -> False) {- No rules active -} - rules binds - - (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds - final_subst = soe_subst final_env - - rules' = substRulesForImportedIds final_subst rules - -- We never unconditionally inline into rules, - -- hence paying just a substitution - - do_one (env, binds') bind - = case simple_opt_bind env bind TopLevel of - (env', Nothing) -> (env', binds') - (env', Just bind') -> (env', bind':binds') - --- In these functions the substitution maps InVar -> OutExpr - ----------------------- -type SimpleClo = (SimpleOptEnv, InExpr) - -data SimpleOptEnv - = SOE { soe_dflags :: DynFlags - , soe_inl :: IdEnv SimpleClo - -- Deals with preInlineUnconditionally; things - -- that occur exactly once and are inlined - -- without having first been simplified - - , soe_subst :: Subst - -- Deals with cloning; includes the InScopeSet - } - -instance Outputable SimpleOptEnv where - ppr (SOE { soe_inl = inl, soe_subst = subst }) - = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl - , text "soe_subst =" <+> ppr subst ] - <+> text "}" - -emptyEnv :: DynFlags -> SimpleOptEnv -emptyEnv dflags - = SOE { soe_dflags = dflags - , soe_inl = emptyVarEnv - , soe_subst = emptySubst } - -soeZapSubst :: SimpleOptEnv -> SimpleOptEnv -soeZapSubst env@(SOE { soe_subst = subst }) - = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } - -soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv --- Take in-scope set from env1, and the rest from env2 -soeSetInScope (SOE { soe_subst = subst1 }) - env2@(SOE { soe_subst = subst2 }) - = env2 { soe_subst = setInScope subst2 (substInScope subst1) } - ---------------- -simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr -simple_opt_clo env (e_env, e) - = simple_opt_expr (soeSetInScope env e_env) e - -simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr -simple_opt_expr env expr - = go expr - where - subst = soe_subst env - in_scope = substInScope subst - in_scope_env = (in_scope, simpleUnfoldingFun) - - go (Var v) - | Just clo <- lookupVarEnv (soe_inl env) v - = simple_opt_clo env clo - | otherwise - = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v - - go (App e1 e2) = simple_app env e1 [(env,e2)] - go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co) - go (Lit lit) = Lit lit - go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) - go (Cast e co) | isReflCo co' = go e - | otherwise = Cast (go e) co' - where - co' = optCoercion (soe_dflags env) (getTCvSubst subst) co - - go (Let bind body) = case simple_opt_bind env bind NotTopLevel of - (env', Nothing) -> simple_opt_expr env' body - (env', Just bind) -> Let bind (simple_opt_expr env' body) - - go lam@(Lam {}) = go_lam env [] lam - go (Case e b ty as) - -- See Note [Getting the map/coerce RULE to work] - | isDeadBinder b - , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' - -- We don't need to be concerned about floats when looking for coerce. - , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as - = case altcon of - DEFAULT -> go rhs - _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs - where - (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ - zipEqual "simpleOptExpr" bs es - - -- Note [Getting the map/coerce RULE to work] - | isDeadBinder b - , [(DEFAULT, _, rhs)] <- as - , isCoVarType (varType b) - , (Var fun, _args) <- collectArgs e - , fun `hasKey` coercibleSCSelIdKey - -- without this last check, we get #11230 - = go rhs - - | otherwise - = Case e' b' (substTy subst ty) - (map (go_alt env') as) - where - e' = go e - (env', b') = subst_opt_bndr env b - - ---------------------- - go_alt env (con, bndrs, rhs) - = (con, bndrs', simple_opt_expr env' rhs) - where - (env', bndrs') = subst_opt_bndrs env bndrs - - ---------------------- - -- go_lam tries eta reduction - go_lam env bs' (Lam b e) - = go_lam env' (b':bs') e - where - (env', b') = subst_opt_bndr env b - go_lam env bs' e - | Just etad_e <- tryEtaReduce bs e' = etad_e - | otherwise = mkLams bs e' - where - bs = reverse bs' - e' = simple_opt_expr env e - ----------------------- --- simple_app collects arguments for beta reduction -simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr - -simple_app env (Var v) as - | Just (env', e) <- lookupVarEnv (soe_inl env) v - = simple_app (soeSetInScope env env') e as - - | let unf = idUnfolding v - , isCompulsoryUnfolding (idUnfolding v) - , isAlwaysActive (idInlineActivation v) - -- See Note [Unfold compulsory unfoldings in LHSs] - = simple_app (soeZapSubst env) (unfoldingTemplate unf) as - - | otherwise - , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v - = finish_app env out_fn as - -simple_app env (App e1 e2) as - = simple_app env e1 ((env, e2) : as) - -simple_app env (Lam b e) (a:as) - = wrapLet mb_pr (simple_app env' e as) - where - (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel - -simple_app env (Tick t e) as - -- Okay to do "(Tick t e) x ==> Tick t (e x)"? - | t `tickishScopesLike` SoftScope - = mkTick t $ simple_app env e as - --- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) --- The let might appear there as a result of inlining --- e.g. let f = let x = e in b --- in f a1 a2 --- (#13208) --- However, do /not/ do this transformation for join points --- See Note [simple_app and join points] -simple_app env (Let bind body) args - = case simple_opt_bind env bind NotTopLevel of - (env', Nothing) -> simple_app env' body args - (env', Just bind') - | isJoinBind bind' -> finish_app env expr' args - | otherwise -> Let bind' (simple_app env' body args) - where - expr' = Let bind' (simple_opt_expr env' body) - -simple_app env e as - = finish_app env (simple_opt_expr env e) as - -finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -finish_app _ fun [] - = fun -finish_app env fun (arg:args) - = finish_app env (App fun (simple_opt_clo env arg)) args - ----------------------- -simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag - -> (SimpleOptEnv, Maybe OutBind) -simple_opt_bind env (NonRec b r) top_level - = (env', case mb_pr of - Nothing -> Nothing - Just (b,r) -> Just (NonRec b r)) - where - (b', r') = joinPointBinding_maybe b r `orElse` (b, r) - (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level - -simple_opt_bind env (Rec prs) top_level - = (env'', res_bind) - where - res_bind = Just (Rec (reverse rev_prs')) - prs' = joinPointBindings_maybe prs `orElse` prs - (env', bndrs') = subst_opt_bndrs env (map fst prs') - (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs') - do_pr (env, prs) ((b,r), b') - = (env', case mb_pr of - Just pr -> pr : prs - Nothing -> prs) - where - (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level - ----------------------- -simple_bind_pair :: SimpleOptEnv - -> InVar -> Maybe OutVar - -> SimpleClo - -> TopLevelFlag - -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) - -- (simple_bind_pair subst in_var out_rhs) - -- either extends subst with (in_var -> out_rhs) - -- or returns Nothing -simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) - in_bndr mb_out_bndr clo@(rhs_env, in_rhs) - top_level - | Type ty <- in_rhs -- let a::* = TYPE ty in - , let out_ty = substTy (soe_subst rhs_env) ty - = ASSERT( isTyVar in_bndr ) - (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) - - | Coercion co <- in_rhs - , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co - = ASSERT( isCoVar in_bndr ) - (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) - - | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) - -- The previous two guards got rid of tyvars and coercions - -- See Note [CoreSyn type and coercion invariant] in CoreSyn - pre_inline_unconditionally - = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) - - | otherwise - = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs - occ active stable_unf top_level - where - stable_unf = isStableUnfolding (idUnfolding in_bndr) - active = isAlwaysActive (idInlineActivation in_bndr) - occ = idOccInfo in_bndr - - out_rhs | Just join_arity <- isJoinId_maybe in_bndr - = simple_join_rhs join_arity - | otherwise - = simple_opt_clo env clo - - simple_join_rhs join_arity -- See Note [Preserve join-binding arity] - = mkLams join_bndrs' (simple_opt_expr env_body join_body) - where - env0 = soeSetInScope env rhs_env - (join_bndrs, join_body) = collectNBinders join_arity in_rhs - (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs - - pre_inline_unconditionally :: Bool - pre_inline_unconditionally - | isExportedId in_bndr = False - | stable_unf = False - | not active = False -- Note [Inline prag in simplOpt] - | not (safe_to_inline occ) = False - | otherwise = True - - -- Unconditionally safe to inline - safe_to_inline :: OccInfo -> Bool - safe_to_inline (IAmALoopBreaker {}) = False - safe_to_inline IAmDead = True - safe_to_inline OneOcc{ occ_in_lam = False - , occ_n_br = 1 } = True - safe_to_inline OneOcc{} = False - safe_to_inline (ManyOccs {}) = False - -------------------- -simple_out_bind :: TopLevelFlag - -> SimpleOptEnv - -> (InVar, OutExpr) - -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) - | Type out_ty <- out_rhs - = ASSERT( isTyVar in_bndr ) - (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) - - | Coercion out_co <- out_rhs - = ASSERT( isCoVar in_bndr ) - (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) - - | otherwise - = simple_out_bind_pair env in_bndr Nothing out_rhs - (idOccInfo in_bndr) True False top_level - -------------------- -simple_out_bind_pair :: SimpleOptEnv - -> InId -> Maybe OutId -> OutExpr - -> OccInfo -> Bool -> Bool -> TopLevelFlag - -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -simple_out_bind_pair env in_bndr mb_out_bndr out_rhs - occ_info active stable_unf top_level - | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) - -- Type and coercion bindings are caught earlier - -- See Note [CoreSyn type and coercion invariant] - post_inline_unconditionally - = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } - , Nothing) - - | otherwise - = ( env', Just (out_bndr, out_rhs) ) - where - (env', bndr1) = case mb_out_bndr of - Just out_bndr -> (env, out_bndr) - Nothing -> subst_opt_bndr env in_bndr - out_bndr = add_info env' in_bndr top_level out_rhs bndr1 - - post_inline_unconditionally :: Bool - post_inline_unconditionally - | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] - | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] - | not active = False -- in SimplUtils - | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline - -- because it might be referred to "earlier" - | exprIsTrivial out_rhs = True - | coercible_hack = True - | otherwise = False - - is_loop_breaker = isWeakLoopBreaker occ_info - - -- See Note [Getting the map/coerce RULE to work] - coercible_hack | (Var fun, args) <- collectArgs out_rhs - , Just dc <- isDataConWorkId_maybe fun - , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey - = all exprIsTrivial args - | otherwise - = False - -{- Note [Exported Ids and trivial RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We obviously do not want to unconditionally inline an Id that is exported. -In SimplUtils, Note [Top level and postInlineUnconditionally], we -explain why we don't inline /any/ top-level things unconditionally, even -trivial ones. But we do here! Why? In the simple optimiser - - * We do no rule rewrites - * We do no call-site inlining - -Those differences obviate the reasons for not inlining a trivial rhs, -and increase the benefit for doing so. So we unconditionally inline trivial -rhss here. - -Note [Preserve join-binding arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Be careful /not/ to eta-reduce the RHS of a join point, lest we lose -the join-point arity invariant. #15108 was caused by simplifying -the RHS with simple_opt_expr, which does eta-reduction. Solution: -simplify the RHS of a join point by simplifying under the lambdas -(which of course should be there). - -Note [simple_app and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general for let-bindings we can do this: - (let { x = e } in b) a ==> let { x = e } in b a - -But not for join points! For two reasons: - -- We would need to push the continuation into the RHS: - (join { j = e } in b) a ==> let { j' = e a } in b[j'/j] a - NB ----^^ - and also change the type of j, hence j'. - That's a bit sophisticated for the very simple optimiser. - -- We might end up with something like - join { j' = e a } in - (case blah of ) - ( True -> j' void# ) a - ( False -> blah ) - and now the call to j' doesn't look like a tail call, and - Lint may reject. I say "may" because this is /explicitly/ - allowed in the "Compiling without Continuations" paper - (Section 3, "Managing \Delta"). But GHC currently does not - allow this slightly-more-flexible form. See CoreSyn - Note [Join points are less general than the paper]. - -The simple thing to do is to disable this transformation -for join points in the simple optimiser - -Note [The Let-Unfoldings Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A program has the Let-Unfoldings property iff: - -- For every let-bound variable f, whether top-level or nested, whether - recursive or not: - - Both the binding Id of f, and every occurence Id of f, has an idUnfolding. - - For non-INLINE things, that unfolding will be f's right hand sids - - For INLINE things (which have a "stable" unfolding) that unfolding is - semantically equivalent to f's RHS, but derived from the original RHS of f - rather that its current RHS. - -Informally, we can say that in a program that has the Let-Unfoldings property, -all let-bound Id's have an explicit unfolding attached to them. - -Currently, the simplifier guarantees the Let-Unfoldings invariant for anything -it outputs. - --} - ----------------------- -subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) -subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs - -subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) -subst_opt_bndr env bndr - | isTyVar bndr = (env { soe_subst = subst_tv }, tv') - | isCoVar bndr = (env { soe_subst = subst_cv }, cv') - | otherwise = subst_opt_id_bndr env bndr - where - subst = soe_subst env - (subst_tv, tv') = substTyVarBndr subst bndr - (subst_cv, cv') = substCoVarBndr subst bndr - -subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) --- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by --- add_info. --- --- Rather like SimplEnv.substIdBndr --- --- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr --- carefully does not do) because simplOptExpr invalidates it - -subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id - = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id) - where - Subst in_scope id_subst tv_subst cv_subst = subst - - id1 = uniqAway in_scope old_id - id2 = setIdType id1 (substTy subst (idType old_id)) - new_id = zapFragileIdInfo id2 - -- Zaps rules, unfolding, and fragile OccInfo - -- The unfolding and rules will get added back later, by add_info - - new_in_scope = in_scope `extendInScopeSet` new_id - - no_change = new_id == old_id - - -- Extend the substitution if the unique has changed, - -- See the notes with substTyVarBndr for the delSubstEnv - new_id_subst - | no_change = delVarEnv id_subst old_id - | otherwise = extendVarEnv id_subst old_id (Var new_id) - - new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst - new_inl = delVarEnv inl old_id - ----------------------- -add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar -add_info env old_bndr top_level new_rhs new_bndr - | isTyVar old_bndr = new_bndr - | otherwise = lazySetIdInfo new_bndr new_info - where - subst = soe_subst env - dflags = soe_dflags env - old_info = idInfo old_bndr - - -- Add back in the rules and unfolding which were - -- removed by zapFragileIdInfo in subst_opt_id_bndr. - -- - -- See Note [The Let-Unfoldings Invariant] - new_info = idInfo new_bndr `setRuleInfo` new_rules - `setUnfoldingInfo` new_unfolding - - old_rules = ruleInfo old_info - new_rules = substSpec subst new_bndr old_rules - - old_unfolding = unfoldingInfo old_info - new_unfolding | isStableUnfolding old_unfolding - = substUnfolding subst old_unfolding - | otherwise - = unfolding_from_rhs - - unfolding_from_rhs = mkUnfolding dflags InlineRhs - (isTopLevel top_level) - False -- may be bottom or not - new_rhs - -simpleUnfoldingFun :: IdUnfoldingFun -simpleUnfoldingFun id - | isAlwaysActive (idInlineActivation id) = idUnfolding id - | otherwise = noUnfolding - -wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr -wrapLet Nothing body = body -wrapLet (Just (b,r)) body = Let (NonRec b r) body - -{- -Note [Inline prag in simplOpt] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If there's an INLINE/NOINLINE pragma that restricts the phase in -which the binder can be inlined, we don't inline here; after all, -we don't know what phase we're in. Here's an example - - foo :: Int -> Int -> Int - {-# INLINE foo #-} - foo m n = inner m - where - {-# INLINE [1] inner #-} - inner m = m+n - - bar :: Int -> Int - bar n = foo n 1 - -When inlining 'foo' in 'bar' we want the let-binding for 'inner' -to remain visible until Phase 1 - -Note [Unfold compulsory unfoldings in LHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user writes `RULES map coerce = coerce` as a rule, the rule -will only ever match if simpleOptExpr replaces coerce by its unfolding -on the LHS, because that is the core that the rule matching engine -will find. So do that for everything that has a compulsory -unfolding. Also see Note [Desugaring coerce as cast] in Desugar. - -However, we don't want to inline 'seq', which happens to also have a -compulsory unfolding, so we only do this unfolding only for things -that are always-active. See Note [User-defined RULES for seq] in MkId. - -Note [Getting the map/coerce RULE to work] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to allow the "map/coerce" RULE to fire: - - {-# RULES "map/coerce" map coerce = coerce #-} - -The naive core produced for this is - - forall a b (dict :: Coercible * a b). - map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' - - where dict' :: Coercible [a] [b] - dict' = ... - -This matches literal uses of `map coerce` in code, but that's not what we -want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) -too. Some of this is addressed by compulsorily unfolding coerce on the LHS, -yielding - - forall a b (dict :: Coercible * a b). - map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Getting better. But this isn't exactly what gets produced. This is because -Coercible essentially has ~R# as a superclass, and superclasses get eagerly -extracted during solving. So we get this: - - forall a b (dict :: Coercible * a b). - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Unfortunately, this still abstracts over a Coercible dictionary. We really -want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, -which transforms the above to (see also Note [Desugaring coerce as cast] in -Desugar) - - forall a b (co :: a ~R# b). - let dict = MkCoercible @* @a @b co in - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... - -Now, we need simpleOptExpr to fix this up. It does so by taking three -separate actions: - 1. Inline certain non-recursive bindings. The choice whether to inline - is made in simple_bind_pair. Note the rather specific check for - MkCoercible in there. - - 2. Stripping case expressions like the Coercible_SCSel one. - See the `Case` case of simple_opt_expr's `go` function. - - 3. Look for case expressions that unpack something that was - just packed and inline them. This is also done in simple_opt_expr's - `go` function. - -This is all a fair amount of special-purpose hackery, but it's for -a good cause. And it won't hurt other RULES and such that it comes across. - - -************************************************************************ -* * - Join points -* * -************************************************************************ --} - --- | Returns Just (bndr,rhs) if the binding is a join point: --- If it's a JoinId, just return it --- If it's not yet a JoinId but is always tail-called, --- make it into a JoinId and return it. --- In the latter case, eta-expand the RHS if necessary, to make the --- lambdas explicit, as is required for join points --- --- Precondition: the InBndr has been occurrence-analysed, --- so its OccInfo is valid -joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) -joinPointBinding_maybe bndr rhs - | not (isId bndr) - = Nothing - - | isJoinId bndr - = Just (bndr, rhs) - - | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) - , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs - , let str_sig = idStrictness bndr - str_arity = count isId bndrs -- Strictness demands are for Ids only - join_bndr = bndr `asJoinId` join_arity - `setIdStrictness` etaExpandStrictSig str_arity str_sig - = Just (join_bndr, mkLams bndrs body) - - | otherwise - = Nothing - -joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] -joinPointBindings_maybe bndrs - = mapM (uncurry joinPointBinding_maybe) bndrs - - -{- Note [Strictness and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - let f = \x. if x>200 then e1 else e1 - -and we know that f is strict in x. Then if we subsequently -discover that f is an arity-2 join point, we'll eta-expand it to - - let f = \x y. if x>200 then e1 else e1 - -and now it's only strict if applied to two arguments. So we should -adjust the strictness info. - -A more common case is when - - f = \x. error ".." - -and again its arity increases (#15517) --} - -{- ********************************************************************* -* * - exprIsConApp_maybe -* * -************************************************************************ - -Note [exprIsConApp_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~ -exprIsConApp_maybe is a very important function. There are two principal -uses: - * case e of { .... } - * cls_op e, where cls_op is a class operation - -In both cases you want to know if e is of form (C e1..en) where C is -a data constructor. - -However e might not *look* as if - - -Note [exprIsConApp_maybe on literal strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #9400 and #13317. - -Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core -they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or -unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. - -For optimizations we want to be able to treat it as a list, so they can be -decomposed when used in a case-statement. exprIsConApp_maybe detects those -calls to unpackCString# and returns: - -Just (':', [Char], ['a', unpackCString# "bc"]). - -We need to be careful about UTF8 strings here. ""# contains a ByteString, so -we must parse it back into a FastString to split off the first character. -That way we can treat unpackCString# and unpackCStringUtf8# in the same way. - -We must also be caeful about - lvl = "foo"# - ...(unpackCString# lvl)... -to ensure that we see through the let-binding for 'lvl'. Hence the -(exprIsLiteral_maybe .. arg) in the guard before the call to -dealWithStringLiteral. - -Note [Push coercions in exprIsConApp_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #13025 I found a case where we had - op (df @t1 @t2) -- op is a ClassOp -where - df = (/\a b. K e1 e2) |> g - -To get this to come out we need to simplify on the fly - ((/\a b. K e1 e2) |> g) @t1 @t2 - -Hence the use of pushCoArgs. - -Note [exprIsConApp_maybe on data constructors with wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: -- some data constructors have wrappers -- these wrappers inline late (see MkId Note [Activation for data constructor wrappers]) -- but we still want case-of-known-constructor to fire early. - -Example: - data T = MkT !Int - $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT - foo x = case $WMkT e of MkT y -> blah - -Here we want the case-of-known-constructor transformation to fire, giving - foo x = case e of x' -> let y = x' in blah - -Here's how exprIsConApp_maybe achieves this: - -0. Start with scrutinee = $WMkT e - -1. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked - as expandable. (See CoreUtils.isExpandableApp.) Now we have - scrutinee = (\n. case n of n' -> MkT n') e - -2. Beta-reduce the application, generating a floated 'let'. - See Note [beta-reduction in exprIsConApp_maybe] below. Now we have - scrutinee = case n of n' -> MkT n' - with floats {Let n = e} - -3. Float the "case x of x' ->" binding out. Now we have - scrutinee = MkT n' - with floats {Let n = e; case n of n' ->} - -And now we have a known-constructor MkT that we can return. - -Notice that both (2) and (3) require exprIsConApp_maybe to gather and return -a bunch of floats, both let and case bindings. - -Note [beta-reduction in exprIsConApp_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is -typically a function. For instance, take the wrapper for MkT in Note -[exprIsConApp_maybe on data constructors with wrappers]: - - $WMkT n = case n of { n' -> T n' } - -If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT, -it will see - - (\n -> case n of { n' -> T n' }) arg - -In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction. - -We don't want to blindly substitute `arg` in the body of the function, because -it duplicates work. We can (and, in fact, used to) substitute `arg` in the body, -but only when `arg` is a variable (or something equally work-free). - -But, because of Note [exprIsConApp_maybe on data constructors with wrappers], -'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce -_always_: - - (\x -> body) arg - -Is transformed into - - let x = arg in body - -Which, effectively, means emitting a float `let x = arg` and recursively -analysing the body. - -For newtypes, this strategy requires that their wrappers have compulsory unfoldings. -Suppose we have - newtype T a b where - MkT :: a -> T b a -- Note args swapped - -This defines a worker function MkT, a wrapper function $WMkT, and an axT: - $WMkT :: forall a b. a -> T b a - $WMkT = /\b a. \(x:a). MkT a b x -- A real binding - - MkT :: forall a b. a -> T a b - MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding - - axiom axT :: a ~R# T a b - -Now we are optimising - case $WMkT (I# 3) |> sym axT of I# y -> ... -we clearly want to simplify this. If $WMkT did not have a compulsory -unfolding, we would end up with - let a = I#3 in case a of I# y -> ... -because in general, we do this on-the-fly beta-reduction - (\x. e) blah --> let x = blah in e -and then float the the let. (Substitution would risk duplicating 'blah'.) - -But if the case-of-known-constructor doesn't actually fire (i.e. -exprIsConApp_maybe does not return Just) then nothing happens, and nothing -will happen the next time either. - -See test T16254, which checks the behavior of newtypes. --} - -data ConCont = CC [CoreExpr] Coercion - -- Substitution already applied - --- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument --- expression is a *saturated* constructor application of the form @let b1 in --- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the --- *universally-quantified* type args of 'dc'. Floats can also be (and most --- likely are) single-alternative case expressions. Why does --- 'exprIsConApp_maybe' return floats? We may have to look through lets and --- cases to detect that we are in the presence of a data constructor wrapper. In --- this case, we need to return the lets and cases that we traversed. See Note --- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers --- are unfolded late, but we really want to trigger case-of-known-constructor as --- early as possible. See also Note [Activation for data constructor wrappers] --- in MkId. --- --- We also return the incoming InScopeSet, augmented with --- the binders from any [FloatBind] that we return -exprIsConApp_maybe :: InScopeEnv -> CoreExpr - -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe (in_scope, id_unf) expr - = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) - where - go :: Either InScopeSet Subst - -- Left in-scope means "empty substitution" - -- Right subst means "apply this substitution to the CoreExpr" - -- NB: in the call (go subst floats expr cont) - -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' - -> [FloatBind] -> CoreExpr -> ConCont - -- Notice that the floats here are in reverse order - -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) - go subst floats (Tick t expr) cont - | not (tickishIsCode t) = go subst floats expr cont - - go subst floats (Cast expr co1) (CC args co2) - | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args - -- See Note [Push coercions in exprIsConApp_maybe] - = case m_co1' of - MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2)) - MRefl -> go subst floats expr (CC args' co2) - - go subst floats (App fun arg) (CC args co) - = go subst floats fun (CC (subst_expr subst arg : args) co) - - go subst floats (Lam bndr body) (CC (arg:args) co) - | exprIsTrivial arg -- Don't duplicate stuff! - = go (extend subst bndr arg) floats body (CC args co) - | otherwise - = let (subst', bndr') = subst_bndr subst bndr - float = FloatLet (NonRec bndr' arg) - in go subst' (float:floats) body (CC args co) - - go subst floats (Let (NonRec bndr rhs) expr) cont - = let rhs' = subst_expr subst rhs - (subst', bndr') = subst_bndr subst bndr - float = FloatLet (NonRec bndr' rhs') - in go subst' (float:floats) expr cont - - go subst floats (Case scrut b _ [(con, vars, expr)]) cont - = let - scrut' = subst_expr subst scrut - (subst', b') = subst_bndr subst b - (subst'', vars') = subst_bndrs subst' vars - float = FloatCase scrut' b' con vars' - in - go subst'' (float:floats) expr cont - - go (Right sub) floats (Var v) cont - = go (Left (substInScope sub)) - floats - (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) - cont - - go (Left in_scope) floats (Var fun) cont@(CC args co) - - | Just con <- isDataConWorkId_maybe fun - , count isValArg args == idArity fun - = succeedWith in_scope floats $ - pushCoDataCon con args co - - -- Look through data constructor wrappers: they inline late (See Note - -- [Activation for data constructor wrappers]) but we want to do - -- case-of-known-constructor optimisation eagerly. - | isDataConWrapId fun - , let rhs = uf_tmpl (realIdUnfolding fun) - = go (Left in_scope) floats rhs cont - - -- Look through dictionary functions; see Note [Unfolding DFuns] - | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding - , bndrs `equalLength` args -- See Note [DFun arity check] - , let subst = mkOpenSubst in_scope (bndrs `zip` args) - = succeedWith in_scope floats $ - pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co - - -- Look through unfoldings, but only arity-zero one; - -- if arity > 0 we are effectively inlining a function call, - -- and that is the business of callSiteInline. - -- In practice, without this test, most of the "hits" were - -- CPR'd workers getting inlined back into their wrappers, - | idArity fun == 0 - , Just rhs <- expandUnfolding_maybe unfolding - , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) - = go (Left in_scope') floats rhs cont - - -- See Note [exprIsConApp_maybe on literal strings] - | (fun `hasKey` unpackCStringIdKey) || - (fun `hasKey` unpackCStringUtf8IdKey) - , [arg] <- args - , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg - = succeedWith in_scope floats $ - dealWithStringLiteral fun str co - where - unfolding = id_unf fun - - go _ _ _ _ = Nothing - - succeedWith :: InScopeSet -> [FloatBind] - -> Maybe (DataCon, [Type], [CoreExpr]) - -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) - succeedWith in_scope rev_floats x - = do { (con, tys, args) <- x - ; let floats = reverse rev_floats - ; return (in_scope, floats, con, tys, args) } - - ---------------------------- - -- Operations on the (Either InScopeSet CoreSubst) - -- The Left case is wildly dominant - subst_co (Left {}) co = co - subst_co (Right s) co = CoreSubst.substCo s co - - subst_expr (Left {}) e = e - subst_expr (Right s) e = substExpr (text "exprIsConApp2") s e - - subst_bndr msubst bndr - = (Right subst', bndr') - where - (subst', bndr') = substBndr subst bndr - subst = case msubst of - Left in_scope -> mkEmptySubst in_scope - Right subst -> subst - - subst_bndrs subst bs = mapAccumL subst_bndr subst bs - - extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) - extend (Right s) v e = Right (extendSubst s v e) - - --- See Note [exprIsConApp_maybe on literal strings] -dealWithStringLiteral :: Var -> BS.ByteString -> Coercion - -> Maybe (DataCon, [Type], [CoreExpr]) - --- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS --- turns those into [] automatically, but just in case something else in GHC --- generates a string literal directly. -dealWithStringLiteral _ str co - | BS.null str - = pushCoDataCon nilDataCon [Type charTy] co - -dealWithStringLiteral fun str co - = let strFS = mkFastStringByteString str - - char = mkConApp charDataCon [mkCharLit (headFS strFS)] - charTail = bytesFS (tailFS strFS) - - -- In singleton strings, just add [] instead of unpackCstring# ""#. - rest = if BS.null charTail - then mkConApp nilDataCon [Type charTy] - else App (Var fun) - (Lit (LitString charTail)) - - in pushCoDataCon consDataCon [Type charTy, char, rest] co - -{- -Note [Unfolding DFuns] -~~~~~~~~~~~~~~~~~~~~~~ -DFuns look like - - df :: forall a b. (Eq a, Eq b) -> Eq (a,b) - df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) - ($c2 a b d_a d_b) - -So to split it up we just need to apply the ops $c1, $c2 etc -to the very same args as the dfun. It takes a little more work -to compute the type arguments to the dictionary constructor. - -Note [DFun arity check] -~~~~~~~~~~~~~~~~~~~~~~~ -Here we check that the total number of supplied arguments (inclding -type args) matches what the dfun is expecting. This may be *less* -than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn --} - -exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal --- Same deal as exprIsConApp_maybe, but much simpler --- Nevertheless we do need to look through unfoldings for --- Integer and string literals, which are vigorously hoisted to top level --- and not subsequently inlined -exprIsLiteral_maybe env@(_, id_unf) e - = case e of - Lit l -> Just l - Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? - Var v | Just rhs <- expandUnfolding_maybe (id_unf v) - -> exprIsLiteral_maybe env rhs - _ -> Nothing - -{- -Note [exprIsLambda_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprIsLambda_maybe will, given an expression `e`, try to turn it into the form -`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through -casts (using the Push rule), and it unfolds function calls if the unfolding -has a greater arity than arguments are present. - -Currently, it is used in Rules.match, and is required to make -"map coerce = coerce" match. --} - -exprIsLambda_maybe :: InScopeEnv -> CoreExpr - -> Maybe (Var, CoreExpr,[Tickish Id]) - -- See Note [exprIsLambda_maybe] - --- The simple case: It is a lambda already -exprIsLambda_maybe _ (Lam x e) - = Just (x, e, []) - --- Still straightforward: Ticks that we can float out of the way -exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) - | tickishFloatable t - , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e - = Just (x, e, t:ts) - --- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) - | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e - -- Only do value lambdas. - -- this implies that x is not in scope in gamma (makes this code simpler) - , not (isTyVar x) && not (isCoVar x) - , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True - , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co - , let res = Just (x',e',ts) - = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) - res - --- Another attempt: See if we find a partial unfolding -exprIsLambda_maybe (in_scope_set, id_unf) e - | (Var f, as, ts) <- collectArgsTicks tickishFloatable e - , idArity f > count isValArg as - -- Make sure there is hope to get a lambda - , Just rhs <- expandUnfolding_maybe (id_unf f) - -- Optimize, for beta-reduction - , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as) - -- Recurse, because of possible casts - , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' - , let res = Just (x', e'', ts++ts') - = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) - res - -exprIsLambda_maybe _ _e - = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) - Nothing - - -{- ********************************************************************* -* * - The "push rules" -* * -************************************************************************ - -Here we implement the "push rules" from FC papers: - -* The push-argument rules, where we can move a coercion past an argument. - We have - (fun |> co) arg - and we want to transform it to - (fun arg') |> co' - for some suitable co' and tranformed arg'. - -* The PushK rule for data constructors. We have - (K e1 .. en) |> co - and we want to tranform to - (K e1' .. en') - by pushing the coercion into the arguments --} - -pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) -pushCoArgs co [] = return ([], MCo co) -pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg - ; case m_co1 of - MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args - ; return (arg':args', m_co2) } - MRefl -> return (arg':args, MRefl) } - -pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) --- We have (fun |> co) arg, and we want to transform it to --- (fun arg) |> co --- This may fail, e.g. if (fun :: N) where N is a newtype --- C.f. simplCast in Simplify.hs --- 'co' is always Representational --- If the returned coercion is Nothing, then it would have been reflexive -pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty - ; return (Type ty', m_co') } -pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co - ; return (val_arg `mkCast` arg_co, m_co') } - -pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) --- We have (fun |> co) @ty --- Push the coercion through to return --- (fun @ty') |> co' --- 'co' is always Representational --- If the returned coercion is Nothing, then it would have been reflexive; --- it's faster not to compute it, though. -pushCoTyArg co ty - -- The following is inefficient - don't do `eqType` here, the coercion - -- optimizer will take care of it. See #14737. - -- -- | tyL `eqType` tyR - -- -- = Just (ty, Nothing) - - | isReflCo co - = Just (ty, MRefl) - - | isForAllTy_ty tyL - = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty ) - Just (ty `mkCastTy` co1, MCo co2) - - | otherwise - = Nothing - where - Pair tyL tyR = coercionKind co - -- co :: tyL ~ tyR - -- tyL = forall (a1 :: k1). ty1 - -- tyR = forall (a2 :: k2). ty2 - - co1 = mkSymCo (mkNthCo Nominal 0 co) - -- co1 :: k2 ~N k1 - -- Note that NthCo can extract a Nominal equality between the - -- kinds of the types related by a coercion between forall-types. - -- See the NthCo case in CoreLint. - - co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) - -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] - -- Arg of mkInstCo is always nominal, hence mkNomReflCo - -pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion) --- We have (fun |> co) arg --- Push the coercion through to return --- (fun (arg |> co_arg)) |> co_res --- 'co' is always Representational --- If the second returned Coercion is actually Nothing, then no cast is necessary; --- the returned coercion would have been reflexive. -pushCoValArg co - -- The following is inefficient - don't do `eqType` here, the coercion - -- optimizer will take care of it. See #14737. - -- -- | tyL `eqType` tyR - -- -- = Just (mkRepReflCo arg, Nothing) - - | isReflCo co - = Just (mkRepReflCo arg, MRefl) - - | isFunTy tyL - , (co1, co2) <- decomposeFunCo Representational co - -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) - -- then co1 :: tyL1 ~ tyR1 - -- co2 :: tyL2 ~ tyR2 - = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) - Just (mkSymCo co1, MCo co2) - - | otherwise - = Nothing - where - arg = funArgTy tyR - Pair tyL tyR = coercionKind co - -pushCoercionIntoLambda - :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) --- This implements the Push rule from the paper on coercions --- (\x. e) |> co --- ===> --- (\x'. e |> co') -pushCoercionIntoLambda in_scope x e co - | ASSERT(not (isTyVar x) && not (isCoVar x)) True - , Pair s1s2 t1t2 <- coercionKind co - , Just (_s1,_s2) <- splitFunTy_maybe s1s2 - , Just (t1,_t2) <- splitFunTy_maybe t1t2 - = let (co1, co2) = decomposeFunCo Representational co - -- Should we optimize the coercions here? - -- Otherwise they might not match too well - x' = x `setIdType` t1 - in_scope' = in_scope `extendInScopeSet` x' - subst = extendIdSubst (mkEmptySubst in_scope') - x - (mkCast (Var x') co1) - in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2) - | otherwise - = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) - Nothing - -pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion - -> Maybe (DataCon - , [Type] -- Universal type args - , [CoreExpr]) -- All other args incl existentials --- Implement the KPush reduction rule as described in "Down with kinds" --- The transformation applies iff we have --- (C e1 ... en) `cast` co --- where co :: (T t1 .. tn) ~ to_ty --- The left-hand one must be a T, because exprIsConApp returned True --- but the right-hand one might not be. (Though it usually will.) -pushCoDataCon dc dc_args co - | isReflCo co || from_ty `eqType` to_ty -- try cheap test first - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args - = Just (dc, map exprToType univ_ty_args, rest_args) - - | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty - , to_tc == dataConTyCon dc - -- These two tests can fail; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there's nothing wrong with it - - = let - tc_arity = tyConArity to_tc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tcvars = dataConExTyCoVars dc - arg_tys = dataConRepArgTys dc - - non_univ_args = dropList dc_univ_tyvars dc_args - (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args - - -- Make the "Psi" from the paper - omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) - (psi_subst, to_ex_arg_tys) - = liftCoSubstWithEx Representational - dc_univ_tyvars - omegas - dc_ex_tcvars - (map exprToType ex_args) - - -- Cast the value arguments (which include dictionaries) - new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) - - to_ex_args = map Type to_ex_arg_tys - - dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, - ppr arg_tys, ppr dc_args, - ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] - in - ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) - ASSERT2( equalLength val_args arg_tys, dump_doc ) - Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) - - | otherwise - = Nothing - - where - Pair from_ty to_ty = coercionKind co - -collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) --- Collect lambda binders, pushing coercions inside if possible --- E.g. (\x.e) |> g g :: -> blah --- = (\x. e |> Nth 1 g) --- --- That is, --- --- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) -collectBindersPushingCo e - = go [] e - where - -- Peel off lambdas until we hit a cast. - go :: [Var] -> CoreExpr -> ([Var], CoreExpr) - -- The accumulator is in reverse order - go bs (Lam b e) = go (b:bs) e - go bs (Cast e co) = go_c bs e co - go bs e = (reverse bs, e) - - -- We are in a cast; peel off casts until we hit a lambda. - go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) - -- (go_c bs e c) is same as (go bs e (e |> c)) - go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) - go_c bs (Lam b e) co = go_lam bs b e co - go_c bs e co = (reverse bs, mkCast e co) - - -- We are in a lambda under a cast; peel off lambdas and build a - -- new coercion for the body. - go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) - -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) - go_lam bs b e co - | isTyVar b - , let Pair tyL tyR = coercionKind co - , ASSERT( isForAllTy_ty tyL ) - isForAllTy_ty tyR - , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) - - | isCoVar b - , let Pair tyL tyR = coercionKind co - , ASSERT( isForAllTy_co tyL ) - isForAllTy_co tyR - , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] - , let cov = mkCoVarCo b - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) - - | isId b - , let Pair tyL tyR = coercionKind co - , ASSERT( isFunTy tyL) isFunTy tyR - , (co_arg, co_res) <- decomposeFunCo Representational co - , isReflCo co_arg -- See Note [collectBindersPushingCo] - = go_c (b:bs) e co_res - - | otherwise = (reverse bs, mkCast (Lam b e) co) - -{- - -Note [collectBindersPushingCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We just look for coercions of form - -> blah -(and similarly for foralls) to keep this function simple. We could do -more elaborate stuff, but it'd involve substitution etc. - --} diff --git a/coreSyn/CorePrep.hs b/coreSyn/CorePrep.hs deleted file mode 100644 --- a/coreSyn/CorePrep.hs +++ /dev/null @@ -1,1736 +0,0 @@ -{- -(c) The University of Glasgow, 1994-2006 - - -Core pass to saturate constructors and PrimOps --} - -{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-} - -module CorePrep ( - corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural, - lookupMkIntegerName, lookupIntegerSDataConName, - lookupMkNaturalName, lookupNaturalSDataConName - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import OccurAnal - -import HscTypes -import PrelNames -import MkId ( realWorldPrimId ) -import CoreUtils -import CoreArity -import CoreFVs -import CoreMonad ( CoreToDo(..) ) -import CoreLint ( endPassIO ) -import CoreSyn -import CoreSubst -import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here -import Type -import Literal -import Coercion -import TcEnv -import TyCon -import Demand -import Var -import VarSet -import VarEnv -import Id -import IdInfo -import TysWiredIn -import DataCon -import BasicTypes -import Module -import UniqSupply -import Maybes -import OrdList -import ErrUtils -import DynFlags -import Util -import Pair -import Outputable -import GHC.Platform -import FastString -import Name ( NamedThing(..), nameSrcSpan ) -import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) -import Data.Bits -import MonadUtils ( mapAccumLM ) -import Data.List ( mapAccumL ) -import Control.Monad -import CostCentre ( CostCentre, ccFromThisModule ) -import qualified Data.Set as S - -{- --- --------------------------------------------------------------------------- --- Note [CorePrep Overview] --- --------------------------------------------------------------------------- - -The goal of this pass is to prepare for code generation. - -1. Saturate constructor applications. - -2. Convert to A-normal form; that is, function arguments - are always variables. - - * Use case for strict arguments: - f E ==> case E of x -> f x - (where f is strict) - - * Use let for non-trivial lazy arguments - f E ==> let x = E in f x - (were f is lazy and x is non-trivial) - -3. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' - rhss in let-form right up to this point.] - -4. Ensure that *value* lambdas only occur as the RHS of a binding - (The code generator can't deal with anything else.) - Type lambdas are ok, however, because the code gen discards them. - -5. [Not any more; nuked Jun 2002] Do the seq/par munging. - -6. Clone all local Ids. - This means that all such Ids are unique, rather than the - weaker guarantee of no clashes which the simplifier provides. - And that is what the code generator needs. - - We don't clone TyVars or CoVars. The code gen doesn't need that, - and doing so would be tiresome because then we'd need - to substitute in types and coercions. - -7. Give each dynamic CCall occurrence a fresh unique; this is - rather like the cloning step above. - -8. Inject bindings for the "implicit" Ids: - * Constructor wrappers - * Constructor workers - We want curried definitions for all of these in case they - aren't inlined by some caller. - -9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.hs - Also replace (noinline e) by e. - -10. Convert (LitInteger i t) into the core representation - for the Integer i. Normally this uses mkInteger, but if - we are using the integer-gmp implementation then there is a - special case where we use the S# constructor for Integers that - are in the range of Int. - -11. Same for LitNatural. - -12. Uphold tick consistency while doing this: We move ticks out of - (non-type) applications where we can, and make sure that we - annotate according to scoping rules when floating. - -13. Collect cost centres (including cost centres in unfoldings) if we're in - profiling mode. We have to do this here beucase we won't have unfoldings - after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules]. - -This is all done modulo type applications and abstractions, so that -when type erasure is done for conversion to STG, we don't end up with -any trivial or useless bindings. - - -Note [CorePrep invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is the syntax of the Core produced by CorePrep: - - Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co - - Applications - app ::= lit | var | app arg | app ty | app co | app |> co - - Expressions - body ::= app - | let(rec) x = rhs in body -- Boxed only - | case body of pat -> body - | /\a. body | /\c. body - | body |> co - - Right hand sides (only place where value lambdas can occur) - rhs ::= /\a.rhs | \x.rhs | body - -We define a synonym for each of these non-terminals. Functions -with the corresponding name produce a result in that syntax. --} - -type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' -type CpeBody = CoreExpr -- Non-terminal 'body' -type CpeRhs = CoreExpr -- Non-terminal 'rhs' - -{- -************************************************************************ -* * - Top level stuff -* * -************************************************************************ --} - -corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] - -> IO (CoreProgram, S.Set CostCentre) -corePrepPgm hsc_env this_mod mod_loc binds data_tycons = - withTiming dflags - (text "CorePrep"<+>brackets (ppr this_mod)) - (const ()) $ do - us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env - - let cost_centres - | WayProf `elem` ways dflags - = collectCostCentres this_mod binds - | otherwise - = S.empty - - implicit_binds = mkDataConWorkers dflags mod_loc data_tycons - -- NB: we must feed mkImplicitBinds through corePrep too - -- so that they are suitably cloned and eta-expanded - - binds_out = initUs_ us $ do - floats1 <- corePrepTopBinds initialCorePrepEnv binds - floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds - return (deFloatTop (floats1 `appendFloats` floats2)) - - endPassIO hsc_env alwaysQualify CorePrep binds_out [] - return (binds_out, cost_centres) - where - dflags = hsc_dflags hsc_env - -corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -corePrepExpr dflags hsc_env expr = - withTiming dflags (text "CorePrep [expr]") (const ()) $ do - us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env - let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) - return new_expr - -corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats --- Note [Floating out of top level bindings] -corePrepTopBinds initialCorePrepEnv binds - = go initialCorePrepEnv binds - where - go _ [] = return emptyFloats - go env (bind : binds) = do (env', floats, maybe_new_bind) - <- cpeBind TopLevel env bind - MASSERT(isNothing maybe_new_bind) - -- Only join points get returned this way by - -- cpeBind, and no join point may float to top - floatss <- go env' binds - return (floats `appendFloats` floatss) - -mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind] --- See Note [Data constructor workers] --- c.f. Note [Injecting implicit bindings] in TidyPgm -mkDataConWorkers dflags mod_loc data_tycons - = [ NonRec id (tick_it (getName data_con) (Var id)) - -- The ice is thin here, but it works - | tycon <- data_tycons, -- CorePrep will eta-expand it - data_con <- tyConDataCons tycon, - let id = dataConWorkId data_con - ] - where - -- If we want to generate debug info, we put a source note on the - -- worker. This is useful, especially for heap profiling. - tick_it name - | debugLevel dflags == 0 = id - | RealSrcSpan span <- nameSrcSpan name = tick span - | Just file <- ml_hs_file mod_loc = tick (span1 file) - | otherwise = tick (span1 "???") - where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name)) - span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 - -{- -Note [Floating out of top level bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: we do need to float out of top-level bindings -Consider x = length [True,False] -We want to get - s1 = False : [] - s2 = True : s1 - x = length s2 - -We return a *list* of bindings, because we may start with - x* = f (g y) -where x is demanded, in which case we want to finish with - a = g y - x* = f a -And then x will actually end up case-bound - -Note [CafInfo and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What happens when we try to float bindings to the top level? At this -point all the CafInfo is supposed to be correct, and we must make certain -that is true of the new top-level bindings. There are two cases -to consider - -a) The top-level binding is marked asCafRefs. In that case we are - basically fine. The floated bindings had better all be lazy lets, - so they can float to top level, but they'll all have HasCafRefs - (the default) which is safe. - -b) The top-level binding is marked NoCafRefs. This really happens - Example. CoreTidy produces - $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... - Now CorePrep has to eta-expand to - $fApplicativeSTM = let sat = \xy. retry x y - in D:Alternative sat ...blah... - So what we *want* is - sat [NoCafRefs] = \xy. retry x y - $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... - - So, gruesomely, we must set the NoCafRefs flag on the sat bindings, - *and* substitute the modified 'sat' into the old RHS. - - It should be the case that 'sat' is itself [NoCafRefs] (a value, no - cafs) else the original top-level binding would not itself have been - marked [NoCafRefs]. The DEBUG check in CoreToStg for - consistentCafInfo will find this. - -This is all very gruesome and horrible. It would be better to figure -out CafInfo later, after CorePrep. We'll do that in due course. -Meanwhile this horrible hack works. - -Note [Join points and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Join points can float out of other join points but not out of value bindings: - - let z = - let w = ... in -- can float - join k = ... in -- can't float - ... jump k ... - join j x1 ... xn = - let y = ... in -- can float (but don't want to) - join h = ... in -- can float (but not much point) - ... jump h ... - in ... - -Here, the jump to h remains valid if h is floated outward, but the jump to k -does not. - -We don't float *out* of join points. It would only be safe to float out of -nullary join points (or ones where the arguments are all either type arguments -or dead binders). Nullary join points aren't ever recursive, so they're always -effectively one-shot functions, which we don't float out of. We *could* float -join points from nullary join points, but there's no clear benefit at this -stage. - -Note [Data constructor workers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Create any necessary "implicit" bindings for data con workers. We -create the rather strange (non-recursive!) binding - - $wC = \x y -> $wC x y - -i.e. a curried constructor that allocates. This means that we can -treat the worker for a constructor like any other function in the rest -of the compiler. The point here is that CoreToStg will generate a -StgConApp for the RHS, rather than a call to the worker (which would -give a loop). As Lennart says: the ice is thin here, but it works. - -Hmm. Should we create bindings for dictionary constructors? They are -always fully applied, and the bindings are just there to support -partial applications. But it's easier to let them through. - - -Note [Dead code in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Imagine that we got an input program like this (see #4962): - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g True (Just x) + g () (Just x), g) - where - g :: Show a => a -> Maybe Int -> Int - g _ Nothing = x - g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown - -After specialisation and SpecConstr, we would get something like this: - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) - where - {-# RULES g $dBool = g$Bool - g $dUnit = g$Unit #-} - g = ... - {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} - g$Bool = ... - {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} - g$Unit = ... - g$Bool_True_Just = ... - g$Unit_Unit_Just = ... - -Note that the g$Bool and g$Unit functions are actually dead code: they -are only kept alive by the occurrence analyser because they are -referred to by the rules of g, which is being kept alive by the fact -that it is used (unspecialised) in the returned pair. - -However, at the CorePrep stage there is no way that the rules for g -will ever fire, and it really seems like a shame to produce an output -program that goes to the trouble of allocating a closure for the -unreachable g$Bool and g$Unit functions. - -The way we fix this is to: - * In cloneBndr, drop all unfoldings/rules - - * In deFloatTop, run a simple dead code analyser on each top-level - RHS to drop the dead local bindings. For that call to OccAnal, we - disable the binder swap, else the occurrence analyser sometimes - introduces new let bindings for cased binders, which lead to the bug - in #5433. - -The reason we don't just OccAnal the whole output of CorePrep is that -the tidier ensures that all top-level binders are GlobalIds, so they -don't show up in the free variables any longer. So if you run the -occurrence analyser on the output of CoreTidy (or later) you e.g. turn -this program: - - Rec { - f = ... f ... - } - -Into this one: - - f = ... f ... - -(Since f is not considered to be free in its own RHS.) - - -************************************************************************ -* * - The main code -* * -************************************************************************ --} - -cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind - -> UniqSM (CorePrepEnv, - Floats, -- Floating value bindings - Maybe CoreBind) -- Just bind' <=> returned new bind; no float - -- Nothing <=> added bind' to floats instead -cpeBind top_lvl env (NonRec bndr rhs) - | not (isJoinId bndr) - = do { (_, bndr1) <- cpCloneBndr env bndr - ; let dmd = idDemandInfo bndr - is_unlifted = isUnliftedType (idType bndr) - ; (floats, rhs1) <- cpePair top_lvl NonRecursive - dmd is_unlifted - env bndr1 rhs - -- See Note [Inlining in CorePrep] - ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl - then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing) - else do { - - ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1 - - ; return (extendCorePrepEnv env bndr bndr1, - addFloat floats new_float, - Nothing) }} - - | otherwise -- A join point; see Note [Join points and floating] - = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point - do { (_, bndr1) <- cpCloneBndr env bndr - ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs - ; return (extendCorePrepEnv env bndr bndr2, - emptyFloats, - Just (NonRec bndr2 rhs1)) } - -cpeBind top_lvl env (Rec pairs) - | not (isJoinId (head bndrs)) - = do { (env', bndrs1) <- cpCloneBndrs env bndrs - ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') - bndrs1 rhss - - ; let (floats_s, rhss1) = unzip stuff - all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) - (concatFloats floats_s) - - ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), - unitFloat (FloatLet (Rec all_pairs)), - Nothing) } - - | otherwise -- See Note [Join points and floating] - = do { (env', bndrs1) <- cpCloneBndrs env bndrs - ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss - - ; let bndrs2 = map fst pairs1 - ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2), - emptyFloats, - Just (Rec pairs1)) } - where - (bndrs, rhss) = unzip pairs - - -- Flatten all the floats, and the current - -- group into a single giant Rec - add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 - add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - add_float b _ = pprPanic "cpeBind" (ppr b) - ---------------- -cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool - -> CorePrepEnv -> OutId -> CoreExpr - -> UniqSM (Floats, CpeRhs) --- Used for all bindings --- The binder is already cloned, hence an OutId -cpePair top_lvl is_rec dmd is_unlifted env bndr rhs - = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair - do { (floats1, rhs1) <- cpeRhsE env rhs - - -- See if we are allowed to float this stuff out of the RHS - ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 - - -- Make the arity match up - ; (floats3, rhs3) - <- if manifestArity rhs1 <= arity - then return (floats2, cpeEtaExpand arity rhs2) - else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) - -- Note [Silly extra arguments] - (do { v <- newVar (idType bndr) - ; let float = mkFloat topDmd False v rhs2 - ; return ( addFloat floats2 float - , cpeEtaExpand arity (Var v)) }) - - -- Wrap floating ticks - ; let (floats4, rhs4) = wrapTicks floats3 rhs3 - - ; return (floats4, rhs4) } - where - platform = targetPlatform (cpe_dynFlags env) - - arity = idArity bndr -- We must match this arity - - --------------------- - float_from_rhs floats rhs - | isEmptyFloats floats = return (emptyFloats, rhs) - | isTopLevel top_lvl = float_top floats rhs - | otherwise = float_nested floats rhs - - --------------------- - float_nested floats rhs - | wantFloatNested is_rec dmd is_unlifted floats rhs - = return (floats, rhs) - | otherwise = dontFloat floats rhs - - --------------------- - float_top floats rhs -- Urhgh! See Note [CafInfo and floating] - | mayHaveCafRefs (idCafInfo bndr) - , allLazyTop floats - = return (floats, rhs) - - -- So the top-level binding is marked NoCafRefs - | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs - = return (floats', rhs') - - | otherwise - = dontFloat floats rhs - -dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody) --- Non-empty floats, but do not want to float from rhs --- So wrap the rhs in the floats --- But: rhs1 might have lambdas, and we can't --- put them inside a wrapBinds -dontFloat floats1 rhs - = do { (floats2, body) <- rhsToBody rhs - ; return (emptyFloats, wrapBinds floats1 $ - wrapBinds floats2 body) } - -{- Note [Silly extra arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we had this - f{arity=1} = \x\y. e -We *must* match the arity on the Id, so we have to generate - f' = \x\y. e - f = \x. f' x - -It's a bizarre case: why is the arity on the Id wrong? Reason -(in the days of __inline_me__): - f{arity=0} = __inline_me__ (let v = expensive in \xy. e) -When InlineMe notes go away this won't happen any more. But -it seems good for CorePrep to be robust. --} - ---------------- -cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr - -> UniqSM (JoinId, CpeRhs) --- Used for all join bindings --- No eta-expansion: see Note [Do not eta-expand join points] in SimplUtils -cpeJoinPair env bndr rhs - = ASSERT(isJoinId bndr) - do { let Just join_arity = isJoinId_maybe bndr - (bndrs, body) = collectNBinders join_arity rhs - - ; (env', bndrs') <- cpCloneBndrs env bndrs - - ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts - -- with a lambda - - ; let rhs' = mkCoreLams bndrs' body' - bndr' = bndr `setIdUnfolding` evaldUnfolding - `setIdArity` count isId bndrs - -- See Note [Arity and join points] - - ; return (bndr', rhs') } - -{- -Note [Arity and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Up to now, we've allowed a join point to have an arity greater than its join -arity (minus type arguments), since this is what's useful for eta expansion. -However, for code gen purposes, its arity must be exactly the number of value -arguments it will be called with, and it must have exactly that many value -lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS: - - join j x y z = \w -> ... in ... - => - join j x y z = (let f = \w -> ... in f) in ... - -This is also what happens with Note [Silly extra arguments]. Note that it's okay -for us to mess with the arity because a join point is never exported. --} - --- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs --- --------------------------------------------------------------------------- - -cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- If --- e ===> (bs, e') --- then --- e = let bs in e' (semantically, that is!) --- --- For example --- f (g x) ===> ([v = g x], f v) - -cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) -cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) -cpeRhsE env (Lit (LitNumber LitNumInteger i _)) - = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) - (cpe_integerSDataCon env) i) -cpeRhsE env (Lit (LitNumber LitNumNatural i _)) - = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env) - (cpe_naturalSDataCon env) i) -cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr -cpeRhsE env expr@(App {}) = cpeApp env expr - -cpeRhsE env (Let bind body) - = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind - ; (body_floats, body') <- cpeRhsE env' body - ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' - Nothing -> body' - ; return (bind_floats `appendFloats` body_floats, expr') } - -cpeRhsE env (Tick tickish expr) - | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope - = do { (floats, body) <- cpeRhsE env expr - -- See [Floating Ticks in CorePrep] - ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) } - | otherwise - = do { body <- cpeBodyNF env expr - ; return (emptyFloats, mkTick tickish' body) } - where - tickish' | Breakpoint n fvs <- tickish - -- See also 'substTickish' - = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) - | otherwise - = tickish - -cpeRhsE env (Cast expr co) - = do { (floats, expr') <- cpeRhsE env expr - ; return (floats, Cast expr' co) } - -cpeRhsE env expr@(Lam {}) - = do { let (bndrs,body) = collectBinders expr - ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body - ; return (emptyFloats, mkLams bndrs' body') } - -cpeRhsE env (Case scrut bndr ty alts) - = do { (floats, scrut') <- cpeBody env scrut - ; (env', bndr2) <- cpCloneBndr env bndr - ; let alts' - -- This flag is intended to aid in debugging strictness - -- analysis bugs. These are particularly nasty to chase down as - -- they may manifest as segmentation faults. When this flag is - -- enabled we instead produce an 'error' expression to catch - -- the case where a function we think should bottom - -- unexpectedly returns. - | gopt Opt_CatchBottoms (cpe_dynFlags env) - , not (altsAreExhaustive alts) - = addDefault alts (Just err) - | otherwise = alts - where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty - "Bottoming expression returned" - ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } - where - sat_alt env (con, bs, rhs) - = do { (env2, bs') <- cpCloneBndrs env bs - ; rhs' <- cpeBodyNF env2 rhs - ; return (con, bs', rhs') } - -cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr --- Here we convert a literal Integer to the low-level --- representation. Exactly how we do this depends on the --- library that implements Integer. If it's GMP we --- use the S# data constructor for small literals. --- See Note [Integer literals] in Literal -cvtLitInteger dflags _ (Just sdatacon) i - | inIntRange dflags i -- Special case for small integers - = mkConApp sdatacon [Lit (mkLitInt dflags i)] - -cvtLitInteger dflags mk_integer _ i - = mkApps (Var mk_integer) [isNonNegative, ints] - where isNonNegative = if i < 0 then mkConApp falseDataCon [] - else mkConApp trueDataCon [] - ints = mkListExpr intTy (f (abs i)) - f 0 = [] - f x = let low = x .&. mask - high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high - bits = 31 - mask = 2 ^ bits - 1 - -cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr --- Here we convert a literal Natural to the low-level --- representation. --- See Note [Natural literals] in Literal -cvtLitNatural dflags _ (Just sdatacon) i - | inWordRange dflags i -- Special case for small naturals - = mkConApp sdatacon [Lit (mkLitWord dflags i)] - -cvtLitNatural dflags mk_natural _ i - = mkApps (Var mk_natural) [words] - where words = mkListExpr wordTy (f i) - f 0 = [] - f x = let low = x .&. mask - high = x `shiftR` bits - in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high - bits = 32 - mask = 2 ^ bits - 1 - --- --------------------------------------------------------------------------- --- CpeBody: produces a result satisfying CpeBody --- --------------------------------------------------------------------------- - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without --- producing any floats (any generated floats are immediately --- let-bound using 'wrapBinds'). Generally you want this, esp. --- when you've reached a binding form (e.g., a lambda) and --- floating any further would be incorrect. -cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr - = do { (floats, body) <- cpeBody env expr - ; return (wrapBinds floats body) } - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce --- a list of 'Floats' which are being propagated upwards. In --- fact, this function is used in only two cases: to --- implement 'cpeBodyNF' (which is what you usually want), --- and in the case when a let-binding is in a case scrutinee--here, --- we can always float out: --- --- case (let x = y in z) of ... --- ==> let x = y in case z of ... --- -cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) -cpeBody env expr - = do { (floats1, rhs) <- cpeRhsE env expr - ; (floats2, body) <- rhsToBody rhs - ; return (floats1 `appendFloats` floats2, body) } - --------- -rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-binding - -rhsToBody (Tick t expr) - | tickishScoped t == NoScope -- only float out of non-scoped annotations - = do { (floats, expr') <- rhsToBody expr - ; return (floats, mkTick t expr') } - -rhsToBody (Cast e co) - -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - = do { (floats, e') <- rhsToBody e - ; return (floats, Cast e' co) } - -rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) - | all isTyVar bndrs -- Type lambdas are ok - = return (emptyFloats, expr) - | otherwise -- Some value lambdas - = do { fn <- newVar (exprType expr) - ; let rhs = cpeEtaExpand (exprArity expr) expr - float = FloatLet (NonRec fn rhs) - ; return (unitFloat float, Var fn) } - where - (bndrs,body) = collectBinders expr - -rhsToBody expr = return (emptyFloats, expr) - - - --- --------------------------------------------------------------------------- --- CpeApp: produces a result satisfying CpeApp --- --------------------------------------------------------------------------- - -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick (Tickish Id) - -{- Note [runRW arg] -~~~~~~~~~~~~~~~~~~~ -If we got, say - runRW# (case bot of {}) -which happened in #11291, we do /not/ want to turn it into - (case bot of {}) realWorldPrimId# -because that gives a panic in CoreToStg.myCollectArgs, which expects -only variables in function position. But if we are sure to make -runRW# strict (which we do in MkId), this can't happen --} - -cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops -cpeApp top_env expr - = do { let (terminal, args, depth) = collect_args expr - ; cpe_app top_env terminal args depth - } - - where - -- We have a nested data structure of the form - -- e `App` a1 `App` a2 ... `App` an, convert it into - -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth) - -- We use 'ArgInfo' because we may also need to - -- record casts and ticks. Depth counts the number - -- of arguments that would consume strictness information - -- (so, no type or coercion arguments.) - collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int) - collect_args e = go e [] 0 - where - go (App fun arg) as !depth - = go fun (CpeApp arg : as) - (if isTyCoArg arg then depth else depth + 1) - go (Cast fun co) as depth - = go fun (CpeCast co : as) depth - go (Tick tickish fun) as depth - | tickishPlace tickish == PlaceNonLam - && tickish `tickishScopesLike` SoftScope - = go fun (CpeTick tickish : as) depth - go terminal as depth = (terminal, as, depth) - - cpe_app :: CorePrepEnv - -> CoreExpr - -> [ArgInfo] - -> Int - -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth - | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and - || f `hasKey` noinlineIdKey -- Replace (noinline a) with a - -- Consider the code: - -- - -- lazy (f x) y - -- - -- We need to make sure that we need to recursively collect arguments on - -- "f x", otherwise we'll float "f x" out (it's not a variable) and - -- end up with this awful -ddump-prep: - -- - -- case f x of f_x { - -- __DEFAULT -> f_x y - -- } - -- - -- rather than the far superior "f x y". Test case is par01. - = let (terminal, args', depth') = collect_args arg - in cpe_app env terminal (args' ++ args) (depth + depth' - 1) - cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1 - | f `hasKey` runRWKey - -- See Note [runRW magic] - -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this - -- is why we return a CorePrepEnv as well) - = case arg of - Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0 - _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1 - cpe_app env (Var v) args depth - = do { v1 <- fiddleCCall v - ; let e2 = lookupCorePrepEnv env v1 - hd = getIdFromTrivialExpr_maybe e2 - -- NB: depth from collect_args is right, because e2 is a trivial expression - -- and thus its embedded Id *must* be at the same depth as any - -- Apps it is under are type applications only (c.f. - -- exprIsTrivial). But note that we need the type of the - -- expression, not the id. - ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts - ; mb_saturate hd app floats depth } - where - stricts = case idStrictness v of - StrictSig (DmdType _ demands _) - | listLengthCmp demands depth /= GT -> demands - -- length demands <= depth - | otherwise -> [] - -- If depth < length demands, then we have too few args to - -- satisfy strictness info so we have to ignore all the - -- strictness info, e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, because this - -- partial application might be seq'd - - -- We inlined into something that's not a var and has no args. - -- Bounce it back up to cpeRhsE. - cpe_app env fun [] _ = cpeRhsE env fun - - -- N-variable fun, better let-bind it - cpe_app env fun args depth - = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty - -- The evalDmd says that it's sure to be evaluated, - -- so we'll end up case-binding it - ; (app, floats) <- rebuild_app args fun' ty fun_floats [] - ; mb_saturate Nothing app floats depth } - where - ty = exprType fun - - -- Saturate if necessary - mb_saturate head app floats depth = - case head of - Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth - ; return (floats, sat_app) } - _other -> return (floats, app) - - -- Deconstruct and rebuild the application, floating any non-atomic - -- arguments to the outside. We collect the type of the expression, - -- the head of the application, and the number of actual value arguments, - -- all of which are used to possibly saturate this application if it - -- has a constructor or primop at the head. - rebuild_app - :: [ArgInfo] -- The arguments (inner to outer) - -> CpeApp - -> Type - -> Floats - -> [Demand] - -> UniqSM (CpeApp, Floats) - rebuild_app [] app _ floats ss = do - MASSERT(null ss) -- make sure we used all the strictness info - return (app, floats) - rebuild_app (a : as) fun' fun_ty floats ss = case a of - CpeApp arg@(Type arg_ty) -> - rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss - CpeApp arg@(Coercion {}) -> - rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss - CpeApp arg -> do - let (ss1, ss_rest) -- See Note [lazyId magic] in MkId - = case (ss, isLazyExpr arg) of - (_ : ss_rest, True) -> (topDmd, ss_rest) - (ss1 : ss_rest, False) -> (ss1, ss_rest) - ([], _) -> (topDmd, []) - (arg_ty, res_ty) = - case splitFunTy_maybe fun_ty of - Just as -> as - Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr) - (fs, arg') <- cpeArg top_env ss1 arg arg_ty - rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest - CpeCast co -> - let Pair _ty1 ty2 = coercionKind co - in rebuild_app as (Cast fun' co) ty2 floats ss - CpeTick tickish -> - -- See [Floating Ticks in CorePrep] - rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss - -isLazyExpr :: CoreExpr -> Bool --- See Note [lazyId magic] in MkId -isLazyExpr (Cast e _) = isLazyExpr e -isLazyExpr (Tick _ e) = isLazyExpr e -isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey -isLazyExpr _ = False - -{- Note [runRW magic] -~~~~~~~~~~~~~~~~~~~~~ -Some definitions, for instance @runST@, must have careful control over float out -of the bindings in their body. Consider this use of @runST@, - - f x = runST ( \ s -> let (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' ) - -If we inline @runST@, we'll get: - - f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -And now if we allow the @newArray#@ binding to float out to become a CAF, -we end up with a result that is totally and utterly wrong: - - f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in \ x -> - let (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -All calls to @f@ will share a {\em single} array! Clearly this is nonsense and -must be prevented. - -This is what @runRW#@ gives us: by being inlined extremely late in the -optimization (right before lowering to STG, in CorePrep), we can ensure that -no further floating will occur. This allows us to safely inline things like -@runST@, which are otherwise needlessly expensive (see #10678 and #5916). - -'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE -pragma. It is levity-polymorphic. - - runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) - => (State# RealWorld -> (# State# RealWorld, o #)) - -> (# State# RealWorld, o #) - -It needs no special treatment in GHC except this special inlining here -in CorePrep (and in ByteCodeGen). - --- --------------------------------------------------------------------------- --- CpeArg: produces a result satisfying CpeArg --- --------------------------------------------------------------------------- - -Note [ANF-ising literal string arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a program like, - - data Foo = Foo Addr# - - foo = Foo "turtle"# - -When we go to ANFise this we might think that we want to float the string -literal like we do any other non-trivial argument. This would look like, - - foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s } - -However, this 1) isn't necessary since strings are in a sense "trivial"; and 2) -wreaks havoc on the CAF annotations that we produce here since we the result -above is caffy since it is updateable. Ideally at some point in the future we -would like to just float the literal to the top level as suggested in #11312, - - s = "turtle"# - foo = Foo s - -However, until then we simply add a special case excluding literals from the -floating done by cpeArg. --} - --- | Is an argument okay to CPE? -okCpeArg :: CoreExpr -> Bool --- Don't float literals. See Note [ANF-ising literal string arguments]. -okCpeArg (Lit _) = False --- Do not eta expand a trivial argument -okCpeArg expr = not (exprIsTrivial expr) - --- This is where we arrange that a non-trivial argument is let-bound -cpeArg :: CorePrepEnv -> Demand - -> CoreArg -> Type -> UniqSM (Floats, CpeArg) -cpeArg env dmd arg arg_ty - = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda - ; (floats2, arg2) <- if want_float floats1 arg1 - then return (floats1, arg1) - else dontFloat floats1 arg1 - -- Else case: arg1 might have lambdas, and we can't - -- put them inside a wrapBinds - - ; if okCpeArg arg2 - then do { v <- newVar arg_ty - ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 - arg_float = mkFloat dmd is_unlifted v arg3 - ; return (addFloat floats2 arg_float, varToCoreExpr v) } - else return (floats2, arg2) - } - where - is_unlifted = isUnliftedType arg_ty - want_float = wantFloatNested NonRecursive dmd is_unlifted - -{- -Note [Floating unlifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider C (let v* = expensive in v) - -where the "*" indicates "will be demanded". Usually v will have been -inlined by now, but let's suppose it hasn't (see #2756). Then we -do *not* want to get - - let v* = expensive in C v - -because that has different strictness. Hence the use of 'allLazy'. -(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) - - ------------------------------------------------------------------------------- --- Building the saturated syntax --- --------------------------------------------------------------------------- - -Note [Eta expansion of hasNoBinding things in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -maybeSaturate deals with eta expanding to saturate things that can't deal with -unsaturated applications (identified by 'hasNoBinding', currently just -foreign calls and unboxed tuple/sum constructors). - -Note that eta expansion in CorePrep is very fragile due to the "prediction" of -CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta -expansion in CorePrep] in TidyPgm for details. We previously saturated primop -applications here as well but due to this fragility (see #16846) we now deal -with this another way, as described in Note [Primop wrappers] in PrimOp. - -It's quite likely that eta expansion of constructor applications will -eventually break in a similar way to how primops did. We really should -eliminate this case as well. --} - -maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs -maybeSaturate fn expr n_args - | hasNoBinding fn -- There's no binding - = return sat_expr - - | otherwise - = return expr - where - fn_arity = idArity fn - excess_arity = fn_arity - n_args - sat_expr = cpeEtaExpand excess_arity expr - -{- -************************************************************************ -* * - Simple CoreSyn operations -* * -************************************************************************ --} - -{- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~~ -Eta expand to match the arity claimed by the binder Remember, -CorePrep must not change arity - -Eta expansion might not have happened already, because it is done by -the simplifier only when there at least one lambda already. - -NB1:we could refrain when the RHS is trivial (which can happen - for exported things). This would reduce the amount of code - generated (a little) and make things a little words for - code compiled without -O. The case in point is data constructor - wrappers. - -NB2: we have to be careful that the result of etaExpand doesn't - invalidate any of the assumptions that CorePrep is attempting - to establish. One possible cause is eta expanding inside of - an SCC note - we're now careful in etaExpand to make sure the - SCC is pushed inside any new lambdas that are generated. - -Note [Eta expansion and the CorePrep invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It turns out to be much much easier to do eta expansion -*after* the main CorePrep stuff. But that places constraints -on the eta expander: given a CpeRhs, it must return a CpeRhs. - -For example here is what we do not want: - f = /\a -> g (h 3) -- h has arity 2 -After ANFing we get - f = /\a -> let s = h 3 in g s -and now we do NOT want eta expansion to give - f = /\a -> \ y -> (let s = h 3 in g s) y - -Instead CoreArity.etaExpand gives - f = /\a -> \y -> let s = h 3 in g s y - --} - -cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs -cpeEtaExpand arity expr - | arity == 0 = expr - | otherwise = etaExpand arity expr - -{- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Why try eta reduction? Hasn't the simplifier already done eta? -But the simplifier only eta reduces if that leaves something -trivial (like f, or f Int). But for deLam it would be enough to -get to a partial application: - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } --} - --- When updating this function, make sure it lines up with --- CoreUtils.tryEtaReduce! -tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f - , n_remaining >= 0 - , and (zipWith ok bndrs last_args) - , not (any (`elemVarSet` fvs_remaining) bndrs) - , exprIsHNF remaining_expr -- Don't turn value into a non-value - -- else the behaviour with 'seq' changes - = Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - - ok bndr (Var arg) = bndr == arg - ok _ _ = False - - -- We can't eta reduce something which must be saturated. - ok_to_eta_reduce (Var f) = not (hasNoBinding f) - ok_to_eta_reduce _ = False -- Safe. ToDo: generalise - - -tryEtaReducePrep bndrs (Tick tickish e) - | tickishFloatable tickish - = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e - -tryEtaReducePrep _ _ = Nothing - -{- -************************************************************************ -* * - Floats -* * -************************************************************************ - -Note [Pin demand info on floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin demand info on floated lets, so that we can see the one-shot thunks. --} - -data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - -- They are always of lifted type; - -- unlifted ones are done with FloatCase - - | FloatCase - Id CpeBody - Bool -- The bool indicates "ok-for-speculation" - - -- | See Note [Floating Ticks in CorePrep] - | FloatTick (Tickish Id) - -data Floats = Floats OkToSpec (OrdList FloatingBind) - -instance Outputable FloatingBind where - ppr (FloatLet b) = ppr b - ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r - ppr (FloatTick t) = ppr t - -instance Outputable Floats where - ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+> - braces (vcat (map ppr (fromOL fs))) - -instance Outputable OkToSpec where - ppr OkToSpec = text "OkToSpec" - ppr IfUnboxedOk = text "IfUnboxedOk" - ppr NotOkToSpec = text "NotOkToSpec" - --- Can we float these binds out of the rhs of a let? We cache this decision --- to avoid having to recompute it in a non-linear way when there are --- deeply nested lets. -data OkToSpec - = OkToSpec -- Lazy bindings of lifted type - | IfUnboxedOk -- A mixture of lazy lifted bindings and n - -- ok-to-speculate unlifted bindings - | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings - -mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkFloat dmd is_unlifted bndr rhs - | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs) - | is_hnf = FloatLet (NonRec bndr rhs) - | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) - -- See Note [Pin demand info on floats] - where - is_hnf = exprIsHNF rhs - is_strict = isStrictDmd dmd - use_case = is_unlifted || is_strict && not is_hnf - -- Don't make a case for a value binding, - -- even if it's strict. Otherwise we get - -- case (\x -> e) of ...! - -emptyFloats :: Floats -emptyFloats = Floats OkToSpec nilOL - -isEmptyFloats :: Floats -> Bool -isEmptyFloats (Floats _ bs) = isNilOL bs - -wrapBinds :: Floats -> CpeBody -> CpeBody -wrapBinds (Floats _ binds) body - = foldrOL mk_bind body binds - where - mk_bind (FloatCase bndr rhs _) body = mkDefaultCase rhs bndr body - mk_bind (FloatLet bind) body = Let bind body - mk_bind (FloatTick tickish) body = mkTick tickish body - -addFloat :: Floats -> FloatingBind -> Floats -addFloat (Floats ok_to_spec floats) new_float - = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) - where - check (FloatLet _) = OkToSpec - check (FloatCase _ _ ok_for_spec) - | ok_for_spec = IfUnboxedOk - | otherwise = NotOkToSpec - check FloatTick{} = OkToSpec - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level - -unitFloat :: FloatingBind -> Floats -unitFloat = addFloat emptyFloats - -appendFloats :: Floats -> Floats -> Floats -appendFloats (Floats spec1 floats1) (Floats spec2 floats2) - = Floats (combine spec1 spec2) (floats1 `appOL` floats2) - -concatFloats :: [Floats] -> OrdList FloatingBind -concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL - -combine :: OkToSpec -> OkToSpec -> OkToSpec -combine NotOkToSpec _ = NotOkToSpec -combine _ NotOkToSpec = NotOkToSpec -combine IfUnboxedOk _ = IfUnboxedOk -combine _ IfUnboxedOk = IfUnboxedOk -combine _ _ = OkToSpec - -deFloatTop :: Floats -> [CoreBind] --- For top level only; we don't expect any FloatCases -deFloatTop (Floats _ floats) - = foldrOL get [] floats - where - get (FloatLet b) bs = occurAnalyseRHSs b : bs - get (FloatCase var body _) bs = - occurAnalyseRHSs (NonRec var body) : bs - get b _ = pprPanic "corePrepPgm" (ppr b) - - -- See Note [Dead code in CorePrep] - occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) - occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes] - ---------------------------------------------------------------------------- - -canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) - -- Note [CafInfo and floating] -canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs - | OkToSpec <- ok_to_spec -- Worth trying - , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) - = Just (Floats OkToSpec fs', subst_expr subst rhs) - | otherwise - = Nothing - where - subst_expr = substExpr (text "CorePrep") - - go :: (Subst, OrdList FloatingBind) -> [FloatingBind] - -> Maybe (Subst, OrdList FloatingBind) - - go (subst, fbs_out) [] = Just (subst, fbs_out) - - go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) - | rhs_ok r - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (subst', b') = set_nocaf_bndr subst b - new_fb = FloatLet (NonRec b' (subst_expr subst r)) - - go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) - | all rhs_ok rs - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (bs,rs) = unzip prs - (subst', bs') = mapAccumL set_nocaf_bndr subst bs - rs' = map (subst_expr subst') rs - new_fb = FloatLet (Rec (bs' `zip` rs')) - - go (subst, fbs_out) (ft@FloatTick{} : fbs_in) - = go (subst, fbs_out `snocOL` ft) fbs_in - - go _ _ = Nothing -- Encountered a caffy binding - - ------------ - set_nocaf_bndr subst bndr - = (extendIdSubst subst bndr (Var bndr'), bndr') - where - bndr' = bndr `setIdCafInfo` NoCafRefs - - ------------ - rhs_ok :: CoreExpr -> Bool - -- We can only float to top level from a NoCaf thing if - -- the new binding is static. However it can't mention - -- any non-static things or it would *already* be Caffy - rhs_ok = rhsIsStatic platform (\_ -> False) - (\_nt i -> pprPanic "rhsIsStatic" (integer i)) - -- Integer or Natural literals should not show up - -wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool -wantFloatNested is_rec dmd is_unlifted floats rhs - = isEmptyFloats floats - || isStrictDmd dmd - || is_unlifted - || (allLazyNested is_rec floats && exprIsHNF rhs) - -- Why the test for allLazyNested? - -- v = f (x `divInt#` y) - -- we don't want to float the case, even if f has arity 2, - -- because floating the case would make it evaluated too early - -allLazyTop :: Floats -> Bool -allLazyTop (Floats OkToSpec _) = True -allLazyTop _ = False - -allLazyNested :: RecFlag -> Floats -> Bool -allLazyNested _ (Floats OkToSpec _) = True -allLazyNested _ (Floats NotOkToSpec _) = False -allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec - -{- -************************************************************************ -* * - Cloning -* * -************************************************************************ --} - --- --------------------------------------------------------------------------- --- The environment --- --------------------------------------------------------------------------- - --- Note [Inlining in CorePrep] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- There is a subtle but important invariant that must be upheld in the output --- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core --- is impermissible: --- --- let x :: () --- x = y --- --- (where y is a reference to a GLOBAL variable). Thunks like this are silly: --- they can always be profitably replaced by inlining x with y. Consequently, --- the code generator/runtime does not bother implementing this properly --- (specifically, there is no implementation of stg_ap_0_upd_info, which is the --- stack frame that would be used to update this thunk. The "0" means it has --- zero free variables.) --- --- In general, the inliner is good at eliminating these let-bindings. However, --- there is one case where these trivial updatable thunks can arise: when --- we are optimizing away 'lazy' (see Note [lazyId magic], and also --- 'cpeRhsE'.) Then, we could have started with: --- --- let x :: () --- x = lazy @ () y --- --- which is a perfectly fine, non-trivial thunk, but then CorePrep will --- drop 'lazy', giving us 'x = y' which is trivial and impermissible. --- The solution is CorePrep to have a miniature inlining pass which deals --- with cases like this. We can then drop the let-binding altogether. --- --- Why does the removal of 'lazy' have to occur in CorePrep? --- The gory details are in Note [lazyId magic] in MkId, but the --- main reason is that lazy must appear in unfoldings (optimizer --- output) and it must prevent call-by-value for catch# (which --- is implemented by CorePrep.) --- --- An alternate strategy for solving this problem is to have the --- inliner treat 'lazy e' as a trivial expression if 'e' is trivial. --- We decided not to adopt this solution to keep the definition --- of 'exprIsTrivial' simple. --- --- There is ONE caveat however: for top-level bindings we have --- to preserve the binding so that we float the (hacky) non-recursive --- binding for data constructors; see Note [Data constructor workers]. --- --- Note [CorePrep inlines trivial CoreExpr not Id] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an --- IdEnv Id? Naively, we might conjecture that trivial updatable thunks --- as per Note [Inlining in CorePrep] always have the form --- 'lazy @ SomeType gbl_id'. But this is not true: the following is --- perfectly reasonable Core: --- --- let x :: () --- x = lazy @ (forall a. a) y @ Bool --- --- When we inline 'x' after eliminating 'lazy', we need to replace --- occurrences of 'x' with 'y @ bool', not just 'y'. Situations like --- this can easily arise with higher-rank types; thus, cpe_env must --- map to CoreExprs, not Ids. - -data CorePrepEnv - = CPE { cpe_dynFlags :: DynFlags - , cpe_env :: IdEnv CoreExpr -- Clone local Ids - -- ^ This environment is used for three operations: - -- - -- 1. To support cloning of local Ids so that they are - -- all unique (see item (6) of CorePrep overview). - -- - -- 2. To support beta-reduction of runRW, see - -- Note [runRW magic] and Note [runRW arg]. - -- - -- 3. To let us inline trivial RHSs of non top-level let-bindings, - -- see Note [lazyId magic], Note [Inlining in CorePrep] - -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076) - , cpe_mkIntegerId :: Id - , cpe_mkNaturalId :: Id - , cpe_integerSDataCon :: Maybe DataCon - , cpe_naturalSDataCon :: Maybe DataCon - } - -lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id -lookupMkIntegerName dflags hsc_env - = guardIntegerUse dflags $ liftM tyThingId $ - lookupGlobal hsc_env mkIntegerName - -lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id -lookupMkNaturalName dflags hsc_env - = guardNaturalUse dflags $ liftM tyThingId $ - lookupGlobal hsc_env mkNaturalName - --- See Note [The integer library] in PrelNames -lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) -lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of - IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $ - lookupGlobal hsc_env integerSDataConName - IntegerSimple -> return Nothing - -lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) -lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of - IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $ - lookupGlobal hsc_env naturalSDataConName - IntegerSimple -> return Nothing - --- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName' -guardIntegerUse :: DynFlags -> IO a -> IO a -guardIntegerUse dflags act - | thisPackage dflags == primUnitId - = return $ panic "Can't use Integer in ghc-prim" - | thisPackage dflags == integerUnitId - = return $ panic "Can't use Integer in integer-*" - | otherwise = act - --- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName' --- --- Just like we can't use Integer literals in `integer-*`, we can't use Natural --- literals in `base`. If we do, we get interface loading error for GHC.Natural. -guardNaturalUse :: DynFlags -> IO a -> IO a -guardNaturalUse dflags act - | thisPackage dflags == primUnitId - = return $ panic "Can't use Natural in ghc-prim" - | thisPackage dflags == integerUnitId - = return $ panic "Can't use Natural in integer-*" - | thisPackage dflags == baseUnitId - = return $ panic "Can't use Natural in base" - | otherwise = act - -mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv -mkInitialCorePrepEnv dflags hsc_env - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - mkNaturalId <- lookupMkNaturalName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env - return $ CPE { - cpe_dynFlags = dflags, - cpe_env = emptyVarEnv, - cpe_mkIntegerId = mkIntegerId, - cpe_mkNaturalId = mkNaturalId, - cpe_integerSDataCon = integerSDataCon, - cpe_naturalSDataCon = naturalSDataCon - } - -extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv -extendCorePrepEnv cpe id id' - = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') } - -extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv -extendCorePrepEnvExpr cpe id expr - = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr } - -extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv -extendCorePrepEnvList cpe prs - = cpe { cpe_env = extendVarEnvList (cpe_env cpe) - (map (\(id, id') -> (id, Var id')) prs) } - -lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr -lookupCorePrepEnv cpe id - = case lookupVarEnv (cpe_env cpe) id of - Nothing -> Var id - Just exp -> exp - -getMkIntegerId :: CorePrepEnv -> Id -getMkIntegerId = cpe_mkIntegerId - -getMkNaturalId :: CorePrepEnv -> Id -getMkNaturalId = cpe_mkNaturalId - ------------------------------------------------------------------------------- --- Cloning binders --- --------------------------------------------------------------------------- - -cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar]) -cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs - -cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) -cpCloneBndr env bndr - | not (isId bndr) - = return (env, bndr) - - | otherwise - = do { bndr' <- clone_it bndr - - -- Drop (now-useless) rules/unfoldings - -- See Note [Drop unfoldings and rules] - -- and Note [Preserve evaluatedness] in CoreTidy - ; let unfolding' = zapUnfolding (realIdUnfolding bndr) - -- Simplifier will set the Id's unfolding - - bndr'' = bndr' `setIdUnfolding` unfolding' - `setIdSpecialisation` emptyRuleInfo - - ; return (extendCorePrepEnv env bndr bndr'', bndr'') } - where - clone_it bndr - | isLocalId bndr, not (isCoVar bndr) - = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) } - | otherwise -- Top level things, which we don't want - -- to clone, have become GlobalIds by now - -- And we don't clone tyvars, or coercion variables - = return bndr - -{- Note [Drop unfoldings and rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to drop the unfolding/rules on every Id: - - - We are now past interface-file generation, and in the - codegen pipeline, so we really don't need full unfoldings/rules - - - The unfolding/rule may be keeping stuff alive that we'd like - to discard. See Note [Dead code in CorePrep] - - - Getting rid of unnecessary unfoldings reduces heap usage - - - We are changing uniques, so if we didn't discard unfoldings/rules - we'd have to substitute in them - -HOWEVER, we want to preserve evaluated-ness; -see Note [Preserve evaluatedness] in CoreTidy. --} - ------------------------------------------------------------------------------- --- Cloning ccall Ids; each must have a unique name, --- to give the code generator a handle to hang it on --- --------------------------------------------------------------------------- - -fiddleCCall :: Id -> UniqSM Id -fiddleCCall id - | isFCallId id = (id `setVarUnique`) <$> getUniqueM - | otherwise = return id - ------------------------------------------------------------------------------- --- Generating new binders --- --------------------------------------------------------------------------- - -newVar :: Type -> UniqSM Id -newVar ty - = seqType ty `seq` do - uniq <- getUniqueM - return (mkSysLocalOrCoVar (fsLit "sat") uniq ty) - - ------------------------------------------------------------------------------- --- Floating ticks --- --------------------------------------------------------------------------- --- --- Note [Floating Ticks in CorePrep] --- --- It might seem counter-intuitive to float ticks by default, given --- that we don't actually want to move them if we can help it. On the --- other hand, nothing gets very far in CorePrep anyway, and we want --- to preserve the order of let bindings and tick annotations in --- relation to each other. For example, if we just wrapped let floats --- when they pass through ticks, we might end up performing the --- following transformation: --- --- src<...> let foo = bar in baz --- ==> let foo = src<...> bar in src<...> baz --- --- Because the let-binding would float through the tick, and then --- immediately materialize, achieving nothing but decreasing tick --- accuracy. The only special case is the following scenario: --- --- let foo = src<...> (let a = b in bar) in baz --- ==> let foo = src<...> bar; a = src<...> b in baz --- --- Here we would not want the source tick to end up covering "baz" and --- therefore refrain from pushing ticks outside. Instead, we copy them --- into the floating binds (here "a") in cpePair. Note that where "b" --- or "bar" are (value) lambdas we have to push the annotations --- further inside in order to uphold our rules. --- --- All of this is implemented below in @wrapTicks@. - --- | Like wrapFloats, but only wraps tick floats -wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) -wrapTicks (Floats flag floats0) expr = - (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1)) - where (floats1, ticks1) = foldlOL go ([], []) $ floats0 - -- Deeply nested constructors will produce long lists of - -- redundant source note floats here. We need to eliminate - -- those early, as relying on mkTick to spot it after the fact - -- can yield O(n^3) complexity [#11095] - go (floats, ticks) (FloatTick t) - = ASSERT(tickishPlace t == PlaceNonLam) - (floats, if any (flip tickishContains t) ticks - then ticks else t:ticks) - go (floats, ticks) f - = (foldr wrap f (reverse ticks):floats, ticks) - - wrap t (FloatLet bind) = FloatLet (wrapBind t bind) - wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok - wrap _ other = pprPanic "wrapTicks: unexpected float!" - (ppr other) - wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) - wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) - ------------------------------------------------------------------------------- --- Collecting cost centres --- --------------------------------------------------------------------------- - --- | Collect cost centres defined in the current module, including those in --- unfoldings. -collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre -collectCostCentres mod_name - = foldl' go_bind S.empty - where - go cs e = case e of - Var{} -> cs - Lit{} -> cs - App e1 e2 -> go (go cs e1) e2 - Lam _ e -> go cs e - Let b e -> go (go_bind cs b) e - Case scrt _ _ alts -> go_alts (go cs scrt) alts - Cast e _ -> go cs e - Tick (ProfNote cc _ _) e -> - go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e - Tick _ e -> go cs e - Type{} -> cs - Coercion{} -> cs - - go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e) - - go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre - go_bind cs (NonRec b e) = - go (maybe cs (go cs) (get_unf b)) e - go_bind cs (Rec bs) = - foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs - - -- Unfoldings may have cost centres that in the original definion are - -- optimized away, see #5889. - get_unf = maybeUnfoldingTemplate . realIdUnfolding diff --git a/coreSyn/CoreSeq.hs b/coreSyn/CoreSeq.hs deleted file mode 100644 --- a/coreSyn/CoreSeq.hs +++ /dev/null @@ -1,113 +0,0 @@ --- | --- Various utilities for forcing Core structures --- --- It can often be useful to force various parts of the AST. This module --- provides a number of @seq@-like functions to accomplish this. - -module CoreSeq ( - -- * Utilities for forcing Core structures - seqExpr, seqExprs, seqUnfolding, seqRules, - megaSeqIdInfo, seqRuleInfo, seqBinds, - ) where - -import GhcPrelude - -import CoreSyn -import IdInfo -import Demand( seqDemand, seqStrictSig ) -import BasicTypes( seqOccInfo ) -import VarSet( seqDVarSet ) -import Var( varType, tyVarKind ) -import Type( seqType, isTyVar ) -import Coercion( seqCo ) -import Id( Id, idInfo ) - --- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the --- compiler -megaSeqIdInfo :: IdInfo -> () -megaSeqIdInfo info - = seqRuleInfo (ruleInfo info) `seq` - --- Omitting this improves runtimes a little, presumably because --- some unfoldings are not calculated at all --- seqUnfolding (unfoldingInfo info) `seq` - - seqDemand (demandInfo info) `seq` - seqStrictSig (strictnessInfo info) `seq` - seqCaf (cafInfo info) `seq` - seqOneShot (oneShotInfo info) `seq` - seqOccInfo (occInfo info) - -seqOneShot :: OneShotInfo -> () -seqOneShot l = l `seq` () - -seqRuleInfo :: RuleInfo -> () -seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs - -seqCaf :: CafInfo -> () -seqCaf c = c `seq` () - -seqRules :: [CoreRule] -> () -seqRules [] = () -seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) - = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules -seqRules (BuiltinRule {} : rules) = seqRules rules - -seqExpr :: CoreExpr -> () -seqExpr (Var v) = v `seq` () -seqExpr (Lit lit) = lit `seq` () -seqExpr (App f a) = seqExpr f `seq` seqExpr a -seqExpr (Lam b e) = seqBndr b `seq` seqExpr e -seqExpr (Let b e) = seqBind b `seq` seqExpr e -seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as -seqExpr (Cast e co) = seqExpr e `seq` seqCo co -seqExpr (Tick n e) = seqTickish n `seq` seqExpr e -seqExpr (Type t) = seqType t -seqExpr (Coercion co) = seqCo co - -seqExprs :: [CoreExpr] -> () -seqExprs [] = () -seqExprs (e:es) = seqExpr e `seq` seqExprs es - -seqTickish :: Tickish Id -> () -seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () -seqTickish HpcTick{} = () -seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids -seqTickish SourceNote{} = () - -seqBndr :: CoreBndr -> () -seqBndr b | isTyVar b = seqType (tyVarKind b) - | otherwise = seqType (varType b) `seq` - megaSeqIdInfo (idInfo b) - -seqBndrs :: [CoreBndr] -> () -seqBndrs [] = () -seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs - -seqBinds :: [Bind CoreBndr] -> () -seqBinds bs = foldr (seq . seqBind) () bs - -seqBind :: Bind CoreBndr -> () -seqBind (NonRec b e) = seqBndr b `seq` seqExpr e -seqBind (Rec prs) = seqPairs prs - -seqPairs :: [(CoreBndr, CoreExpr)] -> () -seqPairs [] = () -seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs - -seqAlts :: [CoreAlt] -> () -seqAlts [] = () -seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts - -seqUnfolding :: Unfolding -> () -seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, - uf_is_value = b1, uf_is_work_free = b2, - uf_expandable = b3, uf_is_conlike = b4, - uf_guidance = g}) - = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g - -seqUnfolding _ = () - -seqGuidance :: UnfoldingGuidance -> () -seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () -seqGuidance _ = () diff --git a/coreSyn/CoreStats.hs b/coreSyn/CoreStats.hs deleted file mode 100644 --- a/coreSyn/CoreStats.hs +++ /dev/null @@ -1,137 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-2015 --} - --- | Functions to computing the statistics reflective of the "size" --- of a Core expression -module CoreStats ( - -- * Expression and bindings size - coreBindsSize, exprSize, - CoreStats(..), coreBindsStats, exprStats, - ) where - -import GhcPrelude - -import BasicTypes -import CoreSyn -import Outputable -import Coercion -import Var -import Type (Type, typeSize) -import Id (isJoinId) - -data CoreStats = CS { cs_tm :: !Int -- Terms - , cs_ty :: !Int -- Types - , cs_co :: !Int -- Coercions - , cs_vb :: !Int -- Local value bindings - , cs_jb :: !Int } -- Local join bindings - - -instance Outputable CoreStats where - ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 }) - = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, - text "types:" <+> intWithCommas i2 <> comma, - text "coercions:" <+> intWithCommas i3 <> comma, - text "joins:" <+> intWithCommas i5 <> char '/' <> - intWithCommas (i4 + i5) ]) - -plusCS :: CoreStats -> CoreStats -> CoreStats -plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 }) - (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 }) - = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2 - , cs_jb = j1+j2 } - -zeroCS, oneTM :: CoreStats -zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 } -oneTM = zeroCS { cs_tm = 1 } - -sumCS :: (a -> CoreStats) -> [a] -> CoreStats -sumCS f = foldl' (\s a -> plusCS s (f a)) zeroCS - -coreBindsStats :: [CoreBind] -> CoreStats -coreBindsStats = sumCS (bindStats TopLevel) - -bindStats :: TopLevelFlag -> CoreBind -> CoreStats -bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r -bindStats top_lvl (Rec prs) = sumCS (\(v,r) -> bindingStats top_lvl v r) prs - -bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats -bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r - -bndrStats :: Var -> CoreStats -bndrStats v = oneTM `plusCS` tyStats (varType v) - -letBndrStats :: TopLevelFlag -> Var -> CoreStats -letBndrStats top_lvl v - | isTyVar v || isTopLevel top_lvl = bndrStats v - | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats - | otherwise = oneTM { cs_vb = 1 } `plusCS` ty_stats - where - ty_stats = tyStats (varType v) - -exprStats :: CoreExpr -> CoreStats -exprStats (Var {}) = oneTM -exprStats (Lit {}) = oneTM -exprStats (Type t) = tyStats t -exprStats (Coercion c) = coStats c -exprStats (App f a) = exprStats f `plusCS` exprStats a -exprStats (Lam b e) = bndrStats b `plusCS` exprStats e -exprStats (Let b e) = bindStats NotTopLevel b `plusCS` exprStats e -exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b - `plusCS` sumCS altStats as -exprStats (Cast e co) = coStats co `plusCS` exprStats e -exprStats (Tick _ e) = exprStats e - -altStats :: CoreAlt -> CoreStats -altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r - -altBndrStats :: [Var] -> CoreStats --- Charge one for the alternative, not for each binder -altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs - -tyStats :: Type -> CoreStats -tyStats ty = zeroCS { cs_ty = typeSize ty } - -coStats :: Coercion -> CoreStats -coStats co = zeroCS { cs_co = coercionSize co } - -coreBindsSize :: [CoreBind] -> Int --- We use coreBindStats for user printout --- but this one is a quick and dirty basis for --- the simplifier's tick limit -coreBindsSize bs = sum (map bindSize bs) - -exprSize :: CoreExpr -> Int --- ^ A measure of the size of the expressions, strictly greater than 0 --- Counts *leaves*, not internal nodes. Types and coercions are not counted. -exprSize (Var _) = 1 -exprSize (Lit _) = 1 -exprSize (App f a) = exprSize f + exprSize a -exprSize (Lam b e) = bndrSize b + exprSize e -exprSize (Let b e) = bindSize b + exprSize e -exprSize (Case e b _ as) = exprSize e + bndrSize b + 1 + sum (map altSize as) -exprSize (Cast e _) = 1 + exprSize e -exprSize (Tick n e) = tickSize n + exprSize e -exprSize (Type _) = 1 -exprSize (Coercion _) = 1 - -tickSize :: Tickish Id -> Int -tickSize (ProfNote _ _ _) = 1 -tickSize _ = 1 - -bndrSize :: Var -> Int -bndrSize _ = 1 - -bndrsSize :: [Var] -> Int -bndrsSize = sum . map bndrSize - -bindSize :: CoreBind -> Int -bindSize (NonRec b e) = bndrSize b + exprSize e -bindSize (Rec prs) = sum (map pairSize prs) - -pairSize :: (Var, CoreExpr) -> Int -pairSize (b,e) = bndrSize b + exprSize e - -altSize :: CoreAlt -> Int -altSize (_,bs,e) = bndrsSize bs + exprSize e diff --git a/coreSyn/CoreSubst.hs b/coreSyn/CoreSubst.hs deleted file mode 100644 --- a/coreSyn/CoreSubst.hs +++ /dev/null @@ -1,756 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utility functions on @Core@ syntax --} - -{-# LANGUAGE CPP #-} -module CoreSubst ( - -- * Main data types - Subst(..), -- Implementation exported for supercompiler's Renaming.hs only - TvSubstEnv, IdSubstEnv, InScopeSet, - - -- ** Substituting into expressions and related types - deShadowBinds, substSpec, substRulesForImportedIds, - substTy, substCo, substExpr, substExprSC, substBind, substBindSC, - substUnfolding, substUnfoldingSC, - lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc, - substTickish, substDVarSet, substIdInfo, - - -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, - extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, - extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, - addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, - isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, - delBndr, delBndrs, - - -- ** Substituting and cloning binders - substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, - cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, - - ) where - -#include "HsVersions.h" - - -import GhcPrelude - -import CoreSyn -import CoreFVs -import CoreSeq -import CoreUtils -import qualified Type -import qualified Coercion - - -- We are defining local versions -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) - -import PrelNames -import VarSet -import VarEnv -import Id -import Name ( Name ) -import Var -import IdInfo -import UniqSupply -import Maybes -import Util -import Outputable -import Data.List - - - -{- -************************************************************************ -* * -\subsection{Substitutions} -* * -************************************************************************ --} - --- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' --- substitutions. --- --- Some invariants apply to how you use the substitution: --- --- 1. Note [The substitution invariant] in TyCoSubst --- --- 2. Note [Substitutions apply only once] in TyCoSubst -data Subst - = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ - -- applying the substitution - IdSubstEnv -- Substitution from NcIds to CoreExprs - TvSubstEnv -- Substitution from TyVars to Types - CvSubstEnv -- Substitution from CoVars to Coercions - - -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] - -- This is what lets us deal with name capture properly - -- It's a hard invariant to check... - -- - -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with - -- Types.TvSubstEnv - -- - -- INVARIANT 3: See Note [Extending the Subst] - -{- -Note [Extending the Subst] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a core Subst, which binds Ids as well, we make a different choice for Ids -than we do for TyVars. - -For TyVars, see Note [Extending the TCvSubst] in TyCoSubst. - -For Ids, we have a different invariant - The IdSubstEnv is extended *only* when the Unique on an Id changes - Otherwise, we just extend the InScopeSet - -In consequence: - -* If all subst envs are empty, substExpr would be a - no-op, so substExprSC ("short cut") does nothing. - - However, substExpr still goes ahead and substitutes. Reason: we may - want to replace existing Ids with new ones from the in-scope set, to - avoid space leaks. - -* In substIdBndr, we extend the IdSubstEnv only when the unique changes - -* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, - substExpr does nothing (Note that the above rule for substIdBndr - maintains this property. If the incoming envts are both empty, then - substituting the type and IdInfo can't change anything.) - -* In lookupIdSubst, we *must* look up the Id in the in-scope set, because - it may contain non-trivial changes. Example: - (/\a. \x:a. ...x...) Int - We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change - so we only extend the in-scope set. Then we must look up in the in-scope - set when we find the occurrence of x. - -* The requirement to look up the Id in the in-scope set means that we - must NOT take no-op short cut when the IdSubst is empty. - We must still look up every Id in the in-scope set. - -* (However, we don't need to do so for expressions found in the IdSubst - itself, whose range is assumed to be correct wrt the in-scope set.) - -Why do we make a different choice for the IdSubstEnv than the -TvSubstEnv and CvSubstEnv? - -* For Ids, we change the IdInfo all the time (e.g. deleting the - unfolding), and adding it back later, so using the TyVar convention - would entail extending the substitution almost all the time - -* The simplifier wants to look up in the in-scope set anyway, in case it - can see a better unfolding from an enclosing case expression - -* For TyVars, only coercion variables can possibly change, and they are - easy to spot --} - --- | An environment for substituting for 'Id's -type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions - ----------------------------- -isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ id_env tv_env cv_env) - = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env - -emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv - -mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv - -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs - --- | Find the in-scope set: see TyCoSubst Note [The substitution invariant] -substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _ _ _) = in_scope - --- | Remove all substitutions for 'Id's and 'Var's that might have been built up --- while preserving the in-scope set -zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv - --- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is --- such that TyCoSubst Note [The substitution invariant] --- holds after extending the substitution like this -extendIdSubst :: Subst -> Id -> CoreExpr -> Subst --- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set -extendIdSubst (Subst in_scope ids tvs cvs) v r - = ASSERT2( isNonCoVarId v, ppr v $$ ppr r ) - Subst in_scope (extendVarEnv ids v r) tvs cvs - --- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' -extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst -extendIdSubstList (Subst in_scope ids tvs cvs) prs - = ASSERT( all (isNonCoVarId . fst) prs ) - Subst in_scope (extendVarEnvList ids prs) tvs cvs - --- | Add a substitution for a 'TyVar' to the 'Subst' --- The 'TyVar' *must* be a real TyVar, and not a CoVar --- You must ensure that the in-scope set is such that --- TyCoSubst Note [The substitution invariant] holds --- after extending the substitution like this. -extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs cvs) tv ty - = ASSERT( isTyVar tv ) - Subst in_scope ids (extendVarEnv tvs tv ty) cvs - --- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' -extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList subst vrs - = foldl' extend subst vrs - where - extend subst (v, r) = extendTvSubst subst v r - --- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': --- you must ensure that the in-scope set satisfies --- TyCoSubst Note [The substitution invariant] --- after extending the substitution like this -extendCvSubst :: Subst -> CoVar -> Coercion -> Subst -extendCvSubst (Subst in_scope ids tvs cvs) v r - = ASSERT( isCoVar v ) - Subst in_scope ids tvs (extendVarEnv cvs v r) - --- | Add a substitution appropriate to the thing being substituted --- (whether an expression, type, or coercion). See also --- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' -extendSubst :: Subst -> Var -> CoreArg -> Subst -extendSubst subst var arg - = case arg of - Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty - Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co - _ -> ASSERT( isId var ) extendIdSubst subst var arg - -extendSubstWithVar :: Subst -> Var -> Var -> Subst -extendSubstWithVar subst v1 v2 - | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) - | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) - | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) - --- | Add a substitution as appropriate to each of the terms being --- substituted (whether expressions, types, or coercions). See also --- 'extendSubst'. -extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst -extendSubstList subst [] = subst -extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs - --- | Find the substitution for an 'Id' in the 'Subst' -lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr -lookupIdSubst doc (Subst in_scope ids _ _) v - | not (isLocalId v) = Var v - | Just e <- lookupVarEnv ids v = e - | Just v' <- lookupInScope in_scope v = Var v' - -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v - $$ ppr in_scope) - Var v - --- | Find the substitution for a 'TyVar' in the 'Subst' -lookupTCvSubst :: Subst -> TyVar -> Type -lookupTCvSubst (Subst _ _ tvs cvs) v - | isTyVar v - = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v - | otherwise - = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v - -delBndr :: Subst -> Var -> Subst -delBndr (Subst in_scope ids tvs cvs) v - | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) - | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs - | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs - -delBndrs :: Subst -> [Var] -> Subst -delBndrs (Subst in_scope ids tvs cvs) vs - = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) - -- Easiest thing is just delete all from all! - --- | Simultaneously substitute for a bunch of variables --- No left-right shadowing --- ie the substitution for (\x \y. e) a1 a2 --- so neither x nor y scope over a1 a2 -mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst -mkOpenSubst in_scope pairs = Subst in_scope - (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) - (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) - (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) - ------------------------------- -isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope - --- | Add the 'Var' to the in-scope set, but do not remove --- any existing substitutions for it -addInScopeSet :: Subst -> VarSet -> Subst -addInScopeSet (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs - --- | Add the 'Var' to the in-scope set: as a side effect, --- and remove any existing substitutions for it -extendInScope :: Subst -> Var -> Subst -extendInScope (Subst in_scope ids tvs cvs) v - = Subst (in_scope `extendInScopeSet` v) - (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendInScopeList :: Subst -> [Var] -> Subst -extendInScopeList (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) - --- | Optimized version of 'extendInScopeList' that can be used if you are certain --- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's -extendInScopeIds :: Subst -> [Id] -> Subst -extendInScopeIds (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) tvs cvs - -setInScope :: Subst -> InScopeSet -> Subst -setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs - --- Pretty printing, for debugging only - -instance Outputable Subst where - ppr (Subst in_scope ids tvs cvs) - = text " in_scope_doc - $$ text " IdSubst =" <+> ppr ids - $$ text " TvSubst =" <+> ppr tvs - $$ text " CvSubst =" <+> ppr cvs - <> char '>' - where - in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) - -{- -************************************************************************ -* * - Substituting expressions -* * -************************************************************************ --} - --- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only --- apply the substitution /once/: --- See Note [Substitutions apply only once] in TyCoSubst --- --- Do *not* attempt to short-cut in the case of an empty substitution! --- See Note [Extending the Subst] -substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr -substExprSC doc subst orig_expr - | isEmptySubst subst = orig_expr - | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ - subst_expr doc subst orig_expr - -substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr -substExpr doc subst orig_expr = subst_expr doc subst orig_expr - -subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr -subst_expr doc subst expr - = go expr - where - go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v - go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (substCo subst co) - go (Lit lit) = Lit lit - go (App fun arg) = App (go fun) (go arg) - go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) - go (Cast e co) = Cast (go e) (substCo subst co) - -- Do not optimise even identity coercions - -- Reason: substitution applies to the LHS of RULES, and - -- if you "optimise" an identity coercion, you may - -- lose a binder. We optimise the LHS of rules at - -- construction time - - go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body) - where - (subst', bndr') = substBndr subst bndr - - go (Let bind body) = Let bind' (subst_expr doc subst' body) - where - (subst', bind') = substBind subst bind - - go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) - where - (subst', bndr') = substBndr subst bndr - - go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs) - where - (subst', bndrs') = substBndrs subst bndrs - --- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' --- that should be used by subsequent substitutions. -substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind) - -substBindSC subst bind -- Short-cut if the substitution is empty - | not (isEmptySubst subst) - = substBind subst bind - | otherwise - = case bind of - NonRec bndr rhs -> (subst', NonRec bndr' rhs) - where - (subst', bndr') = substBndr subst bndr - Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) - where - (bndrs, rhss) = unzip pairs - (subst', bndrs') = substRecBndrs subst bndrs - rhss' | isEmptySubst subst' - = rhss - | otherwise - = map (subst_expr (text "substBindSC") subst') rhss - -substBind subst (NonRec bndr rhs) - = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs)) - where - (subst', bndr') = substBndr subst bndr - -substBind subst (Rec pairs) - = (subst', Rec (bndrs' `zip` rhss')) - where - (bndrs, rhss) = unzip pairs - (subst', bndrs') = substRecBndrs subst bndrs - rhss' = map (subst_expr (text "substBind") subst') rhss - --- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply --- by running over the bindings with an empty substitution, because substitution --- returns a result that has no-shadowing guaranteed. --- --- (Actually, within a single /type/ there might still be shadowing, because --- 'substTy' is a no-op for the empty substitution, but that's probably OK.) --- --- [Aug 09] This function is not used in GHC at the moment, but seems so --- short and simple that I'm going to leave it here -deShadowBinds :: CoreProgram -> CoreProgram -deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) - -{- -************************************************************************ -* * - Substituting binders -* * -************************************************************************ - -Remember that substBndr and friends are used when doing expression -substitution only. Their only business is substitution, so they -preserve all IdInfo (suitably substituted). For example, we *want* to -preserve occ info in rules. --} - --- | Substitutes a 'Var' for another one according to the 'Subst' given, returning --- the result and an updated 'Subst' that should be used by subsequent substitutions. --- 'IdInfo' is preserved by this process, although it is substituted into appropriately. -substBndr :: Subst -> Var -> (Subst, Var) -substBndr subst bndr - | isTyVar bndr = substTyVarBndr subst bndr - | isCoVar bndr = substCoVarBndr subst bndr - | otherwise = substIdBndr (text "var-bndr") subst subst bndr - --- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right -substBndrs :: Subst -> [Var] -> (Subst, [Var]) -substBndrs subst bndrs = mapAccumL substBndr subst bndrs - --- | Substitute in a mutually recursive group of 'Id's -substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) -substRecBndrs subst bndrs - = (new_subst, new_bndrs) - where -- Here's the reason we need to pass rec_subst to subst_id - (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs - -substIdBndr :: SDoc - -> Subst -- ^ Substitution to use for the IdInfo - -> Subst -> Id -- ^ Substitution and Id to transform - -> (Subst, Id) -- ^ Transformed pair - -- NB: unfolding may be zapped - -substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id - = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ - (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) - where - id1 = uniqAway in_scope old_id -- id1 is cloned if necessary - id2 | no_type_change = id1 - | otherwise = setIdType id1 (substTy subst old_ty) - - old_ty = idType old_id - no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || - noFreeVarsOfType old_ty - - -- new_id has the right IdInfo - -- The lazy-set is because we're in a loop here, with - -- rec_subst, when dealing with a mutually-recursive group - new_id = maybeModifyIdInfo mb_new_info id2 - mb_new_info = substIdInfo rec_subst id2 (idInfo id2) - -- NB: unfolding info may be zapped - - -- Extend the substitution if the unique has changed - -- See the notes with substTyVarBndr for the delVarEnv - new_env | no_change = delVarEnv env old_id - | otherwise = extendVarEnv env old_id (Var new_id) - - no_change = id1 == old_id - -- See Note [Extending the Subst] - -- it's /not/ necessary to check mb_new_info and no_type_change - -{- -Now a variant that unconditionally allocates a new unique. -It also unconditionally zaps the OccInfo. --} - --- | Very similar to 'substBndr', but it always allocates a new 'Unique' for --- each variable in its output. It substitutes the IdInfo though. -cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) -cloneIdBndr subst us old_id - = clone_id subst subst (old_id, uniqFromSupply us) - --- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final --- substitution from left to right -cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) -cloneIdBndrs subst us ids - = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) - -cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) --- Works for all kinds of variables (typically case binders) --- not just Ids -cloneBndrs subst us vs - = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) - -cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) -cloneBndr subst uniq v - | isTyVar v = cloneTyVarBndr subst v uniq - | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too - --- | Clone a mutually recursive group of 'Id's -cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) -cloneRecIdBndrs subst us ids - = (subst', ids') - where - (subst', ids') = mapAccumL (clone_id subst') subst - (ids `zip` uniqsFromSupply us) - --- Just like substIdBndr, except that it always makes a new unique --- It is given the unique to use -clone_id :: Subst -- Substitution for the IdInfo - -> Subst -> (Id, Unique) -- Substitution and Id to transform - -> (Subst, Id) -- Transformed pair - -clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) - = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) - where - id1 = setVarUnique old_id uniq - id2 = substIdType subst id1 - new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 - (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) - | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) - -{- -************************************************************************ -* * - Types and Coercions -* * -************************************************************************ - -For types and coercions we just call the corresponding functions in -Type and Coercion, but we have to repackage the substitution, from a -Subst to a TCvSubst. --} - -substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv - = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) -cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq - = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv - = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (Subst in_scope' id_env tv_env' cv_env', cv') - --- | See 'Type.substTy' -substTy :: Subst -> Type -> Type -substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty - -getTCvSubst :: Subst -> TCvSubst -getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv - --- | See 'Coercion.substCo' -substCo :: HasCallStack => Subst -> Coercion -> Coercion -substCo subst co = Coercion.substCo (getTCvSubst subst) co - -{- -************************************************************************ -* * -\section{IdInfo substitution} -* * -************************************************************************ --} - -substIdType :: Subst -> Id -> Id -substIdType subst@(Subst _ _ tv_env cv_env) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id - | otherwise = setIdType id (substTy subst old_ty) - -- The tyCoVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself - where - old_ty = idType id - ------------------- --- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. -substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo -substIdInfo subst new_id info - | nothing_to_do = Nothing - | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules - `setUnfoldingInfo` substUnfolding subst old_unf) - where - old_rules = ruleInfo info - old_unf = unfoldingInfo info - nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf) - ------------------- --- | Substitutes for the 'Id's within an unfolding -substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding - -- Seq'ing on the returned Unfolding is enough to cause - -- all the substitutions to happen completely - -substUnfoldingSC subst unf -- Short-cut version - | isEmptySubst subst = unf - | otherwise = substUnfolding subst unf - -substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = df { df_bndrs = bndrs', df_args = args' } - where - (subst',bndrs') = substBndrs subst bndrs - args' = map (substExpr (text "subst-unf:dfun") subst') args - -substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) - -- Retain an InlineRule! - | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work - = NoUnfolding - | otherwise -- But keep a stable one! - = seqExpr new_tmpl `seq` - unf { uf_tmpl = new_tmpl } - where - new_tmpl = substExpr (text "subst-unf") subst tmpl - -substUnfolding _ unf = unf -- NoUnfolding, OtherCon - ------------------- -substIdOcc :: Subst -> Id -> Id --- These Ids should not be substituted to non-Ids -substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of - Var v' -> v' - other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) - ------------------- --- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' -substSpec :: Subst -> Id -> RuleInfo -> RuleInfo -substSpec subst new_id (RuleInfo rules rhs_fvs) - = seqRuleInfo new_spec `seq` new_spec - where - subst_ru_fn = const (idName new_id) - new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules) - (substDVarSet subst rhs_fvs) - ------------------- -substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] -substRulesForImportedIds subst rules - = map (substRule subst not_needed) rules - where - not_needed name = pprPanic "substRulesForImportedIds" (ppr name) - ------------------- -substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule - --- The subst_ru_fn argument is applied to substitute the ru_fn field --- of the rule: --- - Rules for *imported* Ids never change ru_fn --- - Rules for *local* Ids are in the IdInfo for that Id, --- and the ru_fn field is simply replaced by the new name --- of the Id -substRule _ _ rule@(BuiltinRule {}) = rule -substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs - , ru_local = is_local }) - = rule { ru_bndrs = bndrs' - , ru_fn = if is_local - then subst_ru_fn fn_name - else fn_name - , ru_args = map (substExpr doc subst') args - , ru_rhs = substExpr (text "foo") subst' rhs } - -- Do NOT optimise the RHS (previously we did simplOptExpr here) - -- See Note [Substitute lazily] - where - doc = text "subst-rule" <+> ppr fn_name - (subst', bndrs') = substBndrs subst bndrs - ------------------- -substDVarSet :: Subst -> DVarSet -> DVarSet -substDVarSet subst fvs - = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs - where - subst_fv subst fv acc - | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc - | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc - ------------------- -substTickish :: Subst -> Tickish Id -> Tickish Id -substTickish subst (Breakpoint n ids) - = Breakpoint n (map do_one ids) - where - do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst -substTickish _subst other = other - -{- Note [Substitute lazily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The functions that substitute over IdInfo must be pretty lazy, because -they are knot-tied by substRecBndrs. - -One case in point was #10627 in which a rule for a function 'f' -referred to 'f' (at a different type) on the RHS. But instead of just -substituting in the rhs of the rule, we were calling simpleOptExpr, which -looked at the idInfo for 'f'; result <>. - -In any case we don't need to optimise the RHS of rules, or unfoldings, -because the simplifier will do that. - - -Note [substTickish] -~~~~~~~~~~~~~~~~~~~~~~ -A Breakpoint contains a list of Ids. What happens if we ever want to -substitute an expression for one of these Ids? - -First, we ensure that we only ever substitute trivial expressions for -these Ids, by marking them as NoOccInfo in the occurrence analyser. -Then, when substituting for the Id, we unwrap any type applications -and abstractions to get back to an Id, with getIdFromTrivialExpr. - -Second, we have to ensure that we never try to substitute a literal -for an Id in a breakpoint. We ensure this by never storing an Id with -an unlifted type in a Breakpoint - see Coverage.mkTickish. -Breakpoints can't handle free variables with unlifted types anyway. --} - -{- -Note [Worker inlining] -~~~~~~~~~~~~~~~~~~~~~~ -A worker can get sustituted away entirely. - - it might be trivial - - it might simply be very small -We do not treat an InlWrapper as an 'occurrence' in the occurrence -analyser, so it's possible that the worker is not even in scope any more. - -In all all these cases we simply drop the special case, returning to -InlVanilla. The WARN is just so I can see if it happens a lot. --} diff --git a/coreSyn/CoreSyn.hs b/coreSyn/CoreSyn.hs deleted file mode 100644 --- a/coreSyn/CoreSyn.hs +++ /dev/null @@ -1,2347 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE BangPatterns #-} - --- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection -module CoreSyn ( - -- * Main data types - Expr(..), Alt, Bind(..), AltCon(..), Arg, - Tickish(..), TickishScoping(..), TickishPlacement(..), - CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, - TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, - - -- * In/Out type synonyms - InId, InBind, InExpr, InAlt, InArg, InType, InKind, - InBndr, InVar, InCoercion, InTyVar, InCoVar, - OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind, - OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion, - - -- ** 'Expr' construction - mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams, - mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg, - - mkIntLit, mkIntLitInt, - mkWordLit, mkWordLitWord, - mkWord64LitWord64, mkInt64LitInt64, - mkCharLit, mkStringLit, - mkFloatLit, mkFloatLitFloat, - mkDoubleLit, mkDoubleLitDouble, - - mkConApp, mkConApp2, mkTyBind, mkCoBind, - varToCoreExpr, varsToCoreExprs, - - isId, cmpAltCon, cmpAlt, ltAlt, - - -- ** Simple 'Expr' access functions and predicates - bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, - collectBinders, collectTyBinders, collectTyAndValBinders, - collectNBinders, - collectArgs, stripNArgs, collectArgsTicks, flattenBinds, - - exprToType, exprToCoercion_maybe, - applyTypeToArg, - - isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount, - isRuntimeArg, isRuntimeVar, - - -- * Tick-related functions - tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable, - tickishCanSplit, mkNoCount, mkNoScope, - tickishIsCode, tickishPlace, - tickishContains, - - -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - - -- ** Constructing 'Unfolding's - noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, - unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, - - -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, expandUnfolding_maybe, - maybeUnfoldingTemplate, otherCons, - isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, isFragileUnfolding, hasSomeUnfolding, - isBootUnfolding, - canUnfold, neverUnfoldGuidance, isStableSource, - - -- * Annotated expression data types - AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, - - -- ** Operations on annotated expressions - collectAnnArgs, collectAnnArgsTicks, - - -- ** Operations on annotations - deAnnotate, deAnnotate', deAnnAlt, deAnnBind, - collectAnnBndrs, collectNAnnBndrs, - - -- * Orphanhood - IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, - - -- * Core rule data types - CoreRule(..), RuleBase, - RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, - RuleEnv(..), mkRuleEnv, emptyRuleEnv, - - -- ** Operations on 'CoreRule's - ruleArity, ruleName, ruleIdName, ruleActivation, - setRuleIdName, ruleModule, - isBuiltinRule, isLocalRule, isAutoRule, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CostCentre -import VarEnv( InScopeSet ) -import Var -import Type -import Coercion -import Name -import NameSet -import NameEnv( NameEnv, emptyNameEnv ) -import Literal -import DataCon -import Module -import BasicTypes -import DynFlags -import Outputable -import Util -import UniqSet -import SrcLoc ( RealSrcSpan, containsSpan ) -import Binary - -import Data.Data hiding (TyCon) -import Data.Int -import Data.Word - -infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` --- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) - -{- -************************************************************************ -* * -\subsection{The main data types} -* * -************************************************************************ - -These data types are the heart of the compiler --} - --- | This is the data type that represents GHCs core intermediate language. Currently --- GHC uses System FC for this purpose, --- which is closely related to the simpler and better known System F . --- --- We get from Haskell source to this Core language in a number of stages: --- --- 1. The source code is parsed into an abstract syntax tree, which is represented --- by the data type 'GHC.Hs.Expr.HsExpr' with the names being 'RdrName.RdrNames' --- --- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' --- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. --- For example, this program: --- --- @ --- f x = let f x = x + 1 --- in f (x - 2) --- @ --- --- Would be renamed by having 'Unique's attached so it looked something like this: --- --- @ --- f_1 x_2 = let f_3 x_4 = x_4 + 1 --- in f_3 (x_2 - 2) --- @ --- But see Note [Shadowing] below. --- --- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating --- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'Id.Id' as it's names. --- --- 4. Finally the syntax tree is /desugared/ from the expressive 'GHC.Hs.Expr.HsExpr' type into --- this 'Expr' type, which has far fewer constructors and hence is easier to perform --- optimization, analysis and code generation on. --- --- The type parameter @b@ is for the type of binders in the expression tree. --- --- The language consists of the following elements: --- --- * Variables --- See Note [Variable occurrences in Core] --- --- * Primitive literals --- --- * Applications: note that the argument may be a 'Type'. --- See Note [CoreSyn let/app invariant] --- See Note [Levity polymorphism invariants] --- --- * Lambda abstraction --- See Note [Levity polymorphism invariants] --- --- * Recursive and non recursive @let@s. Operationally --- this corresponds to allocating a thunk for the things --- bound and then executing the sub-expression. --- --- See Note [CoreSyn letrec invariant] --- See Note [CoreSyn let/app invariant] --- See Note [Levity polymorphism invariants] --- See Note [CoreSyn type and coercion invariant] --- --- * Case expression. Operationally this corresponds to evaluating --- the scrutinee (expression examined) to weak head normal form --- and then examining at most one level of resulting constructor (i.e. you --- cannot do nested pattern matching directly with this). --- --- The binder gets bound to the value of the scrutinee, --- and the 'Type' must be that of all the case alternatives --- --- IMPORTANT: see Note [Case expression invariants] --- --- * Cast an expression to a particular type. --- This is used to implement @newtype@s (a @newtype@ constructor or --- destructor just becomes a 'Cast' in Core) and GADTs. --- --- * Notes. These allow general information to be added to expressions --- in the syntax tree --- --- * A type: this should only show up at the top level of an Arg --- --- * A coercion - -{- Note [Why does Case have a 'Type' field?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The obvious alternative is - exprType (Case scrut bndr alts) - | (_,_,rhs1):_ <- alts - = exprType rhs1 - -But caching the type in the Case constructor - exprType (Case scrut bndr ty alts) = ty -is better for at least three reasons: - -* It works when there are no alternatives (see case invarant 1 above) - -* It might be faster in deeply-nested situations. - -* It might not be quite the same as (exprType rhs) for one - of the RHSs in alts. Consider a phantom type synonym - type S a = Int - and we want to form the case expression - case x of { K (a::*) -> (e :: S a) } - Then exprType of the RHS is (S a), but we cannot make that be - the 'ty' in the Case constructor because 'a' is simply not in - scope there. Instead we must expand the synonym to Int before - putting it in the Case constructor. See CoreUtils.mkSingleAltCase. - - So we'd have to do synonym expansion in exprType which would - be inefficient. - -* The type stored in the case is checked with lintInTy. This checks - (among other things) that it does not mention any variables that are - not in scope. If we did not have the type there, it would be a bit - harder for Core Lint to reject case blah of Ex x -> x where - data Ex = forall a. Ex a. --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Expr b - = Var Id - | Lit Literal - | App (Expr b) (Arg b) - | Lam b (Expr b) - | Let (Bind b) (Expr b) - | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants] - -- and Note [Why does Case have a 'Type' field?] - | Cast (Expr b) Coercion - | Tick (Tickish Id) (Expr b) - | Type Type - | Coercion Coercion - deriving Data - --- | Type synonym for expressions that occur in function argument positions. --- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not -type Arg b = Expr b - --- | A case split alternative. Consists of the constructor leading to the alternative, --- the variables bound from the constructor, and the expression to be executed given that binding. --- The default alternative is @(DEFAULT, [], rhs)@ - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -type Alt b = (AltCon, [b], Expr b) - --- | A case alternative constructor (i.e. pattern match) - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data AltCon - = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. - -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ - - | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ - -- Invariant: always an *unlifted* literal - -- See Note [Literal alternatives] - - | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ - deriving (Eq, Data) - --- This instance is a bit shady. It can only be used to compare AltCons for --- a single type constructor. Fortunately, it seems quite unlikely that we'll --- ever need to compare AltCons for different type constructors. --- The instance adheres to the order described in [CoreSyn case invariants] -instance Ord AltCon where - compare (DataAlt con1) (DataAlt con2) = - ASSERT( dataConTyCon con1 == dataConTyCon con2 ) - compare (dataConTag con1) (dataConTag con2) - compare (DataAlt _) _ = GT - compare _ (DataAlt _) = LT - compare (LitAlt l1) (LitAlt l2) = compare l1 l2 - compare (LitAlt _) DEFAULT = GT - compare DEFAULT DEFAULT = EQ - compare DEFAULT _ = LT - --- | Binding, used for top level bindings in a module and local bindings in a @let@. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Bind b = NonRec b (Expr b) - | Rec [(b, (Expr b))] - deriving Data - -{- -Note [Shadowing] -~~~~~~~~~~~~~~~~ -While various passes attempt to rename on-the-fly in a manner that -avoids "shadowing" (thereby simplifying downstream optimizations), -neither the simplifier nor any other pass GUARANTEES that shadowing is -avoided. Thus, all passes SHOULD work fine even in the presence of -arbitrary shadowing in their inputs. - -In particular, scrutinee variables `x` in expressions of the form -`Case e x t` are often renamed to variables with a prefix -"wild_". These "wild" variables may appear in the body of the -case-expression, and further, may be shadowed within the body. - -So the Unique in a Var is not really unique at all. Still, it's very -useful to give a constant-time equality/ordering for Vars, and to give -a key that can be used to make sets of Vars (VarSet), or mappings from -Vars to other things (VarEnv). Moreover, if you do want to eliminate -shadowing, you can give a new Unique to an Id without changing its -printable name, which makes debugging easier. - -Note [Literal alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Literal alternatives (LitAlt lit) are always for *un-lifted* literals. -We have one literal, a literal Integer, that is lifted, and we don't -allow in a LitAlt, because LitAlt cases don't do any evaluation. Also -(see #5603) if you say - case 3 of - S# x -> ... - J# _ _ -> ... -(where S#, J# are the constructors for Integer) we don't want the -simplifier calling findAlt with argument (LitAlt 3). No no. Integer -literals are an opaque encoding of an algebraic data type, not of -an unlifted literal, like all the others. - -Also, we do not permit case analysis with literal patterns on floating-point -types. See #9238 and Note [Rules for floating-point comparisons] in -PrelRules for the rationale for this restriction. - --------------------------- CoreSyn INVARIANTS --------------------------- - -Note [Variable occurrences in Core] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Variable /occurrences/ are never CoVars, though /bindings/ can be. -All CoVars appear in Coercions. - -For example - \(c :: Age~#Int) (d::Int). d |> (sym c) -Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in -a Coercion, (sym c). - -Note [CoreSyn letrec invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The right hand sides of all top-level and recursive @let@s -/must/ be of lifted type (see "Type#type_classification" for -the meaning of /lifted/ vs. /unlifted/). - -There is one exception to this rule, top-level @let@s are -allowed to bind primitive string literals: see -Note [CoreSyn top-level string literals]. - -Note [CoreSyn top-level string literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As an exception to the usual rule that top-level binders must be lifted, -we allow binding primitive string literals (of type Addr#) of type Addr# at the -top level. This allows us to share string literals earlier in the pipeline and -crucially allows other optimizations in the Core2Core pipeline to fire. -Consider, - - f n = let a::Addr# = "foo"# - in \x -> blah - -In order to be able to inline `f`, we would like to float `a` to the top. -Another option would be to inline `a`, but that would lead to duplicating string -literals, which we want to avoid. See #8472. - -The solution is simply to allow top-level unlifted binders. We can't allow -arbitrary unlifted expression at the top-level though, unlifted binders cannot -be thunks, so we just allow string literals. - -We allow the top-level primitive string literals to be wrapped in Ticks -in the same way they can be wrapped when nested in an expression. -CoreToSTG currently discards Ticks around top-level primitive string literals. -See #14779. - -Also see Note [Compilation plan for top-level string literals]. - -Note [Compilation plan for top-level string literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a summary on how top-level string literals are handled by various -parts of the compilation pipeline. - -* In the source language, there is no way to bind a primitive string literal - at the top level. - -* In Core, we have a special rule that permits top-level Addr# bindings. See - Note [CoreSyn top-level string literals]. Core-to-core passes may introduce - new top-level string literals. - -* In STG, top-level string literals are explicitly represented in the syntax - tree. - -* A top-level string literal may end up exported from a module. In this case, - in the object file, the content of the exported literal is given a label with - the _bytes suffix. - -Note [CoreSyn let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The let/app invariant - the right hand side of a non-recursive 'Let', and - the argument of an 'App', - /may/ be of unlifted type, but only if - the expression is ok-for-speculation - or the 'Let' is for a join point. - -This means that the let can be floated around -without difficulty. For example, this is OK: - - y::Int# = x +# 1# - -But this is not, as it may affect termination if the -expression is floated out: - - y::Int# = fac 4# - -In this situation you should use @case@ rather than a @let@. The function -'CoreUtils.needsCaseBinding' can help you determine which to generate, or -alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, -which will generate a @case@ if necessary - -The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in -coreSyn/MkCore. - -For discussion of some implications of the let/app invariant primops see -Note [Checking versus non-checking primops] in PrimOp. - -Note [Case expression invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case expressions are one of the more complicated elements of the Core -language, and come with a number of invariants. All of them should be -checked by Core Lint. - -1. The list of alternatives may be empty; - See Note [Empty case alternatives] - -2. The 'DEFAULT' case alternative must be first in the list, - if it occurs at all. Checked in CoreLint.checkCaseAlts. - -3. The remaining cases are in order of (strictly) increasing - tag (for 'DataAlts') or - lit (for 'LitAlts'). - This makes finding the relevant constructor easy, and makes - comparison easier too. Checked in CoreLint.checkCaseAlts. - -4. The list of alternatives must be exhaustive. An /exhaustive/ case - does not necessarily mention all constructors: - - @ - data Foo = Red | Green | Blue - ... case x of - Red -> True - other -> f (case x of - Green -> ... - Blue -> ... ) ... - @ - - The inner case does not need a @Red@ alternative, because @x@ - can't be @Red@ at that program point. - - This is not checked by Core Lint -- it's very hard to do so. - E.g. suppose that inner case was floated out, thus: - let a = case x of - Green -> ... - Blue -> ... ) - case x of - Red -> True - other -> f a - Now it's really hard to see that the Green/Blue case is - exhaustive. But it is. - - If you have a case-expression that really /isn't/ exhaustive, - we may generate seg-faults. Consider the Green/Blue case - above. Since there are only two branches we may generate - code that tests for Green, and if not Green simply /assumes/ - Blue (since, if the case is exhaustive, that's all that - remains). Of course, if it's not Blue and we start fetching - fields that should be in a Blue constructor, we may die - horribly. See also Note [Core Lint guarantee] in CoreLint. - -5. Floating-point values must not be scrutinised against literals. - See #9238 and Note [Rules for floating-point comparisons] - in PrelRules for rationale. Checked in lintCaseExpr; - see the call to isFloatingTy. - -6. The 'ty' field of (Case scrut bndr ty alts) is the type of the - /entire/ case expression. Checked in lintAltExpr. - See also Note [Why does Case have a 'Type' field?]. - -7. The type of the scrutinee must be the same as the type - of the case binder, obviously. Checked in lintCaseExpr. - -Note [CoreSyn type and coercion invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow a /non-recursive/, /non-top-level/ let to bind type and -coercion variables. These can be very convenient for postponing type -substitutions until the next run of the simplifier. - -* A type variable binding must have a RHS of (Type ty) - -* A coercion variable binding must have a RHS of (Coercion co) - - It is possible to have terms that return a coercion, but we use - case-binding for those; e.g. - case (eq_sel d) of (co :: a ~# b) -> blah - where eq_sel :: (a~b) -> (a~#b) - - Or even even - case (df @Int) of (co :: a ~# b) -> blah - Which is very exotic, and I think never encountered; but see - Note [Equality superclasses in quantified constraints] - in TcCanonical - -Note [CoreSyn case invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #case_invariants# - -Note [Levity polymorphism invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The levity-polymorphism invariants are these (as per "Levity Polymorphism", -PLDI '17): - -* The type of a term-binder must not be levity-polymorphic, - unless it is a let(rec)-bound join point - (see Note [Invariants on join points]) - -* The type of the argument of an App must not be levity-polymorphic. - -A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables. - -For example - \(r::RuntimeRep). \(a::TYPE r). \(x::a). e -is illegal because x's type has kind (TYPE r), which has 'r' free. - -See Note [Levity polymorphism checking] in DsMonad to see where these -invariants are established for user-written code. - -Note [CoreSyn let goal] -~~~~~~~~~~~~~~~~~~~~~~~ -* The simplifier tries to ensure that if the RHS of a let is a constructor - application, its arguments are trivial, so that the constructor can be - inlined vigorously. - -Note [Type let] -~~~~~~~~~~~~~~~ -See #type_let# - -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The alternatives of a case expression should be exhaustive. But -this exhaustive list can be empty! - -* A case expression can have empty alternatives if (and only if) the - scrutinee is bound to raise an exception or diverge. When do we know - this? See Note [Bottoming expressions] in CoreUtils. - -* The possibility of empty alternatives is one reason we need a type on - the case expression: if the alternatives are empty we can't get the - type from the alternatives! - -* In the case of empty types (see Note [Bottoming expressions]), say - data T - we do NOT want to replace - case (x::T) of Bool {} --> error Bool "Inaccessible case" - because x might raise an exception, and *that*'s what we want to see! - (#6067 is an example.) To preserve semantics we'd have to say - x `seq` error Bool "Inaccessible case" - but the 'seq' is just a case, so we are back to square 1. Or I suppose - we could say - x |> UnsafeCoerce T Bool - but that loses all trace of the fact that this originated with an empty - set of alternatives. - -* We can use the empty-alternative construct to coerce error values from - one type to another. For example - - f :: Int -> Int - f n = error "urk" - - g :: Int -> (# Char, Bool #) - g x = case f x of { 0 -> ..., n -> ... } - - Then if we inline f in g's RHS we get - case (error Int "urk") of (# Char, Bool #) { ... } - and we can discard the alternatives since the scrutinee is bottom to give - case (error Int "urk") of (# Char, Bool #) {} - - This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), - if for no other reason that we don't need to instantiate the (~) at an - unboxed type. - -* We treat a case expression with empty alternatives as trivial iff - its scrutinee is (see CoreUtils.exprIsTrivial). This is actually - important; see Note [Empty case is trivial] in CoreUtils - -* An empty case is replaced by its scrutinee during the CoreToStg - conversion; remember STG is un-typed, so there is no need for - the empty case to do the type conversion. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -In Core, a *join point* is a specially tagged function whose only occurrences -are saturated tail calls. A tail call can appear in these places: - - 1. In the branches (not the scrutinee) of a case - 2. Underneath a let (value or join point) - 3. Inside another join point - -We write a join-point declaration as - join j @a @b x y = e1 in e2, -like a let binding but with "join" instead (or "join rec" for "let rec"). Note -that we put the parameters before the = rather than using lambdas; this is -because it's relevant how many parameters the join point takes *as a join -point.* This number is called the *join arity,* distinct from arity because it -counts types as well as values. Note that a join point may return a lambda! So - join j x = x + 1 -is different from - join j = \x -> x + 1 -The former has join arity 1, while the latter has join arity 0. - -The identifier for a join point is called a join id or a *label.* An invocation -is called a *jump.* We write a jump using the jump keyword: - - jump j 3 - -The words *label* and *jump* are evocative of assembly code (or Cmm) for a -reason: join points are indeed compiled as labeled blocks, and jumps become -actual jumps (plus argument passing and stack adjustment). There is no closure -allocated and only a fraction of the function-call overhead. Hence we would -like as many functions as possible to become join points (see OccurAnal) and -the type rules for join points ensure we preserve the properties that make them -efficient. - -In the actual AST, a join point is indicated by the IdDetails of the binder: a -local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its -join arity. - -For more details, see the paper: - - Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling - without continuations." Submitted to PLDI'17. - - https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/ - -Note [Invariants on join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Join points must follow these invariants: - - 1. All occurrences must be tail calls. Each of these tail calls must pass the - same number of arguments, counting both types and values; we call this the - "join arity" (to distinguish from regular arity, which only counts values). - - See Note [Join points are less general than the paper] - - 2. For join arity n, the right-hand side must begin with at least n lambdas. - No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity. - - 2a. Moreover, this same constraint applies to any unfolding of - the binder. Reason: if we want to push a continuation into - the RHS we must push it into the unfolding as well. - - 2b. The Arity (in the IdInfo) of a join point is the number of value - binders in the top n lambdas, where n is the join arity. - - So arity <= join arity; the former counts only value binders - while the latter counts all binders. - e.g. Suppose $j has join arity 1 - let j = \x y. e in case x of { A -> j 1; B -> j 2 } - Then its ordinary arity is also 1, not 2. - - The arity of a join point isn't very important; but short of setting - it to zero, it is helpful to have an invariant. E.g. #17294. - - 3. If the binding is recursive, then all other bindings in the recursive group - must also be join points. - - 4. The binding's type must not be polymorphic in its return type (as defined - in Note [The polymorphism rule of join points]). - -However, join points have simpler invariants in other ways - - 5. A join point can have an unboxed type without the RHS being - ok-for-speculation (i.e. drop the let/app invariant) - e.g. let j :: Int# = factorial x in ... - - 6. A join point can have a levity-polymorphic RHS - e.g. let j :: r :: TYPE l = fail void# in ... - This happened in an intermediate program #13394 - -Examples: - - join j1 x = 1 + x in jump j (jump j x) -- Fails 1: non-tail call - join j1' x = 1 + x in if even a - then jump j1 a - else jump j1 a b -- Fails 1: inconsistent calls - join j2 x = flip (+) x in j2 1 2 -- Fails 2: not enough lambdas - join j2' x = \y -> x + y in j3 1 -- Passes: extra lams ok - join j @a (x :: a) = x -- Fails 4: polymorphic in ret type - -Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join -point must have an exact call as its LHS. - -Strictly speaking, invariant 3 is redundant, since a call from inside a lazy -binding isn't a tail call. Since a let-bound value can't invoke a free join -point, then, they can't be mutually recursive. (A Core binding group *can* -include spurious extra bindings if the occurrence analyser hasn't run, so -invariant 3 does still need to be checked.) For the rigorous definition of -"tail call", see Section 3 of the paper (Note [Join points]). - -Invariant 4 is subtle; see Note [The polymorphism rule of join points]. - -Invariant 6 is to enable code like this: - - f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). - join j :: a - j = error @r @a "bloop" - in case x of - A -> j - B -> j - C -> error @r @a "blurp" - -Core Lint will check these invariants, anticipating that any binder whose -OccInfo is marked AlwaysTailCalled will become a join point as soon as the -simplifier (or simpleOptPgm) runs. - -Note [Join points are less general than the paper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the paper "Compiling without continuations", this expression is -perfectly valid: - - join { j = \_ -> e } - in (case blah of ) - ( True -> j void# ) arg - ( False -> blah ) - -assuming 'j' has arity 1. Here the call to 'j' does not look like a -tail call, but actually everything is fine. See Section 3, "Managing \Delta" -in the paper. - -In GHC, however, we adopt a slightly more restrictive subset, in which -join point calls must be tail calls. I think we /could/ loosen it up, but -in fact the simplifier ensures that we always get tail calls, and it makes -the back end a bit easier I think. Generally, just less to think about; -nothing deeper than that. - -Note [The type of a join point] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A join point has the same type it would have as a function. That is, if it takes -an Int and a Bool and its body produces a String, its type is `Int -> Bool -> -String`. Natural as this may seem, it can be awkward. A join point shouldn't be -thought to "return" in the same sense a function does---a jump is one-way. This -is crucial for understanding how case-of-case interacts with join points: - - case (join - j :: Int -> Bool -> String - j x y = ... - in - jump j z w) of - "" -> True - _ -> False - -The simplifier will pull the case into the join point (see Note [Case-of-case -and join points] in Simplify): - - join - j :: Int -> Bool -> Bool -- changed! - j x y = case ... of "" -> True - _ -> False - in - jump j z w - -The body of the join point now returns a Bool, so the label `j` has to have its -type updated accordingly. Inconvenient though this may be, it has the advantage -that 'CoreUtils.exprType' can still return a type for any expression, including -a jump. - -This differs from the paper (see Note [Invariants on join points]). In the -paper, we instead give j the type `Int -> Bool -> forall a. a`. Then each jump -carries the "return type" as a parameter, exactly the way other non-returning -functions like `error` work: - - case (join - j :: Int -> Bool -> forall a. a - j x y = ... - in - jump j z w @String) of - "" -> True - _ -> False - -Now we can move the case inward and we only have to change the jump: - - join - j :: Int -> Bool -> forall a. a - j x y = case ... of "" -> True - _ -> False - in - jump j z w @Bool - -(Core Lint would still check that the body of the join point has the right type; -that type would simply not be reflected in the join id.) - -Note [The polymorphism rule of join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariant 4 of Note [Invariants on join points] forbids a join point to be -polymorphic in its return type. That is, if its type is - - forall a1 ... ak. t1 -> ... -> tn -> r - -where its join arity is k+n, none of the type parameters ai may occur free in r. - -In some way, this falls out of the fact that given - - join - j @a1 ... @ak x1 ... xn = e1 - in e2 - -then all calls to `j` are in tail-call positions of `e`, and expressions in -tail-call positions in `e` have the same type as `e`. -Therefore the type of `e1` -- the return type of the join point -- must be the -same as the type of e2. -Since the type variables aren't bound in `e2`, its type can't include them, and -thus neither can the type of `e1`. - -This unfortunately prevents the `go` in the following code from being a -join-point: - - iter :: forall a. Int -> (a -> a) -> a -> a - iter @a n f x = go @a n f x - where - go :: forall a. Int -> (a -> a) -> a -> a - go @a 0 _ x = x - go @a n f x = go @a (n-1) f (f x) - -In this case, a static argument transformation would fix that (see -ticket #14620): - - iter :: forall a. Int -> (a -> a) -> a -> a - iter @a n f x = go' @a n f x - where - go' :: Int -> (a -> a) -> a -> a - go' 0 _ x = x - go' n f x = go' (n-1) f (f x) - -In general, loopification could be employed to do that (see #14068.) - -Can we simply drop the requirement, and allow `go` to be a join-point? We -could, and it would work. But we could not longer apply the case-of-join-point -transformation universally. This transformation would do: - - case (join go @a n f x = case n of 0 -> x - n -> go @a (n-1) f (f x) - in go @Bool n neg True) of - True -> e1; False -> e2 - - ===> - - join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2 - n -> go @a (n-1) f (f x) - in go @Bool n neg True - -but that is ill-typed, as `x` is type `a`, not `Bool`. - - -This also justifies why we do not consider the `e` in `e |> co` to be in -tail position: A cast changes the type, but the type must be the same. But -operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for -ideas how to fix this. - -************************************************************************ -* * - In/Out type synonyms -* * -********************************************************************* -} - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the substitution has been applied -} - --- Pre-cloning or substitution -type InBndr = CoreBndr -type InType = Type -type InKind = Kind -type InBind = CoreBind -type InExpr = CoreExpr -type InAlt = CoreAlt -type InArg = CoreArg -type InCoercion = Coercion - --- Post-cloning or substitution -type OutBndr = CoreBndr -type OutType = Type -type OutKind = Kind -type OutCoercion = Coercion -type OutBind = CoreBind -type OutExpr = CoreExpr -type OutAlt = CoreAlt -type OutArg = CoreArg -type MOutCoercion = MCoercion - - -{- ********************************************************************* -* * - Ticks -* * -************************************************************************ --} - --- | Allows attaching extra information to points in expressions - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Tickish id = - -- | An @{-# SCC #-}@ profiling annotation, either automatically - -- added by the desugarer as a result of -auto-all, or added by - -- the user. - ProfNote { - profNoteCC :: CostCentre, -- ^ the cost centre - profNoteCount :: !Bool, -- ^ bump the entry count? - profNoteScope :: !Bool -- ^ scopes over the enclosed expression - -- (i.e. not just a tick) - } - - -- | A "tick" used by HPC to track the execution of each - -- subexpression in the original source code. - | HpcTick { - tickModule :: Module, - tickId :: !Int - } - - -- | A breakpoint for the GHCi debugger. This behaves like an HPC - -- tick, but has a list of free variables which will be available - -- for inspection in GHCi when the program stops at the breakpoint. - -- - -- NB. we must take account of these Ids when (a) counting free variables, - -- and (b) substituting (don't substitute for them) - | Breakpoint - { breakpointId :: !Int - , breakpointFVs :: [id] -- ^ the order of this list is important: - -- it matches the order of the lists in the - -- appropriate entry in HscTypes.ModBreaks. - -- - -- Careful about substitution! See - -- Note [substTickish] in CoreSubst. - } - - -- | A source note. - -- - -- Source notes are pure annotations: Their presence should neither - -- influence compilation nor execution. The semantics are given by - -- causality: The presence of a source note means that a local - -- change in the referenced source code span will possibly provoke - -- the generated code to change. On the flip-side, the functionality - -- of annotated code *must* be invariant against changes to all - -- source code *except* the spans referenced in the source notes - -- (see "Causality of optimized Haskell" paper for details). - -- - -- Therefore extending the scope of any given source note is always - -- valid. Note that it is still undesirable though, as this reduces - -- their usefulness for debugging and profiling. Therefore we will - -- generally try only to make use of this property where it is - -- necessary to enable optimizations. - | SourceNote - { sourceSpan :: RealSrcSpan -- ^ Source covered - , sourceName :: String -- ^ Name for source location - -- (uses same names as CCs) - } - - deriving (Eq, Ord, Data) - --- | A "counting tick" (where tickishCounts is True) is one that --- counts evaluations in some way. We cannot discard a counting tick, --- and the compiler should preserve the number of counting ticks as --- far as possible. --- --- However, we still allow the simplifier to increase or decrease --- sharing, so in practice the actual number of ticks may vary, except --- that we never change the value from zero to non-zero or vice versa. -tickishCounts :: Tickish id -> Bool -tickishCounts n@ProfNote{} = profNoteCount n -tickishCounts HpcTick{} = True -tickishCounts Breakpoint{} = True -tickishCounts _ = False - - --- | Specifies the scoping behaviour of ticks. This governs the --- behaviour of ticks that care about the covered code and the cost --- associated with it. Important for ticks relating to profiling. -data TickishScoping = - -- | No scoping: The tick does not care about what code it - -- covers. Transformations can freely move code inside as well as - -- outside without any additional annotation obligations - NoScope - - -- | Soft scoping: We want all code that is covered to stay - -- covered. Note that this scope type does not forbid - -- transformations from happening, as long as all results of - -- the transformations are still covered by this tick or a copy of - -- it. For example - -- - -- let x = tick<...> (let y = foo in bar) in baz - -- ===> - -- let x = tick<...> bar; y = tick<...> foo in baz - -- - -- Is a valid transformation as far as "bar" and "foo" is - -- concerned, because both still are scoped over by the tick. - -- - -- Note though that one might object to the "let" not being - -- covered by the tick any more. However, we are generally lax - -- with this - constant costs don't matter too much, and given - -- that the "let" was effectively merged we can view it as having - -- lost its identity anyway. - -- - -- Also note that this scoping behaviour allows floating a tick - -- "upwards" in pretty much any situation. For example: - -- - -- case foo of x -> tick<...> bar - -- ==> - -- tick<...> case foo of x -> bar - -- - -- While this is always leagl, we want to make a best effort to - -- only make us of this where it exposes transformation - -- opportunities. - | SoftScope - - -- | Cost centre scoping: We don't want any costs to move to other - -- cost-centre stacks. This means we not only want no code or cost - -- to get moved out of their cost centres, but we also object to - -- code getting associated with new cost-centre ticks - or - -- changing the order in which they get applied. - -- - -- A rule of thumb is that we don't want any code to gain new - -- annotations. However, there are notable exceptions, for - -- example: - -- - -- let f = \y -> foo in tick<...> ... (f x) ... - -- ==> - -- tick<...> ... foo[x/y] ... - -- - -- In-lining lambdas like this is always legal, because inlining a - -- function does not change the cost-centre stack when the - -- function is called. - | CostCentreScope - - deriving (Eq) - --- | Returns the intended scoping rule for a Tickish -tickishScoped :: Tickish id -> TickishScoping -tickishScoped n@ProfNote{} - | profNoteScope n = CostCentreScope - | otherwise = NoScope -tickishScoped HpcTick{} = NoScope -tickishScoped Breakpoint{} = CostCentreScope - -- Breakpoints are scoped: eventually we're going to do call - -- stacks, but also this helps prevent the simplifier from moving - -- breakpoints around and changing their result type (see #1531). -tickishScoped SourceNote{} = SoftScope - --- | Returns whether the tick scoping rule is at least as permissive --- as the given scoping rule. -tickishScopesLike :: Tickish id -> TickishScoping -> Bool -tickishScopesLike t scope = tickishScoped t `like` scope - where NoScope `like` _ = True - _ `like` NoScope = False - SoftScope `like` _ = True - _ `like` SoftScope = False - CostCentreScope `like` _ = True - --- | Returns @True@ for ticks that can be floated upwards easily even --- where it might change execution counts, such as: --- --- Just (tick<...> foo) --- ==> --- tick<...> (Just foo) --- --- This is a combination of @tickishSoftScope@ and --- @tickishCounts@. Note that in principle splittable ticks can become --- floatable using @mkNoTick@ -- even though there's currently no --- tickish for which that is the case. -tickishFloatable :: Tickish id -> Bool -tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) - --- | Returns @True@ for a tick that is both counting /and/ scoping and --- can be split into its (tick, scope) parts using 'mkNoScope' and --- 'mkNoTick' respectively. -tickishCanSplit :: Tickish id -> Bool -tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} - = True -tickishCanSplit _ = False - -mkNoCount :: Tickish id -> Tickish id -mkNoCount n | not (tickishCounts n) = n - | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" -mkNoCount n@ProfNote{} = n {profNoteCount = False} -mkNoCount _ = panic "mkNoCount: Undefined split!" - -mkNoScope :: Tickish id -> Tickish id -mkNoScope n | tickishScoped n == NoScope = n - | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" -mkNoScope n@ProfNote{} = n {profNoteScope = False} -mkNoScope _ = panic "mkNoScope: Undefined split!" - --- | Return @True@ if this source annotation compiles to some backend --- code. Without this flag, the tickish is seen as a simple annotation --- that does not have any associated evaluation code. --- --- What this means that we are allowed to disregard the tick if doing --- so means that we can skip generating any code in the first place. A --- typical example is top-level bindings: --- --- foo = tick<...> \y -> ... --- ==> --- foo = \y -> tick<...> ... --- --- Here there is just no operational difference between the first and --- the second version. Therefore code generation should simply --- translate the code as if it found the latter. -tickishIsCode :: Tickish id -> Bool -tickishIsCode SourceNote{} = False -tickishIsCode _tickish = True -- all the rest for now - - --- | Governs the kind of expression that the tick gets placed on when --- annotating for example using @mkTick@. If we find that we want to --- put a tickish on an expression ruled out here, we try to float it --- inwards until we find a suitable expression. -data TickishPlacement = - - -- | Place ticks exactly on run-time expressions. We can still - -- move the tick through pure compile-time constructs such as - -- other ticks, casts or type lambdas. This is the most - -- restrictive placement rule for ticks, as all tickishs have in - -- common that they want to track runtime processes. The only - -- legal placement rule for counting ticks. - PlaceRuntime - - -- | As @PlaceRuntime@, but we float the tick through all - -- lambdas. This makes sense where there is little difference - -- between annotating the lambda and annotating the lambda's code. - | PlaceNonLam - - -- | In addition to floating through lambdas, cost-centre style - -- tickishs can also be moved from constructors, non-function - -- variables and literals. For example: - -- - -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... - -- - -- Neither the constructor application, the variable or the - -- literal are likely to have any cost worth mentioning. And even - -- if y names a thunk, the call would not care about the - -- evaluation context. Therefore removing all annotations in the - -- above example is safe. - | PlaceCostCentre - - deriving (Eq) - --- | Placement behaviour we want for the ticks -tickishPlace :: Tickish id -> TickishPlacement -tickishPlace n@ProfNote{} - | profNoteCount n = PlaceRuntime - | otherwise = PlaceCostCentre -tickishPlace HpcTick{} = PlaceRuntime -tickishPlace Breakpoint{} = PlaceRuntime -tickishPlace SourceNote{} = PlaceNonLam - --- | Returns whether one tick "contains" the other one, therefore --- making the second tick redundant. -tickishContains :: Eq b => Tickish b -> Tickish b -> Bool -tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) - = containsSpan sp1 sp2 && n1 == n2 - -- compare the String last -tickishContains t1 t2 - = t1 == t2 - -{- -************************************************************************ -* * - Orphans -* * -************************************************************************ --} - --- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' --- witnessing the instance's non-orphanhood. --- See Note [Orphans] -data IsOrphan - = IsOrphan - | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood - -- In that case, the instance is fingerprinted as part - -- of the definition of 'n's definition - deriving Data - --- | Returns true if 'IsOrphan' is orphan. -isOrphan :: IsOrphan -> Bool -isOrphan IsOrphan = True -isOrphan _ = False - --- | Returns true if 'IsOrphan' is not an orphan. -notOrphan :: IsOrphan -> Bool -notOrphan NotOrphan{} = True -notOrphan _ = False - -chooseOrphanAnchor :: NameSet -> IsOrphan --- Something (rule, instance) is relate to all the Names in this --- list. Choose one of them to be an "anchor" for the orphan. We make --- the choice deterministic to avoid gratuitious changes in the ABI --- hash (#4012). Specifically, use lexicographic comparison of --- OccName rather than comparing Uniques --- --- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically --- -chooseOrphanAnchor local_names - | isEmptyNameSet local_names = IsOrphan - | otherwise = NotOrphan (minimum occs) - where - occs = map nameOccName $ nonDetEltsUniqSet local_names - -- It's OK to use nonDetEltsUFM here, see comments above - -instance Binary IsOrphan where - put_ bh IsOrphan = putByte bh 0 - put_ bh (NotOrphan n) = do - putByte bh 1 - put_ bh n - get bh = do - h <- getByte bh - case h of - 0 -> return IsOrphan - _ -> do - n <- get bh - return $ NotOrphan n - -{- -Note [Orphans] -~~~~~~~~~~~~~~ -Class instances, rules, and family instances are divided into orphans -and non-orphans. Roughly speaking, an instance/rule is an orphan if -its left hand side mentions nothing defined in this module. Orphan-hood -has two major consequences - - * A module that contains orphans is called an "orphan module". If - the module being compiled depends (transitively) on an oprhan - module M, then M.hi is read in regardless of whether M is oherwise - needed. This is to ensure that we don't miss any instance decls in - M. But it's painful, because it means we need to keep track of all - the orphan modules below us. - - * A non-orphan is not finger-printed separately. Instead, for - fingerprinting purposes it is treated as part of the entity it - mentions on the LHS. For example - data T = T1 | T2 - instance Eq T where .... - The instance (Eq T) is incorprated as part of T's fingerprint. - - In contrast, orphans are all fingerprinted together in the - mi_orph_hash field of the ModIface. - - See MkIface.addFingerprints. - -Orphan-hood is computed - * For class instances: - when we make a ClsInst - (because it is needed during instance lookup) - - * For rules and family instances: - when we generate an IfaceRule (MkIface.coreRuleToIfaceRule) - or IfaceFamInst (MkIface.instanceToIfaceInst) --} - -{- -************************************************************************ -* * -\subsection{Transformation rules} -* * -************************************************************************ - -The CoreRule type and its friends are dealt with mainly in CoreRules, -but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. --} - --- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] - -- The rules are unordered; - -- we sort out any overlaps on lookup - --- | A full rule environment which we can apply rules from. Like a 'RuleBase', --- but it also includes the set of visible orphans we use to filter out orphan --- rules which are not visible (even though we can see them...) -data RuleEnv - = RuleEnv { re_base :: RuleBase - , re_visible_orphs :: ModuleSet - } - -mkRuleEnv :: RuleBase -> [Module] -> RuleEnv -mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs) - -emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet - --- | A 'CoreRule' is: --- --- * \"Local\" if the function it is a rule for is defined in the --- same module as the rule itself. --- --- * \"Orphan\" if nothing on the LHS is defined in the same module --- as the rule itself -data CoreRule - = Rule { - ru_name :: RuleName, -- ^ Name of the rule, for communication with the user - ru_act :: Activation, -- ^ When the rule is active - - -- Rough-matching stuff - -- see comments with InstEnv.ClsInst( is_cls, is_rough ) - ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule - ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side - - -- Proper-matching stuff - -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) - ru_bndrs :: [CoreBndr], -- ^ Variables quantified over - ru_args :: [CoreExpr], -- ^ Left hand side arguments - - -- And the right-hand side - ru_rhs :: CoreExpr, -- ^ Right hand side of the rule - -- Occurrence info is guaranteed correct - -- See Note [OccInfo in unfoldings and rules] - - -- Locality - ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated - -- (notably by Specialise or SpecConstr) - -- @False@ <=> generated at the user's behest - -- See Note [Trimming auto-rules] in TidyPgm - -- for the sole purpose of this field. - - ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used - -- to test if we should see an orphan rule. - - ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. - - ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is - -- defined in the same module as the rule - -- and is not an implicit 'Id' (like a record selector, - -- class operation, or data constructor). This - -- is different from 'ru_orphan', where a rule - -- can avoid being an orphan if *any* Name in - -- LHS of the rule was defined in the same - -- module as the rule. - } - - -- | Built-in rules are used for constant folding - -- and suchlike. They have no free variables. - -- A built-in rule is always visible (there is no such thing as - -- an orphan built-in rule.) - | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above - ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, - -- if it fires, including type arguments - ru_try :: RuleFun - -- ^ This function does the rewrite. It given too many - -- arguments, it simply discards them; the returned 'CoreExpr' - -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args - } - -- See Note [Extra args in rule matching] in Rules.hs - -type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -type InScopeEnv = (InScopeSet, IdUnfoldingFun) - -type IdUnfoldingFun = Id -> Unfolding --- A function that embodies how to unfold an Id if you need --- to do that in the Rule. The reason we need to pass this info in --- is that whether an Id is unfoldable depends on the simplifier phase - -isBuiltinRule :: CoreRule -> Bool -isBuiltinRule (BuiltinRule {}) = True -isBuiltinRule _ = False - -isAutoRule :: CoreRule -> Bool -isAutoRule (BuiltinRule {}) = False -isAutoRule (Rule { ru_auto = is_auto }) = is_auto - --- | The number of arguments the 'ru_fn' must be applied --- to before the rule can match on it -ruleArity :: CoreRule -> Int -ruleArity (BuiltinRule {ru_nargs = n}) = n -ruleArity (Rule {ru_args = args}) = length args - -ruleName :: CoreRule -> RuleName -ruleName = ru_name - -ruleModule :: CoreRule -> Maybe Module -ruleModule Rule { ru_origin } = Just ru_origin -ruleModule BuiltinRule {} = Nothing - -ruleActivation :: CoreRule -> Activation -ruleActivation (BuiltinRule { }) = AlwaysActive -ruleActivation (Rule { ru_act = act }) = act - --- | The 'Name' of the 'Id.Id' at the head of the rule left hand side -ruleIdName :: CoreRule -> Name -ruleIdName = ru_fn - -isLocalRule :: CoreRule -> Bool -isLocalRule = ru_local - --- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side -setRuleIdName :: Name -> CoreRule -> CoreRule -setRuleIdName nm ru = ru { ru_fn = nm } - -{- -************************************************************************ -* * - Unfoldings -* * -************************************************************************ - -The @Unfolding@ type is declared here to avoid numerous loops --} - --- | Records the /unfolding/ of an identifier, which is approximately the form the --- identifier would have if we substituted its definition in for the identifier. --- This type should be treated as abstract everywhere except in "CoreUnfold" -data Unfolding - = NoUnfolding -- ^ We have no information about the unfolding. - - | BootUnfolding -- ^ We have no information about the unfolding, because - -- this 'Id' came from an @hi-boot@ file. - -- See Note [Inlining and hs-boot files] in ToIface - -- for what this is used for. - - | OtherCon [AltCon] -- ^ It ain't one of these constructors. - -- @OtherCon xs@ also indicates that something has been evaluated - -- and hence there's no point in re-evaluating it. - -- @OtherCon []@ is used even for non-data-type values - -- to indicated evaluated-ness. Notably: - -- - -- > data C = C !(Int -> Int) - -- > case x of { C f -> ... } - -- - -- Here, @f@ gets an @OtherCon []@ unfolding. - - | DFunUnfolding { -- The Unfolding of a DFunId - -- See Note [DFun unfoldings] - -- df = /\a1..am. \d1..dn. MkD t1 .. tk - -- (op1 a1..am d1..dn) - -- (op2 a1..am d1..dn) - df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] - df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) - df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, - } -- in positional order - - | CoreUnfolding { -- An unfolding for an Id with no pragma, - -- or perhaps a NOINLINE pragma - -- (For NOINLINE, the phase, if any, is in the - -- InlinePragInfo for this Id.) - uf_tmpl :: CoreExpr, -- Template; occurrence info is correct - uf_src :: UnfoldingSource, -- Where the unfolding came from - uf_is_top :: Bool, -- True <=> top level binding - uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard - -- a `seq` on this variable - uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function - -- Cached version of exprIsConLike - uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand - -- inside an inlining - -- Cached version of exprIsCheap - uf_expandable :: Bool, -- True <=> can expand in RULE matching - -- Cached version of exprIsExpandable - uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. - } - -- ^ An unfolding with redundant cached information. Parameters: - -- - -- uf_tmpl: Template used to perform unfolding; - -- NB: Occurrence info is guaranteed correct: - -- see Note [OccInfo in unfoldings and rules] - -- - -- uf_is_top: Is this a top level binding? - -- - -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on - -- this variable - -- - -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? - -- Basically this is a cached version of 'exprIsWorkFree' - -- - -- uf_guidance: Tells us about the /size/ of the unfolding template - - ------------------------------------------------- -data UnfoldingSource - = -- See also Note [Historical note: unfoldings for wrappers] - - InlineRhs -- The current rhs of the function - -- Replace uf_tmpl each time around - - | InlineStable -- From an INLINE or INLINABLE pragma - -- INLINE if guidance is UnfWhen - -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever - -- (well, technically an INLINABLE might be made - -- UnfWhen if it was small enough, and then - -- it will behave like INLINE outside the current - -- module, but that is the way automatic unfoldings - -- work so it is consistent with the intended - -- meaning of INLINABLE). - -- - -- uf_tmpl may change, but only as a result of - -- gentle simplification, it doesn't get updated - -- to the current RHS during compilation as with - -- InlineRhs. - -- - -- See Note [InlineStable] - - | InlineCompulsory -- Something that *has* no binding, so you *must* inline it - -- Only a few primop-like things have this property - -- (see MkId.hs, calls to mkCompulsoryUnfolding). - -- Inline absolutely always, however boring the context. - - - --- | 'UnfoldingGuidance' says when unfolding should take place -data UnfoldingGuidance - = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl - -- Used (a) for small *and* cheap unfoldings - -- (b) for INLINE functions - -- See Note [INLINE for small functions] in CoreUnfold - ug_arity :: Arity, -- Number of value arguments expected - - ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated - ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring - -- So True,True means "always" - } - - | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the - -- result of a simple analysis of the RHS - - ug_args :: [Int], -- Discount if the argument is evaluated. - -- (i.e., a simplification will definitely - -- be possible). One elt of the list per *value* arg. - - ug_size :: Int, -- The "size" of the unfolding. - - ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in - } -- a context (case (thing args) of ...), - -- (where there are the right number of arguments.) - - | UnfNever -- The RHS is big, so don't inline it - deriving (Eq) - -{- -Note [Historical note: unfoldings for wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have a nice clever scheme in interface files for -wrappers. A wrapper's unfolding can be reconstructed from its worker's -id and its strictness. This decreased .hi file size (sometimes -significantly, for modules like GHC.Classes with many high-arity w/w -splits) and had a slight corresponding effect on compile times. - -However, when we added the second demand analysis, this scheme lead to -some Core lint errors. The second analysis could change the strictness -signatures, which sometimes resulted in a wrapper's regenerated -unfolding applying the wrapper to too many arguments. - -Instead of repairing the clever .hi scheme, we abandoned it in favor -of simplicity. The .hi sizes are usually insignificant (excluding the -+1M for base libraries), and compile time barely increases (~+1% for -nofib). The nicer upshot is that the UnfoldingSource no longer mentions -an Id, so, eg, substitutions need not traverse them. - - -Note [DFun unfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The Arity in a DFunUnfolding is total number of args (type and value) -that the DFun needs to produce a dictionary. That's not necessarily -related to the ordinary arity of the dfun Id, esp if the class has -one method, so the dictionary is represented by a newtype. Example - - class C a where { op :: a -> Int } - instance C a -> C [a] where op xs = op (head xs) - -The instance translates to - - $dfCList :: forall a. C a => C [a] -- Arity 2! - $dfCList = /\a.\d. $copList {a} d |> co - - $copList :: forall a. C a => [a] -> Int -- Arity 2! - $copList = /\a.\d.\xs. op {a} d (head xs) - -Now we might encounter (op (dfCList {ty} d) a1 a2) -and we want the (op (dfList {ty} d)) rule to fire, because $dfCList -has all its arguments, even though its (value) arity is 2. That's -why we record the number of expected arguments in the DFunUnfolding. - -Note that although it's an Arity, it's most convenient for it to give -the *total* number of arguments, both type and value. See the use -site in exprIsConApp_maybe. --} - --- Constants for the UnfWhen constructor -needSaturated, unSaturatedOk :: Bool -needSaturated = False -unSaturatedOk = True - -boringCxtNotOk, boringCxtOk :: Bool -boringCxtOk = True -boringCxtNotOk = False - ------------------------------------------------- -noUnfolding :: Unfolding --- ^ There is no known 'Unfolding' -evaldUnfolding :: Unfolding --- ^ This unfolding marks the associated thing as being evaluated - -noUnfolding = NoUnfolding -evaldUnfolding = OtherCon [] - --- | There is no known 'Unfolding', because this came from an --- hi-boot file. -bootUnfolding :: Unfolding -bootUnfolding = BootUnfolding - -mkOtherCon :: [AltCon] -> Unfolding -mkOtherCon = OtherCon - -isStableSource :: UnfoldingSource -> Bool --- Keep the unfolding template -isStableSource InlineCompulsory = True -isStableSource InlineStable = True -isStableSource InlineRhs = False - --- | Retrieves the template of an unfolding: panics if none is known -unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate = uf_tmpl - --- | Retrieves the template of an unfolding if possible --- maybeUnfoldingTemplate is used mainly wnen specialising, and we do --- want to specialise DFuns, so it's important to return a template --- for DFunUnfoldings -maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) - = Just expr -maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) -maybeUnfoldingTemplate _ - = Nothing - --- | The constructors that the unfolding could never be: --- returns @[]@ if no information is available -otherCons :: Unfolding -> [AltCon] -otherCons (OtherCon cons) = cons -otherCons _ = [] - --- | Determines if it is certainly the case that the unfolding will --- yield a value (something in HNF): returns @False@ if unsure -isValueUnfolding :: Unfolding -> Bool - -- Returns False for OtherCon -isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald -isValueUnfolding _ = False - --- | Determines if it possibly the case that the unfolding will --- yield a value. Unlike 'isValueUnfolding' it returns @True@ --- for 'OtherCon' -isEvaldUnfolding :: Unfolding -> Bool - -- Returns True for OtherCon -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald -isEvaldUnfolding _ = False - --- | @True@ if the unfolding is a constructor application, the application --- of a CONLIKE function or 'OtherCon' -isConLikeUnfolding :: Unfolding -> Bool -isConLikeUnfolding (OtherCon _) = True -isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con -isConLikeUnfolding _ = False - --- | Is the thing we will unfold into certainly cheap? -isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf -isCheapUnfolding _ = False - -isExpandableUnfolding :: Unfolding -> Bool -isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable -isExpandableUnfolding _ = False - -expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr --- Expand an expandable unfolding; this is used in rule matching --- See Note [Expanding variables] in Rules.hs --- The key point here is that CONLIKE things can be expanded -expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs -expandUnfolding_maybe _ = Nothing - -isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True -isCompulsoryUnfolding _ = False - -isStableUnfolding :: Unfolding -> Bool --- True of unfoldings that should not be overwritten --- by a CoreUnfolding for the RHS of a let-binding -isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src -isStableUnfolding (DFunUnfolding {}) = True -isStableUnfolding _ = False - --- | Only returns False if there is no unfolding information available at all -hasSomeUnfolding :: Unfolding -> Bool -hasSomeUnfolding NoUnfolding = False -hasSomeUnfolding BootUnfolding = False -hasSomeUnfolding _ = True - -isBootUnfolding :: Unfolding -> Bool -isBootUnfolding BootUnfolding = True -isBootUnfolding _ = False - -neverUnfoldGuidance :: UnfoldingGuidance -> Bool -neverUnfoldGuidance UnfNever = True -neverUnfoldGuidance _ = False - -isFragileUnfolding :: Unfolding -> Bool --- An unfolding is fragile if it mentions free variables or --- is otherwise subject to change. A robust one can be kept. --- See Note [Fragile unfoldings] -isFragileUnfolding (CoreUnfolding {}) = True -isFragileUnfolding (DFunUnfolding {}) = True -isFragileUnfolding _ = False - -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile - -canUnfold :: Unfolding -> Bool -canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) -canUnfold _ = False - -{- Note [Fragile unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An unfolding is "fragile" if it mentions free variables (and hence would -need substitution) or might be affected by optimisation. The non-fragile -ones are - - NoUnfolding, BootUnfolding - - OtherCon {} If we know this binder (say a lambda binder) will be - bound to an evaluated thing, we want to retain that - info in simpleOptExpr; see #13077. - -We consider even a StableUnfolding as fragile, because it needs substitution. - -Note [InlineStable] -~~~~~~~~~~~~~~~~~ -When you say - {-# INLINE f #-} - f x = -you intend that calls (f e) are replaced by [e/x] So we -should capture (\x.) in the Unfolding of 'f', and never meddle -with it. Meanwhile, we can optimise to our heart's content, -leaving the original unfolding intact in Unfolding of 'f'. For example - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} -We optimise any's RHS fully, but leave the InlineRule saying "all . map p", -which deforests well at the call site. - -So INLINE pragma gives rise to an InlineRule, which captures the original RHS. - -Moreover, it's only used when 'f' is applied to the -specified number of arguments; that is, the number of argument on -the LHS of the '=' sign in the original source definition. -For example, (.) is now defined in the libraries like this - {-# INLINE (.) #-} - (.) f g = \x -> f (g x) -so that it'll inline when applied to two arguments. If 'x' appeared -on the left, thus - (.) f g x = f (g x) -it'd only inline when applied to three arguments. This slightly-experimental -change was requested by Roman, but it seems to make sense. - -See also Note [Inlining an InlineRule] in CoreUnfold. - - -Note [OccInfo in unfoldings and rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In unfoldings and rules, we guarantee that the template is occ-analysed, -so that the occurrence info on the binders is correct. This is important, -because the Simplifier does not re-analyse the template when using it. If -the occurrence info is wrong - - We may get more simplifier iterations than necessary, because - once-occ info isn't there - - More seriously, we may get an infinite loop if there's a Rec - without a loop breaker marked - - -************************************************************************ -* * - AltCon -* * -************************************************************************ --} - --- The Ord is needed for the FiniteMap used in the lookForConstructor --- in SimplEnv. If you declared that lookForConstructor *ignores* --- constructor-applications with LitArg args, then you could get --- rid of this Ord. - -instance Outputable AltCon where - ppr (DataAlt dc) = ppr dc - ppr (LitAlt lit) = ppr lit - ppr DEFAULT = text "__DEFAULT" - -cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering -cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 - -ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool -ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT - -cmpAltCon :: AltCon -> AltCon -> Ordering --- ^ Compares 'AltCon's within a single list of alternatives --- DEFAULT comes out smallest, so that sorting by AltCon puts --- alternatives in the order required: see Note [Case expression invariants] -cmpAltCon DEFAULT DEFAULT = EQ -cmpAltCon DEFAULT _ = LT - -cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 -cmpAltCon (DataAlt _) DEFAULT = GT -cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 -cmpAltCon (LitAlt _) DEFAULT = GT - -cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> - ppr con1 <+> ppr con2 ) - LT - -{- -************************************************************************ -* * -\subsection{Useful synonyms} -* * -************************************************************************ - -Note [CoreProgram] -~~~~~~~~~~~~~~~~~~ -The top level bindings of a program, a CoreProgram, are represented as -a list of CoreBind - - * Later bindings in the list can refer to earlier ones, but not vice - versa. So this is OK - NonRec { x = 4 } - Rec { p = ...q...x... - ; q = ...p...x } - Rec { f = ...p..x..f.. } - NonRec { g = ..f..q...x.. } - But it would NOT be ok for 'f' to refer to 'g'. - - * The occurrence analyser does strongly-connected component analysis - on each Rec binding, and splits it into a sequence of smaller - bindings where possible. So the program typically starts life as a - single giant Rec, which is then dependency-analysed into smaller - chunks. --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -type CoreProgram = [CoreBind] -- See Note [CoreProgram] - --- | The common case for the type of binders and variables when --- we are manipulating the Core language within GHC -type CoreBndr = Var --- | Expressions where binders are 'CoreBndr's -type CoreExpr = Expr CoreBndr --- | Argument expressions where binders are 'CoreBndr's -type CoreArg = Arg CoreBndr --- | Binding groups where binders are 'CoreBndr's -type CoreBind = Bind CoreBndr --- | Case alternatives where binders are 'CoreBndr's -type CoreAlt = Alt CoreBndr - -{- -************************************************************************ -* * -\subsection{Tagging} -* * -************************************************************************ --} - --- | Binders are /tagged/ with a t -data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" - -type TaggedBind t = Bind (TaggedBndr t) -type TaggedExpr t = Expr (TaggedBndr t) -type TaggedArg t = Arg (TaggedBndr t) -type TaggedAlt t = Alt (TaggedBndr t) - -instance Outputable b => Outputable (TaggedBndr b) where - ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' - -deTagExpr :: TaggedExpr t -> CoreExpr -deTagExpr (Var v) = Var v -deTagExpr (Lit l) = Lit l -deTagExpr (Type ty) = Type ty -deTagExpr (Coercion co) = Coercion co -deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) -deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) -deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) -deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) -deTagExpr (Tick t e) = Tick t (deTagExpr e) -deTagExpr (Cast e co) = Cast (deTagExpr e) co - -deTagBind :: TaggedBind t -> CoreBind -deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) -deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] - -deTagAlt :: TaggedAlt t -> CoreAlt -deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) - -{- -************************************************************************ -* * -\subsection{Core-constructing functions with checking} -* * -************************************************************************ --} - --- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to --- use 'MkCore.mkCoreApps' if possible -mkApps :: Expr b -> [Arg b] -> Expr b --- | Apply a list of type argument expressions to a function expression in a nested fashion -mkTyApps :: Expr b -> [Type] -> Expr b --- | Apply a list of coercion argument expressions to a function expression in a nested fashion -mkCoApps :: Expr b -> [Coercion] -> Expr b --- | Apply a list of type or value variables to a function expression in a nested fashion -mkVarApps :: Expr b -> [Var] -> Expr b --- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to --- use 'MkCore.mkCoreConApps' if possible -mkConApp :: DataCon -> [Arg b] -> Expr b - -mkApps f args = foldl' App f args -mkCoApps f args = foldl' (\ e a -> App e (Coercion a)) f args -mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars -mkConApp con args = mkApps (Var (dataConWorkId con)) args - -mkTyApps f args = foldl' (\ e a -> App e (mkTyArg a)) f args - -mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b -mkConApp2 con tys arg_ids = Var (dataConWorkId con) - `mkApps` map Type tys - `mkApps` map varToCoreExpr arg_ids - -mkTyArg :: Type -> Expr b -mkTyArg ty - | Just co <- isCoercionTy_maybe ty = Coercion co - | otherwise = Type ty - --- | Create a machine integer literal expression of type @Int#@ from an @Integer@. --- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLit :: DynFlags -> Integer -> Expr b --- | Create a machine integer literal expression of type @Int#@ from an @Int@. --- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLitInt :: DynFlags -> Int -> Expr b - -mkIntLit dflags n = Lit (mkLitInt dflags n) -mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n)) - --- | Create a machine word literal expression of type @Word#@ from an @Integer@. --- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLit :: DynFlags -> Integer -> Expr b --- | Create a machine word literal expression of type @Word#@ from a @Word@. --- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLitWord :: DynFlags -> Word -> Expr b - -mkWordLit dflags w = Lit (mkLitWord dflags w) -mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w)) - -mkWord64LitWord64 :: Word64 -> Expr b -mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) - -mkInt64LitInt64 :: Int64 -> Expr b -mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w)) - --- | Create a machine character literal expression of type @Char#@. --- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' -mkCharLit :: Char -> Expr b --- | Create a machine string literal expression of type @Addr#@. --- If you want an expression of type @String@ use 'MkCore.mkStringExpr' -mkStringLit :: String -> Expr b - -mkCharLit c = Lit (mkLitChar c) -mkStringLit s = Lit (mkLitString s) - --- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. --- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' -mkFloatLit :: Rational -> Expr b --- | Create a machine single precision literal expression of type @Float#@ from a @Float@. --- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' -mkFloatLitFloat :: Float -> Expr b - -mkFloatLit f = Lit (mkLitFloat f) -mkFloatLitFloat f = Lit (mkLitFloat (toRational f)) - --- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. --- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' -mkDoubleLit :: Rational -> Expr b --- | Create a machine double precision literal expression of type @Double#@ from a @Double@. --- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' -mkDoubleLitDouble :: Double -> Expr b - -mkDoubleLit d = Lit (mkLitDouble d) -mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) - --- | Bind all supplied binding groups over an expression in a nested let expression. Assumes --- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if --- possible, which does guarantee the invariant -mkLets :: [Bind b] -> Expr b -> Expr b --- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to --- use 'MkCore.mkCoreLams' if possible -mkLams :: [b] -> Expr b -> Expr b - -mkLams binders body = foldr Lam body binders -mkLets binds body = foldr mkLet body binds - -mkLet :: Bind b -> Expr b -> Expr b --- The desugarer sometimes generates an empty Rec group --- which Lint rejects, so we kill it off right away -mkLet (Rec []) body = body -mkLet bind body = Let bind body - --- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr@. -mkLetNonRec :: b -> Expr b -> Expr b -> Expr b -mkLetNonRec b rhs body = Let (NonRec b rhs) body - --- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of --- @binds@ if binds is non-empty. -mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b -mkLetRec [] body = body -mkLetRec bs body = Let (Rec bs) body - --- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", --- this can only be used to bind something in a non-recursive @let@ expression -mkTyBind :: TyVar -> Type -> CoreBind -mkTyBind tv ty = NonRec tv (Type ty) - --- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", --- this can only be used to bind something in a non-recursive @let@ expression -mkCoBind :: CoVar -> Coercion -> CoreBind -mkCoBind cv co = NonRec cv (Coercion co) - --- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately -varToCoreExpr :: CoreBndr -> Expr b -varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) - | isCoVar v = Coercion (mkCoVarCo v) - | otherwise = ASSERT( isId v ) Var v - -varsToCoreExprs :: [CoreBndr] -> [Expr b] -varsToCoreExprs vs = map varToCoreExpr vs - -{- -************************************************************************ -* * - Getting a result type -* * -************************************************************************ - -These are defined here to avoid a module loop between CoreUtils and CoreFVs - --} - -applyTypeToArg :: Type -> CoreExpr -> Type --- ^ Determines the type resulting from applying an expression with given type --- to a given argument expression -applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg) - --- | If the expression is a 'Type', converts. Otherwise, --- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'. -exprToType :: CoreExpr -> Type -exprToType (Type ty) = ty -exprToType _bad = pprPanic "exprToType" empty - --- | If the expression is a 'Coercion', converts. -exprToCoercion_maybe :: CoreExpr -> Maybe Coercion -exprToCoercion_maybe (Coercion co) = Just co -exprToCoercion_maybe _ = Nothing - -{- -************************************************************************ -* * -\subsection{Simple access functions} -* * -************************************************************************ --} - --- | Extract every variable by this group -bindersOf :: Bind b -> [b] --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -bindersOf (NonRec binder _) = [binder] -bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] - --- | 'bindersOf' applied to a list of binding groups -bindersOfBinds :: [Bind b] -> [b] -bindersOfBinds binds = foldr ((++) . bindersOf) [] binds - -rhssOfBind :: Bind b -> [Expr b] -rhssOfBind (NonRec _ rhs) = [rhs] -rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] - -rhssOfAlts :: [Alt b] -> [Expr b] -rhssOfAlts alts = [e | (_,_,e) <- alts] - --- | Collapse all the bindings in the supplied groups into a single --- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group -flattenBinds :: [Bind b] -> [(b, Expr b)] -flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds -flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds -flattenBinds [] = [] - --- | We often want to strip off leading lambdas before getting down to --- business. Variants are 'collectTyBinders', 'collectValBinders', --- and 'collectTyAndValBinders' -collectBinders :: Expr b -> ([b], Expr b) -collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) -collectValBinders :: CoreExpr -> ([Id], CoreExpr) -collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) --- | Strip off exactly N leading lambdas (type or value). Good for use with --- join points. -collectNBinders :: Int -> Expr b -> ([b], Expr b) - -collectBinders expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs e = (reverse bs, e) - -collectTyBinders expr - = go [] expr - where - go tvs (Lam b e) | isTyVar b = go (b:tvs) e - go tvs e = (reverse tvs, e) - -collectValBinders expr - = go [] expr - where - go ids (Lam b e) | isId b = go (b:ids) e - go ids body = (reverse ids, body) - -collectTyAndValBinders expr - = (tvs, ids, body) - where - (tvs, body1) = collectTyBinders expr - (ids, body) = collectValBinders body1 - -collectNBinders orig_n orig_expr - = go orig_n [] orig_expr - where - go 0 bs expr = (reverse bs, expr) - go n bs (Lam b e) = go (n-1) (b:bs) e - go _ _ _ = pprPanic "collectNBinders" $ int orig_n - --- | Takes a nested application expression and returns the function --- being applied and the arguments to which it is applied -collectArgs :: Expr b -> (Expr b, [Arg b]) -collectArgs expr - = go expr [] - where - go (App f a) as = go f (a:as) - go e as = (e, as) - --- | Attempt to remove the last N arguments of a function call. --- Strip off any ticks or coercions encountered along the way and any --- at the end. -stripNArgs :: Word -> Expr a -> Maybe (Expr a) -stripNArgs !n (Tick _ e) = stripNArgs n e -stripNArgs n (Cast f _) = stripNArgs n f -stripNArgs 0 e = Just e -stripNArgs n (App f _) = stripNArgs (n - 1) f -stripNArgs _ _ = Nothing - --- | Like @collectArgs@, but also collects looks through floatable --- ticks if it means that we can find more arguments. -collectArgsTicks :: (Tickish Id -> Bool) -> Expr b - -> (Expr b, [Arg b], [Tickish Id]) -collectArgsTicks skipTick expr - = go expr [] [] - where - go (App f a) as ts = go f (a:as) ts - go (Tick t e) as ts - | skipTick t = go e as (t:ts) - go e as ts = (e, as, reverse ts) - - -{- -************************************************************************ -* * -\subsection{Predicates} -* * -************************************************************************ - -At one time we optionally carried type arguments through to runtime. -@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, -i.e. if type applications are actual lambdas because types are kept around -at runtime. Similarly isRuntimeArg. --} - --- | Will this variable exist at runtime? -isRuntimeVar :: Var -> Bool -isRuntimeVar = isId - --- | Will this argument expression exist at runtime? -isRuntimeArg :: CoreExpr -> Bool -isRuntimeArg = isValArg - --- | Returns @True@ for value arguments, false for type args --- NB: coercions are value arguments (zero width, to be sure, --- like State#, but still value args). -isValArg :: Expr b -> Bool -isValArg e = not (isTypeArg e) - --- | Returns @True@ iff the expression is a 'Type' or 'Coercion' --- expression at its top level -isTyCoArg :: Expr b -> Bool -isTyCoArg (Type {}) = True -isTyCoArg (Coercion {}) = True -isTyCoArg _ = False - --- | Returns @True@ iff the expression is a 'Coercion' --- expression at its top level -isCoArg :: Expr b -> Bool -isCoArg (Coercion {}) = True -isCoArg _ = False - --- | Returns @True@ iff the expression is a 'Type' expression at its --- top level. Note this does NOT include 'Coercion's. -isTypeArg :: Expr b -> Bool -isTypeArg (Type {}) = True -isTypeArg _ = False - --- | The number of binders that bind values rather than types -valBndrCount :: [CoreBndr] -> Int -valBndrCount = count isId - --- | The number of argument expressions that are values rather than types at their top level -valArgCount :: [Arg b] -> Int -valArgCount = count isValArg - -{- -************************************************************************ -* * -\subsection{Annotated core} -* * -************************************************************************ --} - --- | Annotated core: allows annotation at every node in the tree -type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) - --- | A clone of the 'Expr' type but allowing annotation at every tree node -data AnnExpr' bndr annot - = AnnVar Id - | AnnLit Literal - | AnnLam bndr (AnnExpr bndr annot) - | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) - | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] - | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) - | AnnCast (AnnExpr bndr annot) (annot, Coercion) - -- Put an annotation on the (root of) the coercion - | AnnTick (Tickish Id) (AnnExpr bndr annot) - | AnnType Type - | AnnCoercion Coercion - --- | A clone of the 'Alt' type but allowing annotation at every tree node -type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) - --- | A clone of the 'Bind' type but allowing annotation at every tree node -data AnnBind bndr annot - = AnnNonRec bndr (AnnExpr bndr annot) - | AnnRec [(bndr, AnnExpr bndr annot)] - --- | Takes a nested application expression and returns the function --- being applied and the arguments to which it is applied -collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) -collectAnnArgs expr - = go expr [] - where - go (_, AnnApp f a) as = go f (a:as) - go e as = (e, as) - -collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a - -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) -collectAnnArgsTicks tickishOk expr - = go expr [] [] - where - go (_, AnnApp f a) as ts = go f (a:as) ts - go (_, AnnTick t e) as ts | tickishOk t - = go e as (t:ts) - go e as ts = (e, as, reverse ts) - -deAnnotate :: AnnExpr bndr annot -> Expr bndr -deAnnotate (_, e) = deAnnotate' e - -deAnnotate' :: AnnExpr' bndr annot -> Expr bndr -deAnnotate' (AnnType t) = Type t -deAnnotate' (AnnCoercion co) = Coercion co -deAnnotate' (AnnVar v) = Var v -deAnnotate' (AnnLit lit) = Lit lit -deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) -deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co -deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) - -deAnnotate' (AnnLet bind body) - = Let (deAnnBind bind) (deAnnotate body) -deAnnotate' (AnnCase scrut v t alts) - = Case (deAnnotate scrut) v t (map deAnnAlt alts) - -deAnnAlt :: AnnAlt bndr annot -> Alt bndr -deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) - -deAnnBind :: AnnBind b annot -> Bind b -deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) -deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] - --- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' -collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) -collectAnnBndrs e - = collect [] e - where - collect bs (_, AnnLam b body) = collect (b:bs) body - collect bs body = (reverse bs, body) - --- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' -collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) -collectNAnnBndrs orig_n e - = collect orig_n [] e - where - collect 0 bs body = (reverse bs, body) - collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body - collect _ _ _ = pprPanic "collectNBinders" $ int orig_n diff --git a/coreSyn/CoreTidy.hs b/coreSyn/CoreTidy.hs deleted file mode 100644 --- a/coreSyn/CoreTidy.hs +++ /dev/null @@ -1,285 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -This module contains "tidying" code for *nested* expressions, bindings, rules. -The code for *top-level* bindings is in TidyPgm. --} - -{-# LANGUAGE CPP #-} -module CoreTidy ( - tidyExpr, tidyRules, tidyUnfolding - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreSeq ( seqUnfolding ) -import Id -import IdInfo -import Demand ( zapUsageEnvSig ) -import Type( tidyType, tidyVarBndr ) -import Coercion( tidyCo ) -import Var -import VarEnv -import UniqFM -import Name hiding (tidyNameOcc) -import SrcLoc -import Maybes -import Data.List - -{- -************************************************************************ -* * -\subsection{Tidying expressions, rules} -* * -************************************************************************ --} - -tidyBind :: TidyEnv - -> CoreBind - -> (TidyEnv, CoreBind) - -tidyBind env (NonRec bndr rhs) - = tidyLetBndr env env bndr =: \ (env', bndr') -> - (env', NonRec bndr' (tidyExpr env' rhs)) - -tidyBind env (Rec prs) - = let - (bndrs, rhss) = unzip prs - (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs - in - map (tidyExpr env') rhss =: \ rhss' -> - (env', Rec (zip bndrs' rhss')) - - ------------- Expressions -------------- -tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr -tidyExpr env (Var v) = Var (tidyVarOcc env v) -tidyExpr env (Type ty) = Type (tidyType env ty) -tidyExpr env (Coercion co) = Coercion (tidyCo env co) -tidyExpr _ (Lit lit) = Lit lit -tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) -tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) -tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) - -tidyExpr env (Let b e) - = tidyBind env b =: \ (env', b') -> - Let b' (tidyExpr env' e) - -tidyExpr env (Case e b ty alts) - = tidyBndr env b =: \ (env', b) -> - Case (tidyExpr env e) b (tidyType env ty) - (map (tidyAlt env') alts) - -tidyExpr env (Lam b e) - = tidyBndr env b =: \ (env', b) -> - Lam b (tidyExpr env' e) - ------------- Case alternatives -------------- -tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt -tidyAlt env (con, vs, rhs) - = tidyBndrs env vs =: \ (env', vs) -> - (con, vs, tidyExpr env' rhs) - ------------- Tickish -------------- -tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id -tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) -tidyTickish _ other_tickish = other_tickish - ------------- Rules -------------- -tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] -tidyRules _ [] = [] -tidyRules env (rule : rules) - = tidyRule env rule =: \ rule -> - tidyRules env rules =: \ rules -> - (rule : rules) - -tidyRule :: TidyEnv -> CoreRule -> CoreRule -tidyRule _ rule@(BuiltinRule {}) = rule -tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, - ru_fn = fn, ru_rough = mb_ns }) - = tidyBndrs env bndrs =: \ (env', bndrs) -> - map (tidyExpr env') args =: \ args -> - rule { ru_bndrs = bndrs, ru_args = args, - ru_rhs = tidyExpr env' rhs, - ru_fn = tidyNameOcc env fn, - ru_rough = map (fmap (tidyNameOcc env')) mb_ns } - -{- -************************************************************************ -* * -\subsection{Tidying non-top-level binders} -* * -************************************************************************ --} - -tidyNameOcc :: TidyEnv -> Name -> Name --- In rules and instances, we have Names, and we must tidy them too --- Fortunately, we can lookup in the VarEnv with a name -tidyNameOcc (_, var_env) n = case lookupUFM var_env n of - Nothing -> n - Just v -> idName v - -tidyVarOcc :: TidyEnv -> Var -> Var -tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v - --- tidyBndr is used for lambda and case binders -tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) -tidyBndr env var - | isTyCoVar var = tidyVarBndr env var - | otherwise = tidyIdBndr env var - -tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) -tidyBndrs env vars = mapAccumL tidyBndr env vars - --- Non-top-level variables, not covars -tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) -tidyIdBndr env@(tidy_env, var_env) id - = -- Do this pattern match strictly, otherwise we end up holding on to - -- stuff in the OccName. - case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> - let - -- Give the Id a fresh print-name, *and* rename its type - -- The SrcLoc isn't important now, - -- though we could extract it from the Id - -- - ty' = tidyType env (idType id) - name' = mkInternalName (idUnique id) occ' noSrcSpan - id' = mkLocalIdWithInfo name' ty' new_info - var_env' = extendVarEnv var_env id id' - - -- Note [Tidy IdInfo] - new_info = vanillaIdInfo `setOccInfo` occInfo old_info - `setUnfoldingInfo` new_unf - -- see Note [Preserve OneShotInfo] - `setOneShotInfo` oneShotInfo old_info - old_info = idInfo id - old_unf = unfoldingInfo old_info - new_unf = zapUnfolding old_unf -- See Note [Preserve evaluatedness] - in - ((tidy_env', var_env'), id') - } - -tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings - -> TidyEnv -- The one to extend - -> Id -> (TidyEnv, Id) --- Used for local (non-top-level) let(rec)s --- Just like tidyIdBndr above, but with more IdInfo -tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id - = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> - let - ty' = tidyType env (idType id) - name' = mkInternalName (idUnique id) occ' noSrcSpan - details = idDetails id - id' = mkLocalVar details name' ty' new_info - var_env' = extendVarEnv var_env id id' - - -- Note [Tidy IdInfo] - -- We need to keep around any interesting strictness and - -- demand info because later on we may need to use it when - -- converting to A-normal form. - -- eg. - -- f (g x), where f is strict in its argument, will be converted - -- into case (g x) of z -> f z by CorePrep, but only if f still - -- has its strictness info. - -- - -- Similarly for the demand info - on a let binder, this tells - -- CorePrep to turn the let into a case. - -- But: Remove the usage demand here - -- (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap) - -- - -- Similarly arity info for eta expansion in CorePrep - -- Don't attempt to recompute arity here; this is just tidying! - -- Trying to do so led to #17294 - -- - -- Set inline-prag info so that we preseve it across - -- separate compilation boundaries - old_info = idInfo id - new_info = vanillaIdInfo - `setOccInfo` occInfo old_info - `setArityInfo` arityInfo old_info - `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) - `setDemandInfo` demandInfo old_info - `setInlinePragInfo` inlinePragInfo old_info - `setUnfoldingInfo` new_unf - - old_unf = unfoldingInfo old_info - new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf - | otherwise = zapUnfolding old_unf - -- See Note [Preserve evaluatedness] - - in - ((tidy_env', var_env'), id') } - ------------- Unfolding -------------- -tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding -tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ - = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } - where - (tidy_env', bndrs') = tidyBndrs tidy_env bndrs - -tidyUnfolding tidy_env - unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) - unf_from_rhs - | isStableSource src - = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo - -- This seqIt avoids a space leak: otherwise the uf_is_value, - -- uf_is_conlike, ... fields may retain a reference to the - -- pre-tidied expression forever (ToIface doesn't look at them) - - | otherwise - = unf_from_rhs - where seqIt unf = seqUnfolding unf `seq` unf -tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon - -{- -Note [Tidy IdInfo] -~~~~~~~~~~~~~~~~~~ -All nested Ids now have the same IdInfo, namely vanillaIdInfo, which -should save some space; except that we preserve occurrence info for -two reasons: - - (a) To make printing tidy core nicer - - (b) Because we tidy RULES and InlineRules, which may then propagate - via --make into the compilation of the next module, and we want - the benefit of that occurrence analysis when we use the rule or - or inline the function. In particular, it's vital not to lose - loop-breaker info, else we get an infinite inlining loop - -Note that tidyLetBndr puts more IdInfo back. - -Note [Preserve evaluatedness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT !Bool - ....(case v of MkT y -> - let z# = case y of - True -> 1# - False -> 2# - in ...) - -The z# binding is ok because the RHS is ok-for-speculation, -but Lint will complain unless it can *see* that. So we -preserve the evaluated-ness on 'y' in tidyBndr. - -(Another alternative would be to tidy unboxed lets into cases, -but that seems more indirect and surprising.) - -Note [Preserve OneShotInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We keep the OneShotInfo because we want it to propagate into the interface. -Not all OneShotInfo is determined by a compiler analysis; some is added by a -call of GHC.Exts.oneShot, which is then discarded before the end of the -optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we -must preserve this info in inlinings. See Note [The oneShot function] in MkId. - -This applies to lambda binders only, hence it is stored in IfaceLamBndr. --} - -(=:) :: a -> (a -> b) -> b -m =: k = m `seq` k m diff --git a/coreSyn/CoreUnfold.hs b/coreSyn/CoreUnfold.hs deleted file mode 100644 --- a/coreSyn/CoreUnfold.hs +++ /dev/null @@ -1,1654 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -Core-syntax unfoldings - -Unfoldings (which can travel across module boundaries) are in Core -syntax (namely @CoreExpr@s). - -The type @Unfolding@ sits ``above'' simply-Core-expressions -unfoldings, capturing ``higher-level'' things we know about a binding, -usually things that the simplifier found out (e.g., ``it's a -literal''). In the corner of a @CoreUnfolding@ unfolding, you will -find, unsurprisingly, a Core expression. --} - -{-# LANGUAGE CPP #-} - -module CoreUnfold ( - Unfolding, UnfoldingGuidance, -- Abstract types - - noUnfolding, mkImplicitUnfolding, - mkUnfolding, mkCoreUnfolding, - mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, - mkInlineUnfolding, mkInlineUnfoldingWithArity, - mkInlinableUnfolding, mkWwInlineRule, - mkCompulsoryUnfolding, mkDFunUnfolding, - specUnfolding, - - ArgSummary(..), - - couldBeSmallEnoughToInline, inlineBoringOk, - certainlyWillInline, smallEnoughToInline, - - callSiteInline, CallCtxt(..), - - -- Reexport from CoreSubst (it only live there so it can be used - -- by the Very Simple Optimiser) - exprIsConApp_maybe, exprIsLiteral_maybe - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import CoreSyn -import OccurAnal ( occurAnalyseExpr_NoBinderSwap ) -import CoreOpt -import CoreArity ( manifestArity ) -import CoreUtils -import Id -import Demand ( isBottomingSig ) -import DataCon -import Literal -import PrimOp -import IdInfo -import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) -import Type -import PrelNames -import TysPrim ( realWorldStatePrimTy ) -import Bag -import Util -import Outputable -import ForeignCall -import Name - -import qualified Data.ByteString as BS -import Data.List - -{- -************************************************************************ -* * -\subsection{Making unfoldings} -* * -************************************************************************ --} - -mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding -mkTopUnfolding dflags is_bottoming rhs - = mkUnfolding dflags InlineRhs True is_bottoming rhs - -mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding --- For implicit Ids, do a tiny bit of optimising first -mkImplicitUnfolding dflags expr - = mkTopUnfolding dflags False (simpleOptExpr dflags expr) - --- Note [Top-level flag on inline rules] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Slight hack: note that mk_inline_rules conservatively sets the --- top-level flag to True. It gets set more accurately by the simplifier --- Simplify.simplUnfolding. - -mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding -mkSimpleUnfolding dflags rhs - = mkUnfolding dflags InlineRhs False False rhs - -mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding -mkDFunUnfolding bndrs con ops - = DFunUnfolding { df_bndrs = bndrs - , df_con = con - , df_args = map occurAnalyseExpr_NoBinderSwap ops } - -- See Note [Occurrence analysis of unfoldings] - -mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding -mkWwInlineRule dflags expr arity - = mkCoreUnfolding InlineStable True - (simpleOptExpr dflags expr) - (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boringCxtNotOk }) - -mkCompulsoryUnfolding :: CoreExpr -> Unfolding -mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding InlineCompulsory True - (simpleOptExpr unsafeGlobalDynFlags expr) - (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter - , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) - -mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding --- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap -mkWorkerUnfolding dflags work_fn - (CoreUnfolding { uf_src = src, uf_tmpl = tmpl - , uf_is_top = top_lvl }) - | isStableSource src - = mkCoreUnfolding src top_lvl new_tmpl guidance - where - new_tmpl = simpleOptExpr dflags (work_fn tmpl) - guidance = calcUnfoldingGuidance dflags False new_tmpl - -mkWorkerUnfolding _ _ _ = noUnfolding - --- | Make an unfolding that may be used unsaturated --- (ug_unsat_ok = unSaturatedOk) and that is reported as having its --- manifest arity (the number of outer lambdas applications will --- resolve before doing any work). -mkInlineUnfolding :: CoreExpr -> Unfolding -mkInlineUnfolding expr - = mkCoreUnfolding InlineStable - True -- Note [Top-level flag on inline rules] - expr' guide - where - expr' = simpleOptExpr unsafeGlobalDynFlags expr - guide = UnfWhen { ug_arity = manifestArity expr' - , ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boring_ok } - boring_ok = inlineBoringOk expr' - --- | Make an unfolding that will be used once the RHS has been saturated --- to the given arity. -mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding -mkInlineUnfoldingWithArity arity expr - = mkCoreUnfolding InlineStable - True -- Note [Top-level flag on inline rules] - expr' guide - where - expr' = simpleOptExpr unsafeGlobalDynFlags expr - guide = UnfWhen { ug_arity = arity - , ug_unsat_ok = needSaturated - , ug_boring_ok = boring_ok } - -- See Note [INLINE pragmas and boring contexts] as to why we need to look - -- at the arity here. - boring_ok | arity == 0 = True - | otherwise = inlineBoringOk expr' - -mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding -mkInlinableUnfolding dflags expr - = mkUnfolding dflags InlineStable False False expr' - where - expr' = simpleOptExpr dflags expr - -specUnfolding :: DynFlags - -> [Var] -> (CoreExpr -> CoreExpr) - -> [CoreArg] -- LHS arguments in the RULE - -> Unfolding -> Unfolding --- See Note [Specialising unfoldings] --- specUnfolding spec_bndrs spec_args unf --- = \spec_bndrs. unf spec_args --- -specUnfolding dflags spec_bndrs spec_app rule_lhs_args - df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) - = ASSERT2( rule_lhs_args `equalLength` old_bndrs - , ppr df $$ ppr rule_lhs_args ) - -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise - mkDFunUnfolding spec_bndrs con (map spec_arg args) - -- For DFunUnfoldings we transform - -- \obs. MkD ... - -- to - -- \sbs. MkD ((\obs. ) spec_args) ... ditto - where - spec_arg arg = simpleOptExpr dflags $ - spec_app (mkLams old_bndrs arg) - -- The beta-redexes created by spec_app will be - -- simplified away by simplOptExpr - -specUnfolding dflags spec_bndrs spec_app rule_lhs_args - (CoreUnfolding { uf_src = src, uf_tmpl = tmpl - , uf_is_top = top_lvl - , uf_guidance = old_guidance }) - | isStableSource src -- See Note [Specialising unfoldings] - , UnfWhen { ug_arity = old_arity } <- old_guidance - = mkCoreUnfolding src top_lvl new_tmpl - (old_guidance { ug_arity = old_arity - arity_decrease }) - where - new_tmpl = simpleOptExpr dflags $ - mkLams spec_bndrs $ - spec_app tmpl -- The beta-redexes created by spec_app - -- will besimplified away by simplOptExpr - arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs - - -specUnfolding _ _ _ _ _ = noUnfolding - -{- Note [Specialising unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise a function for some given type-class arguments, we use -specUnfolding to specialise its unfolding. Some important points: - -* If the original function has a DFunUnfolding, the specialised one - must do so too! Otherwise we lose the magic rules that make it - interact with ClassOps - -* There is a bit of hack for INLINABLE functions: - f :: Ord a => .... - f = - {- INLINABLE f #-} - Now if we specialise f, should the specialised version still have - an INLINABLE pragma? If it does, we'll capture a specialised copy - of as its unfolding, and that probaby won't inline. But - if we don't, the specialised version of might be small - enough to inline at a call site. This happens with Control.Monad.liftM3, - and can cause a lot more allocation as a result (nofib n-body shows this). - - Moreover, keeping the INLINABLE thing isn't much help, because - the specialised function (probaby) isn't overloaded any more. - - Conclusion: drop the INLINEALE pragma. In practice what this means is: - if a stable unfolding has UnfoldingGuidance of UnfWhen, - we keep it (so the specialised thing too will always inline) - if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs - (which arises from INLINABLE), we discard it - -Note [Honour INLINE on 0-ary bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - x = - {-# INLINE x #-} - - f y = ...x... - -The semantics of an INLINE pragma is - - inline x at every call site, provided it is saturated; - that is, applied to at least as many arguments as appear - on the LHS of the Haskell source definition. - -(This soure-code-derived arity is stored in the `ug_arity` field of -the `UnfoldingGuidance`.) - -In the example, x's ug_arity is 0, so we should inline it at every use -site. It's rare to have such an INLINE pragma (usually INLINE Is on -functions), but it's occasionally very important (#15578, #15519). -In #15519 we had something like - x = case (g a b) of I# r -> T r - {-# INLINE x #-} - f y = ...(h x).... - -where h is strict. So we got - f y = ...(case g a b of I# r -> h (T r))... - -and that in turn allowed SpecConstr to ramp up performance. - -How do we deliver on this? By adjusting the ug_boring_ok -flag in mkInlineUnfoldingWithArity; see -Note [INLINE pragmas and boring contexts] - -NB: there is a real risk that full laziness will float it right back -out again. Consider again - x = factorial 200 - {-# INLINE x #-} - f y = ...x... - -After inlining we get - f y = ...(factorial 200)... - -but it's entirely possible that full laziness will do - lvl23 = factorial 200 - f y = ...lvl23... - -That's a problem for another day. - -Note [INLINE pragmas and boring contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An INLINE pragma uses mkInlineUnfoldingWithArity to build the -unfolding. That sets the ug_boring_ok flag to False if the function -is not tiny (inlineBoringOK), so that even INLINE functions are not -inlined in an utterly boring context. E.g. - \x y. Just (f y x) -Nothing is gained by inlining f here, even if it has an INLINE -pragma. - -But for 0-ary bindings, we want to inline regardless; see -Note [Honour INLINE on 0-ary bindings]. - -I'm a bit worried that it's possible for the same kind of problem -to arise for non-0-ary functions too, but let's wait and see. --} - -mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr - -> UnfoldingGuidance -> Unfolding --- Occurrence-analyses the expression before capturing it -mkCoreUnfolding src top_lvl expr guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, - -- See Note [Occurrence analysis of unfoldings] - uf_src = src, - uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_is_work_free = exprIsWorkFree expr, - uf_expandable = exprIsExpandable expr, - uf_guidance = guidance } - -mkUnfolding :: DynFlags -> UnfoldingSource - -> Bool -- Is top-level - -> Bool -- Definitely a bottoming binding - -- (only relevant for top-level bindings) - -> CoreExpr - -> Unfolding --- Calculates unfolding guidance --- Occurrence-analyses the expression before capturing it -mkUnfolding dflags src is_top_lvl is_bottoming expr - = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, - -- See Note [Occurrence analysis of unfoldings] - uf_src = src, - uf_is_top = is_top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_expandable = exprIsExpandable expr, - uf_is_work_free = exprIsWorkFree expr, - uf_guidance = guidance } - where - is_top_bottoming = is_top_lvl && is_bottoming - guidance = calcUnfoldingGuidance dflags is_top_bottoming expr - -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))! - -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] - -{- -Note [Occurrence analysis of unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do occurrence-analysis of unfoldings once and for all, when the -unfolding is built, rather than each time we inline them. - -But given this decision it's vital that we do -*always* do it. Consider this unfolding - \x -> letrec { f = ...g...; g* = f } in body -where g* is (for some strange reason) the loop breaker. If we don't -occ-anal it when reading it in, we won't mark g as a loop breaker, and -we may inline g entirely in body, dropping its binding, and leaving -the occurrence in f out of scope. This happened in #8892, where -the unfolding in question was a DFun unfolding. - -But more generally, the simplifier is designed on the -basis that it is looking at occurrence-analysed expressions, so better -ensure that they acutally are. - -We use occurAnalyseExpr_NoBinderSwap instead of occurAnalyseExpr; -see Note [No binder swap in unfoldings]. - -Note [No binder swap in unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The binder swap can temporarily violate Core Lint, by assinging -a LocalId binding to a GlobalId. For example, if A.foo{r872} -is a GlobalId with unique r872, then - - case A.foo{r872} of bar { - K x -> ...(A.foo{r872})... - } - -gets transformed to - - case A.foo{r872} of bar { - K x -> let foo{r872} = bar - in ...(A.foo{r872})... - -This is usually not a problem, because the simplifier will transform -this to: - - case A.foo{r872} of bar { - K x -> ...(bar)... - -However, after occurrence analysis but before simplification, this extra 'let' -violates the Core Lint invariant that we do not have local 'let' bindings for -GlobalIds. That seems (just) tolerable for the occurrence analysis that happens -just before the Simplifier, but not for unfoldings, which are Linted -independently. -As a quick workaround, we disable binder swap in this module. -See #16288 and #16296 for further plans. - -Note [Calculate unfolding guidance on the non-occ-anal'd expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we give the non-occur-analysed expression to -calcUnfoldingGuidance. In some ways it'd be better to occur-analyse -first; for example, sometimes during simplification, there's a large -let-bound thing which has been substituted, and so is now dead; so -'expr' contains two copies of the thing while the occurrence-analysed -expression doesn't. - -Nevertheless, we *don't* and *must not* occ-analyse before computing -the size because - -a) The size computation bales out after a while, whereas occurrence - analysis does not. - -b) Residency increases sharply if you occ-anal first. I'm not - 100% sure why, but it's a large effect. Compiling Cabal went - from residency of 534M to over 800M with this one change. - -This can occasionally mean that the guidance is very pessimistic; -it gets fixed up next round. And it should be rare, because large -let-bound things that are dead are usually caught by preInlineUnconditionally - - -************************************************************************ -* * -\subsection{The UnfoldingGuidance type} -* * -************************************************************************ --} - -inlineBoringOk :: CoreExpr -> Bool --- See Note [INLINE for small functions] --- True => the result of inlining the expression is --- no bigger than the expression itself --- eg (\x y -> f y x) --- This is a quick and dirty version. It doesn't attempt --- to deal with (\x y z -> x (y z)) --- The really important one is (x `cast` c) -inlineBoringOk e - = go 0 e - where - go :: Int -> CoreExpr -> Bool - go credit (Lam x e) | isId x = go (credit+1) e - | otherwise = go credit e - -- See Note [Count coercion arguments in boring contexts] - go credit (App f (Type {})) = go credit f - go credit (App f a) | credit > 0 - , exprIsTrivial a = go (credit-1) f - go credit (Tick _ e) = go credit e -- dubious - go credit (Cast e _) = go credit e - go _ (Var {}) = boringCxtOk - go _ _ = boringCxtNotOk - -calcUnfoldingGuidance - :: DynFlags - -> Bool -- Definitely a top-level, bottoming binding - -> CoreExpr -- Expression to look at - -> UnfoldingGuidance -calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr) - | not (tickishIsCode t) -- non-code ticks don't matter for unfolding - = calcUnfoldingGuidance dflags is_top_bottoming expr -calcUnfoldingGuidance dflags is_top_bottoming expr - = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of - TooBig -> UnfNever - SizeIs size cased_bndrs scrut_discount - | uncondInline expr n_val_bndrs size - -> UnfWhen { ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boringCxtOk - , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] - - | is_top_bottoming - -> UnfNever -- See Note [Do not inline top-level bottoming functions] - - | otherwise - -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs - , ug_size = size - , ug_res = scrut_discount } - - where - (bndrs, body) = collectBinders expr - bOMB_OUT_SIZE = ufCreationThreshold dflags - -- Bomb out if size gets bigger than this - val_bndrs = filter isId bndrs - n_val_bndrs = length val_bndrs - - mk_discount :: Bag (Id,Int) -> Id -> Int - mk_discount cbs bndr = foldl' combine 0 cbs - where - combine acc (bndr', disc) - | bndr == bndr' = acc `plus_disc` disc - | otherwise = acc - - plus_disc :: Int -> Int -> Int - plus_disc | isFunTy (idType bndr) = max - | otherwise = (+) - -- See Note [Function and non-function discounts] - -{- -Note [Computing the size of an expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea of sizeExpr is obvious enough: count nodes. But getting the -heuristics right has taken a long time. Here's the basic strategy: - - * Variables, literals: 0 - (Exception for string literals, see litSize.) - - * Function applications (f e1 .. en): 1 + #value args - - * Constructor applications: 1, regardless of #args - - * Let(rec): 1 + size of components - - * Note, cast: 0 - -Examples - - Size Term - -------------- - 0 42# - 0 x - 0 True - 2 f x - 1 Just x - 4 f (g x) - -Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's -a function call to account for. Notice also that constructor applications -are very cheap, because exposing them to a caller is so valuable. - -[25/5/11] All sizes are now multiplied by 10, except for primops -(which have sizes like 1 or 4. This makes primops look fantastically -cheap, and seems to be almost unversally beneficial. Done partly as a -result of #4978. - -Note [Do not inline top-level bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The FloatOut pass has gone to some trouble to float out calls to 'error' -and similar friends. See Note [Bottoming floats] in SetLevels. -Do not re-inline them! But we *do* still inline if they are very small -(the uncondInline stuff). - -Note [INLINE for small functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider {-# INLINE f #-} - f x = Just x - g y = f y -Then f's RHS is no larger than its LHS, so we should inline it into -even the most boring context. In general, f the function is -sufficiently small that its body is as small as the call itself, the -inline unconditionally, regardless of how boring the context is. - -Things to note: - -(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) - than the thing it's replacing. Notice that - (f x) --> (g 3) -- YES, unconditionally - (f x) --> x : [] -- YES, *even though* there are two - -- arguments to the cons - x --> g 3 -- NO - x --> Just v -- NO - - It's very important not to unconditionally replace a variable by - a non-atomic term. - -(2) We do this even if the thing isn't saturated, else we end up with the - silly situation that - f x y = x - ...map (f 3)... - doesn't inline. Even in a boring context, inlining without being - saturated will give a lambda instead of a PAP, and will be more - efficient at runtime. - -(3) However, when the function's arity > 0, we do insist that it - has at least one value argument at the call site. (This check is - made in the UnfWhen case of callSiteInline.) Otherwise we find this: - f = /\a \x:a. x - d = /\b. MkD (f b) - If we inline f here we get - d = /\b. MkD (\x:b. x) - and then prepareRhs floats out the argument, abstracting the type - variables, so we end up with the original again! - -(4) We must be much more cautious about arity-zero things. Consider - let x = y +# z in ... - In *size* terms primops look very small, because the generate a - single instruction, but we do not want to unconditionally replace - every occurrence of x with (y +# z). So we only do the - unconditional-inline thing for *trivial* expressions. - - NB: you might think that PostInlineUnconditionally would do this - but it doesn't fire for top-level things; see SimplUtils - Note [Top level and postInlineUnconditionally] - -Note [Count coercion arguments in boring contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In inlineBoringOK, we ignore type arguments when deciding whether an -expression is okay to inline into boring contexts. This is good, since -if we have a definition like - - let y = x @Int in f y y - -there’s no reason not to inline y at both use sites — no work is -actually duplicated. It may seem like the same reasoning applies to -coercion arguments, and indeed, in #17182 we changed inlineBoringOK to -treat coercions the same way. - -However, this isn’t a good idea: unlike type arguments, which have -no runtime representation, coercion arguments *do* have a runtime -representation (albeit the zero-width VoidRep, see Note [Coercion tokens] -in CoreToStg.hs). This caused trouble in #17787 for DataCon wrappers for -nullary GADT constructors: the wrappers would be inlined and each use of -the constructor would lead to a separate allocation instead of just -sharing the wrapper closure. - -The solution: don’t ignore coercion arguments after all. --} - -uncondInline :: CoreExpr -> Arity -> Int -> Bool --- Inline unconditionally if there no size increase --- Size of call is arity (+1 for the function) --- See Note [INLINE for small functions] -uncondInline rhs arity size - | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) - | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) - -sizeExpr :: DynFlags - -> Int -- Bomb out if it gets bigger than this - -> [Id] -- Arguments; we're interested in which of these - -- get case'd - -> CoreExpr - -> ExprSize - --- Note [Computing the size of an expression] - -sizeExpr dflags bOMB_OUT_SIZE top_args expr - = size_up expr - where - size_up (Cast e _) = size_up e - size_up (Tick _ e) = size_up e - size_up (Type _) = sizeZero -- Types cost nothing - size_up (Coercion _) = sizeZero - size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isRealWorldId f = sizeZero - -- Make sure we get constructor discounts even - -- on nullary constructors - | otherwise = size_up_call f [] 0 - - size_up (App fun arg) - | isTyCoArg arg = size_up fun - | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) - - size_up (Lam b e) - | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) - | otherwise = size_up e - - size_up (Let (NonRec binder rhs) body) - = size_up_rhs (binder, rhs) `addSizeNSD` - size_up body `addSizeN` - size_up_alloc binder - - size_up (Let (Rec pairs) body) - = foldr (addSizeNSD . size_up_rhs) - (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) - pairs - - size_up (Case e _ _ alts) - | null alts - = size_up e -- case e of {} never returns, so take size of scrutinee - - size_up (Case e _ _ alts) - -- Now alts is non-empty - | Just v <- is_top_arg e -- We are scrutinising an argument variable - = let - alt_sizes = map size_up_alt alts - - -- alts_size tries to compute a good discount for - -- the case when we are scrutinising an argument variable - alts_size (SizeIs tot tot_disc tot_scrut) - -- Size of all alternatives - (SizeIs max _ _) - -- Size of biggest alternative - = SizeIs tot (unitBag (v, 20 + tot - max) - `unionBags` tot_disc) tot_scrut - -- If the variable is known, we produce a - -- discount that will take us back to 'max', - -- the size of the largest alternative The - -- 1+ is a little discount for reduced - -- allocation in the caller - -- - -- Notice though, that we return tot_disc, - -- the total discount from all branches. I - -- think that's right. - - alts_size tot_size _ = tot_size - in - alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty - (foldr1 maxSize alt_sizes) - -- Good to inline if an arg is scrutinised, because - -- that may eliminate allocation in the caller - -- And it eliminates the case itself - where - is_top_arg (Var v) | v `elem` top_args = Just v - is_top_arg (Cast e _) = is_top_arg e - is_top_arg _ = Nothing - - - size_up (Case e _ _ alts) = size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts - where - case_size - | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) - | otherwise = sizeZero - -- Normally we don't charge for the case itself, but - -- we charge one per alternative (see size_up_alt, - -- below) to account for the cost of the info table - -- and comparisons. - -- - -- However, in certain cases (see is_inline_scrut - -- below), no code is generated for the case unless - -- there are multiple alts. In these cases we - -- subtract one, making the first alt free. - -- e.g. case x# +# y# of _ -> ... should cost 1 - -- case touch# x# of _ -> ... should cost 0 - -- (see #4978) - -- - -- I would like to not have the "lengthAtMost alts 1" - -- condition above, but without that some programs got worse - -- (spectral/hartel/event and spectral/para). I don't fully - -- understand why. (SDM 24/5/11) - - -- unboxed variables, inline primops and unsafe foreign calls - -- are all "inline" things: - is_inline_scrut (Var v) = isUnliftedType (idType v) - is_inline_scrut scrut - | (Var f, _) <- collectArgs scrut - = case idDetails f of - FCallId fc -> not (isSafeForeignCall fc) - PrimOpId op -> not (primOpOutOfLine op) - _other -> False - | otherwise - = False - - size_up_rhs (bndr, rhs) - | Just join_arity <- isJoinId_maybe bndr - -- Skip arguments to join point - , (_bndrs, body) <- collectNBinders join_arity rhs - = size_up body - | otherwise - = size_up rhs - - ------------ - -- size_up_app is used when there's ONE OR MORE value args - size_up_app (App fun arg) args voids - | isTyCoArg arg = size_up_app fun args voids - | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) - | otherwise = size_up arg `addSizeNSD` - size_up_app fun (arg:args) voids - size_up_app (Var fun) args voids = size_up_call fun args voids - size_up_app (Tick _ expr) args voids = size_up_app expr args voids - size_up_app (Cast expr _) args voids = size_up_app expr args voids - size_up_app other args voids = size_up other `addSizeN` - callSize (length args) voids - -- if the lhs is not an App or a Var, or an invisible thing like a - -- Tick or Cast, then we should charge for a complete call plus the - -- size of the lhs itself. - - ------------ - size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize - size_up_call fun val_args voids - = case idDetails fun of - FCallId _ -> sizeN (callSize (length val_args) voids) - DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op -> primOpSize op (length val_args) - ClassOpId _ -> classOpSize dflags top_args val_args - _ -> funSize dflags top_args fun (length val_args) voids - - ------------ - size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 - -- Don't charge for args, so that wrappers look cheap - -- (See comments about wrappers with Case) - -- - -- IMPORTANT: *do* charge 1 for the alternative, else we - -- find that giant case nests are treated as practically free - -- A good example is Foreign.C.Error.errnoToIOError - - ------------ - -- Cost to allocate binding with given binder - size_up_alloc bndr - | isTyVar bndr -- Doesn't exist at runtime - || isJoinId bndr -- Not allocated at all - || isUnliftedType (idType bndr) -- Doesn't live in heap - = 0 - | otherwise - = 10 - - ------------ - -- These addSize things have to be here because - -- I don't want to give them bOMB_OUT_SIZE as an argument - addSizeN TooBig _ = TooBig - addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d - - -- addAltSize is used to add the sizes of case alternatives - addAltSize TooBig _ = TooBig - addAltSize _ TooBig = TooBig - addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) - = mkSizeIs bOMB_OUT_SIZE (n1 + n2) - (xs `unionBags` ys) - (d1 + d2) -- Note [addAltSize result discounts] - - -- This variant ignores the result discount from its LEFT argument - -- It's used when the second argument isn't part of the result - addSizeNSD TooBig _ = TooBig - addSizeNSD _ TooBig = TooBig - addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) - = mkSizeIs bOMB_OUT_SIZE (n1 + n2) - (xs `unionBags` ys) - d2 -- Ignore d1 - - isRealWorldId id = idType id `eqType` realWorldStatePrimTy - - -- an expression of type State# RealWorld must be a variable - isRealWorldExpr (Var id) = isRealWorldId id - isRealWorldExpr (Tick _ e) = isRealWorldExpr e - isRealWorldExpr _ = False - --- | Finds a nominal size of a string literal. -litSize :: Literal -> Int --- Used by CoreUnfold.sizeExpr -litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers] -litSize (LitNumber LitNumNatural _ _) = 100 -litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) - -- If size could be 0 then @f "x"@ might be too small - -- [Sept03: make literal strings a bit bigger to avoid fruitless - -- duplication of little strings] -litSize _other = 0 -- Must match size of nullary constructors - -- Key point: if x |-> 4, then x must inline unconditionally - -- (eg via case binding) - -classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize --- See Note [Conlike is interesting] -classOpSize _ _ [] - = sizeZero -classOpSize dflags top_args (arg1 : other_args) - = SizeIs size arg_discount 0 - where - size = 20 + (10 * length other_args) - -- If the class op is scrutinising a lambda bound dictionary then - -- give it a discount, to encourage the inlining of this function - -- The actual discount is rather arbitrarily chosen - arg_discount = case arg1 of - Var dict | dict `elem` top_args - -> unitBag (dict, ufDictDiscount dflags) - _other -> emptyBag - --- | The size of a function call -callSize - :: Int -- ^ number of value args - -> Int -- ^ number of value args that are void - -> Int -callSize n_val_args voids = 10 * (1 + n_val_args - voids) - -- The 1+ is for the function itself - -- Add 1 for each non-trivial arg; - -- the allocation cost, as in let(rec) - --- | The size of a jump to a join point -jumpSize - :: Int -- ^ number of value args - -> Int -- ^ number of value args that are void - -> Int -jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) - -- A jump is 20% the size of a function call. Making jumps free reopens - -- bug #6048, but making them any more expensive loses a 21% improvement in - -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a - -- better solution? - -funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize --- Size for functions that are not constructors or primops --- Note [Function applications] -funSize dflags top_args fun n_val_args voids - | fun `hasKey` buildIdKey = buildSize - | fun `hasKey` augmentIdKey = augmentSize - | otherwise = SizeIs size arg_discount res_discount - where - some_val_args = n_val_args > 0 - is_join = isJoinId fun - - size | is_join = jumpSize n_val_args voids - | not some_val_args = 0 - | otherwise = callSize n_val_args voids - - -- DISCOUNTS - -- See Note [Function and non-function discounts] - arg_discount | some_val_args && fun `elem` top_args - = unitBag (fun, ufFunAppDiscount dflags) - | otherwise = emptyBag - -- If the function is an argument and is applied - -- to some values, give it an arg-discount - - res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags - | otherwise = 0 - -- If the function is partially applied, show a result discount --- XXX maybe behave like ConSize for eval'd variable - -conSize :: DataCon -> Int -> ExprSize -conSize dc n_val_args - | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables - --- See Note [Unboxed tuple size and result discount] - | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args)) - --- See Note [Constructor size and result discount] - | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args)) - --- XXX still looks to large to me - -{- -Note [Constructor size and result discount] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Treat a constructors application as size 10, regardless of how many -arguments it has; we are keen to expose them (and we charge separately -for their args). We can't treat them as size zero, else we find that -(Just x) has size 0, which is the same as a lone variable; and hence -'v' will always be replaced by (Just x), where v is bound to Just x. - -The "result discount" is applied if the result of the call is -scrutinised (say by a case). For a constructor application that will -mean the constructor application will disappear, so we don't need to -charge it to the function. So the discount should at least match the -cost of the constructor application, namely 10. But to give a bit -of extra incentive we give a discount of 10*(1 + n_val_args). - -Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), -and said it was an "unambiguous win", but its terribly dangerous -because a function with many many case branches, each finishing with -a constructor, can have an arbitrarily large discount. This led to -terrible code bloat: see #6099. - -Note [Unboxed tuple size and result discount] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -However, unboxed tuples count as size zero. I found occasions where we had - f x y z = case op# x y z of { s -> (# s, () #) } -and f wasn't getting inlined. - -I tried giving unboxed tuples a *result discount* of zero (see the -commented-out line). Why? When returned as a result they do not -allocate, so maybe we don't want to charge so much for them If you -have a non-zero discount here, we find that workers often get inlined -back into wrappers, because it look like - f x = case $wf x of (# a,b #) -> (a,b) -and we are keener because of the case. However while this change -shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% -more. All other changes were very small. So it's not a big deal but I -didn't adopt the idea. - -Note [Function and non-function discounts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want a discount if the function is applied. A good example is -monadic combinators with continuation arguments, where inlining is -quite important. - -But we don't want a big discount when a function is called many times -(see the detailed comments with #6048) because if the function is -big it won't be inlined at its many call sites and no benefit results. -Indeed, we can get exponentially big inlinings this way; that is what -#6048 is about. - -On the other hand, for data-valued arguments, if there are lots of -case expressions in the body, each one will get smaller if we apply -the function to a constructor application, so we *want* a big discount -if the argument is scrutinised by many case expressions. - -Conclusion: - - For functions, take the max of the discounts - - For data values, take the sum of the discounts - - -Note [Literal integer size] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Literal integers *can* be big (mkInteger [...coefficients...]), but -need not be (S# n). We just use an arbitrary big-ish constant here -so that, in particular, we don't inline top-level defns like - n = S# 5 -There's no point in doing so -- any optimisations will see the S# -through n's unfolding. Nor will a big size inhibit unfoldings functions -that mention a literal Integer, because the float-out pass will float -all those constants to top level. --} - -primOpSize :: PrimOp -> Int -> ExprSize -primOpSize op n_val_args - = if primOpOutOfLine op - then sizeN (op_size + n_val_args) - else sizeN op_size - where - op_size = primOpCodeSize op - - -buildSize :: ExprSize -buildSize = SizeIs 0 emptyBag 40 - -- We really want to inline applications of build - -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) - -- Indeed, we should add a result_discount because build is - -- very like a constructor. We don't bother to check that the - -- build is saturated (it usually is). The "-2" discounts for the \c n, - -- The "4" is rather arbitrary. - -augmentSize :: ExprSize -augmentSize = SizeIs 0 emptyBag 40 - -- Ditto (augment t (\cn -> e) ys) should cost only the cost of - -- e plus ys. The -2 accounts for the \cn - --- When we return a lambda, give a discount if it's used (applied) -lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize -lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags) -lamScrutDiscount _ TooBig = TooBig - -{- -Note [addAltSize result discounts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding the size of alternatives, we *add* the result discounts -too, rather than take the *maximum*. For a multi-branch case, this -gives a discount for each branch that returns a constructor, making us -keener to inline. I did try using 'max' instead, but it makes nofib -'rewrite' and 'puzzle' allocate significantly more, and didn't make -binary sizes shrink significantly either. - -Note [Discounts and thresholds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constants for discounts and thesholds are defined in main/DynFlags, -all of form ufXxxx. They are: - -ufCreationThreshold - At a definition site, if the unfolding is bigger than this, we - may discard it altogether - -ufUseThreshold - At a call site, if the unfolding, less discounts, is smaller than - this, then it's small enough inline - -ufKeenessFactor - Factor by which the discounts are multiplied before - subtracting from size - -ufDictDiscount - The discount for each occurrence of a dictionary argument - as an argument of a class method. Should be pretty small - else big functions may get inlined - -ufFunAppDiscount - Discount for a function argument that is applied. Quite - large, because if we inline we avoid the higher-order call. - -ufDearOp - The size of a foreign call or not-dupable PrimOp - -ufVeryAggressive - If True, the compiler ignores all the thresholds and inlines very - aggressively. It still adheres to arity, simplifier phase control and - loop breakers. - - -Note [Function applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a function application (f a b) - - - If 'f' is an argument to the function being analysed, - and there's at least one value arg, record a FunAppDiscount for f - - - If the application if a PAP (arity > 2 in this example) - record a *result* discount (because inlining - with "extra" args in the call may mean that we now - get a saturated application) - -Code for manipulating sizes --} - --- | The size of a candidate expression for unfolding -data ExprSize - = TooBig - | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found - , _es_args :: !(Bag (Id,Int)) - -- ^ Arguments cased herein, and discount for each such - , _es_discount :: {-# UNPACK #-} !Int - -- ^ Size to subtract if result is scrutinised by a case - -- expression - } - -instance Outputable ExprSize where - ppr TooBig = text "TooBig" - ppr (SizeIs a _ c) = brackets (int a <+> int c) - --- subtract the discount before deciding whether to bale out. eg. we --- want to inline a large constructor application into a selector: --- tup = (a_1, ..., a_99) --- x = case tup of ... --- -mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize -mkSizeIs max n xs d | (n - d) > max = TooBig - | otherwise = SizeIs n xs d - -maxSize :: ExprSize -> ExprSize -> ExprSize -maxSize TooBig _ = TooBig -maxSize _ TooBig = TooBig -maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 - | otherwise = s2 - -sizeZero :: ExprSize -sizeN :: Int -> ExprSize - -sizeZero = SizeIs 0 emptyBag 0 -sizeN n = SizeIs n emptyBag 0 - -{- -************************************************************************ -* * -\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} -* * -************************************************************************ - -We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that -we ``couldn't possibly use'' on the other side. Can be overridden w/ -flaggery. Just the same as smallEnoughToInline, except that it has no -actual arguments. --} - -couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline dflags threshold rhs - = case sizeExpr dflags threshold [] body of - TooBig -> False - _ -> True - where - (_, body) = collectBinders rhs - ----------------- -smallEnoughToInline :: DynFlags -> Unfolding -> Bool -smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) - = size <= ufUseThreshold dflags -smallEnoughToInline _ _ - = False - ----------------- - -certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding --- ^ Sees if the unfolding is pretty certain to inline. --- If so, return a *stable* unfolding for it, that will always inline. -certainlyWillInline dflags fn_info - = case unfoldingInfo fn_info of - CoreUnfolding { uf_tmpl = e, uf_guidance = g } - | loop_breaker -> Nothing -- Won't inline, so try w/w - | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] - | otherwise -> do_cunf e g -- Depends on size, so look at that - - DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense - -- to do so, and even if it is currently a - -- loop breaker, it may not be later - - _other_unf -> Nothing - - where - loop_breaker = isStrongLoopBreaker (occInfo fn_info) - noinline = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline - fn_unf = unfoldingInfo fn_info - - do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding - do_cunf _ UnfNever = Nothing - do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) - -- INLINE functions have UnfWhen - - -- The UnfIfGoodArgs case seems important. If we w/w small functions - -- binary sizes go up by 10%! (This is with SplitObjs.) - -- I'm not totally sure why. - -- INLINABLE functions come via this path - -- See Note [certainlyWillInline: INLINABLE] - do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) - | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] - , not (isBottomingSig (strictnessInfo fn_info)) - -- Do not unconditionally inline a bottoming functions even if - -- it seems smallish. We've carefully lifted it out to top level, - -- so we don't want to re-inline it. - , let unf_arity = length args - , size - (10 * (unf_arity + 1)) <= ufUseThreshold dflags - = Just (fn_unf { uf_src = InlineStable - , uf_guidance = UnfWhen { ug_arity = unf_arity - , ug_unsat_ok = unSaturatedOk - , ug_boring_ok = inlineBoringOk expr } }) - -- Note the "unsaturatedOk". A function like f = \ab. a - -- will certainly inline, even if partially applied (f e), so we'd - -- better make sure that the transformed inlining has the same property - | otherwise - = Nothing - -{- Note [certainlyWillInline: be careful of thunks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't claim that thunks will certainly inline, because that risks work -duplication. Even if the work duplication is not great (eg is_cheap -holds), it can make a big difference in an inner loop In #5623 we -found that the WorkWrap phase thought that - y = case x of F# v -> F# (v +# v) -was certainlyWillInline, so the addition got duplicated. - -Note that we check arityInfo instead of the arity of the unfolding to detect -this case. This is so that we don't accidentally fail to inline small partial -applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2 -(say). Here there is no risk of work duplication, and the RHS is tiny, so -certainlyWillInline should return True. But `unf_arity` is zero! However f's -arity, gotten from `arityInfo fn_info`, is 1. - -Failing to say that `f` will inline forces W/W to generate a potentially huge -worker for f that will immediately cancel with `g`'s wrapper anyway, causing -unnecessary churn in the Simplifier while arriving at the same result. - -Note [certainlyWillInline: INLINABLE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -certainlyWillInline /must/ return Nothing for a large INLINABLE thing, -even though we have a stable inlining, so that strictness w/w takes -place. It makes a big difference to efficiency, and the w/w pass knows -how to transfer the INLINABLE info to the worker; see WorkWrap -Note [Worker-wrapper for INLINABLE functions] - -************************************************************************ -* * -\subsection{callSiteInline} -* * -************************************************************************ - -This is the key function. It decides whether to inline a variable at a call site - -callSiteInline is used at call sites, so it is a bit more generous. -It's a very important function that embodies lots of heuristics. -A non-WHNF can be inlined if it doesn't occur inside a lambda, -and occurs exactly once or - occurs once in each branch of a case and is small - -If the thing is in WHNF, there's no danger of duplicating work, -so we can inline if it occurs once, or is small - -NOTE: we don't want to inline top-level functions that always diverge. -It just makes the code bigger. Tt turns out that the convenient way to prevent -them inlining is to give them a NOINLINE pragma, which we do in -StrictAnal.addStrictnessInfoToTopId --} - -callSiteInline :: DynFlags - -> Id -- The Id - -> Bool -- True <=> unfolding is active - -> Bool -- True if there are no arguments at all (incl type args) - -> [ArgSummary] -- One for each value arg; True if it is interesting - -> CallCtxt -- True <=> continuation is interesting - -> Maybe CoreExpr -- Unfolding, if any - -data ArgSummary = TrivArg -- Nothing interesting - | NonTrivArg -- Arg has structure - | ValueArg -- Arg is a con-app or PAP - -- ..or con-like. Note [Conlike is interesting] - -instance Outputable ArgSummary where - ppr TrivArg = text "TrivArg" - ppr NonTrivArg = text "NonTrivArg" - ppr ValueArg = text "ValueArg" - -nonTriv :: ArgSummary -> Bool -nonTriv TrivArg = False -nonTriv _ = True - -data CallCtxt - = BoringCtxt - | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] - | DiscArgCtxt -- Argument of a function with non-zero arg discount - | RuleArgCtxt -- We are somewhere in the argument of a function with rules - - | ValAppCtxt -- We're applied to at least one value arg - -- This arises when we have ((f x |> co) y) - -- Then the (f x) has argument 'x' but in a ValAppCtxt - - | CaseCtxt -- We're the scrutinee of a case - -- that decomposes its scrutinee - -instance Outputable CallCtxt where - ppr CaseCtxt = text "CaseCtxt" - ppr ValAppCtxt = text "ValAppCtxt" - ppr BoringCtxt = text "BoringCtxt" - ppr RhsCtxt = text "RhsCtxt" - ppr DiscArgCtxt = text "DiscArgCtxt" - ppr RuleArgCtxt = text "RuleArgCtxt" - -callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info - = case idUnfolding id of - -- idUnfolding checks for loop-breakers, returning NoUnfolding - -- Things with an INLINE pragma may have an unfolding *and* - -- be a loop breaker (maybe the knot is not yet untied) - CoreUnfolding { uf_tmpl = unf_template - , uf_is_work_free = is_wf - , uf_guidance = guidance, uf_expandable = is_exp } - | active_unfolding -> tryUnfolding dflags id lone_variable - arg_infos cont_info unf_template - is_wf is_exp guidance - | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing - NoUnfolding -> Nothing - BootUnfolding -> Nothing - OtherCon {} -> Nothing - DFunUnfolding {} -> Nothing -- Never unfold a DFun - -traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a -traceInline dflags inline_id str doc result - | Just prefix <- inlineCheck dflags - = if prefix `isPrefixOf` occNameString (getOccName inline_id) - then pprTrace str doc result - else result - | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags - = pprTrace str doc result - | otherwise - = result - --- | This is an awful but temporary workaround for #17615, where the --- case analysis from the 'ufVeryAggressive' selector causes the entire --- 'DynFlags' to be unpacked into local bindings (due to binder swap). This --- results in a tremendous amount of stack spillage, severely bloating the code --- generated for 'callSiteInline'. --- --- The right solution here is likely to fix binder swap to avoid this terrible --- behavior (since there are likely other instances of this as well) but this --- case was serious enough that it showed up in a CPU profile and consequently --- I wanted to fix it for 8.10. -very_aggressive :: DynFlags -> Bool -very_aggressive = ufVeryAggressive -{-# NOINLINE very_aggressive #-} - -tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt - -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance - -> Maybe CoreExpr -tryUnfolding dflags id lone_variable - arg_infos cont_info unf_template - is_wf is_exp guidance - = case guidance of - UnfNever -> traceInline dflags id str (text "UnfNever") Nothing - - UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - | enough_args && (boring_ok || some_benefit || very_aggressive dflags) - -- See Note [INLINE for small functions (3)] - -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template) - | otherwise - -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing - where - some_benefit = calc_some_benefit uf_arity - enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) - - UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } - | very_aggressive dflags - -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) - | is_wf && some_benefit && small_enough - -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) - | otherwise - -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing - where - some_benefit = calc_some_benefit (length arg_discounts) - extra_doc = text "discounted size =" <+> int discounted_size - discounted_size = size - discount - small_enough = discounted_size <= ufUseThreshold dflags - discount = computeDiscount dflags arg_discounts - res_discount arg_infos cont_info - - where - mk_doc some_benefit extra_doc yes_or_no - = vcat [ text "arg infos" <+> ppr arg_infos - , text "interesting continuation" <+> ppr cont_info - , text "some_benefit" <+> ppr some_benefit - , text "is exp:" <+> ppr is_exp - , text "is work-free:" <+> ppr is_wf - , text "guidance" <+> ppr guidance - , extra_doc - , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] - - str = "Considering inlining: " ++ showSDocDump dflags (ppr id) - n_val_args = length arg_infos - - -- some_benefit is used when the RHS is small enough - -- and the call has enough (or too many) value - -- arguments (ie n_val_args >= arity). But there must - -- be *something* interesting about some argument, or the - -- result context, to make it worth inlining - calc_some_benefit :: Arity -> Bool -- The Arity is the number of args - -- expected by the unfolding - calc_some_benefit uf_arity - | not saturated = interesting_args -- Under-saturated - -- Note [Unsaturated applications] - | otherwise = interesting_args -- Saturated or over-saturated - || interesting_call - where - saturated = n_val_args >= uf_arity - over_saturated = n_val_args > uf_arity - interesting_args = any nonTriv arg_infos - -- NB: (any nonTriv arg_infos) looks at the - -- over-saturated args too which is "wrong"; - -- but if over-saturated we inline anyway. - - interesting_call - | over_saturated - = True - | otherwise - = case cont_info of - CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] - ValAppCtxt -> True -- Note [Cast then apply] - RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] - DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - RhsCtxt -> uf_arity > 0 -- - _other -> False -- See Note [Nested functions] - - -{- -Note [Unfold into lazy contexts], Note [RHS of lets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the call is the argument of a function with a RULE, or the RHS of a let, -we are a little bit keener to inline. For example - f y = (y,y,y) - g y = let x = f y in ...(case x of (a,b,c) -> ...) ... -We'd inline 'f' if the call was in a case context, and it kind-of-is, -only we can't see it. Also - x = f v -could be expensive whereas - x = case v of (a,b) -> a -is patently cheap and may allow more eta expansion. -So we treat the RHS of a let as not-totally-boring. - -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When a call is not saturated, we *still* inline if one of the -arguments has interesting structure. That's sometimes very important. -A good example is the Ord instance for Bool in Base: - - Rec { - $fOrdBool =GHC.Classes.D:Ord - @ Bool - ... - $cmin_ajX - - $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool - $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool - } - -But the defn of GHC.Classes.$dmmin is: - - $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a - {- Arity: 3, HasNoCafRefs, Strictness: SLL, - Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> - case @ a GHC.Classes.<= @ a $dOrd x y of wild { - GHC.Types.False -> y GHC.Types.True -> x }) -} - -We *really* want to inline $dmmin, even though it has arity 3, in -order to unravel the recursion. - - -Note [Things to watch] -~~~~~~~~~~~~~~~~~~~~~~ -* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } - Assume x is exported, so not inlined unconditionally. - Then we want x to inline unconditionally; no reason for it - not to, and doing so avoids an indirection. - -* { x = I# 3; ....f x.... } - Make sure that x does not inline unconditionally! - Lest we get extra allocation. - -Note [Inlining an InlineRule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An InlineRules is used for - (a) programmer INLINE pragmas - (b) inlinings from worker/wrapper - -For (a) the RHS may be large, and our contract is that we *only* inline -when the function is applied to all the arguments on the LHS of the -source-code defn. (The uf_arity in the rule.) - -However for worker/wrapper it may be worth inlining even if the -arity is not satisfied (as we do in the CoreUnfolding case) so we don't -require saturation. - -Note [Nested functions] -~~~~~~~~~~~~~~~~~~~~~~~ -At one time we treated a call of a non-top-level function as -"interesting" (regardless of how boring the context) in the hope -that inlining it would eliminate the binding, and its allocation. -Specifically, in the default case of interesting_call we had - _other -> not is_top && uf_arity > 0 - -But actually postInlineUnconditionally does some of this and overall -it makes virtually no difference to nofib. So I simplified away this -special case - -Note [Cast then apply] -~~~~~~~~~~~~~~~~~~~~~~ -Consider - myIndex = __inline_me ( (/\a. ) |> co ) - co :: (forall a. a -> a) ~ (forall a. T a) - ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... - -We need to inline myIndex to unravel this; but the actual call (myIndex a) has -no value arguments. The ValAppCtxt gives it enough incentive to inline. - -Note [Inlining in ArgCtxt] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The condition (arity > 0) here is very important, because otherwise -we end up inlining top-level stuff into useless places; eg - x = I# 3# - f = \y. g x -This can make a very big difference: it adds 16% to nofib 'integer' allocs, -and 20% to 'power'. - -At one stage I replaced this condition by 'True' (leading to the above -slow-down). The motivation was test eyeball/inline1.hs; but that seems -to work ok now. - -NOTE: arguably, we should inline in ArgCtxt only if the result of the -call is at least CONLIKE. At least for the cases where we use ArgCtxt -for the RHS of a 'let', we only profit from the inlining if we get a -CONLIKE thing (modulo lets). - -Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] -~~~~~~~~~~~~~~~~~~~~~ which appears below -The "lone-variable" case is important. I spent ages messing about -with unsatisfactory variants, but this is nice. The idea is that if a -variable appears all alone - - as an arg of lazy fn, or rhs BoringCtxt - as scrutinee of a case CaseCtxt - as arg of a fn ArgCtxt -AND - it is bound to a cheap expression - -then we should not inline it (unless there is some other reason, -e.g. it is the sole occurrence). That is what is happening at -the use of 'lone_variable' in 'interesting_call'. - -Why? At least in the case-scrutinee situation, turning - let x = (a,b) in case x of y -> ... -into - let x = (a,b) in case (a,b) of y -> ... -and thence to - let x = (a,b) in let y = (a,b) in ... -is bad if the binding for x will remain. - -Another example: I discovered that strings -were getting inlined straight back into applications of 'error' -because the latter is strict. - s = "foo" - f = \x -> ...(error s)... - -Fundamentally such contexts should not encourage inlining because, provided -the RHS is "expandable" (see Note [exprIsExpandable] in CoreUtils) the -context can ``see'' the unfolding of the variable (e.g. case or a -RULE) so there's no gain. - -However, watch out: - - * Consider this: - foo = _inline_ (\n. [n]) - bar = _inline_ (foo 20) - baz = \n. case bar of { (m:_) -> m + n } - Here we really want to inline 'bar' so that we can inline 'foo' - and the whole thing unravels as it should obviously do. This is - important: in the NDP project, 'bar' generates a closure data - structure rather than a list. - - So the non-inlining of lone_variables should only apply if the - unfolding is regarded as cheap; because that is when exprIsConApp_maybe - looks through the unfolding. Hence the "&& is_wf" in the - InlineRule branch. - - * Even a type application or coercion isn't a lone variable. - Consider - case $fMonadST @ RealWorld of { :DMonad a b c -> c } - We had better inline that sucker! The case won't see through it. - - For now, I'm treating treating a variable applied to types - in a *lazy* context "lone". The motivating example was - f = /\a. \x. BIG - g = /\a. \y. h (f a) - There's no advantage in inlining f here, and perhaps - a significant disadvantage. Hence some_val_args in the Stop case - -Note [Interaction of exprIsWorkFree and lone variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The lone-variable test says "don't inline if a case expression -scrutinises a lone variable whose unfolding is cheap". It's very -important that, under these circumstances, exprIsConApp_maybe -can spot a constructor application. So, for example, we don't -consider - let x = e in (x,x) -to be cheap, and that's good because exprIsConApp_maybe doesn't -think that expression is a constructor application. - -In the 'not (lone_variable && is_wf)' test, I used to test is_value -rather than is_wf, which was utterly wrong, because the above -expression responds True to exprIsHNF, which is what sets is_value. - -This kind of thing can occur if you have - - {-# INLINE foo #-} - foo = let x = e in (x,x) - -which Roman did. - - --} - -computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt - -> Int -computeDiscount dflags arg_discounts res_discount arg_infos cont_info - -- We multiple the raw discounts (args_discount and result_discount) - -- ty opt_UnfoldingKeenessFactor because the former have to do with - -- *size* whereas the discounts imply that there's some extra - -- *efficiency* to be gained (e.g. beta reductions, case reductions) - -- by inlining. - - = 10 -- Discount of 10 because the result replaces the call - -- so we count 10 for the function itself - - + 10 * length actual_arg_discounts - -- Discount of 10 for each arg supplied, - -- because the result replaces the call - - + round (ufKeenessFactor dflags * - fromIntegral (total_arg_discount + res_discount')) - where - actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos - total_arg_discount = sum actual_arg_discounts - - mk_arg_discount _ TrivArg = 0 - mk_arg_discount _ NonTrivArg = 10 - mk_arg_discount discount ValueArg = discount - - res_discount' - | LT <- arg_discounts `compareLength` arg_infos - = res_discount -- Over-saturated - | otherwise - = case cont_info of - BoringCtxt -> 0 - CaseCtxt -> res_discount -- Presumably a constructor - ValAppCtxt -> res_discount -- Presumably a function - _ -> 40 `min` res_discount - -- ToDo: this 40 `min` res_discount doesn't seem right - -- for DiscArgCtxt it shouldn't matter because the function will - -- get the arg discount for any non-triv arg - -- for RuleArgCtxt we do want to be keener to inline; but not only - -- constructor results - -- for RhsCtxt I suppose that exposing a data con is good in general - -- And 40 seems very arbitrary - -- - -- res_discount can be very large when a function returns - -- constructors; but we only want to invoke that large discount - -- when there's a case continuation. - -- Otherwise we, rather arbitrarily, threshold it. Yuk. - -- But we want to aovid inlining large functions that return - -- constructors into contexts that are simply "interesting" diff --git a/coreSyn/CoreUnfold.hs-boot b/coreSyn/CoreUnfold.hs-boot deleted file mode 100644 --- a/coreSyn/CoreUnfold.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module CoreUnfold ( - mkUnfolding - ) where - -import GhcPrelude -import CoreSyn -import DynFlags - -mkUnfolding :: DynFlags - -> UnfoldingSource - -> Bool - -> Bool - -> CoreExpr - -> Unfolding diff --git a/coreSyn/CoreUtils.hs b/coreSyn/CoreUtils.hs deleted file mode 100644 --- a/coreSyn/CoreUtils.hs +++ /dev/null @@ -1,2675 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utility functions on @Core@ syntax --} - -{-# LANGUAGE CPP #-} - --- | Commonly useful utilites for manipulating the Core language -module CoreUtils ( - -- * Constructing expressions - mkCast, - mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, - bindNonRec, needsCaseBinding, - mkAltExpr, mkDefaultCase, mkSingleAltCase, - - -- * Taking expressions apart - findDefault, addDefault, findAlt, isDefaultAlt, - mergeAlts, trimConArgs, - filterAlts, combineIdenticalAlts, refineDefaultAlt, - - -- * Properties of expressions - exprType, coreAltType, coreAltsType, isExprLevPoly, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, - getIdFromTrivialExpr_maybe, - exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, - exprIsBig, exprIsConLike, - rhsIsStatic, isCheapApp, isExpandableApp, - exprIsTickedString, exprIsTickedString_maybe, - exprIsTopLevelBindable, - altsAreExhaustive, - - -- * Equality - cheapEqExpr, cheapEqExpr', eqExpr, - diffExpr, diffBinds, - - -- * Eta reduction - tryEtaReduce, - - -- * Manipulating data constructors and types - exprToType, exprToCoercion_maybe, - applyTypeToArgs, applyTypeToArg, - dataConRepInstPat, dataConRepFSInstPat, - isEmptyTy, - - -- * Working with ticks - stripTicksTop, stripTicksTopE, stripTicksTopT, - stripTicksE, stripTicksT, - - -- * StaticPtr - collectMakeStaticArgs, - - -- * Join points - isJoinBind - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import PrelNames ( makeStaticName ) -import PprCore -import CoreFVs( exprFreeVars ) -import Var -import SrcLoc -import VarEnv -import VarSet -import Name -import Literal -import DataCon -import PrimOp -import Id -import IdInfo -import PrelNames( absentErrorIdKey ) -import Type -import Predicate -import TyCoRep( TyCoBinder(..), TyBinder ) -import Coercion -import TyCon -import Unique -import Outputable -import TysPrim -import DynFlags -import FastString -import Maybes -import ListSetOps ( minusList ) -import BasicTypes ( Arity, isConLike ) -import GHC.Platform -import Util -import Pair -import Data.ByteString ( ByteString ) -import Data.Function ( on ) -import Data.List -import Data.Ord ( comparing ) -import OrdList -import qualified Data.Set as Set -import UniqSet - -{- -************************************************************************ -* * -\subsection{Find the type of a Core atom/expression} -* * -************************************************************************ --} - -exprType :: CoreExpr -> Type --- ^ Recover the type of a well-typed Core expression. Fails when --- applied to the actual 'CoreSyn.Type' expression as it cannot --- really be said to have a type -exprType (Var var) = idType var -exprType (Lit lit) = literalType lit -exprType (Coercion co) = coercionType co -exprType (Let bind body) - | NonRec tv rhs <- bind -- See Note [Type bindings] - , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) - | otherwise = exprType body -exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = pSnd (coercionKind co) -exprType (Tick _ e) = exprType e -exprType (Lam binder expr) = mkLamType binder (exprType expr) -exprType e@(App _ _) - = case collectArgs e of - (fun, args) -> applyTypeToArgs e (exprType fun) args - -exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy - -coreAltType :: CoreAlt -> Type --- ^ Returns the type of the alternatives right hand side -coreAltType alt@(_,bs,rhs) - = case occCheckExpand bs rhs_ty of - -- Note [Existential variables and silly type synonyms] - Just ty -> ty - Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) - where - rhs_ty = exprType rhs - -coreAltsType :: [CoreAlt] -> Type --- ^ Returns the type of the first alternative, which should be the same as for all alternatives -coreAltsType (alt:_) = coreAltType alt -coreAltsType [] = panic "corAltsType" - --- | Is this expression levity polymorphic? This should be the --- same as saying (isKindLevPoly . typeKind . exprType) but --- much faster. -isExprLevPoly :: CoreExpr -> Bool -isExprLevPoly = go - where - go (Var _) = False -- no levity-polymorphic binders - go (Lit _) = False -- no levity-polymorphic literals - go e@(App f _) | not (go_app f) = False - | otherwise = check_type e - go (Lam _ _) = False - go (Let _ e) = go e - go e@(Case {}) = check_type e -- checking type is fast - go e@(Cast {}) = check_type e - go (Tick _ e) = go e - go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) - go (Coercion {}) = False -- this case can happen in SetLevels - - check_type = isTypeLevPoly . exprType -- slow approach - - -- if the function is a variable (common case), check its - -- levityInfo. This might mean we don't need to look up and compute - -- on the type. Spec of these functions: return False if there is - -- no possibility, ever, of this expression becoming levity polymorphic, - -- no matter what it's applied to; return True otherwise. - -- returning True is always safe. See also Note [Levity info] in - -- IdInfo - go_app (Var id) = not (isNeverLevPolyId id) - go_app (Lit _) = False - go_app (App f _) = go_app f - go_app (Lam _ e) = go_app e - go_app (Let _ e) = go_app e - go_app (Case _ _ ty _) = resultIsLevPoly ty - go_app (Cast _ co) = resultIsLevPoly (pSnd $ coercionKind co) - go_app (Tick _ e) = go_app e - go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) - go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) - - -{- -Note [Type bindings] -~~~~~~~~~~~~~~~~~~~~ -Core does allow type bindings, although such bindings are -not much used, except in the output of the desugarer. -Example: - let a = Int in (\x:a. x) -Given this, exprType must be careful to substitute 'a' in the -result type (#8522). - -Note [Existential variables and silly type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = forall a. T (Funny a) - type Funny a = Bool - f :: T -> Bool - f (T x) = x - -Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. -That means that 'exprType' and 'coreAltsType' may give a result that *appears* -to mention an out-of-scope type variable. See #3409 for a more real-world -example. - -Various possibilities suggest themselves: - - - Ignore the problem, and make Lint not complain about such variables - - - Expand all type synonyms (or at least all those that discard arguments) - This is tricky, because at least for top-level things we want to - retain the type the user originally specified. - - - Expand synonyms on the fly, when the problem arises. That is what - we are doing here. It's not too expensive, I think. - -Note that there might be existentially quantified coercion variables, too. --} - --- Not defined with applyTypeToArg because you can't print from CoreSyn. -applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type --- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. --- The first argument is just for debugging, and gives some context -applyTypeToArgs e op_ty args - = go op_ty args - where - go op_ty [] = op_ty - go op_ty (Type ty : args) = go_ty_args op_ty [ty] args - go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args - go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty - = go res_ty args - go _ _ = pprPanic "applyTypeToArgs" panic_msg - - -- go_ty_args: accumulate type arguments so we can - -- instantiate all at once with piResultTys - go_ty_args op_ty rev_tys (Type ty : args) - = go_ty_args op_ty (ty:rev_tys) args - go_ty_args op_ty rev_tys (Coercion co : args) - = go_ty_args op_ty (mkCoercionTy co : rev_tys) args - go_ty_args op_ty rev_tys args - = go (piResultTys op_ty (reverse rev_tys)) args - - panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e - , text "Type:" <+> ppr op_ty - , text "Args:" <+> ppr args ] - - -{- -************************************************************************ -* * -\subsection{Attaching notes} -* * -************************************************************************ --} - --- | Wrap the given expression in the coercion safely, dropping --- identity coercions and coalescing nested coercions -mkCast :: CoreExpr -> CoercionR -> CoreExpr -mkCast e co - | ASSERT2( coercionRole co == Representational - , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") - <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) - isReflCo co - = e - -mkCast (Coercion e_co) co - | isCoVarType (pSnd (coercionKind co)) - -- The guard here checks that g has a (~#) on both sides, - -- otherwise decomposeCo fails. Can in principle happen - -- with unsafeCoerce - = Coercion (mkCoCast e_co co) - -mkCast (Cast expr co2) co - = WARN(let { Pair from_ty _to_ty = coercionKind co; - Pair _from_ty2 to_ty2 = coercionKind co2} in - not (from_ty `eqType` to_ty2), - vcat ([ text "expr:" <+> ppr expr - , text "co2:" <+> ppr co2 - , text "co:" <+> ppr co ]) ) - mkCast expr (mkTransCo co2 co) - -mkCast (Tick t expr) co - = Tick t (mkCast expr co) - -mkCast expr co - = let Pair from_ty _to_ty = coercionKind co in - WARN( not (from_ty `eqType` exprType expr), - text "Trying to coerce" <+> text "(" <> ppr expr - $$ text "::" <+> ppr (exprType expr) <> text ")" - $$ ppr co $$ ppr (coercionType co) ) - (Cast expr co) - --- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. -mkTick :: Tickish Id -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id id orig_expr - where - -- Some ticks (cost-centres) can be split in two, with the - -- non-counting part having laxer placement properties. - canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t - - mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) - -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) - -> CoreExpr -- ^ current expression - -> CoreExpr - mkTick' top rest expr = case expr of - - -- Cost centre ticks should never be reordered relative to each - -- other. Therefore we can stop whenever two collide. - Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr - - -- Otherwise we assume that ticks of different placements float - -- through each other. - | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e - - -- For annotations this is where we make sure to not introduce - -- redundant ticks. - | tickishContains t t2 -> mkTick' top rest e - | tickishContains t2 t -> orig_expr - | otherwise -> mkTick' top (rest . Tick t2) e - - -- Ticks don't care about types, so we just float all ticks - -- through them. Note that it's not enough to check for these - -- cases top-level. While mkTick will never produce Core with type - -- expressions below ticks, such constructs can be the result of - -- unfoldings. We therefore make an effort to put everything into - -- the right place no matter what we start with. - Cast e co -> mkTick' (top . flip Cast co) rest e - Coercion co -> Coercion co - - Lam x e - -- Always float through type lambdas. Even for non-type lambdas, - -- floating is allowed for all but the most strict placement rule. - | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> mkTick' (top . Lam x) rest e - - -- If it is both counting and scoped, we split the tick into its - -- two components, often allowing us to keep the counting tick on - -- the outside of the lambda and push the scoped tick inside. - -- The point of this is that the counting tick can probably be - -- floated, and the lambda may then be in a position to be - -- beta-reduced. - | canSplit - -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e - - App f arg - -- Always float through type applications. - | not (isRuntimeArg arg) - -> mkTick' (top . flip App arg) rest f - - -- We can also float through constructor applications, placement - -- permitting. Again we can split. - | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) - -> if tickishPlace t == PlaceCostCentre - then top $ rest $ tickHNFArgs t expr - else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr - - Var x - | notFunction && tickishPlace t == PlaceCostCentre - -> orig_expr - | notFunction && canSplit - -> top $ Tick (mkNoScope t) $ rest expr - where - -- SCCs can be eliminated on variables provided the variable - -- is not a function. In these cases the SCC makes no difference: - -- the cost of evaluating the variable will be attributed to its - -- definition site. When the variable refers to a function, however, - -- an SCC annotation on the variable affects the cost-centre stack - -- when the function is called, so we must retain those. - notFunction = not (isFunTy (idType x)) - - Lit{} - | tickishPlace t == PlaceCostCentre - -> orig_expr - - -- Catch-all: Annotate where we stand - _any -> top $ Tick t $ rest expr - -mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr -mkTicks ticks expr = foldr mkTick expr ticks - -isSaturatedConApp :: CoreExpr -> Bool -isSaturatedConApp e = go e [] - where go (App f a) as = go f (a:as) - go (Var fun) args - = isConLikeId fun && idArity fun == valArgCount args - go (Cast f _) as = go f as - go _ _ = False - -mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr -mkTickNoHNF t e - | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e - --- push a tick into the arguments of a HNF (call or constructor app) -tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr -tickHNFArgs t e = push t e - where - push t (App f (Type u)) = App (push t f) (Type u) - push t (App f arg) = App (push t f) (mkTick t arg) - push _t e = e - --- | Strip ticks satisfying a predicate from top of an expression -stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) -stripTicksTop p = go [] - where go ts (Tick t e) | p t = go (t:ts) e - go ts other = (reverse ts, other) - --- | Strip ticks satisfying a predicate from top of an expression, --- returning the remaining expression -stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b -stripTicksTopE p = go - where go (Tick t e) | p t = go e - go other = other - --- | Strip ticks satisfying a predicate from top of an expression, --- returning the ticks -stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] -stripTicksTopT p = go [] - where go ts (Tick t e) | p t = go (t:ts) e - go ts _ = ts - --- | Completely strip ticks satisfying a predicate from an --- expression. Note this is O(n) in the size of the expression! -stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b -stripTicksE p expr = go expr - where go (App e a) = App (go e) (go a) - go (Lam b e) = Lam b (go e) - go (Let b e) = Let (go_bs b) (go e) - go (Case e b t as) = Case (go e) b t (map go_a as) - go (Cast e c) = Cast (go e) c - go (Tick t e) - | p t = go e - | otherwise = Tick t (go e) - go other = other - go_bs (NonRec b e) = NonRec b (go e) - go_bs (Rec bs) = Rec (map go_b bs) - go_b (b, e) = (b, go e) - go_a (c,bs,e) = (c,bs, go e) - -stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] -stripTicksT p expr = fromOL $ go expr - where go (App e a) = go e `appOL` go a - go (Lam _ e) = go e - go (Let b e) = go_bs b `appOL` go e - go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) - go (Cast e _) = go e - go (Tick t e) - | p t = t `consOL` go e - | otherwise = go e - go _ = nilOL - go_bs (NonRec _ e) = go e - go_bs (Rec bs) = concatOL (map go_b bs) - go_b (_, e) = go e - go_a (_, _, e) = go e - -{- -************************************************************************ -* * -\subsection{Other expression construction} -* * -************************************************************************ --} - -bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr --- ^ @bindNonRec x r b@ produces either: --- --- > let x = r in b --- --- or: --- --- > case r of x { _DEFAULT_ -> b } --- --- depending on whether we have to use a @case@ or @let@ --- binding for the expression (see 'needsCaseBinding'). --- It's used by the desugarer to avoid building bindings --- that give Core Lint a heart attack, although actually --- the simplifier deals with them perfectly well. See --- also 'MkCore.mkCoreLet' -bindNonRec bndr rhs body - | isTyVar bndr = let_bind - | isCoVar bndr = if isCoArg rhs then let_bind - {- See Note [Binding coercions] -} else case_bind - | isJoinId bndr = let_bind - | needsCaseBinding (idType bndr) rhs = case_bind - | otherwise = let_bind - where - case_bind = mkDefaultCase rhs bndr body - let_bind = Let (NonRec bndr rhs) body - --- | Tests whether we have to use a @case@ rather than @let@ binding for this expression --- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant" -needsCaseBinding :: Type -> CoreExpr -> Bool -needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) - -- Make a case expression instead of a let - -- These can arise either from the desugarer, - -- or from beta reductions: (\x.e) (x +# y) - -mkAltExpr :: AltCon -- ^ Case alternative constructor - -> [CoreBndr] -- ^ Things bound by the pattern match - -> [Type] -- ^ The type arguments to the case alternative - -> CoreExpr --- ^ This guy constructs the value that the scrutinee must have --- given that you are in one particular branch of a case -mkAltExpr (DataAlt con) args inst_tys - = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) -mkAltExpr (LitAlt lit) [] [] - = Lit lit -mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" -mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" - -mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr --- Make (case x of y { DEFAULT -> e } -mkDefaultCase scrut case_bndr body - = Case scrut case_bndr (exprType body) [(DEFAULT, [], body)] - -mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr --- Use this function if possible, when building a case, --- because it ensures that the type on the Case itself --- doesn't mention variables bound by the case --- See Note [Care with the type of a case expression] -mkSingleAltCase scrut case_bndr con bndrs body - = Case scrut case_bndr case_ty [(con,bndrs,body)] - where - body_ty = exprType body - - case_ty -- See Note [Care with the type of a case expression] - | Just body_ty' <- occCheckExpand bndrs body_ty - = body_ty' - - | otherwise - = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) - -{- Note [Care with the type of a case expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a phantom type synonym - type S a = Int -and we want to form the case expression - case x of K (a::*) -> (e :: S a) - -We must not make the type field of the case-expression (S a) because -'a' isn't in scope. Hence the call to occCheckExpand. This caused -issue #17056. - -NB: this situation can only arise with type synonyms, which can -falsely "mention" type variables that aren't "really there", and which -can be eliminated by expanding the synonym. - -Note [Binding coercions] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider binding a CoVar, c = e. Then, we must atisfy -Note [CoreSyn type and coercion invariant] in CoreSyn, -which allows only (Coercion co) on the RHS. - -************************************************************************ -* * - Operations oer case alternatives -* * -************************************************************************ - -The default alternative must be first, if it exists at all. -This makes it easy to find, though it makes matching marginally harder. --} - --- | Extract the default case alternative -findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) -findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) -findDefault alts = (alts, Nothing) - -addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)] -addDefault alts Nothing = alts -addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts - -isDefaultAlt :: (AltCon, a, b) -> Bool -isDefaultAlt (DEFAULT, _, _) = True -isDefaultAlt _ = False - --- | Find the case alternative corresponding to a particular --- constructor: panics if no such constructor exists -findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) - -- A "Nothing" result *is* legitimate - -- See Note [Unreachable code] -findAlt con alts - = case alts of - (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) - _ -> go alts Nothing - where - go [] deflt = deflt - go (alt@(con1,_,_) : alts) deflt - = case con `cmpAltCon` con1 of - LT -> deflt -- Missed it already; the alts are in increasing order - EQ -> Just alt - GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt - -{- Note [Unreachable code] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible (although unusual) for GHC to find a case expression -that cannot match. For example: - - data Col = Red | Green | Blue - x = Red - f v = case x of - Red -> ... - _ -> ...(case x of { Green -> e1; Blue -> e2 })... - -Suppose that for some silly reason, x isn't substituted in the case -expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff -gets in the way; cf #3118.) Then the full-lazines pass might produce -this - - x = Red - lvl = case x of { Green -> e1; Blue -> e2 }) - f v = case x of - Red -> ... - _ -> ...lvl... - -Now if x gets inlined, we won't be able to find a matching alternative -for 'Red'. That's because 'lvl' is unreachable. So rather than crashing -we generate (error "Inaccessible alternative"). - -Similar things can happen (augmented by GADTs) when the Simplifier -filters down the matching alternatives in Simplify.rebuildCase. --} - ---------------------------------- -mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] --- ^ Merge alternatives preserving order; alternatives in --- the first argument shadow ones in the second -mergeAlts [] as2 = as2 -mergeAlts as1 [] = as1 -mergeAlts (a1:as1) (a2:as2) - = case a1 `cmpAlt` a2 of - LT -> a1 : mergeAlts as1 (a2:as2) - EQ -> a1 : mergeAlts as1 as2 -- Discard a2 - GT -> a2 : mergeAlts (a1:as1) as2 - - ---------------------------------- -trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] --- ^ Given: --- --- > case (C a b x y) of --- > C b x y -> ... --- --- We want to drop the leading type argument of the scrutinee --- leaving the arguments to match against the pattern - -trimConArgs DEFAULT args = ASSERT( null args ) [] -trimConArgs (LitAlt _) args = ASSERT( null args ) [] -trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args - -filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) - -> [Type] -- ^ And its type arguments - -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee - -> [(AltCon, [Var], a)] -- ^ Alternatives - -> ([AltCon], [(AltCon, [Var], a)]) - -- Returns: - -- 1. Constructors that will never be encountered by the - -- *default* case (if any). A superset of imposs_cons - -- 2. The new alternatives, trimmed by - -- a) remove imposs_cons - -- b) remove constructors which can't match because of GADTs - -- - -- NB: the final list of alternatives may be empty: - -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, or if the imposs_cons covers all constructors (after taking - -- account of GADTs), then no alternatives can match. - -- - -- If callers need to preserve the invariant that there is always at least one branch - -- in a "case" statement then they will need to manually add a dummy case branch that just - -- calls "error" or similar. -filterAlts _tycon inst_tys imposs_cons alts - = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) - where - (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | (con,_,_) <- alts_wo_default] - - trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default - - imposs_cons_set = Set.fromList imposs_cons - imposs_deflt_cons = - imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons - -- "imposs_deflt_cons" are handled - -- EITHER by the context, - -- OR by a non-DEFAULT branch in this case expression. - - impossible_alt :: [Type] -> (AltCon, a, b) -> Bool - impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True - impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con - impossible_alt _ _ = False - --- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. --- See Note [Refine Default Alts] -refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders - -> TyCon -- ^ Type constructor of scrutinee's type - -> [Type] -- ^ Type arguments of scrutinee's type - -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) - -> [CoreAlt] - -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' -refineDefaultAlt us tycon tys imposs_deflt_cons all_alts - | (DEFAULT,_,rhs) : rest_alts <- all_alts - , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. - , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: - -- case x of { DEFAULT -> e } - -- and we don't want to fill in a default for them! - , Just all_cons <- tyConDataCons_maybe tycon - , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] - -- We now know it's a data type, so we can use - -- UniqSet rather than Set (more efficient) - impossible con = con `elementOfUniqSet` imposs_data_cons - || dataConCannotMatch tys con - = case filterOut impossible all_cons of - -- Eliminate the default alternative - -- altogether if it can't match: - [] -> (False, rest_alts) - - -- It matches exactly one constructor, so fill it in: - [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) - -- We need the mergeAlts to keep the alternatives in the right order - where - (ex_tvs, arg_ids) = dataConRepInstPat us con tys - - -- It matches more than one, so do nothing - _ -> (False, all_alts) - - | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) - , not (isFamilyTyCon tycon || isAbstractTyCon tycon) - -- Check for no data constructors - -- This can legitimately happen for abstract types and type families, - -- so don't report that - = (False, all_alts) - - | otherwise -- The common case - = (False, all_alts) - -{- Note [Refine Default Alts] - -refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one -possible value it could be. - -The simplest example being - -foo :: () -> () -foo x = case x of !_ -> () - -rewrites to - -foo :: () -> () -foo x = case x of () -> () - -There are two reasons in general why this is desirable. - -1. We can simplify inner expressions - -In this example we can eliminate the inner case by refining the outer case. -If we don't refine it, we are left with both case expressions. - -``` -{-# LANGUAGE BangPatterns #-} -module Test where - -mid x = x -{-# NOINLINE mid #-} - -data Foo = Foo1 () - -test :: Foo -> () -test x = - case x of - !_ -> mid (case x of - Foo1 x1 -> x1) - -``` - -refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x -becomes bound to `Foo ip1` so is inlined into the other case which -causes the KnownBranch optimisation to kick in. - - -2. combineIdenticalAlts does a better job - -Simon Jakobi also points out that that combineIdenticalAlts will do a better job -if we refine the DEFAULT first. - -``` -data D = C0 | C1 | C2 - -case e of - DEFAULT -> e0 - C0 -> e1 - C1 -> e1 -``` - -When we apply combineIdenticalAlts to this expression, it can't -combine the alts for C0 and C1, as we already have a default case. - -If we apply refineDefaultAlt first, we get - -``` -case e of - C0 -> e1 - C1 -> e1 - C2 -> e0 -``` - -and combineIdenticalAlts can turn that into - -``` -case e of - DEFAULT -> e1 - C2 -> e0 -``` - -It isn't obvious that refineDefaultAlt does this but if you look at its one -call site in SimplUtils then the `imposs_deflt_cons` argument is populated with -constructors which are matched elsewhere. - --} - - - - -{- Note [Combine identical alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If several alternatives are identical, merge them into a single -DEFAULT alternative. I've occasionally seen this making a big -difference: - - case e of =====> case e of - C _ -> f x D v -> ....v.... - D v -> ....v.... DEFAULT -> f x - DEFAULT -> f x - -The point is that we merge common RHSs, at least for the DEFAULT case. -[One could do something more elaborate but I've never seen it needed.] -To avoid an expensive test, we just merge branches equal to the *first* -alternative; this picks up the common cases - a) all branches equal - b) some branches equal to the DEFAULT (which occurs first) - -The case where Combine Identical Alternatives transformation showed up -was like this (base/Foreign/C/Err/Error.hs): - - x | p `is` 1 -> e1 - | p `is` 2 -> e2 - ...etc... - -where @is@ was something like - - p `is` n = p /= (-1) && p == n - -This gave rise to a horrible sequence of cases - - case p of - (-1) -> $j p - 1 -> e1 - DEFAULT -> $j p - -and similarly in cascade for all the join points! - -NB: it's important that all this is done in [InAlt], *before* we work -on the alternatives themselves, because Simplify.simplAlt may zap the -occurrence info on the binders in the alternatives, which in turn -defeats combineIdenticalAlts (see #7360). - -Note [Care with impossible-constructors when combining alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (#10538) - data T = A | B | C | D - - case x::T of (Imposs-default-cons {A,B}) - DEFAULT -> e1 - A -> e2 - B -> e1 - -When calling combineIdentialAlts, we'll have computed that the -"impossible constructors" for the DEFAULT alt is {A,B}, since if x is -A or B we'll take the other alternatives. But suppose we combine B -into the DEFAULT, to get - - case x::T of (Imposs-default-cons {A}) - DEFAULT -> e1 - A -> e2 - -Then we must be careful to trim the impossible constructors to just {A}, -else we risk compiling 'e1' wrong! - -Not only that, but we take care when there is no DEFAULT beforehand, -because we are introducing one. Consider - - case x of (Imposs-default-cons {A,B,C}) - A -> e1 - B -> e2 - C -> e1 - -Then when combining the A and C alternatives we get - - case x of (Imposs-default-cons {B}) - DEFAULT -> e1 - B -> e2 - -Note that we have a new DEFAULT branch that we didn't have before. So -we need delete from the "impossible-default-constructors" all the -known-con alternatives that we have eliminated. (In #11172 we -missed the first one.) - --} - -combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT - -> [CoreAlt] - -> (Bool, -- True <=> something happened - [AltCon], -- New constructors that cannot match DEFAULT - [CoreAlt]) -- New alternatives --- See Note [Combine identical alternatives] --- True <=> we did some combining, result is a single DEFAULT alternative -combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) - | all isDeadBinder bndrs1 -- Remember the default - , not (null elim_rest) -- alternative comes first - = (True, imposs_deflt_cons', deflt_alt : filtered_rest) - where - (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts - deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) - - -- See Note [Care with impossible-constructors when combining alternatives] - imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons - elim_cons = elim_con1 ++ map fstOf3 elim_rest - elim_con1 = case con1 of -- Don't forget con1! - DEFAULT -> [] -- See Note [ - _ -> [con1] - - cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 - identical_to_alt1 (_con,bndrs,rhs) - = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 - tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest - -combineIdenticalAlts imposs_cons alts - = (False, imposs_cons, alts) - -{- ********************************************************************* -* * - exprIsTrivial -* * -************************************************************************ - -Note [exprIsTrivial] -~~~~~~~~~~~~~~~~~~~~ -@exprIsTrivial@ is true of expressions we are unconditionally happy to - duplicate; simple variables and constants, and type - applications. Note that primop Ids aren't considered - trivial unless - -Note [Variables are trivial] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There used to be a gruesome test for (hasNoBinding v) in the -Var case: - exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 -The idea here is that a constructor worker, like \$wJust, is -really short for (\x -> \$wJust x), because \$wJust has no binding. -So it should be treated like a lambda. Ditto unsaturated primops. -But now constructor workers are not "have-no-binding" Ids. And -completely un-applied primops and foreign-call Ids are sufficiently -rare that I plan to allow them to be duplicated and put up with -saturating them. - -Note [Tick trivial] -~~~~~~~~~~~~~~~~~~~ -Ticks are only trivial if they are pure annotations. If we treat -"tick x" as trivial, it will be inlined inside lambdas and the -entry count will be skewed, for example. Furthermore "scc x" will -turn into just "x" in mkTick. - -Note [Empty case is trivial] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expression (case (x::Int) Bool of {}) is just a type-changing -case used when we are sure that 'x' will not return. See -Note [Empty case alternatives] in CoreSyn. - -If the scrutinee is trivial, then so is the whole expression; and the -CoreToSTG pass in fact drops the case expression leaving only the -scrutinee. - -Having more trivial expressions is good. Moreover, if we don't treat -it as trivial we may land up with let-bindings like - let v = case x of {} in ... -and after CoreToSTG that gives - let v = x in ... -and that confuses the code generator (#11155). So best to kill -it off at source. --} - -exprIsTrivial :: CoreExpr -> Bool --- If you modify this function, you may also --- need to modify getIdFromTrivialExpr -exprIsTrivial (Var _) = True -- See Note [Variables are trivial] -exprIsTrivial (Type _) = True -exprIsTrivial (Coercion _) = True -exprIsTrivial (Lit lit) = litIsTrivial lit -exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e -exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e -exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e - -- See Note [Tick trivial] -exprIsTrivial (Cast e _) = exprIsTrivial e -exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] -exprIsTrivial _ = False - -{- -Note [getIdFromTrivialExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When substituting in a breakpoint we need to strip away the type cruft -from a trivial expression and get back to the Id. The invariant is -that the expression we're substituting was originally trivial -according to exprIsTrivial, AND the expression is not a literal. -See Note [substTickish] for how breakpoint substitution preserves -this extra invariant. - -We also need this functionality in CorePrep to extract out Id of a -function which we are saturating. However, in this case we don't know -if the variable actually refers to a literal; thus we use -'getIdFromTrivialExpr_maybe' to handle this case. See test -T12076lit for an example where this matters. --} - -getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id -getIdFromTrivialExpr e - = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) - (getIdFromTrivialExpr_maybe e) - -getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id --- See Note [getIdFromTrivialExpr] --- Th equations for this should line up with those for exprIsTrivial -getIdFromTrivialExpr_maybe e - = go e - where - go (App f t) | not (isRuntimeArg t) = go f - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e _) = go e - go (Lam b e) | not (isRuntimeVar b) = go e - go (Case e _ _ []) = go e - go (Var v) = Just v - go _ = Nothing - -{- -exprIsBottom is a very cheap and cheerful function; it may return -False for bottoming expressions, but it never costs much to ask. See -also CoreArity.exprBotStrictness_maybe, but that's a bit more -expensive. --} - -exprIsBottom :: CoreExpr -> Bool --- See Note [Bottoming expressions] -exprIsBottom e - | isEmptyTy (exprType e) - = True - | otherwise - = go 0 e - where - go n (Var v) = isBottomingId v && n >= idArity v - go n (App e a) | isTypeArg a = go n e - | otherwise = go (n+1) e - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (Let _ e) = go n e - go n (Lam v e) | isTyVar v = go n e - go _ (Case _ _ _ alts) = null alts - -- See Note [Empty case alternatives] in CoreSyn - go _ _ = False - -{- Note [Bottoming expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A bottoming expression is guaranteed to diverge, or raise an -exception. We can test for it in two different ways, and exprIsBottom -checks for both of these situations: - -* Visibly-bottom computations. For example - (error Int "Hello") - is visibly bottom. The strictness analyser also finds out if - a function diverges or raises an exception, and puts that info - in its strictness signature. - -* Empty types. If a type is empty, its only inhabitant is bottom. - For example: - data T - f :: T -> Bool - f = \(x:t). case x of Bool {} - Since T has no data constructors, the case alternatives are of course - empty. However note that 'x' is not bound to a visibly-bottom value; - it's the *type* that tells us it's going to diverge. - -A GADT may also be empty even though it has constructors: - data T a where - T1 :: a -> T Bool - T2 :: T Int - ...(case (x::T Char) of {})... -Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), -which is likewise uninhabited. - - -************************************************************************ -* * - exprIsDupable -* * -************************************************************************ - -Note [exprIsDupable] -~~~~~~~~~~~~~~~~~~~~ -@exprIsDupable@ is true of expressions that can be duplicated at a modest - cost in code size. This will only happen in different case - branches, so there's no issue about duplicating work. - - That is, exprIsDupable returns True of (f x) even if - f is very very expensive to call. - - Its only purpose is to avoid fruitless let-binding - and then inlining of case join points --} - -exprIsDupable :: DynFlags -> CoreExpr -> Bool -exprIsDupable dflags e - = isJust (go dupAppSize e) - where - go :: Int -> CoreExpr -> Maybe Int - go n (Type {}) = Just n - go n (Coercion {}) = Just n - go n (Var {}) = decrement n - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (App f a) | Just n' <- go n a = go n' f - go n (Lit lit) | litIsDupable dflags lit = decrement n - go _ _ = Nothing - - decrement :: Int -> Maybe Int - decrement 0 = Nothing - decrement n = Just (n-1) - -dupAppSize :: Int -dupAppSize = 8 -- Size of term we are prepared to duplicate - -- This is *just* big enough to make test MethSharing - -- inline enough join points. Really it should be - -- smaller, and could be if we fixed #4960. - -{- -************************************************************************ -* * - exprIsCheap, exprIsExpandable -* * -************************************************************************ - -Note [exprIsWorkFree] -~~~~~~~~~~~~~~~~~~~~~ -exprIsWorkFree is used when deciding whether to inline something; we -don't inline it if doing so might duplicate work, by peeling off a -complete copy of the expression. Here we do not want even to -duplicate a primop (#5623): - eg let x = a #+ b in x +# x - we do not want to inline/duplicate x - -Previously we were a bit more liberal, which led to the primop-duplicating -problem. However, being more conservative did lead to a big regression in -one nofib benchmark, wheel-sieve1. The situation looks like this: - - let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool - noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> - case GHC.Prim.<=# x_aRs 2 of _ { - GHC.Types.False -> notDivBy ps_adM qs_adN; - GHC.Types.True -> lvl_r2Eb }} - go = \x. ...(noFactor (I# y))....(go x')... - -The function 'noFactor' is heap-allocated and then called. Turns out -that 'notDivBy' is strict in its THIRD arg, but that is invisible to -the caller of noFactor, which therefore cannot do w/w and -heap-allocates noFactor's argument. At the moment (May 12) we are just -going to put up with this, because the previous more aggressive inlining -(which treated 'noFactor' as work-free) was duplicating primops, which -in turn was making inner loops of array calculations runs slow (#5623) - -Note [Case expressions are work-free] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Are case-expressions work-free? Consider - let v = case x of (p,q) -> p - go = \y -> ...case v of ... -Should we inline 'v' at its use site inside the loop? At the moment -we do. I experimented with saying that case are *not* work-free, but -that increased allocation slightly. It's a fairly small effect, and at -the moment we go for the slightly more aggressive version which treats -(case x of ....) as work-free if the alternatives are. - -Moreover it improves arities of overloaded functions where -there is only dictionary selection (no construction) involved - -Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] -~~~~~~~~~~~~~~~~~~ in CoreUnfold.hs -@exprIsCheap@ looks at a Core expression and returns \tr{True} if -it is obviously in weak head normal form, or is cheap to get to WHNF. -[Note that that's not the same as exprIsDupable; an expression might be -big, and hence not dupable, but still cheap.] - -By ``cheap'' we mean a computation we're willing to: - push inside a lambda, or - inline at more than one place -That might mean it gets evaluated more than once, instead of being -shared. The main examples of things which aren't WHNF but are -``cheap'' are: - - * case e of - pi -> ei - (where e, and all the ei are cheap) - - * let x = e in b - (where e and b are cheap) - - * op x1 ... xn - (where op is a cheap primitive operator) - - * error "foo" - (because we are happy to substitute it inside a lambda) - -Notice that a variable is considered 'cheap': we can push it inside a lambda, -because sharing will make sure it is only evaluated once. - -Note [exprIsCheap and exprIsHNF] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that exprIsHNF does not imply exprIsCheap. Eg - let x = fac 20 in Just x -This responds True to exprIsHNF (you can discard a seq), but -False to exprIsCheap. - -Note [Arguments and let-bindings exprIsCheapX] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What predicate should we apply to the argument of an application, or the -RHS of a let-binding? - -We used to say "exprIsTrivial arg" due to concerns about duplicating -nested constructor applications, but see #4978. So now we just recursively -use exprIsCheapX. - -We definitely want to treat let and app the same. The principle here is -that - let x = blah in f x -should behave equivalently to - f blah - -This in turn means that the 'letrec g' does not prevent eta expansion -in this (which it previously was): - f = \x. let v = case x of - True -> letrec g = \w. blah - in g - False -> \x. x - in \w. v True --} - --------------------- -exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] -exprIsWorkFree = exprIsCheapX isWorkFreeApp - -exprIsCheap :: CoreExpr -> Bool -exprIsCheap = exprIsCheapX isCheapApp - -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool -exprIsCheapX ok_app e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = ok_app v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Case scrut _ _ alts) = ok scrut && - and [ go n rhs | (_,_,rhs) <- alts ] - go n (Tick t e) | tickishCounts t = False - | otherwise = go n e - go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e - | otherwise = go n e - go n (App f e) | isRuntimeArg e = go (n+1) f && ok e - | otherwise = go n f - go n (Let (NonRec _ r) e) = go n e && ok r - go n (Let (Rec prs) e) = go n e && all (ok . snd) prs - - -- Case: see Note [Case expressions are work-free] - -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] - - -{- Note [exprIsExpandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -An expression is "expandable" if we are willing to duplicate it, if doing -so might make a RULE or case-of-constructor fire. Consider - let x = (a,b) - y = build g - in ....(case x of (p,q) -> rhs)....(foldr k z y).... - -We don't inline 'x' or 'y' (see Note [Lone variables] in CoreUnfold), -but we do want - - * the case-expression to simplify - (via exprIsConApp_maybe, exprIsLiteral_maybe) - - * the foldr/build RULE to fire - (by expanding the unfolding during rule matching) - -So we classify the unfolding of a let-binding as "expandable" (via the -uf_expandable field) if we want to do this kind of on-the-fly -expansion. Specifically: - -* True of constructor applications (K a b) - -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes. - (NB: exprIsCheap might not be true of this) - -* False of case-expressions. If we have - let x = case ... in ...(case x of ...)... - we won't simplify. We have to inline x. See #14688. - -* False of let-expressions (same reason); and in any case we - float lets out of an RHS if doing so will reveal an expandable - application (see SimplEnv.doFloatFromRhs). - -* Take care: exprIsExpandable should /not/ be true of primops. I - found this in test T5623a: - let q = /\a. Ptr a (a +# b) - in case q @ Float of Ptr v -> ...q... - - q's inlining should not be expandable, else exprIsConApp_maybe will - say that (q @ Float) expands to (Ptr a (a +# b)), and that will - duplicate the (a +# b) primop, which we should not do lightly. - (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) --} - -------------------------------------- -exprIsExpandable :: CoreExpr -> Bool --- See Note [exprIsExpandable] -exprIsExpandable e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = isExpandableApp v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Tick t e) | tickishCounts t = False - | otherwise = go n e - go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e - | otherwise = go n e - go n (App f e) | isRuntimeArg e = go (n+1) f && ok e - | otherwise = go n f - go _ (Case {}) = False - go _ (Let {}) = False - - -------------------------------------- -type CheapAppFun = Id -> Arity -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? - -- True mainly of data constructors, partial applications; - -- but with minor variations: - -- isWorkFreeApp - -- isCheapApp - -- isExpandableApp - -isWorkFreeApp :: CheapAppFun -isWorkFreeApp fn n_val_args - | n_val_args == 0 -- No value args - = True - | n_val_args < idArity fn -- Partial application - = True - | otherwise - = case idDetails fn of - DataConWorkId {} -> True - _ -> False - -isCheapApp :: CheapAppFun -isCheapApp fn n_val_args - | isWorkFreeApp fn n_val_args = True - | isBottomingId fn = True -- See Note [isCheapApp: bottoming functions] - | otherwise - = case idDetails fn of - DataConWorkId {} -> True -- Actually handled by isWorkFreeApp - RecSelId {} -> n_val_args == 1 -- See Note [Record selection] - ClassOpId {} -> n_val_args == 1 - PrimOpId op -> primOpIsCheap op - _ -> False - -- In principle we should worry about primops - -- that return a type variable, since the result - -- might be applied to something, but I'm not going - -- to bother to check the number of args - -isExpandableApp :: CheapAppFun -isExpandableApp fn n_val_args - | isWorkFreeApp fn n_val_args = True - | otherwise - = case idDetails fn of - DataConWorkId {} -> True -- Actually handled by isWorkFreeApp - RecSelId {} -> n_val_args == 1 -- See Note [Record selection] - ClassOpId {} -> n_val_args == 1 - PrimOpId {} -> False - _ | isBottomingId fn -> False - -- See Note [isExpandableApp: bottoming functions] - | isConLike (idRuleMatchInfo fn) -> True - | all_args_are_preds -> True - | otherwise -> False - - where - -- See if all the arguments are PredTys (implicit params or classes) - -- If so we'll regard it as expandable; see Note [Expandable overloadings] - all_args_are_preds = all_pred_args n_val_args (idType fn) - - all_pred_args n_val_args ty - | n_val_args == 0 - = True - - | Just (bndr, ty) <- splitPiTy_maybe ty - = case bndr of - Named {} -> all_pred_args n_val_args ty - Anon InvisArg _ -> all_pred_args (n_val_args-1) ty - Anon VisArg _ -> False - - | otherwise - = False - -{- Note [isCheapApp: bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I'm not sure why we have a special case for bottoming -functions in isCheapApp. Maybe we don't need it. - -Note [isExpandableApp: bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important that isExpandableApp does not respond True to bottoming -functions. Recall undefined :: HasCallStack => a -Suppose isExpandableApp responded True to (undefined d), and we had: - - x = undefined - -Then Simplify.prepareRhs would ANF the RHS: - - d = - x = undefined d - -This is already bad: we gain nothing from having x bound to (undefined -var), unlike the case for data constructors. Worse, we get the -simplifier loop described in OccurAnal Note [Cascading inlines]. -Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will -certainly_inline; so we end up inlining d right back into x; but in -the end x doesn't inline because it is bottom (preInlineUnconditionally); -so the process repeats.. We could elaborate the certainly_inline logic -some more, but it's better just to treat bottoming bindings as -non-expandable, because ANFing them is a bad idea in the first place. - -Note [Record selection] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -I'm experimenting with making record selection -look cheap, so we will substitute it inside a -lambda. Particularly for dictionary field selection. - -BUT: Take care with (sel d x)! The (sel d) might be cheap, but -there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) - -Note [Expandable overloadings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose the user wrote this - {-# RULE forall x. foo (negate x) = h x #-} - f x = ....(foo (negate x)).... -He'd expect the rule to fire. But since negate is overloaded, we might -get this: - f = \d -> let n = negate d in \x -> ...foo (n x)... -So we treat the application of a function (negate in this case) to a -*dictionary* as expandable. In effect, every function is CONLIKE when -it's applied only to dictionaries. - - -************************************************************************ -* * - exprOkForSpeculation -* * -************************************************************************ --} - ------------------------------ --- | 'exprOkForSpeculation' returns True of an expression that is: --- --- * Safe to evaluate even if normal order eval might not --- evaluate the expression at all, or --- --- * Safe /not/ to evaluate even if normal order would do so --- --- It is usually called on arguments of unlifted type, but not always --- In particular, Simplify.rebuildCase calls it on lifted types --- when a 'case' is a plain 'seq'. See the example in --- Note [exprOkForSpeculation: case expressions] below --- --- Precisely, it returns @True@ iff: --- a) The expression guarantees to terminate, --- b) soon, --- c) without causing a write side effect (e.g. writing a mutable variable) --- d) without throwing a Haskell exception --- e) without risking an unchecked runtime exception (array out of bounds, --- divide by zero) --- --- For @exprOkForSideEffects@ the list is the same, but omitting (e). --- --- Note that --- exprIsHNF implies exprOkForSpeculation --- exprOkForSpeculation implies exprOkForSideEffects --- --- See Note [PrimOp can_fail and has_side_effects] in PrimOp --- and Note [Transformations affected by can_fail and has_side_effects] --- --- As an example of the considerations in this test, consider: --- --- > let x = case y# +# 1# of { r# -> I# r# } --- > in E --- --- being translated to: --- --- > case y# +# 1# of { r# -> --- > let x = I# r# --- > in E --- > } --- --- We can only do this if the @y + 1@ is ok for speculation: it has no --- side effects, and can't diverge or raise an exception. - -exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool -exprOkForSpeculation = expr_ok primOpOkForSpeculation -exprOkForSideEffects = expr_ok primOpOkForSideEffects - -expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool -expr_ok _ (Lit _) = True -expr_ok _ (Type _) = True -expr_ok _ (Coercion _) = True - -expr_ok primop_ok (Var v) = app_ok primop_ok v [] -expr_ok primop_ok (Cast e _) = expr_ok primop_ok e -expr_ok primop_ok (Lam b e) - | isTyVar b = expr_ok primop_ok e - | otherwise = True - --- Tick annotations that *tick* cannot be speculated, because these --- are meant to identify whether or not (and how often) the particular --- source expression was evaluated at runtime. -expr_ok primop_ok (Tick tickish e) - | tickishCounts tickish = False - | otherwise = expr_ok primop_ok e - -expr_ok _ (Let {}) = False - -- Lets can be stacked deeply, so just give up. - -- In any case, the argument of exprOkForSpeculation is - -- usually in a strict context, so any lets will have been - -- floated away. - -expr_ok primop_ok (Case scrut bndr _ alts) - = -- See Note [exprOkForSpeculation: case expressions] - expr_ok primop_ok scrut - && isUnliftedType (idType bndr) - && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts - && altsAreExhaustive alts - -expr_ok primop_ok other_expr - | (expr, args) <- collectArgs other_expr - = case stripTicksTopE (not . tickishCounts) expr of - Var f -> app_ok primop_ok f args - -- 'LitRubbish' is the only literal that can occur in the head of an - -- application and will not be matched by the above case (Var /= Lit). - Lit lit -> ASSERT( lit == rubbishLit ) True - _ -> False - ------------------------------ -app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool -app_ok primop_ok fun args - = case idDetails fun of - DFunId new_type -> not new_type - -- DFuns terminate, unless the dict is implemented - -- with a newtype in which case they may not - - DataConWorkId {} -> True - -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account - - PrimOpId op - | isDivOp op - , [arg1, Lit lit] <- args - -> not (isZeroLit lit) && expr_ok primop_ok arg1 - -- Special case for dividing operations that fail - -- In general they are NOT ok-for-speculation - -- (which primop_ok will catch), but they ARE OK - -- if the divisor is definitely non-zero. - -- Often there is a literal divisor, and this - -- can get rid of a thunk in an inner loop - - | SeqOp <- op -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp] - -> False -- for the special cases for SeqOp and DataToTagOp - | DataToTagOp <- op - -> False - - | otherwise - -> primop_ok op -- Check the primop itself - && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments - - _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF - || idArity fun > n_val_args -- Partial apps - -- NB: even in the nullary case, do /not/ check - -- for evaluated-ness of the fun; - -- see Note [exprOkForSpeculation and evaluated variables] - where - n_val_args = valArgCount args - where - (arg_tys, _) = splitPiTys (idType fun) - - primop_arg_ok :: TyBinder -> CoreExpr -> Bool - primop_arg_ok (Named _) _ = True -- A type argument - primop_arg_ok (Anon _ ty) arg -- A term argument - | isUnliftedType ty = expr_ok primop_ok arg - | otherwise = True -- See Note [Primops with lifted arguments] - ------------------------------ -altsAreExhaustive :: [Alt b] -> Bool --- True <=> the case alternatives are definiely exhaustive --- False <=> they may or may not be -altsAreExhaustive [] - = False -- Should not happen -altsAreExhaustive ((con1,_,_) : alts) - = case con1 of - DEFAULT -> True - LitAlt {} -> False - DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) - -- It is possible to have an exhaustive case that does not - -- enumerate all constructors, notably in a GADT match, but - -- we behave conservatively here -- I don't think it's important - -- enough to deserve special treatment - --- | True of dyadic operators that can fail only if the second arg is zero! -isDivOp :: PrimOp -> Bool --- This function probably belongs in PrimOp, or even in --- an automagically generated file.. but it's such a --- special case I thought I'd leave it here for now. -isDivOp IntQuotOp = True -isDivOp IntRemOp = True -isDivOp WordQuotOp = True -isDivOp WordRemOp = True -isDivOp FloatDivOp = True -isDivOp DoubleDivOp = True -isDivOp _ = False - -{- Note [exprOkForSpeculation: case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprOkForSpeculation accepts very special case expressions. -Reason: (a ==# b) is ok-for-speculation, but the litEq rules -in PrelRules convert it (a ==# 3#) to - case a of { DEFAULT -> 0#; 3# -> 1# } -for excellent reasons described in - PrelRules Note [The litEq rule: converting equality to case]. -So, annoyingly, we want that case expression to be -ok-for-speculation too. Bother. - -But we restrict it sharply: - -* We restrict it to unlifted scrutinees. Consider this: - case x of y { - DEFAULT -> ... (let v::Int# = case y of { True -> e1 - ; False -> e2 } - in ...) ... - - Does the RHS of v satisfy the let/app invariant? Previously we said - yes, on the grounds that y is evaluated. But the binder-swap done - by SetLevels would transform the inner alternative to - DEFAULT -> ... (let v::Int# = case x of { ... } - in ...) .... - which does /not/ satisfy the let/app invariant, because x is - not evaluated. See Note [Binder-swap during float-out] - in SetLevels. To avoid this awkwardness it seems simpler - to stick to unlifted scrutinees where the issue does not - arise. - -* We restrict it to exhaustive alternatives. A non-exhaustive - case manifestly isn't ok-for-speculation. for example, - this is a valid program (albeit a slightly dodgy one) - let v = case x of { B -> ...; C -> ... } - in case x of - A -> ... - _ -> ...v...v.... - Should v be considered ok-for-speculation? Its scrutinee may be - evaluated, but the alternatives are incomplete so we should not - evaluate it strictly. - - Now, all this is for lifted types, but it'd be the same for any - finite unlifted type. We don't have many of them, but we might - add unlifted algebraic types in due course. - - ------ Historical note: #15696: -------- - Previously SetLevels used exprOkForSpeculation to guide - floating of single-alternative cases; it now uses exprIsHNF - Note [Floating single-alternative cases]. - - But in those days, consider - case e of x { DEAFULT -> - ...(case x of y - A -> ... - _ -> ...(case (case x of { B -> p; C -> p }) of - I# r -> blah)... - If SetLevels considers the inner nested case as - ok-for-speculation it can do case-floating (in SetLevels). - So we'd float to: - case e of x { DEAFULT -> - case (case x of { B -> p; C -> p }) of I# r -> - ...(case x of y - A -> ... - _ -> ...blah...)... - which is utterly bogus (seg fault); see #5453. - ------ Historical note: #3717: -------- - foo :: Int -> Int - foo 0 = 0 - foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) - -In earlier GHCs, we got this: - T.$wfoo = - \ (ww :: GHC.Prim.Int#) -> - case ww of ds { - __DEFAULT -> case (case <# ds 5 of _ { - GHC.Types.False -> lvl1; - GHC.Types.True -> lvl}) - of _ { __DEFAULT -> - T.$wfoo (GHC.Prim.-# ds_XkE 1) }; - 0 -> 0 } - -Before join-points etc we could only get rid of two cases (which are -redundant) by recognising that the (case <# ds 5 of { ... }) is -ok-for-speculation, even though it has /lifted/ type. But now join -points do the job nicely. -------- End of historical note ------------ - - -Note [Primops with lifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is this ok-for-speculation (see #13027)? - reallyUnsafePtrEq# a b -Well, yes. The primop accepts lifted arguments and does not -evaluate them. Indeed, in general primops are, well, primitive -and do not perform evaluation. - -Bottom line: - * In exprOkForSpeculation we simply ignore all lifted arguments. - * In the rare case of primops that /do/ evaluate their arguments, - (namely DataToTagOp and SeqOp) return False; see - Note [exprOkForSpeculation and evaluated variables] - -Note [exprOkForSpeculation and SeqOp/DataToTagOp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most primops with lifted arguments don't evaluate them -(see Note [Primops with lifted arguments]), so we can ignore -that argument entirely when doing exprOkForSpeculation. - -But DataToTagOp and SeqOp are exceptions to that rule. -For reasons described in Note [exprOkForSpeculation and -evaluated variables], we simply return False for them. - -Not doing this made #5129 go bad. -Lots of discussion in #15696. - -Note [exprOkForSpeculation and evaluated variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that - seq# :: forall a s. a -> State# s -> (# State# s, a #) - dataToTag# :: forall a. a -> Int# -must always evaluate their first argument. - -Now consider these examples: - * case x of y { DEFAULT -> ....y.... } - Should 'y' (alone) be considered ok-for-speculation? - - * case x of y { DEFAULT -> ....f (dataToTag# y)... } - Should (dataToTag# y) be considered ok-for-spec? - -You could argue 'yes', because in the case alternative we know that -'y' is evaluated. But the binder-swap transformation, which is -extremely useful for float-out, changes these expressions to - case x of y { DEFAULT -> ....x.... } - case x of y { DEFAULT -> ....f (dataToTag# x)... } - -And now the expression does not obey the let/app invariant! Yikes! -Moreover we really might float (f (dataToTag# x)) outside the case, -and then it really, really doesn't obey the let/app invariant. - -The solution is simple: exprOkForSpeculation does not try to take -advantage of the evaluated-ness of (lifted) variables. And it returns -False (always) for DataToTagOp and SeqOp. - -Note that exprIsHNF /can/ and does take advantage of evaluated-ness; -it doesn't have the trickiness of the let/app invariant to worry about. - -************************************************************************ -* * - exprIsHNF, exprIsConLike -* * -************************************************************************ --} - --- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] --- ~~~~~~~~~~~~~~~~ --- | exprIsHNF returns true for expressions that are certainly /already/ --- evaluated to /head/ normal form. This is used to decide whether it's ok --- to change: --- --- > case x of _ -> e --- --- into: --- --- > e --- --- and to decide whether it's safe to discard a 'seq'. --- --- So, it does /not/ treat variables as evaluated, unless they say they are. --- However, it /does/ treat partial applications and constructor applications --- as values, even if their arguments are non-trivial, provided the argument --- type is lifted. For example, both of these are values: --- --- > (:) (f x) (map f xs) --- > map (...redex...) --- --- because 'seq' on such things completes immediately. --- --- For unlifted argument types, we have to be careful: --- --- > C (f x :: Int#) --- --- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't --- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of --- unboxed type must be ok-for-speculation (or trivial). -exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP -exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding - --- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as --- data constructors. Conlike arguments are considered interesting by the --- inliner. -exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP -exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding - --- | Returns true for values or value-like expressions. These are lambdas, --- constructors / CONLIKE functions (as determined by the function argument) --- or PAPs. --- -exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool -exprIsHNFlike is_con is_con_unf = is_hnf_like - where - is_hnf_like (Var v) -- NB: There are no value args at this point - = id_app_is_value v 0 -- Catches nullary constructors, - -- so that [] and () are values, for example - -- and (e.g.) primops that don't have unfoldings - || is_con_unf (idUnfolding v) - -- Check the thing's unfolding; it might be bound to a value - -- or to a guaranteed-evaluated variable (isEvaldUnfolding) - -- Contrast with Note [exprOkForSpeculation and evaluated variables] - -- We don't look through loop breakers here, which is a bit conservative - -- but otherwise I worry that if an Id's unfolding is just itself, - -- we could get an infinite loop - - is_hnf_like (Lit _) = True - is_hnf_like (Type _) = True -- Types are honorary Values; - -- we don't mind copying them - is_hnf_like (Coercion _) = True -- Same for coercions - is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e - is_hnf_like (Tick tickish e) = not (tickishCounts tickish) - && is_hnf_like e - -- See Note [exprIsHNF Tick] - is_hnf_like (Cast e _) = is_hnf_like e - is_hnf_like (App e a) - | isValArg a = app_is_value e 1 - | otherwise = is_hnf_like e - is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us - is_hnf_like _ = False - - -- 'n' is the number of value args to which the expression is applied - -- And n>0: there is at least one value argument - app_is_value :: CoreExpr -> Int -> Bool - app_is_value (Var f) nva = id_app_is_value f nva - app_is_value (Tick _ f) nva = app_is_value f nva - app_is_value (Cast f _) nva = app_is_value f nva - app_is_value (App f a) nva - | isValArg a = app_is_value f (nva + 1) - | otherwise = app_is_value f nva - app_is_value _ _ = False - - id_app_is_value id n_val_args - = is_con id - || idArity id > n_val_args - || id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in MkCore - -- absentError behaves like an honorary data constructor - - -{- -Note [exprIsHNF Tick] - -We can discard source annotations on HNFs as long as they aren't -tick-like: - - scc c (\x . e) => \x . e - scc c (C x1..xn) => C x1..xn - -So we regard these as HNFs. Tick annotations that tick are not -regarded as HNF if the expression they surround is HNF, because the -tick is there to tell us that the expression was evaluated, so we -don't want to discard a seq on it. --} - --- | Can we bind this 'CoreExpr' at the top level? -exprIsTopLevelBindable :: CoreExpr -> Type -> Bool --- See Note [CoreSyn top-level string literals] --- Precondition: exprType expr = ty --- Top-level literal strings can't even be wrapped in ticks --- see Note [CoreSyn top-level string literals] in CoreSyn -exprIsTopLevelBindable expr ty - = not (mightBeUnliftedType ty) - -- Note that 'expr' may be levity polymorphic here consequently we must use - -- 'mightBeUnliftedType' rather than 'isUnliftedType' as the latter would panic. - || exprIsTickedString expr - --- | Check if the expression is zero or more Ticks wrapped around a literal --- string. -exprIsTickedString :: CoreExpr -> Bool -exprIsTickedString = isJust . exprIsTickedString_maybe - --- | Extract a literal string from an expression that is zero or more Ticks --- wrapped around a literal string. Returns Nothing if the expression has a --- different shape. --- Used to "look through" Ticks in places that need to handle literal strings. -exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString -exprIsTickedString_maybe (Lit (LitString bs)) = Just bs -exprIsTickedString_maybe (Tick t e) - -- we don't tick literals with CostCentre ticks, compare to mkTick - | tickishPlace t == PlaceCostCentre = Nothing - | otherwise = exprIsTickedString_maybe e -exprIsTickedString_maybe _ = Nothing - -{- -************************************************************************ -* * - Instantiating data constructors -* * -************************************************************************ - -These InstPat functions go here to avoid circularity between DataCon and Id --} - -dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) - -dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) -dataConRepFSInstPat = dataConInstPat - -dataConInstPat :: [FastString] -- A long enough list of FSs to use for names - -> [Unique] -- An equally long list of uniques, at least one for each binder - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyCoVar], [Id]) -- Return instantiated variables --- dataConInstPat arg_fun fss us con inst_tys returns a tuple --- (ex_tvs, arg_ids), --- --- ex_tvs are intended to be used as binders for existential type args --- --- arg_ids are indended to be used as binders for value arguments, --- and their types have been instantiated with inst_tys and ex_tys --- The arg_ids include both evidence and --- programmer-specified arguments (both after rep-ing) --- --- Example. --- The following constructor T1 --- --- data T a where --- T1 :: forall b. Int -> b -> T(a,b) --- ... --- --- has representation type --- forall a. forall a1. forall b. (a ~ (a1,b)) => --- Int -> b -> T a --- --- dataConInstPat fss us T1 (a1',b') will return --- --- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) --- --- where the double-primed variables are created with the FastStrings and --- Uniques given as fss and us -dataConInstPat fss uniqs con inst_tys - = ASSERT( univ_tvs `equalLength` inst_tys ) - (ex_bndrs, arg_ids) - where - univ_tvs = dataConUnivTyVars con - ex_tvs = dataConExTyCoVars con - arg_tys = dataConRepArgTys con - arg_strs = dataConRepStrictness con -- 1-1 with arg_tys - n_ex = length ex_tvs - - -- split the Uniques and FastStrings - (ex_uniqs, id_uniqs) = splitAt n_ex uniqs - (ex_fss, id_fss) = splitAt n_ex fss - - -- Make the instantiating substitution for universals - univ_subst = zipTvSubst univ_tvs inst_tys - - -- Make existential type variables, applying and extending the substitution - (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst - (zip3 ex_tvs ex_fss ex_uniqs) - - mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) - mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv - new_tv - , new_tv) - where - new_tv | isTyVar tv - = mkTyVar (mkSysTvName uniq fs) kind - | otherwise - = mkCoVar (mkSystemVarName uniq fs) kind - kind = Type.substTyUnchecked subst (varType tv) - - -- Make value vars, instantiating types - arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs - mk_id_var uniq fs ty str - = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] - mkLocalIdOrCoVar name (Type.substTy full_subst ty) - where - name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan - -{- -Note [Mark evaluated arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When pattern matching on a constructor with strict fields, the binder -can have an 'evaldUnfolding'. Moreover, it *should* have one, so that -when loading an interface file unfolding like: - data T = MkT !Int - f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 - in ... } -we don't want Lint to complain. The 'y' is evaluated, so the -case in the RHS of the binding for 'v' is fine. But only if we -*know* that 'y' is evaluated. - -c.f. add_evals in Simplify.simplAlt - -************************************************************************ -* * - Equality -* * -************************************************************************ --} - --- | A cheap equality test which bales out fast! --- If it returns @True@ the arguments are definitely equal, --- otherwise, they may or may not be equal. --- --- See also 'exprIsBig' -cheapEqExpr :: Expr b -> Expr b -> Bool -cheapEqExpr = cheapEqExpr' (const False) - --- | Cheap expression equality test, can ignore ticks by type. -cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool -cheapEqExpr' ignoreTick = go_s - where go_s = go `on` stripTicksTopE ignoreTick - go (Var v1) (Var v2) = v1 == v2 - go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = t1 `eqType` t2 - go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 - - go (App f1 a1) (App f2 a2) - = f1 `go_s` f2 && a1 `go_s` a2 - - go (Cast e1 t1) (Cast e2 t2) - = e1 `go_s` e2 && t1 `eqCoercion` t2 - - go (Tick t1 e1) (Tick t2 e2) - = t1 == t2 && e1 `go_s` e2 - - go _ _ = False - {-# INLINE go #-} -{-# INLINE cheapEqExpr' #-} - -exprIsBig :: Expr b -> Bool --- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' -exprIsBig (Lit _) = False -exprIsBig (Var _) = False -exprIsBig (Type _) = False -exprIsBig (Coercion _) = False -exprIsBig (Lam _ e) = exprIsBig e -exprIsBig (App f a) = exprIsBig f || exprIsBig a -exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! -exprIsBig (Tick _ e) = exprIsBig e -exprIsBig _ = True - -eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool --- Compares for equality, modulo alpha -eqExpr in_scope e1 e2 - = go (mkRnEnv2 in_scope) e1 e2 - where - go env (Var v1) (Var v2) - | rnOccL env v1 == rnOccR env v2 - = True - - go _ (Lit lit1) (Lit lit2) = lit1 == lit2 - go env (Type t1) (Type t2) = eqTypeX env t1 t2 - go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 - go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 - go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 - go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 - - go env (Lam b1 e1) (Lam b2 e2) - = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination - && go (rnBndr2 env b1 b2) e1 e2 - - go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) - = go env r1 r2 -- No need to check binder types, since RHSs match - && go (rnBndr2 env v1 v2) e1 e2 - - go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) - = equalLength ps1 ps2 - && all2 (go env') rs1 rs2 && go env' e1 e2 - where - (bs1,rs1) = unzip ps1 - (bs2,rs2) = unzip ps2 - env' = rnBndrs2 env bs1 bs2 - - go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | null a1 -- See Note [Empty case alternatives] in TrieMap - = null a2 && go env e1 e2 && eqTypeX env t1 t2 - | otherwise - = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 - - go _ _ _ = False - - ----------- - go_alt env (c1, bs1, e1) (c2, bs2, e2) - = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 - -eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool -eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) - = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids -eqTickish _ l r = l == r - --- | Finds differences between core expressions, modulo alpha and --- renaming. Setting @top@ means that the @IdInfo@ of bindings will be --- checked for differences as well. -diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] -diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] -diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] -diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] -diffExpr _ env (Coercion co1) (Coercion co2) - | eqCoercionX env co1 co2 = [] -diffExpr top env (Cast e1 co1) (Cast e2 co2) - | eqCoercionX env co1 co2 = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) e2 - | not (tickishIsCode n1) = diffExpr top env e1 e2 -diffExpr top env e1 (Tick n2 e2) - | not (tickishIsCode n2) = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) (Tick n2 e2) - | eqTickish env n1 n2 = diffExpr top env e1 e2 - -- The error message of failed pattern matches will contain - -- generated names, which are allowed to differ. -diffExpr _ _ (App (App (Var absent) _) _) - (App (App (Var absent2) _) _) - | isBottomingId absent && isBottomingId absent2 = [] -diffExpr top env (App f1 a1) (App f2 a2) - = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 -diffExpr top env (Lam b1 e1) (Lam b2 e2) - | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination - = diffExpr top (rnBndr2 env b1 b2) e1 e2 -diffExpr top env (Let bs1 e1) (Let bs2 e2) - = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) - in ds ++ diffExpr top env' e1 e2 -diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 - -- See Note [Empty case alternatives] in TrieMap - = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) - where env' = rnBndr2 env b1 b2 - diffAlt (c1, bs1, e1) (c2, bs2, e2) - | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] - | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 -diffExpr _ _ e1 e2 - = [fsep [ppr e1, text "/=", ppr e2]] - --- | Finds differences between core bindings, see @diffExpr@. --- --- The main problem here is that while we expect the binds to have the --- same order in both lists, this is not guaranteed. To do this --- properly we'd either have to do some sort of unification or check --- all possible mappings, which would be seriously expensive. So --- instead we simply match single bindings as far as we can. This --- leaves us just with mutually recursive and/or mismatching bindings, --- which we then speculatively match by ordering them. It's by no means --- perfect, but gets the job done well enough. -diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] - -> ([SDoc], RnEnv2) -diffBinds top env binds1 = go (length binds1) env binds1 - where go _ env [] [] - = ([], env) - go fuel env binds1 binds2 - -- No binds left to compare? Bail out early. - | null binds1 || null binds2 - = (warn env binds1 binds2, env) - -- Iterated over all binds without finding a match? Then - -- try speculatively matching binders by order. - | fuel == 0 - = if not $ env `inRnEnvL` fst (head binds1) - then let env' = uncurry (rnBndrs2 env) $ unzip $ - zip (sort $ map fst binds1) (sort $ map fst binds2) - in go (length binds1) env' binds1 binds2 - -- If we have already tried that, give up - else (warn env binds1 binds2, env) - go fuel env ((bndr1,expr1):binds1) binds2 - | let matchExpr (bndr,expr) = - (not top || null (diffIdInfo env bndr bndr1)) && - null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) - , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 - = go (length binds1) (rnBndr2 env bndr1 bndr2) - binds1 (binds2l ++ binds2r) - | otherwise -- No match, so push back (FIXME O(n^2)) - = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 - go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough - - -- We have tried everything, but couldn't find a good match. So - -- now we just return the comparison results when we pair up - -- the binds in a pseudo-random order. - warn env binds1 binds2 = - concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ - unmatched "unmatched left-hand:" (drop l binds1') ++ - unmatched "unmatched right-hand:" (drop l binds2') - where binds1' = sortBy (comparing fst) binds1 - binds2' = sortBy (comparing fst) binds2 - l = min (length binds1') (length binds2') - unmatched _ [] = [] - unmatched txt bs = [text txt $$ ppr (Rec bs)] - diffBind env (bndr1,expr1) (bndr2,expr2) - | ds@(_:_) <- diffExpr top env expr1 expr2 - = locBind "in binding" bndr1 bndr2 ds - | otherwise - = diffIdInfo env bndr1 bndr2 - --- | Find differences in @IdInfo@. We will especially check whether --- the unfoldings match, if present (see @diffUnfold@). -diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] -diffIdInfo env bndr1 bndr2 - | arityInfo info1 == arityInfo info2 - && cafInfo info1 == cafInfo info2 - && oneShotInfo info1 == oneShotInfo info2 - && inlinePragInfo info1 == inlinePragInfo info2 - && occInfo info1 == occInfo info2 - && demandInfo info1 == demandInfo info2 - && callArityInfo info1 == callArityInfo info2 - && levityInfo info1 == levityInfo info2 - = locBind "in unfolding of" bndr1 bndr2 $ - diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) - | otherwise - = locBind "in Id info of" bndr1 bndr2 - [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] - where info1 = idInfo bndr1; info2 = idInfo bndr2 - --- | Find differences in unfoldings. Note that we will not check for --- differences of @IdInfo@ in unfoldings, as this is generally --- redundant, and can lead to an exponential blow-up in complexity. -diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] -diffUnfold _ NoUnfolding NoUnfolding = [] -diffUnfold _ BootUnfolding BootUnfolding = [] -diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] -diffUnfold env (DFunUnfolding bs1 c1 a1) - (DFunUnfolding bs2 c2 a2) - | c1 == c2 && equalLength bs1 bs2 - = concatMap (uncurry (diffExpr False env')) (zip a1 a2) - where env' = rnBndrs2 env bs1 bs2 -diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) - (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) - | v1 == v2 && cl1 == cl2 - && wf1 == wf2 && x1 == x2 && g1 == g2 - = diffExpr False env t1 t2 -diffUnfold _ uf1 uf2 - = [fsep [ppr uf1, text "/=", ppr uf2]] - --- | Add location information to diff messages -locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] -locBind loc b1 b2 diffs = map addLoc diffs - where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) - bindLoc | b1 == b2 = ppr b1 - | otherwise = ppr b1 <> char '/' <> ppr b2 - -{- -************************************************************************ -* * - Eta reduction -* * -************************************************************************ - -Note [Eta reduction conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try for eta reduction here, but *only* if we get all the way to an -trivial expression. We don't want to remove extra lambdas unless we -are going to avoid allocating this thing altogether. - -There are some particularly delicate points here: - -* We want to eta-reduce if doing so leaves a trivial expression, - *including* a cast. For example - \x. f |> co --> f |> co - (provided co doesn't mention x) - -* Eta reduction is not valid in general: - \x. bot /= bot - This matters, partly for old-fashioned correctness reasons but, - worse, getting it wrong can yield a seg fault. Consider - f = \x.f x - h y = case (case y of { True -> f `seq` True; False -> False }) of - True -> ...; False -> ... - - If we (unsoundly) eta-reduce f to get f=f, the strictness analyser - says f=bottom, and replaces the (f `seq` True) with just - (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it - *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands - the definition again, so that it does not termninate after all. - Result: seg-fault because the boolean case actually gets a function value. - See #1947. - - So it's important to do the right thing. - -* Note [Arity care]: we need to be careful if we just look at f's - arity. Currently (Dec07), f's arity is visible in its own RHS (see - Note [Arity robustness] in SimplEnv) so we must *not* trust the - arity when checking that 'f' is a value. Otherwise we will - eta-reduce - f = \x. f x - to - f = f - Which might change a terminating program (think (f `seq` e)) to a - non-terminating one. So we check for being a loop breaker first. - - However for GlobalIds we can look at the arity; and for primops we - must, since they have no unfolding. - -* Regardless of whether 'f' is a value, we always want to - reduce (/\a -> f a) to f - This came up in a RULE: foldr (build (/\a -> g a)) - did not match foldr (build (/\b -> ...something complex...)) - The type checker can insert these eta-expanded versions, - with both type and dictionary lambdas; hence the slightly - ad-hoc isDictId - -* Never *reduce* arity. For example - f = \xy. g x y - Then if h has arity 1 we don't want to eta-reduce because then - f's arity would decrease, and that is bad - -These delicacies are why we don't use exprIsTrivial and exprIsHNF here. -Alas. - -Note [Eta reduction with casted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\(x:t3). f (x |> g)) :: t3 -> t2 - where - f :: t1 -> t2 - g :: t3 ~ t1 -This should be eta-reduced to - - f |> (sym g -> t2) - -So we need to accumulate a coercion, pushing it inward (past -variable arguments only) thus: - f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x - f (x:t) |> co --> (f |> (t -> co)) x - f @ a |> co --> (f |> (forall a.co)) @ a - f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) -These are the equations for ok_arg. - -It's true that we could also hope to eta reduce these: - (\xy. (f x |> g) y) - (\xy. (f x y) |> g) -But the simplifier pushes those casts outwards, so we don't -need to address that here. --} - --- When updating this function, make sure to update --- CorePrep.tryEtaReducePrep as well! -tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr -tryEtaReduce bndrs body - = go (reverse bndrs) body (mkRepReflCo (exprType body)) - where - incoming_arity = count isId bndrs - - go :: [Var] -- Binders, innermost first, types [a3,a2,a1] - -> CoreExpr -- Of type tr - -> Coercion -- Of type tr ~ ts - -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts - -- See Note [Eta reduction with casted arguments] - -- for why we have an accumulating coercion - go [] fun co - | ok_fun fun - , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co - , not (any (`elemVarSet` used_vars) bndrs) - = Just (mkCast fun co) -- Check for any of the binders free in the result - -- including the accumulated coercion - - go bs (Tick t e) co - | tickishFloatable t - = fmap (Tick t) $ go bs e co - -- Float app ticks: \x -> Tick t (e x) ==> Tick t e - - go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co - = fmap (flip (foldr mkTick) ticks) $ go bs fun co' - -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e - - go _ _ _ = Nothing -- Failure! - - --------------- - -- Note [Eta reduction conditions] - ok_fun (App fun (Type {})) = ok_fun fun - ok_fun (Cast fun _) = ok_fun fun - ok_fun (Tick _ expr) = ok_fun expr - ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs - ok_fun _fun = False - - --------------- - ok_fun_id fun = fun_arity fun >= incoming_arity - - --------------- - fun_arity fun -- See Note [Arity care] - | isLocalId fun - , isStrongLoopBreaker (idOccInfo fun) = 0 - | arity > 0 = arity - | isEvaldUnfolding (idUnfolding fun) = 1 - -- See Note [Eta reduction of an eval'd function] - | otherwise = 0 - where - arity = idArity fun - - --------------- - ok_lam v = isTyVar v || isEvVar v - - --------------- - ok_arg :: Var -- Of type bndr_t - -> CoreExpr -- Of type arg_t - -> Coercion -- Of kind (t1~t2) - -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) - -- (and similarly for tyvars, coercion args) - , [Tickish Var]) - -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type ty) co - | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkHomoForAllCos [tv] co, []) - ok_arg bndr (Var v) co - | bndr == v = let reflCo = mkRepReflCo (idType bndr) - in Just (mkFunCo Representational reflCo co, []) - ok_arg bndr (Cast e co_arg) co - | (ticks, Var v) <- stripTicksTop tickishFloatable e - , bndr == v - = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks) - -- The simplifier combines multiple casts into one, - -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co - = Just (co', t:ticks) - - ok_arg _ _ _ = Nothing - -{- -Note [Eta reduction of an eval'd function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell it is not true that f = \x. f x -because f might be bottom, and 'seq' can distinguish them. - -But it *is* true that f = f `seq` \x. f x -and we'd like to simplify the latter to the former. This amounts -to the rule that - * when there is just *one* value argument, - * f is not bottom -we can eta-reduce \x. f x ===> f - -This turned up in #7542. - - -************************************************************************ -* * -\subsection{Determining non-updatable right-hand-sides} -* * -************************************************************************ - -Top-level constructor applications can usually be allocated -statically, but they can't if the constructor, or any of the -arguments, come from another DLL (because we can't refer to static -labels in other DLLs). - -If this happens we simply make the RHS into an updatable thunk, -and 'execute' it rather than allocating it statically. --} - --- | This function is called only on *top-level* right-hand sides. --- Returns @True@ if the RHS can be allocated statically in the output, --- with no thunks involved at all. -rhsIsStatic - :: Platform - -> (Name -> Bool) -- Which names are dynamic - -> (LitNumType -> Integer -> Maybe CoreExpr) - -- Desugaring for some literals (disgusting) - -- C.f. Note [Disgusting computation of CafRefs] in TidyPgm - -> CoreExpr -> Bool --- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or --- refers to, CAFs; (ii) in CoreToStg to decide whether to put an --- update flag on it and (iii) in DsExpr to decide how to expand --- list literals --- --- The basic idea is that rhsIsStatic returns True only if the RHS is --- (a) a value lambda --- (b) a saturated constructor application with static args --- --- BUT watch out for --- (i) Any cross-DLL references kill static-ness completely --- because they must be 'executed' not statically allocated --- ("DLL" here really only refers to Windows DLLs, on other platforms, --- this is not necessary) --- --- (ii) We treat partial applications as redexes, because in fact we --- make a thunk for them that runs and builds a PAP --- at run-time. The only applications that are treated as --- static are *saturated* applications of constructors. - --- We used to try to be clever with nested structures like this: --- ys = (:) w ((:) w []) --- on the grounds that CorePrep will flatten ANF-ise it later. --- But supporting this special case made the function much more --- complicated, because the special case only applies if there are no --- enclosing type lambdas: --- ys = /\ a -> Foo (Baz ([] a)) --- Here the nested (Baz []) won't float out to top level in CorePrep. --- --- But in fact, even without -O, nested structures at top level are --- flattened by the simplifier, so we don't need to be super-clever here. --- --- Examples --- --- f = \x::Int. x+7 TRUE --- p = (True,False) TRUE --- --- d = (fst p, False) FALSE because there's a redex inside --- (this particular one doesn't happen but...) --- --- h = D# (1.0## /## 2.0##) FALSE (redex again) --- n = /\a. Nil a TRUE --- --- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) --- --- --- This is a bit like CoreUtils.exprIsHNF, with the following differences: --- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) --- --- b) (C x xs), where C is a constructor is updatable if the application is --- dynamic --- --- c) don't look through unfolding of f in (f x). - -rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs - where - is_static :: Bool -- True <=> in a constructor argument; must be atomic - -> CoreExpr -> Bool - - is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Tick n e) = not (tickishIsCode n) - && is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e - is_static _ (Coercion {}) = True -- Behaves just like a literal - is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of - Just e -> is_static in_arg e - Nothing -> True - is_static _ (Lit (LitLabel {})) = False - is_static _ (Lit _) = True - -- A LitLabel (foreign import "&foo") in an argument - -- prevents a constructor application from being static. The - -- reason is that it might give rise to unresolvable symbols - -- in the object file: under Linux, references to "weak" - -- symbols from the data segment give rise to "unresolvable - -- relocation" errors at link time This might be due to a bug - -- in the linker, but we'll work around it here anyway. - -- SDM 24/2/2004 - - is_static in_arg other_expr = go other_expr 0 - where - go (Var f) n_val_args - | (platformOS platform /= OSMinGW32) || - not (is_dynamic_name (idName f)) - = saturated_data_con f n_val_args - || (in_arg && n_val_args == 0) - -- A naked un-applied variable is *not* deemed a static RHS - -- E.g. f = g - -- Reason: better to update so that the indirection gets shorted - -- out, and the true value will be seen - -- NB: if you change this, you'll break the invariant that THUNK_STATICs - -- are always updatable. If you do so, make sure that non-updatable - -- ones have enough space for their static link field! - - go (App f a) n_val_args - | isTypeArg a = go f n_val_args - | not in_arg && is_static True a = go f (n_val_args + 1) - -- The (not in_arg) checks that we aren't in a constructor argument; - -- if we are, we don't allow (value) applications of any sort - -- - -- NB. In case you wonder, args are sometimes not atomic. eg. - -- x = D# (1.0## /## 2.0##) - -- can't float because /## can fail. - - go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args - go (Cast e _) n_val_args = go e n_val_args - go _ _ = False - - saturated_data_con f n_val_args - = case isDataConWorkId_maybe f of - Just dc -> n_val_args == dataConRepArity dc - Nothing -> False - -{- -************************************************************************ -* * -\subsection{Type utilities} -* * -************************************************************************ --} - --- | True if the type has no non-bottom elements, e.g. when it is an empty --- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. --- See Note [Bottoming expressions] --- --- See Note [No alternatives lint check] for another use of this function. -isEmptyTy :: Type -> Bool -isEmptyTy ty - -- Data types where, given the particular type parameters, no data - -- constructor matches, are empty. - -- This includes data types with no constructors, e.g. Data.Void.Void. - | Just (tc, inst_tys) <- splitTyConApp_maybe ty - , Just dcs <- tyConDataCons_maybe tc - , all (dataConCannotMatch inst_tys) dcs - = True - | otherwise - = False - -{- -***************************************************** -* -* StaticPtr -* -***************************************************** --} - --- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields --- @Just (makeStatic, t, srcLoc, e)@. --- --- Returns @Nothing@ for every other expression. -collectMakeStaticArgs - :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) -collectMakeStaticArgs e - | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e - , idName b == makeStaticName = Just (fun, t, loc, arg) -collectMakeStaticArgs _ = Nothing - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Does this binding bind a join point (or a recursive group of join points)? -isJoinBind :: CoreBind -> Bool -isJoinBind (NonRec b _) = isJoinId b -isJoinBind (Rec ((b, _) : _)) = isJoinId b -isJoinBind _ = False diff --git a/coreSyn/MkCore.hs b/coreSyn/MkCore.hs deleted file mode 100644 --- a/coreSyn/MkCore.hs +++ /dev/null @@ -1,933 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Handy functions for creating much Core syntax -module MkCore ( - -- * Constructing normal syntax - mkCoreLet, mkCoreLets, - mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, mkWildCase, mkIfThenElse, - mkWildValBinder, mkWildEvBinder, - mkSingleAltCase, - sortQuantVars, castBottomExpr, - - -- * Constructing boxed literals - mkWordExpr, mkWordExprWord, - mkIntExpr, mkIntExprInt, - mkIntegerExpr, mkNaturalExpr, - mkFloatExpr, mkDoubleExpr, - mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, - - -- * Floats - FloatBind(..), wrapFloat, wrapFloats, floatBindings, - - -- * Constructing small tuples - mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, - mkCoreTupBoxity, unitExpr, - - -- * Constructing big tuples - mkBigCoreVarTup, mkBigCoreVarTup1, - mkBigCoreVarTupTy, mkBigCoreTupTy, - mkBigCoreTup, - - -- * Deconstructing small tuples - mkSmallTupleSelector, mkSmallTupleCase, - - -- * Deconstructing big tuples - mkTupleSelector, mkTupleSelector1, mkTupleCase, - - -- * Constructing list expressions - mkNilExpr, mkConsExpr, mkListExpr, - mkFoldrExpr, mkBuildExpr, - - -- * Constructing Maybe expressions - mkNothingExpr, mkJustExpr, - - -- * Error Ids - mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, - rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, - tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Id -import Var ( EvVar, setTyVarUnique ) - -import CoreSyn -import CoreUtils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) -import Literal -import HscTypes - -import TysWiredIn -import PrelNames - -import GHC.Hs.Utils ( mkChunkified, chunkify ) -import Type -import Coercion ( isCoVar ) -import TysPrim -import DataCon ( DataCon, dataConWorkId ) -import IdInfo -import Demand -import Name hiding ( varName ) -import Outputable -import FastString -import UniqSupply -import BasicTypes -import Util -import DynFlags -import Data.List - -import Data.Char ( ord ) -import Control.Monad.Fail as MonadFail ( MonadFail ) - -infixl 4 `mkCoreApp`, `mkCoreApps` - -{- -************************************************************************ -* * -\subsection{Basic CoreSyn construction} -* * -************************************************************************ --} -sortQuantVars :: [Var] -> [Var] --- Sort the variables, putting type and covars first, in scoped order, --- and then other Ids --- It is a deterministic sort, meaining it doesn't look at the values of --- Uniques. For explanation why it's important See Note [Unique Determinism] --- in Unique. -sortQuantVars vs = sorted_tcvs ++ ids - where - (tcvs, ids) = partition (isTyVar <||> isCoVar) vs - sorted_tcvs = scopedSort tcvs - --- | Bind a binding group over an expression, using a @let@ or @case@ as --- appropriate (see "CoreSyn#let_app_invariant") -mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr -mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] - = bindNonRec bndr rhs body -mkCoreLet bind body - = Let bind body - --- | Create a lambda where the given expression has a number of variables --- bound over it. The leftmost binder is that bound by the outermost --- lambda in the result -mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr -mkCoreLams = mkLams - --- | Bind a list of binding groups over an expression. The leftmost binding --- group becomes the outermost group in the resulting expression -mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr -mkCoreLets binds body = foldr mkCoreLet body binds - --- | Construct an expression which represents the application of a number of --- expressions to that of a data constructor expression. The leftmost expression --- in the list is applied first -mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr -mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args - --- | Construct an expression which represents the application of a number of --- expressions to another. The leftmost expression in the list is applied first --- Respects the let/app invariant by building a case expression where necessary --- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreApps fun args - = fst $ - foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args - where - doc_string = ppr fun_ty $$ ppr fun $$ ppr args - fun_ty = exprType fun - --- | Construct an expression which represents the application of one expression --- to the other --- Respects the let/app invariant by building a case expression where necessary --- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -mkCoreApp s fun arg - = fst $ mkCoreAppTyped s (fun, exprType fun) arg - --- | Construct an expression which represents the application of one expression --- paired with its type to an argument. The result is paired with its type. This --- function is not exported and used in the definition of 'mkCoreApp' and --- 'mkCoreApps'. --- Respects the let/app invariant by building a case expression where necessary --- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) -mkCoreAppTyped _ (fun, fun_ty) (Type ty) - = (App fun (Type ty), piResultTy fun_ty ty) -mkCoreAppTyped _ (fun, fun_ty) (Coercion co) - = (App fun (Coercion co), funResultTy fun_ty) -mkCoreAppTyped d (fun, fun_ty) arg - = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) - (mkValApp fun arg arg_ty res_ty, res_ty) - where - (arg_ty, res_ty) = splitFunTy fun_ty - -mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr --- Build an application (e1 e2), --- or a strict binding (case e2 of x -> e1 x) --- using the latter when necessary to respect the let/app invariant --- See Note [CoreSyn let/app invariant] -mkValApp fun arg arg_ty res_ty - | not (needsCaseBinding arg_ty arg) - = App fun arg -- The vastly common case - | otherwise - = mkStrictApp fun arg arg_ty res_ty - -{- ********************************************************************* -* * - Building case expressions -* * -********************************************************************* -} - -mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred = mkWildValBinder pred - --- | Make a /wildcard binder/. This is typically used when you need a binder --- that you expect to use only at a *binding* site. Do not use it at --- occurrence sites because it has a single, fixed unique, and it's very --- easy to get into difficulties with shadowing. That's why it is used so little. --- See Note [WildCard binders] in SimplEnv -mkWildValBinder :: Type -> Id -mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty - -mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr --- Make a case expression whose case binder is unused --- The alts and res_ty should not have any occurrences of WildId -mkWildCase scrut scrut_ty res_ty alts - = Case scrut (mkWildValBinder scrut_ty) res_ty alts - -mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr --- Build a strict application (case e2 of x -> e1 x) -mkStrictApp fun arg arg_ty res_ty - = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] - -- mkDefaultCase looks attractive here, and would be sound. - -- But it uses (exprType alt_rhs) to compute the result type, - -- whereas here we already know that the result type is res_ty - where - arg_id = mkWildValBinder arg_ty - -- Lots of shadowing, but it doesn't matter, - -- because 'fun' and 'res_ty' should not have a free wild-id - -- - -- This is Dangerous. But this is the only place we play this - -- game, mkStrictApp returns an expression that does not have - -- a free wild-id. So the only way 'fun' could get a free wild-id - -- would be if you take apart this case expression (or some other - -- expression that uses mkWildValBinder, of which there are not - -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. - -mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr -mkIfThenElse guard then_expr else_expr --- Not going to be refining, so okay to take the type of the "then" clause - = mkWildCase guard boolTy (exprType then_expr) - [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! - (DataAlt trueDataCon, [], then_expr) ] - -castBottomExpr :: CoreExpr -> Type -> CoreExpr --- (castBottomExpr e ty), assuming that 'e' diverges, --- return an expression of type 'ty' --- See Note [Empty case alternatives] in CoreSyn -castBottomExpr e res_ty - | e_ty `eqType` res_ty = e - | otherwise = Case e (mkWildValBinder e_ty) res_ty [] - where - e_ty = exprType e - -{- -************************************************************************ -* * -\subsection{Making literals} -* * -************************************************************************ --} - --- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int -mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] - --- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int -mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] - --- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value -mkWordExpr :: DynFlags -> Integer -> CoreExpr -mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] - --- | Create a 'CoreExpr' which will evaluate to the given @Word@ -mkWordExprWord :: DynFlags -> Word -> CoreExpr -mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] - --- | Create a 'CoreExpr' which will evaluate to the given @Integer@ -mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer -mkIntegerExpr i = do t <- lookupTyCon integerTyConName - return (Lit (mkLitInteger i (mkTyConTy t))) - --- | Create a 'CoreExpr' which will evaluate to the given @Natural@ -mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr -mkNaturalExpr i = do t <- lookupTyCon naturalTyConName - return (Lit (mkLitNatural i (mkTyConTy t))) - --- | Create a 'CoreExpr' which will evaluate to the given @Float@ -mkFloatExpr :: Float -> CoreExpr -mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] - --- | Create a 'CoreExpr' which will evaluate to the given @Double@ -mkDoubleExpr :: Double -> CoreExpr -mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] - - --- | Create a 'CoreExpr' which will evaluate to the given @Char@ -mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int -mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] - --- | Create a 'CoreExpr' which will evaluate to the given @String@ -mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String - --- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ -mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String - -mkStringExpr str = mkStringExprFS (mkFastString str) - -mkStringExprFS = mkStringExprFSWith lookupId - -mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr -mkStringExprFSWith lookupM str - | nullFS str - = return (mkNilExpr charTy) - - | all safeChar chars - = do unpack_id <- lookupM unpackCStringName - return (App (Var unpack_id) lit) - - | otherwise - = do unpack_utf8_id <- lookupM unpackCStringUtf8Name - return (App (Var unpack_utf8_id) lit) - - where - chars = unpackFS str - safeChar c = ord c >= 1 && ord c <= 0x7F - lit = Lit (LitString (bytesFS str)) - -{- -************************************************************************ -* * -\subsection{Tuple constructors} -* * -************************************************************************ --} - -{- -Creating tuples and their types for Core expressions - -@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. - -* If it has only one element, it is the identity function. - -* If there are more elements than a big tuple can have, it nests - the tuples. - -Note [Flattening one-tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This family of functions creates a tuple of variables/expressions/types. - mkCoreTup [e1,e2,e3] = (e1,e2,e3) -What if there is just one variable/expression/type in the argument? -We could do one of two things: - -* Flatten it out, so that - mkCoreTup [e1] = e1 - -* Build a one-tuple (see Note [One-tuples] in TysWiredIn) - mkCoreTup1 [e1] = Unit e1 - We use a suffix "1" to indicate this. - -Usually we want the former, but occasionally the latter. - -NB: The logic in tupleDataCon knows about () and Unit and (,), etc. - -Note [Don't flatten tuples from HsSyn] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell), -we should treat it really as a 1-tuple, without flattening. Note that a -1-tuple and a flattened value have different performance and laziness -characteristics, so should just do what we're asked. - -This arose from discussions in #16881. - -One-tuples that arise internally depend on the circumstance; often flattening -is a good idea. Decisions are made on a case-by-case basis. - --} - --- | Build the type of a small tuple that holds the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreVarTupTy :: [Id] -> Type -mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) - --- | Build a small tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreTup :: [CoreExpr] -> CoreExpr -mkCoreTup [c] = c -mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform - --- | Build a small tuple holding the specified expressions --- One-tuples are *not* flattened; see Note [Flattening one-tuples] --- See also Note [Don't flatten tuples from HsSyn] -mkCoreTup1 :: [CoreExpr] -> CoreExpr -mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs)) - (map (Type . exprType) cs ++ cs) - --- | Build a small unboxed tuple holding the specified expressions, --- with the given types. The types must be the types of the expressions. --- Do not include the RuntimeRep specifiers; this function calculates them --- for you. --- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] -mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr -mkCoreUbxTup tys exps - = ASSERT( tys `equalLength` exps) - mkCoreConApps (tupleDataCon Unboxed (length tys)) - (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) - --- | Make a core tuple of the given boxity; don't flatten 1-tuples -mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr -mkCoreTupBoxity Boxed exps = mkCoreTup1 exps -mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps - --- | Build a big tuple holding the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreVarTup :: [Id] -> CoreExpr -mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) - -mkBigCoreVarTup1 :: [Id] -> CoreExpr --- Same as mkBigCoreVarTup, but one-tuples are NOT flattened --- see Note [Flattening one-tuples] -mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) - [Type (idType id), Var id] -mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) - --- | Build the type of a big tuple that holds the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreVarTupTy :: [Id] -> Type -mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) - --- | Build a big tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreTup :: [CoreExpr] -> CoreExpr -mkBigCoreTup = mkChunkified mkCoreTup - --- | Build the type of a big tuple that holds the specified type of thing --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreTupTy :: [Type] -> Type -mkBigCoreTupTy = mkChunkified mkBoxedTupleTy - --- | The unit expression -unitExpr :: CoreExpr -unitExpr = Var unitDataConId - -{- -************************************************************************ -* * -\subsection{Tuple destructors} -* * -************************************************************************ --} - --- | Builds a selector which scrutises the given --- expression and extracts the one name from the list given. --- If you want the no-shadowing rule to apply, the caller --- is responsible for making sure that none of these names --- are in scope. --- --- If there is just one 'Id' in the tuple, then the selector is --- just the identity. --- --- If necessary, we pattern match on a \"big\" tuple. -mkTupleSelector, mkTupleSelector1 - :: [Id] -- ^ The 'Id's to pattern match the tuple against - -> Id -- ^ The 'Id' to select - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr -- ^ Selector expression - --- mkTupleSelector [a,b,c,d] b v e --- = case e of v { --- (p,q) -> case p of p { --- (a,b) -> b }} --- We use 'tpl' vars for the p,q, since shadowing does not matter. --- --- In fact, it's more convenient to generate it innermost first, getting --- --- case (case e of v --- (p,q) -> p) of p --- (a,b) -> b -mkTupleSelector vars the_var scrut_var scrut - = mk_tup_sel (chunkify vars) the_var - where - mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut - mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ - mk_tup_sel (chunkify tpl_vs) tpl_v - where - tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] - tpl_vs = mkTemplateLocals tpl_tys - [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, - the_var `elem` gp ] --- ^ 'mkTupleSelector1' is like 'mkTupleSelector' --- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) -mkTupleSelector1 vars the_var scrut_var scrut - | [_] <- vars - = mkSmallTupleSelector1 vars the_var scrut_var scrut - | otherwise - = mkTupleSelector vars the_var scrut_var scrut - --- | Like 'mkTupleSelector' but for tuples that are guaranteed --- never to be \"big\". --- --- > mkSmallTupleSelector [x] x v e = [| e |] --- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] -mkSmallTupleSelector, mkSmallTupleSelector1 - :: [Id] -- The tuple args - -> Id -- The selected one - -> Id -- A variable of the same type as the scrutinee - -> CoreExpr -- Scrutinee - -> CoreExpr -mkSmallTupleSelector [var] should_be_the_same_var _ scrut - = ASSERT(var == should_be_the_same_var) - scrut -- Special case for 1-tuples -mkSmallTupleSelector vars the_var scrut_var scrut - = mkSmallTupleSelector1 vars the_var scrut_var scrut - --- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' --- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) -mkSmallTupleSelector1 vars the_var scrut_var scrut - = ASSERT( notNull vars ) - Case scrut scrut_var (idType the_var) - [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] - --- | A generalization of 'mkTupleSelector', allowing the body --- of the case to be an arbitrary expression. --- --- To avoid shadowing, we use uniques to invent new variables. --- --- If necessary we pattern match on a \"big\" tuple. -mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables - -> [Id] -- ^ The tuple identifiers to pattern match on - -> CoreExpr -- ^ Body of the case - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr --- ToDo: eliminate cases where none of the variables are needed. --- --- mkTupleCase uniqs [a,b,c,d] body v e --- = case e of v { (p,q) -> --- case p of p { (a,b) -> --- case q of q { (c,d) -> --- body }}} -mkTupleCase uniqs vars body scrut_var scrut - = mk_tuple_case uniqs (chunkify vars) body - where - -- This is the case where don't need any nesting - mk_tuple_case _ [vars] body - = mkSmallTupleCase vars body scrut_var scrut - - -- This is the case where we must make nest tuples at least once - mk_tuple_case us vars_s body - = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s - in mk_tuple_case us' (chunkify vars') body' - - one_tuple_case chunk_vars (us, vs, body) - = let (uniq, us') = takeUniqFromSupply us - scrut_var = mkSysLocal (fsLit "ds") uniq - (mkBoxedTupleTy (map idType chunk_vars)) - body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) - in (us', scrut_var:vs, body') - --- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed --- not to need nesting. -mkSmallTupleCase - :: [Id] -- ^ The tuple args - -> CoreExpr -- ^ Body of the case - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr - -mkSmallTupleCase [var] body _scrut_var scrut - = bindNonRec var scrut body -mkSmallTupleCase vars body scrut_var scrut --- One branch no refinement? - = Case scrut scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] - -{- -************************************************************************ -* * - Floats -* * -************************************************************************ --} - -data FloatBind - = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating single-alternative cases] in SetLevels - -instance Outputable FloatBind where - ppr (FloatLet b) = text "LET" <+> ppr b - ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) - 2 (ppr c <+> ppr bs) - -wrapFloat :: FloatBind -> CoreExpr -> CoreExpr -wrapFloat (FloatLet defns) body = Let defns body -wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body - --- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] --- u = let b1 in let b2 in … in let bn in u@ -wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr -wrapFloats floats expr = foldr wrapFloat expr floats - -bindBindings :: CoreBind -> [Var] -bindBindings (NonRec b _) = [b] -bindBindings (Rec bnds) = map fst bnds - -floatBindings :: FloatBind -> [Var] -floatBindings (FloatLet bnd) = bindBindings bnd -floatBindings (FloatCase _ b _ bs) = b:bs - -{- -************************************************************************ -* * -\subsection{Common list manipulation expressions} -* * -************************************************************************ - -Call the constructor Ids when building explicit lists, so that they -interact well with rules. --} - --- | Makes a list @[]@ for lists of the specified type -mkNilExpr :: Type -> CoreExpr -mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] - --- | Makes a list @(:)@ for lists of the specified type -mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr -mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] - --- | Make a list containing the given expressions, where the list has the given type -mkListExpr :: Type -> [CoreExpr] -> CoreExpr -mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs - --- | Make a fully applied 'foldr' expression -mkFoldrExpr :: MonadThings m - => Type -- ^ Element type of the list - -> Type -- ^ Fold result type - -> CoreExpr -- ^ "Cons" function expression for the fold - -> CoreExpr -- ^ "Nil" expression for the fold - -> CoreExpr -- ^ List expression being folded acress - -> m CoreExpr -mkFoldrExpr elt_ty result_ty c n list = do - foldr_id <- lookupId foldrName - return (Var foldr_id `App` Type elt_ty - `App` Type result_ty - `App` c - `App` n - `App` list) - --- | Make a 'build' expression applied to a locally-bound worker function -mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m) - => Type -- ^ Type of list elements to be built - -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's - -- of the binders for the build worker function, returns - -- the body of that worker - -> m CoreExpr -mkBuildExpr elt_ty mk_build_inside = do - [n_tyvar] <- newTyVars [alphaTyVar] - let n_ty = mkTyVarTy n_tyvar - c_ty = mkVisFunTys [elt_ty, n_ty] n_ty - [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] - - build_inside <- mk_build_inside (c, c_ty) (n, n_ty) - - build_id <- lookupId buildName - return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside - where - newTyVars tyvar_tmpls = do - uniqs <- getUniquesM - return (zipWith setTyVarUnique tyvar_tmpls uniqs) - -{- -************************************************************************ -* * - Manipulating Maybe data type -* * -************************************************************************ --} - - --- | Makes a Nothing for the specified type -mkNothingExpr :: Type -> CoreExpr -mkNothingExpr ty = mkConApp nothingDataCon [Type ty] - --- | Makes a Just from a value of the specified type -mkJustExpr :: Type -> CoreExpr -> CoreExpr -mkJustExpr ty val = mkConApp justDataCon [Type ty, val] - - -{- -************************************************************************ -* * - Error expressions -* * -************************************************************************ --} - -mkRuntimeErrorApp - :: Id -- Should be of type (forall a. Addr# -> a) - -- where Addr# points to a UTF8 encoded string - -> Type -- The type to instantiate 'a' - -> String -- The string to print - -> CoreExpr - -mkRuntimeErrorApp err_id res_ty err_msg - = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) - , Type res_ty, err_string ] - where - err_string = Lit (mkLitString err_msg) - -mkImpossibleExpr :: Type -> CoreExpr -mkImpossibleExpr res_ty - = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" - -{- -************************************************************************ -* * - Error Ids -* * -************************************************************************ - -GHC randomly injects these into the code. - -@patError@ is just a version of @error@ for pattern-matching -failures. It knows various ``codes'' which expand to longer -strings---this saves space! - -@absentErr@ is a thing we put in for ``absent'' arguments. They jolly -well shouldn't be yanked on, but if one is, then you will get a -friendly message from @absentErr@ (rather than a totally random -crash). - -@parError@ is a special version of @error@ which the compiler does -not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ -templates, but we don't ever expect to generate code for it. --} - -errorIds :: [Id] -errorIds - = [ rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, - nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, - rEC_CON_ERROR_ID, - rEC_SEL_ERROR_ID, - aBSENT_ERROR_ID, - tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 - ] - -recSelErrorName, runtimeErrorName, absentErrorName :: Name -recConErrorName, patErrorName :: Name -nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name -typeErrorName :: Name -absentSumFieldErrorName :: Name - -recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID -absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID -absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey - aBSENT_SUM_FIELD_ERROR_ID -runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID -recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID -patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID -typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID - -noMethodBindingErrorName = err_nm "noMethodBindingError" - noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID -nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" - nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID - -err_nm :: String -> Unique -> Id -> Name -err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id - -rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id -pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id -tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -pAT_ERROR_ID = mkRuntimeErrorId patErrorName -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName - --- Note [aBSENT_SUM_FIELD_ERROR_ID] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Absent argument error for unused unboxed sum fields are different than absent --- error used in dummy worker functions (see `mkAbsentErrorApp`): --- --- - `absentSumFieldError` can't take arguments because it's used in unarise for --- unused pointer fields in unboxed sums, and applying an argument would --- require allocating a thunk. --- --- - `absentSumFieldError` can't be CAFFY because that would mean making some --- non-CAFFY definitions that use unboxed sums CAFFY in unarise. --- --- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in --- RtsStartup.c and mark it as non-CAFFY here. --- --- Getting this wrong causes hard-to-debug runtime issues, see #15038. --- --- TODO: Remove stable pointer hack after fixing #9718. --- However, we should still be careful about not making things CAFFY just --- because they use unboxed sums. Unboxed objects are supposed to be --- efficient, and none of the other unboxed literals make things CAFFY. - -aBSENT_SUM_FIELD_ERROR_ID - = mkVanillaGlobalWithInfo absentSumFieldErrorName - (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a - (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes - `setArityInfo` 0 - `setCafInfo` NoCafRefs) -- #15038 - -mkRuntimeErrorId :: Name -> Id --- Error function --- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a --- with arity: 1 --- which diverges after being given one argument --- The Addr# is expected to be the address of --- a UTF8-encoded error string -mkRuntimeErrorId name - = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info - where - bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig - `setArityInfo` 1 - -- Make arity and strictness agree - - -- Do *not* mark them as NoCafRefs, because they can indeed have - -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, - -- which has some CAFs - -- In due course we may arrange that these error-y things are - -- regarded by the GC as permanently live, in which case we - -- can give them NoCaf info. As it is, any function that calls - -- any pc_bottoming_Id will itself have CafRefs, which bloats - -- SRTs. - - strict_sig = mkClosedStrictSig [evalDmd] botRes - -runtimeErrorTy :: Type --- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a --- See Note [Error and friends have an "open-tyvar" forall] -runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] - (mkVisFunTy addrPrimTy openAlphaTy) - -{- Note [Error and friends have an "open-tyvar" forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'error' and 'undefined' have types - error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a - undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a -Notice the runtime-representation polymorphism. This ensures that -"error" can be instantiated at unboxed as well as boxed types. -This is OK because it never returns, so the return type is irrelevant. - - -************************************************************************ -* * - aBSENT_ERROR_ID -* * -************************************************************************ - -Note [aBSENT_ERROR_ID] -~~~~~~~~~~~~~~~~~~~~~~ -We use aBSENT_ERROR_ID to build dummy values in workers. E.g. - - f x = (case x of (a,b) -> b) + 1::Int - -The demand analyser figures ot that only the second component of x is -used, and does a w/w split thus - - f x = case x of (a,b) -> $wf b - - $wf b = let a = absentError "blah" - x = (a,b) - in - -After some simplification, the (absentError "blah") thunk goes away. - ------- Tricky wrinkle ------- -#14285 had, roughly - - data T a = MkT a !a - {-# INLINABLE f #-} - f x = case x of MkT a b -> g (MkT b a) - -It turned out that g didn't use the second component, and hence f doesn't use -the first. But the stable-unfolding for f looks like - \x. case x of MkT a b -> g ($WMkT b a) -where $WMkT is the wrapper for MkT that evaluates its arguments. We -apply the same w/w split to this unfolding (see Note [Worker-wrapper -for INLINEABLE functions] in WorkWrap) so the template ends up like - \b. let a = absentError "blah" - x = MkT a b - in case x of MkT a b -> g ($WMkT b a) - -After doing case-of-known-constructor, and expanding $WMkT we get - \b -> g (case absentError "blah" of a -> MkT b a) - -Yikes! That bogusly appears to evaluate the absentError! - -This is extremely tiresome. Another way to think of this is that, in -Core, it is an invariant that a strict data contructor, like MkT, must -be applied only to an argument in HNF. So (absentError "blah") had -better be non-bottom. - -So the "solution" is to add a special case for absentError to exprIsHNFlike. -This allows Simplify.rebuildCase, in the Note [Case to let transformation] -branch, to convert the case on absentError into a let. We also make -absentError *not* be diverging, unlike the other error-ids, so that we -can be sure not to remove the case branches before converting the case to -a let. - -If, by some bug or bizarre happenstance, we ever call absentError, we should -throw an exception. This should never happen, of course, but we definitely -can't return anything. e.g. if somehow we had - case absentError "foo" of - Nothing -> ... - Just x -> ... -then if we return, the case expression will select a field and continue. -Seg fault city. Better to throw an exception. (Even though we've said -it is in HNF :-) - -It might seem a bit surprising that seq on absentError is simply erased - - absentError "foo" `seq` x ==> x - -but that should be okay; since there's no pattern match we can't really -be relying on anything from it. --} - -aBSENT_ERROR_ID - = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info - where - absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy) - -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for - -- lifted-type things; see Note [Absent errors] in WwLib - arity_info = vanillaIdInfo `setArityInfo` 1 - -- NB: no bottoming strictness info, unlike other error-ids. - -- See Note [aBSENT_ERROR_ID] - -mkAbsentErrorApp :: Type -- The type to instantiate 'a' - -> String -- The string to print - -> CoreExpr - -mkAbsentErrorApp res_ty err_msg - = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] - where - err_string = Lit (mkLitString err_msg) diff --git a/coreSyn/PprCore.hs b/coreSyn/PprCore.hs deleted file mode 100644 --- a/coreSyn/PprCore.hs +++ /dev/null @@ -1,620 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -Printing of Core syntax --} - -{-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PprCore ( - pprCoreExpr, pprParendExpr, - pprCoreBinding, pprCoreBindings, pprCoreAlt, - pprCoreBindingWithSize, pprCoreBindingsWithSize, - pprRules, pprOptCo - ) where - -import GhcPrelude - -import CoreSyn -import CoreStats (exprStats) -import Literal( pprLiteral ) -import Name( pprInfixName, pprPrefixName ) -import Var -import Id -import IdInfo -import Demand -import DataCon -import TyCon -import TyCoPpr -import Coercion -import DynFlags -import BasicTypes -import Maybes -import Util -import Outputable -import FastString -import SrcLoc ( pprUserRealSpan ) - -{- -************************************************************************ -* * -\subsection{Public interfaces for Core printing (excluding instances)} -* * -************************************************************************ - -@pprParendCoreExpr@ puts parens around non-atomic Core expressions. --} - -pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc -pprCoreBinding :: OutputableBndr b => Bind b -> SDoc -pprCoreExpr :: OutputableBndr b => Expr b -> SDoc -pprParendExpr :: OutputableBndr b => Expr b -> SDoc - -pprCoreBindings = pprTopBinds noAnn -pprCoreBinding = pprTopBind noAnn - -pprCoreBindingsWithSize :: [CoreBind] -> SDoc -pprCoreBindingWithSize :: CoreBind -> SDoc - -pprCoreBindingsWithSize = pprTopBinds sizeAnn -pprCoreBindingWithSize = pprTopBind sizeAnn - -instance OutputableBndr b => Outputable (Bind b) where - ppr bind = ppr_bind noAnn bind - -instance OutputableBndr b => Outputable (Expr b) where - ppr expr = pprCoreExpr expr - -{- -************************************************************************ -* * -\subsection{The guts} -* * -************************************************************************ --} - --- | A function to produce an annotation for a given right-hand-side -type Annotation b = Expr b -> SDoc - --- | Annotate with the size of the right-hand-side -sizeAnn :: CoreExpr -> SDoc -sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) - --- | No annotation -noAnn :: Expr b -> SDoc -noAnn _ = empty - -pprTopBinds :: OutputableBndr a - => Annotation a -- ^ generate an annotation to place before the - -- binding - -> [Bind a] -- ^ bindings to show - -> SDoc -- ^ the pretty result -pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) - -pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc -pprTopBind ann (NonRec binder expr) - = ppr_binding ann (binder,expr) $$ blankLine - -pprTopBind _ (Rec []) - = text "Rec { }" -pprTopBind ann (Rec (b:bs)) - = vcat [text "Rec {", - ppr_binding ann b, - vcat [blankLine $$ ppr_binding ann b | b <- bs], - text "end Rec }", - blankLine] - -ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc - -ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) -ppr_bind ann (Rec binds) = vcat (map pp binds) - where - pp bind = ppr_binding ann bind <> semi - -ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc -ppr_binding ann (val_bdr, expr) - = sdocWithDynFlags $ \dflags -> - vcat [ ann expr - , if gopt Opt_SuppressTypeSignatures dflags - then empty - else pprBndr LetBind val_bdr - , pp_bind - ] - where - pp_bind = case bndrIsJoin_maybe val_bdr of - Nothing -> pp_normal_bind - Just ar -> pp_join_bind ar - - pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr) - - -- For a join point of join arity n, we want to print j = \x1 ... xn -> e - -- as "j x1 ... xn = e" to differentiate when a join point returns a - -- lambda (the first rendering looks like a nullary join point returning - -- an n-argument function). - pp_join_bind join_arity - | bndrs `lengthAtLeast` join_arity - = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs)) - 2 (equals <+> pprCoreExpr rhs) - | otherwise -- Yikes! A join-binding with too few lambda - -- Lint will complain, but we don't want to crash - -- the pretty-printer else we can't see what's wrong - -- So refer to printing j = e - = pp_normal_bind - where - (bndrs, body) = collectBinders expr - lhs_bndrs = take join_arity bndrs - rhs = mkLams (drop join_arity bndrs) body - -pprParendExpr expr = ppr_expr parens expr -pprCoreExpr expr = ppr_expr noParens expr - -noParens :: SDoc -> SDoc -noParens pp = pp - -pprOptCo :: Coercion -> SDoc --- Print a coercion optionally; i.e. honouring -dsuppress-coercions -pprOptCo co = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressCoercions dflags - then angleBrackets (text "Co:" <> int (coercionSize co)) - else parens (sep [ppr co, dcolon <+> ppr (coercionType co)]) - -ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc - -- The function adds parens in context that need - -- an atomic value (e.g. function args) - -ppr_expr add_par (Var name) - | isJoinId name = add_par ((text "jump") <+> ppr name) - | otherwise = ppr name -ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird -ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) -ppr_expr add_par (Lit lit) = pprLiteral add_par lit - -ppr_expr add_par (Cast expr co) - = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] - -ppr_expr add_par expr@(Lam _ _) - = let - (bndrs, body) = collectBinders expr - in - add_par $ - hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) - 2 (pprCoreExpr body) - -ppr_expr add_par expr@(App {}) - = sdocWithDynFlags $ \dflags -> - case collectArgs expr of { (fun, args) -> - let - pp_args = sep (map pprArg args) - val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples - pp_tup_args = pprWithCommas pprCoreExpr val_args - args' - | gopt Opt_SuppressTypeApplications dflags = val_args - | otherwise = args - parens - | null args' = id - | otherwise = add_par - in - case fun of - Var f -> case isDataConWorkId_maybe f of - -- Notice that we print the *worker* - -- for tuples in paren'd format. - Just dc | saturated - , Just sort <- tyConTuple_maybe tc - -> tupleParens sort pp_tup_args - where - tc = dataConTyCon dc - saturated = val_args `lengthIs` idArity f - - _ -> parens (hang fun_doc 2 pp_args) - where - fun_doc | isJoinId f = text "jump" <+> ppr f - | otherwise = ppr f - - _ -> parens (hang (pprParendExpr fun) 2 pp_args) - } - -ppr_expr add_par (Case expr var ty [(con,args,rhs)]) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PprCaseAsLet dflags - then add_par $ -- See Note [Print case as let] - sep [ sep [ text "let! {" - <+> ppr_case_pat con args - <+> text "~" - <+> ppr_bndr var - , text "<-" <+> ppr_expr id expr - <+> text "} in" ] - , pprCoreExpr rhs - ] - else add_par $ - sep [sep [sep [ text "case" <+> pprCoreExpr expr - , whenPprDebug (text "return" <+> ppr ty) - , text "of" <+> ppr_bndr var - ] - , char '{' <+> ppr_case_pat con args <+> arrow - ] - , pprCoreExpr rhs - , char '}' - ] - where - ppr_bndr = pprBndr CaseBind - -ppr_expr add_par (Case expr var ty alts) - = add_par $ - sep [sep [text "case" - <+> pprCoreExpr expr - <+> whenPprDebug (text "return" <+> ppr ty), - text "of" <+> ppr_bndr var <+> char '{'], - nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), - char '}' - ] - where - ppr_bndr = pprBndr CaseBind - - --- special cases: let ... in let ... --- ("disgusting" SLPJ) - -{- -ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) - = add_par $ - vcat [ - hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], - nest 2 (pprCoreExpr rhs), - text "} in", - pprCoreExpr body ] - -ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = add_par - (hang (text "let {") - 2 (hsep [ppr_binding (val_bdr,rhs), - text "} in"]) - $$ - pprCoreExpr expr) --} - - --- General case (recursive case, too) -ppr_expr add_par (Let bind expr) - = add_par $ - sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), - pprCoreExpr expr] - where - keyword (NonRec b _) - | isJust (bndrIsJoin_maybe b) = text "join" - | otherwise = text "let" - keyword (Rec pairs) - | ((b,_):_) <- pairs - , isJust (bndrIsJoin_maybe b) = text "joinrec" - | otherwise = text "letrec" - -ppr_expr add_par (Tick tickish expr) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressTicks dflags - then ppr_expr add_par expr - else add_par (sep [ppr tickish, pprCoreExpr expr]) - -pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc -pprCoreAlt (con, args, rhs) - = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) - -ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc -ppr_case_pat (DataAlt dc) args - | Just sort <- tyConTuple_maybe tc - = tupleParens sort (pprWithCommas ppr_bndr args) - where - ppr_bndr = pprBndr CasePatBind - tc = dataConTyCon dc - -ppr_case_pat con args - = ppr con <+> (fsep (map ppr_bndr args)) - where - ppr_bndr = pprBndr CasePatBind - - --- | Pretty print the argument in a function application. -pprArg :: OutputableBndr a => Expr a -> SDoc -pprArg (Type ty) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressTypeApplications dflags - then empty - else text "@" <+> pprParendType ty -pprArg (Coercion co) = text "@~" <+> pprOptCo co -pprArg expr = pprParendExpr expr - -{- -Note [Print case as let] -~~~~~~~~~~~~~~~~~~~~~~~~ -Single-branch case expressions are very common: - case x of y { I# x' -> - case p of q { I# p' -> ... } } -These are, in effect, just strict let's, with pattern matching. -With -dppr-case-as-let we print them as such: - let! { I# x' ~ y <- x } in - let! { I# p' ~ q <- p } in ... - - -Other printing bits-and-bobs used with the general @pprCoreBinding@ -and @pprCoreExpr@ functions. - - -Note [Binding-site specific printing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust -the information printed. - -Let-bound binders are printed with their full type and idInfo. - -Case-bound variables (both the case binder and pattern variables) are printed -without a type and without their unfolding. - -Furthermore, a dead case-binder is completely ignored, while otherwise, dead -binders are printed as "_". --} - --- These instances are sadly orphans - -instance OutputableBndr Var where - pprBndr = pprCoreBinder - pprInfixOcc = pprInfixName . varName - pprPrefixOcc = pprPrefixName . varName - bndrIsJoin_maybe = isJoinId_maybe - -instance Outputable b => OutputableBndr (TaggedBndr b) where - pprBndr _ b = ppr b -- Simple - pprInfixOcc b = ppr b - pprPrefixOcc b = ppr b - bndrIsJoin_maybe (TB b _) = isJoinId_maybe b - -pprCoreBinder :: BindingSite -> Var -> SDoc -pprCoreBinder LetBind binder - | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = pprTypedLetBinder binder $$ - ppIdInfo binder (idInfo binder) - --- Lambda bound type variables are preceded by "@" -pprCoreBinder bind_site bndr - = getPprStyle $ \ sty -> - pprTypedLamBinder bind_site (debugStyle sty) bndr - -pprUntypedBinder :: Var -> SDoc -pprUntypedBinder binder - | isTyVar binder = text "@" <+> ppr binder -- NB: don't print kind - | otherwise = pprIdBndr binder - -pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc --- For lambda and case binders, show the unfolding info (usually none) -pprTypedLamBinder bind_site debug_on var - = sdocWithDynFlags $ \dflags -> - case () of - _ - | not debug_on -- Show case-bound wild binders only if debug is on - , CaseBind <- bind_site - , isDeadBinder var -> empty - - | not debug_on -- Even dead binders can be one-shot - , isDeadBinder var -> char '_' <+> ppWhen (isId var) - (pprIdBndrInfo (idInfo var)) - - | not debug_on -- No parens, no kind info - , CaseBind <- bind_site -> pprUntypedBinder var - - | not debug_on - , CasePatBind <- bind_site -> pprUntypedBinder var - - | suppress_sigs dflags -> pprUntypedBinder var - - | isTyVar var -> parens (pprKindedTyVarBndr var) - - | otherwise -> parens (hang (pprIdBndr var) - 2 (vcat [ dcolon <+> pprType (idType var) - , pp_unf])) - where - suppress_sigs = gopt Opt_SuppressTypeSignatures - - unf_info = unfoldingInfo (idInfo var) - pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info - | otherwise = empty - -pprTypedLetBinder :: Var -> SDoc --- Print binder with a type or kind signature (not paren'd) -pprTypedLetBinder binder - = sdocWithDynFlags $ \dflags -> - case () of - _ - | isTyVar binder -> pprKindedTyVarBndr binder - | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder - | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) - -pprKindedTyVarBndr :: TyVar -> SDoc --- Print a type variable binder with its kind (but not if *) -pprKindedTyVarBndr tyvar - = text "@" <+> pprTyVar tyvar - --- pprIdBndr does *not* print the type --- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness -pprIdBndr :: Id -> SDoc -pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) - -pprIdBndrInfo :: IdInfo -> SDoc -pprIdBndrInfo info - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressIdInfo dflags) $ - info `seq` doc -- The seq is useful for poking on black holes - where - prag_info = inlinePragInfo info - occ_info = occInfo info - dmd_info = demandInfo info - lbv_info = oneShotInfo info - - has_prag = not (isDefaultInlinePragma prag_info) - has_occ = not (isManyOccs occ_info) - has_dmd = not $ isTopDmd dmd_info - has_lbv = not (hasNoOneShotInfo lbv_info) - - doc = showAttributes - [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) - , (has_occ, text "Occ=" <> ppr occ_info) - , (has_dmd, text "Dmd=" <> ppr dmd_info) - , (has_lbv , text "OS=" <> ppr lbv_info) - ] - -{- ------------------------------------------------------ --- IdDetails and IdInfo ------------------------------------------------------ --} - -ppIdInfo :: Id -> IdInfo -> SDoc -ppIdInfo id info - = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressIdInfo dflags) $ - showAttributes - [ (True, pp_scope <> ppr (idDetails id)) - , (has_arity, text "Arity=" <> int arity) - , (has_called_arity, text "CallArity=" <> int called_arity) - , (has_caf_info, text "Caf=" <> ppr caf_info) - , (has_str_info, text "Str=" <> pprStrictness str_info) - , (has_unf, text "Unf=" <> ppr unf_info) - , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) - ] -- Inline pragma, occ, demand, one-shot info - -- printed out with all binders (when debug is on); - -- see PprCore.pprIdBndr - where - pp_scope | isGlobalId id = text "GblId" - | isExportedId id = text "LclIdX" - | otherwise = text "LclId" - - arity = arityInfo info - has_arity = arity /= 0 - - called_arity = callArityInfo info - has_called_arity = called_arity /= 0 - - caf_info = cafInfo info - has_caf_info = not (mayHaveCafRefs caf_info) - - str_info = strictnessInfo info - has_str_info = not (isTopSig str_info) - - unf_info = unfoldingInfo info - has_unf = hasSomeUnfolding unf_info - - rules = ruleInfoRules (ruleInfo info) - -showAttributes :: [(Bool,SDoc)] -> SDoc -showAttributes stuff - | null docs = empty - | otherwise = brackets (sep (punctuate comma docs)) - where - docs = [d | (True,d) <- stuff] - -{- ------------------------------------------------------ --- Unfolding and UnfoldingGuidance ------------------------------------------------------ --} - -instance Outputable UnfoldingGuidance where - ppr UnfNever = text "NEVER" - ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) - = text "ALWAYS_IF" <> - parens (text "arity=" <> int arity <> comma <> - text "unsat_ok=" <> ppr unsat_ok <> comma <> - text "boring_ok=" <> ppr boring_ok) - ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) - = hsep [ text "IF_ARGS", - brackets (hsep (map int cs)), - int size, - int discount ] - -instance Outputable UnfoldingSource where - ppr InlineCompulsory = text "Compulsory" - ppr InlineStable = text "InlineStable" - ppr InlineRhs = text "" - -instance Outputable Unfolding where - ppr NoUnfolding = text "No unfolding" - ppr BootUnfolding = text "No unfolding (from boot)" - ppr (OtherCon cs) = text "OtherCon" <+> ppr cs - ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = hang (text "DFun:" <+> ptext (sLit "\\") - <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) - 2 (ppr con <+> sep (map ppr args)) - ppr (CoreUnfolding { uf_src = src - , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf - , uf_is_conlike=conlike, uf_is_work_free=wf - , uf_expandable=exp, uf_guidance=g }) - = text "Unf" <> braces (pp_info $$ pp_rhs) - where - pp_info = fsep $ punctuate comma - [ text "Src=" <> ppr src - , text "TopLvl=" <> ppr top - , text "Value=" <> ppr hnf - , text "ConLike=" <> ppr conlike - , text "WorkFree=" <> ppr wf - , text "Expandable=" <> ppr exp - , text "Guidance=" <> ppr g ] - pp_tmpl = sdocWithDynFlags $ \dflags -> - ppUnless (gopt Opt_SuppressUnfoldings dflags) $ - text "Tmpl=" <+> ppr rhs - pp_rhs | isStableSource src = pp_tmpl - | otherwise = empty - -- Don't print the RHS or we get a quadratic - -- blowup in the size of the printout! - -{- ------------------------------------------------------ --- Rules ------------------------------------------------------ --} - -instance Outputable CoreRule where - ppr = pprRule - -pprRules :: [CoreRule] -> SDoc -pprRules rules = vcat (map pprRule rules) - -pprRule :: CoreRule -> SDoc -pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) - -pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, - ru_bndrs = tpl_vars, ru_args = tpl_args, - ru_rhs = rhs }) - = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [text "forall" <+> - sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, - nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (text "=" <+> pprCoreExpr rhs) - ]) - -{- ------------------------------------------------------ --- Tickish ------------------------------------------------------ --} - -instance Outputable id => Outputable (Tickish id) where - ppr (HpcTick modl ix) = - hcat [text "hpc<", - ppr modl, comma, - ppr ix, - text ">"] - ppr (Breakpoint ix vars) = - hcat [text "break<", - ppr ix, - text ">", - parens (hcat (punctuate comma (map ppr vars)))] - ppr (ProfNote { profNoteCC = cc, - profNoteCount = tick, - profNoteScope = scope }) = - case (tick,scope) of - (True,True) -> hcat [text "scctick<", ppr cc, char '>'] - (True,False) -> hcat [text "tick<", ppr cc, char '>'] - _ -> hcat [text "scc<", ppr cc, char '>'] - ppr (SourceNote span _) = - hcat [ text "src<", pprUserRealSpan True span, char '>'] - diff --git a/deSugar/Coverage.hs b/deSugar/Coverage.hs deleted file mode 100644 --- a/deSugar/Coverage.hs +++ /dev/null @@ -1,1368 +0,0 @@ -{- -(c) Galois, 2006 -(c) University of Glasgow, 2007 --} - -{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} - -module Coverage (addTicksToBinds, hpcInitCode) where - -import GhcPrelude as Prelude - -import qualified GHCi -import GHCi.RemoteTypes -import Data.Array -import ByteCodeTypes -import GHC.Stack.CCS -import Type -import GHC.Hs -import Module -import Outputable -import DynFlags -import ConLike -import Control.Monad -import SrcLoc -import ErrUtils -import NameSet hiding (FreeVars) -import Name -import Bag -import CostCentre -import CostCentreState -import CoreSyn -import Id -import VarSet -import Data.List -import FastString -import HscTypes -import TyCon -import BasicTypes -import MonadUtils -import Maybes -import CLabel -import Util - -import Data.Time -import System.Directory - -import Trace.Hpc.Mix -import Trace.Hpc.Util - -import qualified Data.ByteString as BS -import Data.Map (Map) -import qualified Data.Map as Map - -{- -************************************************************************ -* * -* The main function: addTicksToBinds -* * -************************************************************************ --} - -addTicksToBinds - :: HscEnv - -> Module - -> ModLocation -- ... off the current module - -> NameSet -- Exported Ids. When we call addTicksToBinds, - -- isExportedId doesn't work yet (the desugarer - -- hasn't set it), so we have to work from this set. - -> [TyCon] -- Type constructor in this module - -> LHsBinds GhcTc - -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) - -addTicksToBinds hsc_env mod mod_loc exports tyCons binds - | let dflags = hsc_dflags hsc_env - passes = coveragePasses dflags, not (null passes), - Just orig_file <- ml_hs_file mod_loc, - not ("boot" `isSuffixOf` orig_file) = do - - let orig_file2 = guessSourceFile binds orig_file - - tickPass tickish (binds,st) = - let env = TTE - { fileName = mkFastString orig_file2 - , declPath = [] - , tte_dflags = dflags - , exports = exports - , inlines = emptyVarSet - , inScope = emptyVarSet - , blackList = Map.fromList - [ (getSrcSpan (tyConName tyCon),()) - | tyCon <- tyCons ] - , density = mkDensity tickish dflags - , this_mod = mod - , tickishType = tickish - } - (binds',_,st') = unTM (addTickLHsBinds binds) env st - in (binds', st') - - initState = TT { tickBoxCount = 0 - , mixEntries = [] - , ccIndices = newCostCentreState - } - - (binds1,st) = foldr tickPass (binds, initState) passes - - let tickCount = tickBoxCount st - entries = reverse $ mixEntries st - hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 - modBreaks <- mkModBreaks hsc_env mod tickCount entries - - dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1) - - return (binds1, HpcInfo tickCount hashNo, modBreaks) - - | otherwise = return (binds, emptyHpcInfo False, Nothing) - -guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath -guessSourceFile binds orig_file = - -- Try look for a file generated from a .hsc file to a - -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest -> - srcSpanFileName_maybe pos : rest) [] binds - in - case top_pos of - (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name - -> unpackFS file_name - _ -> orig_file - - -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks) -mkModBreaks hsc_env mod count entries - | breakpointsEnabled (hsc_dflags hsc_env) = do - breakArray <- GHCi.newBreakArray hsc_env (length entries) - ccs <- mkCCSArray hsc_env mod count entries - let - locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] - varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] - declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] - return $ Just $ emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs - } - | otherwise = return Nothing - -mkCCSArray - :: HscEnv -> Module -> Int -> [MixEntry_] - -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) -mkCCSArray hsc_env modul count entries = do - if interpreterProfiled dflags - then do - let module_str = moduleNameString (moduleName modul) - costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries) - return (listArray (0,count-1) costcentres) - else do - return (listArray (0,-1) []) - where - dflags = hsc_dflags hsc_env - mk_one (srcspan, decl_path, _, _) = (name, src) - where name = concat (intersperse "." decl_path) - src = showSDoc dflags (ppr srcspan) - - -writeMixEntries - :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int -writeMixEntries dflags mod count entries filename - | not (gopt Opt_Hpc dflags) = return 0 - | otherwise = do - let - hpc_dir = hpcDir dflags - mod_name = moduleNameString (moduleName mod) - - hpc_mod_dir - | moduleUnitId mod == mainUnitId = hpc_dir - | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod) - - tabStop = 8 -- counts as a normal char in GHC's - -- location ranges. - - createDirectoryIfMissing True hpc_mod_dir - modTime <- getModificationUTCTime filename - let entries' = [ (hpcPos, box) - | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] - when (entries' `lengthIsNot` count) $ do - panic "the number of .mix entries are inconsistent" - let hashNo = mixHash filename modTime tabStop entries' - mixCreate hpc_mod_dir mod_name - $ Mix filename modTime (toHash hashNo) tabStop entries' - return hashNo - - --- ----------------------------------------------------------------------------- --- TickDensity: where to insert ticks - -data TickDensity - = TickForCoverage -- for Hpc - | TickForBreakPoints -- for GHCi - | TickAllFunctions -- for -prof-auto-all - | TickTopFunctions -- for -prof-auto-top - | TickExportedFunctions -- for -prof-auto-exported - | TickCallSites -- for stack tracing - deriving Eq - -mkDensity :: TickishType -> DynFlags -> TickDensity -mkDensity tickish dflags = case tickish of - HpcTicks -> TickForCoverage - SourceNotes -> TickForCoverage - Breakpoints -> TickForBreakPoints - ProfNotes -> - case profAuto dflags of - ProfAutoAll -> TickAllFunctions - ProfAutoTop -> TickTopFunctions - ProfAutoExports -> TickExportedFunctions - ProfAutoCalls -> TickCallSites - _other -> panic "mkDensity" - --- | Decide whether to add a tick to a binding or not. -shouldTickBind :: TickDensity - -> Bool -- top level? - -> Bool -- exported? - -> Bool -- simple pat bind? - -> Bool -- INLINE pragma? - -> Bool - -shouldTickBind density top_lev exported _simple_pat inline - = case density of - TickForBreakPoints -> False - -- we never add breakpoints to simple pattern bindings - -- (there's always a tick on the rhs anyway). - TickAllFunctions -> not inline - TickTopFunctions -> top_lev && not inline - TickExportedFunctions -> exported && not inline - TickForCoverage -> True - TickCallSites -> False - -shouldTickPatBind :: TickDensity -> Bool -> Bool -shouldTickPatBind density top_lev - = case density of - TickForBreakPoints -> False - TickAllFunctions -> True - TickTopFunctions -> top_lev - TickExportedFunctions -> False - TickForCoverage -> False - TickCallSites -> False - --- ----------------------------------------------------------------------------- --- Adding ticks to bindings - -addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) -addTickLHsBinds = mapBagM addTickLHsBind - -addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) -addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds, - abs_exports = abs_exports })) = do - withEnv add_exports $ do - withEnv add_inlines $ do - binds' <- addTickLHsBinds binds - return $ cL pos $ bind { abs_binds = binds' } - where - -- in AbsBinds, the Id on each binding is not the actual top-level - -- Id that we are defining, they are related by the abs_exports - -- field of AbsBinds. So if we're doing TickExportedFunctions we need - -- to add the local Ids to the set of exported Names so that we know to - -- tick the right bindings. - add_exports env = - env{ exports = exports env `extendNameSetList` - [ idName mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , idName pid `elemNameSet` (exports env) ] } - - -- See Note [inline sccs] - add_inlines env = - env{ inlines = inlines env `extendVarSetList` - [ mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , isInlinePragma (idInlinePragma pid) ] } - -addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do - let name = getOccString id - decl_path <- getPathEntry - density <- getDensity - - inline_ids <- liftM inlines getEnv - -- See Note [inline sccs] - let inline = isInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids - - -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - if inline && tickish == ProfNotes then return (cL pos funBind) else do - - (fvs, mg) <- - getFreeVars $ - addPathEntry name $ - addTickMatchGroup False (fun_matches funBind) - - case mg of - MG {} -> return () - _ -> panic "addTickLHsBind" - - blackListed <- isBlackListed pos - exported_names <- liftM exports getEnv - - -- We don't want to generate code for blacklisted positions - -- We don't want redundant ticks on simple pattern bindings - -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = isSimplePatBind funBind - toplev = null decl_path - exported = idName id `elemNameSet` exported_names - - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline - then - bindTick density name pos fvs - else - return Nothing - - let mbCons = maybe Prelude.id (:) - return $ cL pos $ funBind { fun_matches = mg - , fun_tick = tick `mbCons` fun_tick funBind } - - where - -- a binding is a simple pattern binding if it is a funbind with - -- zero patterns - isSimplePatBind :: HsBind GhcTc -> Bool - isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 - --- TODO: Revisit this -addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs - , pat_rhs = rhs }))) = do - let name = "(...)" - (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs - let pat' = pat { pat_rhs = rhs'} - - -- Should create ticks here? - density <- getDensity - decl_path <- getPathEntry - let top_lev = null decl_path - if not (shouldTickPatBind density top_lev) - then return (cL pos pat') - else do - - -- Allocate the ticks - rhs_tick <- bindTick density name pos fvs - let patvars = map getOccString (collectPatBinders lhs) - patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars - - -- Add to pattern - let mbCons = maybe id (:) - rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat') - patvar_tickss = zipWith mbCons patvar_ticks - (snd (pat_ticks pat') ++ repeat []) - return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } - --- Only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind -addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind -addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind -addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884 - - - -bindTick - :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) -bindTick density name pos fvs = do - decl_path <- getPathEntry - let - toplev = null decl_path - count_entries = toplev || density == TickAllFunctions - top_only = density /= TickAllFunctions - box_label = if toplev then TopLevelBox [name] - else LocalBox (decl_path ++ [name]) - -- - allocATickBox box_label count_entries top_only pos fvs - - --- Note [inline sccs] --- --- The reason not to add ticks to INLINE functions is that this is --- sometimes handy for avoiding adding a tick to a particular function --- (see #6131) --- --- So for now we do not add any ticks to INLINE functions at all. --- --- We used to use isAnyInlinePragma to figure out whether to avoid adding --- ticks for this purpose. However, #12962 indicates that this contradicts --- the documentation on profiling (which only mentions INLINE pragmas). --- So now we're more careful about what we avoid adding ticks to. - --- ----------------------------------------------------------------------------- --- Decorate an LHsExpr with ticks - --- selectively add ticks to interesting expressions -addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExpr e@(dL->L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- Add a tick to an expression which is the RHS of an equation or a binding. --- We always consider these to be breakpoints, unless the expression is a 'let' --- (because the body will definitely have a tick somewhere). ToDo: perhaps --- we should treat 'case' and 'if' the same way? -addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprRHS e@(dL->L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- The inner expression of an evaluation context: --- let binds in [], ( [] ) --- we never tick these if we're doing HPC, but otherwise --- we treat it like an ordinary expression. -addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprEvalInner e = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprNever e - _otherwise -> addTickLHsExpr e - --- | A let body is treated differently from addTickLHsExprEvalInner --- above with TickForBreakPoints, because for breakpoints we always --- want to tick the body, even if it is not a redex. See test --- break012. This gives the user the opportunity to inspect the --- values of the let-bound variables. -addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprLetBody e@(dL->L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - _other -> addTickLHsExprEvalInner e - where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- version of addTick that does not actually add a tick, --- because the scope of this tick is completely subsumed by --- another. -addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprNever (dL->L pos e0) = do - e1 <- addTickHsExpr e0 - return $ cL pos e1 - --- general heuristic: expressions which do not denote values are good --- break points -isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (HsApp {}) = True -isGoodBreakExpr (HsAppType {}) = True -isGoodBreakExpr (OpApp {}) = True -isGoodBreakExpr _other = False - -isCallSite :: HsExpr GhcTc -> Bool -isCallSite HsApp{} = True -isCallSite HsAppType{} = True -isCallSite OpApp{} = True -isCallSite _ = False - -addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany (dL->L pos e0) - = ifDensity TickForCoverage - (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) - (addTickLHsExpr (cL pos e0)) - -addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (dL->L pos e0) - = ifDensity TickForCoverage - (allocBinTickBox boxLabel pos $ addTickHsExpr e0) - (addTickLHsExpr (cL pos e0)) - - --- ----------------------------------------------------------------------------- --- Decorate the body of an HsExpr with ticks. --- (Whether to put a tick around the whole expression was already decided, --- in the addTickLHsExpr family of functions.) - -addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e -addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" -addTickHsExpr e@(HsConLikeOut _ con) - | Just id <- conLikeWrapId_maybe con = do freeVar id; return e -addTickHsExpr e@(HsIPVar {}) = return e -addTickHsExpr e@(HsOverLit {}) = return e -addTickHsExpr e@(HsOverLabel{}) = return e -addTickHsExpr e@(HsLit {}) = return e -addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x) - (addTickMatchGroup True matchgroup) -addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) - (addTickMatchGroup True mgs) -addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x) - (addTickLHsExprNever e) - (return ty) - -addTickHsExpr (OpApp fix e1 e2 e3) = - liftM4 OpApp - (return fix) - (addTickLHsExpr e1) - (addTickLHsExprNever e2) - (addTickLHsExpr e3) -addTickHsExpr (NegApp x e neg) = - liftM2 (NegApp x) - (addTickLHsExpr e) - (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar x e) = - liftM (HsPar x) (addTickLHsExprEvalInner e) -addTickHsExpr (SectionL x e1 e2) = - liftM2 (SectionL x) - (addTickLHsExpr e1) - (addTickLHsExprNever e2) -addTickHsExpr (SectionR x e1 e2) = - liftM2 (SectionR x) - (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (ExplicitTuple x es boxity) = - liftM2 (ExplicitTuple x) - (mapM addTickTupArg es) - (return boxity) -addTickHsExpr (ExplicitSum ty tag arity e) = do - e' <- addTickLHsExpr e - return (ExplicitSum ty tag arity e') -addTickHsExpr (HsCase x e mgs) = - liftM2 (HsCase x) - (addTickLHsExpr e) -- not an EvalInner; e might not necessarily - -- be evaluated. - (addTickMatchGroup False mgs) -addTickHsExpr (HsIf x cnd e1 e2 e3) = - liftM3 (HsIf x cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsExprOptAlt True e2) - (addTickLHsExprOptAlt True e3) -addTickHsExpr (HsMultiIf ty alts) - = do { let isOneOfMany = case alts of [_] -> False; _ -> True - ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts - ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x (dL->L l binds) e) = - bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet x . cL l) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsExprLetBody e) -addTickHsExpr (HsDo srcloc cxt (dL->L l stmts)) - = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo srcloc cxt (cL l stmts')) } - where - forQual = case cxt of - ListComp -> Just $ BinBox QualBinBox - _ -> Nothing -addTickHsExpr (ExplicitList ty wit es) = - liftM3 ExplicitList - (return ty) - (addTickWit wit) - (mapM (addTickLHsExpr) es) - where addTickWit Nothing = return Nothing - addTickWit (Just fln) - = do fln' <- addTickSyntaxExpr hpcSrcSpan fln - return (Just fln') - -addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e - -addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) - = do { rec_binds' <- addTickHsRecordBinds rec_binds - ; return (expr { rcon_flds = rec_binds' }) } - -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) - = do { e' <- addTickLHsExpr e - ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = flds' }) } - -addTickHsExpr (ExprWithTySig x e ty) = - liftM3 ExprWithTySig - (return x) - (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures - (return ty) -addTickHsExpr (ArithSeq ty wit arith_seq) = - liftM3 ArithSeq - (return ty) - (addTickWit wit) - (addTickArithSeqInfo arith_seq) - where addTickWit Nothing = return Nothing - addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl - return (Just fl') - --- We might encounter existing ticks (multiple Coverage passes) -addTickHsExpr (HsTick x t e) = - liftM (HsTick x t) (addTickLHsExprNever e) -addTickHsExpr (HsBinTick x t0 t1 e) = - liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) - -addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do - e2 <- allocTickBox (ExpBox False) False False pos $ - addTickHsExpr e0 - return $ unLoc e2 -addTickHsExpr (HsSCC x src nm e) = - liftM3 (HsSCC x) - (return src) - (return nm) - (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn x src nm e) = - liftM3 (HsCoreAnn x) - (return src) - (return nm) - (addTickLHsExpr e) -addTickHsExpr e@(HsBracket {}) = return e -addTickHsExpr e@(HsTcBracketOut {}) = return e -addTickHsExpr e@(HsRnBracketOut {}) = return e -addTickHsExpr e@(HsSpliceE {}) = return e -addTickHsExpr (HsProc x pat cmdtop) = - liftM2 (HsProc x) - (addTickLPat pat) - (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (HsWrap x w e) = - liftM2 (HsWrap x) - (return w) - (addTickHsExpr e) -- Explicitly no tick on inside - --- Others should never happen in expression content. -addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) - -addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e - ; return (cL l (Present x e')) } -addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty)) -addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec -addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884 - - -addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) - -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do - let isOneOfMany = matchesOneOfMany matches - matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = cL l matches' } -addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec - -addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) - -> TM (Match GhcTc (LHsExpr GhcTc)) -addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats - , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do - gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs - return $ match { m_grhss = gRHSs' } -addTickMatch _ _ (XMatch nec) = noExtCon nec - -addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) - -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs x guarded' (cL l local_binds') - where - binders = collectLocalBinders local_binds -addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec - -addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) - -> TM (GRHS GhcTc (LHsExpr GhcTc)) -addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do - (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts - (addTickGRHSBody isOneOfMany isLambda expr) - return $ GRHS x stmts' expr' -addTickGRHS _ _ (XGRHS nec) = noExtCon nec - -addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr - TickAllFunctions | isLambda -> - addPathEntry "\\" $ - allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ - addTickHsExpr e0 - _otherwise -> - addTickLHsExprRHS expr - -addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] - -> TM [ExprLStmt GhcTc] -addTickLStmts isGuard stmts = do - (stmts, _) <- addTickLStmts' isGuard stmts (return ()) - return stmts - -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a - -> TM ([ExprLStmt GhcTc], a) -addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders lstmts) $ - do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts - ; a <- res - ; return (lstmts', a) } - -addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) - -> TM (Stmt GhcTc (LHsExpr GhcTc)) -addTickStmt _isGuard (LastStmt x e noret ret) = do - liftM3 (LastStmt x) - (addTickLHsExpr e) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt x pat e bind fail) = do - liftM4 (BindStmt x) - (addTickLPat pat) - (addTickLHsExprRHS e) - (addTickSyntaxExpr hpcSrcSpan bind) - (addTickSyntaxExpr hpcSrcSpan fail) -addTickStmt isGuard (BodyStmt x e bind' guard') = do - liftM3 (BodyStmt x) - (addTick isGuard e) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do - liftM (LetStmt x . cL l) - (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do - liftM3 (ParStmt x) - (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr)) - (addTickSyntaxExpr hpcSrcSpan bindExpr) -addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do - args' <- mapM (addTickApplicativeArg isGuard) args - return (ApplicativeStmt body_ty args' mb_join) - -addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts - , trS_by = by, trS_using = using - , trS_ret = returnExpr, trS_bind = bindExpr - , trS_fmap = liftMExpr }) = do - t_s <- addTickLStmts isGuard stmts - t_y <- fmapMaybeM addTickLHsExprRHS by - t_u <- addTickLHsExprRHS using - t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr - t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr)) - return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u - , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } - -addTickStmt isGuard stmt@(RecStmt {}) - = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } - -addTickStmt _ (XStmtLR nec) = noExtCon nec - -addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e - | otherwise = addTickLHsExprRHS e - -addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -addTickApplicativeArg isGuard (op, arg) = - liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) - where - addTickArg (ApplicativeArgOne x pat expr isBody fail) = - (ApplicativeArgOne x) - <$> addTickLPat pat - <*> addTickLHsExpr expr - <*> pure isBody - <*> addTickSyntaxExpr hpcSrcSpan fail - addTickArg (ApplicativeArgMany x stmts ret pat) = - (ApplicativeArgMany x) - <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret)) - <*> addTickLPat pat - addTickArg (XApplicativeArg nec) = noExtCon nec - -addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc - -> TM (ParStmtBlock GhcTc GhcTc) -addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = - liftM3 (ParStmtBlock x) - (addTickLStmts isGuard stmts) - (return ids) - (addTickSyntaxExpr hpcSrcSpan returnExpr) -addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec - -addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) -addTickHsLocalBinds (HsValBinds x binds) = - liftM (HsValBinds x) - (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds x binds) = - liftM (HsIPBinds x) - (addTickHsIPBinds binds) -addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) -addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x) - -addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) - -> TM (HsValBindsLR GhcTc (GhcPass b)) -addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do - b <- liftM2 NValBinds - (mapM (\ (rec,binds') -> - liftM2 (,) - (return rec) - (addTickLHsBinds binds')) - binds) - (return sigs) - return $ XValBindsLR b -addTickHsValBinds _ = panic "addTickHsValBinds" - -addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) -addTickHsIPBinds (IPBinds dictbinds ipbinds) = - liftM2 IPBinds - (return dictbinds) - (mapM (liftL (addTickIPBind)) ipbinds) -addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x) - -addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) -addTickIPBind (IPBind x nm e) = - liftM2 (IPBind x) - (return nm) - (addTickLHsExpr e) -addTickIPBind (XIPBind x) = return (XIPBind x) - --- There is no location here, so we might need to use a context location?? -addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) -addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do - x' <- fmap unLoc (addTickLHsExpr (cL pos x)) - return $ syn { syn_expr = x' } --- we do not walk into patterns. -addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) -addTickLPat pat = return pat - -addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) -addTickHsCmdTop (HsCmdTop x cmd) = - liftM2 HsCmdTop - (return x) - (addTickLHsCmd cmd) -addTickHsCmdTop (XCmdTop nec) = noExtCon nec - -addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) -addTickLHsCmd (dL->L pos c0) = do - c1 <- addTickHsCmd c0 - return $ cL pos c1 - -addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam x matchgroup) = - liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp x c e) = - liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) -{- -addTickHsCmd (OpApp e1 c2 fix c3) = - liftM4 OpApp - (addTickLHsExpr e1) - (addTickLHsCmd c2) - (return fix) - (addTickLHsCmd c3) --} -addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) -addTickHsCmd (HsCmdCase x e mgs) = - liftM2 (HsCmdCase x) - (addTickLHsExpr e) - (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = - liftM3 (HsCmdIf x cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsCmd c2) - (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x (dL->L l binds) c) = - bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet x . cL l) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsCmd c) -addTickHsCmd (HsCmdDo srcloc (dL->L l stmts)) - = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo srcloc (cL l stmts')) } - -addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = - liftM5 HsCmdArrApp - (return arr_ty) - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (return ty1) - (return lr) -addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = - liftM4 (HsCmdArrForm x) - (addTickLHsExpr e) - (return f) - (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) - -addTickHsCmd (HsCmdWrap x w cmd) - = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) - -addTickHsCmd (XCmd nec) = noExtCon nec - --- Others should never happen in a command context. ---addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) - -addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) - -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) -addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do - matches' <- mapM (liftL addTickCmdMatch) matches - return $ mg { mg_alts = cL l matches' } -addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec - -addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) -addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = - bindLocals (collectPatsBinders pats) $ do - gRHSs' <- addTickCmdGRHSs gRHSs - return $ match { m_grhss = gRHSs' } -addTickCmdMatch (XMatch nec) = noExtCon nec - -addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs x guarded' (cL l local_binds') - where - binders = collectLocalBinders local_binds -addTickCmdGRHSs (XGRHSs nec) = noExtCon nec - -addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) --- The *guards* are *not* Cmds, although the body is --- C.f. addTickGRHS for the BinBox stuff -addTickCmdGRHS (GRHS x stmts cmd) - = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) - stmts (addTickLHsCmd cmd) - ; return $ GRHS x stmts' expr' } -addTickCmdGRHS (XGRHS nec) = noExtCon nec - -addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] - -> TM [LStmt GhcTc (LHsCmd GhcTc)] -addTickLCmdStmts stmts = do - (stmts, _) <- addTickLCmdStmts' stmts (return ()) - return stmts - -addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a - -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) -addTickLCmdStmts' lstmts res - = bindLocals binders $ do - lstmts' <- mapM (liftL addTickCmdStmt) lstmts - a <- res - return (lstmts', a) - where - binders = collectLStmtsBinders lstmts - -addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) -addTickCmdStmt (BindStmt x pat c bind fail) = do - liftM4 (BindStmt x) - (addTickLPat pat) - (addTickLHsCmd c) - (return bind) - (return fail) -addTickCmdStmt (LastStmt x c noret ret) = do - liftM3 (LastStmt x) - (addTickLHsCmd c) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (BodyStmt x c bind' guard') = do - liftM3 (BodyStmt x) - (addTickLHsCmd c) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x (dL->L l binds)) = do - liftM (LetStmt x . cL l) - (addTickHsLocalBinds binds) -addTickCmdStmt stmt@(RecStmt {}) - = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTickCmdStmt ApplicativeStmt{} = - panic "ToDo: addTickCmdStmt ApplicativeLastStmt" -addTickCmdStmt (XStmtLR nec) = - noExtCon nec - --- Others should never happen in a command context. -addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) - -addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc) -addTickHsRecordBinds (HsRecFields fields dd) - = do { fields' <- mapM addTickHsRecField fields - ; return (HsRecFields fields' dd) } - -addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) - -> TM (LHsRecField' id (LHsExpr GhcTc)) -addTickHsRecField (dL->L l (HsRecField id expr pun)) - = do { expr' <- addTickLHsExpr expr - ; return (cL l (HsRecField id expr' pun)) } - - -addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) -addTickArithSeqInfo (From e1) = - liftM From - (addTickLHsExpr e1) -addTickArithSeqInfo (FromThen e1 e2) = - liftM2 FromThen - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromTo e1 e2) = - liftM2 FromTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromThenTo e1 e2 e3) = - liftM3 FromThenTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (addTickLHsExpr e3) - -data TickTransState = TT { tickBoxCount:: Int - , mixEntries :: [MixEntry_] - , ccIndices :: CostCentreState - } - -data TickTransEnv = TTE { fileName :: FastString - , density :: TickDensity - , tte_dflags :: DynFlags - , exports :: NameSet - , inlines :: VarSet - , declPath :: [String] - , inScope :: VarSet - , blackList :: Map SrcSpan () - , this_mod :: Module - , tickishType :: TickishType - } - --- deriving Show - -data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes - deriving (Eq) - -coveragePasses :: DynFlags -> [TickishType] -coveragePasses dflags = - ifa (breakpointsEnabled dflags) Breakpoints $ - ifa (gopt Opt_Hpc dflags) HpcTicks $ - ifa (gopt Opt_SccProfilingOn dflags && - profAuto dflags /= NoProfAuto) ProfNotes $ - ifa (debugLevel dflags > 0) SourceNotes [] - where ifa f x xs | f = x:xs - | otherwise = xs - --- | Should we produce 'Breakpoint' ticks? -breakpointsEnabled :: DynFlags -> Bool -breakpointsEnabled dflags = hscTarget dflags == HscInterpreted - --- | Tickishs that only make sense when their source code location --- refers to the current file. This might not always be true due to --- LINE pragmas in the code - which would confuse at least HPC. -tickSameFileOnly :: TickishType -> Bool -tickSameFileOnly HpcTicks = True -tickSameFileOnly _other = False - -type FreeVars = OccEnv Id -noFVs :: FreeVars -noFVs = emptyOccEnv - --- Note [freevars] --- For breakpoints we want to collect the free variables of an --- expression for pinning on the HsTick. We don't want to collect --- *all* free variables though: in particular there's no point pinning --- on free variables that are will otherwise be in scope at the GHCi --- prompt, which means all top-level bindings. Unfortunately detecting --- top-level bindings isn't easy (collectHsBindsBinders on the top-level --- bindings doesn't do it), so we keep track of a set of "in-scope" --- variables in addition to the free variables, and the former is used --- to filter additions to the latter. This gives us complete control --- over what free variables we track. - -newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } - deriving (Functor) - -- a combination of a state monad (TickTransState) and a writer - -- monad (FreeVars). - -instance Applicative TM where - pure a = TM $ \ _env st -> (a,noFVs,st) - (<*>) = ap - -instance Monad TM where - (TM m) >>= k = TM $ \ env st -> - case m env st of - (r1,fv1,st1) -> - case unTM (k r1) env st1 of - (r2,fv2,st2) -> - (r2, fv1 `plusOccEnv` fv2, st2) - -instance HasDynFlags TM where - getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) - --- | Get the next HPC cost centre index for a given centre name -getCCIndexM :: FastString -> TM CostCentreIndex -getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ - ccIndices st - in (idx, noFVs, st { ccIndices = is' }) - -getState :: TM TickTransState -getState = TM $ \ _ st -> (st, noFVs, st) - -setState :: (TickTransState -> TickTransState) -> TM () -setState f = TM $ \ _ st -> ((), noFVs, f st) - -getEnv :: TM TickTransEnv -getEnv = TM $ \ env st -> (env, noFVs, st) - -withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a -withEnv f (TM m) = TM $ \ env st -> - case m (f env) st of - (a, fvs, st') -> (a, fvs, st') - -getDensity :: TM TickDensity -getDensity = TM $ \env st -> (density env, noFVs, st) - -ifDensity :: TickDensity -> TM a -> TM a -> TM a -ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el - -getFreeVars :: TM a -> TM (FreeVars, a) -getFreeVars (TM m) - = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') - -freeVar :: Id -> TM () -freeVar id = TM $ \ env st -> - if id `elemVarSet` inScope env - then ((), unitOccEnv (nameOccName (idName id)) id, st) - else ((), noFVs, st) - -addPathEntry :: String -> TM a -> TM a -addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) - -getPathEntry :: TM [String] -getPathEntry = declPath `liftM` getEnv - -getFileName :: TM FastString -getFileName = fileName `liftM` getEnv - -isGoodSrcSpan' :: SrcSpan -> Bool -isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False - -isGoodTickSrcSpan :: SrcSpan -> TM Bool -isGoodTickSrcSpan pos = do - file_name <- getFileName - tickish <- tickishType `liftM` getEnv - let need_same_file = tickSameFileOnly tickish - same_file = Just file_name == srcSpanFileName_maybe pos - return (isGoodSrcSpan' pos && (not need_same_file || same_file)) - -ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a -ifGoodTickSrcSpan pos then_code else_code = do - good <- isGoodTickSrcSpan pos - if good then then_code else else_code - -bindLocals :: [Id] -> TM a -> TM a -bindLocals new_ids (TM m) - = TM $ \ env st -> - case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] - -isBlackListed :: SrcSpan -> TM Bool -isBlackListed pos = TM $ \ env st -> - case Map.lookup pos (blackList env) of - Nothing -> (False,noFVs,st) - Just () -> (True,noFVs,st) - --- the tick application inherits the source position of its --- expression argument to support nested box allocations -allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) - -> TM (LHsExpr GhcTc) -allocTickBox boxLabel countEntries topOnly pos m = - ifGoodTickSrcSpan pos (do - (fvs, e) <- getFreeVars m - env <- getEnv - tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (cL pos (HsTick noExtField tickish (cL pos e))) - ) (do - e <- m - return (cL pos e) - ) - --- the tick application inherits the source position of its --- expression argument to support nested box allocations -allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars - -> TM (Maybe (Tickish Id)) -allocATickBox boxLabel countEntries topOnly pos fvs = - ifGoodTickSrcSpan pos (do - let - mydecl_path = case boxLabel of - TopLevelBox x -> x - LocalBox xs -> xs - _ -> panic "allocATickBox" - tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path - return (Just tickish) - ) (return Nothing) - - -mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] - -> TM (Tickish Id) -mkTickish boxLabel countEntries topOnly pos fvs decl_path = do - - let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs - -- unlifted types cause two problems here: - -- * we can't bind them at the GHCi prompt - -- (bindLocalsAtBreakpoint already fliters them out), - -- * the simplifier might try to substitute a literal for - -- the Id, and we can't handle that. - - me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) - - cc_name | topOnly = head decl_path - | otherwise = concat (intersperse "." decl_path) - - dflags <- getDynFlags - env <- getEnv - case tickishType env of - HpcTicks -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me : mixEntries st } - return $ HpcTick (this_mod env) c - - ProfNotes -> do - let nm = mkFastString cc_name - flavour <- HpcCC <$> getCCIndexM nm - let cc = mkUserCC nm (this_mod env) pos flavour - count = countEntries && gopt Opt_ProfCountEntries dflags - return $ ProfNote cc count True{-scopes-} - - Breakpoints -> do - c <- liftM tickBoxCount getState - setState $ \st -> st { tickBoxCount = c + 1 - , mixEntries = me:mixEntries st } - return $ Breakpoint c ids - - SourceNotes | RealSrcSpan pos' <- pos -> - return $ SourceNote pos' cc_name - - _otherwise -> panic "mkTickish: bad source span!" - - -allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) - -> TM (LHsExpr GhcTc) -allocBinTickBox boxLabel pos m = do - env <- getEnv - case tickishType env of - HpcTicks -> do e <- liftM (cL pos) m - ifGoodTickSrcSpan pos - (mkBinTickBoxHpc boxLabel pos e) - (return e) - _other -> allocTickBox (ExpBox False) False False pos m - -mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc - -> TM (LHsExpr GhcTc) -mkBinTickBoxHpc boxLabel pos e = - TM $ \ env st -> - let meT = (pos,declPath env, [],boxLabel True) - meF = (pos,declPath env, [],boxLabel False) - meE = (pos,declPath env, [],ExpBox False) - c = tickBoxCount st - mes = mixEntries st - in - ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c) - $ cL pos $ HsBinTick noExtField (c+1) (c+2) e - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , noFVs - , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} - ) - -mkHpcPos :: SrcSpan -> HpcPos -mkHpcPos pos@(RealSrcSpan s) - | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, - srcSpanStartCol s, - srcSpanEndLine s, - srcSpanEndCol s - 1) - -- the end column of a SrcSpan is one - -- greater than the last column of the - -- span (see SrcLoc), whereas HPC - -- expects to the column range to be - -- inclusive, hence we subtract one above. -mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" - -hpcSrcSpan :: SrcSpan -hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") - -matchesOneOfMany :: [LMatch GhcTc body] -> Bool -matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 - where - matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ })) - = length grhss - matchCount (dL->L _ (Match { m_grhss = XGRHSs nec })) - = noExtCon nec - matchCount (dL->L _ (XMatch nec)) = noExtCon nec - matchCount _ = panic "matchCount: Impossible Match" -- due to #15884 - -type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) - --- For the hash value, we hash everything: the file name, --- the timestamp of the original source file, the tab stop, --- and the mix entries. We cheat, and hash the show'd string. --- This hash only has to be hashed at Mix creation time, --- and is for sanity checking only. - -mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int -mixHash file tm tabstop entries = fromIntegral $ hashString - (show $ Mix file tm 0 tabstop entries) - -{- -************************************************************************ -* * -* initialisation -* * -************************************************************************ - -Each module compiled with -fhpc declares an initialisation function of -the form `hpc_init_()`, which is emitted into the _stub.c file -and annotated with __attribute__((constructor)) so that it gets -executed at startup time. - -The function's purpose is to call hs_hpc_module to register this -module with the RTS, and it looks something like this: - -static void hpc_init_Main(void) __attribute__((constructor)); -static void hpc_init_Main(void) -{extern StgWord64 _hpc_tickboxes_Main_hpc[]; - hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} --} - -hpcInitCode :: Module -> HpcInfo -> SDoc -hpcInitCode _ (NoHpcInfo {}) = Outputable.empty -hpcInitCode this_mod (HpcInfo tickCount hashNo) - = vcat - [ text "static void hpc_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void hpc_init_" <> ppr this_mod <> text "(void)" - , braces (vcat [ - text "extern StgWord64 " <> tickboxes <> - text "[]" <> semi, - text "hs_hpc_module" <> - parens (hcat (punctuate comma [ - doubleQuotes full_name_str, - int tickCount, -- really StgWord32 - int hashNo, -- really StgWord32 - tickboxes - ])) <> semi - ]) - ] - where - tickboxes = ppr (mkHpcTicksLabel $ this_mod) - - module_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (moduleNameFS (Module.moduleName this_mod))) - package_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (unitIdFS (moduleUnitId this_mod))) - full_name_str - | moduleUnitId this_mod == mainUnitId - = module_name - | otherwise - = package_name <> char '/' <> module_name diff --git a/deSugar/Desugar.hs b/deSugar/Desugar.hs deleted file mode 100644 --- a/deSugar/Desugar.hs +++ /dev/null @@ -1,546 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The Desugarer: turning HsSyn into Core. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Desugar ( - -- * Desugaring operations - deSugar, deSugarExpr - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DsUsage -import DynFlags -import HscTypes -import GHC.Hs -import TcRnTypes -import TcRnMonad ( finalSafeMode, fixSafeInstances ) -import TcRnDriver ( runTcInteractive ) -import Id -import Name -import Type -import Avail -import CoreSyn -import CoreFVs ( exprsSomeFreeVarsList ) -import CoreOpt ( simpleOptPgm, simpleOptExpr ) -import PprCore -import DsMonad -import DsExpr -import DsBinds -import DsForeign -import PrelNames ( coercibleTyConKey ) -import TysPrim ( eqReprPrimTyCon ) -import Unique ( hasKey ) -import Coercion ( mkCoVarCo ) -import TysWiredIn ( coercibleDataCon ) -import DataCon ( dataConWrapId ) -import MkCore ( mkCoreLet ) -import Module -import NameSet -import NameEnv -import Rules -import BasicTypes ( Activation(.. ), competesWith, pprRuleName ) -import CoreMonad ( CoreToDo(..) ) -import CoreLint ( endPassIO ) -import VarSet -import FastString -import ErrUtils -import Outputable -import SrcLoc -import Coverage -import Util -import MonadUtils -import OrdList -import ExtractDocs - -import Data.List -import Data.IORef -import Control.Monad( when ) -import Plugins ( LoadedPlugin(..) ) - -{- -************************************************************************ -* * -* The main function: deSugar -* * -************************************************************************ --} - --- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) --- Can modify PCS by faulting in more declarations - -deSugar hsc_env - mod_loc - tcg_env@(TcGblEnv { tcg_mod = id_mod, - tcg_semantic_mod = mod, - tcg_src = hsc_src, - tcg_type_env = type_env, - tcg_imports = imports, - tcg_exports = exports, - tcg_keep = keep_var, - tcg_th_splice_used = tc_splice_used, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_inst_env = inst_env, - tcg_fam_inst_env = fam_inst_env, - tcg_merged = merged, - tcg_warns = warns, - tcg_anns = anns, - tcg_binds = binds, - tcg_imp_specs = imp_specs, - tcg_dependent_files = dependent_files, - tcg_ev_binds = ev_binds, - tcg_th_foreign_files = th_foreign_files_var, - tcg_fords = fords, - tcg_rules = rules, - tcg_patsyns = patsyns, - tcg_tcs = tcs, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info, - tcg_complete_matches = complete_matches - }) - - = do { let dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env - ; withTiming dflags - (text "Desugar"<+>brackets (ppr mod)) - (const ()) $ - do { -- Desugar the program - ; let export_set = availsToNameSet exports - target = hscTarget dflags - hpcInfo = emptyHpcInfo other_hpc_info - - ; (binds_cvr, ds_hpc_info, modBreaks) - <- if not (isHsBootOrSig hsc_src) - then addTicksToBinds hsc_env mod mod_loc - export_set (typeEnvTyCons type_env) binds - else return (binds, hpcInfo, Nothing) - ; (msgs, mb_res) <- initDs hsc_env tcg_env $ - do { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds binds_cvr - ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs - ; (ds_fords, foreign_prs) <- dsForeigns fords - ; ds_rules <- mapMaybeM dsRule rules - ; let hpc_init - | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info - | otherwise = empty - ; return ( ds_ev_binds - , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ ds_rules - , ds_fords `appendStubC` hpc_init) } - - ; case mb_res of { - Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_fords) -> - - do { -- Add export flags to bindings - keep_alive <- readIORef keep_var - ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules - final_prs = addExportFlagsAndRules target export_set keep_alive - rules_for_locals (fromOL all_prs) - - final_pgm = combineEvBinds ds_ev_binds final_prs - -- Notice that we put the whole lot in a big Rec, even the foreign binds - -- When compiling PrelFloat, which defines data Float = F# Float# - -- we want F# to be in scope in the foreign marshalling code! - -- You might think it doesn't matter, but the simplifier brings all top-level - -- things into the in-scope set before simplifying; so we get no unfolding for F#! - - ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps - ; (ds_binds, ds_rules_for_imps) - <- simpleOptPgm dflags mod final_pgm rules_for_imps - -- The simpleOptPgm gets rid of type - -- bindings plus any stupid dead code - - ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps - - ; let used_names = mkUsedNames tcg_env - pluginModules = - map lpModule (cachedPlugins (hsc_dflags hsc_env)) - ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) - (map mi_module pluginModules) tcg_env - - ; used_th <- readIORef tc_splice_used - ; dep_files <- readIORef dependent_files - ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names - dep_files merged pluginModules - -- id_mod /= mod when we are processing an hsig, but hsigs - -- never desugared and compiled (there's no code!) - -- Consequently, this should hold for any ModGuts that make - -- past desugaring. See Note [Identity versus semantic module]. - ; MASSERT( id_mod == mod ) - - ; foreign_files <- readIORef th_foreign_files_var - - ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env - - ; let mod_guts = ModGuts { - mg_module = mod, - mg_hsc_src = hsc_src, - mg_loc = mkFileSrcSpan mod_loc, - mg_exports = exports, - mg_usages = usages, - mg_deps = deps, - mg_used_th = used_th, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_anns = anns, - mg_tcs = tcs, - mg_insts = fixSafeInstances safe_mode insts, - mg_fam_insts = fam_insts, - mg_inst_env = inst_env, - mg_fam_inst_env = fam_inst_env, - mg_patsyns = patsyns, - mg_rules = ds_rules_for_imps, - mg_binds = ds_binds, - mg_foreign = ds_fords, - mg_foreign_files = foreign_files, - mg_hpc_info = ds_hpc_info, - mg_modBreaks = modBreaks, - mg_safe_haskell = safe_mode, - mg_trust_pkg = imp_trust_own_pkg imports, - mg_complete_sigs = complete_matches, - mg_doc_hdr = doc_hdr, - mg_decl_docs = decl_docs, - mg_arg_docs = arg_docs - } - ; return (msgs, Just mod_guts) - }}}} - -mkFileSrcSpan :: ModLocation -> SrcSpan -mkFileSrcSpan mod_loc - = case ml_hs_file mod_loc of - Just file_path -> mkGeneralSrcSpan (mkFastString file_path) - Nothing -> interactiveSrcSpan -- Presumably - -dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) -dsImpSpecs imp_specs - = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs - ; let (spec_binds, spec_rules) = unzip spec_prs - ; return (concatOL spec_binds, spec_rules) } - -combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] --- Top-level bindings can include coercion bindings, but not via superclasses --- See Note [Top-level evidence] -combineEvBinds [] val_prs - = [Rec val_prs] -combineEvBinds (NonRec b r : bs) val_prs - | isId b = combineEvBinds bs ((b,r):val_prs) - | otherwise = NonRec b r : combineEvBinds bs val_prs -combineEvBinds (Rec prs : bs) val_prs - = combineEvBinds bs (prs ++ val_prs) - -{- -Note [Top-level evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level evidence bindings may be mutually recursive with the top-level value -bindings, so we must put those in a Rec. But we can't put them *all* in a Rec -because the occurrence analyser doesn't take account of type/coercion variables -when computing dependencies. - -So we pull out the type/coercion variables (which are in dependency order), -and Rec the rest. --} - -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr) - -deSugarExpr hsc_env tc_expr = do { - let dflags = hsc_dflags hsc_env - - ; showPass dflags "Desugar" - - -- Do desugaring - ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ - dsLExpr tc_expr - - ; case mb_core_expr of - Nothing -> return () - Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" - (pprCoreExpr expr) - - ; return (msgs, mb_core_expr) } - -{- -************************************************************************ -* * -* Add rules and export flags to binders -* * -************************************************************************ --} - -addExportFlagsAndRules - :: HscTarget -> NameSet -> NameSet -> [CoreRule] - -> [(Id, t)] -> [(Id, t)] -addExportFlagsAndRules target exports keep_alive rules prs - = mapFst add_one prs - where - add_one bndr = add_rules name (add_export name bndr) - where - name = idName bndr - - ---------- Rules -------- - -- See Note [Attach rules to local ids] - -- NB: the binder might have some existing rules, - -- arising from specialisation pragmas - add_rules name bndr - | Just rules <- lookupNameEnv rule_base name - = bndr `addIdSpecialisations` rules - | otherwise - = bndr - rule_base = extendRuleBaseList emptyRuleBase rules - - ---------- Export flag -------- - -- See Note [Adding export flags] - add_export name bndr - | dont_discard name = setIdExported bndr - | otherwise = bndr - - dont_discard :: Name -> Bool - dont_discard name = is_exported name - || name `elemNameSet` keep_alive - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isExternalName separates the user-defined top-level names from those - -- introduced by the type checker. - is_exported :: Name -> Bool - is_exported | targetRetainsAllBindings target = isExternalName - | otherwise = (`elemNameSet` exports) - -{- -Note [Adding export flags] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Set the no-discard flag if either - a) the Id is exported - b) it's mentioned in the RHS of an orphan rule - c) it's in the keep-alive set - -It means that the binding won't be discarded EVEN if the binding -ends up being trivial (v = w) -- the simplifier would usually just -substitute w for v throughout, but we don't apply the substitution to -the rules (maybe we should?), so this substitution would make the rule -bogus. - -You might wonder why exported Ids aren't already marked as such; -it's just because the type checker is rather busy already and -I didn't want to pass in yet another mapping. - -Note [Attach rules to local ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Find the rules for locally-defined Ids; then we can attach them -to the binders in the top-level bindings - -Reason - - It makes the rules easier to look up - - It means that transformation rules and specialisations for - locally defined Ids are handled uniformly - - It keeps alive things that are referred to only from a rule - (the occurrence analyser knows about rules attached to Ids) - - It makes sure that, when we apply a rule, the free vars - of the RHS are more likely to be in scope - - The imported rules are carried in the in-scope set - which is extended on each iteration by the new wave of - local binders; any rules which aren't on the binding will - thereby get dropped - - -************************************************************************ -* * -* Desugaring transformation rules -* * -************************************************************************ --} - -dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) -dsRule (dL->L loc (HsRule { rd_name = name - , rd_act = rule_act - , rd_tmvs = vars - , rd_lhs = lhs - , rd_rhs = rhs })) - = putSrcSpanDs loc $ - do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars] - - ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ - unsetWOptM Opt_WarnIdentities $ - dsLExpr lhs -- Note [Desugaring RULE left hand sides] - - ; rhs' <- dsLExpr rhs - ; this_mod <- getModule - - ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs' - - -- Substitute the dict bindings eagerly, - -- and take the body apart into a (f args) form - ; dflags <- getDynFlags - ; case decomposeRuleLhs dflags bndrs'' lhs'' of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; - Right (final_bndrs, fn_id, args) -> do - - { let is_local = isLocalId fn_id - -- NB: isLocalId is False of implicit Ids. This is good because - -- we don't want to attach rules to the bindings of implicit Ids, - -- because they don't show up in the bindings until just before code gen - fn_name = idName fn_id - final_rhs = simpleOptExpr dflags rhs'' -- De-crap it - rule_name = snd (unLoc name) - final_bndrs_set = mkVarSet final_bndrs - arg_ids = filterOut (`elemVarSet` final_bndrs_set) $ - exprsSomeFreeVarsList isId args - - ; rule <- dsMkUserRule this_mod is_local - rule_name rule_act fn_name final_bndrs args - final_rhs - ; when (wopt Opt_WarnInlineRuleShadowing dflags) $ - warnRuleShadowing rule_name rule_act fn_id arg_ids - - ; return (Just rule) - } } } -dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec -dsRule _ = panic "dsRule: Impossible Match" -- due to #15884 - -warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () --- See Note [Rules and inlining/other rules] -warnRuleShadowing rule_name rule_act fn_id arg_ids - = do { check False fn_id -- We often have multiple rules for the same Id in a - -- module. Maybe we should check that they don't overlap - -- but currently we don't - ; mapM_ (check True) arg_ids } - where - check check_rules_too lhs_id - | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) - -- If imported with no unfolding, no worries - , idInlineActivation lhs_id `competesWith` rule_act - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because" <+> quotes (ppr lhs_id) - <+> text "might inline first") - , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" - <+> quotes (ppr lhs_id) - , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) - - | check_rules_too - , bad_rule : _ <- get_bad_rules lhs_id - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) - <+> text "for"<+> quotes (ppr lhs_id) - <+> text "might fire first") - , text "Probable fix: add phase [n] or [~n] to the competing rule" - , whenPprDebug (ppr bad_rule) ]) - - | otherwise - = return () - - get_bad_rules lhs_id - = [ rule | rule <- idCoreRules lhs_id - , ruleActivation rule `competesWith` rule_act ] - --- See Note [Desugaring coerce as cast] -unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) -unfold_coerce bndrs lhs rhs = do - (bndrs', wrap) <- go bndrs - return (bndrs', wrap lhs, wrap rhs) - where - go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) - go [] = return ([], id) - go (v:vs) - | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v) - , tc `hasKey` coercibleTyConKey = do - u <- newUnique - - let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2] - v' = mkLocalCoVar - (mkDerivedInternalName mkRepEqOcc u (getName v)) ty' - box = Var (dataConWrapId coercibleDataCon) `mkTyApps` - [k, t1, t2] `App` - Coercion (mkCoVarCo v') - - (bndrs, wrap) <- go vs - return (v':bndrs, mkCoreLet (NonRec v box) . wrap) - | otherwise = do - (bndrs,wrap) <- go vs - return (v:bndrs, wrap) - -{- Note [Desugaring RULE left hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the LHS of a RULE we do *not* want to desugar - [x] to build (\cn. x `c` n) -We want to leave explicit lists simply as chains -of cons's. We can achieve that slightly indirectly by -switching off EnableRewriteRules. See DsExpr.dsExplicitList. - -That keeps the desugaring of list comprehensions simple too. - -Nor do we want to warn of conversion identities on the LHS; -the rule is precisely to optimise them: - {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} - -Note [Desugaring coerce as cast] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want the user to express a rule saying roughly “mapping a coercion over a -list can be replaced by a coercion”. But the cast operator of Core (▷) cannot -be written in Haskell. So we use `coerce` for that (#2110). The user writes - map coerce = coerce -as a RULE, and this optimizes any kind of mapped' casts away, including `map -MkNewtype`. - -For that we replace any forall'ed `c :: Coercible a b` value in a RULE by -corresponding `co :: a ~#R b` and wrap the LHS and the RHS in -`let c = MkCoercible co in ...`. This is later simplified to the desired form -by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). -See also Note [Getting the map/coerce RULE to work] in CoreSubst. - -Note [Rules and inlining/other rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have - f x = ... - g x = ... - {-# RULES "rule-for-f" forall x. f (g x) = ... #-} -then there's a good chance that in a potential rule redex - ...f (g e)... -then 'f' or 'g' will inline befor the rule can fire. Solution: add an -INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'. - -Note that this applies to all the free variables on the LHS, both the -main function and things in its arguments. - -We also check if there are Ids on the LHS that have competing RULES. -In the above example, suppose we had - {-# RULES "rule-for-g" forally. g [y] = ... #-} -Then "rule-for-f" and "rule-for-g" would compete. Better to add phase -control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes -active; or perhpas after "rule-for-g" has become inactive. This is checked -by 'competesWith' - -Class methods have a built-in RULE to select the method from the dictionary, -so you can't change the phase on this. That makes id very dubious to -match on class methods in RULE lhs's. See #10595. I'm not happy -about this. For example in Control.Arrow we have - -{-# RULES "compose/arr" forall f g . - (arr f) . (arr g) = arr (f . g) #-} - -and similar, which will elicit exactly these warnings, and risk never -firing. But it's not clear what to do instead. We could make the -class method rules inactive in phase 2, but that would delay when -subsequent transformations could fire. --} diff --git a/deSugar/DsArrows.hs b/deSugar/DsArrows.hs deleted file mode 100644 --- a/deSugar/DsArrows.hs +++ /dev/null @@ -1,1269 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring arrow commands --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module DsArrows ( dsProcExpr ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Match -import DsUtils -import DsMonad - -import GHC.Hs hiding (collectPatBinders, collectPatsBinders, - collectLStmtsBinders, collectLStmtBinders, - collectStmtBinders ) -import TcHsSyn -import qualified GHC.Hs.Utils as HsUtils - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types (newtypes etc), and sometimes not --- So WATCH OUT; check each use of split*Ty functions. --- Sigh. This is a pain. - -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, - dsSyntaxExpr ) - -import TcType -import Type ( splitPiTy ) -import TcEvidence -import CoreSyn -import CoreFVs -import CoreUtils -import MkCore -import DsBinds (dsHsWrapper) - -import Name -import Id -import ConLike -import TysWiredIn -import BasicTypes -import PrelNames -import Outputable -import VarSet -import SrcLoc -import ListSetOps( assocMaybe ) -import Data.List -import Util -import UniqDSet - -data DsCmdEnv = DsCmdEnv { - arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr - } - -mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) --- See Note [CmdSyntaxTable] in GHC.Hs.Expr -mkCmdEnv tc_meths - = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths - - -- NB: Some of these lookups might fail, but that's OK if the - -- symbol is never used. That's why we use Maybe first and then - -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 - ; let the_arr_id = assocMaybe prs arrAName - the_compose_id = assocMaybe prs composeAName - the_first_id = assocMaybe prs firstAName - the_app_id = assocMaybe prs appAName - the_choice_id = assocMaybe prs choiceAName - the_loop_id = assocMaybe prs loopAName - - -- used as an argument in, e.g., do_premap - ; check_lev_poly 3 the_arr_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 5 the_compose_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 4 the_first_id - - -- the result of the_app_id is used as an argument in, e.g., - -- dsCmd/HsCmdArrApp/HsHigherOrderApp - ; check_lev_poly 2 the_app_id - - -- used as an argument in, e.g., HsCmdIf - ; check_lev_poly 5 the_choice_id - - -- used as an argument in, e.g., RecStmt - ; check_lev_poly 4 the_loop_id - - ; return (meth_binds, DsCmdEnv { - arr_id = Var (unmaybe the_arr_id arrAName), - compose_id = Var (unmaybe the_compose_id composeAName), - first_id = Var (unmaybe the_first_id firstAName), - app_id = Var (unmaybe the_app_id appAName), - choice_id = Var (unmaybe the_choice_id choiceAName), - loop_id = Var (unmaybe the_loop_id loopAName) - }) } - where - mk_bind (std_name, expr) - = do { rhs <- dsExpr expr - ; id <- newSysLocalDs (exprType rhs) - -- no check needed; these are functions - ; return (NonRec id rhs, (std_name, id)) } - - unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) - unmaybe (Just id) _ = id - - -- returns the result type of a pi-type (that is, a forall or a function) - -- Note that this result type may be ill-scoped. - res_type :: Type -> Type - res_type ty = res_ty - where - (_, res_ty) = splitPiTy ty - - check_lev_poly :: Int -- arity - -> Maybe Id -> DsM () - check_lev_poly _ Nothing = return () - check_lev_poly arity (Just id) - = dsNoLevPoly (nTimes arity res_type (idType id)) - (text "In the result of the function" <+> quotes (ppr id)) - - --- arr :: forall b c. (b -> c) -> a b c -do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr -do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] - --- (>>>) :: forall b c d. a b c -> a c d -> a b d -do_compose :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_compose ids b_ty c_ty d_ty f g - = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g] - --- first :: forall b c d. a b c -> a (b,d) (c,d) -do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr -do_first ids b_ty c_ty d_ty f - = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f] - --- app :: forall b c. a (a b c, b) c -do_app :: DsCmdEnv -> Type -> Type -> CoreExpr -do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty] - --- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d --- note the swapping of d and c -do_choice :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_choice ids b_ty c_ty d_ty f g - = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g] - --- loop :: forall b d c. a (b,d) (c,d) -> a b c --- note the swapping of d and c -do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr -do_loop ids b_ty c_ty d_ty f - = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f] - --- premap :: forall b c d. (b -> c) -> a c d -> a b d --- premap f g = arr f >>> g -do_premap :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_premap ids b_ty c_ty d_ty f g - = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g - -mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr -mkFailExpr ctxt ty - = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) - --- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a -mkFstExpr :: Type -> Type -> DsM CoreExpr -mkFstExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) - return (Lam pair_var - (coreCasePair pair_var a_var b_var (Var a_var))) - --- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b -mkSndExpr :: Type -> Type -> DsM CoreExpr -mkSndExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) - return (Lam pair_var - (coreCasePair pair_var a_var b_var (Var b_var))) - -{- -Build case analysis of a tuple. This cannot be done in the DsM monad, -because the list of variables is typically not yet defined. --} - --- coreCaseTuple [u1..] v [x1..xn] body --- = case v of v { (x1, .., xn) -> body } --- But the matching may be nested if the tuple is very big - -coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr -coreCaseTuple uniqs scrut_var vars body - = mkTupleCase uniqs vars body scrut_var (Var scrut_var) - -coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr -coreCasePair scrut_var var1 var2 body - = Case (Var scrut_var) scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] - -mkCorePairTy :: Type -> Type -> Type -mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] - -mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr -mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] - -mkCoreUnitExpr :: CoreExpr -mkCoreUnitExpr = mkCoreTup [] - -{- -The input is divided into a local environment, which is a flat tuple -(unless it's too big), and a stack, which is a right-nested pair. -In general, the input has the form - - ((x1,...,xn), (s1,...(sk,())...)) - -where xi are the environment values, and si the ones on the stack, -with s1 being the "top", the first one to be matched with a lambda. --} - -envStackType :: [Id] -> Type -> Type -envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty - --- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) -splitTypeAt :: Int -> Type -> ([Type], Type) -splitTypeAt n ty - | n == 0 = ([], ty) - | otherwise = case tcTyConAppArgs ty of - [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) - _ -> pprPanic "splitTypeAt" (ppr ty) - ----------------------------------------------- --- buildEnvStack --- --- ((x1,...,xn),stk) - -buildEnvStack :: [Id] -> Id -> CoreExpr -buildEnvStack env_ids stack_id - = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) - ----------------------------------------------- --- matchEnvStack --- --- \ ((x1,...,xn),stk) -> body --- => --- \ pair -> --- case pair of (tup,stk) -> --- case tup of (x1,...,xn) -> --- body - -matchEnvStack :: [Id] -- x1..xn - -> Id -- stk - -> CoreExpr -- e - -> DsM CoreExpr -matchEnvStack env_ids stack_id body = do - uniqs <- newUniqueSupply - tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - let match_env = coreCaseTuple uniqs tup_var env_ids body - pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id)) - return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) - ----------------------------------------------- --- matchEnv --- --- \ (x1,...,xn) -> body --- => --- \ tup -> --- case tup of (x1,...,xn) -> --- body - -matchEnv :: [Id] -- x1..xn - -> CoreExpr -- e - -> DsM CoreExpr -matchEnv env_ids body = do - uniqs <- newUniqueSupply - tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) - ----------------------------------------------- --- matchVarStack --- --- case (x1, ...(xn, s)...) -> e --- => --- case z0 of (x1,z1) -> --- case zn-1 of (xn,s) -> --- e -matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) -matchVarStack [] stack_id body = return (stack_id, body) -matchVarStack (param_id:param_ids) stack_id body = do - (tail_id, tail_code) <- matchVarStack param_ids stack_id body - pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) - return (pair_id, coreCasePair pair_id param_id tail_id tail_code) - -mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc -mkHsEnvStackExpr env_ids stack_id - = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] - --- Translation of arrow abstraction - --- D; xs |-a c : () --> t' ---> c' --- -------------------------- --- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' --- --- where (xs) is the tuple of variables bound by p - -dsProcExpr - :: LPat GhcTc - -> LHsCmdTop GhcTc - -> DsM CoreExpr -dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do - (meth_binds, meth_ids) <- mkCmdEnv ids - let locals = mkVarSet (collectPatBinders pat) - (core_cmd, _free_vars, env_ids) - <- dsfixCmd meth_ids locals unitTy cmd_ty cmd - let env_ty = mkBigCoreVarTupTy env_ids - let env_stk_ty = mkCorePairTy env_ty unitTy - let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr - fail_expr <- mkFailExpr ProcExpr env_stk_ty - var <- selectSimpleMatchVarL pat - match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr - let pat_ty = hsLPatType pat - let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty - (Lam var match_code) - core_cmd - return (mkLets meth_binds proc_code) -dsProcExpr _ _ = panic "dsProcExpr" - -{- -Translation of a command judgement of the form - - D; xs |-a c : stk --> t - -to an expression e such that - - D |- e :: a (xs, stk) t --} - -dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id] - -> DsM (CoreExpr, DIdSet) -dsLCmd ids local_vars stk_ty res_ty cmd env_ids - = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids - -dsCmd :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> Type -- type of the stack (right-nested tuple) - -> Type -- return type of the command - -> HsCmd GhcTc -- command to desugar - -> [Id] -- list of vars in the input to this command - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - --- D |- fun :: a t1 t2 --- D, xs |- arg :: t1 --- ----------------------------- --- D; xs |-a fun -< arg : stk --> t2 --- --- ---> premap (\ ((xs), _stk) -> arg) fun - -dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) - env_ids = do - let - (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty - (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - core_arrow <- dsLExprNoLP arrow - core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty - core_make_arg <- matchEnvStack env_ids stack_id core_arg - return (do_premap ids - (envStackType env_ids stack_ty) - arg_ty - res_ty - core_make_arg - core_arrow, - exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars) - --- D, xs |- fun :: a t1 t2 --- D, xs |- arg :: t1 --- ------------------------------ --- D; xs |-a fun -<< arg : stk --> t2 --- --- ---> premap (\ ((xs), _stk) -> (fun, arg)) app - -dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) - env_ids = do - let - (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty - (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - - core_arrow <- dsLExpr arrow - core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty - core_make_pair <- matchEnvStack env_ids stack_id - (mkCorePairExpr core_arrow core_arg) - - return (do_premap ids - (envStackType env_ids stack_ty) - (mkCorePairTy arrow_ty arg_ty) - res_ty - core_make_pair - (do_app ids arg_ty res_ty), - (exprsFreeIdsDSet [core_arrow, core_arg]) - `uniqDSetIntersectUniqSet` local_vars) - --- D; ys |-a cmd : (t,stk) --> t' --- D, xs |- exp :: t --- ------------------------ --- D; xs |-a cmd exp : stk --> t' --- --- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd - -dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do - core_arg <- dsLExpr arg - let - arg_ty = exprType core_arg - stack_ty' = mkCorePairTy arg_ty stack_ty - (core_cmd, free_vars, env_ids') - <- dsfixCmd ids local_vars stack_ty' res_ty cmd - stack_id <- newSysLocalDs stack_ty - arg_id <- newSysLocalDsNoLP arg_ty - -- push the argument expression onto the stack - let - stack' = mkCorePairExpr (Var arg_id) (Var stack_id) - core_body = bindNonRec arg_id core_arg - (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') - - -- match the environment and stack against the input - core_map <- matchEnvStack env_ids stack_id core_body - return (do_premap ids - (envStackType env_ids stack_ty) - (envStackType env_ids' stack_ty') - res_ty - core_map - core_cmd, - free_vars `unionDVarSet` - (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) - --- D; ys |-a cmd : stk t' --- ----------------------------------------------- --- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' --- --- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd - -dsCmd ids local_vars stack_ty res_ty - (HsCmdLam _ (MG { mg_alts - = (dL->L _ [dL->L _ (Match { m_pats = pats - , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) })) - env_ids = do - let pat_vars = mkVarSet (collectPatsBinders pats) - let - local_vars' = pat_vars `unionVarSet` local_vars - (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty - (core_body, free_vars, env_ids') - <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM newSysLocalDsNoLP pat_tys - stack_id' <- newSysLocalDs stack_ty' - - -- the expression is built from the inside out, so the actions - -- are presented in reverse order - - let - -- build a new environment, plus what's left of the stack - core_expr = buildEnvStack env_ids' stack_id' - in_ty = envStackType env_ids stack_ty - in_ty' = envStackType env_ids' stack_ty' - - fail_expr <- mkFailExpr LambdaExpr in_ty' - -- match the patterns against the parameters - match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr - fail_expr - -- match the parameters against the top of the old stack - (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code - -- match the old environment and stack against the input - select_code <- matchEnvStack env_ids stack_id param_code - return (do_premap ids in_ty in_ty' res_ty select_code core_body, - free_vars `uniqDSetMinusUniqSet` pat_vars) - -dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids - = dsLCmd ids local_vars stack_ty res_ty cmd env_ids - --- D, xs |- e :: Bool --- D; xs1 |-a c1 : stk --> t --- D; xs2 |-a c2 : stk --> t --- ---------------------------------------- --- D; xs |-a if e then c1 else c2 : stk --> t --- --- ---> premap (\ ((xs),stk) -> --- if e then Left ((xs1),stk) else Right ((xs2),stk)) --- (c1 ||| c2) - -dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) - env_ids = do - core_cond <- dsLExpr cond - (core_then, fvs_then, then_ids) - <- dsfixCmd ids local_vars stack_ty res_ty then_cmd - (core_else, fvs_else, else_ids) - <- dsfixCmd ids local_vars stack_ty res_ty else_cmd - stack_id <- newSysLocalDs stack_ty - either_con <- dsLookupTyCon eitherTyConName - left_con <- dsLookupDataCon leftDataConName - right_con <- dsLookupDataCon rightDataConName - - let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1,Type ty2, e] - mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e] - - in_ty = envStackType env_ids stack_ty - then_ty = envStackType then_ids stack_ty - else_ty = envStackType else_ids stack_ty - sum_ty = mkTyConApp either_con [then_ty, else_ty] - fvs_cond = exprFreeIdsDSet core_cond - `uniqDSetIntersectUniqSet` local_vars - - core_left = mk_left_expr then_ty else_ty - (buildEnvStack then_ids stack_id) - core_right = mk_right_expr then_ty else_ty - (buildEnvStack else_ids stack_id) - - core_if <- case mb_fun of - Just fun -> do { fun_apps <- dsSyntaxExpr fun - [core_cond, core_left, core_right] - ; matchEnvStack env_ids stack_id fun_apps } - Nothing -> matchEnvStack env_ids stack_id $ - mkIfThenElse core_cond core_left core_right - - return (do_premap ids in_ty sum_ty res_ty - core_if - (do_choice ids then_ty else_ty res_ty core_then core_else), - fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else) - -{- -Case commands are treated in much the same way as if commands -(see above) except that there are more alternatives. For example - - case e of { p1 -> c1; p2 -> c2; p3 -> c3 } - -is translated to - - premap (\ ((xs)*ts) -> case e of - p1 -> (Left (Left (xs1)*ts)) - p2 -> Left ((Right (xs2)*ts)) - p3 -> Right ((xs3)*ts)) - ((c1 ||| c2) ||| c3) - -The idea is to extract the commands from the case, build a balanced tree -of choices, and replace the commands with expressions that build tagged -tuples, obtaining a case expression that can be desugared normally. -To build all this, we use triples describing segments of the list of -case bodies, containing the following fields: - * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put - into the case replacing the commands - * a sum type that is the common type of these expressions, and also the - input type of the arrow - * a CoreExpr for an arrow built by combining the translated command - bodies with |||. --} - -dsCmd ids local_vars stack_ty res_ty - (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches) - , mg_ext = MatchGroupTc arg_tys _ - , mg_origin = origin })) - env_ids = do - stack_id <- newSysLocalDs stack_ty - - -- Extract and desugar the leaf commands in the case, building tuple - -- expressions that will (after tagging) replace these leaves - - let - leaves = concatMap leavesMatch matches - make_branch (leaf, bound_vars) = do - (core_leaf, _fvs, leaf_ids) - <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty - res_ty leaf - return ([mkHsEnvStackExpr leaf_ids stack_id], - envStackType leaf_ids stack_ty, - core_leaf) - - branches <- mapM make_branch leaves - either_con <- dsLookupTyCon eitherTyConName - left_con <- dsLookupDataCon leftDataConName - right_con <- dsLookupDataCon rightDataConName - let - left_id = HsConLikeOut noExtField (RealDataCon left_con) - right_id = HsConLikeOut noExtField (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp noExtField - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp noExtField - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e - - -- Prefix each tuple with a distinct series of Left's and Right's, - -- in a balanced way, keeping track of the types. - - merge_branches (builds1, in_ty1, core_exp1) - (builds2, in_ty2, core_exp2) - = (map (left_expr in_ty1 in_ty2) builds1 ++ - map (right_expr in_ty1 in_ty2) builds2, - mkTyConApp either_con [in_ty1, in_ty2], - do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) - (leaves', sum_ty, core_choices) = foldb merge_branches branches - - -- Replace the commands in the case with these tagged tuples, - -- yielding a HsExpr Id we can feed to dsExpr. - - (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches - in_ty = envStackType env_ids stack_ty - - core_body <- dsExpr (HsCase noExtField exp - (MG { mg_alts = cL l matches' - , mg_ext = MatchGroupTc arg_tys sum_ty - , mg_origin = origin })) - -- Note that we replace the HsCase result type by sum_ty, - -- which is the type of matches' - - core_matches <- matchEnvStack env_ids stack_id core_body - return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, - exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars) - --- D; ys |-a cmd : stk --> t --- ---------------------------------- --- D; xs |-a let binds in cmd : stk --> t --- --- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c - -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) - env_ids = do - let - defined_vars = mkVarSet (collectLocalBinders binds) - local_vars' = defined_vars `unionVarSet` local_vars - - (core_body, _free_vars, env_ids') - <- dsfixCmd ids local_vars' stack_ty res_ty body - stack_id <- newSysLocalDs stack_ty - -- build a new environment, plus the stack, using the let bindings - core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) - -- match the old environment and stack against the input - core_map <- matchEnvStack env_ids stack_id core_binds - return (do_premap ids - (envStackType env_ids stack_ty) - (envStackType env_ids' stack_ty) - res_ty - core_map - core_body, - exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) - --- D; xs |-a ss : t --- ---------------------------------- --- D; xs |-a do { ss } : () --> t --- --- ---> premap (\ (env,stk) -> env) c - -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty - (dL->L loc stmts)) - env_ids = do - putSrcSpanDs loc $ - dsNoLevPoly stmts_ty - (text "In the do-command:" <+> ppr do_block) - (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids - let env_ty = mkBigCoreVarTupTy env_ids - core_fst <- mkFstExpr env_ty stack_ty - return (do_premap ids - (mkCorePairTy env_ty stack_ty) - env_ty - res_ty - core_fst - core_stmts, - env_ids') - --- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t --- D; xs |-a ci :: stki --> ti --- ----------------------------------- --- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn - -dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do - let env_ty = mkBigCoreVarTupTy env_ids - core_op <- dsLExpr op - (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args - return (mkApps (App core_op (Type env_ty)) core_args, - unionDVarSets fv_sets) - -dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do - (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids - core_wrap <- dsHsWrapper wrap - return (core_wrap core_cmd, env_ids') - -dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) - --- D; ys |-a c : stk --> t (ys <= xs) --- --------------------- --- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c - -dsTrimCmdArg - :: IdSet -- set of local vars available to this command - -> [Id] -- list of vars in the input to this command - -> LHsCmdTop GhcTc -- command argument to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free -dsTrimCmdArg local_vars env_ids - (dL->L _ (HsCmdTop - (CmdTopTc stack_ty cmd_ty ids) cmd )) = do - (meth_binds, meth_ids) <- mkCmdEnv ids - (core_cmd, free_vars, env_ids') - <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd - stack_id <- newSysLocalDs stack_ty - trim_code - <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) - let - in_ty = envStackType env_ids stack_ty - in_ty' = envStackType env_ids' stack_ty - arg_code = if env_ids' == env_ids then core_cmd else - do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd - return (mkLets meth_binds arg_code, free_vars) -dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg" - --- Given D; xs |-a c : stk --> t, builds c with xs fed back. --- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) - -dsfixCmd - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> Type -- type of the stack (right-nested tuple) - -> Type -- return type of the command - -> LHsCmd GhcTc -- command to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- the same local vars as a list, fed back -dsfixCmd ids local_vars stk_ty cmd_ty cmd - = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty - (text "When desugaring the command:" <+> ppr cmd) - ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } - --- Feed back the list of local variables actually used a command, --- for use as the input tuple of the generated arrow. - -trimInput - :: ([Id] -> DsM (CoreExpr, DIdSet)) - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list, fed back to - -- the inner function to form the tuple of - -- inputs to the arrow. -trimInput build_arrow - = fixDs (\ ~(_,_,env_ids) -> do - (core_cmd, free_vars) <- build_arrow env_ids - return (core_cmd, free_vars, dVarSetElems free_vars)) - -{- -Translation of command judgements of the form - - D |-a do { ss } : t --} - -dsCmdDo :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> Type -- return type of the statement - -> [CmdLStmt GhcTc] -- statements to desugar - -> [Id] -- list of vars in the input to this statement - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - -dsCmdDo _ _ _ [] _ = panic "dsCmdDo" - --- D; xs |-a c : () --> t --- -------------------------- --- D; xs |-a do { c } : t --- --- ---> premap (\ (xs) -> ((xs), ())) c - -dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do - putSrcSpanDs loc $ dsNoLevPoly res_ty - (text "In the command:" <+> ppr body) - (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids - let env_ty = mkBigCoreVarTupTy env_ids - env_var <- newSysLocalDs env_ty - let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) - return (do_premap ids - env_ty - (mkCorePairTy env_ty unitTy) - res_ty - core_map - core_body, - env_ids') - -dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) - let local_vars' = bound_vars `unionVarSet` local_vars - (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids - return (do_compose ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy env_ids') - res_ty - core_stmt - core_stmts, - fv_stmt) - -{- -A statement maps one local environment to another, and is represented -as an arrow from one tuple type to another. A statement sequence is -translated to a composition of such arrows. --} - -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id] - -> DsM (CoreExpr, DIdSet) -dsCmdLStmt ids local_vars out_ids cmd env_ids - = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids - -dsCmdStmt - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- list of vars in the output of this statement - -> CmdStmt GhcTc -- statement to desugar - -> [Id] -- list of vars in the input to this statement - -- This is typically fed back, - -- so don't pull on it too early - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - --- D; xs1 |-a c : () --> t --- D; xs' |-a do { ss } : t' --- ------------------------------ --- D; xs |-a do { c; ss } : t' --- --- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) --- (first c >>> arr snd) >>> ss - -dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd - core_mux <- matchEnv env_ids - (mkCorePairExpr - (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) - (mkBigCoreVarTup out_ids)) - let - in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy - out_ty = mkBigCoreVarTupTy out_ids - before_c_ty = mkCorePairTy in_ty1 out_ty - after_c_ty = mkCorePairTy c_ty out_ty - dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here - snd_fn <- mkSndExpr c_ty out_ty - return (do_premap ids in_ty before_c_ty out_ty core_mux $ - do_compose ids before_c_ty after_c_ty out_ty - (do_first ids in_ty1 c_ty out_ty core_cmd) $ - do_arr ids after_c_ty out_ty snd_fn, - extendDVarSetList fv_cmd out_ids) - --- D; xs1 |-a c : () --> t --- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) --- ----------------------------------- --- D; xs |-a do { p <- c; ss } : t' --- --- ---> premap (\ (xs) -> (((xs1),()),(xs2))) --- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss --- --- It would be simpler and more consistent to do this using second, --- but that's likely to be defined in terms of first. - -dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do - let pat_ty = hsLPatType pat - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd - let pat_vars = mkVarSet (collectPatBinders pat) - let - env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids - env_ty2 = mkBigCoreVarTupTy env_ids2 - - -- multiplexing function - -- \ (xs) -> (((xs1),()),(xs2)) - - core_mux <- matchEnv env_ids - (mkCorePairExpr - (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) - (mkBigCoreVarTup env_ids2)) - - -- projection function - -- \ (p, (xs2)) -> (zs) - - env_id <- newSysLocalDs env_ty2 - uniqs <- newUniqueSupply - let - after_c_ty = mkCorePairTy pat_ty env_ty2 - out_ty = mkBigCoreVarTupTy out_ids - body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) - - fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty - pat_id <- selectSimpleMatchVarL pat - match_code - <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr - pair_id <- newSysLocalDs after_c_ty - let - proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) - - -- put it all together - let - in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy - in_ty2 = mkBigCoreVarTupTy env_ids2 - before_c_ty = mkCorePairTy in_ty1 in_ty2 - return (do_premap ids in_ty before_c_ty out_ty core_mux $ - do_compose ids before_c_ty after_c_ty out_ty - (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ - do_arr ids after_c_ty out_ty proj_expr, - fv_cmd `unionDVarSet` (mkDVarSet out_ids - `uniqDSetMinusUniqSet` pat_vars)) - --- D; xs' |-a do { ss } : t --- -------------------------------------- --- D; xs |-a do { let binds; ss } : t --- --- ---> arr (\ (xs) -> let binds in (xs')) >>> ss - -dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do - -- build a new environment using the let bindings - core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) - -- match the old environment against the input - core_map <- matchEnv env_ids core_binds - return (do_arr ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy out_ids) - core_map, - exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars) - --- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... --- D; xs' |-a do { ss' } : t --- ------------------------------------ --- D; xs |-a do { rec ss; ss' } : t --- --- xs1 = xs' /\ defs(ss) --- xs2 = xs' - defs(ss) --- ys1 = ys - defs(ss) --- ys2 = ys /\ defs(ss) --- --- ---> arr (\(xs) -> ((ys1),(xs2))) >>> --- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> --- arr (\((xs1),(xs2)) -> (xs')) >>> ss' - -dsCmdStmt ids local_vars out_ids - (RecStmt { recS_stmts = stmts - , recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_ext = RecStmtTc { recS_later_rets = later_rets - , recS_rec_rets = rec_rets } }) - env_ids = do - let - later_ids_set = mkVarSet later_ids - env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids - env2_id_set = mkDVarSet env2_ids - env2_ty = mkBigCoreVarTupTy env2_ids - - -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - - uniqs <- newUniqueSupply - env2_id <- newSysLocalDs env2_ty - let - later_ty = mkBigCoreVarTupTy later_ids - post_pair_ty = mkCorePairTy later_ty env2_ty - post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) - - post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body - - --- loop (...) - - (core_loop, env1_id_set, env1_ids) - <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets - - -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) - - let - env1_ty = mkBigCoreVarTupTy env1_ids - pre_pair_ty = mkCorePairTy env1_ty env2_ty - pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) - (mkBigCoreVarTup env2_ids) - - pre_loop_fn <- matchEnv env_ids pre_loop_body - - -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn - - let - env_ty = mkBigCoreVarTupTy env_ids - out_ty = mkBigCoreVarTupTy out_ids - core_body = do_premap ids env_ty pre_pair_ty out_ty - pre_loop_fn - (do_compose ids pre_pair_ty post_pair_ty out_ty - (do_first ids env1_ty later_ty env2_ty - core_loop) - (do_arr ids post_pair_ty out_ty - post_loop_fn)) - - return (core_body, env1_id_set `unionDVarSet` env2_id_set) - -dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) - --- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) --- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>> - -dsRecCmd - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd - -> [Id] -- list of vars defined here and used later - -> [HsExpr GhcTc] -- expressions corresponding to later_ids - -> [Id] -- list of vars fed back through the loop - -> [HsExpr GhcTc] -- expressions corresponding to rec_ids - -> DsM (CoreExpr, -- desugared statement - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list - -dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do - let - later_id_set = mkVarSet later_ids - rec_id_set = mkVarSet rec_ids - local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars - - -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) - - core_later_rets <- mapM dsExpr later_rets - core_rec_rets <- mapM dsExpr rec_rets - let - -- possibly polymorphic version of vars of later_ids and rec_ids - out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets) - out_ty = mkBigCoreVarTupTy out_ids - - later_tuple = mkBigCoreTup core_later_rets - later_ty = mkBigCoreVarTupTy later_ids - - rec_tuple = mkBigCoreTup core_rec_rets - rec_ty = mkBigCoreVarTupTy rec_ids - - out_pair = mkCorePairExpr later_tuple rec_tuple - out_pair_ty = mkCorePairTy later_ty rec_ty - - mk_pair_fn <- matchEnv out_ids out_pair - - -- ss - - (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts - - -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) - - rec_id <- newSysLocalDs rec_ty - let - env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set - env1_ids = dVarSetElems env1_id_set - env1_ty = mkBigCoreVarTupTy env1_ids - in_pair_ty = mkCorePairTy env1_ty rec_ty - core_body = mkBigCoreTup (map selectVar env_ids) - where - selectVar v - | v `elemVarSet` rec_id_set - = mkTupleSelector rec_ids v rec_id (Var rec_id) - | otherwise = Var v - - squash_pair_fn <- matchEnvStack env1_ids rec_id core_body - - -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) - - let - env_ty = mkBigCoreVarTupTy env_ids - core_loop = do_loop ids env1_ty later_ty rec_ty - (do_premap ids in_pair_ty env_ty out_pair_ty - squash_pair_fn - (do_compose ids env_ty out_ty out_pair_ty - core_stmts - (do_arr ids out_ty out_pair_ty mk_pair_fn))) - - return (core_loop, env1_id_set, env1_ids) - -{- -A sequence of statements (as in a rec) is desugared to an arrow between -two environments (no stack) --} - -dsfixCmdStmts - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- output vars of these statements - -> [CmdLStmt GhcTc] -- statements to desugar - -> DsM (CoreExpr, -- desugared expression - DIdSet, -- subset of local vars that occur free - [Id]) -- same local vars as a list - -dsfixCmdStmts ids local_vars out_ids stmts - = trimInput (dsCmdStmts ids local_vars out_ids stmts) - -- TODO: Add levity polymorphism check for the resulting expression. - -- But I (Richard E.) don't know enough about arrows to do so. - -dsCmdStmts - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- output vars of these statements - -> [CmdLStmt GhcTc] -- statements to desugar - -> [Id] -- list of vars in the input to these statements - -> DsM (CoreExpr, -- desugared expression - DIdSet) -- subset of local vars that occur free - -dsCmdStmts ids local_vars out_ids [stmt] env_ids - = dsCmdLStmt ids local_vars out_ids stmt env_ids - -dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do - let bound_vars = mkVarSet (collectLStmtBinders stmt) - let local_vars' = bound_vars `unionVarSet` local_vars - (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids - return (do_compose ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy env_ids') - (mkBigCoreVarTupTy out_ids) - core_stmt - core_stmts, - fv_stmt) - -dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" - --- Match a list of expressions against a list of patterns, left-to-right. - -matchSimplys :: [CoreExpr] -- Scrutinees - -> HsMatchContext Name -- Match kind - -> [LPat GhcTc] -- Patterns they should match - -> CoreExpr -- Return this if they all match - -> CoreExpr -- Return this if they don't - -> DsM CoreExpr -matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr -matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do - match_code <- matchSimplys exps ctxt pats result_expr fail_expr - matchSimply exp ctxt pat match_code fail_expr -matchSimplys _ _ _ _ _ = panic "matchSimplys" - --- List of leaf expressions, with set of variables bound in each - -leavesMatch :: LMatch GhcTc (Located (body GhcTc)) - -> [(Located (body GhcTc), IdSet)] -leavesMatch (dL->L _ (Match { m_pats = pats - , m_grhss = GRHSs _ grhss (dL->L _ binds) })) - = let - defined_vars = mkVarSet (collectPatsBinders pats) - `unionVarSet` - mkVarSet (collectLocalBinders binds) - in - [(body, - mkVarSet (collectLStmtsBinders stmts) - `unionVarSet` defined_vars) - | (dL->L _ (GRHS _ stmts body)) <- grhss] -leavesMatch _ = panic "leavesMatch" - --- Replace the leaf commands in a match - -replaceLeavesMatch - :: Type -- new result type - -> [Located (body' GhcTc)] -- replacement leaf expressions of that type - -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command - -> ([Located (body' GhcTc)], -- remaining leaf expressions - LMatch GhcTc (Located (body' GhcTc))) -- updated match -replaceLeavesMatch _res_ty leaves - (dL->L loc - match@(Match { m_grhss = GRHSs x grhss binds })) - = let - (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss - in - (leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) -replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" - -replaceLeavesGRHS - :: [Located (body' GhcTc)] -- replacement leaf expressions of that type - -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command - -> ([Located (body' GhcTc)], -- remaining leaf expressions - LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _)) - = (leaves, cL loc (GRHS x stmts leaf)) -replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" -replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" - --- Balanced fold of a non-empty list. - -foldb :: (a -> a -> a) -> [a] -> a -foldb _ [] = error "foldb of empty list" -foldb _ [x] = x -foldb f xs = foldb f (fold_pairs xs) - where - fold_pairs [] = [] - fold_pairs [x] = [x] - fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs - -{- -Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following functions to collect value variables from patterns are -copied from GHC.Hs.Utils, with one change: we also collect the dictionary -bindings (pat_binds) from ConPatOut. We need them for cases like - -h :: Arrow a => Int -> a (Int,Int) Int -h x = proc (y,z) -> case compare x y of - GT -> returnA -< z+x - -The type checker turns the case into - - case compare x y of - GT { p77 = plusInt } -> returnA -< p77 z x - -Here p77 is a local binding for the (+) operation. - -See comments in GHC.Hs.Utils for why the other version does not include -these bindings. --} - -collectPatBinders :: LPat GhcTc -> [Id] -collectPatBinders pat = collectl pat [] - -collectPatsBinders :: [LPat GhcTc] -> [Id] -collectPatsBinders pats = foldr collectl [] pats - ---------------------- -collectl :: LPat GhcTc -> [Id] -> [Id] --- See Note [Dictionary binders in ConPatOut] -collectl (dL->L _ pat) bndrs - = go pat - where - go (VarPat _ (dL->L _ var)) = var : bndrs - go (WildPat _) = bndrs - go (LazyPat _ pat) = collectl pat bndrs - go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (dL->L _ a) pat) = a : collectl pat bndrs - go (ParPat _ pat) = collectl pat bndrs - - go (ListPat _ pats) = foldr collectl bndrs pats - go (TuplePat _ pats _) = foldr collectl bndrs pats - go (SumPat _ pat _ _) = collectl pat bndrs - - go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps, pat_binds=ds}) = - collectEvBinders ds - ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs - - go (SigPat _ pat _) = collectl pat bndrs - go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs - go (ViewPat _ _ pat) = collectl pat bndrs - go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) - go p@(XPat {}) = pprPanic "collectl/go" (ppr p) - -collectEvBinders :: TcEvBinds -> [Id] -collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs -collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" - -add_ev_bndr :: EvBind -> [Id] -> [Id] -add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs - | otherwise = bs - -- A worry: what about coercion variable binders?? - -collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders :: LStmt GhcTc body -> [Id] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt GhcTc body -> [Id] -collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids -collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/deSugar/DsBinds.hs b/deSugar/DsBinds.hs deleted file mode 100644 --- a/deSugar/DsBinds.hs +++ /dev/null @@ -1,1322 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching bindings (HsBinds and MonoBinds) - -Handles @HsBinds@; those at the top level require different handling, -in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at -lower levels it is preserved with @let@/@letrec@s). --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} - -module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr( dsLExpr ) -import {-# SOURCE #-} Match( matchWrapper ) - -import DsMonad -import DsGRHSs -import DsUtils -import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches ) - -import GHC.Hs -- lots of things -import CoreSyn -- lots of things -import CoreOpt ( simpleOptExpr ) -import OccurAnal ( occurAnalyseExpr ) -import MkCore -import CoreUtils -import CoreArity ( etaExpand ) -import CoreUnfold -import CoreFVs -import Digraph -import Predicate - -import PrelNames -import TyCon -import TcEvidence -import TcType -import Type -import Coercion -import TysWiredIn ( typeNatKind, typeSymbolKind ) -import Id -import MkId(proxyHashId) -import Name -import VarSet -import Rules -import VarEnv -import Var( EvVar ) -import Outputable -import Module -import SrcLoc -import Maybes -import OrdList -import Bag -import BasicTypes -import DynFlags -import FastString -import Util -import UniqSet( nonDetEltsUniqSet ) -import MonadUtils -import qualified GHC.LanguageExtensions as LangExt -import Control.Monad - -{-********************************************************************** -* * - Desugaring a MonoBinds -* * -**********************************************************************-} - --- | Desugar top level binds, strict binds are treated like normal --- binds since there is no good time to force before first usage. -dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) -dsTopLHsBinds binds - -- see Note [Strict binds checks] - | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) - = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict bindings") bang_binds - ; return nilOL } - - | otherwise - = do { (force_vars, prs) <- dsLHsBinds binds - ; when debugIsOn $ - do { xstrict <- xoptM LangExt.Strict - ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) } - -- with -XStrict, even top-level vars are listed as force vars. - - ; return (toOL prs) } - - where - unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds - bang_binds = filterBag (isBangedHsBind . unLoc) binds - - top_level_err desc (dL->L loc bind) - = putSrcSpanDs loc $ - errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") - 2 (ppr bind)) - - --- | Desugar all other kind of bindings, Ids of strict binds are returned to --- later be forced in the binding group body, see Note [Desugar Strict binds] -dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBinds binds - = do { ds_bs <- mapBagM dsLHsBind binds - ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) - id ([], []) ds_bs) } - ------------------------- -dsLHsBind :: LHsBind GhcTc - -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags - putSrcSpanDs loc $ dsHsBind dflags bind - --- | Desugar a single binding (or group of recursive binds). -dsHsBind :: DynFlags - -> HsBind GhcTc - -> DsM ([Id], [(Id,CoreExpr)]) - -- ^ The Ids of strict binds, to be forced in the body of the - -- binding group see Note [Desugar Strict binds] and all - -- bindings and their desugared right hand sides. - -dsHsBind dflags (VarBind { var_id = var - , var_rhs = expr - , var_inline = inline_regardless }) - = do { core_expr <- dsLExpr expr - -- Dictionary bindings are always VarBinds, - -- so we only need do this here - ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr - | otherwise = var - ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr - force_var = if xopt LangExt.Strict dflags - then [id] - else [] - ; return (force_var, [core_bind]) } - -dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun) - , fun_matches = matches - , fun_co_fn = co_fn - , fun_tick = tick }) - = do { (args, body) <- matchWrapper - (mkPrefixFunRhs (noLoc $ idName fun)) - Nothing matches - ; core_wrap <- dsHsWrapper co_fn - ; let body' = mkOptTickBox tick body - rhs = core_wrap (mkLams args body') - core_binds@(id,_) = makeCorePair dflags fun False 0 rhs - force_var - -- Bindings are strict when -XStrict is enabled - | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas - = [id] - | isBangedHsBind b - = [id] - | otherwise - = [] - ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) - -- , ppr (mg_alts matches) - -- , ppr args, ppr core_binds]) $ - return (force_var, [core_binds]) } - -dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = NPatBindTc _ ty - , pat_ticks = (rhs_tick, var_ticks) }) - = do { body_expr <- dsGuarded grhss ty - ; checkGuardMatches PatBindGuards grhss - ; let body' = mkOptTickBox rhs_tick body_expr - pat' = decideBangHood dflags pat - ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' - -- We silently ignore inline pragmas; no makeCorePair - -- Not so cool, but really doesn't matter - ; let force_var' = if isBangedLPat pat' - then [force_var] - else [] - ; return (force_var', sel_binds) } - -dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = binds, abs_sig = has_sig }) - = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource) - -- FromSource might not be accurate, but at worst - -- we do superfluous calls to the pattern match - -- oracle. - -- addTyCsDs: push type constraints deeper - -- for inner pattern match check - -- See Check, Note [Type and Term Equality Propagation] - (addTyCsDs (listToBag dicts)) - (dsLHsBinds binds) - - ; ds_ev_binds <- dsTcEvBinds_s ev_binds - - -- dsAbsBinds does the hard work - ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } - -dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" -dsHsBind _ (XHsBindsLR nec) = noExtCon nec - - ------------------------ -dsAbsBinds :: DynFlags - -> [TyVar] -> [EvVar] -> [ABExport GhcTc] - -> [CoreBind] -- Desugared evidence bindings - -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings - -> Bool -- Single binding with signature - -> DsM ([Id], [(Id,CoreExpr)]) - -dsAbsBinds dflags tyvars dicts exports - ds_ev_binds (force_vars, bind_prs) has_sig - - -- A very important common case: one exported variable - -- Non-recursive bindings come through this way - -- So do self-recursive bindings - | [export] <- exports - , ABE { abe_poly = global_id, abe_mono = local_id - , abe_wrap = wrap, abe_prags = prags } <- export - , Just force_vars' <- case force_vars of - [] -> Just [] - [v] | v == local_id -> Just [global_id] - _ -> Nothing - -- If there is a variable to force, it's just the - -- single variable we are binding here - = do { core_wrap <- dsHsWrapper wrap -- Usually the identity - - ; let rhs = core_wrap $ - mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_ev_binds $ - body - - body | has_sig - , [(_, lrhs)] <- bind_prs - = lrhs - | otherwise - = mkLetRec bind_prs (Var local_id) - - ; (spec_binds, rules) <- dsSpecs rhs prags - - ; let global_id' = addIdSpecialisations global_id rules - main_bind = makeCorePair dflags global_id' - (isDefaultMethod prags) - (dictArity dicts) rhs - - ; return (force_vars', main_bind : fromOL spec_binds) } - - -- Another common case: no tyvars, no dicts - -- In this case we can have a much simpler desugaring - | null tyvars, null dicts - - = do { let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local - , abe_prags = prags }) - = do { core_wrap <- dsHsWrapper wrap - ; return (makeCorePair dflags global - (isDefaultMethod prags) - 0 (core_wrap (Var local))) } - mk_bind (XABExport nec) = noExtCon nec - ; main_binds <- mapM mk_bind exports - - ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } - - -- The general case - -- See Note [Desugaring AbsBinds] - | otherwise - = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs - | (lcl_id, rhs) <- bind_prs ] - -- Monomorphic recursion possible, hence Rec - new_force_vars = get_new_force_vars force_vars - locals = map abe_mono exports - all_locals = locals ++ new_force_vars - tup_expr = mkBigCoreVarTup all_locals - tup_ty = exprType tup_expr - ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_ev_binds $ - mkLet core_bind $ - tup_expr - - ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) - - -- Find corresponding global or make up a new one: sometimes - -- we need to make new export to desugar strict binds, see - -- Note [Desugar Strict binds] - ; (exported_force_vars, extra_exports) <- get_exports force_vars - - ; let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local, abe_prags = spec_prags }) - -- See Note [AbsBinds wrappers] in HsBinds - = do { tup_id <- newSysLocalDs tup_ty - ; core_wrap <- dsHsWrapper wrap - ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkTupleSelector all_locals local tup_id $ - mkVarApps (Var poly_tup_id) (tyvars ++ dicts) - rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs - ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = (global `setInlinePragma` defaultInlinePragma) - `addIdSpecialisations` rules - -- Kill the INLINE pragma because it applies to - -- the user written (local) function. The global - -- Id is just the selector. Hmm. - ; return ((global', rhs) : fromOL spec_binds) } - mk_bind (XABExport nec) = noExtCon nec - - ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) - - ; return ( exported_force_vars - , (poly_tup_id, poly_tup_rhs) : - concat export_binds_s) } - where - inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with - -- the inline pragma from the source - -- The type checker put the inline pragma - -- on the *global* Id, so we need to transfer it - inline_env - = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) - | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports - , let prag = idInlinePragma gbl_id ] - - add_inline :: Id -> Id -- tran - add_inline lcl_id = lookupVarEnv inline_env lcl_id - `orElse` lcl_id - - global_env :: IdEnv Id -- Maps local Id to its global exported Id - global_env = - mkVarEnv [ (local, global) - | ABE { abe_mono = local, abe_poly = global } <- exports - ] - - -- find variables that are not exported - get_new_force_vars lcls = - foldr (\lcl acc -> case lookupVarEnv global_env lcl of - Just _ -> acc - Nothing -> lcl:acc) - [] lcls - - -- find exports or make up new exports for force variables - get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc]) - get_exports lcls = - foldM (\(glbls, exports) lcl -> - case lookupVarEnv global_env lcl of - Just glbl -> return (glbl:glbls, exports) - Nothing -> do export <- mk_export lcl - let glbl = abe_poly export - return (glbl:glbls, export:exports)) - ([],[]) lcls - - mk_export local = - do global <- newSysLocalDs - (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE { abe_ext = noExtField - , abe_poly = global - , abe_mono = local - , abe_wrap = WpHole - , abe_prags = SpecPrags [] }) - --- | This is where we apply INLINE and INLINABLE pragmas. All we need to --- do is to attach the unfolding information to the Id. --- --- Other decisions about whether to inline are made in --- `calcUnfoldingGuidance` but the decision about whether to then expose --- the unfolding in the interface file is made in `TidyPgm.addExternal` --- using this information. ------------------------- -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr - -> (Id, CoreExpr) -makeCorePair dflags gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined - -- See Note [INLINE and default methods] in TcInstDcls - = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) - - | otherwise - = case inlinePragmaSpec inline_prag of - NoUserInline -> (gbl_id, rhs) - NoInline -> (gbl_id, rhs) - Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline -> inline_pair - - where - inline_prag = idInlinePragma gbl_id - inlinable_unf = mkInlinableUnfolding dflags rhs - inline_pair - | Just arity <- inlinePragmaSat inline_prag - -- Add an Unfolding for an INLINE (but not for NOINLINE) - -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - , let real_arity = dict_arity + arity - -- NB: The arity in the InlineRule takes account of the dictionaries - = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs - , etaExpand real_arity rhs) - - | otherwise - = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ - (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs) - -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts - -{- -Note [Desugaring AbsBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the general AbsBinds case we desugar the binding to this: - - tup a (d:Num a) = let fm = ...gm... - gm = ...fm... - in (fm,gm) - f a d = case tup a d of { (fm,gm) -> fm } - g a d = case tup a d of { (fm,gm) -> fm } - -Note [Rules and inlining] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Common special case: no type or dictionary abstraction -This is a bit less trivial than you might suppose -The naive way would be to desugar to something like - f_lcl = ...f_lcl... -- The "binds" from AbsBinds - M.f = f_lcl -- Generated from "exports" -But we don't want that, because if M.f isn't exported, -it'll be inlined unconditionally at every call site (its rhs is -trivial). That would be ok unless it has RULES, which would -thereby be completely lost. Bad, bad, bad. - -Instead we want to generate - M.f = ...f_lcl... - f_lcl = M.f -Now all is cool. The RULES are attached to M.f (by SimplCore), -and f_lcl is rapidly inlined away. - -This does not happen in the same way to polymorphic binds, -because they desugar to - M.f = /\a. let f_lcl = ...f_lcl... in f_lcl -Although I'm a bit worried about whether full laziness might -float the f_lcl binding out and then inline M.f at its call site - -Note [Specialising in no-dict case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even if there are no tyvars or dicts, we may have specialisation pragmas. -Class methods can generate - AbsBinds [] [] [( ... spec-prag] - { AbsBinds [tvs] [dicts] ...blah } -So the overloading is in the nested AbsBinds. A good example is in GHC.Float: - - class (Real a, Fractional a) => RealFrac a where - round :: (Integral b) => a -> b - - instance RealFrac Float where - {-# SPECIALIZE round :: Float -> Int #-} - -The top-level AbsBinds for $cround has no tyvars or dicts (because the -instance does not). But the method is locally overloaded! - -Note [Abstracting over tyvars only] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When abstracting over type variable only (not dictionaries), we don't really need to -built a tuple and select from it, as we do in the general case. Instead we can take - - AbsBinds [a,b] [ ([a,b], fg, fl, _), - ([b], gg, gl, _) ] - { fl = e1 - gl = e2 - h = e3 } - -and desugar it to - - fg = /\ab. let B in e1 - gg = /\b. let a = () in let B in S(e2) - h = /\ab. let B in e3 - -where B is the *non-recursive* binding - fl = fg a b - gl = gg b - h = h a b -- See (b); note shadowing! - -Notice (a) g has a different number of type variables to f, so we must - use the mkArbitraryType thing to fill in the gaps. - We use a type-let to do that. - - (b) The local variable h isn't in the exports, and rather than - clone a fresh copy we simply replace h by (h a b), where - the two h's have different types! Shadowing happens here, - which looks confusing but works fine. - - (c) The result is *still* quadratic-sized if there are a lot of - small bindings. So if there are more than some small - number (10), we filter the binding set B by the free - variables of the particular RHS. Tiresome. - -Why got to this trouble? It's a common case, and it removes the -quadratic-sized tuple desugaring. Less clutter, hopefully faster -compilation, especially in a case where there are a *lot* of -bindings. - - -Note [Eta-expanding INLINE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo :: Eq a => a -> a - {-# INLINE foo #-} - foo x = ... - -If (foo d) ever gets floated out as a common sub-expression (which can -happen as a result of method sharing), there's a danger that we never -get to do the inlining, which is a Terribly Bad thing given that the -user said "inline"! - -To avoid this we pre-emptively eta-expand the definition, so that foo -has the arity with which it is declared in the source code. In this -example it has arity 2 (one for the Eq and one for x). Doing this -should mean that (foo d) is a PAP and we don't share it. - -Note [Nested arities] -~~~~~~~~~~~~~~~~~~~~~ -For reasons that are not entirely clear, method bindings come out looking like -this: - - AbsBinds [] [] [$cfromT <= [] fromT] - $cfromT [InlPrag=INLINE] :: T Bool -> Bool - { AbsBinds [] [] [fromT <= [] fromT_1] - fromT :: T Bool -> Bool - { fromT_1 ((TBool b)) = not b } } } - -Note the nested AbsBind. The arity for the InlineRule on $cfromT should be -gotten from the binding for fromT_1. - -It might be better to have just one level of AbsBinds, but that requires more -thought! - - -Note [Desugar Strict binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma - -Desugaring strict variable bindings looks as follows (core below ==>) - - let !x = rhs - in body -==> - let x = rhs - in x `seq` body -- seq the variable - -and if it is a pattern binding the desugaring looks like - - let !pat = rhs - in body -==> - let x = rhs -- bind the rhs to a new variable - pat = x - in x `seq` body -- seq the new variable - -if there is no variable in the pattern desugaring looks like - - let False = rhs - in body -==> - let x = case rhs of {False -> (); _ -> error "Match failed"} - in x `seq` body - -In order to force the Ids in the binding group they are passed around -in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind. - -Consider a recursive group like this - - letrec - f : g = rhs[f,g] - in - -Without `Strict`, we get a translation like this: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (fm,gm) - - in let f = /\a. case t a of (fm,_) -> fm - in let g = /\a. case t a of (_,gm) -> gm - in - -Here `tm` is the monomorphic binding for `rhs`. - -With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. -Alas, `tm` isn't in scope in the `in ` part. - -The simplest thing is to return it in the polymorphic -tuple `t`, thus: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (tm, fm, gm) - - in let f = /\a. case t a of (_,fm,_) -> fm - in let g = /\a. case t a of (_,_,gm) -> gm - in let tm = /\a. case t a of (tm,_,_) -> tm - in tm `seq` - - -See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more -detailed explanation of the desugaring of strict bindings. - -Note [Strict binds checks] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several checks around properly formed strict bindings. They -all link to this Note. These checks must be here in the desugarer because -we cannot know whether or not a type is unlifted until after zonking, due -to levity polymorphism. These checks all used to be handled in the typechecker -in checkStrictBinds (before Jan '17). - -We define an "unlifted bind" to be any bind that binds an unlifted id. Note that - - x :: Char - (# True, x #) = blah - -is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. - -Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. -Define a "strict bind" to be either an unlifted bind or a banged bind. - -The restrictions are: - 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. - - 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged - unlifted bind, but an unbanged bind looks lazy, and we don't want users to be - surprised by the strictness of an unlifted bind.) Checked in first clause - of DsExpr.ds_val_bind. - - 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type - variables or constraints.) Checked in first clause - of DsExpr.ds_val_bind. - - 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. - --} - ------------------------- -dsSpecs :: CoreExpr -- Its rhs - -> TcSpecPrags - -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids - , [CoreRule] ) -- Rules for the Global Ids --- See Note [Handling SPECIALISE pragmas] in TcBinds -dsSpecs _ IsDefaultMethod = return (nilOL, []) -dsSpecs poly_rhs (SpecPrags sps) - = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps - ; let (spec_binds_s, rules) = unzip pairs - ; return (concatOL spec_binds_s, rules) } - -dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding - -- Nothing => RULE is for an imported Id - -- rhs is in the Id's unfolding - -> Located TcSpecPrag - -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) -dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl)) - | isJust (isClassOpId_maybe poly_id) - = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" - <+> quotes (ppr poly_id)) - ; return Nothing } -- There is no point in trying to specialise a class op - -- Moreover, classops don't (currently) have an inl_sat arity set - -- (it would be Just 0) and that in turn makes makeCorePair bleat - - | no_act_spec && isNeverActive rule_act - = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" - <+> quotes (ppr poly_id)) - ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that - -- See Note [Activation pragmas for SPECIALISE] - - | otherwise - = putSrcSpanDs loc $ - do { uniq <- newUnique - ; let poly_name = idName poly_id - spec_occ = mkSpecOcc (getOccName poly_name) - spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) - (spec_bndrs, spec_app) = collectHsWrapBinders spec_co - -- spec_co looks like - -- \spec_bndrs. [] spec_args - -- perhaps with the body of the lambda wrapped in some WpLets - -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 - - ; core_app <- dsHsWrapper spec_app - - ; let ds_lhs = core_app (Var poly_id) - spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs) - ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id - -- , text "spec_co:" <+> ppr spec_co - -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ - dflags <- getDynFlags - ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; - Right (rule_bndrs, _fn, rule_lhs_args) -> do - - { this_mod <- getModule - ; let fn_unf = realIdUnfolding poly_id - spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf - spec_id = mkLocalId spec_name spec_ty - `setInlinePragma` inl_prag - `setIdUnfolding` spec_unf - - ; rule <- dsMkUserRule this_mod is_local_id - (mkFastString ("SPEC " ++ showPpr dflags poly_name)) - rule_act poly_name - rule_bndrs rule_lhs_args - (mkVarApps (Var spec_id) spec_bndrs) - - ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs) - --- Commented out: see Note [SPECIALISE on INLINE functions] --- ; when (isInlinePragma id_inl) --- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" --- <+> quotes (ppr poly_name)) - - ; return (Just (unitOL (spec_id, spec_rhs), rule)) - -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because - -- makeCorePair overwrites the unfolding, which we have - -- just created using specUnfolding - } } } - where - is_local_id = isJust mb_poly_rhs - poly_rhs | Just rhs <- mb_poly_rhs - = rhs -- Local Id; this is its rhs - | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) - = unfolding -- Imported Id; this is its unfolding - -- Use realIdUnfolding so we get the unfolding - -- even when it is a loop breaker. - -- We want to specialise recursive functions! - | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) - -- The type checker has checked that it *has* an unfolding - - id_inl = idInlinePragma poly_id - - -- See Note [Activation pragmas for SPECIALISE] - inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl - | not is_local_id -- See Note [Specialising imported functions] - -- in OccurAnal - , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma - | otherwise = id_inl - -- Get the INLINE pragma from SPECIALISE declaration, or, - -- failing that, from the original Id - - spec_prag_act = inlinePragmaActivation spec_inl - - -- See Note [Activation pragmas for SPECIALISE] - -- no_act_spec is True if the user didn't write an explicit - -- phase specification in the SPECIALISE pragma - no_act_spec = case inlinePragmaSpec spec_inl of - NoInline -> isNeverActive spec_prag_act - _ -> isAlwaysActive spec_prag_act - rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit - | otherwise = spec_prag_act -- Specified by user - - -dsMkUserRule :: Module -> Bool -> RuleName -> Activation - -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule -dsMkUserRule this_mod is_local name act fn bndrs args rhs = do - let rule = mkRule this_mod False is_local name act fn bndrs args rhs - dflags <- getDynFlags - when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $ - warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule) - return rule - -ruleOrphWarn :: CoreRule -> SDoc -ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule - -{- Note [SPECIALISE on INLINE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to warn that using SPECIALISE for a function marked INLINE -would be a no-op; but it isn't! Especially with worker/wrapper split -we might have - {-# INLINE f #-} - f :: Ord a => Int -> a -> ... - f d x y = case x of I# x' -> $wf d x' y - -We might want to specialise 'f' so that we in turn specialise '$wf'. -We can't even /name/ '$wf' in the source code, so we can't specialise -it even if we wanted to. #10721 is a case in point. - -Note [Activation pragmas for SPECIALISE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From a user SPECIALISE pragma for f, we generate - a) A top-level binding spec_fn = rhs - b) A RULE f dOrd = spec_fn - -We need two pragma-like things: - -* spec_fn's inline pragma: inherited from f's inline pragma (ignoring - activation on SPEC), unless overriden by SPEC INLINE - -* Activation of RULE: from SPECIALISE pragma (if activation given) - otherwise from f's inline pragma - -This is not obvious (see #5237)! - -Examples Rule activation Inline prag on spec'd fn ---------------------------------------------------------------------- -SPEC [n] f :: ty [n] Always, or NOINLINE [n] - copy f's prag - -NOINLINE f -SPEC [n] f :: ty [n] NOINLINE - copy f's prag - -NOINLINE [k] f -SPEC [n] f :: ty [n] NOINLINE [k] - copy f's prag - -INLINE [k] f -SPEC [n] f :: ty [n] INLINE [k] - copy f's prag - -SPEC INLINE [n] f :: ty [n] INLINE [n] - (ignore INLINE prag on f, - same activation for rule and spec'd fn) - -NOINLINE [k] f -SPEC f :: ty [n] INLINE [k] - - -************************************************************************ -* * -\subsection{Adding inline pragmas} -* * -************************************************************************ --} - -decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr - -> Either SDoc ([Var], Id, [CoreExpr]) --- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, --- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs --- may add some extra dictionary binders (see Note [Free dictionaries]) --- --- Returns an error message if the LHS isn't of the expected shape --- Note [Decomposing the left-hand side of a RULE] -decomposeRuleLhs dflags orig_bndrs orig_lhs - | not (null unbound) -- Check for things unbound on LHS - -- See Note [Unused spec binders] - = Left (vcat (map dead_msg unbound)) - | Var funId <- fun2 - , Just con <- isDataConId_maybe funId - = Left (constructor_msg con) -- See Note [No RULES on datacons] - | Just (fn_id, args) <- decompose fun2 args2 - , let extra_bndrs = mk_extra_bndrs fn_id args - = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs1:" <+> ppr lhs1 - -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs - -- , text "fn_id:" <+> ppr fn_id - -- , text "args:" <+> ppr args]) $ - Right (orig_bndrs ++ extra_bndrs, fn_id, args) - - | otherwise - = Left bad_shape_msg - where - lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS] - (fun2,args2) = collectArgs lhs2 - - lhs_fvs = exprFreeVars lhs2 - unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs - - orig_bndr_set = mkVarSet orig_bndrs - - -- Add extra tyvar binders: Note [Free tyvars in rule LHS] - -- and extra dict binders: Note [Free dictionaries in rule LHS] - mk_extra_bndrs fn_id args - = scopedSort unbound_tvs ++ unbound_dicts - where - unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] - unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d) - | d <- unbound_vars, isDictId d ] - unbound_vars = [ v | v <- exprsFreeVarsList args - , not (v `elemVarSet` orig_bndr_set) - , not (v == fn_id) ] - -- fn_id: do not quantify over the function itself, which may - -- itself be a dictionary (in pathological cases, #10251) - - decompose (Var fn_id) args - | not (fn_id `elemVarSet` orig_bndr_set) - = Just (fn_id, args) - - decompose _ _ = Nothing - - bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") - 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 - , text "Orig lhs:" <+> ppr orig_lhs]) - dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr - , text "is not bound in RULE lhs"]) - 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs - , text "Orig lhs:" <+> ppr orig_lhs - , text "optimised lhs:" <+> ppr lhs2 ]) - pp_bndr bndr - | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) - | isEvVar bndr = text "constraint" <+> quotes (ppr (varType bndr)) - | otherwise = text "variable" <+> quotes (ppr bndr) - - constructor_msg con = vcat - [ text "A constructor," <+> ppr con <> - text ", appears as outermost match in RULE lhs." - , text "This rule will be ignored." ] - - drop_dicts :: CoreExpr -> CoreExpr - drop_dicts e - = wrap_lets needed bnds body - where - needed = orig_bndr_set `minusVarSet` exprFreeVars body - (bnds, body) = split_lets (occurAnalyseExpr e) - -- The occurAnalyseExpr drops dead bindings which is - -- crucial to ensure that every binding is used later; - -- which in turn makes wrap_lets work right - - split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) - split_lets (Let (NonRec d r) body) - | isDictId d - = ((d,r):bs, body') - where (bs, body') = split_lets body - - -- handle "unlifted lets" too, needed for "map/coerce" - split_lets (Case r d _ [(DEFAULT, _, body)]) - | isCoVar d - = ((d,r):bs, body') - where (bs, body') = split_lets body - - split_lets e = ([], e) - - wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr - wrap_lets _ [] body = body - wrap_lets needed ((d, r) : bs) body - | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) - | otherwise = wrap_lets needed bs body - where - rhs_fvs = exprFreeVars r - needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d - -{- -Note [Decomposing the left-hand side of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several things going on here. -* drop_dicts: see Note [Drop dictionary bindings on rule LHS] -* simpleOptExpr: see Note [Simplify rule LHS] -* extra_dict_bndrs: see Note [Free dictionaries] - -Note [Free tyvars on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)), where alpha -is an unbound meta-tyvar. The zonker in TcHsSyn is careful not to -turn the free alpha into Any (as it usually does). Instead it turns it -into a TyVar 'a'. See TcHsSyn Note [Zonking the LHS of a RULE]. - -Now we must quantify over that 'a'. It's /really/ inconvenient to do that -in the zonker, because the HsExpr data type is very large. But it's /easy/ -to do it here in the desugarer. - -Moreover, we have to do something rather similar for dictionaries; -see Note [Free dictionaries on rule LHS]. So that's why we look for -type variables free on the LHS, and quantify over them. - -Note [Free dictionaries on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, -which is presumably in scope at the function definition site, we can quantify -over it too. *Any* dict with that type will do. - -So for example when you have - f :: Eq a => a -> a - f = - ... SPECIALISE f :: Int -> Int ... - -Then we get the SpecPrag - SpecPrag (f Int dInt) - -And from that we want the rule - - RULE forall dInt. f Int dInt = f_spec - f_spec = let f = in f Int dInt - -But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External -Name, and you can't bind them in a lambda or forall without getting things -confused. Likewise it might have an InlineRule or something, which would be -utterly bogus. So we really make a fresh Id, with the same unique and type -as the old one, but with an Internal name and no IdInfo. - -Note [Drop dictionary bindings on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -drop_dicts drops dictionary bindings on the LHS where possible. - E.g. let d:Eq [Int] = $fEqList $fEqInt in f d - --> f d - Reasoning here is that there is only one d:Eq [Int], and so we can - quantify over it. That makes 'd' free in the LHS, but that is later - picked up by extra_dict_bndrs (Note [Dead spec binders]). - - NB 1: We can only drop the binding if the RHS doesn't bind - one of the orig_bndrs, which we assume occur on RHS. - Example - f :: (Eq a) => b -> a -> a - {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} - Here we want to end up with - RULE forall d:Eq a. f ($dfEqList d) = f_spec d - Of course, the ($dfEqlist d) in the pattern makes it less likely - to match, but there is no other way to get d:Eq a - - NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all - the evidence bindings to be wrapped around the outside of the - LHS. (After simplOptExpr they'll usually have been inlined.) - dsHsWrapper does dependency analysis, so that civilised ones - will be simple NonRec bindings. We don't handle recursive - dictionaries! - - NB3: In the common case of a non-overloaded, but perhaps-polymorphic - specialisation, we don't need to bind *any* dictionaries for use - in the RHS. For example (#8331) - {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} - useAbstractMonad :: MonadAbstractIOST m => m Int - Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code - but the RHS uses no dictionaries, so we want to end up with - RULE forall s (d :: MonadAbstractIOST (ReaderT s)). - useAbstractMonad (ReaderT s) d = $suseAbstractMonad s - - #8848 is a good example of where there are some interesting - dictionary bindings to discard. - -The drop_dicts algorithm is based on these observations: - - * Given (let d = rhs in e) where d is a DictId, - matching 'e' will bind e's free variables. - - * So we want to keep the binding if one of the needed variables (for - which we need a binding) is in fv(rhs) but not already in fv(e). - - * The "needed variables" are simply the orig_bndrs. Consider - f :: (Eq a, Show b) => a -> b -> String - ... SPECIALISE f :: (Show b) => Int -> b -> String ... - Then orig_bndrs includes the *quantified* dictionaries of the type - namely (dsb::Show b), but not the one for Eq Int - -So we work inside out, applying the above criterion at each step. - - -Note [Simplify rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~ -simplOptExpr occurrence-analyses and simplifies the LHS: - - (a) Inline any remaining dictionary bindings (which hopefully - occur just once) - - (b) Substitute trivial lets, so that they don't get in the way. - Note that we substitute the function too; we might - have this as a LHS: let f71 = M.f Int in f71 - - (c) Do eta reduction. To see why, consider the fold/build rule, - which without simplification looked like: - fold k z (build (/\a. g a)) ==> ... - This doesn't match unless you do eta reduction on the build argument. - Similarly for a LHS like - augment g (build h) - we do not want to get - augment (\a. g a) (build h) - otherwise we don't match when given an argument like - augment (\a. h a a) (build h) - -Note [Unused spec binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: a -> a - ... SPECIALISE f :: Eq a => a -> a ... -It's true that this *is* a more specialised type, but the rule -we get is something like this: - f_spec d = f - RULE: f = f_spec d -Note that the rule is bogus, because it mentions a 'd' that is -not bound on the LHS! But it's a silly specialisation anyway, because -the constraint is unused. We could bind 'd' to (error "unused") -but it seems better to reject the program because it's almost certainly -a mistake. That's what the isDeadBinder call detects. - -Note [No RULES on datacons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Previously, `RULES` like - - "JustNothing" forall x . Just x = Nothing - -were allowed. Simon Peyton Jones says this seems to have been a -mistake, that such rules have never been supported intentionally, -and that he doesn't know if they can break in horrible ways. -Furthermore, Ben Gamari and Reid Barton are considering trying to -detect the presence of "static data" that the simplifier doesn't -need to traverse at all. Such rules do not play well with that. -So for now, we ban them altogether as requested by #13290. See also #7398. - - -************************************************************************ -* * - Desugaring evidence -* * -************************************************************************ - --} - -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) -dsHsWrapper WpHole = return $ \e -> e -dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) -dsHsWrapper (WpEvLam ev) = return $ Lam ev -dsHsWrapper (WpTyLam tv) = return $ Lam tv -dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds - ; return (mkCoreLets bs) } -dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; return (w1 . w2) } - -- See comments on WpFun in TcEvidence for an explanation of what - -- the specification of this clause is -dsHsWrapper (WpFun c1 c2 t1 doc) - = do { x <- newSysLocalDsNoLP t1 - ; w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a - arg = w1 (Var x) - ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc - ; if ok - then return (\e -> (Lam x (w2 (app e arg)))) - else return id } -- this return is irrelevant -dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) - return $ \e -> mkCastDs e co -dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm - ; return (\e -> App e core_tm) } - --------------------------------------- -dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] -dsTcEvBinds_s [] = return [] -dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null - dsTcEvBinds b - -dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] -dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this -dsTcEvBinds (EvBinds bs) = dsEvBinds bs - -dsEvBinds :: Bag EvBind -> DsM [CoreBind] -dsEvBinds bs - = do { ds_bs <- mapBagM dsEvBind bs - ; return (mk_ev_binds ds_bs) } - -mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] --- We do SCC analysis of the evidence bindings, /after/ desugaring --- them. This is convenient: it means we can use the CoreSyn --- free-variable functions rather than having to do accurate free vars --- for EvTerm. -mk_ev_binds ds_binds - = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) - where - edges :: [ Node EvVar (EvVar,CoreExpr) ] - edges = foldr ((:) . mk_node) [] ds_binds - - mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) - mk_node b@(var, rhs) - = DigraphNode { node_payload = b - , node_key = var - , node_dependencies = nonDetEltsUniqSet $ - exprFreeVars rhs `unionVarSet` - coVarsOfType (varType var) } - -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices - -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. - - ds_scc (AcyclicSCC (v,r)) = NonRec v r - ds_scc (CyclicSCC prs) = Rec prs - -dsEvBind :: EvBind -> DsM (Id, CoreExpr) -dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) - - -{-********************************************************************** -* * - Desugaring EvTerms -* * -**********************************************************************-} - -dsEvTerm :: EvTerm -> DsM CoreExpr -dsEvTerm (EvExpr e) = return e -dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev -dsEvTerm (EvFun { et_tvs = tvs, et_given = given - , et_binds = ev_binds, et_body = wanted_id }) - = do { ds_ev_binds <- dsTcEvBinds ev_binds - ; return $ (mkLams (tvs ++ given) $ - mkCoreLets ds_ev_binds $ - Var wanted_id) } - - -{-********************************************************************** -* * - Desugaring Typeable dictionaries -* * -**********************************************************************-} - -dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr --- Return a CoreExpr :: Typeable ty --- This code is tightly coupled to the representation --- of TypeRep, in base library Data.Typeable.Internals -dsEvTypeable ty ev - = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable - ; let kind = typeKind ty - Just typeable_data_con - = tyConSingleDataCon_maybe tyCl -- "Data constructor" - -- for Typeable - - ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a - - -- Package up the method as `Typeable` dictionary - ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } - -type TypeRepExpr = CoreExpr - --- | Returns a @CoreExpr :: TypeRep ty@ -ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr -ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) - = do { mkTrCon <- dsLookupGlobalId mkTrConName - -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a - ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName - ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName - -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep - - ; tc_rep <- tyConRep tc -- :: TyCon - ; let ks = tyConAppArgs ty - -- Construct a SomeTypeRep - toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr - toSomeTypeRep t ev = do - rep <- getRep ev t - return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] - ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t - ; let -- :: [SomeTypeRep] - kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps - - -- Note that we use the kind of the type, not the TyCon from which it - -- is constructed since the latter may be kind polymorphic whereas the - -- former we know is not (we checked in the solver). - ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] - -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr - ; return expr - } - -ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) - | Just (t1,t2) <- splitAppTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrApp <- dsLookupGlobalId mkTrAppName - -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). - -- TypeRep a -> TypeRep b -> TypeRep (a b) - ; let (k1, k2) = splitFunTy (typeKind t1) - ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] - -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr - ; return expr - } - -ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) - | Just (t1,t2) <- splitFunTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrFun <- dsLookupGlobalId mkTrFunName - -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). - -- TypeRep a -> TypeRep b -> TypeRep (a -> b) - ; let r1 = getRuntimeRep t1 - r2 = getRuntimeRep t2 - ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) - [ e1, e2 ] - } - -ds_ev_typeable ty (EvTypeableTyLit ev) - = -- See Note [Typeable for Nat and Symbol] in TcInteract - do { fun <- dsLookupGlobalId tr_fun - ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol - ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] - ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } - where - ty_kind = typeKind ty - - -- tr_fun is the Name of - -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a - -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a - tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName - | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName - | otherwise = panic "dsEvTypeable: unknown type lit kind" - -ds_ev_typeable ty ev - = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) - -getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ - -> Type -- ^ The type @ty@ - -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ - -- namely @typeRep# dict@ --- Remember that --- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a -getRep ev ty - = do { typeable_expr <- dsEvTerm ev - ; typeRepId <- dsLookupGlobalId typeRepIdName - ; let ty_args = [typeKind ty, ty] - ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } - -tyConRep :: TyCon -> DsM CoreExpr --- Returns CoreExpr :: TyCon -tyConRep tc - | Just tc_rep_nm <- tyConRepName_maybe tc - = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm - ; return (Var tc_rep_id) } - | otherwise - = pprPanic "tyConRep" (ppr tc) diff --git a/deSugar/DsBinds.hs-boot b/deSugar/DsBinds.hs-boot deleted file mode 100644 --- a/deSugar/DsBinds.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module DsBinds where -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) -import TcEvidence (HsWrapper) - -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) diff --git a/deSugar/DsCCall.hs b/deSugar/DsCCall.hs deleted file mode 100644 --- a/deSugar/DsCCall.hs +++ /dev/null @@ -1,386 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -Desugaring foreign calls --} - -{-# LANGUAGE CPP #-} -module DsCCall - ( dsCCall - , mkFCall - , unboxArg - , boxResult - , resultWrapper - ) where - -#include "HsVersions.h" - - -import GhcPrelude - -import CoreSyn - -import DsMonad -import CoreUtils -import MkCore -import MkId -import ForeignCall -import DataCon -import DsUtils - -import TcType -import Type -import Id ( Id ) -import Coercion -import PrimOp -import TysPrim -import TyCon -import TysWiredIn -import BasicTypes -import Literal -import PrelNames -import DynFlags -import Outputable -import Util - -import Data.Maybe - -import RepType (mkCCallSpec) -{- -Desugaring of @ccall@s consists of adding some state manipulation, -unboxing any boxed primitive arguments and boxing the result if -desired. - -The state stuff just consists of adding in -@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place. - -The unboxing is straightforward, as all information needed to unbox is -available from the type. For each boxed-primitive argument, we -transform: -\begin{verbatim} - _ccall_ foo [ r, t1, ... tm ] e1 ... em - | - | - V - case e1 of { T1# x1# -> - ... - case em of { Tm# xm# -> xm# - ccall# foo [ r, t1#, ... tm# ] x1# ... xm# - } ... } -\end{verbatim} - -The reboxing of a @_ccall_@ result is a bit tricker: the types don't -contain information about the state-pairing functions so we have to -keep a list of \tr{(type, s-p-function)} pairs. We transform as -follows: -\begin{verbatim} - ccall# foo [ r, t1#, ... tm# ] e1# ... em# - | - | - V - \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of - (StateAnd# result# state#) -> (R# result#, realWorld#) -\end{verbatim} --} - -dsCCall :: CLabelString -- C routine to invoke - -> [CoreExpr] -- Arguments (desugared) - -- Precondition: none have levity-polymorphic types - -> Safety -- Safety of the call - -> Type -- Type of the result: IO t - -> DsM CoreExpr -- Result, of type ??? - -dsCCall lbl args may_gc result_ty - = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args - (ccall_result_ty, res_wrapper) <- boxResult result_ty - uniq <- newUnique - dflags <- getDynFlags - let - arg_tys = map exprType args - - raw_res_ty = case tcSplitIOType_maybe result_ty of - Just (_ioTyCon, res_ty) -> res_ty - Nothing -> result_ty - - target = StaticTarget NoSourceText lbl Nothing True - the_fcall = CCall (mkCCallSpec target CCallConv may_gc raw_res_ty arg_tys) - the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty - return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) - -mkFCall :: DynFlags -> Unique -> ForeignCall - -> [CoreExpr] -- Args - -> Type -- Result type - -> CoreExpr --- Construct the ccall. The only tricky bit is that the ccall Id should have --- no free vars, so if any of the arg tys do we must give it a polymorphic type. --- [I forget *why* it should have no free vars!] --- For example: --- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] --- --- Here we build a ccall thus --- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) --- a b s x c -mkFCall dflags uniq the_fcall val_args res_ty - = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level - mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args - where - arg_tys = map exprType val_args - body_ty = (mkVisFunTys arg_tys res_ty) - tyvars = tyCoVarsOfTypeWellScoped body_ty - ty = mkInvForAllTys tyvars body_ty - the_fcall_id = mkFCallId dflags uniq the_fcall ty - -unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic - -> DsM (CoreExpr, -- To pass as the actual argument - CoreExpr -> CoreExpr -- Wrapper to unbox the arg - ) --- Example: if the arg is e::Int, unboxArg will return --- (x#::Int#, \W. case x of I# x# -> W) --- where W is a CoreExpr that probably mentions x# - --- always returns a non-levity-polymorphic expression - -unboxArg arg - -- Primitive types: nothing to unbox - | isPrimitiveType arg_ty - = return (arg, \body -> body) - - -- Recursive newtypes - | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty - = unboxArg (mkCastDs arg co) - - -- Booleans - | Just tc <- tyConAppTyCon_maybe arg_ty, - tc `hasKey` boolTyConKey - = do dflags <- getDynFlags - prim_arg <- newSysLocalDs intPrimTy - return (Var prim_arg, - \ body -> Case (mkWildCase arg arg_ty intPrimTy - [(DataAlt falseDataCon,[],mkIntLit dflags 0), - (DataAlt trueDataCon, [],mkIntLit dflags 1)]) - -- In increasing tag order! - prim_arg - (exprType body) - [(DEFAULT,[],body)]) - - -- Data types with a single constructor, which has a single, primitive-typed arg - -- This deals with Int, Float etc; also Ptr, ForeignPtr - | is_product_type && data_con_arity == 1 - = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty) - -- Typechecker ensures this - do case_bndr <- newSysLocalDs arg_ty - prim_arg <- newSysLocalDs data_con_arg_ty1 - return (Var prim_arg, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] - ) - - -- Byte-arrays, both mutable and otherwise; hack warning - -- We're looking for values of type ByteArray, MutableByteArray - -- data ByteArray ix = ByteArray ix ix ByteArray# - -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) - | is_product_type && - data_con_arity == 3 && - isJust maybe_arg3_tycon && - (arg3_tycon == byteArrayPrimTyCon || - arg3_tycon == mutableByteArrayPrimTyCon) - = do case_bndr <- newSysLocalDs arg_ty - vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys - return (Var arr_cts_var, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] - ) - - | otherwise - = do l <- getSrcSpanDs - pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) - where - arg_ty = exprType arg - maybe_product_type = splitDataProductType_maybe arg_ty - is_product_type = isJust maybe_product_type - Just (_, _, data_con, data_con_arg_tys) = maybe_product_type - data_con_arity = dataConSourceArity data_con - (data_con_arg_ty1 : _) = data_con_arg_tys - - (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys - maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 - Just arg3_tycon = maybe_arg3_tycon - -boxResult :: Type - -> DsM (Type, CoreExpr -> CoreExpr) - --- Takes the result of the user-level ccall: --- either (IO t), --- or maybe just t for a side-effect-free call --- Returns a wrapper for the primitive ccall itself, along with the --- type of the result of the primitive ccall. This result type --- will be of the form --- State# RealWorld -> (# State# RealWorld, t' #) --- where t' is the unwrapped form of t. If t is simply (), then --- the result type will be --- State# RealWorld -> (# State# RealWorld #) - -boxResult result_ty - | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty - -- isIOType_maybe handles the case where the type is a - -- simple wrapping of IO. E.g. - -- newtype Wrap a = W (IO a) - -- No coercion necessary because its a non-recursive newtype - -- (If we wanted to handle a *recursive* newtype too, we'd need - -- another case, and a coercion.) - -- The result is IO t, so wrap the result in an IO constructor - = do { res <- resultWrapper io_res_ty - ; let extra_result_tys - = case res of - (Just ty,_) - | isUnboxedTupleType ty - -> let Just ls = tyConAppArgs_maybe ty in tail ls - _ -> [] - - return_result state anss - = mkCoreUbxTup - (realWorldStatePrimTy : io_res_ty : extra_result_tys) - (state : anss) - - ; (ccall_res_ty, the_alt) <- mk_alt return_result res - - ; state_id <- newSysLocalDs realWorldStatePrimTy - ; let io_data_con = head (tyConDataCons io_tycon) - toIOCon = dataConWrapId io_data_con - - wrap the_call = - mkApps (Var toIOCon) - [ Type io_res_ty, - Lam state_id $ - mkWildCase (App the_call (Var state_id)) - ccall_res_ty - (coreAltType the_alt) - [the_alt] - ] - - ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) } - -boxResult result_ty - = do -- It isn't IO, so do unsafePerformIO - -- It's not conveniently available, so we inline it - res <- resultWrapper result_ty - (ccall_res_ty, the_alt) <- mk_alt return_result res - let - wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) - ccall_res_ty - (coreAltType the_alt) - [the_alt] - return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) - where - return_result _ [ans] = ans - return_result _ _ = panic "return_result: expected single result" - - -mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) - -> (Maybe Type, Expr Var -> Expr Var) - -> DsM (Type, (AltCon, [Id], Expr Var)) -mk_alt return_result (Nothing, wrap_result) - = do -- The ccall returns () - state_id <- newSysLocalDs realWorldStatePrimTy - let - the_rhs = return_result (Var state_id) - [wrap_result (panic "boxResult")] - - ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] - the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) - - return (ccall_res_ty, the_alt) - -mk_alt return_result (Just prim_res_ty, wrap_result) - = -- The ccall returns a non-() value - ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty ) - -- True because resultWrapper ensures it is so - do { result_id <- newSysLocalDs prim_res_ty - ; state_id <- newSysLocalDs realWorldStatePrimTy - ; let the_rhs = return_result (Var state_id) - [wrap_result (Var result_id)] - ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] - the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) - ; return (ccall_res_ty, the_alt) } - - -resultWrapper :: Type - -> DsM (Maybe Type, -- Type of the expected result, if any - CoreExpr -> CoreExpr) -- Wrapper for the result --- resultWrapper deals with the result *value* --- E.g. foreign import foo :: Int -> IO T --- Then resultWrapper deals with marshalling the 'T' part --- So if resultWrapper ty = (Just ty_rep, marshal) --- then marshal (e :: ty_rep) :: ty --- That is, 'marshal' wrape the result returned by the foreign call, --- of type ty_rep, into the value Haskell expected, of type 'ty' --- --- Invariant: ty_rep is always a primitive type --- i.e. (isPrimitiveType ty_rep) is True - -resultWrapper result_ty - -- Base case 1: primitive types - | isPrimitiveType result_ty - = return (Just result_ty, \e -> e) - - -- Base case 2: the unit type () - | Just (tc,_) <- maybe_tc_app - , tc `hasKey` unitTyConKey - = return (Nothing, \_ -> Var unitDataConId) - - -- Base case 3: the boolean type - | Just (tc,_) <- maybe_tc_app - , tc `hasKey` boolTyConKey - = do { dflags <- getDynFlags - ; let marshal_bool e - = mkWildCase e intPrimTy boolTy - [ (DEFAULT ,[],Var trueDataConId ) - , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)] - ; return (Just intPrimTy, marshal_bool) } - - -- Newtypes - | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty - = do { (maybe_ty, wrapper) <- resultWrapper rep_ty - ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) } - - -- The type might contain foralls (eg. for dummy type arguments, - -- referring to 'Ptr a' is legal). - | Just (tyvar, rest) <- splitForAllTy_maybe result_ty - = do { (maybe_ty, wrapper) <- resultWrapper rest - ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) } - - -- Data types with a single constructor, which has a single arg - -- This includes types like Ptr and ForeignPtr - | Just (tycon, tycon_arg_tys) <- maybe_tc_app - , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials - , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument - = do { dflags <- getDynFlags - ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty - ; let narrow_wrapper = maybeNarrow dflags tycon - marshal_con e = Var (dataConWrapId data_con) - `mkTyApps` tycon_arg_tys - `App` wrapper (narrow_wrapper e) - ; return (maybe_ty, marshal_con) } - - | otherwise - = pprPanic "resultWrapper" (ppr result_ty) - where - maybe_tc_app = splitTyConApp_maybe result_ty - --- When the result of a foreign call is smaller than the word size, we --- need to sign- or zero-extend the result up to the word size. The C --- standard appears to say that this is the responsibility of the --- caller, not the callee. - -maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) -maybeNarrow dflags tycon - | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e - | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e - | tycon `hasKey` int32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e - - | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e - | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e - | tycon `hasKey` word32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e - | otherwise = id diff --git a/deSugar/DsExpr.hs b/deSugar/DsExpr.hs deleted file mode 100644 --- a/deSugar/DsExpr.hs +++ /dev/null @@ -1,1213 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring expressions. --} - -{-# LANGUAGE CPP, MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds - , dsValBinds, dsLit, dsSyntaxExpr ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Match -import MatchLit -import DsBinds -import DsGRHSs -import DsListComp -import DsUtils -import DsArrows -import DsMonad -import GHC.HsToCore.PmCheck ( checkGuardMatches ) -import Name -import NameEnv -import FamInstEnv( topNormaliseType ) -import DsMeta -import GHC.Hs - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types -import TcType -import TcEvidence -import TcRnMonad -import Type -import CoreSyn -import CoreUtils -import MkCore - -import DynFlags -import CostCentre -import Id -import MkId -import Module -import ConLike -import DataCon -import TyCoPpr( pprWithTYPE ) -import TysWiredIn -import PrelNames -import BasicTypes -import Maybes -import VarEnv -import SrcLoc -import Util -import Bag -import Outputable -import PatSyn - -import Control.Monad - -{- -************************************************************************ -* * - dsLocalBinds, dsValBinds -* * -************************************************************************ --} - -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body -dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body -dsLocalBinds _ _ = panic "dsLocalBinds" - -------------------------- --- caller sets location -dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsValBinds (XValBindsLR (NValBinds binds _)) body - = foldrM ds_val_bind body binds -dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" - -------------------------- -dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ev_binds ip_binds) body - = do { ds_binds <- dsTcEvBinds ev_binds - ; let inner = mkCoreLets ds_binds body - -- The dict bindings may not be in - -- dependency order; hence Rec - ; foldrM ds_ip_bind inner ip_binds } - where - ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body - = do e' <- dsLExpr e - return (Let (NonRec n e') body) - ds_ip_bind _ _ = panic "dsIPBinds" -dsIPBinds (XHsIPBinds nec) _ = noExtCon nec - -------------------------- --- caller sets location -ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr --- Special case for bindings which bind unlifted variables --- We need to do a case right away, rather than building --- a tuple and doing selections. --- Silently ignore INLINE and SPECIALISE pragmas... -ds_val_bind (NonRecursive, hsbinds) body - | [dL->L loc bind] <- bagToList hsbinds - -- Non-recursive, non-overloaded bindings only come in ones - -- ToDo: in some bizarre case it's conceivable that there - -- could be dict binds in the 'binds'. (See the notes - -- below. Then pattern-match would fail. Urk.) - , isUnliftedHsBind bind - = putSrcSpanDs loc $ - -- see Note [Strict binds checks] in DsBinds - if is_polymorphic bind - then errDsCoreExpr (poly_bind_err bind) - -- data Ptr a = Ptr Addr# - -- f x = let p@(Ptr y) = ... in ... - -- Here the binding for 'p' is polymorphic, but does - -- not mix with an unlifted binding for 'y'. You should - -- use a bang pattern. #6078. - - else do { when (looksLazyPatBind bind) $ - warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) - -- Complain about a binding that looks lazy - -- e.g. let I# y = x in ... - -- Remember, in checkStrictBinds we are going to do strict - -- matching, so (for software engineering reasons) we insist - -- that the strictness is manifest on each binding - -- However, lone (unboxed) variables are ok - - - ; dsUnliftedBind bind body } - where - is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) - = not (null tvs && null evs) - is_polymorphic _ = False - - unlifted_must_be_bang bind - = hang (text "Pattern bindings containing unlifted types should use" $$ - text "an outermost bang pattern:") - 2 (ppr bind) - - poly_bind_err bind - = hang (text "You can't mix polymorphic and unlifted bindings:") - 2 (ppr bind) $$ - text "Probable fix: add a type signature" - -ds_val_bind (is_rec, binds) _body - | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds - = ASSERT( isRec is_rec ) - errDsCoreExpr $ - hang (text "Recursive bindings for unlifted types aren't allowed:") - 2 (vcat (map ppr (bagToList binds))) - --- Ordinary case for bindings; none should be unlifted -ds_val_bind (is_rec, binds) body - = do { MASSERT( isRec is_rec || isSingletonBag binds ) - -- we should never produce a non-recursive list of multiple binds - - ; (force_vars,prs) <- dsLHsBinds binds - ; let body' = foldr seqVar body force_vars - ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) - case prs of - [] -> return body - _ -> return (Let (Rec prs) body') } - -- Use a Rec regardless of is_rec. - -- Why? Because it allows the binds to be all - -- mixed up, which is what happens in one rare case - -- Namely, for an AbsBind with no tyvars and no dicts, - -- but which does have dictionary bindings. - -- See notes with TcSimplify.inferLoop [NO TYVARS] - -- It turned out that wrapping a Rec here was the easiest solution - -- - -- NB The previous case dealt with unlifted bindings, so we - -- only have to deal with lifted ones now; so Rec is ok - ------------------- -dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr -dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = lbinds }) body - = do { let body1 = foldr bind_export body exports - bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b - ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) - body1 lbinds - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (mkCoreLets ds_binds body2) } - -dsUnliftedBind (FunBind { fun_id = (dL->L l fun) - , fun_matches = matches - , fun_co_fn = co_fn - , fun_tick = tick }) body - -- Can't be a bang pattern (that looks like a PatBind) - -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun)) - Nothing matches - ; MASSERT( null args ) -- Functions aren't lifted - ; MASSERT( isIdHsWrapper co_fn ) - ; let rhs' = mkOptTickBox tick rhs - ; return (bindNonRec fun rhs' body) } - -dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss - , pat_ext = NPatBindTc _ ty }) body - = -- let C x# y# = rhs in body - -- ==> case rhs of C x# y# -> body - do { rhs <- dsGuarded grhss ty - ; checkGuardMatches PatBindGuards grhss - ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], - eqn_orig = FromSource, - eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar upat - ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (bindNonRec var rhs result) } - -dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) - -{- -************************************************************************ -* * -\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} -* * -************************************************************************ --} - -dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr - -dsLExpr (dL->L loc e) - = putSrcSpanDs loc $ - do { core_expr <- dsExpr e - -- uncomment this check to test the hsExprType function in TcHsSyn - -- ; MASSERT2( exprType core_expr `eqType` hsExprType e - -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ - -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) - ; return core_expr } - --- | Variant of 'dsLExpr' that ensures that the result is not levity --- polymorphic. This should be used when the resulting expression will --- be an argument to some other function. --- See Note [Levity polymorphism checking] in DsMonad --- See Note [Levity polymorphism invariants] in CoreSyn -dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsLExprNoLP (dL->L loc e) - = putSrcSpanDs loc $ - do { e' <- dsExpr e - ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) - ; return e' } - -dsExpr :: HsExpr GhcTc -> DsM CoreExpr -dsExpr = ds_expr False - -ds_expr :: Bool -- are we directly inside an HsWrap? - -- See Wrinkle in Note [Detecting forced eta expansion] - -> HsExpr GhcTc -> DsM CoreExpr -ds_expr _ (HsPar _ e) = dsLExpr e -ds_expr _ (ExprWithTySig _ e _) = dsLExpr e -ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var -ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them -ds_expr w (HsConLikeOut _ con) = dsConLike w con -ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" -ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" - -ds_expr _ (HsLit _ lit) - = do { warnAboutOverflowedLit lit - ; dsLit (convertLit lit) } - -ds_expr _ (HsOverLit _ lit) - = do { warnAboutOverflowedOverLit lit - ; dsOverLit lit } - -ds_expr _ (HsWrap _ co_fn e) - = do { e' <- ds_expr True e -- This is the one place where we recurse to - -- ds_expr (passing True), rather than dsExpr - ; wrap' <- dsHsWrapper co_fn - ; dflags <- getDynFlags - ; let wrapped_e = wrap' e' - wrapped_ty = exprType wrapped_e - ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion] - ; warnAboutIdentities dflags e' wrapped_ty - ; return wrapped_e } - -ds_expr _ (NegApp _ (dL->L loc - (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) - neg_expr) - = do { expr' <- putSrcSpanDs loc $ do - { warnAboutOverflowedOverLit - (lit { ol_val = HsIntegral (negateIntegralLit i) }) - ; dsOverLit lit } - ; dsSyntaxExpr neg_expr [expr'] } - -ds_expr _ (NegApp _ expr neg_expr) - = do { expr' <- dsLExpr expr - ; dsSyntaxExpr neg_expr [expr'] } - -ds_expr _ (HsLam _ a_Match) - = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match - -ds_expr _ (HsLamCase _ matches) - = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches - ; return $ Lam discrim_var matching_code } - -ds_expr _ e@(HsApp _ fun arg) - = do { fun' <- dsLExpr fun - ; dsWhenNoErrs (dsLExprNoLP arg) - (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } - -ds_expr _ (HsAppType _ e _) - -- ignore type arguments here; they're in the wrappers instead at this point - = dsLExpr e - -{- -Note [Desugaring vars] -~~~~~~~~~~~~~~~~~~~~~~ -In one situation we can get a *coercion* variable in a HsVar, namely -the support method for an equality superclass: - class (a~b) => C a b where ... - instance (blah) => C (T a) (T b) where .. -Then we get - $dfCT :: forall ab. blah => C (T a) (T b) - $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) - - $c$p1C :: forall ab. blah => (T a ~ T b) - $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g - -That 'g' in the 'in' part is an evidence variable, and when -converting to core it must become a CO. - - -Note [Desugaring operator sections] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At first it looks as if we can convert - - (expr `op`) - -naively to - - \x -> op expr x - -But no! expr might be a redex, and we can lose laziness badly this -way. Consider - - map (expr `op`) xs - -for example. If expr were a redex then eta-expanding naively would -result in multiple evaluations where the user might only have expected one. - -So we convert instead to - - let y = expr in \x -> op y x - -Also, note that we must do this for both right and (perhaps surprisingly) left -sections. Why are left sections necessary? Consider the program (found in #18151), - - seq (True `undefined`) () - -according to the Haskell Report this should reduce to () (as it specifies -desugaring via eta expansion). However, if we fail to eta expand we will rather -bottom. Consequently, we must eta expand even in the case of a left section. - -If `expr` is actually just a variable, say, then the simplifier -will inline `y`, eliminating the redundant `let`. - -Note that this works even in the case that `expr` is unlifted. In this case -bindNonRec will automatically do the right thing, giving us: - - case expr of y -> (\x -> op y x) - -See #18151. --} - -ds_expr _ e@(OpApp _ e1 op e2) - = -- for the type of y, we need the type of op's 2nd argument - do { op' <- dsLExpr op - ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) - (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } - --- dsExpr (SectionL op expr) === (expr `op`) ~> \y -> op expr y --- --- See Note [Desugaring operator sections]. --- N.B. this also must handle postfix operator sections due to -XPostfixOperators. -ds_expr _ e@(SectionL _ expr op) = do - core_op <- dsLExpr op - x_core <- dsLExpr expr - case splitFunTys (exprType core_op) of - -- Binary operator section - (x_ty:y_ty:_, _) -> do - dsWhenNoErrs - (mapM newSysLocalDsNoLP [x_ty, y_ty]) - (\[x_id, y_id] -> - bindNonRec x_id x_core - $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e) - core_op [Var x_id, Var y_id])) - - -- Postfix operator section - (_:_, _) -> do - return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core - - _ -> pprPanic "dsExpr(SectionL)" (ppr e) - --- dsExpr (SectionR op expr) === (`op` expr) ~> \x -> op x expr --- --- See Note [Desugaring operator sections]. -ds_expr _ e@(SectionR _ op expr) = do - core_op <- dsLExpr op - let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) - y_core <- dsLExpr expr - dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) - (\[x_id, y_id] -> bindNonRec y_id y_core $ - Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) - core_op [Var x_id, Var y_id])) - -ds_expr _ (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (dL->L _ (Missing ty)) - -- For every missing expression, we need - -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDsNoLP ty - ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (dL->L _ (Present _ expr)) - -- Expressions that are present don't generate - -- lambdas, just arguments. - = do { core_expr <- dsLExprNoLP expr - ; return (lam_vars, core_expr : args) } - go _ _ = panic "ds_expr" - - ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) - -- The reverse is because foldM goes left-to-right - (\(lam_vars, args) -> mkCoreLams lam_vars $ - mkCoreTupBoxity boxity args) } - -- See Note [Don't flatten tuples from HsSyn] in MkCore - -ds_expr _ (ExplicitSum types alt arity expr) - = do { dsWhenNoErrs (dsLExprNoLP expr) - (\core_expr -> mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep) types ++ - map Type types ++ - [core_expr]) ) } - -ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do - dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags - then do - mod_name <- getModule - count <- goptM Opt_ProfCountEntries - let nm = sl_fs cc - flavour <- ExprCC <$> getCCIndexM nm - Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True) - <$> dsLExpr expr - else dsLExpr expr - -ds_expr _ (HsCoreAnn _ _ _ expr) - = dsLExpr expr - -ds_expr _ (HsCase _ discrim matches) - = do { core_discrim <- dsLExpr discrim - ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches - ; return (bindNonRec discrim_var core_discrim matching_code) } - --- Pepe: The binds are in scope in the body but NOT in the binding group --- This is to avoid silliness in breakpoints -ds_expr _ (HsLet _ binds body) = do - body' <- dsLExpr body - dsLocalBinds binds body' - --- We need the `ListComp' form to use `deListComp' (rather than the "do" form) --- because the interpretation of `stmts' depends on what sort of thing it is. --- -ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty -ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts - -ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) - = do { pred <- dsLExpr guard_expr - ; b1 <- dsLExpr then_expr - ; b2 <- dsLExpr else_expr - ; case mb_fun of - Just fun -> dsSyntaxExpr fun [pred, b1, b2] - Nothing -> return $ mkIfThenElse pred b1 b2 } - -ds_expr _ (HsMultiIf res_ty alts) - | null alts - = mkErrorExpr - - | otherwise - = do { match_result <- liftM (foldr1 combineMatchResults) - (mapM (dsGRHS IfAlt res_ty) alts) - ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds)) - ; error_expr <- mkErrorExpr - ; extractMatchResult match_result error_expr } - where - mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty - (text "multi-way if") - -{- -\noindent -\underline{\bf Various data construction things} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -ds_expr _ (ExplicitList elt_ty wit xs) - = dsExplicitList elt_ty wit xs - -ds_expr _ (ArithSeq expr witness seq) - = case witness of - Nothing -> dsArithSeq expr seq - Just fl -> do { newArithSeq <- dsArithSeq expr seq - ; dsSyntaxExpr fl [newArithSeq] } - -{- -Static Pointers -~~~~~~~~~~~~~~~ - -See Note [Grand plan for static forms] in StaticPtrTable for an overview. - - g = ... static f ... -==> - g = ... makeStatic loc f ... --} - -ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do - expr_ds <- dsLExprNoLP expr - let ty = exprType expr_ds - makeStaticId <- dsLookupGlobalId makeStaticName - - dflags <- getDynFlags - let (line, col) = case loc of - RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r - , srcLocCol $ realSrcSpanStart r - ) - _ -> (0, 0) - srcLoc = mkCoreConApps (tupleDataCon Boxed 2) - [ Type intTy , Type intTy - , mkIntExprInt dflags line, mkIntExprInt dflags col - ] - - putSrcSpanDs loc $ return $ - mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] - -{- -\noindent -\underline{\bf Record construction and update} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record construction we do this (assuming T has three arguments) -\begin{verbatim} - T { op2 = e } -==> - let err = /\a -> recConErr a - T (recConErr t1 "M.hs/230/op1") - e - (recConErr t1 "M.hs/230/op3") -\end{verbatim} -@recConErr@ then converts its argument string into a proper message -before printing it as -\begin{verbatim} - M.hs, line 230: missing field op1 was evaluated -\end{verbatim} - -We also handle @C{}@ as valid construction syntax for an unlabelled -constructor @C@, setting all of @C@'s fields to bottom. --} - -ds_expr _ (RecordCon { rcon_flds = rbinds - , rcon_ext = RecordConTc { rcon_con_expr = con_expr - , rcon_con_like = con_like }}) - = do { con_expr' <- dsExpr con_expr - ; let - (arg_tys, _) = tcSplitFunTys (exprType con_expr') - -- A newtype in the corner should be opaque; - -- hence TcType.tcSplitFunTys - - mk_arg (arg_ty, fl) - = case findField (rec_flds rbinds) (flSelector fl) of - (rhs:rhss) -> ASSERT( null rhss ) - dsLExprNoLP rhs - [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) - unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty - - labels = conLikeFieldLabels con_like - - ; con_args <- if null labels - then mapM unlabelled_bottom arg_tys - else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) - - ; return (mkCoreApps con_expr' con_args) } - -{- -Record update is a little harder. Suppose we have the decl: -\begin{verbatim} - data T = T1 {op1, op2, op3 :: Int} - | T2 {op4, op2 :: Int} - | T3 -\end{verbatim} -Then we translate as follows: -\begin{verbatim} - r { op2 = e } -===> - let op2 = e in - case r of - T1 op1 _ op3 -> T1 op1 op2 op3 - T2 op4 _ -> T2 op4 op2 - other -> recUpdError "M.hs/230" -\end{verbatim} -It's important that we use the constructor Ids for @T1@, @T2@ etc on the -RHSs, and do not generate a Core constructor application directly, because the constructor -might do some argument-evaluation first; and may have to throw away some -dictionaries. - -Note [Update for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b where - T1 :: { f1 :: a } -> T a Int - -Then the wrapper function for T1 has type - $WT1 :: a -> T a Int -But if x::T a b, then - x { f1 = v } :: T a b (not T a Int!) -So we need to cast (T a Int) to (T a b). Sigh. - --} - -ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields - , rupd_ext = RecordUpdTc - { rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys - , rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap }} ) - | null fields - = dsLExpr record_expr - | otherwise - = ASSERT2( notNull cons_to_upd, ppr expr ) - - do { record_expr' <- dsLExpr record_expr - ; field_binds' <- mapM ds_field fields - ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding - upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] - - -- It's important to generate the match with matchWrapper, - -- and the right hand sides with applications of the wrapper Id - -- so that everything works when we are doing fancy unboxing on the - -- constructor arguments. - ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd - ; ([discrim_var], matching_code) - <- matchWrapper RecUpd Nothing - (MG { mg_alts = noLoc alts - , mg_ext = MatchGroupTc [in_ty] out_ty - , mg_origin = FromSource }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings - - ; return (add_field_binds field_binds' $ - bindNonRec discrim_var record_expr' matching_code) } - where - ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) - -- Clone the Id in the HsRecField, because its Name is that - -- of the record selector, and we must not make that a local binder - -- else we shadow other uses of the record selector - -- Hence 'lcl_id'. Cf #2735 - ds_field (dL->L _ rec_field) - = do { rhs <- dsLExpr (hsRecFieldArg rec_field) - ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } - - add_field_binds [] expr = expr - add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) - - -- Awkwardly, for families, the match goes - -- from instance type to family type - (in_ty, out_ty) = - case (head cons_to_upd) of - RealDataCon data_con -> - let tycon = dataConTyCon data_con in - (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) - PatSynCon pat_syn -> - ( patSynInstResTy pat_syn in_inst_tys - , patSynInstResTy pat_syn out_inst_tys) - mk_alt upd_fld_env con - = do { let (univ_tvs, ex_tvs, eq_spec, - prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - user_tvs = - case con of - RealDataCon data_con -> dataConUserTyVars data_con - PatSynCon _ -> univ_tvs ++ ex_tvs - -- The order here is because of the order in `TcPatSyn`. - in_subst = zipTvSubst univ_tvs in_inst_tys - out_subst = zipTvSubst univ_tvs out_inst_tys - - -- I'm not bothering to clone the ex_tvs - ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) - ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys) - ; let field_labels = conLikeFieldLabels con - val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - field_labels arg_ids - mk_val_arg fl pat_arg_id - = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) - -- Reconstruct with the WrapId so that unpacking happens - wrap = mkWpEvVarApps theta_vars <.> - dict_req_wrap <.> - mkWpTyApps [ lookupTyVar out_subst tv - `orElse` mkTyVarTy tv - | tv <- user_tvs - , not (tv `elemVarEnv` wrap_subst) ] - -- Be sure to use user_tvs (which may be ordered - -- differently than `univ_tvs ++ ex_tvs) above. - -- See Note [DataCon user type variable binders] - -- in DataCon. - rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args - - -- Tediously wrap the application in a cast - -- Note [Update for GADTs] - wrapped_rhs = - case con of - RealDataCon data_con -> - let - wrap_co = - mkTcTyConAppCo Nominal - (dataConTyCon data_con) - [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys ] - lookup univ_tv ty = - case lookupVarEnv wrap_subst univ_tv of - Just co' -> co' - Nothing -> mkTcReflCo Nominal ty - in if null eq_spec - then rhs - else mkLHsWrap (mkWpCastN wrap_co) rhs - -- eq_spec is always null for a PatSynCon - PatSynCon _ -> rhs - - wrap_subst = - mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) - | (spec, eq_var) <- eq_spec `zip` eqs_vars - , let tv = eqSpecTyVar spec ] - - req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - - pat = noLoc $ ConPatOut { pat_con = noLoc con - , pat_tvs = ex_tvs - , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_arg_tys = in_inst_tys - , pat_wrap = req_wrap } - ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } - --- Here is where we desugar the Template Haskell brackets and escapes - --- Template Haskell stuff - -ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" -ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps -ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) - --- Arrow notation extension -ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd - --- Hpc Support - -ds_expr _ (HsTick _ tickish e) = do - e' <- dsLExpr e - return (Tick tickish e') - --- There is a problem here. The then and else branches --- have no free variables, so they are open to lifting. --- We need someway of stopping this. --- This will make no difference to binary coverage --- (did you go here: YES or NO), but will effect accurate --- tick counting. - -ds_expr _ (HsBinTick _ ixT ixF e) = do - e2 <- dsLExpr e - do { ASSERT(exprType e2 `eqType` boolTy) - mkBinaryTickBox ixT ixF e2 - } - -ds_expr _ (HsTickPragma _ _ _ _ expr) = do - dflags <- getDynFlags - if gopt Opt_Hpc dflags - then panic "dsExpr:HsTickPragma" - else dsLExpr expr - --- HsSyn constructs that just shouldn't be here: -ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" -ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" -ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" -ds_expr _ (XExpr nec) = noExtCon nec - - ------------------------------- -dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr -dsSyntaxExpr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - arg_exprs - = do { fun <- dsExpr expr - ; core_arg_wraps <- mapM dsHsWrapper arg_wraps - ; core_res_wrap <- dsHsWrapper res_wrap - ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs - ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) - (\_ -> core_res_wrap (mkApps fun wrapped_args)) } - where - mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) - -findField :: [LHsRecField GhcTc arg] -> Name -> [arg] -findField rbinds sel - = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds - , sel == idName (unLoc $ hsRecFieldId fld) ] - -{- -%-------------------------------------------------------------------- - -Note [Desugaring explicit lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Explicit lists are desugared in a cleverer way to prevent some -fruitless allocations. Essentially, whenever we see a list literal -[x_1, ..., x_n] we generate the corresponding expression in terms of -build: - -Explicit lists (literals) are desugared to allow build/foldr fusion when -beneficial. This is a bit of a trade-off, - - * build/foldr fusion can generate far larger code than the corresponding - cons-chain (e.g. see #11707) - - * even when it doesn't produce more code, build can still fail to fuse, - requiring that the simplifier do more work to bring the expression - back into cons-chain form; this costs compile time - - * when it works, fusion can be a significant win. Allocations are reduced - by up to 25% in some nofib programs. Specifically, - - Program Size Allocs Runtime CompTime - rewrite +0.0% -26.3% 0.02 -1.8% - ansi -0.3% -13.8% 0.00 +0.0% - lift +0.0% -8.7% 0.00 -2.3% - -At the moment we use a simple heuristic to determine whether build will be -fruitful: for small lists we assume the benefits of fusion will be worthwhile; -for long lists we assume that the benefits will be outweighted by the cost of -code duplication. This magic length threshold is @maxBuildLength@. Also, fusion -won't work at all if rewrite rules are disabled, so we don't use the build-based -desugaring in this case. - -We used to have a more complex heuristic which would try to break the list into -"static" and "dynamic" parts and only build-desugar the dynamic part. -Unfortunately, determining "static-ness" reliably is a bit tricky and the -heuristic at times produced surprising behavior (see #11710) so it was dropped. --} - -{- | The longest list length which we will desugar using @build@. - -This is essentially a magic number and its setting is unfortunate rather -arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], -is to avoid deforesting large static data into large(r) code. Ideally we'd -want a smaller threshold with larger consumers and vice-versa, but we have no -way of knowing what will be consuming our list in the desugaring impossible to -set generally correctly. - -The effect of reducing this number will be that 'build' fusion is applied -less often. From a runtime performance perspective, applying 'build' more -liberally on "moderately" sized lists should rarely hurt and will often it can -only expose further optimization opportunities; if no fusion is possible it will -eventually get rule-rewritten back to a list). We do, however, pay in compile -time. --} -maxBuildLength :: Int -maxBuildLength = 32 - -dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] - -> DsM CoreExpr --- See Note [Desugaring explicit lists] -dsExplicitList elt_ty Nothing xs - = do { dflags <- getDynFlags - ; xs' <- mapM dsLExprNoLP xs - ; if xs' `lengthExceeds` maxBuildLength - -- Don't generate builds if the list is very long. - || null xs' - -- Don't generate builds when the [] constructor will do - || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off - -- Don't generate a build if there are no rules to eliminate it! - -- See Note [Desugaring RULE left hand sides] in Desugar - then return $ mkListExpr elt_ty xs' - else mkBuildExpr elt_ty (mk_build_list xs') } - where - mk_build_list xs' (cons, _) (nil, _) - = return (foldr (App . App (Var cons)) (Var nil) xs') - -dsExplicitList elt_ty (Just fln) xs - = do { list <- dsExplicitList elt_ty Nothing xs - ; dflags <- getDynFlags - ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } - -dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr -dsArithSeq expr (From from) - = App <$> dsExpr expr <*> dsLExprNoLP from -dsArithSeq expr (FromTo from to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from Nothing to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - to' <- dsLExprNoLP to - return $ mkApps expr' [from', to'] -dsArithSeq expr (FromThen from thn) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] -dsArithSeq expr (FromThenTo from thn to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from (Just thn) to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - thn' <- dsLExprNoLP thn - to' <- dsLExprNoLP to - return $ mkApps expr' [from', thn', to'] - -{- -Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're -handled in DsListComp). Basically does the translation given in the -Haskell 98 report: --} - -dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsDo stmts - = goL stmts - where - goL [] = panic "dsDo" - goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - go _ (LastStmt _ body _ _) stmts - = ASSERT( null stmts ) dsLExpr body - -- The 'return' op isn't used for 'do' expressions - - go _ (BodyStmt _ rhs then_expr _) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs (exprType rhs2) - ; rest <- goL stmts - ; dsSyntaxExpr then_expr [rhs2, rest] } - - go _ (LetStmt _ binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } - - go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - - go _ (ApplicativeStmt body_ty args mb_join) stmts - = do { - let - (pats, rhss) = unzip (map (do_arg . snd) args) - - do_arg (ApplicativeArgOne _ pat expr _ fail_op) = - ((pat, fail_op), dsLExpr expr) - do_arg (ApplicativeArgMany _ stmts ret pat) = - ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) - do_arg (XApplicativeArg nec) = noExtCon nec - - ; rhss' <- sequence rhss - - ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) - - ; let match_args (pat, fail_op) (vs,body) - = do { var <- selectSimpleMatchVarL pat - ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat - body_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; return (var:vs, match_code) - } - - ; (vars, body) <- foldrM match_args ([],body') pats - ; let fun' = mkLams vars body - ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] - ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') - ; case mb_join of - Nothing -> return expr - Just join_op -> dsSyntaxExpr join_op [expr] } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = return_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_ext = RecStmtTc - { recS_bind_ty = bind_ty - , recS_rec_rets = rec_rets - , recS_ret_ty = body_ty} }) stmts - = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } - where - new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) - mfix_app bind_op - noSyntaxExpr -- Tuple cannot fail - - tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids - tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case - rec_tup_pats = map nlVarPat tup_ids - later_pats = rec_tup_pats - rets = map noLoc rec_rets - mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam noExtField - (MG { mg_alts = noLoc [mkSimpleMatch - LambdaExpr - [mfix_pat] body] - , mg_ext = MatchGroupTc [tup_ty] body_ty - , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo body_ty - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) - ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] - ret_stmt = noLoc $ mkLastStmt ret_app - -- This LastStmt will be desugared with dsDo, - -- which ignores the return_op in the LastStmt, - -- so we must apply the return_op explicitly - - go _ (ParStmt {}) _ = panic "dsDo ParStmt" - go _ (TransStmt {}) _ = panic "dsDo TransStmt" - go _ (XStmtLR nec) _ = noExtCon nec - -handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr - -- In a do expression, pattern-match failure just calls - -- the monadic 'fail' rather than throwing an exception -handle_failure pat match fail_op - | matchCanFail match - = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] - ; extractMatchResult match fail_expr } - | otherwise - = extractMatchResult match (error "It can't fail") - -mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String -mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ - showPpr dflags (getLoc pat) - -{- -************************************************************************ -* * - Desugaring Variables -* * -************************************************************************ --} - -dsHsVar :: Bool -- are we directly inside an HsWrap? - -- See Wrinkle in Note [Detecting forced eta expansion] - -> Id -> DsM CoreExpr -dsHsVar w var - | not w - , let bad_tys = badUseOfLevPolyPrimop var ty - , not (null bad_tys) - = do { levPolyPrimopErr var ty bad_tys - ; return unitExpr } -- return something eminently safe - - | otherwise - = return (varToCoreExpr var) -- See Note [Desugaring vars] - - where - ty = idType var - -dsConLike :: Bool -- as in dsHsVar - -> ConLike -> DsM CoreExpr -dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc) -dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of - Just (id, add_void) - | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) - | otherwise -> Var id - _ -> pprPanic "dsConLike" (ppr ps) - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ --} - --- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () -warnDiscardedDoBindings rhs rhs_ty - | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty - = do { warn_unused <- woptM Opt_WarnUnusedDoBind - ; warn_wrong <- woptM Opt_WarnWrongDoBind - ; when (warn_unused || warn_wrong) $ - do { fam_inst_envs <- dsGetFamInstEnvs - ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty - - -- Warn about discarding non-() things in 'monadic' binding - ; if warn_unused && not (isUnitTy norm_elt_ty) - then warnDs (Reason Opt_WarnUnusedDoBind) - (badMonadBind rhs elt_ty) - else - - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - when warn_wrong $ - do { case tcSplitAppTy_maybe norm_elt_ty of - Just (elt_m_ty, _) - | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> warnDs (Reason Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) - _ -> return () } } } - - | otherwise -- RHS does have type of form (m ty), which is weird - = return () -- but at lesat this warning is irrelevant - -badMonadBind :: LHsExpr GhcTc -> Type -> SDoc -badMonadBind rhs elt_ty - = vcat [ hang (text "A do-notation statement discarded a result of type") - 2 (quotes (ppr elt_ty)) - , hang (text "Suppress this warning by saying") - 2 (quotes $ text "_ <-" <+> ppr rhs) - ] - -{- -************************************************************************ -* * - Forced eta expansion and levity polymorphism -* * -************************************************************************ - -Note [Detecting forced eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We cannot have levity polymorphic function arguments. See -Note [Levity polymorphism invariants] in CoreSyn. But we *can* have -functions that take levity polymorphic arguments, as long as these -functions are eta-reduced. (See #12708 for an example.) - -However, we absolutely cannot do this for functions that have no -binding (i.e., say True to Id.hasNoBinding), like primops and unboxed -tuple constructors. These get eta-expanded in CorePrep.maybeSaturate. - -Detecting when this is about to happen is a bit tricky, though. When -the desugarer is looking at the Id itself (let's be concrete and -suppose we have (#,#)), we don't know whether it will be levity -polymorphic. So the right spot seems to be to look after the Id has -been applied to its type arguments. To make the algorithm efficient, -it's important to be able to spot ((#,#) @a @b @c @d) without looking -past all the type arguments. We thus require that - * The body of an HsWrap is not an HsWrap. -With that representation invariant, we simply look inside every HsWrap -to see if its body is an HsVar whose Id hasNoBinding. Then, we look -at the wrapped type. If it has any levity polymorphic arguments, reject. - -Interestingly, this approach does not look to see whether the Id in -question will be eta expanded. The logic is this: - * Either the Id in question is saturated or not. - * If it is, then it surely can't have levity polymorphic arguments. - If its wrapped type contains levity polymorphic arguments, reject. - * If it's not, then it can't be eta expanded with levity polymorphic - argument. If its wrapped type contains levity polymorphic arguments, reject. -So, either way, we're good to reject. - -Wrinkle -~~~~~~~ -Not all polymorphic Ids are wrapped in -HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type -application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id -without a wrapper, then that is surely problem and we can reject. - -We thus have a parameter to `dsExpr` that tracks whether or not we are -directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when -we're not directly in an HsWrap, reject. - --} - --- | Takes an expression and its instantiated type. If the expression is an --- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments, --- issue an error. See Note [Detecting forced eta expansion] -checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () -checkForcedEtaExpansion expr ty - | Just var <- case expr of - HsVar _ (dL->L _ var) -> Just var - HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) - _ -> Nothing - , let bad_tys = badUseOfLevPolyPrimop var ty - , not (null bad_tys) - = levPolyPrimopErr var ty bad_tys -checkForcedEtaExpansion _ _ = return () - --- | Is this a hasNoBinding Id with a levity-polymorphic type? --- Returns the arguments that are levity polymorphic if they are bad; --- or an empty list otherwise --- See Note [Detecting forced eta expansion] -badUseOfLevPolyPrimop :: Id -> Type -> [Type] -badUseOfLevPolyPrimop id ty - | hasNoBinding id - = filter isTypeLevPoly arg_tys - | otherwise - = [] - where - (binders, _) = splitPiTys ty - arg_tys = mapMaybe binderRelevantType_maybe binders - -levPolyPrimopErr :: Id -> Type -> [Type] -> DsM () -levPolyPrimopErr primop ty bad_tys - = errDs $ vcat - [ hang (text "Cannot use function with levity-polymorphic arguments:") - 2 (ppr primop <+> dcolon <+> pprWithTYPE ty) - , hang (text "Levity-polymorphic arguments:") - 2 $ vcat $ map - (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) - bad_tys - ] diff --git a/deSugar/DsExpr.hs-boot b/deSugar/DsExpr.hs-boot deleted file mode 100644 --- a/deSugar/DsExpr.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module DsExpr where -import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) -import GHC.Hs.Extension ( GhcTc) - -dsExpr :: HsExpr GhcTc -> DsM CoreExpr -dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr diff --git a/deSugar/DsForeign.hs b/deSugar/DsForeign.hs deleted file mode 100644 --- a/deSugar/DsForeign.hs +++ /dev/null @@ -1,847 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - - -Desugaring foreign declarations (see also DsCCall). --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module DsForeign ( dsForeigns ) where - -#include "HsVersions.h" -import GhcPrelude - -import TcRnMonad -- temp - -import CoreSyn - -import DsCCall -import DsMonad - -import GHC.Hs -import DataCon -import CoreUnfold -import Id -import Literal -import Module -import Name -import Type -import RepType -import TyCon -import Coercion -import TcEnv -import TcType - -import CmmExpr -import CmmUtils -import HscTypes -import ForeignCall -import TysWiredIn -import TysPrim -import PrelNames -import BasicTypes -import SrcLoc -import Outputable -import FastString -import DynFlags -import GHC.Platform -import OrdList -import Pair -import Util -import Hooks -import Encoding - -import Data.Maybe -import Data.List - -{- -Desugaring of @foreign@ declarations is naturally split up into -parts, an @import@ and an @export@ part. A @foreign import@ -declaration -\begin{verbatim} - foreign import cc nm f :: prim_args -> IO prim_res -\end{verbatim} -is the same as -\begin{verbatim} - f :: prim_args -> IO prim_res - f a1 ... an = _ccall_ nm cc a1 ... an -\end{verbatim} -so we reuse the desugaring code in @DsCCall@ to deal with these. --} - -type Binding = (Id, CoreExpr) -- No rec/nonrec structure; - -- the occurrence analyser will sort it all out - -dsForeigns :: [LForeignDecl GhcTc] - -> DsM (ForeignStubs, OrdList Binding) -dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) - -dsForeigns' :: [LForeignDecl GhcTc] - -> DsM (ForeignStubs, OrdList Binding) -dsForeigns' [] - = return (NoStubs, nilOL) -dsForeigns' fos = do - mod <- getModule - fives <- mapM do_ldecl fos - let - (hs, cs, idss, bindss) = unzip4 fives - fe_ids = concat idss - fe_init_code = foreignExportsInitialiser mod fe_ids - -- - return (ForeignStubs - (vcat hs) - (vcat cs $$ fe_init_code), - foldr (appOL . toOL) nilOL bindss) - where - do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl) - - do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do - traceIf (text "fi start" <+> ppr id) - let id' = unLoc id - (bs, h, c) <- dsFImport id' co spec - traceIf (text "fi end" <+> ppr id) - return (h, c, [], bs) - - do_decl (ForeignExport { fd_name = (dL->L _ id) - , fd_e_ext = co - , fd_fe = CExport - (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do - (h, c, _, _) <- dsFExport id co ext_nm cconv False - return (h, c, [id], []) - do_decl (XForeignDecl nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection{Foreign import} -* * -************************************************************************ - -Desugaring foreign imports is just the matter of creating a binding -that on its RHS unboxes its arguments, performs the external call -(using the @CCallOp@ primop), before boxing the result up and returning it. - -However, we create a worker/wrapper pair, thus: - - foreign import f :: Int -> IO Int -==> - f x = IO ( \s -> case x of { I# x# -> - case fw s x# of { (# s1, y# #) -> - (# s1, I# y# #)}}) - - fw s x# = ccall f s x# - -The strictness/CPR analyser won't do this automatically because it doesn't look -inside returned tuples; but inlining this wrapper is a Really Good Idea -because it exposes the boxing to the call site. --} - -dsFImport :: Id - -> Coercion - -> ForeignImport - -> DsM ([Binding], SDoc, SDoc) -dsFImport id co (CImport cconv safety mHeader spec _) = - dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader - -dsCImport :: Id - -> Coercion - -> CImportSpec - -> CCallConv - -> Safety - -> Maybe Header - -> DsM ([Binding], SDoc, SDoc) -dsCImport id co (CLabel cid) cconv _ _ = do - dflags <- getDynFlags - let ty = pFst $ coercionKind co - fod = case tyConAppTyCon_maybe (dropForAlls ty) of - Just tycon - | tyConUnique tycon == funPtrTyConKey -> - IsFunction - _ -> IsData - (resTy, foRhs) <- resultWrapper ty - ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this - let - rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) - rhs' = Cast rhs co - stdcall_info = fun_type_arg_stdcall_info dflags cconv ty - in - return ([(id, rhs')], empty, empty) - -dsCImport id co (CFunction target) cconv@PrimCallConv safety _ - = dsPrimCall id co (CCall (mkCCallSpec target cconv safety - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps"))) -dsCImport id co (CFunction target) cconv safety mHeader - = dsFCall id co (CCall (mkCCallSpec target cconv safety - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps"))) mHeader -dsCImport id co CWrapper cconv _ _ - = dsFExportDynamic id co cconv - --- For stdcall labels, if the type was a FunPtr or newtype thereof, --- then we need to calculate the size of the arguments in order to add --- the @n suffix to the label. -fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int -fun_type_arg_stdcall_info dflags StdCallConv ty - | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, - tyConUnique tc == funPtrTyConKey - = let - (bndrs, _) = tcSplitPiTys arg_ty - fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs - in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) -fun_type_arg_stdcall_info _ _other_conv _ - = Nothing - -{- -************************************************************************ -* * -\subsection{Foreign calls} -* * -************************************************************************ --} - -dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header - -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsFCall fn_id co (CCall (CCallSpec target cconv safety _ _)) mDeclHeader = do - let - ty = pFst $ coercionKind co - (tv_bndrs, rho) = tcSplitForAllVarBndrs ty - (arg_tys, io_res_ty) = tcSplitFunTys rho - - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism - (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) - - let - work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars - - (ccall_result_ty, res_wrapper) <- boxResult io_res_ty - - ccall_uniq <- newUnique - work_uniq <- newUnique - - dflags <- getDynFlags - - let - fcall = CCall (mkCCallSpec target cconv safety io_res_ty arg_tys) - - (fcall', cDoc) <- case fcall of - CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) - CApiConv safety _ _) -> - do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) - let fcall' = CCall (mkCCallSpec - (StaticTarget NoSourceText - wrapperName mUnitId - True) - CApiConv safety io_res_ty arg_tys) - c = includes - $$ fun_proto <+> braces (cRet <> semi) - includes = vcat [ text "#include \"" <> ftext h - <> text "\"" - | Header _ h <- nub headers ] - fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes - cRet - | isVoidRes = cCall - | otherwise = text "return" <+> cCall - cCall = if isFun - then ppr cName <> parens argVals - else if null arg_tys - then ppr cName - else panic "dsFCall: Unexpected arguments to FFI value import" - raw_res_ty = case tcSplitIOType_maybe io_res_ty of - Just (_ioTyCon, res_ty) -> res_ty - Nothing -> io_res_ty - isVoidRes = raw_res_ty `eqType` unitTy - (mHeader, cResType) - | isVoidRes = (Nothing, text "void") - | otherwise = toCType raw_res_ty - pprCconv = ccallConvAttribute CApiConv - mHeadersArgTypeList - = [ (header, cType <+> char 'a' <> int n) - | (t, n) <- zip arg_tys [1..] - , let (header, cType) = toCType t ] - (mHeaders, argTypeList) = unzip mHeadersArgTypeList - argTypes = if null argTypeList - then text "void" - else hsep $ punctuate comma argTypeList - mHeaders' = mDeclHeader : mHeader : mHeaders - headers = catMaybes mHeaders' - argVals = hsep $ punctuate comma - [ char 'a' <> int n - | (_, n) <- zip arg_tys [1..] ] - return (fcall', c) - _ -> - return (fcall, empty) - let - -- Build the worker - worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty) - tvs = map binderVar tv_bndrs - the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty - work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) - work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty - - -- Build the wrapper - work_app = mkApps (mkVarApps (Var work_id) tvs) val_args - wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers - wrap_rhs = mkLams (tvs ++ args) wrapper_body - wrap_rhs' = Cast wrap_rhs co - fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity - (length args) wrap_rhs' - - return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) - -{- -************************************************************************ -* * -\subsection{Primitive calls} -* * -************************************************************************ - -This is for `@foreign import prim@' declarations. - -Currently, at the core level we pretend that these primitive calls are -foreign calls. It may make more sense in future to have them as a distinct -kind of Id, or perhaps to bundle them with PrimOps since semantically and -for calling convention they are really prim ops. --} - -dsPrimCall :: Id -> Coercion -> ForeignCall - -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsPrimCall fn_id co (CCall (CCallSpec target cconv safety _ _)) = do - let - ty = pFst $ coercionKind co - (tvs, fun_ty) = tcSplitForAllTys ty - (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - - args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism - - ccall_uniq <- newUnique - dflags <- getDynFlags - let - fcall = CCall (mkCCallSpec target cconv safety io_res_ty arg_tys) - call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty - rhs = mkLams tvs (mkLams args call_app) - rhs' = Cast rhs co - return ([(fn_id, rhs')], empty, empty) - -{- -************************************************************************ -* * -\subsection{Foreign export} -* * -************************************************************************ - -The function that does most of the work for `@foreign export@' declarations. -(see below for the boilerplate code a `@foreign export@' declaration expands - into.) - -For each `@foreign export foo@' in a module M we generate: -\begin{itemize} -\item a C function `@foo@', which calls -\item a Haskell stub `@M.\$ffoo@', which calls -\end{itemize} -the user-written Haskell function `@M.foo@'. --} - -dsFExport :: Id -- Either the exported Id, - -- or the foreign-export-dynamic constructor - -> Coercion -- Coercion between the Haskell type callable - -- from C, and its representation type - -> CLabelString -- The name to export to C land - -> CCallConv - -> Bool -- True => foreign export dynamic - -- so invoke IO action that's hanging off - -- the first argument's stable pointer - -> DsM ( SDoc -- contents of Module_stub.h - , SDoc -- contents of Module_stub.c - , String -- string describing type to pass to createAdj. - , Int -- size of args to stub function - ) - -dsFExport fn_id co ext_name cconv isDyn = do - let - ty = pSnd $ coercionKind co - (bndrs, orig_res_ty) = tcSplitPiTys ty - fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs - -- We must use tcSplits here, because we want to see - -- the (IO t) in the corner of the type! - fe_arg_tys | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' - - -- Look at the result type of the exported function, orig_res_ty - -- If it's IO t, return (t, True) - -- If it's plain t, return (t, False) - (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of - -- The function already returns IO t - Just (_ioTyCon, res_ty) -> (res_ty, True) - -- The function returns t - Nothing -> (orig_res_ty, False) - - dflags <- getDynFlags - return $ - mkFExportCBits dflags ext_name - (if isDyn then Nothing else Just fn_id) - fe_arg_tys res_ty is_IO_res_ty cconv - -{- -@foreign import "wrapper"@ (previously "foreign export dynamic") lets -you dress up Haskell IO actions of some fixed type behind an -externally callable interface (i.e., as a C function pointer). Useful -for callbacks and stuff. - -\begin{verbatim} -type Fun = Bool -> Int -> IO Int -foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) - --- Haskell-visible constructor, which is generated from the above: --- SUP: No check for NULL from createAdjustor anymore??? - -f :: Fun -> IO (FunPtr Fun) -f cback = - bindIO (newStablePtr cback) - (\StablePtr sp# -> IO (\s1# -> - case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of - (# s2#, a# #) -> (# s2#, A# a# #))) - -foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) - --- and the helper in C: (approximately; see `mkFExportCBits` below) - -f_helper(StablePtr s, HsBool b, HsInt i) -{ - Capability *cap; - cap = rts_lock(); - rts_evalIO(&cap, - rts_apply(rts_apply(deRefStablePtr(s), - rts_mkBool(b)), rts_mkInt(i))); - rts_unlock(cap); -} -\end{verbatim} --} - -dsFExportDynamic :: Id - -> Coercion - -> CCallConv - -> DsM ([Binding], SDoc, SDoc) -dsFExportDynamic id co0 cconv = do - mod <- getModule - dflags <- getDynFlags - let fe_nm = mkFastString $ zEncodeString - (moduleStableString mod ++ "$" ++ toCName dflags id) - -- Construct the label based on the passed id, don't use names - -- depending on Unique. See #13807 and Note [Unique Determinism]. - cback <- newSysLocalDs arg_ty - newStablePtrId <- dsLookupGlobalId newStablePtrName - stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName - let - stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] - export_ty = mkVisFunTy stable_ptr_ty arg_ty - bindIOId <- dsLookupGlobalId bindIOName - stbl_value <- newSysLocalDs stable_ptr_ty - (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True - let - {- - The arguments to the external function which will - create a little bit of (template) code on the fly - for allowing the (stable pointed) Haskell closure - to be entered using an external calling convention - (stdcall, ccall). - -} - adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) - , Var stbl_value - , Lit (LitLabel fe_nm mb_sz_args IsFunction) - , Lit (mkLitString typestring) - ] - -- name of external entry point providing these services. - -- (probably in the RTS.) - adjustor = fsLit "createAdjustor" - - -- Determine the number of bytes of arguments to the stub function, - -- so that we can attach the '@N' suffix to its label if it is a - -- stdcall on Windows. - mb_sz_args = case cconv of - StdCallConv -> Just args_size - _ -> Nothing - - ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) - -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback - - let io_app = mkLams tvs $ - Lam cback $ - mkApps (Var bindIOId) - [ Type stable_ptr_ty - , Type res_ty - , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] - , Lam stbl_value ccall_adj - ] - - fed = (id `setInlineActivation` NeverActive, Cast io_app co0) - -- Never inline the f.e.d. function, because the litlit - -- might not be in scope in other modules. - - return ([fed], h_code, c_code) - - where - ty = pFst (coercionKind co0) - (tvs,sans_foralls) = tcSplitForAllTys ty - ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls - Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty - -- Must have an IO type; hence Just - - -toCName :: DynFlags -> Id -> String -toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) - -{- -* - -\subsection{Generating @foreign export@ stubs} - -* - -For each @foreign export@ function, a C stub function is generated. -The C stub constructs the application of the exported Haskell function -using the hugs/ghc rts invocation API. --} - -mkFExportCBits :: DynFlags - -> FastString - -> Maybe Id -- Just==static, Nothing==dynamic - -> [Type] - -> Type - -> Bool -- True <=> returns an IO type - -> CCallConv - -> (SDoc, - SDoc, - String, -- the argument reps - Int -- total size of arguments - ) -mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = (header_bits, c_bits, type_string, - sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args - -- NB. the calculation here isn't strictly speaking correct. - -- We have a primitive Haskell type (eg. Int#, Double#), and - -- we want to know the size, when passed on the C stack, of - -- the associated C type (eg. HsInt, HsDouble). We don't have - -- this information to hand, but we know what GHC's conventions - -- are for passing around the primitive Haskell types, so we - -- use that instead. I hope the two coincide --SDM - ) - where - -- list the arguments to the C function - arg_info :: [(SDoc, -- arg name - SDoc, -- C type - Type, -- Haskell type - CmmType)] -- the CmmType - arg_info = [ let stg_type = showStgType ty in - (arg_cname n stg_type, - stg_type, - ty, - typeCmmType dflags (getPrimTyOf ty)) - | (ty,n) <- zip arg_htys [1::Int ..] ] - - arg_cname n stg_ty - | libffi = char '*' <> parens (stg_ty <> char '*') <> - text "args" <> brackets (int (n-1)) - | otherwise = text ('a':show n) - - -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled - libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target - - type_string - -- libffi needs to know the result type too: - | libffi = primTyDescChar dflags res_hty : arg_type_string - | otherwise = arg_type_string - - arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] - -- just the real args - - -- add some auxiliary args; the stable ptr in the wrapper case, and - -- a slot for the dummy return address in the wrapper + ccall case - aug_arg_info - | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info - | otherwise = arg_info - - stable_ptr_arg = - (text "the_stableptr", text "StgStablePtr", undefined, - typeCmmType dflags (mkStablePtrPrimTy alphaTy)) - - -- stuff to do with the return type of the C function - res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes - - cResType | res_hty_is_unit = text "void" - | otherwise = showStgType res_hty - - -- when the return type is integral and word-sized or smaller, it - -- must be assigned as type ffi_arg (#3516). To see what type - -- libffi is expecting here, take a look in its own testsuite, e.g. - -- libffi/testsuite/libffi.call/cls_align_ulonglong.c - ffi_cResType - | is_ffi_arg_type = text "ffi_arg" - | otherwise = cResType - where - res_ty_key = getUnique (getName (typeTyCon res_hty)) - is_ffi_arg_type = res_ty_key `notElem` - [floatTyConKey, doubleTyConKey, - int64TyConKey, word64TyConKey] - - -- Now we can cook up the prototype for the exported function. - pprCconv = ccallConvAttribute cc - - header_bits = text "extern" <+> fun_proto <> semi - - fun_args - | null aug_arg_info = text "void" - | otherwise = hsep $ punctuate comma - $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info - - fun_proto - | libffi - = text "void" <+> ftext c_nm <> - parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") - | otherwise - = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args - - -- the target which will form the root of what we ask rts_evalIO to run - the_cfun - = case maybe_target of - Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" - Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" - - cap = text "cap" <> comma - - -- the expression we give to rts_evalIO - expr_to_run - = foldl' appArg the_cfun arg_info -- NOT aug_arg_info - where - appArg acc (arg_cname, _, arg_hty, _) - = text "rts_apply" - <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) - - -- various other bits for inside the fn - declareResult = text "HaskellObj ret;" - declareCResult | res_hty_is_unit = empty - | otherwise = cResType <+> text "cret;" - - assignCResult | res_hty_is_unit = empty - | otherwise = - text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi - - -- an extern decl for the fn being called - extern_decl - = case maybe_target of - Nothing -> empty - Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi - - - -- finally, the whole darn thing - c_bits = - space $$ - extern_decl $$ - fun_proto $$ - vcat - [ lbrace - , text "Capability *cap;" - , declareResult - , declareCResult - , text "cap = rts_lock();" - -- create the application + perform it. - , text "rts_evalIO" <> parens ( - char '&' <> cap <> - text "rts_apply" <> parens ( - cap <> - text "(HaskellObj)" - <> ptext (if is_IO_res_ty - then (sLit "runIO_closure") - else (sLit "runNonIO_closure")) - <> comma - <> expr_to_run - ) <+> comma - <> text "&ret" - ) <> semi - , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) - <> comma <> text "cap") <> semi - , assignCResult - , text "rts_unlock(cap);" - , ppUnless res_hty_is_unit $ - if libffi - then char '*' <> parens (ffi_cResType <> char '*') <> - text "resp = cret;" - else text "return cret;" - , rbrace - ] - - -foreignExportsInitialiser :: Module -> [Id] -> SDoc -foreignExportsInitialiser mod hs_fns = - -- Initialise foreign exports by registering a stable pointer from an - -- __attribute__((constructor)) function. - -- The alternative is to do this from stginit functions generated in - -- codeGen/CodeGen.hs; however, stginit functions have a negative impact - -- on binary sizes and link times because the static linker will think that - -- all modules that are imported directly or indirectly are actually used by - -- the program. - -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) - -- - -- See Note [Tracking foreign exports] in rts/ForeignExports.c - vcat - [ text "static struct ForeignExportsList" <+> list_symbol <+> equals - <+> braces ( - text ".exports = " <+> export_list <> comma <+> - text ".n_entries = " <+> ppr (length hs_fns)) - <> semi - , text "static void " <> ctor_symbol <> text "(void)" - <+> text " __attribute__((constructor));" - , text "static void " <> ctor_symbol <> text "()" - , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi) - ] - where - mod_str = pprModuleName (moduleName mod) - ctor_symbol = text "stginit_export_" <> mod_str - list_symbol = text "stg_exports_" <> mod_str - export_list = braces $ pprWithCommas closure_ptr hs_fns - - closure_ptr :: Id -> SDoc - closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" - - -mkHObj :: Type -> SDoc -mkHObj t = text "rts_mk" <> text (showFFIType t) - -unpackHObj :: Type -> SDoc -unpackHObj t = text "rts_get" <> text (showFFIType t) - -showStgType :: Type -> SDoc -showStgType t = text "Hs" <> text (showFFIType t) - -showFFIType :: Type -> String -showFFIType t = getOccString (getName (typeTyCon t)) - -toCType :: Type -> (Maybe Header, SDoc) -toCType = f False - where f voidOK t - -- First, if we have (Ptr t) of (FunPtr t), then we need to - -- convert t to a C type and put a * after it. If we don't - -- know a type for t, then "void" is fine, though. - | Just (ptr, [t']) <- splitTyConApp_maybe t - , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] - = case f True t' of - (mh, cType') -> - (mh, cType' <> char '*') - -- Otherwise, if we have a type constructor application, then - -- see if there is a C type associated with that constructor. - -- Note that we aren't looking through type synonyms or - -- anything, as it may be the synonym that is annotated. - | Just tycon <- tyConAppTyConPicky_maybe t - , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon - = (mHeader, ftext cType) - -- If we don't know a C type for this type, then try looking - -- through one layer of type synonym etc. - | Just t' <- coreView t - = f voidOK t' - -- This may be an 'UnliftedFFITypes'-style ByteArray# argument - -- (which is marshalled like a Ptr) - | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "const void*") - | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "void*") - -- Otherwise we don't know the C type. If we are allowing - -- void then return that; otherwise something has gone wrong. - | voidOK = (Nothing, text "void") - | otherwise - = pprPanic "toCType" (ppr t) - -typeTyCon :: Type -> TyCon -typeTyCon ty - | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) - = tc - | otherwise - = pprPanic "DsForeign.typeTyCon" (ppr ty) - -insertRetAddr :: DynFlags -> CCallConv - -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] -insertRetAddr dflags CCallConv args - = case platformArch platform of - ArchX86_64 - | platformOS platform == OSMinGW32 -> - -- On other Windows x86_64 we insert the return address - -- after the 4th argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 4 args = ret_addr_arg dflags : args - go n (arg:args) = arg : go (n+1) args - go _ [] = [] - in go 0 args - | otherwise -> - -- On other x86_64 platforms we insert the return address - -- after the 6th integer argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg dflags : args - go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args - go _ [] = [] - in go 0 args - _ -> - ret_addr_arg dflags : args - where platform = targetPlatform dflags -insertRetAddr _ _ args = args - -ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) -ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, - typeCmmType dflags addrPrimTy) - --- This function returns the primitive type associated with the boxed --- type argument to a foreign export (eg. Int ==> Int#). -getPrimTyOf :: Type -> UnaryType -getPrimTyOf ty - | isBoolTy rep_ty = intPrimTy - -- Except for Bool, the types we are interested in have a single constructor - -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). - | otherwise = - case splitDataProductType_maybe rep_ty of - Just (_, _, data_con, [prim_ty]) -> - ASSERT(dataConSourceArity data_con == 1) - ASSERT2(isUnliftedType prim_ty, ppr prim_ty) - prim_ty - _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) - where - rep_ty = unwrapType ty - --- represent a primitive type as a Char, for building a string that --- described the foreign function type. The types are size-dependent, --- e.g. 'W' is a signed 32-bit integer. -primTyDescChar :: DynFlags -> Type -> Char -primTyDescChar dflags ty - | ty `eqType` unitTy = 'v' - | otherwise - = case typePrimRep1 (getPrimTyOf ty) of - IntRep -> signed_word - WordRep -> unsigned_word - Int8Rep -> 'B' - Word8Rep -> 'b' - Int16Rep -> 'S' - Word16Rep -> 's' - Int32Rep -> 'W' - Word32Rep -> 'w' - Int64Rep -> 'L' - Word64Rep -> 'l' - AddrRep -> 'p' - FloatRep -> 'f' - DoubleRep -> 'd' - _ -> pprPanic "primTyDescChar" (ppr ty) - where - (signed_word, unsigned_word) - | wORD_SIZE dflags == 4 = ('W','w') - | wORD_SIZE dflags == 8 = ('L','l') - | otherwise = panic "primTyDescChar" diff --git a/deSugar/DsGRHSs.hs b/deSugar/DsGRHSs.hs deleted file mode 100644 --- a/deSugar/DsGRHSs.hs +++ /dev/null @@ -1,157 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Matching guarded right-hand-sides (GRHSs) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} - -module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) -import {-# SOURCE #-} Match ( matchSinglePatVar ) - -import GHC.Hs -import MkCore -import CoreSyn -import CoreUtils (bindNonRec) - -import BasicTypes (Origin(FromSource)) -import DynFlags -import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs) -import DsMonad -import DsUtils -import Type ( Type ) -import Name -import Util -import SrcLoc -import Outputable - -{- -@dsGuarded@ is used for pattern bindings. -It desugars: -\begin{verbatim} - | g1 -> e1 - ... - | gn -> en - where binds -\end{verbatim} -producing an expression with a runtime error in the corner if -necessary. The type argument gives the type of the @ei@. --} - -dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr -dsGuarded grhss rhs_ty = do - match_result <- dsGRHSs PatBindRhs grhss rhs_ty - error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty - extractMatchResult match_result error_expr - --- In contrast, @dsGRHSs@ produces a @MatchResult@. - -dsGRHSs :: HsMatchContext Name - -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs - -> Type -- Type of RHS - -> DsM MatchResult -dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty - = ASSERT( notNull grhss ) - do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss - ; let match_result1 = foldr1 combineMatchResults match_results - match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 - -- NB: nested dsLet inside matchResult - ; return match_result2 } -dsGRHSs _ (XGRHSs nec) _ = noExtCon nec - -dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) - -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs)) - = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty -dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec -dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884 - -{- -************************************************************************ -* * -* matchGuard : make a MatchResult from a guarded RHS * -* * -************************************************************************ --} - -matchGuards :: [GuardStmt GhcTc] -- Guard - -> HsStmtContext Name -- Context - -> LHsExpr GhcTc -- RHS - -> Type -- Type of RHS of guard - -> DsM MatchResult - --- See comments with HsExpr.Stmt re what a BodyStmt means --- Here we must be in a guard context (not do-expression, nor list-comp) - -matchGuards [] _ rhs _ - = do { core_rhs <- dsLExpr rhs - ; return (cantFailMatchResult core_rhs) } - - -- BodyStmts must be guards - -- Turn an "otherwise" guard is a no-op. This ensures that - -- you don't get a "non-exhaustive eqns" message when the guards - -- finish in "otherwise". - -- NB: The success of this clause depends on the typechecker not - -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors - -- If it does, you'll get bogus overlap warnings -matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty - | Just addTicks <- isTrueLHsExpr e = do - match_result <- matchGuards stmts ctx rhs rhs_ty - return (adjustMatchResultDs addTicks match_result) -matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - pred_expr <- dsLExpr expr - return (mkGuardedMatchResult pred_expr match_result) - -matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - return (adjustMatchResultDs (dsLocalBinds binds) match_result) - -- NB the dsLet occurs inside the match_result - -- Reason: dsLet takes the body expression as its argument - -- so we can't desugar the bindings without the - -- body expression in hand - -matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do - let upat = unLoc pat - dicts = collectEvVarsPat upat - match_var <- selectMatchVar upat - - dflags <- getDynFlags - match_result <- - -- See Note [Type and Term Equality Propagation] in Check - applyWhen (needToRunPmCheck dflags FromSource) - -- FromSource might not be accurate, but at worst - -- we do superfluous calls to the pattern match - -- oracle. - (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var]) - (matchGuards stmts ctx rhs rhs_ty) - core_rhs <- dsLExpr bind_rhs - match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty - match_result - pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result' - -matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" -matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" -matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" -matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" -matchGuards (ApplicativeStmt {} : _) _ _ _ = - panic "matchGuards ApplicativeLastStmt" -matchGuards (XStmtLR nec : _) _ _ _ = - noExtCon nec - -{- -Should {\em fail} if @e@ returns @D@ -\begin{verbatim} -f x | p <- e', let C y# = e, f y# = r1 - | otherwise = r2 -\end{verbatim} --} diff --git a/deSugar/DsListComp.hs b/deSugar/DsListComp.hs deleted file mode 100644 --- a/deSugar/DsListComp.hs +++ /dev/null @@ -1,693 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring list comprehensions, monad comprehensions and array comprehensions --} - -{-# LANGUAGE CPP, NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module DsListComp ( dsListComp, dsMonadComp ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) - -import GHC.Hs -import TcHsSyn -import CoreSyn -import MkCore - -import DsMonad -- the monadery used in the desugarer -import DsUtils - -import DynFlags -import CoreUtils -import Id -import Type -import TysWiredIn -import Match -import PrelNames -import SrcLoc -import Outputable -import TcType -import ListSetOps( getNth ) -import Util - -{- -List comprehensions may be desugared in one of two ways: ``ordinary'' -(as you would expect if you read SLPJ's book) and ``with foldr/build -turned on'' (if you read Gill {\em et al.}'s paper on the subject). - -There will be at least one ``qualifier'' in the input. --} - -dsListComp :: [ExprLStmt GhcTc] - -> Type -- Type of entire list - -> DsM CoreExpr -dsListComp lquals res_ty = do - dflags <- getDynFlags - let quals = map unLoc lquals - elt_ty = case tcTyConAppArgs res_ty of - [elt_ty] -> elt_ty - _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) - - if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags - -- Either rules are switched off, or we are ignoring what there are; - -- Either way foldr/build won't happen, so use the more efficient - -- Wadler-style desugaring - || isParallelComp quals - -- Foldr-style desugaring can't handle parallel list comprehensions - then deListComp quals (mkNilExpr elt_ty) - else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) - -- Foldr/build should be enabled, so desugar - -- into foldrs and builds - - where - -- We must test for ParStmt anywhere, not just at the head, because an extension - -- to list comprehensions would be to add brackets to specify the associativity - -- of qualifier lists. This is really easy to do by adding extra ParStmts into the - -- mix of possibly a single element in length, so we do this to leave the possibility open - isParallelComp = any isParallelStmt - - isParallelStmt (ParStmt {}) = True - isParallelStmt _ = False - - --- This function lets you desugar a inner list comprehension and a list of the binders --- of that comprehension that we need in the outer comprehension into such an expression --- and the type of the elements that it outputs (tuples of binders) -dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) -dsInnerListComp (ParStmtBlock _ stmts bndrs _) - = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs - list_ty = mkListTy bndrs_tuple_type - - -- really use original bndrs below! - ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty - - ; return (expr, bndrs_tuple_type) } -dsInnerListComp (XParStmtBlock nec) = noExtCon nec - --- This function factors out commonality between the desugaring strategies for GroupStmt. --- Given such a statement it gives you back an expression representing how to compute the transformed --- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc) -dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_using = using }) = do - let (from_bndrs, to_bndrs) = unzip binderMap - - let from_bndrs_tys = map idType from_bndrs - to_bndrs_tys = map idType to_bndrs - - to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys - - -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts - from_bndrs noSyntaxExpr) - - -- Work out what arguments should be supplied to that expression: i.e. is an extraction - -- function required? If so, create that desugared function and add to arguments - usingExpr' <- dsLExpr using - usingArgs' <- case by of - Nothing -> return [expr'] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam' <- matchTuple from_bndrs by_e' - ; return [lam', expr'] } - - -- Create an unzip function for the appropriate arity and element types and find "map" - unzip_stuff' <- mkUnzipBind form from_bndrs_tys - map_id <- dsLookupGlobalId mapName - - -- Generate the expressions to build the grouped list - let -- First we apply the grouping function to the inner list - inner_list_expr' = mkApps usingExpr' usingArgs' - -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists - -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and - -- the "b" to be a tuple of "to" lists! - -- Then finally we bind the unzip function around that expression - bound_unzipped_inner_list_expr' - = case unzip_stuff' of - Nothing -> inner_list_expr' - Just (unzip_fn', unzip_rhs') -> - Let (Rec [(unzip_fn', unzip_rhs')]) $ - mkApps (Var map_id) $ - [ Type (mkListTy from_tup_ty) - , Type to_bndrs_tup_ty - , Var unzip_fn' - , inner_list_expr' ] - - dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) - (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) - - -- Build a pattern that ensures the consumer binds into the NEW binders, - -- which hold lists rather than single values - let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! - return (bound_unzipped_inner_list_expr', pat) - -dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" - -{- -************************************************************************ -* * -\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions} -* * -************************************************************************ - -Just as in Phil's chapter~7 in SLPJ, using the rules for -optimally-compiled list comprehensions. This is what Kevin followed -as well, and I quite happily do the same. The TQ translation scheme -transforms a list of qualifiers (either boolean expressions or -generators) into a single expression which implements the list -comprehension. Because we are generating 2nd-order polymorphic -lambda-calculus, calls to NIL and CONS must be applied to a type -argument, as well as their usual value arguments. -\begin{verbatim} -TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> - -(Rule C) -TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> - -(Rule B) -TQ << [ e | b , qs ] ++ L >> = - if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> - -(Rule A') -TQ << [ e | p <- L1, qs ] ++ L2 >> = - letrec - h = \ u1 -> - case u1 of - [] -> TE << L2 >> - (u2 : u3) -> - (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) - [] (h u3) - in - h ( TE << L1 >> ) - -"h", "u1", "u2", and "u3" are new variables. -\end{verbatim} - -@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ -is the TE translation scheme. Note that we carry around the @L@ list -already desugared. @dsListComp@ does the top TE rule mentioned above. - -To the above, we add an additional rule to deal with parallel list -comprehensions. The translation goes roughly as follows: - [ e | p1 <- e11, let v1 = e12, p2 <- e13 - | q1 <- e21, let v2 = e22, q2 <- e23] - => - [ e | ((x1, .., xn), (y1, ..., ym)) <- - zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] - [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] -where (x1, .., xn) are the variables bound in p1, v1, p2 - (y1, .., ym) are the variables bound in q1, v2, q2 - -In the translation below, the ParStmt branch translates each parallel branch -into a sub-comprehension, and desugars each independently. The resulting lists -are fed to a zip function, we create a binding for all the variables bound in all -the comprehensions, and then we hand things off the desugarer for bindings. -The zip function is generated here a) because it's small, and b) because then we -don't have to deal with arbitrary limits on the number of zip functions in the -prelude, nor which library the zip function came from. -The introduced tuples are Boxed, but only because I couldn't get it to work -with the Unboxed variety. --} - -deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr - -deListComp [] _ = panic "deListComp" - -deListComp (LastStmt _ body _ _ : quals) list - = -- Figure 7.4, SLPJ, p 135, rule C above - ASSERT( null quals ) - do { core_body <- dsLExpr body - ; return (mkConsExpr (exprType core_body) core_body list) } - - -- Non-last: must be a guard -deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above - core_guard <- dsLExpr guard - core_rest <- deListComp quals list - return (mkIfThenElse core_guard core_rest list) - --- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt _ binds : quals) list = do - core_rest <- deListComp quals list - dsLocalBinds binds core_rest - -deListComp (stmt@(TransStmt {}) : quals) list = do - (inner_list_expr, pat) <- dsTransStmt stmt - deBindComp pat inner_list_expr quals list - -deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above - core_list1 <- dsLExprNoLP list1 - deBindComp pat core_list1 quals core_list2 - -deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list - = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs - ; let (exps, qual_tys) = unzip exps_and_qual_tys - - ; (zip_fn, zip_rhs) <- mkZipBind qual_tys - - -- Deal with [e | pat <- zip l1 .. ln] in example above - ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) - quals list } - where - bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] - - -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above - pat = mkBigLHsPatTupId pats - pats = map mkBigLHsVarPatTupId bndrs_s - -deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" - -deListComp (ApplicativeStmt {} : _) _ = - panic "deListComp ApplicativeStmt" - -deListComp (XStmtLR nec : _) _ = - noExtCon nec - -deBindComp :: OutPat GhcTc - -> CoreExpr - -> [ExprStmt GhcTc] - -> CoreExpr - -> DsM (Expr Id) -deBindComp pat core_list1 quals core_list2 = do - let u3_ty@u1_ty = exprType core_list1 -- two names, same thing - - -- u1_ty is a [alpha] type, and u2_ty = alpha - let u2_ty = hsLPatType pat - - let res_ty = exprType core_list2 - h_ty = u1_ty `mkVisFunTy` res_ty - - -- no levity polymorphism here, as list comprehensions don't work - -- with RebindableSyntax. NB: These are *not* monad comps. - [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] - - -- the "fail" value ... - let - core_fail = App (Var h) (Var u3) - letrec_body = App (Var h) core_list1 - - rest_expr <- deListComp quals core_fail - core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail - - let - rhs = Lam u1 $ - Case (Var u1) u1 res_ty - [(DataAlt nilDataCon, [], core_list2), - (DataAlt consDataCon, [u2, u3], core_match)] - -- Increasing order of tag - - return (Let (Rec [(h, rhs)]) letrec_body) - -{- -************************************************************************ -* * -\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} -* * -************************************************************************ - -@dfListComp@ are the rules used with foldr/build turned on: - -\begin{verbatim} -TE[ e | ] c n = c e n -TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n -TE[ e | p <- l , q ] c n = let - f = \ x b -> case x of - p -> TE[ e | q ] c b - _ -> b - in - foldr f n l -\end{verbatim} --} - -dfListComp :: Id -> Id -- 'c' and 'n' - -> [ExprStmt GhcTc] -- the rest of the qual's - -> DsM CoreExpr - -dfListComp _ _ [] = panic "dfListComp" - -dfListComp c_id n_id (LastStmt _ body _ _ : quals) - = ASSERT( null quals ) - do { core_body <- dsLExprNoLP body - ; return (mkApps (Var c_id) [core_body, Var n_id]) } - - -- Non-last: must be a guard -dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do - core_guard <- dsLExpr guard - core_rest <- dfListComp c_id n_id quals - return (mkIfThenElse core_guard core_rest (Var n_id)) - -dfListComp c_id n_id (LetStmt _ binds : quals) = do - -- new in 1.3, local bindings - core_rest <- dfListComp c_id n_id quals - dsLocalBinds binds core_rest - -dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do - (inner_list_expr, pat) <- dsTransStmt stmt - -- Anyway, we bind the newly grouped list via the generic binding function - dfBindComp c_id n_id (pat, inner_list_expr) quals - -dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do - -- evaluate the two lists - core_list1 <- dsLExpr list1 - - -- Do the rest of the work in the generic binding builder - dfBindComp c_id n_id (pat, core_list1) quals - -dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" -dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" -dfListComp _ _ (ApplicativeStmt {} : _) = - panic "dfListComp ApplicativeStmt" -dfListComp _ _ (XStmtLR nec : _) = - noExtCon nec - -dfBindComp :: Id -> Id -- 'c' and 'n' - -> (LPat GhcTc, CoreExpr) - -> [ExprStmt GhcTc] -- the rest of the qual's - -> DsM CoreExpr -dfBindComp c_id n_id (pat, core_list1) quals = do - -- find the required type - let x_ty = hsLPatType pat - let b_ty = idType n_id - - -- create some new local id's - b <- newSysLocalDs b_ty - x <- newSysLocalDs x_ty - - -- build rest of the comprehesion - core_rest <- dfListComp c_id b quals - - -- build the pattern match - core_expr <- matchSimply (Var x) (StmtCtxt ListComp) - pat core_rest (Var b) - - -- now build the outermost foldr, and return - mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 - -{- -************************************************************************ -* * -\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} -* * -************************************************************************ --} - -mkZipBind :: [Type] -> DsM (Id, CoreExpr) --- mkZipBind [t1, t2] --- = (zip, \as1:[t1] as2:[t2] --- -> case as1 of --- [] -> [] --- (a1:as'1) -> case as2 of --- [] -> [] --- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] - -mkZipBind elt_tys = do - ass <- mapM newSysLocalDs elt_list_tys - as' <- mapM newSysLocalDs elt_tys - as's <- mapM newSysLocalDs elt_list_tys - - zip_fn <- newSysLocalDs zip_fn_ty - - let inner_rhs = mkConsExpr elt_tuple_ty - (mkBigCoreVarTup as') - (mkVarApps (Var zip_fn) as's) - zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) - - return (zip_fn, mkLams ass zip_body) - where - elt_list_tys = map mkListTy elt_tys - elt_tuple_ty = mkBigCoreTupTy elt_tys - elt_tuple_list_ty = mkListTy elt_tuple_ty - - zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty - - mk_case (as, a', as') rest - = Case (Var as) as elt_tuple_list_ty - [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), - (DataAlt consDataCon, [a', as'], rest)] - -- Increasing order of tag - - -mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) --- mkUnzipBind [t1, t2] --- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) --- -> case ax of --- (x1, x2) -> case axs of --- (xs1, xs2) -> (x1 : xs1, x2 : xs2)) --- ([], []) --- ys) --- --- We use foldr here in all cases, even if rules are turned off, because we may as well! -mkUnzipBind ThenForm _ - = return Nothing -- No unzipping for ThenForm -mkUnzipBind _ elt_tys - = do { ax <- newSysLocalDs elt_tuple_ty - ; axs <- newSysLocalDs elt_list_tuple_ty - ; ys <- newSysLocalDs elt_tuple_list_ty - ; xs <- mapM newSysLocalDs elt_tys - ; xss <- mapM newSysLocalDs elt_list_tys - - ; unzip_fn <- newSysLocalDs unzip_fn_ty - - ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] - - ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) - concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) - tupled_concat_expression = mkBigCoreTup concat_expressions - - folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) - folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case - - ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) - ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } - where - elt_tuple_ty = mkBigCoreTupTy elt_tys - elt_tuple_list_ty = mkListTy elt_tuple_ty - elt_list_tys = map mkListTy elt_tys - elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys - - unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty - - mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail - --- Translation for monad comprehensions - --- Entry point for monad comprehension desugaring -dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsMonadComp stmts = dsMcStmts stmts - -dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsMcStmts [] = panic "dsMcStmts" -dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) - ---------------- -dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr - -dsMcStmt (LastStmt _ body _ ret_op) stmts - = ASSERT( null stmts ) - do { body' <- dsLExpr body - ; dsSyntaxExpr ret_op [body'] } - --- [ .. | let binds, stmts ] -dsMcStmt (LetStmt _ binds) stmts - = do { rest <- dsMcStmts stmts - ; dsLocalBinds binds rest } - --- [ .. | a <- m, stmts ] -dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts - = do { rhs' <- dsLExpr rhs - ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } - --- Apply `guard` to the `exp` expression --- --- [ .. | exp, stmts ] --- -dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts - = do { exp' <- dsLExpr exp - ; rest <- dsMcStmts stmts - ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] - ; dsSyntaxExpr then_exp [guard_exp', rest] } - --- Group statements desugar like this: --- --- [| (q, then group by e using f); rest |] --- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> --- case unzip n_tup of qv' -> [| rest |] --- --- where variables (v1:t1, ..., vk:tk) are bound by q --- qv = (v1, ..., vk) --- qt = (t1, ..., tk) --- (>>=) :: m2 a -> (a -> m3 b) -> m3 b --- f :: forall a. (a -> t) -> m1 a -> m2 (n a) --- n_tup :: n qt --- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) - -dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs - , trS_by = by, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_ext = n_tup_ty' -- n (a,b,c) - , trS_fmap = fmap_op, trS_form = form }) stmts_rest - = do { let (from_bndrs, to_bndrs) = unzip bndrs - - ; let from_bndr_tys = map idType from_bndrs -- Types ty - - - -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - ; expr' <- dsInnerMonadComp stmts from_bndrs return_op - - -- Work out what arguments should be supplied to that expression: i.e. is an extraction - -- function required? If so, create that desugared function and add to arguments - ; usingExpr' <- dsLExpr using - ; usingArgs' <- case by of - Nothing -> return [expr'] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam' <- matchTuple from_bndrs by_e' - ; return [lam', expr'] } - - -- Generate the expressions to build the grouped list - -- Build a pattern that ensures the consumer binds into the NEW binders, - -- which hold monads rather than single values - ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs - - ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty' - ; tup_n_var' <- newSysLocalDs tup_n_ty' - ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys - ; us <- newUniqueSupply - ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' - - ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } - --- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel --- statements, for example: --- --- [ body | qs1 | qs2 | qs3 ] --- -> [ body | (bndrs1, (bndrs2, bndrs3)) --- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] --- --- where `mzip` has type --- mzip :: forall a b. m a -> m b -> m (a,b) --- NB: we need a polymorphic mzip because we call it several times - -dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest - = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) - ; mzip_op' <- dsExpr mzip_op - - ; let -- The pattern variables - pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] - -- Pattern with tuples of variables - -- [v1,v2,v3] => (v1, (v2, v3)) - pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats - (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> - (mkApps mzip_op' [Type t1, Type t2, e1, e2], - mkBoxedTupleTy [t1,t2])) - exps_w_tys - - ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } - where - ds_inner (ParStmtBlock _ stmts bndrs return_op) - = do { exp <- dsInnerMonadComp stmts bndrs return_op - ; return (exp, mkBigCoreVarTupTy bndrs) } - ds_inner (XParStmtBlock nec) = noExtCon nec - -dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) - - -matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr --- (matchTuple [a,b,c] body) --- returns the Core term --- \x. case x of (a,b,c) -> body -matchTuple ids body - = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } - --- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a --- desugared `CoreExpr` -dsMcBindStmt :: LPat GhcTc - -> CoreExpr -- ^ the desugared rhs of the bind statement - -> SyntaxExpr GhcTc - -> SyntaxExpr GhcTc - -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T - -> [ExprLStmt GhcTc] - -> DsM CoreExpr -dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts - = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - - where - -- In a monad comprehension expression, pattern-match failure just calls - -- the monadic `fail` rather than throwing an exception - handle_failure pat match fail_op - | matchCanFail match - = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] - ; extractMatchResult match fail_expr } - | otherwise - = extractMatchResult match (error "It can't fail") - - mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String - mk_fail_msg dflags pat - = "Pattern match failure in monad comprehension at " ++ - showPpr dflags (getLoc pat) - --- Desugar nested monad comprehensions, for example in `then..` constructs --- dsInnerMonadComp quals [a,b,c] ret_op --- returns the desugaring of --- [ (a,b,c) | quals ] - -dsInnerMonadComp :: [ExprLStmt GhcTc] - -> [Id] -- Return a tuple of these variables - -> SyntaxExpr GhcTc -- The monomorphic "return" operator - -> DsM CoreExpr -dsInnerMonadComp stmts bndrs ret_op - = dsMcStmts (stmts ++ - [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)]) - - --- The `unzip` function for `GroupStmt` in a monad comprehensions --- --- unzip :: m (a,b,..) -> (m a,m b,..) --- unzip m_tuple = ( liftM selN1 m_tuple --- , liftM selN2 m_tuple --- , .. ) --- --- mkMcUnzipM fmap ys [t1, t2] --- = ( fmap (selN1 :: (t1, t2) -> t1) ys --- , fmap (selN2 :: (t1, t2) -> t2) ys ) - -mkMcUnzipM :: TransForm - -> HsExpr GhcTcId -- fmap - -> Id -- Of type n (a,b,c) - -> [Type] -- [a,b,c] (not levity-polymorphic) - -> DsM CoreExpr -- Of type (n a, n b, n c) -mkMcUnzipM ThenForm _ ys _ - = return (Var ys) -- No unzipping to do - -mkMcUnzipM _ fmap_op ys elt_tys - = do { fmap_op' <- dsExpr fmap_op - ; xs <- mapM newSysLocalDs elt_tys - ; let tup_ty = mkBigCoreTupTy elt_tys - ; tup_xs <- newSysLocalDs tup_ty - - ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b - [ Type tup_ty, Type (getNth elt_tys i) - , mk_sel i, Var ys] - - mk_sel n = Lam tup_xs $ - mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) - - ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/deSugar/DsMeta.hs b/deSugar/DsMeta.hs deleted file mode 100644 --- a/deSugar/DsMeta.hs +++ /dev/null @@ -1,2763 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2006 --- --- The purpose of this module is to transform an HsExpr into a CoreExpr which --- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the --- input HsExpr. We do this in the DsM monad, which supplies access to --- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. --- --- It also defines a bunch of knownKeyNames, in the same way as is done --- in prelude/PrelNames. It's much more convenient to do it here, because --- otherwise we have to recompile PrelNames whenever we add a Name, which is --- a Royal Pain (triggers other recompilation). ------------------------------------------------------------------------------ - -module DsMeta( dsBracket ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DsExpr ( dsExpr ) - -import MatchLit -import DsMonad - -import qualified Language.Haskell.TH as TH - -import GHC.Hs -import PrelNames --- To avoid clashes with DsMeta.varName we must make a local alias for --- OccName.varName we do this by removing varName from the import of --- OccName above, making a qualified instance of OccName and using --- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) - -import Module -import Id -import Name hiding( isVarOcc, isTcOcc, varName, tcName ) -import THNames -import NameEnv -import TcType -import TyCon -import TysWiredIn -import CoreSyn -import MkCore -import CoreUtils -import SrcLoc -import Unique -import BasicTypes -import Outputable -import Bag -import DynFlags -import FastString -import ForeignCall -import Util -import Maybes -import MonadUtils - -import Data.ByteString ( unpack ) -import Control.Monad -import Data.List - ------------------------------------------------------------------------------ -dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr --- Returns a CoreExpr of type TH.ExpQ --- The quoted thing is parameterised over Name, even though it has --- been type checked. We don't want all those type decorations! - -dsBracket brack splices - = dsExtendMetaEnv new_bit (do_brack brack) - where - new_bit = mkNameEnv [(n, DsSplice (unLoc e)) - | PendingTcSplice n e <- splices] - - do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 } - do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } - do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" - do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (XBracket nec) = noExtCon nec - -{- -------------- Examples -------------------- - - [| \x -> x |] -====> - gensym (unpackString "x"#) `bindQ` \ x1::String -> - lam (pvar x1) (var x1) - - - [| \x -> $(f [| x |]) |] -====> - gensym (unpackString "x"#) `bindQ` \ x1::String -> - lam (pvar x1) (f (var x1)) --} - - -------------------------------------------------------- --- Declarations -------------------------------------------------------- - -repTopP :: LPat GhcRn -> DsM (Core TH.PatQ) -repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) - ; pat' <- addBinds ss (repLP pat) - ; wrapGenSyms ss pat' } - -repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec])) -repTopDs group@(HsGroup { hs_valds = valds - , hs_splcds = splcds - , hs_tyclds = tyclds - , hs_derivds = derivds - , hs_fixds = fixds - , hs_defds = defds - , hs_fords = fords - , hs_warnds = warnds - , hs_annds = annds - , hs_ruleds = ruleds - , hs_docs = docs }) - = do { let { bndrs = hsScopedTvBinders valds - ++ hsGroupBinders group - ++ hsPatSynSelectors valds - ; instds = tyclds >>= group_instds } ; - ss <- mkGenSyms bndrs ; - - -- Bind all the names mainly to avoid repeated use of explicit strings. - -- Thus we get - -- do { t :: String <- genSym "T" ; - -- return (Data t [] ...more t's... } - -- The other important reason is that the output must mention - -- only "T", not "Foo:T" where Foo is the current module - - decls <- addBinds ss ( - do { val_ds <- rep_val_binds valds - ; _ <- mapM no_splice splcds - ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) - ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) - ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds) - ; inst_ds <- mapM repInstD instds - ; deriv_ds <- mapM repStandaloneDerivD derivds - ; fix_ds <- mapM repFixD fixds - ; _ <- mapM no_default_decl defds - ; for_ds <- mapM repForD fords - ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) - warnds) - ; ann_ds <- mapM repAnnD annds - ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) - ruleds) - ; _ <- mapM no_doc docs - - -- more needed - ; return (de_loc $ sort_by_loc $ - val_ds ++ catMaybes tycl_ds ++ role_ds - ++ kisig_ds - ++ (concat fix_ds) - ++ inst_ds ++ rule_ds ++ for_ds - ++ ann_ds ++ deriv_ds) }) ; - - decl_ty <- lookupType decQTyConName ; - let { core_list = coreList' decl_ty decls } ; - - dec_ty <- lookupType decTyConName ; - q_decs <- repSequenceQ dec_ty core_list ; - - wrapGenSyms ss q_decs - } - where - no_splice (dL->L loc _) - = notHandledL loc "Splices within declaration brackets" empty - no_default_decl (dL->L loc decl) - = notHandledL loc "Default declarations" (ppr decl) - no_warn (dL->L loc (Warning _ thing _)) - = notHandledL loc "WARNING and DEPRECATION pragmas" $ - text "Pragma for declaration of" <+> ppr thing - no_warn _ = panic "repTopDs" - no_doc (dL->L loc _) - = notHandledL loc "Haddock documentation" empty -repTopDs (XHsGroup nec) = noExtCon nec - -hsScopedTvBinders :: HsValBinds GhcRn -> [Name] --- See Note [Scoped type variables in bindings] -hsScopedTvBinders binds - = concatMap get_scoped_tvs sigs - where - sigs = case binds of - ValBinds _ _ sigs -> sigs - XValBindsLR (NValBinds _ sigs) -> sigs - -get_scoped_tvs :: LSig GhcRn -> [Name] -get_scoped_tvs (dL->L _ signature) - | TypeSig _ _ sig <- signature - = get_scoped_tvs_from_sig (hswc_body sig) - | ClassOpSig _ _ _ sig <- signature - = get_scoped_tvs_from_sig sig - | PatSynSig _ _ sig <- signature - = get_scoped_tvs_from_sig sig - | otherwise - = [] - where - get_scoped_tvs_from_sig sig - -- Both implicit and explicit quantified variables - -- We need the implicit ones for f :: forall (a::k). blah - -- here 'k' scopes too - | HsIB { hsib_ext = implicit_vars - , hsib_body = hs_ty } <- sig - , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty - = implicit_vars ++ hsLTyVarNames explicit_vars - get_scoped_tvs_from_sig (XHsImplicitBndrs nec) - = noExtCon nec - -{- Notes - -Note [Scoped type variables in bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a. a -> a - f x = x::a -Here the 'forall a' brings 'a' into scope over the binding group. -To achieve this we - - a) Gensym a binding for 'a' at the same time as we do one for 'f' - collecting the relevant binders with hsScopedTvBinders - - b) When processing the 'forall', don't gensym - -The relevant places are signposted with references to this Note - -Note [Scoped type variables in class and instance declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Scoped type variables may occur in default methods and default -signatures. We need to bring the type variables in 'foralls' -into the scope of the method bindings. - -Consider - class Foo a where - foo :: forall (b :: k). a -> Proxy b -> Proxy b - foo _ x = (x :: Proxy b) - -We want to ensure that the 'b' in the type signature and the default -implementation are the same, so we do the following: - - a) Before desugaring the signature and binding of 'foo', use - get_scoped_tvs to collect type variables in 'forall' and - create symbols for them. - b) Use 'addBinds' to bring these symbols into the scope of the type - signatures and bindings. - c) Use these symbols to generate Core for the class/instance declaration. - -Note that when desugaring the signatures, we lookup the type variables -from the scope rather than recreate symbols for them. See more details -in "rep_ty_sig" and in Trac#14885. - -Note [Binders and occurrences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we desugar [d| data T = MkT |] -we want to get - Data "T" [] [Con "MkT" []] [] -and *not* - Data "Foo:T" [] [Con "Foo:MkT" []] [] -That is, the new data decl should fit into whatever new module it is -asked to fit in. We do *not* clone, though; no need for this: - Data "T79" .... - -But if we see this: - data T = MkT - foo = reifyDecl T - -then we must desugar to - foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] - -So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. -And we use lookupOcc, rather than lookupBinder -in repTyClD and repC. - -Note [Don't quantify implicit type variables in quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you're not careful, it's suprisingly easy to take this quoted declaration: - - [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b - idProxy x = x - |] - -and have Template Haskell turn it into this: - - idProxy :: forall k proxy (b :: k). proxy b -> proxy b - idProxy x = x - -Notice that we explicitly quantified the variable `k`! The latter declaration -isn't what the user wrote in the first place. - -Usually, the culprit behind these bugs is taking implicitly quantified type -variables (often from the hsib_vars field of HsImplicitBinders) and putting -them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. --} - --- represent associated family instances --- -repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) - -repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $ - repFamilyDecl (L loc fam) - -repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - repSynDecl tc1 bndrs rhs - ; return (Just (loc, dec)) } - -repTyClD (dL->L loc (DataDecl { tcdLName = tc - , tcdTyVars = tvs - , tcdDataDefn = defn })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - repDataDefn tc1 (Left bndrs) defn - ; return (Just (loc, dec)) } - -repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, - tcdTyVars = tvs, tcdFDs = fds, - tcdSigs = sigs, tcdMeths = meth_binds, - tcdATs = ats, tcdATDefs = atds })) - = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { cxt1 <- repLContext cxt - -- See Note [Scoped type variables in class and instance declarations] - ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds - ; fds1 <- repLFunDeps fds - ; ats1 <- repFamilyDecls ats - ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds - ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds) - ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 - ; wrapGenSyms ss decls2 } - ; return $ Just (loc, dec) - } - -repTyClD _ = panic "repTyClD" - -------------------------- -repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles)) - = do { tycon1 <- lookupLOcc tycon - ; roles1 <- mapM repRole roles - ; roles2 <- coreList roleTyConName roles1 - ; dec <- repRoleAnnotD tycon1 roles2 - ; return (loc, dec) } -repRoleD _ = panic "repRoleD" - -------------------------- -repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repKiSigD (dL->L loc kisig) = - case kisig of - StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v - XStandaloneKindSig nec -> noExtCon nec - -------------------------- -repDataDefn :: Core TH.Name - -> Either (Core [TH.TyVarBndrQ]) - -- the repTyClD case - (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) - -- the repDataFamInstD case - -> HsDataDefn GhcRn - -> DsM (Core TH.DecQ) -repDataDefn tc opts - (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig - , dd_cons = cons, dd_derivs = mb_derivs }) - = do { cxt1 <- repLContext cxt - ; derivs1 <- repDerivs mb_derivs - ; case (new_or_data, cons) of - (NewType, [con]) -> do { con' <- repC con - ; ksig' <- repMaybeLTy ksig - ; repNewtype cxt1 tc opts ksig' con' - derivs1 } - (NewType, _) -> failWithDs (text "Multiple constructors for newtype:" - <+> pprQuotedList - (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLTy ksig - ; consL <- mapM repC cons - ; cons1 <- coreList conQTyConName consL - ; repData cxt1 tc opts ksig' cons1 - derivs1 } - } -repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec - -repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] - -> LHsType GhcRn - -> DsM (Core TH.DecQ) -repSynDecl tc bndrs ty - = do { ty1 <- repLTy ty - ; repTySyn tc bndrs ty1 } - -repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info - , fdLName = tc - , fdTyVars = tvs - , fdResultSig = dL->L _ resultSig - , fdInjectivityAnn = injectivity })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn - mkHsQTvs tvs = HsQTvs { hsq_ext = [] - , hsq_explicit = tvs } - resTyVar = case resultSig of - TyVarSig _ bndr -> mkHsQTvs [bndr] - _ -> mkHsQTvs [] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - addTyClTyVarBinds resTyVar $ \_ -> - case info of - ClosedTypeFamily Nothing -> - notHandled "abstract closed type family" (ppr decl) - ClosedTypeFamily (Just eqns) -> - do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns - ; eqns2 <- coreList tySynEqnQTyConName eqns1 - ; result <- repFamilyResultSig resultSig - ; inj <- repInjectivityAnn injectivity - ; repClosedFamilyD tc1 bndrs result inj eqns2 } - OpenTypeFamily -> - do { result <- repFamilyResultSig resultSig - ; inj <- repInjectivityAnn injectivity - ; repOpenFamilyD tc1 bndrs result inj } - DataFamily -> - do { kind <- repFamilyResultSigToMaybeKind resultSig - ; repDataFamilyD tc1 bndrs kind } - ; return (loc, dec) - } -repFamilyDecl _ = panic "repFamilyDecl" - --- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ) -repFamilyResultSig (NoSig _) = repNoSig -repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki - ; repKindSig ki' } -repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr - ; repTyVarSig bndr' } -repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec - --- | Represent result signature using a Maybe Kind. Used with data families, --- where the result signature can be either missing or a kind but never a named --- result variable. -repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn - -> DsM (Core (Maybe TH.KindQ)) -repFamilyResultSigToMaybeKind (NoSig _) = - do { coreNothing kindQTyConName } -repFamilyResultSigToMaybeKind (KindSig _ ki) = - do { ki' <- repLTy ki - ; coreJust kindQTyConName ki' } -repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" - --- | Represent injectivity annotation of a type family -repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) - -> DsM (Core (Maybe TH.InjectivityAnn)) -repInjectivityAnn Nothing = - do { coreNothing injAnnTyConName } -repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) = - do { lhs' <- lookupBinder (unLoc lhs) - ; rhs1 <- mapM (lookupBinder . unLoc) rhs - ; rhs2 <- coreList nameTyConName rhs1 - ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2] - ; coreJust injAnnTyConName injAnn } - -repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ] -repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) - -repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ) -repAssocTyFamDefaultD = repTyFamInstD - -------------------------- --- represent fundeps --- -repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep]) -repLFunDeps fds = repList funDepTyConName repLFunDep fds - -repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep) -repLFunDep (dL->L _ (xs, ys)) - = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs - ys' <- repList nameTyConName (lookupBinder . unLoc) ys - repFunDep xs' ys' - --- Represent instance declarations --- -repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl })) - = do { dec <- repTyFamInstD fi_decl - ; return (loc, dec) } -repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl })) - = do { dec <- repDataFamInstD fi_decl - ; return (loc, dec) } -repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl })) - = do { dec <- repClsInstD cls_decl - ; return (loc, dec) } -repInstD _ = panic "repInstD" - -repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) -repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds - , cid_sigs = sigs, cid_tyfam_insts = ats - , cid_datafam_insts = adts - , cid_overlap_mode = overlap - }) - = addSimpleTyVarBinds tvs $ - -- We must bring the type variables into scope, so their - -- occurrences don't fail, even though the binders don't - -- appear in the resulting data structure - -- - -- But we do NOT bring the binders of 'binds' into scope - -- because they are properly regarded as occurrences - -- For example, the method names should be bound to - -- the selector Ids, not to fresh names (#5410) - -- - do { cxt1 <- repLContext cxt - ; inst_ty1 <- repLTy inst_ty - -- See Note [Scoped type variables in class and instance declarations] - ; (ss, sigs_binds) <- rep_sigs_binds sigs binds - ; ats1 <- mapM (repTyFamInstD . unLoc) ats - ; adts1 <- mapM (repDataFamInstD . unLoc) adts - ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds) - ; rOver <- repOverlap (fmap unLoc overlap) - ; decls2 <- repInst rOver cxt1 inst_ty1 decls1 - ; wrapGenSyms ss decls2 } - where - (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repClsInstD (XClsInstDecl nec) = noExtCon nec - -repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat - , deriv_type = ty })) - = do { dec <- addSimpleTyVarBinds tvs $ - do { cxt' <- repLContext cxt - ; strat' <- repDerivStrategy strat - ; inst_ty' <- repLTy inst_ty - ; repDeriv strat' cxt' inst_ty' } - ; return (loc, dec) } - where - (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) -repStandaloneDerivD _ = panic "repStandaloneDerivD" - -repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) -repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn1 <- repTyFamEqn eqn - ; repTySynInst eqn1 } - -repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (HsIB { hsib_ext = var_names - , hsib_body = FamEqn { feqn_tycon = tc_name - , feqn_bndrs = mb_bndrs - , feqn_pats = tys - , feqn_fixity = fixity - , feqn_rhs = rhs }}) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_ext = var_names - , hsq_explicit = fromMaybe [] mb_bndrs } - ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName - repTyVarBndr - mb_bndrs - ; tys1 <- case fixity of - Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys - ; t1' <- repLTy t1 - ; t2' <- repLTy t2 - ; repTyArgs (repTInfix t1' tc t2') args } - ; rhs1 <- repLTy rhs - ; repTySynEqn mb_bndrs1 tys1 rhs1 } } - where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _:HsValArg _:_) = return tys - checkTys _ = panic "repTyFamEqn:checkTys" -repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec -repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec - -repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ) -repTyArgs f [] = f -repTyArgs f (HsValArg ty : as) = do { f' <- f - ; ty' <- repLTy ty - ; repTyArgs (repTapp f' ty') as } -repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f - ; ki' <- repLTy ki - ; repTyArgs (repTappKind f' ki') as } -repTyArgs f (HsArgPar _ : as) = repTyArgs f as - -repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) -repDataFamInstD (DataFamInstDecl { dfid_eqn = - (HsIB { hsib_ext = var_names - , hsib_body = FamEqn { feqn_tycon = tc_name - , feqn_bndrs = mb_bndrs - , feqn_pats = tys - , feqn_fixity = fixity - , feqn_rhs = defn }})}) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_ext = var_names - , hsq_explicit = fromMaybe [] mb_bndrs } - ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName - repTyVarBndr - mb_bndrs - ; tys1 <- case fixity of - Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys - ; t1' <- repLTy t1 - ; t2' <- repLTy t2 - ; repTyArgs (repTInfix t1' tc t2') args } - ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } } - - where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _: HsValArg _: _) = return tys - checkTys _ = panic "repDataFamInstD:checkTys" - -repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec -repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) - = noExtCon nec - -repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) -repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ - , fd_fi = CImport (dL->L _ cc) - (dL->L _ s) mch cis _ })) - = do MkC name' <- lookupLOcc name - MkC typ' <- repHsSigType typ - MkC cc' <- repCCallConv cc - MkC s' <- repSafety s - cis' <- conv_cimportspec cis - MkC str <- coreStringLit (static ++ chStr ++ cis') - dec <- rep2 forImpDName [cc', s', str, name', typ'] - return (loc, dec) - where - conv_cimportspec (CLabel cls) - = notHandled "Foreign label" (doubleQuotes (ppr cls)) - conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget _ fs _ True)) - = return (unpackFS fs) - conv_cimportspec (CFunction (StaticTarget _ _ _ False)) - = panic "conv_cimportspec: values not supported yet" - conv_cimportspec CWrapper = return "wrapper" - -- these calling conventions do not support headers and the static keyword - raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv - static = case cis of - CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " - _ -> "" - chStr = case mch of - Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " - _ -> "" -repForD decl = notHandled "Foreign declaration" (ppr decl) - -repCCallConv :: CCallConv -> DsM (Core TH.Callconv) -repCCallConv CCallConv = rep2 cCallName [] -repCCallConv StdCallConv = rep2 stdCallName [] -repCCallConv CApiConv = rep2 cApiCallName [] -repCCallConv PrimCallConv = rep2 primCallName [] -repCCallConv JavaScriptCallConv = rep2 javaScriptCallName [] - -repSafety :: Safety -> DsM (Core TH.Safety) -repSafety PlayRisky = rep2 unsafeName [] -repSafety PlayInterruptible = rep2 interruptibleName [] -repSafety PlaySafe = rep2 safeName [] - -repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir))) - = do { MkC prec' <- coreIntLit prec - ; let rep_fn = case dir of - InfixL -> infixLDName - InfixR -> infixRDName - InfixN -> infixNDName - ; let do_one name - = do { MkC name' <- lookupLOcc name - ; dec <- rep2 rep_fn [prec', name'] - ; return (loc,dec) } - ; mapM do_one names } -repFixD _ = panic "repFixD" - -repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRuleD (dL->L loc (HsRule { rd_name = n - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs })) - = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> - do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs - ; ss <- mkGenSyms tm_bndr_names - ; rule <- addBinds ss $ - do { ty_bndrs' <- case ty_bndrs of - Nothing -> coreNothingList tyVarBndrQTyConName - Just _ -> coreJustList tyVarBndrQTyConName - ex_bndrs - ; tm_bndrs' <- repList ruleBndrQTyConName - repRuleBndr - tm_bndrs - ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n - ; act' <- repPhases act - ; lhs' <- repLE lhs - ; rhs' <- repLE rhs - ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } - ; wrapGenSyms ss rule } - ; return (loc, rule) } -repRuleD _ = panic "repRuleD" - -ruleBndrNames :: LRuleBndr GhcRn -> [Name] -ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n] -ruleBndrNames (dL->L _ (RuleBndrSig _ n sig)) - | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig - = unLoc n : vars -ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) - = panic "ruleBndrNames" -ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) - = panic "ruleBndrNames" -ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec -ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884 - -repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) -repRuleBndr (dL->L _ (RuleBndr _ n)) - = do { MkC n' <- lookupLBinder n - ; rep2 ruleVarName [n'] } -repRuleBndr (dL->L _ (RuleBndrSig _ n sig)) - = do { MkC n' <- lookupLBinder n - ; MkC ty' <- repLTy (hsSigWcType sig) - ; rep2 typedRuleVarName [n', ty'] } -repRuleBndr _ = panic "repRuleBndr" - -repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp))) - = do { target <- repAnnProv ann_prov - ; exp' <- repE exp - ; dec <- repPragAnn target exp' - ; return (loc, dec) } -repAnnD _ = panic "repAnnD" - -repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance (dL->L _ n)) - = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level - ; rep2 valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance (dL->L _ n)) - = do { MkC n' <- globalVar n - ; rep2 typeAnnotationName [ n' ] } -repAnnProv ModuleAnnProvenance - = rep2 moduleAnnotationName [] - -------------------------------------------------------- --- Constructors -------------------------------------------------------- - -repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) -repC (dL->L _ (ConDeclH98 { con_name = con - , con_forall = (dL->L _ False) - , con_mb_cxt = Nothing - , con_args = args })) - = repDataCon con args - -repC (dL->L _ (ConDeclH98 { con_name = con - , con_forall = (dL->L _ is_existential) - , con_ex_tvs = con_tvs - , con_mb_cxt = mcxt - , con_args = args })) - = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> - do { c' <- repDataCon con args - ; ctxt' <- repMbContext mcxt - ; if not is_existential && isNothing mcxt - then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) - } - } - -repC (dL->L _ (ConDeclGADT { con_names = cons - , con_qvars = qtvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty })) - | isEmptyLHsQTvs qtvs -- No implicit or explicit variables - , Nothing <- mcxt -- No context - -- ==> no need for a forall - = repGadtDataCons cons args res_ty - - | otherwise - = addTyVarBinds qtvs $ \ ex_bndrs -> - -- See Note [Don't quantify implicit type variables in quotes] - do { c' <- repGadtDataCons cons args res_ty - ; ctxt' <- repMbContext mcxt - ; if null (hsQTvExplicit qtvs) && isNothing mcxt - then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } - -repC _ = panic "repC" - - -repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) -repMbContext Nothing = repContext [] -repMbContext (Just (dL->L _ cxt)) = repContext cxt - -repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) -repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] -repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] -repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] - -repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ) -repSrcStrictness SrcLazy = rep2 sourceLazyName [] -repSrcStrictness SrcStrict = rep2 sourceStrictName [] -repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] - -repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ)) -repBangTy ty = do - MkC u <- repSrcUnpackedness su' - MkC s <- repSrcStrictness ss' - MkC b <- rep2 bangName [u, s] - MkC t <- repLTy ty' - rep2 bangTypeName [b, t] - where - (su', ss', ty') = case unLoc ty of - HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty) - _ -> (NoSrcUnpack, NoSrcStrict, ty) - -------------------------------------------------------- --- Deriving clauses -------------------------------------------------------- - -repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) -repDerivs (dL->L _ clauses) - = repList derivClauseQTyConName repDerivClause clauses - -repDerivClause :: LHsDerivingClause GhcRn - -> DsM (Core TH.DerivClauseQ) -repDerivClause (dL->L _ (HsDerivingClause - { deriv_clause_strategy = dcs - , deriv_clause_tys = (dL->L _ dct) })) - = do MkC dcs' <- repDerivStrategy dcs - MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct - rep2 derivClauseName [dcs',dct'] - where - rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) - rep_deriv_ty ty = repLTy ty -repDerivClause _ = panic "repDerivClause" - -rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn - -> DsM ([GenSymBind], [Core TH.DecQ]) --- Represent signatures and methods in class/instance declarations. --- See Note [Scoped type variables in class and instance declarations] --- --- Why not use 'repBinds': we have already created symbols for methods in --- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate --- these fun_id via 'collectHsValBinders decs', which would lead to the --- instance declarations failing in TH. -rep_sigs_binds sigs binds - = do { let tvs = concatMap get_scoped_tvs sigs - ; ss <- mkGenSyms tvs - ; sigs1 <- addBinds ss $ rep_sigs sigs - ; binds1 <- addBinds ss $ rep_binds binds - ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) } - -------------------------------------------------------- --- Signatures in a class decl, or a group of bindings -------------------------------------------------------- - -rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] - -- We silently ignore ones we don't recognise -rep_sigs = concatMapM rep_sig - -rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (dL->L loc (TypeSig _ nms ty)) - = mapM (rep_wc_ty_sig sigDName loc ty) nms -rep_sig (dL->L loc (PatSynSig _ nms ty)) - = mapM (rep_patsyn_ty_sig loc ty) nms -rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty)) - | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms - | otherwise = mapM (rep_ty_sig sigDName loc ty) nms -rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) -rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level -rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc -rep_sig (dL->L loc (SpecSig _ nm tys ispec)) - = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc -rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty -rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty)) - = rep_complete_sig cls mty loc -rep_sig _ = panic "rep_sig" - -rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name - -> DsM (SrcSpan, Core TH.DecQ) --- Don't create the implicit and explicit variables when desugaring signatures, --- see Note [Scoped type variables in class and instance declarations]. --- and Note [Don't quantify implicit type variables in quotes] -rep_ty_sig mk_sig loc sig_ty nm - | HsIB { hsib_body = hs_ty } <- sig_ty - , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty - = do { nm1 <- lookupLOcc nm - ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv - explicit_tvs - - -- NB: Don't pass any implicit type variables to repList above - -- See Note [Don't quantify implicit type variables in quotes] - - ; th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; ty1 <- if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty - ; sig <- repProto mk_sig nm1 ty1 - ; return (loc, sig) } -rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec - -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name - -> DsM (SrcSpan, Core TH.DecQ) --- represents a pattern synonym type signature; --- see Note [Pattern synonym type signatures and Template Haskell] in Convert --- --- Don't create the implicit and explicit variables when desugaring signatures, --- see Note [Scoped type variables in class and instance declarations] --- and Note [Don't quantify implicit type variables in quotes] -rep_patsyn_ty_sig loc sig_ty nm - | HsIB { hsib_body = hs_ty } <- sig_ty - , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty - = do { nm1 <- lookupLOcc nm - ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv name } - ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs - ; th_exis <- repList tyVarBndrQTyConName rep_in_scope_tv exis - - -- NB: Don't pass any implicit type variables to repList above - -- See Note [Don't quantify implicit type variables in quotes] - - ; th_reqs <- repLContext reqs - ; th_provs <- repLContext provs - ; th_ty <- repLTy ty - ; ty1 <- repTForall th_univs th_reqs =<< - repTForall th_exis th_provs th_ty - ; sig <- repProto patSynSigDName nm1 ty1 - ; return (loc, sig) } -rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec - -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name - -> DsM (SrcSpan, Core TH.DecQ) -rep_wc_ty_sig mk_sig loc sig_ty nm - = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm - -rep_inline :: Located Name - -> InlinePragma -- Never defaultInlinePragma - -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_inline nm ispec loc - = do { nm1 <- lookupLOcc nm - ; inline <- repInline $ inl_inline ispec - ; rm <- repRuleMatch $ inl_rule ispec - ; phases <- repPhases $ inl_act ispec - ; pragma <- repPragInl nm1 inline rm phases - ; return [(loc, pragma)] - } - -rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma - -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_specialise nm ty ispec loc - = do { nm1 <- lookupLOcc nm - ; ty1 <- repHsSigType ty - ; phases <- repPhases $ inl_act ispec - ; let inline = inl_inline ispec - ; pragma <- if noUserInlineSpec inline - then -- SPECIALISE - repPragSpec nm1 ty1 phases - else -- SPECIALISE INLINE - do { inline1 <- repInline inline - ; repPragSpecInl nm1 ty1 inline1 phases } - ; return [(loc, pragma)] - } - -rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_specialiseInst ty loc - = do { ty1 <- repHsSigType ty - ; pragma <- repPragSpecInst ty1 - ; return [(loc, pragma)] } - -repInline :: InlineSpec -> DsM (Core TH.Inline) -repInline NoInline = dataCon noInlineDataConName -repInline Inline = dataCon inlineDataConName -repInline Inlinable = dataCon inlinableDataConName -repInline spec = notHandled "repInline" (ppr spec) - -repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch) -repRuleMatch ConLike = dataCon conLikeDataConName -repRuleMatch FunLike = dataCon funLikeDataConName - -repPhases :: Activation -> DsM (Core TH.Phases) -repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i - ; dataCon' beforePhaseDataConName [arg] } -repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i - ; dataCon' fromPhaseDataConName [arg] } -repPhases _ = dataCon allPhasesDataConName - -rep_complete_sig :: Located [Located Name] - -> Maybe (Located Name) - -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_complete_sig (dL->L _ cls) mty loc - = do { mty' <- repMaybe nameTyConName lookupLOcc mty - ; cls' <- repList nameTyConName lookupLOcc cls - ; sig <- repPragComplete cls' mty' - ; return [(loc, sig)] } - -------------------------------------------------------- --- Types -------------------------------------------------------- - -addSimpleTyVarBinds :: [Name] -- the binders to be added - -> DsM (Core (TH.Q a)) -- action in the ext env - -> DsM (Core (TH.Q a)) -addSimpleTyVarBinds names thing_inside - = do { fresh_names <- mkGenSyms names - ; term <- addBinds fresh_names thing_inside - ; wrapGenSyms fresh_names term } - -addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added - -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env - -> DsM (Core (TH.Q a)) -addHsTyVarBinds exp_tvs thing_inside - = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) - ; term <- addBinds fresh_exp_names $ - do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr - (exp_tvs `zip` fresh_exp_names) - ; thing_inside kbs } - ; wrapGenSyms fresh_exp_names term } - where - mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) - -addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added - -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env - -> DsM (Core (TH.Q a)) --- gensym a list of type variables and enter them into the meta environment; --- the computations passed as the second argument is executed in that extended --- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_ext = imp_tvs - , hsq_explicit = exp_tvs }) - thing_inside - = addSimpleTyVarBinds imp_tvs $ - addHsTyVarBinds exp_tvs $ - thing_inside -addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec - -addTyClTyVarBinds :: LHsQTyVars GhcRn - -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) - -> DsM (Core (TH.Q a)) - --- Used for data/newtype declarations, and family instances, --- so that the nested type variables work right --- instance C (T a) where --- type W (T a) = blah --- The 'a' in the type instance is the one bound by the instance decl -addTyClTyVarBinds tvs m - = do { let tv_names = hsAllLTyVarNames tvs - ; env <- dsGetMetaEnv - ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) - -- Make fresh names for the ones that are not already in scope - -- This makes things work for family declarations - - ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr - (hsQTvExplicit tvs) - ; m kbs } - - ; wrapGenSyms freshNames term } - where - mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) - mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv v } - --- Produce kinded binder constructors from the Haskell tyvar binders --- -repTyVarBndrWithKind :: LHsTyVarBndr GhcRn - -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) -repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm - = repPlainTV nm -repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm - = repLTy ki >>= repKindedTV nm -repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind" - --- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) -repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) ) - = do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki)) - = do { nm' <- lookupBinder nm - ; ki' <- repLTy ki - ; repKindedTV nm' ki' } -repTyVarBndr _ = panic "repTyVarBndr" - --- represent a type context --- -repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ) -repLContext ctxt = repContext (unLoc ctxt) - -repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ) -repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt - repCtxt preds - -repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) -repHsSigType (HsIB { hsib_ext = implicit_tvs - , hsib_body = body }) - | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body - = addSimpleTyVarBinds implicit_tvs $ - -- See Note [Don't quantify implicit type variables in quotes] - addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> - do { th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty } -repHsSigType (XHsImplicitBndrs nec) = noExtCon nec - -repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) -repHsSigWcType (HsWC { hswc_body = sig1 }) - = repHsSigType sig1 -repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec - --- yield the representation of a list of types -repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] -repLTys tys = mapM repLTy tys - --- represent a type -repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ) -repLTy ty = repTy (unLoc ty) - --- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or --- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. --- In other words, the argument to this function is always an --- @HsForAllTy ForallInvis@ or @HsQualTy@. --- Types headed by visible foralls (which are desugared to ForallVisT) are --- handled separately in repTy. -repForallT :: HsType GhcRn -> DsM (Core TH.TypeQ) -repForallT ty - | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty) - = addHsTyVarBinds tvs $ \bndrs -> - do { ctxt1 <- repLContext ctxt - ; tau1 <- repLTy tau - ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} - } - -repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) -repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) = - case fvf of - ForallInvis -> repForallT ty - ForallVis -> addHsTyVarBinds tvs $ \bndrs -> - do body1 <- repLTy body - repTForallVis bndrs body1 -repTy ty@(HsQualTy {}) = repForallT ty - -repTy (HsTyVar _ _ (dL->L _ n)) - | isLiftedTypeKindTyConName n = repTStar - | n `hasKey` constraintKindTyConKey = repTConstraint - | n `hasKey` funTyConKey = repArrowTyCon - | isTvOcc occ = do tv1 <- lookupOcc n - repTvar tv1 - | isDataOcc occ = do tc1 <- lookupOcc n - repPromotedDataCon tc1 - | n == eqTyConName = repTequality - | otherwise = do tc1 <- lookupOcc n - repNamedTyCon tc1 - where - occ = nameOccName n - -repTy (HsAppTy _ f a) = do - f1 <- repLTy f - a1 <- repLTy a - repTapp f1 a1 -repTy (HsAppKindTy _ ty ki) = do - ty1 <- repLTy ty - ki1 <- repLTy ki - repTappKind ty1 ki1 -repTy (HsFunTy _ f a) = do - f1 <- repLTy f - a1 <- repLTy a - tcon <- repArrowTyCon - repTapps tcon [f1, a1] -repTy (HsListTy _ t) = do - t1 <- repLTy t - tcon <- repListTyCon - repTapp tcon t1 -repTy (HsTupleTy _ HsUnboxedTuple tys) = do - tys1 <- repLTys tys - tcon <- repUnboxedTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys - tcon <- repTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsSumTy _ tys) = do tys1 <- repLTys tys - tcon <- repUnboxedSumTyCon (length tys) - repTapps tcon tys1 -repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) -repTy (HsParTy _ t) = repLTy t -repTy (HsStarTy _ _) = repTStar -repTy (HsKindSig _ t k) = do - t1 <- repLTy t - k1 <- repLTy k - repTSig t1 k1 -repTy (HsSpliceTy _ splice) = repSplice splice -repTy (HsExplicitListTy _ _ tys) = do - tys1 <- repLTys tys - repTPromotedList tys1 -repTy (HsExplicitTupleTy _ tys) = do - tys1 <- repLTys tys - tcon <- repPromotedTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsTyLit _ lit) = do - lit' <- repTyLit lit - repTLit lit' -repTy (HsWildCardTy _) = repTWildCard -repTy (HsIParamTy _ n t) = do - n' <- rep_implicit_param_name (unLoc n) - t' <- repLTy t - repTImplicitParam n' t' - -repTy ty = notHandled "Exotic form of type" (ppr ty) - -repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) -repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i - rep2 numTyLitName [iExpr] -repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s - ; rep2 strTyLitName [s'] - } - --- | Represent a type wrapped in a Maybe -repMaybeLTy :: Maybe (LHsKind GhcRn) - -> DsM (Core (Maybe TH.TypeQ)) -repMaybeLTy = repMaybe kindQTyConName repLTy - -repRole :: Located (Maybe Role) -> DsM (Core TH.Role) -repRole (dL->L _ (Just Nominal)) = rep2 nominalRName [] -repRole (dL->L _ (Just Representational)) = rep2 representationalRName [] -repRole (dL->L _ (Just Phantom)) = rep2 phantomRName [] -repRole (dL->L _ Nothing) = rep2 inferRName [] -repRole _ = panic "repRole: Impossible Match" -- due to #15884 - ------------------------------------------------------------------------------ --- Splices ------------------------------------------------------------------------------ - -repSplice :: HsSplice GhcRn -> DsM (Core a) --- See Note [How brackets and nested splices are handled] in TcSplice --- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ _ n _) = rep_splice n -repSplice (HsUntypedSplice _ _ n _) = rep_splice n -repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n -repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) -repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e) -repSplice (XSplice nec) = noExtCon nec - -rep_splice :: Name -> DsM (Core a) -rep_splice splice_name - = do { mb_val <- dsLookupMetaEnv splice_name - ; case mb_val of - Just (DsSplice e) -> do { e' <- dsExpr e - ; return (MkC e') } - _ -> pprPanic "HsSplice" (ppr splice_name) } - -- Should not happen; statically checked - ------------------------------------------------------------------------------ --- Expressions ------------------------------------------------------------------------------ - -repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ]) -repLEs es = repList expQTyConName repLE es - --- FIXME: some of these panics should be converted into proper error messages --- unless we can make sure that constructs, which are plainly not --- supported in TH already lead to error messages at an earlier stage -repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) -repLE (dL->L loc e) = putSrcSpanDs loc (repE e) - -repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) -repE (HsVar _ (dL->L _ x)) = - do { mb_val <- dsLookupMetaEnv x - ; case mb_val of - Nothing -> do { str <- globalVar x - ; repVarOrCon x str } - Just (DsBound y) -> repVarOrCon x (coreVar y) - Just (DsSplice e) -> do { e' <- dsExpr e - ; return (MkC e') } } -repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar -repE (HsOverLabel _ _ s) = repOverLabel s - -repE e@(HsRecFld _ f) = case f of - Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) - Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) - XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e) - - -- Remember, we're desugaring renamer output here, so - -- HsOverlit can definitely occur -repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } -repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m -repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) })) - = do { ms' <- mapM repMatchTup ms - ; core_ms <- coreList matchQTyConName ms' - ; repLamCase core_ms } -repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType _ e t) = do { a <- repLE e - ; s <- repLTy (hswc_body t) - ; repAppType a s } - -repE (OpApp _ e1 op e2) = - do { arg1 <- repLE e1; - arg2 <- repLE e2; - the_op <- repLE op ; - repInfixApp arg1 the_op arg2 } -repE (NegApp _ x _) = do - a <- repLE x - negateVar <- lookupOcc negateName >>= repVar - negateVar `repApp` a -repE (HsPar _ x) = repLE x -repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } -repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) })) - = do { arg <- repLE e - ; ms2 <- mapM repMatchTup ms - ; core_ms2 <- coreList matchQTyConName ms2 - ; repCaseE arg core_ms2 } -repE (HsIf _ _ x y z) = do - a <- repLE x - b <- repLE y - c <- repLE z - repCond a b c -repE (HsMultiIf _ alts) - = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts - ; expr' <- repMultiIf (nonEmptyCoreList alts') - ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repLE e) - ; z <- repLetE ds e2 - ; wrapGenSyms ss z } - --- FIXME: I haven't got the types here right yet -repE e@(HsDo _ ctxt (dL->L _ sts)) - | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } - = do { (ss,zs) <- repLSts sts; - e' <- repDoE (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | ListComp <- ctxt - = do { (ss,zs) <- repLSts sts; - e' <- repComp (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | MDoExpr <- ctxt - = do { (ss,zs) <- repLSts sts; - e' <- repMDoE (nonEmptyCoreList zs); - wrapGenSyms ss e' } - - | otherwise - = notHandled "monad comprehension and [: :]" (ppr e) - -repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } -repE (ExplicitTuple _ es boxity) = - let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ)) - tupArgToCoreExp a - | L _ (Present _ e) <- dL a = do { e' <- repLE e - ; coreJust expQTyConName e' } - | otherwise = coreNothing expQTyConName - - in do { args <- mapM tupArgToCoreExp es - ; expQTy <- lookupType expQTyConName - ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy] - listArg = coreList' maybeExpQTy args - ; if isBoxed boxity - then repTup listArg - else repUnboxedTup listArg } - -repE (ExplicitSum _ alt arity e) - = do { e1 <- repLE e - ; repUnboxedSum e1 alt arity } - -repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) - = do { x <- lookupLOcc c; - fs <- repFields flds; - repRecCon x fs } -repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) - = do { x <- repLE e; - fs <- repUpdFields flds; - repRecUpd x fs } - -repE (ExprWithTySig _ e ty) - = do { e1 <- repLE e - ; t1 <- repHsSigWcType ty - ; repSigExp e1 t1 } - -repE (ArithSeq _ _ aseq) = - case aseq of - From e -> do { ds1 <- repLE e; repFrom ds1 } - FromThen e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromThen ds1 ds2 - FromTo e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromTo ds1 ds2 - FromThenTo e1 e2 e3 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - ds3 <- repLE e3 - repFromThenTo ds1 ds2 ds3 - -repE (HsSpliceE _ splice) = repSplice splice -repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC -repE (HsUnboundVar _ uv) = do - occ <- occNameLit (unboundVarOcc uv) - sname <- repNameS occ - repUnboundVar sname - -repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) -repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) -repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) -repE e = notHandled "Expression form" (ppr e) - ------------------------------------------------------------------------------ --- Building representations of auxillary structures like Match, Clause, Stmt, - -repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) -repMatchTup (dL->L _ (Match { m_pats = [p] - , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatBinders p) - ; addBinds ss1 $ do { - ; p1 <- repLP p - ; (ss2,ds) <- repBinds wheres - ; addBinds ss2 $ do { - ; gs <- repGuards guards - ; match <- repMatch p1 gs ds - ; wrapGenSyms (ss1++ss2) match }}} -repMatchTup _ = panic "repMatchTup: case alt with more than one arg" - -repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) -repClauseTup (dL->L _ (Match { m_pats = ps - , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = - do { ss1 <- mkGenSyms (collectPatsBinders ps) - ; addBinds ss1 $ do { - ps1 <- repLPs ps - ; (ss2,ds) <- repBinds wheres - ; addBinds ss2 $ do { - gs <- repGuards guards - ; clause <- repClause ps1 gs ds - ; wrapGenSyms (ss1++ss2) clause }}} -repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec -repClauseTup _ = panic "repClauseTup" - -repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) -repGuards [dL->L _ (GRHS _ [] e)] - = do {a <- repLE e; repNormal a } -repGuards other - = do { zs <- mapM repLGRHS other - ; let (xs, ys) = unzip zs - ; gd <- repGuarded (nonEmptyCoreList ys) - ; wrapGenSyms (concat xs) gd } - -repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) - -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) -repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2)) - = do { guarded <- repLNormalGE e1 e2 - ; return ([], guarded) } -repLGRHS (dL->L _ (GRHS _ ss rhs)) - = do { (gs, ss') <- repLSts ss - ; rhs' <- addBinds gs $ repLE rhs - ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' - ; return (gs, guarded) } -repLGRHS _ = panic "repLGRHS" - -repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) -repFields (HsRecFields { rec_flds = flds }) - = repList fieldExpQTyConName rep_fld flds - where - rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) - -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } - -repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) -repUpdFields = repList fieldExpQTyConName rep_fld - where - rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of - Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } - _ -> notHandled "Ambiguous record updates" (ppr fld) - - - ------------------------------------------------------------------------------ --- Representing Stmt's is tricky, especially if bound variables --- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] --- First gensym new names for every variable in any of the patterns. --- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) --- if variables didn't shaddow, the static gensym wouldn't be necessary --- and we could reuse the original names (x and x). --- --- do { x'1 <- gensym "x" --- ; x'2 <- gensym "x" --- ; doE [ BindSt (pvar x'1) [| f 1 |] --- , BindSt (pvar x'2) [| f x |] --- , NoBindSt [| g x |] --- ] --- } - --- The strategy is to translate a whole list of do-bindings by building a --- bigger environment, and a bigger set of meta bindings --- (like: x'1 <- gensym "x" ) and then combining these with the translations --- of the expressions within the Do - ------------------------------------------------------------------------------ --- The helper function repSts computes the translation of each sub expression --- and a bunch of prefix bindings denoting the dynamic renaming. - -repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repLSts stmts = repSts (map unLoc stmts) - -repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repSts (BindStmt _ p e _ _ : ss) = - do { e2 <- repLE e - ; ss1 <- mkGenSyms (collectPatBinders p) - ; addBinds ss1 $ do { - ; p1 <- repLP p; - ; (ss2,zs) <- repSts ss - ; z <- repBindSt p1 e2 - ; return (ss1++ss2, z : zs) }} -repSts (LetStmt _ (dL->L _ bs) : ss) = - do { (ss1,ds) <- repBinds bs - ; z <- repLetSt ds - ; (ss2,zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } -repSts (BodyStmt _ e _ _ : ss) = - do { e2 <- repLE e - ; z <- repNoBindSt e2 - ; (ss2,zs) <- repSts ss - ; return (ss2, z : zs) } -repSts (ParStmt _ stmt_blocks _ _ : ss) = - do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks - ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 - ss1 = concat ss_s - ; z <- repParSt stmt_blocks2 - ; (ss2, zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } - where - rep_stmt_block :: ParStmtBlock GhcRn GhcRn - -> DsM ([GenSymBind], Core [TH.StmtQ]) - rep_stmt_block (ParStmtBlock _ stmts _ _) = - do { (ss1, zs) <- repSts (map unLoc stmts) - ; zs1 <- coreList stmtQTyConName zs - ; return (ss1, zs1) } - rep_stmt_block (XParStmtBlock nec) = noExtCon nec -repSts [LastStmt _ e _ _] - = do { e2 <- repLE e - ; z <- repNoBindSt e2 - ; return ([], [z]) } -repSts (stmt@RecStmt{} : ss) - = do { let binders = collectLStmtsBinders (recS_stmts stmt) - ; ss1 <- mkGenSyms binders - -- Bring all of binders in the recursive group into scope for the - -- whole group. - ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt)) - ; MASSERT(sort ss1 == sort ss1_other) - ; z <- repRecSt (nonEmptyCoreList rss) - ; (ss2,zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } -repSts [] = return ([],[]) -repSts other = notHandled "Exotic statement" (ppr other) - - ------------------------------------------------------------ --- Bindings ------------------------------------------------------------ - -repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) -repBinds (EmptyLocalBinds _) - = do { core_list <- coreList decQTyConName [] - ; return ([], core_list) } - -repBinds (HsIPBinds _ (IPBinds _ decs)) - = do { ips <- mapM rep_implicit_param_bind decs - ; core_list <- coreList decQTyConName - (de_loc (sort_by_loc ips)) - ; return ([], core_list) - } - -repBinds b@(HsIPBinds _ XHsIPBinds {}) - = notHandled "Implicit parameter binds extension" (ppr b) - -repBinds (HsValBinds _ decs) - = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } - -- No need to worry about detailed scopes within - -- the binding group, because we are talking Names - -- here, so we can safely treat it as a mutually - -- recursive group - -- For hsScopedTvBinders see Note [Scoped type variables in bindings] - ; ss <- mkGenSyms bndrs - ; prs <- addBinds ss (rep_val_binds decs) - ; core_list <- coreList decQTyConName - (de_loc (sort_by_loc prs)) - ; return (ss, core_list) } -repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b) - -rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs))) - = do { name <- case ename of - Left (dL->L _ n) -> rep_implicit_param_name n - Right _ -> - panic "rep_implicit_param_bind: post typechecking" - ; rhs' <- repE rhs - ; ipb <- repImplicitParamBind name rhs' - ; return (loc, ipb) } -rep_implicit_param_bind (dL->L _ b@(XIPBind _)) - = notHandled "Implicit parameter bind extension" (ppr b) -rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match" - -- due to #15884 - -rep_implicit_param_name :: HsIPName -> DsM (Core String) -rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) - -rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] --- Assumes: all the binders of the binding are already in the meta-env -rep_val_binds (XValBindsLR (NValBinds binds sigs)) - = do { core1 <- rep_binds (unionManyBags (map snd binds)) - ; core2 <- rep_sigs sigs - ; return (core1 ++ core2) } -rep_val_binds (ValBinds _ _ _) - = panic "rep_val_binds: ValBinds" - -rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -rep_binds = mapM rep_bind . bagToList - -rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) --- Assumes: all the binders of the binding are already in the meta-env - --- Note GHC treats declarations of a variable (not a pattern) --- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match --- with an empty list of patterns -rep_bind (dL->L loc (FunBind - { fun_id = fn, - fun_matches = MG { mg_alts - = (dL->L _ [dL->L _ (Match - { m_pats = [] - , m_grhss = GRHSs _ guards - (dL->L _ wheres) } - )]) } })) - = do { (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) - ; fn' <- lookupLBinder fn - ; p <- repPvar fn' - ; ans <- repVal p guardcore wherecore - ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } - -rep_bind (dL->L loc (FunBind { fun_id = fn - , fun_matches = MG { mg_alts = (dL->L _ ms) } })) - = do { ms1 <- mapM repClauseTup ms - ; fn' <- lookupLBinder fn - ; ans <- repFun fn' (nonEmptyCoreList ms1) - ; return (loc, ans) } - -rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec - -rep_bind (dL->L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs _ guards (dL->L _ wheres) })) - = do { patcore <- repLP pat - ; (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) - ; ans <- repVal patcore guardcore wherecore - ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } -rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec - -rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) - = do { v' <- lookupBinder v - ; e2 <- repLE e - ; x <- repNormal e2 - ; patcore <- repPvar v' - ; empty_decls <- coreList decQTyConName [] - ; ans <- repVal patcore x empty_decls - ; return (srcLocSpan (getSrcLoc v), ans) } - -rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) - = do { syn' <- lookupLBinder syn - ; dir' <- repPatSynDir dir - ; ss <- mkGenArgSyms args - ; patSynD' <- addBinds ss ( - do { args' <- repPatSynArgs args - ; pat' <- repLP pat - ; repPatSynD syn' args' dir' pat' }) - ; patSynD'' <- wrapGenArgSyms args ss patSynD' - ; return (loc, patSynD'') } - where - mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind] - -- for Record Pattern Synonyms we want to conflate the selector - -- and the pattern-only names in order to provide a nicer TH - -- API. Whereas inside GHC, record pattern synonym selectors and - -- their pattern-only bound right hand sides have different names, - -- we want to treat them the same in TH. This is the reason why we - -- need an adjusted mkGenArgSyms in the `RecCon` case below. - mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) - mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] - mkGenArgSyms (RecCon fields) - = do { let pats = map (unLoc . recordPatSynPatVar) fields - sels = map (unLoc . recordPatSynSelectorId) fields - ; ss <- mkGenSyms sels - ; return $ replaceNames (zip sels pats) ss } - - replaceNames selsPats genSyms - = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats - , sel == sel' ] - - wrapGenArgSyms :: HsPatSynDetails (Located Name) - -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ) - wrapGenArgSyms (RecCon _) _ dec = return dec - wrapGenArgSyms _ ss dec = wrapGenSyms ss dec - -rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec))) - = noExtCon nec -rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec -rep_bind _ = panic "rep_bind: Impossible match!" - -- due to #15884 - -repPatSynD :: Core TH.Name - -> Core TH.PatSynArgsQ - -> Core TH.PatSynDirQ - -> Core TH.PatQ - -> DsM (Core TH.DecQ) -repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) - = rep2 patSynDName [syn, args, dir, pat] - -repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ) -repPatSynArgs (PrefixCon args) - = do { args' <- repList nameTyConName lookupLOcc args - ; repPrefixPatSynArgs args' } -repPatSynArgs (InfixCon arg1 arg2) - = do { arg1' <- lookupLOcc arg1 - ; arg2' <- lookupLOcc arg2 - ; repInfixPatSynArgs arg1' arg2' } -repPatSynArgs (RecCon fields) - = do { sels' <- repList nameTyConName lookupLOcc sels - ; repRecordPatSynArgs sels' } - where sels = map recordPatSynSelectorId fields - -repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ) -repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] - -repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ) -repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2] - -repRecordPatSynArgs :: Core [TH.Name] - -> DsM (Core TH.PatSynArgsQ) -repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] - -repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) -repPatSynDir Unidirectional = rep2 unidirPatSynName [] -repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] -repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) })) - = do { clauses' <- mapM repClauseTup clauses - ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } -repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec - -repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) -repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] - - ------------------------------------------------------------------------------ --- Since everything in a Bind is mutually recursive we need rename all --- all the variables simultaneously. For example: --- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to --- do { f'1 <- gensym "f" --- ; g'2 <- gensym "g" --- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, --- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} --- ]} --- This requires collecting the bindings (f'1 <- gensym "f"), and the --- environment ( f |-> f'1 ) from each binding, and then unioning them --- together. As we do this we collect GenSymBinds's which represent the renamed --- variables bound by the Bindings. In order not to lose track of these --- representations we build a shadow datatype MB with the same structure as --- MonoBinds, but which has slots for the representations - - ------------------------------------------------------------------------------ --- GHC allows a more general form of lambda abstraction than specified --- by Haskell 98. In particular it allows guarded lambda's like : --- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in --- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like --- (\ p1 .. pn -> exp) by causing an error. - -repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) -repLambda (dL->L _ (Match { m_pats = ps - , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)] - (dL->L _ (EmptyLocalBinds _)) } )) - = do { let bndrs = collectPatsBinders ps ; - ; ss <- mkGenSyms bndrs - ; lam <- addBinds ss ( - do { xs <- repLPs ps; body <- repLE e; repLam xs body }) - ; wrapGenSyms ss lam } - -repLambda (dL->L _ m) = notHandled "Guarded lambdas" (pprMatch m) - - ------------------------------------------------------------------------------ --- Patterns --- repP deals with patterns. It assumes that we have already --- walked over the pattern(s) once to collect the binders, and --- have extended the environment. So every pattern-bound --- variable should already appear in the environment. - --- Process a list of patterns -repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ]) -repLPs ps = repList patQTyConName repLP ps - -repLP :: LPat GhcRn -> DsM (Core TH.PatQ) -repLP p = repP (unLoc p) - -repP :: Pat GhcRn -> DsM (Core TH.PatQ) -repP (WildPat _) = repPwild -repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } -repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } -repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } -repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p - ; repPaspat x' p1 } -repP (ParPat _ p) = repLP p -repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps) - ; e' <- repE (syn_expr e) - ; repPview e' p} -repP (TuplePat _ ps boxed) - | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } - | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } -repP (SumPat _ p alt arity) = do { p1 <- repLP p - ; repPunboxedSum p1 alt arity } -repP (ConPatIn dc details) - = do { con_str <- lookupLOcc dc - ; case details of - PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } - RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec) - ; repPrec con_str fps } - InfixCon p1 p2 -> do { p1' <- repLP p1; - p2' <- repLP p2; - repPinfix p1' con_str p2' } - } - where - rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ)) - rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) - ; MkC p <- repLP (hsRecFieldArg fld) - ; rep2 fieldPatName [v,p] } - -repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l - ; repPlit a } -repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) -repP (SigPat _ p t) = do { p' <- repLP p - ; t' <- repLTy (hsSigWcType t) - ; repPsig p' t' } -repP (SplicePat _ splice) = repSplice splice - -repP other = notHandled "Exotic pattern" (ppr other) - ----------------------------------------------------------- --- Declaration ordering helpers - -sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] -sort_by_loc xs = sortBy comp xs - where comp x y = compare (fst x) (fst y) - -de_loc :: [(a, b)] -> [b] -de_loc = map snd - ----------------------------------------------------------- --- The meta-environment - --- A name/identifier association for fresh names of locally bound entities -type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id - -- I.e. (x, x_id) means - -- let x_id = gensym "x" in ... - --- Generate a fresh name for a locally bound entity - -mkGenSyms :: [Name] -> DsM [GenSymBind] --- We can use the existing name. For example: --- [| \x_77 -> x_77 + x_77 |] --- desugars to --- do { x_77 <- genSym "x"; .... } --- We use the same x_77 in the desugared program, but with the type Bndr --- instead of Int --- --- We do make it an Internal name, though (hence localiseName) --- --- Nevertheless, it's monadic because we have to generate nameTy -mkGenSyms ns = do { var_ty <- lookupType nameTyConName - ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } - - -addBinds :: [GenSymBind] -> DsM a -> DsM a --- Add a list of fresh names for locally bound entities to the --- meta environment (which is part of the state carried around --- by the desugarer monad) -addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m - --- Look up a locally bound name --- -lookupLBinder :: Located Name -> DsM (Core TH.Name) -lookupLBinder n = lookupBinder (unLoc n) - -lookupBinder :: Name -> DsM (Core TH.Name) -lookupBinder = lookupOcc - -- Binders are brought into scope before the pattern or what-not is - -- desugared. Moreover, in instance declaration the binder of a method - -- will be the selector Id and hence a global; so we need the - -- globalVar case of lookupOcc - --- Look up a name that is either locally bound or a global name --- --- * If it is a global name, generate the "original name" representation (ie, --- the : form) for the associated entity --- -lookupLOcc :: Located Name -> DsM (Core TH.Name) --- Lookup an occurrence; it can't be a splice. --- Use the in-scope bindings if they exist -lookupLOcc n = lookupOcc (unLoc n) - -lookupOcc :: Name -> DsM (Core TH.Name) -lookupOcc n - = do { mb_val <- dsLookupMetaEnv n ; - case mb_val of - Nothing -> globalVar n - Just (DsBound x) -> return (coreVar x) - Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) - } - -globalVar :: Name -> DsM (Core TH.Name) --- Not bound by the meta-env --- Could be top-level; or could be local --- f x = $(g [| x |]) --- Here the x will be local -globalVar name - | isExternalName name - = do { MkC mod <- coreStringLit name_mod - ; MkC pkg <- coreStringLit name_pkg - ; MkC occ <- nameLit name - ; rep2 mk_varg [pkg,mod,occ] } - | otherwise - = do { MkC occ <- nameLit name - ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name)) - ; rep2 mkNameLName [occ,uni] } - where - mod = ASSERT( isExternalName name) nameModule name - name_mod = moduleNameString (moduleName mod) - name_pkg = unitIdString (moduleUnitId mod) - name_occ = nameOccName name - mk_varg | OccName.isDataOcc name_occ = mkNameG_dName - | OccName.isVarOcc name_occ = mkNameG_vName - | OccName.isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "DsMeta.globalVar" (ppr name) - -lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) - -> DsM Type -- The type -lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; - return (mkTyConApp tc []) } - -wrapGenSyms :: [GenSymBind] - -> Core (TH.Q a) -> DsM (Core (TH.Q a)) --- wrapGenSyms [(nm1,id1), (nm2,id2)] y --- --> bindQ (gensym nm1) (\ id1 -> --- bindQ (gensym nm2 (\ id2 -> --- y)) - -wrapGenSyms binds body@(MkC b) - = do { var_ty <- lookupType nameTyConName - ; go var_ty binds } - where - [elt_ty] = tcTyConAppArgs (exprType b) - -- b :: Q a, so we can get the type 'a' by looking at the - -- argument type. NB: this relies on Q being a data/newtype, - -- not a type synonym - - go _ [] = return body - go var_ty ((name,id) : binds) - = do { MkC body' <- go var_ty binds - ; lit_str <- nameLit name - ; gensym_app <- repGensym lit_str - ; repBindQ var_ty elt_ty - gensym_app (MkC (Lam id body')) } - -nameLit :: Name -> DsM (Core String) -nameLit n = coreStringLit (occNameString (nameOccName n)) - -occNameLit :: OccName -> DsM (Core String) -occNameLit name = coreStringLit (occNameString name) - - --- %********************************************************************* --- %* * --- Constructing code --- %* * --- %********************************************************************* - ------------------------------------------------------------------------------ --- PHANTOM TYPES for consistency. In order to make sure we do this correct --- we invent a new datatype which uses phantom types. - -newtype Core a = MkC CoreExpr -unC :: Core a -> CoreExpr -unC (MkC x) = x - -rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) -rep2 n xs = do { id <- dsLookupGlobalId n - ; return (MkC (foldl' App (Var id) xs)) } - -dataCon' :: Name -> [CoreExpr] -> DsM (Core a) -dataCon' n args = do { id <- dsLookupDataCon n - ; return $ MkC $ mkCoreConApps id args } - -dataCon :: Name -> DsM (Core a) -dataCon n = dataCon' n [] - - --- %********************************************************************* --- %* * --- The 'smart constructors' --- %* * --- %********************************************************************* - ---------------- Patterns ----------------- -repPlit :: Core TH.Lit -> DsM (Core TH.PatQ) -repPlit (MkC l) = rep2 litPName [l] - -repPvar :: Core TH.Name -> DsM (Core TH.PatQ) -repPvar (MkC s) = rep2 varPName [s] - -repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPtup (MkC ps) = rep2 tupPName [ps] - -repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] - -repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ) --- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here -repPunboxedSum (MkC p) alt arity - = do { dflags <- getDynFlags - ; rep2 unboxedSumPName [ p - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } - -repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] - -repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ) -repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] - -repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) -repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] - -repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ) -repPtilde (MkC p) = rep2 tildePName [p] - -repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ) -repPbang (MkC p) = rep2 bangPName [p] - -repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) -repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] - -repPwild :: DsM (Core TH.PatQ) -repPwild = rep2 wildPName [] - -repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) -repPlist (MkC ps) = rep2 listPName [ps] - -repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ) -repPview (MkC e) (MkC p) = rep2 viewPName [e,p] - -repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) -repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] - ---------------- Expressions ----------------- -repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) -repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str - | otherwise = repVar str - -repVar :: Core TH.Name -> DsM (Core TH.ExpQ) -repVar (MkC s) = rep2 varEName [s] - -repCon :: Core TH.Name -> DsM (Core TH.ExpQ) -repCon (MkC s) = rep2 conEName [s] - -repLit :: Core TH.Lit -> DsM (Core TH.ExpQ) -repLit (MkC c) = rep2 litEName [c] - -repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repApp (MkC x) (MkC y) = rep2 appEName [x,y] - -repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) -repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] - -repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] - -repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ) -repLamCase (MkC ms) = rep2 lamCaseEName [ms] - -repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) -repTup (MkC es) = rep2 tupEName [es] - -repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) -repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] - -repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ) --- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here -repUnboxedSum (MkC e) alt arity - = do { dflags <- getDynFlags - ; rep2 unboxedSumEName [ e - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } - -repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] - -repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ) -repMultiIf (MkC alts) = rep2 multiIfEName [alts] - -repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] - -repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM (Core TH.ExpQ) -repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] - -repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) -repDoE (MkC ss) = rep2 doEName [ss] - -repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) -repMDoE (MkC ss) = rep2 mdoEName [ss] - -repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) -repComp (MkC ss) = rep2 compEName [ss] - -repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) -repListExp (MkC es) = rep2 listEName [es] - -repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) -repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] - -repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ) -repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] - -repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ) -repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] - -repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp)) -repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] - -repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] - -repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] - -repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] - -repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ) -repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x] - ------------- Right hand sides (guarded expressions) ---- -repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ) -repGuarded (MkC pairs) = rep2 guardedBName [pairs] - -repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) -repNormal (MkC e) = rep2 normalBName [e] - ------------- Guards ---- -repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn - -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) -repLNormalGE g e = do g' <- repLE g - e' <- repLE e - repNormalGE g' e' - -repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) -repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] - -repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) -repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] - -------------- Stmts ------------------- -repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ) -repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] - -repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ) -repLetSt (MkC ds) = rep2 letSName [ds] - -repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ) -repNoBindSt (MkC e) = rep2 noBindSName [e] - -repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ) -repParSt (MkC sss) = rep2 parSName [sss] - -repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ) -repRecSt (MkC ss) = rep2 recSName [ss] - --------------- Range (Arithmetic sequences) ----------- -repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFrom (MkC x) = rep2 fromEName [x] - -repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] - -repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] - -repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] - ------------- Match and Clause Tuples ----------- -repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ) -repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] - -repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ) -repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] - --------------- Dec ----------------------------- -repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) -repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] - -repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) -repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] - -repData :: Core TH.CxtQ -> Core TH.Name - -> Either (Core [TH.TyVarBndrQ]) - (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) - -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] - -> DsM (Core TH.DecQ) -repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) - = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] -repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) - (MkC derivs) - = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] - -repNewtype :: Core TH.CxtQ -> Core TH.Name - -> Either (Core [TH.TyVarBndrQ]) - (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) - -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ] - -> DsM (Core TH.DecQ) -repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) - (MkC derivs) - = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] -repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) - (MkC derivs) - = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] - -repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ] - -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repTySyn (MkC nm) (MkC tvs) (MkC rhs) - = rep2 tySynDName [nm, tvs, rhs] - -repInst :: Core (Maybe TH.Overlap) -> - Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) -repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName - [o, cxt, ty, ds] - -repDerivStrategy :: Maybe (LDerivStrategy GhcRn) - -> DsM (Core (Maybe TH.DerivStrategyQ)) -repDerivStrategy mds = - case mds of - Nothing -> nothing - Just ds -> - case unLoc ds of - StockStrategy -> just =<< repStockStrategy - AnyclassStrategy -> just =<< repAnyclassStrategy - NewtypeStrategy -> just =<< repNewtypeStrategy - ViaStrategy ty -> do ty' <- repLTy (hsSigType ty) - via_strat <- repViaStrategy ty' - just via_strat - where - nothing = coreNothing derivStrategyQTyConName - just = coreJust derivStrategyQTyConName - -repStockStrategy :: DsM (Core TH.DerivStrategyQ) -repStockStrategy = rep2 stockStrategyName [] - -repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ) -repAnyclassStrategy = rep2 anyclassStrategyName [] - -repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ) -repNewtypeStrategy = rep2 newtypeStrategyName [] - -repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ) -repViaStrategy (MkC t) = rep2 viaStrategyName [t] - -repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap)) -repOverlap mb = - case mb of - Nothing -> nothing - Just o -> - case o of - NoOverlap _ -> nothing - Overlappable _ -> just =<< dataCon overlappableDataConName - Overlapping _ -> just =<< dataCon overlappingDataConName - Overlaps _ -> just =<< dataCon overlapsDataConName - Incoherent _ -> just =<< dataCon incoherentDataConName - where - nothing = coreNothing overlapTyConName - just = coreJust overlapTyConName - - -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] - -> Core [TH.FunDep] -> Core [TH.DecQ] - -> DsM (Core TH.DecQ) -repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) - = rep2 classDName [cxt, cls, tvs, fds, ds] - -repDeriv :: Core (Maybe TH.DerivStrategyQ) - -> Core TH.CxtQ -> Core TH.TypeQ - -> DsM (Core TH.DecQ) -repDeriv (MkC ds) (MkC cxt) (MkC ty) - = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty] - -repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch - -> Core TH.Phases -> DsM (Core TH.DecQ) -repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) - = rep2 pragInlDName [nm, inline, rm, phases] - -repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases - -> DsM (Core TH.DecQ) -repPragSpec (MkC nm) (MkC ty) (MkC phases) - = rep2 pragSpecDName [nm, ty, phases] - -repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline - -> Core TH.Phases -> DsM (Core TH.DecQ) -repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) - = rep2 pragSpecInlDName [nm, ty, inline, phases] - -repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ) -repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] - -repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ) -repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] - -repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ]) - -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ - -> Core TH.Phases -> DsM (Core TH.DecQ) -repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) - = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases] - -repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ) -repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] - -repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ) -repTySynInst (MkC eqn) - = rep2 tySynInstDName [eqn] - -repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ] - -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ) -repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) - = rep2 dataFamilyDName [nm, tvs, kind] - -repOpenFamilyD :: Core TH.Name - -> Core [TH.TyVarBndrQ] - -> Core TH.FamilyResultSigQ - -> Core (Maybe TH.InjectivityAnn) - -> DsM (Core TH.DecQ) -repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) - = rep2 openTypeFamilyDName [nm, tvs, result, inj] - -repClosedFamilyD :: Core TH.Name - -> Core [TH.TyVarBndrQ] - -> Core TH.FamilyResultSigQ - -> Core (Maybe TH.InjectivityAnn) - -> Core [TH.TySynEqnQ] - -> DsM (Core TH.DecQ) -repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) - = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] - -repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) -> - Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) -repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) - = rep2 tySynEqnName [mb_bndrs, lhs, rhs] - -repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ) -repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] - -repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) -repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] - -repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] - -repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ) -repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] - -repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) -repCtxt (MkC tys) = rep2 cxtName [tys] - -repDataCon :: Located Name - -> HsConDeclDetails GhcRn - -> DsM (Core TH.ConQ) -repDataCon con details - = do con' <- lookupLOcc con -- See Note [Binders and occurrences] - repConstr details Nothing [con'] - -repGadtDataCons :: [Located Name] - -> HsConDeclDetails GhcRn - -> LHsType GhcRn - -> DsM (Core TH.ConQ) -repGadtDataCons cons details res_ty - = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] - repConstr details (Just res_ty) cons' - --- Invariant: --- * for plain H98 data constructors second argument is Nothing and third --- argument is a singleton list --- * for GADTs data constructors second argument is (Just return_type) and --- third argument is a non-empty list -repConstr :: HsConDeclDetails GhcRn - -> Maybe (LHsType GhcRn) - -> [Core TH.Name] - -> DsM (Core TH.ConQ) -repConstr (PrefixCon ps) Nothing [con] - = do arg_tys <- repList bangTypeQTyConName repBangTy ps - rep2 normalCName [unC con, unC arg_tys] - -repConstr (PrefixCon ps) (Just res_ty) cons - = do arg_tys <- repList bangTypeQTyConName repBangTy ps - res_ty' <- repLTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] - -repConstr (RecCon ips) resTy cons - = do args <- concatMapM rep_ip (unLoc ips) - arg_vtys <- coreList varBangTypeQTyConName args - case resTy of - Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] - Just res_ty -> do - res_ty' <- repLTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, - unC res_ty'] - - where - rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) - - rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) - rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) - ; MkC ty <- repBangTy t - ; rep2 varBangTypeName [v,ty] } - -repConstr (InfixCon st1 st2) Nothing [con] - = do arg1 <- repBangTy st1 - arg2 <- repBangTy st2 - rep2 infixCName [unC arg1, unC con, unC arg2] - -repConstr (InfixCon {}) (Just _) _ = - panic "repConstr: infix GADT constructor should be in a PrefixCon" -repConstr _ _ _ = - panic "repConstr: invariant violated" - ------------- Types ------------------- - -repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ - -> DsM (Core TH.TypeQ) -repTForall (MkC tvars) (MkC ctxt) (MkC ty) - = rep2 forallTName [tvars, ctxt, ty] - -repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ - -> DsM (Core TH.TypeQ) -repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] - -repTvar :: Core TH.Name -> DsM (Core TH.TypeQ) -repTvar (MkC s) = rep2 varTName [s] - -repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) -repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] - -repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) -repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki] - -repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) -repTapps f [] = return f -repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } - -repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) -repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] - -repTequality :: DsM (Core TH.TypeQ) -repTequality = rep2 equalityTName [] - -repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ) -repTPromotedList [] = repPromotedNilTyCon -repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon - ; f <- repTapp tcon t - ; t' <- repTPromotedList ts - ; repTapp f t' - } - -repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ) -repTLit (MkC lit) = rep2 litTName [lit] - -repTWildCard :: DsM (Core TH.TypeQ) -repTWildCard = rep2 wildCardTName [] - -repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ) -repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e] - -repTStar :: DsM (Core TH.TypeQ) -repTStar = rep2 starKName [] - -repTConstraint :: DsM (Core TH.TypeQ) -repTConstraint = rep2 constraintKName [] - ---------- Type constructors -------------- - -repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) -repNamedTyCon (MkC s) = rep2 conTName [s] - -repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ - -> DsM (Core TH.TypeQ) -repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] - -repTupleTyCon :: Int -> DsM (Core TH.TypeQ) --- Note: not Core Int; it's easier to be direct here -repTupleTyCon i = do dflags <- getDynFlags - rep2 tupleTName [mkIntExprInt dflags i] - -repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) --- Note: not Core Int; it's easier to be direct here -repUnboxedTupleTyCon i = do dflags <- getDynFlags - rep2 unboxedTupleTName [mkIntExprInt dflags i] - -repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ) --- Note: not Core TH.SumArity; it's easier to be direct here -repUnboxedSumTyCon arity = do dflags <- getDynFlags - rep2 unboxedSumTName [mkIntExprInt dflags arity] - -repArrowTyCon :: DsM (Core TH.TypeQ) -repArrowTyCon = rep2 arrowTName [] - -repListTyCon :: DsM (Core TH.TypeQ) -repListTyCon = rep2 listTName [] - -repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ) -repPromotedDataCon (MkC s) = rep2 promotedTName [s] - -repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) -repPromotedTupleTyCon i = do dflags <- getDynFlags - rep2 promotedTupleTName [mkIntExprInt dflags i] - -repPromotedNilTyCon :: DsM (Core TH.TypeQ) -repPromotedNilTyCon = rep2 promotedNilTName [] - -repPromotedConsTyCon :: DsM (Core TH.TypeQ) -repPromotedConsTyCon = rep2 promotedConsTName [] - ------------- TyVarBndrs ------------------- - -repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ) -repPlainTV (MkC nm) = rep2 plainTVName [nm] - -repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ) -repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] - ----------------------------------------------------------- --- Type family result signature - -repNoSig :: DsM (Core TH.FamilyResultSigQ) -repNoSig = rep2 noSigName [] - -repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ) -repKindSig (MkC ki) = rep2 kindSigName [ki] - -repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ) -repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] - ----------------------------------------------------------- --- Literals - -repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit) -repLiteral (HsStringPrim _ bs) - = do dflags <- getDynFlags - word8_ty <- lookupType word8TyConName - let w8s = unpack bs - w8s_expr = map (\w8 -> mkCoreConApps word8DataCon - [mkWordLit dflags (toInteger w8)]) w8s - rep2 stringPrimLName [mkListExpr word8_ty w8s_expr] -repLiteral lit - = do lit' <- case lit of - HsIntPrim _ i -> mk_integer i - HsWordPrim _ w -> mk_integer w - HsInt _ i -> mk_integer (il_value i) - HsFloatPrim _ r -> mk_rational r - HsDoublePrim _ r -> mk_rational r - HsCharPrim _ c -> mk_char c - _ -> return lit - lit_expr <- dsLit lit' - case mb_lit_name of - Just lit_name -> rep2 lit_name [lit_expr] - Nothing -> notHandled "Exotic literal" (ppr lit) - where - mb_lit_name = case lit of - HsInteger _ _ _ -> Just integerLName - HsInt _ _ -> Just integerLName - HsIntPrim _ _ -> Just intPrimLName - HsWordPrim _ _ -> Just wordPrimLName - HsFloatPrim _ _ -> Just floatPrimLName - HsDoublePrim _ _ -> Just doublePrimLName - HsChar _ _ -> Just charLName - HsCharPrim _ _ -> Just charPrimLName - HsString _ _ -> Just stringLName - HsRat _ _ _ -> Just rationalLName - _ -> Nothing - -mk_integer :: Integer -> DsM (HsLit GhcRn) -mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger NoSourceText i integer_ty - -mk_rational :: FractionalLit -> DsM (HsLit GhcRn) -mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat noExtField r rat_ty -mk_string :: FastString -> DsM (HsLit GhcRn) -mk_string s = return $ HsString NoSourceText s - -mk_char :: Char -> DsM (HsLit GhcRn) -mk_char c = return $ HsChar NoSourceText c - -repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit) -repOverloadedLiteral (OverLit { ol_val = val}) - = do { lit <- mk_lit val; repLiteral lit } - -- The type Rational will be in the environment, because - -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, - -- and rationalL is sucked in when any TH stuff is used -repOverloadedLiteral (XOverLit nec) = noExtCon nec - -mk_lit :: OverLitVal -> DsM (HsLit GhcRn) -mk_lit (HsIntegral i) = mk_integer (il_value i) -mk_lit (HsFractional f) = mk_rational f -mk_lit (HsIsString _ s) = mk_string s - -repNameS :: Core String -> DsM (Core TH.Name) -repNameS (MkC name) = rep2 mkNameSName [name] - ---------------- Miscellaneous ------------------- - -repGensym :: Core String -> DsM (Core (TH.Q TH.Name)) -repGensym (MkC lit_str) = rep2 newNameName [lit_str] - -repBindQ :: Type -> Type -- a and b - -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b)) -repBindQ ty_a ty_b (MkC x) (MkC y) - = rep2 bindQName [Type ty_a, Type ty_b, x, y] - -repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a])) -repSequenceQ ty_a (MkC list) - = rep2 sequenceQName [Type ty_a, list] - -repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ) -repUnboundVar (MkC name) = rep2 unboundVarEName [name] - -repOverLabel :: FastString -> DsM (Core TH.ExpQ) -repOverLabel fs = do - (MkC s) <- coreStringLit $ unpackFS fs - rep2 labelEName [s] - - ------------- Lists ------------------- --- turn a list of patterns into a single pattern matching a list - -repList :: Name -> (a -> DsM (Core b)) - -> [a] -> DsM (Core [b]) -repList tc_name f args - = do { args1 <- mapM f args - ; coreList tc_name args1 } - -coreList :: Name -- Of the TyCon of the element type - -> [Core a] -> DsM (Core [a]) -coreList tc_name es - = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } - -coreList' :: Type -- The element type - -> [Core a] -> Core [a] -coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) - -nonEmptyCoreList :: [Core a] -> Core [a] - -- The list must be non-empty so we can get the element type - -- Otherwise use coreList -nonEmptyCoreList [] = panic "coreList: empty argument" -nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) - -coreStringLit :: String -> DsM (Core String) -coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } - -------------------- Maybe ------------------ - -repMaybe :: Name -> (a -> DsM (Core b)) - -> Maybe a -> DsM (Core (Maybe b)) -repMaybe tc_name _ Nothing = coreNothing tc_name -repMaybe tc_name f (Just es) = coreJust tc_name =<< f es - --- | Construct Core expression for Nothing of a given type name -coreNothing :: Name -- ^ Name of the TyCon of the element type - -> DsM (Core (Maybe a)) -coreNothing tc_name = - do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } - --- | Construct Core expression for Nothing of a given type -coreNothing' :: Type -- ^ The element type - -> Core (Maybe a) -coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) - --- | Store given Core expression in a Just of a given type name -coreJust :: Name -- ^ Name of the TyCon of the element type - -> Core a -> DsM (Core (Maybe a)) -coreJust tc_name es - = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } - --- | Store given Core expression in a Just of a given type -coreJust' :: Type -- ^ The element type - -> Core a -> Core (Maybe a) -coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) - -------------------- Maybe Lists ------------------ - -repMaybeList :: Name -> (a -> DsM (Core b)) - -> Maybe [a] -> DsM (Core (Maybe [b])) -repMaybeList tc_name _ Nothing = coreNothingList tc_name -repMaybeList tc_name f (Just args) - = do { elt_ty <- lookupType tc_name - ; args1 <- mapM f args - ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) } - -coreNothingList :: Name -> DsM (Core (Maybe [a])) -coreNothingList tc_name - = do { elt_ty <- lookupType tc_name - ; return $ coreNothing' (mkListTy elt_ty) } - -coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a])) -coreJustList tc_name args - = do { elt_ty <- lookupType tc_name - ; return $ coreJust' (mkListTy elt_ty) args } - ------------- Literals & Variables ------------------- - -coreIntLit :: Int -> DsM (Core Int) -coreIntLit i = do dflags <- getDynFlags - return (MkC (mkIntExprInt dflags i)) - -coreIntegerLit :: Integer -> DsM (Core Integer) -coreIntegerLit i = fmap MkC (mkIntegerExpr i) - -coreVar :: Id -> Core TH.Name -- The Id has type Name -coreVar id = MkC (Var id) - ------------------ Failure ----------------------- -notHandledL :: SrcSpan -> String -> SDoc -> DsM a -notHandledL loc what doc - | isGoodSrcSpan loc - = putSrcSpanDs loc $ notHandled what doc - | otherwise - = notHandled what doc - -notHandled :: String -> SDoc -> DsM a -notHandled what doc = failWithDs msg - where - msg = hang (text what <+> text "not (yet) handled by Template Haskell") - 2 doc diff --git a/deSugar/DsMonad.hs b/deSugar/DsMonad.hs deleted file mode 100644 --- a/deSugar/DsMonad.hs +++ /dev/null @@ -1,598 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -@DsMonad@: monadery used in desugaring --} - -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan -{-# LANGUAGE ViewPatterns #-} - -module DsMonad ( - DsM, mapM, mapAndUnzipM, - initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs, - foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, - Applicative(..),(<$>), - - duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, - newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, - newFailLocalDs, newPredVarDs, - getSrcSpanDs, putSrcSpanDs, - mkPrintUnqualifiedDs, - newUnique, - UniqSupply, newUniqueSupply, - getGhcModeDs, dsGetFamInstEnvs, - dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, - dsLookupDataCon, dsLookupConLike, - - DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, - - -- Getting and setting pattern match oracle states - getPmDelta, updPmDelta, - - -- Get COMPLETE sets of a TyCon - dsGetCompleteMatches, - - -- Warnings and errors - DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, - failWithDs, failDs, discardWarningsDs, - askNoErrsDs, - - -- Data types - DsMatchContext(..), - EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, - CanItFail(..), orFail, - - -- Levity polymorphism - dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, - - -- Trace injection - pprRuntimeTrace - ) where - -import GhcPrelude - -import TcRnMonad -import FamInstEnv -import CoreSyn -import MkCore ( unitExpr ) -import CoreUtils ( exprType, isExprLevPoly ) -import GHC.Hs -import TcIface -import TcMType ( checkForLevPolyX, formatLevPolyErr ) -import PrelNames -import RdrName -import HscTypes -import Bag -import BasicTypes ( Origin ) -import DataCon -import ConLike -import TyCon -import GHC.HsToCore.PmCheck.Types -import Id -import Module -import Outputable -import SrcLoc -import Type -import UniqSupply -import Name -import NameEnv -import DynFlags -import ErrUtils -import FastString -import UniqFM ( lookupWithDefaultUFM ) -import Literal ( mkLitString ) -import CostCentreState - -import Data.IORef - -{- -************************************************************************ -* * - Data types for the desugarer -* * -************************************************************************ --} - -data DsMatchContext - = DsMatchContext (HsMatchContext Name) SrcSpan - deriving () - -instance Outputable DsMatchContext where - ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match - -data EquationInfo - = EqnInfo { eqn_pats :: [Pat GhcTc] - -- ^ The patterns for an equation - -- - -- NB: We have /already/ applied 'decideBangHood' to - -- these patterns. See Note [decideBangHood] in "DsUtils" - - , eqn_orig :: Origin - -- ^ Was this equation present in the user source? - -- - -- This helps us avoid warnings on patterns that GHC elaborated. - -- - -- For instance, the pattern @-1 :: Word@ gets desugared into - -- @W# -1## :: Word@, but we shouldn't warn about an overflowed - -- literal for /both/ of these cases. - - , eqn_rhs :: MatchResult - -- ^ What to do after match - } - -instance Outputable EquationInfo where - ppr (EqnInfo pats _ _) = ppr pats - -type DsWrapper = CoreExpr -> CoreExpr -idDsWrapper :: DsWrapper -idDsWrapper e = e - --- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult --- \fail. wrap (case vs of { pats -> rhs fail }) --- where vs are not bound by wrap - - --- A MatchResult is an expression with a hole in it -data MatchResult - = MatchResult - CanItFail -- Tells whether the failure expression is used - (CoreExpr -> DsM CoreExpr) - -- Takes a expression to plug in at the - -- failure point(s). The expression should - -- be duplicatable! - -data CanItFail = CanFail | CantFail - -orFail :: CanItFail -> CanItFail -> CanItFail -orFail CantFail CantFail = CantFail -orFail _ _ = CanFail - -{- -************************************************************************ -* * - Monad functions -* * -************************************************************************ --} - --- Compatibility functions -fixDs :: (a -> DsM a) -> DsM a -fixDs = fixM - -type DsWarning = (SrcSpan, SDoc) - -- Not quite the same as a WarnMsg, we have an SDoc here - -- and we'll do the print_unqual stuff later on to turn it - -- into a Doc. - --- | Run a 'DsM' action inside the 'TcM' monad. -initDsTc :: DsM a -> TcM a -initDsTc thing_inside - = do { tcg_env <- getGblEnv - ; msg_var <- getErrsVar - ; hsc_env <- getTopEnv - ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; setEnvs envs thing_inside - } - --- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a) -initDs hsc_env tcg_env thing_inside - = do { msg_var <- newIORef emptyMessages - ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; runDs hsc_env envs thing_inside - } - --- | Build a set of desugarer environments derived from a 'TcGblEnv'. -mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef Messages -> TcGblEnv - -> m (DsGblEnv, DsLclEnv) -mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - = do { cc_st_var <- liftIO $ newIORef newCostCentreState - ; let dflags = hsc_dflags hsc_env - this_mod = tcg_mod tcg_env - type_env = tcg_type_env tcg_env - rdr_env = tcg_rdr_env tcg_env - fam_inst_env = tcg_fam_inst_env tcg_env - complete_matches = hptCompleteSigs hsc_env - ++ tcg_complete_matches tcg_env - ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env - msg_var cc_st_var complete_matches - } - -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) -runDs hsc_env (ds_gbl, ds_lcl) thing_inside - = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl - (tryM thing_inside) - ; msgs <- readIORef (ds_msgs ds_gbl) - ; let final_res - | errorsFound dflags msgs = Nothing - | Right r <- res = Just r - | otherwise = panic "initDs" - ; return (msgs, final_res) - } - where dflags = hsc_dflags hsc_env - --- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) -initDsWithModGuts hsc_env guts thing_inside - = do { cc_st_var <- newIORef newCostCentreState - ; msg_var <- newIORef emptyMessages - ; let dflags = hsc_dflags hsc_env - type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) - rdr_env = mg_rdr_env guts - fam_inst_env = mg_fam_inst_env guts - this_mod = mg_module guts - complete_matches = hptCompleteSigs hsc_env - ++ mg_complete_sigs guts - - bindsToIds (NonRec v _) = [v] - bindsToIds (Rec binds) = map fst binds - ids = concatMap bindsToIds (mg_binds guts) - - envs = mkDsEnvs dflags this_mod rdr_env type_env - fam_inst_env msg_var cc_st_var - complete_matches - ; runDs hsc_env envs thing_inside - } - -initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a) --- Spin up a TcM context so that we can run the constraint solver --- Returns any error messages generated by the constraint solver --- and (Just res) if no error happened; Nothing if an error happened --- --- Simon says: I'm not very happy about this. We spin up a complete TcM monad --- only to immediately refine it to a TcS monad. --- Better perhaps to make TcS into its own monad, rather than building on TcS --- But that may in turn interact with plugins - -initTcDsForSolver thing_inside - = do { (gbl, lcl) <- getEnvs - ; hsc_env <- getTopEnv - - ; let DsGblEnv { ds_mod = mod - , ds_fam_inst_env = fam_inst_env } = gbl - - DsLclEnv { dsl_loc = loc } = lcl - - ; liftIO $ initTc hsc_env HsSrcFile False mod loc $ - updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $ - thing_inside } - -mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef CostCentreState -> [CompleteMatch] - -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var - complete_matches - = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", - if_rec_types = Just (mod, return type_env) } - if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) - False -- not boot! - real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) - completeMatchMap = mkCompleteMatchMap complete_matches - gbl_env = DsGblEnv { ds_mod = mod - , ds_fam_inst_env = fam_inst_env - , ds_if_env = (if_genv, if_lenv) - , ds_unqual = mkPrintUnqualified dflags rdr_env - , ds_msgs = msg_var - , ds_complete_matches = completeMatchMap - , ds_cc_st = cc_st_var - } - lcl_env = DsLclEnv { dsl_meta = emptyNameEnv - , dsl_loc = real_span - , dsl_delta = initDelta - } - in (gbl_env, lcl_env) - - -{- -************************************************************************ -* * - Operations in the monad -* * -************************************************************************ - -And all this mysterious stuff is so we can occasionally reach out and -grab one or more names. @newLocalDs@ isn't exported---exported -functions are defined with it. The difference in name-strings makes -it easier to read debugging output. - -Note [Levity polymorphism checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the "Levity Polymorphism" paper (PLDI '17), levity -polymorphism is forbidden in precisely two places: in the type of a bound -term-level argument and in the type of an argument to a function. The paper -explains it more fully, but briefly: expressions in these contexts need to be -stored in registers, and it's hard (read, impossible) to store something -that's levity polymorphic. - -We cannot check for bad levity polymorphism conveniently in the type checker, -because we can't tell, a priori, which levity metavariables will be solved. -At one point, I (Richard) thought we could check in the zonker, but it's hard -to know where precisely are the abstracted variables and the arguments. So -we check in the desugarer, the only place where we can see the Core code and -still report respectable syntax to the user. This covers the vast majority -of cases; see calls to DsMonad.dsNoLevPoly and friends. - -Levity polymorphism is also prohibited in the types of binders, and the -desugarer checks for this in GHC-generated Ids. (The zonker handles -the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. -The newSysLocalDs variant is used in the vast majority of cases where -the binder is obviously not levity polymorphic, omitting the check. -It would be nice to ASSERT that there is no levity polymorphism here, -but we can't, because of the fixM in DsArrows. It's all OK, though: -Core Lint will catch an error here. - -However, the desugarer is the wrong place for certain checks. In particular, -the desugarer can't report a sensible error message if an HsWrapper is malformed. -After all, GHC itself produced the HsWrapper. So we store some message text -in the appropriate HsWrappers (e.g. WpFun) that we can print out in the -desugarer. - -There are a few more checks in places where Core is generated outside the -desugarer. For example, in datatype and class declarations, where levity -polymorphism is checked for during validity checking. It would be nice to -have one central place for all this, but that doesn't seem possible while -still reporting nice error messages. - --} - --- Make a new Id with the same print name, but different type, and new unique -newUniqueId :: Id -> Type -> DsM Id -newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) - -duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local - = do { uniq <- newUnique - ; return (setIdUnique old_local uniq) } - -newPredVarDs :: PredType -> DsM Var -newPredVarDs pred - = newSysLocalDs pred - -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDsNoLP = mk_local (fsLit "ds") - --- this variant should be used when the caller can be sure that the variable type --- is not levity-polymorphic. It is necessary when the type is knot-tied because --- of the fixM used in DsArrows. See Note [Levity polymorphism checking] -newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") -newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail") - -- the fail variable is used only in a situation where we can tell that - -- levity-polymorphism is impossible. - -newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id] -newSysLocalsDsNoLP = mapM newSysLocalDsNoLP -newSysLocalsDs = mapM newSysLocalDs - -mk_local :: FastString -> Type -> DsM Id -mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> - ppr ty) -- could improve the msg with another - -- parameter indicating context - ; mkSysLocalOrCoVarM fs ty } - -{- -We can also reach out and either set/grab location information from -the @SrcSpan@ being carried around. --} - -getGhcModeDs :: DsM GhcMode -getGhcModeDs = getDynFlags >>= return . ghcMode - --- | Get the current pattern match oracle state. See 'dsl_delta'. -getPmDelta :: DsM Delta -getPmDelta = do { env <- getLclEnv; return (dsl_delta env) } - --- | Set the pattern match oracle state within the scope of the given action. --- See 'dsl_delta'. -updPmDelta :: Delta -> DsM a -> DsM a -updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta }) - -getSrcSpanDs :: DsM SrcSpan -getSrcSpanDs = do { env <- getLclEnv - ; return (RealSrcSpan (dsl_loc env)) } - -putSrcSpanDs :: SrcSpan -> DsM a -> DsM a -putSrcSpanDs (UnhelpfulSpan {}) thing_inside - = thing_inside -putSrcSpanDs (RealSrcSpan real_span) thing_inside - = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside - --- | Emit a warning for the current source location --- NB: Warns whether or not -Wxyz is set -warnDs :: WarnReason -> SDoc -> DsM () -warnDs reason warn - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = makeIntoWarning reason $ - mkWarnMsg dflags loc (ds_unqual env) warn - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } - --- | Emit a warning only if the correct WarnReason is set in the DynFlags -warnIfSetDs :: WarningFlag -> SDoc -> DsM () -warnIfSetDs flag warn - = whenWOptM flag $ - warnDs (Reason flag) warn - -errDs :: SDoc -> DsM () -errDs err - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = mkErrMsg dflags loc (ds_unqual env) err - ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } - --- | Issue an error, but return the expression for (), so that we can continue --- reporting errors. -errDsCoreExpr :: SDoc -> DsM CoreExpr -errDsCoreExpr err - = do { errDs err - ; return unitExpr } - -failWithDs :: SDoc -> DsM a -failWithDs err - = do { errDs err - ; failM } - -failDs :: DsM a -failDs = failM - --- (askNoErrsDs m) runs m --- If m fails, --- then (askNoErrsDs m) fails --- If m succeeds with result r, --- then (askNoErrsDs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- Regardless of success or failure, --- propagate any errors/warnings generated by m --- --- c.f. TcRnMonad.askNoErrs -askNoErrsDs :: DsM a -> DsM (a, Bool) -askNoErrsDs thing_inside - = do { errs_var <- newMutVar emptyMessages - ; env <- getGblEnv - ; mb_res <- tryM $ -- Be careful to catch exceptions - -- so that we propagate errors correctly - -- (#13642) - setGblEnv (env { ds_msgs = errs_var }) $ - thing_inside - - -- Propagate errors - ; msgs@(warns, errs) <- readMutVar errs_var - ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) - - -- And return - ; case mb_res of - Left _ -> failM - Right res -> do { dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs - ; return (res, not errs_found) } } - -mkPrintUnqualifiedDs :: DsM PrintUnqualified -mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv - -instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where - lookupThing = dsLookupGlobal - -dsLookupGlobal :: Name -> DsM TyThing --- Very like TcEnv.tcLookupGlobal -dsLookupGlobal name - = do { env <- getGblEnv - ; setEnvs (ds_if_env env) - (tcIfaceGlobal name) } - -dsLookupGlobalId :: Name -> DsM Id -dsLookupGlobalId name - = tyThingId <$> dsLookupGlobal name - -dsLookupTyCon :: Name -> DsM TyCon -dsLookupTyCon name - = tyThingTyCon <$> dsLookupGlobal name - -dsLookupDataCon :: Name -> DsM DataCon -dsLookupDataCon name - = tyThingDataCon <$> dsLookupGlobal name - -dsLookupConLike :: Name -> DsM ConLike -dsLookupConLike name - = tyThingConLike <$> dsLookupGlobal name - - -dsGetFamInstEnvs :: DsM FamInstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -dsGetFamInstEnvs - = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, ds_fam_inst_env env) } - -dsGetMetaEnv :: DsM (NameEnv DsMetaVal) -dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } - --- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`. -dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch] -dsGetCompleteMatches tc = do - eps <- getEps - env <- getGblEnv - let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc - eps_matches_list = lookup_completes $ eps_complete_matches eps - env_matches_list = lookup_completes $ ds_complete_matches env - return $ eps_matches_list ++ env_matches_list - -dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) -dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } - -dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a -dsExtendMetaEnv menv thing_inside - = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside - -discardWarningsDs :: DsM a -> DsM a --- Ignore warnings inside the thing inside; --- used to ignore inaccessable cases etc. inside generated code -discardWarningsDs thing_inside - = do { env <- getGblEnv - ; old_msgs <- readTcRef (ds_msgs env) - - ; result <- thing_inside - - -- Revert messages to old_msgs - ; writeTcRef (ds_msgs env) old_msgs - - ; return result } - --- | Fail with an error message if the type is levity polymorphic. -dsNoLevPoly :: Type -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty - --- | Check an expression for levity polymorphism, failing if it is --- levity polymorphic. -dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () --- See Note [Levity polymorphism checking] -dsNoLevPolyExpr e doc - | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) - | otherwise = return () - --- | Runs the thing_inside. If there are no errors, then returns the expr --- given. Otherwise, returns unitExpr. This is useful for doing a bunch --- of levity polymorphism checks and then avoiding making a core App. --- (If we make a core App on a levity polymorphic argument, detecting how --- to handle the let/app invariant might call isUnliftedType, which panics --- on a levity polymorphic type.) --- See #12709 for an example of why this machinery is necessary. -dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr -dsWhenNoErrs thing_inside mk_expr - = do { (result, no_errs) <- askNoErrsDs thing_inside - ; return $ if no_errs - then mk_expr result - else unitExpr } - --- | Inject a trace message into the compiled program. Whereas --- pprTrace prints out information *while compiling*, pprRuntimeTrace --- captures that information and causes it to be printed *at runtime* --- using Debug.Trace.trace. --- --- pprRuntimeTrace hdr doc expr --- --- will produce an expression that looks like --- --- trace (hdr + doc) expr --- --- When using this to debug a module that Debug.Trace depends on, --- it is necessary to import {-# SOURCE #-} Debug.Trace () in that --- module. We could avoid this inconvenience by wiring in Debug.Trace.trace, --- but that doesn't seem worth the effort and maintenance cost. -pprRuntimeTrace :: String -- ^ header - -> SDoc -- ^ information to output - -> CoreExpr -- ^ expression - -> DsM CoreExpr -pprRuntimeTrace str doc expr = do - traceId <- dsLookupGlobalId traceName - unpackCStringId <- dsLookupGlobalId unpackCStringName - dflags <- getDynFlags - let message :: CoreExpr - message = App (Var unpackCStringId) $ - Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) - return $ mkApps (Var traceId) [Type (exprType expr), message, expr] diff --git a/deSugar/DsUsage.hs b/deSugar/DsUsage.hs deleted file mode 100644 --- a/deSugar/DsUsage.hs +++ /dev/null @@ -1,373 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -module DsUsage ( - -- * Dependency/fingerprinting code (used by MkIface) - mkUsageInfo, mkUsedNames, mkDependencies - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import HscTypes -import TcRnTypes -import Name -import NameSet -import Module -import Outputable -import Util -import UniqSet -import UniqFM -import Fingerprint -import Maybes -import Packages -import Finder - -import Control.Monad (filterM) -import Data.List -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set -import System.Directory -import System.FilePath - -{- Note [Module self-dependency] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -RnNames.calculateAvails asserts the invariant that a module must not occur in -its own dep_orphs or dep_finsts. However, if we aren't careful this can occur -in the presence of hs-boot files: Consider that we have two modules, A and B, -both with hs-boot files, - - A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A - A.hs-boot declares an orphan instance A.hs defines the orphan instance - -In this case, B's dep_orphs will contain A due to its SOURCE import of A. -Consequently, A will contain itself in its imp_orphs due to its import of B. -This fact would end up being recorded in A's interface file. This would then -break the invariant asserted by calculateAvails that a module does not itself in -its dep_orphs. This was the cause of #14128. - --} - --- | Extract information from the rename and typecheck phases to produce --- a dependencies information for the module being compiled. --- --- The first argument is additional dependencies from plugins -mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies -mkDependencies iuid pluginModules - (TcGblEnv{ tcg_mod = mod, - tcg_imports = imports, - tcg_th_used = th_var - }) - = do - -- Template Haskell used? - let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] - plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms) - th_used <- readIORef th_var - let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports) - (moduleName mod)) - -- M.hi-boot can be in the imp_dep_mods, but we must remove - -- it before recording the modules on which this one depends! - -- (We want to retain M.hi-boot in imp_dep_mods so that - -- loadHiBootInterface can see if M's direct imports depend - -- on M.hi-boot, and hence that we should do the hi-boot consistency - -- check.) - - dep_orphs = filter (/= mod) (imp_orphs imports) - -- We must also remove self-references from imp_orphs. See - -- Note [Module self-dependency] - - raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs - - pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs - | otherwise = raw_pkgs - - -- Set the packages required to be Safe according to Safe Haskell. - -- See Note [RnNames . Tracking Trust Transitively] - sorted_pkgs = sort (Set.toList pkgs) - trust_pkgs = imp_trust_pkgs imports - dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs - - return Deps { dep_mods = dep_mods, - dep_pkgs = dep_pkgs', - dep_orphs = dep_orphs, - dep_plgins = dep_plgins, - dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } - -- sort to get into canonical order - -- NB. remember to use lexicographic ordering - -mkUsedNames :: TcGblEnv -> NameSet -mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus - -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] - -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged - pluginModules - = do - eps <- hscEPS hsc_env - hashes <- mapM getFileHash dependent_files - plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules - let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod - dir_imp_mods used_names - usages = mod_usages ++ [ UsageFile { usg_file_path = f - , usg_file_hash = hash } - | (f, hash) <- zip dependent_files hashes ] - ++ [ UsageMergedRequirement - { usg_mod = mod, - usg_mod_hash = hash - } - | (mod, hash) <- merged ] - ++ concat plugin_usages - usages `seqList` return usages - -- seq the list of Usages returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. - -{- Note [Plugin dependencies] -Modules for which plugins were used in the compilation process, should be -recompiled whenever one of those plugins changes. But how do we know if a -plugin changed from the previous time a module was compiled? - -We could try storing the fingerprints of the interface files of plugins in -the interface file of the module. And see if there are changes between -compilation runs. However, this is pretty much a non-option because interface -fingerprints of plugin modules are fairly stable, unless you compile plugins -with optimisations turned on, and give basically all binders an INLINE pragma. - -So instead: - - * For plugins that were built locally: we store the filepath and hash of the - object files of the module with the `plugin` binder, and the object files of - modules that are dependencies of the plugin module and belong to the same - `UnitId` as the plugin - * For plugins in an external package: we store the filepath and hash of - the dynamic library containing the plugin module. - -During recompilation we then compare the hashes of those files again to see -if anything has changed. - -One issue with this approach is that object files are currently (GHC 8.6.1) -not created fully deterministicly, which could sometimes induce accidental -recompilation of a module for which plugins were used in the compile process. - -One way to improve this is to either: - - * Have deterministic object file creation - * Create and store implementation hashes, which would be based on the Core - of the module and the implementation hashes of its dependencies, and then - compare implementation hashes for recompilation. Creation of implementation - hashes is however potentially expensive. --} -mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] -mkPluginUsage hsc_env pluginModule - = case lookupPluginModuleWithSuggestions dflags pNm Nothing of - LookupFound _ pkg -> do - -- The plugin is from an external package: - -- search for the library files containing the plugin. - let searchPaths = collectLibraryPaths dflags [pkg] - useDyn = WayDyn `elem` ways dflags - suffix = if useDyn then soExt platform else "a" - libLocs = [ searchPath "lib" ++ libLoc <.> suffix - | searchPath <- searchPaths - , libLoc <- packageHsLibs dflags pkg - ] - -- we also try to find plugin library files by adding WayDyn way, - -- if it isn't already present (see trac #15492) - paths = - if useDyn - then libLocs - else - let dflags' = updateWays (addWay' WayDyn dflags) - dlibLocs = [ searchPath mkHsSOName platform dlibLoc - | searchPath <- searchPaths - , dlibLoc <- packageHsLibs dflags' pkg - ] - in libLocs ++ dlibLocs - files <- filterM doesFileExist paths - case files of - [] -> - pprPanic - ( "mkPluginUsage: missing plugin library, tried:\n" - ++ unlines paths - ) - (ppr pNm) - _ -> mapM hashFile (nub files) - _ -> do - foundM <- findPluginModule hsc_env pNm - case foundM of - -- The plugin was built locally: look up the object file containing - -- the `plugin` binder, and all object files belong to modules that are - -- transitive dependencies of the plugin that belong to the same package. - Found ml _ -> do - pluginObject <- hashFile (ml_obj_file ml) - depObjects <- catMaybes <$> mapM lookupObjectFile deps - return (nub (pluginObject : depObjects)) - _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm) - where - dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - pNm = moduleName (mi_module pluginModule) - pPkg = moduleUnitId (mi_module pluginModule) - deps = map fst (dep_mods (mi_deps pluginModule)) - - -- Lookup object file for a plugin dependency, - -- from the same package as the plugin. - lookupObjectFile nm = do - foundM <- findImportedModule hsc_env nm Nothing - case foundM of - Found ml m - | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml) - | otherwise -> return Nothing - _ -> pprPanic "mkPluginUsage: no object for dependency" - (ppr pNm <+> ppr nm) - - hashFile f = do - fExist <- doesFileExist f - if fExist - then do - h <- getFileHash f - return (UsageFile f h) - else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f) - -mk_mod_usage_info :: PackageIfaceTable - -> HscEnv - -> Module - -> ImportedMods - -> NameSet - -> [Usage] -mk_mod_usage_info pit hsc_env this_mod direct_imports used_names - = mapMaybe mkUsage usage_mods - where - hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - - used_mods = moduleEnvKeys ent_map - dir_imp_mods = moduleEnvKeys direct_imports - all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods - usage_mods = sortBy stableModuleCmp all_mods - -- canonical order is imported, to avoid interface-file - -- wobblage. - - -- ent_map groups together all the things imported and used - -- from a particular module - ent_map :: ModuleEnv [OccName] - ent_map = nonDetFoldUniqSet add_mv emptyModuleEnv used_names - -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName - -- in ent_hashs - where - add_mv name mv_map - | isWiredInName name = mv_map -- ignore wired-in names - | otherwise - = case nameModule_maybe name of - Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map - -- See Note [Internal used_names] - - Just mod -> - -- See Note [Identity versus semantic module] - let mod' = if isHoleModule mod - then mkModule this_pkg (moduleName mod) - else mod - -- This lambda function is really just a - -- specialised (++); originally came about to - -- avoid quadratic behaviour (trac #2680) - in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] - where occ = nameOccName name - - -- We want to create a Usage for a home module if - -- a) we used something from it; has something in used_names - -- b) we imported it, even if we used nothing from it - -- (need to recompile if its export list changes: export_fprint) - mkUsage :: Module -> Maybe Usage - mkUsage mod - | isNothing maybe_iface -- We can't depend on it if we didn't - -- load its interface. - || mod == this_mod -- We don't care about usages of - -- things in *this* module - = Nothing - - | moduleUnitId mod /= this_pkg - = Just UsagePackageModule{ usg_mod = mod, - usg_mod_hash = mod_hash, - usg_safe = imp_safe } - -- for package modules, we record the module hash only - - | (null used_occs - && isNothing export_hash - && not is_direct_import - && not finsts_mod) - = Nothing -- Record no usage info - -- for directly-imported modules, we always want to record a usage - -- on the orphan hash. This is what triggers a recompilation if - -- an orphan is added or removed somewhere below us in the future. - - | otherwise - = Just UsageHomeModule { - usg_mod_name = moduleName mod, - usg_mod_hash = mod_hash, - usg_exports = export_hash, - usg_entities = Map.toList ent_hashs, - usg_safe = imp_safe } - where - maybe_iface = lookupIfaceByModule hpt pit mod - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - Just iface = maybe_iface - finsts_mod = mi_finsts (mi_final_exts iface) - hash_env = mi_hash_fn (mi_final_exts iface) - mod_hash = mi_mod_hash (mi_final_exts iface) - export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface)) - | otherwise = Nothing - - by_is_safe (ImportedByUser imv) = imv_is_safe imv - by_is_safe _ = False - (is_direct_import, imp_safe) - = case lookupModuleEnv direct_imports mod of - -- ezyang: I'm not sure if any is the correct - -- metric here. If safety was guaranteed to be uniform - -- across all imports, why did the old code only look - -- at the first import? - Just bys -> (True, any by_is_safe bys) - Nothing -> (False, safeImplicitImpsReq dflags) - -- Nothing case is for references to entities which were - -- not directly imported (NB: the "implicit" Prelude import - -- counts as directly imported! An entity is not directly - -- imported if, e.g., we got a reference to it from a - -- reexport of another module.) - - used_occs = lookupModuleEnv ent_map mod `orElse` [] - - -- Making a Map here ensures that (a) we remove duplicates - -- when we have usages on several subordinates of a single parent, - -- and (b) that the usages emerge in a canonical order, which - -- is why we use Map rather than OccEnv: Map works - -- using Ord on the OccNames, which is a lexicographic ordering. - ent_hashs :: Map OccName Fingerprint - ent_hashs = Map.fromList (map lookup_occ used_occs) - - lookup_occ occ = - case hash_env occ of - Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) - Just r -> r - - depend_on_exports = is_direct_import - {- True - Even if we used 'import M ()', we have to register a - usage on the export list because we are sensitive to - changes in orphan instances/rules. - False - In GHC 6.8.x we always returned true, and in - fact it recorded a dependency on *all* the - modules underneath in the dependency tree. This - happens to make orphans work right, but is too - expensive: it'll read too many interface files. - The 'isNothing maybe_iface' check above saved us - from generating many of these usages (at least in - one-shot mode), but that's even more bogus! - -} diff --git a/deSugar/DsUtils.hs b/deSugar/DsUtils.hs deleted file mode 100644 --- a/deSugar/DsUtils.hs +++ /dev/null @@ -1,1003 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utilities for desugaring - -This module exports some utility functions of no great interest. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | Utility functions for constructing Core syntax, principally for desugaring -module DsUtils ( - EquationInfo(..), - firstPat, shiftEqns, - - MatchResult(..), CanItFail(..), CaseAlt(..), - cantFailMatchResult, alwaysFailMatchResult, - extractMatchResult, combineMatchResults, - adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, - matchCanFail, mkEvalMatchResult, - mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, - wrapBind, wrapBinds, - - mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - - seqVar, - - -- LHs tuples - mkLHsPatTup, mkVanillaTuplePat, - mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, - - mkSelectorBinds, - - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang, - isTrueLHsExpr - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Match ( matchSimply ) -import {-# SOURCE #-} DsExpr ( dsLExpr ) - -import GHC.Hs -import TcHsSyn -import TcType( tcSplitTyConApp ) -import CoreSyn -import DsMonad - -import CoreUtils -import MkCore -import MkId -import Id -import Literal -import TyCon -import DataCon -import PatSyn -import Type -import Coercion -import TysPrim -import TysWiredIn -import BasicTypes -import ConLike -import UniqSet -import UniqSupply -import Module -import PrelNames -import Name( isInternalName ) -import Outputable -import SrcLoc -import Util -import DynFlags -import FastString -import qualified GHC.LanguageExtensions as LangExt - -import TcEvidence - -import Control.Monad ( zipWithM ) - -{- -************************************************************************ -* * -\subsection{ Selecting match variables} -* * -************************************************************************ - -We're about to match against some patterns. We want to make some -@Ids@ to use as match variables. If a pattern has an @Id@ readily at -hand, which should indeed be bound to the pattern as a whole, then use it; -otherwise, make one up. --} - -selectSimpleMatchVarL :: LPat GhcTc -> DsM Id --- Postcondition: the returned Id has an Internal Name -selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) - --- (selectMatchVars ps tys) chooses variables of type tys --- to use for matching ps against. If the pattern is a variable, --- we try to use that, to save inventing lots of fresh variables. --- --- OLD, but interesting note: --- But even if it is a variable, its type might not match. Consider --- data T a where --- T1 :: Int -> T Int --- T2 :: a -> T a --- --- f :: T a -> a -> Int --- f (T1 i) (x::Int) = x --- f (T2 i) (y::a) = 0 --- Then we must not choose (x::Int) as the matching variable! --- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat - -selectMatchVars :: [Pat GhcTc] -> DsM [Id] --- Postcondition: the returned Ids have Internal Names -selectMatchVars ps = mapM selectMatchVar ps - -selectMatchVar :: Pat GhcTc -> DsM Id --- Postcondition: the returned Id has an Internal Name -selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat _ var) = return (localiseId (unLoc var)) - -- Note [Localise pattern binders] -selectMatchVar (AsPat _ var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) - -- OK, better make up one... - -{- Note [Localise pattern binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider module M where - [Just a] = e -After renaming it looks like - module M where - [Just M.a] = e - -We don't generalise, since it's a pattern binding, monomorphic, etc, -so after desugaring we may get something like - M.a = case e of (v:_) -> - case v of Just M.a -> M.a -Notice the "M.a" in the pattern; after all, it was in the original -pattern. However, after optimisation those pattern binders can become -let-binders, and then end up floated to top level. They have a -different *unique* by then (the simplifier is good about maintaining -proper scoping), but it's BAD to have two top-level bindings with the -External Name M.a, because that turns into two linker symbols for M.a. -It's quite rare for this to actually *happen* -- the only case I know -of is tc003 compiled with the 'hpc' way -- but that only makes it -all the more annoying. - -To avoid this, we craftily call 'localiseId' in the desugarer, which -simply turns the External Name for the Id into an Internal one, but -doesn't change the unique. So the desugarer produces this: - M.a{r8} = case e of (v:_) -> - case v of Just a{r8} -> M.a{r8} -The unique is still 'r8', but the binding site in the pattern -is now an Internal Name. Now the simplifier's usual mechanisms -will propagate that Name to all the occurrence sites, as well as -un-shadowing it, so we'll get - M.a{r8} = case e of (v:_) -> - case v of Just a{s77} -> a{s77} -In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr -runs on the output of the desugarer, so all is well by the end of -the desugaring pass. - -See also Note [MatchIds] in Match.hs - -************************************************************************ -* * -* type synonym EquationInfo and access functions for its pieces * -* * -************************************************************************ -\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} - -The ``equation info'' used by @match@ is relatively complicated and -worthy of a type synonym and a few handy functions. --} - -firstPat :: EquationInfo -> Pat GhcTc -firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) - -shiftEqns :: [EquationInfo] -> [EquationInfo] --- Drop the first pattern in each equation -shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ] - --- Functions on MatchResults - -matchCanFail :: MatchResult -> Bool -matchCanFail (MatchResult CanFail _) = True -matchCanFail (MatchResult CantFail _) = False - -alwaysFailMatchResult :: MatchResult -alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) - -cantFailMatchResult :: CoreExpr -> MatchResult -cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) - -extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr -extractMatchResult (MatchResult CantFail match_fn) _ - = match_fn (error "It can't fail!") - -extractMatchResult (MatchResult CanFail match_fn) fail_expr = do - (fail_bind, if_it_fails) <- mkFailurePair fail_expr - body <- match_fn if_it_fails - return (mkCoreLet fail_bind body) - - -combineMatchResults :: MatchResult -> MatchResult -> MatchResult -combineMatchResults (MatchResult CanFail body_fn1) - (MatchResult can_it_fail2 body_fn2) - = MatchResult can_it_fail2 body_fn - where - body_fn fail = do body2 <- body_fn2 fail - (fail_bind, duplicatable_expr) <- mkFailurePair body2 - body1 <- body_fn1 duplicatable_expr - return (Let fail_bind body1) - -combineMatchResults match_result1@(MatchResult CantFail _) _ - = match_result1 - -adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult -adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) - -adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult -adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) - -wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr -wrapBinds [] e = e -wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) - -wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body -- NB: this function must deal with term - | new==old = body -- variables, type variables or coercion variables - | otherwise = Let (NonRec new (varToCoreExpr old)) body - -seqVar :: Var -> CoreExpr -> CoreExpr -seqVar var body = mkDefaultCase (Var var) var body - -mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult -mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) - --- (mkViewMatchResult var' viewExpr mr) makes the expression --- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult -mkViewMatchResult var' viewExpr = - adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) - -mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult -mkEvalMatchResult var ty - = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) - -mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult -mkGuardedMatchResult pred_expr (MatchResult _ body_fn) - = MatchResult CanFail (\fail -> do body <- body_fn fail - return (mkIfThenElse pred_expr body fail)) - -mkCoPrimCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of the case - -> [(Literal, MatchResult)] -- Alternatives - -> MatchResult -- Literals are all unlifted -mkCoPrimCaseMatchResult var ty match_alts - = MatchResult CanFail mk_case - where - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) - - sorted_alts = sortWith fst match_alts -- Right order for a Case - mk_alt fail (lit, MatchResult _ body_fn) - = ASSERT( not (litIsLifted lit) ) - do body <- body_fn fail - return (LitAlt lit, [], body) - -data CaseAlt a = MkCaseAlt{ alt_pat :: a, - alt_bndrs :: [Var], - alt_wrapper :: HsWrapper, - alt_result :: MatchResult } - -mkCoAlgCaseMatchResult - :: Id -- Scrutinee - -> Type -- Type of exp - -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) - -> MatchResult -mkCoAlgCaseMatchResult var ty match_alts - | isNewtype -- Newtype case; use a let - = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) - mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 - - | otherwise - = mkDataConCase var ty match_alts - where - isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) - - -- [Interesting: because of GADTs, we can't rely on the type of - -- the scrutinised Id to be sufficiently refined to have a TyCon in it] - - alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } - = ASSERT( notNull match_alts ) head match_alts - -- Stuff for newtype - arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 - var_ty = idType var - (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) - -mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult -mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt - -sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] -sort_alts = sortWith (dataConTag . alt_pat) - -mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr -mkPatSynCase var ty alt fail = do - matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getRuntimeRep ty, ty] - let MatchResult _ mkCont = match_result - cont <- mkCoreLams bndrs <$> mkCont fail - return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] - where - MkCaseAlt{ alt_pat = psyn, - alt_bndrs = bndrs, - alt_wrapper = wrapper, - alt_result = match_result} = alt - (matcher, needs_void_lam) = patSynMatcher psyn - - -- See Note [Matchers and builders for pattern synonyms] in PatSyns - -- on these extra Void# arguments - ensure_unstrict cont | needs_void_lam = Lam voidArgId cont - | otherwise = cont - -mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult -mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives" -mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case - where - con1 = alt_pat alt1 - tycon = dataConTyCon con1 - data_cons = tyConDataCons tycon - match_results = map alt_result alts - - sorted_alts :: [CaseAlt DataCon] - sorted_alts = sort_alts alts - - var_ty = idType var - (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - - mk_case :: CoreExpr -> DsM CoreExpr - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts) - - mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt - mk_alt fail MkCaseAlt{ alt_pat = con, - alt_bndrs = args, - alt_result = MatchResult _ body_fn } - = do { body <- body_fn fail - ; case dataConBoxer con of { - Nothing -> return (DataAlt con, args, body) ; - Just (DCB boxer) -> - do { us <- newUniqueSupply - ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) - ; return (DataAlt con, rep_ids, mkLets binds body) } } } - - mk_default :: CoreExpr -> [CoreAlt] - mk_default fail | exhaustive_case = [] - | otherwise = [(DEFAULT, [], fail)] - - fail_flag :: CanItFail - fail_flag | exhaustive_case - = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] - | otherwise - = CanFail - - mentioned_constructors = mkUniqSet $ map alt_pat alts - un_mentioned_constructors - = mkUniqSet data_cons `minusUniqSet` mentioned_constructors - exhaustive_case = isEmptyUniqSet un_mentioned_constructors - -{- -************************************************************************ -* * -\subsection{Desugarer's versions of some Core functions} -* * -************************************************************************ --} - -mkErrorAppDs :: Id -- The error function - -> Type -- Type to which it should be applied - -> SDoc -- The error message string to pass - -> DsM CoreExpr - -mkErrorAppDs err_id ty msg = do - src_loc <- getSrcSpanDs - dflags <- getDynFlags - let - full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) - core_msg = Lit (mkLitString full_msg) - -- mkLitString returns a result of type String# - return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) - -{- -'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. - -Note [Desugaring seq] -~~~~~~~~~~~~~~~~~~~~~ - -There are a few subtleties in the desugaring of `seq`: - - 1. (as described in #1031) - - Consider, - f x y = x `seq` (y `seq` (# x,y #)) - - The [CoreSyn let/app invariant] means that, other things being equal, because - the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: - - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v - - But that is bad for two reasons: - (a) we now evaluate y before x, and - (b) we can't bind v to an unboxed pair - - Seq is very, very special! So we recognise it right here, and desugar to - case x of _ -> case y of _ -> (# x,y #) - - 2. (as described in #2273) - - Consider - let chp = case b of { True -> fst x; False -> 0 } - in chp `seq` ...chp... - Here the seq is designed to plug the space leak of retaining (snd x) - for too long. - - If we rely on the ordinary inlining of seq, we'll get - let chp = case b of { True -> fst x; False -> 0 } - case chp of _ { I# -> ...chp... } - - But since chp is cheap, and the case is an alluring contet, we'll - inline chp into the case scrutinee. Now there is only one use of chp, - so we'll inline a second copy. Alas, we've now ruined the purpose of - the seq, by re-introducing the space leak: - case (case b of {True -> fst x; False -> 0}) of - I# _ -> ...case b of {True -> fst x; False -> 0}... - - We can try to avoid doing this by ensuring that the binder-swap in the - case happens, so we get his at an early stage: - case chp of chp2 { I# -> ...chp2... } - But this is fragile. The real culprit is the source program. Perhaps we - should have said explicitly - let !chp2 = chp in ...chp2... - - But that's painful. So the code here does a little hack to make seq - more robust: a saturated application of 'seq' is turned *directly* into - the case expression, thus: - x `seq` e2 ==> case x of x -> e2 -- Note shadowing! - e1 `seq` e2 ==> case x of _ -> e2 - - So we desugar our example to: - let chp = case b of { True -> fst x; False -> 0 } - case chp of chp { I# -> ...chp... } - And now all is well. - - The reason it's a hack is because if you define mySeq=seq, the hack - won't work on mySeq. - - 3. (as described in #2409) - - The isLocalId ensures that we don't turn - True `seq` e - into - case True of True { ... } - which stupidly tries to bind the datacon 'True'. --} - --- NB: Make sure the argument is not levity polymorphic -mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 - | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) - = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] - where - case_bndr = case arg1 of - Var v1 | isInternalName (idName v1) - -> v1 -- Note [Desugaring seq], points (2) and (3) - _ -> mkWildValBinder ty1 - -mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore - --- NB: No argument can be levity polymorphic -mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args - -mkCastDs :: CoreExpr -> Coercion -> CoreExpr --- We define a desugarer-specific version of CoreUtils.mkCast, --- because in the immediate output of the desugarer, we can have --- apparently-mis-matched coercions: E.g. --- let a = b --- in (x :: a) |> (co :: b ~ Int) --- Lint know about type-bindings for let and does not complain --- So here we do not make the assertion checks that we make in --- CoreUtils.mkCast; and we do less peephole optimisation too -mkCastDs e co | isReflCo co = e - | otherwise = Cast e co - -{- -************************************************************************ -* * - Tuples and selector bindings -* * -************************************************************************ - -This is used in various places to do with lazy patterns. -For each binder $b$ in the pattern, we create a binding: -\begin{verbatim} - b = case v of pat' -> b' -\end{verbatim} -where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. - -ToDo: making these bindings should really depend on whether there's -much work to be done per binding. If the pattern is complex, it -should be de-mangled once, into a tuple (and then selected from). -Otherwise the demangling can be in-line in the bindings (as here). - -Boring! Boring! One error message per binder. The above ToDo is -even more helpful. Something very similar happens for pattern-bound -expressions. - -Note [mkSelectorBinds] -~~~~~~~~~~~~~~~~~~~~~~ -mkSelectorBinds is used to desugar a pattern binding {p = e}, -in a binding group: - let { ...; p = e; ... } in body -where p binds x,y (this list of binders can be empty). -There are two cases. - ------- Special case (A) ------- - For a pattern that is just a variable, - let !x = e in body - ==> - let x = e in x `seq` body - So we return the binding, with 'x' as the variable to seq. - ------- Special case (B) ------- - For a pattern that is essentially just a tuple: - * A product type, so cannot fail - * Only one level, so that - - generating multiple matches is fine - - seq'ing it evaluates the same as matching it - Then instead we generate - { v = e - ; x = case v of p -> x - ; y = case v of p -> y } - with 'v' as the variable to force - ------- General case (C) ------- - In the general case we generate these bindings: - let { ...; p = e; ... } in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - in t `seq` body - - Note that we return 't' as the variable to force if the pattern - is strict (i.e. with -XStrict or an outermost-bang-pattern) - - Note that (A) /includes/ the situation where - - * The pattern binds exactly one variable - let !(Just (Just x) = e in body - ==> - let { t = case e of Just (Just v) -> Unit v - ; v = case t of Unit v -> v } - in t `seq` body - The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn - Note that forcing 't' makes the pattern match happen, - but does not force 'v'. - - * The pattern binds no variables - let !(True,False) = e in body - ==> - let t = case e of (True,False) -> () - in t `seq` body - - ------- Examples ---------- - * !(_, (_, a)) = e - ==> - t = case e of (_, (_, a)) -> Unit a - a = case t of Unit a -> a - - Note that - - Forcing 't' will force the pattern to match fully; - e.g. will diverge if (snd e) is bottom - - But 'a' itself is not forced; it is wrapped in a one-tuple - (see Note [One-tuples] in TysWiredIn) - - * !(Just x) = e - ==> - t = case e of Just x -> Unit x - x = case t of Unit x -> x - - Again, forcing 't' will fail if 'e' yields Nothing. - -Note that even though this is rather general, the special cases -work out well: - -* One binder, not -XStrict: - - let Just (Just v) = e in body - ==> - let t = case e of Just (Just v) -> Unit v - v = case t of Unit v -> v - in body - ==> - let v = case (case e of Just (Just v) -> Unit v) of - Unit v -> v - in body - ==> - let v = case e of Just (Just v) -> v - in body - -* Non-recursive, -XStrict - let p = e in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> x } - in t `seq` body - ==> {inline seq, float x,y bindings inwards} - let t = case e of p -> (x,y) in - case t of t' -> - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {inline t, do case of case} - case e of p -> - let t = (x,y) in - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {case-cancellation, drop dead code} - case e of p -> body - -* Special case (B) is there to avoid fruitlessly taking the tuple - apart and rebuilding it. For example, consider - { K x y = e } - where K is a product constructor. Then general case (A) does: - { t = case e of K x y -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - In the lazy case we can't optimise out this fruitless taking apart - and rebuilding. Instead (B) builds - { v = e - ; x = case v of K x y -> x - ; y = case v of K x y -> y } - which is better. --} - -mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly - -> LPat GhcTc -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound - -> DsM (Id,[(Id,CoreExpr)]) - -- ^ Id the rhs is bound to, for desugaring strict - -- binds (see Note [Desugar Strict binds] in DsBinds) - -- and all the desugared binds - -mkSelectorBinds ticks pat val_expr - | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A) - = return (v, [(v, val_expr)]) - - | is_flat_prod_lpat pat' -- Special case (B) - = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDsNoLP pat_ty - - ; let mk_bind tick bndr_var - -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } - -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' - (Var bndr_var) - (Var bndr_var) -- Neat hack - -- Neat hack: since 'pat' can't fail, the - -- "fail-expr" passed to matchSimply is not - -- used. But it /is/ used for its type, and for - -- that bndr_var is just the ticket. - ; return (bndr_var, mkOptTickBox tick rhs_expr) } - - ; binds <- zipWithM mk_bind ticks' binders - ; return ( val_var, (val_var, val_expr) : binds) } - - | otherwise -- General case (C) - = do { tuple_var <- newSysLocalDs tuple_ty - ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat - local_tuple error_expr - ; let mk_tup_bind tick binder - = (binder, mkOptTickBox tick $ - mkTupleSelector1 local_binders binder - tuple_var (Var tuple_var)) - tup_binds = zipWith mk_tup_bind ticks' binders - ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } - where - pat' = strip_bangs pat - -- Strip the bangs before looking for case (A) or (B) - -- The incoming pattern may well have a bang on it - - binders = collectPatBinders pat' - ticks' = ticks ++ repeat [] - - local_binders = map localiseId binders -- See Note [Localise pattern binders] - local_tuple = mkBigCoreVarTup1 binders - tuple_ty = exprType local_tuple - -strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) --- Remove outermost bangs and parens -strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p -strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p -strip_bangs lp = lp - -is_flat_prod_lpat :: LPat (GhcPass p) -> Bool -is_flat_prod_lpat = is_flat_prod_pat . unLoc - -is_flat_prod_pat :: Pat (GhcPass p) -> Bool -is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p -is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon) - , pat_args = ps}) - | RealDataCon con <- pcon - , isProductTyCon (dataConTyCon con) - = all is_triv_lpat (hsConPatArgs ps) -is_flat_prod_pat _ = False - -is_triv_lpat :: LPat (GhcPass p) -> Bool -is_triv_lpat = is_triv_pat . unLoc - -is_triv_pat :: Pat (GhcPass p) -> Bool -is_triv_pat (VarPat {}) = True -is_triv_pat (WildPat{}) = True -is_triv_pat (ParPat _ p) = is_triv_lpat p -is_triv_pat _ = False - - -{- ********************************************************************* -* * - Creating big tuples and their types for full Haskell expressions. - They work over *Ids*, and create tuples replete with their types, - which is whey they are not in GHC.Hs.Utils. -* * -********************************************************************* -} - -mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc -mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed -mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ - mkVanillaTuplePat lpats Boxed - -mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc --- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box - --- The Big equivalents for the source tuple expressions -mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc -mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) - -mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc -mkBigLHsTupId = mkChunkified mkLHsTupleExpr - --- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc -mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) - -mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc -mkBigLHsPatTupId = mkChunkified mkLHsPatTup - -{- -************************************************************************ -* * - Code for pattern-matching and other failures -* * -************************************************************************ - -Generally, we handle pattern matching failure like this: let-bind a -fail-variable, and use that variable if the thing fails: -\begin{verbatim} - let fail.33 = error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 - p3 -> fail.33 - p4 -> ... -\end{verbatim} -Then -\begin{itemize} -\item -If the case can't fail, then there'll be no mention of @fail.33@, and the -simplifier will later discard it. - -\item -If it can fail in only one way, then the simplifier will inline it. - -\item -Only if it is used more than once will the let-binding remain. -\end{itemize} - -There's a problem when the result of the case expression is of -unboxed type. Then the type of @fail.33@ is unboxed too, and -there is every chance that someone will change the let into a case: -\begin{verbatim} - case error "Help" of - fail.33 -> case .... -\end{verbatim} - -which is of course utterly wrong. Rather than drop the condition that -only boxed types can be let-bound, we just turn the fail into a function -for the primitive case: -\begin{verbatim} - let fail.33 :: Void -> Int# - fail.33 = \_ -> error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 void - p3 -> fail.33 void - p4 -> ... -\end{verbatim} - -Now @fail.33@ is a function, so it can be let-bound. - -We would *like* to use join points here; in fact, these "fail variables" are -paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as -CPS functions - i.e. they take "join points" as parameters. It's not impossible -to imagine extending our type system to allow passing join points around (very -carefully), but we certainly don't support it now. - -99.99% of the time, the fail variables wind up as join points in short order -anyway, and the Void# doesn't do much harm. --} - -mkFailurePair :: CoreExpr -- Result type of the whole case expression - -> DsM (CoreBind, -- Binds the newly-created fail variable - -- to \ _ -> expression - CoreExpr) -- Fail variable applied to realWorld# --- See Note [Failure thunks and CPR] -mkFailurePair expr - = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty) - ; fail_fun_arg <- newSysLocalDs voidPrimTy - ; let real_arg = setOneShotLambda fail_fun_arg - ; return (NonRec fail_fun_var (Lam real_arg expr), - App (Var fail_fun_var) (Var voidPrimId)) } - where - ty = exprType expr - -{- -Note [Failure thunks and CPR] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This note predates join points as formal entities (hence the quotation marks). -We can't use actual join points here (see above); if we did, this would also -solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR -join points] in WorkWrap.) - -When we make a failure point we ensure that it -does not look like a thunk. Example: - - let fail = \rw -> error "urk" - in case x of - [] -> fail realWorld# - (y:ys) -> case ys of - [] -> fail realWorld# - (z:zs) -> (y,z) - -Reason: we know that a failure point is always a "join point" and is -entered at most once. Adding a dummy 'realWorld' token argument makes -it clear that sharing is not an issue. And that in turn makes it more -CPR-friendly. This matters a lot: if you don't get it right, you lose -the tail call property. For example, see #3403. - - -************************************************************************ -* * - Ticks -* * -********************************************************************* -} - -mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr -mkOptTickBox = flip (foldr Tick) - -mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr -mkBinaryTickBox ixT ixF e = do - uq <- newUnique - this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq boolTy - let - falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) - trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) - -- - return $ Case e bndr1 boolTy - [ (DataAlt falseDataCon, [], falseBox) - , (DataAlt trueDataCon, [], trueBox) - ] - - - --- ******************************************************************* - -{- Note [decideBangHood] -~~~~~~~~~~~~~~~~~~~~~~~~ -With -XStrict we may make /outermost/ patterns more strict. -E.g. - let (Just x) = e in ... - ==> - let !(Just x) = e in ... -and - f x = e - ==> - f !x = e - -This adjustment is done by decideBangHood, - - * Just before constructing an EqnInfo, in Match - (matchWrapper and matchSinglePat) - - * When desugaring a pattern-binding in DsBinds.dsHsBind - -Note that it is /not/ done recursively. See the -XStrict -spec in the user manual. - -Specifically: - ~pat => pat -- when -XStrict (even if pat = ~pat') - !pat => !pat -- always - pat => !pat -- when -XStrict - pat => pat -- otherwise --} - - --- | Use -XStrict to add a ! or remove a ~ --- See Note [decideBangHood] -decideBangHood :: DynFlags - -> LPat GhcTc -- ^ Original pattern - -> LPat GhcTc -- Pattern with bang if necessary -decideBangHood dflags lpat - | not (xopt LangExt.Strict dflags) - = lpat - | otherwise -- -XStrict - = go lpat - where - go lp@(dL->L l p) - = case p of - ParPat x p -> cL l (ParPat x (go p)) - LazyPat _ lp' -> lp' - BangPat _ _ -> lp - _ -> cL l (BangPat noExtField lp) - --- | Unconditionally make a 'Pat' strict. -addBang :: LPat GhcTc -- ^ Original pattern - -> LPat GhcTc -- ^ Banged pattern -addBang = go - where - go lp@(dL->L l p) - = case p of - ParPat x p -> cL l (ParPat x (go p)) - LazyPat _ lp' -> cL l (BangPat noExtField lp') - -- Should we bring the extension value over? - BangPat _ _ -> lp - _ -> cL l (BangPat noExtField lp) - -isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) - --- Returns Just {..} if we're sure that the expression is True --- I.e. * 'True' datacon --- * 'otherwise' Id --- * Trivial wappings of these --- The arguments to Just are any HsTicks that we have found, --- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v))) - | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId - = Just return - -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (dL->L _ (HsConLikeOut _ con)) - | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (dL->L _ (HsTick _ tickish e)) - | Just ticks <- isTrueLHsExpr e - = Just (\x -> do wrapped <- ticks x - return (Tick tickish wrapped)) - -- This encodes that the result is constant True for Hpc tick purposes; - -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e)) - | Just ticks <- isTrueLHsExpr e - = Just (\x -> do e <- ticks x - this_mod <- getModule - return (Tick (HpcTick this_mod ixT) e)) - -isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing diff --git a/deSugar/ExtractDocs.hs b/deSugar/ExtractDocs.hs deleted file mode 100644 --- a/deSugar/ExtractDocs.hs +++ /dev/null @@ -1,358 +0,0 @@ --- | Extract docs from the renamer output so they can be be serialized. -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -module ExtractDocs (extractDocs) where - -import GhcPrelude -import Bag -import GHC.Hs.Binds -import GHC.Hs.Doc -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Types -import GHC.Hs.Utils -import Name -import NameSet -import SrcLoc -import TcRnTypes - -import Control.Applicative -import Data.Bifunctor (first) -import Data.List -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe -import Data.Semigroup - --- | Extract docs from renamer output. -extractDocs :: TcGblEnv - -> (Maybe HsDocString, DeclDocMap, ArgDocMap) - -- ^ - -- 1. Module header - -- 2. Docs on top level declarations - -- 3. Docs on arguments -extractDocs TcGblEnv { tcg_semantic_mod = mod - , tcg_rn_decls = mb_rn_decls - , tcg_insts = insts - , tcg_fam_insts = fam_insts - , tcg_doc_hdr = mb_doc_hdr - } = - (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map) - where - (doc_map, arg_map) = maybe (M.empty, M.empty) - (mkMaps local_insts) - mb_decls_with_docs - mb_decls_with_docs = topDecls <$> mb_rn_decls - local_insts = filter (nameIsLocalOrFrom mod) - $ map getName insts ++ map getName fam_insts - --- | Create decl and arg doc-maps by looping through the declarations. --- For each declaration, find its names, its subordinates, and its doc strings. -mkMaps :: [Name] - -> [(LHsDecl GhcRn, [HsDocString])] - -> (Map Name (HsDocString), Map Name (Map Int (HsDocString))) -mkMaps instances decls = - ( f' (map (nubByName fst) decls') - , f (filterMapping (not . M.null) args) - ) - where - (decls', args) = unzip (map mappings decls) - - f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b - f = M.fromListWith (<>) . concat - - f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString - f' = M.fromListWith appendDocs . concat - - filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] - filterMapping p = map (filter (p . snd)) - - mappings :: (LHsDecl GhcRn, [HsDocString]) - -> ( [(Name, HsDocString)] - , [(Name, Map Int (HsDocString))] - ) - mappings (L l decl, docStrs) = - (dm, am) - where - doc = concatDocs docStrs - args = declTypeDocs decl - - subs :: [(Name, [(HsDocString)], Map Int (HsDocString))] - subs = subordinates instanceMap decl - - (subDocs, subArgs) = - unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) - - ns = names l decl - subNs = [ n | (n, _, _) <- subs ] - dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] - am = [(n, args) | n <- ns] ++ zip subNs subArgs - - instanceMap :: Map SrcSpan Name - instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances] - - names :: SrcSpan -> HsDecl GhcRn -> [Name] - names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See - -- Note [1]. - where loc = case d of - TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only - -- for TFs - _ -> getInstLoc d - names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. - names _ decl = getMainDeclBinder decl - -{- -Note [1]: ---------- -We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried -inside them. That should work for normal user-written instances (from -looking at GHC sources). We can assume that commented instances are -user-written. This lets us relate Names (from ClsInsts) to comments -(associated with InstDecls and DerivDecls). --} - -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] -getMainDeclBinder (TyClD _ d) = [tcdName d] -getMainDeclBinder (ValD _ d) = - case collectHsBindBinders d of - [] -> [] - (name:_) -> [name] -getMainDeclBinder (SigD _ d) = sigNameNoLoc d -getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] -getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - -sigNameNoLoc :: Sig pass -> [IdP pass] -sigNameNoLoc (TypeSig _ ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns -sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] -sigNameNoLoc (InlineSig _ n _) = [unLoc n] -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns -sigNameNoLoc _ = [] - --- Extract the source location where an instance is defined. This is used --- to correlate InstDecls with their Instance/CoAxiom Names, via the --- instanceMap. -getInstLoc :: InstDecl (GhcPass p) -> SrcSpan -getInstLoc = \case - ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) - DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l - TyFamInstD _ (TyFamInstDecl - -- Since CoAxioms' Names refer to the whole line for type family instances - -- in particular, we need to dig a bit deeper to pull out the entire - -- equation. This does not happen for data family instances, for some - -- reason. - { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l - ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" - DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" - TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" - XInstDecl _ -> error "getInstLoc" - DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" - TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" - --- | Get all subordinate declarations inside a declaration, and their docs. --- A subordinate declaration is something like the associate type or data --- family of a type class. -subordinates :: Map SrcSpan Name - -> HsDecl GhcRn - -> [(Name, [(HsDocString)], Map Int (HsDocString))] -subordinates instMap decl = case decl of - InstD _ (ClsInstD _ d) -> do - DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = (dL->L l _) - , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) - -> dataSubs (feqn_rhs d) - TyClD _ d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) - _ -> [] - where - classSubs dd = [ (name, doc, declTypeDocs d) - | (dL->L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) - ] - dataSubs :: HsDataDefn GhcRn - -> [(Name, [HsDocString], Map Int (HsDocString))] - dataSubs dd = constrs ++ fields ++ derivs - where - cons = map unLoc $ (dd_cons dd) - constrs = [ ( unLoc cname - , maybeToList $ fmap unLoc $ con_doc c - , conArgDocs c) - | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) - | RecCon flds <- map getConArgs cons - , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) - , (dL->L _ n) <- ns ] - derivs = [ (instName, [unLoc doc], M.empty) - | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ - concatMap (unLoc . deriv_clause_tys . unLoc) $ - unLoc $ dd_derivs dd - , Just instName <- [M.lookup l instMap] ] - - extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) - extract_deriv_ty ty = - case dL ty of - -- deriving (forall a. C a {- ^ Doc comment -}) - L l (HsForAllTy{ hst_fvf = ForallInvis - , hst_body = dL->L _ (HsDocTy _ _ doc) }) - -> Just (l, doc) - -- deriving (C a {- ^ Doc comment -}) - L l (HsDocTy _ _ doc) -> Just (l, doc) - _ -> Nothing - --- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) -conArgDocs con = case getConArgs con of - PrefixCon args -> go 0 (map unLoc args ++ ret) - InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) - RecCon _ -> go 1 ret - where - go n = M.fromList . catMaybes . zipWith f [n..] - where - f n (HsDocTy _ _ lds) = Just (n, unLoc lds) - f _ _ = Nothing - - ret = case con of - ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] - _ -> [] - -isValD :: HsDecl a -> Bool -isValD (ValD _ _) = True -isValD _ = False - --- | All the sub declarations of a class (that we handle), ordered by --- source location, with documentation attached if it exists. -classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls - where - decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs (DocD noExtField) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ - sigs = mkDecls tcdSigs (SigD noExtField) class_ - ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ - --- | Extract function argument docs from inside top-level decls. -declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) -declTypeDocs = \case - SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty)) - SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty)) - SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty)) - ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty)) - TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) - _ -> M.empty - -nubByName :: (a -> Name) -> [a] -> [a] -nubByName f ns = go emptyNameSet ns - where - go _ [] = [] - go s (x:xs) - | y `elemNameSet` s = go s xs - | otherwise = let s' = extendNameSet s y - in x : go s' xs - where - y = f x - --- | Extract function argument docs from inside types. -typeDocs :: HsType GhcRn -> Map Int (HsDocString) -typeDocs = go 0 - where - go n = \case - HsForAllTy { hst_body = ty } -> go n (unLoc ty) - HsQualTy { hst_body = ty } -> go n (unLoc ty) - HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) - HsFunTy _ _ ty -> go (n+1) (unLoc ty) - HsDocTy _ _ doc -> M.singleton n (unLoc doc) - _ -> M.empty - --- | The top-level declarations of a module that we care about, --- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup - --- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] -ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ - mkDecls hs_derivds (DerivD noExtField) group_ ++ - mkDecls hs_defds (DefD noExtField) group_ ++ - mkDecls hs_fords (ForD noExtField) group_ ++ - mkDecls hs_docs (DocD noExtField) group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ - mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ - mkDecls (valbinds . hs_valds) (ValD noExtField) group_ - where - typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig - typesigs ValBinds{} = error "expected XValBindsLR" - - valbinds (XValBindsLR (NValBinds binds _)) = - concatMap bagToList . snd . unzip $ binds - valbinds ValBinds{} = error "expected XValBindsLR" - --- | Sort by source location -sortByLoc :: [Located a] -> [Located a] -sortByLoc = sortOn getLoc - --- | Collect docs and attach them to the right declarations. --- --- A declaration may have multiple doc strings attached to it. -collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] --- ^ This is an example. -collectDocs = go [] Nothing - where - go docs mprev decls = case (decls, mprev) of - ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds - ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds - ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds - (d : ds, Nothing) -> go docs (Just d) ds - (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds - ([] , Nothing) -> [] - ([] , Just prev) -> finished prev docs [] - - finished decl docs rest = (decl, reverse docs) : rest - --- | Filter out declarations that we don't handle in Haddock -filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unLoc . fst) - where - isHandled (ForD _ (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True - isHandled (DerivD {}) = True - isHandled (SigD _ d) = isUserSig d - isHandled (ValD {}) = True - -- we keep doc declarations to be able to get at named docs - isHandled (DocD {}) = True - isHandled _ = False - - --- | Go through all class declarations and filter their sub-declarations -filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses = map (first (mapLoc filterClass)) - where - filterClass (TyClD x c@(ClassDecl {})) = - TyClD x $ c { tcdSigs = - filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } - filterClass d = d - --- | Was this signature given by the user? -isUserSig :: Sig name -> Bool -isUserSig TypeSig {} = True -isUserSig ClassOpSig {} = True -isUserSig PatSynSig {} = True -isUserSig _ = False - --- | Take a field of declarations from a data structure and create HsDecls --- using the given constructor -mkDecls :: (struct -> [Located decl]) - -> (decl -> hsDecl) - -> struct - -> [Located hsDecl] -mkDecls field con = map (mapLoc con) . field diff --git a/deSugar/Match.hs b/deSugar/Match.hs deleted file mode 100644 --- a/deSugar/Match.hs +++ /dev/null @@ -1,1140 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @match@ function --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Match ( match, matchEquations, matchWrapper, matchSimply - , matchSinglePat, matchSinglePatVar ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr) - -import BasicTypes ( Origin(..) ) -import DynFlags -import GHC.Hs -import TcHsSyn -import TcEvidence -import TcRnMonad -import GHC.HsToCore.PmCheck -import CoreSyn -import Literal -import CoreUtils -import MkCore -import DsMonad -import DsBinds -import DsGRHSs -import DsUtils -import Id -import ConLike -import DataCon -import PatSyn -import MatchCon -import MatchLit -import Type -import Coercion ( eqCoercion ) -import TyCon( isNewTyCon ) -import TysWiredIn -import SrcLoc -import Maybes -import Util -import Name -import Outputable -import BasicTypes ( isGenerated, il_value, fl_value ) -import FastString -import Unique -import UniqDFM - -import Control.Monad( when, unless ) -import Data.List ( groupBy ) -import qualified Data.Map as Map - -{- -************************************************************************ -* * - The main matching function -* * -************************************************************************ - -The function @match@ is basically the same as in the Wadler chapter -from "The Implementation of Functional Programming Languages", -except it is monadised, to carry around the name supply, info about -annotations, etc. - -Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: -\begin{enumerate} -\item -A list of $n$ variable names, those variables presumably bound to the -$n$ expressions being matched against the $n$ patterns. Using the -list of $n$ expressions as the first argument showed no benefit and -some inelegance. - -\item -The second argument, a list giving the ``equation info'' for each of -the $m$ equations: -\begin{itemize} -\item -the $n$ patterns for that equation, and -\item -a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on -the front'' of the matching code, as in: -\begin{verbatim} -let -in -\end{verbatim} -\item -and finally: (ToDo: fill in) - -The right way to think about the ``after-match function'' is that it -is an embryonic @CoreExpr@ with a ``hole'' at the end for the -final ``else expression''. -\end{itemize} - -There is a data type, @EquationInfo@, defined in module @DsMonad@. - -An experiment with re-ordering this information about equations (in -particular, having the patterns available in column-major order) -showed no benefit. - -\item -A default expression---what to evaluate if the overall pattern-match -fails. This expression will (almost?) always be -a measly expression @Var@, unless we know it will only be used once -(as we do in @glue_success_exprs@). - -Leaving out this third argument to @match@ (and slamming in lots of -@Var "fail"@s) is a positively {\em bad} idea, because it makes it -impossible to share the default expressions. (Also, it stands no -chance of working in our post-upheaval world of @Locals@.) -\end{enumerate} - -Note: @match@ is often called via @matchWrapper@ (end of this module), -a function that does much of the house-keeping that goes with a call -to @match@. - -It is also worth mentioning the {\em typical} way a block of equations -is desugared with @match@. At each stage, it is the first column of -patterns that is examined. The steps carried out are roughly: -\begin{enumerate} -\item -Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add -bindings to the second component of the equation-info): -\item -Now {\em unmix} the equations into {\em blocks} [w\/ local function -@match_groups@], in which the equations in a block all have the same - match group. -(see ``the mixture rule'' in SLPJ). -\item -Call the right match variant on each block of equations; it will do the -appropriate thing for each kind of column-1 pattern. -\end{enumerate} - -We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) -than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). -And gluing the ``success expressions'' together isn't quite so pretty. - -This @match@ uses @tidyEqnInfo@ -to get `as'- and `twiddle'-patterns out of the way (tidying), before -applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em -un}mixes the equations], producing a list of equation-info -blocks, each block having as its first column patterns compatible with each other. - -Note [Match Ids] -~~~~~~~~~~~~~~~~ -Most of the matching functions take an Id or [Id] as argument. This Id -is the scrutinee(s) of the match. The desugared expression may -sometimes use that Id in a local binding or as a case binder. So it -should not have an External name; Lint rejects non-top-level binders -with External names (#13043). - -See also Note [Localise pattern binders] in DsUtils --} - -type MatchId = Id -- See Note [Match Ids] - -match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with - -- ^ See Note [Match Ids] - -> Type -- ^ Type of the case expression - -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- ^ Desugared result! - -match [] ty eqns - = ASSERT2( not (null eqns), ppr ty ) - return (foldr1 combineMatchResults match_results) - where - match_results = [ ASSERT( null (eqn_pats eqn) ) - eqn_rhs eqn - | eqn <- eqns ] - -match vars@(v:_) ty eqns -- Eqns *can* be empty - = ASSERT2( all (isInternalName . idName) vars, ppr vars ) - do { dflags <- getDynFlags - -- Tidy the first pattern, generating - -- auxiliary bindings if necessary - ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns - - -- Group the equations and match each group in turn - ; let grouped = groupEquations dflags tidy_eqns - - -- print the view patterns that are commoned up to help debug - ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) - - ; match_results <- match_groups grouped - ; return (adjustMatchResult (foldr (.) id aux_binds) $ - foldr1 combineMatchResults match_results) } - where - dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo] - dropGroup = map snd - - match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult] - -- Result list of [MatchResult] is always non-empty - match_groups [] = matchEmpty v ty - match_groups gs = mapM match_group gs - - match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult - match_group [] = panic "match_group" - match_group eqns@((group,_) : _) - = case group of - PgCon {} -> matchConFamily vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns]) - PgSyn {} -> matchPatSyn vars ty (dropGroup eqns) - PgLit {} -> matchLiterals vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns]) - PgAny -> matchVariables vars ty (dropGroup eqns) - PgN {} -> matchNPats vars ty (dropGroup eqns) - PgOverS {}-> matchNPats vars ty (dropGroup eqns) - PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns) - PgBang -> matchBangs vars ty (dropGroup eqns) - PgCo {} -> matchCoercion vars ty (dropGroup eqns) - PgView {} -> matchView vars ty (dropGroup eqns) - PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) - - -- FIXME: we should also warn about view patterns that should be - -- commoned up but are not - - -- print some stuff to see what's getting grouped - -- use -dppr-debug to see the resolution of overloaded literals - debug eqns = - let gs = map (\group -> foldr (\ (p,_) -> \acc -> - case p of PgView e _ -> e:acc - _ -> acc) [] group) eqns - maybeWarn [] = return () - maybeWarn l = warnDs NoReason (vcat l) - in - maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) - (filter (not . null) gs)) - -matchEmpty :: MatchId -> Type -> DsM [MatchResult] --- See Note [Empty case expressions] -matchEmpty var res_ty - = return [MatchResult CanFail mk_seq] - where - mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty - [(DEFAULT, [], fail)] - -matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult --- Real true variables, just like in matchVar, SLPJ p 94 --- No binding to do: they'll all be wildcards by now (done in tidy) -matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns) -matchVariables [] _ _ = panic "matchVariables" - -matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -matchBangs (var:vars) ty eqns - = do { match_result <- match (var:vars) ty $ - map (decomposeFirstPat getBangPat) eqns - ; return (mkEvalMatchResult var ty match_result) } -matchBangs [] _ _ = panic "matchBangs" - -matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult --- Apply the coercion to the match variable and then match that -matchCoercion (var:vars) ty (eqns@(eqn1:_)) - = do { let CoPat _ co pat _ = firstPat eqn1 - ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' - ; match_result <- match (var':vars) ty $ - map (decomposeFirstPat getCoPat) eqns - ; core_wrap <- dsHsWrapper co - ; let bind = NonRec var' (core_wrap (Var var)) - ; return (mkCoLetMatchResult bind match_result) } -matchCoercion _ _ _ = panic "matchCoercion" - -matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult --- Apply the view function to the match variable and then match that -matchView (var:vars) ty (eqns@(eqn1:_)) - = do { -- we could pass in the expr from the PgView, - -- but this needs to extract the pat anyway - -- to figure out the type of the fresh variable - let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1 - -- do the rest of the compilation - ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' - ; match_result <- match (var':vars) ty $ - map (decomposeFirstPat getViewPat) eqns - -- compile the view expressions - ; viewExpr' <- dsLExpr viewExpr - ; return (mkViewMatchResult var' - (mkCoreAppDs (text "matchView") viewExpr' (Var var)) - match_result) } -matchView _ _ _ = panic "matchView" - -matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) --- Since overloaded list patterns are treated as view patterns, --- the code is roughly the same as for matchView - = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 - ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand - ; match_result <- match (var':vars) ty $ - map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern - ; e' <- dsSyntaxExpr e [Var var] - ; return (mkViewMatchResult var' e' match_result) } -matchOverloadedList _ _ _ = panic "matchOverloadedList" - --- decompose the first pattern and leave the rest alone -decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo -decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) - = eqn { eqn_pats = extractpat pat : pats} -decomposeFirstPat _ _ = panic "decomposeFirstPat" - -getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc -getCoPat (CoPat _ _ pat _) = pat -getCoPat _ = panic "getCoPat" -getBangPat (BangPat _ pat ) = unLoc pat -getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ _ pat) = unLoc pat -getViewPat _ = panic "getViewPat" -getOLPat (ListPat (ListPatTc ty (Just _)) pats) - = ListPat (ListPatTc ty Nothing) pats -getOLPat _ = panic "getOLPat" - -{- -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The list of EquationInfo can be empty, arising from - case x of {} or \case {} -In that situation we desugar to - case x of { _ -> error "pattern match failure" } -The *desugarer* isn't certain whether there really should be no -alternatives, so it adds a default case, as it always does. A later -pass may remove it if it's inaccessible. (See also Note [Empty case -alternatives] in CoreSyn.) - -We do *not* desugar simply to - error "empty case" -or some such, because 'x' might be bound to (error "hello"), in which -case we want to see that "hello" exception, not (error "empty case"). -See also Note [Case elimination: lifted case] in Simplify. - - -************************************************************************ -* * - Tidying patterns -* * -************************************************************************ - -Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ -which will be scrutinised. - -This makes desugaring the pattern match simpler by transforming some of -the patterns to simpler forms. (Tuples to Constructor Patterns) - -Among other things in the resulting Pattern: -* Variables and irrefutable(lazy) patterns are replaced by Wildcards -* As patterns are replaced by the patterns they wrap. - -The bindings created by the above patterns are put into the returned wrapper -instead. - -This means a definition of the form: - f x = rhs -when called with v get's desugared to the equivalent of: - let x = v - in - f _ = rhs - -The same principle holds for as patterns (@) and -irrefutable/lazy patterns (~). -In the case of irrefutable patterns the irrefutable pattern is pushed into -the binding. - -Pattern Constructors which only represent syntactic sugar are converted into -their desugared representation. -This usually means converting them to Constructor patterns but for some -depends on enabled extensions. (Eg OverloadedLists) - -GHC also tries to convert overloaded Literals into regular ones. - -The result of this tidying is that the column of patterns will include -only these which can be assigned a PatternGroup (see patGroup). - --} - -tidyEqnInfo :: Id -> EquationInfo - -> DsM (DsWrapper, EquationInfo) - -- DsM'd because of internal call to dsLHsBinds - -- and mkSelectorBinds. - -- "tidy1" does the interesting stuff, looking at - -- one pattern and fiddling the list of bindings. - -- - -- POST CONDITION: head pattern in the EqnInfo is - -- one of these for which patGroup is defined. - -tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) - = panic "tidyEqnInfo" - -tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) - = do { (wrap, pat') <- tidy1 v orig pat - ; return (wrap, eqn { eqn_pats = do pat' : pats }) } - -tidy1 :: Id -- The Id being scrutinised - -> Origin -- Was this a pattern the user wrote? - -> Pat GhcTc -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings to do before the match - Pat GhcTc) -- Equivalent pattern - -------------------------------------------------------- --- (pat', mr') = tidy1 v pat mr --- tidies the *outer level only* of pat, giving pat' --- It eliminates many pattern forms (as-patterns, variable patterns, --- list patterns, etc) and returns any created bindings in the wrapper. - -tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) -tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) -tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p - - -- case v of { x -> mr[] } - -- = case v of { _ -> let x=v in mr[] } -tidy1 v _ (VarPat _ (dL->L _ var)) - = return (wrapBind var v, WildPat (idType var)) - - -- case v of { x@p -> mr[] } - -- = case v of { p -> let x=v in mr[] } -tidy1 v o (AsPat _ (dL->L _ var) pat) - = do { (wrap, pat') <- tidy1 v o (unLoc pat) - ; return (wrapBind var v . wrap, pat') } - -{- now, here we handle lazy patterns: - tidy1 v ~p bs = (v, v1 = case v of p -> v1 : - v2 = case v of p -> v2 : ... : bs ) - - where the v_i's are the binders in the pattern. - - ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? - - The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr --} - -tidy1 v _ (LazyPat _ pat) - -- This is a convenient place to check for unlifted types under a lazy pattern. - -- Doing this check during type-checking is unsatisfactory because we may - -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) - ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLoc pat) $ - errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ - text "Unlifted variables:") - 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) - unlifted_bndrs))) - - ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) - ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; return (mkCoreLets sel_binds, WildPat (idType v)) } - -tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats ) - = return (idDsWrapper, unLoc list_ConPat) - where - list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) - (mkNilPat ty) - pats - -tidy1 _ _ (TuplePat tys pats boxity) - = return (idDsWrapper, unLoc tuple_ConPat) - where - arity = length pats - tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys - -tidy1 _ _ (SumPat tys pat alt arity) - = return (idDsWrapper, unLoc sum_ConPat) - where - sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys - --- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (LitPat _ lit) - = do { unless (isGenerated o) $ - warnAboutOverflowedLit lit - ; return (idDsWrapper, tidyLitPat lit) } - --- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq) - = do { unless (isGenerated o) $ - let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } - | otherwise = lit - in warnAboutOverflowedOverLit lit' - ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } - --- NPlusKPat: we may want to warn about the literals -tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _) - = do { unless (isGenerated o) $ do - warnAboutOverflowedOverLit lit1 - warnAboutOverflowedOverLit lit2 - ; return (idDsWrapper, n) } - --- Everything else goes through unchanged... -tidy1 _ _ non_interesting_pat - = return (idDsWrapper, non_interesting_pat) - --------------------- -tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc - -> DsM (DsWrapper, Pat GhcTc) - --- Discard par/sig under a bang -tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p -tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p - --- Push the bang-pattern inwards, in the hope that --- it may disappear next time -tidy_bang_pat v o l (AsPat x v' p) - = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p))) -tidy_bang_pat v o l (CoPat x w p t) - = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t) - --- Discard bang around strict pattern -tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p - --- Data/newtype constructors -tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc)) - , pat_args = args - , pat_arg_tys = arg_tys }) - -- Newtypes: push bang inwards (#9844) - = - if isNewTyCon (dataConTyCon dc) - then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args }) - else tidy1 v o p -- Data types: discard the bang - where - (ty:_) = dataConInstArgTys dc arg_tys - -------------------- --- Default case, leave the bang there: --- VarPat, --- LazyPat, --- WildPat, --- ViewPat, --- pattern synonyms (ConPatOut with PatSynCon) --- NPat, --- NPlusKPat --- --- For LazyPat, remember that it's semantically like a VarPat --- i.e. !(~p) is not like ~p, or p! (#8952) --- --- NB: SigPatIn, ConPatIn should not happen - -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p)) - -------------------- -push_bang_into_newtype_arg :: SrcSpan - -> Type -- The type of the argument we are pushing - -- onto - -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc --- See Note [Bang patterns and newtypes] --- We are transforming !(N p) into (N !p) -push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) - = ASSERT( null args) - PrefixCon [cL l (BangPat noExtField arg)] -push_bang_into_newtype_arg l _ty (RecCon rf) - | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf - , HsRecField { hsRecFieldArg = arg } <- fld - = ASSERT( null flds) - RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg - = cL l (BangPat noExtField arg) })] }) -push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) - | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))] -push_bang_into_newtype_arg _ _ cd - = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) - -{- -Note [Bang patterns and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the pattern !(Just pat) we can discard the bang, because -the pattern is strict anyway. But for !(N pat), where - newtype NT = N Int -we definitely can't discard the bang. #9844. - -So what we do is to push the bang inwards, in the hope that it will -get discarded there. So we transform - !(N pat) into (N !pat) - -But what if there is nothing to push the bang onto? In at least one instance -a user has written !(N {}) which we translate into (N !_). See #13215 - - -\noindent -{\bf Previous @matchTwiddled@ stuff:} - -Now we get to the only interesting part; note: there are choices for -translation [from Simon's notes]; translation~1: -\begin{verbatim} -deTwiddle [s,t] e -\end{verbatim} -returns -\begin{verbatim} -[ w = e, - s = case w of [s,t] -> s - t = case w of [s,t] -> t -] -\end{verbatim} - -Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple -evaluation of \tr{e}. An alternative translation (No.~2): -\begin{verbatim} -[ w = case e of [s,t] -> (s,t) - s = case w of (s,t) -> s - t = case w of (s,t) -> t -] -\end{verbatim} - -************************************************************************ -* * -\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} -* * -************************************************************************ - -We might be able to optimise unmixing when confronted by -only-one-constructor-possible, of which tuples are the most notable -examples. Consider: -\begin{verbatim} -f (a,b,c) ... = ... -f d ... (e:f) = ... -f (g,h,i) ... = ... -f j ... = ... -\end{verbatim} -This definition would normally be unmixed into four equation blocks, -one per equation. But it could be unmixed into just one equation -block, because if the one equation matches (on the first column), -the others certainly will. - -You have to be careful, though; the example -\begin{verbatim} -f j ... = ... -------------------- -f (a,b,c) ... = ... -f d ... (e:f) = ... -f (g,h,i) ... = ... -\end{verbatim} -{\em must} be broken into two blocks at the line shown; otherwise, you -are forcing unnecessary evaluation. In any case, the top-left pattern -always gives the cue. You could then unmix blocks into groups of... -\begin{description} -\item[all variables:] -As it is now. -\item[constructors or variables (mixed):] -Need to make sure the right names get bound for the variable patterns. -\item[literals or variables (mixed):] -Presumably just a variant on the constructor case (as it is now). -\end{description} - -************************************************************************ -* * -* matchWrapper: a convenient way to call @match@ * -* * -************************************************************************ -\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} - -Calls to @match@ often involve similar (non-trivial) work; that work -is collected here, in @matchWrapper@. This function takes as -arguments: -\begin{itemize} -\item -Typechecked @Matches@ (of a function definition, or a case or lambda -expression)---the main input; -\item -An error message to be inserted into any (runtime) pattern-matching -failure messages. -\end{itemize} - -As results, @matchWrapper@ produces: -\begin{itemize} -\item -A list of variables (@Locals@) that the caller must ``promise'' to -bind to appropriate values; and -\item -a @CoreExpr@, the desugared output (main result). -\end{itemize} - -The main actions of @matchWrapper@ include: -\begin{enumerate} -\item -Flatten the @[TypecheckedMatch]@ into a suitable list of -@EquationInfo@s. -\item -Create as many new variables as there are patterns in a pattern-list -(in any one of the @EquationInfo@s). -\item -Create a suitable ``if it fails'' expression---a call to @error@ using -the error-string input; the {\em type} of this fail value can be found -by examining one of the RHS expressions in one of the @EquationInfo@s. -\item -Call @match@ with all of this information! -\end{enumerate} --} - -matchWrapper - :: HsMatchContext Name -- ^ For shadowing warning messages - -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr - -- case scrut of { p1 -> e1 ... } - -- (and in this case the MatchGroup will - -- have all singleton patterns) - -- Nothing for a function definition - -- f p1 q1 = ... -- No "scrutinee" - -- f p2 q2 = ... -- in this case - -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared - -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match') - -{- - There is one small problem with the Lambda Patterns, when somebody - writes something similar to: -\begin{verbatim} - (\ (x:xs) -> ...) -\end{verbatim} - he/she don't want a warning about incomplete patterns, that is done with - the flag @opt_WarnSimplePatterns@. - This problem also appears in the: -\begin{itemize} -\item @do@ patterns, but if the @do@ can fail - it creates another equation if the match can fail - (see @DsExpr.doDo@ function) -\item @let@ patterns, are treated by @matchSimply@ - List Comprension Patterns, are treated by @matchSimply@ also -\end{itemize} - -We can't call @matchSimply@ with Lambda patterns, -due to the fact that lambda patterns can have more than -one pattern, and match simply only accepts one pattern. - -JJQC 30-Nov-1997 --} - -matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) - , mg_ext = MatchGroupTc arg_tys rhs_ty - , mg_origin = origin }) - = do { dflags <- getDynFlags - ; locn <- getSrcSpanDs - - ; new_vars <- case matches of - [] -> mapM newSysLocalDsNoLP arg_tys - (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) - - ; eqns_info <- mapM (mk_eqn_info new_vars) matches - - -- Pattern match check warnings for /this match-group/ - ; when (isMatchContextPmChecked dflags origin ctxt) $ - addScrutTmCs mb_scr new_vars $ - -- See Note [Type and Term Equality Propagation] - checkMatches dflags (DsMatchContext ctxt locn) new_vars matches - - ; result_expr <- handleWarnings $ - matchEquations ctxt new_vars eqns_info rhs_ty - ; return (new_vars, result_expr) } - where - -- Called once per equation in the match, or alternative in the case - mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) - = do { dflags <- getDynFlags - ; let upats = map (unLoc . decideBangHood dflags) pats - dicts = collectEvVarsPats upats - - ; match_result <- - -- Extend the environment with knowledge about - -- the matches before desguaring the RHS - -- See Note [Type and Term Equality Propagation] - applyWhen (needToRunPmCheck dflags origin) - (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars) - (dsGRHSs ctxt grhss rhs_ty) - - ; return (EqnInfo { eqn_pats = upats - , eqn_orig = FromSource - , eqn_rhs = match_result }) } - mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec - mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884 - - handleWarnings = if isGenerated origin - then discardWarningsDs - else id -matchWrapper _ _ (XMatchGroup nec) = noExtCon nec - -matchEquations :: HsMatchContext Name - -> [MatchId] -> [EquationInfo] -> Type - -> DsM CoreExpr -matchEquations ctxt vars eqns_info rhs_ty - = do { let error_doc = matchContextErrString ctxt - - ; match_result <- match vars rhs_ty eqns_info - - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc - ; extractMatchResult match_result fail_expr } - -{- -************************************************************************ -* * -\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} -* * -************************************************************************ - -@mkSimpleMatch@ is a wrapper for @match@ which deals with the -situation where we want to match a single expression against a single -pattern. It returns an expression. --} - -matchSimply :: CoreExpr -- ^ Scrutinee - -> HsMatchContext Name -- ^ Match kind - -> LPat GhcTc -- ^ Pattern it should match - -> CoreExpr -- ^ Return this if it matches - -> CoreExpr -- ^ Return this if it doesn't - -> DsM CoreExpr --- Do not warn about incomplete patterns; see matchSinglePat comments -matchSimply scrut hs_ctx pat result_expr fail_expr = do - let - match_result = cantFailMatchResult result_expr - rhs_ty = exprType fail_expr - -- Use exprType of fail_expr, because won't refine in the case of failure! - match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result - extractMatchResult match_result' fail_expr - -matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult --- matchSinglePat ensures that the scrutinee is a variable --- and then calls matchSinglePatVar --- --- matchSinglePat does not warn about incomplete patterns --- Used for things like [ e | pat <- stuff ], where --- incomplete patterns are just fine - -matchSinglePat (Var var) ctx pat ty match_result - | not (isExternalName (idName var)) - = matchSinglePatVar var ctx pat ty match_result - -matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL pat - ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result - ; return (adjustMatchResult (bindNonRec var scrut) match_result') } - -matchSinglePatVar :: Id -- See Note [Match Ids] - -> HsMatchContext Name -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult -matchSinglePatVar var ctx pat ty match_result - = ASSERT2( isInternalName (idName var), ppr var ) - do { dflags <- getDynFlags - ; locn <- getSrcSpanDs - - -- Pattern match check warnings - ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat) - - ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] - , eqn_orig = FromSource - , eqn_rhs = match_result } - ; match [var] ty [eqn_info] } - - -{- -************************************************************************ -* * - Pattern classification -* * -************************************************************************ --} - -data PatGroup - = PgAny -- Immediate match: variables, wildcards, - -- lazy patterns - | PgCon DataCon -- Constructor patterns (incl list, tuple) - | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups] - | PgLit Literal -- Literal patterns - | PgN Rational -- Overloaded numeric literals; - -- see Note [Don't use Literal for PgN] - | PgOverS FastString -- Overloaded string literals - | PgNpK Integer -- n+k patterns - | PgBang -- Bang patterns - | PgCo Type -- Coercion patterns; the type is the type - -- of the pattern *inside* - | PgView (LHsExpr GhcTc) -- view pattern (e -> p): - -- the LHsExpr is the expression e - Type -- the Type is the type of p (equivalently, the result type of e) - | PgOverloadedList - -{- Note [Don't use Literal for PgN] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously we had, as PatGroup constructors - - | ... - | PgN Literal -- Overloaded literals - | PgNpK Literal -- n+k patterns - | ... - -But Literal is really supposed to represent an *unboxed* literal, like Int#. -We were sticking the literal from, say, an overloaded numeric literal pattern -into a LitInt constructor. This didn't really make sense; and we now have -the invariant that value in a LitInt must be in the range of the target -machine's Int# type, and an overloaded literal could meaningfully be larger. - -Solution: For pattern grouping purposes, just store the literal directly in -the PgN constructor as a Rational if numeric, and add a PgOverStr constructor -for overloaded strings. --} - -groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] --- If the result is of form [g1, g2, g3], --- (a) all the (pg,eq) pairs in g1 have the same pg --- (b) none of the gi are empty --- The ordering of equations is unchanged -groupEquations dflags eqns - = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] - where - same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool - (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 - -subGroup :: (m -> [[EquationInfo]]) -- Map.elems - -> m -- Map.empty - -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup - -> (a -> [EquationInfo] -> m -> m) -- Map.insert - -> [(a, EquationInfo)] -> [[EquationInfo]] --- Input is a particular group. The result sub-groups the --- equations by with particular constructor, literal etc they match. --- Each sub-list in the result has the same PatGroup --- See Note [Take care with pattern order] --- Parameterized by map operations to allow different implementations --- and constraints, eg. types without Ord instance. -subGroup elems empty lookup insert group - = map reverse $ elems $ foldl' accumulate empty group - where - accumulate pg_map (pg, eqn) - = case lookup pg pg_map of - Just eqns -> insert pg (eqn:eqns) pg_map - Nothing -> insert pg [eqn] pg_map - -- pg_map :: Map a [EquationInfo] - -- Equations seen so far in reverse order of appearance - -subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] -subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert - -subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]] -subGroupUniq = - subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v) - -{- Note [Pattern synonym groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see - f (P a) = e1 - f (P b) = e2 - ... -where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the -same group? We can if P is a constructor, but /not/ if P is a pattern synonym. -Consider (#11224) - -- readMaybe :: Read a => String -> Maybe a - pattern PRead :: Read a => () => a -> String - pattern PRead a <- (readMaybe -> Just a) - - f (PRead (x::Int)) = e1 - f (PRead (y::Bool)) = e2 -This is all fine: we match the string by trying to read an Int; if that -fails we try to read a Bool. But clearly we can't combine the two into a single -match. - -Conclusion: we can combine when we invoke PRead /at the same type/. Hence -in PgSyn we record the instantiaing types, and use them in sameGroup. - -Note [Take care with pattern order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the subGroup function we must be very careful about pattern re-ordering, -Consider the patterns [ (True, Nothing), (False, x), (True, y) ] -Then in bringing together the patterns for True, we must not -swap the Nothing and y! --} - -sameGroup :: PatGroup -> PatGroup -> Bool --- Same group means that a single case expression --- or test will suffice to match both, *and* the order --- of testing within the group is insignificant. -sameGroup PgAny PgAny = True -sameGroup PgBang PgBang = True -sameGroup (PgCon _) (PgCon _) = True -- One case expression -sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2 - -- eqTypes: See Note [Pattern synonym groups] -sameGroup (PgLit _) (PgLit _) = True -- One case expression -sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant -sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 -sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] -sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 - -- CoPats are in the same goup only if the type of the - -- enclosed pattern is the same. The patterns outside the CoPat - -- always have the same type, so this boils down to saying that - -- the two coercions are identical. -sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) - -- ViewPats are in the same group iff the expressions - -- are "equal"---conservatively, we use syntactic equality -sameGroup _ _ = False - --- An approximation of syntactic equality used for determining when view --- exprs are in the same group. --- This function can always safely return false; --- but doing so will result in the application of the view function being repeated. --- --- Currently: compare applications of literals and variables --- and anything else that we can do without involving other --- HsSyn types in the recursion --- --- NB we can't assume that the two view expressions have the same type. Consider --- f (e1 -> True) = ... --- f (e2 -> "hi") = ... -viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool -viewLExprEq (e1,_) (e2,_) = lexp e1 e2 - where - lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool - lexp e e' = exp (unLoc e) (unLoc e') - - --------- - exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool - -- real comparison is on HsExpr's - -- strip parens - exp (HsPar _ (dL->L _ e)) e' = exp e e' - exp e (HsPar _ (dL->L _ e')) = exp e e' - -- because the expressions do not necessarily have the same type, - -- we have to compare the wrappers - exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' - exp (HsVar _ i) (HsVar _ i') = i == i' - exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' - -- the instance for IPName derives using the id, so this works if the - -- above does - exp (HsIPVar _ i) (HsIPVar _ i') = i == i' - exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' - exp (HsOverLit _ l) (HsOverLit _ l') = - -- Overloaded lits are equal if they have the same type - -- and the data is the same. - -- this is coarser than comparing the SyntaxExpr's in l and l', - -- which resolve the overloading (e.g., fromInteger 1), - -- because these expressions get written as a bunch of different variables - -- (presumably to improve sharing) - eqType (overLitType l) (overLitType l') && l == l' - exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' - -- the fixities have been straightened out by now, so it's safe - -- to ignore them? - exp (OpApp _ l o ri) (OpApp _ l' o' ri') = - lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' - exp (SectionL _ e1 e2) (SectionL _ e1' e2') = - lexp e1 e1' && lexp e2 e2' - exp (SectionR _ e1 e2) (SectionR _ e1' e2') = - lexp e1 e1' && lexp e2 e2' - exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = - eq_list tup_arg es1 es2 - exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' - exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = - lexp e e' && lexp e1 e1' && lexp e2 e2' - - -- Enhancement: could implement equality for more expressions - -- if it seems useful - -- But no need for HsLit, ExplicitList, ExplicitTuple, - -- because they cannot be functions - exp _ _ = False - - --------- - syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool - syn_exp (SyntaxExpr { syn_expr = expr1 - , syn_arg_wraps = arg_wraps1 - , syn_res_wrap = res_wrap1 }) - (SyntaxExpr { syn_expr = expr2 - , syn_arg_wraps = arg_wraps2 - , syn_res_wrap = res_wrap2 }) - = exp expr1 expr2 && - and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && - wrap res_wrap1 res_wrap2 - - --------- - tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2 - tup_arg (dL->L _ (Missing t1)) (dL->L _ (Missing t2)) = eqType t1 t2 - tup_arg _ _ = False - - --------- - wrap :: HsWrapper -> HsWrapper -> Bool - -- Conservative, in that it demands that wrappers be - -- syntactically identical and doesn't look under binders - -- - -- Coarser notions of equality are possible - -- (e.g., reassociating compositions, - -- equating different ways of writing a coercion) - wrap WpHole WpHole = True - wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' - wrap (WpCast co) (WpCast co') = co `eqCoercion` co' - wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 - wrap (WpTyApp t) (WpTyApp t') = eqType t t' - -- Enhancement: could implement equality for more wrappers - -- if it seems useful (lams and lets) - wrap _ _ = False - - --------- - ev_term :: EvTerm -> EvTerm -> Bool - ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b - ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b - ev_term _ _ = False - - --------- - eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool - eq_list _ [] [] = True - eq_list _ [] (_:_) = False - eq_list _ (_:_) [] = False - eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys - -patGroup :: DynFlags -> Pat GhcTc -> PatGroup -patGroup _ (ConPatOut { pat_con = (dL->L _ con) - , pat_arg_tys = tys }) - | RealDataCon dcon <- con = PgCon dcon - | PatSynCon psyn <- con = PgSyn psyn tys -patGroup _ (WildPat {}) = PgAny -patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) = - case (oval, isJust mb_neg) of - (HsIntegral i, False) -> PgN (fromInteger (il_value i)) - (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) - (HsFractional r, False) -> PgN (fl_value r) - (HsFractional r, True ) -> PgN (-fl_value r) - (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) - PgOverS s -patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) = - case oval of - HsIntegral i -> PgNpK (il_value i) - _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) - -- Type of innelexp pattern -patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList -patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) -patGroup _ pat = pprPanic "patGroup" (ppr pat) - -{- -Note [Grouping overloaded literal patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -WATCH OUT! Consider - - f (n+1) = ... - f (n+2) = ... - f (n+1) = ... - -We can't group the first and third together, because the second may match -the same thing as the first. Same goes for *overloaded* literal patterns - f 1 True = ... - f 2 False = ... - f 1 False = ... -If the first arg matches '1' but the second does not match 'True', we -cannot jump to the third equation! Because the same argument might -match '2'! -Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. --} diff --git a/deSugar/Match.hs-boot b/deSugar/Match.hs-boot deleted file mode 100644 --- a/deSugar/Match.hs-boot +++ /dev/null @@ -1,37 +0,0 @@ -module Match where - -import GhcPrelude -import Var ( Id ) -import TcType ( Type ) -import DsMonad ( DsM, EquationInfo, MatchResult ) -import CoreSyn ( CoreExpr ) -import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) -import Name ( Name ) -import GHC.Hs.Extension ( GhcTc ) - -match :: [Id] - -> Type - -> [EquationInfo] - -> DsM MatchResult - -matchWrapper - :: HsMatchContext Name - -> Maybe (LHsExpr GhcTc) - -> MatchGroup GhcTc (LHsExpr GhcTc) - -> DsM ([Id], CoreExpr) - -matchSimply - :: CoreExpr - -> HsMatchContext Name - -> LPat GhcTc - -> CoreExpr - -> CoreExpr - -> DsM CoreExpr - -matchSinglePatVar - :: Id - -> HsMatchContext Name - -> LPat GhcTc - -> Type - -> MatchResult - -> DsM MatchResult diff --git a/deSugar/MatchCon.hs b/deSugar/MatchCon.hs deleted file mode 100644 --- a/deSugar/MatchCon.hs +++ /dev/null @@ -1,296 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching constructors --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module MatchCon ( matchConFamily, matchPatSyn ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Match ( match ) - -import GHC.Hs -import DsBinds -import ConLike -import BasicTypes ( Origin(..) ) -import TcType -import DsMonad -import DsUtils -import MkCore ( mkCoreLets ) -import Util -import Id -import NameEnv -import FieldLabel ( flSelector ) -import SrcLoc -import Outputable -import Control.Monad(liftM) -import Data.List (groupBy) - -{- -We are confronted with the first column of patterns in a set of -equations, all beginning with constructors from one ``family'' (e.g., -@[]@ and @:@ make up the @List@ ``family''). We want to generate the -alternatives for a @Case@ expression. There are several choices: -\begin{enumerate} -\item -Generate an alternative for every constructor in the family, whether -they are used in this set of equations or not; this is what the Wadler -chapter does. -\begin{description} -\item[Advantages:] -(a)~Simple. (b)~It may also be that large sparsely-used constructor -families are mainly handled by the code for literals. -\item[Disadvantages:] -(a)~Not practical for large sparsely-used constructor families, e.g., -the ASCII character set. (b)~Have to look up a list of what -constructors make up the whole family. -\end{description} - -\item -Generate an alternative for each constructor used, then add a default -alternative in case some constructors in the family weren't used. -\begin{description} -\item[Advantages:] -(a)~Alternatives aren't generated for unused constructors. (b)~The -STG is quite happy with defaults. (c)~No lookup in an environment needed. -\item[Disadvantages:] -(a)~A spurious default alternative may be generated. -\end{description} - -\item -``Do it right:'' generate an alternative for each constructor used, -and add a default alternative if all constructors in the family -weren't used. -\begin{description} -\item[Advantages:] -(a)~You will get cases with only one alternative (and no default), -which should be amenable to optimisation. Tuples are a common example. -\item[Disadvantages:] -(b)~Have to look up constructor families in TDE (as above). -\end{description} -\end{enumerate} - -We are implementing the ``do-it-right'' option for now. The arguments -to @matchConFamily@ are the same as to @match@; the extra @Int@ -returned is the number of constructors in the family. - -The function @matchConFamily@ is concerned with this -have-we-used-all-the-constructors? question; the local function -@match_cons_used@ does all the real work. --} - -matchConFamily :: [Id] - -> Type - -> [[EquationInfo]] - -> DsM MatchResult --- Each group of eqns is for a single constructor -matchConFamily (var:vars) ty groups - = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups - return (mkCoAlgCaseMatchResult var ty alts) - where - toRealAlt alt = case alt_pat alt of - RealDataCon dcon -> alt{ alt_pat = dcon } - _ -> panic "matchConFamily: not RealDataCon" -matchConFamily [] _ _ = panic "matchConFamily []" - -matchPatSyn :: [Id] - -> Type - -> [EquationInfo] - -> DsM MatchResult -matchPatSyn (var:vars) ty eqns - = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns - return (mkCoSynCaseMatchResult var ty alt) - where - toSynAlt alt = case alt_pat alt of - PatSynCon psyn -> alt{ alt_pat = psyn } - _ -> panic "matchPatSyn: not PatSynCon" -matchPatSyn _ _ _ = panic "matchPatSyn []" - -type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) - -matchOneConLike :: [Id] - -> Type - -> [EquationInfo] - -> DsM (CaseAlt ConLike) -matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) - -- ex_tvs can only be tyvars as data types in source - -- Haskell cannot mention covar yet (Aug 2018). - ASSERT( tvs1 `equalLength` ex_tvs ) - arg_tys ++ mkTyVarTys tvs1 - - val_arg_tys = conLikeInstOrigArgTys con1 inst_tys - -- dataConInstOrigArgTys takes the univ and existential tyvars - -- and returns the types of the *value* args, which is what we want - - match_group :: [Id] - -> [(ConArgPats, EquationInfo)] -> DsM MatchResult - -- All members of the group have compatible ConArgPats - match_group arg_vars arg_eqn_prs - = ASSERT( notNull arg_eqn_prs ) - do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) - ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs - ; match_result <- match (group_arg_vars ++ vars) ty eqns' - ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } - - shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, - pat_binds = bind, pat_args = args - } : pats })) - = do ds_bind <- dsTcEvBinds bind - return ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets ds_bind - , eqn { eqn_orig = Generated - , eqn_pats = conArgPats val_arg_tys args ++ pats } - ) - shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) - - ; arg_vars <- selectConMatchVars val_arg_tys args1 - -- Use the first equation as a source of - -- suggestions for the new variables - - -- Divide into sub-groups; see Note [Record patterns] - ; let groups :: [[(ConArgPats, EquationInfo)]] - groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn) - | eqn <- eqn1:eqns ] - - ; match_results <- mapM (match_group arg_vars) groups - - ; return $ MkCaseAlt{ alt_pat = con1, - alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, - alt_wrapper = wrapper1, - alt_result = foldr1 combineMatchResults match_results } } - where - ConPatOut { pat_con = (dL->L _ con1) - , pat_arg_tys = arg_tys, pat_wrap = wrapper1, - pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } - = firstPat eqn1 - fields1 = map flSelector (conLikeFieldLabels con1) - - ex_tvs = conLikeExTyCoVars con1 - - -- Choose the right arg_vars in the right order for this group - -- Note [Record patterns] - select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id] - select_arg_vars arg_vars ((arg_pats, _) : _) - | RecCon flds <- arg_pats - , let rpats = rec_flds flds - , not (null rpats) -- Treated specially; cf conArgPats - = ASSERT2( fields1 `equalLength` arg_vars, - ppr con1 $$ ppr fields1 $$ ppr arg_vars ) - map lookup_fld rpats - | otherwise - = arg_vars - where - fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars - lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env - (idName (unLoc (hsRecFieldId rpat))) - select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" -matchOneConLike _ _ [] = panic "matchOneCon []" - ------------------ -compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool --- Two constructors have compatible argument patterns if the number --- and order of sub-matches is the same in both cases -compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2 -compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) -compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) -compatible_pats _ _ = True -- Prefix or infix con - -same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) - -> Bool -same_fields flds1 flds2 - = all2 (\(dL->L _ f1) (dL->L _ f2) - -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) - (rec_flds flds1) (rec_flds flds2) - - ------------------ -selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys -selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) -selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] - -conArgPats :: [Type] -- Instantiated argument types - -- Used only to fill in the types of WildPats, which - -- are probably never looked at anyway - -> ConArgPats - -> [Pat GhcTc] -conArgPats _arg_tys (PrefixCon ps) = map unLoc ps -conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] -conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) - | null rpats = map WildPat arg_tys - -- Important special case for C {}, which can be used for a - -- datacon that isn't declared to have fields at all - | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats - -{- -Note [Record patterns] -~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = T { x,y,z :: Bool } - - f (T { y=True, x=False }) = ... - -We must match the patterns IN THE ORDER GIVEN, thus for the first -one we match y=True before x=False. See #246; or imagine -matching against (T { y=False, x=undefined }): should fail without -touching the undefined. - -Now consider: - - f (T { y=True, x=False }) = ... - f (T { x=True, y= False}) = ... - -In the first we must test y first; in the second we must test x -first. So we must divide even the equations for a single constructor -T into sub-goups, based on whether they match the same field in the -same order. That's what the (groupBy compatible_pats) grouping. - -All non-record patterns are "compatible" in this sense, because the -positional patterns (T a b) and (a `T` b) all match the arguments -in order. Also T {} is special because it's equivalent to (T _ _). -Hence the (null rpats) checks here and there. - - -Note [Existentials in shift_con_pat] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = forall a. Ord a => T a (a->Int) - - f (T x f) True = ...expr1... - f (T y g) False = ...expr2.. - -When we put in the tyvars etc we get - - f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1... - f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2... - -After desugaring etc we'll get a single case: - - f = \t::T b::Bool -> - case t of - T a (d::Ord a) (x::a) (f::a->Int)) -> - case b of - True -> ...expr1... - False -> ...expr2... - -*** We have to substitute [a/b, d/e] in expr2! ** -Hence - False -> ....((/\b\(e:Ord b).expr2) a d).... - -Originally I tried to use - (\b -> let e = d in expr2) a -to do this substitution. While this is "correct" in a way, it fails -Lint, because e::Ord b but d::Ord a. - --} diff --git a/deSugar/MatchLit.hs b/deSugar/MatchLit.hs deleted file mode 100644 --- a/deSugar/MatchLit.hs +++ /dev/null @@ -1,521 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching literal patterns --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -module MatchLit ( dsLit, dsOverLit, hsLitKey - , tidyLitPat, tidyNPat - , matchLiterals, matchNPlusKPats, matchNPats - , warnAboutIdentities - , warnAboutOverflowedOverLit, warnAboutOverflowedLit - , warnAboutEmptyEnumerations - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Match ( match ) -import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr ) - -import DsMonad -import DsUtils - -import GHC.Hs - -import Id -import CoreSyn -import MkCore -import TyCon -import DataCon -import TcHsSyn ( shortCutLit ) -import TcType -import Name -import Type -import PrelNames -import TysWiredIn -import TysPrim -import Literal -import SrcLoc -import Data.Ratio -import Outputable -import BasicTypes -import DynFlags -import Util -import FastString -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Int -import Data.Word -import Data.Proxy - -{- -************************************************************************ -* * - Desugaring literals - [used to be in DsExpr, but DsMeta needs it, - and it's nice to avoid a loop] -* * -************************************************************************ - -We give int/float literals type @Integer@ and @Rational@, respectively. -The typechecker will (presumably) have put \tr{from{Integer,Rational}s} -around them. - -ToDo: put in range checks for when converting ``@i@'' -(or should that be in the typechecker?) - -For numeric literals, we try to detect there use at a standard type -(@Int@, @Float@, etc.) are directly put in the right constructor. -[NB: down with the @App@ conversion.] - -See also below where we look for @DictApps@ for \tr{plusInt}, etc. --} - -dsLit :: HsLit GhcRn -> DsM CoreExpr -dsLit l = do - dflags <- getDynFlags - case l of - HsStringPrim _ s -> return (Lit (LitString s)) - HsCharPrim _ c -> return (Lit (LitChar c)) - HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i)) - HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w)) - HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i)) - HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w)) - HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) - HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) - HsChar _ c -> return (mkCharExpr c) - HsString _ str -> mkStringExprFS str - HsInteger _ i _ -> mkIntegerExpr i - HsInt _ i -> return (mkIntExpr dflags (il_value i)) - XLit nec -> noExtCon nec - HsRat _ (FL _ _ val) ty -> do - num <- mkIntegerExpr (numerator val) - denom <- mkIntegerExpr (denominator val) - return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) - where - (ratio_data_con, integer_ty) - = case tcSplitTyConApp ty of - (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) - (head (tyConDataCons tycon), i_ty) - x -> pprPanic "dsLit" (ppr x) - -dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr --- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains --- (an expression for) the literal value itself. -dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty - , ol_witness = witness }) = do - dflags <- getDynFlags - case shortCutLit dflags val ty of - Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] - _ -> dsExpr witness -dsOverLit (XOverLit nec) = noExtCon nec -{- -Note [Literal short cut] -~~~~~~~~~~~~~~~~~~~~~~~~ -The type checker tries to do this short-cutting as early as possible, but -because of unification etc, more information is available to the desugarer. -And where it's possible to generate the correct literal right away, it's -much better to do so. - - -************************************************************************ -* * - Warnings about overflowed literals -* * -************************************************************************ - -Warn about functions like toInteger, fromIntegral, that convert -between one type and another when the to- and from- types are the -same. Then it's probably (albeit not definitely) the identity --} - -warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () -warnAboutIdentities dflags (Var conv_fn) type_of_conv - | wopt Opt_WarnIdentities dflags - , idName conv_fn `elem` conversionNames - , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv - , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = warnDs (Reason Opt_WarnIdentities) - (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv - , nest 2 $ text "can probably be omitted" - ]) -warnAboutIdentities _ _ _ = return () - -conversionNames :: [Name] -conversionNames - = [ toIntegerName, toRationalName - , fromIntegralName, realToFracName ] - -- We can't easily add fromIntegerName, fromRationalName, - -- because they are generated by literals - - --- | Emit warnings on overloaded integral literals which overflow the bounds --- implied by their type. -warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () -warnAboutOverflowedOverLit hsOverLit = do - dflags <- getDynFlags - warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit) - --- | Emit warnings on integral literals which overflow the boudns implied by --- their type. -warnAboutOverflowedLit :: HsLit GhcTc -> DsM () -warnAboutOverflowedLit hsLit = do - dflags <- getDynFlags - warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit) - --- | Emit warnings on integral literals which overflow the bounds implied by --- their type. -warnAboutOverflowedLiterals - :: DynFlags - -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon - -> DsM () -warnAboutOverflowedLiterals dflags lit - | wopt Opt_WarnOverflowedLiterals dflags - , Just (i, tc) <- lit - = if tc == intTyConName then check i tc (Proxy :: Proxy Int) - - -- These only show up via the 'HsOverLit' route - else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) - else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) - else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) - else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) - else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) - else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) - else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) - else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) - else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) - else if tc == naturalTyConName then checkPositive i tc - - -- These only show up via the 'HsLit' route - else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int) - else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8) - else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32) - else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64) - else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word) - else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8) - else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32) - else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64) - - else return () - - | otherwise = return () - where - - checkPositive :: Integer -> Name -> DsM () - checkPositive i tc - = when (i < 0) $ do - warnDs (Reason Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is negative but" <+> ppr tc - <+> ptext (sLit "only supports positive numbers") - ]) - - check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () - check i tc _proxy - = when (i < minB || i > maxB) $ do - warnDs (Reason Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") - <+> integer minB <> text ".." <> integer maxB - , sug ]) - where - minB = toInteger (minBound :: a) - maxB = toInteger (maxBound :: a) - sug | minB == -i -- Note [Suggest NegativeLiterals] - , i > 0 - , not (xopt LangExt.NegativeLiterals dflags) - = text "If you are trying to write a large negative literal, use NegativeLiterals" - | otherwise = Outputable.empty - -{- -Note [Suggest NegativeLiterals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you write - x :: Int8 - x = -128 -it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. -We get an erroneous suggestion for - x = 128 -but perhaps that does not matter too much. --} - -warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) - -> LHsExpr GhcTc -> DsM () --- ^ Warns about @[2,3 .. 1]@ which returns the empty list. --- Only works for integral types, not floating point. -warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr - | wopt Opt_WarnEmptyEnumerations dflags - , Just (from,tc) <- getLHsIntegralLit fromExpr - , Just mThn <- traverse getLHsIntegralLit mThnExpr - , Just (to,_) <- getLHsIntegralLit toExpr - , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () - check _proxy - = when (null enumeration) $ - warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") - where - enumeration :: [a] - enumeration = case mThn of - Nothing -> [fromInteger from .. fromInteger to] - Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] - - = if tc == intTyConName then check (Proxy :: Proxy Int) - else if tc == int8TyConName then check (Proxy :: Proxy Int8) - else if tc == int16TyConName then check (Proxy :: Proxy Int16) - else if tc == int32TyConName then check (Proxy :: Proxy Int32) - else if tc == int64TyConName then check (Proxy :: Proxy Int64) - else if tc == wordTyConName then check (Proxy :: Proxy Word) - else if tc == word8TyConName then check (Proxy :: Proxy Word8) - else if tc == word16TyConName then check (Proxy :: Proxy Word16) - else if tc == word32TyConName then check (Proxy :: Proxy Word32) - else if tc == word64TyConName then check (Proxy :: Proxy Word64) - else if tc == integerTyConName then check (Proxy :: Proxy Integer) - else if tc == naturalTyConName then check (Proxy :: Proxy Integer) - -- We use 'Integer' because otherwise a negative 'Natural' literal - -- could cause a compile time crash (instead of a runtime one). - -- See the T10930b test case for an example of where this matters. - else return () - - | otherwise = return () - -getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) --- ^ See if the expression is an 'Integral' literal. --- Remember to look through automatically-added tick-boxes! (#8384) -getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit -getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit -getLHsIntegralLit _ = Nothing - --- | If 'Integral', extract the value and type name of the overloaded literal. -getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) -getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) - | Just tc <- tyConAppTyCon_maybe ty - = Just (il_value i, tyConName tc) -getIntegralLit _ = Nothing - --- | If 'Integral', extract the value and type name of the non-overloaded --- literal. -getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name) -getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName) -getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName) -getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName) -getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName) -getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName) -getSimpleIntegralLit (HsInteger _ i ty) - | Just tc <- tyConAppTyCon_maybe ty - = Just (i, tyConName tc) -getSimpleIntegralLit _ = Nothing - -{- -************************************************************************ -* * - Tidying lit pats -* * -************************************************************************ --} - -tidyLitPat :: HsLit GhcTc -> Pat GhcTc --- Result has only the following HsLits: --- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim --- HsDoublePrim, HsStringPrim, HsString --- * HsInteger, HsRat, HsInt can't show up in LitPats --- * We get rid of HsChar right here -tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) -tidyLitPat (HsString src s) - | lengthFS s <= 1 -- Short string literals only - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon - [mkCharLitPat src c, pat] [charTy]) - (mkNilPat charTy) (unpackFS s) - -- The stringTy is the type of the whole pattern, not - -- the type to instantiate (:) or [] with! -tidyLitPat lit = LitPat noExtField lit - ----------------- -tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc - -> Type - -> Pat GhcTc -tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty - -- False: Take short cuts only if the literal is not using rebindable syntax - -- - -- Once that is settled, look for cases where the type of the - -- entire overloaded literal matches the type of the underlying literal, - -- and in that case take the short cut - -- NB: Watch out for weird cases like #3382 - -- f :: Int -> Int - -- f "blah" = 4 - -- which might be ok if we have 'instance IsString Int' - -- - | not type_change, isIntTy ty, Just int_lit <- mb_int_lit - = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) - | not type_change, isWordTy ty, Just int_lit <- mb_int_lit - = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) - | not type_change, isStringTy ty, Just str_lit <- mb_str_lit - = tidyLitPat (HsString NoSourceText str_lit) - -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 - -- If we do convert to the constructor form, we'll generate a case - -- expression on a Float# or Double# and that's not allowed in Core; see - -- #9238 and Note [Rules for floating-point comparisons] in PrelRules - where - -- Sometimes (like in test case - -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include - -- type-changing wrappers (for example, from Id Int to Int, for the identity - -- type family Id). In these cases, we can't do the short-cut. - type_change = not (outer_ty `eqType` ty) - - mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc - mk_con_pat con lit - = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] []) - - mb_int_lit :: Maybe Integer - mb_int_lit = case (mb_neg, val) of - (Nothing, HsIntegral i) -> Just (il_value i) - (Just _, HsIntegral i) -> Just (-(il_value i)) - _ -> Nothing - - mb_str_lit :: Maybe FastString - mb_str_lit = case (mb_neg, val) of - (Nothing, HsIsString _ s) -> Just s - _ -> Nothing - -tidyNPat over_lit mb_neg eq outer_ty - = NPat outer_ty (noLoc over_lit) mb_neg eq - -{- -************************************************************************ -* * - Pattern matching on LitPat -* * -************************************************************************ --} - -matchLiterals :: [Id] - -> Type -- Type of the whole case expression - -> [[EquationInfo]] -- All PgLits - -> DsM MatchResult - -matchLiterals (var:vars) ty sub_groups - = ASSERT( notNull sub_groups && all notNull sub_groups ) - do { -- Deal with each group - ; alts <- mapM match_group sub_groups - - -- Combine results. For everything except String - -- we can use a case expression; for String we need - -- a chain of if-then-else - ; if isStringTy (idType var) then - do { eq_str <- dsLookupGlobalId eqStringName - ; mrs <- mapM (wrap_str_guard eq_str) alts - ; return (foldr1 combineMatchResults mrs) } - else - return (mkCoPrimCaseMatchResult var ty alts) - } - where - match_group :: [EquationInfo] -> DsM (Literal, MatchResult) - match_group eqns - = do { dflags <- getDynFlags - ; let LitPat _ hs_lit = firstPat (head eqns) - ; match_result <- match vars ty (shiftEqns eqns) - ; return (hsLitKey dflags hs_lit, match_result) } - - wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult - -- Equality check for string literals - wrap_str_guard eq_str (LitString s, mr) - = do { -- We now have to convert back to FastString. Perhaps there - -- should be separate LitBytes and LitString constructors? - let s' = mkFastStringByteString s - ; lit <- mkStringExprFS s' - ; let pred = mkApps (Var eq_str) [Var var, lit] - ; return (mkGuardedMatchResult pred mr) } - wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) - -matchLiterals [] _ _ = panic "matchLiterals []" - ---------------------------- -hsLitKey :: DynFlags -> HsLit GhcTc -> Literal --- Get the Core literal corresponding to a HsLit. --- It only works for primitive types and strings; --- others have been removed by tidy --- For HsString, it produces a LitString, which really represents an _unboxed_ --- string literal; and we deal with it in matchLiterals above. Otherwise, it --- produces a primitive Literal of type matching the original HsLit. --- In the case of the fixed-width numeric types, we need to wrap here --- because Literal has an invariant that the literal is in range, while --- HsLit does not. -hsLitKey dflags (HsIntPrim _ i) = mkLitIntWrap dflags i -hsLitKey dflags (HsWordPrim _ w) = mkLitWordWrap dflags w -hsLitKey dflags (HsInt64Prim _ i) = mkLitInt64Wrap dflags i -hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w -hsLitKey _ (HsCharPrim _ c) = mkLitChar c -hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) -hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) -hsLitKey _ (HsString _ s) = LitString (bytesFS s) -hsLitKey _ l = pprPanic "hsLitKey" (ppr l) - -{- -************************************************************************ -* * - Pattern matching on NPat -* * -************************************************************************ --} - -matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1 - ; lit_expr <- dsOverLit lit - ; neg_lit <- case mb_neg of - Nothing -> return lit_expr - Just neg -> dsSyntaxExpr neg [lit_expr] - ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] - ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) - ; return (mkGuardedMatchResult pred_expr match_result) } -matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) - -{- -************************************************************************ -* * - Pattern matching on n+k patterns -* * -************************************************************************ - -For an n+k pattern, we use the various magic expressions we've been given. -We generate: -\begin{verbatim} - if ge var lit then - let n = sub var lit - in - else - -\end{verbatim} --} - -matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult --- All NPlusKPats, for the *same* literal k -matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus - = firstPat eqn1 - ; lit1_expr <- dsOverLit lit1 - ; lit2_expr <- dsOverLit lit2 - ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] - ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] - ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) - ; match_result <- match vars ty eqns' - ; return (mkGuardedMatchResult pred_expr $ - mkCoLetMatchResult (NonRec n1 minusk_expr) $ - adjustMatchResult (foldr1 (.) wraps) $ - match_result) } - where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats }) - = (wrapBind n n1, eqn { eqn_pats = pats }) - -- The wrapBind is a no-op for the first equation - shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) - -matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -2,7 +2,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 8.10.7 +Version: 9.0.2 License: BSD3 License-File: LICENSE Author: The GHC Team @@ -16,9 +16,12 @@ include loading Haskell code dynamically in a GHCi-like manner. For this reason, a lot of GHC's functionality is made available through this package. + . + See + for more information. Category: Development Build-Type: Simple -Cabal-Version: >=1.10 +Cabal-Version: 2.0 Flag ghci Description: Build GHCi support. @@ -45,16 +48,6 @@ Default: True Manual: True -Flag integer-simple - Description: Use integer-simple - Manual: True - Default: False - -Flag integer-gmp - Description: Use integer-gmp - Manual: True - Default: False - Flag dynamic-system-linker Description: The system can load dynamic code. This is not the case for musl. Default: True @@ -64,26 +57,27 @@ Default-Language: Haskell2010 Exposed: False - Build-Depends: base >= 4.11 && < 4.15, + Build-Depends: base >= 4.11 && < 4.16, deepseq >= 1.4 && < 1.5, directory >= 1 && < 1.4, process >= 1 && < 1.7, bytestring >= 0.9 && < 0.11, binary == 0.8.*, time >= 1.4 && < 1.10, - containers >= 0.5 && < 0.7, + containers >= 0.6.2.1 && < 0.7, array >= 0.1 && < 0.6, filepath >= 1 && < 1.5, - template-haskell == 2.16.*, + template-haskell == 2.17.*, hpc == 0.6.*, transformers == 0.5.*, - ghc-boot == 8.10.7, - ghc-boot-th == 8.10.7, - ghc-heap == 8.10.7, - ghci == 8.10.7 + exceptions == 0.10.*, + ghc-boot == 9.0.2, + ghc-boot-th == 9.0.2, + ghc-heap == 9.0.2, + ghci == 9.0.2 if os(windows) - Build-Depends: Win32 >= 2.3 && < 2.7 + Build-Depends: Win32 >= 2.3 && < 2.13 else if flag(terminfo) Build-Depends: terminfo == 0.4.* @@ -98,26 +92,11 @@ CPP-Options: -DHAVE_INTERNAL_INTERPRETER -- Include-Dirs: ../rts/dist/build - -- sanity-check to ensure not more than one integer flag is set - if flag(integer-gmp) && flag(integer-simple) - build-depends: invalid-cabal-flag-settings<0 - - -- gmp internals are used by the GHCi debugger if available - if flag(integer-gmp) - CPP-Options: -DINTEGER_GMP - build-depends: integer-gmp >= 1.0.2 - - -- simple internals are used by the GHCi debugger if available - if flag(integer-simple) - CPP-Options: -DINTEGER_SIMPLE - build-depends: integer-simple >= 0.1.1.1 - -- if no dynamic system linker is available, don't try DLLs. if flag(dynamic-system-linker) CPP-Options: -DCAN_LOAD_DLL Other-Extensions: - BangPatterns CPP DataKinds DeriveDataTypeable @@ -136,7 +115,6 @@ NondecreasingIndentation RankNTypes RecordWildCards - ScopedTypeVariables StandaloneDeriving Trustworthy TupleSections @@ -145,141 +123,139 @@ UnboxedTuples UndecidableInstances - Include-Dirs: . parser utils + Include-Dirs: . -- We need to set the unit id to ghc (without a version number) -- as it's magic. GHC-Options: -this-unit-id ghc + -- if flag(stage1) + -- Include-Dirs: stage1 + -- else + -- if flag(stage2) + -- Include-Dirs: stage2 + -- else + -- if flag(stage3) + -- Include-Dirs: stage2 + Install-Includes: HsVersions.h c-sources: - parser/cutils.c - ghci/keepCAFsForGHCi.c + cbits/cutils.c cbits/genSym.c + cbits/keepCAFsForGHCi.c hs-source-dirs: . - backpack - basicTypes - cmm - coreSyn - deSugar - ghci - iface - llvmGen - main - nativeGen - parser - prelude - profiling - rename - simplCore - simplStg - specialise - stgSyn - stranal - typecheck - types - utils - hieFile -- we use an explicit Prelude Default-Extensions: NoImplicitPrelude + ,BangPatterns + ,ScopedTypeVariables Exposed-Modules: - HieTypes - HieDebug - HieBin - HieUtils - HieAst - Ar - FileCleanup - DriverBkp - BkpSyn - NameShape - RnModIface - Avail - AsmUtils - BasicTypes - ConLike - DataCon - PatSyn - Demand - Debug - Exception - FieldLabel - GhcMonad - Hooks - Id - IdInfo - Predicate - Lexeme - Literal - Llvm - Llvm.AbsSyn - Llvm.MetaData - Llvm.PpLlvm - Llvm.Types - LlvmCodeGen - LlvmCodeGen.Base - LlvmCodeGen.CodeGen - LlvmCodeGen.Data - LlvmCodeGen.Ppr - LlvmCodeGen.Regs - LlvmMangler - MkId - Module - Name - NameEnv - NameSet - OccName - RdrName - NameCache - SrcLoc - UniqSupply - Unique - Var - VarEnv - VarSet - UnVarGraph - BlockId - CLabel - Cmm - CmmBuildInfoTables - CmmPipeline - CmmCallConv - CmmCommonBlockElim - CmmImplementSwitchPlans - CmmContFlowOpt - CmmExpr - CmmInfo - CmmLex - CmmLint - CmmLive - CmmMachOp - CmmMonad - CmmSwitch - CmmNode - CmmOpt - CmmParse - CmmProcPoint - CmmSink - CmmType - CmmUtils - CmmLayoutStack - CliOption - EnumSet - GhcNameVersion - FileSettings - MkGraph - PprBase - PprC - PprCmm - PprCmmDecl - PprCmmExpr - Bitmap + GHC.Iface.Ext.Types + GHC.Iface.Ext.Debug + GHC.Iface.Ext.Binary + GHC.Iface.Ext.Utils + GHC.Iface.Ext.Ast + GHC.SysTools.Ar + GHC.SysTools.FileCleanup + GHC.Driver.Backend + GHC.Driver.Backpack + GHC.Driver.Backpack.Syntax + GHC.Types.Name.Shape + GHC.Iface.Rename + GHC.Types.Avail + GHC.Utils.Asm + GHC.Types.Basic + GHC.Core.ConLike + GHC.Core.DataCon + GHC.Core.PatSyn + GHC.Types.Demand + GHC.Types.Cpr + GHC.Cmm.DebugBlock + GHC.Utils.Exception + GHC.Types.FieldLabel + GHC.Driver.Monad + GHC.Driver.Hooks + GHC.Driver.Flags + GHC.Driver.Ways + GHC.Types.Id + GHC.Types.Id.Info + GHC.Core.Predicate + GHC.Utils.Lexeme + GHC.Types.Literal + GHC.Llvm + GHC.Llvm.Syntax + GHC.Llvm.MetaData + GHC.Llvm.Ppr + GHC.Llvm.Types + GHC.CmmToLlvm + GHC.CmmToLlvm.Base + GHC.CmmToLlvm.CodeGen + GHC.CmmToLlvm.Data + GHC.CmmToLlvm.Ppr + GHC.CmmToLlvm.Regs + GHC.CmmToLlvm.Mangler + GHC.Types.Id.Make + GHC.Unit + GHC.Unit.Parser + GHC.Unit.Ppr + GHC.Unit.Types + GHC.Unit.Module + GHC.Unit.Module.Name + GHC.Unit.Module.Location + GHC.Unit.Module.Env + GHC.Types.Name + GHC.Types.Name.Env + GHC.Types.Name.Set + GHC.Types.Name.Occurrence + GHC.Types.Name.Reader + GHC.Types.Name.Cache + GHC.Types.SrcLoc + GHC.Types.Unique.Supply + GHC.Types.Unique + GHC.Types.Var + GHC.Types.Var.Env + GHC.Types.Var.Set + GHC.Data.Graph.UnVar + GHC.Cmm.BlockId + GHC.Cmm.CLabel + GHC.Cmm + GHC.Cmm.Info.Build + GHC.Cmm.Pipeline + GHC.Cmm.CallConv + GHC.Cmm.CommonBlockElim + GHC.Cmm.Switch.Implement + GHC.Cmm.ContFlowOpt + GHC.Cmm.Expr + GHC.Cmm.Info + GHC.Cmm.Lexer + GHC.Cmm.Lint + GHC.Cmm.Liveness + GHC.Cmm.MachOp + GHC.Cmm.Monad + GHC.Cmm.Switch + GHC.Cmm.Node + GHC.Cmm.Opt + GHC.Cmm.Parser + GHC.Cmm.ProcPoint + GHC.Cmm.Sink + GHC.Cmm.Type + GHC.Cmm.Utils + GHC.Cmm.LayoutStack + GHC.Utils.CliOption + GHC.Data.EnumSet + GHC.Cmm.Graph + GHC.CmmToAsm.Ppr + GHC.CmmToAsm.Config + GHC.CmmToC + GHC.Cmm.Ppr + GHC.Cmm.Ppr.Decl + GHC.Cmm.Ppr.Expr + GHC.Data.Bitmap GHC.Platform.Regs GHC.Platform.ARM GHC.Platform.AArch64 @@ -307,43 +283,44 @@ GHC.StgToCmm.Ticky GHC.StgToCmm.Utils GHC.StgToCmm.ExtCode - SMRep - CoreArity - CoreFVs - CoreLint - CorePrep - CoreSubst - CoreOpt - CoreSyn - TrieMap - CoreTidy - CoreUnfold - CoreUtils - CoreMap - CoreSeq - CoreStats - MkCore - PprCore + GHC.StgToCmm.Types + GHC.Runtime.Heap.Layout + GHC.Core.Opt.Arity + GHC.Core.FVs + GHC.Core.Lint + GHC.Core.Subst + GHC.Core.SimpleOpt + GHC.Core + GHC.Data.TrieMap + GHC.Core.Tidy + GHC.Core.Unfold + GHC.Core.Utils + GHC.Core.Map + GHC.Core.Seq + GHC.Core.Stats + GHC.Core.Make + GHC.Core.Ppr GHC.HsToCore.PmCheck.Oracle GHC.HsToCore.PmCheck.Ppr GHC.HsToCore.PmCheck.Types GHC.HsToCore.PmCheck - Coverage - Desugar - DsArrows - DsBinds - DsCCall - DsExpr - DsForeign - DsGRHSs - DsListComp - DsMonad - DsUsage - DsUtils - ExtractDocs - Match - MatchCon - MatchLit + GHC.HsToCore.Coverage + GHC.Data.UnionFind + GHC.HsToCore + GHC.HsToCore.Arrows + GHC.HsToCore.Binds + GHC.HsToCore.Foreign.Call + GHC.HsToCore.Expr + GHC.HsToCore.Foreign.Decl + GHC.HsToCore.GuardedRHSs + GHC.HsToCore.ListComp + GHC.HsToCore.Monad + GHC.HsToCore.Usage + GHC.HsToCore.Utils + GHC.HsToCore.Docs + GHC.HsToCore.Match + GHC.HsToCore.Match.Constructor + GHC.HsToCore.Match.Literal GHC.Hs GHC.Hs.Binds GHC.Hs.Decls @@ -351,319 +328,322 @@ GHC.Hs.Expr GHC.Hs.ImpExp GHC.Hs.Lit - GHC.Hs.PlaceHolder GHC.Hs.Extension GHC.Hs.Instances GHC.Hs.Pat - GHC.Hs.Types + GHC.Hs.Type GHC.Hs.Utils GHC.Hs.Dump - BinIface - BinFingerprint - BuildTyCl - IfaceEnv - IfaceSyn - IfaceType - ToIface - LoadIface - MkIface - TcIface - FlagChecker - Annotations - CmdLineParser - CodeOutput - Config - Constants - DriverMkDepend - DriverPhases - PipelineMonad - DriverPipeline - DynFlags - ErrUtils - Finder + GHC.Iface.Binary + GHC.Iface.Recomp.Binary + GHC.Tc.TyCl.Build + GHC.Iface.Env + GHC.Iface.Syntax + GHC.Iface.Type + GHC.CoreToIface + GHC.Iface.Load + GHC.Iface.Make + GHC.Iface.Recomp + GHC.IfaceToCore + GHC.Iface.Recomp.Flags + GHC.Types.Annotations + GHC.Driver.CmdLine + GHC.Driver.CodeOutput + GHC.Settings.Constants + GHC.Driver.MakeFile + GHC.Driver.Phases + GHC.Driver.Pipeline.Monad + GHC.Driver.Pipeline + GHC.Driver.Session + GHC.Utils.Error + GHC.Driver.Finder GHC - GhcMake - GhcPlugins - GhcPrelude - DynamicLoading - HeaderInfo - HscMain - HscStats - HscTypes - InteractiveEval - InteractiveEvalTypes - PackageConfig - Packages - PlatformConstants - Plugins - TcPluginM - PprTyThing - Settings - StaticPtrTable - SysTools - SysTools.BaseDir - SysTools.Terminal - SysTools.ExtraObj - SysTools.Info - SysTools.Process - SysTools.Tasks - SysTools.Settings - Elf - TidyPgm - Ctype - HaddockUtils - Lexer - OptCoercion - Parser - RdrHsSyn - ApiAnnotation - ForeignCall - KnownUniques - PrelInfo - PrelNames - PrelRules - PrimOp - ToolSettings - TysPrim - TysWiredIn - CostCentre - CostCentreState - ProfInit - RnBinds - RnEnv - RnExpr - RnHsDoc - RnNames - RnPat - RnSource - RnSplice - RnTypes - RnFixity - RnUtils - RnUnbound - CoreMonad - CSE - FloatIn - FloatOut - LiberateCase - OccurAnal - SAT - SetLevels - SimplCore - SimplEnv - SimplMonad - SimplUtils - Simplify - SimplStg - StgStats - StgCse - StgLiftLams - StgLiftLams.Analysis - StgLiftLams.LiftM - StgLiftLams.Transformation - StgSubst - UnariseStg - RepType - Rules - SpecConstr - Specialise - CoreToStg - StgLint - StgSyn - StgFVs - CallArity - DmdAnal - Exitify - WorkWrap - WwLib - FamInst - ClsInst - Inst - TcAnnotations - TcArrows - TcBinds - TcSigs - TcClassDcl - TcDefaults - TcDeriv - TcDerivInfer - TcDerivUtils - TcEnv - TcExpr - TcForeign - TcGenDeriv - TcGenFunctor - TcGenGenerics - TcHsSyn - TcHsType - TcInstDcls - TcMType - TcValidity - TcMatches - TcPat - TcPatSyn - TcRnDriver - TcBackpack - TcRnExports - TcRnMonad - TcRnTypes - Constraint - TcOrigin - TcRules - TcSimplify - TcHoleErrors - TcHoleFitTypes - TcErrors - TcTyClsDecls - TcTyDecls - TcTypeable - TcType - TcEvidence - TcEvTerm - TcUnify - TcInteract - TcCanonical - TcFlatten - TcSMonad - TcTypeNats - TcSplice - Class - Coercion - DsMeta - THNames - FamInstEnv - FunDeps - InstEnv - TyCon - CoAxiom - Type - TyCoRep - TyCoFVs - TyCoSubst - TyCoPpr - TyCoTidy - Unify - Bag - Binary - BooleanFormula - BufWrite - Digraph - Encoding - FastFunctions - FastMutInt - FastString - FastStringEnv - Fingerprint - FiniteMap - FV - GraphBase - GraphColor - GraphOps - GraphPpr - IOEnv - Json - ListSetOps - Maybes - MonadUtils - OrdList - Outputable - Pair - Panic - PlainPanic - PprColour - Pretty - State - Stream - StringBuffer - UniqDFM - UniqDSet - UniqFM - UniqMap - UniqSet - Util - Hoopl.Block - Hoopl.Collections - Hoopl.Dataflow - Hoopl.Graph - Hoopl.Label --- CgInfoTbls used in ghci/DebuggerUtils --- CgHeapery mkVirtHeapOffsets used in ghci + GHC.Driver.Make + GHC.Plugins + GHC.Prelude + GHC.Parser.Header + GHC.Driver.Main + GHC.Hs.Stats + GHC.Driver.Types + GHC.Runtime.Eval + GHC.Runtime.Eval.Types + GHC.Runtime.Loader + GHC.Unit.Info + GHC.Unit.State + GHC.Driver.Plugins + GHC.Tc.Plugin + GHC.Core.Ppr.TyThing + GHC.Settings + GHC.Iface.Tidy.StaticPtrTable + GHC.SysTools + GHC.SysTools.BaseDir + GHC.SysTools.Terminal + GHC.SysTools.ExtraObj + GHC.SysTools.Info + GHC.SysTools.Process + GHC.SysTools.Tasks + GHC.Settings.IO + GHC.SysTools.Elf + GHC.Iface.Tidy + GHC.Parser.CharClass + GHC.Parser.Lexer + GHC.Core.Coercion.Opt + GHC.Parser + GHC.Parser.PostProcess + GHC.Parser.PostProcess.Haddock + GHC.Parser.Annotation + GHC.Types.ForeignCall + GHC.Builtin.Uniques + GHC.Builtin.Utils + GHC.Builtin.Names + GHC.Core.Opt.ConstantFold + GHC.Builtin.PrimOps + GHC.Builtin.RebindableNames + GHC.Builtin.Types.Prim + GHC.Builtin.Types + GHC.Types.CostCentre + GHC.Types.CostCentre.State + GHC.Rename.Bind + GHC.Rename.Env + GHC.Rename.Expr + GHC.Rename.Doc + GHC.Rename.Names + GHC.Rename.Pat + GHC.Rename.Module + GHC.Rename.Splice + GHC.Rename.HsType + GHC.Rename.Fixity + GHC.Rename.Utils + GHC.Rename.Unbound + GHC.Core.Opt.Monad + GHC.Core.Opt.CSE + GHC.Core.Opt.FloatIn + GHC.Core.Opt.FloatOut + GHC.Core.Opt.LiberateCase + GHC.Core.Opt.OccurAnal + GHC.Core.Opt.StaticArgs + GHC.Core.Opt.SetLevels + GHC.Core.Opt.Pipeline + GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Monad + GHC.Core.Opt.Simplify.Utils + GHC.Core.Opt.Simplify + GHC.Stg.Pipeline + GHC.Stg.Stats + GHC.Stg.CSE + GHC.Stg.Lift + GHC.Stg.Lift.Analysis + GHC.Stg.Lift.Monad + GHC.Stg.Subst + GHC.Stg.Unarise + GHC.Stg.Lint + GHC.Stg.Syntax + GHC.Stg.FVs + GHC.Stg.DepAnal + GHC.CoreToStg + GHC.CoreToStg.Prep + GHC.Types.RepType + GHC.Core.Rules + GHC.Core.Opt.SpecConstr + GHC.Core.Opt.Specialise + GHC.Core.Opt.CallArity + GHC.Core.Opt.DmdAnal + GHC.Core.Opt.CprAnal + GHC.Core.Opt.Exitify + GHC.Core.Opt.WorkWrap + GHC.Core.Opt.WorkWrap.Utils + GHC.Tc.Instance.Family + GHC.Tc.Instance.Class + GHC.Tc.Utils.Instantiate + GHC.Tc.Gen.Annotation + GHC.Tc.Gen.Arrow + GHC.Tc.Gen.Bind + GHC.Tc.Gen.Sig + GHC.Tc.TyCl.Class + GHC.Tc.Gen.Default + GHC.Tc.Deriv + GHC.Tc.Deriv.Infer + GHC.Tc.Deriv.Utils + GHC.Tc.Utils.Env + GHC.Tc.Gen.Expr + GHC.Tc.Gen.Foreign + GHC.Tc.Deriv.Generate + GHC.Tc.Deriv.Functor + GHC.Tc.Deriv.Generics + GHC.Tc.Utils.Zonk + GHC.Tc.Utils.TcType + GHC.Tc.TyCl.Instance + GHC.Tc.Utils.TcMType + GHC.Tc.Validity + GHC.Tc.Gen.Match + GHC.Tc.Gen.Pat + GHC.Tc.TyCl.PatSyn + GHC.Tc.Module + GHC.Tc.Utils.Backpack + GHC.Tc.Gen.Export + GHC.Tc.Utils.Monad + GHC.Tc.Types + GHC.Tc.Types.Constraint + GHC.Tc.Types.Origin + GHC.Tc.Gen.Rule + GHC.Tc.Errors.Hole + GHC.Tc.Errors.Hole.FitTypes + GHC.Tc.Errors + GHC.Tc.TyCl + GHC.Tc.TyCl.Utils + GHC.Tc.Instance.Typeable + GHC.Tc.Gen.HsType + GHC.Tc.Types.Evidence + GHC.Tc.Types.EvTerm + GHC.Tc.Utils.Unify + GHC.Tc.Solver + GHC.Tc.Solver.Interact + GHC.Tc.Solver.Canonical + GHC.Tc.Solver.Flatten + GHC.Tc.Solver.Monad + GHC.Builtin.Types.Literals + GHC.Tc.Gen.Splice + GHC.Core.Class + GHC.Core.Coercion + GHC.HsToCore.Quote + GHC.Builtin.Names.TH + GHC.Core.FamInstEnv + GHC.Tc.Instance.FunDeps + GHC.Core.InstEnv + GHC.Core.Multiplicity + GHC.Core.UsageEnv + GHC.Core.TyCon + GHC.Core.Coercion.Axiom + GHC.Core.Type + GHC.Core.TyCo.Rep + GHC.Core.TyCo.FVs + GHC.Core.TyCo.Subst + GHC.Core.TyCo.Ppr + GHC.Core.TyCo.Tidy + GHC.Core.Unify + GHC.Data.Bag + GHC.Utils.Binary + GHC.Data.BooleanFormula + GHC.Utils.BufHandle + GHC.Data.Graph.Directed + GHC.Utils.Encoding + GHC.Utils.IO.Unsafe + GHC.Data.FastMutInt + GHC.Data.FastString + GHC.Data.FastString.Env + GHC.Utils.Fingerprint + GHC.Data.FiniteMap + GHC.Utils.FV + GHC.Data.Graph.Base + GHC.Data.Graph.Color + GHC.Data.Graph.Ops + GHC.Data.Graph.Ppr + GHC.Data.IOEnv + GHC.Utils.Json + GHC.Data.List.SetOps + GHC.Data.Maybe + GHC.Utils.Monad + GHC.Data.OrdList + GHC.Utils.Outputable + GHC.Data.Pair + GHC.Utils.Panic + GHC.Utils.Panic.Plain + GHC.Utils.Ppr.Colour + GHC.Utils.Ppr + GHC.Utils.Monad.State + GHC.Data.Stream + GHC.Data.StringBuffer + GHC.Types.Unique.DFM + GHC.Types.Unique.DSet + GHC.Types.Unique.FM + GHC.Types.Unique.Set + GHC.Utils.Misc + GHC.Cmm.Dataflow + GHC.Cmm.Dataflow.Block + GHC.Cmm.Dataflow.Collections + GHC.Cmm.Dataflow.Graph + GHC.Cmm.Dataflow.Label + GHC.Settings.Config + autogen-modules: GHC.Settings.Config + Exposed-Modules: - AsmCodeGen - TargetReg - NCGMonad - Instruction - BlockLayout - CFG - Dominators - Format - Reg - RegClass - PIC - CPrim - X86.Regs - X86.RegInfo - X86.Instr - X86.Cond - X86.Ppr - X86.CodeGen - PPC.Regs - PPC.RegInfo - PPC.Instr - PPC.Cond - PPC.Ppr - PPC.CodeGen - SPARC.Base - SPARC.Regs - SPARC.Imm - SPARC.AddrMode - SPARC.Cond - SPARC.Instr - SPARC.Stack - SPARC.ShortcutJump - SPARC.Ppr - SPARC.CodeGen - SPARC.CodeGen.Amode - SPARC.CodeGen.Base - SPARC.CodeGen.CondCode - SPARC.CodeGen.Gen32 - SPARC.CodeGen.Gen64 - SPARC.CodeGen.Sanity - SPARC.CodeGen.Expand - RegAlloc.Liveness - RegAlloc.Graph.Main - RegAlloc.Graph.Stats - RegAlloc.Graph.ArchBase - RegAlloc.Graph.ArchX86 - RegAlloc.Graph.Coalesce - RegAlloc.Graph.Spill - RegAlloc.Graph.SpillClean - RegAlloc.Graph.SpillCost - RegAlloc.Graph.TrivColorable - RegAlloc.Linear.Main - RegAlloc.Linear.JoinToTargets - RegAlloc.Linear.State - RegAlloc.Linear.Stats - RegAlloc.Linear.FreeRegs - RegAlloc.Linear.StackMap - RegAlloc.Linear.Base - RegAlloc.Linear.X86.FreeRegs - RegAlloc.Linear.X86_64.FreeRegs - RegAlloc.Linear.PPC.FreeRegs - RegAlloc.Linear.SPARC.FreeRegs - Dwarf - Dwarf.Types - Dwarf.Constants + GHC.CmmToAsm + GHC.CmmToAsm.Reg.Target + GHC.CmmToAsm.Monad + GHC.CmmToAsm.Instr + GHC.CmmToAsm.BlockLayout + GHC.CmmToAsm.CFG + GHC.CmmToAsm.CFG.Dominators + GHC.CmmToAsm.Format + GHC.Platform.Reg + GHC.Platform.Reg.Class + GHC.CmmToAsm.PIC + GHC.CmmToAsm.CPrim + GHC.CmmToAsm.X86.Regs + GHC.CmmToAsm.X86.RegInfo + GHC.CmmToAsm.X86.Instr + GHC.CmmToAsm.X86.Cond + GHC.CmmToAsm.X86.Ppr + GHC.CmmToAsm.X86.CodeGen + GHC.CmmToAsm.PPC.Regs + GHC.CmmToAsm.PPC.RegInfo + GHC.CmmToAsm.PPC.Instr + GHC.CmmToAsm.PPC.Cond + GHC.CmmToAsm.PPC.Ppr + GHC.CmmToAsm.PPC.CodeGen + GHC.CmmToAsm.SPARC.Base + GHC.CmmToAsm.SPARC.Regs + GHC.CmmToAsm.SPARC.Imm + GHC.CmmToAsm.SPARC.AddrMode + GHC.CmmToAsm.SPARC.Cond + GHC.CmmToAsm.SPARC.Instr + GHC.CmmToAsm.SPARC.Stack + GHC.CmmToAsm.SPARC.ShortcutJump + GHC.CmmToAsm.SPARC.Ppr + GHC.CmmToAsm.SPARC.CodeGen + GHC.CmmToAsm.SPARC.CodeGen.Amode + GHC.CmmToAsm.SPARC.CodeGen.Base + GHC.CmmToAsm.SPARC.CodeGen.CondCode + GHC.CmmToAsm.SPARC.CodeGen.Gen32 + GHC.CmmToAsm.SPARC.CodeGen.Gen64 + GHC.CmmToAsm.SPARC.CodeGen.Sanity + GHC.CmmToAsm.SPARC.CodeGen.Expand + GHC.CmmToAsm.Reg.Liveness + GHC.CmmToAsm.Reg.Graph + GHC.CmmToAsm.Reg.Graph.Stats + GHC.CmmToAsm.Reg.Graph.Base + GHC.CmmToAsm.Reg.Graph.X86 + GHC.CmmToAsm.Reg.Graph.Coalesce + GHC.CmmToAsm.Reg.Graph.Spill + GHC.CmmToAsm.Reg.Graph.SpillClean + GHC.CmmToAsm.Reg.Graph.SpillCost + GHC.CmmToAsm.Reg.Graph.TrivColorable + GHC.CmmToAsm.Reg.Linear + GHC.CmmToAsm.Reg.Linear.JoinToTargets + GHC.CmmToAsm.Reg.Linear.State + GHC.CmmToAsm.Reg.Linear.Stats + GHC.CmmToAsm.Reg.Linear.FreeRegs + GHC.CmmToAsm.Reg.Linear.StackMap + GHC.CmmToAsm.Reg.Linear.Base + GHC.CmmToAsm.Reg.Linear.X86 + GHC.CmmToAsm.Reg.Linear.X86_64 + GHC.CmmToAsm.Reg.Linear.PPC + GHC.CmmToAsm.Reg.Linear.SPARC + GHC.CmmToAsm.Reg.Utils + GHC.CmmToAsm.Dwarf + GHC.CmmToAsm.Dwarf.Types + GHC.CmmToAsm.Dwarf.Constants GHC.ThToHs - ByteCodeTypes - ByteCodeAsm - ByteCodeGen - ByteCodeInstr - ByteCodeItbls - ByteCodeLink - Debugger - LinkerTypes - Linker - RtClosureInspect - GHCi + GHC.ByteCode.Types + GHC.ByteCode.Asm + GHC.ByteCode.Instr + GHC.ByteCode.InfoTable + GHC.ByteCode.Linker + GHC.CoreToByteCode + GHC.Runtime.Debugger + GHC.Runtime.Linker.Types + GHC.Runtime.Linker + GHC.Runtime.Heap.Inspect + GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.Types diff --git a/ghci/ByteCodeAsm.hs b/ghci/ByteCodeAsm.hs deleted file mode 100644 --- a/ghci/ByteCodeAsm.hs +++ /dev/null @@ -1,566 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeLink: Bytecode assembler and linker -module ByteCodeAsm ( - assembleBCOs, assembleOneBCO, - - bcoFreeNames, - SizedSeq, sizeSS, ssElts, - iNTERP_STACK_CHECK_THRESH - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeInstr -import ByteCodeItbls -import ByteCodeTypes -import GHCi.RemoteTypes -import GHCi - -import HscTypes -import Name -import NameSet -import Literal -import TyCon -import FastString -import GHC.StgToCmm.Layout ( ArgRep(..) ) -import SMRep -import DynFlags -import Outputable -import GHC.Platform -import Util -import Unique -import UniqDSet - --- From iserv -import SizedSeq - -import Control.Monad -import Control.Monad.ST ( runST ) -import Control.Monad.Trans.Class -import Control.Monad.Trans.State.Strict - -import Data.Array.MArray - -import qualified Data.Array.Unboxed as Array -import Data.Array.Base ( UArray(..) ) - -import Data.Array.Unsafe( castSTUArray ) - -import Foreign -import Data.Char ( ord ) -import Data.List ( genericLength ) -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map - --- ----------------------------------------------------------------------------- --- Unlinked BCOs - --- CompiledByteCode represents the result of byte-code --- compiling a bunch of functions and data types - --- | Finds external references. Remember to remove the names --- defined by this group of BCOs themselves -bcoFreeNames :: UnlinkedBCO -> UniqDSet Name -bcoFreeNames bco - = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] - where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) - = unionManyUniqDSets ( - mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] : - mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] : - map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] - ) - --- ----------------------------------------------------------------------------- --- The bytecode assembler - --- The object format for bytecodes is: 16 bits for the opcode, and 16 --- for each field -- so the code can be considered a sequence of --- 16-bit ints. Each field denotes either a stack offset or number of --- items on the stack (eg SLIDE), and index into the pointer table (eg --- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a --- bytecode address in this BCO. - --- Top level assembler fn. -assembleBCOs - :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()] - -> Maybe ModBreaks - -> IO CompiledByteCode -assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do - itblenv <- mkITbls hsc_env tycons - bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos - (bcos',ptrs) <- mallocStrings hsc_env bcos - return CompiledByteCode - { bc_bcos = bcos' - , bc_itbls = itblenv - , bc_ffis = concat (map protoBCOFFIs proto_bcos) - , bc_strs = top_strs ++ ptrs - , bc_breaks = modbreaks - } - --- Find all the literal strings and malloc them together. We want to --- do this because: --- --- a) It should be done when we compile the module, not each time we relink it --- b) For -fexternal-interpreter It's more efficient to malloc the strings --- as a single batch message, especially when compiling in parallel. --- -mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()]) -mallocStrings hsc_env ulbcos = do - let bytestrings = reverse (execState (mapM_ collect ulbcos) []) - ptrs <- iservCmd hsc_env (MallocStrings bytestrings) - return (evalState (mapM splice ulbcos) ptrs, ptrs) - where - splice bco@UnlinkedBCO{..} = do - lits <- mapM spliceLit unlinkedBCOLits - ptrs <- mapM splicePtr unlinkedBCOPtrs - return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs } - - spliceLit (BCONPtrStr _) = do - rptrs <- get - case rptrs of - (RemotePtr p : rest) -> do - put rest - return (BCONPtrWord (fromIntegral p)) - _ -> panic "mallocStrings:spliceLit" - spliceLit other = return other - - splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco - splicePtr other = return other - - collect UnlinkedBCO{..} = do - mapM_ collectLit unlinkedBCOLits - mapM_ collectPtr unlinkedBCOPtrs - - collectLit (BCONPtrStr bs) = do - strs <- get - put (bs:strs) - collectLit _ = return () - - collectPtr (BCOPtrBCO bco) = collect bco - collectPtr _ = return () - - -assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO -assembleOneBCO hsc_env pbco = do - ubco <- assembleBCO (hsc_dflags hsc_env) pbco - ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco] - return ubco' - -assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO -assembleBCO dflags (ProtoBCO { protoBCOName = nm - , protoBCOInstrs = instrs - , protoBCOBitmap = bitmap - , protoBCOBitmapSize = bsize - , protoBCOArity = arity }) = do - -- pass 1: collect up the offsets of the local labels. - let asm = mapM_ (assembleI dflags) instrs - - initial_offset = 0 - - -- Jump instructions are variable-sized, there are long and short variants - -- depending on the magnitude of the offset. However, we can't tell what - -- size instructions we will need until we have calculated the offsets of - -- the labels, which depends on the size of the instructions... So we - -- first create the label environment assuming that all jumps are short, - -- and if the final size is indeed small enough for short jumps, we are - -- done. Otherwise, we repeat the calculation, and we force all jumps in - -- this BCO to be long. - (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm - ((n_insns, lbl_map), long_jumps) - | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True) - | otherwise = ((n_insns0, lbl_map0), False) - - env :: Word16 -> Word - env lbl = fromMaybe - (pprPanic "assembleBCO.findLabel" (ppr lbl)) - (Map.lookup lbl lbl_map) - - -- pass 2: run assembler and generate instructions, literals and pointers - let initial_state = (emptySS, emptySS, emptySS) - (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm - - -- precomputed size should be equal to final size - ASSERT(n_insns == sizeSS final_insns) return () - - let asm_insns = ssElts final_insns - insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns - bitmap_arr = mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs - - -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive - -- objects, since they might get run too early. Disable this until - -- we figure out what to do. - -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) - - return ul_bco - -mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64 --- Here the return type must be an array of Words, not StgWords, --- because the underlying ByteArray# will end up as a component --- of a BCO object. -mkBitmapArray bsize bitmap - = Array.listArray (0, length bitmap) $ - fromIntegral bsize : map (fromInteger . fromStgWord) bitmap - --- instrs nonptrs ptrs -type AsmState = (SizedSeq Word16, - SizedSeq BCONPtr, - SizedSeq BCOPtr) - -data Operand - = Op Word - | SmallOp Word16 - | LabelOp Word16 --- (unused) | LargeOp Word - -data Assembler a - = AllocPtr (IO BCOPtr) (Word -> Assembler a) - | AllocLit [BCONPtr] (Word -> Assembler a) - | AllocLabel Word16 (Assembler a) - | Emit Word16 [Operand] (Assembler a) - | NullAsm a - deriving (Functor) - -instance Applicative Assembler where - pure = NullAsm - (<*>) = ap - -instance Monad Assembler where - NullAsm x >>= f = f x - AllocPtr p k >>= f = AllocPtr p (k >=> f) - AllocLit l k >>= f = AllocLit l (k >=> f) - AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) - Emit w ops k >>= f = Emit w ops (k >>= f) - -ioptr :: IO BCOPtr -> Assembler Word -ioptr p = AllocPtr p return - -ptr :: BCOPtr -> Assembler Word -ptr = ioptr . return - -lit :: [BCONPtr] -> Assembler Word -lit l = AllocLit l return - -label :: Word16 -> Assembler () -label w = AllocLabel w (return ()) - -emit :: Word16 -> [Operand] -> Assembler () -emit w ops = Emit w ops (return ()) - -type LabelEnv = Word16 -> Word - -largeOp :: Bool -> Operand -> Bool -largeOp long_jumps op = case op of - SmallOp _ -> False - Op w -> isLarge w - LabelOp _ -> long_jumps --- LargeOp _ -> True - -runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a -runAsm dflags long_jumps e = go - where - go (NullAsm x) = return x - go (AllocPtr p_io k) = do - p <- lift p_io - w <- state $ \(st_i0,st_l0,st_p0) -> - let st_p1 = addToSS st_p0 p - in (sizeSS st_p0, (st_i0,st_l0,st_p1)) - go $ k w - go (AllocLit lits k) = do - w <- state $ \(st_i0,st_l0,st_p0) -> - let st_l1 = addListToSS st_l0 lits - in (sizeSS st_l0, (st_i0,st_l1,st_p0)) - go $ k w - go (AllocLabel _ k) = go k - go (Emit w ops k) = do - let largeOps = any (largeOp long_jumps) ops - opcode - | largeOps = largeArgInstr w - | otherwise = w - words = concatMap expand ops - expand (SmallOp w) = [w] - expand (LabelOp w) = expand (Op (e w)) - expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w] --- expand (LargeOp w) = largeArg dflags w - state $ \(st_i0,st_l0,st_p0) -> - let st_i1 = addListToSS st_i0 (opcode : words) - in ((), (st_i1,st_l0,st_p0)) - go k - -type LabelEnvMap = Map Word16 Word - -data InspectState = InspectState - { instrCount :: !Word - , ptrCount :: !Word - , litCount :: !Word - , lblEnv :: LabelEnvMap - } - -inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) -inspectAsm dflags long_jumps initial_offset - = go (InspectState initial_offset 0 0 Map.empty) - where - go s (NullAsm _) = (instrCount s, lblEnv s) - go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) - where n = ptrCount s - go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) - where n = litCount s - go s (AllocLabel lbl k) = go s' k - where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } - go s (Emit _ ops k) = go s' k - where - s' = s { instrCount = instrCount s + size } - size = sum (map count ops) + 1 - largeOps = any (largeOp long_jumps) ops - count (SmallOp _) = 1 - count (LabelOp _) = count (Op 0) - count (Op _) = if largeOps then largeArg16s dflags else 1 --- count (LargeOp _) = largeArg16s dflags - --- Bring in all the bci_ bytecode constants. -#include "rts/Bytecodes.h" - -largeArgInstr :: Word16 -> Word16 -largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci - -largeArg :: DynFlags -> Word -> [Word16] -largeArg dflags w - | wORD_SIZE_IN_BITS dflags == 64 - = [fromIntegral (w `shiftR` 48), - fromIntegral (w `shiftR` 32), - fromIntegral (w `shiftR` 16), - fromIntegral w] - | wORD_SIZE_IN_BITS dflags == 32 - = [fromIntegral (w `shiftR` 16), - fromIntegral w] - | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" - -largeArg16s :: DynFlags -> Word -largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4 - | otherwise = 2 - -assembleI :: DynFlags - -> BCInstr - -> Assembler () -assembleI dflags i = case i of - STKCHECK n -> emit bci_STKCHECK [Op n] - PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] - PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] - PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] - PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1] - PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1] - PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1] - PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1] - PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1] - PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp o1] - PUSH_G nm -> do p <- ptr (BCOPtrName nm) - emit bci_PUSH_G [Op p] - PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) - emit bci_PUSH_G [Op p] - PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit bci_PUSH_G [Op p] - PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit bci_PUSH_ALTS [Op p] - PUSH_ALTS_UNLIFTED proto pk - -> do let ul_bco = assembleBCO dflags proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit (push_alts pk) [Op p] - PUSH_PAD8 -> emit bci_PUSH_PAD8 [] - PUSH_PAD16 -> emit bci_PUSH_PAD16 [] - PUSH_PAD32 -> emit bci_PUSH_PAD32 [] - PUSH_UBX8 lit -> do np <- literal lit - emit bci_PUSH_UBX8 [Op np] - PUSH_UBX16 lit -> do np <- literal lit - emit bci_PUSH_UBX16 [Op np] - PUSH_UBX32 lit -> do np <- literal lit - emit bci_PUSH_UBX32 [Op np] - PUSH_UBX lit nws -> do np <- literal lit - emit bci_PUSH_UBX [Op np, SmallOp nws] - - PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] - PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] - PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] - PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] - PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] - PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] - PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] - PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] - PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] - PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] - PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] - - SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] - ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] - ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] - ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] - MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] - MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] - UNPACK n -> emit bci_UNPACK [SmallOp n] - PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] - emit bci_PACK [Op itbl_no, SmallOp sz] - LABEL lbl -> label lbl - TESTLT_I i l -> do np <- int i - emit bci_TESTLT_I [Op np, LabelOp l] - TESTEQ_I i l -> do np <- int i - emit bci_TESTEQ_I [Op np, LabelOp l] - TESTLT_W w l -> do np <- word w - emit bci_TESTLT_W [Op np, LabelOp l] - TESTEQ_W w l -> do np <- word w - emit bci_TESTEQ_W [Op np, LabelOp l] - TESTLT_F f l -> do np <- float f - emit bci_TESTLT_F [Op np, LabelOp l] - TESTEQ_F f l -> do np <- float f - emit bci_TESTEQ_F [Op np, LabelOp l] - TESTLT_D d l -> do np <- double d - emit bci_TESTLT_D [Op np, LabelOp l] - TESTEQ_D d l -> do np <- double d - emit bci_TESTEQ_D [Op np, LabelOp l] - TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] - TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] - CASEFAIL -> emit bci_CASEFAIL [] - SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] - JMP l -> emit bci_JMP [LabelOp l] - ENTER -> emit bci_ENTER [] - RETURN -> emit bci_RETURN [] - RETURN_UBX rep -> emit (return_ubx rep) [] - CCALL off m_addr i -> do np <- addr m_addr - emit bci_CCALL [SmallOp off, Op np, SmallOp i] - BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray - q <- int (getKey uniq) - np <- addr cc - emit bci_BRK_FUN [Op p1, SmallOp index, - Op q, Op np] - - where - literal (LitLabel fs (Just sz) _) - | platformOS (targetPlatform dflags) == OSMinGW32 - = litlabel (appendFS fs (mkFastString ('@':show sz))) - -- On Windows, stdcall labels have a suffix indicating the no. of - -- arg words, e.g. foo@8. testcase: ffi012(ghci) - literal (LitLabel fs _ _) = litlabel fs - literal LitNullAddr = int 0 - literal (LitFloat r) = float (fromRational r) - literal (LitDouble r) = double (fromRational r) - literal (LitChar c) = int (ord c) - literal (LitString bs) = lit [BCONPtrStr bs] - -- LitString requires a zero-terminator when emitted - literal (LitNumber nt i _) = case nt of - LitNumInt -> int (fromIntegral i) - LitNumWord -> int (fromIntegral i) - LitNumInt64 -> int64 (fromIntegral i) - LitNumWord64 -> int64 (fromIntegral i) - LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger" - LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural" - -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most - -- likely to elicit a crash (rather than corrupt memory) in case absence - -- analysis messed up. - literal LitRubbish = int 0 - - litlabel fs = lit [BCONPtrLbl fs] - addr (RemotePtr a) = words [fromIntegral a] - float = words . mkLitF - double = words . mkLitD dflags - int = words . mkLitI - int64 = words . mkLitI64 dflags - words ws = lit (map BCONPtrWord ws) - word w = words [w] - -isLarge :: Word -> Bool -isLarge n = n > 65535 - -push_alts :: ArgRep -> Word16 -push_alts V = bci_PUSH_ALTS_V -push_alts P = bci_PUSH_ALTS_P -push_alts N = bci_PUSH_ALTS_N -push_alts L = bci_PUSH_ALTS_L -push_alts F = bci_PUSH_ALTS_F -push_alts D = bci_PUSH_ALTS_D -push_alts V16 = error "push_alts: vector" -push_alts V32 = error "push_alts: vector" -push_alts V64 = error "push_alts: vector" - -return_ubx :: ArgRep -> Word16 -return_ubx V = bci_RETURN_V -return_ubx P = bci_RETURN_P -return_ubx N = bci_RETURN_N -return_ubx L = bci_RETURN_L -return_ubx F = bci_RETURN_F -return_ubx D = bci_RETURN_D -return_ubx V16 = error "return_ubx: vector" -return_ubx V32 = error "return_ubx: vector" -return_ubx V64 = error "return_ubx: vector" - --- Make lists of host-sized words for literals, so that when the --- words are placed in memory at increasing addresses, the --- bit pattern is correct for the host's word size and endianness. -mkLitI :: Int -> [Word] -mkLitF :: Float -> [Word] -mkLitD :: DynFlags -> Double -> [Word] -mkLitI64 :: DynFlags -> Int64 -> [Word] - -mkLitF f - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 f - f_arr <- castSTUArray arr - w0 <- readArray f_arr 0 - return [w0 :: Word] - ) - -mkLitD dflags d - | wORD_SIZE dflags == 4 - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word, w1] - ) - | wORD_SIZE dflags == 8 - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - return [w0 :: Word] - ) - | otherwise - = panic "mkLitD: Bad wORD_SIZE" - -mkLitI64 dflags ii - | wORD_SIZE dflags == 4 - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 ii - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word,w1] - ) - | wORD_SIZE dflags == 8 - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 ii - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - return [w0 :: Word] - ) - | otherwise - = panic "mkLitI64: Bad wORD_SIZE" - -mkLitI i = [fromIntegral i :: Word] - -iNTERP_STACK_CHECK_THRESH :: Int -iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/ghci/ByteCodeGen.hs b/ghci/ByteCodeGen.hs deleted file mode 100644 --- a/ghci/ByteCodeGen.hs +++ /dev/null @@ -1,2040 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fprof-auto-top #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeGen: Generate bytecode from Core -module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeInstr -import ByteCodeAsm -import ByteCodeTypes - -import GHCi -import GHCi.FFI -import GHCi.RemoteTypes -import BasicTypes -import DynFlags -import Outputable -import GHC.Platform -import Name -import MkId -import Id -import Var ( updateVarType ) -import ForeignCall -import HscTypes -import CoreUtils -import CoreSyn -import PprCore -import Literal -import PrimOp -import CoreFVs -import Type -import RepType -import DataCon -import TyCon -import Util -import VarSet -import TysPrim -import TyCoPpr ( pprType ) -import ErrUtils -import Unique -import FastString -import Panic -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) -import GHC.StgToCmm.Layout -import SMRep hiding (WordOff, ByteOff, wordsToBytes) -import Bitmap -import OrdList -import Maybes -import VarEnv - -import Data.List -import Foreign -import Control.Monad -import Data.Char - -import UniqSupply -import Module - -import Control.Exception -import Data.Array -import Data.ByteString (ByteString) -import Data.Map (Map) -import Data.IntMap (IntMap) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified FiniteMap as Map -import Data.Ord -import GHC.Stack.CCS -import Data.Either ( partitionEithers ) - --- ----------------------------------------------------------------------------- --- Generating byte code for a complete module - -byteCodeGen :: HscEnv - -> Module - -> CoreProgram - -> [TyCon] - -> Maybe ModBreaks - -> IO CompiledByteCode -byteCodeGen hsc_env this_mod binds tycs mb_modBreaks - = withTiming dflags - (text "ByteCodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - -- Split top-level binds into strings and others. - -- See Note [generating code for top-level string literal bindings]. - let (strings, flatBinds) = partitionEithers $ do -- list monad - (bndr, rhs) <- flattenBinds binds - return $ case exprIsTickedString_maybe rhs of - Just str -> Left (bndr, str) - _ -> Right (bndr, simpleFreeVars rhs) - stringPtrs <- allocateTopStrings hsc_env strings - - us <- mkSplitUniqSupply 'y' - (BcM_State{..}, proto_bcos) <- - runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ - mapM schemeTopBind flatBinds - - when (notNull ffis) - (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") - - dumpIfSet_dyn dflags Opt_D_dump_BCOs - "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - - cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs) - (case modBreaks of - Nothing -> Nothing - Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) - - -- Squash space leaks in the CompiledByteCode. This is really - -- important, because when loading a set of modules into GHCi - -- we don't touch the CompiledByteCode until the end when we - -- do linking. Forcing out the thunks here reduces space - -- usage by more than 50% when loading a large number of - -- modules. - evaluate (seqCompiledByteCode cbc) - - return cbc - - where dflags = hsc_dflags hsc_env - -allocateTopStrings - :: HscEnv - -> [(Id, ByteString)] - -> IO [(Var, RemotePtr ())] -allocateTopStrings hsc_env topStrings = do - let !(bndrs, strings) = unzip topStrings - ptrs <- iservCmd hsc_env $ MallocStrings strings - return $ zip bndrs ptrs - -{- -Note [generating code for top-level string literal bindings] - -Here is a summary on how the byte code generator deals with top-level string -literals: - -1. Top-level string literal bindings are separated from the rest of the module. - -2. The strings are allocated via iservCmd, in allocateTopStrings - -3. The mapping from binders to allocated strings (topStrings) are maintained in - BcM and used when generating code for variable references. --} - --- ----------------------------------------------------------------------------- --- Generating byte code for an expression - --- Returns: the root BCO for this expression -coreExprToBCOs :: HscEnv - -> Module - -> CoreExpr - -> IO UnlinkedBCO -coreExprToBCOs hsc_env this_mod expr - = withTiming dflags - (text "ByteCodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - -- create a totally bogus name for the top-level BCO; this - -- should be harmless, since it's never used for anything - let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") - invented_id = Id.mkLocalId invented_name (panic "invented_id's type") - - -- the uniques are needed to generate fresh variables when we introduce new - -- let bindings for ticked expressions - us <- mkSplitUniqSupply 'y' - (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) - <- runBc hsc_env us this_mod Nothing emptyVarEnv $ - schemeTopBind (invented_id, simpleFreeVars expr) - - when (notNull mallocd) - (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") - - dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) - - assembleOneBCO hsc_env proto_bco - where dflags = hsc_dflags hsc_env - --- The regular freeVars function gives more information than is useful to --- us here. We need only the free variables, not everything in an FVAnn. --- Historical note: At one point FVAnn was more sophisticated than just --- a set. Now it isn't. So this function is much simpler. Keeping it around --- so that if someone changes FVAnn, they will get a nice type error right --- here. -simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet -simpleFreeVars = freeVars - --- ----------------------------------------------------------------------------- --- Compilation schema for the bytecode generator - -type BCInstrList = OrdList BCInstr - -newtype ByteOff = ByteOff Int - deriving (Enum, Eq, Integral, Num, Ord, Real) - -newtype WordOff = WordOff Int - deriving (Enum, Eq, Integral, Num, Ord, Real) - -wordsToBytes :: DynFlags -> WordOff -> ByteOff -wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral - --- Used when we know we have a whole number of words -bytesToWords :: DynFlags -> ByteOff -> WordOff -bytesToWords dflags (ByteOff bytes) = - let (q, r) = bytes `quotRem` (wORD_SIZE dflags) - in if r == 0 - then fromIntegral q - else panic $ "ByteCodeGen.bytesToWords: bytes=" ++ show bytes - -wordSize :: DynFlags -> ByteOff -wordSize dflags = ByteOff (wORD_SIZE dflags) - -type Sequel = ByteOff -- back off to this depth before ENTER - -type StackDepth = ByteOff - --- | Maps Ids to their stack depth. This allows us to avoid having to mess with --- it after each push/pop. -type BCEnv = Map Id StackDepth -- To find vars on the stack - -{- -ppBCEnv :: BCEnv -> SDoc -ppBCEnv p - = text "begin-env" - $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) - $$ text "end-env" - where - pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var) - cmp_snd x y = compare (snd x) (snd y) --} - --- Create a BCO and do a spot of peephole optimisation on the insns --- at the same time. -mkProtoBCO - :: DynFlags - -> name - -> BCInstrList - -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) - -- ^ original expression; for debugging only - -> Int - -> Word16 - -> [StgWord] - -> Bool -- True <=> is a return point, rather than a function - -> [FFIInfo] - -> ProtoBCO name -mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis - = ProtoBCO { - protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check, - protoBCOBitmap = bitmap, - protoBCOBitmapSize = bitmap_size, - protoBCOArity = arity, - protoBCOExpr = origin, - protoBCOFFIs = ffis - } - where - -- Overestimate the stack usage (in words) of this BCO, - -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit - -- stack check. (The interpreter always does a stack check - -- for iNTERP_STACK_CHECK_THRESH words at the start of each - -- BCO anyway, so we only need to add an explicit one in the - -- (hopefully rare) cases when the (overestimated) stack use - -- exceeds iNTERP_STACK_CHECK_THRESH. - maybe_with_stack_check - | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d - -- don't do stack checks at return points, - -- everything is aggregated up to the top BCO - -- (which must be a function). - -- That is, unless the stack usage is >= AP_STACK_SPLIM, - -- see bug #1466. - | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH - = STKCHECK stack_usage : peep_d - | otherwise - = peep_d -- the supposedly common case - - -- We assume that this sum doesn't wrap - stack_usage = sum (map bciStackUse peep_d) - - -- Merge local pushes - peep_d = peep (fromOL instrs_ordlist) - - peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) - = PUSH_LLL off1 (off2-1) (off3-2) : peep rest - peep (PUSH_L off1 : PUSH_L off2 : rest) - = PUSH_LL off1 (off2-1) : peep rest - peep (i:rest) - = i : peep rest - peep [] - = [] - -argBits :: DynFlags -> [ArgRep] -> [Bool] -argBits _ [] = [] -argBits dflags (rep : args) - | isFollowableArg rep = False : argBits dflags args - | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args - --- ----------------------------------------------------------------------------- --- schemeTopBind - --- Compile code for the right-hand side of a top-level binding - -schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name) -schemeTopBind (id, rhs) - | Just data_con <- isDataConWorkId_maybe id, - isNullaryRepDataCon data_con = do - dflags <- getDynFlags - -- Special case for the worker of a nullary data con. - -- It'll look like this: Nil = /\a -> Nil a - -- If we feed it into schemeR, we'll get - -- Nil = Nil - -- because mkConAppCode treats nullary constructor applications - -- by just re-using the single top-level definition. So - -- for the worker itself, we must allocate it directly. - -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER]) - (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) - - | otherwise - = schemeR [{- No free variables -}] (id, rhs) - - --- ----------------------------------------------------------------------------- --- schemeR - --- Compile code for a right-hand side, to give a BCO that, --- when executed with the free variables and arguments on top of the stack, --- will return with a pointer to the result on top of the stack, after --- removing the free variables and arguments. --- --- Park the resulting BCO in the monad. Also requires the --- variable to which this value was bound, so as to give the --- resulting BCO a name. - -schemeR :: [Id] -- Free vars of the RHS, ordered as they - -- will appear in the thunk. Empty for - -- top-level things, which have no free vars. - -> (Id, AnnExpr Id DVarSet) - -> BcM (ProtoBCO Name) -schemeR fvs (nm, rhs) -{- - | trace (showSDoc ( - (char ' ' - $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs - $$ pprCoreExpr (deAnnotate rhs) - $$ char ' ' - ))) False - = undefined - | otherwise --} - = schemeR_wrk fvs nm rhs (collect rhs) - --- If an expression is a lambda (after apply bcView), return the --- list of arguments to the lambda (in R-to-L order) and the --- underlying expression -collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) -collect (_, e) = go [] e - where - go xs e | Just e' <- bcView e = go xs e' - go xs (AnnLam x (_,e)) - | typePrimRep (idType x) `lengthExceeds` 1 - = multiValException - | otherwise - = go (x:xs) e - go xs not_lambda = (reverse xs, not_lambda) - -schemeR_wrk - :: [Id] - -> Id - -> AnnExpr Id DVarSet -- expression e, for debugging only - -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e - -> BcM (ProtoBCO Name) -schemeR_wrk fvs nm original_body (args, body) - = do - dflags <- getDynFlags - let - all_args = reverse args ++ fvs - arity = length all_args - -- all_args are the args in reverse order. We're compiling a function - -- \fv1..fvn x1..xn -> e - -- i.e. the fvs come first - - -- Stack arguments always take a whole number of words, we never pack - -- them unlike constructor fields. - szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args - sum_szsb_args = sum szsb_args - p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) - - -- make the arg bitmap - bits = argBits dflags (reverse (map bcIdArgRep all_args)) - bitmap_size = genericLength bits - bitmap = mkBitmap dflags bits - body_code <- schemeER_wrk sum_szsb_args p_init body - - emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body) - arity bitmap_size bitmap False{-not alts-}) - --- introduce break instructions for ticked expressions -schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList -schemeER_wrk d p rhs - | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs - = do code <- schemeE d 0 p newRhs - cc_arr <- getCCArray - this_mod <- moduleName <$> getCurrentModule - dflags <- getDynFlags - let idOffSets = getVarOffSets dflags d p fvs - let breakInfo = CgBreakInfo - { cgb_vars = idOffSets - , cgb_resty = exprType (deAnnotate' newRhs) - } - newBreakInfo tick_no breakInfo - dflags <- getDynFlags - let cc | interpreterProfiled dflags = cc_arr ! tick_no - | otherwise = toRemotePtr nullPtr - let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc - return $ breakInstr `consOL` code - | otherwise = schemeE d 0 p rhs - -getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)] -getVarOffSets dflags depth env = map getOffSet - where - getOffSet id = case lookupBCEnv_maybe id env of - Nothing -> Nothing - Just offset -> - -- michalt: I'm not entirely sure why we need the stack - -- adjustment by 2 here. I initially thought that there's - -- something off with getIdValFromApStack (the only user of this - -- value), but it looks ok to me. My current hypothesis is that - -- this "adjustment" is needed due to stack manipulation for - -- BRK_FUN in Interpreter.c In any case, this is used only when - -- we trigger a breakpoint. - let !var_depth_ws = - trunc16W $ bytesToWords dflags (depth - offset) + 2 - in Just (id, var_depth_ws) - -truncIntegral16 :: Integral a => a -> Word16 -truncIntegral16 w - | w > fromIntegral (maxBound :: Word16) - = panic "stack depth overflow" - | otherwise - = fromIntegral w - -trunc16B :: ByteOff -> Word16 -trunc16B = truncIntegral16 - -trunc16W :: WordOff -> Word16 -trunc16W = truncIntegral16 - -fvsToEnv :: BCEnv -> DVarSet -> [Id] --- Takes the free variables of a right-hand side, and --- delivers an ordered list of the local variables that will --- be captured in the thunk for the RHS --- The BCEnv argument tells which variables are in the local --- environment: these are the ones that should be captured --- --- The code that constructs the thunk, and the code that executes --- it, have to agree about this layout -fvsToEnv p fvs = [v | v <- dVarSetElems fvs, - isId v, -- Could be a type variable - v `Map.member` p] - --- ----------------------------------------------------------------------------- --- schemeE - -returnUnboxedAtom - :: StackDepth - -> Sequel - -> BCEnv - -> AnnExpr' Id DVarSet - -> ArgRep - -> BcM BCInstrList --- Returning an unlifted value. --- Heave it on the stack, SLIDE, and RETURN. -returnUnboxedAtom d s p e e_rep = do - dflags <- getDynFlags - (push, szb) <- pushAtom d p e - return (push -- value onto stack - `appOL` mkSlideB dflags szb (d - s) -- clear to sequel - `snocOL` RETURN_UBX e_rep) -- go - --- Compile code to apply the given expression to the remaining args --- on the stack, returning a HNF. -schemeE - :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList -schemeE d s p e - | Just e' <- bcView e - = schemeE d s p e' - --- Delegate tail-calls to schemeT. -schemeE d s p e@(AnnApp _ _) = schemeT d s p e - -schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit)) -schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V - -schemeE d s p e@(AnnVar v) - -- See Note [Not-necessarily-lifted join points], step 3. - | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId] - | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) - | otherwise = schemeT d s p e - -schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) - | (AnnVar v, args_r_to_l) <- splitApp rhs, - Just data_con <- isDataConWorkId_maybe v, - dataConRepArity data_con == length args_r_to_l - = do -- Special case for a non-recursive let whose RHS is a - -- saturated constructor application. - -- Just allocate the constructor and carry on - alloc_code <- mkConAppCode d s p data_con args_r_to_l - dflags <- getDynFlags - let !d2 = d + wordSize dflags - body_code <- schemeE d2 s (Map.insert x d2 p) body - return (alloc_code `appOL` body_code) - --- General case for let. Generates correct, if inefficient, code in --- all situations. -schemeE d s p (AnnLet binds (_,body)) = do - dflags <- getDynFlags - let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) - AnnRec xs_n_rhss -> unzip xs_n_rhss - n_binds = genericLength xs - - fvss = map (fvsToEnv p' . fst) rhss - - -- See Note [Not-necessarily-lifted join points], step 2. - (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss - - -- Sizes of free vars - size_w = trunc16W . idSizeW dflags - sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss - - -- the arity of each rhs - arities = map (genericLength . fst . collect) rhss' - - -- This p', d' defn is safe because all the items being pushed - -- are ptrs, so all have size 1 word. d' and p' reflect the stack - -- after the closures have been allocated in the heap (but not - -- filled in), and pointers to them parked on the stack. - offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags)) - p' = Map.insertList (zipE xs' offsets) p - d' = d + wordsToBytes dflags n_binds - zipE = zipEqual "schemeE" - - -- ToDo: don't build thunks for things with no free variables - build_thunk - :: StackDepth - -> [Id] - -> Word16 - -> ProtoBCO Name - -> Word16 - -> Word16 - -> BcM BCInstrList - build_thunk _ [] size bco off arity - = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) - where - mkap | arity == 0 = MKAP - | otherwise = MKPAP - build_thunk dd (fv:fvs) size bco off arity = do - (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv) - more_push_code <- - build_thunk (dd + pushed_szb) fvs size bco off arity - return (push_code `appOL` more_push_code) - - alloc_code = toOL (zipWith mkAlloc sizes arities) - where mkAlloc sz 0 - | is_tick = ALLOC_AP_NOUPD sz - | otherwise = ALLOC_AP sz - mkAlloc sz arity = ALLOC_PAP arity sz - - is_tick = case binds of - AnnNonRec id _ -> occNameFS (getOccName id) == tickFS - _other -> False - - compile_bind d' fvs x rhs size arity off = do - bco <- schemeR fvs (x,rhs) - build_thunk d' fvs size bco off arity - - compile_binds = - [ compile_bind d' fvs x rhs size arity (trunc16W n) - | (fvs, x, rhs, size, arity, n) <- - zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1] - ] - body_code <- schemeE d' s p' body - thunk_codes <- sequence compile_binds - return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) - --- Introduce a let binding for a ticked case expression. This rule --- *should* only fire when the expression was not already let-bound --- (the code gen for let bindings should take care of that). Todo: we --- call exprFreeVars on a deAnnotated expression, this may not be the --- best way to calculate the free vars but it seemed like the least --- intrusive thing to do -schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) - | isLiftedTypeKind (typeKind ty) - = do id <- newId ty - -- Todo: is emptyVarSet correct on the next line? - let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id) - schemeE d s p letExp - - | otherwise - = do -- If the result type is not definitely lifted, then we must generate - -- let f = \s . tick e - -- in f realWorld# - -- When we stop at the breakpoint, _result will have an unlifted - -- type and hence won't be bound in the environment, but the - -- breakpoint will otherwise work fine. - -- - -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where - -- r :: RuntimeRep is a variable. This can happen in the - -- continuations for a pattern-synonym matcher - -- match = /\(r::RuntimeRep) /\(a::TYPE r). - -- \(k :: Int -> a) \(v::T). - -- case v of MkV n -> k n - -- Here (k n) :: a :: Type r, so we don't know if it's lifted - -- or not; but that should be fine provided we add that void arg. - - id <- newId (mkVisFunTy realWorldStatePrimTy ty) - st <- newId realWorldStatePrimTy - let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp))) - (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id) - (emptyDVarSet, AnnVar realWorldPrimId))) - schemeE d s p letExp - - where - exp' = deAnnotate' exp - fvs = exprFreeVarsDSet exp' - ty = exprType exp' - --- ignore other kinds of tick -schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs - -schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut - -- no alts: scrut is guaranteed to diverge - -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token) - -- Convert - -- case .... of x { (# V'd-thing, a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } - -- because the return convention for both are identical. - -- - -- Note that it does not matter losing the void-rep thing from the - -- envt (it won't be bound now) because we never look such things up. - , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of - ([], [_]) - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) - ([_], []) - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) - _ -> Nothing - = res - -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) - | isUnboxedTupleCon dc - , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples - = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) - -schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) - | isUnboxedTupleType (idType bndr) - , Just ty <- case typePrimRep (idType bndr) of - [_] -> Just (unwrapType (idType bndr)) - [] -> Just voidPrimTy - _ -> Nothing - -- handles any pattern with a single non-void binder; in particular I/O - -- monad returns (# RealWorld#, a #) - = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) - -schemeE d s p (AnnCase scrut bndr _ alts) - = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} - -schemeE _ _ _ expr - = pprPanic "ByteCodeGen.schemeE: unhandled case" - (pprCoreExpr (deAnnotate' expr)) - --- Is this Id a not-necessarily-lifted join point? --- See Note [Not-necessarily-lifted join points], step 1 -isNNLJoinPoint :: Id -> Bool -isNNLJoinPoint x = isJoinId x && - Just True /= isLiftedType_maybe (idType x) - --- If necessary, modify this Id and body to protect not-necessarily-lifted join points. --- See Note [Not-necessarily-lifted join points], step 2. -protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet) -protectNNLJoinPointBind x rhs@(fvs, _) - | isNNLJoinPoint x - = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs)) - - | otherwise - = (x, rhs) - --- Update an Id's type to take a Void# argument. --- Precondition: the Id is a not-necessarily-lifted join point. --- See Note [Not-necessarily-lifted join points] -protectNNLJoinPointId :: Id -> Id -protectNNLJoinPointId x - = ASSERT( isNNLJoinPoint x ) - updateVarType (voidPrimTy `mkVisFunTy`) x - -{- - Ticked Expressions - ------------------ - - The idea is that the "breakpoint E" is really just an annotation on - the code. When we find such a thing, we pull out the useful information, - and then compile the code as if it was just the expression E. - -Note [Not-necessarily-lifted join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A join point variable is essentially a goto-label: it is, for example, -never used as an argument to another function, and it is called only -in tail position. See Note [Join points] and Note [Invariants on join points], -both in CoreSyn. Because join points do not compile to true, red-blooded -variables (with, e.g., registers allocated to them), they are allowed -to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points] -in CoreSyn.) - -However, in this byte-code generator, join points *are* treated just as -ordinary variables. There is no check whether a binding is for a join point -or not; they are all treated uniformly. (Perhaps there is a missed optimization -opportunity here, but that is beyond the scope of my (Richard E's) Thursday.) - -We thus must have *some* strategy for dealing with levity-polymorphic and -unlifted join points. Levity-polymorphic variables are generally not allowed -(though levity-polymorphic join points *are*; see Note [Invariants on join points] -in CoreSyn, point 6), and we don't wish to evaluate unlifted join points eagerly. -The questionable join points are *not-necessarily-lifted join points* -(NNLJPs). (Not having such a strategy led to #16509, which panicked in the -isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy: - -1. Detect NNLJPs. This is done in isNNLJoinPoint. - -2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the - type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.) - Note that functions are never levity-polymorphic, so this transformation - changes an NNLJP to a non-levity-polymorphic join point. This is done - in protectNNLJoinPointBind, called from the AnnLet case of schemeE. - -3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId), - being careful to note the new type of the NNLJP. This is done in the AnnVar - case of schemeE, with help from protectNNLJoinPointId. - -Here is an example. Suppose we have - - f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). - join j :: a - j = error @r @a "bloop" - in case x of - A -> j - B -> j - C -> error @r @a "blurp" - -Our plan is to behave is if the code was - - f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). - let j :: (Void# -> a) - j = \ _ -> error @r @a "bloop" - in case x of - A -> j void# - B -> j void# - C -> error @r @a "blurp" - -It's a bit hacky, but it works well in practice and is local. I suspect the -Right Fix is to take advantage of join points as goto-labels. - --} - --- Compile code to do a tail call. Specifically, push the fn, --- slide the on-stack app back down to the sequel depth, --- and enter. Four cases: --- --- 0. (Nasty hack). --- An application "GHC.Prim.tagToEnum# unboxed-int". --- The int will be on the stack. Generate a code sequence --- to convert it to the relevant constructor, SLIDE and ENTER. --- --- 1. The fn denotes a ccall. Defer to generateCCall. --- --- 2. (Another nasty hack). Spot (# a::V, b #) and treat --- it simply as b -- since the representations are identical --- (the V takes up zero stack space). Also, spot --- (# b #) and treat it as b. --- --- 3. Application of a constructor, by defn saturated. --- Split the args into ptrs and non-ptrs, and push the nonptrs, --- then the ptrs, and then do PACK and RETURN. --- --- 4. Otherwise, it must be a function call. Push the args --- right to left, SLIDE and ENTER. - -schemeT :: StackDepth -- Stack depth - -> Sequel -- Sequel depth - -> BCEnv -- stack env - -> AnnExpr' Id DVarSet - -> BcM BCInstrList - -schemeT d s p app - - -- Case 0 - | Just (arg, constr_names) <- maybe_is_tagToEnum_call app - = implement_tagToId d s p arg constr_names - - -- Case 1 - | Just (CCall ccall_spec) <- isFCallId_maybe fn - = if isSupportedCConv ccall_spec - then generateCCall d s p ccall_spec fn args_r_to_l - else unsupportedCConvException - - - -- Case 2: Constructor application - | Just con <- maybe_saturated_dcon - , isUnboxedTupleCon con - = case args_r_to_l of - [arg1,arg2] | isVAtom arg1 -> - unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVAtom arg2 -> - unboxedTupleReturn d s p arg1 - _other -> multiValException - - -- Case 3: Ordinary data constructor - | Just con <- maybe_saturated_dcon - = do alloc_con <- mkConAppCode d s p con args_r_to_l - dflags <- getDynFlags - return (alloc_con `appOL` - mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL` - ENTER) - - -- Case 4: Tail call of function - | otherwise - = doTailCall d s p fn args_r_to_l - - where - -- Extract the args (R->L) and fn - -- The function will necessarily be a variable, - -- because we are compiling a tail call - (AnnVar fn, args_r_to_l) = splitApp app - - -- Only consider this to be a constructor application iff it is - -- saturated. Otherwise, we'll call the constructor wrapper. - n_args = length args_r_to_l - maybe_saturated_dcon - = case isDataConWorkId_maybe fn of - Just con | dataConRepArity con == n_args -> Just con - _ -> Nothing - --- ----------------------------------------------------------------------------- --- Generate code to build a constructor application, --- leaving it on top of the stack - -mkConAppCode - :: StackDepth - -> Sequel - -> BCEnv - -> DataCon -- The data constructor - -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order - -> BcM BCInstrList -mkConAppCode _ _ _ con [] -- Nullary constructor - = ASSERT( isNullaryRepDataCon con ) - return (unitOL (PUSH_G (getName (dataConWorkId con)))) - -- Instead of doing a PACK, which would allocate a fresh - -- copy of this constructor, use the single shared version. - -mkConAppCode orig_d _ p con args_r_to_l = - ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code - where - app_code = do - dflags <- getDynFlags - - -- The args are initially in reverse order, but mkVirtHeapOffsets - -- expects them to be left-to-right. - let non_voids = - [ NonVoid (prim_rep, arg) - | arg <- reverse args_r_to_l - , let prim_rep = atomPrimRep arg - , not (isVoidRep prim_rep) - ] - (_, _, args_offsets) = - mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids - - do_pushery !d (arg : args) = do - (push, arg_bytes) <- case arg of - (Padding l _) -> return $! pushPadding l - (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) - more_push_code <- do_pushery (d + arg_bytes) args - return (push `appOL` more_push_code) - do_pushery !d [] = do - let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d) - return (unitOL (PACK con n_arg_words)) - - -- Push on the stack in the reverse order. - do_pushery orig_d (reverse args_offsets) - - --- ----------------------------------------------------------------------------- --- Returning an unboxed tuple with one non-void component (the only --- case we can handle). --- --- Remember, we don't want to *evaluate* the component that is being --- returned, even if it is a pointed type. We always just return. - -unboxedTupleReturn - :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList -unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg) - --- ----------------------------------------------------------------------------- --- Generate code for a tail-call - -doTailCall - :: StackDepth - -> Sequel - -> BCEnv - -> Id - -> [AnnExpr' Id DVarSet] - -> BcM BCInstrList -doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args) - where - do_pushes !d [] reps = do - ASSERT( null reps ) return () - (push_fn, sz) <- pushAtom d p (AnnVar fn) - dflags <- getDynFlags - ASSERT( sz == wordSize dflags ) return () - let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s) - return (push_fn `appOL` (slide `appOL` unitOL ENTER)) - do_pushes !d args reps = do - let (push_apply, n, rest_of_reps) = findPushSeq reps - (these_args, rest_of_args) = splitAt n args - (next_d, push_code) <- push_seq d these_args - dflags <- getDynFlags - instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps - -- ^^^ for the PUSH_APPLY_ instruction - return (push_code `appOL` (push_apply `consOL` instrs)) - - push_seq d [] = return (d, nilOL) - push_seq d (arg:args) = do - (push_code, sz) <- pushAtom d p arg - (final_d, more_push_code) <- push_seq (d + sz) args - return (final_d, push_code `appOL` more_push_code) - --- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) -findPushSeq (P: P: P: P: P: P: rest) - = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (P: P: P: P: P: rest) - = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (P: P: P: P: rest) - = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (P: P: P: rest) - = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (P: P: rest) - = (PUSH_APPLY_PP, 2, rest) -findPushSeq (P: rest) - = (PUSH_APPLY_P, 1, rest) -findPushSeq (V: rest) - = (PUSH_APPLY_V, 1, rest) -findPushSeq (N: rest) - = (PUSH_APPLY_N, 1, rest) -findPushSeq (F: rest) - = (PUSH_APPLY_F, 1, rest) -findPushSeq (D: rest) - = (PUSH_APPLY_D, 1, rest) -findPushSeq (L: rest) - = (PUSH_APPLY_L, 1, rest) -findPushSeq _ - = panic "ByteCodeGen.findPushSeq" - --- ----------------------------------------------------------------------------- --- Case expressions - -doCase - :: StackDepth - -> Sequel - -> BCEnv - -> AnnExpr Id DVarSet - -> Id - -> [AnnAlt Id DVarSet] - -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, - -- don't enter the result - -> BcM BCInstrList -doCase d s p (_,scrut) bndr alts is_unboxed_tuple - | typePrimRep (idType bndr) `lengthExceeds` 1 - = multiValException - | otherwise - = do - dflags <- getDynFlags - let - profiling - | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags - | otherwise = rtsIsProfiled - - -- Top of stack is the return itbl, as usual. - -- underneath it is the pointer to the alt_code BCO. - -- When an alt is entered, it assumes the returned value is - -- on top of the itbl. - ret_frame_size_b :: StackDepth - ret_frame_size_b = 2 * wordSize dflags - - -- The extra frame we push to save/restor the CCCS when profiling - save_ccs_size_b | profiling = 2 * wordSize dflags - | otherwise = 0 - - -- An unlifted value gets an extra info table pushed on top - -- when it is returned. - unlifted_itbl_size_b :: StackDepth - unlifted_itbl_size_b | isAlgCase = 0 - | otherwise = wordSize dflags - - -- depth of stack after the return value has been pushed - d_bndr = - d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr) - - -- depth of stack after the extra info table for an unboxed return - -- has been pushed, if any. This is the stack depth at the - -- continuation. - d_alts = d_bndr + unlifted_itbl_size_b - - -- Env in which to compile the alts, not including - -- any vars bound by the alts themselves - p_alts0 = Map.insert bndr d_bndr p - - p_alts = case is_unboxed_tuple of - Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0 - Nothing -> p_alts0 - - bndr_ty = idType bndr - isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple - - -- given an alt, return a discr and code for it. - codeAlt (DEFAULT, _, (_,rhs)) - = do rhs_code <- schemeE d_alts s p_alts rhs - return (NoDiscr, rhs_code) - - codeAlt alt@(_, bndrs, (_,rhs)) - -- primitive or nullary constructor alt: no need to UNPACK - | null real_bndrs = do - rhs_code <- schemeE d_alts s p_alts rhs - return (my_discr alt, rhs_code) - -- If an alt attempts to match on an unboxed tuple or sum, we must - -- bail out, as the bytecode compiler can't handle them. - -- (See #14608.) - | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs - = multiValException - -- algebraic alt with some binders - | otherwise = - let (tot_wds, _ptrs_wds, args_offsets) = - mkVirtHeapOffsets dflags NoHeader - [ NonVoid (bcIdPrimRep id, id) - | NonVoid id <- nonVoidIds real_bndrs - ] - size = WordOff tot_wds - - stack_bot = d_alts + wordsToBytes dflags size - - -- convert offsets from Sp into offsets into the virtual stack - p' = Map.insertList - [ (arg, stack_bot - ByteOff offset) - | (NonVoid arg, offset) <- args_offsets ] - p_alts - in do - MASSERT(isAlgCase) - rhs_code <- schemeE stack_bot s p' rhs - return (my_discr alt, - unitOL (UNPACK (trunc16W size)) `appOL` rhs_code) - where - real_bndrs = filterOut isTyVar bndrs - - my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} - my_discr (DataAlt dc, _, _) - | isUnboxedTupleCon dc || isUnboxedSumCon dc - = multiValException - | otherwise - = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) - my_discr (LitAlt l, _, _) - = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i) - LitNumber LitNumWord w _ -> DiscrW (fromInteger w) - LitFloat r -> DiscrF (fromRational r) - LitDouble r -> DiscrD (fromRational r) - LitChar i -> DiscrI (ord i) - _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) - - maybe_ncons - | not isAlgCase = Nothing - | otherwise - = case [dc | (DataAlt dc, _, _) <- alts] of - [] -> Nothing - (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) - - -- the bitmap is relative to stack depth d, i.e. before the - -- BCO, info table and return value are pushed on. - -- This bit of code is v. similar to buildLivenessMask in CgBindery, - -- except that here we build the bitmap from the known bindings of - -- things that are pointers, whereas in CgBindery the code builds the - -- bitmap from the free slots and unboxed bindings. - -- (ToDo: merge?) - -- - -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. - -- The bitmap must cover the portion of the stack up to the sequel only. - -- Previously we were building a bitmap for the whole depth (d), but we - -- really want a bitmap up to depth (d-s). This affects compilation of - -- case-of-case expressions, which is the only time we can be compiling a - -- case expression with s /= 0. - bitmap_size = trunc16W $ bytesToWords dflags (d - s) - bitmap_size' :: Int - bitmap_size' = fromIntegral bitmap_size - bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} - (sort (filter (< bitmap_size') rel_slots)) - where - binds = Map.toList p - -- NB: unboxed tuple cases bind the scrut binder to the same offset - -- as one of the alt binders, so we have to remove any duplicates here: - rel_slots = nub $ map fromIntegral $ concat (map spread binds) - spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ] - | otherwise = [] - where rel_offset = trunc16W $ bytesToWords dflags (d - offset) - - alt_stuff <- mapM codeAlt alts - alt_final <- mkMultiBranch maybe_ncons alt_stuff - - let - alt_bco_name = getName bndr - alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) - 0{-no arity-} bitmap_size bitmap True{-is alts-} --- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ --- "\n bitmap = " ++ show bitmap) $ do - - scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b) - (d + ret_frame_size_b + save_ccs_size_b) - p scrut - alt_bco' <- emitBc alt_bco - let push_alts - | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty) - return (push_alts `consOL` scrut_code) - - --- ----------------------------------------------------------------------------- --- Deal with a CCall. - --- Taggedly push the args onto the stack R->L, --- deferencing ForeignObj#s and adjusting addrs to point to --- payloads in Ptr/Byte arrays. Then, generate the marshalling --- (machine) code for the ccall, and create bytecodes to call that and --- then return in the right way. - -generateCCall - :: StackDepth - -> Sequel - -> BCEnv - -> CCallSpec -- where to call - -> Id -- of target, for type info - -> [AnnExpr' Id DVarSet] -- args (atoms) - -> BcM BCInstrList -generateCCall d0 s p (CCallSpec target cconv safety _rep_ret _rep_args) fn args_r_to_l - = do - dflags <- getDynFlags - - let - -- useful constants - addr_size_b :: ByteOff - addr_size_b = wordSize dflags - - -- Get the args on the stack, with tags and suitably - -- dereferenced for the CCall. For each arg, return the - -- depth to the first word of the bits for that arg, and the - -- ArgRep of what was actually pushed. - - pargs - :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)] - pargs _ [] = return [] - pargs d (a:az) - = let arg_ty = unwrapType (exprType (deAnnotate' a)) - - in case tyConAppTyCon_maybe arg_ty of - -- Don't push the FO; instead push the Addr# it - -- contains. - Just t - | t == arrayPrimTyCon || t == mutableArrayPrimTyCon - -> do rest <- pargs (d + addr_size_b) az - code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a - return ((code,AddrRep):rest) - - | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon - -> do rest <- pargs (d + addr_size_b) az - code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a - return ((code,AddrRep):rest) - - | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon - -> do rest <- pargs (d + addr_size_b) az - code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a - return ((code,AddrRep):rest) - - -- Default case: push taggedly, but otherwise intact. - _ - -> do (code_a, sz_a) <- pushAtom d p a - rest <- pargs (d + sz_a) az - return ((code_a, atomPrimRep a) : rest) - - -- Do magic for Ptr/Byte arrays. Push a ptr to the array on - -- the stack but then advance it over the headers, so as to - -- point to the payload. - parg_ArrayishRep - :: Word16 - -> StackDepth - -> BCEnv - -> AnnExpr' Id DVarSet - -> BcM BCInstrList - parg_ArrayishRep hdrSize d p a - = do (push_fo, _) <- pushAtom d p a - -- The ptr points at the header. Advance it over the - -- header and then pretend this is an Addr#. - return (push_fo `snocOL` SWIZZLE 0 hdrSize) - - code_n_reps <- pargs d0 args_r_to_l - let - (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps - a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l) - - push_args = concatOL pushs_arg - !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW - a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l)) - = panic "ByteCodeGen.generateCCall: missing or invalid World token?" - | otherwise - = reverse (tail a_reps_pushed_r_to_l) - - -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. - -- push_args is the code to do that. - -- d_after_args is the stack depth once the args are on. - - -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) - {- - Because the Haskell stack grows down, the a_reps refer to - lowest to highest addresses in that order. The args for the call - are on the stack. Now push an unboxed Addr# indicating - the C function to call. Then push a dummy placeholder for the - result. Finally, emit a CCALL insn with an offset pointing to the - Addr# just pushed, and a literal field holding the mallocville - address of the piece of marshalling code we generate. - So, just prior to the CCALL insn, the stack looks like this - (growing down, as usual): - - - ... - - Addr# address_of_C_fn - (must be an unboxed type) - - The interpreter then calls the marshall code mentioned - in the CCALL insn, passing it (& ), - that is, the addr of the topmost word in the stack. - When this returns, the placeholder will have been - filled in. The placeholder is slid down to the sequel - depth, and we RETURN. - - This arrangement makes it simple to do f-i-dynamic since the Addr# - value is the first arg anyway. - - The marshalling code is generated specifically for this - call site, and so knows exactly the (Haskell) stack - offsets of the args, fn address and placeholder. It - copies the args to the C stack, calls the stacked addr, - and parks the result back in the placeholder. The interpreter - calls it as a normal C call, assuming it has a signature - void marshall_code ( StgWord* ptr_to_top_of_stack ) - -} - -- resolve static address - maybe_static_target :: Maybe Literal - maybe_static_target = - case target of - DynamicTarget -> Nothing - StaticTarget _ _ _ False -> - panic "generateCCall: unexpected FFI value import" - StaticTarget _ target _ True -> - Just (LitLabel target mb_size IsFunction) - where - mb_size - | OSMinGW32 <- platformOS (targetPlatform dflags) - , StdCallConv <- cconv - = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags) - | otherwise - = Nothing - - let - is_static = isJust maybe_static_target - - -- Get the arg reps, zapping the leading Addr# in the dynamic case - a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" - | is_static = a_reps_pushed_RAW - | otherwise = if null a_reps_pushed_RAW - then panic "ByteCodeGen.generateCCall: dyn with no args" - else tail a_reps_pushed_RAW - - -- push the Addr# - (push_Addr, d_after_Addr) - | Just machlabel <- maybe_static_target - = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b) - | otherwise -- is already on the stack - = (nilOL, d_after_args) - - -- Push the return placeholder. For a call returning nothing, - -- this is a V (tag). - r_sizeW = repSizeWords dflags r_rep - d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW - push_r = - if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW)) - - -- generate the marshalling code we're going to call - - -- Offset of the next stack frame down the stack. The CCALL - -- instruction needs to describe the chunk of stack containing - -- the ccall args to the GC, so it needs to know how large it - -- is. See comment in Interpreter.c with the CCALL instruction. - stk_offset = trunc16W $ bytesToWords dflags (d_after_r - s) - - conv = case cconv of - CCallConv -> FFICCall - StdCallConv -> FFIStdCall - _ -> panic "ByteCodeGen: unexpected calling convention" - - -- the only difference in libffi mode is that we prepare a cif - -- describing the call type by calling libffi, and we attach the - -- address of this to the CCALL instruction. - - - let ffires = primRepToFFIType dflags r_rep - ffiargs = map (primRepToFFIType dflags) a_reps - hsc_env <- getHscEnv - token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires) - recordFFIBc token - - let - -- do the call - do_call = unitOL (CCALL stk_offset token flags) - where flags = case safety of - PlaySafe -> 0x0 - PlayInterruptible -> 0x1 - PlayRisky -> 0x2 - - -- slide and return - d_after_r_min_s = bytesToWords dflags (d_after_r - s) - wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW) - `snocOL` RETURN_UBX (toArgRep r_rep) - --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ - return ( - push_args `appOL` - push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup - ) - -primRepToFFIType :: DynFlags -> PrimRep -> FFIType -primRepToFFIType dflags r - = case r of - VoidRep -> FFIVoid - IntRep -> signed_word - WordRep -> unsigned_word - Int8Rep -> FFISInt8 - Word8Rep -> FFIUInt8 - Int16Rep -> FFISInt16 - Word16Rep -> FFIUInt16 - Int32Rep -> FFISInt32 - Word32Rep -> FFIUInt32 - Int64Rep -> FFISInt64 - Word64Rep -> FFIUInt64 - AddrRep -> FFIPointer - FloatRep -> FFIFloat - DoubleRep -> FFIDouble - _ -> panic "primRepToFFIType" - where - (signed_word, unsigned_word) - | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32) - | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64) - | otherwise = panic "primTyDescChar" - --- Make a dummy literal, to be used as a placeholder for FFI return --- values on the stack. -mkDummyLiteral :: DynFlags -> PrimRep -> Literal -mkDummyLiteral dflags pr - = case pr of - IntRep -> mkLitInt dflags 0 - WordRep -> mkLitWord dflags 0 - Int64Rep -> mkLitInt64 0 - Word64Rep -> mkLitWord64 0 - AddrRep -> LitNullAddr - DoubleRep -> LitDouble 0 - FloatRep -> LitFloat 0 - _ -> pprPanic "mkDummyLiteral" (ppr pr) - - --- Convert (eg) --- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld --- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) --- --- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is V'd. --- --- Alternatively, for call-targets returning nothing, convert --- --- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld --- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) --- --- to Nothing - -maybe_getCCallReturnRep :: Type -> Maybe PrimRep -maybe_getCCallReturnRep fn_ty - = let - (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) - in - case r_reps of - [] -> panic "empty typePrimRepArgs" - [VoidRep] -> Nothing - [rep] - | isGcPtrRep rep -> blargh - | otherwise -> Just rep - - -- if it was, it would be impossible to create a - -- valid return value placeholder on the stack - _ -> blargh - -maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) --- Detect and extract relevant info for the tagToEnum kludge. -maybe_is_tagToEnum_call app - | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app - , Just TagToEnumOp <- isPrimOpId_maybe v - = Just (snd arg, extract_constr_Names t) - | otherwise - = Nothing - where - extract_constr_Names ty - | rep_ty <- unwrapType ty - , Just tyc <- tyConAppTyCon_maybe rep_ty - , isDataTyCon tyc - = map (getName . dataConWorkId) (tyConDataCons tyc) - -- NOTE: use the worker name, not the source name of - -- the DataCon. See DataCon.hs for details. - | otherwise - = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) - -{- ----------------------------------------------------------------------------- -Note [Implementing tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(implement_tagToId arg names) compiles code which takes an argument -'arg', (call it i), and enters the i'th closure in the supplied list -as a consequence. The [Name] is a list of the constructors of this -(enumeration) type. - -The code we generate is this: - push arg - push bogus-word - - TESTEQ_I 0 L1 - PUSH_G - JMP L_Exit - - L1: TESTEQ_I 1 L2 - PUSH_G - JMP L_Exit - ...etc... - Ln: TESTEQ_I n L_fail - PUSH_G - JMP L_Exit - - L_fail: CASEFAIL - - L_exit: SLIDE 1 n - ENTER - -The 'bogus-word' push is because TESTEQ_I expects the top of the stack -to have an info-table, and the next word to have the value to be -tested. This is very weird, but it's the way it is right now. See -Interpreter.c. We don't acutally need an info-table here; we just -need to have the argument to be one-from-top on the stack, hence pushing -a 1-word null. See #8383. --} - - -implement_tagToId - :: StackDepth - -> Sequel - -> BCEnv - -> AnnExpr' Id DVarSet - -> [Name] - -> BcM BCInstrList --- See Note [Implementing tagToEnum#] -implement_tagToId d s p arg names - = ASSERT( notNull names ) - do (push_arg, arg_bytes) <- pushAtom d p arg - labels <- getLabelsBc (genericLength names) - label_fail <- getLabelBc - label_exit <- getLabelBc - dflags <- getDynFlags - let infos = zip4 labels (tail labels ++ [label_fail]) - [0 ..] names - steps = map (mkStep label_exit) infos - slide_ws = bytesToWords dflags (d - s + arg_bytes) - - return (push_arg - `appOL` unitOL (PUSH_UBX LitNullAddr 1) - -- Push bogus word (see Note [Implementing tagToEnum#]) - `appOL` concatOL steps - `appOL` toOL [ LABEL label_fail, CASEFAIL, - LABEL label_exit ] - `appOL` mkSlideW 1 (slide_ws + 1) - -- "+1" to account for bogus word - -- (see Note [Implementing tagToEnum#]) - `appOL` unitOL ENTER) - where - mkStep l_exit (my_label, next_label, n, name_for_n) - = toOL [LABEL my_label, - TESTEQ_I n next_label, - PUSH_G name_for_n, - JMP l_exit] - - --- ----------------------------------------------------------------------------- --- pushAtom - --- Push an atom onto the stack, returning suitable code & number of --- stack words used. --- --- The env p must map each variable to the highest- numbered stack --- slot for it. For example, if the stack has depth 4 and we --- tagged-ly push (v :: Int#) on it, the value will be in stack[4], --- the tag in stack[5], the stack will have depth 6, and p must map v --- to 5 and not to 4. Stack locations are numbered from zero, so a --- depth 6 stack has valid words 0 .. 5. - -pushAtom - :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) -pushAtom d p e - | Just e' <- bcView e - = pushAtom d p e' - -pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, - = return (nilOL, 0) -- treated just like a variable V - --- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs --- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs: --- The scrutinee of an empty case evaluates to bottom -pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 - = pushAtom d p a - -pushAtom d p (AnnVar var) - | [] <- typePrimRep (idType var) - = return (nilOL, 0) - - | isFCallId var - = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var) - - | Just primop <- isPrimOpId_maybe var - = do - dflags <-getDynFlags - return (unitOL (PUSH_PRIMOP primop), wordSize dflags) - - | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable - = do dflags <- getDynFlags - - let !szb = idSizeCon dflags var - with_instr instr = do - let !off_b = trunc16B $ d - d_v - return (unitOL (instr off_b), wordSize dflags) - - case szb of - 1 -> with_instr PUSH8_W - 2 -> with_instr PUSH16_W - 4 -> with_instr PUSH32_W - _ -> do - let !szw = bytesToWords dflags szb - !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1 - return (toOL (genericReplicate szw (PUSH_L off_w)), szb) - -- d - d_v offset from TOS to the first slot of the object - -- - -- d - d_v + sz - 1 offset from the TOS of the last slot of the object - -- - -- Having found the last slot, we proceed to copy the right number of - -- slots on to the top of the stack. - - | otherwise -- var must be a global variable - = do topStrings <- getTopStrings - dflags <- getDynFlags - case lookupVarEnv topStrings var of - Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $ - fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr - Nothing -> do - let sz = idSizeCon dflags var - MASSERT( sz == wordSize dflags ) - return (unitOL (PUSH_G (getName var)), sz) - - -pushAtom _ _ (AnnLit lit) = do - dflags <- getDynFlags - let code rep - = let size_words = WordOff (argRepSizeW dflags rep) - in return (unitOL (PUSH_UBX lit (trunc16W size_words)), - wordsToBytes dflags size_words) - - case lit of - LitLabel _ _ _ -> code N - LitFloat _ -> code F - LitDouble _ -> code D - LitChar _ -> code N - LitNullAddr -> code N - LitString _ -> code N - LitRubbish -> code N - LitNumber nt _ _ -> case nt of - LitNumInt -> code N - LitNumWord -> code N - LitNumInt64 -> code L - LitNumWord64 -> code L - -- No LitInteger's or LitNatural's should be left by the time this is - -- called. CorePrep should have converted them all to a real core - -- representation. - LitNumInteger -> panic "pushAtom: LitInteger" - LitNumNatural -> panic "pushAtom: LitNatural" - -pushAtom _ _ expr - = pprPanic "ByteCodeGen.pushAtom" - (pprCoreExpr (deAnnotate' expr)) - - --- | Push an atom for constructor (i.e., PACK instruction) onto the stack. --- This is slightly different to @pushAtom@ due to the fact that we allow --- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. -pushConstrAtom - :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) - -pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) = - return (unitOL (PUSH_UBX32 lit), 4) - -pushConstrAtom d p (AnnVar v) - | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable - dflags <- getDynFlags - let !szb = idSizeCon dflags v - done instr = do - let !off = trunc16B $ d - d_v - return (unitOL (instr off), szb) - case szb of - 1 -> done PUSH8 - 2 -> done PUSH16 - 4 -> done PUSH32 - _ -> pushAtom d p (AnnVar v) - -pushConstrAtom d p expr = pushAtom d p expr - -pushPadding :: Int -> (BCInstrList, ByteOff) -pushPadding !n = go n (nilOL, 0) - where - go n acc@(!instrs, !off) = case n of - 0 -> acc - 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1) - 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2) - 3 -> go 1 (go 2 acc) - 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4) - _ -> go (n - 4) (go 4 acc) - --- ----------------------------------------------------------------------------- --- Given a bunch of alts code and their discrs, do the donkey work --- of making a multiway branch using a switch tree. --- What a load of hassle! - -mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt - -- a hint; generates better code - -- Nothing is always safe - -> [(Discr, BCInstrList)] - -> BcM BCInstrList -mkMultiBranch maybe_ncons raw_ways = do - lbl_default <- getLabelBc - - let - mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList - mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) - -- shouldn't happen? - - mkTree [val] range_lo range_hi - | range_lo == range_hi - = return (snd val) - | null defaults -- Note [CASEFAIL] - = do lbl <- getLabelBc - return (testEQ (fst val) lbl - `consOL` (snd val - `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) - | otherwise - = return (testEQ (fst val) lbl_default `consOL` snd val) - - -- Note [CASEFAIL] It may be that this case has no default - -- branch, but the alternatives are not exhaustive - this - -- happens for GADT cases for example, where the types - -- prove that certain branches are impossible. We could - -- just assume that the other cases won't occur, but if - -- this assumption was wrong (because of a bug in GHC) - -- then the result would be a segfault. So instead we - -- emit an explicit test and a CASEFAIL instruction that - -- causes the interpreter to barf() if it is ever - -- executed. - - mkTree vals range_lo range_hi - = let n = length vals `div` 2 - vals_lo = take n vals - vals_hi = drop n vals - v_mid = fst (head vals_hi) - in do - label_geq <- getLabelBc - code_lo <- mkTree vals_lo range_lo (dec v_mid) - code_hi <- mkTree vals_hi v_mid range_hi - return (testLT v_mid label_geq - `consOL` (code_lo - `appOL` unitOL (LABEL label_geq) - `appOL` code_hi)) - - the_default - = case defaults of - [] -> nilOL - [(_, def)] -> LABEL lbl_default `consOL` def - _ -> panic "mkMultiBranch/the_default" - instrs <- mkTree notd_ways init_lo init_hi - return (instrs `appOL` the_default) - where - (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways - notd_ways = sortBy (comparing fst) not_defaults - - testLT (DiscrI i) fail_label = TESTLT_I i fail_label - testLT (DiscrW i) fail_label = TESTLT_W i fail_label - testLT (DiscrF i) fail_label = TESTLT_F i fail_label - testLT (DiscrD i) fail_label = TESTLT_D i fail_label - testLT (DiscrP i) fail_label = TESTLT_P i fail_label - testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" - - testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label - testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label - testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label - testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label - testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label - testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" - - -- None of these will be needed if there are no non-default alts - (init_lo, init_hi) - | null notd_ways - = panic "mkMultiBranch: awesome foursome" - | otherwise - = case fst (head notd_ways) of - DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) - DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) - DiscrF _ -> ( DiscrF minF, DiscrF maxF ) - DiscrD _ -> ( DiscrD minD, DiscrD maxD ) - DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) - NoDiscr -> panic "mkMultiBranch NoDiscr" - - (algMinBound, algMaxBound) - = case maybe_ncons of - -- XXX What happens when n == 0? - Just n -> (0, fromIntegral n - 1) - Nothing -> (minBound, maxBound) - - isNoDiscr NoDiscr = True - isNoDiscr _ = False - - dec (DiscrI i) = DiscrI (i-1) - dec (DiscrW w) = DiscrW (w-1) - dec (DiscrP i) = DiscrP (i-1) - dec other = other -- not really right, but if you - -- do cases on floating values, you'll get what you deserve - - -- same snotty comment applies to the following - minF, maxF :: Float - minD, maxD :: Double - minF = -1.0e37 - maxF = 1.0e37 - minD = -1.0e308 - maxD = 1.0e308 - - --- ----------------------------------------------------------------------------- --- Supporting junk for the compilation schemes - --- Describes case alts -data Discr - = DiscrI Int - | DiscrW Word - | DiscrF Float - | DiscrD Double - | DiscrP Word16 - | NoDiscr - deriving (Eq, Ord) - -instance Outputable Discr where - ppr (DiscrI i) = int i - ppr (DiscrW w) = text (show w) - ppr (DiscrF f) = text (show f) - ppr (DiscrD d) = text (show d) - ppr (DiscrP i) = ppr i - ppr NoDiscr = text "DEF" - - -lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff -lookupBCEnv_maybe = Map.lookup - -idSizeW :: DynFlags -> Id -> WordOff -idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep - -idSizeCon :: DynFlags -> Id -> ByteOff -idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep - -bcIdArgRep :: Id -> ArgRep -bcIdArgRep = toArgRep . bcIdPrimRep - -bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep id - | [rep] <- typePrimRepArgs (idType id) - = rep - | otherwise - = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - -repSizeWords :: DynFlags -> PrimRep -> WordOff -repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep) - -isFollowableArg :: ArgRep -> Bool -isFollowableArg P = True -isFollowableArg _ = False - -isVoidArg :: ArgRep -> Bool -isVoidArg V = True -isVoidArg _ = False - --- See bug #1257 -multiValException :: a -multiValException = throwGhcException (ProgramError - ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++ - " Possibly due to foreign import/export decls in source.\n"++ - " Workaround: use -fobject-code, or compile this module to .o separately.")) - --- | Indicate if the calling convention is supported -isSupportedCConv :: CCallSpec -> Bool -isSupportedCConv (CCallSpec _ cconv _ _ _) = case cconv of - CCallConv -> True -- we explicitly pattern match on every - StdCallConv -> True -- convention to ensure that a warning - PrimCallConv -> False -- is triggered when a new one is added - JavaScriptCallConv -> False - CApiConv -> False - --- See bug #10462 -unsupportedCConvException :: a -unsupportedCConvException = throwGhcException (ProgramError - ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ - " Workaround: use -fobject-code, or compile this module to .o separately.")) - -mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr -mkSlideB dflags !nb !db = mkSlideW n d - where - !n = trunc16W $ bytesToWords dflags nb - !d = bytesToWords dflags db - -mkSlideW :: Word16 -> WordOff -> OrdList BCInstr -mkSlideW !n !ws - | ws > fromIntegral limit - -- If the amount to slide doesn't fit in a Word16, generate multiple slide - -- instructions - = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit) - | ws == 0 - = nilOL - | otherwise - = unitOL (SLIDE n $ fromIntegral ws) - where - limit :: Word16 - limit = maxBound - -splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) - -- The arguments are returned in *right-to-left* order -splitApp e | Just e' <- bcView e = splitApp e' -splitApp (AnnApp (_,f) (_,a)) = case splitApp f of - (f', as) -> (f', a:as) -splitApp e = (e, []) - - -bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) --- The "bytecode view" of a term discards --- a) type abstractions --- b) type applications --- c) casts --- d) ticks (but not breakpoints) --- Type lambdas *can* occur in random expressions, --- whereas value lambdas cannot; that is why they are nuked here -bcView (AnnCast (_,e) _) = Just e -bcView (AnnLam v (_,e)) | isTyVar v = Just e -bcView (AnnApp (_,e) (_, AnnType _)) = Just e -bcView (AnnTick Breakpoint{} _) = Nothing -bcView (AnnTick _other_tick (_,e)) = Just e -bcView _ = Nothing - -isVAtom :: AnnExpr' Var ann -> Bool -isVAtom e | Just e' <- bcView e = isVAtom e' -isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) -isVAtom (AnnCoercion {}) = True -isVAtom _ = False - -atomPrimRep :: AnnExpr' Id ann -> PrimRep -atomPrimRep e | Just e' <- bcView e = atomPrimRep e' -atomPrimRep (AnnVar v) = bcIdPrimRep v -atomPrimRep (AnnLit l) = typePrimRep1 (literalType l) - --- #12128: --- A case expression can be an atom because empty cases evaluate to bottom. --- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs -atomPrimRep (AnnCase _ _ ty _) = - ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep -atomPrimRep (AnnCoercion {}) = VoidRep -atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) - -atomRep :: AnnExpr' Id ann -> ArgRep -atomRep e = toArgRep (atomPrimRep e) - --- | Let szsw be the sizes in bytes of some items pushed onto the stack, which --- has initial depth @original_depth@. Return the values which the stack --- environment should map these items to. -mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] -mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) - -typeArgRep :: Type -> ArgRep -typeArgRep = toArgRep . typePrimRep1 - --- ----------------------------------------------------------------------------- --- The bytecode generator's monad - -data BcM_State - = BcM_State - { bcm_hsc_env :: HscEnv - , uniqSupply :: UniqSupply -- for generating fresh variable names - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word16 -- for generating local labels - , ffis :: [FFIInfo] -- ffi info blocks, to free later - -- Should be free()d when it is GCd - , modBreaks :: Maybe ModBreaks -- info about breakpoints - , breakInfo :: IntMap CgBreakInfo - , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals - -- See Note [generating code for top-level string literal bindings]. - } - -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) - -ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io - return (st, x) - -runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks - -> IdEnv (RemotePtr ()) - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env us this_mod modBreaks topStrings (BcM m) - = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings) - -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc (BcM expr) cont = BcM $ \st0 -> do - (st1, q) <- expr st0 - let BcM k = cont q - (st2, r) <- k st1 - return (st2, r) - -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do - (st1, _) <- expr st0 - (st2, r) <- cont st1 - return (st2, r) - -returnBc :: a -> BcM a -returnBc result = BcM $ \st -> (return (st, result)) - -instance Applicative BcM where - pure = returnBc - (<*>) = ap - (*>) = thenBc_ - -instance Monad BcM where - (>>=) = thenBc - (>>) = (*>) - -instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) - -getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) - -emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) -emitBc bco - = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) - -recordFFIBc :: RemotePtr C_ffi_cif -> BcM () -recordFFIBc a - = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) - -getLabelBc :: BcM Word16 -getLabelBc - = BcM $ \st -> do let nl = nextlabel st - when (nl == maxBound) $ - panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, nl) - -getLabelsBc :: Word16 -> BcM [Word16] -getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) - -getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre)) -getCCArray = BcM $ \st -> - let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in - return (st, modBreaks_ccs breaks) - - -newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM () -newBreakInfo ix info = BcM $ \st -> - return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) - -newUnique :: BcM Unique -newUnique = BcM $ - \st -> case takeUniqFromSupply (uniqSupply st) of - (uniq, us) -> let newState = st { uniqSupply = us } - in return (newState, uniq) - -getCurrentModule :: BcM Module -getCurrentModule = BcM $ \st -> return (st, thisModule st) - -getTopStrings :: BcM (IdEnv (RemotePtr ())) -getTopStrings = BcM $ \st -> return (st, topStrings st) - -newId :: Type -> BcM Id -newId ty = do - uniq <- newUnique - return $ mkSysLocal tickFS uniq ty - -tickFS :: FastString -tickFS = fsLit "ticked" diff --git a/ghci/ByteCodeInstr.hs b/ghci/ByteCodeInstr.hs deleted file mode 100644 --- a/ghci/ByteCodeInstr.hs +++ /dev/null @@ -1,373 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeInstrs: Bytecode instruction definitions -module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), bciStackUse, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeTypes -import GHCi.RemoteTypes -import GHCi.FFI (C_ffi_cif) -import GHC.StgToCmm.Layout ( ArgRep(..) ) -import PprCore -import Outputable -import FastString -import Name -import Unique -import Id -import CoreSyn -import Literal -import DataCon -import VarSet -import PrimOp -import SMRep - -import Data.Word -import GHC.Stack.CCS (CostCentre) - --- ---------------------------------------------------------------------------- --- Bytecode instructions - -data ProtoBCO a - = ProtoBCO { - protoBCOName :: a, -- name, in some sense - protoBCOInstrs :: [BCInstr], -- instrs - -- arity and GC info - protoBCOBitmap :: [StgWord], - protoBCOBitmapSize :: Word16, - protoBCOArity :: Int, - -- what the BCO came from, for debugging only - protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), - -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] - } - -type LocalLabel = Word16 - -data BCInstr - -- Messing with the stack - = STKCHECK Word - - -- Push locals (existing bits of the stack) - | PUSH_L !Word16{-offset-} - | PUSH_LL !Word16 !Word16{-2 offsets-} - | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} - - -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e., - -- the stack will grow by 8, 16 or 32 bits) - | PUSH8 !Word16 - | PUSH16 !Word16 - | PUSH32 !Word16 - - -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the - -- value will take the whole word on the stack (i.e., the stack will gorw by - -- a word) - -- This is useful when extracting a packed constructor field for further use. - -- Currently we expect all values on the stack to take full words, except for - -- the ones used for PACK (i.e., actually constracting new data types, in - -- which case we use PUSH{8,16,32}) - | PUSH8_W !Word16 - | PUSH16_W !Word16 - | PUSH32_W !Word16 - - -- Push a ptr (these all map to PUSH_G really) - | PUSH_G Name - | PUSH_PRIMOP PrimOp - | PUSH_BCO (ProtoBCO Name) - - -- Push an alt continuation - | PUSH_ALTS (ProtoBCO Name) - | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep - - -- Pushing 8, 16 and 32 bits of padding (for constructors). - | PUSH_PAD8 - | PUSH_PAD16 - | PUSH_PAD32 - - -- Pushing literals - | PUSH_UBX8 Literal - | PUSH_UBX16 Literal - | PUSH_UBX32 Literal - | PUSH_UBX Literal Word16 - -- push this int/float/double/addr, on the stack. Word16 - -- is # of words to copy from literal pool. Eitherness reflects - -- the difficulty of dealing with MachAddr here, mostly due to - -- the excessive (and unnecessary) restrictions imposed by the - -- designers of the new Foreign library. In particular it is - -- quite impossible to convert an Addr to any other integral - -- type, and it appears impossible to get hold of the bits of - -- an addr, even though we need to assemble BCOs. - - -- various kinds of application - | PUSH_APPLY_N - | PUSH_APPLY_V - | PUSH_APPLY_F - | PUSH_APPLY_D - | PUSH_APPLY_L - | PUSH_APPLY_P - | PUSH_APPLY_PP - | PUSH_APPLY_PPP - | PUSH_APPLY_PPPP - | PUSH_APPLY_PPPPP - | PUSH_APPLY_PPPPPP - - | SLIDE Word16{-this many-} Word16{-down by this much-} - - -- To do with the heap - | ALLOC_AP !Word16 -- make an AP with this many payload words - | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words - | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words - | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-} - | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} - | UNPACK !Word16 -- unpack N words from t.o.s Constr - | PACK DataCon !Word16 - -- after assembly, the DataCon is an index into the - -- itbl array - -- For doing case trees - | LABEL LocalLabel - | TESTLT_I Int LocalLabel - | TESTEQ_I Int LocalLabel - | TESTLT_W Word LocalLabel - | TESTEQ_W Word LocalLabel - | TESTLT_F Float LocalLabel - | TESTEQ_F Float LocalLabel - | TESTLT_D Double LocalLabel - | TESTEQ_D Double LocalLabel - - -- The Word16 value is a constructor number and therefore - -- stored in the insn stream rather than as an offset into - -- the literal pool. - | TESTLT_P Word16 LocalLabel - | TESTEQ_P Word16 LocalLabel - - | CASEFAIL - | JMP LocalLabel - - -- For doing calls to C (via glue code generated by libffi) - | CCALL Word16 -- stack frame size - (RemotePtr C_ffi_cif) -- addr of the glue code - Word16 -- flags. - -- - -- 0x1: call is interruptible - -- 0x2: call is unsafe - -- - -- (XXX: inefficient, but I don't know - -- what the alignment constraints are.) - - -- For doing magic ByteArray passing to foreign calls - | SWIZZLE Word16 -- to the ptr N words down the stack, - Word16 -- add M (interpreted as a signed 16-bit entity) - - -- To Infinity And Beyond - | ENTER - | RETURN -- return a lifted value - | RETURN_UBX ArgRep -- return an unlifted value, here's its rep - - -- Breakpoints - | BRK_FUN Word16 Unique (RemotePtr CostCentre) - --- ----------------------------------------------------------------------------- --- Printing bytecode instructions - -instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO { protoBCOName = name - , protoBCOInstrs = instrs - , protoBCOBitmap = bitmap - , protoBCOBitmapSize = bsize - , protoBCOArity = arity - , protoBCOExpr = origin - , protoBCOFFIs = ffis }) - = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity - <+> text (show ffis) <> colon) - $$ nest 3 (case origin of - Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) - (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' - Right rhs -> pprCoreExprShort (deAnnotate rhs)) - $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) - $$ nest 3 (vcat (map ppr instrs)) - --- Print enough of the Core expression to enable the reader to find --- the expression in the -ddump-prep output. That is, we need to --- include at least a binder. - -pprCoreExprShort :: CoreExpr -> SDoc -pprCoreExprShort expr@(Lam _ _) - = let - (bndrs, _) = collectBinders expr - in - char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..." - -pprCoreExprShort (Case _expr var _ty _alts) - = text "case of" <+> ppr var - -pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ...")) -pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) - -pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e -pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T" - -pprCoreExprShort e = pprCoreExpr e - -pprCoreAltShort :: CoreAlt -> SDoc -pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr - -instance Outputable BCInstr where - ppr (STKCHECK n) = text "STKCHECK" <+> ppr n - ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset - ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 - ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 - ppr (PUSH8 offset) = text "PUSH8 " <+> ppr offset - ppr (PUSH16 offset) = text "PUSH16 " <+> ppr offset - ppr (PUSH32 offset) = text "PUSH32 " <+> ppr offset - ppr (PUSH8_W offset) = text "PUSH8_W " <+> ppr offset - ppr (PUSH16_W offset) = text "PUSH16_W " <+> ppr offset - ppr (PUSH32_W offset) = text "PUSH32_W " <+> ppr offset - ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm - ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." - <> ppr op - ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) - ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) - ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) - - ppr PUSH_PAD8 = text "PUSH_PAD8" - ppr PUSH_PAD16 = text "PUSH_PAD16" - ppr PUSH_PAD32 = text "PUSH_PAD32" - - ppr (PUSH_UBX8 lit) = text "PUSH_UBX8" <+> ppr lit - ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit - ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit - ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit - ppr PUSH_APPLY_N = text "PUSH_APPLY_N" - ppr PUSH_APPLY_V = text "PUSH_APPLY_V" - ppr PUSH_APPLY_F = text "PUSH_APPLY_F" - ppr PUSH_APPLY_D = text "PUSH_APPLY_D" - ppr PUSH_APPLY_L = text "PUSH_APPLY_L" - ppr PUSH_APPLY_P = text "PUSH_APPLY_P" - ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" - ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" - ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" - ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" - ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" - - ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d - ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz - ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz - ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz - ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," - <+> ppr offset <+> text "stkoff" - ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," - <+> ppr offset <+> text "stkoff" - ppr (UNPACK sz) = text "UNPACK " <+> ppr sz - ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz - ppr (LABEL lab) = text "__" <> ppr lab <> colon - ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab - ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab - ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab - ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab - ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab - ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab - ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab - ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab - ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab - ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab - ppr CASEFAIL = text "CASEFAIL" - ppr (JMP lab) = text "JMP" <+> ppr lab - ppr (CCALL off marshall_addr flags) = text "CCALL " <+> ppr off - <+> text "marshall code at" - <+> text (show marshall_addr) - <+> (case flags of - 0x1 -> text "(interruptible)" - 0x2 -> text "(unsafe)" - _ -> empty) - ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff - <+> text "by" <+> ppr n - ppr ENTER = text "ENTER" - ppr RETURN = text "RETURN" - ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk - ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "" - --- ----------------------------------------------------------------------------- --- The stack use, in words, of each bytecode insn. These _must_ be --- correct, or overestimates of reality, to be safe. - --- NOTE: we aggregate the stack use from case alternatives too, so that --- we can do a single stack check at the beginning of a function only. - --- This could all be made more accurate by keeping track of a proper --- stack high water mark, but it doesn't seem worth the hassle. - -protoBCOStackUse :: ProtoBCO a -> Word -protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) - -bciStackUse :: BCInstr -> Word -bciStackUse STKCHECK{} = 0 -bciStackUse PUSH_L{} = 1 -bciStackUse PUSH_LL{} = 2 -bciStackUse PUSH_LLL{} = 3 -bciStackUse PUSH8{} = 1 -- overapproximation -bciStackUse PUSH16{} = 1 -- overapproximation -bciStackUse PUSH32{} = 1 -- overapproximation on 64bit arch -bciStackUse PUSH8_W{} = 1 -- takes exactly 1 word -bciStackUse PUSH16_W{} = 1 -- takes exactly 1 word -bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word -bciStackUse PUSH_G{} = 1 -bciStackUse PUSH_PRIMOP{} = 1 -bciStackUse PUSH_BCO{} = 1 -bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco -bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco -bciStackUse (PUSH_PAD8) = 1 -- overapproximation -bciStackUse (PUSH_PAD16) = 1 -- overapproximation -bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch -bciStackUse (PUSH_UBX8 _) = 1 -- overapproximation -bciStackUse (PUSH_UBX16 _) = 1 -- overapproximation -bciStackUse (PUSH_UBX32 _) = 1 -- overapproximation on 64bit arch -bciStackUse (PUSH_UBX _ nw) = fromIntegral nw -bciStackUse PUSH_APPLY_N{} = 1 -bciStackUse PUSH_APPLY_V{} = 1 -bciStackUse PUSH_APPLY_F{} = 1 -bciStackUse PUSH_APPLY_D{} = 1 -bciStackUse PUSH_APPLY_L{} = 1 -bciStackUse PUSH_APPLY_P{} = 1 -bciStackUse PUSH_APPLY_PP{} = 1 -bciStackUse PUSH_APPLY_PPP{} = 1 -bciStackUse PUSH_APPLY_PPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPPP{} = 1 -bciStackUse ALLOC_AP{} = 1 -bciStackUse ALLOC_AP_NOUPD{} = 1 -bciStackUse ALLOC_PAP{} = 1 -bciStackUse (UNPACK sz) = fromIntegral sz -bciStackUse LABEL{} = 0 -bciStackUse TESTLT_I{} = 0 -bciStackUse TESTEQ_I{} = 0 -bciStackUse TESTLT_W{} = 0 -bciStackUse TESTEQ_W{} = 0 -bciStackUse TESTLT_F{} = 0 -bciStackUse TESTEQ_F{} = 0 -bciStackUse TESTLT_D{} = 0 -bciStackUse TESTEQ_D{} = 0 -bciStackUse TESTLT_P{} = 0 -bciStackUse TESTEQ_P{} = 0 -bciStackUse CASEFAIL{} = 0 -bciStackUse JMP{} = 0 -bciStackUse ENTER{} = 0 -bciStackUse RETURN{} = 0 -bciStackUse RETURN_UBX{} = 1 -bciStackUse CCALL{} = 0 -bciStackUse SWIZZLE{} = 0 -bciStackUse BRK_FUN{} = 0 - --- These insns actually reduce stack use, but we need the high-tide level, --- so can't use this info. Not that it matters much. -bciStackUse SLIDE{} = 0 -bciStackUse MKAP{} = 0 -bciStackUse MKPAP{} = 0 -bciStackUse PACK{} = 1 -- worst case is PACK 0 words diff --git a/ghci/ByteCodeItbls.hs b/ghci/ByteCodeItbls.hs deleted file mode 100644 --- a/ghci/ByteCodeItbls.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes -module ByteCodeItbls ( mkITbls ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeTypes -import GHCi -import DynFlags -import HscTypes -import Name ( Name, getName ) -import NameEnv -import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) -import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) -import RepType -import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) -import Util -import Panic - -{- - Manufacturing of info tables for DataCons --} - --- Make info tables for the data decls in this module -mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv -mkITbls hsc_env tcs = - foldr plusNameEnv emptyNameEnv <$> - mapM (mkITbl hsc_env) (filter isDataTyCon tcs) - where - mkITbl :: HscEnv -> TyCon -> IO ItblEnv - mkITbl hsc_env tc - | dcs `lengthIs` n -- paranoia; this is an assertion. - = make_constr_itbls hsc_env dcs - where - dcs = tyConDataCons tc - n = tyConFamilySize tc - mkITbl _ _ = panic "mkITbl" - -mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv -mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] - --- Assumes constructors are numbered from zero, not one -make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv -make_constr_itbls hsc_env cons = - mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) - where - dflags = hsc_dflags hsc_env - - mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) - mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep - | arg <- dataConRepArgTys dcon - , prim_rep <- typePrimRep arg ] - - (tot_wds, ptr_wds) = - mkVirtConstrSizes dflags rep_args - - ptrs' = ptr_wds - nptrs' = tot_wds - ptr_wds - nptrs_really - | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' - | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' - - descr = dataConIdentity dcon - - r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really - conNo (tagForCon dflags dcon) descr) - return (getName dcon, ItblPtr r) diff --git a/ghci/ByteCodeLink.hs b/ghci/ByteCodeLink.hs deleted file mode 100644 --- a/ghci/ByteCodeLink.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeLink: Bytecode assembler and linker -module ByteCodeLink ( - ClosureEnv, emptyClosureEnv, extendClosureEnv, - linkBCO, lookupStaticPtr, - lookupIE, - nameToCLabel, linkFail - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHCi.RemoteTypes -import GHCi.ResolvedBCO -import GHCi.BreakArray -import SizedSeq - -import GHCi -import ByteCodeTypes -import HscTypes -import Name -import NameEnv -import PrimOp -import Module -import FastString -import Panic -import Outputable -import Util - --- Standard libraries -import Data.Array.Unboxed -import Foreign.Ptr -import GHC.Exts - -{- - Linking interpretables into something we can run --} - -type ClosureEnv = NameEnv (Name, ForeignHValue) - -emptyClosureEnv :: ClosureEnv -emptyClosureEnv = emptyNameEnv - -extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv -extendClosureEnv cl_env pairs - = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] - -{- - Linking interpretables into something we can run --} - -linkBCO - :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray - -> UnlinkedBCO - -> IO ResolvedBCO -linkBCO hsc_env ie ce bco_ix breakarray - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do - -- fromIntegral Word -> Word64 should be a no op if Word is Word64 - -- otherwise it will result in a cast to longlong on 32bit systems. - lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0) - ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0) - return (ResolvedBCO isLittleEndian arity insns bitmap - (listArray (0, fromIntegral (sizeSS lits0)-1) lits) - (addListToSS emptySS ptrs)) - -lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word -lookupLiteral _ _ (BCONPtrWord lit) = return lit -lookupLiteral hsc_env _ (BCONPtrLbl sym) = do - Ptr a# <- lookupStaticPtr hsc_env sym - return (W# (int2Word# (addr2Int# a#))) -lookupLiteral hsc_env ie (BCONPtrItbl nm) = do - Ptr a# <- lookupIE hsc_env ie nm - return (W# (int2Word# (addr2Int# a#))) -lookupLiteral _ _ (BCONPtrStr _) = - -- should be eliminated during assembleBCOs - panic "lookupLiteral: BCONPtrStr" - -lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ()) -lookupStaticPtr hsc_env addr_of_label_string = do - m <- lookupSymbol hsc_env addr_of_label_string - case m of - Just ptr -> return ptr - Nothing -> linkFail "ByteCodeLink: can't find label" - (unpackFS addr_of_label_string) - -lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ()) -lookupIE hsc_env ie con_nm = - case lookupNameEnv ie con_nm of - Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) - Nothing -> do -- try looking up in the object files. - let sym_to_find1 = nameToCLabel con_nm "con_info" - m <- lookupSymbol hsc_env sym_to_find1 - case m of - Just addr -> return addr - Nothing - -> do -- perhaps a nullary constructor? - let sym_to_find2 = nameToCLabel con_nm "static_info" - n <- lookupSymbol hsc_env sym_to_find2 - case n of - Just addr -> return addr - Nothing -> linkFail "ByteCodeLink.lookupIE" - (unpackFS sym_to_find1 ++ " or " ++ - unpackFS sym_to_find2) - -lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ()) -lookupPrimOp hsc_env primop = do - let sym_to_find = primopToCLabel primop "closure" - m <- lookupSymbol hsc_env (mkFastString sym_to_find) - case m of - Just p -> return (toRemotePtr p) - Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find - -resolvePtr - :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray - -> BCOPtr - -> IO ResolvedBCOPtr -resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm) - | Just ix <- lookupNameEnv bco_ix nm = - return (ResolvedBCORef ix) -- ref to another BCO in this group - | Just (_, rhv) <- lookupNameEnv ce nm = - return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) - | otherwise = - ASSERT2(isExternalName nm, ppr nm) - do let sym_to_find = nameToCLabel nm "closure" - m <- lookupSymbol hsc_env sym_to_find - case m of - Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) - Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find) -resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) = - ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op -resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) = - ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco -resolvePtr _ _ _ _ breakarray BCOPtrBreakArray = - return (ResolvedBCOPtrBreakArray breakarray) - -linkFail :: String -> String -> IO a -linkFail who what - = throwGhcExceptionIO (ProgramError $ - unlines [ "",who - , "During interactive linking, GHCi couldn't find the following symbol:" - , ' ' : ' ' : what - , "This may be due to you not asking GHCi to load extra object files," - , "archives or DLLs needed by your current session. Restart GHCi, specifying" - , "the missing library using the -L/path/to/object/dir and -lmissinglibname" - , "flags, or simply by naming the relevant files on the GHCi command line." - , "Alternatively, this link failure might indicate a bug in GHCi." - , "If you suspect the latter, please report this as a GHC bug:" - , " https://www.haskell.org/ghc/reportabug" - ]) - - -nameToCLabel :: Name -> String -> FastString -nameToCLabel n suffix = mkFastString label - where - encodeZ = zString . zEncodeFS - (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n - packagePart = encodeZ (unitIdFS pkgKey) - modulePart = encodeZ (moduleNameFS modName) - occPart = encodeZ (occNameFS (nameOccName n)) - - label = concat - [ if pkgKey == mainUnitId then "" else packagePart ++ "_" - , modulePart - , '_':occPart - , '_':suffix - ] - - -primopToCLabel :: PrimOp -> String -> String -primopToCLabel primop suffix = concat - [ "ghczmprim_GHCziPrimopWrappers_" - , zString (zEncodeFS (occNameFS (primOpOcc primop))) - , '_':suffix - ] diff --git a/ghci/ByteCodeTypes.hs b/ghci/ByteCodeTypes.hs deleted file mode 100644 --- a/ghci/ByteCodeTypes.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | Bytecode assembler types -module ByteCodeTypes - ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) - , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) - , ItblEnv, ItblPtr(..) - , CgBreakInfo(..) - , ModBreaks (..), BreakIndex, emptyModBreaks - , CCostCentre - ) where - -import GhcPrelude - -import FastString -import Id -import Name -import NameEnv -import Outputable -import PrimOp -import SizedSeq -import Type -import SrcLoc -import GHCi.BreakArray -import GHCi.RemoteTypes -import GHCi.FFI -import Control.DeepSeq - -import Foreign -import Data.Array -import Data.Array.Base ( UArray(..) ) -import Data.ByteString (ByteString) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Maybe (catMaybes) -import GHC.Exts.Heap -import GHC.Stack.CCS - --- ----------------------------------------------------------------------------- --- Compiled Byte Code - -data CompiledByteCode = CompiledByteCode - { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings - , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls - , bc_ffis :: [FFIInfo] -- ffi blocks we allocated - , bc_strs :: [RemotePtr ()] -- malloc'd strings - , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not - -- creating breakpoints, for some reason) - } - -- ToDo: we're not tracking strings that we malloc'd -newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) - deriving (Show, NFData) - -instance Outputable CompiledByteCode where - ppr CompiledByteCode{..} = ppr bc_bcos - --- Not a real NFData instance, because ModBreaks contains some things --- we can't rnf -seqCompiledByteCode :: CompiledByteCode -> () -seqCompiledByteCode CompiledByteCode{..} = - rnf bc_bcos `seq` - rnf (nameEnvElts bc_itbls) `seq` - rnf bc_ffis `seq` - rnf bc_strs `seq` - rnf (fmap seqModBreaks bc_breaks) - -type ItblEnv = NameEnv (Name, ItblPtr) - -- We need the Name in the range so we know which - -- elements to filter out when unloading a module - -newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) - deriving (Show, NFData) - -data UnlinkedBCO - = UnlinkedBCO { - unlinkedBCOName :: !Name, - unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(UArray Int Word16), -- insns - unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap - unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs - } - -instance NFData UnlinkedBCO where - rnf UnlinkedBCO{..} = - rnf unlinkedBCOLits `seq` - rnf unlinkedBCOPtrs - -data BCOPtr - = BCOPtrName !Name - | BCOPtrPrimOp !PrimOp - | BCOPtrBCO !UnlinkedBCO - | BCOPtrBreakArray -- a pointer to this module's BreakArray - -instance NFData BCOPtr where - rnf (BCOPtrBCO bco) = rnf bco - rnf x = x `seq` () - -data BCONPtr - = BCONPtrWord {-# UNPACK #-} !Word - | BCONPtrLbl !FastString - | BCONPtrItbl !Name - | BCONPtrStr !ByteString - -instance NFData BCONPtr where - rnf x = x `seq` () - --- | Information about a breakpoint that we know at code-generation time -data CgBreakInfo - = CgBreakInfo - { cgb_vars :: [Maybe (Id,Word16)] - , cgb_resty :: Type - } --- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs - --- Not a real NFData instance because we can't rnf Id or Type -seqCgBreakInfo :: CgBreakInfo -> () -seqCgBreakInfo CgBreakInfo{..} = - rnf (map snd (catMaybes (cgb_vars))) `seq` - seqType cgb_resty - -instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) - = sep [text "BCO", ppr nm, text "with", - ppr (sizeSS lits), text "lits", - ppr (sizeSS ptrs), text "ptrs" ] - -instance Outputable CgBreakInfo where - ppr info = text "CgBreakInfo" <+> - parens (ppr (cgb_vars info) <+> - ppr (cgb_resty info)) - --- ----------------------------------------------------------------------------- --- Breakpoints - --- | Breakpoint index -type BreakIndex = Int - --- | C CostCentre type -data CCostCentre - --- | All the information about the breakpoints for a module -data ModBreaks - = ModBreaks - { modBreaks_flags :: ForeignRef BreakArray - -- ^ The array of flags, one per breakpoint, - -- indicating which breakpoints are enabled. - , modBreaks_locs :: !(Array BreakIndex SrcSpan) - -- ^ An array giving the source span of each breakpoint. - , modBreaks_vars :: !(Array BreakIndex [OccName]) - -- ^ An array giving the names of the free variables at each breakpoint. - , modBreaks_decls :: !(Array BreakIndex [String]) - -- ^ An array giving the names of the declarations enclosing each breakpoint. - , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) - -- ^ Array pointing to cost centre for each breakpoint - , modBreaks_breakInfo :: IntMap CgBreakInfo - -- ^ info about each breakpoint from the bytecode generator - } - -seqModBreaks :: ModBreaks -> () -seqModBreaks ModBreaks{..} = - rnf modBreaks_flags `seq` - rnf modBreaks_locs `seq` - rnf modBreaks_vars `seq` - rnf modBreaks_decls `seq` - rnf modBreaks_ccs `seq` - rnf (fmap seqCgBreakInfo modBreaks_breakInfo) - --- | Construct an empty ModBreaks -emptyModBreaks :: ModBreaks -emptyModBreaks = ModBreaks - { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" - -- ToDo: can we avoid this? - , modBreaks_locs = array (0,-1) [] - , modBreaks_vars = array (0,-1) [] - , modBreaks_decls = array (0,-1) [] - , modBreaks_ccs = array (0,-1) [] - , modBreaks_breakInfo = IntMap.empty - } diff --git a/ghci/Debugger.hs b/ghci/Debugger.hs deleted file mode 100644 --- a/ghci/Debugger.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- --- GHCi Interactive debugging commands --- --- Pepe Iborra (supported by Google SoC) 2006 --- --- ToDo: lots of violation of layering here. This module should --- decide whether it is above the GHC API (import GHC and nothing --- else) or below it. --- ------------------------------------------------------------------------------ - -module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where - -import GhcPrelude - -import Linker -import RtClosureInspect - -import GHCi -import GHCi.RemoteTypes -import GhcMonad -import HscTypes -import Id -import IfaceSyn ( showToHeader ) -import IfaceEnv( newInteractiveBinder ) -import Name -import Var hiding ( varName ) -import VarSet -import UniqSet -import Type -import GHC -import Outputable -import PprTyThing -import ErrUtils -import MonadUtils -import DynFlags -import Exception - -import Control.Monad -import Data.List ( (\\) ) -import Data.Maybe -import Data.IORef - -------------------------------------- --- | The :print & friends commands -------------------------------------- -pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () -pprintClosureCommand bindThings force str = do - tythings <- (catMaybes . concat) `liftM` - mapM (\w -> GHC.parseName w >>= - mapM GHC.lookupName) - (words str) - let ids = [id | AnId id <- tythings] - - -- Obtain the terms and the recovered type information - (subst, terms) <- mapAccumLM go emptyTCvSubst ids - - -- Apply the substitutions obtained after recovering the types - modifySession $ \hsc_env -> - hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} - - -- Finally, print the Terms - unqual <- GHC.getPrintUnqual - docterms <- mapM showTerm terms - dflags <- getDynFlags - liftIO $ (printOutputForUser dflags unqual . vcat) - (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) - ids - docterms) - where - -- Do the obtainTerm--bindSuspensions-computeSubstitution dance - go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) - go subst id = do - let id_ty' = substTy subst (idType id) - id' = id `setIdType` id_ty' - term_ <- GHC.obtainTermFromId maxBound force id' - term <- tidyTermTyVars term_ - term' <- if bindThings - then bindSuspensions term - else return term - -- Before leaving, we compare the type obtained to see if it's more specific - -- Then, we extract a substitution, - -- mapping the old tyvars to the reconstructed types. - let reconstructed_type = termType term - hsc_env <- getSession - case (improveRTTIType hsc_env id_ty' reconstructed_type) of - Nothing -> return (subst, term') - Just subst' -> do { dflags <- GHC.getSessionDynFlags - ; liftIO $ - dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" - (fsep $ [text "RTTI Improvement for", ppr id, - text "old substitution:" , ppr subst, - text "new substitution:" , ppr subst']) - ; return (subst `unionTCvSubst` subst', term')} - - tidyTermTyVars :: GhcMonad m => Term -> m Term - tidyTermTyVars t = - withSession $ \hsc_env -> do - let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env - my_tvs = termTyCoVars t - tvs = env_tvs `minusVarSet` my_tvs - tyvarOccName = nameOccName . tyVarName - tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs)) - -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv - -- forgets the ordering immediately by creating an env - , getUniqSet $ env_tvs `intersectVarSet` my_tvs) - return $ mapTermType (snd . tidyOpenType tidyEnv) t - --- | Give names, and bind in the interactive environment, to all the suspensions --- included (inductively) in a term -bindSuspensions :: GhcMonad m => Term -> m Term -bindSuspensions t = do - hsc_env <- getSession - inScope <- GHC.getBindings - let ictxt = hsc_IC hsc_env - prefix = "_t" - alreadyUsedNames = map (occNameString . nameOccName . getName) inScope - availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames - availNames_var <- liftIO $ newIORef availNames - (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t - let (names, tys, fhvs) = unzip3 stuff - let ids = [ mkVanillaGlobal name ty - | (name,ty) <- zip names tys] - new_ic = extendInteractiveContextWithIds ictxt ids - dl = hsc_dynLinker hsc_env - liftIO $ extendLinkEnv dl (zip names fhvs) - setSession hsc_env {hsc_IC = new_ic } - return t' - where - --- Processing suspensions. Give names and recopilate info - nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] - -> TermFold (IO (Term, [(Name,Type,ForeignHValue)])) - nameSuspensionsAndGetInfos hsc_env freeNames = TermFold - { - fSuspension = doSuspension hsc_env freeNames - , fTerm = \ty dc v tt -> do - tt' <- sequence tt - let (terms,names) = unzip tt' - return (Term ty dc v terms, concat names) - , fPrim = \ty n ->return (Prim ty n,[]) - , fNewtypeWrap = - \ty dc t -> do - (term, names) <- t - return (NewtypeWrap ty dc term, names) - , fRefWrap = \ty t -> do - (term, names) <- t - return (RefWrap ty term, names) - } - doSuspension hsc_env freeNames ct ty hval _name = do - name <- atomicModifyIORef' freeNames (\x->(tail x, head x)) - n <- newGrimName hsc_env name - return (Suspension ct ty hval (Just n), [(n,ty,hval)]) - - --- A custom Term printer to enable the use of Show instances -showTerm :: GhcMonad m => Term -> m SDoc -showTerm term = do - dflags <- GHC.getSessionDynFlags - if gopt Opt_PrintEvldWithShow dflags - then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term - else cPprTerm cPprTermBase term - where - cPprShowable prec t@Term{ty=ty, val=fhv} = - if not (isFullyEvaluatedTerm t) - then return Nothing - else do - hsc_env <- getSession - dflags <- GHC.getSessionDynFlags - do - (new_env, bname) <- bindToFreshName hsc_env ty "showme" - setSession new_env - -- XXX: this tries to disable logging of errors - -- does this still do what it is intended to do - -- with the changed error handling and logging? - let noop_log _ _ _ _ _ _ = return () - expr = "Prelude.return (Prelude.show " ++ - showPpr dflags bname ++ - ") :: Prelude.IO Prelude.String" - dl = hsc_dynLinker hsc_env - _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} - txt_ <- withExtendedLinkEnv dl - [(bname, fhv)] - (GHC.compileExprRemote expr) - let myprec = 10 -- application precedence. TODO Infix constructors - txt <- liftIO $ evalString hsc_env txt_ - if not (null txt) then - return $ Just $ cparen (prec >= myprec && needsParens txt) - (text txt) - else return Nothing - `gfinally` do - setSession hsc_env - GHC.setSessionDynFlags dflags - cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = - cPprShowable prec t{ty=new_ty} - cPprShowable _ _ = return Nothing - - needsParens ('"':_) = False -- some simple heuristics to see whether parens - -- are redundant in an arbitrary Show output - needsParens ('(':_) = False - needsParens txt = ' ' `elem` txt - - - bindToFreshName hsc_env ty userName = do - name <- newGrimName hsc_env userName - let id = mkVanillaGlobal name ty - new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] - return (hsc_env {hsc_IC = new_ic }, name) - --- Create new uniques and give them sequentially numbered names -newGrimName :: MonadIO m => HscEnv -> String -> m Name -newGrimName hsc_env userName - = liftIO (newInteractiveBinder hsc_env occ noSrcSpan) - where - occ = mkOccName varName userName - -pprTypeAndContents :: GhcMonad m => Id -> m SDoc -pprTypeAndContents id = do - dflags <- GHC.getSessionDynFlags - let pcontents = gopt Opt_PrintBindContents dflags - pprdId = (pprTyThing showToHeader . AnId) id - if pcontents - then do - let depthBound = 100 - -- If the value is an exception, make sure we catch it and - -- show the exception, rather than propagating the exception out. - e_term <- gtry $ GHC.obtainTermFromId depthBound False id - docs_term <- case e_term of - Right term -> showTerm term - Left exn -> return (text "*** Exception:" <+> - text (show (exn :: SomeException))) - return $ pprdId <+> equals <+> docs_term - else return pprdId diff --git a/ghci/GHCi.hs b/ghci/GHCi.hs deleted file mode 100644 --- a/ghci/GHCi.hs +++ /dev/null @@ -1,667 +0,0 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} - --- --- | Interacting with the interpreter, whether it is running on an --- external process or in the current process. --- -module GHCi - ( -- * High-level interface to the interpreter - evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) - , resumeStmt - , abandonStmt - , evalIO - , evalString - , evalStringToIOString - , mallocData - , createBCOs - , addSptEntry - , mkCostCentres - , costCentreStackInfo - , newBreakArray - , enableBreakpoint - , breakpointStatus - , getBreakpointVar - , getClosure - , seqHValue - - -- * The object-code linker - , initObjLinker - , lookupSymbol - , lookupClosure - , loadDLL - , loadArchive - , loadObj - , unloadObj - , addLibrarySearchPath - , removeLibrarySearchPath - , resolveObjs - , findSystemLibrary - - -- * Lower-level API using messages - , iservCmd, Message(..), withIServ, stopIServ - , iservCall, readIServ, writeIServ - , purgeLookupSymbolCache - , freeHValueRefs - , mkFinalizedHValue - , wormhole, wormholeRef - , mkEvalOpts - , fromEvalResult - ) where - -import GhcPrelude - -import GHCi.Message -#if defined(HAVE_INTERNAL_INTERPRETER) -import GHCi.Run -#endif -import GHCi.RemoteTypes -import GHCi.ResolvedBCO -import GHCi.BreakArray (BreakArray) -import Fingerprint -import HscTypes -import UniqFM -import Panic -import DynFlags -import ErrUtils -import Outputable -import Exception -import BasicTypes -import FastString -import Util -import Hooks - -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Data.Binary -import Data.Binary.Put -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LB -import Data.IORef -import Foreign hiding (void) -import GHC.Exts.Heap -import GHC.Stack.CCS (CostCentre,CostCentreStack) -import System.Exit -import Data.Maybe -import GHC.IO.Handle.Types (Handle) -#if defined(mingw32_HOST_OS) -import Foreign.C -import GHC.IO.Handle.FD (fdToHandle) -#else -import System.Posix as Posix -#endif -import System.Directory -import System.Process -import GHC.Conc (getNumProcessors, pseq, par) - -{- Note [Remote GHCi] - -When the flag -fexternal-interpreter is given to GHC, interpreted code -is run in a separate process called iserv, and we communicate with the -external process over a pipe using Binary-encoded messages. - -Motivation -~~~~~~~~~~ - -When the interpreted code is running in a separate process, it can -use a different "way", e.g. profiled or dynamic. This means - -- compiling Template Haskell code with -prof does not require - building the code without -prof first - -- when GHC itself is profiled, it can interpret unprofiled code, - and the same applies to dynamic linking. - -- An unprofiled GHCi can load and run profiled code, which means it - can use the stack-trace functionality provided by profiling without - taking the performance hit on the compiler that profiling would - entail. - -For other reasons see remote-GHCi on the wiki. - -Implementation Overview -~~~~~~~~~~~~~~~~~~~~~~~ - -The main pieces are: - -- libraries/ghci, containing: - - types for talking about remote values (GHCi.RemoteTypes) - - the message protocol (GHCi.Message), - - implementation of the messages (GHCi.Run) - - implementation of Template Haskell (GHCi.TH) - - a few other things needed to run interpreted code - -- top-level iserv directory, containing the codefor the external - server. This is a fairly simple wrapper, most of the functionality - is provided by modules in libraries/ghci. - -- This module (GHCi) which provides the interface to the server used - by the rest of GHC. - -GHC works with and without -fexternal-interpreter. With the flag, all -interpreted code is run by the iserv binary. Without the flag, -interpreted code is run in the same process as GHC. - -Things that do not work with -fexternal-interpreter -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -dynCompileExpr cannot work, because we have no way to run code of an -unknown type in the remote process. This API fails with an error -message if it is used with -fexternal-interpreter. - -Other Notes on Remote GHCi -~~~~~~~~~~~~~~~~~~~~~~~~~~ - * This wiki page has an implementation overview: - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter - * Note [External GHCi pointers] in compiler/ghci/GHCi.hs - * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs --} - -#if !defined(HAVE_INTERNAL_INTERPRETER) -needExtInt :: IO a -needExtInt = throwIO - (InstallationError "this operation requires -fexternal-interpreter") -#endif - --- | Run a command in the interpreter's context. With --- @-fexternal-interpreter@, the command is serialized and sent to an --- external iserv process, and the response is deserialized (hence the --- @Binary@ constraint). With @-fno-external-interpreter@ we execute --- the command directly here. -iservCmd :: Binary a => HscEnv -> Message a -> IO a -iservCmd hsc_env@HscEnv{..} msg - | gopt Opt_ExternalInterpreter hsc_dflags = - withIServ hsc_env $ \iserv -> - uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] - iservCall iserv msg - | otherwise = -- Just run it directly -#if defined(HAVE_INTERNAL_INTERPRETER) - run msg -#else - needExtInt -#endif - --- Note [uninterruptibleMask_ and iservCmd] --- --- If we receive an async exception, such as ^C, while communicating --- with the iserv process then we will be out-of-sync and not be able --- to recoever. Thus we use uninterruptibleMask_ during --- communication. A ^C will be delivered to the iserv process (because --- signals get sent to the whole process group) which will interrupt --- the running computation and return an EvalException result. - --- | Grab a lock on the 'IServ' and do something with it. --- Overloaded because this is used from TcM as well as IO. -withIServ - :: (MonadIO m, ExceptionMonad m) - => HscEnv -> (IServ -> m a) -> m a -withIServ HscEnv{..} action = - gmask $ \restore -> do - m <- liftIO $ takeMVar hsc_iserv - -- start the iserv process if we haven't done so yet - iserv <- maybe (liftIO $ startIServ hsc_dflags) return m - `gonException` (liftIO $ putMVar hsc_iserv Nothing) - -- free any ForeignHValues that have been garbage collected. - let iserv' = iserv{ iservPendingFrees = [] } - a <- (do - liftIO $ when (not (null (iservPendingFrees iserv))) $ - iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) - -- run the inner action - restore $ action iserv) - `gonException` (liftIO $ putMVar hsc_iserv (Just iserv')) - liftIO $ putMVar hsc_iserv (Just iserv') - return a - - --- ----------------------------------------------------------------------------- --- Wrappers around messages - --- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for --- each of the results. -evalStmt - :: HscEnv -> Bool -> EvalExpr ForeignHValue - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -evalStmt hsc_env step foreign_expr = do - let dflags = hsc_dflags hsc_env - status <- withExpr foreign_expr $ \expr -> - iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr) - handleEvalStatus hsc_env status - where - withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a - withExpr (EvalThis fhv) cont = - withForeignRef fhv $ \hvref -> cont (EvalThis hvref) - withExpr (EvalApp fl fr) cont = - withExpr fl $ \fl' -> - withExpr fr $ \fr' -> - cont (EvalApp fl' fr') - -resumeStmt - :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -resumeStmt hsc_env step resume_ctxt = do - let dflags = hsc_dflags hsc_env - status <- withForeignRef resume_ctxt $ \rhv -> - iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) - handleEvalStatus hsc_env status - -abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () -abandonStmt hsc_env resume_ctxt = do - withForeignRef resume_ctxt $ \rhv -> - iservCmd hsc_env (AbandonStmt rhv) - -handleEvalStatus - :: HscEnv -> EvalStatus [HValueRef] - -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -handleEvalStatus hsc_env status = - case status of - EvalBreak a b c d e f -> return (EvalBreak a b c d e f) - EvalComplete alloc res -> - EvalComplete alloc <$> addFinalizer res - where - addFinalizer (EvalException e) = return (EvalException e) - addFinalizer (EvalSuccess rs) = do - EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs - --- | Execute an action of type @IO ()@ -evalIO :: HscEnv -> ForeignHValue -> IO () -evalIO hsc_env fhv = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult - --- | Execute an action of type @IO String@ -evalString :: HscEnv -> ForeignHValue -> IO String -evalString hsc_env fhv = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalString fhv) >>= fromEvalResult - --- | Execute an action of type @String -> IO String@ -evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String -evalStringToIOString hsc_env fhv str = do - liftIO $ withForeignRef fhv $ \fhv -> - iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult - - --- | Allocate and store the given bytes in memory, returning a pointer --- to the memory in the remote process. -mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) -mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) - -mkCostCentres - :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre] -mkCostCentres hsc_env mod ccs = - iservCmd hsc_env (MkCostCentres mod ccs) - --- | Create a set of BCOs that may be mutually recursive. -createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef] -createBCOs hsc_env rbcos = do - n_jobs <- case parMakeCount (hsc_dflags hsc_env) of - Nothing -> liftIO getNumProcessors - Just n -> return n - -- Serializing ResolvedBCO is expensive, so if we're in parallel mode - -- (-j) parallelise the serialization. - if (n_jobs == 1) - then - iservCmd hsc_env (CreateBCOs [runPut (put rbcos)]) - - else do - old_caps <- getNumCapabilities - if old_caps == n_jobs - then void $ evaluate puts - else bracket_ (setNumCapabilities n_jobs) - (setNumCapabilities old_caps) - (void $ evaluate puts) - iservCmd hsc_env (CreateBCOs puts) - where - puts = parMap doChunk (chunkList 100 rbcos) - - -- make sure we force the whole lazy ByteString - doChunk c = pseq (LB.length bs) bs - where bs = runPut (put c) - - -- We don't have the parallel package, so roll our own simple parMap - parMap _ [] = [] - parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) - where fx = f x; fxs = parMap f xs - -addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO () -addSptEntry hsc_env fpr ref = - withForeignRef ref $ \val -> - iservCmd hsc_env (AddSptEntry fpr val) - -costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] -costCentreStackInfo hsc_env ccs = - iservCmd hsc_env (CostCentreStackInfo ccs) - -newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray) -newBreakArray hsc_env size = do - breakArray <- iservCmd hsc_env (NewBreakArray size) - mkFinalizedHValue hsc_env breakArray - -enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () -enableBreakpoint hsc_env ref ix b = do - withForeignRef ref $ \breakarray -> - iservCmd hsc_env (EnableBreakpoint breakarray ix b) - -breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool -breakpointStatus hsc_env ref ix = do - withForeignRef ref $ \breakarray -> - iservCmd hsc_env (BreakpointStatus breakarray ix) - -getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue) -getBreakpointVar hsc_env ref ix = - withForeignRef ref $ \apStack -> do - mb <- iservCmd hsc_env (GetBreakpointVar apStack ix) - mapM (mkFinalizedHValue hsc_env) mb - -getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue) -getClosure hsc_env ref = - withForeignRef ref $ \hval -> do - mb <- iservCmd hsc_env (GetClosure hval) - mapM (mkFinalizedHValue hsc_env) mb - -seqHValue :: HscEnv -> ForeignHValue -> IO () -seqHValue hsc_env ref = - withForeignRef ref $ \hval -> - iservCmd hsc_env (Seq hval) >>= fromEvalResult - --- ----------------------------------------------------------------------------- --- Interface to the object-code linker - -initObjLinker :: HscEnv -> IO () -initObjLinker hsc_env = iservCmd hsc_env InitLinker - -lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ())) -lookupSymbol hsc_env@HscEnv{..} str - | gopt Opt_ExternalInterpreter hsc_dflags = - -- Profiling of GHCi showed a lot of time and allocation spent - -- making cross-process LookupSymbol calls, so I added a GHC-side - -- cache which sped things up quite a lot. We have to be careful - -- to purge this cache when unloading code though. - withIServ hsc_env $ \iserv@IServ{..} -> do - cache <- readIORef iservLookupSymbolCache - case lookupUFM cache str of - Just p -> return (Just p) - Nothing -> do - m <- uninterruptibleMask_ $ - iservCall iserv (LookupSymbol (unpackFS str)) - case m of - Nothing -> return Nothing - Just r -> do - let p = fromRemotePtr r - writeIORef iservLookupSymbolCache $! addToUFM cache str p - return (Just p) - | otherwise = -#if defined(HAVE_INTERNAL_INTERPRETER) - fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) -#else - needExtInt -#endif - -lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) -lookupClosure hsc_env str = - iservCmd hsc_env (LookupClosure str) - -purgeLookupSymbolCache :: HscEnv -> IO () -purgeLookupSymbolCache hsc_env@HscEnv{..} = - when (gopt Opt_ExternalInterpreter hsc_dflags) $ - withIServ hsc_env $ \IServ{..} -> - writeIORef iservLookupSymbolCache emptyUFM - - --- | loadDLL loads a dynamic library using the OS's native linker --- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either --- an absolute pathname to the file, or a relative filename --- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL --- searches the standard locations for the appropriate library. --- --- Returns: --- --- Nothing => success --- Just err_msg => failure -loadDLL :: HscEnv -> String -> IO (Maybe String) -loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str) - -loadArchive :: HscEnv -> String -> IO () -loadArchive hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (LoadArchive path') - -loadObj :: HscEnv -> String -> IO () -loadObj hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (LoadObj path') - -unloadObj :: HscEnv -> String -> IO () -unloadObj hsc_env path = do - path' <- canonicalizePath path -- Note [loadObj and relative paths] - iservCmd hsc_env (UnloadObj path') - --- Note [loadObj and relative paths] --- the iserv process might have a different current directory from the --- GHC process, so we must make paths absolute before sending them --- over. - -addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ()) -addLibrarySearchPath hsc_env str = - fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str) - -removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool -removeLibrarySearchPath hsc_env p = - iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p)) - -resolveObjs :: HscEnv -> IO SuccessFlag -resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs - -findSystemLibrary :: HscEnv -> String -> IO (Maybe String) -findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str) - - --- ----------------------------------------------------------------------------- --- Raw calls and messages - --- | Send a 'Message' and receive the response from the iserv process -iservCall :: Binary a => IServ -> Message a -> IO a -iservCall iserv@IServ{..} msg = - remoteCall iservPipe msg - `catch` \(e :: SomeException) -> handleIServFailure iserv e - --- | Read a value from the iserv process -readIServ :: IServ -> Get a -> IO a -readIServ iserv@IServ{..} get = - readPipe iservPipe get - `catch` \(e :: SomeException) -> handleIServFailure iserv e - --- | Send a value to the iserv process -writeIServ :: IServ -> Put -> IO () -writeIServ iserv@IServ{..} put = - writePipe iservPipe put - `catch` \(e :: SomeException) -> handleIServFailure iserv e - -handleIServFailure :: IServ -> SomeException -> IO a -handleIServFailure IServ{..} e = do - ex <- getProcessExitCode iservProcess - case ex of - Just (ExitFailure n) -> - throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) - _ -> do - terminateProcess iservProcess - _ <- waitForProcess iservProcess - throw e - --- ----------------------------------------------------------------------------- --- Starting and stopping the iserv process - -startIServ :: DynFlags -> IO IServ -startIServ dflags = do - let flavour - | WayProf `elem` ways dflags = "-prof" - | WayDyn `elem` ways dflags = "-dyn" - | otherwise = "" - prog = pgm_i dflags ++ flavour - opts = getOpts dflags opt_i - debugTraceMsg dflags 3 $ text "Starting " <> text prog - let createProc = lookupHook createIservProcessHook - (\cp -> do { (_,_,_,ph) <- createProcess cp - ; return ph }) - dflags - (ph, rh, wh) <- runWithPipes createProc prog opts - lo_ref <- newIORef Nothing - cache_ref <- newIORef emptyUFM - return $ IServ - { iservPipe = Pipe { pipeRead = rh - , pipeWrite = wh - , pipeLeftovers = lo_ref } - , iservProcess = ph - , iservLookupSymbolCache = cache_ref - , iservPendingFrees = [] - } - -stopIServ :: HscEnv -> IO () -stopIServ HscEnv{..} = - gmask $ \_restore -> do - m <- takeMVar hsc_iserv - maybe (return ()) stop m - putMVar hsc_iserv Nothing - where - stop iserv = do - ex <- getProcessExitCode (iservProcess iserv) - if isJust ex - then return () - else iservCall iserv Shutdown - -runWithPipes :: (CreateProcess -> IO ProcessHandle) - -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) -#if defined(mingw32_HOST_OS) -foreign import ccall "io.h _close" - c__close :: CInt -> IO CInt - -foreign import ccall unsafe "io.h _get_osfhandle" - _get_osfhandle :: CInt -> IO CInt - -runWithPipes createProc prog opts = do - (rfd1, wfd1) <- createPipeFd -- we read on rfd1 - (rfd2, wfd2) <- createPipeFd -- we write on wfd2 - wh_client <- _get_osfhandle wfd1 - rh_client <- _get_osfhandle rfd2 - let args = show wh_client : show rh_client : opts - ph <- createProc (proc prog args) - rh <- mkHandle rfd1 - wh <- mkHandle wfd2 - return (ph, rh, wh) - where mkHandle :: CInt -> IO Handle - mkHandle fd = (fdToHandle fd) `onException` (c__close fd) - -#else -runWithPipes createProc prog opts = do - (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 - (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 - setFdOption rfd1 CloseOnExec True - setFdOption wfd2 CloseOnExec True - let args = show wfd1 : show rfd2 : opts - ph <- createProc (proc prog args) - closeFd wfd1 - closeFd rfd2 - rh <- fdToHandle rfd1 - wh <- fdToHandle wfd2 - return (ph, rh, wh) -#endif - --- ----------------------------------------------------------------------------- -{- Note [External GHCi pointers] - -We have the following ways to reference things in GHCi: - -HValue ------- - -HValue is a direct reference to a value in the local heap. Obviously -we cannot use this to refer to things in the external process. - - -RemoteRef ---------- - -RemoteRef is a StablePtr to a heap-resident value. When --fexternal-interpreter is used, this value resides in the external -process's heap. RemoteRefs are mostly used to send pointers in -messages between GHC and iserv. - -A RemoteRef must be explicitly freed when no longer required, using -freeHValueRefs, or by attaching a finalizer with mkForeignHValue. - -To get from a RemoteRef to an HValue you can use 'wormholeRef', which -fails with an error message if -fexternal-interpreter is in use. - -ForeignRef ----------- - -A ForeignRef is a RemoteRef with a finalizer that will free the -'RemoteRef' when it is garbage collected. We mostly use ForeignHValue -on the GHC side. - -The finalizer adds the RemoteRef to the iservPendingFrees list in the -IServ record. The next call to iservCmd will free any RemoteRefs in -the list. It was done this way rather than calling iservCmd directly, -because I didn't want to have arbitrary threads calling iservCmd. In -principle it would probably be ok, but it seems less hairy this way. --} - --- | Creates a 'ForeignRef' that will automatically release the --- 'RemoteRef' when it is no longer referenced. -mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a) -mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free - where - !external = gopt Opt_ExternalInterpreter hsc_dflags - hvref = toHValueRef rref - - free :: IO () - free - | not external = freeRemoteRef hvref - | otherwise = - modifyMVar_ hsc_iserv $ \mb_iserv -> - case mb_iserv of - Nothing -> return Nothing -- already shut down - Just iserv@IServ{..} -> - return (Just iserv{iservPendingFrees = hvref : iservPendingFrees}) - -freeHValueRefs :: HscEnv -> [HValueRef] -> IO () -freeHValueRefs _ [] = return () -freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) - --- | Convert a 'ForeignRef' to the value it references directly. This --- only works when the interpreter is running in the same process as --- the compiler, so it fails when @-fexternal-interpreter@ is on. -wormhole :: DynFlags -> ForeignRef a -> IO a -wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r) - --- | Convert an 'RemoteRef' to the value it references directly. This --- only works when the interpreter is running in the same process as --- the compiler, so it fails when @-fexternal-interpreter@ is on. -wormholeRef :: DynFlags -> RemoteRef a -> IO a -wormholeRef dflags _r - | gopt Opt_ExternalInterpreter dflags - = throwIO (InstallationError - "this operation requires -fno-external-interpreter") -#if defined(HAVE_INTERNAL_INTERPRETER) - | otherwise - = localRef _r -#else - | otherwise - = throwIO (InstallationError - "can't wormhole a value in a stage1 compiler") -#endif - --- ----------------------------------------------------------------------------- --- Misc utils - -mkEvalOpts :: DynFlags -> Bool -> EvalOpts -mkEvalOpts dflags step = - EvalOpts - { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step - , breakOnException = gopt Opt_BreakOnException dflags - , breakOnError = gopt Opt_BreakOnError dflags } - -fromEvalResult :: EvalResult a -> IO a -fromEvalResult (EvalException e) = throwIO (fromSerializableException e) -fromEvalResult (EvalSuccess a) = return a diff --git a/ghci/Linker.hs b/ghci/Linker.hs deleted file mode 100644 --- a/ghci/Linker.hs +++ /dev/null @@ -1,1764 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} - --- --- (c) The University of Glasgow 2002-2006 --- --- | The dynamic linker for GHCi. --- --- This module deals with the top-level issues of dynamic linking, --- calling the object-code linker and the byte-code linker where --- necessary. -module Linker ( getHValue, showLinkerState, - linkExpr, linkDecls, unload, withExtendedLinkEnv, - extendLinkEnv, deleteFromLinkEnv, - extendLoadedPkgs, - linkPackages, initDynLinker, linkModule, - linkCmdLineLibs, - uninitializedLinker - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHCi -import GHCi.RemoteTypes -import LoadIface -import ByteCodeLink -import ByteCodeAsm -import ByteCodeTypes -import TcRnMonad -import Packages -import DriverPhases -import Finder -import HscTypes -import Name -import NameEnv -import Module -import ListSetOps -import LinkerTypes (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) -import DynFlags -import BasicTypes -import Outputable -import Panic -import Util -import ErrUtils -import SrcLoc -import qualified Maybes -import UniqDSet -import FastString -import GHC.Platform -import SysTools -import FileCleanup - --- Standard libraries -import Control.Monad - -import Data.Char (isSpace) -import Data.IORef -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) -import Data.Maybe -import Control.Concurrent.MVar - -import System.FilePath -import System.Directory -import System.IO.Unsafe -import System.Environment (lookupEnv) - -#if defined(mingw32_HOST_OS) -import System.Win32.Info (getSystemDirectory) -#endif - -import Exception - -{- ********************************************************************** - - The Linker's state - - ********************************************************************* -} - -{- -The persistent linker state *must* match the actual state of the -C dynamic linker at all times. - -The MVar used to hold the PersistentLinkerState contains a Maybe -PersistentLinkerState. The MVar serves to ensure mutual exclusion between -multiple loaded copies of the GHC library. The Maybe may be Nothing to -indicate that the linker has not yet been initialised. - -The PersistentLinkerState maps Names to actual closures (for -interpreted code only), for use during linking. --} - -uninitializedLinker :: IO DynLinker -uninitializedLinker = - newMVar Nothing >>= (pure . DynLinker) - -uninitialised :: a -uninitialised = panic "Dynamic linker not initialised" - -modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO () -modifyPLS_ dl f = - modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised) - -modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a -modifyPLS dl f = - modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised) - where fmapFst f = fmap (\(x, y) -> (f x, y)) - -readPLS :: DynLinker -> IO PersistentLinkerState -readPLS dl = - (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl) - -modifyMbPLS_ - :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () -modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f - -emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS _ = PersistentLinkerState { - closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs, - bcos_loaded = [], - objs_loaded = [], - temp_sos = [] } - - -- Packages that don't need loading, because the compiler - -- shares them with the interpreted program. - -- - -- The linker's symbol table is populated with RTS symbols using an - -- explicit list. See rts/Linker.c for details. - where init_pkgs = map toInstalledUnitId [rtsUnitId] - -extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO () -extendLoadedPkgs dl pkgs = - modifyPLS_ dl $ \s -> - return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } - -extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO () -extendLinkEnv dl new_bindings = - modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do - let new_ce = extendClosureEnv closure_env new_bindings - return $! pls{ closure_env = new_ce } - -- strictness is important for not retaining old copies of the pls - -deleteFromLinkEnv :: DynLinker -> [Name] -> IO () -deleteFromLinkEnv dl to_remove = - modifyPLS_ dl $ \pls -> do - let ce = closure_env pls - let new_ce = delListFromNameEnv ce to_remove - return pls{ closure_env = new_ce } - --- | Get the 'HValue' associated with the given name. --- --- May cause loading the module that contains the name. --- --- Throws a 'ProgramError' if loading fails or the name cannot be found. -getHValue :: HscEnv -> Name -> IO ForeignHValue -getHValue hsc_env name = do - let dl = hsc_dynLinker hsc_env - initDynLinker hsc_env - pls <- modifyPLS dl $ \pls -> do - if (isExternalName name) then do - (pls', ok) <- linkDependencies hsc_env pls noSrcSpan - [nameModule name] - if (failed ok) then throwGhcExceptionIO (ProgramError "") - else return (pls', pls') - else - return (pls, pls) - case lookupNameEnv (closure_env pls) name of - Just (_,aa) -> return aa - Nothing - -> ASSERT2(isExternalName name, ppr name) - do let sym_to_find = nameToCLabel name "closure" - m <- lookupClosure hsc_env (unpackFS sym_to_find) - case m of - Just hvref -> mkFinalizedHValue hsc_env hvref - Nothing -> linkFail "ByteCodeLink.lookupCE" - (unpackFS sym_to_find) - -linkDependencies :: HscEnv -> PersistentLinkerState - -> SrcSpan -> [Module] - -> IO (PersistentLinkerState, SuccessFlag) -linkDependencies hsc_env pls span needed_mods = do --- initDynLinker (hsc_dflags hsc_env) dl - let hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay dflags span - - -- Find what packages and linkables are required - (lnks, pkgs) <- getLinkDeps hsc_env hpt pls - maybe_normal_osuf span needed_mods - - -- Link the packages and modules required - pls1 <- linkPackages' hsc_env pkgs pls - linkModules hsc_env pls1 lnks - - --- | Temporarily extend the linker state. - -withExtendedLinkEnv :: (ExceptionMonad m) => - DynLinker -> [(Name,ForeignHValue)] -> m a -> m a -withExtendedLinkEnv dl new_env action - = gbracket (liftIO $ extendLinkEnv dl new_env) - (\_ -> reset_old_env) - (\_ -> action) - where - -- Remember that the linker state might be side-effected - -- during the execution of the IO action, and we don't want to - -- lose those changes (we might have linked a new module or - -- package), so the reset action only removes the names we - -- added earlier. - reset_old_env = liftIO $ do - modifyPLS_ dl $ \pls -> - let cur = closure_env pls - new = delListFromNameEnv cur (map fst new_env) - in return pls{ closure_env = new } - - --- | Display the persistent linker state. -showLinkerState :: DynLinker -> DynFlags -> IO () -showLinkerState dl dflags - = do pls <- readPLS dl - putLogMsg dflags NoReason SevDump noSrcSpan - (defaultDumpStyle dflags) - (vcat [text "----- Linker state -----", - text "Pkgs:" <+> ppr (pkgs_loaded pls), - text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls)]) - - -{- ********************************************************************** - - Initialisation - - ********************************************************************* -} - --- | Initialise the dynamic linker. This entails --- --- a) Calling the C initialisation procedure, --- --- b) Loading any packages specified on the command line, --- --- c) Loading any packages specified on the command line, now held in the --- @-l@ options in @v_Opt_l@, --- --- d) Loading any @.o\/.dll@ files specified on the command line, now held --- in @ldInputs@, --- --- e) Loading any MacOS frameworks. --- --- NOTE: This function is idempotent; if called more than once, it does --- nothing. This is useful in Template Haskell, where we call it before --- trying to link. --- -initDynLinker :: HscEnv -> IO () -initDynLinker hsc_env = do - let dl = hsc_dynLinker hsc_env - modifyMbPLS_ dl $ \pls -> do - case pls of - Just _ -> return pls - Nothing -> Just <$> reallyInitDynLinker hsc_env - -reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState -reallyInitDynLinker hsc_env = do - -- Initialise the linker state - let dflags = hsc_dflags hsc_env - pls0 = emptyPLS dflags - - -- (a) initialise the C dynamic linker - initObjLinker hsc_env - - -- (b) Load packages from the command-line (Note [preload packages]) - pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0 - - -- steps (c), (d) and (e) - linkCmdLineLibs' hsc_env pls - - -linkCmdLineLibs :: HscEnv -> IO () -linkCmdLineLibs hsc_env = do - let dl = hsc_dynLinker hsc_env - initDynLinker hsc_env - modifyPLS_ dl $ \pls -> do - linkCmdLineLibs' hsc_env pls - -linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState -linkCmdLineLibs' hsc_env pls = - do - let dflags@(DynFlags { ldInputs = cmdline_ld_inputs - , libraryPaths = lib_paths_base}) - = hsc_dflags hsc_env - - -- (c) Link libraries from the command-line - let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] - - -- On Windows we want to add libpthread by default just as GCC would. - -- However because we don't know the actual name of pthread's dll we - -- need to defer this to the locateLib call so we can't initialize it - -- inside of the rts. Instead we do it here to be able to find the - -- import library for pthreads. See #13210. - let platform = targetPlatform dflags - os = platformOS platform - minus_ls = case os of - OSMinGW32 -> "pthread" : minus_ls_1 - _ -> minus_ls_1 - -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags os - - lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base - - maybePutStrLn dflags "Search directories (user):" - maybePutStr dflags (unlines $ map (" "++) lib_paths_env) - maybePutStrLn dflags "Search directories (gcc):" - maybePutStr dflags (unlines $ map (" "++) gcc_paths) - - libspecs - <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls - - -- (d) Link .o files from the command-line - classified_ld_inputs <- mapM (classifyLdInput dflags) - [ f | FileOption _ f <- cmdline_ld_inputs ] - - -- (e) Link any MacOS frameworks - let platform = targetPlatform dflags - let (framework_paths, frameworks) = - if platformUsesFrameworks platform - then (frameworkPaths dflags, cmdlineFrameworks dflags) - else ([],[]) - - -- Finally do (c),(d),(e) - let cmdline_lib_specs = catMaybes classified_ld_inputs - ++ libspecs - ++ map Framework frameworks - if null cmdline_lib_specs then return pls - else do - - -- Add directories to library search paths, this only has an effect - -- on Windows. On Unix OSes this function is a NOP. - let all_paths = let paths = takeDirectory (pgm_c dflags) - : framework_paths - ++ lib_paths_base - ++ [ takeDirectory dll | DLLPath dll <- libspecs ] - in nub $ map normalise paths - let lib_paths = nub $ lib_paths_base ++ gcc_paths - all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths - pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env - - let merged_specs = mergeStaticObjects cmdline_lib_specs - pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls - merged_specs - - maybePutStr dflags "final link ... " - ok <- resolveObjs hsc_env - - -- DLLs are loaded, reset the search paths - mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache - - if succeeded ok then maybePutStrLn dflags "done" - else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") - - return pls1 - --- | Merge runs of consecutive of 'Objects'. This allows for resolution of --- cyclic symbol references when dynamically linking. Specifically, we link --- together all of the static objects into a single shared object, avoiding --- the issue we saw in #13786. -mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] -mergeStaticObjects specs = go [] specs - where - go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] - go accum (Objects objs : rest) = go (objs ++ accum) rest - go accum@(_:_) rest = Objects (reverse accum) : go [] rest - go [] (spec:rest) = spec : go [] rest - go [] [] = [] - -{- Note [preload packages] - -Why do we need to preload packages from the command line? This is an -explanation copied from #2437: - -I tried to implement the suggestion from #3560, thinking it would be -easy, but there are two reasons we link in packages eagerly when they -are mentioned on the command line: - - * So that you can link in extra object files or libraries that - depend on the packages. e.g. ghc -package foo -lbar where bar is a - C library that depends on something in foo. So we could link in - foo eagerly if and only if there are extra C libs or objects to - link in, but.... - - * Haskell code can depend on a C function exported by a package, and - the normal dependency tracking that TH uses can't know about these - dependencies. The test ghcilink004 relies on this, for example. - -I conclude that we need two -package flags: one that says "this is a -package I want to make available", and one that says "this is a -package I want to link in eagerly". Would that be too complicated for -users? --} - -classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) -classifyLdInput dflags f - | isObjectFilename platform f = return (Just (Objects [f])) - | isDynLibFilename platform f = return (Just (DLLPath f)) - | otherwise = do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) - return Nothing - where platform = targetPlatform dflags - -preloadLib - :: HscEnv -> [String] -> [String] -> PersistentLinkerState - -> LibrarySpec -> IO PersistentLinkerState -preloadLib hsc_env lib_paths framework_paths pls lib_spec = do - maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") - case lib_spec of - Objects static_ishs -> do - (b, pls1) <- preload_statics lib_paths static_ishs - maybePutStrLn dflags (if b then "done" else "not found") - return pls1 - - Archive static_ish -> do - b <- preload_static_archive lib_paths static_ish - maybePutStrLn dflags (if b then "done" else "not found") - return pls - - DLL dll_unadorned -> do - maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned) - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm | platformOS platform /= OSDarwin -> - preloadFailed mm lib_paths lib_spec - Just mm | otherwise -> do - -- As a backup, on Darwin, try to also load a .so file - -- since (apparently) some things install that way - see - -- ticket #8770. - let libfile = ("lib" ++ dll_unadorned) <.> "so" - err2 <- loadDLL hsc_env libfile - case err2 of - Nothing -> maybePutStrLn dflags "done" - Just _ -> preloadFailed mm lib_paths lib_spec - return pls - - DLLPath dll_path -> do - do maybe_errstr <- loadDLL hsc_env dll_path - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm lib_paths lib_spec - return pls - - Framework framework -> - if platformUsesFrameworks (targetPlatform dflags) - then do maybe_errstr <- loadFramework hsc_env framework_paths framework - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm framework_paths lib_spec - return pls - else panic "preloadLib Framework" - - where - dflags = hsc_dflags hsc_env - - platform = targetPlatform dflags - - preloadFailed :: String -> [String] -> LibrarySpec -> IO () - preloadFailed sys_errmsg paths spec - = do maybePutStr dflags "failed.\n" - throwGhcExceptionIO $ - CmdLineError ( - "user specified .o/.so/.DLL could not be loaded (" - ++ sys_errmsg ++ ")\nWhilst trying to load: " - ++ showLS spec ++ "\nAdditional directories searched:" - ++ (if null paths then " (none)" else - intercalate "\n" (map (" "++) paths))) - - -- Not interested in the paths in the static case. - preload_statics _paths names - = do b <- or <$> mapM doesFileExist names - if not b then return (False, pls) - else if dynamicGhc - then do pls1 <- dynLoadObjs hsc_env pls names - return (True, pls1) - else do mapM_ (loadObj hsc_env) names - return (True, pls) - - preload_static_archive _paths name - = do b <- doesFileExist name - if not b then return False - else do if dynamicGhc - then throwGhcExceptionIO $ - CmdLineError dynamic_msg - else loadArchive hsc_env name - return True - where - dynamic_msg = unlines - [ "User-specified static library could not be loaded (" - ++ name ++ ")" - , "Loading static libraries is not supported in this configuration." - , "Try using a dynamic library instead." - ] - - -{- ********************************************************************** - - Link a byte-code expression - - ********************************************************************* -} - --- | Link a single expression, /including/ first linking packages and --- modules that this expression depends on. --- --- Raises an IO exception ('ProgramError') if it can't find a compiled --- version of the dependents to link. --- -linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue -linkExpr hsc_env span root_ul_bco - = do { - -- Initialise the linker (if it's not been done already) - ; initDynLinker hsc_env - - -- Extract the DynLinker value for passing into required places - ; let dl = hsc_dynLinker hsc_env - - -- Take lock for the actual work. - ; modifyPLS dl $ \pls0 -> do { - - -- Link the packages and modules required - ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods - ; if failed ok then - throwGhcExceptionIO (ProgramError "") - else do { - - -- Link the expression itself - let ie = itbl_env pls - ce = closure_env pls - - -- Link the necessary packages and linkables - - ; let nobreakarray = error "no break array" - bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco - ; [root_hvref] <- createBCOs hsc_env [resolved] - ; fhv <- mkFinalizedHValue hsc_env root_hvref - ; return (pls, fhv) - }}} - where - free_names = uniqDSetToList (bcoFreeNames root_ul_bco) - - needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - -dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a -dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) - - -checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -checkNonStdWay dflags srcspan - | gopt Opt_ExternalInterpreter dflags = return Nothing - -- with -fexternal-interpreter we load the .o files, whatever way - -- they were built. If they were built for a non-std way, then - -- we will use the appropriate variant of the iserv binary to load them. - - | interpWays == haskellWays = return Nothing - -- Only if we are compiling with the same ways as GHC is built - -- with, can we dynamically load those object files. (see #3604) - - | objectSuf dflags == normalObjectSuffix && not (null haskellWays) - = failNonStd dflags srcspan - - | otherwise = return (Just (interpTag ++ "o")) - where - haskellWays = filter (not . wayRTSOnly) (ways dflags) - interpTag = case mkBuildTag interpWays of - "" -> "" - tag -> tag ++ "_" - -normalObjectSuffix :: String -normalObjectSuffix = phaseInputExt StopLn - -failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -failNonStd dflags srcspan = dieWith dflags srcspan $ - text "Cannot load" <+> compWay <+> - text "objects when GHC is built" <+> ghciWay $$ - text "To fix this, either:" $$ - text " (1) Use -fexternal-interpreter, or" $$ - text " (2) Build the program twice: once" <+> - ghciWay <> text ", and then" $$ - text " with" <+> compWay <+> - text "using -osuf to set a different object file suffix." - where compWay - | WayDyn `elem` ways dflags = text "-dynamic" - | WayProf `elem` ways dflags = text "-prof" - | otherwise = text "normal" - ghciWay - | dynamicGhc = text "with -dynamic" - | rtsIsProfiled = text "with -prof" - | otherwise = text "the normal way" - -getLinkDeps :: HscEnv -> HomePackageTable - -> PersistentLinkerState - -> Maybe FilePath -- replace object suffices? - -> SrcSpan -- for error messages - -> [Module] -- If you need these - -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first --- Fails with an IO exception if it can't find enough files - -getLinkDeps hsc_env hpt pls replace_osuf span mods --- Find all the packages and linkables that a set of modules depends on - = do { - -- 1. Find the dependent home-pkg-modules/packages from each iface - -- (omitting modules from the interactive package, which is already linked) - ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) - emptyUniqDSet emptyUniqDSet; - - ; let { - -- 2. Exclude ones already linked - -- Main reason: avoid findModule calls in get_linkable - mods_needed = mods_s `minusList` linked_mods ; - pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; - - linked_mods = map (moduleName.linkableModule) - (objs_loaded pls ++ bcos_loaded pls) } - - -- 3. For each dependent module, find its linkable - -- This will either be in the HPT or (in the case of one-shot - -- compilation) we may need to use maybe_getFileLinkable - ; let { osuf = objectSuf dflags } - ; lnks_needed <- mapM (get_linkable osuf) mods_needed - - ; return (lnks_needed, pkgs_needed) } - where - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - - -- The ModIface contains the transitive closure of the module dependencies - -- within the current package, *except* for boot modules: if we encounter - -- a boot module, we have to find its real interface and discover the - -- dependencies of that. Hence we need to traverse the dependency - -- tree recursively. See bug #936, testcase ghci/prog007. - follow_deps :: [Module] -- modules to follow - -> UniqDSet ModuleName -- accum. module dependencies - -> UniqDSet InstalledUnitId -- accum. package dependencies - -> IO ([ModuleName], [InstalledUnitId]) -- result - follow_deps [] acc_mods acc_pkgs - = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) - follow_deps (mod:mods) acc_mods acc_pkgs - = do - mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ - loadInterface msg mod (ImportByUser False) - iface <- case mb_iface of - Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Maybes.Succeeded iface -> return iface - - when (mi_boot iface) $ link_boot_mod_error mod - - let - pkg = moduleUnitId mod - deps = mi_deps iface - - pkg_deps = dep_pkgs deps - (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) - where is_boot (m,True) = Left m - is_boot (m,False) = Right m - - boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps - acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps - -- - if pkg /= this_pkg - then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg)) - else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) - acc_mods' acc_pkgs' - where - msg = text "need to link module" <+> ppr mod <+> - text "due to use of Template Haskell" - - - link_boot_mod_error mod = - throwGhcExceptionIO (ProgramError (showSDoc dflags ( - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module"))) - - no_obj :: Outputable a => a -> IO b - no_obj mod = dieWith dflags span $ - text "cannot find object file for module " <> - quotes (ppr mod) $$ - while_linking_expr - - while_linking_expr = text "while linking an interpreted expression" - - -- This one is a build-system bug - - get_linkable osuf mod_name -- A home-package module - | Just mod_info <- lookupHpt hpt mod_name - = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) - | otherwise - = do -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - mb_stuff <- findHomeModule hsc_env mod_name - case mb_stuff of - Found loc mod -> found loc mod - _ -> no_obj mod_name - where - found loc mod = do { - -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod loc ; - case mb_lnk of { - Nothing -> no_obj mod ; - Just lnk -> adjust_linkable lnk - }} - - adjust_linkable lnk - | Just new_osuf <- replace_osuf = do - new_uls <- mapM (adjust_ul new_osuf) - (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } - | otherwise = - return lnk - - adjust_ul new_osuf (DotO file) = do - MASSERT(osuf `isSuffixOf` file) - let file_base = fromJust (stripExtension osuf file) - new_file = file_base <.> new_osuf - ok <- doesFileExist new_file - if (not ok) - then dieWith dflags span $ - text "cannot find object file " - <> quotes (text new_file) $$ while_linking_expr - else return (DotO new_file) - adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) - adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) - adjust_ul _ l@(BCOs {}) = return l - - - -{- ********************************************************************** - - Loading a Decls statement - - ********************************************************************* -} - -linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () -linkDecls hsc_env span cbc@CompiledByteCode{..} = do - -- Initialise the linker (if it's not been done already) - initDynLinker hsc_env - - -- Extract the DynLinker for passing into required places - let dl = hsc_dynLinker hsc_env - - -- Take lock for the actual work. - modifyPLS dl $ \pls0 -> do - - -- Link the packages and modules required - (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods - if failed ok - then throwGhcExceptionIO (ProgramError "") - else do - - -- Link the expression itself - let ie = plusNameEnv (itbl_env pls) bc_itbls - ce = closure_env pls - - -- Link the necessary packages and linkables - new_bindings <- linkSomeBCOs hsc_env ie ce [cbc] - nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings - let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs - , itbl_env = ie } - return (pls2, ()) - where - free_names = uniqDSetToList $ - foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos - - needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - -{- ********************************************************************** - - Loading a single module - - ********************************************************************* -} - -linkModule :: HscEnv -> Module -> IO () -linkModule hsc_env mod = do - initDynLinker hsc_env - let dl = hsc_dynLinker hsc_env - modifyPLS_ dl $ \pls -> do - (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] - if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") - else return pls' - -{- ********************************************************************** - - Link some linkables - The linkables may consist of a mixture of - byte-code modules and object modules - - ********************************************************************* -} - -linkModules :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO (PersistentLinkerState, SuccessFlag) -linkModules hsc_env pls linkables - = mask_ $ do -- don't want to be interrupted by ^C in here - - let (objs, bcos) = partition isObjectLinkable - (concatMap partitionLinkable linkables) - - -- Load objects first; they can't depend on BCOs - (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs - - if failed ok_flag then - return (pls1, Failed) - else do - pls2 <- dynLinkBCOs hsc_env pls1 bcos - return (pls2, Succeeded) - - --- HACK to support f-x-dynamic in the interpreter; no other purpose -partitionLinkable :: Linkable -> [Linkable] -partitionLinkable li - = let li_uls = linkableUnlinked li - li_uls_obj = filter isObject li_uls - li_uls_bco = filter isInterpretable li_uls - in - case (li_uls_obj, li_uls_bco) of - (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, - li {linkableUnlinked=li_uls_bco}] - _ -> [li] - -findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable -findModuleLinkable_maybe lis mod - = case [LM time nm us | LM time nm us <- lis, nm == mod] of - [] -> Nothing - [li] -> Just li - _ -> pprPanic "findModuleLinkable" (ppr mod) - -linkableInSet :: Linkable -> [Linkable] -> Bool -linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModule l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m - - -{- ********************************************************************** - - The object-code linker - - ********************************************************************* -} - -dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO (PersistentLinkerState, SuccessFlag) -dynLinkObjs hsc_env pls objs = do - -- Load the object files and link them - let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs - pls1 = pls { objs_loaded = objs_loaded' } - unlinkeds = concatMap linkableUnlinked new_objs - wanted_objs = map nameOfObject unlinkeds - - if interpreterDynamic (hsc_dflags hsc_env) - then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs - return (pls2, Succeeded) - else do mapM_ (loadObj hsc_env) wanted_objs - - -- Link them all together - ok <- resolveObjs hsc_env - - -- If resolving failed, unload all our - -- object modules and carry on - if succeeded ok then do - return (pls1, Succeeded) - else do - pls2 <- unload_wkr hsc_env [] pls1 - return (pls2, Failed) - - -dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath] - -> IO PersistentLinkerState -dynLoadObjs _ pls [] = return pls -dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do - let dflags = hsc_dflags hsc_env - let platform = targetPlatform dflags - let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] - let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] - (soFile, libPath , libName) <- - newTempLibName dflags TFL_CurrentModule (soExt platform) - let - dflags2 = dflags { - -- We don't want the original ldInputs in - -- (they're already linked in), but we do want - -- to link against previous dynLoadObjs - -- libraries if there were any, so that the linker - -- can resolve dependencies when it loads this - -- library. - ldInputs = - concatMap (\l -> [ Option ("-l" ++ l) ]) - (nub $ snd <$> temp_sos) - ++ concatMap (\lp -> Option ("-L" ++ lp) - : if useXLinkerRPath dflags (platformOS platform) - then [ Option "-Xlinker" - , Option "-rpath" - , Option "-Xlinker" - , Option lp ] - else []) - (nub $ fst <$> temp_sos) - ++ concatMap - (\lp -> Option ("-L" ++ lp) - : if useXLinkerRPath dflags (platformOS platform) - then [ Option "-Xlinker" - , Option "-rpath" - , Option "-Xlinker" - , Option lp ] - else []) - minus_big_ls - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - ++ map (\l -> Option ("-l" ++ l)) minus_ls, - -- Add -l options and -L options from dflags. - -- - -- When running TH for a non-dynamic way, we still - -- need to make -l flags to link against the dynamic - -- libraries, so we need to add WayDyn to ways. - -- - -- Even if we're e.g. profiling, we still want - -- the vanilla dynamic libraries, so we set the - -- ways / build tag to be just WayDyn. - ways = [WayDyn], - buildTag = mkBuildTag [WayDyn], - outputFile = Just soFile - } - -- link all "loaded packages" so symbols in those can be resolved - -- Note: We are loading packages with local scope, so to see the - -- symbols in this link we must link all loaded packages again. - linkDynLib dflags2 objs pkgs_loaded - - -- if we got this far, extend the lifetime of the library file - changeTempFilesLifetime dflags TFL_GhcSession [soFile] - m <- loadDLL hsc_env soFile - case m of - Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } - Just err -> panic ("Loading temp shared object failed: " ++ err) - -rmDupLinkables :: [Linkable] -- Already loaded - -> [Linkable] -- New linkables - -> ([Linkable], -- New loaded set (including new ones) - [Linkable]) -- New linkables (excluding dups) -rmDupLinkables already ls - = go already [] ls - where - go already extras [] = (already, extras) - go already extras (l:ls) - | linkableInSet l already = go already extras ls - | otherwise = go (l:already) (l:extras) ls - -{- ********************************************************************** - - The byte-code linker - - ********************************************************************* -} - - -dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO PersistentLinkerState -dynLinkBCOs hsc_env pls bcos = do - - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos - pls1 = pls { bcos_loaded = bcos_loaded' } - unlinkeds :: [Unlinked] - unlinkeds = concatMap linkableUnlinked new_bcos - - cbcs :: [CompiledByteCode] - cbcs = map byteCodeOfObject unlinkeds - - - ies = map bc_itbls cbcs - gce = closure_env pls - final_ie = foldr plusNameEnv (itbl_env pls) ies - - names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs - - -- We only want to add the external ones to the ClosureEnv - let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs - - -- Immediately release any HValueRefs we're not going to add - freeHValueRefs hsc_env (map snd to_drop) - -- Wrap finalizers on the ones we want to keep - new_binds <- makeForeignNamedHValueRefs hsc_env to_add - - return pls1 { closure_env = extendClosureEnv gce new_binds, - itbl_env = final_ie } - --- Link a bunch of BCOs and return references to their values -linkSomeBCOs :: HscEnv - -> ItblEnv - -> ClosureEnv - -> [CompiledByteCode] - -> IO [(Name,HValueRef)] - -- The returned HValueRefs are associated 1-1 with - -- the incoming unlinked BCOs. Each gives the - -- value of the corresponding unlinked BCO - -linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods [] - where - fun CompiledByteCode{..} inner accum = - case bc_breaks of - Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) - Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> - inner ((breakarray, bc_bcos) : accum) - - do_link [] = return [] - do_link mods = do - let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] - names = map (unlinkedBCOName . snd) flat - bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco - | (breakarray, bco) <- flat ] - hvrefs <- createBCOs hsc_env resolved - return (zip names hvrefs) - --- | Useful to apply to the result of 'linkSomeBCOs' -makeForeignNamedHValueRefs - :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] -makeForeignNamedHValueRefs hsc_env bindings = - mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings - -{- ********************************************************************** - - Unload some object modules - - ********************************************************************* -} - --- --------------------------------------------------------------------------- --- | Unloading old objects ready for a new compilation sweep. --- --- The compilation manager provides us with a list of linkables that it --- considers \"stable\", i.e. won't be recompiled this time around. For --- each of the modules current linked in memory, --- --- * if the linkable is stable (and it's the same one -- the user may have --- recompiled the module on the side), we keep it, --- --- * otherwise, we unload it. --- --- * we also implicitly unload all temporary bindings at this point. --- -unload :: HscEnv - -> [Linkable] -- ^ The linkables to *keep*. - -> IO () -unload hsc_env linkables - = mask_ $ do -- mask, so we're safe from Ctrl-C in here - - -- Initialise the linker (if it's not been done already) - initDynLinker hsc_env - - -- Extract DynLinker for passing into required places - let dl = hsc_dynLinker hsc_env - - new_pls - <- modifyPLS dl $ \pls -> do - pls1 <- unload_wkr hsc_env linkables pls - return (pls1, pls1) - - let dflags = hsc_dflags hsc_env - debugTraceMsg dflags 3 $ - text "unload: retaining objs" <+> ppr (objs_loaded new_pls) - debugTraceMsg dflags 3 $ - text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) - return () - -unload_wkr :: HscEnv - -> [Linkable] -- stable linkables - -> PersistentLinkerState - -> IO PersistentLinkerState --- Does the core unload business --- (the wrapper blocks exceptions and deals with the PLS get and put) - -unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do - -- NB. careful strictness here to avoid keeping the old PLS when - -- we're unloading some code. -fghci-leak-check with the tests in - -- testsuite/ghci can detect space leaks here. - - let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables - - discard keep l = not (linkableInSet l keep) - - (objs_to_unload, remaining_objs_loaded) = - partition (discard objs_to_keep) objs_loaded - (bcos_to_unload, remaining_bcos_loaded) = - partition (discard bcos_to_keep) bcos_loaded - - mapM_ unloadObjs objs_to_unload - mapM_ unloadObjs bcos_to_unload - - -- If we unloaded any object files at all, we need to purge the cache - -- of lookupSymbol results. - when (not (null (objs_to_unload ++ - filter (not . null . linkableObjs) bcos_to_unload))) $ - purgeLookupSymbolCache hsc_env - - let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded - - -- Note that we want to remove all *local* - -- (i.e. non-isExternal) names too (these are the - -- temporary bindings from the command line). - keep_name (n,_) = isExternalName n && - nameModule n `elemModuleSet` bcos_retained - - itbl_env' = filterNameEnv keep_name itbl_env - closure_env' = filterNameEnv keep_name closure_env - - !new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = remaining_bcos_loaded, - objs_loaded = remaining_objs_loaded } - - return new_pls - where - unloadObjs :: Linkable -> IO () - unloadObjs lnk - -- The RTS's PEi386 linker currently doesn't support unloading. - | isWindowsHost = return () - - | dynamicGhc = return () - -- We don't do any cleanup when linking objects with the - -- dynamic linker. Doing so introduces extra complexity for - -- not much benefit. - - | otherwise - = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] - -- The components of a BCO linkable may contain - -- dot-o files. Which is very confusing. - -- - -- But the BCO parts can be unlinked just by - -- letting go of them (plus of course depopulating - -- the symbol table which is done in the main body) - -{- ********************************************************************** - - Loading packages - - ********************************************************************* -} - -data LibrarySpec - = Objects [FilePath] -- Full path names of set of .o files, including trailing .o - -- We allow batched loading to ensure that cyclic symbol - -- references can be resolved (see #13786). - -- For dynamic objects only, try to find the object - -- file in all the directories specified in - -- v_Library_paths before giving up. - - | Archive FilePath -- Full path name of a .a file, including trailing .a - - | DLL String -- "Unadorned" name of a .DLL/.so - -- e.g. On unix "qt" denotes "libqt.so" - -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" - -- loadDLL is platform-specific and adds the lib/.so/.DLL - -- suffixes platform-dependently - - | DLLPath FilePath -- Absolute or relative pathname to a dynamic library - -- (ends with .dll or .so). - - | Framework String -- Only used for darwin, but does no harm - -instance Outputable LibrarySpec where - ppr (Objects objs) = text "Objects" <+> ppr objs - ppr (Archive a) = text "Archive" <+> text a - ppr (DLL s) = text "DLL" <+> text s - ppr (DLLPath f) = text "DLLPath" <+> text f - ppr (Framework s) = text "Framework" <+> text s - --- If this package is already part of the GHCi binary, we'll already --- have the right DLLs for this package loaded, so don't try to --- load them again. --- --- But on Win32 we must load them 'again'; doing so is a harmless no-op --- as far as the loader is concerned, but it does initialise the list --- of DLL handles that rts/Linker.c maintains, and that in turn is --- used by lookupSymbol. So we must call addDLL for each library --- just to get the DLL handle into the list. -partOfGHCi :: [PackageName] -partOfGHCi - | isWindowsHost || isDarwinHost = [] - | otherwise = map (PackageName . mkFastString) - ["base", "template-haskell", "editline"] - -showLS :: LibrarySpec -> String -showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" -showLS (Archive nm) = "(static archive) " ++ nm -showLS (DLL nm) = "(dynamic) " ++ nm -showLS (DLLPath nm) = "(dynamic) " ++ nm -showLS (Framework nm) = "(framework) " ++ nm - --- | Link exactly the specified packages, and their dependents (unless of --- course they are already linked). The dependents are linked --- automatically, and it doesn't matter what order you specify the input --- packages. --- -linkPackages :: HscEnv -> [LinkerUnitId] -> IO () --- NOTE: in fact, since each module tracks all the packages it depends on, --- we don't really need to use the package-config dependencies. --- --- However we do need the package-config stuff (to find aux libs etc), --- and following them lets us load libraries in the right order, which --- perhaps makes the error message a bit more localised if we get a link --- failure. So the dependency walking code is still here. - -linkPackages hsc_env new_pkgs = do - -- It's probably not safe to try to load packages concurrently, so we take - -- a lock. - initDynLinker hsc_env - let dl = hsc_dynLinker hsc_env - modifyPLS_ dl $ \pls -> do - linkPackages' hsc_env new_pkgs pls - -linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState - -> IO PersistentLinkerState -linkPackages' hsc_env new_pks pls = do - pkgs' <- link (pkgs_loaded pls) new_pks - return $! pls { pkgs_loaded = pkgs' } - where - dflags = hsc_dflags hsc_env - - link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId] - link pkgs new_pkgs = - foldM link_one pkgs new_pkgs - - link_one pkgs new_pkg - | new_pkg `elem` pkgs -- Already linked - = return pkgs - - | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg - = do { -- Link dependents first - pkgs' <- link pkgs (depends pkg_cfg) - -- Now link the package itself - ; linkPackage hsc_env pkg_cfg - ; return (new_pkg : pkgs') } - - | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg))) - - -linkPackage :: HscEnv -> PackageConfig -> IO () -linkPackage hsc_env pkg - = do - let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - is_dyn = interpreterDynamic dflags - dirs | is_dyn = Packages.libraryDynDirs pkg - | otherwise = Packages.libraryDirs pkg - - let hs_libs = Packages.hsLibraries pkg - -- The FFI GHCi import lib isn't needed as - -- compiler/ghci/Linker.hs + rts/Linker.c link the - -- interpreted references to FFI to the compiled FFI. - -- We therefore filter it out so that we don't get - -- duplicate symbol errors. - hs_libs' = filter ("HSffi" /=) hs_libs - - -- Because of slight differences between the GHC dynamic linker and - -- the native system linker some packages have to link with a - -- different list of libraries when using GHCi. Examples include: libs - -- that are actually gnu ld scripts, and the possibility that the .a - -- libs do not exactly match the .so/.dll equivalents. So if the - -- package file provides an "extra-ghci-libraries" field then we use - -- that instead of the "extra-libraries" field. - extra_libs = - (if null (Packages.extraGHCiLibraries pkg) - then Packages.extraLibraries pkg - else Packages.extraGHCiLibraries pkg) - ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] - -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags (platformOS platform) - dirs_env <- addEnvPaths "LIBRARY_PATH" dirs - - hs_classifieds - <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs' - extra_classifieds - <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs - let classifieds = hs_classifieds ++ extra_classifieds - - -- Complication: all the .so's must be loaded before any of the .o's. - let known_dlls = [ dll | DLLPath dll <- classifieds ] - dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Objects objs <- classifieds - , obj <- objs ] - archs = [ arch | Archive arch <- classifieds ] - - -- Add directories to library search paths - let dll_paths = map takeDirectory known_dlls - all_paths = nub $ map normalise $ dll_paths ++ dirs - all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths - pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env - - maybePutStr dflags - ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") - - -- See comments with partOfGHCi -#if defined(CAN_LOAD_DLL) - when (packageName pkg `notElem` partOfGHCi) $ do - loadFrameworks hsc_env platform pkg - -- See Note [Crash early load_dyn and locateLib] - -- Crash early if can't load any of `known_dlls` - mapM_ (load_dyn hsc_env True) known_dlls - -- For remaining `dlls` crash early only when there is surely - -- no package's DLL around ... (not is_dyn) - mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) dlls -#endif - -- After loading all the DLLs, we can load the static objects. - -- Ordering isn't important here, because we do one final link - -- step to resolve everything. - mapM_ (loadObj hsc_env) objs - mapM_ (loadArchive hsc_env) archs - - maybePutStr dflags "linking ... " - ok <- resolveObjs hsc_env - - -- DLLs are loaded, reset the search paths - -- Import libraries will be loaded via loadArchive so only - -- reset the DLL search path after all archives are loaded - -- as well. - mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache - - if succeeded ok - then maybePutStrLn dflags "done." - else let errmsg = "unable to load package `" - ++ sourcePackageIdString pkg ++ "'" - in throwGhcExceptionIO (InstallationError errmsg) - -{- -Note [Crash early load_dyn and locateLib] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a package is "normal" (exposes it's code from more than zero Haskell -modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then -it has it's code compiled and linked into the DLL, which GHCi linker picks -when loading the package's code (see the big comment in the beginning of -`locateLib`). - -When loading DLLs, GHCi linker simply calls the system's `dlopen` or -`LoadLibrary` APIs. This is quite different from the case when GHCi linker -loads an object file or static library. When loading an object file or static -library GHCi linker parses them and resolves all symbols "manually". -These object file or static library may reference some external symbols -defined in some external DLLs. And GHCi should know which these -external DLLs are. - -But when GHCi loads a DLL, it's the *system* linker who manages all -the necessary dependencies, and it is able to load this DLL not having -any extra info. Thus we don't *have to* crash in this case even if we -are unable to load any supposed dependencies explicitly. - -Suppose during GHCi session a client of the package wants to -`foreign import` a symbol which isn't exposed by the package DLL, but -is exposed by such an external (dependency) DLL. -If the DLL isn't *explicitly* loaded because `load_dyn` failed to do -this, then the client code eventually crashes because the GHCi linker -isn't able to locate this symbol (GHCi linker maintains a list of -explicitly loaded DLLs it looks into when trying to find a symbol). - -This is why we still should try to load all the dependency DLLs -even though we know that the system linker loads them implicitly when -loading the package DLL. - -Why we still keep the `crash_early` opportunity then not allowing such -a permissive behaviour for any DLLs? Well, we, perhaps, improve a user -experience in some cases slightly. - -But if it happens there exist other corner cases where our current -usage of `crash_early` flag is overly restrictive, we may lift the -restriction very easily. --} - --- we have already searched the filesystem; the strings passed to load_dyn --- can be passed directly to loadDLL. They are either fully-qualified --- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, --- loadDLL is going to search the system paths to find the library. -load_dyn :: HscEnv -> Bool -> FilePath -> IO () -load_dyn hsc_env crash_early dll = do - r <- loadDLL hsc_env dll - case r of - Nothing -> return () - Just err -> - if crash_early - then cmdLineErrorIO err - else let dflags = hsc_dflags hsc_env in - when (wopt Opt_WarnMissedExtraSharedLib dflags) - $ putLogMsg dflags - (Reason Opt_WarnMissedExtraSharedLib) SevWarning - noSrcSpan (defaultUserStyle dflags)(note err) - where - note err = vcat $ map text - [ err - , "It's OK if you don't want to use symbols from it directly." - , "(the package DLL is loaded by the system linker" - , " which manages dependencies by itself)." ] - -loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO () -loadFrameworks hsc_env platform pkg - = when (platformUsesFrameworks platform) $ mapM_ load frameworks - where - fw_dirs = Packages.frameworkDirs pkg - frameworks = Packages.frameworks pkg - - load fw = do r <- loadFramework hsc_env fw_dirs fw - case r of - Nothing -> return () - Just err -> cmdLineErrorIO ("can't load framework: " - ++ fw ++ " (" ++ err ++ ")" ) - --- Try to find an object file for a given library in the given paths. --- If it isn't present, we assume that addDLL in the RTS can find it, --- which generally means that it should be a dynamic library in the --- standard system search path. --- For GHCi we tend to prefer dynamic libraries over static ones as --- they are easier to load and manage, have less overhead. -locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String - -> IO LibrarySpec -locateLib hsc_env is_hs lib_dirs gcc_dirs lib - | not is_hs - -- For non-Haskell libraries (e.g. gmp, iconv): - -- first look in library-dirs for a dynamic library (on User paths only) - -- (libfoo.so) - -- then try looking for import libraries on Windows (on User paths only) - -- (.dll.a, .lib) - -- first look in library-dirs for a dynamic library (on GCC paths only) - -- (libfoo.so) - -- then check for system dynamic libraries (e.g. kernel32.dll on windows) - -- then try looking for import libraries on Windows (on GCC paths only) - -- (.dll.a, .lib) - -- then look in library-dirs for a static library (libfoo.a) - -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) - -- then try looking for import libraries on Windows (.dll.a, .lib) - -- then look in library-dirs and inplace GCC for a static library (libfoo.a) - -- then try "gcc --print-file-name" to search gcc's search path - -- for a dynamic library (#5289) - -- otherwise, assume loadDLL can find it - -- - -- The logic is a bit complicated, but the rationale behind it is that - -- loading a shared library for us is O(1) while loading an archive is - -- O(n). Loading an import library is also O(n) so in general we prefer - -- shared libraries because they are simpler and faster. - -- - = -#if defined(CAN_LOAD_DLL) - findDll user `orElse` -#endif - tryImpLib user `orElse` -#if defined(CAN_LOAD_DLL) - findDll gcc `orElse` - findSysDll `orElse` -#endif - tryImpLib gcc `orElse` - findArchive `orElse` - tryGcc `orElse` - assumeDll - - | loading_dynamic_hs_libs -- search for .so libraries first. - = findHSDll `orElse` - findDynObject `orElse` - assumeDll - - | otherwise - -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a - = findObject `orElse` - findArchive `orElse` - assumeDll - - where - dflags = hsc_dflags hsc_env - dirs = lib_dirs ++ gcc_dirs - gcc = False - user = True - - obj_file - | is_hs && loading_profiled_hs_libs = lib <.> "p_o" - | otherwise = lib <.> "o" - dyn_obj_file = lib <.> "dyn_o" - arch_files = [ "lib" ++ lib ++ lib_tag <.> "a" - , lib <.> "a" -- native code has no lib_tag - , "lib" ++ lib, lib - ] - lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" - - loading_profiled_hs_libs = interpreterProfiled dflags - loading_dynamic_hs_libs = interpreterDynamic dflags - - import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib" - , "lib" ++ lib <.> "dll.a", lib <.> "dll.a" - ] - - hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags - hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name - - so_name = mkSOName platform lib - lib_so_name = "lib" ++ so_name - dyn_lib_file = case (arch, os) of - (ArchX86_64, OSSolaris2) -> "64" so_name - _ -> so_name - - findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file - findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file - findArchive = let local name = liftM (fmap Archive) $ findFile dirs name - in apply (map local arch_files) - findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file - findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs - in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file - findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ - findSystemLibrary hsc_env so_name - tryGcc = let search = searchForLibUsingGcc dflags - dllpath = liftM (fmap DLLPath) - short = dllpath $ search so_name lib_dirs - full = dllpath $ search lib_so_name lib_dirs - gcc name = liftM (fmap Archive) $ search name lib_dirs - files = import_libs ++ arch_files - dlls = [short, full] - archives = map gcc files - in apply $ -#if defined(CAN_LOAD_DLL) - dlls ++ -#endif - archives - tryImpLib re = case os of - OSMinGW32 -> - let dirs' = if re == user then lib_dirs else gcc_dirs - implib name = liftM (fmap Archive) $ - findFile dirs' name - in apply (map implib import_libs) - _ -> return Nothing - - -- TH Makes use of the interpreter so this failure is not obvious. - -- So we are nice and warn/inform users why we fail before we do. - -- But only for haskell libraries, as C libraries don't have a - -- profiling/non-profiling distinction to begin with. - assumeDll - | is_hs - , not loading_dynamic_hs_libs - , interpreterProfiled dflags - = do - warningMsg dflags - (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ - text " \tTrying dynamic library instead. If this fails try to rebuild" <+> - text "libraries with profiling support.") - return (DLL lib) - | otherwise = return (DLL lib) - infixr `orElse` - f `orElse` g = f >>= maybe g return - - apply :: [IO (Maybe a)] -> IO (Maybe a) - apply [] = return Nothing - apply (x:xs) = do x' <- x - if isJust x' - then return x' - else apply xs - - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - -searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc dflags so dirs = do - -- GCC does not seem to extend the library search path (using -L) when using - -- --print-file-name. So instead pass it a new base location. - str <- askLd dflags (map (FileOption "-B") dirs - ++ [Option "--print-file-name", Option so]) - let file = case lines str of - [] -> "" - l:_ -> l - if (file == so) - then return Nothing - else do b <- doesFileExist file -- file could be a folder (see #16063) - return (if b then Just file else Nothing) - --- | Retrieve the list of search directory GCC and the System use to find --- libraries and components. See Note [Fork/Exec Windows]. -getGCCPaths :: DynFlags -> OS -> IO [FilePath] -getGCCPaths dflags os - = case os of - OSMinGW32 -> - do gcc_dirs <- getGccSearchDirectory dflags "libraries" - sys_dirs <- getSystemDirectories - return $ nub $ gcc_dirs ++ sys_dirs - _ -> return [] - --- | Cache for the GCC search directories as this can't easily change --- during an invocation of GHC. (Maybe with some env. variable but we'll) --- deal with that highly unlikely scenario then. -{-# NOINLINE gccSearchDirCache #-} -gccSearchDirCache :: IORef [(String, [String])] -gccSearchDirCache = unsafePerformIO $ newIORef [] - --- Note [Fork/Exec Windows] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- fork/exec is expensive on Windows, for each time we ask GCC for a library we --- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. --- So instead get a list of location that GCC would search and use findDirs --- which hopefully is written in an optimized mannor to take advantage of --- caching. At the very least we remove the overhead of the fork/exec and waits --- which dominate a large percentage of startup time on Windows. -getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] -getGccSearchDirectory dflags key = do - cache <- readIORef gccSearchDirCache - case lookup key cache of - Just x -> return x - Nothing -> do - str <- askLd dflags [Option "--print-search-dirs"] - let line = dropWhile isSpace str - name = key ++ ": =" - if null line - then return [] - else do let val = split $ find name line - dirs <- filterM doesDirectoryExist val - modifyIORef' gccSearchDirCache ((key, dirs):) - return val - where split :: FilePath -> [FilePath] - split r = case break (==';') r of - (s, [] ) -> [s] - (s, (_:xs)) -> s : split xs - - find :: String -> String -> String - find r x = let lst = lines x - val = filter (r `isPrefixOf`) lst - in if null val - then [] - else case break (=='=') (head val) of - (_ , []) -> [] - (_, (_:xs)) -> xs - --- | Get a list of system search directories, this to alleviate pressure on --- the findSysDll function. -getSystemDirectories :: IO [FilePath] -#if defined(mingw32_HOST_OS) -getSystemDirectories = fmap (:[]) getSystemDirectory -#else -getSystemDirectories = return [] -#endif - --- | Merge the given list of paths with those in the environment variable --- given. If the variable does not exist then just return the identity. -addEnvPaths :: String -> [String] -> IO [String] -addEnvPaths name list - = do -- According to POSIX (chapter 8.3) a zero-length prefix means current - -- working directory. Replace empty strings in the env variable with - -- `working_dir` (see also #14695). - working_dir <- getCurrentDirectory - values <- lookupEnv name - case values of - Nothing -> return list - Just arr -> return $ list ++ splitEnv working_dir arr - where - splitEnv :: FilePath -> String -> [String] - splitEnv working_dir value = - case break (== envListSep) value of - (x, [] ) -> - [if null x then working_dir else x] - (x, (_:xs)) -> - (if null x then working_dir else x) : splitEnv working_dir xs -#if defined(mingw32_HOST_OS) - envListSep = ';' -#else - envListSep = ':' -#endif - --- ---------------------------------------------------------------------------- --- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) - -{- -Note [macOS Big Sur dynamic libraries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -macOS Big Sur makes the following change to how frameworks are shipped -with the OS: - -> New in macOS Big Sur 11 beta, the system ships with a built-in -> dynamic linker cache of all system-provided libraries. As part of -> this change, copies of dynamic libraries are no longer present on -> the filesystem. Code that attempts to check for dynamic library -> presence by looking for a file at a path or enumerating a directory -> will fail. Instead, check for library presence by attempting to -> dlopen() the path, which will correctly check for the library in the -> cache. (62986286) - -(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/) - -Therefore, the previous method of checking whether a library exists -before attempting to load it makes GHC.Runtime.Linker.loadFramework -fail to find frameworks installed at /System/Library/Frameworks. -Instead, any attempt to load a framework at runtime, such as by -passing -framework OpenGL to runghc or running code loading such a -framework with GHCi, fails with a 'not found' message. - -GHC.Runtime.Linker.loadFramework now opportunistically loads the -framework libraries without checking for their existence first, -failing only if all attempts to load a given framework from any of the -various possible locations fail. See also #18446, which this change -addresses. --} - --- Darwin / MacOS X only: load a framework --- a framework is a dynamic library packaged inside a directory of the same --- name. They are searched for in different paths than normal libraries. -loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String) -loadFramework hsc_env extraPaths rootname - = do { either_dir <- tryIO getHomeDirectory - ; let homeFrameworkPath = case either_dir of - Left _ -> [] - Right dir -> [dir "Library/Frameworks"] - ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths - ; errs <- findLoadDLL ps [] - ; return $ fmap (intercalate ", ") errs - } - where - fwk_file = rootname <.> "framework" rootname - - -- sorry for the hardcoded paths, I hope they won't change anytime soon: - defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] - - -- Try to call loadDLL for each candidate path. - -- - -- See Note [macOS Big Sur dynamic libraries] - findLoadDLL [] errs = - -- Tried all our known library paths, but dlopen() - -- has no built-in paths for frameworks: give up - return $ Just errs - findLoadDLL (p:ps) errs = - do { dll <- loadDLL hsc_env (p fwk_file) - ; case dll of - Nothing -> return Nothing - Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs) - } - -{- ********************************************************************** - - Helper functions - - ********************************************************************* -} - -maybePutStr :: DynFlags -> String -> IO () -maybePutStr dflags s - = when (verbosity dflags > 1) $ - putLogMsg dflags - NoReason - SevInteractive - noSrcSpan - (defaultUserStyle dflags) - (text s) - -maybePutStrLn :: DynFlags -> String -> IO () -maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/ghci/LinkerTypes.hs b/ghci/LinkerTypes.hs deleted file mode 100644 --- a/ghci/LinkerTypes.hs +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------ --- --- Types for the Dynamic Linker --- --- (c) The University of Glasgow 2019 --- ------------------------------------------------------------------------------ - -module LinkerTypes ( - DynLinker(..), - PersistentLinkerState(..), - LinkerUnitId, - Linkable(..), - Unlinked(..), - SptEntry(..) - ) where - -import GhcPrelude ( FilePath, String, show ) -import Data.Time ( UTCTime ) -import Data.Maybe ( Maybe ) -import Control.Concurrent.MVar ( MVar ) -import Module ( InstalledUnitId, Module ) -import ByteCodeTypes ( ItblEnv, CompiledByteCode ) -import Outputable -import Var ( Id ) -import GHC.Fingerprint.Type ( Fingerprint ) -import NameEnv ( NameEnv ) -import Name ( Name ) -import GHCi.RemoteTypes ( ForeignHValue ) - -type ClosureEnv = NameEnv (Name, ForeignHValue) - -newtype DynLinker = - DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) } - -data PersistentLinkerState - = PersistentLinkerState { - - -- Current global mapping from Names to their true values - closure_env :: ClosureEnv, - - -- The current global mapping from RdrNames of DataCons to - -- info table addresses. - -- When a new Unlinked is linked into the running image, or an existing - -- module in the image is replaced, the itbl_env must be updated - -- appropriately. - itbl_env :: !ItblEnv, - - -- The currently loaded interpreted modules (home package) - bcos_loaded :: ![Linkable], - - -- And the currently-loaded compiled modules (home package) - objs_loaded :: ![Linkable], - - -- The currently-loaded packages; always object code - -- Held, as usual, in dependency order; though I am not sure if - -- that is really important - pkgs_loaded :: ![LinkerUnitId], - - -- we need to remember the name of previous temporary DLL/.so - -- libraries so we can link them (see #10322) - temp_sos :: ![(FilePath, String)] } - --- TODO: Make this type more precise -type LinkerUnitId = InstalledUnitId - --- | Information we can use to dynamically link modules into the compiler -data Linkable = LM { - linkableTime :: UTCTime, -- ^ Time at which this linkable was built - -- (i.e. when the bytecodes were produced, - -- or the mod date on the files) - linkableModule :: Module, -- ^ The linkable module itself - linkableUnlinked :: [Unlinked] - -- ^ Those files and chunks of code we have yet to link. - -- - -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. - -- If this list is empty, the Linkable represents a fake linkable, which - -- is generated in HscNothing mode to avoid recompiling modules. - -- - -- ToDo: Do items get removed from this list when they get linked? - } - -instance Outputable Linkable where - ppr (LM when_made mod unlinkeds) - = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) - $$ nest 3 (ppr unlinkeds) - --- | Objects which have yet to be linked by the compiler -data Unlinked - = DotO FilePath -- ^ An object file (.o) - | DotA FilePath -- ^ Static archive file (.a) - | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | BCOs CompiledByteCode - [SptEntry] -- ^ A byte-code object, lives only in memory. Also - -- carries some static pointer table entries which - -- should be loaded along with the BCOs. - -- See Note [Grant plan for static forms] in - -- StaticPtrTable. - -instance Outputable Unlinked where - ppr (DotO path) = text "DotO" <+> text path - ppr (DotA path) = text "DotA" <+> text path - ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt - --- | An entry to be inserted into a module's static pointer table. --- See Note [Grand plan for static forms] in StaticPtrTable. -data SptEntry = SptEntry Id Fingerprint - -instance Outputable SptEntry where - ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr - diff --git a/ghci/RtClosureInspect.hs b/ghci/RtClosureInspect.hs deleted file mode 100644 --- a/ghci/RtClosureInspect.hs +++ /dev/null @@ -1,1355 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-} - ------------------------------------------------------------------------------ --- --- GHC Interactive support for inspecting arbitrary closures at runtime --- --- Pepe Iborra (supported by Google SoC) 2006 --- ------------------------------------------------------------------------------ -module RtClosureInspect( - -- * Entry points and types - cvObtainTerm, - cvReconstructType, - improveRTTIType, - Term(..), - - -- * Utils - isFullyEvaluatedTerm, - termType, mapTermType, termTyCoVars, - foldTerm, TermFold(..), - cPprTerm, cPprTermBase, - - constrClosToName -- exported to use in test T4891 - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHCi -import GHCi.RemoteTypes -import HscTypes - -import DataCon -import Type -import RepType -import qualified Unify as U -import Var -import TcRnMonad -import TcType -import TcMType -import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) ) -import TcUnify -import TcEnv - -import TyCon -import Name -import OccName -import Module -import IfaceEnv -import Util -import VarSet -import BasicTypes ( Boxity(..) ) -import TysPrim -import PrelNames -import TysWiredIn -import DynFlags -import Outputable as Ppr -import GHC.Char -import GHC.Exts.Heap -import SMRep ( roundUpTo ) - -import Control.Monad -import Data.Maybe -import Data.List ((\\)) -#if defined(INTEGER_GMP) -import GHC.Exts -import Data.Array.Base -import GHC.Integer.GMP.Internals -#elif defined(INTEGER_SIMPLE) -import GHC.Exts -import GHC.Integer.Simple.Internals -#endif -import qualified Data.Sequence as Seq -import Data.Sequence (viewl, ViewL(..)) -import Foreign -import System.IO.Unsafe - - ---------------------------------------------- --- * A representation of semi evaluated Terms ---------------------------------------------- - -data Term = Term { ty :: RttiType - , dc :: Either String DataCon - -- Carries a text representation if the datacon is - -- not exported by the .hi file, which is the case - -- for private constructors in -O0 compiled libraries - , val :: ForeignHValue - , subTerms :: [Term] } - - | Prim { ty :: RttiType - , valRaw :: [Word] } - - | Suspension { ctype :: ClosureType - , ty :: RttiType - , val :: ForeignHValue - , bound_to :: Maybe Name -- Useful for printing - } - | NewtypeWrap{ -- At runtime there are no newtypes, and hence no - -- newtype constructors. A NewtypeWrap is just a - -- made-up tag saying "heads up, there used to be - -- a newtype constructor here". - ty :: RttiType - , dc :: Either String DataCon - , wrapped_term :: Term } - | RefWrap { -- The contents of a reference - ty :: RttiType - , wrapped_term :: Term } - -termType :: Term -> RttiType -termType t = ty t - -isFullyEvaluatedTerm :: Term -> Bool -isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt -isFullyEvaluatedTerm Prim {} = True -isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t -isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t -isFullyEvaluatedTerm _ = False - -instance Outputable (Term) where - ppr t | Just doc <- cPprTerm cPprTermBase t = doc - | otherwise = panic "Outputable Term instance" - ----------------------------------------- --- Runtime Closure information functions ----------------------------------------- - -isThunk :: GenClosure a -> Bool -isThunk ThunkClosure{} = True -isThunk APClosure{} = True -isThunk APStackClosure{} = True -isThunk _ = False - --- Lookup the name in a constructor closure -constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name) -constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do - let occName = mkOccName OccName.dataName occ - modName = mkModule (stringToUnitId pkg) (mkModuleName mod) - Right `fmap` lookupOrigIO hsc_env modName occName -constrClosToName _hsc_env clos = - return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) - ------------------------------------ --- * Traversals for Terms ------------------------------------ -type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b - -data TermFold a = TermFold { fTerm :: TermProcessor a a - , fPrim :: RttiType -> [Word] -> a - , fSuspension :: ClosureType -> RttiType -> ForeignHValue - -> Maybe Name -> a - , fNewtypeWrap :: RttiType -> Either String DataCon - -> a -> a - , fRefWrap :: RttiType -> a -> a - } - - -data TermFoldM m a = - TermFoldM {fTermM :: TermProcessor a (m a) - , fPrimM :: RttiType -> [Word] -> m a - , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue - -> Maybe Name -> m a - , fNewtypeWrapM :: RttiType -> Either String DataCon - -> a -> m a - , fRefWrapM :: RttiType -> a -> m a - } - -foldTerm :: TermFold a -> Term -> a -foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) -foldTerm tf (Prim ty v ) = fPrim tf ty v -foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b -foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) -foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) - - -foldTermM :: Monad m => TermFoldM m a -> Term -> m a -foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v -foldTermM tf (Prim ty v ) = fPrimM tf ty v -foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b -foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc -foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty - -idTermFold :: TermFold Term -idTermFold = TermFold { - fTerm = Term, - fPrim = Prim, - fSuspension = Suspension, - fNewtypeWrap = NewtypeWrap, - fRefWrap = RefWrap - } - -mapTermType :: (RttiType -> Type) -> Term -> Term -mapTermType f = foldTerm idTermFold { - fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, - fSuspension = \ct ty hval n -> - Suspension ct (f ty) hval n, - fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, - fRefWrap = \ty t -> RefWrap (f ty) t} - -mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term -mapTermTypeM f = foldTermM TermFoldM { - fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, - fPrimM = (return.) . Prim, - fSuspensionM = \ct ty hval n -> - f ty >>= \ty' -> return $ Suspension ct ty' hval n, - fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, - fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} - -termTyCoVars :: Term -> TyCoVarSet -termTyCoVars = foldTerm TermFold { - fTerm = \ty _ _ tt -> - tyCoVarsOfType ty `unionVarSet` concatVarEnv tt, - fSuspension = \_ ty _ _ -> tyCoVarsOfType ty, - fPrim = \ _ _ -> emptyVarSet, - fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t, - fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t} - where concatVarEnv = foldr unionVarSet emptyVarSet - ----------------------------------- --- Pretty printing of terms ----------------------------------- - -type Precedence = Int -type TermPrinterM m = Precedence -> Term -> m SDoc - -app_prec,cons_prec, max_prec ::Int -max_prec = 10 -app_prec = max_prec -cons_prec = 5 -- TODO Extract this info from GHC itself - -pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m -pprTermM y p t = pprDeeper `liftM` ppr_termM y p t - -ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do - tt_docs <- mapM (y app_prec) tt - return $ cparen (not (null tt) && p >= app_prec) - (text dc_tag <+> pprDeeperList fsep tt_docs) - -ppr_termM y p Term{dc=Right dc, subTerms=tt} -{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity - = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) - <+> hsep (map (ppr_term1 True) tt) --} -- TODO Printing infix constructors properly - = do { tt_docs' <- mapM (y app_prec) tt - ; return $ ifPprDebug (show_tm tt_docs') - (show_tm (dropList (dataConTheta dc) tt_docs')) - -- Don't show the dictionary arguments to - -- constructors unless -dppr-debug is on - } - where - show_tm tt_docs - | null tt_docs = ppr dc - | otherwise = cparen (p >= app_prec) $ - sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] - -ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t -ppr_termM y p RefWrap{wrapped_term=t} = do - contents <- y app_prec t - return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents) - -- The constructor name is wired in here ^^^ for the sake of simplicity. - -- I don't think mutvars are going to change in a near future. - -- In any case this is solely a presentation matter: MutVar# is - -- a datatype with no constructors, implemented by the RTS - -- (hence there is no way to obtain a datacon and print it). -ppr_termM _ _ t = ppr_termM1 t - - -ppr_termM1 :: Monad m => Term -> m SDoc -ppr_termM1 Prim{valRaw=words, ty=ty} = - return $ repPrim (tyConAppTyCon ty) words -ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = - return (char '_' <+> whenPprDebug (text "::" <> ppr ty)) -ppr_termM1 Suspension{ty=ty, bound_to=Just n} --- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("") - | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty -ppr_termM1 Term{} = panic "ppr_termM1 - Term" -ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" -ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" - -pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} - | Just (tc,_) <- tcSplitTyConApp_maybe ty - , ASSERT(isNewTyCon tc) True - , Just new_dc <- tyConSingleDataCon_maybe tc = do - real_term <- y max_prec t - return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) -pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" - -------------------------------------------------------- --- Custom Term Pretty Printers -------------------------------------------------------- - --- We can want to customize the representation of a --- term depending on its type. --- However, note that custom printers have to work with --- type representations, instead of directly with types. --- We cannot use type classes here, unless we employ some --- typerep trickery (e.g. Weirich's RepLib tricks), --- which I didn't. Therefore, this code replicates a lot --- of what type classes provide for free. - -type CustomTermPrinter m = TermPrinterM m - -> [Precedence -> Term -> (m (Maybe SDoc))] - --- | Takes a list of custom printers with a explicit recursion knot and a term, --- and returns the output of the first successful printer, or the default printer -cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc -cPprTerm printers_ = go 0 where - printers = printers_ go - go prec t = do - let default_ = Just `liftM` pprTermM go prec t - mb_customDocs = [pp prec t | pp <- printers] ++ [default_] - mdoc <- firstJustM mb_customDocs - case mdoc of - Nothing -> panic "cPprTerm" - Just doc -> return $ cparen (prec>app_prec+1) doc - - firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) - firstJustM [] = return Nothing - --- Default set of custom printers. Note that the recursion knot is explicit -cPprTermBase :: forall m. Monad m => CustomTermPrinter m -cPprTermBase y = - [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) - . mapM (y (-1)) - . subTerms) - , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) - ppr_list - , ifTerm' (isTyCon intTyCon . ty) ppr_int - , ifTerm' (isTyCon charTyCon . ty) ppr_char - , ifTerm' (isTyCon floatTyCon . ty) ppr_float - , ifTerm' (isTyCon doubleTyCon . ty) ppr_double - , ifTerm' (isIntegerTy . ty) ppr_integer - ] - where - ifTerm :: (Term -> Bool) - -> (Precedence -> Term -> m SDoc) - -> Precedence -> Term -> m (Maybe SDoc) - ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t) - - ifTerm' :: (Term -> Bool) - -> (Precedence -> Term -> m (Maybe SDoc)) - -> Precedence -> Term -> m (Maybe SDoc) - ifTerm' pred f prec t@Term{} - | pred t = f prec t - ifTerm' _ _ _ _ = return Nothing - - isTupleTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (isBoxedTupleTyCon tc) - - isTyCon a_tc ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (a_tc == tc) - - isIntegerTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (tyConName tc == integerTyConName) - - ppr_int, ppr_char, ppr_float, ppr_double - :: Precedence -> Term -> m (Maybe SDoc) - ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} = - return (Just (Ppr.int (fromIntegral w))) - ppr_int _ _ = return Nothing - - ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} = - return (Just (Ppr.pprHsChar (chr (fromIntegral w)))) - ppr_char _ _ = return Nothing - - ppr_float _ Term{subTerms=[Prim{valRaw=[w]}]} = do - let f = unsafeDupablePerformIO $ - alloca $ \p -> poke p w >> peek (castPtr p) - return (Just (Ppr.float f)) - ppr_float _ _ = return Nothing - - ppr_double _ Term{subTerms=[Prim{valRaw=[w]}]} = do - let f = unsafeDupablePerformIO $ - alloca $ \p -> poke p w >> peek (castPtr p) - return (Just (Ppr.double f)) - -- let's assume that if we get two words, we're on a 32-bit - -- machine. There's no good way to get a DynFlags to check the word - -- size here. - ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do - let f = unsafeDupablePerformIO $ - alloca $ \p -> do - poke p (fromIntegral w1 :: Word32) - poke (p `plusPtr` 4) (fromIntegral w2 :: Word32) - peek (castPtr p) - return (Just (Ppr.double f)) - ppr_double _ _ = return Nothing - - ppr_integer :: Precedence -> Term -> m (Maybe SDoc) -#if defined(INTEGER_GMP) - -- Reconstructing Integers is a bit of a pain. This depends deeply - -- on the integer-gmp representation, so it'll break if that - -- changes (but there are several tests in - -- tests/ghci.debugger/scripts that will tell us if this is wrong). - -- - -- data Integer - -- = S# Int# - -- | Jp# {-# UNPACK #-} !BigNat - -- | Jn# {-# UNPACK #-} !BigNat - -- - -- data BigNat = BN# ByteArray# - -- - ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} = - return (Just (Ppr.integer (S# (word2Int# w)))) - ppr_integer _ Term{dc=Right con, - subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do - -- We don't need to worry about sizes that are not an integral - -- number of words, because luckily GMP uses arrays of words - -- (see GMP_LIMB_SHIFT). - let - !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws - constr - | "Jp#" <- getOccString (dataConName con) = Jp# - | otherwise = Jn# - return (Just (Ppr.integer (constr (BN# arr#)))) -#elif defined(INTEGER_SIMPLE) - -- As with the GMP case, this depends deeply on the integer-simple - -- representation. - -- - -- @ - -- data Integer = Positive !Digits | Negative !Digits | Naught - -- - -- data Digits = Some !Word# !Digits - -- | None - -- @ - -- - -- NB: the above has some type synonyms expanded out for the sake of brevity - ppr_integer _ Term{subTerms=[]} = - return (Just (Ppr.integer Naught)) - ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]} - | Just digits <- get_digits digitTerm - = return (Just (Ppr.integer (constr digits))) - where - get_digits :: Term -> Maybe Digits - get_digits Term{subTerms=[]} = Just None - get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]} - = Some w <$> get_digits t - get_digits _ = Nothing - - constr - | "Positive" <- getOccString (dataConName con) = Positive - | otherwise = Negative -#endif - ppr_integer _ _ = return Nothing - - --Note pprinting of list terms is not lazy - ppr_list :: Precedence -> Term -> m SDoc - ppr_list p (Term{subTerms=[h,t]}) = do - let elems = h : getListTerms t - isConsLast = not (termType (last elems) `eqType` termType h) - is_string = all (isCharTy . ty) elems - chars = [ chr (fromIntegral w) - | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ] - - print_elems <- mapM (y cons_prec) elems - if is_string - then return (Ppr.doubleQuotes (Ppr.text chars)) - else if isConsLast - then return $ cparen (p >= cons_prec) - $ pprDeeperList fsep - $ punctuate (space<>colon) print_elems - else return $ brackets - $ pprDeeperList fcat - $ punctuate comma print_elems - - where getListTerms Term{subTerms=[h,t]} = h : getListTerms t - getListTerms Term{subTerms=[]} = [] - getListTerms t@Suspension{} = [t] - getListTerms t = pprPanic "getListTerms" (ppr t) - ppr_list _ _ = panic "doList" - - -repPrim :: TyCon -> [Word] -> SDoc -repPrim t = rep where - rep x - -- Char# uses native machine words, whereas Char's Storable instance uses - -- Int32, so we have to read it as an Int. - | t == charPrimTyCon = text $ show (chr (build x :: Int)) - | t == intPrimTyCon = text $ show (build x :: Int) - | t == wordPrimTyCon = text $ show (build x :: Word) - | t == floatPrimTyCon = text $ show (build x :: Float) - | t == doublePrimTyCon = text $ show (build x :: Double) - | t == int32PrimTyCon = text $ show (build x :: Int32) - | t == word32PrimTyCon = text $ show (build x :: Word32) - | t == int64PrimTyCon = text $ show (build x :: Int64) - | t == word64PrimTyCon = text $ show (build x :: Word64) - | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) - | t == stablePtrPrimTyCon = text "" - | t == stableNamePrimTyCon = text "" - | t == statePrimTyCon = text "" - | t == proxyPrimTyCon = text "" - | t == realWorldTyCon = text "" - | t == threadIdPrimTyCon = text "" - | t == weakPrimTyCon = text "" - | t == arrayPrimTyCon = text "" - | t == smallArrayPrimTyCon = text "" - | t == byteArrayPrimTyCon = text "" - | t == mutableArrayPrimTyCon = text "" - | t == smallMutableArrayPrimTyCon = text "" - | t == mutableByteArrayPrimTyCon = text "" - | t == mutVarPrimTyCon = text "" - | t == mVarPrimTyCon = text "" - | t == tVarPrimTyCon = text "" - | otherwise = char '<' <> ppr t <> char '>' - where build ww = unsafePerformIO $ withArray ww (peek . castPtr) --- This ^^^ relies on the representation of Haskell heap values being --- the same as in a C array. - ------------------------------------ --- Type Reconstruction ------------------------------------ -{- -Type Reconstruction is type inference done on heap closures. -The algorithm walks the heap generating a set of equations, which -are solved with syntactic unification. -A type reconstruction equation looks like: - - = - -The full equation set is generated by traversing all the subterms, starting -from a given term. - -The only difficult part is that newtypes are only found in the lhs of equations. -Right hand sides are missing them. We can either (a) drop them from the lhs, or -(b) reconstruct them in the rhs when possible. - -The function congruenceNewtypes takes a shot at (b) --} - - --- A (non-mutable) tau type containing --- existentially quantified tyvars. --- (since GHC type language currently does not support --- existentials, we leave these variables unquantified) -type RttiType = Type - --- An incomplete type as stored in GHCi: --- no polymorphism: no quantifiers & all tyvars are skolem. -type GhciType = Type - - --- The Type Reconstruction monad --------------------------------- -type TR a = TcM a - -runTR :: HscEnv -> TR a -> IO a -runTR hsc_env thing = do - mb_val <- runTR_maybe hsc_env thing - case mb_val of - Nothing -> error "unable to :print the term" - Just x -> return x - -runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) -runTR_maybe hsc_env thing_inside - = do { (_errs, res) <- initTcInteractive hsc_env thing_inside - ; return res } - --- | Term Reconstruction trace -traceTR :: SDoc -> TR () -traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti - - --- Semantically different to recoverM in TcRnMonad --- recoverM retains the errors in the first action, --- whereas recoverTc here does not -recoverTR :: TR a -> TR a -> TR a -recoverTR = tryTcDiscardingErrs - -trIO :: IO a -> TR a -trIO = liftTcM . liftIO - -liftTcM :: TcM a -> TR a -liftTcM = id - -newVar :: Kind -> TR TcType -newVar = liftTcM . newFlexiTyVarTy - -newOpenVar :: TR TcType -newOpenVar = liftTcM newOpenFlexiTyVarTy - -instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) --- Instantiate fresh mutable type variables from some TyVars --- This function preserves the print-name, which helps error messages -instTyVars tvs - = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs) - -type RttiInstantiation = [(TcTyVar, TyVar)] - -- Associates the typechecker-world meta type variables - -- (which are mutable and may be refined), to their - -- debugger-world RuntimeUnk counterparts. - -- If the TcTyVar has not been refined by the runtime type - -- elaboration, then we want to turn it back into the - -- original RuntimeUnk - --- | Returns the instantiated type scheme ty', and the --- mapping from new (instantiated) -to- old (skolem) type variables -instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) -instScheme (tvs, ty) - = do { (subst, tvs') <- instTyVars tvs - ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] - ; return (substTy subst ty, rtti_inst) } - -applyRevSubst :: RttiInstantiation -> TR () --- Apply the *reverse* substitution in-place to any un-filled-in --- meta tyvars. This recovers the original debugger-world variable --- unless it has been refined by new information from the heap -applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) - where - do_pair (tc_tv, rtti_tv) - = do { tc_ty <- zonkTcTyVar tc_tv - ; case tcGetTyVar_maybe tc_ty of - Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) - _ -> return () } - --- Adds a constraint of the form t1 == t2 --- t1 is expected to come from walking the heap --- t2 is expected to come from a datacon signature --- Before unification, congruenceNewtypes needs to --- do its magic. -addConstraint :: TcType -> TcType -> TR () -addConstraint actual expected = do - traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) - recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, - text "with", ppr expected]) $ - discardResult $ - captureConstraints $ - do { (ty1, ty2) <- congruenceNewtypes actual expected - ; unifyType Nothing ty1 ty2 } - -- TOMDO: what about the coercion? - -- we should consider family instances - - --- | Term reconstruction --- --- Given a pointer to a heap object (`HValue`) and its type, build a `Term` --- representation of the object. Subterms (objects in the payload) are also --- built up to the given `max_depth`. After `max_depth` any subterms will appear --- as `Suspension`s. Any thunks found while traversing the object will be forced --- based on `force` parameter. --- --- Types of terms will be refined based on constructors we find during term --- reconstruction. See `cvReconstructType` for an overview of how type --- reconstruction works. --- -cvObtainTerm - :: HscEnv - -> Int -- ^ How many times to recurse for subterms - -> Bool -- ^ Force thunks - -> RttiType -- ^ Type of the object to reconstruct - -> ForeignHValue -- ^ Object to reconstruct - -> IO Term -cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do - -- we quantify existential tyvars as universal, - -- as this is needed to be able to manipulate - -- them properly - let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty - sigma_old_ty = mkInvForAllTys old_tvs old_tau - traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) - term <- - if null old_tvs - then do - term <- go max_depth sigma_old_ty sigma_old_ty hval - term' <- zonkTerm term - return $ fixFunDictionaries $ expandNewtypes term' - else do - (old_ty', rev_subst) <- instScheme quant_old_ty - my_ty <- newOpenVar - when (check1 quant_old_ty) (traceTR (text "check1 passed") >> - addConstraint my_ty old_ty') - term <- go max_depth my_ty sigma_old_ty hval - new_ty <- zonkTcType (termType term) - if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty - then do - traceTR (text "check2 passed") - addConstraint new_ty old_ty' - applyRevSubst rev_subst - zterm' <- zonkTerm term - return ((fixFunDictionaries . expandNewtypes) zterm') - else do - traceTR (text "check2 failed" <+> parens - (ppr term <+> text "::" <+> ppr new_ty)) - -- we have unsound types. Replace constructor types in - -- subterms with tyvars - zterm' <- mapTermTypeM - (\ty -> case tcSplitTyConApp_maybe ty of - Just (tc, _:_) | tc /= funTyCon - -> newOpenVar - _ -> return ty) - term - zonkTerm zterm' - traceTR (text "Term reconstruction completed." $$ - text "Term obtained: " <> ppr term $$ - text "Type obtained: " <> ppr (termType term)) - return term - where - go :: Int -> Type -> Type -> ForeignHValue -> TcM Term - -- I believe that my_ty should not have any enclosing - -- foralls, nor any free RuntimeUnk skolems; - -- that is partly what the quantifyType stuff achieved - -- - -- [SPJ May 11] I don't understand the difference between my_ty and old_ty - - go 0 my_ty _old_ty a = do - traceTR (text "Gave up reconstructing a term after" <> - int max_depth <> text " steps") - clos <- trIO $ GHCi.getClosure hsc_env a - return (Suspension (tipe (info clos)) my_ty a Nothing) - go !max_depth my_ty old_ty a = do - let monomorphic = not(isTyVarTy my_ty) - -- This ^^^ is a convention. The ancestor tests for - -- monomorphism and passes a type instead of a tv - clos <- trIO $ GHCi.getClosure hsc_env a - case clos of --- Thunks we may want to force - t | isThunk t && force -> do - traceTR (text "Forcing a " <> text (show (fmap (const ()) t))) - liftIO $ GHCi.seqHValue hsc_env a - go (pred max_depth) my_ty old_ty a --- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If --- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as --- the suspension so that entering it in GHCi will enter the BLACKHOLE instead --- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic). - BlackholeClosure{indirectee=ind} -> do - traceTR (text "Following a BLACKHOLE") - ind_clos <- trIO (GHCi.getClosure hsc_env ind) - let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing) - case ind_clos of - -- TSO and BLOCKING_QUEUE cases - BlockingQueueClosure{} -> return_bh_value - OtherClosure info _ _ - | tipe info == TSO -> return_bh_value - UnsupportedClosure info - | tipe info == TSO -> return_bh_value - -- Otherwise follow the indirectee - -- (NOTE: This code will break if we support TSO in ghc-heap one day) - _ -> go max_depth my_ty old_ty ind --- We always follow indirections - IndClosure{indirectee=ind} -> do - traceTR (text "Following an indirection" ) - go max_depth my_ty old_ty ind --- We also follow references - MutVarClosure{var=contents} - | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty - -> do - -- Deal with the MutVar# primitive - -- It does not have a constructor at all, - -- so we simulate the following one - -- MutVar# :: contents_ty -> MutVar# s contents_ty - traceTR (text "Following a MutVar") - contents_tv <- newVar liftedTypeKind - MASSERT(isUnliftedType my_ty) - (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy - contents_ty (mkTyConApp tycon [world,contents_ty]) - addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty - x <- go (pred max_depth) contents_tv contents_ty contents - return (RefWrap my_ty x) - - -- The interesting case - ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do - traceTR (text "entering a constructor " <> ppr dArgs <+> - if monomorphic - then parens (text "already monomorphic: " <> ppr my_ty) - else Ppr.empty) - Right dcname <- liftIO $ constrClosToName hsc_env clos - (mb_dc, _) <- tryTc (tcLookupDataCon dcname) - case mb_dc of - Nothing -> do -- This can happen for private constructors compiled -O0 - -- where the .hi descriptor does not export them - -- In such case, we return a best approximation: - -- ignore the unpointed args, and recover the pointeds - -- This preserves laziness, and should be safe. - traceTR (text "Not constructor" <+> ppr dcname) - let dflags = hsc_dflags hsc_env - tag = showPpr dflags dcname - vars <- replicateM (length pArgs) - (newVar liftedTypeKind) - subTerms <- sequence $ zipWith (\x tv -> - go (pred max_depth) tv tv x) pArgs vars - return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) - Just dc -> do - traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) - subTtypes <- getDataConArgTys dc my_ty - subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes - return (Term my_ty (Right dc) a subTerms) - - -- This is to support printing of Integers. It's not a general - -- mechanism by any means; in particular we lose the size in - -- bytes of the array. - ArrWordsClosure{bytes=b, arrWords=ws} -> do - traceTR (text "ByteArray# closure, size " <> ppr b) - return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws]) - --- The otherwise case: can be a Thunk,AP,PAP,etc. - _ -> do - traceTR (text "Unknown closure:" <+> - text (show (fmap (const ()) clos))) - return (Suspension (tipe (info clos)) my_ty a Nothing) - - -- insert NewtypeWraps around newtypes - expandNewtypes = foldTerm idTermFold { fTerm = worker } where - worker ty dc hval tt - | Just (tc, args) <- tcSplitTyConApp_maybe ty - , isNewTyCon tc - , wrapped_type <- newTyConInstRhs tc args - , Just dc' <- tyConSingleDataCon_maybe tc - , t' <- worker wrapped_type dc hval tt - = NewtypeWrap ty (Right dc') t' - | otherwise = Term ty dc hval tt - - - -- Avoid returning types where predicates have been expanded to dictionaries. - fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where - worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n - | otherwise = Suspension ct ty hval n - -extractSubTerms :: (Type -> ForeignHValue -> TcM Term) - -> GenClosure ForeignHValue -> [Type] -> TcM [Term] -extractSubTerms recurse clos = liftM thdOf3 . go 0 0 - where - array = dataArgs clos - - go ptr_i arr_i [] = return (ptr_i, arr_i, []) - go ptr_i arr_i (ty:tys) - | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty - , isUnboxedTupleTyCon tc - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - = do (ptr_i, arr_i, terms0) <- - go ptr_i arr_i (dropRuntimeRepArgs elem_tys) - (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys - return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) - | otherwise - = case typePrimRepArgs ty of - [rep_ty] -> do - (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty - (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys - return (ptr_i, arr_i, term0 : terms1) - rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys - (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys - return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) - - go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, []) - go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do - tv <- newVar liftedTypeKind - (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i tv rep_ty - (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys - return (ptr_i, arr_i, term0 : terms1) - - go_rep ptr_i arr_i ty rep - | isGcPtrRep rep = do - t <- recurse ty $ (ptrArgs clos)!!ptr_i - return (ptr_i + 1, arr_i, t) - | otherwise = do - -- This is a bit involved since we allow packing multiple fields - -- within a single word. See also - -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding - dflags <- getDynFlags - let word_size = wORD_SIZE dflags - big_endian = wORDS_BIGENDIAN dflags - size_b = primRepSizeB dflags rep - -- Align the start offset (eg, 2-byte value should be 2-byte - -- aligned). But not more than to a word. The offset calculation - -- should be the same with the offset calculation in - -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding. - !aligned_idx = roundUpTo arr_i (min word_size size_b) - !new_arr_i = aligned_idx + size_b - ws | size_b < word_size = - [index size_b aligned_idx word_size big_endian] - | otherwise = - let (q, r) = size_b `quotRem` word_size - in ASSERT( r == 0 ) - [ array!!i - | o <- [0.. q - 1] - , let i = (aligned_idx `quot` word_size) + o - ] - return (ptr_i, new_arr_i, Prim ty ws) - - unboxedTupleTerm ty terms - = Term ty (Right (tupleDataCon Unboxed (length terms))) - (error "unboxedTupleTerm: no HValue for unboxed tuple") terms - - -- Extract a sub-word sized field from a word - index item_size_b index_b word_size big_endian = - (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes - where - mask :: Word - mask = case item_size_b of - 1 -> 0xFF - 2 -> 0xFFFF - 4 -> 0xFFFFFFFF - _ -> panic ("Weird byte-index: " ++ show index_b) - (q,r) = index_b `quotRem` word_size - word = array!!q - moveBytes = if big_endian - then word_size - (r + item_size_b) * 8 - else r * 8 - - --- | Fast, breadth-first Type reconstruction --- --- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually --- obtained in GHCi), try to reconstruct a more monomorphic type of the object. --- This is used for improving type information in debugger. For example, if we --- have a polymorphic function: --- --- sumNumList :: Num a => [a] -> a --- sumNumList [] = 0 --- sumNumList (x : xs) = x + sumList xs --- --- and add a breakpoint to it: --- --- ghci> break sumNumList --- ghci> sumNumList ([0 .. 9] :: [Int]) --- --- ghci shows us more precise types than just `a`s: --- --- Stopped in Main.sumNumList, debugger.hs:3:23-39 --- _result :: Int = _ --- x :: Int = 0 --- xs :: [Int] = _ --- -cvReconstructType - :: HscEnv - -> Int -- ^ How many times to recurse for subterms - -> GhciType -- ^ Type to refine - -> ForeignHValue -- ^ Refine the type using this value - -> IO (Maybe Type) -cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do - traceTR (text "RTTI started with initial type " <> ppr old_ty) - let sigma_old_ty@(old_tvs, _) = quantifyType old_ty - new_ty <- - if null old_tvs - then return old_ty - else do - (old_ty', rev_subst) <- instScheme sigma_old_ty - my_ty <- newOpenVar - when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> - addConstraint my_ty old_ty') - search (isMonomorphic `fmap` zonkTcType my_ty) - (\(ty,a) -> go ty a) - (Seq.singleton (my_ty, hval)) - max_depth - new_ty <- zonkTcType my_ty - if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty - then do - traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) - addConstraint my_ty old_ty' - applyRevSubst rev_subst - zonkRttiType new_ty - else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >> - return old_ty - traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) - return new_ty - where --- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () - search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> - int max_depth <> text " steps") - search stop expand l d = - case viewl l of - EmptyL -> return () - x :< xx -> unlessM stop $ do - new <- expand x - search stop expand (xx `mappend` Seq.fromList new) $! (pred d) - - -- returns unification tasks,since we are going to want a breadth-first search - go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)] - go my_ty a = do - traceTR (text "go" <+> ppr my_ty) - clos <- trIO $ GHCi.getClosure hsc_env a - case clos of - BlackholeClosure{indirectee=ind} -> go my_ty ind - IndClosure{indirectee=ind} -> go my_ty ind - MutVarClosure{var=contents} -> do - tv' <- newVar liftedTypeKind - world <- newVar liftedTypeKind - addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) - return [(tv', contents)] - ConstrClosure{ptrArgs=pArgs} -> do - Right dcname <- liftIO $ constrClosToName hsc_env clos - traceTR (text "Constr1" <+> ppr dcname) - (mb_dc, _) <- tryTc (tcLookupDataCon dcname) - case mb_dc of - Nothing-> do - forM pArgs $ \x -> do - tv <- newVar liftedTypeKind - return (tv, x) - - Just dc -> do - arg_tys <- getDataConArgTys dc my_ty - (_, itys) <- findPtrTyss 0 arg_tys - traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) - return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs - _ -> return [] - -findPtrTys :: Int -- Current pointer index - -> Type -- Type - -> TR (Int, [(Int, Type)]) -findPtrTys i ty - | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty - , isUnboxedTupleTyCon tc - = findPtrTyss i elem_tys - - | otherwise - = case typePrimRep ty of - [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)]) - | otherwise -> return (i, []) - prim_reps -> - foldM (\(i, extras) prim_rep -> - if isGcPtrRep prim_rep - then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) - else return (i, extras)) - (i, []) prim_reps - -findPtrTyss :: Int - -> [Type] - -> TR (Int, [(Int, Type)]) -findPtrTyss i tys = foldM step (i, []) tys - where step (i, discovered) elem_ty = do - (i, extras) <- findPtrTys i elem_ty - return (i, discovered ++ extras) - - --- Compute the difference between a base type and the type found by RTTI --- improveType --- The types can contain skolem type variables, which need to be treated as normal vars. --- In particular, we want them to unify with things. -improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst -improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty - -getDataConArgTys :: DataCon -> Type -> TR [Type] --- Given the result type ty of a constructor application (D a b c :: ty) --- return the types of the arguments. This is RTTI-land, so 'ty' might --- not be fully known. Moreover, the arg types might involve existentials; --- if so, make up fresh RTTI type variables for them --- --- I believe that con_app_ty should not have any enclosing foralls -getDataConArgTys dc con_app_ty - = do { let rep_con_app_ty = unwrapType con_app_ty - ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty - $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) - ; ASSERT( all isTyVar ex_tvs ) return () - -- ex_tvs can only be tyvars as data types in source - -- Haskell cannot mention covar yet (Aug 2018) - ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) - ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) - -- See Note [Constructor arg types] - ; let con_arg_tys = substTys subst (dataConRepArgTys dc) - ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) - ; return con_arg_tys } - where - univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyCoVars dc - -{- Note [Constructor arg types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a GADT (cf #7386) - data family D a b - data instance D [a] a where - MkT :: a -> D [a] (Maybe a) - ... - -In getDataConArgTys -* con_app_ty is the known type (from outside) of the constructor application, - say D [Int] Int - -* The data constructor MkT has a (representation) dataConTyCon = DList, - say where - data DList a where - MkT :: a -> DList a (Maybe a) - ... - -So the dataConTyCon of the data constructor, DList, differs from -the "outside" type, D. So we can't straightforwardly decompose the -"outside" type, and we end up in the "_" branch of the case. - -Then we match the dataConOrigResTy of the data constructor against the -outside type, hoping to get a substitution that tells how to instantiate -the *representation* type constructor. This looks a bit delicate to -me, but it seems to work. --} - --- Soundness checks --------------------- -{- -This is not formalized anywhere, so hold to your seats! -RTTI in the presence of newtypes can be a tricky and unsound business. - -Example: -~~~~~~~~~ -Suppose we are doing RTTI for a partially evaluated -closure t, the real type of which is t :: MkT Int, for - - newtype MkT a = MkT [Maybe a] - -The table below shows the results of RTTI and the improvement -calculated for different combinations of evaluatedness and :type t. -Regard the two first columns as input and the next two as output. - - # | t | :type t | rtti(t) | improv. | result - ------------------------------------------------------------ - 1 | _ | t b | a | none | OK - 2 | _ | MkT b | a | none | OK - 3 | _ | t Int | a | none | OK - - If t is not evaluated at *all*, we are safe. - - 4 | (_ : _) | t b | [a] | t = [] | UNSOUND - 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype) - 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND - - If a is a minimal whnf, we run into trouble. Note that - row 5 above does newtype enrichment on the ty_rtty parameter. - - 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND - | | | b = Maybe a| - - 8 | (Just _:_)| MkT b | MkT a | none | OK - 9 | (Just _:_)| t Int | FAIL | none | OK - - And if t is any more evaluated than whnf, we are still in trouble. - Because constraints are solved in top-down order, when we reach the - Maybe subterm what we got is already unsound. This explains why the - row 9 fails to complete. - - 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK - 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK - - We can undo the failure in row 9 by leaving out the constraint - coming from the type signature of t (i.e., the 2nd column). - Note that this type information is still used - to calculate the improvement. But we fail - when trying to calculate the improvement, as there is no unifier for - t Int = [Maybe a] or t Int = [Maybe Int]. - - - Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]] - - # | t | :type t | rtti(t) | improvement | result - --------------------------------------------------------------------- - 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] | - | | | | b = Maybe a | - -The checks: -~~~~~~~~~~~ -Consider a function obtainType that takes a value and a type and produces -the Term representation and a substitution (the improvement). -Assume an auxiliar rtti' function which does the actual job if recovering -the type, but which may produce a false type. - -In pseudocode: - - rtti' :: a -> IO Type -- Does not use the static type information - - obtainType :: a -> Type -> IO (Maybe (Term, Improvement)) - obtainType v old_ty = do - rtti_ty <- rtti' v - if monomorphic rtti_ty || (check rtti_ty old_ty) - then ... - else return Nothing - where check rtti_ty old_ty = check1 rtti_ty && - check2 rtti_ty old_ty - - check1 :: Type -> Bool - check2 :: Type -> Type -> Bool - -Now, if rtti' returns a monomorphic type, we are safe. -If that is not the case, then we consider two conditions. - - -1. To prevent the class of unsoundness displayed by - rows 4 and 7 in the example: no higher kind tyvars - accepted. - - check1 (t a) = NO - check1 (t Int) = NO - check1 ([] a) = YES - -2. To prevent the class of unsoundness shown by row 6, - the rtti type should be structurally more - defined than the old type we are comparing it to. - check2 :: NewType -> OldType -> Bool - check2 a _ = True - check2 [a] a = True - check2 [a] (t Int) = False - check2 [a] (t a) = False -- By check1 we never reach this equation - check2 [Int] a = True - check2 [Int] (t Int) = True - check2 [Maybe a] (t Int) = False - check2 [Maybe Int] (t Int) = True - check2 (Maybe [a]) (m [Int]) = False - check2 (Maybe [Int]) (m [Int]) = True - --} - -check1 :: QuantifiedType -> Bool -check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) - where - isHigherKind = not . null . fst . splitPiTys - -check2 :: QuantifiedType -> QuantifiedType -> Bool -check2 (_, rtti_ty) (_, old_ty) - | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty - = case () of - _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty - -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds) - _ | Just _ <- splitAppTy_maybe old_ty - -> isMonomorphicOnNonPhantomArgs rtti_ty - _ -> True - | otherwise = True - --- Dealing with newtypes --------------------------- -{- - congruenceNewtypes does a parallel fold over two Type values, - compensating for missing newtypes on both sides. - This is necessary because newtypes are not present - in runtime, but sometimes there is evidence available. - Evidence can come from DataCon signatures or - from compile-time type inference. - What we are doing here is an approximation - of unification modulo a set of equations derived - from newtype definitions. These equations should be the - same as the equality coercions generated for newtypes - in System Fc. The idea is to perform a sort of rewriting, - taking those equations as rules, before launching unification. - - The caller must ensure the following. - The 1st type (lhs) comes from the heap structure of ptrs,nptrs. - The 2nd type (rhs) comes from a DataCon type signature. - Rewriting (i.e. adding/removing a newtype wrapper) can happen - in both types, but in the rhs it is restricted to the result type. - - Note that it is very tricky to make this 'rewriting' - work with the unification implemented by TcM, where - substitutions are operationally inlined. The order in which - constraints are unified is vital as we cannot modify - anything that has been touched by a previous unification step. -Therefore, congruenceNewtypes is sound only if the types -recovered by the RTTI mechanism are unified Top-Down. --} -congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType) -congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') - where - go l r - -- TyVar lhs inductive case - | Just tv <- getTyVar_maybe l - , isTcTyVar tv - , isMetaTyVar tv - = recoverTR (return r) $ do - Indirect ty_v <- readMetaTyVar tv - traceTR $ fsep [text "(congruence) Following indirect tyvar:", - ppr tv, equals, ppr ty_v] - go ty_v r --- FunTy inductive case - | Just (l1,l2) <- splitFunTy_maybe l - , Just (r1,r2) <- splitFunTy_maybe r - = do r2' <- go l2 r2 - r1' <- go l1 r1 - return (mkVisFunTy r1' r2') --- TyconApp Inductive case; this is the interesting bit. - | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs - , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs - , tycon_l /= tycon_r - = upgrade tycon_l r - - | otherwise = return r - - where upgrade :: TyCon -> Type -> TR Type - upgrade new_tycon ty - | not (isNewTyCon new_tycon) = do - traceTR (text "(Upgrade) Not matching newtype evidence: " <> - ppr new_tycon <> text " for " <> ppr ty) - return ty - | otherwise = do - traceTR (text "(Upgrade) upgraded " <> ppr ty <> - text " in presence of newtype evidence " <> ppr new_tycon) - (_, vars) <- instTyVars (tyConTyVars new_tycon) - let ty' = mkTyConApp new_tycon (mkTyVarTys vars) - rep_ty = unwrapType ty' - _ <- liftTcM (unifyType Nothing ty rep_ty) - -- assumes that reptype doesn't ^^^^ touch tyconApp args - return ty' - - -zonkTerm :: Term -> TcM Term -zonkTerm = foldTermM (TermFoldM - { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> - return (Term ty' dc v tt) - , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty -> - return (Suspension ct ty v b) - , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> - return$ NewtypeWrap ty' dc t - , fRefWrapM = \ty t -> return RefWrap `ap` - zonkRttiType ty `ap` return t - , fPrimM = (return.) . Prim }) - -zonkRttiType :: TcType -> TcM Type --- Zonk the type, replacing any unbound Meta tyvars --- by RuntimeUnk skolems, safely out of Meta-tyvar-land -zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi - ; zonkTcTypeToTypeX ze ty } - --------------------------------------------------------------------------------- --- Restore Class predicates out of a representation type -dictsView :: Type -> Type -dictsView ty = ty - - --- Use only for RTTI types -isMonomorphic :: RttiType -> Bool -isMonomorphic ty = noExistentials && noUniversals - where (tvs, _, ty') = tcSplitSigmaTy ty - noExistentials = noFreeVarsOfType ty' - noUniversals = null tvs - --- Use only for RTTI types -isMonomorphicOnNonPhantomArgs :: RttiType -> Bool -isMonomorphicOnNonPhantomArgs ty - | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty) - , phantom_vars <- tyConPhantomTyVars tc - , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args - , tyv `notElem` phantom_vars] - = all isMonomorphicOnNonPhantomArgs concrete_args - | Just (ty1, ty2) <- splitFunTy_maybe ty - = all isMonomorphicOnNonPhantomArgs [ty1,ty2] - | otherwise = isMonomorphic ty - -tyConPhantomTyVars :: TyCon -> [TyVar] -tyConPhantomTyVars tc - | isAlgTyCon tc - , Just dcs <- tyConDataCons_maybe tc - , dc_vars <- concatMap dataConUnivTyVars dcs - = tyConTyVars tc \\ dc_vars -tyConPhantomTyVars _ = [] - -type QuantifiedType = ([TyVar], Type) - -- Make the free type variables explicit - -- The returned Type should have no top-level foralls (I believe) - -quantifyType :: Type -> QuantifiedType --- Generalize the type: find all free and forall'd tyvars --- and return them, together with the type inside, which --- should not be a forall type. --- --- Thus (quantifyType (forall a. a->[b])) --- returns ([a,b], a -> [b]) - -quantifyType ty = ( filter isTyVar $ - tyCoVarsOfTypeWellScoped rho - , rho) - where - (_tvs, rho) = tcSplitForAllTys ty diff --git a/ghci/keepCAFsForGHCi.c b/ghci/keepCAFsForGHCi.c deleted file mode 100644 --- a/ghci/keepCAFsForGHCi.c +++ /dev/null @@ -1,15 +0,0 @@ -#include - -// This file is only included in the dynamic library. -// It contains an __attribute__((constructor)) function (run prior to main()) -// which sets the keepCAFs flag in the RTS, before any Haskell code is run. -// This is required so that GHCi can use dynamic libraries instead of HSxyz.o -// files. - -static void keepCAFsForGHCi(void) __attribute__((constructor)); - -static void keepCAFsForGHCi(void) -{ - keepCAFs = 1; -} - diff --git a/hieFile/HieAst.hs b/hieFile/HieAst.hs deleted file mode 100644 --- a/hieFile/HieAst.hs +++ /dev/null @@ -1,1923 +0,0 @@ -{- -Main functions for .hie file generation --} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -module HieAst ( mkHieFile ) where - -import GhcPrelude - -import Avail ( Avails ) -import Bag ( Bag, bagToList ) -import BasicTypes -import BooleanFormula -import Class ( FunDep ) -import CoreUtils ( exprType ) -import ConLike ( conLikeName ) -import Desugar ( deSugarExpr ) -import FieldLabel -import GHC.Hs -import HscTypes -import Module ( ModuleName, ml_hs_file ) -import MonadUtils ( concatMapM, liftIO ) -import Name ( Name, nameSrcSpan, setNameLoc ) -import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) -import SrcLoc -import TcHsSyn ( hsLitType, hsPatType ) -import Type ( mkVisFunTys, Type ) -import TysWiredIn ( mkListTy, mkSumTy ) -import Var ( Id, Var, setVarName, varName, varType ) -import TcRnTypes -import MkIface ( mkIfaceExports ) -import Panic - -import HieTypes -import HieUtils - -import qualified Data.Array as A -import qualified Data.ByteString as BS -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Data ( Data, Typeable ) -import Data.List ( foldl1' ) -import Data.Maybe ( listToMaybe ) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class ( lift ) - -{- Note [Updating HieAst for changes in the GHC AST] - -When updating the code in this file for changes in the GHC AST, you -need to pay attention to the following things: - -1) Symbols (Names/Vars/Modules) in the following categories: - - a) Symbols that appear in the source file that directly correspond to - something the user typed - b) Symbols that don't appear in the source, but should be in some sense - "visible" to a user, particularly via IDE tooling or the like. This - includes things like the names introduced by RecordWildcards (We record - all the names introduced by a (..) in HIE files), and will include implicit - parameters and evidence variables after one of my pending MRs lands. - -2) Subtrees that may contain such symbols, or correspond to a SrcSpan in - the file. This includes all `Located` things - -For 1), you need to call `toHie` for one of the following instances - -instance ToHie (Context (Located Name)) where ... -instance ToHie (Context (Located Var)) where ... -instance ToHie (IEContext (Located ModuleName)) where ... - -`Context` is a data type that looks like: - -data Context a = C ContextInfo a -- Used for names and bindings - -`ContextInfo` is defined in `HieTypes`, and looks like - -data ContextInfo - = Use -- ^ regular variable - | MatchBind - | IEThing IEType -- ^ import/export - | TyDecl - -- | Value binding - | ValBind - BindType -- ^ whether or not the binding is in an instance - Scope -- ^ scope over which the value is bound - (Maybe Span) -- ^ span of entire binding - ... - -It is used to annotate symbols in the .hie files with some extra information on -the context in which they occur and should be fairly self explanatory. You need -to select one that looks appropriate for the symbol usage. In very rare cases, -you might need to extend this sum type if none of the cases seem appropriate. - -So, given a `Located Name` that is just being "used", and not defined at a -particular location, you would do the following: - - toHie $ C Use located_name - -If you select one that corresponds to a binding site, you will need to -provide a `Scope` and a `Span` for your binding. Both of these are basically -`SrcSpans`. - -The `SrcSpan` in the `Scope` is supposed to span over the part of the source -where the symbol can be legally allowed to occur. For more details on how to -calculate this, see Note [Capturing Scopes and other non local information] -in HieAst. - -The binding `Span` is supposed to be the span of the entire binding for -the name. - -For a function definition `foo`: - -foo x = x + y - where y = x^2 - -The binding `Span` is the span of the entire function definition from `foo x` -to `x^2`. For a class definition, this is the span of the entire class, and -so on. If this isn't well defined for your bit of syntax (like a variable -bound by a lambda), then you can just supply a `Nothing` - -There is a test that checks that all symbols in the resulting HIE file -occur inside their stated `Scope`. This can be turned on by passing the --fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the -.hie file. - -You may also want to provide a test in testsuite/test/hiefile that includes -a file containing your new construction, and tests that the calculated scope -is valid (by using -fvalidate-ide-info) - -For subtrees in the AST that may contain symbols, the procedure is fairly -straightforward. If you are extending the GHC AST, you will need to provide a -`ToHie` instance for any new types you may have introduced in the AST. - -Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): - - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - ... - HsApp _ a b -> - [ toHie a - , toHie b - ] - -If your subtree is `Located` or has a `SrcSpan` available, the output list -should contain a HieAst `Node` corresponding to the subtree. You can use -either `makeNode` or `getTypeNode` for this purpose, depending on whether it -makes sense to assign a `Type` to the subtree. After this, you just need -to concatenate the result of calling `toHie` on all subexpressions and -appropriately annotated symbols contained in the subtree. - -The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed -to work for both the renamed and typechecked source. `getTypeNode` is from -the `HasType` class defined in this file, and it has different instances -for `GhcTc` and `GhcRn` that allow it to access the type of the expression -when given a typechecked AST: - -class Data a => HasType a where - getTypeNode :: a -> HieM [HieAST Type] -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = ... -- Actually get the type for this expression -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type - -If your subtree doesn't have a span available, you can omit the `makeNode` -call and just recurse directly in to the subexpressions. - --} - --- These synonyms match those defined in main/GHC.hs -type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] - , Maybe [(LIE GhcRn, Avails)] - , Maybe LHsDocString ) -type TypecheckedSource = LHsBinds GhcTc - - -{- Note [Name Remapping] -The Typechecker introduces new names for mono names in AbsBinds. -We don't care about the distinction between mono and poly bindings, -so we replace all occurrences of the mono name with the poly name. --} -newtype HieState = HieState - { name_remapping :: NameEnv Id - } - -initState :: HieState -initState = HieState emptyNameEnv - -class ModifyState a where -- See Note [Name Remapping] - addSubstitution :: a -> a -> HieState -> HieState - -instance ModifyState Name where - addSubstitution _ _ hs = hs - -instance ModifyState Id where - addSubstitution mono poly hs = - hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} - -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState -modifyState = foldr go id - where - go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f - go _ f = f - -type HieM = ReaderT HieState Hsc - --- | Construct an 'HieFile' from the outputs of the typechecker. -mkHieFile :: ModSummary - -> TcGblEnv - -> RenamedSource -> Hsc HieFile -mkHieFile ms ts rs = do - let tc_binds = tcg_binds ts - (asts', arr) <- getCompressedAsts tc_binds rs - let Just src_file = ml_hs_file $ ms_location ms - src <- liftIO $ BS.readFile src_file - return $ HieFile - { hie_hs_file = src_file - , hie_module = ms_mod ms - , hie_types = arr - , hie_asts = asts' - -- mkIfaceExports sorts the AvailInfos for stability - , hie_exports = mkIfaceExports (tcg_exports ts) - , hie_hs_src = src - } - -getCompressedAsts :: TypecheckedSource -> RenamedSource - -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) -getCompressedAsts ts rs = do - asts <- enrichHie ts rs - return $ compressTypes asts - -enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type) -enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do - tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts - rasts <- processGrp hsGrp - imps <- toHie $ filter (not . ideclImplicit . unLoc) imports - exps <- toHie $ fmap (map $ IEC Export . fst) exports - let spanFile children = case children of - [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1) - _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) - (realSrcSpanEnd $ nodeSpan $ last children) - - modulify xs = - Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs - - asts = HieASTs - $ resolveTyVarScopes - $ M.map (modulify . mergeSortAsts) - $ M.fromListWith (++) - $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts - - flat_asts = concat - [ tasts - , rasts - , imps - , exps - ] - return asts - where - processGrp grp = concatM - [ toHie $ fmap (RS ModuleScope ) hs_valds grp - , toHie $ hs_splcds grp - , toHie $ hs_tyclds grp - , toHie $ hs_derivds grp - , toHie $ hs_fixds grp - , toHie $ hs_defds grp - , toHie $ hs_fords grp - , toHie $ hs_warnds grp - , toHie $ hs_annds grp - , toHie $ hs_ruleds grp - ] - -getRealSpan :: SrcSpan -> Maybe Span -getRealSpan (RealSrcSpan sp) = Just sp -getRealSpan _ = Nothing - -grhss_span :: GRHSs p body -> SrcSpan -grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) -grhss_span (XGRHSs _) = panic "XGRHS has no span" - -bindingsOnly :: [Context Name] -> [HieAST a] -bindingsOnly [] = [] -bindingsOnly (C c n : xs) = case nameSrcSpan n of - RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs - where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) - info = mempty{identInfo = S.singleton c} - _ -> bindingsOnly xs - -concatM :: Monad m => [m [a]] -> m [a] -concatM xs = concat <$> sequence xs - -{- Note [Capturing Scopes and other non local information] -toHie is a local tranformation, but scopes of bindings cannot be known locally, -hence we have to push the relevant info down into the binding nodes. -We use the following types (*Context and *Scoped) to wrap things and -carry the required info -(Maybe Span) always carries the span of the entire binding, including rhs --} -data Context a = C ContextInfo a -- Used for names and bindings - -data RContext a = RC RecFieldContext a -data RFContext a = RFC RecFieldContext (Maybe Span) a --- ^ context for record fields - -data IEContext a = IEC IEType a --- ^ context for imports/exports - -data BindContext a = BC BindType Scope a --- ^ context for imports/exports - -data PatSynFieldContext a = PSC (Maybe Span) a --- ^ context for pattern synonym fields. - -data SigContext a = SC SigInfo a --- ^ context for type signatures - -data SigInfo = SI SigType (Maybe Span) - -data SigType = BindSig | ClassSig | InstSig - -data RScoped a = RS Scope a --- ^ Scope spans over everything to the right of a, (mostly) not --- including a itself --- (Includes a in a few special cases like recursive do bindings) or --- let/where bindings - --- | Pattern scope -data PScoped a = PS (Maybe Span) - Scope -- ^ use site of the pattern - Scope -- ^ pattern to the right of a, not including a - a - deriving (Typeable, Data) -- Pattern Scope - -{- Note [TyVar Scopes] -Due to -XScopedTypeVariables, type variables can be in scope quite far from -their original binding. We resolve the scope of these type variables -in a separate pass --} -data TScoped a = TS TyVarScope a -- TyVarScope - -data TVScoped a = TVS TyVarScope Scope a -- TyVarScope --- ^ First scope remains constant --- Second scope is used to build up the scope of a tyvar over --- things to its right, ala RScoped - --- | Each element scopes over the elements to the right -listScopes :: Scope -> [Located a] -> [RScoped (Located a)] -listScopes _ [] = [] -listScopes rhsScope [pat] = [RS rhsScope pat] -listScopes rhsScope (pat : pats) = RS sc pat : pats' - where - pats'@((RS scope p):_) = listScopes rhsScope pats - sc = combineScopes scope $ mkScope $ getLoc p - --- | 'listScopes' specialised to 'PScoped' things -patScopes - :: Maybe Span - -> Scope - -> Scope - -> [LPat (GhcPass p)] - -> [PScoped (LPat (GhcPass p))] -patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $ - listScopes patScope (map dL xs) - --- | 'listScopes' specialised to 'TVScoped' things -tvScopes - :: TyVarScope - -> Scope - -> [LHsTyVarBndr a] - -> [TVScoped (LHsTyVarBndr a)] -tvScopes tvScope rhsScope xs = - map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs - -{- Note [Scoping Rules for SigPat] -Explicitly quantified variables in pattern type signatures are not -brought into scope in the rhs, but implicitly quantified variables -are (HsWC and HsIB). -This is unlike other signatures, where explicitly quantified variables -are brought into the RHS Scope -For example -foo :: forall a. ...; -foo = ... -- a is in scope here - -bar (x :: forall a. a -> a) = ... -- a is not in scope here --- ^ a is in scope here (pattern body) - -bax (x :: a) = ... -- a is in scope here -Because of HsWC and HsIB pass on their scope to their children -we must wrap the LHsType in pattern signatures in a -Shielded explictly, so that the HsWC/HsIB scope is not passed -on the the LHsType --} - -data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead - -type family ProtectedSig a where - ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs - GhcRn - (Shielded (LHsType GhcRn))) - ProtectedSig GhcTc = NoExtField - -class ProtectSig a where - protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a - -instance (HasLoc a) => HasLoc (Shielded a) where - loc (SH _ a) = loc a - -instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where - toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) - -instance ProtectSig GhcTc where - protectSig _ _ = noExtField - -instance ProtectSig GhcRn where - protectSig sc (HsWC a (HsIB b sig)) = - HsWC a (HsIB b (SH sc sig)) - protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec - protectSig _ (XHsWildCardBndrs nec) = noExtCon nec - -class HasLoc a where - -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can - -- know what their implicit bindings are scoping over - loc :: a -> SrcSpan - -instance HasLoc thing => HasLoc (TScoped thing) where - loc (TS _ a) = loc a - -instance HasLoc thing => HasLoc (PScoped thing) where - loc (PS _ _ _ a) = loc a - -instance HasLoc (LHsQTyVars GhcRn) where - loc (HsQTvs _ vs) = loc vs - loc _ = noSrcSpan - -instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where - loc (HsIB _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where - loc (HsWC _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc (Located a) where - loc (L l _) = l - -instance HasLoc a => HasLoc [a] where - loc [] = noSrcSpan - loc xs = foldl1' combineSrcSpans $ map loc xs - -instance HasLoc a => HasLoc (FamEqn s a) where - loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] - loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans - [loc a, loc tvs, loc b, loc c] - loc _ = noSrcSpan -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where - loc (HsValArg tm) = loc tm - loc (HsTypeArg _ ty) = loc ty - loc (HsArgPar sp) = sp - -instance HasLoc (HsDataDefn GhcRn) where - loc def@(HsDataDefn{}) = loc $ dd_cons def - -- Only used for data family instances, so we only need rhs - -- Most probably the rest will be unhelpful anyway - loc _ = noSrcSpan - -{- Note [Real DataCon Name] -The typechecker subtitutes the conLikeWrapId for the name, but we don't want -this showing up in the hieFile, so we replace the name in the Id with the -original datacon name -See also Note [Data Constructor Naming] --} -class HasRealDataConName p where - getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) - -instance HasRealDataConName GhcRn where - getRealDataCon _ n = n -instance HasRealDataConName GhcTc where - getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = - L sp (setVarName var (conLikeName con)) - --- | The main worker class --- See Note [Updating HieAst for changes in the GHC AST] for more information --- on how to add/modify instances for this. -class ToHie a where - toHie :: a -> HieM [HieAST Type] - --- | Used to collect type info -class Data a => HasType a where - getTypeNode :: a -> HieM [HieAST Type] - -instance (ToHie a) => ToHie [a] where - toHie = concatMapM toHie - -instance (ToHie a) => ToHie (Bag a) where - toHie = toHie . bagToList - -instance (ToHie a) => ToHie (Maybe a) where - toHie = maybe (pure []) toHie - -instance ToHie (Context (Located NoExtField)) where - toHie _ = pure [] - -instance ToHie (TScoped NoExtField) where - toHie _ = pure [] - -instance ToHie (IEContext (Located ModuleName)) where - toHie (IEC c (L (RealSrcSpan span) mname)) = - pure $ [Node (NodeInfo S.empty [] idents) span []] - where details = mempty{identInfo = S.singleton (IEThing c)} - idents = M.singleton (Left mname) details - toHie _ = pure [] - -instance ToHie (Context (Located Var)) where - toHie c = case c of - C context (L (RealSrcSpan span) name') - -> do - m <- asks name_remapping - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - pure - [Node - (NodeInfo S.empty [] $ - M.singleton (Right $ varName name) - (IdentifierDetails (Just $ varType name') - (S.singleton context))) - span - []] - _ -> pure [] - -instance ToHie (Context (Located Name)) where - toHie c = case c of - C context (L (RealSrcSpan span) name') -> do - m <- asks name_remapping - let name = case lookupNameEnv m name' of - Just var -> varName var - Nothing -> name' - pure - [Node - (NodeInfo S.empty [] $ - M.singleton (Right name) - (IdentifierDetails Nothing - (S.singleton context))) - span - []] - _ -> pure [] - --- | Dummy instances - never called -instance ToHie (TScoped (LHsSigWcType GhcTc)) where - toHie _ = pure [] -instance ToHie (TScoped (LHsWcType GhcTc)) where - toHie _ = pure [] -instance ToHie (SigContext (LSig GhcTc)) where - toHie _ = pure [] -instance ToHie (TScoped Type) where - toHie _ = pure [] - -instance HasType (LHsBind GhcRn) where - getTypeNode (L spn bind) = makeNode bind spn - -instance HasType (LHsBind GhcTc) where - getTypeNode (L spn bind) = case bind of - FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) - _ -> makeNode bind spn - -instance HasType (Located (Pat GhcRn)) where - getTypeNode (dL -> L spn pat) = makeNode pat spn - -instance HasType (Located (Pat GhcTc)) where - getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat) - -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn - --- | This instance tries to construct 'HieAST' nodes which include the type of --- the expression. It is not yet possible to do this efficiently for all --- expression forms, so we skip filling in the type for those inputs. --- --- 'HsApp', for example, doesn't have any type information available directly on --- the node. Our next recourse would be to desugar it into a 'CoreExpr' then --- query the type of that. Yet both the desugaring call and the type query both --- involve recursive calls to the function and argument! This is particularly --- problematic when you realize that the HIE traversal will eventually visit --- those nodes too and ask for their types again. --- --- Since the above is quite costly, we just skip cases where computing the --- expression's type is going to be expensive. --- --- See #16233 -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = lift $ - -- Some expression forms have their type immediately available - let tyOpt = case e' of - HsLit _ l -> Just (hsLitType l) - HsOverLit _ o -> Just (overLitType o) - - HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - - ExplicitList ty _ _ -> Just (mkListTy ty) - ExplicitSum ty _ _ _ -> Just (mkSumTy ty) - HsDo ty _ _ -> Just ty - HsMultiIf ty _ -> Just ty - - _ -> Nothing - - in - case tyOpt of - Just t -> makeTypeNode e' spn t - Nothing - | skipDesugaring e' -> fallback - | otherwise -> do - hs_env <- Hsc $ \e w -> return (e,w) - (_,mbe) <- liftIO $ deSugarExpr hs_env e - maybe fallback (makeTypeNode e' spn . exprType) mbe - where - fallback = makeNode e' spn - - matchGroupType :: MatchGroupTc -> Type - matchGroupType (MatchGroupTc args res) = mkVisFunTys args res - - -- | Skip desugaring of these expressions for performance reasons. - -- - -- See impact on Haddock output (esp. missing type annotations or links) - -- before marking more things here as 'False'. See impact on Haddock - -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr a -> Bool - skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - HsWrap{} -> False - _ -> True - -instance ( ToHie (Context (Located (IdP a))) - , ToHie (MatchGroup a (LHsExpr a)) - , ToHie (PScoped (LPat a)) - , ToHie (GRHSs a (LHsExpr a)) - , ToHie (LHsExpr a) - , ToHie (Located (PatSynBind a a)) - , HasType (LHsBind a) - , ModifyState (IdP a) - , Data (HsBind a) - ) => ToHie (BindContext (LHsBind a)) where - toHie (BC context scope b@(L span bind)) = - concatM $ getTypeNode b : case bind of - FunBind{fun_id = name, fun_matches = matches} -> - [ toHie $ C (ValBind context scope $ getRealSpan span) name - , toHie matches - ] - PatBind{pat_lhs = lhs, pat_rhs = rhs} -> - [ toHie $ PS (getRealSpan span) scope NoScope lhs - , toHie rhs - ] - VarBind{var_rhs = expr} -> - [ toHie expr - ] - AbsBinds{abs_exports = xs, abs_binds = binds} -> - [ local (modifyState xs) $ -- Note [Name Remapping] - toHie $ fmap (BC context scope) binds - ] - PatSynBind _ psb -> - [ toHie $ L span psb -- PatSynBinds only occur at the top level - ] - XHsBindsLR _ -> [] - -instance ( ToHie (LMatch a body) - ) => ToHie (MatchGroup a body) where - toHie mg = concatM $ case mg of - MG{ mg_alts = (L span alts) , mg_origin = FromSource } -> - [ pure $ locOnly span - , toHie alts - ] - MG{} -> [] - XMatchGroup _ -> [] - -instance ( ToHie (Context (Located (IdP a))) - , ToHie (PScoped (LPat a)) - , ToHie (HsPatSynDir a) - ) => ToHie (Located (PatSynBind a a)) where - toHie (L sp psb) = concatM $ case psb of - PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> - [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var - , toHie $ toBind dets - , toHie $ PS Nothing lhsScope NoScope pat - , toHie dir - ] - where - lhsScope = combineScopes varScope detScope - varScope = mkLScope var - detScope = case dets of - (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args - (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) - (RecCon r) -> foldr go NoScope r - go (RecordPatSynField a b) c = combineScopes c - $ combineScopes (mkLScope a) (mkLScope b) - detSpan = case detScope of - LocalScope a -> Just a - _ -> Nothing - toBind (PrefixCon args) = PrefixCon $ map (C Use) args - toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) - toBind (RecCon r) = RecCon $ map (PSC detSpan) r - XPatSynBind _ -> [] - -instance ( ToHie (MatchGroup a (LHsExpr a)) - ) => ToHie (HsPatSynDir a) where - toHie dir = case dir of - ExplicitBidirectional mg -> toHie mg - _ -> pure [] - -instance ( a ~ GhcPass p - , ToHie body - , ToHie (HsMatchContext (NameOrRdrName (IdP a))) - , ToHie (PScoped (LPat a)) - , ToHie (GRHSs a body) - , Data (Match a body) - ) => ToHie (LMatch (GhcPass p) body) where - toHie (L span m ) = concatM $ makeNode m span : case m of - Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> - [ toHie mctx - , let rhsScope = mkScope $ grhss_span grhss - in toHie $ patScopes Nothing rhsScope NoScope pats - , toHie grhss - ] - XMatch _ -> [] - -instance ( ToHie (Context (Located a)) - ) => ToHie (HsMatchContext a) where - toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name - toHie (StmtCtxt a) = toHie a - toHie _ = pure [] - -instance ( ToHie (HsMatchContext a) - ) => ToHie (HsStmtContext a) where - toHie (PatGuard a) = toHie a - toHie (ParStmtCtxt a) = toHie a - toHie (TransStmtCtxt a) = toHie a - toHie _ = pure [] - -instance ( a ~ GhcPass p - , ToHie (Context (Located (IdP a))) - , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) - , ToHie (LHsExpr a) - , ToHie (TScoped (LHsSigWcType a)) - , ProtectSig a - , ToHie (TScoped (ProtectedSig a)) - , HasType (LPat a) - , Data (HsSplice a) - ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where - toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) = - concatM $ getTypeNode lpat : case opat of - WildPat _ -> - [] - VarPat _ lname -> - [ toHie $ C (PatternBind scope pscope rsp) lname - ] - LazyPat _ p -> - [ toHie $ PS rsp scope pscope p - ] - AsPat _ lname pat -> - [ toHie $ C (PatternBind scope - (combineScopes (mkLScope (dL pat)) pscope) - rsp) - lname - , toHie $ PS rsp scope pscope pat - ] - ParPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - BangPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - ListPat _ pats -> - [ toHie $ patScopes rsp scope pscope pats - ] - TuplePat _ pats _ -> - [ toHie $ patScopes rsp scope pscope pats - ] - SumPat _ pat _ _ -> - [ toHie $ PS rsp scope pscope pat - ] - ConPatIn c dets -> - [ toHie $ C Use c - , toHie $ contextify dets - ] - ConPatOut {pat_con = con, pat_args = dets}-> - [ toHie $ C Use $ fmap conLikeName con - , toHie $ contextify dets - ] - ViewPat _ expr pat -> - [ toHie expr - , toHie $ PS rsp scope pscope pat - ] - SplicePat _ sp -> - [ toHie $ L ospan sp - ] - LitPat _ _ -> - [] - NPat _ _ _ _ -> - [] - NPlusKPat _ n _ _ _ _ -> - [ toHie $ C (PatternBind scope pscope rsp) n - ] - SigPat _ pat sig -> - [ toHie $ PS rsp scope pscope pat - , let cscope = mkLScope (dL pat) in - toHie $ TS (ResolvedScopes [cscope, scope, pscope]) - (protectSig @a cscope sig) - -- See Note [Scoping Rules for SigPat] - ] - CoPat _ _ _ _ -> - [] - XPat _ -> [] - where - contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args - contextify (InfixCon a b) = InfixCon a' b' - where [a', b'] = patScopes rsp scope pscope [a,b] - contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r - contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a - where - go (RS fscope (L spn (HsRecField lbl pat pun))) = - L spn $ HsRecField lbl (PS rsp scope fscope pat) pun - scoped_fds = listScopes pscope fds - -instance ( ToHie body - , ToHie (LGRHS a body) - , ToHie (RScoped (LHsLocalBinds a)) - ) => ToHie (GRHSs a body) where - toHie grhs = concatM $ case grhs of - GRHSs _ grhss binds -> - [ toHie grhss - , toHie $ RS (mkScope $ grhss_span grhs) binds - ] - XGRHSs _ -> [] - -instance ( ToHie (Located body) - , ToHie (RScoped (GuardLStmt a)) - , Data (GRHS a (Located body)) - ) => ToHie (LGRHS a (Located body)) where - toHie (L span g) = concatM $ makeNode g span : case g of - GRHS _ guards body -> - [ toHie $ listScopes (mkLScope body) guards - , toHie body - ] - XGRHS _ -> [] - -instance ( a ~ GhcPass p - , ToHie (Context (Located (IdP a))) - , HasType (LHsExpr a) - , ToHie (PScoped (LPat a)) - , ToHie (MatchGroup a (LHsExpr a)) - , ToHie (LGRHS a (LHsExpr a)) - , ToHie (RContext (HsRecordBinds a)) - , ToHie (RFContext (Located (AmbiguousFieldOcc a))) - , ToHie (ArithSeqInfo a) - , ToHie (LHsCmdTop a) - , ToHie (RScoped (GuardLStmt a)) - , ToHie (RScoped (LHsLocalBinds a)) - , ToHie (TScoped (LHsWcType (NoGhcTc a))) - , ToHie (TScoped (LHsSigWcType (NoGhcTc a))) - , Data (HsExpr a) - , Data (HsSplice a) - , Data (HsTupArg a) - , Data (AmbiguousFieldOcc a) - , (HasRealDataConName a) - ) => ToHie (LHsExpr (GhcPass p)) where - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsUnboundVar _ _ -> - [] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - HsRecFld _ fld -> - [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) - ] - HsOverLabel _ _ _ -> [] - HsIPVar _ _ -> [] - HsOverLit _ _ -> [] - HsLit _ _ -> [] - HsLam _ mg -> - [ toHie mg - ] - HsLamCase _ mg -> - [ toHie mg - ] - HsApp _ a b -> - [ toHie a - , toHie b - ] - HsAppType _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes []) sig - ] - OpApp _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - NegApp _ a _ -> - [ toHie a - ] - HsPar _ a -> - [ toHie a - ] - SectionL _ a b -> - [ toHie a - , toHie b - ] - SectionR _ a b -> - [ toHie a - , toHie b - ] - ExplicitTuple _ args _ -> - [ toHie args - ] - ExplicitSum _ _ _ expr -> - [ toHie expr - ] - HsCase _ expr matches -> - [ toHie expr - , toHie matches - ] - HsIf _ _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsMultiIf _ grhss -> - [ toHie grhss - ] - HsLet _ binds expr -> - [ toHie $ RS (mkLScope expr) binds - , toHie expr - ] - HsDo _ _ (L ispan stmts) -> - [ pure $ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - ExplicitList _ _ exprs -> - [ toHie exprs - ] - RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @a mrealcon name) - -- See Note [Real DataCon Name] - , toHie $ RC RecFieldAssign $ binds - ] - RecordUpd {rupd_expr = expr, rupd_flds = upds}-> - [ toHie expr - , toHie $ map (RC RecFieldAssign) upds - ] - ExprWithTySig _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes [mkLScope expr]) sig - ] - ArithSeq _ _ info -> - [ toHie info - ] - HsSCC _ _ _ expr -> - [ toHie expr - ] - HsCoreAnn _ _ _ expr -> - [ toHie expr - ] - HsProc _ pat cmdtop -> - [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat - , toHie cmdtop - ] - HsStatic _ expr -> - [ toHie expr - ] - HsTick _ _ expr -> - [ toHie expr - ] - HsBinTick _ _ _ expr -> - [ toHie expr - ] - HsTickPragma _ _ _ _ expr -> - [ toHie expr - ] - HsWrap _ _ a -> - [ toHie $ L mspan a - ] - HsBracket _ b -> - [ toHie b - ] - HsRnBracketOut _ b p -> - [ toHie b - , toHie p - ] - HsTcBracketOut _ b p -> - [ toHie b - , toHie p - ] - HsSpliceE _ x -> - [ toHie $ L mspan x - ] - XExpr _ -> [] - -instance ( a ~ GhcPass p - , ToHie (LHsExpr a) - , Data (HsTupArg a) - ) => ToHie (LHsTupArg (GhcPass p)) where - toHie (L span arg) = concatM $ makeNode arg span : case arg of - Present _ expr -> - [ toHie expr - ] - Missing _ -> [] - XTupArg _ -> [] - -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (LHsExpr a) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (LHsLocalBinds a)) - , ToHie (RScoped (ApplicativeArg a)) - , ToHie (Located body) - , Data (StmtLR a a (Located body)) - , Data (StmtLR a a (Located (HsExpr a))) - ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where - toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of - LastStmt _ body _ _ -> - [ toHie body - ] - BindStmt _ pat body _ _ -> - [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat - , toHie body - ] - ApplicativeStmt _ stmts _ -> - [ concatMapM (toHie . RS scope . snd) stmts - ] - BodyStmt _ body _ _ -> - [ toHie body - ] - LetStmt _ binds -> - [ toHie $ RS scope binds - ] - ParStmt _ parstmts _ _ -> - [ concatMapM (\(ParStmtBlock _ stmts _ _) -> - toHie $ listScopes NoScope stmts) - parstmts - ] - TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> - [ toHie $ listScopes scope stmts - , toHie using - , toHie by - ] - RecStmt {recS_stmts = stmts} -> - [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts - ] - XStmtLR _ -> [] - -instance ( ToHie (LHsExpr a) - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (HsLocalBinds a) - ) => ToHie (RScoped (LHsLocalBinds a)) where - toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of - EmptyLocalBinds _ -> [] - HsIPBinds _ _ -> [] - HsValBinds _ valBinds -> - [ toHie $ RS (combineScopes scope $ mkScope sp) - valBinds - ] - XHsLocalBindsLR _ -> [] - -instance ( ToHie (BindContext (LHsBind a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (XXValBindsLR a a)) - ) => ToHie (RScoped (HsValBindsLR a a)) where - toHie (RS sc v) = concatM $ case v of - ValBinds _ binds sigs -> - [ toHie $ fmap (BC RegularBind sc) binds - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - XValBindsLR x -> [ toHie $ RS sc x ] - -instance ToHie (RScoped (NHsValBindsLR GhcTc)) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] -instance ToHie (RScoped (NHsValBindsLR GhcRn)) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - -instance ( ToHie (RContext (LHsRecField a arg)) - ) => ToHie (RContext (HsRecFields a arg)) where - toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields - -instance ( ToHie (RFContext (Located label)) - , ToHie arg - , HasLoc arg - , Data label - , Data arg - ) => ToHie (RContext (LHsRecField' label arg)) where - toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of - HsRecField label expr _ -> - [ toHie $ RFC c (getRealSpan $ loc expr) label - , toHie expr - ] - -removeDefSrcSpan :: Name -> Name -removeDefSrcSpan n = setNameLoc n noSrcSpan - -instance ToHie (RFContext (LFieldOcc GhcRn)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc name _ -> - [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name) - ] - XFieldOcc _ -> [] - -instance ToHie (RFContext (LFieldOcc GhcTc)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc var _ -> - let var' = setVarName var (removeDefSrcSpan $ varName var) - in [ toHie $ C (RecField c rhs) (L nspan var') - ] - XFieldOcc _ -> [] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous name _ -> - [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name - ] - Ambiguous _name _ -> - [ ] - XAmbiguousFieldOcc _ -> [] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous var _ -> - let var' = setVarName var (removeDefSrcSpan $ varName var) - in [ toHie $ C (RecField c rhs) (L nspan var') - ] - Ambiguous var _ -> - let var' = setVarName var (removeDefSrcSpan $ varName var) - in [ toHie $ C (RecField c rhs) (L nspan var') - ] - XAmbiguousFieldOcc _ -> [] - -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (LHsExpr a) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (StmtLR a a (Located (HsExpr a))) - , Data (HsLocalBinds a) - ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where - toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM - [ toHie $ PS Nothing sc NoScope pat - , toHie expr - ] - toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM - [ toHie $ listScopes NoScope stmts - , toHie $ PS Nothing sc NoScope pat - ] - toHie (RS _ (XApplicativeArg _)) = pure [] - -instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where - toHie (PrefixCon args) = toHie args - toHie (RecCon rec) = toHie rec - toHie (InfixCon a b) = concatM [ toHie a, toHie b] - -instance ( ToHie (LHsCmd a) - , Data (HsCmdTop a) - ) => ToHie (LHsCmdTop a) where - toHie (L span top) = concatM $ makeNode top span : case top of - HsCmdTop _ cmd -> - [ toHie cmd - ] - XCmdTop _ -> [] - -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (LHsExpr a) - , ToHie (MatchGroup a (LHsCmd a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (HsCmd a) - , Data (HsCmdTop a) - , Data (StmtLR a a (Located (HsCmd a))) - , Data (HsLocalBinds a) - , Data (StmtLR a a (Located (HsExpr a))) - ) => ToHie (LHsCmd (GhcPass p)) where - toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of - HsCmdArrApp _ a b _ _ -> - [ toHie a - , toHie b - ] - HsCmdArrForm _ a _ _ cmdtops -> - [ toHie a - , toHie cmdtops - ] - HsCmdApp _ a b -> - [ toHie a - , toHie b - ] - HsCmdLam _ mg -> - [ toHie mg - ] - HsCmdPar _ a -> - [ toHie a - ] - HsCmdCase _ expr alts -> - [ toHie expr - , toHie alts - ] - HsCmdIf _ _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsCmdLet _ binds cmd' -> - [ toHie $ RS (mkLScope cmd') binds - , toHie cmd' - ] - HsCmdDo _ (L ispan stmts) -> - [ pure $ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - HsCmdWrap _ _ _ -> [] - XCmd _ -> [] - -instance ToHie (TyClGroup GhcRn) where - toHie TyClGroup{ group_tyclds = classes - , group_roles = roles - , group_kisigs = sigs - , group_instds = instances } = - concatM - [ toHie classes - , toHie sigs - , toHie roles - , toHie instances - ] - toHie (XTyClGroup _) = pure [] - -instance ToHie (LTyClDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamDecl {tcdFam = fdecl} -> - [ toHie (L span fdecl) - ] - SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> - [ toHie $ C (Decl SynDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars - , toHie typ - ] - DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> - [ toHie $ C (Decl DataDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars - , toHie defn - ] - where - quant_scope = mkLScope $ dd_ctxt defn - rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc - sig_sc = maybe NoScope mkLScope $ dd_kindSig defn - con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn - deriv_sc = mkLScope $ dd_derivs defn - ClassDecl { tcdCtxt = context - , tcdLName = name - , tcdTyVars = vars - , tcdFDs = deps - , tcdSigs = sigs - , tcdMeths = meths - , tcdATs = typs - , tcdATDefs = deftyps - } -> - [ toHie $ C (Decl ClassDec $ getRealSpan span) name - , toHie context - , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars - , toHie deps - , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs - , toHie $ fmap (BC InstanceBind ModuleScope) meths - , toHie typs - , concatMapM (pure . locOnly . getLoc) deftyps - , toHie deftyps - ] - where - context_scope = mkLScope context - rhs_scope = foldl1' combineScopes $ map mkScope - [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] - XTyClDecl _ -> [] - -instance ToHie (LFamilyDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamilyDecl _ info name vars _ sig inj -> - [ toHie $ C (Decl FamDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [rhsSpan]) vars - , toHie info - , toHie $ RS injSpan sig - , toHie inj - ] - where - rhsSpan = sigSpan `combineScopes` injSpan - sigSpan = mkScope $ getLoc sig - injSpan = maybe NoScope (mkScope . getLoc) inj - XFamilyDecl _ -> [] - -instance ToHie (FamilyInfo GhcRn) where - toHie (ClosedTypeFamily (Just eqns)) = concatM $ - [ concatMapM (pure . locOnly . getLoc) eqns - , toHie $ map go eqns - ] - where - go (L l ib) = TS (ResolvedScopes [mkScope l]) ib - toHie _ = pure [] - -instance ToHie (RScoped (LFamilyResultSig GhcRn)) where - toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of - NoSig _ -> - [] - KindSig _ k -> - [ toHie k - ] - TyVarSig _ bndr -> - [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr - ] - XFamilyResultSig _ -> [] - -instance ToHie (Located (FunDep (Located Name))) where - toHie (L span fd@(lhs, rhs)) = concatM $ - [ makeNode fd span - , toHie $ map (C Use) lhs - , toHie $ map (C Use) rhs - ] - -instance (ToHie rhs, HasLoc rhs) - => ToHie (TScoped (FamEqn GhcRn rhs)) where - toHie (TS _ f) = toHie f - -instance (ToHie rhs, HasLoc rhs) - => ToHie (FamEqn GhcRn rhs) where - toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ - [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie pats - , toHie rhs - ] - where scope = combineScopes patsScope rhsScope - patsScope = mkScope (loc pats) - rhsScope = mkScope (loc rhs) - toHie (XFamEqn _) = pure [] - -instance ToHie (LInjectivityAnn GhcRn) where - toHie (L span ann) = concatM $ makeNode ann span : case ann of - InjectivityAnn lhs rhs -> - [ toHie $ C Use lhs - , toHie $ map (C Use) rhs - ] - -instance ToHie (HsDataDefn GhcRn) where - toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM - [ toHie ctx - , toHie mkind - , toHie cons - , toHie derivs - ] - toHie (XHsDataDefn _) = pure [] - -instance ToHie (HsDeriving GhcRn) where - toHie (L span clauses) = concatM - [ pure $ locOnly span - , toHie clauses - ] - -instance ToHie (LHsDerivingClause GhcRn) where - toHie (L span cl) = concatM $ makeNode cl span : case cl of - HsDerivingClause _ strat (L ispan tys) -> - [ toHie strat - , pure $ locOnly ispan - , toHie $ map (TS (ResolvedScopes [])) tys - ] - XHsDerivingClause _ -> [] - -instance ToHie (Located (DerivStrategy GhcRn)) where - toHie (L span strat) = concatM $ makeNode strat span : case strat of - StockStrategy -> [] - AnyclassStrategy -> [] - NewtypeStrategy -> [] - ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] - -instance ToHie (Located OverlapMode) where - toHie (L span _) = pure $ locOnly span - -instance ToHie (LConDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ConDeclGADT { con_names = names, con_qvars = qvars - , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> - [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names - , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars - , toHie ctx - , toHie args - , toHie typ - ] - where - rhsScope = combineScopes argsScope tyScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope args - tyScope = mkLScope typ - ConDeclH98 { con_name = name, con_ex_tvs = qvars - , con_mb_cxt = ctx, con_args = dets } -> - [ toHie $ C (Decl ConDec $ getRealSpan span) name - , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars - , toHie ctx - , toHie dets - ] - where - rhsScope = combineScopes ctxScope argsScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope dets - XConDecl _ -> [] - where condecl_scope args = case args of - PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs - InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) - RecCon x -> mkLScope x - -instance ToHie (Located [LConDeclField GhcRn]) where - toHie (L span decls) = concatM $ - [ pure $ locOnly span - , toHie decls - ] - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where - toHie (TS sc (HsIB ibrn a)) = concatM $ - [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn - , toHie $ TS sc a - ] - where span = loc a - toHie (TS _ (XHsImplicitBndrs _)) = pure [] - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where - toHie (TS sc (HsWC names a)) = concatM $ - [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names - , toHie $ TS sc a - ] - where span = loc a - toHie (TS _ (XHsWildCardBndrs _)) = pure [] - -instance ToHie (LStandaloneKindSig GhcRn) where - toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] - -instance ToHie (StandaloneKindSig GhcRn) where - toHie sig = concatM $ case sig of - StandaloneKindSig _ name typ -> - [ toHie $ C TyDecl name - , toHie $ TS (ResolvedScopes []) typ - ] - XStandaloneKindSig _ -> [] - -instance ToHie (SigContext (LSig GhcRn)) where - toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of - TypeSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - PatSynSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - ClassOpSig _ _ names typ -> - [ case styp of - ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names - _ -> toHie $ map (C $ TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ - ] - IdSig _ _ -> [] - FixSig _ fsig -> - [ toHie $ L sp fsig - ] - InlineSig _ name _ -> - [ toHie $ (C Use) name - ] - SpecSig _ name typs _ -> - [ toHie $ (C Use) name - , toHie $ map (TS (ResolvedScopes [])) typs - ] - SpecInstSig _ _ typ -> - [ toHie $ TS (ResolvedScopes []) typ - ] - MinimalSig _ _ form -> - [ toHie form - ] - SCCFunSig _ _ name mtxt -> - [ toHie $ (C Use) name - , pure $ maybe [] (locOnly . getLoc) mtxt - ] - CompleteMatchSig _ _ (L ispan names) typ -> - [ pure $ locOnly ispan - , toHie $ map (C Use) names - , toHie $ fmap (C Use) typ - ] - XSig _ -> [] - -instance ToHie (LHsType GhcRn) where - toHie x = toHie $ TS (ResolvedScopes []) x - -instance ToHie (TScoped (LHsType GhcRn)) where - toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of - HsForAllTy _ _ bndrs body -> - [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs - , toHie body - ] - HsQualTy _ ctx body -> - [ toHie ctx - , toHie body - ] - HsTyVar _ _ var -> - [ toHie $ C Use var - ] - HsAppTy _ a b -> - [ toHie a - , toHie b - ] - HsAppKindTy _ ty ki -> - [ toHie ty - , toHie $ TS (ResolvedScopes []) ki - ] - HsFunTy _ a b -> - [ toHie a - , toHie b - ] - HsListTy _ a -> - [ toHie a - ] - HsTupleTy _ _ tys -> - [ toHie tys - ] - HsSumTy _ tys -> - [ toHie tys - ] - HsOpTy _ a op b -> - [ toHie a - , toHie $ C Use op - , toHie b - ] - HsParTy _ a -> - [ toHie a - ] - HsIParamTy _ ip ty -> - [ toHie ip - , toHie ty - ] - HsKindSig _ a b -> - [ toHie a - , toHie b - ] - HsSpliceTy _ a -> - [ toHie $ L span a - ] - HsDocTy _ a _ -> - [ toHie a - ] - HsBangTy _ _ ty -> - [ toHie ty - ] - HsRecTy _ fields -> - [ toHie fields - ] - HsExplicitListTy _ _ tys -> - [ toHie tys - ] - HsExplicitTupleTy _ tys -> - [ toHie tys - ] - HsTyLit _ _ -> [] - HsWildCardTy _ -> [] - HsStarTy _ _ -> [] - XHsType _ -> [] - -instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where - toHie (HsValArg tm) = toHie tm - toHie (HsTypeArg _ ty) = toHie ty - toHie (HsArgPar sp) = pure $ locOnly sp - -instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where - toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - UserTyVar _ var -> - [ toHie $ C (TyVarBind sc tsc) var - ] - KindedTyVar _ var kind -> - [ toHie $ C (TyVarBind sc tsc) var - , toHie kind - ] - XTyVarBndr _ -> [] - -instance ToHie (TScoped (LHsQTyVars GhcRn)) where - toHie (TS sc (HsQTvs implicits vars)) = concatM $ - [ pure $ bindingsOnly bindings - , toHie $ tvScopes sc NoScope vars - ] - where - varLoc = loc vars - bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits - toHie (TS _ (XLHsQTyVars _)) = pure [] - -instance ToHie (LHsContext GhcRn) where - toHie (L span tys) = concatM $ - [ pure $ locOnly span - , toHie tys - ] - -instance ToHie (LConDeclField GhcRn) where - toHie (L span field) = concatM $ makeNode field span : case field of - ConDeclField _ fields typ _ -> - [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields - , toHie typ - ] - XConDeclField _ -> [] - -instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where - toHie (From expr) = toHie expr - toHie (FromThen a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromTo a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromThenTo a b c) = concatM $ - [ toHie a - , toHie b - , toHie c - ] - -instance ToHie (LSpliceDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - SpliceDecl _ splice _ -> - [ toHie splice - ] - XSpliceDecl _ -> [] - -instance ToHie (HsBracket a) where - toHie _ = pure [] - -instance ToHie PendingRnSplice where - toHie _ = pure [] - -instance ToHie PendingTcSplice where - toHie _ = pure [] - -instance ToHie (LBooleanFormula (Located Name)) where - toHie (L span form) = concatM $ makeNode form span : case form of - Var a -> - [ toHie $ C Use a - ] - And forms -> - [ toHie forms - ] - Or forms -> - [ toHie forms - ] - Parens f -> - [ toHie f - ] - -instance ToHie (Located HsIPName) where - toHie (L span e) = makeNode e span - -instance ( ToHie (LHsExpr a) - , Data (HsSplice a) - ) => ToHie (Located (HsSplice a)) where - toHie (L span sp) = concatM $ makeNode sp span : case sp of - HsTypedSplice _ _ _ expr -> - [ toHie expr - ] - HsUntypedSplice _ _ _ expr -> - [ toHie expr - ] - HsQuasiQuote _ _ _ ispan _ -> - [ pure $ locOnly ispan - ] - HsSpliced _ _ _ -> - [] - HsSplicedT _ -> - [] - XSplice _ -> [] - -instance ToHie (LRoleAnnotDecl GhcRn) where - toHie (L span annot) = concatM $ makeNode annot span : case annot of - RoleAnnotDecl _ var roles -> - [ toHie $ C Use var - , concatMapM (pure . locOnly . getLoc) roles - ] - XRoleAnnotDecl _ -> [] - -instance ToHie (LInstDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ClsInstD _ d -> - [ toHie $ L span d - ] - DataFamInstD _ d -> - [ toHie $ L span d - ] - TyFamInstD _ d -> - [ toHie $ L span d - ] - XInstDecl _ -> [] - -instance ToHie (LClsInstDecl GhcRn) where - toHie (L span decl) = concatM - [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl - , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl - , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl - , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl - , toHie $ cid_tyfam_insts decl - , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl - , toHie $ cid_datafam_insts decl - , toHie $ cid_overlap_mode decl - ] - -instance ToHie (LDataFamInstDecl GhcRn) where - toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (LTyFamInstDecl GhcRn) where - toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (Context a) - => ToHie (PatSynFieldContext (RecordPatSynField a)) where - toHie (PSC sp (RecordPatSynField a b)) = concatM $ - [ toHie $ C (RecField RecFieldDecl sp) a - , toHie $ C Use b - ] - -instance ToHie (LDerivDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DerivDecl _ typ strat overlap -> - [ toHie $ TS (ResolvedScopes []) typ - , toHie strat - , toHie overlap - ] - XDerivDecl _ -> [] - -instance ToHie (LFixitySig GhcRn) where - toHie (L span sig) = concatM $ makeNode sig span : case sig of - FixitySig _ vars _ -> - [ toHie $ map (C Use) vars - ] - XFixitySig _ -> [] - -instance ToHie (LDefaultDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DefaultDecl _ typs -> - [ toHie typs - ] - XDefaultDecl _ -> [] - -instance ToHie (LForeignDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> - [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name - , toHie $ TS (ResolvedScopes []) sig - , toHie fi - ] - ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> - [ toHie $ C Use name - , toHie $ TS (ResolvedScopes []) sig - , toHie fe - ] - XForeignDecl _ -> [] - -instance ToHie ForeignImport where - toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ - [ locOnly a - , locOnly b - , locOnly c - ] - -instance ToHie ForeignExport where - toHie (CExport (L a _) (L b _)) = pure $ concat $ - [ locOnly a - , locOnly b - ] - -instance ToHie (LWarnDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warnings _ _ warnings -> - [ toHie warnings - ] - XWarnDecls _ -> [] - -instance ToHie (LWarnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warning _ vars _ -> - [ toHie $ map (C Use) vars - ] - XWarnDecl _ -> [] - -instance ToHie (LAnnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsAnnotation _ _ prov expr -> - [ toHie prov - , toHie expr - ] - XAnnDecl _ -> [] - -instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where - toHie (ValueAnnProvenance a) = toHie $ C Use a - toHie (TypeAnnProvenance a) = toHie $ C Use a - toHie ModuleAnnProvenance = pure [] - -instance ToHie (LRuleDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsRules _ _ rules -> - [ toHie rules - ] - XRuleDecls _ -> [] - -instance ToHie (LRuleDecl GhcRn) where - toHie (L _ (XRuleDecl _)) = pure [] - toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM - [ makeNode r span - , pure $ locOnly $ getLoc rname - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope span) bndrs - , toHie exprA - , toHie exprB - ] - where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc - bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) - exprA_sc = mkLScope exprA - exprB_sc = mkLScope exprB - -instance ToHie (RScoped (LRuleBndr GhcRn)) where - toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - RuleBndr _ var -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - ] - RuleBndrSig _ var typ -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - , toHie $ TS (ResolvedScopes [sc]) typ - ] - XRuleBndr _ -> [] - -instance ToHie (LImportDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> - [ toHie $ IEC Import name - , toHie $ fmap (IEC ImportAs) as - , maybe (pure []) goIE hidden - ] - XImportDecl _ -> [] - where - goIE (hiding, (L sp liens)) = concatM $ - [ pure $ locOnly sp - , toHie $ map (IEC c) liens - ] - where - c = if hiding then ImportHiding else Import - -instance ToHie (IEContext (LIE GhcRn)) where - toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of - IEVar _ n -> - [ toHie $ IEC c n - ] - IEThingAbs _ n -> - [ toHie $ IEC c n - ] - IEThingAll _ n -> - [ toHie $ IEC c n - ] - IEThingWith _ n _ ns flds -> - [ toHie $ IEC c n - , toHie $ map (IEC c) ns - , toHie $ map (IEC c) flds - ] - IEModuleContents _ n -> - [ toHie $ IEC c n - ] - IEGroup _ _ _ -> [] - IEDoc _ _ -> [] - IEDocNamed _ _ -> [] - XIE _ -> [] - -instance ToHie (IEContext (LIEWrappedName Name)) where - toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of - IEName n -> - [ toHie $ C (IEThing c) n - ] - IEPattern p -> - [ toHie $ C (IEThing c) p - ] - IEType n -> - [ toHie $ C (IEThing c) n - ] - -instance ToHie (IEContext (Located (FieldLbl Name))) where - toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of - FieldLabel _ _ n -> - [ toHie $ C (IEThing c) $ L span n - ] diff --git a/hieFile/HieBin.hs b/hieFile/HieBin.hs deleted file mode 100644 --- a/hieFile/HieBin.hs +++ /dev/null @@ -1,392 +0,0 @@ -{- -Binary serialization for .hie files. --} -{-# LANGUAGE ScopedTypeVariables #-} -module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc) where - -import GHC.Settings ( maybeRead ) - -import Config ( cProjectVersion ) -import GhcPrelude -import Binary -import BinIface ( getDictFastString ) -import FastMutInt -import FastString ( FastString ) -import Module ( Module ) -import Name -import NameCache -import Outputable -import PrelInfo -import SrcLoc -import UniqSupply ( takeUniqFromSupply ) -import Unique -import UniqFM - -import qualified Data.Array as A -import Data.IORef -import Data.ByteString ( ByteString ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import Data.List ( mapAccumR ) -import Data.Word ( Word8, Word32 ) -import Control.Monad ( replicateM, when ) -import System.Directory ( createDirectoryIfMissing ) -import System.FilePath ( takeDirectory ) - -import HieTypes - --- | `Name`'s get converted into `HieName`'s before being written into @.hie@ --- files. See 'toHieName' and 'fromHieName' for logic on how to convert between --- these two types. -data HieName - = ExternalName !Module !OccName !SrcSpan - | LocalName !OccName !SrcSpan - | KnownKeyName !Unique - deriving (Eq) - -instance Ord HieName where - compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f) - compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d) - compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b - -- Not actually non determinstic as it is a KnownKey - compare ExternalName{} _ = LT - compare LocalName{} ExternalName{} = GT - compare LocalName{} _ = LT - compare KnownKeyName{} _ = GT - -instance Outputable HieName where - ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp - ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp - ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u - -hieNameOcc :: HieName -> OccName -hieNameOcc (ExternalName _ occ _) = occ -hieNameOcc (LocalName occ _) = occ -hieNameOcc (KnownKeyName u) = - case lookupKnownKeyName u of - Just n -> nameOccName n - Nothing -> pprPanic "hieNameOcc:unknown known-key unique" - (ppr (unpkUnique u)) - - -data HieSymbolTable = HieSymbolTable - { hie_symtab_next :: !FastMutInt - , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) - } - -data HieDictionary = HieDictionary - { hie_dict_next :: !FastMutInt -- The next index to use - , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString - } - -initBinMemSize :: Int -initBinMemSize = 1024*1024 - --- | The header for HIE files - Capital ASCII letters "HIE". -hieMagic :: [Word8] -hieMagic = [72,73,69] - -hieMagicLen :: Int -hieMagicLen = length hieMagic - -ghcVersion :: ByteString -ghcVersion = BSC.pack cProjectVersion - -putBinLine :: BinHandle -> ByteString -> IO () -putBinLine bh xs = do - mapM_ (putByte bh) $ BS.unpack xs - putByte bh 10 -- newline char - --- | Write a `HieFile` to the given `FilePath`, with a proper header and --- symbol tables for `Name`s and `FastString`s -writeHieFile :: FilePath -> HieFile -> IO () -writeHieFile hie_file_path hiefile = do - bh0 <- openBinMem initBinMemSize - - -- Write the header: hieHeader followed by the - -- hieVersion and the GHC version used to generate this file - mapM_ (putByte bh0) hieMagic - putBinLine bh0 $ BSC.pack $ show hieVersion - putBinLine bh0 $ ghcVersion - - -- remember where the dictionary pointer will go - dict_p_p <- tellBin bh0 - put_ bh0 dict_p_p - - -- remember where the symbol table pointer will go - symtab_p_p <- tellBin bh0 - put_ bh0 symtab_p_p - - -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM - let hie_symtab = HieSymbolTable { - hie_symtab_next = symtab_next, - hie_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM - let hie_dict = HieDictionary { - hie_dict_next = dict_next_ref, - hie_dict_map = dict_map_ref } - - -- put the main thing - let bh = setUserData bh0 $ newWriteState (putName hie_symtab) - (putName hie_symtab) - (putFastString hie_dict) - put_ bh hiefile - - -- write the symtab pointer at the front of the file - symtab_p <- tellBin bh - putAt bh symtab_p_p symtab_p - seekBin bh symtab_p - - -- write the symbol table itself - symtab_next' <- readFastMutInt symtab_next - symtab_map' <- readIORef symtab_map - putSymbolTable bh symtab_next' symtab_map' - - -- write the dictionary pointer at the front of the file - dict_p <- tellBin bh - putAt bh dict_p_p dict_p - seekBin bh dict_p - - -- write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - - -- and send the result to the file - createDirectoryIfMissing True (takeDirectory hie_file_path) - writeBinMem bh hie_file_path - return () - -data HieFileResult - = HieFileResult - { hie_file_result_version :: Integer - , hie_file_result_ghc_version :: ByteString - , hie_file_result :: HieFile - } - -type HieHeader = (Integer, ByteString) - --- | Read a `HieFile` from a `FilePath`. Can use --- an existing `NameCache`. Allows you to specify --- which versions of hieFile to attempt to read. --- `Left` case returns the failing header versions. -readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache)) -readHieFileWithVersion readVersion nc file = do - bh0 <- readBinMem file - - (hieVersion, ghcVersion) <- readHieFileHeader file bh0 - - if readVersion (hieVersion, ghcVersion) - then do - (hieFile, nc') <- readHieFileContents bh0 nc - return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc') - else return $ Left (hieVersion, ghcVersion) - - --- | Read a `HieFile` from a `FilePath`. Can use --- an existing `NameCache`. -readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache) -readHieFile nc file = do - - bh0 <- readBinMem file - - (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 - - -- Check if the versions match - when (readHieVersion /= hieVersion) $ - panic $ unwords ["readHieFile: hie file versions don't match for file:" - , file - , "Expected" - , show hieVersion - , "but got", show readHieVersion - ] - (hieFile, nc') <- readHieFileContents bh0 nc - return $ (HieFileResult hieVersion ghcVersion hieFile, nc') - -readBinLine :: BinHandle -> IO ByteString -readBinLine bh = BS.pack . reverse <$> loop [] - where - loop acc = do - char <- get bh :: IO Word8 - if char == 10 -- ASCII newline '\n' - then return acc - else loop (char : acc) - -readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader -readHieFileHeader file bh0 = do - -- Read the header - magic <- replicateM hieMagicLen (get bh0) - version <- BSC.unpack <$> readBinLine bh0 - case maybeRead version of - Nothing -> - panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" - , show version - ] - Just readHieVersion -> do - ghcVersion <- readBinLine bh0 - - -- Check if the header is valid - when (magic /= hieMagic) $ - panic $ unwords ["readHieFileHeader: headers don't match for file:" - , file - , "Expected" - , show hieMagic - , "but got", show magic - ] - return (readHieVersion, ghcVersion) - -readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache) -readHieFileContents bh0 nc = do - - dict <- get_dictionary bh0 - - -- read the symbol table so we are capable of reading the actual data - (bh1, nc') <- do - let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") - (getDictFastString dict) - (nc', symtab) <- get_symbol_table bh1 - let bh1' = setUserData bh1 - $ newReadState (getSymTabName symtab) - (getDictFastString dict) - return (bh1', nc') - - -- load the actual data - hiefile <- get bh1 - return (hiefile, nc') - where - get_dictionary bin_handle = do - dict_p <- get bin_handle - data_p <- tellBin bin_handle - seekBin bin_handle dict_p - dict <- getDictionary bin_handle - seekBin bin_handle data_p - return dict - - get_symbol_table bh1 = do - symtab_p <- get bh1 - data_p' <- tellBin bh1 - seekBin bh1 symtab_p - (nc', symtab) <- getSymbolTable bh1 nc - seekBin bh1 data_p' - return (nc', symtab) - -putFastString :: HieDictionary -> BinHandle -> FastString -> IO () -putFastString HieDictionary { hie_dict_next = j_r, - hie_dict_map = out_r} bh f - = do - out <- readIORef out_r - let unique = getUnique f - case lookupUFM out unique of - Just (j, _) -> put_ bh (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - put_ bh (fromIntegral j :: Word32) - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out unique (j, f) - -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) - mapM_ (putHieName bh) names - -getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable) -getSymbolTable bh namecache = do - sz <- get bh - od_names <- replicateM sz (getHieName bh) - let arr = A.listArray (0,sz-1) names - (namecache', names) = mapAccumR fromHieName namecache od_names - return (namecache', arr) - -getSymTabName :: SymbolTable -> BinHandle -> IO Name -getSymTabName st bh = do - i :: Word32 <- get bh - return $ st A.! (fromIntegral i) - -putName :: HieSymbolTable -> BinHandle -> Name -> IO () -putName (HieSymbolTable next ref) bh name = do - symmap <- readIORef ref - case lookupUFM symmap name of - Just (off, ExternalName mod occ (UnhelpfulSpan _)) - | isGoodSrcSpan (nameSrcSpan name) -> do - let hieName = ExternalName mod occ (nameSrcSpan name) - writeIORef ref $! addToUFM symmap name (off, hieName) - put_ bh (fromIntegral off :: Word32) - Just (off, LocalName _occ span) - | notLocal (toHieName name) || nameSrcSpan name /= span -> do - writeIORef ref $! addToUFM symmap name (off, toHieName name) - put_ bh (fromIntegral off :: Word32) - Just (off, _) -> put_ bh (fromIntegral off :: Word32) - Nothing -> do - off <- readFastMutInt next - writeFastMutInt next (off+1) - writeIORef ref $! addToUFM symmap name (off, toHieName name) - put_ bh (fromIntegral off :: Word32) - - where - notLocal :: HieName -> Bool - notLocal LocalName{} = False - notLocal _ = True - - --- ** Converting to and from `HieName`'s - -toHieName :: Name -> HieName -toHieName name - | isKnownKeyName name = KnownKeyName (nameUnique name) - | isExternalName name = ExternalName (nameModule name) - (nameOccName name) - (nameSrcSpan name) - | otherwise = LocalName (nameOccName name) (nameSrcSpan name) - -fromHieName :: NameCache -> HieName -> (NameCache, Name) -fromHieName nc (ExternalName mod occ span) = - let cache = nsNames nc - in case lookupOrigNameCache cache mod occ of - Just name -> (nc, name) - Nothing -> - let (uniq, us) = takeUniqFromSupply (nsUniqs nc) - name = mkExternalName uniq mod occ span - new_cache = extendNameCache cache mod occ name - in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) -fromHieName nc (LocalName occ span) = - let (uniq, us) = takeUniqFromSupply (nsUniqs nc) - name = mkInternalName uniq occ span - in ( nc{ nsUniqs = us }, name ) -fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of - Nothing -> pprPanic "fromHieName:unknown known-key unique" - (ppr (unpkUnique u)) - Just n -> (nc, n) - --- ** Reading and writing `HieName`'s - -putHieName :: BinHandle -> HieName -> IO () -putHieName bh (ExternalName mod occ span) = do - putByte bh 0 - put_ bh (mod, occ, span) -putHieName bh (LocalName occName span) = do - putByte bh 1 - put_ bh (occName, span) -putHieName bh (KnownKeyName uniq) = do - putByte bh 2 - put_ bh $ unpkUnique uniq - -getHieName :: BinHandle -> IO HieName -getHieName bh = do - t <- getByte bh - case t of - 0 -> do - (modu, occ, span) <- get bh - return $ ExternalName modu occ span - 1 -> do - (occ, span) <- get bh - return $ LocalName occ span - 2 -> do - (c,i) <- get bh - return $ KnownKeyName $ mkUnique c i - _ -> panic "HieBin.getHieName: invalid tag" diff --git a/hieFile/HieDebug.hs b/hieFile/HieDebug.hs deleted file mode 100644 --- a/hieFile/HieDebug.hs +++ /dev/null @@ -1,171 +0,0 @@ -{- -Functions to validate and check .hie file ASTs generated by GHC. --} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module HieDebug where - -import GhcPrelude - -import SrcLoc -import Module -import FastString -import Outputable - -import HieTypes -import HieBin -import HieUtils -import Name - -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Function ( on ) -import Data.List ( sortOn ) -import Data.Foldable ( toList ) - -ppHies :: Outputable a => (HieASTs a) -> SDoc -ppHies (HieASTs asts) = M.foldrWithKey go "" asts - where - go k a rest = vcat $ - [ "File: " <> ppr k - , ppHie a - , rest - ] - -ppHie :: Outputable a => HieAST a -> SDoc -ppHie = go 0 - where - go n (Node inf sp children) = hang header n rest - where - rest = vcat $ map (go (n+2)) children - header = hsep - [ "Node" - , ppr sp - , ppInfo inf - ] - -ppInfo :: Outputable a => NodeInfo a -> SDoc -ppInfo ni = hsep - [ ppr $ toList $ nodeAnnotations ni - , ppr $ nodeType ni - , ppr $ M.toList $ nodeIdentifiers ni - ] - -type Diff a = a -> a -> [SDoc] - -diffFile :: Diff HieFile -diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) - -diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a)) -diffAsts f = diffList (diffAst f) `on` M.elems - -diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) -diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = - infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 - where - spanDiff - | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] - | otherwise = [] - infoDiff' - = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2 - ++ (diffList diffType `on` nodeType) info1 info2 - ++ (diffIdents `on` nodeIdentifiers) info1 info2 - infoDiff = case infoDiff' of - [] -> [] - xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1) - , "and", ppr (nodeIdentifiers info2,span2) - , "While comparing" - , ppr (normalizeIdents $ nodeIdentifiers info1), "and" - , ppr (normalizeIdents $ nodeIdentifiers info2) - ] - ] - - diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b - diffIdent (a,b) (c,d) = diffName a c - ++ eqDiff b d - diffName (Right a) (Right b) = case (a,b) of - (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o') - (LocalName o _, ExternalName _ o' _) -> eqDiff o o' - _ -> eqDiff a b - diffName a b = eqDiff a b - -type DiffIdent = Either ModuleName HieName - -normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] -normalizeIdents = sortOn go . map (first toHieName) . M.toList - where - first f (a,b) = (fmap f a, b) - go (a,b) = (hieNameOcc <$> a,identInfo b,identType b) - -diffList :: Diff a -> Diff [a] -diffList f xs ys - | length xs == length ys = concat $ zipWith f xs ys - | otherwise = ["length of lists doesn't match"] - -eqDiff :: (Outputable a, Eq a) => Diff a -eqDiff a b - | a == b = [] - | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]] - -validAst :: HieAST a -> Either SDoc () -validAst (Node _ span children) = do - checkContainment children - checkSorted children - mapM_ validAst children - where - checkSorted [] = return () - checkSorted [_] = return () - checkSorted (x:y:xs) - | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs) - | otherwise = Left $ hsep - [ ppr $ nodeSpan x - , "is not to the left of" - , ppr $ nodeSpan y - ] - checkContainment [] = return () - checkContainment (x:xs) - | span `containsSpan` (nodeSpan x) = checkContainment xs - | otherwise = Left $ hsep - [ ppr $ span - , "does not contain" - , ppr $ nodeSpan x - ] - --- | Look for any identifiers which occur outside of their supposed scopes. --- Returns a list of error messages. -validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc] -validateScopes mod asts = validScopes - where - refMap = generateReferencesMap asts - -- We use a refmap for most of the computation - - -- Check if all the names occur in their calculated scopes - validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap - valid (Left _) _ = [] - valid (Right n) refs = concatMap inScope refs - where - mapRef = foldMap getScopeFromContext . identInfo . snd - scopes = case foldMap mapRef refs of - Just xs -> xs - Nothing -> [] - inScope (sp, dets) - | (definedInAsts asts n) - && any isOccurrence (identInfo dets) - -- We validate scopes for names which are defined locally, and occur - -- in this span - = case scopes of - [] | (nameIsLocalOrFrom mod n - && not (isDerivedOccName $ nameOccName n)) - -- If we don't get any scopes for a local name then its an error. - -- We can ignore derived names. - -> return $ hsep $ - [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp - , "Doesn't have a calculated scope: ", ppr scopes] - | otherwise -> [] - _ -> if any (`scopeContainsSpan` sp) scopes - then [] - else return $ hsep $ - [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp - , "doesn't occur in calculated scope", ppr scopes] - | otherwise = [] diff --git a/hieFile/HieTypes.hs b/hieFile/HieTypes.hs deleted file mode 100644 --- a/hieFile/HieTypes.hs +++ /dev/null @@ -1,509 +0,0 @@ -{- -Types for the .hie file format are defined here. - -For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files --} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -module HieTypes where - -import GhcPrelude - -import Config -import Binary -import FastString ( FastString ) -import IfaceType -import Module ( ModuleName, Module ) -import Name ( Name ) -import Outputable hiding ( (<>) ) -import SrcLoc ( RealSrcSpan ) -import Avail - -import qualified Data.Array as A -import qualified Data.Map as M -import qualified Data.Set as S -import Data.ByteString ( ByteString ) -import Data.Data ( Typeable, Data ) -import Data.Semigroup ( Semigroup(..) ) -import Data.Word ( Word8 ) -import Control.Applicative ( (<|>) ) - -type Span = RealSrcSpan - --- | Current version of @.hie@ files -hieVersion :: Integer -hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer - -{- | -GHC builds up a wealth of information about Haskell source as it compiles it. -@.hie@ files are a way of persisting some of this information to disk so that -external tools that need to work with haskell source don't need to parse, -typecheck, and rename all over again. These files contain: - - * a simplified AST - - * nodes are annotated with source positions and types - * identifiers are annotated with scope information - - * the raw bytes of the initial Haskell source - -Besides saving compilation cycles, @.hie@ files also offer a more stable -interface than the GHC API. --} -data HieFile = HieFile - { hie_hs_file :: FilePath - -- ^ Initial Haskell source file path - - , hie_module :: Module - -- ^ The module this HIE file is for - - , hie_types :: A.Array TypeIndex HieTypeFlat - -- ^ Types referenced in the 'hie_asts'. - -- - -- See Note [Efficient serialization of redundant type info] - - , hie_asts :: HieASTs TypeIndex - -- ^ Type-annotated abstract syntax trees - - , hie_exports :: [AvailInfo] - -- ^ The names that this module exports - - , hie_hs_src :: ByteString - -- ^ Raw bytes of the initial Haskell source - } -instance Binary HieFile where - put_ bh hf = do - put_ bh $ hie_hs_file hf - put_ bh $ hie_module hf - put_ bh $ hie_types hf - put_ bh $ hie_asts hf - put_ bh $ hie_exports hf - put_ bh $ hie_hs_src hf - - get bh = HieFile - <$> get bh - <*> get bh - <*> get bh - <*> get bh - <*> get bh - <*> get bh - - -{- -Note [Efficient serialization of redundant type info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The type information in .hie files is highly repetitive and redundant. For -example, consider the expression - - const True 'a' - -There is a lot of shared structure between the types of subterms: - - * const True 'a' :: Bool - * const True :: Char -> Bool - * const :: Bool -> Char -> Bool - -Since all 3 of these types need to be stored in the .hie file, it is worth -making an effort to deduplicate this shared structure. The trick is to define -a new data type that is a flattened version of 'Type': - - data HieType a = HAppTy a a -- data Type = AppTy Type Type - | HFunTy a a -- | FunTy Type Type - | ... - - type TypeIndex = Int - -Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)', -where the 'TypeIndex's in the 'HieType' are references to other elements of the -array. Types recovered from GHC are deduplicated and stored in this compressed -form with sharing of subtrees. --} - -type TypeIndex = Int - --- | A flattened version of 'Type'. --- --- See Note [Efficient serialization of redundant type info] -data HieType a - = HTyVarTy Name - | HAppTy a (HieArgs a) - | HTyConApp IfaceTyCon (HieArgs a) - | HForAllTy ((Name, a),ArgFlag) a - | HFunTy a a - | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') - | HLitTy IfaceTyLit - | HCastTy a - | HCoercionTy - deriving (Functor, Foldable, Traversable, Eq) - -type HieTypeFlat = HieType TypeIndex - --- | Roughly isomorphic to the original core 'Type'. -newtype HieTypeFix = Roll (HieType (HieTypeFix)) - -instance Binary (HieType TypeIndex) where - put_ bh (HTyVarTy n) = do - putByte bh 0 - put_ bh n - put_ bh (HAppTy a b) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh (HTyConApp n xs) = do - putByte bh 2 - put_ bh n - put_ bh xs - put_ bh (HForAllTy bndr a) = do - putByte bh 3 - put_ bh bndr - put_ bh a - put_ bh (HFunTy a b) = do - putByte bh 4 - put_ bh a - put_ bh b - put_ bh (HQualTy a b) = do - putByte bh 5 - put_ bh a - put_ bh b - put_ bh (HLitTy l) = do - putByte bh 6 - put_ bh l - put_ bh (HCastTy a) = do - putByte bh 7 - put_ bh a - put_ bh (HCoercionTy) = putByte bh 8 - - get bh = do - (t :: Word8) <- get bh - case t of - 0 -> HTyVarTy <$> get bh - 1 -> HAppTy <$> get bh <*> get bh - 2 -> HTyConApp <$> get bh <*> get bh - 3 -> HForAllTy <$> get bh <*> get bh - 4 -> HFunTy <$> get bh <*> get bh - 5 -> HQualTy <$> get bh <*> get bh - 6 -> HLitTy <$> get bh - 7 -> HCastTy <$> get bh - 8 -> return HCoercionTy - _ -> panic "Binary (HieArgs Int): invalid tag" - - --- | A list of type arguments along with their respective visibilities (ie. is --- this an argument that would return 'True' for 'isVisibleArgFlag'?). -newtype HieArgs a = HieArgs [(Bool,a)] - deriving (Functor, Foldable, Traversable, Eq) - -instance Binary (HieArgs TypeIndex) where - put_ bh (HieArgs xs) = put_ bh xs - get bh = HieArgs <$> get bh - --- | Mapping from filepaths (represented using 'FastString') to the --- corresponding AST -newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) } - deriving (Functor, Foldable, Traversable) - -instance Binary (HieASTs TypeIndex) where - put_ bh asts = put_ bh $ M.toAscList $ getAsts asts - get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) - - -data HieAST a = - Node - { nodeInfo :: NodeInfo a - , nodeSpan :: Span - , nodeChildren :: [HieAST a] - } deriving (Functor, Foldable, Traversable) - -instance Binary (HieAST TypeIndex) where - put_ bh ast = do - put_ bh $ nodeInfo ast - put_ bh $ nodeSpan ast - put_ bh $ nodeChildren ast - - get bh = Node - <$> get bh - <*> get bh - <*> get bh - - --- | The information stored in one AST node. --- --- The type parameter exists to provide flexibility in representation of types --- (see Note [Efficient serialization of redundant type info]). -data NodeInfo a = NodeInfo - { nodeAnnotations :: S.Set (FastString,FastString) - -- ^ (name of the AST node constructor, name of the AST node Type) - - , nodeType :: [a] - -- ^ The Haskell types of this node, if any. - - , nodeIdentifiers :: NodeIdentifiers a - -- ^ All the identifiers and their details - } deriving (Functor, Foldable, Traversable) - -instance Binary (NodeInfo TypeIndex) where - put_ bh ni = do - put_ bh $ S.toAscList $ nodeAnnotations ni - put_ bh $ nodeType ni - put_ bh $ M.toList $ nodeIdentifiers ni - get bh = NodeInfo - <$> fmap (S.fromDistinctAscList) (get bh) - <*> get bh - <*> fmap (M.fromList) (get bh) - -type Identifier = Either ModuleName Name - -type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a) - --- | Information associated with every identifier --- --- We need to include types with identifiers because sometimes multiple --- identifiers occur in the same span(Overloaded Record Fields and so on) -data IdentifierDetails a = IdentifierDetails - { identType :: Maybe a - , identInfo :: S.Set ContextInfo - } deriving (Eq, Functor, Foldable, Traversable) - -instance Outputable a => Outputable (IdentifierDetails a) where - ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x) - -instance Semigroup (IdentifierDetails a) where - d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2) - (S.union (identInfo d1) (identInfo d2)) - -instance Monoid (IdentifierDetails a) where - mempty = IdentifierDetails Nothing S.empty - -instance Binary (IdentifierDetails TypeIndex) where - put_ bh dets = do - put_ bh $ identType dets - put_ bh $ S.toAscList $ identInfo dets - get bh = IdentifierDetails - <$> get bh - <*> fmap (S.fromDistinctAscList) (get bh) - - --- | Different contexts under which identifiers exist -data ContextInfo - = Use -- ^ regular variable - | MatchBind - | IEThing IEType -- ^ import/export - | TyDecl - - -- | Value binding - | ValBind - BindType -- ^ whether or not the binding is in an instance - Scope -- ^ scope over which the value is bound - (Maybe Span) -- ^ span of entire binding - - -- | Pattern binding - -- - -- This case is tricky because the bound identifier can be used in two - -- distinct scopes. Consider the following example (with @-XViewPatterns@) - -- - -- @ - -- do (b, a, (a -> True)) <- bar - -- foo a - -- @ - -- - -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and - -- in the rest of the @do@-block in @foo a@. - | PatternBind - Scope -- ^ scope /in the pattern/ (the variable bound can be used - -- further in the pattern) - Scope -- ^ rest of the scope outside the pattern - (Maybe Span) -- ^ span of entire binding - - | ClassTyDecl (Maybe Span) - - -- | Declaration - | Decl - DeclType -- ^ type of declaration - (Maybe Span) -- ^ span of entire binding - - -- | Type variable - | TyVarBind Scope TyVarScope - - -- | Record field - | RecField RecFieldContext (Maybe Span) - deriving (Eq, Ord, Show) - -instance Outputable ContextInfo where - ppr = text . show - -instance Binary ContextInfo where - put_ bh Use = putByte bh 0 - put_ bh (IEThing t) = do - putByte bh 1 - put_ bh t - put_ bh TyDecl = putByte bh 2 - put_ bh (ValBind bt sc msp) = do - putByte bh 3 - put_ bh bt - put_ bh sc - put_ bh msp - put_ bh (PatternBind a b c) = do - putByte bh 4 - put_ bh a - put_ bh b - put_ bh c - put_ bh (ClassTyDecl sp) = do - putByte bh 5 - put_ bh sp - put_ bh (Decl a b) = do - putByte bh 6 - put_ bh a - put_ bh b - put_ bh (TyVarBind a b) = do - putByte bh 7 - put_ bh a - put_ bh b - put_ bh (RecField a b) = do - putByte bh 8 - put_ bh a - put_ bh b - put_ bh MatchBind = putByte bh 9 - - get bh = do - (t :: Word8) <- get bh - case t of - 0 -> return Use - 1 -> IEThing <$> get bh - 2 -> return TyDecl - 3 -> ValBind <$> get bh <*> get bh <*> get bh - 4 -> PatternBind <$> get bh <*> get bh <*> get bh - 5 -> ClassTyDecl <$> get bh - 6 -> Decl <$> get bh <*> get bh - 7 -> TyVarBind <$> get bh <*> get bh - 8 -> RecField <$> get bh <*> get bh - 9 -> return MatchBind - _ -> panic "Binary ContextInfo: invalid tag" - - --- | Types of imports and exports -data IEType - = Import - | ImportAs - | ImportHiding - | Export - deriving (Eq, Enum, Ord, Show) - -instance Binary IEType where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) - - -data RecFieldContext - = RecFieldDecl - | RecFieldAssign - | RecFieldMatch - | RecFieldOcc - deriving (Eq, Enum, Ord, Show) - -instance Binary RecFieldContext where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) - - -data BindType - = RegularBind - | InstanceBind - deriving (Eq, Ord, Show, Enum) - -instance Binary BindType where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) - - -data DeclType - = FamDec -- ^ type or data family - | SynDec -- ^ type synonym - | DataDec -- ^ data declaration - | ConDec -- ^ constructor declaration - | PatSynDec -- ^ pattern synonym - | ClassDec -- ^ class declaration - | InstDec -- ^ instance declaration - deriving (Eq, Ord, Show, Enum) - -instance Binary DeclType where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) - - -data Scope - = NoScope - | LocalScope Span - | ModuleScope - deriving (Eq, Ord, Show, Typeable, Data) - -instance Outputable Scope where - ppr NoScope = text "NoScope" - ppr (LocalScope sp) = text "LocalScope" <+> ppr sp - ppr ModuleScope = text "ModuleScope" - -instance Binary Scope where - put_ bh NoScope = putByte bh 0 - put_ bh (LocalScope span) = do - putByte bh 1 - put_ bh span - put_ bh ModuleScope = putByte bh 2 - - get bh = do - (t :: Word8) <- get bh - case t of - 0 -> return NoScope - 1 -> LocalScope <$> get bh - 2 -> return ModuleScope - _ -> panic "Binary Scope: invalid tag" - - --- | Scope of a type variable. --- --- This warrants a data type apart from 'Scope' because of complexities --- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For --- example, consider: --- --- @ --- foo, bar, baz :: forall a. a -> a --- @ --- --- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we --- need a list of scopes to keep track of this. Furthermore, this list cannot be --- computed until we resolve the binding sites of @foo@, @bar@, and @baz@. --- --- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@ --- which later gets resolved into a 'ResolvedScopes'. -data TyVarScope - = ResolvedScopes [Scope] - - -- | Unresolved scopes should never show up in the final @.hie@ file - | UnresolvedScope - [Name] -- ^ names of the definitions over which the scope spans - (Maybe Span) -- ^ the location of the instance/class declaration for - -- the case where the type variable is declared in a - -- method type signature - deriving (Eq, Ord) - -instance Show TyVarScope where - show (ResolvedScopes sc) = show sc - show _ = error "UnresolvedScope" - -instance Binary TyVarScope where - put_ bh (ResolvedScopes xs) = do - putByte bh 0 - put_ bh xs - put_ bh (UnresolvedScope ns span) = do - putByte bh 1 - put_ bh ns - put_ bh span - - get bh = do - (t :: Word8) <- get bh - case t of - 0 -> ResolvedScopes <$> get bh - 1 -> UnresolvedScope <$> get bh <*> get bh - _ -> panic "Binary TyVarScope: invalid tag" diff --git a/hieFile/HieUtils.hs b/hieFile/HieUtils.hs deleted file mode 100644 --- a/hieFile/HieUtils.hs +++ /dev/null @@ -1,455 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -module HieUtils where - -import GhcPrelude - -import CoreMap -import DynFlags ( DynFlags ) -import FastString ( FastString, mkFastString ) -import IfaceType -import Name hiding (varName) -import Outputable ( renderWithStyle, ppr, defaultUserStyle ) -import SrcLoc -import ToIface -import TyCon -import TyCoRep -import Type -import Var -import VarEnv - -import HieTypes - -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.IntMap.Strict as IM -import qualified Data.Array as A -import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) ) -import Data.Maybe ( maybeToList ) -import Data.Monoid -import Data.Traversable ( for ) -import Control.Monad.Trans.State.Strict hiding (get) - - -generateReferencesMap - :: Foldable f - => f (HieAST a) - -> M.Map Identifier [(Span, IdentifierDetails a)] -generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty - where - go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) - where - this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast - -renderHieType :: DynFlags -> HieTypeFix -> String -renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty - where sty = defaultUserStyle df - -resolveVisibility :: Type -> [Type] -> [(Bool,Type)] -resolveVisibility kind ty_args - = go (mkEmptyTCvSubst in_scope) kind ty_args - where - in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) - - go _ _ [] = [] - go env ty ts - | Just ty' <- coreView ty - = go env ty' ts - go env (ForAllTy (Bndr tv vis) res) (t:ts) - | isVisibleArgFlag vis = (True , t) : ts' - | otherwise = (False, t) : ts' - where - ts' = go (extendTvSubst env tv t) res ts - - go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps - = (True,t) : (go env res ts) - - go env (TyVarTy tv) ts - | Just ki <- lookupTyVar env tv = go env ki ts - go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded - -foldType :: (HieType a -> a) -> HieTypeFix -> a -foldType f (Roll t) = f $ fmap (foldType f) t - -hieTypeToIface :: HieTypeFix -> IfaceType -hieTypeToIface = foldType go - where - go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n - go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) - go (HLitTy l) = IfaceLitTy l - go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) - in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t - go (HFunTy a b) = IfaceFunTy VisArg a b - go (HQualTy pred b) = IfaceFunTy InvisArg pred b - go (HCastTy a) = a - go HCoercionTy = IfaceTyVar "" - go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) - - -- This isn't fully faithful - we can't produce the 'Inferred' case - hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs - hieToIfaceArgs (HieArgs xs) = go' xs - where - go' [] = IA_Nil - go' ((True ,x):xs) = IA_Arg x Required $ go' xs - go' ((False,x):xs) = IA_Arg x Specified $ go' xs - -data HieTypeState - = HTS - { tyMap :: !(TypeMap TypeIndex) - , htyTable :: !(IM.IntMap HieTypeFlat) - , freshIndex :: !TypeIndex - } - -initialHTS :: HieTypeState -initialHTS = HTS emptyTypeMap IM.empty 0 - -freshTypeIndex :: State HieTypeState TypeIndex -freshTypeIndex = do - index <- gets freshIndex - modify' $ \hts -> hts { freshIndex = index+1 } - return index - -compressTypes - :: HieASTs Type - -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) -compressTypes asts = (a, arr) - where - (a, (HTS _ m i)) = flip runState initialHTS $ - for asts $ \typ -> do - i <- getTypeIndex typ - return i - arr = A.array (0,i-1) (IM.toList m) - -recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix -recoverFullType i m = go i - where - go i = Roll $ fmap go (m A.! i) - -getTypeIndex :: Type -> State HieTypeState TypeIndex -getTypeIndex t - | otherwise = do - tm <- gets tyMap - case lookupTypeMap tm t of - Just i -> return i - Nothing -> do - ht <- go t - extendHTS t ht - where - extendHTS t ht = do - i <- freshTypeIndex - modify' $ \(HTS tm tt fi) -> - HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi - return i - - go (TyVarTy v) = return $ HTyVarTy $ varName v - go ty@(AppTy _ _) = do - let (head,args) = splitAppTys ty - visArgs = HieArgs $ resolveVisibility (typeKind head) args - ai <- getTypeIndex head - argsi <- mapM getTypeIndex visArgs - return $ HAppTy ai argsi - go (TyConApp f xs) = do - let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs - is <- mapM getTypeIndex visArgs - return $ HTyConApp (toIfaceTyCon f) is - go (ForAllTy (Bndr v a) t) = do - k <- getTypeIndex (varType v) - i <- getTypeIndex t - return $ HForAllTy ((varName v,k),a) i - go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do - ai <- getTypeIndex a - bi <- getTypeIndex b - return $ case af of - InvisArg -> HQualTy ai bi - VisArg -> HFunTy ai bi - go (LitTy a) = return $ HLitTy $ toIfaceTyLit a - go (CastTy t _) = do - i <- getTypeIndex t - return $ HCastTy i - go (CoercionTy _) = return HCoercionTy - -resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a) -resolveTyVarScopes asts = M.map go asts - where - go ast = resolveTyVarScopeLocal ast asts - -resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a -resolveTyVarScopeLocal ast asts = go ast - where - resolveNameScope dets = dets{identInfo = - S.map resolveScope (identInfo dets)} - resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) = - TyVarBind sc $ ResolvedScopes - [ LocalScope binding - | name <- names - , Just binding <- [getNameBinding name asts] - ] - resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) = - TyVarBind sc $ ResolvedScopes - [ LocalScope binding - | name <- names - , Just binding <- [getNameBindingInClass name sp asts] - ] - resolveScope scope = scope - go (Node info span children) = Node info' span $ map go children - where - info' = info { nodeIdentifiers = idents } - idents = M.map resolveNameScope $ nodeIdentifiers info - -getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span -getNameBinding n asts = do - (_,msp) <- getNameScopeAndBinding n asts - msp - -getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope] -getNameScope n asts = do - (scopes,_) <- getNameScopeAndBinding n asts - return scopes - -getNameBindingInClass - :: Name - -> Span - -> M.Map FastString (HieAST a) - -> Maybe Span -getNameBindingInClass n sp asts = do - ast <- M.lookup (srcSpanFile sp) asts - getFirst $ foldMap First $ do - child <- flattenAst ast - dets <- maybeToList - $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child - let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) - return (getFirst binding) - -getNameScopeAndBinding - :: Name - -> M.Map FastString (HieAST a) - -> Maybe ([Scope], Maybe Span) -getNameScopeAndBinding n asts = case nameSrcSpan n of - RealSrcSpan sp -> do -- @Maybe - ast <- M.lookup (srcSpanFile sp) asts - defNode <- selectLargestContainedBy sp ast - getFirst $ foldMap First $ do -- @[] - node <- flattenAst defNode - dets <- maybeToList - $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node - scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) - let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) - return $ Just (scopes, getFirst binding) - _ -> Nothing - -getScopeFromContext :: ContextInfo -> Maybe [Scope] -getScopeFromContext (ValBind _ sc _) = Just [sc] -getScopeFromContext (PatternBind a b _) = Just [a, b] -getScopeFromContext (ClassTyDecl _) = Just [ModuleScope] -getScopeFromContext (Decl _ _) = Just [ModuleScope] -getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs -getScopeFromContext (TyVarBind a _) = Just [a] -getScopeFromContext _ = Nothing - -getBindSiteFromContext :: ContextInfo -> Maybe Span -getBindSiteFromContext (ValBind _ _ sp) = sp -getBindSiteFromContext (PatternBind _ _ sp) = sp -getBindSiteFromContext _ = Nothing - -flattenAst :: HieAST a -> [HieAST a] -flattenAst n = - n : concatMap flattenAst (nodeChildren n) - -smallestContainingSatisfying - :: Span - -> (HieAST a -> Bool) - -> HieAST a - -> Maybe (HieAST a) -smallestContainingSatisfying sp cond node - | nodeSpan node `containsSpan` sp = getFirst $ mconcat - [ foldMap (First . smallestContainingSatisfying sp cond) $ - nodeChildren node - , First $ if cond node then Just node else Nothing - ] - | sp `containsSpan` nodeSpan node = Nothing - | otherwise = Nothing - -selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a) -selectLargestContainedBy sp node - | sp `containsSpan` nodeSpan node = Just node - | nodeSpan node `containsSpan` sp = - getFirst $ foldMap (First . selectLargestContainedBy sp) $ - nodeChildren node - | otherwise = Nothing - -selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a) -selectSmallestContaining sp node - | nodeSpan node `containsSpan` sp = getFirst $ mconcat - [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node - , First (Just node) - ] - | sp `containsSpan` nodeSpan node = Nothing - | otherwise = Nothing - -definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool -definedInAsts asts n = case nameSrcSpan n of - RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts - _ -> False - -isOccurrence :: ContextInfo -> Bool -isOccurrence Use = True -isOccurrence _ = False - -scopeContainsSpan :: Scope -> Span -> Bool -scopeContainsSpan NoScope _ = False -scopeContainsSpan ModuleScope _ = True -scopeContainsSpan (LocalScope a) b = a `containsSpan` b - --- | One must contain the other. Leaf nodes cannot contain anything -combineAst :: HieAST Type -> HieAST Type -> HieAST Type -combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys) - | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys) - | aSpn `containsSpan` bSpn = combineAst b a -combineAst a (Node xs span children) = Node xs span (insertAst a children) - --- | Insert an AST in a sorted list of disjoint Asts -insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type] -insertAst x = mergeAsts [x] - --- | Merge two nodes together. --- --- Precondition and postcondition: elements in 'nodeType' are ordered. -combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type -(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) = - NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) - where - mergeSorted :: [Type] -> [Type] -> [Type] - mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of - LT -> a : mergeSorted as lb - EQ -> a : mergeSorted as bs - GT -> b : mergeSorted la bs - mergeSorted as [] = as - mergeSorted [] bs = bs - - -{- | Merge two sorted, disjoint lists of ASTs, combining when necessary. - -In the absence of position-altering pragmas (ex: @# line "file.hs" 3@), -different nodes in an AST tree should either have disjoint spans (in -which case you can say for sure which one comes first) or one span -should be completely contained in the other (in which case the contained -span corresponds to some child node). - -However, since Haskell does have position-altering pragmas it /is/ -possible for spans to be overlapping. Here is an example of a source file -in which @foozball@ and @quuuuuux@ have overlapping spans: - -@ -module Baz where - -# line 3 "Baz.hs" -foozball :: Int -foozball = 0 - -# line 3 "Baz.hs" -bar, quuuuuux :: Int -bar = 1 -quuuuuux = 2 -@ - -In these cases, we just do our best to produce sensible `HieAST`'s. The blame -should be laid at the feet of whoever wrote the line pragmas in the first place -(usually the C preprocessor...). --} -mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type] -mergeAsts xs [] = xs -mergeAsts [] ys = ys -mergeAsts xs@(a:as) ys@(b:bs) - | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs - | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs) - | span_a `rightOf` span_b = b : mergeAsts xs bs - | span_a `leftOf` span_b = a : mergeAsts as ys - - -- These cases are to work around ASTs that are not fully disjoint - | span_a `startsRightOf` span_b = b : mergeAsts as ys - | otherwise = a : mergeAsts as ys - where - span_a = nodeSpan a - span_b = nodeSpan b - -rightOf :: Span -> Span -> Bool -rightOf s1 s2 - = (srcSpanStartLine s1, srcSpanStartCol s1) - >= (srcSpanEndLine s2, srcSpanEndCol s2) - && (srcSpanFile s1 == srcSpanFile s2) - -leftOf :: Span -> Span -> Bool -leftOf s1 s2 - = (srcSpanEndLine s1, srcSpanEndCol s1) - <= (srcSpanStartLine s2, srcSpanStartCol s2) - && (srcSpanFile s1 == srcSpanFile s2) - -startsRightOf :: Span -> Span -> Bool -startsRightOf s1 s2 - = (srcSpanStartLine s1, srcSpanStartCol s1) - >= (srcSpanStartLine s2, srcSpanStartCol s2) - --- | combines and sorts ASTs using a merge sort -mergeSortAsts :: [HieAST Type] -> [HieAST Type] -mergeSortAsts = go . map pure - where - go [] = [] - go [xs] = xs - go xss = go (mergePairs xss) - mergePairs [] = [] - mergePairs [xs] = [xs] - mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss - -simpleNodeInfo :: FastString -> FastString -> NodeInfo a -simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty - -locOnly :: SrcSpan -> [HieAST a] -locOnly (RealSrcSpan span) = - [Node e span []] - where e = NodeInfo S.empty [] M.empty -locOnly _ = [] - -mkScope :: SrcSpan -> Scope -mkScope (RealSrcSpan sp) = LocalScope sp -mkScope _ = NoScope - -mkLScope :: Located a -> Scope -mkLScope = mkScope . getLoc - -combineScopes :: Scope -> Scope -> Scope -combineScopes ModuleScope _ = ModuleScope -combineScopes _ ModuleScope = ModuleScope -combineScopes NoScope x = x -combineScopes x NoScope = x -combineScopes (LocalScope a) (LocalScope b) = - mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b) - -{-# INLINEABLE makeNode #-} -makeNode - :: (Applicative m, Data a) - => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') - -> SrcSpan -- ^ return an empty list if this is unhelpful - -> m [HieAST b] -makeNode x spn = pure $ case spn of - RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []] - _ -> [] - where - cons = mkFastString . show . toConstr $ x - typ = mkFastString . show . typeRepTyCon . typeOf $ x - -{-# INLINEABLE makeTypeNode #-} -makeTypeNode - :: (Applicative m, Data a) - => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') - -> SrcSpan -- ^ return an empty list if this is unhelpful - -> Type -- ^ type to associate with the node - -> m [HieAST Type] -makeTypeNode x spn etyp = pure $ case spn of - RealSrcSpan span -> - [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []] - _ -> [] - where - cons = mkFastString . show . toConstr $ x - typ = mkFastString . show . typeRepTyCon . typeOf $ x diff --git a/iface/BinFingerprint.hs b/iface/BinFingerprint.hs deleted file mode 100644 --- a/iface/BinFingerprint.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Computing fingerprints of values serializeable with GHC's "Binary" module. -module BinFingerprint - ( -- * Computing fingerprints - fingerprintBinMem - , computeFingerprint - , putNameLiterally - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Fingerprint -import Binary -import Name -import PlainPanic -import Util - -fingerprintBinMem :: BinHandle -> IO Fingerprint -fingerprintBinMem bh = withBinBuffer bh f - where - f bs = - -- we need to take care that we force the result here - -- lest a reference to the ByteString may leak out of - -- withBinBuffer. - let fp = fingerprintByteString bs - in fp `seq` return fp - -computeFingerprint :: (Binary a) - => (BinHandle -> Name -> IO ()) - -> a - -> IO Fingerprint -computeFingerprint put_nonbinding_name a = do - bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block - put_ bh a - fp <- fingerprintBinMem bh - return fp - where - set_user_data bh = - setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS - --- | Used when we want to fingerprint a structure without depending on the --- fingerprints of external Names that it refers to. -putNameLiterally :: BinHandle -> Name -> IO () -putNameLiterally bh name = ASSERT( isExternalName name ) do - put_ bh $! nameModule name - put_ bh $! nameOccName name diff --git a/iface/BinIface.hs b/iface/BinIface.hs deleted file mode 100644 --- a/iface/BinIface.hs +++ /dev/null @@ -1,435 +0,0 @@ -{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-} - --- --- (c) The University of Glasgow 2002-2006 --- - -{-# OPTIONS_GHC -O2 #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- | Binary interface file support. -module BinIface ( - -- * Public API for interface file serialisation - writeBinIface, - readBinIface, - getSymtabName, - getDictFastString, - CheckHiWay(..), - TraceBinIFaceReading(..), - getWithUserData, - putWithUserData, - - -- * Internal serialisation functions - getSymbolTable, - putName, - putDictionary, - putFastString, - putSymbolTable, - BinSymbolTable(..), - BinDictionary(..) - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) -import IfaceEnv -import HscTypes -import Module -import Name -import DynFlags -import UniqFM -import UniqSupply -import Panic -import Binary -import SrcLoc -import ErrUtils -import FastMutInt -import Unique -import Outputable -import NameCache -import GHC.Platform -import FastString -import Constants -import Util - -import Data.Array -import Data.Array.ST -import Data.Array.Unsafe -import Data.Bits -import Data.Char -import Data.Word -import Data.IORef -import Data.Foldable -import Control.Monad -import Control.Monad.ST -import Control.Monad.Trans.Class -import qualified Control.Monad.Trans.State.Strict as State - --- --------------------------------------------------------------------------- --- Reading and writing binary interface files --- - -data CheckHiWay = CheckHiWay | IgnoreHiWay - deriving Eq - -data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading - deriving Eq - --- | Read an interface file -readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath - -> TcRnIf a b ModIface -readBinIface checkHiWay traceBinIFaceReading hi_path = do - ncu <- mkNameCacheUpdater - dflags <- getDynFlags - liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu - -readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath - -> NameCacheUpdater - -> IO ModIface -readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do - let printer :: SDoc -> IO () - printer = case traceBinIFaceReading of - TraceBinIFaceReading -> \sd -> - putLogMsg dflags - NoReason - SevOutput - noSrcSpan - (defaultDumpStyle dflags) - sd - QuietBinIFaceReading -> \_ -> return () - - wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () - wantedGot what wanted got ppr' = - printer (text what <> text ": " <> - vcat [text "Wanted " <> ppr' wanted <> text ",", - text "got " <> ppr' got]) - - errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () - errorOnMismatch what wanted got = - -- This will be caught by readIface which will emit an error - -- msg containing the iface module name. - when (wanted /= got) $ throwGhcExceptionIO $ ProgramError - (what ++ " (wanted " ++ show wanted - ++ ", got " ++ show got ++ ")") - bh <- Binary.readBinMem hi_path - - -- Read the magic number to check that this really is a GHC .hi file - -- (This magic number does not change when we change - -- GHC interface file format) - magic <- get bh - wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr - errorOnMismatch "magic number mismatch: old/corrupt interface file?" - (binaryInterfaceMagic dflags) magic - - -- Note [dummy iface field] - -- read a dummy 32/64 bit value. This field used to hold the - -- dictionary pointer in old interface file formats, but now - -- the dictionary pointer is after the version (where it - -- should be). Also, the serialisation of value of type "Bin - -- a" used to depend on the word size of the machine, now they - -- are always 32 bits. - if wORD_SIZE dflags == 4 - then do _ <- Binary.get bh :: IO Word32; return () - else do _ <- Binary.get bh :: IO Word64; return () - - -- Check the interface file version and ways. - check_ver <- get bh - let our_ver = show hiVersion - wantedGot "Version" our_ver check_ver text - errorOnMismatch "mismatched interface file versions" our_ver check_ver - - check_way <- get bh - let way_descr = getWayDescr dflags - wantedGot "Way" way_descr check_way ppr - when (checkHiWay == CheckHiWay) $ - errorOnMismatch "mismatched interface file ways" way_descr check_way - getWithUserData ncu bh - - --- | This performs a get action after reading the dictionary and symbol --- table. It is necessary to run this before trying to deserialise any --- Names or FastStrings. -getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a -getWithUserData ncu bh = do - -- Read the dictionary - -- The next word in the file is a pointer to where the dictionary is - -- (probably at the end of the file) - dict_p <- Binary.get bh - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - seekBin bh data_p -- Back to where we were before - - -- Initialise the user-data field of bh - bh <- do - bh <- return $ setUserData bh $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab_p <- Binary.get bh -- Get the symtab ptr - data_p <- tellBin bh -- Remember where we are now - seekBin bh symtab_p - symtab <- getSymbolTable bh ncu - seekBin bh data_p -- Back to where we were before - - -- It is only now that we know how to get a Name - return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab) - (getDictFastString dict) - - -- Read the interface file - get bh - --- | Write an interface file -writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () -writeBinIface dflags hi_path mod_iface = do - bh <- openBinMem initBinMemSize - put_ bh (binaryInterfaceMagic dflags) - - -- dummy 32/64-bit field before the version/way for - -- compatibility with older interface file formats. - -- See Note [dummy iface field] above. - if wORD_SIZE dflags == 4 - then Binary.put_ bh (0 :: Word32) - else Binary.put_ bh (0 :: Word64) - - -- The version and way descriptor go next - put_ bh (show hiVersion) - let way_descr = getWayDescr dflags - put_ bh way_descr - - - putWithUserData (debugTraceMsg dflags 3) bh mod_iface - -- And send the result to the file - writeBinMem bh hi_path - --- | Put a piece of data with an initialised `UserData` field. This --- is necessary if you want to serialise Names or FastStrings. --- It also writes a symbol table and the dictionary. --- This segment should be read using `getWithUserData`. -putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO () -putWithUserData log_action bh payload = do - -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh - -- Placeholder for ptr to dictionary - put_ bh dict_p_p - - -- Remember where the symbol table pointer will go - symtab_p_p <- tellBin bh - put_ bh symtab_p_p - -- Make some initial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM - let bin_symtab = BinSymbolTable { - bin_symtab_next = symtab_next, - bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = BinDictionary { - bin_dict_next = dict_next_ref, - bin_dict_map = dict_map_ref } - - -- Put the main thing, - bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) - (putName bin_dict bin_symtab) - (putFastString bin_dict) - put_ bh payload - - -- Write the symtab pointer at the front of the file - symtab_p <- tellBin bh -- This is where the symtab will start - putAt bh symtab_p_p symtab_p -- Fill in the placeholder - seekBin bh symtab_p -- Seek back to the end of the file - - -- Write the symbol table itself - symtab_next <- readFastMutInt symtab_next - symtab_map <- readIORef symtab_map - putSymbolTable bh symtab_next symtab_map - log_action (text "writeBinIface:" <+> int symtab_next - <+> text "Names") - - -- NB. write the dictionary after the symbol table, because - -- writing the symbol table may create more dictionary entries. - - -- Write the dictionary pointer at the front of the file - dict_p <- tellBin bh -- This is where the dictionary will start - putAt bh dict_p_p dict_p -- Fill in the placeholder - seekBin bh dict_p -- Seek back to the end of the file - - -- Write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - log_action (text "writeBinIface:" <+> int dict_next - <+> text "dict entries") - - - --- | Initial ram buffer to allocate for writing interface files -initBinMemSize :: Int -initBinMemSize = 1024 * 1024 - -binaryInterfaceMagic :: DynFlags -> Word32 -binaryInterfaceMagic dflags - | target32Bit (targetPlatform dflags) = 0x1face - | otherwise = 0x1face64 - - --- ----------------------------------------------------------------------------- --- The symbol table --- - -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) - -- It's OK to use nonDetEltsUFM here because the elements have - -- indices that array uses to create order - mapM_ (\n -> serialiseName bh n symtab) names - -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable -getSymbolTable bh ncu = do - sz <- get bh - od_names <- sequence (replicate sz (get bh)) - updateNameCache ncu $ \namecache -> - runST $ flip State.evalStateT namecache $ do - mut_arr <- lift $ newSTArray_ (0, sz-1) - for_ (zip [0..] od_names) $ \(i, odn) -> do - (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn - lift $ writeArray mut_arr i n - State.put nc - arr <- lift $ unsafeFreeze mut_arr - namecache' <- State.get - return (namecache', arr) - where - -- This binding is required because the type of newArray_ cannot be inferred - newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name) - newSTArray_ = newArray_ - -type OnDiskName = (UnitId, ModuleName, OccName) - -fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name) -fromOnDiskName nc (pid, mod_name, occ) = - let mod = mkModule pid mod_name - cache = nsNames nc - in case lookupOrigNameCache cache mod occ of - Just name -> (nc, name) - Nothing -> - let (uniq, us) = takeUniqFromSupply (nsUniqs nc) - name = mkExternalName uniq mod occ noSrcSpan - new_cache = extendNameCache cache mod occ name - in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) - -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () -serialiseName bh name _ = do - let mod = ASSERT2( isExternalName name, ppr name ) nameModule name - put_ bh (moduleUnitId mod, moduleName mod, nameOccName name) - - --- Note [Symbol table representation of names] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- An occurrence of a name in an interface file is serialized as a single 32-bit --- word. The format of this word is: --- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx --- A normal name. x is an index into the symbol table --- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy --- A known-key name. x is the Unique's Char, y is the int part. We assume that --- all known-key uniques fit in this space. This is asserted by --- PrelInfo.knownKeyNamesOkay. --- --- During serialization we check for known-key things using isKnownKeyName. --- During deserialization we use lookupKnownKeyName to get from the unique back --- to its corresponding Name. - - --- See Note [Symbol table representation of names] -putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () -putName _dict BinSymbolTable{ - bin_symtab_map = symtab_map_ref, - bin_symtab_next = symtab_next } - bh name - | isKnownKeyName name - , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits - = -- ASSERT(u < 2^(22 :: Int)) - put_ bh (0x80000000 - .|. (fromIntegral (ord c) `shiftL` 22) - .|. (fromIntegral u :: Word32)) - - | otherwise - = do symtab_map <- readIORef symtab_map_ref - case lookupUFM symtab_map name of - Just (off,_) -> put_ bh (fromIntegral off :: Word32) - Nothing -> do - off <- readFastMutInt symtab_next - -- MASSERT(off < 2^(30 :: Int)) - writeFastMutInt symtab_next (off+1) - writeIORef symtab_map_ref - $! addToUFM symtab_map name (off,name) - put_ bh (fromIntegral off :: Word32) - --- See Note [Symbol table representation of names] -getSymtabName :: NameCacheUpdater - -> Dictionary -> SymbolTable - -> BinHandle -> IO Name -getSymtabName _ncu _dict symtab bh = do - i :: Word32 <- get bh - case i .&. 0xC0000000 of - 0x00000000 -> return $! symtab ! fromIntegral i - - 0x80000000 -> - let - tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) - ix = fromIntegral i .&. 0x003FFFFF - u = mkUnique tag ix - in - return $! case lookupKnownKeyName u of - Nothing -> pprPanic "getSymtabName:unknown known-key unique" - (ppr i $$ ppr (unpkUnique u)) - Just n -> n - - _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) - -data BinSymbolTable = BinSymbolTable { - bin_symtab_next :: !FastMutInt, -- The next index to use - bin_symtab_map :: !(IORef (UniqFM (Int,Name))) - -- indexed by Name - } - -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString dict bh fs = allocateFastString dict fs >>= put_ bh - -allocateFastString :: BinDictionary -> FastString -> IO Word32 -allocateFastString BinDictionary { bin_dict_next = j_r, - bin_dict_map = out_r} f = do - out <- readIORef out_r - let uniq = getUnique f - case lookupUFM out uniq of - Just (j, _) -> return (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out uniq (j, f) - return (fromIntegral j :: Word32) - -getDictFastString :: Dictionary -> BinHandle -> IO FastString -getDictFastString dict bh = do - j <- get bh - return $! (dict ! fromIntegral (j :: Word32)) - -data BinDictionary = BinDictionary { - bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM (Int,FastString))) - -- indexed by FastString - } - -getWayDescr :: DynFlags -> String -getWayDescr dflags - | platformUnregisterised (targetPlatform dflags) = 'u':tag - | otherwise = tag - where tag = buildTag dflags - -- if this is an unregisterised build, make sure our interfaces - -- can't be used by a registerised build. diff --git a/iface/BuildTyCl.hs b/iface/BuildTyCl.hs deleted file mode 100644 --- a/iface/BuildTyCl.hs +++ /dev/null @@ -1,416 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} - -module BuildTyCl ( - buildDataCon, - buildPatSyn, - TcMethInfo, MethInfo, buildClass, - mkNewTyConRhs, - newImplicitBinder, newTyConRepName - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import IfaceEnv -import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) -import TysWiredIn( isCTupleTyConName ) -import TysPrim ( voidPrimTy ) -import DataCon -import PatSyn -import Var -import VarSet -import BasicTypes -import Name -import NameEnv -import MkId -import Class -import TyCon -import Type -import Id -import TcType - -import SrcLoc( SrcSpan, noSrcSpan ) -import DynFlags -import TcRnMonad -import UniqSupply -import Util -import Outputable - - -mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs --- ^ Monadic because it makes a Name for the coercion TyCon --- We pass the Name of the parent TyCon, as well as the TyCon itself, --- because the latter is part of a knot, whereas the former is not. -mkNewTyConRhs tycon_name tycon con - = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs - ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) - ; return (NewTyCon { data_con = con, - nt_rhs = rhs_ty, - nt_etad_rhs = (etad_tvs, etad_rhs), - nt_co = nt_ax, - nt_lev_poly = isKindLevPoly res_kind } ) } - -- Coreview looks through newtypes with a Nothing - -- for nt_co, or uses explicit coercions otherwise - where - tvs = tyConTyVars tycon - roles = tyConRoles tycon - res_kind = tyConResKind tycon - con_arg_ty = case dataConRepArgTys con of - [arg_ty] -> arg_ty - tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) - rhs_ty = substTyWith (dataConUnivTyVars con) - (mkTyVarTys tvs) con_arg_ty - -- Instantiate the newtype's RHS with the - -- type variables from the tycon - -- NB: a newtype DataCon has a type that must look like - -- forall tvs. -> T tvs - -- Note that we *can't* use dataConInstOrigArgTys here because - -- the newtype arising from class Foo a => Bar a where {} - -- has a single argument (Foo a) that is a *type class*, so - -- dataConInstOrigArgTys returns []. - - etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can - etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty - etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface - (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty - - eta_reduce :: [TyVar] -- Reversed - -> [Role] -- also reversed - -> Type -- Rhs type - -> ([TyVar], [Role], Type) -- Eta-reduced version - -- (tyvars in normal order) - eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, - Just tv <- getTyVar_maybe arg, - tv == a, - not (a `elemVarSet` tyCoVarsOfType fun) - = eta_reduce as rs fun - eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) - ------------------------------------------------------- -buildDataCon :: FamInstEnvs - -> Name - -> Bool -- Declared infix - -> TyConRepName - -> [HsSrcBang] - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] in MkId - -> [FieldLabel] -- Field labels - -> [TyVar] -- Universals - -> [TyCoVar] -- Existentials - -> [TyVarBinder] -- User-written 'TyVarBinder's - -> [EqSpec] -- Equality spec - -> KnotTied ThetaType -- Does not include the "stupid theta" - -- or the GADT equalities - -> [KnotTied Type] -- Arguments - -> KnotTied Type -- Result types - -> KnotTied TyCon -- Rep tycon - -> NameEnv ConTag -- Maps the Name of each DataCon to its - -- ConTag - -> TcRnIf m n DataCon --- A wrapper for DataCon.mkDataCon that --- a) makes the worker Id --- b) makes the wrapper Id if necessary, including --- allocating its unique (hence monadic) -buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs - field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty - rep_tycon tag_map - = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc - ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc - -- This last one takes the name of the data constructor in the source - -- code, which (for Haskell source anyway) will be in the DataName name - -- space, and puts it into the VarName name space - - ; traceIf (text "buildDataCon 1" <+> ppr src_name) - ; us <- newUniqueSupply - ; dflags <- getDynFlags - ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs - tag = lookupNameEnv_NF tag_map src_name - -- See Note [Constructor tag allocation], fixes #14657 - data_con = mkDataCon src_name declared_infix prom_info - src_bangs field_lbls - univ_tvs ex_tvs user_tvbs eq_spec ctxt - arg_tys res_ty NoRRI rep_tycon tag - stupid_ctxt dc_wrk dc_rep - dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name - impl_bangs data_con) - - ; traceIf (text "buildDataCon 2" <+> ppr src_name) - ; return data_con } - - --- The stupid context for a data constructor should be limited to --- the type variables mentioned in the arg_tys --- ToDo: Or functionally dependent on? --- This whole stupid theta thing is, well, stupid. -mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] -mkDataConStupidTheta tycon arg_tys univ_tvs - | null stupid_theta = [] -- The common case - | otherwise = filter in_arg_tys stupid_theta - where - tc_subst = zipTvSubst (tyConTyVars tycon) - (mkTyVarTys univ_tvs) - stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) - -- Start by instantiating the master copy of the - -- stupid theta, taken from the TyCon - - arg_tyvars = tyCoVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ - tyCoVarsOfType pred `intersectVarSet` arg_tyvars - - ------------------------------------------------------- -buildPatSyn :: Name -> Bool - -> (Id,Bool) -> Maybe (Id, Bool) - -> ([TyVarBinder], ThetaType) -- ^ Univ and req - -> ([TyVarBinder], ThetaType) -- ^ Ex and prov - -> [Type] -- ^ Argument types - -> Type -- ^ Result type - -> [FieldLabel] -- ^ Field labels for - -- a record pattern synonym - -> PatSyn -buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder - (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys - pat_ty field_labels - = -- The assertion checks that the matcher is - -- compatible with the pattern synonym - ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 - , ex_tvs `equalLength` ex_tvs1 - , pat_ty `eqType` substTy subst pat_ty1 - , prov_theta `eqTypes` substTys subst prov_theta1 - , req_theta `eqTypes` substTys subst req_theta1 - , compareArgTys arg_tys (substTys subst arg_tys1) - ]) - , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 - , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 - , ppr pat_ty <+> twiddle <+> ppr pat_ty1 - , ppr prov_theta <+> twiddle <+> ppr prov_theta1 - , ppr req_theta <+> twiddle <+> ppr req_theta1 - , ppr arg_tys <+> twiddle <+> ppr arg_tys1])) - mkPatSyn src_name declared_infix - (univ_tvs, req_theta) (ex_tvs, prov_theta) - arg_tys pat_ty - matcher builder field_labels - where - ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id - ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau - (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma - (arg_tys1, _) = (tcSplitFunTys cont_tau) - twiddle = char '~' - subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) - (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) - - -- For a nullary pattern synonym we add a single void argument to the - -- matcher to preserve laziness in the case of unlifted types. - -- See #12746 - compareArgTys :: [Type] -> [Type] -> Bool - compareArgTys [] [x] = x `eqType` voidPrimTy - compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys - - ------------------------------------------------------- -type TcMethInfo = MethInfo -- this variant needs zonking -type MethInfo -- A temporary intermediate, to communicate - -- between tcClassSigs and buildClass. - = ( Name -- Name of the class op - , Type -- Type of the class op - , Maybe (DefMethSpec (SrcSpan, Type))) - -- Nothing => no default method - -- - -- Just VanillaDM => There is an ordinary - -- polymorphic default method - -- - -- Just (GenericDM (loc, ty)) => There is a generic default metho - -- Here is its type, and the location - -- of the type signature - -- We need that location /only/ to attach it to the - -- generic default method's Name; and we need /that/ - -- only to give the right location of an ambiguity error - -- for the generic default method, spat out by checkValidClass - -buildClass :: Name -- Name of the class/tycon (they have the same Name) - -> [TyConBinder] -- Of the tycon - -> [Role] - -> [FunDep TyVar] -- Functional dependencies - -- Super classes, associated types, method info, minimal complete def. - -- This is Nothing if the class is abstract. - -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef) - -> TcRnIf m n Class - -buildClass tycon_name binders roles fds Nothing - = fixM $ \ rec_clas -> -- Only name generation inside loop - do { traceIf (text "buildClass") - - ; tc_rep_name <- newTyConRepName tycon_name - ; let univ_tvs = binderVars binders - tycon = mkClassTyCon tycon_name binders roles - AbstractTyCon rec_clas tc_rep_name - result = mkAbstractClass tycon_name univ_tvs fds tycon - ; traceIf (text "buildClass" <+> ppr tycon) - ; return result } - -buildClass tycon_name binders roles fds - (Just (sc_theta, at_items, sig_stuff, mindef)) - = fixM $ \ rec_clas -> -- Only name generation inside loop - do { traceIf (text "buildClass") - - ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc - ; tc_rep_name <- newTyConRepName tycon_name - - ; op_items <- mapM (mk_op_item rec_clas) sig_stuff - -- Build the selector id and default method id - - -- Make selectors for the superclasses - ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) - (takeList sc_theta [fIRST_TAG..]) - ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas - | sc_name <- sc_sel_names] - -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we - -- can construct names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - - ; let use_newtype = isSingleton arg_tys - -- Use a newtype if the data constructor - -- (a) has exactly one value field - -- i.e. exactly one operation or superclass taken together - -- (b) that value is of lifted type (which they always are, because - -- we box equality superclasses) - -- See note [Class newtypes and equality predicates] - - -- We treat the dictionary superclasses as ordinary arguments. - -- That means that in the case of - -- class C a => D a - -- we don't get a newtype with no arguments! - args = sc_sel_names ++ op_names - op_tys = [ty | (_,ty,_) <- sig_stuff] - op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = sc_theta ++ op_tys - rec_tycon = classTyCon rec_clas - univ_bndrs = tyConTyVarBinders binders - univ_tvs = binderVars univ_bndrs - - ; rep_nm <- newTyConRepName datacon_name - ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") - datacon_name - False -- Not declared infix - rep_nm - (map (const no_bang) args) - (Just (map (const HsLazy) args)) - [{- No fields -}] - univ_tvs - [{- no existentials -}] - univ_bndrs - [{- No GADT equalities -}] - [{- No theta -}] - arg_tys - (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) - rec_tycon - (mkTyConTagMap rec_tycon) - - ; rhs <- case () of - _ | use_newtype - -> mkNewTyConRhs tycon_name rec_tycon dict_con - | isCTupleTyConName tycon_name - -> return (TupleTyCon { data_con = dict_con - , tup_sort = ConstraintTuple }) - | otherwise - -> return (mkDataTyConRhs [dict_con]) - - ; let { tycon = mkClassTyCon tycon_name binders roles - rhs rec_clas tc_rep_name - -- A class can be recursive, and in the case of newtypes - -- this matters. For example - -- class C a where { op :: C b => a -> b -> Int } - -- Because C has only one operation, it is represented by - -- a newtype, and it should be a *recursive* newtype. - -- [If we don't make it a recursive newtype, we'll expand the - -- newtype like a synonym, but that will lead to an infinite - -- type] - - ; result = mkClass tycon_name univ_tvs fds - sc_theta sc_sel_ids at_items - op_items mindef tycon - } - ; traceIf (text "buildClass" <+> ppr tycon) - ; return result } - where - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem - mk_op_item rec_clas (op_name, _, dm_spec) - = do { dm_info <- mk_dm_info op_name dm_spec - ; return (mkDictSelId op_name rec_clas, dm_info) } - - mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type)) - -> TcRnIf n m (Maybe (Name, DefMethSpec Type)) - mk_dm_info _ Nothing - = return Nothing - mk_dm_info op_name (Just VanillaDM) - = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc - ; return (Just (dm_name, VanillaDM)) } - mk_dm_info op_name (Just (GenericDM (loc, dm_ty))) - = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc - ; return (Just (dm_name, GenericDM dm_ty)) } - -{- -Note [Class newtypes and equality predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class (a ~ F b) => C a b where - op :: a -> b - -We cannot represent this by a newtype, even though it's not -existential, because there are two value fields (the equality -predicate and op. See #2238 - -Moreover, - class (a ~ F b) => C a b where {} -Here we can't use a newtype either, even though there is only -one field, because equality predicates are unboxed, and classes -are boxed. --} - -newImplicitBinder :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> TcRnIf m n Name -- Implicit name --- Called in BuildTyCl to allocate the implicit binders of type/class decls --- For source type/class decls, this is the first occurrence --- For iface ones, the LoadIface has already allocated a suitable name in the cache -newImplicitBinder base_name mk_sys_occ - = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name) - -newImplicitBinderLoc :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> SrcSpan - -> TcRnIf m n Name -- Implicit name --- Just the same, but lets you specify the SrcSpan -newImplicitBinderLoc base_name mk_sys_occ loc - | Just mod <- nameModule_maybe base_name - = newGlobalBinder mod occ loc - | otherwise -- When typechecking a [d| decl bracket |], - -- TH generates types, classes etc with Internal names, - -- so we follow suit for the implicit binders - = do { uniq <- newUnique - ; return (mkInternalName uniq occ loc) } - where - occ = mk_sys_occ (nameOccName base_name) - --- | Make the 'TyConRepName' for this 'TyCon' -newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName -newTyConRepName tc_name - | Just mod <- nameModule_maybe tc_name - , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) - = newGlobalBinder mod occ noSrcSpan - | otherwise - = newImplicitBinder tc_name mkTyConRepOcc diff --git a/iface/FlagChecker.hs b/iface/FlagChecker.hs deleted file mode 100644 --- a/iface/FlagChecker.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | This module manages storing the various GHC option flags in a modules --- interface file as part of the recompilation checking infrastructure. -module FlagChecker ( - fingerprintDynFlags - , fingerprintOptFlags - , fingerprintHpcFlags - ) where - -import GhcPrelude - -import Binary -import DynFlags -import HscTypes -import Module -import Name -import Fingerprint -import BinFingerprint --- import Outputable - -import qualified EnumSet -import System.FilePath (normalise) - --- | Produce a fingerprint of a @DynFlags@ value. We only base --- the finger print on important fields in @DynFlags@ so that --- the recompilation checker can use this fingerprint. --- --- NB: The 'Module' parameter is the 'Module' recorded by the --- *interface* file, not the actual 'Module' according to our --- 'DynFlags'. -fingerprintDynFlags :: DynFlags -> Module - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint - -fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = - let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing - -- see #5878 - -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) - safeHs = setSafeMode safeHaskell - -- oflags = sort $ filter filterOFlags $ flags dflags - - -- *all* the extension flags and the language - lang = (fmap fromEnum language, - map fromEnum $ EnumSet.toList extensionFlags) - - -- -I, -D and -U flags affect CPP - cpp = ( map normalise $ flattenIncludes includePaths - -- normalise: eliminate spurious differences due to "./foo" vs "foo" - , picPOpts dflags - , opt_P_signature dflags) - -- See Note [Repeated -optP hashing] - - -- Note [path flags and recompilation] - paths = [ hcSuf ] - - -- -fprof-auto etc. - prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 - - -- Ticky - ticky = - map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] - - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel)) - - in -- pprTrace "flags" (ppr flags) $ - computeFingerprint nameio flags - --- Fingerprint the optimisation info. We keep this separate from the rest of --- the flags because GHCi users (especially) may wish to ignore changes in --- optimisation level or optimisation flags so as to use as many pre-existing --- object files as they can. --- See Note [Ignoring some flag changes] -fingerprintOptFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint -fingerprintOptFlags DynFlags{..} nameio = - let - -- See https://gitlab.haskell.org/ghc/ghc/issues/10923 - -- We used to fingerprint the optimisation level, but as Joachim - -- Breitner pointed out in comment 9 on that ticket, it's better - -- to ignore that and just look at the individual optimisation flags. - opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags) - (EnumSet.toList generalFlags) - - in computeFingerprint nameio opt_flags - --- Fingerprint the HPC info. We keep this separate from the rest of --- the flags because GHCi users (especially) may wish to use an object --- file compiled for HPC when not actually using HPC. --- See Note [Ignoring some flag changes] -fingerprintHpcFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint -fingerprintHpcFlags dflags@DynFlags{..} nameio = - let - -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798 - -- hpcDir is output-only, so we should recompile if it changes - hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing - - in computeFingerprint nameio hpc - - -{- Note [path flags and recompilation] - -There are several flags that we deliberately omit from the -recompilation check; here we explain why. - --osuf, -odir, -hisuf, -hidir - If GHC decides that it does not need to recompile, then - it must have found an up-to-date .hi file and .o file. - There is no point recording these flags - the user must - have passed the correct ones. Indeed, the user may - have compiled the source file in one-shot mode using - -o to specify the .o file, and then loaded it in GHCi - using -odir. - --stubdir - We omit this one because it is automatically set by -outputdir, and - we don't want changes in -outputdir to automatically trigger - recompilation. This could be wrong, but only in very rare cases. - --i (importPaths) - For the same reason as -osuf etc. above: if GHC decides not to - recompile, then it must have already checked all the .hi files on - which the current module depends, so it must have found them - successfully. It is occasionally useful to be able to cd to a - different directory and use -i flags to enable GHC to find the .hi - files; we don't want this to force recompilation. - -The only path-related flag left is -hcsuf. --} - -{- Note [Ignoring some flag changes] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Normally, --make tries to reuse only compilation products that are -the same as those that would have been produced compiling from -scratch. Sometimes, however, users would like to be more aggressive -about recompilation avoidance. This is particularly likely when -developing using GHCi (see #13604). Currently, we allow users to -ignore optimisation changes using -fignore-optim-changes, and to -ignore HPC option changes using -fignore-hpc-changes. If there's a -demand for it, we could also allow changes to -fprof-auto-* flags -(although we can't allow -prof flags to differ). The key thing about -these options is that we can still successfully link a library or -executable when some of its components differ in these ways. - -The way we accomplish this is to leave the optimization and HPC -options out of the flag hash, hashing them separately. --} - -{- Note [Repeated -optP hashing] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We invoke fingerprintDynFlags for each compiled module to include -the hash of relevant DynFlags in the resulting interface file. --optP (preprocessor) flags are part of that hash. --optP flags can come from multiple places: - - 1. -optP flags directly passed on command line. - 2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof. - 3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file. - -When compiling many modules at once with many -optP command line arguments -the work of hashing -optP flags would be repeated. This can get expensive -and as noted on #14697 it can take 7% of time and 14% of allocations on -a real codebase. - -The obvious solution is to cache the hash of -optP flags per GHC invocation. -However, one has to be careful there, as the flags that were added in 3. way -have to be accounted for. - -The current strategy is as follows: - - 1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p - is modified. This serves dual purpose. It ensures correctness for when - we add per file -optP flags and lets us save work for when we don't. - 2. When computing the fingerprint in fingerprintDynFlags use the cached - value *and* fingerprint the additional implied (see 2. above) -optP flags. - This is relatively cheap and saves the headache of fingerprinting all - the -optP flags and tracking all the places that could invalidate the - cache. --} diff --git a/iface/IfaceEnv.hs b/iface/IfaceEnv.hs deleted file mode 100644 --- a/iface/IfaceEnv.hs +++ /dev/null @@ -1,298 +0,0 @@ --- (c) The University of Glasgow 2002-2006 - -{-# LANGUAGE CPP, RankNTypes, BangPatterns #-} - -module IfaceEnv ( - newGlobalBinder, newInteractiveBinder, - externaliseName, - lookupIfaceTop, - lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache, - newIfaceName, newIfaceNames, - extendIfaceIdEnv, extendIfaceTyVarEnv, - tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, - lookupIfaceTyVar, extendIfaceEnvs, - setNameModule, - - ifaceExportNames, - - -- Name-cache stuff - allocateGlobalBinder, updNameCacheTc, - mkNameCacheUpdater, NameCacheUpdater(..), - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import HscTypes -import Type -import Var -import Name -import Avail -import Module -import FastString -import FastStringEnv -import IfaceType -import NameCache -import UniqSupply -import SrcLoc - -import Outputable -import Data.List ( partition ) - -{- -********************************************************* -* * - Allocating new Names in the Name Cache -* * -********************************************************* - -See Also: Note [The Name Cache] in NameCache --} - -newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name --- Used for source code and interface files, to make the --- Name for a thing, given its Module and OccName --- See Note [The Name Cache] --- --- The cache may already already have a binding for this thing, --- because we may have seen an occurrence before, but now is the --- moment when we know its Module and SrcLoc in their full glory - -newGlobalBinder mod occ loc - = do { name <- updNameCacheTc mod occ $ \name_cache -> - allocateGlobalBinder name_cache mod occ loc - ; traceIf (text "newGlobalBinder" <+> - (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name])) - ; return name } - -newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name --- Works in the IO monad, and gets the Module --- from the interactive context -newInteractiveBinder hsc_env occ loc - = do { let mod = icInteractiveModule (hsc_IC hsc_env) - ; updNameCacheIO hsc_env mod occ $ \name_cache -> - allocateGlobalBinder name_cache mod occ loc } - -allocateGlobalBinder - :: NameCache - -> Module -> OccName -> SrcSpan - -> (NameCache, Name) --- See Note [The Name Cache] -allocateGlobalBinder name_supply mod occ loc - = case lookupOrigNameCache (nsNames name_supply) mod occ of - -- A hit in the cache! We are at the binding site of the name. - -- This is the moment when we know the SrcLoc - -- of the Name, so we set this field in the Name we return. - -- - -- Then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. - -- - -- Possible other reason: it might be in the cache because we - -- encountered an occurrence before the binding site for an - -- implicitly-imported Name. Perhaps the current SrcLoc is - -- better... but not really: it'll still just say 'imported' - -- - -- IMPORTANT: Don't mess with wired-in names. - -- Their wired-in-ness is in their NameSort - -- and their Module is correct. - - Just name | isWiredInName name - -> (name_supply, name) - | otherwise - -> (new_name_supply, name') - where - uniq = nameUnique name - name' = mkExternalName uniq mod occ loc - -- name' is like name, but with the right SrcSpan - new_cache = extendNameCache (nsNames name_supply) mod occ name' - new_name_supply = name_supply {nsNames = new_cache} - - -- Miss in the cache! - -- Build a completely new Name, and put it in the cache - _ -> (new_name_supply, name) - where - (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) - name = mkExternalName uniq mod occ loc - new_cache = extendNameCache (nsNames name_supply) mod occ name - new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - -ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] -ifaceExportNames exports = return exports - --- | A function that atomically updates the name cache given a modifier --- function. The second result of the modifier function will be the result --- of the IO action. -newtype NameCacheUpdater - = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } - -mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater -mkNameCacheUpdater = do { hsc_env <- getTopEnv - ; let !ncRef = hsc_NC hsc_env - ; return (NCU (updNameCache ncRef)) } - -updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c)) - -> TcRnIf a b c -updNameCacheTc mod occ upd_fn = do { - hsc_env <- getTopEnv - ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn } - - -updNameCacheIO :: HscEnv -> Module -> OccName - -> (NameCache -> (NameCache, c)) - -> IO c -updNameCacheIO hsc_env mod occ upd_fn = do { - - -- First ensure that mod and occ are evaluated - -- If not, chaos can ensue: - -- we read the name-cache - -- then pull on mod (say) - -- which does some stuff that modifies the name cache - -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) - - mod `seq` occ `seq` return () - ; updNameCache (hsc_NC hsc_env) upd_fn } - - -{- -************************************************************************ -* * - Name cache access -* * -************************************************************************ --} - --- | Look up the 'Name' for a given 'Module' and 'OccName'. --- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad --- and 'Module' is simply that of the 'ModIface' you are typechecking. -lookupOrig :: Module -> OccName -> TcRnIf a b Name -lookupOrig mod occ - = do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) - - ; updNameCacheTc mod occ $ lookupNameCache mod occ } - -lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name -lookupOrigIO hsc_env mod occ - = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ - -lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) --- Lookup up the (Module,OccName) in the NameCache --- If you find it, return it; if not, allocate a fresh original name and extend --- the NameCache. --- Reason: this may the first occurrence of (say) Foo.bar we have encountered. --- If we need to explore its value we will load Foo.hi; but meanwhile all we --- need is a Name for it. -lookupNameCache mod occ name_cache = - case lookupOrigNameCache (nsNames name_cache) mod occ of { - Just name -> (name_cache, name); - Nothing -> - case takeUniqFromSupply (nsUniqs name_cache) of { - (uniq, us) -> - let - name = mkExternalName uniq mod occ noSrcSpan - new_cache = extendNameCache (nsNames name_cache) mod occ name - in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} - -externaliseName :: Module -> Name -> TcRnIf m n Name --- Take an Internal Name and make it an External one, --- with the same unique -externaliseName mod name - = do { let occ = nameOccName name - loc = nameSrcSpan name - uniq = nameUnique name - ; occ `seq` return () -- c.f. seq in newGlobalBinder - ; updNameCacheTc mod occ $ \ ns -> - let name' = mkExternalName uniq mod occ loc - ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' } - in (ns', name') } - --- | Set the 'Module' of a 'Name'. -setNameModule :: Maybe Module -> Name -> TcRnIf m n Name -setNameModule Nothing n = return n -setNameModule (Just m) n = - newGlobalBinder m (nameOccName n) (nameSrcSpan n) - -{- -************************************************************************ -* * - Type variables and local Ids -* * -************************************************************************ --} - -tcIfaceLclId :: FastString -> IfL Id -tcIfaceLclId occ - = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_id_env lcl) occ) of - Just ty_var -> return ty_var - Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) - } - -extendIfaceIdEnv :: [Id] -> IfL a -> IfL a -extendIfaceIdEnv ids thing_inside - = do { env <- getLclEnv - ; let { id_env' = extendFsEnvList (if_id_env env) pairs - ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } - ; setLclEnv (env { if_id_env = id_env' }) thing_inside } - - -tcIfaceTyVar :: FastString -> IfL TyVar -tcIfaceTyVar occ - = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_tv_env lcl) occ) of - Just ty_var -> return ty_var - Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) - } - -lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) -lookupIfaceTyVar (occ, _) - = do { lcl <- getLclEnv - ; return (lookupFsEnv (if_tv_env lcl) occ) } - -lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) -lookupIfaceVar (IfaceIdBndr (occ, _)) - = do { lcl <- getLclEnv - ; return (lookupFsEnv (if_id_env lcl) occ) } -lookupIfaceVar (IfaceTvBndr (occ, _)) - = do { lcl <- getLclEnv - ; return (lookupFsEnv (if_tv_env lcl) occ) } - -extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a -extendIfaceTyVarEnv tyvars thing_inside - = do { env <- getLclEnv - ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs - ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } - ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } - -extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a -extendIfaceEnvs tcvs thing_inside - = extendIfaceTyVarEnv tvs $ - extendIfaceIdEnv cvs $ - thing_inside - where - (tvs, cvs) = partition isTyVar tcvs - -{- -************************************************************************ -* * - Getting from RdrNames to Names -* * -************************************************************************ --} - --- | Look up a top-level name from the current Iface module -lookupIfaceTop :: OccName -> IfL Name -lookupIfaceTop occ - = do { env <- getLclEnv; lookupOrig (if_mod env) occ } - -newIfaceName :: OccName -> IfL Name -newIfaceName occ - = do { uniq <- newUnique - ; return $! mkInternalName uniq occ noSrcSpan } - -newIfaceNames :: [OccName] -> IfL [Name] -newIfaceNames occs - = do { uniqs <- newUniqueSupply - ; return [ mkInternalName uniq occ noSrcSpan - | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } diff --git a/iface/IfaceEnv.hs-boot b/iface/IfaceEnv.hs-boot deleted file mode 100644 --- a/iface/IfaceEnv.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module IfaceEnv where - -import Module -import OccName -import TcRnMonad -import Name -import SrcLoc - -newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/iface/IfaceSyn.hs b/iface/IfaceSyn.hs deleted file mode 100644 --- a/iface/IfaceSyn.hs +++ /dev/null @@ -1,2593 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} - -module IfaceSyn ( - module IfaceType, - - IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), - IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, - IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), - IfaceBinding(..), IfaceConAlt(..), - IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), - IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, - IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), - IfaceClassBody(..), - IfaceBang(..), - IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), - IfaceAxBranch(..), - IfaceTyConParent(..), - IfaceCompleteMatch(..), - - -- * Binding names - IfaceTopBndr, - putIfaceTopBndr, getIfaceTopBndr, - - -- Misc - ifaceDeclImplicitBndrs, visibleIfConDecls, - ifaceDeclFingerprints, - - -- Free Names - freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, - - -- Pretty printing - pprIfaceExpr, - pprIfaceDecl, - AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import IfaceType -import BinFingerprint -import CoreSyn( IsOrphan, isOrphan ) -import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) ) -import Demand -import Class -import FieldLabel -import NameSet -import CoAxiom ( BranchIndex ) -import Name -import CostCentre -import Literal -import ForeignCall -import Annotations( AnnPayload, AnnTarget ) -import BasicTypes -import Outputable -import Module -import SrcLoc -import Fingerprint -import Binary -import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import Var( VarBndr(..), binderVar ) -import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) -import Util( dropList, filterByList, notNull, unzipWith ) -import DataCon (SrcStrictness(..), SrcUnpackedness(..)) -import Lexeme (isLexSym) -import TysWiredIn ( constraintKindTyConName ) -import Util (seqList) - -import Control.Monad -import System.IO.Unsafe -import Control.DeepSeq - -infixl 3 &&& - -{- -************************************************************************ -* * - Declarations -* * -************************************************************************ --} - --- | A binding top-level 'Name' in an interface file (e.g. the name of an --- 'IfaceDecl'). -type IfaceTopBndr = Name - -- It's convenient to have a Name in the IfaceSyn, although in each - -- case the namespace is implied by the context. However, having an - -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints - -- very convenient. Moreover, having the key of the binder means that - -- we can encode known-key things cleverly in the symbol table. See Note - -- [Symbol table representation of Names] - -- - -- We don't serialise the namespace onto the disk though; rather we - -- drop it when serialising and add it back in when deserialising. - -getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr -getIfaceTopBndr bh = get bh - -putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () -putIfaceTopBndr bh name = - case getUserData bh of - UserData{ ud_put_binding_name = put_binding_name } -> - --pprTrace "putIfaceTopBndr" (ppr name) $ - put_binding_name bh name - -data IfaceDecl - = IfaceId { ifName :: IfaceTopBndr, - ifType :: IfaceType, - ifIdDetails :: IfaceIdDetails, - ifIdInfo :: IfaceIdInfo } - - | IfaceData { ifName :: IfaceTopBndr, -- Type constructor - ifBinders :: [IfaceTyConBinder], - ifResKind :: IfaceType, -- Result kind of type constructor - ifCType :: Maybe CType, -- C type for CAPI FFI - ifRoles :: [Role], -- Roles - ifCtxt :: IfaceContext, -- The "stupid theta" - ifCons :: IfaceConDecls, -- Includes new/data/data family info - ifGadtSyntax :: Bool, -- True <=> declared using - -- GADT syntax - ifParent :: IfaceTyConParent -- The axiom, for a newtype, - -- or data/newtype family instance - } - - | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor - ifRoles :: [Role], -- Roles - ifBinders :: [IfaceTyConBinder], - ifResKind :: IfaceKind, -- Kind of the *result* - ifSynRhs :: IfaceType } - - | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor - ifResVar :: Maybe IfLclName, -- Result variable name, used - -- only for pretty-printing - -- with --show-iface - ifBinders :: [IfaceTyConBinder], - ifResKind :: IfaceKind, -- Kind of the *tycon* - ifFamFlav :: IfaceFamTyConFlav, - ifFamInj :: Injectivity } -- injectivity information - - | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon - ifRoles :: [Role], -- Roles - ifBinders :: [IfaceTyConBinder], - ifFDs :: [FunDep IfLclName], -- Functional dependencies - ifBody :: IfaceClassBody -- Methods, superclasses, ATs - } - - | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name - ifTyCon :: IfaceTyCon, -- LHS TyCon - ifRole :: Role, -- Role of axiom - ifAxBranches :: [IfaceAxBranch] -- Branches - } - - | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym - ifPatIsInfix :: Bool, - ifPatMatcher :: (IfExtName, Bool), - ifPatBuilder :: Maybe (IfExtName, Bool), - -- Everything below is redundant, - -- but needed to implement pprIfaceDecl - ifPatUnivBndrs :: [IfaceForAllBndr], - ifPatExBndrs :: [IfaceForAllBndr], - ifPatProvCtxt :: IfaceContext, - ifPatReqCtxt :: IfaceContext, - ifPatArgs :: [IfaceType], - ifPatTy :: IfaceType, - ifFieldLabels :: [FieldLabel] } - --- See also 'ClassBody' -data IfaceClassBody - -- Abstract classes don't specify their body; they only occur in @hs-boot@ and - -- @hsig@ files. - = IfAbstractClass - | IfConcreteClass { - ifClassCtxt :: IfaceContext, -- Super classes - ifATs :: [IfaceAT], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition - } - -data IfaceTyConParent - = IfNoParent - | IfDataInstance - IfExtName -- Axiom name - IfaceTyCon -- Family TyCon (pretty-printing only, not used in TcIface) - -- see Note [Pretty printing via IfaceSyn] in PprTyThing - IfaceAppArgs -- Arguments of the family TyCon - -data IfaceFamTyConFlav - = IfaceDataFamilyTyCon -- Data family - | IfaceOpenSynFamilyTyCon - | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) - -- ^ Name of associated axiom and branches for pretty printing purposes, - -- or 'Nothing' for an empty closed family without an axiom - -- See Note [Pretty printing via IfaceSyn] in PprTyThing - | IfaceAbstractClosedSynFamilyTyCon - | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only - -data IfaceClassOp - = IfaceClassOp IfaceTopBndr - IfaceType -- Class op type - (Maybe (DefMethSpec IfaceType)) -- Default method - -- The types of both the class op itself, - -- and the default method, are *not* quantified - -- over the class variables - -data IfaceAT = IfaceAT -- See Class.ClassATItem - IfaceDecl -- The associated type declaration - (Maybe IfaceType) -- Default associated type instance, if any - - --- This is just like CoAxBranch -data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbEtaTyVars :: [IfaceTvBndr] - , ifaxbCoVars :: [IfaceIdBndr] - , ifaxbLHS :: IfaceAppArgs - , ifaxbRoles :: [Role] - , ifaxbRHS :: IfaceType - , ifaxbIncomps :: [BranchIndex] } - -- See Note [Storing compatibility] in CoAxiom - -data IfaceConDecls - = IfAbstractTyCon -- c.f TyCon.AbstractTyCon - | IfDataTyCon [IfaceConDecl] -- Data type decls - | IfNewTyCon IfaceConDecl -- Newtype decls - --- For IfDataTyCon and IfNewTyCon we store: --- * the data constructor(s); --- The field labels are stored individually in the IfaceConDecl --- (there is some redundancy here, because a field label may occur --- in multiple IfaceConDecls and represent the same field label) - -data IfaceConDecl - = IfCon { - ifConName :: IfaceTopBndr, -- Constructor name - ifConWrapper :: Bool, -- True <=> has a wrapper - ifConInfix :: Bool, -- True <=> declared infix - - -- The universal type variables are precisely those - -- of the type constructor of this data constructor - -- This is *easy* to guarantee when creating the IfCon - -- but it's not so easy for the original TyCon/DataCon - -- So this guarantee holds for IfaceConDecl, but *not* for DataCon - - ifConExTCvs :: [IfaceBndr], -- Existential ty/covars - ifConUserTvBinders :: [IfaceForAllBndr], - -- The tyvars, in the order the user wrote them - -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the - -- set of tyvars (*not* covars) of ifConExTCvs, unioned - -- with the set of ifBinders (from the parent IfaceDecl) - -- whose tyvars do not appear in ifConEqSpec - -- See Note [DataCon user type variable binders] in DataCon - ifConEqSpec :: IfaceEqSpec, -- Equality constraints - ifConCtxt :: IfaceContext, -- Non-stupid context - ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [FieldLabel], -- ...ditto... (field labels) - ifConStricts :: [IfaceBang], - -- Empty (meaning all lazy), - -- or 1-1 corresp with arg tys - -- See Note [Bangs on imported data constructors] in MkId - ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts - -type IfaceEqSpec = [(IfLclName,IfaceType)] - --- | This corresponds to an HsImplBang; that is, the final --- implementation decision about the data constructor arg -data IfaceBang - = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion - --- | This corresponds to HsSrcBang -data IfaceSrcBang - = IfSrcBang SrcUnpackedness SrcStrictness - -data IfaceClsInst - = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst - ifDFun :: IfExtName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv - -- There's always a separate IfaceDecl for the DFun, which gives - -- its IdInfo with its full type and version number. - -- The instance declarations taken together have a version number, - -- and we don't want that to wobble gratuitously - -- If this instance decl is *used*, we'll record a usage on the dfun; - -- and if the head does not change it won't be used if it wasn't before - --- The ifFamInstTys field of IfaceFamInst contains a list of the rough --- match types -data IfaceFamInst - = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name - , ifFamInstTys :: [Maybe IfaceTyCon] -- See above - , ifFamInstAxiom :: IfExtName -- The axiom - , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst - } - -data IfaceRule - = IfaceRule { - ifRuleName :: RuleName, - ifActivation :: Activation, - ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfExtName, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr, - ifRuleAuto :: Bool, - ifRuleOrph :: IsOrphan -- Just like IfaceClsInst - } - -data IfaceAnnotation - = IfaceAnnotation { - ifAnnotatedTarget :: IfaceAnnTarget, - ifAnnotatedValue :: AnnPayload - } - -type IfaceAnnTarget = AnnTarget OccName - -data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName - -instance Outputable IfaceCompleteMatch where - ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls - <+> dcolon <+> ppr ty - - - - --- Here's a tricky case: --- * Compile with -O module A, and B which imports A.f --- * Change function f in A, and recompile without -O --- * When we read in old A.hi we read in its IdInfo (as a thunk) --- (In earlier GHCs we used to drop IdInfo immediately on reading, --- but we do not do that now. Instead it's discarded when the --- ModIface is read into the various decl pools.) --- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) --- and so gives a new version. - -data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is - -data IfaceInfoItem - = HsArity Arity - | HsStrictness StrictSig - | HsInline InlinePragma - | HsUnfold Bool -- True <=> isStrongLoopBreaker is true - IfaceUnfolding -- See Note [Expose recursive functions] - | HsNoCafRefs - | HsLevity -- Present <=> never levity polymorphic - --- NB: Specialisations and rules come in separately and are --- only later attached to the Id. Partial reason: some are orphans. - -data IfaceUnfolding - = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding - -- Possibly could eliminate the Bool here, the information - -- is also in the InlinePragma. - - | IfCompulsory IfaceExpr -- Only used for default methods, in fact - - | IfInlineRule Arity -- INLINE pragmas - Bool -- OK to inline even if *un*-saturated - Bool -- OK to inline even if context is boring - IfaceExpr - - | IfDFunUnfold [IfaceBndr] [IfaceExpr] - - --- We only serialise the IdDetails of top-level Ids, and even then --- we only need a very limited selection. Notably, none of the --- implicit ones are needed here, because they are not put it --- interface files - -data IfaceIdDetails - = IfVanillaId - | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool - | IfDFunId - -{- -Note [Versioning of instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See [https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#instances] - - -************************************************************************ -* * - Functions over declarations -* * -************************************************************************ --} - -visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] -visibleIfConDecls IfAbstractTyCon = [] -visibleIfConDecls (IfDataTyCon cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] - -ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] --- *Excludes* the 'main' name, but *includes* the implicitly-bound names --- Deeply revolting, because it has to predict what gets bound, --- especially the question of whether there's a wrapper for a datacon --- See Note [Implicit TyThings] in HscTypes - --- N.B. the set of names returned here *must* match the set of --- TyThings returned by HscTypes.implicitTyThings, in the sense that --- TyThing.getOccName should define a bijection between the two lists. --- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) --- The order of the list does not matter. - -ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) - = case cons of - IfAbstractTyCon -> [] - IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd - IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds - -ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) - = [] - -ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name - , ifBody = IfConcreteClass { - ifClassCtxt = sc_ctxt, - ifSigs = sigs, - ifATs = ats - }}) - = -- (possibly) newtype coercion - co_occs ++ - -- data constructor (DataCon namespace) - -- data worker (Id namespace) - -- no wrapper (class dictionaries never have a wrapper) - [dc_occ, dcww_occ] ++ - -- associated types - [occName (ifName at) | IfaceAT at _ <- ats ] ++ - -- superclass selectors - [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ - -- operation selectors - [occName op | IfaceClassOp op _ _ <- sigs] - where - cls_tc_occ = occName cls_tc_name - n_ctxt = length sc_ctxt - n_sigs = length sigs - co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] - | otherwise = [] - dcww_occ = mkDataConWorkerOcc dc_occ - dc_occ = mkClassDataConOcc cls_tc_occ - is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) - -ifaceDeclImplicitBndrs _ = [] - -ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] -ifaceConDeclImplicitBndrs (IfCon { - ifConWrapper = has_wrapper, ifConName = con_name }) - = [occName con_name, work_occ] ++ wrap_occs - where - con_occ = occName con_name - work_occ = mkDataConWorkerOcc con_occ -- Id namespace - wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace - | otherwise = [] - --- ----------------------------------------------------------------------------- --- The fingerprints of an IfaceDecl - - -- We better give each name bound by the declaration a - -- different fingerprint! So we calculate the fingerprint of - -- each binder by combining the fingerprint of the whole - -- declaration with the name of the binder. (#5614, #7215) -ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] -ifaceDeclFingerprints hash decl - = (getOccName decl, hash) : - [ (occ, computeFingerprint' (hash,occ)) - | occ <- ifaceDeclImplicitBndrs decl ] - where - computeFingerprint' = - unsafeDupablePerformIO - . computeFingerprint (panic "ifaceDeclFingerprints") - -{- -************************************************************************ -* * - Expressions -* * -************************************************************************ --} - -data IfaceExpr - = IfaceLcl IfLclName - | IfaceExt IfExtName - | IfaceType IfaceType - | IfaceCo IfaceCoercion - | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceLamBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName [IfaceAlt] - | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] - | IfaceLet IfaceBinding IfaceExpr - | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType - | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E - -data IfaceTickish - = IfaceHpcTick Module Int -- from HpcTick x - | IfaceSCC CostCentre Bool Bool -- from ProfNote - | IfaceSource RealSrcSpan String -- from SourceNote - -- no breakpoints: we never export these into interface files - -type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) - -- Note: IfLclName, not IfaceBndr (and same with the case binder) - -- We reconstruct the kind/type of the thing from the context - -- thus saving bulk in interface files - -data IfaceConAlt = IfaceDefault - | IfaceDataAlt IfExtName - | IfaceLitAlt Literal - -data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] - --- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too --- It's used for *non-top-level* let/rec binders --- See Note [IdInfo on nested let-bindings] -data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo - -data IfaceJoinInfo = IfaceNotJoinPoint - | IfaceJoinPoint JoinArity - -{- -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In IfaceSyn an IfaceCase does not record the types of the alternatives, -unlike CorSyn Case. But we need this type if the alternatives are empty. -Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. - -Note [Expose recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For supercompilation we want to put *all* unfoldings in the interface -file, even for functions that are recursive (or big). So we need to -know when an unfolding belongs to a loop-breaker so that we can refrain -from inlining it (except during supercompilation). - -Note [IdInfo on nested let-bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Occasionally we want to preserve IdInfo on nested let bindings. The one -that came up was a NOINLINE pragma on a let-binding inside an INLINE -function. The user (Duncan Coutts) really wanted the NOINLINE control -to cross the separate compilation boundary. - -In general we retain all info that is left by CoreTidy.tidyLetBndr, since -that is what is seen by importing module with --make - -Note [Displaying axiom incompatibilities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -fprint-axiom-incomps we display which closed type family equations -are incompatible with which. This information is sometimes necessary -because GHC doesn't try equations in order: any equation can be used when -all preceding equations that are incompatible with it do not apply. - -For example, the last "a && a = a" equation in Data.Type.Bool.&& is -actually compatible with all previous equations, and can reduce at any -time. - -This is displayed as: -Prelude> :i Data.Type.Equality.== -type family (==) (a :: k) (b :: k) :: Bool - where - {- #0 -} (==) (f a) (g b) = (f == g) && (a == b) - {- #1 -} (==) a a = 'True - -- incompatible with: #0 - {- #2 -} (==) _1 _2 = 'False - -- incompatible with: #1, #0 -The comment after an equation refers to all previous equations (0-indexed) -that are incompatible with it. - -************************************************************************ -* * - Printing IfaceDecl -* * -************************************************************************ --} - -pprAxBranch :: SDoc -> BranchIndex -> IfaceAxBranch -> SDoc --- The TyCon might be local (just an OccName), or this might --- be a branch for an imported TyCon, so it would be an ExtName --- So it's easier to take an SDoc here --- --- This function is used --- to print interface files, --- in debug messages --- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon --- For user error messages we use Coercion.pprCoAxiom and friends -pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs - , ifaxbCoVars = _cvs - , ifaxbLHS = pat_tys - , ifaxbRHS = rhs - , ifaxbIncomps = incomps }) - = WARN( not (null _cvs), pp_tc $$ ppr _cvs ) - hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) - $+$ - nest 4 maybe_incomps - where - -- See Note [Printing foralls in type family instances] in IfaceType - ppr_binders = maybe_index <+> - pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) - pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) - - -- See Note [Displaying axiom incompatibilities] - maybe_index - = sdocWithDynFlags $ \dflags -> - ppWhen (gopt Opt_PrintAxiomIncomps dflags) $ - text "{-" <+> (text "#" <> ppr idx) <+> text "-}" - maybe_incomps - = sdocWithDynFlags $ \dflags -> - ppWhen (gopt Opt_PrintAxiomIncomps dflags && notNull incomps) $ - text "--" <+> text "incompatible with:" - <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps - -instance Outputable IfaceAnnotation where - ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value - -instance NamedThing IfaceClassOp where - getName (IfaceClassOp n _ _) = n - -instance HasOccName IfaceClassOp where - occName = getOccName - -instance NamedThing IfaceConDecl where - getName = ifConName - -instance HasOccName IfaceConDecl where - occName = getOccName - -instance NamedThing IfaceDecl where - getName = ifName - -instance HasOccName IfaceDecl where - occName = getOccName - -instance Outputable IfaceDecl where - ppr = pprIfaceDecl showToIface - -{- -Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The minimal complete definition should only be included if a complete -class definition is shown. Since the minimal complete definition is -anonymous we can't reuse the same mechanism that is used for the -filtering of method signatures. Instead we just check if anything at all is -filtered and hide it in that case. --} - -data ShowSub - = ShowSub - { ss_how_much :: ShowHowMuch - , ss_forall :: ShowForAllFlag } - --- See Note [Printing IfaceDecl binders] --- The alternative pretty printer referred to in the note. -newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) - -data ShowHowMuch - = ShowHeader AltPpr -- ^Header information only, not rhs - | ShowSome [OccName] AltPpr - -- ^ Show only some sub-components. Specifically, - -- - -- [@[]@] Print all sub-components. - -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; - -- elide other sub-components to @...@ - -- May 14: the list is max 1 element long at the moment - | ShowIface - -- ^Everything including GHC-internal information (used in --show-iface) - -{- -Note [Printing IfaceDecl binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The binders in an IfaceDecl are just OccNames, so we don't know what module they -come from. But when we pretty-print a TyThing by converting to an IfaceDecl -(see PprTyThing), the TyThing may come from some other module so we really need -the module qualifier. We solve this by passing in a pretty-printer for the -binders. - -When printing an interface file (--show-iface), we want to print -everything unqualified, so we can just print the OccName directly. --} - -instance Outputable ShowHowMuch where - ppr (ShowHeader _) = text "ShowHeader" - ppr ShowIface = text "ShowIface" - ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs - -showToHeader :: ShowSub -showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing - , ss_forall = ShowForAllWhen } - -showToIface :: ShowSub -showToIface = ShowSub { ss_how_much = ShowIface - , ss_forall = ShowForAllWhen } - -ppShowIface :: ShowSub -> SDoc -> SDoc -ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc -ppShowIface _ _ = Outputable.empty - --- show if all sub-components or the complete interface is shown -ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] -ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc -ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc -ppShowAllSubs _ _ = Outputable.empty - -ppShowRhs :: ShowSub -> SDoc -> SDoc -ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty -ppShowRhs _ doc = doc - -showSub :: HasOccName n => ShowSub -> n -> Bool -showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False -showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing -showSub (ShowSub { ss_how_much = _ }) _ = True - -ppr_trim :: [Maybe SDoc] -> [SDoc] --- Collapse a group of Nothings to a single "..." -ppr_trim xs - = snd (foldr go (False, []) xs) - where - go (Just doc) (_, so_far) = (False, doc : so_far) - go Nothing (True, so_far) = (True, so_far) - go Nothing (False, so_far) = (True, text "..." : so_far) - -isIfaceDataInstance :: IfaceTyConParent -> Bool -isIfaceDataInstance IfNoParent = False -isIfaceDataInstance _ = True - -pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc -pprClassRoles ss clas binders roles = - pprRoles (== Nominal) - (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) - binders - roles - -pprClassStandaloneKindSig :: ShowSub -> IfaceTopBndr -> IfaceKind -> SDoc -pprClassStandaloneKindSig ss clas = - pprStandaloneKindSig (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) - -constraintIfaceKind :: IfaceKind -constraintIfaceKind = - IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil - -pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc --- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi --- See Note [Pretty-printing TyThings] in PprTyThing -pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, - ifCtxt = context, ifResKind = kind, - ifRoles = roles, ifCons = condecls, - ifParent = parent, - ifGadtSyntax = gadt, - ifBinders = binders }) - - | gadt = vcat [ pp_roles - , pp_ki_sig - , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where - , nest 2 (vcat pp_cons) - , nest 2 $ ppShowIface ss pp_extra ] - | otherwise = vcat [ pp_roles - , pp_ki_sig - , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) - , nest 2 $ ppShowIface ss pp_extra ] - where - is_data_instance = isIfaceDataInstance parent - -- See Note [Printing foralls in type family instances] in IfaceType - pp_data_inst_forall :: SDoc - pp_data_inst_forall = pprUserIfaceForAll forall_bndrs - - forall_bndrs :: [IfaceForAllBndr] - forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] - - cons = visibleIfConDecls condecls - pp_where = ppWhen (gadt && not (null cons)) $ text "where" - pp_cons = ppr_trim (map show_con cons) :: [SDoc] - pp_kind = ppUnless (if ki_sig_printable - then isIfaceTauType kind - -- Even in the presence of a standalone kind signature, a non-tau - -- result kind annotation cannot be discarded as it determines the arity. - -- See Note [Arity inference in kcDeclHeader_sig] in TcHsType - else isIfaceLiftedTypeKind kind) - (dcolon <+> ppr kind) - - pp_lhs = case parent of - IfNoParent -> pprIfaceDeclHead suppress_bndr_sig context ss tycon binders - IfDataInstance{} - -> text "instance" <+> pp_data_inst_forall - <+> pprIfaceTyConParent parent - - pp_roles - | is_data_instance = empty - | otherwise = pprRoles (== Representational) name_doc binders roles - -- Don't display roles for data family instances (yet) - -- See discussion on #8672. - - ki_sig_printable = - -- If we print a standalone kind signature for a data instance, we leak - -- the internal constructor name: - -- - -- type T15827.R:Dka :: forall k. k -> * - -- data instance forall k (a :: k). D a = MkD (Proxy a) - -- - -- This T15827.R:Dka is a compiler-generated type constructor for the - -- data instance. - not is_data_instance - - pp_ki_sig = ppWhen ki_sig_printable $ - pprStandaloneKindSig name_doc (mkIfaceTyConKind binders kind) - - -- See Note [Suppressing binder signatures] in IfaceType - suppress_bndr_sig = SuppressBndrSig ki_sig_printable - - name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) - - add_bars [] = Outputable.empty - add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) - - ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) - - show_con dc - | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc - | otherwise = Nothing - - pp_nd = case condecls of - IfAbstractTyCon{} -> text "data" - IfDataTyCon{} -> text "data" - IfNewTyCon{} -> text "newtype" - - pp_extra = vcat [pprCType ctype] - -pprIfaceDecl ss (IfaceClass { ifName = clas - , ifRoles = roles - , ifFDs = fds - , ifBinders = binders - , ifBody = IfAbstractClass }) - = vcat [ pprClassRoles ss clas binders roles - , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) - , text "class" <+> pprIfaceDeclHead suppress_bndr_sig [] ss clas binders <+> pprFundeps fds ] - where - -- See Note [Suppressing binder signatures] in IfaceType - suppress_bndr_sig = SuppressBndrSig True - -pprIfaceDecl ss (IfaceClass { ifName = clas - , ifRoles = roles - , ifFDs = fds - , ifBinders = binders - , ifBody = IfConcreteClass { - ifATs = ats, - ifSigs = sigs, - ifClassCtxt = context, - ifMinDef = minDef - }}) - = vcat [ pprClassRoles ss clas binders roles - , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) - , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where - , nest 2 (vcat [ vcat asocs, vcat dsigs - , ppShowAllSubs ss (pprMinDef minDef)])] - where - pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") - - asocs = ppr_trim $ map maybeShowAssoc ats - dsigs = ppr_trim $ map maybeShowSig sigs - - maybeShowAssoc :: IfaceAT -> Maybe SDoc - maybeShowAssoc asc@(IfaceAT d _) - | showSub ss d = Just $ pprIfaceAT ss asc - | otherwise = Nothing - - maybeShowSig :: IfaceClassOp -> Maybe SDoc - maybeShowSig sg - | showSub ss sg = Just $ pprIfaceClassOp ss sg - | otherwise = Nothing - - pprMinDef :: BooleanFormula IfLclName -> SDoc - pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions - text "{-# MINIMAL" <+> - pprBooleanFormula - (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> - text "#-}" - - -- See Note [Suppressing binder signatures] in IfaceType - suppress_bndr_sig = SuppressBndrSig True - -pprIfaceDecl ss (IfaceSynonym { ifName = tc - , ifBinders = binders - , ifSynRhs = mono_ty - , ifResKind = res_kind}) - = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) - , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals) - 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau - , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) - ] - where - (tvs, theta, tau) = splitIfaceSigmaTy mono_ty - name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) - - -- See Note [Suppressing binder signatures] in IfaceType - suppress_bndr_sig = SuppressBndrSig True - -pprIfaceDecl ss (IfaceFamily { ifName = tycon - , ifFamFlav = rhs, ifBinders = binders - , ifResKind = res_kind - , ifResVar = res_var, ifFamInj = inj }) - | IfaceDataFamilyTyCon <- rhs - = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) - , text "data family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders - ] - - | otherwise - = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) - , hang (text "type family" - <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders - <+> ppShowRhs ss (pp_where rhs)) - 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) - $$ - nest 2 (ppShowRhs ss (pp_branches rhs)) - ] - where - name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) - - pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" - pp_where _ = empty - - pp_inj Nothing _ = empty - pp_inj (Just res) inj - | Injective injectivity <- inj = hsep [ equals, ppr res - , pp_inj_cond res injectivity] - | otherwise = hsep [ equals, ppr res ] - - pp_inj_cond res inj = case filterByList inj binders of - [] -> empty - tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] - - pp_rhs IfaceDataFamilyTyCon - = ppShowIface ss (text "data") - pp_rhs IfaceOpenSynFamilyTyCon - = ppShowIface ss (text "open") - pp_rhs IfaceAbstractClosedSynFamilyTyCon - = ppShowIface ss (text "closed, abstract") - pp_rhs (IfaceClosedSynFamilyTyCon {}) - = empty -- see pp_branches - pp_rhs IfaceBuiltInSynFamTyCon - = ppShowIface ss (text "built-in") - - pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) - = vcat (unzipWith (pprAxBranch - (pprPrefixIfDeclBndr - (ss_how_much ss) - (occName tycon)) - ) $ zip [0..] brs) - $$ ppShowIface ss (text "axiom" <+> ppr ax) - pp_branches _ = Outputable.empty - - -- See Note [Suppressing binder signatures] in IfaceType - suppress_bndr_sig = SuppressBndrSig True - -pprIfaceDecl _ (IfacePatSyn { ifName = name, - ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, - ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, - ifPatArgs = arg_tys, - ifPatTy = pat_ty} ) - = sdocWithDynFlags mk_msg - where - mk_msg dflags - = hang (text "pattern" <+> pprPrefixOcc name) - 2 (dcolon <+> sep [univ_msg - , pprIfaceContextArr req_ctxt - , ppWhen insert_empty_ctxt $ parens empty <+> darrow - , ex_msg - , pprIfaceContextArr prov_ctxt - , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ]) - where - univ_msg = pprUserIfaceForAll univ_bndrs - ex_msg = pprUserIfaceForAll ex_bndrs - - insert_empty_ctxt = null req_ctxt - && not (null prov_ctxt && isEmpty dflags ex_msg) - -pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, - ifIdDetails = details, ifIdInfo = info }) - = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) - 2 (pprIfaceSigmaType (ss_forall ss) ty) - , ppShowIface ss (ppr details) - , ppShowIface ss (ppr info) ] - -pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon - , ifAxBranches = branches }) - = hang (text "axiom" <+> ppr name <+> dcolon) - 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) - -pprCType :: Maybe CType -> SDoc -pprCType Nothing = Outputable.empty -pprCType (Just cType) = text "C type:" <+> ppr cType - --- if, for each role, suppress_if role is True, then suppress the role --- output -pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] - -> [Role] -> SDoc -pprRoles suppress_if tyCon bndrs roles - = sdocWithDynFlags $ \dflags -> - let froles = suppressIfaceInvisibles dflags bndrs roles - in ppUnless (all suppress_if froles || null froles) $ - text "type role" <+> tyCon <+> hsep (map ppr froles) - -pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc -pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty - -pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc -pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name - = pprInfixVar (isSymOcc name) (ppr_bndr name) -pprInfixIfDeclBndr _ name - = pprInfixVar (isSymOcc name) (ppr name) - -pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc -pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name - = parenSymOcc name (ppr_bndr name) -pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name - = parenSymOcc name (ppr_bndr name) -pprPrefixIfDeclBndr _ name - = parenSymOcc name (ppr name) - -instance Outputable IfaceClassOp where - ppr = pprIfaceClassOp showToIface - -pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc -pprIfaceClassOp ss (IfaceClassOp n ty dm) - = pp_sig n ty $$ generic_dm - where - generic_dm | Just (GenericDM dm_ty) <- dm - = text "default" <+> pp_sig n dm_ty - | otherwise - = empty - pp_sig n ty - = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) - <+> dcolon - <+> pprIfaceSigmaType ShowForAllWhen ty - -instance Outputable IfaceAT where - ppr = pprIfaceAT showToIface - -pprIfaceAT :: ShowSub -> IfaceAT -> SDoc -pprIfaceAT ss (IfaceAT d mb_def) - = vcat [ pprIfaceDecl ss d - , case mb_def of - Nothing -> Outputable.empty - Just rhs -> nest 2 $ - text "Default:" <+> ppr rhs ] - -instance Outputable IfaceTyConParent where - ppr p = pprIfaceTyConParent p - -pprIfaceTyConParent :: IfaceTyConParent -> SDoc -pprIfaceTyConParent IfNoParent - = Outputable.empty -pprIfaceTyConParent (IfDataInstance _ tc tys) - = pprIfaceTypeApp topPrec tc tys - -pprIfaceDeclHead :: SuppressBndrSig - -> IfaceContext -> ShowSub -> Name - -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression - -> SDoc -pprIfaceDeclHead suppress_sig context ss tc_occ bndrs - = sdocWithDynFlags $ \ dflags -> - sep [ pprIfaceContextArr context - , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) - <+> pprIfaceTyConBinders suppress_sig - (suppressIfaceInvisibles dflags bndrs bndrs) ] - -pprIfaceConDecl :: ShowSub -> Bool - -> IfaceTopBndr - -> [IfaceTyConBinder] - -> IfaceTyConParent - -> IfaceConDecl -> SDoc -pprIfaceConDecl ss gadt_style tycon tc_binders parent - (IfCon { ifConName = name, ifConInfix = is_infix, - ifConUserTvBinders = user_tvbs, - ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = stricts, ifConFields = fields }) - | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty - | otherwise = ppr_ex_quant pp_h98_con - where - pp_h98_con - | not (null fields) = pp_prefix_con <+> pp_field_args - | is_infix - , [ty1, ty2] <- pp_args - = sep [ ty1 - , pprInfixIfDeclBndr how_much (occName name) - , ty2] - | otherwise = pp_prefix_con <+> sep pp_args - - how_much = ss_how_much ss - tys_w_strs :: [(IfaceBang, IfaceType)] - tys_w_strs = zip stricts arg_tys - pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) - - -- If we're pretty-printing a H98-style declaration with existential - -- quantification, then user_tvbs will always consist of the universal - -- tyvar binders followed by the existential tyvar binders. So to recover - -- the visibilities of the existential tyvar binders, we can simply drop - -- the universal tyvar binders from user_tvbs. - ex_tvbs = dropList tc_binders user_tvbs - ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt - pp_gadt_res_ty = mk_user_con_res_ty eq_spec - ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau - - -- A bit gruesome this, but we can't form the full con_tau, and ppr it, - -- because we don't have a Name for the tycon, only an OccName - pp_tau | null fields - = case pp_args ++ [pp_gadt_res_ty] of - (t:ts) -> fsep (t : map (arrow <+>) ts) - [] -> panic "pp_con_taus" - | otherwise - = sep [pp_field_args, arrow <+> pp_gadt_res_ty] - - ppr_bang IfNoBang = whenPprDebug $ char '_' - ppr_bang IfStrict = char '!' - ppr_bang IfUnpack = text "{-# UNPACK #-}" - ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> - pprParendIfaceCoercion co - - pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc - -- If using record syntax, the only reason one would need to parenthesize - -- a compound field type is if it's preceded by a bang pattern. - pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty - -- If not using record syntax, a compound field type might need to be - -- parenthesized if one of the following holds: - -- - -- 1. We're using Haskell98 syntax. - -- 2. The field type is preceded with a bang pattern. - pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty - - ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc - ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty - - -- If we're displaying the fields GADT-style, e.g., - -- - -- data Foo a where - -- MkFoo :: (Int -> Int) -> Maybe a -> Foo - -- - -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the - -- parentheses that it requires, but simple compound types like `Maybe a` - -- (which don't require parentheses in a function argument position) won't - -- get them, assuming that there are no bang patterns (see bang_prec). - -- - -- If we're displaying the fields Haskell98-style, e.g., - -- - -- data Foo a = MkFoo (Int -> Int) (Maybe a) - -- - -- Then not only must we parenthesize `Int -> Int`, we must also - -- parenthesize compound fields like (Maybe a). Therefore, we pick - -- `appPrec`, which has higher precedence than `funPrec`. - gadt_prec :: PprPrec - gadt_prec - | gadt_style = funPrec - | otherwise = appPrec - - -- The presence of bang patterns or UNPACK annotations requires - -- surrounding the type with parentheses, if needed (#13699) - bang_prec :: IfaceBang -> PprPrec - bang_prec IfNoBang = topPrec - bang_prec IfStrict = appPrec - bang_prec IfUnpack = appPrec - bang_prec IfUnpackCo{} = appPrec - - pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or - -- `!(Maybe a) -> !Int -> ...` - pp_args = map pprArgTy tys_w_strs - - pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or - -- { x :: !(Maybe a), y :: !Int } - pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ - zipWith maybe_show_label fields tys_w_strs - - maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc - maybe_show_label lbl bty - | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ - <+> dcolon <+> pprFieldArgTy bty) - | otherwise = Nothing - where - sel = flSelector lbl - occ = mkVarOccFS (flLabel lbl) - - mk_user_con_res_ty :: IfaceEqSpec -> SDoc - -- See Note [Result type of a data family GADT] - mk_user_con_res_ty eq_spec - | IfDataInstance _ tc tys <- parent - = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys)) - | otherwise - = ppr_tc_app gadt_subst - where - gadt_subst = mkIfaceTySubst eq_spec - - -- When pretty-printing a GADT return type, we: - -- - -- 1. Take the data tycon binders, extract their variable names and - -- visibilities, and construct suitable arguments from them. (This is - -- the role of mk_tc_app_args.) - -- 2. Apply the GADT substitution constructed from the eq_spec. - -- (See Note [Result type of a data family GADT].) - -- 3. Pretty-print the data type constructor applied to its arguments. - -- This process will omit any invisible arguments, such as coercion - -- variables, if necessary. (See Note - -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.) - ppr_tc_app gadt_subst = - pprPrefixIfDeclBndr how_much (occName tycon) - <+> pprParendIfaceAppArgs - (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders)) - - mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs - mk_tc_app_args [] = IA_Nil - mk_tc_app_args (Bndr bndr vis:tc_bndrs) = - IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) - (mk_tc_app_args tc_bndrs) - -instance Outputable IfaceRule where - ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, - ifRuleOrph = orph }) - = sep [ hsep [ pprRuleName name - , if isOrphan orph then text "[orphan]" else Outputable.empty - , ppr act - , pp_foralls ] - , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), - text "=" <+> ppr rhs]) ] - where - pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot - -instance Outputable IfaceClsInst where - ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag - , ifInstCls = cls, ifInstTys = mb_tcs - , ifInstOrph = orph }) - = hang (text "instance" <+> ppr flag - <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) - <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) - 2 (equals <+> ppr dfun_id) - -instance Outputable IfaceFamInst where - ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs - , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) - = hang (text "family instance" - <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) - <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) - 2 (equals <+> ppr tycon_ax) - -ppr_rough :: Maybe IfaceTyCon -> SDoc -ppr_rough Nothing = dot -ppr_rough (Just tc) = ppr tc - -{- -Note [Result type of a data family GADT] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a - data instance T (p,q) where - T1 :: T (Int, Maybe c) - T2 :: T (Bool, q) - -The IfaceDecl actually looks like - - data TPr p q where - T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q - T2 :: forall p q. (p~Bool) => TPr p q - -To reconstruct the result types for T1 and T2 that we -want to pretty print, we substitute the eq-spec -[p->Int, q->Maybe c] in the arg pattern (p,q) to give - T (Int, Maybe c) -Remember that in IfaceSyn, the TyCon and DataCon share the same -universal type variables. - ------------------------------ Printing IfaceExpr ------------------------------------ --} - -instance Outputable IfaceExpr where - ppr e = pprIfaceExpr noParens e - -noParens :: SDoc -> SDoc -noParens pp = pp - -pprParendIfaceExpr :: IfaceExpr -> SDoc -pprParendIfaceExpr = pprIfaceExpr parens - --- | Pretty Print an IfaceExpre --- --- The first argument should be a function that adds parens in context that need --- an atomic value (e.g. function args) -pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc - -pprIfaceExpr _ (IfaceLcl v) = ppr v -pprIfaceExpr _ (IfaceExt v) = ppr v -pprIfaceExpr _ (IfaceLit l) = ppr l -pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) -pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty -pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co - -pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) -pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) - -pprIfaceExpr add_par i@(IfaceLam _ _) - = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, - pprIfaceExpr noParens body]) - where - (bndrs,body) = collect [] i - collect bs (IfaceLam b e) = collect (b:bs) e - collect bs e = (reverse bs, e) - -pprIfaceExpr add_par (IfaceECase scrut ty) - = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut - , text "ret_ty" <+> pprParendIfaceType ty - , text "of {}" ]) - -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) - = add_par (sep [text "case" - <+> pprIfaceExpr noParens scrut <+> text "of" - <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, - pprIfaceExpr noParens rhs <+> char '}']) - -pprIfaceExpr add_par (IfaceCase scrut bndr alts) - = add_par (sep [text "case" - <+> pprIfaceExpr noParens scrut <+> text "of" - <+> ppr bndr <+> char '{', - nest 2 (sep (map ppr_alt alts)) <+> char '}']) - -pprIfaceExpr _ (IfaceCast expr co) - = sep [pprParendIfaceExpr expr, - nest 2 (text "`cast`"), - pprParendIfaceCoercion co] - -pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) - = add_par (sep [text "let {", - nest 2 (ppr_bind (b, rhs)), - text "} in", - pprIfaceExpr noParens body]) - -pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) - = add_par (sep [text "letrec {", - nest 2 (sep (map ppr_bind pairs)), - text "} in", - pprIfaceExpr noParens body]) - -pprIfaceExpr add_par (IfaceTick tickish e) - = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) - -ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc -ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, - arrow <+> pprIfaceExpr noParens rhs] - -ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc -ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) - -ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc -ppr_bind (IfLetBndr b ty info ji, rhs) - = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), - equals <+> pprIfaceExpr noParens rhs] - ------------------- -pprIfaceTickish :: IfaceTickish -> SDoc -pprIfaceTickish (IfaceHpcTick m ix) - = braces (text "tick" <+> ppr m <+> ppr ix) -pprIfaceTickish (IfaceSCC cc tick scope) - = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) -pprIfaceTickish (IfaceSource src _names) - = braces (pprUserRealSpan True src) - ------------------- -pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc -pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ - nest 2 (pprParendIfaceExpr arg) : args -pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) - ------------------- -instance Outputable IfaceConAlt where - ppr IfaceDefault = text "DEFAULT" - ppr (IfaceLitAlt l) = ppr l - ppr (IfaceDataAlt d) = ppr d - ------------------- -instance Outputable IfaceIdDetails where - ppr IfVanillaId = Outputable.empty - ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc - <+> if b - then text "" - else Outputable.empty - ppr IfDFunId = text "DFunId" - -instance Outputable IfaceIdInfo where - ppr NoInfo = Outputable.empty - ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is - <+> text "-}" - -instance Outputable IfaceInfoItem where - ppr (HsUnfold lb unf) = text "Unfolding" - <> ppWhen lb (text "(loop-breaker)") - <> colon <+> ppr unf - ppr (HsInline prag) = text "Inline:" <+> ppr prag - ppr (HsArity arity) = text "Arity:" <+> int arity - ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str - ppr HsNoCafRefs = text "HasNoCafRefs" - ppr HsLevity = text "Never levity-polymorphic" - -instance Outputable IfaceJoinInfo where - ppr IfaceNotJoinPoint = empty - ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) - -instance Outputable IfaceUnfolding where - ppr (IfCompulsory e) = text "" <+> parens (ppr e) - ppr (IfCoreUnfold s e) = (if s - then text "" - else Outputable.empty) - <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" - <+> ppr (a,uok,bok), - pprParendIfaceExpr e] - ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) - 2 (sep (map pprParendIfaceExpr es)) - -{- -************************************************************************ -* * - Finding the Names in IfaceSyn -* * -************************************************************************ - -This is used for dependency analysis in MkIface, so that we -fingerprint a declaration before the things that depend on it. It -is specific to interface-file fingerprinting in the sense that we -don't collect *all* Names: for example, the DFun of an instance is -recorded textually rather than by its fingerprint when -fingerprinting the instance, so DFuns are not dependencies. --} - -freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i}) - = freeNamesIfType t &&& - freeNamesIfIdInfo i &&& - freeNamesIfIdDetails d - -freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k - , ifParent = p, ifCtxt = ctxt, ifCons = cons }) - = freeNamesIfVarBndrs bndrs &&& - freeNamesIfType res_k &&& - freeNamesIfaceTyConParent p &&& - freeNamesIfContext ctxt &&& - freeNamesIfConDecls cons - -freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k - , ifSynRhs = rhs }) - = freeNamesIfVarBndrs bndrs &&& - freeNamesIfKind res_k &&& - freeNamesIfType rhs - -freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k - , ifFamFlav = flav }) - = freeNamesIfVarBndrs bndrs &&& - freeNamesIfKind res_k &&& - freeNamesIfFamFlav flav - -freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) - = freeNamesIfVarBndrs bndrs &&& - freeNamesIfClassBody cls_body - -freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) - = freeNamesIfTc tc &&& - fnList freeNamesIfAxBranch branches - -freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) - , ifPatBuilder = mb_builder - , ifPatUnivBndrs = univ_bndrs - , ifPatExBndrs = ex_bndrs - , ifPatProvCtxt = prov_ctxt - , ifPatReqCtxt = req_ctxt - , ifPatArgs = args - , ifPatTy = pat_ty - , ifFieldLabels = lbls }) - = unitNameSet matcher &&& - maybe emptyNameSet (unitNameSet . fst) mb_builder &&& - freeNamesIfVarBndrs univ_bndrs &&& - freeNamesIfVarBndrs ex_bndrs &&& - freeNamesIfContext prov_ctxt &&& - freeNamesIfContext req_ctxt &&& - fnList freeNamesIfType args &&& - freeNamesIfType pat_ty &&& - mkNameSet (map flSelector lbls) - -freeNamesIfClassBody :: IfaceClassBody -> NameSet -freeNamesIfClassBody IfAbstractClass - = emptyNameSet -freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }) - = freeNamesIfContext ctxt &&& - fnList freeNamesIfAT ats &&& - fnList freeNamesIfClsSig sigs - -freeNamesIfAxBranch :: IfaceAxBranch -> NameSet -freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars - , ifaxbCoVars = covars - , ifaxbLHS = lhs - , ifaxbRHS = rhs }) - = fnList freeNamesIfTvBndr tyvars &&& - fnList freeNamesIfIdBndr covars &&& - freeNamesIfAppArgs lhs &&& - freeNamesIfType rhs - -freeNamesIfIdDetails :: IfaceIdDetails -> NameSet -freeNamesIfIdDetails (IfRecSelId tc _) = - either freeNamesIfTc freeNamesIfDecl tc -freeNamesIfIdDetails _ = emptyNameSet - --- All other changes are handled via the version info on the tycon -freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet -freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet -freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet -freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) - = unitNameSet ax &&& fnList freeNamesIfAxBranch br -freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet -freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet -freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet - -freeNamesIfContext :: IfaceContext -> NameSet -freeNamesIfContext = fnList freeNamesIfType - -freeNamesIfAT :: IfaceAT -> NameSet -freeNamesIfAT (IfaceAT decl mb_def) - = freeNamesIfDecl decl &&& - case mb_def of - Nothing -> emptyNameSet - Just rhs -> freeNamesIfType rhs - -freeNamesIfClsSig :: IfaceClassOp -> NameSet -freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm - -freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet -freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty -freeNamesDM _ = emptyNameSet - -freeNamesIfConDecls :: IfaceConDecls -> NameSet -freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c -freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c -freeNamesIfConDecls _ = emptyNameSet - -freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt - , ifConArgTys = arg_tys - , ifConFields = flds - , ifConEqSpec = eq_spec - , ifConStricts = bangs }) - = fnList freeNamesIfBndr ex_tvs &&& - freeNamesIfContext ctxt &&& - fnList freeNamesIfType arg_tys &&& - mkNameSet (map flSelector flds) &&& - fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints - fnList freeNamesIfBang bangs - -freeNamesIfBang :: IfaceBang -> NameSet -freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co -freeNamesIfBang _ = emptyNameSet - -freeNamesIfKind :: IfaceType -> NameSet -freeNamesIfKind = freeNamesIfType - -freeNamesIfAppArgs :: IfaceAppArgs -> NameSet -freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts -freeNamesIfAppArgs IA_Nil = emptyNameSet - -freeNamesIfType :: IfaceType -> NameSet -freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet -freeNamesIfType (IfaceTyVar _) = emptyNameSet -freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t -freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts -freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts -freeNamesIfType (IfaceLitTy _) = emptyNameSet -freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t -freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t -freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c -freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c - -freeNamesIfMCoercion :: IfaceMCoercion -> NameSet -freeNamesIfMCoercion IfaceMRefl = emptyNameSet -freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co - -freeNamesIfCoercion :: IfaceCoercion -> NameSet -freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t -freeNamesIfCoercion (IfaceGReflCo _ t mco) - = freeNamesIfType t &&& freeNamesIfMCoercion mco -freeNamesIfCoercion (IfaceFunCo _ c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) - = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos -freeNamesIfCoercion (IfaceAppCo c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceForAllCo _ kind_co co) - = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co -freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet -freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet -freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet -freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) - = unitNameSet ax &&& fnList freeNamesIfCoercion cos -freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) - = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 -freeNamesIfCoercion (IfaceSymCo c) - = freeNamesIfCoercion c -freeNamesIfCoercion (IfaceTransCo c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceNthCo _ co) - = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceLRCo _ co) - = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceInstCo co co2) - = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 -freeNamesIfCoercion (IfaceKindCo c) - = freeNamesIfCoercion c -freeNamesIfCoercion (IfaceSubCo co) - = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) - -- the axiom is just a string, so we don't count it as a name. - = fnList freeNamesIfCoercion cos - -freeNamesIfProv :: IfaceUnivCoProv -> NameSet -freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet -freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfacePluginProv _) = emptyNameSet - -freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet -freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr - -freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet -freeNamesIfVarBndrs = fnList freeNamesIfVarBndr - -freeNamesIfBndr :: IfaceBndr -> NameSet -freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b -freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b - -freeNamesIfBndrs :: [IfaceBndr] -> NameSet -freeNamesIfBndrs = fnList freeNamesIfBndr - -freeNamesIfLetBndr :: IfaceLetBndr -> NameSet --- Remember IfaceLetBndr is used only for *nested* bindings --- The IdInfo can contain an unfolding (in the case of --- local INLINE pragmas), so look there too -freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty - &&& freeNamesIfIdInfo info - -freeNamesIfTvBndr :: IfaceTvBndr -> NameSet -freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k - -- kinds can have Names inside, because of promotion - -freeNamesIfIdBndr :: IfaceIdBndr -> NameSet -freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k - -freeNamesIfIdInfo :: IfaceIdInfo -> NameSet -freeNamesIfIdInfo NoInfo = emptyNameSet -freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i - -freeNamesItem :: IfaceInfoItem -> NameSet -freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u -freeNamesItem _ = emptyNameSet - -freeNamesIfUnfold :: IfaceUnfolding -> NameSet -freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e -freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es - -freeNamesIfExpr :: IfaceExpr -> NameSet -freeNamesIfExpr (IfaceExt v) = unitNameSet v -freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty -freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty -freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co -freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as -freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body -freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a -freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co -freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e -freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty -freeNamesIfExpr (IfaceCase s _ alts) - = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts - where - fn_alt (_con,_bs,r) = freeNamesIfExpr r - - -- Depend on the data constructors. Just one will do! - -- Note [Tracking data constructors] - fn_cons [] = emptyNameSet - fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs - fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con - fn_cons (_ : _ ) = emptyNameSet - -freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body - -freeNamesIfExpr (IfaceLet (IfaceRec as) x) - = fnList fn_pair as &&& freeNamesIfExpr x - where - fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs - -freeNamesIfExpr _ = emptyNameSet - -freeNamesIfTc :: IfaceTyCon -> NameSet -freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) --- ToDo: shouldn't we include IfaceIntTc & co.? - -freeNamesIfRule :: IfaceRule -> NameSet -freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f - , ifRuleArgs = es, ifRuleRhs = rhs }) - = unitNameSet f &&& - fnList freeNamesIfBndr bs &&& - fnList freeNamesIfExpr es &&& - freeNamesIfExpr rhs - -freeNamesIfFamInst :: IfaceFamInst -> NameSet -freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName - , ifFamInstAxiom = axName }) - = unitNameSet famName &&& - unitNameSet axName - -freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet -freeNamesIfaceTyConParent IfNoParent = emptyNameSet -freeNamesIfaceTyConParent (IfDataInstance ax tc tys) - = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys - --- helpers -(&&&) :: NameSet -> NameSet -> NameSet -(&&&) = unionNameSet - -fnList :: (a -> NameSet) -> [a] -> NameSet -fnList f = foldr (&&&) emptyNameSet . map f - -{- -Note [Tracking data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case expression - case e of { C a -> ...; ... } -You might think that we don't need to include the datacon C -in the free names, because its type will probably show up in -the free names of 'e'. But in rare circumstances this may -not happen. Here's the one that bit me: - - module DynFlags where - import {-# SOURCE #-} Packages( PackageState ) - data DynFlags = DF ... PackageState ... - - module Packages where - import DynFlags - data PackageState = PS ... - lookupModule (df :: DynFlags) - = case df of - DF ...p... -> case p of - PS ... -> ... - -Now, lookupModule depends on DynFlags, but the transitive dependency -on the *locally-defined* type PackageState is not visible. We need -to take account of the use of the data constructor PS in the pattern match. - - -************************************************************************ -* * - Binary instances -* * -************************************************************************ - -Note that there is a bit of subtlety here when we encode names. While -IfaceTopBndrs is really just a synonym for Name, we need to take care to -encode them with {get,put}IfaceTopBndr. The difference becomes important when -we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for -details. - --} - -instance Binary IfaceDecl where - put_ bh (IfaceId name ty details idinfo) = do - putByte bh 0 - putIfaceTopBndr bh name - lazyPut bh (ty, details, idinfo) - -- See Note [Lazy deserialization of IfaceId] - - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 2 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do - putByte bh 3 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - - put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do - putByte bh 4 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - - -- NB: Written in a funny way to avoid an interface change - put_ bh (IfaceClass { - ifName = a2, - ifRoles = a3, - ifBinders = a4, - ifFDs = a5, - ifBody = IfConcreteClass { - ifClassCtxt = a1, - ifATs = a6, - ifSigs = a7, - ifMinDef = a8 - }}) = do - putByte bh 5 - put_ bh a1 - putIfaceTopBndr bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - - put_ bh (IfaceAxiom a1 a2 a3 a4) = do - putByte bh 6 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - - put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do - putByte bh 7 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - put_ bh a11 - - put_ bh (IfaceClass { - ifName = a1, - ifRoles = a2, - ifBinders = a3, - ifFDs = a4, - ifBody = IfAbstractClass }) = do - putByte bh 8 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - - get bh = do - h <- getByte bh - case h of - 0 -> do name <- get bh - ~(ty, details, idinfo) <- lazyGet bh - -- See Note [Lazy deserialization of IfaceId] - return (IfaceId name ty details idinfo) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) - 3 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceSynonym a1 a2 a3 a4 a5) - 4 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - return (IfaceFamily a1 a2 a3 a4 a5 a6) - 5 -> do a1 <- get bh - a2 <- getIfaceTopBndr bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceClass { - ifName = a2, - ifRoles = a3, - ifBinders = a4, - ifFDs = a5, - ifBody = IfConcreteClass { - ifClassCtxt = a1, - ifATs = a6, - ifSigs = a7, - ifMinDef = a8 - }}) - 6 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - return (IfaceAxiom a1 a2 a3 a4) - 7 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - a11 <- get bh - return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) - 8 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - return (IfaceClass { - ifName = a1, - ifRoles = a2, - ifBinders = a3, - ifFDs = a4, - ifBody = IfAbstractClass }) - _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) - -{- Note [Lazy deserialization of IfaceId] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The use of lazyPut and lazyGet in the IfaceId Binary instance is -purely for performance reasons, to avoid deserializing details about -identifiers that will never be used. It's not involved in tying the -knot in the type checker. It saved ~1% of the total build time of GHC. - -When we read an interface file, we extend the PTE, a mapping of Names -to TyThings, with the declarations we have read. The extension of the -PTE is strict in the Names, but not in the TyThings themselves. -LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to -add to the PTE. For an IfaceId, there's just one binding to add; and -the ty, details, and idinfo fields of an IfaceId are used only in the -TyThing. So by reading those fields lazily we may be able to save the -work of ever having to deserialize them (into IfaceType, etc.). - -For IfaceData and IfaceClass, loadDecl creates extra implicit bindings -(the constructors and field selectors of the data declaration, or the -methods of the class), whose Names depend on more than just the Name -of the type constructor or class itself. So deserializing them lazily -would be more involved. Similar comments apply to the other -constructors of IfaceDecl with the additional point that they probably -represent a small proportion of all declarations. --} - -instance Binary IfaceFamTyConFlav where - put_ bh IfaceDataFamilyTyCon = putByte bh 0 - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 - put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb - put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 - put_ _ IfaceBuiltInSynFamTyCon - = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty - - get bh = do { h <- getByte bh - ; case h of - 0 -> return IfaceDataFamilyTyCon - 1 -> return IfaceOpenSynFamilyTyCon - 2 -> do { mb <- get bh - ; return (IfaceClosedSynFamilyTyCon mb) } - 3 -> return IfaceAbstractClosedSynFamilyTyCon - _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" - (ppr (fromIntegral h :: Int)) } - -instance Binary IfaceClassOp where - put_ bh (IfaceClassOp n ty def) = do - putIfaceTopBndr bh n - put_ bh ty - put_ bh def - get bh = do - n <- getIfaceTopBndr bh - ty <- get bh - def <- get bh - return (IfaceClassOp n ty def) - -instance Binary IfaceAT where - put_ bh (IfaceAT dec defs) = do - put_ bh dec - put_ bh defs - get bh = do - dec <- get bh - defs <- get bh - return (IfaceAT dec defs) - -instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) - -instance Binary IfaceConDecls where - put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c - get bh = do - h <- getByte bh - case h of - 0 -> return IfAbstractTyCon - 1 -> liftM IfDataTyCon (get bh) - 2 -> liftM IfNewTyCon (get bh) - _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" - -instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh (length a9) - mapM_ (put_ bh) a9 - put_ bh a10 - put_ bh a11 - get bh = do - a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - n_fields <- get bh - a9 <- replicateM n_fields (get bh) - a10 <- get bh - a11 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) - -instance Binary IfaceBang where - put_ bh IfNoBang = putByte bh 0 - put_ bh IfStrict = putByte bh 1 - put_ bh IfUnpack = putByte bh 2 - put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co - - get bh = do - h <- getByte bh - case h of - 0 -> do return IfNoBang - 1 -> do return IfStrict - 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } - -instance Binary IfaceSrcBang where - put_ bh (IfSrcBang a1 a2) = - do put_ bh a1 - put_ bh a2 - - get bh = - do a1 <- get bh - a2 <- get bh - return (IfSrcBang a1 a2) - -instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do - put_ bh cls - put_ bh tys - put_ bh dfun - put_ bh flag - put_ bh orph - get bh = do - cls <- get bh - tys <- get bh - dfun <- get bh - flag <- get bh - orph <- get bh - return (IfaceClsInst cls tys dfun flag orph) - -instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys name orph) = do - put_ bh fam - put_ bh tys - put_ bh name - put_ bh orph - get bh = do - fam <- get bh - tys <- get bh - name <- get bh - orph <- get bh - return (IfaceFamInst fam tys name orph) - -instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) - -instance Binary IfaceAnnotation where - put_ bh (IfaceAnnotation a1 a2) = do - put_ bh a1 - put_ bh a2 - get bh = do - a1 <- get bh - a2 <- get bh - return (IfaceAnnotation a1 a2) - -instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh IfDFunId = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - _ -> return IfDFunId - -instance Binary IfaceIdInfo where - put_ bh NoInfo = putByte bh 0 - put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut - - get bh = do - h <- getByte bh - case h of - 0 -> return NoInfo - _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet - -instance Binary IfaceInfoItem where - put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab - put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad - put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad - put_ bh HsNoCafRefs = putByte bh 4 - put_ bh HsLevity = putByte bh 5 - get bh = do - h <- getByte bh - case h of - 0 -> liftM HsArity $ get bh - 1 -> liftM HsStrictness $ get bh - 2 -> do lb <- get bh - ad <- get bh - return (HsUnfold lb ad) - 3 -> liftM HsInline $ get bh - 4 -> return HsNoCafRefs - _ -> return HsLevity - -instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s e) = do - putByte bh 0 - put_ bh s - put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfDFunUnfold as bs) = do - putByte bh 2 - put_ bh as - put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 3 - put_ bh e - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - e <- get bh - return (IfCoreUnfold s e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do as <- get bh - bs <- get bh - return (IfDFunUnfold as bs) - _ -> do e <- get bh - return (IfCompulsory e) - - -instance Binary IfaceExpr where - put_ bh (IfaceLcl aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (IfaceCo ab) = do - putByte bh 2 - put_ bh ab - put_ bh (IfaceTuple ac ad) = do - putByte bh 3 - put_ bh ac - put_ bh ad - put_ bh (IfaceLam (ae, os) af) = do - putByte bh 4 - put_ bh ae - put_ bh os - put_ bh af - put_ bh (IfaceApp ag ah) = do - putByte bh 5 - put_ bh ag - put_ bh ah - put_ bh (IfaceCase ai aj ak) = do - putByte bh 6 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (IfaceLet al am) = do - putByte bh 7 - put_ bh al - put_ bh am - put_ bh (IfaceTick an ao) = do - putByte bh 8 - put_ bh an - put_ bh ao - put_ bh (IfaceLit ap) = do - putByte bh 9 - put_ bh ap - put_ bh (IfaceFCall as at) = do - putByte bh 10 - put_ bh as - put_ bh at - put_ bh (IfaceExt aa) = do - putByte bh 11 - put_ bh aa - put_ bh (IfaceCast ie ico) = do - putByte bh 12 - put_ bh ie - put_ bh ico - put_ bh (IfaceECase a b) = do - putByte bh 13 - put_ bh a - put_ bh b - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceLcl aa) - 1 -> do ab <- get bh - return (IfaceType ab) - 2 -> do ab <- get bh - return (IfaceCo ab) - 3 -> do ac <- get bh - ad <- get bh - return (IfaceTuple ac ad) - 4 -> do ae <- get bh - os <- get bh - af <- get bh - return (IfaceLam (ae, os) af) - 5 -> do ag <- get bh - ah <- get bh - return (IfaceApp ag ah) - 6 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (IfaceCase ai aj ak) - 7 -> do al <- get bh - am <- get bh - return (IfaceLet al am) - 8 -> do an <- get bh - ao <- get bh - return (IfaceTick an ao) - 9 -> do ap <- get bh - return (IfaceLit ap) - 10 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 11 -> do aa <- get bh - return (IfaceExt aa) - 12 -> do ie <- get bh - ico <- get bh - return (IfaceCast ie ico) - 13 -> do a <- get bh - b <- get bh - return (IfaceECase a b) - _ -> panic ("get IfaceExpr " ++ show h) - -instance Binary IfaceTickish where - put_ bh (IfaceHpcTick m ix) = do - putByte bh 0 - put_ bh m - put_ bh ix - put_ bh (IfaceSCC cc tick push) = do - putByte bh 1 - put_ bh cc - put_ bh tick - put_ bh push - put_ bh (IfaceSource src name) = do - putByte bh 2 - put_ bh (srcSpanFile src) - put_ bh (srcSpanStartLine src) - put_ bh (srcSpanStartCol src) - put_ bh (srcSpanEndLine src) - put_ bh (srcSpanEndCol src) - put_ bh name - - get bh = do - h <- getByte bh - case h of - 0 -> do m <- get bh - ix <- get bh - return (IfaceHpcTick m ix) - 1 -> do cc <- get bh - tick <- get bh - push <- get bh - return (IfaceSCC cc tick push) - 2 -> do file <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh - let start = mkRealSrcLoc file sl sc - end = mkRealSrcLoc file el ec - name <- get bh - return (IfaceSource (mkRealSrcSpan start end) name) - _ -> panic ("get IfaceTickish " ++ show h) - -instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 - put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa - put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceDefault - 1 -> liftM IfaceDataAlt $ get bh - _ -> liftM IfaceLitAlt $ get bh - -instance Binary IfaceBinding where - put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab - put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } - _ -> do { ac <- get bh; return (IfaceRec ac) } - -instance Binary IfaceLetBndr where - put_ bh (IfLetBndr a b c d) = do - put_ bh a - put_ bh b - put_ bh c - put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfLetBndr a b c d) - -instance Binary IfaceJoinInfo where - put_ bh IfaceNotJoinPoint = putByte bh 0 - put_ bh (IfaceJoinPoint ar) = do - putByte bh 1 - put_ bh ar - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceNotJoinPoint - _ -> liftM IfaceJoinPoint $ get bh - -instance Binary IfaceTyConParent where - put_ bh IfNoParent = putByte bh 0 - put_ bh (IfDataInstance ax pr ty) = do - putByte bh 1 - put_ bh ax - put_ bh pr - put_ bh ty - get bh = do - h <- getByte bh - case h of - 0 -> return IfNoParent - _ -> do - ax <- get bh - pr <- get bh - ty <- get bh - return $ IfDataInstance ax pr ty - -instance Binary IfaceCompleteMatch where - put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts - get bh = IfaceCompleteMatch <$> get bh <*> get bh - - -{- -************************************************************************ -* * - NFData instances - See Note [Avoiding space leaks in toIface*] in ToIface -* * -************************************************************************ --} - -instance NFData IfaceDecl where - rnf = \case - IfaceId f1 f2 f3 f4 -> - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 - - IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> - f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq` - rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 - - IfaceSynonym f1 f2 f3 f4 f5 -> - rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 - - IfaceFamily f1 f2 f3 f4 f5 f6 -> - rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` () - - IfaceClass f1 f2 f3 f4 f5 -> - rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 - - IfaceAxiom nm tycon role ax -> - rnf nm `seq` - rnf tycon `seq` - role `seq` - rnf ax - - IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq` - rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` () - -instance NFData IfaceAxBranch where - rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 - -instance NFData IfaceClassBody where - rnf = \case - IfAbstractClass -> () - IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () - -instance NFData IfaceAT where - rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 - -instance NFData IfaceClassOp where - rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` () - -instance NFData IfaceTyConParent where - rnf = \case - IfNoParent -> () - IfDataInstance f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 - -instance NFData IfaceConDecls where - rnf = \case - IfAbstractTyCon -> () - IfDataTyCon f1 -> rnf f1 - IfNewTyCon f1 -> rnf f1 - -instance NFData IfaceConDecl where - rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` - rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 - -instance NFData IfaceSrcBang where - rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` () - -instance NFData IfaceBang where - rnf x = x `seq` () - -instance NFData IfaceIdDetails where - rnf = \case - IfVanillaId -> () - IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b - IfRecSelId (Right decl) b -> rnf decl `seq` rnf b - IfDFunId -> () - -instance NFData IfaceIdInfo where - rnf = \case - NoInfo -> () - HasInfo f1 -> rnf f1 - -instance NFData IfaceInfoItem where - rnf = \case - HsArity a -> rnf a - HsStrictness str -> seqStrictSig str - HsInline p -> p `seq` () -- TODO: seq further? - HsUnfold b unf -> rnf b `seq` rnf unf - HsNoCafRefs -> () - HsLevity -> () - -instance NFData IfaceUnfolding where - rnf = \case - IfCoreUnfold inlinable expr -> - rnf inlinable `seq` rnf expr - IfCompulsory expr -> - rnf expr - IfInlineRule arity b1 b2 e -> - rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e - IfDFunUnfold bndrs exprs -> - rnf bndrs `seq` rnf exprs - -instance NFData IfaceExpr where - rnf = \case - IfaceLcl nm -> rnf nm - IfaceExt nm -> rnf nm - IfaceType ty -> rnf ty - IfaceCo co -> rnf co - IfaceTuple sort exprs -> sort `seq` rnf exprs - IfaceLam bndr expr -> rnf bndr `seq` rnf expr - IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 - IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts - IfaceECase e ty -> rnf e `seq` rnf ty - IfaceLet bind e -> rnf bind `seq` rnf e - IfaceCast e co -> rnf e `seq` rnf co - IfaceLit l -> l `seq` () -- FIXME - IfaceFCall fc ty -> fc `seq` rnf ty - IfaceTick tick e -> rnf tick `seq` rnf e - -instance NFData IfaceBinding where - rnf = \case - IfaceNonRec bndr e -> rnf bndr `seq` rnf e - IfaceRec binds -> rnf binds - -instance NFData IfaceLetBndr where - rnf (IfLetBndr nm ty id_info join_info) = - rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info - -instance NFData IfaceFamTyConFlav where - rnf = \case - IfaceDataFamilyTyCon -> () - IfaceOpenSynFamilyTyCon -> () - IfaceClosedSynFamilyTyCon f1 -> rnf f1 - IfaceAbstractClosedSynFamilyTyCon -> () - IfaceBuiltInSynFamTyCon -> () - -instance NFData IfaceJoinInfo where - rnf x = x `seq` () - -instance NFData IfaceTickish where - rnf = \case - IfaceHpcTick m i -> rnf m `seq` rnf i - IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2 - IfaceSource src str -> src `seq` rnf str - -instance NFData IfaceConAlt where - rnf = \case - IfaceDefault -> () - IfaceDataAlt nm -> rnf nm - IfaceLitAlt lit -> lit `seq` () - -instance NFData IfaceCompleteMatch where - rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2 - -instance NFData IfaceRule where - rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = - rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` () - -instance NFData IfaceFamInst where - rnf (IfaceFamInst f1 f2 f3 f4) = - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () - -instance NFData IfaceClsInst where - rnf (IfaceClsInst f1 f2 f3 f4 f5) = - f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` () - -instance NFData IfaceAnnotation where - rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` () diff --git a/iface/IfaceType.hs b/iface/IfaceType.hs deleted file mode 100644 --- a/iface/IfaceType.hs +++ /dev/null @@ -1,2052 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - -This module defines interface types and binders --} - -{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} - -- FlexibleInstances for Binary (DefMethSpec IfaceType) - -module IfaceType ( - IfExtName, IfLclName, - - IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), - IfaceMCoercion(..), - IfaceUnivCoProv(..), - IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), - IfaceTyLit(..), IfaceAppArgs(..), - IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, - IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, - IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), - ForallVisFlag(..), ShowForAllFlag(..), - mkIfaceForAllTvBndr, - mkIfaceTyConKind, - - ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, - ifTyConBinderVar, ifTyConBinderName, - - -- Equality testing - isIfaceLiftedTypeKind, - - -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags - appArgsIfaceTypes, appArgsIfaceTypesArgFlags, - - -- Printing - SuppressBndrSig(..), - UseBndrParens(..), - pprIfaceType, pprParendIfaceType, pprPrecIfaceType, - pprIfaceContext, pprIfaceContextArr, - pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, - pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, - pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, - pprIfaceSigmaType, pprIfaceTyLit, - pprIfaceCoercion, pprParendIfaceCoercion, - splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, - pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, - isIfaceTauType, - - suppressIfaceInvisibles, - stripIfaceInvisVars, - stripInvisArgs, - - mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon - , liftedRepDataConTyCon, tupleTyConName ) -import {-# SOURCE #-} Type ( isRuntimeRepTy ) - -import DynFlags -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom -import Var -import PrelNames -import Name -import BasicTypes -import Binary -import Outputable -import FastString -import FastStringEnv -import Util - -import Data.Maybe( isJust ) -import qualified Data.Semigroup as Semi -import Control.DeepSeq - -{- -************************************************************************ -* * - Local (nested) binders -* * -************************************************************************ --} - -type IfLclName = FastString -- A local name in iface syntax - -type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn - -- (However Internal or System Names never should) - -data IfaceBndr -- Local (non-top-level) binders - = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr - | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr - -type IfaceIdBndr = (IfLclName, IfaceType) -type IfaceTvBndr = (IfLclName, IfaceKind) - -ifaceTvBndrName :: IfaceTvBndr -> IfLclName -ifaceTvBndrName (n,_) = n - -ifaceIdBndrName :: IfaceIdBndr -> IfLclName -ifaceIdBndrName (n,_) = n - -ifaceBndrName :: IfaceBndr -> IfLclName -ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr -ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr - -ifaceBndrType :: IfaceBndr -> IfaceType -ifaceBndrType (IfaceIdBndr (_, t)) = t -ifaceBndrType (IfaceTvBndr (_, t)) = t - -type IfaceLamBndr = (IfaceBndr, IfaceOneShot) - -data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy - = IfaceNoOneShot -- and Note [The oneShot function] in MkId - | IfaceOneShot - - -{- -%************************************************************************ -%* * - IfaceType -%* * -%************************************************************************ --} - -------------------------------- -type IfaceKind = IfaceType - --- | A kind of universal type, used for types and kinds. --- --- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' --- before being printed. See Note [Pretty printing via IfaceSyn] in PprTyThing -data IfaceType - = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] - | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon - | IfaceLitTy IfaceTyLit - | IfaceAppTy IfaceType IfaceAppArgs - -- See Note [Suppressing invisible arguments] for - -- an explanation of why the second field isn't - -- IfaceType, analogous to AppTy. - | IfaceFunTy AnonArgFlag IfaceType IfaceType - | IfaceForAllTy IfaceForAllBndr IfaceType - | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated - -- Includes newtypes, synonyms, tuples - | IfaceCastTy IfaceType IfaceCoercion - | IfaceCoercionTy IfaceCoercion - - | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) - TupleSort -- What sort of tuple? - PromotionFlag -- A bit like IfaceTyCon - IfaceAppArgs -- arity = length args - -- For promoted data cons, the kind args are omitted - -type IfacePredType = IfaceType -type IfaceContext = [IfacePredType] - -data IfaceTyLit - = IfaceNumTyLit Integer - | IfaceStrTyLit FastString - deriving (Eq) - -type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag - --- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. -mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr -mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis - --- | Build the 'tyConKind' from the binders and the result kind. --- Keep in sync with 'mkTyConKind' in types/TyCon. -mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind -mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs - where - mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind - mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af (ifaceBndrType tv) k - mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k - --- | Stores the arguments in a type application as a list. --- See @Note [Suppressing invisible arguments]@. -data IfaceAppArgs - = IA_Nil - | IA_Arg IfaceType -- The type argument - - ArgFlag -- The argument's visibility. We store this here so - -- that we can: - -- - -- 1. Avoid pretty-printing invisible (i.e., specified - -- or inferred) arguments when - -- -fprint-explicit-kinds isn't enabled, or - -- 2. When -fprint-explicit-kinds *is*, enabled, print - -- specified arguments in @(...) and inferred - -- arguments in @{...}. - - IfaceAppArgs -- The rest of the arguments - -instance Semi.Semigroup IfaceAppArgs where - IA_Nil <> xs = xs - IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) - -instance Monoid IfaceAppArgs where - mempty = IA_Nil - mappend = (Semi.<>) - --- Encodes type constructors, kind constructors, --- coercion constructors, the lot. --- We have to tag them in order to pretty print them --- properly. -data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName - , ifaceTyConInfo :: IfaceTyConInfo } - deriving (Eq) - --- | The various types of TyCons which have special, built-in syntax. -data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon - - | IfaceTupleTyCon !Arity !TupleSort - -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@. - -- The arity is the tuple width, not the tycon arity - -- (which is twice the width in the case of unboxed - -- tuples). - - | IfaceSumTyCon !Arity - -- ^ e.g. @(a | b | c)@ - - | IfaceEqualityTyCon - -- ^ A heterogeneous equality TyCon - -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon) - -- that is actually being applied to two types - -- of the same kind. This affects pretty-printing - -- only: see Note [Equality predicates in IfaceType] - deriving (Eq) - -{- Note [Free tyvars in IfaceType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to -an IfaceType and pretty printing that. This eliminates a lot of -pretty-print duplication, and it matches what we do with pretty- -printing TyThings. See Note [Pretty printing via IfaceSyn] in PprTyThing. - -It works fine for closed types, but when printing debug traces (e.g. -when using -ddump-tc-trace) we print a lot of /open/ types. These -types are full of TcTyVars, and it's absolutely crucial to print them -in their full glory, with their unique, TcTyVarDetails etc. - -So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. -Note that: - -* We never expect to serialise an IfaceFreeTyVar into an interface file, nor - to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType - and then pretty-print" pipeline. - -We do the same for covars, naturally. - -Note [Equality predicates in IfaceType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has several varieties of type equality (see Note [The equality types story] -in TysPrim for details). In an effort to avoid confusing users, we suppress -the differences during pretty printing unless certain flags are enabled. -Here is how each equality predicate* is printed in homogeneous and -heterogeneous contexts, depending on which combination of the --fprint-explicit-kinds and -fprint-equality-relations flags is used: - --------------------------------------------------------------------------------------------- -| Predicate | Neither flag | -fprint-explicit-kinds | -|-------------------------------|----------------------------|-----------------------------| -| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | -| a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | -| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | -| a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | -| a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | -| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | -| a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | -| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | -|-------------------------------|----------------------------|-----------------------------| -| Predicate | -fprint-equality-relations | Both flags | -|-------------------------------|----------------------------|-----------------------------| -| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | -| a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | -| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | -| a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | -| a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | -| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | -| a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | -| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | --------------------------------------------------------------------------------------------- - -(* There is no heterogeneous, representational, lifted equality counterpart -to (~~). There could be, but there seems to be no use for it.) - -This table adheres to the following rules: - -A. With -fprint-equality-relations, print the true equality relation. -B. Without -fprint-equality-relations: - i. If the equality is representational and homogeneous, use Coercible. - ii. Otherwise, if the equality is representational, use ~R#. - iii. If the equality is nominal and homogeneous, use ~. - iv. Otherwise, if the equality is nominal, use ~~. -C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator, - as above; or print the kind with Coercible. -D. Without -fprint-explicit-kinds, don't print kinds. - -A hetero-kinded equality is used homogeneously when it is applied to two -identical kinds. Unfortunately, determining this from an IfaceType isn't -possible since we can't see through type synonyms. Consequently, we need to -record whether this particular application is homogeneous in IfaceTyConSort -for the purposes of pretty-printing. - -See Note [The equality types story] in TysPrim. --} - -data IfaceTyConInfo -- Used to guide pretty-printing - -- and to disambiguate D from 'D (they share a name) - = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag - , ifaceTyConSort :: IfaceTyConSort } - deriving (Eq) - -data IfaceMCoercion - = IfaceMRefl - | IfaceMCo IfaceCoercion - -data IfaceCoercion - = IfaceReflCo IfaceType - | IfaceGReflCo Role IfaceType (IfaceMCoercion) - | IfaceFunCo Role IfaceCoercion IfaceCoercion - | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] - | IfaceAppCo IfaceCoercion IfaceCoercion - | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion - | IfaceCoVarCo IfLclName - | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] - | IfaceAxiomRuleCo IfLclName [IfaceCoercion] - -- There are only a fixed number of CoAxiomRules, so it suffices - -- to use an IfaceLclName to distinguish them. - -- See Note [Adding built-in type families] in TcTypeNats - | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType - | IfaceSymCo IfaceCoercion - | IfaceTransCo IfaceCoercion IfaceCoercion - | IfaceNthCo Int IfaceCoercion - | IfaceLRCo LeftOrRight IfaceCoercion - | IfaceInstCo IfaceCoercion IfaceCoercion - | IfaceKindCo IfaceCoercion - | IfaceSubCo IfaceCoercion - | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] - | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] - -data IfaceUnivCoProv - = IfaceUnsafeCoerceProv - | IfacePhantomProv IfaceCoercion - | IfaceProofIrrelProv IfaceCoercion - | IfacePluginProv String - -{- Note [Holes in IfaceCoercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking fails the typechecker will produce a HoleCo to stand -in place of the unproven assertion. While we generally don't want to -let these unproven assertions leak into interface files, we still need -to be able to pretty-print them as we use IfaceType's pretty-printer -to render Types. For this reason IfaceCoercion has a IfaceHoleCo -constructor; however, we fails when asked to serialize to a -IfaceHoleCo to ensure that they don't end up in an interface file. - - -%************************************************************************ -%* * - Functions over IFaceTypes -* * -************************************************************************ --} - -ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool -ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key - -isIfaceLiftedTypeKind :: IfaceKind -> Bool -isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) - = isLiftedTypeKindTyConName (ifaceTyConName tc) -isIfaceLiftedTypeKind (IfaceTyConApp tc - (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil) - Required IA_Nil)) - = tc `ifaceTyConHasKey` tYPETyConKey - && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey -isIfaceLiftedTypeKind _ = False - -splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) --- Mainly for printing purposes --- --- Here we split nested IfaceSigmaTy properly. --- --- @ --- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b) --- @ --- --- If you called @splitIfaceSigmaTy@ on this type: --- --- @ --- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b)) --- @ -splitIfaceSigmaTy ty - = case (bndrs, theta) of - ([], []) -> (bndrs, theta, tau) - _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau - in (bndrs ++ bndrs', theta ++ theta', tau') - where - (bndrs, rho) = split_foralls ty - (theta, tau) = split_rho rho - - split_foralls (IfaceForAllTy bndr ty) - = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } - split_foralls rho = ([], rho) - - split_rho (IfaceFunTy InvisArg ty1 ty2) - = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } - split_rho tau = ([], tau) - -suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a] -suppressIfaceInvisibles dflags tys xs - | gopt Opt_PrintExplicitKinds dflags = xs - | otherwise = suppress tys xs - where - suppress _ [] = [] - suppress [] a = a - suppress (k:ks) (x:xs) - | isInvisibleTyConBinder k = suppress ks xs - | otherwise = x : suppress ks xs - -stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder] -stripIfaceInvisVars dflags tyvars - | gopt Opt_PrintExplicitKinds dflags = tyvars - | otherwise = filterOut isInvisibleTyConBinder tyvars - --- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. -ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr -ifForAllBndrVar = binderVar - --- | Extract the variable name from an 'IfaceForAllBndr'. -ifForAllBndrName :: IfaceForAllBndr -> IfLclName -ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) - --- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. -ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr -ifTyConBinderVar = binderVar - --- | Extract the variable name from an 'IfaceTyConBinder'. -ifTyConBinderName :: IfaceTyConBinder -> IfLclName -ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) - -ifTypeIsVarFree :: IfaceType -> Bool --- Returns True if the type definitely has no variables at all --- Just used to control pretty printing -ifTypeIsVarFree ty = go ty - where - go (IfaceTyVar {}) = False - go (IfaceFreeTyVar {}) = False - go (IfaceAppTy fun args) = go fun && go_args args - go (IfaceFunTy _ arg res) = go arg && go res - go (IfaceForAllTy {}) = False - go (IfaceTyConApp _ args) = go_args args - go (IfaceTupleTy _ _ args) = go_args args - go (IfaceLitTy _) = True - go (IfaceCastTy {}) = False -- Safe - go (IfaceCoercionTy {}) = False -- Safe - - go_args IA_Nil = True - go_args (IA_Arg arg _ args) = go arg && go_args args - -{- Note [Substitution on IfaceType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Substitutions on IfaceType are done only during pretty-printing to -construct the result type of a GADT, and does not deal with binders -(eg IfaceForAll), so it doesn't need fancy capture stuff. -} - -type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType] - -mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst --- See Note [Substitution on IfaceType] -mkIfaceTySubst eq_spec = mkFsEnv eq_spec - -inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool --- See Note [Substitution on IfaceType] -inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs) - -substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType --- See Note [Substitution on IfaceType] -substIfaceType env ty - = go ty - where - go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv - go (IfaceTyVar tv) = substIfaceTyVar env tv - go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) - go (IfaceFunTy af t1 t2) = IfaceFunTy af (go t1) (go t2) - go ty@(IfaceLitTy {}) = ty - go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys) - go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys) - go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) - go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) - go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) - - go_mco IfaceMRefl = IfaceMRefl - go_mco (IfaceMCo co) = IfaceMCo $ go_co co - - go_co (IfaceReflCo ty) = IfaceReflCo (go ty) - go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) - go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) - go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) - go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) - go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) - go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv - go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv - go_co (IfaceHoleCo cv) = IfaceHoleCo cv - go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) - go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) - go_co (IfaceSymCo co) = IfaceSymCo (go_co co) - go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) - go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) - go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) - go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) - go_co (IfaceKindCo co) = IfaceKindCo (go_co co) - go_co (IfaceSubCo co) = IfaceSubCo (go_co co) - go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) - - go_cos = map go_co - - go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv - go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) - go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) - go_prov (IfacePluginProv str) = IfacePluginProv str - -substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs -substIfaceAppArgs env args - = go args - where - go IA_Nil = IA_Nil - go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) - -substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType -substIfaceTyVar env tv - | Just ty <- lookupFsEnv env tv = ty - | otherwise = IfaceTyVar tv - - -{- -************************************************************************ -* * - Functions over IfaceAppArgs -* * -************************************************************************ --} - -stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs -stripInvisArgs dflags tys - | gopt Opt_PrintExplicitKinds dflags = tys - | otherwise = suppress_invis tys - where - suppress_invis c - = case c of - IA_Nil -> IA_Nil - IA_Arg t argf ts - | isVisibleArgFlag argf - -> IA_Arg t argf $ suppress_invis ts - -- Keep recursing through the remainder of the arguments, as it's - -- possible that there are remaining invisible ones. - -- See the "In type declarations" section of Note [VarBndrs, - -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. - | otherwise - -> suppress_invis ts - -appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] -appArgsIfaceTypes IA_Nil = [] -appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts - -appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] -appArgsIfaceTypesArgFlags IA_Nil = [] -appArgsIfaceTypesArgFlags (IA_Arg t a ts) - = (t, a) : appArgsIfaceTypesArgFlags ts - -ifaceVisAppArgsLength :: IfaceAppArgs -> Int -ifaceVisAppArgsLength = go 0 - where - go !n IA_Nil = n - go n (IA_Arg _ argf rest) - | isVisibleArgFlag argf = go (n+1) rest - | otherwise = go n rest - -{- -Note [Suppressing invisible arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use the IfaceAppArgs data type to specify which of the arguments to a type -should be displayed when pretty-printing, under the control of --fprint-explicit-kinds. -See also Type.filterOutInvisibleTypes. -For example, given - - T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism - 'Just :: forall k. k -> 'Maybe k -- Promoted - -we want - - T * Tree Int prints as T Tree Int - 'Just * prints as Just * - -For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, -since the corresponding Core constructor: - - data Type - = ... - | TyConApp TyCon [Type] - -Already puts all of its arguments into a list. So when converting a Type to an -IfaceType (see toIfaceAppArgsX in ToIface), we simply use the kind of the TyCon -(which is cached) to guide the process of converting the argument Types into an -IfaceAppArgs list. - -We also want this behavior for IfaceAppTy, since given: - - data Proxy (a :: k) - f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) - -We want to print the return type as `Proxy (t True)` without the use of --fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the -tycon case, because the corresponding Core constructor for IfaceAppTy: - - data Type - = ... - | AppTy Type Type - -Only stores one argument at a time. Therefore, when converting an AppTy to an -IfaceAppTy (in toIfaceTypeX in ToIface), we: - -1. Flatten the chain of AppTys down as much as possible -2. Use typeKind to determine the function Type's kind -3. Use this kind to guide the process of converting the argument Types into an - IfaceAppArgs list. - -By flattening the arguments like this, we obtain two benefits: - -(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as - we do IfaceTyApp arguments, which means that we only need to implement the - logic to filter out invisible arguments once. -(b) Unlike for tycons, finding the kind of a type in general (through typeKind) - is not a constant-time operation, so by flattening the arguments first, we - decrease the number of times we have to call typeKind. - -Note [Pretty-printing invisible arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [Suppressing invisible arguments] is all about how to avoid printing -invisible arguments when the -fprint-explicit-kinds flag is disables. Well, -what about when it's enabled? Then we can and should print invisible kind -arguments, and this Note explains how we do it. - -As two running examples, consider the following code: - - {-# LANGUAGE PolyKinds #-} - data T1 a - data T2 (a :: k) - -When displaying these types (with -fprint-explicit-kinds on), we could just -do the following: - - T1 k a - T2 k a - -That certainly gets the job done. But it lacks a crucial piece of information: -is the `k` argument inferred or specified? To communicate this, we use visible -kind application syntax to distinguish the two cases: - - T1 @{k} a - T2 @k a - -Here, @{k} indicates that `k` is an inferred argument, and @k indicates that -`k` is a specified argument. (See -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for -a lengthier explanation on what "inferred" and "specified" mean.) - -************************************************************************ -* * - Pretty-printing -* * -************************************************************************ --} - -if_print_coercions :: SDoc -- ^ if printing coercions - -> SDoc -- ^ otherwise - -> SDoc -if_print_coercions yes no - = sdocWithDynFlags $ \dflags -> - getPprStyle $ \style -> - if gopt Opt_PrintExplicitCoercions dflags - || dumpStyle style || debugStyle style - then yes - else no - -pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc -pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 - = maybeParen ctxt_prec opPrec $ - sep [pp_ty1, pp_tc <+> pp_ty2] - -pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc -pprIfacePrefixApp ctxt_prec pp_fun pp_tys - | null pp_tys = pp_fun - | otherwise = maybeParen ctxt_prec appPrec $ - hang pp_fun 2 (sep pp_tys) - -isIfaceTauType :: IfaceType -> Bool -isIfaceTauType (IfaceForAllTy _ _) = False -isIfaceTauType (IfaceFunTy InvisArg _ _) = False -isIfaceTauType _ = True - --- ----------------------------- Printing binders ------------------------------------ - -instance Outputable IfaceBndr where - ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr - ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr (SuppressBndrSig False) - (UseBndrParens False) - -pprIfaceBndrs :: [IfaceBndr] -> SDoc -pprIfaceBndrs bs = sep (map ppr bs) - -pprIfaceLamBndr :: IfaceLamBndr -> SDoc -pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b -pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" - -pprIfaceIdBndr :: IfaceIdBndr -> SDoc -pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) - -{- Note [Suppressing binder signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When printing the binders in a 'forall', we want to keep the kind annotations: - - forall (a :: k). blah - ^^^^ - good - -On the other hand, when we print the binders of a data declaration in :info, -the kind information would be redundant due to the standalone kind signature: - - type F :: Symbol -> Type - type F (s :: Symbol) = blah - ^^^^^^^^^ - redundant - -Here we'd like to omit the kind annotation: - - type F :: Symbol -> Type - type F s = blah --} - --- | Do we want to suppress kind annotations on binders? --- See Note [Suppressing binder signatures] -newtype SuppressBndrSig = SuppressBndrSig Bool - -newtype UseBndrParens = UseBndrParens Bool - -pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc -pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) - | suppress_sig = ppr tv - | isIfaceLiftedTypeKind ki = ppr tv - | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) - where - maybe_parens | use_parens = parens - | otherwise = id - -pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinder] -> SDoc -pprIfaceTyConBinders suppress_sig = sep . map go - where - go :: IfaceTyConBinder -> SDoc - go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr - go (Bndr (IfaceTvBndr bndr) vis) = - -- See Note [Pretty-printing invisible arguments] - case vis of - AnonTCB VisArg -> ppr_bndr (UseBndrParens True) - AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - -- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.) - -- Should we print these differently? - NamedTCB Required -> ppr_bndr (UseBndrParens True) - NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) - NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - where - ppr_bndr = pprIfaceTvBndr bndr suppress_sig - -instance Binary IfaceBndr where - put_ bh (IfaceIdBndr aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTvBndr ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceIdBndr aa) - _ -> do ab <- get bh - return (IfaceTvBndr ab) - -instance Binary IfaceOneShot where - put_ bh IfaceNoOneShot = do - putByte bh 0 - put_ bh IfaceOneShot = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return IfaceNoOneShot - _ -> do return IfaceOneShot - --- ----------------------------- Printing IfaceType ------------------------------------ - ---------------------------------- -instance Outputable IfaceType where - ppr ty = pprIfaceType ty - -pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc -pprIfaceType = pprPrecIfaceType topPrec -pprParendIfaceType = pprPrecIfaceType appPrec - -pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc --- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe --- called from other places, besides `:type` and `:info`. -pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty - -ppr_sigma :: PprPrec -> IfaceType -> SDoc -ppr_sigma ctxt_prec ty - = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) - -ppr_ty :: PprPrec -> IfaceType -> SDoc -ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty -ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _) = ppr_sigma ctxt_prec ty - -ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! -ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType] -ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys -ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n - -- Function types -ppr_ty ctxt_prec (IfaceFunTy _ ty1 ty2) -- Should be VisArg - = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - maybeParen ctxt_prec funPrec $ - sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)] - where - ppr_fun_tail (IfaceFunTy VisArg ty1 ty2) - = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2 - ppr_fun_tail other_ty - = [arrow <+> pprIfaceType other_ty] - -ppr_ty ctxt_prec (IfaceAppTy t ts) - = if_print_coercions - ppr_app_ty - ppr_app_ty_no_casts - where - ppr_app_ty = - sdocWithDynFlags $ \dflags -> - pprIfacePrefixApp ctxt_prec - (ppr_ty funPrec t) - (map (ppr_app_arg appPrec) (tys_wo_kinds dflags)) - - tys_wo_kinds dflags = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags ts - - -- Strip any casts from the head of the application - ppr_app_ty_no_casts = - case t of - IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) - _ -> ppr_app_ty - - mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType - mk_app_tys (IfaceTyConApp tc tys1) tys2 = - IfaceTyConApp tc (tys1 `mappend` tys2) - mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 - -ppr_ty ctxt_prec (IfaceCastTy ty co) - = if_print_coercions - (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) - (ppr_ty ctxt_prec ty) - -ppr_ty ctxt_prec (IfaceCoercionTy co) - = if_print_coercions - (ppr_co ctxt_prec co) - (text "<>") - -{- Note [Defaulting RuntimeRep variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -RuntimeRep variables are considered by many (most?) users to be little -more than syntactic noise. When the notion was introduced there was a -signficant and understandable push-back from those with pedagogy in -mind, which argued that RuntimeRep variables would throw a wrench into -nearly any teach approach since they appear in even the lowly ($) -function's type, - - ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b - -which is significantly less readable than its non RuntimeRep-polymorphic type of - - ($) :: (a -> b) -> a -> b - -Moreover, unboxed types don't appear all that often in run-of-the-mill -Haskell programs, so it makes little sense to make all users pay this -syntactic overhead. - -For this reason it was decided that we would hide RuntimeRep variables -for now (see #11549). We do this by defaulting all type variables of -kind RuntimeRep to LiftedRep. This is done in a pass right before -pretty-printing (defaultRuntimeRepVars, controlled by --fprint-explicit-runtime-reps) - -This applies to /quantified/ variables like 'w' above. What about -variables that are /free/ in the type being printed, which certainly -happens in error messages. Suppose (#16074) we are reporting a -mismatch between two skolems - (a :: RuntimeRep) ~ (b :: RuntimeRep) -We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"! - -But if we are printing the type - (forall (a :: Type r). blah -we do want to turn that (free) r into LiftedRep, so it prints as - (forall a. blah) - -Conclusion: keep track of whether we we are in the kind of a -binder; ohly if so, convert free RuntimeRep variables to LiftedRep. --} - --- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. --- --- @ --- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). --- (a -> b) -> a -> b --- @ --- --- turns in to, --- --- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ --- --- We do this to prevent RuntimeRep variables from incurring a significant --- syntactic overhead in otherwise simple type signatures (e.g. ($)). See --- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. --- -defaultRuntimeRepVars :: IfaceType -> IfaceType -defaultRuntimeRepVars ty = go False emptyFsEnv ty - where - go :: Bool -- True <=> Inside the kind of a binder - -> FastStringEnv () -- Set of enclosing forall-ed RuntimeRep variables - -> IfaceType -- (replace them with LiftedRep) - -> IfaceType - go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) - | isRuntimeRep var_kind - , isInvisibleArgFlag argf -- Don't default *visible* quantification - -- or we get the mess in #13963 - = let subs' = extendFsEnv subs var () - -- Record that we should replace it with LiftedRep, - -- and recurse, discarding the forall - in go ink subs' ty - - go ink subs (IfaceForAllTy bndr ty) - = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty) - - go _ subs ty@(IfaceTyVar tv) - | tv `elemFsEnv` subs - = IfaceTyConApp liftedRep IA_Nil - | otherwise - = ty - - go in_kind _ ty@(IfaceFreeTyVar tv) - -- See Note [Defaulting RuntimeRep variables], about free vars - | in_kind && Type.isRuntimeRepTy (tyVarKind tv) - = IfaceTyConApp liftedRep IA_Nil - | otherwise - = ty - - go ink subs (IfaceTyConApp tc tc_args) - = IfaceTyConApp tc (go_args ink subs tc_args) - - go ink subs (IfaceTupleTy sort is_prom tc_args) - = IfaceTupleTy sort is_prom (go_args ink subs tc_args) - - go ink subs (IfaceFunTy af arg res) - = IfaceFunTy af (go ink subs arg) (go ink subs res) - - go ink subs (IfaceAppTy t ts) - = IfaceAppTy (go ink subs t) (go_args ink subs ts) - - go ink subs (IfaceCastTy x co) - = IfaceCastTy (go ink subs x) co - - go _ _ ty@(IfaceLitTy {}) = ty - go _ _ ty@(IfaceCoercionTy {}) = ty - - go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr - go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf) - = Bndr (IfaceIdBndr (n, go True subs t)) argf - go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) - = Bndr (IfaceTvBndr (n, go True subs t)) argf - - go_args :: Bool -> FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs - go_args _ _ IA_Nil = IA_Nil - go_args ink subs (IA_Arg ty argf args) - = IA_Arg (go ink subs ty) argf (go_args ink subs args) - - liftedRep :: IfaceTyCon - liftedRep = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) - where dc_name = getName liftedRepDataConTyCon - - isRuntimeRep :: IfaceType -> Bool - isRuntimeRep (IfaceTyConApp tc _) = - tc `ifaceTyConHasKey` runtimeRepTyConKey - isRuntimeRep _ = False - -eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc -eliminateRuntimeRep f ty - = sdocWithDynFlags $ \dflags -> - getPprStyle $ \sty -> - if userStyle sty && not (gopt Opt_PrintExplicitRuntimeReps dflags) - then f (defaultRuntimeRepVars ty) - else f ty - -instance Outputable IfaceAppArgs where - ppr tca = pprIfaceAppArgs tca - -pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc -pprIfaceAppArgs = ppr_app_args topPrec -pprParendIfaceAppArgs = ppr_app_args appPrec - -ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc -ppr_app_args ctx_prec = go - where - go :: IfaceAppArgs -> SDoc - go IA_Nil = empty - go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts - --- See Note [Pretty-printing invisible arguments] -ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc -ppr_app_arg ctx_prec (t, argf) = - sdocWithDynFlags $ \dflags -> - let print_kinds = gopt Opt_PrintExplicitKinds dflags - in case argf of - Required -> ppr_ty ctx_prec t - Specified | print_kinds - -> char '@' <> ppr_ty appPrec t - Inferred | print_kinds - -> char '@' <> braces (ppr_ty topPrec t) - _ -> empty - -------------------- -pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -pprIfaceForAllPart tvs ctxt sdoc - = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc - --- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. -pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -pprIfaceForAllPartMust tvs ctxt sdoc - = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc - -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc -pprIfaceForAllCoPart tvs sdoc - = sep [ pprIfaceForAllCo tvs, sdoc ] - -ppr_iface_forall_part :: ShowForAllFlag - -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -ppr_iface_forall_part show_forall tvs ctxt sdoc - = sep [ case show_forall of - ShowForAllMust -> pprIfaceForAll tvs - ShowForAllWhen -> pprUserIfaceForAll tvs - , pprIfaceContextArr ctxt - , sdoc] - --- | Render the "forall ... ." or "forall ... ->" bit of a type. -pprIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprIfaceForAll [] = empty -pprIfaceForAll bndrs@(Bndr _ vis : _) - = sep [ add_separator (forAllLit <+> fsep docs) - , pprIfaceForAll bndrs' ] - where - (bndrs', docs) = ppr_itv_bndrs bndrs vis - - add_separator stuff = case vis of - Required -> stuff <+> arrow - _inv -> stuff <> dot - - --- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. --- Returns both the list of not-yet-rendered binders and the doc. --- No anonymous binders here! -ppr_itv_bndrs :: [IfaceForAllBndr] - -> ArgFlag -- ^ visibility of the first binder in the list - -> ([IfaceForAllBndr], [SDoc]) -ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 - | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in - (bndrs', pprIfaceForAllBndr bndr : doc) - | otherwise = (all_bndrs, []) -ppr_itv_bndrs [] _ = ([], []) - -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCo [] = empty -pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot - -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs - -pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc -pprIfaceForAllBndr bndr = - case bndr of - Bndr (IfaceTvBndr tv) Inferred -> - sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitForalls dflags - then braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) - else pprIfaceTvBndr tv suppress_sig (UseBndrParens True) - Bndr (IfaceTvBndr tv) _ -> - pprIfaceTvBndr tv suppress_sig (UseBndrParens True) - Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv - where - -- See Note [Suppressing binder signatures] in IfaceType - suppress_sig = SuppressBndrSig False - -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc -pprIfaceForAllCoBndr (tv, kind_co) - = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) - --- | Show forall flag --- --- Unconditionally show the forall quantifier with ('ShowForAllMust') --- or when ('ShowForAllWhen') the names used are free in the binder --- or when compiling with -fprint-explicit-foralls. -data ShowForAllFlag = ShowForAllMust | ShowForAllWhen - -pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc -pprIfaceSigmaType show_forall ty - = eliminateRuntimeRep ppr_fn ty - where - ppr_fn iface_ty = - let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty - in ppr_iface_forall_part show_forall tvs theta (ppr tau) - -pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprUserIfaceForAll tvs - = sdocWithDynFlags $ \dflags -> - -- See Note [When to print foralls] in this module. - ppWhen (any tv_has_kind_var tvs - || any tv_is_required tvs - || gopt Opt_PrintExplicitForalls dflags) $ - pprIfaceForAll tvs - where - tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) - = not (ifTypeIsVarFree kind) - tv_has_kind_var _ = False - - tv_is_required = isVisibleArgFlag . binderArgFlag - -{- -Note [When to print foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We opt to explicitly pretty-print `forall`s if any of the following -criteria are met: - -1. -fprint-explicit-foralls is on. - -2. A bound type variable has a polymorphic kind. E.g., - - forall k (a::k). Proxy a -> Proxy a - - Since a's kind mentions a variable k, we print the foralls. - -3. A bound type variable is a visible argument (#14238). - Suppose we are printing the kind of: - - T :: forall k -> k -> Type - - The "forall k ->" notation means that this kind argument is required. - That is, it must be supplied at uses of T. E.g., - - f :: T (Type->Type) Monad -> Int - - So we print an explicit "T :: forall k -> k -> Type", - because omitting it and printing "T :: k -> Type" would be - utterly misleading. - - See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] - in TyCoRep. - -N.B. Until now (Aug 2018) we didn't check anything for coercion variables. - -Note [Printing foralls in type family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use the same criteria as in Note [When to print foralls] to determine -whether a type family instance should be pretty-printed with an explicit -`forall`. Example: - - type family Foo (a :: k) :: k where - Foo Maybe = [] - Foo (a :: Type) = Int - Foo a = a - -Without -fprint-explicit-foralls enabled, this will be pretty-printed as: - -type family Foo (a :: k) :: k where - Foo Maybe = [] - Foo a = Int - forall k (a :: k). Foo a = a - -Note that only the third equation has an explicit forall, since it has a type -variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then -the second equation would be preceded with `forall a.`.) - -There is one tricky point in the implementation: what visibility -do we give the type variables in a type family instance? Type family instances -only store type *variables*, not type variable *binders*, and only the latter -has visibility information. We opt to default the visibility of each of these -type variables to Specified because users can't ever instantiate these -variables manually, so the choice of visibility is only relevant to -pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is -printed the way it is, even though it wasn't written explicitly in the -original source code.) - -We adopt the same strategy for data family instances. Example: - - data family DF (a :: k) - data instance DF '[a, b] = DFList - -That data family instance is pretty-printed as: - - data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList - -This is despite that the representation tycon for this data instance (call it -$DF:List) actually has different visibilities for its binders. -However, the visibilities of these binders are utterly irrelevant to the -programmer, who cares only about the specificity of variables in `DF`'s type, -not $DF:List's type. Therefore, we opt to pretty-print all variables in data -family instances as Specified. - -Note [Printing promoted type constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GHCi session (#14343) - > _ :: Proxy '[ 'True ] - error: - Found hole: _ :: Proxy '['True] - -This would be bad, because the '[' looks like a character literal. -Solution: in type-level lists and tuples, add a leading space -if the first type is itself promoted. See pprSpaceIfPromotedTyCon. --} - - -------------------- - --- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. --- See Note [Printing promoted type constructors] -pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc -pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) - = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of - IsPromoted -> (space <>) - _ -> id -pprSpaceIfPromotedTyCon _ - = id - --- See equivalent function in TyCoRep.hs -pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc --- Given a type-level list (t1 ': t2), see if we can print --- it in list notation [t1, ...]. --- Precondition: Opt_PrintExplicitKinds is off -pprIfaceTyList ctxt_prec ty1 ty2 - = case gather ty2 of - (arg_tys, Nothing) - -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep - (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) - (arg_tys, Just tl) - -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) - 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) - where - gather :: IfaceType -> ([IfaceType], Maybe IfaceType) - -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] - -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl - gather (IfaceTyConApp tc tys) - | tc `ifaceTyConHasKey` consDataConKey - , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys - , isInvisibleArgFlag argf - , (args, tl) <- gather ty2 - = (ty1:args, tl) - | tc `ifaceTyConHasKey` nilDataConKey - = ([], Nothing) - gather ty = ([], Just ty) - -pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc -pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args - -pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc -pprTyTcApp ctxt_prec tc tys = - sdocWithDynFlags $ \dflags -> - getPprStyle $ \style -> - pprTyTcApp' ctxt_prec tc tys dflags style - -pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs - -> DynFlags -> PprStyle -> SDoc -pprTyTcApp' ctxt_prec tc tys dflags style - | ifaceTyConName tc `hasKey` ipClassKey - , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) - Required (IA_Arg ty Required IA_Nil) <- tys - = maybeParen ctxt_prec funPrec - $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty - - | IfaceTupleTyCon arity sort <- ifaceTyConSort info - , not (debugStyle style) - , arity == ifaceVisAppArgsLength tys - = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys - - | IfaceSumTyCon arity <- ifaceTyConSort info - = pprSum arity (ifaceTyConIsPromoted info) tys - - | tc `ifaceTyConHasKey` consDataConKey - , not (gopt Opt_PrintExplicitKinds dflags) - , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys - , isInvisibleArgFlag argf - = pprIfaceTyList ctxt_prec ty1 ty2 - - | tc `ifaceTyConHasKey` tYPETyConKey - , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys - , rep `ifaceTyConHasKey` liftedRepDataConKey - = kindType - - | otherwise - = getPprDebug $ \dbg -> - if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey - -- Suppress detail unles you _really_ want to see - -> text "(TypeError ...)" - - | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) - -> doc - - | otherwise - -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds - where - info = ifaceTyConInfo tc - tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags tys - --- | Pretty-print a type-level equality. --- Returns (Just doc) if the argument is a /saturated/ application --- of eqTyCon (~) --- eqPrimTyCon (~#) --- eqReprPrimTyCon (~R#) --- heqTyCon (~~) --- --- See Note [Equality predicates in IfaceType] --- and Note [The equality types story] in TysPrim -ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc -ppr_equality ctxt_prec tc args - | hetero_eq_tc - , [k1, k2, t1, t2] <- args - = Just $ print_equality (k1, k2, t1, t2) - - | hom_eq_tc - , [k, t1, t2] <- args - = Just $ print_equality (k, k, t1, t2) - - | otherwise - = Nothing - where - homogeneous = tc_name `hasKey` eqTyConKey -- (~) - || hetero_tc_used_homogeneously - where - hetero_tc_used_homogeneously - = case ifaceTyConSort $ ifaceTyConInfo tc of - IfaceEqualityTyCon -> True - _other -> False - -- True <=> a heterogeneous equality whose arguments - -- are (in this case) of the same kind - - tc_name = ifaceTyConName tc - pp = ppr_ty - hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) - hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) - || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) - || tc_name `hasKey` heqTyConKey -- (~~) - nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) - || tc_name `hasKey` eqPrimTyConKey -- (~#) - print_equality args = - sdocWithDynFlags $ \dflags -> - getPprStyle $ \style -> - print_equality' args style dflags - - print_equality' (ki1, ki2, ty1, ty2) style dflags - | -- If -fprint-equality-relations is on, just print the original TyCon - print_eqs - = ppr_infix_eq (ppr tc) - - | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) - -- or unlifted equality (ty1 ~# ty2) - nominal_eq_tc, homogeneous - = ppr_infix_eq (text "~") - - | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) - not homogeneous - = ppr_infix_eq (ppr heqTyCon) - - | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) - tc_name `hasKey` eqReprPrimTyConKey, homogeneous - = let ki | print_kinds = [pp appPrec ki1] - | otherwise = [] - in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) - (ki ++ [pp appPrec ty1, pp appPrec ty2]) - - -- The other cases work as you'd expect - | otherwise - = ppr_infix_eq (ppr tc) - where - ppr_infix_eq :: SDoc -> SDoc - ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op - (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) - where - pp_ty_ki ty ki - | print_kinds - = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) - | otherwise - = pp opPrec ty - - print_kinds = gopt Opt_PrintExplicitKinds dflags - print_eqs = gopt Opt_PrintEqualityRelations dflags || - dumpStyle style || debugStyle style - - -pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc -pprIfaceCoTcApp ctxt_prec tc tys = - ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc - (map (, Required) tys) - -- We are trying to re-use ppr_iface_tc_app here, which requires its - -- arguments to be accompanied by visibilities. But visibility is - -- irrelevant when printing coercions, so just default everything to - -- Required. - --- | Pretty-prints an application of a type constructor to some arguments --- (whose visibilities are known). This is polymorphic (over @a@) since we use --- this function to pretty-print two different things: --- --- 1. Types (from `pprTyTcApp'`) --- --- 2. Coercions (from 'pprIfaceCoTcApp') -ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) - -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc -ppr_iface_tc_app pp _ tc [ty] - | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) - -ppr_iface_tc_app pp ctxt_prec tc tys - | tc `ifaceTyConHasKey` liftedTypeKindTyConKey - = kindType - - | not (isSymOcc (nameOccName (ifaceTyConName tc))) - = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) - - | [ ty1@(_, Required) - , ty2@(_, Required) ] <- tys - -- Infix, two visible arguments (we know nothing of precedence though). - -- Don't apply this special case if one of the arguments is invisible, - -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). - = pprIfaceInfixApp ctxt_prec (ppr tc) - (pp opPrec ty1) (pp opPrec ty2) - - | otherwise - = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) - -pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc -pprSum _arity is_promoted args - = -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - let tys = appArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - in pprPromotionQuoteI is_promoted - <> sumParens (pprWithBars (ppr_ty topPrec) args') - -pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc -pprTuple ctxt_prec sort promoted args = - case promoted of - IsPromoted - -> let tys = appArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - spaceIfPromoted = case args' of - arg0:_ -> pprSpaceIfPromotedTyCon arg0 - _ -> id - in ppr_tuple_app args' $ - pprPromotionQuoteI IsPromoted <> - tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) - - NotPromoted - | ConstraintTuple <- sort - , IA_Nil <- args - -> maybeParen ctxt_prec sigPrec $ - text "() :: Constraint" - - | otherwise - -> -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - let tys = appArgsIfaceTypes args - args' = case sort of - UnboxedTuple -> drop (length tys `div` 2) tys - _ -> tys - in - ppr_tuple_app args' $ - pprPromotionQuoteI promoted <> - tupleParens sort (pprWithCommas pprIfaceType args') - where - ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc - ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens - -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Unit x`, not `(x)` - | [_] <- args_wo_runtime_reps - , BoxedTuple <- sort - = let unit_tc_info = IfaceTyConInfo promoted IfaceNormalTyCon - unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in - pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args - | otherwise - = ppr_args_w_parens - -pprIfaceTyLit :: IfaceTyLit -> SDoc -pprIfaceTyLit (IfaceNumTyLit n) = integer n -pprIfaceTyLit (IfaceStrTyLit n) = text (show n) - -pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc -pprIfaceCoercion = ppr_co topPrec -pprParendIfaceCoercion = ppr_co appPrec - -ppr_co :: PprPrec -> IfaceCoercion -> SDoc -ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal -ppr_co _ (IfaceGReflCo r ty IfaceMRefl) - = angleBrackets (ppr ty) <> ppr_role r -ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) - = ppr_special_co ctxt_prec - (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] -ppr_co ctxt_prec (IfaceFunCo r co1 co2) - = maybeParen ctxt_prec funPrec $ - sep (ppr_co funPrec co1 : ppr_fun_tail co2) - where - ppr_fun_tail (IfaceFunCo r co1 co2) - = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2 - ppr_fun_tail other_co - = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] - -ppr_co _ (IfaceTyConAppCo r tc cos) - = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r -ppr_co ctxt_prec (IfaceAppCo co1 co2) - = maybeParen ctxt_prec appPrec $ - ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 -ppr_co ctxt_prec co@(IfaceForAllCo {}) - = maybeParen ctxt_prec funPrec $ - pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) - where - (tvs, inner_co) = split_co co - - split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') - = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') - split_co (IfaceForAllCo (IfaceIdBndr (name, _)) kind_co co') - = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') - split_co co' = ([], co') - --- Why these three? See Note [TcTyVars in IfaceType] -ppr_co _ (IfaceFreeCoVar covar) = ppr covar -ppr_co _ (IfaceCoVarCo covar) = ppr covar -ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) - -ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) - = maybeParen ctxt_prec appPrec $ - text "UnsafeCo" <+> ppr r <+> - pprParendIfaceType ty1 <+> pprParendIfaceType ty2 - -ppr_co _ (IfaceUnivCo prov role ty1 ty2) - = text "Univ" <> (parens $ - sep [ ppr role <+> pprIfaceUnivCoProv prov - , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) - -ppr_co ctxt_prec (IfaceInstCo co ty) - = maybeParen ctxt_prec appPrec $ - text "Inst" <+> pprParendIfaceCoercion co - <+> pprParendIfaceCoercion ty - -ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) - = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) - -ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) - = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos -ppr_co ctxt_prec (IfaceSymCo co) - = ppr_special_co ctxt_prec (text "Sym") [co] -ppr_co ctxt_prec (IfaceTransCo co1 co2) - = maybeParen ctxt_prec opPrec $ - ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2 -ppr_co ctxt_prec (IfaceNthCo d co) - = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] -ppr_co ctxt_prec (IfaceLRCo lr co) - = ppr_special_co ctxt_prec (ppr lr) [co] -ppr_co ctxt_prec (IfaceSubCo co) - = ppr_special_co ctxt_prec (text "Sub") [co] -ppr_co ctxt_prec (IfaceKindCo co) - = ppr_special_co ctxt_prec (text "Kind") [co] - -ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc -ppr_special_co ctxt_prec doc cos - = maybeParen ctxt_prec appPrec - (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) - -ppr_role :: Role -> SDoc -ppr_role r = underscore <> pp_role - where pp_role = case r of - Nominal -> char 'N' - Representational -> char 'R' - Phantom -> char 'P' - ------------------- -pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc -pprIfaceUnivCoProv IfaceUnsafeCoerceProv - = text "unsafe" -pprIfaceUnivCoProv (IfacePhantomProv co) - = text "phantom" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfaceProofIrrelProv co) - = text "irrel" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfacePluginProv s) - = text "plugin" <+> doubleQuotes (text s) - -------------------- -instance Outputable IfaceTyCon where - ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) - -pprPromotionQuote :: IfaceTyCon -> SDoc -pprPromotionQuote tc = - pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc - -pprPromotionQuoteI :: PromotionFlag -> SDoc -pprPromotionQuoteI NotPromoted = empty -pprPromotionQuoteI IsPromoted = char '\'' - -instance Outputable IfaceCoercion where - ppr = pprIfaceCoercion - -instance Binary IfaceTyCon where - put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i - - get bh = do n <- get bh - i <- get bh - return (IfaceTyCon n i) - -instance Binary IfaceTyConSort where - put_ bh IfaceNormalTyCon = putByte bh 0 - put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort - put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity - put_ bh IfaceEqualityTyCon = putByte bh 3 - - get bh = do - n <- getByte bh - case n of - 0 -> return IfaceNormalTyCon - 1 -> IfaceTupleTyCon <$> get bh <*> get bh - 2 -> IfaceSumTyCon <$> get bh - _ -> return IfaceEqualityTyCon - -instance Binary IfaceTyConInfo where - put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s - - get bh = IfaceTyConInfo <$> get bh <*> get bh - -instance Outputable IfaceTyLit where - ppr = pprIfaceTyLit - -instance Binary IfaceTyLit where - put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n - put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n - - get bh = - do tag <- getByte bh - case tag of - 1 -> do { n <- get bh - ; return (IfaceNumTyLit n) } - 2 -> do { n <- get bh - ; return (IfaceStrTyLit n) } - _ -> panic ("get IfaceTyLit " ++ show tag) - -instance Binary IfaceAppArgs where - put_ bh tk = - case tk of - IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts - IA_Nil -> putByte bh 1 - - get bh = - do c <- getByte bh - case c of - 0 -> do - t <- get bh - a <- get bh - ts <- get bh - return $! IA_Arg t a ts - 1 -> return IA_Nil - _ -> panic ("get IfaceAppArgs " ++ show c) - -------------------- - --- Some notes about printing contexts --- --- In the event that we are printing a singleton context (e.g. @Eq a@) we can --- omit parentheses. However, we must take care to set the precedence correctly --- to opPrec, since something like @a :~: b@ must be parenthesized (see --- #9658). --- --- When printing a larger context we use 'fsep' instead of 'sep' so that --- the context doesn't get displayed as a giant column. Rather than, --- instance (Eq a, --- Eq b, --- Eq c, --- Eq d, --- Eq e, --- Eq f, --- Eq g, --- Eq h, --- Eq i, --- Eq j, --- Eq k, --- Eq l) => --- Eq (a, b, c, d, e, f, g, h, i, j, k, l) --- --- we want --- --- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, --- Eq j, Eq k, Eq l) => --- Eq (a, b, c, d, e, f, g, h, i, j, k, l) - - - --- | Prints "(C a, D b) =>", including the arrow. --- Used when we want to print a context in a type, so we --- use 'funPrec' to decide whether to parenthesise a singleton --- predicate; e.g. Num a => a -> a -pprIfaceContextArr :: [IfacePredType] -> SDoc -pprIfaceContextArr [] = empty -pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow -pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow - --- | Prints a context or @()@ if empty --- You give it the context precedence -pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc -pprIfaceContext _ [] = text "()" -pprIfaceContext prec [pred] = ppr_ty prec pred -pprIfaceContext _ preds = ppr_parend_preds preds - -ppr_parend_preds :: [IfacePredType] -> SDoc -ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) - -instance Binary IfaceType where - put_ _ (IfaceFreeTyVar tv) - = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) - - put_ bh (IfaceForAllTy aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (IfaceTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (IfaceAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (IfaceFunTy af ag ah) = do - putByte bh 3 - put_ bh af - put_ bh ag - put_ bh ah - put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 5; put_ bh tc; put_ bh tys } - put_ bh (IfaceCastTy a b) - = do { putByte bh 6; put_ bh a; put_ bh b } - put_ bh (IfaceCoercionTy a) - = do { putByte bh 7; put_ bh a } - put_ bh (IfaceTupleTy s i tys) - = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } - put_ bh (IfaceLitTy n) - = do { putByte bh 9; put_ bh n } - - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (IfaceForAllTy aa ab) - 1 -> do ad <- get bh - return (IfaceTyVar ad) - 2 -> do ae <- get bh - af <- get bh - return (IfaceAppTy ae af) - 3 -> do af <- get bh - ag <- get bh - ah <- get bh - return (IfaceFunTy af ag ah) - 5 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp tc tys) } - 6 -> do { a <- get bh; b <- get bh - ; return (IfaceCastTy a b) } - 7 -> do { a <- get bh - ; return (IfaceCoercionTy a) } - - 8 -> do { s <- get bh; i <- get bh; tys <- get bh - ; return (IfaceTupleTy s i tys) } - _ -> do n <- get bh - return (IfaceLitTy n) - -instance Binary IfaceMCoercion where - put_ bh IfaceMRefl = do - putByte bh 1 - put_ bh (IfaceMCo co) = do - putByte bh 2 - put_ bh co - - get bh = do - tag <- getByte bh - case tag of - 1 -> return IfaceMRefl - 2 -> do a <- get bh - return $ IfaceMCo a - _ -> panic ("get IfaceMCoercion " ++ show tag) - -instance Binary IfaceCoercion where - put_ bh (IfaceReflCo a) = do - putByte bh 1 - put_ bh a - put_ bh (IfaceGReflCo a b c) = do - putByte bh 2 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceFunCo a b c) = do - putByte bh 3 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceTyConAppCo a b c) = do - putByte bh 4 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceAppCo a b) = do - putByte bh 5 - put_ bh a - put_ bh b - put_ bh (IfaceForAllCo a b c) = do - putByte bh 6 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceCoVarCo a) = do - putByte bh 7 - put_ bh a - put_ bh (IfaceAxiomInstCo a b c) = do - putByte bh 8 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceUnivCo a b c d) = do - putByte bh 9 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfaceSymCo a) = do - putByte bh 10 - put_ bh a - put_ bh (IfaceTransCo a b) = do - putByte bh 11 - put_ bh a - put_ bh b - put_ bh (IfaceNthCo a b) = do - putByte bh 12 - put_ bh a - put_ bh b - put_ bh (IfaceLRCo a b) = do - putByte bh 13 - put_ bh a - put_ bh b - put_ bh (IfaceInstCo a b) = do - putByte bh 14 - put_ bh a - put_ bh b - put_ bh (IfaceKindCo a) = do - putByte bh 15 - put_ bh a - put_ bh (IfaceSubCo a) = do - putByte bh 16 - put_ bh a - put_ bh (IfaceAxiomRuleCo a b) = do - putByte bh 17 - put_ bh a - put_ bh b - put_ _ (IfaceFreeCoVar cv) - = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) - put_ _ (IfaceHoleCo cv) - = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) - -- See Note [Holes in IfaceCoercion] - - get bh = do - tag <- getByte bh - case tag of - 1 -> do a <- get bh - return $ IfaceReflCo a - 2 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceGReflCo a b c - 3 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceFunCo a b c - 4 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceTyConAppCo a b c - 5 -> do a <- get bh - b <- get bh - return $ IfaceAppCo a b - 6 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceForAllCo a b c - 7 -> do a <- get bh - return $ IfaceCoVarCo a - 8 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceAxiomInstCo a b c - 9 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return $ IfaceUnivCo a b c d - 10-> do a <- get bh - return $ IfaceSymCo a - 11-> do a <- get bh - b <- get bh - return $ IfaceTransCo a b - 12-> do a <- get bh - b <- get bh - return $ IfaceNthCo a b - 13-> do a <- get bh - b <- get bh - return $ IfaceLRCo a b - 14-> do a <- get bh - b <- get bh - return $ IfaceInstCo a b - 15-> do a <- get bh - return $ IfaceKindCo a - 16-> do a <- get bh - return $ IfaceSubCo a - 17-> do a <- get bh - b <- get bh - return $ IfaceAxiomRuleCo a b - _ -> panic ("get IfaceCoercion " ++ show tag) - -instance Binary IfaceUnivCoProv where - put_ bh IfaceUnsafeCoerceProv = putByte bh 1 - put_ bh (IfacePhantomProv a) = do - putByte bh 2 - put_ bh a - put_ bh (IfaceProofIrrelProv a) = do - putByte bh 3 - put_ bh a - put_ bh (IfacePluginProv a) = do - putByte bh 4 - put_ bh a - - get bh = do - tag <- getByte bh - case tag of - 1 -> return $ IfaceUnsafeCoerceProv - 2 -> do a <- get bh - return $ IfacePhantomProv a - 3 -> do a <- get bh - return $ IfaceProofIrrelProv a - 4 -> do a <- get bh - return $ IfacePluginProv a - _ -> panic ("get IfaceUnivCoProv " ++ show tag) - - -instance Binary (DefMethSpec IfaceType) where - put_ bh VanillaDM = putByte bh 0 - put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t - get bh = do - h <- getByte bh - case h of - 0 -> return VanillaDM - _ -> do { t <- get bh; return (GenericDM t) } - -instance NFData IfaceType where - rnf = \case - IfaceFreeTyVar f1 -> f1 `seq` () - IfaceTyVar f1 -> rnf f1 - IfaceLitTy f1 -> rnf f1 - IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 - IfaceFunTy f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 - IfaceForAllTy f1 f2 -> f1 `seq` rnf f2 - IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 - IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 - IfaceCoercionTy f1 -> rnf f1 - IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3 - -instance NFData IfaceTyLit where - rnf = \case - IfaceNumTyLit f1 -> rnf f1 - IfaceStrTyLit f1 -> rnf f1 - -instance NFData IfaceCoercion where - rnf = \case - IfaceReflCo f1 -> rnf f1 - IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 - IfaceFunCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 - IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 - IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 - IfaceCoVarCo f1 -> rnf f1 - IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 - IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 - IfaceSymCo f1 -> rnf f1 - IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceNthCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceLRCo f1 f2 -> f1 `seq` rnf f2 - IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceKindCo f1 -> rnf f1 - IfaceSubCo f1 -> rnf f1 - IfaceFreeCoVar f1 -> f1 `seq` () - IfaceHoleCo f1 -> f1 `seq` () - -instance NFData IfaceUnivCoProv where - rnf x = seq x () - -instance NFData IfaceMCoercion where - rnf x = seq x () - -instance NFData IfaceOneShot where - rnf x = seq x () - -instance NFData IfaceTyConSort where - rnf = \case - IfaceNormalTyCon -> () - IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` () - IfaceSumTyCon arity -> rnf arity - IfaceEqualityTyCon -> () - -instance NFData IfaceTyConInfo where - rnf (IfaceTyConInfo f s) = f `seq` rnf s - -instance NFData IfaceTyCon where - rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info - -instance NFData IfaceBndr where - rnf = \case - IfaceIdBndr id_bndr -> rnf id_bndr - IfaceTvBndr tv_bndr -> rnf tv_bndr - -instance NFData IfaceAppArgs where - rnf = \case - IA_Nil -> () - IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3 diff --git a/iface/IfaceType.hs-boot b/iface/IfaceType.hs-boot deleted file mode 100644 --- a/iface/IfaceType.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ --- Used only by ToIface.hs-boot - -module IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr - , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) where - -import Var (VarBndr, ArgFlag) - -data IfaceAppArgs - -data IfaceType -data IfaceTyCon -data IfaceTyLit -data IfaceCoercion -data IfaceBndr -type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag diff --git a/iface/LoadIface.hs b/iface/LoadIface.hs deleted file mode 100644 --- a/iface/LoadIface.hs +++ /dev/null @@ -1,1289 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Loading interface files --} - -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module LoadIface ( - -- Importing one thing - tcLookupImported_maybe, importDecl, - checkWiredInTyCon, ifCheckWiredInThing, - - -- RnM/TcM functions - loadModuleInterface, loadModuleInterfaces, - loadSrcInterface, loadSrcInterface_maybe, - loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule, - - -- IfM functions - loadInterface, - loadSysInterface, loadUserInterface, loadPluginInterface, - findAndReadIface, readIface, -- Used when reading the module's old interface - loadDecls, -- Should move to TcIface and be renamed - initExternalPackageState, - moduleFreeHolesPrecise, - needWiredInHomeIface, loadWiredInHomeIface, - - pprModIfaceSimple, - ifaceStats, pprModIface, showIface - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, - tcIfaceFamInst, - tcIfaceAnnotations, tcIfaceCompleteSigs ) - -import DynFlags -import IfaceSyn -import IfaceEnv -import HscTypes - -import BasicTypes hiding (SuccessFlag(..)) -import TcRnMonad - -import Constants -import PrelNames -import PrelInfo -import PrimOp ( allThePrimOps, primOpFixity, primOpOcc ) -import MkId ( seqId ) -import TysPrim ( funTyConName ) -import Rules -import TyCon -import Annotations -import InstEnv -import FamInstEnv -import Name -import NameEnv -import Avail -import Module -import Maybes -import ErrUtils -import Finder -import UniqFM -import SrcLoc -import Outputable -import BinIface -import Panic -import Util -import FastString -import Fingerprint -import Hooks -import FieldLabel -import RnModIface -import UniqDSet -import Plugins - -import Control.Monad -import Control.Exception -import Data.IORef -import System.FilePath - -{- -************************************************************************ -* * -* tcImportDecl is the key function for "faulting in" * -* imported things -* * -************************************************************************ - -The main idea is this. We are chugging along type-checking source code, and -find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find -it in the EPS type envt. So it - 1 loads GHC.Base.hi - 2 gets the decl for GHC.Base.map - 3 typechecks it via tcIfaceDecl - 4 and adds it to the type env in the EPS - -Note that DURING STEP 4, we may find that map's type mentions a type -constructor that also - -Notice that for imported things we read the current version from the EPS -mutable variable. This is important in situations like - ...$(e1)...$(e2)... -where the code that e1 expands to might import some defns that -also turn out to be needed by the code that e2 expands to. --} - -tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) --- Returns (Failed err) if we can't find the interface file for the thing -tcLookupImported_maybe name - = do { hsc_env <- getTopEnv - ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) - ; case mb_thing of - Just thing -> return (Succeeded thing) - Nothing -> tcImportDecl_maybe name } - -tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) --- Entry point for *source-code* uses of importDecl -tcImportDecl_maybe name - | Just thing <- wiredInNameTyThing_maybe name - = do { when (needWiredInHomeIface thing) - (initIfaceTcRn (loadWiredInHomeIface name)) - -- See Note [Loading instances for wired-in things] - ; return (Succeeded thing) } - | otherwise - = initIfaceTcRn (importDecl name) - -importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) --- Get the TyThing for this Name from an interface file --- It's not a wired-in thing -- the caller caught that -importDecl name - = ASSERT( not (isWiredInName name) ) - do { traceIf nd_doc - - -- Load the interface, which should populate the PTE - ; mb_iface <- ASSERT2( isExternalName name, ppr name ) - loadInterface nd_doc (nameModule name) ImportBySystem - ; case mb_iface of { - Failed err_msg -> return (Failed err_msg) ; - Succeeded _ -> do - - -- Now look it up again; this time we should find it - { eps <- getEps - ; case lookupTypeEnv (eps_PTE eps) name of - Just thing -> return $ Succeeded thing - Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty) - $$ not_found_msg - in return $ Failed doc - }}} - where - nd_doc = text "Need decl for" <+> ppr name - not_found_msg = hang (text "Can't find interface-file declaration for" <+> - pprNameSpace (nameNameSpace name) <+> ppr name) - 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", - text "Use -ddump-if-trace to get an idea of which file caused the error"]) - found_things_msg eps = - hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) - 2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps)) - where - is_interesting thing = nameModule name == nameModule (getName thing) - - -{- -************************************************************************ -* * - Checks for wired-in things -* * -************************************************************************ - -Note [Loading instances for wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to make sure that we have at least *read* the interface files -for any module with an instance decl or RULE that we might want. - -* If the instance decl is an orphan, we have a whole separate mechanism - (loadOrphanModules) - -* If the instance decl is not an orphan, then the act of looking at the - TyCon or Class will force in the defining module for the - TyCon/Class, and hence the instance decl - -* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; - but we must make sure we read its interface in case it has instances or - rules. That is what LoadIface.loadWiredInHomeIface does. It's called - from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} - -* HOWEVER, only do this for TyCons. There are no wired-in Classes. There - are some wired-in Ids, but we don't want to load their interfaces. For - example, Control.Exception.Base.recSelError is wired in, but that module - is compiled late in the base library, and we don't want to force it to - load before it's been compiled! - -All of this is done by the type checker. The renamer plays no role. -(It used to, but no longer.) --} - -checkWiredInTyCon :: TyCon -> TcM () --- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. See Note [Loading instances for wired-in things] --- It might not be a wired-in tycon (see the calls in TcUnify), --- in which case this is a no-op. -checkWiredInTyCon tc - | not (isWiredInName tc_name) - = return () - | otherwise - = do { mod <- getModule - ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) - ; ASSERT( isExternalName tc_name ) - when (mod /= nameModule tc_name) - (initIfaceTcRn (loadWiredInHomeIface tc_name)) - -- Don't look for (non-existent) Float.hi when - -- compiling Float.hs, which mentions Float of course - -- A bit yukky to call initIfaceTcRn here - } - where - tc_name = tyConName tc - -ifCheckWiredInThing :: TyThing -> IfL () --- Even though we are in an interface file, we want to make --- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) --- Ditto want to ensure that RULES are loaded too --- See Note [Loading instances for wired-in things] -ifCheckWiredInThing thing - = do { mod <- getIfModule - -- Check whether we are typechecking the interface for this - -- very module. E.g when compiling the base library in --make mode - -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in - -- the HPT, so without the test we'll demand-load it into the PIT! - -- C.f. the same test in checkWiredInTyCon above - ; let name = getName thing - ; ASSERT2( isExternalName name, ppr name ) - when (needWiredInHomeIface thing && mod /= nameModule name) - (loadWiredInHomeIface name) } - -needWiredInHomeIface :: TyThing -> Bool --- Only for TyCons; see Note [Loading instances for wired-in things] -needWiredInHomeIface (ATyCon {}) = True -needWiredInHomeIface _ = False - - -{- -************************************************************************ -* * - loadSrcInterface, loadOrphanModules, loadInterfaceForName - - These three are called from TcM-land -* * -************************************************************************ --} - --- | Load the interface corresponding to an @import@ directive in --- source code. On a failure, fail in the monad with an error message. -loadSrcInterface :: SDoc - -> ModuleName - -> IsBootInterface -- {-# SOURCE #-} ? - -> Maybe FastString -- "package", if any - -> RnM ModIface - -loadSrcInterface doc mod want_boot maybe_pkg - = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg - ; case res of - Failed err -> failWithTc err - Succeeded iface -> return iface } - --- | Like 'loadSrcInterface', but returns a 'MaybeErr'. -loadSrcInterface_maybe :: SDoc - -> ModuleName - -> IsBootInterface -- {-# SOURCE #-} ? - -> Maybe FastString -- "package", if any - -> RnM (MaybeErr MsgDoc ModIface) - -loadSrcInterface_maybe doc mod want_boot maybe_pkg - -- We must first find which Module this import refers to. This involves - -- calling the Finder, which as a side effect will search the filesystem - -- and create a ModLocation. If successful, loadIface will read the - -- interface; it will call the Finder again, but the ModLocation will be - -- cached from the first search. - = do { hsc_env <- getTopEnv - ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg - ; case res of - Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) - -- TODO: Make sure this error message is good - err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) } - --- | Load interface directly for a fully qualified 'Module'. (This is a fairly --- rare operation, but in particular it is used to load orphan modules --- in order to pull their instances into the global package table and to --- handle some operations in GHCi). -loadModuleInterface :: SDoc -> Module -> TcM ModIface -loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) - --- | Load interfaces for a collection of modules. -loadModuleInterfaces :: SDoc -> [Module] -> TcM () -loadModuleInterfaces doc mods - | null mods = return () - | otherwise = initIfaceTcRn (mapM_ load mods) - where - load mod = loadSysInterface (doc <+> parens (ppr mod)) mod - --- | Loads the interface for a given Name. --- Should only be called for an imported name; --- otherwise loadSysInterface may not find the interface -loadInterfaceForName :: SDoc -> Name -> TcRn ModIface -loadInterfaceForName doc name - = do { when debugIsOn $ -- Check pre-condition - do { this_mod <- getModule - ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) } - ; ASSERT2( isExternalName name, ppr name ) - initIfaceTcRn $ loadSysInterface doc (nameModule name) } - --- | Only loads the interface for external non-local names. -loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface) -loadInterfaceForNameMaybe doc name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name || not (isExternalName name) - then return Nothing - else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name)) - } - --- | Loads the interface for a given Module. -loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface -loadInterfaceForModule doc m - = do - -- Should not be called with this module - when debugIsOn $ do - this_mod <- getModule - MASSERT2( this_mod /= m, ppr m <+> parens doc ) - initIfaceTcRn $ loadSysInterface doc m - -{- -********************************************************* -* * - loadInterface - - The main function to load an interface - for an imported module, and put it in - the External Package State -* * -********************************************************* --} - --- | An 'IfM' function to load the home interface for a wired-in thing, --- so that we're sure that we see its instance declarations and rules --- See Note [Loading instances for wired-in things] -loadWiredInHomeIface :: Name -> IfM lcl () -loadWiredInHomeIface name - = ASSERT( isWiredInName name ) - do _ <- loadSysInterface doc (nameModule name); return () - where - doc = text "Need home interface for wired-in thing" <+> ppr name - ------------------- --- | Loads a system interface and throws an exception if it fails -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface -loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem - ------------------- --- | Loads a user interface and throws an exception if it fails. The first parameter indicates --- whether we should import the boot variant of the module -loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface -loadUserInterface is_boot doc mod_name - = loadInterfaceWithException doc mod_name (ImportByUser is_boot) - -loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface -loadPluginInterface doc mod_name - = loadInterfaceWithException doc mod_name ImportByPlugin - ------------------- --- | A wrapper for 'loadInterface' that throws an exception if it fails -loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface -loadInterfaceWithException doc mod_name where_from - = withException (loadInterface doc mod_name where_from) - ------------------- -loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr MsgDoc ModIface) - --- loadInterface looks in both the HPT and PIT for the required interface --- If not found, it loads it, and puts it in the PIT (always). - --- If it can't find a suitable interface file, we --- a) modify the PackageIfaceTable to have an empty entry --- (to avoid repeated complaints) --- b) return (Left message) --- --- It's not necessarily an error for there not to be an interface --- file -- perhaps the module has changed, and that interface --- is no longer used - -loadInterface doc_str mod from - | isHoleModule mod - -- Hole modules get special treatment - = do dflags <- getDynFlags - -- Redo search for our local hole module - loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from - | otherwise - = withTimingSilentD (text "loading interface") (pure ()) $ - do { -- Read the state - (eps,hpt) <- getEpsAndHpt - ; gbl_env <- getGblEnv - - ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) - - -- Check whether we have the interface already - ; dflags <- getDynFlags - ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { - Just iface - -> return (Succeeded iface) ; -- Already loaded - -- The (src_imp == mi_boot iface) test checks that the already-loaded - -- interface isn't a boot iface. This can conceivably happen, - -- if an earlier import had a before we got to real imports. I think. - _ -> do { - - -- READ THE MODULE IN - ; read_result <- case (wantHiBootFile dflags eps mod from) of - Failed err -> return (Failed err) - Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod - ; case read_result of { - Failed err -> do - { let fake_iface = emptyFullModIface mod - - ; updateEps_ $ \eps -> - eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } - -- Not found, so add an empty iface to - -- the EPS map so that we don't look again - - ; return (Failed err) } ; - - -- Found and parsed! - -- We used to have a sanity check here that looked for: - -- * System importing .. - -- * a home package module .. - -- * that we know nothing about (mb_dep == Nothing)! - -- - -- But this is no longer valid because thNameToGhcName allows users to - -- cause the system to load arbitrary interfaces (by supplying an appropriate - -- Template Haskell original-name). - Succeeded (iface, loc) -> - let - loc_doc = text loc - in - initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do - - dontLeakTheHPT $ do - - -- Load the new ModIface into the External Package State - -- Even home-package interfaces loaded by loadInterface - -- (which only happens in OneShot mode; in Batch/Interactive - -- mode, home-package modules are loaded one by one into the HPT) - -- are put in the EPS. - -- - -- The main thing is to add the ModIface to the PIT, but - -- we also take the - -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, - -- out of the ModIface and put them into the big EPS pools - - -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined - --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). - -- If we do loadExport first the wrong info gets into the cache (unless we - -- explicitly tag each export which seems a bit of a bore) - - ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas - ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) - ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) - ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) - ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) - ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - - ; let { final_iface = iface { - mi_decls = panic "No mi_decls in PIT", - mi_insts = panic "No mi_insts in PIT", - mi_fam_insts = panic "No mi_fam_insts in PIT", - mi_rules = panic "No mi_rules in PIT", - mi_anns = panic "No mi_anns in PIT" - } - } - - ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod - -- Warn warn against an EPS-updating import - -- of one's own boot file! (one-shot only) - -- See Note [Loading your own hi-boot file] - -- in MkIface. - - ; WARN( bad_boot, ppr mod ) - updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface - then eps - else if bad_boot - -- See Note [Loading your own hi-boot file] - then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls } - else - eps { - eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, - eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, - eps_rule_base = extendRuleBaseList (eps_rule_base eps) - new_eps_rules, - eps_complete_matches - = extendCompleteMatchMap - (eps_complete_matches eps) - new_eps_complete_sigs, - eps_inst_env = extendInstEnvList (eps_inst_env eps) - new_eps_insts, - eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) - new_eps_fam_insts, - eps_ann_env = extendAnnEnvList (eps_ann_env eps) - new_eps_anns, - eps_mod_fam_inst_env - = let - fam_inst_env = - extendFamInstEnvList emptyFamInstEnv - new_eps_fam_insts - in - extendModuleEnv (eps_mod_fam_inst_env eps) - mod - fam_inst_env, - eps_stats = addEpsInStats (eps_stats eps) - (length new_eps_decls) - (length new_eps_insts) - (length new_eps_rules) } - - ; -- invoke plugins - res <- withPlugins dflags interfaceLoadAction final_iface - ; return (Succeeded res) - }}}} - -{- Note [Loading your own hi-boot file] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, when compiling module M, we should not -load M.hi boot into the EPS. After all, we are very shortly -going to have full information about M. Moreover, see -Note [Do not update EPS with your own hi-boot] in MkIface. - -But there is a HORRIBLE HACK here. - -* At the end of tcRnImports, we call checkFamInstConsistency to - check consistency of imported type-family instances - See Note [The type family instance consistency story] in FamInst - -* Alas, those instances may refer to data types defined in M, - if there is a M.hs-boot. - -* And that means we end up loading M.hi-boot, because those - data types are not yet in the type environment. - -But in this wierd case, /all/ we need is the types. We don't need -instances, rules etc. And if we put the instances in the EPS -we get "duplicate instance" warnings when we compile the "real" -instance in M itself. Hence the strange business of just updateing -the eps_PTE. - -This really happens in practice. The module HsExpr.hs gets -"duplicate instance" errors if this hack is not present. - -This is a mess. - - -Note [HPT space leak] (#15111) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In IfL, we defer some work until it is demanded using forkM, such -as building TyThings from IfaceDecls. These thunks are stored in -the ExternalPackageState, and they might never be poked. If we're -not careful, these thunks will capture the state of the loaded -program when we read an interface file, and retain all that data -for ever. - -Therefore, when loading a package interface file , we use a "clean" -version of the HscEnv with all the data about the currently loaded -program stripped out. Most of the fields can be panics because -we'll never read them, but hsc_HPT needs to be empty because this -interface will cause other interfaces to be loaded recursively, and -when looking up those interfaces we use the HPT in loadInterface. -We know that none of the interfaces below here can refer to -home-package modules however, so it's safe for the HPT to be empty. --} - -dontLeakTheHPT :: IfL a -> IfL a -dontLeakTheHPT thing_inside = do - let - cleanTopEnv HscEnv{..} = - let - -- wrinkle: when we're typechecking in --backpack mode, the - -- instantiation of a signature might reside in the HPT, so - -- this case breaks the assumption that EPS interfaces only - -- refer to other EPS interfaces. We can detect when we're in - -- typechecking-only mode by using hscTarget==HscNothing, and - -- in that case we don't empty the HPT. (admittedly this is - -- a bit of a hack, better suggestions welcome). A number of - -- tests in testsuite/tests/backpack break without this - -- tweak. - !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT - | otherwise = emptyHomePackageTable - in - HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph" - , hsc_IC = panic "cleanTopEnv: hsc_IC" - , hsc_HPT = hpt - , .. } - - updTopEnv cleanTopEnv $ do - !_ <- getTopEnv -- force the updTopEnv - thing_inside - - --- | Returns @True@ if a 'ModIface' comes from an external package. --- In this case, we should NOT load it into the EPS; the entities --- should instead come from the local merged signature interface. -is_external_sig :: DynFlags -> ModIface -> Bool -is_external_sig dflags iface = - -- It's a signature iface... - mi_semantic_module iface /= mi_module iface && - -- and it's not from the local package - moduleUnitId (mi_module iface) /= thisPackage dflags - --- | This is an improved version of 'findAndReadIface' which can also --- handle the case when a user requests @p[A=]:M@ but we only --- have an interface for @p[A=]:M@ (the indefinite interface. --- If we are not trying to build code, we load the interface we have, --- *instantiating it* according to how the holes are specified. --- (Of course, if we're actually building code, this is a hard error.) --- --- In the presence of holes, 'computeInterface' has an important invariant: --- to load module M, its set of transitively reachable requirements must --- have an up-to-date local hi file for that requirement. Note that if --- we are loading the interface of a requirement, this does not --- apply to the requirement itself; e.g., @p[A=]:A@ does not require --- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless --- we are actually typechecking p.) -computeInterface :: - SDoc -> IsBootInterface -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) -computeInterface doc_str hi_boot_file mod0 = do - MASSERT( not (isHoleModule mod0) ) - dflags <- getDynFlags - case splitModuleInsts mod0 of - (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do - r <- findAndReadIface doc_str imod mod0 hi_boot_file - case r of - Succeeded (iface0, path) -> do - hsc_env <- getTopEnv - r <- liftIO $ - rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) - Nothing iface0 - case r of - Right x -> return (Succeeded (x, path)) - Left errs -> liftIO . throwIO . mkSrcErr $ errs - Failed err -> return (Failed err) - (mod, _) -> - findAndReadIface doc_str mod mod0 hi_boot_file - --- | Compute the signatures which must be compiled in order to --- load the interface for a 'Module'. The output of this function --- is always a subset of 'moduleFreeHoles'; it is more precise --- because in signature @p[A=,B=]:B@, although the free holes --- are A and B, B might not depend on A at all! --- --- If this is invoked on a signature, this does NOT include the --- signature itself; e.g. precise free module holes of --- @p[A=,B=]:B@ never includes B. -moduleFreeHolesPrecise - :: SDoc -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) -moduleFreeHolesPrecise doc_str mod - | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) - | otherwise = - case splitModuleInsts mod of - (imod, Just indef) -> do - let insts = indefUnitIdInsts (indefModuleUnitId indef) - traceIf (text "Considering whether to load" <+> ppr mod <+> - text "to compute precise free module holes") - (eps, hpt) <- getEpsAndHpt - case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of - Just r -> return (Succeeded r) - Nothing -> readAndCache imod insts - (_, Nothing) -> return (Succeeded emptyUniqDSet) - where - tryEpsAndHpt eps hpt = - fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod) - tryDepsCache eps imod insts = - case lookupInstalledModuleEnv (eps_free_holes eps) imod of - Just ifhs -> Just (renameFreeHoles ifhs insts) - _otherwise -> Nothing - readAndCache imod insts = do - mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False - case mb_iface of - Succeeded (iface, _) -> do - let ifhs = mi_free_holes iface - -- Cache it - updateEps_ (\eps -> - eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs }) - return (Succeeded (renameFreeHoles ifhs insts)) - Failed err -> return (Failed err) - -wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr MsgDoc IsBootInterface --- Figure out whether we want Foo.hi or Foo.hi-boot -wantHiBootFile dflags eps mod from - = case from of - ImportByUser usr_boot - | usr_boot && not this_package - -> Failed (badSourceImport mod) - | otherwise -> Succeeded usr_boot - - ImportByPlugin - -> Succeeded False - - ImportBySystem - | not this_package -- If the module to be imported is not from this package - -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed - -- on the ModuleName of *home-package* modules only. - -- We never import boot modules from other packages! - - | otherwise - -> case lookupUFM (eps_is_boot eps) (moduleName mod) of - Just (_, is_boot) -> Succeeded is_boot - Nothing -> Succeeded False - -- The boot-ness of the requested interface, - -- based on the dependencies in directly-imported modules - where - this_package = thisPackage dflags == moduleUnitId mod - -badSourceImport :: Module -> SDoc -badSourceImport mod - = hang (text "You cannot {-# SOURCE #-} import a module from another package") - 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") - <+> quotes (ppr (moduleUnitId mod))) - ------------------------------------------------------ --- Loading type/class/value decls --- We pass the full Module name here, replete with --- its package info, so that we can build a Name for --- each binder with the right package info in it --- All subsequent lookups, including crucially lookups during typechecking --- the declaration itself, will find the fully-glorious Name --- --- We handle ATs specially. They are not main declarations, but also not --- implicit things (in particular, adding them to `implicitTyThings' would mess --- things up in the renaming/type checking of source programs). ------------------------------------------------------ - -addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv -addDeclsToPTE pte things = extendNameEnvList pte things - -loadDecls :: Bool - -> [(Fingerprint, IfaceDecl)] - -> IfL [(Name,TyThing)] -loadDecls ignore_prags ver_decls - = do { thingss <- mapM (loadDecl ignore_prags) ver_decls - ; return (concat thingss) - } - -loadDecl :: Bool -- Don't load pragmas into the decl pool - -> (Fingerprint, IfaceDecl) - -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the - -- TyThings are forkM'd thunks -loadDecl ignore_prags (_version, decl) - = do { -- Populate the name cache with final versions of all - -- the names associated with the decl - let main_name = ifName decl - - -- Typecheck the thing, lazily - -- NB. Firstly, the laziness is there in case we never need the - -- declaration (in one-shot mode), and secondly it is there so that - -- we don't look up the occurrence of a name before calling mk_new_bndr - -- on the binder. This is important because we must get the right name - -- which includes its nameParent. - - ; thing <- forkM doc $ do { bumpDeclStats main_name - ; tcIfaceDecl ignore_prags decl } - - -- Populate the type environment with the implicitTyThings too. - -- - -- Note [Tricky iface loop] - -- ~~~~~~~~~~~~~~~~~~~~~~~~ - -- Summary: The delicate point here is that 'mini-env' must be - -- buildable from 'thing' without demanding any of the things - -- 'forkM'd by tcIfaceDecl. - -- - -- In more detail: Consider the example - -- data T a = MkT { x :: T a } - -- The implicitTyThings of T are: [ , ] - -- (plus their workers, wrappers, coercions etc etc) - -- - -- We want to return an environment - -- [ "MkT" -> , "x" -> , ... ] - -- (where the "MkT" is the *Name* associated with MkT, etc.) - -- - -- We do this by mapping the implicit_names to the associated - -- TyThings. By the invariant on ifaceDeclImplicitBndrs and - -- implicitTyThings, we can use getOccName on the implicit - -- TyThings to make this association: each Name's OccName should - -- be the OccName of exactly one implicitTyThing. So the key is - -- to define a "mini-env" - -- - -- [ 'MkT' -> , 'x' -> , ... ] - -- where the 'MkT' here is the *OccName* associated with MkT. - -- - -- However, there is a subtlety: due to how type checking needs - -- to be staged, we can't poke on the forkM'd thunks inside the - -- implicitTyThings while building this mini-env. - -- If we poke these thunks too early, two problems could happen: - -- (1) When processing mutually recursive modules across - -- hs-boot boundaries, poking too early will do the - -- type-checking before the recursive knot has been tied, - -- so things will be type-checked in the wrong - -- environment, and necessary variables won't be in - -- scope. - -- - -- (2) Looking up one OccName in the mini_env will cause - -- others to be looked up, which might cause that - -- original one to be looked up again, and hence loop. - -- - -- The code below works because of the following invariant: - -- getOccName on a TyThing does not force the suspended type - -- checks in order to extract the name. For example, we don't - -- poke on the "T a" type of on the way to - -- extracting 's OccName. Of course, there is no - -- reason in principle why getting the OccName should force the - -- thunks, but this means we need to be careful in - -- implicitTyThings and its helper functions. - -- - -- All a bit too finely-balanced for my liking. - - -- This mini-env and lookup function mediates between the - --'Name's n and the map from 'OccName's to the implicit TyThings - ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] - lookup n = case lookupOccEnv mini_env (getOccName n) of - Just thing -> thing - Nothing -> - pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) - - ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl) - --- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) - ; return $ (main_name, thing) : - -- uses the invariant that implicit_names and - -- implicitTyThings are bijective - [(n, lookup n) | n <- implicit_names] - } - where - doc = text "Declaration for" <+> ppr (ifName decl) - -bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used -bumpDeclStats name - = do { traceIf (text "Loading decl for" <+> ppr name) - ; updateEps_ (\eps -> let stats = eps_stats eps - in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) - } - -{- -********************************************************* -* * -\subsection{Reading an interface file} -* * -********************************************************* - -Note [Home module load error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the sought-for interface is in the current package (as determined -by -package-name flag) then it jolly well should already be in the HPT -because we process home-package modules in dependency order. (Except -in one-shot mode; see notes with hsc_HPT decl in HscTypes). - -It is possible (though hard) to get this error through user behaviour. - * Suppose package P (modules P1, P2) depends on package Q (modules Q1, - Q2, with Q2 importing Q1) - * We compile both packages. - * Now we edit package Q so that it somehow depends on P - * Now recompile Q with --make (without recompiling P). - * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2 - is a home-package module which is not yet in the HPT! Disaster. - -This actually happened with P=base, Q=ghc-prim, via the AMP warnings. -See #8320. --} - -findAndReadIface :: SDoc - -- The unique identifier of the on-disk module we're - -- looking for - -> InstalledModule - -- The *actual* module we're looking for. We use - -- this to check the consistency of the requirements - -- of the module we read out. - -> Module - -> IsBootInterface -- True <=> Look for a .hi-boot file - -- False <=> Look for .hi file - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) - -- Nothing <=> file not found, or unreadable, or illegible - -- Just x <=> successfully found and parsed - - -- It *doesn't* add an error to the monad, because - -- sometimes it's ok to fail... see notes with loadInterface -findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file - = do traceIf (sep [hsep [text "Reading", - if hi_boot_file - then text "[boot]" - else Outputable.empty, - text "interface for", - ppr mod <> semi], - nest 4 (text "reason:" <+> doc_str)]) - - -- Check for GHC.Prim, and return its static interface - -- TODO: make this check a function - if mod `installedModuleEq` gHC_PRIM - then do - iface <- getHooked ghcPrimIfaceHook ghcPrimIface - return (Succeeded (iface, - "")) - else do - dflags <- getDynFlags - -- Look for the file - hsc_env <- getTopEnv - mb_found <- liftIO (findExactModule hsc_env mod) - case mb_found of - InstalledFound loc mod -> do - -- Found file, so read it - let file_path = addBootSuffix_maybe hi_boot_file - (ml_hi_file loc) - - -- See Note [Home module load error] - if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags && - not (isOneShot (ghcMode dflags)) - then return (Failed (homeModError mod loc)) - else do r <- read_file file_path - checkBuildDynamicToo r - return r - err -> do - traceIf (text "...not found") - dflags <- getDynFlags - return (Failed (cannotFindInterface dflags - (installedModuleName mod) err)) - where read_file file_path = do - traceIf (text "readIFace" <+> text file_path) - -- Figure out what is recorded in mi_module. If this is - -- a fully definite interface, it'll match exactly, but - -- if it's indefinite, the inside will be uninstantiated! - dflags <- getDynFlags - let wanted_mod = - case splitModuleInsts wanted_mod_with_insts of - (_, Nothing) -> wanted_mod_with_insts - (_, Just indef_mod) -> - indefModuleToModule dflags - (generalizeIndefModule indef_mod) - read_result <- readIface wanted_mod file_path - case read_result of - Failed err -> return (Failed (badIfaceFile file_path err)) - Succeeded iface -> return (Succeeded (iface, file_path)) - -- Don't forget to fill in the package name... - checkBuildDynamicToo (Succeeded (iface, filePath)) = do - dflags <- getDynFlags - -- Indefinite interfaces are ALWAYS non-dynamic, and - -- that's OK. - let is_definite_iface = moduleIsDefinite (mi_module iface) - when is_definite_iface $ - whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do - let ref = canGenerateDynamicToo dflags - dynFilePath = addBootSuffix_maybe hi_boot_file - $ replaceExtension filePath (dynHiSuf dflags) - r <- read_file dynFilePath - case r of - Succeeded (dynIface, _) - | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> - return () - | otherwise -> - do traceIf (text "Dynamic hash doesn't match") - liftIO $ writeIORef ref False - Failed err -> - do traceIf (text "Failed to load dynamic interface file:" $$ err) - liftIO $ writeIORef ref False - checkBuildDynamicToo _ = return () - --- @readIface@ tries just the one file. - -readIface :: Module -> FilePath - -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) - -- Failed err <=> file not found, or unreadable, or illegible - -- Succeeded iface <=> successfully found and parsed - -readIface wanted_mod file_path - = do { res <- tryMostM $ - readBinIface CheckHiWay QuietBinIFaceReading file_path - ; dflags <- getDynFlags - ; case res of - Right iface - -- NB: This check is NOT just a sanity check, it is - -- critical for correctness of recompilation checking - -- (it lets us tell when -this-unit-id has changed.) - | wanted_mod == actual_mod - -> return (Succeeded iface) - | otherwise -> return (Failed err) - where - actual_mod = mi_module iface - err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod - - Left exn -> return (Failed (text (showException exn))) - } - -{- -********************************************************* -* * - Wired-in interface for GHC.Prim -* * -********************************************************* --} - -initExternalPackageState :: ExternalPackageState -initExternalPackageState - = EPS { - eps_is_boot = emptyUFM, - eps_PIT = emptyPackageIfaceTable, - eps_free_holes = emptyInstalledModuleEnv, - eps_PTE = emptyTypeEnv, - eps_inst_env = emptyInstEnv, - eps_fam_inst_env = emptyFamInstEnv, - eps_rule_base = mkRuleBase builtinRules, - -- Initialise the EPS rule pool with the built-in rules - eps_mod_fam_inst_env - = emptyModuleEnv, - eps_complete_matches = emptyUFM, - eps_ann_env = emptyAnnEnv, - eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 - , n_insts_in = 0, n_insts_out = 0 - , n_rules_in = length builtinRules, n_rules_out = 0 } - } - -{- -********************************************************* -* * - Wired-in interface for GHC.Prim -* * -********************************************************* --} - -ghcPrimIface :: ModIface -ghcPrimIface - = empty_iface { - mi_exports = ghcPrimExports, - mi_decls = [], - mi_fixities = fixities, - mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities } - } - where - empty_iface = emptyFullModIface gHC_PRIM - - -- The fixities listed here for @`seq`@ or @->@ should match - -- those in primops.txt.pp (from which Haddock docs are generated). - fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) - : (occName funTyConName, funTyFixity) -- trac #10145 - : mapMaybe mkFixity allThePrimOps - mkFixity op = (,) (primOpOcc op) <$> primOpFixity op - -{- -********************************************************* -* * -\subsection{Statistics} -* * -********************************************************* --} - -ifaceStats :: ExternalPackageState -> SDoc -ifaceStats eps - = hcat [text "Renamer stats: ", msg] - where - stats = eps_stats eps - msg = vcat - [int (n_ifaces_in stats) <+> text "interfaces read", - hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", - int (n_decls_in stats), text "read"], - hsep [ int (n_insts_out stats), text "instance decls imported, out of", - int (n_insts_in stats), text "read"], - hsep [ int (n_rules_out stats), text "rule decls imported, out of", - int (n_rules_in stats), text "read"] - ] - -{- -************************************************************************ -* * - Printing interfaces -* * -************************************************************************ - -Note [Name qualification with --show-iface] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In order to disambiguate between identifiers from different modules, we qualify -all names that don't originate in the current module. In order to keep visual -noise as low as possible, we keep local names unqualified. - -For some background on this choice see trac #15269. --} - --- | Read binary interface, and print it out -showIface :: HscEnv -> FilePath -> IO () -showIface hsc_env filename = do - -- skip the hi way check; we don't want to worry about profiled vs. - -- non-profiled interfaces, for example. - iface <- initTcRnIf 's' hsc_env () () $ - readBinIface IgnoreHiWay TraceBinIFaceReading filename - let dflags = hsc_dflags hsc_env - -- See Note [Name qualification with --show-iface] - qualifyImportedNames mod _ - | mod == mi_module iface = NameUnqual - | otherwise = NameNotInScope1 - print_unqual = QueryQualify qualifyImportedNames - neverQualifyModules - neverQualifyPackages - putLogMsg dflags NoReason SevDump noSrcSpan - (mkDumpStyle dflags print_unqual) (pprModIface iface) - --- Show a ModIface but don't display details; suitable for ModIfaces stored in --- the EPT. -pprModIfaceSimple :: ModIface -> SDoc -pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) - -pprModIface :: ModIface -> SDoc --- Show a ModIface -pprModIface iface@ModIface{ mi_final_exts = exts } - = vcat [ text "interface" - <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) - <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty) - <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty) - <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) - <+> integer hiVersion - , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts)) - , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts)) - , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts)) - , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts)) - , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts)) - , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) - , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) - , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) - , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) - , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) - , nest 2 (text "where") - , text "exports:" - , nest 2 (vcat (map pprExport (mi_exports iface))) - , pprDeps (mi_deps iface) - , vcat (map pprUsage (mi_usages iface)) - , vcat (map pprIfaceAnnotation (mi_anns iface)) - , pprFixities (mi_fixities iface) - , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] - , vcat (map ppr (mi_insts iface)) - , vcat (map ppr (mi_fam_insts iface)) - , vcat (map ppr (mi_rules iface)) - , ppr (mi_warns iface) - , pprTrustInfo (mi_trust iface) - , pprTrustPkg (mi_trust_pkg iface) - , vcat (map ppr (mi_complete_sigs iface)) - , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) - , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) - , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface)) - ] - where - pp_hsc_src HsBootFile = text "[boot]" - pp_hsc_src HsigFile = text "[hsig]" - pp_hsc_src HsSrcFile = Outputable.empty - -{- -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C --} - -pprExport :: IfaceExport -> SDoc -pprExport (Avail n) = ppr n -pprExport (AvailTC _ [] []) = Outputable.empty -pprExport (AvailTC n ns0 fs) - = case ns0 of - (n':ns) | n==n' -> ppr n <> pp_export ns fs - _ -> ppr n <> vbar <> pp_export ns0 fs - where - pp_export [] [] = Outputable.empty - pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs)) - -pprUsage :: Usage -> SDoc -pprUsage usage@UsagePackageModule{} - = pprUsageImport usage usg_mod -pprUsage usage@UsageHomeModule{} - = pprUsageImport usage usg_mod_name $$ - nest 2 ( - maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ - vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] - ) -pprUsage usage@UsageFile{} - = hsep [text "addDependentFile", - doubleQuotes (text (usg_file_path usage)), - ppr (usg_file_hash usage)] -pprUsage usage@UsageMergedRequirement{} - = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] - -pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc -pprUsageImport usage usg_mod' - = hsep [text "import", safe, ppr (usg_mod' usage), - ppr (usg_mod_hash usage)] - where - safe | usg_safe usage = text "safe" - | otherwise = text " -/ " - -pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, - dep_finsts = finsts }) - = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods), - text "package dependencies:" <+> fsep (map ppr_pkg pkgs), - text "orphans:" <+> fsep (map ppr orphs), - text "family instance modules:" <+> fsep (map ppr finsts) - ] - where - ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot - ppr_pkg (pkg,trust_req) = ppr pkg <> - (if trust_req then text "*" else Outputable.empty) - ppr_boot True = text "[boot]" - ppr_boot False = Outputable.empty - -pprFixities :: [(OccName, Fixity)] -> SDoc -pprFixities [] = Outputable.empty -pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes - where - pprFix (occ,fix) = ppr fix <+> ppr occ - -pprTrustInfo :: IfaceTrustInfo -> SDoc -pprTrustInfo trust = text "trusted:" <+> ppr trust - -pprTrustPkg :: Bool -> SDoc -pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg - -instance Outputable Warnings where - ppr = pprWarns - -pprWarns :: Warnings -> SDoc -pprWarns NoWarnings = Outputable.empty -pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt -pprWarns (WarnSome prs) = text "Warnings" - <+> vcat (map pprWarning prs) - where pprWarning (name, txt) = ppr name <+> ppr txt - -pprIfaceAnnotation :: IfaceAnnotation -> SDoc -pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) - = ppr target <+> text "annotated by" <+> ppr serialized - -{- -********************************************************* -* * -\subsection{Errors} -* * -********************************************************* --} - -badIfaceFile :: String -> SDoc -> SDoc -badIfaceFile file err - = vcat [text "Bad interface file:" <+> text file, - nest 4 err] - -hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc -hiModuleNameMismatchWarn dflags requested_mod read_mod - | moduleUnitId requested_mod == moduleUnitId read_mod = - sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, - text "but we were expecting module" <+> quotes (ppr requested_mod), - sep [text "Probable cause: the source code which generated interface file", - text "has an incompatible module name" - ] - ] - | otherwise = - -- ToDo: This will fail to have enough qualification when the package IDs - -- are the same - withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ - -- we want the Modules below to be qualified with package names, - -- so reset the PrintUnqualified setting. - hsep [ text "Something is amiss; requested module " - , ppr requested_mod - , text "differs from name found in the interface file" - , ppr read_mod - , parens (text "if these names look the same, try again with -dppr-debug") - ] - -homeModError :: InstalledModule -> ModLocation -> SDoc --- See Note [Home module load error] -homeModError mod location - = text "attempting to use module " <> quotes (ppr mod) - <> (case ml_hs_file location of - Just file -> space <> parens (text file) - Nothing -> Outputable.empty) - <+> text "which is not loaded" diff --git a/iface/LoadIface.hs-boot b/iface/LoadIface.hs-boot deleted file mode 100644 --- a/iface/LoadIface.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module LoadIface where -import Module (Module) -import TcRnMonad (IfM) -import HscTypes (ModIface) -import Outputable (SDoc) - -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/iface/MkIface.hs b/iface/MkIface.hs deleted file mode 100644 --- a/iface/MkIface.hs +++ /dev/null @@ -1,2078 +0,0 @@ -{- -(c) The University of Glasgow 2006-2008 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --} - -{-# LANGUAGE CPP, NondecreasingIndentation #-} -{-# LANGUAGE MultiWayIf #-} - --- | Module for constructing @ModIface@ values (interface files), --- writing them to disk and comparing two versions to see if --- recompilation is required. -module MkIface ( - mkPartialIface, - mkFullIface, - - mkIfaceTc, - - writeIfaceFile, -- Write the interface file - - checkOldIface, -- See if recompilation is required, by - -- comparing version information - RecompileRequired(..), recompileRequired, - mkIfaceExports, - - coAxiomToIfaceDecl, - tyThingToIfaceDecl -- Converting things to their Iface equivalents - ) where - -{- - ----------------------------------------------- - Recompilation checking - ----------------------------------------------- - -A complete description of how recompilation checking works can be -found in the wiki commentary: - - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance - -Please read the above page for a top-down description of how this all -works. Notes below cover specific issues related to the implementation. - -Basic idea: - - * In the mi_usages information in an interface, we record the - fingerprint of each free variable of the module - - * In mkIface, we compute the fingerprint of each exported thing A.f. - For each external thing that A.f refers to, we include the fingerprint - of the external reference when computing the fingerprint of A.f. So - if anything that A.f depends on changes, then A.f's fingerprint will - change. - Also record any dependent files added with - * addDependentFile - * #include - * -optP-include - - * In checkOldIface we compare the mi_usages for the module with - the actual fingerprint for all each thing recorded in mi_usages --} - -#include "HsVersions.h" - -import GhcPrelude - -import IfaceSyn -import BinFingerprint -import LoadIface -import ToIface -import FlagChecker - -import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies ) -import Id -import Annotations -import CoreSyn -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import Type -import TcType -import InstEnv -import FamInstEnv -import TcRnMonad -import GHC.Hs -import HscTypes -import Finder -import DynFlags -import VarEnv -import Var -import Name -import Avail -import RdrName -import NameEnv -import NameSet -import Module -import BinIface -import ErrUtils -import Digraph -import SrcLoc -import Outputable -import BasicTypes hiding ( SuccessFlag(..) ) -import Unique -import Util hiding ( eqListBy ) -import FastString -import Maybes -import Binary -import Fingerprint -import Exception -import UniqSet -import Packages -import ExtractDocs - -import Control.Monad -import Data.Function -import Data.List (find, findIndex, mapAccumL, sortBy, sort) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Ord -import Data.IORef -import System.Directory -import System.FilePath -import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..), - pluginRecompile', plugins ) - ---Qualified import so we can define a Semigroup instance --- but it doesn't clash with Outputable.<> -import qualified Data.Semigroup - -{- -************************************************************************ -* * -\subsection{Completing an interface} -* * -************************************************************************ --} - -mkPartialIface :: HscEnv - -> ModDetails - -> ModGuts - -> PartialModIface -mkPartialIface hsc_env mod_details - ModGuts{ mg_module = this_mod - , mg_hsc_src = hsc_src - , mg_usages = usages - , mg_used_th = used_th - , mg_deps = deps - , mg_rdr_env = rdr_env - , mg_fix_env = fix_env - , mg_warns = warns - , mg_hpc_info = hpc_info - , mg_safe_haskell = safe_mode - , mg_trust_pkg = self_trust - , mg_doc_hdr = doc_hdr - , mg_decl_docs = decl_docs - , mg_arg_docs = arg_docs - } - = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages doc_hdr decl_docs arg_docs mod_details - --- | Fully instantiate a interface --- Adds fingerprints and potentially code generator produced information. -mkFullIface :: HscEnv -> PartialModIface -> IO ModIface -mkFullIface hsc_env partial_iface = do - full_iface <- - {-# SCC "addFingerprints" #-} - addFingerprints hsc_env partial_iface - - -- Debug printing - dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" (pprModIface full_iface) - - return full_iface - --- | Make an interface from the results of typechecking only. Useful --- for non-optimising compilation, or where we aren't generating any --- object code at all ('HscNothing'). -mkIfaceTc :: HscEnv - -> SafeHaskellMode -- The safe haskell mode - -> ModDetails -- gotten from mkBootModDetails, probably - -> TcGblEnv -- Usages, deprecations, etc - -> IO ModIface -mkIfaceTc hsc_env safe_mode mod_details - tc_result@TcGblEnv{ tcg_mod = this_mod, - tcg_src = hsc_src, - tcg_imports = imports, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_merged = merged, - tcg_warns = warns, - tcg_hpc = other_hpc_info, - tcg_th_splice_used = tc_splice_used, - tcg_dependent_files = dependent_files - } - = do - let used_names = mkUsedNames tc_result - let pluginModules = - map lpModule (cachedPlugins (hsc_dflags hsc_env)) - deps <- mkDependencies - (thisInstalledUnitId (hsc_dflags hsc_env)) - (map mi_module pluginModules) tc_result - let hpc_info = emptyHpcInfo other_hpc_info - used_th <- readIORef tc_splice_used - dep_files <- (readIORef dependent_files) - -- Do NOT use semantic module here; this_mod in mkUsageInfo - -- is used solely to decide if we should record a dependency - -- or not. When we instantiate a signature, the semantic - -- module is something we want to record dependencies for, - -- but if you pass that in here, we'll decide it's the local - -- module and does not need to be recorded as a dependency. - -- See Note [Identity versus semantic module] - usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names - dep_files merged pluginModules - - let (doc_hdr', doc_map, arg_map) = extractDocs tc_result - - let partial_iface = mkIface_ hsc_env - this_mod hsc_src - used_th deps rdr_env - fix_env warns hpc_info - (imp_trust_own_pkg imports) safe_mode usages - doc_hdr' doc_map arg_map - mod_details - - mkFullIface hsc_env partial_iface - -mkIface_ :: HscEnv -> Module -> HscSource - -> Bool -> Dependencies -> GlobalRdrEnv - -> NameEnv FixItem -> Warnings -> HpcInfo - -> Bool - -> SafeHaskellMode - -> [Usage] - -> Maybe HsDocString - -> DeclDocMap - -> ArgDocMap - -> ModDetails - -> PartialModIface -mkIface_ hsc_env - this_mod hsc_src used_th deps rdr_env fix_env src_warns - hpc_info pkg_trust_req safe_mode usages - doc_hdr decl_docs arg_docs - ModDetails{ md_insts = insts, - md_fam_insts = fam_insts, - md_rules = rules, - md_anns = anns, - md_types = type_env, - md_exports = exports, - md_complete_sigs = complete_sigs } --- NB: notice that mkIface does not look at the bindings --- only at the TypeEnv. The previous Tidy phase has --- put exactly the info into the TypeEnv that we want --- to expose in the interface - - = do - let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) - entities = typeEnvElts type_env - decls = [ tyThingToIfaceDecl entity - | entity <- entities, - let name = getName entity, - not (isImplicitTyThing entity), - -- No implicit Ids and class tycons in the interface file - not (isWiredInName name), - -- Nor wired-in things; the compiler knows about them anyhow - nameIsLocalOrFrom semantic_mod name ] - -- Sigh: see Note [Root-main Id] in TcRnDriver - -- NB: ABSOLUTELY need to check against semantic_mod, - -- because all of the names in an hsig p[H=]:H - -- are going to be for , not the former id! - -- See Note [Identity versus semantic module] - - fixities = sortBy (comparing fst) - [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] - -- The order of fixities returned from nameEnvElts is not - -- deterministic, so we sort by OccName to canonicalize it. - -- See Note [Deterministic UniqFM] in UniqDFM for more details. - warns = src_warns - iface_rules = map coreRuleToIfaceRule rules - iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts - iface_fam_insts = map famInstToIfaceFamInst fam_insts - trust_info = setSafeMode safe_mode - annotations = map mkIfaceAnnotation anns - icomplete_sigs = map mkIfaceCompleteSig complete_sigs - - ModIface { - mi_module = this_mod, - -- Need to record this because it depends on the -instantiated-with flag - -- which could change - mi_sig_of = if semantic_mod == this_mod - then Nothing - else Just semantic_mod, - mi_hsc_src = hsc_src, - mi_deps = deps, - mi_usages = usages, - mi_exports = mkIfaceExports exports, - - -- Sort these lexicographically, so that - -- the result is stable across compilations - mi_insts = sortBy cmp_inst iface_insts, - mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, - mi_rules = sortBy cmp_rule iface_rules, - - mi_fixities = fixities, - mi_warns = warns, - mi_anns = annotations, - mi_globals = maybeGlobalRdrEnv rdr_env, - mi_used_th = used_th, - mi_decls = decls, - mi_hpc = isHpcUsed hpc_info, - mi_trust = trust_info, - mi_trust_pkg = pkg_trust_req, - mi_complete_sigs = icomplete_sigs, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, - mi_final_exts = () } - where - cmp_rule = comparing ifRuleName - -- Compare these lexicographically by OccName, *not* by unique, - -- because the latter is not stable across compilations: - cmp_inst = comparing (nameOccName . ifDFun) - cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) - - dflags = hsc_dflags hsc_env - - -- We only fill in mi_globals if the module was compiled to byte - -- code. Otherwise, the compiler may not have retained all the - -- top-level bindings and they won't be in the TypeEnv (see - -- Desugar.addExportFlagsAndRules). The mi_globals field is used - -- by GHCi to decide whether the module has its full top-level - -- scope available. (#5534) - maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv - maybeGlobalRdrEnv rdr_env - | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env - | otherwise = Nothing - - ifFamInstTcName = ifFamInstFam - ------------------------------ -writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO () -writeIfaceFile dflags hi_file_path new_iface - = do createDirectoryIfMissing True (takeDirectory hi_file_path) - writeBinIface dflags hi_file_path new_iface - - --- ----------------------------------------------------------------------------- --- Look up parents and versions of Names - --- This is like a global version of the mi_hash_fn field in each ModIface. --- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get --- the parent and version info. - -mkHashFun - :: HscEnv -- needed to look up versions - -> ExternalPackageState -- ditto - -> (Name -> IO Fingerprint) -mkHashFun hsc_env eps name - | isHoleModule orig_mod - = lookup (mkModule (thisPackage dflags) (moduleName orig_mod)) - | otherwise - = lookup orig_mod - where - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - occ = nameOccName name - orig_mod = nameModule name - lookup mod = do - MASSERT2( isExternalName name, ppr name ) - iface <- case lookupIfaceByModule hpt pit mod of - Just iface -> return iface - Nothing -> do - -- This can occur when we're writing out ifaces for - -- requirements; we didn't do any /real/ typechecking - -- so there's no guarantee everything is loaded. - -- Kind of a heinous hack. - iface <- initIfaceLoad hsc_env . withException - $ loadInterface (text "lookupVers2") mod ImportBySystem - return iface - return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ)) - --- --------------------------------------------------------------------------- --- Compute fingerprints for the interface - -{- -Note [Fingerprinting IfaceDecls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The general idea here is that we first examine the 'IfaceDecl's and determine -the recursive groups of them. We then walk these groups in dependency order, -serializing each contained 'IfaceDecl' to a "Binary" buffer which we then -hash using MD5 to produce a fingerprint for the group. - -However, the serialization that we use is a bit funny: we override the @putName@ -operation with our own which serializes the hash of a 'Name' instead of the -'Name' itself. This ensures that the fingerprint of a decl changes if anything -in its transitive closure changes. This trick is why we must be careful about -traversing in dependency order: we need to ensure that we have hashes for -everything referenced by the decl which we are fingerprinting. - -Moreover, we need to be careful to distinguish between serialization of binding -Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls -field of a IfaceClsInst): only in the non-binding case should we include the -fingerprint; in the binding case we shouldn't since it is merely the name of the -thing that we are currently fingerprinting. --} - --- | Add fingerprints for top-level declarations to a 'ModIface'. --- --- See Note [Fingerprinting IfaceDecls] -addFingerprints - :: HscEnv - -> PartialModIface - -> IO ModIface -addFingerprints hsc_env iface0 - = do - eps <- hscEPS hsc_env - let - decls = mi_decls iface0 - warn_fn = mkIfaceWarnCache (mi_warns iface0) - fix_fn = mkIfaceFixCache (mi_fixities iface0) - - -- The ABI of a declaration represents everything that is made - -- visible about the declaration that a client can depend on. - -- see IfaceDeclABI below. - declABI :: IfaceDecl -> IfaceDeclABI - -- TODO: I'm not sure if this should be semantic_mod or this_mod. - -- See also Note [Identity versus semantic module] - declABI decl = (this_mod, decl, extras) - where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts - non_orph_fis top_lvl_name_env decl - - -- This is used for looking up the Name of a default method - -- from its OccName. See Note [default method Name] - top_lvl_name_env = - mkOccEnv [ (nameOccName nm, nm) - | IfaceId { ifName = nm } <- decls ] - - -- Dependency edges between declarations in the current module. - -- This is computed by finding the free external names of each - -- declaration, including IfaceDeclExtras (things that a - -- declaration implicitly depends on). - edges :: [ Node Unique IfaceDeclABI ] - edges = [ DigraphNode abi (getUnique (getOccName decl)) out - | decl <- decls - , let abi = declABI decl - , let out = localOccs $ freeNamesDeclABI abi - ] - - name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n - localOccs = - map (getUnique . getParent . getOccName) - -- NB: names always use semantic module, so - -- filtering must be on the semantic module! - -- See Note [Identity versus semantic module] - . filter ((== semantic_mod) . name_module) - . nonDetEltsUniqSet - -- It's OK to use nonDetEltsUFM as localOccs is only - -- used to construct the edges and - -- stronglyConnCompFromEdgedVertices is deterministic - -- even with non-deterministic order of edges as - -- explained in Note [Deterministic SCC] in Digraph. - where getParent :: OccName -> OccName - getParent occ = lookupOccEnv parent_map occ `orElse` occ - - -- maps OccNames to their parents in the current module. - -- e.g. a reference to a constructor must be turned into a reference - -- to the TyCon for the purposes of calculating dependencies. - parent_map :: OccEnv OccName - parent_map = foldl' extend emptyOccEnv decls - where extend env d = - extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] - where n = getOccName d - - -- Strongly-connected groups of declarations, in dependency order - groups :: [SCC IfaceDeclABI] - groups = stronglyConnCompFromEdgedVerticesUniq edges - - global_hash_fn = mkHashFun hsc_env eps - - -- How to output Names when generating the data to fingerprint. - -- Here we want to output the fingerprint for each top-level - -- Name, whether it comes from the current module or another - -- module. In this way, the fingerprint for a declaration will - -- change if the fingerprint for anything it refers to (transitively) - -- changes. - mk_put_name :: OccEnv (OccName,Fingerprint) - -> BinHandle -> Name -> IO () - mk_put_name local_env bh name - | isWiredInName name = putNameLiterally bh name - -- wired-in names don't have fingerprints - | otherwise - = ASSERT2( isExternalName name, ppr name ) - let hash | nameModule name /= semantic_mod = global_hash_fn name - -- Get it from the REAL interface!! - -- This will trigger when we compile an hsig file - -- and we know a backing impl for it. - -- See Note [Identity versus semantic module] - | semantic_mod /= this_mod - , not (isHoleModule semantic_mod) = global_hash_fn name - | otherwise = return (snd (lookupOccEnv local_env (getOccName name) - `orElse` pprPanic "urk! lookup local fingerprint" - (ppr name $$ ppr local_env))) - -- This panic indicates that we got the dependency - -- analysis wrong, because we needed a fingerprint for - -- an entity that wasn't in the environment. To debug - -- it, turn the panic into a trace, uncomment the - -- pprTraces below, run the compile again, and inspect - -- the output and the generated .hi file with - -- --show-iface. - in hash >>= put_ bh - - -- take a strongly-connected group of declarations and compute - -- its fingerprint. - - fingerprint_group :: (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) - -> SCC IfaceDeclABI - -> IO (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) - - fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) - = do let hash_fn = mk_put_name local_env - decl = abiDecl abi - --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do - hash <- computeFingerprint hash_fn abi - env' <- extend_hash_env local_env (hash,decl) - return (env', (hash,decl) : decls_w_hashes) - - fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) - = do let decls = map abiDecl abis - local_env1 <- foldM extend_hash_env local_env - (zip (repeat fingerprint0) decls) - let hash_fn = mk_put_name local_env1 - -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do - let stable_abis = sortBy cmp_abiNames abis - -- put the cycle in a canonical order - hash <- computeFingerprint hash_fn stable_abis - let pairs = zip (repeat hash) decls - local_env2 <- foldM extend_hash_env local_env pairs - return (local_env2, pairs ++ decls_w_hashes) - - -- we have fingerprinted the whole declaration, but we now need - -- to assign fingerprints to all the OccNames that it binds, to - -- use when referencing those OccNames in later declarations. - -- - extend_hash_env :: OccEnv (OccName,Fingerprint) - -> (Fingerprint,IfaceDecl) - -> IO (OccEnv (OccName,Fingerprint)) - extend_hash_env env0 (hash,d) = do - return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 - (ifaceDeclFingerprints hash d)) - - -- - (local_env, decls_w_hashes) <- - foldM fingerprint_group (emptyOccEnv, []) groups - - -- when calculating fingerprints, we always need to use canonical - -- ordering for lists of things. In particular, the mi_deps has various - -- lists of modules and suchlike, so put these all in canonical order: - let sorted_deps = sortDependencies (mi_deps iface0) - - -- The export hash of a module depends on the orphan hashes of the - -- orphan modules below us in the dependency tree. This is the way - -- that changes in orphans get propagated all the way up the - -- dependency tree. - -- - -- Note [A bad dep_orphs optimization] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- In a previous version of this code, we filtered out orphan modules which - -- were not from the home package, justifying it by saying that "we'd - -- pick up the ABI hashes of the external module instead". This is wrong. - -- Suppose that we have: - -- - -- module External where - -- instance Show (a -> b) - -- - -- module Home1 where - -- import External - -- - -- module Home2 where - -- import Home1 - -- - -- The export hash of Home1 needs to reflect the orphan instances of - -- External. It's true that Home1 will get rebuilt if the orphans - -- of External, but we also need to make sure Home2 gets rebuilt - -- as well. See #12733 for more details. - let orph_mods - = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot] - $ dep_orphs sorted_deps - dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods - - -- Note [Do not update EPS with your own hi-boot] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- (See also #10182). When your hs-boot file includes an orphan - -- instance declaration, you may find that the dep_orphs of a module you - -- import contains reference to yourself. DO NOT actually load this module - -- or add it to the orphan hashes: you're going to provide the orphan - -- instances yourself, no need to consult hs-boot; if you do load the - -- interface into EPS, you will see a duplicate orphan instance. - - orphan_hash <- computeFingerprint (mk_put_name local_env) - (map ifDFun orph_insts, orph_rules, orph_fis) - - -- the export list hash doesn't depend on the fingerprints of - -- the Names it mentions, only the Names themselves, hence putNameLiterally. - export_hash <- computeFingerprint putNameLiterally - (mi_exports iface0, - orphan_hash, - dep_orphan_hashes, - dep_pkgs (mi_deps iface0), - -- See Note [Export hash depends on non-orphan family instances] - dep_finsts (mi_deps iface0), - -- dep_pkgs: see "Package Version Changes" on - -- wiki/commentary/compiler/recompilation-avoidance - mi_trust iface0) - -- Make sure change of Safe Haskell mode causes recomp. - - -- Note [Export hash depends on non-orphan family instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- - -- Suppose we have: - -- - -- module A where - -- type instance F Int = Bool - -- - -- module B where - -- import A - -- - -- module C where - -- import B - -- - -- The family instance consistency check for C depends on the dep_finsts of - -- B. If we rename module A to A2, when the dep_finsts of B changes, we need - -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of - -- the exports of B, because C always considers them when checking - -- consistency. - -- - -- A full discussion is in #12723. - -- - -- We do NOT need to hash dep_orphs, because this is implied by - -- dep_orphan_hashes, and we do not need to hash ordinary class instances, - -- because there is no eager consistency check as there is with type families - -- (also we didn't store it anywhere!) - -- - - -- put the declarations in a canonical order, sorted by OccName - let sorted_decls = Map.elems $ Map.fromList $ - [(getOccName d, e) | e@(_, d) <- decls_w_hashes] - - -- the flag hash depends on: - -- - (some of) dflags - -- it returns two hashes, one that shouldn't change - -- the abi hash and one that should - flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally - - opt_hash <- fingerprintOptFlags dflags putNameLiterally - - hpc_hash <- fingerprintHpcFlags dflags putNameLiterally - - plugin_hash <- fingerprintPlugins hsc_env - - -- the ABI hash depends on: - -- - decls - -- - export list - -- - orphans - -- - deprecations - -- - flag abi hash - mod_hash <- computeFingerprint putNameLiterally - (map fst sorted_decls, - export_hash, -- includes orphan_hash - mi_warns iface0) - - -- The interface hash depends on: - -- - the ABI hash, plus - -- - the module level annotations, - -- - usages - -- - deps (home and external packages, dependent files) - -- - hpc - iface_hash <- computeFingerprint putNameLiterally - (mod_hash, - ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache - mi_usages iface0, - sorted_deps, - mi_hpc iface0) - - let - final_iface_exts = ModIfaceBackend - { mi_iface_hash = iface_hash - , mi_mod_hash = mod_hash - , mi_flag_hash = flag_hash - , mi_opt_hash = opt_hash - , mi_hpc_hash = hpc_hash - , mi_plugin_hash = plugin_hash - , mi_orphan = not ( all ifRuleAuto orph_rules - -- See Note [Orphans and auto-generated rules] - && null orph_insts - && null orph_fis) - , mi_finsts = not (null (mi_fam_insts iface0)) - , mi_exp_hash = export_hash - , mi_orphan_hash = orphan_hash - , mi_warn_fn = warn_fn - , mi_fix_fn = fix_fn - , mi_hash_fn = lookupOccEnv local_env - } - final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts } - -- - return final_iface - - where - this_mod = mi_module iface0 - semantic_mod = mi_semantic_module iface0 - dflags = hsc_dflags hsc_env - (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) - (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) - (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) - ann_fn = mkIfaceAnnCache (mi_anns iface0) - --- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules --- (in particular, the orphan modules which are transitively imported by the --- current module). --- --- Q: Why do we need the hash at all, doesn't the list of transitively --- imported orphan modules suffice? --- --- A: If one of our transitive imports adds a new orphan instance, our --- export hash must change so that modules which import us rebuild. If we just --- hashed the [Module], the hash would not change even when a new instance was --- added to a module that already had an orphan instance. --- --- Q: Why don't we just hash the orphan hashes of our direct dependencies? --- Why the full transitive closure? --- --- A: Suppose we have these modules: --- --- module A where --- instance Show (a -> b) where --- module B where --- import A -- ** --- module C where --- import A --- import B --- --- Whether or not we add or remove the import to A in B affects the --- orphan hash of B. But it shouldn't really affect the orphan hash --- of C. If we hashed only direct dependencies, there would be no --- way to tell that the net effect was a wash, and we'd be forced --- to recompile C and everything else. -getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] -getOrphanHashes hsc_env mods = do - eps <- hscEPS hsc_env - let - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - get_orph_hash mod = - case lookupIfaceByModule hpt pit mod of - Just iface -> return (mi_orphan_hash (mi_final_exts iface)) - Nothing -> do -- similar to 'mkHashFun' - iface <- initIfaceLoad hsc_env . withException - $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash (mi_final_exts iface)) - - -- - mapM get_orph_hash mods - - -sortDependencies :: Dependencies -> Dependencies -sortDependencies d - = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), - dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d), - dep_orphs = sortBy stableModuleCmp (dep_orphs d), - dep_finsts = sortBy stableModuleCmp (dep_finsts d), - dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) } - --- | Creates cached lookup for the 'mi_anns' field of ModIface --- Hackily, we use "module" as the OccName for any module-level annotations -mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload] -mkIfaceAnnCache anns - = \n -> lookupOccEnv env n `orElse` [] - where - pair (IfaceAnnotation target value) = - (case target of - NamedTarget occn -> occn - ModuleTarget _ -> mkVarOcc "module" - , [value]) - -- flipping (++), so the first argument is always short - env = mkOccEnv_C (flip (++)) (map pair anns) - -{- -************************************************************************ -* * - The ABI of an IfaceDecl -* * -************************************************************************ - -Note [The ABI of an IfaceDecl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ABI of a declaration consists of: - - (a) the full name of the identifier (inc. module and package, - because these are used to construct the symbol name by which - the identifier is known externally). - - (b) the declaration itself, as exposed to clients. That is, the - definition of an Id is included in the fingerprint only if - it is made available as an unfolding in the interface. - - (c) the fixity of the identifier (if it exists) - (d) for Ids: rules - (e) for classes: instances, fixity & rules for methods - (f) for datatypes: instances, fixity & rules for constrs - -Items (c)-(f) are not stored in the IfaceDecl, but instead appear -elsewhere in the interface file. But they are *fingerprinted* with -the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, -and fingerprinting that as part of the declaration. --} - -type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) - -data IfaceDeclExtras - = IfaceIdExtras IfaceIdExtras - - | IfaceDataExtras - (Maybe Fixity) -- Fixity of the tycon itself (if it exists) - [IfaceInstABI] -- Local class and family instances of this tycon - -- See Note [Orphans] in InstEnv - [AnnPayload] -- Annotations of the type itself - [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations - - | IfaceClassExtras - (Maybe Fixity) -- Fixity of the class itself (if it exists) - [IfaceInstABI] -- Local instances of this class *or* - -- of its associated data types - -- See Note [Orphans] in InstEnv - [AnnPayload] -- Annotations of the type itself - [IfaceIdExtras] -- For each class method: fixity, RULES and annotations - [IfExtName] -- Default methods. If a module - -- mentions a class, then it can - -- instantiate the class and thereby - -- use the default methods, so we must - -- include these in the fingerprint of - -- a class. - - | IfaceSynonymExtras (Maybe Fixity) [AnnPayload] - - | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload] - - | IfaceOtherDeclExtras - -data IfaceIdExtras - = IdExtras - (Maybe Fixity) -- Fixity of the Id (if it exists) - [IfaceRule] -- Rules for the Id - [AnnPayload] -- Annotations for the Id - --- When hashing a class or family instance, we hash only the --- DFunId or CoAxiom, because that depends on all the --- information about the instance. --- -type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance - -abiDecl :: IfaceDeclABI -> IfaceDecl -abiDecl (_, decl, _) = decl - -cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering -cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` - getOccName (abiDecl abi2) - -freeNamesDeclABI :: IfaceDeclABI -> NameSet -freeNamesDeclABI (_mod, decl, extras) = - freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras - -freeNamesDeclExtras :: IfaceDeclExtras -> NameSet -freeNamesDeclExtras (IfaceIdExtras id_extras) - = freeNamesIdExtras id_extras -freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) - = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) -freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms) - = unionNameSets $ - mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs -freeNamesDeclExtras (IfaceSynonymExtras _ _) - = emptyNameSet -freeNamesDeclExtras (IfaceFamilyExtras _ insts _) - = mkNameSet insts -freeNamesDeclExtras IfaceOtherDeclExtras - = emptyNameSet - -freeNamesIdExtras :: IfaceIdExtras -> NameSet -freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules) - -instance Outputable IfaceDeclExtras where - ppr IfaceOtherDeclExtras = Outputable.empty - ppr (IfaceIdExtras extras) = ppr_id_extras extras - ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] - ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] - ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, - ppr_id_extras_s stuff] - ppr (IfaceClassExtras fix insts anns stuff defms) = - vcat [ppr fix, ppr_insts insts, ppr anns, - ppr_id_extras_s stuff, ppr defms] - -ppr_insts :: [IfaceInstABI] -> SDoc -ppr_insts _ = text "" - -ppr_id_extras_s :: [IfaceIdExtras] -> SDoc -ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) - -ppr_id_extras :: IfaceIdExtras -> SDoc -ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) - --- This instance is used only to compute fingerprints -instance Binary IfaceDeclExtras where - get _bh = panic "no get for IfaceDeclExtras" - put_ bh (IfaceIdExtras extras) = do - putByte bh 1; put_ bh extras - put_ bh (IfaceDataExtras fix insts anns cons) = do - putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons - put_ bh (IfaceClassExtras fix insts anns methods defms) = do - putByte bh 3 - put_ bh fix - put_ bh insts - put_ bh anns - put_ bh methods - put_ bh defms - put_ bh (IfaceSynonymExtras fix anns) = do - putByte bh 4; put_ bh fix; put_ bh anns - put_ bh (IfaceFamilyExtras fix finsts anns) = do - putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns - put_ bh IfaceOtherDeclExtras = putByte bh 6 - -instance Binary IfaceIdExtras where - get _bh = panic "no get for IfaceIdExtras" - put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns } - -declExtras :: (OccName -> Maybe Fixity) - -> (OccName -> [AnnPayload]) - -> OccEnv [IfaceRule] - -> OccEnv [IfaceClsInst] - -> OccEnv [IfaceFamInst] - -> OccEnv IfExtName -- lookup default method names - -> IfaceDecl - -> IfaceDeclExtras - -declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl - = case decl of - IfaceId{} -> IfaceIdExtras (id_extras n) - IfaceData{ifCons=cons} -> - IfaceDataExtras (fix_fn n) - (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ - map ifDFun (lookupOccEnvL inst_env n)) - (ann_fn n) - (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) - IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> - IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms - where - insts = (map ifDFun $ (concatMap at_extras ats) - ++ lookupOccEnvL inst_env n) - -- Include instances of the associated types - -- as well as instances of the class (#5147) - meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] - -- Names of all the default methods (see Note [default method Name]) - defms = [ dmName - | IfaceClassOp bndr _ (Just _) <- sigs - , let dmOcc = mkDefaultMethodOcc (nameOccName bndr) - , Just dmName <- [lookupOccEnv dm_env dmOcc] ] - IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) - (ann_fn n) - IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) - (map ifFamInstAxiom (lookupOccEnvL fi_env n)) - (ann_fn n) - _other -> IfaceOtherDeclExtras - where - n = getOccName decl - id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) - at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) - - -{- Note [default method Name] (see also #15970) - -The Names for the default methods aren't available in the IfaceSyn. - -* We originally start with a DefMethInfo from the class, contain a - Name for the default method - -* We turn that into IfaceSyn as a DefMethSpec which lacks a Name - entirely. Why? Because the Name can be derived from the method name - (in TcIface), so doesn't need to be serialised into the interface - file. - -But now we have to get the Name back, because the class declaration's -fingerprint needs to depend on it (this was the bug in #15970). This -is done in a slightly convoluted way: - -* Then, in addFingerprints we build a map that maps OccNames to Names - -* We pass that map to declExtras which laboriously looks up in the map - (using the derived occurrence name) to recover the Name we have just - thrown away. --} - -lookupOccEnvL :: OccEnv [v] -> OccName -> [v] -lookupOccEnvL env k = lookupOccEnv env k `orElse` [] - -{- --- for testing: use the md5sum command to generate fingerprints and --- compare the results against our built-in version. - fp' <- oldMD5 dflags bh - if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') - else return fp - -oldMD5 dflags bh = do - tmp <- newTempName dflags CurrentModule "bin" - writeBinMem bh tmp - tmp2 <- newTempName dflags CurrentModule "md5" - let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 - r <- system cmd - case r of - ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) - ExitSuccess -> do - hash_str <- readFile tmp2 - return $! readHexFingerprint hash_str --} - ----------------------- --- mkOrphMap partitions instance decls or rules into --- (a) an OccEnv for ones that are not orphans, --- mapping the local OccName to a list of its decls --- (b) a list of orphan decls -mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl - -> [decl] -- Sorted into canonical order - -> (OccEnv [decl], -- Non-orphan decls associated with their key; - -- each sublist in canonical order - [decl]) -- Orphan decls; in canonical order -mkOrphMap get_key decls - = foldl' go (emptyOccEnv, []) decls - where - go (non_orphs, orphs) d - | NotOrphan occ <- get_key d - = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) - | otherwise = (non_orphs, d:orphs) - -{- -************************************************************************ -* * - COMPLETE Pragmas -* * -************************************************************************ --} - -mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch -mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc - - -{- -************************************************************************ -* * - Keeping track of what we've slurped, and fingerprints -* * -************************************************************************ --} - - -mkIfaceAnnotation :: Annotation -> IfaceAnnotation -mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) - = IfaceAnnotation { - ifAnnotatedTarget = fmap nameOccName target, - ifAnnotatedValue = payload - } - -mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical -mkIfaceExports exports - = sortBy stableAvailCmp (map sort_subs exports) - where - sort_subs :: AvailInfo -> AvailInfo - sort_subs (Avail n) = Avail n - sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs) - sort_subs (AvailTC n (m:ms) fs) - | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs) - | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs) - -- Maintain the AvailTC Invariant - - sort_flds = sortBy (stableNameCmp `on` flSelector) - -{- -Note [Original module] -~~~~~~~~~~~~~~~~~~~~~ -Consider this: - module X where { data family T } - module Y( T(..) ) where { import X; data instance T Int = MkT Int } -The exported Avail from Y will look like - X.T{X.T, Y.MkT} -That is, in Y, - - only MkT is brought into scope by the data instance; - - but the parent (used for grouping and naming in T(..) exports) is X.T - - and in this case we export X.T too - -In the result of MkIfaceExports, the names are grouped by defining module, -so we may need to split up a single Avail into multiple ones. - -Note [Internal used_names] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the used_names are External Names, but we can have Internal -Names too: see Note [Binders in Template Haskell] in Convert, and -#5362 for an example. Such Names are always - - Such Names are always for locally-defined things, for which we - don't gather usage info, so we can just ignore them in ent_map - - They are always System Names, hence the assert, just as a double check. - - -************************************************************************ -* * - Load the old interface file for this module (unless - we have it already), and check whether it is up to date -* * -************************************************************************ --} - -data RecompileRequired - = UpToDate - -- ^ everything is up to date, recompilation is not required - | MustCompile - -- ^ The .hs file has been touched, or the .o/.hi file does not exist - | RecompBecause String - -- ^ The .o/.hi files are up to date, but something else has changed - -- to force recompilation; the String says what (one-line summary) - deriving Eq - -instance Semigroup RecompileRequired where - UpToDate <> r = r - mc <> _ = mc - -instance Monoid RecompileRequired where - mempty = UpToDate - -recompileRequired :: RecompileRequired -> Bool -recompileRequired UpToDate = False -recompileRequired _ = True - - - --- | Top level function to check if the version of an old interface file --- is equivalent to the current source file the user asked us to compile. --- If the same, we can avoid recompilation. We return a tuple where the --- first element is a bool saying if we should recompile the object file --- and the second is maybe the interface file, where Nothing means to --- rebuild the interface file and not use the existing one. -checkOldIface - :: HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (RecompileRequired, Maybe ModIface) - -checkOldIface hsc_env mod_summary source_modified maybe_iface - = do let dflags = hsc_dflags hsc_env - showPass dflags $ - "Checking old interface for " ++ - (showPpr dflags $ ms_mod mod_summary) ++ - " (use -ddump-hi-diffs for more details)" - initIfaceCheck (text "checkOldIface") hsc_env $ - check_old_iface hsc_env mod_summary source_modified maybe_iface - -check_old_iface - :: HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface - -> IfG (RecompileRequired, Maybe ModIface) - -check_old_iface hsc_env mod_summary src_modified maybe_iface - = let dflags = hsc_dflags hsc_env - getIface = - case maybe_iface of - Just _ -> do - traceIf (text "We already have the old interface for" <+> - ppr (ms_mod mod_summary)) - return maybe_iface - Nothing -> loadIface - - loadIface = do - let iface_path = msHiFilePath mod_summary - read_result <- readIface (ms_mod mod_summary) iface_path - case read_result of - Failed err -> do - traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) - traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err) - return Nothing - Succeeded iface -> do - traceIf (text "Read the interface file" <+> text iface_path) - return $ Just iface - - src_changed - | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True - | SourceModified <- src_modified = True - | otherwise = False - in do - when src_changed $ - traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off") - - case src_changed of - -- If the source has changed and we're in interactive mode, - -- avoid reading an interface; just return the one we might - -- have been supplied with. - True | not (isObjectTarget $ hscTarget dflags) -> - return (MustCompile, maybe_iface) - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - True -> do - maybe_iface' <- getIface - return (MustCompile, maybe_iface') - - False -> do - maybe_iface' <- getIface - case maybe_iface' of - -- We can't retrieve the iface - Nothing -> return (MustCompile, Nothing) - - -- We have got the old iface; check its versions - -- even in the SourceUnmodifiedAndStable case we - -- should check versions because some packages - -- might have changed or gone away. - Just iface -> checkVersions hsc_env mod_summary iface - --- | Check if a module is still the same 'version'. --- --- This function is called in the recompilation checker after we have --- determined that the module M being checked hasn't had any changes --- to its source file since we last compiled M. So at this point in general --- two things may have changed that mean we should recompile M: --- * The interface export by a dependency of M has changed. --- * The compiler flags specified this time for M have changed --- in a manner that is significant for recompilation. --- We return not just if we should recompile the object file but also --- if we should rebuild the interface file. -checkVersions :: HscEnv - -> ModSummary - -> ModIface -- Old interface - -> IfG (RecompileRequired, Maybe ModIface) -checkVersions hsc_env mod_summary iface - = do { traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) - - -- readIface will have verified that the InstalledUnitId matches, - -- but we ALSO must make sure the instantiation matches up. See - -- test case bkpcabal04! - ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env) - then return (RecompBecause "-this-unit-id changed", Nothing) else do { - ; recomp <- checkFlagHash hsc_env iface - ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- checkOptimHash hsc_env iface - ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- checkHpcHash hsc_env iface - ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- checkMergedSignatures mod_summary iface - ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- checkHsig mod_summary iface - ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- checkHie mod_summary - ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- checkDependencies hsc_env mod_summary iface - ; if recompileRequired recomp then return (recomp, Just iface) else do { - ; recomp <- checkPlugins hsc_env iface - ; if recompileRequired recomp then return (recomp, Nothing) else do { - - - -- Source code unchanged and no errors yet... carry on - -- - -- First put the dependent-module info, read from the old - -- interface, into the envt, so that when we look for - -- interfaces we look for the right one (.hi or .hi-boot) - -- - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - -- - -- We do this regardless of compilation mode, although in --make mode - -- all the dependent modules should be in the HPT already, so it's - -- quite redundant - ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } - ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] - ; return (recomp, Just iface) - }}}}}}}}}} - where - this_pkg = thisPackage (hsc_dflags hsc_env) - -- This is a bit of a hack really - mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) - mod_deps = mkModDeps (dep_mods (mi_deps iface)) - --- | Check if any plugins are requesting recompilation -checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired -checkPlugins hsc iface = liftIO $ do - new_fingerprint <- fingerprintPlugins hsc - let old_fingerprint = mi_plugin_hash (mi_final_exts iface) - pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc)) - return $ - pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr - -fingerprintPlugins :: HscEnv -> IO Fingerprint -fingerprintPlugins hsc_env = do - fingerprintPlugins' $ plugins (hsc_dflags hsc_env) - -fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint -fingerprintPlugins' plugins = do - res <- mconcat <$> mapM pluginRecompile' plugins - return $ case res of - NoForceRecompile -> fingerprintString "NoForceRecompile" - ForceRecompile -> fingerprintString "ForceRecompile" - -- is the chance of collision worth worrying about? - -- An alternative is to fingerprintFingerprints [fingerprintString - -- "maybeRecompile", fp] - (MaybeRecompile fp) -> fp - - -pluginRecompileToRecompileRequired - :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired -pluginRecompileToRecompileRequired old_fp new_fp pr - | old_fp == new_fp = - case pr of - NoForceRecompile -> UpToDate - - -- we already checked the fingerprint above so a mismatch is not possible - -- here, remember that: `fingerprint (MaybeRecomp x) == x`. - MaybeRecompile _ -> UpToDate - - -- when we have an impure plugin in the stack we have to unconditionally - -- recompile since it might integrate all sorts of crazy IO results into - -- its compilation output. - ForceRecompile -> RecompBecause "Impure plugin forced recompilation" - - | old_fp `elem` magic_fingerprints || - new_fp `elem` magic_fingerprints - -- The fingerprints do not match either the old or new one is a magic - -- fingerprint. This happens when non-pure plugins are added for the first - -- time or when we go from one recompilation strategy to another: (force -> - -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.) - -- - -- For example when we go from from ForceRecomp to NoForceRecomp - -- recompilation is triggered since the old impure plugins could have - -- changed the build output which is now back to normal. - = RecompBecause "Plugins changed" - - | otherwise = - let reason = "Plugin fingerprint changed" in - case pr of - -- even though a plugin is forcing recompilation the fingerprint changed - -- which would cause recompilation anyways so we report the fingerprint - -- change instead. - ForceRecompile -> RecompBecause reason - - _ -> RecompBecause reason - - where - magic_fingerprints = - [ fingerprintString "NoForceRecompile" - , fingerprintString "ForceRecompile" - ] - - --- | Check if an hsig file needs recompilation because its --- implementing module has changed. -checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired -checkHsig mod_summary iface = do - dflags <- getDynFlags - let outer_mod = ms_mod mod_summary - inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - case inner_mod == mi_semantic_module iface of - True -> up_to_date (text "implementing module unchanged") - False -> return (RecompBecause "implementing module changed") - --- | Check if @.hie@ file is out of date or missing. -checkHie :: ModSummary -> IfG RecompileRequired -checkHie mod_summary = do - dflags <- getDynFlags - let hie_date_opt = ms_hie_date mod_summary - hs_date = ms_hs_date mod_summary - pure $ case gopt Opt_WriteHie dflags of - False -> UpToDate - True -> case hie_date_opt of - Nothing -> RecompBecause "HIE file is missing" - Just hie_date - | hie_date < hs_date - -> RecompBecause "HIE file is out of date" - | otherwise - -> UpToDate - --- | Check the flags haven't changed -checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired -checkFlagHash hsc_env iface = do - let old_hash = mi_flag_hash (mi_final_exts iface) - new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) - (mi_module iface) - putNameLiterally - case old_hash == new_hash of - True -> up_to_date (text "Module flags unchanged") - False -> out_of_date_hash "flags changed" - (text " Module flags have changed") - old_hash new_hash - --- | Check the optimisation flags haven't changed -checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired -checkOptimHash hsc_env iface = do - let old_hash = mi_opt_hash (mi_final_exts iface) - new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env) - putNameLiterally - if | old_hash == new_hash - -> up_to_date (text "Optimisation flags unchanged") - | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) - -> up_to_date (text "Optimisation flags changed; ignoring") - | otherwise - -> out_of_date_hash "Optimisation flags changed" - (text " Optimisation flags have changed") - old_hash new_hash - --- | Check the HPC flags haven't changed -checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired -checkHpcHash hsc_env iface = do - let old_hash = mi_hpc_hash (mi_final_exts iface) - new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env) - putNameLiterally - if | old_hash == new_hash - -> up_to_date (text "HPC flags unchanged") - | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) - -> up_to_date (text "HPC flags changed; ignoring") - | otherwise - -> out_of_date_hash "HPC flags changed" - (text " HPC flags have changed") - old_hash new_hash - --- Check that the set of signatures we are merging in match. --- If the -unit-id flags change, this can change too. -checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired -checkMergedSignatures mod_summary iface = do - dflags <- getDynFlags - let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] - new_merged = case Map.lookup (ms_mod_name mod_summary) - (requirementContext (pkgState dflags)) of - Nothing -> [] - Just r -> sort $ map (indefModuleToModule dflags) r - if old_merged == new_merged - then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged) - else return (RecompBecause "signatures to merge in changed") - --- If the direct imports of this module are resolved to targets that --- are not among the dependencies of the previous interface file, --- then we definitely need to recompile. This catches cases like --- - an exposed package has been upgraded --- - we are compiling with different package flags --- - a home module that was shadowing a package module has been removed --- - a new home module has been added that shadows a package module --- See bug #1372. --- --- In addition, we also check if the union of dependencies of the imported --- modules has any difference to the previous set of dependencies. We would need --- to recompile in that case also since the `mi_deps` field of ModIface needs --- to be updated to match that information. This is one of the invariants --- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants). --- See bug #16511. --- --- Returns (RecompBecause ) if recompilation is required. -checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired -checkDependencies hsc_env summary iface - = do - checkList $ - [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) - , do - (recomp, mnames_seen) <- runUntilRecompRequired $ map - checkForNewHomeDependency - (ms_home_imps summary) - case recomp of - UpToDate -> do - let - seen_home_deps = Set.unions $ map Set.fromList mnames_seen - checkIfAllOldHomeDependenciesAreSeen seen_home_deps - _ -> return recomp] - where - prev_dep_mods = dep_mods (mi_deps iface) - prev_dep_plgn = dep_plgins (mi_deps iface) - prev_dep_pkgs = dep_pkgs (mi_deps iface) - - this_pkg = thisPackage (hsc_dflags hsc_env) - - dep_missing (mb_pkg, L _ mod) = do - find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg) - let reason = moduleNameString mod ++ " changed" - case find_res of - Found _ mod - | pkg == this_pkg - -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn - then do traceHiDiffs $ - text "imported module " <> quotes (ppr mod) <> - text " not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - | otherwise - -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs) - then do traceHiDiffs $ - text "imported module " <> quotes (ppr mod) <> - text " is from package " <> quotes (ppr pkg) <> - text ", which is not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - where pkg = moduleUnitId mod - _otherwise -> return (RecompBecause reason) - - old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods - isOldHomeDeps = flip Set.member old_deps - checkForNewHomeDependency (L _ mname) = do - let - mod = mkModule this_pkg mname - str_mname = moduleNameString mname - reason = str_mname ++ " changed" - -- We only want to look at home modules to check if any new home dependency - -- pops in and thus here, skip modules that are not home. Checking - -- membership in old home dependencies suffice because the `dep_missing` - -- check already verified that all imported home modules are present there. - if not (isOldHomeDeps mname) - then return (UpToDate, []) - else do - mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do - let mnames = mname:(map fst $ filter (not . snd) $ - dep_mods $ mi_deps imported_iface) - case find (not . isOldHomeDeps) mnames of - Nothing -> return (UpToDate, mnames) - Just new_dep_mname -> do - traceHiDiffs $ - text "imported home module " <> quotes (ppr mod) <> - text " has a new dependency " <> quotes (ppr new_dep_mname) - return (RecompBecause reason, []) - return $ fromMaybe (MustCompile, []) mb_result - - -- Performs all recompilation checks in the list until a check that yields - -- recompile required is encountered. Returns the list of the results of - -- all UpToDate checks. - runUntilRecompRequired [] = return (UpToDate, []) - runUntilRecompRequired (check:checks) = do - (recompile, value) <- check - if recompileRequired recompile - then return (recompile, []) - else do - (recomp, values) <- runUntilRecompRequired checks - return (recomp, value:values) - - checkIfAllOldHomeDependenciesAreSeen seen_deps = do - let unseen_old_deps = Set.difference - old_deps - seen_deps - if not (null unseen_old_deps) - then do - let missing_dep = Set.elemAt 0 unseen_old_deps - traceHiDiffs $ - text "missing old home dependency " <> quotes (ppr missing_dep) - return $ RecompBecause "missing old dependency" - else return UpToDate - -needInterface :: Module -> (ModIface -> IfG RecompileRequired) - -> IfG RecompileRequired -needInterface mod continue - = do - mb_recomp <- getFromModIface - "need version info for" - mod - continue - case mb_recomp of - Nothing -> return MustCompile - Just recomp -> return recomp - -getFromModIface :: String -> Module -> (ModIface -> IfG a) - -> IfG (Maybe a) -getFromModIface doc_msg mod getter - = do -- Load the imported interface if possible - let doc_str = sep [text doc_msg, ppr mod] - traceHiDiffs (text "Checking innterface for module" <+> ppr mod) - - mb_iface <- loadInterface doc_str mod ImportBySystem - -- Load the interface, but don't complain on failure; - -- Instead, get an Either back which we can test - - case mb_iface of - Failed _ -> do - traceHiDiffs (sep [text "Couldn't load interface for module", - ppr mod]) - return Nothing - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain: it might - -- just be that the current module doesn't need that - -- import and it's been deleted - Succeeded iface -> Just <$> getter iface - --- | Given the usage information extracted from the old --- M.hi file for the module being compiled, figure out --- whether M needs to be recompiled. -checkModUsage :: UnitId -> Usage -> IfG RecompileRequired -checkModUsage _this_pkg UsagePackageModule{ - usg_mod = mod, - usg_mod_hash = old_mod_hash } - = needInterface mod $ \iface -> do - let reason = moduleNameString (moduleName mod) ++ " changed" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) - -- We only track the ABI hash of package modules, rather than - -- individual entity usages, so if the ABI hash changes we must - -- recompile. This is safe but may entail more recompilation when - -- a dependent package has changed. - -checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } - = needInterface mod $ \iface -> do - let reason = moduleNameString (moduleName mod) ++ " changed (raw)" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) - -checkModUsage this_pkg UsageHomeModule{ - usg_mod_name = mod_name, - usg_mod_hash = old_mod_hash, - usg_exports = maybe_old_export_hash, - usg_entities = old_decl_hash } - = do - let mod = mkModule this_pkg mod_name - needInterface mod $ \iface -> do - - let - new_mod_hash = mi_mod_hash (mi_final_exts iface) - new_decl_hash = mi_hash_fn (mi_final_exts iface) - new_export_hash = mi_exp_hash (mi_final_exts iface) - - reason = moduleNameString mod_name ++ " changed" - - -- CHECK MODULE - recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash - if not (recompileRequired recompile) - then return UpToDate - else do - - -- CHECK EXPORT LIST - checkMaybeHash reason maybe_old_export_hash new_export_hash - (text " Export list changed") $ do - - -- CHECK ITEMS ONE BY ONE - recompile <- checkList [ checkEntityUsage reason new_decl_hash u - | u <- old_decl_hash] - if recompileRequired recompile - then return recompile -- This one failed, so just bail out now - else up_to_date (text " Great! The bits I use are up to date") - - -checkModUsage _this_pkg UsageFile{ usg_file_path = file, - usg_file_hash = old_hash } = - liftIO $ - handleIO handle $ do - new_hash <- getFileHash file - if (old_hash /= new_hash) - then return recomp - else return UpToDate - where - recomp = RecompBecause (file ++ " changed") - handle = -#if defined(DEBUG) - \e -> pprTrace "UsageFile" (text (show e)) $ return recomp -#else - \_ -> return recomp -- if we can't find the file, just recompile, don't fail -#endif - ------------------------- -checkModuleFingerprint :: String -> Fingerprint -> Fingerprint - -> IfG RecompileRequired -checkModuleFingerprint reason old_mod_hash new_mod_hash - | new_mod_hash == old_mod_hash - = up_to_date (text "Module fingerprint unchanged") - - | otherwise - = out_of_date_hash reason (text " Module fingerprint has changed") - old_mod_hash new_mod_hash - ------------------------- -checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc - -> IfG RecompileRequired -> IfG RecompileRequired -checkMaybeHash reason maybe_old_hash new_hash doc continue - | Just hash <- maybe_old_hash, hash /= new_hash - = out_of_date_hash reason doc hash new_hash - | otherwise - = continue - ------------------------- -checkEntityUsage :: String - -> (OccName -> Maybe (OccName, Fingerprint)) - -> (OccName, Fingerprint) - -> IfG RecompileRequired -checkEntityUsage reason new_hash (name,old_hash) - = case new_hash name of - - Nothing -> -- We used it before, but it ain't there now - out_of_date reason (sep [text "No longer exported:", ppr name]) - - Just (_, new_hash) -- It's there, but is it up to date? - | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) - return UpToDate - | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name) - old_hash new_hash - -up_to_date :: SDoc -> IfG RecompileRequired -up_to_date msg = traceHiDiffs msg >> return UpToDate - -out_of_date :: String -> SDoc -> IfG RecompileRequired -out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) - -out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired -out_of_date_hash reason msg old_hash new_hash - = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) - ----------------------- -checkList :: [IfG RecompileRequired] -> IfG RecompileRequired --- This helper is used in two places -checkList [] = return UpToDate -checkList (check:checks) = do recompile <- check - if recompileRequired recompile - then return recompile - else checkList checks - -{- -************************************************************************ -* * - Converting things to their Iface equivalents -* * -************************************************************************ --} - -tyThingToIfaceDecl :: TyThing -> IfaceDecl -tyThingToIfaceDecl (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) -tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax -tyThingToIfaceDecl (AConLike cl) = case cl of - RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only - PatSynCon ps -> patSynToIfaceDecl ps - --------------------------- -idToIfaceDecl :: Id -> IfaceDecl --- The Id is already tidied, so that locally-bound names --- (lambdas, for-alls) already have non-clashing OccNames --- We can't tidy it here, locally, because it may have --- free variables in its type or IdInfo -idToIfaceDecl id - = IfaceId { ifName = getName id, - ifType = toIfaceType (idType id), - ifIdDetails = toIfaceIdDetails (idDetails id), - ifIdInfo = toIfaceIdInfo (idInfo id) } - --------------------------- -dataConToIfaceDecl :: DataCon -> IfaceDecl -dataConToIfaceDecl dataCon - = IfaceId { ifName = getName dataCon, - ifType = toIfaceType (dataConUserType dataCon), - ifIdDetails = IfVanillaId, - ifIdInfo = NoInfo } - --------------------------- -coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl --- We *do* tidy Axioms, because they are not (and cannot --- conveniently be) built in tidy form -coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches - , co_ax_role = role }) - = IfaceAxiom { ifName = getName ax - , ifTyCon = toIfaceTyCon tycon - , ifRole = role - , ifAxBranches = map (coAxBranchToIfaceBranch tycon - (map coAxBranchLHS branch_list)) - branch_list } - where - branch_list = fromBranches branches - --- 2nd parameter is the list of branch LHSs, in case of a closed type family, --- for conversion from incompatible branches to incompatible indices. --- For an open type family the list should be empty. --- See Note [Storing compatibility] in CoAxiom -coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch tc lhs_s - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_eta_tvs = eta_tvs - , cab_lhs = lhs, cab_roles = roles - , cab_rhs = rhs, cab_incomps = incomps }) - - = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs - , ifaxbCoVars = map toIfaceIdBndr cvs - , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs - , ifaxbLHS = toIfaceTcArgs tc lhs - , ifaxbRoles = roles - , ifaxbRHS = toIfaceType rhs - , ifaxbIncomps = iface_incomps } - where - iface_incomps = map (expectJust "iface_incomps" - . flip findIndex lhs_s - . eqTypes - . coAxBranchLHS) incomps - ------------------ -tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) --- We *do* tidy TyCons, because they are not (and cannot --- conveniently be) built in tidy form --- The returned TidyEnv is the one after tidying the tyConTyVars -tyConToIfaceDecl env tycon - | Just clas <- tyConClass_maybe tycon - = classToIfaceDecl env clas - - | Just syn_rhs <- synTyConRhs_maybe tycon - = ( tc_env1 - , IfaceSynonym { ifName = getName tycon, - ifRoles = tyConRoles tycon, - ifSynRhs = if_syn_type syn_rhs, - ifBinders = if_binders, - ifResKind = if_res_kind - }) - - | Just fam_flav <- famTyConFlav_maybe tycon - = ( tc_env1 - , IfaceFamily { ifName = getName tycon, - ifResVar = if_res_var, - ifFamFlav = to_if_fam_flav fam_flav, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifFamInj = tyConInjectivityInfo tycon - }) - - | isAlgTyCon tycon - = ( tc_env1 - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = tyConCType tycon, - ifRoles = tyConRoles tycon, - ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifParent = parent }) - - | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon - -- We only convert these TyCons to IfaceTyCons when we are - -- just about to pretty-print them, not because we are going - -- to put them into interface files - = ( env - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = Nothing, - ifRoles = tyConRoles tycon, - ifCtxt = [], - ifCons = IfDataTyCon [], - ifGadtSyntax = False, - ifParent = IfNoParent }) - where - -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` - -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause - -- an error. - (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - tc_tyvars = binderVars tc_binders - if_binders = toIfaceTyCoVarBinders tc_binders - -- No tidying of the binders; they are already tidy - if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) - if_syn_type ty = tidyToIfaceType tc_env1 ty - if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon - - parent = case tyConFamInstSig_maybe tycon of - Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) - (toIfaceTyCon tc) - (tidyToIfaceTcArgs tc_env1 tc ty) - Nothing -> IfNoParent - - to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon - to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon - to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon - to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon - to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing - to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) - = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) - where defs = fromBranches $ coAxiomBranches ax - lhss = map coAxBranchLHS defs - ibr = map (coAxBranchToIfaceBranch tycon lhss) defs - axn = coAxiomName ax - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con] - ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The AbstractTyCon case happens when a TyCon has been trimmed - -- during tidying. - -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver - -- for GHCi, when browsing a module, in which case the - -- AbstractTyCon and TupleTyCon cases are perfectly sensible. - -- (Tuple declarations are not serialised into interface files.) - - ifaceConDecl data_con - = IfCon { ifConName = dataConName data_con, - ifConInfix = dataConIsInfix data_con, - ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConExTCvs = map toIfaceBndr ex_tvs', - ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', - ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, - ifConCtxt = tidyToIfaceContext con_env2 theta, - ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, - ifConFields = dataConFieldLabels data_con, - ifConStricts = map (toIfaceBang con_env2) - (dataConImplBangs data_con), - ifConSrcStricts = map toIfaceSrcBang - (dataConSrcBangs data_con)} - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - user_bndrs = dataConUserTyVarBinders data_con - - -- Tidy the univ_tvs of the data constructor to be identical - -- to the tyConTyVars of the type constructor. This means - -- (a) we don't need to redundantly put them into the interface file - -- (b) when pretty-printing an Iface data declaration in H98-style syntax, - -- we know that the type variables will line up - -- The latter (b) is important because we pretty-print type constructors - -- by converting to IfaceSyn and pretty-printing that - con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) - -- A bit grimy, perhaps, but it's simple! - - (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs - user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs - to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) - - -- By this point, we have tidied every universal and existential - -- tyvar. Because of the dcUserTyCoVarBinders invariant - -- (see Note [DataCon user type variable binders]), *every* - -- user-written tyvar must be contained in the substitution that - -- tidying produced. Therefore, tidying the user-written tyvars is a - -- simple matter of looking up each variable in the substitution, - -- which tidyTyCoVarOcc accomplishes. - tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder - tidyUserTyCoVarBinder env (Bndr tv vis) = - Bndr (tidyTyCoVarOcc env tv) vis - -classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) -classToIfaceDecl env clas - = ( env1 - , IfaceClass { ifName = getName tycon, - ifRoles = tyConRoles (classTyCon clas), - ifBinders = toIfaceTyCoVarBinders tc_binders, - ifBody = body, - ifFDs = map toIfaceFD clas_fds }) - where - (_, clas_fds, sc_theta, _, clas_ats, op_stuff) - = classExtraBigSig clas - tycon = classTyCon clas - - body | isAbstractTyCon tycon = IfAbstractClass - | otherwise - = IfConcreteClass { - ifClassCtxt = tidyToIfaceContext env1 sc_theta, - ifATs = map toIfaceAT clas_ats, - ifSigs = map toIfaceClassOp op_stuff, - ifMinDef = fmap getOccFS (classMinimalDef clas) - } - - (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - - toIfaceAT :: ClassATItem -> IfaceAT - toIfaceAT (ATI tc def) - = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) - where - (env2, if_decl) = tyConToIfaceDecl env1 tc - - toIfaceClassOp (sel_id, def_meth) - = ASSERT( sel_tyvars == binderVars tc_binders ) - IfaceClassOp (getName sel_id) - (tidyToIfaceType env1 op_ty) - (fmap toDmSpec def_meth) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) - op_ty = funResultTy rho_ty - - toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType - toDmSpec (_, VanillaDM) = VanillaDM - toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) - - toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 - ,map (tidyTyVar env1) tvs2) - --------------------------- - -tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) --- If the type variable "binder" is in scope, don't re-bind it --- In a class decl, for example, the ATD binders mention --- (amd must mention) the class tyvars -tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) - = case lookupVarEnv subst tv of - Just tv' -> (env, Bndr tv' vis) - Nothing -> tidyTyCoVarBinder env tvb - -tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) -tidyTyConBinders = mapAccumL tidyTyConBinder - -tidyTyVar :: TidyEnv -> TyVar -> FastString -tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) - --------------------------- -instanceToIfaceInst :: ClsInst -> IfaceClsInst -instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag - , is_cls_nm = cls_name, is_cls = cls - , is_tcs = mb_tcs - , is_orphan = orph }) - = ASSERT( cls_name == className cls ) - IfaceClsInst { ifDFun = dfun_name, - ifOFlag = oflag, - ifInstCls = cls_name, - ifInstTys = map do_rough mb_tcs, - ifInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) - - dfun_name = idName dfun_id - - --------------------------- -famInstToIfaceFamInst :: FamInst -> IfaceFamInst -famInstToIfaceFamInst (FamInst { fi_axiom = axiom, - fi_fam = fam, - fi_tcs = roughs }) - = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom - , ifFamInstFam = fam - , ifFamInstTys = map do_rough roughs - , ifFamInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) - - fam_decl = tyConName $ coAxiomTyCon axiom - mod = ASSERT( isExternalName (coAxiomName axiom) ) - nameModule (coAxiomName axiom) - is_local name = nameIsLocalOrFrom mod name - - lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom) - - orph | is_local fam_decl - = NotOrphan (nameOccName fam_decl) - | otherwise - = chooseOrphanAnchor lhs_names - --------------------------- -coreRuleToIfaceRule :: CoreRule -> IfaceRule -coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) - = pprTrace "toHsRule: builtin" (ppr fn) $ - bogusIfaceRule fn - -coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, - ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, - ru_orphan = orph, ru_auto = auto }) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map toIfaceBndr bndrs, - ifRuleHead = fn, - ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr rhs, - ifRuleAuto = auto, - ifRuleOrph = orph } - where - -- For type args we must remove synonyms from the outermost - -- level. Reason: so that when we read it back in we'll - -- construct the same ru_rough field as we have right now; - -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) - do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) - do_arg arg = toIfaceExpr arg - -bogusIfaceRule :: Name -> IfaceRule -bogusIfaceRule id_name - = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, - ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], - ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan, - ifRuleAuto = True } diff --git a/iface/TcIface.hs b/iface/TcIface.hs deleted file mode 100644 --- a/iface/TcIface.hs +++ /dev/null @@ -1,1822 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Type checking of type signatures in interface files --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE NondecreasingIndentation #-} - -module TcIface ( - tcLookupImported_maybe, - importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - typecheckIfacesForMerging, - typecheckIfaceForInstantiate, - tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, - tcIfaceAnnotations, tcIfaceCompleteSigs, - tcIfaceExpr, -- Desired by HERMIT (#7683) - tcIfaceGlobal - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcTypeNats(typeNatCoAxiomRules) -import IfaceSyn -import LoadIface -import IfaceEnv -import BuildTyCl -import TcRnMonad -import TcType -import Type -import Coercion -import CoAxiom -import TyCoRep -- needs to build types & coercions in a knot -import TyCoSubst ( substTyCoVars ) -import HscTypes -import Annotations -import InstEnv -import FamInstEnv -import CoreSyn -import CoreUtils -import CoreUnfold -import CoreLint -import MkCore -import Id -import MkId -import IdInfo -import Class -import TyCon -import ConLike -import DataCon -import PrelNames -import TysWiredIn -import Literal -import Var -import VarSet -import Name -import NameEnv -import NameSet -import OccurAnal ( occurAnalyseExpr ) -import Demand -import Module -import UniqFM -import UniqSupply -import Outputable -import Maybes -import SrcLoc -import DynFlags -import Util -import FastString -import BasicTypes hiding ( SuccessFlag(..) ) -import ListSetOps -import GHC.Fingerprint -import qualified BooleanFormula as BF - -import Control.Monad -import qualified Data.Map as Map - -{- -This module takes - - IfaceDecl -> TyThing - IfaceType -> Type - etc - -An IfaceDecl is populated with RdrNames, and these are not renamed to -Names before typechecking, because there should be no scope errors etc. - - -- For (b) consider: f = \$(...h....) - -- where h is imported, and calls f via an hi-boot file. - -- This is bad! But it is not seen as a staging error, because h - -- is indeed imported. We don't want the type-checker to black-hole - -- when simplifying and compiling the splice! - -- - -- Simple solution: discard any unfolding that mentions a variable - -- bound in this module (and hence not yet processed). - -- The discarding happens when forkM finds a type error. - - -************************************************************************ -* * - Type-checking a complete interface -* * -************************************************************************ - -Suppose we discover we don't need to recompile. Then we must type -check the old interface file. This is a bit different to the -incremental type checking we do as we suck in interface files. Instead -we do things similarly as when we are typechecking source decls: we -bring into scope the type envt for the interface all at once, using a -knot. Remember, the decls aren't necessarily in dependency order -- -and even if they were, the type decls might be mutually recursive. - -Note [Knot-tying typecheckIface] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are typechecking an interface A.hi, and we come across -a Name for another entity defined in A.hi. How do we get the -'TyCon', in this case? There are three cases: - - 1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in - preparation of checking if the hs file we're building - is compatible. In this case, we want all of the internal - TyCons to MATCH the ones that we just constructed during - typechecking: the knot is thus tied through if_rec_types. - - 2) retypecheckLoop in GhcMake: We are retypechecking a - mutually recursive cluster of hi files, in order to ensure - that all of the references refer to each other correctly. - In this case, the knot is tied through the HPT passed in, - which contains all of the interfaces we are in the process - of typechecking. - - 3) genModDetails in HscMain: We are typechecking an - old interface to generate the ModDetails. In this case, - we do the same thing as (2) and pass in an HPT with - the HomeModInfo being generated to tie knots. - -The upshot is that the CLIENT of this function is responsible -for making sure that the knot is tied correctly. If you don't, -then you'll get a message saying that we couldn't load the -declaration you wanted. - -BTW, in one-shot mode we never call typecheckIface; instead, -loadInterface handles type-checking interface. In that case, -knots are tied through the EPS. No problem! --} - --- Clients of this function be careful, see Note [Knot-tying typecheckIface] -typecheckIface :: ModIface -- Get the decls from here - -> IfG ModDetails -typecheckIface iface - = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do - { -- Get the right set of decls and rules. If we are compiling without -O - -- we discard pragmas before typechecking, so that we don't "see" - -- information that we shouldn't. From a versioning point of view - -- It's not actually *wrong* to do so, but in fact GHCi is unable - -- to handle unboxed tuples, so it must not see unfoldings. - ignore_prags <- goptM Opt_IgnoreInterfacePragmas - - -- Typecheck the decls. This is done lazily, so that the knot-tying - -- within this single module works out right. It's the callers - -- job to make sure the knot is tied. - ; names_w_things <- loadDecls ignore_prags (mi_decls iface) - ; let type_env = mkNameEnv names_w_things - - -- Now do those rules, instances and annotations - ; insts <- mapM tcIfaceInst (mi_insts iface) - ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - ; rules <- tcIfaceRules ignore_prags (mi_rules iface) - ; anns <- tcIfaceAnnotations (mi_anns iface) - - -- Exports - ; exports <- ifaceExportNames (mi_exports iface) - - -- Complete Sigs - ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - - -- Finished - ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), - -- Careful! If we tug on the TyThing thunks too early - -- we'll infinite loop with hs-boot. See #10083 for - -- an example where this would cause non-termination. - text "Type envt:" <+> ppr (map fst names_w_things)]) - ; return $ ModDetails { md_types = type_env - , md_insts = insts - , md_fam_insts = fam_insts - , md_rules = rules - , md_anns = anns - , md_exports = exports - , md_complete_sigs = complete_sigs - } - } - -{- -************************************************************************ -* * - Typechecking for merging -* * -************************************************************************ --} - --- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) -isAbstractIfaceDecl :: IfaceDecl -> Bool -isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True -isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True -isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True -isAbstractIfaceDecl _ = False - -ifMaybeRoles :: IfaceDecl -> Maybe [Role] -ifMaybeRoles IfaceData { ifRoles = rs } = Just rs -ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs -ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs -ifMaybeRoles _ = Nothing - --- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If --- both are non-abstract we pick one arbitrarily (and check for consistency --- later.) -mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl -mergeIfaceDecl d1 d2 - | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1 - | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2 - | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1 - , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2 - = let ops = nameEnvElts $ - plusNameEnv_C mergeIfaceClassOp - (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ]) - (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) - in d1 { ifBody = (ifBody d1) { - ifSigs = ops, - ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2] - } - } `withRolesFrom` d2 - -- It doesn't matter; we'll check for consistency later when - -- we merge, see 'mergeSignatures' - | otherwise = d1 `withRolesFrom` d2 - --- Note [Role merging] --- ~~~~~~~~~~~~~~~~~~~ --- First, why might it be necessary to do a non-trivial role --- merge? It may rescue a merge that might otherwise fail: --- --- signature A where --- type role T nominal representational --- data T a b --- --- signature A where --- type role T representational nominal --- data T a b --- --- A module that defines T as representational in both arguments --- would successfully fill both signatures, so it would be better --- if we merged the roles of these types in some nontrivial --- way. --- --- However, we have to be very careful about how we go about --- doing this, because role subtyping is *conditional* on --- the supertype being NOT representationally injective, e.g., --- if we have instead: --- --- signature A where --- type role T nominal representational --- data T a b = T a b --- --- signature A where --- type role T representational nominal --- data T a b = T a b --- --- Should we merge the definitions of T so that the roles are R/R (or N/N)? --- Absolutely not: neither resulting type is a subtype of the original --- types (see Note [Role subtyping]), because data is not representationally --- injective. --- --- Thus, merging only occurs when BOTH TyCons in question are --- representationally injective. If they're not, no merge. - -withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl -d1 `withRolesFrom` d2 - | Just roles1 <- ifMaybeRoles d1 - , Just roles2 <- ifMaybeRoles d2 - , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2) - = d1 { ifRoles = mergeRoles roles1 roles2 } - | otherwise = d1 - where - mergeRoles roles1 roles2 = zipWith max roles1 roles2 - -isRepInjectiveIfaceDecl :: IfaceDecl -> Bool -isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True -isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True -isRepInjectiveIfaceDecl _ = False - -mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp -mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1 -mergeIfaceClassOp _ op2 = op2 - --- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'. -mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl -mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl - --- | This is a very interesting function. Like typecheckIface, we want --- to type check an interface file into a ModDetails. However, the use-case --- for these ModDetails is different: we want to compare all of the --- ModDetails to ensure they define compatible declarations, and then --- merge them together. So in particular, we have to take a different --- strategy for knot-tying: we first speculatively merge the declarations --- to get the "base" truth for what we believe the types will be --- (this is "type computation.") Then we read everything in relative --- to this truth and check for compatibility. --- --- During the merge process, we may need to nondeterministically --- pick a particular declaration to use, if multiple signatures define --- the declaration ('mergeIfaceDecl'). If, for all choices, there --- are no type synonym cycles in the resulting merged graph, then --- we can show that our choice cannot matter. Consider the --- set of entities which the declarations depend on: by assumption --- of acyclicity, we can assume that these have already been shown to be equal --- to each other (otherwise merging will fail). Then it must --- be the case that all candidate declarations here are type-equal --- (the choice doesn't matter) or there is an inequality (in which --- case merging will fail.) --- --- Unfortunately, the choice can matter if there is a cycle. Consider the --- following merge: --- --- signature H where { type A = C; type B = A; data C } --- signature H where { type A = (); data B; type C = B } --- --- If we pick @type A = C@ as our representative, there will be --- a cycle and merging will fail. But if we pick @type A = ()@ as --- our representative, no cycle occurs, and we instead conclude --- that all of the types are unit. So it seems that we either --- (a) need a stronger acyclicity check which considers *all* --- possible choices from a merge, or (b) we must find a selection --- of declarations which is acyclic, and show that this is always --- the "best" choice we could have made (ezyang conjectures this --- is the case but does not have a proof). For now this is --- not implemented. --- --- It's worth noting that at the moment, a data constructor and a --- type synonym are never compatible. Consider: --- --- signature H where { type Int=C; type B = Int; data C = Int} --- signature H where { export Prelude.Int; data B; type C = B; } --- --- This will be rejected, because the reexported Int in the second --- signature (a proper data type) is never considered equal to a --- type synonym. Perhaps this should be relaxed, where a type synonym --- in a signature is considered implemented by a data type declaration --- which matches the reference of the type synonym. -typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails]) -typecheckIfacesForMerging mod ifaces tc_env_var = - -- cannot be boot (False) - initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do - ignore_prags <- goptM Opt_IgnoreInterfacePragmas - -- Build the initial environment - -- NB: Don't include dfuns here, because we don't want to - -- serialize them out. See Note [rnIfaceNeverExported] in RnModIface - -- NB: But coercions are OK, because they will have the right OccName. - let mk_decl_env decls - = mkOccEnv [ (getOccName decl, decl) - | decl <- decls - , case decl of - IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns - _ -> True ] - decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces - :: [OccEnv IfaceDecl] - decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs - :: OccEnv IfaceDecl - -- TODO: change loadDecls to accept w/o Fingerprint - names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x)) - (occEnvElts decl_env)) - let global_type_env = mkNameEnv names_w_things - writeMutVar tc_env_var global_type_env - - -- OK, now typecheck each ModIface using this environment - details <- forM ifaces $ \iface -> do - -- See Note [Resolving never-exported Names in TcIface] - type_env <- fixM $ \type_env -> do - setImplicitEnvM type_env $ do - decls <- loadDecls ignore_prags (mi_decls iface) - return (mkNameEnv decls) - -- But note that we use this type_env to typecheck references to DFun - -- in 'IfaceInst' - setImplicitEnvM type_env $ do - insts <- mapM tcIfaceInst (mi_insts iface) - fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - rules <- tcIfaceRules ignore_prags (mi_rules iface) - anns <- tcIfaceAnnotations (mi_anns iface) - exports <- ifaceExportNames (mi_exports iface) - complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - return $ ModDetails { md_types = type_env - , md_insts = insts - , md_fam_insts = fam_insts - , md_rules = rules - , md_anns = anns - , md_exports = exports - , md_complete_sigs = complete_sigs - } - return (global_type_env, details) - --- | Typecheck a signature 'ModIface' under the assumption that we have --- instantiated it under some implementation (recorded in 'mi_semantic_module') --- and want to check if the implementation fills the signature. --- --- This needs to operate slightly differently than 'typecheckIface' --- because (1) we have a 'NameShape', from the exports of the --- implementing module, which we will use to give our top-level --- declarations the correct 'Name's even when the implementor --- provided them with a reexport, and (2) we have to deal with --- DFun silliness (see Note [rnIfaceNeverExported]) -typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails -typecheckIfaceForInstantiate nsubst iface = - initIfaceLclWithSubst (mi_semantic_module iface) - (text "typecheckIfaceForInstantiate") - (mi_boot iface) nsubst $ do - ignore_prags <- goptM Opt_IgnoreInterfacePragmas - -- See Note [Resolving never-exported Names in TcIface] - type_env <- fixM $ \type_env -> do - setImplicitEnvM type_env $ do - decls <- loadDecls ignore_prags (mi_decls iface) - return (mkNameEnv decls) - -- See Note [rnIfaceNeverExported] - setImplicitEnvM type_env $ do - insts <- mapM tcIfaceInst (mi_insts iface) - fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) - rules <- tcIfaceRules ignore_prags (mi_rules iface) - anns <- tcIfaceAnnotations (mi_anns iface) - exports <- ifaceExportNames (mi_exports iface) - complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - return $ ModDetails { md_types = type_env - , md_insts = insts - , md_fam_insts = fam_insts - , md_rules = rules - , md_anns = anns - , md_exports = exports - , md_complete_sigs = complete_sigs - } - --- Note [Resolving never-exported Names in TcIface] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- For the high-level overview, see --- Note [Handling never-exported TyThings under Backpack] --- --- As described in 'typecheckIfacesForMerging', the splendid innovation --- of signature merging is to rewrite all Names in each of the signatures --- we are merging together to a pre-merged structure; this is the key --- ingredient that lets us solve some problems when merging type --- synonyms. --- --- However, when a 'Name' refers to a NON-exported entity, as is the --- case with the DFun of a ClsInst, or a CoAxiom of a type family, --- this strategy causes problems: if we pick one and rewrite all --- references to a shared 'Name', we will accidentally fail to check --- if the DFun or CoAxioms are compatible, as they will never be --- checked--only exported entities are checked for compatibility, --- and a non-exported TyThing is checked WHEN we are checking the --- ClsInst or type family for compatibility in checkBootDeclM. --- By virtue of the fact that everything's been pointed to the merged --- declaration, you'll never notice there's a difference even if there --- is one. --- --- Fortunately, there are only a few places in the interface declarations --- where this can occur, so we replace those calls with 'tcIfaceImplicit', --- which will consult a local TypeEnv that records any never-exported --- TyThings which we should wire up with. --- --- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a --- type family can refer to a coercion axiom, all of which are done in one go --- when we typecheck 'mi_decls'. An alternate strategy would be to typecheck --- coercions first before type families, but that seemed more fragile. --- - -{- -************************************************************************ -* * - Type and class declarations -* * -************************************************************************ --} - -tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo --- Load the hi-boot iface for the module being compiled, --- if it indeed exists in the transitive closure of imports --- Return the ModDetails; Nothing if no hi-boot iface -tcHiBootIface hsc_src mod - | HsBootFile <- hsc_src -- Already compiling a hs-boot file - = return NoSelfBoot - | otherwise - = do { traceIf (text "loadHiBootInterface" <+> ppr mod) - - ; mode <- getGhcMode - ; if not (isOneShot mode) - -- In --make and interactive mode, if this module has an hs-boot file - -- we'll have compiled it already, and it'll be in the HPT - -- - -- We check wheher the interface is a *boot* interface. - -- It can happen (when using GHC from Visual Studio) that we - -- compile a module in TypecheckOnly mode, with a stable, - -- fully-populated HPT. In that case the boot interface isn't there - -- (it's been replaced by the mother module) so we can't check it. - -- And that's fine, because if M's ModInfo is in the HPT, then - -- it's been compiled once, and we don't need to check the boot iface - then do { hpt <- getHpt - ; case lookupHpt hpt (moduleName mod) of - Just info | mi_boot (hm_iface info) - -> mkSelfBootInfo (hm_iface info) (hm_details info) - _ -> return NoSelfBoot } - else do - - -- OK, so we're in one-shot mode. - -- Re #9245, we always check if there is an hi-boot interface - -- to check consistency against, rather than just when we notice - -- that an hi-boot is necessary due to a circular import. - { read_result <- findAndReadIface - need (fst (splitModuleInsts mod)) mod - True -- Hi-boot file - - ; case read_result of { - Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface - ; mkSelfBootInfo iface tc_iface } ; - Failed err -> - - -- There was no hi-boot file. But if there is circularity in - -- the module graph, there really should have been one. - -- Since we've read all the direct imports by now, - -- eps_is_boot will record if any of our imports mention the - -- current module, which either means a module loop (not - -- a SOURCE import) or that our hi-boot file has mysteriously - -- disappeared. - do { eps <- getEps - ; case lookupUFM (eps_is_boot eps) (moduleName mod) of - Nothing -> return NoSelfBoot -- The typical case - - Just (_, False) -> failWithTc moduleLoop - -- Someone below us imported us! - -- This is a loop with no hi-boot in the way - - Just (_mod, True) -> failWithTc (elaborate err) - -- The hi-boot file has mysteriously disappeared. - }}}} - where - need = text "Need the hi-boot interface for" <+> ppr mod - <+> text "to compare against the Real Thing" - - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - elaborate err = hang (text "Could not find hi-boot interface for" <+> - quotes (ppr mod) <> colon) 4 err - - -mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo -mkSelfBootInfo iface mds - = do -- NB: This is computed DIRECTLY from the ModIface rather - -- than from the ModDetails, so that we can query 'sb_tcs' - -- WITHOUT forcing the contents of the interface. - let tcs = map ifName - . filter isIfaceTyCon - . map snd - $ mi_decls iface - return $ SelfBoot { sb_mds = mds - , sb_tcs = mkNameSet tcs } - where - -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on - -- this 'IfaceDecl', an ATyCon would be returned. - -- NB: This code assumes that a TyCon cannot be implicit. - isIfaceTyCon IfaceId{} = False - isIfaceTyCon IfaceData{} = True - isIfaceTyCon IfaceSynonym{} = True - isIfaceTyCon IfaceFamily{} = True - isIfaceTyCon IfaceClass{} = True - isIfaceTyCon IfaceAxiom{} = False - isIfaceTyCon IfacePatSyn{} = False - -{- -************************************************************************ -* * - Type and class declarations -* * -************************************************************************ - -When typechecking a data type decl, we *lazily* (via forkM) typecheck -the constructor argument types. This is in the hope that we may never -poke on those argument types, and hence may never need to load the -interface files for types mentioned in the arg types. - -E.g. - data Foo.S = MkS Baz.T -Maybe we can get away without even loading the interface for Baz! - -This is not just a performance thing. Suppose we have - data Foo.S = MkS Baz.T - data Baz.T = MkT Foo.S -(in different interface files, of course). -Now, first we load and typecheck Foo.S, and add it to the type envt. -If we do explore MkS's argument, we'll load and typecheck Baz.T. -If we explore MkT's argument we'll find Foo.S already in the envt. - -If we typechecked constructor args eagerly, when loading Foo.S we'd try to -typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S... -which isn't done yet. - -All very cunning. However, there is a rather subtle gotcha which bit -me when developing this stuff. When we typecheck the decl for S, we -extend the type envt with S, MkS, and all its implicit Ids. Suppose -(a bug, but it happened) that the list of implicit Ids depended in -turn on the constructor arg types. Then the following sequence of -events takes place: - * we build a thunk for the constructor arg tys - * we build a thunk for the extended type environment (depends on ) - * we write the extended type envt into the global EPS mutvar - -Now we look something up in the type envt - * that pulls on - * which reads the global type envt out of the global EPS mutvar - * but that depends in turn on - -It's subtle, because, it'd work fine if we typechecked the constructor args -eagerly -- they don't need the extended type envt. They just get the extended -type envt by accident, because they look at it later. - -What this means is that the implicitTyThings MUST NOT DEPEND on any of -the forkM stuff. --} - -tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings - -> IfaceDecl - -> IfL TyThing -tcIfaceDecl = tc_iface_decl Nothing - -tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations - -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings - -> IfaceDecl - -> IfL TyThing -tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, - ifIdDetails = details, ifIdInfo = info}) - = do { ty <- tcIfaceType iface_type - ; details <- tcIdDetails ty details - ; info <- tcIdInfo ignore_prags TopLevel name ty info - ; return (AnId (mkGlobalId details name ty info)) } - -tc_iface_decl _ _ (IfaceData {ifName = tc_name, - ifCType = cType, - ifBinders = binders, - ifResKind = res_kind, - ifRoles = roles, - ifCtxt = ctxt, ifGadtSyntax = gadt_syn, - ifCons = rdr_cons, - ifParent = mb_parent }) - = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { res_kind' <- tcIfaceType res_kind - - ; tycon <- fixM $ \ tycon -> do - { stupid_theta <- tcIfaceCtxt ctxt - ; parent' <- tc_parent tc_name mb_parent - ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons - ; return (mkAlgTyCon tc_name binders' res_kind' - roles cType stupid_theta - cons parent' gadt_syn) } - ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) - ; return (ATyCon tycon) } - where - tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav - tc_parent tc_name IfNoParent - = do { tc_rep_name <- newTyConRepName tc_name - ; return (VanillaAlgTyCon tc_rep_name) } - tc_parent _ (IfDataInstance ax_name _ arg_tys) - = do { ax <- tcIfaceCoAxiom ax_name - ; let fam_tc = coAxiomTyCon ax - ax_unbr = toUnbranchedAxiom ax - ; lhs_tys <- tcIfaceAppArgs arg_tys - ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) } - -tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name, - ifRoles = roles, - ifSynRhs = rhs_ty, - ifBinders = binders, - ifResKind = res_kind }) - = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] - ; rhs <- forkM (mk_doc tc_name) $ - tcIfaceType rhs_ty - ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs - ; return (ATyCon tycon) } - where - mk_doc n = text "Type synonym" <+> ppr n - -tc_iface_decl parent _ (IfaceFamily {ifName = tc_name, - ifFamFlav = fam_flav, - ifBinders = binders, - ifResKind = res_kind, - ifResVar = res, ifFamInj = inj }) - = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] - ; rhs <- forkM (mk_doc tc_name) $ - tc_fam_flav tc_name fam_flav - ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res - ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj - ; return (ATyCon tycon) } - where - mk_doc n = text "Type synonym" <+> ppr n - - tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav - tc_fam_flav tc_name IfaceDataFamilyTyCon - = do { tc_rep_name <- newTyConRepName tc_name - ; return (DataFamilyTyCon tc_rep_name) } - tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon - tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches) - = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches - ; return (ClosedSynFamilyTyCon ax) } - tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon - = return AbstractClosedSynFamilyTyCon - tc_fam_flav _ IfaceBuiltInSynFamTyCon - = pprPanic "tc_iface_decl" - (text "IfaceBuiltInSynFamTyCon in interface file") - -tc_iface_decl _parent _ignore_prags - (IfaceClass {ifName = tc_name, - ifRoles = roles, - ifBinders = binders, - ifFDs = rdr_fds, - ifBody = IfAbstractClass}) - = bindIfaceTyConBinders binders $ \ binders' -> do - { fds <- mapM tc_fd rdr_fds - ; cls <- buildClass tc_name binders' roles fds Nothing - ; return (ATyCon (classTyCon cls)) } - -tc_iface_decl _parent ignore_prags - (IfaceClass {ifName = tc_name, - ifRoles = roles, - ifBinders = binders, - ifFDs = rdr_fds, - ifBody = IfConcreteClass { - ifClassCtxt = rdr_ctxt, - ifATs = rdr_ats, ifSigs = rdr_sigs, - ifMinDef = mindef_occ - }}) - = bindIfaceTyConBinders binders $ \ binders' -> do - { traceIf (text "tc-iface-class1" <+> ppr tc_name) - ; ctxt <- mapM tc_sc rdr_ctxt - ; traceIf (text "tc-iface-class2" <+> ppr tc_name) - ; sigs <- mapM tc_sig rdr_sigs - ; fds <- mapM tc_fd rdr_fds - ; traceIf (text "tc-iface-class3" <+> ppr tc_name) - ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ - ; cls <- fixM $ \ cls -> do - { ats <- mapM (tc_at cls) rdr_ats - ; traceIf (text "tc-iface-class4" <+> ppr tc_name) - ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) } - ; return (ATyCon (classTyCon cls)) } - where - tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) - -- The *length* of the superclasses is used by buildClass, and hence must - -- not be inside the thunk. But the *content* maybe recursive and hence - -- must be lazy (via forkM). Example: - -- class C (T a) => D a where - -- data T a - -- Here the associated type T is knot-tied with the class, and - -- so we must not pull on T too eagerly. See #5970 - - tc_sig :: IfaceClassOp -> IfL TcMethInfo - tc_sig (IfaceClassOp op_name rdr_ty dm) - = do { let doc = mk_op_doc op_name rdr_ty - ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty - -- Must be done lazily for just the same reason as the - -- type of a data con; to avoid sucking in types that - -- it mentions unless it's necessary to do so - ; dm' <- tc_dm doc dm - ; return (op_name, op_ty, dm') } - - tc_dm :: SDoc - -> Maybe (DefMethSpec IfaceType) - -> IfL (Maybe (DefMethSpec (SrcSpan, Type))) - tc_dm _ Nothing = return Nothing - tc_dm _ (Just VanillaDM) = return (Just VanillaDM) - tc_dm doc (Just (GenericDM ty)) - = do { -- Must be done lazily to avoid sucking in types - ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty - ; return (Just (GenericDM (noSrcSpan, ty'))) } - - tc_at cls (IfaceAT tc_decl if_def) - = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl - mb_def <- case if_def of - Nothing -> return Nothing - Just def -> forkM (mk_at_doc tc) $ - extendIfaceTyVarEnv (tyConTyVars tc) $ - do { tc_def <- tcIfaceType def - ; return (Just (tc_def, noSrcSpan)) } - -- Must be done lazily in case the RHS of the defaults mention - -- the type constructor being defined here - -- e.g. type AT a; type AT b = AT [b] #8002 - return (ATI tc mb_def) - - mk_sc_doc pred = text "Superclass" <+> ppr pred - mk_at_doc tc = text "Associated type" <+> ppr tc - mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] - -tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc - , ifAxBranches = branches, ifRole = role }) - = do { tc_tycon <- tcIfaceTyCon tc - -- Must be done lazily, because axioms are forced when checking - -- for family instance consistency, and the RHS may mention - -- a hs-boot declared type constructor that is going to be - -- defined by this module. - -- e.g. type instance F Int = ToBeDefined - -- See #13803 - ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name) - $ tc_ax_branches branches - ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name - , co_ax_name = tc_name - , co_ax_tc = tc_tycon - , co_ax_role = role - , co_ax_branches = manyBranches tc_branches - , co_ax_implicit = False } - ; return (ACoAxiom axiom) } - -tc_iface_decl _ _ (IfacePatSyn{ ifName = name - , ifPatMatcher = if_matcher - , ifPatBuilder = if_builder - , ifPatIsInfix = is_infix - , ifPatUnivBndrs = univ_bndrs - , ifPatExBndrs = ex_bndrs - , ifPatProvCtxt = prov_ctxt - , ifPatReqCtxt = req_ctxt - , ifPatArgs = args - , ifPatTy = pat_ty - , ifFieldLabels = field_labels }) - = do { traceIf (text "tc_iface_decl" <+> ppr name) - ; matcher <- tc_pr if_matcher - ; builder <- fmapMaybeM tc_pr if_builder - ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do - { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do - { patsyn <- forkM (mk_doc name) $ - do { prov_theta <- tcIfaceCtxt prov_ctxt - ; req_theta <- tcIfaceCtxt req_ctxt - ; pat_ty <- tcIfaceType pat_ty - ; arg_tys <- mapM tcIfaceType args - ; return $ buildPatSyn name is_infix matcher builder - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - arg_tys pat_ty field_labels } - ; return $ AConLike . PatSynCon $ patsyn }}} - where - mk_doc n = text "Pattern synonym" <+> ppr n - tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) - tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) - ; return (id, b) } - -tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar) -tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 - ; tvs2' <- mapM tcIfaceTyVar tvs2 - ; return (tvs1', tvs2') } - -tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] -tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches - -tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] -tc_ax_branch prev_branches - (IfaceAxBranch { ifaxbTyVars = tv_bndrs - , ifaxbEtaTyVars = eta_tv_bndrs - , ifaxbCoVars = cv_bndrs - , ifaxbLHS = lhs, ifaxbRHS = rhs - , ifaxbRoles = roles, ifaxbIncomps = incomps }) - = bindIfaceTyConBinders_AT - (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> - -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom - bindIfaceIds cv_bndrs $ \ cvs -> do - { tc_lhs <- tcIfaceAppArgs lhs - ; tc_rhs <- tcIfaceType rhs - ; eta_tvs <- bindIfaceTyVars eta_tv_bndrs return - ; this_mod <- getIfModule - ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS` - moduleNameFS (moduleName this_mod)) - br = CoAxBranch { cab_loc = loc - , cab_tvs = binderVars tvs - , cab_eta_tvs = eta_tvs - , cab_cvs = cvs - , cab_lhs = tc_lhs - , cab_roles = roles - , cab_rhs = tc_rhs - , cab_incomps = map (prev_branches `getNth`) incomps } - ; return (prev_branches ++ [br]) } - -tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs -tcIfaceDataCons tycon_name tycon tc_tybinders if_cons - = case if_cons of - IfAbstractTyCon -> return AbstractTyCon - IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons - ; return (mkDataTyConRhs data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; mkNewTyConRhs tycon_name tycon data_con } - where - univ_tvs :: [TyVar] - univ_tvs = binderVars (tyConTyVarBinders tc_tybinders) - - tag_map :: NameEnv ConTag - tag_map = mkTyConTagMap tycon - - tc_con_decl (IfCon { ifConInfix = is_infix, - ifConExTCvs = ex_bndrs, - ifConUserTvBinders = user_bndrs, - ifConName = dc_name, - ifConCtxt = ctxt, ifConEqSpec = spec, - ifConArgTys = args, ifConFields = lbl_names, - ifConStricts = if_stricts, - ifConSrcStricts = if_src_stricts}) - = -- Universally-quantified tyvars are shared with - -- parent TyCon, and are already in scope - bindIfaceBndrs ex_bndrs $ \ ex_tvs -> do - { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name) - - -- By this point, we have bound every universal and existential - -- tyvar. Because of the dcUserTyVarBinders invariant - -- (see Note [DataCon user type variable binders]), *every* tyvar in - -- ifConUserTvBinders has a matching counterpart somewhere in the - -- bound universals/existentials. As a result, calling tcIfaceTyVar - -- below is always guaranteed to succeed. - ; user_tv_bndrs <- mapM (\(Bndr bd vis) -> - case bd of - IfaceIdBndr (name, _) -> - Bndr <$> tcIfaceLclId name <*> pure vis - IfaceTvBndr (name, _) -> - Bndr <$> tcIfaceTyVar name <*> pure vis) - user_bndrs - - -- Read the context and argument types, but lazily for two reasons - -- (a) to avoid looking tugging on a recursive use of - -- the type itself, which is knot-tied - -- (b) to avoid faulting in the component types unless - -- they are really needed - ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $ - do { eq_spec <- tcIfaceEqSpec spec - ; theta <- tcIfaceCtxt ctxt - -- This fixes #13710. The enclosing lazy thunk gets - -- forced when typechecking record wildcard pattern - -- matching (it's not completely clear why this - -- tuple is needed), which causes trouble if one of - -- the argument types was recursively defined. - -- See also Note [Tying the knot] - ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys") - $ mapM tcIfaceType args - ; stricts <- mapM tc_strict if_stricts - -- The IfBang field can mention - -- the type itself; hence inside forkM - ; return (eq_spec, theta, arg_tys, stricts) } - - -- Remember, tycon is the representation tycon - ; let orig_res_ty = mkFamilyTyConApp tycon - (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec)) - (binderVars tc_tybinders)) - - ; prom_rep_name <- newTyConRepName dc_name - - ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) - dc_name is_infix prom_rep_name - (map src_strict if_src_stricts) - (Just stricts) - -- Pass the HsImplBangs (i.e. final - -- decisions) to buildDataCon; it'll use - -- these to guide the construction of a - -- worker. - -- See Note [Bangs on imported data constructors] in MkId - lbl_names - univ_tvs ex_tvs user_tv_bndrs - eq_spec theta - arg_tys orig_res_ty tycon tag_map - ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) - ; return con } - mk_doc con_name = text "Constructor" <+> ppr con_name - - tc_strict :: IfaceBang -> IfL HsImplBang - tc_strict IfNoBang = return (HsLazy) - tc_strict IfStrict = return (HsStrict) - tc_strict IfUnpack = return (HsUnpack Nothing) - tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co - ; return (HsUnpack (Just co)) } - - src_strict :: IfaceSrcBang -> HsSrcBang - src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang - -tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] -tcIfaceEqSpec spec - = mapM do_item spec - where - do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ - ; ty <- tcIfaceType if_ty - ; return (mkEqSpec tv ty) } - -{- -Note [Synonym kind loop] -~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we eagerly grab the *kind* from the interface file, but -build a forkM thunk for the *rhs* (and family stuff). To see why, -consider this (#2412) - -M.hs: module M where { import X; data T = MkT S } -X.hs: module X where { import {-# SOURCE #-} M; type S = T } -M.hs-boot: module M where { data T } - -When kind-checking M.hs we need S's kind. But we do not want to -find S's kind from (typeKind S-rhs), because we don't want to look at -S-rhs yet! Since S is imported from X.hi, S gets just one chance to -be defined, and we must not do that until we've finished with M.T. - -Solution: record S's kind in the interface file; now we can safely -look at it. - -************************************************************************ -* * - Instances -* * -************************************************************************ --} - -tcIfaceInst :: IfaceClsInst -> IfL ClsInst -tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag - , ifInstCls = cls, ifInstTys = mb_tcs - , ifInstOrph = orph }) - = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ - fmap tyThingId (tcIfaceImplicit dfun_name) - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } - -tcIfaceFamInst :: IfaceFamInst -> IfL FamInst -tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs - , ifFamInstAxiom = axiom_name } ) - = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $ - tcIfaceCoAxiom axiom_name - -- will panic if branched, but that's OK - ; let axiom'' = toUnbranchedAxiom axiom' - mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedFamInst fam mb_tcs' axiom'') } - -{- -************************************************************************ -* * - Rules -* * -************************************************************************ - -We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars -are in the type environment. However, remember that typechecking a Rule may -(as a side effect) augment the type envt, and so we may need to iterate the process. --} - -tcIfaceRules :: Bool -- True <=> ignore rules - -> [IfaceRule] - -> IfL [CoreRule] -tcIfaceRules ignore_prags if_rules - | ignore_prags = return [] - | otherwise = mapM tcIfaceRule if_rules - -tcIfaceRule :: IfaceRule -> IfL CoreRule -tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, - ifRuleAuto = auto, ifRuleOrph = orph }) - = do { ~(bndrs', args', rhs') <- - -- Typecheck the payload lazily, in the hope it'll never be looked at - forkM (text "Rule" <+> pprRuleName name) $ - bindIfaceBndrs bndrs $ \ bndrs' -> - do { args' <- mapM tcIfaceExpr args - ; rhs' <- tcIfaceExpr rhs - ; return (bndrs', args', rhs') } - ; let mb_tcs = map ifTopFreeName args - ; this_mod <- getIfModule - ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, - ru_bndrs = bndrs', ru_args = args', - ru_rhs = occurAnalyseExpr rhs', - ru_rough = mb_tcs, - ru_origin = this_mod, - ru_orphan = orph, - ru_auto = auto, - ru_local = False }) } -- An imported RULE is never for a local Id - -- or, even if it is (module loop, perhaps) - -- we'll just leave it in the non-local set - where - -- This function *must* mirror exactly what Rules.roughTopNames does - -- We could have stored the ru_rough field in the iface file - -- but that would be redundant, I think. - -- The only wrinkle is that we must not be deceived by - -- type synonyms at the top of a type arg. Since - -- we can't tell at this point, we are careful not - -- to write them out in coreRuleToIfaceRule - ifTopFreeName :: IfaceExpr -> Maybe Name - ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) - ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts))) - ifTopFreeName (IfaceApp f _) = ifTopFreeName f - ifTopFreeName (IfaceExt n) = Just n - ifTopFreeName _ = Nothing - -{- -************************************************************************ -* * - Annotations -* * -************************************************************************ --} - -tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] -tcIfaceAnnotations = mapM tcIfaceAnnotation - -tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation -tcIfaceAnnotation (IfaceAnnotation target serialized) = do - target' <- tcIfaceAnnTarget target - return $ Annotation { - ann_target = target', - ann_value = serialized - } - -tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) -tcIfaceAnnTarget (NamedTarget occ) = do - name <- lookupIfaceTop occ - return $ NamedTarget name -tcIfaceAnnTarget (ModuleTarget mod) = do - return $ ModuleTarget mod - -{- -************************************************************************ -* * - Complete Match Pragmas -* * -************************************************************************ --} - -tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] -tcIfaceCompleteSigs = mapM tcIfaceCompleteSig - -tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch -tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t) - -{- -************************************************************************ -* * - Types -* * -************************************************************************ --} - -tcIfaceType :: IfaceType -> IfL Type -tcIfaceType = go - where - go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n - go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n) - go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l - go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2 - go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks - go (IfaceAppTy t ts) - = do { t' <- go t - ; ts' <- traverse go (appArgsIfaceTypes ts) - ; pure (foldl' AppTy t' ts') } - go (IfaceTyConApp tc tks) - = do { tc' <- tcIfaceTyCon tc - ; tks' <- mapM go (appArgsIfaceTypes tks) - ; return (mkTyConApp tc' tks') } - go (IfaceForAllTy bndr t) - = bindIfaceForAllBndr bndr $ \ tv' vis -> - ForAllTy (Bndr tv' vis) <$> go t - go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co - go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co - -tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type -tcIfaceTupleTy sort is_promoted args - = do { args' <- tcIfaceAppArgs args - ; let arity = length args' - ; base_tc <- tcTupleTyCon True sort arity - ; case is_promoted of - NotPromoted - -> return (mkTyConApp base_tc args') - - IsPromoted - -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) - kind_args = map typeKind args' - ; return (mkTyConApp tc (kind_args ++ args')) } } - --- See Note [Unboxed tuple RuntimeRep vars] in TyCon -tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) - -> TupleSort - -> Arity -- the number of args. *not* the tuple arity. - -> IfL TyCon -tcTupleTyCon in_type sort arity - = case sort of - ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity) - ; return (tyThingTyCon thing) } - BoxedTuple -> return (tupleTyCon Boxed arity) - UnboxedTuple -> return (tupleTyCon Unboxed arity') - where arity' | in_type = arity `div` 2 - | otherwise = arity - -- in expressions, we only have term args - -tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type] -tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes - ------------------------------------------ -tcIfaceCtxt :: IfaceContext -> IfL ThetaType -tcIfaceCtxt sts = mapM tcIfaceType sts - ------------------------------------------ -tcIfaceTyLit :: IfaceTyLit -> IfL TyLit -tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) -tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) - -{- -%************************************************************************ -%* * - Coercions -* * -************************************************************************ --} - -tcIfaceCo :: IfaceCoercion -> IfL Coercion -tcIfaceCo = go - where - go_mco IfaceMRefl = pure MRefl - go_mco (IfaceMCo co) = MCo <$> (go co) - - go (IfaceReflCo t) = Refl <$> tcIfaceType t - go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco - go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 - go (IfaceTyConAppCo r tc cs) - = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs - go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 - go (IfaceForAllCo tv k c) = do { k' <- go k - ; bindIfaceBndr tv $ \ tv' -> - ForAllCo tv' k' <$> go c } - go (IfaceCoVarCo n) = CoVarCo <$> go_var n - go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs - go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r - <*> tcIfaceType t1 <*> tcIfaceType t2 - go (IfaceSymCo c) = SymCo <$> go c - go (IfaceTransCo c1 c2) = TransCo <$> go c1 - <*> go c2 - go (IfaceInstCo c1 t2) = InstCo <$> go c1 - <*> go t2 - go (IfaceNthCo d c) = do { c' <- go c - ; return $ mkNthCo (nthCoRole d c') d c' } - go (IfaceLRCo lr c) = LRCo lr <$> go c - go (IfaceKindCo c) = KindCo <$> go c - go (IfaceSubCo c) = SubCo <$> go c - go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax - <*> mapM go cos - go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c) - go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c) - - go_var :: FastString -> IfL CoVar - go_var = tcIfaceLclId - -tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance -tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv -tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco -tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco -tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str - -{- -************************************************************************ -* * - Core -* * -************************************************************************ --} - -tcIfaceExpr :: IfaceExpr -> IfL CoreExpr -tcIfaceExpr (IfaceType ty) - = Type <$> tcIfaceType ty - -tcIfaceExpr (IfaceCo co) - = Coercion <$> tcIfaceCo co - -tcIfaceExpr (IfaceCast expr co) - = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co - -tcIfaceExpr (IfaceLcl name) - = Var <$> tcIfaceLclId name - -tcIfaceExpr (IfaceExt gbl) - = Var <$> tcIfaceExtId gbl - -tcIfaceExpr (IfaceLit lit) - = do lit' <- tcIfaceLit lit - return (Lit lit') - -tcIfaceExpr (IfaceFCall cc ty) = do - ty' <- tcIfaceType ty - u <- newUnique - dflags <- getDynFlags - return (Var (mkFCallId dflags u cc ty')) - -tcIfaceExpr (IfaceTuple sort args) - = do { args' <- mapM tcIfaceExpr args - ; tc <- tcTupleTyCon False sort arity - ; let con_tys = map exprType args' - some_con_args = map Type con_tys ++ args' - con_args = case sort of - UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args - _ -> some_con_args - -- Put the missing type arguments back in - con_id = dataConWorkId (tyConSingleDataCon tc) - ; return (mkApps (Var con_id) con_args) } - where - arity = length args - -tcIfaceExpr (IfaceLam (bndr, os) body) - = bindIfaceBndr bndr $ \bndr' -> - Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body - where - tcIfaceOneShot IfaceOneShot b = setOneShotLambda b - tcIfaceOneShot _ b = b - -tcIfaceExpr (IfaceApp fun arg) - = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg - -tcIfaceExpr (IfaceECase scrut ty) - = do { scrut' <- tcIfaceExpr scrut - ; ty' <- tcIfaceType ty - ; return (castBottomExpr scrut' ty') } - -tcIfaceExpr (IfaceCase scrut case_bndr alts) = do - scrut' <- tcIfaceExpr scrut - case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) - let - scrut_ty = exprType scrut' - case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty - tc_app = splitTyConApp scrut_ty - -- NB: Won't always succeed (polymorphic case) - -- but won't be demanded in those cases - -- NB: not tcSplitTyConApp; we are looking at Core here - -- look through non-rec newtypes to find the tycon that - -- corresponds to the datacon in this case alternative - - extendIfaceIdEnv [case_bndr'] $ do - alts' <- mapM (tcIfaceAlt scrut' tc_app) alts - return (Case scrut' case_bndr' (coreAltsType alts') alts') - -tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) - = do { name <- newIfaceName (mkVarOccFS fs) - ; ty' <- tcIfaceType ty - ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} - NotTopLevel name ty' info - ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info - `asJoinId_maybe` tcJoinInfo ji - ; rhs' <- tcIfaceExpr rhs - ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) - ; return (Let (NonRec id rhs') body') } - -tcIfaceExpr (IfaceLet (IfaceRec pairs) body) - = do { ids <- mapM tc_rec_bndr (map fst pairs) - ; extendIfaceIdEnv ids $ do - { pairs' <- zipWithM tc_pair pairs ids - ; body' <- tcIfaceExpr body - ; return (Let (Rec pairs') body') } } - where - tc_rec_bndr (IfLetBndr fs ty _ ji) - = do { name <- newIfaceName (mkVarOccFS fs) - ; ty' <- tcIfaceType ty - ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) } - tc_pair (IfLetBndr _ _ info _, rhs) id - = do { rhs' <- tcIfaceExpr rhs - ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} - NotTopLevel (idName id) (idType id) info - ; return (setIdInfo id id_info, rhs') } - -tcIfaceExpr (IfaceTick tickish expr) = do - expr' <- tcIfaceExpr expr - -- If debug flag is not set: Ignore source notes - dbgLvl <- fmap debugLevel getDynFlags - case tickish of - IfaceSource{} | dbgLvl == 0 - -> return expr' - _otherwise -> do - tickish' <- tcIfaceTickish tickish - return (Tick tickish' expr') - -------------------------- -tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) -tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) -tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) -tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) - -------------------------- -tcIfaceLit :: Literal -> IfL Literal --- Integer literals deserialise to (LitInteger i ) --- so tcIfaceLit just fills in the type. --- See Note [Integer literals] in Literal -tcIfaceLit (LitNumber LitNumInteger i _) - = do t <- tcIfaceTyConByName integerTyConName - return (mkLitInteger i (mkTyConTy t)) --- Natural literals deserialise to (LitNatural i ) --- so tcIfaceLit just fills in the type. --- See Note [Natural literals] in Literal -tcIfaceLit (LitNumber LitNumNatural i _) - = do t <- tcIfaceTyConByName naturalTyConName - return (mkLitNatural i (mkTyConTy t)) -tcIfaceLit lit = return lit - -------------------------- -tcIfaceAlt :: CoreExpr -> (TyCon, [Type]) - -> (IfaceConAlt, [FastString], IfaceExpr) - -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceAlt _ _ (IfaceDefault, names, rhs) - = ASSERT( null names ) do - rhs' <- tcIfaceExpr rhs - return (DEFAULT, [], rhs') - -tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) - = ASSERT( null names ) do - lit' <- tcIfaceLit lit - rhs' <- tcIfaceExpr rhs - return (LitAlt lit', [], rhs') - --- A case alternative is made quite a bit more complicated --- by the fact that we omit type annotations because we can --- work them out. True enough, but its not that easy! -tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) - = do { con <- tcIfaceDataCon data_occ - ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) - (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) - ; tcIfaceDataAlt con inst_tys arg_strs rhs } - -tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr - -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceDataAlt con inst_tys arg_strs rhs - = do { us <- newUniqueSupply - ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, arg_ids) - = dataConRepFSInstPat arg_strs uniqs con inst_tys - - ; rhs' <- extendIfaceEnvs ex_tvs $ - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs - ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } - -{- -************************************************************************ -* * - IdInfo -* * -************************************************************************ --} - -tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) - where - (_, _, cls, _) = tcSplitDFunTy ty - -tcIdDetails _ (IfRecSelId tc naughty) - = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) - (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) - tc - ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } - where - tyThingPatSyn (AConLike (PatSynCon ps)) = ps - tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" - -tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo -tcIdInfo ignore_prags toplvl name ty info = do - lcl_env <- getLclEnv - -- Set the CgInfo to something sensible but uninformative before - -- we start; default assumption is that it has CAFs - let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding - | otherwise = vanillaIdInfo - if ignore_prags - then return init_info - else case info of - NoInfo -> return init_info - HasInfo info -> foldlM tcPrag init_info info - where - tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo - tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = return (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) - tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) - tcPrag info HsLevity = return (info `setNeverLevPoly` ty) - - -- The next two are lazy, so they don't transitively suck stuff in - tcPrag info (HsUnfold lb if_unf) - = do { unf <- tcUnfolding toplvl name ty info if_unf - ; let info1 | lb = info `setOccInfo` strongLoopBreaker - | otherwise = info - ; return (info1 `setUnfoldingInfo` unf) } - -tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity -tcJoinInfo (IfaceJoinPoint ar) = Just ar -tcJoinInfo IfaceNotJoinPoint = Nothing - -tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding -tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) - = do { dflags <- getDynFlags - ; mb_expr <- tcPragExpr toplvl name if_expr - ; let unf_src | stable = InlineStable - | otherwise = InlineRhs - ; return $ case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkUnfolding dflags unf_src - True {- Top level -} - (isBottomingSig strict_sig) - expr - } - where - -- Strictness should occur before unfolding! - strict_sig = strictnessInfo info -tcUnfolding toplvl name _ _ (IfCompulsory if_expr) - = do { mb_expr <- tcPragExpr toplvl name if_expr - ; return (case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkCompulsoryUnfolding expr) } - -tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) - = do { mb_expr <- tcPragExpr toplvl name if_expr - ; return (case mb_expr of - Nothing -> NoUnfolding - Just expr -> mkCoreUnfolding InlineStable True expr guidance )} - where - guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - -tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops) - = bindIfaceBndrs bs $ \ bs' -> - do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops - ; return (case mb_ops1 of - Nothing -> noUnfolding - Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) } - where - doc = text "Class ops for dfun" <+> ppr name - (_, _, cls, _) = tcSplitDFunTy dfun_ty - -{- -For unfoldings we try to do the job lazily, so that we never type check -an unfolding that isn't going to be looked at. --} - -tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr) -tcPragExpr toplvl name expr - = forkM_maybe doc $ do - core_expr' <- tcIfaceExpr expr - - -- Check for type consistency in the unfolding - -- See Note [Linting Unfoldings from Interfaces] - when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do - in_scope <- get_in_scope - dflags <- getDynFlags - case lintUnfolding dflags noSrcLoc in_scope core_expr' of - Nothing -> return () - Just fail_msg -> do { mod <- getIfModule - ; pprPanic "Iface Lint failure" - (vcat [ text "In interface for" <+> ppr mod - , hang doc 2 fail_msg - , ppr name <+> equals <+> ppr core_expr' - , text "Iface expr =" <+> ppr expr ]) } - return core_expr' - where - doc = text "Unfolding of" <+> ppr name - - get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting - get_in_scope - = do { (gbl_env, lcl_env) <- getEnvs - ; rec_ids <- case if_rec_types gbl_env of - Nothing -> return [] - Just (_, get_env) -> do - { type_env <- setLclEnv () get_env - ; return (typeEnvIds type_env) } - ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet` - bindingsVars (if_id_env lcl_env) `unionVarSet` - mkVarSet rec_ids) } - - bindingsVars :: FastStringEnv Var -> VarSet - bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm - -- It's OK to use nonDetEltsUFM here because we immediately forget - -- the ordering by creating a set - -{- -************************************************************************ -* * - Getting from Names to TyThings -* * -************************************************************************ --} - -tcIfaceGlobal :: Name -> IfL TyThing -tcIfaceGlobal name - | Just thing <- wiredInNameTyThing_maybe name - -- Wired-in things include TyCons, DataCons, and Ids - -- Even though we are in an interface file, we want to make - -- sure the instances and RULES of this thing (particularly TyCon) are loaded - -- Imagine: f :: Double -> Double - = do { ifCheckWiredInThing thing; return thing } - - | otherwise - = do { env <- getGblEnv - ; case if_rec_types env of { -- Note [Tying the knot] - Just (mod, get_type_env) - | nameIsLocalOrFrom mod name - -> do -- It's defined in the module being compiled - { type_env <- setLclEnv () get_type_env -- yuk - ; case lookupNameEnv type_env name of - Just thing -> return thing - -- See Note [Knot-tying fallback on boot] - Nothing -> via_external - } - - ; _ -> via_external }} - where - via_external = do - { hsc_env <- getTopEnv - ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) - ; case mb_thing of { - Just thing -> return thing ; - Nothing -> do - - { mb_thing <- importDecl name -- It's imported; go get it - ; case mb_thing of - Failed err -> failIfM err - Succeeded thing -> return thing - }}} - --- Note [Tying the knot] --- ~~~~~~~~~~~~~~~~~~~~~ --- The if_rec_types field is used when we are compiling M.hs, which indirectly --- imports Foo.hi, which mentions M.T Then we look up M.T in M's type --- environment, which is splatted into if_rec_types after we've built M's type --- envt. --- --- This is a dark and complicated part of GHC type checking, with a lot --- of moving parts. Interested readers should also look at: --- --- * Note [Knot-tying typecheckIface] --- * Note [DFun knot-tying] --- * Note [hsc_type_env_var hack] --- * Note [Knot-tying fallback on boot] --- --- There is also a wiki page on the subject, see: --- --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot - --- Note [Knot-tying fallback on boot] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Suppose that you are typechecking A.hs, which transitively imports, --- via B.hs, A.hs-boot. When we poke on B.hs and discover that it --- has a reference to a type T from A, what TyThing should we wire --- it up with? Clearly, if we have already typechecked T and --- added it into the type environment, we should go ahead and use that --- type. But what if we haven't typechecked it yet? --- --- For the longest time, GHC adopted the policy that this was --- *an error condition*; that you MUST NEVER poke on B.hs's reference --- to a T defined in A.hs until A.hs has gotten around to kind-checking --- T and adding it to the env. However, actually ensuring this is the --- case has proven to be a bug farm, because it's really difficult to --- actually ensure this never happens. The problem was especially poignant --- with type family consistency checks, which eagerly happen before any --- typechecking takes place. --- --- Today, we take a different strategy: if we ever try to access --- an entity from A which doesn't exist, we just fall back on the --- definition of A from the hs-boot file. This is complicated in --- its own way: it means that you may end up with a mix of A.hs and --- A.hs-boot TyThings during the course of typechecking. We don't --- think (and have not observed) any cases where this would cause --- problems, but the hypothetical situation one might worry about --- is something along these lines in Core: --- --- case x of --- A -> e1 --- B -> e2 --- --- If, when typechecking this, we find x :: T, and the T we are hooked --- up with is the abstract one from the hs-boot file, rather than the --- one defined in this module with constructors A and B. But it's hard --- to see how this could happen, especially because the reference to --- the constructor (A and B) means that GHC will always typecheck --- this expression *after* typechecking T. - -tcIfaceTyConByName :: IfExtName -> IfL TyCon -tcIfaceTyConByName name - = do { thing <- tcIfaceGlobal name - ; return (tyThingTyCon thing) } - -tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon (IfaceTyCon name info) - = do { thing <- tcIfaceGlobal name - ; return $ case ifaceTyConIsPromoted info of - NotPromoted -> tyThingTyCon thing - IsPromoted -> promoteDataCon $ tyThingDataCon thing } - -tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) -tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name - ; return (tyThingCoAxiom thing) } - - -tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule --- Unlike CoAxioms, which arise form user 'type instance' declarations, --- there are a fixed set of CoAxiomRules, --- currently enumerated in typeNatCoAxiomRules -tcIfaceCoAxiomRule n - = case Map.lookup n typeNatCoAxiomRules of - Just ax -> return ax - _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) - -tcIfaceDataCon :: Name -> IfL DataCon -tcIfaceDataCon name = do { thing <- tcIfaceGlobal name - ; case thing of - AConLike (RealDataCon dc) -> return dc - _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } - -tcIfaceExtId :: Name -> IfL Id -tcIfaceExtId name = do { thing <- tcIfaceGlobal name - ; case thing of - AnId id -> return id - _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } - --- See Note [Resolving never-exported Names in TcIface] -tcIfaceImplicit :: Name -> IfL TyThing -tcIfaceImplicit n = do - lcl_env <- getLclEnv - case if_implicits_env lcl_env of - Nothing -> tcIfaceGlobal n - Just tenv -> - case lookupTypeEnv tenv n of - Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv) - Just tything -> return tything - -{- -************************************************************************ -* * - Bindings -* * -************************************************************************ --} - -bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a -bindIfaceId (fs, ty) thing_inside - = do { name <- newIfaceName (mkVarOccFS fs) - ; ty' <- tcIfaceType ty - ; let id = mkLocalIdOrCoVar name ty' - ; extendIfaceIdEnv [id] (thing_inside id) } - -bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a -bindIfaceIds [] thing_inside = thing_inside [] -bindIfaceIds (b:bs) thing_inside - = bindIfaceId b $ \b' -> - bindIfaceIds bs $ \bs' -> - thing_inside (b':bs') - -bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a -bindIfaceBndr (IfaceIdBndr bndr) thing_inside - = bindIfaceId bndr thing_inside -bindIfaceBndr (IfaceTvBndr bndr) thing_inside - = bindIfaceTyVar bndr thing_inside - -bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a -bindIfaceBndrs [] thing_inside = thing_inside [] -bindIfaceBndrs (b:bs) thing_inside - = bindIfaceBndr b $ \ b' -> - bindIfaceBndrs bs $ \ bs' -> - thing_inside (b':bs') - ------------------------ -bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a -bindIfaceForAllBndrs [] thing_inside = thing_inside [] -bindIfaceForAllBndrs (bndr:bndrs) thing_inside - = bindIfaceForAllBndr bndr $ \tv vis -> - bindIfaceForAllBndrs bndrs $ \bndrs' -> - thing_inside (mkTyCoVarBinder vis tv : bndrs') - -bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a -bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside - = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis -bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside - = bindIfaceId tv $ \tv' -> thing_inside tv' vis - -bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a -bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName (mkTyVarOccFS occ) - ; tyvar <- mk_iface_tyvar name kind - ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } - -bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a -bindIfaceTyVars [] thing_inside = thing_inside [] -bindIfaceTyVars (bndr:bndrs) thing_inside - = bindIfaceTyVar bndr $ \tv -> - bindIfaceTyVars bndrs $ \tvs -> - thing_inside (tv : tvs) - -mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar -mk_iface_tyvar name ifKind - = do { kind <- tcIfaceType ifKind - ; return (Var.mkTyVar name kind) } - -bindIfaceTyConBinders :: [IfaceTyConBinder] - -> ([TyConBinder] -> IfL a) -> IfL a -bindIfaceTyConBinders [] thing_inside = thing_inside [] -bindIfaceTyConBinders (b:bs) thing_inside - = bindIfaceTyConBinderX bindIfaceBndr b $ \ b' -> - bindIfaceTyConBinders bs $ \ bs' -> - thing_inside (b':bs') - -bindIfaceTyConBinders_AT :: [IfaceTyConBinder] - -> ([TyConBinder] -> IfL a) -> IfL a --- Used for type variable in nested associated data/type declarations --- where some of the type variables are already in scope --- class C a where { data T a b } --- Here 'a' is in scope when we look at the 'data T' -bindIfaceTyConBinders_AT [] thing_inside - = thing_inside [] -bindIfaceTyConBinders_AT (b : bs) thing_inside - = bindIfaceTyConBinderX bind_tv b $ \b' -> - bindIfaceTyConBinders_AT bs $ \bs' -> - thing_inside (b':bs') - where - bind_tv tv thing - = do { mb_tv <- lookupIfaceVar tv - ; case mb_tv of - Just b' -> thing b' - Nothing -> bindIfaceBndr tv thing } - -bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a) - -> IfaceTyConBinder - -> (TyConBinder -> IfL a) -> IfL a -bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside - = bind_tv tv $ \tv' -> - thing_inside (Bndr tv' vis) diff --git a/iface/TcIface.hs-boot b/iface/TcIface.hs-boot deleted file mode 100644 --- a/iface/TcIface.hs-boot +++ /dev/null @@ -1,19 +0,0 @@ -module TcIface where - -import GhcPrelude -import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, - IfaceAnnotation, IfaceCompleteMatch ) -import TyCoRep ( TyThing ) -import TcRnTypes ( IfL ) -import InstEnv ( ClsInst ) -import FamInstEnv ( FamInst ) -import CoreSyn ( CoreRule ) -import HscTypes ( CompleteMatch ) -import Annotations ( Annotation ) - -tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing -tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] -tcIfaceInst :: IfaceClsInst -> IfL ClsInst -tcIfaceFamInst :: IfaceFamInst -> IfL FamInst -tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] -tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] diff --git a/iface/ToIface.hs b/iface/ToIface.hs deleted file mode 100644 --- a/iface/ToIface.hs +++ /dev/null @@ -1,684 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] - --- | Functions for converting Core things to interface file things. -module ToIface - ( -- * Binders - toIfaceTvBndr - , toIfaceTvBndrs - , toIfaceIdBndr - , toIfaceBndr - , toIfaceForAllBndr - , toIfaceTyCoVarBinders - , toIfaceTyVar - -- * Types - , toIfaceType, toIfaceTypeX - , toIfaceKind - , toIfaceTcArgs - , toIfaceTyCon - , toIfaceTyCon_name - , toIfaceTyLit - -- * Tidying types - , tidyToIfaceType - , tidyToIfaceContext - , tidyToIfaceTcArgs - -- * Coercions - , toIfaceCoercion, toIfaceCoercionX - -- * Pattern synonyms - , patSynToIfaceDecl - -- * Expressions - , toIfaceExpr - , toIfaceBang - , toIfaceSrcBang - , toIfaceLetBndr - , toIfaceIdDetails - , toIfaceIdInfo - , toIfUnfolding - , toIfaceOneShot - , toIfaceTickish - , toIfaceBind - , toIfaceAlt - , toIfaceCon - , toIfaceApp - , toIfaceVar - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import IfaceSyn -import DataCon -import Id -import IdInfo -import CoreSyn -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom -import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) -import TysWiredIn ( heqTyCon ) -import MkId ( noinlineIdName ) -import PrelNames -import Name -import BasicTypes -import Type -import PatSyn -import Outputable -import FastString -import Util -import Var -import VarEnv -import VarSet -import TyCoRep -import TyCoTidy ( tidyCo ) -import Demand ( isTopSig ) - -import Data.Maybe ( catMaybes ) - -{- Note [Avoiding space leaks in toIface*] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Building a interface file depends on the output of the simplifier. -If we build these lazily this would mean keeping the Core AST alive -much longer than necessary causing a space "leak". - -This happens for example when we only write the interface file to disk -after code gen has run, in which case we might carry megabytes of core -AST in the heap which is no longer needed. - -We avoid this in two ways. -* First we use -XStrict in ToIface which avoids many thunks to begin with. -* Second we define NFData instance for IFaceSyn and use them to - force any remaining thunks. - --XStrict is not sufficient as patterns of the form `f (g x)` would still -result in a thunk being allocated for `g x`. - -NFData is sufficient for the space leak, but using -XStrict reduces allocation -by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370). -It's essentially free performance hence we use -XStrict on top of NFData. - -MR !1633 on gitlab, has more discussion on the topic. --} - ----------------- -toIfaceTvBndr :: TyVar -> IfaceTvBndr -toIfaceTvBndr = toIfaceTvBndrX emptyVarSet - -toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr -toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) - , toIfaceTypeX fr (tyVarKind tyvar) - ) - -toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] -toIfaceTvBndrs = map toIfaceTvBndr - -toIfaceIdBndr :: Id -> IfaceIdBndr -toIfaceIdBndr = toIfaceIdBndrX emptyVarSet - -toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr -toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar) - , toIfaceTypeX fr (varType covar) - ) - -toIfaceBndr :: Var -> IfaceBndr -toIfaceBndr var - | isId var = IfaceIdBndr (toIfaceIdBndr var) - | otherwise = IfaceTvBndr (toIfaceTvBndr var) - -toIfaceBndrX :: VarSet -> Var -> IfaceBndr -toIfaceBndrX fr var - | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) - | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) - -toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis -toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis - -toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] -toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder - -{- -************************************************************************ -* * - Conversion from Type to IfaceType -* * -************************************************************************ --} - -toIfaceKind :: Type -> IfaceType -toIfaceKind = toIfaceType - ---------------------- -toIfaceType :: Type -> IfaceType -toIfaceType = toIfaceTypeX emptyVarSet - -toIfaceTypeX :: VarSet -> Type -> IfaceType --- (toIfaceTypeX free ty) --- translates the tyvars in 'free' as IfaceFreeTyVars --- --- Synonyms are retained in the interface type -toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType - | tv `elemVarSet` fr = IfaceFreeTyVar tv - | otherwise = IfaceTyVar (toIfaceTyVar tv) -toIfaceTypeX fr ty@(AppTy {}) = - -- Flatten as many argument AppTys as possible, then turn them into an - -- IfaceAppArgs list. - -- See Note [Suppressing invisible arguments] in IfaceType. - let (head, args) = splitAppTys ty - in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args) -toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) -toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) - (toIfaceTypeX (fr `delVarSet` binderVar b) t) -toIfaceTypeX fr (FunTy { ft_arg = t1, ft_res = t2, ft_af = af }) - = IfaceFunTy af (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) -toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) -toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) - -toIfaceTypeX fr (TyConApp tc tys) - -- tuples - | Just sort <- tyConTuple_maybe tc - , n_tys == arity - = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys) - - | Just dc <- isPromotedDataCon_maybe tc - , isTupleDataCon dc - , n_tys == 2*arity - = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) - - | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] - , (k1:k2:_) <- tys - = let info = IfaceTyConInfo NotPromoted sort - sort | k1 `eqType` k2 = IfaceEqualityTyCon - | otherwise = IfaceNormalTyCon - in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) - - -- other applications - | otherwise - = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys) - where - arity = tyConArity tc - n_tys = length tys - -toIfaceTyVar :: TyVar -> FastString -toIfaceTyVar = occNameFS . getOccName - -toIfaceCoVar :: CoVar -> FastString -toIfaceCoVar = occNameFS . getOccName - -toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr -toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet - -toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr -toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis - ----------------- -toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTyCon tc - = IfaceTyCon tc_name info - where - tc_name = tyConName tc - info = IfaceTyConInfo promoted sort - promoted | isPromotedDataCon tc = IsPromoted - | otherwise = NotPromoted - - tupleSort :: TyCon -> Maybe IfaceTyConSort - tupleSort tc' = - case tyConTuple_maybe tc' of - Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 - in Just $ IfaceTupleTyCon arity UnboxedTuple - Just sort -> let arity = tyConArity tc' - in Just $ IfaceTupleTyCon arity sort - Nothing -> Nothing - - sort - | Just tsort <- tupleSort tc = tsort - - | Just dcon <- isPromotedDataCon_maybe tc - , let tc' = dataConTyCon dcon - , Just tsort <- tupleSort tc' = tsort - - | isUnboxedSumTyCon tc - , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) - - | otherwise = IfaceNormalTyCon - - -toIfaceTyCon_name :: Name -> IfaceTyCon -toIfaceTyCon_name n = IfaceTyCon n info - where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon - -- Used for the "rough-match" tycon stuff, - -- where pretty-printing is not an issue - -toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x -toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x - ----------------- -toIfaceCoercion :: Coercion -> IfaceCoercion -toIfaceCoercion = toIfaceCoercionX emptyVarSet - -toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion --- (toIfaceCoercionX free ty) --- translates the tyvars in 'free' as IfaceFreeTyVars -toIfaceCoercionX fr co - = go co - where - go_mco MRefl = IfaceMRefl - go_mco (MCo co) = IfaceMCo $ go co - - go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) - go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) - go (CoVarCo cv) - -- See [TcTyVars in IfaceType] in IfaceType - | cv `elemVarSet` fr = IfaceFreeCoVar cv - | otherwise = IfaceCoVarCo (toIfaceCoVar cv) - go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) - - go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) - go (SymCo co) = IfaceSymCo (go co) - go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) - go (NthCo _r d co) = IfaceNthCo d (go co) - go (LRCo lr co) = IfaceLRCo lr (go co) - go (InstCo co arg) = IfaceInstCo (go co) (go arg) - go (KindCo c) = IfaceKindCo (go c) - go (SubCo co) = IfaceSubCo (go co) - go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) - go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) - go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r - (toIfaceTypeX fr t1) - (toIfaceTypeX fr t2) - go (TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co) - | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) - go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2) - - go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) - (toIfaceCoercionX fr' k) - (toIfaceCoercionX fr' co) - where - fr' = fr `delVarSet` tv - - go_prov :: UnivCoProvenance -> IfaceUnivCoProv - go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv - go_prov (PhantomProv co) = IfacePhantomProv (go co) - go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) - go_prov (PluginProv str) = IfacePluginProv str - -toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs -toIfaceTcArgs = toIfaceTcArgsX emptyVarSet - -toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs -toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args - -toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs -toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args - -toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs --- See Note [Suppressing invisible arguments] in IfaceType --- We produce a result list of args describing visibility --- The awkward case is --- T :: forall k. * -> k --- And consider --- T (forall j. blah) * blib --- Is 'blib' visible? It depends on the visibility flag on j, --- so we have to substitute for k. Annoying! -toIfaceAppArgsX fr kind ty_args - = go (mkEmptyTCvSubst in_scope) kind ty_args - where - in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) - - go _ _ [] = IA_Nil - go env ty ts - | Just ty' <- coreView ty - = go env ty' ts - go env (ForAllTy (Bndr tv vis) res) (t:ts) - = IA_Arg t' vis ts' - where - t' = toIfaceTypeX fr t - ts' = go (extendTCvSubst env tv t) res ts - - go env (FunTy { ft_af = af, ft_res = res }) (t:ts) - = IA_Arg (toIfaceTypeX fr t) argf (go env res ts) - where - argf = case af of - VisArg -> Required - InvisArg -> Inferred - -- It's rare for a kind to have a constraint argument, but - -- it can happen. See Note [AnonTCB InvisArg] in TyCon. - - go env ty ts@(t1:ts1) - | not (isEmptyTCvSubst env) - = go (zapTCvSubst env) (substTy env ty) ts - -- See Note [Care with kind instantiation] in Type.hs - - | otherwise - = -- There's a kind error in the type we are trying to print - -- e.g. kind = k, ty_args = [Int] - -- This is probably a compiler bug, so we print a trace and - -- carry on as if it were FunTy. Without the test for - -- isEmptyTCvSubst we'd get an infinite loop (#15473) - WARN( True, ppr kind $$ ppr ty_args ) - IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) - -tidyToIfaceType :: TidyEnv -> Type -> IfaceType -tidyToIfaceType env ty = toIfaceType (tidyType env ty) - -tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs -tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) - -tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext -tidyToIfaceContext env theta = map (tidyToIfaceType env) theta - -{- -************************************************************************ -* * - Conversion of pattern synonyms -* * -************************************************************************ --} - -patSynToIfaceDecl :: PatSyn -> IfaceDecl -patSynToIfaceDecl ps - = IfacePatSyn { ifName = getName $ ps - , ifPatMatcher = to_if_pr (patSynMatcher ps) - , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) - , ifPatIsInfix = patSynIsInfix ps - , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' - , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' - , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta - , ifPatReqCtxt = tidyToIfaceContext env2 req_theta - , ifPatArgs = map (tidyToIfaceType env2) args - , ifPatTy = tidyToIfaceType env2 rhs_ty - , ifFieldLabels = (patSynFieldLabels ps) - } - where - (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps - univ_bndrs = patSynUnivTyVarBinders ps - ex_bndrs = patSynExTyVarBinders ps - (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs - (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs - to_if_pr (id, needs_dummy) = (idName id, needs_dummy) - -{- -************************************************************************ -* * - Conversion of other things -* * -************************************************************************ --} - -toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang -toIfaceBang _ HsLazy = IfNoBang -toIfaceBang _ (HsUnpack Nothing) = IfUnpack -toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) -toIfaceBang _ HsStrict = IfStrict - -toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang -toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang - -toIfaceLetBndr :: Id -> IfaceLetBndr -toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) - (toIfaceType (idType id)) - (toIfaceIdInfo (idInfo id)) - (toIfaceJoinInfo (isJoinId_maybe id)) - -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr - -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn - -toIfaceIdDetails :: IdDetails -> IfaceIdDetails -toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (DFunId {}) = IfDFunId -toIfaceIdDetails (RecSelId { sel_naughty = n - , sel_tycon = tc }) = - let iface = case tc of - RecSelData ty_con -> Left (toIfaceTyCon ty_con) - RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) - in IfRecSelId iface n - - -- The remaining cases are all "implicit Ids" which don't - -- appear in interface files at all -toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) - IfVanillaId -- Unexpected; the other - -toIfaceIdInfo :: IdInfo -> IfaceIdInfo -toIfaceIdInfo id_info - = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, unfold_hsinfo, levity_hsinfo] of - [] -> NoInfo - infos -> HasInfo infos - -- NB: strictness and arity must appear in the list before unfolding - -- See TcIface.tcUnfolding - where - ------------ Arity -------------- - arity_info = arityInfo id_info - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_info = cafInfo id_info - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - sig_info = strictnessInfo id_info - strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) - | otherwise = Nothing - - ------------ Unfolding -------------- - unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) - loop_breaker = isStrongLoopBreaker (occInfo id_info) - - ------------ Inline prag -------------- - inline_prag = inlinePragInfo id_info - inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing - | otherwise = Just (HsInline inline_prag) - - ------------ Levity polymorphism ---------- - levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity - | otherwise = Nothing - -toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo -toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar -toIfaceJoinInfo Nothing = IfaceNotJoinPoint - --------------------------- -toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem -toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs - , uf_src = src - , uf_guidance = guidance }) - = Just $ HsUnfold lb $ - case src of - InlineStable - -> case guidance of - UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - -> IfInlineRule arity unsat_ok boring_ok if_rhs - _other -> IfCoreUnfold True if_rhs - InlineCompulsory -> IfCompulsory if_rhs - InlineRhs -> IfCoreUnfold False if_rhs - -- Yes, even if guidance is UnfNever, expose the unfolding - -- If we didn't want to expose the unfolding, TidyPgm would - -- have stuck in NoUnfolding. For supercompilation we want - -- to see that unfolding! - where - if_rhs = toIfaceExpr rhs - -toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) - -- No need to serialise the data constructor; - -- we can recover it from the type of the dfun - -toIfUnfolding _ (OtherCon {}) = Nothing - -- The binding site of an Id doesn't have OtherCon, except perhaps - -- where we have called zapUnfolding; and that evald'ness info is - -- not needed by importing modules - -toIfUnfolding _ BootUnfolding = Nothing - -- Can't happen; we only have BootUnfolding for imported binders - -toIfUnfolding _ NoUnfolding = Nothing - -{- -************************************************************************ -* * - Conversion of expressions -* * -************************************************************************ --} - -toIfaceExpr :: CoreExpr -> IfaceExpr -toIfaceExpr (Var v) = toIfaceVar v -toIfaceExpr (Lit l) = IfaceLit l -toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) -toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) -toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) -toIfaceExpr (App f a) = toIfaceApp f [a] -toIfaceExpr (Case s x ty as) - | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) - | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) -toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) -toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) -toIfaceExpr (Tick t e) - | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) - | otherwise = toIfaceExpr e - -toIfaceOneShot :: Id -> IfaceOneShot -toIfaceOneShot id | isId id - , OneShotLam <- oneShotInfo (idInfo id) - = IfaceOneShot - | otherwise - = IfaceNoOneShot - ---------------------- -toIfaceTickish :: Tickish Id -> Maybe IfaceTickish -toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) -toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) -toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) -toIfaceTickish (Breakpoint {}) = Nothing - -- Ignore breakpoints, since they are relevant only to GHCi, and - -- should not be serialised (#8333) - ---------------------- -toIfaceBind :: Bind Id -> IfaceBinding -toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) -toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] - ---------------------- -toIfaceAlt :: (AltCon, [Var], CoreExpr) - -> (IfaceConAlt, [FastString], IfaceExpr) -toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) - ---------------------- -toIfaceCon :: AltCon -> IfaceConAlt -toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) -toIfaceCon (LitAlt l) = IfaceLitAlt l -toIfaceCon DEFAULT = IfaceDefault - ---------------------- -toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr -toIfaceApp (App f a) as = toIfaceApp f (a:as) -toIfaceApp (Var v) as - = case isDataConWorkId_maybe v of - -- We convert the *worker* for tuples into IfaceTuples - Just dc | saturated - , Just tup_sort <- tyConTuple_maybe tc - -> IfaceTuple tup_sort tup_args - where - val_args = dropWhile isTypeArg as - saturated = val_args `lengthIs` idArity v - tup_args = map toIfaceExpr val_args - tc = dataConTyCon dc - - _ -> mkIfaceApps (toIfaceVar v) as - -toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as - -mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr -mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as - ---------------------- -toIfaceVar :: Id -> IfaceExpr -toIfaceVar v - | isBootUnfolding (idUnfolding v) - = -- See Note [Inlining and hs-boot files] - IfaceApp (IfaceApp (IfaceExt noinlineIdName) - (IfaceType (toIfaceType (idType v)))) - (IfaceExt name) -- don't use mkIfaceApps, or infinite loop - - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) - -- Foreign calls have special syntax - - | isExternalName name = IfaceExt name - | otherwise = IfaceLcl (getOccFS name) - where name = idName v - - -{- Note [Inlining and hs-boot files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example (#10083, #12789): - - ---------- RSR.hs-boot ------------ - module RSR where - data RSR - eqRSR :: RSR -> RSR -> Bool - - ---------- SR.hs ------------ - module SR where - import {-# SOURCE #-} RSR - data SR = MkSR RSR - eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 - - ---------- RSR.hs ------------ - module RSR where - import SR - data RSR = MkRSR SR -- deriving( Eq ) - eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) - foo x y = not (eqRSR x y) - -When compiling RSR we get this code - - RSR.eqRSR :: RSR -> RSR -> Bool - RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> - case ds1 of _ { RSR.MkRSR s1 -> - case ds2 of _ { RSR.MkRSR s2 -> - SR.eqSR s1 s2 }} - - RSR.foo :: RSR -> RSR -> Bool - RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) - -Now, when optimising foo: - Inline eqRSR (small, non-rec) - Inline eqSR (small, non-rec) -but the result of inlining eqSR from SR is another call to eqRSR, so -everything repeats. Neither eqSR nor eqRSR are (apparently) loop -breakers. - -Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR -with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means -that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly -as would have been the case if `foo` had been defined in SR.hs (and -marked as a loop-breaker). - -But how do we arrange for this to happen? There are two ingredients: - - 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), - for every variable reference we see if we are referring to an - 'Id' that came from an hs-boot file. If so, we add a `noinline` - to the reference. - - 2. But how do we know if a reference came from an hs-boot file - or not? We could record this directly in the 'IdInfo', but - actually we deduce this by looking at the unfolding: 'Id's - that come from boot files are given a special unfolding - (upon typechecking) 'BootUnfolding' which say that there is - no unfolding, and the reason is because the 'Id' came from - a boot file. - -Here is a solution that doesn't work: when compiling RSR, -add a NOINLINE pragma to every function exported by the boot-file -for RSR (if it exists). Doing so makes the bootstrapped GHC itself -slower by 8% overall (on #9872a-d, and T1969: the reason -is that these NOINLINE'd functions now can't be profitably inlined -outside of the hs-boot loop. - --} diff --git a/iface/ToIface.hs-boot b/iface/ToIface.hs-boot deleted file mode 100644 --- a/iface/ToIface.hs-boot +++ /dev/null @@ -1,18 +0,0 @@ -module ToIface where - -import {-# SOURCE #-} TyCoRep ( Type, TyLit, Coercion ) -import {-# SOURCE #-} IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr - , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) -import Var ( TyCoVarBinder ) -import VarEnv ( TidyEnv ) -import TyCon ( TyCon ) -import VarSet( VarSet ) - --- For TyCoRep -toIfaceTypeX :: VarSet -> Type -> IfaceType -toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr -toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs -toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion -tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs diff --git a/llvmGen/Llvm.hs b/llvmGen/Llvm.hs deleted file mode 100644 --- a/llvmGen/Llvm.hs +++ /dev/null @@ -1,64 +0,0 @@ --- ---------------------------------------------------------------------------- --- | This module supplies bindings to generate Llvm IR from Haskell --- (). --- --- Note: this module is developed in a demand driven way. It is no complete --- LLVM binding library in Haskell, but enough to generate code for GHC. --- --- This code is derived from code taken from the Essential Haskell Compiler --- (EHC) project (). --- - -module Llvm ( - - -- * Modules, Functions and Blocks - LlvmModule(..), - - LlvmFunction(..), LlvmFunctionDecl(..), - LlvmFunctions, LlvmFunctionDecls, - LlvmStatement(..), LlvmExpression(..), - LlvmBlocks, LlvmBlock(..), LlvmBlockId, - LlvmParamAttr(..), LlvmParameter, - - -- * Atomic operations - LlvmAtomicOp(..), - - -- * Fence synchronization - LlvmSyncOrdering(..), - - -- * Call Handling - LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), - LlvmLinkageType(..), LlvmFuncAttr(..), - - -- * Operations and Comparisons - LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..), - - -- * Variables and Type System - LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), - LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign, - LMConst(..), - - -- ** Some basic types - i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, - - -- ** Metadata types - MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..), - - -- ** Operations on the type system. - isGlobal, getLitType, getVarType, - getLink, getStatType, pVarLift, pVarLower, - pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, - - -- * Pretty Printing - ppLit, ppName, ppPlainName, - ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, - ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, - ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, - - ) where - -import Llvm.AbsSyn -import Llvm.MetaData -import Llvm.PpLlvm -import Llvm.Types - diff --git a/llvmGen/Llvm/AbsSyn.hs b/llvmGen/Llvm/AbsSyn.hs deleted file mode 100644 --- a/llvmGen/Llvm/AbsSyn.hs +++ /dev/null @@ -1,352 +0,0 @@ --------------------------------------------------------------------------------- --- | The LLVM abstract syntax. --- - -module Llvm.AbsSyn where - -import GhcPrelude - -import Llvm.MetaData -import Llvm.Types - -import Unique - --- | Block labels -type LlvmBlockId = Unique - --- | A block of LLVM code. -data LlvmBlock = LlvmBlock { - -- | The code label for this block - blockLabel :: LlvmBlockId, - - -- | A list of LlvmStatement's representing the code for this block. - -- This list must end with a control flow statement. - blockStmts :: [LlvmStatement] - } - -type LlvmBlocks = [LlvmBlock] - --- | An LLVM Module. This is a top level container in LLVM. -data LlvmModule = LlvmModule { - -- | Comments to include at the start of the module. - modComments :: [LMString], - - -- | LLVM Alias type definitions. - modAliases :: [LlvmAlias], - - -- | LLVM meta data. - modMeta :: [MetaDecl], - - -- | Global variables to include in the module. - modGlobals :: [LMGlobal], - - -- | LLVM Functions used in this module but defined in other modules. - modFwdDecls :: LlvmFunctionDecls, - - -- | LLVM Functions defined in this module. - modFuncs :: LlvmFunctions - } - --- | An LLVM Function -data LlvmFunction = LlvmFunction { - -- | The signature of this declared function. - funcDecl :: LlvmFunctionDecl, - - -- | The functions arguments - funcArgs :: [LMString], - - -- | The function attributes. - funcAttrs :: [LlvmFuncAttr], - - -- | The section to put the function into, - funcSect :: LMSection, - - -- | Prefix data - funcPrefix :: Maybe LlvmStatic, - - -- | The body of the functions. - funcBody :: LlvmBlocks - } - -type LlvmFunctions = [LlvmFunction] - -type SingleThreaded = Bool - --- | LLVM ordering types for synchronization purposes. (Introduced in LLVM --- 3.0). Please see the LLVM documentation for a better description. -data LlvmSyncOrdering - -- | Some partial order of operations exists. - = SyncUnord - -- | A single total order for operations at a single address exists. - | SyncMonotonic - -- | Acquire synchronization operation. - | SyncAcquire - -- | Release synchronization operation. - | SyncRelease - -- | Acquire + Release synchronization operation. - | SyncAcqRel - -- | Full sequential Consistency operation. - | SyncSeqCst - deriving (Show, Eq) - --- | LLVM atomic operations. Please see the @atomicrmw@ instruction in --- the LLVM documentation for a complete description. -data LlvmAtomicOp - = LAO_Xchg - | LAO_Add - | LAO_Sub - | LAO_And - | LAO_Nand - | LAO_Or - | LAO_Xor - | LAO_Max - | LAO_Min - | LAO_Umax - | LAO_Umin - deriving (Show, Eq) - --- | Llvm Statements -data LlvmStatement - {- | - Assign an expression to a variable: - * dest: Variable to assign to - * source: Source expression - -} - = Assignment LlvmVar LlvmExpression - - {- | - Memory fence operation - -} - | Fence Bool LlvmSyncOrdering - - {- | - Always branch to the target label - -} - | Branch LlvmVar - - {- | - Branch to label targetTrue if cond is true otherwise to label targetFalse - * cond: condition that will be tested, must be of type i1 - * targetTrue: label to branch to if cond is true - * targetFalse: label to branch to if cond is false - -} - | BranchIf LlvmVar LlvmVar LlvmVar - - {- | - Comment - Plain comment. - -} - | Comment [LMString] - - {- | - Set a label on this position. - * name: Identifier of this label, unique for this module - -} - | MkLabel LlvmBlockId - - {- | - Store variable value in pointer ptr. If value is of type t then ptr must - be of type t*. - * value: Variable/Constant to store. - * ptr: Location to store the value in - -} - | Store LlvmVar LlvmVar - - {- | - Multiway branch - * scrutinee: Variable or constant which must be of integer type that is - determines which arm is chosen. - * def: The default label if there is no match in target. - * target: A list of (value,label) where the value is an integer - constant and label the corresponding label to jump to if the - scrutinee matches the value. - -} - | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)] - - {- | - Return a result. - * result: The variable or constant to return - -} - | Return (Maybe LlvmVar) - - {- | - An instruction for the optimizer that the code following is not reachable - -} - | Unreachable - - {- | - Raise an expression to a statement (if don't want result or want to use - Llvm unnamed values. - -} - | Expr LlvmExpression - - {- | - A nop LLVM statement. Useful as its often more efficient to use this - then to wrap LLvmStatement in a Just or []. - -} - | Nop - - {- | - A LLVM statement with metadata attached to it. - -} - | MetaStmt [MetaAnnot] LlvmStatement - - deriving (Eq) - - --- | Llvm Expressions -data LlvmExpression - {- | - Allocate amount * sizeof(tp) bytes on the stack - * tp: LlvmType to reserve room for - * amount: The nr of tp's which must be allocated - -} - = Alloca LlvmType Int - - {- | - Perform the machine operator op on the operands left and right - * op: operator - * left: left operand - * right: right operand - -} - | LlvmOp LlvmMachOp LlvmVar LlvmVar - - {- | - Perform a compare operation on the operands left and right - * op: operator - * left: left operand - * right: right operand - -} - | Compare LlvmCmpOp LlvmVar LlvmVar - - {- | - Extract a scalar element from a vector - * val: The vector - * idx: The index of the scalar within the vector - -} - | Extract LlvmVar LlvmVar - - {- | - Extract a scalar element from a structure - * val: The structure - * idx: The index of the scalar within the structure - Corresponds to "extractvalue" instruction. - -} - | ExtractV LlvmVar Int - - {- | - Insert a scalar element into a vector - * val: The source vector - * elt: The scalar to insert - * index: The index at which to insert the scalar - -} - | Insert LlvmVar LlvmVar LlvmVar - - {- | - Allocate amount * sizeof(tp) bytes on the heap - * tp: LlvmType to reserve room for - * amount: The nr of tp's which must be allocated - -} - | Malloc LlvmType Int - - {- | - Load the value at location ptr - -} - | Load LlvmVar - - {- | - Atomic load of the value at location ptr - -} - | ALoad LlvmSyncOrdering SingleThreaded LlvmVar - - {- | - Navigate in a structure, selecting elements - * inbound: Is the pointer inbounds? (computed pointer doesn't overflow) - * ptr: Location of the structure - * indexes: A list of indexes to select the correct value. - -} - | GetElemPtr Bool LlvmVar [LlvmVar] - - {- | - Cast the variable from to the to type. This is an abstraction of three - cast operators in Llvm, inttoptr, ptrtoint and bitcast. - * cast: Cast type - * from: Variable to cast - * to: type to cast to - -} - | Cast LlvmCastOp LlvmVar LlvmType - - {- | - Atomic read-modify-write operation - * op: Atomic operation - * addr: Address to modify - * operand: Operand to operation - * ordering: Ordering requirement - -} - | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering - - {- | - Compare-and-exchange operation - * addr: Address to modify - * old: Expected value - * new: New value - * suc_ord: Ordering required in success case - * fail_ord: Ordering required in failure case, can be no stronger than - suc_ord - - Result is an @i1@, true if store was successful. - -} - | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering - - {- | - Call a function. The result is the value of the expression. - * tailJumps: CallType to signal if the function should be tail called - * fnptrval: An LLVM value containing a pointer to a function to be - invoked. Can be indirect. Should be LMFunction type. - * args: Concrete arguments for the parameters - * attrs: A list of function attributes for the call. Only NoReturn, - NoUnwind, ReadOnly and ReadNone are valid here. - -} - | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr] - - {- | - Call a function as above but potentially taking metadata as arguments. - * tailJumps: CallType to signal if the function should be tail called - * fnptrval: An LLVM value containing a pointer to a function to be - invoked. Can be indirect. Should be LMFunction type. - * args: Arguments that may include metadata. - * attrs: A list of function attributes for the call. Only NoReturn, - NoUnwind, ReadOnly and ReadNone are valid here. - -} - | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr] - - {- | - Merge variables from different basic blocks which are predecessors of this - basic block in a new variable of type tp. - * tp: type of the merged variable, must match the types of the - predecessor variables. - * predecessors: A list of variables and the basic block that they originate - from. - -} - | Phi LlvmType [(LlvmVar,LlvmVar)] - - {- | - Inline assembly expression. Syntax is very similar to the style used by GCC. - * assembly: Actual inline assembly code. - * constraints: Operand constraints. - * return ty: Return type of function. - * vars: Any variables involved in the assembly code. - * sideeffect: Does the expression have side effects not visible from the - constraints list. - * alignstack: Should the stack be conservatively aligned before this - expression is executed. - -} - | Asm LMString LMString LlvmType [LlvmVar] Bool Bool - - {- | - A LLVM expression with metadata attached to it. - -} - | MExpr [MetaAnnot] LlvmExpression - - deriving (Eq) - diff --git a/llvmGen/Llvm/MetaData.hs b/llvmGen/Llvm/MetaData.hs deleted file mode 100644 --- a/llvmGen/Llvm/MetaData.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Llvm.MetaData where - -import GhcPrelude - -import Llvm.Types -import Outputable - --- The LLVM Metadata System. --- --- The LLVM metadata feature is poorly documented but roughly follows the --- following design: --- * Metadata can be constructed in a few different ways (See below). --- * After which it can either be attached to LLVM statements to pass along --- extra information to the optimizer and code generator OR specifically named --- metadata has an affect on the whole module (i.e., linking behaviour). --- --- --- # Constructing metadata --- Metadata comes largely in three forms: --- --- * Metadata expressions -- these are the raw metadata values that encode --- information. They consist of metadata strings, metadata nodes, regular --- LLVM values (both literals and references to global variables) and --- metadata expressions (i.e., recursive data type). Some examples: --- !{ !"hello", !0, i32 0 } --- !{ !1, !{ i32 0 } } --- --- * Metadata nodes -- global metadata variables that attach a metadata --- expression to a number. For example: --- !0 = !{ [] !} --- --- * Named metadata -- global metadata variables that attach a metadata nodes --- to a name. Used ONLY to communicated module level information to LLVM --- through a meaningful name. For example: --- !llvm.module.linkage = !{ !0, !1 } --- --- --- # Using Metadata --- Using metadata depends on the form it is in: --- --- * Attach to instructions -- metadata can be attached to LLVM instructions --- using a specific reference as follows: --- %l = load i32* @glob, !nontemporal !10 --- %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } } --- Only metadata nodes or expressions can be attached, named metadata cannot. --- Refer to LLVM documentation for which instructions take metadata and its --- meaning. --- --- * As arguments -- llvm functions can take metadata as arguments, for --- example: --- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1) --- As with instructions, only metadata nodes or expressions can be attached. --- --- * As a named metadata -- Here the metadata is simply declared in global --- scope using a specific name to communicate module level information to LLVM. --- For example: --- !llvm.module.linkage = !{ !0, !1 } --- - --- | A reference to an un-named metadata node. -newtype MetaId = MetaId Int - deriving (Eq, Ord, Enum) - -instance Outputable MetaId where - ppr (MetaId n) = char '!' <> int n - --- | LLVM metadata expressions -data MetaExpr = MetaStr !LMString - | MetaNode !MetaId - | MetaVar !LlvmVar - | MetaStruct [MetaExpr] - deriving (Eq) - -instance Outputable MetaExpr where - ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null" - ppr (MetaStr s ) = char '!' <> doubleQuotes (ftext s) - ppr (MetaNode n ) = ppr n - ppr (MetaVar v ) = ppr v - ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es) - --- | Associates some metadata with a specific label for attaching to an --- instruction. -data MetaAnnot = MetaAnnot LMString MetaExpr - deriving (Eq) - --- | Metadata declarations. Metadata can only be declared in global scope. -data MetaDecl - -- | Named metadata. Only used for communicating module information to - -- LLVM. ('!name = !{ [!] }' form). - = MetaNamed !LMString [MetaId] - -- | Metadata node declaration. - -- ('!0 = metadata !{ }' form). - | MetaUnnamed !MetaId !MetaExpr diff --git a/llvmGen/Llvm/PpLlvm.hs b/llvmGen/Llvm/PpLlvm.hs deleted file mode 100644 --- a/llvmGen/Llvm/PpLlvm.hs +++ /dev/null @@ -1,502 +0,0 @@ -{-# LANGUAGE CPP #-} - --------------------------------------------------------------------------------- --- | Pretty print LLVM IR Code. --- - -module Llvm.PpLlvm ( - - -- * Top level LLVM objects. - ppLlvmModule, - ppLlvmComments, - ppLlvmComment, - ppLlvmGlobals, - ppLlvmGlobal, - ppLlvmAliases, - ppLlvmAlias, - ppLlvmMetas, - ppLlvmMeta, - ppLlvmFunctionDecls, - ppLlvmFunctionDecl, - ppLlvmFunctions, - ppLlvmFunction, - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Llvm.AbsSyn -import Llvm.MetaData -import Llvm.Types - -import Data.List ( intersperse ) -import Outputable -import Unique -import FastString ( sLit ) - --------------------------------------------------------------------------------- --- * Top Level Print functions --------------------------------------------------------------------------------- - --- | Print out a whole LLVM module. -ppLlvmModule :: LlvmModule -> SDoc -ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) - = ppLlvmComments comments $+$ newLine - $+$ ppLlvmAliases aliases $+$ newLine - $+$ ppLlvmMetas meta $+$ newLine - $+$ ppLlvmGlobals globals $+$ newLine - $+$ ppLlvmFunctionDecls decls $+$ newLine - $+$ ppLlvmFunctions funcs - --- | Print out a multi-line comment, can be inside a function or on its own -ppLlvmComments :: [LMString] -> SDoc -ppLlvmComments comments = vcat $ map ppLlvmComment comments - --- | Print out a comment, can be inside a function or on its own -ppLlvmComment :: LMString -> SDoc -ppLlvmComment com = semi <+> ftext com - - --- | Print out a list of global mutable variable definitions -ppLlvmGlobals :: [LMGlobal] -> SDoc -ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls - --- | Print out a global mutable variable definition -ppLlvmGlobal :: LMGlobal -> SDoc -ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = - let sect = case x of - Just x' -> text ", section" <+> doubleQuotes (ftext x') - Nothing -> empty - - align = case a of - Just a' -> text ", align" <+> int a' - Nothing -> empty - - rhs = case dat of - Just stat -> pprSpecialStatic stat - Nothing -> ppr (pLower $ getVarType var) - - -- Position of linkage is different for aliases. - const = case c of - Global -> "global" - Constant -> "constant" - Alias -> "alias" - - in ppAssignment var $ ppr link <+> text const <+> rhs <> sect <> align - $+$ newLine - -ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags -> - error $ "Non Global var ppr as global! " - ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val) - - --- | Print out a list of LLVM type aliases. -ppLlvmAliases :: [LlvmAlias] -> SDoc -ppLlvmAliases tys = vcat $ map ppLlvmAlias tys - --- | Print out an LLVM type alias. -ppLlvmAlias :: LlvmAlias -> SDoc -ppLlvmAlias (name, ty) - = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty - - --- | Print out a list of LLVM metadata. -ppLlvmMetas :: [MetaDecl] -> SDoc -ppLlvmMetas metas = vcat $ map ppLlvmMeta metas - --- | Print out an LLVM metadata definition. -ppLlvmMeta :: MetaDecl -> SDoc -ppLlvmMeta (MetaUnnamed n m) - = ppr n <+> equals <+> ppr m - -ppLlvmMeta (MetaNamed n m) - = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes - where - nodes = hcat $ intersperse comma $ map ppr m - - --- | Print out a list of function definitions. -ppLlvmFunctions :: LlvmFunctions -> SDoc -ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs - --- | Print out a function definition. -ppLlvmFunction :: LlvmFunction -> SDoc -ppLlvmFunction fun = - let attrDoc = ppSpaceJoin (funcAttrs fun) - secDoc = case funcSect fun of - Just s' -> text "section" <+> (doubleQuotes $ ftext s') - Nothing -> empty - prefixDoc = case funcPrefix fun of - Just v -> text "prefix" <+> ppr v - Nothing -> empty - in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) - <+> attrDoc <+> secDoc <+> prefixDoc - $+$ lbrace - $+$ ppLlvmBlocks (funcBody fun) - $+$ rbrace - $+$ newLine - $+$ newLine - --- | Print out a function definition header. -ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc -ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args - = let varg' = case varg of - VarArgs | null p -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" - align = case a of - Just a' -> text " align " <> ppr a' - Nothing -> empty - args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%' - <> ftext n) - (zip p args) - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> - (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align - --- | Print out a list of function declaration. -ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc -ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs - --- | Print out a function declaration. --- Declarations define the function type but don't define the actual body of --- the function. -ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc -ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) - = let varg' = case varg of - VarArgs | null p -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" - align = case a of - Just a' -> text " align" <+> ppr a' - Nothing -> empty - args = hcat $ intersperse (comma <> space) $ - map (\(t,a) -> ppr t <+> ppSpaceJoin a) p - in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> - ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine - - --- | Print out a list of LLVM blocks. -ppLlvmBlocks :: LlvmBlocks -> SDoc -ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks - --- | Print out an LLVM block. --- It must be part of a function definition. -ppLlvmBlock :: LlvmBlock -> SDoc -ppLlvmBlock (LlvmBlock blockId stmts) = - let isLabel (MkLabel _) = True - isLabel _ = False - (block, rest) = break isLabel stmts - ppRest = case rest of - MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs) - _ -> empty - in ppLlvmBlockLabel blockId - $+$ (vcat $ map ppLlvmStatement block) - $+$ newLine - $+$ ppRest - --- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> SDoc -ppLlvmBlockLabel id = pprUniqueAlways id <> colon - - --- | Print out an LLVM statement. -ppLlvmStatement :: LlvmStatement -> SDoc -ppLlvmStatement stmt = - let ind = (text " " <>) - in case stmt of - Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) - Fence st ord -> ind $ ppFence st ord - Branch target -> ind $ ppBranch target - BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF - Comment comments -> ind $ ppLlvmComments comments - MkLabel label -> ppLlvmBlockLabel label - Store value ptr -> ind $ ppStore value ptr - Switch scrut def tgs -> ind $ ppSwitch scrut def tgs - Return result -> ind $ ppReturn result - Expr expr -> ind $ ppLlvmExpression expr - Unreachable -> ind $ text "unreachable" - Nop -> empty - MetaStmt meta s -> ppMetaStatement meta s - - --- | Print out an LLVM expression. -ppLlvmExpression :: LlvmExpression -> SDoc -ppLlvmExpression expr - = case expr of - Alloca tp amount -> ppAlloca tp amount - LlvmOp op left right -> ppMachOp op left right - Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs - CallM tp fp args attrs -> ppCall tp fp args attrs - Cast op from to -> ppCast op from to - Compare op left right -> ppCmpOp op left right - Extract vec idx -> ppExtract vec idx - ExtractV struct idx -> ppExtractV struct idx - Insert vec elt idx -> ppInsert vec elt idx - GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes - Load ptr -> ppLoad ptr - ALoad ord st ptr -> ppALoad ord st ptr - Malloc tp amount -> ppMalloc tp amount - AtomicRMW aop tgt src ordering -> ppAtomicRMW aop tgt src ordering - CmpXChg addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord - Phi tp predecessors -> ppPhi tp predecessors - Asm asm c ty v se sk -> ppAsm asm c ty v se sk - MExpr meta expr -> ppMetaExpr meta expr - - --------------------------------------------------------------------------------- --- * Individual print functions --------------------------------------------------------------------------------- - --- | Should always be a function pointer. So a global var of function type --- (since globals are always pointers) or a local var of pointer function type. -ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc -ppCall ct fptr args attrs = case fptr of - -- - -- if local var function pointer, unwrap - LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d - - -- should be function type otherwise - LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d - - -- not pointer or function, so error - _other -> error $ "ppCall called with non LMFunction type!\nMust be " - ++ " called with either global var of function type or " - ++ "local var of pointer function type." - - where - ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = - let tc = if ct == TailCall then text "tail " else empty - ppValues = ppCallParams (map snd params) args - ppArgTy = (ppCommaJoin $ map fst params) <> - (case argTy of - VarArgs -> text ", ..." - FixedArgs -> empty) - fnty = space <> lparen <> ppArgTy <> rparen - attrDoc = ppSpaceJoin attrs - in tc <> text "call" <+> ppr cc <+> ppr ret - <> fnty <+> ppName fptr <> lparen <+> ppValues - <+> rparen <+> attrDoc - - ppCallParams :: [[LlvmParamAttr]] -> [MetaExpr] -> SDoc - ppCallParams attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args - where - -- Metadata needs to be marked as having the `metadata` type when used - -- in a call argument - ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs v - ppCallMetaExpr _ v = text "metadata" <+> ppr v - -ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc -ppMachOp op left right = - (ppr op) <+> (ppr (getVarType left)) <+> ppName left - <> comma <+> ppName right - - -ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc -ppCmpOp op left right = - let cmpOp - | isInt (getVarType left) && isInt (getVarType right) = text "icmp" - | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" - | otherwise = text "icmp" -- Just continue as its much easier to debug - {- - | otherwise = error ("can't compare different types, left = " - ++ (show $ getVarType left) ++ ", right = " - ++ (show $ getVarType right)) - -} - in cmpOp <+> ppr op <+> ppr (getVarType left) - <+> ppName left <> comma <+> ppName right - - -ppAssignment :: LlvmVar -> SDoc -> SDoc -ppAssignment var expr = ppName var <+> equals <+> expr - -ppFence :: Bool -> LlvmSyncOrdering -> SDoc -ppFence st ord = - let singleThread = case st of True -> text "singlethread" - False -> empty - in text "fence" <+> singleThread <+> ppSyncOrdering ord - -ppSyncOrdering :: LlvmSyncOrdering -> SDoc -ppSyncOrdering SyncUnord = text "unordered" -ppSyncOrdering SyncMonotonic = text "monotonic" -ppSyncOrdering SyncAcquire = text "acquire" -ppSyncOrdering SyncRelease = text "release" -ppSyncOrdering SyncAcqRel = text "acq_rel" -ppSyncOrdering SyncSeqCst = text "seq_cst" - -ppAtomicOp :: LlvmAtomicOp -> SDoc -ppAtomicOp LAO_Xchg = text "xchg" -ppAtomicOp LAO_Add = text "add" -ppAtomicOp LAO_Sub = text "sub" -ppAtomicOp LAO_And = text "and" -ppAtomicOp LAO_Nand = text "nand" -ppAtomicOp LAO_Or = text "or" -ppAtomicOp LAO_Xor = text "xor" -ppAtomicOp LAO_Max = text "max" -ppAtomicOp LAO_Min = text "min" -ppAtomicOp LAO_Umax = text "umax" -ppAtomicOp LAO_Umin = text "umin" - -ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc -ppAtomicRMW aop tgt src ordering = - text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma - <+> ppr src <+> ppSyncOrdering ordering - -ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar - -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc -ppCmpXChg addr old new s_ord f_ord = - text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new - <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord - --- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but --- we have no way of guaranteeing that this is true with GHC (we would need to --- modify the layout of the stack and closures, change the storage manager, --- etc.). So, we blindly tell LLVM that *any* vector store or load could be --- unaligned. In the future we may be able to guarantee that certain vector --- access patterns are aligned, in which case we will need a more granular way --- of specifying alignment. - -ppLoad :: LlvmVar -> SDoc -ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align - where - derefType = pLower $ getVarType var - align | isVector . pLower . getVarType $ var = text ", align 1" - | otherwise = empty - -ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc -ppALoad ord st var = sdocWithDynFlags $ \dflags -> - let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8 - align = text ", align" <+> ppr alignment - sThreaded | st = text " singlethread" - | otherwise = empty - derefType = pLower $ getVarType var - in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded - <+> ppSyncOrdering ord <> align - -ppStore :: LlvmVar -> LlvmVar -> SDoc -ppStore val dst - | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <> - comma <+> text "align 1" - | otherwise = text "store" <+> ppr val <> comma <+> ppr dst - where - isVecPtrVar :: LlvmVar -> Bool - isVecPtrVar = isVector . pLower . getVarType - - -ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc -ppCast op from to - = ppr op - <+> ppr (getVarType from) <+> ppName from - <+> text "to" - <+> ppr to - - -ppMalloc :: LlvmType -> Int -> SDoc -ppMalloc tp amount = - let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "malloc" <+> ppr tp <> comma <+> ppr amount' - - -ppAlloca :: LlvmType -> Int -> SDoc -ppAlloca tp amount = - let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "alloca" <+> ppr tp <> comma <+> ppr amount' - - -ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc -ppGetElementPtr inb ptr idx = - let indexes = comma <+> ppCommaJoin idx - inbound = if inb then text "inbounds" else empty - derefType = pLower $ getVarType ptr - in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr - <> indexes - - -ppReturn :: Maybe LlvmVar -> SDoc -ppReturn (Just var) = text "ret" <+> ppr var -ppReturn Nothing = text "ret" <+> ppr LMVoid - - -ppBranch :: LlvmVar -> SDoc -ppBranch var = text "br" <+> ppr var - - -ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc -ppBranchIf cond trueT falseT - = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT - - -ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc -ppPhi tp preds = - let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label - in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) - - -ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc -ppSwitch scrut dflt targets = - let ppTarget (val, lab) = ppr val <> comma <+> ppr lab - ppTargets xs = brackets $ vcat (map ppTarget xs) - in text "switch" <+> ppr scrut <> comma <+> ppr dflt - <+> ppTargets targets - - -ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc -ppAsm asm constraints rty vars sideeffect alignstack = - let asm' = doubleQuotes $ ftext asm - cons = doubleQuotes $ ftext constraints - rty' = ppr rty - vars' = lparen <+> ppCommaJoin vars <+> rparen - side = if sideeffect then text "sideeffect" else empty - align = if alignstack then text "alignstack" else empty - in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma - <+> cons <> vars' - -ppExtract :: LlvmVar -> LlvmVar -> SDoc -ppExtract vec idx = - text "extractelement" - <+> ppr (getVarType vec) <+> ppName vec <> comma - <+> ppr idx - -ppExtractV :: LlvmVar -> Int -> SDoc -ppExtractV struct idx = - text "extractvalue" - <+> ppr (getVarType struct) <+> ppName struct <> comma - <+> ppr idx - -ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc -ppInsert vec elt idx = - text "insertelement" - <+> ppr (getVarType vec) <+> ppName vec <> comma - <+> ppr (getVarType elt) <+> ppName elt <> comma - <+> ppr idx - - -ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc -ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta - -ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc -ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta - -ppMetaAnnots :: [MetaAnnot] -> SDoc -ppMetaAnnots meta = hcat $ map ppMeta meta - where - ppMeta (MetaAnnot name e) - = comma <+> exclamation <> ftext name <+> - case e of - MetaNode n -> ppr n - MetaStruct ms -> exclamation <> braces (ppCommaJoin ms) - other -> exclamation <> braces (ppr other) -- possible? - - --------------------------------------------------------------------------------- --- * Misc functions --------------------------------------------------------------------------------- - --- | Blank line. -newLine :: SDoc -newLine = empty - --- | Exclamation point. -exclamation :: SDoc -exclamation = char '!' diff --git a/llvmGen/Llvm/Types.hs b/llvmGen/Llvm/Types.hs deleted file mode 100644 --- a/llvmGen/Llvm/Types.hs +++ /dev/null @@ -1,896 +0,0 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} - --------------------------------------------------------------------------------- --- | The LLVM Type System. --- - -module Llvm.Types where - -#include "HsVersions.h" - -import GhcPrelude - -import Data.Char -import Data.Int -import Numeric - -import DynFlags -import FastString -import Outputable -import Unique - --- from NCG -import PprBase - -import GHC.Float - --- ----------------------------------------------------------------------------- --- * LLVM Basic Types and Variables --- - --- | A global mutable variable. Maybe defined or external -data LMGlobal = LMGlobal { - getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal' - getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal' - } - --- | A String in LLVM -type LMString = FastString - --- | A type alias -type LlvmAlias = (LMString, LlvmType) - --- | Llvm Types -data LlvmType - = LMInt Int -- ^ An integer with a given width in bits. - | LMFloat -- ^ 32 bit floating point - | LMDouble -- ^ 64 bit floating point - | LMFloat80 -- ^ 80 bit (x86 only) floating point - | LMFloat128 -- ^ 128 bit floating point - | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' - | LMArray Int LlvmType -- ^ An array of 'LlvmType' - | LMVector Int LlvmType -- ^ A vector of 'LlvmType' - | LMLabel -- ^ A 'LlvmVar' can represent a label (address) - | LMVoid -- ^ Void type - | LMStruct [LlvmType] -- ^ Packed structure type - | LMStructU [LlvmType] -- ^ Unpacked structure type - | LMAlias LlvmAlias -- ^ A type alias - | LMMetadata -- ^ LLVM Metadata - - -- | Function type, used to create pointers to functions - | LMFunction LlvmFunctionDecl - deriving (Eq) - -instance Outputable LlvmType where - ppr (LMInt size ) = char 'i' <> ppr size - ppr (LMFloat ) = text "float" - ppr (LMDouble ) = text "double" - ppr (LMFloat80 ) = text "x86_fp80" - ppr (LMFloat128 ) = text "fp128" - ppr (LMPointer x ) = ppr x <> char '*' - ppr (LMArray nr tp ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']' - ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>' - ppr (LMLabel ) = text "label" - ppr (LMVoid ) = text "void" - ppr (LMStruct tys ) = text "<{" <> ppCommaJoin tys <> text "}>" - ppr (LMStructU tys ) = text "{" <> ppCommaJoin tys <> text "}" - ppr (LMMetadata ) = text "metadata" - - ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) - = ppr r <+> lparen <> ppParams varg p <> rparen - - ppr (LMAlias (s,_)) = char '%' <> ftext s - -ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc -ppParams varg p - = let varg' = case varg of - VarArgs | null args -> sLit "..." - | otherwise -> sLit ", ..." - _otherwise -> sLit "" - -- by default we don't print param attributes - args = map fst p - in ppCommaJoin args <> ptext varg' - --- | An LLVM section definition. If Nothing then let LLVM decide the section -type LMSection = Maybe LMString -type LMAlign = Maybe Int - -data LMConst = Global -- ^ Mutable global variable - | Constant -- ^ Constant global variable - | Alias -- ^ Alias of another variable - deriving (Eq) - --- | LLVM Variables -data LlvmVar - -- | Variables with a global scope. - = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst - -- | Variables local to a function or parameters. - | LMLocalVar Unique LlvmType - -- | Named local variables. Sometimes we need to be able to explicitly name - -- variables (e.g for function arguments). - | LMNLocalVar LMString LlvmType - -- | A constant variable - | LMLitVar LlvmLit - deriving (Eq) - -instance Outputable LlvmVar where - ppr = ppVar' [] - -ppVar' :: [LlvmParamAttr] -> LlvmVar -> SDoc -ppVar' attrs v = case v of - LMLitVar x -> ppTypeLit' attrs x - x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName x - - --- | Llvm Literal Data. --- --- These can be used inline in expressions. -data LlvmLit - -- | Refers to an integer constant (i64 42). - = LMIntLit Integer LlvmType - -- | Floating point literal - | LMFloatLit Double LlvmType - -- | Literal NULL, only applicable to pointer types - | LMNullLit LlvmType - -- | Vector literal - | LMVectorLit [LlvmLit] - -- | Undefined value, random bit pattern. Useful for optimisations. - | LMUndefLit LlvmType - deriving (Eq) - -instance Outputable LlvmLit where - ppr = ppTypeLit' [] - -ppTypeLit' :: [LlvmParamAttr] -> LlvmLit -> SDoc -ppTypeLit' attrs l = case l of - l@(LMVectorLit {}) -> ppLit l - _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit l - - --- | Llvm Static Data. --- --- These represent the possible global level variables and constants. -data LlvmStatic - = LMComment LMString -- ^ A comment in a static section - | LMStaticLit LlvmLit -- ^ A static variant of a literal value - | LMUninitType LlvmType -- ^ For uninitialised data - | LMStaticStr LMString LlvmType -- ^ Defines a static 'LMString' - | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array - | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type - | LMStaticPointer LlvmVar -- ^ A pointer to other data - - -- static expressions, could split out but leave - -- for moment for ease of use. Not many of them. - - | LMTrunc LlvmStatic LlvmType -- ^ Truncate - | LMBitc LlvmStatic LlvmType -- ^ Pointer to Pointer conversion - | LMPtoI LlvmStatic LlvmType -- ^ Pointer to Integer conversion - | LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation - | LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation - -instance Outputable LlvmStatic where - ppr (LMComment s) = text "; " <> ftext s - ppr (LMStaticLit l ) = ppr l - ppr (LMUninitType t) = ppr t <> text " undef" - ppr (LMStaticStr s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\"" - ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']' - ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>" - ppr (LMStaticPointer v) = ppr v - ppr (LMTrunc v t) - = ppr t <> text " trunc (" <> ppr v <> text " to " <> ppr t <> char ')' - ppr (LMBitc v t) - = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')' - ppr (LMPtoI v t) - = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')' - - ppr (LMAdd s1 s2) - = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd" - ppr (LMSub s1 s2) - = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub" - - -pprSpecialStatic :: LlvmStatic -> SDoc -pprSpecialStatic (LMBitc v t) = - ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t - <> char ')' -pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v -pprSpecialStatic stat = ppr stat - - -pprStaticArith :: LlvmStatic -> LlvmStatic -> PtrString -> PtrString - -> String -> SDoc -pprStaticArith s1 s2 int_op float_op op_name = - let ty1 = getStatType s1 - op = if isFloat ty1 then float_op else int_op - in if ty1 == getStatType s2 - then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen - else sdocWithDynFlags $ \dflags -> - error $ op_name ++ " with different types! s1: " - ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2) - --- ----------------------------------------------------------------------------- --- ** Operations on LLVM Basic Types and Variables --- - --- | Return the variable name or value of the 'LlvmVar' --- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). -ppName :: LlvmVar -> SDoc -ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v -ppName v@(LMLocalVar {}) = char '%' <> ppPlainName v -ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v -ppName v@(LMLitVar {}) = ppPlainName v - --- | Return the variable name or value of the 'LlvmVar' --- in a plain textual representation (e.g. @x@, @y@ or @42@). -ppPlainName :: LlvmVar -> SDoc -ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x -ppPlainName (LMLocalVar x LMLabel ) = text (show x) -ppPlainName (LMLocalVar x _ ) = text ('l' : show x) -ppPlainName (LMNLocalVar x _ ) = ftext x -ppPlainName (LMLitVar x ) = ppLit x - --- | Print a literal value. No type. -ppLit :: LlvmLit -> SDoc -ppLit (LMIntLit i (LMInt 32)) = ppr (fromInteger i :: Int32) -ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64) -ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int) -ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r -ppLit (LMFloatLit r LMDouble) = ppDouble r -ppLit f@(LMFloatLit _ _) = sdocWithDynFlags (\dflags -> - error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f)) -ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>' -ppLit (LMNullLit _ ) = text "null" --- #11487 was an issue where we passed undef for some arguments --- that were actually live. By chance the registers holding those --- arguments usually happened to have the right values anyways, but --- that was not guaranteed. To find such bugs reliably, we set the --- flag below when validating, which replaces undef literals (at --- common types) with values that are likely to cause a crash or test --- failure. -ppLit (LMUndefLit t ) = sdocWithDynFlags f - where f dflags - | gopt Opt_LlvmFillUndefWithGarbage dflags, - Just lit <- garbageLit t = ppLit lit - | otherwise = text "undef" - -garbageLit :: LlvmType -> Maybe LlvmLit -garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t) - -- Use a value that looks like an untagged pointer, so we are more - -- likely to try to enter it -garbageLit t - | isFloat t = Just (LMFloatLit 12345678.9 t) -garbageLit t@(LMPointer _) = Just (LMNullLit t) - -- Using null isn't totally ideal, since some functions may check for null. - -- But producing another value is inconvenient since it needs a cast, - -- and the knowledge for how to format casts is in PpLlvm. -garbageLit _ = Nothing - -- More cases could be added, but this should do for now. - --- | Return the 'LlvmType' of the 'LlvmVar' -getVarType :: LlvmVar -> LlvmType -getVarType (LMGlobalVar _ y _ _ _ _) = y -getVarType (LMLocalVar _ y ) = y -getVarType (LMNLocalVar _ y ) = y -getVarType (LMLitVar l ) = getLitType l - --- | Return the 'LlvmType' of a 'LlvmLit' -getLitType :: LlvmLit -> LlvmType -getLitType (LMIntLit _ t) = t -getLitType (LMFloatLit _ t) = t -getLitType (LMVectorLit []) = panic "getLitType" -getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls)) -getLitType (LMNullLit t) = t -getLitType (LMUndefLit t) = t - --- | Return the 'LlvmType' of the 'LlvmStatic' -getStatType :: LlvmStatic -> LlvmType -getStatType (LMStaticLit l ) = getLitType l -getStatType (LMUninitType t) = t -getStatType (LMStaticStr _ t) = t -getStatType (LMStaticArray _ t) = t -getStatType (LMStaticStruc _ t) = t -getStatType (LMStaticPointer v) = getVarType v -getStatType (LMTrunc _ t) = t -getStatType (LMBitc _ t) = t -getStatType (LMPtoI _ t) = t -getStatType (LMAdd t _) = getStatType t -getStatType (LMSub t _) = getStatType t -getStatType (LMComment _) = error "Can't call getStatType on LMComment!" - --- | Return the 'LlvmLinkageType' for a 'LlvmVar' -getLink :: LlvmVar -> LlvmLinkageType -getLink (LMGlobalVar _ _ l _ _ _) = l -getLink _ = Internal - --- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' --- cannot be lifted. -pLift :: LlvmType -> LlvmType -pLift LMLabel = error "Labels are unliftable" -pLift LMVoid = error "Voids are unliftable" -pLift LMMetadata = error "Metadatas are unliftable" -pLift x = LMPointer x - --- | Lift a variable to 'LMPointer' type. -pVarLift :: LlvmVar -> LlvmVar -pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c -pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) -pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) -pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" - --- | Remove the pointer indirection of the supplied type. Only 'LMPointer' --- constructors can be lowered. -pLower :: LlvmType -> LlvmType -pLower (LMPointer x) = x -pLower x = pprPanic "llvmGen(pLower)" - $ ppr x <+> text " is a unlowerable type, need a pointer" - --- | Lower a variable of 'LMPointer' type. -pVarLower :: LlvmVar -> LlvmVar -pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c -pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t) -pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t) -pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!" - --- | Test if the given 'LlvmType' is an integer -isInt :: LlvmType -> Bool -isInt (LMInt _) = True -isInt _ = False - --- | Test if the given 'LlvmType' is a floating point type -isFloat :: LlvmType -> Bool -isFloat LMFloat = True -isFloat LMDouble = True -isFloat LMFloat80 = True -isFloat LMFloat128 = True -isFloat _ = False - --- | Test if the given 'LlvmType' is an 'LMPointer' construct -isPointer :: LlvmType -> Bool -isPointer (LMPointer _) = True -isPointer _ = False - --- | Test if the given 'LlvmType' is an 'LMVector' construct -isVector :: LlvmType -> Bool -isVector (LMVector {}) = True -isVector _ = False - --- | Test if a 'LlvmVar' is global. -isGlobal :: LlvmVar -> Bool -isGlobal (LMGlobalVar _ _ _ _ _ _) = True -isGlobal _ = False - --- | Width in bits of an 'LlvmType', returns 0 if not applicable -llvmWidthInBits :: DynFlags -> LlvmType -> Int -llvmWidthInBits _ (LMInt n) = n -llvmWidthInBits _ (LMFloat) = 32 -llvmWidthInBits _ (LMDouble) = 64 -llvmWidthInBits _ (LMFloat80) = 80 -llvmWidthInBits _ (LMFloat128) = 128 --- Could return either a pointer width here or the width of what --- it points to. We will go with the former for now. --- PMW: At least judging by the way LLVM outputs constants, pointers --- should use the former, but arrays the latter. -llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags) -llvmWidthInBits dflags (LMArray n t) = n * llvmWidthInBits dflags t -llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty -llvmWidthInBits _ LMLabel = 0 -llvmWidthInBits _ LMVoid = 0 -llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys -llvmWidthInBits _ (LMStructU _) = - -- It's not trivial to calculate the bit width of the unpacked structs, - -- since they will be aligned depending on the specified datalayout ( - -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support - -- this could be to make the LlvmCodeGen.Ppr.moduleLayout be a data type - -- that exposes the alignment information. However, currently the only place - -- we use unpacked structs is LLVM intrinsics that return them (e.g., - -- llvm.sadd.with.overflow.*), so we don't actually need to compute their - -- bit width. - panic "llvmWidthInBits: not implemented for LMStructU" -llvmWidthInBits _ (LMFunction _) = 0 -llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t -llvmWidthInBits _ LMMetadata = panic "llvmWidthInBits: Meta-data has no runtime representation!" - - --- ----------------------------------------------------------------------------- --- ** Shortcut for Common Types --- - -i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType -i128 = LMInt 128 -i64 = LMInt 64 -i32 = LMInt 32 -i16 = LMInt 16 -i8 = LMInt 8 -i1 = LMInt 1 -i8Ptr = pLift i8 - --- | The target architectures word size -llvmWord, llvmWordPtr :: DynFlags -> LlvmType -llvmWord dflags = LMInt (wORD_SIZE dflags * 8) -llvmWordPtr dflags = pLift (llvmWord dflags) - --- ----------------------------------------------------------------------------- --- * LLVM Function Types --- - --- | An LLVM Function -data LlvmFunctionDecl = LlvmFunctionDecl { - -- | Unique identifier of the function - decName :: LMString, - -- | LinkageType of the function - funcLinkage :: LlvmLinkageType, - -- | The calling convention of the function - funcCc :: LlvmCallConvention, - -- | Type of the returned value - decReturnType :: LlvmType, - -- | Indicates if this function uses varargs - decVarargs :: LlvmParameterListType, - -- | Parameter types and attributes - decParams :: [LlvmParameter], - -- | Function align value, must be power of 2 - funcAlign :: LMAlign - } - deriving (Eq) - -instance Outputable LlvmFunctionDecl where - ppr (LlvmFunctionDecl n l c r varg p a) - = let align = case a of - Just a' -> text " align " <> ppr a' - Nothing -> empty - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> - lparen <> ppParams varg p <> rparen <> align - -type LlvmFunctionDecls = [LlvmFunctionDecl] - -type LlvmParameter = (LlvmType, [LlvmParamAttr]) - --- | LLVM Parameter Attributes. --- --- Parameter attributes are used to communicate additional information about --- the result or parameters of a function -data LlvmParamAttr - -- | This indicates to the code generator that the parameter or return value - -- should be zero-extended to a 32-bit value by the caller (for a parameter) - -- or the callee (for a return value). - = ZeroExt - -- | This indicates to the code generator that the parameter or return value - -- should be sign-extended to a 32-bit value by the caller (for a parameter) - -- or the callee (for a return value). - | SignExt - -- | This indicates that this parameter or return value should be treated in - -- a special target-dependent fashion during while emitting code for a - -- function call or return (usually, by putting it in a register as opposed - -- to memory). - | InReg - -- | This indicates that the pointer parameter should really be passed by - -- value to the function. - | ByVal - -- | This indicates that the pointer parameter specifies the address of a - -- structure that is the return value of the function in the source program. - | SRet - -- | This indicates that the pointer does not alias any global or any other - -- parameter. - | NoAlias - -- | This indicates that the callee does not make any copies of the pointer - -- that outlive the callee itself - | NoCapture - -- | This indicates that the pointer parameter can be excised using the - -- trampoline intrinsics. - | Nest - deriving (Eq) - -instance Outputable LlvmParamAttr where - ppr ZeroExt = text "zeroext" - ppr SignExt = text "signext" - ppr InReg = text "inreg" - ppr ByVal = text "byval" - ppr SRet = text "sret" - ppr NoAlias = text "noalias" - ppr NoCapture = text "nocapture" - ppr Nest = text "nest" - --- | Llvm Function Attributes. --- --- Function attributes are set to communicate additional information about a --- function. Function attributes are considered to be part of the function, --- not of the function type, so functions with different parameter attributes --- can have the same function type. Functions can have multiple attributes. --- --- Descriptions taken from -data LlvmFuncAttr - -- | This attribute indicates that the inliner should attempt to inline this - -- function into callers whenever possible, ignoring any active inlining - -- size threshold for this caller. - = AlwaysInline - -- | This attribute indicates that the source code contained a hint that - -- inlining this function is desirable (such as the \"inline\" keyword in - -- C/C++). It is just a hint; it imposes no requirements on the inliner. - | InlineHint - -- | This attribute indicates that the inliner should never inline this - -- function in any situation. This attribute may not be used together - -- with the alwaysinline attribute. - | NoInline - -- | This attribute suggests that optimization passes and code generator - -- passes make choices that keep the code size of this function low, and - -- otherwise do optimizations specifically to reduce code size. - | OptSize - -- | This function attribute indicates that the function never returns - -- normally. This produces undefined behavior at runtime if the function - -- ever does dynamically return. - | NoReturn - -- | This function attribute indicates that the function never returns with - -- an unwind or exceptional control flow. If the function does unwind, its - -- runtime behavior is undefined. - | NoUnwind - -- | This attribute indicates that the function computes its result (or - -- decides to unwind an exception) based strictly on its arguments, without - -- dereferencing any pointer arguments or otherwise accessing any mutable - -- state (e.g. memory, control registers, etc) visible to caller functions. - -- It does not write through any pointer arguments (including byval - -- arguments) and never changes any state visible to callers. This means - -- that it cannot unwind exceptions by calling the C++ exception throwing - -- methods, but could use the unwind instruction. - | ReadNone - -- | This attribute indicates that the function does not write through any - -- pointer arguments (including byval arguments) or otherwise modify any - -- state (e.g. memory, control registers, etc) visible to caller functions. - -- It may dereference pointer arguments and read state that may be set in - -- the caller. A readonly function always returns the same value (or unwinds - -- an exception identically) when called with the same set of arguments and - -- global state. It cannot unwind an exception by calling the C++ exception - -- throwing methods, but may use the unwind instruction. - | ReadOnly - -- | This attribute indicates that the function should emit a stack smashing - -- protector. It is in the form of a \"canary\"—a random value placed on the - -- stack before the local variables that's checked upon return from the - -- function to see if it has been overwritten. A heuristic is used to - -- determine if a function needs stack protectors or not. - -- - -- If a function that has an ssp attribute is inlined into a function that - -- doesn't have an ssp attribute, then the resulting function will have an - -- ssp attribute. - | Ssp - -- | This attribute indicates that the function should always emit a stack - -- smashing protector. This overrides the ssp function attribute. - -- - -- If a function that has an sspreq attribute is inlined into a function - -- that doesn't have an sspreq attribute or which has an ssp attribute, - -- then the resulting function will have an sspreq attribute. - | SspReq - -- | This attribute indicates that the code generator should not use a red - -- zone, even if the target-specific ABI normally permits it. - | NoRedZone - -- | This attributes disables implicit floating point instructions. - | NoImplicitFloat - -- | This attribute disables prologue / epilogue emission for the function. - -- This can have very system-specific consequences. - | Naked - deriving (Eq) - -instance Outputable LlvmFuncAttr where - ppr AlwaysInline = text "alwaysinline" - ppr InlineHint = text "inlinehint" - ppr NoInline = text "noinline" - ppr OptSize = text "optsize" - ppr NoReturn = text "noreturn" - ppr NoUnwind = text "nounwind" - ppr ReadNone = text "readnon" - ppr ReadOnly = text "readonly" - ppr Ssp = text "ssp" - ppr SspReq = text "ssqreq" - ppr NoRedZone = text "noredzone" - ppr NoImplicitFloat = text "noimplicitfloat" - ppr Naked = text "naked" - - --- | Different types to call a function. -data LlvmCallType - -- | Normal call, allocate a new stack frame. - = StdCall - -- | Tail call, perform the call in the current stack frame. - | TailCall - deriving (Eq,Show) - --- | Different calling conventions a function can use. -data LlvmCallConvention - -- | The C calling convention. - -- This calling convention (the default if no other calling convention is - -- specified) matches the target C calling conventions. This calling - -- convention supports varargs function calls and tolerates some mismatch in - -- the declared prototype and implemented declaration of the function (as - -- does normal C). - = CC_Ccc - -- | This calling convention attempts to make calls as fast as possible - -- (e.g. by passing things in registers). This calling convention allows - -- the target to use whatever tricks it wants to produce fast code for the - -- target, without having to conform to an externally specified ABI - -- (Application Binary Interface). Implementations of this convention should - -- allow arbitrary tail call optimization to be supported. This calling - -- convention does not support varargs and requires the prototype of al - -- callees to exactly match the prototype of the function definition. - | CC_Fastcc - -- | This calling convention attempts to make code in the caller as efficient - -- as possible under the assumption that the call is not commonly executed. - -- As such, these calls often preserve all registers so that the call does - -- not break any live ranges in the caller side. This calling convention - -- does not support varargs and requires the prototype of all callees to - -- exactly match the prototype of the function definition. - | CC_Coldcc - -- | The GHC-specific 'registerised' calling convention. - | CC_Ghc - -- | Any calling convention may be specified by number, allowing - -- target-specific calling conventions to be used. Target specific calling - -- conventions start at 64. - | CC_Ncc Int - -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it - -- rather than just using CC_Ncc. - | CC_X86_Stdcc - deriving (Eq) - -instance Outputable LlvmCallConvention where - ppr CC_Ccc = text "ccc" - ppr CC_Fastcc = text "fastcc" - ppr CC_Coldcc = text "coldcc" - ppr CC_Ghc = text "ghccc" - ppr (CC_Ncc i) = text "cc " <> ppr i - ppr CC_X86_Stdcc = text "x86_stdcallcc" - - --- | Functions can have a fixed amount of parameters, or a variable amount. -data LlvmParameterListType - -- Fixed amount of arguments. - = FixedArgs - -- Variable amount of arguments. - | VarArgs - deriving (Eq,Show) - - --- | Linkage type of a symbol. --- --- The description of the constructors is copied from the Llvm Assembly Language --- Reference Manual , because --- they correspond to the Llvm linkage types. -data LlvmLinkageType - -- | Global values with internal linkage are only directly accessible by - -- objects in the current module. In particular, linking code into a module - -- with an internal global value may cause the internal to be renamed as - -- necessary to avoid collisions. Because the symbol is internal to the - -- module, all references can be updated. This corresponds to the notion - -- of the @static@ keyword in C. - = Internal - -- | Globals with @linkonce@ linkage are merged with other globals of the - -- same name when linkage occurs. This is typically used to implement - -- inline functions, templates, or other code which must be generated - -- in each translation unit that uses it. Unreferenced linkonce globals are - -- allowed to be discarded. - | LinkOnce - -- | @weak@ linkage is exactly the same as linkonce linkage, except that - -- unreferenced weak globals may not be discarded. This is used for globals - -- that may be emitted in multiple translation units, but that are not - -- guaranteed to be emitted into every translation unit that uses them. One - -- example of this are common globals in C, such as @int X;@ at global - -- scope. - | Weak - -- | @appending@ linkage may only be applied to global variables of pointer - -- to array type. When two global variables with appending linkage are - -- linked together, the two global arrays are appended together. This is - -- the Llvm, typesafe, equivalent of having the system linker append - -- together @sections@ with identical names when .o files are linked. - | Appending - -- | The semantics of this linkage follow the ELF model: the symbol is weak - -- until linked, if not linked, the symbol becomes null instead of being an - -- undefined reference. - | ExternWeak - -- | The symbol participates in linkage and can be used to resolve external - -- symbol references. - | ExternallyVisible - -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM - -- assembly. - | External - -- | Symbol is private to the module and should not appear in the symbol table - | Private - deriving (Eq) - -instance Outputable LlvmLinkageType where - ppr Internal = text "internal" - ppr LinkOnce = text "linkonce" - ppr Weak = text "weak" - ppr Appending = text "appending" - ppr ExternWeak = text "extern_weak" - -- ExternallyVisible does not have a textual representation, it is - -- the linkage type a function resolves to if no other is specified - -- in Llvm. - ppr ExternallyVisible = empty - ppr External = text "external" - ppr Private = text "private" - --- ----------------------------------------------------------------------------- --- * LLVM Operations --- - --- | Llvm binary operators machine operations. -data LlvmMachOp - = LM_MO_Add -- ^ add two integer, floating point or vector values. - | LM_MO_Sub -- ^ subtract two ... - | LM_MO_Mul -- ^ multiply .. - | LM_MO_UDiv -- ^ unsigned integer or vector division. - | LM_MO_SDiv -- ^ signed integer .. - | LM_MO_URem -- ^ unsigned integer or vector remainder (mod) - | LM_MO_SRem -- ^ signed ... - - | LM_MO_FAdd -- ^ add two floating point or vector values. - | LM_MO_FSub -- ^ subtract two ... - | LM_MO_FMul -- ^ multiply ... - | LM_MO_FDiv -- ^ divide ... - | LM_MO_FRem -- ^ remainder ... - - -- | Left shift - | LM_MO_Shl - -- | Logical shift right - -- Shift right, filling with zero - | LM_MO_LShr - -- | Arithmetic shift right - -- The most significant bits of the result will be equal to the sign bit of - -- the left operand. - | LM_MO_AShr - - | LM_MO_And -- ^ AND bitwise logical operation. - | LM_MO_Or -- ^ OR bitwise logical operation. - | LM_MO_Xor -- ^ XOR bitwise logical operation. - deriving (Eq) - -instance Outputable LlvmMachOp where - ppr LM_MO_Add = text "add" - ppr LM_MO_Sub = text "sub" - ppr LM_MO_Mul = text "mul" - ppr LM_MO_UDiv = text "udiv" - ppr LM_MO_SDiv = text "sdiv" - ppr LM_MO_URem = text "urem" - ppr LM_MO_SRem = text "srem" - ppr LM_MO_FAdd = text "fadd" - ppr LM_MO_FSub = text "fsub" - ppr LM_MO_FMul = text "fmul" - ppr LM_MO_FDiv = text "fdiv" - ppr LM_MO_FRem = text "frem" - ppr LM_MO_Shl = text "shl" - ppr LM_MO_LShr = text "lshr" - ppr LM_MO_AShr = text "ashr" - ppr LM_MO_And = text "and" - ppr LM_MO_Or = text "or" - ppr LM_MO_Xor = text "xor" - - --- | Llvm compare operations. -data LlvmCmpOp - = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) - | LM_CMP_Ne -- ^ Not equal (Signed and Unsigned) - | LM_CMP_Ugt -- ^ Unsigned greater than - | LM_CMP_Uge -- ^ Unsigned greater than or equal - | LM_CMP_Ult -- ^ Unsigned less than - | LM_CMP_Ule -- ^ Unsigned less than or equal - | LM_CMP_Sgt -- ^ Signed greater than - | LM_CMP_Sge -- ^ Signed greater than or equal - | LM_CMP_Slt -- ^ Signed less than - | LM_CMP_Sle -- ^ Signed less than or equal - - -- Float comparisons. GHC uses a mix of ordered and unordered float - -- comparisons. - | LM_CMP_Feq -- ^ Float equal - | LM_CMP_Fne -- ^ Float not equal - | LM_CMP_Fgt -- ^ Float greater than - | LM_CMP_Fge -- ^ Float greater than or equal - | LM_CMP_Flt -- ^ Float less than - | LM_CMP_Fle -- ^ Float less than or equal - deriving (Eq) - -instance Outputable LlvmCmpOp where - ppr LM_CMP_Eq = text "eq" - ppr LM_CMP_Ne = text "ne" - ppr LM_CMP_Ugt = text "ugt" - ppr LM_CMP_Uge = text "uge" - ppr LM_CMP_Ult = text "ult" - ppr LM_CMP_Ule = text "ule" - ppr LM_CMP_Sgt = text "sgt" - ppr LM_CMP_Sge = text "sge" - ppr LM_CMP_Slt = text "slt" - ppr LM_CMP_Sle = text "sle" - ppr LM_CMP_Feq = text "oeq" - ppr LM_CMP_Fne = text "une" - ppr LM_CMP_Fgt = text "ogt" - ppr LM_CMP_Fge = text "oge" - ppr LM_CMP_Flt = text "olt" - ppr LM_CMP_Fle = text "ole" - - --- | Llvm cast operations. -data LlvmCastOp - = LM_Trunc -- ^ Integer truncate - | LM_Zext -- ^ Integer extend (zero fill) - | LM_Sext -- ^ Integer extend (sign fill) - | LM_Fptrunc -- ^ Float truncate - | LM_Fpext -- ^ Float extend - | LM_Fptoui -- ^ Float to unsigned Integer - | LM_Fptosi -- ^ Float to signed Integer - | LM_Uitofp -- ^ Unsigned Integer to Float - | LM_Sitofp -- ^ Signed Int to Float - | LM_Ptrtoint -- ^ Pointer to Integer - | LM_Inttoptr -- ^ Integer to Pointer - | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed - deriving (Eq) - -instance Outputable LlvmCastOp where - ppr LM_Trunc = text "trunc" - ppr LM_Zext = text "zext" - ppr LM_Sext = text "sext" - ppr LM_Fptrunc = text "fptrunc" - ppr LM_Fpext = text "fpext" - ppr LM_Fptoui = text "fptoui" - ppr LM_Fptosi = text "fptosi" - ppr LM_Uitofp = text "uitofp" - ppr LM_Sitofp = text "sitofp" - ppr LM_Ptrtoint = text "ptrtoint" - ppr LM_Inttoptr = text "inttoptr" - ppr LM_Bitcast = text "bitcast" - - --- ----------------------------------------------------------------------------- --- * Floating point conversion --- - --- | Convert a Haskell Double to an LLVM hex encoded floating point form. In --- Llvm float literals can be printed in a big-endian hexadecimal format, --- regardless of underlying architecture. --- --- See Note [LLVM Float Types]. -ppDouble :: Double -> SDoc -ppDouble d - = let bs = doubleToBytes d - hex d' = case showHex d' "" of - [] -> error "dToStr: too few hex digits for float" - [x] -> ['0',x] - [x,y] -> [x,y] - _ -> error "dToStr: too many hex digits for float" - - in sdocWithDynFlags (\dflags -> - let fixEndian = if wORDS_BIGENDIAN dflags then id else reverse - str = map toUpper $ concat $ fixEndian $ map hex bs - in text "0x" <> text str) - --- Note [LLVM Float Types] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- We use 'ppDouble' for both printing Float and Double floating point types. This is --- as LLVM expects all floating point constants (single & double) to be in IEEE --- 754 Double precision format. However, for single precision numbers (Float) --- they should be *representable* in IEEE 754 Single precision format. So the --- easiest way to do this is to narrow and widen again. --- (i.e., Double -> Float -> Double). We must be careful doing this that GHC --- doesn't optimize that away. - --- Note [narrowFp & widenFp] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- NOTE: we use float2Double & co directly as GHC likes to optimize away --- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600). --- 'realToFrac' has inconsistent behaviour with optimisation as well that can --- also cause issues, these methods don't. - -narrowFp :: Double -> Float -{-# NOINLINE narrowFp #-} -narrowFp = double2Float - -widenFp :: Float -> Double -{-# NOINLINE widenFp #-} -widenFp = float2Double - -ppFloat :: Float -> SDoc -ppFloat = ppDouble . widenFp - - --------------------------------------------------------------------------------- --- * Misc functions --------------------------------------------------------------------------------- - -ppCommaJoin :: (Outputable a) => [a] -> SDoc -ppCommaJoin strs = hsep $ punctuate comma (map ppr strs) - -ppSpaceJoin :: (Outputable a) => [a] -> SDoc -ppSpaceJoin strs = hsep (map ppr strs) diff --git a/llvmGen/LlvmCodeGen.hs b/llvmGen/LlvmCodeGen.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-} - --- ----------------------------------------------------------------------------- --- | This is the top-level module in the LLVM code generator. --- -module LlvmCodeGen ( LlvmVersion, llvmVersionList, llvmCodeGen, llvmFixupAsm ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Llvm -import LlvmCodeGen.Base -import LlvmCodeGen.CodeGen -import LlvmCodeGen.Data -import LlvmCodeGen.Ppr -import LlvmCodeGen.Regs -import LlvmMangler - -import GHC.StgToCmm.CgUtils ( fixStgRegisters ) -import Cmm -import Hoopl.Collections -import PprCmm - -import BufWrite -import DynFlags -import GHC.Platform ( platformArch, Arch(..) ) -import ErrUtils -import FastString -import Outputable -import SysTools ( figureLlvmVersion ) -import qualified Stream - -import Control.Monad ( when, forM_ ) -import Data.Maybe ( fromMaybe, catMaybes ) -import System.IO - --- ----------------------------------------------------------------------------- --- | Top-level of the LLVM Code generator --- -llvmCodeGen :: DynFlags -> Handle - -> Stream.Stream IO RawCmmGroup a - -> IO a -llvmCodeGen dflags h cmm_stream - = withTiming dflags (text "LLVM CodeGen") (const ()) $ do - bufh <- newBufHandle h - - -- Pass header - showPass dflags "LLVM CodeGen" - - -- get llvm version, cache for later use - mb_ver <- figureLlvmVersion dflags - - -- warn if unsupported - forM_ mb_ver $ \ver -> do - debugTraceMsg dflags 2 - (text "Using LLVM version:" <+> text (llvmVersionStr ver)) - let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $ - "You are using an unsupported version of LLVM!" $$ - "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+> - "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+> - "System LLVM version: " <> text (llvmVersionStr ver) $$ - "We will try though..." - let isS390X = platformArch (targetPlatform dflags) == ArchS390X - let major_ver = head . llvmVersionList $ ver - when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $ - "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> - "You are using LLVM version: " <> text (llvmVersionStr ver) - - -- HACK: the Nothing case here is potentially wrong here but we - -- currently don't use the LLVM version to guide code generation - -- so this is okay. - let llvm_ver :: LlvmVersion - llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver - - -- run code generation - a <- runLlvm dflags llvm_ver bufh $ - llvmCodeGen' (liftStream cmm_stream) - - bFlush bufh - - return a - -llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup a -> LlvmM a -llvmCodeGen' cmm_stream - = do -- Preamble - renderLlvm header - ghcInternalFunctions - cmmMetaLlvmPrelude - - -- Procedures - a <- Stream.consume cmm_stream llvmGroupLlvmGens - - -- Declare aliases for forward references - renderLlvm . pprLlvmData =<< generateExternDecls - - -- Postamble - cmmUsedLlvmGens - - return a - where - header :: SDoc - header = sdocWithDynFlags $ \dflags -> - let target = platformMisc_llvmTarget $ platformMisc dflags - in text ("target datalayout = \"" ++ getDataLayout dflags target ++ "\"") - $+$ text ("target triple = \"" ++ target ++ "\"") - - getDataLayout :: DynFlags -> String -> String - getDataLayout dflags target = - case lookup target (llvmTargets $ llvmConfig dflags) of - Just (LlvmTarget {lDataLayout=dl}) -> dl - Nothing -> pprPanic "Failed to lookup LLVM data layout" $ - text "Target:" <+> text target $$ - hang (text "Available targets:") 4 - (vcat $ map (text . fst) $ llvmTargets $ llvmConfig dflags) - -llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () -llvmGroupLlvmGens cmm = do - - -- Insert functions into map, collect data - let split (CmmData s d' ) = return $ Just (s, d') - split (CmmProc h l live g) = do - -- Set function type - let l' = case mapLookup (g_entry g) h of - Nothing -> l - Just (Statics info_lbl _) -> info_lbl - lml <- strCLabel_llvm l' - funInsert lml =<< llvmFunTy live - return Nothing - cdata <- fmap catMaybes $ mapM split cmm - - {-# SCC "llvm_datas_gen" #-} - cmmDataLlvmGens cdata - {-# SCC "llvm_procs_gen" #-} - mapM_ cmmLlvmGen cmm - --- ----------------------------------------------------------------------------- --- | Do LLVM code generation on all these Cmms data sections. --- -cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM () - -cmmDataLlvmGens statics - = do lmdatas <- mapM genLlvmData statics - - let (concat -> gs, tss) = unzip lmdatas - - let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _) - = funInsert l ty - regGlobal _ = pure () - mapM_ regGlobal gs - gss' <- mapM aliasify $ gs - - renderLlvm $ pprLlvmData (concat gss', concat tss) - --- | Complete LLVM code generation phase for a single top-level chunk of Cmm. -cmmLlvmGen ::RawCmmDecl -> LlvmM () -cmmLlvmGen cmm@CmmProc{} = do - - -- rewrite assignments to global regs - dflags <- getDynFlag id - let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm - - dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) - - -- generate llvm code from cmm - llvmBC <- withClearVars $ genLlvmProc fixed_cmm - - -- pretty print - (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC - - -- Output, note down used variables - renderLlvm (vcat docs) - mapM_ markUsedVar $ concat ivars - -cmmLlvmGen _ = return () - --- ----------------------------------------------------------------------------- --- | Generate meta data nodes --- - -cmmMetaLlvmPrelude :: LlvmM () -cmmMetaLlvmPrelude = do - metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do - -- Generate / lookup meta data IDs - tbaaId <- getMetaUniqueId - setUniqMeta uniq tbaaId - parentId <- maybe (return Nothing) getUniqMeta parent - -- Build definition - return $ MetaUnnamed tbaaId $ MetaStruct $ - case parentId of - Just p -> [ MetaStr name, MetaNode p ] - -- As of LLVM 4.0, a node without parents should be rendered as - -- just a name on its own. Previously `null` was accepted as the - -- name. - Nothing -> [ MetaStr name ] - renderLlvm $ ppLlvmMetas metas - --- ----------------------------------------------------------------------------- --- | Marks variables as used where necessary --- - -cmmUsedLlvmGens :: LlvmM () -cmmUsedLlvmGens = do - - -- LLVM would discard variables that are internal and not obviously - -- used if we didn't provide these hints. This will generate a - -- definition of the form - -- - -- @llvm.used = appending global [42 x i8*] [i8* bitcast to i8*, ...] - -- - -- Which is the LLVM way of protecting them against getting removed. - ivars <- getUsedVars - let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr - ty = (LMArray (length ivars) i8Ptr) - usedArray = LMStaticArray (map cast ivars) ty - sectName = Just $ fsLit "llvm.metadata" - lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant - lmUsed = LMGlobal lmUsedVar (Just usedArray) - if null ivars - then return () - else renderLlvm $ pprLlvmData ([lmUsed], []) diff --git a/llvmGen/LlvmCodeGen/Base.hs b/llvmGen/LlvmCodeGen/Base.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Base.hs +++ /dev/null @@ -1,687 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - --- ---------------------------------------------------------------------------- --- | Base LLVM Code Generation module --- --- Contains functions useful through out the code generator. --- - -module LlvmCodeGen.Base ( - - LlvmCmmDecl, LlvmBasicBlock, - LiveGlobalRegs, - LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - - LlvmVersion, llvmVersionSupported, parseLlvmVersion, - supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, - llvmVersionStr, llvmVersionList, - - LlvmM, - runLlvm, liftStream, withClearVars, varLookup, varInsert, - markStackReg, checkStackReg, - funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, - dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars, - ghcInternalFunctions, - - getMetaUniqueId, - setUniqMeta, getUniqMeta, - - cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, - llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, - llvmPtrBits, tysToParams, llvmFunSection, - - strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, - getGlobalPtr, generateExternDecls, - - aliasify, llvmDefLabel, - - padLiveArgs, isFPR - ) where - -#include "HsVersions.h" -#include "ghcautoconf.h" - -import GhcPrelude - -import Llvm -import LlvmCodeGen.Regs -import Panic - -import PprCmm () -import CLabel -import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) -import DynFlags -import FastString -import Cmm hiding ( succ ) -import CmmUtils (regsOverlap) -import Outputable as Outp -import GHC.Platform -import UniqFM -import Unique -import BufWrite ( BufHandle ) -import UniqSet -import UniqSupply -import ErrUtils -import qualified Stream - -import Data.Maybe (fromJust) -import Control.Monad (ap) -import Data.Char (isDigit) -import Data.List (sortBy, groupBy, intercalate) -import Data.Ord (comparing) -import qualified Data.List.NonEmpty as NE - --- ---------------------------------------------------------------------------- --- * Some Data Types --- - -type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) -type LlvmBasicBlock = GenBasicBlock LlvmStatement - --- | Global registers live on proc entry -type LiveGlobalRegs = [GlobalReg] - --- | Unresolved code. --- Of the form: (data label, data type, unresolved data) -type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) - --- | Top level LLVM Data (globals and type aliases) -type LlvmData = ([LMGlobal], [LlvmType]) - --- | An unresolved Label. --- --- Labels are unresolved when we haven't yet determined if they are defined in --- the module we are currently compiling, or an external one. -type UnresLabel = CmmLit -type UnresStatic = Either UnresLabel LlvmStatic - --- ---------------------------------------------------------------------------- --- * Type translations --- - --- | Translate a basic CmmType to an LlvmType. -cmmToLlvmType :: CmmType -> LlvmType -cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty)) - | isFloatType ty = widthToLlvmFloat $ typeWidth ty - | otherwise = widthToLlvmInt $ typeWidth ty - --- | Translate a Cmm Float Width to a LlvmType. -widthToLlvmFloat :: Width -> LlvmType -widthToLlvmFloat W32 = LMFloat -widthToLlvmFloat W64 = LMDouble -widthToLlvmFloat W128 = LMFloat128 -widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w - --- | Translate a Cmm Bit Width to a LlvmType. -widthToLlvmInt :: Width -> LlvmType -widthToLlvmInt w = LMInt $ widthInBits w - --- | GHC Call Convention for LLVM -llvmGhcCC :: DynFlags -> LlvmCallConvention -llvmGhcCC dflags - | platformUnregisterised (targetPlatform dflags) = CC_Ccc - | otherwise = CC_Ghc - --- | Llvm Function type for Cmm function -llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType -llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible - --- | Llvm Function signature -llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl -llvmFunSig live lbl link = do - lbl' <- strCLabel_llvm lbl - llvmFunSig' live lbl' link - -llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl -llvmFunSig' live lbl link - = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) - | otherwise = (x, []) - dflags <- getDynFlags - return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs dflags live)) - (llvmFunAlign dflags) - --- | Alignment to use for functions -llvmFunAlign :: DynFlags -> LMAlign -llvmFunAlign dflags = Just (wORD_SIZE dflags) - --- | Alignment to use for into tables -llvmInfAlign :: DynFlags -> LMAlign -llvmInfAlign dflags = Just (wORD_SIZE dflags) - --- | Section to use for a function -llvmFunSection :: DynFlags -> LMString -> LMSection -llvmFunSection dflags lbl - | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl]) - | otherwise = Nothing - --- | A Function's arguments -llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] -llvmFunArgs dflags live = - map (lmGlobalRegArg dflags) (filter isPassed allRegs) - where allRegs = activeStgRegs (targetPlatform dflags) - paddingRegs = padLiveArgs dflags live - isLive r = r `elem` alwaysLive - || r `elem` live - || r `elem` paddingRegs - isPassed r = not (isFPR r) || isLive r - - -isFPR :: GlobalReg -> Bool -isFPR (FloatReg _) = True -isFPR (DoubleReg _) = True -isFPR (XmmReg _) = True -isFPR (YmmReg _) = True -isFPR (ZmmReg _) = True -isFPR _ = False - --- | Return a list of "padding" registers for LLVM function calls. --- --- When we generate LLVM function signatures, we can't just make any register --- alive on function entry. Instead, we need to insert fake arguments of the --- same register class until we are sure that one of them is mapped to the --- register we want alive. E.g. to ensure that F5 is alive, we may need to --- insert fake arguments mapped to F1, F2, F3 and F4. --- --- Invariant: Cmm FPR regs with number "n" maps to real registers with number --- "n" If the calling convention uses registers in a different order or if the --- invariant doesn't hold, this code probably won't be correct. -padLiveArgs :: DynFlags -> LiveGlobalRegs -> LiveGlobalRegs -padLiveArgs dflags live = - if platformUnregisterised platform - then [] -- not using GHC's register convention for platform. - else padded - where - platform = targetPlatform dflags - - ---------------------------------- - -- handle floating-point registers (FPR) - - fprLive = filter isFPR live -- real live FPR registers - - -- we group live registers sharing the same classes, i.e. that use the same - -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg - -- all use the same real regs on X86-64 (XMM registers). - -- - classes = groupBy sharesClass fprLive - sharesClass a b = regsOverlap dflags (norm a) (norm b) -- check if mapped to overlapping registers - norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family - - -- For each class, we just have to fill missing registers numbers. We use - -- the constructor of the greatest register to build padding registers. - -- - -- E.g. sortedRs = [ F2, XMM4, D5] - -- output = [D1, D3] - padded = concatMap padClass classes - padClass rs = go sortedRs [1..] - where - sortedRs = sortBy (comparing fpr_num) rs - maxr = last sortedRs - ctor = fpr_ctor maxr - - go [] _ = [] - go (c1:c2:_) _ -- detect bogus case (see #17920) - | fpr_num c1 == fpr_num c2 - , Just real <- globalRegMaybe platform c1 - = sorryDoc "LLVM code generator" $ - text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <> - text ") both alive AND mapped to the same real register: " <> ppr real <> - text ". This isn't currently supported by the LLVM backend." - go (c:cs) (f:fs) - | fpr_num c == f = go cs fs -- already covered by a real register - | otherwise = ctor f : go (c:cs) fs -- add padding register - go _ _ = undefined -- unreachable - - fpr_ctor :: GlobalReg -> Int -> GlobalReg - fpr_ctor (FloatReg _) = FloatReg - fpr_ctor (DoubleReg _) = DoubleReg - fpr_ctor (XmmReg _) = XmmReg - fpr_ctor (YmmReg _) = YmmReg - fpr_ctor (ZmmReg _) = ZmmReg - fpr_ctor _ = error "fpr_ctor expected only FPR regs" - - fpr_num :: GlobalReg -> Int - fpr_num (FloatReg i) = i - fpr_num (DoubleReg i) = i - fpr_num (XmmReg i) = i - fpr_num (YmmReg i) = i - fpr_num (ZmmReg i) = i - fpr_num _ = error "fpr_num expected only FPR regs" - - --- | Llvm standard fun attributes -llvmStdFunAttrs :: [LlvmFuncAttr] -llvmStdFunAttrs = [NoUnwind] - --- | Convert a list of types to a list of function parameters --- (each with no parameter attributes) -tysToParams :: [LlvmType] -> [LlvmParameter] -tysToParams = map (\ty -> (ty, [])) - --- | Pointer width -llvmPtrBits :: DynFlags -> Int -llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags - --- ---------------------------------------------------------------------------- --- * Llvm Version --- - -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } - deriving (Eq, Ord) - -parseLlvmVersion :: String -> Maybe LlvmVersion -parseLlvmVersion = - fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit) - where - go vs s - | null ver_str - = reverse vs - | '.' : rest' <- rest - = go (read ver_str : vs) rest' - | otherwise - = reverse (read ver_str : vs) - where - (ver_str, rest) = span isDigit s - --- | The (inclusive) lower bound on the LLVM Version that is currently supported. -supportedLlvmVersionLowerBound :: LlvmVersion -supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) - --- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. -supportedLlvmVersionUpperBound :: LlvmVersion -supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) - -llvmVersionSupported :: LlvmVersion -> Bool -llvmVersionSupported v = - v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound - -llvmVersionStr :: LlvmVersion -> String -llvmVersionStr = intercalate "." . map show . llvmVersionList - -llvmVersionList :: LlvmVersion -> [Int] -llvmVersionList = NE.toList . llvmVersionNE - --- ---------------------------------------------------------------------------- --- * Environment Handling --- - -data LlvmEnv = LlvmEnv - { envVersion :: LlvmVersion -- ^ LLVM version - , envDynFlags :: DynFlags -- ^ Dynamic flags - , envOutput :: BufHandle -- ^ Output buffer - , envMask :: !Char -- ^ Mask for creating unique values - , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs - , envUniqMeta :: UniqFM MetaId -- ^ Global metadata nodes - , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type - , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] - , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) - - -- the following get cleared for every function (see @withClearVars@) - , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type - , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) - } - -type LlvmEnvMap = UniqFM LlvmType - --- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad -newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } - deriving (Functor) - -instance Applicative LlvmM where - pure x = LlvmM $ \env -> return (x, env) - (<*>) = ap - -instance Monad LlvmM where - m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env - runLlvmM (f x) env' - -instance HasDynFlags LlvmM where - getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) - -instance MonadUnique LlvmM where - getUniqueSupplyM = do - mask <- getEnv envMask - liftIO $! mkSplitUniqSupply mask - - getUniqueM = do - mask <- getEnv envMask - liftIO $! uniqFromMask mask - --- | Lifting of IO actions. Not exported, as we want to encapsulate IO. -liftIO :: IO a -> LlvmM a -liftIO m = LlvmM $ \env -> do x <- m - return (x, env) - --- | Get initial Llvm environment. -runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a -runLlvm dflags ver out m = do - (a, _) <- runLlvmM m env - return a - where env = LlvmEnv { envFunMap = emptyUFM - , envVarMap = emptyUFM - , envStackRegs = [] - , envUsedVars = [] - , envAliases = emptyUniqSet - , envVersion = ver - , envDynFlags = dflags - , envOutput = out - , envMask = 'n' - , envFreshMeta = MetaId 0 - , envUniqMeta = emptyUFM - } - --- | Get environment (internal) -getEnv :: (LlvmEnv -> a) -> LlvmM a -getEnv f = LlvmM (\env -> return (f env, env)) - --- | Modify environment (internal) -modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () -modifyEnv f = LlvmM (\env -> return ((), f env)) - --- | Lift a stream into the LlvmM monad -liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x -liftStream s = Stream.Stream $ do - r <- liftIO $ Stream.runStream s - case r of - Left b -> return (Left b) - Right (a, r2) -> return (Right (a, liftStream r2)) - --- | Clear variables from the environment for a subcomputation -withClearVars :: LlvmM a -> LlvmM a -withClearVars m = LlvmM $ \env -> do - (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } - return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) - --- | Insert variables or functions into the environment. -varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () -varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t } -funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t } - --- | Lookup variables or functions in the environment. -varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) -varLookup s = getEnv (flip lookupUFM s . envVarMap) -funLookup s = getEnv (flip lookupUFM s . envFunMap) - --- | Set a register as allocated on the stack -markStackReg :: GlobalReg -> LlvmM () -markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } - --- | Check whether a register is allocated on the stack -checkStackReg :: GlobalReg -> LlvmM Bool -checkStackReg r = getEnv ((elem r) . envStackRegs) - --- | Allocate a new global unnamed metadata identifier -getMetaUniqueId :: LlvmM MetaId -getMetaUniqueId = LlvmM $ \env -> - return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env }) - --- | Get the LLVM version we are generating code for -getLlvmVer :: LlvmM LlvmVersion -getLlvmVer = getEnv envVersion - --- | Get the platform we are generating code for -getDynFlag :: (DynFlags -> a) -> LlvmM a -getDynFlag f = getEnv (f . envDynFlags) - --- | Get the platform we are generating code for -getLlvmPlatform :: LlvmM Platform -getLlvmPlatform = getDynFlag targetPlatform - --- | Dumps the document if the corresponding flag has been set by the user -dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM () -dumpIfSetLlvm flag hdr doc = do - dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags flag hdr doc - --- | Prints the given contents to the output handle -renderLlvm :: Outp.SDoc -> LlvmM () -renderLlvm sdoc = do - - -- Write to output - dflags <- getDynFlags - out <- getEnv envOutput - liftIO $ Outp.bufLeftRenderSDoc dflags out - (Outp.mkCodeStyle Outp.CStyle) sdoc - - -- Dump, if requested - dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc - return () - --- | Marks a variable as "used" -markUsedVar :: LlvmVar -> LlvmM () -markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } - --- | Return all variables marked as "used" so far -getUsedVars :: LlvmM [LlvmVar] -getUsedVars = getEnv envUsedVars - --- | Saves that at some point we didn't know the type of the label and --- generated a reference to a type variable instead -saveAlias :: LMString -> LlvmM () -saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } - --- | Sets metadata node for a given unique -setUniqMeta :: Unique -> MetaId -> LlvmM () -setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } - --- | Gets metadata node for given unique -getUniqMeta :: Unique -> LlvmM (Maybe MetaId) -getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) - --- ---------------------------------------------------------------------------- --- * Internal functions --- - --- | Here we pre-initialise some functions that are used internally by GHC --- so as to make sure they have the most general type in the case that --- user code also uses these functions but with a different type than GHC --- internally. (Main offender is treating return type as 'void' instead of --- 'void *'). Fixes trac #5486. -ghcInternalFunctions :: LlvmM () -ghcInternalFunctions = do - dflags <- getDynFlags - let w = llvmWord dflags - cint = LMInt $ widthInBits $ cIntWidth dflags - mk "memcmp" cint [i8Ptr, i8Ptr, w] - mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w] - mk "memmove" i8Ptr [i8Ptr, i8Ptr, w] - mk "memset" i8Ptr [i8Ptr, w, w] - mk "newSpark" w [i8Ptr, i8Ptr] - where - mk n ret args = do - let n' = fsLit n - decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret - FixedArgs (tysToParams args) Nothing - renderLlvm $ ppLlvmFunctionDecl decl - funInsert n' (LMFunction decl) - --- ---------------------------------------------------------------------------- --- * Label handling --- - --- | Pretty print a 'CLabel'. -strCLabel_llvm :: CLabel -> LlvmM LMString -strCLabel_llvm lbl = do - dflags <- getDynFlags - let sdoc = pprCLabel dflags lbl - str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) - return (fsLit str) - -strDisplayName_llvm :: CLabel -> LlvmM LMString -strDisplayName_llvm lbl = do - dflags <- getDynFlags - let sdoc = pprCLabel dflags lbl - depth = Outp.PartWay 1 - style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth - str = Outp.renderWithStyle dflags sdoc style - return (fsLit (dropInfoSuffix str)) - -dropInfoSuffix :: String -> String -dropInfoSuffix = go - where go "_info" = [] - go "_static_info" = [] - go "_con_info" = [] - go (x:xs) = x:go xs - go [] = [] - -strProcedureName_llvm :: CLabel -> LlvmM LMString -strProcedureName_llvm lbl = do - dflags <- getDynFlags - let sdoc = pprCLabel dflags lbl - depth = Outp.PartWay 1 - style = Outp.mkUserStyle dflags Outp.neverQualify depth - str = Outp.renderWithStyle dflags sdoc style - return (fsLit str) - --- ---------------------------------------------------------------------------- --- * Global variables / forward references --- - --- | Create/get a pointer to a global value. Might return an alias if --- the value in question hasn't been defined yet. We especially make --- no guarantees on the type of the returned pointer. -getGlobalPtr :: LMString -> LlvmM LlvmVar -getGlobalPtr llvmLbl = do - m_ty <- funLookup llvmLbl - let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing - case m_ty of - -- Directly reference if we have seen it already - Just ty -> do - if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"]) - then return $ mkGlbVar (llvmLbl) ty Global - else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global - -- Otherwise use a forward alias of it - Nothing -> do - saveAlias llvmLbl - return $ mkGlbVar llvmLbl i8 Alias - --- | Derive the definition label. It has an identified --- structure type. -llvmDefLabel :: LMString -> LMString -llvmDefLabel = (`appendFS` fsLit "$def") - --- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. --- --- Must be called at a point where we are sure that no new global definitions --- will be generated anymore! -generateExternDecls :: LlvmM ([LMGlobal], [LlvmType]) -generateExternDecls = do - delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - defss <- flip mapM delayed $ \lbl -> do - m_ty <- funLookup lbl - case m_ty of - -- If we have a definition we've already emitted the proper aliases - -- when the symbol itself was emitted by @aliasify@ - Just _ -> return [] - - -- If we don't have a definition this is an external symbol and we - -- need to emit a declaration - Nothing -> - let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global - in return [LMGlobal var Nothing] - - -- Reset forward list - modifyEnv $ \env -> env { envAliases = emptyUniqSet } - return (concat defss, []) - --- | Here we take a global variable definition, rename it with a --- @$def@ suffix, and generate the appropriate alias. -aliasify :: LMGlobal -> LlvmM [LMGlobal] --- See note [emit-time elimination of static indirections] in CLabel. --- Here we obtain the indirectee's precise type and introduce --- fresh aliases to both the precise typed label (lbl$def) and the i8* --- typed (regular) label of it with the matching new names. -aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias) - (Just orig)) = do - let defLbl = llvmDefLabel lbl - LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig - defOrigLbl = llvmDefLabel origLbl - orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias) - origType <- funLookup origLbl - let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl - (pLift $ fromJust origType) oLnk - Nothing Nothing Alias)) - (pLift ty) - pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig) - , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig') - ] -aliasify (LMGlobal var val) = do - let LMGlobalVar lbl ty link sect align const = var - - defLbl = llvmDefLabel lbl - defVar = LMGlobalVar defLbl ty Internal sect align const - - defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const - aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias - aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr - - -- we need to mark the $def symbols as used so LLVM doesn't forget which - -- section they need to go in. This will vanish once we switch away from - -- mangling sections for TNTC. - markUsedVar defVar - - return [ LMGlobal defVar val - , LMGlobal aliasVar (Just aliasVal) - ] - --- Note [Llvm Forward References] --- --- The issue here is that LLVM insists on being strongly typed at --- every corner, so the first time we mention something, we have to --- settle what type we assign to it. That makes things awkward, as Cmm --- will often reference things before their definition, and we have no --- idea what (LLVM) type it is going to be before that point. --- --- Our work-around is to define "aliases" of a standard type (i8 *) in --- these kind of situations, which we later tell LLVM to be either --- references to their actual local definitions (involving a cast) or --- an external reference. This obviously only works for pointers. --- --- In particular when we encounter a reference to a symbol in a chunk of --- C-- there are three possible scenarios, --- --- 1. We have already seen a definition for the referenced symbol. This --- means we already know its type. --- --- 2. We have not yet seen a definition but we will find one later in this --- compilation unit. Since we want to be a good consumer of the --- C-- streamed to us from upstream, we don't know the type of the --- symbol at the time when we must emit the reference. --- --- 3. We have not yet seen a definition nor will we find one in this --- compilation unit. In this case the reference refers to an --- external symbol for which we do not know the type. --- --- Let's consider case (2) for a moment: say we see a reference to --- the symbol @fooBar@ for which we have not seen a definition. As we --- do not know the symbol's type, we assume it is of type @i8*@ and emit --- the appropriate casts in @getSymbolPtr@. Later on, when we --- encounter the definition of @fooBar@ we emit it but with a modified --- name, @fooBar$def@ (which we'll call the definition symbol), to --- since we have already had to assume that the symbol @fooBar@ --- is of type @i8*@. We then emit @fooBar@ itself as an alias --- of @fooBar$def@ with appropriate casts. This all happens in --- @aliasify@. --- --- Case (3) is quite similar to (2): References are emitted assuming --- the referenced symbol is of type @i8*@. When we arrive at the end of --- the compilation unit and realize that the symbol is external, we emit --- an LLVM @external global@ declaration for the symbol @fooBar@ --- (handled in @generateExternDecls@). This takes advantage of the --- fact that the aliases produced by @aliasify@ for exported symbols --- have external linkage and can therefore be used as normal symbols. --- --- Historical note: As of release 3.5 LLVM does not allow aliases to --- refer to declarations. This the reason why aliases are produced at the --- point of definition instead of the point of usage, as was previously --- done. See #9142 for details. --- --- Finally, case (1) is trival. As we already have a definition for --- and therefore know the type of the referenced symbol, we can do --- away with casting the alias to the desired type in @getSymbolPtr@ --- and instead just emit a reference to the definition symbol directly. --- This is the @Just@ case in @getSymbolPtr@. diff --git a/llvmGen/LlvmCodeGen/CodeGen.hs b/llvmGen/LlvmCodeGen/CodeGen.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/CodeGen.hs +++ /dev/null @@ -1,2115 +0,0 @@ -{-# LANGUAGE CPP, GADTs, MultiWayIf #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} --- ---------------------------------------------------------------------------- --- | Handle conversion of CmmProc to LLVM code. --- -module LlvmCodeGen.CodeGen ( genLlvmProc ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Llvm -import LlvmCodeGen.Base -import LlvmCodeGen.Regs - -import BlockId -import GHC.Platform.Regs ( activeStgRegs, callerSaves ) -import CLabel -import Cmm -import PprCmm -import CmmUtils -import CmmSwitch -import Hoopl.Block -import Hoopl.Graph -import Hoopl.Collections - -import DynFlags -import FastString -import ForeignCall -import Outputable hiding (panic, pprPanic) -import qualified Outputable -import GHC.Platform -import OrdList -import UniqSupply -import Unique -import Util - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer -import Control.Monad - -import qualified Data.Semigroup as Semigroup -import Data.List ( nub ) -import Data.Maybe ( catMaybes ) - -import TyCon (PrimRep(..)) - -type Atomic = Bool -type LlvmStatements = OrdList LlvmStatement - -data Signage = Signed | Unsigned deriving (Eq, Show) - --- ----------------------------------------------------------------------------- --- | Top-level of the LLVM proc Code generator --- -genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] -genLlvmProc (CmmProc infos lbl live graph) = do - let blocks = toBlockListEntryFirstFalseFallthrough graph - (lmblocks, lmdata) <- basicBlocksCodeGen live blocks - let info = mapLookup (g_entry graph) infos - proc = CmmProc info lbl live (ListGraph lmblocks) - return (proc:lmdata) - -genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" - --- ----------------------------------------------------------------------------- --- * Block code generation --- - --- | Generate code for a list of blocks that make up a complete --- procedure. The first block in the list is expected to be the entry --- point. -basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] - -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) -basicBlocksCodeGen _ [] = panic "no entry block!" -basicBlocksCodeGen live cmmBlocks - = do -- Emit the prologue - -- N.B. this must be its own block to ensure that the entry block of the - -- procedure has no predecessors, as required by the LLVM IR. See #17589 - -- and #11649. - bid <- newBlockId - (prologue, prologueTops) <- funPrologue live cmmBlocks - let entryBlock = BasicBlock bid (fromOL prologue) - - -- Generate code - (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks - - -- Compose - return (entryBlock : blocks, prologueTops ++ concat topss) - - --- | Generate code for one block -basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) -basicBlockCodeGen block - = do let (_, nodes, tail) = blockSplit block - id = entryLabel block - (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes - (tail_instrs, top') <- stmtToInstrs tail - let instrs = fromOL (mid_instrs `appOL` tail_instrs) - return (BasicBlock id instrs, top' ++ top) - --- ----------------------------------------------------------------------------- --- * CmmNode code generation --- - --- A statement conversion return data. --- * LlvmStatements: The compiled LLVM statements. --- * LlvmCmmDecl: Any global data needed. -type StmtData = (LlvmStatements, [LlvmCmmDecl]) - - --- | Convert a list of CmmNode's to LlvmStatement's -stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData -stmtsToInstrs stmts - = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts - return (concatOL instrss, concat topss) - - --- | Convert a CmmStmt to a list of LlvmStatement's -stmtToInstrs :: CmmNode e x -> LlvmM StmtData -stmtToInstrs stmt = case stmt of - - CmmComment _ -> return (nilOL, []) -- nuke comments - CmmTick _ -> return (nilOL, []) - CmmUnwind {} -> return (nilOL, []) - - CmmAssign reg src -> genAssign reg src - CmmStore addr src -> genStore addr src - - CmmBranch id -> genBranch id - CmmCondBranch arg true false likely - -> genCondBranch arg true false likely - CmmSwitch arg ids -> genSwitch arg ids - - -- Foreign Call - CmmUnsafeForeignCall target res args - -> genCall target res args - - -- Tail call - CmmCall { cml_target = arg, - cml_args_regs = live } -> genJump arg live - - _ -> panic "Llvm.CodeGen.stmtToInstrs" - --- | Wrapper function to declare an instrinct function by function type -getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData -getInstrinct2 fname fty@(LMFunction funSig) = do - - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant - - fn <- funLookup fname - tops <- case fn of - Just _ -> - return [] - Nothing -> do - funInsert fname fty - un <- getUniqueM - let lbl = mkAsmTempLabel un - return [CmmData (Section Data lbl) [([],[fty])]] - - return (fv, nilOL, tops) - -getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" - --- | Declares an instrinct function by return and parameter types -getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData -getInstrinct fname retTy parTys = - let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy - FixedArgs (tysToParams parTys) Nothing - fty = LMFunction funSig - in getInstrinct2 fname fty - --- | Memory barrier instruction for LLVM >= 3.0 -barrier :: LlvmM StmtData -barrier = do - let s = Fence False SyncSeqCst - return (unitOL s, []) - --- | Insert a 'barrier', unless the target platform is in the provided list of --- exceptions (where no code will be emitted instead). -barrierUnless :: [Arch] -> LlvmM StmtData -barrierUnless exs = do - platform <- getLlvmPlatform - if platformArch platform `elem` exs - then return (nilOL, []) - else barrier - --- | Foreign Calls -genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData - --- Barriers need to be handled specially as they are implemented as LLVM --- intrinsic functions. -genCall (PrimTarget MO_ReadBarrier) _ _ = - barrierUnless [ArchX86, ArchX86_64, ArchSPARC] -genCall (PrimTarget MO_WriteBarrier) _ _ = do - barrierUnless [ArchX86, ArchX86_64, ArchSPARC] - -genCall (PrimTarget MO_Touch) _ _ - = return (nilOL, []) - -genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do - dstV <- getCmmRegW (CmmLocal dst) - let ty = cmmToLlvmType $ localRegType dst - width = widthToLlvmFloat w - castV <- lift $ mkLocalVar ty - ve <- exprToVarW e - statement $ Assignment castV $ Cast LM_Uitofp ve width - statement $ Store castV dstV - -genCall (PrimTarget (MO_UF_Conv _)) [_] args = - panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ - "Can only handle 1, given" ++ show (length args) ++ "." - --- Handle prefetching data -genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args - | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do - let argTy = [i8Ptr, i32, i32, i32] - funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing - - let (_, arg_hints) = foreignTargetHints t - let args_hints' = zip args arg_hints - argVars <- arg_varsW args_hints' ([], nilOL, []) - fptr <- liftExprData $ getFunPtr funTy t - argVars' <- castVarsW Signed $ zip argVars argTy - - doTrashStmts - let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1] - statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] - | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) - --- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg --- and return types -genCall t@(PrimTarget (MO_PopCnt w)) dsts args = - genCallSimpleCast w t dsts args - -genCall t@(PrimTarget (MO_Pdep w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Pext w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Clz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_Ctz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BSwap w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BRev w)) dsts args = - genCallSimpleCast w t dsts args - -genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do - addrVar <- exprToVarW addr - nVar <- exprToVarW n - let targetTy = widthToLlvmInt width - ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) - ptrVar <- doExprW (pLift targetTy) ptrExpr - dstVar <- getCmmRegW (CmmLocal dst) - let op = case amop of - AMO_Add -> LAO_Add - AMO_Sub -> LAO_Sub - AMO_And -> LAO_And - AMO_Nand -> LAO_Nand - AMO_Or -> LAO_Or - AMO_Xor -> LAO_Xor - retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst - statement $ Store retVar dstVar - -genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do - dstV <- getCmmRegW (CmmLocal dst) - v1 <- genLoadW True addr (localRegType dst) - statement $ Store v1 dstV - -genCall (PrimTarget (MO_Cmpxchg _width)) - [dst] [addr, old, new] = runStmtsDecls $ do - addrVar <- exprToVarW addr - oldVar <- exprToVarW old - newVar <- exprToVarW new - let targetTy = getVarType oldVar - ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) - ptrVar <- doExprW (pLift targetTy) ptrExpr - dstVar <- getCmmRegW (CmmLocal dst) - retVar <- doExprW (LMStructU [targetTy,i1]) - $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst - retVar' <- doExprW targetTy $ ExtractV retVar 0 - statement $ Store retVar' dstVar - -genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do - addrVar <- exprToVarW addr - valVar <- exprToVarW val - let ptrTy = pLift $ getVarType valVar - ptrExpr = Cast LM_Inttoptr addrVar ptrTy - ptrVar <- doExprW ptrTy ptrExpr - statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst - --- Handle memcpy function specifically since llvm's intrinsic version takes --- some extra parameters. -genCall t@(PrimTarget op) [] args - | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do - dflags <- getDynFlags - let isVolTy = [i1] - isVolVal = [mkIntLit i1 0] - argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy - | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy - funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - argVars <- arg_varsW args_hints ([], nilOL, []) - fptr <- getFunPtrW funTy t - argVars' <- castVarsW Signed $ zip argVars argTy - - doTrashStmts - let alignVal = mkIntLit i32 align - arguments = argVars' ++ (alignVal:isVolVal) - statement $ Expr $ Call StdCall fptr arguments [] - --- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands --- twice the width (we first zero-extend them), e.g., on 64-bit arch we will --- generate 'mul' on 128-bit operands. Then we only need some plumbing to --- extract the two 64-bit values out of 128-bit result. -genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do - let width = widthToLlvmInt w - bitWidth = widthInBits w - width2x = LMInt (bitWidth * 2) - -- First zero-extend the operands ('mul' instruction requires the operands - -- and the result to be of the same type). Note that we don't use 'castVars' - -- because it tries to do LM_Sext. - lhsVar <- exprToVarW lhs - rhsVar <- exprToVarW rhs - lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x - rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x - -- Do the actual multiplication (note that the result is also 2x width). - retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt - -- Extract the lower bits of the result into retL. - retL <- doExprW width $ Cast LM_Trunc retV width - -- Now we right-shift the higher bits by width. - let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width - retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit - -- And extract them into retH. - retH <- doExprW width $ Cast LM_Trunc retShifted width - dstRegL <- getCmmRegW (CmmLocal dstL) - dstRegH <- getCmmRegW (CmmLocal dstH) - statement $ Store retL dstRegL - statement $ Store retH dstRegH - --- MO_U_QuotRem2 is another case we handle by widening the registers to double --- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The --- main difference here is that we need to combine two words into one register --- and then use both 'udiv' and 'urem' instructions to compute the result. -genCall (PrimTarget (MO_U_QuotRem2 w)) - [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do - let width = widthToLlvmInt w - bitWidth = widthInBits w - width2x = LMInt (bitWidth * 2) - -- First zero-extend all parameters to double width. - let zeroExtend expr = do - var <- exprToVarW expr - doExprW width2x $ Cast LM_Zext var width2x - lhsExtH <- zeroExtend lhsH - lhsExtL <- zeroExtend lhsL - rhsExt <- zeroExtend rhs - -- Now we combine the first two parameters (that represent the high and low - -- bits of the value). So first left-shift the high bits to their position - -- and then bit-or them with the low bits. - let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width - lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit - lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL - -- Finally, we can call 'udiv' and 'urem' to compute the results. - retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt - retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt - -- And since everything is in 2x width, we need to truncate the results and - -- then return them. - let narrow var = doExprW width $ Cast LM_Trunc var width - retDiv <- narrow retExtDiv - retRem <- narrow retExtRem - dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) - dstRegR <- lift $ getCmmReg (CmmLocal dstR) - statement $ Store retDiv dstRegQ - statement $ Store retRem dstRegR - --- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from --- which we need to extract the actual values. -genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] -genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] - --- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the --- return tuple to be the overflow bit and the second element to contain the --- actual result of the addition. So we still use genCallWithOverflow but swap --- the return registers. -genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] - -genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] - -genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] = - genCallWithOverflow t w [dstV, dstO] [lhs, rhs] - --- Handle all other foreign calls and prim ops. -genCall target res args = runStmtsDecls $ do - dflags <- getDynFlags - platform <- lift $ getLlvmPlatform - - - let primRepToLlvmTy VoidRep = (Unsigned, LMVoid) - -- GHC's IntRep is not the same as CIntRep, GHC's - -- IntRep is always Word Sized. This conversely also - -- means that any CInt needs to be mapped to Int32Rep - -- and any custom signature that expects to to C FFI - -- needs to also be Int32Rep. - primRepToLlvmTy IntRep = (Signed, widthToLlvmInt (wordWidth dflags)) - primRepToLlvmTy Int8Rep = (Signed, i8) - primRepToLlvmTy Int16Rep = (Signed, i16) - primRepToLlvmTy Int32Rep = (Signed, i32) - primRepToLlvmTy Int64Rep = (Signed, i64) - primRepToLlvmTy WordRep = (Unsigned, widthToLlvmInt (wordWidth dflags)) - primRepToLlvmTy Word8Rep = (Unsigned, i8) - primRepToLlvmTy Word16Rep = (Unsigned, i16) - primRepToLlvmTy Word32Rep = (Unsigned, i32) - primRepToLlvmTy Word64Rep = (Unsigned, i64) - primRepToLlvmTy FloatRep = (Signed, LMFloat) - primRepToLlvmTy DoubleRep = (Signed, LMDouble) - -- pointers - primRepToLlvmTy AddrRep = (Unsigned, i8Ptr) - primRepToLlvmTy LiftedRep = (Unsigned, i8Ptr) - primRepToLlvmTy UnliftedRep = (Unsigned, i8Ptr) - primRepToLlvmTy _ = panic "LlvmCodeGen.CodeGen.genCall: Invalid primRep; cannot convert to llvm type" - - -- ret type - let -- similarly to arg_type_cmm, we may need to widen/narrow the result. - -- most likely widen, as cmm regs will be 64bit wide. - ret_type_cmm [] = LMVoid - ret_type_cmm [(_, AddrHint)] = i8Ptr - ret_type_cmm [(reg, _)] = cmmToLlvmType $ localRegType reg - ret_type_cmm _ = panic "LlvmCodeGen.CodeGen.genCall: invalid return type; we only support single return values" - - -- extract Cmm call convention, and translate to LLVM call convention - let lmconv = case target of - ForeignTarget _ (ForeignConvention conv _ _ _ _ _) -> - case conv of - StdCallConv -> case platformArch platform of - ArchX86 -> CC_X86_Stdcc - ArchX86_64 -> CC_X86_Stdcc - _ -> CC_Ccc - CCallConv -> CC_Ccc - CApiConv -> CC_Ccc - PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv" - JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv" - - PrimTarget _ -> CC_Ccc - - {- - CC_Ccc of the possibilities here are a worry with the use of a custom - calling convention for passing STG args. In practice the more - dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. - - The native code generator only handles StdCall and CCallConv. - -} - - let arg_type (hint, expr) = - case expr of - ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform - -> (ty, if hint == Signed then [SignExt] else [ZeroExt]) - ty -> (ty, []) - - -- call attributes - let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs - | otherwise = llvmStdFunAttrs - - never_returns = case target of - ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns _ _) -> True - _ -> False - - -- fun type - let (res_hints, _arg_hints) = foreignTargetHints target - let (ret_rep, args_rep) = foreignTargetReps target - - let ress_hints = zip res res_hints - let ccTy = StdCall -- tail calls should be done through CmmJump - - let retTyCmm = ret_type_cmm ress_hints - - let argTy = map arg_type $ map primRepToLlvmTy args_rep - let retTy = snd $ primRepToLlvmTy ret_rep - let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - - - let args_with_reps = zip args (map primRepToLlvmTy args_rep) - - let doReturn | ccTy == TailCall = statement $ Return Nothing - | never_returns = statement $ Unreachable - | otherwise = return () - - doTrashStmts - - -- make the actual call - argVars <- arg_varsW2 args_with_reps ([], nilOL, []) - fptr <- getFunPtrW funTy target - case retTy of - LMVoid -> do - statement $ Expr $ Call ccTy fptr argVars fnAttrs - - _ -> do - let (signage, retTy) = primRepToLlvmTy ret_rep - v0 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs - v1 <- castVarW signage v0 retTyCmm - -- get the return register - let ret_reg [reg] = reg - ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" - ++ " 1, given " ++ show (length t) ++ "." - let creg = ret_reg res - vreg <- getCmmRegW (CmmLocal creg) - if retTyCmm == pLower (getVarType vreg) - then do - statement $ Store v1 vreg - doReturn - else do - let ty = pLower $ getVarType vreg - let op = case ty of - vt | isPointer vt -> LM_Bitcast - | isInt vt -> LM_Ptrtoint - | otherwise -> - panic $ "genCall: CmmReg bad match for" - ++ " returned type!" - - v2 <- doExprW ty $ Cast op v1 ty - statement $ Store v2 vreg - doReturn - where - -- | For some architectures the C calling convention is that any - -- integer shorter than 64 bits is replaced by its 64 bits - -- representation using sign or zero extension. - platformCConvNeedsExtension :: Platform -> Bool - platformCConvNeedsExtension platform = case platformArch platform of - ArchPPC_64 _ -> True - ArchS390X -> True - _ -> False - --- | Generate a call to an LLVM intrinsic that performs arithmetic operation --- with overflow bit (i.e., returns a struct containing the actual result of the --- operation and an overflow bit). This function will also extract the overflow --- bit and zero-extend it (all the corresponding Cmm PrimOps represent the --- overflow "bit" as a usual Int# or Word#). -genCallWithOverflow - :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData -genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do - -- So far this was only tested for the following four CallishMachOps. - let valid = op `elem` [ MO_Add2 w - , MO_AddIntC w - , MO_SubIntC w - , MO_AddWordC w - , MO_SubWordC w - ] - MASSERT(valid) - let width = widthToLlvmInt w - -- This will do most of the work of generating the call to the intrinsic and - -- extracting the values from the struct. - (value, overflowBit, (stmts, top)) <- - genCallExtract t w (lhs, rhs) (width, i1) - -- value is i, but overflowBit is i1, so we need to cast (Cmm expects - -- both to be i) - (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width - dstRegV <- getCmmReg (CmmLocal dstV) - dstRegO <- getCmmReg (CmmLocal dstO) - let storeV = Store value dstRegV - storeO = Store overflow dstRegO - return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) -genCallWithOverflow _ _ _ _ = - panic "genCallExtract: wrong ForeignTarget or number of arguments" - --- | A helper function for genCallWithOverflow that handles generating the call --- to the LLVM intrinsic and extracting the result from the struct to LlvmVars. -genCallExtract - :: ForeignTarget -- ^ PrimOp - -> Width -- ^ Width of the operands. - -> (CmmActual, CmmActual) -- ^ Actual arguments. - -> (LlvmType, LlvmType) -- ^ LLVM types of the returned struct. - -> LlvmM (LlvmVar, LlvmVar, StmtData) -genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do - let width = widthToLlvmInt w - argTy = [width, width] - retTy = LMStructU [llvmTypeA, llvmTypeB] - - -- Process the arguments. - let args_hints = zip [argA, argB] (snd $ foreignTargetHints target) - (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, []) - (argsV2, args2) <- castVars Signed $ zip argsV1 argTy - - -- Get the function and make the call. - fname <- cmmPrimOpFunctions op - (fptr, _, top2) <- getInstrinct fname retTy argTy - -- We use StdCall for primops. See also the last case of genCall. - (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 [] - - -- This will result in a two element struct, we need to use "extractvalue" - -- to get them out of it. - (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0) - (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1) - - let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2 - tops = top1 ++ top2 - return (res1, res2, (stmts, tops)) - -genCallExtract _ _ _ _ = - panic "genCallExtract: unsupported ForeignTarget" - --- Handle simple function call that only need simple type casting, of the form: --- truncate arg >>= \a -> call(a) >>= zext --- --- since GHC only really has i32 and i64 types and things like Word8 are backed --- by an i32 and just present a logical i8 range. So we must handle conversions --- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width [width] - - dstV <- getCmmReg (CmmLocal dst) - - let args_hints = zip args (snd (foreignTargetHints t)) - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast" retVs' - let s2 = Store retV' dstV - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (stmts, top2 ++ top3) -genCallSimpleCast _ _ dsts _ = - panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") - --- Handle simple function call that only need simple type casting, of the form: --- truncate arg >>= \a -> call(a) >>= zext --- --- since GHC only really has i32 and i64 types and things like Word8 are backed --- by an i32 and just present a logical i8 range. So we must handle conversions --- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width (const width <$> args) - - dstV <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV) - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast2" retVs' - let s2 = Store retV' dstV - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (stmts, top2 ++ top3) -genCallSimpleCast2 _ _ dsts _ = - panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts") - --- | Create a function pointer from a target. -getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget - -> WriterT LlvmAccum LlvmM LlvmVar -getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ - --- | Create a function pointer from a target. -getFunPtr :: (LMString -> LlvmType) -> ForeignTarget - -> LlvmM ExprData -getFunPtr funTy targ = case targ of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do - name <- strCLabel_llvm lbl - getHsFunc' name (funTy name) - - ForeignTarget expr _ -> do - (v1, stmts, top) <- exprToVar expr - dflags <- getDynFlags - let fty = funTy $ fsLit "dynamic" - cast = case getVarType v1 of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - ty -> panic $ "genCall: Expr is of bad type for function" - ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" - - (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) - return (v2, stmts `snocOL` s1, top) - - PrimTarget mop -> do - name <- cmmPrimOpFunctions mop - let fty = funTy name - getInstrinct2 name fty - --- | Conversion of call arguments. -arg_varsW :: [(CmmActual, ForeignHint)] - -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> WriterT LlvmAccum LlvmM [LlvmVar] -arg_varsW xs ys = do - (vars, stmts, decls) <- lift $ arg_vars xs ys - tell $ LlvmAccum stmts decls - return vars - -arg_varsW2 :: [(CmmActual, (Signage, LlvmType))] - -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> WriterT LlvmAccum LlvmM [LlvmVar] -arg_varsW2 xs ys = do - (vars, stmts, decls) <- lift $ arg_vars2 xs ys - tell $ LlvmAccum stmts decls - return vars - --- | Conversion of call arguments. -arg_vars :: [(CmmActual, ForeignHint)] - -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -arg_vars [] (vars, stmts, tops) - = return (vars, stmts, tops) - -arg_vars ((e, AddrHint):rest) (vars, stmts, tops) - = do (v1, stmts', top') <- exprToVar e - let op = case getVarType v1 of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - a -> pprPanic "genCall: Can't cast llvmType to i8*!" (ppr a) - (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr - arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, - tops ++ top') - -arg_vars ((e, _):rest) (vars, stmts, tops) - = do (v1, stmts', top') <- exprToVar e - arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') - - -arg_vars2 :: [(CmmActual, (Signage, LlvmType))] - -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) -arg_vars2 [] x = return x -arg_vars2 ((e, (_s, ty0)):rest) (vars, stmts, tops) - | ty0 == i8Ptr - = do (v1, stmts', top') <- exprToVar e - let op = case getVarType v1 of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - a -> pprPanic "genCall: Can't cast llvmType to i8*!" (ppr a) - (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr - arg_vars2 rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, - tops ++ top') - -arg_vars2 ((e, (s, ty)):rest) (vars, stmts, tops) - = do (v1, stmts', top') <- exprToVar e - (v2, s1) <- castVar s v1 ty - arg_vars2 rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') - --- | Cast a collection of LLVM variables to specific types. -castVarsW :: Signage - -> [(LlvmVar, LlvmType)] - -> WriterT LlvmAccum LlvmM [LlvmVar] -castVarsW signage vars = do - (vars, stmts) <- lift $ castVars signage vars - tell $ LlvmAccum stmts mempty - return vars - --- | Cast a collection of LLVM variables to specific types. -castVars :: Signage -> [(LlvmVar, LlvmType)] - -> LlvmM ([LlvmVar], LlvmStatements) -castVars signage vars = do - done <- mapM (uncurry (castVar signage)) vars - let (vars', stmts) = unzip done - return (vars', toOL stmts) - --- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) -castVar signage v t | getVarType v == t - = return (v, Nop) - - | otherwise - = do dflags <- getDynFlags - let op = case (getVarType v, t) of - (LMInt n, LMInt m) - -> if n < m then extend else LM_Trunc - (vt, _) | isFloat vt && isFloat t - -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t - then LM_Fpext else LM_Fptrunc - (vt, _) | isInt vt && isFloat t -> LM_Sitofp - (vt, _) | isFloat vt && isInt t -> LM_Fptosi - (vt, _) | isInt vt && isPointer t -> LM_Inttoptr - (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint - (vt, _) | isPointer vt && isPointer t -> LM_Bitcast - (vt, _) | isVector vt && isVector t -> LM_Bitcast - - (vt, _) -> panic $ "castVars: Can't cast this type (" - ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" - doExpr t $ Cast op v t - where extend = case signage of - Signed -> LM_Sext - Unsigned -> LM_Zext - -castVarW :: Signage -> LlvmVar -> LlvmType -> WriterT LlvmAccum LlvmM LlvmVar -castVarW signage var ty = do - (var, stmt) <- lift $ castVar signage var ty - statement $ stmt - return var - - -cmmPrimOpRetValSignage :: CallishMachOp -> Signage -cmmPrimOpRetValSignage mop = case mop of - MO_Pdep _ -> Unsigned - MO_Pext _ -> Unsigned - _ -> Signed - --- | Decide what C function to use to implement a CallishMachOp -cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString -cmmPrimOpFunctions mop = do - - dflags <- getDynFlags - let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags) - intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags) - unsupported = panic ("cmmPrimOpFunctions: " ++ show mop - ++ " not supported here") - - return $ case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_ExpM1 -> fsLit "expm1f" - MO_F32_Log -> fsLit "logf" - MO_F32_Log1P -> fsLit "log1pf" - MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" - MO_F32_Fabs -> fsLit "llvm.fabs.f32" - MO_F32_Pwr -> fsLit "llvm.pow.f32" - - MO_F32_Sin -> fsLit "llvm.sin.f32" - MO_F32_Cos -> fsLit "llvm.cos.f32" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F32_Asinh -> fsLit "asinhf" - MO_F32_Acosh -> fsLit "acoshf" - MO_F32_Atanh -> fsLit "atanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_ExpM1 -> fsLit "expm1" - MO_F64_Log -> fsLit "log" - MO_F64_Log1P -> fsLit "log1p" - MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" - MO_F64_Fabs -> fsLit "llvm.fabs.f64" - MO_F64_Pwr -> fsLit "llvm.pow.f64" - - MO_F64_Sin -> fsLit "llvm.sin.f64" - MO_F64_Cos -> fsLit "llvm.cos.f64" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_F64_Asinh -> fsLit "asinh" - MO_F64_Acosh -> fsLit "acosh" - MO_F64_Atanh -> fsLit "atanh" - - MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1 - MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1 - MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2 - MO_Memcmp _ -> fsLit $ "memcmp" - - (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - (MO_BRev w) -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) - - (MO_Pdep w) -> let w' = showSDoc dflags (ppr $ widthInBits w) - in if isBmi2Enabled dflags - then fsLit $ "llvm.x86.bmi.pdep." ++ w' - else fsLit $ "hs_pdep" ++ w' - (MO_Pext w) -> let w' = showSDoc dflags (ppr $ widthInBits w) - in if isBmi2Enabled dflags - then fsLit $ "llvm.x86.bmi.pext." ++ w' - else fsLit $ "hs_pext" ++ w' - - (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" - - MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - MO_AddWordC w -> fsLit $ "llvm.uadd.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow." - ++ showSDoc dflags (ppr $ widthToLlvmInt w) - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the - -- appropriate case of genCall. - MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - MO_UF_Conv _ -> unsupported - - MO_AtomicRead _ -> unsupported - MO_AtomicRMW _ _ -> unsupported - MO_AtomicWrite _ -> unsupported - MO_Cmpxchg _ -> unsupported - --- | Tail function calls -genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData - --- Call to known function -genJump (CmmLit (CmmLabel lbl)) live = do - (vf, stmts, top) <- getHsFunc live lbl - (stgRegs, stgStmts) <- funEpilogue live - let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs - let s2 = Return Nothing - return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) - - --- Call to unknown function / address -genJump expr live = do - fty <- llvmFunTy live - (vf, stmts, top) <- exprToVar expr - dflags <- getDynFlags - - let cast = case getVarType vf of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - ty -> panic $ "genJump: Expr is of bad type for function call! (" - ++ showSDoc dflags (ppr ty) ++ ")" - - (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue live - let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs - let s3 = Return Nothing - return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, - top) - - --- | CmmAssign operation --- --- We use stack allocated variables for CmmReg. The optimiser will replace --- these with registers when possible. -genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData -genAssign reg val = do - vreg <- getCmmReg reg - (vval, stmts2, top2) <- exprToVar val - let stmts = stmts2 - - let ty = (pLower . getVarType) vreg - dflags <- getDynFlags - case ty of - -- Some registers are pointer types, so need to cast value to pointer - LMPointer _ | getVarType vval == llvmWord dflags -> do - (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vreg - return (stmts `snocOL` s1 `snocOL` s2, top2) - - LMVector _ _ -> do - (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty - let s2 = Store v vreg - return (stmts `snocOL` s1 `snocOL` s2, top2) - - _ -> do - let s1 = Store vval vreg - return (stmts `snocOL` s1, top2) - - --- | CmmStore operation -genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData - --- First we try to detect a few common cases and produce better code for --- these then the default case. We are mostly trying to detect Cmm code --- like I32[Sp + n] and use 'getelementptr' operations instead of the --- generic case that uses casts and pointer arithmetic -genStore addr@(CmmReg (CmmGlobal r)) val - = genStore_fast addr r 0 val - -genStore addr@(CmmRegOff (CmmGlobal r) n) val - = genStore_fast addr r n val - -genStore addr@(CmmMachOp (MO_Add _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - val - = genStore_fast addr r (fromInteger n) val - -genStore addr@(CmmMachOp (MO_Sub _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - val - = genStore_fast addr r (negate $ fromInteger n) val - --- generic case -genStore addr val - = getTBAAMeta topN >>= genStore_slow addr val - --- | CmmStore operation --- This is a special case for storing to a global register pointer --- offset such as I32[Sp+8]. -genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr - -> LlvmM StmtData -genStore_fast addr r n val - = do dflags <- getDynFlags - (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r - let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - case isPointer grt && rem == 0 of - True -> do - (vval, stmts, top) <- exprToVar val - (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - -- We might need a different pointer type, so check - case pLower grt == getVarType vval of - -- were fine - True -> do - let s3 = MetaStmt meta $ Store vval ptr - return (stmts `appOL` s1 `snocOL` s2 - `snocOL` s3, top) - - -- cast to pointer type needed - False -> do - let ty = (pLift . getVarType) vval - (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = MetaStmt meta $ Store vval ptr' - return (stmts `appOL` s1 `snocOL` s2 - `snocOL` s3 `snocOL` s4, top) - - -- If its a bit type then we use the slow method since - -- we can't avoid casting anyway. - False -> genStore_slow addr val meta - - --- | CmmStore operation --- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData -genStore_slow addr val meta = do - (vaddr, stmts1, top1) <- exprToVar addr - (vval, stmts2, top2) <- exprToVar val - - let stmts = stmts1 `appOL` stmts2 - dflags <- getDynFlags - case getVarType vaddr of - -- sometimes we need to cast an int to a pointer before storing - LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do - (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = MetaStmt meta $ Store v vaddr - return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) - - LMPointer _ -> do - let s1 = MetaStmt meta $ Store vval vaddr - return (stmts `snocOL` s1, top1 ++ top2) - - i@(LMInt _) | i == llvmWord dflags -> do - let vty = pLift $ getVarType vval - (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = MetaStmt meta $ Store vval vptr - return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) - - other -> - pprPanic "genStore: ptr not right type!" - (PprCmm.pprExpr addr <+> text ( - "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ showSDoc dflags (ppr vaddr))) - - --- | Unconditional branch -genBranch :: BlockId -> LlvmM StmtData -genBranch id = - let label = blockIdToLlvm id - in return (unitOL $ Branch label, []) - - --- | Conditional branch -genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData -genCondBranch cond idT idF likely = do - let labelT = blockIdToLlvm idT - let labelF = blockIdToLlvm idF - -- See Note [Literals and branch conditions]. - (vc, stmts1, top1) <- exprToVarOpt i1Option cond - if getVarType vc == i1 - then do - (vc', (stmts2, top2)) <- case likely of - Just b -> genExpectLit (if b then 1 else 0) i1 vc - _ -> pure (vc, (nilOL, [])) - let s1 = BranchIf vc' labelT labelF - return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) - else do - dflags <- getDynFlags - panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" - - --- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var. -genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData) -genExpectLit expLit expTy var = do - dflags <- getDynFlags - - let - lit = LMLitVar $ LMIntLit expLit expTy - - llvmExpectName - | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy) - | otherwise = panic $ "genExpectedLit: Type not an int!" - - (llvmExpect, stmts, top) <- - getInstrinct llvmExpectName expTy [expTy, expTy] - (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] [] - return (var', (stmts `snocOL` call, top)) - -{- Note [Literals and branch conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is important that whenever we generate branch conditions for -literals like '1', they are properly narrowed to an LLVM expression of -type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert -a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt -must be certain to return a properly narrowed type. genLit is -responsible for this, in the case of literal integers. - -Often, we won't see direct statements like: - - if(1) { - ... - } else { - ... - } - -at this point in the pipeline, because the Glorious Code Generator -will do trivial branch elimination in the sinking pass (among others,) -which will eliminate the expression entirely. - -However, it's certainly possible and reasonable for this to occur in -hand-written C-- code. Consider something like: - - #if !defined(SOME_CONDITIONAL) - #define CHECK_THING(x) 1 - #else - #define CHECK_THING(x) some_operation((x)) - #endif - - f() { - - if (CHECK_THING(xyz)) { - ... - } else { - ... - } - - } - -In such an instance, CHECK_THING might result in an *expression* in -one case, and a *literal* in the other, depending on what in -particular was #define'd. So we must be sure to properly narrow the -literal in this case to i1 as it won't be eliminated beforehand. - -For a real example of this, see ./rts/StgStdThunks.cmm - --} - - - --- | Switch branch -genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData -genSwitch cond ids = do - (vc, stmts, top) <- exprToVar cond - let ty = getVarType vc - - let labels = [ (mkIntLit ty ix, blockIdToLlvm b) - | (ix, b) <- switchTargetsCases ids ] - -- out of range is undefined, so let's just branch to first label - let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l - | otherwise = snd (head labels) - - let s1 = Switch vc defLbl labels - return $ (stmts `snocOL` s1, top) - - --- ----------------------------------------------------------------------------- --- * CmmExpr code generation --- - --- | An expression conversion return data: --- * LlvmVar: The var holding the result of the expression --- * LlvmStatements: Any statements needed to evaluate the expression --- * LlvmCmmDecl: Any global data needed for this expression -type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) - --- | Values which can be passed to 'exprToVar' to configure its --- behaviour in certain circumstances. --- --- Currently just used for determining if a comparison should return --- a boolean (i1) or a word. See Note [Literals and branch conditions]. -newtype EOption = EOption { i1Expected :: Bool } --- XXX: EOption is an ugly and inefficient solution to this problem. - --- | i1 type expected (condition scrutinee). -i1Option :: EOption -i1Option = EOption True - --- | Word type expected (usual). -wordOption :: EOption -wordOption = EOption False - --- | Convert a CmmExpr to a list of LlvmStatements with the result of the --- expression being stored in the returned LlvmVar. -exprToVar :: CmmExpr -> LlvmM ExprData -exprToVar = exprToVarOpt wordOption - -exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData -exprToVarOpt opt e = case e of - - CmmLit lit - -> genLit opt lit - - CmmLoad e' ty - -> genLoad False e' ty - - -- Cmmreg in expression is the value, so must load. If you want actual - -- reg pointer, call getCmmReg directly. - CmmReg r -> do - (v1, ty, s1) <- getCmmRegVal r - case isPointer ty of - True -> do - -- Cmm wants the value, so pointer types must be cast to ints - dflags <- getDynFlags - (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) - return (v2, s1 `snocOL` s2, []) - - False -> return (v1, s1, []) - - CmmMachOp op exprs - -> genMachOp opt op exprs - - CmmRegOff r i - -> do dflags <- getDynFlags - exprToVar $ expandCmmReg dflags (r, i) - - CmmStackSlot _ _ - -> panic "exprToVar: CmmStackSlot not supported!" - - --- | Handle CmmMachOp expressions -genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData - --- Unary Machop -genMachOp _ op [x] = case op of - - MO_Not w -> - let all1 = mkIntLit (widthToLlvmInt w) (-1) - in negate (widthToLlvmInt w) all1 LM_MO_Xor - - MO_S_Neg w -> - let all0 = mkIntLit (widthToLlvmInt w) 0 - in negate (widthToLlvmInt w) all0 LM_MO_Sub - - MO_F_Neg w -> - let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w) - in negate (widthToLlvmFloat w) all0 LM_MO_FSub - - MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp - MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi - - MO_SS_Conv from to - -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext - - MO_UU_Conv from to - -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext - - MO_XX_Conv from to - -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext - - MO_FF_Conv from to - -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext - - MO_VS_Neg len w -> - let ty = widthToLlvmInt w - vecty = LMVector len ty - all0 = LMIntLit (-0) ty - all0s = LMLitVar $ LMVectorLit (replicate len all0) - in negateVec vecty all0s LM_MO_Sub - - MO_VF_Neg len w -> - let ty = widthToLlvmFloat w - vecty = LMVector len ty - all0 = LMFloatLit (-0) ty - all0s = LMLitVar $ LMVectorLit (replicate len all0) - in negateVec vecty all0s LM_MO_FSub - - MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm" - - -- Handle unsupported cases explicitly so we get a warning - -- of missing case when new MachOps added - MO_Add _ -> panicOp - MO_Mul _ -> panicOp - MO_Sub _ -> panicOp - MO_S_MulMayOflo _ -> panicOp - MO_S_Quot _ -> panicOp - MO_S_Rem _ -> panicOp - MO_U_MulMayOflo _ -> panicOp - MO_U_Quot _ -> panicOp - MO_U_Rem _ -> panicOp - - MO_Eq _ -> panicOp - MO_Ne _ -> panicOp - MO_S_Ge _ -> panicOp - MO_S_Gt _ -> panicOp - MO_S_Le _ -> panicOp - MO_S_Lt _ -> panicOp - MO_U_Ge _ -> panicOp - MO_U_Gt _ -> panicOp - MO_U_Le _ -> panicOp - MO_U_Lt _ -> panicOp - - MO_F_Add _ -> panicOp - MO_F_Sub _ -> panicOp - MO_F_Mul _ -> panicOp - MO_F_Quot _ -> panicOp - MO_F_Eq _ -> panicOp - MO_F_Ne _ -> panicOp - MO_F_Ge _ -> panicOp - MO_F_Gt _ -> panicOp - MO_F_Le _ -> panicOp - MO_F_Lt _ -> panicOp - - MO_And _ -> panicOp - MO_Or _ -> panicOp - MO_Xor _ -> panicOp - MO_Shl _ -> panicOp - MO_U_Shr _ -> panicOp - MO_S_Shr _ -> panicOp - - MO_V_Insert _ _ -> panicOp - MO_V_Extract _ _ -> panicOp - - MO_V_Add _ _ -> panicOp - MO_V_Sub _ _ -> panicOp - MO_V_Mul _ _ -> panicOp - - MO_VS_Quot _ _ -> panicOp - MO_VS_Rem _ _ -> panicOp - - MO_VU_Quot _ _ -> panicOp - MO_VU_Rem _ _ -> panicOp - - MO_VF_Insert _ _ -> panicOp - MO_VF_Extract _ _ -> panicOp - - MO_VF_Add _ _ -> panicOp - MO_VF_Sub _ _ -> panicOp - MO_VF_Mul _ _ -> panicOp - MO_VF_Quot _ _ -> panicOp - - where - negate ty v2 negOp = do - (vx, stmts, top) <- exprToVar x - (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx - return (v1, stmts `snocOL` s1, top) - - negateVec ty v2 negOp = do - (vx, stmts1, top) <- exprToVar x - (vxs', stmts2) <- castVars Signed [(vx, ty)] - let vx' = singletonPanic "genMachOp: negateVec" vxs' - (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' - return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) - - fiConv ty convOp = do - (vx, stmts, top) <- exprToVar x - (v1, s1) <- doExpr ty $ Cast convOp vx ty - return (v1, stmts `snocOL` s1, top) - - sameConv from ty reduce expand = do - x'@(vx, stmts, top) <- exprToVar x - let sameConv' op = do - (v1, s1) <- doExpr ty $ Cast op vx ty - return (v1, stmts `snocOL` s1, top) - dflags <- getDynFlags - let toWidth = llvmWidthInBits dflags ty - -- LLVM doesn't like trying to convert to same width, so - -- need to check for that as we do get Cmm code doing it. - case widthInBits from of - w | w < toWidth -> sameConv' expand - w | w > toWidth -> sameConv' reduce - _w -> return x' - - panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered" - ++ "with one argument! (" ++ show op ++ ")" - --- Handle GlobalRegs pointers -genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast opt o r (fromInteger n) e - -genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast opt o r (negate . fromInteger $ n) e - --- Generic case -genMachOp opt op e = genMachOp_slow opt op e - - --- | Handle CmmMachOp expressions --- This is a specialised method that handles Global register manipulations like --- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] - -> LlvmM ExprData -genMachOp_fast opt op r n e - = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - dflags <- getDynFlags - let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - case isPointer grt && rem == 0 of - True -> do - (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) - return (var, s1 `snocOL` s2 `snocOL` s3, []) - - False -> genMachOp_slow opt op e - - --- | Handle CmmMachOp expressions --- This handles all the cases not handle by the specialised genMachOp_fast. -genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData - --- Element extraction -genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do - vval <- exprToVarW val - vidx <- exprToVarW idx - vval' <- singletonPanic "genMachOp_slow" <$> - castVarsW Signed [(vval, LMVector l ty)] - doExprW ty $ Extract vval' vidx - where - ty = widthToLlvmInt w - -genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do - vval <- exprToVarW val - vidx <- exprToVarW idx - vval' <- singletonPanic "genMachOp_slow" <$> - castVarsW Signed [(vval, LMVector l ty)] - doExprW ty $ Extract vval' vidx - where - ty = widthToLlvmFloat w - --- Element insertion -genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do - vval <- exprToVarW val - velt <- exprToVarW elt - vidx <- exprToVarW idx - vval' <- singletonPanic "genMachOp_slow" <$> - castVarsW Signed [(vval, ty)] - doExprW ty $ Insert vval' velt vidx - where - ty = LMVector l (widthToLlvmInt w) - -genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do - vval <- exprToVarW val - velt <- exprToVarW elt - vidx <- exprToVarW idx - vval' <- singletonPanic "genMachOp_slow" <$> - castVarsW Signed [(vval, ty)] - doExprW ty $ Insert vval' velt vidx - where - ty = LMVector l (widthToLlvmFloat w) - --- Binary MachOp -genMachOp_slow opt op [x, y] = case op of - - MO_Eq _ -> genBinComp opt LM_CMP_Eq - MO_Ne _ -> genBinComp opt LM_CMP_Ne - - MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt - MO_S_Ge _ -> genBinComp opt LM_CMP_Sge - MO_S_Lt _ -> genBinComp opt LM_CMP_Slt - MO_S_Le _ -> genBinComp opt LM_CMP_Sle - - MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt - MO_U_Ge _ -> genBinComp opt LM_CMP_Uge - MO_U_Lt _ -> genBinComp opt LM_CMP_Ult - MO_U_Le _ -> genBinComp opt LM_CMP_Ule - - MO_Add _ -> genBinMach LM_MO_Add - MO_Sub _ -> genBinMach LM_MO_Sub - MO_Mul _ -> genBinMach LM_MO_Mul - - MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!" - - MO_S_MulMayOflo w -> isSMulOK w x y - - MO_S_Quot _ -> genBinMach LM_MO_SDiv - MO_S_Rem _ -> genBinMach LM_MO_SRem - - MO_U_Quot _ -> genBinMach LM_MO_UDiv - MO_U_Rem _ -> genBinMach LM_MO_URem - - MO_F_Eq _ -> genBinComp opt LM_CMP_Feq - MO_F_Ne _ -> genBinComp opt LM_CMP_Fne - MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt - MO_F_Ge _ -> genBinComp opt LM_CMP_Fge - MO_F_Lt _ -> genBinComp opt LM_CMP_Flt - MO_F_Le _ -> genBinComp opt LM_CMP_Fle - - MO_F_Add _ -> genBinMach LM_MO_FAdd - MO_F_Sub _ -> genBinMach LM_MO_FSub - MO_F_Mul _ -> genBinMach LM_MO_FMul - MO_F_Quot _ -> genBinMach LM_MO_FDiv - - MO_And _ -> genBinMach LM_MO_And - MO_Or _ -> genBinMach LM_MO_Or - MO_Xor _ -> genBinMach LM_MO_Xor - MO_Shl _ -> genBinMach LM_MO_Shl - MO_U_Shr _ -> genBinMach LM_MO_LShr - MO_S_Shr _ -> genBinMach LM_MO_AShr - - MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add - MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub - MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul - - MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv - MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem - - MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv - MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem - - MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd - MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub - MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul - MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv - - MO_Not _ -> panicOp - MO_S_Neg _ -> panicOp - MO_F_Neg _ -> panicOp - - MO_SF_Conv _ _ -> panicOp - MO_FS_Conv _ _ -> panicOp - MO_SS_Conv _ _ -> panicOp - MO_UU_Conv _ _ -> panicOp - MO_XX_Conv _ _ -> panicOp - MO_FF_Conv _ _ -> panicOp - - MO_V_Insert {} -> panicOp - MO_V_Extract {} -> panicOp - - MO_VS_Neg {} -> panicOp - - MO_VF_Insert {} -> panicOp - MO_VF_Extract {} -> panicOp - - MO_VF_Neg {} -> panicOp - - MO_AlignmentCheck {} -> panicOp - - where - binLlvmOp ty binOp = runExprData $ do - vx <- exprToVarW x - vy <- exprToVarW y - if getVarType vx == getVarType vy - then do - doExprW (ty vx) $ binOp vx vy - - else do - -- Error. Continue anyway so we can debug the generated ll file. - dflags <- getDynFlags - let style = mkCodeStyle CStyle - toString doc = renderWithStyle dflags doc style - cmmToStr = (lines . toString . PprCmm.pprExpr) - statement $ Comment $ map fsLit $ cmmToStr x - statement $ Comment $ map fsLit $ cmmToStr y - doExprW (ty vx) $ binOp vx vy - - binCastLlvmOp ty binOp = runExprData $ do - vx <- exprToVarW x - vy <- exprToVarW y - vxy' <- castVarsW Signed [(vx, ty), (vy, ty)] - case vxy' of - [vx',vy'] -> doExprW ty $ binOp vx' vy' - _ -> panic "genMachOp_slow: binCastLlvmOp" - - -- | Need to use EOption here as Cmm expects word size results from - -- comparisons while LLVM return i1. Need to extend to llvmWord type - -- if expected. See Note [Literals and branch conditions]. - genBinComp opt cmp = do - ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) - dflags <- getDynFlags - if getVarType v1 == i1 - then case i1Expected opt of - True -> return ed - False -> do - let w_ = llvmWord dflags - (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ - return (v2, stmts `snocOL` s1, top) - else - panic $ "genBinComp: Compare returned type other then i1! " - ++ (showSDoc dflags $ ppr $ getVarType v1) - - genBinMach op = binLlvmOp getVarType (LlvmOp op) - - genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) - - -- | Detect if overflow will occur in signed multiply of the two - -- CmmExpr's. This is the LLVM assembly equivalent of the NCG - -- implementation. Its much longer due to type information/safety. - -- This should actually compile to only about 3 asm instructions. - isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData - isSMulOK _ x y = runExprData $ do - vx <- exprToVarW x - vy <- exprToVarW y - - dflags <- getDynFlags - let word = getVarType vx - let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) - let shift = llvmWidthInBits dflags word - let shift1 = toIWord dflags (shift - 1) - let shift2 = toIWord dflags shift - - if isInt word - then do - x1 <- doExprW word2 $ Cast LM_Sext vx word2 - y1 <- doExprW word2 $ Cast LM_Sext vy word2 - r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1 - rlow1 <- doExprW word $ Cast LM_Trunc r1 word - rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1 - rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2 - rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word - doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2 - - else - panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" - - panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" - ++ "with two arguments! (" ++ show op ++ ")" - --- More than two expression, invalid! -genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!" - - --- | Handle CmmLoad expression. -genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData - --- First we try to detect a few common cases and produce better code for --- these then the default case. We are mostly trying to detect Cmm code --- like I32[Sp + n] and use 'getelementptr' operations instead of the --- generic case that uses casts and pointer arithmetic -genLoad atomic e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast atomic e r 0 ty - -genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast atomic e r n ty - -genLoad atomic e@(CmmMachOp (MO_Add _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - ty - = genLoad_fast atomic e r (fromInteger n) ty - -genLoad atomic e@(CmmMachOp (MO_Sub _) [ - (CmmReg (CmmGlobal r)), - (CmmLit (CmmInt n _))]) - ty - = genLoad_fast atomic e r (negate $ fromInteger n) ty - --- generic case -genLoad atomic e ty - = getTBAAMeta topN >>= genLoad_slow atomic e ty - --- | Handle CmmLoad expression. --- This is a special case for loading from a global register pointer --- offset such as I32[Sp+8]. -genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType - -> LlvmM ExprData -genLoad_fast atomic e r n ty = do - dflags <- getDynFlags - (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r - let ty' = cmmToLlvmType ty - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - case isPointer grt && rem == 0 of - True -> do - (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - -- We might need a different pointer type, so check - case grt == ty' of - -- were fine - True -> do - (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr) - return (var, s1 `snocOL` s2 `snocOL` s3, - []) - - -- cast to pointer type needed - False -> do - let pty = pLift ty' - (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr') - return (var, s1 `snocOL` s2 `snocOL` s3 - `snocOL` s4, []) - - -- If its a bit type then we use the slow method since - -- we can't avoid casting anyway. - False -> genLoad_slow atomic e ty meta - where - loadInstr ptr | atomic = ALoad SyncSeqCst False ptr - | otherwise = Load ptr - --- | Handle Cmm load expression. --- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData -genLoad_slow atomic e ty meta = runExprData $ do - iptr <- exprToVarW e - dflags <- getDynFlags - case getVarType iptr of - LMPointer _ -> do - doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) - - i@(LMInt _) | i == llvmWord dflags -> do - let pty = LMPointer $ cmmToLlvmType ty - ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty - doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr) - - other -> do pprPanic "exprToVar: CmmLoad expression is not right type!" - (PprCmm.pprExpr e <+> text ( - "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ showSDoc dflags (ppr iptr))) - where - loadInstr ptr | atomic = ALoad SyncSeqCst False ptr - | otherwise = Load ptr - - --- | Handle CmmReg expression. This will return a pointer to the stack --- location of the register. Throws an error if it isn't allocated on --- the stack. -getCmmReg :: CmmReg -> LlvmM LlvmVar -getCmmReg (CmmLocal (LocalReg un _)) - = do exists <- varLookup un - dflags <- getDynFlags - case exists of - Just ety -> return (LMLocalVar un $ pLift ety) - Nothing -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" - -- This should never happen, as every local variable should - -- have been assigned a value at some point, triggering - -- "funPrologue" to allocate it on the stack. - -getCmmReg (CmmGlobal g) - = do onStack <- checkStackReg g - dflags <- getDynFlags - if onStack - then return (lmGlobalRegVar dflags g) - else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" - --- | Return the value of a given register, as well as its type. Might --- need to be load from stack. -getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) -getCmmRegVal reg = - case reg of - CmmGlobal g -> do - onStack <- checkStackReg g - dflags <- getDynFlags - if onStack then loadFromStack else do - let r = lmGlobalRegArg dflags g - return (r, getVarType r, nilOL) - _ -> loadFromStack - where loadFromStack = do - ptr <- getCmmReg reg - let ty = pLower $ getVarType ptr - (v, s) <- doExpr ty (Load ptr) - return (v, ty, unitOL s) - --- | Allocate a local CmmReg on the stack -allocReg :: CmmReg -> (LlvmVar, LlvmStatements) -allocReg (CmmLocal (LocalReg un ty)) - = let ty' = cmmToLlvmType ty - var = LMLocalVar un (LMPointer ty') - alc = Alloca ty' 1 - in (var, unitOL $ Assignment var alc) - -allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" - ++ " have been handled elsewhere!" - - --- | Generate code for a literal -genLit :: EOption -> CmmLit -> LlvmM ExprData -genLit opt (CmmInt i w) - -- See Note [Literals and branch conditions]. - = let width | i1Expected opt = i1 - | otherwise = LMInt (widthInBits w) - -- comm = Comment [ fsLit $ "EOption: " ++ show opt - -- , fsLit $ "Width : " ++ show w - -- , fsLit $ "Width' : " ++ show (widthInBits w) - -- ] - in return (mkIntLit width i, nilOL, []) - -genLit _ (CmmFloat r w) - = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), - nilOL, []) - -genLit opt (CmmVec ls) - = do llvmLits <- mapM toLlvmLit ls - return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) - where - toLlvmLit :: CmmLit -> LlvmM LlvmLit - toLlvmLit lit = do - (llvmLitVar, _, _) <- genLit opt lit - case llvmLitVar of - LMLitVar llvmLit -> return llvmLit - _ -> panic "genLit" - -genLit _ cmm@(CmmLabel l) - = do var <- getGlobalPtr =<< strCLabel_llvm l - dflags <- getDynFlags - let lmty = cmmToLlvmType $ cmmLitType dflags cmm - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (v1, unitOL s1, []) - -genLit opt (CmmLabelOff label off) = do - dflags <- getDynFlags - (vlbl, stmts, stat) <- genLit opt (CmmLabel label) - let voff = toIWord dflags off - (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff - return (v1, stmts `snocOL` s1, stat) - -genLit opt (CmmLabelDiffOff l1 l2 off w) = do - dflags <- getDynFlags - (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) - (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) - let voff = toIWord dflags off - let ty1 = getVarType vl1 - let ty2 = getVarType vl2 - if (isInt ty1) && (isInt ty2) - && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2) - then do - (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 - (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff - let ty = widthToLlvmInt w - let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2 - if w /= wordWidth dflags - then do - (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty - return (v3, stmts `snocOL` s3, stat1 ++ stat2) - else - return (v2, stmts, stat1 ++ stat2) - else - panic "genLit: CmmLabelDiffOff encountered with different label ty!" - -genLit opt (CmmBlock b) - = genLit opt (CmmLabel $ infoTblLbl b) - -genLit _ CmmHighStackMark - = panic "genStaticLit - CmmHighStackMark unsupported!" - - --- ----------------------------------------------------------------------------- --- * Misc --- - --- | Find CmmRegs that get assigned and allocate them on the stack --- --- Any register that gets written needs to be allcoated on the --- stack. This avoids having to map a CmmReg to an equivalent SSA form --- and avoids having to deal with Phi node insertion. This is also --- the approach recommended by LLVM developers. --- --- On the other hand, this is unnecessarily verbose if the register in --- question is never written. Therefore we skip it where we can to --- save a few lines in the output and hopefully speed compilation up a --- bit. -funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData -funPrologue live cmmBlocks = do - - trash <- getTrashRegs - let getAssignedRegs :: CmmNode O O -> [CmmReg] - getAssignedRegs (CmmAssign reg _) = [reg] - -- Calls will trash all registers. Unfortunately, this needs them to - -- be stack-allocated in the first place. - getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs - getAssignedRegs _ = [] - getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body - assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks - isLive r = r `elem` alwaysLive || r `elem` live - - dflags <- getDynFlags - stmtss <- forM assignedRegs $ \reg -> - case reg of - CmmLocal (LocalReg un _) -> do - let (newv, stmts) = allocReg reg - varInsert un (pLower $ getVarType newv) - return stmts - CmmGlobal r -> do - let reg = lmGlobalRegVar dflags r - arg = lmGlobalRegArg dflags r - ty = (pLower . getVarType) reg - trash = LMLitVar $ LMUndefLit ty - rval = if isLive r then arg else trash - alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - markStackReg r - return $ toOL [alloc, Store rval reg] - - return (concatOL stmtss `snocOL` jumpToEntry, []) - where - entryBlk : _ = cmmBlocks - jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk) - --- | Function epilogue. Load STG variables to use as argument for call. --- STG Liveness optimisation done here. -funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) -funEpilogue live = do - dflags <- getDynFlags - - let paddingRegs = padLiveArgs dflags live - - -- Set to value or "undef" depending on whether the register is - -- actually live - let loadExpr r = do - (v, _, s) <- getCmmRegVal (CmmGlobal r) - return (Just $ v, s) - loadUndef r = do - let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) - return (Just $ LMLitVar $ LMUndefLit ty, nilOL) - - -- Note that floating-point registers in `activeStgRegs` must be sorted - -- according to the calling convention. - -- E.g. for X86: - -- GOOD: F1,D1,XMM1,F2,D2,XMM2,... - -- BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,... - -- As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't - -- want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1 - -- and D1 -> XMM2. - let allRegs = activeStgRegs (targetPlatform dflags) - loads <- forM allRegs $ \r -> if - -- load live registers - | r `elem` alwaysLive -> loadExpr r - | r `elem` live -> loadExpr r - -- load all non Floating-Point Registers - | not (isFPR r) -> loadUndef r - -- load padding Floating-Point Registers - | r `elem` paddingRegs -> loadUndef r - | otherwise -> return (Nothing, nilOL) - - let (vars, stmts) = unzip loads - return (catMaybes vars, concatOL stmts) - - --- | A series of statements to trash all the STG registers. --- --- In LLVM we pass the STG registers around everywhere in function calls. --- So this means LLVM considers them live across the entire function, when --- in reality they usually aren't. For Caller save registers across C calls --- the saving and restoring of them is done by the Cmm code generator, --- using Cmm local vars. So to stop LLVM saving them as well (and saving --- all of them since it thinks they're always live, we trash them just --- before the call by assigning the 'undef' value to them. The ones we --- need are restored from the Cmm local var and the ones we don't need --- are fine to be trashed. -getTrashStmts :: LlvmM LlvmStatements -getTrashStmts = do - regs <- getTrashRegs - stmts <- flip mapM regs $ \ r -> do - reg <- getCmmReg (CmmGlobal r) - let ty = (pLower . getVarType) reg - return $ Store (LMLitVar $ LMUndefLit ty) reg - return $ toOL stmts - -getTrashRegs :: LlvmM [GlobalReg] -getTrashRegs = do plat <- getLlvmPlatform - return $ filter (callerSaves plat) (activeStgRegs plat) - --- | Get a function pointer to the CLabel specified. --- --- This is for Haskell functions, function type is assumed, so doesn't work --- with foreign functions. -getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData -getHsFunc live lbl - = do fty <- llvmFunTy live - name <- strCLabel_llvm lbl - getHsFunc' name fty - -getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData -getHsFunc' name fty - = do fun <- getGlobalPtr name - if getVarType fun == fty - then return (fun, nilOL, []) - else do (v1, s1) <- doExpr (pLift fty) - $ Cast LM_Bitcast fun (pLift fty) - return (v1, unitOL s1, []) - --- | Create a new local var -mkLocalVar :: LlvmType -> LlvmM LlvmVar -mkLocalVar ty = do - un <- getUniqueM - return $ LMLocalVar un ty - - --- | Execute an expression, assigning result to a var -doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) -doExpr ty expr = do - v <- mkLocalVar ty - return (v, Assignment v expr) - - --- | Expand CmmRegOff -expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr -expandCmmReg dflags (reg, off) - = let width = typeWidth (cmmRegType dflags reg) - voff = CmmLit $ CmmInt (fromIntegral off) width - in CmmMachOp (MO_Add width) [CmmReg reg, voff] - - --- | Convert a block id into a appropriate Llvm label -blockIdToLlvm :: BlockId -> LlvmVar -blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel - --- | Create Llvm int Literal -mkIntLit :: Integral a => LlvmType -> a -> LlvmVar -mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty - --- | Convert int type to a LLvmVar of word or i32 size -toI32 :: Integral a => a -> LlvmVar -toI32 = mkIntLit i32 - -toIWord :: Integral a => DynFlags -> a -> LlvmVar -toIWord dflags = mkIntLit (llvmWord dflags) - - --- | Error functions -panic :: String -> a -panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s - -pprPanic :: String -> SDoc -> a -pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d - - --- | Returns TBAA meta data by unique -getTBAAMeta :: Unique -> LlvmM [MetaAnnot] -getTBAAMeta u = do - mi <- getUniqMeta u - return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] - --- | Returns TBAA meta data for given register -getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] -getTBAARegMeta = getTBAAMeta . getTBAA - - --- | A more convenient way of accumulating LLVM statements and declarations. -data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl] - -instance Semigroup LlvmAccum where - LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB = - LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB) - -instance Monoid LlvmAccum where - mempty = LlvmAccum nilOL [] - mappend = (Semigroup.<>) - -liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar -liftExprData action = do - (var, stmts, decls) <- lift action - tell $ LlvmAccum stmts decls - return var - -statement :: LlvmStatement -> WriterT LlvmAccum LlvmM () -statement stmt = tell $ LlvmAccum (unitOL stmt) [] - -doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar -doExprW a b = do - (var, stmt) <- lift $ doExpr a b - statement stmt - return var - -exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar -exprToVarW = liftExprData . exprToVar - -runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData -runExprData action = do - (var, LlvmAccum stmts decls) <- runWriterT action - return (var, stmts, decls) - -runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl]) -runStmtsDecls action = do - LlvmAccum stmts decls <- execWriterT action - return (stmts, decls) - -getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar -getCmmRegW = lift . getCmmReg - -genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar -genLoadW atomic e ty = liftExprData $ genLoad atomic e ty - -doTrashStmts :: WriterT LlvmAccum LlvmM () -doTrashStmts = do - stmts <- lift getTrashStmts - tell $ LlvmAccum stmts mempty - --- | Return element of single-element list; 'panic' if list is not a single-element list -singletonPanic :: String -> [a] -> a -singletonPanic _ [x] = x -singletonPanic s _ = panic s diff --git a/llvmGen/LlvmCodeGen/Data.hs b/llvmGen/LlvmCodeGen/Data.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Data.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE CPP #-} --- ---------------------------------------------------------------------------- --- | Handle conversion of CmmData to LLVM code. --- - -module LlvmCodeGen.Data ( - genLlvmData, genData - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Llvm -import LlvmCodeGen.Base - -import BlockId -import CLabel -import Cmm -import DynFlags -import GHC.Platform - -import FastString -import Outputable -import qualified Data.ByteString as BS - --- ---------------------------------------------------------------------------- --- * Constants --- - --- | The string appended to a variable name to create its structure type alias -structStr :: LMString -structStr = fsLit "_struct" - --- | The LLVM visibility of the label -linkage :: CLabel -> LlvmLinkageType -linkage lbl = if externallyVisibleCLabel lbl - then ExternallyVisible else Internal - --- ---------------------------------------------------------------------------- --- * Top level --- - --- | Pass a CmmStatic section to an equivalent Llvm code. -genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData --- See note [emit-time elimination of static indirections] in CLabel. -genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) - | lbl == mkIndStaticInfoLabel - , let labelInd (CmmLabelOff l _) = Just l - labelInd (CmmLabel l) = Just l - labelInd _ = Nothing - , Just ind' <- labelInd ind - , alias `mayRedirectTo` ind' = do - label <- strCLabel_llvm alias - label' <- strCLabel_llvm ind' - let link = linkage alias - link' = linkage ind' - -- the LLVM type we give the alias is an empty struct type - -- but it doesn't really matter, as the pointer is only - -- used for (bit/int)casting. - tyAlias = LMAlias (label `appendFS` structStr, LMStructU []) - - aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias - -- we don't know the type of the indirectee here - indType = panic "will be filled by 'aliasify', later" - orig = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias - - pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) - -genLlvmData (sec, Statics lbl xs) = do - label <- strCLabel_llvm lbl - static <- mapM genData xs - lmsec <- llvmSection sec - platform <- getLlvmPlatform - let types = map getStatType static - - strucTy = LMStruct types - tyAlias = LMAlias (label `appendFS` structStr, strucTy) - - struct = Just $ LMStaticStruc static tyAlias - link = linkage lbl - align = case sec of - Section CString _ -> if (platformArch platform == ArchS390X) - then Just 2 else Just 1 - _ -> Nothing - const = if sectionProtection sec == ReadOnlySection - then Constant else Global - varDef = LMGlobalVar label tyAlias link lmsec align const - globDef = LMGlobal varDef struct - - return ([globDef], [tyAlias]) - --- | Format the section type part of a Cmm Section -llvmSectionType :: Platform -> SectionType -> FastString -llvmSectionType p t = case t of - Text -> fsLit ".text" - ReadOnlyData -> case platformOS p of - OSMinGW32 -> fsLit ".rdata" - _ -> fsLit ".rodata" - RelocatableReadOnlyData -> case platformOS p of - OSMinGW32 -> fsLit ".rdata$rel.ro" - _ -> fsLit ".data.rel.ro" - ReadOnlyData16 -> case platformOS p of - OSMinGW32 -> fsLit ".rdata$cst16" - _ -> fsLit ".rodata.cst16" - Data -> fsLit ".data" - UninitialisedData -> fsLit ".bss" - CString -> case platformOS p of - OSMinGW32 -> fsLit ".rdata$str" - _ -> fsLit ".rodata.str" - (OtherSection _) -> panic "llvmSectionType: unknown section type" - --- | Format a Cmm Section into a LLVM section name -llvmSection :: Section -> LlvmM LMSection -llvmSection (Section t suffix) = do - dflags <- getDynFlags - let splitSect = gopt Opt_SplitSections dflags - platform = targetPlatform dflags - if not splitSect - then return Nothing - else do - lmsuffix <- strCLabel_llvm suffix - let result sep = Just (concatFS [llvmSectionType platform t - , fsLit sep, lmsuffix]) - case platformOS platform of - OSMinGW32 -> return (result "$") - _ -> return (result ".") - --- ---------------------------------------------------------------------------- --- * Generate static data --- - --- | Handle static data -genData :: CmmStatic -> LlvmM LlvmStatic - -genData (CmmString str) = do - let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) - (BS.unpack str) - ve = v ++ [LMStaticLit $ LMIntLit 0 i8] - return $ LMStaticArray ve (LMArray (length ve) i8) - -genData (CmmUninitialised bytes) - = return $ LMUninitType (LMArray bytes i8) - -genData (CmmStaticLit lit) - = genStaticLit lit - --- | Generate Llvm code for a static literal. --- --- Will either generate the code or leave it unresolved if it is a 'CLabel' --- which isn't yet known. -genStaticLit :: CmmLit -> LlvmM LlvmStatic -genStaticLit (CmmInt i w) - = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) - -genStaticLit (CmmFloat r w) - = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) - -genStaticLit (CmmVec ls) - = do sls <- mapM toLlvmLit ls - return $ LMStaticLit (LMVectorLit sls) - where - toLlvmLit :: CmmLit -> LlvmM LlvmLit - toLlvmLit lit = do - slit <- genStaticLit lit - case slit of - LMStaticLit llvmLit -> return llvmLit - _ -> panic "genStaticLit" - --- Leave unresolved, will fix later -genStaticLit cmm@(CmmLabel l) = do - var <- getGlobalPtr =<< strCLabel_llvm l - dflags <- getDynFlags - let ptr = LMStaticPointer var - lmty = cmmToLlvmType $ cmmLitType dflags cmm - return $ LMPtoI ptr lmty - -genStaticLit (CmmLabelOff label off) = do - dflags <- getDynFlags - var <- genStaticLit (CmmLabel label) - let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - return $ LMAdd var offset - -genStaticLit (CmmLabelDiffOff l1 l2 off w) = do - dflags <- getDynFlags - var1 <- genStaticLit (CmmLabel l1) - var2 <- genStaticLit (CmmLabel l2) - let var - | w == wordWidth dflags = LMSub var1 var2 - | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w) - offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w) - return $ LMAdd var offset - -genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b - -genStaticLit (CmmHighStackMark) - = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/llvmGen/LlvmCodeGen/Ppr.hs b/llvmGen/LlvmCodeGen/Ppr.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Ppr.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ---------------------------------------------------------------------------- --- | Pretty print helpers for the LLVM Code generator. --- -module LlvmCodeGen.Ppr ( - pprLlvmCmmDecl, pprLlvmData, infoSection - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Llvm -import LlvmCodeGen.Base -import LlvmCodeGen.Data - -import CLabel -import Cmm - -import FastString -import Outputable -import Unique - --- ---------------------------------------------------------------------------- --- * Top level --- - --- | Pretty print LLVM data code -pprLlvmData :: LlvmData -> SDoc -pprLlvmData (globals, types) = - let ppLlvmTys (LMAlias a) = ppLlvmAlias a - ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f - ppLlvmTys _other = empty - - types' = vcat $ map ppLlvmTys types - globals' = ppLlvmGlobals globals - in types' $+$ globals' - - --- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) -pprLlvmCmmDecl (CmmData _ lmdata) - = return (vcat $ map pprLlvmData lmdata, []) - -pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) - = do let lbl = case mb_info of - Nothing -> entry_lbl - Just (Statics info_lbl _) -> info_lbl - link = if externallyVisibleCLabel lbl - then ExternallyVisible - else Internal - lmblocks = map (\(BasicBlock id stmts) -> - LlvmBlock (getUnique id) stmts) blks - - funDec <- llvmFunSig live lbl link - dflags <- getDynFlags - let buildArg = fsLit . showSDoc dflags . ppPlainName - funArgs = map buildArg (llvmFunArgs dflags live) - funSect = llvmFunSection dflags (decName funDec) - - -- generate the info table - prefix <- case mb_info of - Nothing -> return Nothing - Just (Statics _ statics) -> do - infoStatics <- mapM genData statics - let infoTy = LMStruct $ map getStatType infoStatics - return $ Just $ LMStaticStruc infoStatics infoTy - - - let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect - prefix lmblocks - name = decName $ funcDecl fun - defName = llvmDefLabel name - funcDecl' = (funcDecl fun) { decName = defName } - fun' = fun { funcDecl = funcDecl' } - funTy = LMFunction funcDecl' - funVar = LMGlobalVar name - (LMPointer funTy) - link - Nothing - Nothing - Alias - defVar = LMGlobalVar defName - (LMPointer funTy) - (funcLinkage funcDecl') - (funcSect fun) - (funcAlign funcDecl') - Alias - alias = LMGlobal funVar - (Just $ LMBitc (LMStaticPointer defVar) - i8Ptr) - - return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', []) - - --- | The section we are putting info tables and their entry code into, should --- be unique since we process the assembly pattern matching this. -infoSection :: String -infoSection = "X98A__STRIP,__me" diff --git a/llvmGen/LlvmCodeGen/Regs.hs b/llvmGen/LlvmCodeGen/Regs.hs deleted file mode 100644 --- a/llvmGen/LlvmCodeGen/Regs.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP #-} - --------------------------------------------------------------------------------- --- | Deal with Cmm registers --- - -module LlvmCodeGen.Regs ( - lmGlobalRegArg, lmGlobalRegVar, alwaysLive, - stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Llvm - -import CmmExpr -import DynFlags -import FastString -import Outputable ( panic ) -import Unique - --- | Get the LlvmVar function variable storing the real register -lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar -lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var" - --- | Get the LlvmVar function argument storing the real register -lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar -lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg" - -{- Need to make sure the names here can't conflict with the unique generated - names. Uniques generated names containing only base62 chars. So using say - the '_' char guarantees this. --} -lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar -lmGlobalReg dflags suf reg - = case reg of - BaseReg -> ptrGlobal $ "Base" ++ suf - Sp -> ptrGlobal $ "Sp" ++ suf - Hp -> ptrGlobal $ "Hp" ++ suf - VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf - VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf - VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf - VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf - VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf - VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf - VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf - VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf - SpLim -> wordGlobal $ "SpLim" ++ suf - FloatReg 1 -> floatGlobal $"F1" ++ suf - FloatReg 2 -> floatGlobal $"F2" ++ suf - FloatReg 3 -> floatGlobal $"F3" ++ suf - FloatReg 4 -> floatGlobal $"F4" ++ suf - FloatReg 5 -> floatGlobal $"F5" ++ suf - FloatReg 6 -> floatGlobal $"F6" ++ suf - DoubleReg 1 -> doubleGlobal $ "D1" ++ suf - DoubleReg 2 -> doubleGlobal $ "D2" ++ suf - DoubleReg 3 -> doubleGlobal $ "D3" ++ suf - DoubleReg 4 -> doubleGlobal $ "D4" ++ suf - DoubleReg 5 -> doubleGlobal $ "D5" ++ suf - DoubleReg 6 -> doubleGlobal $ "D6" ++ suf - XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf - XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf - XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf - XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf - XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf - XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf - YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf - YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf - YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf - YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf - YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf - YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf - ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf - ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf - ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf - ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf - ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf - ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf - MachSp -> wordGlobal $ "MachSp" ++ suf - _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) - ++ ") not supported!" - -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc - -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg - where - wordGlobal name = LMNLocalVar (fsLit name) (llvmWord dflags) - ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr dflags) - floatGlobal name = LMNLocalVar (fsLit name) LMFloat - doubleGlobal name = LMNLocalVar (fsLit name) LMDouble - xmmGlobal name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32)) - ymmGlobal name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32)) - zmmGlobal name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32)) - --- | A list of STG Registers that should always be considered alive -alwaysLive :: [GlobalReg] -alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] - --- | STG Type Based Alias Analysis hierarchy -stgTBAA :: [(Unique, LMString, Maybe Unique)] -stgTBAA - = [ (rootN, fsLit "root", Nothing) - , (topN, fsLit "top", Just rootN) - , (stackN, fsLit "stack", Just topN) - , (heapN, fsLit "heap", Just topN) - , (rxN, fsLit "rx", Just heapN) - , (baseN, fsLit "base", Just topN) - -- FIX: Not 100% sure if this hierarchy is complete. I think the big thing - -- is Sp is never aliased, so might want to change the hierarchy to have Sp - -- on its own branch that is never aliased (e.g never use top as a TBAA - -- node). - ] - --- | Id values --- The `rootN` node is the root (there can be more than one) of the TBAA --- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It --- should never occur in any LLVM instruction statement. -rootN, topN, stackN, heapN, rxN, baseN :: Unique -rootN = getUnique (fsLit "LlvmCodeGen.Regs.rootN") -topN = getUnique (fsLit "LlvmCodeGen.Regs.topN") -stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN") -heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN") -rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN") -baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN") - --- | The TBAA metadata identifier -tbaa :: LMString -tbaa = fsLit "tbaa" - --- | Get the correct TBAA metadata information for this register type -getTBAA :: GlobalReg -> Unique -getTBAA BaseReg = baseN -getTBAA Sp = stackN -getTBAA Hp = heapN -getTBAA (VanillaReg _ _) = rxN -getTBAA _ = topN diff --git a/llvmGen/LlvmMangler.hs b/llvmGen/LlvmMangler.hs deleted file mode 100644 --- a/llvmGen/LlvmMangler.hs +++ /dev/null @@ -1,129 +0,0 @@ --- ----------------------------------------------------------------------------- --- | GHC LLVM Mangler --- --- This script processes the assembly produced by LLVM, rewriting all symbols --- of type @function to @object. This keeps them from going through the PLT, --- which would be bad due to tables-next-to-code. On x86_64, --- it also rewrites AVX instructions that require alignment to their --- unaligned counterparts, since the stack is only 16-byte aligned but these --- instructions require 32-byte alignment. --- - -module LlvmMangler ( llvmFixupAsm ) where - -import GhcPrelude - -import DynFlags ( DynFlags, targetPlatform ) -import GHC.Platform ( platformArch, Arch(..) ) -import ErrUtils ( withTiming ) -import Outputable ( text ) - -import Control.Exception -import qualified Data.ByteString.Char8 as B -import System.IO - --- | Read in assembly file and process -llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} - withTiming dflags (text "LLVM Mangler") id $ - withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do - go r w - hClose r - hClose w - return () - where - go :: Handle -> Handle -> IO () - go r w = do - e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString) - let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w - case e_l of - Right l -> writeline l - Left _ -> return () - --- | These are the rewrites that the mangler will perform -rewrites :: [Rewrite] -rewrites = [rewriteSymType, rewriteAVX] - -type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString - --- | Rewrite a line of assembly source with the given rewrites, --- taking the first rewrite that applies. -rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString -rewriteLine dflags rewrites l - -- We disable .subsections_via_symbols on darwin and ios, as the llvm code - -- gen uses prefix data for the info table. This however does not prevent - -- llvm from generating .subsections_via_symbols, which in turn with - -- -dead_strip, strips the info tables, and therefore breaks ghc. - | isSubsectionsViaSymbols l = - (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!") - | otherwise = - case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of - Nothing -> l - Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten] - where - isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols") - - (symbol, rest) = splitLine l - - firstJust :: [Maybe a] -> Maybe a - firstJust (Just x:_) = Just x - firstJust [] = Nothing - firstJust (_:rest) = firstJust rest - --- | This rewrites @.type@ annotations of function symbols to @%object@. --- This is done as the linker can relocate @%functions@ through the --- Procedure Linking Table (PLT). This is bad since we expect that the --- info table will appear directly before the symbol's location. In the --- case that the PLT is used, this will be not an info table but instead --- some random PLT garbage. -rewriteSymType :: Rewrite -rewriteSymType _ l - | isType l = Just $ rewrite '@' $ rewrite '%' l - | otherwise = Nothing - where - isType = B.isPrefixOf (B.pack ".type") - - rewrite :: Char -> B.ByteString -> B.ByteString - rewrite prefix = replaceOnce funcType objType - where - funcType = prefix `B.cons` B.pack "function" - objType = prefix `B.cons` B.pack "object" - --- | This rewrites aligned AVX instructions to their unaligned counterparts on --- x86-64. This is necessary because the stack is not adequately aligned for --- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer --- and disable tail call optimization. Both would be catastrophic here so GHC --- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then --- rewrites the instructions in the mangler. -rewriteAVX :: Rewrite -rewriteAVX dflags s - | not isX86_64 = Nothing - | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s - | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s - | otherwise = Nothing - where - isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64 - isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") - isVmovap = B.isPrefixOf (B.pack "vmovap") - --- | @replaceOnce match replace bs@ replaces the first occurrence of the --- substring @match@ in @bs@ with @replace@. -replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -replaceOnce matchBS replaceOnceBS = loop - where - loop :: B.ByteString -> B.ByteString - loop cts = - case B.breakSubstring matchBS cts of - (hd,tl) | B.null tl -> hd - | otherwise -> hd `B.append` replaceOnceBS `B.append` - B.drop (B.length matchBS) tl - --- | This function splits a line of assembly code into the label and the --- rest of the code. -splitLine :: B.ByteString -> (B.ByteString, B.ByteString) -splitLine l = (symbol, B.dropWhile isSpace rest) - where - isSpace ' ' = True - isSpace '\t' = True - isSpace _ = False - (symbol, rest) = B.span (not . isSpace) l diff --git a/main/Annotations.hs b/main/Annotations.hs deleted file mode 100644 --- a/main/Annotations.hs +++ /dev/null @@ -1,132 +0,0 @@ --- | --- Support for source code annotation feature of GHC. That is the ANN pragma. --- --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- -{-# LANGUAGE DeriveFunctor #-} -module Annotations ( - -- * Main Annotation data types - Annotation(..), AnnPayload, - AnnTarget(..), CoreAnnTarget, - getAnnTargetName_maybe, - - -- * AnnEnv for collecting and querying Annotations - AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, - findAnns, findAnnsByTypeRep, - deserializeAnns - ) where - -import GhcPrelude - -import Binary -import Module ( Module ) -import Name -import Outputable -import GHC.Serialized -import UniqFM -import Unique - -import Control.Monad -import Data.Maybe -import Data.Typeable -import Data.Word ( Word8 ) - - --- | Represents an annotation after it has been sufficiently desugared from --- it's initial form of 'HsDecls.AnnDecl' -data Annotation = Annotation { - ann_target :: CoreAnnTarget, -- ^ The target of the annotation - ann_value :: AnnPayload - } - -type AnnPayload = Serialized -- ^ The "payload" of an annotation - -- allows recovery of its value at a given type, - -- and can be persisted to an interface file - --- | An annotation target -data AnnTarget name - = NamedTarget name -- ^ We are annotating something with a name: - -- a type or identifier - | ModuleTarget Module -- ^ We are annotating a particular module - deriving (Functor) - --- | The kind of annotation target found in the middle end of the compiler -type CoreAnnTarget = AnnTarget Name - --- | Get the 'name' of an annotation target if it exists. -getAnnTargetName_maybe :: AnnTarget name -> Maybe name -getAnnTargetName_maybe (NamedTarget nm) = Just nm -getAnnTargetName_maybe _ = Nothing - -instance Uniquable name => Uniquable (AnnTarget name) where - getUnique (NamedTarget nm) = getUnique nm - getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0 - -- deriveUnique prevents OccName uniques clashing with NamedTarget - -instance Outputable name => Outputable (AnnTarget name) where - ppr (NamedTarget nm) = text "Named target" <+> ppr nm - ppr (ModuleTarget mod) = text "Module target" <+> ppr mod - -instance Binary name => Binary (AnnTarget name) where - put_ bh (NamedTarget a) = do - putByte bh 0 - put_ bh a - put_ bh (ModuleTarget a) = do - putByte bh 1 - put_ bh a - get bh = do - h <- getByte bh - case h of - 0 -> liftM NamedTarget $ get bh - _ -> liftM ModuleTarget $ get bh - -instance Outputable Annotation where - ppr ann = ppr (ann_target ann) - --- | A collection of annotations --- Can't use a type synonym or we hit bug #2412 due to source import -newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload]) - --- | An empty annotation environment. -emptyAnnEnv :: AnnEnv -emptyAnnEnv = MkAnnEnv emptyUFM - --- | Construct a new annotation environment that contains the list of --- annotations provided. -mkAnnEnv :: [Annotation] -> AnnEnv -mkAnnEnv = extendAnnEnvList emptyAnnEnv - --- | Add the given annotation to the environment. -extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv -extendAnnEnvList (MkAnnEnv env) anns - = MkAnnEnv $ addListToUFM_C (++) env $ - map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns - --- | Union two annotation environments. -plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv -plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] -findAnns deserialize (MkAnnEnv ann_env) - = (mapMaybe (fromSerialized deserialize)) - . (lookupWithDefaultUFM ann_env []) - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] -findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep - = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target - , tyrep' == tyrep ] - --- | Deserialize all annotations of a given type. This happens lazily, that is --- no deserialization will take place until the [a] is actually demanded and --- the [a] can also be empty (the UniqFM is not filtered). -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] -deserializeAnns deserialize (MkAnnEnv ann_env) - = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env diff --git a/main/Ar.hs b/main/Ar.hs deleted file mode 100644 --- a/main/Ar.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-} -{- Note: [The need for Ar.hs] -Building `-staticlib` required the presence of libtool, and was a such -restricted to mach-o only. As libtool on macOS and gnu libtool are very -different, there was no simple portable way to support this. - -libtool for static archives does essentially: concatinate the input archives, -add the input objects, and create a symbol index. Using `ar` for this task -fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same -features across platforms (e.g. index prefixed retrieval of objects with -the same name.) - -As Archives are rather simple structurally, we can just build the archives -with Haskell directly and use ranlib on the final result to get the symbol -index. This should allow us to work around with the differences/abailability -of libtool across differet platforms. --} -module Ar - (ArchiveEntry(..) - ,Archive(..) - ,afilter - - ,parseAr - - ,loadAr - ,loadObj - ,writeBSDAr - ,writeGNUAr - - ,isBSDSymdef - ,isGNUSymdef - ) - where - -import GhcPrelude - -import Data.List (mapAccumL, isPrefixOf) -import Data.Monoid ((<>)) -import Data.Binary.Get -import Data.Binary.Put -import Control.Monad -import Control.Applicative -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as L -#if !defined(mingw32_HOST_OS) -import qualified System.Posix.Files as POSIX -#endif -import System.FilePath (takeFileName) - -data ArchiveEntry = ArchiveEntry - { filename :: String -- ^ File name. - , filetime :: Int -- ^ File modification time. - , fileown :: Int -- ^ File owner. - , filegrp :: Int -- ^ File group. - , filemode :: Int -- ^ File mode. - , filesize :: Int -- ^ File size. - , filedata :: B.ByteString -- ^ File bytes. - } deriving (Eq, Show) - -newtype Archive = Archive [ArchiveEntry] - deriving (Eq, Show, Semigroup, Monoid) - -afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive -afilter f (Archive xs) = Archive (filter f xs) - -isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool -isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a) -isGNUSymdef a = "/" == (filename a) - --- | Archives have numeric values padded with '\x20' to the right. -getPaddedInt :: B.ByteString -> Int -getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20') - -putPaddedInt :: Int -> Int -> Put -putPaddedInt padding i = putPaddedString '\x20' padding (show i) - -putPaddedString :: Char -> Int -> String -> Put -putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad) - -getBSDArchEntries :: Get [ArchiveEntry] -getBSDArchEntries = do - empty <- isEmpty - if empty then - return [] - else do - name <- getByteString 16 - when ('/' `C.elem` name && C.take 3 name /= "#1/") $ - fail "Looks like GNU Archive" - time <- getPaddedInt <$> getByteString 12 - own <- getPaddedInt <$> getByteString 6 - grp <- getPaddedInt <$> getByteString 6 - mode <- getPaddedInt <$> getByteString 8 - st_size <- getPaddedInt <$> getByteString 10 - end <- getByteString 2 - when (end /= "\x60\x0a") $ - fail ("[BSD Archive] Invalid archive header end marker for name: " ++ - C.unpack name) - off1 <- liftM fromIntegral bytesRead :: Get Int - -- BSD stores extended filenames, by writing #1/ into the - -- name field, the first @length@ bytes then represent the file name - -- thus the payload size is filesize + file name length. - name <- if C.unpack (C.take 3 name) == "#1/" then - liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name) - else - return $ C.unpack $ C.takeWhile (/= ' ') name - off2 <- liftM fromIntegral bytesRead :: Get Int - file <- getByteString (st_size - (off2 - off1)) - -- data sections are two byte aligned (see #15396) - when (odd st_size) $ - void (getByteString 1) - - rest <- getBSDArchEntries - return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest - --- | GNU Archives feature a special '//' entry that contains the --- extended names. Those are referred to as /, where num is the --- offset into the '//' entry. --- In addition, filenames are terminated with '/' in the archive. -getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry] -getGNUArchEntries extInfo = do - empty <- isEmpty - if empty - then return [] - else - do - name <- getByteString 16 - time <- getPaddedInt <$> getByteString 12 - own <- getPaddedInt <$> getByteString 6 - grp <- getPaddedInt <$> getByteString 6 - mode <- getPaddedInt <$> getByteString 8 - st_size <- getPaddedInt <$> getByteString 10 - end <- getByteString 2 - when (end /= "\x60\x0a") $ - fail ("[BSD Archive] Invalid archive header end marker for name: " ++ - C.unpack name) - file <- getByteString st_size - -- data sections are two byte aligned (see #15396) - when (odd st_size) $ - void (getByteString 1) - name <- return . C.unpack $ - if C.unpack (C.take 1 name) == "/" - then case C.takeWhile (/= ' ') name of - name@"/" -> name -- symbol table - name@"//" -> name -- extendedn file names table - name -> getExtName extInfo (read . C.unpack $ C.drop 1 name) - else C.takeWhile (/= '/') name - case name of - "/" -> getGNUArchEntries extInfo - "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file)) - _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo - - where - getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString - getExtName Nothing _ = error "Invalid extended filename reference." - getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info - --- | put an Archive Entry. This assumes that the entries --- have been preprocessed to account for the extenden file name --- table section "//" e.g. for GNU Archives. Or that the names --- have been move into the payload for BSD Archives. -putArchEntry :: ArchiveEntry -> PutM () -putArchEntry (ArchiveEntry name time own grp mode st_size file) = do - putPaddedString ' ' 16 name - putPaddedInt 12 time - putPaddedInt 6 own - putPaddedInt 6 grp - putPaddedInt 8 mode - putPaddedInt 10 (st_size + pad) - putByteString "\x60\x0a" - putByteString file - when (pad == 1) $ - putWord8 0x0a - where - pad = st_size `mod` 2 - -getArchMagic :: Get () -getArchMagic = do - magic <- liftM C.unpack $ getByteString 8 - if magic /= "!\n" - then fail $ "Invalid magic number " ++ show magic - else return () - -putArchMagic :: Put -putArchMagic = putByteString $ C.pack "!\n" - -getArch :: Get Archive -getArch = Archive <$> do - getArchMagic - getBSDArchEntries <|> getGNUArchEntries Nothing - -putBSDArch :: Archive -> PutM () -putBSDArch (Archive as) = do - putArchMagic - mapM_ putArchEntry (processEntries as) - - where - padStr pad size str = take size $ str <> repeat pad - nameSize name = case length name `divMod` 4 of - (n, 0) -> 4 * n - (n, _) -> 4 * (n + 1) - needExt name = length name > 16 || ' ' `elem` name - processEntry :: ArchiveEntry -> ArchiveEntry - processEntry archive@(ArchiveEntry name _ _ _ _ st_size _) - | needExt name = archive { filename = "#1/" <> show sz - , filedata = C.pack (padStr '\0' sz name) <> filedata archive - , filesize = st_size + sz } - | otherwise = archive - - where sz = nameSize name - - processEntries = map processEntry - -putGNUArch :: Archive -> PutM () -putGNUArch (Archive as) = do - putArchMagic - mapM_ putArchEntry (processEntries as) - - where - processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry) - processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _) - | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2 - , filedata = filedata extInfo <> C.pack name <> "/\n" } - , archive { filename = "/" <> show (filesize extInfo) } ) - | otherwise = ( extInfo, archive { filename = name <> "/" } ) - - processEntries :: [ArchiveEntry] -> [ArchiveEntry] - processEntries = - uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty) - -parseAr :: B.ByteString -> Archive -parseAr = runGet getArch . L.fromChunks . pure - -writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO () -writeBSDAr fp = L.writeFile fp . runPut . putBSDArch -writeGNUAr fp = L.writeFile fp . runPut . putGNUArch - -loadAr :: FilePath -> IO Archive -loadAr fp = parseAr <$> B.readFile fp - -loadObj :: FilePath -> IO ArchiveEntry -loadObj fp = do - payload <- B.readFile fp - (modt, own, grp, mode) <- fileInfo fp - return $ ArchiveEntry - (takeFileName fp) modt own grp mode - (B.length payload) payload - --- | Take a filePath and return (mod time, own, grp, mode in decimal) -fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal) -#if defined(mingw32_HOST_OS) --- on windows mod time, owner group and mode are zero. -fileInfo _ = pure (0,0,0,0) -#else -fileInfo fp = go <$> POSIX.getFileStatus fp - where go status = ( fromEnum $ POSIX.modificationTime status - , fromIntegral $ POSIX.fileOwner status - , fromIntegral $ POSIX.fileGroup status - , oct2dec . fromIntegral $ POSIX.fileMode status - ) - -oct2dec :: Int -> Int -oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8 - where dec _ 0 = [] - dec b i = let (rest, last) = i `quotRem` b - in last:dec b rest - -#endif diff --git a/main/CliOption.hs b/main/CliOption.hs deleted file mode 100644 --- a/main/CliOption.hs +++ /dev/null @@ -1,27 +0,0 @@ -module CliOption - ( Option (..) - , showOpt - ) where - -import GhcPrelude - --- ----------------------------------------------------------------------------- --- Command-line options - --- | When invoking external tools as part of the compilation pipeline, we --- pass these a sequence of options on the command-line. Rather than --- just using a list of Strings, we use a type that allows us to distinguish --- between filepaths and 'other stuff'. The reason for this is that --- this type gives us a handle on transforming filenames, and filenames only, --- to whatever format they're expected to be on a particular platform. -data Option - = FileOption -- an entry that _contains_ filename(s) / filepaths. - String -- a non-filepath prefix that shouldn't be - -- transformed (e.g., "/out=") - String -- the filepath/filename portion - | Option String - deriving ( Eq ) - -showOpt :: Option -> String -showOpt (FileOption pre f) = pre ++ f -showOpt (Option s) = s diff --git a/main/CmdLineParser.hs b/main/CmdLineParser.hs deleted file mode 100644 --- a/main/CmdLineParser.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -------------------------------------------------------------------------------- --- --- | Command-line parser --- --- This is an abstract command-line parser used by DynFlags. --- --- (c) The University of Glasgow 2005 --- -------------------------------------------------------------------------------- - -module CmdLineParser - ( - processArgs, OptKind(..), GhcFlagMode(..), - CmdLineP(..), getCmdLineState, putCmdLineState, - Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, - errorsToGhcException, - - Err(..), Warn(..), WarnReason(..), - - EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, - deprecate - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Util -import Outputable -import Panic -import Bag -import SrcLoc -import Json - -import Data.Function -import Data.List - -import Control.Monad (liftM, ap) - --------------------------------------------------------- --- The Flag and OptKind types --------------------------------------------------------- - -data Flag m = Flag - { flagName :: String, -- Flag, without the leading "-" - flagOptKind :: OptKind m, -- What to do if we see it - flagGhcMode :: GhcFlagMode -- Which modes this flag affects - } - -defFlag :: String -> OptKind m -> Flag m -defFlag name optKind = Flag name optKind AllModes - -defGhcFlag :: String -> OptKind m -> Flag m -defGhcFlag name optKind = Flag name optKind OnlyGhc - -defGhciFlag :: String -> OptKind m -> Flag m -defGhciFlag name optKind = Flag name optKind OnlyGhci - -defHiddenFlag :: String -> OptKind m -> Flag m -defHiddenFlag name optKind = Flag name optKind HiddenFlag - --- | GHC flag modes describing when a flag has an effect. -data GhcFlagMode - = OnlyGhc -- ^ The flag only affects the non-interactive GHC - | OnlyGhci -- ^ The flag only affects the interactive GHC - | AllModes -- ^ The flag affects multiple ghc modes - | HiddenFlag -- ^ This flag should not be seen in cli completion - -data OptKind m -- Suppose the flag is -f - = NoArg (EwM m ()) -- -f all by itself - | HasArg (String -> EwM m ()) -- -farg or -f arg - | SepArg (String -> EwM m ()) -- -f arg - | Prefix (String -> EwM m ()) -- -farg - | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) - | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn - | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn - | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn - | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn - | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn - - --------------------------------------------------------- --- The EwM monad --------------------------------------------------------- - --- | Used when filtering warnings: if a reason is given --- it can be filtered out when displaying. -data WarnReason - = NoReason - | ReasonDeprecatedFlag - | ReasonUnrecognisedFlag - deriving (Eq, Show) - -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json reason = JSString $ show reason - --- | A command-line error message -newtype Err = Err { errMsg :: Located String } - --- | A command-line warning message and the reason it arose -data Warn = Warn - { warnReason :: WarnReason, - warnMsg :: Located String - } - -type Errs = Bag Err -type Warns = Bag Warn - --- EwM ("errors and warnings monad") is a monad --- transformer for m that adds an (err, warn) state -newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg - -> Errs -> Warns - -> m (Errs, Warns, a) } - -instance Monad m => Functor (EwM m) where - fmap = liftM - -instance Monad m => Applicative (EwM m) where - pure v = EwM (\_ e w -> return (e, w, v)) - (<*>) = ap - -instance Monad m => Monad (EwM m) where - (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w - unEwM (k r) l e' w') - -runEwM :: EwM m a -> m (Errs, Warns, a) -runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag - -setArg :: Located String -> EwM m () -> EwM m () -setArg l (EwM f) = EwM (\_ es ws -> f l es ws) - -addErr :: Monad m => String -> EwM m () -addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) - -addWarn :: Monad m => String -> EwM m () -addWarn = addFlagWarn NoReason - -addFlagWarn :: Monad m => WarnReason -> String -> EwM m () -addFlagWarn reason msg = EwM $ - (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) - -deprecate :: Monad m => String -> EwM m () -deprecate s = do - arg <- getArg - addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) - -getArg :: Monad m => EwM m String -getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) - -getCurLoc :: Monad m => EwM m SrcSpan -getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) - -liftEwM :: Monad m => m a -> EwM m a -liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) - - --------------------------------------------------------- --- A state monad for use in the command-line parser --------------------------------------------------------- - --- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) -newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } - deriving (Functor) - -instance Applicative (CmdLineP s) where - pure a = CmdLineP $ \s -> (a, s) - (<*>) = ap - -instance Monad (CmdLineP s) where - m >>= k = CmdLineP $ \s -> - let (a, s') = runCmdLine m s - in runCmdLine (k a) s' - - -getCmdLineState :: CmdLineP s s -getCmdLineState = CmdLineP $ \s -> (s,s) -putCmdLineState :: s -> CmdLineP s () -putCmdLineState s = CmdLineP $ \_ -> ((),s) - - --------------------------------------------------------- --- Processing arguments --------------------------------------------------------- - -processArgs :: Monad m - => [Flag m] -- cmdline parser spec - -> [Located String] -- args - -> m ( [Located String], -- spare args - [Err], -- errors - [Warn] ) -- warnings -processArgs spec args = do - (errs, warns, spare) <- runEwM action - return (spare, bagToList errs, bagToList warns) - where - action = process args [] - - -- process :: [Located String] -> [Located String] -> EwM m [Located String] - process [] spare = return (reverse spare) - - process (locArg@(L _ ('-' : arg)) : args) spare = - case findArg spec arg of - Just (rest, opt_kind) -> - case processOneArg opt_kind rest arg args of - Left err -> - let b = process args spare - in (setArg locArg $ addErr err) >> b - - Right (action,rest) -> - let b = process rest spare - in (setArg locArg $ action) >> b - - Nothing -> process args (locArg : spare) - - process (arg : args) spare = process args (arg : spare) - - -processOneArg :: OptKind m -> String -> String -> [Located String] - -> Either String (EwM m (), [Located String]) -processOneArg opt_kind rest arg args - = let dash_arg = '-' : arg - rest_no_eq = dropEq rest - in case opt_kind of - NoArg a -> ASSERT(null rest) Right (a, args) - - HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> case args of - [] -> missingArgErr dash_arg - (L _ arg1:args1) -> Right (f arg1, args1) - - -- See #9776 - SepArg f -> case args of - [] -> missingArgErr dash_arg - (L _ arg1:args1) -> Right (f arg1, args1) - - -- See #12625 - Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> missingArgErr dash_arg - - PassFlag f | notNull rest -> unknownFlagErr dash_arg - | otherwise -> Right (f dash_arg, args) - - OptIntSuffix f | null rest -> Right (f Nothing, args) - | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) - | otherwise -> Left ("malformed integer argument in " ++ dash_arg) - - IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) - | otherwise -> Left ("malformed integer argument in " ++ dash_arg) - - FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) - | otherwise -> Left ("malformed float argument in " ++ dash_arg) - - OptPrefix f -> Right (f rest_no_eq, args) - AnySuffix f -> Right (f dash_arg, args) - -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) -findArg spec arg = - case sortBy (compare `on` (length . fst)) -- prefer longest matching flag - [ (removeSpaces rest, optKind) - | flag <- spec, - let optKind = flagOptKind flag, - Just rest <- [stripPrefix (flagName flag) arg], - arg_ok optKind rest arg ] - of - [] -> Nothing - (one:_) -> Just one - -arg_ok :: OptKind t -> [Char] -> String -> Bool -arg_ok (NoArg _) rest _ = null rest -arg_ok (HasArg _) _ _ = True -arg_ok (SepArg _) rest _ = null rest -arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t - -- to improve error message (#12625) -arg_ok (OptIntSuffix _) _ _ = True -arg_ok (IntSuffix _) _ _ = True -arg_ok (FloatSuffix _) _ _ = True -arg_ok (OptPrefix _) _ _ = True -arg_ok (PassFlag _) rest _ = null rest -arg_ok (AnySuffix _) _ _ = True - --- | Parse an Int --- --- Looks for "433" or "=342", with no trailing gubbins --- * n or =n => Just n --- * gibberish => Nothing -parseInt :: String -> Maybe Int -parseInt s = case reads s of - ((n,""):_) -> Just n - _ -> Nothing - -parseFloat :: String -> Maybe Float -parseFloat s = case reads s of - ((n,""):_) -> Just n - _ -> Nothing - --- | Discards a leading equals sign -dropEq :: String -> String -dropEq ('=' : s) = s -dropEq s = s - -unknownFlagErr :: String -> Either String a -unknownFlagErr f = Left ("unrecognised flag: " ++ f) - -missingArgErr :: String -> Either String a -missingArgErr f = Left ("missing argument for flag: " ++ f) - --------------------------------------------------------- --- Utils --------------------------------------------------------- - - --- See Note [Handling errors when parsing flags] -errorsToGhcException :: [(String, -- Location - String)] -- Error - -> GhcException -errorsToGhcException errs = - UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] - -{- Note [Handling errors when parsing commandline flags] - -Parsing of static and mode flags happens before any session is started, i.e., -before the first call to 'GHC.withGhc'. Therefore, to report errors for -invalid usage of these two types of flags, we can not call any function that -needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags -is not set either). So we always print "on the commandline" as the location, -which is true except for Api users, which is probably ok. - -When reporting errors for invalid usage of dynamic flags we /can/ make use of -DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. - -Before, we called unsafeGlobalDynFlags when an invalid (combination of) -flag(s) was given on the commandline, resulting in panics (#9963). --} diff --git a/main/CodeOutput.hs b/main/CodeOutput.hs deleted file mode 100644 --- a/main/CodeOutput.hs +++ /dev/null @@ -1,262 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section{Code output phase} --} - -{-# LANGUAGE CPP #-} - -module CodeOutput( codeOutput, outputForeignStubs ) where - -#include "HsVersions.h" - -import GhcPrelude - -import AsmCodeGen ( nativeCodeGen ) -import LlvmCodeGen ( llvmCodeGen ) - -import UniqSupply ( mkSplitUniqSupply ) - -import Finder ( mkStubPaths ) -import PprC ( writeC ) -import CmmLint ( cmmLint ) -import Packages -import Cmm ( RawCmmGroup ) -import HscTypes -import DynFlags -import Stream ( Stream ) -import qualified Stream -import FileCleanup - -import ErrUtils -import Outputable -import Module -import SrcLoc - -import Control.Exception -import System.Directory -import System.FilePath -import System.IO - -{- -************************************************************************ -* * -\subsection{Steering} -* * -************************************************************************ --} - -codeOutput :: DynFlags - -> Module - -> FilePath - -> ModLocation - -> ForeignStubs - -> [(ForeignSrcLang, FilePath)] - -- ^ additional files to be compiled with with the C compiler - -> [InstalledUnitId] - -> Stream IO RawCmmGroup a -- Compiled C-- - -> IO (FilePath, - (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), - [(ForeignSrcLang, FilePath)]{-foreign_fps-}, - a) - -codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps - cmm_stream - = - do { - -- Lint each CmmGroup as it goes past - ; let linted_cmm_stream = - if gopt Opt_DoCmmLinting dflags - then Stream.mapM do_lint cmm_stream - else cmm_stream - - do_lint cmm = withTimingSilent - dflags - (text "CmmLint"<+>brackets (ppr this_mod)) - (const ()) $ do - { case cmmLint dflags cmm of - Just err -> do { log_action dflags - dflags - NoReason - SevDump - noSrcSpan - (defaultDumpStyle dflags) - err - ; ghcExit dflags 1 - } - Nothing -> return () - ; return cmm - } - - ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs - ; a <- case hscTarget dflags of - HscAsm -> outputAsm dflags this_mod location filenm - linted_cmm_stream - HscC -> outputC dflags filenm linted_cmm_stream pkg_deps - HscLlvm -> outputLlvm dflags filenm linted_cmm_stream - HscInterpreted -> panic "codeOutput: HscInterpreted" - HscNothing -> panic "codeOutput: HscNothing" - ; return (filenm, stubs_exist, foreign_fps, a) - } - -doOutput :: String -> (Handle -> IO a) -> IO a -doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action - -{- -************************************************************************ -* * -\subsection{C} -* * -************************************************************************ --} - -outputC :: DynFlags - -> FilePath - -> Stream IO RawCmmGroup a - -> [InstalledUnitId] - -> IO a - -outputC dflags filenm cmm_stream packages - = do - withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - - -- figure out which header files to #include in the generated .hc file: - -- - -- * extra_includes from packages - -- * -#include options from the cmdline and OPTIONS pragmas - -- * the _stub.h file, if there is one. - -- - let rts = getPackageDetails dflags rtsUnitId - - let cc_injects = unlines (map mk_include (includes rts)) - mk_include h_file = - case h_file of - '"':_{-"-} -> "#include "++h_file - '<':_ -> "#include "++h_file - _ -> "#include \""++h_file++"\"" - - let pkg_names = map installedUnitIdString packages - - doOutput filenm $ \ h -> do - hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") - hPutStr h cc_injects - Stream.consume cmm_stream (writeC dflags h) - -{- -************************************************************************ -* * -\subsection{Assembler} -* * -************************************************************************ --} - -outputAsm :: DynFlags -> Module -> ModLocation -> FilePath - -> Stream IO RawCmmGroup a - -> IO a -outputAsm dflags this_mod location filenm cmm_stream - | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags - = do ncg_uniqs <- mkSplitUniqSupply 'n' - - debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) - - {-# SCC "OutputAsm" #-} doOutput filenm $ - \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream - - | otherwise - = panic "This compiler was built without a native code generator" - -{- -************************************************************************ -* * -\subsection{LLVM} -* * -************************************************************************ --} - -outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputLlvm dflags filenm cmm_stream - = do {-# SCC "llvm_output" #-} doOutput filenm $ - \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f cmm_stream - -{- -************************************************************************ -* * -\subsection{Foreign import/export} -* * -************************************************************************ --} - -outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs - -> IO (Bool, -- Header file created - Maybe FilePath) -- C file created -outputForeignStubs dflags mod location stubs - = do - let stub_h = mkStubPaths dflags (moduleName mod) location - stub_c <- newTempName dflags TFL_CurrentModule "c" - - case stubs of - NoStubs -> - return (False, Nothing) - - ForeignStubs h_code c_code -> do - let - stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc dflags stub_c_output_d - - -- Header file protos for "foreign export"ed functions. - stub_h_output_d = pprCode CStyle h_code - stub_h_output_w = showSDoc dflags stub_h_output_d - - createDirectoryIfMissing True (takeDirectory stub_h) - - dumpIfSet_dyn dflags Opt_D_dump_foreign - "Foreign export header file" stub_h_output_d - - -- we need the #includes from the rts package for the stub files - let rts_includes = - let rts_pkg = getPackageDetails dflags rtsUnitId in - concatMap mk_include (includes rts_pkg) - mk_include i = "#include \"" ++ i ++ "\"\n" - - -- wrapper code mentions the ffi_arg type, which comes from ffi.h - ffi_includes - | platformMisc_libFFI $ platformMisc dflags = "#include \n" - | otherwise = "" - - stub_h_file_exists - <- outputForeignStubs_help stub_h stub_h_output_w - ("#include \n" ++ cplusplus_hdr) cplusplus_ftr - - dumpIfSet_dyn dflags Opt_D_dump_foreign - "Foreign export stubs" stub_c_output_d - - stub_c_file_exists - <- outputForeignStubs_help stub_c stub_c_output_w - ("#define IN_STG_CODE 0\n" ++ - "#include \n" ++ - rts_includes ++ - ffi_includes ++ - cplusplus_hdr) - cplusplus_ftr - -- We're adding the default hc_header to the stub file, but this - -- isn't really HC code, so we need to define IN_STG_CODE==0 to - -- avoid the register variables etc. being enabled. - - return (stub_h_file_exists, if stub_c_file_exists - then Just stub_c - else Nothing ) - where - cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n" - cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" - - --- Don't use doOutput for dumping the f. export stubs --- since it is more than likely that the stubs file will --- turn out to be empty, in which case no file should be created. -outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool -outputForeignStubs_help _fname "" _header _footer = return False -outputForeignStubs_help fname doc_str header footer - = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") - return True diff --git a/main/Constants.hs b/main/Constants.hs deleted file mode 100644 --- a/main/Constants.hs +++ /dev/null @@ -1,46 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Constants]{Info about this compilation} --} - -module Constants (module Constants) where - -import GhcPrelude - -import Config - -hiVersion :: Integer -hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer - --- All pretty arbitrary: - -mAX_TUPLE_SIZE :: Int -mAX_TUPLE_SIZE = 62 -- Should really match the number - -- of decls in Data.Tuple - -mAX_CTUPLE_SIZE :: Int -- Constraint tuples -mAX_CTUPLE_SIZE = 62 -- Should match the number of decls in GHC.Classes - -mAX_SUM_SIZE :: Int -mAX_SUM_SIZE = 62 - --- | Default maximum depth for both class instance search and type family --- reduction. See also #5395. -mAX_REDUCTION_DEPTH :: Int -mAX_REDUCTION_DEPTH = 200 - --- | Default maximum constraint-solver iterations --- Typically there should be very few -mAX_SOLVER_ITERATIONS :: Int -mAX_SOLVER_ITERATIONS = 4 - -wORD64_SIZE :: Int -wORD64_SIZE = 8 - --- Size of float in bytes. -fLOAT_SIZE :: Int -fLOAT_SIZE = 4 - -tARGET_MAX_CHAR :: Int -tARGET_MAX_CHAR = 0x10ffff diff --git a/main/DriverMkDepend.hs b/main/DriverMkDepend.hs deleted file mode 100644 --- a/main/DriverMkDepend.hs +++ /dev/null @@ -1,433 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Makefile Dependency Generation --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module DriverMkDepend ( - doMkDependHS - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import qualified GHC -import GhcMonad -import DynFlags -import Util -import HscTypes -import qualified SysTools -import Module -import Digraph ( SCC(..) ) -import Finder -import Outputable -import Panic -import SrcLoc -import Data.List -import FastString -import FileCleanup - -import Exception -import ErrUtils - -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error ( isEOFError ) -import Control.Monad ( when, forM_ ) -import Data.Maybe ( isJust ) -import Data.IORef - ------------------------------------------------------------------ --- --- The main function --- ------------------------------------------------------------------ - -doMkDependHS :: GhcMonad m => [FilePath] -> m () -doMkDependHS srcs = do - -- Initialisation - dflags0 <- GHC.getSessionDynFlags - - -- We kludge things a bit for dependency generation. Rather than - -- generating dependencies for each way separately, we generate - -- them once and then duplicate them for each way's osuf/hisuf. - -- We therefore do the initial dependency generation with an empty - -- way and .o/.hi extensions, regardless of any flags that might - -- be specified. - let dflags = dflags0 { - ways = [], - buildTag = mkBuildTag [], - hiSuf = "hi", - objectSuf = "o" - } - _ <- GHC.setSessionDynFlags dflags - - when (null (depSuffixes dflags)) $ liftIO $ - throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") - - files <- liftIO $ beginMkDependHS dflags - - -- Do the downsweep to find all the modules - targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs - GHC.setTargets targets - let excl_mods = depExcludeMods dflags - module_graph <- GHC.depanal excl_mods True {- Allow dup roots -} - - -- Sort into dependency order - -- There should be no cycles - let sorted = GHC.topSortModuleGraph False module_graph Nothing - - -- Print out the dependencies if wanted - liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) - - -- Process them one by one, dumping results into makefile - -- and complaining about cycles - hsc_env <- getSession - root <- liftIO getCurrentDirectory - mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted - - -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles dflags module_graph - - -- Tidy up - liftIO $ endMkDependHS dflags files - - -- Unconditional exiting is a bad idea. If an error occurs we'll get an - --exception; if that is not caught it's fine, but at least we have a - --chance to find out exactly what went wrong. Uncomment the following - --line if you disagree. - - --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) - ------------------------------------------------------------------ --- --- beginMkDependHs --- Create a temporary file, --- find the Makefile, --- slurp through it, etc --- ------------------------------------------------------------------ - -data MkDepFiles - = MkDep { mkd_make_file :: FilePath, -- Name of the makefile - mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile - mkd_tmp_file :: FilePath, -- Name of the temporary file - mkd_tmp_hdl :: Handle } -- Handle of the open temporary file - -beginMkDependHS :: DynFlags -> IO MkDepFiles -beginMkDependHS dflags = do - -- open a new temp file in which to stuff the dependency info - -- as we go along. - tmp_file <- newTempName dflags TFL_CurrentModule "dep" - tmp_hdl <- openFile tmp_file WriteMode - - -- open the makefile - let makefile = depMakefile dflags - exists <- doesFileExist makefile - mb_make_hdl <- - if not exists - then return Nothing - else do - makefile_hdl <- openFile makefile ReadMode - - -- slurp through until we get the magic start string, - -- copying the contents into dep_makefile - let slurp = do - l <- hGetLine makefile_hdl - if (l == depStartMarker) - then return () - else do hPutStrLn tmp_hdl l; slurp - - -- slurp through until we get the magic end marker, - -- throwing away the contents - let chuck = do - l <- hGetLine makefile_hdl - if (l == depEndMarker) - then return () - else chuck - - catchIO slurp - (\e -> if isEOFError e then return () else ioError e) - catchIO chuck - (\e -> if isEOFError e then return () else ioError e) - - return (Just makefile_hdl) - - - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depStartMarker - - return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) - - ------------------------------------------------------------------ --- --- processDeps --- ------------------------------------------------------------------ - -processDeps :: DynFlags - -> HscEnv - -> [ModuleName] - -> FilePath - -> Handle -- Write dependencies to here - -> SCC ModSummary - -> IO () --- Write suitable dependencies to handle --- Always: --- this.o : this.hs --- --- If the dependency is on something other than a .hi file: --- this.o this.p_o ... : dep --- otherwise --- this.o ... : dep.hi --- this.p_o ... : dep.p_hi --- ... --- (where .o is $osuf, and the other suffixes come from --- the cmdline -s options). --- --- For {-# SOURCE #-} imports the "hi" will be "hi-boot". - -processDeps dflags _ _ _ _ (CyclicSCC nodes) - = -- There shouldn't be any cycles; report them - throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) - -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) - = do { let extra_suffixes = depSuffixes dflags - include_pkg_deps = depIncludePkgDeps dflags - src_file = msHsFilePath node - obj_file = msObjFilePath node - obj_files = insertSuffixes obj_file extra_suffixes - - do_imp loc is_boot pkg_qual imp_mod - = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod - is_boot include_pkg_deps - ; case mb_hi of { - Nothing -> return () ; - Just hi_file -> do - { let hi_files = insertSuffixes hi_file extra_suffixes - write_dep (obj,hi) = writeDependency root hdl [obj] hi - - -- Add one dependency for each suffix; - -- e.g. A.o : B.hi - -- A.x_o : B.x_hi - ; mapM_ write_dep (obj_files `zip` hi_files) }}} - - - -- Emit std dependency of the object(s) on the source file - -- Something like A.o : A.hs - ; writeDependency root hdl obj_files src_file - - -- add dependency between objects and their corresponding .hi-boot - -- files if the module has a corresponding .hs-boot file (#14482) - ; when (isBootSummary node) $ do - let hi_boot = msHiFilePath node - let obj = removeBootSuffix (msObjFilePath node) - forM_ extra_suffixes $ \suff -> do - let way_obj = insertSuffixes obj [suff] - let way_hi_boot = insertSuffixes hi_boot [suff] - mapM_ (writeDependency root hdl way_obj) way_hi_boot - - -- Emit a dependency for each CPP import - ; when (depIncludeCppDeps dflags) $ do - -- CPP deps are descovered in the module parsing phase by parsing - -- comment lines left by the preprocessor. - -- Note that GHC.parseModule may throw an exception if the module - -- fails to parse, which may not be desirable (see #16616). - { session <- Session <$> newIORef hsc_env - ; parsedMod <- reflectGhc (GHC.parseModule node) session - ; mapM_ (writeDependency root hdl obj_files) - (GHC.pm_extra_src_files parsedMod) - } - - -- Emit a dependency for each import - - ; let do_imps is_boot idecls = sequence_ - [ do_imp loc is_boot mb_pkg mod - | (mb_pkg, L loc mod) <- idecls, - mod `notElem` excl_mods ] - - ; do_imps True (ms_srcimps node) - ; do_imps False (ms_imps node) - } - - -findDependency :: HscEnv - -> SrcSpan - -> Maybe FastString -- package qualifier, if any - -> ModuleName -- Imported module - -> IsBootInterface -- Source import - -> Bool -- Record dependency on package modules - -> IO (Maybe FilePath) -- Interface file file -findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps - = do { -- Find the module; this will be fast because - -- we've done it once during downsweep - r <- findImportedModule hsc_env imp pkg - ; case r of - Found loc _ - -- Home package: just depend on the .hi or hi-boot file - | isJust (ml_hs_file loc) || include_pkg_deps - -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) - - -- Not in this package: we don't need a dependency - | otherwise - -> return Nothing - - fail -> - let dflags = hsc_dflags hsc_env - in throwOneError $ mkPlainErrMsg dflags srcloc $ - cannotFindModule dflags imp fail - } - ------------------------------ -writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () --- (writeDependency r h [t1,t2] dep) writes to handle h the dependency --- t1 t2 : dep -writeDependency root hdl targets dep - = do let -- We need to avoid making deps on - -- c:/foo/... - -- on cygwin as make gets confused by the : - -- Making relative deps avoids some instances of this. - dep' = makeRelative root dep - forOutput = escapeSpaces . reslash Forwards . normalise - output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' - hPutStrLn hdl output - ------------------------------ -insertSuffixes - :: FilePath -- Original filename; e.g. "foo.o" - -> [String] -- Suffix prefixes e.g. ["x_", "y_"] - -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] - -- Note that that the extra bit gets inserted *before* the old suffix - -- We assume the old suffix contains no dots, so we know where to - -- split it -insertSuffixes file_name extras - = [ basename <.> (extra ++ suffix) | extra <- extras ] - where - (basename, suffix) = case splitExtension file_name of - -- Drop the "." from the extension - (b, s) -> (b, drop 1 s) - - ------------------------------------------------------------------ --- --- endMkDependHs --- Complete the makefile, close the tmp file etc --- ------------------------------------------------------------------ - -endMkDependHS :: DynFlags -> MkDepFiles -> IO () - -endMkDependHS dflags - (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) - = do - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depEndMarker - - case makefile_hdl of - Nothing -> return () - Just hdl -> do - - -- slurp the rest of the original makefile and copy it into the output - let slurp = do - l <- hGetLine hdl - hPutStrLn tmp_hdl l - slurp - - catchIO slurp - (\e -> if isEOFError e then return () else ioError e) - - hClose hdl - - hClose tmp_hdl -- make sure it's flushed - - -- Create a backup of the original makefile - when (isJust makefile_hdl) - (SysTools.copy dflags ("Backing up " ++ makefile) - makefile (makefile++".bak")) - - -- Copy the new makefile in place - SysTools.copy dflags "Installing new makefile" tmp_file makefile - - ------------------------------------------------------------------ --- Module cycles ------------------------------------------------------------------ - -dumpModCycles :: DynFlags -> ModuleGraph -> IO () -dumpModCycles dflags module_graph - | not (dopt Opt_D_dump_mod_cycles dflags) - = return () - - | null cycles - = putMsg dflags (text "No module cycles") - - | otherwise - = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) - where - - cycles :: [[ModSummary]] - cycles = - [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ] - - pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------")) - $$ pprCycle c $$ blankLine - | (n,c) <- [1..] `zip` cycles ] - -pprCycle :: [ModSummary] -> SDoc --- Print a cycle, but show only the imports within the cycle -pprCycle summaries = pp_group (CyclicSCC summaries) - where - cycle_mods :: [ModuleName] -- The modules in this cycle - cycle_mods = map (moduleName . ms_mod) summaries - - pp_group (AcyclicSCC ms) = pp_ms ms - pp_group (CyclicSCC mss) - = ASSERT( not (null boot_only) ) - -- The boot-only list must be non-empty, else there would - -- be an infinite chain of non-boot imoprts, and we've - -- already checked for that in processModDeps - pp_ms loop_breaker $$ vcat (map pp_group groups) - where - (boot_only, others) = partition is_boot_only mss - is_boot_only ms = not (any in_group (map snd (ms_imps ms))) - in_group (L _ m) = m `elem` group_mods - group_mods = map (moduleName . ms_mod) mss - - loop_breaker = head boot_only - all_others = tail boot_only ++ others - groups = - GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing - - pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) - <+> (pp_imps empty (map snd (ms_imps summary)) $$ - pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) - where - mod_str = moduleNameString (moduleName (ms_mod summary)) - - pp_imps :: SDoc -> [Located ModuleName] -> SDoc - pp_imps _ [] = empty - pp_imps what lms - = case [m | L _ m <- lms, m `elem` cycle_mods] of - [] -> empty - ms -> what <+> text "imports" <+> - pprWithCommas ppr ms - ------------------------------------------------------------------ --- --- Flags --- ------------------------------------------------------------------ - -depStartMarker, depEndMarker :: String -depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" -depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" - diff --git a/main/DriverPhases.hs b/main/DriverPhases.hs deleted file mode 100644 --- a/main/DriverPhases.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ --- --- GHC Driver --- --- (c) The University of Glasgow 2002 --- ------------------------------------------------------------------------------ - -module DriverPhases ( - HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, - Phase(..), - happensBefore, eqPhase, anyHsc, isStopLn, - startPhase, - phaseInputExt, - - isHaskellishSuffix, - isHaskellSrcSuffix, - isBackpackishSuffix, - isObjectSuffix, - isCishSuffix, - isDynLibSuffix, - isHaskellUserSrcSuffix, - isHaskellSigSuffix, - isSourceSuffix, - - isHaskellishTarget, - - isHaskellishFilename, - isHaskellSrcFilename, - isHaskellSigFilename, - isObjectFilename, - isCishFilename, - isDynLibFilename, - isHaskellUserSrcFilename, - isSourceFilename - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DynFlags -import Outputable -import GHC.Platform -import System.FilePath -import Binary -import Util - ------------------------------------------------------------------------------ --- 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 --} - --- Note [HscSource types] --- ~~~~~~~~~~~~~~~~~~~~~~ --- There are three types of source file for Haskell code: --- --- * HsSrcFile is an ordinary hs file which contains code, --- --- * HsBootFile is an hs-boot file, which is used to break --- recursive module imports (there will always be an --- HsSrcFile associated with it), and --- --- * HsigFile is an hsig file, which contains only type --- signatures and is used to specify signatures for --- modules. --- --- Syntactically, hs-boot files and hsig files are quite similar: they --- only include type signatures and must be associated with an --- actual HsSrcFile. isHsBootOrSig allows us to abstract over code --- which is indifferent to which. However, there are some important --- differences, mostly owing to the fact that hsigs are proper --- modules (you `import Sig` directly) whereas HsBootFiles are --- temporary placeholders (you `import {-# SOURCE #-} Mod). --- When we finish compiling the true implementation of an hs-boot, --- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the --- other hand, is never replaced (in particular, we *cannot* use the --- HomeModInfo of the original HsSrcFile backing the signature, since it --- will export too many symbols.) --- --- Additionally, while HsSrcFile is the only Haskell file --- which has *code*, we do generate .o files for HsigFile, because --- this is how the recompilation checker figures out if a file --- needs to be recompiled. These are fake object files which --- should NOT be linked against. - -data HscSource - = HsSrcFile | HsBootFile | HsigFile - deriving( Eq, Ord, Show ) - -- Ord needed for the finite maps we build in CompManager - -instance Binary HscSource where - put_ bh HsSrcFile = putByte bh 0 - put_ bh HsBootFile = putByte bh 1 - put_ bh HsigFile = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return HsSrcFile - 1 -> return HsBootFile - _ -> return HsigFile - -hscSourceString :: HscSource -> String -hscSourceString HsSrcFile = "" -hscSourceString HsBootFile = "[boot]" -hscSourceString HsigFile = "[sig]" - --- See Note [isHsBootOrSig] -isHsBootOrSig :: HscSource -> Bool -isHsBootOrSig HsBootFile = True -isHsBootOrSig HsigFile = True -isHsBootOrSig _ = False - -isHsigFile :: HscSource -> Bool -isHsigFile HsigFile = True -isHsigFile _ = False - -data Phase - = Unlit HscSource - | Cpp HscSource - | HsPp HscSource - | Hsc HscSource - | Ccxx -- Compile C++ - | Cc -- Compile C - | Cobjc -- Compile Objective-C - | Cobjcxx -- Compile Objective-C++ - | HCc -- Haskellised C (as opposed to vanilla C) compilation - | As Bool -- Assembler for regular assembly files (Bool: with-cpp) - | LlvmOpt -- Run LLVM opt tool over llvm assembly - | LlvmLlc -- LLVM bitcode to native assembly - | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM - | CmmCpp -- pre-process Cmm source - | Cmm -- parse & compile Cmm code - | MergeForeign -- merge in the foreign object files - - -- The final phase is a pseudo-phase that tells the pipeline to stop. - -- There is no runPhase case for it. - | StopLn -- Stop, but linking will follow, so generate .o file - deriving (Eq, Show) - -instance Outputable Phase where - ppr p = text (show p) - -anyHsc :: Phase -anyHsc = Hsc (panic "anyHsc") - -isStopLn :: Phase -> Bool -isStopLn StopLn = True -isStopLn _ = False - -eqPhase :: Phase -> Phase -> Bool --- Equality of constructors, ignoring the HscSource field --- NB: the HscSource field can be 'bot'; see anyHsc above -eqPhase (Unlit _) (Unlit _) = True -eqPhase (Cpp _) (Cpp _) = True -eqPhase (HsPp _) (HsPp _) = True -eqPhase (Hsc _) (Hsc _) = True -eqPhase Cc Cc = True -eqPhase Cobjc Cobjc = True -eqPhase HCc HCc = True -eqPhase (As x) (As y) = x == y -eqPhase LlvmOpt LlvmOpt = True -eqPhase LlvmLlc LlvmLlc = True -eqPhase LlvmMangle LlvmMangle = True -eqPhase CmmCpp CmmCpp = True -eqPhase Cmm Cmm = True -eqPhase MergeForeign MergeForeign = True -eqPhase StopLn StopLn = True -eqPhase Ccxx Ccxx = True -eqPhase Cobjcxx Cobjcxx = True -eqPhase _ _ = False - -{- Note [Partial ordering on phases] - -We want to know which phases will occur before which others. This is used for -sanity checking, to ensure that the pipeline will stop at some point (see -DriverPipeline.runPipeline). - -A < B iff A occurs before B in a normal compilation pipeline. - -There is explicitly not a total ordering on phases, because in registerised -builds, the phase `HsC` doesn't happen before nor after any other phase. - -Although we check that a normal user doesn't set the stop_phase to HsC through -use of -C with registerised builds (in Main.checkOptions), it is still -possible for a ghc-api user to do so. So be careful when using the function -happensBefore, and don't think that `not (a <= b)` implies `b < a`. --} -happensBefore :: DynFlags -> Phase -> Phase -> Bool -happensBefore dflags p1 p2 = p1 `happensBefore'` p2 - where StopLn `happensBefore'` _ = False - x `happensBefore'` y = after_x `eqPhase` y - || after_x `happensBefore'` y - where after_x = nextPhase dflags x - -nextPhase :: DynFlags -> Phase -> Phase -nextPhase dflags p - -- A conservative approximation to the next phase, used in happensBefore - = case p of - Unlit sf -> Cpp sf - Cpp sf -> HsPp sf - HsPp sf -> Hsc sf - Hsc _ -> maybeHCc - LlvmOpt -> LlvmLlc - LlvmLlc -> LlvmMangle - LlvmMangle -> As False - As _ -> MergeForeign - Ccxx -> As False - Cc -> As False - Cobjc -> As False - Cobjcxx -> As False - CmmCpp -> Cmm - Cmm -> maybeHCc - HCc -> As False - MergeForeign -> StopLn - StopLn -> panic "nextPhase: nothing after StopLn" - where maybeHCc = if platformUnregisterised (targetPlatform dflags) - then HCc - else As False - --- the first compilation phase for a given file is determined --- by its suffix. -startPhase :: String -> Phase -startPhase "lhs" = Unlit HsSrcFile -startPhase "lhs-boot" = Unlit HsBootFile -startPhase "lhsig" = Unlit HsigFile -startPhase "hs" = Cpp HsSrcFile -startPhase "hs-boot" = Cpp HsBootFile -startPhase "hsig" = Cpp HsigFile -startPhase "hscpp" = HsPp HsSrcFile -startPhase "hspp" = Hsc HsSrcFile -startPhase "hc" = HCc -startPhase "c" = Cc -startPhase "cpp" = Ccxx -startPhase "C" = Cc -startPhase "m" = Cobjc -startPhase "M" = Cobjcxx -startPhase "mm" = Cobjcxx -startPhase "cc" = Ccxx -startPhase "cxx" = Ccxx -startPhase "s" = As False -startPhase "S" = As True -startPhase "ll" = LlvmOpt -startPhase "bc" = LlvmLlc -startPhase "lm_s" = LlvmMangle -startPhase "o" = StopLn -startPhase "cmm" = CmmCpp -startPhase "cmmcpp" = Cmm -startPhase _ = StopLn -- all unknown file types - --- This is used to determine the extension for the output from the --- current phase (if it generates a new file). The extension depends --- on the next phase in the pipeline. -phaseInputExt :: Phase -> String -phaseInputExt (Unlit HsSrcFile) = "lhs" -phaseInputExt (Unlit HsBootFile) = "lhs-boot" -phaseInputExt (Unlit HsigFile) = "lhsig" -phaseInputExt (Cpp _) = "lpp" -- intermediate only -phaseInputExt (HsPp _) = "hscpp" -- intermediate only -phaseInputExt (Hsc _) = "hspp" -- intermediate only - -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x - -- because runPipeline uses the StopBefore phase to pick the - -- output filename. That could be fixed, but watch out. -phaseInputExt HCc = "hc" -phaseInputExt Ccxx = "cpp" -phaseInputExt Cobjc = "m" -phaseInputExt Cobjcxx = "mm" -phaseInputExt Cc = "c" -phaseInputExt (As True) = "S" -phaseInputExt (As False) = "s" -phaseInputExt LlvmOpt = "ll" -phaseInputExt LlvmLlc = "bc" -phaseInputExt LlvmMangle = "lm_s" -phaseInputExt CmmCpp = "cmmcpp" -phaseInputExt Cmm = "cmm" -phaseInputExt MergeForeign = "o" -phaseInputExt StopLn = "o" - -haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - haskellish_user_src_suffixes, haskellish_sig_suffixes - :: [String] --- When a file with an extension in the haskellish_src_suffixes group is --- loaded in --make mode, its imports will be loaded too. -haskellish_src_suffixes = haskellish_user_src_suffixes ++ - [ "hspp", "hscpp" ] -haskellish_suffixes = haskellish_src_suffixes ++ - [ "hc", "cmm", "cmmcpp" ] -cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] - --- Will not be deleted as temp files: -haskellish_user_src_suffixes = - haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] -haskellish_sig_suffixes = [ "hsig", "lhsig" ] -backpackish_suffixes = [ "bkp" ] - -objish_suffixes :: Platform -> [String] --- Use the appropriate suffix for the system on which --- the GHC-compiled code will run -objish_suffixes platform = case platformOS platform of - OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] - _ -> [ "o" ] - -dynlib_suffixes :: Platform -> [String] -dynlib_suffixes platform = case platformOS platform of - OSMinGW32 -> ["dll", "DLL"] - OSDarwin -> ["dylib", "so"] - _ -> ["so"] - -isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isHaskellSigSuffix - :: String -> Bool -isHaskellishSuffix s = s `elem` haskellish_suffixes -isBackpackishSuffix s = s `elem` backpackish_suffixes -isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes -isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes -isCishSuffix s = s `elem` cish_suffixes -isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes - -isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool -isObjectSuffix platform s = s `elem` objish_suffixes platform -isDynLibSuffix platform s = s `elem` dynlib_suffixes platform - -isSourceSuffix :: String -> Bool -isSourceSuffix suff = isHaskellishSuffix suff - || isCishSuffix suff - || isBackpackishSuffix suff - --- | When we are given files (modified by -x arguments) we need --- to determine if they are Haskellish or not to figure out --- how we should try to compile it. The rules are: --- --- 1. If no -x flag was specified, we check to see if --- the file looks like a module name, has no extension, --- or has a Haskell source extension. --- --- 2. If an -x flag was specified, we just make sure the --- specified suffix is a Haskell one. -isHaskellishTarget :: (String, Maybe Phase) -> Bool -isHaskellishTarget (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) -isHaskellishTarget (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm - , StopLn] - -isHaskellishFilename, isHaskellSrcFilename, isCishFilename, - isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename - :: FilePath -> Bool --- takeExtension return .foo, so we drop 1 to get rid of the . -isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) -isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) -isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) -isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) -isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) -isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) - -isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool -isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) -isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) diff --git a/main/DriverPipeline.hs b/main/DriverPipeline.hs deleted file mode 100644 --- a/main/DriverPipeline.hs +++ /dev/null @@ -1,2386 +0,0 @@ -{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module DriverPipeline ( - -- Run a series of compilation steps in a pipeline, for a - -- collection of source files. - oneShot, compileFile, - - -- Interfaces for the batch-mode driver - linkBinary, - - -- Interfaces for the compilation manager (interpreted/batch-mode) - preprocess, - compileOne, compileOne', - link, - - -- Exports for hooks to override runPhase and link - PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), - phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, - hscPostBackendPhase, getLocation, setModLocation, setDynFlags, - runPhase, exeFileName, - maybeCreateManifest, - doCpp, - linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode - ) where - -#include -#include "HsVersions.h" - -import GhcPrelude - -import PipelineMonad -import Packages -import HeaderInfo -import DriverPhases -import SysTools -import SysTools.ExtraObj -import HscMain -import Finder -import HscTypes hiding ( Hsc ) -import Outputable -import Module -import ErrUtils -import DynFlags -import Panic -import Util -import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) -import BasicTypes ( SuccessFlag(..) ) -import Maybes ( expectJust ) -import SrcLoc -import LlvmCodeGen ( llvmFixupAsm, llvmVersionList ) -import MonadUtils -import GHC.Platform -import TcRnTypes -import ToolSettings -import Hooks -import qualified GHC.LanguageExtensions as LangExt -import FileCleanup -import Ar -import Bag ( unitBag ) -import FastString ( mkFastString ) -import MkIface ( mkFullIface ) - -import Exception -import System.Directory -import System.FilePath -import System.IO -import Control.Monad -import Data.List ( isInfixOf, intercalate ) -import Data.Maybe -import Data.Version -import Data.Either ( partitionEithers ) - -import Data.Time ( UTCTime ) - --- --------------------------------------------------------------------------- --- Pre-process - --- | Just preprocess a file, put the result in a temp. file (used by the --- compilation manager during the summary phase). --- --- We return the augmented DynFlags, because they contain the result --- of slurping in the OPTIONS pragmas - -preprocess :: HscEnv - -> FilePath -- ^ input filename - -> Maybe InputFileBuffer - -- ^ optional buffer to use instead of reading the input file - -> Maybe Phase -- ^ starting phase - -> IO (Either ErrorMessages (DynFlags, FilePath)) -preprocess hsc_env input_fn mb_input_buf mb_phase = - handleSourceError (\err -> return (Left (srcErrorMessages err))) $ - ghandle handler $ - fmap Right $ do - MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) - (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) - Nothing - -- We keep the processed file for the whole session to save on - -- duplicated work in ghci. - (Temporary TFL_GhcSession) - Nothing{-no ModLocation-} - []{-no foreign objects-} - -- We stop before Hsc phase so we shouldn't generate an interface - MASSERT(isNothing mb_iface) - return (dflags, fp) - where - srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 - handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg - handler ex = throwGhcExceptionIO ex - --- --------------------------------------------------------------------------- - --- | Compile --- --- Compile a single module, under the control of the compilation manager. --- --- This is the interface between the compilation manager and the --- compiler proper (hsc), where we deal with tedious details like --- reading the OPTIONS pragma from the source file, converting the --- C or assembly that GHC produces into an object file, and compiling --- FFI stub files. --- --- NB. No old interface can also mean that the source has changed. - -compileOne :: HscEnv - -> ModSummary -- ^ summary for module being compiled - -> Int -- ^ module N ... - -> Int -- ^ ... of M - -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified - -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful - -compileOne = compileOne' Nothing (Just batchMsg) - -compileOne' :: Maybe TcGblEnv - -> Maybe Messager - -> HscEnv - -> ModSummary -- ^ summary for module being compiled - -> Int -- ^ module N ... - -> Int -- ^ ... of M - -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified - -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful - -compileOne' m_tc_result mHscMessage - hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable - source_modified0 - = do - - debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) - - -- Run the pipeline up to codeGen (so everything up to, but not including, STG) - (status, hmi_details, plugin_dflags) <- hscIncrementalCompile - always_do_basic_recompilation_check - m_tc_result mHscMessage - hsc_env summary source_modified mb_old_iface (mod_index, nmods) - - let flags = hsc_dflags hsc_env0 - in do unless (gopt Opt_KeepHiFiles flags) $ - addFilesToClean flags TFL_CurrentModule $ - [ml_hi_file $ ms_location summary] - unless (gopt Opt_KeepOFiles flags) $ - addFilesToClean flags TFL_GhcSession $ - [ml_obj_file $ ms_location summary] - - -- Use an HscEnv with DynFlags updated with the plugin info (returned from - -- hscIncrementalCompile) - let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags } - - case (status, hsc_lang) of - (HscUpToDate iface, _) -> - -- TODO recomp014 triggers this assert. What's going on?! - -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) - return $! HomeModInfo iface hmi_details mb_old_linkable - (HscNotGeneratingCode iface, HscNothing) -> - let mb_linkable = if isHsBootOrSig src_flavour - then Nothing - -- TODO: Questionable. - else Just (LM (ms_hs_date summary) this_mod []) - in return $! HomeModInfo iface hmi_details mb_linkable - (HscNotGeneratingCode _, _) -> panic "compileOne HscNotGeneratingCode" - (_, HscNothing) -> panic "compileOne HscNothing" - (HscUpdateBoot iface, HscInterpreted) -> do - return $! HomeModInfo iface hmi_details Nothing - (HscUpdateBoot iface, _) -> do - touchObjectFile dflags object_filename - return $! HomeModInfo iface hmi_details Nothing - (HscUpdateSig iface, HscInterpreted) -> do - let !linkable = LM (ms_hs_date summary) this_mod [] - return $! HomeModInfo iface hmi_details (Just linkable) - (HscUpdateSig iface, _) -> do - output_fn <- getOutputFilename next_phase - (Temporary TFL_CurrentModule) basename dflags - next_phase (Just location) - - -- #10660: Use the pipeline instead of calling - -- compileEmptyStub directly, so -dynamic-too gets - -- handled properly - _ <- runPipeline StopLn hsc_env' - (output_fn, - Nothing, - Just (HscOut src_flavour - mod_name (HscUpdateSig iface))) - (Just basename) - Persistent - (Just location) - [] - o_time <- getModificationUTCTime object_filename - let !linkable = LM o_time this_mod [DotO object_filename] - return $! HomeModInfo iface hmi_details (Just linkable) - (HscRecomp { hscs_guts = cgguts, - hscs_mod_location = mod_location, - hscs_partial_iface = partial_iface, - hscs_old_iface_hash = mb_old_iface_hash, - hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do - -- In interpreted mode the regular codeGen backend is not run so we - -- generate a interface without codeGen info. - final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface - liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash mod_location - - (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location - - stub_o <- case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env' stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc spt_entries] - unlinked_time = ms_hs_date summary - -- Why do we use the timestamp of the source file here, - -- rather than the current time? This works better in - -- the case where the local clock is out of sync - -- with the filesystem's clock. It's just as accurate: - -- if the source is modified, then the linkable will - -- be out of date. - let !linkable = LM unlinked_time (ms_mod summary) - (hs_unlinked ++ stub_o) - return $! HomeModInfo final_iface hmi_details (Just linkable) - (HscRecomp{}, _) -> do - output_fn <- getOutputFilename next_phase - (Temporary TFL_CurrentModule) - basename dflags next_phase (Just location) - -- We're in --make mode: finish the compilation pipeline. - (_, _, Just iface) <- runPipeline StopLn hsc_env' - (output_fn, - Nothing, - Just (HscOut src_flavour mod_name status)) - (Just basename) - Persistent - (Just location) - [] - -- The object filename comes from the ModLocation - o_time <- getModificationUTCTime object_filename - let !linkable = LM o_time this_mod [DotO object_filename] - return $! HomeModInfo iface hmi_details (Just linkable) - - where dflags0 = ms_hspp_opts summary - this_mod = ms_mod summary - location = ms_location summary - input_fn = expectJust "compile:hs" (ml_hs_file location) - input_fnpp = ms_hspp_file summary - mod_graph = hsc_mod_graph hsc_env0 - needsLinker = needsTemplateHaskellOrQQ mod_graph - isDynWay = any (== WayDyn) (ways dflags0) - isProfWay = any (== WayProf) (ways dflags0) - internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) - - src_flavour = ms_hsc_src summary - mod_name = ms_mod_name summary - next_phase = hscPostBackendPhase src_flavour hsc_lang - object_filename = ml_obj_file location - - -- #8180 - when using TemplateHaskell, switch on -dynamic-too so - -- the linker can correctly load the object files. This isn't necessary - -- when using -fexternal-interpreter. - dflags1 = if dynamicGhc && internalInterpreter && - not isDynWay && not isProfWay && needsLinker - then gopt_set dflags0 Opt_BuildDynamicToo - else dflags0 - - -- #16331 - when no "internal interpreter" is available but we - -- need to process some TemplateHaskell or QuasiQuotes, we automatically - -- turn on -fexternal-interpreter. - dflags2 = if not internalInterpreter && needsLinker - then gopt_set dflags1 Opt_ExternalInterpreter - else dflags1 - - basename = dropExtension input_fn - - -- We add the directory in which the .hs files resides) to the import - -- path. This is needed when we try to compile the .hc file later, if it - -- imports a _stub.h file that we created here. - current_dir = takeDirectory basename - old_paths = includePaths dflags2 - !prevailing_dflags = hsc_dflags hsc_env0 - dflags = - dflags2 { includePaths = addQuoteInclude old_paths [current_dir] - , log_action = log_action prevailing_dflags } - -- use the prevailing log_action / log_finaliser, - -- not the one cached in the summary. This is so - -- that we can change the log_action without having - -- to re-summarize all the source files. - hsc_env = hsc_env0 {hsc_dflags = dflags} - - -- Figure out what lang we're generating - hsc_lang = hscTarget dflags - - -- -fforce-recomp should also work with --make - force_recomp = gopt Opt_ForceRecomp dflags - source_modified - | force_recomp = SourceModified - | otherwise = source_modified0 - - always_do_basic_recompilation_check = case hsc_lang of - HscInterpreted -> True - _ -> False - ------------------------------------------------------------------------------ --- stub .h and .c files (for foreign export support), and cc files. - --- The _stub.c file is derived from the haskell source file, possibly taking --- into account the -stubdir option. --- --- The object file created by compiling the _stub.c file is put into a --- temporary file, which will be later combined with the main .o file --- (see the MergeForeigns phase). --- --- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files --- from TH, that are then compiled and linked to the module. This is --- useful to implement facilities such as inline-c. - -compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath -compileForeign _ RawObject object_file = return object_file -compileForeign hsc_env lang stub_c = do - let phase = case lang of - LangC -> Cc - LangCxx -> Ccxx - LangObjc -> Cobjc - LangObjcxx -> Cobjcxx - LangAsm -> As True -- allow CPP - RawObject -> panic "compileForeign: should be unreachable" - (_, stub_o, _) <- runPipeline StopLn hsc_env - (stub_c, Nothing, Just (RealPhase phase)) - Nothing (Temporary TFL_GhcSession) - Nothing{-no ModLocation-} - [] - return stub_o - -compileStub :: HscEnv -> FilePath -> IO FilePath -compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c - -compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () -compileEmptyStub dflags hsc_env basename location mod_name = do - -- To maintain the invariant that every Haskell file - -- compiles to object code, we make an empty (but - -- valid) stub object file for signatures. However, - -- we make sure this object file has a unique symbol, - -- so that ranlib on OS X doesn't complain, see - -- https://gitlab.haskell.org/ghc/ghc/issues/12673 - -- and https://github.com/haskell/cabal/issues/2257 - empty_stub <- newTempName dflags TFL_CurrentModule "c" - let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;" - writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) - _ <- runPipeline StopLn hsc_env - (empty_stub, Nothing, Nothing) - (Just basename) - Persistent - (Just location) - [] - return () - --- --------------------------------------------------------------------------- --- Link --- --- Note [Dynamic linking on macOS] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Since macOS Sierra (10.14), the dynamic system linker enforces --- a limit on the Load Commands. Specifically the Load Command Size --- Limit is at 32K (32768). The Load Commands contain the install --- name, dependencies, runpaths, and a few other commands. We however --- only have control over the install name, dependencies and runpaths. --- --- The install name is the name by which this library will be --- referenced. This is such that we do not need to bake in the full --- absolute location of the library, and can move the library around. --- --- The dependency commands contain the install names from of referenced --- libraries. Thus if a libraries install name is @rpath/libHS...dylib, --- that will end up as the dependency. --- --- Finally we have the runpaths, which informs the linker about the --- directories to search for the referenced dependencies. --- --- The system linker can do recursive linking, however using only the --- direct dependencies conflicts with ghc's ability to inline across --- packages, and as such would end up with unresolved symbols. --- --- Thus we will pass the full dependency closure to the linker, and then --- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs). --- --- We still need to add the relevant runpaths, for the dynamic linker to --- lookup the referenced libraries though. The linker (ld64) does not --- have any option to dead strip runpaths; which makes sense as runpaths --- can be used for dependencies of dependencies as well. --- --- The solution we then take in GHC is to not pass any runpaths to the --- linker at link time, but inject them after the linking. For this to --- work we'll need to ask the linker to create enough space in the header --- to add more runpaths after the linking (-headerpad 8000). --- --- After the library has been linked by $LD (usually ld64), we will use --- otool to inspect the libraries left over after dead stripping, compute --- the relevant runpaths, and inject them into the linked product using --- the install_name_tool command. --- --- This strategy should produce the smallest possible set of load commands --- while still retaining some form of relocatability via runpaths. --- --- The only way I can see to reduce the load command size further would be --- by shortening the library names, or start putting libraries into the same --- folders, such that one runpath would be sufficient for multiple/all --- libraries. -link :: GhcLink -- interactive or batch - -> DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link - -> IO SuccessFlag - --- For the moment, in the batch linker, we don't bother to tell doLink --- which packages to link -- it just tries all that are available. --- batch_attempt_linking should only be *looked at* in batch mode. It --- should only be True if the upsweep was successful and someone --- exports main, i.e., we have good reason to believe that linking --- will succeed. - -link ghcLink dflags - = lookupHook linkHook l dflags ghcLink dflags - where - l LinkInMemory _ _ _ - = if platformMisc_ghcWithInterpreter $ platformMisc dflags - then -- Not Linking...(demand linker will do the job) - return Succeeded - else panicBadLink LinkInMemory - - l NoLink _ _ _ - = return Succeeded - - l LinkBinary dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt - - l LinkStaticLib dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt - - l LinkDynLib dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt - -panicBadLink :: GhcLink -> a -panicBadLink other = panic ("link: GHC not built to link this way: " ++ - show other) - -link' :: DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link - -> IO SuccessFlag - -link' dflags batch_attempt_linking hpt - | batch_attempt_linking - = do - let - staticLink = case ghcLink dflags of - LinkStaticLib -> True - _ -> False - - home_mod_infos = eltsHpt hpt - - -- the packages we depend on - pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos - - -- the linkables to link - linkables = map (expectJust "link".hm_linkable) home_mod_infos - - debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) - - -- check for the -no-link flag - if isNoLink (ghcLink dflags) - then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") - return Succeeded - else do - - let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables - - exe_file = exeFileName staticLink dflags - - linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps - - if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") - return Succeeded - else do - - compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") - - -- Don't showPass in Batch mode; doLink will do that for us. - let link = case ghcLink dflags of - LinkBinary -> linkBinary - LinkStaticLib -> linkStaticLib - LinkDynLib -> linkDynLibCheck - other -> panicBadLink other - link dflags obj_files pkg_deps - - debugTraceMsg dflags 3 (text "link: done") - - -- linkBinary only returns if it succeeds - return Succeeded - - | otherwise - = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ - text " Main.main not exported; not linking.") - return Succeeded - - -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool -linkingNeeded dflags staticLink linkables pkg_deps = do - -- if the modification time on the executable is later than the - -- modification times on all of the objects and libraries, then omit - -- linking (unless the -fforce-recomp flag was given). - let exe_file = exeFileName staticLink dflags - e_exe_time <- tryIO $ getModificationUTCTime exe_file - case e_exe_time of - Left _ -> return True - Right t -> do - -- first check object files and extra_ld_inputs - let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] - e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs - let (errs,extra_times) = partitionEithers e_extra_times - let obj_times = map linkableTime linkables ++ extra_times - if not (null errs) || any (t <) obj_times - then return True - else do - - -- next, check libraries. XXX this only checks Haskell libraries, - -- not extra_libraries or -l things from the command line. - let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib) - | Just c <- map (lookupInstalledPackage dflags) pkg_deps, - lib <- packageHsLibs dflags c ] - - pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs - if any isNothing pkg_libfiles then return True else do - e_lib_times <- mapM (tryIO . getModificationUTCTime) - (catMaybes pkg_libfiles) - let (lib_errs,lib_times) = partitionEithers e_lib_times - if not (null lib_errs) || any (t <) lib_times - then return True - else checkLinkInfo dflags pkg_deps exe_file - -findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) -findHSLib dflags dirs lib = do - let batch_lib_file = if WayDyn `notElem` ways dflags - then "lib" ++ lib <.> "a" - else mkSOName (targetPlatform dflags) lib - found <- filterM doesFileExist (map ( batch_lib_file) dirs) - case found of - [] -> return Nothing - (x:_) -> return (Just x) - --- ----------------------------------------------------------------------------- --- Compile files in one-shot mode. - -oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () -oneShot hsc_env stop_phase srcs = do - o_files <- mapM (compileFile hsc_env stop_phase) srcs - doLink (hsc_dflags hsc_env) stop_phase o_files - -compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath -compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- doesFileExist src - when (not exists) $ - throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) - - let - dflags = hsc_dflags hsc_env - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - -- If we are doing -fno-code, then act as if the output is - -- 'Temporary'. This stops GHC trying to copy files to their - -- final location. - | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule - | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | isJust mb_o_file = SpecificFile - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - - ( _, out_file, _) <- runPipeline stop_phase hsc_env - (src, Nothing, fmap RealPhase mb_phase) - Nothing - output - Nothing{-no ModLocation-} [] - return out_file - - -doLink :: DynFlags -> Phase -> [FilePath] -> IO () -doLink dflags stop_phase o_files - | not (isStopLn stop_phase) - = return () -- We stopped before the linking phase - - | otherwise - = case ghcLink dflags of - NoLink -> return () - LinkBinary -> linkBinary dflags o_files [] - LinkStaticLib -> linkStaticLib dflags o_files [] - LinkDynLib -> linkDynLibCheck dflags o_files [] - other -> panicBadLink other - - --- --------------------------------------------------------------------------- - --- | Run a compilation pipeline, consisting of multiple phases. --- --- This is the interface to the compilation pipeline, which runs --- a series of compilation steps on a single source file, specifying --- at which stage to stop. --- --- The DynFlags can be modified by phases in the pipeline (eg. by --- OPTIONS_GHC pragmas), and the changes affect later phases in the --- pipeline. -runPipeline - :: Phase -- ^ When to stop - -> HscEnv -- ^ Compilation environment - -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus) - -- ^ Pipeline input file name, optional - -- buffer and maybe -x suffix - -> Maybe FilePath -- ^ original basename (if different from ^^^) - -> PipelineOutput -- ^ Output filename - -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> [FilePath] -- ^ foreign objects - -> IO (DynFlags, FilePath, Maybe ModIface) - -- ^ (final flags, output filename, interface) -runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) - mb_basename output maybe_loc foreign_os - - = do let - dflags0 = hsc_dflags hsc_env0 - - -- Decide where dump files should go based on the pipeline output - dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } - hsc_env = hsc_env0 {hsc_dflags = dflags} - - (input_basename, suffix) = splitExtension input_fn - suffix' = drop 1 suffix -- strip off the . - basename | Just b <- mb_basename = b - | otherwise = input_basename - - -- If we were given a -x flag, then use that phase to start from - start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase - - isHaskell (RealPhase (Unlit _)) = True - isHaskell (RealPhase (Cpp _)) = True - isHaskell (RealPhase (HsPp _)) = True - isHaskell (RealPhase (Hsc _)) = True - isHaskell (HscOut {}) = True - isHaskell _ = False - - isHaskellishFile = isHaskell start_phase - - env = PipeEnv{ stop_phase, - src_filename = input_fn, - src_basename = basename, - src_suffix = suffix', - output_spec = output } - - when (isBackpackishSuffix suffix') $ - throwGhcExceptionIO (UsageError - ("use --backpack to process " ++ input_fn)) - - -- We want to catch cases of "you can't get there from here" before - -- we start the pipeline, because otherwise it will just run off the - -- end. - let happensBefore' = happensBefore dflags - case start_phase of - RealPhase start_phase' -> - -- See Note [Partial ordering on phases] - -- Not the same as: (stop_phase `happensBefore` start_phase') - when (not (start_phase' `happensBefore'` stop_phase || - start_phase' `eqPhase` stop_phase)) $ - throwGhcExceptionIO (UsageError - ("cannot compile this file to desired target: " - ++ input_fn)) - HscOut {} -> return () - - -- Write input buffer to temp file if requested - input_fn' <- case (start_phase, mb_input_buf) of - (RealPhase real_start_phase, Just input_buf) -> do - let suffix = phaseInputExt real_start_phase - fn <- newTempName dflags TFL_CurrentModule suffix - hdl <- openBinaryFile fn WriteMode - -- Add a LINE pragma so reported source locations will - -- mention the real input file, not this temp file. - hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" - hPutStringBuffer hdl input_buf - hClose hdl - return fn - (_, _) -> return input_fn - - debugTraceMsg dflags 4 (text "Running the pipeline") - r <- runPipeline' start_phase hsc_env env input_fn' - maybe_loc foreign_os - - -- If we are compiling a Haskell module, and doing - -- -dynamic-too, but couldn't do the -dynamic-too fast - -- path, then rerun the pipeline for the dyn way - let dflags = hsc_dflags hsc_env - -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) - when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do - when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do - debugTraceMsg dflags 4 - (text "Running the pipeline again for -dynamic-too") - let dflags' = dynamicTooMkDynamicDynFlags dflags - hsc_env' <- newHscEnv dflags' - _ <- runPipeline' start_phase hsc_env' env input_fn' - maybe_loc foreign_os - return () - return r - -runPipeline' - :: PhasePlus -- ^ When to start - -> HscEnv -- ^ Compilation environment - -> PipeEnv - -> FilePath -- ^ Input filename - -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> [FilePath] -- ^ foreign objects, if we have one - -> IO (DynFlags, FilePath, Maybe ModIface) - -- ^ (final flags, output filename, interface) -runPipeline' start_phase hsc_env env input_fn - maybe_loc foreign_os - = do - -- Execute the pipeline... - let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing } - (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state - return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state) - --- --------------------------------------------------------------------------- --- outer pipeline loop - --- | pipeLoop runs phases until we reach the stop phase -pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath -pipeLoop phase input_fn = do - env <- getPipeEnv - dflags <- getDynFlags - -- See Note [Partial ordering on phases] - let happensBefore' = happensBefore dflags - stopPhase = stop_phase env - case phase of - RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done - -> -- Sometimes, a compilation phase doesn't actually generate any output - -- (eg. the CPP phase when -fcpp is not turned on). If we end on this - -- stage, but we wanted to keep the output, then we have to explicitly - -- copy the file, remembering to prepend a {-# LINE #-} pragma so that - -- further compilation stages can tell what the original filename was. - case output_spec env of - Temporary _ -> - return input_fn - output -> - do pst <- getPipeState - final_fn <- liftIO $ getOutputFilename - stopPhase output (src_basename env) - dflags stopPhase (maybe_loc pst) - when (final_fn /= input_fn) $ do - let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") - line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") - liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn - return final_fn - - - | not (realPhase `happensBefore'` stopPhase) - -- Something has gone wrong. We'll try to cover all the cases when - -- this could happen, so if we reach here it is a panic. - -- eg. it might happen if the -C flag is used on a source file that - -- has {-# OPTIONS -fasm #-}. - -> panic ("pipeLoop: at phase " ++ show realPhase ++ - " but I wanted to stop at phase " ++ show stopPhase) - - _ - -> do liftIO $ debugTraceMsg dflags 4 - (text "Running phase" <+> ppr phase) - (next_phase, output_fn) <- runHookedPhase phase input_fn dflags - case phase of - HscOut {} -> do - -- We don't pass Opt_BuildDynamicToo to the backend - -- in DynFlags. - -- Instead it's run twice with flags accordingly set - -- per run. - let noDynToo = pipeLoop next_phase output_fn - let dynToo = do - setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo - r <- pipeLoop next_phase output_fn - setDynFlags $ dynamicTooMkDynamicDynFlags dflags - -- TODO shouldn't ignore result: - _ <- pipeLoop phase input_fn - return r - ifGeneratingDynamicToo dflags dynToo noDynToo - _ -> pipeLoop next_phase output_fn - -runHookedPhase :: PhasePlus -> FilePath -> DynFlags - -> CompPipeline (PhasePlus, FilePath) -runHookedPhase pp input dflags = - lookupHook runPhaseHook runPhase dflags pp input dflags - --- ----------------------------------------------------------------------------- --- In each phase, we need to know into what filename to generate the --- output. All the logic about which filenames we generate output --- into is embodied in the following function. - --- | Computes the next output filename after we run @next_phase@. --- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad --- (which specifies all of the ambient information.) -phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath -phaseOutputFilename next_phase = do - PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv - PipeState{maybe_loc, hsc_env} <- getPipeState - let dflags = hsc_dflags hsc_env - liftIO $ getOutputFilename stop_phase output_spec - src_basename dflags next_phase maybe_loc - --- | Computes the next output filename for something in the compilation --- pipeline. This is controlled by several variables: --- --- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This --- is used to tell if we're in the last phase or not, because --- in that case flags like @-o@ may be important. --- 2. 'PipelineOutput': is this intended to be a 'Temporary' or --- 'Persistent' build output? Temporary files just go in --- a fresh temporary name. --- 3. 'String': what was the basename of the original input file? --- 4. 'DynFlags': the obvious thing --- 5. 'Phase': the phase we want to determine the output filename of. --- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're --- compiling; this can be used to override the default output --- of an object file. (TODO: do we actually need this?) -getOutputFilename - :: Phase -> PipelineOutput -> String - -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath -getOutputFilename stop_phase output basename dflags next_phase maybe_location - | is_last_phase, Persistent <- output = persistent_fn - | is_last_phase, SpecificFile <- output = case outputFile dflags of - Just f -> return f - Nothing -> - panic "SpecificFile: No filename" - | keep_this_output = persistent_fn - | Temporary lifetime <- output = newTempName dflags lifetime suffix - | otherwise = newTempName dflags TFL_CurrentModule - suffix - where - hcsuf = hcSuf dflags - odir = objectDir dflags - osuf = objectSuf dflags - keep_hc = gopt Opt_KeepHcFiles dflags - keep_hscpp = gopt Opt_KeepHscppFiles dflags - keep_s = gopt Opt_KeepSFiles dflags - keep_bc = gopt Opt_KeepLlvmFiles dflags - - myPhaseInputExt HCc = hcsuf - myPhaseInputExt MergeForeign = osuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other - - is_last_phase = next_phase `eqPhase` stop_phase - - -- sometimes, we keep output from intermediate stages - keep_this_output = - case next_phase of - As _ | keep_s -> True - LlvmOpt | keep_bc -> True - HCc | keep_hc -> True - HsPp _ | keep_hscpp -> True -- See #10869 - _other -> False - - suffix = myPhaseInputExt next_phase - - -- persistent object files get put in odir - persistent_fn - | StopLn <- next_phase = return odir_persistent - | otherwise = return persistent - - persistent = basename <.> suffix - - odir_persistent - | Just loc <- maybe_location = ml_obj_file loc - | Just d <- odir = d persistent - | otherwise = persistent - - --- | The fast LLVM Pipeline skips the mangler and assembler, --- emitting object code directly from llc. --- --- slow: opt -> llc -> .s -> mangler -> as -> .o --- fast: opt -> llc -> .o --- --- hidden flag: -ffast-llvm --- --- if keep-s-files is specified, we need to go through --- the slow pipeline (Kavon Farvardin requested this). -fastLlvmPipeline :: DynFlags -> Bool -fastLlvmPipeline dflags - = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags - --- | LLVM Options. These are flags to be passed to opt and llc, to ensure --- consistency we list them in pairs, so that they form groups. -llvmOptions :: DynFlags - -> [(String, String)] -- ^ pairs of (opt, llc) arguments -llvmOptions dflags = - [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] - ++ [("-relocation-model=" ++ rmodel - ,"-relocation-model=" ++ rmodel) | not (null rmodel)] - ++ [("-stack-alignment=" ++ (show align) - ,"-stack-alignment=" ++ (show align)) | align > 0 ] - ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ] - - -- Additional llc flags - ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) - , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] - ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] - - where target = platformMisc_llvmTarget $ platformMisc dflags - Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags) - - -- Relocation models - rmodel | gopt Opt_PIC dflags = "pic" - | positionIndependent dflags = "pic" - | WayDyn `elem` ways dflags = "dynamic-no-pic" - | otherwise = "static" - - align :: Int - align = case platformArch (targetPlatform dflags) of - ArchX86_64 | isAvxEnabled dflags -> 32 - _ -> 0 - - attrs :: String - attrs = intercalate "," $ mattr - ++ ["+sse42" | isSse4_2Enabled dflags ] - ++ ["+sse2" | isSse2Enabled dflags ] - ++ ["+sse" | isSseEnabled dflags ] - ++ ["+avx512f" | isAvx512fEnabled dflags ] - ++ ["+avx2" | isAvx2Enabled dflags ] - ++ ["+avx" | isAvxEnabled dflags ] - ++ ["+avx512cd"| isAvx512cdEnabled dflags ] - ++ ["+avx512er"| isAvx512erEnabled dflags ] - ++ ["+avx512pf"| isAvx512pfEnabled dflags ] - ++ ["+bmi" | isBmiEnabled dflags ] - ++ ["+bmi2" | isBmi2Enabled dflags ] - --- ----------------------------------------------------------------------------- --- | Each phase in the pipeline returns the next phase to execute, and the --- name of the file in which the output was placed. --- --- We must do things dynamically this way, because we often don't know --- what the rest of the phases will be until part-way through the --- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning --- of a source file can change the latter stages of the pipeline from --- taking the LLVM route to using the native code generator. --- -runPhase :: PhasePlus -- ^ Run this phase - -> FilePath -- ^ name of the input file - -> DynFlags -- ^ for convenience, we pass the current dflags in - -> CompPipeline (PhasePlus, -- next phase to run - FilePath) -- output filename - - -- Invariant: the output filename always contains the output - -- Interesting case: Hsc when there is no recompilation to do - -- Then the output filename is still a .o file - - -------------------------------------------------------------------------------- --- Unlit phase - -runPhase (RealPhase (Unlit sf)) input_fn dflags - = do - output_fn <- phaseOutputFilename (Cpp sf) - - let flags = [ -- The -h option passes the file name for unlit to - -- put in a #line directive - SysTools.Option "-h" - -- See Note [Don't normalise input filenames]. - , SysTools.Option $ escape input_fn - , SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn - ] - - liftIO $ SysTools.runUnlit dflags flags - - return (RealPhase (Cpp sf), output_fn) - where - -- escape the characters \, ", and ', but don't try to escape - -- Unicode or anything else (so we don't use Util.charToC - -- here). If we get this wrong, then in - -- Coverage.isGoodTickSrcSpan where we check that the filename in - -- a SrcLoc is the same as the source filenaame, the two will - -- look bogusly different. See test: - -- libraries/hpc/tests/function/subdir/tough2.hs - escape ('\\':cs) = '\\':'\\': escape cs - escape ('\"':cs) = '\\':'\"': escape cs - escape ('\'':cs) = '\\':'\'': escape cs - escape (c:cs) = c : escape cs - escape [] = [] - -------------------------------------------------------------------------------- --- Cpp phase : (a) gets OPTIONS out of file --- (b) runs cpp if necessary - -runPhase (RealPhase (Cpp sf)) input_fn dflags0 - = do - src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn - (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicFilePragma dflags0 src_opts - setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags - - if not (xopt LangExt.Cpp dflags1) then do - -- we have to be careful to emit warnings only once. - unless (gopt Opt_Pp dflags1) $ - liftIO $ handleFlagWarnings dflags1 warns - - -- no need to preprocess CPP, just pass input file along - -- to the next phase of the pipeline. - return (RealPhase (HsPp sf), input_fn) - else do - output_fn <- phaseOutputFilename (HsPp sf) - liftIO $ doCpp dflags1 True{-raw-} - input_fn output_fn - -- re-read the pragmas now that we've preprocessed the file - -- See #2464,#3457 - src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn - (dflags2, unhandled_flags, warns) - <- liftIO $ parseDynamicFilePragma dflags0 src_opts - liftIO $ checkProcessArgsResult dflags2 unhandled_flags - unless (gopt Opt_Pp dflags2) $ - liftIO $ handleFlagWarnings dflags2 warns - -- the HsPp pass below will emit warnings - - setDynFlags dflags2 - - return (RealPhase (HsPp sf), output_fn) - -------------------------------------------------------------------------------- --- HsPp phase - -runPhase (RealPhase (HsPp sf)) input_fn dflags - = do - if not (gopt Opt_Pp dflags) then - -- no need to preprocess, just pass input file along - -- to the next phase of the pipeline. - return (RealPhase (Hsc sf), input_fn) - else do - PipeEnv{src_basename, src_suffix} <- getPipeEnv - let orig_fn = src_basename <.> src_suffix - output_fn <- phaseOutputFilename (Hsc sf) - liftIO $ SysTools.runPp dflags - ( [ SysTools.Option orig_fn - , SysTools.Option input_fn - , SysTools.FileOption "" output_fn - ] - ) - - -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- liftIO $ getOptionsFromFile dflags output_fn - (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicFilePragma dflags src_opts - setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags - liftIO $ handleFlagWarnings dflags1 warns - - return (RealPhase (Hsc sf), output_fn) - ------------------------------------------------------------------------------ --- Hsc phase - --- Compilation of a single module, in "legacy" mode (_not_ under --- the direction of the compilation manager). -runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 - = do -- normal Hsc mode, not mkdependHS - - PipeEnv{ stop_phase=stop, - src_basename=basename, - src_suffix=suff } <- getPipeEnv - - -- we add the current directory (i.e. the directory in which - -- the .hs files resides) to the include path, since this is - -- what gcc does, and it's probably what you want. - let current_dir = takeDirectory basename - new_includes = addQuoteInclude paths [current_dir] - paths = includePaths dflags0 - dflags = dflags0 { includePaths = new_includes } - - setDynFlags dflags - - -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do - do - buf <- hGetStringBuffer input_fn - eimps <- getImports dflags buf input_fn (basename <.> suff) - case eimps of - Left errs -> throwErrors errs - Right (src_imps,imps,L _ mod_name) -> return - (Just buf, mod_name, imps, src_imps) - - -- Take -o into account if present - -- Very like -ohi, but we must *only* do this if we aren't linking - -- (If we're linking then the -o applies to the linked thing, not to - -- the object file for one module.) - -- Note the nasty duplication with the same computation in compileFile above - location <- getLocation src_flavour mod_name - - let o_file = ml_obj_file location -- The real object file - hi_file = ml_hi_file location - hie_file = ml_hie_file location - dest_file | writeInterfaceOnlyMode dflags - = hi_file - | otherwise - = o_file - - -- Figure out if the source has changed, for recompilation avoidance. - -- - -- Setting source_unchanged to True means that M.o (or M.hie) seems - -- to be up to date wrt M.hs; so no need to recompile unless imports have - -- changed (which the compiler itself figures out). - -- Setting source_unchanged to False tells the compiler that M.o is out of - -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) - - source_unchanged <- liftIO $ - if not (isStopLn stop) - -- SourceModified unconditionally if - -- (a) recompilation checker is off, or - -- (b) we aren't going all the way to .o file (e.g. ghc -S) - then return SourceModified - -- Otherwise look at file modification dates - else do dest_file_mod <- sourceModified dest_file src_timestamp - hie_file_mod <- if gopt Opt_WriteHie dflags - then sourceModified hie_file - src_timestamp - else pure False - if dest_file_mod || hie_file_mod - then return SourceModified - else return SourceUnmodified - - PipeState{hsc_env=hsc_env'} <- getPipeState - - -- Tell the finder cache about this module - mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location - - -- Make the ModSummary to hand to hscMain - let - mod_summary = ModSummary { ms_mod = mod, - ms_hsc_src = src_flavour, - ms_hspp_file = input_fn, - ms_hspp_opts = dflags, - ms_hspp_buf = hspp_buf, - ms_location = location, - ms_hs_date = src_timestamp, - ms_obj_date = Nothing, - ms_parsed_mod = Nothing, - ms_iface_date = Nothing, - ms_hie_date = Nothing, - ms_textual_imps = imps, - ms_srcimps = src_imps } - - -- run the compiler! - let msg hsc_env _ what _ = oneShotMsg hsc_env what - (result, _mod_details, plugin_dflags) <- - liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' - mod_summary source_unchanged Nothing (1,1) - - -- In the rest of the pipeline use the dflags with plugin info - setDynFlags plugin_dflags - - return (HscOut src_flavour mod_name result, - panic "HscOut doesn't have an input filename") - -runPhase (HscOut src_flavour mod_name result) _ dflags = do - location <- getLocation src_flavour mod_name - setModLocation location - - let o_file = ml_obj_file location -- The real object file - hsc_lang = hscTarget dflags - next_phase = hscPostBackendPhase src_flavour hsc_lang - - case result of - HscNotGeneratingCode _ -> - return (RealPhase StopLn, - panic "No output filename from Hsc when no-code") - HscUpToDate _ -> - do liftIO $ touchObjectFile dflags o_file - -- The .o file must have a later modification date - -- than the source file (else we wouldn't get Nothing) - -- but we touch it anyway, to keep 'make' happy (we think). - return (RealPhase StopLn, o_file) - HscUpdateBoot _ -> - do -- In the case of hs-boot files, generate a dummy .o-boot - -- stamp file for the benefit of Make - liftIO $ touchObjectFile dflags o_file - return (RealPhase StopLn, o_file) - HscUpdateSig _ -> - do -- We need to create a REAL but empty .o file - -- because we are going to attempt to put it in a library - PipeState{hsc_env=hsc_env'} <- getPipeState - let input_fn = expectJust "runPhase" (ml_hs_file location) - basename = dropExtension input_fn - liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name - return (RealPhase StopLn, o_file) - HscRecomp { hscs_guts = cgguts, - hscs_mod_location = mod_location, - hscs_partial_iface = partial_iface, - hscs_old_iface_hash = mb_old_iface_hash, - hscs_iface_dflags = iface_dflags } - -> do output_fn <- phaseOutputFilename next_phase - - PipeState{hsc_env=hsc_env'} <- getPipeState - - (outputFilename, mStub, foreign_files) <- liftIO $ - hscGenHardCode hsc_env' cgguts mod_location output_fn - - final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface) - setIface final_iface - - -- See Note [Writing interface files] - let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo - liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location - - stub_o <- liftIO (mapM (compileStub hsc_env') mStub) - foreign_os <- liftIO $ - mapM (uncurry (compileForeign hsc_env')) foreign_files - setForeignOs (maybe [] return stub_o ++ foreign_os) - - return (RealPhase next_phase, outputFilename) - ------------------------------------------------------------------------------ --- Cmm phase - -runPhase (RealPhase CmmCpp) input_fn dflags - = do output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp dflags False{-not raw-} - input_fn output_fn - return (RealPhase Cmm, output_fn) - -runPhase (RealPhase Cmm) input_fn dflags - = do let hsc_lang = hscTarget dflags - let next_phase = hscPostBackendPhase HsSrcFile hsc_lang - output_fn <- phaseOutputFilename next_phase - PipeState{hsc_env} <- getPipeState - liftIO $ hscCompileCmmFile hsc_env input_fn output_fn - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- Cc phase - -runPhase (RealPhase cc_phase) input_fn dflags - | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] - = do - let platform = targetPlatform dflags - hcc = cc_phase `eqPhase` HCc - - let cmdline_include_paths = includePaths dflags - - -- HC files have the dependent packages stamped into them - pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return [] - - -- add package include paths even if we're just compiling .c - -- files; this is the Value Add(TM) that using ghc instead of - -- gcc gives you :) - pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - -- pass -D or -optP to preprocessor when compiling foreign C files - -- (#16737). Doing it in this way is simpler and also enable the C - -- compiler to performs preprocessing and parsing in a single pass, - -- but it may introduce inconsistency if a different pgm_P is specified. - let more_preprocessor_opts = concat - [ ["-Xpreprocessor", i] - | not hcc - , i <- getOpts dflags opt_P - ] - - let gcc_extra_viac_flags = extraGccViaCFlags dflags - let pic_c_flags = picCCOpts dflags - - let verbFlags = getVerbFlags dflags - - -- cc-options are not passed when compiling .hc files. Our - -- hc code doesn't not #include any header files anyway, so these - -- options aren't necessary. - pkg_extra_cc_opts <- liftIO $ - if hcc - then return [] - else getPackageExtraCcOpts dflags pkgs - - framework_paths <- - if platformUsesFrameworks platform - then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs - let cmdlineFrameworkPaths = frameworkPaths dflags - return $ map ("-F"++) - (cmdlineFrameworkPaths ++ pkgFrameworkPaths) - else return [] - - let cc_opt | optLevel dflags >= 2 = [ "-O2" ] - | optLevel dflags >= 1 = [ "-O" ] - | otherwise = [] - - -- Decide next phase - let next_phase = As False - output_fn <- phaseOutputFilename next_phase - - let - more_hcc_opts = - -- on x86 the floating point regs have greater precision - -- than a double, which leads to unpredictable results. - -- By default, we turn this off with -ffloat-store unless - -- the user specified -fexcess-precision. - (if platformArch platform == ArchX86 && - not (gopt Opt_ExcessPrecision dflags) - then [ "-ffloat-store" ] - else []) ++ - - -- gcc's -fstrict-aliasing allows two accesses to memory - -- to be considered non-aliasing if they have different types. - -- This interacts badly with the C code we generate, which is - -- very weakly typed, being derived from C--. - ["-fno-strict-aliasing"] - - ghcVersionH <- liftIO $ getGhcVersionPathName dflags - - liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( - [ SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - pic_c_flags - - -- Stub files generated for foreign exports references the runIO_closure - -- and runNonIO_closure symbols, which are defined in the base package. - -- These symbols are imported into the stub.c file via RtsAPI.h, and the - -- way we do the import depends on whether we're currently compiling - -- the base package or not. - ++ (if platformOS platform == OSMinGW32 && - thisPackage dflags == baseUnitId - then [ "-DCOMPILING_BASE_PACKAGE" ] - else []) - - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. See #2872, commit - -- 5bd3072ac30216a505151601884ac88bf404c9f2 - ++ (if platformArch platform == ArchSPARC - then ["-mcpu=v9"] - else []) - - -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. - ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) - then ["-Wimplicit"] - else []) - - ++ (if hcc - then gcc_extra_viac_flags ++ more_hcc_opts - else []) - ++ verbFlags - ++ [ "-S" ] - ++ cc_opt - ++ [ "-include", ghcVersionH ] - ++ framework_paths - ++ include_paths - ++ more_preprocessor_opts - ++ pkg_extra_cc_opts - )) - - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- As, SpitAs phase : Assembler - --- This is for calling the assembler on a regular assembly file -runPhase (RealPhase (As with_cpp)) input_fn dflags - = do - -- LLVM from version 3.0 onwards doesn't support the OS X system - -- assembler, so we use clang as the assembler instead. (#5636) - let as_prog | hscTarget dflags == HscLlvm && - platformOS (targetPlatform dflags) == OSDarwin - = SysTools.runClang - | otherwise = SysTools.runAs - - let cmdline_include_paths = includePaths dflags - let pic_c_flags = picCCOpts dflags - - next_phase <- maybeMergeForeign - output_fn <- phaseOutputFilename next_phase - - -- we create directories for the object file, because it - -- might be a hierarchical module. - liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - - ccInfo <- liftIO $ getCompilerInfo dflags - let global_includes = [ SysTools.Option ("-I" ++ p) - | p <- includePathsGlobal cmdline_include_paths ] - let local_includes = [ SysTools.Option ("-iquote" ++ p) - | p <- includePathsQuote cmdline_include_paths ] - let runAssembler inputFilename outputFilename - = liftIO $ do - withAtomicRename outputFilename $ \temp_outputFilename -> do - as_prog - dflags - (local_includes ++ global_includes - -- See Note [-fPIC for assembler] - ++ map SysTools.Option pic_c_flags - -- See Note [Produce big objects on Windows] - ++ [ SysTools.Option "-Wa,-mbig-obj" - | platformOS (targetPlatform dflags) == OSMinGW32 - , not $ target32Bit (targetPlatform dflags) - ] - - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction so we have to make sure that the assembler accepts the - -- instruction set. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. - ++ (if platformArch (targetPlatform dflags) == ArchSPARC - then [SysTools.Option "-mcpu=v9"] - else []) - ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [SysTools.Option "-Qunused-arguments"] - else []) - ++ [ SysTools.Option "-x" - , if with_cpp - then SysTools.Option "assembler-with-cpp" - else SysTools.Option "assembler" - , SysTools.Option "-c" - , SysTools.FileOption "" inputFilename - , SysTools.Option "-o" - , SysTools.FileOption "" temp_outputFilename - ]) - - liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") - runAssembler input_fn output_fn - - return (RealPhase next_phase, output_fn) - - ------------------------------------------------------------------------------ --- LlvmOpt phase -runPhase (RealPhase LlvmOpt) input_fn dflags - = do - output_fn <- phaseOutputFilename LlvmLlc - - liftIO $ SysTools.runLlvmOpt dflags - ( optFlag - ++ defaultOptions ++ - [ SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn] - ) - - return (RealPhase LlvmLlc, output_fn) - where - -- we always (unless -optlo specified) run Opt since we rely on it to - -- fix up some pretty big deficiencies in the code we generate - optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] - llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of - Just passes -> passes - Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " - ++ "is missing passes for level " - ++ show optIdx) - - -- don't specify anything if user has specified commands. We do this - -- for opt but not llc since opt is very specifically for optimisation - -- passes only, so if the user is passing us extra options we assume - -- they know what they are doing and don't get in the way. - optFlag = if null (getOpts dflags opt_lo) - then map SysTools.Option $ words llvmOpts - else [] - - defaultOptions = map SysTools.Option . concat . fmap words . fst - $ unzip (llvmOptions dflags) - ------------------------------------------------------------------------------ --- LlvmLlc phase - -runPhase (RealPhase LlvmLlc) input_fn dflags - = do - next_phase <- if | fastLlvmPipeline dflags -> maybeMergeForeign - -- hidden debugging flag '-dno-llvm-mangler' to skip mangling - | gopt Opt_NoLlvmMangler dflags -> return (As False) - | otherwise -> return LlvmMangle - - output_fn <- phaseOutputFilename next_phase - - liftIO $ SysTools.runLlvmLlc dflags - ( optFlag - ++ defaultOptions - ++ [ SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ) - - return (RealPhase next_phase, output_fn) - where - -- Note [Clamping of llc optimizations] - -- - -- See #13724 - -- - -- we clamp the llc optimization between [1,2]. This is because passing -O0 - -- to llc 3.9 or llc 4.0, the naive register allocator can fail with - -- - -- Error while trying to spill R1 from class GPR: Cannot scavenge register - -- without an emergency spill slot! - -- - -- Observed at least with target 'arm-unknown-linux-gnueabihf'. - -- - -- - -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile - -- rts/HeapStackCheck.cmm - -- - -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s - -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40 - -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358 - -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26 - -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876 - -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699 - -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381 - -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457 - -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20 - -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134 - -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498 - -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67 - -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920 - -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133 - -- 13 llc 0x000000010195bf0b main + 491 - -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1 - -- Stack dump: - -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s - -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'. - -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"' - -- - -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa - -- - llvmOpts = case optLevel dflags of - 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. - 1 -> "-O1" - _ -> "-O2" - - optFlag = if null (getOpts dflags opt_lc) - then map SysTools.Option $ words llvmOpts - else [] - - defaultOptions = map SysTools.Option . concat . fmap words . snd - $ unzip (llvmOptions dflags) - - ------------------------------------------------------------------------------ --- LlvmMangle phase - -runPhase (RealPhase LlvmMangle) input_fn dflags - = do - let next_phase = As False - output_fn <- phaseOutputFilename next_phase - liftIO $ llvmFixupAsm dflags input_fn output_fn - return (RealPhase next_phase, output_fn) - ------------------------------------------------------------------------------ --- merge in stub objects - -runPhase (RealPhase MergeForeign) input_fn dflags - = do - PipeState{foreign_os} <- getPipeState - output_fn <- phaseOutputFilename StopLn - liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - if null foreign_os - then panic "runPhase(MergeForeign): no foreign objects" - else do - liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn - return (RealPhase StopLn, output_fn) - --- warning suppression -runPhase (RealPhase other) _input_fn _dflags = - panic ("runPhase: don't know how to run phase " ++ show other) - -maybeMergeForeign :: CompPipeline Phase -maybeMergeForeign - = do - PipeState{foreign_os} <- getPipeState - if null foreign_os then return StopLn else return MergeForeign - -getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation -getLocation src_flavour mod_name = do - dflags <- getDynFlags - - PipeEnv{ src_basename=basename, - src_suffix=suff } <- getPipeEnv - PipeState { maybe_loc=maybe_loc} <- getPipeState - case maybe_loc of - -- Build a ModLocation to pass to hscMain. - -- The source filename is rather irrelevant by now, but it's used - -- by hscMain for messages. hscMain also needs - -- the .hi and .o filenames. If we already have a ModLocation - -- then simply update the extensions of the interface and object - -- files to match the DynFlags, otherwise use the logic in Finder. - Just l -> return $ l - { ml_hs_file = Just $ basename <.> suff - , ml_hi_file = ml_hi_file l -<.> hiSuf dflags - , ml_obj_file = ml_obj_file l -<.> objectSuf dflags - } - _ -> do - location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff - - -- Boot-ify it if necessary - let location2 - | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 - | otherwise = location1 - - - -- Take -ohi into account if present - -- This can't be done in mkHomeModuleLocation because - -- it only applies to the module being compiles - let ohi = outputHi dflags - location3 | Just fn <- ohi = location2{ ml_hi_file = fn } - | otherwise = location2 - - -- Take -o into account if present - -- Very like -ohi, but we must *only* do this if we aren't linking - -- (If we're linking then the -o applies to the linked thing, not to - -- the object file for one module.) - -- Note the nasty duplication with the same computation in compileFile - -- above - let expl_o_file = outputFile dflags - location4 | Just ofile <- expl_o_file - , isNoLink (ghcLink dflags) - = location3 { ml_obj_file = ofile } - | otherwise = location3 - return location4 - ------------------------------------------------------------------------------ --- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file - -getHCFilePackages :: FilePath -> IO [InstalledUnitId] -getHCFilePackages filename = - Exception.bracket (openFile filename ReadMode) hClose $ \h -> do - l <- hGetLine h - case l of - '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToInstalledUnitId (words rest)) - _other -> - return [] - ------------------------------------------------------------------------------ --- Static linking, of .o files - --- The list of packages passed to link is the list of packages on --- which this program depends, as discovered by the compilation --- manager. It is combined with the list of packages that the user --- specifies on the command line with -package flags. --- --- In one-shot linking mode, we can't discover the package --- dependencies (because we haven't actually done any compilation or --- read any interface files), so the user must explicitly specify all --- the packages. - -{- -Note [-Xlinker -rpath vs -Wl,-rpath] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --Wl takes a comma-separated list of options which in the case of --Wl,-rpath -Wl,some,path,with,commas parses the path with commas -as separate options. -Buck, the build system, produces paths with commas in them. - --Xlinker doesn't have this disadvantage and as far as I can tell -it is supported by both gcc and clang. Anecdotally nvcc supports --Xlinker, but not -Wl. --} - -linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () -linkBinary = linkBinary' False - -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () -linkBinary' staticLink dflags o_files dep_packages = do - let platform = targetPlatform dflags - toolSettings' = toolSettings dflags - verbFlags = getVerbFlags dflags - output_fn = exeFileName staticLink dflags - - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d output_fn) - pkg_lib_paths <- getPackageLibraryPath dflags dep_packages - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | osElfTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "$ORIGIN" - (l `makeRelativeTo` full_output_fn) - else l - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - rpath = if useXLinkerRPath dflags (platformOS platform) - then ["-Xlinker", "-rpath", "-Xlinker", libpath] - else [] - -- Solaris 11's linker does not support -rpath-link option. It silently - -- ignores it and then complains about next option which is -l as being a directory and not expected object file, E.g - -- ld: elf error: file - -- /tmp/ghc-src/libraries/base/dist-install/build: - -- elf_begin: I/O error: region read: Is a directory - rpathlink = if (platformOS platform) == OSSolaris2 - then [] - else ["-Xlinker", "-rpath-link", "-Xlinker", l] - in ["-L" ++ l] ++ rpathlink ++ rpath - | osMachOTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags && - useXLinkerRPath dflags (platformOS platform) - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "@loader_path" - (l `makeRelativeTo` full_output_fn) - else l - in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] - | otherwise = ["-L" ++ l] - - pkg_lib_path_opts <- - if gopt Opt_SingleLibFolder dflags - then do - libs <- getLibs dflags dep_packages - tmpDir <- newTempDir dflags - sequence_ [ copyFile lib (tmpDir basename) - | (lib, basename) <- libs] - return [ "-L" ++ tmpDir ] - else pure pkg_lib_path_opts - - let - dead_strip - | gopt Opt_WholeArchiveHsLibs dflags = [] - | otherwise = if osSubsectionsViaSymbols (platformOS platform) - then ["-Wl,-dead_strip"] - else [] - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags - noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages - - let - (pre_hs_libs, post_hs_libs) - | gopt Opt_WholeArchiveHsLibs dflags - = if platformOS platform == OSDarwin - then (["-Wl,-all_load"], []) - -- OS X does not have a flag to turn off -all_load - else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) - | otherwise - = ([],[]) - - pkg_link_opts <- do - (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages - return $ if staticLink - then package_hs_libs -- If building an executable really means making a static - -- library (e.g. iOS), then we only keep the -l options for - -- HS packages, because libtool doesn't accept other options. - -- In the case of iOS these need to be added by hand to the - -- final link in Xcode. - else other_flags ++ dead_strip - ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs - ++ extra_libs - -- -Wl,-u, contained in other_flags - -- needs to be put before -l, - -- otherwise Solaris linker fails linking - -- a binary with unresolved symbols in RTS - -- which are defined in base package - -- the reason for this is a note in ld(1) about - -- '-u' option: "The placement of this option - -- on the command line is significant. - -- This option must be placed before the library - -- that defines the symbol." - - -- frameworks - pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages - let framework_opts = getFrameworkOpts dflags platform - - -- probably _stub.o files - let extra_ld_inputs = ldInputs dflags - - rc_objs <- maybeCreateManifest dflags output_fn - - let link dflags args | staticLink = SysTools.runLibtool dflags args - | platformOS platform == OSDarwin - = SysTools.runLink dflags args >> SysTools.runInjectRPaths dflags pkg_lib_paths output_fn - | otherwise - = SysTools.runLink dflags args - - link dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ libmLinkOpts - ++ map SysTools.Option ( - [] - - -- See Note [No PIE when linking] - ++ picCCOpts dflags - - -- Permit the linker to auto link _symbol to _imp_symbol. - -- This lets us link against DLLs without needing an "import library". - ++ (if platformOS platform == OSMinGW32 - then ["-Wl,--enable-auto-import"] - else []) - - -- '-no_compact_unwind' - -- C++/Objective-C exceptions cannot use optimised - -- stack unwinding code. The optimised form is the - -- default in Xcode 4 on at least x86_64, and - -- without this flag we're also seeing warnings - -- like - -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog - -- on x86. - ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' && - not staticLink && - (platformOS platform == OSDarwin) && - case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - ArchARM {} -> True - ArchAArch64 -> True - _ -> False - then ["-Wl,-no_compact_unwind"] - else []) - - -- '-Wl,-read_only_relocs,suppress' - -- ld gives loads of warnings like: - -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure - -- when linking any program. We're not sure - -- whether this is something we ought to fix, but - -- for now this flags silences them. - ++ (if platformOS platform == OSDarwin && - platformArch platform == ArchX86 && - not staticLink - then ["-Wl,-read_only_relocs,suppress"] - else []) - - ++ (if toolSettings_ldIsGnuLd toolSettings' && - not (gopt Opt_WholeArchiveHsLibs dflags) - then ["-Wl,--gc-sections"] - else []) - - ++ o_files - ++ lib_path_opts) - ++ extra_ld_inputs - ++ map SysTools.Option ( - rc_objs - ++ framework_opts - ++ pkg_lib_path_opts - ++ extraLinkObj:noteLinkObjs - ++ pkg_link_opts - ++ pkg_framework_opts - ++ (if platformOS platform == OSDarwin - -- dead_strip_dylibs, will remove unused dylibs, and thus save - -- space in the load commands. The -headerpad is necessary so - -- that we can inject more @rpath's later for the left over - -- libraries during runInjectRpaths phase. - -- - -- See Note [Dynamic linking on macOS]. - then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] - else []) - )) - -exeFileName :: Bool -> DynFlags -> FilePath -exeFileName staticLink dflags - | Just s <- outputFile dflags = - case platformOS (targetPlatform dflags) of - OSMinGW32 -> s "exe" - _ -> if staticLink - then s "a" - else s - | otherwise = - if platformOS (targetPlatform dflags) == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" - where s ext | null (takeExtension s) = s <.> ext - | otherwise = s - -maybeCreateManifest - :: DynFlags - -> FilePath -- filename of executable - -> IO [FilePath] -- extra objects to embed, maybe -maybeCreateManifest dflags exe_filename - | platformOS (targetPlatform dflags) == OSMinGW32 && - gopt Opt_GenManifest dflags - = do let manifest_filename = exe_filename <.> "manifest" - - writeFile manifest_filename $ - "\n"++ - " \n"++ - " \n\n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - "\n" - - -- Windows will find the manifest file if it is named - -- foo.exe.manifest. However, for extra robustness, and so that - -- we can move the binary around, we can embed the manifest in - -- the binary itself using windres: - if not (gopt Opt_EmbedManifest dflags) then return [] else do - - rc_filename <- newTempName dflags TFL_CurrentModule "rc" - rc_obj_filename <- - newTempName dflags TFL_GhcSession (objectSuf dflags) - - writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" - -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. - - runWindres dflags $ map SysTools.Option $ - ["--input="++rc_filename, - "--output="++rc_obj_filename, - "--output-format=coff"] - -- no FileOptions here: windres doesn't like seeing - -- backslashes, apparently - - removeFile manifest_filename - - return [rc_obj_filename] - | otherwise = return [] - - -linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkDynLibCheck dflags o_files dep_packages - = do - when (haveRtsOptsFlags dflags) $ do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - linkDynLib dflags o_files dep_packages - --- | Linking a static lib will not really link anything. It will merely produce --- a static archive of all dependent static libraries. The resulting library --- will still need to be linked with any remaining link flags. -linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkStaticLib dflags o_files dep_packages = do - let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] - modules = o_files ++ extra_ld_inputs - output_fn = exeFileName True dflags - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d output_fn) - output_exists <- doesFileExist full_output_fn - (when output_exists) $ removeFile full_output_fn - - pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages - archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs - - ar <- foldl mappend - <$> (Archive <$> mapM loadObj modules) - <*> mapM loadAr archives - - if toolSettings_ldIsGnuLd (toolSettings dflags) - then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar - else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar - - -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib dflags [SysTools.FileOption "" output_fn] - --- ----------------------------------------------------------------------------- --- Running CPP - -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do - let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args - | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args) - - let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags - targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags - let target_defs = - [ "-D" ++ HOST_OS ++ "_BUILD_OS", - "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", - "-D" ++ targetOS ++ "_HOST_OS", - "-D" ++ targetArch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitPackages (pkgState dflags) - pkgs = catMaybes (map (lookupPackage dflags) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | hscTarget dflags == HscLlvm = do - llvmVer <- figureLlvmVersion dflags - return $ case fmap llvmVersionList llvmVer of - Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] - Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ = - return [] - --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [PackageConfig] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - --- --------------------------------------------------------------------------- --- join object files into a single relocatable object file, using ld -r - -{- -Note [Produce big objects on Windows] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The Windows Portable Executable object format has a limit of 32k sections, which -we tend to blow through pretty easily. Thankfully, there is a "big object" -extension, which raises this limit to 2^32. However, it must be explicitly -enabled in the toolchain: - - * the assembler accepts the -mbig-obj flag, which causes it to produce a - bigobj-enabled COFF object. - - * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name - suggests, this tells the linker to produce a bigobj-enabled COFF object, no a - PE executable. - -We must enable bigobj output in a few places: - - * When merging object files (DriverPipeline.joinObjectFiles) - - * When assembling (DriverPipeline.runPhase (RealPhase As ...)) - -Unfortunately the big object format is not supported on 32-bit targets so -none of this can be used in that case. - - -Note [Merging object files for GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHCi can usually loads standard linkable object files using GHC's linker -implementation. However, most users build their projects with -split-sections, -meaning that such object files can have an extremely high number of sections. -As the linker must map each of these sections individually, loading such object -files is very inefficient. - -To avoid this inefficiency, we use the linker's `-r` flag and a linker script -to produce a merged relocatable object file. This file will contain a singe -text section section and can consequently be mapped far more efficiently. As -gcc tends to do unpredictable things to our linker command line, we opt to -invoke ld directly in this case, in contrast to our usual strategy of linking -via gcc. - --} - -joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () -joinObjectFiles dflags o_files output_fn = do - let toolSettings' = toolSettings dflags - ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' - osInfo = platformOS (targetPlatform dflags) - ld_r args = SysTools.runMergeObjects dflags ( - -- See Note [Produce big objects on Windows] - concat - [ [SysTools.Option "--oformat", SysTools.Option "pe-bigobj-x86-64"] - | OSMinGW32 == osInfo - , not $ target32Bit (targetPlatform dflags) - ] - ++ map SysTools.Option ld_build_id - ++ [ SysTools.Option "-o", - SysTools.FileOption "" output_fn ] - ++ args) - - -- suppress the generation of the .note.gnu.build-id section, - -- which we don't need and sometimes causes ld to emit a - -- warning: - ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"] - | otherwise = [] - - if ldIsGnuLd - then do - script <- newTempName dflags TFL_CurrentModule "ldscript" - cwd <- getCurrentDirectory - let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files - writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" - ld_r [SysTools.FileOption "" script] - else if toolSettings_ldSupportsFilelist toolSettings' - then do - filelist <- newTempName dflags TFL_CurrentModule "filelist" - writeFile filelist $ unlines o_files - ld_r [SysTools.Option "-filelist", - SysTools.FileOption "" filelist] - else do - ld_r (map (SysTools.FileOption "") o_files) - --- ----------------------------------------------------------------------------- --- Misc. - -writeInterfaceOnlyMode :: DynFlags -> Bool -writeInterfaceOnlyMode dflags = - gopt Opt_WriteInterface dflags && - HscNothing == hscTarget dflags - --- | Figure out if a source file was modified after an output file (or if we --- anyways need to consider the source file modified since the output is gone). -sourceModified :: FilePath -- ^ destination file we are looking for - -> UTCTime -- ^ last time of modification of source file - -> IO Bool -- ^ do we need to regenerate the output? -sourceModified dest_file src_timestamp = do - dest_file_exists <- doesFileExist dest_file - if not dest_file_exists - then return True -- Need to recompile - else do t2 <- getModificationUTCTime dest_file - return (t2 <= src_timestamp) - --- | What phase to run after one of the backend code generators has run -hscPostBackendPhase :: HscSource -> HscTarget -> Phase -hscPostBackendPhase HsBootFile _ = StopLn -hscPostBackendPhase HsigFile _ = StopLn -hscPostBackendPhase _ hsc_lang = - case hsc_lang of - HscC -> HCc - HscAsm -> As False - HscLlvm -> LlvmOpt - HscNothing -> StopLn - HscInterpreted -> StopLn - -touchObjectFile :: DynFlags -> FilePath -> IO () -touchObjectFile dflags path = do - createDirectoryIfMissing True $ takeDirectory path - SysTools.touch dflags "Touching object file" path - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) - - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x - --- Note [-fPIC for assembler] --- When compiling .c source file GHC's driver pipeline basically --- does the following two things: --- 1. ${CC} -S 'PIC_CFLAGS' source.c --- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S --- --- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? --- Because on some architectures (at least sparc32) assembler also chooses --- the relocation type! --- Consider the following C module: --- --- /* pic-sample.c */ --- int v; --- void set_v (int n) { v = n; } --- int get_v (void) { return v; } --- --- $ gcc -S -fPIC pic-sample.c --- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary --- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary --- --- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od --- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od --- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od --- --- Most of architectures won't show any difference in this test, but on sparc32 --- the following assembly snippet: --- --- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 --- --- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: --- --- 3c: 2f 00 00 00 sethi %hi(0), %l7 --- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 --- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 - -{- Note [Don't normalise input filenames] - -Summary - We used to normalise input filenames when starting the unlit phase. This - broke hpc in `--make` mode with imported literate modules (#2991). - -Introduction - 1) --main - When compiling a module with --main, GHC scans its imports to find out which - other modules it needs to compile too. It turns out that there is a small - difference between saying `ghc --make A.hs`, when `A` imports `B`, and - specifying both modules on the command line with `ghc --make A.hs B.hs`. In - the former case, the filename for B is inferred to be './B.hs' instead of - 'B.hs'. - - 2) unlit - When GHC compiles a literate haskell file, the source code first needs to go - through unlit, which turns it into normal Haskell source code. At the start - of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the - option `-h` and the name of the original file. We used to normalise this - filename using System.FilePath.normalise, which among other things removes - an initial './'. unlit then uses that filename in #line directives that it - inserts in the transformed source code. - - 3) SrcSpan - A SrcSpan represents a portion of a source code file. It has fields - linenumber, start column, end column, and also a reference to the file it - originated from. The SrcSpans for a literate haskell file refer to the - filename that was passed to unlit -h. - - 4) -fhpc - At some point during compilation with -fhpc, in the function - `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a - `SrcSpan` refers to with the name of the file we are currently compiling. - For some reason I don't yet understand, they can sometimes legitimally be - different, and then hpc ignores that SrcSpan. - -Problem - When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate - module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the - start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). - Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are - still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), - doesn't include ticks for B, and we have unhappy customers (#2991). - -Solution - Do not normalise `input_fn` when starting the unlit phase. - -Alternative solution - Another option would be to not compare the two filenames on equality, but to - use System.FilePath.equalFilePath. That function first normalises its - arguments. The problem is that by the time we need to do the comparison, the - filenames have been turned into FastStrings, probably for performance - reasons, so System.FilePath.equalFilePath can not be used directly. - -Archeology - The call to `normalise` was added in a commit called "Fix slash - direction on Windows with the new filePath code" (c9b6b5e8). The problem - that commit was addressing has since been solved in a different manner, in a - commit called "Fix the filename passed to unlit" (1eedbc6b). So the - `normalise` is no longer necessary. --} diff --git a/main/DynFlags.hs b/main/DynFlags.hs deleted file mode 100644 --- a/main/DynFlags.hs +++ /dev/null @@ -1,5975 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} - -------------------------------------------------------------------------------- --- --- | Dynamic flags --- --- Most flags are dynamic flags, which means they can change from compilation --- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each --- session can be using different dynamic flags. Dynamic flags can also be set --- at the prompt in GHCi. --- --- (c) The University of Glasgow 2005 --- -------------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - -module DynFlags ( - -- * Dynamic flags and associated configuration types - DumpFlag(..), - GeneralFlag(..), - WarningFlag(..), WarnReason(..), - Language(..), - PlatformConstants(..), - FatalMessager, LogAction, FlushOut(..), FlushErr(..), - ProfAuto(..), - glasgowExtsFlags, - warningGroups, warningHierarchies, - hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, - dopt, dopt_set, dopt_unset, - gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', - wopt, wopt_set, wopt_unset, - wopt_fatal, wopt_set_fatal, wopt_unset_fatal, - xopt, xopt_set, xopt_unset, - xopt_set_unlessExplSpec, - lang_set, - useUnicodeSyntax, - useStarIsType, - whenGeneratingDynamicToo, ifGeneratingDynamicToo, - whenCannotGenerateDynamicToo, - dynamicTooMkDynamicDynFlags, - dynamicOutputFile, - DynFlags(..), - FlagSpec(..), - HasDynFlags(..), ContainsDynFlags(..), - RtsOptsEnabled(..), - HscTarget(..), isObjectTarget, defaultObjectTarget, - targetRetainsAllBindings, - GhcMode(..), isOneShot, - GhcLink(..), isNoLink, - PackageFlag(..), PackageArg(..), ModRenaming(..), - packageFlagsChanged, - IgnorePackageFlag(..), TrustFlag(..), - PackageDBFlag(..), PkgConfRef(..), - Option(..), showOpt, - DynLibLoader(..), - fFlags, fLangFlags, xFlags, - wWarningFlags, - dynFlagDependencies, - makeDynFlagsConsistent, - shouldUseColor, - shouldUseHexWordLiterals, - positionIndependent, - optimisationFlags, - setFlagsFromEnvFile, - - Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, - wayGeneralFlags, wayUnsetGeneralFlags, - - thisPackage, thisComponentId, thisUnitIdInsts, - - -- ** Log output - putLogMsg, - - -- ** Safe Haskell - SafeHaskellMode(..), - safeHaskellOn, safeHaskellModeEnabled, - safeImportsOn, safeLanguageOn, safeInferOn, - packageTrustOn, - safeDirectImpsReq, safeImplicitImpsReq, - unsafeFlags, unsafeFlagsForInfer, - - -- ** LLVM Targets - LlvmTarget(..), LlvmConfig(..), - - -- ** System tool settings and locations - Settings(..), - sProgramName, - sProjectVersion, - sGhcUsagePath, - sGhciUsagePath, - sToolDir, - sTopDir, - sTmpDir, - sSystemPackageConfig, - sLdSupportsCompactUnwind, - sLdSupportsBuildId, - sLdSupportsFilelist, - sLdIsGnuLd, - sGccSupportsNoPie, - sPgm_L, - sPgm_P, - sPgm_F, - sPgm_c, - sPgm_a, - sPgm_l, - sPgm_lm, - sPgm_dll, - sPgm_T, - sPgm_windres, - sPgm_libtool, - sPgm_ar, - sPgm_ranlib, - sPgm_lo, - sPgm_lc, - sPgm_lcc, - sPgm_i, - sOpt_L, - sOpt_P, - sOpt_P_fingerprint, - sOpt_F, - sOpt_c, - sOpt_cxx, - sOpt_a, - sOpt_l, - sOpt_lm, - sOpt_windres, - sOpt_lo, - sOpt_lc, - sOpt_lcc, - sOpt_i, - sExtraGccViaCFlags, - sTargetPlatformString, - sIntegerLibrary, - sIntegerLibraryType, - sGhcWithInterpreter, - sGhcWithNativeCodeGen, - sGhcWithSMP, - sGhcRTSWays, - sTablesNextToCode, - sLeadingUnderscore, - sLibFFI, - sGhcThreaded, - sGhcDebugged, - sGhcRtsWithLibdw, - IntegerLibrary(..), - GhcNameVersion(..), - FileSettings(..), - PlatformMisc(..), - settings, - programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, tmpDir, - versionedAppDir, versionedFilePath, - extraGccViaCFlags, systemPackageConfig, - pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T, - pgm_windres, pgm_libtool, pgm_ar, pgm_otool, pgm_install_name_tool, - pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i, - opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, - opt_P_signature, - opt_windres, opt_lo, opt_lc, opt_lcc, - tablesNextToCode, - - -- ** Manipulating DynFlags - addPluginModuleName, - defaultDynFlags, -- Settings -> DynFlags - defaultWays, - interpWays, - interpreterProfiled, interpreterDynamic, - initDynFlags, -- DynFlags -> IO DynFlags - defaultFatalMessager, - defaultLogAction, - defaultLogActionHPrintDoc, - defaultLogActionHPutStrDoc, - defaultFlushOut, - defaultFlushErr, - - getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlags, - updOptLevel, - setTmpDir, - setUnitId, - canonicalizeHomeModule, - canonicalizeModuleIfHome, - - -- ** Parsing DynFlags - parseDynamicFlagsCmdLine, - parseDynamicFilePragma, - parseDynamicFlagsFull, - - -- ** Available DynFlags - allNonDeprecatedFlags, - flagsAll, - flagsDynamic, - flagsPackage, - flagsForCompletion, - - supportedLanguagesAndExtensions, - languageExtensions, - - -- ** DynFlags C compiler options - picCCOpts, picPOpts, - - -- * Compiler configuration suitable for display to the user - compilerInfo, - - rtsIsProfiled, - dynamicGhc, - -#include "GHCConstantsHaskellExports.hs" - bLOCK_SIZE_W, - wORD_SIZE_IN_BITS, - wordAlignment, - tAG_MASK, - mAX_PTR_TAG, - tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, - - unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, - - -- * SSE and AVX - isSseEnabled, - isSse2Enabled, - isSse4_2Enabled, - isBmiEnabled, - isBmi2Enabled, - isAvxEnabled, - isAvx2Enabled, - isAvx512cdEnabled, - isAvx512erEnabled, - isAvx512fEnabled, - isAvx512pfEnabled, - - -- * Linker/compiler information - LinkerInfo(..), - CompilerInfo(..), - useXLinkerRPath, - - -- * File cleanup - FilesToClean(..), emptyFilesToClean, - - -- * Include specifications - IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, - - - -- * Make use of the Cmm CFG - CfgWeights(..), backendMaintainsCfg - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Platform -import GHC.UniqueSubdir (uniqueSubdir) -import PlatformConstants -import Module -import PackageConfig -import {-# SOURCE #-} Plugins -import {-# SOURCE #-} Hooks -import {-# SOURCE #-} PrelNames ( mAIN ) -import {-# SOURCE #-} Packages (PackageState, emptyPackageState) -import DriverPhases ( Phase(..), phaseInputExt ) -import Config -import CliOption -import CmdLineParser hiding (WarnReason(..)) -import qualified CmdLineParser as Cmd -import Constants -import GhcNameVersion -import Panic -import qualified PprColour as Col -import Util -import Maybes -import MonadUtils -import qualified Pretty -import SrcLoc -import BasicTypes ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) -import FastString -import Fingerprint -import FileSettings -import Outputable -import Settings -import ToolSettings - -import Foreign.C ( CInt(..) ) -import System.IO.Unsafe ( unsafeDupablePerformIO ) -import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn - , getCaretDiagnostic ) -import Json -import SysTools.Terminal ( stderrSupportsAnsiColors ) -import SysTools.BaseDir ( expandToolDir, expandTopDir ) - -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef -import Control.Arrow ((&&&)) -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Except - -import Data.Ord -import Data.Bits -import Data.Char -import Data.Int -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Word -import System.FilePath -import System.Directory -import System.Environment (lookupEnv) -import System.IO -import System.IO.Error -import Text.ParserCombinators.ReadP hiding (char) -import Text.ParserCombinators.ReadP as R - -import EnumSet (EnumSet) -import qualified EnumSet - -import GHC.Foreign (withCString, peekCString) -import qualified GHC.LanguageExtensions as LangExt - -#if GHC_STAGE >= 2 --- used by SHARED_GLOBAL_VAR -import Foreign (Ptr) -#endif - --- Note [Updating flag description in the User's Guide] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you modify anything in this file please make sure that your changes are --- described in the User's Guide. Please update the flag description in the --- users guide (docs/users_guide) whenever you add or change a flag. - --- Note [Supporting CLI completion] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- The command line interface completion (in for example bash) is an easy way --- for the developer to learn what flags are available from GHC. --- GHC helps by separating which flags are available when compiling with GHC, --- and which flags are available when using GHCi. --- A flag is assumed to either work in both these modes, or only in one of them. --- When adding or changing a flag, please consider for which mode the flag will --- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, --- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. - --- Note [Adding a language extension] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- There are a few steps to adding (or removing) a language extension, --- --- * Adding the extension to GHC.LanguageExtensions --- --- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs --- is the canonical list of language extensions known by GHC. --- --- * Adding a flag to DynFlags.xFlags --- --- This is fairly self-explanatory. The name should be concise, memorable, --- and consistent with any previous implementations of the similar idea in --- other Haskell compilers. --- --- * Adding the flag to the documentation --- --- This is the same as any other flag. See --- Note [Updating flag description in the User's Guide] --- --- * Adding the flag to Cabal --- --- The Cabal library has its own list of all language extensions supported --- by all major compilers. This is the list that user code being uploaded --- to Hackage is checked against to ensure language extension validity. --- Consequently, it is very important that this list remains up-to-date. --- --- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) --- whose job it is to ensure these GHC's extensions are consistent with --- Cabal. --- --- The recommended workflow is, --- --- 1. Temporarily add your new language extension to the --- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't --- break while Cabal is updated. --- --- 2. After your GHC change is accepted, submit a Cabal pull request adding --- your new extension to Cabal's list (found in --- Cabal/Language/Haskell/Extension.hs). --- --- 3. After your Cabal change is accepted, let the GHC developers know so --- they can update the Cabal submodule and remove the extensions from --- expectedGhcOnlyExtensions. --- --- * Adding the flag to the GHC Wiki --- --- There is a change log tracking language extension additions and removals --- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history --- --- See #4437 and #8176. - --- ----------------------------------------------------------------------------- --- DynFlags - -data DumpFlag --- See Note [Updating flag description in the User's Guide] - - -- debugging flags - = Opt_D_dump_cmm - | Opt_D_dump_cmm_from_stg - | Opt_D_dump_cmm_raw - | Opt_D_dump_cmm_verbose_by_proc - -- All of the cmm subflags (there are a lot!) automatically - -- enabled if you run -ddump-cmm-verbose-by-proc - -- Each flag corresponds to exact stage of Cmm pipeline. - | Opt_D_dump_cmm_verbose - -- same as -ddump-cmm-verbose-by-proc but writes each stage - -- to a separate file (if used with -ddump-to-file) - | Opt_D_dump_cmm_cfg - | Opt_D_dump_cmm_cbe - | Opt_D_dump_cmm_switch - | Opt_D_dump_cmm_proc - | Opt_D_dump_cmm_sp - | Opt_D_dump_cmm_sink - | Opt_D_dump_cmm_caf - | Opt_D_dump_cmm_procmap - | Opt_D_dump_cmm_split - | Opt_D_dump_cmm_info - | Opt_D_dump_cmm_cps - -- end cmm subflags - | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. - | Opt_D_dump_asm - | Opt_D_dump_asm_native - | Opt_D_dump_asm_liveness - | Opt_D_dump_asm_regalloc - | Opt_D_dump_asm_regalloc_stages - | Opt_D_dump_asm_conflicts - | Opt_D_dump_asm_stats - | Opt_D_dump_asm_expanded - | Opt_D_dump_llvm - | Opt_D_dump_core_stats - | Opt_D_dump_deriv - | Opt_D_dump_ds - | Opt_D_dump_ds_preopt - | Opt_D_dump_foreign - | Opt_D_dump_inlinings - | Opt_D_dump_rule_firings - | Opt_D_dump_rule_rewrites - | Opt_D_dump_simpl_trace - | Opt_D_dump_occur_anal - | Opt_D_dump_parsed - | Opt_D_dump_parsed_ast - | Opt_D_dump_rn - | Opt_D_dump_rn_ast - | Opt_D_dump_simpl - | Opt_D_dump_simpl_iterations - | Opt_D_dump_spec - | Opt_D_dump_prep - | Opt_D_dump_stg -- CoreToStg output - | Opt_D_dump_stg_unarised -- STG after unarise - | Opt_D_dump_stg_final -- STG after stg2stg - | Opt_D_dump_call_arity - | Opt_D_dump_exitify - | Opt_D_dump_stranal - | Opt_D_dump_str_signatures - | Opt_D_dump_tc - | Opt_D_dump_tc_ast - | Opt_D_dump_types - | Opt_D_dump_rules - | Opt_D_dump_cse - | Opt_D_dump_worker_wrapper - | Opt_D_dump_rn_trace - | Opt_D_dump_rn_stats - | Opt_D_dump_opt_cmm - | Opt_D_dump_simpl_stats - | Opt_D_dump_cs_trace -- Constraint solver in type checker - | Opt_D_dump_tc_trace - | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker - | Opt_D_dump_if_trace - | Opt_D_dump_vt_trace - | Opt_D_dump_splices - | Opt_D_th_dec_file - | Opt_D_dump_BCOs - | Opt_D_dump_ticked - | Opt_D_dump_rtti - | Opt_D_source_stats - | Opt_D_verbose_stg2stg - | Opt_D_dump_hi - | Opt_D_dump_hi_diffs - | Opt_D_dump_mod_cycles - | Opt_D_dump_mod_map - | Opt_D_dump_timings - | Opt_D_dump_view_pattern_commoning - | Opt_D_verbose_core2core - | Opt_D_dump_debug - | Opt_D_dump_json - | Opt_D_ppr_debug - | Opt_D_no_debug_output - deriving (Eq, Show, Enum) - - --- | Enumerates the simple on-or-off dynamic flags -data GeneralFlag --- See Note [Updating flag description in the User's Guide] - - = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. - | Opt_D_faststring_stats - | Opt_D_dump_minimal_imports - | Opt_DoCoreLinting - | Opt_DoStgLinting - | Opt_DoCmmLinting - | Opt_DoAsmLinting - | Opt_DoAnnotationLinting - | Opt_NoLlvmMangler -- hidden flag - | Opt_FastLlvm -- hidden flag - | Opt_NoTypeableBinds - - | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_ShowWarnGroups -- Show the group a warning belongs to - | Opt_HideSourcePaths -- Hide module source/object paths - - | Opt_PrintExplicitForalls - | Opt_PrintExplicitKinds - | Opt_PrintExplicitCoercions - | Opt_PrintExplicitRuntimeReps - | Opt_PrintEqualityRelations - | Opt_PrintAxiomIncomps - | Opt_PrintUnicodeSyntax - | Opt_PrintExpandedSynonyms - | Opt_PrintPotentialInstances - | Opt_PrintTypecheckerElaboration - - -- optimisation opts - | Opt_CallArity - | Opt_Exitification - | Opt_Strictness - | Opt_LateDmdAnal -- #6087 - | Opt_KillAbsence - | Opt_KillOneShot - | Opt_FullLaziness - | Opt_FloatIn - | Opt_LateSpecialise - | Opt_Specialise - | Opt_SpecialiseAggressively - | Opt_CrossModuleSpecialise - | Opt_StaticArgumentTransformation - | Opt_CSE - | Opt_StgCSE - | Opt_StgLiftLams - | Opt_LiberateCase - | Opt_SpecConstr - | Opt_SpecConstrKeen - | Opt_DoLambdaEtaExpansion - | Opt_IgnoreAsserts - | Opt_DoEtaReduction - | Opt_CaseMerge - | Opt_CaseFolding -- Constant folding through case-expressions - | Opt_UnboxStrictFields - | Opt_UnboxSmallStrictFields - | Opt_DictsCheap - | Opt_EnableRewriteRules -- Apply rewrite rules during simplification - | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices - | Opt_RegsGraph -- do graph coloring register allocation - | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation - | Opt_PedanticBottoms -- Be picky about how we treat bottom - | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) - | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) - | Opt_IrrefutableTuples - | Opt_CmmSink - | Opt_CmmElimCommonBlocks - | Opt_AsmShortcutting - | Opt_OmitYields - | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas - | Opt_DictsStrict -- be strict in argument dictionaries - | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors - | Opt_Loopification -- See Note [Self-recursive tail calls] - | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. - | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. - | Opt_CprAnal - | Opt_WorkerWrapper - | Opt_SolveConstantDicts - | Opt_AlignmentSanitisation - | Opt_CatchBottoms - | Opt_NumConstantFolding - - -- PreInlining is on by default. The option is there just to see how - -- bad things get if you turn it off! - | Opt_SimplPreInlining - - -- Interface files - | Opt_IgnoreInterfacePragmas - | Opt_OmitInterfacePragmas - | Opt_ExposeAllUnfoldings - | Opt_WriteInterface -- forces .hi files to be written even with -fno-code - | Opt_WriteHie -- generate .hie files - - -- profiling opts - | Opt_AutoSccsOnIndividualCafs - | Opt_ProfCountEntries - - -- misc opts - | Opt_Pp - | Opt_ForceRecomp - | Opt_IgnoreOptimChanges - | Opt_IgnoreHpcChanges - | Opt_ExcessPrecision - | Opt_EagerBlackHoling - | Opt_NoHsMain - | Opt_SplitSections - | Opt_StgStats - | Opt_HideAllPackages - | Opt_HideAllPluginPackages - | Opt_PrintBindResult - | Opt_Haddock - | Opt_HaddockOptions - | Opt_BreakOnException - | Opt_BreakOnError - | Opt_PrintEvldWithShow - | Opt_PrintBindContents - | Opt_GenManifest - | Opt_EmbedManifest - | Opt_SharedImplib - | Opt_BuildingCabalPackage - | Opt_IgnoreDotGhci - | Opt_GhciSandbox - | Opt_GhciHistory - | Opt_GhciLeakCheck - | Opt_ValidateHie - | Opt_LocalGhciHistory - | Opt_NoIt - | Opt_HelpfulErrors - | Opt_DeferTypeErrors - | Opt_DeferTypedHoles - | Opt_DeferOutOfScopeVariables - | Opt_PIC -- ^ @-fPIC@ - | Opt_PIE -- ^ @-fPIE@ - | Opt_PICExecutable -- ^ @-pie@ - | Opt_ExternalDynamicRefs - | Opt_SccProfilingOn - | Opt_Ticky - | Opt_Ticky_Allocd - | Opt_Ticky_LNE - | Opt_Ticky_Dyn_Thunk - | Opt_RPath - | Opt_RelativeDynlibPaths - | Opt_Hpc - | Opt_FlatCache - | Opt_ExternalInterpreter - | Opt_OptimalApplicativeDo - | Opt_VersionMacros - | Opt_WholeArchiveHsLibs - -- copy all libs into a single folder prior to linking binaries - -- this should elivate the excessive command line limit restrictions - -- on windows, by only requiring a single -L argument instead of - -- one for each dependency. At the time of this writing, gcc - -- forwards all -L flags to the collect2 command without using a - -- response file and as such breaking apart. - | Opt_SingleLibFolder - | Opt_KeepCAFs - | Opt_KeepGoing - | Opt_ByteCodeIfUnboxed - - -- output style opts - | Opt_ErrorSpans -- Include full span info in error messages, - -- instead of just the start position. - | Opt_DeferDiagnostics - | Opt_DiagnosticsShowCaret -- Show snippets of offending code - | Opt_PprCaseAsLet - | Opt_PprShowTicks - | Opt_ShowHoleConstraints - -- Options relating to the display of valid hole fits - -- when generating an error message for a typed hole - -- See Note [Valid hole fits include] in TcHoleErrors.hs - | Opt_ShowValidHoleFits - | Opt_SortValidHoleFits - | Opt_SortBySizeHoleFits - | Opt_SortBySubsumHoleFits - | Opt_AbstractRefHoleFits - | Opt_UnclutterValidHoleFits - | Opt_ShowTypeAppOfHoleFits - | Opt_ShowTypeAppVarsOfHoleFits - | Opt_ShowDocsOfHoleFits - | Opt_ShowTypeOfHoleFits - | Opt_ShowProvOfHoleFits - | Opt_ShowMatchesOfHoleFits - - | Opt_ShowLoadedModules - | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] - - -- Suppress all coercions, them replacing with '...' - | Opt_SuppressCoercions - | Opt_SuppressVarKinds - -- Suppress module id prefixes on variables. - | Opt_SuppressModulePrefixes - -- Suppress type applications. - | Opt_SuppressTypeApplications - -- Suppress info such as arity and unfoldings on identifiers. - | Opt_SuppressIdInfo - -- Suppress separate type signatures in core, but leave types on - -- lambda bound vars - | Opt_SuppressUnfoldings - -- Suppress the details of even stable unfoldings - | Opt_SuppressTypeSignatures - -- Suppress unique ids on variables. - -- Except for uniques, as some simplifier phases introduce new - -- variables that have otherwise identical names. - | Opt_SuppressUniques - | Opt_SuppressStgExts - | Opt_SuppressTicks -- Replaces Opt_PprShowTicks - | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps - - -- temporary flags - | Opt_AutoLinkPackages - | Opt_ImplicitImportQualified - - -- keeping stuff - | Opt_KeepHscppFiles - | Opt_KeepHiDiffs - | Opt_KeepHcFiles - | Opt_KeepSFiles - | Opt_KeepTmpFiles - | Opt_KeepRawTokenStream - | Opt_KeepLlvmFiles - | Opt_KeepHiFiles - | Opt_KeepOFiles - - | Opt_BuildDynamicToo - - -- safe haskell flags - | Opt_DistrustAllPackages - | Opt_PackageTrust - | Opt_PluginTrustworthy - - | Opt_G_NoStateHack - | Opt_G_NoOptCoercion - deriving (Eq, Show, Enum) - --- Check whether a flag should be considered an "optimisation flag" --- for purposes of recompilation avoidance (see --- Note [Ignoring some flag changes] in FlagChecker). Being listed here is --- not a guarantee that the flag has no other effect. We could, and --- perhaps should, separate out the flags that have some minor impact on --- program semantics and/or error behavior (e.g., assertions), but --- then we'd need to go to extra trouble (and an additional flag) --- to allow users to ignore the optimisation level even though that --- means ignoring some change. -optimisationFlags :: EnumSet GeneralFlag -optimisationFlags = EnumSet.fromList - [ Opt_CallArity - , Opt_Strictness - , Opt_LateDmdAnal - , Opt_KillAbsence - , Opt_KillOneShot - , Opt_FullLaziness - , Opt_FloatIn - , Opt_LateSpecialise - , Opt_Specialise - , Opt_SpecialiseAggressively - , Opt_CrossModuleSpecialise - , Opt_StaticArgumentTransformation - , Opt_CSE - , Opt_StgCSE - , Opt_StgLiftLams - , Opt_LiberateCase - , Opt_SpecConstr - , Opt_SpecConstrKeen - , Opt_DoLambdaEtaExpansion - , Opt_IgnoreAsserts - , Opt_DoEtaReduction - , Opt_CaseMerge - , Opt_CaseFolding - , Opt_UnboxStrictFields - , Opt_UnboxSmallStrictFields - , Opt_DictsCheap - , Opt_EnableRewriteRules - , Opt_RegsGraph - , Opt_RegsIterative - , Opt_PedanticBottoms - , Opt_LlvmTBAA - , Opt_LlvmFillUndefWithGarbage - , Opt_IrrefutableTuples - , Opt_CmmSink - , Opt_CmmElimCommonBlocks - , Opt_AsmShortcutting - , Opt_OmitYields - , Opt_FunToThunk - , Opt_DictsStrict - , Opt_DmdTxDictSel - , Opt_Loopification - , Opt_CfgBlocklayout - , Opt_WeightlessBlocklayout - , Opt_CprAnal - , Opt_WorkerWrapper - , Opt_SolveConstantDicts - , Opt_CatchBottoms - , Opt_IgnoreAsserts - ] - --- | Used when outputting warnings: if a reason is given, it is --- displayed. If a warning isn't controlled by a flag, this is made --- explicit at the point of use. -data WarnReason - = NoReason - -- | Warning was enabled with the flag - | Reason !WarningFlag - -- | Warning was made an error because of -Werror or -Werror=WarningFlag - | ErrReason !(Maybe WarningFlag) - deriving Show - --- | Used to differentiate the scope an include needs to apply to. --- We have to split the include paths to avoid accidentally forcing recursive --- includes since -I overrides the system search paths. See #14312. -data IncludeSpecs - = IncludeSpecs { includePathsQuote :: [String] - , includePathsGlobal :: [String] - } - deriving Show - --- | Append to the list of includes a path that shall be included using `-I` --- when the C compiler is called. These paths override system search paths. -addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs -addGlobalInclude spec paths = let f = includePathsGlobal spec - in spec { includePathsGlobal = f ++ paths } - --- | Append to the list of includes a path that shall be included using --- `-iquote` when the C compiler is called. These paths only apply when quoted --- includes are used. e.g. #include "foo.h" -addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs -addQuoteInclude spec paths = let f = includePathsQuote spec - in spec { includePathsQuote = f ++ paths } - --- | Concatenate and flatten the list of global and quoted includes returning --- just a flat list of paths. -flattenIncludes :: IncludeSpecs -> [String] -flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs - -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json (Reason wf) = JSString (show wf) - json (ErrReason Nothing) = JSString "Opt_WarnIsError" - json (ErrReason (Just wf)) = JSString (show wf) - -data WarningFlag = --- See Note [Updating flag description in the User's Guide] - Opt_WarnDuplicateExports - | Opt_WarnDuplicateConstraints - | Opt_WarnRedundantConstraints - | Opt_WarnHiShadows - | Opt_WarnImplicitPrelude - | Opt_WarnIncompletePatterns - | Opt_WarnIncompleteUniPatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnOverflowedLiterals - | Opt_WarnEmptyEnumerations - | Opt_WarnMissingFields - | Opt_WarnMissingImportList - | Opt_WarnMissingMethods - | Opt_WarnMissingSignatures - | Opt_WarnMissingLocalSignatures - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnTypeDefaults - | Opt_WarnMonomorphism - | Opt_WarnUnusedTopBinds - | Opt_WarnUnusedLocalBinds - | Opt_WarnUnusedPatternBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnUnusedTypePatterns - | Opt_WarnUnusedForalls - | Opt_WarnUnusedRecordWildcards - | Opt_WarnRedundantRecordWildcards - | Opt_WarnWarningsDeprecations - | Opt_WarnDeprecatedFlags - | Opt_WarnMissingMonadFailInstances -- since 8.0 - | Opt_WarnSemigroup -- since 8.0 - | Opt_WarnDodgyExports - | Opt_WarnDodgyImports - | Opt_WarnOrphans - | Opt_WarnAutoOrphans - | Opt_WarnIdentities - | Opt_WarnTabs - | Opt_WarnUnrecognisedPragmas - | Opt_WarnDodgyForeignImports - | Opt_WarnUnusedDoBind - | Opt_WarnWrongDoBind - | Opt_WarnAlternativeLayoutRuleTransitional - | Opt_WarnUnsafe - | Opt_WarnSafe - | Opt_WarnTrustworthySafe - | Opt_WarnMissedSpecs - | Opt_WarnAllMissedSpecs - | Opt_WarnUnsupportedCallingConventions - | Opt_WarnUnsupportedLlvmVersion - | Opt_WarnMissedExtraSharedLib - | Opt_WarnInlineRuleShadowing - | Opt_WarnTypedHoles - | Opt_WarnPartialTypeSignatures - | Opt_WarnMissingExportedSignatures - | Opt_WarnUntickedPromotedConstructors - | Opt_WarnDerivingTypeable - | Opt_WarnDeferredTypeErrors - | Opt_WarnDeferredOutOfScopeVariables - | Opt_WarnNonCanonicalMonadInstances -- since 8.0 - | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 - | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 - | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 - | Opt_WarnUnrecognisedWarningFlags -- since 8.0 - | Opt_WarnSimplifiableClassConstraints -- Since 8.2 - | Opt_WarnCPPUndef -- Since 8.2 - | Opt_WarnUnbangedStrictPatterns -- Since 8.2 - | Opt_WarnMissingHomeModules -- Since 8.2 - | Opt_WarnPartialFields -- Since 8.4 - | Opt_WarnMissingExportList - | Opt_WarnInaccessibleCode - | Opt_WarnStarIsType -- Since 8.6 - | Opt_WarnStarBinder -- Since 8.6 - | Opt_WarnImplicitKindVars -- Since 8.6 - | Opt_WarnSpaceAfterBang - | Opt_WarnMissingDerivingStrategies -- Since 8.8 - | Opt_WarnPrepositiveQualifiedModule -- Since TBD - | Opt_WarnUnusedPackages -- Since 8.10 - | Opt_WarnInferredSafeImports -- Since 8.10 - | Opt_WarnMissingSafeHaskellMode -- Since 8.10 - | Opt_WarnCompatUnqualifiedImports -- Since 8.10 - | Opt_WarnDerivingDefaults - deriving (Eq, Show, Enum) - -data Language = Haskell98 | Haskell2010 - deriving (Eq, Enum, Show) - -instance Outputable Language where - ppr = text . show - --- | The various Safe Haskell modes -data SafeHaskellMode - = Sf_None -- ^ inferred unsafe - | Sf_Unsafe -- ^ declared and checked - | Sf_Trustworthy -- ^ declared and checked - | Sf_Safe -- ^ declared and checked - | Sf_SafeInferred -- ^ inferred as safe - | Sf_Ignore -- ^ @-fno-safe-haskell@ state - deriving (Eq) - -instance Show SafeHaskellMode where - show Sf_None = "None" - show Sf_Unsafe = "Unsafe" - show Sf_Trustworthy = "Trustworthy" - show Sf_Safe = "Safe" - show Sf_SafeInferred = "Safe-Inferred" - show Sf_Ignore = "Ignore" - -instance Outputable SafeHaskellMode where - ppr = text . show - --- | Contains not only a collection of 'GeneralFlag's but also a plethora of --- information relating to the compilation of a single file or GHC session -data DynFlags = DynFlags { - ghcMode :: GhcMode, - ghcLink :: GhcLink, - hscTarget :: HscTarget, - - -- formerly Settings - ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, - fileSettings :: {-# UNPACK #-} !FileSettings, - targetPlatform :: Platform, -- Filled in by SysTools - toolSettings :: {-# UNPACK #-} !ToolSettings, - platformMisc :: {-# UNPACK #-} !PlatformMisc, - platformConstants :: PlatformConstants, - rawSettings :: [(String, String)], - - integerLibrary :: IntegerLibrary, - -- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overriden - -- by GHC-API users. See Note [The integer library] in PrelNames - llvmConfig :: LlvmConfig, - -- ^ N.B. It's important that this field is lazy since we load the LLVM - -- configuration lazily. See Note [LLVM Configuration] in SysTools. - verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] - optLevel :: Int, -- ^ Optimisation level - debugLevel :: Int, -- ^ How much debug information to produce - simplPhases :: Int, -- ^ Number of simplifier phases - maxSimplIterations :: Int, -- ^ Max simplifier iterations - ruleCheck :: Maybe String, - inlineCheck :: Maybe String, -- ^ A prefix to report inlining decisions about - strictnessBefore :: [Int], -- ^ Additional demand analysis - - parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel - -- in --make mode, where Nothing ==> compile as - -- many in parallel as there are CPUs. - - enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? - ghcHeapSize :: Maybe Int, -- ^ The heap size to set. - - maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt - -- to show in type error messages - maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show - -- in typed hole error messages - maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole - -- fits to show in typed hole error - -- messages - refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for - -- refinement hole fits in typed hole - -- error messages - maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show - -- in non-exhaustiveness warnings - maxPmCheckModels :: Int, -- ^ Soft limit on the number of models - -- the pattern match checker checks - -- a pattern against. A safe guard - -- against exponential blow-up. - simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks - specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr - specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function - specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types - -- Not optional; otherwise ForceSpecConstr can diverge. - binBlobThreshold :: Word, -- ^ Binary literals (e.g. strings) whose size is above - -- this threshold will be dumped in a binary file - -- by the assembler code generator (0 to disable) - liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase - floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating - -- See CoreMonad.FloatOutSwitches - - liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a - -- recursive function. - liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a - -- non-recursive function. - liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call - -- into an unknown call. - - cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. - - historySize :: Int, -- ^ Simplification history size - - importPaths :: [FilePath], - mainModIs :: Module, - mainFunIs :: Maybe String, - reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth - solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver - -- Typically only 1 is needed - - thisInstalledUnitId :: InstalledUnitId, - thisComponentId_ :: Maybe ComponentId, - thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], - - -- ways - ways :: [Way], -- ^ Way flags from the command line - buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) - - -- For object splitting - splitInfo :: Maybe (String,Int), - - -- paths etc. - objectDir :: Maybe String, - dylibInstallName :: Maybe String, - hiDir :: Maybe String, - hieDir :: Maybe String, - stubDir :: Maybe String, - dumpDir :: Maybe String, - - objectSuf :: String, - hcSuf :: String, - hiSuf :: String, - hieSuf :: String, - - canGenerateDynamicToo :: IORef Bool, - dynObjectSuf :: String, - dynHiSuf :: String, - - outputFile :: Maybe String, - dynOutputFile :: Maybe String, - outputHi :: Maybe String, - dynLibLoader :: DynLibLoader, - - -- | This is set by 'DriverPipeline.runPipeline' based on where - -- its output is going. - dumpPrefix :: Maybe FilePath, - - -- | Override the 'dumpPrefix' set by 'DriverPipeline.runPipeline'. - -- Set by @-ddump-file-prefix@ - dumpPrefixForce :: Maybe FilePath, - - ldInputs :: [Option], - - includePaths :: IncludeSpecs, - libraryPaths :: [String], - frameworkPaths :: [String], -- used on darwin only - cmdlineFrameworks :: [String], -- ditto - - rtsOpts :: Maybe String, - rtsOptsEnabled :: RtsOptsEnabled, - rtsOptsSuggestions :: Bool, - - hpcDir :: String, -- ^ Path to store the .mix files - - -- Plugins - pluginModNames :: [ModuleName], - pluginModNameOpts :: [(ModuleName,String)], - frontendPluginOpts :: [String], - -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* - -- order that they're specified on the command line. - cachedPlugins :: [LoadedPlugin], - -- ^ plugins dynamically loaded after processing arguments. What will be - -- loaded here is directed by pluginModNames. Arguments are loaded from - -- pluginModNameOpts. The purpose of this field is to cache the plugins so - -- they don't have to be loaded each time they are needed. See - -- 'DynamicLoading.initializePlugins'. - staticPlugins :: [StaticPlugin], - -- ^ staic plugins which do not need dynamic loading. These plugins are - -- intended to be added by GHC API users directly to this list. - -- - -- To add dynamically loaded plugins through the GHC API see - -- 'addPluginModuleName' instead. - - -- GHC API hooks - hooks :: Hooks, - - -- For ghc -M - depMakefile :: FilePath, - depIncludePkgDeps :: Bool, - depIncludeCppDeps :: Bool, - depExcludeMods :: [ModuleName], - depSuffixes :: [String], - - -- Package flags - packageDBFlags :: [PackageDBFlag], - -- ^ The @-package-db@ flags given on the command line, In - -- *reverse* order that they're specified on the command line. - -- This is intended to be applied with the list of "initial" - -- package databases derived from @GHC_PACKAGE_PATH@; see - -- 'getPackageConfRefs'. - - ignorePackageFlags :: [IgnorePackageFlag], - -- ^ The @-ignore-package@ flags from the command line. - -- In *reverse* order that they're specified on the command line. - packageFlags :: [PackageFlag], - -- ^ The @-package@ and @-hide-package@ flags from the command-line. - -- In *reverse* order that they're specified on the command line. - pluginPackageFlags :: [PackageFlag], - -- ^ The @-plugin-package-id@ flags from command line. - -- In *reverse* order that they're specified on the command line. - trustFlags :: [TrustFlag], - -- ^ The @-trust@ and @-distrust@ flags. - -- In *reverse* order that they're specified on the command line. - packageEnv :: Maybe FilePath, - -- ^ Filepath to the package environment file (if overriding default) - - -- Package state - -- NB. do not modify this field, it is calculated by - -- Packages.initPackages - pkgDatabase :: Maybe [(FilePath, [PackageConfig])], - pkgState :: PackageState, - - -- Temporary files - -- These have to be IORefs, because the defaultCleanupHandler needs to - -- know what to clean when an exception happens - filesToClean :: IORef FilesToClean, - dirsToClean :: IORef (Map FilePath FilePath), - -- The next available suffix to uniquely name a temp file, updated atomically - nextTempSuffix :: IORef Int, - - -- Names of files which were generated from -ddump-to-file; used to - -- track which ones we need to truncate because it's our first run - -- through - generatedDumps :: IORef (Set FilePath), - - -- hsc dynamic flags - dumpFlags :: EnumSet DumpFlag, - generalFlags :: EnumSet GeneralFlag, - warningFlags :: EnumSet WarningFlag, - fatalWarningFlags :: EnumSet WarningFlag, - -- Don't change this without updating extensionFlags: - language :: Maybe Language, - -- | Safe Haskell mode - safeHaskell :: SafeHaskellMode, - safeInfer :: Bool, - safeInferred :: Bool, - -- We store the location of where some extension and flags were turned on so - -- we can produce accurate error messages when Safe Haskell fails due to - -- them. - thOnLoc :: SrcSpan, - newDerivOnLoc :: SrcSpan, - overlapInstLoc :: SrcSpan, - incoherentOnLoc :: SrcSpan, - pkgTrustOnLoc :: SrcSpan, - warnSafeOnLoc :: SrcSpan, - warnUnsafeOnLoc :: SrcSpan, - trustworthyOnLoc :: SrcSpan, - -- Don't change this without updating extensionFlags: - -- Here we collect the settings of the language extensions - -- from the command line, the ghci config file and - -- from interactive :set / :seti commands. - extensions :: [OnOff LangExt.Extension], - -- extensionFlags should always be equal to - -- flattenExtensionFlags language extensions - -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used - -- by template-haskell - extensionFlags :: EnumSet LangExt.Extension, - - -- Unfolding control - -- See Note [Discounts and thresholds] in CoreUnfold - ufCreationThreshold :: Int, - ufUseThreshold :: Int, - ufFunAppDiscount :: Int, - ufDictDiscount :: Int, - ufKeenessFactor :: Float, - ufDearOp :: Int, - ufVeryAggressive :: Bool, - - maxWorkerArgs :: Int, - - ghciHistSize :: Int, - - -- | MsgDoc output action: use "ErrUtils" instead of this if you can - log_action :: LogAction, - flushOut :: FlushOut, - flushErr :: FlushErr, - - ghcVersionFile :: Maybe FilePath, - haddockOptions :: Maybe String, - - -- | GHCi scripts specified by -ghci-script, in reverse order - ghciScripts :: [String], - - -- Output style options - pprUserLength :: Int, - pprCols :: Int, - - useUnicode :: Bool, - useColor :: OverridingBool, - canUseColor :: Bool, - colScheme :: Col.Scheme, - - -- | what kind of {-# SCC #-} to add automatically - profAuto :: ProfAuto, - - interactivePrint :: Maybe String, - - nextWrapperNum :: IORef (ModuleEnv Int), - - -- | Machine dependent flags (-m stuff) - sseVersion :: Maybe SseVersion, - bmiVersion :: Maybe BmiVersion, - avx :: Bool, - avx2 :: Bool, - avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. - avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. - avx512f :: Bool, -- Enable AVX-512 instructions. - avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. - - -- | Run-time linker information (what options we need, etc.) - rtldInfo :: IORef (Maybe LinkerInfo), - - -- | Run-time compiler information - rtccInfo :: IORef (Maybe CompilerInfo), - - -- Constants used to control the amount of optimization done. - - -- | Max size, in bytes, of inline array allocations. - maxInlineAllocSize :: Int, - - -- | Only inline memcpy if it generates no more than this many - -- pseudo (roughly: Cmm) instructions. - maxInlineMemcpyInsns :: Int, - - -- | Only inline memset if it generates no more than this many - -- pseudo (roughly: Cmm) instructions. - maxInlineMemsetInsns :: Int, - - -- | Reverse the order of error messages in GHC/GHCi - reverseErrors :: Bool, - - -- | Limit the maximum number of errors to show - maxErrors :: Maybe Int, - - -- | Unique supply configuration for testing build determinism - initialUnique :: Int, - uniqueIncrement :: Int, - - -- | Temporary: CFG Edge weights for fast iterations - cfgWeightInfo :: CfgWeights -} - --- | Edge weights to use when generating a CFG from CMM -data CfgWeights - = CFGWeights - { uncondWeight :: Int - , condBranchWeight :: Int - , switchWeight :: Int - , callWeight :: Int - , likelyCondWeight :: Int - , unlikelyCondWeight :: Int - , infoTablePenalty :: Int - , backEdgeBonus :: Int - } - -defaultCfgWeights :: CfgWeights -defaultCfgWeights - = CFGWeights - { uncondWeight = 1000 - , condBranchWeight = 800 - , switchWeight = 1 - , callWeight = -10 - , likelyCondWeight = 900 - , unlikelyCondWeight = 300 - , infoTablePenalty = 300 - , backEdgeBonus = 400 - } - -parseCfgWeights :: String -> CfgWeights -> CfgWeights -parseCfgWeights s oldWeights = - foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments - where - assignments = map assignment $ settings s - update "uncondWeight" n w = - w {uncondWeight = n} - update "condBranchWeight" n w = - w {condBranchWeight = n} - update "switchWeight" n w = - w {switchWeight = n} - update "callWeight" n w = - w {callWeight = n} - update "likelyCondWeight" n w = - w {likelyCondWeight = n} - update "unlikelyCondWeight" n w = - w {unlikelyCondWeight = n} - update "infoTablePenalty" n w = - w {infoTablePenalty = n} - update "backEdgeBonus" n w = - w {backEdgeBonus = n} - update other _ _ - = panic $ other ++ - " is not a cfg weight parameter. " ++ - exampleString - settings s - | (s1,rest) <- break (== ',') s - , null rest - = [s1] - | (s1,rest) <- break (== ',') s - = [s1] ++ settings (drop 1 rest) - | otherwise = panic $ "Invalid cfg parameters." ++ exampleString - assignment as - | (name, _:val) <- break (== '=') as - = (name,read val) - | otherwise - = panic $ "Invalid cfg parameters." ++ exampleString - exampleString = "Example parameters: uncondWeight=1000," ++ - "condBranchWeight=800,switchWeight=0,callWeight=300" ++ - ",likelyCondWeight=900,unlikelyCondWeight=300" ++ - ",infoTablePenalty=300,backEdgeBonus=400" - -backendMaintainsCfg :: DynFlags -> Bool -backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of - -- ArchX86 -- Should work but not tested so disabled currently. - ArchX86_64 -> True - _otherwise -> False - -class HasDynFlags m where - getDynFlags :: m DynFlags - -{- It would be desirable to have the more generalised - - instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where - getDynFlags = lift getDynFlags - -instance definition. However, that definition would overlap with the -`HasDynFlags (GhcT m)` instance. Instead we define instances for a -couple of common Monad transformers explicitly. -} - -instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where - getDynFlags = lift getDynFlags - -class ContainsDynFlags t where - extractDynFlags :: t -> DynFlags - -data ProfAuto - = NoProfAuto -- ^ no SCC annotations added - | ProfAutoAll -- ^ top-level and nested functions are annotated - | ProfAutoTop -- ^ top-level functions annotated only - | ProfAutoExports -- ^ exported functions annotated only - | ProfAutoCalls -- ^ annotate call-sites - deriving (Eq,Enum) - -data LlvmTarget = LlvmTarget - { lDataLayout :: String - , lCPU :: String - , lAttributes :: [String] - } - --- | See Note [LLVM Configuration] in SysTools. -data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] - , llvmPasses :: [(Int, String)] - } - ------------------------------------------------------------------------------ --- Accessessors from 'DynFlags' - --- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the --- vast majority of code. But GHCi questionably uses this to produce a default --- 'DynFlags' from which to compute a flags diff for printing. -settings :: DynFlags -> Settings -settings dflags = Settings - { sGhcNameVersion = ghcNameVersion dflags - , sFileSettings = fileSettings dflags - , sTargetPlatform = targetPlatform dflags - , sToolSettings = toolSettings dflags - , sPlatformMisc = platformMisc dflags - , sPlatformConstants = platformConstants dflags - , sRawSettings = rawSettings dflags - } - -programName :: DynFlags -> String -programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags -projectVersion :: DynFlags -> String -projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) -ghcUsagePath :: DynFlags -> FilePath -ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags -ghciUsagePath :: DynFlags -> FilePath -ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags -toolDir :: DynFlags -> Maybe FilePath -toolDir dflags = fileSettings_toolDir $ fileSettings dflags -topDir :: DynFlags -> FilePath -topDir dflags = fileSettings_topDir $ fileSettings dflags -tmpDir :: DynFlags -> String -tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags -extraGccViaCFlags :: DynFlags -> [String] -extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags -systemPackageConfig :: DynFlags -> FilePath -systemPackageConfig dflags = fileSettings_systemPackageConfig $ fileSettings dflags -pgm_L :: DynFlags -> String -pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags -pgm_P :: DynFlags -> (String,[Option]) -pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags -pgm_F :: DynFlags -> String -pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags -pgm_c :: DynFlags -> String -pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags -pgm_a :: DynFlags -> (String,[Option]) -pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags -pgm_l :: DynFlags -> (String,[Option]) -pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags -pgm_lm :: DynFlags -> (String,[Option]) -pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags -pgm_dll :: DynFlags -> (String,[Option]) -pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags -pgm_T :: DynFlags -> String -pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags -pgm_windres :: DynFlags -> String -pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags -pgm_libtool :: DynFlags -> String -pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags -pgm_lcc :: DynFlags -> (String,[Option]) -pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags -pgm_ar :: DynFlags -> String -pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags -pgm_otool :: DynFlags -> String -pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags -pgm_install_name_tool :: DynFlags -> String -pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags -pgm_ranlib :: DynFlags -> String -pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags -pgm_lo :: DynFlags -> (String,[Option]) -pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags -pgm_lc :: DynFlags -> (String,[Option]) -pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags -pgm_i :: DynFlags -> String -pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags -opt_L :: DynFlags -> [String] -opt_L dflags = toolSettings_opt_L $ toolSettings dflags -opt_P :: DynFlags -> [String] -opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) - ++ toolSettings_opt_P (toolSettings dflags) - --- This function packages everything that's needed to fingerprint opt_P --- flags. See Note [Repeated -optP hashing]. -opt_P_signature :: DynFlags -> ([String], Fingerprint) -opt_P_signature dflags = - ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) - , toolSettings_opt_P_fingerprint $ toolSettings dflags - ) - -opt_F :: DynFlags -> [String] -opt_F dflags= toolSettings_opt_F $ toolSettings dflags -opt_c :: DynFlags -> [String] -opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) - ++ toolSettings_opt_c (toolSettings dflags) -opt_cxx :: DynFlags -> [String] -opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags -opt_a :: DynFlags -> [String] -opt_a dflags= toolSettings_opt_a $ toolSettings dflags -opt_l :: DynFlags -> [String] -opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) - ++ toolSettings_opt_l (toolSettings dflags) -opt_lm :: DynFlags -> [String] -opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags -opt_windres :: DynFlags -> [String] -opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags -opt_lcc :: DynFlags -> [String] -opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags -opt_lo :: DynFlags -> [String] -opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags -opt_lc :: DynFlags -> [String] -opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags -opt_i :: DynFlags -> [String] -opt_i dflags= toolSettings_opt_i $ toolSettings dflags - -tablesNextToCode :: DynFlags -> Bool -tablesNextToCode = platformMisc_tablesNextToCode . platformMisc - --- | The directory for this version of ghc in the user's app directory --- (typically something like @~/.ghc/x86_64-linux-7.6.3@) --- -versionedAppDir :: DynFlags -> MaybeT IO FilePath -versionedAppDir dflags = do - -- Make sure we handle the case the HOME isn't set (see #11678) - appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags) - return $ appdir versionedFilePath dflags - -versionedFilePath :: DynFlags -> FilePath -versionedFilePath dflags = uniqueSubdir $ platformMini $ targetPlatform dflags - --- | The target code type of the compilation (if any). --- --- Whenever you change the target, also make sure to set 'ghcLink' to --- something sensible. --- --- 'HscNothing' can be used to avoid generating any output, however, note --- that: --- --- * If a program uses Template Haskell the typechecker may need to run code --- from an imported module. To facilitate this, code generation is enabled --- for modules imported by modules that use template haskell. --- See Note [-fno-code mode]. --- -data HscTarget - = HscC -- ^ Generate C code. - | HscAsm -- ^ Generate assembly using the native code generator. - | HscLlvm -- ^ Generate assembly using the llvm code generator. - | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') - | HscNothing -- ^ Don't generate any code. See notes above. - deriving (Eq, Show) - --- | Will this target result in an object file on the disk? -isObjectTarget :: HscTarget -> Bool -isObjectTarget HscC = True -isObjectTarget HscAsm = True -isObjectTarget HscLlvm = True -isObjectTarget _ = False - --- | Does this target retain *all* top-level bindings for a module, --- rather than just the exported bindings, in the TypeEnv and compiled --- code (if any)? In interpreted mode we do this, so that GHCi can --- call functions inside a module. In HscNothing mode we also do it, --- so that Haddock can get access to the GlobalRdrEnv for a module --- after typechecking it. -targetRetainsAllBindings :: HscTarget -> Bool -targetRetainsAllBindings HscInterpreted = True -targetRetainsAllBindings HscNothing = True -targetRetainsAllBindings _ = False - --- | The 'GhcMode' tells us whether we're doing multi-module --- compilation (controlled via the "GHC" API) or one-shot --- (single-module) compilation. This makes a difference primarily to --- the "Finder": in one-shot mode we look for interface files for --- imported modules, but in multi-module mode we look for source files --- in order to check whether they need to be recompiled. -data GhcMode - = CompManager -- ^ @\-\-make@, GHCi, etc. - | OneShot -- ^ @ghc -c Foo.hs@ - | MkDepend -- ^ @ghc -M@, see "Finder" for why we need this - deriving Eq - -instance Outputable GhcMode where - ppr CompManager = text "CompManager" - ppr OneShot = text "OneShot" - ppr MkDepend = text "MkDepend" - -isOneShot :: GhcMode -> Bool -isOneShot OneShot = True -isOneShot _other = False - --- | What to do in the link step, if there is one. -data GhcLink - = NoLink -- ^ Don't link at all - | LinkBinary -- ^ Link object code into a binary - | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both - -- bytecode and object code). - | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) - | LinkStaticLib -- ^ Link objects into a static lib - deriving (Eq, Show) - -isNoLink :: GhcLink -> Bool -isNoLink NoLink = True -isNoLink _ = False - --- | We accept flags which make packages visible, but how they select --- the package varies; this data type reflects what selection criterion --- is used. -data PackageArg = - PackageArg String -- ^ @-package@, by 'PackageName' - | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' - deriving (Eq, Show) -instance Outputable PackageArg where - ppr (PackageArg pn) = text "package" <+> text pn - ppr (UnitIdArg uid) = text "unit" <+> ppr uid - --- | Represents the renaming that may be associated with an exposed --- package, e.g. the @rns@ part of @-package "foo (rns)"@. --- --- Here are some example parsings of the package flags (where --- a string literal is punned to be a 'ModuleName': --- --- * @-package foo@ is @ModRenaming True []@ --- * @-package foo ()@ is @ModRenaming False []@ --- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ --- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ --- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ -data ModRenaming = ModRenaming { - modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? - modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope - -- under name @n@. - } deriving (Eq) -instance Outputable ModRenaming where - ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) - --- | Flags for manipulating the set of non-broken packages. -newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ - deriving (Eq) - --- | Flags for manipulating package trust. -data TrustFlag - = TrustPackage String -- ^ @-trust@ - | DistrustPackage String -- ^ @-distrust@ - deriving (Eq) - --- | Flags for manipulating packages visibility. -data PackageFlag - = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ - | HidePackage String -- ^ @-hide-package@ - deriving (Eq) -- NB: equality instance is used by packageFlagsChanged - -data PackageDBFlag - = PackageDB PkgConfRef - | NoUserPackageDB - | NoGlobalPackageDB - | ClearPackageDBs - deriving (Eq) - -packageFlagsChanged :: DynFlags -> DynFlags -> Bool -packageFlagsChanged idflags1 idflags0 = - packageFlags idflags1 /= packageFlags idflags0 || - ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || - pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || - trustFlags idflags1 /= trustFlags idflags0 || - packageDBFlags idflags1 /= packageDBFlags idflags0 || - packageGFlags idflags1 /= packageGFlags idflags0 - where - packageGFlags dflags = map (`gopt` dflags) - [ Opt_HideAllPackages - , Opt_HideAllPluginPackages - , Opt_AutoLinkPackages ] - -instance Outputable PackageFlag where - ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) - ppr (HidePackage str) = text "-hide-package" <+> text str - --- | The 'HscTarget' value corresponding to the default way to create --- object files on the current platform. - -defaultHscTarget :: Platform -> PlatformMisc -> HscTarget -defaultHscTarget platform pMisc - | platformUnregisterised platform = HscC - | platformMisc_ghcWithNativeCodeGen pMisc = HscAsm - | otherwise = HscLlvm - -defaultObjectTarget :: DynFlags -> HscTarget -defaultObjectTarget dflags = defaultHscTarget - (targetPlatform dflags) - (platformMisc dflags) - -data DynLibLoader - = Deployable - | SystemDependent - deriving Eq - -data RtsOptsEnabled - = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly - | RtsOptsAll - deriving (Show) - -shouldUseColor :: DynFlags -> Bool -shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags) - -shouldUseHexWordLiterals :: DynFlags -> Bool -shouldUseHexWordLiterals dflags = - Opt_HexWordLiterals `EnumSet.member` generalFlags dflags - --- | Are we building with @-fPIE@ or @-fPIC@ enabled? -positionIndependent :: DynFlags -> Bool -positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags - ------------------------------------------------------------------------------ --- 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+threaded. - --- 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. - -data Way - = WayCustom String -- for GHC API clients building custom variants - | WayThreaded - | WayDebug - | WayProf - | WayEventLog - | WayDyn - deriving (Eq, Ord, Show) - -allowed_combination :: [Way] -> Bool -allowed_combination way = and [ x `allowedWith` y - | x <- way, y <- way, x < y ] - where - -- Note ordering in these tests: the left argument is - -- <= the right argument, according to the Ord instance - -- on Way above. - - -- dyn is allowed with everything - _ `allowedWith` WayDyn = True - WayDyn `allowedWith` _ = True - - -- debug is allowed with everything - _ `allowedWith` WayDebug = True - WayDebug `allowedWith` _ = True - - (WayCustom {}) `allowedWith` _ = True - WayThreaded `allowedWith` WayProf = True - WayThreaded `allowedWith` WayEventLog = True - WayProf `allowedWith` WayEventLog = True - _ `allowedWith` _ = False - -mkBuildTag :: [Way] -> String -mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) - -wayTag :: Way -> String -wayTag (WayCustom xs) = xs -wayTag WayThreaded = "thr" -wayTag WayDebug = "debug" -wayTag WayDyn = "dyn" -wayTag WayProf = "p" -wayTag WayEventLog = "l" - -wayRTSOnly :: Way -> Bool -wayRTSOnly (WayCustom {}) = False -wayRTSOnly WayThreaded = True -wayRTSOnly WayDebug = True -wayRTSOnly WayDyn = False -wayRTSOnly WayProf = False -wayRTSOnly WayEventLog = True - -wayDesc :: Way -> String -wayDesc (WayCustom xs) = xs -wayDesc WayThreaded = "Threaded" -wayDesc WayDebug = "Debug" -wayDesc WayDyn = "Dynamic" -wayDesc WayProf = "Profiling" -wayDesc WayEventLog = "RTS Event Logging" - --- Turn these flags on when enabling this way -wayGeneralFlags :: Platform -> Way -> [GeneralFlag] -wayGeneralFlags _ (WayCustom {}) = [] -wayGeneralFlags _ WayThreaded = [] -wayGeneralFlags _ WayDebug = [] -wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] - -- We could get away without adding -fPIC when compiling the - -- modules of a program that is to be linked with -dynamic; the - -- program itself does not need to be position-independent, only - -- the libraries need to be. HOWEVER, GHCi links objects into a - -- .so before loading the .so using the system linker. Since only - -- PIC objects can be linked into a .so, we have to compile even - -- modules of the main program with -fPIC when using -dynamic. -wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] -wayGeneralFlags _ WayEventLog = [] - --- Turn these flags off when enabling this way -wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] -wayUnsetGeneralFlags _ (WayCustom {}) = [] -wayUnsetGeneralFlags _ WayThreaded = [] -wayUnsetGeneralFlags _ WayDebug = [] -wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting - -- when we're going to be dynamically - -- linking. Plus it breaks compilation - -- on OSX x86. - Opt_SplitSections] -wayUnsetGeneralFlags _ WayProf = [] -wayUnsetGeneralFlags _ WayEventLog = [] - -wayOptc :: Platform -> Way -> [String] -wayOptc _ (WayCustom {}) = [] -wayOptc platform WayThreaded = case platformOS platform of - OSOpenBSD -> ["-pthread"] - OSNetBSD -> ["-pthread"] - _ -> [] -wayOptc _ WayDebug = [] -wayOptc _ WayDyn = [] -wayOptc _ WayProf = ["-DPROFILING"] -wayOptc _ WayEventLog = ["-DTRACING"] - -wayOptl :: Platform -> Way -> [String] -wayOptl _ (WayCustom {}) = [] -wayOptl platform WayThreaded = - case platformOS platform of - -- N.B. FreeBSD cc throws a warning if we pass -pthread without - -- actually using any pthread symbols. - OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] - OSOpenBSD -> ["-pthread"] - OSNetBSD -> ["-pthread"] - _ -> [] -wayOptl _ WayDebug = [] -wayOptl _ WayDyn = [] -wayOptl _ WayProf = [] -wayOptl _ WayEventLog = [] - -wayOptP :: Platform -> Way -> [String] -wayOptP _ (WayCustom {}) = [] -wayOptP _ WayThreaded = [] -wayOptP _ WayDebug = [] -wayOptP _ WayDyn = [] -wayOptP _ WayProf = ["-DPROFILING"] -wayOptP _ WayEventLog = ["-DTRACING"] - -whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () -whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) - -ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a -ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g - -whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () -whenCannotGenerateDynamicToo dflags f - = ifCannotGenerateDynamicToo dflags f (return ()) - -ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a -ifCannotGenerateDynamicToo dflags f g - = generateDynamicTooConditional dflags g f g - -generateDynamicTooConditional :: MonadIO m - => DynFlags -> m a -> m a -> m a -> m a -generateDynamicTooConditional dflags canGen cannotGen notTryingToGen - = if gopt Opt_BuildDynamicToo dflags - then do let ref = canGenerateDynamicToo dflags - b <- liftIO $ readIORef ref - if b then canGen else cannotGen - else notTryingToGen - -dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags -dynamicTooMkDynamicDynFlags dflags0 - = let dflags1 = addWay' WayDyn dflags0 - dflags2 = dflags1 { - outputFile = dynOutputFile dflags1, - hiSuf = dynHiSuf dflags1, - objectSuf = dynObjectSuf dflags1 - } - dflags3 = updateWays dflags2 - dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo - in dflags4 - --- | Compute the path of the dynamic object corresponding to an object file. -dynamicOutputFile :: DynFlags -> FilePath -> FilePath -dynamicOutputFile dflags outputFile = dynOut outputFile - where - dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension - ------------------------------------------------------------------------------ - --- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value -initDynFlags :: DynFlags -> IO DynFlags -initDynFlags dflags = do - let -- We can't build with dynamic-too on Windows, as labels before - -- the fork point are different depending on whether we are - -- building dynamically or not. - platformCanGenerateDynamicToo - = platformOS (targetPlatform dflags) /= OSMinGW32 - refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo - refNextTempSuffix <- newIORef 0 - refFilesToClean <- newIORef emptyFilesToClean - refDirsToClean <- newIORef Map.empty - refGeneratedDumps <- newIORef Set.empty - refRtldInfo <- newIORef Nothing - refRtccInfo <- newIORef Nothing - wrapperNum <- newIORef emptyModuleEnv - canUseUnicode <- do let enc = localeEncoding - str = "‘’" - (withCString enc str $ \cstr -> - do str' <- peekCString enc cstr - return (str == str')) - `catchIOError` \_ -> return False - maybeGhcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" - let adjustNoUnicode (Just _) = False - adjustNoUnicode Nothing = True - let useUnicode' = (adjustNoUnicode maybeGhcNoUnicodeEnv) && canUseUnicode - canUseColor <- stderrSupportsAnsiColors - maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" - maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" - let adjustCols (Just env) = Col.parseScheme env - adjustCols Nothing = id - let (useColor', colScheme') = - (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) - (useColor dflags, colScheme dflags) - return dflags{ - canGenerateDynamicToo = refCanGenerateDynamicToo, - nextTempSuffix = refNextTempSuffix, - filesToClean = refFilesToClean, - dirsToClean = refDirsToClean, - generatedDumps = refGeneratedDumps, - nextWrapperNum = wrapperNum, - useUnicode = useUnicode', - useColor = useColor', - canUseColor = canUseColor, - colScheme = colScheme', - rtldInfo = refRtldInfo, - rtccInfo = refRtccInfo - } - --- | The normal 'DynFlags'. Note that they are not suitable for use in this form --- and must be fully initialized by 'GHC.runGhc' first. -defaultDynFlags :: Settings -> LlvmConfig -> DynFlags -defaultDynFlags mySettings llvmConfig = --- See Note [Updating flag description in the User's Guide] - DynFlags { - ghcMode = CompManager, - ghcLink = LinkBinary, - hscTarget = defaultHscTarget (sTargetPlatform mySettings) (sPlatformMisc mySettings), - integerLibrary = sIntegerLibraryType mySettings, - verbosity = 0, - optLevel = 0, - debugLevel = 0, - simplPhases = 2, - maxSimplIterations = 4, - ruleCheck = Nothing, - inlineCheck = Nothing, - binBlobThreshold = 500000, -- 500K is a good default (see #16190) - maxRelevantBinds = Just 6, - maxValidHoleFits = Just 6, - maxRefHoleFits = Just 6, - refLevelHoleFits = Nothing, - maxUncoveredPatterns = 4, - maxPmCheckModels = 100, - simplTickFactor = 100, - specConstrThreshold = Just 2000, - specConstrCount = Just 3, - specConstrRecursive = 3, - liberateCaseThreshold = Just 2000, - floatLamArgs = Just 0, -- Default: float only if no fvs - liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 - liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 - liftLamsKnown = False, -- Default: don't turn known calls into unknown ones - cmmProcAlignment = Nothing, - - historySize = 20, - strictnessBefore = [], - - parMakeCount = Just 1, - - enableTimeStats = False, - ghcHeapSize = Nothing, - - importPaths = ["."], - mainModIs = mAIN, - mainFunIs = Nothing, - reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, - solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, - - thisInstalledUnitId = toInstalledUnitId mainUnitId, - thisUnitIdInsts_ = Nothing, - thisComponentId_ = Nothing, - - objectDir = Nothing, - dylibInstallName = Nothing, - hiDir = Nothing, - hieDir = Nothing, - stubDir = Nothing, - dumpDir = Nothing, - - objectSuf = phaseInputExt StopLn, - hcSuf = phaseInputExt HCc, - hiSuf = "hi", - hieSuf = "hie", - - canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", - dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, - dynHiSuf = "dyn_hi", - - pluginModNames = [], - pluginModNameOpts = [], - frontendPluginOpts = [], - cachedPlugins = [], - staticPlugins = [], - hooks = emptyHooks, - - outputFile = Nothing, - dynOutputFile = Nothing, - outputHi = Nothing, - dynLibLoader = SystemDependent, - dumpPrefix = Nothing, - dumpPrefixForce = Nothing, - ldInputs = [], - includePaths = IncludeSpecs [] [], - libraryPaths = [], - frameworkPaths = [], - cmdlineFrameworks = [], - rtsOpts = Nothing, - rtsOptsEnabled = RtsOptsSafeOnly, - rtsOptsSuggestions = True, - - hpcDir = ".hpc", - - packageDBFlags = [], - packageFlags = [], - pluginPackageFlags = [], - ignorePackageFlags = [], - trustFlags = [], - packageEnv = Nothing, - pkgDatabase = Nothing, - -- This gets filled in with GHC.setSessionDynFlags - pkgState = emptyPackageState, - ways = defaultWays mySettings, - buildTag = mkBuildTag (defaultWays mySettings), - splitInfo = Nothing, - - ghcNameVersion = sGhcNameVersion mySettings, - fileSettings = sFileSettings mySettings, - toolSettings = sToolSettings mySettings, - targetPlatform = sTargetPlatform mySettings, - platformMisc = sPlatformMisc mySettings, - platformConstants = sPlatformConstants mySettings, - rawSettings = sRawSettings mySettings, - - -- See Note [LLVM configuration]. - llvmConfig = llvmConfig, - - -- ghc -M values - depMakefile = "Makefile", - depIncludePkgDeps = False, - depIncludeCppDeps = False, - depExcludeMods = [], - depSuffixes = [], - -- end of ghc -M values - nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", - filesToClean = panic "defaultDynFlags: No filesToClean", - dirsToClean = panic "defaultDynFlags: No dirsToClean", - generatedDumps = panic "defaultDynFlags: No generatedDumps", - ghcVersionFile = Nothing, - haddockOptions = Nothing, - dumpFlags = EnumSet.empty, - generalFlags = EnumSet.fromList (defaultFlags mySettings), - warningFlags = EnumSet.fromList standardWarnings, - fatalWarningFlags = EnumSet.empty, - ghciScripts = [], - language = Nothing, - safeHaskell = Sf_None, - safeInfer = True, - safeInferred = True, - thOnLoc = noSrcSpan, - newDerivOnLoc = noSrcSpan, - overlapInstLoc = noSrcSpan, - incoherentOnLoc = noSrcSpan, - pkgTrustOnLoc = noSrcSpan, - warnSafeOnLoc = noSrcSpan, - warnUnsafeOnLoc = noSrcSpan, - trustworthyOnLoc = noSrcSpan, - extensions = [], - extensionFlags = flattenExtensionFlags Nothing [], - - -- The ufCreationThreshold threshold must be reasonably high to - -- take account of possible discounts. - -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline - -- into Csg.calc (The unfolding for sqr never makes it into the - -- interface file.) - ufCreationThreshold = 750, - ufUseThreshold = 60, - ufFunAppDiscount = 60, - -- Be fairly keen to inline a function if that means - -- we'll be able to pick the right method from a dictionary - ufDictDiscount = 30, - ufKeenessFactor = 1.5, - ufDearOp = 40, - ufVeryAggressive = False, - - maxWorkerArgs = 10, - - ghciHistSize = 50, -- keep a log of length 50 by default - - -- Logging - - log_action = defaultLogAction, - - flushOut = defaultFlushOut, - flushErr = defaultFlushErr, - pprUserLength = 5, - pprCols = 100, - useUnicode = False, - useColor = Auto, - canUseColor = False, - colScheme = Col.defaultScheme, - profAuto = NoProfAuto, - interactivePrint = Nothing, - nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", - sseVersion = Nothing, - bmiVersion = Nothing, - avx = False, - avx2 = False, - avx512cd = False, - avx512er = False, - avx512f = False, - avx512pf = False, - rtldInfo = panic "defaultDynFlags: no rtldInfo", - rtccInfo = panic "defaultDynFlags: no rtccInfo", - - maxInlineAllocSize = 128, - maxInlineMemcpyInsns = 32, - maxInlineMemsetInsns = 32, - - initialUnique = 0, - uniqueIncrement = 1, - - reverseErrors = False, - maxErrors = Nothing, - cfgWeightInfo = defaultCfgWeights - } - -defaultWays :: Settings -> [Way] -defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) - then [WayDyn] - else [] - -interpWays :: [Way] -interpWays - | dynamicGhc = [WayDyn] - | rtsIsProfiled = [WayProf] - | otherwise = [] - -interpreterProfiled :: DynFlags -> Bool -interpreterProfiled dflags - | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags - | otherwise = rtsIsProfiled - -interpreterDynamic :: DynFlags -> Bool -interpreterDynamic dflags - | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags - | otherwise = dynamicGhc - --------------------------------------------------------------------------- --- --- Note [JSON Error Messages] --- --- When the user requests the compiler output to be dumped as json --- we used to collect them all in an IORef and then print them at the end. --- This doesn't work very well with GHCi. (See #14078) So instead we now --- use the simpler method of just outputting a JSON document inplace to --- stdout. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. - -type FatalMessager = String -> IO () - -type LogAction = DynFlags - -> WarnReason - -> Severity - -> SrcSpan - -> PprStyle - -> MsgDoc - -> IO () - -defaultFatalMessager :: FatalMessager -defaultFatalMessager = hPutStrLn stderr - - --- See Note [JSON Error Messages] --- -jsonLogAction :: LogAction -jsonLogAction dflags reason severity srcSpan _style msg - = do - defaultLogActionHPutStrDoc dflags stdout (doc $$ text "") - (mkCodeStyle CStyle) - where - doc = renderJSON $ - JSObject [ ( "span", json srcSpan ) - , ( "doc" , JSString (showSDoc dflags msg) ) - , ( "severity", json severity ) - , ( "reason" , json reason ) - ] - - -defaultLogAction :: LogAction -defaultLogAction dflags reason severity srcSpan style msg - = case severity of - SevOutput -> printOut msg style - SevDump -> printOut (msg $$ blankLine) style - SevInteractive -> putStrSDoc msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - SevWarning -> printWarns - SevError -> printWarns - where - printOut = defaultLogActionHPrintDoc dflags stdout - printErrs = defaultLogActionHPrintDoc dflags stderr - putStrSDoc = defaultLogActionHPutStrDoc dflags stdout - -- Pretty print the warning flag, if any (#10752) - message = mkLocMessageAnn flagMsg severity srcSpan msg - - printWarns = do - hPutChar stderr '\n' - caretDiagnostic <- - if gopt Opt_DiagnosticsShowCaret dflags - then getCaretDiagnostic severity srcSpan - else pure empty - printErrs (message $+$ caretDiagnostic) - (setStyleColoured True style) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. - - flagMsg = - case reason of - NoReason -> Nothing - Reason wflag -> do - spec <- flagSpecOf wflag - return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) - ErrReason Nothing -> - return "-Werror" - ErrReason (Just wflag) -> do - spec <- flagSpecOf wflag - return $ - "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ - ", -Werror=" ++ flagSpecName spec - - warnFlagGrp flag - | gopt Opt_ShowWarnGroups dflags = - case smallestGroups flag of - [] -> "" - groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" - | otherwise = "" - --- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. -defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () -defaultLogActionHPrintDoc dflags h d sty - = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty - -defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () -defaultLogActionHPutStrDoc dflags h d sty - -- Don't add a newline at the end, so that successive - -- calls to this log-action can output all on the same line - = printSDoc Pretty.PageMode dflags h sty d - -newtype FlushOut = FlushOut (IO ()) - -defaultFlushOut :: FlushOut -defaultFlushOut = FlushOut $ hFlush stdout - -newtype FlushErr = FlushErr (IO ()) - -defaultFlushErr :: FlushErr -defaultFlushErr = FlushErr $ hFlush stderr - -{- -Note [Verbosity levels] -~~~~~~~~~~~~~~~~~~~~~~~ - 0 | print errors & warnings only - 1 | minimal verbosity: print "compiling M ... done." for each module. - 2 | equivalent to -dshow-passes - 3 | equivalent to existing "ghc -v" - 4 | "ghc -v -ddump-most" - 5 | "ghc -v -ddump-all" --} - -data OnOff a = On a - | Off a - deriving (Eq, Show) - -instance Outputable a => Outputable (OnOff a) where - ppr (On x) = text "On" <+> ppr x - ppr (Off x) = text "Off" <+> ppr x - --- OnOffs accumulate in reverse order, so we use foldr in order to --- process them in the right order -flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension -flattenExtensionFlags ml = foldr f defaultExtensionFlags - where f (On f) flags = EnumSet.insert f flags - f (Off f) flags = EnumSet.delete f flags - defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) - --- | The language extensions implied by the various language variants. --- When updating this be sure to update the flag documentation in --- @docs/users-guide/glasgow_exts.rst@. -languageExtensions :: Maybe Language -> [LangExt.Extension] - -languageExtensions Nothing - -- Nothing => the default case - = LangExt.NondecreasingIndentation -- This has been on by default for some time - : delete LangExt.DatatypeContexts -- The Haskell' committee decided to - -- remove datatype contexts from the - -- language: - -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html - (languageExtensions (Just Haskell2010)) - - -- NB: MonoPatBinds is no longer the default - -languageExtensions (Just Haskell98) - = [LangExt.ImplicitPrelude, - -- See Note [When is StarIsType enabled] - LangExt.StarIsType, - LangExt.CUSKs, - LangExt.MonomorphismRestriction, - LangExt.NPlusKPatterns, - LangExt.DatatypeContexts, - LangExt.TraditionalRecordSyntax, - LangExt.NondecreasingIndentation - -- strictly speaking non-standard, but we always had this - -- on implicitly before the option was added in 7.1, and - -- turning it off breaks code, so we're keeping it on for - -- backwards compatibility. Cabal uses -XHaskell98 by - -- default unless you specify another language. - ] - -languageExtensions (Just Haskell2010) - = [LangExt.ImplicitPrelude, - -- See Note [When is StarIsType enabled] - LangExt.StarIsType, - LangExt.CUSKs, - LangExt.MonomorphismRestriction, - LangExt.DatatypeContexts, - LangExt.TraditionalRecordSyntax, - LangExt.EmptyDataDecls, - LangExt.ForeignFunctionInterface, - LangExt.PatternGuards, - LangExt.DoAndIfThenElse, - LangExt.RelaxedPolyRec] - -hasPprDebug :: DynFlags -> Bool -hasPprDebug = dopt Opt_D_ppr_debug - -hasNoDebugOutput :: DynFlags -> Bool -hasNoDebugOutput = dopt Opt_D_no_debug_output - -hasNoStateHack :: DynFlags -> Bool -hasNoStateHack = gopt Opt_G_NoStateHack - -hasNoOptCoercion :: DynFlags -> Bool -hasNoOptCoercion = gopt Opt_G_NoOptCoercion - - --- | Test whether a 'DumpFlag' is set -dopt :: DumpFlag -> DynFlags -> Bool -dopt f dflags = (f `EnumSet.member` dumpFlags dflags) - || (verbosity dflags >= 4 && enableIfVerbose f) - where enableIfVerbose Opt_D_dump_tc_trace = False - enableIfVerbose Opt_D_dump_rn_trace = False - enableIfVerbose Opt_D_dump_cs_trace = False - enableIfVerbose Opt_D_dump_if_trace = False - enableIfVerbose Opt_D_dump_vt_trace = False - enableIfVerbose Opt_D_dump_tc = False - enableIfVerbose Opt_D_dump_rn = False - enableIfVerbose Opt_D_dump_rn_stats = False - enableIfVerbose Opt_D_dump_hi_diffs = False - enableIfVerbose Opt_D_verbose_core2core = False - enableIfVerbose Opt_D_verbose_stg2stg = False - enableIfVerbose Opt_D_dump_splices = False - enableIfVerbose Opt_D_th_dec_file = False - enableIfVerbose Opt_D_dump_rule_firings = False - enableIfVerbose Opt_D_dump_rule_rewrites = False - enableIfVerbose Opt_D_dump_simpl_trace = False - enableIfVerbose Opt_D_dump_rtti = False - enableIfVerbose Opt_D_dump_inlinings = False - enableIfVerbose Opt_D_dump_core_stats = False - enableIfVerbose Opt_D_dump_asm_stats = False - enableIfVerbose Opt_D_dump_types = False - enableIfVerbose Opt_D_dump_simpl_iterations = False - enableIfVerbose Opt_D_dump_ticked = False - enableIfVerbose Opt_D_dump_view_pattern_commoning = False - enableIfVerbose Opt_D_dump_mod_cycles = False - enableIfVerbose Opt_D_dump_mod_map = False - enableIfVerbose Opt_D_dump_ec_trace = False - enableIfVerbose _ = True - --- | Set a 'DumpFlag' -dopt_set :: DynFlags -> DumpFlag -> DynFlags -dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } - --- | Unset a 'DumpFlag' -dopt_unset :: DynFlags -> DumpFlag -> DynFlags -dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } - --- | Test whether a 'GeneralFlag' is set -gopt :: GeneralFlag -> DynFlags -> Bool -gopt f dflags = f `EnumSet.member` generalFlags dflags - --- | Set a 'GeneralFlag' -gopt_set :: DynFlags -> GeneralFlag -> DynFlags -gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } - --- | Unset a 'GeneralFlag' -gopt_unset :: DynFlags -> GeneralFlag -> DynFlags -gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } - --- | Test whether a 'WarningFlag' is set -wopt :: WarningFlag -> DynFlags -> Bool -wopt f dflags = f `EnumSet.member` warningFlags dflags - --- | Set a 'WarningFlag' -wopt_set :: DynFlags -> WarningFlag -> DynFlags -wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } - --- | Unset a 'WarningFlag' -wopt_unset :: DynFlags -> WarningFlag -> DynFlags -wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } - --- | Test whether a 'WarningFlag' is set as fatal -wopt_fatal :: WarningFlag -> DynFlags -> Bool -wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags - --- | Mark a 'WarningFlag' as fatal (do not set the flag) -wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_set_fatal dfs f - = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } - --- | Mark a 'WarningFlag' as not fatal -wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_unset_fatal dfs f - = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } - --- | Test whether a 'LangExt.Extension' is set -xopt :: LangExt.Extension -> DynFlags -> Bool -xopt f dflags = f `EnumSet.member` extensionFlags dflags - --- | Set a 'LangExt.Extension' -xopt_set :: DynFlags -> LangExt.Extension -> DynFlags -xopt_set dfs f - = let onoffs = On f : extensions dfs - in dfs { extensions = onoffs, - extensionFlags = flattenExtensionFlags (language dfs) onoffs } - --- | Unset a 'LangExt.Extension' -xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags -xopt_unset dfs f - = let onoffs = Off f : extensions dfs - in dfs { extensions = onoffs, - extensionFlags = flattenExtensionFlags (language dfs) onoffs } - --- | Set or unset a 'LangExt.Extension', unless it has been explicitly --- set or unset before. -xopt_set_unlessExplSpec - :: LangExt.Extension - -> (DynFlags -> LangExt.Extension -> DynFlags) - -> DynFlags -> DynFlags -xopt_set_unlessExplSpec ext setUnset dflags = - let referedExts = stripOnOff <$> extensions dflags - stripOnOff (On x) = x - stripOnOff (Off x) = x - in - if ext `elem` referedExts then dflags else setUnset dflags ext - -lang_set :: DynFlags -> Maybe Language -> DynFlags -lang_set dflags lang = - dflags { - language = lang, - extensionFlags = flattenExtensionFlags lang (extensions dflags) - } - --- | An internal helper to check whether to use unicode syntax for output. --- --- Note: You should very likely be using 'Outputable.unicodeSyntax' instead --- of this function. -useUnicodeSyntax :: DynFlags -> Bool -useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax - -useStarIsType :: DynFlags -> Bool -useStarIsType = xopt LangExt.StarIsType - --- | Set the Haskell language standard to use -setLanguage :: Language -> DynP () -setLanguage l = upd (`lang_set` Just l) - --- | Some modules have dependencies on others through the DynFlags rather than textual imports -dynFlagDependencies :: DynFlags -> [ModuleName] -dynFlagDependencies = pluginModNames - --- | Is the -fpackage-trust mode on -packageTrustOn :: DynFlags -> Bool -packageTrustOn = gopt Opt_PackageTrust - --- | Is Safe Haskell on in some way (including inference mode) -safeHaskellOn :: DynFlags -> Bool -safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags - -safeHaskellModeEnabled :: DynFlags -> Bool -safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy - , Sf_Safe ] - - --- | Is the Safe Haskell safe language in use -safeLanguageOn :: DynFlags -> Bool -safeLanguageOn dflags = safeHaskell dflags == Sf_Safe - --- | Is the Safe Haskell safe inference mode active -safeInferOn :: DynFlags -> Bool -safeInferOn = safeInfer - --- | Test if Safe Imports are on in some form -safeImportsOn :: DynFlags -> Bool -safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || - safeHaskell dflags == Sf_Trustworthy || - safeHaskell dflags == Sf_Safe - --- | Set a 'Safe Haskell' flag -setSafeHaskell :: SafeHaskellMode -> DynP () -setSafeHaskell s = updM f - where f dfs = do - let sf = safeHaskell dfs - safeM <- combineSafeFlags sf s - case s of - Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } - -- leave safe inferrence on in Trustworthy mode so we can warn - -- if it could have been inferred safe. - Sf_Trustworthy -> do - l <- getCurLoc - return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } - -- leave safe inference on in Unsafe mode as well. - _ -> return $ dfs { safeHaskell = safeM } - --- | Are all direct imports required to be safe for this Safe Haskell mode? --- Direct imports are when the code explicitly imports a module -safeDirectImpsReq :: DynFlags -> Bool -safeDirectImpsReq d = safeLanguageOn d - --- | Are all implicit imports required to be safe for this Safe Haskell mode? --- Implicit imports are things in the prelude. e.g System.IO when print is used. -safeImplicitImpsReq :: DynFlags -> Bool -safeImplicitImpsReq d = safeLanguageOn d - --- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. --- This makes Safe Haskell very much a monoid but for now I prefer this as I don't --- want to export this functionality from the module but do want to export the --- type constructors. -combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode -combineSafeFlags a b | a == Sf_None = return b - | b == Sf_None = return a - | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore - | a == b = return a - | otherwise = addErr errm >> pure a - where errm = "Incompatible Safe Haskell flags! (" - ++ show a ++ ", " ++ show b ++ ")" - --- | A list of unsafe flags under Safe Haskell. Tuple elements are: --- * name of the flag --- * function to get srcspan that enabled the flag --- * function to test if the flag is on --- * function to turn the flag off -unsafeFlags, unsafeFlagsForInfer - :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] -unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, - xopt LangExt.GeneralizedNewtypeDeriving, - flip xopt_unset LangExt.GeneralizedNewtypeDeriving) - , ("-XTemplateHaskell", thOnLoc, - xopt LangExt.TemplateHaskell, - flip xopt_unset LangExt.TemplateHaskell) - ] -unsafeFlagsForInfer = unsafeFlags - - --- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order -getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from - -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors - -> [a] -- ^ Correctly ordered extracted options -getOpts dflags opts = reverse (opts dflags) - -- We add to the options from the front, so we need to reverse the list - --- | Gets the verbosity flag for the current verbosity level. This is fed to --- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlags :: DynFlags -> [String] -getVerbFlags dflags - | verbosity dflags >= 4 = ["-v"] - | otherwise = [] - -setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, - setDynObjectSuf, setDynHiSuf, - setDylibInstallName, - setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, - setPgmP, addOptl, addOptc, addOptcxx, addOptP, - addCmdlineFramework, addHaddockOpts, addGhciScript, - setInteractivePrint - :: String -> DynFlags -> DynFlags -setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce - :: Maybe String -> DynFlags -> DynFlags - -setObjectDir f d = d { objectDir = Just f} -setHiDir f d = d { hiDir = Just f} -setHieDir f d = d { hieDir = Just f} -setStubDir f d = d { stubDir = Just f - , includePaths = addGlobalInclude (includePaths d) [f] } - -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling via C (i.e. unregisterised - -- builds). -setDumpDir f d = d { dumpDir = Just f} -setOutputDir f = setObjectDir f - . setHieDir f - . setHiDir f - . setStubDir f - . setDumpDir f -setDylibInstallName f d = d { dylibInstallName = Just f} - -setObjectSuf f d = d { objectSuf = f} -setDynObjectSuf f d = d { dynObjectSuf = f} -setHiSuf f d = d { hiSuf = f} -setHieSuf f d = d { hieSuf = f} -setDynHiSuf f d = d { dynHiSuf = f} -setHcSuf f d = d { hcSuf = f} - -setOutputFile f d = d { outputFile = f} -setDynOutputFile f d = d { dynOutputFile = f} -setOutputHi f d = d { outputHi = f} - -setJsonLogAction :: DynFlags -> DynFlags -setJsonLogAction d = d { log_action = jsonLogAction } - -thisComponentId :: DynFlags -> ComponentId -thisComponentId dflags = - case thisComponentId_ dflags of - Just cid -> cid - Nothing -> - case thisUnitIdInsts_ dflags of - Just _ -> - throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") - Nothing -> ComponentId (unitIdFS (thisPackage dflags)) - -thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] -thisUnitIdInsts dflags = - case thisUnitIdInsts_ dflags of - Just insts -> insts - Nothing -> [] - -thisPackage :: DynFlags -> UnitId -thisPackage dflags = - case thisUnitIdInsts_ dflags of - Nothing -> default_uid - Just insts - | all (\(x,y) -> mkHoleModule x == y) insts - -> newUnitId (thisComponentId dflags) insts - | otherwise - -> default_uid - where - default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags)) - -parseUnitIdInsts :: String -> [(ModuleName, Module)] -parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of - [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) - where parse = sepBy parseEntry (R.char ',') - parseEntry = do - n <- parseModuleName - _ <- R.char '=' - m <- parseModuleId - return (n, m) - -setUnitIdInsts :: String -> DynFlags -> DynFlags -setUnitIdInsts s d = - d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) } - -setComponentId :: String -> DynFlags -> DynFlags -setComponentId s d = - d { thisComponentId_ = Just (ComponentId (fsLit s)) } - -addPluginModuleName :: String -> DynFlags -> DynFlags -addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } - -clearPluginModuleNames :: DynFlags -> DynFlags -clearPluginModuleNames d = - d { pluginModNames = [] - , pluginModNameOpts = [] - , cachedPlugins = [] } - -addPluginModuleNameOption :: String -> DynFlags -> DynFlags -addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } - where (m, rest) = break (== ':') optflag - option = case rest of - [] -> "" -- should probably signal an error - (_:plug_opt) -> plug_opt -- ignore the ':' from break - -addFrontendPluginOption :: String -> DynFlags -> DynFlags -addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } - -parseDynLibLoaderMode f d = - case splitAt 8 f of - ("deploy", "") -> d { dynLibLoader = Deployable } - ("sysdep", "") -> d { dynLibLoader = SystemDependent } - _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) - -setDumpPrefixForce f d = d { dumpPrefixForce = f} - --- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] --- Config.hs should really use Option. -setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) - where (pgm:args) = words f -addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) -addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) -addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) -addOptP f = alterToolSettings $ \s -> s - { toolSettings_opt_P = f : toolSettings_opt_P s - , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) - } - -- See Note [Repeated -optP hashing] - where - fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - - -setDepMakefile :: FilePath -> DynFlags -> DynFlags -setDepMakefile f d = d { depMakefile = f } - -setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags -setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } - -setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags -setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } - -addDepExcludeMod :: String -> DynFlags -> DynFlags -addDepExcludeMod m d - = d { depExcludeMods = mkModuleName m : depExcludeMods d } - -addDepSuffix :: FilePath -> DynFlags -> DynFlags -addDepSuffix s d = d { depSuffixes = s : depSuffixes d } - -addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} - -addGhcVersionFile :: FilePath -> DynFlags -> DynFlags -addGhcVersionFile f d = d { ghcVersionFile = Just f } - -addHaddockOpts f d = d { haddockOptions = Just f} - -addGhciScript f d = d { ghciScripts = f : ghciScripts d} - -setInteractivePrint f d = d { interactivePrint = Just f} - ------------------------------------------------------------------------------ --- Setting the optimisation level - -updOptLevel :: Int -> DynFlags -> DynFlags --- ^ Sets the 'DynFlags' to be appropriate to the optimisation level -updOptLevel n dfs - = dfs2{ optLevel = final_n } - where - final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 - dfs1 = foldr (flip gopt_unset) dfs remove_gopts - dfs2 = foldr (flip gopt_set) dfs1 extra_gopts - - extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] - remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] - -{- ********************************************************************** -%* * - DynFlags parser -%* * -%********************************************************************* -} - --- ----------------------------------------------------------------------------- --- Parsing the dynamic flags. - - --- | Parse dynamic flags from a list of command line arguments. Returns --- the parsed 'DynFlags', the left-over arguments, and a list of warnings. --- Throws a 'UsageError' if errors occurred during parsing (such as unknown --- flags or missing arguments). -parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True - - --- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags --- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). --- Used to parse flags set in a modules pragma. -parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False - - --- | Parses the dynamically set flags for GHC. This is the most general form of --- the dynamic flag parser that the other methods simply wrap. It allows --- saying which flags are valid flags and indicating if we are parsing --- arguments from the command line or from a file pragma. -parseDynamicFlagsFull :: MonadIO m - => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against - -> Bool -- ^ are the arguments from the command line? - -> DynFlags -- ^ current dynamic flags - -> [Located String] -- ^ arguments to parse - -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlagsFull activeFlags cmdline dflags0 args = do - let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs activeFlags args) dflags0 - - -- See Note [Handling errors when parsing commandline flags] - unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ - map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs - - -- check for disabled flags in safe haskell - let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 - dflags3 = updateWays dflags2 - theWays = ways dflags3 - - unless (allowed_combination theWays) $ liftIO $ - throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ - intercalate "/" (map wayDesc theWays))) - - let chooseOutput - | isJust (outputFile dflags3) -- Only iff user specified -o ... - , not (isJust (dynOutputFile dflags3)) -- but not -dyno - = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile } - | otherwise - = return dflags3 - where - outFile = fromJust $ outputFile dflags3 - dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) - - let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 - - -- Set timer stats & heap size - when (enableTimeStats dflags5) $ liftIO enableTimingStats - case (ghcHeapSize dflags5) of - Just x -> liftIO (setHeapSize x) - _ -> return () - - liftIO $ setUnsafeGlobalDynFlags dflags5 - - let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) - - return (dflags5, leftover, warns' ++ warns) - --- | Write an error or warning to the 'LogOutput'. -putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle - -> MsgDoc -> IO () -putLogMsg dflags = log_action dflags dflags - -updateWays :: DynFlags -> DynFlags -updateWays dflags - = let theWays = sort $ nub $ ways dflags - in dflags { - ways = theWays, - buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) - } - --- | Check (and potentially disable) any extensions that aren't allowed --- in safe mode. --- --- The bool is to indicate if we are parsing command line flags (false means --- file pragma). This allows us to generate better warnings. -safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) -safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) - where - -- Handle illegal flags under safe language. - (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags - - check_method (df, warns) (str,loc,test,fix) - | test df = (fix df, warns ++ safeFailure (loc df) str) - | otherwise = (df, warns) - - safeFailure loc str - = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " - ++ str] - -safeFlagCheck cmdl dflags = - case (safeInferOn dflags) of - True | safeFlags -> (dflags', warn) - True -> (dflags' { safeInferred = False }, warn) - False -> (dflags', warn) - - where - -- dynflags and warn for when -fpackage-trust by itself with no safe - -- haskell flag - (dflags', warn) - | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags - = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) - | otherwise = (dflags, []) - - pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ - "-fpackage-trust ignored;" ++ - " must be specified with a Safe Haskell flag"] - - -- Have we inferred Unsafe? See Note [HscMain . Safe Haskell Inference] - safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer - - -{- ********************************************************************** -%* * - DynFlags specifications -%* * -%********************************************************************* -} - --- | All dynamic flags option strings without the deprecated ones. --- These are the user facing strings for enabling and disabling options. -allNonDeprecatedFlags :: [String] -allNonDeprecatedFlags = allFlagsDeps False - --- | All flags with possibility to filter deprecated ones -allFlagsDeps :: Bool -> [String] -allFlagsDeps keepDeprecated = [ '-':flagName flag - | (deprecated, flag) <- flagsAllDeps - , keepDeprecated || not (isDeprecated deprecated)] - where isDeprecated Deprecated = True - isDeprecated _ = False - -{- - - Below we export user facing symbols for GHC dynamic flags for use with the - - GHC API. - -} - --- All dynamic flags present in GHC. -flagsAll :: [Flag (CmdLineP DynFlags)] -flagsAll = map snd flagsAllDeps - --- All dynamic flags present in GHC with deprecation information. -flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] -flagsAllDeps = package_flags_deps ++ dynamic_flags_deps - - --- All dynamic flags, minus package flags, present in GHC. -flagsDynamic :: [Flag (CmdLineP DynFlags)] -flagsDynamic = map snd dynamic_flags_deps - --- ALl package flags present in GHC. -flagsPackage :: [Flag (CmdLineP DynFlags)] -flagsPackage = map snd package_flags_deps - -----------------Helpers to make flags and keep deprecation information---------- - -type FlagMaker m = String -> OptKind m -> Flag m -type DynFlagMaker = FlagMaker (CmdLineP DynFlags) -data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) - --- Make a non-deprecated flag -make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) - -> (Deprecation, Flag (CmdLineP DynFlags)) -make_ord_flag fm name kind = (NotDeprecated, fm name kind) - --- Make a deprecated flag -make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String - -> (Deprecation, Flag (CmdLineP DynFlags)) -make_dep_flag fm name kind message = (Deprecated, - fm name $ add_dep_message kind message) - -add_dep_message :: OptKind (CmdLineP DynFlags) -> String - -> OptKind (CmdLineP DynFlags) -add_dep_message (NoArg f) message = NoArg $ f >> deprecate message -add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message -add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message -add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message -add_dep_message (OptPrefix f) message = - OptPrefix $ \s -> f s >> deprecate message -add_dep_message (OptIntSuffix f) message = - OptIntSuffix $ \oi -> f oi >> deprecate message -add_dep_message (IntSuffix f) message = - IntSuffix $ \i -> f i >> deprecate message -add_dep_message (FloatSuffix f) message = - FloatSuffix $ \fl -> f fl >> deprecate message -add_dep_message (PassFlag f) message = - PassFlag $ \s -> f s >> deprecate message -add_dep_message (AnySuffix f) message = - AnySuffix $ \s -> f s >> deprecate message - ------------------------ The main flags themselves ------------------------------ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] -dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] -dynamic_flags_deps = [ - make_dep_flag defFlag "n" (NoArg $ return ()) - "The -n flag is deprecated and no longer has any effect" - , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) - , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) - , (Deprecated, defFlag "#include" - (HasArg (\_s -> - deprecate ("-#include and INCLUDE pragmas are " ++ - "deprecated: They no longer have any effect")))) - , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) - - , make_ord_flag defGhcFlag "j" (OptIntSuffix - (\n -> case n of - Just n - | n > 0 -> upd (\d -> d { parMakeCount = Just n }) - | otherwise -> addErr "Syntax: -j[n] where n > 0" - Nothing -> upd (\d -> d { parMakeCount = Nothing }))) - -- When the number of parallel builds - -- is omitted, it is the same - -- as specifing that the number of - -- parallel builds is equal to the - -- result of getNumProcessors - , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) - , make_ord_flag defFlag "this-component-id" (sepArg setComponentId) - - -- RTS options ------------------------------------------------------------- - , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> - d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) - - , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> - d { enableTimeStats = True }))) - - ------- ways --------------------------------------------------------------- - , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf)) - , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) - , make_dep_flag defGhcFlag "smp" - (NoArg $ addWay WayThreaded) "Use -threaded instead" - , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) - , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) - - , make_ord_flag defGhcFlag "ticky" - (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) - - -- -ticky enables ticky-ticky code generation, and also implies -debug which - -- is required to get the RTS ticky support. - - ----- Linker -------------------------------------------------------- - , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) - , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn)) - , make_ord_flag defGhcFlag "rdynamic" $ noArg $ -#if defined(linux_HOST_OS) - addOptl "-rdynamic" -#elif defined(mingw32_HOST_OS) - addOptl "-Wl,--export-all-symbols" -#else - -- ignored for compat w/ gcc: - id -#endif - , make_ord_flag defGhcFlag "relative-dynlib-paths" - (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) - , make_ord_flag defGhcFlag "copy-libs-when-linking" - (NoArg (setGeneralFlag Opt_SingleLibFolder)) - , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) - , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) - - ------- Specific phases -------------------------------------------- - -- need to appear before -pgmL to be parsed as LLVM flags. - , make_ord_flag defFlag "pgmlo" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } - , make_ord_flag defFlag "pgmlc" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) } - , make_ord_flag defFlag "pgmlm" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm = (f,[]) } - , make_ord_flag defFlag "pgmi" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } - , make_ord_flag defFlag "pgmL" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } - , make_ord_flag defFlag "pgmP" - (hasArg setPgmP) - , make_ord_flag defFlag "pgmF" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } - , make_ord_flag defFlag "pgmc" - $ hasArg $ \f -> alterToolSettings $ \s -> s - { toolSettings_pgm_c = f - , -- Don't pass -no-pie with -pgmc - -- (see #15319) - toolSettings_ccSupportsNoPie = False - } - , make_ord_flag defFlag "pgmc-supports-no-pie" - $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True } - , make_ord_flag defFlag "pgms" - (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) - , make_ord_flag defFlag "pgma" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } - , make_ord_flag defFlag "pgml" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_l = (f,[]) } - , make_ord_flag defFlag "pgmdll" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) } - , make_ord_flag defFlag "pgmwindres" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } - , make_ord_flag defFlag "pgmlibtool" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f } - , make_ord_flag defFlag "pgmar" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } - , make_ord_flag defFlag "pgmotool" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f} - , make_ord_flag defFlag "pgminstall_name_tool" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f} - , make_ord_flag defFlag "pgmranlib" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } - - - -- need to appear before -optl/-opta to be parsed as LLVM flags. - , make_ord_flag defFlag "optlm" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm = f : toolSettings_opt_lm s } - , make_ord_flag defFlag "optlo" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } - , make_ord_flag defFlag "optlc" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc = f : toolSettings_opt_lc s } - , make_ord_flag defFlag "opti" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } - , make_ord_flag defFlag "optL" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } - , make_ord_flag defFlag "optP" - (hasArg addOptP) - , make_ord_flag defFlag "optF" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } - , make_ord_flag defFlag "optc" - (hasArg addOptc) - , make_ord_flag defFlag "optcxx" - (hasArg addOptcxx) - , make_ord_flag defFlag "opta" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } - , make_ord_flag defFlag "optl" - (hasArg addOptl) - , make_ord_flag defFlag "optwindres" - $ hasArg $ \f -> - alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } - - , make_ord_flag defGhcFlag "split-objs" - (NoArg $ addWarn "ignoring -split-objs") - - , make_ord_flag defGhcFlag "split-sections" - (noArgM (\dflags -> do - if platformHasSubsectionsViaSymbols (targetPlatform dflags) - then do addWarn $ - "-split-sections is not useful on this platform " ++ - "since it always uses subsections via symbols. Ignoring." - return dflags - else return (gopt_set dflags Opt_SplitSections))) - - -------- ghc -M ----------------------------------------------------- - , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) - , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) - , make_ord_flag defGhcFlag "include-cpp-deps" - (noArg (setDepIncludeCppDeps True)) - , make_ord_flag defGhcFlag "include-pkg-deps" - (noArg (setDepIncludePkgDeps True)) - , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) - - -------- Linking ---------------------------------------------------- - , make_ord_flag defGhcFlag "no-link" - (noArg (\d -> d { ghcLink=NoLink })) - , make_ord_flag defGhcFlag "shared" - (noArg (\d -> d { ghcLink=LinkDynLib })) - , make_ord_flag defGhcFlag "staticlib" - (noArg (\d -> d { ghcLink=LinkStaticLib })) - , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) - , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) - - ------- Libraries --------------------------------------------------- - , make_ord_flag defFlag "L" (Prefix addLibraryPath) - , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) - - ------- Frameworks -------------------------------------------------- - -- -framework-path should really be -F ... - , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) - , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) - - ------- Output Redirection ------------------------------------------ - , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) - , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) - , make_ord_flag defGhcFlag "dyno" - (sepArg (setDynOutputFile . Just)) - , make_ord_flag defGhcFlag "ohi" - (hasArg (setOutputHi . Just )) - , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) - , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) - , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) - , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) - , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) - , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) - , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) - , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) - , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) - , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) - , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) - , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) - , make_ord_flag defGhcFlag "ddump-file-prefix" - (hasArg (setDumpPrefixForce . Just)) - - , make_ord_flag defGhcFlag "dynamic-too" - (NoArg (setGeneralFlag Opt_BuildDynamicToo)) - - ------- Keeping temporary files ------------------------------------- - -- These can be singular (think ghc -c) or plural (think ghc --make) - , make_ord_flag defGhcFlag "keep-hc-file" - (NoArg (setGeneralFlag Opt_KeepHcFiles)) - , make_ord_flag defGhcFlag "keep-hc-files" - (NoArg (setGeneralFlag Opt_KeepHcFiles)) - , make_ord_flag defGhcFlag "keep-hscpp-file" - (NoArg (setGeneralFlag Opt_KeepHscppFiles)) - , make_ord_flag defGhcFlag "keep-hscpp-files" - (NoArg (setGeneralFlag Opt_KeepHscppFiles)) - , make_ord_flag defGhcFlag "keep-s-file" - (NoArg (setGeneralFlag Opt_KeepSFiles)) - , make_ord_flag defGhcFlag "keep-s-files" - (NoArg (setGeneralFlag Opt_KeepSFiles)) - , make_ord_flag defGhcFlag "keep-llvm-file" - (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) - , make_ord_flag defGhcFlag "keep-llvm-files" - (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) - -- This only makes sense as plural - , make_ord_flag defGhcFlag "keep-tmp-files" - (NoArg (setGeneralFlag Opt_KeepTmpFiles)) - , make_ord_flag defGhcFlag "keep-hi-file" - (NoArg (setGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "no-keep-hi-file" - (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "keep-hi-files" - (NoArg (setGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "no-keep-hi-files" - (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "keep-o-file" - (NoArg (setGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "no-keep-o-file" - (NoArg (unSetGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "keep-o-files" - (NoArg (setGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "no-keep-o-files" - (NoArg (unSetGeneralFlag Opt_KeepOFiles)) - - ------- Miscellaneous ---------------------------------------------- - , make_ord_flag defGhcFlag "no-auto-link-packages" - (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) - , make_ord_flag defGhcFlag "no-hs-main" - (NoArg (setGeneralFlag Opt_NoHsMain)) - , make_ord_flag defGhcFlag "fno-state-hack" - (NoArg (setGeneralFlag Opt_G_NoStateHack)) - , make_ord_flag defGhcFlag "fno-opt-coercion" - (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) - , make_ord_flag defGhcFlag "with-rtsopts" - (HasArg setRtsOpts) - , make_ord_flag defGhcFlag "rtsopts" - (NoArg (setRtsOptsEnabled RtsOptsAll)) - , make_ord_flag defGhcFlag "rtsopts=all" - (NoArg (setRtsOptsEnabled RtsOptsAll)) - , make_ord_flag defGhcFlag "rtsopts=some" - (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) - , make_ord_flag defGhcFlag "rtsopts=none" - (NoArg (setRtsOptsEnabled RtsOptsNone)) - , make_ord_flag defGhcFlag "rtsopts=ignore" - (NoArg (setRtsOptsEnabled RtsOptsIgnore)) - , make_ord_flag defGhcFlag "rtsopts=ignoreAll" - (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) - , make_ord_flag defGhcFlag "no-rtsopts" - (NoArg (setRtsOptsEnabled RtsOptsNone)) - , make_ord_flag defGhcFlag "no-rtsopts-suggestions" - (noArg (\d -> d {rtsOptsSuggestions = False})) - , make_ord_flag defGhcFlag "dhex-word-literals" - (NoArg (setGeneralFlag Opt_HexWordLiterals)) - - , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) - , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) - , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) - , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) - , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) - , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) - , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) - , make_ord_flag defGhcFlag "ticky-allocd" - (NoArg (setGeneralFlag Opt_Ticky_Allocd)) - , make_ord_flag defGhcFlag "ticky-LNE" - (NoArg (setGeneralFlag Opt_Ticky_LNE)) - , make_ord_flag defGhcFlag "ticky-dyn-thunk" - (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) - ------- recompilation checker -------------------------------------- - , make_dep_flag defGhcFlag "recomp" - (NoArg $ unSetGeneralFlag Opt_ForceRecomp) - "Use -fno-force-recomp instead" - , make_dep_flag defGhcFlag "no-recomp" - (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" - , make_ord_flag defFlag "fmax-errors" - (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) - , make_ord_flag defFlag "fno-max-errors" - (noArg (\d -> d { maxErrors = Nothing })) - , make_ord_flag defFlag "freverse-errors" - (noArg (\d -> d {reverseErrors = True} )) - , make_ord_flag defFlag "fno-reverse-errors" - (noArg (\d -> d {reverseErrors = False} )) - - ------ HsCpp opts --------------------------------------------------- - , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) - , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) - - ------- Include/Import Paths ---------------------------------------- - , make_ord_flag defFlag "I" (Prefix addIncludePath) - , make_ord_flag defFlag "i" (OptPrefix addImportPath) - - ------ Output style options ----------------------------------------- - , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> - d { pprUserLength = n })) - , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> - d { pprCols = n })) - , make_ord_flag defFlag "fdiagnostics-color=auto" - (NoArg (upd (\d -> d { useColor = Auto }))) - , make_ord_flag defFlag "fdiagnostics-color=always" - (NoArg (upd (\d -> d { useColor = Always }))) - , make_ord_flag defFlag "fdiagnostics-color=never" - (NoArg (upd (\d -> d { useColor = Never }))) - - -- Suppress all that is suppressable in core dumps. - -- Except for uniques, as some simplifier phases introduce new variables that - -- have otherwise identical names. - , make_ord_flag defGhcFlag "dsuppress-all" - (NoArg $ do setGeneralFlag Opt_SuppressCoercions - setGeneralFlag Opt_SuppressVarKinds - setGeneralFlag Opt_SuppressModulePrefixes - setGeneralFlag Opt_SuppressTypeApplications - setGeneralFlag Opt_SuppressIdInfo - setGeneralFlag Opt_SuppressTicks - setGeneralFlag Opt_SuppressStgExts - setGeneralFlag Opt_SuppressTypeSignatures - setGeneralFlag Opt_SuppressTimestamps) - - ------ Debugging ---------------------------------------------------- - , make_ord_flag defGhcFlag "dstg-stats" - (NoArg (setGeneralFlag Opt_StgStats)) - - , make_ord_flag defGhcFlag "ddump-cmm" - (setDumpFlag Opt_D_dump_cmm) - , make_ord_flag defGhcFlag "ddump-cmm-from-stg" - (setDumpFlag Opt_D_dump_cmm_from_stg) - , make_ord_flag defGhcFlag "ddump-cmm-raw" - (setDumpFlag Opt_D_dump_cmm_raw) - , make_ord_flag defGhcFlag "ddump-cmm-verbose" - (setDumpFlag Opt_D_dump_cmm_verbose) - , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" - (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) - , make_ord_flag defGhcFlag "ddump-cmm-cfg" - (setDumpFlag Opt_D_dump_cmm_cfg) - , make_ord_flag defGhcFlag "ddump-cmm-cbe" - (setDumpFlag Opt_D_dump_cmm_cbe) - , make_ord_flag defGhcFlag "ddump-cmm-switch" - (setDumpFlag Opt_D_dump_cmm_switch) - , make_ord_flag defGhcFlag "ddump-cmm-proc" - (setDumpFlag Opt_D_dump_cmm_proc) - , make_ord_flag defGhcFlag "ddump-cmm-sp" - (setDumpFlag Opt_D_dump_cmm_sp) - , make_ord_flag defGhcFlag "ddump-cmm-sink" - (setDumpFlag Opt_D_dump_cmm_sink) - , make_ord_flag defGhcFlag "ddump-cmm-caf" - (setDumpFlag Opt_D_dump_cmm_caf) - , make_ord_flag defGhcFlag "ddump-cmm-procmap" - (setDumpFlag Opt_D_dump_cmm_procmap) - , make_ord_flag defGhcFlag "ddump-cmm-split" - (setDumpFlag Opt_D_dump_cmm_split) - , make_ord_flag defGhcFlag "ddump-cmm-info" - (setDumpFlag Opt_D_dump_cmm_info) - , make_ord_flag defGhcFlag "ddump-cmm-cps" - (setDumpFlag Opt_D_dump_cmm_cps) - , make_ord_flag defGhcFlag "ddump-cfg-weights" - (setDumpFlag Opt_D_dump_cfg_weights) - , make_ord_flag defGhcFlag "ddump-core-stats" - (setDumpFlag Opt_D_dump_core_stats) - , make_ord_flag defGhcFlag "ddump-asm" - (setDumpFlag Opt_D_dump_asm) - , make_ord_flag defGhcFlag "ddump-asm-native" - (setDumpFlag Opt_D_dump_asm_native) - , make_ord_flag defGhcFlag "ddump-asm-liveness" - (setDumpFlag Opt_D_dump_asm_liveness) - , make_ord_flag defGhcFlag "ddump-asm-regalloc" - (setDumpFlag Opt_D_dump_asm_regalloc) - , make_ord_flag defGhcFlag "ddump-asm-conflicts" - (setDumpFlag Opt_D_dump_asm_conflicts) - , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" - (setDumpFlag Opt_D_dump_asm_regalloc_stages) - , make_ord_flag defGhcFlag "ddump-asm-stats" - (setDumpFlag Opt_D_dump_asm_stats) - , make_ord_flag defGhcFlag "ddump-asm-expanded" - (setDumpFlag Opt_D_dump_asm_expanded) - , make_ord_flag defGhcFlag "ddump-llvm" - (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm) - , make_ord_flag defGhcFlag "ddump-deriv" - (setDumpFlag Opt_D_dump_deriv) - , make_ord_flag defGhcFlag "ddump-ds" - (setDumpFlag Opt_D_dump_ds) - , make_ord_flag defGhcFlag "ddump-ds-preopt" - (setDumpFlag Opt_D_dump_ds_preopt) - , make_ord_flag defGhcFlag "ddump-foreign" - (setDumpFlag Opt_D_dump_foreign) - , make_ord_flag defGhcFlag "ddump-inlinings" - (setDumpFlag Opt_D_dump_inlinings) - , make_ord_flag defGhcFlag "ddump-rule-firings" - (setDumpFlag Opt_D_dump_rule_firings) - , make_ord_flag defGhcFlag "ddump-rule-rewrites" - (setDumpFlag Opt_D_dump_rule_rewrites) - , make_ord_flag defGhcFlag "ddump-simpl-trace" - (setDumpFlag Opt_D_dump_simpl_trace) - , make_ord_flag defGhcFlag "ddump-occur-anal" - (setDumpFlag Opt_D_dump_occur_anal) - , make_ord_flag defGhcFlag "ddump-parsed" - (setDumpFlag Opt_D_dump_parsed) - , make_ord_flag defGhcFlag "ddump-parsed-ast" - (setDumpFlag Opt_D_dump_parsed_ast) - , make_ord_flag defGhcFlag "ddump-rn" - (setDumpFlag Opt_D_dump_rn) - , make_ord_flag defGhcFlag "ddump-rn-ast" - (setDumpFlag Opt_D_dump_rn_ast) - , make_ord_flag defGhcFlag "ddump-simpl" - (setDumpFlag Opt_D_dump_simpl) - , make_ord_flag defGhcFlag "ddump-simpl-iterations" - (setDumpFlag Opt_D_dump_simpl_iterations) - , make_ord_flag defGhcFlag "ddump-spec" - (setDumpFlag Opt_D_dump_spec) - , make_ord_flag defGhcFlag "ddump-prep" - (setDumpFlag Opt_D_dump_prep) - , make_ord_flag defGhcFlag "ddump-stg" - (setDumpFlag Opt_D_dump_stg) - , make_ord_flag defGhcFlag "ddump-stg-unarised" - (setDumpFlag Opt_D_dump_stg_unarised) - , make_ord_flag defGhcFlag "ddump-stg-final" - (setDumpFlag Opt_D_dump_stg_final) - , make_ord_flag defGhcFlag "ddump-call-arity" - (setDumpFlag Opt_D_dump_call_arity) - , make_ord_flag defGhcFlag "ddump-exitify" - (setDumpFlag Opt_D_dump_exitify) - , make_ord_flag defGhcFlag "ddump-stranal" - (setDumpFlag Opt_D_dump_stranal) - , make_ord_flag defGhcFlag "ddump-str-signatures" - (setDumpFlag Opt_D_dump_str_signatures) - , make_ord_flag defGhcFlag "ddump-tc" - (setDumpFlag Opt_D_dump_tc) - , make_ord_flag defGhcFlag "ddump-tc-ast" - (setDumpFlag Opt_D_dump_tc_ast) - , make_ord_flag defGhcFlag "ddump-types" - (setDumpFlag Opt_D_dump_types) - , make_ord_flag defGhcFlag "ddump-rules" - (setDumpFlag Opt_D_dump_rules) - , make_ord_flag defGhcFlag "ddump-cse" - (setDumpFlag Opt_D_dump_cse) - , make_ord_flag defGhcFlag "ddump-worker-wrapper" - (setDumpFlag Opt_D_dump_worker_wrapper) - , make_ord_flag defGhcFlag "ddump-rn-trace" - (setDumpFlag Opt_D_dump_rn_trace) - , make_ord_flag defGhcFlag "ddump-if-trace" - (setDumpFlag Opt_D_dump_if_trace) - , make_ord_flag defGhcFlag "ddump-cs-trace" - (setDumpFlag Opt_D_dump_cs_trace) - , make_ord_flag defGhcFlag "ddump-tc-trace" - (NoArg (do setDumpFlag' Opt_D_dump_tc_trace - setDumpFlag' Opt_D_dump_cs_trace)) - , make_ord_flag defGhcFlag "ddump-ec-trace" - (setDumpFlag Opt_D_dump_ec_trace) - , make_ord_flag defGhcFlag "ddump-vt-trace" - (setDumpFlag Opt_D_dump_vt_trace) - , make_ord_flag defGhcFlag "ddump-splices" - (setDumpFlag Opt_D_dump_splices) - , make_ord_flag defGhcFlag "dth-dec-file" - (setDumpFlag Opt_D_th_dec_file) - - , make_ord_flag defGhcFlag "ddump-rn-stats" - (setDumpFlag Opt_D_dump_rn_stats) - , make_ord_flag defGhcFlag "ddump-opt-cmm" - (setDumpFlag Opt_D_dump_opt_cmm) - , make_ord_flag defGhcFlag "ddump-simpl-stats" - (setDumpFlag Opt_D_dump_simpl_stats) - , make_ord_flag defGhcFlag "ddump-bcos" - (setDumpFlag Opt_D_dump_BCOs) - , make_ord_flag defGhcFlag "dsource-stats" - (setDumpFlag Opt_D_source_stats) - , make_ord_flag defGhcFlag "dverbose-core2core" - (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) - , make_ord_flag defGhcFlag "dverbose-stg2stg" - (setDumpFlag Opt_D_verbose_stg2stg) - , make_ord_flag defGhcFlag "ddump-hi" - (setDumpFlag Opt_D_dump_hi) - , make_ord_flag defGhcFlag "ddump-minimal-imports" - (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) - , make_ord_flag defGhcFlag "ddump-hpc" - (setDumpFlag Opt_D_dump_ticked) -- back compat - , make_ord_flag defGhcFlag "ddump-ticked" - (setDumpFlag Opt_D_dump_ticked) - , make_ord_flag defGhcFlag "ddump-mod-cycles" - (setDumpFlag Opt_D_dump_mod_cycles) - , make_ord_flag defGhcFlag "ddump-mod-map" - (setDumpFlag Opt_D_dump_mod_map) - , make_ord_flag defGhcFlag "ddump-timings" - (setDumpFlag Opt_D_dump_timings) - , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" - (setDumpFlag Opt_D_dump_view_pattern_commoning) - , make_ord_flag defGhcFlag "ddump-to-file" - (NoArg (setGeneralFlag Opt_DumpToFile)) - , make_ord_flag defGhcFlag "ddump-hi-diffs" - (setDumpFlag Opt_D_dump_hi_diffs) - , make_ord_flag defGhcFlag "ddump-rtti" - (setDumpFlag Opt_D_dump_rtti) - , make_ord_flag defGhcFlag "dcore-lint" - (NoArg (setGeneralFlag Opt_DoCoreLinting)) - , make_ord_flag defGhcFlag "dstg-lint" - (NoArg (setGeneralFlag Opt_DoStgLinting)) - , make_ord_flag defGhcFlag "dcmm-lint" - (NoArg (setGeneralFlag Opt_DoCmmLinting)) - , make_ord_flag defGhcFlag "dasm-lint" - (NoArg (setGeneralFlag Opt_DoAsmLinting)) - , make_ord_flag defGhcFlag "dannot-lint" - (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) - , make_ord_flag defGhcFlag "dshow-passes" - (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) - , make_ord_flag defGhcFlag "dfaststring-stats" - (NoArg (setGeneralFlag Opt_D_faststring_stats)) - , make_ord_flag defGhcFlag "dno-llvm-mangler" - (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag - , make_ord_flag defGhcFlag "fast-llvm" - (NoArg (setGeneralFlag Opt_FastLlvm)) -- hidden flag - , make_ord_flag defGhcFlag "dno-typeable-binds" - (NoArg (setGeneralFlag Opt_NoTypeableBinds)) - , make_ord_flag defGhcFlag "ddump-debug" - (setDumpFlag Opt_D_dump_debug) - , make_ord_flag defGhcFlag "ddump-json" - (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) - , make_ord_flag defGhcFlag "dppr-debug" - (setDumpFlag Opt_D_ppr_debug) - , make_ord_flag defGhcFlag "ddebug-output" - (noArg (flip dopt_unset Opt_D_no_debug_output)) - , make_ord_flag defGhcFlag "dno-debug-output" - (setDumpFlag Opt_D_no_debug_output) - - ------ Machine dependent (-m) stuff --------------------------- - - , make_ord_flag defGhcFlag "msse" (noArg (\d -> - d { sseVersion = Just SSE1 })) - , make_ord_flag defGhcFlag "msse2" (noArg (\d -> - d { sseVersion = Just SSE2 })) - , make_ord_flag defGhcFlag "msse3" (noArg (\d -> - d { sseVersion = Just SSE3 })) - , make_ord_flag defGhcFlag "msse4" (noArg (\d -> - d { sseVersion = Just SSE4 })) - , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> - d { sseVersion = Just SSE42 })) - , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> - d { bmiVersion = Just BMI1 })) - , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> - d { bmiVersion = Just BMI2 })) - , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) - , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) - , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> - d { avx512cd = True })) - , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> - d { avx512er = True })) - , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) - , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> - d { avx512pf = True })) - - ------ Warning opts ------------------------------------------------- - , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) - , make_ord_flag defFlag "Werror" - (NoArg (do { setGeneralFlag Opt_WarnIsError - ; mapM_ setFatalWarningFlag minusWeverythingOpts })) - , make_ord_flag defFlag "Wwarn" - (NoArg (do { unSetGeneralFlag Opt_WarnIsError - ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) - -- Opt_WarnIsError is still needed to pass -Werror - -- to CPP; see runCpp in SysTools - , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> - d {warningFlags = EnumSet.empty}))) - "Use -w or -Wno-everything instead" - , make_ord_flag defFlag "w" (NoArg (upd (\d -> - d {warningFlags = EnumSet.empty}))) - - -- New-style uniform warning sets - -- - -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything - , make_ord_flag defFlag "Weverything" (NoArg (mapM_ - setWarningFlag minusWeverythingOpts)) - , make_ord_flag defFlag "Wno-everything" - (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) - - , make_ord_flag defFlag "Wall" (NoArg (mapM_ - setWarningFlag minusWallOpts)) - , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ - unSetWarningFlag minusWallOpts)) - - , make_ord_flag defFlag "Wextra" (NoArg (mapM_ - setWarningFlag minusWOpts)) - , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ - unSetWarningFlag minusWOpts)) - - , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ - setWarningFlag standardWarnings)) - , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ - unSetWarningFlag standardWarnings)) - - , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ - setWarningFlag minusWcompatOpts)) - , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ - unSetWarningFlag minusWcompatOpts)) - - ------ Plugin flags ------------------------------------------------ - , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) - , make_ord_flag defGhcFlag "fplugin-trustworthy" - (NoArg (setGeneralFlag Opt_PluginTrustworthy)) - , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) - , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) - , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) - - ------ Optimisation flags ------------------------------------------ - , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) - "Use -O0 instead" - , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> - setOptLevel (mb_n `orElse` 1))) - -- If the number is missing, use 1 - - , make_ord_flag defFlag "fbinary-blob-threshold" - (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n })) - - , make_ord_flag defFlag "fmax-relevant-binds" - (intSuffix (\n d -> d { maxRelevantBinds = Just n })) - , make_ord_flag defFlag "fno-max-relevant-binds" - (noArg (\d -> d { maxRelevantBinds = Nothing })) - - , make_ord_flag defFlag "fmax-valid-hole-fits" - (intSuffix (\n d -> d { maxValidHoleFits = Just n })) - , make_ord_flag defFlag "fno-max-valid-hole-fits" - (noArg (\d -> d { maxValidHoleFits = Nothing })) - , make_ord_flag defFlag "fmax-refinement-hole-fits" - (intSuffix (\n d -> d { maxRefHoleFits = Just n })) - , make_ord_flag defFlag "fno-max-refinement-hole-fits" - (noArg (\d -> d { maxRefHoleFits = Nothing })) - , make_ord_flag defFlag "frefinement-level-hole-fits" - (intSuffix (\n d -> d { refLevelHoleFits = Just n })) - , make_ord_flag defFlag "fno-refinement-level-hole-fits" - (noArg (\d -> d { refLevelHoleFits = Nothing })) - - , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" - (noArg id) - "vectors registers are now passed in registers by default." - , make_ord_flag defFlag "fmax-uncovered-patterns" - (intSuffix (\n d -> d { maxUncoveredPatterns = n })) - , make_ord_flag defFlag "fmax-pmcheck-models" - (intSuffix (\n d -> d { maxPmCheckModels = n })) - , make_ord_flag defFlag "fsimplifier-phases" - (intSuffix (\n d -> d { simplPhases = n })) - , make_ord_flag defFlag "fmax-simplifier-iterations" - (intSuffix (\n d -> d { maxSimplIterations = n })) - , (Deprecated, defFlag "fmax-pmcheck-iterations" - (intSuffixM (\_ d -> - do { deprecate $ "use -fmax-pmcheck-models instead" - ; return d }))) - , make_ord_flag defFlag "fsimpl-tick-factor" - (intSuffix (\n d -> d { simplTickFactor = n })) - , make_ord_flag defFlag "fspec-constr-threshold" - (intSuffix (\n d -> d { specConstrThreshold = Just n })) - , make_ord_flag defFlag "fno-spec-constr-threshold" - (noArg (\d -> d { specConstrThreshold = Nothing })) - , make_ord_flag defFlag "fspec-constr-count" - (intSuffix (\n d -> d { specConstrCount = Just n })) - , make_ord_flag defFlag "fno-spec-constr-count" - (noArg (\d -> d { specConstrCount = Nothing })) - , make_ord_flag defFlag "fspec-constr-recursive" - (intSuffix (\n d -> d { specConstrRecursive = n })) - , make_ord_flag defFlag "fliberate-case-threshold" - (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) - , make_ord_flag defFlag "fno-liberate-case-threshold" - (noArg (\d -> d { liberateCaseThreshold = Nothing })) - , make_ord_flag defFlag "drule-check" - (sepArg (\s d -> d { ruleCheck = Just s })) - , make_ord_flag defFlag "dinline-check" - (sepArg (\s d -> d { inlineCheck = Just s })) - , make_ord_flag defFlag "freduction-depth" - (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) - , make_ord_flag defFlag "fconstraint-solver-iterations" - (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) - , (Deprecated, defFlag "fcontext-stack" - (intSuffixM (\n d -> - do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" - ; return $ d { reductionDepth = treatZeroAsInf n } }))) - , (Deprecated, defFlag "ftype-function-depth" - (intSuffixM (\n d -> - do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" - ; return $ d { reductionDepth = treatZeroAsInf n } }))) - , make_ord_flag defFlag "fstrictness-before" - (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) - , make_ord_flag defFlag "ffloat-lam-args" - (intSuffix (\n d -> d { floatLamArgs = Just n })) - , make_ord_flag defFlag "ffloat-all-lams" - (noArg (\d -> d { floatLamArgs = Nothing })) - , make_ord_flag defFlag "fstg-lift-lams-rec-args" - (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) - , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" - (noArg (\d -> d { liftLamsRecArgs = Nothing })) - , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" - (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) - , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" - (noArg (\d -> d { liftLamsRecArgs = Nothing })) - , make_ord_flag defFlag "fstg-lift-lams-known" - (noArg (\d -> d { liftLamsKnown = True })) - , make_ord_flag defFlag "fno-stg-lift-lams-known" - (noArg (\d -> d { liftLamsKnown = False })) - , make_ord_flag defFlag "fproc-alignment" - (intSuffix (\n d -> d { cmmProcAlignment = Just n })) - , make_ord_flag defFlag "fblock-layout-weights" - (HasArg (\s -> - upd (\d -> d { cfgWeightInfo = - parseCfgWeights s (cfgWeightInfo d)}))) - , make_ord_flag defFlag "fhistory-size" - (intSuffix (\n d -> d { historySize = n })) - , make_ord_flag defFlag "funfolding-creation-threshold" - (intSuffix (\n d -> d {ufCreationThreshold = n})) - , make_ord_flag defFlag "funfolding-use-threshold" - (intSuffix (\n d -> d {ufUseThreshold = n})) - , make_ord_flag defFlag "funfolding-fun-discount" - (intSuffix (\n d -> d {ufFunAppDiscount = n})) - , make_ord_flag defFlag "funfolding-dict-discount" - (intSuffix (\n d -> d {ufDictDiscount = n})) - , make_ord_flag defFlag "funfolding-keeness-factor" - (floatSuffix (\n d -> d {ufKeenessFactor = n})) - , make_ord_flag defFlag "fmax-worker-args" - (intSuffix (\n d -> d {maxWorkerArgs = n})) - , make_ord_flag defGhciFlag "fghci-hist-size" - (intSuffix (\n d -> d {ghciHistSize = n})) - , make_ord_flag defGhcFlag "fmax-inline-alloc-size" - (intSuffix (\n d -> d { maxInlineAllocSize = n })) - , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" - (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) - , make_ord_flag defGhcFlag "fmax-inline-memset-insns" - (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) - , make_ord_flag defGhcFlag "dinitial-unique" - (intSuffix (\n d -> d { initialUnique = n })) - , make_ord_flag defGhcFlag "dunique-increment" - (intSuffix (\n d -> d { uniqueIncrement = n })) - - ------ Profiling ---------------------------------------------------- - - -- OLD profiling flags - , make_dep_flag defGhcFlag "auto-all" - (noArg (\d -> d { profAuto = ProfAutoAll } )) - "Use -fprof-auto instead" - , make_dep_flag defGhcFlag "no-auto-all" - (noArg (\d -> d { profAuto = NoProfAuto } )) - "Use -fno-prof-auto instead" - , make_dep_flag defGhcFlag "auto" - (noArg (\d -> d { profAuto = ProfAutoExports } )) - "Use -fprof-auto-exported instead" - , make_dep_flag defGhcFlag "no-auto" - (noArg (\d -> d { profAuto = NoProfAuto } )) - "Use -fno-prof-auto instead" - , make_dep_flag defGhcFlag "caf-all" - (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) - "Use -fprof-cafs instead" - , make_dep_flag defGhcFlag "no-caf-all" - (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) - "Use -fno-prof-cafs instead" - - -- NEW profiling flags - , make_ord_flag defGhcFlag "fprof-auto" - (noArg (\d -> d { profAuto = ProfAutoAll } )) - , make_ord_flag defGhcFlag "fprof-auto-top" - (noArg (\d -> d { profAuto = ProfAutoTop } )) - , make_ord_flag defGhcFlag "fprof-auto-exported" - (noArg (\d -> d { profAuto = ProfAutoExports } )) - , make_ord_flag defGhcFlag "fprof-auto-calls" - (noArg (\d -> d { profAuto = ProfAutoCalls } )) - , make_ord_flag defGhcFlag "fno-prof-auto" - (noArg (\d -> d { profAuto = NoProfAuto } )) - - ------ Compiler flags ----------------------------------------------- - - , make_ord_flag defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) - , make_ord_flag defGhcFlag "fvia-c" (NoArg - (deprecate $ "The -fvia-c flag does nothing; " ++ - "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fvia-C" (NoArg - (deprecate $ "The -fvia-C flag does nothing; " ++ - "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) - - , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> - d { ghcLink=NoLink }) >> setTarget HscNothing)) - , make_ord_flag defFlag "fbyte-code" (NoArg ((upd $ \d -> - -- Enabling Opt_ByteCodeIfUnboxed is a workaround for #18955. - -- See the comments for resetOptByteCodeIfUnboxed for more details. - gopt_set d Opt_ByteCodeIfUnboxed) >> setTarget HscInterpreted)) - , make_ord_flag defFlag "fobject-code" $ NoArg $ do - dflags <- liftEwM getCmdLineState - setTarget $ defaultObjectTarget dflags - - , make_dep_flag defFlag "fglasgow-exts" - (NoArg enableGlasgowExts) "Use individual extensions instead" - , make_dep_flag defFlag "fno-glasgow-exts" - (NoArg disableGlasgowExts) "Use individual extensions instead" - , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) - , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) - , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) - , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg - disableUnusedBinds) - - ------ Safe Haskell flags ------------------------------------------- - , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) - , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> - d { safeInfer = False })) - , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) - - ------ position independent flags ---------------------------------- - , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIC)) - - ------ Debugging flags ---------------------------------------------- - , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) - ] - ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps - ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps - ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps - ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps - ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps - ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps - ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) - wWarningFlagsDeps - ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) - wWarningFlagsDeps - ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) - wWarningFlagsDeps - ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) - wWarningFlagsDeps - ++ [ (NotDeprecated, unrecognisedWarning "W"), - (Deprecated, unrecognisedWarning "fwarn-"), - (Deprecated, unrecognisedWarning "fno-warn-") ] - ++ [ make_ord_flag defFlag "Werror=compat" - (NoArg (mapM_ setWErrorFlag minusWcompatOpts)) - , make_ord_flag defFlag "Wno-error=compat" - (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) - , make_ord_flag defFlag "Wwarn=compat" - (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ] - ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps - ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps - ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps - ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps - ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps - ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps - ++ [ make_dep_flag defFlag "XGenerics" - (NoArg $ return ()) - ("it does nothing; look into -XDefaultSignatures " ++ - "and -XDeriveGeneric for generic programming support.") - , make_dep_flag defFlag "XNoGenerics" - (NoArg $ return ()) - ("it does nothing; look into -XDefaultSignatures and " ++ - "-XDeriveGeneric for generic programming support.") ] - --- | This is where we handle unrecognised warning flags. We only issue a warning --- if -Wunrecognised-warning-flags is set. See #11429 for context. -unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) -unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) - where - action :: String -> EwM (CmdLineP DynFlags) () - action flag = do - f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState - when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $ - "unrecognised warning flag: -" ++ prefix ++ flag - --- See Note [Supporting CLI completion] -package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] -package_flags_deps = [ - ------- Packages ---------------------------------------------------- - make_ord_flag defFlag "package-db" - (HasArg (addPkgConfRef . PkgConfFile)) - , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgConf) - , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgConf) - , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgConf) - , make_ord_flag defFlag "global-package-db" - (NoArg (addPkgConfRef GlobalPkgConf)) - , make_ord_flag defFlag "user-package-db" - (NoArg (addPkgConfRef UserPkgConf)) - -- backwards compat with GHC<=7.4 : - , make_dep_flag defFlag "package-conf" - (HasArg $ addPkgConfRef . PkgConfFile) "Use -package-db instead" - , make_dep_flag defFlag "no-user-package-conf" - (NoArg removeUserPkgConf) "Use -no-user-package-db instead" - , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do - upd (setUnitId name)) - -- TODO: Since we JUST deprecated - -- -this-package-key, let's keep this - -- undeprecated for another cycle. - -- Deprecate this eventually. - -- deprecate "Use -this-unit-id instead") - , make_dep_flag defGhcFlag "this-package-key" (HasArg $ upd . setUnitId) - "Use -this-unit-id instead" - , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) - , make_ord_flag defFlag "package" (HasArg exposePackage) - , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) - , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) - , make_ord_flag defFlag "package-id" (HasArg exposePackageId) - , make_ord_flag defFlag "hide-package" (HasArg hidePackage) - , make_ord_flag defFlag "hide-all-packages" - (NoArg (setGeneralFlag Opt_HideAllPackages)) - , make_ord_flag defFlag "hide-all-plugin-packages" - (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) - , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) - , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) - , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" - , make_ord_flag defFlag "distrust-all-packages" - (NoArg (setGeneralFlag Opt_DistrustAllPackages)) - , make_ord_flag defFlag "trust" (HasArg trustPackage) - , make_ord_flag defFlag "distrust" (HasArg distrustPackage) - ] - where - setPackageEnv env = upd $ \s -> s { packageEnv = Just env } - --- | Make a list of flags for shell completion. --- Filter all available flags into two groups, for interactive GHC vs all other. -flagsForCompletion :: Bool -> [String] -flagsForCompletion isInteractive - = [ '-':flagName flag - | flag <- flagsAll - , modeFilter (flagGhcMode flag) - ] - where - modeFilter AllModes = True - modeFilter OnlyGhci = isInteractive - modeFilter OnlyGhc = not isInteractive - modeFilter HiddenFlag = False - -type TurnOnFlag = Bool -- True <=> we are turning the flag on - -- False <=> we are turning the flag off -turnOn :: TurnOnFlag; turnOn = True -turnOff :: TurnOnFlag; turnOff = False - -data FlagSpec flag - = FlagSpec - { flagSpecName :: String -- ^ Flag in string form - , flagSpecFlag :: flag -- ^ Flag in internal form - , flagSpecAction :: (TurnOnFlag -> DynP ()) - -- ^ Extra action to run when the flag is found - -- Typically, emit a warning or error - , flagSpecGhcMode :: GhcFlagMode - -- ^ In which ghc mode the flag has effect - } - --- | Define a new flag. -flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagSpec name flag = flagSpec' name flag nop - --- | Define a new flag with an effect. -flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) - --- | Define a new deprecated flag with an effect. -depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String - -> (Deprecation, FlagSpec flag) -depFlagSpecOp name flag act dep = - (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) - --- | Define a new deprecated flag. -depFlagSpec :: String -> flag -> String - -> (Deprecation, FlagSpec flag) -depFlagSpec name flag dep = depFlagSpecOp name flag nop dep - --- | Define a new deprecated flag with an effect where the deprecation message --- depends on the flag value -depFlagSpecOp' :: String - -> flag - -> (TurnOnFlag -> DynP ()) - -> (TurnOnFlag -> String) - -> (Deprecation, FlagSpec flag) -depFlagSpecOp' name flag act dep = - (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) - AllModes) - --- | Define a new deprecated flag where the deprecation message --- depends on the flag value -depFlagSpec' :: String - -> flag - -> (TurnOnFlag -> String) - -> (Deprecation, FlagSpec flag) -depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep - - --- | Define a new deprecated flag where the deprecation message --- is shown depending on the flag value -depFlagSpecCond :: String - -> flag - -> (TurnOnFlag -> Bool) - -> String - -> (Deprecation, FlagSpec flag) -depFlagSpecCond name flag cond dep = - (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) - AllModes) - --- | Define a new flag for GHCi. -flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagGhciSpec name flag = flagGhciSpec' name flag nop - --- | Define a new flag for GHCi with an effect. -flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) - --- | Define a new flag invisible to CLI completion. -flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagHiddenSpec name flag = flagHiddenSpec' name flag nop - --- | Define a new flag invisible to CLI completion with an effect. -flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act - HiddenFlag) - --- | Hide a 'FlagSpec' from being displayed in @--show-options@. --- --- This is for example useful for flags that are obsolete, but should not --- (yet) be deprecated for compatibility reasons. -hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) -hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) - -mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on - -> String -- ^ The flag prefix - -> (flag -> DynP ()) -- ^ What to do when the flag is found - -> (Deprecation, FlagSpec flag) -- ^ Specification of - -- this particular flag - -> (Deprecation, Flag (CmdLineP DynFlags)) -mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) - = (dep, - Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) - -deprecatedForExtension :: String -> TurnOnFlag -> String -deprecatedForExtension lang turn_on - = "use -X" ++ flag ++ - " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" - where - flag | turn_on = lang - | otherwise = "No" ++ lang - -useInstead :: String -> String -> TurnOnFlag -> String -useInstead prefix flag turn_on - = "Use " ++ prefix ++ no ++ flag ++ " instead" - where - no = if turn_on then "" else "no-" - -nop :: TurnOnFlag -> DynP () -nop _ = return () - --- | Find the 'FlagSpec' for a 'WarningFlag'. -flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) -flagSpecOf flag = listToMaybe $ filter check wWarningFlags - where - check fs = flagSpecFlag fs == flag - --- | These @-W\@ flags can all be reversed with @-Wno-\@ -wWarningFlags :: [FlagSpec WarningFlag] -wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) - -wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] -wWarningFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - flagSpec "alternative-layout-rule-transitional" - Opt_WarnAlternativeLayoutRuleTransitional, - depFlagSpec "auto-orphans" Opt_WarnAutoOrphans - "it has no effect", - flagSpec "cpp-undef" Opt_WarnCPPUndef, - flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, - flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, - flagSpec "deferred-out-of-scope-variables" - Opt_WarnDeferredOutOfScopeVariables, - flagSpec "deprecations" Opt_WarnWarningsDeprecations, - flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags, - flagSpec "deriving-defaults" Opt_WarnDerivingDefaults, - flagSpec "deriving-typeable" Opt_WarnDerivingTypeable, - flagSpec "dodgy-exports" Opt_WarnDodgyExports, - flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports, - flagSpec "dodgy-imports" Opt_WarnDodgyImports, - flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations, - depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints - "it is subsumed by -Wredundant-constraints", - flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, - flagSpec "duplicate-exports" Opt_WarnDuplicateExports, - depFlagSpec "hi-shadowing" Opt_WarnHiShadows - "it is not used, and was never implemented", - flagSpec "inaccessible-code" Opt_WarnInaccessibleCode, - flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, - depFlagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars - "it is now an error", - flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, - flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, - flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, - flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing, - flagSpec "identities" Opt_WarnIdentities, - flagSpec "missing-fields" Opt_WarnMissingFields, - flagSpec "missing-import-lists" Opt_WarnMissingImportList, - flagSpec "missing-export-lists" Opt_WarnMissingExportList, - depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures - "it is replaced by -Wmissing-local-signatures", - flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures, - flagSpec "missing-methods" Opt_WarnMissingMethods, - flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances, - flagSpec "semigroup" Opt_WarnSemigroup, - flagSpec "missing-signatures" Opt_WarnMissingSignatures, - depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures - "it is replaced by -Wmissing-exported-signatures", - flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures, - flagSpec "monomorphism-restriction" Opt_WarnMonomorphism, - flagSpec "name-shadowing" Opt_WarnNameShadowing, - flagSpec "noncanonical-monad-instances" - Opt_WarnNonCanonicalMonadInstances, - depFlagSpec "noncanonical-monadfail-instances" - Opt_WarnNonCanonicalMonadInstances - "fail is no longer a method of Monad", - flagSpec "noncanonical-monoid-instances" - Opt_WarnNonCanonicalMonoidInstances, - flagSpec "orphans" Opt_WarnOrphans, - flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, - flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, - flagSpec "missed-specialisations" Opt_WarnMissedSpecs, - flagSpec "missed-specializations" Opt_WarnMissedSpecs, - flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, - flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs, - flagSpec' "safe" Opt_WarnSafe setWarnSafe, - flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe, - flagSpec "inferred-safe-imports" Opt_WarnInferredSafeImports, - flagSpec "missing-safe-haskell-mode" Opt_WarnMissingSafeHaskellMode, - flagSpec "tabs" Opt_WarnTabs, - flagSpec "type-defaults" Opt_WarnTypeDefaults, - flagSpec "typed-holes" Opt_WarnTypedHoles, - flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures, - flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, - flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe, - flagSpec "unsupported-calling-conventions" - Opt_WarnUnsupportedCallingConventions, - flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, - flagSpec "missed-extra-shared-lib" Opt_WarnMissedExtraSharedLib, - flagSpec "unticked-promoted-constructors" - Opt_WarnUntickedPromotedConstructors, - flagSpec "unused-do-bind" Opt_WarnUnusedDoBind, - flagSpec "unused-foralls" Opt_WarnUnusedForalls, - flagSpec "unused-imports" Opt_WarnUnusedImports, - flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds, - flagSpec "unused-matches" Opt_WarnUnusedMatches, - flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds, - flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, - flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, - flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards, - flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards, - flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, - flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, - flagSpec "missing-pattern-synonym-signatures" - Opt_WarnMissingPatternSynonymSignatures, - flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies, - flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, - flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, - flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, - flagSpec "star-binder" Opt_WarnStarBinder, - flagSpec "star-is-type" Opt_WarnStarIsType, - flagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang, - flagSpec "partial-fields" Opt_WarnPartialFields, - flagSpec "prepositive-qualified-module" - Opt_WarnPrepositiveQualifiedModule, - flagSpec "unused-packages" Opt_WarnUnusedPackages, - flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports - ] - --- | These @-\@ flags can all be reversed with @-no-\@ -negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -negatableFlagsDeps = [ - flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] - --- | These @-d\@ flags can all be reversed with @-dno-\@ -dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -dFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, - depFlagSpec' "ppr-ticks" Opt_PprShowTicks - (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), - flagSpec "suppress-ticks" Opt_SuppressTicks, - depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts - (useInstead "-d" "suppress-stg-exts"), - flagSpec "suppress-stg-exts" Opt_SuppressStgExts, - flagSpec "suppress-coercions" Opt_SuppressCoercions, - flagSpec "suppress-idinfo" Opt_SuppressIdInfo, - flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, - flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, - flagSpec "suppress-timestamps" Opt_SuppressTimestamps, - flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, - flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, - flagSpec "suppress-uniques" Opt_SuppressUniques, - flagSpec "suppress-var-kinds" Opt_SuppressVarKinds - ] - --- | These @-f\@ flags can all be reversed with @-fno-\@ -fFlags :: [FlagSpec GeneralFlag] -fFlags = map snd fFlagsDeps - -fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -fFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - flagSpec "asm-shortcutting" Opt_AsmShortcutting, - flagGhciSpec "break-on-error" Opt_BreakOnError, - flagGhciSpec "break-on-exception" Opt_BreakOnException, - flagSpec "building-cabal-package" Opt_BuildingCabalPackage, - flagSpec "call-arity" Opt_CallArity, - flagSpec "exitification" Opt_Exitification, - flagSpec "case-merge" Opt_CaseMerge, - flagSpec "case-folding" Opt_CaseFolding, - flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, - flagSpec "cmm-sink" Opt_CmmSink, - flagSpec "cse" Opt_CSE, - flagSpec "stg-cse" Opt_StgCSE, - flagSpec "stg-lift-lams" Opt_StgLiftLams, - flagSpec "cpr-anal" Opt_CprAnal, - flagSpec "defer-diagnostics" Opt_DeferDiagnostics, - flagSpec "defer-type-errors" Opt_DeferTypeErrors, - flagSpec "defer-typed-holes" Opt_DeferTypedHoles, - flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, - flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, - flagSpec "dicts-cheap" Opt_DictsCheap, - flagSpec "dicts-strict" Opt_DictsStrict, - flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, - flagSpec "do-eta-reduction" Opt_DoEtaReduction, - flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, - flagSpec "eager-blackholing" Opt_EagerBlackHoling, - flagSpec "embed-manifest" Opt_EmbedManifest, - flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, - flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, - flagSpec "error-spans" Opt_ErrorSpans, - flagSpec "excess-precision" Opt_ExcessPrecision, - flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, - flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, - flagSpec "external-interpreter" Opt_ExternalInterpreter, - flagSpec "flat-cache" Opt_FlatCache, - flagSpec "float-in" Opt_FloatIn, - flagSpec "force-recomp" Opt_ForceRecomp, - flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, - flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, - flagSpec "full-laziness" Opt_FullLaziness, - flagSpec "fun-to-thunk" Opt_FunToThunk, - flagSpec "gen-manifest" Opt_GenManifest, - flagSpec "ghci-history" Opt_GhciHistory, - flagSpec "ghci-leak-check" Opt_GhciLeakCheck, - flagSpec "validate-ide-info" Opt_ValidateHie, - flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, - flagGhciSpec "no-it" Opt_NoIt, - flagSpec "ghci-sandbox" Opt_GhciSandbox, - flagSpec "helpful-errors" Opt_HelpfulErrors, - flagSpec "hpc" Opt_Hpc, - flagSpec "ignore-asserts" Opt_IgnoreAsserts, - flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, - flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, - flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, - flagSpec "keep-going" Opt_KeepGoing, - flagSpec "kill-absence" Opt_KillAbsence, - flagSpec "kill-one-shot" Opt_KillOneShot, - flagSpec "late-dmd-anal" Opt_LateDmdAnal, - flagSpec "late-specialise" Opt_LateSpecialise, - flagSpec "liberate-case" Opt_LiberateCase, - flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, - flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, - flagSpec "loopification" Opt_Loopification, - flagSpec "block-layout-cfg" Opt_CfgBlocklayout, - flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, - flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, - flagSpec "omit-yields" Opt_OmitYields, - flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, - flagSpec "pedantic-bottoms" Opt_PedanticBottoms, - flagSpec "pre-inlining" Opt_SimplPreInlining, - flagGhciSpec "print-bind-contents" Opt_PrintBindContents, - flagGhciSpec "print-bind-result" Opt_PrintBindResult, - flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, - flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, - flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, - flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, - flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, - flagSpec "print-equality-relations" Opt_PrintEqualityRelations, - flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, - flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, - flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, - flagSpec "print-potential-instances" Opt_PrintPotentialInstances, - flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, - flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, - flagSpec "prof-count-entries" Opt_ProfCountEntries, - flagSpec "regs-graph" Opt_RegsGraph, - flagSpec "regs-iterative" Opt_RegsIterative, - depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules - (useInstead "-f" "enable-rewrite-rules"), - flagSpec "shared-implib" Opt_SharedImplib, - flagSpec "spec-constr" Opt_SpecConstr, - flagSpec "spec-constr-keen" Opt_SpecConstrKeen, - flagSpec "specialise" Opt_Specialise, - flagSpec "specialize" Opt_Specialise, - flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, - flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, - flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, - flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, - flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, - flagSpec "strictness" Opt_Strictness, - flagSpec "use-rpaths" Opt_RPath, - flagSpec "write-interface" Opt_WriteInterface, - flagSpec "write-ide-info" Opt_WriteHie, - flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, - flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, - flagSpec "version-macros" Opt_VersionMacros, - flagSpec "worker-wrapper" Opt_WorkerWrapper, - flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, - flagSpec "catch-bottoms" Opt_CatchBottoms, - flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, - flagSpec "num-constant-folding" Opt_NumConstantFolding, - flagSpec "show-warning-groups" Opt_ShowWarnGroups, - flagSpec "hide-source-paths" Opt_HideSourcePaths, - flagSpec "show-loaded-modules" Opt_ShowLoadedModules, - flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, - flagSpec "keep-cafs" Opt_KeepCAFs - ] - ++ fHoleFlags - --- | These @-f\@ flags have to do with the typed-hole error message or --- the valid hole fits in that message. See Note [Valid hole fits include ...] --- in the TcHoleErrors module. These flags can all be reversed with --- @-fno-\@ -fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] -fHoleFlags = [ - flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, - depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits - (useInstead "-f" "show-valid-hole-fits"), - flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, - -- Sorting settings - flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, - flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, - flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, - flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, - -- Output format settings - flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, - flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, - flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, - flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, - flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, - flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, - flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits - ] - --- | These @-f\@ flags can all be reversed with @-fno-\@ -fLangFlags :: [FlagSpec LangExt.Extension] -fLangFlags = map snd fLangFlagsDeps - -fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] -fLangFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] - depFlagSpecOp' "th" LangExt.TemplateHaskell - checkTemplateHaskellOk - (deprecatedForExtension "TemplateHaskell"), - depFlagSpec' "fi" LangExt.ForeignFunctionInterface - (deprecatedForExtension "ForeignFunctionInterface"), - depFlagSpec' "ffi" LangExt.ForeignFunctionInterface - (deprecatedForExtension "ForeignFunctionInterface"), - depFlagSpec' "arrows" LangExt.Arrows - (deprecatedForExtension "Arrows"), - depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude - (deprecatedForExtension "ImplicitPrelude"), - depFlagSpec' "bang-patterns" LangExt.BangPatterns - (deprecatedForExtension "BangPatterns"), - depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction - (deprecatedForExtension "MonomorphismRestriction"), - depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds - (deprecatedForExtension "MonoPatBinds"), - depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules - (deprecatedForExtension "ExtendedDefaultRules"), - depFlagSpec' "implicit-params" LangExt.ImplicitParams - (deprecatedForExtension "ImplicitParams"), - depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables - (deprecatedForExtension "ScopedTypeVariables"), - depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances - (deprecatedForExtension "OverlappingInstances"), - depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances - (deprecatedForExtension "UndecidableInstances"), - depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances - (deprecatedForExtension "IncoherentInstances") - ] - -supportedLanguages :: [String] -supportedLanguages = map (flagSpecName . snd) languageFlagsDeps - -supportedLanguageOverlays :: [String] -supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps - -supportedExtensions :: PlatformMini -> [String] -supportedExtensions targetPlatformMini = concatMap toFlagSpecNamePair xFlags - where - toFlagSpecNamePair flg - -- IMPORTANT! Make sure that `ghc --supported-extensions` omits - -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the - -- box. See also GHC #11102 and #16331 for more details about - -- the rationale - | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] - | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] - | otherwise = [name, noName] - where - isAIX = platformMini_os targetPlatformMini == OSAIX - noName = "No" ++ name - name = flagSpecName flg - -supportedLanguagesAndExtensions :: PlatformMini -> [String] -supportedLanguagesAndExtensions targetPlatformMini = - supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions targetPlatformMini - --- | These -X flags cannot be reversed with -XNo -languageFlagsDeps :: [(Deprecation, FlagSpec Language)] -languageFlagsDeps = [ - flagSpec "Haskell98" Haskell98, - flagSpec "Haskell2010" Haskell2010 - ] - --- | These -X flags cannot be reversed with -XNo --- They are used to place hard requirements on what GHC Haskell language --- features can be used. -safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] -safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] - where mkF flag = flagSpec (show flag) flag - --- | These -X flags can all be reversed with -XNo -xFlags :: [FlagSpec LangExt.Extension] -xFlags = map snd xFlagsDeps - -xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] -xFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- See Note [Adding a language extension] --- Please keep the list of flags below sorted alphabetically - flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, - flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, - flagSpec "AlternativeLayoutRuleTransitional" - LangExt.AlternativeLayoutRuleTransitional, - flagSpec "Arrows" LangExt.Arrows, - depFlagSpecCond "AutoDeriveTypeable" LangExt.AutoDeriveTypeable - id - ("Typeable instances are created automatically " ++ - "for all types since GHC 8.2."), - flagSpec "BangPatterns" LangExt.BangPatterns, - flagSpec "BinaryLiterals" LangExt.BinaryLiterals, - flagSpec "CApiFFI" LangExt.CApiFFI, - flagSpec "CPP" LangExt.Cpp, - flagSpec "CUSKs" LangExt.CUSKs, - flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, - flagSpec "ConstraintKinds" LangExt.ConstraintKinds, - flagSpec "DataKinds" LangExt.DataKinds, - depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts - id - ("It was widely considered a misfeature, " ++ - "and has been removed from the Haskell language."), - flagSpec "DefaultSignatures" LangExt.DefaultSignatures, - flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, - flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, - flagSpec "DeriveFoldable" LangExt.DeriveFoldable, - flagSpec "DeriveFunctor" LangExt.DeriveFunctor, - flagSpec "DeriveGeneric" LangExt.DeriveGeneric, - flagSpec "DeriveLift" LangExt.DeriveLift, - flagSpec "DeriveTraversable" LangExt.DeriveTraversable, - flagSpec "DerivingStrategies" LangExt.DerivingStrategies, - flagSpec "DerivingVia" LangExt.DerivingVia, - flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, - flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, - flagSpec "BlockArguments" LangExt.BlockArguments, - depFlagSpec' "DoRec" LangExt.RecursiveDo - (deprecatedForExtension "RecursiveDo"), - flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, - flagSpec "EmptyCase" LangExt.EmptyCase, - flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, - flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, - flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, - flagSpec "ExplicitForAll" LangExt.ExplicitForAll, - flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, - flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, - flagSpec "FlexibleContexts" LangExt.FlexibleContexts, - flagSpec "FlexibleInstances" LangExt.FlexibleInstances, - flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, - flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, - flagSpec "GADTSyntax" LangExt.GADTSyntax, - flagSpec "GADTs" LangExt.GADTs, - flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, - flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving - setGenDeriving, - flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving - setGenDeriving, - flagSpec "ImplicitParams" LangExt.ImplicitParams, - flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, - flagSpec "ImportQualifiedPost" LangExt.ImportQualifiedPost, - flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, - flagSpec' "IncoherentInstances" LangExt.IncoherentInstances - setIncoherentInsts, - flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, - flagSpec "InstanceSigs" LangExt.InstanceSigs, - flagSpec "ApplicativeDo" LangExt.ApplicativeDo, - flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, - flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, - flagSpec "KindSignatures" LangExt.KindSignatures, - flagSpec "LambdaCase" LangExt.LambdaCase, - flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, - flagSpec "MagicHash" LangExt.MagicHash, - flagSpec "MonadComprehensions" LangExt.MonadComprehensions, - depFlagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring - "MonadFailDesugaring is now the default behavior", - flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, - depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds - id - "Experimental feature now removed; has no effect", - flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, - flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, - flagSpec "MultiWayIf" LangExt.MultiWayIf, - flagSpec "NumericUnderscores" LangExt.NumericUnderscores, - flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, - flagSpec "NamedFieldPuns" LangExt.RecordPuns, - flagSpec "NamedWildCards" LangExt.NamedWildCards, - flagSpec "NegativeLiterals" LangExt.NegativeLiterals, - flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, - flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, - depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses - (deprecatedForExtension "MultiParamTypeClasses"), - flagSpec "NumDecimals" LangExt.NumDecimals, - depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances - setOverlappingInsts - "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", - flagSpec "OverloadedLabels" LangExt.OverloadedLabels, - flagSpec "OverloadedLists" LangExt.OverloadedLists, - flagSpec "OverloadedStrings" LangExt.OverloadedStrings, - flagSpec "PackageImports" LangExt.PackageImports, - flagSpec "ParallelArrays" LangExt.ParallelArrays, - flagSpec "ParallelListComp" LangExt.ParallelListComp, - flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, - flagSpec "PatternGuards" LangExt.PatternGuards, - depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables - (deprecatedForExtension "ScopedTypeVariables"), - flagSpec "PatternSynonyms" LangExt.PatternSynonyms, - flagSpec "PolyKinds" LangExt.PolyKinds, - flagSpec "PolymorphicComponents" LangExt.RankNTypes, - flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints, - flagSpec "PostfixOperators" LangExt.PostfixOperators, - flagSpec "QuasiQuotes" LangExt.QuasiQuotes, - flagSpec "Rank2Types" LangExt.RankNTypes, - flagSpec "RankNTypes" LangExt.RankNTypes, - flagSpec "RebindableSyntax" LangExt.RebindableSyntax, - depFlagSpec' "RecordPuns" LangExt.RecordPuns - (deprecatedForExtension "NamedFieldPuns"), - flagSpec "RecordWildCards" LangExt.RecordWildCards, - flagSpec "RecursiveDo" LangExt.RecursiveDo, - flagSpec "RelaxedLayout" LangExt.RelaxedLayout, - depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec - not - "You can't turn off RelaxedPolyRec any more", - flagSpec "RoleAnnotations" LangExt.RoleAnnotations, - flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, - flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, - flagSpec "StarIsType" LangExt.StarIsType, - flagSpec "StaticPointers" LangExt.StaticPointers, - flagSpec "Strict" LangExt.Strict, - flagSpec "StrictData" LangExt.StrictData, - flagSpec' "TemplateHaskell" LangExt.TemplateHaskell - checkTemplateHaskellOk, - flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, - flagSpec "StandaloneKindSignatures" LangExt.StandaloneKindSignatures, - flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, - flagSpec "TransformListComp" LangExt.TransformListComp, - flagSpec "TupleSections" LangExt.TupleSections, - flagSpec "TypeApplications" LangExt.TypeApplications, - flagSpec "TypeInType" LangExt.TypeInType, - flagSpec "TypeFamilies" LangExt.TypeFamilies, - flagSpec "TypeOperators" LangExt.TypeOperators, - flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, - flagSpec "UnboxedTuples" LangExt.UnboxedTuples, - flagSpec "UnboxedSums" LangExt.UnboxedSums, - flagSpec "UndecidableInstances" LangExt.UndecidableInstances, - flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, - flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, - flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, - flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes, - flagSpec "ViewPatterns" LangExt.ViewPatterns - ] - -defaultFlags :: Settings -> [GeneralFlag] -defaultFlags settings --- See Note [Updating flag description in the User's Guide] - = [ Opt_AutoLinkPackages, - Opt_DiagnosticsShowCaret, - Opt_EmbedManifest, - Opt_FlatCache, - Opt_GenManifest, - Opt_GhciHistory, - Opt_GhciSandbox, - Opt_HelpfulErrors, - Opt_KeepHiFiles, - Opt_KeepOFiles, - Opt_OmitYields, - Opt_PrintBindContents, - Opt_ProfCountEntries, - Opt_SharedImplib, - Opt_SimplPreInlining, - Opt_VersionMacros, - Opt_RPath - ] - - ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] - -- The default -O0 options - - ++ default_PIC platform - - ++ concatMap (wayGeneralFlags platform) (defaultWays settings) - ++ validHoleFitDefaults - - where platform = sTargetPlatform settings - --- | These are the default settings for the display and sorting of valid hole --- fits in typed-hole error messages. See Note [Valid hole fits include ...] - -- in the TcHoleErrors module. -validHoleFitDefaults :: [GeneralFlag] -validHoleFitDefaults - = [ Opt_ShowTypeAppOfHoleFits - , Opt_ShowTypeOfHoleFits - , Opt_ShowProvOfHoleFits - , Opt_ShowMatchesOfHoleFits - , Opt_ShowValidHoleFits - , Opt_SortValidHoleFits - , Opt_SortBySizeHoleFits - , Opt_ShowHoleConstraints ] - - -validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -validHoleFitsImpliedGFlags - = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) - , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) - , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] - -default_PIC :: Platform -> [GeneralFlag] -default_PIC platform = - case (platformOS platform, platformArch platform) of - -- Darwin always requires PIC. Especially on more recent macOS releases - -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses - -- while we could work around this on x86_64 (like WINE does), we won't be - -- able on aarch64, where this is enforced. - (OSDarwin, ArchX86_64) -> [Opt_PIC] - -- For AArch64, we need to always have PIC enabled. The relocation model - -- on AArch64 does not permit arbitrary relocations. Under ASLR, we can't - -- control much how far apart symbols are in memory for our in-memory static - -- linker; and thus need to ensure we get sufficiently capable relocations. - -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux on top - -- of that. Subsequently we expect all code on aarch64/linux (and macOS) to - -- be built with -fPIC. - -- See #15275, #18892 - (OSDarwin, ArchAArch64) -> [Opt_PIC] - (OSLinux, ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs] - (OSLinux, ArchARM {}) -> [Opt_PIC, Opt_ExternalDynamicRefs] - (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in - -- OpenBSD since 5.3 release - -- (1 May 2013) we need to - -- always generate PIC. See - -- #10597 for more - -- information. - _ -> [] - --- General flags that are switched on/off when other general flags are switched --- on -impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) - ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) - ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) - ] ++ validHoleFitsImpliedGFlags - --- General flags that are switched on/off when other general flags are switched --- off -impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] - -impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) - , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) - , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) - , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) - , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) - , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) - , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) - , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 - , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) - - , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! - - , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) - - , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) - , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) - , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) - - , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures - , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds - - -- TypeInType is now just a synonym for a couple of other extensions. - , (LangExt.TypeInType, turnOn, LangExt.DataKinds) - , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) - , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) - - -- Standalone kind signatures are a replacement for CUSKs. - , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) - , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) - - , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) - - , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) - - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) - , (LangExt.Strict, turnOn, LangExt.StrictData) - ] - --- Note [When is StarIsType enabled] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The StarIsType extension determines whether to treat '*' as a regular type --- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType --- programs expect '*' to be synonymous with 'Type', so by default StarIsType is --- enabled. --- --- Programs that use TypeOperators might expect to repurpose '*' for --- multiplication or another binary operation, but making TypeOperators imply --- NoStarIsType caused too much breakage on Hackage. --- - --- Note [Documenting optimisation flags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you change the list of flags enabled for particular optimisation levels --- please remember to update the User's Guide. The relevant file is: --- --- docs/users_guide/using-optimisation.rst --- --- Make sure to note whether a flag is implied by -O0, -O or -O2. - -optLevelFlags :: [([Int], GeneralFlag)] -optLevelFlags -- see Note [Documenting optimisation flags] - = [ ([0,1,2], Opt_DoLambdaEtaExpansion) - , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] - , ([0,1,2], Opt_DmdTxDictSel) - , ([0,1,2], Opt_LlvmTBAA) - - , ([0], Opt_IgnoreInterfacePragmas) - , ([0], Opt_OmitInterfacePragmas) - - , ([1,2], Opt_CallArity) - , ([1,2], Opt_Exitification) - , ([1,2], Opt_CaseMerge) - , ([1,2], Opt_CaseFolding) - , ([1,2], Opt_CmmElimCommonBlocks) - , ([2], Opt_AsmShortcutting) - , ([1,2], Opt_CmmSink) - , ([1,2], Opt_CSE) - , ([1,2], Opt_StgCSE) - , ([2], Opt_StgLiftLams) - , ([1,2], Opt_EnableRewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules] - -- in PrelRules - , ([1,2], Opt_FloatIn) - , ([1,2], Opt_FullLaziness) - , ([1,2], Opt_IgnoreAsserts) - , ([1,2], Opt_Loopification) - , ([1,2], Opt_CfgBlocklayout) -- Experimental - - , ([1,2], Opt_Specialise) - , ([1,2], Opt_CrossModuleSpecialise) - , ([1,2], Opt_Strictness) - , ([1,2], Opt_UnboxSmallStrictFields) - , ([1,2], Opt_CprAnal) - , ([1,2], Opt_WorkerWrapper) - , ([1,2], Opt_SolveConstantDicts) - , ([1,2], Opt_NumConstantFolding) - - , ([2], Opt_LiberateCase) - , ([2], Opt_SpecConstr) --- , ([2], Opt_RegsGraph) --- RegsGraph suffers performance regression. See #7679 --- , ([2], Opt_StaticArgumentTransformation) --- Static Argument Transformation needs investigation. See #9374 - ] - -{- Note [Eta-reduction in -O0] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#11562 showed an example which tripped an ASSERT in CoreToStg; a -function was marked as MayHaveCafRefs when in fact it obviously -didn't. Reason was: - * Eta reduction wasn't happening in the simplifier, but it was - happening in CorePrep, on - $fBla = MkDict (/\a. K a) - * Result: rhsIsStatic told TidyPgm that $fBla might have CAF refs - but the eta-reduced version (MkDict K) obviously doesn't -Simple solution: just let the simplifier do eta-reduction even in -O0. -After all, CorePrep does it unconditionally! Not a big deal, but -removes an assertion failure. -} - - --- ----------------------------------------------------------------------------- --- Standard sets of warning options - --- Note [Documenting warning flags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you change the list of warning enabled by default --- please remember to update the User's Guide. The relevant file is: --- --- docs/users_guide/using-warnings.rst - --- | Warning groups. --- --- As all warnings are in the Weverything set, it is ignored when --- displaying to the user which group a warning is in. -warningGroups :: [(String, [WarningFlag])] -warningGroups = - [ ("compat", minusWcompatOpts) - , ("unused-binds", unusedBindsFlags) - , ("default", standardWarnings) - , ("extra", minusWOpts) - , ("all", minusWallOpts) - , ("everything", minusWeverythingOpts) - ] - --- | Warning group hierarchies, where there is an explicit inclusion --- relation. --- --- Each inner list is a hierarchy of warning groups, ordered from --- smallest to largest, where each group is a superset of the one --- before it. --- --- Separating this from 'warningGroups' allows for multiple --- hierarchies with no inherent relation to be defined. --- --- The special-case Weverything group is not included. -warningHierarchies :: [[String]] -warningHierarchies = hierarchies ++ map (:[]) rest - where - hierarchies = [["default", "extra", "all"]] - rest = filter (`notElem` "everything" : concat hierarchies) $ - map fst warningGroups - --- | Find the smallest group in every hierarchy which a warning --- belongs to, excluding Weverything. -smallestGroups :: WarningFlag -> [String] -smallestGroups flag = mapMaybe go warningHierarchies where - -- Because each hierarchy is arranged from smallest to largest, - -- the first group we find in a hierarchy which contains the flag - -- is the smallest. - go (group:rest) = fromMaybe (go rest) $ do - flags <- lookup group warningGroups - guard (flag `elem` flags) - pure (Just group) - go [] = Nothing - --- | Warnings enabled unless specified otherwise -standardWarnings :: [WarningFlag] -standardWarnings -- see Note [Documenting warning flags] - = [ Opt_WarnOverlappingPatterns, - Opt_WarnWarningsDeprecations, - Opt_WarnDeprecatedFlags, - Opt_WarnDeferredTypeErrors, - Opt_WarnTypedHoles, - Opt_WarnDeferredOutOfScopeVariables, - Opt_WarnPartialTypeSignatures, - Opt_WarnUnrecognisedPragmas, - Opt_WarnDuplicateExports, - Opt_WarnDerivingDefaults, - Opt_WarnOverflowedLiterals, - Opt_WarnEmptyEnumerations, - Opt_WarnMissingFields, - Opt_WarnMissingMethods, - Opt_WarnWrongDoBind, - Opt_WarnUnsupportedCallingConventions, - Opt_WarnDodgyForeignImports, - Opt_WarnInlineRuleShadowing, - Opt_WarnAlternativeLayoutRuleTransitional, - Opt_WarnUnsupportedLlvmVersion, - Opt_WarnMissedExtraSharedLib, - Opt_WarnTabs, - Opt_WarnUnrecognisedWarningFlags, - Opt_WarnSimplifiableClassConstraints, - Opt_WarnStarBinder, - Opt_WarnInaccessibleCode, - Opt_WarnSpaceAfterBang - ] - --- | Things you get with -W -minusWOpts :: [WarningFlag] -minusWOpts - = standardWarnings ++ - [ Opt_WarnUnusedTopBinds, - Opt_WarnUnusedLocalBinds, - Opt_WarnUnusedPatternBinds, - Opt_WarnUnusedMatches, - Opt_WarnUnusedForalls, - Opt_WarnUnusedImports, - Opt_WarnIncompletePatterns, - Opt_WarnDodgyExports, - Opt_WarnDodgyImports, - Opt_WarnUnbangedStrictPatterns - ] - --- | Things you get with -Wall -minusWallOpts :: [WarningFlag] -minusWallOpts - = minusWOpts ++ - [ Opt_WarnTypeDefaults, - Opt_WarnNameShadowing, - Opt_WarnMissingSignatures, - Opt_WarnHiShadows, - Opt_WarnOrphans, - Opt_WarnUnusedDoBind, - Opt_WarnTrustworthySafe, - Opt_WarnUntickedPromotedConstructors, - Opt_WarnMissingPatternSynonymSignatures, - Opt_WarnUnusedRecordWildcards, - Opt_WarnRedundantRecordWildcards - ] - --- | Things you get with -Weverything, i.e. *all* known warnings flags -minusWeverythingOpts :: [WarningFlag] -minusWeverythingOpts = [ toEnum 0 .. ] - --- | Things you get with -Wcompat. --- --- This is intended to group together warnings that will be enabled by default --- at some point in the future, so that library authors eager to make their --- code future compatible to fix issues before they even generate warnings. -minusWcompatOpts :: [WarningFlag] -minusWcompatOpts - = [ Opt_WarnMissingMonadFailInstances - , Opt_WarnSemigroup - , Opt_WarnNonCanonicalMonoidInstances - , Opt_WarnStarIsType - , Opt_WarnCompatUnqualifiedImports - ] - -enableUnusedBinds :: DynP () -enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags - -disableUnusedBinds :: DynP () -disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags - --- Things you get with -Wunused-binds -unusedBindsFlags :: [WarningFlag] -unusedBindsFlags = [ Opt_WarnUnusedTopBinds - , Opt_WarnUnusedLocalBinds - , Opt_WarnUnusedPatternBinds - ] - -enableGlasgowExts :: DynP () -enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls - mapM_ setExtensionFlag glasgowExtsFlags - -disableGlasgowExts :: DynP () -disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls - mapM_ unSetExtensionFlag glasgowExtsFlags - --- Please keep what_glasgow_exts_does.rst up to date with this list -glasgowExtsFlags :: [LangExt.Extension] -glasgowExtsFlags = [ - LangExt.ConstrainedClassMethods - , LangExt.DeriveDataTypeable - , LangExt.DeriveFoldable - , LangExt.DeriveFunctor - , LangExt.DeriveGeneric - , LangExt.DeriveTraversable - , LangExt.EmptyDataDecls - , LangExt.ExistentialQuantification - , LangExt.ExplicitNamespaces - , LangExt.FlexibleContexts - , LangExt.FlexibleInstances - , LangExt.ForeignFunctionInterface - , LangExt.FunctionalDependencies - , LangExt.GeneralizedNewtypeDeriving - , LangExt.ImplicitParams - , LangExt.KindSignatures - , LangExt.LiberalTypeSynonyms - , LangExt.MagicHash - , LangExt.MultiParamTypeClasses - , LangExt.ParallelListComp - , LangExt.PatternGuards - , LangExt.PostfixOperators - , LangExt.RankNTypes - , LangExt.RecursiveDo - , LangExt.ScopedTypeVariables - , LangExt.StandaloneDeriving - , LangExt.TypeOperators - , LangExt.TypeSynonymInstances - , LangExt.UnboxedTuples - , LangExt.UnicodeSyntax - , LangExt.UnliftedFFITypes ] - -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt - --- | Was the runtime system built with profiling enabled? -rtsIsProfiled :: Bool -rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 - --- Consult the RTS to find whether GHC itself has been built with --- dynamic linking. This can't be statically known at compile-time, --- because we build both the static and dynamic versions together with --- -dynamic-too. -foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt - -dynamicGhc :: Bool -dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 - -setWarnSafe :: Bool -> DynP () -setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) -setWarnSafe False = return () - -setWarnUnsafe :: Bool -> DynP () -setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) -setWarnUnsafe False = return () - -setPackageTrust :: DynP () -setPackageTrust = do - setGeneralFlag Opt_PackageTrust - l <- getCurLoc - upd $ \d -> d { pkgTrustOnLoc = l } - -setGenDeriving :: TurnOnFlag -> DynP () -setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) -setGenDeriving False = return () - -setOverlappingInsts :: TurnOnFlag -> DynP () -setOverlappingInsts False = return () -setOverlappingInsts True = do - l <- getCurLoc - upd (\d -> d { overlapInstLoc = l }) - -setIncoherentInsts :: TurnOnFlag -> DynP () -setIncoherentInsts False = return () -setIncoherentInsts True = do - l <- getCurLoc - upd (\d -> d { incoherentOnLoc = l }) - -checkTemplateHaskellOk :: TurnOnFlag -> DynP () -checkTemplateHaskellOk _turn_on - = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) - -{- ********************************************************************** -%* * - DynFlags constructors -%* * -%********************************************************************* -} - -type DynP = EwM (CmdLineP DynFlags) - -upd :: (DynFlags -> DynFlags) -> DynP () -upd f = liftEwM (do dflags <- getCmdLineState - putCmdLineState $! f dflags) - -updM :: (DynFlags -> DynP DynFlags) -> DynP () -updM f = do dflags <- liftEwM getCmdLineState - dflags' <- f dflags - liftEwM $ putCmdLineState $! dflags' - ---------------- Constructor functions for OptKind ----------------- -noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -noArg fn = NoArg (upd fn) - -noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) -noArgM fn = NoArg (updM fn) - -hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -hasArg fn = HasArg (upd . fn) - -sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -sepArg fn = SepArg (upd . fn) - -intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -intSuffix fn = IntSuffix (\n -> upd (fn n)) - -intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) -intSuffixM fn = IntSuffix (\n -> updM (fn n)) - -floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -floatSuffix fn = FloatSuffix (\n -> upd (fn n)) - -optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) - -> OptKind (CmdLineP DynFlags) -optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) - -setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) -setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) - --------------------------- -addWay :: Way -> DynP () -addWay w = upd (addWay' w) - -addWay' :: Way -> DynFlags -> DynFlags -addWay' w dflags0 = let platform = targetPlatform dflags0 - dflags1 = dflags0 { ways = w : ways dflags0 } - dflags2 = foldr setGeneralFlag' dflags1 - (wayGeneralFlags platform w) - dflags3 = foldr unSetGeneralFlag' dflags2 - (wayUnsetGeneralFlags platform w) - in dflags3 - -removeWayDyn :: DynP () -removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) - --------------------------- -setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () -setGeneralFlag f = upd (setGeneralFlag' f) -unSetGeneralFlag f = upd (unSetGeneralFlag' f) - -setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags -setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps - where - deps = [ if turn_on then setGeneralFlag' d - else unSetGeneralFlag' d - | (f', turn_on, d) <- impliedGFlags, f' == f ] - -- When you set f, set the ones it implies - -- NB: use setGeneralFlag recursively, in case the implied flags - -- implies further flags - -unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags -unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps - where - deps = [ if turn_on then setGeneralFlag' d - else unSetGeneralFlag' d - | (f', turn_on, d) <- impliedOffGFlags, f' == f ] - -- In general, when you un-set f, we don't un-set the things it implies. - -- There are however some exceptions, e.g., -fno-strictness implies - -- -fno-worker-wrapper. - -- - -- NB: use unSetGeneralFlag' recursively, in case the implied off flags - -- imply further flags. - --------------------------- -setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () -setWarningFlag f = upd (\dfs -> wopt_set dfs f) -unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) - -setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () -setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) -unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) - -setWErrorFlag :: WarningFlag -> DynP () -setWErrorFlag flag = - do { setWarningFlag flag - ; setFatalWarningFlag flag } - --------------------------- -setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () -setExtensionFlag f = upd (setExtensionFlag' f) -unSetExtensionFlag f = upd (unSetExtensionFlag' f) - -setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags -setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps - where - deps = [ if turn_on then setExtensionFlag' d - else unSetExtensionFlag' d - | (f', turn_on, d) <- impliedXFlags, f' == f ] - -- When you set f, set the ones it implies - -- NB: use setExtensionFlag recursively, in case the implied flags - -- implies further flags - -unSetExtensionFlag' f dflags = xopt_unset dflags f - -- When you un-set f, however, we don't un-set the things it implies - -- (except for -fno-glasgow-exts, which is treated specially) - --------------------------- -alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags -alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) } - -alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags -alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } - --------------------------- -setDumpFlag' :: DumpFlag -> DynP () -setDumpFlag' dump_flag - = do upd (\dfs -> dopt_set dfs dump_flag) - when want_recomp forceRecompile - where -- Certain dumpy-things are really interested in what's going - -- on during recompilation checking, so in those cases we - -- don't want to turn it off. - want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, - Opt_D_dump_hi_diffs, - Opt_D_no_debug_output] - -forceRecompile :: DynP () --- Whenver we -ddump, force recompilation (by switching off the --- recompilation checker), else you don't see the dump! However, --- don't switch it off in --make mode, else *everything* gets --- recompiled which probably isn't what you want -forceRecompile = do dfs <- liftEwM getCmdLineState - when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) - where - force_recomp dfs = isOneShot (ghcMode dfs) - - -setVerboseCore2Core :: DynP () -setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core - -setVerbosity :: Maybe Int -> DynP () -setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) - -setDebugLevel :: Maybe Int -> DynP () -setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 }) - -data PkgConfRef - = GlobalPkgConf - | UserPkgConf - | PkgConfFile FilePath - deriving Eq - -addPkgConfRef :: PkgConfRef -> DynP () -addPkgConfRef p = upd $ \s -> - s { packageDBFlags = PackageDB p : packageDBFlags s } - -removeUserPkgConf :: DynP () -removeUserPkgConf = upd $ \s -> - s { packageDBFlags = NoUserPackageDB : packageDBFlags s } - -removeGlobalPkgConf :: DynP () -removeGlobalPkgConf = upd $ \s -> - s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } - -clearPkgConf :: DynP () -clearPkgConf = upd $ \s -> - s { packageDBFlags = ClearPackageDBs : packageDBFlags s } - -parsePackageFlag :: String -- the flag - -> ReadP PackageArg -- type of argument - -> String -- string to parse - -> PackageFlag -parsePackageFlag flag arg_parse str - = case filter ((=="").snd) (readP_to_S parse str) of - [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) - where doc = flag ++ " " ++ str - parse = do - pkg_arg <- tok arg_parse - let mk_expose = ExposePackage doc pkg_arg - ( do _ <- tok $ string "with" - fmap (mk_expose . ModRenaming True) parseRns - <++ fmap (mk_expose . ModRenaming False) parseRns - <++ return (mk_expose (ModRenaming True []))) - parseRns = do _ <- tok $ R.char '(' - rns <- tok $ sepBy parseItem (tok $ R.char ',') - _ <- tok $ R.char ')' - return rns - parseItem = do - orig <- tok $ parseModuleName - (do _ <- tok $ string "as" - new <- tok $ parseModuleName - return (orig, new) - +++ - return (orig, orig)) - tok m = m >>= \x -> skipSpaces >> return x - -exposePackage, exposePackageId, hidePackage, - exposePluginPackage, exposePluginPackageId, - ignorePackage, - trustPackage, distrustPackage :: String -> DynP () -exposePackage p = upd (exposePackage' p) -exposePackageId p = - upd (\s -> s{ packageFlags = - parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) -exposePluginPackage p = - upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) -exposePluginPackageId p = - upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) -hidePackage p = - upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) -ignorePackage p = - upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) - -trustPackage p = exposePackage p >> -- both trust and distrust also expose a package - upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) -distrustPackage p = exposePackage p >> - upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) - -exposePackage' :: String -> DynFlags -> DynFlags -exposePackage' p dflags - = dflags { packageFlags = - parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } - -parsePackageArg :: ReadP PackageArg -parsePackageArg = - fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) - -parseUnitIdArg :: ReadP PackageArg -parseUnitIdArg = - fmap UnitIdArg parseUnitId - -setUnitId :: String -> DynFlags -> DynFlags -setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p } - --- | Given a 'ModuleName' of a signature in the home library, find --- out how it is instantiated. E.g., the canonical form of --- A in @p[A=q[]:A]@ is @q[]:A@. -canonicalizeHomeModule :: DynFlags -> ModuleName -> Module -canonicalizeHomeModule dflags mod_name = - case lookup mod_name (thisUnitIdInsts dflags) of - Nothing -> mkModule (thisPackage dflags) mod_name - Just mod -> mod - -canonicalizeModuleIfHome :: DynFlags -> Module -> Module -canonicalizeModuleIfHome dflags mod - = if thisPackage dflags == moduleUnitId mod - then canonicalizeHomeModule dflags (moduleName mod) - else mod - --- If we're linking a binary, then only targets that produce object --- code are allowed (requests for other target types are ignored). -setTarget :: HscTarget -> DynP () -setTarget l = upd $ \ dfs -> - if ghcLink dfs /= LinkBinary || isObjectTarget l - then dfs{ hscTarget = l } - else dfs - --- Changes the target only if we're compiling object code. This is --- used by -fasm and -fllvm, which switch from one to the other, but --- not from bytecode to object-code. The idea is that -fasm/-fllvm --- can be safely used in an OPTIONS_GHC pragma. -setObjTarget :: HscTarget -> DynP () -setObjTarget l = updM set - where - set dflags - | isObjectTarget (hscTarget dflags) - = return $ dflags { hscTarget = l } - | otherwise = return dflags - -setOptLevel :: Int -> DynFlags -> DynP DynFlags -setOptLevel n dflags = return (updOptLevel n dflags) - -checkOptLevel :: Int -> DynFlags -> Either String DynFlags -checkOptLevel n dflags - | hscTarget dflags == HscInterpreted && n > 0 - = Left "-O conflicts with --interactive; -O ignored." - | otherwise - = Right dflags - -setMainIs :: String -> DynP () -setMainIs arg - | not (null main_fn) && isLower (head main_fn) - -- The arg looked like "Foo.Bar.baz" - = upd $ \d -> d { mainFunIs = Just main_fn, - mainModIs = mkModule mainUnitId (mkModuleName main_mod) } - - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" - = upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) } - - | otherwise -- The arg looked like "baz" - = upd $ \d -> d { mainFunIs = Just arg } - where - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - -addLdInputs :: Option -> DynFlags -> DynFlags -addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} - --- ----------------------------------------------------------------------------- --- Load dynflags from environment files. - -setFlagsFromEnvFile :: FilePath -> String -> DynP () -setFlagsFromEnvFile envfile content = do - setGeneralFlag Opt_HideAllPackages - parseEnvFile envfile content - -parseEnvFile :: FilePath -> String -> DynP () -parseEnvFile envfile = mapM_ parseEntry . lines - where - parseEntry str = case words str of - ("package-db": _) -> addPkgConfRef (PkgConfFile (envdir db)) - -- relative package dbs are interpreted relative to the env file - where envdir = takeDirectory envfile - db = drop 11 str - ["clear-package-db"] -> clearPkgConf - ["global-package-db"] -> addPkgConfRef GlobalPkgConf - ["user-package-db"] -> addPkgConfRef UserPkgConf - ["package-id", pkgid] -> exposePackageId pkgid - (('-':'-':_):_) -> return () -- comments - -- and the original syntax introduced in 7.10: - [pkgid] -> exposePackageId pkgid - [] -> return () - _ -> throwGhcException $ CmdLineError $ - "Can't parse environment file entry: " - ++ envfile ++ ": " ++ str - - ------------------------------------------------------------------------------ --- Paths & Libraries - -addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () - --- -i on its own deletes the import paths -addImportPath "" = upd (\s -> s{importPaths = []}) -addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) - -addLibraryPath p = - upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) - -addIncludePath p = - upd (\s -> s{includePaths = - addGlobalInclude (includePaths s) (splitPathList p)}) - -addFrameworkPath p = - upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) - -#if !defined(mingw32_HOST_OS) -split_marker :: Char -split_marker = ':' -- not configurable (ToDo) -#endif - -splitPathList :: String -> [String] -splitPathList s = filter notNull (splitUp s) - -- empty paths are ignored: there might be a trailing - -- ':' in the initial list, for example. Empty paths can - -- cause confusion when they are translated into -I options - -- for passing to gcc. - where -#if !defined(mingw32_HOST_OS) - splitUp xs = split split_marker xs -#else - -- Windows: 'hybrid' support for DOS-style paths in directory lists. - -- - -- That is, if "foo:bar:baz" is used, this interpreted as - -- consisting of three entries, 'foo', 'bar', 'baz'. - -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted - -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" - -- - -- Notice that no attempt is made to fully replace the 'standard' - -- split marker ':' with the Windows / DOS one, ';'. The reason being - -- that this will cause too much breakage for users & ':' will - -- work fine even with DOS paths, if you're not insisting on being silly. - -- So, use either. - splitUp [] = [] - splitUp (x:':':div:xs) | div `elem` dir_markers - = ((x:':':div:p): splitUp rs) - where - (p,rs) = findNextPath xs - -- we used to check for existence of the path here, but that - -- required the IO monad to be threaded through the command-line - -- parser which is quite inconvenient. The - splitUp xs = cons p (splitUp rs) - where - (p,rs) = findNextPath xs - - cons "" xs = xs - cons x xs = x:xs - - -- will be called either when we've consumed nought or the - -- ":/" part of a DOS path, so splitting is just a Q of - -- finding the next split marker. - findNextPath xs = - case break (`elem` split_markers) xs of - (p, _:ds) -> (p, ds) - (p, xs) -> (p, xs) - - split_markers :: [Char] - split_markers = [':', ';'] - - dir_markers :: [Char] - dir_markers = ['/', '\\'] -#endif - --- ----------------------------------------------------------------------------- --- tmpDir, where we store temporary files. - -setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir } - -- we used to fix /cygdrive/c/.. on Windows, but this doesn't - -- seem necessary now --SDM 7/2/2008 - ------------------------------------------------------------------------------ --- RTS opts - -setRtsOpts :: String -> DynP () -setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} - -setRtsOptsEnabled :: RtsOptsEnabled -> DynP () -setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} - ------------------------------------------------------------------------------ --- Hpc stuff - -setOptHpcDir :: String -> DynP () -setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} - ------------------------------------------------------------------------------ --- Via-C compilation stuff - --- There are some options that we need to pass to gcc when compiling --- Haskell code via C, but are only supported by recent versions of --- gcc. The configure script decides which of these options we need, --- and puts them in the "settings" file in $topdir. The advantage of --- having these in a separate file is that the file can be created at --- install-time depending on the available gcc version, and even --- re-generated later if gcc is upgraded. --- --- The options below are not dependent on the version of gcc, only the --- platform. - -picCCOpts :: DynFlags -> [String] -picCCOpts dflags = pieOpts ++ picOpts - where - picOpts = - case platformOS (targetPlatform dflags) of - OSDarwin - -- Apple prefers to do things the other way round. - -- PIC is on by default. - -- -mdynamic-no-pic: - -- Turn off PIC code generation. - -- -fno-common: - -- Don't generate "common" symbols - these are unwanted - -- in dynamic libraries. - - | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] - | otherwise -> ["-mdynamic-no-pic"] - OSMinGW32 -- no -fPIC for Windows - | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] - | otherwise -> [] - _ - -- we need -fPIC for C files when we are compiling with -dynamic, - -- otherwise things like stub.c files don't get compiled - -- correctly. They need to reference data in the Haskell - -- objects, but can't without -fPIC. See - -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code - | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> - ["-fPIC", "-U__PIC__", "-D__PIC__"] - -- gcc may be configured to have PIC on by default, let's be - -- explicit here, see #15847 - | otherwise -> ["-fno-PIC"] - - pieOpts - | gopt Opt_PICExecutable dflags = ["-pie"] - -- See Note [No PIE when linking] - | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"] - | otherwise = [] - - -{- -Note [No PIE while linking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by -default in their gcc builds. This is incompatible with -r as it implies that we -are producing an executable. Consequently, we must manually pass -no-pie to gcc -when joining object files or linking dynamic libraries. Unless, of course, the -user has explicitly requested a PIE executable with -pie. See #12759. --} - -picPOpts :: DynFlags -> [String] -picPOpts dflags - | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] - | otherwise = [] - --- ----------------------------------------------------------------------------- --- Compiler Info - -compilerInfo :: DynFlags -> [(String, String)] -compilerInfo dflags - = -- We always make "Project name" be first to keep parsing in - -- other languages simple, i.e. when looking for other fields, - -- you don't have to worry whether there is a leading '[' or not - ("Project name", cProjectName) - -- Next come the settings, so anything else can be overridden - -- in the settings file (as "lookup" uses the first match for the - -- key) - : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) - (rawSettings dflags) - ++ [("Project version", projectVersion dflags), - ("Project Git commit id", cProjectGitCommitId), - ("Booter version", cBooterVersion), - ("Stage", cStage), - ("Build platform", cBuildPlatformString), - ("Host platform", cHostPlatformString), - ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), - ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), - ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformMisc_ghcWithNativeCodeGen $ platformMisc dflags), - -- Whether or not we support @-dynamic-too@ - ("Support dynamic-too", showBool $ not isWindows), - -- Whether or not we support the @-j@ flag with @--make@. - ("Support parallel --make", "YES"), - -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in - -- installed package info. - ("Support reexported-modules", "YES"), - -- Whether or not we support extended @-package foo (Foo)@ syntax. - ("Support thinning and renaming package flags", "YES"), - -- Whether or not we support Backpack. - ("Support Backpack", "YES"), - -- If true, we require that the 'id' field in installed package info - -- match what is passed to the @-this-unit-id@ flag for modules - -- built in it - ("Requires unified installed package IDs", "YES"), - -- Whether or not we support the @-this-package-key@ flag. Prefer - -- "Uses unit IDs" over it. - ("Uses package keys", "YES"), - -- Whether or not we support the @-this-unit-id@ flag - ("Uses unit IDs", "YES"), - -- Whether or not GHC compiles libraries as dynamic by default - ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), - -- Whether or not GHC was compiled using -dynamic - ("GHC Dynamic", showBool dynamicGhc), - -- Whether or not GHC was compiled using -prof - ("GHC Profiled", showBool rtsIsProfiled), - ("Debug on", showBool debugIsOn), - ("LibDir", topDir dflags), - -- The path of the global package database used by GHC - ("Global Package DB", systemPackageConfig dflags) - ] - where - showBool True = "YES" - showBool False = "NO" - isWindows = platformOS (targetPlatform dflags) == OSMinGW32 - expandDirectories :: FilePath -> Maybe FilePath -> String -> String - expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd - --- Produced by deriveConstants -#include "GHCConstantsHaskellWrappers.hs" - -bLOCK_SIZE_W :: DynFlags -> Int -bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags - -wORD_SIZE_IN_BITS :: DynFlags -> Int -wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 - -wordAlignment :: DynFlags -> Alignment -wordAlignment dflags = alignmentOf (wORD_SIZE dflags) - -tAG_MASK :: DynFlags -> Int -tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 - -mAX_PTR_TAG :: DynFlags -> Int -mAX_PTR_TAG = tAG_MASK - --- Might be worth caching these in targetPlatform? -tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer -tARGET_MIN_INT dflags - = case platformWordSize (targetPlatform dflags) of - PW4 -> toInteger (minBound :: Int32) - PW8 -> toInteger (minBound :: Int64) -tARGET_MAX_INT dflags - = case platformWordSize (targetPlatform dflags) of - PW4 -> toInteger (maxBound :: Int32) - PW8 -> toInteger (maxBound :: Int64) -tARGET_MAX_WORD dflags - = case platformWordSize (targetPlatform dflags) of - PW4 -> toInteger (maxBound :: Word32) - PW8 -> toInteger (maxBound :: Word64) - - -{- ----------------------------------------------------------------------------- -Note [DynFlags consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a number of number of DynFlags configurations which either -do not make sense or lead to unimplemented or buggy codepaths in the -compiler. makeDynFlagsConsistent is responsible for verifying the validity -of a set of DynFlags, fixing any issues, and reporting them back to the -caller. - -GHCi and -O ---------------- - -When using optimization, the compiler can introduce several things -(such as unboxed tuples) into the intermediate code, which GHCi later -chokes on since the bytecode interpreter can't handle this (and while -this is arguably a bug these aren't handled, there are no plans to fix -it.) - -While the driver pipeline always checks for this particular erroneous -combination when parsing flags, we also need to check when we update -the flags; this is because API clients may parse flags but update the -DynFlags afterwords, before finally running code inside a session (see -T10052 and #10052). --} - --- | Resolve any internal inconsistencies in a set of 'DynFlags'. --- Returns the consistent 'DynFlags' as well as a list of warnings --- to report to the user. -makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) --- Whenever makeDynFlagsConsistent does anything, it starts over, to --- ensure that a later change doesn't invalidate an earlier check. --- Be careful not to introduce potential loops! -makeDynFlagsConsistent dflags - -- Disable -dynamic-too on Windows (#8228, #7134, #5987) - | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags - = let dflags' = gopt_unset dflags Opt_BuildDynamicToo - warn = "-dynamic-too is not supported on Windows" - in loop dflags' warn - | hscTarget dflags == HscC && - not (platformUnregisterised (targetPlatform dflags)) - = if platformMisc_ghcWithNativeCodeGen $ platformMisc dflags - then let dflags' = dflags { hscTarget = HscAsm } - warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" - in loop dflags' warn - else let dflags' = dflags { hscTarget = HscLlvm } - warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" - in loop dflags' warn - | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted - = let dflags' = gopt_unset dflags Opt_Hpc - warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." - in loop dflags' warn - | hscTarget dflags `elem` [HscAsm, HscLlvm] && - platformUnregisterised (targetPlatform dflags) - = loop (dflags { hscTarget = HscC }) - "Compiler unregisterised, so compiling via C" - | hscTarget dflags == HscAsm && - not (platformMisc_ghcWithNativeCodeGen $ platformMisc dflags) - = let dflags' = dflags { hscTarget = HscLlvm } - warn = "No native code generator, so using LLVM" - in loop dflags' warn - | not (osElfTarget os) && gopt Opt_PIE dflags - = loop (gopt_unset dflags Opt_PIE) - "Position-independent only supported on ELF platforms" - | os == OSDarwin && - arch == ArchX86_64 && - not (gopt Opt_PIC dflags) - = loop (gopt_set dflags Opt_PIC) - "Enabling -fPIC as it is always on for this platform" - | Left err <- checkOptLevel (optLevel dflags) dflags - = loop (updOptLevel 0 dflags) err - - | LinkInMemory <- ghcLink dflags - , not (gopt Opt_ExternalInterpreter dflags) - , rtsIsProfiled - , isObjectTarget (hscTarget dflags) - , WayProf `notElem` ways dflags - = loop dflags{ways = WayProf : ways dflags} - "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" - - | otherwise = (dflags, []) - where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") - loop updated_dflags warning - = case makeDynFlagsConsistent updated_dflags of - (dflags', ws) -> (dflags', L loc warning : ws) - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - - --------------------------------------------------------------------------- --- Do not use unsafeGlobalDynFlags! --- --- unsafeGlobalDynFlags is a hack, necessary because we need to be able --- to show SDocs when tracing, but we don't always have DynFlags --- available. --- --- Do not use it if you can help it. You may get the wrong value, or this --- panic! - --- | This is the value that 'unsafeGlobalDynFlags' takes before it is --- initialized. -defaultGlobalDynFlags :: DynFlags -defaultGlobalDynFlags = - (defaultDynFlags settings llvmConfig) { verbosity = 2 } - where - settings = panic "v_unsafeGlobalDynFlags: settings not initialised" - llvmConfig = panic "v_unsafeGlobalDynFlags: llvmConfig not initialised" - -#if GHC_STAGE < 2 -GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) -#else -SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags - , getOrSetLibHSghcGlobalDynFlags - , "getOrSetLibHSghcGlobalDynFlags" - , defaultGlobalDynFlags - , DynFlags ) -#endif - -unsafeGlobalDynFlags :: DynFlags -unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags - -setUnsafeGlobalDynFlags :: DynFlags -> IO () -setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags - --- ----------------------------------------------------------------------------- --- SSE and AVX - --- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to --- check if SSE is enabled, we might have x86-64 imply the -msse2 --- flag. - -data SseVersion = SSE1 - | SSE2 - | SSE3 - | SSE4 - | SSE42 - deriving (Eq, Ord) - -isSseEnabled :: DynFlags -> Bool -isSseEnabled dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> True - ArchX86 -> True - _ -> False - -isSse2Enabled :: DynFlags -> Bool -isSse2Enabled dflags = case platformArch (targetPlatform dflags) of - -- We Assume SSE1 and SSE2 operations are available on both - -- x86 and x86_64. Historically we didn't default to SSE2 and - -- SSE1 on x86, which results in defacto nondeterminism for how - -- rounding behaves in the associated x87 floating point instructions - -- because variations in the spill/fpu stack placement of arguments for - -- operations would change the precision and final result of what - -- would otherwise be the same expressions with respect to single or - -- double precision IEEE floating point computations. - ArchX86_64 -> True - ArchX86 -> True - _ -> False - - -isSse4_2Enabled :: DynFlags -> Bool -isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 - -isAvxEnabled :: DynFlags -> Bool -isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags - -isAvx2Enabled :: DynFlags -> Bool -isAvx2Enabled dflags = avx2 dflags || avx512f dflags - -isAvx512cdEnabled :: DynFlags -> Bool -isAvx512cdEnabled dflags = avx512cd dflags - -isAvx512erEnabled :: DynFlags -> Bool -isAvx512erEnabled dflags = avx512er dflags - -isAvx512fEnabled :: DynFlags -> Bool -isAvx512fEnabled dflags = avx512f dflags - -isAvx512pfEnabled :: DynFlags -> Bool -isAvx512pfEnabled dflags = avx512pf dflags - --- ----------------------------------------------------------------------------- --- BMI2 - -data BmiVersion = BMI1 - | BMI2 - deriving (Eq, Ord) - -isBmiEnabled :: DynFlags -> Bool -isBmiEnabled dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> bmiVersion dflags >= Just BMI1 - ArchX86 -> bmiVersion dflags >= Just BMI1 - _ -> False - -isBmi2Enabled :: DynFlags -> Bool -isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> bmiVersion dflags >= Just BMI2 - ArchX86 -> bmiVersion dflags >= Just BMI2 - _ -> False - --- ----------------------------------------------------------------------------- --- Linker/compiler information - --- LinkerInfo contains any extra options needed by the system linker. -data LinkerInfo - = GnuLD [Option] - | GnuGold [Option] - | LlvmLLD [Option] - | DarwinLD [Option] - | SolarisLD [Option] - | AixLD [Option] - | UnknownLD - deriving Eq - --- CompilerInfo tells us which C compiler we're using -data CompilerInfo - = GCC - | Clang - | AppleClang - | AppleClang51 - | UnknownCC - deriving Eq - - --- | Should we use `-XLinker -rpath` when linking or not? --- See Note [-fno-use-rpaths] -useXLinkerRPath :: DynFlags -> OS -> Bool -useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS] -useXLinkerRPath dflags _ = gopt Opt_RPath dflags - -{- -Note [-fno-use-rpaths] -~~~~~~~~~~~~~~~~~~~~~~ - -First read, Note [Dynamic linking on macOS] to understand why on darwin we never -use `-XLinker -rpath`. - -The specification of `Opt_RPath` is as follows: - -The default case `-fuse-rpaths`: -* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath - afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin - as things stand but it wasn't documented in the user guide before this patch how - `-fuse-rpaths` should behave and the fact it was always disabled on darwin. -* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable, - this is the normal way you should set the rpath. - -The case of `-fno-use-rpaths` -* Never inject anything into the rpath. - -When this was first implemented, `Opt_RPath` was disabled on darwin, but -the rpath was still always augmented by `runInjectRPaths`, and there was no way to -stop this. This was problematic because you couldn't build an executable in CI -with a clean rpath. - --} - --- ----------------------------------------------------------------------------- --- RTS hooks - --- Convert sizes like "3.5M" into integers -decodeSize :: String -> Integer -decodeSize str - | c == "" = truncate n - | c == "K" || c == "k" = truncate (n * 1000) - | c == "M" || c == "m" = truncate (n * 1000 * 1000) - | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) - | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) - where (m, c) = span pred str - n = readRational m - pred c = isDigit c || c == '.' - -foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () -foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () - --- ----------------------------------------------------------------------------- --- Types for managing temporary files. --- --- these are here because FilesToClean is used in DynFlags - --- | A collection of files that must be deleted before ghc exits. --- The current collection --- is stored in an IORef in DynFlags, 'filesToClean'. -data FilesToClean = FilesToClean { - ftcGhcSession :: !(Set FilePath), - -- ^ Files that will be deleted at the end of runGhc(T) - ftcCurrentModule :: !(Set FilePath) - -- ^ Files that will be deleted the next time - -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the - -- end of the session. - } - --- | An empty FilesToClean -emptyFilesToClean :: FilesToClean -emptyFilesToClean = FilesToClean Set.empty Set.empty diff --git a/main/DynFlags.hs-boot b/main/DynFlags.hs-boot deleted file mode 100644 --- a/main/DynFlags.hs-boot +++ /dev/null @@ -1,20 +0,0 @@ -module DynFlags where - -import GhcPrelude -import GHC.Platform - -data DynFlags -data DumpFlag -data GeneralFlag - -targetPlatform :: DynFlags -> Platform -pprUserLength :: DynFlags -> Int -pprCols :: DynFlags -> Int -unsafeGlobalDynFlags :: DynFlags -useUnicode :: DynFlags -> Bool -useUnicodeSyntax :: DynFlags -> Bool -useStarIsType :: DynFlags -> Bool -shouldUseColor :: DynFlags -> Bool -shouldUseHexWordLiterals :: DynFlags -> Bool -hasPprDebug :: DynFlags -> Bool -hasNoDebugOutput :: DynFlags -> Bool diff --git a/main/DynamicLoading.hs b/main/DynamicLoading.hs deleted file mode 100644 --- a/main/DynamicLoading.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} - --- | Dynamically lookup up values from modules and loading them. -module DynamicLoading ( - initializePlugins, - -- * Loading plugins - loadFrontendPlugin, - - -- * Force loading information - forceLoadModuleInterfaces, - forceLoadNameModuleInterface, - forceLoadTyCon, - - -- * Finding names - lookupRdrNameInModuleForPlugins, - - -- * Loading values - getValueSafely, - getHValueSafely, - lessUnsafeCoerce - ) where - -import GhcPrelude -import DynFlags - -import Linker ( linkModule, getHValue ) -import GHCi ( wormhole ) -import SrcLoc ( noSrcSpan ) -import Finder ( findPluginModule, cannotFindModule ) -import TcRnMonad ( initTcInteractive, initIfaceTcRn ) -import LoadIface ( loadPluginInterface ) -import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , gre_name, mkRdrQual ) -import OccName ( OccName, mkVarOcc ) -import RnNames ( gresFromAvails ) -import Plugins -import PrelNames ( pluginTyConName, frontendPluginTyConName ) - -import HscTypes -import GHCi.RemoteTypes ( HValue ) -import Type ( Type, eqType, mkTyConTy ) -import TyCoPpr ( pprTyThingCategory ) -import TyCon ( TyCon ) -import Name ( Name, nameModule_maybe ) -import Id ( idType ) -import Module ( Module, ModuleName ) -import Panic -import FastString -import ErrUtils -import Outputable -import Exception -import Hooks - -import Control.Monad ( when, unless ) -import Data.Maybe ( mapMaybe ) -import GHC.Exts ( unsafeCoerce# ) - --- | Loads the plugins specified in the pluginModNames field of the dynamic --- flags. Should be called after command line arguments are parsed, but before --- actual compilation starts. Idempotent operation. Should be re-called if --- pluginModNames or pluginModNameOpts changes. -initializePlugins :: HscEnv -> DynFlags -> IO DynFlags -initializePlugins hsc_env df - | map lpModuleName (cachedPlugins df) - == pluginModNames df -- plugins not changed - && all (\p -> paArguments (lpPlugin p) - == argumentsForPlugin p (pluginModNameOpts df)) - (cachedPlugins df) -- arguments not changed - = return df -- no need to reload plugins - | otherwise - = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) - let df' = df { cachedPlugins = loadedPlugins } - df'' <- withPlugins df' runDflagsPlugin df' - return df'' - - where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) - runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags - -loadPlugins :: HscEnv -> IO [LoadedPlugin] -loadPlugins hsc_env - = do { unless (null to_load) $ - checkExternalInterpreter hsc_env - ; plugins <- mapM loadPlugin to_load - ; return $ zipWith attachOptions to_load plugins } - where - dflags = hsc_dflags hsc_env - to_load = pluginModNames dflags - - attachOptions mod_nm (plug, mod) = - LoadedPlugin (PluginWithArgs plug (reverse options)) mod - where - options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags - , opt_mod_nm == mod_nm ] - loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env - - -loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin -loadFrontendPlugin hsc_env mod_name = do - checkExternalInterpreter hsc_env - fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName - hsc_env mod_name - --- #14335 -checkExternalInterpreter :: HscEnv -> IO () -checkExternalInterpreter hsc_env = - when (gopt Opt_ExternalInterpreter dflags) $ - throwCmdLineError $ showSDoc dflags $ - text "Plugins require -fno-external-interpreter" - where - dflags = hsc_dflags hsc_env - -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) -loadPlugin' occ_name plugin_name hsc_env mod_name - = do { let plugin_rdr_name = mkRdrQual mod_name occ_name - dflags = hsc_dflags hsc_env - ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name - plugin_rdr_name - ; case mb_name of { - Nothing -> - throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ text "The module", ppr mod_name - , text "did not export the plugin name" - , ppr plugin_rdr_name ]) ; - Just (name, mod_iface) -> - - do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name - ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) - ; case mb_plugin of - Nothing -> - throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ text "The value", ppr name - , text "did not have the type" - , ppr pluginTyConName, text "as required"]) - Just plugin -> return (plugin, mod_iface) } } } - - --- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used --- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. -forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () -forceLoadModuleInterfaces hsc_env doc modules - = (initTcInteractive hsc_env $ - initIfaceTcRn $ - mapM_ (loadPluginInterface doc) modules) - >> return () - --- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used --- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. -forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () -forceLoadNameModuleInterface hsc_env reason name = do - let name_modules = mapMaybe nameModule_maybe [name] - forceLoadModuleInterfaces hsc_env reason name_modules - --- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: --- --- * The interface could not be loaded --- * The name is not that of a 'TyCon' --- * The name did not exist in the loaded module -forceLoadTyCon :: HscEnv -> Name -> IO TyCon -forceLoadTyCon hsc_env con_name = do - forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name - - mb_con_thing <- lookupTypeHscEnv hsc_env con_name - case mb_con_thing of - Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name - Just (ATyCon tycon) -> return tycon - Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing - where dflags = hsc_dflags hsc_env - --- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety --- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! --- --- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: --- --- * If we could not load the names module --- * If the thing being loaded is not a value --- * If the Name does not exist in the module --- * If the link failed - -getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) -getValueSafely hsc_env val_name expected_type = do - mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type - case mb_hval of - Nothing -> return Nothing - Just hval -> do - value <- lessUnsafeCoerce dflags "getValueSafely" hval - return (Just value) - where - dflags = hsc_dflags hsc_env - -getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) -getHValueSafely hsc_env val_name expected_type = do - forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name - -- Now look up the names for the value and type constructor in the type environment - mb_val_thing <- lookupTypeHscEnv hsc_env val_name - case mb_val_thing of - Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name - Just (AnId id) -> do - -- Check the value type in the interface against the type recovered from the type constructor - -- before finally casting the value to the type we assume corresponds to that constructor - if expected_type `eqType` idType id - then do - -- Link in the module that contains the value, if it has such a module - case nameModule_maybe val_name of - Just mod -> do linkModule hsc_env mod - return () - Nothing -> return () - -- Find the value that we just linked in and cast it given that we have proved it's type - hval <- getHValue hsc_env val_name >>= wormhole dflags - return (Just hval) - else return Nothing - Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing - where dflags = hsc_dflags hsc_env - --- | Coerce a value as usual, but: --- --- 1) Evaluate it immediately to get a segfault early if the coercion was wrong --- --- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened --- if it /does/ segfault -lessUnsafeCoerce :: DynFlags -> String -> a -> IO b -lessUnsafeCoerce dflags context what = do - debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> - (text "...") - output <- evaluate (unsafeCoerce# what) - debugTraceMsg dflags 3 (text "Successfully evaluated coercion") - return output - - --- | Finds the 'Name' corresponding to the given 'RdrName' in the --- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' --- could be found. Any other condition results in an exception: --- --- * If the module could not be found --- * If we could not determine the imports of the module --- --- Can only be used for looking up names while loading plugins (and is --- *not* suitable for use within plugins). The interface file is --- loaded very partially: just enough that it can be used, without its --- rules and instances affecting (and being linked from!) the module --- being compiled. This was introduced by 57d6798. --- --- Need the module as well to record information in the interface file -lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName - -> IO (Maybe (Name, ModIface)) -lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do - -- First find the package the module resides in by searching exposed packages and home modules - found_module <- findPluginModule hsc_env mod_name - case found_module of - Found _ mod -> do - -- Find the exports of the module - (_, mb_iface) <- initTcInteractive hsc_env $ - initIfaceTcRn $ - loadPluginInterface doc mod - case mb_iface of - Just iface -> do - -- Try and find the required name in the exports - let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name - , is_qual = False, is_dloc = noSrcSpan } - imp_spec = ImpSpec decl_spec ImpAll - env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) - case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (gre_name gre, iface)) - [] -> return Nothing - _ -> panic "lookupRdrNameInModule" - - Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env - doc = text "contains a name used in an invocation of lookupRdrNameInModule" - -wrongTyThingError :: Name -> TyThing -> SDoc -wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] - -missingTyThingError :: Name -> SDoc -missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] - -throwCmdLineErrorS :: DynFlags -> SDoc -> IO a -throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags - -throwCmdLineError :: String -> IO a -throwCmdLineError = throwGhcExceptionIO . CmdLineError diff --git a/main/Elf.hs b/main/Elf.hs deleted file mode 100644 --- a/main/Elf.hs +++ /dev/null @@ -1,479 +0,0 @@ -{-# LANGUAGE CPP #-} -{- ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2015 --- --- ELF format tools --- ------------------------------------------------------------------------------ --} - -module Elf ( - readElfSectionByName, - readElfNoteAsString, - makeElfNote - ) where - -#include -#include "HsVersions.h" - -import GhcPrelude - -import AsmUtils -import Exception -import DynFlags -import ErrUtils -import Maybes (MaybeT(..),runMaybeT) -import Util (charToC) -import Outputable (text,hcat,SDoc) - -import Control.Monad (when) -import Data.Binary.Get -import Data.Word -import Data.Char (ord) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as B8 - -{- Note [ELF specification] - ~~~~~~~~~~~~~~~~~~~~~~~~ - - ELF (Executable and Linking Format) is described in the System V Application - Binary Interface (or ABI). The latter is composed of two parts: a generic - part and a processor specific part. The generic ABI describes the parts of - the interface that remain constant across all hardware implementations of - System V. - - The latest release of the specification of the generic ABI is the version - 4.1 from March 18, 1997: - - - http://www.sco.com/developers/devspecs/gabi41.pdf - - Since 1997, snapshots of the draft for the "next" version are published: - - - http://www.sco.com/developers/gabi/ - - Quoting the notice on the website: "There is more than one instance of these - chapters to permit references to older instances to remain valid. All - modifications to these chapters are forward-compatible, so that correct use - of an older specification will not be invalidated by a newer instance. - Approximately on a yearly basis, a new instance will be saved, as it reaches - what appears to be a stable state." - - Nevertheless we will see that since 1998 it is not true for Note sections. - - Many ELF sections - ----------------- - - ELF-4.1: the normal section number fields in ELF are limited to 16 bits, - which runs out of bits when you try to cram in more sections than that. Two - fields are concerned: the one containing the number of the sections and the - one containing the index of the section that contains section's names. (The - same thing applies to the field containing the number of segments, but we - don't care about it here). - - ELF-next: to solve this, theses fields in the ELF header have an escape - value (different for each case), and the actual section number is stashed - into unused fields in the first section header. - - We support this extension as it is forward-compatible with ELF-4.1. - Moreover, GHC may generate objects with a lot of sections with the - "function-sections" feature (one section per function). - - Note sections - ------------- - - Sections with type "note" (SHT_NOTE in the specification) are used to add - arbitrary data into an ELF file. An entry in a note section is composed of a - name, a type and a value. - - ELF-4.1: "The note information in sections and program header elements holds - any number of entries, each of which is an array of 4-byte words in the - format of the target processor." Each entry has the following format: - | namesz | Word32: size of the name string (including the ending \0) - | descsz | Word32: size of the value - | type | Word32: type of the note - | name | Name string (with \0 padding to ensure 4-byte alignment) - | ... | - | desc | Value (with \0 padding to ensure 4-byte alignment) - | ... | - - ELF-next: "The note information in sections and program header elements - holds a variable amount of entries. In 64-bit objects (files with - e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte - words in the format of the target processor. In 32-bit objects (files with - e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte - words in the format of the target processor." (from 1998-2015 snapshots) - - This is not forward-compatible with ELF-4.1. In practice, for almost all - platforms namesz, descz and type fields are 4-byte words for both 32-bit and - 64-bit objects (see elf.h and readelf source code). - - The only exception in readelf source code is for IA_64 machines with OpenVMS - OS: "This OS has so many departures from the ELF standard that we test it at - many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz, - descsz and type fields are 8-byte words and name and value fields are padded - to ensure 8-byte alignment. - - We don't support this platform in the following code. Reading a note section - could be done easily (by testing Machine and OS fields in the ELF header). - Writing a note section, however, requires that we generate a different - assembly code for GAS depending on the target platform and this is a little - bit more involved. - --} - - --- | ELF header --- --- The ELF header indicates the native word size (32-bit or 64-bit) and the --- endianness of the target machine. We directly store getters for words of --- different sizes as it is more convenient to use. We also store the word size --- as it is useful to skip some uninteresting fields. --- --- Other information such as the target machine and OS are left out as we don't --- use them yet. We could add them in the future if we ever need them. -data ElfHeader = ElfHeader - { gw16 :: Get Word16 -- ^ Get a Word16 with the correct endianness - , gw32 :: Get Word32 -- ^ Get a Word32 with the correct endianness - , gwN :: Get Word64 -- ^ Get a Word with the correct word size - -- and endianness - , wordSize :: Int -- ^ Word size in bytes - } - - --- | Read the ELF header -readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader) -readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF header") - return Nothing - where - getHeader = do - magic <- getWord32be - ws <- getWord8 - endian <- getWord8 - version <- getWord8 - skip 9 -- skip OSABI, ABI version and padding - when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header" - - case (ws, endian) of - -- ELF 32, little endian - (1,1) -> return . Just $ ElfHeader - getWord16le - getWord32le - (fmap fromIntegral getWord32le) 4 - -- ELF 32, big endian - (1,2) -> return . Just $ ElfHeader - getWord16be - getWord32be - (fmap fromIntegral getWord32be) 4 - -- ELF 64, little endian - (2,1) -> return . Just $ ElfHeader - getWord16le - getWord32le - (fmap fromIntegral getWord64le) 8 - -- ELF 64, big endian - (2,2) -> return . Just $ ElfHeader - getWord16be - getWord32be - (fmap fromIntegral getWord64be) 8 - _ -> fail "Invalid ELF header" - - ------------------- --- SECTIONS ------------------- - - --- | Description of the section table -data SectionTable = SectionTable - { sectionTableOffset :: Word64 -- ^ offset of the table describing sections - , sectionEntrySize :: Word16 -- ^ size of an entry in the section table - , sectionEntryCount :: Word64 -- ^ number of sections - , sectionNameIndex :: Word32 -- ^ index of a special section which - -- contains section's names - } - --- | Read the ELF section table -readElfSectionTable :: DynFlags - -> ElfHeader - -> ByteString - -> IO (Maybe SectionTable) - -readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section table") - return Nothing - where - getSectionTable :: Get SectionTable - getSectionTable = do - skip (24 + 2*wordSize hdr) -- skip header and some other fields - secTableOffset <- gwN hdr - skip 10 - entrySize <- gw16 hdr - entryCount <- gw16 hdr - secNameIndex <- gw16 hdr - return (SectionTable secTableOffset entrySize - (fromIntegral entryCount) - (fromIntegral secNameIndex)) - - action = do - secTable <- runGetOrThrow getSectionTable bs - -- In some cases, the number of entries and the index of the section - -- containing section's names must be found in unused fields of the first - -- section entry (see Note [ELF specification]) - let - offSize0 = fromIntegral $ sectionTableOffset secTable + 8 - + 3 * fromIntegral (wordSize hdr) - offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr) - - entryCount' <- if sectionEntryCount secTable /= 0 - then return (sectionEntryCount secTable) - else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs) - entryNameIndex' <- if sectionNameIndex secTable /= 0xffff - then return (sectionNameIndex secTable) - else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs) - return (Just $ secTable - { sectionEntryCount = entryCount' - , sectionNameIndex = entryNameIndex' - }) - - --- | A section -data Section = Section - { entryName :: ByteString -- ^ Name of the section - , entryBS :: ByteString -- ^ Content of the section - } - --- | Read a ELF section -readElfSectionByIndex :: DynFlags - -> ElfHeader - -> SectionTable - -> Word64 - -> ByteString - -> IO (Maybe Section) - -readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section") - return Nothing - where - -- read an entry from the section table - getEntry = do - nameIndex <- gw32 hdr - skip (4+2*wordSize hdr) - offset <- fmap fromIntegral $ gwN hdr - size <- fmap fromIntegral $ gwN hdr - let bs' = LBS.take size (LBS.drop offset bs) - return (nameIndex,bs') - - -- read the entry with the given index in the section table - getEntryByIndex x = runGetOrThrow getEntry bs' - where - bs' = LBS.drop off bs - off = fromIntegral $ sectionTableOffset secTable + - x * fromIntegral (sectionEntrySize secTable) - - -- Get the name of a section - getEntryName nameIndex = do - let idx = fromIntegral (sectionNameIndex secTable) - (_,nameTable) <- getEntryByIndex idx - let bs' = LBS.drop nameIndex nameTable - runGetOrThrow getLazyByteStringNul bs' - - action = do - (nameIndex,bs') <- getEntryByIndex (fromIntegral i) - name <- getEntryName (fromIntegral nameIndex) - return (Just $ Section name bs') - - --- | Find a section from its name. Return the section contents. --- --- We do not perform any check on the section type. -findSectionFromName :: DynFlags - -> ElfHeader - -> SectionTable - -> String - -> ByteString - -> IO (Maybe ByteString) -findSectionFromName dflags hdr secTable name bs = - rec [0..sectionEntryCount secTable - 1] - where - -- convert the required section name into a ByteString to perform - -- ByteString comparison instead of String comparison - name' = B8.pack name - - -- compare recursively each section name and return the contents of - -- the matching one, if any - rec [] = return Nothing - rec (x:xs) = do - me <- readElfSectionByIndex dflags hdr secTable x bs - case me of - Just e | entryName e == name' -> return (Just (entryBS e)) - _ -> rec xs - - --- | Given a section name, read its contents as a ByteString. --- --- If the section isn't found or if there is any parsing error, we return --- Nothing -readElfSectionByName :: DynFlags - -> ByteString - -> String - -> IO (Maybe LBS.ByteString) - -readElfSectionByName dflags bs name = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF section \"" ++ name ++ "\"") - return Nothing - where - action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - secTable <- MaybeT $ readElfSectionTable dflags hdr bs - MaybeT $ findSectionFromName dflags hdr secTable name bs - ------------------- --- NOTE SECTIONS ------------------- - --- | read a Note as a ByteString --- --- If you try to read a note from a section which does not support the Note --- format, the parsing is likely to fail and Nothing will be returned -readElfNoteBS :: DynFlags - -> ByteString - -> String - -> String - -> IO (Maybe LBS.ByteString) - -readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF note \"" ++ noteId ++ - "\" in section \"" ++ sectionName ++ "\"") - return Nothing - where - -- align the getter on n bytes - align n = do - m <- bytesRead - if m `mod` n == 0 - then return () - else skip 1 >> align n - - -- noteId as a bytestring - noteId' = B8.pack noteId - - -- read notes recursively until the one with a valid identifier is found - findNote hdr = do -#if defined(aarch64_HOST_ARCH) - align 8 -#else - align 4 -#endif - namesz <- gw32 hdr - descsz <- gw32 hdr - _ <- gw32 hdr -- we don't use the note type - name <- if namesz == 0 - then return LBS.empty - else getLazyByteStringNul -#if defined(aarch64_HOST_ARCH) - align 8 -#else - align 4 -#endif - desc <- if descsz == 0 - then return LBS.empty - else getLazyByteString (fromIntegral descsz) - if name == noteId' - then return $ Just desc - else findNote hdr - - - action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - sec <- MaybeT $ readElfSectionByName dflags bs sectionName - MaybeT $ runGetOrThrow (findNote hdr) sec - --- | read a Note as a String --- --- If you try to read a note from a section which does not support the Note --- format, the parsing is likely to fail and Nothing will be returned -readElfNoteAsString :: DynFlags - -> FilePath - -> String - -> String - -> IO (Maybe String) - -readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ - text ("Unable to read ELF note \"" ++ noteId ++ - "\" in section \"" ++ sectionName ++ "\"") - return Nothing - where - action = do - bs <- LBS.readFile path - note <- readElfNoteBS dflags bs sectionName noteId - return (fmap B8.unpack note) - - --- | Generate the GAS code to create a Note section --- --- Header fields for notes are 32-bit long (see Note [ELF specification]). --- --- It seems there is no easy way to force GNU AS to generate a 32-bit word in --- every case. Hence we use .int directive to create them: however "The byte --- order and bit size of the number depends on what kind of target the assembly --- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int) --- --- If we add new target platforms, we need to check that the generated words --- are 32-bit long, otherwise we need to use platform specific directives to --- force 32-bit .int in asWord32. -makeElfNote :: String -> String -> Word32 -> String -> SDoc -makeElfNote sectionName noteName typ contents = hcat [ - text "\t.section ", - text sectionName, - text ",\"\",", - sectionType "note", - text "\n", - - -- note name length (+ 1 for ending \0) - asWord32 (length noteName + 1), - - -- note contents size - asWord32 (length contents), - - -- note type - asWord32 typ, - - -- note name (.asciz for \0 ending string) + padding - text "\t.asciz \"", - text noteName, - text "\"\n", - text "\t.align 4\n", - - -- note contents (.ascii to avoid ending \0) + padding - text "\t.ascii \"", - text (escape contents), - text "\"\n", - text "\t.align 4\n"] - where - escape :: String -> String - escape = concatMap (charToC.fromIntegral.ord) - - asWord32 :: Show a => a -> SDoc - asWord32 x = hcat [ - text "\t.int ", - text (show x), - text "\n"] - - ------------------- --- Helpers ------------------- - --- | runGet in IO monad that throws an IOException on failure -runGetOrThrow :: Get a -> LBS.ByteString -> IO a -runGetOrThrow g bs = case runGetOrFail g bs of - Left _ -> fail "Error while reading file" - Right (_,_,a) -> return a diff --git a/main/ErrUtils.hs b/main/ErrUtils.hs deleted file mode 100644 --- a/main/ErrUtils.hs +++ /dev/null @@ -1,921 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[ErrsUtils]{Utilities for error reporting} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} - -module ErrUtils ( - -- * Basic types - Validity(..), andValid, allValid, isValid, getInvalids, orValid, - Severity(..), - - -- * Messages - ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason, - ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary, - WarnMsg, MsgDoc, - Messages, ErrorMessages, WarningMessages, - unionMessages, - errMsgSpan, errMsgContext, - errorsFound, isEmptyMessages, - isWarnMsgFatal, - warningsToMessages, - - -- ** Formatting - pprMessageBag, pprErrMsgBagWithLoc, - pprLocErrMsg, printBagOfErrors, - formatErrDoc, - - -- ** Construction - emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, - mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg, - mkPlainWarnMsg, - mkLongWarnMsg, - - -- * Utilities - doIfSet, doIfSet_dyn, - getCaretDiagnostic, - - -- * Dump files - dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, - mkDumpDoc, dumpSDoc, dumpSDocForUser, - dumpSDocWithStyle, - - -- * Issuing messages during compilation - putMsg, printInfoForUser, printOutputForUser, - logInfo, logOutput, - errorMsg, warningMsg, - fatalErrorMsg, fatalErrorMsg'', - compilationProgressMsg, - showPass, - withTiming, withTimingSilent, withTimingD, withTimingSilentD, - debugTraceMsg, - ghcExit, - prettyPrintGhcErrors, - traceCmd - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import Exception -import Outputable -import Panic -import qualified PprColour as Col -import SrcLoc -import DynFlags -import FastString (unpackFS) -import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) -import Json - -import System.Directory -import System.Exit ( ExitCode(..), exitWith ) -import System.FilePath ( takeDirectory, () ) -import Data.List -import qualified Data.Set as Set -import Data.IORef -import Data.Maybe ( fromMaybe ) -import Data.Ord -import Data.Time -import Debug.Trace -import Control.Monad -import Control.Monad.IO.Class -import System.IO -import System.IO.Error ( catchIOError ) -import GHC.Conc ( getAllocationCounter ) -import System.CPUTime - -------------------------- -type MsgDoc = SDoc - -------------------------- -data Validity - = IsValid -- ^ Everything is fine - | NotValid MsgDoc -- ^ A problem, and some indication of why - -isValid :: Validity -> Bool -isValid IsValid = True -isValid (NotValid {}) = False - -andValid :: Validity -> Validity -> Validity -andValid IsValid v = v -andValid v _ = v - --- | If they aren't all valid, return the first -allValid :: [Validity] -> Validity -allValid [] = IsValid -allValid (v : vs) = v `andValid` allValid vs - -getInvalids :: [Validity] -> [MsgDoc] -getInvalids vs = [d | NotValid d <- vs] - -orValid :: Validity -> Validity -> Validity -orValid IsValid _ = IsValid -orValid _ v = v - --- ----------------------------------------------------------------------------- --- Basic error messages: just render a message with a source location. - -type Messages = (WarningMessages, ErrorMessages) -type WarningMessages = Bag WarnMsg -type ErrorMessages = Bag ErrMsg - -unionMessages :: Messages -> Messages -> Messages -unionMessages (warns1, errs1) (warns2, errs2) = - (warns1 `unionBags` warns2, errs1 `unionBags` errs2) - -data ErrMsg = ErrMsg { - errMsgSpan :: SrcSpan, - errMsgContext :: PrintUnqualified, - errMsgDoc :: ErrDoc, - -- | This has the same text as errDocImportant . errMsgDoc. - errMsgShortString :: String, - errMsgSeverity :: Severity, - errMsgReason :: WarnReason - } - -- The SrcSpan is used for sorting errors into line-number order - - --- | Categorise error msgs by their importance. This is so each section can --- be rendered visually distinct. See Note [Error report] for where these come --- from. -data ErrDoc = ErrDoc { - -- | Primary error msg. - errDocImportant :: [MsgDoc], - -- | Context e.g. \"In the second argument of ...\". - errDocContext :: [MsgDoc], - -- | Supplementary information, e.g. \"Relevant bindings include ...\". - errDocSupplementary :: [MsgDoc] - } - -errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc -errDoc = ErrDoc - -type WarnMsg = ErrMsg - -data Severity - = SevOutput - | SevFatal - | SevInteractive - - | SevDump - -- ^ Log message intended for compiler developers - -- No file/line/column stuff - - | SevInfo - -- ^ Log messages intended for end users. - -- No file/line/column stuff. - - | SevWarning - | SevError - -- ^ SevWarning and SevError are used for warnings and errors - -- o The message has a file/line/column heading, - -- plus "warning:" or "error:", - -- added by mkLocMessags - -- o Output is intended for end users - deriving Show - - -instance ToJson Severity where - json s = JSString (show s) - - -instance Show ErrMsg where - show em = errMsgShortString em - -pprMessageBag :: Bag MsgDoc -> SDoc -pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) - --- | Make an unannotated error message with location info. -mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc -mkLocMessage = mkLocMessageAnn Nothing - --- | Make a possibly annotated error message with location info. -mkLocMessageAnn - :: Maybe String -- ^ optional annotation - -> Severity -- ^ severity - -> SrcSpan -- ^ location - -> MsgDoc -- ^ message - -> MsgDoc - -- Always print the location, even if it is unhelpful. Error messages - -- are supposed to be in a standard format, and one without a location - -- would look strange. Better to say explicitly "". -mkLocMessageAnn ann severity locn msg - = sdocWithDynFlags $ \dflags -> - let locn' = if gopt Opt_ErrorSpans dflags - then ppr locn - else ppr (srcSpanStart locn) - - sevColour = getSeverityColour severity (colScheme dflags) - - -- Add optional information - optAnn = case ann of - Nothing -> text "" - Just i -> text " [" <> coloured sevColour (text i) <> text "]" - - -- Add prefixes, like Foo.hs:34: warning: - -- - header = locn' <> colon <+> - coloured sevColour sevText <> optAnn - - in coloured (Col.sMessage (colScheme dflags)) - (hang (coloured (Col.sHeader (colScheme dflags)) header) 4 - msg) - - where - sevText = - case severity of - SevWarning -> text "warning:" - SevError -> text "error:" - SevFatal -> text "fatal:" - _ -> empty - -getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour -getSeverityColour SevWarning = Col.sWarning -getSeverityColour SevError = Col.sError -getSeverityColour SevFatal = Col.sFatal -getSeverityColour _ = const mempty - -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc -getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic severity (RealSrcSpan span) = do - caretDiagnostic <$> getSrcLine (srcSpanFile span) row - - where - getSrcLine fn i = - getLine i (unpackFS fn) - `catchIOError` \_ -> - pure Nothing - - getLine i fn = do - -- StringBuffer has advantages over readFile: - -- (a) no lazy IO, otherwise IO exceptions may occur in pure code - -- (b) always UTF-8, rather than some system-dependent encoding - -- (Haskell source code must be UTF-8 anyway) - content <- hGetStringBuffer fn - case atLine i content of - Just at_line -> pure $ - case lines (fix <$> lexemeToString at_line (len at_line)) of - srcLine : _ -> Just srcLine - _ -> Nothing - _ -> pure Nothing - - -- allow user to visibly see that their code is incorrectly encoded - -- (StringBuffer.nextChar uses \0 to represent undecodable characters) - fix '\0' = '\xfffd' - fix c = c - - row = srcSpanStartLine span - rowStr = show row - multiline = row /= srcSpanEndLine span - - caretDiagnostic Nothing = empty - caretDiagnostic (Just srcLineWithNewline) = - sdocWithDynFlags $ \ dflags -> - let sevColour = getSeverityColour severity (colScheme dflags) - marginColour = Col.sMargin (colScheme dflags) - in - coloured marginColour (text marginSpace) <> - text ("\n") <> - coloured marginColour (text marginRow) <> - text (" " ++ srcLinePre) <> - coloured sevColour (text srcLineSpan) <> - text (srcLinePost ++ "\n") <> - coloured marginColour (text marginSpace) <> - coloured sevColour (text (" " ++ caretLine)) - - where - - -- expand tabs in a device-independent manner #13664 - expandTabs tabWidth i s = - case s of - "" -> "" - '\t' : cs -> replicate effectiveWidth ' ' ++ - expandTabs tabWidth (i + effectiveWidth) cs - c : cs -> c : expandTabs tabWidth (i + 1) cs - where effectiveWidth = tabWidth - i `mod` tabWidth - - srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) - - start = srcSpanStartCol span - 1 - end | multiline = length srcLine - | otherwise = srcSpanEndCol span - 1 - width = max 1 (end - start) - - marginWidth = length rowStr - marginSpace = replicate marginWidth ' ' ++ " |" - marginRow = rowStr ++ " |" - - (srcLinePre, srcLineRest) = splitAt start srcLine - (srcLineSpan, srcLinePost) = splitAt width srcLineRest - - caretEllipsis | multiline = "..." - | otherwise = "" - caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis - -makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg -makeIntoWarning reason err = err - { errMsgSeverity = SevWarning - , errMsgReason = reason } - --- ----------------------------------------------------------------------------- --- Collecting up messages for later ordering and printing. - -mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg -mk_err_msg dflags sev locn print_unqual doc - = ErrMsg { errMsgSpan = locn - , errMsgContext = print_unqual - , errMsgDoc = doc - , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) - , errMsgSeverity = sev - , errMsgReason = NoReason } - -mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg -mkErrDoc dflags = mk_err_msg dflags SevError - -mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg --- ^ A long (multi-line) error message -mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg --- ^ A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg --- ^ Variant that doesn't care about qualified/unqualified names - -mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra]) -mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] []) -mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] []) -mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra]) -mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] []) -mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] []) - ----------------- -emptyMessages :: Messages -emptyMessages = (emptyBag, emptyBag) - -isEmptyMessages :: Messages -> Bool -isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs - -errorsFound :: DynFlags -> Messages -> Bool -errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) - -warningsToMessages :: DynFlags -> WarningMessages -> Messages -warningsToMessages dflags = - partitionBagWith $ \warn -> - case isWarnMsgFatal dflags warn of - Nothing -> Left warn - Just err_reason -> - Right warn{ errMsgSeverity = SevError - , errMsgReason = ErrReason err_reason } - -printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors - = sequence_ [ let style = mkErrStyle dflags unqual - in putLogMsg dflags reason sev s style (formatErrDoc dflags doc) - | ErrMsg { errMsgSpan = s, - errMsgDoc = doc, - errMsgSeverity = sev, - errMsgReason = reason, - errMsgContext = unqual } <- sortMsgBag (Just dflags) - bag_of_errors ] - -formatErrDoc :: DynFlags -> ErrDoc -> SDoc -formatErrDoc dflags (ErrDoc important context supplementary) - = case msgs of - [msg] -> vcat msg - _ -> vcat $ map starred msgs - where - msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags)) - [important, context, supplementary] - starred = (bullet<+>) . vcat - -pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] -pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] - -pprLocErrMsg :: ErrMsg -> SDoc -pprLocErrMsg (ErrMsg { errMsgSpan = s - , errMsgDoc = doc - , errMsgSeverity = sev - , errMsgContext = unqual }) - = sdocWithDynFlags $ \dflags -> - withPprStyle (mkErrStyle dflags unqual) $ - mkLocMessage sev s (formatErrDoc dflags doc) - -sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg] -sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList - where maybeFlip :: (a -> a -> b) -> (a -> a -> b) - maybeFlip - | fromMaybe False (fmap reverseErrors dflags) = flip - | otherwise = id - cmp = comparing errMsgSpan - maybeLimit = case join (fmap maxErrors dflags) of - Nothing -> id - Just err_limit -> take err_limit - -ghcExit :: DynFlags -> Int -> IO () -ghcExit dflags val - | val == 0 = exitWith ExitSuccess - | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") - exitWith (ExitFailure val) - -doIfSet :: Bool -> IO () -> IO () -doIfSet flag action | flag = action - | otherwise = return () - -doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO() -doIfSet_dyn dflags flag action | gopt flag dflags = action - | otherwise = return () - --- ----------------------------------------------------------------------------- --- Dumping - -dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () -dumpIfSet dflags flag hdr doc - | not flag = return () - | otherwise = putLogMsg dflags - NoReason - SevDump - noSrcSpan - (defaultDumpStyle dflags) - (mkDumpDoc hdr doc) - --- | a wrapper around 'dumpSDoc'. --- First check whether the dump flag is set --- Do nothing if it is unset -dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpIfSet_dyn dflags flag hdr doc - = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc - --- | a wrapper around 'dumpSDoc'. --- First check whether the dump flag is set --- Do nothing if it is unset --- --- Unlike 'dumpIfSet_dyn', --- has a printer argument but no header argument -dumpIfSet_dyn_printer :: PrintUnqualified - -> DynFlags -> DumpFlag -> SDoc -> IO () -dumpIfSet_dyn_printer printer dflags flag doc - = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc - -mkDumpDoc :: String -> SDoc -> SDoc -mkDumpDoc hdr doc - = vcat [blankLine, - line <+> text hdr <+> line, - doc, - blankLine] - where - line = text (replicate 20 '=') - --- | Run an action with the handle of a 'DumpFlag' if we are outputting to a --- file, otherwise 'Nothing'. -withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () -withDumpFileHandle dflags flag action = do - let mFile = chooseDumpFile dflags flag - case mFile of - Just fileName -> do - let gdref = generatedDumps dflags - gd <- readIORef gdref - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef gdref (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - withFile fileName mode $ \handle -> do - -- We do not want the dump file to be affected by - -- environment variables, but instead to always use - -- UTF8. See: - -- https://gitlab.haskell.org/ghc/ghc/issues/10762 - hSetEncoding handle utf8 - - action (Just handle) - Nothing -> action Nothing - - -dumpSDoc, dumpSDocForUser - :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () - --- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style. -dumpSDoc dflags print_unqual - = dumpSDocWithStyle dump_style dflags - where dump_style = mkDumpStyle dflags print_unqual - --- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style. -dumpSDocForUser dflags print_unqual - = dumpSDocWithStyle user_style dflags - where user_style = mkUserStyle dflags print_unqual AllTheWay - --- | Write out a dump. --- If --dump-to-file is set then this goes to a file. --- otherwise emit to stdout. --- --- When @hdr@ is empty, we print in a more compact format (no separators and --- blank lines) --- --- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@ --- is used; it is not used to decide whether to dump the output -dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpSDocWithStyle sty dflags flag hdr doc = - withDumpFileHandle dflags flag writeDump - where - -- write dump to file - writeDump (Just handle) = do - doc' <- if null hdr - then return doc - else do t <- getCurrentTime - let timeStamp = if (gopt Opt_SuppressTimestamps dflags) - then empty - else text (show t) - let d = timeStamp - $$ blankLine - $$ doc - return $ mkDumpDoc hdr d - defaultLogActionHPrintDoc dflags handle doc' sty - - -- write the dump to stdout - writeDump Nothing = do - let (doc', severity) - | null hdr = (doc, SevOutput) - | otherwise = (mkDumpDoc hdr doc, SevDump) - putLogMsg dflags NoReason severity noSrcSpan sty doc' - - --- | Choose where to put a dump file based on DynFlags --- -chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath -chooseDumpFile dflags flag - - | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file - , Just prefix <- getPrefix - = Just $ setDir (prefix ++ (beautifyDumpName flag)) - - | otherwise - = Nothing - - where getPrefix - -- dump file location is being forced - -- by the --ddump-file-prefix flag. - | Just prefix <- dumpPrefixForce dflags - = Just prefix - -- dump file location chosen by DriverPipeline.runPipeline - | Just prefix <- dumpPrefix dflags - = Just prefix - -- we haven't got a place to put a dump file. - | otherwise - = Nothing - setDir f = case dumpDir dflags of - Just d -> d f - Nothing -> f - --- | Build a nice file name from name of a 'DumpFlag' constructor -beautifyDumpName :: DumpFlag -> String -beautifyDumpName Opt_D_th_dec_file = "th.hs" -beautifyDumpName flag - = let str = show flag - suff = case stripPrefix "Opt_D_" str of - Just x -> x - Nothing -> panic ("Bad flag name: " ++ str) - dash = map (\c -> if c == '_' then '-' else c) suff - in dash - - --- ----------------------------------------------------------------------------- --- Outputting messages from the compiler - --- We want all messages to go through one place, so that we can --- redirect them if necessary. For example, when GHC is used as a --- library we might want to catch all messages that GHC tries to --- output and do something else with them. - -ifVerbose :: DynFlags -> Int -> IO () -> IO () -ifVerbose dflags val act - | verbosity dflags >= val = act - | otherwise = return () - -errorMsg :: DynFlags -> MsgDoc -> IO () -errorMsg dflags msg - = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg - -warningMsg :: DynFlags -> MsgDoc -> IO () -warningMsg dflags msg - = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg - -fatalErrorMsg :: DynFlags -> MsgDoc -> IO () -fatalErrorMsg dflags msg = - putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg - -fatalErrorMsg'' :: FatalMessager -> String -> IO () -fatalErrorMsg'' fm msg = fm msg - -compilationProgressMsg :: DynFlags -> String -> IO () -compilationProgressMsg dflags msg = do - traceEventIO $ "GHC progress: " ++ msg - ifVerbose dflags 1 $ - logOutput dflags (defaultUserStyle dflags) (text msg) - -showPass :: DynFlags -> String -> IO () -showPass dflags what - = ifVerbose dflags 2 $ - logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon) - -data PrintTimings = PrintTimings | DontPrintTimings - deriving (Eq, Show) - --- | Time a compilation phase. --- --- When timings are enabled (e.g. with the @-v2@ flag), the allocations --- and CPU time used by the phase will be reported to stderr. Consider --- a typical usage: --- @withTiming getDynFlags (text "simplify") force PrintTimings pass@. --- When timings are enabled the following costs are included in the --- produced accounting, --- --- - The cost of executing @pass@ to a result @r@ in WHNF --- - The cost of evaluating @force r@ to WHNF (e.g. @()@) --- --- The choice of the @force@ function depends upon the amount of forcing --- desired; the goal here is to ensure that the cost of evaluating the result --- is, to the greatest extent possible, included in the accounting provided by --- 'withTiming'. Often the pass already sufficiently forces its result during --- construction; in this case @const ()@ is a reasonable choice. --- In other cases, it is necessary to evaluate the result to normal form, in --- which case something like @Control.DeepSeq.rnf@ is appropriate. --- --- To avoid adversely affecting compiler performance when timings are not --- requested, the result is only forced when timings are enabled. --- --- See Note [withTiming] for more. -withTiming :: MonadIO m - => DynFlags -- ^ DynFlags - -> SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed - -> m a -withTiming dflags what force action = - withTiming' dflags what force PrintTimings action - --- | Like withTiming but get DynFlags from the Monad. -withTimingD :: (MonadIO m, HasDynFlags m) - => SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed - -> m a -withTimingD what force action = do - dflags <- getDynFlags - withTiming' dflags what force PrintTimings action - - --- | Same as 'withTiming', but doesn't print timings in the --- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). --- --- See Note [withTiming] for more. -withTimingSilent - :: MonadIO m - => DynFlags -- ^ DynFlags - -> SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed - -> m a -withTimingSilent dflags what force action = - withTiming' dflags what force DontPrintTimings action - --- | Same as 'withTiming', but doesn't print timings in the --- console (when given @-vN@, @N >= 2@ or @-ddump-timings@) --- and gets the DynFlags from the given Monad. --- --- See Note [withTiming] for more. -withTimingSilentD - :: (MonadIO m, HasDynFlags m) - => SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed - -> m a -withTimingSilentD what force action = do - dflags <- getDynFlags - withTiming' dflags what force DontPrintTimings action - --- | Worker for 'withTiming' and 'withTimingSilent'. -withTiming' :: MonadIO m - => DynFlags -- ^ A means of getting a 'DynFlags' (often - -- 'getDynFlags' will work here) - -> SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> PrintTimings -- ^ Whether to print the timings - -> m a -- ^ The body of the phase to be timed - -> m a -withTiming' dflags what force_result prtimings action - = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags - then do whenPrintTimings $ - logInfo dflags (defaultUserStyle dflags) $ - text "***" <+> what <> colon - eventBegins dflags what - alloc0 <- liftIO getAllocationCounter - start <- liftIO getCPUTime - !r <- action - () <- pure $ force_result r - eventEnds dflags what - end <- liftIO getCPUTime - alloc1 <- liftIO getAllocationCounter - -- recall that allocation counter counts down - let alloc = alloc0 - alloc1 - time = realToFrac (end - start) * 1e-9 - - when (verbosity dflags >= 2 && prtimings == PrintTimings) - $ liftIO $ logInfo dflags (defaultUserStyle dflags) - (text "!!!" <+> what <> colon <+> text "finished in" - <+> doublePrec 2 time - <+> text "milliseconds" - <> comma - <+> text "allocated" - <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) - <+> text "megabytes") - - whenPrintTimings $ - dumpIfSet_dyn dflags Opt_D_dump_timings "" - $ text $ showSDocOneLine dflags - $ hsep [ what <> colon - , text "alloc=" <> ppr alloc - , text "time=" <> doublePrec 3 time - ] - pure r - else action - - where whenPrintTimings = liftIO . when (prtimings == PrintTimings) - eventBegins dflags w = do - whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w) - liftIO $ traceEventIO (eventEndsDoc dflags w) - eventEnds dflags w = do - whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w) - liftIO $ traceEventIO (eventEndsDoc dflags w) - - eventBeginsDoc dflags w = showSDocOneLine dflags $ text "GHC:started:" <+> w - eventEndsDoc dflags w = showSDocOneLine dflags $ text "GHC:finished:" <+> w - -debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () -debugTraceMsg dflags val msg = ifVerbose dflags val $ - logInfo dflags (defaultDumpStyle dflags) msg -putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg - -printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () -printInfoForUser dflags print_unqual msg - = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg - -printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () -printOutputForUser dflags print_unqual msg - = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg - -logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () -logInfo dflags sty msg - = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg - -logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () --- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput dflags sty msg - = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg - -prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a -prettyPrintGhcErrors dflags - = ghandle $ \e -> case e of - PprPanic str doc -> - pprDebugAndThen dflags panic (text str) doc - PprSorry str doc -> - pprDebugAndThen dflags sorry (text str) doc - PprProgramError str doc -> - pprDebugAndThen dflags pgmError (text str) doc - _ -> - liftIO $ throwIO e - --- | Checks if given 'WarnMsg' is a fatal warning. -isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) -isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} - = if wopt_fatal wflag dflags - then Just (Just wflag) - else Nothing -isWarnMsgFatal dflags _ - = if gopt Opt_WarnIsError dflags - then Just Nothing - else Nothing - -traceCmd :: DynFlags -> String -> String -> IO a -> IO a --- trace the command (at two levels of verbosity) -traceCmd dflags phase_name cmd_line action - = do { let verb = verbosity dflags - ; showPass dflags phase_name - ; debugTraceMsg dflags 3 (text cmd_line) - ; case flushErr dflags of - FlushErr io -> io - - -- And run it! - ; action `catchIO` handle_exn verb - } - where - handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') - ; debugTraceMsg dflags 2 - (text "Failed:" - <+> text cmd_line - <+> text (show exn)) - ; throwGhcExceptionIO (ProgramError (show exn))} - -{- Note [withTiming] -~~~~~~~~~~~~~~~~~~~~ - -For reference: - - withTiming - :: MonadIO - => m DynFlags -- how to get the DynFlags - -> SDoc -- label for the computation we're timing - -> (a -> ()) -- how to evaluate the result - -> PrintTimings -- whether to report the timings when passed - -- -v2 or -ddump-timings - -> m a -- computation we're timing - -> m a - -withTiming lets you run an action while: - -(1) measuring the CPU time it took and reporting that on stderr - (when PrintTimings is passed), -(2) emitting start/stop events to GHC's event log, with the label - given as an argument. - -Evaluation of the result ------------------------- - -'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is -to evaluate the result "sufficiently". A given pass might return an 'm a' for -some monad 'm' and result type 'a', but where the 'a' is complex enough -that evaluating it to WHNF barely scratches its surface and leaves many -complex and time-consuming computations unevaluated. Those would only be -forced by the next pass, and the time needed to evaluate them would be -mis-attributed to that next pass. A more appropriate function would be -one that deeply evaluates the result, so as to assign the time spent doing it -to the pass we're timing. - -Note: as hinted at above, the time spent evaluating the application of the -forcing function to the result is included in the timings reported by -'withTiming'. - -How we use it -------------- - -We measure the time and allocations of various passes in GHC's pipeline by just -wrapping the whole pass with 'withTiming'. This also materializes by having -a label for each pass in the eventlog, where each pass is executed in one go, -during a continuous time window. - -However, from STG onwards, the pipeline uses streams to emit groups of -STG/Cmm/etc declarations one at a time, and process them until we get to -assembly code generation. This means that the execution of those last few passes -is interleaved and that we cannot measure how long they take by just wrapping -the whole thing with 'withTiming'. Instead we wrap the processing of each -individual stream element, all along the codegen pipeline, using the appropriate -label for the pass to which this processing belongs. That generates a lot more -data but allows us to get fine-grained timings about all the passes and we can -easily compute totals withh tools like ghc-events-analyze (see below). - - -Producing an eventlog for GHC ------------------------------ - -To actually produce the eventlog, you need an eventlog-capable GHC build: - - With Hadrian: - $ hadrian/build.sh -j "stage1.ghc-bin.ghc.link.opts += -eventlog" - - With Make: - $ make -j GhcStage2HcOpts+=-eventlog - -You can then produce an eventlog when compiling say hello.hs by simply -doing: - - If GHC was built by Hadrian: - $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l - - If GHC was built with Make: - $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l - -You could alternatively use -v (with N >= 2) instead of -ddump-timings, -to ask GHC to report timings (on stderr and the eventlog). - -This will write the eventlog to ./ghc.eventlog in both cases. You can then -visualize it or look at the totals for each label by using ghc-events-analyze, -threadscope or any other eventlog consumer. Illustrating with -ghc-events-analyze: - - $ ghc-events-analyze --timed --timed-txt --totals \ - --start "GHC:started:" --stop "GHC:finished:" \ - ghc.eventlog - -This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation -of the execution through the various labels) and ghc.totals.txt (total time -spent in each label). - --} diff --git a/main/ErrUtils.hs-boot b/main/ErrUtils.hs-boot deleted file mode 100644 --- a/main/ErrUtils.hs-boot +++ /dev/null @@ -1,26 +0,0 @@ -module ErrUtils where - -import GhcPrelude -import Outputable (SDoc, PrintUnqualified ) -import SrcLoc (SrcSpan) -import Json -import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag ) - -data Severity - = SevOutput - | SevFatal - | SevInteractive - | SevDump - | SevInfo - | SevWarning - | SevError - - -type MsgDoc = SDoc - -mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc -mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc -dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () - -instance ToJson Severity diff --git a/main/FileCleanup.hs b/main/FileCleanup.hs deleted file mode 100644 --- a/main/FileCleanup.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE CPP #-} -module FileCleanup - ( TempFileLifetime(..) - , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles - , addFilesToClean, changeTempFilesLifetime - , newTempName, newTempLibName, newTempDir - , withSystemTempDirectory, withTempDirectory - ) where - -import GhcPrelude - -import DynFlags -import ErrUtils -import Outputable -import Util -import Exception -import DriverPhases - -import Control.Monad -import Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.IORef -import System.Directory -import System.FilePath -import System.IO.Error - -#if !defined(mingw32_HOST_OS) -import qualified System.Posix.Internals -#endif - --- | Used when a temp file is created. This determines which component Set of --- FilesToClean will get the temp file -data TempFileLifetime - = TFL_CurrentModule - -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the - -- end of upweep_mod - | TFL_GhcSession - -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of - -- runGhc(T) - deriving (Show) - -cleanTempDirs :: DynFlags -> IO () -cleanTempDirs dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ - $ do let ref = dirsToClean dflags - ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) - removeTmpDirs dflags (Map.elems ds) - --- | Delete all files in @filesToClean dflags@. -cleanTempFiles :: DynFlags -> IO () -cleanTempFiles dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ - $ do let ref = filesToClean dflags - to_delete <- atomicModifyIORef' ref $ - \FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files - } -> ( emptyFilesToClean - , Set.toList cm_files ++ Set.toList gs_files) - removeTmpFiles dflags to_delete - --- | Delete all files in @filesToClean dflags@. That have lifetime --- TFL_CurrentModule. --- If a file must be cleaned eventually, but must survive a --- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. -cleanCurrentModuleTempFiles :: DynFlags -> IO () -cleanCurrentModuleTempFiles dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ - $ do let ref = filesToClean dflags - to_delete <- atomicModifyIORef' ref $ - \ftc@FilesToClean{ftcCurrentModule = cm_files} -> - (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) - removeTmpFiles dflags to_delete - --- | Ensure that new_files are cleaned on the next call of --- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. --- If any of new_files are already tracked, they will have their lifetime --- updated. -addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () -addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $ - \FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files - } -> case lifetime of - TFL_CurrentModule -> FilesToClean - { ftcCurrentModule = cm_files `Set.union` new_files_set - , ftcGhcSession = gs_files `Set.difference` new_files_set - } - TFL_GhcSession -> FilesToClean - { ftcCurrentModule = cm_files `Set.difference` new_files_set - , ftcGhcSession = gs_files `Set.union` new_files_set - } - where - new_files_set = Set.fromList new_files - --- | Update the lifetime of files already being tracked. If any files are --- not being tracked they will be discarded. -changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () -changeTempFilesLifetime dflags lifetime files = do - FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files - } <- readIORef (filesToClean dflags) - let old_set = case lifetime of - TFL_CurrentModule -> gs_files - TFL_GhcSession -> cm_files - existing_files = [f | f <- files, f `Set.member` old_set] - addFilesToClean dflags lifetime existing_files - --- Return a unique numeric temp file suffix -newTempSuffix :: DynFlags -> IO Int -newTempSuffix dflags = - atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) - --- Find a temporary name that doesn't already exist. -newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath -newTempName dflags lifetime extn - = do d <- getTempDir dflags - findTempName (d "ghc_") -- See Note [Deterministic base name] - where - findTempName :: FilePath -> IO FilePath - findTempName prefix - = do n <- newTempSuffix dflags - let filename = prefix ++ show n <.> extn - b <- doesFileExist filename - if b then findTempName prefix - else do -- clean it up later - addFilesToClean dflags lifetime [filename] - return filename - -newTempDir :: DynFlags -> IO FilePath -newTempDir dflags - = do d <- getTempDir dflags - findTempDir (d "ghc_") - where - findTempDir :: FilePath -> IO FilePath - findTempDir prefix - = do n <- newTempSuffix dflags - let filename = prefix ++ show n - b <- doesDirectoryExist filename - if b then findTempDir prefix - else do createDirectory filename - -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename - return filename - -newTempLibName :: DynFlags -> TempFileLifetime -> Suffix - -> IO (FilePath, FilePath, String) -newTempLibName dflags lifetime extn - = do d <- getTempDir dflags - findTempName d ("ghc_") - where - findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) - findTempName dir prefix - = do n <- newTempSuffix dflags -- See Note [Deterministic base name] - let libname = prefix ++ show n - filename = dir "lib" ++ libname <.> extn - b <- doesFileExist filename - if b then findTempName dir prefix - else do -- clean it up later - addFilesToClean dflags lifetime [filename] - return (filename, dir, libname) - - --- Return our temporary directory within tmp_dir, creating one if we --- don't have one yet. -getTempDir :: DynFlags -> IO FilePath -getTempDir dflags = do - mapping <- readIORef dir_ref - case Map.lookup tmp_dir mapping of - Nothing -> do - pid <- getProcessID - let prefix = tmp_dir "ghc" ++ show pid ++ "_" - mask_ $ mkTempDir prefix - Just dir -> return dir - where - tmp_dir = tmpDir dflags - dir_ref = dirsToClean dflags - - mkTempDir :: FilePath -> IO FilePath - mkTempDir prefix = do - n <- newTempSuffix dflags - let our_dir = prefix ++ show n - - -- 1. Speculatively create our new directory. - createDirectory our_dir - - -- 2. Update the dirsToClean mapping unless an entry already exists - -- (i.e. unless another thread beat us to it). - their_dir <- atomicModifyIORef' dir_ref $ \mapping -> - case Map.lookup tmp_dir mapping of - Just dir -> (mapping, Just dir) - Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) - - -- 3. If there was an existing entry, return it and delete the - -- directory we created. Otherwise return the directory we created. - case their_dir of - Nothing -> do - debugTraceMsg dflags 2 $ - text "Created temporary directory:" <+> text our_dir - return our_dir - Just dir -> do - removeDirectory our_dir - return dir - `catchIO` \e -> if isAlreadyExistsError e - then mkTempDir prefix else ioError e - -{- Note [Deterministic base name] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The filename of temporary files, especially the basename of C files, can end -up in the output in some form, e.g. as part of linker debug information. In the -interest of bit-wise exactly reproducible compilation (#4012), the basename of -the temporary file no longer contains random information (it used to contain -the process id). - -This is ok, as the temporary directory used contains the pid (see getTempDir). --} -removeTmpDirs :: DynFlags -> [FilePath] -> IO () -removeTmpDirs dflags ds - = traceCmd dflags "Deleting temp dirs" - ("Deleting: " ++ unwords ds) - (mapM_ (removeWith dflags removeDirectory) ds) - -removeTmpFiles :: DynFlags -> [FilePath] -> IO () -removeTmpFiles dflags fs - = warnNon $ - traceCmd dflags "Deleting temp files" - ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith dflags removeFile) deletees) - where - -- Flat out refuse to delete files that are likely to be source input - -- files (is there a worse bug than having a compiler delete your source - -- files?) - -- - -- Deleting source files is a sign of a bug elsewhere, so prominently flag - -- the condition. - warnNon act - | null non_deletees = act - | otherwise = do - putMsg dflags (text "WARNING - NOT deleting source files:" - <+> hsep (map text non_deletees)) - act - - (non_deletees, deletees) = partition isHaskellUserSrcFilename fs - -removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith dflags remover f = remover f `catchIO` - (\e -> - let msg = if isDoesNotExistError e - then text "Warning: deleting non-existent" <+> text f - else text "Warning: exception raised when deleting" - <+> text f <> colon - $$ text (show e) - in debugTraceMsg dflags 2 msg - ) - -#if defined(mingw32_HOST_OS) --- relies on Int == Int32 on Windows -foreign import ccall unsafe "_getpid" getProcessID :: IO Int -#else -getProcessID :: IO Int -getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral -#endif - --- The following three functions are from the `temporary` package. - --- | Create and use a temporary directory in the system standard temporary --- directory. --- --- Behaves exactly the same as 'withTempDirectory', except that the parent --- temporary directory will be that returned by 'getTemporaryDirectory'. -withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'. - -> (FilePath -> IO a) -- ^ Callback that can use the directory - -> IO a -withSystemTempDirectory template action = - getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action - - --- | Create and use a temporary directory. --- --- Creates a new temporary directory inside the given directory, making use --- of the template. The temp directory is deleted after use. For example: --- --- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... --- --- The @tmpDir@ will be a new subdirectory of the given directory, e.g. --- @src/sdist.342@. -withTempDirectory :: FilePath -- ^ Temp directory to create the directory in - -> String -- ^ Directory name template. See 'openTempFile'. - -> (FilePath -> IO a) -- ^ Callback that can use the directory - -> IO a -withTempDirectory targetDir template = - Exception.bracket - (createTempDirectory targetDir template) - (ignoringIOErrors . removeDirectoryRecursive) - -ignoringIOErrors :: IO () -> IO () -ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError)) - - -createTempDirectory :: FilePath -> String -> IO FilePath -createTempDirectory dir template = do - pid <- getProcessID - findTempName pid - where findTempName x = do - let path = dir template ++ show x - createDirectory path - return path - `catchIO` \e -> if isAlreadyExistsError e - then findTempName (x+1) else ioError e diff --git a/main/FileSettings.hs b/main/FileSettings.hs deleted file mode 100644 --- a/main/FileSettings.hs +++ /dev/null @@ -1,16 +0,0 @@ -module FileSettings - ( FileSettings (..) - ) where - -import GhcPrelude - --- | Paths to various files and directories used by GHC, including those that --- provide more settings. -data FileSettings = FileSettings - { fileSettings_ghcUsagePath :: FilePath -- ditto - , fileSettings_ghciUsagePath :: FilePath -- ditto - , fileSettings_toolDir :: Maybe FilePath -- ditto - , fileSettings_topDir :: FilePath -- ditto - , fileSettings_tmpDir :: String -- no trailing '/' - , fileSettings_systemPackageConfig :: FilePath - } diff --git a/main/Finder.hs b/main/Finder.hs deleted file mode 100644 --- a/main/Finder.hs +++ /dev/null @@ -1,844 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 - -\section[Finder]{Module Finder} --} - -{-# LANGUAGE CPP #-} - -module Finder ( - flushFinderCaches, - FindResult(..), - findImportedModule, - findPluginModule, - findExactModule, - findHomeModule, - findExposedPackageModule, - mkHomeModLocation, - mkHomeModLocation2, - mkHiOnlyModLocation, - mkHiPath, - mkObjPath, - addHomeModuleToFinder, - uncacheModule, - mkStubPaths, - - findObjectLinkableMaybe, - findObjectLinkable, - - cannotFindModule, - cannotFindInterface, - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Module -import HscTypes -import Packages -import FastString -import Util -import PrelNames ( gHC_PRIM ) -import DynFlags -import Outputable -import Maybes ( expectJust ) - -import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) -import System.Directory -import System.FilePath -import Control.Monad -import Data.Time - - -type FileExt = String -- Filename extension -type BaseName = String -- Basename of file - --- ----------------------------------------------------------------------------- --- The Finder - --- The Finder provides a thin filesystem abstraction to the rest of --- the compiler. For a given module, it can tell you where the --- source, interface, and object files for that module live. - --- It does *not* know which particular package a module lives in. Use --- Packages.lookupModuleInAllPackages for that. - --- ----------------------------------------------------------------------------- --- The finder's cache - --- remove all the home modules from the cache; package modules are --- assumed to not move around during a session. -flushFinderCaches :: HscEnv -> IO () -flushFinderCaches hsc_env = - atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) - where - this_pkg = thisPackage (hsc_dflags hsc_env) - fc_ref = hsc_FC hsc_env - is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True - | otherwise = False - -addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () -addToFinderCache ref key val = - atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) - -removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO () -removeFromFinderCache ref key = - atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) - -lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) -lookupFinderCache ref key = do - c <- readIORef ref - return $! lookupInstalledModuleEnv c key - --- ----------------------------------------------------------------------------- --- The three external entry points - --- | Locate a module that was imported by the user. We have the --- module's name, and possibly a package name. Without a package --- name, this function will use the search path and the known exposed --- packages to find the module, if a package is specified then only --- that package is searched for the module. - -findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult -findImportedModule hsc_env mod_name mb_pkg = - case mb_pkg of - Nothing -> unqual_import - Just pkg | pkg == fsLit "this" -> home_import -- "this" is special - | otherwise -> pkg_import - where - home_import = findHomeModule hsc_env mod_name - - pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg - - unqual_import = home_import - `orIfNotFound` - findExposedPackageModule hsc_env mod_name Nothing - --- | Locate a plugin module requested by the user, for a compiler --- plugin. This consults the same set of exposed packages as --- 'findImportedModule', unless @-hide-all-plugin-packages@ or --- @-plugin-package@ are specified. -findPluginModule :: HscEnv -> ModuleName -> IO FindResult -findPluginModule hsc_env mod_name = - findHomeModule hsc_env mod_name - `orIfNotFound` - findExposedPluginPackageModule hsc_env mod_name - --- | Locate a specific 'Module'. The purpose of this function is to --- create a 'ModLocation' for a given 'Module', that is to find out --- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, --- for example (a "system import"). - -findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult -findExactModule hsc_env mod = - let dflags = hsc_dflags hsc_env - in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags - then findInstalledHomeModule hsc_env (installedModuleName mod) - else findPackageModule hsc_env mod - --- ----------------------------------------------------------------------------- --- Helpers - --- | Given a monadic actions @this@ and @or_this@, first execute --- @this@. If the returned 'FindResult' is successful, return --- it; otherwise, execute @or_this@. If both failed, this function --- also combines their failure messages in a reasonable way. -orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult -orIfNotFound this or_this = do - res <- this - case res of - NotFound { fr_paths = paths1, fr_mods_hidden = mh1 - , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } - -> do res2 <- or_this - case res2 of - NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 - , fr_pkgs_hidden = ph2, fr_unusables = u2 - , fr_suggestions = s2 } - -> return (NotFound { fr_paths = paths1 ++ paths2 - , fr_pkg = mb_pkg2 -- snd arg is the package search - , fr_mods_hidden = mh1 ++ mh2 - , fr_pkgs_hidden = ph1 ++ ph2 - , fr_unusables = u1 ++ u2 - , fr_suggestions = s1 ++ s2 }) - _other -> return res2 - _other -> return res - --- | Helper function for 'findHomeModule': this function wraps an IO action --- which would look up @mod_name@ in the file system (the home package), --- and first consults the 'hsc_FC' cache to see if the lookup has already --- been done. Otherwise, do the lookup (with the IO action) and save --- the result in the finder cache and the module location cache (if it --- was successful.) -homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult -homeSearchCache hsc_env mod_name do_this = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name - modLocationCache hsc_env mod do_this - -findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString - -> IO FindResult -findExposedPackageModule hsc_env mod_name mb_pkg - = findLookupResult hsc_env - $ lookupModuleWithSuggestions - (hsc_dflags hsc_env) mod_name mb_pkg - -findExposedPluginPackageModule :: HscEnv -> ModuleName - -> IO FindResult -findExposedPluginPackageModule hsc_env mod_name - = findLookupResult hsc_env - $ lookupPluginModuleWithSuggestions - (hsc_dflags hsc_env) mod_name Nothing - -findLookupResult :: HscEnv -> LookupResult -> IO FindResult -findLookupResult hsc_env r = case r of - LookupFound m pkg_conf -> do - let im = fst (splitModuleInsts m) - r' <- findPackageModule_ hsc_env im pkg_conf - case r' of - -- TODO: ghc -M is unlikely to do the right thing - -- with just the location of the thing that was - -- instantiated; you probably also need all of the - -- implicit locations from the instances - InstalledFound loc _ -> return (Found loc m) - InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) - InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_unusables = [] - , fr_suggestions = []}) - LookupMultiple rs -> - return (FoundMultiple rs) - LookupHidden pkg_hiddens mod_hiddens -> - return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens - , fr_unusables = [] - , fr_suggestions = [] }) - LookupUnusable unusable -> - let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnitId m, r) - get_unusable (_, r) = - pprPanic "findLookupResult: unexpected origin" (ppr r) - in return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_unusables = unusables' - , fr_suggestions = [] }) - LookupNotFound suggest -> - return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_unusables = [] - , fr_suggestions = suggest }) - -modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult -modLocationCache hsc_env mod do_this = do - m <- lookupFinderCache (hsc_FC hsc_env) mod - case m of - Just result -> return result - Nothing -> do - result <- do_this - addToFinderCache (hsc_FC hsc_env) mod result - return result - -mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule -mkHomeInstalledModule dflags mod_name = - let iuid = thisInstalledUnitId dflags - in InstalledModule iuid mod_name - --- This returns a module because it's more convenient for users -addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module -addHomeModuleToFinder hsc_env mod_name loc = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name - addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) - return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name) - -uncacheModule :: HscEnv -> ModuleName -> IO () -uncacheModule hsc_env mod_name = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name - removeFromFinderCache (hsc_FC hsc_env) mod - --- ----------------------------------------------------------------------------- --- The internal workers - -findHomeModule :: HscEnv -> ModuleName -> IO FindResult -findHomeModule hsc_env mod_name = do - r <- findInstalledHomeModule hsc_env mod_name - return $ case r of - InstalledFound loc _ -> Found loc (mkModule uid mod_name) - InstalledNoPackage _ -> NoPackage uid -- impossible - InstalledNotFound fps _ -> NotFound { - fr_paths = fps, - fr_pkg = Just uid, - fr_mods_hidden = [], - fr_pkgs_hidden = [], - fr_unusables = [], - fr_suggestions = [] - } - where - dflags = hsc_dflags hsc_env - uid = thisPackage dflags - --- | Implements the search for a module name in the home package only. Calling --- this function directly is usually *not* what you want; currently, it's used --- as a building block for the following operations: --- --- 1. When you do a normal package lookup, we first check if the module --- is available in the home module, before looking it up in the package --- database. --- --- 2. When you have a package qualified import with package name "this", --- we shortcut to the home module. --- --- 3. When we look up an exact 'Module', if the unit id associated with --- the module is the current home module do a look up in the home module. --- --- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to --- call this.) -findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult -findInstalledHomeModule hsc_env mod_name = - homeSearchCache hsc_env mod_name $ - let - dflags = hsc_dflags hsc_env - home_path = importPaths dflags - hisuf = hiSuf dflags - mod = mkHomeInstalledModule dflags mod_name - - source_exts = - [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") - , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") - , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") - , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") - ] - - -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that - -- when hiDir field is set in dflags, we know to look there (see #16500) - hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name) - , (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name) - ] - - -- In compilation manager modes, we look for source files in the home - -- package because we can compile these automatically. In one-shot - -- compilation mode we look for .hi and .hi-boot files only. - exts | isOneShot (ghcMode dflags) = hi_exts - | otherwise = source_exts - in - - -- special case for GHC.Prim; we won't find it in the filesystem. - -- This is important only when compiling the base package (where GHC.Prim - -- is a home module). - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else searchPathExts home_path mod exts - - --- | Search for a module in external packages only. -findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult -findPackageModule hsc_env mod = do - let - dflags = hsc_dflags hsc_env - pkg_id = installedModuleUnitId mod - -- - case lookupInstalledPackage dflags pkg_id of - Nothing -> return (InstalledNoPackage pkg_id) - Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf - --- | Look up the interface file associated with module @mod@. This function --- requires a few invariants to be upheld: (1) the 'Module' in question must --- be the module identifier of the *original* implementation of a module, --- not a reexport (this invariant is upheld by @Packages.hs@) and (2) --- the 'PackageConfig' must be consistent with the unit id in the 'Module'. --- The redundancy is to avoid an extra lookup in the package state --- for the appropriate config. -findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult -findPackageModule_ hsc_env mod pkg_conf = - ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) ) - modLocationCache hsc_env mod $ - - -- special case for GHC.Prim; we won't find it in the filesystem. - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else - - let - dflags = hsc_dflags hsc_env - tag = buildTag dflags - - -- hi-suffix for packages depends on the build tag. - package_hisuf | null tag = "hi" - | otherwise = tag ++ "_hi" - - mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf - - import_dirs = importDirs pkg_conf - -- we never look for a .hi-boot file in an external package; - -- .hi-boot files only make sense for the home package. - in - case import_dirs of - [one] | MkDepend <- ghcMode dflags -> do - -- there's only one place that this .hi file can be, so - -- don't bother looking for it. - let basename = moduleNameSlashes (installedModuleName mod) - loc <- mk_hi_loc one basename - return (InstalledFound loc mod) - _otherwise -> - searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] - --- ----------------------------------------------------------------------------- --- General path searching - -searchPathExts - :: [FilePath] -- paths to search - -> InstalledModule -- module name - -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action - ) - ] - -> IO InstalledFindResult - -searchPathExts paths mod exts - = do result <- search to_search -{- - hPutStrLn stderr (showSDoc $ - vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) - , nest 2 (vcat (map text paths)) - , case result of - Succeeded (loc, p) -> text "Found" <+> ppr loc - Failed fs -> text "not found"]) --} - return result - - where - basename = moduleNameSlashes (installedModuleName mod) - - to_search :: [(FilePath, IO ModLocation)] - to_search = [ (file, fn path basename) - | path <- paths, - (ext,fn) <- exts, - let base | path == "." = basename - | otherwise = path basename - file = base <.> ext - ] - - search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod))) - - search ((file, mk_result) : rest) = do - b <- doesFileExist file - if b - then do { loc <- mk_result; return (InstalledFound loc mod) } - else search rest - -mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation -mkHomeModLocationSearched dflags mod suff path basename = do - mkHomeModLocation2 dflags mod (path basename) suff - --- ----------------------------------------------------------------------------- --- Constructing a home module location - --- This is where we construct the ModLocation for a module in the home --- package, for which we have a source file. It is called from three --- places: --- --- (a) Here in the finder, when we are searching for a module to import, --- using the search path (-i option). --- --- (b) The compilation manager, when constructing the ModLocation for --- a "root" module (a source file named explicitly on the command line --- or in a :load command in GHCi). --- --- (c) The driver in one-shot mode, when we need to construct a --- ModLocation for a source file named on the command-line. --- --- Parameters are: --- --- mod --- The name of the module --- --- path --- (a): The search path component where the source file was found. --- (b) and (c): "." --- --- src_basename --- (a): (moduleNameSlashes mod) --- (b) and (c): The filename of the source file, minus its extension --- --- ext --- The filename extension of the source file (usually "hs" or "lhs"). - -mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation -mkHomeModLocation dflags mod src_filename = do - let (basename,extension) = splitExtension src_filename - mkHomeModLocation2 dflags mod basename extension - -mkHomeModLocation2 :: DynFlags - -> ModuleName - -> FilePath -- Of source module, without suffix - -> String -- Suffix - -> IO ModLocation -mkHomeModLocation2 dflags mod src_basename ext = do - let mod_basename = moduleNameSlashes mod - - obj_fn = mkObjPath dflags src_basename mod_basename - hi_fn = mkHiPath dflags src_basename mod_basename - hie_fn = mkHiePath dflags src_basename mod_basename - - return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn, - ml_hie_file = hie_fn }) - -mkHomeModHiOnlyLocation :: DynFlags - -> ModuleName - -> FilePath - -> BaseName - -> IO ModLocation -mkHomeModHiOnlyLocation dflags mod path basename = do - loc <- mkHomeModLocation2 dflags mod (path basename) "" - return loc { ml_hs_file = Nothing } - -mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String - -> IO ModLocation -mkHiOnlyModLocation dflags hisuf path basename - = do let full_basename = path basename - obj_fn = mkObjPath dflags full_basename basename - hie_fn = mkHiePath dflags full_basename basename - return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename <.> hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn, - ml_hie_file = hie_fn - } - --- | Constructs the filename of a .o file for a given source file. --- Does /not/ check whether the .o file exists -mkObjPath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkObjPath dflags basename mod_basename = obj_basename <.> osuf - where - odir = objectDir dflags - osuf = objectSuf dflags - - obj_basename | Just dir <- odir = dir mod_basename - | otherwise = basename - - --- | Constructs the filename of a .hi file for a given source file. --- Does /not/ check whether the .hi file exists -mkHiPath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkHiPath dflags basename mod_basename = hi_basename <.> hisuf - where - hidir = hiDir dflags - hisuf = hiSuf dflags - - hi_basename | Just dir <- hidir = dir mod_basename - | otherwise = basename - --- | Constructs the filename of a .hie file for a given source file. --- Does /not/ check whether the .hie file exists -mkHiePath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> FilePath -mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf - where - hiedir = hieDir dflags - hiesuf = hieSuf dflags - - hie_basename | Just dir <- hiedir = dir mod_basename - | otherwise = basename - - - --- ----------------------------------------------------------------------------- --- Filenames of the stub files - --- We don't have to store these in ModLocations, because they can be derived --- from other available information, and they're only rarely needed. - -mkStubPaths - :: DynFlags - -> ModuleName - -> ModLocation - -> FilePath - -mkStubPaths dflags mod location - = let - stubdir = stubDir dflags - - mod_basename = moduleNameSlashes mod - src_basename = dropExtension $ expectJust "mkStubPaths" - (ml_hs_file location) - - stub_basename0 - | Just dir <- stubdir = dir mod_basename - | otherwise = src_basename - - stub_basename = stub_basename0 ++ "_stub" - in - stub_basename <.> "h" - --- ----------------------------------------------------------------------------- --- findLinkable isn't related to the other stuff in here, --- but there's no other obvious place for it - -findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) -findObjectLinkableMaybe mod locn - = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn - case maybe_obj_time of - Nothing -> return Nothing - Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) - --- Make an object linkable when we know the object file exists, and we know --- its modification time. -findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) - -- We used to look for _stub.o files here, but that was a bug (#706) - -- Now GHC merges the stub.o into the main .o (#3687) - --- ----------------------------------------------------------------------------- --- Error messages - -cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc -cannotFindModule flags mod res = - cantFindErr (sLit cannotFindMsg) - (sLit "Ambiguous module name") - flags mod res - where - cannotFindMsg = - case res of - NotFound { fr_mods_hidden = hidden_mods - , fr_pkgs_hidden = hidden_pkgs - , fr_unusables = unusables } - | not (null hidden_mods && null hidden_pkgs && null unusables) - -> "Could not load module" - _ -> "Could not find module" - -cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") - (sLit "Ambiguous interface for") - -cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult - -> SDoc -cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) - | Just pkgs <- unambiguousPackages - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [text "it was found in multiple packages:", - hsep (map ppr pkgs) ] - ) - | otherwise - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - vcat (map pprMod mods) - ) - where - unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnitId m : xs) - unambiguousPackage _ _ = Nothing - - pprMod (m, o) = text "it is bound as" <+> ppr m <+> - text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( - if e == Just True - then [text "package" <+> ppr (moduleUnitId m)] - else [] ++ - map ((text "a reexport in package" <+>) - .ppr.packageConfigId) res ++ - if f then [text "a package flag"] else [] - ) - -cantFindErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - more_info - = case find_result of - NoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" - - NotFound { fr_paths = files, fr_pkg = mb_pkg - , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens - , fr_unusables = unusables, fr_suggestions = suggest } - | Just pkg <- mb_pkg, pkg /= thisPackage dflags - -> not_found_in_package pkg files - - | not (null suggest) - -> pp_suggestions suggest $$ tried_these files dflags - - | null files && null mod_hiddens && - null pkg_hiddens && null unusables - -> text "It is not a module in the current program, or in any known package." - - | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ - vcat (map mod_hidden mod_hiddens) $$ - vcat (map unusable unusables) $$ - tried_these files dflags - - _ -> panic "cantFindErr" - - build_tag = buildTag dflags - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files dflags - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files dflags - - pkg_hidden :: UnitId -> SDoc - pkg_hidden pkgid = - text "It is a member of the hidden package" - <+> quotes (ppr pkgid) - --FIXME: we don't really want to show the unit id here we should - -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint pkgid - pkg_hidden_hint pkgid - | gopt Opt_BuildingCabalPackage dflags - = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid) - in text "Perhaps you need to add" <+> - quotes (ppr (packageName pkg)) <+> - text "to the build-depends in your .cabal file." - | Just pkg <- lookupPackage dflags pkgid - = text "You can run" <+> - quotes (text ":set -package " <> ppr (packageName pkg)) <+> - text "to expose it." $$ - text "(Note: this unloads all the modules in the current scope.)" - | otherwise = Outputable.empty - - mod_hidden pkg = - text "it is a hidden module in the package" <+> quotes (ppr pkg) - - unusable (pkg, reason) - = text "It is a member of the package" - <+> quotes (ppr pkg) - $$ pprReason (text "which is") reason - - pp_suggestions :: [ModuleSuggestion] -> SDoc - pp_suggestions sugs - | null sugs = Outputable.empty - | otherwise = hang (text "Perhaps you meant") - 2 (vcat (map pp_sugg sugs)) - - -- NB: Prefer the *original* location, and then reexports, and then - -- package flags when making suggestions. ToDo: if the original package - -- also has a reexport, prefer that one - pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigPackage = e, - fromExposedReexport = res, - fromPackageFlag = f }) - | Just True <- e - = parens (text "from" <+> ppr (moduleUnitId mod)) - | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnitId mod)) - | (pkg:_) <- res - = parens (text "from" <+> ppr (packageConfigId pkg) - <> comma <+> text "reexporting" <+> ppr mod) - | f - = parens (text "defined via package flags to be" - <+> ppr mod) - | otherwise = Outputable.empty - pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigPackage = e, - fromHiddenReexport = rhs }) - | Just False <- e - = parens (text "needs flag -package-key" - <+> ppr (moduleUnitId mod)) - | (pkg:_) <- rhs - = parens (text "needs flag -package-id" - <+> ppr (packageConfigId pkg)) - | otherwise = Outputable.empty - -cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName - -> InstalledFindResult -> SDoc -cantFindInstalledErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - more_info - = case find_result of - InstalledNoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg - - InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags) - -> not_found_in_package pkg files - - | null files - -> text "It is not a module in the current program, or in any known package." - - | otherwise - -> tried_these files dflags - - _ -> panic "cantFindInstalledErr" - - build_tag = buildTag dflags - - looks_like_srcpkgid :: InstalledUnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id FastString into a source package ID - -- FastString and see if it means anything. - | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files dflags - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files dflags - -tried_these :: [FilePath] -> DynFlags -> SDoc -tried_these files dflags - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v (or `:set -v` in ghci) " <> - text "to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/main/GHC.hs b/main/GHC.hs deleted file mode 100644 --- a/main/GHC.hs +++ /dev/null @@ -1,1568 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-} -{-# LANGUAGE TupleSections, NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2012 --- --- The GHC API --- --- ----------------------------------------------------------------------------- - -module GHC ( - -- * Initialisation - defaultErrorHandler, - defaultCleanupHandler, - prettyPrintGhcErrors, - withSignalHandlers, - withCleanupSession, - - -- * GHC Monad - Ghc, GhcT, GhcMonad(..), HscEnv, - runGhc, runGhcT, initGhcMonad, - gcatch, gbracket, gfinally, - printException, - handleSourceError, - needsTemplateHaskellOrQQ, - - -- * Flags and settings - DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt, - GhcMode(..), GhcLink(..), defaultObjectTarget, - parseDynamicFlags, - getSessionDynFlags, setSessionDynFlags, - getProgramDynFlags, setProgramDynFlags, setLogAction, - getInteractiveDynFlags, setInteractiveDynFlags, - - -- * Targets - Target(..), TargetId(..), Phase, - setTargets, - getTargets, - addTarget, - removeTarget, - guessTarget, - - -- * Loading\/compiling the program - depanal, - load, LoadHowMuch(..), InteractiveImport(..), - SuccessFlag(..), succeeded, failed, - defaultWarnErrLogger, WarnErrLogger, - workingDirectoryChanged, - parseModule, typecheckModule, desugarModule, loadModule, - ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), - TypecheckedSource, ParsedSource, RenamedSource, -- ditto - TypecheckedMod, ParsedMod, - moduleInfo, renamedSource, typecheckedSource, - parsedSource, coreModule, - - -- ** Compiling to Core - CoreModule(..), - compileToCoreModule, compileToCoreSimplified, - - -- * Inspecting the module structure of the program - ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, - mgLookupModule, - ModSummary(..), ms_mod_name, ModLocation(..), - getModSummary, - getModuleGraph, - isLoaded, - topSortModuleGraph, - - -- * Inspecting modules - ModuleInfo, - getModuleInfo, - modInfoTyThings, - modInfoTopLevelScope, - modInfoExports, - modInfoExportsWithSelectors, - modInfoInstances, - modInfoIsExportedName, - modInfoLookupName, - modInfoIface, - modInfoRdrEnv, - modInfoSafe, - lookupGlobalName, - findGlobalAnns, - mkPrintUnqualifiedForModule, - ModIface, ModIface_(..), - SafeHaskellMode(..), - - -- * Querying the environment - -- packageDbModules, - - -- * Printing - PrintUnqualified, alwaysQualify, - - -- * Interactive evaluation - - -- ** Executing statements - execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), - resumeExec, - - -- ** Adding new declarations - runDecls, runDeclsWithLocation, runParsedDecls, - - -- ** Get/set the current context - parseImportDecl, - setContext, getContext, - setGHCiMonad, getGHCiMonad, - - -- ** Inspecting the current context - getBindings, getInsts, getPrintUnqual, - findModule, lookupModule, - isModuleTrusted, moduleTrustReqs, - getNamesInScope, - getRdrNamesInScope, - getGRE, - moduleIsInterpreted, - getInfo, - showModule, - moduleIsBootOrNotObjectLinkable, - getNameToInstancesIndex, - - -- ** Inspecting types and kinds - exprType, TcRnExprMode(..), - typeKind, - - -- ** Looking up a Name - parseName, - lookupName, - - -- ** Compiling expressions - HValue, parseExpr, compileParsedExpr, - InteractiveEval.compileExpr, dynCompileExpr, - ForeignHValue, - compileExprRemote, compileParsedExprRemote, - - -- ** Docs - getDocs, GetDocsFailure(..), - - -- ** Other - runTcInteractive, -- Desired by some clients (#8878) - isStmt, hasImport, isImport, isDecl, - - -- ** The debugger - SingleStep(..), - Resume(..), - History(historyBreakInfo, historyEnclosingDecls), - GHC.getHistorySpan, getHistoryModule, - abandon, abandonAll, - getResumeContext, - GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, - modInfoModBreaks, - ModBreaks(..), BreakIndex, - BreakInfo(breakInfo_number, breakInfo_module), - InteractiveEval.back, - InteractiveEval.forward, - - -- * Abstract syntax elements - - -- ** Packages - UnitId, - - -- ** Modules - Module, mkModule, pprModule, moduleName, moduleUnitId, - ModuleName, mkModuleName, moduleNameString, - - -- ** Names - Name, - isExternalName, nameModule, pprParenSymName, nameSrcSpan, - NamedThing(..), - RdrName(Qual,Unqual), - - -- ** Identifiers - Id, idType, - isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, - recordSelectorTyCon, - - -- ** Type constructors - TyCon, - tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, - isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, - tyConClass_maybe, - synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, - - -- ** Type variables - TyVar, - alphaTyVars, - - -- ** Data constructors - DataCon, - dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, dataConUserType, - dataConSrcBangs, - StrictnessMark(..), isMarkedStrict, - - -- ** Classes - Class, - classMethods, classSCTheta, classTvsFds, classATs, - pprFundeps, - - -- ** Instances - ClsInst, - instanceDFunId, - pprInstance, pprInstanceHdr, - pprFamInst, - - FamInst, - - -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, - Kind, - PredType, - ThetaType, pprForAll, pprThetaArrowTy, - parseInstanceHead, - getInstancesForType, - - -- ** Entities - TyThing(..), - - -- ** Syntax - module GHC.Hs, -- ToDo: remove extraneous bits - - -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, - compareFixity, - LexicalFixity(..), - - -- ** Source locations - SrcLoc(..), RealSrcLoc, - mkSrcLoc, noSrcLoc, - srcLocFile, srcLocLine, srcLocCol, - SrcSpan(..), RealSrcSpan, - mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, - srcSpanStart, srcSpanEnd, - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Located - GenLocated(..), Located, - - -- *** Constructing Located - noLoc, mkGeneralLocated, - - -- *** Deconstructing Located - getLoc, unLoc, - getRealSrcSpan, unRealSrcSpan, - - -- ** HasSrcSpan - HasSrcSpan(..), SrcSpanLess, dL, cL, - - -- *** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, - - -- * Exceptions - GhcException(..), showGhcException, - - -- * Token stream manipulations - Token, - getTokenStream, getRichTokenStream, - showRichTokenStream, addSourceToTokens, - - -- * Pure interface to the parser - parser, - - -- * API Annotations - ApiAnns,AnnKeywordId(..),AnnotationComment(..), - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments, getAndRemoveAnnotationComments, - unicodeAnn, - - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, - ) where - -{- - ToDo: - - * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. --} - -#include "HsVersions.h" - -import GhcPrelude hiding (init) - -import ByteCodeTypes -import InteractiveEval -import InteractiveEvalTypes -import GHCi -import GHCi.RemoteTypes - -import PprTyThing ( pprFamInst ) -import HscMain -import GhcMake -import DriverPipeline ( compileOne' ) -import GhcMonad -import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) -import LoadIface ( loadSysInterface ) -import TcRnTypes -import Predicate -import Packages -import NameSet -import RdrName -import GHC.Hs -import Type hiding( typeKind ) -import TcType -import Id -import TysPrim ( alphaTyVars ) -import TyCon -import TyCoPpr ( pprForAll ) -import Class -import DataCon -import Name hiding ( varName ) -import Avail -import InstEnv -import FamInstEnv ( FamInst ) -import SrcLoc -import CoreSyn -import TidyPgm -import DriverPhases ( Phase(..), isHaskellSrcFilename ) -import Finder -import HscTypes -import CmdLineParser -import DynFlags hiding (WarnReason(..)) -import SysTools -import SysTools.BaseDir -import Annotations -import Module -import Panic -import GHC.Platform -import Bag ( listToBag ) -import ErrUtils -import MonadUtils -import Util -import StringBuffer -import Outputable -import BasicTypes -import Maybes ( expectJust ) -import FastString -import qualified Parser -import Lexer -import ApiAnnotation -import qualified GHC.LanguageExtensions as LangExt -import NameEnv -import CoreFVs ( orphNamesOfFamInst ) -import FamInstEnv ( famInstEnvElts ) -import TcRnDriver -import Inst -import FamInst -import FileCleanup - -import Data.Foldable -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Sequence as Seq -import System.Directory ( doesFileExist ) -import Data.Maybe -import Data.Time -import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) -import Control.Monad -import System.Exit ( exitWith, ExitCode(..) ) -import Exception -import Data.IORef -import System.FilePath - - --- %************************************************************************ --- %* * --- Initialisation: exception handlers --- %* * --- %************************************************************************ - - --- | Install some default exception handlers and run the inner computation. --- Unless you want to handle exceptions yourself, you should wrap this around --- the top level of your program. The default handlers output the error --- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m) - => FatalMessager -> FlushOut -> m a -> m a -defaultErrorHandler fm (FlushOut flushOut) inner = - -- top-level exception handler: any unrecognised exception is a compiler bug. - ghandle (\exception -> liftIO $ do - flushOut - case fromException exception of - -- an IO exception probably isn't our fault, so don't panic - Just (ioe :: IOException) -> - fatalErrorMsg'' fm (show ioe) - _ -> case fromException exception of - Just UserInterrupt -> - -- Important to let this one propagate out so our - -- calling process knows we were interrupted by ^C - liftIO $ throwIO UserInterrupt - Just StackOverflow -> - fatalErrorMsg'' fm "stack overflow: use +RTS -K to increase it" - _ -> case fromException exception of - Just (ex :: ExitCode) -> liftIO $ throwIO ex - _ -> - fatalErrorMsg'' fm - (show (Panic (show exception))) - exitWith (ExitFailure 1) - ) $ - - -- error messages propagated as exceptions - handleGhcException - (\ge -> liftIO $ do - flushOut - case ge of - Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg'' fm (show ge) - exitWith (ExitFailure 1) - ) $ - inner - --- | This function is no longer necessary, cleanup is now done by --- runGhc/runGhcT. -{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} -defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a -defaultCleanupHandler _ m = m - where _warning_suppression = m `gonException` undefined - - --- %************************************************************************ --- %* * --- The Ghc Monad --- %* * --- %************************************************************************ - --- | Run function for the 'Ghc' monad. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. --- --- Any errors not handled inside the 'Ghc' action are propagated as IO --- exceptions. - -runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> Ghc a -- ^ The action to perform. - -> IO a -runGhc mb_top_dir ghc = do - ref <- newIORef (panic "empty session") - let session = Session ref - flip unGhc session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghc - --- | Run function for 'GhcT' monad transformer. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. - -runGhcT :: ExceptionMonad m => - Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> GhcT m a -- ^ The action to perform. - -> m a -runGhcT mb_top_dir ghct = do - ref <- liftIO $ newIORef (panic "empty session") - let session = Session ref - flip unGhcT session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghct - -withCleanupSession :: GhcMonad m => m a -> m a -withCleanupSession ghc = ghc `gfinally` cleanup - where - cleanup = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - liftIO $ do - cleanTempFiles dflags - cleanTempDirs dflags - stopIServ hsc_env -- shut down the IServ - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. - --- | Initialise a GHC session. --- --- If you implement a custom 'GhcMonad' you must call this function in the --- monad run function. It will initialise the session variable and clear all --- warnings. --- --- The first argument should point to the directory where GHC's library files --- reside. More precisely, this should be the output of @ghc --print-libdir@ --- of the version of GHC the module using this API is compiled with. For --- portability, you should use the @ghc-paths@ package, available at --- . - -initGhcMonad :: GhcMonad m => Maybe FilePath -> m () -initGhcMonad mb_top_dir - = do { env <- liftIO $ - do { top_dir <- findTopDir mb_top_dir - ; mySettings <- initSysTools top_dir - ; myLlvmConfig <- lazyInitLlvmConfig top_dir - ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) - ; checkBrokenTablesNextToCode dflags - ; setUnsafeGlobalDynFlags dflags - -- c.f. DynFlags.parseDynamicFlagsFull, which - -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; newHscEnv dflags } - ; setSession env } - --- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which --- breaks tables-next-to-code in dynamically linked modules. This --- check should be more selective but there is currently no released --- version where this bug is fixed. --- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and --- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 -checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () -checkBrokenTablesNextToCode dflags - = do { broken <- checkBrokenTablesNextToCode' dflags - ; when broken - $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr - ; liftIO $ fail "unsupported linker" - } - } - where - invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> - text "when using binutils ld (please see:" <+> - text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" - -checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool -checkBrokenTablesNextToCode' dflags - | not (isARM arch) = return False - | WayDyn `notElem` ways dflags = return False - | not (tablesNextToCode dflags) = return False - | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo dflags - case linkerInfo of - GnuLD _ -> return True - _ -> return False - where platform = targetPlatform dflags - arch = platformArch platform - - --- %************************************************************************ --- %* * --- Flags & settings --- %* * --- %************************************************************************ - --- $DynFlags --- --- The GHC session maintains two sets of 'DynFlags': --- --- * The "interactive" @DynFlags@, which are used for everything --- related to interactive evaluation, including 'runStmt', --- 'runDecls', 'exprType', 'lookupName' and so on (everything --- under \"Interactive evaluation\" in this module). --- --- * The "program" @DynFlags@, which are used when loading --- whole modules with 'load' --- --- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the --- interactive @DynFlags@. --- --- 'setProgramDynFlags', 'getProgramDynFlags' work with the --- program @DynFlags@. --- --- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' --- retrieves the program @DynFlags@ (for backwards compatibility). - - --- | Updates both the interactive and program DynFlags in a Session. --- This also reads the package database (unless it has already been --- read), and prepares the compilers knowledge about packages. It can --- be called again to load new packages: just add new package flags to --- (packageFlags dflags). --- --- Returns a list of new packages that may need to be linked in using --- the dynamic linker (see 'linkPackages') as a result of new package --- flags. If you are not doing linking or doing static linking, you --- can ignore the list of packages returned. --- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setSessionDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - (dflags'', preload) <- liftIO $ initPackages dflags' - modifySession $ \h -> h{ hsc_dflags = dflags'' - , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } } - invalidateModSummaryCache - return preload - --- | Sets the program 'DynFlags'. Note: this invalidates the internal --- cached module graph, causing more work to be done the next time --- 'load' is called. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setProgramDynFlags dflags = setProgramDynFlags_ True dflags - --- | Set the action taken when the compiler produces a message. This --- can also be accomplished using 'setProgramDynFlags', but using --- 'setLogAction' avoids invalidating the cached module graph. -setLogAction :: GhcMonad m => LogAction -> m () -setLogAction action = do - dflags' <- getProgramDynFlags - void $ setProgramDynFlags_ False $ - dflags' { log_action = action } - -setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] -setProgramDynFlags_ invalidate_needed dflags = do - dflags' <- checkNewDynFlags dflags - dflags_prev <- getProgramDynFlags - (dflags'', preload) <- - if (packageFlagsChanged dflags_prev dflags') - then liftIO $ initPackages dflags' - else return (dflags', []) - modifySession $ \h -> h{ hsc_dflags = dflags'' } - when invalidate_needed $ invalidateModSummaryCache - return preload - - --- When changing the DynFlags, we want the changes to apply to future --- loads, but without completely discarding the program. But the --- DynFlags are cached in each ModSummary in the hsc_mod_graph, so --- after a change to DynFlags, the changes would apply to new modules --- but not existing modules; this seems undesirable. --- --- Furthermore, the GHC API client might expect that changing --- log_action would affect future compilation messages, but for those --- modules we have cached ModSummaries for, we'll continue to use the --- old log_action. This is definitely wrong (#7478). --- --- Hence, we invalidate the ModSummary cache after changing the --- DynFlags. We do this by tweaking the date on each ModSummary, so --- that the next downsweep will think that all the files have changed --- and preprocess them again. This won't necessarily cause everything --- to be recompiled, because by the time we check whether we need to --- recopmile a module, we'll have re-summarised the module and have a --- correct ModSummary. --- -invalidateModSummaryCache :: GhcMonad m => m () -invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } - where - inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } - --- | Returns the program 'DynFlags'. -getProgramDynFlags :: GhcMonad m => m DynFlags -getProgramDynFlags = getSessionDynFlags - --- | Set the 'DynFlags' used to evaluate interactive expressions. --- Note: this cannot be used for changes to packages. Use --- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the --- 'pkgState' into the interactive @DynFlags@. -setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () -setInteractiveDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- checkNewInteractiveDynFlags dflags' - modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }} - --- | Get the 'DynFlags' used to evaluate interactive expressions. -getInteractiveDynFlags :: GhcMonad m => m DynFlags -getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) - - -parseDynamicFlags :: MonadIO m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlags = parseDynamicFlagsCmdLine - --- | Checks the set of new DynFlags for possibly erroneous option --- combinations when invoking 'setSessionDynFlags' and friends, and if --- found, returns a fixed copy (if possible). -checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewDynFlags dflags = do - -- See Note [DynFlags consistency] - let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings) - return dflags' - -checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewInteractiveDynFlags dflags0 = do - -- We currently don't support use of StaticPointers in expressions entered on - -- the REPL. See #12356. - if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowWarnings dflags0 $ listToBag - [mkPlainWarnMsg dflags0 interactiveSrcSpan - $ text "StaticPointers is not supported in GHCi interactive expressions."] - return $ xopt_unset dflags0 LangExt.StaticPointers - else return dflags0 - - --- %************************************************************************ --- %* * --- Setting, getting, and modifying the targets --- %* * --- %************************************************************************ - --- ToDo: think about relative vs. absolute file paths. And what --- happens when the current directory changes. - --- | Sets the targets for this session. Each target may be a module name --- or a filename. The targets correspond to the set of root modules for --- the program\/library. Unloading the current program is achieved by --- setting the current set of targets to be empty, followed by 'load'. -setTargets :: GhcMonad m => [Target] -> m () -setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) - --- | Returns the current set of targets -getTargets :: GhcMonad m => m [Target] -getTargets = withSession (return . hsc_targets) - --- | Add another target. -addTarget :: GhcMonad m => Target -> m () -addTarget target - = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) - --- | Remove a target -removeTarget :: GhcMonad m => TargetId -> m () -removeTarget target_id - = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) - where - filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] - --- | Attempts to guess what Target a string refers to. This function --- implements the @--make@/GHCi command-line syntax for filenames: --- --- - if the string looks like a Haskell source filename, then interpret it --- as such --- --- - if adding a .hs or .lhs suffix yields the name of an existing file, --- then use that --- --- - otherwise interpret the string as a module name --- -guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target -guessTarget str (Just phase) - = return (Target (TargetFile str (Just phase)) True Nothing) -guessTarget str Nothing - | isHaskellSrcFilename file - = return (target (TargetFile file Nothing)) - | otherwise - = do exists <- liftIO $ doesFileExist hs_file - if exists - then return (target (TargetFile hs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lhs_file - if exists - then return (target (TargetFile lhs_file Nothing)) - else do - if looksLikeModuleName file - then return (target (TargetModule (mkModuleName file))) - else do - dflags <- getDynFlags - liftIO $ throwGhcExceptionIO - (ProgramError (showSDoc dflags $ - text "target" <+> quotes (text file) <+> - text "is not a module name or a source file")) - where - (file,obj_allowed) - | '*':rest <- str = (rest, False) - | otherwise = (str, True) - - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" - - target tid = Target tid obj_allowed Nothing - - --- | Inform GHC that the working directory has changed. GHC will flush --- its cache of module locations, since it may no longer be valid. --- --- Note: Before changing the working directory make sure all threads running --- in the same session have stopped. If you change the working directory, --- you should also unload the current program (set targets to empty, --- followed by load). -workingDirectoryChanged :: GhcMonad m => m () -workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) - - --- %************************************************************************ --- %* * --- Running phases one at a time --- %* * --- %************************************************************************ - -class ParsedMod m where - modSummary :: m -> ModSummary - parsedSource :: m -> ParsedSource - -class ParsedMod m => TypecheckedMod m where - renamedSource :: m -> Maybe RenamedSource - typecheckedSource :: m -> TypecheckedSource - moduleInfo :: m -> ModuleInfo - tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. - -class TypecheckedMod m => DesugaredMod m where - coreModule :: m -> ModGuts - --- | The result of successful parsing. -data ParsedModule = - ParsedModule { pm_mod_summary :: ModSummary - , pm_parsed_source :: ParsedSource - , pm_extra_src_files :: [FilePath] - , pm_annotations :: ApiAnns } - -- See Note [Api annotations] in ApiAnnotation.hs - -instance ParsedMod ParsedModule where - modSummary m = pm_mod_summary m - parsedSource m = pm_parsed_source m - --- | The result of successful typechecking. It also contains the parser --- result. -data TypecheckedModule = - TypecheckedModule { tm_parsed_module :: ParsedModule - , tm_renamed_source :: Maybe RenamedSource - , tm_typechecked_source :: TypecheckedSource - , tm_checked_module_info :: ModuleInfo - , tm_internals_ :: (TcGblEnv, ModDetails) - } - -instance ParsedMod TypecheckedModule where - modSummary m = modSummary (tm_parsed_module m) - parsedSource m = parsedSource (tm_parsed_module m) - -instance TypecheckedMod TypecheckedModule where - renamedSource m = tm_renamed_source m - typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m - tm_internals m = tm_internals_ m - --- | The result of successful desugaring (i.e., translation to core). Also --- contains all the information of a typechecked module. -data DesugaredModule = - DesugaredModule { dm_typechecked_module :: TypecheckedModule - , dm_core_module :: ModGuts - } - -instance ParsedMod DesugaredModule where - modSummary m = modSummary (dm_typechecked_module m) - parsedSource m = parsedSource (dm_typechecked_module m) - -instance TypecheckedMod DesugaredModule where - renamedSource m = renamedSource (dm_typechecked_module m) - typecheckedSource m = typecheckedSource (dm_typechecked_module m) - moduleInfo m = moduleInfo (dm_typechecked_module m) - tm_internals m = tm_internals_ (dm_typechecked_module m) - -instance DesugaredMod DesugaredModule where - coreModule m = dm_core_module m - -type ParsedSource = Located (HsModule GhcPs) -type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString) -type TypecheckedSource = LHsBinds GhcTc - --- NOTE: --- - things that aren't in the output of the typechecker right now: --- - the export list --- - the imports --- - type signatures --- - type/data/newtype declarations --- - class declarations --- - instances --- - extra things in the typechecker's output: --- - default methods are turned into top-level decls. --- - dictionary bindings - --- | Return the 'ModSummary' of a module with the given name. --- --- The module must be part of the module graph (see 'hsc_mod_graph' and --- 'ModuleGraph'). If this is not the case, this function will throw a --- 'GhcApiError'. --- --- This function ignores boot modules and requires that there is only one --- non-boot module with the given name. -getModSummary :: GhcMonad m => ModuleName -> m ModSummary -getModSummary mod = do - mg <- liftM hsc_mod_graph getSession - let mods_by_name = [ ms | ms <- mgModSummaries mg - , ms_mod_name ms == mod - , not (isBootSummary ms) ] - case mods_by_name of - [] -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph") - [ms] -> return ms - multiple -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) - --- | Parse a module. --- --- Throws a 'SourceError' on parse error. -parseModule :: GhcMonad m => ModSummary -> m ParsedModule -parseModule ms = do - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - hpm <- liftIO $ hscParse hsc_env_tmp ms - return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) - (hpm_annotations hpm)) - -- See Note [Api annotations] in ApiAnnotation.hs - --- | Typecheck and rename a parsed module. --- --- Throws a 'SourceError' if either fails. -typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule -typecheckModule pmod = do - let ms = modSummary pmod - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } - details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env - safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - - return $ - TypecheckedModule { - tm_internals_ = (tc_gbl_env, details), - tm_parsed_module = pmod, - tm_renamed_source = rn_info, - tm_typechecked_source = tcg_binds tc_gbl_env, - tm_checked_module_info = - ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = fixSafeInstances safe $ md_insts details, - minf_iface = Nothing, - minf_safe = safe, - minf_modBreaks = emptyModBreaks - }} - --- | Desugar a typechecked module. -desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule -desugarModule tcm = do - let ms = modSummary tcm - let (tcg, _) = tm_internals tcm - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg - return $ - DesugaredModule { - dm_typechecked_module = tcm, - dm_core_module = guts - } - --- | Load a module. Input doesn't need to be desugared. --- --- A module must be loaded before dependent modules can be typechecked. This --- always includes generating a 'ModIface' and, depending on the --- 'DynFlags.hscTarget', may also include code generation. --- --- This function will always cause recompilation and will always overwrite --- previous compilation results (potentially files on disk). --- -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod -loadModule tcm = do - let ms = modSummary tcm - let mod = ms_mod_name ms - let loc = ms_location ms - let (tcg, _details) = tm_internals tcm - - mb_linkable <- case ms_obj_date ms of - Just t | t > ms_hs_date ms -> do - l <- liftIO $ findObjectLinkable (ms_mod ms) - (ml_obj_file loc) t - return (Just l) - _otherwise -> return Nothing - - let source_modified | isNothing mb_linkable = SourceModified - | otherwise = SourceUnmodified - -- we can't determine stability here - - -- compile doesn't change the session - hsc_env <- getSession - mod_info <- liftIO $ compileOne' (Just tcg) Nothing - hsc_env ms 1 1 Nothing mb_linkable - source_modified - - modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info } - return tcm - - --- %************************************************************************ --- %* * --- Dealing with Core --- %* * --- %************************************************************************ - --- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for --- the 'GHC.compileToCoreModule' interface. -data CoreModule - = CoreModule { - -- | Module name - cm_module :: !Module, - -- | Type environment for types declared in this module - cm_types :: !TypeEnv, - -- | Declarations - cm_binds :: CoreProgram, - -- | Safe Haskell mode - cm_safe :: SafeHaskellMode - } - -instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, - cm_safe = sf}) - = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te - $$ vcat (map ppr cb) - --- | This is the way to get access to the Core bindings corresponding --- to a module. 'compileToCore' parses, typechecks, and --- desugars the module, then returns the resulting Core module (consisting of --- the module name, type declarations, and function declarations) if --- successful. -compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule -compileToCoreModule = compileCore False - --- | Like compileToCoreModule, but invokes the simplifier, so --- as to return simplified and tidied Core. -compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule -compileToCoreSimplified = compileCore True - -compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule -compileCore simplify fn = do - -- First, set the target to the desired filename - target <- guessTarget fn Nothing - addTarget target - _ <- load LoadAllTargets - -- Then find dependencies - modGraph <- depanal [] True - case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of - Just modSummary -> do - -- Now we have the module name; - -- parse, typecheck and desugar the module - (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly? - do tm <- typecheckModule =<< parseModule modSummary - let tcg = fst (tm_internals tm) - (,) tcg . coreModule <$> desugarModule tm - liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ - if simplify - then do - -- If simplify is true: simplify (hscSimplify), then tidy - -- (tidyProgram). - hsc_env <- getSession - simpl_guts <- liftIO $ do - plugins <- readIORef (tcg_th_coreplugins tcg) - hscSimplify hsc_env plugins mod_guts - tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts - return $ Left tidy_guts - else - return $ Right mod_guts - - Nothing -> panic "compileToCoreModule: target FilePath not found in\ - module dependency graph" - where -- two versions, based on whether we simplify (thus run tidyProgram, - -- which returns a (CgGuts, ModDetails) pair, or not (in which case - -- we just have a ModGuts. - gutsToCoreModule :: SafeHaskellMode - -> Either (CgGuts, ModDetails) ModGuts - -> CoreModule - gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { - cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg, - cm_safe = safe_mode - } - gutsToCoreModule safe_mode (Right mg) = CoreModule { - cm_module = mg_module mg, - cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) - (mg_tcs mg) - (mg_fam_insts mg), - cm_binds = mg_binds mg, - cm_safe = safe_mode - } - --- %************************************************************************ --- %* * --- Inspecting the session --- %* * --- %************************************************************************ - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - --- | Return @True@ <==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> - return $! isJust (lookupHpt (hsc_HPT hsc_env) m) - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - return $ icInScopeTTs $ hsc_IC hsc_env - --- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) -getInsts = withSession $ \hsc_env -> - return $ ic_instances (hsc_IC hsc_env) - -getPrintUnqual :: GhcMonad m => m PrintUnqualified -getPrintUnqual = withSession $ \hsc_env -> - return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: [AvailInfo], - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: ModBreaks - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - let mg = hsc_mod_graph hsc_env - if mgElemModule mg mdl - then liftIO $ getHomeModuleInfo hsc_env mdl - else do - {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl - -- ToDo: we don't understand what the following comment means. - -- (SDM, 19/7/2011) - -- getPackageModuleInfo will attempt to find the interface, so - -- we don't want to call it for a home module, just in case there - -- was a problem loading the module and the interface doesn't - -- exist... hence the isHomeModule test here. (ToDo: reinstate) - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env - iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = avails, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = emptyModBreaks - })) - -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] -modInfoTopLevelScope minf - = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = concatMap availNames $! minf_exports minf - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [ClsInst] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) - -mkPrintUnqualifiedForModule :: GhcMonad m => - ModuleInfo - -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X -mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name - -modInfoIface :: ModuleInfo -> Maybe ModIface -modInfoIface = minf_iface - -modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv -modInfoRdrEnv = minf_rdr_env - --- | Retrieve module safe haskell mode -modInfoSafe :: ModuleInfo -> SafeHaskellMode -modInfoSafe = minf_safe - -modInfoModBreaks :: ModuleInfo -> ModBreaks -modInfoModBreaks = minf_modBreaks - -isDictonaryId :: Id -> Bool -isDictonaryId id - = case tcSplitSigmaTy (idType id) of { - (_tvs, _theta, tau) -> isDictTy tau } - --- | Looks up a global name: that is, any top-level name in any --- visible module. Unlike 'lookupName', lookupGlobalName does not use --- the interactive context, and therefore does not require a preceding --- 'setContext'. -lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupGlobalName name = withSession $ \hsc_env -> do - liftIO $ lookupTypeHscEnv hsc_env name - -findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] -findGlobalAnns deserialize target = withSession $ \hsc_env -> do - ann_env <- liftIO $ prepareAnnotations hsc_env Nothing - return (findAnns deserialize ann_env target) - --- | get the GlobalRdrEnv for a session -getGRE :: GhcMonad m => m GlobalRdrEnv -getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) - --- | Retrieve all type and family instances in the environment, indexed --- by 'Name'. Each name's lists will contain every instance in which that name --- is mentioned in the instance head. -getNameToInstancesIndex :: GhcMonad m - => [Module] -- ^ visible modules. An orphan instance will be returned - -- if it is visible from at least one module in the list. - -> Maybe [Module] -- ^ modules to load. If this is not specified, we load - -- modules for everything that is in scope unqualified. - -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) -getNameToInstancesIndex visible_mods mods_to_load = do - hsc_env <- getSession - liftIO $ runTcInteractive hsc_env $ - do { case mods_to_load of - Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env) - Just mods -> - let doc = text "Need interface for reporting instances in scope" - in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods - - ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs - ; let visible_mods' = mkModuleSet visible_mods - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- We use Data.Sequence.Seq because we are creating left associated - -- mappends. - -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts - ; let cls_index = Map.fromListWith mappend - [ (n, Seq.singleton ispec) - | ispec <- instEnvElts ie_local ++ instEnvElts ie_global - , instIsVisible visible_mods' ispec - , n <- nameSetElemsStable $ orphNamesOfClsInst ispec - ] - ; let fam_index = Map.fromListWith mappend - [ (n, Seq.singleton fispec) - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , n <- nameSetElemsStable $ orphNamesOfFamInst fispec - ] - ; return $ mkNameEnv $ - [ (nm, (toList clss, toList fams)) - | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend - (fmap (,Seq.empty) cls_index) - (fmap (Seq.empty,) fam_index) - ] } - --- ----------------------------------------------------------------------------- - -{- ToDo: Move the primary logic here to compiler/main/Packages.hs --- | Return all /external/ modules available in the package database. --- Modules from the current session (i.e., from the 'HomePackageTable') are --- not included. This includes module names which are reexported by packages. -packageDbModules :: GhcMonad m => - Bool -- ^ Only consider exposed packages. - -> m [Module] -packageDbModules only_exposed = do - dflags <- getSessionDynFlags - let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) - return $ - [ mkModule pid modname - | p <- pkgs - , not only_exposed || exposed p - , let pid = packageConfigId p - , modname <- exposedModules p - ++ map exportName (reexportedModules p) ] - -} - --- ----------------------------------------------------------------------------- --- Misc exported utils - -dataConType :: DataCon -> Type -dataConType dc = idType (dataConWrapId dc) - --- | print a 'NamedThing', adding parentheses if the name is an operator. -pprParenSymName :: NamedThing a => a -> SDoc -pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) - --- ---------------------------------------------------------------------------- - - --- ToDo: --- - Data and Typeable instances for HsSyn. - --- ToDo: check for small transformations that happen to the syntax in --- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) - --- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way --- to get from TyCons, Ids etc. to TH syntax (reify). - --- :browse will use either lm_toplev or inspect lm_interface, depending --- on whether the module is interpreted or not. - - --- Extract the filename, stringbuffer content and dynflags associed to a module --- --- XXX: Explain pre-conditions -getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) -getModuleSourceAndFlags mod = do - m <- getModSummary (moduleName mod) - case ml_hs_file $ ms_location m of - Nothing -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod) - Just sourceFile -> do - source <- liftIO $ hGetStringBuffer sourceFile - return (sourceFile, source, ms_hspp_opts m) - - --- | Return module source as token stream, including comments. --- --- The module must be in the module graph and its source must be available. --- Throws a 'HscTypes.SourceError' on parse error. -getTokenStream :: GhcMonad m => Module -> m [Located Token] -getTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return ts - PFailed pst -> - do dflags <- getDynFlags - throwErrors (getErrorMessages pst dflags) - --- | Give even more information on the source than 'getTokenStream' --- This function allows reconstructing the source completely with --- 'showRichTokenStream'. -getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] -getRichTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed pst -> - do dflags <- getDynFlags - throwErrors (getErrorMessages pst dflags) - --- | Given a source location and a StringBuffer corresponding to this --- location, return a rich token stream with the source associated to the --- tokens. -addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] - -> [(Located Token, String)] -addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(dL->L span _) : ts) - = case span of - UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts - RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts - where - (newLoc, newBuf, str) = go "" loc buf - start = realSrcSpanStart s - end = realSrcSpanEnd s - go acc loc buf | loc < start = go acc nLoc nBuf - | start <= loc && loc < end = go (ch:acc) nLoc nBuf - | otherwise = (loc, buf, reverse acc) - where (ch, nBuf) = nextChar buf - nLoc = advanceSrcLoc loc ch - - --- | Take a rich token stream such as produced from 'getRichTokenStream' and --- return source code almost identical to the original code (except for --- insignificant whitespace.) -showRichTokenStream :: [(Located Token, String)] -> String -showRichTokenStream ts = go startLoc ts "" - where sourceFile = getFile $ map (getLoc . fst) ts - getFile [] = panic "showRichTokenStream: No source file found" - getFile (UnhelpfulSpan _ : xs) = getFile xs - getFile (RealSrcSpan s : _) = srcSpanFile s - startLoc = mkRealSrcLoc sourceFile 1 1 - go _ [] = id - go loc ((dL->L span _, str):ts) - = case span of - UnhelpfulSpan _ -> go loc ts - RealSrcSpan s - | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) - . (str ++) - . go tokEnd ts - | otherwise -> ((replicate (tokLine - locLine) '\n') ++) - . ((replicate (tokCol - 1) ' ') ++) - . (str ++) - . go tokEnd ts - where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) - (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) - tokEnd = realSrcSpanEnd s - --- ----------------------------------------------------------------------------- --- Interactive evaluation - --- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the --- filesystem and package database to find the corresponding 'Module', --- using the algorithm that is used for an @import@ declaration. -findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> do - let - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - -- - case maybe_pkg of - Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m -> return m - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - _otherwise -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found loc m | moduleUnitId m /= this_pkg -> return m - | otherwise -> modNotLoadedError dflags m loc - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - -modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a -modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ - text "module is not loaded:" <+> - quotes (ppr (moduleName m)) <+> - parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) - --- | Like 'findModule', but differs slightly when the module refers to --- a source file, and the file has not been loaded via 'load'. In --- this case, 'findModule' will throw an error (module not loaded), --- but 'lookupModule' will check to see whether the module can also be --- found in a package, and if so, that package 'Module' will be --- returned. If not, the usual module-not-found error will be thrown. --- -lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) -lookupModule mod_name Nothing = withSession $ \hsc_env -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findExposedPackageModule hsc_env mod_name Nothing - case res of - Found _ m -> return m - err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err - -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) -lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) mod_name of - Just mod_info -> return (Just (mi_module (hm_iface mod_info))) - _not_a_home_module -> return Nothing - --- | Check that a module is safe to import (according to Safe Haskell). --- --- We return True to indicate the import is safe and False otherwise --- although in the False case an error may be thrown first. -isModuleTrusted :: GhcMonad m => Module -> m Bool -isModuleTrusted m = withSession $ \hsc_env -> - liftIO $ hscCheckSafe hsc_env m noSrcSpan - --- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId) -moduleTrustReqs m = withSession $ \hsc_env -> - liftIO $ hscGetSafe hsc_env m noSrcSpan - --- | Set the monad GHCi lifts user statements into. --- --- Checks that a type (in string form) is an instance of the --- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, --- throws an error otherwise. -setGHCiMonad :: GhcMonad m => String -> m () -setGHCiMonad name = withSession $ \hsc_env -> do - ty <- liftIO $ hscIsGHCiMonad hsc_env name - modifySession $ \s -> - let ic = (hsc_IC s) { ic_monad = ty } - in s { hsc_IC = ic } - --- | Get the monad GHCi lifts user statements into. -getGHCiMonad :: GhcMonad m => m Name -getGHCiMonad = fmap (ic_monad . hsc_IC) getSession - -getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> - return $ InteractiveEval.getHistorySpan hsc_env h - -obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term -obtainTermFromVal bound force ty a = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a - -obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermFromId bound force id = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id - - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupName name = - withSession $ \hsc_env -> - liftIO $ hscTcRcLookupName hsc_env name - --- ----------------------------------------------------------------------------- --- Pure API - --- | A pure interface to the module parser. --- -parser :: String -- ^ Haskell module source text (full Unicode is supported) - -> DynFlags -- ^ the flags - -> FilePath -- ^ the filename (for source locations) - -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs))) - -parser str dflags filename = - let - loc = mkRealSrcLoc (mkFastString filename) 1 1 - buf = stringToStringBuffer str - in - case unP Parser.parseModule (mkPState dflags buf loc) of - - PFailed pst -> - let (warns,errs) = getMessages pst dflags in - (warns, Left errs) - - POk pst rdr_module -> - let (warns,_) = getMessages pst dflags in - (warns, Right rdr_module) diff --git a/main/GhcMake.hs b/main/GhcMake.hs deleted file mode 100644 --- a/main/GhcMake.hs +++ /dev/null @@ -1,2721 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2011 --- --- This module implements multi-module compilation, and is used --- by --make and GHCi. --- --- ----------------------------------------------------------------------------- -module GhcMake( - depanal, depanalPartial, - load, load', LoadHowMuch(..), - - downsweep, - - topSortModuleGraph, - - ms_home_srcimps, ms_home_imps, - - IsBoot(..), - summariseModule, - hscSourceToIsBoot, - findExtraSigImports, - implicitRequirements, - - noModError, cyclicModuleErr, - moduleGraphNodes, SummaryNode - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import qualified Linker ( unload ) - -import DriverPhases -import DriverPipeline -import DynFlags -import ErrUtils -import Finder -import GhcMonad -import HeaderInfo -import HscTypes -import Module -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import HscMain - -import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) -import BasicTypes -import Digraph -import Exception ( tryIO, gbracket, gfinally ) -import FastString -import Maybes ( expectJust ) -import Name -import MonadUtils ( allM, MonadIO ) -import Outputable -import Panic -import SrcLoc -import StringBuffer -import UniqFM -import UniqDSet -import TcBackpack -import Packages -import UniqSet -import Util -import qualified GHC.LanguageExtensions as LangExt -import NameEnv -import FileCleanup - -import Data.Either ( rights, partitionEithers ) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Set as Set -import qualified FiniteMap as Map ( insertListWith ) - -import Control.Concurrent ( forkIOWithUnmask, killThread ) -import qualified GHC.Conc as CC -import Control.Concurrent.MVar -import Control.Concurrent.QSem -import Control.Exception -import Control.Monad -import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) -import Data.IORef -import Data.List -import qualified Data.List as List -import Data.Foldable (toList) -import Data.Maybe -import Data.Ord ( comparing ) -import Data.Time -import System.Directory -import System.FilePath -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) - -import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) - -label_self :: String -> IO () -label_self thread_name = do - self_tid <- CC.myThreadId - CC.labelThread self_tid thread_name - --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. --- --- Dependency analysis entails parsing the @import@ directives and may --- therefore require running certain preprocessors. --- --- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. --- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the --- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want --- changes to the 'DynFlags' to take effect you need to call this function --- again. --- -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - hsc_env <- getSession - (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots - if isEmptyBag errs - then do - warnMissingHomeModules hsc_env mod_graph - setSession hsc_env { hsc_mod_graph = mod_graph } - return mod_graph - else throwErrors errs - - --- | Perform dependency analysis like 'depanal' but return a partial module --- graph even in the face of problems with some modules. --- --- Modules which have parse errors in the module header, failing --- preprocessors or other issues preventing them from being summarised will --- simply be absent from the returned module graph. --- --- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the --- new module graph. -depanalPartial - :: GhcMonad m - => [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m (ErrorMessages, ModuleGraph) - -- ^ possibly empty 'Bag' of errors and a module graph. -depanalPartial excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - - withTiming dflags (text "Chasing dependencies") (const ()) $ do - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - -- Home package modules may have been moved or deleted, and new - -- source files may have appeared in the home package that shadow - -- external package modules, so we have to discard the existing - -- cached finder data. - liftIO $ flushFinderCaches hsc_env - - mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph) - excluded_mods allow_dup_roots - let - (errs, mod_summaries) = partitionEithers mod_summariesE - mod_graph = mkModuleGraph mod_summaries - return (unionManyBags errs, mod_graph) - --- Note [Missing home modules] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Sometimes user doesn't want GHC to pick up modules, not explicitly listed --- in a command line. For example, cabal may want to enable this warning --- when building a library, so that GHC warns user about modules, not listed --- neither in `exposed-modules`, nor in `other-modules`. --- --- Here "home module" means a module, that doesn't come from an other package. --- --- For example, if GHC is invoked with modules "A" and "B" as targets, --- but "A" imports some other module "C", then GHC will issue a warning --- about module "C" not being listed in a command line. --- --- The warning in enabled by `-Wmissing-home-modules`. See #13129 -warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () -warnMissingHomeModules hsc_env mod_graph = - when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $ - logWarnings (listToBag [warn]) - where - dflags = hsc_dflags hsc_env - targets = map targetId (hsc_targets hsc_env) - - is_known_module mod = any (is_my_target mod) targets - - -- We need to be careful to handle the case where (possibly - -- path-qualified) filenames (aka 'TargetFile') rather than module - -- names are being passed on the GHC command-line. - -- - -- For instance, `ghc --make src-exe/Main.hs` and - -- `ghc --make -isrc-exe Main` are supposed to be equivalent. - -- Note also that we can't always infer the associated module name - -- directly from the filename argument. See #13727. - is_my_target mod (TargetModule name) - = moduleName (ms_mod mod) == name - is_my_target mod (TargetFile target_file _) - | Just mod_file <- ml_hs_file (ms_location mod) - = target_file == mod_file || - - -- Don't warn on B.hs-boot if B.hs is specified (#16551) - addBootSuffix target_file == mod_file || - - -- We can get a file target even if a module name was - -- originally specified in a command line because it can - -- be converted in guessTarget (by appending .hs/.lhs). - -- So let's convert it back and compare with module name - mkModuleName (fst $ splitExtension target_file) - == moduleName (ms_mod mod) - is_my_target _ _ = False - - missing = map (moduleName . ms_mod) $ - filter (not . is_known_module) (mgModSummaries mod_graph) - - msg - | gopt Opt_BuildingCabalPackage dflags - = hang - (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ") - 4 - (sep (map ppr missing)) - | otherwise - = - hang - (text "Modules are not listed in command line but needed for compilation: ") - 4 - (sep (map ppr missing)) - warn = makeIntoWarning - (Reason Opt_WarnMissingHomeModules) - (mkPlainErrMsg dflags noSrcSpan msg) - --- | Describes which modules of the module graph need to be loaded. -data LoadHowMuch - = LoadAllTargets - -- ^ Load all targets and its dependencies. - | LoadUpTo ModuleName - -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf ModuleName - -- ^ Load only the dependencies of the given module, but not the module - -- itself. - --- | Try to load the program. See 'LoadHowMuch' for the different modes. --- --- This function implements the core of GHC's @--make@ mode. It preprocesses, --- compiles and loads the specified modules, avoiding re-compilation wherever --- possible. Depending on the target (see 'DynFlags.hscTarget') compiling --- and loading may result in files being created on disk. --- --- Calls the 'defaultWarnErrLogger' after each compiling each module, whether --- successful or not. --- --- Throw a 'SourceError' if errors are encountered before the actual --- compilation starts (e.g., during dependency analysis). All other errors --- are reported using the 'defaultWarnErrLogger'. --- -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = do - mod_graph <- depanal [] False - success <- load' how_much (Just batchMsg) mod_graph - warnUnusedPackages - pure success - --- Note [Unused packages] --- --- Cabal passes `--package-id` flag for each direct dependency. But GHC --- loads them lazily, so when compilation is done, we have a list of all --- actually loaded packages. All the packages, specified on command line, --- but never loaded, are probably unused dependencies. - -warnUnusedPackages :: GhcMonad m => m () -warnUnusedPackages = do - hsc_env <- getSession - eps <- liftIO $ hscEPS hsc_env - - let dflags = hsc_dflags hsc_env - pit = eps_PIT eps - - let loadedPackages - = map (getPackageDetails dflags) - . nub . sort - . map moduleUnitId - . moduleEnvKeys - $ pit - - requestedArgs = mapMaybe packageArg (packageFlags dflags) - - unusedArgs - = filter (\arg -> not $ any (matching dflags arg) loadedPackages) - requestedArgs - - let warn = makeIntoWarning - (Reason Opt_WarnUnusedPackages) - (mkPlainErrMsg dflags noSrcSpan msg) - msg = vcat [ text "The following packages were specified" <+> - text "via -package or -package-id flags," - , text "but were not needed for compilation:" - , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] - - when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $ - logWarnings (listToBag [warn]) - - where - packageArg (ExposePackage _ arg _) = Just arg - packageArg _ = Nothing - - pprUnusedArg (PackageArg str) = text str - pprUnusedArg (UnitIdArg uid) = ppr uid - - withDash = (<+>) (text "-") - - matchingStr :: String -> PackageConfig -> Bool - matchingStr str p - = str == sourcePackageIdString p - || str == packageNameString p - - matching :: DynFlags -> PackageArg -> PackageConfig -> Bool - matching _ (PackageArg str) p = matchingStr str p - matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p - - -- For wired-in packages, we have to unwire their id, - -- otherwise they won't match package flags - realUnitId :: DynFlags -> PackageConfig -> UnitId - realUnitId dflags - = unwireUnitId dflags - . DefiniteUnitId - . DefUnitId - . installedPackageConfigId - --- | Generalized version of 'load' which also supports a custom --- 'Messager' (for reporting progress) and 'ModuleGraph' (generally --- produced by calling 'depanal'. -load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag -load' how_much mHscMessage mod_graph = do - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = - mkUniqSet [ ms_mod_name s - | s <- mgModSummaries mod_graph, not (isBootSummary s)] - -- TODO: Figure out what the correct form of this assert is. It's violated - -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot - -- files without corresponding hs files. - -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - -- not (ms_mod_name s `elem` all_home_mods)] - -- ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elementOfUniqSet` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. Among other things, it is used for - -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- nonDetEltsUniqSet stable_obj ++ - nonDetEltsUniqSet stable_bco, - -- It's OK to use nonDetEltsUniqSet here - -- because it only affects linking. Besides - -- this list only serves as a poor man's set. - Just hmi <- [lookupHpt pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - stable_mod_summary ms ] - - stable_mod_summary ms = - ms_mod_name ms `elementOfUniqSet` stable_obj || - ms_mod_name ms `elementOfUniqSet` stable_bco - - -- the modules from partial_mg that are not also stable - -- NB. also keep cycles, we need to emit an error message later - unstable_mg = filter not_stable partial_mg - where not_stable (CyclicSCC _) = True - not_stable (AcyclicSCC ms) - = not $ stable_mod_summary ms - - -- Load all the stable modules first, before attempting to load - -- an unstable module (#7231). - mg = stable_mg ++ unstable_mg - - -- clean up between compilations - let cleanup = cleanCurrentModuleTempFiles . hsc_dflags - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - - n_jobs <- case parMakeCount dflags of - Nothing -> liftIO getNumProcessors - Just n -> return n - let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs - | otherwise = upsweep - - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } - (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ - upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - hsc_env1 <- getSession - liftIO $ cleanCurrentModuleTempFiles dflags - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = gopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = mgElemModule mod_graph main_mod - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib - - -- link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - if ghcLink dflags == LinkBinary && isJust ofile && not do_linking - then do - liftIO $ errorMsg dflags $ text - ("output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - -- This should be an error, not a warning (#10895). - loadFinish Failed linkresult - else - loadFinish Succeeded linkresult - - else - -- Tricky. We need to back out the effects of compiling any - -- half-done cycles, both so as to clean up the top level envs - -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let (mods_to_clean, mods_to_keep) = - partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone - hsc_env1 <- getSession - let hpt4 = hsc_HPT hsc_env1 - -- We must change the lifetime to TFL_CurrentModule for any temp - -- file created for an element of mod_to_clean during the upsweep. - -- These include preprocessed files and object files for loaded - -- modules. - unneeded_temps = concat - [ms_hspp_file : object_files - | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean - , let object_files = maybe [] linkableObjs $ - lookupHpt hpt4 (moduleName ms_mod) - >>= hm_linkable - ] - liftIO $ - changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps - liftIO $ cleanCurrentModuleTempFiles dflags - - let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - hpt4 - - -- Clean up after ourselves - - -- there should be no Nothings where linkables should be, now - let just_linkables = - isNoLink (ghcLink dflags) - || allHpt (isJust.hm_linkable) - (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface) - hpt5) - ASSERT( just_linkables ) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5 - - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } - loadFinish Failed linkresult - - --- | Finish up after a load. -loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag - --- If the link failed, unload everything and return. -loadFinish _all_ok Failed - = do hsc_env <- getSession - liftIO $ unload hsc_env [] - modifySession discardProg - return Failed - --- Empty the interactive context and set the module context to the topmost --- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded - = do modifySession discardIC - return all_ok - - --- | Forget the current program, but retain the persistent info in HscEnv -discardProg :: HscEnv -> HscEnv -discardProg hsc_env - = discardIC $ hsc_env { hsc_mod_graph = emptyMG - , hsc_HPT = emptyHomePackageTable } - --- | Discard the contents of the InteractiveContext, but keep the DynFlags. --- It will also keep ic_int_print and ic_monad if their names are from --- external packages. -discardIC :: HscEnv -> HscEnv -discardIC hsc_env - = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print - , ic_monad = new_ic_monad } } - where - -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic - !new_ic_int_print = keep_external_name ic_int_print - !new_ic_monad = keep_external_name ic_monad - dflags = ic_dflags old_ic - old_ic = hsc_IC hsc_env - empty_ic = emptyInteractiveContext dflags - keep_external_name ic_name - | nameIsFromExternalPackage this_pkg old_name = old_name - | otherwise = ic_name empty_ic - where - this_pkg = thisPackage dflags - old_name = ic_name old_ic - --- | If there is no -o option, guess the name of target executable --- by using top-level source file name as a base. -guessOutputFile :: GhcMonad m => m () -guessOutputFile = modifySession $ \env -> - let dflags = hsc_dflags env - -- Force mod_graph to avoid leaking env - !mod_graph = hsc_mod_graph env - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - ms <- mgLookupModule mod_graph (mainModIs dflags) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - - name_exe = do -#if defined(mingw32_HOST_OS) - -- we must add the .exe extension unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by DriverPipeline.exeFileName. See #2248 - name' <- fmap (<.> "exe") name -#else - name' <- name -#endif - mainModuleSrcPath' <- mainModuleSrcPath - -- #9930: don't clobber input files (unless they ask for it) - if name' == mainModuleSrcPath' - then throwGhcException . UsageError $ - "default output name would overwrite the input file; " ++ - "must specify -o explicitly" - else Just name' - in - case outputFile dflags of - Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } - --- ----------------------------------------------------------------------------- --- --- | Prune the HomePackageTable --- --- Before doing an upsweep, we can throw away: --- --- - For non-stable modules: --- - all ModDetails, all linked code --- - all unlinked code that is out of date with respect to --- the source file --- --- This is VERY IMPORTANT otherwise we'll end up requiring 2x the --- space at the end of the upsweep, because the topmost ModDetails of the --- old HPT holds on to the entire type environment from the previous --- compilation. -pruneHomePackageTable :: HomePackageTable - -> [ModSummary] - -> StableModules - -> HomePackageTable -pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapHpt prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms - = hmi{ hm_linkable = Nothing } - | otherwise - = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) - - ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - - is_stable m = - m `elementOfUniqSet` stable_obj || - m `elementOfUniqSet` stable_bco - --- ----------------------------------------------------------------------------- --- --- | Return (names of) all those in modsDone who are part of a cycle as defined --- by theGraph. -findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module -findPartiallyCompletedCycles modsDone theGraph - = Set.unions - [mods_in_this_cycle - | CyclicSCC vs <- theGraph -- Acyclic? Not interesting. - , let names_in_this_cycle = Set.fromList (map ms_mod vs) - mods_in_this_cycle = - Set.intersection (Set.fromList modsDone) names_in_this_cycle - -- If size mods_in_this_cycle == size names_in_this_cycle, - -- then this cycle has already been completed and we're not - -- interested. - , Set.size mods_in_this_cycle < Set.size names_in_this_cycle] - - --- --------------------------------------------------------------------------- --- --- | Unloading -unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcLink (hsc_dflags hsc_env) of - LinkInMemory -> Linker.unload hsc_env stable_linkables - _other -> return () - --- ----------------------------------------------------------------------------- -{- | - - Stability tells us which modules definitely do not need to be recompiled. - There are two main reasons for having stability: - - - avoid doing a complete upsweep of the module graph in GHCi when - modules near the bottom of the tree have not changed. - - - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the - module. So we need to know that we will definitely not be recompiling - any of these modules, and we can use the object code. - - The stability check is as follows. Both stableObject and - stableBCO are used during the upsweep phase later. - -@ - stable m = stableObject m || stableBCO m - - stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) - - stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) -@ - - These properties embody the following ideas: - - - if a module is stable, then: - - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. - - - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. - - - if a modules is not stable, we will definitely be at least - re-linking, and possibly re-compiling it during the 'upsweep'. - All non-stable modules can (and should) therefore be unlinked - before the 'upsweep'. - - - Note that objects are only considered stable if they only depend - on other objects. We can't link object code against byte code. - - - Note that even if an object is stable, we may end up recompiling - if the interface is out of date because an *external* interface - has changed. The current code in GhcMake handles this case - fairly poorly, so be careful. --} - -type StableModules = - ( UniqSet ModuleName -- stableObject - , UniqSet ModuleName -- stableBCO - ) - - -checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> UniqSet ModuleName -- all home modules - -> StableModules - -checkStability hpt sccs all_home_mods = - foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs - where - checkSCC :: StableModules -> SCC ModSummary -> StableModules - checkSCC (stable_obj, stable_bco) scc0 - | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco) - | stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods) - | otherwise = (stable_obj, stable_bco) - where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = - m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods - - scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps - stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearset second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. - -- - -- But see #5527, where someone ran into this and it caused - -- a problem. - - bco_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | otherwise = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False - -{- Parallel Upsweep - - - - The parallel upsweep attempts to concurrently compile the modules in the - - compilation graph using multiple Haskell threads. - - - - The Algorithm - - - - A Haskell thread is spawned for each module in the module graph, waiting for - - its direct dependencies to finish building before it itself begins to build. - - - - Each module is associated with an initially empty MVar that stores the - - result of that particular module's compile. If the compile succeeded, then - - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that - - module, and the module's HMI is deleted from the old HPT (synchronized by an - - IORef) to save space. - - - - Instead of immediately outputting messages to the standard handles, all - - compilation output is deferred to a per-module TQueue. A QSem is used to - - limit the number of workers that are compiling simultaneously. - - - - Meanwhile, the main thread sequentially loops over all the modules in the - - module graph, outputting the messages stored in each module's TQueue. --} - --- | Each module is given a unique 'LogQueue' to redirect compilation messages --- to. A 'Nothing' value contains the result of compilation, and denotes the --- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)]) - !(MVar ()) - --- | The graph of modules to compile and their corresponding result 'MVar' and --- 'LogQueue'. -type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)] - --- | Build a 'CompilationGraph' out of a list of strongly-connected modules, --- also returning the first, if any, encountered module cycle. -buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary]) -buildCompGraph [] = return ([], Nothing) -buildCompGraph (scc:sccs) = case scc of - AcyclicSCC ms -> do - mvar <- newEmptyMVar - log_queue <- do - ref <- newIORef [] - sem <- newEmptyMVar - return (LogQueue ref sem) - (rest,cycle) <- buildCompGraph sccs - return ((ms,mvar,log_queue):rest, cycle) - CyclicSCC mss -> return ([], Just mss) - --- A Module and whether it is a boot module. -type BuildModule = (Module, IsBoot) - --- | 'Bool' indicating if a module is a boot module or not. We need to treat --- boot modules specially when building compilation graphs, since they break --- cycles. Regular source files and signature files are treated equivalently. -data IsBoot = IsBoot | NotBoot - deriving (Ord, Eq, Show, Read) - --- | Tests if an 'HscSource' is a boot file, primarily for constructing --- elements of 'BuildModule'. -hscSourceToIsBoot :: HscSource -> IsBoot -hscSourceToIsBoot HsBootFile = IsBoot -hscSourceToIsBoot _ = NotBoot - -mkBuildModule :: ModSummary -> BuildModule -mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot) - --- | The entry point to the parallel upsweep. --- --- See also the simpler, sequential 'upsweep'. -parUpsweep - :: GhcMonad m - => Int - -- ^ The number of workers we wish to run in parallel - -> Maybe Messager - -> HomePackageTable - -> StableModules - -> (HscEnv -> IO ()) - -> [SCC ModSummary] - -> m (SuccessFlag, - [ModSummary]) -parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - - when (not (null (unitIdsToCheck dflags))) $ - throwGhcException (ProgramError "Backpack typechecking not supported with -j") - - -- The bits of shared state we'll be using: - - -- The global HscEnv is updated with the module's HMI when a module - -- successfully compiles. - hsc_env_var <- liftIO $ newMVar hsc_env - - -- The old HPT is used for recompilation checking in upsweep_mod. When a - -- module successfully gets compiled, its HMI is pruned from the old HPT. - old_hpt_var <- liftIO $ newIORef old_hpt - - -- What we use to limit parallelism with. - par_sem <- liftIO $ newQSem n_jobs - - - let updNumCapabilities = liftIO $ do - n_capabilities <- getNumCapabilities - n_cpus <- getNumProcessors - -- Setting number of capabilities more than - -- CPU count usually leads to high userspace - -- lock contention. #9221 - let n_caps = min n_jobs n_cpus - unless (n_capabilities /= 1) $ setNumCapabilities n_caps - return n_capabilities - -- Reset the number of capabilities once the upsweep ends. - let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n - - gbracket updNumCapabilities resetNumCapabilities $ \_ -> do - - -- Sync the global session with the latest HscEnv once the upsweep ends. - let finallySyncSession io = io `gfinally` do - hsc_env <- liftIO $ readMVar hsc_env_var - setSession hsc_env - - finallySyncSession $ do - - -- Build the compilation graph out of the list of SCCs. Module cycles are - -- handled at the very end, after some useful work gets done. Note that - -- this list is topologically sorted (by virtue of 'sccs' being sorted so). - (comp_graph,cycle) <- liftIO $ buildCompGraph sccs - let comp_graph_w_idx = zip comp_graph [1..] - - -- The list of all loops in the compilation graph. - -- NB: For convenience, the last module of each loop (aka the module that - -- finishes the loop) is prepended to the beginning of the loop. - let graph = map fstOf3 (reverse comp_graph) - boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms] - comp_graph_loops = go graph boot_modules - where - remove ms bm - | isBootSummary ms = delModuleSet bm (ms_mod ms) - | otherwise = bm - go [] _ = [] - go mg@(ms:mss) boot_modules - | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules) - = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules) - | otherwise - = go mss (remove ms boot_modules) - - -- Build a Map out of the compilation graph with which we can efficiently - -- look up the result MVar associated with a particular home module. - let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int) - home_mod_map = - Map.fromList [ (mkBuildModule ms, (mvar, idx)) - | ((ms,mvar,_),idx) <- comp_graph_w_idx ] - - - liftIO $ label_self "main --make thread" - -- For each module in the module graph, spawn a worker thread that will - -- compile this module. - let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> - forkIOWithUnmask $ \unmask -> do - liftIO $ label_self $ unwords - [ "worker --make thread" - , "for module" - , show (moduleNameString (ms_mod_name mod)) - , "number" - , show mod_idx - ] - -- Replace the default log_action with one that writes each - -- message to the module's log_queue. The main thread will - -- deal with synchronously printing these messages. - -- - -- Use a local filesToClean var so that we can clean up - -- intermediate files in a timely fashion (as soon as - -- compilation for that module is finished) without having to - -- worry about accidentally deleting a simultaneous compile's - -- important files. - lcl_files_to_clean <- newIORef emptyFilesToClean - let lcl_dflags = dflags { log_action = parLogAction log_queue - , filesToClean = lcl_files_to_clean } - - -- Unmask asynchronous exceptions and perform the thread-local - -- work to compile the module (see parUpsweep_one). - m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $ - parUpsweep_one mod home_mod_map comp_graph_loops - lcl_dflags mHscMessage cleanup - par_sem hsc_env_var old_hpt_var - stable_mods mod_idx (length sccs) - - res <- case m_res of - Right flag -> return flag - Left exc -> do - -- Don't print ThreadKilled exceptions: they are used - -- to kill the worker thread in the event of a user - -- interrupt, and the user doesn't have to be informed - -- about that. - when (fromException exc /= Just ThreadKilled) - (errorMsg lcl_dflags (text (show exc))) - return Failed - - -- Populate the result MVar. - putMVar mvar res - - -- Write the end marker to the message queue, telling the main - -- thread that it can stop waiting for messages from this - -- particular compile. - writeLogQueue log_queue Nothing - - -- Add the remaining files that weren't cleaned up to the - -- global filesToClean ref, for cleanup later. - FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files - } <- readIORef (filesToClean lcl_dflags) - addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files - addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files - - -- Kill all the workers, masking interrupts (since killThread is - -- interruptible). XXX: This is not ideal. - ; killWorkers = uninterruptibleMask_ . mapM_ killThread } - - - -- Spawn the workers, making sure to kill them later. Collect the results - -- of each compile. - results <- liftIO $ bracket spawnWorkers killWorkers $ \_ -> - -- Loop over each module in the compilation graph in order, printing - -- each message from its log_queue. - forM comp_graph $ \(mod,mvar,log_queue) -> do - printLogs dflags log_queue - result <- readMVar mvar - if succeeded result then return (Just mod) else return Nothing - - - -- Collect and return the ModSummaries of all the successful compiles. - -- NB: Reverse this list to maintain output parity with the sequential upsweep. - let ok_results = reverse (catMaybes results) - - -- Handle any cycle in the original compilation graph and return the result - -- of the upsweep. - case cycle of - Just mss -> do - liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) - return (Failed,ok_results) - Nothing -> do - let success_flag = successIf (all isJust results) - return (success_flag,ok_results) - - where - writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO () - writeLogQueue (LogQueue ref sem) msg = do - atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) - _ <- tryPutMVar sem () - return () - - -- The log_action callback that is used to synchronize messages from a - -- worker thread. - parLogAction :: LogQueue -> LogAction - parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do - writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg)) - - -- Print each message from the log_queue using the log_action from the - -- session's DynFlags. - printLogs :: DynFlags -> LogQueue -> IO () - printLogs !dflags (LogQueue ref sem) = read_msgs - where read_msgs = do - takeMVar sem - msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) - print_loop msgs - - print_loop [] = read_msgs - print_loop (x:xs) = case x of - Just (reason,severity,srcSpan,style,msg) -> do - putLogMsg dflags reason severity srcSpan style msg - print_loop xs - -- Exit the loop once we encounter the end marker. - Nothing -> return () - --- The interruptible subset of the worker threads' work. -parUpsweep_one - :: ModSummary - -- ^ The module we wish to compile - -> Map BuildModule (MVar SuccessFlag, Int) - -- ^ The map of home modules and their result MVar - -> [[BuildModule]] - -- ^ The list of all module loops within the compilation graph. - -> DynFlags - -- ^ The thread-local DynFlags - -> Maybe Messager - -- ^ The messager - -> (HscEnv -> IO ()) - -- ^ The callback for cleaning up intermediate files - -> QSem - -- ^ The semaphore for limiting the number of simultaneous compiles - -> MVar HscEnv - -- ^ The MVar that synchronizes updates to the global HscEnv - -> IORef HomePackageTable - -- ^ The old HPT - -> StableModules - -- ^ Sets of stable objects and BCOs - -> Int - -- ^ The index of this module - -> Int - -- ^ The total number of modules - -> IO SuccessFlag - -- ^ The result of this compile -parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem - hsc_env_var old_hpt_var stable_mods mod_index num_mods = do - - let this_build_mod = mkBuildModule mod - - let home_imps = map unLoc $ ms_home_imps mod - let home_src_imps = map unLoc $ ms_home_srcimps mod - - -- All the textual imports of this module. - let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $ - zip home_imps (repeat NotBoot) ++ - zip home_src_imps (repeat IsBoot) - - -- Dealing with module loops - -- ~~~~~~~~~~~~~~~~~~~~~~~~~ - -- - -- Not only do we have to deal with explicit textual dependencies, we also - -- have to deal with implicit dependencies introduced by import cycles that - -- are broken by an hs-boot file. We have to ensure that: - -- - -- 1. A module that breaks a loop must depend on all the modules in the - -- loop (transitively or otherwise). This is normally always fulfilled - -- by the module's textual dependencies except in degenerate loops, - -- e.g.: - -- - -- A.hs imports B.hs-boot - -- B.hs doesn't import A.hs - -- C.hs imports A.hs, B.hs - -- - -- In this scenario, getModLoop will detect the module loop [A,B] but - -- the loop finisher B doesn't depend on A. So we have to explicitly add - -- A in as a dependency of B when we are compiling B. - -- - -- 2. A module that depends on a module in an external loop can't proceed - -- until the entire loop is re-typechecked. - -- - -- These two invariants have to be maintained to correctly build a - -- compilation graph with one or more loops. - - - -- The loop that this module will finish. After this module successfully - -- compiles, this loop is going to get re-typechecked. - let finish_loop = listToMaybe - [ tail loop | loop <- comp_graph_loops - , head loop == this_build_mod ] - - -- If this module finishes a loop then it must depend on all the other - -- modules in that loop because the entire module loop is going to be - -- re-typechecked once this module gets compiled. These extra dependencies - -- are this module's "internal" loop dependencies, because this module is - -- inside the loop in question. - let int_loop_deps = Set.fromList $ - case finish_loop of - Nothing -> [] - Just loop -> filter (/= this_build_mod) loop - - -- If this module depends on a module within a loop then it must wait for - -- that loop to get re-typechecked, i.e. it must wait on the module that - -- finishes that loop. These extra dependencies are this module's - -- "external" loop dependencies, because this module is outside of the - -- loop(s) in question. - let ext_loop_deps = Set.fromList - [ head loop | loop <- comp_graph_loops - , any (`Set.member` textual_deps) loop - , this_build_mod `notElem` loop ] - - - let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps] - - -- All of the module's home-module dependencies. - let home_deps_with_idx = - [ home_dep | dep <- Set.toList all_deps - , Just home_dep <- [Map.lookup dep home_mod_map] ] - - -- Sort the list of dependencies in reverse-topological order. This way, by - -- the time we get woken up by the result of an earlier dependency, - -- subsequent dependencies are more likely to have finished. This step - -- effectively reduces the number of MVars that each thread blocks on. - let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx - - -- Wait for the all the module's dependencies to finish building. - deps_ok <- allM (fmap succeeded . readMVar) home_deps - - -- We can't build this module if any of its dependencies failed to build. - if not deps_ok - then return Failed - else do - -- Any hsc_env at this point is OK to use since we only really require - -- that the HPT contains the HMIs of our dependencies. - hsc_env <- readMVar hsc_env_var - old_hpt <- readIORef old_hpt_var - - let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) - - -- Limit the number of parallel compiles. - let withSem sem = bracket_ (waitQSem sem) (signalQSem sem) - mb_mod_info <- withSem par_sem $ - handleSourceError (\err -> do logger err; return Nothing) $ do - -- Have the ModSummary and HscEnv point to our local log_action - -- and filesToClean var. - let lcl_mod = localize_mod mod - let lcl_hsc_env = localize_hsc_env hsc_env - - -- Re-typecheck the loop - -- This is necessary to make sure the knot is tied when - -- we close a recursive module loop, see bug #12035. - type_env_var <- liftIO $ newIORef emptyNameEnv - let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var = - Just (ms_mod lcl_mod, type_env_var) } - lcl_hsc_env'' <- case finish_loop of - Nothing -> return lcl_hsc_env' - -- In the non-parallel case, the retypecheck prior to - -- typechecking the loop closer includes all modules - -- EXCEPT the loop closer. However, our precomputed - -- SCCs include the loop closer, so we have to filter - -- it out. - Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $ - filter (/= moduleName (fst this_build_mod)) $ - map (moduleName . fst) loop - - -- Compile the module. - mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods - lcl_mod mod_index num_mods - return (Just mod_info) - - case mb_mod_info of - Nothing -> return Failed - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Prune the old HPT unless this is an hs-boot module. - unless (isBootSummary mod) $ - atomicModifyIORef' old_hpt_var $ \old_hpt -> - (delFromHpt old_hpt this_mod, ()) - - -- Update and fetch the global HscEnv. - lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do - let hsc_env' = hsc_env - { hsc_HPT = addToHpt (hsc_HPT hsc_env) - this_mod mod_info } - -- We've finished typechecking the module, now we must - -- retypecheck the loop AGAIN to ensure unfoldings are - -- updated. This time, however, we include the loop - -- closer! - hsc_env'' <- case finish_loop of - Nothing -> return hsc_env' - Just loop -> typecheckLoop lcl_dflags hsc_env' $ - map (moduleName . fst) loop - return (hsc_env'', localize_hsc_env hsc_env'') - - -- Clean up any intermediate files. - cleanup lcl_hsc_env' - return Succeeded - - where - localize_mod mod - = mod { ms_hspp_opts = (ms_hspp_opts mod) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } - - localize_hsc_env hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } - --- ----------------------------------------------------------------------------- --- --- | The upsweep --- --- This is where we compile each module in the module graph, in a pass --- from the bottom to the top of the graph. --- --- There better had not be any cyclic groups here -- we check for them. -upsweep - :: GhcMonad m - => Maybe Messager - -> HomePackageTable -- ^ HPT from last time round (pruned) - -> StableModules -- ^ stable modules (see checkStability) - -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) - -> m (SuccessFlag, - [ModSummary]) - -- ^ Returns: - -- - -- 1. A flag whether the complete upsweep was successful. - -- 2. The 'HscEnv' in the monad has an updated HPT - -- 3. A list of modules which succeeded loading. - -upsweep mHscMessage old_hpt stable_mods cleanup sccs = do - dflags <- getSessionDynFlags - (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) - (unitIdsToCheck dflags) done_holes - return (res, reverse $ mgModSummaries done) - where - done_holes = emptyUniqSet - - keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do - let sum_deps ms (AcyclicSCC mod) = - if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms - then ms_mod_name mod:ms - else ms - sum_deps ms _ = ms - dep_closure = foldl' sum_deps this_mods mods - dropped_ms = drop (length this_mods) (reverse dep_closure) - prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure - prunable _ = False - mods' = filter (not . prunable) mods - nmods' = nmods - length dropped_ms - - when (not $ null dropped_ms) $ do - dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms) - (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes - return (Failed, done') - - upsweep' - :: GhcMonad m - => HomePackageTable - -> ModuleGraph - -> [SCC ModSummary] - -> Int - -> Int - -> [UnitId] - -> UniqSet ModuleName - -> m (SuccessFlag, ModuleGraph) - upsweep' _old_hpt done - [] _ _ uids_to_check _ - = do hsc_env <- getSession - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check - return (Succeeded, done) - - upsweep' _old_hpt done - (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes - = do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) - if gopt Opt_KeepGoing dflags - then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods - uids_to_check done_holes - else return (Failed, done) - - upsweep' old_hpt done - (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes - = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger _mod = defaultWarnErrLogger - - hsc_env <- getSession - - -- TODO: Cache this, so that we don't repeatedly re-check - -- our imports when you run --make. - let (ready_uids, uids_to_check') - = partition (\uid -> isEmptyUniqDSet - (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes)) - uids_to_check - done_holes' - | ms_hsc_src mod == HsigFile - = addOneToUniqSet done_holes (ms_mod_name mod) - | otherwise = done_holes - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids - - -- Remove unwanted tmp files between compilations - liftIO (cleanup hsc_env) - - -- Get ready to tie the knot - type_env_var <- liftIO $ newIORef emptyNameEnv - let hsc_env1 = hsc_env { hsc_type_env_var = - Just (ms_mod mod, type_env_var) } - setSession hsc_env1 - - -- Lazily reload the HPT modules participating in the loop. - -- See Note [Tying the knot]--if we don't throw out the old HPT - -- and reinitalize the knot-tying process, anything that was forced - -- while we were previously typechecking won't get updated, this - -- was bug #12035. - hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done - setSession hsc_env2 - - mb_mod_info - <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods - mod mod_index nmods - logger mod Nothing -- log warnings - return (Just mod_info) - - case mb_mod_info of - Nothing -> do - dflags <- getSessionDynFlags - if gopt Opt_KeepGoing dflags - then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods - uids_to_check done_holes - else return (Failed, done) - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info - hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing } - - -- Space-saving: delete the old HPT entry - -- for mod BUT if mod is a hs-boot - -- node, don't delete it. For the - -- interface, the HPT entry is probaby for the - -- main Haskell source file. Deleting it - -- would force the real module to be recompiled - -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromHpt old_hpt this_mod - - done' = extendMG done mod - - -- fixup our HomePackageTable after we've finished compiling - -- a mutually-recursive loop. We have to do this again - -- to make sure we have the final unfoldings, which may - -- not have been computed accurately in the previous - -- retypecheck. - hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' - setSession hsc_env4 - - -- Add any necessary entries to the static pointer - -- table. See Note [Grand plan for static forms] in - -- StaticPtrTable. - when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ - liftIO $ hscAddSptEntries hsc_env4 - [ spt - | Just linkable <- pure $ hm_linkable mod_info - , unlinked <- linkableUnlinked linkable - , BCOs _ spts <- pure unlinked - , spt <- spts - ] - - upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' - -unitIdsToCheck :: DynFlags -> [UnitId] -unitIdsToCheck dflags = - nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags)) - where - goUnitId uid = - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef - in uid : concatMap (goUnitId . moduleUnitId . snd) insts - _ -> [] - -maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) -maybeGetIfaceDate dflags location - | writeInterfaceOnlyMode dflags - -- Minor optimization: it should be harmless to check the hi file location - -- always, but it's better to avoid hitting the filesystem if possible. - = modificationTimeIfExists (ml_hi_file location) - | otherwise - = return Nothing - --- | Compile a single module. Always produce a Linkable for it if --- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: HscEnv - -> Maybe Messager - -> HomePackageTable - -> StableModules - -> ModSummary - -> Int -- index of module - -> Int -- total number of modules - -> IO HomeModInfo -upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods - = let - this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - mb_if_date = ms_iface_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary - - is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj - is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco - - old_hmi = lookupHpt old_hpt this_mod_name - - -- We're using the dflags for this module now, obtained by - -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary - prevailing_target = hscTarget (hsc_dflags hsc_env) - local_target = hscTarget dflags - - -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that - -- we don't do anything dodgy: these should only work to change - -- from -fllvm to -fasm and vice-versa, or away from -fno-code, - -- otherwise we could end up trying to link object code to byte - -- code. - target = if prevailing_target /= local_target - && (not (isObjectTarget prevailing_target) - || not (isObjectTarget local_target)) - && not (prevailing_target == HscNothing) - && not (prevailing_target == HscInterpreted) - then prevailing_target - else local_target - - -- store the corrected hscTarget into the summary - summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo - compile_it mb_linkable src_modified = - compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - mb_old_iface mb_linkable src_modified - - compile_it_discard_iface :: Maybe Linkable -> SourceModified - -> IO HomeModInfo - compile_it_discard_iface mb_linkable src_modified = - compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - Nothing mb_linkable src_modified - - -- With the HscNothing target we create empty linkables to avoid - -- recompilation. We have to detect these to recompile anyway if - -- the target changed since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) SourceUnmodifiedAndStable - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (isObjectTarget target), is_stable_bco, - (target /= HscNothing) `implies` not is_fake_linkable -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (isObjectTarget target), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (target /= HscNothing) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | isObjectTarget target, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) SourceUnmodified - - -- See Note [Recompilation checking in -fno-code mode] - | writeInterfaceOnlyMode dflags, - Just if_date <- mb_if_date, - if_date >= hs_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping tc'd mod:" <+> ppr this_mod_name) - compile_it Nothing SourceUnmodified - - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing SourceModified - - -{- Note [-fno-code mode] -~~~~~~~~~~~~~~~~~~~~~~~~ -GHC offers the flag -fno-code for the purpose of parsing and typechecking a -program without generating object files. This is intended to be used by tooling -and IDEs to provide quick feedback on any parser or type errors as cheaply as -possible. - -When GHC is invoked with -fno-code no object files or linked output will be -generated. As many errors and warnings as possible will be generated, as if --fno-code had not been passed. The session DynFlags will have -hscTarget == HscNothing. - --fwrite-interface -~~~~~~~~~~~~~~~~ -Whether interface files are generated in -fno-code mode is controlled by the --fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is -not also passed. Recompilation avoidance requires interface files, so passing --fno-code without -fwrite-interface should be avoided. If -fno-code were -re-implemented today, -fwrite-interface would be discarded and it would be -considered always on; this behaviour is as it is for backwards compatibility. - -================================================================ -IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER -================================================================ - -Template Haskell -~~~~~~~~~~~~~~~~ -A module using template haskell may invoke an imported function from inside a -splice. This will cause the type-checker to attempt to execute that code, which -would fail if no object files had been generated. See #8025. To rectify this, -during the downsweep we patch the DynFlags in the ModSummary of any home module -that is imported by a module that uses template haskell, to generate object -code. - -The flavour of generated object code is chosen by defaultObjectTarget for the -target platform. It would likely be faster to generate bytecode, but this is not -supported on all platforms(?Please Confirm?), and does not support the entirety -of GHC haskell. See #1257. - -The object files (and interface files if -fwrite-interface is disabled) produced -for template haskell are written to temporary files. - -Note that since template haskell can run arbitrary IO actions, -fno-code mode -is no more secure than running without it. - -Potential TODOS: -~~~~~ -* Remove -fwrite-interface and have interface files always written in -fno-code - mode -* Both .o and .dyn_o files are generated for template haskell, but we only need - .dyn_o. Fix it. -* In make mode, a message like - Compiling A (A.hs, /tmp/ghc_123.o) - is shown if downsweep enabled object code generation for A. Perhaps we should - show "nothing" or "temporary object file" instead. Note that one - can currently use -keep-tmp-files and inspect the generated file with the - current behaviour. -* Offer a -no-codedir command line option, and write what were temporary - object files there. This would speed up recompilation. -* Use existing object files (if they are up to date) instead of always - generating temporary ones. --} - --- Note [Recompilation checking in -fno-code mode] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If we are compiling with -fno-code -fwrite-interface, there won't --- be any object code that we can compare against, nor should there --- be: we're *just* generating interface files. In this case, we --- want to check if the interface file is new, in lieu of the object --- file. See also #9243. - --- Filter modules in the HPT -retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable -retainInTopLevelEnvs keep_these hpt - = listToHpt [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupHpt hpt mod - , isJust mb_mod_info ] - --- --------------------------------------------------------------------------- --- Typecheck module loops -{- -See bug #930. This code fixes a long-standing bug in --make. The -problem is that when compiling the modules *inside* a loop, a data -type that is only defined at the top of the loop looks opaque; but -after the loop is done, the structure of the data type becomes -apparent. - -The difficulty is then that two different bits of code have -different notions of what the data type looks like. - -The idea is that after we compile a module which also has an .hs-boot -file, we re-generate the ModDetails for each of the modules that -depends on the .hs-boot file, so that everyone points to the proper -TyCons, Ids etc. defined by the real module, not the boot module. -Fortunately re-generating a ModDetails from a ModIface is easy: the -function TcIface.typecheckIface does exactly that. - -Picking the modules to re-typecheck is slightly tricky. Starting from -the module graph consisting of the modules that have already been -compiled, we reverse the edges (so they point from the imported module -to the importing module), and depth-first-search from the .hs-boot -node. This gives us all the modules that depend transitively on the -.hs-boot module, and those are exactly the modules that we need to -re-typecheck. - -Following this fix, GHC can compile itself with --make -O2. --} - -reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv -reTypecheckLoop hsc_env ms graph - | Just loop <- getModLoop ms mss appearsAsBoot - -- SOME hs-boot files should still - -- get used, just not the loop-closer. - , let non_boot = filter (\l -> not (isBootSummary l && - ms_mod l == ms_mod ms)) loop - = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) - | otherwise - = return hsc_env - where - mss = mgModSummaries graph - appearsAsBoot = (`elemModuleSet` mgBootModules graph) - --- | Given a non-boot ModSummary @ms@ of a module, for which there exists a --- corresponding boot file in @graph@, return the set of modules which --- transitively depend on this boot file. This function is slightly misnamed, --- but its name "getModLoop" alludes to the fact that, when getModLoop is called --- with a graph that does not contain @ms@ (non-parallel case) or is an --- SCC with hs-boot nodes dropped (parallel-case), the modules which --- depend on the hs-boot file are typically (but not always) the --- modules participating in the recursive module loop. The returned --- list includes the hs-boot file. --- --- Example: --- let g represent the module graph: --- C.hs --- A.hs-boot imports C.hs --- B.hs imports A.hs-boot --- A.hs imports B.hs --- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs] --- --- It would also be permissible to omit A.hs from the graph, --- in which case the result is [A.hs-boot, B.hs] --- --- Example: --- A counter-example to the claim that modules returned --- by this function participate in the loop occurs here: --- --- let g represent the module graph: --- C.hs --- A.hs-boot imports C.hs --- B.hs imports A.hs-boot --- A.hs imports B.hs --- D.hs imports A.hs-boot --- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs] --- --- Arguably, D.hs should import A.hs, not A.hs-boot, but --- a dependency on the boot file is not illegal. --- -getModLoop - :: ModSummary - -> [ModSummary] - -> (Module -> Bool) -- check if a module appears as a boot module in 'graph' - -> Maybe [ModSummary] -getModLoop ms graph appearsAsBoot - | not (isBootSummary ms) - , appearsAsBoot this_mod - , let mss = reachableBackwards (ms_mod_name ms) graph - = Just mss - | otherwise - = Nothing - where - this_mod = ms_mod ms - --- NB: sometimes mods has duplicates; this is harmless because --- any duplicates get clobbered in addListToHpt and never get forced. -typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop dflags hsc_env mods = do - debugTraceMsg dflags 2 $ - text "Re-typechecking loop: " <> ppr mods - new_hpt <- - fixIO $ \new_hpt -> do - let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } - mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $ - mapM (typecheckIface . hm_iface) hmis - let new_hpt = addListToHpt old_hpt - (zip mods [ hmi{ hm_details = details } - | (hmi,details) <- zip hmis mds ]) - return new_hpt - return hsc_env{ hsc_HPT = new_hpt } - where - old_hpt = hsc_HPT hsc_env - hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods - -reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] -reachableBackwards mod summaries - = [ node_payload node | node <- reachableG (transposeG graph) root ] - where -- the rest just sets up the graph: - (graph, lookup_node) = moduleGraphNodes False summaries - root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) - --- --------------------------------------------------------------------------- --- --- | Topological sort of the module graph -topSortModuleGraph - :: Bool - -- ^ Drop hi-boot nodes? (see below) - -> ModuleGraph - -> Maybe ModuleName - -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] --- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes --- The resulting list of strongly-connected-components is in topologically --- sorted order, starting with the module(s) at the bottom of the --- dependency graph (ie compile them first) and ending with the ones at --- the top. --- --- Drop hi-boot nodes (first boolean arg)? --- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic --- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic - -topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod - = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph - where - summaries = mgModSummaries module_graph - -- stronglyConnCompG flips the original order, so if we reverse - -- the summaries we get a stable topological sort. - (graph, lookup_node) = - moduleGraphNodes drop_hs_boot_nodes (reverse summaries) - - initial_graph = case mb_root_mod of - Nothing -> graph - Just root_mod -> - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - let root | Just node <- lookup_node HsSrcFile root_mod - , graph `hasVertexG` node - = node - | otherwise - = throwGhcException (ProgramError "module does not exist") - in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) - -type SummaryNode = Node Int ModSummary - -summaryNodeKey :: SummaryNode -> Int -summaryNodeKey = node_key - -summaryNodeSummary :: SummaryNode -> ModSummary -summaryNodeSummary = node_payload - -moduleGraphNodes :: Bool -> [ModSummary] - -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) -moduleGraphNodes drop_hs_boot_nodes summaries = - (graphFromEdgedVerticesUniq nodes, lookup_node) - where - numbered_summaries = zip summaries [1..] - - lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) - - node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), - hscSourceToIsBoot (ms_hsc_src s)), node) - | node <- nodes - , let s = summaryNodeSummary node ] - - -- We use integers as the keys for the SCC algorithm - nodes :: [SummaryNode] - nodes = [ DigraphNode s key out_keys - | (s, key) <- numbered_summaries - -- Drop the hi-boot ones if told to do so - , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) ] - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - out_edge_keys :: HscSource -> [ModuleName] -> [Int] - out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- IsBoot; else NotBoot - --- The nodes of the graph are keyed by (mod, is boot?) pairs --- NB: hsig files show up as *normal* nodes (not boot!), since they don't --- participate in cycles (for now) -type NodeKey = (ModuleName, IsBoot) -type NodeMap a = Map.Map NodeKey a - -msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) - = (moduleName mod, hscSourceToIsBoot boot) - -mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - -nodeMapElts :: NodeMap a -> [a] -nodeMapElts = Map.elems - --- | If there are {-# SOURCE #-} imports between strongly connected --- components in the topological sort, then those imports can --- definitely be replaced by ordinary non-SOURCE imports: if SOURCE --- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = do - dflags <- getDynFlags - when (wopt Opt_WarnUnusedImports dflags) - (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) - where check dflags ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn dflags i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: DynFlags -> Located ModuleName -> WarnMsg - warn dflags (L loc mod) = - mkPlainErrMsg dflags loc - (text "Warning: {-# SOURCE #-} unnecessary in import of " - <+> quotes (ppr mod)) - - -reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b] -reportImportErrors xs | null errs = return oks - | otherwise = throwErrors $ unionManyBags errs - where (errs, oks) = partitionEithers xs - - ------------------------------------------------------------------------------ --- --- | Downsweep (dependency analysis) --- --- Chase downwards from the specified root set, returning summaries --- for all home modules encountered. Only follow source-import --- links. --- --- We pass in the previous collection of summaries, which is used as a --- cache to avoid recalculating a module summary if the source is --- unchanged. --- --- The returned list of [ModSummary] nodes has one node for each home-package --- module, plus one for any hs-boot files. The imports of these nodes --- are all there, including the imports of non-home-package modules. -downsweep :: HscEnv - -> [ModSummary] -- Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> IO [Either ErrorMessages ModSummary] - -- The elts of [ModSummary] all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true - -- in which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do - rootSummaries <- mapM getRootSummary roots - rootSummariesOk <- reportImportErrors rootSummaries - let root_map = mkRootMap rootSummariesOk - checkDuplicates root_map - map0 <- loop (concatMap calcDeps rootSummariesOk) root_map - -- if we have been passed -fno-code, we enable code generation - -- for dependencies of modules that have -XTemplateHaskell, - -- otherwise those modules will fail to compile. - -- See Note [-fno-code mode] #8025 - map1 <- if hscTarget dflags == HscNothing - then enableCodeGenForTH - (defaultObjectTarget dflags) - map0 - else if hscTarget dflags == HscInterpreted - then enableCodeGenForUnboxedTuplesOrSums - (defaultObjectTarget dflags) - map0 - else return map0 - return $ concat $ nodeMapElts map1 - where - calcDeps = msDeps - - dflags = hsc_dflags hsc_env - roots = hsc_targets hsc_env - - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries - - getRootSummary :: Target -> IO (Either ErrorMessages ModSummary) - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists || isJust maybe_buf - then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf - else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot - (L rootLoc modl) obj_allowed - maybe_buf excl_mods - case maybe_summary of - Nothing -> return $ Left $ moduleNotFoundErr dflags modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map - - loop :: [(Located ModuleName,IsBoot)] - -- Work list: process these modules - -> NodeMap [Either ErrorMessages ModSummary] - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO (NodeMap [Either ErrorMessages ModSummary]) - -- The result is the completed NodeMap - loop [] done = return done - loop ((wanted_mod, is_boot) : ss) done - | Just summs <- Map.lookup key done - = if isSingleton summs then - loop ss done - else - do { multiRootsErr dflags (rights summs); return Map.empty } - | otherwise - = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod True - Nothing excl_mods - case mb_s of - Nothing -> loop ss done - Just (Left e) -> loop ss (Map.insert key [Left e] done) - Just (Right s)-> do - new_map <- - loop (calcDeps s) (Map.insert key [Right s] done) - loop ss new_map - where - key = (unLoc wanted_mod, is_boot) - --- | Update the every ModSummary that is depended on --- by a module that needs template haskell. We enable codegen to --- the specified target, disable optimization and change the .hi --- and .o file locations to be temporary files. --- See Note [-fno-code mode] -enableCodeGenForTH :: HscTarget - -> NodeMap [Either ErrorMessages ModSummary] - -> IO (NodeMap [Either ErrorMessages ModSummary]) -enableCodeGenForTH = - enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession - where - condition = isTemplateHaskellOrQQNonBoot - should_modify (ModSummary { ms_hspp_opts = dflags }) = - hscTarget dflags == HscNothing && - -- Don't enable codegen for TH on indefinite packages; we - -- can't compile anything anyway! See #16219. - not (isIndefinite dflags) - --- | Update the every ModSummary that is depended on --- by a module that needs unboxed tuples. We enable codegen to --- the specified target, disable optimization and change the .hi --- and .o file locations to be temporary files. --- --- This is used used in order to load code that uses unboxed tuples --- or sums into GHCi while still allowing some code to be interpreted. -enableCodeGenForUnboxedTuplesOrSums :: HscTarget - -> NodeMap [Either ErrorMessages ModSummary] - -> IO (NodeMap [Either ErrorMessages ModSummary]) -enableCodeGenForUnboxedTuplesOrSums = - enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule - where - condition ms = - unboxed_tuples_or_sums (ms_hspp_opts ms) && - not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) && - not (isBootSummary ms) - unboxed_tuples_or_sums d = - xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d - should_modify (ModSummary { ms_hspp_opts = dflags }) = - hscTarget dflags == HscInterpreted - --- | Helper used to implement 'enableCodeGenForTH' and --- 'enableCodeGenForUnboxedTuples'. In particular, this enables --- unoptimized code generation for all modules that meet some --- condition (first parameter), or are dependencies of those --- modules. The second parameter is a condition to check before --- marking modules for code generation. -enableCodeGenWhen - :: (ModSummary -> Bool) - -> (ModSummary -> Bool) - -> TempFileLifetime - -> TempFileLifetime - -> HscTarget - -> NodeMap [Either ErrorMessages ModSummary] - -> IO (NodeMap [Either ErrorMessages ModSummary]) -enableCodeGenWhen condition should_modify staticLife dynLife target nodemap = - traverse (traverse (traverse enable_code_gen)) nodemap - where - enable_code_gen ms - | ModSummary - { ms_mod = ms_mod - , ms_location = ms_location - , ms_hsc_src = HsSrcFile - , ms_hspp_opts = dflags - } <- ms - , should_modify ms - , ms_mod `Set.member` needs_codegen_set - = do - let new_temp_file suf dynsuf = do - tn <- newTempName dflags staticLife suf - let dyn_tn = tn -<.> dynsuf - addFilesToClean dflags dynLife [dyn_tn] - return tn - -- We don't want to create .o or .hi files unless we have been asked - -- to by the user. But we need them, so we patch their locations in - -- the ModSummary with temporary files. - -- - (hi_file, o_file) <- - -- If ``-fwrite-interface` is specified, then the .o and .hi files - -- are written into `-odir` and `-hidir` respectively. #16670 - if gopt Opt_WriteInterface dflags - then return (ml_hi_file ms_location, ml_obj_file ms_location) - else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags)) - <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags)) - return $ - ms - { ms_location = - ms_location {ml_hi_file = hi_file, ml_obj_file = o_file} - , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target} - } - | otherwise = return ms - - needs_codegen_set = transitive_deps_set - [ ms - | mss <- Map.elems nodemap - , Right ms <- mss - , condition ms - ] - - -- find the set of all transitive dependencies of a list of modules. - transitive_deps_set modSums = foldl' go Set.empty modSums - where - go marked_mods ms@ModSummary{ms_mod} - | ms_mod `Set.member` marked_mods = marked_mods - | otherwise = - let deps = - [ dep_ms - -- If a module imports a boot module, msDeps helpfully adds a - -- dependency to that non-boot module in it's result. This - -- means we don't have to think about boot modules here. - | (L _ mn, NotBoot) <- msDeps ms - , dep_ms <- - toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>= - toList - ] - new_marked_mods = Set.insert ms_mod marked_mods - in foldl' go new_marked_mods deps - -mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary] -mkRootMap summaries = Map.insertListWith (flip (++)) - [ (msKey s, [Right s]) | s <- summaries ] - Map.empty - --- | Returns the dependencies of the ModSummary s. --- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file --- as "dependencies". That ensures that the list of all relevant --- modules always contains B.hs if it contains B.hs-boot. --- Remember, this pass isn't doing the topological sort. It's --- just gathering the list of all relevant ModSummaries -msDeps :: ModSummary -> [(Located ModuleName, IsBoot)] -msDeps s = - concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ] - ++ [ (m,NotBoot) | m <- ms_home_imps s ] - ------------------------------------------------------------------------------ --- Summarising modules - --- We have two types of summarisation: --- --- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. --- --- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. - -summariseFile - :: HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase - -> Bool -- object code allowed? - -> Maybe (StringBuffer,UTCTime) - -> IO (Either ErrorMessages ModSummary) - -summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries src_fn - = do - let location = ms_location old_summary - dflags = hsc_dflags hsc_env - - src_timestamp <- get_src_timestamp - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationUTCTime may fail, but that's the right - -- behaviour. - - -- return the cached summary if the source didn't change - checkSummaryTimestamp - hsc_env dflags obj_allowed NotBoot (new_summary src_fn) - old_summary location src_timestamp - - | otherwise - = do src_timestamp <- get_src_timestamp - new_summary src_fn src_timestamp - where - get_src_timestamp = case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime src_fn - -- getModificationUTCTime may fail - - new_summary src_fn src_timestamp = runExceptT $ do - preimps@PreprocessedImports {..} - <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf - - - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn - - -- Tell the Finder cache where it is, so that subsequent calls - -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location - - liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary - { nms_src_fn = src_fn - , nms_src_timestamp = src_timestamp - , nms_is_boot = NotBoot - , nms_hsc_src = - if isHaskellSigFilename src_fn - then HsigFile - else HsSrcFile - , nms_location = location - , nms_mod = mod - , nms_obj_allowed = obj_allowed - , nms_preimps = preimps - } - -findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary -findSummaryBySourceFile summaries file - = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of - [] -> Nothing - (x:_) -> Just x - -checkSummaryTimestamp - :: HscEnv -> DynFlags -> Bool -> IsBoot - -> (UTCTime -> IO (Either e ModSummary)) - -> ModSummary -> ModLocation -> UTCTime - -> IO (Either e ModSummary) -checkSummaryTimestamp - hsc_env dflags obj_allowed is_boot new_summary - old_summary location src_timestamp - | ms_hs_date old_summary == src_timestamp && - not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do - -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location is_boot - else return Nothing - - -- We have to repopulate the Finder's cache for file targets - -- because the file might not even be on the regular serach path - -- and it was likely flushed in depanal. This is not technically - -- needed when we're called from sumariseModule but it shouldn't - -- hurt. - _ <- addHomeModuleToFinder hsc_env - (moduleName (ms_mod old_summary)) location - - hi_timestamp <- maybeGetIfaceDate dflags location - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) - - return $ Right old_summary - { ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp - } - - | otherwise = - -- source changed: re-summarise. - new_summary src_timestamp - --- Summarise a module, and pick up source and timestamp. -summariseModule - :: HscEnv - -> NodeMap ModSummary -- Map of old summaries - -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? - -> Maybe (StringBuffer, UTCTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe (Either ErrorMessages ModSummary)) -- Its new summary - -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods - | wanted_mod `elem` excl_mods - = return Nothing - - | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the modification time on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (_,t) -> - Just <$> check_timestamp old_summary location src_fn t - Nothing -> do - m <- tryIO (getModificationUTCTime src_fn) - case m of - Right t -> - Just <$> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e - - | otherwise = find_it - where - dflags = hsc_dflags hsc_env - - check_timestamp old_summary location src_fn = - checkSummaryTimestamp - hsc_env dflags obj_allowed is_boot - (new_summary location (ms_mod old_summary) src_fn) - old_summary location - - find_it = do - found <- findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - Just <$> just_found location mod - - _ -> return Nothing - -- Not found - -- (If it is TRULY not found at all, we'll - -- error when we actually try to compile) - - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' | IsBoot <- is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = expectJust "summarise2" (ml_hs_file location') - - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of - Nothing -> return $ Left $ noHsFileErr dflags loc src_fn - Just t -> new_summary location' mod src_fn t - - new_summary location mod src_fn src_timestamp - = runExceptT $ do - preimps@PreprocessedImports {..} - <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf - - -- NB: Despite the fact that is_boot is a top-level parameter, we - -- don't actually know coming into this function what the HscSource - -- of the module in question is. This is because we may be processing - -- this module because another module in the graph imported it: in this - -- case, we know if it's a boot or not because of the {-# SOURCE #-} - -- annotation, but we don't know if it's a signature or a regular - -- module until we actually look it up on the filesystem. - let hsc_src = case is_boot of - IsBoot -> HsBootFile - _ | isHaskellSigFilename src_fn -> HsigFile - | otherwise -> HsSrcFile - - when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr pi_mod_name) - $$ text "Expected:" <+> quotes (ppr wanted_mod) - - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $ - let suggested_instantiated_with = - hcat (punctuate comma $ - [ ppr k <> text "=" <> ppr v - | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) - : thisUnitIdInsts dflags) - ]) - in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ - text "Unexpected signature:" <+> quotes (ppr pi_mod_name) - $$ if gopt Opt_BuildingCabalPackage dflags - then parens (text "Try adding" <+> quotes (ppr pi_mod_name) - <+> text "to the" - <+> quotes (text "signatures") - <+> text "field in your Cabal file.") - else parens (text "Try passing -instantiated-with=\"" <> - suggested_instantiated_with <> text "\"" $$ - text "replacing <" <> ppr pi_mod_name <> text "> as necessary.") - - liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary - { nms_src_fn = src_fn - , nms_src_timestamp = src_timestamp - , nms_is_boot = is_boot - , nms_hsc_src = hsc_src - , nms_location = location - , nms_mod = mod - , nms_obj_allowed = obj_allowed - , nms_preimps = preimps - } - --- | Convenience named arguments for 'makeNewModSummary' only used to make --- code more readable, not exported. -data MakeNewModSummary - = MakeNewModSummary - { nms_src_fn :: FilePath - , nms_src_timestamp :: UTCTime - , nms_is_boot :: IsBoot - , nms_hsc_src :: HscSource - , nms_location :: ModLocation - , nms_mod :: Module - , nms_obj_allowed :: Bool - , nms_preimps :: PreprocessedImports - } - -makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary -makeNewModSummary hsc_env MakeNewModSummary{..} = do - let PreprocessedImports{..} = nms_preimps - let dflags = hsc_dflags hsc_env - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- liftIO $ - if isObjectTarget (hscTarget dflags) - || nms_obj_allowed -- bug #1205 - then getObjTimestamp nms_location nms_is_boot - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags nms_location - hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) - - extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name - required_by_imports <- implicitRequirements hsc_env pi_theimps - - return $ ModSummary - { ms_mod = nms_mod - , ms_hsc_src = nms_hsc_src - , ms_location = nms_location - , ms_hspp_file = pi_hspp_fn - , ms_hspp_opts = pi_local_dflags - , ms_hspp_buf = Just pi_hspp_buf - , ms_parsed_mod = Nothing - , ms_srcimps = pi_srcimps - , ms_textual_imps = - pi_theimps ++ extra_sig_imports ++ required_by_imports - , ms_hs_date = nms_src_timestamp - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp - , ms_obj_date = obj_timestamp - } - -getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) -getObjTimestamp location is_boot - = if is_boot == IsBoot then return Nothing - else modificationTimeIfExists (ml_obj_file location) - -data PreprocessedImports - = PreprocessedImports - { pi_local_dflags :: DynFlags - , pi_srcimps :: [(Maybe FastString, Located ModuleName)] - , pi_theimps :: [(Maybe FastString, Located ModuleName)] - , pi_hspp_fn :: FilePath - , pi_hspp_buf :: StringBuffer - , pi_mod_name_loc :: SrcSpan - , pi_mod_name :: ModuleName - } - --- Preprocess the source file and get its imports --- The pi_local_dflags contains the OPTIONS pragmas -getPreprocessedImports - :: HscEnv - -> FilePath - -> Maybe Phase - -> Maybe (StringBuffer, UTCTime) - -- ^ optional source code buffer and modification time - -> ExceptT ErrorMessages IO PreprocessedImports -getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do - (pi_local_dflags, pi_hspp_fn) - <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase - pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn - (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name) - <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn - return PreprocessedImports {..} - - ------------------------------------------------------------------------------ --- Error messages ------------------------------------------------------------------------------ - --- Defer and group warning, error and fatal messages so they will not get lost --- in the regular output. -withDeferredDiagnostics :: GhcMonad m => m a -> m a -withDeferredDiagnostics f = do - dflags <- getDynFlags - if not $ gopt Opt_DeferDiagnostics dflags - then f - else do - warnings <- liftIO $ newIORef [] - errors <- liftIO $ newIORef [] - fatals <- liftIO $ newIORef [] - - let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do - let action = putLogMsg dflags reason severity srcSpan style msg - case severity of - SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) - SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) - SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ()) - _ -> action - - printDeferredDiagnostics = liftIO $ - forM_ [warnings, errors, fatals] $ \ref -> do - -- This IORef can leak when the dflags leaks, so let us always - -- reset the content. - actions <- atomicModifyIORef' ref $ \i -> ([], i) - sequence_ $ reverse actions - - setLogAction action = modifySession $ \hsc_env -> - hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } } - - gbracket - (setLogAction deferDiagnostics) - (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) - (\_ -> f) - -noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg --- ToDo: we don't have a proper line number for this error -noModError dflags loc wanted_mod err - = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages -noHsFileErr dflags loc path - = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path - -moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages -moduleNotFoundErr dflags mod - = unitBag $ mkPlainErrMsg dflags noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" - -multiRootsErr :: DynFlags -> [ModSummary] -> IO () -multiRootsErr _ [] = panic "multiRootsErr" -multiRootsErr dflags summs@(summ1:_) - = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> - text "is defined in multiple files:" <+> - sep (map text files) - where - mod = ms_mod summ1 - files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs - -keepGoingPruneErr :: [ModuleName] -> SDoc -keepGoingPruneErr ms - = vcat (( text "-fkeep-going in use, removing the following" <+> - text "dependencies and continuing:"): - map (nest 6 . ppr) ms ) - -cyclicModuleErr :: [ModSummary] -> SDoc --- From a strongly connected component we find --- a single cycle to report -cyclicModuleErr mss - = ASSERT( not (null mss) ) - case findCycle graph of - Nothing -> text "Unexpected non-cycle" <+> ppr mss - Just path -> vcat [ text "Module imports form a cycle:" - , nest 2 (show_path path) ] - where - graph :: [Node NodeKey ModSummary] - graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss] - - get_deps :: ModSummary -> [NodeKey] - get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++ - [ (unLoc m, NotBoot) | m <- ms_home_imps ms ]) - - show_path [] = panic "show_path" - show_path [m] = text "module" <+> ppr_ms m - <+> text "imports itself" - show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1) - : nest 6 (text "imports" <+> ppr_ms m2) - : go ms ) - where - go [] = [text "which imports" <+> ppr_ms m1] - go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms - - - ppr_ms :: ModSummary -> SDoc - ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> - (parens (text (msHsFilePath ms))) diff --git a/main/GhcMonad.hs b/main/GhcMonad.hs deleted file mode 100644 --- a/main/GhcMonad.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2010 --- --- The Session type and related functionality --- --- ----------------------------------------------------------------------------- - -module GhcMonad ( - -- * 'Ghc' monad stuff - GhcMonad(..), - Ghc(..), - GhcT(..), liftGhcT, - reflectGhc, reifyGhc, - getSessionDynFlags, - liftIO, - Session(..), withSession, modifySession, withTempSession, - - -- ** Warnings - logWarnings, printException, - WarnErrLogger, defaultWarnErrLogger - ) where - -import GhcPrelude - -import MonadUtils -import HscTypes -import DynFlags -import Exception -import ErrUtils - -import Control.Monad -import Data.IORef - --- ----------------------------------------------------------------------------- --- | A monad that has all the features needed by GHC API calls. --- --- In short, a GHC monad --- --- - allows embedding of IO actions, --- --- - can log warnings, --- --- - allows handling of (extensible) exceptions, and --- --- - maintains a current session. --- --- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' --- before any call to the GHC API functions can occur. --- -class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where - getSession :: m HscEnv - setSession :: HscEnv -> m () - --- | Call the argument with the current session. -withSession :: GhcMonad m => (HscEnv -> m a) -> m a -withSession f = getSession >>= f - --- | Grabs the DynFlags from the Session -getSessionDynFlags :: GhcMonad m => m DynFlags -getSessionDynFlags = withSession (return . hsc_dflags) - --- | Set the current session to the result of applying the current session to --- the argument. -modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () -modifySession f = do h <- getSession - setSession $! f h - -withSavedSession :: GhcMonad m => m a -> m a -withSavedSession m = do - saved_session <- getSession - m `gfinally` setSession saved_session - --- | Call an action with a temporarily modified Session. -withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a -withTempSession f m = - withSavedSession $ modifySession f >> m - --- ----------------------------------------------------------------------------- --- | A monad that allows logging of warnings. - -logWarnings :: GhcMonad m => WarningMessages -> m () -logWarnings warns = do - dflags <- getSessionDynFlags - liftIO $ printOrThrowWarnings dflags warns - --- ----------------------------------------------------------------------------- --- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, --- e.g., to maintain additional state consider wrapping this monad or using --- 'GhcT'. -newtype Ghc a = Ghc { unGhc :: Session -> IO a } deriving (Functor) - --- | The Session is a handle to the complete state of a compilation --- session. A compilation session consists of a set of modules --- constituting the current program or library, the context for --- interactive evaluation, and various caches. -data Session = Session !(IORef HscEnv) - -instance Applicative Ghc where - pure a = Ghc $ \_ -> return a - g <*> m = do f <- g; a <- m; return (f a) - -instance Monad Ghc where - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance MonadFix Ghc where - mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) - -instance ExceptionMonad Ghc where - gcatch act handle = - Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s - gmask f = - Ghc $ \s -> gmask $ \io_restore -> - let - g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) - in - unGhc (f g_restore) s - -instance HasDynFlags Ghc where - getDynFlags = getSessionDynFlags - -instance GhcMonad Ghc where - getSession = Ghc $ \(Session r) -> readIORef r - setSession s' = Ghc $ \(Session r) -> writeIORef r s' - --- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. --- --- You can use this to call functions returning an action in the 'Ghc' monad --- inside an 'IO' action. This is needed for some (too restrictive) callback --- arguments of some library functions: --- --- > libFunc :: String -> (Int -> IO a) -> IO a --- > ghcFunc :: Int -> Ghc a --- > --- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a --- > ghcFuncUsingLibFunc str = --- > reifyGhc $ \s -> --- > libFunc $ \i -> do --- > reflectGhc (ghcFunc i) s --- -reflectGhc :: Ghc a -> Session -> IO a -reflectGhc m = unGhc m - --- > Dual to 'reflectGhc'. See its documentation. -reifyGhc :: (Session -> IO a) -> Ghc a -reifyGhc act = Ghc $ act - --- ----------------------------------------------------------------------------- --- | A monad transformer to add GHC specific features to another monad. --- --- Note that the wrapped monad must support IO and handling of exceptions. -newtype GhcT m a = GhcT { unGhcT :: Session -> m a } - deriving (Functor) - -liftGhcT :: m a -> GhcT m a -liftGhcT m = GhcT $ \_ -> m - -instance Applicative m => Applicative (GhcT m) where - pure x = GhcT $ \_ -> pure x - g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s - -instance Monad m => Monad (GhcT m) where - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - -instance ExceptionMonad m => ExceptionMonad (GhcT m) where - gcatch act handle = - GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s - gmask f = - GhcT $ \s -> gmask $ \io_restore -> - let - g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) - in - unGhcT (f g_restore) s - -instance MonadIO m => HasDynFlags (GhcT m) where - getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) - -instance ExceptionMonad m => GhcMonad (GhcT m) where - getSession = GhcT $ \(Session r) -> liftIO $ readIORef r - setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' - - --- | Print the error message and all warnings. Useful inside exception --- handlers. Clears warnings after printing. -printException :: GhcMonad m => SourceError -> m () -printException err = do - dflags <- getSessionDynFlags - liftIO $ printBagOfErrors dflags (srcErrorMessages err) - --- | A function called to log warnings and errors. -type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () - -defaultWarnErrLogger :: WarnErrLogger -defaultWarnErrLogger Nothing = return () -defaultWarnErrLogger (Just e) = printException e - diff --git a/main/GhcNameVersion.hs b/main/GhcNameVersion.hs deleted file mode 100644 --- a/main/GhcNameVersion.hs +++ /dev/null @@ -1,11 +0,0 @@ -module GhcNameVersion - ( GhcNameVersion (..) - ) where - -import GhcPrelude - --- | Settings for what GHC this is. -data GhcNameVersion = GhcNameVersion - { ghcNameVersion_programName :: String - , ghcNameVersion_projectVersion :: String - } diff --git a/main/GhcPlugins.hs b/main/GhcPlugins.hs deleted file mode 100644 --- a/main/GhcPlugins.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-} - --- | This module is not used by GHC itself. Rather, it exports all of --- the functions and types you are likely to need when writing a --- plugin for GHC. So authors of plugins can probably get away simply --- with saying "import GhcPlugins". --- --- Particularly interesting modules for plugin writers include --- "CoreSyn" and "CoreMonad". -module GhcPlugins( - module Plugins, - module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, - module CoreMonad, module CoreSyn, module Literal, module DataCon, - module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, - module Rules, module Annotations, - module DynFlags, module Packages, - module Module, module Type, module TyCon, module Coercion, - module TysWiredIn, module HscTypes, module BasicTypes, - module VarSet, module VarEnv, module NameSet, module NameEnv, - module UniqSet, module UniqFM, module FiniteMap, - module Util, module GHC.Serialized, module SrcLoc, module Outputable, - module UniqSupply, module Unique, module FastString, - - -- * Getting 'Name's - thNameToGhcName - ) where - --- Plugin stuff itself -import Plugins - --- Variable naming -import RdrName -import OccName hiding ( varName {- conflicts with Var.varName -} ) -import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) -import Var -import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) -import IdInfo - --- Core -import CoreMonad -import CoreSyn -import Literal -import DataCon -import CoreUtils -import MkCore -import CoreFVs -import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) - -- These names are also exported by Type - --- Core "extras" -import Rules -import Annotations - --- Pipeline-related stuff -import DynFlags -import Packages - --- Important GHC types -import Module -import Type hiding {- conflict with CoreSubst -} - ( substTy, extendTvSubst, extendTvSubstList, isInScope ) -import Coercion hiding {- conflict with CoreSubst -} - ( substCo ) -import TyCon -import TysWiredIn -import HscTypes -import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) - --- Collections and maps -import VarSet -import VarEnv -import NameSet -import NameEnv -import UniqSet -import UniqFM --- Conflicts with UniqFM: ---import LazyUniqFM -import FiniteMap - --- Common utilities -import Util -import GHC.Serialized -import SrcLoc -import Outputable -import UniqSupply -import Unique ( Unique, Uniquable(..) ) -import FastString -import Data.Maybe - -import IfaceEnv ( lookupOrigIO ) -import GhcPrelude -import MonadUtils ( mapMaybeM ) -import GHC.ThToHs ( thRdrNameGuesses ) -import TcEnv ( lookupGlobal ) - -import qualified Language.Haskell.TH as TH - -{- This instance is defined outside CoreMonad.hs so that - CoreMonad does not depend on TcEnv -} -instance MonadThings CoreM where - lookupThing name = do { hsc_env <- getHscEnv - ; liftIO $ lookupGlobal hsc_env name } - -{- -************************************************************************ -* * - Template Haskell interoperability -* * -************************************************************************ --} - --- | Attempt to convert a Template Haskell name to one that GHC can --- understand. Original TH names such as those you get when you use --- the @'foo@ syntax will be translated to their equivalent GHC name --- exactly. Qualified or unqualified TH names will be dynamically bound --- to names in the module being compiled, if possible. Exact TH names --- will be bound to the name they represent, exactly. -thNameToGhcName :: TH.Name -> CoreM (Maybe Name) -thNameToGhcName th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) - -- Pick the first that works - -- E.g. reify (mkName "A") will pick the class A in preference - -- to the data constructor A - ; return (listToMaybe names) } - where - lookup rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = return $ if isExternalName n then Just n else Nothing - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { hsc_env <- getHscEnv - ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) } - | otherwise = return Nothing diff --git a/main/HeaderInfo.hs b/main/HeaderInfo.hs deleted file mode 100644 --- a/main/HeaderInfo.hs +++ /dev/null @@ -1,357 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - ------------------------------------------------------------------------------ --- --- | Parsing the top of a Haskell source file to get its module name, --- imports and options. --- --- (c) Simon Marlow 2005 --- (c) Lemmih 2006 --- ------------------------------------------------------------------------------ - -module HeaderInfo ( getImports - , mkPrelImports -- used by the renamer too - , getOptionsFromFile, getOptions - , optionsErrorMsgs, - checkProcessArgsResult ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Platform -import HscTypes -import Parser ( parseHeader ) -import Lexer -import FastString -import GHC.Hs -import Module -import PrelNames -import StringBuffer -import SrcLoc -import DynFlags -import ErrUtils -import Util -import Outputable -import Maybes -import Bag ( emptyBag, listToBag, unitBag ) -import MonadUtils -import Exception -import BasicTypes -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import System.IO -import System.IO.Unsafe -import Data.List - ------------------------------------------------------------------------------- - --- | Parse the imports of a source file. --- --- Throws a 'SourceError' if parsing fails. -getImports :: DynFlags - -> StringBuffer -- ^ Parse this. - -> FilePath -- ^ Filename the buffer came from. Used for - -- reporting parse error locations. - -> FilePath -- ^ The original source filename (used for locations - -- in the function result) - -> IO (Either - ErrorMessages - ([(Maybe FastString, Located ModuleName)], - [(Maybe FastString, Located ModuleName)], - Located ModuleName)) - -- ^ The source imports, normal imports, and the module name. -getImports dflags buf filename source_filename = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 - case unP parseHeader (mkPState dflags buf loc) of - PFailed pst -> - -- assuming we're not logging warnings here as per below - return $ Left $ getErrorMessages pst dflags - POk pst rdr_module -> fmap Right $ do - let _ms@(_warns, errs) = getMessages pst dflags - -- don't log warnings: they'll be reported when we parse the file - -- for real. See #2500. - ms = (emptyBag, errs) - -- logWarnings warns - if errorsFound dflags ms - then throwIO $ mkSrcErr errs - else - let hsmod = unLoc rdr_module - mb_mod = hsmodName hsmod - imps = hsmodImports hsmod - main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) - 1 1) - mod = mb_mod `orElse` cL main_loc mAIN_NAME - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc - . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports (unLoc mod) main_loc - implicit_prelude imps - convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i) - , ideclName i) - in - return (map convImport src_idecls, - map convImport (implicit_imports ++ ordinary_imps), - mod) - -mkPrelImports :: ModuleName - -> SrcSpan -- Attribute the "import Prelude" to this location - -> Bool -> [LImportDecl GhcPs] - -> [LImportDecl GhcPs] --- Construct the implicit declaration "import Prelude" (or not) --- --- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); --- because the former doesn't even look at Prelude.hi for instance --- declarations, whereas the latter does. -mkPrelImports this_mod loc implicit_prelude import_decls - | this_mod == pRELUDE_NAME - || explicit_prelude_import - || not implicit_prelude - = [] - | otherwise = [preludeImportDecl] - where - explicit_prelude_import - = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing })) - <- import_decls - , unLoc mod == pRELUDE_NAME ] - - preludeImportDecl :: LImportDecl GhcPs - preludeImportDecl - = cL loc $ ImportDecl { ideclExt = noExtField, - ideclSourceSrc = NoSourceText, - ideclName = cL loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = NotQualified, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } - --------------------------------------------------------------- --- Get options --------------------------------------------------------------- - --- | Parse OPTIONS and LANGUAGE pragmas of the source file. --- --- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) -getOptionsFromFile :: DynFlags - -> FilePath -- ^ Input file - -> IO [Located String] -- ^ Parsed options, if any. -getOptionsFromFile dflags filename - = Exception.bracket - (openBinaryFile filename ReadMode) - (hClose) - (\handle -> do - opts <- fmap (getOptions' dflags) - (lazyGetToks dflags' filename handle) - seqList opts $ return opts) - where -- We don't need to get haddock doc tokens when we're just - -- getting the options from pragmas, and lazily lexing them - -- correctly is a little tricky: If there is "\n" or "\n-" - -- left at the end of a buffer then the haddock doc may - -- continue past the end of the buffer, despite the fact that - -- we already have an apparently-complete token. - -- We therefore just turn Opt_Haddock off when doing the lazy - -- lex. - dflags' = gopt_unset dflags Opt_Haddock - -blockSize :: Int --- blockSize = 17 -- for testing :-) -blockSize = 1024 - -lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] -lazyGetToks dflags filename handle = do - buf <- hGetStringBufferBlock handle blockSize - unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize - where - loc = mkRealSrcLoc (mkFastString filename) 1 1 - - lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] - lazyLexBuf handle state eof size = do - case unP (lexer False return) state of - POk state' t -> do - -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) - if atEnd (buffer state') && not eof - -- if this token reached the end of the buffer, and we haven't - -- necessarily read up to the end of the file, then the token might - -- be truncated, so read some more of the file and lex it again. - then getMore handle state size - else case unLoc t of - ITeof -> return [t] - _other -> do rest <- lazyLexBuf handle state' eof size - return (t : rest) - _ | not eof -> getMore handle state size - | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof] - -- parser assumes an ITeof sentinel at the end - - getMore :: Handle -> PState -> Int -> IO [Located Token] - getMore handle state size = do - -- pprTrace "getMore" (text (show (buffer state))) (return ()) - let new_size = size * 2 - -- double the buffer size each time we read a new block. This - -- counteracts the quadratic slowdown we otherwise get for very - -- large module names (#5981) - nextbuf <- hGetStringBufferBlock handle new_size - if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do - newbuf <- appendStringBuffers (buffer state) nextbuf - unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size - - -getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] -getToks dflags filename buf = lexAll (pragState dflags buf loc) - where - loc = mkRealSrcLoc (mkFastString filename) 1 1 - - lexAll state = case unP (lexer False return) state of - POk _ t@(dL->L _ ITeof) -> [t] - POk state' t -> t : lexAll state' - _ -> [cL (RealSrcSpan (last_loc state)) ITeof] - - --- | Parse OPTIONS and LANGUAGE pragmas of the source file. --- --- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) -getOptions :: DynFlags - -> StringBuffer -- ^ Input Buffer - -> FilePath -- ^ Source filename. Used for location info. - -> [Located String] -- ^ Parsed options. -getOptions dflags buf filename - = getOptions' dflags (getToks dflags filename buf) - --- The token parser is written manually because Happy can't --- return a partial result when it encounters a lexer error. --- We want to extract options before the buffer is passed through --- CPP, so we can't use the same trick as 'getImports'. -getOptions' :: DynFlags - -> [Located Token] -- Input buffer - -> [Located String] -- Options. -getOptions' dflags toks - = parseToks toks - where - parseToks (open:close:xs) - | IToptions_prag str <- unLoc open - , ITclose_prag <- unLoc close - = case toArgs str of - Left _err -> optionsParseError str dflags $ -- #15053 - combineSrcSpans (getLoc open) (getLoc close) - Right args -> map (cL (getLoc open)) args ++ parseToks xs - parseToks (open:close:xs) - | ITinclude_prag str <- unLoc open - , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-#include",removeSpaces str] ++ - parseToks xs - parseToks (open:close:xs) - | ITdocOptions str <- unLoc open - , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str] - ++ parseToks xs - parseToks (open:xs) - | ITlanguage_prag <- unLoc open - = parseLanguage xs - parseToks (comment:xs) -- Skip over comments - | isComment (unLoc comment) - = parseToks xs - parseToks _ = [] - parseLanguage ((dL->L loc (ITconid fs)):rest) - = checkExtension dflags (cL loc fs) : - case rest of - (dL->L _loc ITcomma):more -> parseLanguage more - (dL->L _loc ITclose_prag):more -> parseToks more - (dL->L loc _):_ -> languagePragParseError dflags loc - [] -> panic "getOptions'.parseLanguage(1) went past eof token" - parseLanguage (tok:_) - = languagePragParseError dflags (getLoc tok) - parseLanguage [] - = panic "getOptions'.parseLanguage(2) went past eof token" - - isComment :: Token -> Bool - isComment c = - case c of - (ITlineComment {}) -> True - (ITblockComment {}) -> True - (ITdocCommentNext {}) -> True - (ITdocCommentPrev {}) -> True - (ITdocCommentNamed {}) -> True - (ITdocSection {}) -> True - _ -> False - ------------------------------------------------------------------------------ - --- | Complain about non-dynamic flags in OPTIONS pragmas. --- --- Throws a 'SourceError' if the input list is non-empty claiming that the --- input flags are unknown. -checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () -checkProcessArgsResult dflags flags - = when (notNull flags) $ - liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags - where mkMsg (dL->L loc flag) - = mkPlainErrMsg dflags loc $ - (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> - text flag) - ------------------------------------------------------------------------------ - -checkExtension :: DynFlags -> Located FastString -> Located String -checkExtension dflags (dL->L l ext) --- Checks if a given extension is valid, and if so returns --- its corresponding flag. Otherwise it throws an exception. - = if ext' `elem` supported - then cL l ("-X"++ext') - else unsupportedExtnError dflags l ext' - where - ext' = unpackFS ext - supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags - -languagePragParseError :: DynFlags -> SrcSpan -> a -languagePragParseError dflags loc = - throwErr dflags loc $ - vcat [ text "Cannot parse LANGUAGE pragma" - , text "Expecting comma-separated list of language options," - , text "each starting with a capital letter" - , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ] - -unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a -unsupportedExtnError dflags loc unsup = - throwErr dflags loc $ - text "Unsupported extension: " <> text unsup $$ - if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) - where - supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags - suggestions = fuzzyMatch unsup supported - - -optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages -optionsErrorMsgs dflags unhandled_flags flags_lines _filename - = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) - where unhandled_flags_lines :: [Located String] - unhandled_flags_lines = [ cL l f - | f <- unhandled_flags - , (dL->L l f') <- flags_lines - , f == f' ] - mkMsg (dL->L flagSpan flag) = - ErrUtils.mkPlainErrMsg dflags flagSpan $ - text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag - -optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 -optionsParseError str dflags loc = - throwErr dflags loc $ - vcat [ text "Error while parsing OPTIONS_GHC pragma." - , text "Expecting whitespace-separated list of GHC options." - , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" - , text ("Input was: " ++ show str) ] - -throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053 -throwErr dflags loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc diff --git a/main/Hooks.hs b/main/Hooks.hs deleted file mode 100644 --- a/main/Hooks.hs +++ /dev/null @@ -1,104 +0,0 @@ --- \section[Hooks]{Low level API hooks} - --- NB: this module is SOURCE-imported by DynFlags, and should primarily --- refer to *types*, rather than *code* - -{-# LANGUAGE CPP #-} -module Hooks ( Hooks - , emptyHooks - , lookupHook - , getHooked - -- the hooks: - , dsForeignsHook - , tcForeignImportsHook - , tcForeignExportsHook - , hscFrontendHook - , hscCompileCoreExprHook - , ghcPrimIfaceHook - , runPhaseHook - , runMetaHook - , linkHook - , runRnSpliceHook - , getValueSafelyHook - , createIservProcessHook - ) where - -import GhcPrelude - -import DynFlags -import PipelineMonad -import HscTypes -import GHC.Hs.Decls -import GHC.Hs.Binds -import GHC.Hs.Expr -import OrdList -import TcRnTypes -import Bag -import RdrName -import Name -import Id -import CoreSyn -import GHCi.RemoteTypes -import SrcLoc -import Type -import System.Process -import BasicTypes -import GHC.Hs.Extension - -import Data.Maybe - -{- -************************************************************************ -* * -\subsection{Hooks} -* * -************************************************************************ --} - --- | Hooks can be used by GHC API clients to replace parts of --- the compiler pipeline. If a hook is not installed, GHC --- uses the default built-in behaviour - -emptyHooks :: Hooks -emptyHooks = Hooks - { dsForeignsHook = Nothing - , tcForeignImportsHook = Nothing - , tcForeignExportsHook = Nothing - , hscFrontendHook = Nothing - , hscCompileCoreExprHook = Nothing - , ghcPrimIfaceHook = Nothing - , runPhaseHook = Nothing - , runMetaHook = Nothing - , linkHook = Nothing - , runRnSpliceHook = Nothing - , getValueSafelyHook = Nothing - , createIservProcessHook = Nothing - } - -data Hooks = Hooks - { dsForeignsHook :: Maybe ([LForeignDecl GhcTc] - -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) - , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn] - -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)) - , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn] - -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)) - , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) - , hscCompileCoreExprHook :: - Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) - , ghcPrimIfaceHook :: Maybe ModIface - , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags - -> CompPipeline (PhasePlus, FilePath)) - , runMetaHook :: Maybe (MetaHook TcM) - , linkHook :: Maybe (GhcLink -> DynFlags -> Bool - -> HomePackageTable -> IO SuccessFlag) - , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)) - , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type - -> IO (Maybe HValue)) - , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) - } - -getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a -getHooked hook def = fmap (lookupHook hook def) getDynFlags - -lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a -lookupHook hook def = fromMaybe def . hook . hooks diff --git a/main/Hooks.hs-boot b/main/Hooks.hs-boot deleted file mode 100644 --- a/main/Hooks.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module Hooks where - -import GhcPrelude () - -data Hooks - -emptyHooks :: Hooks diff --git a/main/HscMain.hs b/main/HscMain.hs deleted file mode 100644 --- a/main/HscMain.hs +++ /dev/null @@ -1,1929 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} -{-# OPTIONS_GHC -fprof-auto-top #-} - -------------------------------------------------------------------------------- --- --- | Main API for compiling plain Haskell source code. --- --- This module implements compilation of a Haskell source. It is --- /not/ concerned with preprocessing of source files; this is handled --- in "DriverPipeline". --- --- There are various entry points depending on what mode we're in: --- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and --- "interactive" mode (GHCi). There are also entry points for --- individual passes: parsing, typechecking/renaming, desugaring, and --- simplification. --- --- All the functions here take an 'HscEnv' as a parameter, but none of --- them return a new one: 'HscEnv' is treated as an immutable value --- from here on in (although it has mutable components, for the --- caches). --- --- We use the Hsc monad to deal with warning messages consistently: --- specifically, while executing within an Hsc monad, warnings are --- collected. When a Hsc monad returns to an IO monad, the --- warnings are printed, or compilation aborts if the @-Werror@ --- flag is enabled. --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 --- -------------------------------------------------------------------------------- - -module HscMain - ( - -- * Making an HscEnv - newHscEnv - - -- * Compiling complete source files - , Messager, batchMsg - , HscStatus (..) - , hscIncrementalCompile - , hscMaybeWriteIface - , hscCompileCmmFile - - , hscGenHardCode - , hscInteractive - - -- * Running passes separately - , hscParse - , hscTypecheckRename - , hscDesugar - , makeSimpleDetails - , hscSimplify -- ToDo, shouldn't really export this - - -- * Safe Haskell - , hscCheckSafe - , hscGetSafe - - -- * Support for interactive evaluation - , hscParseIdentifier - , hscTcRcLookupName - , hscTcRnGetInfo - , hscIsGHCiMonad - , hscGetModuleInterface - , hscRnImportDecls - , hscTcRnLookupRdrName - , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt - , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls - , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType - , hscParseExpr - , hscParseType - , hscCompileCoreExpr - -- * Low-level exports for hooks - , hscCompileCoreExpr' - -- We want to make sure that we export enough to be able to redefine - -- hscFileFrontEnd in client code - , hscParse', hscSimplify', hscDesugar', tcRnModule' - , getHscEnv - , hscSimpleIface' - , oneShotMsg - , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats - , ioMsgMaybe - , showModuleIndex - , hscAddSptEntries - ) where - -import GhcPrelude - -import Data.Data hiding (Fixity, TyCon) -import Data.Maybe ( fromJust ) -import Id -import GHCi ( addSptEntry ) -import GHCi.RemoteTypes ( ForeignHValue ) -import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) -import Linker -import CoreTidy ( tidyExpr ) -import Type ( Type ) -import {- Kind parts of -} Type ( Kind ) -import CoreLint ( lintInteractiveExpr ) -import VarEnv ( emptyTidyEnv ) -import Panic -import ConLike -import Control.Concurrent - -import Module -import Packages -import RdrName -import GHC.Hs -import GHC.Hs.Dump -import CoreSyn -import StringBuffer -import Parser -import Lexer -import SrcLoc -import TcRnDriver -import TcIface ( typecheckIface ) -import TcRnMonad -import TcHsSyn ( ZonkFlexi (DefaultFlexi) ) -import NameCache ( initNameCache ) -import LoadIface ( ifaceStats, initExternalPackageState ) -import PrelInfo -import MkIface -import Desugar -import SimplCore -import TidyPgm -import CorePrep -import CoreToStg ( coreToStg ) -import qualified GHC.StgToCmm as StgToCmm ( codeGen ) -import StgSyn -import StgFVs ( annTopBindingsFreeVars ) -import CostCentre -import ProfInit -import TyCon -import Name -import SimplStg ( stg2stg ) -import Cmm -import CmmParse ( parseCmmFile ) -import CmmBuildInfoTables -import CmmPipeline -import CmmInfo -import CodeOutput -import InstEnv -import FamInstEnv -import Fingerprint ( Fingerprint ) -import Hooks -import TcEnv -import PrelNames -import Plugins -import DynamicLoading ( initializePlugins ) - -import DynFlags -import ErrUtils - -import Outputable -import NameEnv -import HscStats ( ppSourceStats ) -import HscTypes -import FastString -import UniqSupply -import Bag -import Exception -import qualified Stream -import Stream (Stream) - -import Util - -import Data.List ( nub, isPrefixOf, partition ) -import Control.Monad -import Data.IORef -import System.FilePath as FilePath -import System.Directory -import System.IO (fixIO) -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Set (Set) -import Control.DeepSeq (force) - -import HieAst ( mkHieFile ) -import HieTypes ( getAsts, hie_asts, hie_module ) -import HieBin ( readHieFile, writeHieFile , hie_file_result) -import HieDebug ( diffFile, validateScopes ) - -#include "HsVersions.h" - - -{- ********************************************************************** -%* * - Initialisation -%* * -%********************************************************************* -} - -newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags = do - eps_var <- newIORef initExternalPackageState - us <- mkSplitUniqSupply 'r' - nc_var <- newIORef (initNameCache us knownKeyNames) - fc_var <- newIORef emptyInstalledModuleEnv - iserv_mvar <- newMVar Nothing - emptyDynLinker <- uninitializedLinker - return HscEnv { hsc_dflags = dflags - , hsc_targets = [] - , hsc_mod_graph = emptyMG - , hsc_IC = emptyInteractiveContext dflags - , hsc_HPT = emptyHomePackageTable - , hsc_EPS = eps_var - , hsc_NC = nc_var - , hsc_FC = fc_var - , hsc_type_env_var = Nothing - , hsc_iserv = iserv_mvar - , hsc_dynLinker = emptyDynLinker - } - --- ----------------------------------------------------------------------------- - -getWarnings :: Hsc WarningMessages -getWarnings = Hsc $ \_ w -> return (w, w) - -clearWarnings :: Hsc () -clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) - -logWarnings :: WarningMessages -> Hsc () -logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) - -getHscEnv :: Hsc HscEnv -getHscEnv = Hsc $ \e w -> return (e, w) - -handleWarnings :: Hsc () -handleWarnings = do - dflags <- getDynFlags - w <- getWarnings - liftIO $ printOrThrowWarnings dflags w - clearWarnings - --- | log warning in the monad, and if there are errors then --- throw a SourceError exception. -logWarningsReportErrors :: Messages -> Hsc () -logWarningsReportErrors (warns,errs) = do - logWarnings warns - when (not $ isEmptyBag errs) $ throwErrors errs - --- | Log warnings and throw errors, assuming the messages --- contain at least one error (e.g. coming from PFailed) -handleWarningsThrowErrors :: Messages -> Hsc a -handleWarningsThrowErrors (warns, errs) = do - logWarnings warns - dflags <- getDynFlags - (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings - liftIO $ printBagOfErrors dflags wWarns - throwErrors (unionBags errs wErrs) - --- | Deal with errors and warnings returned by a compilation step --- --- In order to reduce dependencies to other parts of the compiler, functions --- outside the "main" parts of GHC return warnings and errors as a parameter --- and signal success via by wrapping the result in a 'Maybe' type. This --- function logs the returned warnings and propagates errors as exceptions --- (of type 'SourceError'). --- --- This function assumes the following invariants: --- --- 1. If the second result indicates success (is of the form 'Just x'), --- there must be no error messages in the first result. --- --- 2. If there are no error messages, but the second result indicates failure --- there should be warnings in the first result. That is, if the action --- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a -ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO ioA - logWarnings warns - case mb_r of - Nothing -> throwErrors errs - Just r -> ASSERT( isEmptyBag errs ) return r - --- | like ioMsgMaybe, except that we ignore error messages and return --- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) -ioMsgMaybe' ioA = do - ((warns,_errs), mb_r) <- liftIO $ ioA - logWarnings warns - return mb_r - --- ----------------------------------------------------------------------------- --- | Lookup things in the compiler's environment - -hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] -hscTcRnLookupRdrName hsc_env0 rdr_name - = runInteractiveHsc hsc_env0 $ - do { hsc_env <- getHscEnv - ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } - -hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe' $ tcRnLookupName hsc_env name - -- ignore errors: the only error we're likely to get is - -- "name not found", and the Maybe in the return type - -- is used to indicate that. - -hscTcRnGetInfo :: HscEnv -> Name - -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -hscTcRnGetInfo hsc_env0 name - = runInteractiveHsc hsc_env0 $ - do { hsc_env <- getHscEnv - ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } - -hscIsGHCiMonad :: HscEnv -> String -> IO Name -hscIsGHCiMonad hsc_env name - = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name - -hscGetModuleInterface :: HscEnv -> Module -> IO ModIface -hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe $ getModuleInterface hsc_env mod - --- ----------------------------------------------------------------------------- --- | Rename some import declarations -hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe $ tcRnImportDecls hsc_env import_decls - --- ----------------------------------------------------------------------------- --- | parse a file, returning the abstract syntax - -hscParse :: HscEnv -> ModSummary -> IO HsParsedModule -hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary - --- internal version, that doesn't fail due to -Werror -hscParse' :: ModSummary -> Hsc HsParsedModule -hscParse' mod_summary - | Just r <- ms_parsed_mod mod_summary = return r - | otherwise = {-# SCC "Parser" #-} - withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) - (const ()) $ do - dflags <- getDynFlags - let src_filename = ms_hspp_file mod_summary - maybe_src_buf = ms_hspp_buf mod_summary - - -------------------------- Parser ---------------- - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> liftIO $ hGetStringBuffer src_filename - - let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 - let parseMod | HsigFile == ms_hsc_src mod_summary - = parseSignature - | otherwise = parseModule - - case unP parseMod (mkPState dflags buf loc) of - PFailed pst -> - handleWarningsThrowErrors (getMessages pst dflags) - POk pst rdr_module -> do - let (warns, errs) = getMessages pst dflags - logWarnings warns - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $ - ppr rdr_module - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - showAstData NoBlankSrcSpan rdr_module - liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $ - ppSourceStats False rdr_module - when (not $ isEmptyBag errs) $ throwErrors errs - - -- To get the list of extra source files, we take the list - -- that the parser gave us, - -- - eliminate files beginning with '<'. gcc likes to use - -- pseudo-filenames like "" and "" - -- - normalise them (eliminate differences between ./f and f) - -- - filter out the preprocessed source file - -- - filter out anything beginning with tmpdir - -- - remove duplicates - -- - filter out the .hs/.lhs source filename if we have one - -- - let n_hspp = FilePath.normalise src_filename - srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) - $ filter (not . (== n_hspp)) - $ map FilePath.normalise - $ filter (not . isPrefixOf "<") - $ map unpackFS - $ srcfiles pst - srcs1 = case ml_hs_file (ms_location mod_summary) of - Just f -> filter (/= FilePath.normalise f) srcs0 - Nothing -> srcs0 - - -- sometimes we see source files from earlier - -- preprocessing stages that cannot be found, so just - -- filter them out: - srcs2 <- liftIO $ filterM doesFileExist srcs1 - - let res = HsParsedModule { - hpm_module = rdr_module, - hpm_src_files = srcs2, - hpm_annotations - = (M.fromListWith (++) $ annotations pst, - M.fromList $ ((noSrcSpan,comment_q pst) - :(annotations_comments pst))) - } - - -- apply parse transformation of plugins - let applyPluginAction p opts - = parsedResultAction p opts mod_summary - withPlugins dflags applyPluginAction res - - --- ----------------------------------------------------------------------------- --- | If the renamed source has been kept, extract it. Dump it if requested. -extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff -extract_renamed_stuff mod_summary tc_result = do - let rn_info = getRenamedStuff tc_result - - dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $ - showAstData NoBlankSrcSpan rn_info - - -- Create HIE files - when (gopt Opt_WriteHie dflags) $ do - -- I assume this fromJust is safe because `-fwrite-hie-file` - -- enables the option which keeps the renamed source. - hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) - let out_file = ml_hie_file $ ms_location mod_summary - liftIO $ writeHieFile out_file hieFile - - -- Validate HIE files - when (gopt Opt_ValidateHie dflags) $ do - hs_env <- Hsc $ \e w -> return (e, w) - liftIO $ do - -- Validate Scopes - let mdl = hie_module hieFile - case validateScopes mdl $ getAsts $ hie_asts hieFile of - [] -> putMsg dflags $ text "Got valid scopes" - xs -> do - putMsg dflags $ text "Got invalid scopes" - mapM_ (putMsg dflags) xs - -- Roundtrip testing - nc <- readIORef $ hsc_NC hs_env - (file', _) <- readHieFile nc out_file - case diffFile hieFile (hie_file_result file') of - [] -> - putMsg dflags $ text "Got no roundtrip errors" - xs -> do - putMsg dflags $ text "Got roundtrip errors" - mapM_ (putMsg dflags) xs - return rn_info - - --- ----------------------------------------------------------------------------- --- | Rename and typecheck a module, additionally returning the renamed syntax -hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule - -> IO (TcGblEnv, RenamedStuff) -hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- hsc_typecheck True mod_summary (Just rdr_module) - rn_info <- extract_renamed_stuff mod_summary tc_result - return (tc_result, rn_info) - --- | Rename and typecheck a module, but don't return the renamed syntax -hscTypecheck :: Bool -- ^ Keep renamed source? - -> ModSummary -> Maybe HsParsedModule - -> Hsc TcGblEnv -hscTypecheck keep_rn mod_summary mb_rdr_module = do - tc_result <- hsc_typecheck keep_rn mod_summary mb_rdr_module - _ <- extract_renamed_stuff mod_summary tc_result - return tc_result - -hsc_typecheck :: Bool -- ^ Keep renamed source? - -> ModSummary -> Maybe HsParsedModule - -> Hsc TcGblEnv -hsc_typecheck keep_rn mod_summary mb_rdr_module = do - hsc_env <- getHscEnv - let hsc_src = ms_hsc_src mod_summary - dflags = hsc_dflags hsc_env - outer_mod = ms_mod mod_summary - mod_name = moduleName outer_mod - outer_mod' = mkModule (thisPackage dflags) mod_name - inner_mod = canonicalizeHomeModule dflags mod_name - src_filename = ms_hspp_file mod_summary - real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 - keep_rn' = gopt Opt_WriteHie dflags || keep_rn - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - if hsc_src == HsigFile && not (isHoleModule inner_mod) - then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc - else - do hpm <- case mb_rdr_module of - Just hpm -> return hpm - Nothing -> hscParse' mod_summary - tc_result0 <- tcRnModule' mod_summary keep_rn' hpm - if hsc_src == HsigFile - then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing - ioMsgMaybe $ - tcRnMergeSignatures hsc_env hpm tc_result0 iface - else return tc_result0 - --- wrapper around tcRnModule to handle safe haskell extras -tcRnModule' :: ModSummary -> Bool -> HsParsedModule - -> Hsc TcGblEnv -tcRnModule' sum save_rn_syntax mod = do - hsc_env <- getHscEnv - dflags <- getDynFlags - - -- -Wmissing-safe-haskell-mode - when (not (safeHaskellModeEnabled dflags) - && wopt Opt_WarnMissingSafeHaskellMode dflags) $ - logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ - mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $ - warnMissingSafeHaskellMode - - tcg_res <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env sum - save_rn_syntax mod - - -- See Note [Safe Haskell Overlapping Instances Implementation] - -- although this is used for more than just that failure case. - (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res) - let allSafeOK = safeInferred dflags && tcSafeOK - - -- end of the safe haskell line, how to respond to user? - res <- if not (safeHaskellOn dflags) - || (safeInferOn dflags && not allSafeOK) - -- if safe Haskell off or safe infer failed, mark unsafe - then markUnsafeInfer tcg_res whyUnsafe - - -- module (could be) safe, throw warning if needed - else do - tcg_res' <- hscCheckSafeImports tcg_res - safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') - when safe $ do - case wopt Opt_WarnSafe dflags of - True - | safeHaskell dflags == Sf_Safe -> return () - | otherwise -> (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ - errSafe tcg_res') - False | safeHaskell dflags == Sf_Trustworthy && - wopt Opt_WarnTrustworthySafe dflags -> - (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ - errTwthySafe tcg_res') - False -> return () - return tcg_res' - - -- apply plugins to the type checking result - - - return res - where - pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" - errTwthySafe t = quotes (pprMod t) - <+> text "is marked as Trustworthy but has been inferred as safe!" - warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum)) - <+> text "is missing Safe Haskell mode" - --- | Convert a typechecked module to Core -hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts -hscDesugar hsc_env mod_summary tc_result = - runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result - -hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts -hscDesugar' mod_location tc_result = do - hsc_env <- getHscEnv - r <- ioMsgMaybe $ - {-# SCC "deSugar" #-} - deSugar hsc_env mod_location tc_result - - -- always check -Werror after desugaring, this is the last opportunity for - -- warnings to arise before the backend. - handleWarnings - return r - --- | Make a 'ModDetails' from the results of typechecking. Used when --- typechecking only, as opposed to full compilation. -makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails -makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result - - -{- ********************************************************************** -%* * - The main compiler pipeline -%* * -%********************************************************************* -} - -{- - -------------------------------- - The compilation proper - -------------------------------- - -It's the task of the compilation proper to compile Haskell, hs-boot and core -files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all -(the module is still parsed and type-checked. This feature is mostly used by -IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', -'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' -mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode -targets byte-code. - -The modes are kept separate because of their different types and meanings: - - * In 'one-shot' mode, we're only compiling a single file and can therefore - discard the new ModIface and ModDetails. This is also the reason it only - targets hard-code; compiling to byte-code or nothing doesn't make sense when - we discard the result. - - * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface - and ModDetails. 'Batch' mode doesn't target byte-code since that require us to - return the newly compiled byte-code. - - * 'Nothing' mode has exactly the same type as 'batch' mode but they're still - kept separate. This is because compiling to nothing is fairly special: We - don't output any interface files, we don't run the simplifier and we don't - generate any code. - - * 'Interactive' mode is similar to 'batch' mode except that we return the - compiled byte-code together with the ModIface and ModDetails. - -Trying to compile a hs-boot file to byte-code will result in a run-time error. -This is the only thing that isn't caught by the type-system. --} - - -type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () - --- | This function runs GHC's frontend with recompilation --- avoidance. Specifically, it checks if recompilation is needed, --- and if it is, it parses and typechecks the input module. --- It does not write out the results of typechecking (See --- compileOne and hscIncrementalCompile). -hscIncrementalFrontend :: Bool -- always do basic recompilation check? - -> Maybe TcGblEnv - -> Maybe Messager - -> ModSummary - -> SourceModified - -> Maybe ModIface -- Old interface, if available - -> (Int,Int) -- (i,n) = module i of n (for msgs) - -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)) - -hscIncrementalFrontend - always_do_basic_recompilation_check m_tc_result - mHscMessage mod_summary source_modified mb_old_iface mod_index - = do - hsc_env <- getHscEnv - - let msg what = case mHscMessage of - Just hscMessage -> hscMessage hsc_env mod_index what mod_summary - Nothing -> return () - - skip iface = do - liftIO $ msg UpToDate - return $ Left iface - - compile mb_old_hash reason = do - liftIO $ msg reason - result <- genericHscFrontend mod_summary - return $ Right (result, mb_old_hash) - - stable = case source_modified of - SourceUnmodifiedAndStable -> True - _ -> False - - case m_tc_result of - Just tc_result - | not always_do_basic_recompilation_check -> - return $ Right (FrontendTypecheck tc_result, Nothing) - _ -> do - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_modified mb_old_iface - -- save the interface that comes back from checkOldIface. - -- In one-shot mode we don't have the old iface until this - -- point, when checkOldIface reads it from the disk. - let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface - - case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> - -- If the module used TH splices when it was last - -- compiled, then the recompilation check is not - -- accurate enough (#481) and we must ignore - -- it. However, if the module is stable (none of - -- the modules it depends on, directly or - -- indirectly, changed), then we *can* skip - -- recompilation. This is why the SourceModified - -- type contains SourceUnmodifiedAndStable, and - -- it's pretty important: otherwise ghc --make - -- would always recompile TH modules, even if - -- nothing at all has changed. Stability is just - -- the same check that make is doing for us in - -- one-shot mode. - case m_tc_result of - Nothing - | mi_used_th iface && not stable -> - compile mb_old_hash (RecompBecause "TH") - _ -> - skip iface - _ -> - case m_tc_result of - Nothing -> compile mb_old_hash recomp_reqd - Just tc_result -> - return $ Right (FrontendTypecheck tc_result, mb_old_hash) - -genericHscFrontend :: ModSummary -> Hsc FrontendResult -genericHscFrontend mod_summary = - getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary) - -genericHscFrontend' :: ModSummary -> Hsc FrontendResult -genericHscFrontend' mod_summary - = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary - --------------------------------------------------------------- --- Compilers --------------------------------------------------------------- - --- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts --- of the pipeline. --- We return a interface if we already had an old one around and recompilation --- was not needed. Otherwise it will be created during later passes when we --- run the compilation pipeline. -hscIncrementalCompile :: Bool - -> Maybe TcGblEnv - -> Maybe Messager - -> HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface - -> (Int,Int) - -> IO (HscStatus, ModDetails, DynFlags) -hscIncrementalCompile always_do_basic_recompilation_check m_tc_result - mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index - = do - dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env') - let hsc_env'' = hsc_env' { hsc_dflags = dflags } - - -- One-shot mode needs a knot-tying mutable variable for interface - -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. - -- See also Note [hsc_type_env_var hack] - type_env_var <- newIORef emptyNameEnv - let mod = ms_mod mod_summary - hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env'')) - = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) } - | otherwise - = hsc_env'' - - -- NB: enter Hsc monad here so that we don't bail out early with - -- -Werror on typechecker warnings; we also want to run the desugarer - -- to get those warnings too. (But we'll always exit at that point - -- because the desugarer runs ioMsgMaybe.) - runHsc hsc_env $ do - e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage - mod_summary source_modified mb_old_iface mod_index - case e of - -- We didn't need to do any typechecking; the old interface - -- file on disk was good enough. - Left iface -> do - -- Knot tying! See Note [Knot-tying typecheckIface] - details <- liftIO . fixIO $ \details' -> do - let hsc_env' = - hsc_env { - hsc_HPT = addToHpt (hsc_HPT hsc_env) - (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing) - } - -- NB: This result is actually not that useful - -- in one-shot mode, since we're not going to do - -- any further typechecking. It's much more useful - -- in make mode, since this HMI will go into the HPT. - details <- genModDetails hsc_env' iface - return details - return (HscUpToDate iface, details, dflags) - -- We finished type checking. (mb_old_hash is the hash of - -- the interface that existed on disk; it's possible we had - -- to retypecheck but the resulting interface is exactly - -- the same.) - Right (FrontendTypecheck tc_result, mb_old_hash) -> do - (status, mb_old_hash) <- finish mod_summary tc_result mb_old_hash - return (status, mb_old_hash, dflags) - --- Runs the post-typechecking frontend (desugar and simplify). We want to --- generate most of the interface as late as possible. This gets us up-to-date --- and good unfoldings and other info in the interface file. --- --- We might create a interface right away, in which case we also return the --- updated HomeModInfo. But we might also need to run the backend first. In the --- later case Status will be HscRecomp and we return a function from ModIface -> --- HomeModInfo. --- --- HscRecomp in turn will carry the information required to compute a interface --- when passed the result of the code generator. So all this can and is done at --- the call site of the backend code gen if it is run. -finish :: ModSummary - -> TcGblEnv - -> Maybe Fingerprint - -> Hsc (HscStatus, ModDetails) -finish summary tc_result mb_old_hash = do - hsc_env <- getHscEnv - let dflags = hsc_dflags hsc_env - target = hscTarget dflags - hsc_src = ms_hsc_src summary - should_desugar = - ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile - mk_simple_iface :: Hsc (HscStatus, ModDetails) - mk_simple_iface = do - (iface, mb_old_iface_hash, details) <- liftIO $ - hscSimpleIface hsc_env tc_result mb_old_hash - - liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) - - let hsc_status = - case (target, hsc_src) of - (HscNothing, _) -> HscNotGeneratingCode iface - (_, HsBootFile) -> HscUpdateBoot iface - (_, HsigFile) -> HscUpdateSig iface - _ -> panic "finish" - return (hsc_status, details) - - if should_desugar - then do - -- We usually desugar even when we are not generating code, otherwise we - -- would miss errors thrown by the desugaring (see #10600). The only - -- exceptions are when the Module is Ghc.Prim or when it is not a - -- HsSrcFile Module. - desugared_guts0 <- hscDesugar' (ms_location summary) tc_result - if target == HscNothing - -- We are not generating code, so we can skip simplification - -- and generate a simple interface. - then mk_simple_iface - else do - plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) - desugared_guts <- hscSimplify' plugins desugared_guts0 - - (cg_guts, details) <- {-# SCC "CoreTidy" #-} - liftIO $ tidyProgram hsc_env desugared_guts - - let !partial_iface = - {-# SCC "HscMain.mkPartialIface" #-} - -- This `force` saves 2M residency in test T10370 - -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hsc_env details desugared_guts) - - return ( HscRecomp { hscs_guts = cg_guts, - hscs_mod_location = ms_location summary, - hscs_partial_iface = partial_iface, - hscs_old_iface_hash = mb_old_hash, - hscs_iface_dflags = dflags }, - details ) - else mk_simple_iface - - -{- -Note [Writing interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We write interface files in HscMain.hs and DriverPipeline.hs using -hscMaybeWriteIface, but only once per compilation (twice with dynamic-too). - -* If a compilation does NOT require (re)compilation of the hard code we call - hscMaybeWriteIface inside HscMain:finish. -* If we run in One Shot mode and target bytecode we write it in compileOne' -* Otherwise we must be compiling to regular hard code and require recompilation. - In this case we create the interface file inside RunPhase using the interface - generator contained inside the HscRecomp status. --} -hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () -hscMaybeWriteIface dflags iface old_iface location = do - let force_write_interface = gopt Opt_WriteInterface dflags - write_interface = case hscTarget dflags of - HscNothing -> False - HscInterpreted -> False - _ -> True - no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) - - when (write_interface || force_write_interface) $ - hscWriteIface dflags iface no_change location - --------------------------------------------------------------- --- NoRecomp handlers --------------------------------------------------------------- - --- NB: this must be knot-tied appropriately, see hscIncrementalCompile -genModDetails :: HscEnv -> ModIface -> IO ModDetails -genModDetails hsc_env old_iface - = do - new_details <- {-# SCC "tcRnIface" #-} - initIfaceLoad hsc_env (typecheckIface old_iface) - dumpIfaceStats hsc_env - return new_details - --------------------------------------------------------------- --- Progress displayers. --------------------------------------------------------------- - -oneShotMsg :: HscEnv -> RecompileRequired -> IO () -oneShotMsg hsc_env recomp = - case recomp of - UpToDate -> - compilationProgressMsg (hsc_dflags hsc_env) $ - "compilation IS NOT required" - _ -> - return () - -batchMsg :: Messager -batchMsg hsc_env mod_index recomp mod_summary = - case recomp of - MustCompile -> showMsg "Compiling " "" - UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" - | otherwise -> return () - RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") - where - dflags = hsc_dflags hsc_env - showMsg msg reason = - compilationProgressMsg dflags $ - (showModuleIndex mod_index ++ - msg ++ showModMsg dflags (hscTarget dflags) - (recompileRequired recomp) mod_summary) - ++ reason - --------------------------------------------------------------- --- FrontEnds --------------------------------------------------------------- - --- | Given a 'ModSummary', parses and typechecks it, returning the --- 'TcGblEnv' resulting from type-checking. -hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv -hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing - --------------------------------------------------------------- --- Safe Haskell --------------------------------------------------------------- - --- Note [Safe Haskell Trust Check] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Safe Haskell checks that an import is trusted according to the following --- rules for an import of module M that resides in Package P: --- --- * If M is recorded as Safe and all its trust dependencies are OK --- then M is considered safe. --- * If M is recorded as Trustworthy and P is considered trusted and --- all M's trust dependencies are OK then M is considered safe. --- --- By trust dependencies we mean that the check is transitive. So if --- a module M that is Safe relies on a module N that is trustworthy, --- importing module M will first check (according to the second case) --- that N is trusted before checking M is trusted. --- --- This is a minimal description, so please refer to the user guide --- for more details. The user guide is also considered the authoritative --- source in this matter, not the comments or code. - - --- Note [Safe Haskell Inference] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Safe Haskell does Safe inference on modules that don't have any specific --- safe haskell mode flag. The basic approach to this is: --- * When deciding if we need to do a Safe language check, treat --- an unmarked module as having -XSafe mode specified. --- * For checks, don't throw errors but return them to the caller. --- * Caller checks if there are errors: --- * For modules explicitly marked -XSafe, we throw the errors. --- * For unmarked modules (inference mode), we drop the errors --- and mark the module as being Unsafe. --- --- It used to be that we only did safe inference on modules that had no Safe --- Haskell flags, but now we perform safe inference on all modules as we want --- to allow users to set the `-Wsafe`, `-Wunsafe` and --- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a --- user can ensure their assumptions are correct and see reasons for why a --- module is safe or unsafe. --- --- This is tricky as we must be careful when we should throw an error compared --- to just warnings. For checking safe imports we manage it as two steps. First --- we check any imports that are required to be safe, then we check all other --- imports to see if we can infer them to be safe. - - --- | Check that the safe imports of the module being compiled are valid. --- If not we either issue a compilation error if the module is explicitly --- using Safe Haskell, or mark the module as unsafe if we're in safe --- inference mode. -hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv -hscCheckSafeImports tcg_env = do - dflags <- getDynFlags - tcg_env' <- checkSafeImports tcg_env - checkRULES dflags tcg_env' - - where - checkRULES dflags tcg_env' = do - case safeLanguageOn dflags of - True -> do - -- XSafe: we nuke user written RULES - logWarnings $ warns dflags (tcg_rules tcg_env') - return tcg_env' { tcg_rules = [] } - False - -- SafeInferred: user defined RULES, so not safe - | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') - - -- Trustworthy OR SafeInferred: with no RULES - | otherwise - -> return tcg_env' - - warns dflags rules = listToBag $ map (warnRules dflags) rules - - warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg - warnRules dflags (L loc (HsRule { rd_name = n })) = - mkPlainWarnMsg dflags loc $ - text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ - text "User defined rules are disabled under Safe Haskell" - warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec - --- | Validate that safe imported modules are actually safe. For modules in the --- HomePackage (the package the module we are compiling in resides) this just --- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules --- that reside in another package we also must check that the external package --- is trusted. See the Note [Safe Haskell Trust Check] above for more --- information. --- --- The code for this is quite tricky as the whole algorithm is done in a few --- distinct phases in different parts of the code base. See --- RnNames.rnImportDecl for where package trust dependencies for a module are --- collected and unioned. Specifically see the Note [RnNames . Tracking Trust --- Transitively] and the Note [RnNames . Trust Own Package]. -checkSafeImports :: TcGblEnv -> Hsc TcGblEnv -checkSafeImports tcg_env - = do - dflags <- getDynFlags - imps <- mapM condense imports' - let (safeImps, regImps) = partition (\(_,_,s) -> s) imps - - -- We want to use the warning state specifically for detecting if safe - -- inference has failed, so store and clear any existing warnings. - oldErrs <- getWarnings - clearWarnings - - -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps - safeErrs <- getWarnings - clearWarnings - - -- Check non-safe imports are correct if inferring safety - -- See the Note [Safe Haskell Inference] - (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyBag, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps - infErrs <- getWarnings - clearWarnings - return (infErrs, infPkgs) - - -- restore old errors - logWarnings oldErrs - - case (isEmptyBag safeErrs) of - -- Failed safe check - False -> liftIO . throwIO . mkSrcErr $ safeErrs - - -- Passed safe check - True -> do - let infPassed = isEmptyBag infErrs - tcg_env' <- case (not infPassed) of - True -> markUnsafeInfer tcg_env infErrs - False -> return tcg_env - when (packageTrustOn dflags) $ checkPkgTrust pkgReqs - let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed - return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } - - where - impInfo = tcg_imports tcg_env -- ImportAvails - imports = imp_mods impInfo -- ImportedMods - imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) - imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) - pkgReqs = imp_trust_pkgs impInfo -- [UnitId] - - condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) - condense (_, []) = panic "HscMain.condense: Pattern match failure!" - condense (m, x:xs) = do imv <- foldlM cond' x xs - return (m, imv_span imv, imv_is_safe imv) - - -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) - cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal - cond' v1 v2 - | imv_is_safe v1 /= imv_is_safe v2 - = do - dflags <- getDynFlags - throwOneError $ mkPlainErrMsg dflags (imv_span v1) - (text "Module" <+> ppr (imv_name v1) <+> - (text $ "is imported both as a safe and unsafe import!")) - | otherwise - = return v1 - - -- easier interface to work with - checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId) - checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l - - -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId -> - Bool -> ImportAvails - pkgTrustReqs dflags req inf infPassed | safeInferOn dflags - && not (safeHaskellModeEnabled dflags) && infPassed - = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf - } - pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe - = emptyImportAvails - pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } - --- | Check that a module is safe to import. --- --- We return True to indicate the import is safe and False otherwise --- although in the False case an exception may be thrown first. -hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool -hscCheckSafe hsc_env m l = runHsc hsc_env $ do - dflags <- getDynFlags - pkgs <- snd `fmap` hscCheckSafe' m l - when (packageTrustOn dflags) $ checkPkgTrust pkgs - errs <- getWarnings - return $ isEmptyBag errs - --- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId) -hscGetSafe hsc_env m l = runHsc hsc_env $ do - (self, pkgs) <- hscCheckSafe' m l - good <- isEmptyBag `fmap` getWarnings - clearWarnings -- don't want them printed... - let pkgs' | Just p <- self = S.insert p pkgs - | otherwise = pkgs - return (good, pkgs') - --- | Is a module trusted? If not, throw or log errors depending on the type. --- Return (regardless of trusted or not) if the trust type requires the modules --- own package be trusted and a list of other packages required to be trusted --- (these later ones haven't been checked) but the own package trust has been. -hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId) -hscCheckSafe' m l = do - dflags <- getDynFlags - (tw, pkgs) <- isModSafe m l - case tw of - False -> return (Nothing, pkgs) - True | isHomePkg dflags m -> return (Nothing, pkgs) - -- TODO: do we also have to check the trust of the instantiation? - -- Not necessary if that is reflected in dependencies - | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs) - where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId) - isModSafe m l = do - dflags <- getDynFlags - iface <- lookup' m - case iface of - -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainErrMsg dflags l - $ text "Can't load the interface file for" <+> ppr m - <> text ", to check that it can be safely imported" - - -- got iface, check trust - Just iface' -> - let trust = getSafeMode $ mi_trust iface' - trust_own_pkg = mi_trust_pkg iface' - -- check module is trusted - safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] - -- check package is trusted - safeP = packageTrusted dflags trust trust_own_pkg m - -- pkg trust reqs - pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' - -- warn if Safe module imports Safe-Inferred module. - warns = if wopt Opt_WarnInferredSafeImports dflags - && safeLanguageOn dflags - && trust == Sf_SafeInferred - then inferredImportWarn - else emptyBag - -- General errors we throw but Safe errors we log - errs = case (safeM, safeP) of - (True, True ) -> emptyBag - (True, False) -> pkgTrustErr - (False, _ ) -> modTrustErr - in do - logWarnings warns - logWarnings errs - return (trust == Sf_Trustworthy, pkgRs) - - where - inferredImportWarn = unitBag - $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) - $ mkWarnMsg dflags l (pkgQual dflags) - $ sep - [ text "Importing Safe-Inferred module " - <> ppr (moduleName m) - <> text " from explicitly Safe module" - ] - pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ - sep [ ppr (moduleName m) - <> text ": Can't be safely imported!" - , text "The package (" <> ppr (moduleUnitId m) - <> text ") the module resides in isn't trusted." - ] - modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ - sep [ ppr (moduleName m) - <> text ": Can't be safely imported!" - , text "The module itself isn't safe." ] - - -- | Check the package a module resides in is trusted. Safe compiled - -- modules are trusted without requiring that their package is trusted. For - -- trustworthy modules, modules in the home package are trusted but - -- otherwise we check the package trust flag. - packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted _ Sf_None _ _ = False -- shouldn't hit these cases - packageTrusted _ Sf_Ignore _ _ = False -- shouldn't hit these cases - packageTrusted _ Sf_Unsafe _ _ = False -- prefer for completeness. - packageTrusted dflags _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted _ Sf_Safe False _ = True - packageTrusted _ Sf_SafeInferred False _ = True - packageTrusted dflags _ _ m - | isHomePkg dflags m = True - | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) - - lookup' :: Module -> Hsc (Maybe ModIface) - lookup' m = do - hsc_env <- getHscEnv - hsc_eps <- liftIO $ hscEPS hsc_env - let pkgIfaceT = eps_PIT hsc_eps - homePkgT = hsc_HPT hsc_env - iface = lookupIfaceByModule homePkgT pkgIfaceT m - -- the 'lookupIfaceByModule' method will always fail when calling from GHCi - -- as the compiler hasn't filled in the various module tables - -- so we need to call 'getModuleInterface' to load from disk - iface' <- case iface of - Just _ -> return iface - Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) - return iface' - - - isHomePkg :: DynFlags -> Module -> Bool - isHomePkg dflags m - | thisPackage dflags == moduleUnitId m = True - | otherwise = False - --- | Check the list of packages are trusted. -checkPkgTrust :: Set InstalledUnitId -> Hsc () -checkPkgTrust pkgs = do - dflags <- getDynFlags - let errors = S.foldr go [] pkgs - go pkg acc - | trusted $ getInstalledPackageDetails dflags pkg - = acc - | otherwise - = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags) - $ text "The package (" <> ppr pkg <> text ") is required" <> - text " to be trusted but it isn't!" - case errors of - [] -> return () - _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors - --- | Set module to unsafe and (potentially) wipe trust information. --- --- Make sure to call this method to set a module to inferred unsafe, it should --- be a central and single failure method. We only wipe the trust information --- when we aren't in a specific Safe Haskell mode. --- --- While we only use this for recording that a module was inferred unsafe, we --- may call it on modules using Trustworthy or Unsafe flags so as to allow --- warning flags for safety to function correctly. See Note [Safe Haskell --- Inference]. -markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv -markUnsafeInfer tcg_env whyUnsafe = do - dflags <- getDynFlags - - when (wopt Opt_WarnUnsafe dflags) - (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ - mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) - - liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) - -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other - -- times inference may be on but we are in Trustworthy mode -- so we want - -- to record safe-inference failed but not wipe the trust dependencies. - case not (safeHaskellModeEnabled dflags) of - True -> return $ tcg_env { tcg_imports = wiped_trust } - False -> return tcg_env - - where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } - pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" - , text "Reason:" - , nest 4 $ (vcat $ badFlags df) $+$ - (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$ - (vcat $ badInsts $ tcg_insts tcg_env) - ] - badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer - badFlag df (str,loc,on,_) - | on df = [mkLocMessage SevOutput (loc df) $ - text str <+> text "is not allowed in Safe Haskell"] - | otherwise = [] - badInsts insts = concat $ map badInst insts - - checkOverlap (NoOverlap _) = False - checkOverlap _ = True - - badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ - ppr (overlapMode $ is_flag ins) <+> - text "overlap mode isn't allowed in Safe Haskell"] - | otherwise = [] - - --- | Figure out the final correct safe haskell mode -hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode -hscGetSafeMode tcg_env = do - dflags <- getDynFlags - liftIO $ finalSafeMode dflags tcg_env - --------------------------------------------------------------- --- Simplifiers --------------------------------------------------------------- - -hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts -hscSimplify hsc_env plugins modguts = - runHsc hsc_env $ hscSimplify' plugins modguts - -hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts -hscSimplify' plugins ds_result = do - hsc_env <- getHscEnv - let hsc_env_with_plugins = hsc_env - { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins - } - {-# SCC "Core2Core" #-} - liftIO $ core2core hsc_env_with_plugins ds_result - --------------------------------------------------------------- --- Interface generators --------------------------------------------------------------- - --- | Generate a striped down interface file, e.g. for boot files or when ghci --- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] -hscSimpleIface :: HscEnv - -> TcGblEnv - -> Maybe Fingerprint - -> IO (ModIface, Maybe Fingerprint, ModDetails) -hscSimpleIface hsc_env tc_result mb_old_iface - = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface - -hscSimpleIface' :: TcGblEnv - -> Maybe Fingerprint - -> Hsc (ModIface, Maybe Fingerprint, ModDetails) -hscSimpleIface' tc_result mb_old_iface = do - hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result - safe_mode <- hscGetSafeMode tc_result - new_iface - <- {-# SCC "MkFinalIface" #-} - liftIO $ - mkIfaceTc hsc_env safe_mode details tc_result - -- And the answer is ... - liftIO $ dumpIfaceStats hsc_env - return (new_iface, mb_old_iface, details) - --------------------------------------------------------------- --- BackEnd combinators --------------------------------------------------------------- -{- -Note [Interface filename extensions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -ModLocation only contains the base names, however when generating dynamic files -the actual extension might differ from the default. - -So we only load the base name from ModLocation and replace the actual extension -according to the information in DynFlags. - -If we generate a interface file right after running the core pipeline we will -have set -dynamic-too and potentially generate both interface files at the same -time. - -If we generate a interface file after running the backend then dynamic-too won't -be set, however then the extension will be contained in the dynflags instead so -things still work out fine. --} - -hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO () -hscWriteIface dflags iface no_change mod_location = do - -- mod_location only contains the base name, so we rebuild the - -- correct file extension from the dynflags. - let ifaceBaseFile = ml_hi_file mod_location - unless no_change $ - let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags) - in {-# SCC "writeIface" #-} - writeIfaceFile dflags ifaceFile iface - whenGeneratingDynamicToo dflags $ do - -- TODO: We should do a no_change check for the dynamic - -- interface file too - -- When we generate iface files after core - let dynDflags = dynamicTooMkDynamicDynFlags dflags - -- dynDflags will have set hiSuf correctly. - dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags) - - writeIfaceFile dynDflags dynIfaceFile iface - where - buildIfName :: String -> String -> String - buildIfName baseName suffix - | Just name <- outputHi dflags - = name - | otherwise - = let with_hi = replaceExtension baseName suffix - in addBootSuffix_maybe (mi_boot iface) with_hi - --- | Compile to hard-code. -hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)]) - -- ^ @Just f@ <=> _stub.c is f -hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info } = cgguts - dflags = hsc_dflags hsc_env - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes - - ------------------- - -- PREPARE FOR CODE GENERATION - -- Do saturation and convert to A-normal form - (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env this_mod location - core_binds data_tycons - ----------------- Convert to STG ------------------ - (stg_binds, (caf_ccs, caf_cc_stacks)) - <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags this_mod prepd_binds - - let cost_centre_info = - (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) - prof_init = profilingInitCode this_mod cost_centre_info - foreign_stubs = foreign_stubs0 `appendStubC` prof_init - - ------------------ Code generation ------------------ - - -- The back-end is streamed: each top-level function goes - -- from Stg all the way to asm before dealing with the next - -- top-level function, so showPass isn't very useful here. - -- Hence we have one showPass for the whole backend, the - -- next showPass after this will be "Assembler". - withTiming dflags - (text "CodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod data_tycons - cost_centre_info - stg_binds hpc_info - - ------------------ Code output ----------------------- - rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - cmmToRawCmm dflags cmms - - let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" - (ppr a) - return a - rawcmms1 = Stream.mapM dump rawcmms0 - - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ()) - <- {-# SCC "codeOutput" #-} - codeOutput dflags this_mod output_filename location - foreign_stubs foreign_files dependencies rawcmms1 - return (output_filename, stub_c_exists, foreign_fps) - - -hscInteractive :: HscEnv - -> CgGuts - -> ModLocation - -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) -hscInteractive hsc_env cgguts location = do - let dflags = hsc_dflags hsc_env - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_foreign = foreign_stubs, - cg_modBreaks = mod_breaks, - cg_spt_entries = spt_entries } = cgguts - - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes - - ------------------- - -- PREPARE FOR CODE GENERATION - -- Do saturation and convert to A-normal form - (prepd_binds, _) <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env this_mod location core_binds data_tycons - ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks - ------------------ Create f-x-dynamic C-side stuff ----- - (_istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags this_mod location foreign_stubs - return (istub_c_exists, comp_bc, spt_entries) - ------------------------------- - -hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () -hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do - let dflags = hsc_dflags hsc_env - cmm <- ioMsgMaybe $ parseCmmFile dflags filename - liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" (ppr cmm) - let -- Make up a module name to give the NCG. We can't pass bottom here - -- lest we reproduce #11784. - mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename - cmm_mod = mkModule (thisPackage dflags) mod_name - (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm - dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup) - rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) - _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] - rawCmms - return () - where - no_loc = ModLocation{ ml_hs_file = Just filename, - ml_hi_file = panic "hscCompileCmmFile: no hi file", - ml_obj_file = panic "hscCompileCmmFile: no obj file", - ml_hie_file = panic "hscCompileCmmFile: no hie file"} - --------------------- Stuff for new code gen --------------------- - -doCodeGen :: HscEnv -> Module -> [TyCon] - -> CollectedCCs - -> [StgTopBinding] - -> HpcInfo - -> IO (Stream IO CmmGroup ()) - -- Note we produce a 'Stream' of CmmGroups, so that the - -- backend can be run incrementally. Otherwise it generates all - -- the C-- up front, which has a significant space cost. -doCodeGen hsc_env this_mod data_tycons - cost_centre_info stg_binds hpc_info = do - let dflags = hsc_dflags hsc_env - - let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds - - let cmm_stream :: Stream IO CmmGroup () - cmm_stream = {-# SCC "StgToCmm" #-} - StgToCmm.codeGen dflags this_mod data_tycons - cost_centre_info stg_binds_w_fvs hpc_info - - -- codegen consumes a stream of CmmGroup, and produces a new - -- stream of CmmGroup (not necessarily synchronised: one - -- CmmGroup on input may produce many CmmGroups on output due - -- to proc-point splitting). - - let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg - "Cmm produced by codegen" (ppr a) - return a - - ppr_stream1 = Stream.mapM dump1 cmm_stream - - pipeline_stream - = {-# SCC "cmmPipeline" #-} - let run_pipeline = cmmPipeline hsc_env - in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 - - dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm - "Output Cmm" (ppr a) - return a - - ppr_stream2 = Stream.mapM dump2 pipeline_stream - - return ppr_stream2 - - - -myCoreToStg :: DynFlags -> Module -> CoreProgram - -> IO ( [StgTopBinding] -- output program - , CollectedCCs ) -- CAF cost centre info (declared and used) -myCoreToStg dflags this_mod prepd_binds = do - let (stg_binds, cost_centre_info) - = {-# SCC "Core2Stg" #-} - coreToStg dflags this_mod prepd_binds - - stg_binds2 - <- {-# SCC "Stg2Stg" #-} - stg2stg dflags this_mod stg_binds - - return (stg_binds2, cost_centre_info) - - -{- ********************************************************************** -%* * -\subsection{Compiling a do-statement} -%* * -%********************************************************************* -} - -{- -When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When -you run it you get a list of HValues that should be the same length as the list -of names; add them to the ClosureEnv. - -A naked expression returns a singleton Name [it]. The stmt is lifted into the -IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes --} - --- | Compile a stmt all the way to an HValue, but don't run it --- --- We return Nothing to indicate an empty statement (or comment only), not a --- parse error. -hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) -hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 - --- | Compile a stmt all the way to an HValue, but don't run it --- --- We return Nothing to indicate an empty statement (or comment only), not a --- parse error. -hscStmtWithLocation :: HscEnv - -> String -- ^ The statement - -> String -- ^ The source - -> Int -- ^ Starting line - -> IO ( Maybe ([Id] - , ForeignHValue {- IO [HValue] -} - , FixityEnv)) -hscStmtWithLocation hsc_env0 stmt source linenumber = - runInteractiveHsc hsc_env0 $ do - maybe_stmt <- hscParseStmtWithLocation source linenumber stmt - case maybe_stmt of - Nothing -> return Nothing - - Just parsed_stmt -> do - hsc_env <- getHscEnv - liftIO $ hscParsedStmt hsc_env parsed_stmt - -hscParsedStmt :: HscEnv - -> GhciLStmt GhcPs -- ^ The parsed statement - -> IO ( Maybe ([Id] - , ForeignHValue {- IO [HValue] -} - , FixityEnv)) -hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do - -- Rename and typecheck it - (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt - - -- Desugar it - ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr - liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) - handleWarnings - - -- Then code-gen, and link it - -- It's important NOT to have package 'interactive' as thisUnitId - -- for linking, else we try to link 'main' and can't find it. - -- Whereas the linker already knows to ignore 'interactive' - let src_span = srcLocSpan interactiveSrcLoc - hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr - - return $ Just (ids, hval, fix_env) - --- | Compile a decls -hscDecls :: HscEnv - -> String -- ^ The statement - -> IO ([TyThing], InteractiveContext) -hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "" 1 - -hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs] -hscParseDeclsWithLocation hsc_env source line_num str = do - L _ (HsModule{ hsmodDecls = decls }) <- - runInteractiveHsc hsc_env $ - hscParseThingWithLocation source line_num parseModule str - return decls - --- | Compile a decls -hscDeclsWithLocation :: HscEnv - -> String -- ^ The statement - -> String -- ^ The source - -> Int -- ^ Starting line - -> IO ([TyThing], InteractiveContext) -hscDeclsWithLocation hsc_env str source linenumber = do - L _ (HsModule{ hsmodDecls = decls }) <- - runInteractiveHsc hsc_env $ - hscParseThingWithLocation source linenumber parseModule str - hscParsedDecls hsc_env decls - -hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) -hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do - {- Rename and typecheck it -} - hsc_env <- getHscEnv - tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls - - {- Grab the new instances -} - -- We grab the whole environment because of the overlapping that may have - -- been done. See the notes at the definition of InteractiveContext - -- (ic_instances) for more details. - let defaults = tcg_default tc_gblenv - - {- Desugar it -} - -- We use a basically null location for iNTERACTIVE - let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, - ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", - ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file", - ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" } - ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv - - {- Simplify -} - simpl_mg <- liftIO $ do - plugins <- readIORef (tcg_th_coreplugins tc_gblenv) - hscSimplify hsc_env plugins ds_result - - {- Tidy -} - (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg - - let !CgGuts{ cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_modBreaks = mod_breaks } = tidy_cg - - !ModDetails { md_insts = cls_insts - , md_fam_insts = fam_insts } = mod_details - -- Get the *tidied* cls_insts and fam_insts - - data_tycons = filter isDataTyCon tycons - - {- Prepare For Code Generation -} - -- Do saturation and convert to A-normal form - (prepd_binds, _) <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons - - {- Generate byte code -} - cbc <- liftIO $ byteCodeGen hsc_env this_mod - prepd_binds data_tycons mod_breaks - - let src_span = srcLocSpan interactiveSrcLoc - liftIO $ linkDecls hsc_env src_span cbc - - {- Load static pointer table entries -} - liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) - - let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) - patsyns = mg_patsyns simpl_mg - - ext_ids = [ id | id <- bindersOfBinds core_binds - , isExternalName (idName id) - , not (isDFunId id || isImplicitId id) ] - -- We only need to keep around the external bindings - -- (as decided by TidyPgm), since those are the only ones - -- that might later be looked up by name. But we can exclude - -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes - -- - Implicit Ids, which are implicit in tcs - -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv - - new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns - ictxt = hsc_IC hsc_env - -- See Note [Fixity declarations in GHCi] - fix_env = tcg_fix_env tc_gblenv - new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts - fam_insts defaults fix_env - return (new_tythings, new_ictxt) - --- | Load the given static-pointer table entries into the interpreter. --- See Note [Grand plan for static forms] in StaticPtrTable. -hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () -hscAddSptEntries hsc_env entries = do - let add_spt_entry :: SptEntry -> IO () - add_spt_entry (SptEntry i fpr) = do - val <- getHValue hsc_env (idName i) - addSptEntry hsc_env fpr val - mapM_ add_spt_entry entries - -{- - Note [Fixity declarations in GHCi] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - To support fixity declarations on types defined within GHCi (as requested - in #10018) we record the fixity environment in InteractiveContext. - When we want to evaluate something TcRnDriver.runTcInteractive pulls out this - fixity environment and uses it to initialize the global typechecker environment. - After the typechecker has finished its business, an updated fixity environment - (reflecting whatever fixity declarations were present in the statements we - passed it) will be returned from hscParsedStmt. This is passed to - updateFixityEnv, which will stuff it back into InteractiveContext, to be - used in evaluating the next statement. - --} - -hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) -hscImport hsc_env str = runInteractiveHsc hsc_env $ do - (L _ (HsModule{hsmodImports=is})) <- - hscParseThing parseModule str - case is of - [L _ i] -> return i - _ -> liftIO $ throwOneError $ - mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ - text "parse error in import declaration" - --- | Typecheck an expression (but don't run it) -hscTcExpr :: HscEnv - -> TcRnExprMode - -> String -- ^ The expression - -> IO Type -hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - parsed_expr <- hscParseExpr expr - ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr - --- | Find the kind of a type, after generalisation -hscKcType - :: HscEnv - -> Bool -- ^ Normalise the type - -> String -- ^ The type as a string - -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind -hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ty <- hscParseType str - ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty - -hscParseExpr :: String -> Hsc (LHsExpr GhcPs) -hscParseExpr expr = do - hsc_env <- getHscEnv - maybe_stmt <- hscParseStmt expr - case maybe_stmt of - Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan - (text "not an expression:" <+> quotes (text expr)) - -hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) -hscParseStmt = hscParseThing parseStmt - -hscParseStmtWithLocation :: String -> Int -> String - -> Hsc (Maybe (GhciLStmt GhcPs)) -hscParseStmtWithLocation source linenumber stmt = - hscParseThingWithLocation source linenumber parseStmt stmt - -hscParseType :: String -> Hsc (LHsType GhcPs) -hscParseType = hscParseThing parseType - -hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) -hscParseIdentifier hsc_env str = - runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str - -hscParseThing :: (Outputable thing, Data thing) - => Lexer.P thing -> String -> Hsc thing -hscParseThing = hscParseThingWithLocation "" 1 - -hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int - -> Lexer.P thing -> String -> Hsc thing -hscParseThingWithLocation source linenumber parser str - = withTimingD - (text "Parser [source]") - (const ()) $ {-# SCC "Parser" #-} do - dflags <- getDynFlags - - let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 - - case unP parser (mkPState dflags buf loc) of - PFailed pst -> do - handleWarningsThrowErrors (getMessages pst dflags) - - POk pst thing -> do - logWarningsReportErrors (getMessages pst dflags) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - showAstData NoBlankSrcSpan thing - return thing - - -{- ********************************************************************** -%* * - Desugar, simplify, convert to bytecode, and link an expression -%* * -%********************************************************************* -} - -hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue -hscCompileCoreExpr hsc_env = - lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env - -hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue -hscCompileCoreExpr' hsc_env srcspan ds_expr - = do { let dflags = hsc_dflags hsc_env - - {- Simplify it -} - ; simpl_expr <- simplifyExpr dflags ds_expr - - {- Tidy it (temporary, until coreSat does cloning) -} - ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr - - {- Prepare for codegen -} - ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr - - {- Lint if necessary -} - ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr - - {- Convert to BCOs -} - ; bcos <- coreExprToBCOs hsc_env - (icInteractiveModule (hsc_IC hsc_env)) prepd_expr - - {- link it -} - ; hval <- linkExpr hsc_env srcspan bcos - - ; return hval } - - -{- ********************************************************************** -%* * - Statistics on reading interfaces -%* * -%********************************************************************* -} - -dumpIfaceStats :: HscEnv -> IO () -dumpIfaceStats hsc_env = do - eps <- readIORef (hsc_EPS hsc_env) - dumpIfSet dflags (dump_if_trace || dump_rn_stats) - "Interface statistics" - (ifaceStats eps) - where - dflags = hsc_dflags hsc_env - dump_rn_stats = dopt Opt_D_dump_rn_stats dflags - dump_if_trace = dopt Opt_D_dump_if_trace dflags - - -{- ********************************************************************** -%* * - Progress Messages: Module i of n -%* * -%********************************************************************* -} - -showModuleIndex :: (Int, Int) -> String -showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] " - where - n_str = show n - i_str = show i - padded = replicate (length n_str - length i_str) ' ' ++ i_str diff --git a/main/HscStats.hs b/main/HscStats.hs deleted file mode 100644 --- a/main/HscStats.hs +++ /dev/null @@ -1,190 +0,0 @@ --- | --- Statistics for per-module compilations --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --- - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module HscStats ( ppSourceStats ) where - -import GhcPrelude - -import Bag -import GHC.Hs -import Outputable -import SrcLoc -import Util - -import Data.Char - --- | Source Statistics -ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc -ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) - = (if short then hcat else vcat) - (map pp_val - [("ExportAll ", export_all), -- 1 if no export list - ("ExportDecls ", export_ds), - ("ExportModules ", export_ms), - ("Imports ", imp_no), - (" ImpSafe ", imp_safe), - (" ImpQual ", imp_qual), - (" ImpAs ", imp_as), - (" ImpAll ", imp_all), - (" ImpPartial ", imp_partial), - (" ImpHiding ", imp_hiding), - ("FixityDecls ", fixity_sigs), - ("DefaultDecls ", default_ds), - ("TypeDecls ", type_ds), - ("DataDecls ", data_ds), - ("NewTypeDecls ", newt_ds), - ("TypeFamilyDecls ", type_fam_ds), - ("DataConstrs ", data_constrs), - ("DataDerivings ", data_derivs), - ("ClassDecls ", class_ds), - ("ClassMethods ", class_method_ds), - ("DefaultMethods ", default_method_ds), - ("InstDecls ", inst_ds), - ("InstMethods ", inst_method_ds), - ("InstType ", inst_type_ds), - ("InstData ", inst_data_ds), - ("TypeSigs ", bind_tys), - ("ClassOpSigs ", generic_sigs), - ("ValBinds ", val_bind_ds), - ("FunBinds ", fn_bind_ds), - ("PatSynBinds ", patsyn_ds), - ("InlineMeths ", method_inlines), - ("InlineBinds ", bind_inlines), - ("SpecialisedMeths ", method_specs), - ("SpecialisedBinds ", bind_specs) - ]) - where - decls = map unLoc ldecls - - pp_val (_, 0) = empty - pp_val (str, n) - | not short = hcat [text str, int n] - | otherwise = hcat [text (trim str), equals, int n, semi] - - trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - - (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) - = count_sigs [d | SigD _ d <- decls] - -- NB: this omits fixity decls on local bindings and - -- in class decls. ToDo - - tycl_decls = [d | TyClD _ d <- decls] - (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = - countTyClDecls tycl_decls - - inst_decls = [d | InstD _ d <- decls] - inst_ds = length inst_decls - default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls - val_decls = [d | ValD _ d <- decls] - - real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es } - n_exports = length real_exports - export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True - ; _ -> False}) - real_exports - export_ds = n_exports - export_ms - export_all = case exports of { Nothing -> 1; _ -> 0 } - - (val_bind_ds, fn_bind_ds, patsyn_ds) - = sum3 (map count_bind val_decls) - - (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) - = sum7 (map import_info imports) - (data_constrs, data_derivs) - = sum2 (map data_info tycl_decls) - (class_method_ds, default_method_ds) - = sum2 (map class_info tycl_decls) - (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) - = sum5 (map inst_info inst_decls) - - count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0) - count_bind (PatBind {}) = (0,1,0) - count_bind (FunBind {}) = (0,1,0) - count_bind (PatSynBind {}) = (0,0,1) - count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) - - count_sigs sigs = sum5 (map sig_info sigs) - - sig_info (FixSig {}) = (1,0,0,0,0) - sig_info (TypeSig {}) = (0,1,0,0,0) - sig_info (SpecSig {}) = (0,0,1,0,0) - sig_info (InlineSig {}) = (0,0,0,1,0) - sig_info (ClassOpSig {}) = (0,0,0,0,1) - sig_info _ = (0,0,0,0,0) - - import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual - , ideclAs = as, ideclHiding = spec })) - = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) - import_info (dL->L _ (XImportDecl nec)) = noExtCon nec - import_info _ = panic " import_info: Impossible Match" - -- due to #15884 - - safe_info False = 0 - safe_info True = 1 - qual_info NotQualified = 0 - qual_info _ = 1 - as_info Nothing = 0 - as_info (Just _) = 1 - spec_info Nothing = (0,0,0,0,1,0,0) - spec_info (Just (False, _)) = (0,0,0,0,0,1,0) - spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - - data_info (DataDecl { tcdDataDefn = HsDataDefn - { dd_cons = cs - , dd_derivs = (dL->L _ derivs)}}) - = ( length cs - , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) - 0 derivs ) - data_info _ = (0,0) - - class_info decl@(ClassDecl {}) - = (classops, addpr (sum3 (map count_bind methods))) - where - methods = map unLoc $ bagToList (tcdMeths decl) - (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) - class_info _ = (0,0) - - inst_info (TyFamInstD {}) = (0,0,0,1,0) - inst_info (DataFamInstD {}) = (0,0,0,0,1) - inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths - , cid_sigs = inst_sigs - , cid_tyfam_insts = ats - , cid_datafam_insts = adts } }) - = case count_sigs (map unLoc inst_sigs) of - (_,_,ss,is,_) -> - (addpr (sum3 (map count_bind methods)), - ss, is, length ats, length adts) - where - methods = map unLoc $ bagToList inst_meths - inst_info (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec - inst_info (XInstDecl nec) = noExtCon nec - - -- TODO: use Sum monoid - addpr :: (Int,Int,Int) -> Int - sum2 :: [(Int, Int)] -> (Int, Int) - sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) - sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) - sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) - add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) - -> (Int, Int, Int, Int, Int, Int, Int) - - addpr (x,y,z) = x+y+z - sum2 = foldr add2 (0,0) - where - add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) - sum3 = foldr add3 (0,0,0) - where - add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) - sum5 = foldr add5 (0,0,0,0,0) - where - add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) - sum7 = foldr add7 (0,0,0,0,0,0,0) - - add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) diff --git a/main/HscTypes.hs b/main/HscTypes.hs deleted file mode 100644 --- a/main/HscTypes.hs +++ /dev/null @@ -1,3260 +0,0 @@ -{- -(c) The University of Glasgow, 2006 - -\section[HscTypes]{Types for the per-module compiler} --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} - --- | Types for the per-module compiler -module HscTypes ( - -- * compilation state - HscEnv(..), hscEPS, - FinderCache, FindResult(..), InstalledFindResult(..), - Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, - HscStatus(..), - IServ(..), - - -- * ModuleGraph - ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG, - mgModSummaries, mgElemModule, mgLookupModule, - needsTemplateHaskellOrQQ, mgBootModules, - - -- * Hsc monad - Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc, - - -- * Information about modules - ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, - ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), - ForeignSrcLang(..), - phaseForeignLanguage, - - ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps, - home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary, - msHsFilePath, msHiFilePath, msObjFilePath, - SourceModified(..), isTemplateHaskellOrQQNonBoot, - - -- * Information about the module being compiled - -- (re-exported from DriverPhases) - HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, - - - -- * State relating to modules in this package - HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, - addToHpt, addListToHpt, lookupHptDirectly, listToHpt, - hptCompleteSigs, - hptInstances, hptRules, pprHPT, - - -- * State relating to known packages - ExternalPackageState(..), EpsStats(..), addEpsInStats, - PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule, - - PackageInstEnv, PackageFamInstEnv, PackageRuleBase, - PackageCompleteMatchMap, - - mkSOName, mkHsSOName, soExt, - - -- * Metaprogramming - MetaRequest(..), - MetaResult, -- data constructors not exported to ensure correct response type - metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, - MetaHook, - - -- * Annotations - prepareAnnotations, - - -- * Interactive context - InteractiveContext(..), emptyInteractiveContext, - icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, - extendInteractiveContext, extendInteractiveContextWithIds, - substInteractiveContext, - setInteractivePrintName, icInteractiveModule, - InteractiveImport(..), setInteractivePackage, - mkPrintUnqualified, pprModulePrefix, - mkQualPackage, mkQualModule, pkgQual, - - -- * Interfaces - ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..), - mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, - emptyIfaceWarnCache, mi_boot, mi_fix, - mi_semantic_module, - mi_free_holes, - renameFreeHoles, - - -- * Fixity - FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - - -- * TyThings and type environments - TyThing(..), tyThingAvailInfo, - tyThingTyCon, tyThingDataCon, tyThingConLike, - tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, - implicitTyThings, implicitTyConThings, implicitClassThings, - isImplicitTyThing, - - TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, - typeEnvFromEntities, mkTypeEnvWithImplicits, - extendTypeEnv, extendTypeEnvList, - extendTypeEnvWithIds, plusTypeEnv, - lookupTypeEnv, - typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, - typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, - - -- * MonadThings - MonadThings(..), - - -- * Information on imports and exports - WhetherHasOrphans, IsBootInterface, Usage(..), - Dependencies(..), noDependencies, - updNameCache, - IfaceExport, - - -- * Warnings - Warnings(..), WarningTxt(..), plusWarns, - - -- * Linker stuff - Linkable(..), isObjectLinkable, linkableObjs, - Unlinked(..), CompiledByteCode, - isObject, nameOfObject, isInterpretable, byteCodeOfObject, - - -- * Program coverage - HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, - - -- * Breakpoints - ModBreaks (..), emptyModBreaks, - - -- * Safe Haskell information - IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, - trustInfoToNum, numToTrustInfo, IsSafeImport, - - -- * result of the parser - HsParsedModule(..), - - -- * Compilation errors and warnings - SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, - throwOneError, throwErrors, handleSourceError, - handleFlagWarnings, printOrThrowWarnings, - - -- * COMPLETE signature - CompleteMatch(..), CompleteMatchMap, - mkCompleteMatchMap, extendCompleteMatchMap - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeTypes -import InteractiveEvalTypes ( Resume ) -import GHCi.Message ( Pipe ) -import GHCi.RemoteTypes -import GHC.ForeignSrcLang - -import UniqFM -import GHC.Hs -import RdrName -import Avail -import Module -import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) -import FamInstEnv -import CoreSyn ( CoreProgram, RuleBase, CoreRule ) -import Name -import NameEnv -import VarSet -import Var -import Id -import IdInfo ( IdDetails(..), RecSelParent(..)) -import Type - -import ApiAnnotation ( ApiAnns ) -import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import PatSyn -import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) -import TysWiredIn -import Packages hiding ( Version(..) ) -import CmdLineParser -import DynFlags -import LinkerTypes ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) -import DriverPhases ( Phase, HscSource(..), hscSourceString - , isHsBootOrSig, isHsigFile ) -import qualified DriverPhases as Phase -import BasicTypes -import IfaceSyn -import Maybes -import Outputable -import SrcLoc -import Unique -import UniqDFM -import FastString -import StringBuffer ( StringBuffer ) -import Fingerprint -import MonadUtils -import Bag -import Binary -import ErrUtils -import NameCache -import GHC.Platform -import Util -import UniqDSet -import GHC.Serialized ( Serialized ) -import qualified GHC.LanguageExtensions as LangExt - -import Foreign -import Control.Monad ( guard, liftM, ap ) -import Data.IORef -import Data.Time -import Exception -import System.FilePath -import Control.Concurrent -import System.Process ( ProcessHandle ) -import Control.DeepSeq - --- ----------------------------------------------------------------------------- --- Compilation state --- ----------------------------------------------------------------------------- - --- | Status of a compilation to hard-code -data HscStatus - -- | Nothing to do. - = HscNotGeneratingCode ModIface - -- | Nothing to do because code already exists. - | HscUpToDate ModIface - -- | Update boot file result. - | HscUpdateBoot ModIface - -- | Generate signature file (backpack) - | HscUpdateSig ModIface - -- | Recompile this module. - | HscRecomp - { hscs_guts :: CgGuts - -- ^ Information for the code generator. - , hscs_mod_location :: !ModLocation - -- ^ Module info - , hscs_partial_iface :: !PartialModIface - -- ^ Partial interface - , hscs_old_iface_hash :: !(Maybe Fingerprint) - -- ^ Old interface hash for this compilation, if an old interface file - -- exists. Pass to `hscMaybeWriteIface` when writing the interface to - -- avoid updating the existing interface when the interface isn't - -- changed. - , hscs_iface_dflags :: !DynFlags - -- ^ Generate final iface using this DynFlags. - -- FIXME (osa): I don't understand why this is necessary, but I spent - -- almost two days trying to figure this out and I couldn't .. perhaps - -- someone who understands this code better will remove this later. - } --- Should HscStatus contain the HomeModInfo? --- All places where we return a status we also return a HomeModInfo. - --- ----------------------------------------------------------------------------- --- The Hsc monad: Passing an environment and warning state - -newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) - deriving (Functor) - -instance Applicative Hsc where - pure a = Hsc $ \_ w -> return (a, w) - (<*>) = ap - -instance Monad Hsc where - Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w - case k a of - Hsc k' -> k' e w1 - -instance MonadIO Hsc where - liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) - -instance HasDynFlags Hsc where - getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) - -runHsc :: HscEnv -> Hsc a -> IO a -runHsc hsc_env (Hsc hsc) = do - (a, w) <- hsc hsc_env emptyBag - printOrThrowWarnings (hsc_dflags hsc_env) w - return a - -mkInteractiveHscEnv :: HscEnv -> HscEnv -mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags } - where - interactive_dflags = ic_dflags (hsc_IC hsc_env) - -runInteractiveHsc :: HscEnv -> Hsc a -> IO a --- A variant of runHsc that switches in the DynFlags from the --- InteractiveContext before running the Hsc computation. -runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) - --- ----------------------------------------------------------------------------- --- Source Errors - --- When the compiler (HscMain) discovers errors, it throws an --- exception in the IO monad. - -mkSrcErr :: ErrorMessages -> SourceError -mkSrcErr = SourceError - -srcErrorMessages :: SourceError -> ErrorMessages -srcErrorMessages (SourceError msgs) = msgs - -mkApiErr :: DynFlags -> SDoc -> GhcApiError -mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) - -throwErrors :: MonadIO io => ErrorMessages -> io a -throwErrors = liftIO . throwIO . mkSrcErr - -throwOneError :: MonadIO io => ErrMsg -> io a -throwOneError = throwErrors . unitBag - --- | A source error is an error that is caused by one or more errors in the --- source code. A 'SourceError' is thrown by many functions in the --- compilation pipeline. Inside GHC these errors are merely printed via --- 'log_action', but API clients may treat them differently, for example, --- insert them into a list box. If you want the default behaviour, use the --- idiom: --- --- > handleSourceError printExceptionAndWarnings $ do --- > ... api calls that may fail ... --- --- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. --- This list may be empty if the compiler failed due to @-Werror@ --- ('Opt_WarnIsError'). --- --- See 'printExceptionAndWarnings' for more information on what to take care --- of when writing a custom error handler. -newtype SourceError = SourceError ErrorMessages - -instance Show SourceError where - show (SourceError msgs) = unlines . map show . bagToList $ msgs - -instance Exception SourceError - --- | Perform the given action and call the exception handler if the action --- throws a 'SourceError'. See 'SourceError' for more information. -handleSourceError :: (ExceptionMonad m) => - (SourceError -> m a) -- ^ exception handler - -> m a -- ^ action to perform - -> m a -handleSourceError handler act = - gcatch act (\(e :: SourceError) -> handler e) - --- | An error thrown if the GHC API is used in an incorrect fashion. -newtype GhcApiError = GhcApiError String - -instance Show GhcApiError where - show (GhcApiError msg) = msg - -instance Exception GhcApiError - --- | Given a bag of warnings, turn them into an exception if --- -Werror is enabled, or print them out otherwise. -printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () -printOrThrowWarnings dflags warns = do - let (make_error, warns') = - mapAccumBagL - (\make_err warn -> - case isWarnMsgFatal dflags warn of - Nothing -> - (make_err, warn) - Just err_reason -> - (True, warn{ errMsgSeverity = SevError - , errMsgReason = ErrReason err_reason - })) - False warns - if make_error - then throwIO (mkSrcErr warns') - else printBagOfErrors dflags warns - -handleFlagWarnings :: DynFlags -> [Warn] -> IO () -handleFlagWarnings dflags warns = do - let warns' = filter (shouldPrintWarning dflags . warnReason) warns - - -- It would be nicer if warns :: [Located MsgDoc], but that - -- has circular import problems. - bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) - | Warn _ (dL->L loc warn) <- warns' ] - - printOrThrowWarnings dflags bag - --- Given a warn reason, check to see if it's associated -W opt is enabled -shouldPrintWarning :: DynFlags -> CmdLineParser.WarnReason -> Bool -shouldPrintWarning dflags ReasonDeprecatedFlag - = wopt Opt_WarnDeprecatedFlags dflags -shouldPrintWarning dflags ReasonUnrecognisedFlag - = wopt Opt_WarnUnrecognisedWarningFlags dflags -shouldPrintWarning _ _ - = True - -{- -************************************************************************ -* * -\subsection{HscEnv} -* * -************************************************************************ --} - --- | HscEnv is like 'Session', except that some of the fields are immutable. --- An HscEnv is used to compile a single module from plain Haskell source --- code (after preprocessing) to either C, assembly or C--. It's also used --- to store the dynamic linker state to allow for multiple linkers in the --- same address space. --- Things like the module graph don't change during a single compilation. --- --- Historical note: \"hsc\" used to be the name of the compiler binary, --- when there was a separate driver and compiler. To compile a single --- module, the driver would invoke hsc on the source code... so nowadays --- we think of hsc as the layer of the compiler that deals with compiling --- a single module. -data HscEnv - = HscEnv { - hsc_dflags :: DynFlags, - -- ^ The dynamic flag settings - - hsc_targets :: [Target], - -- ^ The targets (or roots) of the current session - - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - - hsc_IC :: InteractiveContext, - -- ^ The context for evaluating interactive statements - - hsc_HPT :: HomePackageTable, - -- ^ The home package table describes already-compiled - -- home-package modules, /excluding/ the module we - -- are compiling right now. - -- (In one-shot mode the current module is the only - -- home-package module, so hsc_HPT is empty. All other - -- modules count as \"external-package\" modules. - -- However, even in GHCi mode, hi-boot interfaces are - -- demand-loaded into the external-package table.) - -- - -- 'hsc_HPT' is not mutable because we only demand-load - -- external packages; the home package is eagerly - -- loaded, module by module, by the compilation manager. - -- - -- The HPT may contain modules compiled earlier by @--make@ - -- but not actually below the current module in the dependency - -- graph. - -- - -- (This changes a previous invariant: changed Jan 05.) - - hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), - -- ^ Information about the currently loaded external packages. - -- This is mutable because packages will be demand-loaded during - -- a compilation run as required. - - hsc_NC :: {-# UNPACK #-} !(IORef NameCache), - -- ^ As with 'hsc_EPS', this is side-effected by compiling to - -- reflect sucking in interface files. They cache the state of - -- external interface files, in effect. - - hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), - -- ^ The cached result of performing finding in the file system - - hsc_type_env_var :: Maybe (Module, IORef TypeEnv) - -- ^ Used for one-shot compilation only, to initialise - -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for - -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] - - , hsc_iserv :: MVar (Maybe IServ) - -- ^ interactive server process. Created the first - -- time it is needed. - - , hsc_dynLinker :: DynLinker - -- ^ dynamic linker. - - } - --- Note [hsc_type_env_var hack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- hsc_type_env_var is used to initialize tcg_type_env_var, and --- eventually it is the mutable variable that is queried from --- if_rec_types to get a TypeEnv. So, clearly, it's something --- related to knot-tying (see Note [Tying the knot]). --- hsc_type_env_var is used in two places: initTcRn (where --- it initializes tcg_type_env_var) and initIfaceCheck --- (where it initializes if_rec_types). --- --- But why do we need a way to feed a mutable variable in? Why --- can't we just initialize tcg_type_env_var when we start --- typechecking? The problem is we need to knot-tie the --- EPS, and we may start adding things to the EPS before type --- checking starts. --- --- Here is a concrete example. Suppose we are running --- "ghc -c A.hs", and we have this file system state: --- --- A.hs-boot A.hi-boot **up to date** --- B.hs B.hi **up to date** --- A.hs A.hi **stale** --- --- The first thing we do is run checkOldIface on A.hi. --- checkOldIface will call loadInterface on B.hi so it can --- get its hands on the fingerprints, to find out if A.hi --- needs recompilation. But loadInterface also populates --- the EPS! And so if compilation turns out to be necessary, --- as it is in this case, the thunks we put into the EPS for --- B.hi need to have the correct if_rec_types mutable variable --- to query. --- --- If the mutable variable is only allocated WHEN we start --- typechecking, then that's too late: we can't get the --- information to the thunks. So we need to pre-commit --- to a type variable in 'hscIncrementalCompile' BEFORE we --- check the old interface. --- --- This is all a massive hack because arguably checkOldIface --- should not populate the EPS. But that's a refactor for --- another day. - - -data IServ = IServ - { iservPipe :: Pipe - , iservProcess :: ProcessHandle - , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) - , iservPendingFrees :: [HValueRef] - } - --- | Retrieve the ExternalPackageState cache. -hscEPS :: HscEnv -> IO ExternalPackageState -hscEPS hsc_env = readIORef (hsc_EPS hsc_env) - --- | A compilation target. --- --- A target may be supplied with the actual text of the --- module. If so, use this instead of the file contents (this --- is for use in an IDE where the file hasn't been saved by --- the user yet). -data Target - = Target { - targetId :: TargetId, -- ^ module or filename - targetAllowObjCode :: Bool, -- ^ object code allowed? - targetContents :: Maybe (InputFileBuffer, UTCTime) - -- ^ Optional in-memory buffer containing the source code GHC should - -- use for this target instead of reading it from disk. - -- - -- Since GHC version 8.10 modules which require preprocessors such as - -- Literate Haskell or CPP to run are also supported. - -- - -- If a corresponding source file does not exist on disk this will - -- result in a 'SourceError' exception if @targetId = TargetModule _@ - -- is used. However together with @targetId = TargetFile _@ GHC will - -- not complain about the file missing. - } - -data TargetId - = TargetModule ModuleName - -- ^ A module name: search for the file - | TargetFile FilePath (Maybe Phase) - -- ^ A filename: preprocess & parse it to find the module name. - -- If specified, the Phase indicates how to compile this file - -- (which phase to start from). Nothing indicates the starting phase - -- should be determined from the suffix of the filename. - deriving Eq - -type InputFileBuffer = StringBuffer - -pprTarget :: Target -> SDoc -pprTarget (Target id obj _) = - (if obj then char '*' else empty) <> pprTargetId id - -instance Outputable Target where - ppr = pprTarget - -pprTargetId :: TargetId -> SDoc -pprTargetId (TargetModule m) = ppr m -pprTargetId (TargetFile f _) = text f - -instance Outputable TargetId where - ppr = pprTargetId - -{- -************************************************************************ -* * -\subsection{Package and Module Tables} -* * -************************************************************************ --} - --- | Helps us find information about modules in the home package -type HomePackageTable = DModuleNameEnv HomeModInfo - -- Domain = modules in the home package that have been fully compiled - -- "home" unit id cached here for convenience - --- | Helps us find information about modules in the imported packages -type PackageIfaceTable = ModuleEnv ModIface - -- Domain = modules in the imported packages - --- | Constructs an empty HomePackageTable -emptyHomePackageTable :: HomePackageTable -emptyHomePackageTable = emptyUDFM - --- | Constructs an empty PackageIfaceTable -emptyPackageIfaceTable :: PackageIfaceTable -emptyPackageIfaceTable = emptyModuleEnv - -pprHPT :: HomePackageTable -> SDoc --- A bit arbitrary for now -pprHPT hpt = pprUDFM hpt $ \hms -> - vcat [ hang (ppr (mi_module (hm_iface hm))) - 2 (ppr (md_types (hm_details hm))) - | hm <- hms ] - -lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo -lookupHpt = lookupUDFM - -lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo -lookupHptDirectly = lookupUDFM_Directly - -eltsHpt :: HomePackageTable -> [HomeModInfo] -eltsHpt = eltsUDFM - -filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable -filterHpt = filterUDFM - -allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool -allHpt = allUDFM - -mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable -mapHpt = mapUDFM - -delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable -delFromHpt = delFromUDFM - -addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable -addToHpt = addToUDFM - -addListToHpt - :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable -addListToHpt = addListToUDFM - -listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable -listToHpt = listToUDFM - -lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo --- The HPT is indexed by ModuleName, not Module, --- we must check for a hit on the right Module -lookupHptByModule hpt mod - = case lookupHpt hpt (moduleName mod) of - Just hm | mi_module (hm_iface hm) == mod -> Just hm - _otherwise -> Nothing - --- | Information about modules in the package being compiled -data HomeModInfo - = HomeModInfo { - hm_iface :: !ModIface, - -- ^ The basic loaded interface file: every loaded module has one of - -- these, even if it is imported from another package - hm_details :: !ModDetails, - -- ^ Extra information that has been created from the 'ModIface' for - -- the module, typically during typechecking - hm_linkable :: !(Maybe Linkable) - -- ^ The actual artifact we would like to link to access things in - -- this module. - -- - -- 'hm_linkable' might be Nothing: - -- - -- 1. If this is an .hs-boot module - -- - -- 2. Temporarily during compilation if we pruned away - -- the old linkable because it was out of date. - -- - -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields - -- in the 'HomePackageTable' will be @Just@. - -- - -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the - -- 'HomeModInfo' by building a new 'ModDetails' from the old - -- 'ModIface' (only). - } - --- | Find the 'ModIface' for a 'Module', searching in both the loaded home --- and external package module information -lookupIfaceByModule - :: HomePackageTable - -> PackageIfaceTable - -> Module - -> Maybe ModIface -lookupIfaceByModule hpt pit mod - = case lookupHptByModule hpt mod of - Just hm -> Just (hm_iface hm) - Nothing -> lookupModuleEnv pit mod - --- If the module does come from the home package, why do we look in the PIT as well? --- (a) In OneShot mode, even home-package modules accumulate in the PIT --- (b) Even in Batch (--make) mode, there is *one* case where a home-package --- module is in the PIT, namely GHC.Prim when compiling the base package. --- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package --- of its own, but it doesn't seem worth the bother. - -hptCompleteSigs :: HscEnv -> [CompleteMatch] -hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) - --- | Find all the instance declarations (of classes and families) from --- the Home Package Table filtered by the provided predicate function. --- Used in @tcRnImports@, to select the instances that are in the --- transitive closure of imports from the currently compiled module. -hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) -hptInstances hsc_env want_this_module - = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do - guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) - let details = hm_details mod_info - return (md_insts details, md_fam_insts details) - in (concat insts, concat famInsts) - --- | Get rules from modules "below" this one (in the dependency sense) -hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False - - --- | Get annotations from modules "below" this one (in the dependency sense) -hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] -hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps -hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env - -hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] -hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) - --- | Get things from modules "below" this one (in the dependency sense) --- C.f Inst.hptInstances -hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a] -hptSomeThingsBelowUs extract include_hi_boot hsc_env deps - | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] - - | otherwise - = let hpt = hsc_HPT hsc_env - in - [ thing - | -- Find each non-hi-boot module below me - (mod, is_boot_mod) <- deps - , include_hi_boot || not is_boot_mod - - -- unsavoury: when compiling the base package with --make, we - -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't - -- be in the HPT, because we never compile it; it's in the EPT - -- instead. ToDo: clean up, and remove this slightly bogus filter: - , mod /= moduleName gHC_PRIM - - -- Look it up in the HPT - , let things = case lookupHpt hpt mod of - Just info -> extract info - Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] - msg = vcat [text "missing module" <+> ppr mod, - text "Probable cause: out-of-date interface files"] - -- This really shouldn't happen, but see #962 - - -- And get its dfuns - , thing <- things ] - - -{- -************************************************************************ -* * -\subsection{Metaprogramming} -* * -************************************************************************ --} - --- | The supported metaprogramming result types -data MetaRequest - = MetaE (LHsExpr GhcPs -> MetaResult) - | MetaP (LPat GhcPs -> MetaResult) - | MetaT (LHsType GhcPs -> MetaResult) - | MetaD ([LHsDecl GhcPs] -> MetaResult) - | MetaAW (Serialized -> MetaResult) - --- | data constructors not exported to ensure correct result type -data MetaResult - = MetaResE { unMetaResE :: LHsExpr GhcPs } - | MetaResP { unMetaResP :: LPat GhcPs } - | MetaResT { unMetaResT :: LHsType GhcPs } - | MetaResD { unMetaResD :: [LHsDecl GhcPs] } - | MetaResAW { unMetaResAW :: Serialized } - -type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult - -metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) -metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) - -metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) -metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) - -metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) -metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) - -metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] -metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) - -metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized -metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) - -{- -************************************************************************ -* * -\subsection{Dealing with Annotations} -* * -************************************************************************ --} - --- | Deal with gathering annotations in from all possible places --- and combining them into a single 'AnnEnv' -prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv -prepareAnnotations hsc_env mb_guts = do - eps <- hscEPS hsc_env - let -- Extract annotations from the module being compiled if supplied one - mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts - -- Extract dependencies of the module if we are supplied one, - -- otherwise load annotations from all home package table - -- entries regardless of dependency ordering. - home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts - other_pkg_anns = eps_ann_env eps - ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, - Just home_pkg_anns, - Just other_pkg_anns] - return ann_env - -{- -************************************************************************ -* * -\subsection{The Finder cache} -* * -************************************************************************ --} - --- | The 'FinderCache' maps modules to the result of --- searching for that module. It records the results of searching for --- modules along the search path. On @:load@, we flush the entire --- contents of this cache. --- -type FinderCache = InstalledModuleEnv InstalledFindResult - -data InstalledFindResult - = InstalledFound ModLocation InstalledModule - | InstalledNoPackage InstalledUnitId - | InstalledNotFound [FilePath] (Maybe InstalledUnitId) - --- | The result of searching for an imported module. --- --- NB: FindResult manages both user source-import lookups --- (which can result in 'Module') as well as direct imports --- for interfaces (which always result in 'InstalledModule'). -data FindResult - = Found ModLocation Module - -- ^ The module was found - | NoPackage UnitId - -- ^ The requested package was not found - | FoundMultiple [(Module, ModuleOrigin)] - -- ^ _Error_: both in multiple packages - - -- | Not found - | NotFound - { fr_paths :: [FilePath] -- Places where I looked - - , fr_pkg :: Maybe UnitId -- Just p => module is in this package's - -- manifest, but couldn't find - -- the .hi file - - , fr_mods_hidden :: [UnitId] -- Module is in these packages, - -- but the *module* is hidden - - , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, - -- but the *package* is hidden - - -- Modules are in these packages, but it is unusable - , fr_unusables :: [(UnitId, UnusablePackageReason)] - - , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules - } - -{- -************************************************************************ -* * -\subsection{Symbol tables and Module details} -* * -************************************************************************ --} - -{- Note [Interface file stages] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Interface files have two possible stages. - -* A partial stage built from the result of the core pipeline. -* A fully instantiated form. Which also includes fingerprints and - potentially information provided by backends. - -We can build a full interface file two ways: -* Directly from a partial one: - Then we omit backend information and mostly compute fingerprints. -* From a partial one + information produced by a backend. - Then we store the provided information and fingerprint both. --} - -type PartialModIface = ModIface_ 'ModIfaceCore -type ModIface = ModIface_ 'ModIfaceFinal - --- | Extends a PartialModIface with information which is either: --- * Computed after codegen --- * Or computed just before writing the iface to disk. (Hashes) --- In order to fully instantiate it. -data ModIfaceBackend = ModIfaceBackend - { mi_iface_hash :: !Fingerprint - -- ^ Hash of the whole interface - , mi_mod_hash :: !Fingerprint - -- ^ Hash of the ABI only - , mi_flag_hash :: !Fingerprint - -- ^ Hash of the important flags used when compiling the module, excluding - -- optimisation flags - , mi_opt_hash :: !Fingerprint - -- ^ Hash of optimisation flags - , mi_hpc_hash :: !Fingerprint - -- ^ Hash of hpc flags - , mi_plugin_hash :: !Fingerprint - -- ^ Hash of plugins - , mi_orphan :: !WhetherHasOrphans - -- ^ Whether this module has orphans - , mi_finsts :: !WhetherHasFamInst - -- ^ Whether this module has family instances. See Note [The type family - -- instance consistency story]. - , mi_exp_hash :: !Fingerprint - -- ^ Hash of export list - , mi_orphan_hash :: !Fingerprint - -- ^ Hash for orphan rules, class and family instances combined - - -- Cached environments for easy lookup. These are computed (lazily) from - -- other fields and are not put into the interface file. - -- Not really produced by the backend but there is no need to create them - -- any earlier. - , mi_warn_fn :: !(OccName -> Maybe WarningTxt) - -- ^ Cached lookup for 'mi_warns' - , mi_fix_fn :: !(OccName -> Maybe Fixity) - -- ^ Cached lookup for 'mi_fixities' - , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) - -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that - -- the thing isn't in decls. It's useful to know that when seeing if we are - -- up to date wrt. the old interface. The 'OccName' is the parent of the - -- name, if it has one. - } - -data ModIfacePhase - = ModIfaceCore - -- ^ Partial interface built based on output of core pipeline. - | ModIfaceFinal - --- | Selects a IfaceDecl representation. --- For fully instantiated interfaces we also maintain --- a fingerprint, which is used for recompilation checks. -type family IfaceDeclExts (phase :: ModIfacePhase) where - IfaceDeclExts 'ModIfaceCore = IfaceDecl - IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) - -type family IfaceBackendExts (phase :: ModIfacePhase) where - IfaceBackendExts 'ModIfaceCore = () - IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend - - - --- | A 'ModIface' plus a 'ModDetails' summarises everything we know --- about a compiled module. The 'ModIface' is the stuff *before* linking, --- and can be written out to an interface file. The 'ModDetails is after --- linking and can be completely recovered from just the 'ModIface'. --- --- When we read an interface file, we also construct a 'ModIface' from it, --- except that we explicitly make the 'mi_decls' and a few other fields empty; --- as when reading we consolidate the declarations etc. into a number of indexed --- maps and environments in the 'ExternalPackageState'. -data ModIface_ (phase :: ModIfacePhase) - = ModIface { - mi_module :: !Module, -- ^ Name of the module we are for - mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? - - mi_hsc_src :: !HscSource, -- ^ Boot? Signature? - - mi_deps :: Dependencies, - -- ^ The dependencies of the module. This is - -- consulted for directly-imported modules, but not - -- for anything else (hence lazy) - - mi_usages :: [Usage], - -- ^ Usages; kept sorted so that it's easy to decide - -- whether to write a new iface file (changing usages - -- doesn't affect the hash of this module) - -- NOT STRICT! we read this field lazily from the interface file - -- It is *only* consulted by the recompilation checker - - mi_exports :: ![IfaceExport], - -- ^ Exports - -- Kept sorted by (mod,occ), to make version comparisons easier - -- Records the modules that are the declaration points for things - -- exported by this module, and the 'OccName's of those things - - - mi_used_th :: !Bool, - -- ^ Module required TH splices when it was compiled. - -- This disables recompilation avoidance (see #481). - - mi_fixities :: [(OccName,Fixity)], - -- ^ Fixities - -- NOT STRICT! we read this field lazily from the interface file - - mi_warns :: Warnings, - -- ^ Warnings - -- NOT STRICT! we read this field lazily from the interface file - - mi_anns :: [IfaceAnnotation], - -- ^ Annotations - -- NOT STRICT! we read this field lazily from the interface file - - - mi_decls :: [IfaceDeclExts phase], - -- ^ Type, class and variable declarations - -- The hash of an Id changes if its fixity or deprecations change - -- (as well as its type of course) - -- Ditto data constructors, class operations, except that - -- the hash of the parent class/tycon changes - - mi_globals :: !(Maybe GlobalRdrEnv), - -- ^ Binds all the things defined at the top level in - -- the /original source/ code for this module. which - -- is NOT the same as mi_exports, nor mi_decls (which - -- may contains declarations for things not actually - -- defined by the user). Used for GHCi and for inspecting - -- the contents of modules via the GHC API only. - -- - -- (We need the source file to figure out the - -- top-level environment, if we didn't compile this module - -- from source then this field contains @Nothing@). - -- - -- Strictly speaking this field should live in the - -- 'HomeModInfo', but that leads to more plumbing. - - -- Instance declarations and rules - mi_insts :: [IfaceClsInst], -- ^ Sorted class instance - mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances - mi_rules :: [IfaceRule], -- ^ Sorted rules - - mi_hpc :: !AnyHpcUsage, - -- ^ True if this program uses Hpc at any point in the program. - - mi_trust :: !IfaceTrustInfo, - -- ^ Safe Haskell Trust information for this module. - - mi_trust_pkg :: !Bool, - -- ^ Do we require the package this module resides in be trusted - -- to trust this module? This is used for the situation where a - -- module is Safe (so doesn't require the package be trusted - -- itself) but imports some trustworthy modules from its own - -- package (which does require its own package be trusted). - -- See Note [RnNames . Trust Own Package] - mi_complete_sigs :: [IfaceCompleteMatch], - - mi_doc_hdr :: Maybe HsDocString, - -- ^ Module header. - - mi_decl_docs :: DeclDocMap, - -- ^ Docs on declarations. - - mi_arg_docs :: ArgDocMap, - -- ^ Docs on arguments. - - mi_final_exts :: !(IfaceBackendExts phase) - -- ^ Either `()` or `ModIfaceBackend` for - -- a fully instantiated interface. - } - --- | Old-style accessor for whether or not the ModIface came from an hs-boot --- file. -mi_boot :: ModIface -> Bool -mi_boot iface = mi_hsc_src iface == HsBootFile - --- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be --- found, 'defaultFixity' is returned instead. -mi_fix :: ModIface -> OccName -> Fixity -mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity - --- | The semantic module for this interface; e.g., if it's a interface --- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' --- will be @@. -mi_semantic_module :: ModIface_ a -> Module -mi_semantic_module iface = case mi_sig_of iface of - Nothing -> mi_module iface - Just mod -> mod - --- | The "precise" free holes, e.g., the signatures that this --- 'ModIface' depends on. -mi_free_holes :: ModIface -> UniqDSet ModuleName -mi_free_holes iface = - case splitModuleInsts (mi_module iface) of - (_, Just indef) - -- A mini-hack: we rely on the fact that 'renameFreeHoles' - -- drops things that aren't holes. - -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef)) - _ -> emptyUniqDSet - where - cands = map fst (dep_mods (mi_deps iface)) - --- | Given a set of free holes, and a unit identifier, rename --- the free holes according to the instantiation of the unit --- identifier. For example, if we have A and B free, and --- our unit identity is @p[A=,B=impl:B]@, the renamed free --- holes are just C. -renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName -renameFreeHoles fhs insts = - unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) - where - hmap = listToUFM insts - lookup_impl mod_name - | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod - -- It wasn't actually a hole - | otherwise = emptyUniqDSet - -instance Binary ModIface where - put_ bh (ModIface { - mi_module = mod, - mi_sig_of = sig_of, - mi_hsc_src = hsc_src, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_used_th = used_th, - mi_fixities = fixities, - mi_warns = warns, - mi_anns = anns, - mi_decls = decls, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - mi_complete_sigs = complete_sigs, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, - mi_final_exts = ModIfaceBackend { - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_opt_hash = opt_hash, - mi_hpc_hash = hpc_hash, - mi_plugin_hash = plugin_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_exp_hash = exp_hash, - mi_orphan_hash = orphan_hash - }}) = do - put_ bh mod - put_ bh sig_of - put_ bh hsc_src - put_ bh iface_hash - put_ bh mod_hash - put_ bh flag_hash - put_ bh opt_hash - put_ bh hpc_hash - put_ bh plugin_hash - put_ bh orphan - put_ bh hasFamInsts - lazyPut bh deps - lazyPut bh usages - put_ bh exports - put_ bh exp_hash - put_ bh used_th - put_ bh fixities - lazyPut bh warns - lazyPut bh anns - put_ bh decls - put_ bh insts - put_ bh fam_insts - lazyPut bh rules - put_ bh orphan_hash - put_ bh hpc_info - put_ bh trust - put_ bh trust_pkg - put_ bh complete_sigs - lazyPut bh doc_hdr - lazyPut bh decl_docs - lazyPut bh arg_docs - - get bh = do - mod <- get bh - sig_of <- get bh - hsc_src <- get bh - iface_hash <- get bh - mod_hash <- get bh - flag_hash <- get bh - opt_hash <- get bh - hpc_hash <- get bh - plugin_hash <- get bh - orphan <- get bh - hasFamInsts <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - exp_hash <- get bh - used_th <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - warns <- {-# SCC "bin_warns" #-} lazyGet bh - anns <- {-# SCC "bin_anns" #-} lazyGet bh - decls <- {-# SCC "bin_tycldecls" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - fam_insts <- {-# SCC "bin_fam_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - orphan_hash <- get bh - hpc_info <- get bh - trust <- get bh - trust_pkg <- get bh - complete_sigs <- get bh - doc_hdr <- lazyGet bh - decl_docs <- lazyGet bh - arg_docs <- lazyGet bh - return (ModIface { - mi_module = mod, - mi_sig_of = sig_of, - mi_hsc_src = hsc_src, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_used_th = used_th, - mi_anns = anns, - mi_fixities = fixities, - mi_warns = warns, - mi_decls = decls, - mi_globals = Nothing, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - -- And build the cached values - mi_complete_sigs = complete_sigs, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, - mi_final_exts = ModIfaceBackend { - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_opt_hash = opt_hash, - mi_hpc_hash = hpc_hash, - mi_plugin_hash = plugin_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_exp_hash = exp_hash, - mi_orphan_hash = orphan_hash, - mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_hash_fn = mkIfaceHashCache decls - }}) - --- | The original names declared of a certain module that are exported -type IfaceExport = AvailInfo - -emptyPartialModIface :: Module -> PartialModIface -emptyPartialModIface mod - = ModIface { mi_module = mod, - mi_sig_of = Nothing, - mi_hsc_src = HsSrcFile, - mi_deps = noDependencies, - mi_usages = [], - mi_exports = [], - mi_used_th = False, - mi_fixities = [], - mi_warns = NoWarnings, - mi_anns = [], - mi_insts = [], - mi_fam_insts = [], - mi_rules = [], - mi_decls = [], - mi_globals = Nothing, - mi_hpc = False, - mi_trust = noIfaceTrustInfo, - mi_trust_pkg = False, - mi_complete_sigs = [], - mi_doc_hdr = Nothing, - mi_decl_docs = emptyDeclDocMap, - mi_arg_docs = emptyArgDocMap, - mi_final_exts = () } - -emptyFullModIface :: Module -> ModIface -emptyFullModIface mod = - (emptyPartialModIface mod) - { mi_decls = [] - , mi_final_exts = ModIfaceBackend - { mi_iface_hash = fingerprint0, - mi_mod_hash = fingerprint0, - mi_flag_hash = fingerprint0, - mi_opt_hash = fingerprint0, - mi_hpc_hash = fingerprint0, - mi_plugin_hash = fingerprint0, - mi_orphan = False, - mi_finsts = False, - mi_exp_hash = fingerprint0, - mi_orphan_hash = fingerprint0, - mi_warn_fn = emptyIfaceWarnCache, - mi_fix_fn = emptyIfaceFixCache, - mi_hash_fn = emptyIfaceHashCache } } - --- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' -mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] - -> (OccName -> Maybe (OccName, Fingerprint)) -mkIfaceHashCache pairs - = \occ -> lookupOccEnv env occ - where - env = foldl' add_decl emptyOccEnv pairs - add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) - where - add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) - -emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) -emptyIfaceHashCache _occ = Nothing - - --- | The 'ModDetails' is essentially a cache for information in the 'ModIface' --- for home modules only. Information relating to packages will be loaded into --- global environments in 'ExternalPackageState'. -data ModDetails - = ModDetails { - -- The next two fields are created by the typechecker - md_exports :: [AvailInfo], - md_types :: !TypeEnv, -- ^ Local type environment for this particular module - -- Includes Ids, TyCons, PatSyns - md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module - md_fam_insts :: ![FamInst], - md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules - md_anns :: ![Annotation], -- ^ Annotations present in this module: currently - -- they only annotate things also declared in this module - md_complete_sigs :: [CompleteMatch] - -- ^ Complete match pragmas for this module - } - --- | Constructs an empty ModDetails -emptyModDetails :: ModDetails -emptyModDetails - = ModDetails { md_types = emptyTypeEnv, - md_exports = [], - md_insts = [], - md_rules = [], - md_fam_insts = [], - md_anns = [], - md_complete_sigs = [] } - --- | Records the modules directly imported by a module for extracting e.g. --- usage information, and also to give better error message -type ImportedMods = ModuleEnv [ImportedBy] - --- | If a module was "imported" by the user, we associate it with --- more detailed usage information 'ImportedModsVal'; a module --- imported by the system only gets used for usage information. -data ImportedBy - = ImportedByUser ImportedModsVal - | ImportedBySystem - -importedByUser :: [ImportedBy] -> [ImportedModsVal] -importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys -importedByUser (ImportedBySystem : bys) = importedByUser bys -importedByUser [] = [] - -data ImportedModsVal - = ImportedModsVal { - imv_name :: ModuleName, -- ^ The name the module is imported with - imv_span :: SrcSpan, -- ^ the source span of the whole import - imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import - imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import - imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide - -- NB. BangPattern here: otherwise this leaks. (#15111) - imv_qualified :: Bool -- ^ whether this is a qualified import - } - --- | A ModGuts is carried through the compiler, accumulating stuff as it goes --- There is only one ModGuts at any time, the one for the module --- being compiled right now. Once it is compiled, a 'ModIface' and --- 'ModDetails' are extracted and the ModGuts is discarded. -data ModGuts - = ModGuts { - mg_module :: !Module, -- ^ Module being compiled - mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module - mg_loc :: SrcSpan, -- ^ For error messages from inner passes - mg_exports :: ![AvailInfo], -- ^ What it exports - mg_deps :: !Dependencies, -- ^ What it depends on, directly or - -- otherwise - mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. - - mg_used_th :: !Bool, -- ^ Did we run a TH splice? - mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment - - -- These fields all describe the things **declared in this module** - mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. - -- Used for creating interface files. - mg_tcs :: ![TyCon], -- ^ TyCons declared in this module - -- (includes TyCons for classes) - mg_insts :: ![ClsInst], -- ^ Class instances declared in this module - mg_fam_insts :: ![FamInst], - -- ^ Family instances declared in this module - mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module - mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains - -- See Note [Overall plumbing for rules] in Rules.hs - mg_binds :: !CoreProgram, -- ^ Bindings for this module - mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module - mg_foreign_files :: ![(ForeignSrcLang, FilePath)], - -- ^ Files to be compiled with the C compiler - mg_warns :: !Warnings, -- ^ Warnings declared in the module - mg_anns :: [Annotation], -- ^ Annotations declared in this module - mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches - mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module - mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module - - -- The next two fields are unusual, because they give instance - -- environments for *all* modules in the home package, including - -- this module, rather than for *just* this module. - -- Reason: when looking up an instance we don't want to have to - -- look at each module in the home package in turn - mg_inst_env :: InstEnv, -- ^ Class instance environment for - -- /home-package/ modules (including this - -- one); c.f. 'tcg_inst_env' - mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for - -- /home-package/ modules (including this - -- one); c.f. 'tcg_fam_inst_env' - - mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode - mg_trust_pkg :: Bool, -- ^ Do we need to trust our - -- own package for Safe Haskell? - -- See Note [RnNames . Trust Own Package] - - mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. - mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. - mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. - } - --- The ModGuts takes on several slightly different forms: --- --- After simplification, the following fields change slightly: --- mg_rules Orphan rules only (local ones now attached to binds) --- mg_binds With rules attached - ---------------------------------------------------------- --- The Tidy pass forks the information about this module: --- * one lot goes to interface file generation (ModIface) --- and later compilations (ModDetails) --- * the other lot goes to code generation (CgGuts) - --- | A restricted form of 'ModGuts' for code generation purposes -data CgGuts - = CgGuts { - cg_module :: !Module, - -- ^ Module being compiled - - cg_tycons :: [TyCon], - -- ^ Algebraic data types (including ones that started - -- life as classes); generate constructors and info - -- tables. Includes newtypes, just for the benefit of - -- External Core - - cg_binds :: CoreProgram, - -- ^ The tidied main bindings, including - -- previously-implicit bindings for record and class - -- selectors, and data constructor wrappers. But *not* - -- data constructor workers; reason: we regard them - -- as part of the code-gen of tycons - - cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to - -- generate #includes for C code gen - cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information - cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints - cg_spt_entries :: [SptEntry] - -- ^ Static pointer table entries for static forms defined in - -- the module. - -- See Note [Grand plan for static forms] in StaticPtrTable - } - ------------------------------------ --- | Foreign export stubs -data ForeignStubs - = NoStubs - -- ^ We don't have any stubs - | ForeignStubs SDoc SDoc - -- ^ There are some stubs. Parameters: - -- - -- 1) Header file prototypes for - -- "foreign exported" functions - -- - -- 2) C stubs to use when calling - -- "foreign exported" functions - -appendStubC :: ForeignStubs -> SDoc -> ForeignStubs -appendStubC NoStubs c_code = ForeignStubs empty c_code -appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) - -{- -************************************************************************ -* * - The interactive context -* * -************************************************************************ - -Note [The interactive package] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type, class, and value declarations at the command prompt are treated -as if they were defined in modules - interactive:Ghci1 - interactive:Ghci2 - ...etc... -with each bunch of declarations using a new module, all sharing a -common package 'interactive' (see Module.interactiveUnitId, and -PrelNames.mkInteractiveModule). - -This scheme deals well with shadowing. For example: - - ghci> data T = A - ghci> data T = B - ghci> :i A - data Ghci1.T = A -- Defined at :2:10 - -Here we must display info about constructor A, but its type T has been -shadowed by the second declaration. But it has a respectable -qualified name (Ghci1.T), and its source location says where it was -defined. - -So the main invariant continues to hold, that in any session an -original name M.T only refers to one unique thing. (In a previous -iteration both the T's above were called :Interactive.T, albeit with -different uniques, which gave rise to all sorts of trouble.) - -The details are a bit tricky though: - - * The field ic_mod_index counts which Ghci module we've got up to. - It is incremented when extending ic_tythings - - * ic_tythings contains only things from the 'interactive' package. - - * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go - in the Home Package Table (HPT). When you say :load, that's when we - extend the HPT. - - * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. - It stays as 'main' (or whatever -this-unit-id says), and is the - package to which :load'ed modules are added to. - - * So how do we arrange that declarations at the command prompt get to - be in the 'interactive' package? Simply by setting the tcg_mod - field of the TcGblEnv to "interactive:Ghci1". This is done by the - call to initTc in initTcInteractive, which in turn get the module - from it 'icInteractiveModule' field of the interactive context. - - The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says. - - * The main trickiness is that the type environment (tcg_type_env) and - fixity envt (tcg_fix_env), now contain entities from all the - interactive-package modules (Ghci1, Ghci2, ...) together, rather - than just a single module as is usually the case. So you can't use - "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs - the HPT/PTE. This is a change, but not a problem provided you - know. - -* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields - of the TcGblEnv, which collect "things defined in this module", all - refer to stuff define in a single GHCi command, *not* all the commands - so far. - - In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from - all GhciN modules, which makes sense -- they are all "home package" - modules. - - -Note [Interactively-bound Ids in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Ids bound by previous Stmts in GHCi are currently - a) GlobalIds, with - b) An External Name, like Ghci4.foo - See Note [The interactive package] above - c) A tidied type - - (a) They must be GlobalIds (not LocalIds) otherwise when we come to - compile an expression using these ids later, the byte code - generator will consider the occurrences to be free rather than - global. - - (b) Having an External Name is important because of Note - [GlobalRdrEnv shadowing] in RdrName - - (c) Their types are tidied. This is important, because :info may ask - to look at them, and :info expects the things it looks up to have - tidy types - -Where do interactively-bound Ids come from? - - - GHCi REPL Stmts e.g. - ghci> let foo x = x+1 - These start with an Internal Name because a Stmt is a local - construct, so the renamer naturally builds an Internal name for - each of its binders. Then in tcRnStmt they are externalised via - TcRnDriver.externaliseAndTidyId, so they get Names like Ghic4.foo. - - - Ids bound by the debugger etc have Names constructed by - IfaceEnv.newInteractiveBinder; at the call sites it is followed by - mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are - all Global, External. - - - TyCons, Classes, and Ids bound by other top-level declarations in - GHCi (eg foreign import, record selectors) also get External - Names, with Ghci9 (or 8, or 7, etc) as the module name. - - -Note [ic_tythings] -~~~~~~~~~~~~~~~~~~ -The ic_tythings field contains - * The TyThings declared by the user at the command prompt - (eg Ids, TyCons, Classes) - - * The user-visible Ids that arise from such things, which - *don't* come from 'implicitTyThings', notably: - - record selectors - - class ops - The implicitTyThings are readily obtained from the TyThings - but record selectors etc are not - -It does *not* contain - * DFunIds (they can be gotten from ic_instances) - * CoAxioms (ditto) - -See also Note [Interactively-bound Ids in GHCi] - -Note [Override identical instances in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you declare a new instance in GHCi that is identical to a previous one, -we simply override the previous one; we don't regard it as overlapping. -e.g. Prelude> data T = A | B - Prelude> instance Eq T where ... - Prelude> instance Eq T where ... -- This one overrides - -It's exactly the same for type-family instances. See #7102 --} - --- | Interactive context, recording information about the state of the --- context in which statements are executed in a GHCi session. -data InteractiveContext - = InteractiveContext { - ic_dflags :: DynFlags, - -- ^ The 'DynFlags' used to evaluate interative expressions - -- and statements. - - ic_mod_index :: Int, - -- ^ Each GHCi stmt or declaration brings some new things into - -- scope. We give them names like interactive:Ghci9.T, - -- where the ic_index is the '9'. The ic_mod_index is - -- incremented whenever we add something to ic_tythings - -- See Note [The interactive package] - - ic_imports :: [InteractiveImport], - -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with - -- these imports - -- - -- This field is only stored here so that the client - -- can retrieve it with GHC.getContext. GHC itself doesn't - -- use it, but does reset it to empty sometimes (such - -- as before a GHC.load). The context is set with GHC.setContext. - - ic_tythings :: [TyThing], - -- ^ TyThings defined by the user, in reverse order of - -- definition (ie most recent at the front) - -- See Note [ic_tythings] - - ic_rn_gbl_env :: GlobalRdrEnv, - -- ^ The cached 'GlobalRdrEnv', built by - -- 'InteractiveEval.setContext' and updated regularly - -- It contains everything in scope at the command line, - -- including everything in ic_tythings - - ic_instances :: ([ClsInst], [FamInst]), - -- ^ All instances and family instances created during - -- this session. These are grabbed en masse after each - -- update to be sure that proper overlapping is retained. - -- That is, rather than re-check the overlapping each - -- time we update the context, we just take the results - -- from the instance code that already does that. - - ic_fix_env :: FixityEnv, - -- ^ Fixities declared in let statements - - ic_default :: Maybe [Type], - -- ^ The current default types, set by a 'default' declaration - - ic_resume :: [Resume], - -- ^ The stack of breakpoint contexts - - ic_monad :: Name, - -- ^ The monad that GHCi is executing in - - ic_int_print :: Name, - -- ^ The function that is used for printing results - -- of expressions in ghci and -e mode. - - ic_cwd :: Maybe FilePath - -- virtual CWD of the program - } - -data InteractiveImport - = IIDecl (ImportDecl GhcPs) - -- ^ Bring the exports of a particular module - -- (filtered by an import decl) into scope - - | IIModule ModuleName - -- ^ Bring into scope the entire top-level envt of - -- of this module, including the things imported - -- into it. - - --- | Constructs an empty InteractiveContext. -emptyInteractiveContext :: DynFlags -> InteractiveContext -emptyInteractiveContext dflags - = InteractiveContext { - ic_dflags = dflags, - ic_imports = [], - ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_mod_index = 1, - ic_tythings = [], - ic_instances = ([],[]), - ic_fix_env = emptyNameEnv, - ic_monad = ioTyConName, -- IO monad by default - ic_int_print = printName, -- System.IO.print by default - ic_default = Nothing, - ic_resume = [], - ic_cwd = Nothing } - -icInteractiveModule :: InteractiveContext -> Module -icInteractiveModule (InteractiveContext { ic_mod_index = index }) - = mkInteractiveModule index - --- | This function returns the list of visible TyThings (useful for --- e.g. showBindings) -icInScopeTTs :: InteractiveContext -> [TyThing] -icInScopeTTs = ic_tythings - --- | Get the PrintUnqualified function based on the flags and this InteractiveContext -icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified -icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = - mkPrintUnqualified dflags grenv - --- | extendInteractiveContext is called with new TyThings recently defined to update the --- InteractiveContext to include them. Ids are easily removed when shadowed, --- but Classes and TyCons are not. Some work could be done to determine --- whether they are entirely shadowed, but as you could still have references --- to them (e.g. instances for classes or values of the type for TyCons), it's --- not clear whether removing them is even the appropriate behavior. -extendInteractiveContext :: InteractiveContext - -> [TyThing] - -> [ClsInst] -> [FamInst] - -> Maybe [Type] - -> FixityEnv - -> InteractiveContext -extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env - = ictxt { ic_mod_index = ic_mod_index ictxt + 1 - -- Always bump this; even instances should create - -- a new mod_index (#9426) - , ic_tythings = new_tythings ++ old_tythings - , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings - , ic_instances = ( new_cls_insts ++ old_cls_insts - , new_fam_insts ++ fam_insts ) - -- we don't shadow old family instances (#7102), - -- so don't need to remove them here - , ic_default = defaults - , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] - } - where - new_ids = [id | AnId id <- new_tythings] - old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) - - -- Discard old instances that have been fully overridden - -- See Note [Override identical instances in GHCi] - (cls_insts, fam_insts) = ic_instances ictxt - old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts - -extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext --- Just a specialised version -extendInteractiveContextWithIds ictxt new_ids - | null new_ids = ictxt - | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 - , ic_tythings = new_tythings ++ old_tythings - , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } - where - new_tythings = map AnId new_ids - old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) - -shadowed_by :: [Id] -> TyThing -> Bool -shadowed_by ids = shadowed - where - shadowed id = getOccName id `elemOccSet` new_occs - new_occs = mkOccSet (map getOccName ids) - -setInteractivePackage :: HscEnv -> HscEnv --- Set the 'thisPackage' DynFlag to 'interactive' -setInteractivePackage hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } } - -setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext -setInteractivePrintName ic n = ic{ic_int_print = n} - - -- ToDo: should not add Ids to the gbl env here - --- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing --- later ones, and shadowing existing entries in the GlobalRdrEnv. -icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv -icExtendGblRdrEnv env tythings - = foldr add env tythings -- Foldr makes things in the front of - -- the list shadow things at the back - where - -- One at a time, to ensure each shadows the previous ones - add thing env - | is_sub_bndr thing - = env - | otherwise - = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) - where - env1 = shadowNames env (concatMap availNames avail) - avail = tyThingAvailInfo thing - - -- Ugh! The new_tythings may include record selectors, since they - -- are not implicit-ids, and must appear in the TypeEnv. But they - -- will also be brought into scope by the corresponding (ATyCon - -- tc). And we want the latter, because that has the correct - -- parent (#10520) - is_sub_bndr (AnId f) = case idDetails f of - RecSelId {} -> True - ClassOpId {} -> True - _ -> False - is_sub_bndr _ = False - -substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext -substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst - | isEmptyTCvSubst subst = ictxt - | otherwise = ictxt { ic_tythings = map subst_ty tts } - where - subst_ty (AnId id) - = AnId $ id `setIdType` substTyAddInScope subst (idType id) - -- Variables in the interactive context *can* mention free type variables - -- because of the runtime debugger. Otherwise you'd expect all - -- variables bound in the interactive context to be closed. - subst_ty tt - = tt - -instance Outputable InteractiveImport where - ppr (IIModule m) = char '*' <> ppr m - ppr (IIDecl d) = ppr d - -{- -************************************************************************ -* * - Building a PrintUnqualified -* * -************************************************************************ - -Note [Printing original names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deciding how to print names is pretty tricky. We are given a name -P:M.T, where P is the package name, M is the defining module, and T is -the occurrence name, and we have to decide in which form to display -the name given a GlobalRdrEnv describing the current scope. - -Ideally we want to display the name in the form in which it is in -scope. However, the name might not be in scope at all, and that's -where it gets tricky. Here are the cases: - - 1. T uniquely maps to P:M.T ---> "T" NameUnqual - 2. There is an X for which X.T - uniquely maps to P:M.T ---> "X.T" NameQual X - 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 - 4. Otherwise ---> "P:M.T" NameNotInScope2 - -(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at -all. In these cases we still want to refer to the name as "M.T", *but* -"M.T" might mean something else in the current scope (e.g. if there's -an "import X as M"), so to avoid confusion we avoid using "M.T" if -there's already a binding for it. Instead we write P:M.T. - -There's one further subtlety: in case (3), what if there are two -things around, P1:M.T and P2:M.T? Then we don't want to print both of -them as M.T! However only one of the modules P1:M and P2:M can be -exposed (say P2), so we use M.T for that, and P1:M.T for the other one. -This is handled by the qual_mod component of PrintUnqualified, inside -the (ppr mod) of case (3), in Name.pprModulePrefix - -Note [Printing unit ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the old days, original names were tied to PackageIds, which directly -corresponded to the entities that users wrote in Cabal files, and were perfectly -suitable for printing when we need to disambiguate packages. However, with -UnitId, the situation can be different: if the key is instantiated with -some holes, we should try to give the user some more useful information. --} - --- | Creates some functions that work out the best ways to format --- names for the user according to a set of heuristics. -mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified dflags env = QueryQualify qual_name - (mkQualModule dflags) - (mkQualPackage dflags) - where - qual_name mod occ - | [gre] <- unqual_gres - , right_name gre - = NameUnqual -- If there's a unique entity that's in scope - -- unqualified with 'occ' AND that entity is - -- the right one, then we can use the unqualified name - - | [] <- unqual_gres - , any is_name forceUnqualNames - , not (isDerivedOccName occ) - = NameUnqual -- Don't qualify names that come from modules - -- that come with GHC, often appear in error messages, - -- but aren't typically in scope. Doing this does not - -- cause ambiguity, and it reduces the amount of - -- qualification in error messages thus improving - -- readability. - -- - -- A motivating example is 'Constraint'. It's often not - -- in scope, but printing GHC.Prim.Constraint seems - -- overkill. - - | [gre] <- qual_gres - = NameQual (greQualModName gre) - - | null qual_gres - = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) - then NameNotInScope1 - else NameNotInScope2 - - | otherwise - = NameNotInScope1 -- Can happen if 'f' is bound twice in the module - -- Eg f = True; g = 0; f = False - where - is_name :: Name -> Bool - is_name name = ASSERT2( isExternalName name, ppr name ) - nameModule name == mod && nameOccName name == occ - - forceUnqualNames :: [Name] - forceUnqualNames = - map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] - ++ [ eqTyConName ] - - right_name gre = nameModule_maybe (gre_name gre) == Just mod - - unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env - qual_gres = filter right_name (lookupGlobalRdrEnv env occ) - - -- we can mention a module P:M without the P: qualifier iff - -- "import M" would resolve unambiguously to P:M. (if P is the - -- current package we can just assume it is unqualified). - --- | Creates a function for formatting modules based on two heuristics: --- (1) if the module is the current module, don't qualify, and (2) if there --- is only one exposed package which exports this module, don't qualify. -mkQualModule :: DynFlags -> QueryQualifyModule -mkQualModule dflags mod - | moduleUnitId mod == thisPackage dflags = False - - | [(_, pkgconfig)] <- lookup, - packageConfigId pkgconfig == moduleUnitId mod - -- this says: we are given a module P:M, is there just one exposed package - -- that exposes a module M, and is it package P? - = False - - | otherwise = True - where lookup = lookupModuleInAllPackages dflags (moduleName mod) - --- | Creates a function for formatting packages based on two heuristics: --- (1) don't qualify if the package in question is "main", and (2) only qualify --- with a unit id if the package ID would be ambiguous. -mkQualPackage :: DynFlags -> QueryQualifyPackage -mkQualPackage dflags pkg_key - | pkg_key == mainUnitId || pkg_key == interactiveUnitId - -- Skip the lookup if it's main, since it won't be in the package - -- database! - = False - | Just pkgid <- mb_pkgid - , searchPackageId dflags pkgid `lengthIs` 1 - -- this says: we are given a package pkg-0.1@MMM, are there only one - -- exposed packages whose package ID is pkg-0.1? - = False - | otherwise - = True - where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key) - --- | A function which only qualifies package names if necessary; but --- qualifies all other identifiers. -pkgQual :: DynFlags -> PrintUnqualified -pkgQual dflags = alwaysQualify { - queryQualifyPackage = mkQualPackage dflags - } - -{- -************************************************************************ -* * - Implicit TyThings -* * -************************************************************************ - -Note [Implicit TyThings] -~~~~~~~~~~~~~~~~~~~~~~~~ - DEFINITION: An "implicit" TyThing is one that does not have its own - IfaceDecl in an interface file. Instead, its binding in the type - environment is created as part of typechecking the IfaceDecl for - some other thing. - -Examples: - * All DataCons are implicit, because they are generated from the - IfaceDecl for the data/newtype. Ditto class methods. - - * Record selectors are *not* implicit, because they get their own - free-standing IfaceDecl. - - * Associated data/type families are implicit because they are - included in the IfaceDecl of the parent class. (NB: the - IfaceClass decl happens to use IfaceDecl recursively for the - associated types, but that's irrelevant here.) - - * Dictionary function Ids are not implicit. - - * Axioms for newtypes are implicit (same as above), but axioms - for data/type family instances are *not* implicit (like DFunIds). --} - --- | Determine the 'TyThing's brought into scope by another 'TyThing' --- /other/ than itself. For example, Id's don't have any implicit TyThings --- as they just bring themselves into scope, but classes bring their --- dictionary datatype, type constructor and some selector functions into --- scope, just for a start! - --- N.B. the set of TyThings returned here *must* match the set of --- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that --- TyThing.getOccName should define a bijection between the two lists. --- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) --- The order of the list does not matter. -implicitTyThings :: TyThing -> [TyThing] -implicitTyThings (AnId _) = [] -implicitTyThings (ACoAxiom _cc) = [] -implicitTyThings (ATyCon tc) = implicitTyConThings tc -implicitTyThings (AConLike cl) = implicitConLikeThings cl - -implicitConLikeThings :: ConLike -> [TyThing] -implicitConLikeThings (RealDataCon dc) - = dataConImplicitTyThings dc - -implicitConLikeThings (PatSynCon {}) - = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher - -- are not "implicit"; they are simply new top-level bindings, - -- and they have their own declaration in an interface file - -- Unless a record pat syn when there are implicit selectors - -- They are still not included here as `implicitConLikeThings` is - -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked - -- by `tcTopValBinds`. - -implicitClassThings :: Class -> [TyThing] -implicitClassThings cl - = -- Does not include default methods, because those Ids may have - -- their own pragmas, unfoldings etc, not derived from the Class object - - -- associated types - -- No recursive call for the classATs, because they - -- are only the family decls; they have no implicit things - map ATyCon (classATs cl) ++ - - -- superclass and operation selectors - map AnId (classAllSelIds cl) - -implicitTyConThings :: TyCon -> [TyThing] -implicitTyConThings tc - = class_stuff ++ - -- fields (names of selectors) - - -- (possibly) implicit newtype axioms - -- or type family axioms - implicitCoTyCon tc ++ - - -- for each data constructor in order, - -- the constructor, worker, and (possibly) wrapper - [ thing | dc <- tyConDataCons tc - , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] - -- NB. record selectors are *not* implicit, they have fully-fledged - -- bindings that pass through the compilation pipeline as normal. - where - class_stuff = case tyConClass_maybe tc of - Nothing -> [] - Just cl -> implicitClassThings cl - --- For newtypes and closed type families (only) add the implicit coercion tycon -implicitCoTyCon :: TyCon -> [TyThing] -implicitCoTyCon tc - | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] - | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc - = [ACoAxiom co] - | otherwise = [] - --- | Returns @True@ if there should be no interface-file declaration --- for this thing on its own: either it is built-in, or it is part --- of some other declaration, or it is generated implicitly by some --- other declaration. -isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (AConLike cl) = case cl of - RealDataCon {} -> True - PatSynCon {} -> False -isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc -isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax - --- | tyThingParent_maybe x returns (Just p) --- when pprTyThingInContext should print a declaration for p --- (albeit with some "..." in it) when asked to show x --- It returns the *immediate* parent. So a datacon returns its tycon --- but the tycon could be the associated type of a class, so it in turn --- might have a parent. -tyThingParent_maybe :: TyThing -> Maybe TyThing -tyThingParent_maybe (AConLike cl) = case cl of - RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) - PatSynCon{} -> Nothing -tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of - Just tc -> Just (ATyCon tc) - Nothing -> Nothing -tyThingParent_maybe (AnId id) = case idDetails id of - RecSelId { sel_tycon = RecSelData tc } -> - Just (ATyCon tc) - ClassOpId cls -> - Just (ATyCon (classTyCon cls)) - _other -> Nothing -tyThingParent_maybe _other = Nothing - -tyThingsTyCoVars :: [TyThing] -> TyCoVarSet -tyThingsTyCoVars tts = - unionVarSets $ map ttToVarSet tts - where - ttToVarSet (AnId id) = tyCoVarsOfType $ idType id - ttToVarSet (AConLike cl) = case cl of - RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc - PatSynCon{} -> emptyVarSet - ttToVarSet (ATyCon tc) - = case tyConClass_maybe tc of - Just cls -> (mkVarSet . fst . classTvsFds) cls - Nothing -> tyCoVarsOfType $ tyConKind tc - ttToVarSet (ACoAxiom _) = emptyVarSet - --- | The Names that a TyThing should bring into scope. Used to build --- the GlobalRdrEnv for the InteractiveContext. -tyThingAvailInfo :: TyThing -> [AvailInfo] -tyThingAvailInfo (ATyCon t) - = case tyConClass_maybe t of - Just c -> [AvailTC n (n : map getName (classMethods c) - ++ map getName (classATs c)) - [] ] - where n = getName c - Nothing -> [AvailTC n (n : map getName dcs) flds] - where n = getName t - dcs = tyConDataCons t - flds = tyConFieldLabels t -tyThingAvailInfo (AConLike (PatSynCon p)) - = map avail ((getName p) : map flSelector (patSynFieldLabels p)) -tyThingAvailInfo t - = [avail (getName t)] - -{- -************************************************************************ -* * - TypeEnv -* * -************************************************************************ --} - --- | A map from 'Name's to 'TyThing's, constructed by typechecking --- local declarations or interface files -type TypeEnv = NameEnv TyThing - -emptyTypeEnv :: TypeEnv -typeEnvElts :: TypeEnv -> [TyThing] -typeEnvTyCons :: TypeEnv -> [TyCon] -typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] -typeEnvIds :: TypeEnv -> [Id] -typeEnvPatSyns :: TypeEnv -> [PatSyn] -typeEnvDataCons :: TypeEnv -> [DataCon] -typeEnvClasses :: TypeEnv -> [Class] -lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing - -emptyTypeEnv = emptyNameEnv -typeEnvElts env = nameEnvElts env -typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] -typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] -typeEnvIds env = [id | AnId id <- typeEnvElts env] -typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] -typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] -typeEnvClasses env = [cl | tc <- typeEnvTyCons env, - Just cl <- [tyConClass_maybe tc]] - -mkTypeEnv :: [TyThing] -> TypeEnv -mkTypeEnv things = extendTypeEnvList emptyTypeEnv things - -mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv -mkTypeEnvWithImplicits things = - mkTypeEnv things - `plusNameEnv` - mkTypeEnv (concatMap implicitTyThings things) - -typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv -typeEnvFromEntities ids tcs famInsts = - mkTypeEnv ( map AnId ids - ++ map ATyCon all_tcs - ++ concatMap implicitTyConThings all_tcs - ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts - ) - where - all_tcs = tcs ++ famInstsRepTyCons famInsts - -lookupTypeEnv = lookupNameEnv - --- Extend the type environment -extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv -extendTypeEnv env thing = extendNameEnv env (getName thing) thing - -extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv -extendTypeEnvList env things = foldl' extendTypeEnv env things - -extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv -extendTypeEnvWithIds env ids - = extendNameEnvList env [(getName id, AnId id) | id <- ids] - -plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv -plusTypeEnv env1 env2 = plusNameEnv env1 env2 - --- | Find the 'TyThing' for the given 'Name' by using all the resources --- at our disposal: the compiled modules in the 'HomePackageTable' and the --- compiled modules in other packages that live in 'PackageTypeEnv'. Note --- that this does NOT look up the 'TyThing' in the module being compiled: you --- have to do that yourself, if desired -lookupType :: DynFlags - -> HomePackageTable - -> PackageTypeEnv - -> Name - -> Maybe TyThing - -lookupType dflags hpt pte name - | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT - = lookupNameEnv pte name - | otherwise - = case lookupHptByModule hpt mod of - Just hm -> lookupNameEnv (md_types (hm_details hm)) name - Nothing -> lookupNameEnv pte name - where - mod = ASSERT2( isExternalName name, ppr name ) - if isHoleName name - then mkModule (thisPackage dflags) (moduleName (nameModule name)) - else nameModule name - --- | As 'lookupType', but with a marginally easier-to-use interface --- if you have a 'HscEnv' -lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) -lookupTypeHscEnv hsc_env name = do - eps <- readIORef (hsc_EPS hsc_env) - return $! lookupType dflags hpt (eps_PTE eps) name - where - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - --- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise -tyThingTyCon :: TyThing -> TyCon -tyThingTyCon (ATyCon tc) = tc -tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) - --- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise -tyThingCoAxiom :: TyThing -> CoAxiom Branched -tyThingCoAxiom (ACoAxiom ax) = ax -tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) - --- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise -tyThingDataCon :: TyThing -> DataCon -tyThingDataCon (AConLike (RealDataCon dc)) = dc -tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) - --- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. --- Panics otherwise -tyThingConLike :: TyThing -> ConLike -tyThingConLike (AConLike dc) = dc -tyThingConLike other = pprPanic "tyThingConLike" (ppr other) - --- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise -tyThingId :: TyThing -> Id -tyThingId (AnId id) = id -tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc -tyThingId other = pprPanic "tyThingId" (ppr other) - -{- -************************************************************************ -* * -\subsection{MonadThings and friends} -* * -************************************************************************ --} - --- | Class that abstracts out the common ability of the monads in GHC --- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides --- a number of related convenience functions for accessing particular --- kinds of 'TyThing' -class Monad m => MonadThings m where - lookupThing :: Name -> m TyThing - - lookupId :: Name -> m Id - lookupId = liftM tyThingId . lookupThing - - lookupDataCon :: Name -> m DataCon - lookupDataCon = liftM tyThingDataCon . lookupThing - - lookupTyCon :: Name -> m TyCon - lookupTyCon = liftM tyThingTyCon . lookupThing - -{- -************************************************************************ -* * -\subsection{Auxiliary types} -* * -************************************************************************ - -These types are defined here because they are mentioned in ModDetails, -but they are mostly elaborated elsewhere --} - ------------------- Warnings ------------------------- --- | Warning information for a module -data Warnings - = NoWarnings -- ^ Nothing deprecated - | WarnAll WarningTxt -- ^ Whole module deprecated - | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated - - -- Only an OccName is needed because - -- (1) a deprecation always applies to a binding - -- defined in the module in which the deprecation appears. - -- (2) deprecations are only reported outside the defining module. - -- this is important because, otherwise, if we saw something like - -- - -- {-# DEPRECATED f "" #-} - -- f = ... - -- h = f - -- g = let f = undefined in f - -- - -- we'd need more information than an OccName to know to say something - -- about the use of f in h but not the use of the locally bound f in g - -- - -- however, because we only report about deprecations from the outside, - -- and a module can only export one value called f, - -- an OccName suffices. - -- - -- this is in contrast with fixity declarations, where we need to map - -- a Name to its fixity declaration. - deriving( Eq ) - -instance Binary Warnings where - put_ bh NoWarnings = putByte bh 0 - put_ bh (WarnAll t) = do - putByte bh 1 - put_ bh t - put_ bh (WarnSome ts) = do - putByte bh 2 - put_ bh ts - - get bh = do - h <- getByte bh - case h of - 0 -> return NoWarnings - 1 -> do aa <- get bh - return (WarnAll aa) - _ -> do aa <- get bh - return (WarnSome aa) - --- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' -mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt -mkIfaceWarnCache NoWarnings = \_ -> Nothing -mkIfaceWarnCache (WarnAll t) = \_ -> Just t -mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) - -emptyIfaceWarnCache :: OccName -> Maybe WarningTxt -emptyIfaceWarnCache _ = Nothing - -plusWarns :: Warnings -> Warnings -> Warnings -plusWarns d NoWarnings = d -plusWarns NoWarnings d = d -plusWarns _ (WarnAll t) = WarnAll t -plusWarns (WarnAll t) _ = WarnAll t -plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) - --- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' -mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity -mkIfaceFixCache pairs - = \n -> lookupOccEnv env n - where - env = mkOccEnv pairs - -emptyIfaceFixCache :: OccName -> Maybe Fixity -emptyIfaceFixCache _ = Nothing - --- | Fixity environment mapping names to their fixities -type FixityEnv = NameEnv FixItem - --- | Fixity information for an 'Name'. We keep the OccName in the range --- so that we can generate an interface from it -data FixItem = FixItem OccName Fixity - -instance Outputable FixItem where - ppr (FixItem occ fix) = ppr fix <+> ppr occ - -emptyFixityEnv :: FixityEnv -emptyFixityEnv = emptyNameEnv - -lookupFixity :: FixityEnv -> Name -> Fixity -lookupFixity env n = case lookupNameEnv env n of - Just (FixItem _ fix) -> fix - Nothing -> defaultFixity - -{- -************************************************************************ -* * -\subsection{WhatsImported} -* * -************************************************************************ --} - --- | Records whether a module has orphans. An \"orphan\" is one of: --- --- * An instance declaration in a module other than the definition --- module for one of the type constructors or classes in the instance head --- --- * A transformation rule in a module other than the one defining --- the function in the head of the rule --- -type WhetherHasOrphans = Bool - --- | Does this module define family instances? -type WhetherHasFamInst = Bool - --- | Did this module originate from a *-boot file? -type IsBootInterface = Bool - --- | Dependency information about ALL modules and packages below this one --- in the import hierarchy. --- --- Invariant: the dependencies of a module @M@ never includes @M@. --- --- Invariant: none of the lists contain duplicates. -data Dependencies - = Deps { dep_mods :: [(ModuleName, IsBootInterface)] - -- ^ All home-package modules transitively below this one - -- I.e. modules that this one imports, or that are in the - -- dep_mods of those directly-imported modules - - , dep_pkgs :: [(InstalledUnitId, Bool)] - -- ^ All packages transitively below this module - -- I.e. packages to which this module's direct imports belong, - -- or that are in the dep_pkgs of those modules - -- The bool indicates if the package is required to be - -- trusted when the module is imported as a safe import - -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively] - - , dep_orphs :: [Module] - -- ^ Transitive closure of orphan modules (whether - -- home or external pkg). - -- - -- (Possible optimization: don't include family - -- instance orphans as they are anyway included in - -- 'dep_finsts'. But then be careful about code - -- which relies on dep_orphs having the complete list!) - -- This does NOT include us, unlike 'imp_orphs'. - - , dep_finsts :: [Module] - -- ^ Transitive closure of depended upon modules which - -- contain family instances (whether home or external). - -- This is used by 'checkFamInstConsistency'. This - -- does NOT include us, unlike 'imp_finsts'. See Note - -- [The type family instance consistency story]. - - , dep_plgins :: [ModuleName] - -- ^ All the plugins used while compiling this module. - } - deriving( Eq ) - -- Equality used only for old/new comparison in MkIface.addFingerprints - -- See 'TcRnTypes.ImportAvails' for details on dependencies. - -instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - put_ bh (dep_finsts deps) - put_ bh (dep_plgins deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - fis <- get bh - pl <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, - dep_finsts = fis, dep_plgins = pl }) - -noDependencies :: Dependencies -noDependencies = Deps [] [] [] [] [] - --- | Records modules for which changes may force recompilation of this module --- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance --- --- This differs from Dependencies. A module X may be in the dep_mods of this --- module (via an import chain) but if we don't use anything from X it won't --- appear in our Usage -data Usage - -- | Module from another package - = UsagePackageModule { - usg_mod :: Module, - -- ^ External package module depended on - usg_mod_hash :: Fingerprint, - -- ^ Cached module fingerprint - usg_safe :: IsSafeImport - -- ^ Was this module imported as a safe import - } - -- | Module from the current package - | UsageHomeModule { - usg_mod_name :: ModuleName, - -- ^ Name of the module - usg_mod_hash :: Fingerprint, - -- ^ Cached module fingerprint - usg_entities :: [(OccName,Fingerprint)], - -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. - -- NB: usages are for parent names only, e.g. type constructors - -- but not the associated data constructors. - usg_exports :: Maybe Fingerprint, - -- ^ Fingerprint for the export list of this module, - -- if we directly imported it (and hence we depend on its export list) - usg_safe :: IsSafeImport - -- ^ Was this module imported as a safe import - } -- ^ Module from the current package - -- | A file upon which the module depends, e.g. a CPP #include, or using TH's - -- 'addDependentFile' - | UsageFile { - usg_file_path :: FilePath, - -- ^ External file dependency. From a CPP #include or TH - -- addDependentFile. Should be absolute. - usg_file_hash :: Fingerprint - -- ^ 'Fingerprint' of the file contents. - - -- Note: We don't consider things like modification timestamps - -- here, because there's no reason to recompile if the actual - -- contents don't change. This previously lead to odd - -- recompilation behaviors; see #8114 - } - -- | A requirement which was merged into this one. - | UsageMergedRequirement { - usg_mod :: Module, - usg_mod_hash :: Fingerprint - } - deriving( Eq ) - -- The export list field is (Just v) if we depend on the export list: - -- i.e. we imported the module directly, whether or not we - -- enumerated the things we imported, or just imported - -- everything - -- We need to recompile if M's exports change, because - -- if the import was import M, we might now have a name clash - -- in the importing module. - -- if the import was import M(x) M might no longer export x - -- The only way we don't depend on the export list is if we have - -- import M() - -- And of course, for modules that aren't imported directly we don't - -- depend on their export lists - -instance Binary Usage where - put_ bh usg@UsagePackageModule{} = do - putByte bh 0 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageHomeModule{} = do - putByte bh 1 - put_ bh (usg_mod_name usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageFile{} = do - putByte bh 2 - put_ bh (usg_file_path usg) - put_ bh (usg_file_hash usg) - - put_ bh usg@UsageMergedRequirement{} = do - putByte bh 3 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - - get bh = do - h <- getByte bh - case h of - 0 -> do - nm <- get bh - mod <- get bh - safe <- get bh - return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } - 1 -> do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - safe <- get bh - return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, - usg_exports = exps, usg_entities = ents, usg_safe = safe } - 2 -> do - fp <- get bh - hash <- get bh - return UsageFile { usg_file_path = fp, usg_file_hash = hash } - 3 -> do - mod <- get bh - hash <- get bh - return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } - i -> error ("Binary.get(Usage): " ++ show i) - -{- -************************************************************************ -* * - The External Package State -* * -************************************************************************ --} - -type PackageTypeEnv = TypeEnv -type PackageRuleBase = RuleBase -type PackageInstEnv = InstEnv -type PackageFamInstEnv = FamInstEnv -type PackageAnnEnv = AnnEnv -type PackageCompleteMatchMap = CompleteMatchMap - --- | Information about other packages that we have slurped in by reading --- their interface files -data ExternalPackageState - = EPS { - eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), - -- ^ In OneShot mode (only), home-package modules - -- accumulate in the external package state, and are - -- sucked in lazily. For these home-pkg modules - -- (only) we need to record which are boot modules. - -- We set this field after loading all the - -- explicitly-imported interfaces, but before doing - -- anything else - -- - -- The 'ModuleName' part is not necessary, but it's useful for - -- debug prints, and it's convenient because this field comes - -- direct from 'TcRnTypes.imp_dep_mods' - - eps_PIT :: !PackageIfaceTable, - -- ^ The 'ModIface's for modules in external packages - -- whose interfaces we have opened. - -- The declarations in these interface files are held in the - -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' - -- fields of this record, not in the 'mi_decls' fields of the - -- interface we have sucked in. - -- - -- What /is/ in the PIT is: - -- - -- * The Module - -- - -- * Fingerprint info - -- - -- * Its exports - -- - -- * Fixities - -- - -- * Deprecations and warnings - - eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), - -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on - -- the 'eps_PIT' for this information, EXCEPT that when - -- we do dependency analysis, we need to look at the - -- 'Dependencies' of our imports to determine what their - -- precise free holes are ('moduleFreeHolesPrecise'). We - -- don't want to repeatedly reread in the interface - -- for every import, so cache it here. When the PIT - -- gets filled in we can drop these entries. - - eps_PTE :: !PackageTypeEnv, - -- ^ Result of typechecking all the external package - -- interface files we have sucked in. The domain of - -- the mapping is external-package modules - - eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated - -- from all the external-package modules - eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated - -- from all the external-package modules - eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated - -- from all the external-package modules - eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated - -- from all the external-package modules - eps_complete_matches :: !PackageCompleteMatchMap, - -- ^ The total 'CompleteMatchMap' accumulated - -- from all the external-package modules - - eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external - -- packages, keyed off the module that declared them - - eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages - } - --- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. --- \"In\" means stuff that is just /read/ from interface files, --- \"Out\" means actually sucked in and type-checked -data EpsStats = EpsStats { n_ifaces_in - , n_decls_in, n_decls_out - , n_rules_in, n_rules_out - , n_insts_in, n_insts_out :: !Int } - -addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats --- ^ Add stats for one newly-read interface -addEpsInStats stats n_decls n_insts n_rules - = stats { n_ifaces_in = n_ifaces_in stats + 1 - , n_decls_in = n_decls_in stats + n_decls - , n_insts_in = n_insts_in stats + n_insts - , n_rules_in = n_rules_in stats + n_rules } - -{- -Names in a NameCache are always stored as a Global, and have the SrcLoc -of their binding locations. - -Actually that's not quite right. When we first encounter the original -name, we might not be at its binding site (e.g. we are reading an -interface file); so we give it 'noSrcLoc' then. Later, when we find -its binding site, we fix it up. --} - -updNameCache :: IORef NameCache - -> (NameCache -> (NameCache, c)) -- The updating function - -> IO c -updNameCache ncRef upd_fn - = atomicModifyIORef' ncRef upd_fn - -mkSOName :: Platform -> FilePath -> FilePath -mkSOName platform root - = case platformOS platform of - OSMinGW32 -> root <.> soExt platform - _ -> ("lib" ++ root) <.> soExt platform - -mkHsSOName :: Platform -> FilePath -> FilePath -mkHsSOName platform root = ("lib" ++ root) <.> soExt platform - -soExt :: Platform -> FilePath -soExt platform - = case platformOS platform of - OSDarwin -> "dylib" - OSMinGW32 -> "dll" - _ -> "so" - -{- -************************************************************************ -* * - The module graph and ModSummary type - A ModSummary is a node in the compilation manager's - dependency graph, and it's also passed to hscMain -* * -************************************************************************ --} - --- | A ModuleGraph contains all the nodes from the home package (only). --- There will be a node for each source module, plus a node for each hi-boot --- module. --- --- The graph is not necessarily stored in topologically-sorted order. Use --- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. -data ModuleGraph = ModuleGraph - { mg_mss :: [ModSummary] - , mg_non_boot :: ModuleEnv ModSummary - -- a map of all non-boot ModSummaries keyed by Modules - , mg_boot :: ModuleSet - -- a set of boot Modules - , mg_needs_th_or_qq :: !Bool - -- does any of the modules in mg_mss require TemplateHaskell or - -- QuasiQuotes? - } - --- | Determines whether a set of modules requires Template Haskell or --- Quasi Quotes --- --- Note that if the session's 'DynFlags' enabled Template Haskell when --- 'depanal' was called, then each module in the returned module graph will --- have Template Haskell enabled whether it is actually needed or not. -needsTemplateHaskellOrQQ :: ModuleGraph -> Bool -needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg - --- | Map a function 'f' over all the 'ModSummaries'. --- To preserve invariants 'f' can't change the isBoot status. -mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph -mapMG f mg@ModuleGraph{..} = mg - { mg_mss = map f mg_mss - , mg_non_boot = mapModuleEnv f mg_non_boot - } - -mgBootModules :: ModuleGraph -> ModuleSet -mgBootModules ModuleGraph{..} = mg_boot - -mgModSummaries :: ModuleGraph -> [ModSummary] -mgModSummaries = mg_mss - -mgElemModule :: ModuleGraph -> Module -> Bool -mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot - --- | Look up a ModSummary in the ModuleGraph -mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary -mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m - -emptyMG :: ModuleGraph -emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False - -isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool -isTemplateHaskellOrQQNonBoot ms = - (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) - || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && - not (isBootSummary ms) - --- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is --- not an element of the ModuleGraph. -extendMG :: ModuleGraph -> ModSummary -> ModuleGraph -extendMG ModuleGraph{..} ms = ModuleGraph - { mg_mss = ms:mg_mss - , mg_non_boot = if isBootSummary ms - then mg_non_boot - else extendModuleEnv mg_non_boot (ms_mod ms) ms - , mg_boot = if isBootSummary ms - then extendModuleSet mg_boot (ms_mod ms) - else mg_boot - , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms - } - -mkModuleGraph :: [ModSummary] -> ModuleGraph -mkModuleGraph = foldr (flip extendMG) emptyMG - --- | A single node in a 'ModuleGraph'. The nodes of the module graph --- are one of: --- --- * A regular Haskell source module --- * A hi-boot source module --- -data ModSummary - = ModSummary { - ms_mod :: Module, - -- ^ Identity of the module - ms_hsc_src :: HscSource, - -- ^ The module source either plain Haskell or hs-boot - ms_location :: ModLocation, - -- ^ Location of the various files belonging to the module - ms_hs_date :: UTCTime, - -- ^ Timestamp of source file - ms_obj_date :: Maybe UTCTime, - -- ^ Timestamp of object, if we have one - ms_iface_date :: Maybe UTCTime, - -- ^ Timestamp of hi file, if we *only* are typechecking (it is - -- 'Nothing' otherwise. - -- See Note [Recompilation checking in -fno-code mode] and #9243 - ms_hie_date :: Maybe UTCTime, - -- ^ Timestamp of hie file, if we have one - ms_srcimps :: [(Maybe FastString, Located ModuleName)], - -- ^ Source imports of the module - ms_textual_imps :: [(Maybe FastString, Located ModuleName)], - -- ^ Non-source imports of the module from the module *text* - ms_parsed_mod :: Maybe HsParsedModule, - -- ^ The parsed, nonrenamed source, if we have it. This is also - -- used to support "inline module syntax" in Backpack files. - ms_hspp_file :: FilePath, - -- ^ Filename of preprocessed source file - ms_hspp_opts :: DynFlags, - -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ - -- pragmas in the modules source code - ms_hspp_buf :: Maybe StringBuffer - -- ^ The actual preprocessed source, if we have it - } - -ms_installed_mod :: ModSummary -> InstalledModule -ms_installed_mod = fst . splitModuleInsts . ms_mod - -ms_mod_name :: ModSummary -> ModuleName -ms_mod_name = moduleName . ms_mod - -ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] -ms_imps ms = - ms_textual_imps ms ++ - map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) - where - mk_additional_import mod_nm = (Nothing, noLoc mod_nm) - -home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] -home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, - isLocal mb_pkg ] - where isLocal Nothing = True - isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special - isLocal _ = False - -ms_home_allimps :: ModSummary -> [ModuleName] -ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) - --- | Like 'ms_home_imps', but for SOURCE imports. -ms_home_srcimps :: ModSummary -> [Located ModuleName] -ms_home_srcimps = home_imps . ms_srcimps - --- | All of the (possibly) home module imports from a --- 'ModSummary'; that is to say, each of these module names --- could be a home import if an appropriately named file --- existed. (This is in contrast to package qualified --- imports, which are guaranteed not to be home imports.) -ms_home_imps :: ModSummary -> [Located ModuleName] -ms_home_imps = home_imps . ms_imps - --- The ModLocation contains both the original source filename and the --- filename of the cleaned-up source file after all preprocessing has been --- done. The point is that the summariser will have to cpp/unlit/whatever --- all files anyway, and there's no point in doing this twice -- just --- park the result in a temp file, put the name of it in the location, --- and let @compile@ read from that file on the way back up. - --- The ModLocation is stable over successive up-sweeps in GHCi, wheres --- the ms_hs_date and imports can, of course, change - -msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath -msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) -msHiFilePath ms = ml_hi_file (ms_location ms) -msObjFilePath ms = ml_obj_file (ms_location ms) - -msDynObjFilePath :: ModSummary -> DynFlags -> FilePath -msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms) - --- | Did this 'ModSummary' originate from a hs-boot file? -isBootSummary :: ModSummary -> Bool -isBootSummary ms = ms_hsc_src ms == HsBootFile - -instance Outputable ModSummary where - ppr ms - = sep [text "ModSummary {", - nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), - text "ms_mod =" <+> ppr (ms_mod ms) - <> text (hscSourceString (ms_hsc_src ms)) <> comma, - text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), - text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), - char '}' - ] - -showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String -showModMsg dflags target recomp mod_summary = showSDoc dflags $ - if gopt Opt_HideSourcePaths dflags - then text mod_str - else hsep $ - [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') - , char '(' - , text (op $ msHsFilePath mod_summary) <> char ',' - ] ++ - if gopt Opt_BuildDynamicToo dflags - then [ text obj_file <> char ',' - , text dyn_file - , char ')' - ] - else [ text obj_file, char ')' ] - where - op = normalise - mod = moduleName (ms_mod mod_summary) - mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) - dyn_file = op $ msDynObjFilePath mod_summary dflags - obj_file = case target of - HscInterpreted | recomp -> "interpreted" - HscNothing -> "nothing" - _ -> (op $ msObjFilePath mod_summary) - -{- -************************************************************************ -* * -\subsection{Recompilation} -* * -************************************************************************ --} - --- | Indicates whether a given module's source has been modified since it --- was last compiled. -data SourceModified - = SourceModified - -- ^ the source has been modified - | SourceUnmodified - -- ^ the source has not been modified. Compilation may or may - -- not be necessary, depending on whether any dependencies have - -- changed since we last compiled. - | SourceUnmodifiedAndStable - -- ^ the source has not been modified, and furthermore all of - -- its (transitive) dependencies are up to date; it definitely - -- does not need to be recompiled. This is important for two - -- reasons: (a) we can omit the version check in checkOldIface, - -- and (b) if the module used TH splices we don't need to force - -- recompilation. - -{- -************************************************************************ -* * -\subsection{Hpc Support} -* * -************************************************************************ --} - --- | Information about a modules use of Haskell Program Coverage -data HpcInfo - = HpcInfo - { hpcInfoTickCount :: Int - , hpcInfoHash :: Int - } - | NoHpcInfo - { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? - } - --- | This is used to signal if one of my imports used HPC instrumentation --- even if there is no module-local HPC usage -type AnyHpcUsage = Bool - -emptyHpcInfo :: AnyHpcUsage -> HpcInfo -emptyHpcInfo = NoHpcInfo - --- | Find out if HPC is used by this module or any of the modules --- it depends upon -isHpcUsed :: HpcInfo -> AnyHpcUsage -isHpcUsed (HpcInfo {}) = True -isHpcUsed (NoHpcInfo { hpcUsed = used }) = used - -{- -************************************************************************ -* * -\subsection{Safe Haskell Support} -* * -************************************************************************ - -This stuff here is related to supporting the Safe Haskell extension, -primarily about storing under what trust type a module has been compiled. --} - --- | Is an import a safe import? -type IsSafeImport = Bool - --- | Safe Haskell information for 'ModIface' --- Simply a wrapper around SafeHaskellMode to sepperate iface and flags -newtype IfaceTrustInfo = TrustInfo SafeHaskellMode - -getSafeMode :: IfaceTrustInfo -> SafeHaskellMode -getSafeMode (TrustInfo x) = x - -setSafeMode :: SafeHaskellMode -> IfaceTrustInfo -setSafeMode = TrustInfo - -noIfaceTrustInfo :: IfaceTrustInfo -noIfaceTrustInfo = setSafeMode Sf_None - -trustInfoToNum :: IfaceTrustInfo -> Word8 -trustInfoToNum it - = case getSafeMode it of - Sf_None -> 0 - Sf_Unsafe -> 1 - Sf_Trustworthy -> 2 - Sf_Safe -> 3 - Sf_SafeInferred -> 4 - Sf_Ignore -> 0 - -numToTrustInfo :: Word8 -> IfaceTrustInfo -numToTrustInfo 0 = setSafeMode Sf_None -numToTrustInfo 1 = setSafeMode Sf_Unsafe -numToTrustInfo 2 = setSafeMode Sf_Trustworthy -numToTrustInfo 3 = setSafeMode Sf_Safe -numToTrustInfo 4 = setSafeMode Sf_SafeInferred -numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" - -instance Outputable IfaceTrustInfo where - ppr (TrustInfo Sf_None) = text "none" - ppr (TrustInfo Sf_Ignore) = text "none" - ppr (TrustInfo Sf_Unsafe) = text "unsafe" - ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" - ppr (TrustInfo Sf_Safe) = text "safe" - ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred" - -instance Binary IfaceTrustInfo where - put_ bh iftrust = putByte bh $ trustInfoToNum iftrust - get bh = getByte bh >>= (return . numToTrustInfo) - -{- -************************************************************************ -* * -\subsection{Parser result} -* * -************************************************************************ --} - -data HsParsedModule = HsParsedModule { - hpm_module :: Located (HsModule GhcPs), - hpm_src_files :: [FilePath], - -- ^ extra source files (e.g. from #includes). The lexer collects - -- these from '# ' pragmas, which the C preprocessor - -- leaves behind. These files and their timestamps are stored in - -- the .hi file, so that we can force recompilation if any of - -- them change (#3589) - hpm_annotations :: ApiAnns - -- See note [Api annotations] in ApiAnnotation.hs - } - -{- -************************************************************************ -* * -\subsection{Linkable stuff} -* * -************************************************************************ - -This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs -stuff is the *dynamic* linker, and isn't present in a stage-1 compiler --} - -isObjectLinkable :: Linkable -> Bool -isObjectLinkable l = not (null unlinked) && all isObject unlinked - where unlinked = linkableUnlinked l - -- A linkable with no Unlinked's is treated as a BCO. We can - -- generate a linkable with no Unlinked's as a result of - -- compiling a module in HscNothing mode, and this choice - -- happens to work well with checkStability in module GHC. - -linkableObjs :: Linkable -> [FilePath] -linkableObjs l = [ f | DotO f <- linkableUnlinked l ] - -------------------------------------------- - --- | Is this an actual file on disk we can link in somehow? -isObject :: Unlinked -> Bool -isObject (DotO _) = True -isObject (DotA _) = True -isObject (DotDLL _) = True -isObject _ = False - --- | Is this a bytecode linkable with no file on disk? -isInterpretable :: Unlinked -> Bool -isInterpretable = not . isObject - --- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object -nameOfObject :: Unlinked -> FilePath -nameOfObject (DotO fn) = fn -nameOfObject (DotA fn) = fn -nameOfObject (DotDLL fn) = fn -nameOfObject other = pprPanic "nameOfObject" (ppr other) - --- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable -byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc _) = bc -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) - - -------------------------------------------- - --- | A list of conlikes which represents a complete pattern match. --- These arise from @COMPLETE@ signatures. - --- See Note [Implementation of COMPLETE signatures] -data CompleteMatch = CompleteMatch { - completeMatchConLikes :: [Name] - -- ^ The ConLikes that form a covering family - -- (e.g. Nothing, Just) - , completeMatchTyCon :: Name - -- ^ The TyCon that they cover (e.g. Maybe) - } - -instance Outputable CompleteMatch where - ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl - <+> dcolon <+> ppr ty - --- | A map keyed by the 'completeMatchTyCon'. - --- See Note [Implementation of COMPLETE signatures] -type CompleteMatchMap = UniqFM [CompleteMatch] - -mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap -mkCompleteMatchMap = extendCompleteMatchMap emptyUFM - -extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] - -> CompleteMatchMap -extendCompleteMatchMap = foldl' insertMatch - where - insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap - insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] - -{- -Note [Implementation of COMPLETE signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A COMPLETE signature represents a set of conlikes (i.e., constructors or -pattern synonyms) such that if they are all pattern-matched against in a -function, it gives rise to a total function. An example is: - - newtype Boolean = Boolean Int - pattern F, T :: Boolean - pattern F = Boolean 0 - pattern T = Boolean 1 - {-# COMPLETE F, T #-} - - -- This is a total function - booleanToInt :: Boolean -> Int - booleanToInt F = 0 - booleanToInt T = 1 - -COMPLETE sets are represented internally in GHC with the CompleteMatch data -type. For example, {-# COMPLETE F, T #-} would be represented as: - - CompleteMatch { complateMatchConLikes = [F, T] - , completeMatchTyCon = Boolean } - -Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the -cases in which it's ambiguous, you can also explicitly specify it in the source -language by writing this: - - {-# COMPLETE F, T :: Boolean #-} - -For efficiency purposes, GHC collects all of the CompleteMatches that it knows -about into a CompleteMatchMap, which is a map that is keyed by the -completeMatchTyCon. In other words, you could have a multiple COMPLETE sets -for the same TyCon: - - {-# COMPLETE F, T1 :: Boolean #-} - {-# COMPLETE F, T2 :: Boolean #-} - -And looking up the values in the CompleteMatchMap associated with Boolean -would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. -dsGetCompleteMatches in DsMeta accomplishes this lookup. - -Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed -explanation for how GHC ensures that all the conlikes in a COMPLETE set are -consistent. --} - --- | Foreign language of the phase if the phase deals with a foreign code -phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang -phaseForeignLanguage phase = case phase of - Phase.Cc -> Just LangC - Phase.Ccxx -> Just LangCxx - Phase.Cobjc -> Just LangObjc - Phase.Cobjcxx -> Just LangObjcxx - Phase.HCc -> Just LangC - Phase.As _ -> Just LangAsm - Phase.MergeForeign -> Just RawObject - _ -> Nothing - -------------------------------------------- - --- Take care, this instance only forces to the degree necessary to --- avoid major space leaks. -instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where - rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = - rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` - f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` - rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 diff --git a/main/InteractiveEval.hs b/main/InteractiveEval.hs deleted file mode 100644 --- a/main/InteractiveEval.hs +++ /dev/null @@ -1,1266 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, - RecordWildCards, BangPatterns #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEval ( - Resume(..), History(..), - execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec, - runDecls, runDeclsWithLocation, runParsedDecls, - isStmt, hasImport, isImport, isDecl, - parseImportDecl, SingleStep(..), - abandon, abandonAll, - getResumeContext, - getHistorySpan, - getModBreaks, - getHistoryModule, - back, forward, - setContext, getContext, - availsToGlobalRdrEnv, - getNamesInScope, - getRdrNamesInScope, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - parseInstanceHead, - getInstancesForType, - getDocs, - GetDocsFailure(..), - showModule, - moduleIsBootOrNotObjectLinkable, - parseExpr, compileParsedExpr, - compileExpr, dynCompileExpr, - compileExprRemote, compileParsedExprRemote, - Term(..), obtainTermFromId, obtainTermFromVal, reconstructType - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import InteractiveEvalTypes - -import GHCi -import GHCi.Message -import GHCi.RemoteTypes -import GhcMonad -import HscMain -import GHC.Hs -import HscTypes -import InstEnv -import IfaceEnv ( newInteractiveBinder ) -import FamInstEnv ( FamInst ) -import CoreFVs ( orphNamesOfFamInst ) -import TyCon -import Type hiding( typeKind ) -import RepType -import TcType -import Constraint -import TcOrigin -import Predicate -import Var -import Id -import Name hiding ( varName ) -import NameSet -import Avail -import RdrName -import VarEnv -import ByteCodeTypes -import Linker -import DynFlags -import Unique -import UniqSupply -import MonadUtils -import Module -import PrelNames ( toDynName, pretendNameIsInScope ) -import TysWiredIn ( isCTupleTyConName ) -import Panic -import Maybes -import ErrUtils -import SrcLoc -import RtClosureInspect -import Outputable -import FastString -import Bag -import Util -import qualified Lexer (P (..), ParseResult(..), unP, mkPState) -import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport) - -import System.Directory -import Data.Dynamic -import Data.Either -import qualified Data.IntMap as IntMap -import Data.List (find,intercalate) -import Data.Map (Map) -import qualified Data.Map as Map -import StringBuffer (stringToStringBuffer) -import Control.Monad -import GHC.Exts -import Data.Array -import Exception - -import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces ) -import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) ) - -import TcEnv (tcGetInstEnvs) - -import Inst (instDFunType) -import TcSimplify (solveWanteds) -import TcRnMonad -import TcEvidence -import Data.Bifunctor (second) - -import TcSMonad (runTcS) - --- ----------------------------------------------------------------------------- --- running a statement interactively - -getResumeContext :: GhcMonad m => m [Resume] -getResumeContext = withSession (return . ic_resume . hsc_IC) - -mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History -mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) - -getHistoryModule :: History -> Module -getHistoryModule = breakInfo_module . historyBreakInfo - -getHistorySpan :: HscEnv -> History -> SrcSpan -getHistorySpan hsc_env History{..} = - let BreakInfo{..} = historyBreakInfo in - case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of - Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number - _ -> panic "getHistorySpan" - -getModBreaks :: HomeModInfo -> ModBreaks -getModBreaks hmi - | Just linkable <- hm_linkable hmi, - [BCOs cbc _] <- linkableUnlinked linkable - = fromMaybe emptyModBreaks (bc_breaks cbc) - | otherwise - = emptyModBreaks -- probably object code - -{- | Finds the enclosing top level function name -} --- ToDo: a better way to do this would be to keep hold of the decl_path computed --- by the coverage pass, which gives the list of lexically-enclosing bindings --- for each tick. -findEnclosingDecls :: HscEnv -> BreakInfo -> [String] -findEnclosingDecls hsc_env (BreakInfo modl ix) = - let hmi = expectJust "findEnclosingDecls" $ - lookupHpt (hsc_HPT hsc_env) (moduleName modl) - mb = getModBreaks hmi - in modBreaks_decls mb ! ix - --- | Update fixity environment in the current interactive context. -updateFixityEnv :: GhcMonad m => FixityEnv -> m () -updateFixityEnv fix_env = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } - --- ----------------------------------------------------------------------------- --- execStmt - --- | default ExecOptions -execOptions :: ExecOptions -execOptions = ExecOptions - { execSingleStep = RunToCompletion - , execSourceFile = "" - , execLineNumber = 1 - , execWrap = EvalThis -- just run the statement, don't wrap it in anything - } - --- | Run a statement in the current interactive context. -execStmt - :: GhcMonad m - => String -- ^ a statement (bind or expression) - -> ExecOptions - -> m ExecResult -execStmt input exec_opts@ExecOptions{..} = do - hsc_env <- getSession - - mb_stmt <- - liftIO $ - runInteractiveHsc hsc_env $ - hscParseStmtWithLocation execSourceFile execLineNumber input - - case mb_stmt of - -- empty statement / comment - Nothing -> return (ExecComplete (Right []) 0) - Just stmt -> execStmt' stmt input exec_opts - --- | Like `execStmt`, but takes a parsed statement as argument. Useful when --- doing preprocessing on the AST before execution, e.g. in GHCi (see --- GHCi.UI.runStmt). -execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult -execStmt' stmt stmt_text ExecOptions{..} = do - hsc_env <- getSession - - -- Turn off -fwarn-unused-local-binds when running a statement, to hide - -- warnings about the implicit bindings we introduce. - -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset - -- -wwarn-unused-local-binds) - let ic = hsc_IC hsc_env -- use the interactive dflags - idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds - hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }) - - r <- liftIO $ hscParsedStmt hsc_env' stmt - - case r of - Nothing -> - -- empty statement / comment - return (ExecComplete (Right []) 0) - Just (ids, hval, fix_env) -> do - updateFixityEnv fix_env - - status <- - withVirtualCWD $ - liftIO $ - evalStmt hsc_env' (isStep execSingleStep) (execWrap hval) - - let ic = hsc_IC hsc_env - bindings = (ic_tythings ic, ic_rn_gbl_env ic) - - size = ghciHistSize idflags' - - handleRunStatus execSingleStep stmt_text bindings ids - status (emptyHistory size) - -runDecls :: GhcMonad m => String -> m [Name] -runDecls = runDeclsWithLocation "" 1 - --- | Run some declarations and return any user-visible names that were brought --- into scope. -runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] -runDeclsWithLocation source line_num input = do - hsc_env <- getSession - decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input) - runParsedDecls decls - --- | Like `runDeclsWithLocation`, but takes parsed declarations as argument. --- Useful when doing preprocessing on the AST before execution, e.g. in GHCi --- (see GHCi.UI.runStmt). -runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name] -runParsedDecls decls = do - hsc_env <- getSession - (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls) - - setSession $ hsc_env { hsc_IC = ic } - hsc_env <- getSession - hsc_env' <- liftIO $ rttiEnvironment hsc_env - setSession hsc_env' - return $ filter (not . isDerivedOccName . nameOccName) - -- For this filter, see Note [What to show to users] - $ map getName tyThings - -{- Note [What to show to users] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to display internally-generated bindings to users. -Things like the coercion axiom for newtypes. These bindings all get -OccNames that users can't write, to avoid the possibility of name -clashes (in linker symbols). That gives a convenient way to suppress -them. The relevant predicate is OccName.isDerivedOccName. -See #11051 for more background and examples. --} - -withVirtualCWD :: GhcMonad m => m a -> m a -withVirtualCWD m = do - hsc_env <- getSession - - -- a virtual CWD is only necessary when we're running interpreted code in - -- the same process as the compiler. - if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do - - let ic = hsc_IC hsc_env - let set_cwd = do - dir <- liftIO $ getCurrentDirectory - case ic_cwd ic of - Just dir -> liftIO $ setCurrentDirectory dir - Nothing -> return () - return dir - - reset_cwd orig_dir = do - virt_dir <- liftIO $ getCurrentDirectory - hsc_env <- getSession - let old_IC = hsc_IC hsc_env - setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } - liftIO $ setCurrentDirectory orig_dir - - gbracket set_cwd reset_cwd $ \_ -> m - -parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) -parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr - -emptyHistory :: Int -> BoundedList History -emptyHistory size = nilBL size - -handleRunStatus :: GhcMonad m - => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] - -> EvalStatus_ [ForeignHValue] [HValueRef] - -> BoundedList History - -> m ExecResult - -handleRunStatus step expr bindings final_ids status history - | RunAndLogSteps <- step = tracing - | otherwise = not_tracing - where - tracing - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status - , not is_exception - = do - hsc_env <- getSession - let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) - modl = mi_module (hm_iface hmi) - breaks = getModBreaks hmi - - b <- liftIO $ - breakpointStatus hsc_env (modBreaks_flags breaks) ix - if b - then not_tracing - -- This breakpoint is explicitly enabled; we want to stop - -- instead of just logging it. - else do - apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let bi = BreakInfo modl ix - !history' = mkHistory hsc_env apStack_fhv bi `consBL` history - -- history is strict, otherwise our BoundedList is pointless. - fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt - status <- liftIO $ GHCi.resumeStmt hsc_env True fhv - handleRunStatus RunAndLogSteps expr bindings final_ids - status history' - | otherwise - = not_tracing - - not_tracing - -- Hit a breakpoint - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status - = do - hsc_env <- getSession - resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt - apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) - modl = mi_module (hm_iface hmi) - bp | is_exception = Nothing - | otherwise = Just (BreakInfo modl ix) - (hsc_env1, names, span, decl) <- liftIO $ - bindLocalsAtBreakpoint hsc_env apStack_fhv bp - let - resume = Resume - { resumeStmt = expr, resumeContext = resume_ctxt_fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack_fhv - , resumeBreakInfo = bp - , resumeSpan = span, resumeHistory = toListBL history - , resumeDecl = decl - , resumeCCS = ccs - , resumeHistoryIx = 0 } - hsc_env2 = pushResume hsc_env1 resume - - setSession hsc_env2 - return (ExecBreak names bp) - - -- Completed successfully - | EvalComplete allocs (EvalSuccess hvals) <- status - = do hsc_env <- getSession - let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids - final_names = map getName final_ids - dl = hsc_dynLinker hsc_env - liftIO $ Linker.extendLinkEnv dl (zip final_names hvals) - hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} - setSession hsc_env' - return (ExecComplete (Right final_names) allocs) - - -- Completed with an exception - | EvalComplete alloc (EvalException e) <- status - = return (ExecComplete (Left (fromSerializableException e)) alloc) - - | otherwise - = panic "not_tracing" -- actually exhaustive, but GHC can't tell - - -resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult -resumeExec canLogSpan step - = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - - case resume of - [] -> liftIO $ - throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") - (r:rs) -> do - -- unbind the temporary locals by restoring the TypeEnv from - -- before the breakpoint, and drop this Resume from the - -- InteractiveContext. - let (resume_tmp_te,resume_rdr_env) = resumeBindings r - ic' = ic { ic_tythings = resume_tmp_te, - ic_rn_gbl_env = resume_rdr_env, - ic_resume = rs } - setSession hsc_env{ hsc_IC = ic' } - - -- remove any bindings created since the breakpoint from the - -- linker's environment - let old_names = map getName resume_tmp_te - new_names = [ n | thing <- ic_tythings ic - , let n = getName thing - , not (n `elem` old_names) ] - dl = hsc_dynLinker hsc_env - liftIO $ Linker.deleteFromLinkEnv dl new_names - - case r of - Resume { resumeStmt = expr, resumeContext = fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_brkpt - , resumeSpan = span - , resumeHistory = hist } -> do - withVirtualCWD $ do - status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv - let prevHistoryLst = fromListBL 50 hist - hist' = case mb_brkpt of - Nothing -> prevHistoryLst - Just bi - | not $canLogSpan span -> prevHistoryLst - | otherwise -> mkHistory hsc_env apStack bi `consBL` - fromListBL 50 hist - handleRunStatus step expr bindings final_ids status hist' - -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) -back n = moveHist (+n) - -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) -forward n = moveHist (subtract n) - -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) -moveHist fn = do - hsc_env <- getSession - case ic_resume (hsc_IC hsc_env) of - [] -> liftIO $ - throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") - (r:rs) -> do - let ix = resumeHistoryIx r - history = resumeHistory r - new_ix = fn ix - -- - when (history `lengthLessThan` new_ix) $ liftIO $ - throwGhcExceptionIO (ProgramError "no more logged breakpoints") - when (new_ix < 0) $ liftIO $ - throwGhcExceptionIO (ProgramError "already at the beginning of the history") - - let - update_ic apStack mb_info = do - (hsc_env1, names, span, decl) <- - liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info - let ic = hsc_IC hsc_env1 - r' = r { resumeHistoryIx = new_ix } - ic' = ic { ic_resume = r':rs } - - setSession hsc_env1{ hsc_IC = ic' } - - return (names, new_ix, span, decl) - - -- careful: we want apStack to be the AP_STACK itself, not a thunk - -- around it, hence the cases are carefully constructed below to - -- make this the case. ToDo: this is v. fragile, do something better. - if new_ix == 0 - then case r of - Resume { resumeApStack = apStack, - resumeBreakInfo = mb_brkpt } -> - update_ic apStack mb_brkpt - else case history !! (new_ix - 1) of - History{..} -> - update_ic historyApStack (Just historyBreakInfo) - - --- ----------------------------------------------------------------------------- --- After stopping at a breakpoint, add free variables to the environment - -result_fs :: FastString -result_fs = fsLit "_result" - -bindLocalsAtBreakpoint - :: HscEnv - -> ForeignHValue - -> Maybe BreakInfo - -> IO (HscEnv, [Name], SrcSpan, String) - --- Nothing case: we stopped when an exception was raised, not at a --- breakpoint. We have no location information or local variables to --- bind, all we can do is bind a local variable to the exception --- value. -bindLocalsAtBreakpoint hsc_env apStack Nothing = do - let exn_occ = mkVarOccFS (fsLit "_exception") - span = mkGeneralSrcSpan (fsLit "") - exn_name <- newInteractiveBinder hsc_env exn_occ span - - let e_fs = fsLit "e" - e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span - e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind - exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) - - ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] - dl = hsc_dynLinker hsc_env - -- - Linker.extendLinkEnv dl [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "") - --- Just case: we stopped at a breakpoint, we have information about the location --- of the breakpoint and the free variables of the expression. -bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do - let - hmi = expectJust "bindLocalsAtBreakpoint" $ - lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) - breaks = getModBreaks hmi - info = expectJust "bindLocalsAtBreakpoint2" $ - IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) - mbVars = cgb_vars info - result_ty = cgb_resty info - occs = modBreaks_vars breaks ! breakInfo_number - span = modBreaks_locs breaks ! breakInfo_number - decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number - - -- Filter out any unboxed ids by changing them to Nothings; - -- we can't bind these at the prompt - mbPointers = nullUnboxed <$> mbVars - - (ids, offsets, occs') = syncOccs mbPointers occs - - free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids) - - -- It might be that getIdValFromApStack fails, because the AP_STACK - -- has been accidentally evaluated, or something else has gone wrong. - -- So that we don't fall over in a heap when this happens, just don't - -- bind any free variables instead, and we emit a warning. - mb_hValues <- - mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets - when (any isNothing mb_hValues) $ - debugTraceMsg (hsc_dflags hsc_env) 1 $ - text "Warning: _result has been evaluated, some bindings have been lost" - - us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time - let tv_subst = newTyVars us free_tvs - (filtered_ids, occs'') = unzip -- again, sync the occ-names - [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ] - (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $ - map (substTy tv_subst . idType) filtered_ids - - new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids - result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span - - let result_id = Id.mkVanillaGlobal result_name - (substTy tv_subst result_ty) - result_ok = isPointer result_id - - final_ids | result_ok = result_id : new_ids - | otherwise = new_ids - ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids - names = map idName new_ids - dl = hsc_dynLinker hsc_env - - let fhvs = catMaybes mb_hValues - Linker.extendLinkEnv dl (zip names fhvs) - when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)] - hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names, span, decl) - where - -- We need a fresh Unique for each Id we bind, because the linker - -- state is single-threaded and otherwise we'd spam old bindings - -- whenever we stop at a breakpoint. The InteractveContext is properly - -- saved/restored, but not the linker state. See #1743, test break026. - mkNewId :: OccName -> Type -> Id -> IO Id - mkNewId occ ty old_id - = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) - ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } - - newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst - -- Similarly, clone the type variables mentioned in the types - -- we have here, *and* make them all RuntimeUnk tyvars - newTyVars us tvs - = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) - | (tv, uniq) <- tvs `zip` uniqsFromSupply us - , let name = setNameUnique (tyVarName tv) uniq ] - - isPointer id | [rep] <- typePrimRep (idType id) - , isGcPtrRep rep = True - | otherwise = False - - -- Convert unboxed Id's to Nothings - nullUnboxed (Just (fv@(id, _))) - | isPointer id = Just fv - | otherwise = Nothing - nullUnboxed Nothing = Nothing - - -- See Note [Syncing breakpoint info] - syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c]) - syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs - where - joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)] - joinOccs = zipWith joinOcc - joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc - -rttiEnvironment :: HscEnv -> IO HscEnv -rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - incompletelyTypedIds = - [id | id <- tmp_ids - , not $ noSkolems id - , (occNameFS.nameOccName.idName) id /= result_fs] - hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) - return hsc_env' - where - noSkolems = noFreeVarsOfType . idType - improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - Just id = find (\i -> idName i == name) tmp_ids - if noSkolems id - then return hsc_env - else do - mb_new_ty <- reconstructType hsc_env 10 id - let old_ty = idType id - case mb_new_ty of - Nothing -> return hsc_env - Just new_ty -> do - case improveRTTIType hsc_env old_ty new_ty of - Nothing -> return $ - WARN(True, text (":print failed to calculate the " - ++ "improvement for a type")) hsc_env - Just subst -> do - let dflags = hsc_dflags hsc_env - dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" - (fsep [text "RTTI Improvement for", ppr id, equals, - ppr subst]) - - let ic' = substInteractiveContext ic subst - return hsc_env{hsc_IC=ic'} - -pushResume :: HscEnv -> Resume -> HscEnv -pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } - where - ictxt0 = hsc_IC hsc_env - ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } - - - {- - Note [Syncing breakpoint info] - - To display the values of the free variables for a single breakpoint, the - function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint` pulls - out the information from the fields `modBreaks_breakInfo` and - `modBreaks_vars` of the `ModBreaks` data structure. - For a specific breakpoint this gives 2 lists of type `Id` (or `Var`) - and `OccName`. - They are used to create the Id's for the free variables and must be kept - in sync! - - There are 3 situations where items are removed from the Id list - (or replaced with `Nothing`): - 1.) If function `compiler/ghci/ByteCodeGen.hs:schemeER_wrk` (which creates - the Id list) doesn't find an Id in the ByteCode environement. - 2.) If function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint` - filters out unboxed elements from the Id list, because GHCi cannot - yet handle them. - 3.) If the GHCi interpreter doesn't find the reference to a free variable - of our breakpoint. This also happens in the function - bindLocalsAtBreakpoint. - - If an element is removed from the Id list, then the corresponding element - must also be removed from the Occ list. Otherwise GHCi will confuse - variable names as in #8487. - -} - --- ----------------------------------------------------------------------------- --- Abandoning a resume context - -abandon :: GhcMonad m => m Bool -abandon = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - case resume of - [] -> return False - r:rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = rs } } - liftIO $ abandonStmt hsc_env (resumeContext r) - return True - -abandonAll :: GhcMonad m => m Bool -abandonAll = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - case resume of - [] -> return False - rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = [] } } - liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs - return True - --- ----------------------------------------------------------------------------- --- Bounded list, optimised for repeated cons - -data BoundedList a = BL - {-# UNPACK #-} !Int -- length - {-# UNPACK #-} !Int -- bound - [a] -- left - [a] -- right, list is (left ++ reverse right) - -nilBL :: Int -> BoundedList a -nilBL bound = BL 0 bound [] [] - -consBL :: a -> BoundedList a -> BoundedList a -consBL a (BL len bound left right) - | len < bound = BL (len+1) bound (a:left) right - | null right = BL len bound [a] $! tail (reverse left) - | otherwise = BL len bound (a:left) $! tail right - -toListBL :: BoundedList a -> [a] -toListBL (BL _ _ left right) = left ++ reverse right - -fromListBL :: Int -> [a] -> BoundedList a -fromListBL bound l = BL (length l) bound l [] - --- lenBL (BL len _ _ _) = len - --- ----------------------------------------------------------------------------- --- | Set the interactive evaluation context. --- --- (setContext imports) sets the ic_imports field (which in turn --- determines what is in scope at the prompt) to 'imports', and --- constructs the ic_rn_glb_env environment to reflect it. --- --- We retain in scope all the things defined at the prompt, and kept --- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) - -setContext :: GhcMonad m => [InteractiveImport] -> m () -setContext imports - = do { hsc_env <- getSession - ; let dflags = hsc_dflags hsc_env - ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports - ; case all_env_err of - Left (mod, err) -> - liftIO $ throwGhcExceptionIO (formatError dflags mod err) - Right all_env -> do { - ; let old_ic = hsc_IC hsc_env - !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic - ; setSession - hsc_env{ hsc_IC = old_ic { ic_imports = imports - , ic_rn_gbl_env = final_rdr_env }}}} - where - formatError dflags mod err = ProgramError . showSDoc dflags $ - text "Cannot add module" <+> ppr mod <+> - text "to context:" <+> text err - -findGlobalRdrEnv :: HscEnv -> [InteractiveImport] - -> IO (Either (ModuleName, String) GlobalRdrEnv) --- Compute the GlobalRdrEnv for the interactive context -findGlobalRdrEnv hsc_env imports - = do { idecls_env <- hscRnImportDecls hsc_env idecls - -- This call also loads any orphan modules - ; return $ case partitionEithers (map mkEnv imods) of - ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) - (err : _, _) -> Left err } - where - idecls :: [LImportDecl GhcPs] - idecls = [noLoc d | IIDecl d <- imports] - - imods :: [ModuleName] - imods = [m | IIModule m <- imports] - - mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of - Left err -> Left (mod, err) - Right env -> Right env - -availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv -availsToGlobalRdrEnv mod_name avails - = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) - where - -- We're building a GlobalRdrEnv as if the user imported - -- all the specified modules into the global interactive module - imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } - -mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv -mkTopLevEnv hpt modl - = case lookupHpt hpt modl of - Nothing -> Left "not a home module" - Just details -> - case mi_globals (hm_iface details) of - Nothing -> Left "not interpreted" - Just env -> Right env - --- | Get the interactive evaluation context, consisting of a pair of the --- set of modules from which we take the full top-level scope, and the set --- of modules from which we take just the exports respectively. -getContext :: GhcMonad m => m [InteractiveImport] -getContext = withSession $ \HscEnv{ hsc_IC=ic } -> - return (ic_imports ic) - --- | Returns @True@ if the specified module is interpreted, and hence has --- its full top-level scope available. -moduleIsInterpreted :: GhcMonad m => Module -> m Bool -moduleIsInterpreted modl = withSession $ \h -> - if moduleUnitId modl /= thisPackage (hsc_dflags h) - then return False - else case lookupHpt (hsc_HPT h) (moduleName modl) of - Just details -> return (isJust (mi_globals (hm_iface details))) - _not_a_home_module -> return False - --- | Looks up an identifier in the current interactive context (for :info) --- Filter the instances by the ones whose tycons (or clases resp) --- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! --- The exact choice of which ones to show, and which to hide, is a judgement call. --- (see #1581) -getInfo :: GhcMonad m => Bool -> Name - -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc)) -getInfo allInfo name - = withSession $ \hsc_env -> - do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name - case mb_stuff of - Nothing -> return Nothing - Just (thing, fixity, cls_insts, fam_insts, docs) -> do - let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) - - -- Filter the instances based on whether the constituent names of their - -- instance heads are all in scope. - let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts - fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts - return (Just (thing, fixity, cls_insts', fam_insts', docs)) - where - plausible rdr_env names - -- Dfun involving only names that are in ic_rn_glb_env - = allInfo - || nameSetAll ok names - where -- A name is ok if it's in the rdr_env, - -- whether qualified or not - ok n | n == name = True - -- The one we looked for in the first place! - | pretendNameIsInScope n = True - | isBuiltInSyntax n = True - | isCTupleTyConName n = True - | isExternalName n = isJust (lookupGRE_Name rdr_env n) - | otherwise = True - --- | Returns all names in scope in the current interactive context -getNamesInScope :: GhcMonad m => m [Name] -getNamesInScope = withSession $ \hsc_env -> do - return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) - --- | Returns all 'RdrName's in scope in the current interactive --- context, excluding any that are internally-generated. -getRdrNamesInScope :: GhcMonad m => m [RdrName] -getRdrNamesInScope = withSession $ \hsc_env -> do - let - ic = hsc_IC hsc_env - gbl_rdrenv = ic_rn_gbl_env ic - gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv - -- Exclude internally generated names; see e.g. #11328 - return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names) - - --- | Parses a string as an identifier, and returns the list of 'Name's that --- the identifier can refer to in the current interactive context. -parseName :: GhcMonad m => String -> m [Name] -parseName str = withSession $ \hsc_env -> liftIO $ - do { lrdr_name <- hscParseIdentifier hsc_env str - ; hscTcRnLookupRdrName hsc_env lrdr_name } - --- | Returns @True@ if passed string is a statement. -isStmt :: DynFlags -> String -> Bool -isStmt dflags stmt = - case parseThing Parser.parseStmt dflags stmt of - Lexer.POk _ _ -> True - Lexer.PFailed _ -> False - --- | Returns @True@ if passed string has an import declaration. -hasImport :: DynFlags -> String -> Bool -hasImport dflags stmt = - case parseThing Parser.parseModule dflags stmt of - Lexer.POk _ thing -> hasImports thing - Lexer.PFailed _ -> False - where - hasImports = not . null . hsmodImports . unLoc - --- | Returns @True@ if passed string is an import declaration. -isImport :: DynFlags -> String -> Bool -isImport dflags stmt = - case parseThing Parser.parseImport dflags stmt of - Lexer.POk _ _ -> True - Lexer.PFailed _ -> False - --- | Returns @True@ if passed string is a declaration but __/not a splice/__. -isDecl :: DynFlags -> String -> Bool -isDecl dflags stmt = do - case parseThing Parser.parseDeclaration dflags stmt of - Lexer.POk _ thing -> - case unLoc thing of - SpliceD _ _ -> False - _ -> True - Lexer.PFailed _ -> False - -parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing -parseThing parser dflags stmt = do - let buf = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit "") 1 1 - - Lexer.unP parser (Lexer.mkPState dflags buf loc) - -getDocs :: GhcMonad m - => Name - -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)) - -- TODO: What about docs for constructors etc.? -getDocs name = - withSession $ \hsc_env -> do - case nameModule_maybe name of - Nothing -> pure (Left (NameHasNoModule name)) - Just mod -> do - if isInteractiveModule mod - then pure (Left InteractiveName) - else do - ModIface { mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap - } <- liftIO $ hscGetModuleInterface hsc_env mod - if isNothing mb_doc_hdr && Map.null dmap && Map.null amap - then pure (Left (NoDocsInIface mod compiled)) - else pure (Right ( Map.lookup name dmap - , Map.findWithDefault Map.empty name amap)) - where - compiled = - -- TODO: Find a more direct indicator. - case nameSrcLoc name of - RealSrcLoc {} -> False - UnhelpfulLoc {} -> True - --- | Failure modes for 'getDocs'. - --- TODO: Find a way to differentiate between modules loaded without '-haddock' --- and modules that contain no docs. -data GetDocsFailure - - -- | 'nameModule_maybe' returned 'Nothing'. - = NameHasNoModule Name - - -- | This is probably because the module was loaded without @-haddock@, - -- but it's also possible that the entire module contains no documentation. - | NoDocsInIface - Module - Bool -- ^ 'True': The module was compiled. - -- 'False': The module was :loaded. - - -- | The 'Name' was defined interactively. - | InteractiveName - -instance Outputable GetDocsFailure where - ppr (NameHasNoModule name) = - quotes (ppr name) <+> text "has no module where we could look for docs." - ppr (NoDocsInIface mod compiled) = vcat - [ text "Can't find any documentation for" <+> ppr mod <> char '.' - , text "This is probably because the module was" - <+> text (if compiled then "compiled" else "loaded") - <+> text "without '-haddock'," - , text "but it's also possible that the module contains no documentation." - , text "" - , if compiled - then text "Try re-compiling with '-haddock'." - else text "Try running ':set -haddock' and :load the file again." - -- TODO: Figure out why :reload doesn't load the docs and maybe fix it. - ] - ppr InteractiveName = - text "Docs are unavailable for interactive declarations." - --- ----------------------------------------------------------------------------- --- Getting the type of an expression - --- | Get the type of an expression --- Returns the type as described by 'TcRnExprMode' -exprType :: GhcMonad m => TcRnExprMode -> String -> m Type -exprType mode expr = withSession $ \hsc_env -> do - ty <- liftIO $ hscTcExpr hsc_env mode expr - return $ tidyType emptyTidyEnv ty - --- ----------------------------------------------------------------------------- --- Getting the kind of a type - --- | Get the kind of a type -typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) -typeKind normalise str = withSession $ \hsc_env -> do - liftIO $ hscKcType hsc_env normalise str - --- ---------------------------------------------------------------------------- --- Getting the class instances for a type - -{- - Note [Querying instances for a type] - - Here is the implementation of GHC proposal 41. - (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst) - - The objective is to take a query string representing a (partial) type, and - report all the class single-parameter class instances available to that type. - Extending this feature to multi-parameter typeclasses is left as future work. - - The general outline of how we solve this is: - - 1. Parse the type, leaving skolems in the place of type-holes. - 2. For every class, get a list of all instances that match with the query type. - 3. For every matching instance, ask GHC for the context the instance dictionary needs. - 4. Format and present the results, substituting our query into the instance - and simplifying the context. - - For example, given the query "Maybe Int", we want to return: - - instance Show (Maybe Int) - instance Read (Maybe Int) - instance Eq (Maybe Int) - .... - - [Holes in queries] - - Often times we want to know what instances are available for a polymorphic type, - like `Maybe a`, and we'd like to return instances such as: - - instance Show a => Show (Maybe a) - .... - - These queries are expressed using type holes, so instead of `Maybe a` the user writes - `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes - with (un-named) type variables. - - When zonking the type holes we have two real choices: replace them with Any or replace - them with skolem typevars. Using skolem type variables ensures that the output is more - intuitive to end users, and there is no difference in the results between Any and skolems. - --} - --- Find all instances that match a provided type -getInstancesForType :: GhcMonad m => Type -> m [ClsInst] -getInstancesForType ty = withSession $ \hsc_env -> do - liftIO $ runInteractiveHsc hsc_env $ do - ioMsgMaybe $ runTcInteractive hsc_env $ do - -- Bring class and instances from unqualified modules into scope, this fixes #16793. - loadUnqualIfaces hsc_env (hsc_IC hsc_env) - matches <- findMatchingInstances ty - fmap catMaybes . forM matches $ uncurry checkForExistence - --- Parse a type string and turn any holes into skolems -parseInstanceHead :: GhcMonad m => String -> m Type -parseInstanceHead str = withSession $ \hsc_env0 -> do - (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ty <- hscParseType str - ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty - - return ty - --- Get all the constraints required of a dictionary binding -getDictionaryBindings :: PredType -> TcM WantedConstraints -getDictionaryBindings theta = do - dictName <- newName (mkDictOcc (mkVarOcc "magic")) - let dict_var = mkVanillaGlobal dictName theta - loc <- getCtLocM (GivenOrigin UnkSkol) Nothing - let wCs = mkSimpleWC [CtDerived - { ctev_pred = varType dict_var - , ctev_loc = loc - }] - - return wCs - -{- - When we've found an instance that a query matches against, we still need to - check that all the instance's constraints are satisfiable. checkForExistence - creates an instance dictionary and verifies that any unsolved constraints - mention a type-hole, meaning it is blocked on an unknown. - - If the instance satisfies this condition, then we return it with the query - substituted into the instance and all constraints simplified, for example given: - - instance D a => C (MyType a b) where - - and the query `MyType _ String` - - the unsolved constraints will be [D _] so we apply the substitution: - - { a -> _; b -> String} - - and return the instance: - - instance D _ => C (MyType _ String) - --} - -checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst) -checkForExistence res mb_inst_tys = do - (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys - - wanteds <- forM thetas getDictionaryBindings - (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds)) - - let all_residual_constraints = bagToList $ wc_simple residuals - let preds = map ctPred all_residual_constraints - if all isSatisfiablePred preds && (null $ wc_impl residuals) - then return . Just $ substInstArgs tys preds res - else return Nothing - - where - - -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least - -- one argument or for the head to be a TyVar. The reason is that we want to ensure - -- that all residual constraints mention a type-hole somewhere in the constraint, - -- meaning that with the correct choice of a concrete type it could be possible for - -- the constraint to be discharged. - isSatisfiablePred :: PredType -> Bool - isSatisfiablePred ty = case getClassPredTys_maybe ty of - Just (_, tys@(_:_)) -> all isTyVarTy tys - _ -> isTyVarTy ty - - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res))) - - {- Create a ClsInst with instantiated arguments and constraints. - - The thetas are the list of constraints that couldn't be solved because - they mention a type-hole. - -} - substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst - substInstArgs tys thetas inst = let - subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys) - -- Build instance head with arguments substituted in - tau = mkClassPred cls (substTheta subst args) - -- Constrain the instance with any residual constraints - phi = mkPhiTy thetas tau - sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi - - in inst { is_dfun = (is_dfun inst) { varType = sigma }} - where - (dfun_tvs, _, cls, args) = instanceSig inst - --- Find instances where the head unifies with the provided type -findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] -findMatchingInstances ty = do - ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs - let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local - - concat <$> mapM (\cls -> do - let (matches, _, _) = lookupInstEnv True ies cls [ty] - return matches) allClasses - ------------------------------------------------------------------------------ --- Compile an expression, run it, and deliver the result - --- | Parse an expression, the parsed expression can be further processed and --- passed to compileParsedExpr. -parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) -parseExpr expr = withSession $ \hsc_env -> do - liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr - --- | Compile an expression, run it, and deliver the resulting HValue. -compileExpr :: GhcMonad m => String -> m HValue -compileExpr expr = do - parsed_expr <- parseExpr expr - compileParsedExpr parsed_expr - --- | Compile an expression, run it, and deliver the resulting HValue. -compileExprRemote :: GhcMonad m => String -> m ForeignHValue -compileExprRemote expr = do - parsed_expr <- parseExpr expr - compileParsedExprRemote parsed_expr - --- | Compile a parsed expression (before renaming), run it, and deliver --- the resulting HValue. -compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue -compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do - -- > let _compileParsedExpr = expr - -- Create let stmt from expr to make hscParsedStmt happy. - -- We will ignore the returned [Id], namely [expr_id], and not really - -- create a new binding. - let expr_fs = fsLit "_compileParsedExpr" - expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $ - ValBinds noExtField - (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] - - pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt - let (hvals_io, fix_env) = case pstmt of - Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env') - _ -> panic "compileParsedExprRemote" - - updateFixityEnv fix_env - status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io) - case status of - EvalComplete _ (EvalSuccess [hval]) -> return hval - EvalComplete _ (EvalException e) -> - liftIO $ throwIO (fromSerializableException e) - _ -> panic "compileParsedExpr" - -compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue -compileParsedExpr expr = do - fhv <- compileParsedExprRemote expr - dflags <- getDynFlags - liftIO $ wormhole dflags fhv - --- | Compile an expression, run it and return the result as a Dynamic. -dynCompileExpr :: GhcMonad m => String -> m Dynamic -dynCompileExpr expr = do - parsed_expr <- parseExpr expr - -- > Data.Dynamic.toDyn expr - let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName) - parsed_expr - hval <- compileParsedExpr to_dyn_expr - return (unsafeCoerce# hval :: Dynamic) - ------------------------------------------------------------------------------ --- show a module and it's source/object filenames - -showModule :: GhcMonad m => ModSummary -> m String -showModule mod_summary = - withSession $ \hsc_env -> do - interpreted <- moduleIsBootOrNotObjectLinkable mod_summary - let dflags = hsc_dflags hsc_env - return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) - -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool -moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return $ case hm_linkable mod_info of - Nothing -> True - Just linkable -> not (isObjectLinkable linkable) - ----------------------------------------------------------------------------- --- RTTI primitives - -obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term -obtainTermFromVal hsc_env bound force ty x - | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) - = throwIO (InstallationError - "this operation requires -fno-external-interpreter") - | otherwise - = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) - -obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term -obtainTermFromId hsc_env bound force id = do - hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env bound force (idType id) hv - --- Uses RTTI to reconstruct the type of an Id, making it less polymorphic -reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) -reconstructType hsc_env bound id = do - hv <- Linker.getHValue hsc_env (varName id) - cvReconstructType hsc_env bound (idType id) hv - -mkRuntimeUnkTyVar :: Name -> Kind -> TyVar -mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk diff --git a/main/InteractiveEvalTypes.hs b/main/InteractiveEvalTypes.hs deleted file mode 100644 --- a/main/InteractiveEvalTypes.hs +++ /dev/null @@ -1,89 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEvalTypes ( - Resume(..), History(..), ExecResult(..), - SingleStep(..), isStep, ExecOptions(..), - BreakInfo(..) - ) where - -import GhcPrelude - -import GHCi.RemoteTypes -import GHCi.Message (EvalExpr, ResumeContext) -import Id -import Name -import Module -import RdrName -import Type -import SrcLoc -import Exception - -import Data.Word -import GHC.Stack.CCS - -data ExecOptions - = ExecOptions - { execSingleStep :: SingleStep -- ^ stepping mode - , execSourceFile :: String -- ^ filename (for errors) - , execLineNumber :: Int -- ^ line number (for errors) - , execWrap :: ForeignHValue -> EvalExpr ForeignHValue - } - -data SingleStep - = RunToCompletion - | SingleStep - | RunAndLogSteps - -isStep :: SingleStep -> Bool -isStep RunToCompletion = False -isStep _ = True - -data ExecResult - = ExecComplete - { execResult :: Either SomeException [Name] - , execAllocation :: Word64 - } - | ExecBreak - { breakNames :: [Name] - , breakInfo :: Maybe BreakInfo - } - -data BreakInfo = BreakInfo - { breakInfo_module :: Module - , breakInfo_number :: Int - } - -data Resume = Resume - { resumeStmt :: String -- the original statement - , resumeContext :: ForeignRef (ResumeContext [HValueRef]) - , resumeBindings :: ([TyThing], GlobalRdrEnv) - , resumeFinalIds :: [Id] -- [Id] to bind on completion - , resumeApStack :: ForeignHValue -- The object from which we can get - -- value of the free variables. - , resumeBreakInfo :: Maybe BreakInfo - -- the breakpoint we stopped at - -- (module, index) - -- (Nothing <=> exception) - , resumeSpan :: SrcSpan -- just a copy of the SrcSpan - -- from the ModBreaks, - -- otherwise it's a pain to - -- fetch the ModDetails & - -- ModBreaks to get this. - , resumeDecl :: String -- ditto - , resumeCCS :: RemotePtr CostCentreStack - , resumeHistory :: [History] - , resumeHistoryIx :: Int -- 0 <==> at the top of the history - } - -data History - = History { - historyApStack :: ForeignHValue, - historyBreakInfo :: BreakInfo, - historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint - } diff --git a/main/PackageConfig.hs b/main/PackageConfig.hs deleted file mode 100644 --- a/main/PackageConfig.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} - --- | --- Package configuration information: essentially the interface to Cabal, with --- some utilities --- --- (c) The University of Glasgow, 2004 --- -module PackageConfig ( - -- $package_naming - - -- * UnitId - packageConfigId, - expandedPackageConfigId, - definitePackageConfigId, - installedPackageConfigId, - - -- * The PackageConfig type: information about a package - PackageConfig, - InstalledPackageInfo(..), - ComponentId(..), - SourcePackageId(..), - PackageName(..), - Version(..), - defaultPackageConfig, - sourcePackageIdString, - packageNameString, - pprPackageConfig, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.PackageDb -import Data.Version - -import FastString -import Outputable -import Module -import Unique - --- ----------------------------------------------------------------------------- --- Our PackageConfig type is the InstalledPackageInfo from ghc-boot, --- which is similar to a subset of the InstalledPackageInfo type from Cabal. - -type PackageConfig = InstalledPackageInfo - ComponentId - SourcePackageId - PackageName - Module.InstalledUnitId - Module.UnitId - Module.ModuleName - Module.Module - --- TODO: there's no need for these to be FastString, as we don't need the uniq --- feature, but ghc doesn't currently have convenient support for any --- other compact string types, e.g. plain ByteString or Text. - -newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) -newtype PackageName = PackageName FastString deriving (Eq, Ord) - -instance BinaryStringRep SourcePackageId where - fromStringRep = SourcePackageId . mkFastStringByteString - toStringRep (SourcePackageId s) = bytesFS s - -instance BinaryStringRep PackageName where - fromStringRep = PackageName . mkFastStringByteString - toStringRep (PackageName s) = bytesFS s - -instance Uniquable SourcePackageId where - getUnique (SourcePackageId n) = getUnique n - -instance Uniquable PackageName where - getUnique (PackageName n) = getUnique n - -instance Outputable SourcePackageId where - ppr (SourcePackageId str) = ftext str - -instance Outputable PackageName where - ppr (PackageName str) = ftext str - -defaultPackageConfig :: PackageConfig -defaultPackageConfig = emptyInstalledPackageInfo - -sourcePackageIdString :: PackageConfig -> String -sourcePackageIdString pkg = unpackFS str - where - SourcePackageId str = sourcePackageId pkg - -packageNameString :: PackageConfig -> String -packageNameString pkg = unpackFS str - where - PackageName str = packageName pkg - -pprPackageConfig :: PackageConfig -> SDoc -pprPackageConfig InstalledPackageInfo {..} = - vcat [ - field "name" (ppr packageName), - field "version" (text (showVersion packageVersion)), - field "id" (ppr unitId), - field "exposed" (ppr exposed), - field "exposed-modules" (ppr exposedModules), - field "hidden-modules" (fsep (map ppr hiddenModules)), - field "trusted" (ppr trusted), - field "import-dirs" (fsep (map text importDirs)), - field "library-dirs" (fsep (map text libraryDirs)), - field "dynamic-library-dirs" (fsep (map text libraryDynDirs)), - field "hs-libraries" (fsep (map text hsLibraries)), - field "extra-libraries" (fsep (map text extraLibraries)), - field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)), - field "include-dirs" (fsep (map text includeDirs)), - field "includes" (fsep (map text includes)), - field "depends" (fsep (map ppr depends)), - field "cc-options" (fsep (map text ccOptions)), - field "ld-options" (fsep (map text ldOptions)), - field "framework-dirs" (fsep (map text frameworkDirs)), - field "frameworks" (fsep (map text frameworks)), - field "haddock-interfaces" (fsep (map text haddockInterfaces)), - field "haddock-html" (fsep (map text haddockHTMLs)) - ] - where - field name body = text name <> colon <+> nest 4 body - --- ----------------------------------------------------------------------------- --- UnitId (package names, versions and dep hash) - --- $package_naming --- #package_naming# --- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes --- of a package ID, keys of its dependencies, and Cabal flags. You're expected --- to pass in the unit id in the @-this-unit-id@ flag. However, for --- wired-in packages like @base@ & @rts@, we don't necessarily know what the --- version is, so these are handled specially; see #wired_in_packages#. - --- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' -installedPackageConfigId :: PackageConfig -> InstalledUnitId -installedPackageConfigId = unitId - -packageConfigId :: PackageConfig -> UnitId -packageConfigId p = - if indefinite p - then newUnitId (componentId p) (instantiatedWith p) - else DefiniteUnitId (DefUnitId (unitId p)) - -expandedPackageConfigId :: PackageConfig -> UnitId -expandedPackageConfigId p = - newUnitId (componentId p) (instantiatedWith p) - -definitePackageConfigId :: PackageConfig -> Maybe DefUnitId -definitePackageConfigId p = - case packageConfigId p of - DefiniteUnitId def_uid -> Just def_uid - _ -> Nothing diff --git a/main/PackageConfig.hs-boot b/main/PackageConfig.hs-boot deleted file mode 100644 --- a/main/PackageConfig.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module PackageConfig where -import FastString -import {-# SOURCE #-} Module -import GHC.PackageDb -newtype PackageName = PackageName FastString -newtype SourcePackageId = SourcePackageId FastString -type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module diff --git a/main/Packages.hs b/main/Packages.hs deleted file mode 100644 --- a/main/Packages.hs +++ /dev/null @@ -1,2338 +0,0 @@ --- (c) The University of Glasgow, 2006 - -{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} - --- | Package manipulation -module Packages ( - module PackageConfig, - - -- * Reading the package config, and processing cmdline args - PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext), - PackageConfigMap, - emptyPackageState, - initPackages, - readPackageConfigs, - getPackageConfRefs, - resolvePackageConfig, - readPackageConfig, - listPackageConfigMap, - - -- * Querying the package config - lookupPackage, - lookupPackage', - lookupInstalledPackage, - lookupPackageName, - improveUnitId, - searchPackageId, - getPackageDetails, - getInstalledPackageDetails, - componentIdString, - displayInstalledUnitId, - listVisibleModuleNames, - lookupModuleInAllPackages, - lookupModuleWithSuggestions, - lookupPluginModuleWithSuggestions, - LookupResult(..), - ModuleSuggestion(..), - ModuleOrigin(..), - UnusablePackageReason(..), - pprReason, - - -- * Inspecting the set of packages in scope - getPackageIncludePath, - getPackageLibraryPath, - getPackageLinkOpts, - getPackageExtraCcOpts, - getPackageFrameworkPath, - getPackageFrameworks, - getPackageConfigMap, - getPreloadPackagesAnd, - - collectArchives, - collectIncludeDirs, collectLibraryPaths, collectLinkOpts, - packageHsLibs, getLibs, - - -- * Utils - unwireUnitId, - pprFlag, - pprPackages, - pprPackagesSimple, - pprModuleMap, - isIndefinite, - isDllName - ) -where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.PackageDb -import PackageConfig -import DynFlags -import Name ( Name, nameModule_maybe ) -import UniqFM -import UniqDFM -import UniqSet -import Module -import Util -import Panic -import GHC.Platform -import Outputable -import Maybes -import CmdLineParser - -import System.Environment ( getEnv ) -import FastString -import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg, - withTiming ) -import Exception - -import System.Directory -import System.FilePath as FilePath -import qualified System.FilePath.Posix as FilePath.Posix -import System.IO.Error ( isDoesNotExistError ) -import Control.Monad -import Data.Graph (stronglyConnComp, SCC(..)) -import Data.Char ( toUpper ) -import Data.List as List -import Data.Map (Map) -import Data.Set (Set) -import Data.Monoid (First(..)) -import qualified Data.Semigroup as Semigroup -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict -import qualified Data.Set as Set -import Data.Version - --- --------------------------------------------------------------------------- --- The Package state - --- | Package state is all stored in 'DynFlags', including the details of --- all packages, which packages are exposed, and which modules they --- provide. --- --- The package state is computed by 'initPackages', and kept in DynFlags. --- It is influenced by various package flags: --- --- * @-package @ and @-package-id @ cause @@ to become exposed. --- If @-hide-all-packages@ was not specified, these commands also cause --- all other packages with the same name to become hidden. --- --- * @-hide-package @ causes @@ to become hidden. --- --- * (there are a few more flags, check below for their semantics) --- --- The package state has the following properties. --- --- * Let @exposedPackages@ be the set of packages thus exposed. --- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of --- their dependencies. --- --- * When searching for a module from a preload import declaration, --- only the exposed modules in @exposedPackages@ are valid. --- --- * When searching for a module from an implicit import, all modules --- from @depExposedPackages@ are valid. --- --- * When linking in a compilation manager mode, we link in packages the --- program depends on (the compiler knows this list by the --- time it gets to the link step). Also, we link in all packages --- which were mentioned with preload @-package@ flags on the command-line, --- or are a transitive dependency of same, or are \"base\"\/\"rts\". --- The reason for this is that we might need packages which don't --- contain any Haskell modules, and therefore won't be discovered --- by the normal mechanism of dependency tracking. - --- Notes on DLLs --- ~~~~~~~~~~~~~ --- When compiling module A, which imports module B, we need to --- know whether B will be in the same DLL as A. --- If it's in the same DLL, we refer to B_f_closure --- If it isn't, we refer to _imp__B_f_closure --- When compiling A, we record in B's Module value whether it's --- in a different DLL, by setting the DLL flag. - --- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! -data ModuleOrigin = - -- | Module is hidden, and thus never will be available for import. - -- (But maybe the user didn't realize), so we'll still keep track - -- of these modules.) - ModHidden - -- | Module is unavailable because the package is unusable. - | ModUnusable UnusablePackageReason - -- | Module is public, and could have come from some places. - | ModOrigin { - -- | @Just False@ means that this module is in - -- someone's @exported-modules@ list, but that package is hidden; - -- @Just True@ means that it is available; @Nothing@ means neither - -- applies. - fromOrigPackage :: Maybe Bool - -- | Is the module available from a reexport of an exposed package? - -- There could be multiple. - , fromExposedReexport :: [PackageConfig] - -- | Is the module available from a reexport of a hidden package? - , fromHiddenReexport :: [PackageConfig] - -- | Did the module export come from a package flag? (ToDo: track - -- more information. - , fromPackageFlag :: Bool - } - -instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" - ppr (ModUnusable _) = text "unusable module" - ppr (ModOrigin e res rhs f) = sep (punctuate comma ( - (case e of - Nothing -> [] - Just False -> [text "hidden package"] - Just True -> [text "exposed package"]) ++ - (if null res - then [] - else [text "reexport by" <+> - sep (map (ppr . packageConfigId) res)]) ++ - (if null rhs - then [] - else [text "hidden reexport by" <+> - sep (map (ppr . packageConfigId) res)]) ++ - (if f then [text "package flag"] else []) - )) - --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False - --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is expsed, and --- also its 'PackageConfig'. -fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False - --- | Smart constructor for a module which was bound by a package flag. -fromFlag :: ModuleOrigin -fromFlag = ModOrigin Nothing [] [] True - -instance Semigroup ModuleOrigin where - ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = panic "ModOrigin: package both exposed/hidden" - g Nothing x = x - g x Nothing = x - _x <> _y = panic "ModOrigin: hidden module redefined" - -instance Monoid ModuleOrigin where - mempty = ModOrigin Nothing [] [] False - mappend = (Semigroup.<>) - --- | Is the name from the import actually visible? (i.e. does it cause --- ambiguity, or is it only relevant when we're making suggestions?) -originVisible :: ModuleOrigin -> Bool -originVisible ModHidden = False -originVisible (ModUnusable _) = False -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f - --- | Are there actually no providers for this module? This will never occur --- except when we're filtering based on package imports. -originEmpty :: ModuleOrigin -> Bool -originEmpty (ModOrigin Nothing [] [] False) = True -originEmpty _ = False - --- | 'UniqFM' map from 'InstalledUnitId' -type InstalledUnitIdMap = UniqDFM - --- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus --- the transitive closure of preload packages. -data PackageConfigMap = PackageConfigMap { - unPackageConfigMap :: InstalledUnitIdMap PackageConfig, - -- | The set of transitively reachable packages according - -- to the explicitly provided command line arguments. - -- See Note [UnitId to InstalledUnitId improvement] - preloadClosure :: UniqSet InstalledUnitId - } - --- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. -type VisibilityMap = Map UnitId UnitVisibility - --- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'UnitId'. -data UnitVisibility = UnitVisibility - { uv_expose_all :: Bool - -- ^ Should all modules in exposed-modules should be dumped into scope? - , uv_renamings :: [(ModuleName, ModuleName)] - -- ^ Any custom renamings that should bring extra 'ModuleName's into - -- scope. - , uv_package_name :: First FastString - -- ^ The package name is associated with the 'UnitId'. This is used - -- to implement legacy behavior where @-package foo-0.1@ implicitly - -- hides any packages named @foo@ - , uv_requirements :: Map ModuleName (Set IndefModule) - -- ^ The signatures which are contributed to the requirements context - -- from this unit ID. - , uv_explicit :: Bool - -- ^ Whether or not this unit was explicitly brought into scope, - -- as opposed to implicitly via the 'exposed' fields in the - -- package database (when @-hide-all-packages@ is not passed.) - } - -instance Outputable UnitVisibility where - ppr (UnitVisibility { - uv_expose_all = b, - uv_renamings = rns, - uv_package_name = First mb_pn, - uv_requirements = reqs, - uv_explicit = explicit - }) = ppr (b, rns, mb_pn, reqs, explicit) - -instance Semigroup UnitVisibility where - uv1 <> uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) - , uv_explicit = uv_explicit uv1 || uv_explicit uv2 - } - -instance Monoid UnitVisibility where - mempty = UnitVisibility - { uv_expose_all = False - , uv_renamings = [] - , uv_package_name = First Nothing - , uv_requirements = Map.empty - , uv_explicit = False - } - mappend = (Semigroup.<>) - -type WiredUnitId = DefUnitId -type PreloadUnitId = InstalledUnitId - --- | Map from 'ModuleName' to 'Module' to all the origins of the bindings --- in scope. The 'PackageConf' is not cached, mostly for convenience reasons --- (since this is the slow path, we'll just look it up again). -type ModuleToPkgConfAll = - Map ModuleName (Map Module ModuleOrigin) - -data PackageState = PackageState { - -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted - -- so that only valid packages are here. 'PackageConfig' reflects - -- what was stored *on disk*, except for the 'trusted' flag, which - -- is adjusted at runtime. (In particular, some packages in this map - -- may have the 'exposed' flag be 'False'.) - pkgIdMap :: PackageConfigMap, - - -- | A mapping of 'PackageName' to 'ComponentId'. This is used when - -- users refer to packages in Backpack includes. - packageNameMap :: Map PackageName ComponentId, - - -- | A mapping from wired in names to the original names from the - -- package database. - unwireMap :: Map WiredUnitId WiredUnitId, - - -- | The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. - preloadPackages :: [PreloadUnitId], - - -- | Packages which we explicitly depend on (from a command line flag). - -- We'll use this to generate version macros. - explicitPackages :: [UnitId], - - -- | This is a full map from 'ModuleName' to all modules which may possibly - -- be providing it. These providers may be hidden (but we'll still want - -- to report them in error messages), or it may be an ambiguous import. - moduleToPkgConfAll :: !ModuleToPkgConfAll, - - -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility. - pluginModuleToPkgConfAll :: !ModuleToPkgConfAll, - - -- | A map saying, for each requirement, what interfaces must be merged - -- together when we use them. For example, if our dependencies - -- are @p[A=]@ and @q[A=,B=r[C=]:B]@, then the interfaces - -- to merge for A are @p[A=]:A@, @q[A=,B=r[C=]:B]:A@ - -- and @r[C=]:C@. - -- - -- There's an entry in this map for each hole in our home library. - requirementContext :: Map ModuleName [IndefModule] - } - -emptyPackageState :: PackageState -emptyPackageState = PackageState { - pkgIdMap = emptyPackageConfigMap, - packageNameMap = Map.empty, - unwireMap = Map.empty, - preloadPackages = [], - explicitPackages = [], - moduleToPkgConfAll = Map.empty, - pluginModuleToPkgConfAll = Map.empty, - requirementContext = Map.empty - } - -type InstalledPackageIndex = Map InstalledUnitId PackageConfig - --- | Empty package configuration map -emptyPackageConfigMap :: PackageConfigMap -emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet - --- | Find the package we know about with the given unit id, if any -lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig -lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags)) - --- | A more specialized interface, which takes a boolean specifying --- whether or not to look for on-the-fly renamed interfaces, and --- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can --- be used while we're initializing 'DynFlags' -lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig -lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid -lookupPackage' True m@(PackageConfigMap pkg_map _) uid = - case splitUnitIdInsts uid of - (iuid, Just indef) -> - fmap (renamePackage m (indefUnitIdInsts indef)) - (lookupUDFM pkg_map iuid) - (_, Nothing) -> lookupUDFM pkg_map uid - -{- --- | Find the indefinite package for a given 'ComponentId'. --- The way this works is just by fiat'ing that every indefinite package's --- unit key is precisely its component ID; and that they share uniques. -lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig -lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs - where - PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) --} - --- | Find the package we know about with the given package name (e.g. @foo@), if any --- (NB: there might be a locally defined unit name which overrides this) -lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId -lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) - --- | Search for packages with a given package ID (e.g. \"foo-0.1\") -searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] -searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) - (listPackageConfigMap dflags) - --- | Extends the package configuration map with a list of package configs. -extendPackageConfigMap - :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs - = PackageConfigMap (foldl' add pkg_map new_pkgs) closure - -- We also add the expanded version of the packageConfigId, so that - -- 'improveUnitId' can find it. - where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) - (installedPackageConfigId p) p - --- | Looks up the package with the given id in the package state, panicing if it is --- not found -getPackageDetails :: DynFlags -> UnitId -> PackageConfig -getPackageDetails dflags pid = case lookupPackage dflags pid of - Just c -> c - Nothing -> pprPanic "getPackageDetails: couldn't find package" (ppr pid) - -lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig -lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid - -lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig -lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid - -getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig -getInstalledPackageDetails dflags uid = case lookupInstalledPackage dflags uid of - Just c -> c - Nothing -> pprPanic "getInstalledPackageDetails: couldn't find package" (ppr uid) - --- | Get a list of entries from the package database. NB: be careful with --- this function, although all packages in this map are "visible", this --- does not imply that the exposed-modules of the package are available --- (they may have been thinned or renamed). -listPackageConfigMap :: DynFlags -> [PackageConfig] -listPackageConfigMap dflags = eltsUDFM pkg_map - where - PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags) - --- ---------------------------------------------------------------------------- --- Loading the package db files and building up the package state - --- | Call this after 'DynFlags.parseDynFlags'. It reads the package --- database files, and sets up various internal tables of package --- information, according to the package-related flags on the --- command-line (@-package@, @-hide-package@ etc.) --- --- Returns a list of packages to link in if we're doing dynamic linking. --- This list contains the packages that the user explicitly mentioned with --- @-package@ flags. --- --- 'initPackages' can be called again subsequently after updating the --- 'packageFlags' field of the 'DynFlags', and it will update the --- 'pkgState' in 'DynFlags' and return a list of packages to --- link in. -initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) -initPackages dflags0 = withTiming dflags0 - (text "initializing package database") - forcePkgDb $ do - dflags <- interpretPackageEnv dflags0 - pkg_db <- - case pkgDatabase dflags of - Nothing -> readPackageConfigs dflags - Just db -> return $ map (\(p, pkgs) - -> (p, setBatchPackageFlags dflags pkgs)) db - (pkg_state, preload, insts) - <- mkPackageState dflags pkg_db [] - return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, - thisUnitIdInsts_ = insts }, - preload) - where - forcePkgDb (dflags, _) = pkgIdMap (pkgState dflags) `seq` () - --- ----------------------------------------------------------------------------- --- Reading the package database(s) - -readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])] -readPackageConfigs dflags = do - conf_refs <- getPackageConfRefs dflags - confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs - mapM (readPackageConfig dflags) confs - - -getPackageConfRefs :: DynFlags -> IO [PkgConfRef] -getPackageConfRefs dflags = do - let system_conf_refs = [UserPkgConf, GlobalPkgConf] - - e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") - let base_conf_refs = case e_pkg_path of - Left _ -> system_conf_refs - Right path - | not (null path) && isSearchPathSeparator (last path) - -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs - | otherwise - -> map PkgConfFile (splitSearchPath path) - - -- Apply the package DB-related flags from the command line to get the - -- final list of package DBs. - -- - -- Notes on ordering: - -- * The list of flags is reversed (later ones first) - -- * We work with the package DB list in "left shadows right" order - -- * and finally reverse it at the end, to get "right shadows left" - -- - return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags)) - where - doFlag (PackageDB p) dbs = p : dbs - doFlag NoUserPackageDB dbs = filter isNotUser dbs - doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs - doFlag ClearPackageDBs _ = [] - - isNotUser UserPkgConf = False - isNotUser _ = True - - isNotGlobal GlobalPkgConf = False - isNotGlobal _ = True - -resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) -resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) --- NB: This logic is reimplemented in Cabal, so if you change it, --- make sure you update Cabal. (Or, better yet, dump it in the --- compiler info so Cabal can use the info.) -resolvePackageConfig dflags UserPkgConf = runMaybeT $ do - dir <- versionedAppDir dflags - let pkgconf = dir "package.conf.d" - exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return pkgconf else mzero -resolvePackageConfig _ (PkgConfFile name) = return $ Just name - -readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig]) -readPackageConfig dflags conf_file = do - isdir <- doesDirectoryExist conf_file - - proto_pkg_configs <- - if isdir - then readDirStylePackageConfig conf_file - else do - isfile <- doesFileExist conf_file - if isfile - then do - mpkgs <- tryReadOldFileStylePackageConfig - case mpkgs of - Just pkgs -> return pkgs - Nothing -> throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package " ++ - "databases (" ++ conf_file ++ - ") use 'ghc-pkg init' to create the database with " ++ - "the correct format." - else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ conf_file - - let - -- Fix #16360: remove trailing slash from conf_file before calculting pkgroot - conf_file' = dropTrailingPathSeparator conf_file - top_dir = topDir dflags - pkgroot = takeDirectory conf_file' - pkg_configs1 = map (mungePackageConfig top_dir pkgroot) - proto_pkg_configs - pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 - -- - return (conf_file', pkg_configs2) - where - readDirStylePackageConfig conf_dir = do - let filename = conf_dir "package.cache" - cache_exists <- doesFileExist filename - if cache_exists - then do - debugTraceMsg dflags 2 $ text "Using binary package database:" - <+> text filename - readPackageDbForGhc filename - else do - -- If there is no package.cache file, we check if the database is not - -- empty by inspecting if the directory contains any .conf file. If it - -- does, something is wrong and we fail. Otherwise we assume that the - -- database is empty. - debugTraceMsg dflags 2 $ text "There is no package.cache in" - <+> text conf_dir - <> text ", checking if the database is empty" - db_empty <- all (not . isSuffixOf ".conf") - <$> getDirectoryContents conf_dir - if db_empty - then do - debugTraceMsg dflags 3 $ text "There are no .conf files in" - <+> text conf_dir <> text ", treating" - <+> text "package database as empty" - return [] - else do - throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ conf_dir ++ - " even though package database is not empty" - - - -- Single-file style package dbs have been deprecated for some time, but - -- it turns out that Cabal was using them in one place. So this is a - -- workaround to allow older Cabal versions to use this newer ghc. - -- We check if the file db contains just "[]" and if so, we look for a new - -- dir-style db in conf_file.d/, ie in a dir next to the given file. - -- We cannot just replace the file with a new dir style since Cabal still - -- assumes it's a file and tries to overwrite with 'writeFile'. - -- ghc-pkg also cooperates with this workaround. - tryReadOldFileStylePackageConfig = do - content <- readFile conf_file `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - let conf_dir = conf_file <.> "d" - direxists <- doesDirectoryExist conf_dir - if direxists - then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) - liftM Just (readDirStylePackageConfig conf_dir) - else return (Just []) -- ghc-pkg will create it when it's updated - else return Nothing - -setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] -setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs - where - maybeDistrustAll pkgs' - | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' - | otherwise = pkgs' - - distrust pkg = pkg{ trusted = False } - -mungePackageConfig :: FilePath -> FilePath - -> PackageConfig -> PackageConfig -mungePackageConfig top_dir pkgroot = - mungeDynLibFields - . mungePackagePaths top_dir pkgroot - -mungeDynLibFields :: PackageConfig -> PackageConfig -mungeDynLibFields pkg = - pkg { - libraryDynDirs = libraryDynDirs pkg - `orIfNull` libraryDirs pkg - } - where - orIfNull [] flags = flags - orIfNull flags _ = flags - --- TODO: This code is duplicated in utils/ghc-pkg/Main.hs -mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig --- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec --- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) --- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. --- The "pkgroot" is the directory containing the package database. --- --- Also perform a similar substitution for the older GHC-specific --- "$topdir" variable. The "topdir" is the location of the ghc --- installation (obtained from the -B option). -mungePackagePaths top_dir pkgroot pkg = - pkg { - importDirs = munge_paths (importDirs pkg), - includeDirs = munge_paths (includeDirs pkg), - libraryDirs = munge_paths (libraryDirs pkg), - libraryDynDirs = munge_paths (libraryDynDirs pkg), - frameworkDirs = munge_paths (frameworkDirs pkg), - haddockInterfaces = munge_paths (haddockInterfaces pkg), - haddockHTMLs = munge_urls (haddockHTMLs pkg) - } - where - munge_paths = map munge_path - munge_urls = map munge_url - - munge_path p - | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' - | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' - | otherwise = p - - munge_url p - | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' - | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' - | otherwise = p - - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath - (r : -- We need to drop a leading "/" or "\\" - -- if there is one: - dropWhile (all isPathSeparator) - (FilePath.splitDirectories p)) - - -- We could drop the separator here, and then use above. However, - -- by leaving it in and using ++ we keep the same path separator - -- rather than letting FilePath change it to use \ as the separator - stripVarPrefix var path = case stripPrefix var path of - Just [] -> Just [] - Just cs@(c : _) | isPathSeparator c -> Just cs - _ -> Nothing - - --- ----------------------------------------------------------------------------- --- Modify our copy of the package database based on trust flags, --- -trust and -distrust. - -applyTrustFlag - :: DynFlags - -> PackagePrecedenceIndex - -> UnusablePackages - -> [PackageConfig] - -> TrustFlag - -> IO [PackageConfig] -applyTrustFlag dflags prec_map unusable pkgs flag = - case flag of - -- we trust all matching packages. Maybe should only trust first one? - -- and leave others the same or set them untrusted - TrustPackage str -> - case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr dflags flag ps - Right (ps,qs) -> return (map trust ps ++ qs) - where trust p = p {trusted=True} - - DistrustPackage str -> - case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr dflags flag ps - Right (ps,qs) -> return (map distrust ps ++ qs) - where distrust p = p {trusted=False} - --- | A little utility to tell if the 'thisPackage' is indefinite --- (if it is not, we should never use on-the-fly renaming.) -isIndefinite :: DynFlags -> Bool -isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) - -applyPackageFlag - :: DynFlags - -> PackagePrecedenceIndex - -> PackageConfigMap - -> UnusablePackages - -> Bool -- if False, if you expose a package, it implicitly hides - -- any previously exposed packages with the same name - -> [PackageConfig] - -> VisibilityMap -- Initially exposed - -> PackageFlag -- flag to apply - -> IO VisibilityMap -- Now exposed - -applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = - case flag of - ExposePackage _ arg (ModRenaming b rns) -> - case findPackages prec_map pkg_db arg pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right (p:_) -> return vm' - where - n = fsPackageName p - - -- If a user says @-unit-id p[A=]@, this imposes - -- a requirement on us: whatever our signature A is, - -- it must fulfill all of p[A=]:A's requirements. - -- This method is responsible for computing what our - -- inherited requirements are. - reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid - | otherwise = Map.empty - - collectHoles uid = case splitUnitIdInsts uid of - (_, Just indef) -> - let local = [ Map.singleton - (moduleName mod) - (Set.singleton $ IndefModule indef mod_name) - | (mod_name, mod) <- indefUnitIdInsts indef - , isHoleModule mod ] - recurse = [ collectHoles (moduleUnitId mod) - | (_, mod) <- indefUnitIdInsts indef ] - in Map.unionsWith Set.union $ local ++ recurse - -- Other types of unit identities don't have holes - (_, Nothing) -> Map.empty - - - uv = UnitVisibility - { uv_expose_all = b - , uv_renamings = rns - , uv_package_name = First (Just n) - , uv_requirements = reqs - , uv_explicit = True - } - vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared - -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` - -- (or if p-0.1 was registered in the pkgdb as exposed: True), - -- the second package flag would override the first one and you - -- would only see p-0.2 in exposed modules. This is good for - -- usability. - -- - -- However, with thinning and renaming (or Backpack), there might be - -- situations where you legitimately want to see two versions of a - -- package at the same time, and this behavior would make it - -- impossible to do so. So we decided that if you pass - -- -hide-all-packages, this should turn OFF the overriding behavior - -- where an exposed package hides all other packages with the same - -- name. This should not affect Cabal at all, which only ever - -- exposes one package at a time. - -- - -- NB: Why a variable no_hide_others? We have to apply this logic to - -- -plugin-package too, and it's more consistent if the switch in - -- behavior is based off of - -- -hide-all-packages/-hide-all-plugin-packages depending on what - -- flag is in question. - vm_cleared | no_hide_others = vm - -- NB: renamings never clear - | (_:_) <- rns = vm - | otherwise = Map.filterWithKey - (\k uv -> k == packageConfigId p - || First (Just n) /= uv_package_name uv) vm - _ -> panic "applyPackageFlag" - - HidePackage str -> - case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right ps -> return vm' - where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) - --- | Like 'selectPackages', but doesn't return a list of unmatched --- packages. Furthermore, any packages it returns are *renamed* --- if the 'UnitArg' has a renaming associated with it. -findPackages :: PackagePrecedenceIndex - -> PackageConfigMap -> PackageArg -> [PackageConfig] - -> UnusablePackages - -> Either [(PackageConfig, UnusablePackageReason)] - [PackageConfig] -findPackages prec_map pkg_db arg pkgs unusable - = let ps = mapMaybe (finder arg) pkgs - in if null ps - then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) - (Map.elems unusable)) - else Right (sortByPreference prec_map ps) - where - finder (PackageArg str) p - = if str == sourcePackageIdString p || str == packageNameString p - then Just p - else Nothing - finder (UnitIdArg uid) p - = let (iuid, mb_indef) = splitUnitIdInsts uid - in if iuid == installedPackageConfigId p - then Just (case mb_indef of - Nothing -> p - Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) - else Nothing - -selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig] - -> UnusablePackages - -> Either [(PackageConfig, UnusablePackageReason)] - ([PackageConfig], [PackageConfig]) -selectPackages prec_map arg pkgs unusable - = let matches = matching arg - (ps,rest) = partition matches pkgs - in if null ps - then Left (filter (matches.fst) (Map.elems unusable)) - else Right (sortByPreference prec_map ps, rest) - --- | Rename a 'PackageConfig' according to some module instantiation. -renamePackage :: PackageConfigMap -> [(ModuleName, Module)] - -> PackageConfig -> PackageConfig -renamePackage pkg_map insts conf = - let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map hsubst - new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) - in conf { - instantiatedWith = new_insts, - exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) - (exposedModules conf) - } - - --- A package named on the command line can either include the --- version, or just the name if it is unambiguous. -matchingStr :: String -> PackageConfig -> Bool -matchingStr str p - = str == sourcePackageIdString p - || str == packageNameString p - -matchingId :: InstalledUnitId -> PackageConfig -> Bool -matchingId uid p = uid == installedPackageConfigId p - -matching :: PackageArg -> PackageConfig -> Bool -matching (PackageArg str) = matchingStr str -matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid -matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case - --- | This sorts a list of packages, putting "preferred" packages first. --- See 'compareByPreference' for the semantics of "preference". -sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig] -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) - --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking --- which should be "active". Here is the order of preference: --- --- 1. First, prefer the latest version --- 2. If the versions are the same, prefer the package that --- came in the latest package database. --- --- Pursuant to #12518, we could change this policy to, for example, remove --- the version preference, meaning that we would always prefer the packages --- in later package database. --- --- Instead, we use that preference based policy only when one of the packages --- is integer-gmp and the other is integer-simple. --- This currently only happens when we're looking up which concrete --- package to use in place of @integer-wired-in@ and that two different --- package databases supply a different integer library. For more about --- the fake @integer-wired-in@ package, see Note [The integer library] --- in the @PrelNames@ module. -compareByPreference - :: PackagePrecedenceIndex - -> PackageConfig - -> PackageConfig - -> Ordering -compareByPreference prec_map pkg pkg' - | Just prec <- Map.lookup (unitId pkg) prec_map - , Just prec' <- Map.lookup (unitId pkg') prec_map - , differentIntegerPkgs pkg pkg' - = compare prec prec' - - | otherwise - = case comparing packageVersion pkg pkg' of - GT -> GT - EQ | Just prec <- Map.lookup (unitId pkg) prec_map - , Just prec' <- Map.lookup (unitId pkg') prec_map - -- Prefer the package from the later DB flag (i.e., higher - -- precedence) - -> compare prec prec' - | otherwise - -> EQ - LT -> LT - - where isIntegerPkg p = packageNameString p `elem` - ["integer-simple", "integer-gmp"] - differentIntegerPkgs p p' = - isIntegerPkg p && isIntegerPkg p' && - (packageName p /= packageName p') - -comparing :: Ord a => (t -> a) -> t -> t -> Ordering -comparing f a b = f a `compare` f b - -packageFlagErr :: DynFlags - -> PackageFlag - -> [(PackageConfig, UnusablePackageReason)] - -> IO a -packageFlagErr dflags flag reasons - = packageFlagErr' dflags (pprFlag flag) reasons - -trustFlagErr :: DynFlags - -> TrustFlag - -> [(PackageConfig, UnusablePackageReason)] - -> IO a -trustFlagErr dflags flag reasons - = packageFlagErr' dflags (pprTrustFlag flag) reasons - -packageFlagErr' :: DynFlags - -> SDoc - -> [(PackageConfig, UnusablePackageReason)] - -> IO a -packageFlagErr' dflags flag_doc reasons - = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) - where err = text "cannot satisfy " <> flag_doc <> - (if null reasons then Outputable.empty else text ": ") $$ - nest 4 (ppr_reasons $$ - text "(use -v for more information)") - ppr_reasons = vcat (map ppr_reason reasons) - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason - -pprFlag :: PackageFlag -> SDoc -pprFlag flag = case flag of - HidePackage p -> text "-hide-package " <> text p - ExposePackage doc _ _ -> text doc - -pprTrustFlag :: TrustFlag -> SDoc -pprTrustFlag flag = case flag of - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p - --- ----------------------------------------------------------------------------- --- Wired-in packages --- --- See Note [Wired-in packages] in Module - -type WiredInUnitId = String -type WiredPackagesMap = Map WiredUnitId WiredUnitId - -wired_in_pkgids :: [WiredInUnitId] -wired_in_pkgids = map unitIdString wiredInUnitIds - -findWiredInPackages - :: DynFlags - -> PackagePrecedenceIndex - -> [PackageConfig] -- database - -> VisibilityMap -- info on what packages are visible - -- for wired in selection - -> IO ([PackageConfig], -- package database updated for wired in - WiredPackagesMap) -- map from unit id to wired identity - -findWiredInPackages dflags prec_map pkgs vis_map = do - -- Now we must find our wired-in packages, and rename them to - -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in packages] in Module - let - matches :: PackageConfig -> WiredInUnitId -> Bool - pc `matches` pid - -- See Note [The integer library] in PrelNames - | pid == unitIdString integerUnitId - = packageNameString pc `elem` ["integer-gmp", "integer-simple"] - pc `matches` pid = packageNameString pc == pid - - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. - -- - -- When choosing which package to map to a wired-in package - -- name, we try to pick the latest version of exposed packages. - -- However, if there are no exposed wired in packages available - -- (e.g. -hide-all-packages was used), we can't bail: we *have* - -- to assign a package for the wired-in package: so we try again - -- with hidden packages included to (and pick the latest - -- version). - -- - -- You can also override the default choice by using -ignore-package: - -- this works even when there is no exposed wired in package - -- available. - -- - findWiredInPackage :: [PackageConfig] -> WiredInUnitId - -> IO (Maybe (WiredInUnitId, PackageConfig)) - findWiredInPackage pkgs wired_pkg = - let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = - [ p | p <- all_ps - , Map.member (packageConfigId p) vis_map ] in - case all_exposed_ps of - [] -> case all_ps of - [] -> notfound - many -> pick (head (sortByPreference prec_map many)) - many -> pick (head (sortByPreference prec_map many)) - where - notfound = do - debugTraceMsg dflags 2 $ - text "wired-in package " - <> text wired_pkg - <> text " not found." - return Nothing - pick :: PackageConfig - -> IO (Maybe (WiredInUnitId, PackageConfig)) - pick pkg = do - debugTraceMsg dflags 2 $ - text "wired-in package " - <> text wired_pkg - <> text " mapped to " - <> ppr (unitId pkg) - return (Just (wired_pkg, pkg)) - - - mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids - let - wired_in_pkgs = catMaybes mb_wired_in_pkgs - - -- this is old: we used to assume that if there were - -- multiple versions of wired-in packages installed that - -- they were mutually exclusive. Now we're assuming that - -- you have one "main" version of each wired-in package - -- (the latest version), and the others are backward-compat - -- wrappers that depend on this one. e.g. base-4.0 is the - -- latest, base-3.0 is a compat wrapper depending on base-4.0. - {- - deleteOtherWiredInPackages pkgs = filterOut bad pkgs - where bad p = any (p `matches`) wired_in_pkgids - && package p `notElem` map fst wired_in_ids - -} - - wiredInMap :: Map WiredUnitId WiredUnitId - wiredInMap = Map.fromList - [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId)) - | (wiredInUnitId, pkg) <- wired_in_pkgs - , Just key <- pure $ definitePackageConfigId pkg - ] - - updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs - where upd_pkg pkg - | Just def_uid <- definitePackageConfigId pkg - , Just wiredInUnitId <- Map.lookup def_uid wiredInMap - = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) - in pkg { - unitId = fsToInstalledUnitId fs, - componentId = ComponentId fs - } - | otherwise - = pkg - upd_deps pkg = pkg { - -- temporary harmless DefUnitId invariant violation - depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg), - exposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (exposedModules pkg) - } - - - return (updateWiredInDependencies pkgs, wiredInMap) - --- Helper functions for rewiring Module and UnitId. These --- rewrite UnitIds of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in packages] in Module. --- --- For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in PrelNames. - -upd_wired_in_mod :: WiredPackagesMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId -upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = - DefiniteUnitId (upd_wired_in wiredInMap def_uid) -upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = - IndefiniteUnitId $ newIndefUnitId - (indefUnitIdComponentId indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) - -upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId -upd_wired_in wiredInMap key - | Just key' <- Map.lookup key wiredInMap = key' - | otherwise = key - -updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap -updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) - where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of - Nothing -> vm - Just r -> Map.insert (DefiniteUnitId to) r - (Map.delete (DefiniteUnitId from) vm) - - --- ---------------------------------------------------------------------------- - --- | The reason why a package is unusable. -data UnusablePackageReason - = -- | We ignored it explicitly using @-ignore-package@. - IgnoredWithFlag - -- | This package transitively depends on a package that was never present - -- in any of the provided databases. - | BrokenDependencies [InstalledUnitId] - -- | This package transitively depends on a package involved in a cycle. - -- Note that the list of 'InstalledUnitId' reports the direct dependencies - -- of this package that (transitively) depended on the cycle, and not - -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [InstalledUnitId] - -- | This package transitively depends on a package which was ignored. - | IgnoredDependencies [InstalledUnitId] - -- | This package transitively depends on a package which was - -- shadowed by an ABI-incompatible package. - | ShadowedDependencies [InstalledUnitId] - -instance Outputable UnusablePackageReason where - ppr IgnoredWithFlag = text "[ignored with flag]" - ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) - ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) - ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) - ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) - -type UnusablePackages = Map InstalledUnitId - (PackageConfig, UnusablePackageReason) - -pprReason :: SDoc -> UnusablePackageReason -> SDoc -pprReason pref reason = case reason of - IgnoredWithFlag -> - pref <+> text "ignored due to an -ignore-package flag" - BrokenDependencies deps -> - pref <+> text "unusable due to missing dependencies:" $$ - nest 2 (hsep (map ppr deps)) - CyclicDependencies deps -> - pref <+> text "unusable due to cyclic dependencies:" $$ - nest 2 (hsep (map ppr deps)) - IgnoredDependencies deps -> - pref <+> text ("unusable because the -ignore-package flag was used to " ++ - "ignore at least one of its dependencies:") $$ - nest 2 (hsep (map ppr deps)) - ShadowedDependencies deps -> - pref <+> text "unusable due to shadowed dependencies:" $$ - nest 2 (hsep (map ppr deps)) - -reportCycles :: DynFlags -> [SCC PackageConfig] -> IO () -reportCycles dflags sccs = mapM_ report sccs - where - report (AcyclicSCC _) = return () - report (CyclicSCC vs) = - debugTraceMsg dflags 2 $ - text "these packages are involved in a cycle:" $$ - nest 2 (hsep (map (ppr . unitId) vs)) - -reportUnusable :: DynFlags -> UnusablePackages -> IO () -reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) - where - report (ipid, (_, reason)) = - debugTraceMsg dflags 2 $ - pprReason - (text "package" <+> ppr ipid <+> text "is") reason - --- ---------------------------------------------------------------------------- --- --- Utilities on the database --- - --- | A reverse dependency index, mapping an 'InstalledUnitId' to --- the 'InstalledUnitId's which have a dependency on it. -type RevIndex = Map InstalledUnitId [InstalledUnitId] - --- | Compute the reverse dependency index of a package database. -reverseDeps :: InstalledPackageIndex -> RevIndex -reverseDeps db = Map.foldl' go Map.empty db - where - go r pkg = foldl' (go' (unitId pkg)) r (depends pkg) - go' from r to = Map.insertWith (++) to [from] r - --- | Given a list of 'InstalledUnitId's to remove, a database, --- and a reverse dependency index (as computed by 'reverseDeps'), --- remove those packages, plus any packages which depend on them. --- Returns the pruned database, as well as a list of 'PackageConfig's --- that was removed. -removePackages :: [InstalledUnitId] -> RevIndex - -> InstalledPackageIndex - -> (InstalledPackageIndex, [PackageConfig]) -removePackages uids index m = go uids (m,[]) - where - go [] (m,pkgs) = (m,pkgs) - go (uid:uids) (m,pkgs) - | Just pkg <- Map.lookup uid m - = case Map.lookup uid index of - Nothing -> go uids (Map.delete uid m, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) - | otherwise - = go uids (m,pkgs) - --- | Given a 'PackageConfig' from some 'InstalledPackageIndex', --- return all entries in 'depends' which correspond to packages --- that do not exist in the index. -depsNotAvailable :: InstalledPackageIndex - -> PackageConfig - -> [InstalledUnitId] -depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg) - --- | Given a 'PackageConfig' from some 'InstalledPackageIndex' --- return all entries in 'abiDepends' which correspond to packages --- that do not exist, OR have mismatching ABIs. -depsAbiMismatch :: InstalledPackageIndex - -> PackageConfig - -> [InstalledUnitId] -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg - where - abiMatch (dep_uid, abi) - | Just dep_pkg <- Map.lookup dep_uid pkg_map - = abiHash dep_pkg == abi - | otherwise - = False - --- ----------------------------------------------------------------------------- --- Ignore packages - -ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages -ignorePackages flags pkgs = Map.fromList (concatMap doit flags) - where - doit (IgnorePackage str) = - case partition (matchingStr str) pkgs of - (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) - | p <- ps ] - -- missing package is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. - --- ---------------------------------------------------------------------------- --- --- Merging databases --- - --- | For each package, a mapping from uid -> i indicates that this --- package was brought into GHC by the ith @-package-db@ flag on --- the command line. We use this mapping to make sure we prefer --- packages that were defined later on the command line, if there --- is an ambiguity. -type PackagePrecedenceIndex = Map InstalledUnitId Int - --- | Given a list of databases, merge them together, where --- packages with the same unit id in later databases override --- earlier ones. This does NOT check if the resulting database --- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])] - -> IO (InstalledPackageIndex, PackagePrecedenceIndex) -mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] - where - merge (pkg_map, prec_map) (i, (db_path, db)) = do - debugTraceMsg dflags 2 $ - text "loading package database" <+> text db_path - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg dflags 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" - return (pkg_map', prec_map') - where - db_map = mk_pkg_map db - mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) - - -- The set of UnitIds which appear in both db and pkgs. These are the - -- ones that get overridden. Compute this just to give some - -- helpful debug messages at -v2 - override_set :: Set InstalledUnitId - override_set = Set.intersection (Map.keysSet db_map) - (Map.keysSet pkg_map) - - -- Now merge the sets together (NB: in case of duplicate, - -- first argument preferred) - pkg_map' :: InstalledPackageIndex - pkg_map' = Map.union db_map pkg_map - - prec_map' :: PackagePrecedenceIndex - prec_map' = Map.union (Map.map (const i) db_map) prec_map - --- | Validates a database, removing unusable packages from it --- (this includes removing packages that the user has explicitly --- ignored.) Our general strategy: --- --- 1. Remove all broken packages (dangling dependencies) --- 2. Remove all packages that are cyclic --- 3. Apply ignore flags --- 4. Remove all packages which have deps with mismatching ABIs --- -validateDatabase :: DynFlags -> InstalledPackageIndex - -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig]) -validateDatabase dflags pkg_map1 = - (pkg_map5, unusable, sccs) - where - ignore_flags = reverse (ignorePackageFlags dflags) - - -- Compute the reverse dependency index - index = reverseDeps pkg_map1 - - -- Helper function - mk_unusable mk_err dep_matcher m uids = - Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids ] - - -- Find broken packages - directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (Map.elems pkg_map1) - (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1 - unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken - - -- Find recursive packages - sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg) - | pkg <- Map.elems pkg_map2 ] - getCyclicSCC (CyclicSCC vs) = map unitId vs - getCyclicSCC (AcyclicSCC _) = [] - (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2 - unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic - - -- Apply ignore flags - directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3) - (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3 - unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored - - -- Knock out packages whose dependencies don't agree with ABI - -- (i.e., got invalidated due to shadowing) - directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (Map.elems pkg_map4) - (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4 - unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - - unusable = directly_ignored `Map.union` unusable_ignored - `Map.union` unusable_broken - `Map.union` unusable_cyclic - `Map.union` unusable_shadowed - --- ----------------------------------------------------------------------------- --- When all the command-line options are in, we can process our package --- settings and populate the package state. - -mkPackageState - :: DynFlags - -- initial databases, in the order they were specified on - -- the command line (later databases shadow earlier ones) - -> [(FilePath, [PackageConfig])] - -> [PreloadUnitId] -- preloaded packages - -> IO (PackageState, - [PreloadUnitId], -- new packages to preload - Maybe [(ModuleName, Module)]) - -mkPackageState dflags dbs preload0 = do -{- - Plan. - - There are two main steps for making the package state: - - 1. We want to build a single, unified package database based - on all of the input databases, which upholds the invariant that - there is only one package per any UnitId and there are no - dangling dependencies. We'll do this by merging, and - then successively filtering out bad dependencies. - - a) Merge all the databases together. - If an input database defines unit ID that is already in - the unified database, that package SHADOWS the existing - package in the current unified database. Note that - order is important: packages defined later in the list of - command line arguments shadow those defined earlier. - - b) Remove all packages with missing dependencies, or - mutually recursive dependencies. - - b) Remove packages selected by -ignore-package from input database - - c) Remove all packages which depended on packages that are now - shadowed by an ABI-incompatible package - - d) report (with -v) any packages that were removed by steps 1-3 - - 2. We want to look at the flags controlling package visibility, - and build a mapping of what module names are in scope and - where they live. - - a) on the final, unified database, we apply -trust/-distrust - flags directly, modifying the database so that the 'trusted' - field has the correct value. - - b) we use the -package/-hide-package flags to compute a - visibility map, stating what packages are "exposed" for - the purposes of computing the module map. - * if any flag refers to a package which was removed by 1-5, then - we can give an error message explaining why - * if -hide-all-packages what not specified, this step also - hides packages which are superseded by later exposed packages - * this step is done TWICE if -plugin-package/-hide-all-plugin-packages - are used - - c) based on the visibility map, we pick wired packages and rewrite - them to have the expected unitId. - - d) finally, using the visibility map and the package database, - we build a mapping saying what every in scope module name points to. --} - - -- This, and the other reverse's that you will see, are due to the face that - -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order - -- than they are on the command line. - let other_flags = reverse (packageFlags dflags) - debugTraceMsg dflags 2 $ - text "package flags" <+> ppr other_flags - - -- Merge databases together, without checking validity - (pkg_map1, prec_map) <- mergeDatabases dflags dbs - - -- Now that we've merged everything together, prune out unusable - -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1 - - reportCycles dflags sccs - reportUnusable dflags unusable - - -- Apply trust flags (these flags apply regardless of whether - -- or not packages are visible or not) - pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable) - (Map.elems pkg_map2) (reverse (trustFlags dflags)) - let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 - - -- - -- Calculate the initial set of units from package databases, prior to any package flags. - -- - -- Conceptually, we select the latest versions of all valid (not unusable) *packages* - -- (not units). This is empty if we have -hide-all-packages. - -- - -- Then we create an initial visibility map with default visibilities for all - -- exposed, definite units which belong to the latest valid packages. - -- - let preferLater unit unit' = - case compareByPreference prec_map unit unit' of - GT -> unit - _ -> unit' - addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit - -- This is the set of maximally preferable packages. In fact, it is a set of - -- most preferable *units* keyed by package name, which act as stand-ins in - -- for "a package in a database". We use units here because we don't have - -- "a package in a database" as a type currently. - mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags - then emptyUDFM - else foldl' addIfMorePreferable emptyUDFM pkgs1 - -- When exposing units, we want to consider all of those in the most preferable - -- packages. We can implement that by looking for units that are equi-preferable - -- with the most preferable unit for package. Being equi-preferable means that - -- they must be in the same database, with the same version, and the same pacakge name. - -- - -- We must take care to consider all these units and not just the most - -- preferable one, otherwise we can end up with problems like #16228. - mostPreferable u = - case lookupUDFM mostPreferablePackageReps (fsPackageName u) of - Nothing -> False - Just u' -> compareByPreference prec_map u u' == EQ - vis_map1 = foldl' (\vm p -> - -- Note: we NEVER expose indefinite packages by - -- default, because it's almost assuredly not - -- what you want (no mix-in linking has occurred). - if exposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p - then Map.insert (packageConfigId p) - UnitVisibility { - uv_expose_all = True, - uv_renamings = [], - uv_package_name = First (Just (fsPackageName p)), - uv_requirements = Map.empty, - uv_explicit = False - } - vm - else vm) - Map.empty pkgs1 - - -- - -- Compute a visibility map according to the command-line flags (-package, - -- -hide-package). This needs to know about the unusable packages, since if a - -- user tries to enable an unusable package, we should let them know. - -- - vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable - (gopt Opt_HideAllPackages dflags) pkgs1) - vis_map1 other_flags - - -- - -- Sort out which packages are wired in. This has to be done last, since - -- it modifies the unit ids of wired in packages, but when we process - -- package arguments we need to key against the old versions. - -- - (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2 - let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 - - -- Update the visibility map, so we treat wired packages as visible. - let vis_map = updateVisibilityMap wired_map vis_map2 - - let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags - plugin_vis_map <- - case pluginPackageFlags dflags of - -- common case; try to share the old vis_map - [] | not hide_plugin_pkgs -> return vis_map - | otherwise -> return Map.empty - _ -> do let plugin_vis_map1 - | hide_plugin_pkgs = Map.empty - -- Use the vis_map PRIOR to wired in, - -- because otherwise applyPackageFlag - -- won't work. - | otherwise = vis_map2 - plugin_vis_map2 - <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable - (gopt Opt_HideAllPluginPackages dflags) pkgs1) - plugin_vis_map1 - (reverse (pluginPackageFlags dflags)) - -- Updating based on wired in packages is mostly - -- good hygiene, because it won't matter: no wired in - -- package has a compiler plugin. - -- TODO: If a wired in package had a compiler plugin, - -- and you tried to pick different wired in packages - -- with the plugin flags and the normal flags... what - -- would happen? I don't know! But this doesn't seem - -- likely to actually happen. - return (updateVisibilityMap wired_map plugin_vis_map2) - - -- - -- Here we build up a set of the packages mentioned in -package - -- flags on the command line; these are called the "preload" - -- packages. we link these packages in eagerly. The preload set - -- should contain at least rts & base, which is why we pretend that - -- the command line contains -package rts & -package base. - -- - -- NB: preload IS important even for type-checking, because we - -- need the correct include path to be set. - -- - let preload1 = Map.keys (Map.filter uv_explicit vis_map) - - let pkgname_map = foldl' add Map.empty pkgs2 - where add pn_map p - = Map.insert (packageName p) (componentId p) pn_map - - -- The explicitPackages accurately reflects the set of packages we have turned - -- on; as such, it also is the only way one can come up with requirements. - -- The requirement context is directly based off of this: we simply - -- look for nested unit IDs that are directly fed holes: the requirements - -- of those units are precisely the ones we need to track - let explicit_pkgs = Map.keys vis_map - req_ctx = Map.map (Set.toList) - $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) - - - let preload2 = preload1 - - let - -- add base & rts to the preload packages - basicLinkedPackages - | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUDFM (unPackageConfigMap pkg_db)) - [baseUnitId, rtsUnitId] - | otherwise = [] - -- but in any case remove the current package from the set of - -- preloaded packages so that base/rts does not end up in the - -- set up preloaded package when we are just building it - -- (NB: since this is only relevant for base/rts it doesn't matter - -- that thisUnitIdInsts_ is not wired yet) - -- - preload3 = ordNub $ filter (/= thisPackage dflags) - $ (basicLinkedPackages ++ preload2) - - -- Close the preload packages with their dependencies - dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) - let new_dep_preload = filter (`notElem` preload0) dep_preload - - let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map - mod_map2 = mkUnusableModuleToPkgConfAll unusable - mod_map = Map.union mod_map1 mod_map2 - - dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" - (pprModuleMap mod_map) - - -- Force pstate to avoid leaking the dflags0 passed to mkPackageState - let !pstate = PackageState{ - preloadPackages = dep_preload, - explicitPackages = explicit_pkgs, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mod_map, - pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map, - packageNameMap = pkgname_map, - unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], - requirementContext = req_ctx - } - let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) - return (pstate, new_dep_preload, new_insts) - --- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' --- that it was recorded as in the package database. -unwireUnitId :: DynFlags -> UnitId -> UnitId -unwireUnitId dflags uid@(DefiniteUnitId def_uid) = - maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) -unwireUnitId _ uid = uid - --- ----------------------------------------------------------------------------- --- | Makes the mapping from module to package info - --- Slight irritation: we proceed by leafing through everything --- in the installed package database, which makes handling indefinite --- packages a bit bothersome. - -mkModuleToPkgConfAll - :: DynFlags - -> PackageConfigMap - -> VisibilityMap - -> ModuleToPkgConfAll -mkModuleToPkgConfAll dflags pkg_db vis_map = - -- What should we fold on? Both situations are awkward: - -- - -- * Folding on the visibility map means that we won't create - -- entries for packages that aren't mentioned in vis_map - -- (e.g., hidden packages, causing #14717) - -- - -- * Folding on pkg_db is awkward because if we have an - -- Backpack instantiation, we need to possibly add a - -- package from pkg_db multiple times to the actual - -- ModuleToPkgConfAll. Also, we don't really want - -- definite package instantiations to show up in the - -- list of possibilities. - -- - -- So what will we do instead? We'll extend vis_map with - -- entries for every definite (for non-Backpack) and - -- indefinite (for Backpack) package, so that we get the - -- hidden entries we need. - Map.foldlWithKey extend_modmap emptyMap vis_map_extended - where - vis_map_extended = Map.union vis_map {- preferred -} default_vis - - default_vis = Map.fromList - [ (packageConfigId pkg, mempty) - | pkg <- eltsUDFM (unPackageConfigMap pkg_db) - -- Exclude specific instantiations of an indefinite - -- package - , indefinite pkg || null (instantiatedWith pkg) - ] - - emptyMap = Map.empty - setOrigins m os = fmap (const os) m - extend_modmap modmap uid - UnitVisibility { uv_expose_all = b, uv_renamings = rns } - = addListTo modmap theBindings - where - pkg = pkg_lookup uid - - theBindings :: [(ModuleName, Map Module ModuleOrigin)] - theBindings = newBindings b rns - - newBindings :: Bool - -> [(ModuleName, ModuleName)] - -> [(ModuleName, Map Module ModuleOrigin)] - newBindings e rns = es e ++ hiddens ++ map rnBinding rns - - rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, Map Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) - where origEntry = case lookupUFM esmap orig of - Just r -> r - Nothing -> throwGhcException (CmdLineError (showSDoc dflags - (text "package flag: could not find module name" <+> - ppr orig <+> text "in package" <+> ppr pk))) - - es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] - es e = do - (m, exposedReexport) <- exposed_mods - let (pk', m', origin') = - case exposedReexport of - Nothing -> (pk, m, fromExposedModules e) - Just (Module pk' m') -> - let pkg' = pkg_lookup pk' - in (pk', m', fromReexportedModules e pkg') - return (m, mkModMap pk' m' origin') - - esmap :: UniqFM (Map Module ModuleOrigin) - esmap = listToUFM (es False) -- parameter here doesn't matter, orig will - -- be overwritten - - hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] - - pk = packageConfigId pkg - pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid - `orElse` pprPanic "pkg_lookup" (ppr uid) - - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg - --- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages. -mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll -mkUnusableModuleToPkgConfAll unusables = - Map.foldl' extend_modmap Map.empty unusables - where - extend_modmap modmap (pkg, reason) = addListTo modmap bindings - where bindings :: [(ModuleName, Map Module ModuleOrigin)] - bindings = exposed ++ hidden - - origin = ModUnusable reason - pkg_id = packageConfigId pkg - - exposed = map get_exposed exposed_mods - hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] - - get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin) - get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) - - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg - --- | Add a list of key/value pairs to a nested map. --- --- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks --- when reloading modules in GHCi (see #4029). This ensures that each --- value is forced before installing into the map. -addListTo :: (Monoid a, Ord k1, Ord k2) - => Map k1 (Map k2 a) - -> [(k1, Map k2 a)] - -> Map k1 (Map k2 a) -addListTo = foldl' merge - where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m - --- | Create a singleton module mapping -mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin -mkModMap pkg mod = Map.singleton (mkModule pkg mod) - --- ----------------------------------------------------------------------------- --- Extracting information from the packages in scope - --- Many of these functions take a list of packages: in those cases, --- the list is expected to contain the "dependent packages", --- i.e. those packages that were found to be depended on by the --- current module/program. These can be auto or non-auto packages, it --- doesn't really matter. The list is always combined with the list --- of preload (command-line) packages to determine which packages to --- use. - --- | Find all the include directories in these and the preload packages -getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageIncludePath dflags pkgs = - collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs - -collectIncludeDirs :: [PackageConfig] -> [FilePath] -collectIncludeDirs ps = ordNub (filter notNull (concatMap includeDirs ps)) - --- | Find all the library paths in these and the preload packages -getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageLibraryPath dflags pkgs = - collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs - -collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath] -collectLibraryPaths dflags = ordNub . filter notNull - . concatMap (libraryDirsForWay dflags) - --- | Find all the link options in these and the preload packages, --- returning (package hs lib options, extra library options, other flags) -getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) -getPackageLinkOpts dflags pkgs = - collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs - -collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) -collectLinkOpts dflags ps = - ( - concatMap (map ("-l" ++) . packageHsLibs dflags) ps, - concatMap (map ("-l" ++) . extraLibraries) ps, - concatMap ldOptions ps - ) -collectArchives :: DynFlags -> PackageConfig -> IO [FilePath] -collectArchives dflags pc = - filterM doesFileExist [ searchPath ("lib" ++ lib ++ ".a") - | searchPath <- searchPaths - , lib <- libs ] - where searchPaths = ordNub . filter notNull . libraryDirsForWay dflags $ pc - libs = packageHsLibs dflags pc ++ extraLibraries pc - -getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)] -getLibs dflags pkgs = do - ps <- getPreloadPackagesAnd dflags pkgs - fmap concat . forM ps $ \p -> do - let candidates = [ (l f, f) | l <- collectLibraryPaths dflags [p] - , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] - filterM (doesFileExist . fst) candidates - -packageHsLibs :: DynFlags -> PackageConfig -> [String] -packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) - where - ways0 = ways dflags - - ways1 = filter (/= WayDyn) ways0 - -- the name of a shared library is libHSfoo-ghc.so - -- we leave out the _dyn, because it is superfluous - - -- debug and profiled RTSs include support for -eventlog - ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 - = filter (/= WayEventLog) ways1 - | otherwise - = ways1 - - tag = mkBuildTag (filter (not . wayRTSOnly) ways2) - rts_tag = mkBuildTag ways2 - - mkDynName x - | WayDyn `notElem` ways dflags = x - | "HS" `isPrefixOf` x = - x ++ '-':programName dflags ++ projectVersion dflags - -- For non-Haskell libraries, we use the name "Cfoo". The .a - -- file is libCfoo.a, and the .so is libfoo.so. That way the - -- linker knows what we mean for the vanilla (-lCfoo) and dyn - -- (-lfoo) ways. We therefore need to strip the 'C' off here. - | Just x' <- stripPrefix "C" x = x' - | otherwise - = panic ("Don't understand library name " ++ x) - - -- Add _thr and other rts suffixes to packages named - -- `rts` or `rts-1.0`. Why both? Traditionally the rts - -- package is called `rts` only. However the tooling - -- usually expects a package name to have a version. - -- As such we will gradually move towards the `rts-1.0` - -- package name, at which point the `rts` package name - -- will eventually be unused. - -- - -- This change elevates the need to add custom hooks - -- and handling specifically for the `rts` package for - -- example in ghc-cabal. - addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) - addSuffix rts@"HSrts-1.0.1" = rts ++ (expandTag rts_tag) - addSuffix other_lib = other_lib ++ (expandTag tag) - - expandTag t | null t = "" - | otherwise = '_':t - --- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way. -libraryDirsForWay :: DynFlags -> PackageConfig -> [String] -libraryDirsForWay dflags - | WayDyn `elem` ways dflags = libraryDynDirs - | otherwise = libraryDirs - --- | Find all the C-compiler options in these and the preload packages -getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageExtraCcOpts dflags pkgs = do - ps <- getPreloadPackagesAnd dflags pkgs - return (concatMap ccOptions ps) - --- | Find all the package framework paths in these and the preload packages -getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageFrameworkPath dflags pkgs = do - ps <- getPreloadPackagesAnd dflags pkgs - return (ordNub (filter notNull (concatMap frameworkDirs ps))) - --- | Find all the package frameworks in these and the preload packages -getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] -getPackageFrameworks dflags pkgs = do - ps <- getPreloadPackagesAnd dflags pkgs - return (concatMap frameworks ps) - --- ----------------------------------------------------------------------------- --- Package Utils - --- | Takes a 'ModuleName', and if the module is in any package returns --- list of modules which take that name. -lookupModuleInAllPackages :: DynFlags - -> ModuleName - -> [(Module, PackageConfig)] -lookupModuleInAllPackages dflags m - = case lookupModuleWithSuggestions dflags m Nothing of - LookupFound a b -> [(a,b)] - LookupMultiple rs -> map f rs - where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags - (moduleUnitId m))) - _ -> [] - --- | The result of performing a lookup -data LookupResult = - -- | Found the module uniquely, nothing else to do - LookupFound Module PackageConfig - -- | Multiple modules with the same name in scope - | LookupMultiple [(Module, ModuleOrigin)] - -- | No modules found, but there were some hidden ones with - -- an exact name match. First is due to package hidden, second - -- is due to module being hidden - | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] - -- | No modules found, but there were some unusable ones with - -- an exact name match - | LookupUnusable [(Module, ModuleOrigin)] - -- | Nothing found, here are some suggested different names - | LookupNotFound [ModuleSuggestion] -- suggestions - -data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin - | SuggestHidden ModuleName Module ModuleOrigin - -lookupModuleWithSuggestions :: DynFlags - -> ModuleName - -> Maybe FastString - -> LookupResult -lookupModuleWithSuggestions dflags - = lookupModuleWithSuggestions' dflags - (moduleToPkgConfAll (pkgState dflags)) - -lookupPluginModuleWithSuggestions :: DynFlags - -> ModuleName - -> Maybe FastString - -> LookupResult -lookupPluginModuleWithSuggestions dflags - = lookupModuleWithSuggestions' dflags - (pluginModuleToPkgConfAll (pkgState dflags)) - -lookupModuleWithSuggestions' :: DynFlags - -> ModuleToPkgConfAll - -> ModuleName - -> Maybe FastString - -> LookupResult -lookupModuleWithSuggestions' dflags mod_map m mb_pn - = case Map.lookup m mod_map of - Nothing -> LookupNotFound suggestions - Just xs -> - case foldl' classify ([],[],[], []) (Map.toList xs) of - ([], [], [], []) -> LookupNotFound suggestions - (_, _, _, [(m, _)]) -> LookupFound m (mod_pkg m) - (_, _, _, exposed@(_:_)) -> LookupMultiple exposed - ([], [], unusable@(_:_), []) -> LookupUnusable unusable - (hidden_pkg, hidden_mod, _, []) -> - LookupHidden hidden_pkg hidden_mod - where - classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = - let origin = filterOrigin mb_pn (mod_pkg m) origin0 - x = (m, origin) - in case origin of - ModHidden - -> (hidden_pkg, x:hidden_mod, unusable, exposed) - ModUnusable _ - -> (hidden_pkg, hidden_mod, x:unusable, exposed) - _ | originEmpty origin - -> (hidden_pkg, hidden_mod, unusable, exposed) - | originVisible origin - -> (hidden_pkg, hidden_mod, unusable, x:exposed) - | otherwise - -> (x:hidden_pkg, hidden_mod, unusable, exposed) - - pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) - mod_pkg = pkg_lookup . moduleUnitId - - -- Filters out origins which are not associated with the given package - -- qualifier. No-op if there is no package qualifier. Test if this - -- excluded all origins with 'originEmpty'. - filterOrigin :: Maybe FastString - -> PackageConfig - -> ModuleOrigin - -> ModuleOrigin - filterOrigin Nothing _ o = o - filterOrigin (Just pn) pkg o = - case o of - ModHidden -> if go pkg then ModHidden else mempty - (ModUnusable _) -> if go pkg then o else mempty - ModOrigin { fromOrigPackage = e, fromExposedReexport = res, - fromHiddenReexport = rhs } - -> ModOrigin { - fromOrigPackage = if go pkg then e else Nothing - , fromExposedReexport = filter go res - , fromHiddenReexport = filter go rhs - , fromPackageFlag = False -- always excluded - } - where go pkg = pn == fsPackageName pkg - - suggestions - | gopt Opt_HelpfulErrors dflags = - fuzzyLookup (moduleNameString m) all_mods - | otherwise = [] - - all_mods :: [(String, ModuleSuggestion)] -- All modules - all_mods = sortBy (comparing fst) $ - [ (moduleNameString m, suggestion) - | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) - , suggestion <- map (getSuggestion m) (Map.toList e) - ] - getSuggestion name (mod, origin) = - (if originVisible origin then SuggestVisible else SuggestHidden) - name mod origin - -listVisibleModuleNames :: DynFlags -> [ModuleName] -listVisibleModuleNames dflags = - map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) - where visible (_, ms) = any originVisible (Map.elems ms) - --- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of --- 'PackageConfig's -getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig] -getPreloadPackagesAnd dflags pkgids0 = - let - pkgids = pkgids0 ++ - -- An indefinite package will have insts to HOLE, - -- which is not a real package. Don't look it up. - -- Fixes #14525 - if isIndefinite dflags - then [] - else map (toInstalledUnitId . moduleUnitId . snd) - (thisUnitIdInsts dflags) - state = pkgState dflags - pkg_map = pkgIdMap state - preload = preloadPackages state - pairs = zip pkgids (repeat Nothing) - in do - all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) - return (map (getInstalledPackageDetails dflags) all_pkgs) - --- Takes a list of packages, and returns the list with dependencies included, --- in reverse dependency order (a package appears before those it depends on). -closeDeps :: DynFlags - -> PackageConfigMap - -> [(InstalledUnitId, Maybe InstalledUnitId)] - -> IO [InstalledUnitId] -closeDeps dflags pkg_map ps - = throwErr dflags (closeDepsErr dflags pkg_map ps) - -throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a -throwErr dflags m - = case m of - Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) - Succeeded r -> return r - -closeDepsErr :: DynFlags - -> PackageConfigMap - -> [(InstalledUnitId,Maybe InstalledUnitId)] - -> MaybeErr MsgDoc [InstalledUnitId] -closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps - --- internal helper -add_package :: DynFlags - -> PackageConfigMap - -> [PreloadUnitId] - -> (PreloadUnitId,Maybe PreloadUnitId) - -> MaybeErr MsgDoc [PreloadUnitId] -add_package dflags pkg_db ps (p, mb_parent) - | p `elem` ps = return ps -- Check if we've already added this package - | otherwise = - case lookupInstalledPackage' pkg_db p of - Nothing -> Failed (missingPackageMsg p <> - missingDependencyMsg mb_parent) - Just pkg -> do - -- Add the package's dependents also - ps' <- foldM add_unit_key ps (depends pkg) - return (p : ps') - where - add_unit_key ps key - = add_package dflags pkg_db ps (key, Just p) - -missingPackageMsg :: Outputable pkgid => pkgid -> SDoc -missingPackageMsg p = text "unknown package:" <+> ppr p - -missingDependencyMsg :: Maybe InstalledUnitId -> SDoc -missingDependencyMsg Nothing = Outputable.empty -missingDependencyMsg (Just parent) - = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) - --- ----------------------------------------------------------------------------- - -componentIdString :: DynFlags -> ComponentId -> Maybe String -componentIdString dflags cid = do - conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) - return $ - case sourceLibName conf of - Nothing -> sourcePackageIdString conf - Just (PackageName libname) -> - packageNameString conf - ++ "-" ++ showVersion (packageVersion conf) - ++ ":" ++ unpackFS libname - -displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String -displayInstalledUnitId dflags uid = - fmap sourcePackageIdString (lookupInstalledPackage dflags uid) - --- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> Module -> Name -> Bool --- Despite the "dll", I think this function just means that --- the symbol comes from another dynamically-linked package, --- and applies on all platforms, not just Windows -isDllName dflags this_mod name - | not (gopt Opt_ExternalDynamicRefs dflags) = False - | Just mod <- nameModule_maybe name - -- Issue #8696 - when GHC is dynamically linked, it will attempt - -- to load the dynamic dependencies of object files at compile - -- time for things like QuasiQuotes or - -- TemplateHaskell. Unfortunately, this interacts badly with - -- intra-package linking, because we don't generate indirect - -- (dynamic) symbols for intra-package calls. This means that if a - -- module with an intra-package call is loaded without its - -- dependencies, then GHC fails to link. This is the cause of # - -- - -- In the mean time, always force dynamic indirections to be - -- generated: when the module name isn't the module being - -- compiled, references are dynamic. - = case platformOS $ targetPlatform dflags of - -- On Windows the hack for #8696 makes it unlinkable. - -- As the entire setup of the code from Cmm down to the RTS expects - -- the use of trampolines for the imported functions only when - -- doing intra-package linking, e.g. refering to a symbol defined in the same - -- package should not use a trampoline. - -- I much rather have dynamic TH not supported than the entire Dynamic linking - -- not due to a hack. - -- Also not sure this would break on Windows anyway. - OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod - - -- For the other platforms, still perform the hack - _ -> mod /= this_mod - - | otherwise = False -- no, it is not even an external name - --- ----------------------------------------------------------------------------- --- Displaying packages - --- | Show (very verbose) package info -pprPackages :: DynFlags -> SDoc -pprPackages = pprPackagesWith pprPackageConfig - -pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc -pprPackagesWith pprIPI dflags = - vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags))) - --- | Show simplified package info. --- --- The idea is to only print package id, and any information that might --- be different from the package databases (exposure, trust) -pprPackagesSimple :: DynFlags -> SDoc -pprPackagesSimple = pprPackagesWith pprIPI - where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) - e = if exposed ipi then text "E" else text " " - t = if trusted ipi then text "T" else text " " - in e <> t <> text " " <> ftext i - --- | Show the mapping of modules to where they come from. -pprModuleMap :: ModuleToPkgConfAll -> SDoc -pprModuleMap mod_map = - vcat (map pprLine (Map.toList mod_map)) - where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) - pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc - pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) - | otherwise = ppr m' <+> parens (ppr o) - -fsPackageName :: PackageConfig -> FastString -fsPackageName = mkFastString . packageNameString - --- | Given a fully instantiated 'UnitId', improve it into a --- 'InstalledUnitId' if we can find it in the package database. -improveUnitId :: PackageConfigMap -> UnitId -> UnitId -improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit -improveUnitId pkg_map uid = - -- Do NOT lookup indefinite ones, they won't be useful! - case lookupPackage' False pkg_map uid of - Nothing -> uid - Just pkg -> - -- Do NOT improve if the indefinite unit id is not - -- part of the closure unique set. See - -- Note [UnitId to InstalledUnitId improvement] - if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map - then packageConfigId pkg - else uid - --- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used --- in the @hs-boot@ loop-breaker. -getPackageConfigMap :: DynFlags -> PackageConfigMap -getPackageConfigMap = pkgIdMap . pkgState - --- ----------------------------------------------------------------------------- --- | Find the package environment (if one exists) --- --- We interpret the package environment as a set of package flags; to be --- specific, if we find a package environment file like --- --- > clear-package-db --- > global-package-db --- > package-db blah/package.conf.d --- > package-id id1 --- > package-id id2 --- --- we interpret this as --- --- > [ -hide-all-packages --- > , -clear-package-db --- > , -global-package-db --- > , -package-db blah/package.conf.d --- > , -package-id id1 --- > , -package-id id2 --- > ] --- --- There's also an older syntax alias for package-id, which is just an --- unadorned package id --- --- > id1 --- > id2 --- -interpretPackageEnv :: DynFlags -> IO DynFlags -interpretPackageEnv dflags = do - mPkgEnv <- runMaybeT $ msum $ [ - getCmdLineArg >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , cmdLineError env - ] - , getEnvVar >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , envError env - ] - , notIfHideAllPackages >> msum [ - findLocalEnvFile >>= probeEnvFile - , probeEnvName defaultEnvName - ] - ] - case mPkgEnv of - Nothing -> - -- No environment found. Leave DynFlags unchanged. - return dflags - Just "-" -> do - -- Explicitly disabled environment file. Leave DynFlags unchanged. - return dflags - Just envfile -> do - content <- readFile envfile - compilationProgressMsg dflags ("Loaded package environment from " ++ envfile) - let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags - - return dflags' - where - -- Loading environments (by name or by location) - - namedEnvPath :: String -> MaybeT IO FilePath - namedEnvPath name = do - appdir <- versionedAppDir dflags - return $ appdir "environments" name - - probeEnvName :: String -> MaybeT IO FilePath - probeEnvName name = probeEnvFile =<< namedEnvPath name - - probeEnvFile :: FilePath -> MaybeT IO FilePath - probeEnvFile path = do - guard =<< liftMaybeT (doesFileExist path) - return path - - probeNullEnv :: FilePath -> MaybeT IO FilePath - probeNullEnv "-" = return "-" - probeNullEnv _ = mzero - - -- Various ways to define which environment to use - - getCmdLineArg :: MaybeT IO String - getCmdLineArg = MaybeT $ return $ packageEnv dflags - - getEnvVar :: MaybeT IO String - getEnvVar = do - mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" - case mvar of - Right var -> return var - Left err -> if isDoesNotExistError err then mzero - else liftMaybeT $ throwIO err - - notIfHideAllPackages :: MaybeT IO () - notIfHideAllPackages = - guard (not (gopt Opt_HideAllPackages dflags)) - - defaultEnvName :: String - defaultEnvName = "default" - - -- e.g. .ghc.environment.x86_64-linux-7.6.3 - localEnvFileName :: FilePath - localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags - - -- Search for an env file, starting in the current dir and looking upwards. - -- Fail if we get to the users home dir or the filesystem root. That is, - -- we don't look for an env file in the user's home dir. The user-wide - -- env lives in ghc's versionedAppDir/environments/default - findLocalEnvFile :: MaybeT IO FilePath - findLocalEnvFile = do - curdir <- liftMaybeT getCurrentDirectory - homedir <- tryMaybeT getHomeDirectory - let probe dir | isDrive dir || dir == homedir - = mzero - probe dir = do - let file = dir localEnvFileName - exists <- liftMaybeT (doesFileExist file) - if exists - then return file - else probe (takeDirectory dir) - probe curdir - - -- Error reporting - - cmdLineError :: String -> MaybeT IO a - cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " ++ show env ++ " not found" - - envError :: String -> MaybeT IO a - envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " - ++ show env - ++ " (specified in GHC_ENVIRONMENT) not found" diff --git a/main/Packages.hs-boot b/main/Packages.hs-boot deleted file mode 100644 --- a/main/Packages.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -module Packages where -import GhcPrelude -import {-# SOURCE #-} DynFlags(DynFlags) -import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) -data PackageState -data PackageConfigMap -emptyPackageState :: PackageState -componentIdString :: DynFlags -> ComponentId -> Maybe String -displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String -improveUnitId :: PackageConfigMap -> UnitId -> UnitId -getPackageConfigMap :: DynFlags -> PackageConfigMap diff --git a/main/PipelineMonad.hs b/main/PipelineMonad.hs deleted file mode 100644 --- a/main/PipelineMonad.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE NamedFieldPuns #-} --- | The CompPipeline monad and associated ops --- --- Defined in separate module so that it can safely be imported from Hooks -module PipelineMonad ( - CompPipeline(..), evalP - , PhasePlus(..) - , PipeEnv(..), PipeState(..), PipelineOutput(..) - , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface - , pipeStateDynFlags, pipeStateModIface - ) where - -import GhcPrelude - -import MonadUtils -import Outputable -import DynFlags -import DriverPhases -import HscTypes -import Module -import FileCleanup (TempFileLifetime) - -import Control.Monad - -newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } - deriving (Functor) - -evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a) -evalP (P f) env st = f env st - -instance Applicative CompPipeline where - pure a = P $ \_env state -> return (state, a) - (<*>) = ap - -instance Monad CompPipeline where - P m >>= k = P $ \env state -> do (state',a) <- m env state - unP (k a) env state' - -instance MonadIO CompPipeline where - liftIO m = P $ \_env state -> do a <- m; return (state, a) - -data PhasePlus = RealPhase Phase - | HscOut HscSource ModuleName HscStatus - -instance Outputable PhasePlus where - ppr (RealPhase p) = ppr p - ppr (HscOut {}) = text "HscOut" - --- ----------------------------------------------------------------------------- --- The pipeline uses a monad to carry around various bits of information - --- PipeEnv: invariant information passed down -data PipeEnv = PipeEnv { - stop_phase :: Phase, -- ^ Stop just before this phase - src_filename :: String, -- ^ basename of original input source - src_basename :: String, -- ^ basename of original input source - src_suffix :: String, -- ^ its extension - output_spec :: PipelineOutput -- ^ says where to put the pipeline output - } - --- PipeState: information that might change during a pipeline run -data PipeState = PipeState { - hsc_env :: HscEnv, - -- ^ only the DynFlags change in the HscEnv. The DynFlags change - -- at various points, for example when we read the OPTIONS_GHC - -- pragmas in the Cpp phase. - maybe_loc :: Maybe ModLocation, - -- ^ the ModLocation. This is discovered during compilation, - -- in the Hsc phase where we read the module header. - foreign_os :: [FilePath], - -- ^ additional object files resulting from compiling foreign - -- code. They come from two sources: foreign stubs, and - -- add{C,Cxx,Objc,Objcxx}File from template haskell - iface :: Maybe ModIface - -- ^ Interface generated by HscOut phase. Only available after the - -- phase runs. - } - -pipeStateDynFlags :: PipeState -> DynFlags -pipeStateDynFlags = hsc_dflags . hsc_env - -pipeStateModIface :: PipeState -> Maybe ModIface -pipeStateModIface = iface - -data PipelineOutput - = Temporary TempFileLifetime - -- ^ Output should be to a temporary file: we're going to - -- run more compilation steps on this output later. - | Persistent - -- ^ We want a persistent file, i.e. a file in the current directory - -- derived from the input filename, but with the appropriate extension. - -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. - | SpecificFile - -- ^ The output must go into the specific outputFile in DynFlags. - -- We don't store the filename in the constructor as it changes - -- when doing -dynamic-too. - deriving Show - -getPipeEnv :: CompPipeline PipeEnv -getPipeEnv = P $ \env state -> return (state, env) - -getPipeState :: CompPipeline PipeState -getPipeState = P $ \_env state -> return (state, state) - -instance HasDynFlags CompPipeline where - getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) - -setDynFlags :: DynFlags -> CompPipeline () -setDynFlags dflags = P $ \_env state -> - return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) - -setModLocation :: ModLocation -> CompPipeline () -setModLocation loc = P $ \_env state -> - return (state{ maybe_loc = Just loc }, ()) - -setForeignOs :: [FilePath] -> CompPipeline () -setForeignOs os = P $ \_env state -> - return (state{ foreign_os = os }, ()) - -setIface :: ModIface -> CompPipeline () -setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ()) diff --git a/main/PlatformConstants.hs b/main/PlatformConstants.hs deleted file mode 100644 --- a/main/PlatformConstants.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE CPP #-} - -------------------------------------------------------------------------------- --- --- | Platform constants --- --- (c) The University of Glasgow 2013 --- -------------------------------------------------------------------------------- - -module PlatformConstants (PlatformConstants(..)) where - -import GhcPrelude - --- Produced by deriveConstants -#include "GHCConstantsHaskellType.hs" - diff --git a/main/Plugins.hs b/main/Plugins.hs deleted file mode 100644 --- a/main/Plugins.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} - --- | Definitions for writing /plugins/ for GHC. Plugins can hook into --- several areas of the compiler. See the 'Plugin' type. These plugins --- include type-checker plugins, source plugins, and core-to-core plugins. - -module Plugins ( - -- * Plugins - Plugin(..) - , defaultPlugin - , CommandLineOption - -- ** Recompilation checking - , purePlugin, impurePlugin, flagRecompile - , PluginRecompile(..) - - -- * Plugin types - -- ** Frontend plugins - , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction - -- ** Core plugins - -- | Core plugins allow plugins to register as a Core-to-Core pass. - , CorePlugin - -- ** Typechecker plugins - -- | Typechecker plugins allow plugins to provide evidence to the - -- typechecker. - , TcPlugin - -- ** Source plugins - -- | GHC offers a number of points where plugins can access and modify its - -- front-end (\"source\") representation. These include: - -- - -- - access to the parser result with 'parsedResultAction' - -- - access to the renamed AST with 'renamedResultAction' - -- - access to the typechecked AST with 'typeCheckResultAction' - -- - access to the Template Haskell splices with 'spliceRunAction' - -- - access to loaded interface files with 'interfaceLoadAction' - -- - , keepRenamedSource - -- ** Hole fit plugins - -- | hole fit plugins allow plugins to change the behavior of valid hole - -- fit suggestions - , HoleFitPluginR - - -- * Internal - , PluginWithArgs(..), plugins, pluginRecompile' - , LoadedPlugin(..), lpModuleName - , StaticPlugin(..) - , mapPlugins, withPlugins, withPlugins_ - ) where - -import GhcPrelude - -import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) -import qualified TcRnTypes -import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) -import TcHoleFitTypes ( HoleFitPluginR ) -import GHC.Hs -import DynFlags -import HscTypes -import GhcMonad -import DriverPhases -import Module ( ModuleName, Module(moduleName)) -import Fingerprint -import Data.List (sort) -import Outputable (Outputable(..), text, (<+>)) - ---Qualified import so we can define a Semigroup instance --- but it doesn't clash with Outputable.<> -import qualified Data.Semigroup - -import Control.Monad - --- | Command line options gathered from the -PModule.Name:stuff syntax --- are given to you as this type -type CommandLineOption = String - --- | 'Plugin' is the compiler plugin data type. Try to avoid --- constructing one of these directly, and just modify some fields of --- 'defaultPlugin' instead: this is to try and preserve source-code --- compatibility when we add fields to this. --- --- Nonetheless, this API is preliminary and highly likely to change in --- the future. -data Plugin = Plugin { - installCoreToDos :: CorePlugin - -- ^ Modify the Core pipeline that will be used for compilation. - -- This is called as the Core pipeline is built for every module - -- being compiled, and plugins get the opportunity to modify the - -- pipeline in a nondeterministic order. - , tcPlugin :: TcPlugin - -- ^ An optional typechecker plugin, which may modify the - -- behaviour of the constraint solver. - , holeFitPlugin :: HoleFitPlugin - -- ^ An optional plugin to handle hole fits, which may re-order - -- or change the list of valid hole fits and refinement hole fits. - , dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags - -- ^ An optional plugin to update 'DynFlags', right after - -- plugin loading. This can be used to register hooks - -- or tweak any field of 'DynFlags' before doing - -- actual work on a module. - -- - -- @since 8.10.1 - , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile - -- ^ Specify how the plugin should affect recompilation. - , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule - -> Hsc HsParsedModule - -- ^ Modify the module when it is parsed. This is called by - -- HscMain when the parsing is successful. - , renamedResultAction :: [CommandLineOption] -> TcGblEnv - -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) - -- ^ Modify each group after it is renamed. This is called after each - -- `HsGroup` has been renamed. - , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv - -> TcM TcGblEnv - -- ^ Modify the module when it is type checked. This is called at the - -- very end of typechecking. - , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc - -> TcM (LHsExpr GhcTc) - -- ^ Modify the TH splice or quasiqoute before it is run. - , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface - -> IfM lcl ModIface - -- ^ Modify an interface that have been loaded. This is called by - -- LoadIface when an interface is successfully loaded. Not applied to - -- the loading of the plugin interface. Tools that rely on information from - -- modules other than the currently compiled one should implement this - -- function. - } - --- Note [Source plugins] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The `Plugin` datatype have been extended by fields that allow access to the --- different inner representations that are generated during the compilation --- process. These fields are `parsedResultAction`, `renamedResultAction`, --- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`. --- --- The main purpose of these plugins is to help tool developers. They allow --- development tools to extract the information about the source code of a big --- Haskell project during the normal build procedure. In this case the plugin --- acts as the tools access point to the compiler that can be controlled by --- compiler flags. This is important because the manipulation of compiler flags --- is supported by most build environment. --- --- For the full discussion, check the full proposal at: --- https://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal - -data PluginWithArgs = PluginWithArgs - { paPlugin :: Plugin - -- ^ the actual callable plugin - , paArguments :: [CommandLineOption] - -- ^ command line arguments for the plugin - } - --- | A plugin with its arguments. The result of loading the plugin. -data LoadedPlugin = LoadedPlugin - { lpPlugin :: PluginWithArgs - -- ^ the actual plugin together with its commandline arguments - , lpModule :: ModIface - -- ^ the module containing the plugin - } - --- | A static plugin with its arguments. For registering compiled-in plugins --- through the GHC API. -data StaticPlugin = StaticPlugin - { spPlugin :: PluginWithArgs - -- ^ the actual plugin together with its commandline arguments - } - -lpModuleName :: LoadedPlugin -> ModuleName -lpModuleName = moduleName . mi_module . lpModule - -pluginRecompile' :: PluginWithArgs -> IO PluginRecompile -pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args - -data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint - -instance Outputable PluginRecompile where - ppr ForceRecompile = text "ForceRecompile" - ppr NoForceRecompile = text "NoForceRecompile" - ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp - -instance Semigroup PluginRecompile where - ForceRecompile <> _ = ForceRecompile - NoForceRecompile <> r = r - MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp - MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp']) - MaybeRecompile _fp <> ForceRecompile = ForceRecompile - -instance Monoid PluginRecompile where - mempty = NoForceRecompile - -type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin -type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR - -purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile -purePlugin _args = return NoForceRecompile - -impurePlugin _args = return ForceRecompile - -flagRecompile = - return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort - --- | Default plugin: does nothing at all, except for marking that safe --- inference has failed unless @-fplugin-trustworthy@ is passed. For --- compatibility reaso you should base all your plugin definitions on this --- default value. -defaultPlugin :: Plugin -defaultPlugin = Plugin { - installCoreToDos = const return - , tcPlugin = const Nothing - , holeFitPlugin = const Nothing - , dynflagsPlugin = const return - , pluginRecompile = impurePlugin - , renamedResultAction = \_ env grp -> return (env, grp) - , parsedResultAction = \_ _ -> return - , typeCheckResultAction = \_ _ -> return - , spliceRunAction = \_ -> return - , interfaceLoadAction = \_ -> return - } - - --- | A renamer plugin which mades the renamed source available in --- a typechecker plugin. -keepRenamedSource :: [CommandLineOption] -> TcGblEnv - -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) -keepRenamedSource _ gbl_env group = - return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env) - , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group) - where - update_exports Nothing = Just [] - update_exports m = m - - update Nothing = Just emptyRnGroup - update m = m - - -type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a -type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () - -plugins :: DynFlags -> [PluginWithArgs] -plugins df = - map lpPlugin (cachedPlugins df) ++ - map spPlugin (staticPlugins df) - --- | Perform an operation by using all of the plugins in turn. -withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a -withPlugins df transformation input = foldM go input (plugins df) - where - go arg (PluginWithArgs p opts) = transformation p opts arg - -mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a] -mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df) - --- | Perform a constant operation by using all of the plugins in turn. -withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m () -withPlugins_ df transformation input - = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input) - (plugins df) - -type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () -data FrontendPlugin = FrontendPlugin { - frontend :: FrontendPluginAction - } -defaultFrontendPlugin :: FrontendPlugin -defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } diff --git a/main/Plugins.hs-boot b/main/Plugins.hs-boot deleted file mode 100644 --- a/main/Plugins.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ --- The plugins datatype is stored in DynFlags, so it needs to be --- exposed without importing all of its implementation. -module Plugins where - -import GhcPrelude () - -data Plugin - -data LoadedPlugin -data StaticPlugin diff --git a/main/PprTyThing.hs b/main/PprTyThing.hs deleted file mode 100644 --- a/main/PprTyThing.hs +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------------ --- --- Pretty-printing TyThings --- --- (c) The GHC Team 2005 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE CPP #-} -module PprTyThing ( - pprTyThing, - pprTyThingInContext, - pprTyThingLoc, - pprTyThingInContextLoc, - pprTyThingHdr, - pprTypeForUser, - pprFamInst - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) -import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..) - , showToHeader, pprIfaceDecl ) -import CoAxiom ( coAxiomTyCon ) -import HscTypes( tyThingParent_maybe ) -import MkIface ( tyThingToIfaceDecl ) -import FamInstEnv( FamInst(..), FamFlavor(..) ) -import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) -import Name -import VarEnv( emptyTidyEnv ) -import Outputable - --- ----------------------------------------------------------------------------- --- Pretty-printing entities that we get from the GHC API - -{- Note [Pretty printing via IfaceSyn] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our general plan for prett-printing - - Types - - TyCons - - Classes - - Pattern synonyms - ...etc... - -is to convert them to IfaceSyn, and pretty-print that. For example - - pprType converts a Type to an IfaceType, and pretty prints that. - - pprTyThing converts the TyThing to an IfaceDecl, - and pretty prints that. - -So IfaceSyn play a dual role: - - it's the internal version of an interface files - - it's used for pretty-printing - -Why do this? - -* A significant reason is that we need to be able - to pretty-print IfaceSyn (to display Foo.hi), and it was a - pain to duplicate masses of pretty-printing goop, esp for - Type and IfaceType. - -* When pretty-printing (a type, say), we want to tidy (with - tidyType) to avoids having (forall a a. blah) where the two - a's have different uniques. - - Alas, for type constructors, TyCon, tidying does not work well, - because a TyCon includes DataCons which include Types, which mention - TyCons. And tidying can't tidy a mutually recursive data structure - graph, only trees. - -* Interface files contains fast-strings, not uniques, so the very same - tidying must take place when we convert to IfaceDecl. E.g. - MkIface.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon, - Class etc) to an IfaceDecl. - - Bottom line: IfaceDecls are already 'tidy', so it's straightforward - to print them. - -* An alternative I once explored was to ensure that TyCons get type - variables with distinct print-names. That's ok for type variables - but less easy for kind variables. Processing data type declarations - is already so complicated that I don't think it's sensible to add - the extra requirement that it generates only "pretty" types and - kinds. - -Consequences: - -- IfaceSyn (and IfaceType) must contain enough information to - print nicely. Hence, for example, the IfaceAppArgs type, which - allows us to suppress invisible kind arguments in types - (see Note [Suppressing invisible arguments] in IfaceType) - -- In a few places we have info that is used only for pretty-printing, - and is totally ignored when turning IfaceSyn back into TyCons - etc (in TcIface). For example, IfaceClosedSynFamilyTyCon - stores a [IfaceAxBranch] that is used only for pretty-printing. - -- See Note [Free tyvars in IfaceType] in IfaceType - -See #7730, #8776 for details -} - --------------------- --- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. -pprFamInst :: FamInst -> SDoc --- * For data instances we go via pprTyThing of the representational TyCon, --- because there is already much cleverness associated with printing --- data type declarations that I don't want to duplicate --- * For type instances we print directly here; there is no TyCon --- to give to pprTyThing --- --- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes - -pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) - = pprTyThingInContextLoc (ATyCon rep_tc) - -pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom - , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs }) - = showWithLoc (pprDefinedAt (getName axiom)) $ - hang (text "type instance" - <+> pprUserForAll (mkTyVarBinders Specified tvs) - -- See Note [Printing foralls in type family instances] - -- in IfaceType - <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) - 2 (equals <+> ppr rhs) - ----------------------------- --- | Pretty-prints a 'TyThing' with its defining location. -pprTyThingLoc :: TyThing -> SDoc -pprTyThingLoc tyThing - = showWithLoc (pprDefinedAt (getName tyThing)) - (pprTyThing showToHeader tyThing) - --- | Pretty-prints the 'TyThing' header. For functions and data constructors --- the function is equivalent to 'pprTyThing' but for type constructors --- and classes it prints only the header part of the declaration. -pprTyThingHdr :: TyThing -> SDoc -pprTyThingHdr = pprTyThing showToHeader - --- | Pretty-prints a 'TyThing' in context: that is, if the entity --- is a data constructor, record selector, or class method, then --- the entity's parent declaration is pretty-printed with irrelevant --- parts omitted. -pprTyThingInContext :: ShowSub -> TyThing -> SDoc -pprTyThingInContext show_sub thing - = go [] thing - where - go ss thing - = case tyThingParent_maybe thing of - Just parent -> - go (getOccName thing : ss) parent - Nothing -> - pprTyThing - (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) }) - thing - --- | Like 'pprTyThingInContext', but adds the defining location. -pprTyThingInContextLoc :: TyThing -> SDoc -pprTyThingInContextLoc tyThing - = showWithLoc (pprDefinedAt (getName tyThing)) - (pprTyThingInContext showToHeader tyThing) - --- | Pretty-prints a 'TyThing'. -pprTyThing :: ShowSub -> TyThing -> SDoc --- We pretty-print 'TyThing' via 'IfaceDecl' --- See Note [Pretty-printing TyThings] -pprTyThing ss ty_thing - = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing) - where - ss' = case ss_how_much ss of - ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } - ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' } - _ -> ss - - ppr' = AltPpr $ ppr_bndr $ getName ty_thing - - ppr_bndr :: Name -> Maybe (OccName -> SDoc) - ppr_bndr name - | isBuiltInSyntax name - = Nothing - | otherwise - = case nameModule_maybe name of - Just mod -> Just $ \occ -> getPprStyle $ \sty -> - pprModulePrefix sty mod occ <> ppr occ - Nothing -> WARN( True, ppr name ) Nothing - -- Nothing is unexpected here; TyThings have External names - -pprTypeForUser :: Type -> SDoc --- The type is tidied -pprTypeForUser ty - = pprSigmaType tidy_ty - where - (_, tidy_ty) = tidyOpenType emptyTidyEnv ty - -- Often the types/kinds we print in ghci are fully generalised - -- and have no free variables, but it turns out that we sometimes - -- print un-generalised kinds (eg when doing :k T), so it's - -- better to use tidyOpenType here - -showWithLoc :: SDoc -> SDoc -> SDoc -showWithLoc loc doc - = hang doc 2 (char '\t' <> comment <+> loc) - -- The tab tries to make them line up a bit - where - comment = text "--" diff --git a/main/Settings.hs b/main/Settings.hs deleted file mode 100644 --- a/main/Settings.hs +++ /dev/null @@ -1,215 +0,0 @@ -module Settings - ( Settings (..) - , sProgramName - , sProjectVersion - , sGhcUsagePath - , sGhciUsagePath - , sToolDir - , sTopDir - , sTmpDir - , sSystemPackageConfig - , sLdSupportsCompactUnwind - , sLdSupportsBuildId - , sLdSupportsFilelist - , sLdIsGnuLd - , sGccSupportsNoPie - , sPgm_L - , sPgm_P - , sPgm_F - , sPgm_c - , sPgm_a - , sPgm_l - , sPgm_lm - , sPgm_dll - , sPgm_T - , sPgm_windres - , sPgm_libtool - , sPgm_ar - , sPgm_otool - , sPgm_install_name_tool - , sPgm_ranlib - , sPgm_lo - , sPgm_lc - , sPgm_lcc - , sPgm_i - , sOpt_L - , sOpt_P - , sOpt_P_fingerprint - , sOpt_F - , sOpt_c - , sOpt_cxx - , sOpt_a - , sOpt_l - , sOpt_lm - , sOpt_windres - , sOpt_lo - , sOpt_lc - , sOpt_lcc - , sOpt_i - , sExtraGccViaCFlags - , sTargetPlatformString - , sIntegerLibrary - , sIntegerLibraryType - , sGhcWithInterpreter - , sGhcWithNativeCodeGen - , sGhcWithSMP - , sGhcRTSWays - , sTablesNextToCode - , sLeadingUnderscore - , sLibFFI - , sGhcThreaded - , sGhcDebugged - , sGhcRtsWithLibdw - ) where - -import GhcPrelude - -import CliOption -import Fingerprint -import FileSettings -import GhcNameVersion -import GHC.Platform -import PlatformConstants -import ToolSettings - -data Settings = Settings - { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion - , sFileSettings :: {-# UNPACK #-} !FileSettings - , sTargetPlatform :: Platform -- Filled in by SysTools - , sToolSettings :: {-# UNPACK #-} !ToolSettings - , sPlatformMisc :: {-# UNPACK #-} !PlatformMisc - , sPlatformConstants :: PlatformConstants - - -- You shouldn't need to look things up in rawSettings directly. - -- They should have their own fields instead. - , sRawSettings :: [(String, String)] - } - ------------------------------------------------------------------------------ --- Accessessors from 'Settings' - -sProgramName :: Settings -> String -sProgramName = ghcNameVersion_programName . sGhcNameVersion -sProjectVersion :: Settings -> String -sProjectVersion = ghcNameVersion_projectVersion . sGhcNameVersion - -sGhcUsagePath :: Settings -> FilePath -sGhcUsagePath = fileSettings_ghcUsagePath . sFileSettings -sGhciUsagePath :: Settings -> FilePath -sGhciUsagePath = fileSettings_ghciUsagePath . sFileSettings -sToolDir :: Settings -> Maybe FilePath -sToolDir = fileSettings_toolDir . sFileSettings -sTopDir :: Settings -> FilePath -sTopDir = fileSettings_topDir . sFileSettings -sTmpDir :: Settings -> String -sTmpDir = fileSettings_tmpDir . sFileSettings -sSystemPackageConfig :: Settings -> FilePath -sSystemPackageConfig = fileSettings_systemPackageConfig . sFileSettings - -sLdSupportsCompactUnwind :: Settings -> Bool -sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings -sLdSupportsBuildId :: Settings -> Bool -sLdSupportsBuildId = toolSettings_ldSupportsBuildId . sToolSettings -sLdSupportsFilelist :: Settings -> Bool -sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings -sLdIsGnuLd :: Settings -> Bool -sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings -sGccSupportsNoPie :: Settings -> Bool -sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings - -sPgm_L :: Settings -> String -sPgm_L = toolSettings_pgm_L . sToolSettings -sPgm_P :: Settings -> (String, [Option]) -sPgm_P = toolSettings_pgm_P . sToolSettings -sPgm_F :: Settings -> String -sPgm_F = toolSettings_pgm_F . sToolSettings -sPgm_c :: Settings -> String -sPgm_c = toolSettings_pgm_c . sToolSettings -sPgm_a :: Settings -> (String, [Option]) -sPgm_a = toolSettings_pgm_a . sToolSettings -sPgm_l :: Settings -> (String, [Option]) -sPgm_l = toolSettings_pgm_l . sToolSettings -sPgm_lm :: Settings -> (String, [Option]) -sPgm_lm = toolSettings_pgm_lm . sToolSettings -sPgm_dll :: Settings -> (String, [Option]) -sPgm_dll = toolSettings_pgm_dll . sToolSettings -sPgm_T :: Settings -> String -sPgm_T = toolSettings_pgm_T . sToolSettings -sPgm_windres :: Settings -> String -sPgm_windres = toolSettings_pgm_windres . sToolSettings -sPgm_libtool :: Settings -> String -sPgm_libtool = toolSettings_pgm_libtool . sToolSettings -sPgm_ar :: Settings -> String -sPgm_ar = toolSettings_pgm_ar . sToolSettings -sPgm_otool :: Settings -> String -sPgm_otool = toolSettings_pgm_otool . sToolSettings -sPgm_install_name_tool :: Settings -> String -sPgm_install_name_tool = toolSettings_pgm_install_name_tool . sToolSettings -sPgm_ranlib :: Settings -> String -sPgm_ranlib = toolSettings_pgm_ranlib . sToolSettings -sPgm_lo :: Settings -> (String, [Option]) -sPgm_lo = toolSettings_pgm_lo . sToolSettings -sPgm_lc :: Settings -> (String, [Option]) -sPgm_lc = toolSettings_pgm_lc . sToolSettings -sPgm_lcc :: Settings -> (String, [Option]) -sPgm_lcc = toolSettings_pgm_lcc . sToolSettings -sPgm_i :: Settings -> String -sPgm_i = toolSettings_pgm_i . sToolSettings -sOpt_L :: Settings -> [String] -sOpt_L = toolSettings_opt_L . sToolSettings -sOpt_P :: Settings -> [String] -sOpt_P = toolSettings_opt_P . sToolSettings -sOpt_P_fingerprint :: Settings -> Fingerprint -sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings -sOpt_F :: Settings -> [String] -sOpt_F = toolSettings_opt_F . sToolSettings -sOpt_c :: Settings -> [String] -sOpt_c = toolSettings_opt_c . sToolSettings -sOpt_cxx :: Settings -> [String] -sOpt_cxx = toolSettings_opt_cxx . sToolSettings -sOpt_a :: Settings -> [String] -sOpt_a = toolSettings_opt_a . sToolSettings -sOpt_l :: Settings -> [String] -sOpt_l = toolSettings_opt_l . sToolSettings -sOpt_lm :: Settings -> [String] -sOpt_lm = toolSettings_opt_lm . sToolSettings -sOpt_windres :: Settings -> [String] -sOpt_windres = toolSettings_opt_windres . sToolSettings -sOpt_lo :: Settings -> [String] -sOpt_lo = toolSettings_opt_lo . sToolSettings -sOpt_lc :: Settings -> [String] -sOpt_lc = toolSettings_opt_lc . sToolSettings -sOpt_lcc :: Settings -> [String] -sOpt_lcc = toolSettings_opt_lcc . sToolSettings -sOpt_i :: Settings -> [String] -sOpt_i = toolSettings_opt_i . sToolSettings - -sExtraGccViaCFlags :: Settings -> [String] -sExtraGccViaCFlags = toolSettings_extraGccViaCFlags . sToolSettings - -sTargetPlatformString :: Settings -> String -sTargetPlatformString = platformMisc_targetPlatformString . sPlatformMisc -sIntegerLibrary :: Settings -> String -sIntegerLibrary = platformMisc_integerLibrary . sPlatformMisc -sIntegerLibraryType :: Settings -> IntegerLibrary -sIntegerLibraryType = platformMisc_integerLibraryType . sPlatformMisc -sGhcWithInterpreter :: Settings -> Bool -sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc -sGhcWithNativeCodeGen :: Settings -> Bool -sGhcWithNativeCodeGen = platformMisc_ghcWithNativeCodeGen . sPlatformMisc -sGhcWithSMP :: Settings -> Bool -sGhcWithSMP = platformMisc_ghcWithSMP . sPlatformMisc -sGhcRTSWays :: Settings -> String -sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc -sTablesNextToCode :: Settings -> Bool -sTablesNextToCode = platformMisc_tablesNextToCode . sPlatformMisc -sLeadingUnderscore :: Settings -> Bool -sLeadingUnderscore = platformMisc_leadingUnderscore . sPlatformMisc -sLibFFI :: Settings -> Bool -sLibFFI = platformMisc_libFFI . sPlatformMisc -sGhcThreaded :: Settings -> Bool -sGhcThreaded = platformMisc_ghcThreaded . sPlatformMisc -sGhcDebugged :: Settings -> Bool -sGhcDebugged = platformMisc_ghcDebugged . sPlatformMisc -sGhcRtsWithLibdw :: Settings -> Bool -sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc diff --git a/main/StaticPtrTable.hs b/main/StaticPtrTable.hs deleted file mode 100644 --- a/main/StaticPtrTable.hs +++ /dev/null @@ -1,293 +0,0 @@ --- | Code generation for the Static Pointer Table --- --- (c) 2014 I/O Tweag --- --- Each module that uses 'static' keyword declares an initialization function of --- the form hs_spt_init_() which is emitted into the _stub.c file and --- annotated with __attribute__((constructor)) so that it gets executed at --- startup time. --- --- The function's purpose is to call hs_spt_insert to insert the static --- pointers of this module in the hashtable of the RTS, and it looks something --- like this: --- --- > static void hs_hpc_init_Main(void) __attribute__((constructor)); --- > static void hs_hpc_init_Main(void) { --- > --- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > extern StgPtr Main_r2wb_closure; --- > hs_spt_insert(k0, &Main_r2wb_closure); --- > --- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > extern StgPtr Main_r2wc_closure; --- > hs_spt_insert(k1, &Main_r2wc_closure); --- > --- > } --- --- where the constants are fingerprints produced from the static forms. --- --- The linker must find the definitions matching the @extern StgPtr @ --- declarations. For this to work, the identifiers of static pointers need to be --- exported. This is done in SetLevels.newLvlVar. --- --- There is also a finalization function for the time when the module is --- unloaded. --- --- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); --- > static void hs_hpc_fini_Main(void) { --- > --- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > hs_spt_remove(k0); --- > --- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > hs_spt_remove(k1); --- > --- > } --- - -{-# LANGUAGE ViewPatterns, TupleSections #-} -module StaticPtrTable - ( sptCreateStaticBinds - , sptModuleInitCode - ) where - -{- Note [Grand plan for static forms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Static forms go through the compilation phases as follows. -Here is a running example: - - f x = let k = map toUpper - in ...(static k)... - -* The renamer looks for out-of-scope names in the body of the static - form, as always. If all names are in scope, the free variables of the - body are stored in AST at the location of the static form. - -* The typechecker verifies that all free variables occurring in the - static form are floatable to top level (see Note [Meaning of - IdBindingInfo] in TcRnTypes). In our example, 'k' is floatable. - Even though it is bound in a nested let, we are fine. - -* The desugarer replaces the static form with an application of the - function 'makeStatic' (defined in module GHC.StaticPtr.Internal of - base). So we get - - f x = let k = map toUpper - in ...fromStaticPtr (makeStatic location k)... - -* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic' - to the top level. Thus the FloatOut pass is always executed, even when - optimizations are disabled. So we get - - k = map toUpper - static_ptr = makeStatic location k - f x = ...fromStaticPtr static_ptr... - - The FloatOut pass is careful to produce an /exported/ Id for a floated - 'makeStatic' call, so the binding is not removed or inlined by the - simplifier. - E.g. the code for `f` above might look like - - static_ptr = makeStatic location k - f x = ...(case static_ptr of ...)... - - which might be simplified to - - f x = ...(case makeStatic location k of ...)... - - BUT the top-level binding for static_ptr must remain, so that it can be - collected to populate the Static Pointer Table. - - Making the binding exported also has a necessary effect during the - CoreTidy pass. - -* The CoreTidy pass replaces all bindings of the form - - b = /\ ... -> makeStatic location value - - with - - b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value - - where a distinct key is generated for each binding. - -* If we are compiling to object code we insert a C stub (generated by - sptModuleInitCode) into the final object which runs when the module is loaded, - inserting the static forms defined by the module into the RTS's static pointer - table. - -* If we are compiling for the byte-code interpreter, we instead explicitly add - the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter - process' SPT table using the addSptEntry interpreter message. This happens - in upsweep after we have compiled the module (see GhcMake.upsweep'). --} - -import GhcPrelude - -import CLabel -import CoreSyn -import CoreUtils (collectMakeStaticArgs) -import DataCon -import DynFlags -import HscTypes -import Id -import MkCore (mkStringExprFSWith) -import Module -import Name -import Outputable -import GHC.Platform -import PrelNames -import TcEnv (lookupGlobal) -import Type - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State -import Data.List -import Data.Maybe -import GHC.Fingerprint -import qualified GHC.LanguageExtensions as LangExt - --- | Replaces all bindings of the form --- --- > b = /\ ... -> makeStatic location value --- --- with --- --- > b = /\ ... -> --- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value --- --- where a distinct key is generated for each binding. --- --- It also yields the C stub that inserts these bindings into the static --- pointer table. -sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram - -> IO ([SptEntry], CoreProgram) -sptCreateStaticBinds hsc_env this_mod binds - | not (xopt LangExt.StaticPointers dflags) = - return ([], binds) - | otherwise = do - -- Make sure the required interface files are loaded. - _ <- lookupGlobal hsc_env unpackCStringName - (fps, binds') <- evalStateT (go [] [] binds) 0 - return (fps, binds') - where - go fps bs xs = case xs of - [] -> return (reverse fps, reverse bs) - bnd : xs' -> do - (fps', bnd') <- replaceStaticBind bnd - go (reverse fps' ++ fps) (bnd' : bs) xs' - - dflags = hsc_dflags hsc_env - - -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. - -- - -- The 'Int' state is used to produce a different key for each binding. - replaceStaticBind :: CoreBind - -> StateT Int IO ([SptEntry], CoreBind) - replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e - return (maybeToList mfp, NonRec b' e') - replaceStaticBind (Rec rbs) = do - (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs - return (catMaybes mfps, Rec rbs') - - replaceStatic :: Id -> CoreExpr - -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) - replaceStatic b e@(collectTyBinders -> (tvs, e0)) = - case collectMakeStaticArgs e0 of - Nothing -> return (Nothing, (b, e)) - Just (_, t, info, arg) -> do - (fp, e') <- mkStaticBind t info arg - return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) - - mkStaticBind :: Type -> CoreExpr -> CoreExpr - -> StateT Int IO (Fingerprint, CoreExpr) - mkStaticBind t srcLoc e = do - i <- get - put (i + 1) - staticPtrInfoDataCon <- - lift $ lookupDataConHscEnv staticPtrInfoDataConName - let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i - info <- mkConApp staticPtrInfoDataCon <$> - (++[srcLoc]) <$> - mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) - [ unitIdFS $ moduleUnitId this_mod - , moduleNameFS $ moduleName this_mod - ] - - -- The module interface of GHC.StaticPtr should be loaded at least - -- when looking up 'fromStatic' during type-checking. - staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName - return (fp, mkConApp staticPtrDataCon - [ Type t - , mkWord64LitWordRep dflags w0 - , mkWord64LitWordRep dflags w1 - , info - , e ]) - - mkStaticPtrFingerprint :: Int -> Fingerprint - mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" - [ unitIdString $ moduleUnitId this_mod - , moduleNameString $ moduleName this_mod - , show n - ] - - -- Choose either 'Word64#' or 'Word#' to represent the arguments of the - -- 'Fingerprint' data constructor. - mkWord64LitWordRep dflags = - case platformWordSize (targetPlatform dflags) of - PW4 -> mkWord64LitWord64 - PW8 -> mkWordLit dflags . toInteger - - lookupIdHscEnv :: Name -> IO Id - lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>= - maybe (getError n) (return . tyThingId) - - lookupDataConHscEnv :: Name -> IO DataCon - lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>= - maybe (getError n) (return . tyThingDataCon) - - getError n = pprPanic "sptCreateStaticBinds.get: not found" $ - text "Couldn't find" <+> ppr n - --- | @sptModuleInitCode module fps@ is a C stub to insert the static entries --- of @module@ into the static pointer table. --- --- @fps@ is a list associating each binding corresponding to a static entry with --- its fingerprint. -sptModuleInitCode :: Module -> [SptEntry] -> SDoc -sptModuleInitCode _ [] = Outputable.empty -sptModuleInitCode this_mod entries = vcat - [ text "static void hs_spt_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" - , braces $ vcat $ - [ text "static StgWord64 k" <> int i <> text "[2] = " - <> pprFingerprint fp <> semi - $$ text "extern StgPtr " - <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi - $$ text "hs_spt_insert" <> parens - (hcat $ punctuate comma - [ char 'k' <> int i - , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) - ] - ) - <> semi - | (i, SptEntry n fp) <- zip [0..] entries - ] - , text "static void hs_spt_fini_" <> ppr this_mod - <> text "(void) __attribute__((destructor));" - , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" - , braces $ vcat $ - [ text "StgWord64 k" <> int i <> text "[2] = " - <> pprFingerprint fp <> semi - $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi - | (i, (SptEntry _ fp)) <- zip [0..] entries - ] - ] - where - pprFingerprint :: Fingerprint -> SDoc - pprFingerprint (Fingerprint w1 w2) = - braces $ hcat $ punctuate comma - [ integer (fromIntegral w1) <> text "ULL" - , integer (fromIntegral w2) <> text "ULL" - ] diff --git a/main/SysTools.hs b/main/SysTools.hs deleted file mode 100644 --- a/main/SysTools.hs +++ /dev/null @@ -1,483 +0,0 @@ -{- ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2001-2003 --- --- Access to system tools: gcc, cp, rm etc --- ------------------------------------------------------------------------------ --} - -{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-} - -module SysTools ( - -- * Initialisation - initSysTools, - lazyInitLlvmConfig, - - -- * Interface to system tools - module SysTools.Tasks, - module SysTools.Info, - - linkDynLib, - - copy, - copyWithHeader, - - -- * General utilities - Option(..), - expandTopDir, - - -- * Platform-specifics - libmLinkOpts, - - -- * Mac OS X frameworks - getPkgFrameworkOpts, - getFrameworkOpts - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Settings - -import Module -import Packages -import Outputable -import ErrUtils -import GHC.Platform -import DynFlags - -import Control.Monad.Trans.Except (runExceptT) -import System.FilePath -import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) -import SysTools.ExtraObj -import SysTools.Info -import SysTools.Tasks -import SysTools.BaseDir -import SysTools.Settings - -{- -Note [How GHC finds toolchain utilities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -SysTools.initSysProgs figures out exactly where all the auxiliary programs -are, and initialises mutable variables to make it easy to call them. -To do this, it makes use of definitions in Config.hs, which is a Haskell -file containing variables whose value is figured out by the build system. - -Config.hs contains two sorts of things - - cGCC, The *names* of the programs - cCPP e.g. cGCC = gcc - cUNLIT cCPP = gcc -E - etc They do *not* include paths - - - cUNLIT_DIR The *path* to the directory containing unlit, split etc - cSPLIT_DIR *relative* to the root of the build tree, - for use when running *in-place* in a build tree (only) - - ---------------------------------------------- -NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): - -Another hair-brained scheme for simplifying the current tool location -nightmare in GHC: Simon originally suggested using another -configuration file along the lines of GCC's specs file - which is fine -except that it means adding code to read yet another configuration -file. What I didn't notice is that the current package.conf is -general enough to do this: - -Package - {name = "tools", import_dirs = [], source_dirs = [], - library_dirs = [], hs_libraries = [], extra_libraries = [], - include_dirs = [], c_includes = [], package_deps = [], - extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], - extra_cc_opts = [], extra_ld_opts = []} - -Which would have the advantage that we get to collect together in one -place the path-specific package stuff with the path-specific tool -stuff. - End of NOTES ---------------------------------------------- - -************************************************************************ -* * -\subsection{Initialisation} -* * -************************************************************************ --} - --- Note [LLVM configuration] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain --- information needed by the LLVM backend to invoke `llc` and `opt`. --- Specifically: --- --- * llvm-targets maps autoconf host triples to the corresponding LLVM --- `data-layout` declarations. This information is extracted from clang using --- the script in utils/llvm-targets/gen-data-layout.sh and should be updated --- whenever we target a new version of LLVM. --- --- * llvm-passes maps GHC optimization levels to sets of LLVM optimization --- flags that GHC should pass to `opt`. --- --- This information is contained in files rather the GHC source to allow users --- to add new targets to GHC without having to recompile the compiler. --- --- Since this information is only needed by the LLVM backend we load it lazily --- with unsafeInterleaveIO. Consequently it is important that we lazily pattern --- match on LlvmConfig until we actually need its contents. - -lazyInitLlvmConfig :: String - -> IO LlvmConfig -lazyInitLlvmConfig top_dir - = unsafeInterleaveIO $ do -- see Note [LLVM configuration] - targets <- readAndParse "llvm-targets" mkLlvmTarget - passes <- readAndParse "llvm-passes" id - return $ LlvmConfig { llvmTargets = targets, llvmPasses = passes } - where - readAndParse name builder = - do let llvmConfigFile = top_dir name - llvmConfigStr <- readFile llvmConfigFile - case maybeReadFuzzy llvmConfigStr of - Just s -> return (fmap builder <$> s) - Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) - - mkLlvmTarget :: (String, String, String) -> LlvmTarget - mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) - - -initSysTools :: String -- TopDir path - -> IO Settings -- Set all the mutable variables above, holding - -- (a) the system programs - -- (b) the package-config file - -- (c) the GHC usage message -initSysTools top_dir = do - res <- runExceptT $ initSettings top_dir - case res of - Right a -> pure a - Left (SettingsError_MissingData msg) -> pgmError msg - Left (SettingsError_BadData msg) -> pgmError msg - -{- Note [Windows stack usage] - -See: #8870 (and #8834 for related info) and #12186 - -On Windows, occasionally we need to grow the stack. In order to do -this, we would normally just bump the stack pointer - but there's a -catch on Windows. - -If the stack pointer is bumped by more than a single page, then the -pages between the initial pointer and the resulting location must be -properly committed by the Windows virtual memory subsystem. This is -only needed in the event we bump by more than one page (i.e 4097 bytes -or more). - -Windows compilers solve this by emitting a call to a special function -called _chkstk, which does this committing of the pages for you. - -The reason this was causing a segfault was because due to the fact the -new code generator tends to generate larger functions, we needed more -stack space in GHC itself. In the x86 codegen, we needed approximately -~12kb of stack space in one go, which caused the process to segfault, -as the intervening pages were not committed. - -GCC can emit such a check for us automatically but only when the flag --fstack-check is used. - -See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html -for more information. - --} - -copy :: DynFlags -> String -> FilePath -> FilePath -> IO () -copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to - -copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath - -> IO () -copyWithHeader dflags purpose maybe_header from to = do - showPass dflags purpose - - hout <- openBinaryFile to WriteMode - hin <- openBinaryFile from ReadMode - ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up - maybe (return ()) (header hout) maybe_header - hPutStr hout ls - hClose hout - hClose hin - where - -- write the header string in UTF-8. The header is something like - -- {-# LINE "foo.hs" #-} - -- and we want to make sure a Unicode filename isn't mangled. - header h str = do - hSetEncoding h utf8 - hPutStr h str - hSetBinaryMode h True - -{- -************************************************************************ -* * -\subsection{Support code} -* * -************************************************************************ --} - -linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkDynLib dflags0 o_files dep_packages - = do - let -- This is a rather ugly hack to fix dynamically linked - -- GHC on Windows. If GHC is linked with -threaded, then - -- it links against libHSrts_thr. But if base is linked - -- against libHSrts, then both end up getting loaded, - -- and things go wrong. We therefore link the libraries - -- with the same RTS flags that we link GHC with. - dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0 - then addWay' WayThreaded dflags0 - else dflags0 - dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1 - then addWay' WayDebug dflags1 - else dflags1 - dflags = updateWays dflags2 - - verbFlags = getVerbFlags dflags - o_file = outputFile dflags - - pkgs <- getPreloadPackagesAnd dflags dep_packages - - let platform = targetPlatform dflags - os = platformOS platform - let pkg_lib_paths = collectLibraryPaths dflags pkgs - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | ( osElfTarget (platformOS (targetPlatform dflags)) || - osMachOTarget (platformOS (targetPlatform dflags)) ) && - dynLibLoader dflags == SystemDependent && - -- Only if we want dynamic libraries - WayDyn `elem` ways dflags && - -- Only use RPath if we explicitly asked for it - useXLinkerRPath dflags os - = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - | otherwise = ["-L" ++ l] - - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - -- We don't want to link our dynamic libs against the RTS package, - -- because the RTS lib comes in several flavours and we want to be - -- able to pick the flavour when a binary is linked. - -- On Windows we need to link the RTS import lib as Windows does - -- not allow undefined symbols. - -- The RTS library path is still added to the library search path - -- above in case the RTS is being explicitly linked in (see #3807). - let pkgs_no_rts = case os of - OSMinGW32 -> - pkgs - _ -> - filter ((/= rtsUnitId) . packageConfigId) pkgs - let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts - in package_hs_libs ++ extra_libs ++ other_flags - - -- probably _stub.o files - -- and last temporary shared object file - let extra_ld_inputs = ldInputs dflags - - -- frameworks - pkg_framework_opts <- getPkgFrameworkOpts dflags platform - (map unitId pkgs) - let framework_opts = getFrameworkOpts dflags platform - - case os of - OSMinGW32 -> do - ------------------------------------------------------------- - -- Making a DLL - ------------------------------------------------------------- - let output_fn = case o_file of - Just s -> s - Nothing -> "HSdll.dll" - - runLink dflags ( - map Option verbFlags - ++ [ Option "-o" - , FileOption "" output_fn - , Option "-shared" - ] ++ - [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | gopt Opt_SharedImplib dflags - ] - ++ map (FileOption "") o_files - - -- Permit the linker to auto link _symbol to _imp_symbol - -- This lets us link against DLLs without needing an "import library" - ++ [Option "-Wl,--enable-auto-import"] - - ++ extra_ld_inputs - ++ map Option ( - lib_path_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) - _ | os == OSDarwin -> do - ------------------------------------------------------------------- - -- Making a darwin dylib - ------------------------------------------------------------------- - -- About the options used for Darwin: - -- -dynamiclib - -- Apple's way of saying -shared - -- -undefined dynamic_lookup: - -- Without these options, we'd have to specify the correct - -- dependencies for each of the dylibs. Note that we could - -- (and should) do without this for all libraries except - -- the RTS; all we need to do is to pass the correct - -- HSfoo_dyn.dylib files to the link command. - -- This feature requires Mac OS X 10.3 or later; there is - -- a similar feature, -flat_namespace -undefined suppress, - -- which works on earlier versions, but it has other - -- disadvantages. - -- -single_module - -- Build the dynamic library as a single "module", i.e. no - -- dynamic binding nonsense when referring to symbols from - -- within the library. The NCG assumes that this option is - -- specified (on i386, at least). - -- -install_name - -- Mac OS/X stores the path where a dynamic library is (to - -- be) installed in the library itself. It's called the - -- "install name" of the library. Then any library or - -- executable that links against it before it's installed - -- will search for it in its ultimate install location. - -- By default we set the install name to the absolute path - -- at build time, but it can be overridden by the - -- -dylib-install-name option passed to ghc. Cabal does - -- this. - ------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - instName <- case dylibInstallName dflags of - Just n -> return n - Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) - runLink dflags ( - map Option verbFlags - ++ [ Option "-dynamiclib" - , Option "-o" - , FileOption "" output_fn - ] - ++ map Option o_files - ++ [ Option "-undefined", - Option "dynamic_lookup", - Option "-single_module" ] - ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ] - then [ ] - else [ Option "-Wl,-read_only_relocs,suppress" ]) - ++ [ Option "-install_name", Option instName ] - ++ map Option lib_path_opts - ++ extra_ld_inputs - ++ map Option framework_opts - ++ map Option pkg_lib_path_opts - ++ map Option pkg_link_opts - ++ map Option pkg_framework_opts - -- dead_strip_dylibs, will remove unused dylibs, and thus save - -- space in the load commands. The -headerpad is necessary so - -- that we can inject more @rpath's later for the leftover - -- libraries in the runInjectRpaths phase below. - -- - -- See Note [Dynamic linking on macOS] - ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] - ) - runInjectRPaths dflags pkg_lib_paths output_fn - _ -> do - ------------------------------------------------------------------- - -- Making a DSO - ------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - unregisterised = platformUnregisterised (targetPlatform dflags) - let bsymbolicFlag = -- we need symbolic linking to resolve - -- non-PIC intra-package-relocations for - -- performance (where symbolic linking works) - -- See Note [-Bsymbolic assumptions by GHC] - ["-Wl,-Bsymbolic" | not unregisterised] - - runLink dflags ( - map Option verbFlags - ++ libmLinkOpts - ++ [ Option "-o" - , FileOption "" output_fn - ] - ++ map Option o_files - ++ [ Option "-shared" ] - ++ map Option bsymbolicFlag - -- Set the library soname. We use -h rather than -soname as - -- Solaris 10 doesn't support the latter: - ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] - ++ extra_ld_inputs - ++ map Option lib_path_opts - ++ map Option pkg_lib_path_opts - ++ map Option pkg_link_opts - ) - --- | Some platforms require that we explicitly link against @libm@ if any --- math-y things are used (which we assume to include all programs). See #14022. -libmLinkOpts :: [Option] -libmLinkOpts = -#if defined(HAVE_LIBM) - [Option "-lm"] -#else - [] -#endif - -getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String] -getPkgFrameworkOpts dflags platform dep_packages - | platformUsesFrameworks platform = do - pkg_framework_path_opts <- do - pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages - return $ map ("-F" ++) pkg_framework_paths - - pkg_framework_opts <- do - pkg_frameworks <- getPackageFrameworks dflags dep_packages - return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] - - return (pkg_framework_path_opts ++ pkg_framework_opts) - - | otherwise = return [] - -getFrameworkOpts :: DynFlags -> Platform -> [String] -getFrameworkOpts dflags platform - | platformUsesFrameworks platform = framework_path_opts ++ framework_opts - | otherwise = [] - where - framework_paths = frameworkPaths dflags - framework_path_opts = map ("-F" ++) framework_paths - - frameworks = cmdlineFrameworks dflags - -- reverse because they're added in reverse order from the cmd line: - framework_opts = concat [ ["-framework", fw] - | fw <- reverse frameworks ] - -{- -Note [-Bsymbolic assumptions by GHC] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC has a few assumptions about interaction of relocations in NCG and linker: - -1. -Bsymbolic resolves internal references when the shared library is linked, - which is important for performance. -2. When there is a reference to data in a shared library from the main program, - the runtime linker relocates the data object into the main program using an - R_*_COPY relocation. -3. If we used -Bsymbolic, then this results in multiple copies of the data - object, because some references have already been resolved to point to the - original instance. This is bad! - -We work around [3.] for native compiled code by avoiding the generation of -R_*_COPY relocations. - -Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable --Bsymbolic linking there. - -See related tickets: #4210, #15338 --} diff --git a/main/SysTools/BaseDir.hs b/main/SysTools/BaseDir.hs deleted file mode 100644 --- a/main/SysTools/BaseDir.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2001-2017 --- --- Finding the compiler's base directory. --- ------------------------------------------------------------------------------ --} - -module SysTools.BaseDir - ( expandTopDir, expandToolDir - , findTopDir, findToolDir - , tryFindTopDir - ) where - -#include "HsVersions.h" - -import GhcPrelude - --- See note [Base Dir] for why some of this logic is shared with ghc-pkg. -import GHC.BaseDir - -import Panic - -import System.Environment (lookupEnv) -import System.FilePath - --- Windows -#if defined(mingw32_HOST_OS) -import System.Directory (doesDirectoryExist) -#endif - -{- -Note [topdir: How GHC finds its files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC needs various support files (library packages, RTS etc), plus -various auxiliary programs (cp, gcc, etc). It starts by finding topdir, -the root of GHC's support files - -On Unix: - - ghc always has a shell wrapper that passes a -B option - -On Windows: - - ghc never has a shell wrapper. - - we can find the location of the ghc binary, which is - $topdir//.exe - where may be "ghc", "ghc-stage2", or similar - - we strip off the "/.exe" to leave $topdir. - -from topdir we can find package.conf, ghc-asm, etc. - - -Note [tooldir: How GHC finds mingw on Windows] - -GHC has some custom logic on Windows for finding the mingw -toolchain and perl. Depending on whether GHC is built -with the make build system or Hadrian, and on whether we're -running a bindist, we might find the mingw toolchain -either under $topdir/../{mingw, perl}/ or -$topdir/../../{mingw, perl}/. - -This story is long and with lots of twist and turns.. But lets talk about how -the build system finds and wires through the toolchain information. - -1) It all starts in configure.ac which has two modes it operates on: - a) The default is where `EnableDistroToolchain` is false. This indicates - that we want to use the in-tree bundled toolchains. In this mode we will - download and unpack some custom toolchains into the `inplace/mingw` folder - and everything is pointed to that folder. - b) The second path is when `EnableDistroToolchain` is true. This makes the - toolchain behave a lot like Linux, in that the environment is queried for - information on the tools we require. - - From configure.ac we export the standard variables to set the paths to the - tools for the build system to use. - -2) After we have the path to the tools we have to generate the right paths to - store in the settings file for ghc to use. This is done in aclocal.m4. - Again we have two modes of operation: - a) If not `EnableDistroToolchain` the paths are rewritten to paths using a - variable `$tooldir` as we need an absolute path. $tooldir is filled in by - the `expandToolDir` function in this module at GHC startup. - b) When `EnableDistroToolchain` then instead of filling in a absolute path - we fill in just the program name. The assumption here is that at runtime - the environment GHC is operating on will be the same as the one configure - was run in. This means we expect `gcc, ld, as` etc to be on the PATH. - - From `aclocal.m4` we export a couple of variables starting with `Settings` - which will be used to generate the settings file. - -3) The next step is to generate the settings file, this is where things diverge - based on the build system. Both Make and Hadrian handle this differently: - -make) - Make deals with this rather simply. As an output of configure.ac - `config.mk.in` is processed and `config.mk` generated which has the values we - set in `aclocal.m4`. This allows the rest of the build system to have access - to these and other values determined by configure. - - Based on this file, `includes/ghc.mk` when ran will produce the settings file - by echoing the values into a the final file. Coincidentally this is also - where `ghcplatform.h` and `ghcversion.h` generated which contains information - about the build platform and sets CPP for use by the entire build. - -hadrian) - For hadrian the file `cfg/system.config.in` is preprocessed by configure and - the output written to `system.config`. This serves the same purpose as - `config.mk` but it rewrites the values that were exported. As an example - `SettingsCCompilerCommand` is rewritten to `settings-c-compiler-command`. - - Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to - the settings `keys` in the `system.config`. As an example, - `settings-c-compiler-command` is mapped to - `SettingsFileSetting_CCompilerCommand`. - - The last part of this is the `generateSettings` in `src/Rules/Generate.hs` - which produces the desired settings file out of Hadrian. This is the - equivalent to `includes/ghc.mk`. - --- - -So why do we have these? On Windows there's no such thing as a platform compiler -and as such we need to provide GCC and binutils. The easiest way is to bundle -these with the compiler and wire them up. This gives you a relocatable -binball. This works fine for most users. However mingw-w64 have a different -requirement. They require all packages in the repo to be compiled using the -same version of the compiler. So it means when they are rebuilding the world to -add support for GCC X, they expect all packages to have been compiled with GCC X -which is a problem since we ship an older GCC version. - -GHC is a package in mingw-w64 because there are Haskell packages in the -repository which of course requires a Haskell compiler. To help them we -provide the override which allows GHC to instead of using an inplace compiler to -play nice with the system compiler instead. --} - --- | Expand occurrences of the @$tooldir@ interpolation in a string --- on Windows, leave the string untouched otherwise. -expandToolDir :: Maybe FilePath -> String -> String -#if defined(mingw32_HOST_OS) && !defined(USE_INPLACE_MINGW_TOOLCHAIN) -expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s -expandToolDir Nothing _ = panic "Could not determine $tooldir" -#else -expandToolDir _ s = s -#endif - --- | Returns a Unix-format path pointing to TopDir. -findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). - -> IO String -- TopDir (in Unix format '/' separated) -findTopDir m_minusb = do - maybe_exec_dir <- tryFindTopDir m_minusb - case maybe_exec_dir of - -- "Just" on Windows, "Nothing" on unix - Nothing -> throwGhcExceptionIO $ - InstallationError "missing -B option" - Just dir -> return dir - -tryFindTopDir - :: Maybe String -- ^ Maybe TopDir path (without the '-B' prefix). - -> IO (Maybe String) -- ^ TopDir (in Unix format '/' separated) -tryFindTopDir (Just minusb) = return $ Just $ normalise minusb -tryFindTopDir Nothing - = do -- The _GHC_TOP_DIR environment variable can be used to specify - -- the top dir when the -B argument is not specified. It is not - -- intended for use by users, it was added specifically for the - -- purpose of running GHC within GHCi. - maybe_env_top_dir <- lookupEnv "_GHC_TOP_DIR" - case maybe_env_top_dir of - Just env_top_dir -> return $ Just env_top_dir - -- Try directory of executable - Nothing -> getBaseDir - - --- See Note [tooldir: How GHC finds mingw on Windows] --- Returns @Nothing@ when not on Windows. --- When called on Windows, it either throws an error when the --- tooldir can't be located, or returns @Just tooldirpath@. --- If the distro toolchain is being used we treat Windows the same as Linux -findToolDir - :: FilePath -- ^ topdir - -> IO (Maybe FilePath) -#if defined(mingw32_HOST_OS) && !defined(USE_INPLACE_MINGW_TOOLCHAIN) -findToolDir top_dir = go 0 (top_dir "..") - where maxDepth = 3 - go :: Int -> FilePath -> IO (Maybe FilePath) - go k path - | k == maxDepth = throwGhcExceptionIO $ - InstallationError "could not detect mingw toolchain" - | otherwise = do - oneLevel <- doesDirectoryExist (path "mingw") - if oneLevel - then return (Just path) - else go (k+1) (path "..") -#else -findToolDir _ = return Nothing -#endif diff --git a/main/SysTools/ExtraObj.hs b/main/SysTools/ExtraObj.hs deleted file mode 100644 --- a/main/SysTools/ExtraObj.hs +++ /dev/null @@ -1,243 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHC Extra object linking code --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ - -module SysTools.ExtraObj ( - mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, - checkLinkInfo, getLinkInfo, getCompilerInfo, - ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts, - haveRtsOptsFlags -) where - -import AsmUtils -import ErrUtils -import DynFlags -import Packages -import GHC.Platform -import Outputable -import SrcLoc ( noSrcSpan ) -import Module -import Elf -import Util -import GhcPrelude - -import Control.Monad -import Data.Maybe - -import Control.Monad.IO.Class - -import FileCleanup -import SysTools.Tasks -import SysTools.Info - -mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath -mkExtraObj dflags extn xs - = do cFile <- newTempName dflags TFL_CurrentModule extn - oFile <- newTempName dflags TFL_GhcSession "o" - writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo dflags - runCc Nothing dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else asmOpts ccInfo) - return oFile - where - -- Pass a different set of options to the C compiler depending one whether - -- we're compiling C or assembler. When compiling C, we pass the usual - -- set of include directories and PIC flags. - cOpts = map Option (picCCOpts dflags) - ++ map (FileOption "-I") - (includeDirs $ getPackageDetails dflags rtsUnitId) - - -- When compiling assembler code, we drop the usual C options, and if the - -- compiler is Clang, we add an extra argument to tell Clang to ignore - -- unused command line options. See trac #11684. - asmOpts ccInfo = - if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [Option "-Qunused-arguments"] - else [] - --- When linking a binary, we need to create a C main() function that --- starts everything off. This used to be compiled statically as part --- of the RTS, but that made it hard to change the -rtsopts setting, --- so now we generate and compile a main() stub as part of every --- binary and pass the -rtsopts setting directly to the RTS (#5373) --- --- On Windows, when making a shared library we also may need a DllMain. --- -mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath -mkExtraObjToLinkIntoBinary dflags = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - mkExtraObj dflags "c" (showSDoc dflags main) - where - main - | gopt Opt_NoHsMain dflags = Outputable.empty - | otherwise - = case ghcLink dflags of - LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 - then dllMain - else Outputable.empty - _ -> exeMain - - exeMain = vcat [ - text "#include ", - text "extern StgClosure ZCMain_main_closure;", - text "int main(int argc, char *argv[])", - char '{', - text " RtsConfig __conf = defaultRtsConfig;", - text " __conf.rts_opts_enabled = " - <> text (show (rtsOptsEnabled dflags)) <> semi, - text " __conf.rts_opts_suggestions = " - <> text (if rtsOptsSuggestions dflags - then "true" - else "false") <> semi, - text "__conf.keep_cafs = " - <> text (if gopt Opt_KeepCAFs dflags - then "true" - else "false") <> semi, - case rtsOpts dflags of - Nothing -> Outputable.empty - Just opts -> text " __conf.rts_opts= " <> - text (show opts) <> semi, - text " __conf.rts_hs_main = true;", - text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", - char '}', - char '\n' -- final newline, to keep gcc happy - ] - - dllMain = vcat [ - text "#include ", - text "#include ", - text "#include ", - char '\n', - text "bool", - text "WINAPI", - text "DllMain ( HINSTANCE hInstance STG_UNUSED", - text " , DWORD reason STG_UNUSED", - text " , LPVOID reserved STG_UNUSED", - text " )", - text "{", - text " return true;", - text "}", - char '\n' -- final newline, to keep gcc happy - ] - --- Write out the link info section into a new assembly file. Previously --- this was included as inline assembly in the main.c file but this --- is pretty fragile. gas gets upset trying to calculate relative offsets --- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - - if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) - else return [] - - where - link_opts info = hcat [ - -- "link info" section (see Note [LinkInfo section]) - makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- compiler/nativeGen/AsmCodeGen.hs for another instance - -- where we need to do this. - if platformHasGnuNonexecStack (targetPlatform dflags) - then text ".section .note.GNU-stack,\"\"," - <> sectionType "progbits" <> char '\n' - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String -getLinkInfo dflags dep_packages = do - package_link_opts <- getPackageLinkOpts dflags dep_packages - pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) - then getPackageFrameworks dflags dep_packages - else return [] - let extra_ld_inputs = ldInputs dflags - let - link_info = (package_link_opts, - pkg_frameworks, - rtsOpts dflags, - rtsOptsEnabled dflags, - gopt Opt_NoHsMain dflags, - map showOpt extra_ld_inputs, - getOpts dflags opt_l) - -- - return (show link_info) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | os == OSSolaris2 = False -- see #5382 - | otherwise = osElfTarget os - --- See Note [LinkInfo section] -ghcLinkInfoSectionName :: String -ghcLinkInfoSectionName = ".debug-ghc-link-info" - -- if we use the ".debug" prefix, then strip will strip it by default - --- Identifier for the note (see Note [LinkInfo section]) -ghcLinkInfoNoteName :: String -ghcLinkInfoNoteName = "GHC link info" - --- Returns 'False' if it was, and we can avoid linking, because the --- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool -checkLinkInfo dflags pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = return False -- conservatively we should return True, but not - -- linking in this case was the behaviour for a long - -- time so we leave it as-is. - | otherwise - = do - link_info <- getLinkInfo dflags pkg_deps - debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString dflags exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg dflags 3 $ case m_exe_link_info of - Nothing -> text "Exe link info: Not found" - Just s - | sameLinkInfo -> text ("Exe link info is the same") - | otherwise -> text ("Exe link info is different: " ++ s) - return (not sameLinkInfo) - -{- Note [LinkInfo section] - ~~~~~~~~~~~~~~~~~~~~~~~ - -The "link info" is a string representing the parameters of the link. We save -this information in the binary, and the next time we link, if nothing else has -changed, we use the link info stored in the existing binary to decide whether -to re-link or not. - -The "link info" string is stored in a ELF section called ".debug-ghc-link-info" -(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to -not follow the specified record-based format (see #11022). - --} - -haveRtsOptsFlags :: DynFlags -> Bool -haveRtsOptsFlags dflags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True diff --git a/main/SysTools/Info.hs b/main/SysTools/Info.hs deleted file mode 100644 --- a/main/SysTools/Info.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Compiler information functions --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ -module SysTools.Info where - -import Exception -import ErrUtils -import DynFlags -import Outputable -import Util - -import Data.List -import Data.IORef - -import System.IO - -import GHC.Platform -import GhcPrelude - -import SysTools.Process - -{- Note [Run-time linker info] - -See also: #5240, #6063, #10110 - -Before 'runLink', we need to be sure to get the relevant information -about the linker we're using at runtime to see if we need any extra -options. For example, GNU ld requires '--reduce-memory-overheads' and -'--hash-size=31' in order to use reasonable amounts of memory (see -trac #5240.) But this isn't supported in GNU gold. - -Generally, the linker changing from what was detected at ./configure -time has always been possible using -pgml, but on Linux it can happen -'transparently' by installing packages like binutils-gold, which -change what /usr/bin/ld actually points to. - -Clang vs GCC notes: - -For gcc, 'gcc -Wl,--version' gives a bunch of output about how to -invoke the linker before the version information string. For 'clang', -the version information for 'ld' is all that's output. For this -reason, we typically need to slurp up all of the standard error output -and look through it. - -Other notes: - -We cache the LinkerInfo inside DynFlags, since clients may link -multiple times. The definition of LinkerInfo is there to avoid a -circular dependency. - --} - -{- Note [ELF needed shared libs] - -Some distributions change the link editor's default handling of -ELF DT_NEEDED tags to include only those shared objects that are -needed to resolve undefined symbols. For Template Haskell we need -the last temporary shared library also if it is not needed for the -currently linked temporary shared library. We specify --no-as-needed -to override the default. This flag exists in GNU ld and GNU gold. - -The flag is only needed on ELF systems. On Windows (PE) and Mac OS X -(Mach-O) the flag is not needed. - --} - -{- Note [Windows static libGCC] - -The GCC versions being upgraded to in #10726 are configured with -dynamic linking of libgcc supported. This results in libgcc being -linked dynamically when a shared library is created. - -This introduces thus an extra dependency on GCC dll that was not -needed before by shared libraries created with GHC. This is a particular -issue on Windows because you get a non-obvious error due to this missing -dependency. This dependent dll is also not commonly on your path. - -For this reason using the static libgcc is preferred as it preserves -the same behaviour that existed before. There are however some very good -reasons to have the shared version as well as described on page 181 of -https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : - -"There are several situations in which an application should use the - shared ‘libgcc’ instead of the static version. The most common of these - is when the application wishes to throw and catch exceptions across different - shared libraries. In that case, each of the libraries as well as the application - itself should use the shared ‘libgcc’. " - --} - -neededLinkArgs :: LinkerInfo -> [Option] -neededLinkArgs (GnuLD o) = o -neededLinkArgs (GnuGold o) = o -neededLinkArgs (LlvmLLD o) = o -neededLinkArgs (DarwinLD o) = o -neededLinkArgs (SolarisLD o) = o -neededLinkArgs (AixLD o) = o -neededLinkArgs UnknownLD = [] - --- Grab linker info and cache it in DynFlags. -getLinkerInfo :: DynFlags -> IO LinkerInfo -getLinkerInfo dflags = do - info <- readIORef (rtldInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getLinkerInfo' dflags - writeIORef (rtldInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getLinkerInfo' :: DynFlags -> IO LinkerInfo -getLinkerInfo' dflags = do - let platform = targetPlatform dflags - os = platformOS platform - (pgm,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 - args3 = filter notNull (map showOpt args2) - - -- Try to grab the info from the process output. - parseLinkerInfo stdo _stde _exitc - | any ("GNU ld" `isPrefixOf`) stdo = - -- GNU ld specifically needs to use less memory. This especially - -- hurts on small object files. #5240. - -- Set DT_NEEDED for all shared libraries. #10110. - -- TODO: Investigate if these help or hurt when using split sections. - return (GnuLD $ map Option ["-Wl,--hash-size=31", - "-Wl,--reduce-memory-overheads", - -- ELF specific flag - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - | any ("GNU gold" `isPrefixOf`) stdo = - -- GNU gold only needs --no-as-needed. #10110. - -- ELF specific flag, see Note [ELF needed shared libs] - return (GnuGold [Option "-Wl,--no-as-needed"]) - - | any ("LLD" `isPrefixOf`) stdo = - return (LlvmLLD $ map Option [ - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - -- Unknown linker. - | otherwise = fail "invalid --version output, or linker is unsupported" - - -- Process the executable call - info <- catchIO (do - case os of - OSSolaris2 -> - -- Solaris uses its own Solaris linker. Even all - -- GNU C are recommended to configure with Solaris - -- linker instead of using GNU binutils linker. Also - -- all GCC distributed with Solaris follows this rule - -- precisely so we assume here, the Solaris linker is - -- used. - return $ SolarisLD [] - OSAIX -> - -- IBM AIX uses its own non-binutils linker as well - return $ AixLD [] - OSDarwin -> - -- Darwin has neither GNU Gold or GNU LD, but a strange linker - -- that doesn't support --version. We can just assume that's - -- what we're using. - return $ DarwinLD [] - OSMinGW32 -> - -- GHC doesn't support anything but GNU ld on Windows anyway. - -- Process creation is also fairly expensive on win32, so - -- we short-circuit here. - return $ GnuLD $ map Option - [ -- Reduce ld memory usage - "-Wl,--hash-size=31" - , "-Wl,--reduce-memory-overheads" - -- Emit gcc stack checks - -- Note [Windows stack usage] - , "-fstack-check" - -- Force static linking of libGCC - -- Note [Windows static libGCC] - , "-static-libgcc" ] - _ -> do - -- In practice, we use the compiler as the linker here. Pass - -- -Wl,--version to get linker version info. - (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm - (["-Wl,--version"] ++ args3) - c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. In particular, 'clang' and 'gcc' - -- have slightly different outputs for '-Wl,--version', but - -- it's still easy to figure out. - parseLinkerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out linker information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out linker information!" $$ - text "Make sure you're using GNU ld, GNU gold" <+> - text "or the built in OS X linker, etc." - return UnknownLD) - return info - --- Grab compiler info and cache it in DynFlags. -getCompilerInfo :: DynFlags -> IO CompilerInfo -getCompilerInfo dflags = do - info <- readIORef (rtccInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getCompilerInfo' dflags - writeIORef (rtccInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getCompilerInfo' :: DynFlags -> IO CompilerInfo -getCompilerInfo' dflags = do - let pgm = pgm_c dflags - -- Try to grab the info from the process output. - parseCompilerInfo _stdo stde _exitc - -- Regular GCC - | any ("gcc version" `isInfixOf`) stde = - return GCC - -- Regular clang - | any ("clang version" `isInfixOf`) stde = - return Clang - -- FreeBSD clang - | any ("FreeBSD clang version" `isInfixOf`) stde = - return Clang - -- Xcode 5.1 clang - | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = - return AppleClang51 - -- Xcode 5 clang - | any ("Apple LLVM version" `isPrefixOf`) stde = - return AppleClang - -- Xcode 4.1 clang - | any ("Apple clang version" `isPrefixOf`) stde = - return AppleClang - -- Unknown linker. - | otherwise = fail "invalid -v output, or compiler is unsupported" - - -- Process the executable call - info <- catchIO (do - (exitc, stdo, stde) <- - readProcessEnvWithExitCode pgm ["-v"] c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. - parseCompilerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out C compiler information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out C compiler information!" $$ - text "Make sure you're using GNU gcc, or clang" - return UnknownCC) - return info diff --git a/main/SysTools/Process.hs b/main/SysTools/Process.hs deleted file mode 100644 --- a/main/SysTools/Process.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- --- Misc process handling code for SysTools --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ -module SysTools.Process where - -#include "HsVersions.h" - -import Exception -import ErrUtils -import DynFlags -import FastString -import Outputable -import Panic -import GhcPrelude -import Util -import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) - -import Control.Concurrent -import Data.Char - -import System.Exit -import System.Environment -import System.FilePath -import System.IO -import System.IO.Error as IO -import System.Process - -import FileCleanup - --- Similar to System.Process.readCreateProcessWithExitCode, but stderr is --- inherited from the parent process, and output to stderr is not captured. -readCreateProcessWithExitCode' - :: CreateProcess - -> IO (ExitCode, String) -- ^ stdout -readCreateProcessWithExitCode' proc = do - (_, Just outh, _, pid) <- - createProcess proc{ std_out = CreatePipe } - - -- fork off a thread to start consuming the output - output <- hGetContents outh - outMVar <- newEmptyMVar - _ <- forkIO $ evaluate (length output) >> putMVar outMVar () - - -- wait on the output - takeMVar outMVar - hClose outh - - -- wait on the process - ex <- waitForProcess pid - - return (ex, output) - -replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] -replaceVar (var, value) env = - (var, value) : filter (\(var',_) -> var /= var') env - --- | Version of @System.Process.readProcessWithExitCode@ that takes a --- key-value tuple to insert into the environment. -readProcessEnvWithExitCode - :: String -- ^ program path - -> [String] -- ^ program args - -> (String, String) -- ^ addition to the environment - -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) -readProcessEnvWithExitCode prog args env_update = do - current_env <- getEnvironment - readCreateProcessWithExitCode (proc prog args) { - env = Just (replaceVar env_update current_env) } "" - --- Don't let gcc localize version info string, #8825 -c_locale_env :: (String, String) -c_locale_env = ("LANGUAGE", "C") - --- If the -B option is set, add to PATH. This works around --- a bug in gcc on Windows Vista where it can't find its auxiliary --- binaries (see bug #1110). -getGccEnv :: [Option] -> IO (Maybe [(String,String)]) -getGccEnv opts = - if null b_dirs - then return Nothing - else do env <- getEnvironment - return (Just (mangle_paths env)) - where - (b_dirs, _) = partitionWith get_b_opt opts - - get_b_opt (Option ('-':'B':dir)) = Left dir - get_b_opt other = Right other - - -- Work around #1110 on Windows only (lest we stumble into #17266). -#if defined(mingw32_HOST_OS) - mangle_paths = map mangle_path - mangle_path (path,paths) | map toUpper path == "PATH" - = (path, '\"' : head b_dirs ++ "\";" ++ paths) - mangle_path other = other -#else - mangle_paths = id -#endif - - ------------------------------------------------------------------------------ --- Running an external program - -runSomething :: DynFlags - -> String -- For -v message - -> String -- Command name (possibly a full path) - -- assumed already dos-ified - -> [Option] -- Arguments - -- runSomething will dos-ify them - -> IO () - -runSomething dflags phase_name pgm args = - runSomethingFiltered dflags id phase_name pgm args Nothing Nothing - --- | Run a command, placing the arguments in an external response file. --- --- This command is used in order to avoid overlong command line arguments on --- Windows. The command line arguments are first written to an external, --- temporary response file, and then passed to the linker via @filepath. --- response files for passing them in. See: --- --- https://gcc.gnu.org/wiki/Response_Files --- https://gitlab.haskell.org/ghc/ghc/issues/10777 -runSomethingResponseFile - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe [(String,String)] -> IO () - -runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do - fp <- getResponseFile real_args - let args = ['@':fp] - r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env - return (r,()) - where - getResponseFile args = do - fp <- newTempName dflags TFL_CurrentModule "rsp" - withFile fp WriteMode $ \h -> do -#if defined(mingw32_HOST_OS) - hSetEncoding h latin1 -#else - hSetEncoding h utf8 -#endif - hPutStr h $ unlines $ map escape args - return fp - - -- Note: Response files have backslash-escaping, double quoting, and are - -- whitespace separated (some implementations use newline, others any - -- whitespace character). Therefore, escape any backslashes, newlines, and - -- double quotes in the argument, and surround the content with double - -- quotes. - -- - -- Another possibility that could be considered would be to convert - -- backslashes in the argument to forward slashes. This would generally do - -- the right thing, since backslashes in general only appear in arguments - -- as part of file paths on Windows, and the forward slash is accepted for - -- those. However, escaping is more reliable, in case somehow a backslash - -- appears in a non-file. - escape x = concat - [ "\"" - , concatMap - (\c -> - case c of - '\\' -> "\\\\" - '\n' -> "\\n" - '\"' -> "\\\"" - _ -> [c]) - x - , "\"" - ] - -runSomethingFiltered - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe FilePath -> Maybe [(String,String)] -> IO () - -runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do - runSomethingWith dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env - return (r,()) - -runSomethingWith - :: DynFlags -> String -> String -> [Option] - -> ([String] -> IO (ExitCode, a)) - -> IO a - -runSomethingWith dflags phase_name pgm args io = do - let real_args = filter notNull (map showOpt args) - cmdLine = showCommandForUser pgm real_args - traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args - -handleProc :: String -> String -> IO (ExitCode, r) -> IO r -handleProc pgm phase_name proc = do - (rc, r) <- proc `catchIO` handler - case rc of - ExitSuccess{} -> return r - ExitFailure n -> throwGhcExceptionIO ( - ProgramError ("`" ++ takeFileName pgm ++ "'" ++ - " failed in phase `" ++ phase_name ++ "'." ++ - " (Exit code: " ++ show n ++ ")")) - where - handler err = - if IO.isDoesNotExistError err - then does_not_exist - else throwGhcExceptionIO (ProgramError $ show err) - - does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) - - -builderMainLoop :: DynFlags -> (String -> String) -> FilePath - -> [String] -> Maybe FilePath -> Maybe [(String, String)] - -> IO ExitCode -builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do - chan <- newChan - - -- We use a mask here rather than a bracket because we want - -- to distinguish between cleaning up with and without an - -- exception. This is to avoid calling terminateProcess - -- unless an exception was raised. - let safely inner = mask $ \restore -> do - -- acquire - (hStdIn, hStdOut, hStdErr, hProcess) <- restore $ - runInteractiveProcess pgm real_args mb_cwd mb_env - let cleanup_handles = do - hClose hStdIn - hClose hStdOut - hClose hStdErr - r <- try $ restore $ do - hSetBuffering hStdOut LineBuffering - hSetBuffering hStdErr LineBuffering - let make_reader_proc h = forkIO $ readerProc chan h filter_fn - bracketOnError (make_reader_proc hStdOut) killThread $ \_ -> - bracketOnError (make_reader_proc hStdErr) killThread $ \_ -> - inner hProcess - case r of - -- onException - Left (SomeException e) -> do - terminateProcess hProcess - cleanup_handles - throw e - -- cleanup when there was no exception - Right s -> do - cleanup_handles - return s - safely $ \h -> do - -- we don't want to finish until 2 streams have been complete - -- (stdout and stderr) - log_loop chan (2 :: Integer) - -- after that, we wait for the process to finish and return the exit code. - waitForProcess h - where - -- t starts at the number of streams we're listening to (2) decrements each - -- time a reader process sends EOF. We are safe from looping forever if a - -- reader thread dies, because they send EOF in a finally handler. - log_loop _ 0 = return () - log_loop chan t = do - msg <- readChan chan - case msg of - BuildMsg msg -> do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) msg - log_loop chan t - BuildError loc msg -> do - putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) - (defaultUserStyle dflags) msg - log_loop chan t - EOF -> - log_loop chan (t-1) - -readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () -readerProc chan hdl filter_fn = - (do str <- hGetContents hdl - loop (linesPlatform (filter_fn str)) Nothing) - `finally` - writeChan chan EOF - -- ToDo: check errors more carefully - -- ToDo: in the future, the filter should be implemented as - -- a stream transformer. - where - loop [] Nothing = return () - loop [] (Just err) = writeChan chan err - loop (l:ls) in_err = - case in_err of - Just err@(BuildError srcLoc msg) - | leading_whitespace l -> do - loop ls (Just (BuildError srcLoc (msg $$ text l))) - | otherwise -> do - writeChan chan err - checkError l ls - Nothing -> do - checkError l ls - _ -> panic "readerProc/loop" - - checkError l ls - = case parseError l of - Nothing -> do - writeChan chan (BuildMsg (text l)) - loop ls Nothing - Just (file, lineNum, colNum, msg) -> do - let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum - loop ls (Just (BuildError srcLoc (text msg))) - - leading_whitespace [] = False - leading_whitespace (x:_) = isSpace x - -parseError :: String -> Maybe (String, Int, Int, String) -parseError s0 = case breakColon s0 of - Just (filename, s1) -> - case breakIntColon s1 of - Just (lineNum, s2) -> - case breakIntColon s2 of - Just (columnNum, s3) -> - Just (filename, lineNum, columnNum, s3) - Nothing -> - Just (filename, lineNum, 0, s2) - Nothing -> Nothing - Nothing -> Nothing - -breakColon :: String -> Maybe (String, String) -breakColon xs = case break (':' ==) xs of - (ys, _:zs) -> Just (ys, zs) - _ -> Nothing - -breakIntColon :: String -> Maybe (Int, String) -breakIntColon xs = case break (':' ==) xs of - (ys, _:zs) - | not (null ys) && all isAscii ys && all isDigit ys -> - Just (read ys, zs) - _ -> Nothing - -data BuildMessage - = BuildMsg !SDoc - | BuildError !SrcLoc !SDoc - | EOF - --- Divvy up text stream into lines, taking platform dependent --- line termination into account. -linesPlatform :: String -> [String] -#if !defined(mingw32_HOST_OS) -linesPlatform ls = lines ls -#else -linesPlatform "" = [] -linesPlatform xs = - case lineBreak xs of - (as,xs1) -> as : linesPlatform xs1 - where - lineBreak "" = ("","") - lineBreak ('\r':'\n':xs) = ([],xs) - lineBreak ('\n':xs) = ([],xs) - lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) - -#endif diff --git a/main/SysTools/Settings.hs b/main/SysTools/Settings.hs deleted file mode 100644 --- a/main/SysTools/Settings.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module SysTools.Settings - ( SettingsError (..) - , initSettings - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Settings - -import Config -import CliOption -import FileSettings -import Fingerprint -import GHC.Platform -import GhcNameVersion -import Outputable -import Settings -import SysTools.BaseDir -import ToolSettings - -import Control.Monad.Trans.Except -import Control.Monad.IO.Class -import qualified Data.Map as Map -import System.FilePath -import System.Directory - -data SettingsError - = SettingsError_MissingData String - | SettingsError_BadData String - -initSettings - :: forall m - . MonadIO m - => String -- ^ TopDir path - -> ExceptT SettingsError m Settings -initSettings top_dir = do - -- see Note [topdir: How GHC finds its files] - -- NB: top_dir is assumed to be in standard Unix - -- format, '/' separated - mtool_dir <- liftIO $ findToolDir top_dir - -- see Note [tooldir: How GHC finds mingw on Windows] - - let installed :: FilePath -> FilePath - installed file = top_dir file - libexec :: FilePath -> FilePath - libexec file = top_dir "bin" file - settingsFile = installed "settings" - platformConstantsFile = installed "platformConstants" - - readFileSafe :: FilePath -> ExceptT SettingsError m String - readFileSafe path = liftIO (doesFileExist path) >>= \case - True -> liftIO $ readFile path - False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path - - settingsStr <- readFileSafe settingsFile - platformConstantsStr <- readFileSafe platformConstantsFile - settingsList <- case maybeReadFuzzy settingsStr of - Just s -> pure s - Nothing -> throwE $ SettingsError_BadData $ - "Can't parse " ++ show settingsFile - let mySettings = Map.fromList settingsList - platformConstants <- case maybeReadFuzzy platformConstantsStr of - Just s -> pure s - Nothing -> throwE $ SettingsError_BadData $ - "Can't parse " ++ show platformConstantsFile - -- See Note [Settings file] for a little more about this file. We're - -- just partially applying those functions and throwing 'Left's; they're - -- written in a very portable style to keep ghc-boot light. - let getSetting key = either pgmError pure $ - getFilePathSetting0 top_dir settingsFile mySettings key - getToolSetting :: String -> ExceptT SettingsError m String - getToolSetting key = expandToolDir mtool_dir <$> getSetting key - getBooleanSetting :: String -> ExceptT SettingsError m Bool - getBooleanSetting key = either pgmError pure $ - getBooleanSetting0 settingsFile mySettings key - targetPlatformString <- getSetting "target platform string" - tablesNextToCode <- getBooleanSetting "Tables next to code" - myExtraGccViaCFlags <- getSetting "GCC extra via C opts" - -- On Windows, mingw is distributed with GHC, - -- so we look in TopDir/../mingw/bin, - -- as well as TopDir/../../mingw/bin for hadrian. - -- It would perhaps be nice to be able to override this - -- with the settings file, but it would be a little fiddly - -- to make that possible, so for now you can't. - cc_prog <- getToolSetting "C compiler command" - cc_args_str <- getSetting "C compiler flags" - cxx_args_str <- getSetting "C++ compiler flags" - gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cpp_prog <- getToolSetting "Haskell CPP command" - cpp_args_str <- getSetting "Haskell CPP flags" - - platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings - - let unreg_cc_args = if platformUnregisterised platform - then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] - else [] - cpp_args = map Option (words cpp_args_str) - cc_args = words cc_args_str ++ unreg_cc_args - cxx_args = words cxx_args_str - ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" - ldSupportsBuildId <- getBooleanSetting "ld supports build-id" - ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldIsGnuLd <- getBooleanSetting "ld is GNU ld" - - let pkgconfig_path = installed "package.conf.d" - ghc_usage_msg_path = installed "ghc-usage.txt" - ghci_usage_msg_path = installed "ghci-usage.txt" - - -- For all systems, unlit, split, mangle are GHC utilities - -- architecture-specific stuff is done when building Config.hs - unlit_path <- getToolSetting "unlit command" - - windres_path <- getToolSetting "windres command" - libtool_path <- getToolSetting "libtool command" - ar_path <- getToolSetting "ar command" - otool_path <- getToolSetting "otool command" - install_name_tool_path <- getToolSetting "install_name_tool command" - ranlib_path <- getToolSetting "ranlib command" - - -- TODO this side-effect doesn't belong here. Reading and parsing the settings - -- should be idempotent and accumulate no resources. - tmpdir <- liftIO $ getTemporaryDirectory - - touch_path <- getToolSetting "touch command" - - mkdll_prog <- getToolSetting "dllwrap command" - let mkdll_args = [] - - -- cpp is derived from gcc on all platforms - -- HACK, see setPgmP below. We keep 'words' here to remember to fix - -- Config.hs one day. - - - -- Other things being equal, as and ld are simply gcc - cc_link_args_str <- getSetting "C compiler link flags" - let as_prog = cc_prog - as_args = map Option cc_args - ld_prog = cc_prog - ld_args = map Option (cc_args ++ words cc_link_args_str) - ld_r_prog <- getToolSetting "Merge objects command" - ld_r_args <- getSetting "Merge objects flags" - - llvmTarget <- getSetting "LLVM target" - - -- We just assume on command line - lc_prog <- getSetting "LLVM llc command" - lo_prog <- getSetting "LLVM opt command" - lcc_prog <- getSetting "LLVM clang command" - - let iserv_prog = libexec "ghc-iserv" - - integerLibrary <- getSetting "integer library" - integerLibraryType <- case integerLibrary of - "integer-gmp" -> pure IntegerGMP - "integer-simple" -> pure IntegerSimple - _ -> pgmError $ unwords - [ "Entry for" - , show "integer library" - , "must be one of" - , show "integer-gmp" - , "or" - , show "integer-simple" - ] - - ghcWithInterpreter <- getBooleanSetting "Use interpreter" - ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" - ghcWithSMP <- getBooleanSetting "Support SMP" - ghcRTSWays <- getSetting "RTS ways" - leadingUnderscore <- getBooleanSetting "Leading underscore" - useLibFFI <- getBooleanSetting "Use LibFFI" - ghcThreaded <- getBooleanSetting "Use Threads" - ghcDebugged <- getBooleanSetting "Use Debugging" - ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" - - return $ Settings - { sGhcNameVersion = GhcNameVersion - { ghcNameVersion_programName = "ghc" - , ghcNameVersion_projectVersion = cProjectVersion - } - - , sFileSettings = FileSettings - { fileSettings_tmpDir = normalise tmpdir - , fileSettings_ghcUsagePath = ghc_usage_msg_path - , fileSettings_ghciUsagePath = ghci_usage_msg_path - , fileSettings_toolDir = mtool_dir - , fileSettings_topDir = top_dir - , fileSettings_systemPackageConfig = pkgconfig_path - } - - , sToolSettings = ToolSettings - { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind - , toolSettings_ldSupportsBuildId = ldSupportsBuildId - , toolSettings_ldSupportsFilelist = ldSupportsFilelist - , toolSettings_ldIsGnuLd = ldIsGnuLd - , toolSettings_ccSupportsNoPie = gccSupportsNoPie - - , toolSettings_pgm_L = unlit_path - , toolSettings_pgm_P = (cpp_prog, cpp_args) - , toolSettings_pgm_F = "" - , toolSettings_pgm_c = cc_prog - , toolSettings_pgm_a = (as_prog, as_args) - , toolSettings_pgm_l = (ld_prog, ld_args) - , toolSettings_pgm_lm = (ld_r_prog, map Option $ words ld_r_args) - , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) - , toolSettings_pgm_T = touch_path - , toolSettings_pgm_windres = windres_path - , toolSettings_pgm_libtool = libtool_path - , toolSettings_pgm_ar = ar_path - , toolSettings_pgm_otool = otool_path - , toolSettings_pgm_install_name_tool = install_name_tool_path - , toolSettings_pgm_ranlib = ranlib_path - , toolSettings_pgm_lo = (lo_prog,[]) - , toolSettings_pgm_lc = (lc_prog,[]) - , toolSettings_pgm_lcc = (lcc_prog,[]) - , toolSettings_pgm_i = iserv_prog - , toolSettings_opt_L = [] - , toolSettings_opt_P = [] - , toolSettings_opt_P_fingerprint = fingerprint0 - , toolSettings_opt_F = [] - , toolSettings_opt_c = cc_args - , toolSettings_opt_cxx = cxx_args - , toolSettings_opt_a = [] - , toolSettings_opt_l = [] - , toolSettings_opt_lm = [] - , toolSettings_opt_windres = [] - , toolSettings_opt_lcc = [] - , toolSettings_opt_lo = [] - , toolSettings_opt_lc = [] - , toolSettings_opt_i = [] - - , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags - } - - , sTargetPlatform = platform - , sPlatformMisc = PlatformMisc - { platformMisc_targetPlatformString = targetPlatformString - , platformMisc_integerLibrary = integerLibrary - , platformMisc_integerLibraryType = integerLibraryType - , platformMisc_ghcWithInterpreter = ghcWithInterpreter - , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen - , platformMisc_ghcWithSMP = ghcWithSMP - , platformMisc_ghcRTSWays = ghcRTSWays - , platformMisc_tablesNextToCode = tablesNextToCode - , platformMisc_leadingUnderscore = leadingUnderscore - , platformMisc_libFFI = useLibFFI - , platformMisc_ghcThreaded = ghcThreaded - , platformMisc_ghcDebugged = ghcDebugged - , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw - , platformMisc_llvmTarget = llvmTarget - } - - , sPlatformConstants = platformConstants - - , sRawSettings = settingsList - } diff --git a/main/SysTools/Tasks.hs b/main/SysTools/Tasks.hs deleted file mode 100644 --- a/main/SysTools/Tasks.hs +++ /dev/null @@ -1,462 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- --- Tasks running external programs for SysTools --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ -module SysTools.Tasks where - -import Exception -import ErrUtils -import HscTypes -import DynFlags -import Outputable -import GHC.Platform -import Util - -import Data.List -import Data.Char -import Data.Maybe - -import System.IO -import System.Process -import GhcPrelude - -import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion) - -import SysTools.Process -import SysTools.Info - -import Control.Monad (join, forM, filterM, void) -import System.Directory (doesFileExist) -import System.FilePath (()) -import Text.ParserCombinators.ReadP as Parser - -{- -************************************************************************ -* * -\subsection{Running an external program} -* * -************************************************************************ --} - -runUnlit :: DynFlags -> [Option] -> IO () -runUnlit dflags args = traceToolCommand dflags "unlit" $ do - let prog = pgm_L dflags - opts = getOpts dflags opt_L - runSomething dflags "Literate pre-processor" prog - (map Option opts ++ args) - -runCpp :: DynFlags -> [Option] -> IO () -runCpp dflags args = traceToolCommand dflags "cpp" $ do - let (p,args0) = pgm_P dflags - args1 = map Option (getOpts dflags opt_P) - args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] - ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "C pre-processor" p - (args0 ++ args1 ++ args2 ++ args) Nothing mb_env - -runPp :: DynFlags -> [Option] -> IO () -runPp dflags args = traceToolCommand dflags "pp" $ do - let prog = pgm_F dflags - opts = map Option (getOpts dflags opt_F) - runSomething dflags "Haskell pre-processor" prog (args ++ opts) - --- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO () -runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do - let p = pgm_c dflags - args1 = map Option userOpts - args2 = languageOptions ++ args ++ args1 - -- We take care to pass -optc flags in args1 last to ensure that the - -- user can override flags passed by GHC. See #14452. - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env - where - -- discard some harmless warnings from gcc that we can't turn off - cc_filter = unlines . doFilter . lines - - {- - gcc gives warnings in chunks like so: - In file included from /foo/bar/baz.h:11, - from /foo/bar/baz2.h:22, - from wibble.c:33: - /foo/flibble:14: global register variable ... - /foo/flibble:15: warning: call-clobbered r... - We break it up into its chunks, remove any call-clobbered register - warnings from each chunk, and then delete any chunks that we have - emptied of warnings. - -} - doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] - -- We can't assume that the output will start with an "In file inc..." - -- line, so we start off expecting a list of warnings rather than a - -- location stack. - chunkWarnings :: [String] -- The location stack to use for the next - -- list of warnings - -> [String] -- The remaining lines to look at - -> [([String], [String])] - chunkWarnings loc_stack [] = [(loc_stack, [])] - chunkWarnings loc_stack xs - = case break loc_stack_start xs of - (warnings, lss:xs') -> - case span loc_start_continuation xs' of - (lsc, xs'') -> - (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' - _ -> [(loc_stack, xs)] - - filterWarnings :: [([String], [String])] -> [([String], [String])] - filterWarnings [] = [] - -- If the warnings are already empty then we are probably doing - -- something wrong, so don't delete anything - filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs - filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of - [] -> filterWarnings zs - ys' -> (xs, ys') : filterWarnings zs - - unChunkWarnings :: [([String], [String])] -> [String] - unChunkWarnings [] = [] - unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs - - loc_stack_start s = "In file included from " `isPrefixOf` s - loc_start_continuation s = " from " `isPrefixOf` s - wantedWarning w - | "warning: call-clobbered register used" `isContainedIn` w = False - | otherwise = True - - -- force the C compiler to interpret this file as C when - -- compiling .hc files, by adding the -x c option. - -- Also useful for plain .c files, just in case GHC saw a - -- -x c option. - (languageOptions, userOpts) = case mLanguage of - Nothing -> ([], userOpts_c) - Just language -> ([Option "-x", Option languageName], opts) - where - (languageName, opts) = case language of - LangC -> ("c", userOpts_c) - LangCxx -> ("c++", userOpts_cxx) - LangObjc -> ("objective-c", userOpts_c) - LangObjcxx -> ("objective-c++", userOpts_cxx) - LangAsm -> ("assembler", []) - RawObject -> ("c", []) -- claim C for lack of a better idea - userOpts_c = getOpts dflags opt_c - userOpts_cxx = getOpts dflags opt_cxx - -isContainedIn :: String -> String -> Bool -xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) - --- | Run the linker with some arguments and return the output -askLd :: DynFlags -> [Option] -> IO String -askLd dflags args = traceToolCommand dflags "linker" $ do - let (p,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingWith dflags "gcc" p args2 $ \real_args -> - readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } - -runAs :: DynFlags -> [Option] -> IO () -runAs dflags args = traceToolCommand dflags "as" $ do - let (p,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env - --- | Run the LLVM Optimiser -runLlvmOpt :: DynFlags -> [Option] -> IO () -runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do - let (p,args0) = pgm_lo dflags - args1 = map Option (getOpts dflags opt_lo) - -- We take care to pass -optlo flags (e.g. args0) last to ensure that the - -- user can override flags passed by GHC. See #14821. - runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0) - --- | Run the LLVM Compiler -runLlvmLlc :: DynFlags -> [Option] -> IO () -runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do - let (p,args0) = pgm_lc dflags - args1 = map Option (getOpts dflags opt_lc) - runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) - --- | Run the clang compiler (used as an assembler for the LLVM --- backend on OS X as LLVM doesn't support the OS X system --- assembler) -runClang :: DynFlags -> [Option] -> IO () -runClang dflags args = traceToolCommand dflags "clang" $ do - let (clang,_) = pgm_lcc dflags - -- be careful what options we call clang with - -- see #5903 and #7617 for bugs caused by this. - (_,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - Exception.catch (do - runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env - ) - (\(err :: SomeException) -> do - errorMsg dflags $ - text ("Error running clang! you need clang installed to use the" ++ - " LLVM backend") $+$ - text "(or GHC tried to execute clang incorrectly)" - throwIO err - ) - --- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do - let (pgm,opts) = pgm_lc dflags - args = filter notNull (map showOpt opts) - -- we grab the args even though they should be useless just in - -- case the user is using a customised 'llc' that requires some - -- of the options they've specified. llc doesn't care what other - -- options are specified when '-version' is used. - args' = args ++ ["-version"] - catchIO (do - (pin, pout, perr, _) <- runInteractiveProcess pgm args' - Nothing Nothing - {- > llc -version - LLVM (http://llvm.org/): - LLVM version 3.5.2 - ... - -} - hSetBinaryMode pout False - _ <- hGetLine pout - vline <- hGetLine pout - let mb_ver = parseLlvmVersion vline - hClose pin - hClose pout - hClose perr - return mb_ver - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out LLVM version):" <+> - text (show err)) - errorMsg dflags $ vcat - [ text "Warning:", nest 9 $ - text "Couldn't figure out LLVM version!" $$ - text ("Make sure you have installed LLVM between [" - ++ llvmVersionStr supportedLlvmVersionLowerBound - ++ " and " - ++ llvmVersionStr supportedLlvmVersionUpperBound - ++ ")") ] - return Nothing) - - --- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused --- libraries from the dynamic library. We do this to reduce the number of load --- commands that end up in the dylib, and has been limited to 32K (32768) since --- macOS Sierra (10.14). --- --- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing --- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not --- being included in the load commands, however the @-rpath@ entries are all --- forced to be included. This can lead to 100s of @-rpath@ entries being --- included when only a handful of libraries end up being truely linked. --- --- Thus after building the library, we run a fixup phase where we inject the --- @-rpath@ for each found library (in the given library search paths) into the --- dynamic library through @-add_rpath@. --- --- See Note [Dynamic linking on macOS] -runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO () -runInjectRPaths dflags _ _ | not (gopt Opt_RPath dflags) = return () -runInjectRPaths dflags lib_paths dylib = do - info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib] - -- filter the output for only the libraries. And then drop the @rpath prefix. - let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info - -- find any pre-existing LC_PATH items - info <- lines <$> askOtool dflags Nothing [Option "-l", Option dylib] - - let paths = mapMaybe get_rpath info - lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] - -- only find those rpaths, that aren't already in the library. - rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l f)) lib_paths') - -- inject the rpaths - case rpaths of - [] -> return () - _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] - -get_rpath :: String -> Maybe FilePath -get_rpath l = case readP_to_S rpath_parser l of - [(rpath, "")] -> Just rpath - _ -> Nothing - - -rpath_parser :: ReadP FilePath -rpath_parser = do - skipSpaces - void $ string "path" - void $ many1 (satisfy isSpace) - rpath <- many get - void $ many1 (satisfy isSpace) - void $ string "(offset " - void $ munch1 isDigit - void $ Parser.char ')' - skipSpaces - return rpath - -runLink :: DynFlags -> [Option] -> IO () -runLink dflags args = traceToolCommand dflags "linker" $ do - -- See Note [Run-time linker info] - -- - -- `-optl` args come at the end, so that later `-l` options - -- given there manually can fill in symbols needed by - -- Haskell libaries coming in via `args`. - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let (p,args0) = pgm_l dflags - optl_args = map Option (getOpts dflags opt_l) - args2 = args0 ++ linkargs ++ args ++ optl_args - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env - where - ld_filter = case (platformOS (targetPlatform dflags)) of - OSSolaris2 -> sunos_ld_filter - _ -> id -{- - SunOS/Solaris ld emits harmless warning messages about unresolved - symbols in case of compiling into shared library when we do not - link against all the required libs. That is the case of GHC which - does not link against RTS library explicitly in order to be able to - choose the library later based on binary application linking - parameters. The warnings look like: - -Undefined first referenced - symbol in file -stg_ap_n_fast ./T2386_Lib.o -stg_upd_frame_info ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o -newCAF ./T2386_Lib.o -stg_bh_upd_frame_info ./T2386_Lib.o -stg_ap_ppp_fast ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o -stg_ap_p_fast ./T2386_Lib.o -stg_ap_pp_fast ./T2386_Lib.o -ld: warning: symbol referencing errors - - this is actually coming from T2386 testcase. The emitting of those - warnings is also a reason why so many TH testcases fail on Solaris. - - Following filter code is SunOS/Solaris linker specific and should - filter out only linker warnings. Please note that the logic is a - little bit more complex due to the simple reason that we need to preserve - any other linker emitted messages. If there are any. Simply speaking - if we see "Undefined" and later "ld: warning:..." then we omit all - text between (including) the marks. Otherwise we copy the whole output. --} - sunos_ld_filter :: String -> String - sunos_ld_filter = unlines . sunos_ld_filter' . lines - sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) - then (ld_prefix x) ++ (ld_postfix x) - else x - breakStartsWith x y = break (isPrefixOf x) y - ld_prefix = fst . breakStartsWith "Undefined" - undefined_found = not . null . snd . breakStartsWith "Undefined" - ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" - ld_postfix = tail . snd . ld_warn_break - ld_warning_found = not . null . snd . ld_warn_break - --- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. -runMergeObjects :: DynFlags -> [Option] -> IO () -runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do - let (p,args0) = pgm_lm dflags - optl_args = map Option (getOpts dflags opt_lm) - args2 = args0 ++ args ++ optl_args - -- N.B. Darwin's ld64 doesn't support response files. Consequently we only - -- use them on Windows where they are truly necessary. -#if defined(mingw32_HOST_OS) - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags id "Merge objects" p args2 mb_env -#else - runSomething dflags "Merge objects" p args2 -#endif - -runLibtool :: DynFlags -> [Option] -> IO () -runLibtool dflags args = traceToolCommand dflags "libtool" $ do - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let args1 = map Option (getOpts dflags opt_l) - args2 = [Option "-static"] ++ args1 ++ args ++ linkargs - libtool = pgm_libtool dflags - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env - -runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr dflags cwd args = traceToolCommand dflags "ar" $ do - let ar = pgm_ar dflags - runSomethingFiltered dflags id "Ar" ar args cwd Nothing - -askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String -askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do - let ar = pgm_ar dflags - runSomethingWith dflags "Ar" ar args $ \real_args -> - readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd } - -askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String -askOtool dflags mb_cwd args = do - let otool = pgm_otool dflags - runSomethingWith dflags "otool" otool args $ \real_args -> - readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } - -runInstallNameTool :: DynFlags -> [Option] -> IO () -runInstallNameTool dflags args = do - let tool = pgm_install_name_tool dflags - runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing - -runRanlib :: DynFlags -> [Option] -> IO () -runRanlib dflags args = traceToolCommand dflags "ranlib" $ do - let ranlib = pgm_ranlib dflags - runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing - -runMkDLL :: DynFlags -> [Option] -> IO () -runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do - let (p,args0) = pgm_dll dflags - args1 = args0 ++ args - mb_env <- getGccEnv (args0++args) - runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env - -runWindres :: DynFlags -> [Option] -> IO () -runWindres dflags args = traceToolCommand dflags "windres" $ do - let cc = pgm_c dflags - cc_args = map Option (sOpt_c (settings dflags)) - windres = pgm_windres dflags - opts = map Option (getOpts dflags opt_windres) - quote x = "\"" ++ x ++ "\"" - args' = -- If windres.exe and gcc.exe are in a directory containing - -- spaces then windres fails to run gcc. We therefore need - -- to tell it what command to use... - Option ("--preprocessor=" ++ - unwords (map quote (cc : - map showOpt opts ++ - ["-E", "-xc", "-DRC_INVOKED"]))) - -- ...but if we do that then if windres calls popen then - -- it can't understand the quoting, so we have to use - -- --use-temp-file so that it interprets it correctly. - -- See #1828. - : Option "--use-temp-file" - : args - mb_env <- getGccEnv cc_args - runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env - -touch :: DynFlags -> String -> String -> IO () -touch dflags purpose arg = traceToolCommand dflags "touch" $ - runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] - --- * Tracing utility - --- | Record in the eventlog when the given tool command starts --- and finishes, prepending the given 'String' with --- \"systool:\", to easily be able to collect and process --- all the systool events. --- --- For those events to show up in the eventlog, you need --- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: DynFlags -> String -> IO a -> IO a -traceToolCommand dflags tool = withTiming - dflags (text $ "systool:" ++ tool) (const ()) diff --git a/main/SysTools/Terminal.hs b/main/SysTools/Terminal.hs deleted file mode 100644 --- a/main/SysTools/Terminal.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -module SysTools.Terminal (stderrSupportsAnsiColors) where - -import GhcPrelude - -#if defined(MIN_VERSION_terminfo) -import Control.Exception (catch) -import Data.Maybe (fromMaybe) -import System.Console.Terminfo (SetupTermError, Terminal, getCapability, - setupTermFromEnv, termColors) -import System.Posix (queryTerminal, stdError) -#elif defined(mingw32_HOST_OS) -import Control.Exception (catch, try) -import Data.Bits ((.|.), (.&.)) -import Foreign (Ptr, peek, with) -import qualified Graphics.Win32 as Win32 -import qualified System.Win32 as Win32 -#endif - -#if defined(mingw32_HOST_OS) && !defined(WINAPI) -# if defined(i386_HOST_ARCH) -# define WINAPI stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINAPI ccall -# else -# error unknown architecture -# endif -#endif - --- | Check if ANSI escape sequences can be used to control color in stderr. -stderrSupportsAnsiColors :: IO Bool -stderrSupportsAnsiColors = do -#if defined(MIN_VERSION_terminfo) - queryTerminal stdError `andM` do - (termSupportsColors <$> setupTermFromEnv) - `catch` \ (_ :: SetupTermError) -> - pure False - - where - - andM :: Monad m => m Bool -> m Bool -> m Bool - andM mx my = do - x <- mx - if x - then my - else pure x - - termSupportsColors :: Terminal -> Bool - termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 - -#elif defined(mingw32_HOST_OS) - h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE - `catch` \ (_ :: IOError) -> - pure Win32.nullHANDLE - if h == Win32.nullHANDLE - then pure False - else do - eMode <- try (getConsoleMode h) - case eMode of - Left (_ :: IOError) -> Win32.isMinTTYHandle h - -- Check if the we're in a MinTTY terminal - -- (e.g., Cygwin or MSYS2) - Right mode - | modeHasVTP mode -> pure True - | otherwise -> enableVTP h mode - - where - - enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool - enableVTP h mode = do - setConsoleMode h (modeAddVTP mode) - modeHasVTP <$> getConsoleMode h - `catch` \ (_ :: IOError) -> - pure False - - modeHasVTP :: Win32.DWORD -> Bool - modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 - - modeAddVTP :: Win32.DWORD -> Win32.DWORD - modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING - -eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD -eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 - -getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD -getConsoleMode h = with 64 $ \ mode -> do - Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode) - peek mode - -setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO () -setConsoleMode h mode = do - Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) - -foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode - :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL - -foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode - :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL - -#else - pure False -#endif diff --git a/main/TidyPgm.hs b/main/TidyPgm.hs deleted file mode 100644 --- a/main/TidyPgm.hs +++ /dev/null @@ -1,1484 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{Tidying up Core} --} - -{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-} - -module TidyPgm ( - mkBootModDetailsTc, tidyProgram - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -import DynFlags -import CoreSyn -import CoreUnfold -import CoreFVs -import CoreTidy -import CoreMonad -import CorePrep -import CoreUtils (rhsIsStatic) -import CoreStats (coreBindsStats, CoreStats(..)) -import CoreSeq (seqBinds) -import CoreLint -import Literal -import Rules -import PatSyn -import ConLike -import CoreArity ( exprArity, exprBotStrictness_maybe ) -import StaticPtrTable -import VarEnv -import VarSet -import Var -import Id -import MkId ( mkDictSelRhs ) -import IdInfo -import InstEnv -import Type ( tidyTopType ) -import Demand ( appIsBottom, isTopSig, isBottomingSig ) -import BasicTypes -import Name hiding (varName) -import NameSet -import NameCache -import Avail -import IfaceEnv -import TcEnv -import TcRnMonad -import DataCon -import TyCon -import Class -import Module -import Packages( isDllName ) -import HscTypes -import Maybes -import UniqSupply -import Outputable -import Util( filterOut ) -import qualified ErrUtils as Err - -import Control.Monad -import Data.Function -import Data.List ( sortBy, mapAccumL ) -import Data.IORef ( atomicModifyIORef' ) - -{- -Constructing the TypeEnv, Instances, Rules from which the -ModIface is constructed, and which goes on to subsequent modules in ---make mode. - -Most of the interface file is obtained simply by serialising the -TypeEnv. One important consequence is that if the *interface file* -has pragma info if and only if the final TypeEnv does. This is not so -important for *this* module, but it's essential for ghc --make: -subsequent compilations must not see (e.g.) the arity if the interface -file does not contain arity If they do, they'll exploit the arity; -then the arity might change, but the iface file doesn't change => -recompilation does not happen => disaster. - -For data types, the final TypeEnv will have a TyThing for the TyCon, -plus one for each DataCon; the interface file will contain just one -data type declaration, but it is de-serialised back into a collection -of TyThings. - -************************************************************************ -* * - Plan A: simpleTidyPgm -* * -************************************************************************ - - -Plan A: mkBootModDetails: omit pragmas, make interfaces small -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Ignore the bindings - -* Drop all WiredIn things from the TypeEnv - (we never want them in interface files) - -* Retain all TyCons and Classes in the TypeEnv, to avoid - having to find which ones are mentioned in the - types of exported Ids - -* Trim off the constructors of non-exported TyCons, both - from the TyCon and from the TypeEnv - -* Drop non-exported Ids from the TypeEnv - -* Tidy the types of the DFunIds of Instances, - make them into GlobalIds, (they already have External Names) - and add them to the TypeEnv - -* Tidy the types of the (exported) Ids in the TypeEnv, - make them into GlobalIds (they already have External Names) - -* Drop rules altogether - -* Tidy the bindings, to ensure that the Caf and Arity - information is correct for each top-level binder; the - code generator needs it. And to ensure that local names have - distinct OccNames in case of object-file splitting - -* If this an hsig file, drop the instances altogether too (they'll - get pulled in by the implicit module import. --} - --- This is Plan A: make a small type env when typechecking only, --- or when compiling a hs-boot file, or simply when not using -O --- --- We don't look at the bindings at all -- there aren't any --- for hs-boot files - -mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails -mkBootModDetailsTc hsc_env - TcGblEnv{ tcg_exports = exports, - tcg_type_env = type_env, -- just for the Ids - tcg_tcs = tcs, - tcg_patsyns = pat_syns, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_complete_matches = complete_sigs, - tcg_mod = this_mod - } - = -- This timing isn't terribly useful since the result isn't forced, but - -- the message is useful to locating oneself in the compilation process. - Err.withTiming dflags - (text "CoreTidy"<+>brackets (ppr this_mod)) - (const ()) $ - return (ModDetails { md_types = type_env' - , md_insts = insts' - , md_fam_insts = fam_insts - , md_rules = [] - , md_anns = [] - , md_exports = exports - , md_complete_sigs = complete_sigs - }) - where - dflags = hsc_dflags hsc_env - - -- Find the LocalIds in the type env that are exported - -- Make them into GlobalIds, and tidy their types - -- - -- It's very important to remove the non-exported ones - -- because we don't tidy the OccNames, and if we don't remove - -- the non-exported ones we'll get many things with the - -- same name in the interface file, giving chaos. - -- - -- Do make sure that we keep Ids that are already Global. - -- When typechecking an .hs-boot file, the Ids come through as - -- GlobalIds. - final_ids = [ globaliseAndTidyBootId id - | id <- typeEnvIds type_env - , keep_it id ] - - final_tcs = filterOut (isWiredInName . getName) tcs - -- See Note [Drop wired-in things] - type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts - insts' = mkFinalClsInsts type_env1 insts - pat_syns' = mkFinalPatSyns type_env1 pat_syns - type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 - - -- Default methods have their export flag set (isExportedId), - -- but everything else doesn't (yet), because this is - -- pre-desugaring, so we must test against the exports too. - keep_it id | isWiredInName id_name = False - -- See Note [Drop wired-in things] - | isExportedId id = True - | id_name `elemNameSet` exp_names = True - | otherwise = False - where - id_name = idName id - - exp_names = availsToNameSet exports - -lookupFinalId :: TypeEnv -> Id -> Id -lookupFinalId type_env id - = case lookupTypeEnv type_env (idName id) of - Just (AnId id') -> id' - _ -> pprPanic "lookup_final_id" (ppr id) - -mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] -mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) - -mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn] -mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env)) - -extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv -extendTypeEnvWithPatSyns tidy_patsyns type_env - = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] - -globaliseAndTidyBootId :: Id -> Id --- For a LocalId with an External Name, --- makes it into a GlobalId --- * unchanged Name (might be Internal or External) --- * unchanged details --- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity) --- * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface) -globaliseAndTidyBootId id - = globaliseId id `setIdType` tidyTopType (idType id) - `setIdUnfolding` BootUnfolding - -{- -************************************************************************ -* * - Plan B: tidy bindings, make TypeEnv full of IdInfo -* * -************************************************************************ - -Plan B: include pragmas, make interfaces -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Step 1: Figure out which Ids are externally visible - See Note [Choosing external Ids] - -* Step 2: Gather the externally visible rules, separately from - the top-level bindings. - See Note [Finding external rules] - -* Step 3: Tidy the bindings, externalising appropriate Ids - See Note [Tidy the top-level bindings] - -* Drop all Ids from the TypeEnv, and add all the External Ids from - the bindings. (This adds their IdInfo to the TypeEnv; and adds - floated-out Ids that weren't even in the TypeEnv before.) - -Note [Choosing external Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also the section "Interface stability" in the -recompilation-avoidance commentary: - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance - -First we figure out which Ids are "external" Ids. An -"external" Id is one that is visible from outside the compilation -unit. These are - a) the user exported ones - b) the ones bound to static forms - c) ones mentioned in the unfoldings, workers, or - rules of externally-visible ones - -While figuring out which Ids are external, we pick a "tidy" OccName -for each one. That is, we make its OccName distinct from the other -external OccNames in this module, so that in interface files and -object code we can refer to it unambiguously by its OccName. The -OccName for each binder is prefixed by the name of the exported Id -that references it; e.g. if "f" references "x" in its unfolding, then -"x" is renamed to "f_x". This helps distinguish the different "x"s -from each other, and means that if "f" is later removed, things that -depend on the other "x"s will not need to be recompiled. Of course, -if there are multiple "f_x"s, then we have to disambiguate somehow; we -use "f_x0", "f_x1" etc. - -As far as possible we should assign names in a deterministic fashion. -Each time this module is compiled with the same options, we should end -up with the same set of external names with the same types. That is, -the ABI hash in the interface should not change. This turns out to be -quite tricky, since the order of the bindings going into the tidy -phase is already non-deterministic, as it is based on the ordering of -Uniques, which are assigned unpredictably. - -To name things in a stable way, we do a depth-first-search of the -bindings, starting from the exports sorted by name. This way, as long -as the bindings themselves are deterministic (they sometimes aren't!), -the order in which they are presented to the tidying phase does not -affect the names we assign. - -Note [Tidy the top-level bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Next we traverse the bindings top to bottom. For each *top-level* -binder - - 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, - reflecting the fact that from now on we regard it as a global, - not local, Id - - 2. Give it a system-wide Unique. - [Even non-exported things need system-wide Uniques because the - byte-code generator builds a single Name->BCO symbol table.] - - We use the NameCache kept in the HscEnv as the - source of such system-wide uniques. - - For external Ids, use the original-name cache in the NameCache - to ensure that the unique assigned is the same as the Id had - in any previous compilation run. - - 3. Rename top-level Ids according to the names we chose in step 1. - If it's an external Id, make it have a External Name, otherwise - make it have an Internal Name. This is used by the code generator - to decide whether to make the label externally visible - - 4. Give it its UTTERLY FINAL IdInfo; in ptic, - * its unfolding, if it should have one - - * its arity, computed from the number of visible lambdas - - * its CAF info, computed from what is free in its RHS - - -Finally, substitute these new top-level binders consistently -throughout, including in unfoldings. We also tidy binders in -RHSs, so that they print nicely in interfaces. --} - -tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) -tidyProgram hsc_env (ModGuts { mg_module = mod - , mg_exports = exports - , mg_rdr_env = rdr_env - , mg_tcs = tcs - , mg_insts = cls_insts - , mg_fam_insts = fam_insts - , mg_binds = binds - , mg_patsyns = patsyns - , mg_rules = imp_rules - , mg_anns = anns - , mg_complete_sigs = complete_sigs - , mg_deps = deps - , mg_foreign = foreign_stubs - , mg_foreign_files = foreign_files - , mg_hpc_info = hpc_info - , mg_modBreaks = modBreaks - }) - - = Err.withTiming dflags - (text "CoreTidy"<+>brackets (ppr mod)) - (const ()) $ - do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags - ; expose_all = gopt Opt_ExposeAllUnfoldings dflags - ; print_unqual = mkPrintUnqualified dflags rdr_env - ; implicit_binds = concatMap getImplicitBinds tcs - } - - ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags expose_all - binds implicit_binds imp_rules - ; let { (trimmed_binds, trimmed_rules) - = findExternalRules omit_prags binds imp_rules unfold_env } - - ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds - - -- See Note [Grand plan for static forms] in StaticPtrTable. - ; (spt_entries, tidy_binds') <- - sptCreateStaticBinds hsc_env mod tidy_binds - ; let { spt_init_code = sptModuleInitCode mod spt_entries - ; add_spt_init_code = - case hscTarget dflags of - -- If we are compiling for the interpreter we will insert - -- any necessary SPT entries dynamically - HscInterpreted -> id - -- otherwise add a C stub to do so - _ -> (`appendStubC` spt_init_code) - - -- The completed type environment is gotten from - -- a) the types and classes defined here (plus implicit things) - -- b) adding Ids with correct IdInfo, including unfoldings, - -- gotten from the bindings - -- From (b) we keep only those Ids with External names; - -- the CoreTidy pass makes sure these are all and only - -- the externally-accessible ones - -- This truncates the type environment to include only the - -- exported Ids and things needed from them, which saves space - -- - -- See Note [Don't attempt to trim data types] - ; final_ids = [ if omit_prags then trimId id else id - | id <- bindersOfBinds tidy_binds - , isExternalName (idName id) - , not (isWiredInName (getName id)) - ] -- See Note [Drop wired-in things] - - ; final_tcs = filterOut (isWiredInName . getName) tcs - -- See Note [Drop wired-in things] - ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts - ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts - ; tidy_patsyns = mkFinalPatSyns type_env patsyns - ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env - ; tidy_rules = tidyRules tidy_env trimmed_rules - - ; -- See Note [Injecting implicit bindings] - all_tidy_binds = implicit_binds ++ tidy_binds' - - -- Get the TyCons to generate code for. Careful! We must use - -- the untidied TyCons here, because we need - -- (a) implicit TyCons arising from types and classes defined - -- in this module - -- (b) wired-in TyCons, which are normally removed from the - -- TypeEnv we put in the ModDetails - -- (c) Constructors even if they are not exported (the - -- tidied TypeEnv has trimmed these away) - ; alg_tycons = filter isAlgTyCon tcs - } - - ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules - - -- If the endPass didn't print the rules, but ddump-rules is - -- on, print now - ; unless (dopt Opt_D_dump_simpl dflags) $ - Err.dumpIfSet_dyn dflags Opt_D_dump_rules - (showSDoc dflags (ppr CoreTidy <+> text "rules")) - (pprRulesForUser dflags tidy_rules) - - -- Print one-line size info - ; let cs = coreBindsStats tidy_binds - ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" - (text "Tidy size (terms,types,coercions)" - <+> ppr (moduleName mod) <> colon - <+> int (cs_tm cs) - <+> int (cs_ty cs) - <+> int (cs_co cs) ) - - ; return (CgGuts { cg_module = mod, - cg_tycons = alg_tycons, - cg_binds = all_tidy_binds, - cg_foreign = add_spt_init_code foreign_stubs, - cg_foreign_files = foreign_files, - cg_dep_pkgs = map fst $ dep_pkgs deps, - cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks, - cg_spt_entries = spt_entries }, - - ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_cls_insts, - md_fam_insts = fam_insts, - md_exports = exports, - md_anns = anns, -- are already tidy - md_complete_sigs = complete_sigs - }) - } - where - dflags = hsc_dflags hsc_env - --------------------------- -trimId :: Id -> Id -trimId id - | not (isImplicitId id) - = id `setIdInfo` vanillaIdInfo - | otherwise - = id - -{- Note [Drop wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never put wired-in TyCons or Ids in an interface file. -They are wired-in, so the compiler knows about them already. - -Note [Don't attempt to trim data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For some time GHC tried to avoid exporting the data constructors -of a data type if it wasn't strictly necessary to do so; see #835. -But "strictly necessary" accumulated a longer and longer list -of exceptions, and finally I gave up the battle: - - commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11 - Author: Simon Peyton Jones - Date: Thu Dec 6 16:03:16 2012 +0000 - - Stop attempting to "trim" data types in interface files - - Without -O, we previously tried to make interface files smaller - by not including the data constructors of data types. But - there are a lot of exceptions, notably when Template Haskell is - involved or, more recently, DataKinds. - - However #7445 shows that even without TemplateHaskell, using - the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ - is enough to require us to expose the data constructors. - - So I've given up on this "optimisation" -- it's probably not - important anyway. Now I'm simply not attempting to trim off - the data constructors. The gain in simplicity is worth the - modest cost in interface file growth, which is limited to the - bits reqd to describe those data constructors. - -************************************************************************ -* * - Implicit bindings -* * -************************************************************************ - -Note [Injecting implicit bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We inject the implicit bindings right at the end, in CoreTidy. -Some of these bindings, notably record selectors, are not -constructed in an optimised form. E.g. record selector for - data T = MkT { x :: {-# UNPACK #-} !Int } -Then the unfolding looks like - x = \t. case t of MkT x1 -> let x = I# x1 in x -This generates bad code unless it's first simplified a bit. That is -why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of -optimisation first. (Only matters when the selector is used curried; -eg map x ys.) See #2070. - -[Oct 09: in fact, record selectors are no longer implicit Ids at all, -because we really do want to optimise them properly. They are treated -much like any other Id. But doing "light" optimisation on an implicit -Id still makes sense.] - -At one time I tried injecting the implicit bindings *early*, at the -beginning of SimplCore. But that gave rise to real difficulty, -because GlobalIds are supposed to have *fixed* IdInfo, but the -simplifier and other core-to-core passes mess with IdInfo all the -time. The straw that broke the camels back was when a class selector -got the wrong arity -- ie the simplifier gave it arity 2, whereas -importing modules were expecting it to have arity 1 (#2844). -It's much safer just to inject them right at the end, after tidying. - -Oh: two other reasons for injecting them late: - - - If implicit Ids are already in the bindings when we start TidyPgm, - we'd have to be careful not to treat them as external Ids (in - the sense of chooseExternalIds); else the Ids mentioned in *their* - RHSs will be treated as external and you get an interface file - saying a18 = - but nothing referring to a18 (because the implicit Id is the - one that does, and implicit Ids don't appear in interface files). - - - More seriously, the tidied type-envt will include the implicit - Id replete with a18 in its unfolding; but we won't take account - of a18 when computing a fingerprint for the class; result chaos. - -There is one sort of implicit binding that is injected still later, -namely those for data constructor workers. Reason (I think): it's -really just a code generation trick.... binding itself makes no sense. -See Note [Data constructor workers] in CorePrep. --} - -getImplicitBinds :: TyCon -> [CoreBind] -getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc - where - cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) - -getTyConImplicitBinds :: TyCon -> [CoreBind] -getTyConImplicitBinds tc - | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId - | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) - -getClassImplicitBinds :: Class -> [CoreBind] -getClassImplicitBinds cls - = [ NonRec op (mkDictSelRhs cls val_index) - | (op, val_index) <- classAllSelIds cls `zip` [0..] ] - -get_defn :: Id -> CoreBind -get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) - -{- -************************************************************************ -* * -\subsection{Step 1: finding externals} -* * -************************************************************************ - -See Note [Choosing external Ids]. --} - -type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) - -- Maps each top-level Id to its new Name (the Id is tidied in step 2) - -- The Unique is unchanged. If the new Name is external, it will be - -- visible in the interface file. - -- - -- Bool => expose unfolding or not. - -chooseExternalIds :: HscEnv - -> Module - -> Bool -> Bool - -> [CoreBind] - -> [CoreBind] - -> [CoreRule] - -> IO (UnfoldEnv, TidyOccEnv) - -- Step 1 from the notes above - -chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules - = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env - ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders - ; tidy_internal internal_ids unfold_env1 occ_env1 } - where - nc_var = hsc_NC hsc_env - - -- init_ext_ids is the initial list of Ids that should be - -- externalised. It serves as the starting point for finding a - -- deterministic, tidy, renaming for all external Ids in this - -- module. - -- - -- It is sorted, so that it has a deterministic order (i.e. it's the - -- same list every time this module is compiled), in contrast to the - -- bindings, which are ordered non-deterministically. - init_work_list = zip init_ext_ids init_ext_ids - init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders - - -- An Id should be external if either (a) it is exported, - -- (b) it appears in the RHS of a local rule for an imported Id, or - -- See Note [Which rules to expose] - is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars - - rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules - - binders = map fst $ flattenBinds binds - implicit_binders = bindersOfBinds implicit_binds - binder_set = mkVarSet binders - - avoids = [getOccName name | bndr <- binders ++ implicit_binders, - let name = idName bndr, - isExternalName name ] - -- In computing our "avoids" list, we must include - -- all implicit Ids - -- all things with global names (assigned once and for - -- all by the renamer) - -- since their names are "taken". - -- The type environment is a convenient source of such things. - -- In particular, the set of binders doesn't include - -- implicit Ids at this stage. - - -- We also make sure to avoid any exported binders. Consider - -- f{-u1-} = 1 -- Local decl - -- ... - -- f{-u2-} = 2 -- Exported decl - -- - -- The second exported decl must 'get' the name 'f', so we - -- have to put 'f' in the avoids list before we get to the first - -- decl. tidyTopId then does a no-op on exported binders. - init_occ_env = initTidyOccEnv avoids - - - search :: [(Id,Id)] -- The work-list: (external id, referring id) - -- Make a tidy, external Name for the external id, - -- add it to the UnfoldEnv, and do the same for the - -- transitive closure of Ids it refers to - -- The referring id is used to generate a tidy - --- name for the external id - -> UnfoldEnv -- id -> (new Name, show_unfold) - -> TidyOccEnv -- occ env for choosing new Names - -> IO (UnfoldEnv, TidyOccEnv) - - search [] unfold_env occ_env = return (unfold_env, occ_env) - - search ((idocc,referrer) : rest) unfold_env occ_env - | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env - | otherwise = do - (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc - let - (new_ids, show_unfold) - | omit_prags = ([], False) - | otherwise = addExternal expose_all refined_id - - -- 'idocc' is an *occurrence*, but we need to see the - -- unfolding in the *definition*; so look up in binder_set - refined_id = case lookupVarSet binder_set idocc of - Just id -> id - Nothing -> WARN( True, ppr idocc ) idocc - - unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) - referrer' | isExportedId refined_id = refined_id - | otherwise = referrer - -- - search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' - - tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv - -> IO (UnfoldEnv, TidyOccEnv) - tidy_internal [] unfold_env occ_env = return (unfold_env,occ_env) - tidy_internal (id:ids) unfold_env occ_env = do - (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id - let unfold_env' = extendVarEnv unfold_env id (name',False) - tidy_internal ids unfold_env' occ_env' - -addExternal :: Bool -> Id -> ([Id], Bool) -addExternal expose_all id = (new_needed_ids, show_unfold) - where - new_needed_ids = bndrFvsInOrder show_unfold id - idinfo = idInfo id - show_unfold = show_unfolding (unfoldingInfo idinfo) - never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) - loop_breaker = isStrongLoopBreaker (occInfo idinfo) - bottoming_fn = isBottomingSig (strictnessInfo idinfo) - - -- Stuff to do with the Id's unfolding - -- We leave the unfolding there even if there is a worker - -- In GHCi the unfolding is used by importers - - show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) - = expose_all -- 'expose_all' says to expose all - -- unfoldings willy-nilly - - || isStableSource src -- Always expose things whose - -- source is an inline rule - - || not (bottoming_fn -- No need to inline bottom functions - || never_active -- Or ones that say not to - || loop_breaker -- Or that are loop breakers - || neverUnfoldGuidance guidance) - show_unfolding (DFunUnfolding {}) = True - show_unfolding _ = False - -{- -************************************************************************ -* * - Deterministic free variables -* * -************************************************************************ - -We want a deterministic free-variable list. exprFreeVars gives us -a VarSet, which is in a non-deterministic order when converted to a -list. Hence, here we define a free-variable finder that returns -the free variables in the order that they are encountered. - -See Note [Choosing external Ids] --} - -bndrFvsInOrder :: Bool -> Id -> [Id] -bndrFvsInOrder show_unfold id - = run (dffvLetBndr show_unfold id) - -run :: DFFV () -> [Id] -run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of - ((_,ids),_) -> ids - -newtype DFFV a - = DFFV (VarSet -- Envt: non-top-level things that are in scope - -- we don't want to record these as free vars - -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far - -> ((VarSet,[Var]),a)) -- Output state - deriving (Functor) - -instance Applicative DFFV where - pure a = DFFV $ \_ st -> (st, a) - (<*>) = ap - -instance Monad DFFV where - (DFFV m) >>= k = DFFV $ \env st -> - case m env st of - (st',a) -> case k a of - DFFV f -> f env st' - -extendScope :: Var -> DFFV a -> DFFV a -extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) - -extendScopeList :: [Var] -> DFFV a -> DFFV a -extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) - -insert :: Var -> DFFV () -insert v = DFFV $ \ env (set, ids) -> - let keep_me = isLocalId v && - not (v `elemVarSet` env) && - not (v `elemVarSet` set) - in if keep_me - then ((extendVarSet set v, v:ids), ()) - else ((set, ids), ()) - - -dffvExpr :: CoreExpr -> DFFV () -dffvExpr (Var v) = insert v -dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 -dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e -dffvExpr (Tick _other e) = dffvExpr e -dffvExpr (Cast e _) = dffvExpr e -dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) -dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ - (mapM_ dffvBind prs >> dffvExpr e) -dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) -dffvExpr _other = return () - -dffvAlt :: (t, [Var], CoreExpr) -> DFFV () -dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) - -dffvBind :: (Id, CoreExpr) -> DFFV () -dffvBind(x,r) - | not (isId x) = dffvExpr r - | otherwise = dffvLetBndr False x >> dffvExpr r - -- Pass False because we are doing the RHS right here - -- If you say True you'll get *exponential* behaviour! - -dffvLetBndr :: Bool -> Id -> DFFV () --- Gather the free vars of the RULES and unfolding of a binder --- We always get the free vars of a *stable* unfolding, but --- for a *vanilla* one (InlineRhs), the flag controls what happens: --- True <=> get fvs of even a *vanilla* unfolding --- False <=> ignore an InlineRhs --- For nested bindings (call from dffvBind) we always say "False" because --- we are taking the fvs of the RHS anyway --- For top-level bindings (call from addExternal, via bndrFvsInOrder) --- we say "True" if we are exposing that unfolding -dffvLetBndr vanilla_unfold id - = do { go_unf (unfoldingInfo idinfo) - ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } - where - idinfo = idInfo id - - go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - = case src of - InlineRhs | vanilla_unfold -> dffvExpr rhs - | otherwise -> return () - _ -> dffvExpr rhs - - go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = extendScopeList bndrs $ mapM_ dffvExpr args - go_unf _ = return () - - go_rule (BuiltinRule {}) = return () - go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) - = extendScopeList bndrs (dffvExpr rhs) - -{- -************************************************************************ -* * - findExternalRules -* * -************************************************************************ - -Note [Finding external rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The complete rules are gotten by combining - a) local rules for imported Ids - b) rules embedded in the top-level Ids - -There are two complications: - * Note [Which rules to expose] - * Note [Trimming auto-rules] - -Note [Which rules to expose] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function 'expose_rule' filters out rules that mention, on the LHS, -Ids that aren't externally visible; these rules can't fire in a client -module. - -The externally-visible binders are computed (by chooseExternalIds) -assuming that all orphan rules are externalised (see init_ext_ids in -function 'search'). So in fact it's a bit conservative and we may -export more than we need. (It's a sort of mutual recursion.) - -Note [Trimming auto-rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Second, with auto-specialisation we may specialise local or imported -dfuns or INLINE functions, and then later inline them. That may leave -behind something like - RULE "foo" forall d. f @ Int d = f_spec -where f is either local or imported, and there is no remaining -reference to f_spec except from the RULE. - -Now that RULE *might* be useful to an importing module, but that is -purely speculative, and meanwhile the code is taking up space and -codegen time. I found that binary sizes jumped by 6-10% when I -started to specialise INLINE functions (again, Note [Inline -specialisations] in Specialise). - -So it seems better to drop the binding for f_spec, and the rule -itself, if the auto-generated rule is the *only* reason that it is -being kept alive. - -(The RULE still might have been useful in the past; that is, it was -the right thing to have generated it in the first place. See Note -[Inline specialisations] in Specialise. But now it has served its -purpose, and can be discarded.) - -So findExternalRules does this: - * Remove all bindings that are kept alive *only* by isAutoRule rules - (this is done in trim_binds) - * Remove all auto rules that mention bindings that have been removed - (this is done by filtering by keep_rule) - -NB: if a binding is kept alive for some *other* reason (e.g. f_spec is -called in the final code), we keep the rule too. - -This stuff is the only reason for the ru_auto field in a Rule. --} - -findExternalRules :: Bool -- Omit pragmas - -> [CoreBind] - -> [CoreRule] -- Local rules for imported fns - -> UnfoldEnv -- Ids that are exported, so we need their rules - -> ([CoreBind], [CoreRule]) --- See Note [Finding external rules] -findExternalRules omit_prags binds imp_id_rules unfold_env - = (trimmed_binds, filter keep_rule all_rules) - where - imp_rules = filter expose_rule imp_id_rules - imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules - - user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet - | otherwise = ruleRhsFreeVars rule - - (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds - - keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs - -- Remove rules that make no sense, because they mention a - -- local binder (on LHS or RHS) that we have now discarded. - -- (NB: ruleFreeVars only includes LocalIds) - -- - -- LHS: we have already filtered out rules that mention internal Ids - -- on LHS but that isn't enough because we might have by now - -- discarded a binding with an external Id. (How? - -- chooseExternalIds is a bit conservative.) - -- - -- RHS: the auto rules that might mention a binder that has - -- been discarded; see Note [Trimming auto-rules] - - expose_rule rule - | omit_prags = False - | otherwise = all is_external_id (ruleLhsFreeIdsList rule) - -- Don't expose a rule whose LHS mentions a locally-defined - -- Id that is completely internal (i.e. not visible to an - -- importing module). NB: ruleLhsFreeIds only returns LocalIds. - -- See Note [Which rules to expose] - - is_external_id id = case lookupVarEnv unfold_env id of - Just (name, _) -> isExternalName name - Nothing -> False - - trim_binds :: [CoreBind] - -> ( [CoreBind] -- Trimmed bindings - , VarSet -- Binders of those bindings - , VarSet -- Free vars of those bindings + rhs of user rules - -- (we don't bother to delete the binders) - , [CoreRule]) -- All rules, imported + from the bindings - -- This function removes unnecessary bindings, and gathers up rules from - -- the bindings we keep. See Note [Trimming auto-rules] - trim_binds [] -- Base case, start with imp_user_rule_fvs - = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) - - trim_binds (bind:binds) - | any needed bndrs -- Keep binding - = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) - | otherwise -- Discard binding altogether - = stuff - where - stuff@(binds', bndr_set, needed_fvs, rules) - = trim_binds binds - needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs - - bndrs = bindersOf bind - rhss = rhssOfBind bind - bndr_set' = bndr_set `extendVarSetList` bndrs - - needed_fvs' = needed_fvs `unionVarSet` - mapUnionVarSet idUnfoldingVars bndrs `unionVarSet` - -- Ignore type variables in the type of bndrs - mapUnionVarSet exprFreeVars rhss `unionVarSet` - mapUnionVarSet user_rule_rhs_fvs local_rules - -- In needed_fvs', we don't bother to delete binders from the fv set - - local_rules = [ rule - | id <- bndrs - , is_external_id id -- Only collect rules for external Ids - , rule <- idCoreRules id - , expose_rule rule ] -- and ones that can fire in a client - -{- -************************************************************************ -* * - tidyTopName -* * -************************************************************************ - -This is where we set names to local/global based on whether they really are -externally visible (see comment at the top of this module). If the name -was previously local, we have to give it a unique occurrence name if -we intend to externalise it. --} - -tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv - -> Id -> IO (TidyOccEnv, Name) -tidyTopName mod nc_var maybe_ref occ_env id - | global && internal = return (occ_env, localiseName name) - - | global && external = return (occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too - - -- Now we get to the real reason that all this is in the IO Monad: - -- we have to update the name cache in a nice atomic fashion - - | local && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local - ; return (occ_env', new_local_name) } - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table - - | local && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external - ; return (occ_env', new_external_name) } - - | otherwise = panic "tidyTopName" - where - name = idName id - external = isJust maybe_ref - global = isExternalName name - local = not global - internal = not external - loc = nameSrcSpan name - - old_occ = nameOccName name - new_occ | Just ref <- maybe_ref - , ref /= id - = mkOccName (occNameSpace old_occ) $ - let - ref_str = occNameString (getOccName ref) - occ_str = occNameString old_occ - in - case occ_str of - '$':'w':_ -> occ_str - -- workers: the worker for a function already - -- includes the occname for its parent, so there's - -- no need to prepend the referrer. - _other | isSystemName name -> ref_str - | otherwise -> ref_str ++ '_' : occ_str - -- If this name was system-generated, then don't bother - -- to retain its OccName, just use the referrer. These - -- system-generated names will become "f1", "f2", etc. for - -- a referrer "f". - | otherwise = old_occ - - (occ_env', occ') = tidyOccName occ_env new_occ - - mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) - where - (uniq, us) = takeUniqFromSupply (nsUniqs nc) - - mk_new_external nc = allocateGlobalBinder nc mod occ' loc - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table. - -- All this is done by allcoateGlobalBinder. - -- This is needed when *re*-compiling a module in GHCi; we must - -- use the same name for externally-visible things as we did before. - -{- -************************************************************************ -* * -\subsection{Step 2: top-level tidying} -* * -************************************************************************ --} - --- TopTidyEnv: when tidying we need to know --- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. --- These may have arisen because the --- renamer read in an interface file mentioning M.$wf, say, --- and assigned it unique r77. If, on this compilation, we've --- invented an Id whose name is $wf (but with a different unique) --- we want to rename it to have unique r77, so that we can do easy --- comparisons with stuff from the interface file --- --- * occ_env: The TidyOccEnv, which tells us which local occurrences --- are 'used' --- --- * subst_env: A Var->Var mapping that substitutes the new Var for the old - -tidyTopBinds :: HscEnv - -> Module - -> UnfoldEnv - -> TidyOccEnv - -> CoreProgram - -> IO (TidyEnv, CoreProgram) - -tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - mkNaturalId <- lookupMkNaturalName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env - let cvt_literal nt i = case nt of - LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i) - LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i) - _ -> Nothing - result = tidy cvt_literal init_env binds - seqBinds (snd result) `seq` return result - -- This seqBinds avoids a spike in space usage (see #13564) - where - dflags = hsc_dflags hsc_env - - init_env = (init_occ_env, emptyVarEnv) - - tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env) - ------------------------- -tidyTopBind :: DynFlags - -> Module - -> (LitNumType -> Integer -> Maybe CoreExpr) - -> UnfoldEnv - -> TidyEnv - -> CoreBind - -> (TidyEnv, CoreBind) - -tidyTopBind dflags this_mod cvt_literal unfold_env - (occ_env,subst1) (NonRec bndr rhs) - = (tidy_env2, NonRec bndr' rhs') - where - Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs dflags this_mod - (subst1, cvt_literal) - (idArity bndr) rhs - (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' - (bndr, rhs) - subst2 = extendVarEnv subst1 bndr bndr' - tidy_env2 = (occ_env, subst2) - -tidyTopBind dflags this_mod cvt_literal unfold_env - (occ_env, subst1) (Rec prs) - = (tidy_env2, Rec prs') - where - prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) - | (id,rhs) <- prs, - let (name',show_unfold) = - expectJust "tidyTopBind" $ lookupVarEnv unfold_env id - ] - - subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') - tidy_env2 = (occ_env, subst2) - - bndrs = map fst prs - - -- the CafInfo for a recursive group says whether *any* rhs in - -- the group may refer indirectly to a CAF (because then, they all do). - caf_info - | or [ mayHaveCafRefs (hasCafRefs dflags this_mod - (subst1, cvt_literal) - (idArity bndr) rhs) - | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - ------------------------------------------------------------ -tidyTopPair :: DynFlags - -> Bool -- show unfolding - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -- It is knot-tied: don't look at it! - -> CafInfo - -> Name -- New name - -> (Id, CoreExpr) -- Binder and RHS before tidying - -> (Id, CoreExpr) - -- This function is the heart of Step 2 - -- The rec_tidy_env is the one to use for the IdInfo - -- It's necessary because when we are dealing with a recursive - -- group, a variable late in the group might be mentioned - -- in the IdInfo of one early in the group - -tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) - = (bndr1, rhs1) - where - bndr1 = mkGlobalId details name' ty' idinfo' - details = idDetails bndr -- Preserve the IdDetails - ty' = tidyTopType (idType bndr) - rhs1 = tidyExpr rhs_tidy_env rhs - idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) - show_unfold caf_info - --- tidyTopIdInfo creates the final IdInfo for top-level --- binders. There are two delicate pieces: --- --- * Arity. After CoreTidy, this arity must not change any more. --- Indeed, CorePrep must eta expand where necessary to make --- the manifest arity equal to the claimed arity. --- --- * CAF info. This must also remain valid through to code generation. --- We add the info here so that it propagates to all --- occurrences of the binders in RHSs, and hence to occurrences in --- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. --- CoreToStg makes use of this when constructing SRTs. -tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr - -> IdInfo -> Bool -> CafInfo -> IdInfo -tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info - | not is_external -- For internal Ids (not externally visible) - = vanillaIdInfo -- we only need enough info for code generation - -- Arity and strictness info are enough; - -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig - `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] - -- in CoreTidy - - | otherwise -- Externally-visible Ids get the whole lot - = vanillaIdInfo - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig - `setOccInfo` robust_occ_info - `setInlinePragInfo` (inlinePragInfo idinfo) - `setUnfoldingInfo` unfold_info - -- NB: we throw away the Rules - -- They have already been extracted by findExternalRules - where - is_external = isExternalName name - - --------- OccInfo ------------ - robust_occ_info = zapFragileOcc (occInfo idinfo) - -- It's important to keep loop-breaker information - -- when we are doing -fexpose-all-unfoldings - - --------- Strictness ------------ - mb_bot_str = exprBotStrictness_maybe orig_rhs - - sig = strictnessInfo idinfo - final_sig | not $ isTopSig sig - = WARN( _bottom_hidden sig , ppr name ) sig - -- try a cheap-and-cheerful bottom analyser - | Just (_, nsig) <- mb_bot_str = nsig - | otherwise = sig - - _bottom_hidden id_sig = case mb_bot_str of - Nothing -> False - Just (arity, _) -> not (appIsBottom id_sig arity) - - --------- Unfolding ------------ - unf_info = unfoldingInfo idinfo - unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs - | otherwise = minimal_unfold_info - minimal_unfold_info = zapUnfolding unf_info - unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs - is_bot = isBottomingSig final_sig - -- NB: do *not* expose the worker if show_unfold is off, - -- because that means this thing is a loop breaker or - -- marked NOINLINE or something like that - -- This is important: if you expose the worker for a loop-breaker - -- then you can make the simplifier go into an infinite loop, because - -- in effect the unfolding is exposed. See #1709 - -- - -- You might think that if show_unfold is False, then the thing should - -- not be w/w'd in the first place. But a legitimate reason is this: - -- the function returns bottom - -- In this case, show_unfold will be false (we don't expose unfoldings - -- for bottoming functions), but we might still have a worker/wrapper - -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs - - - --------- Arity ------------ - -- Usually the Id will have an accurate arity on it, because - -- the simplifier has just run, but not always. - -- One case I found was when the last thing the simplifier - -- did was to let-bind a non-atomic argument and then float - -- it to the top level. So it seems more robust just to - -- fix it here. - arity = exprArity orig_rhs - -{- -************************************************************************ -* * - Figuring out CafInfo for an expression -* * -************************************************************************ - -hasCafRefs decides whether a top-level closure can point into the dynamic heap. -We mark such things as `MayHaveCafRefs' because this information is -used to decide whether a particular closure needs to be referenced -in an SRT or not. - -There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs - -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore -it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. - -Note [Disgusting computation of CafRefs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute hasCafRefs here, because IdInfo is supposed to be finalised -after TidyPgm. But CorePrep does some transformations that affect CAF-hood. -So we have to *predict* the result here, which is revolting. - -In particular CorePrep expands Integer and Natural literals. So in the -prediction code here we resort to applying the same expansion (cvt_literal). -There are also numberous other ways in which we can introduce inconsistencies -between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta -expansion in TidyPgm] for one such example. - -Ugh! What ugliness we hath wrought. - - -Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Eta expansion during CorePrep can have non-obvious negative consequences on -the CAFfyness computation done by TidyPgm (see Note [Disgusting computation of -CafRefs] in TidyPgm). This late expansion happens/happened for a few reasons: - - * CorePrep previously eta expanded unsaturated primop applications, as - described in Note [Primop wrappers]). - - * CorePrep still does eta expand unsaturated data constructor applications. - -In particular, consider the program: - - data Ty = Ty (RealWorld# -> (# RealWorld#, Int #)) - - -- Is this CAFfy? - x :: STM Int - x = Ty (retry# @Int) - -Consider whether x is CAFfy. One might be tempted to answer "no". -Afterall, f obviously has no CAF references and the application (retry# -@Int) is essentially just a variable reference at runtime. - -However, when CorePrep expanded the unsaturated application of 'retry#' -it would rewrite this to - - x = \u [] - let sat = retry# @Int - in Ty sat - -This is now a CAF. Failing to handle this properly was the cause of -#16846. We fixed this by eliminating the need to eta expand primops, as -described in Note [Primop wrappers]), However we have not yet done the same for -data constructor applications. - --} - -type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr) - -- The env finds the Caf-ness of the Id - -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for - -- Integer and Natural literals - -- See Note [Disgusting computation of CafRefs] - -hasCafRefs :: DynFlags -> Module - -> CafRefEnv -> Arity -> CoreExpr - -> CafInfo -hasCafRefs dflags this_mod (subst, cvt_literal) arity expr - | is_caf || mentions_cafs = MayHaveCafRefs - | otherwise = NoCafRefs - where - mentions_cafs = cafRefsE expr - is_dynamic_name = isDllName dflags this_mod - is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name - cvt_literal expr) - - -- NB. we pass in the arity of the expression, which is expected - -- to be calculated by exprArity. This is because exprArity - -- knows how much eta expansion is going to be done by - -- CorePrep later on, and we don't want to duplicate that - -- knowledge in rhsIsStatic below. - - cafRefsE :: Expr a -> Bool - cafRefsE (Var id) = cafRefsV id - cafRefsE (Lit lit) = cafRefsL lit - cafRefsE (App f a) = cafRefsE f || cafRefsE a - cafRefsE (Lam _ e) = cafRefsE e - cafRefsE (Let b e) = cafRefsEs (rhssOfBind b) || cafRefsE e - cafRefsE (Case e _ _ alts) = cafRefsE e || cafRefsEs (rhssOfAlts alts) - cafRefsE (Tick _n e) = cafRefsE e - cafRefsE (Cast e _co) = cafRefsE e - cafRefsE (Type _) = False - cafRefsE (Coercion _) = False - - cafRefsEs :: [Expr a] -> Bool - cafRefsEs [] = False - cafRefsEs (e:es) = cafRefsE e || cafRefsEs es - - cafRefsL :: Literal -> Bool - -- Don't forget that mk_integer id might have Caf refs! - -- We first need to convert the Integer into its final form, to - -- see whether mkInteger is used. Same for LitNatural. - cafRefsL (LitNumber nt i _) = case cvt_literal nt i of - Just e -> cafRefsE e - Nothing -> False - cafRefsL _ = False - - cafRefsV :: Id -> Bool - cafRefsV id - | not (isLocalId id) = mayHaveCafRefs (idCafInfo id) - | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id') - | otherwise = False - - -{- -************************************************************************ -* * - Old, dead, type-trimming code -* * -************************************************************************ - -We used to try to "trim off" the constructors of data types that are -not exported, to reduce the size of interface files, at least without --O. But that is not always possible: see the old Note [When we can't -trim types] below for exceptions. - -Then (#7445) I realised that the TH problem arises for any data type -that we have deriving( Data ), because we can invoke - Language.Haskell.TH.Quote.dataToExpQ -to get a TH Exp representation of a value built from that data type. -You don't even need {-# LANGUAGE TemplateHaskell #-}. - -At this point I give up. The pain of trimming constructors just -doesn't seem worth the gain. So I've dumped all the code, and am just -leaving it here at the end of the module in case something like this -is ever resurrected. - - -Note [When we can't trim types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea of type trimming is to export algebraic data types -abstractly (without their data constructors) when compiling without --O, unless of course they are explicitly exported by the user. - -We always export synonyms, because they can be mentioned in the type -of an exported Id. We could do a full dependency analysis starting -from the explicit exports, but that's quite painful, and not done for -now. - -But there are some times we can't do that, indicated by the 'no_trim_types' flag. - -First, Template Haskell. Consider (#2386) this - module M(T, makeOne) where - data T = Yay String - makeOne = [| Yay "Yep" |] -Notice that T is exported abstractly, but makeOne effectively exports it too! -A module that splices in $(makeOne) will then look for a declaration of Yay, -so it'd better be there. Hence, brutally but simply, we switch off type -constructor trimming if TH is enabled in this module. - -Second, data kinds. Consider (#5912) - {-# LANGUAGE DataKinds #-} - module M() where - data UnaryTypeC a = UnaryDataC a - type Bug = 'UnaryDataC -We always export synonyms, so Bug is exposed, and that means that -UnaryTypeC must be too, even though it's not explicitly exported. In -effect, DataKinds means that we'd need to do a full dependency analysis -to see what data constructors are mentioned. But we don't do that yet. - -In these two cases we just switch off type trimming altogether. - -mustExposeTyCon :: Bool -- Type-trimming flag - -> NameSet -- Exports - -> TyCon -- The tycon - -> Bool -- Can its rep be hidden? --- We are compiling without -O, and thus trying to write as little as --- possible into the interface file. But we must expose the details of --- any data types whose constructors or fields are exported -mustExposeTyCon no_trim_types exports tc - | no_trim_types -- See Note [When we can't trim types] - = True - - | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to - -- figure out whether it was mentioned in the type - -- of any other exported thing) - = True - - | isEnumerationTyCon tc -- For an enumeration, exposing the constructors - = True -- won't lead to the need for further exposure - - | isFamilyTyCon tc -- Open type family - = True - - -- Below here we just have data/newtype decls or family instances - - | null data_cons -- Ditto if there are no data constructors - = True -- (NB: empty data types do not count as enumerations - -- see Note [Enumeration types] in TyCon - - | any exported_con data_cons -- Expose rep if any datacon or field is exported - = True - - | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) - = True -- Expose the rep for newtypes if the rep is an FFI type. - -- For a very annoying reason. 'Foreign import' is meant to - -- be able to look through newtypes transparently, but it - -- can only do that if it can "see" the newtype representation - - | otherwise - = False - where - data_cons = tyConDataCons tc - exported_con con = any (`elemNameSet` exports) - (dataConName con : dataConFieldLabels con) --} diff --git a/main/ToolSettings.hs b/main/ToolSettings.hs deleted file mode 100644 --- a/main/ToolSettings.hs +++ /dev/null @@ -1,68 +0,0 @@ -module ToolSettings - ( ToolSettings (..) - ) where - -import GhcPrelude - -import CliOption -import Fingerprint - --- | Settings for other executables GHC calls. --- --- Probably should futher split down by phase, or split between --- platform-specific and platform-agnostic. -data ToolSettings = ToolSettings - { toolSettings_ldSupportsCompactUnwind :: Bool - , toolSettings_ldSupportsBuildId :: Bool - , toolSettings_ldSupportsFilelist :: Bool - , toolSettings_ldIsGnuLd :: Bool - , toolSettings_ccSupportsNoPie :: Bool - - -- commands for particular phases - , toolSettings_pgm_L :: String - , toolSettings_pgm_P :: (String, [Option]) - , toolSettings_pgm_F :: String - , toolSettings_pgm_c :: String - , toolSettings_pgm_a :: (String, [Option]) - , toolSettings_pgm_l :: (String, [Option]) - , toolSettings_pgm_lm :: (String, [Option]) - , toolSettings_pgm_dll :: (String, [Option]) - , toolSettings_pgm_T :: String - , toolSettings_pgm_windres :: String - , toolSettings_pgm_libtool :: String - , toolSettings_pgm_ar :: String - , toolSettings_pgm_otool :: String - , toolSettings_pgm_install_name_tool :: String - , toolSettings_pgm_ranlib :: String - , -- | LLVM: opt llvm optimiser - toolSettings_pgm_lo :: (String, [Option]) - , -- | LLVM: llc static compiler - toolSettings_pgm_lc :: (String, [Option]) - , -- | LLVM: c compiler - toolSettings_pgm_lcc :: (String, [Option]) - , toolSettings_pgm_i :: String - - -- options for particular phases - , toolSettings_opt_L :: [String] - , toolSettings_opt_P :: [String] - , -- | cached Fingerprint of sOpt_P - -- See Note [Repeated -optP hashing] - toolSettings_opt_P_fingerprint :: Fingerprint - , toolSettings_opt_F :: [String] - , toolSettings_opt_c :: [String] - , toolSettings_opt_cxx :: [String] - , toolSettings_opt_a :: [String] - , toolSettings_opt_l :: [String] - , toolSettings_opt_lm :: [String] - , toolSettings_opt_windres :: [String] - , -- | LLVM: llvm optimiser - toolSettings_opt_lo :: [String] - , -- | LLVM: llc static compiler - toolSettings_opt_lc :: [String] - , -- | LLVM: c compiler - toolSettings_opt_lcc :: [String] - , -- | iserv options - toolSettings_opt_i :: [String] - - , toolSettings_extraGccViaCFlags :: [String] - } diff --git a/nativeGen/AsmCodeGen.hs b/nativeGen/AsmCodeGen.hs deleted file mode 100644 --- a/nativeGen/AsmCodeGen.hs +++ /dev/null @@ -1,1222 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1993-2004 --- --- This is the top-level module in the native code generator. --- --- ----------------------------------------------------------------------------- - -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms, - DeriveFunctor #-} - -#if !defined(GHC_LOADED_INTO_GHCI) -{-# LANGUAGE UnboxedTuples #-} -#endif - -module AsmCodeGen ( - -- * Module entry point - nativeCodeGen - - -- * Test-only exports: see trac #12744 - -- used by testGraphNoSpills, which needs to access - -- the register allocator intermediate data structures - -- cmmNativeGen emits - , cmmNativeGen - , NcgImpl(..) - , x86NcgImpl - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import qualified X86.CodeGen -import qualified X86.Regs -import qualified X86.Instr -import qualified X86.Ppr - -import qualified SPARC.CodeGen -import qualified SPARC.Regs -import qualified SPARC.Instr -import qualified SPARC.Ppr -import qualified SPARC.ShortcutJump -import qualified SPARC.CodeGen.Expand - -import qualified PPC.CodeGen -import qualified PPC.Regs -import qualified PPC.RegInfo -import qualified PPC.Instr -import qualified PPC.Ppr - -import RegAlloc.Liveness -import qualified RegAlloc.Linear.Main as Linear - -import qualified GraphColor as Color -import qualified RegAlloc.Graph.Main as Color -import qualified RegAlloc.Graph.Stats as Color -import qualified RegAlloc.Graph.TrivColorable as Color - -import AsmUtils -import TargetReg -import GHC.Platform -import BlockLayout -import Config -import Instruction -import PIC -import Reg -import NCGMonad -import CFG -import Dwarf -import Debug - -import BlockId -import GHC.StgToCmm.CgUtils ( fixStgRegisters ) -import Cmm -import CmmUtils -import Hoopl.Collections -import Hoopl.Label -import Hoopl.Block -import CmmOpt ( cmmMachOpFold ) -import PprCmm -import CLabel - -import UniqFM -import UniqSupply -import DynFlags -import Util - -import BasicTypes ( Alignment ) -import qualified Pretty -import BufWrite -import Outputable -import FastString -import UniqSet -import ErrUtils -import Module -import Stream (Stream) -import qualified Stream - --- DEBUGGING ONLY ---import OrdList - -import Data.List -import Data.Maybe -import Data.Ord ( comparing ) -import Control.Exception -import Control.Monad -import System.IO - -{- -The native-code generator has machine-independent and -machine-dependent modules. - -This module ("AsmCodeGen") is the top-level machine-independent -module. Before entering machine-dependent land, we do some -machine-independent optimisations (defined below) on the -'CmmStmts's. - -We convert to the machine-specific 'Instr' datatype with -'cmmCodeGen', assuming an infinite supply of registers. We then use -a machine-independent register allocator ('regAlloc') to rejoin -reality. Obviously, 'regAlloc' has machine-specific helper -functions (see about "RegAllocInfo" below). - -Finally, we order the basic blocks of the function so as to minimise -the number of jumps between blocks, by utilising fallthrough wherever -possible. - -The machine-dependent bits break down as follows: - - * ["MachRegs"] Everything about the target platform's machine - registers (and immediate operands, and addresses, which tend to - intermingle/interact with registers). - - * ["MachInstrs"] Includes the 'Instr' datatype (possibly should - have a module of its own), plus a miscellany of other things - (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) - - * ["MachCodeGen"] is where 'Cmm' stuff turns into - machine instructions. - - * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really - a 'SDoc'). - - * ["RegAllocInfo"] In the register allocator, we manipulate - 'MRegsState's, which are 'BitSet's, one bit per machine register. - When we want to say something about a specific machine register - (e.g., ``it gets clobbered by this instruction''), we set/unset - its bit. Obviously, we do this 'BitSet' thing for efficiency - reasons. - - The 'RegAllocInfo' module collects together the machine-specific - info needed to do register allocation. - - * ["RegisterAlloc"] The (machine-independent) register allocator. --} - --------------------- -nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply - -> Stream IO RawCmmGroup a - -> IO a -nativeCodeGen dflags this_mod modLoc h us cmms - = let platform = targetPlatform dflags - nCG' :: ( Outputable statics, Outputable instr - , Outputable jumpDest, Instruction instr) - => NcgImpl statics instr jumpDest -> IO a - nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms - in case platformArch platform of - ArchX86 -> nCG' (x86NcgImpl dflags) - ArchX86_64 -> nCG' (x86_64NcgImpl dflags) - ArchPPC -> nCG' (ppcNcgImpl dflags) - ArchS390X -> panic "nativeCodeGen: No NCG for S390X" - ArchSPARC -> nCG' (sparcNcgImpl dflags) - ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64" - ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" - ArchAArch64 -> panic "nativeCodeGen: No NCG for ARM64" - ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags) - ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" - ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" - ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" - ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" - ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" - -x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) - X86.Instr.Instr X86.Instr.JumpDest -x86NcgImpl dflags - = (x86_64NcgImpl dflags) - -x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) - X86.Instr.Instr X86.Instr.JumpDest -x86_64NcgImpl dflags - = NcgImpl { - cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags - ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId - ,canShortcut = X86.Instr.canShortcut - ,shortcutStatics = X86.Instr.shortcutStatics - ,shortcutJump = X86.Instr.shortcutJump - ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl - ,maxSpillSlots = X86.Instr.maxSpillSlots dflags - ,allocatableRegs = X86.Regs.allocatableRegs platform - ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform - ,ncgExpandTop = id - ,ncgMakeFarBranches = const id - ,extractUnwindPoints = X86.CodeGen.extractUnwindPoints - ,invertCondBranches = X86.CodeGen.invertCondBranches - } - where platform = targetPlatform dflags - -ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest -ppcNcgImpl dflags - = NcgImpl { - cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags - ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId - ,canShortcut = PPC.RegInfo.canShortcut - ,shortcutStatics = PPC.RegInfo.shortcutStatics - ,shortcutJump = PPC.RegInfo.shortcutJump - ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl - ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags - ,allocatableRegs = PPC.Regs.allocatableRegs platform - ,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform - ,ncgExpandTop = id - ,ncgMakeFarBranches = PPC.Instr.makeFarBranches - ,extractUnwindPoints = const [] - ,invertCondBranches = \_ _ -> id - } - where platform = targetPlatform dflags - -sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest -sparcNcgImpl dflags - = NcgImpl { - cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags - ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId - ,canShortcut = SPARC.ShortcutJump.canShortcut - ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics - ,shortcutJump = SPARC.ShortcutJump.shortcutJump - ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl - ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags - ,allocatableRegs = SPARC.Regs.allocatableRegs - ,ncgAllocMoreStack = noAllocMoreStack - ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop - ,ncgMakeFarBranches = const id - ,extractUnwindPoints = const [] - ,invertCondBranches = \_ _ -> id - } - --- --- Allocating more stack space for spilling is currently only --- supported for the linear register allocator on x86/x86_64, the rest --- default to the panic below. To support allocating extra stack on --- more platforms provide a definition of ncgAllocMoreStack. --- -noAllocMoreStack :: Int -> NatCmmDecl statics instr - -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]) -noAllocMoreStack amount _ - = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n" - ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" - ++ " is a known limitation in the linear allocator.\n" - ++ "\n" - ++ " Try enabling the graph colouring allocator with -fregs-graph instead." - ++ " You can still file a bug report if you like.\n" - - --- | Data accumulated during code generation. Mostly about statistics, --- but also collects debug data for DWARF generation. -data NativeGenAcc statics instr - = NGS { ngs_imports :: ![[CLabel]] - , ngs_natives :: ![[NatCmmDecl statics instr]] - -- ^ Native code generated, for statistics. This might - -- hold a lot of data, so it is important to clear this - -- field as early as possible if it isn't actually - -- required. - , ngs_colorStats :: ![[Color.RegAllocStats statics instr]] - , ngs_linearStats :: ![[Linear.RegAllocStats]] - , ngs_labels :: ![Label] - , ngs_debug :: ![DebugBlock] - , ngs_dwarfFiles :: !DwarfFiles - , ngs_unwinds :: !(LabelMap [UnwindPoint]) - -- ^ see Note [Unwinding information in the NCG] - -- and Note [What is this unwinding business?] in Debug. - } - -{- -Note [Unwinding information in the NCG] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Unwind information is a type of metadata which allows a debugging tool -to reconstruct the values of machine registers at the time a procedure was -entered. For the most part, the production of unwind information is handled by -the Cmm stage, where it is represented by CmmUnwind nodes. - -Unfortunately, the Cmm stage doesn't know everything necessary to produce -accurate unwinding information. For instance, the x86-64 calling convention -requires that the stack pointer be aligned to 16 bytes, which in turn means that -GHC must sometimes add padding to $sp prior to performing a foreign call. When -this happens unwind information must be updated accordingly. -For this reason, we make the NCG backends responsible for producing -unwinding tables (with the extractUnwindPoints function in NcgImpl). - -We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds -field of NativeGenAcc. This is a label map which contains an entry for each -procedure, containing a list of unwinding points (e.g. a label and an associated -unwinding table). - -See also Note [What is this unwinding business?] in Debug. --} - -nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest, - Instruction instr) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> Handle - -> UniqSupply - -> Stream IO RawCmmGroup a - -> IO a -nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms - = do - -- BufHandle is a performance hack. We could hide it inside - -- Pretty if it weren't for the fact that we do lots of little - -- printDocs here (in order to do codegen in constant space). - bufh <- newBufHandle h - let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty - (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us - cmms ngs0 - _ <- finishNativeGen dflags modLoc bufh us' ngs - return a - -finishNativeGen :: Instruction instr - => DynFlags - -> ModLocation - -> BufHandle - -> UniqSupply - -> NativeGenAcc statics instr - -> IO UniqSupply -finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs - = withTimingSilent dflags (text "NCG") (`seq` ()) $ do - -- Write debug data and finish - let emitDw = debugLevel dflags > 0 - us' <- if not emitDw then return us else do - (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs) - emitNativeCode dflags bufh dwarf - return us' - bFlush bufh - - -- dump global NCG stats for graph coloring allocator - let stats = concat (ngs_colorStats ngs) - unless (null stats) $ do - - -- build the global register conflict graph - let graphGlobal - = foldl' Color.union Color.initGraph - $ [ Color.raGraph stat - | stat@Color.RegAllocStatsStart{} <- stats] - - dump_stats (Color.pprStats stats graphGlobal) - - let platform = targetPlatform dflags - dumpIfSet_dyn dflags - Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph - (targetRegDotColor platform) - (Color.trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - $ graphGlobal - - - -- dump global NCG stats for linear allocator - let linearStats = concat (ngs_linearStats ngs) - unless (null linearStats) $ - dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) - - -- write out the imports - printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle) - $ makeImportsDoc dflags (concat (ngs_imports ngs)) - return us' - where - dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats" - -cmmNativeGenStream :: (Outputable statics, Outputable instr - ,Outputable jumpDest, Instruction instr) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> BufHandle - -> UniqSupply - -> Stream IO RawCmmGroup a - -> NativeGenAcc statics instr - -> IO (NativeGenAcc statics instr, UniqSupply, a) - -cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs - = do r <- Stream.runStream cmm_stream - case r of - Left a -> - return (ngs { ngs_imports = reverse $ ngs_imports ngs - , ngs_natives = reverse $ ngs_natives ngs - , ngs_colorStats = reverse $ ngs_colorStats ngs - , ngs_linearStats = reverse $ ngs_linearStats ngs - }, - us, - a) - Right (cmms, cmm_stream') -> do - (us', ngs'') <- - withTimingSilent - dflags - ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do - -- Generate debug information - let debugFlag = debugLevel dflags > 0 - !ndbgs | debugFlag = cmmDebugGen modLoc cmms - | otherwise = [] - dbgMap = debugToMap ndbgs - - -- Generate native code - (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h - dbgMap us cmms ngs 0 - - -- Link native code information into debug blocks - -- See Note [What is this unwinding business?] in Debug. - let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs - unless (null ldbgs) $ - dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" - (vcat $ map ppr ldbgs) - - -- Accumulate debug information for emission in finishNativeGen. - let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] } - return (us', ngs'') - - cmmNativeGenStream dflags this_mod modLoc ncgImpl h us' - cmm_stream' ngs'' - - where ncglabel = text "NCG" - --- | Do native code generation on all these cmms. --- -cmmNativeGens :: forall statics instr jumpDest. - (Outputable statics, Outputable instr - ,Outputable jumpDest, Instruction instr) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> BufHandle - -> LabelMap DebugBlock - -> UniqSupply - -> [RawCmmDecl] - -> NativeGenAcc statics instr - -> Int - -> IO (NativeGenAcc statics instr, UniqSupply) - -cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go - where - go :: UniqSupply -> [RawCmmDecl] - -> NativeGenAcc statics instr -> Int - -> IO (NativeGenAcc statics instr, UniqSupply) - - go us [] ngs !_ = - return (ngs, us) - - go us (cmm : cmms) ngs count = do - let fileIds = ngs_dwarfFiles ngs - (us', fileIds', native, imports, colorStats, linearStats, unwinds) - <- {-# SCC "cmmNativeGen" #-} - cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap - cmm count - - -- Generate .file directives for every new file that has been - -- used. Note that it is important that we generate these in - -- ascending order, as Clang's 3.6 assembler complains. - let newFileIds = sortBy (comparing snd) $ - nonDetEltsUFM $ fileIds' `minusUFM` fileIds - -- See Note [Unique Determinism and code generation] - pprDecl (f,n) = text "\t.file " <> ppr n <+> - pprFilePathString (unpackFS f) - - emitNativeCode dflags h $ vcat $ - map pprDecl newFileIds ++ - map (pprNatCmmDecl ncgImpl) native - - -- force evaluation all this stuff to avoid space leaks - {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) () - - let !labels' = if debugLevel dflags > 0 - then cmmDebugLabels isMetaInstr native else [] - !natives' = if dopt Opt_D_dump_asm_stats dflags - then native : ngs_natives ngs else [] - - mCon = maybe id (:) - ngs' = ngs{ ngs_imports = imports : ngs_imports ngs - , ngs_natives = natives' - , ngs_colorStats = colorStats `mCon` ngs_colorStats ngs - , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs - , ngs_labels = ngs_labels ngs ++ labels' - , ngs_dwarfFiles = fileIds' - , ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds - } - go us' cmms ngs' (count + 1) - - -emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO () -emitNativeCode dflags h sdoc = do - - {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h - (mkCodeStyle AsmStyle) sdoc - - -- dump native code - dumpIfSet_dyn dflags - Opt_D_dump_asm "Asm code" - sdoc - --- | Complete native code generation phase for a single top-level chunk of Cmm. --- Dumping the output of each stage along the way. --- Global conflict graph and NGC stats -cmmNativeGen - :: forall statics instr jumpDest. (Instruction instr, - Outputable statics, Outputable instr, Outputable jumpDest) - => DynFlags - -> Module -> ModLocation - -> NcgImpl statics instr jumpDest - -> UniqSupply - -> DwarfFiles - -> LabelMap DebugBlock - -> RawCmmDecl -- ^ the cmm to generate code for - -> Int -- ^ sequence number of this top thing - -> IO ( UniqSupply - , DwarfFiles - , [NatCmmDecl statics instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats] -- stats for the linear register allocators - , LabelMap [UnwindPoint] -- unwinding information for blocks - ) - -cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count - = do - let platform = targetPlatform dflags - - let proc_name = case cmm of - (CmmProc _ entry_label _ _) -> ppr entry_label - _ -> text "DataChunk" - - -- rewrite assignments to global regs - let fixed_cmm = - {-# SCC "fixStgRegisters" #-} - fixStgRegisters dflags cmm - - -- cmm to cmm optimisations - let (opt_cmm, imports) = - {-# SCC "cmmToCmm" #-} - cmmToCmm dflags this_mod fixed_cmm - - dumpIfSet_dyn dflags - Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmmGroup [opt_cmm]) - - let cmmCfg = {-# SCC "getCFG" #-} - getCfgProc (cfgWeightInfo dflags) opt_cmm - - -- generate native code from cmm - let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) = - {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags this_mod modLoc - (cmmTopCodeGen ncgImpl) - fileIds dbgMap opt_cmm cmmCfg - - dumpIfSet_dyn dflags - Opt_D_dump_asm_native "Native code" - (vcat $ map (pprNatCmmDecl ncgImpl) native) - - maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name - - -- tag instructions with register liveness information - -- also drops dead code. We don't keep the cfg in sync on - -- some backends, so don't use it there. - let livenessCfg = if (backendMaintainsCfg dflags) - then Just nativeCfgWeights - else Nothing - let (withLiveness, usLive) = - {-# SCC "regLiveness" #-} - initUs usGen - $ mapM (cmmTopLiveness livenessCfg platform) native - - dumpIfSet_dyn dflags - Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map ppr withLiveness) - - -- allocate registers - (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <- - if ( gopt Opt_RegsGraph dflags - || gopt Opt_RegsIterative dflags ) - then do - -- the regs usable for allocation - let (alloc_regs :: UniqFM (UniqSet RealReg)) - = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) - emptyUFM - $ allocatableRegs ncgImpl - - -- do the graph coloring register allocation - let ((alloced, maybe_more_stack, regAllocStats), usAlloc) - = {-# SCC "RegAlloc-color" #-} - initUs usLive - $ Color.regAlloc - dflags - alloc_regs - (mkUniqSet [0 .. maxSpillSlots ncgImpl]) - (maxSpillSlots ncgImpl) - withLiveness - livenessCfg - - let ((alloced', stack_updt_blks), usAlloc') - = initUs usAlloc $ - case maybe_more_stack of - Nothing -> return (alloced, []) - Just amount -> do - (alloced',stack_updt_blks) <- unzip <$> - (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced) - return (alloced', concat stack_updt_blks ) - - - -- dump out what happened during register allocation - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc_stages "Build/spill stages" - (vcat $ map (\(stage, stats) - -> text "# --------------------------" - $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ ppr stats) - $ zip [0..] regAllocStats) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just regAllocStats else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced', usAlloc' - , mPprStats - , Nothing - , [], stack_updt_blks) - - else do - -- do linear register allocation - let reg_alloc proc = do - (alloced, maybe_more_stack, ra_stats) <- - Linear.regAlloc dflags proc - case maybe_more_stack of - Nothing -> return ( alloced, ra_stats, [] ) - Just amount -> do - (alloced',stack_updt_blks) <- - ncgAllocMoreStack ncgImpl amount alloced - return (alloced', ra_stats, stack_updt_blks ) - - let ((alloced, regAllocStats, stack_updt_blks), usAlloc) - = {-# SCC "RegAlloc-linear" #-} - initUs usLive - $ liftM unzip3 - $ mapM reg_alloc withLiveness - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just (catMaybes regAllocStats) else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced, usAlloc - , Nothing - , mPprStats, (catMaybes regAllocStats) - , concat stack_updt_blks ) - - -- Fixupblocks the register allocator inserted (from, regMoves, to) - let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)] - cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats) - - let cfgWithFixupBlks = - (\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg - - -- Insert stack update blocks - let postRegCFG = - pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m )) - <*> cfgWithFixupBlks - <*> pure stack_updt_blks - - ---- generate jump tables - let tabled = - {-# SCC "generateJumpTables" #-} - generateJumpTables ncgImpl alloced - - when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags - Opt_D_dump_cfg_weights "CFG Update information" - ( text "stack:" <+> ppr stack_updt_blks $$ - text "linearAlloc:" <+> ppr cfgRegAllocUpdates ) - - ---- shortcut branches - let (shorted, postShortCFG) = - {-# SCC "shortcutBranches" #-} - shortcutBranches dflags ncgImpl tabled postRegCFG - - let optimizedCFG :: Maybe CFG - optimizedCFG = - optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG - - maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name - - --TODO: Partially check validity of the cfg. - let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks - getBlks _ = [] - - when ( backendMaintainsCfg dflags && - (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do - let blocks = concatMap getBlks shorted - let labels = setFromList $ fmap blockId blocks :: LabelSet - let cfg = fromJust optimizedCFG - return $! seq (sanityCheckCfg cfg labels $ - text "cfg not in lockstep") () - - ---- sequence blocks - let sequenced :: [NatCmmDecl statics instr] - sequenced = - checkLayout shorted $ - {-# SCC "sequenceBlocks" #-} - map (BlockLayout.sequenceTop - dflags - ncgImpl optimizedCFG) - shorted - - let branchOpt :: [NatCmmDecl statics instr] - branchOpt = - {-# SCC "invertCondBranches" #-} - map invert sequenced - where - invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr] - -> [NatBasicBlock instr] - invertConds = invertCondBranches ncgImpl optimizedCFG - invert top@CmmData {} = top - invert (CmmProc info lbl live (ListGraph blocks)) = - CmmProc info lbl live (ListGraph $ invertConds info blocks) - - ---- expansion of SPARC synthetic instrs - let expanded = - {-# SCC "sparc_expand" #-} - ncgExpandTop ncgImpl branchOpt - --ncgExpandTop ncgImpl sequenced - - dumpIfSet_dyn dflags - Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (pprNatCmmDecl ncgImpl) expanded) - - -- generate unwinding information from cmm - let unwinds :: BlockMap [UnwindPoint] - unwinds = - {-# SCC "unwindingInfo" #-} - foldl' addUnwind mapEmpty expanded - where - addUnwind acc proc = - acc `mapUnion` computeUnwinding dflags ncgImpl proc - - return ( usAlloc - , fileIds' - , expanded - , lastMinuteImports ++ imports - , ppr_raStatsColor - , ppr_raStatsLinear - , unwinds ) - -maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO () -maybeDumpCfg _dflags Nothing _ _ = return () -maybeDumpCfg dflags (Just cfg) msg proc_name - | null cfg = return () - | otherwise - = dumpIfSet_dyn - dflags Opt_D_dump_cfg_weights msg - (proc_name <> char ':' $$ pprEdgeWeights cfg) - --- | Make sure all blocks we want the layout algorithm to place have been placed. -checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] - -> [NatCmmDecl statics instr] -checkLayout procsUnsequenced procsSequenced = - ASSERT2(setNull diff, - ppr "Block sequencing dropped blocks:" <> ppr diff) - procsSequenced - where - blocks1 = foldl' (setUnion) setEmpty $ - map getBlockIds procsUnsequenced :: LabelSet - blocks2 = foldl' (setUnion) setEmpty $ - map getBlockIds procsSequenced - diff = setDifference blocks1 blocks2 - - getBlockIds (CmmData _ _) = setEmpty - getBlockIds (CmmProc _ _ _ (ListGraph blocks)) = - setFromList $ map blockId blocks - --- | Compute unwinding tables for the blocks of a procedure -computeUnwinding :: Instruction instr - => DynFlags -> NcgImpl statics instr jumpDest - -> NatCmmDecl statics instr - -- ^ the native code generated for the procedure - -> LabelMap [UnwindPoint] - -- ^ unwinding tables for all points of all blocks of the - -- procedure -computeUnwinding dflags _ _ - | debugLevel dflags == 0 = mapEmpty -computeUnwinding _ _ (CmmData _ _) = mapEmpty -computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) = - -- In general we would need to push unwinding information down the - -- block-level call-graph to ensure that we fully account for all - -- relevant register writes within a procedure. - -- - -- However, the only unwinding information that we care about in GHC is for - -- Sp. The fact that CmmLayoutStack already ensures that we have unwind - -- information at the beginning of every block means that there is no need - -- to perform this sort of push-down. - mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs) - | BasicBlock blk_lbl instrs <- blks ] - --- | Build a doc for all the imports. --- -makeImportsDoc :: DynFlags -> [CLabel] -> SDoc -makeImportsDoc dflags imports - = dyld_stubs imports - $$ - -- On recent versions of Darwin, the linker supports - -- dead-stripping of code and data on a per-symbol basis. - -- There's a hack to make this work in PprMach.pprNatCmmDecl. - (if platformHasSubsectionsViaSymbols platform - then text ".subsections_via_symbols" - else Outputable.empty) - $$ - -- On recent GNU ELF systems one can mark an object file - -- as not requiring an executable stack. If all objects - -- linked into a program have this note then the program - -- will not use an executable stack, which is good for - -- security. GHC generated code does not need an executable - -- stack so add the note in: - (if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits" - else Outputable.empty) - $$ - -- And just because every other compiler does, let's stick in - -- an identifier directive: .ident "GHC x.y.z" - (if platformHasIdentDirective platform - then let compilerIdent = text "GHC" <+> text cProjectVersion - in text ".ident" <+> doubleQuotes compilerIdent - else Outputable.empty) - - where - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - - -- Generate "symbol stubs" for all external symbols that might - -- come from a dynamic library. - dyld_stubs :: [CLabel] -> SDoc -{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $ - map head $ group $ sort imps-} - -- (Hack) sometimes two Labels pretty-print the same, but have - -- different uniques; so we compare their text versions... - dyld_stubs imps - | needImportedSymbols dflags arch os - = vcat $ - (pprGotDeclaration dflags arch os :) $ - map ( pprImportedSymbol dflags platform . fst . head) $ - groupBy (\(_,a) (_,b) -> a == b) $ - sortBy (\(_,a) (_,b) -> compare a b) $ - map doPpr $ - imps - | otherwise - = Outputable.empty - - doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle) - astyle = mkCodeStyle AsmStyle - --- ----------------------------------------------------------------------------- --- Generate jump tables - --- Analyzes all native code and generates data sections for all jump --- table instructions. -generateJumpTables - :: NcgImpl statics instr jumpDest - -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] -generateJumpTables ncgImpl xs = concatMap f xs - where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs - f p = [p] - g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) - --- ----------------------------------------------------------------------------- --- Shortcut branches - -shortcutBranches - :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags - -> NcgImpl statics instr jumpDest - -> [NatCmmDecl statics instr] - -> Maybe CFG - -> ([NatCmmDecl statics instr],Maybe CFG) - -shortcutBranches dflags ncgImpl tops weights - | gopt Opt_AsmShortcutting dflags - = ( map (apply_mapping ncgImpl mapping) tops' - , shortcutWeightMap mappingBid <$!> weights ) - | otherwise - = (tops, weights) - where - (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops - mapping = mapUnions mappings :: LabelMap jumpDest - mappingBid = fmap (getJumpDestBlockId ncgImpl) mapping - -build_mapping :: forall instr t d statics jumpDest. - NcgImpl statics instr jumpDest - -> GenCmmDecl d (LabelMap t) (ListGraph instr) - -> (GenCmmDecl d (LabelMap t) (ListGraph instr) - ,LabelMap jumpDest) -build_mapping _ top@(CmmData _ _) = (top, mapEmpty) -build_mapping _ (CmmProc info lbl live (ListGraph [])) - = (CmmProc info lbl live (ListGraph []), mapEmpty) -build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) - = (CmmProc info lbl live (ListGraph (head:others)), mapping) - -- drop the shorted blocks, but don't ever drop the first one, - -- because it is pointed to by a global label. - where - -- find all the blocks that just consist of a jump that can be - -- shorted. - -- Don't completely eliminate loops here -- that can leave a dangling jump! - shortcut_blocks :: [(BlockId, jumpDest)] - (_, shortcut_blocks, others) = - foldl' split (setEmpty :: LabelSet, [], []) blocks - split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) - | Just jd <- canShortcut ncgImpl insn - , Just dest <- getJumpDestBlockId ncgImpl jd - , not (has_info id) - , (setMember dest s) || dest == id -- loop checks - = (s, shortcut_blocks, b : others) - split (s, shortcut_blocks, others) (BasicBlock id [insn]) - | Just dest <- canShortcut ncgImpl insn - , not (has_info id) - = (setInsert id s, (id,dest) : shortcut_blocks, others) - split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) - - -- do not eliminate blocks that have an info table - has_info l = mapMember l info - - -- build a mapping from BlockId to JumpDest for shorting branches - mapping = mapFromList shortcut_blocks - -apply_mapping :: NcgImpl statics instr jumpDest - -> LabelMap jumpDest - -> GenCmmDecl statics h (ListGraph instr) - -> GenCmmDecl statics h (ListGraph instr) -apply_mapping ncgImpl ufm (CmmData sec statics) - = CmmData sec (shortcutStatics ncgImpl (\bid -> mapLookup bid ufm) statics) -apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map short_bb blocks) - where - short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns - short_insn i = shortcutJump ncgImpl (\bid -> mapLookup bid ufm) i - -- shortcutJump should apply the mapping repeatedly, - -- just in case we can short multiple branches. - --- ----------------------------------------------------------------------------- --- Instruction selection - --- Native code instruction selection for a chunk of stix code. For --- this part of the computation, we switch from the UniqSM monad to --- the NatM monad. The latter carries not only a Unique, but also an --- Int denoting the current C stack pointer offset in the generated --- code; this is needed for creating correct spill offsets on --- architectures which don't offer, or for which it would be --- prohibitively expensive to employ, a frame pointer register. Viz, --- x86. - --- The offset is measured in bytes, and indicates the difference --- between the current (simulated) C stack-ptr and the value it was at --- the beginning of the block. For stacks which grow down, this value --- should be either zero or negative. - --- Along with the stack pointer offset, we also carry along a LabelMap of --- DebugBlocks, which we read to generate .location directives. --- --- Switching between the two monads whilst carrying along the same --- Unique supply breaks abstraction. Is that bad? - -genMachCode - :: DynFlags - -> Module -> ModLocation - -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) - -> DwarfFiles - -> LabelMap DebugBlock - -> RawCmmDecl - -> CFG - -> UniqSM - ( [NatCmmDecl statics instr] - , [CLabel] - , DwarfFiles - , CFG - ) - -genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg - = do { initial_us <- getUniqueSupplyM - ; let initial_st = mkNatM_State initial_us 0 dflags this_mod - modLoc fileIds dbgMap cmm_cfg - (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) - final_delta = natm_delta final_st - final_imports = natm_imports final_st - final_cfg = natm_cfg final_st - ; if final_delta == 0 - then return (new_tops, final_imports - , natm_fileid final_st, final_cfg) - else pprPanic "genMachCode: nonzero final delta" (int final_delta) - } - --- ----------------------------------------------------------------------------- --- Generic Cmm optimiser - -{- -Here we do: - - (a) Constant folding - (c) Position independent code and dynamic linking - (i) introduce the appropriate indirections - and position independent refs - (ii) compile a list of imported symbols - (d) Some arch-specific optimizations - -(a) will be moving to the new Hoopl pipeline, however, (c) and -(d) are only needed by the native backend and will continue to live -here. - -Ideas for other things we could do (put these in Hoopl please!): - - - shortcut jumps-to-jumps - - simple CSE: if an expr is assigned to a temp, then replace later occs of - that expr with the temp, until the expr is no longer valid (can push through - temp assignments, and certain assigns to mem...) --} - -cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) -cmmToCmm _ _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags this_mod (CmmProc info lbl live graph) - = runCmmOpt dflags this_mod $ - do blocks' <- mapM cmmBlockConFold (toBlockList graph) - return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') - --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - -type OptMResult a = (# a, [CLabel] #) - -pattern OptMResult :: a -> b -> (# a, b #) -pattern OptMResult x y = (# x, y #) -{-# COMPLETE OptMResult #-} -#else - -data OptMResult a = OptMResult !a ![CLabel] deriving (Functor) -#endif - -newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a) - deriving (Functor) - -instance Applicative CmmOptM where - pure x = CmmOptM $ \_ _ imports -> OptMResult x imports - (<*>) = ap - -instance Monad CmmOptM where - (CmmOptM f) >>= g = - CmmOptM $ \dflags this_mod imports0 -> - case f dflags this_mod imports0 of - OptMResult x imports1 -> - case g x of - CmmOptM g' -> g' dflags this_mod imports1 - -instance CmmMakeDynamicReferenceM CmmOptM where - addImport = addImportCmmOpt - getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports - -addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports) - -instance HasDynFlags CmmOptM where - getDynFlags = CmmOptM $ \dflags _ imports -> OptMResult dflags imports - -runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel]) -runCmmOpt dflags this_mod (CmmOptM f) = - case f dflags this_mod [] of - OptMResult result imports -> (result, imports) - -cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock -cmmBlockConFold block = do - let (entry, middle, last) = blockSplit block - stmts = blockToList middle - stmts' <- mapM cmmStmtConFold stmts - last' <- cmmStmtConFold last - return $ blockJoin entry (blockFromList stmts') last' - --- This does three optimizations, but they're very quick to check, so we don't --- bother turning them off even when the Hoopl code is active. Since --- this is on the old Cmm representation, we can't reuse the code either: --- * reg = reg --> nop --- * if 0 then jump --> nop --- * if 1 then jump --> jump --- We might be tempted to skip this step entirely of not Opt_PIC, but --- there is some PowerPC code for the non-PIC case, which would also --- have to be separated. -cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) -cmmStmtConFold stmt - = case stmt of - CmmAssign reg src - -> do src' <- cmmExprConFold DataReference src - return $ case src' of - CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") - new_src -> CmmAssign reg new_src - - CmmStore addr src - -> do addr' <- cmmExprConFold DataReference addr - src' <- cmmExprConFold DataReference src - return $ CmmStore addr' src' - - CmmCall { cml_target = addr } - -> do addr' <- cmmExprConFold JumpReference addr - return $ stmt { cml_target = addr' } - - CmmUnsafeForeignCall target regs args - -> do target' <- case target of - ForeignTarget e conv -> do - e' <- cmmExprConFold CallReference e - return $ ForeignTarget e' conv - PrimTarget _ -> - return target - args' <- mapM (cmmExprConFold DataReference) args - return $ CmmUnsafeForeignCall target' regs args' - - CmmCondBranch test true false likely - -> do test' <- cmmExprConFold DataReference test - return $ case test' of - CmmLit (CmmInt 0 _) -> CmmBranch false - CmmLit (CmmInt _ _) -> CmmBranch true - _other -> CmmCondBranch test' true false likely - - CmmSwitch expr ids - -> do expr' <- cmmExprConFold DataReference expr - return $ CmmSwitch expr' ids - - other - -> return other - -cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprConFold referenceKind expr = do - dflags <- getDynFlags - - -- With -O1 and greater, the cmmSink pass does constant-folding, so - -- we don't need to do it again here. - let expr' = if optLevel dflags >= 1 - then expr - else cmmExprCon dflags expr - - cmmExprNative referenceKind expr' - -cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr -cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep -cmmExprCon dflags (CmmMachOp mop args) - = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args) -cmmExprCon _ other = other - --- handles both PIC and non-PIC cases... a very strange mixture --- of things to do. -cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprNative referenceKind expr = do - dflags <- getDynFlags - let platform = targetPlatform dflags - arch = platformArch platform - case expr of - CmmLoad addr rep - -> do addr' <- cmmExprNative DataReference addr - return $ CmmLoad addr' rep - - CmmMachOp mop args - -> do args' <- mapM (cmmExprNative DataReference) args - return $ CmmMachOp mop args' - - CmmLit (CmmBlock id) - -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) - -- we must convert block Ids to CLabels here, because we - -- might have to do the PIC transformation. Hence we must - -- not modify BlockIds beyond this point. - - CmmLit (CmmLabel lbl) - -> do - cmmMakeDynamicReference dflags referenceKind lbl - CmmLit (CmmLabelOff lbl off) - -> do - dynRef <- cmmMakeDynamicReference dflags referenceKind lbl - -- need to optimize here, since it's late - return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [ - dynRef, - (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags)) - ] - - -- On powerpc (non-PIC), it's easier to jump directly to a label than - -- to use the register table, so we replace these registers - -- with the corresponding labels: - CmmReg (CmmGlobal EagerBlackholeInfo) - | arch == ArchPPC && not (positionIndependent dflags) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) - CmmReg (CmmGlobal GCEnter1) - | arch == ArchPPC && not (positionIndependent dflags) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) - CmmReg (CmmGlobal GCFun) - | arch == ArchPPC && not (positionIndependent dflags) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) - - other - -> return other diff --git a/nativeGen/BlockLayout.hs b/nativeGen/BlockLayout.hs deleted file mode 100644 --- a/nativeGen/BlockLayout.hs +++ /dev/null @@ -1,945 +0,0 @@ --- --- Copyright (c) 2018 Andreas Klebinger --- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} - -module BlockLayout - ( sequenceTop ) -where - -#include "HsVersions.h" -import GhcPrelude - -import Instruction -import NCGMonad -import CFG - -import BlockId -import Cmm -import Hoopl.Collections -import Hoopl.Label - -import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg) -import UniqFM -import Util -import Unique - -import Digraph -import Outputable -import Maybes - --- DEBUGGING ONLY ---import Debug ---import Debug.Trace -import ListSetOps (removeDups) - -import OrdList -import Data.List -import Data.Foldable (toList) - -import qualified Data.Set as Set -import Data.STRef -import Control.Monad.ST.Strict -import Control.Monad (foldM) - -{- - Note [CFG based code layout] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - The major steps in placing blocks are as follow: - * Compute a CFG based on the Cmm AST, see getCfgProc. - This CFG will have edge weights representing a guess - on how important they are. - * After we convert Cmm to Asm we run `optimizeCFG` which - adds a few more "educated guesses" to the equation. - * Then we run loop analysis on the CFG (`loopInfo`) which tells us - about loop headers, loop nesting levels and the sort. - * Based on the CFG and loop information refine the edge weights - in the CFG and normalize them relative to the most often visited - node. (See `mkGlobalWeights`) - * Feed this CFG into the block layout code (`sequenceTop`) in this - module. Which will then produce a code layout based on the input weights. - - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~ Note [Chain based CFG serialization] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - For additional information also look at - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout - - We have a CFG with edge weights based on which we try to place blocks next to - each other. - - Edge weights not only represent likelyhood of control transfer between blocks - but also how much a block would benefit from being placed sequentially after - it's predecessor. - For example blocks which are preceeded by an info table are more likely to end - up in a different cache line than their predecessor and we can't eliminate the jump - so there is less benefit to placing them sequentially. - - For example consider this example: - - A: ... - jmp cond D (weak successor) - jmp B - B: ... - jmp C - C: ... - jmp X - D: ... - jmp B (weak successor) - - We determine a block layout by building up chunks (calling them chains) of - possible control flows for which blocks will be placed sequentially. - - Eg for our example we might end up with two chains like: - [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially. - However there is no particular order in which chains are placed since - (hopefully) the blocks for which sequentiality is important have already - been placed in the same chain. - - ----------------------------------------------------------------------------- - 1) First try to create a list of good chains. - ----------------------------------------------------------------------------- - - Good chains are these which allow us to eliminate jump instructions. - Which further eliminate often executed jumps first. - - We do so by: - - *) Ignore edges which represent instructions which can not be replaced - by fall through control flow. Primarily calls and edges to blocks which - are prefixed by a info table we have to jump across. - - *) Then process remaining edges in order of frequency taken and: - - +) If source and target have not been placed build a new chain from them. - - +) If source and target have been placed, and are ends of differing chains - try to merge the two chains. - - +) If one side of the edge is a end/front of a chain, add the other block of - to edge to the same chain - - Eg if we look at edge (B -> C) and already have the chain (A -> B) - then we extend the chain to (A -> B -> C). - - +) If the edge was used to modify or build a new chain remove the edge from - our working list. - - *) If there any blocks not being placed into a chain after these steps we place - them into a chain consisting of only this block. - - Ranking edges by their taken frequency, if - two edges compete for fall through on the same target block, the one taken - more often will automatically win out. Resulting in fewer instructions being - executed. - - Creating singleton chains is required for situations where we have code of the - form: - - A: goto B: - - B: goto C: - - C: ... - - As the code in block B is only connected to the rest of the program via edges - which will be ignored in this step we make sure that B still ends up in a chain - this way. - - ----------------------------------------------------------------------------- - 2) We also try to fuse chains. - ----------------------------------------------------------------------------- - - As a result from the above step we still end up with multiple chains which - represent sequential control flow chunks. But they are not yet suitable for - code layout as we need to place *all* blocks into a single sequence. - - In this step we combine chains result from the above step via these steps: - - *) Look at the ranked list of *all* edges, including calls/jumps across info tables - and the like. - - *) Look at each edge and - - +) Given an edge (A -> B) try to find two chains for which - * Block A is at the end of one chain - * Block B is at the front of the other chain. - +) If we find such a chain we "fuse" them into a single chain, remove the - edge from working set and continue. - +) If we can't find such chains we skip the edge and continue. - - ----------------------------------------------------------------------------- - 3) Place indirect successors (neighbours) after each other - ----------------------------------------------------------------------------- - - We might have chains [A,B,C,X],[E] in a CFG of the sort: - - A ---> B ---> C --------> X(exit) - \- ->E- -/ - - While E does not follow X it's still beneficial to place them near each other. - This can be advantageous if eg C,X,E will end up in the same cache line. - - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~ Note [Triangle Control Flow] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Checking if an argument is already evaluated leads to a somewhat - special case which looks like this: - - A: - if (R1 & 7 != 0) goto Leval; else goto Lwork; - Leval: // global - call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8; - Lwork: // global - ... - - A - |\ - | Leval - |/ - (This edge can be missing because of optimizations) - Lwork - - Once we hit the metal the call instruction is just 2-3 bytes large - depending on the register used. So we lay out the assembly like this: - - movq %rbx,%rax - andl $7,%eax - cmpq $1,%rax - jne Lwork - Leval: - jmp *(%rbx) # encoded in 2-3 bytes. - - Lwork: - ... - - We could explicitly check for this control flow pattern. - - This is advantageous because: - * It's optimal if the argument isn't evaluated. - * If it's evaluated we only have the extra cost of jumping over - the 2-3 bytes for the call. - * Guarantees the smaller encoding for the conditional jump. - - However given that Lwork usually has an info table we - penalize this edge. So Leval should get placed first - either way and things work out for the best. - - Optimizing for the evaluated case instead would penalize - the other code path. It adds an jump as we can't fall through - to Lwork because of the info table. - Assuming that Lwork is large the chance that the "call" ends up - in the same cache line is also fairly small. - - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~ Note [Layout relevant edge weights] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - The input to the chain based code layout algorithm is a CFG - with edges annotated with their frequency. The frequency - of traversal corresponds quite well to the cost of not placing - the connected blocks next to each other. - - However even if having the same frequency certain edges are - inherently more or less relevant to code layout. - - In particular: - - * Edges which cross an info table are less relevant than others. - - If we place the blocks across this edge next to each other - they are still separated by the info table which negates - much of the benefit. It makes it less likely both blocks - will share a cache line reducing the benefits from locality. - But it also prevents us from eliminating jump instructions. - - * Conditional branches and switches are slightly less relevant. - - We can completely remove unconditional jumps by placing them - next to each other. This is not true for conditional branch edges. - We apply a small modifier to them to ensure edges for which we can - eliminate the overhead completely are considered first. See also #18053. - - * Edges constituted by a call are ignored. - - Considering these hardly helped with performance and ignoring - them helps quite a bit to improve compiler performance. - - So we perform a preprocessing step where we apply a multiplicator - to these kinds of edges. - - -} - - --- | Look at X number of blocks in two chains to determine --- if they are "neighbours". -neighbourOverlapp :: Int -neighbourOverlapp = 2 - --- | Maps blocks near the end of a chain to it's chain AND --- the other blocks near the end. --- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E])) --- where [A,B] are blocks in the end region of a chain. --- This is cheaper then recomputing the ends multiple times. -type FrontierMap = LabelMap ([BlockId],BlockChain) - --- | A non empty ordered sequence of basic blocks. --- It is suitable for serialization in this order. --- --- We use OrdList instead of [] to allow fast append on both sides --- when combining chains. -newtype BlockChain - = BlockChain { chainBlocks :: (OrdList BlockId) } - --- All chains are constructed the same way so comparison --- including structure is faster. -instance Eq BlockChain where - BlockChain b1 == BlockChain b2 = strictlyEqOL b1 b2 - --- Useful for things like sets and debugging purposes, sorts by blocks --- in the chain. -instance Ord (BlockChain) where - (BlockChain lbls1) `compare` (BlockChain lbls2) - = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) - strictlyOrdOL lbls1 lbls2 - -instance Outputable (BlockChain) where - ppr (BlockChain blks) = - parens (text "Chain:" <+> ppr (fromOL $ blks) ) - -chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b -chainFoldl f z (BlockChain blocks) = foldl' f z blocks - -noDups :: [BlockChain] -> Bool -noDups chains = - let chainBlocks = concatMap chainToBlocks chains :: [BlockId] - (_blocks, dups) = removeDups compare chainBlocks - in if null dups then True - else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False - -inFront :: BlockId -> BlockChain -> Bool -inFront bid (BlockChain seq) - = headOL seq == bid - -chainSingleton :: BlockId -> BlockChain -chainSingleton lbl - = BlockChain (unitOL lbl) - -chainFromList :: [BlockId] -> BlockChain -chainFromList = BlockChain . toOL - -chainSnoc :: BlockChain -> BlockId -> BlockChain -chainSnoc (BlockChain blks) lbl - = BlockChain (blks `snocOL` lbl) - -chainCons :: BlockId -> BlockChain -> BlockChain -chainCons lbl (BlockChain blks) - = BlockChain (lbl `consOL` blks) - -chainConcat :: BlockChain -> BlockChain -> BlockChain -chainConcat (BlockChain blks1) (BlockChain blks2) - = BlockChain (blks1 `appOL` blks2) - -chainToBlocks :: BlockChain -> [BlockId] -chainToBlocks (BlockChain blks) = fromOL blks - --- | Given the Chain A -> B -> C -> D and we break at C --- we get the two Chains (A -> B, C -> D) as result. -breakChainAt :: BlockId -> BlockChain - -> (BlockChain,BlockChain) -breakChainAt bid (BlockChain blks) - | not (bid == head rblks) - = panic "Block not in chain" - | otherwise - = (BlockChain (toOL lblks), - BlockChain (toOL rblks)) - where - (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks) - -takeR :: Int -> BlockChain -> [BlockId] -takeR n (BlockChain blks) = - take n . fromOLReverse $ blks - -takeL :: Int -> BlockChain -> [BlockId] -takeL n (BlockChain blks) = - take n . fromOL $ blks - --- Note [Combining neighborhood chains] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- See also Note [Chain based CFG serialization] --- We have the chains (A-B-C-D) and (E-F) and an Edge C->E. --- --- While placing the latter after the former doesn't result in sequential --- control flow it is still benefical. As block C and E might end --- up in the same cache line. --- --- So we place these chains next to each other even if we can't fuse them. --- --- A -> B -> C -> D --- v --- - -> E -> F ... --- --- A simple heuristic to chose which chains we want to combine: --- * Process edges in descending priority. --- * Check if there is a edge near the end of one chain which goes --- to a block near the start of another edge. --- --- While we could take into account the space between the two blocks which --- share an edge this blows up compile times quite a bit. It requires --- us to find all edges between two chains, check the distance for all edges, --- rank them based on the distance and and only then we can select two chains --- to combine. Which would add a lot of complexity for little gain. --- --- So instead we just rank by the strength of the edge and use the first pair we --- find. - --- | For a given list of chains and edges try to combine chains with strong --- edges between them. -combineNeighbourhood :: [CfgEdge] -- ^ Edges to consider - -> [BlockChain] -- ^ Current chains of blocks - -> ([BlockChain], Set.Set (BlockId,BlockId)) - -- ^ Resulting list of block chains, and a set of edges which - -- were used to fuse chains and as such no longer need to be - -- considered. -combineNeighbourhood edges chains - = -- pprTraceIt "Neigbours" $ - -- pprTrace "combineNeighbours" (ppr edges) $ - applyEdges edges endFrontier startFrontier (Set.empty) - where - --Build maps from chain ends to chains - endFrontier, startFrontier :: FrontierMap - endFrontier = - mapFromList $ concatMap (\chain -> - let ends = getEnds chain :: [BlockId] - entry = (ends,chain) - in map (\x -> (x,entry)) ends ) chains - startFrontier = - mapFromList $ concatMap (\chain -> - let front = getFronts chain - entry = (front,chain) - in map (\x -> (x,entry)) front) chains - applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId) - -> ([BlockChain], Set.Set (BlockId,BlockId)) - applyEdges [] chainEnds _chainFronts combined = - (ordNub $ map snd $ mapElems chainEnds, combined) - applyEdges ((CfgEdge from to _w):edges) chainEnds chainFronts combined - | Just (c1_e,c1) <- mapLookup from chainEnds - , Just (c2_f,c2) <- mapLookup to chainFronts - , c1 /= c2 -- Avoid trying to concat a chain with itself. - = let newChain = chainConcat c1 c2 - newChainFrontier = getFronts newChain - newChainEnds = getEnds newChain - newFronts :: FrontierMap - newFronts = - let withoutOld = - foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1) - entry = - (newChainFrontier,newChain) --let bound to ensure sharing - in foldl' (\m x -> mapInsert x entry m) - withoutOld newChainFrontier - - newEnds = - let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2) - entry = (newChainEnds,newChain) --let bound to ensure sharing - in foldl' (\m x -> mapInsert x entry m) - withoutOld newChainEnds - in - -- pprTrace "ApplyEdges" - -- (text "before" $$ - -- text "fronts" <+> ppr chainFronts $$ - -- text "ends" <+> ppr chainEnds $$ - - -- text "various" $$ - -- text "newChain" <+> ppr newChain $$ - -- text "newChainFrontier" <+> ppr newChainFrontier $$ - -- text "newChainEnds" <+> ppr newChainEnds $$ - -- text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$ - - -- text "after" $$ - -- text "fronts" <+> ppr newFronts $$ - -- text "ends" <+> ppr newEnds - -- ) - applyEdges edges newEnds newFronts (Set.insert (from,to) combined) - | otherwise - = applyEdges edges chainEnds chainFronts combined - where - - getFronts chain = takeL neighbourOverlapp chain - getEnds chain = takeR neighbourOverlapp chain - --- In the last stop we combine all chains into a single one. --- Trying to place chains with strong edges next to each other. -mergeChains :: [CfgEdge] -> [BlockChain] - -> (BlockChain) -mergeChains edges chains - = -- pprTrace "combine" (ppr edges) $ - runST $ do - let addChain m0 chain = do - ref <- newSTRef chain - return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain - chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains - merge edges chainMap' - where - -- We keep a map from ALL blocks to their respective chain (sigh) - -- This is required since when looking at an edge we need to find - -- the associated chains quickly. - -- We use a map of STRefs, maintaining a invariant of one STRef per chain. - -- When merging chains we can update the - -- STRef of one chain once (instead of writing to the map for each block). - -- We then overwrite the STRefs for the other chain so there is again only - -- a single STRef for the combined chain. - -- The difference in terms of allocations saved is ~0.2% with -O so actually - -- significant compared to using a regular map. - - merge :: forall s. [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain - merge [] chains = do - chains' <- ordNub <$> (mapM readSTRef $ mapElems chains) :: ST s [BlockChain] - return $ foldl' chainConcat (head chains') (tail chains') - merge ((CfgEdge from to _):edges) chains - -- | pprTrace "merge" (ppr (from,to) <> ppr chains) False - -- = undefined - | cFrom == cTo - = merge edges chains - | otherwise - = do - chains' <- mergeComb cFrom cTo - merge edges chains' - where - mergeComb :: STRef s BlockChain -> STRef s BlockChain -> ST s (LabelMap (STRef s BlockChain)) - mergeComb refFrom refTo = do - cRight <- readSTRef refTo - chain <- pure chainConcat <*> readSTRef refFrom <*> pure cRight - writeSTRef refFrom chain - return $ chainFoldl (\m b -> mapInsert b refFrom m) chains cRight - - cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains - cTo = expectJust "mergeChains:chainMap:to" $ mapLookup to chains - - --- See Note [Chain based CFG serialization] for the general idea. --- This creates and fuses chains at the same time for performance reasons. - --- Try to build chains from a list of edges. --- Edges must be sorted **descending** by their priority. --- Returns the constructed chains, along with all edges which --- are irrelevant past this point, this information doesn't need --- to be complete - it's only used to speed up the process. --- An Edge is irrelevant if the ends are part of the same chain. --- We say these edges are already linked -buildChains :: [CfgEdge] -> [BlockId] - -> ( LabelMap BlockChain -- Resulting chains, indexd by end if chain. - , Set.Set (BlockId, BlockId)) --List of fused edges. -buildChains edges blocks - = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty - where - -- buildNext builds up chains from edges one at a time. - - -- We keep a map from the ends of chains to the chains. - -- This we we can easily check if an block should be appended to an - -- existing chain! - -- We store them using STRefs so we don't have to rebuild the spine of both - -- maps every time we update a chain. - buildNext :: forall s. LabelSet - -> LabelMap (STRef s BlockChain) -- Map from end of chain to chain. - -> LabelMap (STRef s BlockChain) -- Map from start of chain to chain. - -> [CfgEdge] -- Edges to check - ordered by decreasing weight - -> Set.Set (BlockId, BlockId) -- Used edges - -> ST s ( LabelMap BlockChain -- Chains by end - , Set.Set (BlockId, BlockId) --List of fused edges - ) - buildNext placed _chainStarts chainEnds [] linked = do - ends' <- sequence $ mapMap readSTRef chainEnds :: ST s (LabelMap BlockChain) - -- Any remaining blocks have to be made to singleton chains. - -- They might be combined with other chains later on outside this function. - let unplaced = filter (\x -> not (setMember x placed)) blocks - singletons = map (\x -> (x,chainSingleton x)) unplaced :: [(BlockId,BlockChain)] - return (foldl' (\m (k,v) -> mapInsert k v m) ends' singletons , linked) - buildNext placed chainStarts chainEnds (edge:todo) linked - | from == to - -- We skip self edges - = buildNext placed chainStarts chainEnds todo (Set.insert (from,to) linked) - | not (alreadyPlaced from) && - not (alreadyPlaced to) - = do - --pprTraceM "Edge-Chain:" (ppr edge) - chain' <- newSTRef $ chainFromList [from,to] - buildNext - (setInsert to (setInsert from placed)) - (mapInsert from chain' chainStarts) - (mapInsert to chain' chainEnds) - todo - (Set.insert (from,to) linked) - - | (alreadyPlaced from) && - (alreadyPlaced to) - , Just predChain <- mapLookup from chainEnds - , Just succChain <- mapLookup to chainStarts - , predChain /= succChain -- Otherwise we try to create a cycle. - = do - -- pprTraceM "Fusing edge" (ppr edge) - fuseChain predChain succChain - - | (alreadyPlaced from) && - (alreadyPlaced to) - = --pprTraceM "Skipping:" (ppr edge) >> - buildNext placed chainStarts chainEnds todo linked - - | otherwise - = do -- pprTraceM "Finding chain for:" (ppr edge $$ - -- text "placed" <+> ppr placed) - findChain - where - from = edgeFrom edge - to = edgeTo edge - alreadyPlaced blkId = (setMember blkId placed) - - -- Combine two chains into a single one. - fuseChain :: STRef s BlockChain -> STRef s BlockChain - -> ST s ( LabelMap BlockChain -- Chains by end - , Set.Set (BlockId, BlockId) --List of fused edges - ) - fuseChain fromRef toRef = do - fromChain <- readSTRef fromRef - toChain <- readSTRef toRef - let newChain = chainConcat fromChain toChain - ref <- newSTRef newChain - let start = head $ takeL 1 newChain - let end = head $ takeR 1 newChain - -- chains <- sequence $ mapMap readSTRef chainStarts - -- pprTraceM "pre-fuse chains:" $ ppr chains - buildNext - placed - (mapInsert start ref $ mapDelete to $ chainStarts) - (mapInsert end ref $ mapDelete from $ chainEnds) - todo - (Set.insert (from,to) linked) - - - --Add the block to a existing chain or creates a new chain - findChain :: ST s ( LabelMap BlockChain -- Chains by end - , Set.Set (BlockId, BlockId) --List of fused edges - ) - findChain - -- We can attach the block to the end of a chain - | alreadyPlaced from - , Just predChain <- mapLookup from chainEnds - = do - chain <- readSTRef predChain - let newChain = chainSnoc chain to - writeSTRef predChain newChain - let chainEnds' = mapInsert to predChain $ mapDelete from chainEnds - -- chains <- sequence $ mapMap readSTRef chainStarts - -- pprTraceM "from chains:" $ ppr chains - buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked) - -- We can attack it to the front of a chain - | alreadyPlaced to - , Just succChain <- mapLookup to chainStarts - = do - chain <- readSTRef succChain - let newChain = from `chainCons` chain - writeSTRef succChain newChain - let chainStarts' = mapInsert from succChain $ mapDelete to chainStarts - -- chains <- sequence $ mapMap readSTRef chainStarts' - -- pprTraceM "to chains:" $ ppr chains - buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked) - -- The placed end of the edge is part of a chain already and not an end. - | otherwise - = do - let block = if alreadyPlaced to then from else to - --pprTraceM "Singleton" $ ppr block - let newChain = chainSingleton block - ref <- newSTRef newChain - buildNext (setInsert block placed) (mapInsert block ref chainStarts) - (mapInsert block ref chainEnds) todo (linked) - where - alreadyPlaced blkId = (setMember blkId placed) - --- | Place basic blocks based on the given CFG. --- See Note [Chain based CFG serialization] -sequenceChain :: forall a i. (Instruction i, Outputable i) - => LabelMap a -- ^ Keys indicate an info table on the block. - -> CFG -- ^ Control flow graph and some meta data. - -> [GenBasicBlock i] -- ^ List of basic blocks to be placed. - -> [GenBasicBlock i] -- ^ Blocks placed in sequence. -sequenceChain _info _weights [] = [] -sequenceChain _info _weights [x] = [x] -sequenceChain info weights' blocks@((BasicBlock entry _):_) = - let weights :: CFG - weights = --pprTrace "cfg'" (pprEdgeWeights cfg') - cfg' - where - (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-} mkGlobalWeights entry weights' - cfg' = {-# SCC rewriteEdges #-} - mapFoldlWithKey - (\cfg from m -> - mapFoldlWithKey - (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to ) - cfg m ) - weights' - globalEdgeWeights - - directEdges :: [CfgEdge] - directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights) - where - -- Apply modifiers to turn edge frequencies into useable weights - -- for computing code layout. - -- See also Note [Layout relevant edge weights] - relevantWeight :: CfgEdge -> Maybe CfgEdge - relevantWeight edge@(CfgEdge from to edgeInfo) - | (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo - -- Ignore edges across calls. - = Nothing - | mapMember to info - , w <- edgeWeight edgeInfo - -- The payoff is quite small if we jump over an info table - = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 }) - | (EdgeInfo CmmSource { trans_cmmNode = exitNode } _) <- edgeInfo - , cantEliminate exitNode - , w <- edgeWeight edgeInfo - -- A small penalty to edge types which - -- we can't optimize away by layout. - -- w * 0.96875 == w - w/32 - = Just (CfgEdge from to edgeInfo { edgeWeight = w * 0.96875 }) - | otherwise - = Just edge - where - cantEliminate CmmCondBranch {} = True - cantEliminate CmmSwitch {} = True - cantEliminate _ = False - - blockMap :: LabelMap (GenBasicBlock i) - blockMap - = foldl' (\m blk@(BasicBlock lbl _ins) -> - mapInsert lbl blk m) - mapEmpty blocks - - (builtChains, builtEdges) - = {-# SCC "buildChains" #-} - --pprTraceIt "generatedChains" $ - --pprTrace "blocks" (ppr (mapKeys blockMap)) $ - buildChains directEdges (mapKeys blockMap) - - rankedEdges :: [CfgEdge] - -- Sort descending by weight, remove fused edges - rankedEdges = - filter (\edge -> not (Set.member (edgeFrom edge,edgeTo edge) builtEdges)) $ - directEdges - - (neighbourChains, combined) - = ASSERT(noDups $ mapElems builtChains) - {-# SCC "groupNeighbourChains" #-} - -- pprTraceIt "NeighbourChains" $ - combineNeighbourhood rankedEdges (mapElems builtChains) - - - allEdges :: [CfgEdge] - allEdges = {-# SCC allEdges #-} - sortOn (relevantWeight) $ filter (not . deadEdge) $ (infoEdgeList weights) - where - deadEdge :: CfgEdge -> Bool - deadEdge (CfgEdge from to _) = let e = (from,to) in Set.member e combined || Set.member e builtEdges - relevantWeight :: CfgEdge -> EdgeWeight - relevantWeight (CfgEdge _ _ edgeInfo) - | EdgeInfo (CmmSource { trans_cmmNode = CmmCall {}}) _ <- edgeInfo - -- Penalize edges across calls - = weight/(64.0) - | otherwise - = weight - where - -- negate to sort descending - weight = negate (edgeWeight edgeInfo) - - masterChain = - {-# SCC "mergeChains" #-} - -- pprTraceIt "MergedChains" $ - mergeChains allEdges neighbourChains - - --Make sure the first block stays first - prepedChains - | inFront entry masterChain - = [masterChain] - | (rest,entry) <- breakChainAt entry masterChain - = [entry,rest] - | otherwise = pprPanic "Entry point eliminated" $ - ppr masterChain - - blockList - = ASSERT(noDups [masterChain]) - (concatMap fromOL $ map chainBlocks prepedChains) - - --chainPlaced = setFromList $ map blockId blockList :: LabelSet - chainPlaced = setFromList $ blockList :: LabelSet - unplaced = - let blocks = mapKeys blockMap - isPlaced b = setMember (b) chainPlaced - in filter (\block -> not (isPlaced block)) blocks - - placedBlocks = - -- We want debug builds to catch this as it's a good indicator for - -- issues with CFG invariants. But we don't want to blow up production - -- builds if something slips through. - ASSERT(null unplaced) - --pprTraceIt "placedBlocks" $ - -- ++ [] is stil kinda expensive - if null unplaced then blockList else blockList ++ unplaced - getBlock bid = expectJust "Block placment" $ mapLookup bid blockMap - in - --Assert we placed all blocks given as input - ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks) - dropJumps info $ map getBlock placedBlocks - -{-# SCC dropJumps #-} --- | Remove redundant jumps between blocks when we can rely on --- fall through. -dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i] - -> [GenBasicBlock i] -dropJumps _ [] = [] -dropJumps info ((BasicBlock lbl ins):todo) - | not . null $ ins --This can happen because of shortcutting - , [dest] <- jumpDestsOfInstr (last ins) - , ((BasicBlock nextLbl _) : _) <- todo - , not (mapMember dest info) - , nextLbl == dest - = BasicBlock lbl (init ins) : dropJumps info todo - | otherwise - = BasicBlock lbl ins : dropJumps info todo - - --- ----------------------------------------------------------------------------- --- Sequencing the basic blocks - --- Cmm BasicBlocks are self-contained entities: they always end in a --- jump, either non-local or to another basic block in the same proc. --- In this phase, we attempt to place the basic blocks in a sequence --- such that as many of the local jumps as possible turn into --- fallthroughs. - -sequenceTop - :: (Instruction instr, Outputable instr) - => DynFlags -- Determine which layout algo to use - -> NcgImpl statics instr jumpDest - -> Maybe CFG -- ^ CFG if we have one. - -> NatCmmDecl statics instr -- ^ Function to serialize - -> NatCmmDecl statics instr - -sequenceTop _ _ _ top@(CmmData _ _) = top -sequenceTop dflags ncgImpl edgeWeights - (CmmProc info lbl live (ListGraph blocks)) - | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags - --Use chain based algorithm - , Just cfg <- edgeWeights - = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $ - {-# SCC layoutBlocks #-} - sequenceChain info cfg blocks ) - | otherwise - --Use old algorithm - = let cfg = if dontUseCfg then Nothing else edgeWeights - in CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $ - {-# SCC layoutBlocks #-} - sequenceBlocks cfg info blocks) - where - dontUseCfg = gopt Opt_WeightlessBlocklayout dflags || - (not $ backendMaintainsCfg dflags) - --- The old algorithm: --- It is very simple (and stupid): We make a graph out of --- the blocks where there is an edge from one block to another iff the --- first block ends by jumping to the second. Then we topologically --- sort this graph. Then traverse the list: for each block, we first --- output the block, then if it has an out edge, we move the --- destination of the out edge to the front of the list, and continue. - --- FYI, the classic layout for basic blocks uses postorder DFS; this --- algorithm is implemented in Hoopl. - -sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a - -> [GenBasicBlock inst] -> [GenBasicBlock inst] -sequenceBlocks _edgeWeight _ [] = [] -sequenceBlocks edgeWeights infos (entry:blocks) = - let entryNode = mkNode edgeWeights entry - bodyNodes = reverse - (flattenSCCs (sccBlocks edgeWeights blocks)) - in dropJumps infos . seqBlocks infos $ ( entryNode : bodyNodes) - -- the first block is the entry point ==> it must remain at the start. - -sccBlocks - :: Instruction instr - => Maybe CFG -> [NatBasicBlock instr] - -> [SCC (Node BlockId (NatBasicBlock instr))] -sccBlocks edgeWeights blocks = - stronglyConnCompFromEdgedVerticesUniqR - (map (mkNode edgeWeights) blocks) - -mkNode :: (Instruction t) - => Maybe CFG -> GenBasicBlock t - -> Node BlockId (GenBasicBlock t) -mkNode edgeWeights block@(BasicBlock id instrs) = - DigraphNode block id outEdges - where - outEdges :: [BlockId] - outEdges - --Select the heaviest successor, ignore weights <= zero - = successor - where - successor - | Just successors <- fmap (`getSuccEdgesSorted` id) - edgeWeights -- :: Maybe [(Label, EdgeInfo)] - = case successors of - [] -> [] - ((target,info):_) - | length successors > 2 || edgeWeight info <= 0 -> [] - | otherwise -> [target] - | otherwise - = case jumpDestsOfInstr (last instrs) of - [one] -> [one] - _many -> [] - - -seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)] - -> [GenBasicBlock t1] -seqBlocks infos blocks = placeNext pullable0 todo0 - where - -- pullable: Blocks that are not yet placed - -- todo: Original order of blocks, to be followed if we have no good - -- reason not to; - -- may include blocks that have already been placed, but then - -- these are not in pullable - pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ] - todo0 = map node_key blocks - - placeNext _ [] = [] - placeNext pullable (i:rest) - | Just (block, pullable') <- lookupDeleteUFM pullable i - = place pullable' rest block - | otherwise - -- We already placed this block, so ignore - = placeNext pullable rest - - place pullable todo (block,[]) - = block : placeNext pullable todo - place pullable todo (block@(BasicBlock id instrs),[next]) - | mapMember next infos - = block : placeNext pullable todo - | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next - = BasicBlock id instrs : place pullable' todo nextBlock - | otherwise - = block : placeNext pullable todo - place _ _ (_,tooManyNextNodes) - = pprPanic "seqBlocks" (ppr tooManyNextNodes) - - -lookupDeleteUFM :: Uniquable key => UniqFM elt -> key - -> Maybe (elt, UniqFM elt) -lookupDeleteUFM m k = do -- Maybe monad - v <- lookupUFM m k - return (v, delFromUFM m k) - diff --git a/nativeGen/CFG.hs b/nativeGen/CFG.hs deleted file mode 100644 --- a/nativeGen/CFG.hs +++ /dev/null @@ -1,1321 +0,0 @@ --- --- Copyright (c) 2018 Andreas Klebinger --- - -{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} - -module CFG - ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..) - , TransitionSource(..) - - --Modify the CFG - , addWeightEdge, addEdge - , delEdge, delNode - , addNodesBetween, shortcutWeightMap - , reverseEdges, filterEdges - , addImmediateSuccessor - , mkWeightInfo, adjustEdgeWeight, setEdgeWeight - - --Query the CFG - , infoEdgeList, edgeList - , getSuccessorEdges, getSuccessors - , getSuccEdgesSorted - , getEdgeInfo - , getCfgNodes, hasNode - - -- Loop Information - , loopMembers, loopLevels, loopInfo - - --Construction/Misc - , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg - - --Find backedges and update their weight - , optimizeCFG - , mkGlobalWeights - - ) -where - -#include "HsVersions.h" - -import GhcPrelude - -import BlockId -import Cmm - -import CmmUtils -import CmmSwitch -import Hoopl.Collections -import Hoopl.Label -import Hoopl.Block -import qualified Hoopl.Graph as G - -import Util -import Digraph -import Maybes - -import Unique -import qualified Dominators as Dom -import Data.IntMap.Strict (IntMap) -import Data.IntSet (IntSet) - -import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M -import qualified Data.IntSet as IS -import qualified Data.Set as S -import Data.Tree -import Data.Bifunctor - -import Outputable --- DEBUGGING ONLY ---import Debug --- import Debug.Trace ---import OrdList ---import Debug.Trace -import PprCmm () -- For Outputable instances -import qualified DynFlags as D - -import Data.List (sort, nub, partition) -import Data.STRef.Strict -import Control.Monad.ST - -import Data.Array.MArray -import Data.Array.ST -import Data.Array.IArray -import Data.Array.Unsafe (unsafeFreeze) -import Data.Array.Base (unsafeRead, unsafeWrite) - -import Control.Monad - -type Prob = Double - -type Edge = (BlockId, BlockId) -type Edges = [Edge] - -newtype EdgeWeight - = EdgeWeight { weightToDouble :: Double } - deriving (Eq,Ord,Enum,Num,Real,Fractional) - -instance Outputable EdgeWeight where - ppr (EdgeWeight w) = doublePrec 5 w - -type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo) - --- | A control flow graph where edges have been annotated with a weight. --- Implemented as IntMap (IntMap ) --- We must uphold the invariant that for each edge A -> B we must have: --- A entry B in the outer map. --- A entry B in the map we get when looking up A. --- Maintaining this invariant is useful as any failed lookup now indicates --- an actual error in code which might go unnoticed for a while --- otherwise. -type CFG = EdgeInfoMap EdgeInfo - -data CfgEdge - = CfgEdge - { edgeFrom :: !BlockId - , edgeTo :: !BlockId - , edgeInfo :: !EdgeInfo - } - --- | Careful! Since we assume there is at most one edge from A to B --- the Eq instance does not consider weight. -instance Eq CfgEdge where - (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _) - = from1 == from2 && to1 == to2 - --- | Edges are sorted ascending pointwise by weight, source and destination -instance Ord CfgEdge where - compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1})) - (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2})) - | weight1 < weight2 || weight1 == weight2 && from1 < from2 || - weight1 == weight2 && from1 == from2 && to1 < to2 - = LT - | from1 == from2 && to1 == to2 && weight1 == weight2 - = EQ - | otherwise - = GT - -instance Outputable CfgEdge where - ppr (CfgEdge from1 to1 edgeInfo) - = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1) - --- | Can we trace back a edge to a specific Cmm Node --- or has it been introduced during assembly codegen. We use this to maintain --- some information which would otherwise be lost during the --- Cmm <-> asm transition. --- See also Note [Inverting Conditional Branches] -data TransitionSource - = CmmSource { trans_cmmNode :: (CmmNode O C) - , trans_info :: BranchInfo } - | AsmCodeGen - deriving (Eq) - -data BranchInfo = NoInfo -- ^ Unknown, but not heap or stack check. - | HeapStackCheck -- ^ Heap or stack check - deriving Eq - -instance Outputable BranchInfo where - ppr NoInfo = text "regular" - ppr HeapStackCheck = text "heap/stack" - -isHeapOrStackCheck :: TransitionSource -> Bool -isHeapOrStackCheck (CmmSource { trans_info = HeapStackCheck}) = True -isHeapOrStackCheck _ = False - --- | Information about edges -data EdgeInfo - = EdgeInfo - { transitionSource :: !TransitionSource - , edgeWeight :: !EdgeWeight - } deriving (Eq) - -instance Outputable EdgeInfo where - ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo) - --- | Convenience function, generate edge info based --- on weight not originating from cmm. -mkWeightInfo :: EdgeWeight -> EdgeInfo -mkWeightInfo = EdgeInfo AsmCodeGen - --- | Adjust the weight between the blocks using the given function. --- If there is no such edge returns the original map. -adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight) - -> BlockId -> BlockId -> CFG -adjustEdgeWeight cfg f from to - | Just info <- getEdgeInfo from to cfg - , !weight <- edgeWeight info - , !newWeight <- f weight - = addEdge from to (info { edgeWeight = newWeight}) cfg - | otherwise = cfg - --- | Set the weight between the blocks to the given weight. --- If there is no such edge returns the original map. -setEdgeWeight :: CFG -> EdgeWeight - -> BlockId -> BlockId -> CFG -setEdgeWeight cfg !weight from to - | Just info <- getEdgeInfo from to cfg - = addEdge from to (info { edgeWeight = weight}) cfg - | otherwise = cfg - - -getCfgNodes :: CFG -> [BlockId] -getCfgNodes m = - mapKeys m - --- | Is this block part of this graph? -hasNode :: CFG -> BlockId -> Bool -hasNode m node = - -- Check the invariant that each node must exist in the first map or not at all. - ASSERT( found || not (any (mapMember node) m)) - found - where - found = mapMember node m - - - --- | Check if the nodes in the cfg and the set of blocks are the same. --- In a case of a missmatch we panic and show the difference. -sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool -sanityCheckCfg m blockSet msg - | blockSet == cfgNodes - = True - | otherwise = - pprPanic "Block list and cfg nodes don't match" ( - text "difference:" <+> ppr diff $$ - text "blocks:" <+> ppr blockSet $$ - text "cfg:" <+> pprEdgeWeights m $$ - msg ) - False - where - cfgNodes = setFromList $ getCfgNodes m :: LabelSet - diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet - --- | Filter the CFG with a custom function f. --- Paramaeters are `f from to edgeInfo` -filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG -filterEdges f cfg = - mapMapWithKey filterSources cfg - where - filterSources from m = - mapFilterWithKey (\to w -> f from to w) m - - -{- Note [Updating the CFG during shortcutting] - -See Note [What is shortcutting] in the control flow optimization -code (CmmContFlowOpt.hs) for a slightly more in depth explanation on shortcutting. - -In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs) -This means we remove blocks containing only one jump from the code -and instead redirecting all jumps targeting this block to the deleted -blocks jump target. - -However we want to have an accurate representation of control -flow in the CFG. So we add/remove edges accordingly to account -for the eliminated blocks and new edges. - -If we shortcut A -> B -> C to A -> C: -* We delete edges A -> B and B -> C -* Replacing them with the edge A -> C - -We also try to preserve jump weights while doing so. - -Note that: -* The edge B -> C can't have interesting weights since - the block B consists of a single unconditional jump without branching. -* We delete the edge A -> B and add the edge A -> C. -* The edge A -> B can be one of many edges originating from A so likely - has edge weights we want to preserve. - -For this reason we simply store the edge info from the original A -> B -edge and apply this information to the new edge A -> C. - -Sometimes we have a scenario where jump target C is not represented by an -BlockId but an immediate value. I'm only aware of this happening without -tables next to code currently. - -Then we go from A ---> B - -> IMM to A - -> IMM where the dashed arrows -are not stored in the CFG. - -In that case we simply delete the edge A -> B. - -In terms of implementation the native backend first builds a mapping -from blocks suitable for shortcutting to their jump targets. -Then it redirects all jump instructions to these blocks using the -built up mapping. -This function (shortcutWeightMap) takes the same mapping and -applies the mapping to the CFG in the way layed out above. - --} -shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG -shortcutWeightMap cuts cfg = - foldl' applyMapping cfg $ mapToList cuts - where --- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting] - applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG - --Shortcut immediate - applyMapping m (from, Nothing) = - mapDelete from . - fmap (mapDelete from) $ m - --Regular shortcut - applyMapping m (from, Just to) = - let updatedMap :: CFG - updatedMap - = fmap (shortcutEdge (from,to)) $ - (mapDelete from m :: CFG ) - --Sometimes we can shortcut multiple blocks like so: - -- A -> B -> C -> D -> E => A -> E - -- so we check for such chains. - in case mapLookup to cuts of - Nothing -> updatedMap - Just dest -> applyMapping updatedMap (to, dest) - --Redirect edge from B to C - shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo - shortcutEdge (from, to) m = - case mapLookup from m of - Just info -> mapInsert to info $ mapDelete from m - Nothing -> m - --- | Sometimes we insert a block which should unconditionally be executed --- after a given block. This function updates the CFG for these cases. --- So we get A -> B => A -> A' -> B --- \ \ --- -> C => -> C --- -addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG -addImmediateSuccessor node follower cfg - = updateEdges . addWeightEdge node follower uncondWeight $ cfg - where - uncondWeight = fromIntegral . D.uncondWeight . - D.cfgWeightInfo $ D.unsafeGlobalDynFlags - targets = getSuccessorEdges cfg node - successors = map fst targets :: [BlockId] - updateEdges = addNewSuccs . remOldSuccs - remOldSuccs m = foldl' (flip (delEdge node)) m successors - addNewSuccs m = - foldl' (\m' (t,info) -> addEdge follower t info m') m targets - --- | Adds a new edge, overwrites existing edges if present -addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG -addEdge from to info cfg = - mapAlter addFromToEdge from $ - mapAlter addDestNode to cfg - where - -- Simply insert the edge into the edge list. - addFromToEdge Nothing = Just $ mapSingleton to info - addFromToEdge (Just wm) = Just $ mapInsert to info wm - -- We must add the destination node explicitly - addDestNode Nothing = Just $ mapEmpty - addDestNode n@(Just _) = n - - --- | Adds a edge with the given weight to the cfg --- If there already existed an edge it is overwritten. --- `addWeightEdge from to weight cfg` -addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG -addWeightEdge from to weight cfg = - addEdge from to (mkWeightInfo weight) cfg - -delEdge :: BlockId -> BlockId -> CFG -> CFG -delEdge from to m = - mapAlter remDest from m - where - remDest Nothing = Nothing - remDest (Just wm) = Just $ mapDelete to wm - -delNode :: BlockId -> CFG -> CFG -delNode node cfg = - fmap (mapDelete node) -- < Edges to the node - (mapDelete node cfg) -- < Edges from the node - --- | Destinations from bid ordered by weight (descending) -getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)] -getSuccEdgesSorted m bid = - let destMap = mapFindWithDefault mapEmpty bid m - cfgEdges = mapToList destMap - sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges - in --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m) - sortedEdges - --- | Get successors of a given node with edge weights. -getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)] -getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m) - where - lookupError = pprPanic "getSuccessorEdges: Block does not exist" $ - ppr bid <+> pprEdgeWeights m - -getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo -getEdgeInfo from to m - | Just wm <- mapLookup from m - , Just info <- mapLookup to wm - = Just $! info - | otherwise - = Nothing - -getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight -getEdgeWeight cfg from to = - edgeWeight $ expectJust "Edgeweight for noexisting block" $ - getEdgeInfo from to cfg - -getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource -getTransitionSource from to cfg = transitionSource $ expectJust "Source info for noexisting block" $ - getEdgeInfo from to cfg - -reverseEdges :: CFG -> CFG -reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg - where - -- We must preserve nodes without outgoing edges! - addNode :: CFG -> BlockId -> CFG - addNode cfg b = mapInsertWith mapUnion b mapEmpty cfg - go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG - go cfg from toMap = mapFoldlWithKey (\cfg to info -> addEdge to from info cfg) cfg toMap :: CFG - - --- | Returns a unordered list of all edges with info -infoEdgeList :: CFG -> [CfgEdge] -infoEdgeList m = - go (mapToList m) [] - where - -- We avoid foldMap to avoid thunk buildup - go :: [(BlockId,LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge] - go [] acc = acc - go ((from,toMap):xs) acc - = go' xs from (mapToList toMap) acc - go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [(BlockId,EdgeInfo)] -> [CfgEdge] -> [CfgEdge] - go' froms _ [] acc = go froms acc - go' froms from ((to,info):tos) acc - = go' froms from tos (CfgEdge from to info : acc) - --- | Returns a unordered list of all edges without weights -edgeList :: CFG -> [Edge] -edgeList m = - go (mapToList m) [] - where - -- We avoid foldMap to avoid thunk buildup - go :: [(BlockId,LabelMap EdgeInfo)] -> [Edge] -> [Edge] - go [] acc = acc - go ((from,toMap):xs) acc - = go' xs from (mapKeys toMap) acc - go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [BlockId] -> [Edge] -> [Edge] - go' froms _ [] acc = go froms acc - go' froms from (to:tos) acc - = go' froms from tos ((from,to) : acc) - --- | Get successors of a given node without edge weights. -getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId] -getSuccessors m bid - | Just wm <- mapLookup bid m - = mapKeys wm - | otherwise = lookupError - where - lookupError = pprPanic "getSuccessors: Block does not exist" $ - ppr bid <+> pprEdgeWeights m - -pprEdgeWeights :: CFG -> SDoc -pprEdgeWeights m = - let edges = sort $ infoEdgeList m :: [CfgEdge] - printEdge (CfgEdge from to (EdgeInfo { edgeWeight = weight })) - = text "\t" <> ppr from <+> text "->" <+> ppr to <> - text "[label=\"" <> ppr weight <> text "\",weight=\"" <> - ppr weight <> text "\"];\n" - --for the case that there are no edges from/to this node. - --This should rarely happen but it can save a lot of time - --to immediately see it when it does. - printNode node - = text "\t" <> ppr node <> text ";\n" - getEdgeNodes (CfgEdge from to _) = [from,to] - edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet - nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m - in - text "digraph {\n" <> - (foldl' (<>) empty (map printEdge edges)) <> - (foldl' (<>) empty (map printNode nodes)) <> - text "}\n" - -{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible --- | Invariant: The edge **must** exist already in the graph. -updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG -updateEdgeWeight f (from, to) cfg - | Just oldInfo <- getEdgeInfo from to cfg - = let !oldWeight = edgeWeight oldInfo - !newWeight = f oldWeight - in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg - | otherwise - = panic "Trying to update invalid edge" - --- from to oldWeight => newWeight -mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG -mapWeights f cfg = - foldl' (\cfg (CfgEdge from to info) -> - let oldWeight = edgeWeight info - newWeight = f from to oldWeight - in addEdge from to (info {edgeWeight = newWeight}) cfg) - cfg (infoEdgeList cfg) - - --- | Insert a block in the control flow between two other blocks. --- We pass a list of tuples (A,B,C) where --- * A -> C: Old edge --- * A -> B -> C : New Arc, where B is the new block. --- It's possible that a block has two jumps to the same block --- in the assembly code. However we still only store a single edge for --- these cases. --- We assign the old edge info to the edge A -> B and assign B -> C the --- weight of an unconditional jump. -addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG -addNodesBetween m updates = - foldl' updateWeight m . - weightUpdates $ updates - where - weight = fromIntegral . D.uncondWeight . - D.cfgWeightInfo $ D.unsafeGlobalDynFlags - -- We might add two blocks for different jumps along a single - -- edge. So we end up with edges: A -> B -> C , A -> D -> C - -- in this case after applying the first update the weight for A -> C - -- is no longer available. So we calculate future weights before updates. - weightUpdates = map getWeight - getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo) - getWeight (from,between,old) - | Just edgeInfo <- getEdgeInfo from old m - = (from,between,old,edgeInfo) - | otherwise - = pprPanic "Can't find weight for edge that should have one" ( - text "triple" <+> ppr (from,between,old) $$ - text "updates" <+> ppr updates $$ - text "cfg:" <+> pprEdgeWeights m ) - updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG - updateWeight m (from,between,old,edgeInfo) - = addEdge from between edgeInfo . - addWeightEdge between old weight . - delEdge from old $ m - -{- - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~ Note [CFG Edge Weights] ~~~ - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Edge weights assigned do not currently represent a specific - cost model and rather just a ranking of which blocks should - be placed next to each other given their connection type in - the CFG. - This is especially relevant if we whenever two blocks will - jump to the same target. - - A B - \ / - C - - Should A or B be placed in front of C? The block layout algorithm - decides this based on which edge (A,C)/(B,C) is heavier. So we - make a educated guess on which branch should be preferred. - - We rank edges in this order: - * Unconditional Control Transfer - They will always - transfer control to their target. Unless there is a info table - we can turn the jump into a fallthrough as well. - We use 20k as default, so it's easy to spot if values have been - modified but unlikely that we run into issues with overflow. - * If branches (likely) - We assume branches marked as likely - are taken more than 80% of the time. - By ranking them below unconditional jumps we make sure we - prefer the unconditional if there is a conditional and - unconditional edge towards a block. - * If branches (regular) - The false branch can potentially be turned - into a fallthrough so we prefer it slightly over the true branch. - * Unlikely branches - These can be assumed to be taken less than 20% - of the time. So we given them one of the lowest priorities. - * Switches - Switches at this level are implemented as jump tables - so have a larger number of successors. So without more information - we can only say that each individual successor is unlikely to be - jumped to and we rank them accordingly. - * Calls - We currently ignore calls completly: - * By the time we return from a call there is a good chance - that the address we return to has already been evicted from - cache eliminating a main advantage sequential placement brings. - * Calls always require a info table in front of their return - address. This reduces the chance that we return to the same - cache line further. - --} --- | Generate weights for a Cmm proc based on some simple heuristics. -getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG -getCfgProc _ (CmmData {}) = mapEmpty -getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph - -getCfg :: D.CfgWeights -> CmmGraph -> CFG -getCfg weights graph = - foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks - where - D.CFGWeights - { D.uncondWeight = uncondWeight - , D.condBranchWeight = condBranchWeight - , D.switchWeight = switchWeight - , D.callWeight = callWeight - , D.likelyCondWeight = likelyCondWeight - , D.unlikelyCondWeight = unlikelyCondWeight - -- Last two are used in other places - --, D.infoTablePenalty = infoTablePenalty - --, D.backEdgeBonus = backEdgeBonus - } = weights - -- Explicitly add all nodes to the cfg to ensure they are part of the - -- CFG. - edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty) - insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG - insertEdge m ((from,to),weight) = - mapAlter f from m - where - f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo) - f Nothing = Just $ mapSingleton to weight - f (Just destMap) = Just $ mapInsert to weight destMap - getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)] - getBlockEdges block = - case branch of - CmmBranch dest -> [mkEdge dest uncondWeight] - CmmCondBranch cond t f l - | l == Nothing -> - [mkEdge f condBranchWeight, mkEdge t condBranchWeight] - | l == Just True -> - [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight] - | l == Just False -> - [mkEdge f likelyCondWeight, mkEdge t unlikelyCondWeight] - where - mkEdgeInfo = -- pprTrace "Info" (ppr branchInfo <+> ppr cond) - EdgeInfo (CmmSource branch branchInfo) . fromIntegral - mkEdge target weight = ((bid,target), mkEdgeInfo weight) - branchInfo = - foldRegsUsed - (panic "foldRegsDynFlags") - (\info r -> if r == SpLim || r == HpLim || r == BaseReg - then HeapStackCheck else info) - NoInfo cond - - (CmmSwitch _e ids) -> - let switchTargets = switchTargetsToList ids - --Compiler performance hack - for very wide switches don't - --consider targets for layout. - adjustedWeight = - if (length switchTargets > 10) then -1 else switchWeight - in map (\x -> mkEdge x adjustedWeight) switchTargets - (CmmCall { cml_cont = Just cont}) -> [mkEdge cont callWeight] - (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight] - (CmmCall { cml_cont = Nothing }) -> [] - other -> - panic "Foo" $ - ASSERT2(False, ppr "Unkown successor cause:" <> - (ppr branch <+> text "=>" <> ppr (G.successors other))) - map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other - where - bid = G.entryLabel block - mkEdgeInfo = EdgeInfo (CmmSource branch NoInfo) . fromIntegral - mkEdge target weight = ((bid,target), mkEdgeInfo weight) - branch = lastNode block :: CmmNode O C - - blocks = revPostorder graph :: [CmmBlock] - ---Find back edges by BFS -findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges -findBackEdges root cfg = - --pprTraceIt "Backedges:" $ - map fst . - filter (\x -> snd x == Backward) $ typedEdges - where - edges = edgeList cfg :: [(BlockId,BlockId)] - getSuccs = getSuccessors cfg :: BlockId -> [BlockId] - typedEdges = - classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)] - - -optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG -optimizeCFG _ (CmmData {}) cfg = cfg -optimizeCFG weights (CmmProc info _lab _live graph) cfg = - {-# SCC optimizeCFG #-} - -- pprTrace "Initial:" (pprEdgeWeights cfg) $ - -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $ - - -- pprTrace "LoopInfo:" (ppr $ loopInfo cfg (g_entry graph)) $ - favourFewerPreds . - penalizeInfoTables info . - increaseBackEdgeWeight (g_entry graph) $ cfg - where - - -- | Increase the weight of all backedges in the CFG - -- this helps to make loop jumpbacks the heaviest edges - increaseBackEdgeWeight :: BlockId -> CFG -> CFG - increaseBackEdgeWeight root cfg = - let backedges = findBackEdges root cfg - update weight - --Keep irrelevant edges irrelevant - | weight <= 0 = 0 - | otherwise - = weight + fromIntegral (D.backEdgeBonus weights) - in foldl' (\cfg edge -> updateEdgeWeight update edge cfg) - cfg backedges - - -- | Since we cant fall through info tables we penalize these. - penalizeInfoTables :: LabelMap a -> CFG -> CFG - penalizeInfoTables info cfg = - mapWeights fupdate cfg - where - fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight - fupdate _ to weight - | mapMember to info - = weight - (fromIntegral $ D.infoTablePenalty weights) - | otherwise = weight - - -- | If a block has two successors, favour the one with fewer - -- predecessors and/or the one allowing fall through. - favourFewerPreds :: CFG -> CFG - favourFewerPreds cfg = - let - revCfg = - reverseEdges $ filterEdges - (\_from -> fallthroughTarget) cfg - - predCount n = length $ getSuccessorEdges revCfg n - nodes = getCfgNodes cfg - - modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight) - modifiers preds1 preds2 - | preds1 < preds2 = ( 1,-1) - | preds1 == preds2 = ( 0, 0) - | otherwise = (-1, 1) - - update :: CFG -> BlockId -> CFG - update cfg node - | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node - , !w1 <- edgeWeight e1 - , !w2 <- edgeWeight e2 - --Only change the weights if there isn't already a ordering. - , w1 == w2 - , (mod1,mod2) <- modifiers (predCount s1) (predCount s2) - = (\cfg' -> - (adjustEdgeWeight cfg' (+mod2) node s2)) - (adjustEdgeWeight cfg (+mod1) node s1) - | otherwise - = cfg - in foldl' update cfg nodes - where - fallthroughTarget :: BlockId -> EdgeInfo -> Bool - fallthroughTarget to (EdgeInfo source _weight) - | mapMember to info = False - | AsmCodeGen <- source = True - | CmmSource { trans_cmmNode = CmmBranch {} } <- source = True - | CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True - | otherwise = False - --- | Determine loop membership of blocks based on SCC analysis --- This is faster but only gives yes/no answers. -loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool -loopMembers cfg = - foldl' (flip setLevel) mapEmpty sccs - where - mkNode :: BlockId -> Node BlockId BlockId - mkNode bid = DigraphNode bid bid (getSuccessors cfg bid) - nodes = map mkNode (getCfgNodes cfg) - - sccs = stronglyConnCompFromEdgedVerticesOrd nodes - - setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool - setLevel (AcyclicSCC bid) m = mapInsert bid False m - setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids - -loopLevels :: CFG -> BlockId -> LabelMap Int -loopLevels cfg root = liLevels loopInfos - where - loopInfos = loopInfo cfg root - -data LoopInfo = LoopInfo - { liBackEdges :: [(Edge)] -- ^ List of back edges - , liLevels :: LabelMap Int -- ^ BlockId -> LoopLevel mapping - , liLoops :: [(Edge, LabelSet)] -- ^ (backEdge, loopBody), body includes header - } - -instance Outputable LoopInfo where - ppr (LoopInfo _ _lvls loops) = - text "Loops:(backEdge, bodyNodes)" $$ - (vcat $ map ppr loops) - -{- Note [Determining the loop body] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Starting with the knowledge that: - * head dominates the loop - * `tail` -> `head` is a backedge - - We can determine all nodes by: - * Deleting the loop head from the graph. - * Collect all blocks which are reachable from the `tail`. - - We do so by performing bfs from the tail node towards the head. - -} - --- | Determine loop membership of blocks based on Dominator analysis. --- This is slower but gives loop levels instead of just loop membership. --- However it only detects natural loops. Irreducible control flow is not --- recognized even if it loops. But that is rare enough that we don't have --- to care about that special case. -loopInfo :: HasDebugCallStack => CFG -> BlockId -> LoopInfo -loopInfo cfg root = LoopInfo { liBackEdges = backEdges - , liLevels = mapFromList loopCounts - , liLoops = loopBodies } - where - revCfg = reverseEdges cfg - - graph = -- pprTrace "CFG - loopInfo" (pprEdgeWeights cfg) $ - fmap (setFromList . mapKeys ) cfg :: LabelMap LabelSet - - - --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ... - rooted = ( fromBlockId root - , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet) - tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId - - -- Map from Nodes to their dominators - domMap :: LabelMap LabelSet - domMap = mkDomMap tree - - edges = edgeList cfg :: [(BlockId, BlockId)] - -- We can't recompute nodes from edges, there might be blocks not connected via edges. - nodes = getCfgNodes cfg :: [BlockId] - - -- identify back edges - isBackEdge (from,to) - | Just doms <- mapLookup from domMap - , setMember to doms - = True - | otherwise = False - - -- See Note [Determining the loop body] - -- Get the loop body associated with a back edge. - findBody edge@(tail, head) - = ( edge, setInsert head $ go (setSingleton tail) (setSingleton tail) ) - where - -- See Note [Determining the loop body] - cfg' = delNode head revCfg - - go :: LabelSet -> LabelSet -> LabelSet - go found current - | setNull current = found - | otherwise = go (setUnion newSuccessors found) - newSuccessors - where - -- Really predecessors, since we use the reversed cfg. - newSuccessors = setFilter (\n -> not $ setMember n found) successors :: LabelSet - successors = setFromList $ concatMap - (getSuccessors cfg') - -- we filter head as it's no longer part of the cfg. - (filter (/= head) $ setElems current) :: LabelSet - - backEdges = filter isBackEdge edges - loopBodies = map findBody backEdges :: [(Edge, LabelSet)] - - -- Block b is part of n loop bodies => loop nest level of n - loopCounts = - let bodies = map (first snd) loopBodies -- [(Header, Body)] - loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies - in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] - - toIntSet :: LabelSet -> IntSet - toIntSet s = IS.fromList . map fromBlockId . setElems $ s - toIntMap :: LabelMap a -> IntMap a - toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m - - mkDomMap :: Tree BlockId -> LabelMap LabelSet - mkDomMap root = mapFromList $ go setEmpty root - where - go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)] - go parents (Node lbl []) - = [(lbl, parents)] - go parents (Node _ leaves) - = let nodes = map rootLabel leaves - entries = map (\x -> (x,parents)) nodes - in entries ++ concatMap - (\n -> go (setInsert (rootLabel n) parents) n) - leaves - - fromBlockId :: BlockId -> Int - fromBlockId = getKey . getUnique - - toBlockId :: Int -> BlockId - toBlockId = mkBlockId . mkUniqueGrimily - --- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. -newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId]) - -instance G.NonLocal (BlockNode) where - entryLabel (BN (lbl,_)) = lbl - successors (BN (_,succs)) = succs - -revPostorderFrom :: HasDebugCallStack => CFG -> BlockId -> [BlockId] -revPostorderFrom cfg root = - map fromNode $ G.revPostorderFrom hooplGraph root - where - nodes = getCfgNodes cfg - hooplGraph = foldl' (\m n -> mapInsert n (toNode n) m) mapEmpty nodes - - fromNode :: BlockNode C C -> BlockId - fromNode (BN x) = fst x - - toNode :: BlockId -> BlockNode C C - toNode bid = - BN (bid,getSuccessors cfg $ bid) - - --- | We take in a CFG which has on its edges weights which are --- relative only to other edges originating from the same node. --- --- We return a CFG for which each edge represents a GLOBAL weight. --- This means edge weights are comparable across the whole graph. --- --- For irreducible control flow results might be imprecise, otherwise they --- are reliable. --- --- The algorithm is based on the Paper --- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus --- The only big change is that we go over the nodes in the body of loops in --- reverse post order. Which is required for diamond control flow to work probably. --- --- We also apply a few prediction heuristics (based on the same paper) - -{-# NOINLINE mkGlobalWeights #-} -{-# SCC mkGlobalWeights #-} -mkGlobalWeights :: HasDebugCallStack => BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double)) -mkGlobalWeights root localCfg - | null localCfg = panic "Error - Empty CFG" - | otherwise - = (blockFreqs', edgeFreqs') - where - -- Calculate fixpoints - (blockFreqs, edgeFreqs) = calcFreqs nodeProbs backEdges' bodies' revOrder' - blockFreqs' = mapFromList $ map (first fromVertex) (assocs blockFreqs) :: LabelMap Double - edgeFreqs' = fmap fromVertexMap $ fromVertexMap edgeFreqs - - fromVertexMap :: IM.IntMap x -> LabelMap x - fromVertexMap m = mapFromList . map (first fromVertex) $ IM.toList m - - revOrder = revPostorderFrom localCfg root :: [BlockId] - loopResults@(LoopInfo backedges _levels bodies) = loopInfo localCfg root - - revOrder' = map toVertex revOrder - backEdges' = map (bimap toVertex toVertex) backedges - bodies' = map calcBody bodies - - estimatedCfg = staticBranchPrediction root loopResults localCfg - -- Normalize the weights to probabilities and apply heuristics - nodeProbs = cfgEdgeProbabilities estimatedCfg toVertex - - -- By mapping vertices to numbers in reverse post order we can bring any subset into reverse post - -- order simply by sorting. - -- TODO: The sort is redundant if we can guarantee that setElems returns elements ascending - calcBody (backedge, blocks) = - (toVertex $ snd backedge, sort . map toVertex $ (setElems blocks)) - - vertexMapping = mapFromList $ zip revOrder [0..] :: LabelMap Int - blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId - -- Map from blockId to indicies starting at zero - toVertex :: BlockId -> Int - toVertex blockId = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping - -- Map from indicies starting at zero to blockIds - fromVertex :: Int -> BlockId - fromVertex vertex = blockMapping ! vertex - -{- Note [Static Branch Prediction] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The work here has been based on the paper -"Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus. - -The primary differences are that if we branch on the result of a heap -check we do not apply any of the heuristics. -The reason is simple: They look like loops in the control flow graph -but are usually never entered, and if at most once. - -Currently implemented is a heuristic to predict that we do not exit -loops (lehPredicts) and one to predict that backedges are more likely -than any other edge. - -The back edge case is special as it superceeds any other heuristic if it -applies. - -Do NOT rely solely on nofib results for benchmarking this. I recommend at least -comparing megaparsec and container benchmarks. Nofib does not seeem to have -many instances of "loopy" Cmm where these make a difference. - -TODO: -* The paper containers more benchmarks which should be implemented. -* If we turn the likelyhood on if/else branches into a probability - instead of true/false we could implement this as a Cmm pass. - + The complete Cmm code still exists and can be accessed by the heuristics - + There is no chance of register allocation/codegen inserting branches/blocks - + making the TransitionSource info wrong. - + potential to use this information in CmmPasses. - - Requires refactoring of all the code relying on the binary nature of likelyhood. - - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG. --} - --- | Combination of target node id and information about the branch --- we are looking at. -type TargetNodeInfo = (BlockId, EdgeInfo) - - --- | Update branch weights based on certain heuristics. --- See Note [Static Branch Prediction] --- TODO: This should be combined with optimizeCFG -{-# SCC staticBranchPrediction #-} -staticBranchPrediction :: BlockId -> LoopInfo -> CFG -> CFG -staticBranchPrediction _root (LoopInfo l_backEdges loopLevels l_loops) cfg = - -- pprTrace "staticEstimatesOn" (ppr (cfg)) $ - foldl' update cfg nodes - where - nodes = getCfgNodes cfg - backedges = S.fromList $ l_backEdges - -- Loops keyed by their back edge - loops = M.fromList $ l_loops :: M.Map Edge LabelSet - loopHeads = S.fromList $ map snd $ M.keys loops - - update :: CFG -> BlockId -> CFG - update cfg node - -- No successors, nothing to do. - | null successors = cfg - - -- Mix of backedges and others: - -- Always predict the backedges. - | not (null m) && length m < length successors - -- Heap/Stack checks "loop", but only once. - -- So we simply exclude any case involving them. - , not $ any (isHeapOrStackCheck . transitionSource . snd) successors - = let loopChance = repeat $! pred_LBH / (fromIntegral $ length m) - exitChance = repeat $! (1 - pred_LBH) / fromIntegral (length not_m) - updates = zip (map fst m) loopChance ++ zip (map fst not_m) exitChance - in -- pprTrace "mix" (ppr (node,successors)) $ - foldl' (\cfg (to,weight) -> setEdgeWeight cfg weight node to) cfg updates - - -- For (regular) non-binary branches we keep the weights from the STG -> Cmm translation. - | length successors /= 2 - = cfg - - -- Only backedges - no need to adjust - | length m > 0 - = cfg - - -- A regular binary branch, we can plug addition predictors in here. - | [(s1,s1_info),(s2,s2_info)] <- successors - , not $ any (isHeapOrStackCheck . transitionSource . snd) successors - = -- Normalize weights to total of 1 - let !w1 = max (edgeWeight s1_info) (0) - !w2 = max (edgeWeight s2_info) (0) - -- Of both weights are <= 0 we set both to 0.5 - normalizeWeight w = if w1 + w2 == 0 then 0.5 else w/(w1+w2) - !cfg' = setEdgeWeight cfg (normalizeWeight w1) node s1 - !cfg'' = setEdgeWeight cfg' (normalizeWeight w2) node s2 - - -- Figure out which heuristics apply to these successors - heuristics = map ($ ((s1,s1_info),(s2,s2_info))) - [lehPredicts, phPredicts, ohPredicts, ghPredicts, lhhPredicts, chPredicts - , shPredicts, rhPredicts] - -- Apply result of a heuristic. Argument is the likelyhood - -- predicted for s1. - applyHeuristic :: CFG -> Maybe Prob -> CFG - applyHeuristic cfg Nothing = cfg - applyHeuristic cfg (Just (s1_pred :: Double)) - | s1_old == 0 || s2_old == 0 || - isHeapOrStackCheck (transitionSource s1_info) || - isHeapOrStackCheck (transitionSource s2_info) - = cfg - | otherwise = - let -- Predictions from heuristic - s1_prob = EdgeWeight s1_pred :: EdgeWeight - s2_prob = 1.0 - s1_prob - -- Update - d = (s1_old * s1_prob) + (s2_old * s2_prob) :: EdgeWeight - s1_prob' = s1_old * s1_prob / d - !s2_prob' = s2_old * s2_prob / d - !cfg_s1 = setEdgeWeight cfg s1_prob' node s1 - in -- pprTrace "Applying heuristic!" (ppr (node,s1,s2) $$ ppr (s1_prob', s2_prob')) $ - setEdgeWeight cfg_s1 s2_prob' node s2 - where - -- Old weights - s1_old = getEdgeWeight cfg node s1 - s2_old = getEdgeWeight cfg node s2 - - in - -- pprTraceIt "RegularCfgResult" $ - foldl' applyHeuristic cfg'' heuristics - - -- Branch on heap/stack check - | otherwise = cfg - - where - -- Chance that loops are taken. - pred_LBH = 0.875 - -- successors - successors = getSuccessorEdges cfg node - -- backedges - (m,not_m) = partition (\succ -> S.member (node, fst succ) backedges) successors - - -- Heuristics return nothing if they don't say anything about this branch - -- or Just (prob_s1) where prob_s1 is the likelyhood for s1 to be the - -- taken branch. s1 is the branch in the true case. - - -- Loop exit heuristic. - -- We are unlikely to leave a loop unless it's to enter another one. - pred_LEH = 0.75 - -- If and only if no successor is a loopheader, - -- then we will likely not exit the current loop body. - lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob - lehPredicts ((s1,_s1_info),(s2,_s2_info)) - | S.member s1 loopHeads || S.member s2 loopHeads - = Nothing - - | otherwise - = --pprTrace "lehPredict:" (ppr $ compare s1Level s2Level) $ - case compare s1Level s2Level of - EQ -> Nothing - LT -> Just (1-pred_LEH) --s1 exits to a shallower loop level (exits loop) - GT -> Just (pred_LEH) --s1 exits to a deeper loop level - where - s1Level = mapLookup s1 loopLevels - s2Level = mapLookup s2 loopLevels - - -- Comparing to a constant is unlikely to be equal. - ohPredicts (s1,_s2) - | CmmSource { trans_cmmNode = src1 } <- getTransitionSource node (fst s1) cfg - , CmmCondBranch cond ltrue _lfalse likely <- src1 - , likely == Nothing - , CmmMachOp mop args <- cond - , MO_Eq {} <- mop - , not (null [x | x@CmmLit{} <- args]) - = if fst s1 == ltrue then Just 0.3 else Just 0.7 - - | otherwise - = Nothing - - -- TODO: These are all the other heuristics from the paper. - -- Not all will apply, for now we just stub them out as Nothing. - phPredicts = const Nothing - ghPredicts = const Nothing - lhhPredicts = const Nothing - chPredicts = const Nothing - shPredicts = const Nothing - rhPredicts = const Nothing - --- We normalize all edge weights as probabilities between 0 and 1. --- Ignoring rounding errors all outgoing edges sum up to 1. -cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob) -cfgEdgeProbabilities cfg toVertex - = mapFoldlWithKey foldEdges IM.empty cfg - where - foldEdges = (\m from toMap -> IM.insert (toVertex from) (normalize toMap) m) - - normalize :: (LabelMap EdgeInfo) -> (IM.IntMap Prob) - normalize weightMap - | edgeCount <= 1 = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) 1.0 m) IM.empty weightMap - | otherwise = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) (normalWeight k) m) IM.empty weightMap - where - edgeCount = mapSize weightMap - -- Negative weights are generally allowed but are mapped to zero. - -- We then check if there is at least one non-zero edge and if not - -- assign uniform weights to all branches. - minWeight = 0 :: Prob - weightMap' = fmap (\w -> max (weightToDouble . edgeWeight $ w) minWeight) weightMap - totalWeight = sum weightMap' - - normalWeight :: BlockId -> Prob - normalWeight bid - | totalWeight == 0 - = 1.0 / fromIntegral edgeCount - | Just w <- mapLookup bid weightMap' - = w/totalWeight - | otherwise = panic "impossible" - --- This is the fixpoint algorithm from --- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus --- The adaption to Haskell is my own. -calcFreqs :: IM.IntMap (IM.IntMap Prob) -> [(Int,Int)] -> [(Int, [Int])] -> [Int] - -> (Array Int Double, IM.IntMap (IM.IntMap Prob)) -calcFreqs graph backEdges loops revPostOrder = runST $ do - visitedNodes <- newArray (0,nodeCount-1) False :: ST s (STUArray s Int Bool) - blockFreqs <- newArray (0,nodeCount-1) 0.0 :: ST s (STUArray s Int Double) - edgeProbs <- newSTRef graph - edgeBackProbs <- newSTRef graph - - -- let traceArray a = do - -- vs <- forM [0..nodeCount-1] $ \i -> readArray a i >>= (\v -> return (i,v)) - -- trace ("array: " ++ show vs) $ return () - - let -- See #1600, we need to inline or unboxing makes perf worse. - -- {-# INLINE getFreq #-} - {-# INLINE visited #-} - visited b = unsafeRead visitedNodes b - getFreq b = unsafeRead blockFreqs b - -- setFreq :: forall s. Int -> Double -> ST s () - setFreq b f = unsafeWrite blockFreqs b f - -- setVisited :: forall s. Node -> ST s () - setVisited b = unsafeWrite visitedNodes b True - -- Frequency/probability that edge is taken. - getProb' arr b1 b2 = readSTRef arr >>= - (\graph -> - return . - fromMaybe (error "getFreq 1") . - IM.lookup b2 . - fromMaybe (error "getFreq 2") $ - (IM.lookup b1 graph) - ) - setProb' arr b1 b2 prob = do - g <- readSTRef arr - let !m = fromMaybe (error "Foo") $ IM.lookup b1 g - !m' = IM.insert b2 prob m - writeSTRef arr $! (IM.insert b1 m' g) - - getEdgeFreq b1 b2 = getProb' edgeProbs b1 b2 - setEdgeFreq b1 b2 = setProb' edgeProbs b1 b2 - getProb b1 b2 = fromMaybe (error "getProb") $ do - m' <- IM.lookup b1 graph - IM.lookup b2 m' - - getBackProb b1 b2 = getProb' edgeBackProbs b1 b2 - setBackProb b1 b2 = setProb' edgeBackProbs b1 b2 - - - let -- calcOutFreqs :: Node -> ST s () - calcOutFreqs bhead block = do - !f <- getFreq block - forM (successors block) $ \bi -> do - let !prob = getProb block bi - let !succFreq = f * prob - setEdgeFreq block bi succFreq - -- traceM $ "SetOut: " ++ show (block, bi, f, prob, succFreq) - when (bi == bhead) $ setBackProb block bi succFreq - - - let propFreq block head = do - -- traceM ("prop:" ++ show (block,head)) - -- traceShowM block - - !v <- visited block - if v then - return () --Dont look at nodes twice - else if block == head then - setFreq block 1.0 -- Loop header frequency is always 1 - else do - let preds = IS.elems $ predecessors block - irreducible <- (fmap or) $ forM preds $ \bp -> do - !bp_visited <- visited bp - let bp_backedge = isBackEdge bp block - return (not bp_visited && not bp_backedge) - - if irreducible - then return () -- Rare we don't care - else do - setFreq block 0 - !cycleProb <- sum <$> (forM preds $ \pred -> do - if isBackEdge pred block - then - getBackProb pred block - else do - !f <- getFreq block - !prob <- getEdgeFreq pred block - setFreq block $! f + prob - return 0) - -- traceM $ "cycleProb:" ++ show cycleProb - let limit = 1 - 1/512 -- Paper uses 1 - epsilon, but this works. - -- determines how large likelyhoods in loops can grow. - !cycleProb <- return $ min cycleProb limit -- <- return $ if cycleProb > limit then limit else cycleProb - -- traceM $ "cycleProb:" ++ show cycleProb - - !f <- getFreq block - setFreq block (f / (1.0 - cycleProb)) - - setVisited block - calcOutFreqs head block - - -- Loops, by nesting, inner to outer - forM_ loops $ \(head, body) -> do - forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i True) -- Mark all nodes as visited. - forM_ body (\i -> unsafeWrite visitedNodes i False) -- Mark all blocks reachable from head as not visited - forM_ body $ \block -> propFreq block head - - -- After dealing with all loops, deal with non-looping parts of the CFG - forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i False) -- Everything in revPostOrder is reachable - forM_ revPostOrder $ \block -> propFreq block (head revPostOrder) - - -- trace ("Final freqs:") $ return () - -- let freqString = pprFreqs freqs - -- trace (unlines freqString) $ return () - -- trace (pprFre) $ return () - graph' <- readSTRef edgeProbs - freqs' <- unsafeFreeze blockFreqs - - return (freqs', graph') - where - -- How can these lookups fail? Consider the CFG [A -> B] - predecessors :: Int -> IS.IntSet - predecessors b = fromMaybe IS.empty $ IM.lookup b revGraph - successors :: Int -> [Int] - successors b = fromMaybe (lookupError "succ" b graph)$ IM.keys <$> IM.lookup b graph - lookupError s b g = pprPanic ("Lookup error " ++ s) $ - ( text "node" <+> ppr b $$ - text "graph" <+> - vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g) - ) - - nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets count toMap) (IM.size graph) graph - where - countTargets = (\count k _ -> countNode k + count ) - countNode n = if IM.member n graph then 0 else 1 - - isBackEdge from to = S.member (from,to) backEdgeSet - backEdgeSet = S.fromList backEdges - - revGraph :: IntMap IntSet - revGraph = IM.foldlWithKey' (\m from toMap -> addEdges m from toMap) IM.empty graph - where - addEdges m0 from toMap = IM.foldlWithKey' (\m k _ -> addEdge m from k) m0 toMap - addEdge m0 from to = IM.insertWith IS.union to (IS.singleton from) m0 diff --git a/nativeGen/CPrim.hs b/nativeGen/CPrim.hs deleted file mode 100644 --- a/nativeGen/CPrim.hs +++ /dev/null @@ -1,133 +0,0 @@ --- | Generating C symbol names emitted by the compiler. -module CPrim - ( atomicReadLabel - , atomicWriteLabel - , atomicRMWLabel - , cmpxchgLabel - , popCntLabel - , pdepLabel - , pextLabel - , bSwapLabel - , bRevLabel - , clzLabel - , ctzLabel - , word2FloatLabel - ) where - -import GhcPrelude - -import CmmType -import CmmMachOp -import Outputable - -popCntLabel :: Width -> String -popCntLabel w = "hs_popcnt" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w) - -pdepLabel :: Width -> String -pdepLabel w = "hs_pdep" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "pdepLabel: Unsupported word width " (ppr w) - -pextLabel :: Width -> String -pextLabel w = "hs_pext" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "pextLabel: Unsupported word width " (ppr w) - -bSwapLabel :: Width -> String -bSwapLabel w = "hs_bswap" ++ pprWidth w - where - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w) - -bRevLabel :: Width -> String -bRevLabel w = "hs_bitrev" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "bRevLabel: Unsupported word width " (ppr w) - -clzLabel :: Width -> String -clzLabel w = "hs_clz" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "clzLabel: Unsupported word width " (ppr w) - -ctzLabel :: Width -> String -ctzLabel w = "hs_ctz" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w) - -word2FloatLabel :: Width -> String -word2FloatLabel w = "hs_word2float" ++ pprWidth w - where - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) - -atomicRMWLabel :: Width -> AtomicMachOp -> String -atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) - - pprFunName AMO_Add = "add" - pprFunName AMO_Sub = "sub" - pprFunName AMO_And = "and" - pprFunName AMO_Nand = "nand" - pprFunName AMO_Or = "or" - pprFunName AMO_Xor = "xor" - -cmpxchgLabel :: Width -> String -cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) - -atomicReadLabel :: Width -> String -atomicReadLabel w = "hs_atomicread" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) - -atomicWriteLabel :: Width -> String -atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w - where - pprWidth W8 = "8" - pprWidth W16 = "16" - pprWidth W32 = "32" - pprWidth W64 = "64" - pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/nativeGen/Dwarf.hs b/nativeGen/Dwarf.hs deleted file mode 100644 --- a/nativeGen/Dwarf.hs +++ /dev/null @@ -1,269 +0,0 @@ -module Dwarf ( - dwarfGen - ) where - -import GhcPrelude - -import CLabel -import CmmExpr ( GlobalReg(..) ) -import Config ( cProjectName, cProjectVersion ) -import CoreSyn ( Tickish(..) ) -import Debug -import DynFlags -import Module -import Outputable -import GHC.Platform -import Unique -import UniqSupply - -import Dwarf.Constants -import Dwarf.Types - -import Control.Arrow ( first ) -import Control.Monad ( mfilter ) -import Data.Maybe -import Data.List ( sortBy ) -import Data.Ord ( comparing ) -import qualified Data.Map as Map -import System.FilePath -import System.Directory ( getCurrentDirectory ) - -import qualified Hoopl.Label as H -import qualified Hoopl.Collections as H - --- | Generate DWARF/debug information -dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] - -> IO (SDoc, UniqSupply) -dwarfGen _ _ us [] = return (empty, us) -dwarfGen df modLoc us blocks = do - - -- Convert debug data structures to DWARF info records - -- We strip out block information when running with -g0 or -g1. - let procs = debugSplitProcs blocks - stripBlocks dbg - | debugLevel df < 2 = dbg { dblBlocks = [] } - | otherwise = dbg - compPath <- getCurrentDirectory - let lowLabel = dblCLabel $ head procs - highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs - dwarfUnit = DwarfCompileUnit - { dwChildren = map (procToDwarf df) (map stripBlocks procs) - , dwName = fromMaybe "" (ml_hs_file modLoc) - , dwCompDir = addTrailingPathSeparator compPath - , dwProducer = cProjectName ++ " " ++ cProjectVersion - , dwLowLabel = lowLabel - , dwHighLabel = highLabel - , dwLineLabel = dwarfLineLabel - } - - -- Check whether we have any source code information, so we do not - -- end up writing a pointer to an empty .debug_line section - -- (dsymutil on Mac Os gets confused by this). - let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) - || any haveSrcIn (dblBlocks blk) - haveSrc = any haveSrcIn procs - - -- .debug_abbrev section: Declare the format we're using - let abbrevSct = pprAbbrevDecls haveSrc - - -- .debug_info section: Information records on procedures and blocks - let -- unique to identify start and end compilation unit .debug_inf - (unitU, us') = takeUniqFromSupply us - infoSct = vcat [ ptext dwarfInfoLabel <> colon - , dwarfInfoSection - , compileUnitHeader unitU - , pprDwarfInfo haveSrc dwarfUnit - , compileUnitFooter unitU - ] - - -- .debug_line section: Generated mainly by the assembler, but we - -- need to label it - let lineSct = dwarfLineSection $$ - ptext dwarfLineLabel <> colon - - -- .debug_frame section: Information about the layout of the GHC stack - let (framesU, us'') = takeUniqFromSupply us' - frameSct = dwarfFrameSection $$ - ptext dwarfFrameLabel <> colon $$ - pprDwarfFrame (debugFrame framesU procs) - - -- .aranges section: Information about the bounds of compilation units - let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs - | otherwise = [DwarfARange lowLabel highLabel] - let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU - - return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') - --- | Build an address range entry for one proc. --- With split sections, each proc needs its own entry, since they may get --- scattered in the final binary. Without split sections, we could make a --- single arange based on the first/last proc. -mkDwarfARange :: DebugBlock -> DwarfARange -mkDwarfARange proc = DwarfARange start end - where - start = dblCLabel proc - end = mkAsmTempEndLabel start - --- | Header for a compilation unit, establishing global format --- parameters -compileUnitHeader :: Unique -> SDoc -compileUnitHeader unitU = sdocWithPlatform $ \plat -> - let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field - length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel - <> text "-4" -- length of initialLength field - in vcat [ ppr cuLabel <> colon - , text "\t.long " <> length -- compilation unit size - , pprHalf 3 -- DWARF version - , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) - -- abbrevs offset - , text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size - ] - --- | Compilation unit footer, mainly establishing size of debug sections -compileUnitFooter :: Unique -> SDoc -compileUnitFooter unitU = - let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU - in ppr cuEndLabel <> colon - --- | Splits the blocks by procedures. In the result all nested blocks --- will come from the same procedure as the top-level block. See --- Note [Splitting DebugBlocks] for details. -debugSplitProcs :: [DebugBlock] -> [DebugBlock] -debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b - where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty - split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock] - split parent blk = H.mapInsert prc [blk'] nested - where prc = dblProcedure blk - blk' = blk { dblBlocks = own_blks - , dblParent = parent - } - own_blks = fromMaybe [] $ H.mapLookup prc nested - nested = mergeMaps $ map (split parent') $ dblBlocks blk - -- Figure out who should be the parent of nested blocks. - -- If @blk@ is optimized out then it isn't a good choice - -- and we just use its parent. - parent' - | Nothing <- dblPosition blk = parent - | otherwise = Just blk - -{- -Note [Splitting DebugBlocks] - -DWARF requires that we break up the nested DebugBlocks produced from -the C-- AST. For instance, we begin with tick trees containing nested procs. -For example, - - proc A [tick1, tick2] - block B [tick3] - proc C [tick4] - -when producing DWARF we need to procs (which are represented in DWARF as -TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for -this transform, pulling out the nested procs into top-level procs. - -However, in doing this we need to be careful to preserve the parentage of the -nested procs. This is the reason DebugBlocks carry the dblParent field, allowing -us to reorganize the above tree as, - - proc A [tick1, tick2] - block B [tick3] - proc C [tick4] parent=B - -Here we have annotated the new proc C with an attribute giving its original -parent, B. --} - --- | Generate DWARF info for a procedure debug block -procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo -procToDwarf df prc - = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc) - , dwName = case dblSourceTick prc of - Just s@SourceNote{} -> sourceName s - _otherwise -> showSDocDump df $ ppr $ dblLabel prc - , dwLabel = dblCLabel prc - , dwParent = fmap mkAsmTempDieLabel - $ mfilter goodParent - $ fmap dblCLabel (dblParent prc) - } - where - goodParent a | a == dblCLabel prc = False - -- Omit parent if it would be self-referential - goodParent a | not (externallyVisibleCLabel a) - , debugLevel df < 2 = False - -- We strip block information when running -g0 or -g1, don't - -- refer to blocks in that case. Fixes #14894. - goodParent _ = True - --- | Generate DWARF info for a block -blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo -blockToDwarf df blk - = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk) - ++ map (blockToDwarf df) (dblBlocks blk) - , dwLabel = dblCLabel blk - , dwMarker = marker - } - where - marker - | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk - | otherwise = Nothing -- block was optimized out - -tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo] -tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss] -tickToDwarf _ _ = [] - --- | Generates the data for the debug frame section, which encodes the --- desired stack unwind behaviour for the debugger -debugFrame :: Unique -> [DebugBlock] -> DwarfFrame -debugFrame u procs - = DwarfFrame { dwCieLabel = mkAsmTempLabel u - , dwCieInit = initUws - , dwCieProcs = map (procToFrame initUws) procs - } - where - initUws :: UnwindTable - initUws = Map.fromList [(Sp, Just (UwReg Sp 0))] - --- | Generates unwind information for a procedure debug block -procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc -procToFrame initUws blk - = DwarfFrameProc { dwFdeProc = dblCLabel blk - , dwFdeHasInfo = dblHasInfoTbl blk - , dwFdeBlocks = map (uncurry blockToFrame) - (setHasInfo blockUws) - } - where blockUws :: [(DebugBlock, [UnwindPoint])] - blockUws = map snd $ sortBy (comparing fst) $ flatten blk - - flatten :: DebugBlock - -> [(Int, (DebugBlock, [UnwindPoint]))] - flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks } - | Just p <- pos = (p, (b, uws')):nested - | otherwise = nested -- block was optimized out - where uws' = addDefaultUnwindings initUws uws - nested = concatMap flatten blocks - - -- | If the current procedure has an info table, then we also say that - -- its first block has one to ensure that it gets the necessary -1 - -- offset applied to its start address. - -- See Note [Info Offset] in Dwarf.Types. - setHasInfo :: [(DebugBlock, [UnwindPoint])] - -> [(DebugBlock, [UnwindPoint])] - setHasInfo [] = [] - setHasInfo (c0:cs) = first setIt c0 : cs - where - setIt child = - child { dblHasInfoTbl = dblHasInfoTbl child - || dblHasInfoTbl blk } - -blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock -blockToFrame blk uws - = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk - , dwFdeUnwind = uws - } - -addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint] -addDefaultUnwindings tbl pts = - [ UnwindPoint lbl (tbl' `mappend` tbl) - -- mappend is left-biased - | UnwindPoint lbl tbl' <- pts - ] diff --git a/nativeGen/Dwarf/Constants.hs b/nativeGen/Dwarf/Constants.hs deleted file mode 100644 --- a/nativeGen/Dwarf/Constants.hs +++ /dev/null @@ -1,229 +0,0 @@ --- | Constants describing the DWARF format. Most of this simply --- mirrors /usr/include/dwarf.h. - -module Dwarf.Constants where - -import GhcPrelude - -import AsmUtils -import FastString -import GHC.Platform -import Outputable - -import Reg -import X86.Regs - -import Data.Word - --- | Language ID used for Haskell. -dW_LANG_Haskell :: Word -dW_LANG_Haskell = 0x18 - -- Thanks to Nathan Howell for getting us our very own language ID! - --- * Dwarf tags -dW_TAG_compile_unit, dW_TAG_subroutine_type, - dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block, - dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type, - dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef, - dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable, - dW_TAG_ghc_src_note :: Word -dW_TAG_array_type = 1 -dW_TAG_lexical_block = 11 -dW_TAG_pointer_type = 15 -dW_TAG_compile_unit = 17 -dW_TAG_structure_type = 19 -dW_TAG_typedef = 22 -dW_TAG_subroutine_type = 32 -dW_TAG_subrange_type = 33 -dW_TAG_base_type = 36 -dW_TAG_file_type = 41 -dW_TAG_subprogram = 46 -dW_TAG_variable = 52 -dW_TAG_auto_variable = 256 -dW_TAG_arg_variable = 257 - -dW_TAG_ghc_src_note = 0x5b00 - --- * Dwarf attributes -dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language, - dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base, - dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word -dW_AT_name = 0x03 -dW_AT_stmt_list = 0x10 -dW_AT_low_pc = 0x11 -dW_AT_high_pc = 0x12 -dW_AT_language = 0x13 -dW_AT_comp_dir = 0x1b -dW_AT_producer = 0x25 -dW_AT_external = 0x3f -dW_AT_frame_base = 0x40 -dW_AT_use_UTF8 = 0x53 -dW_AT_MIPS_linkage_name = 0x2007 - --- * Custom DWARF attributes --- Chosen a more or less random section of the vendor-extensible region - --- ** Describing C-- blocks --- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks -dW_AT_ghc_tick_parent :: Word -dW_AT_ghc_tick_parent = 0x2b20 - --- ** Describing source notes --- These appear in DW_TAG_ghc_src_note DIEs -dW_AT_ghc_span_file, dW_AT_ghc_span_start_line, - dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line, - dW_AT_ghc_span_end_col :: Word -dW_AT_ghc_span_file = 0x2b00 -dW_AT_ghc_span_start_line = 0x2b01 -dW_AT_ghc_span_start_col = 0x2b02 -dW_AT_ghc_span_end_line = 0x2b03 -dW_AT_ghc_span_end_col = 0x2b04 - - --- * Abbrev declarations -dW_CHILDREN_no, dW_CHILDREN_yes :: Word8 -dW_CHILDREN_no = 0 -dW_CHILDREN_yes = 1 - -dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag, - dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word -dW_FORM_addr = 0x01 -dW_FORM_data2 = 0x05 -dW_FORM_data4 = 0x06 -dW_FORM_string = 0x08 -dW_FORM_flag = 0x0c -dW_FORM_block1 = 0x0a -dW_FORM_ref_addr = 0x10 -dW_FORM_ref4 = 0x13 -dW_FORM_flag_present = 0x19 - --- * Dwarf native types -dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed, - dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word -dW_ATE_address = 1 -dW_ATE_boolean = 2 -dW_ATE_float = 4 -dW_ATE_signed = 5 -dW_ATE_signed_char = 6 -dW_ATE_unsigned = 7 -dW_ATE_unsigned_char = 8 - --- * Call frame information -dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value, - dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression, - dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf, - dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression, - dW_CFA_offset :: Word8 -dW_CFA_set_loc = 0x01 -dW_CFA_undefined = 0x07 -dW_CFA_same_value = 0x08 -dW_CFA_def_cfa = 0x0c -dW_CFA_def_cfa_offset = 0x0e -dW_CFA_def_cfa_expression = 0x0f -dW_CFA_expression = 0x10 -dW_CFA_offset_extended_sf = 0x11 -dW_CFA_def_cfa_sf = 0x12 -dW_CFA_def_cfa_offset_sf = 0x13 -dW_CFA_val_offset = 0x14 -dW_CFA_val_expression = 0x16 -dW_CFA_offset = 0x80 - --- * Operations -dW_OP_addr, dW_OP_deref, dW_OP_consts, - dW_OP_minus, dW_OP_mul, dW_OP_plus, - dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8 -dW_OP_addr = 0x03 -dW_OP_deref = 0x06 -dW_OP_consts = 0x11 -dW_OP_minus = 0x1c -dW_OP_mul = 0x1e -dW_OP_plus = 0x22 -dW_OP_lit0 = 0x30 -dW_OP_breg0 = 0x70 -dW_OP_call_frame_cfa = 0x9c - --- * Dwarf section declarations -dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, - dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc -dwarfInfoSection = dwarfSection "info" -dwarfAbbrevSection = dwarfSection "abbrev" -dwarfLineSection = dwarfSection "line" -dwarfFrameSection = dwarfSection "frame" -dwarfGhcSection = dwarfSection "ghc" -dwarfARangesSection = dwarfSection "aranges" - -dwarfSection :: String -> SDoc -dwarfSection name = sdocWithPlatform $ \plat -> - case platformOS plat of - os | osElfTarget os - -> text "\t.section .debug_" <> text name <> text ",\"\"," - <> sectionType "progbits" - | osMachOTarget os - -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug" - | otherwise - -> text "\t.section .debug_" <> text name <> text ",\"dr\"" - --- * Dwarf section labels -dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString -dwarfInfoLabel = sLit ".Lsection_info" -dwarfAbbrevLabel = sLit ".Lsection_abbrev" -dwarfLineLabel = sLit ".Lsection_line" -dwarfFrameLabel = sLit ".Lsection_frame" - --- | Mapping of registers to DWARF register numbers -dwarfRegNo :: Platform -> Reg -> Word8 -dwarfRegNo p r = case platformArch p of - ArchX86 - | r == eax -> 0 - | r == ecx -> 1 -- yes, no typo - | r == edx -> 2 - | r == ebx -> 3 - | r == esp -> 4 - | r == ebp -> 5 - | r == esi -> 6 - | r == edi -> 7 - ArchX86_64 - | r == rax -> 0 - | r == rdx -> 1 -- this neither. The order GCC allocates registers in? - | r == rcx -> 2 - | r == rbx -> 3 - | r == rsi -> 4 - | r == rdi -> 5 - | r == rbp -> 6 - | r == rsp -> 7 - | r == r8 -> 8 - | r == r9 -> 9 - | r == r10 -> 10 - | r == r11 -> 11 - | r == r12 -> 12 - | r == r13 -> 13 - | r == r14 -> 14 - | r == r15 -> 15 - | r == xmm0 -> 17 - | r == xmm1 -> 18 - | r == xmm2 -> 19 - | r == xmm3 -> 20 - | r == xmm4 -> 21 - | r == xmm5 -> 22 - | r == xmm6 -> 23 - | r == xmm7 -> 24 - | r == xmm8 -> 25 - | r == xmm9 -> 26 - | r == xmm10 -> 27 - | r == xmm11 -> 28 - | r == xmm12 -> 29 - | r == xmm13 -> 30 - | r == xmm14 -> 31 - | r == xmm15 -> 32 - _other -> error "dwarfRegNo: Unsupported platform or unknown register!" - --- | Virtual register number to use for return address. -dwarfReturnRegNo :: Platform -> Word8 -dwarfReturnRegNo p - -- We "overwrite" IP with our pseudo register - that makes sense, as - -- when using this mechanism gdb already knows the IP anyway. Clang - -- does this too, so it must be safe. - = case platformArch p of - ArchX86 -> 8 -- eip - ArchX86_64 -> 16 -- rip - _other -> error "dwarfReturnRegNo: Unsupported platform!" diff --git a/nativeGen/Dwarf/Types.hs b/nativeGen/Dwarf/Types.hs deleted file mode 100644 --- a/nativeGen/Dwarf/Types.hs +++ /dev/null @@ -1,612 +0,0 @@ -module Dwarf.Types - ( -- * Dwarf information - DwarfInfo(..) - , pprDwarfInfo - , pprAbbrevDecls - -- * Dwarf address range table - , DwarfARange(..) - , pprDwarfARanges - -- * Dwarf frame - , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..) - , pprDwarfFrame - -- * Utilities - , pprByte - , pprHalf - , pprData4' - , pprDwWord - , pprWord - , pprLEBWord - , pprLEBInt - , wordAlign - , sectionOffset - ) - where - -import GhcPrelude - -import Debug -import CLabel -import CmmExpr ( GlobalReg(..) ) -import Encoding -import FastString -import Outputable -import GHC.Platform -import Unique -import Reg -import SrcLoc -import Util - -import Dwarf.Constants - -import qualified Data.ByteString as BS -import qualified Control.Monad.Trans.State.Strict as S -import Control.Monad (zipWithM, join) -import Data.Bits -import qualified Data.Map as Map -import Data.Word -import Data.Char - -import GHC.Platform.Regs - --- | Individual dwarf records. Each one will be encoded as an entry in --- the @.debug_info@ section. -data DwarfInfo - = DwarfCompileUnit { dwChildren :: [DwarfInfo] - , dwName :: String - , dwProducer :: String - , dwCompDir :: String - , dwLowLabel :: CLabel - , dwHighLabel :: CLabel - , dwLineLabel :: PtrString } - | DwarfSubprogram { dwChildren :: [DwarfInfo] - , dwName :: String - , dwLabel :: CLabel - , dwParent :: Maybe CLabel - -- ^ label of DIE belonging to the parent tick - } - | DwarfBlock { dwChildren :: [DwarfInfo] - , dwLabel :: CLabel - , dwMarker :: Maybe CLabel - } - | DwarfSrcNote { dwSrcSpan :: RealSrcSpan - } - --- | Abbreviation codes used for encoding above records in the --- @.debug_info@ section. -data DwarfAbbrev - = DwAbbrNull -- ^ Pseudo, used for marking the end of lists - | DwAbbrCompileUnit - | DwAbbrSubprogram - | DwAbbrSubprogramWithParent - | DwAbbrBlockWithoutCode - | DwAbbrBlock - | DwAbbrGhcSrcNote - deriving (Eq, Enum) - --- | Generate assembly for the given abbreviation code -pprAbbrev :: DwarfAbbrev -> SDoc -pprAbbrev = pprLEBWord . fromIntegral . fromEnum - --- | Abbreviation declaration. This explains the binary encoding we --- use for representing 'DwarfInfo'. Be aware that this must be updated --- along with 'pprDwarfInfo'. -pprAbbrevDecls :: Bool -> SDoc -pprAbbrevDecls haveDebugLine = - let mkAbbrev abbr tag chld flds = - let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form - in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$ - vcat (map fld flds) $$ pprByte 0 $$ pprByte 0 - -- These are shared between DwAbbrSubprogram and - -- DwAbbrSubprogramWithParent - subprogramAttrs = - [ (dW_AT_name, dW_FORM_string) - , (dW_AT_MIPS_linkage_name, dW_FORM_string) - , (dW_AT_external, dW_FORM_flag) - , (dW_AT_low_pc, dW_FORM_addr) - , (dW_AT_high_pc, dW_FORM_addr) - , (dW_AT_frame_base, dW_FORM_block1) - ] - in dwarfAbbrevSection $$ - ptext dwarfAbbrevLabel <> colon $$ - mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes - ([(dW_AT_name, dW_FORM_string) - , (dW_AT_producer, dW_FORM_string) - , (dW_AT_language, dW_FORM_data4) - , (dW_AT_comp_dir, dW_FORM_string) - , (dW_AT_use_UTF8, dW_FORM_flag_present) -- not represented in body - , (dW_AT_low_pc, dW_FORM_addr) - , (dW_AT_high_pc, dW_FORM_addr) - ] ++ - (if haveDebugLine - then [ (dW_AT_stmt_list, dW_FORM_data4) ] - else [])) $$ - mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes - subprogramAttrs $$ - mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes - (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$ - mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes - [ (dW_AT_name, dW_FORM_string) - ] $$ - mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes - [ (dW_AT_name, dW_FORM_string) - , (dW_AT_low_pc, dW_FORM_addr) - , (dW_AT_high_pc, dW_FORM_addr) - ] $$ - mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no - [ (dW_AT_ghc_span_file, dW_FORM_string) - , (dW_AT_ghc_span_start_line, dW_FORM_data4) - , (dW_AT_ghc_span_start_col, dW_FORM_data2) - , (dW_AT_ghc_span_end_line, dW_FORM_data4) - , (dW_AT_ghc_span_end_col, dW_FORM_data2) - ] $$ - pprByte 0 - --- | Generate assembly for DWARF data -pprDwarfInfo :: Bool -> DwarfInfo -> SDoc -pprDwarfInfo haveSrc d - = case d of - DwarfCompileUnit {} -> hasChildren - DwarfSubprogram {} -> hasChildren - DwarfBlock {} -> hasChildren - DwarfSrcNote {} -> noChildren - where - hasChildren = - pprDwarfInfoOpen haveSrc d $$ - vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$ - pprDwarfInfoClose - noChildren = pprDwarfInfoOpen haveSrc d - --- | Prints assembler data corresponding to DWARF info records. Note --- that the binary format of this is parameterized in @abbrevDecls@ and --- has to be kept in synch. -pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc -pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel - highLabel lineLbl) = - pprAbbrev DwAbbrCompileUnit - $$ pprString name - $$ pprString producer - $$ pprData4 dW_LANG_Haskell - $$ pprString compDir - $$ pprWord (ppr lowLabel) - $$ pprWord (ppr highLabel) - $$ if haveSrc - then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel) - else empty -pprDwarfInfoOpen _ (DwarfSubprogram _ name label - parent) = sdocWithDynFlags $ \df -> - ppr (mkAsmTempDieLabel label) <> colon - $$ pprAbbrev abbrev - $$ pprString name - $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) - $$ pprFlag (externallyVisibleCLabel label) - $$ pprWord (ppr label) - $$ pprWord (ppr $ mkAsmTempEndLabel label) - $$ pprByte 1 - $$ pprByte dW_OP_call_frame_cfa - $$ parentValue - where - abbrev = case parent of Nothing -> DwAbbrSubprogram - Just _ -> DwAbbrSubprogramWithParent - parentValue = maybe empty pprParentDie parent - pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel) -pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df -> - ppr (mkAsmTempDieLabel label) <> colon - $$ pprAbbrev DwAbbrBlockWithoutCode - $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) -pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df -> - ppr (mkAsmTempDieLabel label) <> colon - $$ pprAbbrev DwAbbrBlock - $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) - $$ pprWord (ppr marker) - $$ pprWord (ppr $ mkAsmTempEndLabel marker) -pprDwarfInfoOpen _ (DwarfSrcNote ss) = - pprAbbrev DwAbbrGhcSrcNote - $$ pprString' (ftext $ srcSpanFile ss) - $$ pprData4 (fromIntegral $ srcSpanStartLine ss) - $$ pprHalf (fromIntegral $ srcSpanStartCol ss) - $$ pprData4 (fromIntegral $ srcSpanEndLine ss) - $$ pprHalf (fromIntegral $ srcSpanEndCol ss) - --- | Close a DWARF info record with children -pprDwarfInfoClose :: SDoc -pprDwarfInfoClose = pprAbbrev DwAbbrNull - --- | A DWARF address range. This is used by the debugger to quickly locate --- which compilation unit a given address belongs to. This type assumes --- a non-segmented address-space. -data DwarfARange - = DwarfARange - { dwArngStartLabel :: CLabel - , dwArngEndLabel :: CLabel - } - --- | Print assembler directives corresponding to a DWARF @.debug_aranges@ --- address table entry. -pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc -pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat -> - let wordSize = platformWordSizeInBytes plat - paddingSize = 4 :: Int - -- header is 12 bytes long. - -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform). - -- pad such that first entry begins at multiple of entry size. - pad n = vcat $ replicate n $ pprByte 0 - -- Fix for #17428 - initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize - in pprDwWord (ppr initialLength) - $$ pprHalf 2 - $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU) - (ptext dwarfInfoLabel) - $$ pprByte (fromIntegral wordSize) - $$ pprByte 0 - $$ pad paddingSize - -- body - $$ vcat (map pprDwarfARange arngs) - -- terminus - $$ pprWord (char '0') - $$ pprWord (char '0') - -pprDwarfARange :: DwarfARange -> SDoc -pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length - where - length = ppr (dwArngEndLabel arng) - <> char '-' <> ppr (dwArngStartLabel arng) - --- | Information about unwind instructions for a procedure. This --- corresponds to a "Common Information Entry" (CIE) in DWARF. -data DwarfFrame - = DwarfFrame - { dwCieLabel :: CLabel - , dwCieInit :: UnwindTable - , dwCieProcs :: [DwarfFrameProc] - } - --- | Unwind instructions for an individual procedure. Corresponds to a --- "Frame Description Entry" (FDE) in DWARF. -data DwarfFrameProc - = DwarfFrameProc - { dwFdeProc :: CLabel - , dwFdeHasInfo :: Bool - , dwFdeBlocks :: [DwarfFrameBlock] - -- ^ List of blocks. Order must match asm! - } - --- | Unwind instructions for a block. Will become part of the --- containing FDE. -data DwarfFrameBlock - = DwarfFrameBlock - { dwFdeBlkHasInfo :: Bool - , dwFdeUnwind :: [UnwindPoint] - -- ^ these unwind points must occur in the same order as they occur - -- in the block - } - -instance Outputable DwarfFrameBlock where - ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds - --- | Header for the @.debug_frame@ section. Here we emit the "Common --- Information Entry" record that etablishes general call frame --- parameters and the default stack layout. -pprDwarfFrame :: DwarfFrame -> SDoc -pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} - = sdocWithPlatform $ \plat -> - let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") - cieEndLabel = mkAsmTempEndLabel cieLabel - length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel - spReg = dwarfGlobalRegNo plat Sp - retReg = dwarfReturnRegNo plat - wordSize = platformWordSizeInBytes plat - pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc - pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw) - - -- Preserve C stack pointer: This necessary to override that default - -- unwinding behavior of setting $sp = CFA. - preserveSp = case platformArch plat of - ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 - ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 - _ -> empty - in vcat [ ppr cieLabel <> colon - , pprData4' length -- Length of CIE - , ppr cieStartLabel <> colon - , pprData4' (text "-1") - -- Common Information Entry marker (-1 = 0xf..f) - , pprByte 3 -- CIE version (we require DWARF 3) - , pprByte 0 -- Augmentation (none) - , pprByte 1 -- Code offset multiplicator - , pprByte (128-fromIntegral wordSize) - -- Data offset multiplicator - -- (stacks grow down => "-w" in signed LEB128) - , pprByte retReg -- virtual register holding return address - ] $$ - -- Initial unwind table - vcat (map pprInit $ Map.toList cieInit) $$ - vcat [ -- RET = *CFA - pprByte (dW_CFA_offset+retReg) - , pprByte 0 - - -- Preserve C stack pointer - , preserveSp - - -- Sp' = CFA - -- (we need to set this manually as our (STG) Sp register is - -- often not the architecture's default stack register) - , pprByte dW_CFA_val_offset - , pprLEBWord (fromIntegral spReg) - , pprLEBWord 0 - ] $$ - wordAlign $$ - ppr cieEndLabel <> colon $$ - -- Procedure unwind tables - vcat (map (pprFrameProc cieLabel cieInit) procs) - --- | Writes a "Frame Description Entry" for a procedure. This consists --- mainly of referencing the CIE and writing state machine --- instructions to describe how the frame base (CFA) changes. -pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc -pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) - = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") - fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") - procEnd = mkAsmTempEndLabel procLbl - ifInfo str = if hasInfo then text str else empty - -- see [Note: Info Offset] - in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon - , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel) - , ppr fdeLabel <> colon - , pprData4' (ppr frameLbl <> char '-' <> - ptext dwarfFrameLabel) -- Reference to CIE - , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer - , pprWord (ppr procEnd <> char '-' <> - ppr procLbl <> ifInfo "+1") -- Block byte length - ] $$ - vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$ - wordAlign $$ - ppr fdeEndLabel <> colon - --- | Generates unwind information for a block. We only generate --- instructions where unwind information actually changes. This small --- optimisations saves a lot of space, as subsequent blocks often have --- the same unwind information. -pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc -pprFrameBlock (DwarfFrameBlock hasInfo uws0) = - vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0 - where - pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc - pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws -> - let -- Did a register's unwind expression change? - isChanged :: GlobalReg -> Maybe UnwindExpr - -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr) - isChanged g new - -- the value didn't change - | Just new == old = Nothing - -- the value was and still is undefined - | Nothing <- old - , Nothing <- new = Nothing - -- the value changed - | otherwise = Just (join old, new) - where - old = Map.lookup g oldUws - - changed = Map.toList $ Map.mapMaybeWithKey isChanged uws - - in if oldUws == uws - then (empty, oldUws) - else let -- see [Note: Info Offset] - needsOffset = firstDecl && hasInfo - lblDoc = ppr lbl <> - if needsOffset then text "-1" else empty - doc = sdocWithPlatform $ \plat -> - pprByte dW_CFA_set_loc $$ pprWord lblDoc $$ - vcat (map (uncurry $ pprSetUnwind plat) changed) - in (doc, uws) - --- Note [Info Offset] --- --- GDB was pretty much written with C-like programs in mind, and as a --- result they assume that once you have a return address, it is a --- good idea to look at (PC-1) to unwind further - as that's where the --- "call" instruction is supposed to be. --- --- Now on one hand, code generated by GHC looks nothing like what GDB --- expects, and in fact going up from a return pointer is guaranteed --- to land us inside an info table! On the other hand, that actually --- gives us some wiggle room, as we expect IP to never *actually* end --- up inside the info table, so we can "cheat" by putting whatever GDB --- expects to see there. This is probably pretty safe, as GDB cannot --- assume (PC-1) to be a valid code pointer in the first place - and I --- have seen no code trying to correct this. --- --- Note that this will not prevent GDB from failing to look-up the --- correct function name for the frame, as that uses the symbol table, --- which we can not manipulate as easily. --- --- There's a GDB patch to address this at [1]. At the moment of writing --- it's not merged, so I recommend building GDB with the patch if you --- care about unwinding. The hack above doesn't cover every case. --- --- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html - --- | Get DWARF register ID for a given GlobalReg -dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8 -dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p -dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg - --- | Generate code for setting the unwind information for a register, --- optimized using its known old value in the table. Note that "Sp" is --- special: We see it as synonym for the CFA. -pprSetUnwind :: Platform - -> GlobalReg - -- ^ the register to produce an unwinding table entry for - -> (Maybe UnwindExpr, Maybe UnwindExpr) - -- ^ the old and new values of the register - -> SDoc -pprSetUnwind plat g (_, Nothing) - = pprUndefUnwind plat g -pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s' - = if o' >= 0 - then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') - else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' -pprSetUnwind plat Sp (_, Just (UwReg s' o')) - = if o' >= 0 - then pprByte dW_CFA_def_cfa $$ - pprLEBRegNo plat s' $$ - pprLEBWord (fromIntegral o') - else pprByte dW_CFA_def_cfa_sf $$ - pprLEBRegNo plat s' $$ - pprLEBInt o' -pprSetUnwind _ Sp (_, Just uw) - = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw -pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) - | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case - = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ - pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat)) - | otherwise - = pprByte dW_CFA_offset_extended_sf $$ - pprLEBRegNo plat g $$ - pprLEBInt o -pprSetUnwind plat g (_, Just (UwDeref uw)) - = pprByte dW_CFA_expression $$ - pprLEBRegNo plat g $$ - pprUnwindExpr True uw -pprSetUnwind plat g (_, Just (UwReg g' 0)) - | g == g' - = pprByte dW_CFA_same_value $$ - pprLEBRegNo plat g -pprSetUnwind plat g (_, Just uw) - = pprByte dW_CFA_val_expression $$ - pprLEBRegNo plat g $$ - pprUnwindExpr True uw - --- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 --- encoded number. -pprLEBRegNo :: Platform -> GlobalReg -> SDoc -pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat - --- | Generates a DWARF expression for the given unwind expression. If --- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets --- mentioned. -pprUnwindExpr :: Bool -> UnwindExpr -> SDoc -pprUnwindExpr spIsCFA expr - = sdocWithPlatform $ \plat -> - let pprE (UwConst i) - | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) - | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... - pprE (UwReg Sp i) | spIsCFA - = if i == 0 - then pprByte dW_OP_call_frame_cfa - else pprE (UwPlus (UwReg Sp 0) (UwConst i)) - pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$ - pprLEBInt i - pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref - pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord (ppr l) - pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus - pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus - pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul - in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length - -- computed as the difference of the following local labels 2: and 1: - text "1:" $$ - pprE expr $$ - text "2:" - --- | Generate code for re-setting the unwind information for a --- register to @undefined@ -pprUndefUnwind :: Platform -> GlobalReg -> SDoc -pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ - pprLEBRegNo plat g - - --- | Align assembly at (machine) word boundary -wordAlign :: SDoc -wordAlign = sdocWithPlatform $ \plat -> - text "\t.align " <> case platformOS plat of - OSDarwin -> case platformWordSize plat of - PW8 -> char '3' - PW4 -> char '2' - _other -> ppr (platformWordSizeInBytes plat) - --- | Assembly for a single byte of constant DWARF data -pprByte :: Word8 -> SDoc -pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word) - --- | Assembly for a two-byte constant integer -pprHalf :: Word16 -> SDoc -pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word) - --- | Assembly for a constant DWARF flag -pprFlag :: Bool -> SDoc -pprFlag f = pprByte (if f then 0xff else 0x00) - --- | Assembly for 4 bytes of dynamic DWARF data -pprData4' :: SDoc -> SDoc -pprData4' x = text "\t.long " <> x - --- | Assembly for 4 bytes of constant DWARF data -pprData4 :: Word -> SDoc -pprData4 = pprData4' . ppr - --- | Assembly for a DWARF word of dynamic data. This means 32 bit, as --- we are generating 32 bit DWARF. -pprDwWord :: SDoc -> SDoc -pprDwWord = pprData4' - --- | Assembly for a machine word of dynamic data. Depends on the --- architecture we are currently generating code for. -pprWord :: SDoc -> SDoc -pprWord s = (<> s) . sdocWithPlatform $ \plat -> - case platformWordSize plat of - PW4 -> text "\t.long " - PW8 -> text "\t.quad " - --- | Prints a number in "little endian base 128" format. The idea is --- to optimize for small numbers by stopping once all further bytes --- would be 0. The highest bit in every byte signals whether there --- are further bytes to read. -pprLEBWord :: Word -> SDoc -pprLEBWord x | x < 128 = pprByte (fromIntegral x) - | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ - pprLEBWord (x `shiftR` 7) - --- | Same as @pprLEBWord@, but for a signed number -pprLEBInt :: Int -> SDoc -pprLEBInt x | x >= -64 && x < 64 - = pprByte (fromIntegral (x .&. 127)) - | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ - pprLEBInt (x `shiftR` 7) - --- | Generates a dynamic null-terminated string. If required the --- caller needs to make sure that the string is escaped properly. -pprString' :: SDoc -> SDoc -pprString' str = text "\t.asciz \"" <> str <> char '"' - --- | Generate a string constant. We take care to escape the string. -pprString :: String -> SDoc -pprString str - = pprString' $ hcat $ map escapeChar $ - if str `lengthIs` utf8EncodedLength str - then str - else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str - --- | Escape a single non-unicode character -escapeChar :: Char -> SDoc -escapeChar '\\' = text "\\\\" -escapeChar '\"' = text "\\\"" -escapeChar '\n' = text "\\n" -escapeChar c - | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings - = char c - | otherwise - = char '\\' <> char (intToDigit (ch `div` 64)) <> - char (intToDigit ((ch `div` 8) `mod` 8)) <> - char (intToDigit (ch `mod` 8)) - where ch = ord c - --- | Generate an offset into another section. This is tricky because --- this is handled differently depending on platform: Mac Os expects --- us to calculate the offset using assembler arithmetic. Linux expects --- us to just reference the target directly, and will figure out on --- their own that we actually need an offset. Finally, Windows has --- a special directive to refer to relative offsets. Fun. -sectionOffset :: SDoc -> SDoc -> SDoc -sectionOffset target section = sdocWithPlatform $ \plat -> - case platformOS plat of - OSDarwin -> pprDwWord (target <> char '-' <> section) - OSMinGW32 -> text "\t.secrel32 " <> target - _other -> pprDwWord target diff --git a/nativeGen/Format.hs b/nativeGen/Format.hs deleted file mode 100644 --- a/nativeGen/Format.hs +++ /dev/null @@ -1,105 +0,0 @@ --- | Formats on this architecture --- A Format is a combination of width and class --- --- TODO: Signed vs unsigned? --- --- TODO: This module is currenly shared by all architectures because --- NCGMonad need to know about it to make a VReg. It would be better --- to have architecture specific formats, and do the overloading --- properly. eg SPARC doesn't care about FF80. --- -module Format ( - Format(..), - intFormat, - floatFormat, - isFloatFormat, - cmmTypeFormat, - formatToWidth, - formatInBytes -) - -where - -import GhcPrelude - -import Cmm -import Outputable - --- It looks very like the old MachRep, but it's now of purely local --- significance, here in the native code generator. You can change it --- without global consequences. --- --- A major use is as an opcode qualifier; thus the opcode --- mov.l a b --- might be encoded --- MOV II32 a b --- where the Format field encodes the ".l" part. - --- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats --- here. I've removed them from the x86 version, we'll see what happens --SDM - --- ToDo: quite a few occurrences of Format could usefully be replaced by Width - -data Format - = II8 - | II16 - | II32 - | II64 - | FF32 - | FF64 - deriving (Show, Eq) - - --- | Get the integer format of this width. -intFormat :: Width -> Format -intFormat width - = case width of - W8 -> II8 - W16 -> II16 - W32 -> II32 - W64 -> II64 - other -> sorry $ "The native code generator cannot " ++ - "produce code for Format.intFormat " ++ show other - ++ "\n\tConsider using the llvm backend with -fllvm" - - --- | Get the float format of this width. -floatFormat :: Width -> Format -floatFormat width - = case width of - W32 -> FF32 - W64 -> FF64 - - other -> pprPanic "Format.floatFormat" (ppr other) - - --- | Check if a format represents a floating point value. -isFloatFormat :: Format -> Bool -isFloatFormat format - = case format of - FF32 -> True - FF64 -> True - _ -> False - - --- | Convert a Cmm type to a Format. -cmmTypeFormat :: CmmType -> Format -cmmTypeFormat ty - | isFloatType ty = floatFormat (typeWidth ty) - | otherwise = intFormat (typeWidth ty) - - --- | Get the Width of a Format. -formatToWidth :: Format -> Width -formatToWidth format - = case format of - II8 -> W8 - II16 -> W16 - II32 -> W32 - II64 -> W64 - FF32 -> W32 - FF64 -> W64 - - -formatInBytes :: Format -> Int -formatInBytes = widthInBytes . formatToWidth diff --git a/nativeGen/Instruction.hs b/nativeGen/Instruction.hs deleted file mode 100644 --- a/nativeGen/Instruction.hs +++ /dev/null @@ -1,202 +0,0 @@ - -module Instruction ( - RegUsage(..), - noUsage, - GenBasicBlock(..), blockId, - ListGraph(..), - NatCmm, - NatCmmDecl, - NatBasicBlock, - topInfoTable, - entryBlocks, - Instruction(..) -) - -where - -import GhcPrelude - -import Reg - -import BlockId -import Hoopl.Collections -import Hoopl.Label -import DynFlags -import Cmm hiding (topInfoTable) -import GHC.Platform - --- | Holds a list of source and destination registers used by a --- particular instruction. --- --- Machine registers that are pre-allocated to stgRegs are filtered --- out, because they are uninteresting from a register allocation --- standpoint. (We wouldn't want them to end up on the free list!) --- --- As far as we are concerned, the fixed registers simply don't exist --- (for allocation purposes, anyway). --- -data RegUsage - = RU [Reg] [Reg] - --- | No regs read or written to. -noUsage :: RegUsage -noUsage = RU [] [] - --- Our flavours of the Cmm types --- Type synonyms for Cmm populated with native code -type NatCmm instr - = GenCmmGroup - CmmStatics - (LabelMap CmmStatics) - (ListGraph instr) - -type NatCmmDecl statics instr - = GenCmmDecl - statics - (LabelMap CmmStatics) - (ListGraph instr) - - -type NatBasicBlock instr - = GenBasicBlock instr - - --- | Returns the info table associated with the CmmDecl's entry point, --- if any. -topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i -topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) - = mapLookup (blockId b) infos -topInfoTable _ - = Nothing - --- | Return the list of BlockIds in a CmmDecl that are entry points --- for this proc (i.e. they may be jumped to from outside this proc). -entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId] -entryBlocks (CmmProc info _ _ (ListGraph code)) = entries - where - infos = mapKeys info - entries = case code of - [] -> infos - BasicBlock entry _ : _ -- first block is the entry point - | entry `elem` infos -> infos - | otherwise -> entry : infos -entryBlocks _ = [] - --- | Common things that we can do with instructions, on all architectures. --- These are used by the shared parts of the native code generator, --- specifically the register allocators. --- -class Instruction instr where - - -- | Get the registers that are being used by this instruction. - -- regUsage doesn't need to do any trickery for jumps and such. - -- Just state precisely the regs read and written by that insn. - -- The consequences of control flow transfers, as far as register - -- allocation goes, are taken care of by the register allocator. - -- - regUsageOfInstr - :: Platform - -> instr - -> RegUsage - - - -- | Apply a given mapping to all the register references in this - -- instruction. - patchRegsOfInstr - :: instr - -> (Reg -> Reg) - -> instr - - - -- | Checks whether this instruction is a jump/branch instruction. - -- One that can change the flow of control in a way that the - -- register allocator needs to worry about. - isJumpishInstr - :: instr -> Bool - - - -- | Give the possible destinations of this jump instruction. - -- Must be defined for all jumpish instructions. - jumpDestsOfInstr - :: instr -> [BlockId] - - - -- | Change the destination of this jump instruction. - -- Used in the linear allocator when adding fixup blocks for join - -- points. - patchJumpInstr - :: instr - -> (BlockId -> BlockId) - -> instr - - - -- | An instruction to spill a register into a spill slot. - mkSpillInstr - :: DynFlags - -> Reg -- ^ the reg to spill - -> Int -- ^ the current stack delta - -> Int -- ^ spill slot to use - -> instr - - - -- | An instruction to reload a register from a spill slot. - mkLoadInstr - :: DynFlags - -> Reg -- ^ the reg to reload. - -> Int -- ^ the current stack delta - -> Int -- ^ the spill slot to use - -> instr - - -- | See if this instruction is telling us the current C stack delta - takeDeltaInstr - :: instr - -> Maybe Int - - -- | Check whether this instruction is some meta thing inserted into - -- the instruction stream for other purposes. - -- - -- Not something that has to be treated as a real machine instruction - -- and have its registers allocated. - -- - -- eg, comments, delta, ldata, etc. - isMetaInstr - :: instr - -> Bool - - - - -- | Copy the value in a register to another one. - -- Must work for all register classes. - mkRegRegMoveInstr - :: Platform - -> Reg -- ^ source register - -> Reg -- ^ destination register - -> instr - - -- | Take the source and destination from this reg -> reg move instruction - -- or Nothing if it's not one - takeRegRegMoveInstr - :: instr - -> Maybe (Reg, Reg) - - -- | Make an unconditional jump instruction. - -- For architectures with branch delay slots, its ok to put - -- a NOP after the jump. Don't fill the delay slot with an - -- instruction that references regs or you'll confuse the - -- linear allocator. - mkJumpInstr - :: BlockId - -> [instr] - - - -- Subtract an amount from the C stack pointer - mkStackAllocInstr - :: Platform - -> Int - -> [instr] - - -- Add an amount to the C stack pointer - mkStackDeallocInstr - :: Platform - -> Int - -> [instr] diff --git a/nativeGen/NCGMonad.hs b/nativeGen/NCGMonad.hs deleted file mode 100644 --- a/nativeGen/NCGMonad.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE BangPatterns #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1993-2004 --- --- The native code generator's monad. --- --- ----------------------------------------------------------------------------- - -module NCGMonad ( - NcgImpl(..), - NatM_State(..), mkNatM_State, - - NatM, -- instance Monad - initNat, - addImportNat, - addNodeBetweenNat, - addImmediateSuccessorNat, - updateCfgNat, - getUniqueNat, - mapAccumLNat, - setDeltaNat, - getDeltaNat, - getThisModuleNat, - getBlockIdNat, - getNewLabelNat, - getNewRegNat, - getNewRegPairNat, - getPicBaseMaybeNat, - getPicBaseNat, - getDynFlags, - getModLoc, - getFileId, - getDebugBlock, - - DwarfFiles -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import Reg -import Format -import TargetReg - -import BlockId -import Hoopl.Collections -import Hoopl.Label -import CLabel ( CLabel ) -import Debug -import FastString ( FastString ) -import UniqFM -import UniqSupply -import Unique ( Unique ) -import DynFlags -import Module - -import Control.Monad ( ap ) - -import Instruction -import Outputable (SDoc, pprPanic, ppr) -import Cmm (RawCmmDecl, CmmStatics) -import CFG - -data NcgImpl statics instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], - generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), - getJumpDestBlockId :: jumpDest -> Maybe BlockId, - canShortcut :: instr -> Maybe jumpDest, - shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, - shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, - maxSpillSlots :: Int, - allocatableRegs :: [RealReg], - ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], - ncgAllocMoreStack :: Int -> NatCmmDecl statics instr - -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]), - -- ^ The list of block ids records the redirected jumps to allow us to update - -- the CFG. - ncgMakeFarBranches :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr], - extractUnwindPoints :: [instr] -> [UnwindPoint], - -- ^ given the instruction sequence of a block, produce a list of - -- the block's 'UnwindPoint's - -- See Note [What is this unwinding business?] in Debug - -- and Note [Unwinding information in the NCG] in this module. - invertCondBranches :: Maybe CFG -> LabelMap CmmStatics -> [NatBasicBlock instr] - -> [NatBasicBlock instr] - -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; ` - -- when possible. - } - -data NatM_State - = NatM_State { - natm_us :: UniqSupply, - natm_delta :: Int, - natm_imports :: [(CLabel)], - natm_pic :: Maybe Reg, - natm_dflags :: DynFlags, - natm_this_module :: Module, - natm_modloc :: ModLocation, - natm_fileid :: DwarfFiles, - natm_debug_map :: LabelMap DebugBlock, - natm_cfg :: CFG - -- ^ Having a CFG with additional information is essential for some - -- operations. However we can't reconstruct all information once we - -- generated instructions. So instead we update the CFG as we go. - } - -type DwarfFiles = UniqFM (FastString, Int) - -newtype NatM result = NatM (NatM_State -> (result, NatM_State)) - deriving (Functor) - -unNat :: NatM a -> NatM_State -> (a, NatM_State) -unNat (NatM a) = a - -mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation -> - DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State -mkNatM_State us delta dflags this_mod - = \loc dwf dbg cfg -> - NatM_State - { natm_us = us - , natm_delta = delta - , natm_imports = [] - , natm_pic = Nothing - , natm_dflags = dflags - , natm_this_module = this_mod - , natm_modloc = loc - , natm_fileid = dwf - , natm_debug_map = dbg - , natm_cfg = cfg - } - -initNat :: NatM_State -> NatM a -> (a, NatM_State) -initNat init_st m - = case unNat m init_st of { (r,st) -> (r,st) } - -instance Applicative NatM where - pure = returnNat - (<*>) = ap - -instance Monad NatM where - (>>=) = thenNat - -instance MonadUnique NatM where - getUniqueSupplyM = NatM $ \st -> - case splitUniqSupply (natm_us st) of - (us1, us2) -> (us1, st {natm_us = us2}) - - getUniqueM = NatM $ \st -> - case takeUniqFromSupply (natm_us st) of - (uniq, us') -> (uniq, st {natm_us = us'}) - -thenNat :: NatM a -> (a -> NatM b) -> NatM b -thenNat expr cont - = NatM $ \st -> case unNat expr st of - (result, st') -> unNat (cont result) st' - -returnNat :: a -> NatM a -returnNat result - = NatM $ \st -> (result, st) - -mapAccumLNat :: (acc -> x -> NatM (acc, y)) - -> acc - -> [x] - -> NatM (acc, [y]) - -mapAccumLNat _ b [] - = return (b, []) -mapAccumLNat f b (x:xs) - = do (b__2, x__2) <- f b x - (b__3, xs__2) <- mapAccumLNat f b__2 xs - return (b__3, x__2:xs__2) - -getUniqueNat :: NatM Unique -getUniqueNat = NatM $ \ st -> - case takeUniqFromSupply $ natm_us st of - (uniq, us') -> (uniq, st {natm_us = us'}) - -instance HasDynFlags NatM where - getDynFlags = NatM $ \ st -> (natm_dflags st, st) - - -getDeltaNat :: NatM Int -getDeltaNat = NatM $ \ st -> (natm_delta st, st) - - -setDeltaNat :: Int -> NatM () -setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) - - -getThisModuleNat :: NatM Module -getThisModuleNat = NatM $ \ st -> (natm_this_module st, st) - - -addImportNat :: CLabel -> NatM () -addImportNat imp - = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st}) - -updateCfgNat :: (CFG -> CFG) -> NatM () -updateCfgNat f - = NatM $ \ st -> let !cfg' = f (natm_cfg st) - in ((), st { natm_cfg = cfg'}) - --- | Record that we added a block between `from` and `old`. -addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM () -addNodeBetweenNat from between to - = do df <- getDynFlags - let jmpWeight = fromIntegral . uncondWeight . - cfgWeightInfo $ df - updateCfgNat (updateCfg jmpWeight from between to) - where - -- When transforming A -> B to A -> A' -> B - -- A -> A' keeps the old edge info while - -- A' -> B gets the info for an unconditional - -- jump. - updateCfg weight from between old m - | Just info <- getEdgeInfo from old m - = addEdge from between info . - addWeightEdge between old weight . - delEdge from old $ m - | otherwise - = pprPanic "Faild to update cfg: Untracked edge" (ppr (from,to)) - - --- | Place `succ` after `block` and change any edges --- block -> X to `succ` -> X -addImmediateSuccessorNat :: BlockId -> BlockId -> NatM () -addImmediateSuccessorNat block succ - = updateCfgNat (addImmediateSuccessor block succ) - -getBlockIdNat :: NatM BlockId -getBlockIdNat - = do u <- getUniqueNat - return (mkBlockId u) - - -getNewLabelNat :: NatM CLabel -getNewLabelNat - = blockLbl <$> getBlockIdNat - - -getNewRegNat :: Format -> NatM Reg -getNewRegNat rep - = do u <- getUniqueNat - dflags <- getDynFlags - return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) - - -getNewRegPairNat :: Format -> NatM (Reg,Reg) -getNewRegPairNat rep - = do u <- getUniqueNat - dflags <- getDynFlags - let vLo = targetMkVirtualReg (targetPlatform dflags) u rep - let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep - let hi = RegVirtual $ getHiVirtualRegFromLo vLo - return (lo, hi) - - -getPicBaseMaybeNat :: NatM (Maybe Reg) -getPicBaseMaybeNat - = NatM (\state -> (natm_pic state, state)) - - -getPicBaseNat :: Format -> NatM Reg -getPicBaseNat rep - = do mbPicBase <- getPicBaseMaybeNat - case mbPicBase of - Just picBase -> return picBase - Nothing - -> do - reg <- getNewRegNat rep - NatM (\state -> (reg, state { natm_pic = Just reg })) - -getModLoc :: NatM ModLocation -getModLoc - = NatM $ \ st -> (natm_modloc st, st) - -getFileId :: FastString -> NatM Int -getFileId f = NatM $ \st -> - case lookupUFM (natm_fileid st) f of - Just (_,n) -> (n, st) - Nothing -> let n = 1 + sizeUFM (natm_fileid st) - fids = addToUFM (natm_fileid st) f (f,n) - in n `seq` fids `seq` (n, st { natm_fileid = fids }) - -getDebugBlock :: Label -> NatM (Maybe DebugBlock) -getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st) diff --git a/nativeGen/PIC.hs b/nativeGen/PIC.hs deleted file mode 100644 --- a/nativeGen/PIC.hs +++ /dev/null @@ -1,838 +0,0 @@ -{- - This module handles generation of position independent code and - dynamic-linking related issues for the native code generator. - - This depends both the architecture and OS, so we define it here - instead of in one of the architecture specific modules. - - Things outside this module which are related to this: - - + module CLabel - - PIC base label (pretty printed as local label 1) - - DynamicLinkerLabels - several kinds: - CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset - - labelDynamic predicate - + module Cmm - - The GlobalReg datatype has a PicBaseReg constructor - - The CmmLit datatype has a CmmLabelDiffOff constructor - + codeGen & RTS - - When tablesNextToCode, no absolute addresses are stored in info tables - any more. Instead, offsets from the info label are used. - - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers - because Win32 doesn't support external references in data sections. - TODO: make sure this still works, it might be bitrotted - + NCG - - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all - labels. - - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output - all the necessary stuff for imported symbols. - - The NCG monad keeps track of a list of imported symbols. - - MachCodeGen invokes initializePicBase to generate code to initialize - the PIC base register when needed. - - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel - that wasn't in the original Cmm code (e.g. floating point literals). --} - -module PIC ( - cmmMakeDynamicReference, - CmmMakeDynamicReferenceM(..), - ReferenceKind(..), - needImportedSymbols, - pprImportedSymbol, - pprGotDeclaration, - - initializePicBase_ppc, - initializePicBase_x86 -) - -where - -import GhcPrelude - -import qualified PPC.Instr as PPC -import qualified PPC.Regs as PPC - -import qualified X86.Instr as X86 - -import GHC.Platform -import Instruction -import Reg -import NCGMonad - - -import Hoopl.Collections -import Cmm -import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, - mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), - dynamicLinkerLabelInfo, mkPicBaseLabel, - labelDynamic, externallyVisibleCLabel ) - -import CLabel ( mkForeignLabel ) - - -import BasicTypes -import Module - -import Outputable - -import DynFlags -import FastString - - - --------------------------------------------------------------------------------- --- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm --- code. It does The Right Thing(tm) to convert the CmmLabel into a --- position-independent, dynamic-linking-aware reference to the thing --- in question. --- Note that this also has to be called from MachCodeGen in order to --- access static data like floating point literals (labels that were --- created after the cmmToCmm pass). --- The function must run in a monad that can keep track of imported symbols --- A function for recording an imported symbol must be passed in: --- - addImportCmmOpt for the CmmOptM monad --- - addImportNat for the NatM monad. - -data ReferenceKind - = DataReference - | CallReference - | JumpReference - deriving(Eq) - -class Monad m => CmmMakeDynamicReferenceM m where - addImport :: CLabel -> m () - getThisModule :: m Module - -instance CmmMakeDynamicReferenceM NatM where - addImport = addImportNat - getThisModule = getThisModuleNat - -cmmMakeDynamicReference - :: CmmMakeDynamicReferenceM m - => DynFlags - -> ReferenceKind -- whether this is the target of a jump - -> CLabel -- the label - -> m CmmExpr - -cmmMakeDynamicReference dflags referenceKind lbl - | Just _ <- dynamicLinkerLabelInfo lbl - = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through - - | otherwise - = do this_mod <- getThisModule - case howToAccessLabel - dflags - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - this_mod - referenceKind lbl of - - AccessViaStub -> do - let stub = mkDynamicLinkerLabel CodeStub lbl - addImport stub - return $ CmmLit $ CmmLabel stub - - AccessViaSymbolPtr -> do - let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl - addImport symbolPtr - return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags) - - AccessDirectly -> case referenceKind of - -- for data, we might have to make some calculations: - DataReference -> return $ cmmMakePicReference dflags lbl - -- all currently supported processors support - -- PC-relative branch and call instructions, - -- so just jump there if it's a call or a jump - _ -> return $ CmmLit $ CmmLabel lbl - - --- ----------------------------------------------------------------------------- --- Create a position independent reference to a label. --- (but do not bother with dynamic linking). --- We calculate the label's address by adding some (platform-dependent) --- offset to our base register; this offset is calculated by --- the function picRelative in the platform-dependent part below. - -cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr -cmmMakePicReference dflags lbl - - -- Windows doesn't need PIC, - -- everything gets relocated at runtime - | OSMinGW32 <- platformOS $ targetPlatform dflags - = CmmLit $ CmmLabel lbl - - | OSAIX <- platformOS $ targetPlatform dflags - = CmmMachOp (MO_Add W32) - [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative dflags - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - lbl ] - - -- both ABI versions default to medium code model - | ArchPPC_64 _ <- platformArch $ targetPlatform dflags - = CmmMachOp (MO_Add W32) -- code model medium - [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative dflags - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - lbl ] - - | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags) - && absoluteLabel lbl - = CmmMachOp (MO_Add (wordWidth dflags)) - [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative dflags - (platformArch $ targetPlatform dflags) - (platformOS $ targetPlatform dflags) - lbl ] - - | otherwise - = CmmLit $ CmmLabel lbl - - -absoluteLabel :: CLabel -> Bool -absoluteLabel lbl - = case dynamicLinkerLabelInfo lbl of - Just (GotSymbolPtr, _) -> False - Just (GotSymbolOffset, _) -> False - _ -> True - - --------------------------------------------------------------------------------- --- Knowledge about how special dynamic linker labels like symbol --- pointers, code stubs and GOT offsets look like is located in the --- module CLabel. - --- We have to decide which labels need to be accessed --- indirectly or via a piece of stub code. -data LabelAccessStyle - = AccessViaStub - | AccessViaSymbolPtr - | AccessDirectly - -howToAccessLabel - :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle - - --- Windows --- In Windows speak, a "module" is a set of objects linked into the --- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs). --- --- If we're compiling a multi-module program then symbols from other modules --- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the --- following. --- --- (in the local module) --- __imp_SYMBOL: addr of SYMBOL --- --- (in the other module) --- SYMBOL: the real function / data. --- --- To access the function at SYMBOL from our local module, we just need to --- dereference the local __imp_SYMBOL. --- --- If not compiling with -dynamic we assume that all our code will be linked --- into the same .exe file. In this case we always access symbols directly, --- and never use __imp_SYMBOL. --- -howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl - - -- Assume all symbols will be in the same PE, so just access them directly. - | not (gopt Opt_ExternalDynamicRefs dflags) - = AccessDirectly - - -- If the target symbol is in another PE we need to access it via the - -- appropriate __imp_SYMBOL pointer. - | labelDynamic dflags this_mod lbl - = AccessViaSymbolPtr - - -- Target symbol is in the same PE as the caller, so just access it directly. - | otherwise - = AccessDirectly - - --- Mach-O (Darwin, Mac OS X) --- --- Indirect access is required in the following cases: --- * things imported from a dynamic library --- * (not on x86_64) data from a different module, if we're generating PIC code --- It is always possible to access something indirectly, --- even when it's not necessary. --- -howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl - -- data access to a dynamic library goes via a symbol pointer - | labelDynamic dflags this_mod lbl - = AccessViaSymbolPtr - - -- when generating PIC code, all cross-module data references must - -- must go via a symbol pointer, too, because the assembler - -- cannot generate code for a label difference where one - -- label is undefined. Doesn't apply t x86_64. - -- Unfortunately, we don't know whether it's cross-module, - -- so we do it for all externally visible labels. - -- This is a slight waste of time and space, but otherwise - -- we'd need to pass the current Module all the way in to - -- this function. - | arch /= ArchX86_64 - , positionIndependent dflags && externallyVisibleCLabel lbl - = AccessViaSymbolPtr - - | otherwise - = AccessDirectly - -howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl - -- dyld code stubs don't work for tailcalls because the - -- stack alignment is only right for regular calls. - -- Therefore, we have to go via a symbol pointer: - | arch == ArchX86 || arch == ArchX86_64 - , labelDynamic dflags this_mod lbl - = AccessViaSymbolPtr - - -howToAccessLabel dflags arch OSDarwin this_mod _ lbl - -- Code stubs are the usual method of choice for imported code; - -- not needed on x86_64 because Apple's new linker, ld64, generates - -- them automatically. - | arch /= ArchX86_64 - , labelDynamic dflags this_mod lbl - = AccessViaStub - - | otherwise - = AccessDirectly - - ----------------------------------------------------------------------------- --- AIX - --- quite simple (for now) -howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl - = case kind of - DataReference -> AccessViaSymbolPtr - CallReference -> AccessDirectly - JumpReference -> AccessDirectly - --- ELF (Linux) --- --- ELF tries to pretend to the main application code that dynamic linking does --- not exist. While this may sound convenient, it tends to mess things up in --- very bad ways, so we have to be careful when we generate code for a non-PIE --- main program (-dynamic but no -fPIC). --- --- Indirect access is required for references to imported symbols --- from position independent code. It is also required from the main program --- when dynamic libraries containing Haskell code are used. - -howToAccessLabel _ (ArchPPC_64 _) os _ kind _ - | osElfTarget os - = case kind of - -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC - DataReference -> AccessViaSymbolPtr - -- RTLD does not generate stubs for function descriptors - -- in tail calls. Create a symbol pointer and generate - -- the code to load the function descriptor at the call site. - JumpReference -> AccessViaSymbolPtr - -- regular calls are handled by the runtime linker - _ -> AccessDirectly - -howToAccessLabel dflags _ os _ _ _ - -- no PIC -> the dynamic linker does everything for us; - -- if we don't dynamically link to Haskell code, - -- it actually manages to do so without messing things up. - | osElfTarget os - , not (positionIndependent dflags) && - not (gopt Opt_ExternalDynamicRefs dflags) - = AccessDirectly - -howToAccessLabel dflags arch os this_mod DataReference lbl - | osElfTarget os - = case () of - -- A dynamic label needs to be accessed via a symbol pointer. - _ | labelDynamic dflags this_mod lbl - -> AccessViaSymbolPtr - - -- For PowerPC32 -fPIC, we have to access even static data - -- via a symbol pointer (see below for an explanation why - -- PowerPC32 Linux is especially broken). - | arch == ArchPPC - , positionIndependent dflags - -> AccessViaSymbolPtr - - | otherwise - -> AccessDirectly - - - -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons: - -- on i386, the position-independent symbol stubs in the Procedure Linkage Table - -- require the address of the GOT to be loaded into register %ebx on entry. - -- The linker will take any reference to the symbol stub as a hint that - -- the label in question is a code label. When linking executables, this - -- will cause the linker to replace even data references to the label with - -- references to the symbol stub. - - -- This leaves calling a (foreign) function from non-PIC code - -- (AccessDirectly, because we get an implicit symbol stub) - -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) - -howToAccessLabel dflags arch os this_mod CallReference lbl - | osElfTarget os - , labelDynamic dflags this_mod lbl && not (positionIndependent dflags) - = AccessDirectly - - | osElfTarget os - , arch /= ArchX86 - , labelDynamic dflags this_mod lbl - , positionIndependent dflags - = AccessViaStub - -howToAccessLabel dflags _ os this_mod _ lbl - | osElfTarget os - = if labelDynamic dflags this_mod lbl - then AccessViaSymbolPtr - else AccessDirectly - --- all other platforms -howToAccessLabel dflags _ _ _ _ _ - | not (positionIndependent dflags) - = AccessDirectly - - | otherwise - = panic "howToAccessLabel: PIC not defined for this platform" - - - --- ------------------------------------------------------------------- --- | Says what we have to add to our 'PIC base register' in order to --- get the address of a label. - -picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit - --- Darwin, but not x86_64: --- The PIC base register points to the PIC base label at the beginning --- of the current CmmDecl. We just have to use a label difference to --- get the offset. --- We have already made sure that all labels that are not from the current --- module are accessed indirectly ('as' can't calculate differences between --- undefined labels). -picRelative dflags arch OSDarwin lbl - | arch /= ArchX86_64 - = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags) - --- On AIX we use an indirect local TOC anchored by 'gotLabel'. --- This way we use up only one global TOC entry per compilation-unit --- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode) -picRelative dflags _ OSAIX lbl - = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags) - --- PowerPC Linux: --- The PIC base register points to our fake GOT. Use a label difference --- to get the offset. --- We have made sure that *everything* is accessed indirectly, so this --- is only used for offsets from the GOT to symbol pointers inside the --- GOT. -picRelative dflags ArchPPC os lbl - | osElfTarget os - = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags) - - --- Most Linux versions: --- The PIC base register points to the GOT. Use foo@got for symbol --- pointers, and foo@gotoff for everything else. --- Linux and Darwin on x86_64: --- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers, --- and a GotSymbolOffset label for other things. --- For reasons of tradition, the symbol offset label is written as a plain label. -picRelative _ arch os lbl - | osElfTarget os || (os == OSDarwin && arch == ArchX86_64) - = let result - | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl - = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl' - - | otherwise - = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl - - in result - -picRelative _ _ _ _ - = panic "PositionIndependentCode.picRelative undefined for this platform" - - - --------------------------------------------------------------------------------- - -needImportedSymbols :: DynFlags -> Arch -> OS -> Bool -needImportedSymbols dflags arch os - | os == OSDarwin - , arch /= ArchX86_64 - = True - - | os == OSAIX - = True - - -- PowerPC Linux: -fPIC or -dynamic - | osElfTarget os - , arch == ArchPPC - = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags - - -- PowerPC 64 Linux: always - | osElfTarget os - , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2 - = True - - -- i386 (and others?): -dynamic but not -fPIC - | osElfTarget os - , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = gopt Opt_ExternalDynamicRefs dflags && - not (positionIndependent dflags) - - | otherwise - = False - --- gotLabel --- The label used to refer to our "fake GOT" from --- position-independent code. -gotLabel :: CLabel -gotLabel - -- HACK: this label isn't really foreign - = mkForeignLabel - (fsLit ".LCTOC1") - Nothing ForeignLabelInThisPackage IsData - - - --------------------------------------------------------------------------------- --- We don't need to declare any offset tables. --- However, for PIC on x86, we need a small helper function. -pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc -pprGotDeclaration dflags ArchX86 OSDarwin - | positionIndependent dflags - = vcat [ - text ".section __TEXT,__textcoal_nt,coalesced,no_toc", - text ".weak_definition ___i686.get_pc_thunk.ax", - text ".private_extern ___i686.get_pc_thunk.ax", - text "___i686.get_pc_thunk.ax:", - text "\tmovl (%esp), %eax", - text "\tret" ] - -pprGotDeclaration _ _ OSDarwin - = empty - --- Emit XCOFF TOC section -pprGotDeclaration _ _ OSAIX - = vcat $ [ text ".toc" - , text ".tc ghc_toc_table[TC],.LCTOC1" - , text ".csect ghc_toc_table[RW]" - -- See Note [.LCTOC1 in PPC PIC code] - , text ".set .LCTOC1,$+0x8000" - ] - - --- PPC 64 ELF v1 needs a Table Of Contents (TOC) -pprGotDeclaration _ (ArchPPC_64 ELF_V1) _ - = text ".section \".toc\",\"aw\"" --- In ELF v2 we also need to tell the assembler that we want ABI --- version 2. This would normally be done at the top of the file --- right after a file directive, but I could not figure out how --- to do that. -pprGotDeclaration _ (ArchPPC_64 ELF_V2) _ - = vcat [ text ".abiversion 2", - text ".section \".toc\",\"aw\"" - ] - --- Emit GOT declaration --- Output whatever needs to be output once per .s file. -pprGotDeclaration dflags arch os - | osElfTarget os - , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - , not (positionIndependent dflags) - = empty - - | osElfTarget os - , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = vcat [ - -- See Note [.LCTOC1 in PPC PIC code] - text ".section \".got2\",\"aw\"", - text ".LCTOC1 = .+32768" ] - -pprGotDeclaration _ _ _ - = panic "pprGotDeclaration: no match" - - --------------------------------------------------------------------------------- --- On Darwin, we have to generate our own stub code for lazy binding.. --- For each processor architecture, there are two versions, one for PIC --- and one for non-PIC. --- - -pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc -pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_arch = ArchX86, platformMini_os = OSDarwin } }) importedLbl - | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl - = case positionIndependent dflags of - False -> - vcat [ - text ".symbol_stub", - text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel dflags lbl, - text "\tjmp *L" <> pprCLabel dflags lbl - <> text "$lazy_ptr", - text "L" <> pprCLabel dflags lbl - <> text "$stub_binder:", - text "\tpushl $L" <> pprCLabel dflags lbl - <> text "$lazy_ptr", - text "\tjmp dyld_stub_binding_helper" - ] - True -> - vcat [ - text ".section __TEXT,__picsymbolstub2," - <> text "symbol_stubs,pure_instructions,25", - text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel dflags lbl, - text "\tcall ___i686.get_pc_thunk.ax", - text "1:", - text "\tmovl L" <> pprCLabel dflags lbl - <> text "$lazy_ptr-1b(%eax),%edx", - text "\tjmp *%edx", - text "L" <> pprCLabel dflags lbl - <> text "$stub_binder:", - text "\tlea L" <> pprCLabel dflags lbl - <> text "$lazy_ptr-1b(%eax),%eax", - text "\tpushl %eax", - text "\tjmp dyld_stub_binding_helper" - ] - $+$ vcat [ text ".section __DATA, __la_sym_ptr" - <> (if positionIndependent dflags then int 2 else int 3) - <> text ",lazy_symbol_pointers", - text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"), - text "\t.indirect_symbol" <+> pprCLabel dflags lbl, - text "\t.long L" <> pprCLabel dflags lbl - <> text "$stub_binder"] - - | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl - = vcat [ - text ".non_lazy_symbol_pointer", - char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:", - text "\t.indirect_symbol" <+> pprCLabel dflags lbl, - text "\t.long\t0"] - - | otherwise - = empty - - -pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = OSDarwin } }) _ - = empty - --- XCOFF / AIX --- --- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To --- workaround the limitation of a global TOC we use an indirect TOC --- with the label `ghc_toc_table`. --- --- See also GCC's `-mminimal-toc` compilation mode or --- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/ --- --- NB: No DSO-support yet - -pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_os = OSAIX } }) importedLbl - = case dynamicLinkerLabelInfo importedLbl of - Just (SymbolPtr, lbl) - -> vcat [ - text "LC.." <> pprCLabel dflags lbl <> char ':', - text "\t.long" <+> pprCLabel dflags lbl ] - _ -> empty - --- ELF / Linux --- --- In theory, we don't need to generate any stubs or symbol pointers --- by hand for Linux. --- --- Reality differs from this in two areas. --- --- 1) If we just use a dynamically imported symbol directly in a read-only --- section of the main executable (as GCC does), ld generates R_*_COPY --- relocations, which are fundamentally incompatible with reversed info --- tables. Therefore, we need a table of imported addresses in a writable --- section. --- The "official" GOT mechanism (label@got) isn't intended to be used --- in position dependent code, so we have to create our own "fake GOT" --- when not Opt_PIC && WayDyn `elem` ways dflags. --- --- 2) PowerPC Linux is just plain broken. --- While it's theoretically possible to use GOT offsets larger --- than 16 bit, the standard crt*.o files don't, which leads to --- linker errors as soon as the GOT size exceeds 16 bit. --- Also, the assembler doesn't support @gotoff labels. --- In order to be able to use a larger GOT, we have to circumvent the --- entire GOT mechanism and do it ourselves (this is also what GCC does). - - --- When needImportedSymbols is defined, --- the NCG will keep track of all DynamicLinkerLabels it uses --- and output each of them using pprImportedSymbol. - -pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { platformMini_arch = ArchPPC_64 _ } }) - importedLbl - | osElfTarget (platformOS platform) - = case dynamicLinkerLabelInfo importedLbl of - Just (SymbolPtr, lbl) - -> vcat [ - text ".section \".toc\", \"aw\"", - text ".LC_" <> pprCLabel dflags lbl <> char ':', - text "\t.quad" <+> pprCLabel dflags lbl ] - _ -> empty - -pprImportedSymbol dflags platform importedLbl - | osElfTarget (platformOS platform) - = case dynamicLinkerLabelInfo importedLbl of - Just (SymbolPtr, lbl) - -> let symbolSize = case wordWidth dflags of - W32 -> sLit "\t.long" - W64 -> sLit "\t.quad" - _ -> panic "Unknown wordRep in pprImportedSymbol" - - in vcat [ - text ".section \".got2\", \"aw\"", - text ".LC_" <> pprCLabel dflags lbl <> char ':', - ptext symbolSize <+> pprCLabel dflags lbl ] - - -- PLT code stubs are generated automatically by the dynamic linker. - _ -> empty - -pprImportedSymbol _ _ _ - = panic "PIC.pprImportedSymbol: no match" - --------------------------------------------------------------------------------- --- Generate code to calculate the address that should be put in the --- PIC base register. --- This is called by MachCodeGen for every CmmProc that accessed the --- PIC base register. It adds the appropriate instructions to the --- top of the CmmProc. - --- It is assumed that the first NatCmmDecl in the input list is a Proc --- and the rest are CmmDatas. - --- Darwin is simple: just fetch the address of a local label. --- The FETCHPC pseudo-instruction is expanded to multiple instructions --- during pretty-printing so that we don't have to deal with the --- local label: - --- PowerPC version: --- bcl 20,31,1f. --- 1: mflr picReg - --- i386 version: --- call 1f --- 1: popl %picReg - - - --- Get a pointer to our own fake GOT, which is defined on a per-module basis. --- This is exactly how GCC does it in linux. - -initializePicBase_ppc - :: Arch -> OS -> Reg - -> [NatCmmDecl CmmStatics PPC.Instr] - -> NatM [NatCmmDecl CmmStatics PPC.Instr] - -initializePicBase_ppc ArchPPC os picReg - (CmmProc info lab live (ListGraph blocks) : statics) - | osElfTarget os - = do - let - gotOffset = PPC.ImmConstantDiff - (PPC.ImmCLbl gotLabel) - (PPC.ImmCLbl mkPicBaseLabel) - - blocks' = case blocks of - [] -> [] - (b:bs) -> fetchPC b : map maybeFetchPC bs - - maybeFetchPC b@(BasicBlock bID _) - | bID `mapMember` info = fetchPC b - | otherwise = b - - -- GCC does PIC prologs thusly: - -- bcl 20,31,.L1 - -- .L1: - -- mflr 30 - -- addis 30,30,.LCTOC1-.L1@ha - -- addi 30,30,.LCTOC1-.L1@l - -- TODO: below we use it over temporary register, - -- it can and should be optimised by picking - -- correct PIC reg. - fetchPC (BasicBlock bID insns) = - BasicBlock bID (PPC.FETCHPC picReg - : PPC.ADDIS picReg picReg (PPC.HA gotOffset) - : PPC.ADD picReg picReg - (PPC.RIImm (PPC.LO gotOffset)) - : PPC.MR PPC.r30 picReg - : insns) - - return (CmmProc info lab live (ListGraph blocks') : statics) - -------------------------------------------------------------------------- --- Load TOC into register 2 --- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee --- in register 12. --- We pass the label to FETCHTOC and create a .localentry too. --- TODO: Explain this better and refer to ABI spec! -{- -We would like to do approximately this, but spill slot allocation -might be added before the first BasicBlock. That violates the ABI. - -For now we will emit the prologue code in the pretty printer, -which is also what we do for ELF v1. -initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg - (CmmProc info lab live (ListGraph (entry:blocks)) : statics) - = do - bID <-getUniqueM - return (CmmProc info lab live (ListGraph (b':entry:blocks)) - : statics) - where BasicBlock entryID _ = entry - b' = BasicBlock bID [PPC.FETCHTOC picReg lab, - PPC.BCC PPC.ALWAYS entryID] --} - -initializePicBase_ppc _ _ _ _ - = panic "initializePicBase_ppc: not needed" - - --- We cheat a bit here by defining a pseudo-instruction named FETCHGOT --- which pretty-prints as: --- call 1f --- 1: popl %picReg --- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg --- (See PprMach.hs) - -initializePicBase_x86 - :: Arch -> OS -> Reg - -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr] - -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] - -initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab live (ListGraph blocks) : statics) - | osElfTarget os - = return (CmmProc info lab live (ListGraph blocks') : statics) - where blocks' = case blocks of - [] -> [] - (b:bs) -> fetchGOT b : map maybeFetchGOT bs - - -- we want to add a FETCHGOT instruction to the beginning of - -- every block that is an entry point, which corresponds to - -- the blocks that have entries in the info-table mapping. - maybeFetchGOT b@(BasicBlock bID _) - | bID `mapMember` info = fetchGOT b - | otherwise = b - - fetchGOT (BasicBlock bID insns) = - BasicBlock bID (X86.FETCHGOT picReg : insns) - -initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab live (ListGraph (entry:blocks)) : statics) - = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) - - where BasicBlock bID insns = entry - block' = BasicBlock bID (X86.FETCHPC picReg : insns) - -initializePicBase_x86 _ _ _ _ - = panic "initializePicBase_x86: not needed" - diff --git a/nativeGen/PPC/CodeGen.hs b/nativeGen/PPC/CodeGen.hs deleted file mode 100644 --- a/nativeGen/PPC/CodeGen.hs +++ /dev/null @@ -1,2452 +0,0 @@ -{-# LANGUAGE CPP, GADTs #-} - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ - --- This is a big module, but, if you pay attention to --- (a) the sectioning, and (b) the type signatures, --- the structure should not be too overwhelming. - -module PPC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) - -where - -#include "HsVersions.h" - --- NCG stuff: -import GhcPrelude - -import GHC.Platform.Regs -import PPC.Instr -import PPC.Cond -import PPC.Regs -import CPrim -import NCGMonad ( NatM, getNewRegNat, getNewLabelNat - , getBlockIdNat, getPicBaseNat, getNewRegPairNat - , getPicBaseMaybeNat ) -import Instruction -import PIC -import Format -import RegClass -import Reg -import TargetReg -import GHC.Platform - --- Our intermediate code: -import BlockId -import PprCmm ( pprExpr ) -import Cmm -import CmmUtils -import CmmSwitch -import CLabel -import Hoopl.Block -import Hoopl.Graph - --- The rest: -import OrdList -import Outputable -import DynFlags - -import Control.Monad ( mapAndUnzipM, when ) -import Data.Bits -import Data.Word - -import BasicTypes -import FastString -import Util - --- ----------------------------------------------------------------------------- --- Top-level of the instruction selector - --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal (pre-order?) yields the insns in the correct --- order. - -cmmTopCodeGen - :: RawCmmDecl - -> NatM [NatCmmDecl CmmStatics Instr] - -cmmTopCodeGen (CmmProc info lab live graph) = do - let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - dflags <- getDynFlags - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - tops = proc : concat statics - os = platformOS $ targetPlatform dflags - arch = platformArch $ targetPlatform dflags - case arch of - ArchPPC | os == OSAIX -> return tops - | otherwise -> do - picBaseMb <- getPicBaseMaybeNat - case picBaseMb of - Just picBase -> initializePicBase_ppc arch os picBase tops - Nothing -> return tops - ArchPPC_64 ELF_V1 -> fixup_entry tops - -- generating function descriptor is handled in - -- pretty printer - ArchPPC_64 ELF_V2 -> fixup_entry tops - -- generating function prologue is handled in - -- pretty printer - _ -> panic "PPC.cmmTopCodeGen: unknown arch" - where - fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics) - = do - let BasicBlock bID insns = entry - bID' <- if lab == (blockLbl bID) - then newBlockId - else return bID - let b' = BasicBlock bID' insns - return (CmmProc info lab live (ListGraph (b':blocks)) : statics) - fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc" - -cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic - -basicBlockCodeGen - :: Block CmmNode C C - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl CmmStatics Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs - -- code generation may introduce new basic block boundaries, which - -- are indicated by the NEWBLOCK instruction. We must split up the - -- instruction stream into basic blocks again. Also, we extract - -- LDATAs here too. - let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - return (BasicBlock id top : other_blocks, statics) - -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - dflags <- getDynFlags - case stmt of - CmmComment s -> return (unitOL (COMMENT s)) - CmmTick {} -> return nilOL - CmmUnwind {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | target32Bit (targetPlatform dflags) && - isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType dflags reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | target32Bit (targetPlatform dflags) && - isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType dflags src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false prediction -> do - b1 <- genCondJump true arg prediction - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids - CmmCall { cml_target = arg - , cml_args_regs = gregs } -> do - dflags <- getDynFlags - genJump arg (jumpRegs dflags gregs) - _ -> - panic "stmtToInstrs: statement should have been cps'd away" - -jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] -jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] - where platform = targetPlatform dflags - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - -swizzleRegisterRep :: Register -> Format -> Register -swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code -swizzleRegisterRep (Any _ codefn) format = Any format codefn - - --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) - -getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal reg - Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence ... - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = blockLbl blockid - - - --- ----------------------------------------------------------------------------- --- General things for putting together code sequences - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr -mangleIndexTree dflags (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) - -mangleIndexTree _ _ - = panic "PPC.CodeGen.mangleIndexTree: no match" - --- ----------------------------------------------------------------------------- --- Code gen for 64-bit arithmetic on 32-bit platforms - -{- -Simple support for generating 64-bit code (ie, 64 bit values and 64 -bit assignments) on 32-bit platforms. Unlike the main code generator -we merely shoot for generating working code as simply as possible, and -pay little attention to code quality. Specifically, there is no -attempt to deal cleverly with the fixed-vs-floating register -distinction; all values are generated into (pairs of) floating -registers, even if this would mean some redundant reg-reg moves as a -result. Only one of the VRegUniques is returned, since it will be -of the VRegUniqueLo form, and the upper-half VReg can be determined -by applying getHiVRegFromLo to it. --} - -data ChildCode64 -- a.k.a "Register64" - = ChildCode64 - InstrBlock -- code - Reg -- the lower 32-bit temporary which contains the - -- result; use getHiVRegFromLo to find the other - -- VRegUnique. Rules of this simplified insn - -- selection game are therefore that the returned - -- Reg may be modified - - --- | Compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - -getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) -getI64Amodes addrTree = do - Amode hi_addr addr_code <- getAmode D addrTree - case addrOffset hi_addr 4 of - Just lo_addr -> return (hi_addr, lo_addr, addr_code) - Nothing -> do (hi_ptr, code) <- getSomeReg addrTree - return (AddrRegImm hi_ptr (ImmInt 0), - AddrRegImm hi_ptr (ImmInt 4), - code) - - -assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_I64Code addrTree valueTree = do - (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree - ChildCode64 vcode rlo <- iselExpr64 valueTree - let - rhi = getHiVRegFromLo rlo - - -- Big-endian store - mov_hi = ST II32 rhi hi_addr - mov_lo = ST II32 rlo lo_addr - return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) - - -assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MR r_dst_lo r_src_lo - mov_hi = MR r_dst_hi r_src_hi - return ( - vcode `snocOL` mov_lo `snocOL` mov_hi - ) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(powerpc): invalid lvalue" - - -iselExpr64 :: CmmExpr -> NatM ChildCode64 -iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do - (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree - (rlo, rhi) <- getNewRegPairNat II32 - let mov_hi = LD II32 rhi hi_addr - mov_lo = LD II32 rlo lo_addr - return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) - rlo - -iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty - = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) - -iselExpr64 (CmmLit (CmmInt i _)) = do - (rlo,rhi) <- getNewRegPairNat II32 - let - half0 = fromIntegral (fromIntegral i :: Word16) - half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) - half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) - half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) - - code = toOL [ - LIS rlo (ImmInt half1), - OR rlo rlo (RIImm $ ImmInt half0), - LIS rhi (ImmInt half3), - OR rhi rhi (RIImm $ ImmInt half2) - ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ ADDC rlo r1lo r2lo, - ADDE rhi r1hi r2hi ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ SUBFC rlo r2lo (RIReg r1lo), - SUBFE rhi r2hi r1hi ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do - (expr_reg,expr_code) <- getSomeReg expr - (rlo, rhi) <- getNewRegPairNat II32 - let mov_hi = LI rhi (ImmInt 0) - mov_lo = MR rlo expr_reg - return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) - rlo - -iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do - (expr_reg,expr_code) <- getSomeReg expr - (rlo, rhi) <- getNewRegPairNat II32 - let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31)) - mov_lo = MR rlo expr_reg - return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) - rlo -iselExpr64 expr - = pprPanic "iselExpr64(powerpc)" (pprExpr expr) - - - -getRegister :: CmmExpr -> NatM Register -getRegister e = do dflags <- getDynFlags - getRegister' dflags e - -getRegister' :: DynFlags -> CmmExpr -> NatM Register - -getRegister' dflags (CmmReg (CmmGlobal PicBaseReg)) - | OSAIX <- platformOS (targetPlatform dflags) = do - let code dst = toOL [ LD II32 dst tocAddr ] - tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]")) - return (Any II32 code) - | target32Bit (targetPlatform dflags) = do - reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags)) - return (Fixed (archWordFormat (target32Bit (targetPlatform dflags))) - reg nilOL) - | otherwise = return (Fixed II64 toc nilOL) - -getRegister' dflags (CmmReg reg) - = return (Fixed (cmmTypeFormat (cmmRegType dflags reg)) - (getRegisterReg (targetPlatform dflags) reg) nilOL) - -getRegister' dflags tree@(CmmRegOff _ _) - = getRegister' dflags (mangleIndexTree dflags tree) - - -- for 32-bit architectuers, support some 64 -> 32 bit conversions: - -- TO_W_(x), TO_W_(x >> 32) - -getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) - | target32Bit (targetPlatform dflags) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' dflags (CmmLoad mem pk) - | not (isWord64 pk) = do - let platform = targetPlatform dflags - Amode addr addr_code <- getAmode D mem - let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) - addr_code `snocOL` LD format dst addr - return (Any format code) - | not (target32Bit (targetPlatform dflags)) = do - Amode addr addr_code <- getAmode DS mem - let code dst = addr_code `snocOL` LD II64 dst addr - return (Any II64 code) - - where format = cmmTypeFormat pk - --- catch simple cases of zero- or sign-extended load -getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -getRegister' _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -getRegister' _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) - --- Note: there is no Load Byte Arithmetic instruction, so no signed case here - -getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) - -getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do - Amode addr addr_code <- getAmode D mem - return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) - -getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do - -- lwa is DS-form. See Note [Power instruction format] - Amode addr addr_code <- getAmode DS mem - return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) - -getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps - = case mop of - MO_Not rep -> triv_ucode_int rep NOT - - MO_F_Neg w -> triv_ucode_float w FNEG - MO_S_Neg w -> triv_ucode_int w NEG - - MO_FF_Conv W64 W32 -> trivialUCode FF32 FRSP x - MO_FF_Conv W32 W64 -> conversionNop FF64 x - - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - MO_SS_Conv from to - | from >= to -> conversionNop (intFormat to) x - | otherwise -> triv_ucode_int to (EXTS (intFormat from)) - - MO_UU_Conv from to - | from >= to -> conversionNop (intFormat to) x - | otherwise -> clearLeft from to - - MO_XX_Conv _ to -> conversionNop (intFormat to) x - - _ -> panic "PPC.CodeGen.getRegister: no match" - - where - triv_ucode_int width instr = trivialUCode (intFormat width) instr x - triv_ucode_float width instr = trivialUCode (floatFormat width) instr x - - conversionNop new_format expr - = do e_code <- getRegister' dflags expr - return (swizzleRegisterRep e_code new_format) - - clearLeft from to - = do (src1, code1) <- getSomeReg x - let arch_fmt = intFormat (wordWidth dflags) - arch_bits = widthInBits (wordWidth dflags) - size = widthInBits from - code dst = code1 `snocOL` - CLRLI arch_fmt dst src1 (arch_bits - size) - return (Any (intFormat to) code) - -getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps - = case mop of - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y - - MO_Eq rep -> condIntReg EQQ rep x y - MO_Ne rep -> condIntReg NE rep x y - - MO_S_Gt rep -> condIntReg GTT rep x y - MO_S_Ge rep -> condIntReg GE rep x y - MO_S_Lt rep -> condIntReg LTT rep x y - MO_S_Le rep -> condIntReg LE rep x y - - MO_U_Gt rep -> condIntReg GU rep x y - MO_U_Ge rep -> condIntReg GEU rep x y - MO_U_Lt rep -> condIntReg LU rep x y - MO_U_Le rep -> condIntReg LEU rep x y - - MO_F_Add w -> triv_float w FADD - MO_F_Sub w -> triv_float w FSUB - MO_F_Mul w -> triv_float w FMUL - MO_F_Quot w -> triv_float w FDIV - - -- optimize addition with 32-bit immediate - -- (needed for PIC) - MO_Add W32 -> - case y of - CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm - -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep) - CmmLit lit - -> do - (src, srcCode) <- getSomeReg x - let imm = litToImm lit - code dst = srcCode `appOL` toOL [ - ADDIS dst src (HA imm), - ADD dst dst (RIImm (LO imm)) - ] - return (Any II32 code) - _ -> trivialCode W32 True ADD x y - - MO_Add rep -> trivialCode rep True ADD x y - MO_Sub rep -> - case y of - CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm) - -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep) - _ -> case x of - CmmLit (CmmInt imm _) - | Just _ <- makeImmediate rep True imm - -- subfi ('substract from' with immediate) doesn't exist - -> trivialCode rep True SUBFC y x - _ -> trivialCodeNoImm' (intFormat rep) SUBF y x - - MO_Mul rep -> shiftMulCode rep True MULL x y - MO_S_MulMayOflo rep -> do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - format = intFormat rep - code dst = code1 `appOL` code2 - `appOL` toOL [ MULLO format dst src1 src2 - , MFOV format dst - ] - return (Any format code) - - MO_S_Quot rep -> divCode rep True x y - MO_U_Quot rep -> divCode rep False x y - - MO_S_Rem rep -> remainder rep True x y - MO_U_Rem rep -> remainder rep False x y - - MO_And rep -> case y of - (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4 - -> do - (src, srcCode) <- getSomeReg x - let clear_mask = if imm == -4 then 2 else 3 - fmt = intFormat rep - code dst = srcCode - `appOL` unitOL (CLRRI fmt dst src clear_mask) - return (Any fmt code) - _ -> trivialCode rep False AND x y - MO_Or rep -> trivialCode rep False OR x y - MO_Xor rep -> trivialCode rep False XOR x y - - MO_Shl rep -> shiftMulCode rep False SL x y - MO_S_Shr rep -> srCode rep True SRA x y - MO_U_Shr rep -> srCode rep False SR x y - _ -> panic "PPC.CodeGen.getRegister: no match" - - where - triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register - triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y - - remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register - remainder rep sgn x y = do - let fmt = intFormat rep - tmp <- getNewRegNat fmt - code <- remainderCode rep sgn tmp x y - return (Any fmt code) - - -getRegister' _ (CmmLit (CmmInt i rep)) - | Just imm <- makeImmediate rep True i - = let - code dst = unitOL (LI dst imm) - in - return (Any (intFormat rep) code) - -getRegister' _ (CmmLit (CmmFloat f frep)) = do - lbl <- getNewLabelNat - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - Amode addr addr_code <- getAmode D dynRef - let format = floatFormat frep - code dst = - LDATA (Section ReadOnlyData lbl) - (Statics lbl [CmmStaticLit (CmmFloat f frep)]) - `consOL` (addr_code `snocOL` LD format dst addr) - return (Any format code) - -getRegister' dflags (CmmLit lit) - | target32Bit (targetPlatform dflags) - = let rep = cmmLitType dflags lit - imm = litToImm lit - code dst = toOL [ - LIS dst (HA imm), - ADD dst dst (RIImm (LO imm)) - ] - in return (Any (cmmTypeFormat rep) code) - | otherwise - = do lbl <- getNewLabelNat - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - Amode addr addr_code <- getAmode D dynRef - let rep = cmmLitType dflags lit - format = cmmTypeFormat rep - code dst = - LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit]) - `consOL` (addr_code `snocOL` LD format dst addr) - return (Any format code) - -getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) - - -- extend?Rep: wrap integer expression of type `from` - -- in a conversion to `to` -extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr -extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x] - -extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr -extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x] - --- ----------------------------------------------------------------------------- --- The 'Amode' type: Memory addressing modes passed up the tree. - -data Amode - = Amode AddrMode InstrBlock - -{- -Now, given a tree (the argument to a CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - -{- Note [Power instruction format] -In some instructions the 16 bit offset must be a multiple of 4, i.e. -the two least significant bits must be zero. The "Power ISA" specification -calls these instruction formats "DS-FORM" and the instructions with -arbitrary 16 bit offsets are "D-FORM". - -The Power ISA specification document can be obtained from www.power.org. --} -data InstrForm = D | DS - -getAmode :: InstrForm -> CmmExpr -> NatM Amode -getAmode inf tree@(CmmRegOff _ _) - = do dflags <- getDynFlags - getAmode inf (mangleIndexTree dflags tree) - -getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W32 True (-i) - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - - -getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W32 True i - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - -getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True (-i) - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - - -getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True i - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - -getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True (-i) - = do - (reg, code) <- getSomeReg x - (reg', off', code') <- - if i `mod` 4 == 0 - then do return (reg, off, code) - else do - tmp <- getNewRegNat II64 - return (tmp, ImmInt 0, - code `snocOL` ADD tmp reg (RIImm off)) - return (Amode (AddrRegImm reg' off') code') - -getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W64 True i - = do - (reg, code) <- getSomeReg x - (reg', off', code') <- - if i `mod` 4 == 0 - then do return (reg, off, code) - else do - tmp <- getNewRegNat II64 - return (tmp, ImmInt 0, - code `snocOL` ADD tmp reg (RIImm off)) - return (Amode (AddrRegImm reg' off') code') - - -- optimize addition with 32-bit immediate - -- (needed for PIC) -getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit]) - = do - dflags <- getDynFlags - (src, srcCode) <- getSomeReg x - let imm = litToImm lit - case () of - _ | OSAIX <- platformOS (targetPlatform dflags) - , isCmmLabelType lit -> - -- HA16/LO16 relocations on labels not supported on AIX - return (Amode (AddrRegImm src imm) srcCode) - | otherwise -> do - tmp <- getNewRegNat II32 - let code = srcCode `snocOL` ADDIS tmp src (HA imm) - return (Amode (AddrRegImm tmp (LO imm)) code) - where - isCmmLabelType (CmmLabel {}) = True - isCmmLabelType (CmmLabelOff {}) = True - isCmmLabelType (CmmLabelDiffOff {}) = True - isCmmLabelType _ = False - -getAmode _ (CmmLit lit) - = do - dflags <- getDynFlags - case platformArch $ targetPlatform dflags of - ArchPPC -> do - tmp <- getNewRegNat II32 - let imm = litToImm lit - code = unitOL (LIS tmp (HA imm)) - return (Amode (AddrRegImm tmp (LO imm)) code) - _ -> do -- TODO: Load from TOC, - -- see getRegister' _ (CmmLit lit) - tmp <- getNewRegNat II64 - let imm = litToImm lit - code = toOL [ - LIS tmp (HIGHESTA imm), - OR tmp tmp (RIImm (HIGHERA imm)), - SL II64 tmp tmp (RIImm (ImmInt 32)), - ORIS tmp tmp (HA imm) - ] - return (Amode (AddrRegImm tmp (LO imm)) code) - -getAmode _ (CmmMachOp (MO_Add W32) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - -getAmode _ (CmmMachOp (MO_Add W64) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - -getAmode _ other - = do - (reg, code) <- getSomeReg other - let - off = ImmInt 0 - return (Amode (AddrRegImm reg off) code) - - --- The 'CondCode' type: Condition codes passed up the tree. -data CondCode - = CondCode Bool Cond InstrBlock - --- Set up a condition code for a conditional branch. - -getCondCode :: CmmExpr -> NatM CondCode - --- almost the same as everywhere else - but we need to --- extend small integers to 32 bit or 64 bit first - -getCondCode (CmmMachOp mop [x, y]) - = do - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - MO_F_Lt W32 -> condFltCode LTT x y - MO_F_Le W32 -> condFltCode LE x y - - MO_F_Eq W64 -> condFltCode EQQ x y - MO_F_Ne W64 -> condFltCode NE x y - MO_F_Gt W64 -> condFltCode GTT x y - MO_F_Ge W64 -> condFltCode GE x y - MO_F_Lt W64 -> condFltCode LTT x y - MO_F_Le W64 -> condFltCode LE x y - - MO_Eq rep -> condIntCode EQQ rep x y - MO_Ne rep -> condIntCode NE rep x y - - MO_S_Gt rep -> condIntCode GTT rep x y - MO_S_Ge rep -> condIntCode GE rep x y - MO_S_Lt rep -> condIntCode LTT rep x y - MO_S_Le rep -> condIntCode LE rep x y - - MO_U_Gt rep -> condIntCode GU rep x y - MO_U_Ge rep -> condIntCode GEU rep x y - MO_U_Lt rep -> condIntCode LU rep x y - MO_U_Le rep -> condIntCode LEU rep x y - - _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) - -getCondCode _ = panic "getCondCode(2)(powerpc)" - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode -condIntCode cond width x y = do - dflags <- getDynFlags - condIntCode' (target32Bit (targetPlatform dflags)) cond width x y - -condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode - --- simple code for 64-bit on 32-bit platforms -condIntCode' True cond W64 x y - | condUnsigned cond - = do - ChildCode64 code_x x_lo <- iselExpr64 x - ChildCode64 code_y y_lo <- iselExpr64 y - let x_hi = getHiVRegFromLo x_lo - y_hi = getHiVRegFromLo y_lo - end_lbl <- getBlockIdNat - let code = code_x `appOL` code_y `appOL` toOL - [ CMPL II32 x_hi (RIReg y_hi) - , BCC NE end_lbl Nothing - , CMPL II32 x_lo (RIReg y_lo) - , BCC ALWAYS end_lbl Nothing - - , NEWBLOCK end_lbl - ] - return (CondCode False cond code) - | otherwise - = do - ChildCode64 code_x x_lo <- iselExpr64 x - ChildCode64 code_y y_lo <- iselExpr64 y - let x_hi = getHiVRegFromLo x_lo - y_hi = getHiVRegFromLo y_lo - end_lbl <- getBlockIdNat - cmp_lo <- getBlockIdNat - let code = code_x `appOL` code_y `appOL` toOL - [ CMP II32 x_hi (RIReg y_hi) - , BCC NE end_lbl Nothing - , CMP II32 x_hi (RIImm (ImmInt 0)) - , BCC LE cmp_lo Nothing - , CMPL II32 x_lo (RIReg y_lo) - , BCC ALWAYS end_lbl Nothing - , NEWBLOCK cmp_lo - , CMPL II32 y_lo (RIReg x_lo) - , BCC ALWAYS end_lbl Nothing - - , NEWBLOCK end_lbl - ] - return (CondCode False cond code) - --- optimize pointer tag checks. Operation andi. sets condition register --- so cmpi ..., 0 is redundant. -condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)]) - (CmmLit (CmmInt 0 _)) - | not $ condUnsigned cond, - Just src2 <- makeImmediate rep False imm - = do - (src1, code) <- getSomeReg x - let code' = code `snocOL` AND r0 src1 (RIImm src2) - return (CondCode False cond code') - -condIntCode' _ cond width x (CmmLit (CmmInt y rep)) - | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y - = do - let op_len = max W32 width - let extend = extendSExpr width op_len - (src1, code) <- getSomeReg (extend x) - let format = intFormat op_len - code' = code `snocOL` - (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2) - return (CondCode False cond code') - -condIntCode' _ cond width x y = do - let op_len = max W32 width - let extend = if condUnsigned cond then extendUExpr width op_len - else extendSExpr width op_len - (src1, code1) <- getSomeReg (extend x) - (src2, code2) <- getSomeReg (extend y) - let format = intFormat op_len - code' = code1 `appOL` code2 `snocOL` - (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2) - return (CondCode False cond code') - -condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condFltCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 - code'' = case cond of -- twiddle CR to handle unordered case - GE -> code' `snocOL` CRNOR ltbit eqbit gtbit - LE -> code' `snocOL` CRNOR gtbit eqbit ltbit - _ -> code' - where - ltbit = 0 ; eqbit = 2 ; gtbit = 1 - return (CondCode True cond code'') - - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src - Amode dstAddr addr_code <- case pk of - II64 -> getAmode DS addr - _ -> getAmode D addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - --- dst is a reg, but src could be anything -assignReg_IntCode _ reg src - = do - dflags <- getDynFlags - let dst = getRegisterReg (targetPlatform dflags) reg - r <- getRegister src - return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` MR dst freg - - - --- Easy, isn't it? -assignMem_FltCode = assignMem_IntCode -assignReg_FltCode = assignReg_IntCode - - - -genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock - -genJump (CmmLit (CmmLabel lbl)) regs - = return (unitOL $ JMP lbl regs) - -genJump tree gregs - = do - dflags <- getDynFlags - genJump' tree (platformToGCP (targetPlatform dflags)) gregs - -genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock - -genJump' tree (GCP64ELF 1) regs - = do - (target,code) <- getSomeReg tree - return (code - `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0)) - `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8)) - `snocOL` MTCTR r11 - `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16)) - `snocOL` BCTR [] Nothing regs) - -genJump' tree (GCP64ELF 2) regs - = do - (target,code) <- getSomeReg tree - return (code - `snocOL` MR r12 target - `snocOL` MTCTR r12 - `snocOL` BCTR [] Nothing regs) - -genJump' tree _ regs - = do - (target,code) <- getSomeReg tree - return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs) - --- ----------------------------------------------------------------------------- --- Unconditional branches -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> Maybe Bool - -> NatM InstrBlock - -genCondJump id bool prediction = do - CondCode _ cond code <- getCondCode bool - return (code `snocOL` BCC cond id prediction) - - - --- ----------------------------------------------------------------------------- --- Generating C calls - --- Now the biggest nightmare---calls. Most of the nastiness is buried in --- @get_arg@, which moves the arguments to the correct registers/stack --- locations. Apart from that, the code is easy. - -genCCall :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall (PrimTarget MO_ReadBarrier) _ _ - = return $ unitOL LWSYNC -genCCall (PrimTarget MO_WriteBarrier) _ _ - = return $ unitOL LWSYNC - -genCCall (PrimTarget MO_Touch) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - fmt = intFormat width - reg_dst = getRegisterReg platform (CmmLocal dst) - (instr, n_code) <- case amop of - AMO_Add -> getSomeRegOrImm ADD True reg_dst - AMO_Sub -> case n of - CmmLit (CmmInt i _) - | Just imm <- makeImmediate width True (-i) - -> return (ADD reg_dst reg_dst (RIImm imm), nilOL) - _ - -> do - (n_reg, n_code) <- getSomeReg n - return (SUBF reg_dst n_reg reg_dst, n_code) - AMO_And -> getSomeRegOrImm AND False reg_dst - AMO_Nand -> do (n_reg, n_code) <- getSomeReg n - return (NAND reg_dst reg_dst n_reg, n_code) - AMO_Or -> getSomeRegOrImm OR False reg_dst - AMO_Xor -> getSomeRegOrImm XOR False reg_dst - Amode addr_reg addr_code <- getAmodeIndex addr - lbl_retry <- getBlockIdNat - return $ n_code `appOL` addr_code - `appOL` toOL [ HWSYNC - , BCC ALWAYS lbl_retry Nothing - - , NEWBLOCK lbl_retry - , LDR fmt reg_dst addr_reg - , instr - , STC fmt reg_dst addr_reg - , BCC NE lbl_retry (Just False) - , ISYNC - ] - where - getAmodeIndex (CmmMachOp (MO_Add _) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - getAmodeIndex other - = do - (reg, code) <- getSomeReg other - return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here! - getSomeRegOrImm op sign dst - = case n of - CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i - -> return (op dst dst (RIImm imm), nilOL) - _ - -> do - (n_reg, n_code) <- getSomeReg n - return (op dst dst (RIReg n_reg), n_code) - -genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - fmt = intFormat width - reg_dst = getRegisterReg platform (CmmLocal dst) - form = if widthInBits width == 64 then DS else D - Amode addr_reg addr_code <- getAmode form addr - lbl_end <- getBlockIdNat - return $ addr_code `appOL` toOL [ HWSYNC - , LD fmt reg_dst addr_reg - , CMP fmt reg_dst (RIReg reg_dst) - , BCC NE lbl_end (Just False) - , BCC ALWAYS lbl_end Nothing - -- See Note [Seemingly useless cmp and bne] - , NEWBLOCK lbl_end - , ISYNC - ] - --- Note [Seemingly useless cmp and bne] --- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction --- the second paragraph says that isync may complete before storage accesses --- "associated" with a preceding instruction have been performed. The cmp --- operation and the following bne introduce a data and control dependency --- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe --- Fetch). --- This is also what gcc does. - - -genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do - code <- assignMem_IntCode (intFormat width) addr val - return $ unitOL(HWSYNC) `appOL` code - -genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - reg_dst = getRegisterReg platform (CmmLocal dst) - if target32Bit platform && width == W64 - then do - ChildCode64 code vr_lo <- iselExpr64 src - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat - lbl3 <- getBlockIdNat - let vr_hi = getHiVRegFromLo vr_lo - cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0)) - , BCC NE lbl2 Nothing - , BCC ALWAYS lbl1 Nothing - - , NEWBLOCK lbl1 - , CNTLZ II32 reg_dst vr_lo - , ADD reg_dst reg_dst (RIImm (ImmInt 32)) - , BCC ALWAYS lbl3 Nothing - - , NEWBLOCK lbl2 - , CNTLZ II32 reg_dst vr_hi - , BCC ALWAYS lbl3 Nothing - - , NEWBLOCK lbl3 - ] - return $ code `appOL` cntlz - else do - let format = if width == W64 then II64 else II32 - (s_reg, s_code) <- getSomeReg src - (pre, reg , post) <- - case width of - W64 -> return (nilOL, s_reg, nilOL) - W32 -> return (nilOL, s_reg, nilOL) - W16 -> do - reg_tmp <- getNewRegNat format - return - ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535)) - , reg_tmp - , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16))) - ) - W8 -> do - reg_tmp <- getNewRegNat format - return - ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255)) - , reg_tmp - , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24))) - ) - _ -> panic "genCall: Clz wrong format" - let cntlz = unitOL (CNTLZ format reg_dst reg) - return $ s_code `appOL` pre `appOL` cntlz `appOL` post - -genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do dflags <- getDynFlags - let platform = targetPlatform dflags - reg_dst = getRegisterReg platform (CmmLocal dst) - if target32Bit platform && width == W64 - then do - let format = II32 - ChildCode64 code vr_lo <- iselExpr64 src - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat - lbl3 <- getBlockIdNat - x' <- getNewRegNat format - x'' <- getNewRegNat format - r' <- getNewRegNat format - cnttzlo <- cnttz format reg_dst vr_lo - let vr_hi = getHiVRegFromLo vr_lo - cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0)) - , BCC NE lbl2 Nothing - , BCC ALWAYS lbl1 Nothing - - , NEWBLOCK lbl1 - , ADD x' vr_hi (RIImm (ImmInt (-1))) - , ANDC x'' x' vr_hi - , CNTLZ format r' x'' - -- 32 + (32 - clz(x'')) - , SUBFC reg_dst r' (RIImm (ImmInt 64)) - , BCC ALWAYS lbl3 Nothing - - , NEWBLOCK lbl2 - ] - `appOL` cnttzlo `appOL` - toOL [ BCC ALWAYS lbl3 Nothing - - , NEWBLOCK lbl3 - ] - return $ code `appOL` cnttz64 - else do - let format = if width == W64 then II64 else II32 - (s_reg, s_code) <- getSomeReg src - (reg_ctz, pre_code) <- - case width of - W64 -> return (s_reg, nilOL) - W32 -> return (s_reg, nilOL) - W16 -> do - reg_tmp <- getNewRegNat format - return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1)) - W8 -> do - reg_tmp <- getNewRegNat format - return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256))) - _ -> panic "genCall: Ctz wrong format" - ctz_code <- cnttz format reg_dst reg_ctz - return $ s_code `appOL` pre_code `appOL` ctz_code - where - -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1)) - -- see Henry S. Warren, Hacker's Delight, p 107 - cnttz format dst src = do - let format_bits = 8 * formatInBytes format - x' <- getNewRegNat format - x'' <- getNewRegNat format - r' <- getNewRegNat format - return $ toOL [ ADD x' src (RIImm (ImmInt (-1))) - , ANDC x'' x' src - , CNTLZ format r' x'' - , SUBFC dst r' (RIImm (ImmInt (format_bits))) - ] - -genCCall target dest_regs argsAndHints - = do dflags <- getDynFlags - let platform = targetPlatform dflags - case target of - PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width - dest_regs argsAndHints - PrimTarget (MO_U_QuotRem width) -> divOp1 platform False width - dest_regs argsAndHints - PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs - argsAndHints - PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs - argsAndHints - PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints - PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints - PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints - PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width - dest_regs argsAndHints - PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width - dest_regs argsAndHints - PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints - PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints - _ -> genCCall' dflags (platformToGCP platform) - target dest_regs argsAndHints - where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y] - = do let reg_q = getRegisterReg platform (CmmLocal res_q) - reg_r = getRegisterReg platform (CmmLocal res_r) - remainderCode width signed reg_q arg_x arg_y - <*> pure reg_r - - divOp1 _ _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp1" - divOp2 platform width [res_q, res_r] - [arg_x_high, arg_x_low, arg_y] - = do let reg_q = getRegisterReg platform (CmmLocal res_q) - reg_r = getRegisterReg platform (CmmLocal res_r) - fmt = intFormat width - half = 4 * (formatInBytes fmt) - (xh_reg, xh_code) <- getSomeReg arg_x_high - (xl_reg, xl_code) <- getSomeReg arg_x_low - (y_reg, y_code) <- getSomeReg arg_y - s <- getNewRegNat fmt - b <- getNewRegNat fmt - v <- getNewRegNat fmt - vn1 <- getNewRegNat fmt - vn0 <- getNewRegNat fmt - un32 <- getNewRegNat fmt - tmp <- getNewRegNat fmt - un10 <- getNewRegNat fmt - un1 <- getNewRegNat fmt - un0 <- getNewRegNat fmt - q1 <- getNewRegNat fmt - rhat <- getNewRegNat fmt - tmp1 <- getNewRegNat fmt - q0 <- getNewRegNat fmt - un21 <- getNewRegNat fmt - again1 <- getBlockIdNat - no1 <- getBlockIdNat - then1 <- getBlockIdNat - endif1 <- getBlockIdNat - again2 <- getBlockIdNat - no2 <- getBlockIdNat - then2 <- getBlockIdNat - endif2 <- getBlockIdNat - return $ y_code `appOL` xl_code `appOL` xh_code `appOL` - -- see Hacker's Delight p 196 Figure 9-3 - toOL [ -- b = 2 ^ (bits_in_word / 2) - LI b (ImmInt 1) - , SL fmt b b (RIImm (ImmInt half)) - -- s = clz(y) - , CNTLZ fmt s y_reg - -- v = y << s - , SL fmt v y_reg (RIReg s) - -- vn1 = upper half of v - , SR fmt vn1 v (RIImm (ImmInt half)) - -- vn0 = lower half of v - , CLRLI fmt vn0 v half - -- un32 = (u1 << s) - -- | (u0 >> (bits_in_word - s)) - , SL fmt un32 xh_reg (RIReg s) - , SUBFC tmp s - (RIImm (ImmInt (8 * formatInBytes fmt))) - , SR fmt tmp xl_reg (RIReg tmp) - , OR un32 un32 (RIReg tmp) - -- un10 = u0 << s - , SL fmt un10 xl_reg (RIReg s) - -- un1 = upper half of un10 - , SR fmt un1 un10 (RIImm (ImmInt half)) - -- un0 = lower half of un10 - , CLRLI fmt un0 un10 half - -- q1 = un32/vn1 - , DIV fmt False q1 un32 vn1 - -- rhat = un32 - q1*vn1 - , MULL fmt tmp q1 (RIReg vn1) - , SUBF rhat tmp un32 - , BCC ALWAYS again1 Nothing - - , NEWBLOCK again1 - -- if (q1 >= b || q1*vn0 > b*rhat + un1) - , CMPL fmt q1 (RIReg b) - , BCC GEU then1 Nothing - , BCC ALWAYS no1 Nothing - - , NEWBLOCK no1 - , MULL fmt tmp q1 (RIReg vn0) - , SL fmt tmp1 rhat (RIImm (ImmInt half)) - , ADD tmp1 tmp1 (RIReg un1) - , CMPL fmt tmp (RIReg tmp1) - , BCC LEU endif1 Nothing - , BCC ALWAYS then1 Nothing - - , NEWBLOCK then1 - -- q1 = q1 - 1 - , ADD q1 q1 (RIImm (ImmInt (-1))) - -- rhat = rhat + vn1 - , ADD rhat rhat (RIReg vn1) - -- if (rhat < b) goto again1 - , CMPL fmt rhat (RIReg b) - , BCC LTT again1 Nothing - , BCC ALWAYS endif1 Nothing - - , NEWBLOCK endif1 - -- un21 = un32*b + un1 - q1*v - , SL fmt un21 un32 (RIImm (ImmInt half)) - , ADD un21 un21 (RIReg un1) - , MULL fmt tmp q1 (RIReg v) - , SUBF un21 tmp un21 - -- compute second quotient digit - -- q0 = un21/vn1 - , DIV fmt False q0 un21 vn1 - -- rhat = un21- q0*vn1 - , MULL fmt tmp q0 (RIReg vn1) - , SUBF rhat tmp un21 - , BCC ALWAYS again2 Nothing - - , NEWBLOCK again2 - -- if (q0>b || q0*vn0 > b*rhat + un0) - , CMPL fmt q0 (RIReg b) - , BCC GEU then2 Nothing - , BCC ALWAYS no2 Nothing - - , NEWBLOCK no2 - , MULL fmt tmp q0 (RIReg vn0) - , SL fmt tmp1 rhat (RIImm (ImmInt half)) - , ADD tmp1 tmp1 (RIReg un0) - , CMPL fmt tmp (RIReg tmp1) - , BCC LEU endif2 Nothing - , BCC ALWAYS then2 Nothing - - , NEWBLOCK then2 - -- q0 = q0 - 1 - , ADD q0 q0 (RIImm (ImmInt (-1))) - -- rhat = rhat + vn1 - , ADD rhat rhat (RIReg vn1) - -- if (rhat> s - , SL fmt reg_r un21 (RIImm (ImmInt half)) - , ADD reg_r reg_r (RIReg un0) - , MULL fmt tmp q0 (RIReg v) - , SUBF reg_r tmp reg_r - , SR fmt reg_r reg_r (RIReg s) - -- compute quotient - -- q = q1*b + q0 - , SL fmt reg_q q1 (RIImm (ImmInt half)) - , ADD reg_q reg_q (RIReg q0) - ] - divOp2 _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp2" - multOp2 platform width [res_h, res_l] [arg_x, arg_y] - = do let reg_h = getRegisterReg platform (CmmLocal res_h) - reg_l = getRegisterReg platform (CmmLocal res_l) - fmt = intFormat width - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg) - , MULHU fmt reg_h x_reg y_reg - ] - multOp2 _ _ _ _ - = panic "genCall: Wrong number of arguments for multOp2" - add2Op platform [res_h, res_l] [arg_x, arg_y] - = do let reg_h = getRegisterReg platform (CmmLocal res_h) - reg_l = getRegisterReg platform (CmmLocal res_l) - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ LI reg_h (ImmInt 0) - , ADDC reg_l x_reg y_reg - , ADDZE reg_h reg_h - ] - add2Op _ _ _ - = panic "genCCall: Wrong number of arguments/results for add2" - - addcOp platform [res_r, res_c] [arg_x, arg_y] - = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y] - addcOp _ _ _ - = panic "genCCall: Wrong number of arguments/results for addc" - - -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1, - -- which is 0 for borrow and 1 otherwise. We need 1 and 0 - -- so xor with 1. - subcOp platform [res_r, res_c] [arg_x, arg_y] - = do let reg_r = getRegisterReg platform (CmmLocal res_r) - reg_c = getRegisterReg platform (CmmLocal res_c) - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ LI reg_c (ImmInt 0) - , SUBFC reg_r y_reg (RIReg x_reg) - , ADDZE reg_c reg_c - , XOR reg_c reg_c (RIImm (ImmInt 1)) - ] - subcOp _ _ _ - = panic "genCCall: Wrong number of arguments/results for subc" - addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y] - = do let reg_r = getRegisterReg platform (CmmLocal res_r) - reg_c = getRegisterReg platform (CmmLocal res_c) - (x_reg, x_code) <- getSomeReg arg_x - (y_reg, y_code) <- getSomeReg arg_y - return $ y_code `appOL` x_code - `appOL` toOL [ instr reg_r y_reg x_reg, - -- SUBFO argument order reversed! - MFOV (intFormat width) reg_c - ] - addSubCOp _ _ _ _ _ - = panic "genCall: Wrong number of arguments/results for addC" - fabs platform [res] [arg] - = do let res_r = getRegisterReg platform (CmmLocal res) - (arg_reg, arg_code) <- getSomeReg arg - return $ arg_code `snocOL` FABS res_r arg_reg - fabs _ _ _ - = panic "genCall: Wrong number of arguments/results for fabs" - --- TODO: replace 'Int' by an enum such as 'PPC_64ABI' -data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX - -platformToGCP :: Platform -> GenCCallPlatform -platformToGCP platform - = case platformOS platform of - OSAIX -> GCPAIX - _ -> case platformArch platform of - ArchPPC -> GCP32ELF - ArchPPC_64 ELF_V1 -> GCP64ELF 1 - ArchPPC_64 ELF_V2 -> GCP64ELF 2 - _ -> panic "platformToGCP: Not PowerPC" - - -genCCall' - :: DynFlags - -> GenCCallPlatform - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - -{- - PowerPC Linux uses the System V Release 4 Calling Convention - for PowerPC. It is described in the - "System V Application Binary Interface PowerPC Processor Supplement". - - PowerPC 64 Linux uses the System V Release 4 Calling Convention for - 64-bit PowerPC. It is specified in - "64-bit PowerPC ELF Application Binary Interface Supplement 1.9" - (PPC64 ELF v1.9). - - PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit - ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement" - (PPC64 ELF v2). - - AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian - 32-Bit Hardware Implementation" - - All four conventions are similar: - Parameters may be passed in general-purpose registers starting at r3, in - floating point registers starting at f1, or on the stack. - - But there are substantial differences: - * The number of registers used for parameter passing and the exact set of - nonvolatile registers differs (see MachRegs.hs). - * On AIX and 64-bit ELF, stack space is always reserved for parameters, - even if they are passed in registers. The called routine may choose to - save parameters from registers to the corresponding space on the stack. - * On AIX and 64-bit ELF, a corresponding amount of GPRs is skipped when - a floating point parameter is passed in an FPR. - * SysV insists on either passing I64 arguments on the stack, or in two GPRs, - starting with an odd-numbered GPR. It may skip a GPR to achieve this. - AIX just treats an I64 likt two separate I32s (high word first). - * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only - 4-byte aligned like everything else on AIX. - * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on - PowerPC Linux does not agree, so neither do we. - - According to all conventions, the parameter area should be part of the - caller's stack frame, allocated in the caller's prologue code (large enough - to hold the parameter lists for all called routines). The NCG already - uses the stack for register spilling, leaving 64 bytes free at the top. - If we need a larger parameter area than that, we increase the size - of the stack frame just before ccalling. --} - - -genCCall' dflags gcp target dest_regs args - = do - (finalStack,passArgumentsCode,usedRegs) <- passArguments - (zip3 args argReps argHints) - allArgRegs - (allFPArgRegs platform) - initialStackOffset - nilOL [] - - (labelOrExpr, reduceToFF32) <- case target of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do - uses_pic_base_implicitly - return (Left lbl, False) - ForeignTarget expr _ -> do - uses_pic_base_implicitly - return (Right expr, False) - PrimTarget mop -> outOfLineMachOp mop - - let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode - codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 - - case labelOrExpr of - Left lbl -> do -- the linker does all the work for us - return ( codeBefore - `snocOL` BL lbl usedRegs - `appOL` maybeNOP -- some ABI require a NOP after BL - `appOL` codeAfter) - Right dyn -> do -- implement call through function pointer - (dynReg, dynCode) <- getSomeReg dyn - case gcp of - GCP64ELF 1 -> return ( dynCode - `appOL` codeBefore - `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40)) - `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0)) - `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8)) - `snocOL` MTCTR r11 - `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16)) - `snocOL` BCTRL usedRegs - `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40)) - `appOL` codeAfter) - GCP64ELF 2 -> return ( dynCode - `appOL` codeBefore - `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24)) - `snocOL` MR r12 dynReg - `snocOL` MTCTR r12 - `snocOL` BCTRL usedRegs - `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24)) - `appOL` codeAfter) - GCPAIX -> return ( dynCode - -- AIX/XCOFF follows the PowerOPEN ABI - -- which is quite similiar to LinuxPPC64/ELFv1 - `appOL` codeBefore - `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20)) - `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0)) - `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4)) - `snocOL` MTCTR r11 - `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8)) - `snocOL` BCTRL usedRegs - `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20)) - `appOL` codeAfter) - _ -> return ( dynCode - `snocOL` MTCTR dynReg - `appOL` codeBefore - `snocOL` BCTRL usedRegs - `appOL` codeAfter) - where - platform = targetPlatform dflags - - uses_pic_base_implicitly = do - -- See Note [implicit register in PPC PIC code] - -- on why we claim to use PIC register here - when (positionIndependent dflags && target32Bit platform) $ do - _ <- getPicBaseNat $ archWordFormat True - return () - - initialStackOffset = case gcp of - GCPAIX -> 24 - GCP32ELF -> 8 - GCP64ELF 1 -> 48 - GCP64ELF 2 -> 32 - _ -> panic "genCall': unknown calling convention" - -- size of linkage area + size of arguments, in bytes - stackDelta finalStack = case gcp of - GCPAIX -> - roundTo 16 $ (24 +) $ max 32 $ sum $ - map (widthInBytes . typeWidth) argReps - GCP32ELF -> roundTo 16 finalStack - GCP64ELF 1 -> - roundTo 16 $ (48 +) $ max 64 $ sum $ - map (roundTo 8 . widthInBytes . typeWidth) - argReps - GCP64ELF 2 -> - roundTo 16 $ (32 +) $ max 64 $ sum $ - map (roundTo 8 . widthInBytes . typeWidth) - argReps - _ -> panic "genCall': unknown calling conv." - - argReps = map (cmmExprType dflags) args - (argHints, _) = foreignTargetHints target - - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) - - spFormat = if target32Bit platform then II32 else II64 - - -- TODO: Do not create a new stack frame if delta is too large. - move_sp_down finalStack - | delta > stackFrameHeaderSize dflags = - toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))), - DELTA (-delta)] - | otherwise = nilOL - where delta = stackDelta finalStack - move_sp_up finalStack - | delta > stackFrameHeaderSize dflags = - toOL [ADD sp sp (RIImm (ImmInt delta)), - DELTA 0] - | otherwise = nilOL - where delta = stackDelta finalStack - - -- A NOP instruction is required after a call (bl instruction) - -- on AIX and 64-Bit Linux. - -- If the call is to a function with a different TOC (r2) the - -- link editor replaces the NOP instruction with a load of the TOC - -- from the stack to restore the TOC. - maybeNOP = case gcp of - GCP32ELF -> nilOL - -- See Section 3.9.4 of OpenPower ABI - GCPAIX -> unitOL NOP - -- See Section 3.5.11 of PPC64 ELF v1.9 - GCP64ELF 1 -> unitOL NOP - -- See Section 2.3.6 of PPC64 ELF v2 - GCP64ELF 2 -> unitOL NOP - _ -> panic "maybeNOP: Unknown PowerPC 64-bit ABI" - - passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) - passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset - accumCode accumUsed | isWord64 arg_ty - && target32Bit (targetPlatform dflags) = - do - ChildCode64 code vr_lo <- iselExpr64 arg - let vr_hi = getHiVRegFromLo vr_lo - - case gcp of - GCPAIX -> - do let storeWord vr (gpr:_) _ = MR gpr vr - storeWord vr [] offset - = ST II32 vr (AddrRegImm sp (ImmInt offset)) - passArguments args - (drop 2 gprs) - fprs - (stackOffset+8) - (accumCode `appOL` code - `snocOL` storeWord vr_hi gprs stackOffset - `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) - ((take 2 gprs) ++ accumUsed) - GCP32ELF -> - do let stackOffset' = roundTo 8 stackOffset - stackCode = accumCode `appOL` code - `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) - `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) - regCode hireg loreg = - accumCode `appOL` code - `snocOL` MR hireg vr_hi - `snocOL` MR loreg vr_lo - - case gprs of - hireg : loreg : regs | even (length gprs) -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _skipped : hireg : loreg : regs -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _ -> -- only one or no regs left - passArguments args [] fprs (stackOffset'+8) - stackCode accumUsed - GCP64ELF _ -> panic "passArguments: 32 bit code" - - passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed - | reg : _ <- regs = do - register <- getRegister arg_pro - let code = case register of - Fixed _ freg fcode -> fcode `snocOL` MR reg freg - Any _ acode -> acode reg - stackOffsetRes = case gcp of - -- The PowerOpen ABI requires that we - -- reserve stack slots for register - -- parameters - GCPAIX -> stackOffset + stackBytes - -- ... the SysV ABI 32-bit doesn't. - GCP32ELF -> stackOffset - -- ... but SysV ABI 64-bit does. - GCP64ELF _ -> stackOffset + stackBytes - passArguments args - (drop nGprs gprs) - (drop nFprs fprs) - stackOffsetRes - (accumCode `appOL` code) - (reg : accumUsed) - | otherwise = do - (vr, code) <- getSomeReg arg_pro - passArguments args - (drop nGprs gprs) - (drop nFprs fprs) - (stackOffset' + stackBytes) - (accumCode `appOL` code - `snocOL` ST format_pro vr stackSlot) - accumUsed - where - arg_pro - | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth dflags)) [arg] - | otherwise = arg - format_pro - | isBitsType rep = intFormat (wordWidth dflags) - | otherwise = cmmTypeFormat rep - conv_op = case hint of - SignedHint -> MO_SS_Conv - _ -> MO_UU_Conv - - stackOffset' = case gcp of - GCPAIX -> - -- The 32bit PowerOPEN ABI is happy with - -- 32bit-alignment ... - stackOffset - GCP32ELF - -- ... the SysV ABI requires 8-byte - -- alignment for doubles. - | isFloatType rep && typeWidth rep == W64 -> - roundTo 8 stackOffset - | otherwise -> - stackOffset - GCP64ELF _ -> - -- Everything on the stack is mapped to - -- 8-byte aligned doublewords - stackOffset - stackOffset'' - | isFloatType rep && typeWidth rep == W32 = - case gcp of - -- The ELF v1 ABI Section 3.2.3 requires: - -- "Single precision floating point values - -- are mapped to the second word in a single - -- doubleword" - GCP64ELF 1 -> stackOffset' + 4 - _ -> stackOffset' - | otherwise = stackOffset' - - stackSlot = AddrRegImm sp (ImmInt stackOffset'') - (nGprs, nFprs, stackBytes, regs) - = case gcp of - GCPAIX -> - case cmmTypeFormat rep of - II8 -> (1, 0, 4, gprs) - II16 -> (1, 0, 4, gprs) - II32 -> (1, 0, 4, gprs) - -- The PowerOpen ABI requires that we skip a - -- corresponding number of GPRs when we use - -- the FPRs. - -- - -- E.g. for a `double` two GPRs are skipped, - -- whereas for a `float` one GPR is skipped - -- when parameters are assigned to - -- registers. - -- - -- The PowerOpen ABI specification can be found at - -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/ - FF32 -> (1, 1, 4, fprs) - FF64 -> (2, 1, 8, fprs) - II64 -> panic "genCCall' passArguments II64" - - GCP32ELF -> - case cmmTypeFormat rep of - II8 -> (1, 0, 4, gprs) - II16 -> (1, 0, 4, gprs) - II32 -> (1, 0, 4, gprs) - -- ... the SysV ABI doesn't. - FF32 -> (0, 1, 4, fprs) - FF64 -> (0, 1, 8, fprs) - II64 -> panic "genCCall' passArguments II64" - GCP64ELF _ -> - case cmmTypeFormat rep of - II8 -> (1, 0, 8, gprs) - II16 -> (1, 0, 8, gprs) - II32 -> (1, 0, 8, gprs) - II64 -> (1, 0, 8, gprs) - -- The ELFv1 ABI requires that we skip a - -- corresponding number of GPRs when we use - -- the FPRs. - FF32 -> (1, 1, 8, fprs) - FF64 -> (1, 1, 8, fprs) - - moveResult reduceToFF32 = - case dest_regs of - [] -> nilOL - [dest] - | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) - | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) - | isWord64 rep && target32Bit (targetPlatform dflags) - -> toOL [MR (getHiVRegFromLo r_dest) r3, - MR r_dest r4] - | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType dflags (CmmLocal dest) - r_dest = getRegisterReg platform (CmmLocal dest) - _ -> panic "genCCall' moveResult: Bad dest_regs" - - outOfLineMachOp mop = - do - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags CallReference $ - mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction - let mopLabelOrExpr = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - return (mopLabelOrExpr, reduce) - where - (functionName, reduce) = case mop of - MO_F32_Exp -> (fsLit "exp", True) - MO_F32_ExpM1 -> (fsLit "expm1", True) - MO_F32_Log -> (fsLit "log", True) - MO_F32_Log1P -> (fsLit "log1p", True) - MO_F32_Sqrt -> (fsLit "sqrt", True) - MO_F32_Fabs -> unsupported - - MO_F32_Sin -> (fsLit "sin", True) - MO_F32_Cos -> (fsLit "cos", True) - MO_F32_Tan -> (fsLit "tan", True) - - MO_F32_Asin -> (fsLit "asin", True) - MO_F32_Acos -> (fsLit "acos", True) - MO_F32_Atan -> (fsLit "atan", True) - - MO_F32_Sinh -> (fsLit "sinh", True) - MO_F32_Cosh -> (fsLit "cosh", True) - MO_F32_Tanh -> (fsLit "tanh", True) - MO_F32_Pwr -> (fsLit "pow", True) - - MO_F32_Asinh -> (fsLit "asinh", True) - MO_F32_Acosh -> (fsLit "acosh", True) - MO_F32_Atanh -> (fsLit "atanh", True) - - MO_F64_Exp -> (fsLit "exp", False) - MO_F64_ExpM1 -> (fsLit "expm1", False) - MO_F64_Log -> (fsLit "log", False) - MO_F64_Log1P -> (fsLit "log1p", False) - MO_F64_Sqrt -> (fsLit "sqrt", False) - MO_F64_Fabs -> unsupported - - MO_F64_Sin -> (fsLit "sin", False) - MO_F64_Cos -> (fsLit "cos", False) - MO_F64_Tan -> (fsLit "tan", False) - - MO_F64_Asin -> (fsLit "asin", False) - MO_F64_Acos -> (fsLit "acos", False) - MO_F64_Atan -> (fsLit "atan", False) - - MO_F64_Sinh -> (fsLit "sinh", False) - MO_F64_Cosh -> (fsLit "cosh", False) - MO_F64_Tanh -> (fsLit "tanh", False) - MO_F64_Pwr -> (fsLit "pow", False) - - MO_F64_Asinh -> (fsLit "asinh", False) - MO_F64_Acosh -> (fsLit "acosh", False) - MO_F64_Atanh -> (fsLit "atanh", False) - - MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False) - - MO_Memcpy _ -> (fsLit "memcpy", False) - MO_Memset _ -> (fsLit "memset", False) - MO_Memmove _ -> (fsLit "memmove", False) - MO_Memcmp _ -> (fsLit "memcmp", False) - - MO_BSwap w -> (fsLit $ bSwapLabel w, False) - MO_BRev w -> (fsLit $ bRevLabel w, False) - MO_PopCnt w -> (fsLit $ popCntLabel w, False) - MO_Pdep w -> (fsLit $ pdepLabel w, False) - MO_Pext w -> (fsLit $ pextLabel w, False) - MO_Clz _ -> unsupported - MO_Ctz _ -> unsupported - MO_AtomicRMW {} -> unsupported - MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) - MO_AtomicRead _ -> unsupported - MO_AtomicWrite _ -> unsupported - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddWordC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - MO_Prefetch_Data _ -> unsupported - unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported") - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets - | OSAIX <- platformOS (targetPlatform dflags) - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - let fmt = archWordFormat $ target32Bit $ targetPlatform dflags - sha = if target32Bit $ targetPlatform dflags then 2 else 3 - tmp <- getNewRegNat fmt - lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let code = e_code `appOL` t_code `appOL` toOL [ - SL fmt tmp reg (RIImm (ImmInt sha)), - LD fmt tmp (AddrRegReg tableReg tmp), - MTCTR tmp, - BCTR ids (Just lbl) [] - ] - return code - - | (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags) - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - let fmt = archWordFormat $ target32Bit $ targetPlatform dflags - sha = if target32Bit $ targetPlatform dflags then 2 else 3 - tmp <- getNewRegNat fmt - lbl <- getNewLabelNat - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let code = e_code `appOL` t_code `appOL` toOL [ - SL fmt tmp reg (RIImm (ImmInt sha)), - LD fmt tmp (AddrRegReg tableReg tmp), - ADD tmp tmp (RIReg tableReg), - MTCTR tmp, - BCTR ids (Just lbl) [] - ] - return code - | otherwise - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - let fmt = archWordFormat $ target32Bit $ targetPlatform dflags - sha = if target32Bit $ targetPlatform dflags then 2 else 3 - tmp <- getNewRegNat fmt - lbl <- getNewLabelNat - let code = e_code `appOL` toOL [ - SL fmt tmp reg (RIImm (ImmInt sha)), - ADDIS tmp tmp (HA (ImmCLbl lbl)), - LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), - MTCTR tmp, - BCTR ids (Just lbl) [] - ] - return code - where (offset, ids) = switchTargetsToTable targets - -generateJumpTableForInstr :: DynFlags -> Instr - -> Maybe (NatCmmDecl CmmStatics Instr) -generateJumpTableForInstr dflags (BCTR ids (Just lbl) _) = - let jumpTable - | (positionIndependent dflags) - || (not $ target32Bit $ targetPlatform dflags) - = map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry dflags) ids - where jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 (wordWidth dflags)) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 - (wordWidth dflags)) - where blockLabel = blockLbl blockid - in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable)) -generateJumpTableForInstr _ _ = Nothing - --- ----------------------------------------------------------------------------- --- 'condIntReg' and 'condFltReg': condition codes into registers - --- Turn those condition codes into integers now (when they appear on --- the right hand side of an assignment). - - - -condReg :: NatM CondCode -> NatM Register -condReg getCond = do - CondCode _ cond cond_code <- getCond - dflags <- getDynFlags - let - code dst = cond_code - `appOL` negate_code - `appOL` toOL [ - MFCR dst, - RLWINM dst dst (bit + 1) 31 31 - ] - - negate_code | do_negate = unitOL (CRNOR bit bit bit) - | otherwise = nilOL - - (bit, do_negate) = case cond of - LTT -> (0, False) - LE -> (1, True) - EQQ -> (2, False) - GE -> (0, True) - GTT -> (1, False) - - NE -> (2, True) - - LU -> (0, False) - LEU -> (1, True) - GEU -> (0, True) - GU -> (1, False) - _ -> panic "PPC.CodeGen.codeReg: no match" - - format = archWordFormat $ target32Bit $ targetPlatform dflags - return (Any format code) - -condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register -condIntReg cond width x y = condReg (condIntCode cond width x y) -condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condFltReg cond x y = condReg (condFltCode cond x y) - - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - - - -{- -Wolfgang's PowerPC version of The Rules: - -A slightly modified version of The Rules to take advantage of the fact -that PowerPC instructions work on all registers and don't implicitly -clobber any fixed registers. - -* The only expression for which getRegister returns Fixed is (CmmReg reg). - -* If getRegister returns Any, then the code it generates may modify only: - (a) fresh temporaries - (b) the destination register - It may *not* modify global registers, unless the global - register happens to be the destination register. - It may not clobber any other registers. In fact, only ccalls clobber any - fixed registers. - Also, it may not modify the counter register (used by genCCall). - - Corollary: If a getRegister for a subexpression returns Fixed, you need - not move it to a fresh temporary before evaluating the next subexpression. - The Fixed register won't be modified. - Therefore, we don't need a counterpart for the x86's getStableReg on PPC. - -* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on - the value of the destination register. --} - -trivialCode - :: Width - -> Bool - -> (Reg -> Reg -> RI -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialCode rep signed instr x (CmmLit (CmmInt y _)) - | Just imm <- makeImmediate rep signed y - = do - (src1, code1) <- getSomeReg x - let code dst = code1 `snocOL` instr dst src1 (RIImm imm) - return (Any (intFormat rep) code) - -trivialCode rep _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2) - return (Any (intFormat rep) code) - -shiftMulCode - :: Width - -> Bool - -> (Format-> Reg -> Reg -> RI -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register -shiftMulCode width sign instr x (CmmLit (CmmInt y _)) - | Just imm <- makeImmediate width sign y - = do - (src1, code1) <- getSomeReg x - let format = intFormat width - let ins_fmt = intFormat (max W32 width) - let code dst = code1 `snocOL` instr ins_fmt dst src1 (RIImm imm) - return (Any format code) - -shiftMulCode width _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let format = intFormat width - let ins_fmt = intFormat (max W32 width) - let code dst = code1 `appOL` code2 - `snocOL` instr ins_fmt dst src1 (RIReg src2) - return (Any format code) - -trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCodeNoImm' format instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2 - return (Any format code) - -trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCodeNoImm format instr x y - = trivialCodeNoImm' format (instr format) x y - -srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -srCode width sgn instr x (CmmLit (CmmInt y _)) - | Just imm <- makeImmediate width sgn y - = do - let op_len = max W32 width - extend = if sgn then extendSExpr else extendUExpr - (src1, code1) <- getSomeReg (extend width op_len x) - let code dst = code1 `snocOL` - instr (intFormat op_len) dst src1 (RIImm imm) - return (Any (intFormat width) code) - -srCode width sgn instr x y = do - let op_len = max W32 width - extend = if sgn then extendSExpr else extendUExpr - (src1, code1) <- getSomeReg (extend width op_len x) - (src2, code2) <- getSomeReg (extendUExpr width op_len y) - -- Note: Shift amount `y` is unsigned - let code dst = code1 `appOL` code2 `snocOL` - instr (intFormat op_len) dst src1 (RIReg src2) - return (Any (intFormat width) code) - -divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register -divCode width sgn x y = do - let op_len = max W32 width - extend = if sgn then extendSExpr else extendUExpr - (src1, code1) <- getSomeReg (extend width op_len x) - (src2, code2) <- getSomeReg (extend width op_len y) - let code dst = code1 `appOL` code2 `snocOL` - DIV (intFormat op_len) sgn dst src1 src2 - return (Any (intFormat width) code) - - -trivialUCode :: Format - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register -trivialUCode rep instr x = do - (src, code) <- getSomeReg x - let code' dst = code `snocOL` instr dst src - return (Any rep code') - --- There is no "remainder" instruction on the PPC, so we have to do --- it the hard way. --- The "sgn" parameter is the signedness for the division instruction - -remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr - -> NatM (Reg -> InstrBlock) -remainderCode rep sgn reg_q arg_x arg_y = do - let op_len = max W32 rep - fmt = intFormat op_len - extend = if sgn then extendSExpr else extendUExpr - (x_reg, x_code) <- getSomeReg (extend rep op_len arg_x) - (y_reg, y_code) <- getSomeReg (extend rep op_len arg_y) - return $ \reg_r -> y_code `appOL` x_code - `appOL` toOL [ DIV fmt sgn reg_q x_reg y_reg - , MULL fmt reg_r reg_q (RIReg y_reg) - , SUBF reg_r reg_r x_reg - ] - - -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP fromRep toRep x = do - dflags <- getDynFlags - let arch = platformArch $ targetPlatform dflags - coerceInt2FP' arch fromRep toRep x - -coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP' ArchPPC fromRep toRep x = do - (src, code) <- getSomeReg x - lbl <- getNewLabelNat - itmp <- getNewRegNat II32 - ftmp <- getNewRegNat FF64 - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - Amode addr addr_code <- getAmode D dynRef - let - code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA (Section ReadOnlyData lbl) $ Statics lbl - [CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], - XORIS itmp src (ImmInt 0x8000), - ST II32 itmp (spRel dflags 3), - LIS itmp (ImmInt 0x4330), - ST II32 itmp (spRel dflags 2), - LD FF64 ftmp (spRel dflags 2) - ] `appOL` addr_code `appOL` toOL [ - LD FF64 dst addr, - FSUB FF64 dst ftmp dst - ] `appOL` maybe_frsp dst - - maybe_exts = case fromRep of - W8 -> unitOL $ EXTS II8 src src - W16 -> unitOL $ EXTS II16 src src - W32 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - maybe_frsp dst - = case toRep of - W32 -> unitOL $ FRSP dst dst - W64 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - return (Any (floatFormat toRep) code') - --- On an ELF v1 Linux we use the compiler doubleword in the stack frame --- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only --- set right before a call and restored right after return from the call. --- So it is fine. -coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do - (src, code) <- getSomeReg x - dflags <- getDynFlags - let - code' dst = code `appOL` maybe_exts `appOL` toOL [ - ST II64 src (spRel dflags 3), - LD FF64 dst (spRel dflags 3), - FCFID dst dst - ] `appOL` maybe_frsp dst - - maybe_exts = case fromRep of - W8 -> unitOL $ EXTS II8 src src - W16 -> unitOL $ EXTS II16 src src - W32 -> unitOL $ EXTS II32 src src - W64 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - maybe_frsp dst - = case toRep of - W32 -> unitOL $ FRSP dst dst - W64 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - - return (Any (floatFormat toRep) code') - -coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch" - - -coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int fromRep toRep x = do - dflags <- getDynFlags - let arch = platformArch $ targetPlatform dflags - coerceFP2Int' arch fromRep toRep x - -coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int' ArchPPC _ toRep x = do - dflags <- getDynFlags - -- the reps don't really matter: F*->FF64 and II32->I* are no-ops - (src, code) <- getSomeReg x - tmp <- getNewRegNat FF64 - let - code' dst = code `appOL` toOL [ - -- convert to int in FP reg - FCTIWZ tmp src, - -- store value (64bit) from FP to stack - ST FF64 tmp (spRel dflags 2), - -- read low word of value (high word is undefined) - LD II32 dst (spRel dflags 3)] - return (Any (intFormat toRep) code') - -coerceFP2Int' (ArchPPC_64 _) _ toRep x = do - dflags <- getDynFlags - -- the reps don't really matter: F*->FF64 and II64->I* are no-ops - (src, code) <- getSomeReg x - tmp <- getNewRegNat FF64 - let - code' dst = code `appOL` toOL [ - -- convert to int in FP reg - FCTIDZ tmp src, - -- store value (64bit) from FP to compiler word on stack - ST FF64 tmp (spRel dflags 3), - LD II64 dst (spRel dflags 3)] - return (Any (intFormat toRep) code') - -coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch" - --- Note [.LCTOC1 in PPC PIC code] --- The .LCTOC1 label is defined to point 32768 bytes into the GOT table --- to make the most of the PPC's 16-bit displacements. --- As 16-bit signed offset is used (usually via addi/lwz instructions) --- first element will have '-32768' offset against .LCTOC1. - --- Note [implicit register in PPC PIC code] --- PPC generates calls by labels in assembly --- in form of: --- bl puts+32768@plt --- in this form it's not seen directly (by GHC NCG) --- that r30 (PicBaseReg) is used, --- but r30 is a required part of PLT code setup: --- puts+32768@plt: --- lwz r11,-30484(r30) ; offset in .LCTOC1 --- mtctr r11 --- bctr diff --git a/nativeGen/PPC/Cond.hs b/nativeGen/PPC/Cond.hs deleted file mode 100644 --- a/nativeGen/PPC/Cond.hs +++ /dev/null @@ -1,63 +0,0 @@ -module PPC.Cond ( - Cond(..), - condNegate, - condUnsigned, - condToSigned, - condToUnsigned, -) - -where - -import GhcPrelude - -import Panic - -data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - deriving Eq - - -condNegate :: Cond -> Cond -condNegate ALWAYS = panic "condNegate: ALWAYS" -condNegate EQQ = NE -condNegate GE = LTT -condNegate GEU = LU -condNegate GTT = LE -condNegate GU = LEU -condNegate LE = GTT -condNegate LEU = GU -condNegate LTT = GE -condNegate LU = GEU -condNegate NE = EQQ - --- Condition utils -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x diff --git a/nativeGen/PPC/Instr.hs b/nativeGen/PPC/Instr.hs deleted file mode 100644 --- a/nativeGen/PPC/Instr.hs +++ /dev/null @@ -1,711 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ - -#include "HsVersions.h" - -module PPC.Instr ( - archWordFormat, - RI(..), - Instr(..), - stackFrameHeaderSize, - maxSpillSlots, - allocMoreStack, - makeFarBranches -) - -where - -import GhcPrelude - -import PPC.Regs -import PPC.Cond -import Instruction -import Format -import TargetReg -import RegClass -import Reg - -import GHC.Platform.Regs -import BlockId -import Hoopl.Collections -import Hoopl.Label -import DynFlags -import Cmm -import CmmInfo -import FastString -import CLabel -import Outputable -import GHC.Platform -import UniqFM (listToUFM, lookupUFM) -import UniqSupply - -import Control.Monad (replicateM) -import Data.Maybe (fromMaybe) - --------------------------------------------------------------------------------- --- Format of a PPC memory address. --- -archWordFormat :: Bool -> Format -archWordFormat is32Bit - | is32Bit = II32 - | otherwise = II64 - - --- | Instruction instance for powerpc -instance Instruction Instr where - regUsageOfInstr = ppc_regUsageOfInstr - patchRegsOfInstr = ppc_patchRegsOfInstr - isJumpishInstr = ppc_isJumpishInstr - jumpDestsOfInstr = ppc_jumpDestsOfInstr - patchJumpInstr = ppc_patchJumpInstr - mkSpillInstr = ppc_mkSpillInstr - mkLoadInstr = ppc_mkLoadInstr - takeDeltaInstr = ppc_takeDeltaInstr - isMetaInstr = ppc_isMetaInstr - mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr - takeRegRegMoveInstr = ppc_takeRegRegMoveInstr - mkJumpInstr = ppc_mkJumpInstr - mkStackAllocInstr = ppc_mkStackAllocInstr - mkStackDeallocInstr = ppc_mkStackDeallocInstr - - -ppc_mkStackAllocInstr :: Platform -> Int -> [Instr] -ppc_mkStackAllocInstr platform amount - = ppc_mkStackAllocInstr' platform (-amount) - -ppc_mkStackDeallocInstr :: Platform -> Int -> [Instr] -ppc_mkStackDeallocInstr platform amount - = ppc_mkStackAllocInstr' platform amount - -ppc_mkStackAllocInstr' :: Platform -> Int -> [Instr] -ppc_mkStackAllocInstr' platform amount - | fits16Bits amount - = [ LD fmt r0 (AddrRegImm sp zero) - , STU fmt r0 (AddrRegImm sp immAmount) - ] - | otherwise - = [ LD fmt r0 (AddrRegImm sp zero) - , ADDIS tmp sp (HA immAmount) - , ADD tmp tmp (RIImm (LO immAmount)) - , STU fmt r0 (AddrRegReg sp tmp) - ] - where - fmt = intFormat $ widthFromBytes (platformWordSizeInBytes platform) - zero = ImmInt 0 - tmp = tmpReg platform - immAmount = ImmInt amount - --- --- See note [extra spill slots] in X86/Instr.hs --- -allocMoreStack - :: Platform - -> Int - -> NatCmmDecl statics PPC.Instr.Instr - -> UniqSM (NatCmmDecl statics PPC.Instr.Instr, [(BlockId,BlockId)]) - -allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) -allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do - let - infos = mapKeys info - entries = case code of - [] -> infos - BasicBlock entry _ : _ -- first block is the entry point - | entry `elem` infos -> infos - | otherwise -> entry : infos - - uniqs <- replicateM (length entries) getUniqueM - - let - delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up - where x = slots * spillSlotSize -- sp delta - - alloc = mkStackAllocInstr platform delta - dealloc = mkStackDeallocInstr platform delta - - retargetList = (zip entries (map mkBlockId uniqs)) - - new_blockmap :: LabelMap BlockId - new_blockmap = mapFromList retargetList - - insert_stack_insns (BasicBlock id insns) - | Just new_blockid <- mapLookup id new_blockmap - = [ BasicBlock id $ alloc ++ [BCC ALWAYS new_blockid Nothing] - , BasicBlock new_blockid block' - ] - | otherwise - = [ BasicBlock id block' ] - where - block' = foldr insert_dealloc [] insns - - insert_dealloc insn r - -- BCTR might or might not be a non-local jump. For - -- "labeled-goto" we use JMP, and for "computed-goto" we - -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'. - = case insn of - JMP _ _ -> dealloc ++ (insn : r) - BCTR [] Nothing _ -> dealloc ++ (insn : r) - BCTR ids label rs -> BCTR (map (fmap retarget) ids) label rs : r - BCCFAR cond b p -> BCCFAR cond (retarget b) p : r - BCC cond b p -> BCC cond (retarget b) p : r - _ -> insn : r - -- BL and BCTRL are call-like instructions rather than - -- jumps, and are used only for C calls. - - retarget :: BlockId -> BlockId - retarget b - = fromMaybe b (mapLookup b new_blockmap) - - new_code - = concatMap insert_stack_insns code - - -- in - return (CmmProc info lbl live (ListGraph new_code),retargetList) - - --- ----------------------------------------------------------------------------- --- Machine's assembly language - --- We have a few common "instructions" (nearly all the pseudo-ops) but --- mostly all of 'Instr' is machine-specific. - --- Register or immediate -data RI - = RIReg Reg - | RIImm Imm - -data Instr - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code - -- generation. Will be extracted before - -- pretty-printing. - | LDATA Section CmmStatics - - -- start a new basic block. Useful during - -- codegen, removed later. Preceding - -- instruction should be a jump, as per the - -- invariants for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for - -- benefit of subsequent passes - | DELTA Int - - -- Loads and stores. - | LD Format Reg AddrMode -- Load format, dst, src - | LDFAR Format Reg AddrMode -- Load format, dst, src 32 bit offset - | LDR Format Reg AddrMode -- Load and reserve format, dst, src - | LA Format Reg AddrMode -- Load arithmetic format, dst, src - | ST Format Reg AddrMode -- Store format, src, dst - | STFAR Format Reg AddrMode -- Store format, src, dst 32 bit offset - | STU Format Reg AddrMode -- Store with Update format, src, dst - | STC Format Reg AddrMode -- Store conditional format, src, dst - | LIS Reg Imm -- Load Immediate Shifted dst, src - | LI Reg Imm -- Load Immediate dst, src - | MR Reg Reg -- Move Register dst, src -- also for fmr - - | CMP Format Reg RI -- format, src1, src2 - | CMPL Format Reg RI -- format, src1, src2 - - | BCC Cond BlockId (Maybe Bool) -- cond, block, hint - | BCCFAR Cond BlockId (Maybe Bool) -- cond, block, hint - -- hint: - -- Just True: branch likely taken - -- Just False: branch likely not taken - -- Nothing: no hint - | JMP CLabel [Reg] -- same as branch, - -- but with CLabel instead of block ID - -- and live global registers - | MTCTR Reg - | BCTR [Maybe BlockId] (Maybe CLabel) [Reg] - -- with list of local destinations, and - -- jump table location if necessary - | BL CLabel [Reg] -- with list of argument regs - | BCTRL [Reg] - - | ADD Reg Reg RI -- dst, src1, src2 - | ADDO Reg Reg Reg -- add and set overflow - | ADDC Reg Reg Reg -- (carrying) dst, src1, src2 - | ADDE Reg Reg Reg -- (extended) dst, src1, src2 - | ADDZE Reg Reg -- (to zero extended) dst, src - | ADDIS Reg Reg Imm -- Add Immediate Shifted dst, src1, src2 - | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1 - | SUBFO Reg Reg Reg -- subtract from and set overflow - | SUBFC Reg Reg RI -- (carrying) dst, src1, src2 ; - -- dst = src2 - src1 - | SUBFE Reg Reg Reg -- (extended) dst, src1, src2 ; - -- dst = src2 - src1 - | MULL Format Reg Reg RI - | MULLO Format Reg Reg Reg -- multiply and set overflow - | MFOV Format Reg -- move overflow bit (1|33) to register - -- pseudo-instruction; pretty printed as - -- mfxer dst - -- extr[w|d]i dst, dst, 1, [1|33] - | MULHU Format Reg Reg Reg - | DIV Format Bool Reg Reg Reg - | AND Reg Reg RI -- dst, src1, src2 - | ANDC Reg Reg Reg -- AND with complement, dst = src1 & ~ src2 - | NAND Reg Reg Reg -- dst, src1, src2 - | OR Reg Reg RI -- dst, src1, src2 - | ORIS Reg Reg Imm -- OR Immediate Shifted dst, src1, src2 - | XOR Reg Reg RI -- dst, src1, src2 - | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2 - - | EXTS Format Reg Reg - | CNTLZ Format Reg Reg - - | NEG Reg Reg - | NOT Reg Reg - - | SL Format Reg Reg RI -- shift left - | SR Format Reg Reg RI -- shift right - | SRA Format Reg Reg RI -- shift right arithmetic - - | RLWINM Reg Reg Int Int Int -- Rotate Left Word Immediate then AND with Mask - | CLRLI Format Reg Reg Int -- clear left immediate (extended mnemonic) - | CLRRI Format Reg Reg Int -- clear right immediate (extended mnemonic) - - | FADD Format Reg Reg Reg - | FSUB Format Reg Reg Reg - | FMUL Format Reg Reg Reg - | FDIV Format Reg Reg Reg - | FABS Reg Reg -- abs is the same for single and double - | FNEG Reg Reg -- negate is the same for single and double prec. - - | FCMP Reg Reg - - | FCTIWZ Reg Reg -- convert to integer word - | FCTIDZ Reg Reg -- convert to integer double word - | FCFID Reg Reg -- convert from integer double word - | FRSP Reg Reg -- reduce to single precision - -- (but destination is a FP register) - - | CRNOR Int Int Int -- condition register nor - | MFCR Reg -- move from condition register - - | MFLR Reg -- move from link register - | FETCHPC Reg -- pseudo-instruction: - -- bcl to next insn, mflr reg - | HWSYNC -- heavy weight sync - | ISYNC -- instruction synchronize - | LWSYNC -- memory barrier - | NOP -- no operation, PowerPC 64 bit - -- needs this as place holder to - -- reload TOC pointer - --- | Get the registers that are being used by this instruction. --- regUsage doesn't need to do any trickery for jumps and such. --- Just state precisely the regs read and written by that insn. --- The consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. --- -ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage -ppc_regUsageOfInstr platform instr - = case instr of - LD _ reg addr -> usage (regAddr addr, [reg]) - LDFAR _ reg addr -> usage (regAddr addr, [reg]) - LDR _ reg addr -> usage (regAddr addr, [reg]) - LA _ reg addr -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - STFAR _ reg addr -> usage (reg : regAddr addr, []) - STU _ reg addr -> usage (reg : regAddr addr, []) - STC _ reg addr -> usage (reg : regAddr addr, []) - LIS reg _ -> usage ([], [reg]) - LI reg _ -> usage ([], [reg]) - MR reg1 reg2 -> usage ([reg2], [reg1]) - CMP _ reg ri -> usage (reg : regRI ri,[]) - CMPL _ reg ri -> usage (reg : regRI ri,[]) - BCC _ _ _ -> noUsage - BCCFAR _ _ _ -> noUsage - JMP _ regs -> usage (regs, []) - MTCTR reg -> usage ([reg],[]) - BCTR _ _ regs -> usage (regs, []) - BL _ params -> usage (params, callClobberedRegs platform) - BCTRL params -> usage (params, callClobberedRegs platform) - - ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - ADDO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - ADDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - ADDE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - ADDZE reg1 reg2 -> usage ([reg2], [reg1]) - ADDIS reg1 reg2 _ -> usage ([reg2], [reg1]) - SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - SUBFO reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - SUBFC reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - SUBFE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - MULL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - MULLO _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - MFOV _ reg -> usage ([], [reg]) - MULHU _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - DIV _ _ reg1 reg2 reg3 - -> usage ([reg2,reg3], [reg1]) - - AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - ANDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - NAND reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - ORIS reg1 reg2 _ -> usage ([reg2], [reg1]) - XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - XORIS reg1 reg2 _ -> usage ([reg2], [reg1]) - EXTS _ reg1 reg2 -> usage ([reg2], [reg1]) - CNTLZ _ reg1 reg2 -> usage ([reg2], [reg1]) - NEG reg1 reg2 -> usage ([reg2], [reg1]) - NOT reg1 reg2 -> usage ([reg2], [reg1]) - SL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - SR _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - SRA _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1]) - CLRLI _ reg1 reg2 _ -> usage ([reg2], [reg1]) - CLRRI _ reg1 reg2 _ -> usage ([reg2], [reg1]) - - FADD _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FSUB _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FMUL _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FDIV _ r1 r2 r3 -> usage ([r2,r3], [r1]) - FABS r1 r2 -> usage ([r2], [r1]) - FNEG r1 r2 -> usage ([r2], [r1]) - FCMP r1 r2 -> usage ([r1,r2], []) - FCTIWZ r1 r2 -> usage ([r2], [r1]) - FCTIDZ r1 r2 -> usage ([r2], [r1]) - FCFID r1 r2 -> usage ([r2], [r1]) - FRSP r1 r2 -> usage ([r2], [r1]) - MFCR reg -> usage ([], [reg]) - MFLR reg -> usage ([], [reg]) - FETCHPC reg -> usage ([], [reg]) - _ -> noUsage - where - usage (src, dst) = RU (filter (interesting platform) src) - (filter (interesting platform) dst) - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] - - regRI (RIReg r) = [r] - regRI _ = [] - -interesting :: Platform -> Reg -> Bool -interesting _ (RegVirtual _) = True -interesting platform (RegReal (RealRegSingle i)) = freeReg platform i -interesting _ (RegReal (RealRegPair{})) - = panic "PPC.Instr.interesting: no reg pairs on this arch" - - - --- | Apply a given mapping to all the register references in this --- instruction. -ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -ppc_patchRegsOfInstr instr env - = case instr of - LD fmt reg addr -> LD fmt (env reg) (fixAddr addr) - LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr) - LDR fmt reg addr -> LDR fmt (env reg) (fixAddr addr) - LA fmt reg addr -> LA fmt (env reg) (fixAddr addr) - ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) - STFAR fmt reg addr -> STFAR fmt (env reg) (fixAddr addr) - STU fmt reg addr -> STU fmt (env reg) (fixAddr addr) - STC fmt reg addr -> STC fmt (env reg) (fixAddr addr) - LIS reg imm -> LIS (env reg) imm - LI reg imm -> LI (env reg) imm - MR reg1 reg2 -> MR (env reg1) (env reg2) - CMP fmt reg ri -> CMP fmt (env reg) (fixRI ri) - CMPL fmt reg ri -> CMPL fmt (env reg) (fixRI ri) - BCC cond lbl p -> BCC cond lbl p - BCCFAR cond lbl p -> BCCFAR cond lbl p - JMP l regs -> JMP l regs -- global regs will not be remapped - MTCTR reg -> MTCTR (env reg) - BCTR targets lbl rs -> BCTR targets lbl rs - BL imm argRegs -> BL imm argRegs -- argument regs - BCTRL argRegs -> BCTRL argRegs -- cannot be remapped - ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri) - ADDO reg1 reg2 reg3 -> ADDO (env reg1) (env reg2) (env reg3) - ADDC reg1 reg2 reg3 -> ADDC (env reg1) (env reg2) (env reg3) - ADDE reg1 reg2 reg3 -> ADDE (env reg1) (env reg2) (env reg3) - ADDZE reg1 reg2 -> ADDZE (env reg1) (env reg2) - ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm - SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3) - SUBFO reg1 reg2 reg3 -> SUBFO (env reg1) (env reg2) (env reg3) - SUBFC reg1 reg2 ri -> SUBFC (env reg1) (env reg2) (fixRI ri) - SUBFE reg1 reg2 reg3 -> SUBFE (env reg1) (env reg2) (env reg3) - MULL fmt reg1 reg2 ri - -> MULL fmt (env reg1) (env reg2) (fixRI ri) - MULLO fmt reg1 reg2 reg3 - -> MULLO fmt (env reg1) (env reg2) (env reg3) - MFOV fmt reg -> MFOV fmt (env reg) - MULHU fmt reg1 reg2 reg3 - -> MULHU fmt (env reg1) (env reg2) (env reg3) - DIV fmt sgn reg1 reg2 reg3 - -> DIV fmt sgn (env reg1) (env reg2) (env reg3) - - AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri) - ANDC reg1 reg2 reg3 -> ANDC (env reg1) (env reg2) (env reg3) - NAND reg1 reg2 reg3 -> NAND (env reg1) (env reg2) (env reg3) - OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri) - ORIS reg1 reg2 imm -> ORIS (env reg1) (env reg2) imm - XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri) - XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm - EXTS fmt reg1 reg2 -> EXTS fmt (env reg1) (env reg2) - CNTLZ fmt reg1 reg2 -> CNTLZ fmt (env reg1) (env reg2) - NEG reg1 reg2 -> NEG (env reg1) (env reg2) - NOT reg1 reg2 -> NOT (env reg1) (env reg2) - SL fmt reg1 reg2 ri - -> SL fmt (env reg1) (env reg2) (fixRI ri) - SR fmt reg1 reg2 ri - -> SR fmt (env reg1) (env reg2) (fixRI ri) - SRA fmt reg1 reg2 ri - -> SRA fmt (env reg1) (env reg2) (fixRI ri) - RLWINM reg1 reg2 sh mb me - -> RLWINM (env reg1) (env reg2) sh mb me - CLRLI fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n - CLRRI fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n - FADD fmt r1 r2 r3 -> FADD fmt (env r1) (env r2) (env r3) - FSUB fmt r1 r2 r3 -> FSUB fmt (env r1) (env r2) (env r3) - FMUL fmt r1 r2 r3 -> FMUL fmt (env r1) (env r2) (env r3) - FDIV fmt r1 r2 r3 -> FDIV fmt (env r1) (env r2) (env r3) - FABS r1 r2 -> FABS (env r1) (env r2) - FNEG r1 r2 -> FNEG (env r1) (env r2) - FCMP r1 r2 -> FCMP (env r1) (env r2) - FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) - FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2) - FCFID r1 r2 -> FCFID (env r1) (env r2) - FRSP r1 r2 -> FRSP (env r1) (env r2) - MFCR reg -> MFCR (env reg) - MFLR reg -> MFLR (env reg) - FETCHPC reg -> FETCHPC (env reg) - _ -> instr - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - --------------------------------------------------------------------------------- --- | Checks whether this instruction is a jump/branch instruction. --- One that can change the flow of control in a way that the --- register allocator needs to worry about. -ppc_isJumpishInstr :: Instr -> Bool -ppc_isJumpishInstr instr - = case instr of - BCC{} -> True - BCCFAR{} -> True - BCTR{} -> True - BCTRL{} -> True - BL{} -> True - JMP{} -> True - _ -> False - - --- | Checks whether this instruction is a jump/branch instruction. --- One that can change the flow of control in a way that the --- register allocator needs to worry about. -ppc_jumpDestsOfInstr :: Instr -> [BlockId] -ppc_jumpDestsOfInstr insn - = case insn of - BCC _ id _ -> [id] - BCCFAR _ id _ -> [id] - BCTR targets _ _ -> [id | Just id <- targets] - _ -> [] - - --- | Change the destination of this jump instruction. --- Used in the linear allocator when adding fixup blocks for join --- points. -ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr -ppc_patchJumpInstr insn patchF - = case insn of - BCC cc id p -> BCC cc (patchF id) p - BCCFAR cc id p -> BCCFAR cc (patchF id) p - BCTR ids lbl rs -> BCTR (map (fmap patchF) ids) lbl rs - _ -> insn - - --- ----------------------------------------------------------------------------- - --- | An instruction to spill a register into a spill slot. -ppc_mkSpillInstr - :: DynFlags - -> Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -ppc_mkSpillInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - arch = platformArch platform - in - let fmt = case targetClassOfReg platform reg of - RcInteger -> case arch of - ArchPPC -> II32 - _ -> II64 - RcDouble -> FF64 - _ -> panic "PPC.Instr.mkSpillInstr: no match" - instr = case makeImmediate W32 True (off-delta) of - Just _ -> ST - Nothing -> STFAR -- pseudo instruction: 32 bit offsets - - in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) - - -ppc_mkLoadInstr - :: DynFlags - -> Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -ppc_mkLoadInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - arch = platformArch platform - in - let fmt = case targetClassOfReg platform reg of - RcInteger -> case arch of - ArchPPC -> II32 - _ -> II64 - RcDouble -> FF64 - _ -> panic "PPC.Instr.mkLoadInstr: no match" - instr = case makeImmediate W32 True (off-delta) of - Just _ -> LD - Nothing -> LDFAR -- pseudo instruction: 32 bit offsets - - in instr fmt reg (AddrRegImm sp (ImmInt (off-delta))) - - --- | The size of a minimal stackframe header including minimal --- parameter save area. -stackFrameHeaderSize :: DynFlags -> Int -stackFrameHeaderSize dflags - = case platformOS platform of - OSAIX -> 24 + 8 * 4 - _ -> case platformArch platform of - -- header + parameter save area - ArchPPC -> 64 -- TODO: check ABI spec - ArchPPC_64 ELF_V1 -> 48 + 8 * 8 - ArchPPC_64 ELF_V2 -> 32 + 8 * 8 - _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS" - where platform = targetPlatform dflags - --- | The maximum number of bytes required to spill a register. PPC32 --- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and --- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike --- x86. Note that AltiVec's vector registers are 128-bit wide so we --- must not use this to spill them. -spillSlotSize :: Int -spillSlotSize = 8 - --- | The number of spill slots available without allocating more. -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((rESERVED_C_STACK_BYTES dflags - stackFrameHeaderSize dflags) - `div` spillSlotSize) - 1 --- = 0 -- useful for testing allocMoreStack - --- | The number of bytes that the stack pointer should be aligned --- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor --- specific supplements). -stackAlign :: Int -stackAlign = 16 - --- | Convert a spill slot number to a *byte* offset, with no sign. -spillSlotToOffset :: DynFlags -> Int -> Int -spillSlotToOffset dflags slot - = stackFrameHeaderSize dflags + spillSlotSize * slot - - --------------------------------------------------------------------------------- --- | See if this instruction is telling us the current C stack delta -ppc_takeDeltaInstr - :: Instr - -> Maybe Int - -ppc_takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -ppc_isMetaInstr - :: Instr - -> Bool - -ppc_isMetaInstr instr - = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - - --- | Copy the value in a register to another one. --- Must work for all register classes. -ppc_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr - -ppc_mkRegRegMoveInstr src dst - = MR dst src - - --- | Make an unconditional jump instruction. -ppc_mkJumpInstr - :: BlockId - -> [Instr] - -ppc_mkJumpInstr id - = [BCC ALWAYS id Nothing] - - --- | Take the source and destination from this reg -> reg move instruction --- or Nothing if it's not one -ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) -ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst) -ppc_takeRegRegMoveInstr _ = Nothing - --- ----------------------------------------------------------------------------- --- Making far branches - --- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too --- big, we have to work around this limitation. - -makeFarBranches - :: LabelMap CmmStatics - -> [NatBasicBlock Instr] - -> [NatBasicBlock Instr] -makeFarBranches info_env blocks - | last blockAddresses < nearLimit = blocks - | otherwise = zipWith handleBlock blockAddresses blocks - where - blockAddresses = scanl (+) 0 $ map blockLen blocks - blockLen (BasicBlock _ instrs) = length instrs - - handleBlock addr (BasicBlock id instrs) - = BasicBlock id (zipWith makeFar [addr..] instrs) - - makeFar _ (BCC ALWAYS tgt _) = BCC ALWAYS tgt Nothing - makeFar addr (BCC cond tgt p) - | abs (addr - targetAddr) >= nearLimit - = BCCFAR cond tgt p - | otherwise - = BCC cond tgt p - where Just targetAddr = lookupUFM blockAddressMap tgt - makeFar _ other = other - - -- 8192 instructions are allowed; let's keep some distance, as - -- we have a few pseudo-insns that are pretty-printed as - -- multiple instructions, and it's just not worth the effort - -- to calculate things exactly - nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW - - blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses diff --git a/nativeGen/PPC/Ppr.hs b/nativeGen/PPC/Ppr.hs deleted file mode 100644 --- a/nativeGen/PPC/Ppr.hs +++ /dev/null @@ -1,994 +0,0 @@ ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PPC.Ppr (pprNatCmmDecl) where - -import GhcPrelude - -import PPC.Regs -import PPC.Instr -import PPC.Cond -import PprBase -import Instruction -import Format -import Reg -import RegClass -import TargetReg - -import Cmm hiding (topInfoTable) -import Hoopl.Collections -import Hoopl.Label - -import BlockId -import CLabel -import PprCmmExpr () -- For Outputable instances - -import Unique ( pprUniqueAlways, getUnique ) -import GHC.Platform -import FastString -import Outputable -import DynFlags - -import Data.Word -import Data.Int -import Data.Bits - --- ----------------------------------------------------------------------------- --- Printing this stuff out - -pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats - -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - case topInfoTable proc of - Nothing -> - sdocWithPlatform $ \platform -> - -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - (case platformArch platform of - ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl - ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl - _ -> pprLabel lbl) $$ -- blocks guaranteed not null, - -- so label needed - vcat (map (pprBasicBlock top_info) blocks) - - Just (Statics info_lbl _) -> - sdocWithPlatform $ \platform -> - pprSectionAlign (Section Text info_lbl) $$ - (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then - -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> ppr info_lbl - <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) - else empty) - -pprFunctionDescriptor :: CLabel -> SDoc -pprFunctionDescriptor lab = pprGloblDecl lab - $$ text "\t.section \".opd\", \"aw\"" - $$ text "\t.align 3" - $$ ppr lab <> char ':' - $$ text "\t.quad ." - <> ppr lab - <> text ",.TOC.@tocbase,0" - $$ text "\t.previous" - $$ text "\t.type" - <+> ppr lab - <> text ", @function" - $$ char '.' <> ppr lab <> char ':' - -pprFunctionPrologue :: CLabel ->SDoc -pprFunctionPrologue lab = pprGloblDecl lab - $$ text ".type " - <> ppr lab - <> text ", @function" - $$ ppr lab <> char ':' - $$ text "0:\taddis\t" <> pprReg toc - <> text ",12,.TOC.-0b@ha" - $$ text "\taddi\t" <> pprReg toc - <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" - $$ text "\t.localentry\t" <> ppr lab - <> text ",.-" <> ppr lab - -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) - = maybe_infotable $$ - pprLabel (blockLbl blockid) $$ - vcat (map pprInstr instrs) - where - maybe_infotable = case mapLookup blockid info_env of - Nothing -> empty - Just (Statics info_lbl info) -> - pprAlignForSection Text $$ - vcat (map pprData info) $$ - pprLabel info_lbl - - - -pprDatas :: CmmStatics -> SDoc --- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) - | lbl == mkIndStaticInfoLabel - , let labelInd (CmmLabelOff l _) = Just l - labelInd (CmmLabel l) = Just l - labelInd _ = Nothing - , Just ind' <- labelInd ind - , alias `mayRedirectTo` ind' - = pprGloblDecl alias - $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) - -pprData :: CmmStatic -> SDoc -pprData (CmmString str) = pprBytes str -pprData (CmmUninitialised bytes) = text ".space " <> int bytes -pprData (CmmStaticLit lit) = pprDataItem lit - -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> ppr lbl - -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl - = sdocWithPlatform $ \platform -> - if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> - ppr lbl <> text ", @object" - else empty - -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl - $$ (ppr lbl <> char ':') - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance Outputable Instr where - ppr instr = pprInstr instr - - -pprReg :: Reg -> SDoc - -pprReg r - = case r of - RegReal (RealRegSingle i) -> ppr_reg_no i - RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u - RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u - RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u - - where - ppr_reg_no :: Int -> SDoc - ppr_reg_no i - | i <= 31 = int i -- GPRs - | i <= 63 = int (i-32) -- FPRs - | otherwise = text "very naughty powerpc register" - - - -pprFormat :: Format -> SDoc -pprFormat x - = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "w" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd") - - -pprCond :: Cond -> SDoc -pprCond c - = ptext (case c of { - ALWAYS -> sLit ""; - EQQ -> sLit "eq"; NE -> sLit "ne"; - LTT -> sLit "lt"; GE -> sLit "ge"; - GTT -> sLit "gt"; LE -> sLit "le"; - LU -> sLit "lt"; GEU -> sLit "ge"; - GU -> sLit "gt"; LEU -> sLit "le"; }) - - -pprImm :: Imm -> SDoc - -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = ppr l -pprImm (ImmIndex l i) = ppr l <> char '+' <> int i -pprImm (ImmLit s) = s - -pprImm (ImmFloat _) = text "naughty float immediate" -pprImm (ImmDouble _) = text "naughty double immediate" - -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen - -pprImm (LO (ImmInt i)) = pprImm (LO (ImmInteger (toInteger i))) -pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16)) - where - lo16 = fromInteger (i .&. 0xffff) :: Int16 - -pprImm (LO i) - = pprImm i <> text "@l" - -pprImm (HI i) - = pprImm i <> text "@h" - -pprImm (HA (ImmInt i)) = pprImm (HA (ImmInteger (toInteger i))) -pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16) - where - ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 - hi16 = (i `shiftR` 16) - lo16 = i .&. 0xffff - -pprImm (HA i) - = pprImm i <> text "@ha" - -pprImm (HIGHERA i) - = pprImm i <> text "@highera" - -pprImm (HIGHESTA i) - = pprImm i <> text "@highesta" - - -pprAddr :: AddrMode -> SDoc -pprAddr (AddrRegReg r1 r2) - = pprReg r1 <> char ',' <+> pprReg r2 -pprAddr (AddrRegImm r1 (ImmInt i)) - = hcat [ int i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 (ImmInteger i)) - = hcat [ integer i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 imm) - = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] - - -pprSectionAlign :: Section -> SDoc -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - sdocWithPlatform $ \platform -> - let ppc64 = not $ target32Bit platform - in ptext $ case seg of - Text -> sLit ".align 2" - Data - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - ReadOnlyData - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - RelocatableReadOnlyData - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - UninitialisedData - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - ReadOnlyData16 -> sLit ".align 4" - -- TODO: This is copied from the ReadOnlyData case, but it can likely be - -- made more efficient. - CString - | ppc64 -> sLit ".align 3" - | otherwise -> sLit ".align 2" - OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" - -pprDataItem :: CmmLit -> SDoc -pprDataItem lit - = sdocWithDynFlags $ \dflags -> - vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags) - where - imm = litToImm lit - archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags - - ppr_item II8 _ _ = [text "\t.byte\t" <> pprImm imm] - - ppr_item II32 _ _ = [text "\t.long\t" <> pprImm imm] - - ppr_item II64 _ dflags - | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm] - - - ppr_item FF32 (CmmFloat r _) _ - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) _ - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item II16 _ _ = [text "\t.short\t" <> pprImm imm] - - ppr_item II64 (CmmInt x _) dflags - | not(archPPC_64 dflags) = - [text "\t.long\t" - <> int (fromIntegral - (fromIntegral (x `shiftR` 32) :: Word32)), - text "\t.long\t" - <> int (fromIntegral (fromIntegral x :: Word32))] - - ppr_item _ _ _ - = panic "PPC.Ppr.pprDataItem: no match" - - -pprInstr :: Instr -> SDoc - -pprInstr (COMMENT _) = empty -- nuke 'em -{- -pprInstr (COMMENT s) = - if platformOS platform == OSLinux - then text "# " <> ftext s - else text "; " <> ftext s --} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) - -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - -{- -pprInstr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char '\t', - pprReg reg, - comma, - text "SLOT" <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - text "\tRELOAD", - char '\t', - text "SLOT" <> parens (int slot), - comma, - pprReg reg] --} - -pprInstr (LD fmt reg addr) = hcat [ - char '\t', - text "l", - ptext (case fmt of - II8 -> sLit "bz" - II16 -> sLit "hz" - II32 -> sLit "wz" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - ), - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] - -pprInstr (LDFAR fmt reg (AddrRegImm source off)) = - sdocWithPlatform $ \platform -> vcat [ - pprInstr (ADDIS (tmpReg platform) source (HA off)), - pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off))) - ] -pprInstr (LDFAR _ _ _) = - panic "PPC.Ppr.pprInstr LDFAR: no match" - -pprInstr (LDR fmt reg1 addr) = hcat [ - text "\tl", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC.Ppr.Instr LDR: no match", - text "arx\t", - pprReg reg1, - text ", ", - pprAddr addr - ] - -pprInstr (LA fmt reg addr) = hcat [ - char '\t', - text "l", - ptext (case fmt of - II8 -> sLit "ba" - II16 -> sLit "ha" - II32 -> sLit "wa" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - ), - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (ST fmt reg addr) = hcat [ - char '\t', - text "st", - pprFormat fmt, - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (STFAR fmt reg (AddrRegImm source off)) = - sdocWithPlatform $ \platform -> vcat [ - pprInstr (ADDIS (tmpReg platform) source (HA off)), - pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off))) - ] -pprInstr (STFAR _ _ _) = - panic "PPC.Ppr.pprInstr STFAR: no match" -pprInstr (STU fmt reg addr) = hcat [ - char '\t', - text "st", - pprFormat fmt, - char 'u', - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (STC fmt reg1 addr) = hcat [ - text "\tst", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC.Ppr.Instr STC: no match", - text "cx.\t", - pprReg reg1, - text ", ", - pprAddr addr - ] -pprInstr (LIS reg imm) = hcat [ - char '\t', - text "lis", - char '\t', - pprReg reg, - text ", ", - pprImm imm - ] -pprInstr (LI reg imm) = hcat [ - char '\t', - text "li", - char '\t', - pprReg reg, - text ", ", - pprImm imm - ] -pprInstr (MR reg1 reg2) - | reg1 == reg2 = empty - | otherwise = hcat [ - char '\t', - sdocWithPlatform $ \platform -> - case targetClassOfReg platform reg1 of - RcInteger -> text "mr" - _ -> text "fmr", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] -pprInstr (CMP fmt reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg reg, - text ", ", - pprRI ri - ] - where - op = hcat [ - text "cmp", - pprFormat fmt, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] -pprInstr (CMPL fmt reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg reg, - text ", ", - pprRI ri - ] - where - op = hcat [ - text "cmpl", - pprFormat fmt, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] -pprInstr (BCC cond blockid prediction) = hcat [ - char '\t', - text "b", - pprCond cond, - pprPrediction prediction, - char '\t', - ppr lbl - ] - where lbl = mkLocalBlockLabel (getUnique blockid) - pprPrediction p = case p of - Nothing -> empty - Just True -> char '+' - Just False -> char '-' - -pprInstr (BCCFAR cond blockid prediction) = vcat [ - hcat [ - text "\tb", - pprCond (condNegate cond), - neg_prediction, - text "\t$+8" - ], - hcat [ - text "\tb\t", - ppr lbl - ] - ] - where lbl = mkLocalBlockLabel (getUnique blockid) - neg_prediction = case prediction of - Nothing -> empty - Just True -> char '-' - Just False -> char '+' - -pprInstr (JMP lbl _) - -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL" - | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel" - | otherwise = - hcat [ -- an alias for b that takes a CLabel - char '\t', - text "b", - char '\t', - ppr lbl - ] - -pprInstr (MTCTR reg) = hcat [ - char '\t', - text "mtctr", - char '\t', - pprReg reg - ] -pprInstr (BCTR _ _ _) = hcat [ - char '\t', - text "bctr" - ] -pprInstr (BL lbl _) = do - sdocWithPlatform $ \platform -> case platformOS platform of - OSAIX -> - -- On AIX, "printf" denotes a function-descriptor (for use - -- by function pointers), whereas the actual entry-code - -- address is denoted by the dot-prefixed ".printf" label. - -- Moreover, the PPC NCG only ever emits a BL instruction - -- for calling C ABI functions. Most of the time these calls - -- originate from FFI imports and have a 'ForeignLabel', - -- but when profiling the codegen inserts calls via - -- 'emitRtsCallGen' which are 'CmmLabel's even though - -- they'd technically be more like 'ForeignLabel's. - hcat [ - text "\tbl\t.", - ppr lbl - ] - _ -> - hcat [ - text "\tbl\t", - ppr lbl - ] -pprInstr (BCTRL _) = hcat [ - char '\t', - text "bctrl" - ] -pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri -pprInstr (ADDIS reg1 reg2 imm) = hcat [ - char '\t', - text "addis", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] - -pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3) -pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) -pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) -pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2 -pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) -pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3) -pprInstr (SUBFC reg1 reg2 ri) = hcat [ - char '\t', - text "subf", - case ri of - RIReg _ -> empty - RIImm _ -> char 'i', - text "c\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprRI ri - ] -pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) -pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri -pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [ - char '\t', - text "mull", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "o\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] -pprInstr (MFOV fmt reg) = vcat [ - hcat [ - char '\t', - text "mfxer", - char '\t', - pprReg reg - ], - hcat [ - char '\t', - text "extr", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "i\t", - pprReg reg, - text ", ", - pprReg reg, - text ", 1, ", - case fmt of - II32 -> text "1" - II64 -> text "33" - _ -> panic "PPC: illegal format" - ] - ] - -pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [ - char '\t', - text "mulh", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "u\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] - -pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3 - - -- for some reason, "andi" doesn't exist. - -- we'll use "andi." instead. -pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ - char '\t', - text "andi.", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] -pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri -pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3) -pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3) - -pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri -pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri - -pprInstr (ORIS reg1 reg2 imm) = hcat [ - char '\t', - text "oris", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] - -pprInstr (XORIS reg1 reg2 imm) = hcat [ - char '\t', - text "xoris", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] - -pprInstr (EXTS fmt reg1 reg2) = hcat [ - char '\t', - text "exts", - pprFormat fmt, - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] -pprInstr (CNTLZ fmt reg1 reg2) = hcat [ - char '\t', - text "cntlz", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] - -pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 -pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 - -pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = - -- Handle the case where we are asked to shift a 32 bit register by - -- less than zero or more than 31 bits. We convert this into a clear - -- of the destination register. - -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900 - pprInstr (XOR reg1 reg2 (RIReg reg2)) - -pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = - -- As above for SR, but for left shifts. - -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870 - pprInstr (XOR reg1 reg2 (RIReg reg2)) - -pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 = - -- PT: I don't know what to do for negative shift amounts: - -- For now just panic. - -- - -- For shift amounts greater than 31 set all bit to the - -- value of the sign bit, this also what sraw does. - pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31))) - -pprInstr (SL fmt reg1 reg2 ri) = - let op = case fmt of - II32 -> "slw" - II64 -> "sld" - _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) - -pprInstr (SR fmt reg1 reg2 ri) = - let op = case fmt of - II32 -> "srw" - II64 -> "srd" - _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) - -pprInstr (SRA fmt reg1 reg2 ri) = - let op = case fmt of - II32 -> "sraw" - II64 -> "srad" - _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) - -pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ - text "\trlwinm\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int sh, - text ", ", - int mb, - text ", ", - int me - ] - -pprInstr (CLRLI fmt reg1 reg2 n) = hcat [ - text "\tclrl", - pprFormat fmt, - text "i ", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int n - ] -pprInstr (CLRRI fmt reg1 reg2 n) = hcat [ - text "\tclrr", - pprFormat fmt, - text "i ", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int n - ] - -pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3 -pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3 -pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3 -pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3 -pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2 -pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 - -pprInstr (FCMP reg1 reg2) = hcat [ - char '\t', - text "fcmpu\t0, ", - -- Note: we're using fcmpu, not fcmpo - -- The difference is with fcmpo, compare with NaN is an invalid operation. - -- We don't handle invalid fp ops, so we don't care. - -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for - -- better portability since some non-GNU assembler (such as - -- IBM's `as`) tend not to support the symbolic register name cr0. - -- This matches the syntax that GCC seems to emit for PPC targets. - pprReg reg1, - text ", ", - pprReg reg2 - ] - -pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2 -pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2 -pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 - -pprInstr (CRNOR dst src1 src2) = hcat [ - text "\tcrnor\t", - int dst, - text ", ", - int src1, - text ", ", - int src2 - ] - -pprInstr (MFCR reg) = hcat [ - char '\t', - text "mfcr", - char '\t', - pprReg reg - ] - -pprInstr (MFLR reg) = hcat [ - char '\t', - text "mflr", - char '\t', - pprReg reg - ] - -pprInstr (FETCHPC reg) = vcat [ - text "\tbcl\t20,31,1f", - hcat [ text "1:\tmflr\t", pprReg reg ] - ] - -pprInstr HWSYNC = text "\tsync" - -pprInstr ISYNC = text "\tisync" - -pprInstr LWSYNC = text "\tlwsync" - -pprInstr NOP = text "\tnop" - - -pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc -pprLogic op reg1 reg2 ri = hcat [ - char '\t', - ptext op, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i', - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprRI ri - ] - - -pprMul :: Format -> Reg -> Reg -> RI -> SDoc -pprMul fmt reg1 reg2 ri = hcat [ - char '\t', - text "mull", - case ri of - RIReg _ -> case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format" - RIImm _ -> char 'i', - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprRI ri - ] - - -pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc -pprDiv fmt sgn reg1 reg2 reg3 = hcat [ - char '\t', - text "div", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - if sgn then empty else char 'u', - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] - - -pprUnary :: PtrString -> Reg -> Reg -> SDoc -pprUnary op reg1 reg2 = hcat [ - char '\t', - ptext op, - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] - - -pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc -pprBinaryF op fmt reg1 reg2 reg3 = hcat [ - char '\t', - ptext op, - pprFFormat fmt, - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] - -pprRI :: RI -> SDoc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r - - -pprFFormat :: Format -> SDoc -pprFFormat FF64 = empty -pprFFormat FF32 = char 's' -pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match" - - -- limit immediate argument for shift instruction to range 0..63 - -- for 64 bit size and 0..32 otherwise -limitShiftRI :: Format -> RI -> RI -limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 = - panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." -limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 = - panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed." -limitShiftRI _ x = x diff --git a/nativeGen/PPC/RegInfo.hs b/nativeGen/PPC/RegInfo.hs deleted file mode 100644 --- a/nativeGen/PPC/RegInfo.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Machine-specific parts of the register allocator --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ -module PPC.RegInfo ( - JumpDest( DestBlockId ), getJumpDestBlockId, - canShortcut, - shortcutJump, - - shortcutStatics -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import PPC.Instr - -import BlockId -import Cmm -import CLabel - -import Unique -import Outputable (ppr, text, Outputable, (<>)) - -data JumpDest = DestBlockId BlockId - --- Debug Instance -instance Outputable JumpDest where - ppr (DestBlockId bid) = text "jd:" <> ppr bid - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid - -canShortcut :: Instr -> Maybe JumpDest -canShortcut _ = Nothing - -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump _ other = other - - --- Here because it knows about JumpDest -shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics -shortcutStatics fn (Statics lbl statics) - = Statics lbl $ map (shortcutStatic fn) statics - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId - | otherwise = lab - -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) - -- slightly dodgy, we're ignoring the second label, but this - -- works with the way we use CmmLabelDiffOff for jump tables now. -shortcutStatic _ other_static - = other_static - -shortBlockId - :: (BlockId -> Maybe JumpDest) - -> BlockId - -> CLabel - -shortBlockId fn blockid = - case fn blockid of - Nothing -> mkLocalBlockLabel uq - Just (DestBlockId blockid') -> shortBlockId fn blockid' - where uq = getUnique blockid diff --git a/nativeGen/PPC/Regs.hs b/nativeGen/PPC/Regs.hs deleted file mode 100644 --- a/nativeGen/PPC/Regs.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- ----------------------------------------------------------------------------- - -module PPC.Regs ( - -- squeeze functions - virtualRegSqueeze, - realRegSqueeze, - - mkVirtualReg, - regDotColor, - - -- immediates - Imm(..), - strImmLit, - litToImm, - - -- addressing modes - AddrMode(..), - addrOffset, - - -- registers - spRel, - argRegs, - allArgRegs, - callClobberedRegs, - allMachRegNos, - classOfRealReg, - showReg, - - -- machine specific - allFPArgRegs, - fits16Bits, - makeImmediate, - fReg, - r0, sp, toc, r3, r4, r11, r12, r30, - tmpReg, - f1, - - allocatableRegs - -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import Reg -import RegClass -import Format - -import Cmm -import CLabel ( CLabel ) -import Unique - -import GHC.Platform.Regs -import DynFlags -import Outputable -import GHC.Platform - -import Data.Word ( Word8, Word16, Word32, Word64 ) -import Data.Int ( Int8, Int16, Int32, Int64 ) - - --- squeese functions for the graph allocator ----------------------------------- - --- | regSqueeze_class reg --- Calculate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegD{} -> 1 - VirtualRegF{} -> 0 - _other -> 0 - - _other -> 0 - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 1 -- first fp reg is 32 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 0 - - _other -> 0 - -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - | not (isFloatFormat format) = VirtualRegI u - | otherwise - = case format of - FF32 -> VirtualRegD u - FF64 -> VirtualRegD u - _ -> panic "mkVirtualReg" - -regDotColor :: RealReg -> SDoc -regDotColor reg - = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - RcDouble -> text "green" - - - --- immediates ------------------------------------------------------------------ -data Imm - = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - | LO Imm - | HI Imm - | HA Imm {- high halfword adjusted -} - | HIGHERA Imm - | HIGHESTA Imm - - -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - -litToImm :: CmmLit -> Imm -litToImm (CmmInt i w) = ImmInteger (narrowS w i) - -- narrow to the width: a CmmInt might be out of - -- range, but we assume that ImmInteger only contains - -- in-range values. A signed value should be fine here. -litToImm (CmmFloat f W32) = ImmFloat f -litToImm (CmmFloat f W64) = ImmDouble f -litToImm (CmmLabel l) = ImmCLbl l -litToImm (CmmLabelOff l off) = ImmIndex l off -litToImm (CmmLabelDiffOff l1 l2 off _) - = ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) -litToImm _ = panic "PPC.Regs.litToImm: no match" - - --- addressing modes ------------------------------------------------------------ - -data AddrMode - = AddrRegReg Reg Reg - | AddrRegImm Reg Imm - - -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - AddrRegImm r (ImmInt n) - | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2)) - | otherwise -> Nothing - where n2 = n + off - - AddrRegImm r (ImmInteger n) - | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) - | otherwise -> Nothing - where n2 = n + toInteger off - - _ -> Nothing - - --- registers ------------------------------------------------------------------- --- @spRel@ gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. @fpRel@, where --- applicable, is the same but for the frame pointer. - -spRel :: DynFlags - -> Int -- desired stack offset in words, positive or negative - -> AddrMode - -spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags)) - - --- argRegs is the set of regs which are read for an n-argument call to C. --- For archs which pass all args on the stack (x86), is empty. --- Sparc passes up to the first 6 args in regs. -argRegs :: RegNo -> [Reg] -argRegs 0 = [] -argRegs 1 = map regSingle [3] -argRegs 2 = map regSingle [3,4] -argRegs 3 = map regSingle [3..5] -argRegs 4 = map regSingle [3..6] -argRegs 5 = map regSingle [3..7] -argRegs 6 = map regSingle [3..8] -argRegs 7 = map regSingle [3..9] -argRegs 8 = map regSingle [3..10] -argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!" - - -allArgRegs :: [Reg] -allArgRegs = map regSingle [3..10] - - --- these are the regs which we cannot assume stay alive over a C call. -callClobberedRegs :: Platform -> [Reg] -callClobberedRegs _platform - = map regSingle (0:[2..12] ++ map fReg [0..13]) - - -allMachRegNos :: [RegNo] -allMachRegNos = [0..63] - - -{-# INLINE classOfRealReg #-} -classOfRealReg :: RealReg -> RegClass -classOfRealReg (RealRegSingle i) - | i < 32 = RcInteger - | otherwise = RcDouble - -classOfRealReg (RealRegPair{}) - = panic "regClass(ppr): no reg pairs on this architecture" - -showReg :: RegNo -> String -showReg n - | n >= 0 && n <= 31 = "%r" ++ show n - | n >= 32 && n <= 63 = "%f" ++ show (n - 32) - | otherwise = "%unknown_powerpc_real_reg_" ++ show n - - - --- machine specific ------------------------------------------------------------ - -allFPArgRegs :: Platform -> [Reg] -allFPArgRegs platform - = case platformOS platform of - OSAIX -> map (regSingle . fReg) [1..13] - _ -> case platformArch platform of - ArchPPC -> map (regSingle . fReg) [1..8] - ArchPPC_64 _ -> map (regSingle . fReg) [1..13] - _ -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux" - -fits16Bits :: Integral a => a -> Bool -fits16Bits x = x >= -32768 && x < 32768 - -makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm -makeImmediate rep signed x = fmap ImmInt (toI16 rep signed) - where - narrow W64 False = fromIntegral (fromIntegral x :: Word64) - narrow W32 False = fromIntegral (fromIntegral x :: Word32) - narrow W16 False = fromIntegral (fromIntegral x :: Word16) - narrow W8 False = fromIntegral (fromIntegral x :: Word8) - narrow W64 True = fromIntegral (fromIntegral x :: Int64) - narrow W32 True = fromIntegral (fromIntegral x :: Int32) - narrow W16 True = fromIntegral (fromIntegral x :: Int16) - narrow W8 True = fromIntegral (fromIntegral x :: Int8) - narrow _ _ = panic "PPC.Regs.narrow: no match" - - narrowed = narrow rep signed - - toI16 W32 True - | narrowed >= -32768 && narrowed < 32768 = Just narrowed - | otherwise = Nothing - toI16 W32 False - | narrowed >= 0 && narrowed < 65536 = Just narrowed - | otherwise = Nothing - toI16 W64 True - | narrowed >= -32768 && narrowed < 32768 = Just narrowed - | otherwise = Nothing - toI16 W64 False - | narrowed >= 0 && narrowed < 65536 = Just narrowed - | otherwise = Nothing - toI16 _ _ = Just narrowed - - -{- -The PowerPC has 64 registers of interest; 32 integer registers and 32 floating -point registers. --} - -fReg :: Int -> RegNo -fReg x = (32 + x) - -r0, sp, toc, r3, r4, r11, r12, r30, f1 :: Reg -r0 = regSingle 0 -sp = regSingle 1 -toc = regSingle 2 -r3 = regSingle 3 -r4 = regSingle 4 -r11 = regSingle 11 -r12 = regSingle 12 -r30 = regSingle 30 -f1 = regSingle $ fReg 1 - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: Platform -> [RealReg] -allocatableRegs platform - = let isFree i = freeReg platform i - in map RealRegSingle $ filter isFree allMachRegNos - --- temporary register for compiler use -tmpReg :: Platform -> Reg -tmpReg platform = - case platformArch platform of - ArchPPC -> regSingle 13 - ArchPPC_64 _ -> regSingle 30 - _ -> panic "PPC.Regs.tmpReg: unknown arch" diff --git a/nativeGen/PprBase.hs b/nativeGen/PprBase.hs deleted file mode 100644 --- a/nativeGen/PprBase.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -module PprBase ( - castFloatToWord8Array, - castDoubleToWord8Array, - floatToBytes, - doubleToBytes, - pprASCII, - pprBytes, - pprSectionHeader -) - -where - -import GhcPrelude - -import AsmUtils -import CLabel -import Cmm -import DynFlags -import FastString -import Outputable -import GHC.Platform -import FileCleanup - -import qualified Data.Array.Unsafe as U ( castSTUArray ) -import Data.Array.ST - -import Control.Monad.ST - -import Data.Word -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import GHC.Exts -import GHC.Word -import System.IO.Unsafe - - - --- ----------------------------------------------------------------------------- --- Converting floating-point literals to integrals for printing - -castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) -castFloatToWord8Array = U.castSTUArray - -castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) -castDoubleToWord8Array = U.castSTUArray - --- floatToBytes and doubleToBytes convert to the host's byte --- order. Providing that we're not cross-compiling for a --- target with the opposite endianness, this should work ok --- on all targets. - --- ToDo: this stuff is very similar to the shenanigans in PprAbs, --- could they be merged? - -floatToBytes :: Float -> [Int] -floatToBytes f - = runST (do - arr <- newArray_ ((0::Int),3) - writeArray arr 0 f - arr <- castFloatToWord8Array arr - i0 <- readArray arr 0 - i1 <- readArray arr 1 - i2 <- readArray arr 2 - i3 <- readArray arr 3 - return (map fromIntegral [i0,i1,i2,i3]) - ) - -doubleToBytes :: Double -> [Int] -doubleToBytes d - = runST (do - arr <- newArray_ ((0::Int),7) - writeArray arr 0 d - arr <- castDoubleToWord8Array arr - i0 <- readArray arr 0 - i1 <- readArray arr 1 - i2 <- readArray arr 2 - i3 <- readArray arr 3 - i4 <- readArray arr 4 - i5 <- readArray arr 5 - i6 <- readArray arr 6 - i7 <- readArray arr 7 - return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7]) - ) - --- --------------------------------------------------------------------------- --- Printing ASCII strings. --- --- Print as a string and escape non-printable characters. --- This is similar to charToC in Utils. - -pprASCII :: ByteString -> SDoc -pprASCII str - -- Transform this given literal bytestring to escaped string and construct - -- the literal SDoc directly. - -- See #14741 - -- and Note [Pretty print ASCII when AsmCodeGen] - = text $ BS.foldr (\w s -> do1 w ++ s) "" str - where - do1 :: Word8 -> String - do1 w | 0x09 == w = "\\t" - | 0x0A == w = "\\n" - | 0x22 == w = "\\\"" - | 0x5C == w = "\\\\" - -- ASCII printable characters range - | w >= 0x20 && w <= 0x7E = [chr' w] - | otherwise = '\\' : octal w - - -- we know that the Chars we create are in the ASCII range - -- so we bypass the check in "chr" - chr' :: Word8 -> Char - chr' (W8# w#) = C# (chr# (word2Int# w#)) - - octal :: Word8 -> String - octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07) - , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07) - , chr' (ord0 + w .&. 0x07) - ] - ord0 = 0x30 -- = ord '0' - --- | Pretty print binary data. --- --- Use either the ".string" directive or a ".incbin" directive. --- See Note [Embedding large binary blobs] --- --- A NULL byte is added after the binary data. --- -pprBytes :: ByteString -> SDoc -pprBytes bs = sdocWithDynFlags $ \dflags -> - if binBlobThreshold dflags == 0 - || fromIntegral (BS.length bs) <= binBlobThreshold dflags - then text "\t.string " <> doubleQuotes (pprASCII bs) - else unsafePerformIO $ do - bFile <- newTempName dflags TFL_CurrentModule ".dat" - BS.writeFile bFile bs - return $ text "\t.incbin " - <> pprFilePathString bFile -- proper escape (see #16389) - <> text "\n\t.byte 0" - -{- -Note [Embedding large binary blobs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To embed a blob of binary data (e.g. an UTF-8 encoded string) into the generated -code object, we have several options: - - 1. Generate a ".byte" directive for each byte. This is what was done in the past - (see Note [Pretty print ASCII when AsmCodeGen]). - - 2. Generate a single ".string"/".asciz" directive for the whole sequence of - bytes. Bytes in the ASCII printable range are rendered as characters and - other values are escaped (e.g., "\t", "\077", etc.). - - 3. Create a temporary file into which we dump the binary data and generate a - single ".incbin" directive. The assembler will include the binary file for - us in the generated output object. - -Now the code generator uses either (2) or (3), depending on the binary blob -size. Using (3) for small blobs adds too much overhead (see benchmark results -in #16190), so we only do it when the size is above a threshold (500K at the -time of writing). - -The threshold is configurable via the `-fbinary-blob-threshold` flag. - --} - - -{- -Note [Pretty print ASCII when AsmCodeGen] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, when generating assembly code, we created SDoc with -`(ptext . sLit)` for every bytes in literal bytestring, then -combine them using `hcat`. - -When handling literal bytestrings with millions of bytes, -millions of SDoc would be created and to combine, leading to -high memory usage. - -Now we escape the given bytestring to string directly and construct -SDoc only once. This improvement could dramatically decrease the -memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal -string in source code. See #14741 for profiling results. --} - --- ---------------------------------------------------------------------------- --- Printing section headers. --- --- If -split-section was specified, include the suffix label, otherwise just --- print the section type. For Darwin, where subsections-for-symbols are --- used instead, only print section type. --- --- For string literals, additional flags are specified to enable merging of --- identical strings in the linker. With -split-sections each string also gets --- a unique section to allow strings from unused code to be GC'd. - -pprSectionHeader :: Platform -> Section -> SDoc -pprSectionHeader platform (Section t suffix) = - case platformOS platform of - OSAIX -> pprXcoffSectionHeader t - OSDarwin -> pprDarwinSectionHeader t - OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix - _ -> pprGNUSectionHeader (char '.') t suffix - -pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc -pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags -> - let splitSections = gopt Opt_SplitSections dflags - subsection | splitSections = sep <> ppr suffix - | otherwise = empty - in text ".section " <> ptext (header dflags) <> subsection <> - flags dflags - where - header dflags = case t of - Text -> sLit ".text" - Data -> sLit ".data" - ReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags) - -> sLit ".rdata" - | otherwise -> sLit ".rodata" - RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags) - -- Concept does not exist on Windows, - -- So map these to R/O data. - -> sLit ".rdata$rel.ro" - | otherwise -> sLit ".data.rel.ro" - UninitialisedData -> sLit ".bss" - ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags) - -> sLit ".rdata$cst16" - | otherwise -> sLit ".rodata.cst16" - CString - | OSMinGW32 <- platformOS (targetPlatform dflags) - -> sLit ".rdata" - | otherwise -> sLit ".rodata.str" - OtherSection _ -> - panic "PprBase.pprGNUSectionHeader: unknown section type" - flags dflags = case t of - CString - | OSMinGW32 <- platformOS (targetPlatform dflags) - -> empty - | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1" - _ -> empty - --- XCOFF doesn't support relocating label-differences, so we place all --- RO sections into .text[PR] sections -pprXcoffSectionHeader :: SectionType -> SDoc -pprXcoffSectionHeader t = text $ case t of - Text -> ".csect .text[PR]" - Data -> ".csect .data[RW]" - ReadOnlyData -> ".csect .text[PR] # ReadOnlyData" - RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData" - ReadOnlyData16 -> ".csect .text[PR] # ReadOnlyData16" - CString -> ".csect .text[PR] # CString" - UninitialisedData -> ".csect .data[BS]" - OtherSection _ -> - panic "PprBase.pprXcoffSectionHeader: unknown section type" - -pprDarwinSectionHeader :: SectionType -> SDoc -pprDarwinSectionHeader t = - ptext $ case t of - Text -> sLit ".text" - Data -> sLit ".data" - ReadOnlyData -> sLit ".const" - RelocatableReadOnlyData -> sLit ".const_data" - UninitialisedData -> sLit ".data" - ReadOnlyData16 -> sLit ".const" - CString -> sLit ".section\t__TEXT,__cstring,cstring_literals" - OtherSection _ -> - panic "PprBase.pprDarwinSectionHeader: unknown section type" diff --git a/nativeGen/Reg.hs b/nativeGen/Reg.hs deleted file mode 100644 --- a/nativeGen/Reg.hs +++ /dev/null @@ -1,241 +0,0 @@ --- | An architecture independent description of a register. --- This needs to stay architecture independent because it is used --- by NCGMonad and the register allocators, which are shared --- by all architectures. --- -module Reg ( - RegNo, - Reg(..), - regPair, - regSingle, - isRealReg, takeRealReg, - isVirtualReg, takeVirtualReg, - - VirtualReg(..), - renameVirtualReg, - classOfVirtualReg, - getHiVirtualRegFromLo, - getHiVRegFromLo, - - RealReg(..), - regNosOfRealReg, - realRegsAlias, - - liftPatchFnToRegReg -) - -where - -import GhcPrelude - -import Outputable -import Unique -import RegClass -import Data.List (intersect) - --- | An identifier for a primitive real machine register. -type RegNo - = Int - --- VirtualRegs are virtual registers. The register allocator will --- eventually have to map them into RealRegs, or into spill slots. --- --- VirtualRegs are allocated on the fly, usually to represent a single --- value in the abstract assembly code (i.e. dynamic registers are --- usually single assignment). --- --- The single assignment restriction isn't necessary to get correct code, --- although a better register allocation will result if single --- assignment is used -- because the allocator maps a VirtualReg into --- a single RealReg, even if the VirtualReg has multiple live ranges. --- --- Virtual regs can be of either class, so that info is attached. --- -data VirtualReg - = VirtualRegI {-# UNPACK #-} !Unique - | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register - | VirtualRegF {-# UNPACK #-} !Unique - | VirtualRegD {-# UNPACK #-} !Unique - - deriving (Eq, Show) - --- This is laborious, but necessary. We can't derive Ord because --- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the --- implementation. See Note [No Ord for Unique] --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] -instance Ord VirtualReg where - compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b - compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b - compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b - compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b - - compare VirtualRegI{} _ = LT - compare _ VirtualRegI{} = GT - compare VirtualRegHi{} _ = LT - compare _ VirtualRegHi{} = GT - compare VirtualRegF{} _ = LT - compare _ VirtualRegF{} = GT - - - -instance Uniquable VirtualReg where - getUnique reg - = case reg of - VirtualRegI u -> u - VirtualRegHi u -> u - VirtualRegF u -> u - VirtualRegD u -> u - -instance Outputable VirtualReg where - ppr reg - = case reg of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - -- this code is kinda wrong on x86 - -- because float and double occupy the same register set - -- namely SSE2 register xmm0 .. xmm15 - VirtualRegF u -> text "%vFloat_" <> pprUniqueAlways u - VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u - - - -renameVirtualReg :: Unique -> VirtualReg -> VirtualReg -renameVirtualReg u r - = case r of - VirtualRegI _ -> VirtualRegI u - VirtualRegHi _ -> VirtualRegHi u - VirtualRegF _ -> VirtualRegF u - VirtualRegD _ -> VirtualRegD u - - -classOfVirtualReg :: VirtualReg -> RegClass -classOfVirtualReg vr - = case vr of - VirtualRegI{} -> RcInteger - VirtualRegHi{} -> RcInteger - VirtualRegF{} -> RcFloat - VirtualRegD{} -> RcDouble - - - --- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform --- when supplied with the vreg for the lower-half of the quantity. --- (NB. Not reversible). -getHiVirtualRegFromLo :: VirtualReg -> VirtualReg -getHiVirtualRegFromLo reg - = case reg of - -- makes a pseudo-unique with tag 'H' - VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') - _ -> panic "Reg.getHiVirtualRegFromLo" - -getHiVRegFromLo :: Reg -> Reg -getHiVRegFromLo reg - = case reg of - RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) - RegReal _ -> panic "Reg.getHiVRegFromLo" - - ------------------------------------------------------------------------------------- --- | RealRegs are machine regs which are available for allocation, in --- the usual way. We know what class they are, because that's part of --- the processor's architecture. --- --- RealRegPairs are pairs of real registers that are allocated together --- to hold a larger value, such as with Double regs on SPARC. --- -data RealReg - = RealRegSingle {-# UNPACK #-} !RegNo - | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo - deriving (Eq, Show, Ord) - -instance Uniquable RealReg where - getUnique reg - = case reg of - RealRegSingle i -> mkRegSingleUnique i - RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) - -instance Outputable RealReg where - ppr reg - = case reg of - RealRegSingle i -> text "%r" <> int i - RealRegPair r1 r2 -> text "%r(" <> int r1 - <> vbar <> int r2 <> text ")" - -regNosOfRealReg :: RealReg -> [RegNo] -regNosOfRealReg rr - = case rr of - RealRegSingle r1 -> [r1] - RealRegPair r1 r2 -> [r1, r2] - - -realRegsAlias :: RealReg -> RealReg -> Bool -realRegsAlias rr1 rr2 - = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) - --------------------------------------------------------------------------------- --- | A register, either virtual or real -data Reg - = RegVirtual !VirtualReg - | RegReal !RealReg - deriving (Eq, Ord) - -regSingle :: RegNo -> Reg -regSingle regNo = RegReal $ RealRegSingle regNo - -regPair :: RegNo -> RegNo -> Reg -regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 - - --- We like to have Uniques for Reg so that we can make UniqFM and UniqSets --- in the register allocator. -instance Uniquable Reg where - getUnique reg - = case reg of - RegVirtual vr -> getUnique vr - RegReal rr -> getUnique rr - --- | Print a reg in a generic manner --- If you want the architecture specific names, then use the pprReg --- function from the appropriate Ppr module. -instance Outputable Reg where - ppr reg - = case reg of - RegVirtual vr -> ppr vr - RegReal rr -> ppr rr - - -isRealReg :: Reg -> Bool -isRealReg reg - = case reg of - RegReal _ -> True - RegVirtual _ -> False - -takeRealReg :: Reg -> Maybe RealReg -takeRealReg reg - = case reg of - RegReal rr -> Just rr - _ -> Nothing - - -isVirtualReg :: Reg -> Bool -isVirtualReg reg - = case reg of - RegReal _ -> False - RegVirtual _ -> True - -takeVirtualReg :: Reg -> Maybe VirtualReg -takeVirtualReg reg - = case reg of - RegReal _ -> Nothing - RegVirtual vr -> Just vr - - --- | The patch function supplied by the allocator maps VirtualReg to RealReg --- regs, but sometimes we want to apply it to plain old Reg. --- -liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) -liftPatchFnToRegReg patchF reg - = case reg of - RegVirtual vr -> RegReal (patchF vr) - RegReal _ -> reg diff --git a/nativeGen/RegAlloc/Graph/ArchBase.hs b/nativeGen/RegAlloc/Graph/ArchBase.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/ArchBase.hs +++ /dev/null @@ -1,161 +0,0 @@ - --- | Utils for calculating general worst, bound, squeese and free, functions. --- --- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" --- Michael Smith, Normal Ramsey, Glenn Holloway. --- PLDI 2004 --- --- These general versions are not used in GHC proper because they are too slow. --- Instead, hand written optimised versions are provided for each architecture --- in MachRegs*.hs --- --- This code is here because we can test the architecture specific code against --- it. --- -module RegAlloc.Graph.ArchBase ( - RegClass(..), - Reg(..), - RegSub(..), - - worst, - bound, - squeese -) where -import GhcPrelude - -import UniqSet -import UniqFM -import Unique - - --- Some basic register classes. --- These aren't necessarily in 1-to-1 correspondence with the allocatable --- RegClasses in MachRegs.hs -data RegClass - -- general purpose regs - = ClassG32 -- 32 bit GPRs - | ClassG16 -- 16 bit GPRs - | ClassG8 -- 8 bit GPRs - - -- floating point regs - | ClassF64 -- 64 bit FPRs - deriving (Show, Eq, Enum) - - --- | A register of some class -data Reg - -- a register of some class - = Reg RegClass Int - - -- a sub-component of one of the other regs - | RegSub RegSub Reg - deriving (Show, Eq) - - --- | so we can put regs in UniqSets -instance Uniquable Reg where - getUnique (Reg c i) - = mkRegSingleUnique - $ fromEnum c * 1000 + i - - getUnique (RegSub s (Reg c i)) - = mkRegSubUnique - $ fromEnum s * 10000 + fromEnum c * 1000 + i - - getUnique (RegSub _ (RegSub _ _)) - = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg." - - --- | A subcomponent of another register -data RegSub - = SubL16 -- lowest 16 bits - | SubL8 -- lowest 8 bits - | SubL8H -- second lowest 8 bits - deriving (Show, Enum, Ord, Eq) - - --- | Worst case displacement --- --- a node N of classN has some number of neighbors, --- all of which are from classC. --- --- (worst neighbors classN classC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. --- --- This should be hand coded/cached for each particular architecture, --- because the compute time is very long.. -worst :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> Int -> RegClass -> RegClass -> Int - -worst regsOfClass regAlias neighbors classN classC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUniqSet regs - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- all the regs in classes N, C - regsN = regsOfClass classN - regsC = regsOfClass classC - - -- all the possible subsets of c which have size < m - regsS = filter (\s -> sizeUniqSet s >= 1 - && sizeUniqSet s <= neighbors) - $ powersetLS regsC - - -- for each of the subsets of C, the regs which conflict - -- with posiblities for N - regsS_conflict - = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS - - in maximum $ map sizeUniqSet $ regsS_conflict - - --- | For a node N of classN and neighbors of classesC --- (bound classN classesC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. -bound :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [RegClass] -> Int - -bound regsOfClass regAlias classN classesC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUFM regs - -- See Note [Unique Determinism and code generation] - - regsC_aliases - = unionManyUniqSets - $ map (regAliasS . getUniqSet . regsOfClass) classesC - - overlap = intersectUniqSets (regsOfClass classN) regsC_aliases - - in sizeUniqSet overlap - - --- | The total squeese on a particular node with a list of neighbors. --- --- A version of this should be constructed for each particular architecture, --- possibly including uses of bound, so that alised registers don't get --- counted twice, as per the paper. -squeese :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [(Int, RegClass)] -> Int - -squeese regsOfClass regAlias classN countCs - = sum - $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) - $ countCs - - --- | powerset (for lists) -powersetL :: [a] -> [[a]] -powersetL = map concat . mapM (\x -> [[],[x]]) - - --- | powersetLS (list of sets) -powersetLS :: Uniquable a => UniqSet a -> [UniqSet a] -powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s - -- See Note [Unique Determinism and code generation] diff --git a/nativeGen/RegAlloc/Graph/ArchX86.hs b/nativeGen/RegAlloc/Graph/ArchX86.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/ArchX86.hs +++ /dev/null @@ -1,161 +0,0 @@ - --- | A description of the register set of the X86. --- --- This isn't used directly in GHC proper. --- --- See RegArchBase.hs for the reference. --- See MachRegs.hs for the actual trivColorable function used in GHC. --- -module RegAlloc.Graph.ArchX86 ( - classOfReg, - regsOfClass, - regName, - regAlias, - worst, - squeese, -) where - -import GhcPrelude - -import RegAlloc.Graph.ArchBase (Reg(..), RegSub(..), RegClass(..)) -import UniqSet - -import qualified Data.Array as A - - --- | Determine the class of a register -classOfReg :: Reg -> RegClass -classOfReg reg - = case reg of - Reg c _ -> c - - RegSub SubL16 _ -> ClassG16 - RegSub SubL8 _ -> ClassG8 - RegSub SubL8H _ -> ClassG8 - - --- | Determine all the regs that make up a certain class. -regsOfClass :: RegClass -> UniqSet Reg -regsOfClass c - = case c of - ClassG32 - -> mkUniqSet [ Reg ClassG32 i - | i <- [0..7] ] - - ClassG16 - -> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) - | i <- [0..7] ] - - ClassG8 - -> unionUniqSets - (mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ]) - (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ]) - - ClassF64 - -> mkUniqSet [ Reg ClassF64 i - | i <- [0..5] ] - - --- | Determine the common name of a reg --- returns Nothing if this reg is not part of the machine. -regName :: Reg -> Maybe String -regName reg - = case reg of - Reg ClassG32 i - | i <= 7 -> - let names = A.listArray (0,8) - [ "eax", "ebx", "ecx", "edx" - , "ebp", "esi", "edi", "esp" ] - in Just $ names A.! i - - RegSub SubL16 (Reg ClassG32 i) - | i <= 7 -> - let names = A.listArray (0,8) - [ "ax", "bx", "cx", "dx" - , "bp", "si", "di", "sp"] - in Just $ names A.! i - - RegSub SubL8 (Reg ClassG32 i) - | i <= 3 -> - let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"] - in Just $ names A.! i - - RegSub SubL8H (Reg ClassG32 i) - | i <= 3 -> - let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"] - in Just $ names A.! i - - _ -> Nothing - - --- | Which regs alias what other regs. -regAlias :: Reg -> UniqSet Reg -regAlias reg - = case reg of - - -- 32 bit regs alias all of the subregs - Reg ClassG32 i - - -- for eax, ebx, ecx, eds - | i <= 3 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg - , RegSub SubL8 reg, RegSub SubL8H reg ] - - -- for esi, edi, esp, ebp - | 4 <= i && i <= 7 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg ] - - -- 16 bit subregs alias the whole reg - RegSub SubL16 r@(Reg ClassG32 _) - -> regAlias r - - -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg - RegSub SubL8 r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] - - RegSub SubL8H r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] - - -- fp - Reg ClassF64 _ - -> unitUniqSet reg - - _ -> error "regAlias: invalid register" - - --- | Optimised versions of RegColorBase.{worst, squeese} specific to x86 -worst :: Int -> RegClass -> RegClass -> Int -worst n classN classC - = case classN of - ClassG32 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG16 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG8 - -> case classC of - ClassG32 -> min (n*2) 8 - ClassG16 -> min (n*2) 8 - ClassG8 -> min n 8 - ClassF64 -> 0 - - ClassF64 - -> case classC of - ClassF64 -> min n 6 - _ -> 0 - -squeese :: RegClass -> [(Int, RegClass)] -> Int -squeese classN countCs - = sum (map (\(i, classC) -> worst i classN classC) countCs) - diff --git a/nativeGen/RegAlloc/Graph/Coalesce.hs b/nativeGen/RegAlloc/Graph/Coalesce.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Coalesce.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Register coalescing. -module RegAlloc.Graph.Coalesce ( - regCoalesce, - slurpJoinMovs -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import Reg - -import Cmm -import Bag -import Digraph -import UniqFM -import UniqSet -import UniqSupply - - --- | Do register coalescing on this top level thing --- --- For Reg -> Reg moves, if the first reg dies at the same time the --- second reg is born then the mov only serves to join live ranges. --- The two regs can be renamed to be the same and the move instruction --- safely erased. -regCoalesce - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM [LiveCmmDecl statics instr] - -regCoalesce code - = do - let joins = foldl' unionBags emptyBag - $ map slurpJoinMovs code - - let alloc = foldl' buildAlloc emptyUFM - $ bagToList joins - - let patched = map (patchEraseLive (sinkReg alloc)) code - - return patched - - --- | Add a v1 = v2 register renaming to the map. --- The register with the lowest lexical name is set as the --- canonical version. -buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg -buildAlloc fm (r1, r2) - = let rmin = min r1 r2 - rmax = max r1 r2 - in addToUFM fm rmax rmin - - --- | Determine the canonical name for a register by following --- v1 = v2 renamings in this map. -sinkReg :: UniqFM Reg -> Reg -> Reg -sinkReg fm r - = case lookupUFM fm r of - Nothing -> r - Just r' -> sinkReg fm r' - - --- | Slurp out mov instructions that only serve to join live ranges. --- --- During a mov, if the source reg dies and the destination reg is --- born then we can rename the two regs to the same thing and --- eliminate the move. -slurpJoinMovs - :: Instruction instr - => LiveCmmDecl statics instr - -> Bag (Reg, Reg) - -slurpJoinMovs live - = slurpCmm emptyBag live - where - slurpCmm rs CmmData{} - = rs - - slurpCmm rs (CmmProc _ _ _ sccs) - = foldl' slurpBlock rs (flattenSCCs sccs) - - slurpBlock rs (BasicBlock _ instrs) - = foldl' slurpLI rs instrs - - slurpLI rs (LiveInstr _ Nothing) = rs - slurpLI rs (LiveInstr instr (Just live)) - | Just (r1, r2) <- takeRegRegMoveInstr instr - , elementOfUniqSet r1 $ liveDieRead live - , elementOfUniqSet r2 $ liveBorn live - - -- only coalesce movs between two virtuals for now, - -- else we end up with allocatable regs in the live - -- regs list.. - , isVirtualReg r1 && isVirtualReg r2 - = consBag (r1, r2) rs - - | otherwise - = rs - diff --git a/nativeGen/RegAlloc/Graph/Main.hs b/nativeGen/RegAlloc/Graph/Main.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Main.hs +++ /dev/null @@ -1,469 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | Graph coloring register allocator. -module RegAlloc.Graph.Main ( - regAlloc -) where -import GhcPrelude - -import qualified GraphColor as Color -import RegAlloc.Liveness -import RegAlloc.Graph.Spill -import RegAlloc.Graph.SpillClean -import RegAlloc.Graph.SpillCost -import RegAlloc.Graph.Stats -import RegAlloc.Graph.TrivColorable -import Instruction -import TargetReg -import RegClass -import Reg - -import Bag -import DynFlags -import Outputable -import GHC.Platform -import UniqFM -import UniqSet -import UniqSupply -import Util (seqList) -import CFG - -import Data.Maybe -import Control.Monad - - --- | The maximum number of build\/spill cycles we'll allow. --- --- It should only take 3 or 4 cycles for the allocator to converge. --- If it takes any longer than this it's probably in an infinite loop, --- so it's better just to bail out and report a bug. -maxSpinCount :: Int -maxSpinCount = 10 - - --- | The top level of the graph coloring register allocator. -regAlloc - :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation - -> UniqSet Int -- ^ set of available spill slots. - -> Int -- ^ current number of spill slots - -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. - -> Maybe CFG -- ^ CFG of basic blocks if available - -> UniqSM ( [NatCmmDecl statics instr] - , Maybe Int, [RegAllocStats statics instr] ) - -- ^ code with registers allocated, additional stacks required - -- and stats for each stage of allocation - -regAlloc dflags regsFree slotsFree slotsCount code cfg - = do - -- TODO: the regClass function is currently hard coded to the default - -- target architecture. Would prefer to determine this from dflags. - -- There are other uses of targetRegClass later in this module. - let platform = targetPlatform dflags - triv = trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform) - - (code_final, debug_codeGraphs, slotsCount', _) - <- regAlloc_spin dflags 0 - triv - regsFree slotsFree slotsCount [] code cfg - - let needStack - | slotsCount == slotsCount' - = Nothing - | otherwise - = Just slotsCount' - - return ( code_final - , needStack - , reverse debug_codeGraphs ) - - --- | Perform solver iterations for the graph coloring allocator. --- --- We extract a register confict graph from the provided cmm code, --- and try to colour it. If that works then we use the solution rewrite --- the code with real hregs. If coloring doesn't work we add spill code --- and try to colour it again. After `maxSpinCount` iterations we give up. --- -regAlloc_spin - :: forall instr statics. - (Instruction instr, - Outputable instr, - Outputable statics) - => DynFlags - -> Int -- ^ Number of solver iterations we've already performed. - -> Color.Triv VirtualReg RegClass RealReg - -- ^ Function for calculating whether a register is trivially - -- colourable. - -> UniqFM (UniqSet RealReg) -- ^ Free registers that we can allocate. - -> UniqSet Int -- ^ Free stack slots that we can use. - -> Int -- ^ Number of spill slots in use - -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to. - -> [LiveCmmDecl statics instr] -- ^ Liveness annotated code to allocate. - -> Maybe CFG - -> UniqSM ( [NatCmmDecl statics instr] - , [RegAllocStats statics instr] - , Int -- Slots in use - , Color.Graph VirtualReg RegClass RealReg) - -regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg - = do - let platform = targetPlatform dflags - - -- If any of these dump flags are turned on we want to hang on to - -- intermediate structures in the allocator - otherwise tell the - -- allocator to ditch them early so we don't end up creating space leaks. - let dump = or - [ dopt Opt_D_dump_asm_regalloc_stages dflags - , dopt Opt_D_dump_asm_stats dflags - , dopt Opt_D_dump_asm_conflicts dflags ] - - -- Check that we're not running off down the garden path. - when (spinCount > maxSpinCount) - $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." - ( text "It looks like the register allocator is stuck in an infinite loop." - $$ text "max cycles = " <> int maxSpinCount - $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr - $ nonDetEltsUniqSet $ unionManyUniqSets - $ nonDetEltsUFM regsFree) - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) - - -- Build the register conflict graph from the cmm code. - (graph :: Color.Graph VirtualReg RegClass RealReg) - <- {-# SCC "BuildGraph" #-} buildGraph code - - -- VERY IMPORTANT: - -- We really do want the graph to be fully evaluated _before_ we - -- start coloring. If we don't do this now then when the call to - -- Color.colorGraph forces bits of it, the heap will be filled with - -- half evaluated pieces of graph and zillions of apply thunks. - seqGraph graph `seq` return () - - -- Build a map of the cost of spilling each instruction. - -- This is a lazy binding, so the map will only be computed if we - -- actually have to spill to the stack. - let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map (slurpSpillCostInfo platform cfg) code - - -- The function to choose regs to leave uncolored. - let spill = chooseSpill spillCosts - - -- Record startup state in our log. - let stat1 - = if spinCount == 0 - then Just $ RegAllocStatsStart - { raLiveCmm = code - , raGraph = graph - , raSpillCosts = spillCosts } - else Nothing - - -- Try and color the graph. - let (graph_colored, rsSpill, rmCoalesce) - = {-# SCC "ColorGraph" #-} - Color.colorGraph - (gopt Opt_RegsIterative dflags) - spinCount - regsFree triv spill graph - - -- Rewrite registers in the code that have been coalesced. - let patchF reg - | RegVirtual vr <- reg - = case lookupUFM rmCoalesce vr of - Just vr' -> patchF (RegVirtual vr') - Nothing -> reg - - | otherwise - = reg - - let (code_coalesced :: [LiveCmmDecl statics instr]) - = map (patchEraseLive patchF) code - - -- Check whether we've found a coloring. - if isEmptyUniqSet rsSpill - - -- Coloring was successful because no registers needed to be spilled. - then do - -- if -fasm-lint is turned on then validate the graph. - -- This checks for bugs in the graph allocator itself. - let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - True -- Require all nodes to be colored. - graph_colored - else graph_colored - - -- Rewrite the code to use real hregs, using the colored graph. - let code_patched - = map (patchRegsFromGraph platform graph_colored_lint) - code_coalesced - - -- Clean out unneeded SPILL/RELOAD meta instructions. - -- The spill code generator just spills the entire live range - -- of a vreg, but it might not need to be on the stack for - -- its entire lifetime. - let code_spillclean - = map (cleanSpills platform) code_patched - - -- Strip off liveness information from the allocated code. - -- Also rewrite SPILL/RELOAD meta instructions into real machine - -- instructions along the way - let code_final - = map (stripLive dflags) code_spillclean - - -- Record what happened in this stage for debugging - let stat - = RegAllocStatsColored - { raCode = code - , raGraph = graph - , raGraphColored = graph_colored_lint - , raCoalesced = rmCoalesce - , raCodeCoalesced = code_coalesced - , raPatched = code_patched - , raSpillClean = code_spillclean - , raFinal = code_final - , raSRMs = foldl' addSRM (0, 0, 0) - $ map countSRMs code_spillclean } - - -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not - -- needed, otherwise we'll get a space leak. - let statList = - if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- Ensure all the statistics are evaluated, to avoid space leaks. - seqList statList (return ()) - - return ( code_final - , statList - , slotsCount - , graph_colored_lint) - - -- Coloring was unsuccessful. We need to spill some register to the - -- stack, make a new graph, and try to color it again. - else do - -- if -fasm-lint is turned on then validate the graph - let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - False -- don't require nodes to be colored - graph_colored - else graph_colored - - -- Spill uncolored regs to the stack. - (code_spilled, slotsFree', slotsCount', spillStats) - <- regSpill platform code_coalesced slotsFree slotsCount rsSpill - - -- Recalculate liveness information. - -- NOTE: we have to reverse the SCCs here to get them back into - -- the reverse-dependency order required by computeLiveness. - -- If they're not in the correct order that function will panic. - code_relive <- mapM (regLiveness platform . reverseBlocksInTops) - code_spilled - - -- Record what happened in this stage for debugging. - let stat = - RegAllocStatsSpill - { raCode = code - , raGraph = graph_colored_lint - , raCoalesced = rmCoalesce - , raSpillStats = spillStats - , raSpillCosts = spillCosts - , raSpilled = code_spilled } - - -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not - -- needed, otherwise we'll get a space leak. - let statList = - if dump - then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- Ensure all the statistics are evaluated, to avoid space leaks. - seqList statList (return ()) - - regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' - slotsCount' statList code_relive cfg - - --- | Build a graph from the liveness and coalesce information in this code. -buildGraph - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM (Color.Graph VirtualReg RegClass RealReg) - -buildGraph code - = do - -- Slurp out the conflicts and reg->reg moves from this code. - let (conflictList, moveList) = - unzip $ map slurpConflicts code - - -- Slurp out the spill/reload coalesces. - let moveList2 = map slurpReloadCoalesce code - - -- Add the reg-reg conflicts to the graph. - let conflictBag = unionManyBags conflictList - let graph_conflict - = foldr graphAddConflictSet Color.initGraph conflictBag - - -- Add the coalescences edges to the graph. - let moveBag - = unionBags (unionManyBags moveList2) - (unionManyBags moveList) - - let graph_coalesce - = foldr graphAddCoalesce graph_conflict moveBag - - return graph_coalesce - - --- | Add some conflict edges to the graph. --- Conflicts between virtual and real regs are recorded as exclusions. -graphAddConflictSet - :: UniqSet Reg - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - -graphAddConflictSet set graph - = let virtuals = mkUniqSet - [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] - - graph1 = Color.addConflicts virtuals classOfVirtualReg graph - - graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) - graph1 - [ (vr, rr) - | RegVirtual vr <- nonDetEltsUniqSet set - , RegReal rr <- nonDetEltsUniqSet set] - -- See Note [Unique Determinism and code generation] - - in graph2 - - --- | Add some coalesence edges to the graph --- Coalesences between virtual and real regs are recorded as preferences. -graphAddCoalesce - :: (Reg, Reg) - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - -graphAddCoalesce (r1, r2) graph - | RegReal rr <- r1 - , RegVirtual vr <- r2 - = Color.addPreference (vr, classOfVirtualReg vr) rr graph - - | RegReal rr <- r2 - , RegVirtual vr <- r1 - = Color.addPreference (vr, classOfVirtualReg vr) rr graph - - | RegVirtual vr1 <- r1 - , RegVirtual vr2 <- r2 - = Color.addCoalesce - (vr1, classOfVirtualReg vr1) - (vr2, classOfVirtualReg vr2) - graph - - -- We can't coalesce two real regs, but there could well be existing - -- hreg,hreg moves in the input code. We'll just ignore these - -- for coalescing purposes. - | RegReal _ <- r1 - , RegReal _ <- r2 - = graph - - | otherwise - = panic "graphAddCoalesce" - - --- | Patch registers in code using the reg -> reg mapping in this graph. -patchRegsFromGraph - :: (Outputable statics, Outputable instr, Instruction instr) - => Platform -> Color.Graph VirtualReg RegClass RealReg - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr - -patchRegsFromGraph platform graph code - = patchEraseLive patchF code - where - -- Function to lookup the hardreg for a virtual reg from the graph. - patchF reg - -- leave real regs alone. - | RegReal{} <- reg - = reg - - -- this virtual has a regular node in the graph. - | RegVirtual vr <- reg - , Just node <- Color.lookupNode graph vr - = case Color.nodeColor node of - Just color -> RegReal color - Nothing -> RegVirtual vr - - -- no node in the graph for this virtual, bad news. - | otherwise - = pprPanic "patchRegsFromGraph: register mapping failed." - ( text "There is no node in the graph for register " - <> ppr reg - $$ ppr code - $$ Color.dotGraph - (\_ -> text "white") - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - graph) - - ------ --- for when laziness just isn't what you wanted... --- We need to deepSeq the whole graph before trying to colour it to avoid --- space leaks. -seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () -seqGraph graph = seqNodes (nonDetEltsUFM (Color.graphMap graph)) - -- See Note [Unique Determinism and code generation] - -seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () -seqNodes ns - = case ns of - [] -> () - (n : ns) -> seqNode n `seq` seqNodes ns - -seqNode :: Color.Node VirtualReg RegClass RealReg -> () -seqNode node - = seqVirtualReg (Color.nodeId node) - `seq` seqRegClass (Color.nodeClass node) - `seq` seqMaybeRealReg (Color.nodeColor node) - `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node))) - `seq` (seqRealRegList (nonDetEltsUniqSet (Color.nodeExclusions node))) - `seq` (seqRealRegList (Color.nodePreference node)) - `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node))) - -- It's OK to use nonDetEltsUniqSet for seq - -seqVirtualReg :: VirtualReg -> () -seqVirtualReg reg = reg `seq` () - -seqRealReg :: RealReg -> () -seqRealReg reg = reg `seq` () - -seqRegClass :: RegClass -> () -seqRegClass c = c `seq` () - -seqMaybeRealReg :: Maybe RealReg -> () -seqMaybeRealReg mr - = case mr of - Nothing -> () - Just r -> seqRealReg r - -seqVirtualRegList :: [VirtualReg] -> () -seqVirtualRegList rs - = case rs of - [] -> () - (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs - -seqRealRegList :: [RealReg] -> () -seqRealRegList rs - = case rs of - [] -> () - (r : rs) -> seqRealReg r `seq` seqRealRegList rs diff --git a/nativeGen/RegAlloc/Graph/Spill.hs b/nativeGen/RegAlloc/Graph/Spill.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Spill.hs +++ /dev/null @@ -1,382 +0,0 @@ - --- | When there aren't enough registers to hold all the vregs we have to spill --- some of those vregs to slots on the stack. This module is used modify the --- code to use those slots. -module RegAlloc.Graph.Spill ( - regSpill, - SpillStats(..), - accSpillSL -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import Reg -import Cmm hiding (RegSet) -import BlockId -import Hoopl.Collections - -import MonadUtils -import State -import Unique -import UniqFM -import UniqSet -import UniqSupply -import Outputable -import GHC.Platform - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - - --- | Spill all these virtual regs to stack slots. --- --- Bumps the number of required stack slots if required. --- --- --- TODO: See if we can split some of the live ranges instead of just globally --- spilling the virtual reg. This might make the spill cleaner's job easier. --- --- TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction --- when making spills. If an instr is using a spilled virtual we may be able to --- address the spill slot directly. --- -regSpill - :: Instruction instr - => Platform - -> [LiveCmmDecl statics instr] -- ^ the code - -> UniqSet Int -- ^ available stack slots - -> Int -- ^ current number of spill slots. - -> UniqSet VirtualReg -- ^ the regs to spill - -> UniqSM - ([LiveCmmDecl statics instr] - -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , Int -- slot count in use now. - , SpillStats ) -- stats about what happened during spilling - -regSpill platform code slotsFree slotCount regs - - -- Not enough slots to spill these regs. - | sizeUniqSet slotsFree < sizeUniqSet regs - = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $ - let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512]) - in regSpill platform code slotsFree' (slotCount+512) regs - - | otherwise - = do - -- Allocate a slot for each of the spilled regs. - let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree - let regSlotMap = listToUFM - $ zip (nonDetEltsUniqSet regs) slots - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- Grab the unique supply from the monad. - us <- getUniqueSupplyM - - -- Run the spiller on all the blocks. - let (code', state') = - runState (mapM (regSpill_top platform regSlotMap) code) - (initSpillS us) - - return ( code' - , minusUniqSet slotsFree (mkUniqSet slots) - , slotCount - , makeSpillStats state') - - --- | Spill some registers to stack slots in a top-level thing. -regSpill_top - :: Instruction instr - => Platform - -> RegMap Int - -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmDecl statics instr - -- ^ the top level thing. - -> SpillM (LiveCmmDecl statics instr) - -regSpill_top platform regSlotMap cmm - = case cmm of - CmmData{} - -> return cmm - - CmmProc info label live sccs - | LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info - -> do - -- The liveVRegsOnEntry contains the set of vregs that are live - -- on entry to each basic block. If we spill one of those vregs - -- we remove it from that set and add the corresponding slot - -- number to the liveSlotsOnEntry set. The spill cleaner needs - -- this information to erase unneeded spill and reload instructions - -- after we've done a successful allocation. - let liveSlotsOnEntry' :: BlockMap IntSet - liveSlotsOnEntry' - = mapFoldlWithKey patchLiveSlot - liveSlotsOnEntry liveVRegsOnEntry - - let info' - = LiveInfo static firstId - liveVRegsOnEntry - liveSlotsOnEntry' - - -- Apply the spiller to all the basic blocks in the CmmProc. - sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs - - return $ CmmProc info' label live sccs' - - where -- Given a BlockId and the set of registers live in it, - -- if registers in this block are being spilled to stack slots, - -- then record the fact that these slots are now live in those blocks - -- in the given slotmap. - patchLiveSlot - :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet - - patchLiveSlot slotMap blockId regsLive - = let - -- Slots that are already recorded as being live. - curSlotsLive = fromMaybe IntSet.empty - $ mapLookup blockId slotMap - - moreSlotsLive = IntSet.fromList - $ catMaybes - $ map (lookupUFM regSlotMap) - $ nonDetEltsUniqSet regsLive - -- See Note [Unique Determinism and code generation] - - slotMap' - = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive) - slotMap - - in slotMap' - - --- | Spill some registers to stack slots in a basic block. -regSpill_block - :: Instruction instr - => Platform - -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. - -> LiveBasicBlock instr - -> SpillM (LiveBasicBlock instr) - -regSpill_block platform regSlotMap (BasicBlock i instrs) - = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs - return $ BasicBlock i (concat instrss') - - --- | Spill some registers to stack slots in a single instruction. --- If the instruction uses registers that need to be spilled, then it is --- prefixed (or postfixed) with the appropriate RELOAD or SPILL meta --- instructions. -regSpill_instr - :: Instruction instr - => Platform - -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. - -> LiveInstr instr - -> SpillM [LiveInstr instr] - -regSpill_instr _ _ li@(LiveInstr _ Nothing) - = do return [li] - -regSpill_instr platform regSlotMap - (LiveInstr instr (Just _)) - = do - -- work out which regs are read and written in this instr - let RU rlRead rlWritten = regUsageOfInstr platform instr - - -- sometimes a register is listed as being read more than once, - -- nub this so we don't end up inserting two lots of spill code. - let rsRead_ = nub rlRead - let rsWritten_ = nub rlWritten - - -- if a reg is modified, it appears in both lists, want to undo this.. - let rsRead = rsRead_ \\ rsWritten_ - let rsWritten = rsWritten_ \\ rsRead_ - let rsModify = intersect rsRead_ rsWritten_ - - -- work out if any of the regs being used are currently being spilled. - let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead - let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten - let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify - - -- rewrite the instr and work out spill code. - (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead - (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten - (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify - - let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) - let prefixes = concat mPrefixes - let postfixes = concat mPostfixes - - -- final code - let instrs' = prefixes - ++ [LiveInstr instr3 Nothing] - ++ postfixes - - return $ instrs' - - --- | Add a RELOAD met a instruction to load a value for an instruction that --- writes to a vreg that is being spilled. -spillRead - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillRead regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } - - return ( instr' - , ( [LiveInstr (RELOAD slot nReg) Nothing] - , []) ) - - | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" - - --- | Add a SPILL meta instruction to store a value for an instruction that --- writes to a vreg that is being spilled. -spillWrite - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillWrite regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) } - - return ( instr' - , ( [] - , [LiveInstr (SPILL nReg slot) Nothing])) - - | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" - - --- | Add both RELOAD and SPILL meta instructions for an instruction that --- both reads and writes to a vreg that is being spilled. -spillModify - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillModify regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } - - return ( instr' - , ( [LiveInstr (RELOAD slot nReg) Nothing] - , [LiveInstr (SPILL nReg slot) Nothing])) - - | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" - - --- | Rewrite uses of this virtual reg in an instr to use a different --- virtual reg. -patchInstr - :: Instruction instr - => Reg -> instr -> SpillM (instr, Reg) - -patchInstr reg instr - = do nUnique <- newUnique - - -- The register we're rewriting is suppoed to be virtual. - -- If it's not then something has gone horribly wrong. - let nReg - = case reg of - RegVirtual vr - -> RegVirtual (renameVirtualReg nUnique vr) - - RegReal{} - -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" - - let instr' = patchReg1 reg nReg instr - return (instr', nReg) - - -patchReg1 - :: Instruction instr - => Reg -> Reg -> instr -> instr - -patchReg1 old new instr - = let patchF r - | r == old = new - | otherwise = r - in patchRegsOfInstr instr patchF - - --- Spiller monad -------------------------------------------------------------- --- | State monad for the spill code generator. -type SpillM a - = State SpillS a - --- | Spill code generator state. -data SpillS - = SpillS - { -- | Unique supply for generating fresh vregs. - stateUS :: UniqSupply - - -- | Spilled vreg vs the number of times it was loaded, stored. - , stateSpillSL :: UniqFM (Reg, Int, Int) } - - --- | Create a new spiller state. -initSpillS :: UniqSupply -> SpillS -initSpillS uniqueSupply - = SpillS - { stateUS = uniqueSupply - , stateSpillSL = emptyUFM } - - --- | Allocate a new unique in the spiller monad. -newUnique :: SpillM Unique -newUnique - = do us <- gets stateUS - case takeUniqFromSupply us of - (uniq, us') - -> do modify $ \s -> s { stateUS = us' } - return uniq - - --- | Add a spill/reload count to a stats record for a register. -accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int) -accSpillSL (r1, s1, l1) (_, s2, l2) - = (r1, s1 + s2, l1 + l2) - - --- Spiller stats -------------------------------------------------------------- --- | Spiller statistics. --- Tells us what registers were spilled. -data SpillStats - = SpillStats - { spillStoreLoad :: UniqFM (Reg, Int, Int) } - - --- | Extract spiller statistics from the spiller state. -makeSpillStats :: SpillS -> SpillStats -makeSpillStats s - = SpillStats - { spillStoreLoad = stateSpillSL s } - - -instance Outputable SpillStats where - ppr stats - = pprUFM (spillStoreLoad stats) - (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l)) diff --git a/nativeGen/RegAlloc/Graph/SpillClean.hs b/nativeGen/RegAlloc/Graph/SpillClean.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/SpillClean.hs +++ /dev/null @@ -1,614 +0,0 @@ - --- | Clean out unneeded spill\/reload instructions. --- --- Handling of join points --- ~~~~~~~~~~~~~~~~~~~~~~~ --- --- B1: B2: --- ... ... --- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1 --- ... A ... ... B ... --- jump B3 jump B3 --- --- B3: ... C ... --- RELOAD SLOT(0), %r1 --- ... --- --- The Plan --- ~~~~~~~~ --- As long as %r1 hasn't been written to in A, B or C then we don't need --- the reload in B3. --- --- What we really care about here is that on the entry to B3, %r1 will --- always have the same value that is in SLOT(0) (ie, %r1 is _valid_) --- --- This also works if the reloads in B1\/B2 were spills instead, because --- spilling %r1 to a slot makes that slot have the same value as %r1. --- -module RegAlloc.Graph.SpillClean ( - cleanSpills -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import Reg - -import BlockId -import Cmm -import UniqSet -import UniqFM -import Unique -import State -import Outputable -import GHC.Platform -import Hoopl.Collections - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - - --- | The identification number of a spill slot. --- A value is stored in a spill slot when we don't have a free --- register to hold it. -type Slot = Int - - --- | Clean out unneeded spill\/reloads from this top level thing. -cleanSpills - :: Instruction instr - => Platform - -> LiveCmmDecl statics instr - -> LiveCmmDecl statics instr - -cleanSpills platform cmm - = evalState (cleanSpin platform 0 cmm) initCleanS - - --- | Do one pass of cleaning. -cleanSpin - :: Instruction instr - => Platform - -> Int -- ^ Iteration number for the cleaner. - -> LiveCmmDecl statics instr -- ^ Liveness annotated code to clean. - -> CleanM (LiveCmmDecl statics instr) - -cleanSpin platform spinCount code - = do - -- Initialise count of cleaned spill and reload instructions. - modify $ \s -> s - { sCleanedSpillsAcc = 0 - , sCleanedReloadsAcc = 0 - , sReloadedBy = emptyUFM } - - code_forward <- mapBlockTopM (cleanBlockForward platform) code - code_backward <- cleanTopBackward code_forward - - -- During the cleaning of each block we collected information about - -- what regs were valid across each jump. Based on this, work out - -- whether it will be safe to erase reloads after join points for - -- the next pass. - collateJoinPoints - - -- Remember how many spill and reload instructions we cleaned in this pass. - spills <- gets sCleanedSpillsAcc - reloads <- gets sCleanedReloadsAcc - modify $ \s -> s - { sCleanedCount = (spills, reloads) : sCleanedCount s } - - -- If nothing was cleaned in this pass or the last one - -- then we're done and it's time to bail out. - cleanedCount <- gets sCleanedCount - if take 2 cleanedCount == [(0, 0), (0, 0)] - then return code - - -- otherwise go around again - else cleanSpin platform (spinCount + 1) code_backward - - -------------------------------------------------------------------------------- --- | Clean out unneeded reload instructions, --- while walking forward over the code. -cleanBlockForward - :: Instruction instr - => Platform - -> LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) - -cleanBlockForward platform (BasicBlock blockId instrs) - = do - -- See if we have a valid association for the entry to this block. - jumpValid <- gets sJumpValid - let assoc = case lookupUFM jumpValid blockId of - Just assoc -> assoc - Nothing -> emptyAssoc - - instrs_reload <- cleanForward platform blockId assoc [] instrs - return $ BasicBlock blockId instrs_reload - - - --- | Clean out unneeded reload instructions. --- --- Walking forwards across the code --- On a reload, if we know a reg already has the same value as a slot --- then we don't need to do the reload. --- -cleanForward - :: Instruction instr - => Platform - -> BlockId -- ^ the block that we're currently in - -> Assoc Store -- ^ two store locations are associated if - -- they have the same value - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) - -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) - -cleanForward _ _ _ acc [] - = return acc - --- Rewrite live range joins via spill slots to just a spill and a reg-reg move --- hopefully the spill will be also be cleaned in the next pass -cleanForward platform blockId assoc acc (li1 : li2 : instrs) - - | LiveInstr (SPILL reg1 slot1) _ <- li1 - , LiveInstr (RELOAD slot2 reg2) _ <- li2 - , slot1 == slot2 - = do - modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanForward platform blockId assoc acc - $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing - : instrs - -cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) - | Just (r1, r2) <- takeRegRegMoveInstr i1 - = if r1 == r2 - -- Erase any left over nop reg reg moves while we're here - -- this will also catch any nop moves that the previous case - -- happens to add. - then cleanForward platform blockId assoc acc instrs - - -- If r1 has the same value as some slots and we copy r1 to r2, - -- then r2 is now associated with those slots instead - else do let assoc' = addAssoc (SReg r1) (SReg r2) - $ delAssoc (SReg r2) - $ assoc - - cleanForward platform blockId assoc' (li : acc) instrs - - -cleanForward platform blockId assoc acc (li : instrs) - - -- Update association due to the spill. - | LiveInstr (SPILL reg slot) _ <- li - = let assoc' = addAssoc (SReg reg) (SSlot slot) - $ delAssoc (SSlot slot) - $ assoc - in cleanForward platform blockId assoc' (li : acc) instrs - - -- Clean a reload instr. - | LiveInstr (RELOAD{}) _ <- li - = do (assoc', mli) <- cleanReload platform blockId assoc li - case mli of - Nothing -> cleanForward platform blockId assoc' acc - instrs - - Just li' -> cleanForward platform blockId assoc' (li' : acc) - instrs - - -- Remember the association over a jump. - | LiveInstr instr _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accJumpValid assoc) targets - cleanForward platform blockId assoc (li : acc) instrs - - -- Writing to a reg changes its value. - | LiveInstr instr _ <- li - , RU _ written <- regUsageOfInstr platform instr - = let assoc' = foldr delAssoc assoc (map SReg $ nub written) - in cleanForward platform blockId assoc' (li : acc) instrs - - - --- | Try and rewrite a reload instruction to something more pleasing -cleanReload - :: Instruction instr - => Platform - -> BlockId - -> Assoc Store - -> LiveInstr instr - -> CleanM (Assoc Store, Maybe (LiveInstr instr)) - -cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) - - -- If the reg we're reloading already has the same value as the slot - -- then we can erase the instruction outright. - | elemAssoc (SSlot slot) (SReg reg) assoc - = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - return (assoc, Nothing) - - -- If we can find another reg with the same value as this slot then - -- do a move instead of a reload. - | Just reg2 <- findRegOfSlot assoc slot - = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - - let assoc' = addAssoc (SReg reg) (SReg reg2) - $ delAssoc (SReg reg) - $ assoc - - return ( assoc' - , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) - - -- Gotta keep this instr. - | otherwise - = do -- Update the association. - let assoc' - = addAssoc (SReg reg) (SSlot slot) - -- doing the reload makes reg and slot the same value - $ delAssoc (SReg reg) - -- reg value changes on reload - $ assoc - - -- Remember that this block reloads from this slot. - accBlockReloadsSlot blockId slot - - return (assoc', Just li) - -cleanReload _ _ _ _ - = panic "RegSpillClean.cleanReload: unhandled instr" - - -------------------------------------------------------------------------------- --- | Clean out unneeded spill instructions, --- while walking backwards over the code. --- --- If there were no reloads from a slot between a spill and the last one --- then the slot was never read and we don't need the spill. --- --- SPILL r0 -> s1 --- RELOAD s1 -> r2 --- SPILL r3 -> s1 <--- don't need this spill --- SPILL r4 -> s1 --- RELOAD s1 -> r5 --- --- Maintain a set of --- "slots which were spilled to but not reloaded from yet" --- --- Walking backwards across the code: --- a) On a reload from a slot, remove it from the set. --- --- a) On a spill from a slot --- If the slot is in set then we can erase the spill, --- because it won't be reloaded from until after the next spill. --- --- otherwise --- keep the spill and add the slot to the set --- --- TODO: This is mostly inter-block --- we should really be updating the noReloads set as we cross jumps also. --- --- TODO: generate noReloads from liveSlotsOnEntry --- -cleanTopBackward - :: Instruction instr - => LiveCmmDecl statics instr - -> CleanM (LiveCmmDecl statics instr) - -cleanTopBackward cmm - = case cmm of - CmmData{} - -> return cmm - - CmmProc info label live sccs - | LiveInfo _ _ _ liveSlotsOnEntry <- info - -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label live sccs' - - -cleanBlockBackward - :: Instruction instr - => BlockMap IntSet - -> LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) - -cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs) - = do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs - return $ BasicBlock blockId instrs_spill - - - -cleanBackward - :: Instruction instr - => BlockMap IntSet -- ^ Slots live on entry to each block - -> UniqSet Int -- ^ Slots that have been spilled, but not reloaded from - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ Instrs to clean (in forwards order) - -> CleanM [LiveInstr instr] -- ^ Cleaned instrs (in backwards order) - -cleanBackward liveSlotsOnEntry noReloads acc lis - = do reloadedBy <- gets sReloadedBy - cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis - - -cleanBackward' - :: Instruction instr - => BlockMap IntSet - -> UniqFM [BlockId] - -> UniqSet Int - -> [LiveInstr instr] - -> [LiveInstr instr] - -> State CleanS [LiveInstr instr] - -cleanBackward' _ _ _ acc [] - = return acc - -cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) - - -- If nothing ever reloads from this slot then we don't need the spill. - | LiveInstr (SPILL _ slot) _ <- li - , Nothing <- lookupUFM reloadedBy (SSlot slot) - = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } - cleanBackward liveSlotsOnEntry noReloads acc instrs - - | LiveInstr (SPILL _ slot) _ <- li - = if elementOfUniqSet slot noReloads - - -- We can erase this spill because the slot won't be read until - -- after the next one - then do - modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } - cleanBackward liveSlotsOnEntry noReloads acc instrs - - else do - -- This slot is being spilled to, but we haven't seen any reloads yet. - let noReloads' = addOneToUniqSet noReloads slot - cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- if we reload from a slot then it's no longer unused - | LiveInstr (RELOAD slot _) _ <- li - , noReloads' <- delOneFromUniqSet noReloads slot - = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- If a slot is live in a jump target then assume it's reloaded there. - -- - -- TODO: A real dataflow analysis would do a better job here. - -- If the target block _ever_ used the slot then we assume - -- it always does, but if those reloads are cleaned the slot - -- liveness map doesn't get updated. - | LiveInstr instr _ <- li - , targets <- jumpDestsOfInstr instr - = do - let slotsReloadedByTargets - = IntSet.unions - $ catMaybes - $ map (flip mapLookup liveSlotsOnEntry) - $ targets - - let noReloads' - = foldl' delOneFromUniqSet noReloads - $ IntSet.toList slotsReloadedByTargets - - cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- some other instruction - | otherwise - = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs - - --- | Combine the associations from all the inward control flow edges. --- -collateJoinPoints :: CleanM () -collateJoinPoints - = modify $ \s -> s - { sJumpValid = mapUFM intersects (sJumpValidAcc s) - , sJumpValidAcc = emptyUFM } - -intersects :: [Assoc Store] -> Assoc Store -intersects [] = emptyAssoc -intersects assocs = foldl1' intersectAssoc assocs - - --- | See if we have a reg with the same value as this slot in the association table. -findRegOfSlot :: Assoc Store -> Int -> Maybe Reg -findRegOfSlot assoc slot - | close <- closeAssoc (SSlot slot) assoc - , Just (SReg reg) <- find isStoreReg $ nonDetEltsUniqSet close - -- See Note [Unique Determinism and code generation] - = Just reg - - | otherwise - = Nothing - - -------------------------------------------------------------------------------- --- | Cleaner monad. -type CleanM - = State CleanS - --- | Cleaner state. -data CleanS - = CleanS - { -- | Regs which are valid at the start of each block. - sJumpValid :: UniqFM (Assoc Store) - - -- | Collecting up what regs were valid across each jump. - -- in the next pass we can collate these and write the results - -- to sJumpValid. - , sJumpValidAcc :: UniqFM [Assoc Store] - - -- | Map of (slot -> blocks which reload from this slot) - -- used to decide if whether slot spilled to will ever be - -- reloaded from on this path. - , sReloadedBy :: UniqFM [BlockId] - - -- | Spills and reloads cleaned each pass (latest at front) - , sCleanedCount :: [(Int, Int)] - - -- | Spills and reloads that have been cleaned in this pass so far. - , sCleanedSpillsAcc :: Int - , sCleanedReloadsAcc :: Int } - - --- | Construct the initial cleaner state. -initCleanS :: CleanS -initCleanS - = CleanS - { sJumpValid = emptyUFM - , sJumpValidAcc = emptyUFM - - , sReloadedBy = emptyUFM - - , sCleanedCount = [] - - , sCleanedSpillsAcc = 0 - , sCleanedReloadsAcc = 0 } - - --- | Remember the associations before a jump. -accJumpValid :: Assoc Store -> BlockId -> CleanM () -accJumpValid assocs target - = modify $ \s -> s { - sJumpValidAcc = addToUFM_C (++) - (sJumpValidAcc s) - target - [assocs] } - - -accBlockReloadsSlot :: BlockId -> Slot -> CleanM () -accBlockReloadsSlot blockId slot - = modify $ \s -> s { - sReloadedBy = addToUFM_C (++) - (sReloadedBy s) - (SSlot slot) - [blockId] } - - -------------------------------------------------------------------------------- --- A store location can be a stack slot or a register -data Store - = SSlot Int - | SReg Reg - - --- | Check if this is a reg store. -isStoreReg :: Store -> Bool -isStoreReg ss - = case ss of - SSlot _ -> False - SReg _ -> True - - --- Spill cleaning is only done once all virtuals have been allocated to realRegs -instance Uniquable Store where - getUnique (SReg r) - | RegReal (RealRegSingle i) <- r - = mkRegSingleUnique i - - | RegReal (RealRegPair r1 r2) <- r - = mkRegPairUnique (r1 * 65535 + r2) - - | otherwise - = error $ "RegSpillClean.getUnique: found virtual reg during spill clean," - ++ "only real regs expected." - - getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok - - -instance Outputable Store where - ppr (SSlot i) = text "slot" <> int i - ppr (SReg r) = ppr r - - -------------------------------------------------------------------------------- --- Association graphs. --- In the spill cleaner, two store locations are associated if they are known --- to hold the same value. --- -type Assoc a = UniqFM (UniqSet a) - --- | An empty association -emptyAssoc :: Assoc a -emptyAssoc = emptyUFM - - --- | Add an association between these two things. -addAssoc :: Uniquable a - => a -> a -> Assoc a -> Assoc a - -addAssoc a b m - = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b) - m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a) - in m2 - - --- | Delete all associations to a node. -delAssoc :: (Uniquable a) - => a -> Assoc a -> Assoc a - -delAssoc a m - | Just aSet <- lookupUFM m a - , m1 <- delFromUFM m a - = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet - -- It's OK to use nonDetFoldUFM here because deletion is commutative - - | otherwise = m - - --- | Delete a single association edge (a -> b). -delAssoc1 :: Uniquable a - => a -> a -> Assoc a -> Assoc a - -delAssoc1 a b m - | Just aSet <- lookupUFM m a - = addToUFM m a (delOneFromUniqSet aSet b) - - | otherwise = m - - --- | Check if these two things are associated. -elemAssoc :: (Uniquable a) - => a -> a -> Assoc a -> Bool - -elemAssoc a b m - = elementOfUniqSet b (closeAssoc a m) - - --- | Find the refl. trans. closure of the association from this point. -closeAssoc :: (Uniquable a) - => a -> Assoc a -> UniqSet a - -closeAssoc a assoc - = closeAssoc' assoc emptyUniqSet (unitUniqSet a) - where - closeAssoc' assoc visited toVisit - = case nonDetEltsUniqSet toVisit of - -- See Note [Unique Determinism and code generation] - - -- nothing else to visit, we're done - [] -> visited - - (x:_) - -- we've already seen this node - | elementOfUniqSet x visited - -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x) - - -- haven't seen this node before, - -- remember to visit all its neighbors - | otherwise - -> let neighbors - = case lookupUFM assoc x of - Nothing -> emptyUniqSet - Just set -> set - - in closeAssoc' assoc - (addOneToUniqSet visited x) - (unionUniqSets toVisit neighbors) - --- | Intersect two associations. -intersectAssoc :: Assoc a -> Assoc a -> Assoc a -intersectAssoc a b - = intersectUFM_C (intersectUniqSets) a b - diff --git a/nativeGen/RegAlloc/Graph/SpillCost.hs b/nativeGen/RegAlloc/Graph/SpillCost.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/SpillCost.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-} -module RegAlloc.Graph.SpillCost ( - SpillCostRecord, - plusSpillCostRecord, - pprSpillCostRecord, - - SpillCostInfo, - zeroSpillCostInfo, - plusSpillCostInfo, - - slurpSpillCostInfo, - chooseSpill, - - lifeMapFromSpillCostInfo -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import RegClass -import Reg - -import GraphBase - -import Hoopl.Collections (mapLookup) -import Hoopl.Label -import Cmm -import UniqFM -import UniqSet -import Digraph (flattenSCCs) -import Outputable -import GHC.Platform -import State -import CFG - -import Data.List (nub, minimumBy) -import Data.Maybe -import Control.Monad (join) - - --- | Records the expected cost to spill some regster. -type SpillCostRecord - = ( VirtualReg -- register name - , Int -- number of writes to this reg - , Int -- number of reads from this reg - , Int) -- number of instrs this reg was live on entry to - - --- | Map of `SpillCostRecord` -type SpillCostInfo - = UniqFM SpillCostRecord - -type SpillCostState = State (UniqFM SpillCostRecord) () - --- | An empty map of spill costs. -zeroSpillCostInfo :: SpillCostInfo -zeroSpillCostInfo = emptyUFM - - --- | Add two spill cost infos. -plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo -plusSpillCostInfo sc1 sc2 - = plusUFM_C plusSpillCostRecord sc1 sc2 - - --- | Add two spill cost records. -plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord -plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) - | r1 == r2 = (r1, a1 + a2, b1 + b2, c1 + c2) - | otherwise = error "RegSpillCost.plusRegInt: regs don't match" - - --- | Slurp out information used for determining spill costs. --- --- For each vreg, the number of times it was written to, read from, --- and the number of instructions it was live on entry to (lifetime) --- -slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr) - => Platform - -> Maybe CFG - -> LiveCmmDecl statics instr - -> SpillCostInfo - -slurpSpillCostInfo platform cfg cmm - = execState (countCmm cmm) zeroSpillCostInfo - where - countCmm CmmData{} = return () - countCmm (CmmProc info _ _ sccs) - = mapM_ (countBlock info freqMap) - $ flattenSCCs sccs - where - LiveInfo _ entries _ _ = info - freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg - - -- Lookup the regs that are live on entry to this block in - -- the info table from the CmmProc. - countBlock info freqMap (BasicBlock blockId instrs) - | LiveInfo _ _ blockLive _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , rsLiveEntry_virt <- takeVirtuals rsLiveEntry - = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs - - | otherwise - = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" - - - countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState - countLIs _ _ [] - = return () - - -- Skip over comment and delta pseudo instrs. - countLIs scale rsLive (LiveInstr instr Nothing : lis) - | isMetaInstr instr - = countLIs scale rsLive lis - - | otherwise - = pprPanic "RegSpillCost.slurpSpillCostInfo" - $ text "no liveness information on instruction " <> ppr instr - - countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis) - = do - -- Increment the lifetime counts for regs live on entry to this instr. - mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- Increment counts for what regs were read/written from. - let (RU read written) = regUsageOfInstr platform instr - mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read - mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written - - -- Compute liveness for entry to next instruction. - let liveDieRead_virt = takeVirtuals (liveDieRead live) - let liveDieWrite_virt = takeVirtuals (liveDieWrite live) - let liveBorn_virt = takeVirtuals (liveBorn live) - - let rsLiveAcross - = rsLiveEntry `minusUniqSet` liveDieRead_virt - - let rsLiveNext - = (rsLiveAcross `unionUniqSets` liveBorn_virt) - `minusUniqSet` liveDieWrite_virt - - countLIs scale rsLiveNext lis - - incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0) - incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0) - incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) - - blockFreq :: Maybe (LabelMap Double) -> Label -> Double - blockFreq freqs bid - | Just freq <- join (mapLookup bid <$> freqs) - = max 1.0 (10000 * freq) - | otherwise - = 1.0 -- Only if no cfg given - --- | Take all the virtual registers from this set. -takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg -takeVirtuals set = mkUniqSet - [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] - -- See Note [Unique Determinism and code generation] - - --- | Choose a node to spill from this graph -chooseSpill - :: SpillCostInfo - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -chooseSpill info graph - = let cost = spillCost_length info graph - node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - in nodeId node - - -------------------------------------------------------------------------------- --- | Chaitins spill cost function is: --- --- cost = sum loadCost * freq (u) + sum storeCost * freq (d) --- u <- uses (v) d <- defs (v) --- --- There are no loops in our code at the moment, so we can set the freq's to 1. --- --- If we don't have live range splitting then Chaitins function performs badly --- if we have lots of nested live ranges and very few registers. --- --- v1 v2 v3 --- def v1 . --- use v1 . --- def v2 . . --- def v3 . . . --- use v1 . . . --- use v3 . . . --- use v2 . . --- use v1 . --- --- defs uses degree cost --- v1: 1 3 3 1.5 --- v2: 1 2 3 1.0 --- v3: 1 1 3 0.666 --- --- v3 has the lowest cost, but if we only have 2 hardregs and we insert --- spill code for v3 then this isn't going to improve the colorability of --- the graph. --- --- When compiling SHA1, which as very long basic blocks and some vregs --- with very long live ranges the allocator seems to try and spill from --- the inside out and eventually run out of stack slots. --- --- Without live range splitting, its's better to spill from the outside --- in so set the cost of very long live ranges to zero --- - --- spillCost_chaitin --- :: SpillCostInfo --- -> Graph VirtualReg RegClass RealReg --- -> VirtualReg --- -> Float - --- spillCost_chaitin info graph reg --- -- Spilling a live range that only lives for 1 instruction --- -- isn't going to help us at all - and we definitely want to avoid --- -- trying to re-spill previously inserted spill code. --- | lifetime <= 1 = 1/0 - --- -- It's unlikely that we'll find a reg for a live range this long --- -- better to spill it straight up and not risk trying to keep it around --- -- and have to go through the build/color cycle again. - --- -- To facility this we scale down the spill cost of long ranges. --- -- This makes sure long ranges are still spilled first. --- -- But this way spill cost remains relevant for long live --- -- ranges. --- | lifetime >= 128 --- = (spillCost / conflicts) / 10.0 - - --- -- Otherwise revert to chaitin's regular cost function. --- | otherwise = (spillCost / conflicts) --- where --- !spillCost = fromIntegral (uses + defs) :: Float --- conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg) --- (_, defs, uses, lifetime) --- = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg - - --- Just spill the longest live range. -spillCost_length - :: SpillCostInfo - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -> Float - -spillCost_length info _ reg - | lifetime <= 1 = 1/0 - | otherwise = 1 / fromIntegral lifetime - where (_, _, _, lifetime) - = fromMaybe (reg, 0, 0, 0) - $ lookupUFM info reg - - --- | Extract a map of register lifetimes from a `SpillCostInfo`. -lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int) -lifeMapFromSpillCostInfo info - = listToUFM - $ map (\(r, _, _, life) -> (r, (r, life))) - $ nonDetEltsUFM info - -- See Note [Unique Determinism and code generation] - - --- | Determine the degree (number of neighbors) of this node which --- have the same class. -nodeDegree - :: (VirtualReg -> RegClass) - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -> Int - -nodeDegree classOfVirtualReg graph reg - | Just node <- lookupUFM (graphMap graph) reg - - , virtConflicts - <- length - $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ nodeConflicts node - - = virtConflicts + sizeUniqSet (nodeExclusions node) - - | otherwise - = 0 - - --- | Show a spill cost record, including the degree from the graph --- and final calulated spill cost. -pprSpillCostRecord - :: (VirtualReg -> RegClass) - -> (Reg -> SDoc) - -> Graph VirtualReg RegClass RealReg - -> SpillCostRecord - -> SDoc - -pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) - = hsep - [ pprReg (RegVirtual reg) - , ppr uses - , ppr defs - , ppr life - , ppr $ nodeDegree regClass graph reg - , text $ show $ (fromIntegral (uses + defs) - / fromIntegral (nodeDegree regClass graph reg) :: Float) ] - diff --git a/nativeGen/RegAlloc/Graph/Stats.hs b/nativeGen/RegAlloc/Graph/Stats.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/Stats.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} - --- | Carries interesting info for debugging / profiling of the --- graph coloring register allocator. -module RegAlloc.Graph.Stats ( - RegAllocStats (..), - - pprStats, - pprStatsSpills, - pprStatsLifetimes, - pprStatsConflict, - pprStatsLifeConflict, - - countSRMs, addSRM -) where - -import GhcPrelude - -import qualified GraphColor as Color -import RegAlloc.Liveness -import RegAlloc.Graph.Spill -import RegAlloc.Graph.SpillCost -import RegAlloc.Graph.TrivColorable -import Instruction -import RegClass -import Reg -import TargetReg - -import Outputable -import UniqFM -import UniqSet -import State - --- | Holds interesting statistics from the register allocator. -data RegAllocStats statics instr - - -- Information about the initial conflict graph. - = RegAllocStatsStart - { -- | Initial code, with liveness. - raLiveCmm :: [LiveCmmDecl statics instr] - - -- | The initial, uncolored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | Information to help choose which regs to spill. - , raSpillCosts :: SpillCostInfo } - - - -- Information about an intermediate graph. - -- This is one that we couldn't color, so had to insert spill code - -- instruction stream. - | RegAllocStatsSpill - { -- | Code we tried to allocate registers for. - raCode :: [LiveCmmDecl statics instr] - - -- | Partially colored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | The regs that were coalesced. - , raCoalesced :: UniqFM VirtualReg - - -- | Spiller stats. - , raSpillStats :: SpillStats - - -- | Number of instructions each reg lives for. - , raSpillCosts :: SpillCostInfo - - -- | Code with spill instructions added. - , raSpilled :: [LiveCmmDecl statics instr] } - - - -- a successful coloring - | RegAllocStatsColored - { -- | Code we tried to allocate registers for. - raCode :: [LiveCmmDecl statics instr] - - -- | Uncolored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | Coalesced and colored graph. - , raGraphColored :: Color.Graph VirtualReg RegClass RealReg - - -- | Regs that were coalesced. - , raCoalesced :: UniqFM VirtualReg - - -- | Code with coalescings applied. - , raCodeCoalesced :: [LiveCmmDecl statics instr] - - -- | Code with vregs replaced by hregs. - , raPatched :: [LiveCmmDecl statics instr] - - -- | Code with unneeded spill\/reloads cleaned out. - , raSpillClean :: [LiveCmmDecl statics instr] - - -- | Final code. - , raFinal :: [NatCmmDecl statics instr] - - -- | Spill\/reload\/reg-reg moves present in this code. - , raSRMs :: (Int, Int, Int) } - - -instance (Outputable statics, Outputable instr) - => Outputable (RegAllocStats statics instr) where - - ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> - text "# Start" - $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) - $$ text "" - $$ text "# Initial register conflict graph." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraph s) - - - ppr (s@RegAllocStatsSpill{}) = - text "# Spill" - - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" - - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) - $$ text "" - else empty) - - $$ text "# Spills inserted." - $$ ppr (raSpillStats s) - $$ text "" - - $$ text "# Code with spills inserted." - $$ ppr (raSpilled s) - - - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) - = sdocWithPlatform $ \platform -> - text "# Colored" - - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" - - $$ text "# Register conflict graph (colored)." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraphColored s) - $$ text "" - - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) - $$ text "" - else empty) - - $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) - $$ text "" - - $$ text "# Native code after register allocation." - $$ ppr (raPatched s) - $$ text "" - - $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) - $$ text "" - - $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) - $$ text "" - $$ text "# Score:" - $$ (text "# spills inserted: " <> int spills) - $$ (text "# reloads inserted: " <> int reloads) - $$ (text "# reg-reg moves remaining: " <> int moves) - $$ text "" - - --- | Do all the different analysis on this list of RegAllocStats -pprStats - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg - -> SDoc - -pprStats stats graph - = let outSpills = pprStatsSpills stats - outLife = pprStatsLifetimes stats - outConflict = pprStatsConflict stats - outScatter = pprStatsLifeConflict stats graph - - in vcat [outSpills, outLife, outConflict, outScatter] - - --- | Dump a table of how many spill loads \/ stores were inserted for each vreg. -pprStatsSpills - :: [RegAllocStats statics instr] -> SDoc - -pprStatsSpills stats - = let - finals = [ s | s@RegAllocStatsColored{} <- stats] - - -- sum up how many stores\/loads\/reg-reg-moves were left in the code - total = foldl' addSRM (0, 0, 0) - $ map raSRMs finals - - in ( text "-- spills-added-total" - $$ text "-- (stores, loads, reg_reg_moves_remaining)" - $$ ppr total - $$ text "") - - --- | Dump a table of how long vregs tend to live for in the initial code. -pprStatsLifetimes - :: [RegAllocStats statics instr] -> SDoc - -pprStatsLifetimes stats - = let info = foldl' plusSpillCostInfo zeroSpillCostInfo - [ raSpillCosts s - | s@RegAllocStatsStart{} <- stats ] - - lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info - - in ( text "-- vreg-population-lifetimes" - $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" - $$ pprUFM lifeBins (vcat . map ppr) - $$ text "\n") - - -binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) -binLifetimeCount fm - = let lifes = map (\l -> (l, (l, 1))) - $ map snd - $ nonDetEltsUFM fm - -- See Note [Unique Determinism and code generation] - - in addListToUFM_C - (\(l1, c1) (_, c2) -> (l1, c1 + c2)) - emptyUFM - lifes - - --- | Dump a table of how many conflicts vregs tend to have in the initial code. -pprStatsConflict - :: [RegAllocStats statics instr] -> SDoc - -pprStatsConflict stats - = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) - emptyUFM - $ map Color.slurpNodeConflictCount - [ raGraph s | s@RegAllocStatsStart{} <- stats ] - - in ( text "-- vreg-conflicts" - $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" - $$ pprUFM confMap (vcat . map ppr) - $$ text "\n") - - --- | For every vreg, dump how many conflicts it has, and its lifetime. --- Good for making a scatter plot. -pprStatsLifeConflict - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph - -> SDoc - -pprStatsLifeConflict stats graph - = let lifeMap = lifeMapFromSpillCostInfo - $ foldl' plusSpillCostInfo zeroSpillCostInfo - $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] - - scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of - Just (_, l) -> l - Nothing -> 0 - Just node = Color.lookupNode graph r - in parens $ hcat $ punctuate (text ", ") - [ doubleQuotes $ ppr $ Color.nodeId node - , ppr $ sizeUniqSet (Color.nodeConflicts node) - , ppr $ lifetime ]) - $ map Color.nodeId - $ nonDetEltsUFM - -- See Note [Unique Determinism and code generation] - $ Color.graphMap graph - - in ( text "-- vreg-conflict-lifetime" - $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" - $$ (vcat scatter) - $$ text "\n") - - --- | Count spill/reload/reg-reg moves. --- Lets us see how well the register allocator has done. -countSRMs - :: Instruction instr - => LiveCmmDecl statics instr -> (Int, Int, Int) - -countSRMs cmm - = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) - - -countSRM_block - :: Instruction instr - => GenBasicBlock (LiveInstr instr) - -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) - -countSRM_block (BasicBlock i instrs) - = do instrs' <- mapM countSRM_instr instrs - return $ BasicBlock i instrs' - - -countSRM_instr - :: Instruction instr - => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) - -countSRM_instr li - | LiveInstr SPILL{} _ <- li - = do modify $ \(s, r, m) -> (s + 1, r, m) - return li - - | LiveInstr RELOAD{} _ <- li - = do modify $ \(s, r, m) -> (s, r + 1, m) - return li - - | LiveInstr instr _ <- li - , Just _ <- takeRegRegMoveInstr instr - = do modify $ \(s, r, m) -> (s, r, m + 1) - return li - - | otherwise - = return li - - --- sigh.. -addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) -addSRM (s1, r1, m1) (s2, r2, m2) - = let !s = s1 + s2 - !r = r1 + r2 - !m = m1 + m2 - in (s, r, m) - diff --git a/nativeGen/RegAlloc/Graph/TrivColorable.hs b/nativeGen/RegAlloc/Graph/TrivColorable.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE CPP #-} - -module RegAlloc.Graph.TrivColorable ( - trivColorable, -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import RegClass -import Reg - -import GraphBase - -import UniqSet -import GHC.Platform -import Panic - --- trivColorable --------------------------------------------------------------- - --- trivColorable function for the graph coloring allocator --- --- This gets hammered by scanGraph during register allocation, --- so needs to be fairly efficient. --- --- NOTE: This only works for arcitectures with just RcInteger and RcDouble --- (which are disjoint) ie. x86, x86_64 and ppc --- --- The number of allocatable regs is hard coded in here so we can do --- a fast comparison in trivColorable. --- --- It's ok if these numbers are _less_ than the actual number of free --- regs, but they can't be more or the register conflict --- graph won't color. --- --- If the graph doesn't color then the allocator will panic, but it won't --- generate bad object code or anything nasty like that. --- --- There is an allocatableRegsInClass :: RegClass -> Int, but doing --- the unboxing is too slow for us here. --- TODO: Is that still true? Could we use allocatableRegsInClass --- without losing performance now? --- --- Look at includes/stg/MachRegs.h to get the numbers. --- - - --- Disjoint registers ---------------------------------------------------------- --- --- The definition has been unfolded into individual cases for speed. --- Each architecture has a different register setup, so we use a --- different regSqueeze function for each. --- -accSqueeze - :: Int - -> Int - -> (reg -> Int) - -> UniqSet reg - -> Int - -accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us) - -- See Note [Unique Determinism and code generation] - where acc count [] = count - acc count _ | count >= maxCount = count - acc count (r:rs) = acc (count + squeeze r) rs - -{- Note [accSqueeze] -~~~~~~~~~~~~~~~~~~~~ -BL 2007/09 -Doing a nice fold over the UniqSet makes trivColorable use -32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs. -Therefore the UniqFM is made non-abstract and we use custom fold. - -MS 2010/04 -When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal -representation any more. But it is imperative that the accSqueeze stops -the folding if the count gets greater or equal to maxCount. We thus convert -UniqFM to a (lazy) list, do the fold and stops if necessary, which was -the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows. -(original = previous implementation, folding = fold of the whole UFM, - lazyFold = the current implementation, - hackFold = using internal representation of Data.IntMap) - - original folding hackFold lazyFold - -O -fasm (used everywhere) 31.509s 30.387s 30.791s 30.603s - 100.00% 96.44% 97.72% 97.12% - -fregs-graph 67.938s 74.875s 62.673s 64.679s - 100.00% 110.21% 92.25% 95.20% - -fregs-iterative 89.761s 143.913s 81.075s 86.912s - 100.00% 160.33% 90.32% 96.83% - -fnew-codegen 38.225s 37.142s 37.551s 37.119s - 100.00% 97.17% 98.24% 97.11% - -fnew-codegen -fregs-graph 91.786s 91.51s 87.368s 86.88s - 100.00% 99.70% 95.19% 94.65% - -fnew-codegen -fregs-iterative 206.72s 343.632s 194.694s 208.677s - 100.00% 166.23% 94.18% 100.95% --} - -trivColorable - :: Platform - -> (RegClass -> VirtualReg -> Int) - -> (RegClass -> RealReg -> Int) - -> Triv VirtualReg RegClass RealReg - -trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions - | let cALLOCATABLE_REGS_INTEGER - = (case platformArch platform of - ArchX86 -> 3 - ArchX86_64 -> 5 - ArchPPC -> 16 - ArchSPARC -> 14 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 15 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> panic "trivColorable ArchAArch64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchS390X -> panic "trivColorable ArchS390X" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER - (virtualRegSqueeze RcInteger) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_INTEGER - (realRegSqueeze RcInteger) - exclusions - - = count3 < cALLOCATABLE_REGS_INTEGER - -trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions - | let cALLOCATABLE_REGS_FLOAT - = (case platformArch platform of - -- On x86_64 and x86, Float and RcDouble - -- use the same registers, - -- so we only use RcDouble to represent the - -- register allocation problem on those types. - ArchX86 -> 0 - ArchX86_64 -> 0 - ArchPPC -> 0 - ArchSPARC -> 22 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 0 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> panic "trivColorable ArchAArch64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchS390X -> panic "trivColorable ArchS390X" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT - (virtualRegSqueeze RcFloat) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_FLOAT - (realRegSqueeze RcFloat) - exclusions - - = count3 < cALLOCATABLE_REGS_FLOAT - -trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions - | let cALLOCATABLE_REGS_DOUBLE - = (case platformArch platform of - ArchX86 -> 8 - -- in x86 32bit mode sse2 there are only - -- 8 XMM registers xmm0 ... xmm7 - ArchX86_64 -> 10 - -- in x86_64 there are 16 XMM registers - -- xmm0 .. xmm15, here 10 is a - -- "dont need to solve conflicts" count that - -- was chosen at some point in the past. - ArchPPC -> 26 - ArchSPARC -> 11 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 20 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> panic "trivColorable ArchAArch64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchS390X -> panic "trivColorable ArchS390X" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE - (virtualRegSqueeze RcDouble) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_DOUBLE - (realRegSqueeze RcDouble) - exclusions - - = count3 < cALLOCATABLE_REGS_DOUBLE - - - - --- Specification Code ---------------------------------------------------------- --- --- The trivColorable function for each particular architecture should --- implement the following function, but faster. --- - -{- -trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool -trivColorable classN conflicts exclusions - = let - - acc :: Reg -> (Int, Int) -> (Int, Int) - acc r (cd, cf) - = case regClass r of - RcInteger -> (cd+1, cf) - RcFloat -> (cd, cf+1) - _ -> panic "Regs.trivColorable: reg class not handled" - - tmp = nonDetFoldUFM acc (0, 0) conflicts - (countInt, countFloat) = nonDetFoldUFM acc tmp exclusions - - squeese = worst countInt classN RcInteger - + worst countFloat classN RcFloat - - in squeese < allocatableRegsInClass classN - --- | Worst case displacement --- node N of classN has n neighbors of class C. --- --- We currently only have RcInteger and RcDouble, which don't conflict at all. --- This is a bit boring compared to what's in RegArchX86. --- -worst :: Int -> RegClass -> RegClass -> Int -worst n classN classC - = case classN of - RcInteger - -> case classC of - RcInteger -> min n (allocatableRegsInClass RcInteger) - RcFloat -> 0 - - RcDouble - -> case classC of - RcFloat -> min n (allocatableRegsInClass RcFloat) - RcInteger -> 0 - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: [RegNo] -allocatableRegs - = let isFree i = freeReg i - in filter isFree allMachRegNos - - --- | The number of regs in each class. --- We go via top level CAFs to ensure that we're not recomputing --- the length of these lists each time the fn is called. -allocatableRegsInClass :: RegClass -> Int -allocatableRegsInClass cls - = case cls of - RcInteger -> allocatableRegsInteger - RcFloat -> allocatableRegsDouble - -allocatableRegsInteger :: Int -allocatableRegsInteger - = length $ filter (\r -> regClass r == RcInteger) - $ map RealReg allocatableRegs - -allocatableRegsFloat :: Int -allocatableRegsFloat - = length $ filter (\r -> regClass r == RcFloat - $ map RealReg allocatableRegs --} diff --git a/nativeGen/RegAlloc/Linear/Base.hs b/nativeGen/RegAlloc/Linear/Base.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/Base.hs +++ /dev/null @@ -1,141 +0,0 @@ - --- | Put common type definitions here to break recursive module dependencies. - -module RegAlloc.Linear.Base ( - BlockAssignment, - - Loc(..), - regsOfLoc, - - -- for stats - SpillReason(..), - RegAllocStats(..), - - -- the allocator monad - RA_State(..), -) - -where - -import GhcPrelude - -import RegAlloc.Linear.StackMap -import RegAlloc.Liveness -import Reg - -import DynFlags -import Outputable -import Unique -import UniqFM -import UniqSupply -import BlockId - - --- | Used to store the register assignment on entry to a basic block. --- We use this to handle join points, where multiple branch instructions --- target a particular label. We have to insert fixup code to make --- the register assignments from the different sources match up. --- -type BlockAssignment freeRegs - = BlockMap (freeRegs, RegMap Loc) - - --- | Where a vreg is currently stored --- A temporary can be marked as living in both a register and memory --- (InBoth), for example if it was recently loaded from a spill location. --- This makes it cheap to spill (no save instruction required), but we --- have to be careful to turn this into InReg if the value in the --- register is changed. - --- This is also useful when a temporary is about to be clobbered. We --- save it in a spill location, but mark it as InBoth because the current --- instruction might still want to read it. --- -data Loc - -- | vreg is in a register - = InReg !RealReg - - -- | vreg is held in a stack slot - | InMem {-# UNPACK #-} !StackSlot - - - -- | vreg is held in both a register and a stack slot - | InBoth !RealReg - {-# UNPACK #-} !StackSlot - deriving (Eq, Show, Ord) - -instance Outputable Loc where - ppr l = text (show l) - - --- | Get the reg numbers stored in this Loc. -regsOfLoc :: Loc -> [RealReg] -regsOfLoc (InReg r) = [r] -regsOfLoc (InBoth r _) = [r] -regsOfLoc (InMem _) = [] - - --- | Reasons why instructions might be inserted by the spiller. --- Used when generating stats for -ddrop-asm-stats. --- -data SpillReason - -- | vreg was spilled to a slot so we could use its - -- current hreg for another vreg - = SpillAlloc !Unique - - -- | vreg was moved because its hreg was clobbered - | SpillClobber !Unique - - -- | vreg was loaded from a spill slot - | SpillLoad !Unique - - -- | reg-reg move inserted during join to targets - | SpillJoinRR !Unique - - -- | reg-mem move inserted during join to targets - | SpillJoinRM !Unique - - --- | Used to carry interesting stats out of the register allocator. -data RegAllocStats - = RegAllocStats - { ra_spillInstrs :: UniqFM [Int] - , ra_fixupList :: [(BlockId,BlockId,BlockId)] - -- ^ (from,fixup,to) : We inserted fixup code between from and to - } - - --- | The register allocator state -data RA_State freeRegs - = RA_State - - { - -- | the current mapping from basic blocks to - -- the register assignments at the beginning of that block. - ra_blockassig :: BlockAssignment freeRegs - - -- | free machine registers - , ra_freeregs :: !freeRegs - - -- | assignment of temps to locations - , ra_assig :: RegMap Loc - - -- | current stack delta - , ra_delta :: Int - - -- | free stack slots for spilling - , ra_stack :: StackMap - - -- | unique supply for generating names for join point fixup blocks. - , ra_us :: UniqSupply - - -- | Record why things were spilled, for -ddrop-asm-stats. - -- Just keep a list here instead of a map of regs -> reasons. - -- We don't want to slow down the allocator if we're not going to emit the stats. - , ra_spills :: [SpillReason] - , ra_DynFlags :: DynFlags - - -- | (from,fixup,to) : We inserted fixup code between from and to - , ra_fixups :: [(BlockId,BlockId,BlockId)] } - - diff --git a/nativeGen/RegAlloc/Linear/FreeRegs.hs b/nativeGen/RegAlloc/Linear/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE CPP #-} - -module RegAlloc.Linear.FreeRegs ( - FR(..), - maxSpillSlots -) - -#include "HsVersions.h" - -where - -import GhcPrelude - -import Reg -import RegClass - -import DynFlags -import Panic -import GHC.Platform - --- ----------------------------------------------------------------------------- --- The free register set --- This needs to be *efficient* --- Here's an inefficient 'executable specification' of the FreeRegs data type: --- --- type FreeRegs = [RegNo] --- noFreeRegs = 0 --- releaseReg n f = if n `elem` f then f else (n : f) --- initFreeRegs = allocatableRegs --- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f --- allocateReg f r = filter (/= r) f - -import qualified RegAlloc.Linear.PPC.FreeRegs as PPC -import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC -import qualified RegAlloc.Linear.X86.FreeRegs as X86 -import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 - -import qualified PPC.Instr -import qualified SPARC.Instr -import qualified X86.Instr - -class Show freeRegs => FR freeRegs where - frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs - frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] - frInitFreeRegs :: Platform -> freeRegs - frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs - -instance FR X86.FreeRegs where - frAllocateReg = \_ -> X86.allocateReg - frGetFreeRegs = X86.getFreeRegs - frInitFreeRegs = X86.initFreeRegs - frReleaseReg = \_ -> X86.releaseReg - -instance FR X86_64.FreeRegs where - frAllocateReg = \_ -> X86_64.allocateReg - frGetFreeRegs = X86_64.getFreeRegs - frInitFreeRegs = X86_64.initFreeRegs - frReleaseReg = \_ -> X86_64.releaseReg - -instance FR PPC.FreeRegs where - frAllocateReg = \_ -> PPC.allocateReg - frGetFreeRegs = \_ -> PPC.getFreeRegs - frInitFreeRegs = PPC.initFreeRegs - frReleaseReg = \_ -> PPC.releaseReg - -instance FR SPARC.FreeRegs where - frAllocateReg = SPARC.allocateReg - frGetFreeRegs = \_ -> SPARC.getFreeRegs - frInitFreeRegs = SPARC.initFreeRegs - frReleaseReg = SPARC.releaseReg - -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = case platformArch (targetPlatform dflags) of - ArchX86 -> X86.Instr.maxSpillSlots dflags - ArchX86_64 -> X86.Instr.maxSpillSlots dflags - ArchPPC -> PPC.Instr.maxSpillSlots dflags - ArchS390X -> panic "maxSpillSlots ArchS390X" - ArchSPARC -> SPARC.Instr.maxSpillSlots dflags - ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" - ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" - ArchAArch64 -> panic "maxSpillSlots ArchAArch64" - ArchPPC_64 _ -> PPC.Instr.maxSpillSlots dflags - ArchAlpha -> panic "maxSpillSlots ArchAlpha" - ArchMipseb -> panic "maxSpillSlots ArchMipseb" - ArchMipsel -> panic "maxSpillSlots ArchMipsel" - ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" - ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/nativeGen/RegAlloc/Linear/JoinToTargets.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ /dev/null @@ -1,377 +0,0 @@ - --- | Handles joining of a jump instruction to its targets. - --- The first time we encounter a jump to a particular basic block, we --- record the assignment of temporaries. The next time we encounter a --- jump to the same block, we compare our current assignment to the --- stored one. They might be different if spilling has occurred in one --- branch; so some fixup code will be required to match up the assignments. --- -module RegAlloc.Linear.JoinToTargets (joinToTargets) where - -import GhcPrelude - -import RegAlloc.Linear.State -import RegAlloc.Linear.Base -import RegAlloc.Linear.FreeRegs -import RegAlloc.Liveness -import Instruction -import Reg - -import BlockId -import Hoopl.Collections -import Digraph -import DynFlags -import Outputable -import Unique -import UniqFM -import UniqSet - --- | For a jump instruction at the end of a block, generate fixup code so its --- vregs are in the correct regs for its destination. --- -joinToTargets - :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs - -- that are known to be live on the entry to each block. - - -> BlockId -- ^ id of the current block - -> instr -- ^ branch instr on the end of the source block. - - -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. - , instr) -- the original branch - -- instruction, but maybe - -- patched to jump - -- to a fixup block first. - -joinToTargets block_live id instr - - -- we only need to worry about jump instructions. - | not $ isJumpishInstr instr - = return ([], instr) - - | otherwise - = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) - ------ -joinToTargets' - :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs - -- that are known to be live on the entry to each block. - - -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. - - -> BlockId -- ^ id of the current block - -> instr -- ^ branch instr on the end of the source block. - - -> [BlockId] -- ^ branch destinations still to consider. - - -> RegM freeRegs ([NatBasicBlock instr], instr) - --- no more targets to consider. all done. -joinToTargets' _ new_blocks _ instr [] - = return (new_blocks, instr) - --- handle a branch target. -joinToTargets' block_live new_blocks block_id instr (dest:dests) - = do - -- get the map of where the vregs are stored on entry to each basic block. - block_assig <- getBlockAssigR - - -- get the assignment on entry to the branch instruction. - assig <- getAssigR - - -- adjust the current assignment to remove any vregs that are not live - -- on entry to the destination block. - let Just live_set = mapLookup dest block_live - let still_live uniq _ = uniq `elemUniqSet_Directly` live_set - let adjusted_assig = filterUFM_Directly still_live assig - - -- and free up those registers which are now free. - let to_free = - [ r | (reg, loc) <- nonDetUFMToList assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , not (elemUniqSet_Directly reg live_set) - , r <- regsOfLoc loc ] - - case mapLookup dest block_assig of - Nothing - -> joinToTargets_first - block_live new_blocks block_id instr dest dests - block_assig adjusted_assig to_free - - Just (_, dest_assig) - -> joinToTargets_again - block_live new_blocks block_id instr dest dests - adjusted_assig dest_assig - - --- this is the first time we jumped to this block. -joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet - -> [NatBasicBlock instr] - -> BlockId - -> instr - -> BlockId - -> [BlockId] - -> BlockAssignment freeRegs - -> RegMap Loc - -> [RealReg] - -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first block_live new_blocks block_id instr dest dests - block_assig src_assig - to_free - - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - -- free up the regs that are not live on entry to this block. - freeregs <- getFreeRegsR - let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free - - -- remember the current assignment on entry to this block. - setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) - - joinToTargets' block_live new_blocks block_id instr dests - - --- we've jumped to this block before -joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr) - => BlockMap RegSet - -> [NatBasicBlock instr] - -> BlockId - -> instr - -> BlockId - -> [BlockId] - -> UniqFM Loc - -> UniqFM Loc - -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_again - block_live new_blocks block_id instr dest dests - src_assig dest_assig - - -- the assignments already match, no problem. - | nonDetUFMToList dest_assig == nonDetUFMToList src_assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - = joinToTargets' block_live new_blocks block_id instr dests - - -- assignments don't match, need fixup code - | otherwise - = do - - -- make a graph of what things need to be moved where. - let graph = makeRegMovementGraph src_assig dest_assig - - -- look for cycles in the graph. This can happen if regs need to be swapped. - -- Note that we depend on the fact that this function does a - -- bottom up traversal of the tree-like portions of the graph. - -- - -- eg, if we have - -- R1 -> R2 -> R3 - -- - -- ie move value in R1 to R2 and value in R2 to R3. - -- - -- We need to do the R2 -> R3 move before R1 -> R2. - -- - let sccs = stronglyConnCompFromEdgedVerticesOrdR graph - - -- debugging - {- - pprTrace - ("joinToTargets: making fixup code") - (vcat [ text " in block: " <> ppr block_id - , text " jmp instruction: " <> ppr instr - , text " src assignment: " <> ppr src_assig - , text " dest assignment: " <> ppr dest_assig - , text " movement graph: " <> ppr graph - , text " sccs of graph: " <> ppr sccs - , text ""]) - (return ()) - -} - delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs - let fixUpInstrs = concat fixUpInstrs_ - - -- make a new basic block containing the fixup code. - -- A the end of the current block we will jump to the fixup one, - -- then that will jump to our original destination. - fixup_block_id <- mkBlockId <$> getUniqueR - let block = BasicBlock fixup_block_id - $ fixUpInstrs ++ mkJumpInstr dest - - -- if we didn't need any fixups, then don't include the block - case fixUpInstrs of - [] -> joinToTargets' block_live new_blocks block_id instr dests - - -- patch the original branch instruction so it goes to our - -- fixup block instead. - _ -> let instr' = patchJumpInstr instr - (\bid -> if bid == dest - then fixup_block_id - else bid) -- no change! - - in do - {- --debugging - pprTrace "FixUpEdge info:" - ( - text "inBlock:" <> ppr block_id $$ - text "instr:" <> ppr instr $$ - text "instr':" <> ppr instr' $$ - text "fixup_block_id':" <> - ppr fixup_block_id $$ - text "dest:" <> ppr dest - ) (return ()) - -} - recordFixupBlock block_id fixup_block_id dest - joinToTargets' block_live (block : new_blocks) - block_id instr' dests - - --- | Construct a graph of register\/spill movements. --- --- Cyclic components seem to occur only very rarely. --- --- We cut some corners by not handling memory-to-memory moves. --- This shouldn't happen because every temporary gets its own stack slot. --- -makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique] -makeRegMovementGraph adjusted_assig dest_assig - = [ node | (vreg, src) <- nonDetUFMToList adjusted_assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - -- source reg might not be needed at the dest: - , Just loc <- [lookupUFM_Directly dest_assig vreg] - , node <- expandNode vreg src loc ] - - --- | Expand out the destination, so InBoth destinations turn into --- a combination of InReg and InMem. - --- The InBoth handling is a little tricky here. If the destination is --- InBoth, then we must ensure that the value ends up in both locations. --- An InBoth destination must conflict with an InReg or InMem source, so --- we expand an InBoth destination as necessary. --- --- An InBoth source is slightly different: we only care about the register --- that the source value is in, so that we can move it to the destinations. --- -expandNode - :: a - -> Loc -- ^ source of move - -> Loc -- ^ destination of move - -> [Node Loc a ] - -expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [DigraphNode vreg loc [InMem mem]] - | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] - -expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [DigraphNode vreg loc [InReg dst]] - | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] - -expandNode _ (InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true - -expandNode _ (InBoth src _) (InReg dst) - | src == dst = [] - -expandNode vreg (InBoth src _) dst - = expandNode vreg (InReg src) dst - -expandNode vreg src dst - | src == dst = [] - | otherwise = [DigraphNode vreg src [dst]] - - --- | Generate fixup code for a particular component in the move graph --- This component tells us what values need to be moved to what --- destinations. We have eliminated any possibility of single-node --- cycles in expandNode above. --- -handleComponent - :: Instruction instr - => Int -> instr -> SCC (Node Loc Unique) - -> RegM freeRegs [instr] - --- If the graph is acyclic then we won't get the swapping problem below. --- In this case we can just do the moves directly, and avoid having to --- go via a spill slot. --- -handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts)) - = mapM (makeMove delta vreg src) dsts - - --- Handle some cyclic moves. --- This can happen if we have two regs that need to be swapped. --- eg: --- vreg source loc dest loc --- (vreg1, InReg r1, [InReg r2]) --- (vreg2, InReg r2, [InReg r1]) --- --- To avoid needing temp register, we just spill all the source regs, then --- reaload them into their destination regs. --- --- Note that we can not have cycles that involve memory locations as --- sources as single destination because memory locations (stack slots) --- are allocated exclusively for a virtual register and therefore can not --- require a fixup. --- -handleComponent delta instr - (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest)) - -- dest list may have more than one element, if the reg is also InMem. - = do - -- spill the source into its slot - (instrSpill, slot) - <- spillR (RegReal sreg) vreg - - -- reload into destination reg - instrLoad <- loadR (RegReal dreg) slot - - remainingFixUps <- mapM (handleComponent delta instr) - (stronglyConnCompFromEdgedVerticesOrdR rest) - - -- make sure to do all the reloads after all the spills, - -- so we don't end up clobbering the source values. - return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) - -handleComponent _ _ (CyclicSCC _) - = panic "Register Allocator: handleComponent cyclic" - - --- | Move a vreg between these two locations. --- -makeMove - :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs instr -- ^ move instruction. - -makeMove delta vreg src dst - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - case (src, dst) of - (InReg s, InReg d) -> - do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) - (InMem s, InReg d) -> - do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr dflags (RegReal d) delta s - (InReg s, InMem d) -> - do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr dflags (RegReal s) delta d - _ -> - -- we don't handle memory to memory moves. - -- they shouldn't happen because we don't share - -- stack slots between vregs. - panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " we don't handle mem->mem moves.") - diff --git a/nativeGen/RegAlloc/Linear/Main.hs b/nativeGen/RegAlloc/Linear/Main.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/Main.hs +++ /dev/null @@ -1,917 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- --- The register allocator --- --- (c) The University of Glasgow 2004 --- ------------------------------------------------------------------------------ - -{- -The algorithm is roughly: - - 1) Compute strongly connected components of the basic block list. - - 2) Compute liveness (mapping from pseudo register to - point(s) of death?). - - 3) Walk instructions in each basic block. We keep track of - (a) Free real registers (a bitmap?) - (b) Current assignment of temporaries to machine registers and/or - spill slots (call this the "assignment"). - (c) Partial mapping from basic block ids to a virt-to-loc mapping. - When we first encounter a branch to a basic block, - we fill in its entry in this table with the current mapping. - - For each instruction: - (a) For each temporary *read* by the instruction: - If the temporary does not have a real register allocation: - - Allocate a real register from the free list. If - the list is empty: - - Find a temporary to spill. Pick one that is - not used in this instruction (ToDo: not - used for a while...) - - generate a spill instruction - - If the temporary was previously spilled, - generate an instruction to read the temp from its spill loc. - (optimisation: if we can see that a real register is going to - be used soon, then don't use it for allocation). - - (b) For each real register clobbered by this instruction: - If a temporary resides in it, - If the temporary is live after this instruction, - Move the temporary to another (non-clobbered & free) reg, - or spill it to memory. Mark the temporary as residing - in both memory and a register if it was spilled (it might - need to be read by this instruction). - - (ToDo: this is wrong for jump instructions?) - - We do this after step (a), because if we start with - movq v1, %rsi - which is an instruction that clobbers %rsi, if v1 currently resides - in %rsi we want to get - movq %rsi, %freereg - movq %rsi, %rsi -- will disappear - instead of - movq %rsi, %freereg - movq %freereg, %rsi - - (c) Update the current assignment - - (d) If the instruction is a branch: - if the destination block already has a register assignment, - Generate a new block with fixup code and redirect the - jump to the new block. - else, - Update the block id->assignment mapping with the current - assignment. - - (e) Delete all register assignments for temps which are read - (only) and die here. Update the free register list. - - (f) Mark all registers clobbered by this instruction as not free, - and mark temporaries which have been spilled due to clobbering - as in memory (step (a) marks then as in both mem & reg). - - (g) For each temporary *written* by this instruction: - Allocate a real register as for (b), spilling something - else if necessary. - - except when updating the assignment, drop any memory - locations that the temporary was previously in, since - they will be no longer valid after this instruction. - - (h) Delete all register assignments for temps which are - written and die here (there should rarely be any). Update - the free register list. - - (i) Rewrite the instruction with the new mapping. - - (j) For each spilled reg known to be now dead, re-add its stack slot - to the free list. - --} - -module RegAlloc.Linear.Main ( - regAlloc, - module RegAlloc.Linear.Base, - module RegAlloc.Linear.Stats - ) where - -#include "HsVersions.h" - - -import GhcPrelude - -import RegAlloc.Linear.State -import RegAlloc.Linear.Base -import RegAlloc.Linear.StackMap -import RegAlloc.Linear.FreeRegs -import RegAlloc.Linear.Stats -import RegAlloc.Linear.JoinToTargets -import qualified RegAlloc.Linear.PPC.FreeRegs as PPC -import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC -import qualified RegAlloc.Linear.X86.FreeRegs as X86 -import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 -import TargetReg -import RegAlloc.Liveness -import Instruction -import Reg - -import BlockId -import Hoopl.Collections -import Cmm hiding (RegSet) - -import Digraph -import DynFlags -import Unique -import UniqSet -import UniqFM -import UniqSupply -import Outputable -import GHC.Platform - -import Data.Maybe -import Data.List -import Control.Monad - --- ----------------------------------------------------------------------------- --- Top level of the register allocator - --- Allocate registers -regAlloc - :: (Outputable instr, Instruction instr) - => DynFlags - -> LiveCmmDecl statics instr - -> UniqSM ( NatCmmDecl statics instr - , Maybe Int -- number of extra stack slots required, - -- beyond maxSpillSlots - , Maybe RegAllocStats - ) - -regAlloc _ (CmmData sec d) - = return - ( CmmData sec d - , Nothing - , Nothing ) - -regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) - = return ( CmmProc info lbl live (ListGraph []) - , Nothing - , Nothing ) - -regAlloc dflags (CmmProc static lbl live sccs) - | LiveInfo info entry_ids@(first_id:_) block_live _ <- static - = do - -- do register allocation on each component. - (final_blocks, stats, stack_use) - <- linearRegAlloc dflags entry_ids block_live sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output - let ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks - - let max_spill_slots = maxSpillSlots dflags - extra_stack - | stack_use > max_spill_slots - = Just (stack_use - max_spill_slots) - | otherwise - = Nothing - - return ( CmmProc info lbl live (ListGraph (first' : rest')) - , extra_stack - , Just stats) - --- bogus. to make non-exhaustive match warning go away. -regAlloc _ (CmmProc _ _ _ _) - = panic "RegAllocLinear.regAlloc: no match" - - --- ----------------------------------------------------------------------------- --- Linear sweep to allocate registers - - --- | Do register allocation on some basic blocks. --- But be careful to allocate a block in an SCC only if it has --- an entry in the block map or it is the first block. --- -linearRegAlloc - :: (Outputable instr, Instruction instr) - => DynFlags - -> [BlockId] -- ^ entry points - -> BlockMap RegSet - -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] - -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) - -linearRegAlloc dflags entry_ids block_live sccs - = case platformArch platform of - ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) - ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) - ArchS390X -> panic "linearRegAlloc ArchS390X" - ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) - ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64" - ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) - ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" - ArchAArch64 -> panic "linearRegAlloc ArchAArch64" - ArchPPC_64 _ -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) - ArchAlpha -> panic "linearRegAlloc ArchAlpha" - ArchMipseb -> panic "linearRegAlloc ArchMipseb" - ArchMipsel -> panic "linearRegAlloc ArchMipsel" - ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" - where - go f = linearRegAlloc' dflags f entry_ids block_live sccs - platform = targetPlatform dflags - -linearRegAlloc' - :: (FR freeRegs, Outputable instr, Instruction instr) - => DynFlags - -> freeRegs - -> [BlockId] -- ^ entry points - -> BlockMap RegSet -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) - -linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs - = do us <- getUniqueSupplyM - let (_, stack, stats, blocks) = - runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us - $ linearRA_SCCs entry_ids block_live [] sccs - return (blocks, stats, getStackUse stack) - - -linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => [BlockId] - -> BlockMap RegSet - -> [NatBasicBlock instr] - -> [SCC (LiveBasicBlock instr)] - -> RegM freeRegs [NatBasicBlock instr] - -linearRA_SCCs _ _ blocksAcc [] - = return $ reverse blocksAcc - -linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock block_live block - linearRA_SCCs entry_ids block_live - ((reverse blocks') ++ blocksAcc) - sccs - -linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) - = do - blockss' <- process entry_ids block_live blocks [] (return []) False - linearRA_SCCs entry_ids block_live - (reverse (concat blockss') ++ blocksAcc) - sccs - -{- from John Dias's patch 2008/10/16: - The linear-scan allocator sometimes allocates a block - before allocating one of its predecessors, which could lead to - inconsistent allocations. Make it so a block is only allocated - if a predecessor has set the "incoming" assignments for the block, or - if it's the procedure's entry block. - - BL 2009/02: Careful. If the assignment for a block doesn't get set for - some reason then this function will loop. We should probably do some - more sanity checking to guard against this eventuality. --} - -process :: (FR freeRegs, Instruction instr, Outputable instr) - => [BlockId] - -> BlockMap RegSet - -> [GenBasicBlock (LiveInstr instr)] - -> [GenBasicBlock (LiveInstr instr)] - -> [[NatBasicBlock instr]] - -> Bool - -> RegM freeRegs [[NatBasicBlock instr]] - -process _ _ [] [] accum _ - = return $ reverse accum - -process entry_ids block_live [] next_round accum madeProgress - | not madeProgress - - {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. - pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." - ( text "Unreachable blocks:" - $$ vcat (map ppr next_round)) -} - = return $ reverse accum - - | otherwise - = process entry_ids block_live - next_round [] accum False - -process entry_ids block_live (b@(BasicBlock id _) : blocks) - next_round accum madeProgress - = do - block_assig <- getBlockAssigR - - if isJust (mapLookup id block_assig) - || id `elem` entry_ids - then do - b' <- processBlock block_live b - process entry_ids block_live blocks - next_round (b' : accum) True - - else process entry_ids block_live blocks - (b : next_round) accum madeProgress - - --- | Do register allocation on this basic block --- -processBlock - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ live regs on entry to each basic block - -> LiveBasicBlock instr -- ^ block to do register allocation on - -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated - -processBlock block_live (BasicBlock id instrs) - = do initBlock id block_live - (instrs', fixups) - <- linearRA block_live [] [] id instrs - return $ BasicBlock id instrs' : fixups - - --- | Load the freeregs and current reg assignment into the RegM state --- for the basic block with this BlockId. -initBlock :: FR freeRegs - => BlockId -> BlockMap RegSet -> RegM freeRegs () -initBlock id block_live - = do dflags <- getDynFlags - let platform = targetPlatform dflags - block_assig <- getBlockAssigR - case mapLookup id block_assig of - -- no prior info about this block: we must consider - -- any fixed regs to be allocated, but we can ignore - -- virtual regs (presumably this is part of a loop, - -- and we'll iterate again). The assignment begins - -- empty. - Nothing - -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) - case mapLookup id block_live of - Nothing -> - setFreeRegsR (frInitFreeRegs platform) - Just live -> - setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) - [ r | RegReal r <- nonDetEltsUniqSet live ] - -- See Note [Unique Determinism and code generation] - setAssigR emptyRegMap - - -- load info about register assignments leading into this block. - Just (freeregs, assig) - -> do setFreeRegsR freeregs - setAssigR assig - - --- | Do allocation for a sequence of instructions. -linearRA - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. - -> [instr] -- ^ accumulator for instructions already processed. - -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. - -> BlockId -- ^ id of the current block, for debugging. - -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. - - -> RegM freeRegs - ( [instr] -- instructions after register allocation - , [NatBasicBlock instr]) -- fresh blocks of fixup code. - - -linearRA _ accInstr accFixup _ [] - = return - ( reverse accInstr -- instrs need to be returned in the correct order. - , accFixup) -- it doesn't matter what order the fixup blocks are returned in. - - -linearRA block_live accInstr accFixups id (instr:instrs) - = do - (accInstr', new_fixups) <- raInsn block_live accInstr id instr - - linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs - - --- | Do allocation for a single instruction. -raInsn - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. - -> [instr] -- ^ accumulator for instructions already processed. - -> BlockId -- ^ the id of the current block, for debugging - -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. - -> RegM freeRegs - ( [instr] -- new instructions - , [NatBasicBlock instr]) -- extra fixup blocks - -raInsn _ new_instrs _ (LiveInstr ii Nothing) - | Just n <- takeDeltaInstr ii - = do setDeltaR n - return (new_instrs, []) - -raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing) - | isMetaInstr ii - = return (i : new_instrs, []) - - -raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) - = do - assig <- getAssigR - - -- If we have a reg->reg move between virtual registers, where the - -- src register is not live after this instruction, and the dst - -- register does not already have an assignment, - -- and the source register is assigned to a register, not to a spill slot, - -- then we can eliminate the instruction. - -- (we can't eliminate it if the source register is on the stack, because - -- we do not want to use one spill slot for different virtual registers) - case takeRegRegMoveInstr instr of - Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), - isVirtualReg dst, - not (dst `elemUFM` assig), - isRealReg src || isInReg src assig -> do - case src of - (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) - -- if src is a fixed reg, then we just map dest to this - -- reg in the assignment. src must be an allocatable reg, - -- otherwise it wouldn't be in r_dying. - _virt -> case lookupUFM assig src of - Nothing -> panic "raInsn" - Just loc -> - setAssigR (addToUFM (delFromUFM assig src) dst loc) - - -- we have eliminated this instruction - {- - freeregs <- getFreeRegsR - assig <- getAssigR - pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) - $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do - -} - return (new_instrs, []) - - _ -> genRaInsn block_live new_instrs id instr - (nonDetEltsUniqSet $ liveDieRead live) - (nonDetEltsUniqSet $ liveDieWrite live) - -- See Note [Unique Determinism and code generation] - -raInsn _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> ppr instr) - --- ToDo: what can we do about --- --- R1 = x --- jump I64[x] // [R1] --- --- where x is mapped to the same reg as R1. We want to coalesce x and --- R1, but the register allocator doesn't know whether x will be --- assigned to again later, in which case x and R1 should be in --- different registers. Right now we assume the worst, and the --- assignment to R1 will clobber x, so we'll spill x into another reg, --- generating another reg->reg move. - - -isInReg :: Reg -> RegMap Loc -> Bool -isInReg src assig | Just (InReg _) <- lookupUFM assig src = True - | otherwise = False - - -genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet - -> [instr] - -> BlockId - -> instr - -> [Reg] - -> [Reg] - -> RegM freeRegs ([instr], [NatBasicBlock instr]) - -genRaInsn block_live new_instrs block_id instr r_dying w_dying = do - dflags <- getDynFlags - let platform = targetPlatform dflags - case regUsageOfInstr platform instr of { RU read written -> - do - let real_written = [ rr | (RegReal rr) <- written ] - let virt_written = [ vr | (RegVirtual vr) <- written ] - - -- we don't need to do anything with real registers that are - -- only read by this instr. (the list is typically ~2 elements, - -- so using nub isn't a problem). - let virt_read = nub [ vr | (RegVirtual vr) <- read ] - - -- debugging -{- freeregs <- getFreeRegsR - assig <- getAssigR - pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn" - (ppr instr - $$ text "r_dying = " <+> ppr r_dying - $$ text "w_dying = " <+> ppr w_dying - $$ text "virt_read = " <+> ppr virt_read - $$ text "virt_written = " <+> ppr virt_written - $$ text "freeregs = " <+> text (show freeregs) - $$ text "assig = " <+> ppr assig) - $ do --} - - -- (a), (b) allocate real regs for all regs read by this instruction. - (r_spills, r_allocd) <- - allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read - - -- (c) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying - - -- (d) Update block map for new destinations - -- NB. do this before removing dead regs from the assignment, because - -- these dead regs might in fact be live in the jump targets (they're - -- only dead in the code that follows in the current basic block). - (fixup_blocks, adjusted_instr) - <- joinToTargets block_live block_id instr - - -- Debugging - show places where the reg alloc inserted - -- assignment fixup blocks. - -- when (not $ null fixup_blocks) $ - -- pprTrace "fixup_blocks" (ppr fixup_blocks) (return ()) - - -- (e) Delete all register assignments for temps which are read - -- (only) and die here. Update the free register list. - releaseRegs r_dying - - -- (f) Mark regs which are clobbered as unallocatable - clobberRegs real_written - - -- (g) Allocate registers for temporaries *written* (only) - (w_spills, w_allocd) <- - allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written - - -- (h) Release registers for temps which are written here and not - -- used again. - releaseRegs w_dying - - let - -- (i) Patch the instruction - patch_map - = listToUFM - [ (t, RegReal r) - | (t, r) <- zip virt_read r_allocd - ++ zip virt_written w_allocd ] - - patched_instr - = patchRegsOfInstr adjusted_instr patchLookup - - patchLookup x - = case lookupUFM patch_map x of - Nothing -> x - Just y -> y - - - -- (j) free up stack slots for dead spilled regs - -- TODO (can't be bothered right now) - - -- erase reg->reg moves where the source and destination are the same. - -- If the src temp didn't die in this instr but happened to be allocated - -- to the same real reg as the destination, then we can erase the move anyway. - let squashed_instr = case takeRegRegMoveInstr patched_instr of - Just (src, dst) - | src == dst -> [] - _ -> [patched_instr] - - let code = squashed_instr ++ w_spills ++ reverse r_spills - ++ clobber_saves ++ new_instrs - --- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do --- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do - - return (code, fixup_blocks) - - } - --- ----------------------------------------------------------------------------- --- releaseRegs - -releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () -releaseRegs regs = do - dflags <- getDynFlags - let platform = targetPlatform dflags - assig <- getAssigR - free <- getFreeRegsR - let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs - loop assig !free (r:rs) = - case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs - Just (InReg real) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs - _ -> loop (delFromUFM assig r) free rs - loop assig free regs - - --- ----------------------------------------------------------------------------- --- Clobber real registers - --- For each temp in a register that is going to be clobbered: --- - if the temp dies after this instruction, do nothing --- - otherwise, put it somewhere safe (another reg if possible, --- otherwise spill and record InBoth in the assignment). --- - for allocateRegs on the temps *read*, --- - clobbered regs are allocatable. --- --- for allocateRegs on the temps *written*, --- - clobbered regs are not allocatable. --- - -saveClobberedTemps - :: (Instruction instr, FR freeRegs) - => [RealReg] -- real registers clobbered by this instruction - -> [Reg] -- registers which are no longer live after this insn - -> RegM freeRegs [instr] -- return: instructions to spill any temps that will - -- be clobbered. - -saveClobberedTemps [] _ - = return [] - -saveClobberedTemps clobbered dying - = do - assig <- getAssigR - let to_spill - = [ (temp,reg) - | (temp, InReg reg) <- nonDetUFMToList assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , any (realRegsAlias reg) clobbered - , temp `notElem` map getUnique dying ] - - (instrs,assig') <- clobber assig [] to_spill - setAssigR assig' - return instrs - - where - clobber assig instrs [] - = return (instrs, assig) - - clobber assig instrs ((temp, reg) : rest) - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - freeRegs <- getFreeRegsR - let regclass = targetClassOfRealReg platform reg - freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs - - case filter (`notElem` clobbered) freeRegs_thisClass of - - -- (1) we have a free reg of the right class that isn't - -- clobbered by this instruction; use it to save the - -- clobbered value. - (my_reg : _) -> do - setFreeRegsR (frAllocateReg platform my_reg freeRegs) - - let new_assign = addToUFM assig temp (InReg my_reg) - let instr = mkRegRegMoveInstr platform - (RegReal reg) (RegReal my_reg) - - clobber new_assign (instr : instrs) rest - - -- (2) no free registers: spill the value - [] -> do - (spill, slot) <- spillR (RegReal reg) temp - - -- record why this reg was spilled for profiling - recordSpill (SpillClobber temp) - - let new_assign = addToUFM assig temp (InBoth reg slot) - - clobber new_assign (spill : instrs) rest - - - --- | Mark all these real regs as allocated, --- and kick out their vreg assignments. --- -clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () -clobberRegs [] - = return () - -clobberRegs clobbered - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - freeregs <- getFreeRegsR - setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered - - assig <- getAssigR - setAssigR $! clobber assig (nonDetUFMToList assig) - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - where - -- if the temp was InReg and clobbered, then we will have - -- saved it in saveClobberedTemps above. So the only case - -- we have to worry about here is InBoth. Note that this - -- also catches temps which were loaded up during allocation - -- of read registers, not just those saved in saveClobberedTemps. - - clobber assig [] - = assig - - clobber assig ((temp, InBoth reg slot) : rest) - | any (realRegsAlias reg) clobbered - = clobber (addToUFM assig temp (InMem slot)) rest - - clobber assig (_:rest) - = clobber assig rest - --- ----------------------------------------------------------------------------- --- allocateRegsAndSpill - --- Why are we performing a spill? -data SpillLoc = ReadMem StackSlot -- reading from register only in memory - | WriteNew -- writing to a new variable - | WriteMem -- writing to register only in memory --- Note that ReadNew is not valid, since you don't want to be reading --- from an uninitialized register. We also don't need the location of --- the register in memory, since that will be invalidated by the write. --- Technically, we could coalesce WriteNew and WriteMem into a single --- entry as well. -- EZY - --- This function does several things: --- For each temporary referred to by this instruction, --- we allocate a real register (spilling another temporary if necessary). --- We load the temporary up from memory if necessary. --- We also update the register assignment in the process, and --- the list of free registers and free stack slots. - -allocateRegsAndSpill - :: (FR freeRegs, Outputable instr, Instruction instr) - => Bool -- True <=> reading (load up spilled regs) - -> [VirtualReg] -- don't push these out - -> [instr] -- spill insns - -> [RealReg] -- real registers allocated (accum.) - -> [VirtualReg] -- temps to allocate - -> RegM freeRegs ( [instr] , [RealReg]) - -allocateRegsAndSpill _ _ spills alloc [] - = return (spills, reverse alloc) - -allocateRegsAndSpill reading keep spills alloc (r:rs) - = do assig <- getAssigR - let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig - case lookupUFM assig r of - -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignment to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg _) - -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- Not already in a register, so we need to find a free one... - Just (InMem slot) | reading -> doSpill (ReadMem slot) - | otherwise -> doSpill WriteMem - Nothing | reading -> - pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) - -- NOTE: if the input to the NCG contains some - -- unreachable blocks with junk code, this panic - -- might be triggered. Make sure you only feed - -- sensible code into the NCG. In CmmPipeline we - -- call removeUnreachableBlocks at the end for this - -- reason. - - | otherwise -> doSpill WriteNew - - --- reading is redundant with reason, but we keep it around because it's --- convenient and it maintains the recursive structure of the allocator. -- EZY -allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) - => Bool - -> [VirtualReg] - -> [instr] - -> [RealReg] - -> VirtualReg - -> [VirtualReg] - -> UniqFM Loc - -> SpillLoc - -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc - = do dflags <- getDynFlags - let platform = targetPlatform dflags - freeRegs <- getFreeRegsR - let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs - - case freeRegs_thisClass of - - -- case (2): we have a free register - (my_reg : _) -> - do spills' <- loadTemp r spill_loc my_reg spills - - setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) - setFreeRegsR $ frAllocateReg platform my_reg freeRegs - - allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs - - - -- case (3): we need to push something out to free up a register - [] -> - do let inRegOrBoth (InReg _) = True - inRegOrBoth (InBoth _ _) = True - inRegOrBoth _ = False - let candidates' = - flip delListFromUFM keep $ - filterUFM inRegOrBoth $ - assig - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - let candidates = nonDetUFMToList candidates' - - -- the vregs we could kick out that are already in a slot - let candidates_inBoth - = [ (temp, reg, mem) - | (temp, InBoth reg mem) <- candidates - , targetClassOfRealReg platform reg == classOfVirtualReg r ] - - -- the vregs we could kick out that are only in a reg - -- this would require writing the reg to a new slot before using it. - let candidates_inReg - = [ (temp, reg) - | (temp, InReg reg) <- candidates - , targetClassOfRealReg platform reg == classOfVirtualReg r ] - - let result - - -- we have a temporary that is in both register and mem, - -- just free up its register for use. - | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp r spill_loc my_reg spills - let assig1 = addToUFM assig temp (InMem slot) - let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg - - setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- otherwise, we need to spill a temporary that currently - -- resides in a register. - | (temp_to_push_out, (my_reg :: RealReg)) : _ - <- candidates_inReg - = do - (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out - let spill_store = (if reading then id else reverse) - [ -- COMMENT (fsLit "spill alloc") - spill_insn ] - - -- record that this temp was spilled - recordSpill (SpillAlloc temp_to_push_out) - - -- update the register assignment - let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg - setAssigR assig2 - - -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp r spill_loc my_reg spills - - allocateRegsAndSpill reading keep - (spill_store ++ spills') - (my_reg:alloc) rs - - - -- there wasn't anything to spill, so we're screwed. - | otherwise - = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") - $ vcat - [ text "allocating vreg: " <> text (show r) - , text "assignment: " <> ppr assig - , text "freeRegs: " <> text (show freeRegs) - , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] - - result - - --- | Calculate a new location after a register has been loaded. -newLocation :: SpillLoc -> RealReg -> Loc --- if the tmp was read from a slot, then now its in a reg as well -newLocation (ReadMem slot) my_reg = InBoth my_reg slot --- writes will always result in only the register being available -newLocation _ my_reg = InReg my_reg - --- | Load up a spilled temporary if we need to (read from memory). -loadTemp - :: (Instruction instr) - => VirtualReg -- the temp being loaded - -> SpillLoc -- the current location of this temp - -> RealReg -- the hreg to load the temp into - -> [instr] - -> RegM freeRegs [instr] - -loadTemp vreg (ReadMem slot) hreg spills - = do - insn <- loadR (RegReal hreg) slot - recordSpill (SpillLoad $ getUnique vreg) - return $ {- COMMENT (fsLit "spill load") : -} insn : spills - -loadTemp _ _ _ spills = - return spills diff --git a/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | Free regs map for PowerPC -module RegAlloc.Linear.PPC.FreeRegs -where - -import GhcPrelude - -import PPC.Regs -import RegClass -import Reg - -import Outputable -import GHC.Platform - -import Data.Word -import Data.Bits - --- The PowerPC has 32 integer and 32 floating point registers. --- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much --- better. --- Note that when getFreeRegs scans for free registers, it starts at register --- 31 and counts down. This is a hack for the PowerPC - the higher-numbered --- registers are callee-saves, while the lower regs are caller-saves, so it --- makes sense to start at the high end. --- Apart from that, the code does nothing PowerPC-specific, so feel free to --- add your favourite platform to the #if (if you have 64 registers but only --- 32-bit words). - -data FreeRegs = FreeRegs !Word32 !Word32 - deriving( Show ) -- The Show is used in an ASSERT - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 - -releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle r) (FreeRegs g f) - | r > 31 = FreeRegs g (f .|. (1 `shiftL` (r - 32))) - | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f - -releaseReg _ _ - = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" - -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) - -getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs cls (FreeRegs g f) - | RcDouble <- cls = go f (0x80000000) 63 - | RcInteger <- cls = go g (0x80000000) 31 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) - where - go _ 0 _ = [] - go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1) - | otherwise = go x (m `shiftR` 1) $! i-1 - -allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) (FreeRegs g f) - | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) - | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f - -allocateReg _ _ - = panic "RegAlloc.Linear.PPC.allocateReg: bad reg" diff --git a/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +++ /dev/null @@ -1,187 +0,0 @@ - --- | Free regs map for SPARC -module RegAlloc.Linear.SPARC.FreeRegs -where - -import GhcPrelude - -import SPARC.Regs -import RegClass -import Reg - -import GHC.Platform.Regs -import Outputable -import GHC.Platform - -import Data.Word -import Data.Bits - - --------------------------------------------------------------------------------- --- SPARC is like PPC, except for twinning of floating point regs. --- When we allocate a double reg we must take an even numbered --- float reg, as well as the one after it. - - --- Holds bitmaps showing what registers are currently allocated. --- The float and double reg bitmaps overlap, but we only alloc --- float regs into the float map, and double regs into the double map. --- --- Free regs have a bit set in the corresponding bitmap. --- -data FreeRegs - = FreeRegs - !Word32 -- int reg bitmap regs 0..31 - !Word32 -- float reg bitmap regs 32..63 - !Word32 -- double reg bitmap regs 32..63 - -instance Show FreeRegs where - show = showFreeRegs - --- | A reg map where no regs are free to be allocated. -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 0 - - --- | The initial set of free regs. -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs - - --- | Get all the free registers of this class. -getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs cls (FreeRegs g f d) - | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 - | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 - | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) - where - go _ _ 0 _ - = [] - - go step bitmap mask ix - | bitmap .&. mask /= 0 - = ix : (go step bitmap (mask `shiftL` step) $! ix + step) - - | otherwise - = go step bitmap (mask `shiftL` step) $! ix + step - - --- | Grab a register. -allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -allocateReg platform - reg@(RealRegSingle r) - (FreeRegs g f d) - - -- can't allocate free regs - | not $ freeReg platform r - = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) - - -- a general purpose reg - | r <= 31 - = let mask = complement (bitMask r) - in FreeRegs - (g .&. mask) - f - d - - -- a float reg - | r >= 32, r <= 63 - = let mask = complement (bitMask (r - 32)) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then complement (bitMask (r - 32)) - else complement (bitMask (r - 32 - 1)) - in FreeRegs - g - (f .&. mask) - (d .&. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - -allocateReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = complement (bitMask (r1 - 32)) - mask2 = complement (bitMask (r2 - 32)) - in - FreeRegs - g - ((f .&. mask1) .&. mask2) - (d .&. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - - - --- | Release a register from allocation. --- The register liveness information says that most regs die after a C call, --- but we still don't want to allocate to some of them. --- -releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -releaseReg platform - reg@(RealRegSingle r) - regs@(FreeRegs g f d) - - -- don't release pinned reg - | not $ freeReg platform r - = regs - - -- a general purpose reg - | r <= 31 - = let mask = bitMask r - in FreeRegs (g .|. mask) f d - - -- a float reg - | r >= 32, r <= 63 - = let mask = bitMask (r - 32) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then bitMask (r - 32) - else bitMask (r - 32 - 1) - in FreeRegs - g - (f .|. mask) - (d .|. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - -releaseReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = bitMask (r1 - 32) - mask2 = bitMask (r2 - 32) - in - FreeRegs - g - ((f .|. mask1) .|. mask2) - (d .|. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - - - -bitMask :: Int -> Word32 -bitMask n = 1 `shiftL` n - - -showFreeRegs :: FreeRegs -> String -showFreeRegs regs - = "FreeRegs\n" - ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" - ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" - ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" - diff --git a/nativeGen/RegAlloc/Linear/StackMap.hs b/nativeGen/RegAlloc/Linear/StackMap.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/StackMap.hs +++ /dev/null @@ -1,61 +0,0 @@ - --- | The assignment of virtual registers to stack slots - --- We have lots of stack slots. Memory-to-memory moves are a pain on most --- architectures. Therefore, we avoid having to generate memory-to-memory moves --- by simply giving every virtual register its own stack slot. - --- The StackMap stack map keeps track of virtual register - stack slot --- associations and of which stack slots are still free. Once it has been --- associated, a stack slot is never "freed" or removed from the StackMap again, --- it remains associated until we are done with the current CmmProc. --- -module RegAlloc.Linear.StackMap ( - StackSlot, - StackMap(..), - emptyStackMap, - getStackSlotFor, - getStackUse -) - -where - -import GhcPrelude - -import DynFlags -import UniqFM -import Unique - - --- | Identifier for a stack slot. -type StackSlot = Int - -data StackMap - = StackMap - { -- | The slots that are still available to be allocated. - stackMapNextFreeSlot :: !Int - - -- | Assignment of vregs to stack slots. - , stackMapAssignment :: UniqFM StackSlot } - - --- | An empty stack map, with all slots available. -emptyStackMap :: DynFlags -> StackMap -emptyStackMap _ = StackMap 0 emptyUFM - - --- | If this vreg unique already has a stack assignment then return the slot number, --- otherwise allocate a new slot, and update the map. --- -getStackSlotFor :: StackMap -> Unique -> (StackMap, Int) - -getStackSlotFor fs@(StackMap _ reserved) reg - | Just slot <- lookupUFM reserved reg = (fs, slot) - -getStackSlotFor (StackMap freeSlot reserved) reg = - (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot) - --- | Return the number of stack slots that were allocated -getStackUse :: StackMap -> Int -getStackUse (StackMap freeSlot _) = freeSlot - diff --git a/nativeGen/RegAlloc/Linear/State.hs b/nativeGen/RegAlloc/Linear/State.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/State.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-} - -#if !defined(GHC_LOADED_INTO_GHCI) -{-# LANGUAGE UnboxedTuples #-} -#endif - --- | State monad for the linear register allocator. - --- Here we keep all the state that the register allocator keeps track --- of as it walks the instructions in a basic block. - -module RegAlloc.Linear.State ( - RA_State(..), - RegM, - runR, - - spillR, - loadR, - - getFreeRegsR, - setFreeRegsR, - - getAssigR, - setAssigR, - - getBlockAssigR, - setBlockAssigR, - - setDeltaR, - getDeltaR, - - getUniqueR, - - recordSpill, - recordFixupBlock -) -where - -import GhcPrelude - -import RegAlloc.Linear.Stats -import RegAlloc.Linear.StackMap -import RegAlloc.Linear.Base -import RegAlloc.Liveness -import Instruction -import Reg -import BlockId - -import DynFlags -import Unique -import UniqSupply - -import Control.Monad (ap) - --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - -type RA_Result freeRegs a = (# RA_State freeRegs, a #) - -pattern RA_Result :: a -> b -> (# a, b #) -pattern RA_Result a b = (# a, b #) -{-# COMPLETE RA_Result #-} -#else - -data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a - deriving (Functor) - -#endif - --- | The register allocator monad type. -newtype RegM freeRegs a - = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a } - deriving (Functor) - -instance Applicative (RegM freeRegs) where - pure a = RegM $ \s -> RA_Result s a - (<*>) = ap - -instance Monad (RegM freeRegs) where - m >>= k = RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s } - -instance HasDynFlags (RegM a) where - getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s) - - --- | Run a computation in the RegM register allocator monad. -runR :: DynFlags - -> BlockAssignment freeRegs - -> freeRegs - -> RegMap Loc - -> StackMap - -> UniqSupply - -> RegM freeRegs a - -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) - -runR dflags block_assig freeregs assig stack us thing = - case unReg thing - (RA_State - { ra_blockassig = block_assig - , ra_freeregs = freeregs - , ra_assig = assig - , ra_delta = 0{-???-} - , ra_stack = stack - , ra_us = us - , ra_spills = [] - , ra_DynFlags = dflags - , ra_fixups = [] }) - of - RA_Result state returned_thing - -> (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing) - - --- | Make register allocator stats from its final state. -makeRAStats :: RA_State freeRegs -> RegAllocStats -makeRAStats state - = RegAllocStats - { ra_spillInstrs = binSpillReasons (ra_spills state) - , ra_fixupList = ra_fixups state } - - -spillR :: Instruction instr - => Reg -> Unique -> RegM freeRegs (instr, Int) - -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} -> - let dflags = ra_DynFlags s - (stack1,slot) = getStackSlotFor stack0 temp - instr = mkSpillInstr dflags reg delta slot - in - RA_Result s{ra_stack=stack1} (instr,slot) - - -loadR :: Instruction instr - => Reg -> Int -> RegM freeRegs instr - -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - let dflags = ra_DynFlags s - in RA_Result s (mkLoadInstr dflags reg delta slot) - -getFreeRegsR :: RegM freeRegs freeRegs -getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> - RA_Result s freeregs - -setFreeRegsR :: freeRegs -> RegM freeRegs () -setFreeRegsR regs = RegM $ \ s -> - RA_Result s{ra_freeregs = regs} () - -getAssigR :: RegM freeRegs (RegMap Loc) -getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> - RA_Result s assig - -setAssigR :: RegMap Loc -> RegM freeRegs () -setAssigR assig = RegM $ \ s -> - RA_Result s{ra_assig=assig} () - -getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) -getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> - RA_Result s assig - -setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () -setBlockAssigR assig = RegM $ \ s -> - RA_Result s{ra_blockassig = assig} () - -setDeltaR :: Int -> RegM freeRegs () -setDeltaR n = RegM $ \ s -> - RA_Result s{ra_delta = n} () - -getDeltaR :: RegM freeRegs Int -getDeltaR = RegM $ \s -> RA_Result s (ra_delta s) - -getUniqueR :: RegM freeRegs Unique -getUniqueR = RegM $ \s -> - case takeUniqFromSupply (ra_us s) of - (uniq, us) -> RA_Result s{ra_us = us} uniq - - --- | Record that a spill instruction was inserted, for profiling. -recordSpill :: SpillReason -> RegM freeRegs () -recordSpill spill - = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) () - --- | Record a created fixup block -recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs () -recordFixupBlock from between to - = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) () diff --git a/nativeGen/RegAlloc/Linear/Stats.hs b/nativeGen/RegAlloc/Linear/Stats.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/Stats.hs +++ /dev/null @@ -1,87 +0,0 @@ -module RegAlloc.Linear.Stats ( - binSpillReasons, - countRegRegMovesNat, - pprStats -) - -where - -import GhcPrelude - -import RegAlloc.Linear.Base -import RegAlloc.Liveness -import Instruction - -import UniqFM -import Outputable - -import State - --- | Build a map of how many times each reg was alloced, clobbered, loaded etc. -binSpillReasons - :: [SpillReason] -> UniqFM [Int] - -binSpillReasons reasons - = addListToUFM_C - (zipWith (+)) - emptyUFM - (map (\reason -> case reason of - SpillAlloc r -> (r, [1, 0, 0, 0, 0]) - SpillClobber r -> (r, [0, 1, 0, 0, 0]) - SpillLoad r -> (r, [0, 0, 1, 0, 0]) - SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) - SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) - - --- | Count reg-reg moves remaining in this code. -countRegRegMovesNat - :: Instruction instr - => NatCmmDecl statics instr -> Int - -countRegRegMovesNat cmm - = execState (mapGenBlockTopM countBlock cmm) 0 - where - countBlock b@(BasicBlock _ instrs) - = do mapM_ countInstr instrs - return b - - countInstr instr - | Just _ <- takeRegRegMoveInstr instr - = do modify (+ 1) - return instr - - | otherwise - = return instr - - --- | Pretty print some RegAllocStats -pprStats - :: Instruction instr - => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc - -pprStats code statss - = let -- sum up all the instrs inserted by the spiller - spills = foldl' (plusUFM_C (zipWith (+))) - emptyUFM - $ map ra_spillInstrs statss - - spillTotals = foldl' (zipWith (+)) - [0, 0, 0, 0, 0] - $ nonDetEltsUFM spills - -- See Note [Unique Determinism and code generation] - - -- count how many reg-reg-moves remain in the code - moves = sum $ map countRegRegMovesNat code - - pprSpill (reg, spills) - = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) - - in ( text "-- spills-added-total" - $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" - $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) - $$ text "" - $$ text "-- spills-added" - $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" - $$ (pprUFMWithKeys spills (vcat . map pprSpill)) - $$ text "") - diff --git a/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ /dev/null @@ -1,53 +0,0 @@ - --- | Free regs map for i386 -module RegAlloc.Linear.X86.FreeRegs -where - -import GhcPrelude - -import X86.Regs -import RegClass -import Reg -import Panic -import GHC.Platform - -import Data.Word -import Data.Bits - -newtype FreeRegs = FreeRegs Word32 - deriving Show - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 - -releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle n) (FreeRegs f) - = FreeRegs (f .|. (1 `shiftL` n)) - -releaseReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg" - -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) - -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = go f 0 - - where go 0 _ = [] - go n m - | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls - = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) - - | otherwise - = go (n `shiftR` 1) $! (m+1) - -- ToDo: there's no point looking through all the integer registers - -- in order to find a floating-point one. - -allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) (FreeRegs f) - = FreeRegs (f .&. complement (1 `shiftL` r)) - -allocateReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" - diff --git a/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs +++ /dev/null @@ -1,54 +0,0 @@ - --- | Free regs map for x86_64 -module RegAlloc.Linear.X86_64.FreeRegs -where - -import GhcPrelude - -import X86.Regs -import RegClass -import Reg -import Panic -import GHC.Platform - -import Data.Word -import Data.Bits - -newtype FreeRegs = FreeRegs Word64 - deriving Show - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 - -releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle n) (FreeRegs f) - = FreeRegs (f .|. (1 `shiftL` n)) - -releaseReg _ _ - = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg" - -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) - -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = go f 0 - - where go 0 _ = [] - go n m - | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls - = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) - - | otherwise - = go (n `shiftR` 1) $! (m+1) - -- ToDo: there's no point looking through all the integer registers - -- in order to find a floating-point one. - -allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) (FreeRegs f) - = FreeRegs (f .&. complement (1 `shiftL` r)) - -allocateReg _ _ - = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg" - - diff --git a/nativeGen/RegAlloc/Liveness.hs b/nativeGen/RegAlloc/Liveness.hs deleted file mode 100644 --- a/nativeGen/RegAlloc/Liveness.hs +++ /dev/null @@ -1,1023 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - ------------------------------------------------------------------------------ --- --- The register liveness determinator --- --- (c) The University of Glasgow 2004-2013 --- ------------------------------------------------------------------------------ - -module RegAlloc.Liveness ( - RegSet, - RegMap, emptyRegMap, - BlockMap, mapEmpty, - LiveCmmDecl, - InstrSR (..), - LiveInstr (..), - Liveness (..), - LiveInfo (..), - LiveBasicBlock, - - mapBlockTop, mapBlockTopM, mapSCCM, - mapGenBlockTop, mapGenBlockTopM, - stripLive, - stripLiveBlock, - slurpConflicts, - slurpReloadCoalesce, - eraseDeltasLive, - patchEraseLive, - patchRegsLiveInstr, - reverseBlocksInTops, - regLiveness, - cmmTopLiveness - ) where -import GhcPrelude - -import Reg -import Instruction - -import BlockId -import CFG -import Hoopl.Collections -import Hoopl.Label -import Cmm hiding (RegSet, emptyRegSet) - -import Digraph -import DynFlags -import MonadUtils -import Outputable -import GHC.Platform -import UniqSet -import UniqFM -import UniqSupply -import Bag -import State - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) - ------------------------------------------------------------------------------ -type RegSet = UniqSet Reg - -type RegMap a = UniqFM a - -emptyRegMap :: UniqFM a -emptyRegMap = emptyUFM - -emptyRegSet :: RegSet -emptyRegSet = emptyUniqSet - -type BlockMap a = LabelMap a - - --- | A top level thing which carries liveness information. -type LiveCmmDecl statics instr - = GenCmmDecl - statics - LiveInfo - [SCC (LiveBasicBlock instr)] - - --- | The register allocator also wants to use SPILL/RELOAD meta instructions, --- so we'll keep those here. -data InstrSR instr - -- | A real machine instruction - = Instr instr - - -- | spill this reg to a stack slot - | SPILL Reg Int - - -- | reload this reg from a stack slot - | RELOAD Int Reg - -instance Instruction instr => Instruction (InstrSR instr) where - regUsageOfInstr platform i - = case i of - Instr instr -> regUsageOfInstr platform instr - SPILL reg _ -> RU [reg] [] - RELOAD _ reg -> RU [] [reg] - - patchRegsOfInstr i f - = case i of - Instr instr -> Instr (patchRegsOfInstr instr f) - SPILL reg slot -> SPILL (f reg) slot - RELOAD slot reg -> RELOAD slot (f reg) - - isJumpishInstr i - = case i of - Instr instr -> isJumpishInstr instr - _ -> False - - jumpDestsOfInstr i - = case i of - Instr instr -> jumpDestsOfInstr instr - _ -> [] - - patchJumpInstr i f - = case i of - Instr instr -> Instr (patchJumpInstr instr f) - _ -> i - - mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" - mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" - - takeDeltaInstr i - = case i of - Instr instr -> takeDeltaInstr instr - _ -> Nothing - - isMetaInstr i - = case i of - Instr instr -> isMetaInstr instr - _ -> False - - mkRegRegMoveInstr platform r1 r2 - = Instr (mkRegRegMoveInstr platform r1 r2) - - takeRegRegMoveInstr i - = case i of - Instr instr -> takeRegRegMoveInstr instr - _ -> Nothing - - mkJumpInstr target = map Instr (mkJumpInstr target) - - mkStackAllocInstr platform amount = - Instr <$> mkStackAllocInstr platform amount - - mkStackDeallocInstr platform amount = - Instr <$> mkStackDeallocInstr platform amount - - --- | An instruction with liveness information. -data LiveInstr instr - = LiveInstr (InstrSR instr) (Maybe Liveness) - --- | Liveness information. --- The regs which die are ones which are no longer live in the *next* instruction --- in this sequence. --- (NB. if the instruction is a jump, these registers might still be live --- at the jump target(s) - you have to check the liveness at the destination --- block to find out). - -data Liveness - = Liveness - { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. - , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. - - --- | Stash regs live on entry to each basic block in the info part of the cmm code. -data LiveInfo - = LiveInfo - (LabelMap CmmStatics) -- cmm info table static stuff - [BlockId] -- entry points (first one is the - -- entry point for the proc). - (BlockMap RegSet) -- argument locals live on entry to this block - (BlockMap IntSet) -- stack slots live on entry to this block - - --- | A basic block with liveness information. -type LiveBasicBlock instr - = GenBasicBlock (LiveInstr instr) - - -instance Outputable instr - => Outputable (InstrSR instr) where - - ppr (Instr realInstr) - = ppr realInstr - - ppr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char ' ', - ppr reg, - comma, - text "SLOT" <> parens (int slot)] - - ppr (RELOAD slot reg) - = hcat [ - text "\tRELOAD", - char ' ', - text "SLOT" <> parens (int slot), - comma, - ppr reg] - -instance Outputable instr - => Outputable (LiveInstr instr) where - - ppr (LiveInstr instr Nothing) - = ppr instr - - ppr (LiveInstr instr (Just live)) - = ppr instr - $$ (nest 8 - $ vcat - [ pprRegs (text "# born: ") (liveBorn live) - , pprRegs (text "# r_dying: ") (liveDieRead live) - , pprRegs (text "# w_dying: ") (liveDieWrite live) ] - $+$ space) - - where pprRegs :: SDoc -> RegSet -> SDoc - pprRegs name regs - | isEmptyUniqSet regs = empty - | otherwise = name <> - (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) - -instance Outputable LiveInfo where - ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) - = (ppr mb_static) - $$ text "# entryIds = " <> ppr entryIds - $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry - $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) - - - --- | map a function across all the basic blocks in this code --- -mapBlockTop - :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr - -mapBlockTop f cmm - = evalState (mapBlockTopM (\x -> return $ f x) cmm) () - - --- | map a function across all the basic blocks in this code (monadic version) --- -mapBlockTopM - :: Monad m - => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr) - -mapBlockTopM _ cmm@(CmmData{}) - = return cmm - -mapBlockTopM f (CmmProc header label live sccs) - = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label live sccs' - -mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) -mapSCCM f (AcyclicSCC x) - = do x' <- f x - return $ AcyclicSCC x' - -mapSCCM f (CyclicSCC xs) - = do xs' <- mapM f xs - return $ CyclicSCC xs' - - --- map a function across all the basic blocks in this code -mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i)) - -mapGenBlockTop f cmm - = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () - - --- | map a function across all the basic blocks in this code (monadic version) -mapGenBlockTopM - :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))) - -mapGenBlockTopM _ cmm@(CmmData{}) - = return cmm - -mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) - = do blocks' <- mapM f blocks - return $ CmmProc header label live (ListGraph blocks') - - --- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. --- Slurping of conflicts and moves is wrapped up together so we don't have --- to make two passes over the same code when we want to build the graph. --- -slurpConflicts - :: Instruction instr - => LiveCmmDecl statics instr - -> (Bag (UniqSet Reg), Bag (Reg, Reg)) - -slurpConflicts live - = slurpCmm (emptyBag, emptyBag) live - - where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ sccs) - = foldl' (slurpSCC info) rs sccs - - slurpSCC info rs (AcyclicSCC b) - = slurpBlock info rs b - - slurpSCC info rs (CyclicSCC bs) - = foldl' (slurpBlock info) rs bs - - slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ blockLive _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs - = (consBag rsLiveEntry conflicts, moves) - - | otherwise - = panic "Liveness.slurpConflicts: bad block" - - slurpLIs rsLive (conflicts, moves) [] - = (consBag rsLive conflicts, moves) - - slurpLIs rsLive rs (LiveInstr _ Nothing : lis) - = slurpLIs rsLive rs lis - - slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) - = let - -- regs that die because they are read for the last time at the start of an instruction - -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) - - -- regs live on entry to the next instruction. - -- be careful of orphans, make sure to delete dying regs _after_ unioning - -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) - - -- orphan vregs are the ones that die in the same instruction they are born in. - -- these are likely to be results that are never used, but we still - -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets - (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) - - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans - - in case takeRegRegMoveInstr instr of - Just rr -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , consBag rr moves) lis - - Nothing -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , moves) lis - - --- | For spill\/reloads --- --- SPILL v1, slot1 --- ... --- RELOAD slot1, v2 --- --- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely --- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. --- --- -slurpReloadCoalesce - :: forall statics instr. Instruction instr - => LiveCmmDecl statics instr - -> Bag (Reg, Reg) - -slurpReloadCoalesce live - = slurpCmm emptyBag live - - where - slurpCmm :: Bag (Reg, Reg) - -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] - -> Bag (Reg, Reg) - slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ _ sccs) - = slurpComp cs (flattenSCCs sccs) - - slurpComp :: Bag (Reg, Reg) - -> [LiveBasicBlock instr] - -> Bag (Reg, Reg) - slurpComp cs blocks - = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM - in unionManyBags (cs : moveBags) - - slurpCompM :: [LiveBasicBlock instr] - -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] - slurpCompM blocks - = do -- run the analysis once to record the mapping across jumps. - mapM_ (slurpBlock False) blocks - - -- run it a second time while using the information from the last pass. - -- We /could/ run this many more times to deal with graphical control - -- flow and propagating info across multiple jumps, but it's probably - -- not worth the trouble. - mapM (slurpBlock True) blocks - - slurpBlock :: Bool -> LiveBasicBlock instr - -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) - slurpBlock propagate (BasicBlock blockId instrs) - = do -- grab the slot map for entry to this block - slotMap <- if propagate - then getSlotMap blockId - else return emptyUFM - - (_, mMoves) <- mapAccumLM slurpLI slotMap instrs - return $ listToBag $ catMaybes mMoves - - slurpLI :: UniqFM Reg -- current slotMap - -> LiveInstr instr - -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] - -- for tracking slotMaps across jumps - - ( UniqFM Reg -- new slotMap - , Maybe (Reg, Reg)) -- maybe a new coalesce edge - - slurpLI slotMap li - - -- remember what reg was stored into the slot - | LiveInstr (SPILL reg slot) _ <- li - , slotMap' <- addToUFM slotMap slot reg - = return (slotMap', Nothing) - - -- add an edge between the this reg and the last one stored into the slot - | LiveInstr (RELOAD slot reg) _ <- li - = case lookupUFM slotMap slot of - Just reg2 - | reg /= reg2 -> return (slotMap, Just (reg, reg2)) - | otherwise -> return (slotMap, Nothing) - - Nothing -> return (slotMap, Nothing) - - -- if we hit a jump, remember the current slotMap - | LiveInstr (Instr instr) _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accSlotMap slotMap) targets - return (slotMap, Nothing) - - | otherwise - = return (slotMap, Nothing) - - -- record a slotmap for an in edge to this block - accSlotMap slotMap blockId - = modify (\s -> addToUFM_C (++) s blockId [slotMap]) - - -- work out the slot map on entry to this block - -- if we have slot maps for multiple in-edges then we need to merge them. - getSlotMap blockId - = do map <- get - let slotMaps = fromMaybe [] (lookupUFM map blockId) - return $ foldr mergeSlotMaps emptyUFM slotMaps - - mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg - mergeSlotMaps map1 map2 - = listToUFM - $ [ (k, r1) - | (k, r1) <- nonDetUFMToList map1 - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - , case lookupUFM map2 k of - Nothing -> False - Just r2 -> r1 == r2 ] - - --- | Strip away liveness information, yielding NatCmmDecl -stripLive - :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> LiveCmmDecl statics instr - -> NatCmmDecl statics instr - -stripLive dflags live - = stripCmm live - - where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) - => LiveCmmDecl statics instr -> NatCmmDecl statics instr - stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) - = let final_blocks = flattenSCCs sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output. This is the entry point - -- of the proc, and it needs to come first. - ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks - - in CmmProc info label live - (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') - - -- If the proc has blocks but we don't know what the first one was, then we're dead. - stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) - --- | Strip away liveness information from a basic block, --- and make real spill instructions out of SPILL, RELOAD pseudos along the way. - -stripLiveBlock - :: Instruction instr - => DynFlags - -> LiveBasicBlock instr - -> NatBasicBlock instr - -stripLiveBlock dflags (BasicBlock i lis) - = BasicBlock i instrs' - - where (instrs', _) - = runState (spillNat [] lis) 0 - - spillNat acc [] - = return (reverse acc) - - spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) - = do delta <- get - spillNat (mkSpillInstr dflags reg delta slot : acc) instrs - - spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) - = do delta <- get - spillNat (mkLoadInstr dflags reg delta slot : acc) instrs - - spillNat acc (LiveInstr (Instr instr) _ : instrs) - | Just i <- takeDeltaInstr instr - = do put i - spillNat acc instrs - - spillNat acc (LiveInstr (Instr instr) _ : instrs) - = spillNat (instr : acc) instrs - - --- | Erase Delta instructions. - -eraseDeltasLive - :: Instruction instr - => LiveCmmDecl statics instr - -> LiveCmmDecl statics instr - -eraseDeltasLive cmm - = mapBlockTop eraseBlock cmm - where - eraseBlock (BasicBlock id lis) - = BasicBlock id - $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) - $ lis - - --- | Patch the registers in this code according to this register mapping. --- also erase reg -> reg moves when the reg is the same. --- also erase reg -> reg moves when the destination dies in this instr. -patchEraseLive - :: Instruction instr - => (Reg -> Reg) - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr - -patchEraseLive patchF cmm - = patchCmm cmm - where - patchCmm cmm@CmmData{} = cmm - - patchCmm (CmmProc info label live sccs) - | LiveInfo static id blockMap mLiveSlots <- info - = let - patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set - -- See Note [Unique Determinism and code generation] - blockMap' = mapMap (patchRegSet . getUniqSet) blockMap - - info' = LiveInfo static id blockMap' mLiveSlots - in CmmProc info' label live $ map patchSCC sccs - - patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) - patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) - - patchBlock (BasicBlock id lis) - = BasicBlock id $ patchInstrs lis - - patchInstrs [] = [] - patchInstrs (li : lis) - - | LiveInstr i (Just live) <- li' - , Just (r1, r2) <- takeRegRegMoveInstr i - , eatMe r1 r2 live - = patchInstrs lis - - | otherwise - = li' : patchInstrs lis - - where li' = patchRegsLiveInstr patchF li - - eatMe r1 r2 live - -- source and destination regs are the same - | r1 == r2 = True - - -- destination reg is never used - | elementOfUniqSet r2 (liveBorn live) - , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) - = True - - | otherwise = False - - --- | Patch registers in this LiveInstr, including the liveness information. --- -patchRegsLiveInstr - :: Instruction instr - => (Reg -> Reg) - -> LiveInstr instr -> LiveInstr instr - -patchRegsLiveInstr patchF li - = case li of - LiveInstr instr Nothing - -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - - LiveInstr instr (Just live) - -> LiveInstr - (patchRegsOfInstr instr patchF) - (Just live - { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mapUniqSet patchF $ liveBorn live - , liveDieRead = mapUniqSet patchF $ liveDieRead live - , liveDieWrite = mapUniqSet patchF $ liveDieWrite live }) - -- See Note [Unique Determinism and code generation] - - --------------------------------------------------------------------------------- --- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information - -cmmTopLiveness - :: (Outputable instr, Instruction instr) - => Maybe CFG -> Platform - -> NatCmmDecl statics instr - -> UniqSM (LiveCmmDecl statics instr) -cmmTopLiveness cfg platform cmm - = regLiveness platform $ natCmmTopToLive cfg cmm - -natCmmTopToLive - :: (Instruction instr, Outputable instr) - => Maybe CFG -> NatCmmDecl statics instr - -> LiveCmmDecl statics instr - -natCmmTopToLive _ (CmmData i d) - = CmmData i d - -natCmmTopToLive _ (CmmProc info lbl live (ListGraph [])) - = CmmProc (LiveInfo info [] mapEmpty mapEmpty) lbl live [] - -natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) - = CmmProc (LiveInfo info' (first_id : entry_ids) mapEmpty mapEmpty) - lbl live sccsLive - where - first_id = blockId first - all_entry_ids = entryBlocks proc - sccs = sccBlocks blocks all_entry_ids mCfg - sccsLive = map (fmap (\(BasicBlock l instrs) -> - BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) - $ sccs - - entry_ids = filter (reachable_node) . - filter (/= first_id) $ all_entry_ids - info' = mapFilterWithKey (\node _ -> reachable_node node) info - reachable_node - | Just cfg <- mCfg - = hasNode cfg - | otherwise - = const True - --- --- Compute the liveness graph of the set of basic blocks. Important: --- we also discard any unreachable code here, starting from the entry --- points (the first block in the list, and any blocks with info --- tables). Unreachable code arises when code blocks are orphaned in --- earlier optimisation passes, and may confuse the register allocator --- by referring to registers that are not initialised. It's easy to --- discard the unreachable code as part of the SCC pass, so that's --- exactly what we do. (#7574) --- -sccBlocks - :: forall instr . Instruction instr - => [NatBasicBlock instr] - -> [BlockId] - -> Maybe CFG - -> [SCC (NatBasicBlock instr)] - -sccBlocks blocks entries mcfg = map (fmap node_payload) sccs - where - nodes :: [ Node BlockId (NatBasicBlock instr) ] - nodes = [ DigraphNode block id (getOutEdges instrs) - | block@(BasicBlock id instrs) <- blocks ] - - g1 = graphFromEdgedVerticesUniq nodes - - reachable :: LabelSet - reachable - | Just cfg <- mcfg - -- Our CFG only contains reachable nodes by construction at this point. - = setFromList $ getCfgNodes cfg - | otherwise - = setFromList $ [ node_key node | node <- reachablesG g1 roots ] - - g2 = graphFromEdgedVerticesUniq [ node | node <- nodes - , node_key node - `setMember` reachable ] - - sccs = stronglyConnCompG g2 - - getOutEdges :: Instruction instr => [instr] -> [BlockId] - getOutEdges instrs = concat $ map jumpDestsOfInstr instrs - - -- This is truly ugly, but I don't see a good alternative. - -- Digraph just has the wrong API. We want to identify nodes - -- by their keys (BlockId), but Digraph requires the whole - -- node: (NatBasicBlock, BlockId, [BlockId]). This takes - -- advantage of the fact that Digraph only looks at the key, - -- even though it asks for the whole triple. - roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks") - | b <- entries ] - --------------------------------------------------------------------------------- --- Annotate code with register liveness information --- - -regLiveness - :: (Outputable instr, Instruction instr) - => Platform - -> LiveCmmDecl statics instr - -> UniqSM (LiveCmmDecl statics instr) - -regLiveness _ (CmmData i d) - = return $ CmmData i d - -regLiveness _ (CmmProc info lbl live []) - | LiveInfo static mFirst _ _ <- info - = return $ CmmProc - (LiveInfo static mFirst mapEmpty mapEmpty) - lbl live [] - -regLiveness platform (CmmProc info lbl live sccs) - | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness platform sccs - - in return $ CmmProc (LiveInfo static mFirst block_live liveSlotsOnEntry) - lbl live ann_sccs - - --- ----------------------------------------------------------------------------- --- | Check ordering of Blocks --- The computeLiveness function requires SCCs to be in reverse --- dependent order. If they're not the liveness information will be --- wrong, and we'll get a bad allocation. Better to check for this --- precondition explicitly or some other poor sucker will waste a --- day staring at bad assembly code.. --- -checkIsReverseDependent - :: Instruction instr - => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. - -> Maybe BlockId -- ^ BlockIds that fail the test (if any) - -checkIsReverseDependent sccs' - = go emptyUniqSet sccs' - - where go _ [] - = Nothing - - go blocksSeen (AcyclicSCC block : sccs) - = let dests = slurpJumpDestsOfBlock block - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] - badDests = dests `minusUniqSet` blocksSeen' - in case nonDetEltsUniqSet badDests of - -- See Note [Unique Determinism and code generation] - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - go blocksSeen (CyclicSCC blocks : sccs) - = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks - badDests = dests `minusUniqSet` blocksSeen' - in case nonDetEltsUniqSet badDests of - -- See Note [Unique Determinism and code generation] - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - slurpJumpDestsOfBlock (BasicBlock _ instrs) - = unionManyUniqSets - $ map (mkUniqSet . jumpDestsOfInstr) - [ i | LiveInstr i _ <- instrs] - - --- | If we've compute liveness info for this code already we have to reverse --- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr -reverseBlocksInTops top - = case top of - CmmData{} -> top - CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) - - --- | Computing liveness --- --- On entry, the SCCs must be in "reverse" order: later blocks may transfer --- control to earlier ones only, else `panic`. --- --- The SCCs returned are in the *opposite* order, which is exactly what we --- want for the next pass. --- -computeLiveness - :: (Outputable instr, Instruction instr) - => Platform - -> [SCC (LiveBasicBlock instr)] - -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers - -- which are "dead after this instruction". - BlockMap RegSet) -- blocks annotated with set of live registers - -- on entry to the block. - -computeLiveness platform sccs - = case checkIsReverseDependent sccs of - Nothing -> livenessSCCs platform mapEmpty [] sccs - Just bad -> pprPanic "RegAlloc.Liveness.computeLiveness" - (vcat [ text "SCCs aren't in reverse dependent order" - , text "bad blockId" <+> ppr bad - , ppr sccs]) - -livenessSCCs - :: Instruction instr - => Platform - -> BlockMap RegSet - -> [SCC (LiveBasicBlock instr)] -- accum - -> [SCC (LiveBasicBlock instr)] - -> ( [SCC (LiveBasicBlock instr)] - , BlockMap RegSet) - -livenessSCCs _ blockmap done [] - = (done, blockmap) - -livenessSCCs platform blockmap done (AcyclicSCC block : sccs) - = let (blockmap', block') = livenessBlock platform blockmap block - in livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs - -livenessSCCs platform blockmap done - (CyclicSCC blocks : sccs) = - livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs - where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks - - iterateUntilUnchanged - :: (a -> b -> (a,c)) -> (a -> a -> Bool) - -> a -> b - -> (a,c) - - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, panic "RegLiveness.livenessSCCs") - - - linearLiveness - :: Instruction instr - => BlockMap RegSet -> [LiveBasicBlock instr] - -> (BlockMap RegSet, [LiveBasicBlock instr]) - - linearLiveness = mapAccumL (livenessBlock platform) - - -- probably the least efficient way to compare two - -- BlockMaps for equality. - equalBlockMaps a b - = a' == b' - where a' = map f $ mapToList a - b' = map f $ mapToList b - f (key,elt) = (key, nonDetEltsUniqSet elt) - -- See Note [Unique Determinism and code generation] - - - --- | Annotate a basic block with register liveness information. --- -livenessBlock - :: Instruction instr - => Platform - -> BlockMap RegSet - -> LiveBasicBlock instr - -> (BlockMap RegSet, LiveBasicBlock instr) - -livenessBlock platform blockmap (BasicBlock block_id instrs) - = let - (regsLiveOnEntry, instrs1) - = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) - blockmap' = mapInsert block_id regsLiveOnEntry blockmap - - instrs2 = livenessForward platform regsLiveOnEntry instrs1 - - output = BasicBlock block_id instrs2 - - in ( blockmap', output) - --- | Calculate liveness going forwards, --- filling in when regs are born - -livenessForward - :: Instruction instr - => Platform - -> RegSet -- regs live on this instr - -> [LiveInstr instr] -> [LiveInstr instr] - -livenessForward _ _ [] = [] -livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) - | Just live <- mLive - = let - RU _ written = regUsageOfInstr platform instr - -- Regs that are written to but weren't live on entry to this instruction - -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written - - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) - - in LiveInstr instr (Just live { liveBorn = rsBorn }) - : livenessForward platform rsLiveNext lis - - | otherwise - = li : livenessForward platform rsLiveEntry lis - - --- | Calculate liveness going backwards, --- filling in when regs die, and what regs are live across each instruction - -livenessBack - :: Instruction instr - => Platform - -> RegSet -- regs live on this instr - -> BlockMap RegSet -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (RegSet, [LiveInstr instr]) - -livenessBack _ liveregs _ done [] = (liveregs, done) - -livenessBack platform liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 platform liveregs blockmap instr - in livenessBack platform liveregs' blockmap (instr' : acc) instrs - - --- don't bother tagging comments or deltas with liveness -liveness1 - :: Instruction instr - => Platform - -> RegSet - -> BlockMap RegSet - -> LiveInstr instr - -> (RegSet, LiveInstr instr) - -liveness1 _ liveregs _ (LiveInstr instr _) - | isMetaInstr instr - = (liveregs, LiveInstr instr Nothing) - -liveness1 platform liveregs blockmap (LiveInstr instr _) - - | not_a_branch - = (liveregs1, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying - , liveDieWrite = mkUniqSet w_dying })) - - | otherwise - = (liveregs_br, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying_br - , liveDieWrite = mkUniqSet w_dying })) - - where - !(RU read written) = regUsageOfInstr platform instr - - -- registers that were written here are dead going backwards. - -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read - - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] - - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] - - -- union in the live regs from all the jump destinations of this - -- instruction. - targets = jumpDestsOfInstr instr -- where we go from here - not_a_branch = null targets - - targetLiveRegs target - = case mapLookup target blockmap of - Just ra -> ra - Nothing -> emptyRegSet - - live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - - liveregs_br = liveregs1 `unionUniqSets` live_from_branch - - -- registers that are live only in the branch targets should - -- be listed as dying here. - live_branch_only = live_from_branch `minusUniqSet` liveregs - r_dying_br = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets` - live_branch_only) - -- See Note [Unique Determinism and code generation] diff --git a/nativeGen/RegClass.hs b/nativeGen/RegClass.hs deleted file mode 100644 --- a/nativeGen/RegClass.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | An architecture independent description of a register's class. -module RegClass - ( RegClass (..) ) - -where - -import GhcPrelude - -import Outputable -import Unique - - --- | The class of a register. --- Used in the register allocator. --- We treat all registers in a class as being interchangable. --- -data RegClass - = RcInteger - | RcFloat - | RcDouble - deriving Eq - - -instance Uniquable RegClass where - getUnique RcInteger = mkRegClassUnique 0 - getUnique RcFloat = mkRegClassUnique 1 - getUnique RcDouble = mkRegClassUnique 2 - -instance Outputable RegClass where - ppr RcInteger = Outputable.text "I" - ppr RcFloat = Outputable.text "F" - ppr RcDouble = Outputable.text "D" diff --git a/nativeGen/SPARC/AddrMode.hs b/nativeGen/SPARC/AddrMode.hs deleted file mode 100644 --- a/nativeGen/SPARC/AddrMode.hs +++ /dev/null @@ -1,44 +0,0 @@ - -module SPARC.AddrMode ( - AddrMode(..), - addrOffset -) - -where - -import GhcPrelude - -import SPARC.Imm -import SPARC.Base -import Reg - --- addressing modes ------------------------------------------------------------ - --- | Represents a memory address in an instruction. --- Being a RISC machine, the SPARC addressing modes are very regular. --- -data AddrMode - = AddrRegReg Reg Reg -- addr = r1 + r2 - | AddrRegImm Reg Imm -- addr = r1 + imm - - --- | Add an integer offset to the address in an AddrMode. --- -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - AddrRegImm r (ImmInt n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2)) - | otherwise -> Nothing - where n2 = n + off - - AddrRegImm r (ImmInteger n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) - | otherwise -> Nothing - where n2 = n + toInteger off - - AddrRegReg r (RegReal (RealRegSingle 0)) - | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) - | otherwise -> Nothing - - _ -> Nothing diff --git a/nativeGen/SPARC/Base.hs b/nativeGen/SPARC/Base.hs deleted file mode 100644 --- a/nativeGen/SPARC/Base.hs +++ /dev/null @@ -1,77 +0,0 @@ - --- | Bits and pieces on the bottom of the module dependency tree. --- Also import the required constants, so we know what we're using. --- --- In the interests of cross-compilation, we want to free ourselves --- from the autoconf generated modules like main/Constants - -module SPARC.Base ( - wordLength, - wordLengthInBits, - spillAreaLength, - spillSlotSize, - extraStackArgsHere, - fits13Bits, - is32BitInteger, - largeOffsetError -) - -where - -import GhcPrelude - -import DynFlags -import Panic - -import Data.Int - - --- On 32 bit SPARC, pointers are 32 bits. -wordLength :: Int -wordLength = 4 - -wordLengthInBits :: Int -wordLengthInBits - = wordLength * 8 - --- Size of the available spill area -spillAreaLength :: DynFlags -> Int -spillAreaLength - = rESERVED_C_STACK_BYTES - --- | We need 8 bytes because our largest registers are 64 bit. -spillSlotSize :: Int -spillSlotSize = 8 - - --- | We (allegedly) put the first six C-call arguments in registers; --- where do we start putting the rest of them? -extraStackArgsHere :: Int -extraStackArgsHere = 23 - - -{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-} --- | Check whether an offset is representable with 13 bits. -fits13Bits :: Integral a => a -> Bool -fits13Bits x = x >= -4096 && x < 4096 - --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i - = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - --- | Sadness. -largeOffsetError :: (Show a) => a -> b -largeOffsetError i - = panic ("ERROR: SPARC native-code generator cannot handle large offset (" - ++ show i ++ ");\nprobably because of large constant data structures;" ++ - "\nworkaround: use -fllvm on this module.\n") - - diff --git a/nativeGen/SPARC/CodeGen.hs b/nativeGen/SPARC/CodeGen.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen.hs +++ /dev/null @@ -1,699 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2013 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GADTs #-} -module SPARC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) - -where - -#include "HsVersions.h" - --- NCG stuff: -import GhcPrelude - -import SPARC.Base -import SPARC.CodeGen.Sanity -import SPARC.CodeGen.Amode -import SPARC.CodeGen.CondCode -import SPARC.CodeGen.Gen64 -import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.Instr -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Regs -import SPARC.Stack -import Instruction -import Format -import NCGMonad ( NatM, getNewRegNat, getNewLabelNat ) - --- Our intermediate code: -import BlockId -import Cmm -import CmmUtils -import CmmSwitch -import Hoopl.Block -import Hoopl.Graph -import PIC -import Reg -import CLabel -import CPrim - --- The rest: -import BasicTypes -import DynFlags -import FastString -import OrdList -import Outputable -import GHC.Platform - -import Control.Monad ( mapAndUnzipM ) - --- | Top level code generation -cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl CmmStatics Instr] - -cmmTopCodeGen (CmmProc info lab live graph) - = do let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - let tops = proc : concat statics - - return tops - -cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic - - --- | Do code generation on a single block of CMM code. --- code generation may introduce new basic block boundaries, which --- are indicated by the NEWBLOCK instruction. We must split up the --- instruction stream into basic blocks again. Also, we extract --- LDATAs here too. -basicBlockCodeGen :: CmmBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl CmmStatics Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs - let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - - -- do intra-block sanity checking - blocksChecked - = map (checkBlock block) - $ BasicBlock id top : other_blocks - - return (blocksChecked, statics) - - --- | Convert some Cmm statements to SPARC instructions. -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - dflags <- getDynFlags - case stmt of - CmmComment s -> return (unitOL (COMMENT s)) - CmmTick {} -> return nilOL - CmmUnwind {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType dflags reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType dflags src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false _ -> do - b1 <- genCondJump true arg - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids - CmmCall { cml_target = arg } -> genJump arg - - _ - -> panic "stmtToInstrs: statement should have been cps'd away" - - -{- -Now, given a tree (the argument to a CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - - - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = blockLbl blockid - - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src - Amode dstAddr addr_code <- getAmode addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - - -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_IntCode _ reg src = do - dflags <- getDynFlags - r <- getRegister src - let dst = getRegisterReg (targetPlatform dflags) reg - return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst - - - --- Floating point assignment to memory -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_FltCode pk addr src = do - dflags <- getDynFlags - Amode dst__2 code1 <- getAmode addr - (src__2, code2) <- getSomeReg src - tmp1 <- getNewRegNat pk - let - pk__2 = cmmExprType dflags src - code__2 = code1 `appOL` code2 `appOL` - if formatToWidth pk == typeWidth pk__2 - then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] - return code__2 - --- Floating point assignment to a register/temporary -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_FltCode pk dstCmmReg srcCmmExpr = do - dflags <- getDynFlags - let platform = targetPlatform dflags - srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg platform dstCmmReg - - return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg - - - - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - -genJump (CmmLit (CmmLabel lbl)) - = return (toOL [CALL (Left target) 0 True, NOP]) - where - target = ImmCLbl lbl - -genJump tree - = do - (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -SPARC: First, we have to ensure that the condition codes are set -according to the supplied comparison operation. We generate slightly -different code for floating point comparisons, because a floating -point operation cannot directly precede a @BF@. We assume the worst -and fill that slot with a @NOP@. - -SPARC: Do not fill the delay slots here; you will confuse the register -allocator. --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - - - -genCondJump bid bool = do - CondCode is_float cond code <- getCondCode bool - return ( - code `appOL` - toOL ( - if is_float - then [NOP, BF cond False bid, NOP] - else [BI cond False bid, NOP] - ) - ) - - - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets - | positionIndependent dflags - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset) - - base_reg <- getNewRegNat II32 - offset_reg <- getNewRegNat II32 - dst <- getNewRegNat II32 - - label <- getNewLabelNat - - return $ e_code `appOL` - toOL - [ -- load base of jump table - SETHI (HI (ImmCLbl label)) base_reg - , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg - - -- the addrs in the table are 32 bits wide.. - , SLL e_reg (RIImm $ ImmInt 2) offset_reg - - -- load and jump to the destination - , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label - , NOP ] - where (offset, ids) = switchTargetsToTable targets - -generateJumpTableForInstr :: DynFlags -> Instr - -> Maybe (NatCmmDecl CmmStatics Instr) -generateJumpTableForInstr dflags (JMP_TBL _ ids label) = - let jumpTable = map (jumpTableEntry dflags) ids - in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable)) -generateJumpTableForInstr _ _ = Nothing - - - --- ----------------------------------------------------------------------------- --- Generating C calls - -{- - Now the biggest nightmare---calls. Most of the nastiness is buried in - @get_arg@, which moves the arguments to the correct registers/stack - locations. Apart from that, the code is easy. - - The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) - - If we have to put args on the stack, move %o6==%sp down by - the number of words to go on the stack, to ensure there's enough space. - - According to Fraser and Hanson's lcc book, page 478, fig 17.2, - 16 words above the stack pointer is a word for the address of - a structure return value. I use this as a temporary location - for moving values from float to int regs. Certainly it isn't - safe to put anything in the 16 words starting at %sp, since - this area can get trashed at any time due to window overflows - caused by signal handlers. - - A final complication (if the above isn't enough) is that - we can't blithely calculate the arguments one by one into - %o0 .. %o5. Consider the following nested calls: - - fff a (fff b c) - - Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately - the inner call will itself use %o0, which trashes the value put there - in preparation for the outer call. Upshot: we need to calculate the - args into temporary regs, and move those to arg regs or onto the - stack only immediately prior to the call proper. Sigh. --} - -genCCall - :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - - - --- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream --- are guaranteed to take place before writes afterwards (unlike on PowerPC). --- Ref: Section 8.4 of the SPARC V9 Architecture manual. --- --- In the SPARC case we don't need a barrier. --- -genCCall (PrimTarget MO_ReadBarrier) _ _ - = return $ nilOL -genCCall (PrimTarget MO_WriteBarrier) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ - = return $ nilOL - -genCCall target dest_regs args - = do -- work out the arguments, and assign them to integer regs - argcode_and_vregs <- mapM arg_to_int_vregs args - let (argcodes, vregss) = unzip argcode_and_vregs - let vregs = concat vregss - - let n_argRegs = length allArgRegs - let n_argRegs_used = min (length vregs) n_argRegs - - - -- deal with static vs dynamic call targets - callinsns <- case target of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - ForeignTarget expr _ - -> do (dyn_c, dyn_rs) <- arg_to_int_vregs expr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - PrimTarget mop - -> do res <- outOfLineMachOp mop - lblOrMopExpr <- case res of - Left lbl -> do - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - Right mopExpr -> do - (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - return lblOrMopExpr - - let argcode = concatOL argcodes - - let (move_sp_down, move_sp_up) - = let diff = length vregs - n_argRegs - nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment - in if nn <= 0 - then (nilOL, nilOL) - else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) - - let transfer_code - = toOL (move_final vregs allArgRegs extraStackArgsHere) - - dflags <- getDynFlags - return - $ argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up `appOL` - assign_code (targetPlatform dflags) dest_regs - - --- | Generate code to calculate an argument, and move it into one --- or two integer vregs. -arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg = do dflags <- getDynFlags - arg_to_int_vregs' dflags arg - -arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs' dflags arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType dflags arg) - = do (ChildCode64 code r_lo) <- iselExpr64 arg - let r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - - | otherwise - = do (src, code) <- getSomeReg arg - let pk = cmmExprType dflags arg - - case cmmTypeFormat pk of - - -- Load a 64 bit float return value into two integer regs. - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - - let code2 = - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f1 (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - - return (code2, [v1,v2]) - - -- Load a 32 bit float return value into an integer reg - FF32 -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - - return (code2, [v1]) - - -- Move an integer return value into its destination reg. - _ -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - OR False g0 (RIReg src) v1 - - return (code2, [v1]) - - --- | Move args from the integer vregs into which they have been --- marshalled, into %o0 .. %o5, and the rest onto the stack. --- -move_final :: [Reg] -> [Reg] -> Int -> [Instr] - --- all args done -move_final [] _ _ - = [] - --- out of aregs; move to stack -move_final (v:vs) [] offset - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - --- move into an arg (%o[0..5]) reg -move_final (v:vs) (a:az) offset - = OR False g0 (RIReg v) a - : move_final vs az offset - - --- | Assign results returned from the call into their --- destination regs. --- -assign_code :: Platform -> [LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [dest] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg platform (CmmLocal dest) - - result - | isFloatType rep - , W32 <- width - = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest - - | isFloatType rep - , W64 <- width - = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest - - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] - - | otherwise - = panic "SPARC.CodeGen.GenCCall: no match" - - in result - -assign_code _ _ - = panic "SPARC.CodeGen.GenCCall: no match" - - - --- | Generate a call to implement an out-of-line floating point operation -outOfLineMachOp - :: CallishMachOp - -> NatM (Either CLabel CmmExpr) - -outOfLineMachOp mop - = do let functionName - = outOfLineMachOp_table mop - - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags CallReference - $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction - - let mopLabelOrExpr - = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - - return mopLabelOrExpr - - --- | Decide what C function to use to implement a CallishMachOp --- -outOfLineMachOp_table - :: CallishMachOp - -> FastString - -outOfLineMachOp_table mop - = case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_ExpM1 -> fsLit "expm1f" - MO_F32_Log -> fsLit "logf" - MO_F32_Log1P -> fsLit "log1pf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Fabs -> unsupported - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F32_Asinh -> fsLit "asinhf" - MO_F32_Acosh -> fsLit "acoshf" - MO_F32_Atanh -> fsLit "atanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_ExpM1 -> fsLit "expm1" - MO_F64_Log -> fsLit "log" - MO_F64_Log1P -> fsLit "log1p" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Fabs -> unsupported - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_F64_Asinh -> fsLit "asinh" - MO_F64_Acosh -> fsLit "acosh" - MO_F64_Atanh -> fsLit "atanh" - - MO_UF_Conv w -> fsLit $ word2FloatLabel w - - MO_Memcpy _ -> fsLit "memcpy" - MO_Memset _ -> fsLit "memset" - MO_Memmove _ -> fsLit "memmove" - MO_Memcmp _ -> fsLit "memcmp" - - MO_BSwap w -> fsLit $ bSwapLabel w - MO_BRev w -> fsLit $ bRevLabel w - MO_PopCnt w -> fsLit $ popCntLabel w - MO_Pdep w -> fsLit $ pdepLabel w - MO_Pext w -> fsLit $ pextLabel w - MO_Clz w -> fsLit $ clzLabel w - MO_Ctz w -> fsLit $ ctzLabel w - MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop - MO_Cmpxchg w -> fsLit $ cmpxchgLabel w - MO_AtomicRead w -> fsLit $ atomicReadLabel w - MO_AtomicWrite w -> fsLit $ atomicWriteLabel w - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddWordC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _) -> unsupported - where unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - diff --git a/nativeGen/SPARC/CodeGen/Amode.hs b/nativeGen/SPARC/CodeGen/Amode.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Amode.hs +++ /dev/null @@ -1,74 +0,0 @@ -module SPARC.CodeGen.Amode ( - getAmode -) - -where - -import GhcPrelude - -import {-# SOURCE #-} SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.AddrMode -import SPARC.Imm -import SPARC.Instr -import SPARC.Regs -import SPARC.Base -import NCGMonad -import Format - -import Cmm - -import OrdList - - --- | Generate code to reference a memory address. -getAmode - :: CmmExpr -- ^ expr producing an address - -> NatM Amode - -getAmode tree@(CmmRegOff _ _) - = do dflags <- getDynFlags - getAmode (mangleIndexTree dflags tree) - -getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) - | fits13Bits (-i) - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (-(fromInteger i)) - return (Amode (AddrRegImm reg off) code) - - -getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) - | fits13Bits i - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (fromInteger i) - return (Amode (AddrRegImm reg off) code) - -getAmode (CmmMachOp (MO_Add _) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - let - code = codeX `appOL` codeY - return (Amode (AddrRegReg regX regY) code) - -getAmode (CmmLit lit) - = do - let imm__2 = litToImm lit - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 - - let code = toOL [ SETHI (HI imm__2) tmp1 - , OR False tmp1 (RIImm (LO imm__2)) tmp2] - - return (Amode (AddrRegReg tmp2 g0) code) - -getAmode other - = do - (reg, code) <- getSomeReg other - let - off = ImmInt 0 - return (Amode (AddrRegImm reg off) code) diff --git a/nativeGen/SPARC/CodeGen/Base.hs b/nativeGen/SPARC/CodeGen/Base.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Base.hs +++ /dev/null @@ -1,119 +0,0 @@ -module SPARC.CodeGen.Base ( - InstrBlock, - CondCode(..), - ChildCode64(..), - Amode(..), - - Register(..), - setFormatOfRegister, - - getRegisterReg, - mangleIndexTree -) - -where - -import GhcPrelude - -import SPARC.Instr -import SPARC.Cond -import SPARC.AddrMode -import SPARC.Regs -import Format -import Reg - -import GHC.Platform.Regs -import DynFlags -import Cmm -import PprCmmExpr () -- For Outputable instances -import GHC.Platform - -import Outputable -import OrdList - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Condition codes passed up the tree. --- -data CondCode - = CondCode Bool Cond InstrBlock - - --- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. --- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified --- -data ChildCode64 - = ChildCode64 - InstrBlock - Reg - - --- | Holds code that references a memory address. -data Amode - = Amode - -- the AddrMode we can use in the instruction - -- that does the real load\/store. - AddrMode - - -- other setup code we have to run first before we can use the - -- above AddrMode. - InstrBlock - - - --------------------------------------------------------------------------------- --- | Code to produce a result into a register. --- If the result must go in a specific register, it comes out as Fixed. --- Otherwise, the parent can decide which register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - --- | Change the format field in a Register. -setFormatOfRegister - :: Register -> Format -> Register - -setFormatOfRegister reg format - = case reg of - Fixed _ reg code -> Fixed format reg code - Any _ codefn -> Any format codefn - - --------------------------------------------------------------------------------- --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) - -getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal reg - Nothing -> pprPanic - "SPARC.CodeGen.Base.getRegisterReg: global is in memory" - (ppr $ CmmGlobal mid) - - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr - -mangleIndexTree dflags (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) - -mangleIndexTree _ _ - = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/nativeGen/SPARC/CodeGen/CondCode.hs b/nativeGen/SPARC/CodeGen/CondCode.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/CondCode.hs +++ /dev/null @@ -1,110 +0,0 @@ -module SPARC.CodeGen.CondCode ( - getCondCode, - condIntCode, - condFltCode -) - -where - -import GhcPrelude - -import {-# SOURCE #-} SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.Instr -import SPARC.Regs -import SPARC.Cond -import SPARC.Imm -import SPARC.Base -import NCGMonad -import Format - -import Cmm - -import OrdList -import Outputable - - -getCondCode :: CmmExpr -> NatM CondCode -getCondCode (CmmMachOp mop [x, y]) - = - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - MO_F_Lt W32 -> condFltCode LTT x y - MO_F_Le W32 -> condFltCode LE x y - - MO_F_Eq W64 -> condFltCode EQQ x y - MO_F_Ne W64 -> condFltCode NE x y - MO_F_Gt W64 -> condFltCode GTT x y - MO_F_Ge W64 -> condFltCode GE x y - MO_F_Lt W64 -> condFltCode LTT x y - MO_F_Le W64 -> condFltCode LE x y - - MO_Eq _ -> condIntCode EQQ x y - MO_Ne _ -> condIntCode NE x y - - MO_S_Gt _ -> condIntCode GTT x y - MO_S_Ge _ -> condIntCode GE x y - MO_S_Lt _ -> condIntCode LTT x y - MO_S_Le _ -> condIntCode LE x y - - MO_U_Gt _ -> condIntCode GU x y - MO_U_Ge _ -> condIntCode GEU x y - MO_U_Lt _ -> condIntCode LU x y - MO_U_Le _ -> condIntCode LEU x y - - _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) - -getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) - - - - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condIntCode cond x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code' = code `snocOL` SUB False True src1 (RIImm src2) g0 - return (CondCode False cond code') - -condIntCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 = code1 `appOL` code2 `snocOL` - SUB False True src1 (RIReg src2) g0 - return (CondCode False cond code__2) - - -condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condFltCode cond x y = do - dflags <- getDynFlags - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y - - code__2 = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - FCMP True (cmmTypeFormat pk1) src1 src2 - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - FCMP True FF64 tmp src2 - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - FCMP True FF64 src1 tmp - return (CondCode True cond code__2) diff --git a/nativeGen/SPARC/CodeGen/Expand.hs b/nativeGen/SPARC/CodeGen/Expand.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Expand.hs +++ /dev/null @@ -1,154 +0,0 @@ --- | Expand out synthetic instructions into single machine instrs. -module SPARC.CodeGen.Expand ( - expandTop -) - -where - -import GhcPrelude - -import SPARC.Instr -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Regs -import Instruction -import Reg -import Format -import Cmm - - -import Outputable -import OrdList - --- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr -expandTop top@(CmmData{}) - = top - -expandTop (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map expandBlock blocks) - - --- | Expand out synthetic instructions in this block -expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr - -expandBlock (BasicBlock label instrs) - = let instrs_ol = expandBlockInstrs instrs - instrs' = fromOL instrs_ol - in BasicBlock label instrs' - - --- | Expand out some instructions -expandBlockInstrs :: [Instr] -> OrdList Instr -expandBlockInstrs [] = nilOL - -expandBlockInstrs (ii:is) - = let ii_doubleRegs = remapRegPair ii - is_misaligned = expandMisalignedDoubles ii_doubleRegs - - in is_misaligned `appOL` expandBlockInstrs is - - - --- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are refered to by just the first reg --- of the pair. Remap our internal reg pairs to the appropriate reg. --- --- For example: --- ldd [%l1], (%f0 | %f1) --- --- gets mapped to --- ldd [$l1], %f0 --- -remapRegPair :: Instr -> Instr -remapRegPair instr - = let patchF reg - = case reg of - RegReal (RealRegSingle _) - -> reg - - RegReal (RealRegPair r1 r2) - - -- sanity checking - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - , r2 == r1 + 1 - -> RegReal (RealRegSingle r1) - - | otherwise - -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) - - RegVirtual _ - -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) - - in patchRegsOfInstr instr patchF - - - - --- Expand out 64 bit load/stores into individual instructions to handle --- possible double alignment problems. --- --- TODO: It'd be better to use a scratch reg instead of the add/sub thing. --- We might be able to do this faster if we use the UA2007 instr set --- instead of restricting ourselves to SPARC V9. --- -expandMisalignedDoubles :: Instr -> OrdList Instr -expandMisalignedDoubles instr - - -- Translate to: - -- add g1,g2,g1 - -- ld [g1],%fn - -- ld [g1+4],%f(n+1) - -- sub g1,g2,g1 -- to restore g1 - | LD FF64 (AddrRegReg r1 r2) fReg <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , LD FF32 (AddrRegReg r1 g0) fReg - , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | LD FF64 addr fReg <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ LD FF32 addr fReg - , LD FF32 addr' (fRegHi fReg) ] - - -- Translate to: - -- add g1,g2,g1 - -- st %fn,[g1] - -- st %f(n+1),[g1+4] - -- sub g1,g2,g1 -- to restore g1 - | ST FF64 fReg (AddrRegReg r1 r2) <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , ST FF32 fReg (AddrRegReg r1 g0) - , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | ST FF64 fReg addr <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ ST FF32 fReg addr - , ST FF32 (fRegHi fReg) addr' ] - - -- some other instr - | otherwise - = unitOL instr - - - --- | The high partner for this float reg. -fRegHi :: Reg -> Reg -fRegHi (RegReal (RealRegSingle r1)) - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - = (RegReal $ RealRegSingle (r1 + 1)) - --- Can't take high partner for non-low reg. -fRegHi reg - = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/nativeGen/SPARC/CodeGen/Gen32.hs b/nativeGen/SPARC/CodeGen/Gen32.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Gen32.hs +++ /dev/null @@ -1,692 +0,0 @@ --- | Evaluation of 32 bit values. -module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import GhcPrelude - -import SPARC.CodeGen.CondCode -import SPARC.CodeGen.Amode -import SPARC.CodeGen.Gen64 -import SPARC.CodeGen.Base -import SPARC.Stack -import SPARC.Instr -import SPARC.Cond -import SPARC.AddrMode -import SPARC.Imm -import SPARC.Regs -import SPARC.Base -import NCGMonad -import Format -import Reg - -import Cmm - -import Control.Monad (liftM) -import DynFlags -import OrdList -import Outputable - --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - - - --- | Make code to evaluate a 32 bit expression. --- -getRegister :: CmmExpr -> NatM Register - -getRegister (CmmReg reg) - = do dflags <- getDynFlags - let platform = targetPlatform dflags - return (Fixed (cmmTypeFormat (cmmRegType dflags reg)) - (getRegisterReg platform reg) nilOL) - -getRegister tree@(CmmRegOff _ _) - = do dflags <- getDynFlags - getRegister (mangleIndexTree dflags tree) - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - - --- Load a literal float into a float register. --- The actual literal is stored in a new data area, and we load it --- at runtime. -getRegister (CmmLit (CmmFloat f W32)) = do - - -- a label for the new data area - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - - let code dst = toOL [ - -- the data area - LDATA (Section ReadOnlyData lbl) $ Statics lbl - [CmmStaticLit (CmmFloat f W32)], - - -- load the literal - SETHI (HI (ImmCLbl lbl)) tmp, - LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - - return (Any FF32 code) - -getRegister (CmmLit (CmmFloat d W64)) = do - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - let code dst = toOL [ - LDATA (Section ReadOnlyData lbl) $ Statics lbl - [CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) tmp, - LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - return (Any FF64 code) - - --- Unary machine ops -getRegister (CmmMachOp mop [x]) - = case mop of - -- Floating point negation ------------------------- - MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x - MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x - - - -- Integer negation -------------------------------- - MO_S_Neg rep -> trivialUCode (intFormat rep) (SUB False False g0) x - MO_Not rep -> trivialUCode (intFormat rep) (XNOR False g0) x - - - -- Float word size conversion ---------------------- - MO_FF_Conv W64 W32 -> coerceDbl2Flt x - MO_FF_Conv W32 W64 -> coerceFlt2Dbl x - - - -- Float <-> Signed Int conversion ----------------- - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - - -- Unsigned integer word size conversions ---------- - - -- If it's the same size, then nothing needs to be done. - MO_UU_Conv from to - | from == to -> conversionNop (intFormat to) x - - -- To narrow an unsigned word, mask out the high bits to simulate what would - -- happen if we copied the value into a smaller register. - MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - - -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 - -- case because the only way we can load it is via SETHI, which needs 2 ops. - -- Do some shifts to chop out the high bits instead. - MO_UU_Conv W32 W16 - -> do tmpReg <- getNewRegNat II32 - (xReg, xCode) <- getSomeReg x - let code dst - = xCode - `appOL` toOL - [ SLL xReg (RIImm $ ImmInt 16) tmpReg - , SRL tmpReg (RIImm $ ImmInt 16) dst] - - return $ Any II32 code - - -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- To widen an unsigned word we don't have to do anything. - -- Just leave it in the same register and mark the result as the new size. - MO_UU_Conv W8 W16 -> conversionNop (intFormat W16) x - MO_UU_Conv W8 W32 -> conversionNop (intFormat W32) x - MO_UU_Conv W16 W32 -> conversionNop (intFormat W32) x - - - -- Signed integer word size conversions ------------ - - -- Mask out high bits when narrowing them - MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- Sign extend signed words when widening them. - MO_SS_Conv W8 W16 -> integerExtend W8 W16 x - MO_SS_Conv W8 W32 -> integerExtend W8 W32 x - MO_SS_Conv W16 W32 -> integerExtend W16 W32 x - - _ -> panic ("Unknown unary mach op: " ++ show mop) - - --- Binary machine ops -getRegister (CmmMachOp mop [x, y]) - = case mop of - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt W32 -> condIntReg GU x y - MO_U_Ge W32 -> condIntReg GEU x y - MO_U_Lt W32 -> condIntReg LU x y - MO_U_Le W32 -> condIntReg LEU x y - - MO_U_Gt W16 -> condIntReg GU x y - MO_U_Ge W16 -> condIntReg GEU x y - MO_U_Lt W16 -> condIntReg LU x y - MO_U_Le W16 -> condIntReg LEU x y - - MO_Add W32 -> trivialCode W32 (ADD False False) x y - MO_Sub W32 -> trivialCode W32 (SUB False False) x y - - MO_S_MulMayOflo rep -> imulMayOflo rep x y - - MO_S_Quot W32 -> idiv True False x y - MO_U_Quot W32 -> idiv False False x y - - MO_S_Rem W32 -> irem True x y - MO_U_Rem W32 -> irem False x y - - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y - - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y - - MO_F_Add w -> trivialFCode w FADD x y - MO_F_Sub w -> trivialFCode w FSUB x y - MO_F_Mul w -> trivialFCode w FMUL x y - MO_F_Quot w -> trivialFCode w FDIV x y - - MO_And rep -> trivialCode rep (AND False) x y - MO_Or rep -> trivialCode rep (OR False) x y - MO_Xor rep -> trivialCode rep (XOR False) x y - - MO_Mul rep -> trivialCode rep (SMUL False) x y - - MO_Shl rep -> trivialCode rep SLL x y - MO_U_Shr rep -> trivialCode rep SRL x y - MO_S_Shr rep -> trivialCode rep SRA x y - - _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) - -getRegister (CmmLoad mem pk) = do - Amode src code <- getAmode mem - let - code__2 dst = code `snocOL` LD (cmmTypeFormat pk) src dst - return (Any (cmmTypeFormat pk) code__2) - -getRegister (CmmLit (CmmInt i _)) - | fits13Bits i - = let - src = ImmInt (fromInteger i) - code dst = unitOL (OR False g0 (RIImm src) dst) - in - return (Any II32 code) - -getRegister (CmmLit lit) - = let imm = litToImm lit - code dst = toOL [ - SETHI (HI imm) dst, - OR False dst (RIImm (LO imm)) dst] - in return (Any II32 code) - - -getRegister _ - = panic "SPARC.CodeGen.Gen32.getRegister: no match" - - --- | sign extend and widen -integerExtend - :: Width -- ^ width of source expression - -> Width -- ^ width of result - -> CmmExpr -- ^ source expression - -> NatM Register - -integerExtend from to expr - = do -- load the expr into some register - (reg, e_code) <- getSomeReg expr - tmp <- getNewRegNat II32 - let bitCount - = case (from, to) of - (W8, W32) -> 24 - (W16, W32) -> 16 - (W8, W16) -> 24 - _ -> panic "SPARC.CodeGen.Gen32: no match" - let code dst - = e_code - - -- local shift word left to load the sign bit - `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp - - -- arithmetic shift right to sign extend - `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst - - return (Any (intFormat to) code) - - --- | For nop word format conversions we set the resulting value to have the --- required size, but don't need to generate any actual code. --- -conversionNop - :: Format -> CmmExpr -> NatM Register - -conversionNop new_rep expr - = do e_code <- getRegister expr - return (setFormatOfRegister e_code new_rep) - - - --- | Generate an integer division instruction. -idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned division with a 32 bit numerator, --- we can just clear the Y register. -idiv False cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- For _signed_ division with a 32 bit numerator, --- we have to sign extend the numerator into the Y register. -idiv True cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend - , SRA tmp (RIImm (ImmInt 16)) tmp - - , WRY tmp g0 - , SDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- | Do an integer remainder. --- --- NOTE: The SPARC v8 architecture manual says that integer division --- instructions _may_ generate a remainder, depending on the implementation. --- If so it is _recommended_ that the remainder is placed in the Y register. --- --- The UltraSparc 2007 manual says Y is _undefined_ after division. --- --- The SPARC T2 doesn't store the remainder, not sure about the others. --- It's probably best not to worry about it, and just generate our own --- remainders. --- -irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned operands: --- Division is between a 64 bit numerator and a 32 bit denominator, --- so we still have to clear the Y register. -irem False x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV False a_reg (RIReg b_reg) tmp_reg - , UMUL False tmp_reg (RIReg b_reg) tmp_reg - , SUB False False a_reg (RIReg tmp_reg) dst] - - return (Any II32 code) - - - --- For signed operands: --- Make sure to sign extend into the Y register, or the remainder --- will have the wrong sign when the numerator is negative. --- --- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, --- not the full 32. Not sure why this is, something to do with overflow? --- If anyone cares enough about the speed of signed remainder they --- can work it out themselves (then tell me). -- BL 2009/01/20 -irem True x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp1_reg <- getNewRegNat II32 - tmp2_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , WRY tmp1_reg g0 - - , SDIV False a_reg (RIReg b_reg) tmp2_reg - , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg - , SUB False False a_reg (RIReg tmp2_reg) dst] - - return (Any II32 code) - - -imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register -imulMayOflo rep a b - = do - (a_reg, a_code) <- getSomeReg a - (b_reg, b_code) <- getSomeReg b - res_lo <- getNewRegNat II32 - res_hi <- getNewRegNat II32 - - let shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - let code dst = a_code `appOL` b_code `appOL` - toOL [ - SMUL False a_reg (RIReg b_reg) res_lo, - RDY res_hi, - SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, - SUB False False res_lo (RIReg res_hi) dst - ] - return (Any II32 code) - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - -trivialCode - :: Width - -> (Reg -> RI -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialCode _ instr x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code__2 dst = code `snocOL` instr src1 (RIImm src2) dst - return (Any II32 code__2) - - -trivialCode _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `snocOL` - instr src1 (RIReg src2) dst - return (Any II32 code__2) - - -trivialFCode - :: Width - -> (Format -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialFCode pk instr x y = do - dflags <- getDynFlags - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y - - code__2 dst = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - instr (floatFormat pk) src1 src2 dst - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - instr FF64 tmp src2 dst - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - instr FF64 src1 tmp dst - return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) - code__2) - - - -trivialUCode - :: Format - -> (RI -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUCode format instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr (RIReg src) dst - return (Any format code__2) - - -trivialUFCode - :: Format - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUFCode pk instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr src dst - return (Any pk code__2) - - - - --- Coercions ------------------------------------------------------------------- - --- | Coerce a integer value to floating point -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP width1 width2 x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - ST (intFormat width1) src (spRel (-2)), - LD (intFormat width1) (spRel (-2)) dst, - FxTOy (intFormat width1) (floatFormat width2) dst dst] - return (Any (floatFormat $ width2) code__2) - - - --- | Coerce a floating point value to integer --- --- NOTE: On sparc v9 there are no instructions to move a value from an --- FP register directly to an int register, so we have to use a load/store. --- -coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int width1 width2 x - = do let fformat1 = floatFormat width1 - fformat2 = floatFormat width2 - - iformat2 = intFormat width2 - - (fsrc, code) <- getSomeReg x - fdst <- getNewRegNat fformat2 - - let code2 dst - = code - `appOL` toOL - -- convert float to int format, leaving it in a float reg. - [ FxTOy fformat1 iformat2 fsrc fdst - - -- store the int into mem, then load it back to move - -- it into an actual int reg. - , ST fformat2 fdst (spRel (-2)) - , LD iformat2 (spRel (-2)) dst] - - return (Any iformat2 code2) - - --- | Coerce a double precision floating point value to single precision. -coerceDbl2Flt :: CmmExpr -> NatM Register -coerceDbl2Flt x = do - (src, code) <- getSomeReg x - return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) - - --- | Coerce a single precision floating point value to double precision -coerceFlt2Dbl :: CmmExpr -> NatM Register -coerceFlt2Dbl x = do - (src, code) <- getSomeReg x - return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst)) - - - - --- Condition Codes ------------------------------------------------------------- --- --- Evaluate a comparison, and get the result into a register. --- --- Do not fill the delay slots here. you will confuse the register allocator. --- -condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg EQQ x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg NE x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg NE x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - CondCode _ cond cond_code <- condIntCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ BI cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2] - - return (Any II32 code__2) - - -condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condFltReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - - CondCode _ cond cond_code <- condFltCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ NOP - , BF cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2 ] - - return (Any II32 code__2) diff --git a/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/nativeGen/SPARC/CodeGen/Gen32.hs-boot deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ - -module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import SPARC.CodeGen.Base -import NCGMonad -import Reg - -import Cmm - -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getRegister :: CmmExpr -> NatM Register diff --git a/nativeGen/SPARC/CodeGen/Gen64.hs b/nativeGen/SPARC/CodeGen/Gen64.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Gen64.hs +++ /dev/null @@ -1,216 +0,0 @@ --- | Evaluation of 64 bit values on 32 bit platforms. -module SPARC.CodeGen.Gen64 ( - assignMem_I64Code, - assignReg_I64Code, - iselExpr64 -) - -where - -import GhcPrelude - -import {-# SOURCE #-} SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.CodeGen.Amode -import SPARC.Regs -import SPARC.AddrMode -import SPARC.Imm -import SPARC.Instr --- import SPARC.Ppr() -import NCGMonad -import Instruction -import Format -import Reg - -import Cmm - -import DynFlags -import OrdList -import Outputable - --- | Code to assign a 64 bit value to memory. -assignMem_I64Code - :: CmmExpr -- ^ expr producing the destination address - -> CmmExpr -- ^ expr producing the source value. - -> NatM InstrBlock - -assignMem_I64Code addrTree valueTree - = do - ChildCode64 vcode rlo <- iselExpr64 valueTree - - (src, acode) <- getSomeReg addrTree - let - rhi = getHiVRegFromLo rlo - - -- Big-endian store - mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0)) - mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4)) - - code = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo - -{- pprTrace "assignMem_I64Code" - (vcat [ text "addrTree: " <+> ppr addrTree - , text "valueTree: " <+> ppr valueTree - , text "vcode:" - , vcat $ map ppr $ fromOL vcode - , text "" - , text "acode:" - , vcat $ map ppr $ fromOL acode ]) - $ -} - return code - - --- | Code to assign a 64 bit value to a register. -assignReg_I64Code - :: CmmReg -- ^ the destination register - -> CmmExpr -- ^ expr producing the source value - -> NatM InstrBlock - -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree - = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk) - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - - return (vcode `snocOL` mov_hi `snocOL` mov_lo) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(sparc): invalid lvalue" - - - - --- | Get the value of an expression into a 64 bit register. - -iselExpr64 :: CmmExpr -> NatM ChildCode64 - --- Load a 64 bit word -iselExpr64 (CmmLoad addrTree ty) - | isWord64 ty - = do Amode amode addr_code <- getAmode addrTree - let result - - | AddrRegReg r1 r2 <- amode - = do rlo <- getNewRegNat II32 - tmp <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ ADD False False r1 (RIReg r2) tmp - , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi - , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ]) - rlo - - | AddrRegImm r1 (ImmInt i) <- amode - = do rlo <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi - , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ]) - rlo - - | otherwise - = panic "SPARC.CodeGen.Gen64: no match" - - result - - --- Add a literal to a 64 bit integer -iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` toOL - [ ADD False True r1_lo (RIImm (ImmInteger i)) r_dst_lo - , ADD True False r1_hi (RIReg g0) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - --- Addition of II64 -iselExpr64 (CmmMachOp (MO_Add _) [e1, e2]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - ChildCode64 code2 r2_lo <- iselExpr64 e2 - let r2_hi = getHiVRegFromLo r2_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` code2 - `appOL` toOL - [ ADD False True r1_lo (RIReg r2_lo) r_dst_lo - , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) - | isWord64 ty - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = RegVirtual $ mkVirtualReg uq II32 - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - return ( - ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo - ) - --- Convert something into II64 -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - -- compute expr and load it into r_dst_lo - (a_reg, a_code) <- getSomeReg expr - - dflags <- getDynFlags - let platform = targetPlatform dflags - code = a_code - `appOL` toOL - [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr platform a_reg r_dst_lo ] - - return $ ChildCode64 code r_dst_lo - --- only W32 supported for now -iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - -- compute expr and load it into r_dst_lo - (a_reg, a_code) <- getSomeReg expr - - dflags <- getDynFlags - let platform = targetPlatform dflags - code = a_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi - , mkRegRegMoveInstr platform a_reg r_dst_lo ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 expr - = pprPanic "iselExpr64(sparc)" (ppr expr) diff --git a/nativeGen/SPARC/CodeGen/Sanity.hs b/nativeGen/SPARC/CodeGen/Sanity.hs deleted file mode 100644 --- a/nativeGen/SPARC/CodeGen/Sanity.hs +++ /dev/null @@ -1,69 +0,0 @@ --- | One ounce of sanity checking is worth 10000000000000000 ounces --- of staring blindly at assembly code trying to find the problem.. -module SPARC.CodeGen.Sanity ( - checkBlock -) - -where - -import GhcPrelude - -import SPARC.Instr -import SPARC.Ppr () -- For Outputable instances -import Instruction - -import Cmm - -import Outputable - - --- | Enforce intra-block invariants. --- -checkBlock :: CmmBlock - -> NatBasicBlock Instr - -> NatBasicBlock Instr - -checkBlock cmm block@(BasicBlock _ instrs) - | checkBlockInstrs instrs - = block - - | otherwise - = pprPanic - ("SPARC.CodeGen: bad block\n") - ( vcat [ text " -- cmm -----------------\n" - , ppr cmm - , text " -- native code ---------\n" - , ppr block ]) - - -checkBlockInstrs :: [Instr] -> Bool -checkBlockInstrs ii - - -- An unconditional jumps end the block. - -- There must be an unconditional jump in the block, otherwise - -- the register liveness determinator will get the liveness - -- information wrong. - -- - -- If the block ends with a cmm call that never returns - -- then there can be unreachable instructions after the jump, - -- but we don't mind here. - -- - | instr : NOP : _ <- ii - , isUnconditionalJump instr - = True - - -- All jumps must have a NOP in their branch delay slot. - -- The liveness determinator and register allocators aren't smart - -- enough to handle branch delay slots. - -- - | instr : NOP : is <- ii - , isJumpishInstr instr - = checkBlockInstrs is - - -- keep checking - | _:i2:is <- ii - = checkBlockInstrs (i2:is) - - -- this block is no good - | otherwise - = False diff --git a/nativeGen/SPARC/Cond.hs b/nativeGen/SPARC/Cond.hs deleted file mode 100644 --- a/nativeGen/SPARC/Cond.hs +++ /dev/null @@ -1,54 +0,0 @@ -module SPARC.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned -) - -where - -import GhcPrelude - --- | Branch condition codes. -data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | NEVER - | POS - | VC - | VS - deriving Eq - - -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x diff --git a/nativeGen/SPARC/Imm.hs b/nativeGen/SPARC/Imm.hs deleted file mode 100644 --- a/nativeGen/SPARC/Imm.hs +++ /dev/null @@ -1,67 +0,0 @@ -module SPARC.Imm ( - -- immediate values - Imm(..), - strImmLit, - litToImm -) - -where - -import GhcPrelude - -import Cmm -import CLabel - -import Outputable - --- | An immediate value. --- Not all of these are directly representable by the machine. --- Things like ImmLit are slurped out and put in a data segment instead. --- -data Imm - = ImmInt Int - - -- Sigh. - | ImmInteger Integer - - -- AbstractC Label (with baggage) - | ImmCLbl CLabel - - -- Simple string - | ImmLit SDoc - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - - | LO Imm - | HI Imm - - --- | Create a ImmLit containing this string. -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - --- | Convert a CmmLit to an Imm. --- Narrow to the width: a CmmInt might be out of --- range, but we assume that ImmInteger only contains --- in-range values. A signed value should be fine here. --- -litToImm :: CmmLit -> Imm -litToImm lit - = case lit of - CmmInt i w -> ImmInteger (narrowS w i) - CmmFloat f W32 -> ImmFloat f - CmmFloat f W64 -> ImmDouble f - CmmLabel l -> ImmCLbl l - CmmLabelOff l off -> ImmIndex l off - - CmmLabelDiffOff l1 l2 off _ - -> ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) - - _ -> panic "SPARC.Regs.litToImm: no match" diff --git a/nativeGen/SPARC/Instr.hs b/nativeGen/SPARC/Instr.hs deleted file mode 100644 --- a/nativeGen/SPARC/Instr.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ -#include "HsVersions.h" - -module SPARC.Instr ( - RI(..), - riZero, - - fpRelEA, - moveSp, - - isUnconditionalJump, - - Instr(..), - maxSpillSlots -) - -where - -import GhcPrelude - -import SPARC.Stack -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Cond -import SPARC.Regs -import SPARC.Base -import TargetReg -import Instruction -import RegClass -import Reg -import Format - -import CLabel -import GHC.Platform.Regs -import BlockId -import DynFlags -import Cmm -import FastString -import Outputable -import GHC.Platform - - --- | Register or immediate -data RI - = RIReg Reg - | RIImm Imm - --- | Check if a RI represents a zero value. --- - a literal zero --- - register %g0, which is always zero. --- -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (RegReal (RealRegSingle 0))) = True -riZero _ = False - - --- | Calculate the effective address which would be used by the --- corresponding fpRel sequence. -fpRelEA :: Int -> Reg -> Instr -fpRelEA n dst - = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst - - --- | Code to shift the stack pointer by n words. -moveSp :: Int -> Instr -moveSp n - = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp - --- | An instruction that will cause the one after it never to be exectuted -isUnconditionalJump :: Instr -> Bool -isUnconditionalJump ii - = case ii of - CALL{} -> True - JMP{} -> True - JMP_TBL{} -> True - BI ALWAYS _ _ -> True - BF ALWAYS _ _ -> True - _ -> False - - --- | instance for sparc instruction set -instance Instruction Instr where - regUsageOfInstr = sparc_regUsageOfInstr - patchRegsOfInstr = sparc_patchRegsOfInstr - isJumpishInstr = sparc_isJumpishInstr - jumpDestsOfInstr = sparc_jumpDestsOfInstr - patchJumpInstr = sparc_patchJumpInstr - mkSpillInstr = sparc_mkSpillInstr - mkLoadInstr = sparc_mkLoadInstr - takeDeltaInstr = sparc_takeDeltaInstr - isMetaInstr = sparc_isMetaInstr - mkRegRegMoveInstr = sparc_mkRegRegMoveInstr - takeRegRegMoveInstr = sparc_takeRegRegMoveInstr - mkJumpInstr = sparc_mkJumpInstr - mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" - mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" - - --- | SPARC instruction set. --- Not complete. This is only the ones we need. --- -data Instr - - -- meta ops -------------------------------------------------- - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code generation. - -- Will be extracted before pretty-printing. - | LDATA Section CmmStatics - - -- Start a new basic block. Useful during codegen, removed later. - -- Preceding instruction should be a jump, as per the invariants - -- for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for benefit of subsequent passes. - | DELTA Int - - -- real instrs ----------------------------------------------- - -- Loads and stores. - | LD Format AddrMode Reg -- format, src, dst - | ST Format Reg AddrMode -- format, src, dst - - -- Int Arithmetic. - -- x: add/sub with carry bit. - -- In SPARC V9 addx and friends were renamed addc. - -- - -- cc: modify condition codes - -- - | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - - | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst - | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst - - - -- The SPARC divide instructions perform 64bit by 32bit division - -- The Y register is xored into the first operand. - - -- On _some implementations_ the Y register is overwritten by - -- the remainder, so we have to make sure it is 0 each time. - - -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 - | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst - | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst - - | RDY Reg -- move contents of Y register to reg - | WRY Reg Reg -- Y <- src1 `xor` src2 - - -- Logic operations. - | AND Bool Reg RI Reg -- cc?, src1, src2, dst - | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst - | OR Bool Reg RI Reg -- cc?, src1, src2, dst - | ORN Bool Reg RI Reg -- cc?, src1, src2, dst - | XOR Bool Reg RI Reg -- cc?, src1, src2, dst - | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst - | SLL Reg RI Reg -- src1, src2, dst - | SRL Reg RI Reg -- src1, src2, dst - | SRA Reg RI Reg -- src1, src2, dst - - -- Load immediates. - | SETHI Imm Reg -- src, dst - - -- Do nothing. - -- Implemented by the assembler as SETHI 0, %g0, but worth an alias - | NOP - - -- Float Arithmetic. - -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single - -- instructions right up until we spit them out. - -- - | FABS Format Reg Reg -- src dst - | FADD Format Reg Reg Reg -- src1, src2, dst - | FCMP Bool Format Reg Reg -- exception?, src1, src2, dst - | FDIV Format Reg Reg Reg -- src1, src2, dst - | FMOV Format Reg Reg -- src, dst - | FMUL Format Reg Reg Reg -- src1, src2, dst - | FNEG Format Reg Reg -- src, dst - | FSQRT Format Reg Reg -- src, dst - | FSUB Format Reg Reg Reg -- src1, src2, dst - | FxTOy Format Format Reg Reg -- src, dst - - -- Jumping around. - | BI Cond Bool BlockId -- cond, annul?, target - | BF Cond Bool BlockId -- cond, annul?, target - - | JMP AddrMode -- target - - -- With a tabled jump we know all the possible destinations. - -- We also need this info so we can work out what regs are live across the jump. - -- - | JMP_TBL AddrMode [Maybe BlockId] CLabel - - | CALL (Either Imm Reg) Int Bool -- target, args, terminal - - --- | regUsage returns the sets of src and destination registers used --- by a particular instruction. Machine registers that are --- pre-allocated to stgRegs are filtered out, because they are --- uninteresting from a register allocation standpoint. (We wouldn't --- want them to end up on the free list!) As far as we are concerned, --- the fixed registers simply don't exist (for allocation purposes, --- anyway). - --- regUsage doesn't need to do any trickery for jumps and such. Just --- state precisely the regs read and written by that insn. The --- consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. --- -sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage -sparc_regUsageOfInstr platform instr - = case instr of - LD _ addr reg -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - RDY rd -> usage ([], [rd]) - WRY r1 r2 -> usage ([r1, r2], []) - AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SETHI _ reg -> usage ([], [reg]) - FABS _ r1 r2 -> usage ([r1], [r2]) - FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FCMP _ _ r1 r2 -> usage ([r1, r2], []) - FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV _ r1 r2 -> usage ([r1], [r2]) - FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FNEG _ r1 r2 -> usage ([r1], [r2]) - FSQRT _ r1 r2 -> usage ([r1], [r2]) - FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FxTOy _ _ r1 r2 -> usage ([r1], [r2]) - - JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ _ -> usage (regAddr addr, []) - - CALL (Left _ ) _ True -> noUsage - CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) - CALL (Right reg) _ True -> usage ([reg], []) - CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) - _ -> noUsage - - where - usage (src, dst) - = RU (filter (interesting platform) src) - (filter (interesting platform) dst) - - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] - - regRI (RIReg r) = [r] - regRI _ = [] - - --- | Interesting regs are virtuals, or ones that are allocatable --- by the register allocator. -interesting :: Platform -> Reg -> Bool -interesting platform reg - = case reg of - RegVirtual _ -> True - RegReal (RealRegSingle r1) -> freeReg platform r1 - RegReal (RealRegPair r1 _) -> freeReg platform r1 - - - --- | Apply a given mapping to tall the register references in this instruction. -sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -sparc_patchRegsOfInstr instr env = case instr of - LD fmt addr reg -> LD fmt (fixAddr addr) (env reg) - ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) - - ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) - SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) - UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) - SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) - UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) - SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) - RDY rd -> RDY (env rd) - WRY r1 r2 -> WRY (env r1) (env r2) - AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) - ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) - OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) - ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) - XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) - XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - - SETHI imm reg -> SETHI imm (env reg) - - FABS s r1 r2 -> FABS s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMOV s r1 r2 -> FMOV s (env r1) (env r2) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) - - JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l - - CALL (Left i) n t -> CALL (Left i) n t - CALL (Right r) n t -> CALL (Right (env r)) n t - _ -> instr - - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - --------------------------------------------------------------------------------- -sparc_isJumpishInstr :: Instr -> Bool -sparc_isJumpishInstr instr - = case instr of - BI{} -> True - BF{} -> True - JMP{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False - -sparc_jumpDestsOfInstr :: Instr -> [BlockId] -sparc_jumpDestsOfInstr insn - = case insn of - BI _ _ id -> [id] - BF _ _ id -> [id] - JMP_TBL _ ids _ -> [id | Just id <- ids] - _ -> [] - - -sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr -sparc_patchJumpInstr insn patchF - = case insn of - BI cc annul id -> BI cc annul (patchF id) - BF cc annul id -> BF cc annul (patchF id) - JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l - _ -> insn - - --------------------------------------------------------------------------------- --- | Make a spill instruction. --- On SPARC we spill below frame pointer leaving 2 words/spill -sparc_mkSpillInstr - :: DynFlags - -> Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr - -sparc_mkSpillInstr dflags reg _ slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - - in ST fmt reg (fpRel (negate off_w)) - - --- | Make a spill reload instruction. -sparc_mkLoadInstr - :: DynFlags - -> Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr - -sparc_mkLoadInstr dflags reg _ slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - - in LD fmt (fpRel (- off_w)) reg - - --------------------------------------------------------------------------------- --- | See if this instruction is telling us the current C stack delta -sparc_takeDeltaInstr - :: Instr - -> Maybe Int - -sparc_takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -sparc_isMetaInstr - :: Instr - -> Bool - -sparc_isMetaInstr instr - = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - - --- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. --- -sparc_mkRegRegMoveInstr - :: Platform - -> Reg - -> Reg - -> Instr - -sparc_mkRegRegMoveInstr platform src dst - | srcClass <- targetClassOfReg platform src - , dstClass <- targetClassOfReg platform dst - , srcClass == dstClass - = case srcClass of - RcInteger -> ADD False False src (RIReg g0) dst - RcDouble -> FMOV FF64 src dst - RcFloat -> FMOV FF32 src dst - - | otherwise - = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" - - --- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. --- -sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) -sparc_takeRegRegMoveInstr instr - = case instr of - ADD False False src (RIReg src2) dst - | g0 == src2 -> Just (src, dst) - - FMOV FF64 src dst -> Just (src, dst) - FMOV FF32 src dst -> Just (src, dst) - _ -> Nothing - - --- | Make an unconditional branch instruction. -sparc_mkJumpInstr - :: BlockId - -> [Instr] - -sparc_mkJumpInstr id - = [BI ALWAYS False id - , NOP] -- fill the branch delay slot. diff --git a/nativeGen/SPARC/Ppr.hs b/nativeGen/SPARC/Ppr.hs deleted file mode 100644 --- a/nativeGen/SPARC/Ppr.hs +++ /dev/null @@ -1,645 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module SPARC.Ppr ( - pprNatCmmDecl, - pprBasicBlock, - pprData, - pprInstr, - pprFormat, - pprImm, - pprDataItem -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import SPARC.Regs -import SPARC.Instr -import SPARC.Cond -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Base -import Instruction -import Reg -import Format -import PprBase - -import Cmm hiding (topInfoTable) -import PprCmm() -- For Outputable instances -import BlockId -import CLabel -import Hoopl.Label -import Hoopl.Collections - -import Unique ( pprUniqueAlways ) -import Outputable -import GHC.Platform -import FastString - --- ----------------------------------------------------------------------------- --- Printing this stuff out - -pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats - -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - case topInfoTable proc of - Nothing -> - -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock top_info) blocks) - - Just (Statics info_lbl _) -> - sdocWithPlatform $ \platform -> - (if platformHasSubsectionsViaSymbols platform - then pprSectionAlign dspSection $$ - ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then - -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> ppr info_lbl - <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) - else empty) - -dspSection :: Section -dspSection = Section Text $ - panic "subsections-via-symbols doesn't combine with split-sections" - -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) - = maybe_infotable $$ - pprLabel (blockLbl blockid) $$ - vcat (map pprInstr instrs) - where - maybe_infotable = case mapLookup blockid info_env of - Nothing -> empty - Just (Statics info_lbl info) -> - pprAlignForSection Text $$ - vcat (map pprData info) $$ - pprLabel info_lbl - - -pprDatas :: CmmStatics -> SDoc --- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) - | lbl == mkIndStaticInfoLabel - , let labelInd (CmmLabelOff l _) = Just l - labelInd (CmmLabel l) = Just l - labelInd _ = Nothing - , Just ind' <- labelInd ind - , alias `mayRedirectTo` ind' - = pprGloblDecl alias - $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) - -pprData :: CmmStatic -> SDoc -pprData (CmmString str) = pprBytes str -pprData (CmmUninitialised bytes) = text ".skip " <> int bytes -pprData (CmmStaticLit lit) = pprDataItem lit - -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".global " <> ppr lbl - -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl - = sdocWithPlatform $ \platform -> - if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> ppr lbl <> ptext (sLit ", @object") - else empty - -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl - $$ (ppr lbl <> char ':') - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance Outputable Instr where - ppr instr = pprInstr instr - - --- | Pretty print a register. -pprReg :: Reg -> SDoc -pprReg reg - = case reg of - RegVirtual vr - -> case vr of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - VirtualRegF u -> text "%vF_" <> pprUniqueAlways u - VirtualRegD u -> text "%vD_" <> pprUniqueAlways u - - - RegReal rr - -> case rr of - RealRegSingle r1 - -> pprReg_ofRegNo r1 - - RealRegPair r1 r2 - -> text "(" <> pprReg_ofRegNo r1 - <> vbar <> pprReg_ofRegNo r2 - <> text ")" - - - --- | Pretty print a register name, based on this register number. --- The definition has been unfolded so we get a jump-table in the --- object code. This function is called quite a lot when emitting --- the asm file.. --- -pprReg_ofRegNo :: Int -> SDoc -pprReg_ofRegNo i - = ptext - (case i of { - 0 -> sLit "%g0"; 1 -> sLit "%g1"; - 2 -> sLit "%g2"; 3 -> sLit "%g3"; - 4 -> sLit "%g4"; 5 -> sLit "%g5"; - 6 -> sLit "%g6"; 7 -> sLit "%g7"; - 8 -> sLit "%o0"; 9 -> sLit "%o1"; - 10 -> sLit "%o2"; 11 -> sLit "%o3"; - 12 -> sLit "%o4"; 13 -> sLit "%o5"; - 14 -> sLit "%o6"; 15 -> sLit "%o7"; - 16 -> sLit "%l0"; 17 -> sLit "%l1"; - 18 -> sLit "%l2"; 19 -> sLit "%l3"; - 20 -> sLit "%l4"; 21 -> sLit "%l5"; - 22 -> sLit "%l6"; 23 -> sLit "%l7"; - 24 -> sLit "%i0"; 25 -> sLit "%i1"; - 26 -> sLit "%i2"; 27 -> sLit "%i3"; - 28 -> sLit "%i4"; 29 -> sLit "%i5"; - 30 -> sLit "%i6"; 31 -> sLit "%i7"; - 32 -> sLit "%f0"; 33 -> sLit "%f1"; - 34 -> sLit "%f2"; 35 -> sLit "%f3"; - 36 -> sLit "%f4"; 37 -> sLit "%f5"; - 38 -> sLit "%f6"; 39 -> sLit "%f7"; - 40 -> sLit "%f8"; 41 -> sLit "%f9"; - 42 -> sLit "%f10"; 43 -> sLit "%f11"; - 44 -> sLit "%f12"; 45 -> sLit "%f13"; - 46 -> sLit "%f14"; 47 -> sLit "%f15"; - 48 -> sLit "%f16"; 49 -> sLit "%f17"; - 50 -> sLit "%f18"; 51 -> sLit "%f19"; - 52 -> sLit "%f20"; 53 -> sLit "%f21"; - 54 -> sLit "%f22"; 55 -> sLit "%f23"; - 56 -> sLit "%f24"; 57 -> sLit "%f25"; - 58 -> sLit "%f26"; 59 -> sLit "%f27"; - 60 -> sLit "%f28"; 61 -> sLit "%f29"; - 62 -> sLit "%f30"; 63 -> sLit "%f31"; - _ -> sLit "very naughty sparc register" }) - - --- | Pretty print a format for an instruction suffix. -pprFormat :: Format -> SDoc -pprFormat x - = ptext - (case x of - II8 -> sLit "ub" - II16 -> sLit "uh" - II32 -> sLit "" - II64 -> sLit "d" - FF32 -> sLit "" - FF64 -> sLit "d") - - --- | Pretty print a format for an instruction suffix. --- eg LD is 32bit on sparc, but LDD is 64 bit. -pprStFormat :: Format -> SDoc -pprStFormat x - = ptext - (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "" - II64 -> sLit "x" - FF32 -> sLit "" - FF64 -> sLit "d") - - - --- | Pretty print a condition code. -pprCond :: Cond -> SDoc -pprCond c - = ptext - (case c of - ALWAYS -> sLit "" - NEVER -> sLit "n" - GEU -> sLit "geu" - LU -> sLit "lu" - EQQ -> sLit "e" - GTT -> sLit "g" - GE -> sLit "ge" - GU -> sLit "gu" - LTT -> sLit "l" - LE -> sLit "le" - LEU -> sLit "leu" - NE -> sLit "ne" - NEG -> sLit "neg" - POS -> sLit "pos" - VC -> sLit "vc" - VS -> sLit "vs") - - --- | Pretty print an address mode. -pprAddr :: AddrMode -> SDoc -pprAddr am - = case am of - AddrRegReg r1 (RegReal (RealRegSingle 0)) - -> pprReg r1 - - AddrRegReg r1 r2 - -> hcat [ pprReg r1, char '+', pprReg r2 ] - - AddrRegImm r1 (ImmInt i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, int i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 (ImmInteger i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, integer i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 imm - -> hcat [ pprReg r1, char '+', pprImm imm ] - - --- | Pretty print an immediate value. -pprImm :: Imm -> SDoc -pprImm imm - = case imm of - ImmInt i -> int i - ImmInteger i -> integer i - ImmCLbl l -> ppr l - ImmIndex l i -> ppr l <> char '+' <> int i - ImmLit s -> s - - ImmConstantSum a b - -> pprImm a <> char '+' <> pprImm b - - ImmConstantDiff a b - -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen - - LO i - -> hcat [ text "%lo(", pprImm i, rparen ] - - HI i - -> hcat [ text "%hi(", pprImm i, rparen ] - - -- these should have been converted to bytes and placed - -- in the data section. - ImmFloat _ -> text "naughty float immediate" - ImmDouble _ -> text "naughty double immediate" - - --- | Pretty print a section \/ segment header. --- On SPARC all the data sections must be at least 8 byte aligned --- incase we store doubles in them. --- -pprSectionAlign :: Section -> SDoc -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - ptext (case seg of - Text -> sLit ".align 4" - Data -> sLit ".align 8" - ReadOnlyData -> sLit ".align 8" - RelocatableReadOnlyData - -> sLit ".align 8" - UninitialisedData -> sLit ".align 8" - ReadOnlyData16 -> sLit ".align 16" - -- TODO: This is copied from the ReadOnlyData case, but it can likely be - -- made more efficient. - CString -> sLit ".align 8" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section") - --- | Pretty print a data item. -pprDataItem :: CmmLit -> SDoc -pprDataItem lit - = sdocWithDynFlags $ \dflags -> - vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit) - where - imm = litToImm lit - - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] - - ppr_item FF32 (CmmFloat r _) - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] - ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm] - ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" - - --- | Pretty print an instruction. -pprInstr :: Instr -> SDoc - --- nuke comments. -pprInstr (COMMENT _) - = empty - -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) - --- Newblocks and LData should have been slurped out before producing the .s file. -pprInstr (NEWBLOCK _) - = panic "X86.Ppr.pprInstr: NEWBLOCK" - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - --- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand -pprInstr (LD FF64 _ reg) - | RegReal (RealRegSingle{}) <- reg - = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" - -pprInstr (LD format addr reg) - = hcat [ - text "\tld", - pprFormat format, - char '\t', - lbrack, - pprAddr addr, - pp_rbracket_comma, - pprReg reg - ] - --- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand -pprInstr (ST FF64 reg _) - | RegReal (RealRegSingle{}) <- reg - = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" - --- no distinction is made between signed and unsigned bytes on stores for the --- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), --- so we call a special-purpose pprFormat for ST.. -pprInstr (ST format reg addr) - = hcat [ - text "\tst", - pprStFormat format, - char '\t', - pprReg reg, - pp_comma_lbracket, - pprAddr addr, - rbrack - ] - - -pprInstr (ADD x cc reg1 ri reg2) - | not x && not cc && riZero ri - = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 - - -pprInstr (SUB x cc reg1 ri reg2) - | not x && cc && reg2 == g0 - = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ] - - | not x && not cc && riZero ri - = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 - -pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2 - -pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 - -pprInstr (OR b reg1 ri reg2) - | not b && reg1 == g0 - = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ] - in case ri of - RIReg rrr | rrr == reg2 -> empty - _ -> doit - - | otherwise - = pprRegRIReg (sLit "or") b reg1 ri reg2 - -pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2 - -pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2 -pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2 - -pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 -pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 -pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 - -pprInstr (RDY rd) = text "\trd\t%y," <> pprReg rd -pprInstr (WRY reg1 reg2) - = text "\twr\t" - <> pprReg reg1 - <> char ',' - <> pprReg reg2 - <> char ',' - <> text "%y" - -pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 -pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 -pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2 -pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2 - -pprInstr (SETHI imm reg) - = hcat [ - text "\tsethi\t", - pprImm imm, - comma, - pprReg reg - ] - -pprInstr NOP - = text "\tnop" - -pprInstr (FABS format reg1 reg2) - = pprFormatRegReg (sLit "fabs") format reg1 reg2 - -pprInstr (FADD format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3 - -pprInstr (FCMP e format reg1 reg2) - = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp") - format reg1 reg2 - -pprInstr (FDIV format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3 - -pprInstr (FMOV format reg1 reg2) - = pprFormatRegReg (sLit "fmov") format reg1 reg2 - -pprInstr (FMUL format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3 - -pprInstr (FNEG format reg1 reg2) - = pprFormatRegReg (sLit "fneg") format reg1 reg2 - -pprInstr (FSQRT format reg1 reg2) - = pprFormatRegReg (sLit "fsqrt") format reg1 reg2 - -pprInstr (FSUB format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3 - -pprInstr (FxTOy format1 format2 reg1 reg2) - = hcat [ - text "\tf", - ptext - (case format1 of - II32 -> sLit "ito" - FF32 -> sLit "sto" - FF64 -> sLit "dto" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - ptext - (case format2 of - II32 -> sLit "i\t" - II64 -> sLit "x\t" - FF32 -> sLit "s\t" - FF64 -> sLit "d\t" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - pprReg reg1, comma, pprReg reg2 - ] - - -pprInstr (BI cond b blockid) - = hcat [ - text "\tb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - ppr (blockLbl blockid) - ] - -pprInstr (BF cond b blockid) - = hcat [ - text "\tfb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - ppr (blockLbl blockid) - ] - -pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr -pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) - -pprInstr (CALL (Left imm) n _) - = hcat [ text "\tcall\t", pprImm imm, comma, int n ] - -pprInstr (CALL (Right reg) n _) - = hcat [ text "\tcall\t", pprReg reg, comma, int n ] - - --- | Pretty print a RI -pprRI :: RI -> SDoc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r - - --- | Pretty print a two reg instruction. -pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc -pprFormatRegReg name format reg1 reg2 - = hcat [ - char '\t', - ptext name, - (case format of - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), - - pprReg reg1, - comma, - pprReg reg2 - ] - - --- | Pretty print a three reg instruction. -pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc -pprFormatRegRegReg name format reg1 reg2 reg3 - = hcat [ - char '\t', - ptext name, - (case format of - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), - pprReg reg1, - comma, - pprReg reg2, - comma, - pprReg reg3 - ] - - --- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc -pprRegRIReg name b reg1 ri reg2 - = hcat [ - char '\t', - ptext name, - if b then text "cc\t" else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -{- -pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc -pprRIReg name b ri reg1 - = hcat [ - char '\t', - ptext name, - if b then text "cc\t" else char '\t', - pprRI ri, - comma, - pprReg reg1 - ] --} - -{- -pp_ld_lbracket :: SDoc -pp_ld_lbracket = text "\tld\t[" --} - -pp_rbracket_comma :: SDoc -pp_rbracket_comma = text "]," - - -pp_comma_lbracket :: SDoc -pp_comma_lbracket = text ",[" - - -pp_comma_a :: SDoc -pp_comma_a = text ",a" diff --git a/nativeGen/SPARC/Regs.hs b/nativeGen/SPARC/Regs.hs deleted file mode 100644 --- a/nativeGen/SPARC/Regs.hs +++ /dev/null @@ -1,259 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- ----------------------------------------------------------------------------- - -module SPARC.Regs ( - -- registers - showReg, - virtualRegSqueeze, - realRegSqueeze, - classOfRealReg, - allRealRegs, - - -- machine specific info - gReg, iReg, lReg, oReg, fReg, - fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, - - -- allocatable - allocatableRegs, - - -- args - argRegs, - allArgRegs, - callClobberedRegs, - - -- - mkVirtualReg, - regDotColor -) - -where - - -import GhcPrelude - -import GHC.Platform.SPARC -import Reg -import RegClass -import Format - -import Unique -import Outputable - -{- - The SPARC has 64 registers of interest; 32 integer registers and 32 - floating point registers. The mapping of STG registers to SPARC - machine registers is defined in StgRegs.h. We are, of course, - prepared for any eventuality. - - The whole fp-register pairing thing on sparcs is a huge nuisance. See - includes/stg/MachRegs.h for a description of what's going on - here. --} - - --- | Get the standard name for the register with this number. -showReg :: RegNo -> String -showReg n - | n >= 0 && n < 8 = "%g" ++ show n - | n >= 8 && n < 16 = "%o" ++ show (n-8) - | n >= 16 && n < 24 = "%l" ++ show (n-16) - | n >= 24 && n < 32 = "%i" ++ show (n-24) - | n >= 32 && n < 64 = "%f" ++ show (n-32) - | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" - - --- Get the register class of a certain real reg -classOfRealReg :: RealReg -> RegClass -classOfRealReg reg - = case reg of - RealRegSingle i - | i < 32 -> RcInteger - | otherwise -> RcFloat - - RealRegPair{} -> RcDouble - - --- | regSqueeze_class reg --- Calculate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int - -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcFloat - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 2 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 1 - _other -> 0 - - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int - -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcFloat - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 2 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 1 - - --- | All the allocatable registers in the machine, --- including register pairs. -allRealRegs :: [RealReg] -allRealRegs - = [ (RealRegSingle i) | i <- [0..63] ] - ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] - - --- | Get the regno for this sort of reg -gReg, lReg, iReg, oReg, fReg :: Int -> RegNo - -gReg x = x -- global regs -oReg x = (8 + x) -- output regs -lReg x = (16 + x) -- local regs -iReg x = (24 + x) -- input regs -fReg x = (32 + x) -- float regs - - --- | Some specific regs used by the code generator. -g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg - -f6 = RegReal (RealRegSingle (fReg 6)) -f8 = RegReal (RealRegSingle (fReg 8)) -f22 = RegReal (RealRegSingle (fReg 22)) -f26 = RegReal (RealRegSingle (fReg 26)) -f27 = RegReal (RealRegSingle (fReg 27)) - --- g0 is always zero, and writes to it vanish. -g0 = RegReal (RealRegSingle (gReg 0)) -g1 = RegReal (RealRegSingle (gReg 1)) -g2 = RegReal (RealRegSingle (gReg 2)) - --- FP, SP, int and float return (from C) regs. -fp = RegReal (RealRegSingle (iReg 6)) -sp = RegReal (RealRegSingle (oReg 6)) -o0 = RegReal (RealRegSingle (oReg 0)) -o1 = RegReal (RealRegSingle (oReg 1)) -f0 = RegReal (RealRegSingle (fReg 0)) -f1 = RegReal (RealRegSingle (fReg 1)) - --- | Produce the second-half-of-a-double register given the first half. -{- -fPair :: Reg -> Maybe Reg -fPair (RealReg n) - | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) - -fPair (VirtualRegD u) - = Just (VirtualRegHi u) - -fPair reg - = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) - Nothing --} - - --- | All the regs that the register allocator can allocate to, --- with the fixed use regs removed. --- -allocatableRegs :: [RealReg] -allocatableRegs - = let isFree rr - = case rr of - RealRegSingle r -> freeReg r - RealRegPair r1 r2 -> freeReg r1 && freeReg r2 - in filter isFree allRealRegs - - --- | The registers to place arguments for function calls, --- for some number of arguments. --- -argRegs :: RegNo -> [Reg] -argRegs r - = case r of - 0 -> [] - 1 -> map (RegReal . RealRegSingle . oReg) [0] - 2 -> map (RegReal . RealRegSingle . oReg) [0,1] - 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] - 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] - 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] - 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] - _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" - - --- | All all the regs that could possibly be returned by argRegs --- -allArgRegs :: [Reg] -allArgRegs - = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] - - --- These are the regs that we cannot assume stay alive over a C call. --- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 --- -callClobberedRegs :: [Reg] -callClobberedRegs - = map (RegReal . RealRegSingle) - ( oReg 7 : - [oReg i | i <- [0..5]] ++ - [gReg i | i <- [1..7]] ++ - [fReg i | i <- [0..31]] ) - - - --- | Make a virtual reg with this format. -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - | not (isFloatFormat format) - = VirtualRegI u - - | otherwise - = case format of - FF32 -> VirtualRegF u - FF64 -> VirtualRegD u - _ -> panic "mkVReg" - - -regDotColor :: RealReg -> SDoc -regDotColor reg - = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - _other -> text "green" diff --git a/nativeGen/SPARC/ShortcutJump.hs b/nativeGen/SPARC/ShortcutJump.hs deleted file mode 100644 --- a/nativeGen/SPARC/ShortcutJump.hs +++ /dev/null @@ -1,74 +0,0 @@ -module SPARC.ShortcutJump ( - JumpDest(..), getJumpDestBlockId, - canShortcut, - shortcutJump, - shortcutStatics, - shortBlockId -) - -where - -import GhcPrelude - -import SPARC.Instr -import SPARC.Imm - -import CLabel -import BlockId -import Cmm - -import Panic -import Outputable - -data JumpDest - = DestBlockId BlockId - | DestImm Imm - --- Debug Instance -instance Outputable JumpDest where - ppr (DestBlockId bid) = text "blk:" <> ppr bid - ppr (DestImm _bid) = text "imm:?" - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid -getJumpDestBlockId _ = Nothing - - -canShortcut :: Instr -> Maybe JumpDest -canShortcut _ = Nothing - - -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump _ other = other - - - -shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics -shortcutStatics fn (Statics lbl statics) - = Statics lbl $ map (shortcutStatic fn) statics - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId - | otherwise = lab - -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) --- slightly dodgy, we're ignoring the second label, but this --- works with the way we use CmmLabelDiffOff for jump tables now. -shortcutStatic _ other_static - = other_static - - -shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel -shortBlockId fn blockid = - case fn blockid of - Nothing -> blockLbl blockid - Just (DestBlockId blockid') -> shortBlockId fn blockid' - Just (DestImm (ImmCLbl lbl)) -> lbl - _other -> panic "shortBlockId" diff --git a/nativeGen/SPARC/Stack.hs b/nativeGen/SPARC/Stack.hs deleted file mode 100644 --- a/nativeGen/SPARC/Stack.hs +++ /dev/null @@ -1,59 +0,0 @@ -module SPARC.Stack ( - spRel, - fpRel, - spillSlotToOffset, - maxSpillSlots -) - -where - -import GhcPrelude - -import SPARC.AddrMode -import SPARC.Regs -import SPARC.Base -import SPARC.Imm - -import DynFlags -import Outputable - --- | Get an AddrMode relative to the address in sp. --- This gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. --- -spRel :: Int -- ^ stack offset in words, positive or negative - -> AddrMode - -spRel n = AddrRegImm sp (ImmInt (n * wordLength)) - - --- | Get an address relative to the frame pointer. --- This doesn't work work for offsets greater than 13 bits; we just hope for the best --- -fpRel :: Int -> AddrMode -fpRel n - = AddrRegImm fp (ImmInt (n * wordLength)) - - --- | Convert a spill slot number to a *byte* offset, with no sign. --- -spillSlotToOffset :: DynFlags -> Int -> Int -spillSlotToOffset dflags slot - | slot >= 0 && slot < maxSpillSlots dflags - = 64 + spillSlotSize * slot - - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) - - --- | The maximum number of spill slots available on the C stack. --- If we use up all of the slots, then we're screwed. --- --- Why do we reserve 64 bytes, instead of using the whole thing?? --- -- BL 2009/02/15 --- -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 diff --git a/nativeGen/TargetReg.hs b/nativeGen/TargetReg.hs deleted file mode 100644 --- a/nativeGen/TargetReg.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE CPP #-} --- | Hard wired things related to registers. --- This is module is preventing the native code generator being able to --- emit code for non-host architectures. --- --- TODO: Do a better job of the overloading, and eliminate this module. --- We'd probably do better with a Register type class, and hook this to --- Instruction somehow. --- --- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable -module TargetReg ( - targetVirtualRegSqueeze, - targetRealRegSqueeze, - targetClassOfRealReg, - targetMkVirtualReg, - targetRegDotColor, - targetClassOfReg -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import Reg -import RegClass -import Format - -import Outputable -import Unique -import GHC.Platform - -import qualified X86.Regs as X86 -import qualified X86.RegInfo as X86 - -import qualified PPC.Regs as PPC - -import qualified SPARC.Regs as SPARC - -targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int -targetVirtualRegSqueeze platform - = case platformArch platform of - ArchX86 -> X86.virtualRegSqueeze - ArchX86_64 -> X86.virtualRegSqueeze - ArchPPC -> PPC.virtualRegSqueeze - ArchS390X -> panic "targetVirtualRegSqueeze ArchS390X" - ArchSPARC -> SPARC.virtualRegSqueeze - ArchSPARC64 -> panic "targetVirtualRegSqueeze ArchSPARC64" - ArchPPC_64 _ -> PPC.virtualRegSqueeze - ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" - ArchAArch64 -> panic "targetVirtualRegSqueeze ArchAArch64" - ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" - ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" - ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" - ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" - ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" - - -targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int -targetRealRegSqueeze platform - = case platformArch platform of - ArchX86 -> X86.realRegSqueeze - ArchX86_64 -> X86.realRegSqueeze - ArchPPC -> PPC.realRegSqueeze - ArchS390X -> panic "targetRealRegSqueeze ArchS390X" - ArchSPARC -> SPARC.realRegSqueeze - ArchSPARC64 -> panic "targetRealRegSqueeze ArchSPARC64" - ArchPPC_64 _ -> PPC.realRegSqueeze - ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" - ArchAArch64 -> panic "targetRealRegSqueeze ArchAArch64" - ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" - ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" - ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" - ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" - ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" - -targetClassOfRealReg :: Platform -> RealReg -> RegClass -targetClassOfRealReg platform - = case platformArch platform of - ArchX86 -> X86.classOfRealReg platform - ArchX86_64 -> X86.classOfRealReg platform - ArchPPC -> PPC.classOfRealReg - ArchS390X -> panic "targetClassOfRealReg ArchS390X" - ArchSPARC -> SPARC.classOfRealReg - ArchSPARC64 -> panic "targetClassOfRealReg ArchSPARC64" - ArchPPC_64 _ -> PPC.classOfRealReg - ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" - ArchAArch64 -> panic "targetClassOfRealReg ArchAArch64" - ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" - ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" - ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" - ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" - ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" - -targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg -targetMkVirtualReg platform - = case platformArch platform of - ArchX86 -> X86.mkVirtualReg - ArchX86_64 -> X86.mkVirtualReg - ArchPPC -> PPC.mkVirtualReg - ArchS390X -> panic "targetMkVirtualReg ArchS390X" - ArchSPARC -> SPARC.mkVirtualReg - ArchSPARC64 -> panic "targetMkVirtualReg ArchSPARC64" - ArchPPC_64 _ -> PPC.mkVirtualReg - ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" - ArchAArch64 -> panic "targetMkVirtualReg ArchAArch64" - ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" - ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" - ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" - ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" - ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" - -targetRegDotColor :: Platform -> RealReg -> SDoc -targetRegDotColor platform - = case platformArch platform of - ArchX86 -> X86.regDotColor platform - ArchX86_64 -> X86.regDotColor platform - ArchPPC -> PPC.regDotColor - ArchS390X -> panic "targetRegDotColor ArchS390X" - ArchSPARC -> SPARC.regDotColor - ArchSPARC64 -> panic "targetRegDotColor ArchSPARC64" - ArchPPC_64 _ -> PPC.regDotColor - ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" - ArchAArch64 -> panic "targetRegDotColor ArchAArch64" - ArchAlpha -> panic "targetRegDotColor ArchAlpha" - ArchMipseb -> panic "targetRegDotColor ArchMipseb" - ArchMipsel -> panic "targetRegDotColor ArchMipsel" - ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" - ArchUnknown -> panic "targetRegDotColor ArchUnknown" - - -targetClassOfReg :: Platform -> Reg -> RegClass -targetClassOfReg platform reg - = case reg of - RegVirtual vr -> classOfVirtualReg vr - RegReal rr -> targetClassOfRealReg platform rr diff --git a/nativeGen/X86/CodeGen.hs b/nativeGen/X86/CodeGen.hs deleted file mode 100644 --- a/nativeGen/X86/CodeGen.hs +++ /dev/null @@ -1,3903 +0,0 @@ -{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} - -#if __GLASGOW_HASKELL__ <= 808 --- GHC 8.10 deprecates this flag, but GHC 8.8 needs it --- The default iteration limit is a bit too low for the definitions --- in this module. -{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} -#endif - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ - --- This is a big module, but, if you pay attention to --- (a) the sectioning, and (b) the type signatures, the --- structure should not be too overwhelming. - -module X86.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - extractUnwindPoints, - invertCondBranches, - InstrBlock -) - -where - -#include "HsVersions.h" - --- NCG stuff: -import GhcPrelude - -import X86.Instr -import X86.Cond -import X86.Regs -import X86.Ppr ( ) -import X86.RegInfo - -import GHC.Platform.Regs -import CPrim -import Debug ( DebugBlock(..), UnwindPoint(..), UnwindTable - , UnwindExpr(UwReg), toUnwindExpr ) -import Instruction -import PIC -import NCGMonad ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat - , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat - , getPicBaseMaybeNat, getDebugBlock, getFileId - , addImmediateSuccessorNat, updateCfgNat) -import CFG -import Format -import Reg -import GHC.Platform - --- Our intermediate code: -import BasicTypes -import BlockId -import Module ( primUnitId ) -import CmmUtils -import CmmSwitch -import Cmm -import Hoopl.Block -import Hoopl.Collections -import Hoopl.Graph -import Hoopl.Label -import CLabel -import CoreSyn ( Tickish(..) ) -import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) - --- The rest: -import ForeignCall ( CCallConv(..) ) -import OrdList -import Outputable -import FastString -import DynFlags -import Util -import UniqSupply ( getUniqueM ) - -import Control.Monad -import Data.Bits -import Data.Foldable (fold) -import Data.Int -import Data.Maybe -import Data.Word - -import qualified Data.Map as M - -is32BitPlatform :: NatM Bool -is32BitPlatform = do - dflags <- getDynFlags - return $ target32Bit (targetPlatform dflags) - -sse2Enabled :: NatM Bool -sse2Enabled = do - dflags <- getDynFlags - case platformArch (targetPlatform dflags) of - -- We Assume SSE1 and SSE2 operations are available on both - -- x86 and x86_64. Historically we didn't default to SSE2 and - -- SSE1 on x86, which results in defacto nondeterminism for how - -- rounding behaves in the associated x87 floating point instructions - -- because variations in the spill/fpu stack placement of arguments for - -- operations would change the precision and final result of what - -- would otherwise be the same expressions with respect to single or - -- double precision IEEE floating point computations. - ArchX86_64 -> return True - ArchX86 -> return True - _ -> panic "trying to generate x86/x86_64 on the wrong platform" - - -sse4_2Enabled :: NatM Bool -sse4_2Enabled = do - dflags <- getDynFlags - return (isSse4_2Enabled dflags) - - -cmmTopCodeGen - :: RawCmmDecl - -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] - -cmmTopCodeGen (CmmProc info lab live graph) = do - let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlags - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - tops = proc : concat statics - os = platformOS $ targetPlatform dflags - - case picBaseMb of - Just picBase -> initializePicBase_x86 ArchX86 os picBase tops - Nothing -> return tops - -cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic - -{- Note [Verifying basic blocks] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - We want to guarantee a few things about the results - of instruction selection. - - Namely that each basic blocks consists of: - * A (potentially empty) sequence of straight line instructions - followed by - * A (potentially empty) sequence of jump like instructions. - - We can verify this by going through the instructions and - making sure that any non-jumpish instruction can't appear - after a jumpish instruction. - - There are gotchas however: - * CALLs are strictly speaking control flow but here we care - not about them. Hence we treat them as regular instructions. - - It's safe for them to appear inside a basic block - as (ignoring side effects inside the call) they will result in - straight line code. - - * NEWBLOCK marks the start of a new basic block so can - be followed by any instructions. --} - --- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally. -verifyBasicBlock :: [Instr] -> () -verifyBasicBlock instrs - | debugIsOn = go False instrs - | otherwise = () - where - go _ [] = () - go atEnd (i:instr) - = case i of - -- Start a new basic block - NEWBLOCK {} -> go False instr - -- Calls are not viable block terminators - CALL {} | atEnd -> faultyBlockWith i - | not atEnd -> go atEnd instr - -- All instructions ok, check if we reached the end and continue. - _ | not atEnd -> go (isJumpishInstr i) instr - -- Only jumps allowed at the end of basic blocks. - | otherwise -> if isJumpishInstr i - then go True instr - else faultyBlockWith i - faultyBlockWith i - = pprPanic "Non control flow instructions after end of basic block." - (ppr i <+> text "in:" $$ vcat (map ppr instrs)) - -basicBlockCodeGen - :: CmmBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl (Alignment, CmmStatics) Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - -- Generate location directive - dbg <- getDebugBlock (entryLabel block) - loc_instrs <- case dblSourceTick =<< dbg of - Just (SourceNote span name) - -> do fileId <- getFileId (srcSpanFile span) - let line = srcSpanStartLine span; col = srcSpanStartCol span - return $ unitOL $ LOCATION fileId line col name - _ -> return nilOL - (mid_instrs,mid_bid) <- stmtsToInstrs id stmts - (!tail_instrs,_) <- stmtToInstrs mid_bid tail - let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs - return $! verifyBasicBlock (fromOL instrs) - instrs' <- fold <$> traverse addSpUnwindings instrs - -- code generation may introduce new basic block boundaries, which - -- are indicated by the NEWBLOCK instruction. We must split up the - -- instruction stream into basic blocks again. Also, we extract - -- LDATAs here too. - let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs' - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - return (BasicBlock id top : other_blocks, statics) - --- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes --- in the @sp@ register. See Note [What is this unwinding business?] in Debug --- for details. -addSpUnwindings :: Instr -> NatM (OrdList Instr) -addSpUnwindings instr@(DELTA d) = do - dflags <- getDynFlags - if debugLevel dflags >= 1 - then do lbl <- mkAsmTempLabel <$> getUniqueM - let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d) - return $ toOL [ instr, UNWIND lbl unwind ] - else return (unitOL instr) -addSpUnwindings instr = return $ unitOL instr - -{- Note [Keeping track of the current block] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When generating instructions for Cmm we sometimes require -the current block for things like retry loops. - -We also sometimes change the current block, if a MachOP -results in branching control flow. - -Issues arise if we have two statements in the same block, -which both depend on the current block id *and* change the -basic block after them. This happens for atomic primops -in the X86 backend where we want to update the CFG data structure -when introducing new basic blocks. - -For example in #17334 we got this Cmm code: - - c3Bf: // global - (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18); - (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0); - _s3sT::I64 = _s3sV::I64; - goto c3B1; - -This resulted in two new basic blocks being inserted: - - c3Bf: - movl $18,%vI_n3Bo - movq 88(%vI_s3sQ),%rax - jmp _n3Bp - n3Bp: - ... - cmpxchgq %vI_n3Bq,88(%vI_s3sQ) - jne _n3Bp - ... - jmp _n3Bs - n3Bs: - ... - cmpxchgq %vI_n3Bt,88(%vI_s3sQ) - jne _n3Bs - ... - jmp _c3B1 - ... - -Based on the Cmm we called stmtToInstrs we translated both atomic operations under -the assumption they would be placed into their Cmm basic block `c3Bf`. -However for the retry loop we introduce new labels, so this is not the case -for the second statement. -This resulted in a desync between the explicit control flow graph -we construct as a separate data type and the actual control flow graph in the code. - -Instead we now return the new basic block if a statement causes a change -in the current block and use the block for all following statements. - -For this reason genCCall is also split into two parts. One for calls which -*won't* change the basic blocks in which successive instructions will be -placed (since they only evaluate CmmExpr, which can only contain MachOps, which -cannot introduce basic blocks in their lowerings). A different one for calls -which *are* known to change the basic block. - --} - --- See Note [Keeping track of the current block] for why --- we pass the BlockId. -stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in. - -> [CmmNode O O] -- ^ Cmm Statement - -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction -stmtsToInstrs bid stmts = - go bid stmts nilOL - where - go bid [] instrs = return (instrs,bid) - go bid (s:stmts) instrs = do - (instrs',bid') <- stmtToInstrs bid s - -- If the statement introduced a new block, we use that one - let !newBid = fromMaybe bid bid' - go newBid stmts (instrs `appOL` instrs') - --- | `bid` refers to the current block and is used to update the CFG --- if new blocks are inserted in the control flow. --- See Note [Keeping track of the current block] for more details. -stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in. - -> CmmNode e x - -> NatM (InstrBlock, Maybe BlockId) - -- ^ Instructions, and bid of new block if successive - -- statements are placed in a different basic block. -stmtToInstrs bid stmt = do - dflags <- getDynFlags - is32Bit <- is32BitPlatform - case stmt of - CmmUnsafeForeignCall target result_regs args - -> genCCall dflags is32Bit target result_regs args bid - - _ -> (,Nothing) <$> case stmt of - CmmComment s -> return (unitOL (COMMENT s)) - CmmTick {} -> return nilOL - - CmmUnwind regs -> do - let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable - to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr) - case foldMap to_unwind_entry regs of - tbl | M.null tbl -> return nilOL - | otherwise -> do - lbl <- mkAsmTempLabel <$> getUniqueM - return $ unitOL $ UNWIND lbl tbl - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | is32Bit && isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType dflags reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | is32Bit && isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType dflags src - format = cmmTypeFormat ty - - CmmBranch id -> return $ genBranch id - - --We try to arrange blocks such that the likely branch is the fallthrough - --in CmmContFlowOpt. So we can assume the condition is likely false here. - CmmCondBranch arg true false _ -> genCondBranch bid true false arg - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids - CmmCall { cml_target = arg - , cml_args_regs = gregs } -> do - dflags <- getDynFlags - genJump arg (jumpRegs dflags gregs) - _ -> - panic "stmtToInstrs: statement should have been cps'd away" - - -jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] -jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] - where platform = targetPlatform dflags - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Condition codes passed up the tree. --- -data CondCode - = CondCode Bool Cond InstrBlock - - --- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. --- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified --- -data ChildCode64 - = ChildCode64 - InstrBlock - Reg - - --- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - -swizzleRegisterRep :: Register -> Format -> Register -swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code -swizzleRegisterRep (Any _ codefn) format = Any format codefn - - --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated - let fmt = cmmTypeFormat pk in - RegVirtual (mkVirtualReg u fmt) - -getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal $ reg - Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence ... - - --- | Memory addressing modes passed up the tree. -data Amode - = Amode AddrMode InstrBlock - -{- -Now, given a tree (the argument to a CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - - --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = blockLbl blockid - - --- ----------------------------------------------------------------------------- --- General things for putting together code sequences - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr -mangleIndexTree dflags reg off - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) - --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - - -assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_I64Code addrTree valueTree = do - Amode addr addr_code <- getAmode addrTree - ChildCode64 vcode rlo <- iselExpr64 valueTree - let - rhi = getHiVRegFromLo rlo - - -- Little-endian store - mov_lo = MOV II32 (OpReg rlo) (OpAddr addr) - mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) - return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) - - -assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo) - mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi) - return ( - vcode `snocOL` mov_lo `snocOL` mov_hi - ) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(i386): invalid lvalue" - - -iselExpr64 :: CmmExpr -> NatM ChildCode64 -iselExpr64 (CmmLit (CmmInt i _)) = do - (rlo,rhi) <- getNewRegPairNat II32 - let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) - code = toOL [ - MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) - ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do - Amode addr addr_code <- getAmode addrTree - (rlo,rhi) <- getNewRegPairNat II32 - let - mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) - mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) - return ( - ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) - rlo - ) - -iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty - = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) - --- we handle addition, but rather badly -iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - (rlo,rhi) <- getNewRegPairNat II32 - let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) - r1hi = getHiVRegFromLo r1lo - code = code1 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpReg r2lo) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpReg r2hi) (OpReg rhi) ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do - ChildCode64 code1 r1lo <- iselExpr64 e1 - ChildCode64 code2 r2lo <- iselExpr64 e2 - (rlo,rhi) <- getNewRegPairNat II32 - let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - SUB II32 (OpReg r2lo) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - SBB II32 (OpReg r2hi) (OpReg rhi) ] - return (ChildCode64 code rlo) - -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do - fn <- getAnyReg expr - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - code = fn r_dst_lo - return ( - ChildCode64 (code `snocOL` - MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi)) - r_dst_lo - ) - -iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do - fn <- getAnyReg expr - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - code = fn r_dst_lo - return ( - ChildCode64 (code `snocOL` - MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL` - CLTD II32 `snocOL` - MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL` - MOV II32 (OpReg edx) (OpReg r_dst_hi)) - r_dst_lo - ) - -iselExpr64 expr - = pprPanic "iselExpr64(i386)" (ppr expr) - - --------------------------------------------------------------------------------- -getRegister :: CmmExpr -> NatM Register -getRegister e = do dflags <- getDynFlags - is32Bit <- is32BitPlatform - getRegister' dflags is32Bit e - -getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register - -getRegister' dflags is32Bit (CmmReg reg) - = case reg of - CmmGlobal PicBaseReg - | is32Bit -> - -- on x86_64, we have %rip for PicBaseReg, but it's not - -- a full-featured register, it can only be used for - -- rip-relative addressing. - do reg' <- getPicBaseNat (archWordFormat is32Bit) - return (Fixed (archWordFormat is32Bit) reg' nilOL) - _ -> - do - let - fmt = cmmTypeFormat (cmmRegType dflags reg) - format = fmt - -- - let platform = targetPlatform dflags - return (Fixed format - (getRegisterReg platform reg) - nilOL) - - -getRegister' dflags is32Bit (CmmRegOff r n) - = getRegister' dflags is32Bit $ mangleIndexTree dflags r n - -getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e]) - = addAlignmentCheck align <$> getRegister' dflags is32Bit e - --- for 32-bit architectures, support some 64 -> 32 bit conversions: --- TO_W_(x), TO_W_(x >> 32) - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) - | is32Bit = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister' _ _ (CmmLit lit@(CmmFloat f w)) = - float_const_sse2 where - float_const_sse2 - | f == 0.0 = do - let - format = floatFormat w - code dst = unitOL (XOR format (OpReg dst) (OpReg dst)) - -- I don't know why there are xorpd, xorps, and pxor instructions. - -- They all appear to do the same thing --SDM - return (Any format code) - - | otherwise = do - Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit - loadFloatAmode w addr code - --- catch simple cases of zero- or sign-extended load -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVZxL II8) addr - return (Any II32 code) - -getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVSxL II8) addr - return (Any II32 code) - -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVZxL II16) addr - return (Any II32 code) - -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do - code <- intLoadCode (MOVSxL II16) addr - return (Any II32 code) - --- catch simple cases of zero- or sign-extended load -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVZxL II8) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVSxL II8) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVZxL II16) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVSxL II16) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) - | not is32Bit = do - code <- intLoadCode (MOVSxL II32) addr - return (Any II64 code) - -getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), - CmmLit displacement]) - | not is32Bit = do - return $ Any II64 (\dst -> unitOL $ - LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) - -getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps - case mop of - MO_F_Neg w -> sse2NegCode w x - - - MO_S_Neg w -> triv_ucode NEGI (intFormat w) - MO_Not w -> triv_ucode NOT (intFormat w) - - -- Nop conversions - MO_UU_Conv W32 W8 -> toI8Reg W32 x - MO_SS_Conv W32 W8 -> toI8Reg W32 x - MO_XX_Conv W32 W8 -> toI8Reg W32 x - MO_UU_Conv W16 W8 -> toI8Reg W16 x - MO_SS_Conv W16 W8 -> toI8Reg W16 x - MO_XX_Conv W16 W8 -> toI8Reg W16 x - MO_UU_Conv W32 W16 -> toI16Reg W32 x - MO_SS_Conv W32 W16 -> toI16Reg W32 x - MO_XX_Conv W32 W16 -> toI16Reg W32 x - - MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x - MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x - MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x - MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x - MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x - MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x - MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x - MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x - MO_XX_Conv W64 W8 | not is32Bit -> toI8Reg W64 x - - MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x - MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x - MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x - - -- widenings - MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x - MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x - MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x - - MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x - MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x - MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x - - -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we - -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register - -- has 8-bit version). So for 32-bit code, we'll just zero-extend. - MO_XX_Conv W8 W32 - | is32Bit -> integerExtend W8 W32 MOVZxL x - | otherwise -> integerExtend W8 W32 MOV x - MO_XX_Conv W8 W16 - | is32Bit -> integerExtend W8 W16 MOVZxL x - | otherwise -> integerExtend W8 W16 MOV x - MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x - - MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x - MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x - MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x - MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x - MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x - MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x - -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl. - -- However, we don't want the register allocator to throw it - -- away as an unnecessary reg-to-reg move, so we keep it in - -- the form of a movzl and print it as a movl later. - -- This doesn't apply to MO_XX_Conv since in this case we don't care about - -- the upper bits. So we can just use MOV. - MO_XX_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOV x - MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x - MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x - - MO_FF_Conv W32 W64 -> coerceFP2FP W64 x - - - MO_FF_Conv W64 W32 -> coerceFP2FP W32 x - - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - MO_V_Insert {} -> needLlvm - MO_V_Extract {} -> needLlvm - MO_V_Add {} -> needLlvm - MO_V_Sub {} -> needLlvm - MO_V_Mul {} -> needLlvm - MO_VS_Quot {} -> needLlvm - MO_VS_Rem {} -> needLlvm - MO_VS_Neg {} -> needLlvm - MO_VU_Quot {} -> needLlvm - MO_VU_Rem {} -> needLlvm - MO_VF_Insert {} -> needLlvm - MO_VF_Extract {} -> needLlvm - MO_VF_Add {} -> needLlvm - MO_VF_Sub {} -> needLlvm - MO_VF_Mul {} -> needLlvm - MO_VF_Quot {} -> needLlvm - MO_VF_Neg {} -> needLlvm - - _other -> pprPanic "getRegister" (pprMachOp mop) - where - triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register - triv_ucode instr format = trivialUCode format (instr format) x - - -- signed or unsigned extension. - integerExtend :: Width -> Width - -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr -> NatM Register - integerExtend from to instr expr = do - (reg,e_code) <- if from == W8 then getByteReg expr - else getSomeReg expr - let - code dst = - e_code `snocOL` - instr (intFormat from) (OpReg reg) (OpReg dst) - return (Any (intFormat to) code) - - toI8Reg :: Width -> CmmExpr -> NatM Register - toI8Reg new_rep expr - = do codefn <- getAnyReg expr - return (Any (intFormat new_rep) codefn) - -- HACK: use getAnyReg to get a byte-addressable register. - -- If the source was a Fixed register, this will add the - -- mov instruction to put it into the desired destination. - -- We're assuming that the destination won't be a fixed - -- non-byte-addressable register; it won't be, because all - -- fixed registers are word-sized. - - toI16Reg = toI8Reg -- for now - - conversionNop :: Format -> CmmExpr -> NatM Register - conversionNop new_format expr - = do e_code <- getRegister' dflags is32Bit expr - return (swizzleRegisterRep e_code new_format) - - -getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps - case mop of - MO_F_Eq _ -> condFltReg is32Bit EQQ x y - MO_F_Ne _ -> condFltReg is32Bit NE x y - MO_F_Gt _ -> condFltReg is32Bit GTT x y - MO_F_Ge _ -> condFltReg is32Bit GE x y - -- Invert comparison condition and swap operands - -- See Note [SSE Parity Checks] - MO_F_Lt _ -> condFltReg is32Bit GTT y x - MO_F_Le _ -> condFltReg is32Bit GE y x - - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt _ -> condIntReg GU x y - MO_U_Ge _ -> condIntReg GEU x y - MO_U_Lt _ -> condIntReg LU x y - MO_U_Le _ -> condIntReg LEU x y - - MO_F_Add w -> trivialFCode_sse2 w ADD x y - - MO_F_Sub w -> trivialFCode_sse2 w SUB x y - - MO_F_Quot w -> trivialFCode_sse2 w FDIV x y - - MO_F_Mul w -> trivialFCode_sse2 w MUL x y - - - MO_Add rep -> add_code rep x y - MO_Sub rep -> sub_code rep x y - - MO_S_Quot rep -> div_code rep True True x y - MO_S_Rem rep -> div_code rep True False x y - MO_U_Quot rep -> div_code rep False True x y - MO_U_Rem rep -> div_code rep False False x y - - MO_S_MulMayOflo rep -> imulMayOflo rep x y - - MO_Mul W8 -> imulW8 x y - MO_Mul rep -> triv_op rep IMUL - MO_And rep -> triv_op rep AND - MO_Or rep -> triv_op rep OR - MO_Xor rep -> triv_op rep XOR - - {- Shift ops on x86s have constraints on their source, it - either has to be Imm, CL or 1 - => trivialCode is not restrictive enough (sigh.) - -} - MO_Shl rep -> shift_code rep SHL x y {-False-} - MO_U_Shr rep -> shift_code rep SHR x y {-False-} - MO_S_Shr rep -> shift_code rep SAR x y {-False-} - - MO_V_Insert {} -> needLlvm - MO_V_Extract {} -> needLlvm - MO_V_Add {} -> needLlvm - MO_V_Sub {} -> needLlvm - MO_V_Mul {} -> needLlvm - MO_VS_Quot {} -> needLlvm - MO_VS_Rem {} -> needLlvm - MO_VS_Neg {} -> needLlvm - MO_VF_Insert {} -> needLlvm - MO_VF_Extract {} -> needLlvm - MO_VF_Add {} -> needLlvm - MO_VF_Sub {} -> needLlvm - MO_VF_Mul {} -> needLlvm - MO_VF_Quot {} -> needLlvm - MO_VF_Neg {} -> needLlvm - - _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) - where - -------------------- - triv_op width instr = trivialCode width op (Just op) x y - where op = instr (intFormat width) - - -- Special case for IMUL for bytes, since the result of IMULB will be in - -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider - -- values. - imulW8 :: CmmExpr -> CmmExpr -> NatM Register - imulW8 arg_a arg_b = do - (a_reg, a_code) <- getNonClobberedReg arg_a - b_code <- getAnyReg arg_b - - let code = a_code `appOL` b_code eax `appOL` - toOL [ IMUL2 format (OpReg a_reg) ] - format = intFormat W8 - - return (Fixed format eax code) - - - imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register - imulMayOflo rep a b = do - (a_reg, a_code) <- getNonClobberedReg a - b_code <- getAnyReg b - let - shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - format = intFormat rep - code = a_code `appOL` b_code eax `appOL` - toOL [ - IMUL2 format (OpReg a_reg), -- result in %edx:%eax - SAR format (OpImm (ImmInt shift_amt)) (OpReg eax), - -- sign extend lower part - SUB format (OpReg edx) (OpReg eax) - -- compare against upper - -- eax==0 if high part == sign extended low part - ] - return (Fixed format eax code) - - -------------------- - shift_code :: Width - -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - - {- Case1: shift length as immediate -} - shift_code width instr x (CmmLit lit) = do - x_code <- getAnyReg x - let - format = intFormat width - code dst - = x_code dst `snocOL` - instr format (OpImm (litToImm lit)) (OpReg dst) - return (Any format code) - - {- Case2: shift length is complex (non-immediate) - * y must go in %ecx. - * we cannot do y first *and* put its result in %ecx, because - %ecx might be clobbered by x. - * if we do y second, then x cannot be - in a clobbered reg. Also, we cannot clobber x's reg - with the instruction itself. - * so we can either: - - do y first, put its result in a fresh tmp, then copy it to %ecx later - - do y second and put its result into %ecx. x gets placed in a fresh - tmp. This is likely to be better, because the reg alloc can - eliminate this reg->reg move here (it won't eliminate the other one, - because the move is into the fixed %ecx). - * in the case of C calls the use of ecx here can interfere with arguments. - We avoid this with the hack described in Note [Evaluate C-call - arguments before placing in destination registers] - -} - shift_code width instr x y{-amount-} = do - x_code <- getAnyReg x - let format = intFormat width - tmp <- getNewRegNat format - y_code <- getAnyReg y - let - code = x_code tmp `appOL` - y_code ecx `snocOL` - instr format (OpReg ecx) (OpReg tmp) - return (Fixed format tmp code) - - -------------------- - add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register - add_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger y = add_int rep x y - add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y - where format = intFormat rep - -- TODO: There are other interesting patterns we want to replace - -- with a LEA, e.g. `(x + offset) + (y << shift)`. - - -------------------- - sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register - sub_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger (-y) = add_int rep x (-y) - sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y - - -- our three-operand add instruction: - add_int width x y = do - (x_reg, x_code) <- getSomeReg x - let - format = intFormat width - imm = ImmInt (fromInteger y) - code dst - = x_code `snocOL` - LEA format - (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) - (OpReg dst) - -- - return (Any format code) - - ---------------------- - - -- See Note [DIV/IDIV for bytes] - div_code W8 signed quotient x y = do - let widen | signed = MO_SS_Conv W8 W16 - | otherwise = MO_UU_Conv W8 W16 - div_code - W16 - signed - quotient - (CmmMachOp widen [x]) - (CmmMachOp widen [y]) - - div_code width signed quotient x y = do - (y_op, y_code) <- getRegOrMem y -- cannot be clobbered - x_code <- getAnyReg x - let - format = intFormat width - widen | signed = CLTD format - | otherwise = XOR format (OpReg edx) (OpReg edx) - - instr | signed = IDIV - | otherwise = DIV - - code = y_code `appOL` - x_code eax `appOL` - toOL [widen, instr format y_op] - - result | quotient = eax - | otherwise = edx - - return (Fixed format result code) - - -getRegister' _ _ (CmmLoad mem pk) - | isFloatType pk - = do - Amode addr mem_code <- getAmode mem - loadFloatAmode (typeWidth pk) addr mem_code - -getRegister' _ is32Bit (CmmLoad mem pk) - | is32Bit && not (isWord64 pk) - = do - code <- intLoadCode instr mem - return (Any format code) - where - width = typeWidth pk - format = intFormat width - instr = case width of - W8 -> MOVZxL II8 - _other -> MOV format - -- We always zero-extend 8-bit loads, if we - -- can't think of anything better. This is because - -- we can't guarantee access to an 8-bit variant of every register - -- (esi and edi don't have 8-bit variants), so to make things - -- simpler we do our 8-bit arithmetic with full 32-bit registers. - --- Simpler memory load code on x86_64 -getRegister' _ is32Bit (CmmLoad mem pk) - | not is32Bit - = do - code <- intLoadCode (MOV format) mem - return (Any format code) - where format = intFormat $ typeWidth pk - -getRegister' _ is32Bit (CmmLit (CmmInt 0 width)) - = let - format = intFormat width - - -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits - format1 = if is32Bit then format - else case format of - II64 -> II32 - _ -> format - code dst - = unitOL (XOR format1 (OpReg dst) (OpReg dst)) - in - return (Any format code) - - -- optimisation for loading small literals on x86_64: take advantage - -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit - -- instruction forms are shorter. -getRegister' dflags is32Bit (CmmLit lit) - | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit) - = let - imm = litToImm lit - code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) - in - return (Any II64 code) - where - isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff - isBigLit _ = False - -- note1: not the same as (not.is32BitLit), because that checks for - -- signed literals that fit in 32 bits, but we want unsigned - -- literals here. - -- note2: all labels are small, because we're assuming the - -- small memory model (see gcc docs, -mcmodel=small). - -getRegister' dflags _ (CmmLit lit) - = do let format = cmmTypeFormat (cmmLitType dflags lit) - imm = litToImm lit - code dst = unitOL (MOV format (OpImm imm) (OpReg dst)) - return (Any format code) - -getRegister' _ _ other - | isVecExpr other = needLlvm - | otherwise = pprPanic "getRegister(x86)" (ppr other) - - -intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr - -> NatM (Reg -> InstrBlock) -intLoadCode instr mem = do - Amode src mem_code <- getAmode mem - return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst)) - --- Compute an expression into *any* register, adding the appropriate --- move instruction if necessary. -getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock) -getAnyReg expr = do - r <- getRegister expr - anyReg r - -anyReg :: Register -> NatM (Reg -> InstrBlock) -anyReg (Any _ code) = return code -anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst) - --- A bit like getSomeReg, but we want a reg that can be byte-addressed. --- Fixed registers might not be byte-addressable, so we make sure we've --- got a temporary, inserting an extra reg copy if necessary. -getByteReg :: CmmExpr -> NatM (Reg, InstrBlock) -getByteReg expr = do - is32Bit <- is32BitPlatform - if is32Bit - then do r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed rep reg code - | isVirtualReg reg -> return (reg,code) - | otherwise -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - -- ToDo: could optimise slightly by checking for - -- byte-addressable real registers, but that will - -- happen very rarely if at all. - else getSomeReg expr -- all regs are byte-addressable on x86_64 - --- Another variant: this time we want the result in a register that cannot --- be modified by code to evaluate an arbitrary expression. -getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) -getNonClobberedReg expr = do - dflags <- getDynFlags - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed rep reg code - -- only certain regs can be clobbered - | reg `elem` instrClobberedRegs (targetPlatform dflags) - -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - | otherwise -> - return (reg, code) - -reg2reg :: Format -> Reg -> Reg -> Instr -reg2reg format src dst = MOV format (OpReg src) (OpReg dst) - - --------------------------------------------------------------------------------- -getAmode :: CmmExpr -> NatM Amode -getAmode e = do is32Bit <- is32BitPlatform - getAmode' is32Bit e - -getAmode' :: Bool -> CmmExpr -> NatM Amode -getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags - getAmode $ mangleIndexTree dflags r n - -getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), - CmmLit displacement]) - | not is32Bit - = return $ Amode (ripRel (litToImm displacement)) nilOL - - --- This is all just ridiculous, since it carefully undoes --- what mangleIndexTree has just done. -getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]) - | is32BitLit is32Bit lit - -- ASSERT(rep == II32)??? - = do (x_reg, x_code) <- getSomeReg x - let off = ImmInt (-(fromInteger i)) - return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) - -getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit]) - | is32BitLit is32Bit lit - -- ASSERT(rep == II32)??? - = do (x_reg, x_code) <- getSomeReg x - let off = litToImm lit - return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) - --- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be --- recognised by the next rule. -getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), - b@(CmmLit _)]) - = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a]) - --- Matches: (x + offset) + (y << shift) -getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset, - CmmMachOp (MO_Shl _) - [y, CmmLit (CmmInt shift _)]]) - | shift == 0 || shift == 1 || shift == 2 || shift == 3 - = x86_complex_amode (CmmReg x) y shift (fromIntegral offset) - -getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) - [y, CmmLit (CmmInt shift _)]]) - | shift == 0 || shift == 1 || shift == 2 || shift == 3 - = x86_complex_amode x y shift 0 - -getAmode' _ (CmmMachOp (MO_Add _) - [x, CmmMachOp (MO_Add _) - [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)], - CmmLit (CmmInt offset _)]]) - | shift == 0 || shift == 1 || shift == 2 || shift == 3 - && is32BitInteger offset - = x86_complex_amode x y shift offset - -getAmode' _ (CmmMachOp (MO_Add _) [x,y]) - = x86_complex_amode x y 0 0 - -getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit - = return (Amode (ImmAddr (litToImm lit) 0) nilOL) - -getAmode' _ expr = do - (reg,code) <- getSomeReg expr - return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) - --- | Like 'getAmode', but on 32-bit use simple register addressing --- (i.e. no index register). This stops us from running out of --- registers on x86 when using instructions such as cmpxchg, which can --- use up to three virtual registers and one fixed register. -getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode -getSimpleAmode dflags is32Bit addr - | is32Bit = do - addr_code <- getAnyReg addr - addr_r <- getNewRegNat (intFormat (wordWidth dflags)) - let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) - return $! Amode amode (addr_code addr_r) - | otherwise = getAmode addr - -x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode -x86_complex_amode base index shift offset - = do (x_reg, x_code) <- getNonClobberedReg base - -- x must be in a temp, because it has to stay live over y_code - -- we could compre x_reg and y_reg and do something better here... - (y_reg, y_code) <- getSomeReg index - let - code = x_code `appOL` y_code - base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; - n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" - return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) - code) - - - - --- ----------------------------------------------------------------------------- --- getOperand: sometimes any operand will do. - --- getNonClobberedOperand: the value of the operand will remain valid across --- the computation of an arbitrary expression, unless the expression --- is computed directly into a register which the operand refers to --- (see trivialCode where this function is used for an example). - -getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) -getNonClobberedOperand (CmmLit lit) = do - if isSuitableFloatingPointLit lit - then do - let CmmFloat _ w = lit - Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit - return (OpAddr addr, code) - else do - - is32Bit <- is32BitPlatform - dflags <- getDynFlags - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) - then return (OpImm (litToImm lit), nilOL) - else getNonClobberedOperand_generic (CmmLit lit) - -getNonClobberedOperand (CmmLoad mem pk) = do - is32Bit <- is32BitPlatform - -- this logic could be simplified - -- TODO FIXME - if (if is32Bit then not (isWord64 pk) else True) - -- if 32bit and pk is at float/double/simd value - -- or if 64bit - -- this could use some eyeballs or i'll need to stare at it more later - then do - dflags <- getDynFlags - let platform = targetPlatform dflags - Amode src mem_code <- getAmode mem - (src',save_code) <- - if (amodeCouldBeClobbered platform src) - then do - tmp <- getNewRegNat (archWordFormat is32Bit) - return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), - unitOL (LEA (archWordFormat is32Bit) - (OpAddr src) - (OpReg tmp))) - else - return (src, nilOL) - return (OpAddr src', mem_code `appOL` save_code) - else do - -- if its a word or gcptr on 32bit? - getNonClobberedOperand_generic (CmmLoad mem pk) - -getNonClobberedOperand e = getNonClobberedOperand_generic e - -getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) -getNonClobberedOperand_generic e = do - (reg, code) <- getNonClobberedReg e - return (OpReg reg, code) - -amodeCouldBeClobbered :: Platform -> AddrMode -> Bool -amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) - -regClobbered :: Platform -> Reg -> Bool -regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr -regClobbered _ _ = False - --- getOperand: the operand is not required to remain valid across the --- computation of an arbitrary expression. -getOperand :: CmmExpr -> NatM (Operand, InstrBlock) - -getOperand (CmmLit lit) = do - use_sse2 <- sse2Enabled - if (use_sse2 && isSuitableFloatingPointLit lit) - then do - let CmmFloat _ w = lit - Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit - return (OpAddr addr, code) - else do - - is32Bit <- is32BitPlatform - dflags <- getDynFlags - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) - then return (OpImm (litToImm lit), nilOL) - else getOperand_generic (CmmLit lit) - -getOperand (CmmLoad mem pk) = do - is32Bit <- is32BitPlatform - use_sse2 <- sse2Enabled - if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) - then do - Amode src mem_code <- getAmode mem - return (OpAddr src, mem_code) - else - getOperand_generic (CmmLoad mem pk) - -getOperand e = getOperand_generic e - -getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) -getOperand_generic e = do - (reg, code) <- getSomeReg e - return (OpReg reg, code) - -isOperand :: Bool -> CmmExpr -> Bool -isOperand _ (CmmLoad _ _) = True -isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit - || isSuitableFloatingPointLit lit -isOperand _ _ = False - --- | Given a 'Register', produce a new 'Register' with an instruction block --- which will check the value for alignment. Used for @-falignment-sanitisation@. -addAlignmentCheck :: Int -> Register -> Register -addAlignmentCheck align reg = - case reg of - Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg) - Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt reg) - where - check :: Format -> Reg -> InstrBlock - check fmt reg = - ASSERT(not $ isFloatFormat fmt) - toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg) - , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel - ] - -memConstant :: Alignment -> CmmLit -> NatM Amode -memConstant align lit = do - lbl <- getNewLabelNat - let rosection = Section ReadOnlyData lbl - dflags <- getDynFlags - (addr, addr_code) <- if target32Bit (targetPlatform dflags) - then do dynRef <- cmmMakeDynamicReference - dflags - DataReference - lbl - Amode addr addr_code <- getAmode dynRef - return (addr, addr_code) - else return (ripRel (ImmCLbl lbl), nilOL) - let code = - LDATA rosection (align, Statics lbl [CmmStaticLit lit]) - `consOL` addr_code - return (Amode addr code) - - -loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register -loadFloatAmode w addr addr_code = do - let format = floatFormat w - code dst = addr_code `snocOL` - MOV format (OpAddr addr) (OpReg dst) - - return (Any format code) - - --- if we want a floating-point literal as an operand, we can --- use it directly from memory. However, if the literal is --- zero, we're better off generating it into a register using --- xor. -isSuitableFloatingPointLit :: CmmLit -> Bool -isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0 -isSuitableFloatingPointLit _ = False - -getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) -getRegOrMem e@(CmmLoad mem pk) = do - is32Bit <- is32BitPlatform - use_sse2 <- sse2Enabled - if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) - then do - Amode src mem_code <- getAmode mem - return (OpAddr src, mem_code) - else do - (reg, code) <- getNonClobberedReg e - return (OpReg reg, code) -getRegOrMem e = do - (reg, code) <- getNonClobberedReg e - return (OpReg reg, code) - -is32BitLit :: Bool -> CmmLit -> Bool -is32BitLit is32Bit (CmmInt i W64) - | not is32Bit - = -- assume that labels are in the range 0-2^31-1: this assumes the - -- small memory model (see gcc docs, -mcmodel=small). - is32BitInteger i -is32BitLit _ _ = True - - - - --- Set up a condition code for a conditional branch. - -getCondCode :: CmmExpr -> NatM CondCode - --- yes, they really do seem to want exactly the same! - -getCondCode (CmmMachOp mop [x, y]) - = - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - -- Invert comparison condition and swap operands - -- See Note [SSE Parity Checks] - MO_F_Lt W32 -> condFltCode GTT y x - MO_F_Le W32 -> condFltCode GE y x - - MO_F_Eq W64 -> condFltCode EQQ x y - MO_F_Ne W64 -> condFltCode NE x y - MO_F_Gt W64 -> condFltCode GTT x y - MO_F_Ge W64 -> condFltCode GE x y - MO_F_Lt W64 -> condFltCode GTT y x - MO_F_Le W64 -> condFltCode GE y x - - _ -> condIntCode (machOpToCond mop) x y - -getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) - -machOpToCond :: MachOp -> Cond -machOpToCond mo = case mo of - MO_Eq _ -> EQQ - MO_Ne _ -> NE - MO_S_Gt _ -> GTT - MO_S_Ge _ -> GE - MO_S_Lt _ -> LTT - MO_S_Le _ -> LE - MO_U_Gt _ -> GU - MO_U_Ge _ -> GEU - MO_U_Lt _ -> LU - MO_U_Le _ -> LEU - _other -> pprPanic "machOpToCond" (pprMachOp mo) - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condIntCode cond x y = do is32Bit <- is32BitPlatform - condIntCode' is32Bit cond x y - -condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode - --- memory vs immediate -condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit) - | is32BitLit is32Bit lit = do - Amode x_addr x_code <- getAmode x - let - imm = litToImm lit - code = x_code `snocOL` - CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr) - -- - return (CondCode False cond code) - --- anything vs zero, using a mask --- TODO: Add some sanity checking!!!! -condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk)) - | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit - = do - (x_reg, x_code) <- getSomeReg x - let - code = x_code `snocOL` - TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg) - -- - return (CondCode False cond code) - --- anything vs zero -condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do - (x_reg, x_code) <- getSomeReg x - let - code = x_code `snocOL` - TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg) - -- - return (CondCode False cond code) - --- anything vs operand -condIntCode' is32Bit cond x y - | isOperand is32Bit y = do - dflags <- getDynFlags - (x_reg, x_code) <- getNonClobberedReg x - (y_op, y_code) <- getOperand y - let - code = x_code `appOL` y_code `snocOL` - CMP (cmmTypeFormat (cmmExprType dflags x)) y_op (OpReg x_reg) - return (CondCode False cond code) --- operand vs. anything: invert the comparison so that we can use a --- single comparison instruction. - | isOperand is32Bit x - , Just revcond <- maybeFlipCond cond = do - dflags <- getDynFlags - (y_reg, y_code) <- getNonClobberedReg y - (x_op, x_code) <- getOperand x - let - code = y_code `appOL` x_code `snocOL` - CMP (cmmTypeFormat (cmmExprType dflags x)) x_op (OpReg y_reg) - return (CondCode False revcond code) - --- anything vs anything -condIntCode' _ cond x y = do - dflags <- getDynFlags - (y_reg, y_code) <- getNonClobberedReg y - (x_op, x_code) <- getRegOrMem x - let - code = y_code `appOL` - x_code `snocOL` - CMP (cmmTypeFormat (cmmExprType dflags x)) (OpReg y_reg) x_op - return (CondCode False cond code) - - - --------------------------------------------------------------------------------- -condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode - -condFltCode cond x y - = condFltCode_sse2 - where - - - -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be - -- an operand, but the right must be a reg. We can probably do better - -- than this general case... - condFltCode_sse2 = do - dflags <- getDynFlags - (x_reg, x_code) <- getNonClobberedReg x - (y_op, y_code) <- getOperand y - let - code = x_code `appOL` - y_code `snocOL` - CMP (floatFormat $ cmmExprWidth dflags x) y_op (OpReg x_reg) - -- NB(1): we need to use the unsigned comparison operators on the - -- result of this comparison. - return (CondCode True (condToUnsigned cond) code) - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock - - --- integer assignment to memory - --- specific case of adding/subtracting an integer to a particular address. --- ToDo: catch other cases where we can use an operation directly on a memory --- address. -assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _, - CmmLit (CmmInt i _)]) - | addr == addr2, pk /= II64 || is32BitInteger i, - Just instr <- check op - = do Amode amode code_addr <- getAmode addr - let code = code_addr `snocOL` - instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode) - return code - where - check (MO_Add _) = Just ADD - check (MO_Sub _) = Just SUB - check _ = Nothing - -- ToDo: more? - --- general case -assignMem_IntCode pk addr src = do - is32Bit <- is32BitPlatform - Amode addr code_addr <- getAmode addr - (code_src, op_src) <- get_op_RI is32Bit src - let - code = code_src `appOL` - code_addr `snocOL` - MOV pk op_src (OpAddr addr) - -- NOTE: op_src is stable, so it will still be valid - -- after code_addr. This may involve the introduction - -- of an extra MOV to a temporary register, but we hope - -- the register allocator will get rid of it. - -- - return code - where - get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator - get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit - = return (nilOL, OpImm (litToImm lit)) - get_op_RI _ op - = do (reg,code) <- getNonClobberedReg op - return (code, OpReg reg) - - --- Assign; dst is a reg, rhs is mem -assignReg_IntCode pk reg (CmmLoad src _) = do - load_code <- intLoadCode (MOV pk) src - dflags <- getDynFlags - let platform = targetPlatform dflags - return (load_code (getRegisterReg platform reg)) - --- dst is a reg, but src could be anything -assignReg_IntCode _ reg src = do - dflags <- getDynFlags - let platform = targetPlatform dflags - code <- getAnyReg src - return (code (getRegisterReg platform reg)) - - --- Floating point assignment to memory -assignMem_FltCode pk addr src = do - (src_reg, src_code) <- getNonClobberedReg src - Amode addr addr_code <- getAmode addr - let - code = src_code `appOL` - addr_code `snocOL` - MOV pk (OpReg src_reg) (OpAddr addr) - - return code - --- Floating point assignment to a register/temporary -assignReg_FltCode _ reg src = do - src_code <- getAnyReg src - dflags <- getDynFlags - let platform = targetPlatform dflags - return (src_code (getRegisterReg platform reg)) - - -genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock - -genJump (CmmLoad mem _) regs = do - Amode target code <- getAmode mem - return (code `snocOL` JMP (OpAddr target) regs) - -genJump (CmmLit lit) regs = do - return (unitOL (JMP (OpImm (litToImm lit)) regs)) - -genJump expr regs = do - (reg,code) <- getSomeReg expr - return (code `snocOL` JMP (OpReg reg) regs) - - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> InstrBlock -genBranch = toOL . mkJumpInstr - - - --- ----------------------------------------------------------------------------- --- Conditional jumps/branches - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -I386: First, we have to ensure that the condition -codes are set according to the supplied comparison operation. --} - -{- Note [64-bit integer comparisons on 32-bit] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - When doing these comparisons there are 2 kinds of - comparisons. - - * Comparison for equality (or lack thereof) - - We use xor to check if high/low bits are - equal. Then combine the results using or and - perform a single conditional jump based on the - result. - - * Other comparisons: - - We map all other comparisons to the >= operation. - Why? Because it's easy to encode it with a single - conditional jump. - - We do this by first computing [r1_lo - r2_lo] - and use the carry flag to compute - [r1_high - r2_high - CF]. - - At which point if r1 >= r2 then the result will be - positive. Otherwise negative so we can branch on this - condition. - --} - - -genCondBranch - :: BlockId -- the source of the jump - -> BlockId -- the true branch target - -> BlockId -- the false branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock -- Instructions - -genCondBranch bid id false expr = do - is32Bit <- is32BitPlatform - genCondBranch' is32Bit bid id false expr - --- | We return the instructions generated. -genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr - -> NatM InstrBlock - --- 64-bit integer comparisons on 32-bit --- See Note [64-bit integer comparisons on 32-bit] -genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2]) - | is32Bit, Just W64 <- maybeIntComparison mop = do - - -- The resulting registers here are both the lower part of - -- the register as well as a way to get at the higher part. - ChildCode64 code1 r1 <- iselExpr64 e1 - ChildCode64 code2 r2 <- iselExpr64 e2 - let cond = machOpToCond mop :: Cond - - let cmpCode = intComparison cond true false r1 r2 - return $ code1 `appOL` code2 `appOL` cmpCode - - where - intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock - intComparison cond true false r1_lo r2_lo = - case cond of - -- Impossible results of machOpToCond - ALWAYS -> panic "impossible" - NEG -> panic "impossible" - POS -> panic "impossible" - CARRY -> panic "impossible" - OFLO -> panic "impossible" - PARITY -> panic "impossible" - NOTPARITY -> panic "impossible" - -- Special case #1 x == y and x != y - EQQ -> cmpExact - NE -> cmpExact - -- [x >= y] - GE -> cmpGE - GEU -> cmpGE - -- [x > y] <==> ![y >= x] - GTT -> intComparison GE false true r2_lo r1_lo - GU -> intComparison GEU false true r2_lo r1_lo - -- [x <= y] <==> [y >= x] - LE -> intComparison GE true false r2_lo r1_lo - LEU -> intComparison GEU true false r2_lo r1_lo - -- [x < y] <==> ![x >= x] - LTT -> intComparison GE false true r1_lo r2_lo - LU -> intComparison GEU false true r1_lo r2_lo - where - r1_hi = getHiVRegFromLo r1_lo - r2_hi = getHiVRegFromLo r2_lo - cmpExact :: OrdList Instr - cmpExact = - toOL - [ XOR II32 (OpReg r2_hi) (OpReg r1_hi) - , XOR II32 (OpReg r2_lo) (OpReg r1_lo) - , OR II32 (OpReg r1_hi) (OpReg r1_lo) - , JXX cond true - , JXX ALWAYS false - ] - cmpGE = toOL - [ CMP II32 (OpReg r2_lo) (OpReg r1_lo) - , SBB II32 (OpReg r2_hi) (OpReg r1_hi) - , JXX cond true - , JXX ALWAYS false ] - -genCondBranch' _ bid id false bool = do - CondCode is_float cond cond_code <- getCondCode bool - use_sse2 <- sse2Enabled - if not is_float || not use_sse2 - then - return (cond_code `snocOL` JXX cond id `appOL` genBranch false) - else do - -- See Note [SSE Parity Checks] - let jmpFalse = genBranch false - code - = case cond of - NE -> or_unordered - GU -> plain_test - GEU -> plain_test - -- Use ASSERT so we don't break releases if - -- LTT/LE creep in somehow. - LTT -> - ASSERT2(False, ppr "Should have been turned into >") - and_ordered - LE -> - ASSERT2(False, ppr "Should have been turned into >=") - and_ordered - _ -> and_ordered - - plain_test = unitOL ( - JXX cond id - ) `appOL` jmpFalse - or_unordered = toOL [ - JXX cond id, - JXX PARITY id - ] `appOL` jmpFalse - and_ordered = toOL [ - JXX PARITY false, - JXX cond id, - JXX ALWAYS false - ] - updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false) - return (cond_code `appOL` code) - -{- Note [Introducing cfg edges inside basic blocks] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - During instruction selection a statement `s` - in a block B with control of the sort: B -> C - will sometimes result in control - flow of the sort: - - ┌ < ┐ - v ^ - B -> B1 ┴ -> C - - as is the case for some atomic operations. - - Now to keep the CFG in sync when introducing B1 we clearly - want to insert it between B and C. However there is - a catch when we have to deal with self loops. - - We might start with code and a CFG of these forms: - - loop: - stmt1 ┌ < ┐ - .... v ^ - stmtX loop ┘ - stmtY - .... - goto loop: - - Now we introduce B1: - ┌ ─ ─ ─ ─ ─┐ - loop: │ ┌ < ┐ │ - instrs v │ │ ^ - .... loop ┴ B1 ┴ ┘ - instrsFromX - stmtY - goto loop: - - This is simple, all outgoing edges from loop now simply - start from B1 instead and the code generator knows which - new edges it introduced for the self loop of B1. - - Disaster strikes if the statement Y follows the same pattern. - If we apply the same rule that all outgoing edges change then - we end up with: - - loop ─> B1 ─> B2 ┬─┐ - │ │ └─<┤ │ - │ └───<───┘ │ - └───────<────────┘ - - This is problematic. The edge B1->B1 is modified as expected. - However the modification is wrong! - - The assembly in this case looked like this: - - _loop: - - _B1: - ... - cmpxchgq ... - jne _B1 - - - _B2: - ... - cmpxchgq ... - jne _B2 - - jmp loop - - There is no edge _B2 -> _B1 here. It's still a self loop onto _B1. - - The problem here is that really B1 should be two basic blocks. - Otherwise we have control flow in the *middle* of a basic block. - A contradiction! - - So to account for this we add yet another basic block marker: - - _B: - - _B1: - ... - cmpxchgq ... - jne _B1 - jmp _B1' - _B1': - - - _B2: - ... - - Now when inserting B2 we will only look at the outgoing edges of B1' and - everything will work out nicely. - - You might also wonder why we don't insert jumps at the end of _B1'. There is - no way another block ends up jumping to the labels _B1 or _B2 since they are - essentially invisible to other blocks. View them as control flow labels local - to the basic block if you'd like. - - Not doing this ultimately caused (part 2 of) #17334. --} - - --- ----------------------------------------------------------------------------- --- Generating C calls - --- Now the biggest nightmare---calls. Most of the nastiness is buried in --- @get_arg@, which moves the arguments to the correct registers/stack --- locations. Apart from that, the code is easy. --- --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. --- --- See Note [Keeping track of the current block] for information why we need --- to take/return a block id. - -genCCall - :: DynFlags - -> Bool -- 32 bit platform? - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> BlockId -- The block we are in - -> NatM (InstrBlock, Maybe BlockId) - --- First we deal with cases which might introduce new blocks in the stream. - -genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) - [dst] [addr, n] bid = do - Amode amode addr_code <- - if amop `elem` [AMO_Add, AMO_Sub] - then getAmode addr - else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg - arg <- getNewRegNat format - arg_code <- getAnyReg n - let platform = targetPlatform dflags - dst_r = getRegisterReg platform (CmmLocal dst) - (code, lbl) <- op_code dst_r arg amode - return (addr_code `appOL` arg_code arg `appOL` code, Just lbl) - where - -- Code for the operation - op_code :: Reg -- Destination reg - -> Reg -- Register containing argument - -> AddrMode -- Address of location to mutate - -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId - op_code dst_r arg amode = case amop of - -- In the common case where dst_r is a virtual register the - -- final move should go away, because it's the last use of arg - -- and the first use of dst_r. - AMO_Add -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode)) - , MOV format (OpReg arg) (OpReg dst_r) - ], bid) - AMO_Sub -> return $ (toOL [ NEGI format (OpReg arg) - , LOCK (XADD format (OpReg arg) (OpAddr amode)) - , MOV format (OpReg arg) (OpReg dst_r) - ], bid) - -- In these cases we need a new block id, and have to return it so - -- that later instruction selection can reference it. - AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst) - AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst - , NOT format dst - ]) - AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst) - AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst) - where - -- Simulate operation that lacks a dedicated instruction using - -- cmpxchg. - cmpxchg_code :: (Operand -> Operand -> OrdList Instr) - -> NatM (OrdList Instr, BlockId) - cmpxchg_code instrs = do - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat - tmp <- getNewRegNat format - - --Record inserted blocks - -- We turn A -> B into A -> A' -> A'' -> B - -- with a self loop on A'. - addImmediateSuccessorNat bid lbl1 - addImmediateSuccessorNat lbl1 lbl2 - updateCfgNat (addWeightEdge lbl1 lbl1 0) - - return $ (toOL - [ MOV format (OpAddr amode) (OpReg eax) - , JXX ALWAYS lbl1 - , NEWBLOCK lbl1 - -- Keep old value so we can return it: - , MOV format (OpReg eax) (OpReg dst_r) - , MOV format (OpReg eax) (OpReg tmp) - ] - `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL - [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode)) - , JXX NE lbl1 - -- See Note [Introducing cfg edges inside basic blocks] - -- why this basic block is required. - , JXX ALWAYS lbl2 - , NEWBLOCK lbl2 - ], - lbl2) - format = intFormat width - -genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid - | is32Bit, width == W64 = do - ChildCode64 vcode rlo <- iselExpr64 src - let rhi = getHiVRegFromLo rlo - dst_r = getRegisterReg platform (CmmLocal dst) - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat - let format = if width == W8 then II16 else intFormat width - tmp_r <- getNewRegNat format - - -- New CFG Edges: - -- bid -> lbl2 - -- bid -> lbl1 -> lbl2 - -- We also changes edges originating at bid to start at lbl2 instead. - updateCfgNat (addWeightEdge bid lbl1 110 . - addWeightEdge lbl1 lbl2 110 . - addImmediateSuccessor bid lbl2) - - -- The following instruction sequence corresponds to the pseudo-code - -- - -- if (src) { - -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32); - -- } else { - -- dst = 64; - -- } - let !instrs = vcode `appOL` toOL - ([ MOV II32 (OpReg rhi) (OpReg tmp_r) - , OR II32 (OpReg rlo) (OpReg tmp_r) - , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r) - , JXX EQQ lbl2 - , JXX ALWAYS lbl1 - - , NEWBLOCK lbl1 - , BSF II32 (OpReg rhi) dst_r - , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r) - , BSF II32 (OpReg rlo) tmp_r - , CMOV NE II32 (OpReg tmp_r) dst_r - , JXX ALWAYS lbl2 - - , NEWBLOCK lbl2 - ]) - return (instrs, Just lbl2) - - | otherwise = do - code_src <- getAnyReg src - let dst_r = getRegisterReg platform (CmmLocal dst) - - if isBmi2Enabled dflags - then do - src_r <- getNewRegNat (intFormat width) - let instrs = appOL (code_src src_r) $ case width of - W8 -> toOL - [ OR II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r) - , TZCNT II32 (OpReg src_r) dst_r - ] - W16 -> toOL - [ TZCNT II16 (OpReg src_r) dst_r - , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) - ] - _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r - return (instrs, Nothing) - else do - -- The following insn sequence makes sure 'ctz 0' has a defined value. - -- starting with Haswell, one could use the TZCNT insn instead. - let format = if width == W8 then II16 else intFormat width - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - let !instrs = code_src src_r `appOL` toOL - ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ - [ BSF format (OpReg src_r) tmp_r - , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) - , CMOV NE format (OpReg tmp_r) dst_r - ]) -- NB: We don't need to zero-extend the result for the - -- W8/W16 cases because the 'MOV' insn already - -- took care of implicitly clearing the upper bits - return (instrs, Nothing) - where - bw = widthInBits width - platform = targetPlatform dflags - -genCCall dflags bits mop dst args bid = do - instr <- genCCall' dflags bits mop dst args bid - return (instr, Nothing) - --- genCCall' handles cases not introducing new code blocks. -genCCall' - :: DynFlags - -> Bool -- 32 bit platform? - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> BlockId -- The block we are in - -> NatM InstrBlock - --- Unroll memcpy calls if the number of bytes to copy isn't too --- large. Otherwise, call C's memcpy. -genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _ - [dst, src, CmmLit (CmmInt n _)] _ - | fromInteger insns <= maxInlineMemcpyInsns dflags = do - code_dst <- getAnyReg dst - dst_r <- getNewRegNat format - code_src <- getAnyReg src - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - return $ code_dst dst_r `appOL` code_src src_r `appOL` - go dst_r src_r tmp_r (fromInteger n) - where - -- The number of instructions we will generate (approx). We need 2 - -- instructions per move. - insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) - - maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported - effectiveAlignment = min (alignmentOf align) maxAlignment - format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment - - -- The size of each move, in bytes. - sizeBytes :: Integer - sizeBytes = fromIntegral (formatInBytes format) - - go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr - go dst src tmp i - | i >= sizeBytes = - unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - sizeBytes) - -- Deal with remaining bytes. - | i >= 4 = -- Will never happen on 32-bit - unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - 4) - | i >= 2 = - unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - 2) - | i >= 1 = - unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` - unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` - go dst src tmp (i - 1) - | otherwise = nilOL - where - src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone - (ImmInteger (n - i)) - dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone - (ImmInteger (n - i)) - -genCCall' dflags _ (PrimTarget (MO_Memset align)) _ - [dst, - CmmLit (CmmInt c _), - CmmLit (CmmInt n _)] - _ - | fromInteger insns <= maxInlineMemsetInsns dflags = do - code_dst <- getAnyReg dst - dst_r <- getNewRegNat format - if format == II64 && n >= 8 then do - code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64)) - imm8byte_r <- getNewRegNat II64 - return $ code_dst dst_r `appOL` - code_imm8byte imm8byte_r `appOL` - go8 dst_r imm8byte_r (fromInteger n) - else - return $ code_dst dst_r `appOL` - go4 dst_r (fromInteger n) - where - maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported - effectiveAlignment = min (alignmentOf align) maxAlignment - format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment - c2 = c `shiftL` 8 .|. c - c4 = c2 `shiftL` 16 .|. c2 - c8 = c4 `shiftL` 32 .|. c4 - - -- The number of instructions we will generate (approx). We need 1 - -- instructions per move. - insns = (n + sizeBytes - 1) `div` sizeBytes - - -- The size of each move, in bytes. - sizeBytes :: Integer - sizeBytes = fromIntegral (formatInBytes format) - - -- Depending on size returns the widest MOV instruction and its - -- width. - gen4 :: AddrMode -> Integer -> (InstrBlock, Integer) - gen4 addr size - | size >= 4 = - (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4) - | size >= 2 = - (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2) - | size >= 1 = - (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1) - | otherwise = (nilOL, 0) - - -- Generates a 64-bit wide MOV instruction from REG to MEM. - gen8 :: AddrMode -> Reg -> InstrBlock - gen8 addr reg8byte = - unitOL (MOV format (OpReg reg8byte) (OpAddr addr)) - - -- Unrolls memset when the widest MOV is <= 4 bytes. - go4 :: Reg -> Integer -> InstrBlock - go4 dst left = - if left <= 0 then nilOL - else curMov `appOL` go4 dst (left - curWidth) - where - possibleWidth = minimum [left, sizeBytes] - dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) - (curMov, curWidth) = gen4 dst_addr possibleWidth - - -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg - -- argument). Falls back to go4 when all 8 byte moves are - -- exhausted. - go8 :: Reg -> Reg -> Integer -> InstrBlock - go8 dst reg8byte left = - if possibleWidth >= 8 then - let curMov = gen8 dst_addr reg8byte - in curMov `appOL` go8 dst reg8byte (left - 8) - else go4 dst left - where - possibleWidth = minimum [left, sizeBytes] - dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) - -genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _ = return nilOL -genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL - -- barriers compile to no code on x86/x86-64; - -- we keep it this long in order to prevent earlier optimisations. - -genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL - -genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _ [src] _ = - case n of - 0 -> genPrefetch src $ PREFETCH NTA format - 1 -> genPrefetch src $ PREFETCH Lvl2 format - 2 -> genPrefetch src $ PREFETCH Lvl1 format - 3 -> genPrefetch src $ PREFETCH Lvl0 format - l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l) - -- the c / llvm prefetch convention is 0, 1, 2, and 3 - -- the x86 corresponding names are : NTA, 2 , 1, and 0 - where - format = archWordFormat is32bit - -- need to know what register width for pointers! - genPrefetch inRegSrc prefetchCTor = - do - code_src <- getAnyReg inRegSrc - src_r <- getNewRegNat format - return $ code_src src_r `appOL` - (unitOL (prefetchCTor (OpAddr - ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) )) - -- prefetch always takes an address - -genCCall' dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do - let platform = targetPlatform dflags - let dst_r = getRegisterReg platform (CmmLocal dst) - case width of - W64 | is32Bit -> do - ChildCode64 vcode rlo <- iselExpr64 src - let dst_rhi = getHiVRegFromLo dst_r - rhi = getHiVRegFromLo rlo - return $ vcode `appOL` - toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi), - MOV II32 (OpReg rhi) (OpReg dst_r), - BSWAP II32 dst_rhi, - BSWAP II32 dst_r ] - W16 -> do code_src <- getAnyReg src - return $ code_src dst_r `appOL` - unitOL (BSWAP II32 dst_r) `appOL` - unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r)) - _ -> do code_src <- getAnyReg src - return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r) - where - format = intFormat width - -genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] - args@[src] bid = do - sse4_2 <- sse4_2Enabled - let platform = targetPlatform dflags - if sse4_2 - then do code_src <- getAnyReg src - src_r <- getNewRegNat format - let dst_r = getRegisterReg platform (CmmLocal dst) - return $ code_src src_r `appOL` - (if width == W8 then - -- The POPCNT instruction doesn't take a r/m8 - unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` - unitOL (POPCNT II16 (OpReg src_r) dst_r) - else - unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL` - (if width == W8 || width == W16 then - -- We used a 16-bit destination register above, - -- so zero-extend - unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) - else nilOL) - else do - targetExpr <- cmmMakeDynamicReference dflags - CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn - -- this is only safe, because - -- genCCall32' and genCCall64' - -- never inspect these arguments. - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps")) - genCCall' dflags is32Bit target dest_regs args bid - where - format = intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width)) - -genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] - args@[src, mask] bid = do - let platform = targetPlatform dflags - if isBmi2Enabled dflags - then do code_src <- getAnyReg src - code_mask <- getAnyReg mask - src_r <- getNewRegNat format - mask_r <- getNewRegNat format - let dst_r = getRegisterReg platform (CmmLocal dst) - return $ code_src src_r `appOL` code_mask mask_r `appOL` - (if width == W8 then - -- The PDEP instruction doesn't take a r/m8 - unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL` - unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL` - unitOL (PDEP II16 (OpReg mask_r) (OpReg src_r ) dst_r) - else - unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL` - (if width == W8 || width == W16 then - -- We used a 16-bit destination register above, - -- so zero-extend - unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) - else nilOL) - else do - targetExpr <- cmmMakeDynamicReference dflags - CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn - -- this is only safe, because - -- genCCall32' and genCCall64' - -- never inspect these arguments. - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps")) - genCCall' dflags is32Bit target dest_regs args bid - where - format = intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width)) - -genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] - args@[src, mask] bid = do - let platform = targetPlatform dflags - if isBmi2Enabled dflags - then do code_src <- getAnyReg src - code_mask <- getAnyReg mask - src_r <- getNewRegNat format - mask_r <- getNewRegNat format - let dst_r = getRegisterReg platform (CmmLocal dst) - return $ code_src src_r `appOL` code_mask mask_r `appOL` - (if width == W8 then - -- The PEXT instruction doesn't take a r/m8 - unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL` - unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL` - unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r) - else - unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL` - (if width == W8 || width == W16 then - -- We used a 16-bit destination register above, - -- so zero-extend - unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) - else nilOL) - else do - targetExpr <- cmmMakeDynamicReference dflags - CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn - -- this is only safe, because - -- genCCall32' and genCCall64' - -- never inspect these arguments. - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps")) - genCCall' dflags is32Bit target dest_regs args bid - where - format = intFormat width - lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width)) - -genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid - | is32Bit && width == W64 = do - -- Fallback to `hs_clz64` on i386 - targetExpr <- cmmMakeDynamicReference dflags CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn - -- this is only safe, because - -- genCCall32' and genCCall64' - -- never inspect these arguments. - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps")) - genCCall' dflags is32Bit target dest_regs args bid - - | otherwise = do - code_src <- getAnyReg src - let dst_r = getRegisterReg platform (CmmLocal dst) - if isBmi2Enabled dflags - then do - src_r <- getNewRegNat (intFormat width) - return $ appOL (code_src src_r) $ case width of - W8 -> toOL - [ MOVZxL II8 (OpReg src_r) (OpReg src_r) -- zero-extend to 32 bit - , LZCNT II32 (OpReg src_r) dst_r -- lzcnt with extra 24 zeros - , SUB II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros - ] - W16 -> toOL - [ LZCNT II16 (OpReg src_r) dst_r - , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit - ] - _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r) - else do - let format = if width == W8 then II16 else intFormat width - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - return $ code_src src_r `appOL` toOL - ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ - [ BSR format (OpReg src_r) tmp_r - , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) - , CMOV NE format (OpReg tmp_r) dst_r - , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r) - ]) -- NB: We don't need to zero-extend the result for the - -- W8/W16 cases because the 'MOV' insn already - -- took care of implicitly clearing the upper bits - where - bw = widthInBits width - platform = targetPlatform dflags - lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) - -genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do - targetExpr <- cmmMakeDynamicReference dflags - CallReference lbl - let target = ForeignTarget targetExpr (ForeignConvention CCallConv - [NoHint] [NoHint] - CmmMayReturn - -- this is only safe, because - -- genCCall32' and genCCall64' - -- never inspect these arguments. - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps")) - genCCall' dflags is32Bit target dest_regs args bid - where - lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) - -genCCall' dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do - load_code <- intLoadCode (MOV (intFormat width)) addr - let platform = targetPlatform dflags - - return (load_code (getRegisterReg platform (CmmLocal dst))) - -genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do - code <- assignMem_IntCode (intFormat width) addr val - return $ code `snocOL` MFENCE - -genCCall' dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do - -- On x86 we don't have enough registers to use cmpxchg with a - -- complicated addressing mode, so on that architecture we - -- pre-compute the address first. - Amode amode addr_code <- getSimpleAmode dflags is32Bit addr - newval <- getNewRegNat format - newval_code <- getAnyReg new - oldval <- getNewRegNat format - oldval_code <- getAnyReg old - let platform = targetPlatform dflags - dst_r = getRegisterReg platform (CmmLocal dst) - code = toOL - [ MOV format (OpReg oldval) (OpReg eax) - , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode)) - , MOV format (OpReg eax) (OpReg dst_r) - ] - return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval - `appOL` code - where - format = intFormat width - -genCCall' _ is32Bit target dest_regs args bid = do - dflags <- getDynFlags - let platform = targetPlatform dflags - case (target, dest_regs) of - -- void return type prim op - (PrimTarget op, []) -> - outOfLineCmmOp bid op Nothing args - -- we only cope with a single result for foreign calls - (PrimTarget op, [r]) -> case op of - MO_F32_Fabs -> case args of - [x] -> sse2FabsCode W32 x - _ -> panic "genCCall: Wrong number of arguments for fabs" - MO_F64_Fabs -> case args of - [x] -> sse2FabsCode W64 x - _ -> panic "genCCall: Wrong number of arguments for fabs" - - MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args - MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args - _other_op -> outOfLineCmmOp bid op (Just r) args - - where - actuallyInlineSSE2Op = actuallyInlineFloatOp' - - actuallyInlineFloatOp' instr format [x] - = do res <- trivialUFCode format (instr format) x - any <- anyReg res - return (any (getRegisterReg platform (CmmLocal r))) - - actuallyInlineFloatOp' _ _ args - = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! (" - ++ show (length args) ++ ")" - - sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock - sse2FabsCode w x = do - let fmt = floatFormat w - x_code <- getAnyReg x - let - const | FF32 <- fmt = CmmInt 0x7fffffff W32 - | otherwise = CmmInt 0x7fffffffffffffff W64 - Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const - tmp <- getNewRegNat fmt - let - code dst = x_code dst `appOL` amode_code `appOL` toOL [ - MOV fmt (OpAddr amode) (OpReg tmp), - AND fmt (OpReg tmp) (OpReg dst) - ] - - return $ code (getRegisterReg platform (CmmLocal r)) - - (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args - (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args - (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args - (PrimTarget (MO_Add2 width), [res_h, res_l]) -> - case args of - [arg_x, arg_y] -> - do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) - let format = intFormat width - lCode <- anyReg =<< trivialCode width (ADD_CC format) - (Just (ADD_CC format)) arg_x arg_y - let reg_l = getRegisterReg platform (CmmLocal res_l) - reg_h = getRegisterReg platform (CmmLocal res_h) - code = hCode reg_h `appOL` - lCode reg_l `snocOL` - ADC format (OpImm (ImmInteger 0)) (OpReg reg_h) - return code - _ -> panic "genCCall: Wrong number of arguments/results for add2" - (PrimTarget (MO_AddWordC width), [res_r, res_c]) -> - addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args - (PrimTarget (MO_SubWordC width), [res_r, res_c]) -> - addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args - (PrimTarget (MO_AddIntC width), [res_r, res_c]) -> - addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args - (PrimTarget (MO_SubIntC width), [res_r, res_c]) -> - addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args - (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> - case args of - [arg_x, arg_y] -> - do (y_reg, y_code) <- getRegOrMem arg_y - x_code <- getAnyReg arg_x - let format = intFormat width - reg_h = getRegisterReg platform (CmmLocal res_h) - reg_l = getRegisterReg platform (CmmLocal res_l) - code = y_code `appOL` - x_code rax `appOL` - toOL [MUL2 format y_reg, - MOV format (OpReg rdx) (OpReg reg_h), - MOV format (OpReg rax) (OpReg reg_l)] - return code - _ -> panic "genCCall: Wrong number of arguments/results for mul2" - - _ -> do - (instrs0, args') <- evalArgs bid args - instrs1 <- if is32Bit - then genCCall32' dflags target dest_regs args' - else genCCall64' dflags target dest_regs args' - return (instrs0 `appOL` instrs1) - - where divOp1 platform signed width results [arg_x, arg_y] - = divOp platform signed width results Nothing arg_x arg_y - divOp1 _ _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp1" - divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] - = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y - divOp2 _ _ _ _ _ - = panic "genCCall: Wrong number of arguments for divOp2" - - -- See Note [DIV/IDIV for bytes] - divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y = - let widen | signed = MO_SS_Conv W8 W16 - | otherwise = MO_UU_Conv W8 W16 - arg_x_low_16 = CmmMachOp widen [arg_x_low] - arg_y_16 = CmmMachOp widen [arg_y] - m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high - in divOp - platform signed W16 [res_q, res_r] - m_arg_x_high_16 arg_x_low_16 arg_y_16 - - divOp platform signed width [res_q, res_r] - m_arg_x_high arg_x_low arg_y - = do let format = intFormat width - reg_q = getRegisterReg platform (CmmLocal res_q) - reg_r = getRegisterReg platform (CmmLocal res_r) - widen | signed = CLTD format - | otherwise = XOR format (OpReg rdx) (OpReg rdx) - instr | signed = IDIV - | otherwise = DIV - (y_reg, y_code) <- getRegOrMem arg_y - x_low_code <- getAnyReg arg_x_low - x_high_code <- case m_arg_x_high of - Just arg_x_high -> - getAnyReg arg_x_high - Nothing -> - return $ const $ unitOL widen - return $ y_code `appOL` - x_low_code rax `appOL` - x_high_code rdx `appOL` - toOL [instr format y_reg, - MOV format (OpReg rax) (OpReg reg_q), - MOV format (OpReg rdx) (OpReg reg_r)] - divOp _ _ _ _ _ _ _ - = panic "genCCall: Wrong number of results for divOp" - - addSubIntC platform instr mrevinstr cond width - res_r res_c [arg_x, arg_y] - = do let format = intFormat width - rCode <- anyReg =<< trivialCode width (instr format) - (mrevinstr format) arg_x arg_y - reg_tmp <- getNewRegNat II8 - let reg_c = getRegisterReg platform (CmmLocal res_c) - reg_r = getRegisterReg platform (CmmLocal res_r) - code = rCode reg_r `snocOL` - SETCC cond (OpReg reg_tmp) `snocOL` - MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) - - return code - addSubIntC _ _ _ _ _ _ _ _ - = panic "genCCall: Wrong number of arguments/results for addSubIntC" - -{- -Note [Evaluate C-call arguments before placing in destination registers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When producing code for C calls we must take care when placing arguments -in their final registers. Specifically, we must ensure that temporary register -usage due to evaluation of one argument does not clobber a register in which we -already placed a previous argument (e.g. as the code generation logic for -MO_Shl can clobber %rcx due to x86 instruction limitations). - -This is precisely what happened in #18527. Consider this C--: - - (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64)); - -Here we are calling the C function `doSomething` with three arguments, the last -involving a non-trivial expression involving MO_Shl. In this case the NCG could -naively generate the following assembly (where $tmp denotes some temporary -register and $argN denotes the register for argument N, as dictated by the -platform's calling convention): - - mov _s2hp, $arg1 # place first argument - mov _s2hq, $arg2 # place second argument - - # Compute 1 << _s2hz - mov _s2hz, %rcx - shl %cl, $tmp - - # Compute (_s2hw | (1 << _s2hz)) - mov _s2hw, $arg3 - or $tmp, $arg3 - - # Perform the call - call func - -This code is outright broken on Windows which assigns $arg1 to %rcx. This means -that the evaluation of the last argument clobbers the first argument. - -To avoid this we use a rather awful hack: when producing code for a C call with -at least one non-trivial argument, we first evaluate all of the arguments into -local registers before moving them into their final calling-convention-defined -homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an -expression which might contain a MachOp since these are the only cases which -might clobber registers. Furthermore, we use a conservative approximation of -this condition (only looking at the top-level of CmmExprs) to avoid spending -too much effort trying to decide whether we want to take the fast path. - -Note that this hack *also* applies to calls to out-of-line PrimTargets (which -are lowered via a C call) since outOfLineCmmOp produces the call via -(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up -back in genCCall{32,64}. --} - --- | See Note [Evaluate C-call arguments before placing in destination registers] -evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual]) -evalArgs bid actuals - | any mightContainMachOp actuals = do - regs_blks <- mapM evalArg actuals - return (concatOL $ map fst regs_blks, map snd regs_blks) - | otherwise = return (nilOL, actuals) - where - mightContainMachOp (CmmReg _) = False - mightContainMachOp (CmmRegOff _ _) = False - mightContainMachOp (CmmLit _) = False - mightContainMachOp _ = True - - evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr) - evalArg actual = do - dflags <- getDynFlags - lreg <- newLocalReg $ cmmExprType dflags actual - (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual - -- The above assignment shouldn't change the current block - MASSERT(isNothing bid1) - return (instrs, CmmReg $ CmmLocal lreg) - - newLocalReg :: CmmType -> NatM LocalReg - newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty - --- Note [DIV/IDIV for bytes] --- --- IDIV reminder: --- Size Dividend Divisor Quotient Remainder --- byte %ax r/m8 %al %ah --- word %dx:%ax r/m16 %ax %dx --- dword %edx:%eax r/m32 %eax %edx --- qword %rdx:%rax r/m64 %rax %rdx --- --- We do a special case for the byte division because the current --- codegen doesn't deal well with accessing %ah register (also, --- accessing %ah in 64-bit mode is complicated because it cannot be an --- operand of many instructions). So we just widen operands to 16 bits --- and get the results from %al, %dl. This is not optimal, but a few --- register moves are probably not a huge deal when doing division. - -genCCall32' :: DynFlags - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall32' dflags target dest_regs args = do - let - prom_args = map (maybePromoteCArg dflags W32) args - - -- Align stack to 16n for calls, assuming a starting stack - -- alignment of 16n - word_size on procedure entry. Which we - -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] - sizes = map (arg_size_bytes . cmmExprType dflags) (reverse args) - raw_arg_size = sum sizes + wORD_SIZE dflags - arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size - tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags - delta0 <- getDeltaNat - setDeltaNat (delta0 - arg_pad_size) - - push_codes <- mapM push_arg (reverse prom_args) - delta <- getDeltaNat - MASSERT(delta == delta0 - tot_arg_size) - - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - ForeignTarget (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) []), conv) - where fn_imm = ImmCLbl lbl - ForeignTarget expr conv - -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType dflags expr) ) - return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - PrimTarget _ - -> panic $ "genCCall: Can't handle PrimTarget call type here, error " - ++ "probably because too many return values." - - let push_code - | arg_pad_size /= 0 - = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), - DELTA (delta0 - arg_pad_size)] - `appOL` concatOL push_codes - | otherwise - = concatOL push_codes - - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - -- - -- We have to pop any stack padding we added - -- even if we are doing stdcall, though (#5052) - pop_size - | ForeignConvention StdCallConv _ _ _ _ _ <- cconv = arg_pad_size - | otherwise = tot_arg_size - - call = callinsns `appOL` - toOL ( - (if pop_size==0 then [] else - [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) - ++ - [DELTA delta0] - ) - setDeltaNat delta0 - - dflags <- getDynFlags - let platform = targetPlatform dflags - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [dest] - | isFloatType ty = - -- we assume SSE2 - let tmp_amode = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - fmt = floatFormat w - in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), - DELTA (delta0 - b), - X87Store fmt tmp_amode, - -- X87Store only supported for the CDECL ABI - -- NB: This code will need to be - -- revisted once GHC does more work around - -- SIGFPE f - MOV fmt (OpAddr tmp_amode) (OpReg r_dest), - ADD II32 (OpImm (ImmInt b)) (OpReg esp), - DELTA delta0] - | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), - MOV II32 (OpReg edx) (OpReg r_dest_hi)] - | otherwise = unitOL (MOV (intFormat w) - (OpReg eax) - (OpReg r_dest)) - where - ty = localRegType dest - w = typeWidth ty - b = widthInBytes w - r_dest_hi = getHiVRegFromLo r_dest - r_dest = getRegisterReg platform (CmmLocal dest) - assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) - - return (push_code `appOL` - call `appOL` - assign_code dest_regs) - - where - -- If the size is smaller than the word, we widen things (see maybePromoteCArg) - arg_size_bytes :: CmmType -> Int - arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth dflags)) - - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) - - push_arg :: CmmActual {-current argument-} - -> NatM InstrBlock -- code - - push_arg arg -- we don't need the hints on x86 - | isWord64 arg_ty = do - ChildCode64 code r_lo <- iselExpr64 arg - delta <- getDeltaNat - setDeltaNat (delta - 8) - let r_hi = getHiVRegFromLo r_lo - return ( code `appOL` - toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), - PUSH II32 (OpReg r_lo), DELTA (delta - 8), - DELTA (delta-8)] - ) - - | isFloatType arg_ty = do - (reg, code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `appOL` - toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), - DELTA (delta-size), - let addr = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - format = floatFormat (typeWidth arg_ty) - in - - -- assume SSE2 - MOV format (OpReg reg) (OpAddr addr) - - ] - ) - - | otherwise = do - -- Arguments can be smaller than 32-bit, but we still use @PUSH - -- II32@ - the usual calling conventions expect integers to be - -- 4-byte aligned. - ASSERT((typeWidth arg_ty) <= W32) return () - (operand, code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `snocOL` - PUSH II32 operand `snocOL` - DELTA (delta-size)) - - where - arg_ty = cmmExprType dflags arg - size = arg_size_bytes arg_ty -- Byte size - -genCCall64' :: DynFlags - -> ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall64' dflags target dest_regs args = do - -- load up the register arguments - let prom_args = map (maybePromoteCArg dflags W32) args - - (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code) - <- - if platformOS platform == OSMinGW32 - then load_args_win prom_args [] [] (allArgRegs platform) nilOL - else do - (stack_args, aregs, fregs, load_args_code, assign_args_code) - <- load_args prom_args (allIntArgRegs platform) - (allFPArgRegs platform) - nilOL nilOL - let used_regs rs as = reverse (drop (length rs) (reverse as)) - fregs_used = used_regs fregs (allFPArgRegs platform) - aregs_used = used_regs aregs (allIntArgRegs platform) - return (stack_args, aregs_used, fregs_used, load_args_code - , assign_args_code) - - let - arg_regs_used = int_regs_used ++ fp_regs_used - arg_regs = [eax] ++ arg_regs_used - -- for annotating the call instruction with - sse_regs = length fp_regs_used - arg_stack_slots = if platformOS platform == OSMinGW32 - then length stack_args + length (allArgRegs platform) - else length stack_args - tot_arg_size = arg_size * arg_stack_slots - - - -- Align stack to 16n for calls, assuming a starting stack - -- alignment of 16n - word_size on procedure entry. Which we - -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] - (real_size, adjust_rsp) <- - if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta - wORD_SIZE dflags) - return (tot_arg_size + wORD_SIZE dflags, toOL [ - SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp), - DELTA (delta - wORD_SIZE dflags) ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL - -- On Win64, we also have to leave stack space for the arguments - -- that we are passing in registers - lss_code <- if platformOS platform == OSMinGW32 - then leaveStackSpace (length (allArgRegs platform)) - else return nilOL - delta <- getDeltaNat - - -- deal with static vs dynamic call targets - (callinsns,_cconv) <- - case target of - ForeignTarget (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - ForeignTarget expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - PrimTarget _ - -> panic $ "genCCall: Can't handle PrimTarget call type here, error " - ++ "probably because too many return values." - - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- stdcall has callee do it, but is not supported on - -- x86_64 target (see #3336) - (if real_size==0 then [] else - [ADD (intFormat (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - setDeltaNat (delta + real_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [dest] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatFormat W32) - (OpReg xmm0) - (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatFormat W64) - (OpReg xmm0) - (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg platform (CmmLocal dest) - assign_code _many = panic "genCCall.assign_code many" - - return (adjust_rsp `appOL` - push_code `appOL` - load_args_code `appOL` - assign_args_code `appOL` - lss_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) - - where platform = targetPlatform dflags - arg_size = 8 -- always, at the mo - - - load_args :: [CmmExpr] - -> [Reg] -- int regs avail for args - -> [Reg] -- FP regs avail for args - -> InstrBlock -- code computing args - -> InstrBlock -- code assigning args to ABI regs - -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock) - -- no more regs to use - load_args args [] [] code acode = - return (args, [], [], code, acode) - - -- no more args to push - load_args [] aregs fregs code acode = - return ([], aregs, fregs, code, acode) - - load_args (arg : rest) aregs fregs code acode - | isFloatType arg_rep = case fregs of - [] -> push_this_arg - (r:rs) -> do - (code',acode') <- reg_this_arg r - load_args rest aregs rs code' acode' - | otherwise = case aregs of - [] -> push_this_arg - (r:rs) -> do - (code',acode') <- reg_this_arg r - load_args rest rs fregs code' acode' - where - - -- put arg into the list of stack pushed args - push_this_arg = do - (args',ars,frs,code',acode') - <- load_args rest aregs fregs code acode - return (arg:args', ars, frs, code', acode') - - -- pass the arg into the given register - reg_this_arg r - -- "operand" args can be directly assigned into r - | isOperand False arg = do - arg_code <- getAnyReg arg - return (code, (acode `appOL` arg_code r)) - -- The last non-operand arg can be directly assigned after its - -- computation without going into a temporary register - | all (isOperand False) rest = do - arg_code <- getAnyReg arg - return (code `appOL` arg_code r,acode) - - -- other args need to be computed beforehand to avoid clobbering - -- previously assigned registers used to pass parameters (see - -- #11792, #12614). They are assigned into temporary registers - -- and get assigned to proper call ABI registers after they all - -- have been computed. - | otherwise = do - arg_code <- getAnyReg arg - tmp <- getNewRegNat arg_fmt - let - code' = code `appOL` arg_code tmp - acode' = acode `snocOL` reg2reg arg_fmt tmp r - return (code',acode') - - arg_rep = cmmExprType dflags arg - arg_fmt = cmmTypeFormat arg_rep - - load_args_win :: [CmmExpr] - -> [Reg] -- used int regs - -> [Reg] -- used FP regs - -> [(Reg, Reg)] -- (int, FP) regs avail for args - -> InstrBlock - -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock) - load_args_win args usedInt usedFP [] code - = return (args, usedInt, usedFP, code, nilOL) - -- no more regs to use - load_args_win [] usedInt usedFP _ code - = return ([], usedInt, usedFP, code, nilOL) - -- no more args to push - load_args_win (arg : rest) usedInt usedFP - ((ireg, freg) : regs) code - | isFloatType arg_rep = do - arg_code <- getAnyReg arg - load_args_win rest (ireg : usedInt) (freg : usedFP) regs - (code `appOL` - arg_code freg `snocOL` - -- If we are calling a varargs function - -- then we need to define ireg as well - -- as freg - MOV II64 (OpReg freg) (OpReg ireg)) - | otherwise = do - arg_code <- getAnyReg arg - load_args_win rest (ireg : usedInt) usedFP regs - (code `appOL` arg_code ireg) - where - arg_rep = cmmExprType dflags arg - - push_args [] code = return code - push_args (arg:rest) code - | isFloatType arg_rep = do - (arg_reg, arg_code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp), - DELTA (delta-arg_size), - MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel dflags 0))] - push_args rest code' - - | otherwise = do - -- Arguments can be smaller than 64-bit, but we still use @PUSH - -- II64@ - the usual calling conventions expect integers to be - -- 8-byte aligned. - ASSERT(width <= W64) return () - (arg_op, arg_code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - PUSH II64 arg_op, - DELTA (delta-arg_size)] - push_args rest code' - where - arg_rep = cmmExprType dflags arg - width = typeWidth arg_rep - - leaveStackSpace n = do - delta <- getDeltaNat - setDeltaNat (delta - n * arg_size) - return $ toOL [ - SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp), - DELTA (delta - n * arg_size)] - -maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr -maybePromoteCArg dflags wto arg - | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] - | otherwise = arg - where - wfrom = cmmExprWidth dflags arg - -outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual] - -> NatM InstrBlock -outOfLineCmmOp bid mop res args - = do - dflags <- getDynFlags - targetExpr <- cmmMakeDynamicReference dflags CallReference lbl - let target = ForeignTarget targetExpr - (ForeignConvention CCallConv [] [] CmmMayReturn - -- this is only safe, because - -- genCCall32' and genCCall64' - -- never inspect these arguments. - (panic "Missing Return PrimRep") - (panic "Missing Argument PrimReps")) - - -- We know foreign calls results in no new basic blocks, so we can ignore - -- the returned block id. - (instrs, _) <- stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args) - return instrs - where - -- Assume we can call these functions directly, and that they're not in a dynamic library. - -- TODO: Why is this ok? Under linux this code will be in libm.so - -- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 - lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction - - fn = case mop of - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Fabs -> fsLit "fabsf" - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - MO_F32_Exp -> fsLit "expf" - MO_F32_ExpM1 -> fsLit "expm1f" - MO_F32_Log -> fsLit "logf" - MO_F32_Log1P -> fsLit "log1pf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Asinh -> fsLit "asinhf" - MO_F32_Acosh -> fsLit "acoshf" - MO_F32_Atanh -> fsLit "atanhf" - - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Fabs -> fsLit "fabs" - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - MO_F64_Exp -> fsLit "exp" - MO_F64_ExpM1 -> fsLit "expm1" - MO_F64_Log -> fsLit "log" - MO_F64_Log1P -> fsLit "log1p" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Asinh -> fsLit "asinh" - MO_F64_Acosh -> fsLit "acosh" - MO_F64_Atanh -> fsLit "atanh" - - MO_Memcpy _ -> fsLit "memcpy" - MO_Memset _ -> fsLit "memset" - MO_Memmove _ -> fsLit "memmove" - MO_Memcmp _ -> fsLit "memcmp" - - MO_PopCnt _ -> fsLit "popcnt" - MO_BSwap _ -> fsLit "bswap" - {- Here the C implementation is used as there is no x86 - instruction to reverse a word's bit order. - -} - MO_BRev w -> fsLit $ bRevLabel w - MO_Clz w -> fsLit $ clzLabel w - MO_Ctz _ -> unsupported - - MO_Pdep w -> fsLit $ pdepLabel w - MO_Pext w -> fsLit $ pextLabel w - - MO_AtomicRMW _ _ -> fsLit "atomicrmw" - MO_AtomicRead _ -> fsLit "atomicread" - MO_AtomicWrite _ -> fsLit "atomicwrite" - MO_Cmpxchg _ -> fsLit "cmpxchg" - - MO_UF_Conv _ -> unsupported - - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_AddWordC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _ ) -> unsupported - unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock - -genSwitch dflags expr targets - | positionIndependent dflags - = do - (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset) - -- getNonClobberedReg because it needs to survive across t_code - lbl <- getNewLabelNat - dflags <- getDynFlags - let is32bit = target32Bit (targetPlatform dflags) - os = platformOS (targetPlatform dflags) - -- Might want to use .rodata. instead, but as - -- long as it's something unique it'll work out since the - -- references to the jump table are in the appropriate section. - rosection = case os of - -- on Mac OS X/x86_64, put the jump table in the text section to - -- work around a limitation of the linker. - -- ld64 is unable to handle the relocations for - -- .quad L1 - L0 - -- if L0 is not preceded by a non-anonymous label in its section. - OSDarwin | not is32bit -> Section Text lbl - _ -> Section ReadOnlyData lbl - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) - (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) - - offsetReg <- getNewRegNat (intFormat (wordWidth dflags)) - return $ if is32bit || os == OSDarwin - then e_code `appOL` t_code `appOL` toOL [ - ADD (intFormat (wordWidth dflags)) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids rosection lbl - ] - else -- HACK: On x86_64 binutils<2.17 is only able to generate - -- PC32 relocations, hence we only get 32-bit offsets in - -- the jump table. As these offsets are always negative - -- we need to properly sign extend them to 64-bit. This - -- hack should be removed in conjunction with the hack in - -- PprMach.hs/pprDataItem once binutils 2.17 is standard. - e_code `appOL` t_code `appOL` toOL [ - MOVSxL II32 op (OpReg offsetReg), - ADD (intFormat (wordWidth dflags)) - (OpReg offsetReg) - (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids rosection lbl - ] - | otherwise - = do - (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) - lbl <- getNewLabelNat - let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) - code = e_code `appOL` toOL [ - JMP_TBL op ids (Section ReadOnlyData lbl) lbl - ] - return code - where - (offset, blockIds) = switchTargetsToTable targets - ids = map (fmap DestBlockId) blockIds - -generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr) -generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl) - = let getBlockId (DestBlockId id) = id - getBlockId _ = panic "Non-Label target in Jump Table" - blockIds = map (fmap getBlockId) ids - in Just (createJumpTable dflags blockIds section lbl) -generateJumpTableForInstr _ _ = Nothing - -createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel - -> GenCmmDecl (Alignment, CmmStatics) h g -createJumpTable dflags ids section lbl - = let jumpTable - | positionIndependent dflags = - let ww = wordWidth dflags - jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 ww) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww) - where blockLabel = blockLbl blockid - in map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry dflags) ids - in CmmData section (mkAlignment 1, Statics lbl jumpTable) - -extractUnwindPoints :: [Instr] -> [UnwindPoint] -extractUnwindPoints instrs = - [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs] - --- ----------------------------------------------------------------------------- --- 'condIntReg' and 'condFltReg': condition codes into registers - --- Turn those condition codes into integers now (when they appear on --- the right hand side of an assignment). --- --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. - -condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register - -condIntReg cond x y = do - CondCode _ cond cond_code <- condIntCode cond x y - tmp <- getNewRegNat II8 - let - code dst = cond_code `appOL` toOL [ - SETCC cond (OpReg tmp), - MOVZxL II8 (OpReg tmp) (OpReg dst) - ] - return (Any II32 code) - - ------------------------------------------------------------ ---- Note [SSE Parity Checks] --- ------------------------------------------------------------ - --- We have to worry about unordered operands (eg. comparisons --- against NaN). If the operands are unordered, the comparison --- sets the parity flag, carry flag and zero flag. --- All comparisons are supposed to return false for unordered --- operands except for !=, which returns true. --- --- Optimisation: we don't have to test the parity flag if we --- know the test has already excluded the unordered case: eg > --- and >= test for a zero carry flag, which can only occur for --- ordered operands. --- --- By reversing comparisons we can avoid testing the parity --- for < and <= as well. If any of the arguments is an NaN we --- return false either way. If both arguments are valid then --- x <= y <-> y >= x holds. So it's safe to swap these. --- --- We invert the condition inside getRegister'and getCondCode --- which should cover all invertable cases. --- All other functions translating FP comparisons to assembly --- use these to two generate the comparison code. --- --- As an example consider a simple check: --- --- func :: Float -> Float -> Int --- func x y = if x < y then 1 else 0 --- --- Which in Cmm gives the floating point comparison. --- --- if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf; --- --- We used to compile this to an assembly code block like this: --- _c2gh: --- ucomiss %xmm2,%xmm1 --- jp _c2gf --- jb _c2gg --- jmp _c2gf --- --- Where we have to introduce an explicit --- check for unordered results (using jmp parity): --- --- We can avoid this by exchanging the arguments and inverting the direction --- of the comparison. This results in the sequence of: --- --- ucomiss %xmm1,%xmm2 --- ja _c2g2 --- jmp _c2g1 --- --- Removing the jump reduces the pressure on the branch predidiction system --- and plays better with the uOP cache. - -condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register -condFltReg is32Bit cond x y = condFltReg_sse2 - where - - - condFltReg_sse2 = do - CondCode _ cond cond_code <- condFltCode cond x y - tmp1 <- getNewRegNat (archWordFormat is32Bit) - tmp2 <- getNewRegNat (archWordFormat is32Bit) - let -- See Note [SSE Parity Checks] - code dst = - cond_code `appOL` - (case cond of - NE -> or_unordered dst - GU -> plain_test dst - GEU -> plain_test dst - -- Use ASSERT so we don't break releases if these creep in. - LTT -> ASSERT2(False, ppr "Should have been turned into >") - and_ordered dst - LE -> ASSERT2(False, ppr "Should have been turned into >=") - and_ordered dst - _ -> and_ordered dst) - - plain_test dst = toOL [ - SETCC cond (OpReg tmp1), - MOVZxL II8 (OpReg tmp1) (OpReg dst) - ] - or_unordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC PARITY (OpReg tmp2), - OR II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] - and_ordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC NOTPARITY (OpReg tmp2), - AND II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] - return (Any II32 code) - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - - -{- -The Rules of the Game are: - -* You cannot assume anything about the destination register dst; - it may be anything, including a fixed reg. - -* You may compute an operand into a fixed reg, but you may not - subsequently change the contents of that fixed reg. If you - want to do so, first copy the value either to a temporary - or into dst. You are free to modify dst even if it happens - to be a fixed reg -- that's not your problem. - -* You cannot assume that a fixed reg will stay live over an - arbitrary computation. The same applies to the dst reg. - -* Temporary regs obtained from getNewRegNat are distinct from - each other and from all other regs, and stay live over - arbitrary computations. - --------------------- - -SDM's version of The Rules: - -* If getRegister returns Any, that means it can generate correct - code which places the result in any register, period. Even if that - register happens to be read during the computation. - - Corollary #1: this means that if you are generating code for an - operation with two arbitrary operands, you cannot assign the result - of the first operand into the destination register before computing - the second operand. The second operand might require the old value - of the destination register. - - Corollary #2: A function might be able to generate more efficient - code if it knows the destination register is a new temporary (and - therefore not read by any of the sub-computations). - -* If getRegister returns Any, then the code it generates may modify only: - (a) fresh temporaries - (b) the destination register - (c) known registers (eg. %ecx is used by shifts) - In particular, it may *not* modify global registers, unless the global - register happens to be the destination register. --} - -trivialCode :: Width -> (Operand -> Operand -> Instr) - -> Maybe (Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCode width instr m a b - = do is32Bit <- is32BitPlatform - trivialCode' is32Bit width instr m a b - -trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr) - -> Maybe (Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b - | is32BitLit is32Bit lit_a = do - b_code <- getAnyReg b - let - code dst - = b_code dst `snocOL` - revinstr (OpImm (litToImm lit_a)) (OpReg dst) - return (Any (intFormat width) code) - -trivialCode' _ width instr _ a b - = genTrivialCode (intFormat width) instr a b - --- This is re-used for floating pt instructions too. -genTrivialCode :: Format -> (Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -genTrivialCode rep instr a b = do - (b_op, b_code) <- getNonClobberedOperand b - a_code <- getAnyReg a - tmp <- getNewRegNat rep - let - -- We want the value of b to stay alive across the computation of a. - -- But, we want to calculate a straight into the destination register, - -- because the instruction only has two operands (dst := dst `op` src). - -- The troublesome case is when the result of b is in the same register - -- as the destination reg. In this case, we have to save b in a - -- new temporary across the computation of a. - code dst - | dst `regClashesWithOp` b_op = - b_code `appOL` - unitOL (MOV rep b_op (OpReg tmp)) `appOL` - a_code dst `snocOL` - instr (OpReg tmp) (OpReg dst) - | otherwise = - b_code `appOL` - a_code dst `snocOL` - instr b_op (OpReg dst) - return (Any rep code) - -regClashesWithOp :: Reg -> Operand -> Bool -reg `regClashesWithOp` OpReg reg2 = reg == reg2 -reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) -_ `regClashesWithOp` _ = False - ------------ - -trivialUCode :: Format -> (Operand -> Instr) - -> CmmExpr -> NatM Register -trivialUCode rep instr x = do - x_code <- getAnyReg x - let - code dst = - x_code dst `snocOL` - instr (OpReg dst) - return (Any rep code) - ------------ - - -trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -trivialFCode_sse2 pk instr x y - = genTrivialCode format (instr format) x y - where format = floatFormat pk - - -trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register -trivialUFCode format instr x = do - (x_reg, x_code) <- getSomeReg x - let - code dst = - x_code `snocOL` - instr x_reg dst - return (Any format code) - - --------------------------------------------------------------------------------- -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP from to x = coerce_sse2 - where - - coerce_sse2 = do - (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand - let - opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD - n -> panic $ "coerceInt2FP.sse: unhandled width (" - ++ show n ++ ")" - code dst = x_code `snocOL` opc (intFormat from) x_op dst - return (Any (floatFormat to) code) - -- works even if the destination rep is Width -> CmmExpr -> NatM Register -coerceFP2Int from to x = coerceFP2Int_sse2 - where - coerceFP2Int_sse2 = do - (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand - let - opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ; - n -> panic $ "coerceFP2Init.sse: unhandled width (" - ++ show n ++ ")" - code dst = x_code `snocOL` opc (intFormat to) x_op dst - return (Any (intFormat to) code) - -- works even if the destination rep is CmmExpr -> NatM Register -coerceFP2FP to x = do - (x_reg, x_code) <- getSomeReg x - let - opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD; - n -> panic $ "coerceFP2FP: unhandled width (" - ++ show n ++ ")" - code dst = x_code `snocOL` opc x_reg dst - return (Any ( floatFormat to) code) - --------------------------------------------------------------------------------- - -sse2NegCode :: Width -> CmmExpr -> NatM Register -sse2NegCode w x = do - let fmt = floatFormat w - x_code <- getAnyReg x - -- This is how gcc does it, so it can't be that bad: - let - const = case fmt of - FF32 -> CmmInt 0x80000000 W32 - FF64 -> CmmInt 0x8000000000000000 W64 - x@II8 -> wrongFmt x - x@II16 -> wrongFmt x - x@II32 -> wrongFmt x - x@II64 -> wrongFmt x - - where - wrongFmt x = panic $ "sse2NegCode: " ++ show x - Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const - tmp <- getNewRegNat fmt - let - code dst = x_code dst `appOL` amode_code `appOL` toOL [ - MOV fmt (OpAddr amode) (OpReg tmp), - XOR fmt (OpReg tmp) (OpReg dst) - ] - -- - return (Any fmt code) - -isVecExpr :: CmmExpr -> Bool -isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True -isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True -isVecExpr (CmmMachOp (MO_V_Add {}) _) = True -isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True -isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True -isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True -isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True -isVecExpr (CmmMachOp _ [e]) = isVecExpr e -isVecExpr _ = False - -needLlvm :: NatM a -needLlvm = - sorry $ unlines ["The native code generator does not support vector" - ,"instructions. Please use -fllvm."] - --- | This works on the invariant that all jumps in the given blocks are required. --- Starting from there we try to make a few more jumps redundant by reordering --- them. --- We depend on the information in the CFG to do so so without a given CFG --- we do nothing. -invertCondBranches :: Maybe CFG -- ^ CFG if present - -> LabelMap a -- ^ Blocks with info tables - -> [NatBasicBlock Instr] -- ^ List of basic blocks - -> [NatBasicBlock Instr] -invertCondBranches Nothing _ bs = bs -invertCondBranches (Just cfg) keep bs = - invert bs - where - invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr] - invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs) - | --pprTrace "Block" (ppr lbl1) True, - (jmp1,jmp2) <- last2 ins - , JXX cond1 target1 <- jmp1 - , target1 == lbl2 - --, pprTrace "CutChance" (ppr b1) True - , JXX ALWAYS target2 <- jmp2 - -- We have enough information to check if we can perform the inversion - -- TODO: We could also check for the last asm instruction which sets - -- status flags instead. Which I suspect is worse in terms of compiler - -- performance, but might be applicable to more cases - , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg - , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg - -- Both jumps come from the same cmm statement - , transitionSource edgeInfo1 == transitionSource edgeInfo2 - , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1 - - --Int comparisons are invertable - , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch - , Just _ <- maybeIntComparison op - , Just invCond <- maybeInvertCond cond1 - - --Swap the last two jumps, invert the conditional jumps condition. - = let jumps = - case () of - -- We are free the eliminate the jmp. So we do so. - _ | not (mapMember target1 keep) - -> [JXX invCond target2] - -- If the conditional target is unlikely we put the other - -- target at the front. - | edgeWeight edgeInfo2 > edgeWeight edgeInfo1 - -> [JXX invCond target2, JXX ALWAYS target1] - -- Keep things as-is otherwise - | otherwise - -> [jmp1, jmp2] - in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $ - (BasicBlock lbl1 - (dropTail 2 ins ++ jumps)) - : invert (b2:bs) - invert (b:bs) = b : invert bs - invert [] = [] diff --git a/nativeGen/X86/Cond.hs b/nativeGen/X86/Cond.hs deleted file mode 100644 --- a/nativeGen/X86/Cond.hs +++ /dev/null @@ -1,109 +0,0 @@ -module X86.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned, - maybeFlipCond, - maybeInvertCond -) - -where - -import GhcPrelude - -data Cond - = ALWAYS -- What's really used? ToDo - | EQQ -- je/jz -> zf = 1 - | GE -- jge - | GEU -- ae - | GTT -- jg - | GU -- ja - | LE -- jle - | LEU -- jbe - | LTT -- jl - | LU -- jb - | NE -- jne - | NEG -- js - | POS -- jns - | CARRY -- jc - | OFLO -- jo - | PARITY -- jp - | NOTPARITY -- jnp - deriving Eq - -condUnsigned :: Cond -> Bool -condUnsigned GU = True -condUnsigned LU = True -condUnsigned GEU = True -condUnsigned LEU = True -condUnsigned _ = False - - -condToSigned :: Cond -> Cond -condToSigned GU = GTT -condToSigned LU = LTT -condToSigned GEU = GE -condToSigned LEU = LE -condToSigned x = x - - -condToUnsigned :: Cond -> Cond -condToUnsigned GTT = GU -condToUnsigned LTT = LU -condToUnsigned GE = GEU -condToUnsigned LE = LEU -condToUnsigned x = x - --- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the --- arguments to the conditional @c@, and the new condition should be @c'@. -maybeFlipCond :: Cond -> Maybe Cond -maybeFlipCond cond = case cond of - EQQ -> Just EQQ - NE -> Just NE - LU -> Just GU - GU -> Just LU - LEU -> Just GEU - GEU -> Just LEU - LTT -> Just GTT - GTT -> Just LTT - LE -> Just GE - GE -> Just LE - _other -> Nothing - --- | If we apply @maybeInvertCond@ to the condition of a jump we turn --- jumps taken into jumps not taken and vice versa. --- --- Careful! If the used comparison and the conditional jump --- don't match the above behaviour will NOT hold. --- When used for FP comparisons this does not consider unordered --- numbers. --- Also inverting twice might return a synonym for the original condition. -maybeInvertCond :: Cond -> Maybe Cond -maybeInvertCond cond = case cond of - ALWAYS -> Nothing - EQQ -> Just NE - NE -> Just EQQ - - NEG -> Just POS - POS -> Just NEG - - GEU -> Just LU - LU -> Just GEU - - GE -> Just LTT - LTT -> Just GE - - GTT -> Just LE - LE -> Just GTT - - GU -> Just LEU - LEU -> Just GU - - --GEU "==" NOTCARRY, they are synonyms - --at the assembly level - CARRY -> Just GEU - - OFLO -> Nothing - - PARITY -> Just NOTPARITY - NOTPARITY -> Just PARITY diff --git a/nativeGen/X86/Instr.hs b/nativeGen/X86/Instr.hs deleted file mode 100644 --- a/nativeGen/X86/Instr.hs +++ /dev/null @@ -1,1055 +0,0 @@ -{-# LANGUAGE CPP, TypeFamilies #-} - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ - -module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..), - getJumpDestBlockId, canShortcut, shortcutStatics, - shortcutJump, allocMoreStack, - maxSpillSlots, archWordFormat ) -where - -#include "HsVersions.h" - -import GhcPrelude - -import X86.Cond -import X86.Regs -import Instruction -import Format -import RegClass -import Reg -import TargetReg - -import BlockId -import Hoopl.Collections -import Hoopl.Label -import GHC.Platform.Regs -import Cmm -import FastString -import Outputable -import GHC.Platform - -import BasicTypes (Alignment) -import CLabel -import DynFlags -import UniqSet -import Unique -import UniqSupply -import Debug (UnwindTable) - -import Control.Monad -import Data.Maybe (fromMaybe) - --- Format of an x86/x86_64 memory address, in bytes. --- -archWordFormat :: Bool -> Format -archWordFormat is32Bit - | is32Bit = II32 - | otherwise = II64 - --- | Instruction instance for x86 instruction set. -instance Instruction Instr where - regUsageOfInstr = x86_regUsageOfInstr - patchRegsOfInstr = x86_patchRegsOfInstr - isJumpishInstr = x86_isJumpishInstr - jumpDestsOfInstr = x86_jumpDestsOfInstr - patchJumpInstr = x86_patchJumpInstr - mkSpillInstr = x86_mkSpillInstr - mkLoadInstr = x86_mkLoadInstr - takeDeltaInstr = x86_takeDeltaInstr - isMetaInstr = x86_isMetaInstr - mkRegRegMoveInstr = x86_mkRegRegMoveInstr - takeRegRegMoveInstr = x86_takeRegRegMoveInstr - mkJumpInstr = x86_mkJumpInstr - mkStackAllocInstr = x86_mkStackAllocInstr - mkStackDeallocInstr = x86_mkStackDeallocInstr - - --- ----------------------------------------------------------------------------- --- Intel x86 instructions - -{- -Intel, in their infinite wisdom, selected a stack model for floating -point registers on x86. That might have made sense back in 1979 -- -nowadays we can see it for the nonsense it really is. A stack model -fits poorly with the existing nativeGen infrastructure, which assumes -flat integer and FP register sets. Prior to this commit, nativeGen -could not generate correct x86 FP code -- to do so would have meant -somehow working the register-stack paradigm into the register -allocator and spiller, which sounds very difficult. - -We have decided to cheat, and go for a simple fix which requires no -infrastructure modifications, at the expense of generating ropey but -correct FP code. All notions of the x86 FP stack and its insns have -been removed. Instead, we pretend (to the instruction selector and -register allocator) that x86 has six floating point registers, %fake0 -.. %fake5, which can be used in the usual flat manner. We further -claim that x86 has floating point instructions very similar to SPARC -and Alpha, that is, a simple 3-operand register-register arrangement. -Code generation and register allocation proceed on this basis. - -When we come to print out the final assembly, our convenient fiction -is converted to dismal reality. Each fake instruction is -independently converted to a series of real x86 instructions. -%fake0 .. %fake5 are mapped to %st(0) .. %st(5). To do reg-reg -arithmetic operations, the two operands are pushed onto the top of the -FP stack, the operation done, and the result copied back into the -relevant register. There are only six %fake registers because 2 are -needed for the translation, and x86 has 8 in total. - -The translation is inefficient but is simple and it works. A cleverer -translation would handle a sequence of insns, simulating the FP stack -contents, would not impose a fixed mapping from %fake to %st regs, and -hopefully could avoid most of the redundant reg-reg moves of the -current translation. - -We might as well make use of whatever unique FP facilities Intel have -chosen to bless us with (let's not be churlish, after all). -Hence GLDZ and GLD1. Bwahahahahahahaha! --} - -{- -Note [x86 Floating point precision] - -Intel's internal floating point registers are by default 80 bit -extended precision. This means that all operations done on values in -registers are done at 80 bits, and unless the intermediate values are -truncated to the appropriate size (32 or 64 bits) by storing in -memory, calculations in registers will give different results from -calculations which pass intermediate values in memory (eg. via -function calls). - -One solution is to set the FPU into 64 bit precision mode. Some OSs -do this (eg. FreeBSD) and some don't (eg. Linux). The problem here is -that this will only affect 64-bit precision arithmetic; 32-bit -calculations will still be done at 64-bit precision in registers. So -it doesn't solve the whole problem. - -There's also the issue of what the C library is expecting in terms of -precision. It seems to be the case that glibc on Linux expects the -FPU to be set to 80 bit precision, so setting it to 64 bit could have -unexpected effects. Changing the default could have undesirable -effects on other 3rd-party library code too, so the right thing would -be to save/restore the FPU control word across Haskell code if we were -to do this. - -gcc's -ffloat-store gives consistent results by always storing the -results of floating-point calculations in memory, which works for both -32 and 64-bit precision. However, it only affects the values of -user-declared floating point variables in C, not intermediate results. -GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision -flag). - -Another problem is how to spill floating point registers in the -register allocator. Should we spill the whole 80 bits, or just 64? -On an OS which is set to 64 bit precision, spilling 64 is fine. On -Linux, spilling 64 bits will round the results of some operations. -This is what gcc does. Spilling at 80 bits requires taking up a full -128 bit slot (so we get alignment). We spill at 80-bits and ignore -the alignment problems. - -In the future [edit: now available in GHC 7.0.1, with the -msse2 -flag], we'll use the SSE registers for floating point. This requires -a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision -float ops), which means P4 or Xeon and above. Using SSE will solve -all these problems, because the SSE registers use fixed 32 bit or 64 -bit precision. - ---SDM 1/2003 --} - -data Instr - -- comment pseudo-op - = COMMENT FastString - - -- location pseudo-op (file, line, col, name) - | LOCATION Int Int Int String - - -- some static data spat out during code - -- generation. Will be extracted before - -- pretty-printing. - | LDATA Section (Alignment, CmmStatics) - - -- start a new basic block. Useful during - -- codegen, removed later. Preceding - -- instruction should be a jump, as per the - -- invariants for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- unwinding information - -- See Note [Unwinding information in the NCG]. - | UNWIND CLabel UnwindTable - - -- specify current stack offset for benefit of subsequent passes. - -- This carries a BlockId so it can be used in unwinding information. - | DELTA Int - - -- Moves. - | MOV Format Operand Operand - | CMOV Cond Format Operand Reg - | MOVZxL Format Operand Operand -- format is the size of operand 1 - | MOVSxL Format Operand Operand -- format is the size of operand 1 - -- x86_64 note: plain mov into a 32-bit register always zero-extends - -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which - -- don't affect the high bits of the register. - - -- Load effective address (also a very useful three-operand add instruction :-) - | LEA Format Operand Operand - - -- Int Arithmetic. - | ADD Format Operand Operand - | ADC Format Operand Operand - | SUB Format Operand Operand - | SBB Format Operand Operand - - | MUL Format Operand Operand - | MUL2 Format Operand -- %edx:%eax = operand * %rax - | IMUL Format Operand Operand -- signed int mul - | IMUL2 Format Operand -- %edx:%eax = operand * %eax - - | DIV Format Operand -- eax := eax:edx/op, edx := eax:edx%op - | IDIV Format Operand -- ditto, but signed - - -- Int Arithmetic, where the effects on the condition register - -- are important. Used in specialized sequences such as MO_Add2. - -- Do not rewrite these instructions to "equivalent" ones that - -- have different effect on the condition register! (See #9013.) - | ADD_CC Format Operand Operand - | SUB_CC Format Operand Operand - - -- Simple bit-twiddling. - | AND Format Operand Operand - | OR Format Operand Operand - | XOR Format Operand Operand - | NOT Format Operand - | NEGI Format Operand -- NEG instruction (name clash with Cond) - | BSWAP Format Reg - - -- Shifts (amount may be immediate or %cl only) - | SHL Format Operand{-amount-} Operand - | SAR Format Operand{-amount-} Operand - | SHR Format Operand{-amount-} Operand - - | BT Format Imm Operand - | NOP - - - -- We need to support the FSTP (x87 store and pop) instruction - -- so that we can correctly read off the return value of an - -- x86 CDECL C function call when its floating point. - -- so we dont include a register argument, and just use st(0) - -- this instruction is used ONLY for return values of C ffi calls - -- in x86_32 abi - | X87Store Format AddrMode -- st(0), dst - - - -- SSE2 floating point: we use a restricted set of the available SSE2 - -- instructions for floating-point. - -- use MOV for moving (either movss or movsd (movlpd better?)) - | CVTSS2SD Reg Reg -- F32 to F64 - | CVTSD2SS Reg Reg -- F64 to F32 - | CVTTSS2SIQ Format Operand Reg -- F32 to I32/I64 (with truncation) - | CVTTSD2SIQ Format Operand Reg -- F64 to I32/I64 (with truncation) - | CVTSI2SS Format Operand Reg -- I32/I64 to F32 - | CVTSI2SD Format Operand Reg -- I32/I64 to F64 - - -- use ADD, SUB, and SQRT for arithmetic. In both cases, operands - -- are Operand Reg. - - -- SSE2 floating-point division: - | FDIV Format Operand Operand -- divisor, dividend(dst) - - -- use CMP for comparisons. ucomiss and ucomisd instructions - -- compare single/double prec floating point respectively. - - | SQRT Format Operand Reg -- src, dst - - - -- Comparison - | TEST Format Operand Operand - | CMP Format Operand Operand - | SETCC Cond Operand - - -- Stack Operations. - | PUSH Format Operand - | POP Format Operand - -- both unused (SDM): - -- | PUSHA - -- | POPA - - -- Jumping around. - | JMP Operand [Reg] -- including live Regs at the call - | JXX Cond BlockId -- includes unconditional branches - | JXX_GBL Cond Imm -- non-local version of JXX - -- Table jump - | JMP_TBL Operand -- Address to jump to - [Maybe JumpDest] -- Targets of the jump table - Section -- Data section jump table should be put in - CLabel -- Label of jump table - -- | X86 call instruction - | CALL (Either Imm Reg) -- ^ Jump target - [Reg] -- ^ Arguments (required for register allocation) - - -- Other things. - | CLTD Format -- sign extend %eax into %edx:%eax - - | FETCHGOT Reg -- pseudo-insn for ELF position-independent code - -- pretty-prints as - -- call 1f - -- 1: popl %reg - -- addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg - | FETCHPC Reg -- pseudo-insn for Darwin position-independent code - -- pretty-prints as - -- call 1f - -- 1: popl %reg - - -- bit counting instructions - | POPCNT Format Operand Reg -- [SSE4.2] count number of bits set to 1 - | LZCNT Format Operand Reg -- [BMI2] count number of leading zeros - | TZCNT Format Operand Reg -- [BMI2] count number of trailing zeros - | BSF Format Operand Reg -- bit scan forward - | BSR Format Operand Reg -- bit scan reverse - - -- bit manipulation instructions - | PDEP Format Operand Operand Reg -- [BMI2] deposit bits to the specified mask - | PEXT Format Operand Operand Reg -- [BMI2] extract bits from the specified mask - - -- prefetch - | PREFETCH PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch - -- variant can be NTA, Lvl0, Lvl1, or Lvl2 - - | LOCK Instr -- lock prefix - | XADD Format Operand Operand -- src (r), dst (r/m) - | CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit - | MFENCE - -data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 - - -data Operand - = OpReg Reg -- register - | OpImm Imm -- immediate value - | OpAddr AddrMode -- memory reference - - - --- | Returns which registers are read and written as a (read, written) --- pair. -x86_regUsageOfInstr :: Platform -> Instr -> RegUsage -x86_regUsageOfInstr platform instr - = case instr of - MOV _ src dst -> usageRW src dst - CMOV _ _ src dst -> mkRU (use_R src [dst]) [dst] - MOVZxL _ src dst -> usageRW src dst - MOVSxL _ src dst -> usageRW src dst - LEA _ src dst -> usageRW src dst - ADD _ src dst -> usageRM src dst - ADC _ src dst -> usageRM src dst - SUB _ src dst -> usageRM src dst - SBB _ src dst -> usageRM src dst - IMUL _ src dst -> usageRM src dst - - -- Result of IMULB will be in just in %ax - IMUL2 II8 src -> mkRU (eax:use_R src []) [eax] - -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and - -- %ax/%eax/%rax. - IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] - - MUL _ src dst -> usageRM src dst - MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] - DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] - IDIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] - ADD_CC _ src dst -> usageRM src dst - SUB_CC _ src dst -> usageRM src dst - AND _ src dst -> usageRM src dst - OR _ src dst -> usageRM src dst - - XOR _ (OpReg src) (OpReg dst) - | src == dst -> mkRU [] [dst] - - XOR _ src dst -> usageRM src dst - NOT _ op -> usageM op - BSWAP _ reg -> mkRU [reg] [reg] - NEGI _ op -> usageM op - SHL _ imm dst -> usageRM imm dst - SAR _ imm dst -> usageRM imm dst - SHR _ imm dst -> usageRM imm dst - BT _ _ src -> mkRUR (use_R src []) - - PUSH _ op -> mkRUR (use_R op []) - POP _ op -> mkRU [] (def_W op) - TEST _ src dst -> mkRUR (use_R src $! use_R dst []) - CMP _ src dst -> mkRUR (use_R src $! use_R dst []) - SETCC _ op -> mkRU [] (def_W op) - JXX _ _ -> mkRU [] [] - JXX_GBL _ _ -> mkRU [] [] - JMP op regs -> mkRUR (use_R op regs) - JMP_TBL op _ _ _ -> mkRUR (use_R op []) - CALL (Left _) params -> mkRU params (callClobberedRegs platform) - CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform) - CLTD _ -> mkRU [eax] [edx] - NOP -> mkRU [] [] - - X87Store _ dst -> mkRUR ( use_EA dst []) - - CVTSS2SD src dst -> mkRU [src] [dst] - CVTSD2SS src dst -> mkRU [src] [dst] - CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst] - CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst] - CVTSI2SS _ src dst -> mkRU (use_R src []) [dst] - CVTSI2SD _ src dst -> mkRU (use_R src []) [dst] - FDIV _ src dst -> usageRM src dst - SQRT _ src dst -> mkRU (use_R src []) [dst] - - FETCHGOT reg -> mkRU [] [reg] - FETCHPC reg -> mkRU [] [reg] - - COMMENT _ -> noUsage - LOCATION{} -> noUsage - UNWIND{} -> noUsage - DELTA _ -> noUsage - - POPCNT _ src dst -> mkRU (use_R src []) [dst] - LZCNT _ src dst -> mkRU (use_R src []) [dst] - TZCNT _ src dst -> mkRU (use_R src []) [dst] - BSF _ src dst -> mkRU (use_R src []) [dst] - BSR _ src dst -> mkRU (use_R src []) [dst] - - PDEP _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] - PEXT _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] - - -- note: might be a better way to do this - PREFETCH _ _ src -> mkRU (use_R src []) [] - LOCK i -> x86_regUsageOfInstr platform i - XADD _ src dst -> usageMM src dst - CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) - MFENCE -> noUsage - - _other -> panic "regUsage: unrecognised instr" - where - -- # Definitions - -- - -- Written: If the operand is a register, it's written. If it's an - -- address, registers mentioned in the address are read. - -- - -- Modified: If the operand is a register, it's both read and - -- written. If it's an address, registers mentioned in the address - -- are read. - - -- 2 operand form; first operand Read; second Written - usageRW :: Operand -> Operand -> RegUsage - usageRW op (OpReg reg) = mkRU (use_R op []) [reg] - usageRW op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) - usageRW _ _ = panic "X86.RegInfo.usageRW: no match" - - -- 2 operand form; first operand Read; second Modified - usageRM :: Operand -> Operand -> RegUsage - usageRM op (OpReg reg) = mkRU (use_R op [reg]) [reg] - usageRM op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) - usageRM _ _ = panic "X86.RegInfo.usageRM: no match" - - -- 2 operand form; first operand Modified; second Modified - usageMM :: Operand -> Operand -> RegUsage - usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] - usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src] - usageMM _ _ = panic "X86.RegInfo.usageMM: no match" - - -- 3 operand form; first operand Read; second Modified; third Modified - usageRMM :: Operand -> Operand -> Operand -> RegUsage - usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg] - usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] - usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" - - -- 1 operand form; operand Modified - usageM :: Operand -> RegUsage - usageM (OpReg reg) = mkRU [reg] [reg] - usageM (OpAddr ea) = mkRUR (use_EA ea []) - usageM _ = panic "X86.RegInfo.usageM: no match" - - -- Registers defd when an operand is written. - def_W (OpReg reg) = [reg] - def_W (OpAddr _ ) = [] - def_W _ = panic "X86.RegInfo.def_W: no match" - - -- Registers used when an operand is read. - use_R (OpReg reg) tl = reg : tl - use_R (OpImm _) tl = tl - use_R (OpAddr ea) tl = use_EA ea tl - - -- Registers used to compute an effective address. - use_EA (ImmAddr _ _) tl = tl - use_EA (AddrBaseIndex base index _) tl = - use_base base $! use_index index tl - where use_base (EABaseReg r) tl = r : tl - use_base _ tl = tl - use_index EAIndexNone tl = tl - use_index (EAIndex i _) tl = i : tl - - mkRUR src = src' `seq` RU src' [] - where src' = filter (interesting platform) src - - mkRU src dst = src' `seq` dst' `seq` RU src' dst' - where src' = filter (interesting platform) src - dst' = filter (interesting platform) dst - --- | Is this register interesting for the register allocator? -interesting :: Platform -> Reg -> Bool -interesting _ (RegVirtual _) = True -interesting platform (RegReal (RealRegSingle i)) = freeReg platform i -interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" - - - --- | Applies the supplied function to all registers in instructions. --- Typically used to change virtual registers to real registers. -x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -x86_patchRegsOfInstr instr env - = case instr of - MOV fmt src dst -> patch2 (MOV fmt) src dst - CMOV cc fmt src dst -> CMOV cc fmt (patchOp src) (env dst) - MOVZxL fmt src dst -> patch2 (MOVZxL fmt) src dst - MOVSxL fmt src dst -> patch2 (MOVSxL fmt) src dst - LEA fmt src dst -> patch2 (LEA fmt) src dst - ADD fmt src dst -> patch2 (ADD fmt) src dst - ADC fmt src dst -> patch2 (ADC fmt) src dst - SUB fmt src dst -> patch2 (SUB fmt) src dst - SBB fmt src dst -> patch2 (SBB fmt) src dst - IMUL fmt src dst -> patch2 (IMUL fmt) src dst - IMUL2 fmt src -> patch1 (IMUL2 fmt) src - MUL fmt src dst -> patch2 (MUL fmt) src dst - MUL2 fmt src -> patch1 (MUL2 fmt) src - IDIV fmt op -> patch1 (IDIV fmt) op - DIV fmt op -> patch1 (DIV fmt) op - ADD_CC fmt src dst -> patch2 (ADD_CC fmt) src dst - SUB_CC fmt src dst -> patch2 (SUB_CC fmt) src dst - AND fmt src dst -> patch2 (AND fmt) src dst - OR fmt src dst -> patch2 (OR fmt) src dst - XOR fmt src dst -> patch2 (XOR fmt) src dst - NOT fmt op -> patch1 (NOT fmt) op - BSWAP fmt reg -> BSWAP fmt (env reg) - NEGI fmt op -> patch1 (NEGI fmt) op - SHL fmt imm dst -> patch1 (SHL fmt imm) dst - SAR fmt imm dst -> patch1 (SAR fmt imm) dst - SHR fmt imm dst -> patch1 (SHR fmt imm) dst - BT fmt imm src -> patch1 (BT fmt imm) src - TEST fmt src dst -> patch2 (TEST fmt) src dst - CMP fmt src dst -> patch2 (CMP fmt) src dst - PUSH fmt op -> patch1 (PUSH fmt) op - POP fmt op -> patch1 (POP fmt) op - SETCC cond op -> patch1 (SETCC cond) op - JMP op regs -> JMP (patchOp op) regs - JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl - - -- literally only support storing the top x87 stack value st(0) - X87Store fmt dst -> X87Store fmt (lookupAddr dst) - - CVTSS2SD src dst -> CVTSS2SD (env src) (env dst) - CVTSD2SS src dst -> CVTSD2SS (env src) (env dst) - CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst) - CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst) - CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst) - CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst) - FDIV fmt src dst -> FDIV fmt (patchOp src) (patchOp dst) - SQRT fmt src dst -> SQRT fmt (patchOp src) (env dst) - - CALL (Left _) _ -> instr - CALL (Right reg) p -> CALL (Right (env reg)) p - - FETCHGOT reg -> FETCHGOT (env reg) - FETCHPC reg -> FETCHPC (env reg) - - NOP -> instr - COMMENT _ -> instr - LOCATION {} -> instr - UNWIND {} -> instr - DELTA _ -> instr - - JXX _ _ -> instr - JXX_GBL _ _ -> instr - CLTD _ -> instr - - POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst) - LZCNT fmt src dst -> LZCNT fmt (patchOp src) (env dst) - TZCNT fmt src dst -> TZCNT fmt (patchOp src) (env dst) - PDEP fmt src mask dst -> PDEP fmt (patchOp src) (patchOp mask) (env dst) - PEXT fmt src mask dst -> PEXT fmt (patchOp src) (patchOp mask) (env dst) - BSF fmt src dst -> BSF fmt (patchOp src) (env dst) - BSR fmt src dst -> BSR fmt (patchOp src) (env dst) - - PREFETCH lvl format src -> PREFETCH lvl format (patchOp src) - - LOCK i -> LOCK (x86_patchRegsOfInstr i env) - XADD fmt src dst -> patch2 (XADD fmt) src dst - CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst - MFENCE -> instr - - _other -> panic "patchRegs: unrecognised instr" - - where - patch1 :: (Operand -> a) -> Operand -> a - patch1 insn op = insn $! patchOp op - patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a - patch2 insn src dst = (insn $! patchOp src) $! patchOp dst - - patchOp (OpReg reg) = OpReg $! env reg - patchOp (OpImm imm) = OpImm imm - patchOp (OpAddr ea) = OpAddr $! lookupAddr ea - - lookupAddr (ImmAddr imm off) = ImmAddr imm off - lookupAddr (AddrBaseIndex base index disp) - = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp - where - lookupBase EABaseNone = EABaseNone - lookupBase EABaseRip = EABaseRip - lookupBase (EABaseReg r) = EABaseReg $! env r - - lookupIndex EAIndexNone = EAIndexNone - lookupIndex (EAIndex r i) = (EAIndex $! env r) i - - --------------------------------------------------------------------------------- -x86_isJumpishInstr - :: Instr -> Bool - -x86_isJumpishInstr instr - = case instr of - JMP{} -> True - JXX{} -> True - JXX_GBL{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False - - -x86_jumpDestsOfInstr - :: Instr - -> [BlockId] - -x86_jumpDestsOfInstr insn - = case insn of - JXX _ id -> [id] - JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids] - _ -> [] - - -x86_patchJumpInstr - :: Instr -> (BlockId -> BlockId) -> Instr - -x86_patchJumpInstr insn patchF - = case insn of - JXX cc id -> JXX cc (patchF id) - JMP_TBL op ids section lbl - -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl - _ -> insn - where - patchJumpDest f (DestBlockId id) = DestBlockId (f id) - patchJumpDest _ dest = dest - - - - - --- ----------------------------------------------------------------------------- --- | Make a spill instruction. -x86_mkSpillInstr - :: DynFlags - -> Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -x86_mkSpillInstr dflags reg delta slot - = let off = spillSlotToOffset platform slot - delta - in - case targetClassOfReg platform reg of - RcInteger -> MOV (archWordFormat is32Bit) - (OpReg reg) (OpAddr (spRel dflags off)) - RcDouble -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off)) - _ -> panic "X86.mkSpillInstr: no match" - where platform = targetPlatform dflags - is32Bit = target32Bit platform - --- | Make a spill reload instruction. -x86_mkLoadInstr - :: DynFlags - -> Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -x86_mkLoadInstr dflags reg delta slot - = let off = spillSlotToOffset platform slot - delta - in - case targetClassOfReg platform reg of - RcInteger -> MOV (archWordFormat is32Bit) - (OpAddr (spRel dflags off)) (OpReg reg) - RcDouble -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg) - _ -> panic "X86.x86_mkLoadInstr" - where platform = targetPlatform dflags - is32Bit = target32Bit platform - -spillSlotSize :: Platform -> Int -spillSlotSize dflags = if is32Bit then 12 else 8 - where is32Bit = target32Bit dflags - -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1 --- = 0 -- useful for testing allocMoreStack - --- number of bytes that the stack pointer should be aligned to -stackAlign :: Int -stackAlign = 16 - --- convert a spill slot number to a *byte* offset, with no sign: --- decide on a per arch basis whether you are spilling above or below --- the C stack pointer. -spillSlotToOffset :: Platform -> Int -> Int -spillSlotToOffset platform slot - = 64 + spillSlotSize platform * slot - --------------------------------------------------------------------------------- - --- | See if this instruction is telling us the current C stack delta -x86_takeDeltaInstr - :: Instr - -> Maybe Int - -x86_takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -x86_isMetaInstr - :: Instr - -> Bool - -x86_isMetaInstr instr - = case instr of - COMMENT{} -> True - LOCATION{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - UNWIND{} -> True - DELTA{} -> True - _ -> False - - - ---- TODO: why is there --- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. --- -x86_mkRegRegMoveInstr - :: Platform - -> Reg - -> Reg - -> Instr - -x86_mkRegRegMoveInstr platform src dst - = case targetClassOfReg platform src of - RcInteger -> case platformArch platform of - ArchX86 -> MOV II32 (OpReg src) (OpReg dst) - ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst) - _ -> panic "x86_mkRegRegMoveInstr: Bad arch" - RcDouble -> MOV FF64 (OpReg src) (OpReg dst) - -- this code is the lie we tell ourselves because both float and double - -- use the same register class.on x86_64 and x86 32bit with SSE2, - -- more plainly, both use the XMM registers - _ -> panic "X86.RegInfo.mkRegRegMoveInstr: no match" - --- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. --- -x86_takeRegRegMoveInstr - :: Instr - -> Maybe (Reg,Reg) - -x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2)) - = Just (r1,r2) - -x86_takeRegRegMoveInstr _ = Nothing - - --- | Make an unconditional branch instruction. -x86_mkJumpInstr - :: BlockId - -> [Instr] - -x86_mkJumpInstr id - = [JXX ALWAYS id] - --- Note [Windows stack layout] --- | On most OSes the kernel will place a guard page after the current stack --- page. If you allocate larger than a page worth you may jump over this --- guard page. Not only is this a security issue, but on certain OSes such --- as Windows a new page won't be allocated if you don't hit the guard. This --- will cause a segfault or access fault. --- --- This function defines if the current allocation amount requires a probe. --- On Windows (for now) we emit a call to _chkstk for this. For other OSes --- this is not yet implemented. --- See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk --- The Windows stack looks like this: --- --- +-------------------+ --- | SP | --- +-------------------+ --- | | --- | GUARD PAGE | --- | | --- +-------------------+ --- | | --- | | --- | UNMAPPED | --- | | --- | | --- +-------------------+ --- --- In essense each allocation larger than a page size needs to be chunked and --- a probe emitted after each page allocation. You have to hit the guard --- page so the kernel can map in the next page, otherwise you'll segfault. --- See Note [Windows stack allocations]. --- -needs_probe_call :: Platform -> Int -> Bool -needs_probe_call platform amount - = case platformOS platform of - OSMinGW32 -> case platformArch platform of - ArchX86 -> amount > (4 * 1024) - ArchX86_64 -> amount > (4 * 1024) - _ -> False - _ -> False - -x86_mkStackAllocInstr - :: Platform - -> Int - -> [Instr] -x86_mkStackAllocInstr platform amount - = case platformOS platform of - OSMinGW32 -> - -- These will clobber AX but this should be ok because - -- - -- 1. It is the first thing we do when entering the closure and AX is - -- a caller saved registers on Windows both on x86_64 and x86. - -- - -- 2. The closures are only entered via a call or longjmp in which case - -- there are no expectations for volatile registers. - -- - -- 3. When the target is a local branch point it is re-targeted - -- after the dealloc, preserving #2. See note [extra spill slots]. - -- - -- We emit a call because the stack probes are quite involved and - -- would bloat code size a lot. GHC doesn't really have an -Os. - -- ___chkstk is guaranteed to leave all nonvolatile registers and AX - -- untouched. It's part of the standard prologue code for any Windows - -- function dropping the stack more than a page. - -- See Note [Windows stack layout] - case platformArch platform of - ArchX86 | needs_probe_call platform amount -> - [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax) - , CALL (Left $ strImmLit "___chkstk_ms") [eax] - , SUB II32 (OpReg eax) (OpReg esp) - ] - | otherwise -> - [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) - , TEST II32 (OpReg esp) (OpReg esp) - ] - ArchX86_64 | needs_probe_call platform amount -> - [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax) - , CALL (Left $ strImmLit "___chkstk_ms") [rax] - , SUB II64 (OpReg rax) (OpReg rsp) - ] - | otherwise -> - [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) - , TEST II64 (OpReg rsp) (OpReg rsp) - ] - _ -> panic "x86_mkStackAllocInstr" - _ -> - case platformArch platform of - ArchX86 -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ] - ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ] - _ -> panic "x86_mkStackAllocInstr" - -x86_mkStackDeallocInstr - :: Platform - -> Int - -> [Instr] -x86_mkStackDeallocInstr platform amount - = case platformArch platform of - ArchX86 -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)] - ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)] - _ -> panic "x86_mkStackDeallocInstr" - - --- --- Note [extra spill slots] --- --- If the register allocator used more spill slots than we have --- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more --- C stack space on entry and exit from this proc. Therefore we --- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp" --- before every non-local jump. --- --- This became necessary when the new codegen started bundling entire --- functions together into one proc, because the register allocator --- assigns a different stack slot to each virtual reg within a proc. --- To avoid using so many slots we could also: --- --- - split up the proc into connected components before code generator --- --- - rename the virtual regs, so that we re-use vreg names and hence --- stack slots for non-overlapping vregs. --- --- Note that when a block is both a non-local entry point (with an --- info table) and a local branch target, we have to split it into --- two, like so: --- --- --- L: --- --- --- becomes --- --- --- L: --- subl $rsp, N --- jmp Lnew --- Lnew: --- --- --- and all branches pointing to L are retargetted to point to Lnew. --- Otherwise, we would repeat the $rsp adjustment for each branch to --- L. --- --- Returns a list of (L,Lnew) pairs. --- -allocMoreStack - :: Platform - -> Int - -> NatCmmDecl statics X86.Instr.Instr - -> UniqSM (NatCmmDecl statics X86.Instr.Instr, [(BlockId,BlockId)]) - -allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) -allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do - let entries = entryBlocks proc - - uniqs <- replicateM (length entries) getUniqueM - - let - delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up - where x = slots * spillSlotSize platform -- sp delta - - alloc = mkStackAllocInstr platform delta - dealloc = mkStackDeallocInstr platform delta - - retargetList = (zip entries (map mkBlockId uniqs)) - - new_blockmap :: LabelMap BlockId - new_blockmap = mapFromList retargetList - - insert_stack_insns (BasicBlock id insns) - | Just new_blockid <- mapLookup id new_blockmap - = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid] - , BasicBlock new_blockid block' ] - | otherwise - = [ BasicBlock id block' ] - where - block' = foldr insert_dealloc [] insns - - insert_dealloc insn r = case insn of - JMP _ _ -> dealloc ++ (insn : r) - JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL" - _other -> x86_patchJumpInstr insn retarget : r - where retarget b = fromMaybe b (mapLookup b new_blockmap) - - new_code = concatMap insert_stack_insns code - -- in - return (CmmProc info lbl live (ListGraph new_code), retargetList) - -data JumpDest = DestBlockId BlockId | DestImm Imm - --- Debug Instance -instance Outputable JumpDest where - ppr (DestBlockId bid) = text "jd:" <> ppr bid - ppr (DestImm _imm) = text "jd:noShow" - - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid -getJumpDestBlockId _ = Nothing - -canShortcut :: Instr -> Maybe JumpDest -canShortcut (JXX ALWAYS id) = Just (DestBlockId id) -canShortcut (JMP (OpImm imm) _) = Just (DestImm imm) -canShortcut _ = Nothing - - --- This helper shortcuts a sequence of branches. --- The blockset helps avoid following cycles. -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn - where - shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr - shortcutJump' fn seen insn@(JXX cc id) = - if setMember id seen then insn - else case fn id of - Nothing -> insn - Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') - Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) - where seen' = setInsert id seen - shortcutJump' fn _ (JMP_TBL addr blocks section tblId) = - let updateBlock (Just (DestBlockId bid)) = - case fn bid of - Nothing -> Just (DestBlockId bid ) - Just dest -> Just dest - updateBlock dest = dest - blocks' = map updateBlock blocks - in JMP_TBL addr blocks' section tblId - shortcutJump' _ _ other = other - --- Here because it knows about JumpDest -shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) -shortcutStatics fn (align, Statics lbl statics) - = (align, Statics lbl $ map (shortcutStatic fn) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId - | otherwise = lab - -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) - -- slightly dodgy, we're ignoring the second label, but this - -- works with the way we use CmmLabelDiffOff for jump tables now. -shortcutStatic _ other_static - = other_static - -shortBlockId - :: (BlockId -> Maybe JumpDest) - -> UniqSet Unique - -> BlockId - -> CLabel - -shortBlockId fn seen blockid = - case (elementOfUniqSet uq seen, fn blockid) of - (True, _) -> blockLbl blockid - (_, Nothing) -> blockLbl blockid - (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' - (_, Just (DestImm (ImmCLbl lbl))) -> lbl - (_, _other) -> panic "shortBlockId" - where uq = getUnique blockid diff --git a/nativeGen/X86/Ppr.hs b/nativeGen/X86/Ppr.hs deleted file mode 100644 --- a/nativeGen/X86/Ppr.hs +++ /dev/null @@ -1,1009 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module X86.Ppr ( - pprNatCmmDecl, - pprData, - pprInstr, - pprFormat, - pprImm, - pprDataItem, -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import X86.Regs -import X86.Instr -import X86.Cond -import Instruction -import Format -import Reg -import PprBase - - -import Hoopl.Collections -import Hoopl.Label -import BasicTypes (Alignment, mkAlignment, alignmentBytes) -import DynFlags -import Cmm hiding (topInfoTable) -import BlockId -import CLabel -import Unique ( pprUniqueAlways ) -import GHC.Platform -import FastString -import Outputable - -import Data.Word -import Data.Bits - --- ----------------------------------------------------------------------------- --- Printing this stuff out --- --- --- Note [Subsections Via Symbols] --- --- If we are using the .subsections_via_symbols directive --- (available on recent versions of Darwin), --- we have to make sure that there is some kind of reference --- from the entry code to a label on the _top_ of of the info table, --- so that the linker will not think it is unreferenced and dead-strip --- it. That's why the label is called a DeadStripPreventer (_dsp). --- --- The LLVM code gen already creates `iTableSuf` symbols, where --- the X86 would generate the DeadStripPreventer (_dsp) symbol. --- Therefore all that is left for llvm code gen, is to ensure --- that all the `iTableSuf` symbols are marked as used. --- As of this writing the documentation regarding the --- .subsections_via_symbols and -dead_strip can be found at --- - -pprProcAlignment :: SDoc -pprProcAlignment = sdocWithDynFlags $ \dflags -> - (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags)) - -pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats - -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - sdocWithDynFlags $ \dflags -> - pprProcAlignment $$ - case topInfoTable proc of - Nothing -> - -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - pprProcAlignment $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock top_info) blocks) $$ - (if debugLevel dflags > 0 - then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ - pprSizeDecl lbl - - Just (Statics info_lbl _) -> - sdocWithPlatform $ \platform -> - pprSectionAlign (Section Text info_lbl) $$ - pprProcAlignment $$ - (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then -- See Note [Subsections Via Symbols] - text "\t.long " - <+> ppr info_lbl - <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) - else empty) $$ - pprSizeDecl info_lbl - --- | Output the ELF .size directive. -pprSizeDecl :: CLabel -> SDoc -pprSizeDecl lbl - = sdocWithPlatform $ \platform -> - if osElfTarget (platformOS platform) - then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl - else empty - -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) - = sdocWithDynFlags $ \dflags -> - maybe_infotable dflags $ - pprLabel asmLbl $$ - vcat (map pprInstr instrs) $$ - (if debugLevel dflags > 0 - then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty) - where - asmLbl = blockLbl blockid - maybe_infotable dflags c = case mapLookup blockid info_env of - Nothing -> c - Just (Statics infoLbl info) -> - pprAlignForSection Text $$ - infoTableLoc $$ - vcat (map pprData info) $$ - pprLabel infoLbl $$ - c $$ - (if debugLevel dflags > 0 - then ppr (mkAsmTempEndLabel infoLbl) <> char ':' else empty) - -- Make sure the info table has the right .loc for the block - -- coming right after it. See [Note: Info Offset] - infoTableLoc = case instrs of - (l@LOCATION{} : _) -> pprInstr l - _other -> empty - - -pprDatas :: (Alignment, CmmStatics) -> SDoc --- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) - | lbl == mkIndStaticInfoLabel - , let labelInd (CmmLabelOff l _) = Just l - labelInd (CmmLabel l) = Just l - labelInd _ = Nothing - , Just ind' <- labelInd ind - , alias `mayRedirectTo` ind' - = pprGloblDecl alias - $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') - -pprDatas (align, (Statics lbl dats)) - = vcat (pprAlign align : pprLabel lbl : map pprData dats) - -pprData :: CmmStatic -> SDoc -pprData (CmmString str) = pprBytes str - -pprData (CmmUninitialised bytes) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin then text ".space " <> int bytes - else text ".skip " <> int bytes - -pprData (CmmStaticLit lit) = pprDataItem lit - -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> ppr lbl - -pprLabelType' :: DynFlags -> CLabel -> SDoc -pprLabelType' dflags lbl = - if isCFunctionLabel lbl || functionOkInfoTable then - text "@function" - else - text "@object" - where - {- - NOTE: This is a bit hacky. - - With the `tablesNextToCode` info tables look like this: - ``` - - label_info: - - ``` - So actually info table label points exactly to the code and we can mark - the label as @function. (This is required to make perf and potentially other - tools to work on Haskell binaries). - This usually works well but it can cause issues with a linker. - A linker uses different algorithms for the relocation depending on - the symbol type.For some reason, a linker will generate JUMP_SLOT relocation - when constructor info table is referenced from a data section. - This only happens with static constructor call so - we mark _con_info symbols as `@object` to avoid the issue with relocations. - - @SimonMarlow hack explanation: - "The reasoning goes like this: - - * The danger when we mark a symbol as `@function` is that the linker will - redirect it to point to the PLT and use a `JUMP_SLOT` relocation when - the symbol refers to something outside the current shared object. - A PLT / JUMP_SLOT reference only works for symbols that we jump to, not - for symbols representing data,, nor for info table symbol references which - we expect to point directly to the info table. - * GHC generates code that might refer to any info table symbol from the text - segment, but that's OK, because those will be explicit GOT references - generated by the code generator. - * When we refer to info tables from the data segment, it's either - * a FUN_STATIC/THUNK_STATIC local to this module - * a `con_info` that could be from anywhere - - So, the only info table symbols that we might refer to from the data segment - of another shared object are `con_info` symbols, so those are the ones we - need to exclude from getting the @function treatment. - " - - A good place to check for more - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code - - Another possible hack is to create an extra local function symbol for - every code-like thing to give the needed information for to the tools - but mess up with the relocation. https://phabricator.haskell.org/D4730 - -} - functionOkInfoTable = tablesNextToCode dflags && - isInfoTableLabel lbl && not (isConInfoTableLabel lbl) - - -pprTypeDecl :: CLabel -> SDoc -pprTypeDecl lbl - = sdocWithPlatform $ \platform -> - if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then - sdocWithDynFlags $ \df -> - text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' df lbl - else empty - -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeDecl lbl - $$ (ppr lbl <> char ':') - -pprAlign :: Alignment -> SDoc -pprAlign alignment - = sdocWithPlatform $ \platform -> - text ".align " <> int (alignmentOn platform) - where - bytes = alignmentBytes alignment - alignmentOn platform = if platformOS platform == OSDarwin - then log2 bytes - else bytes - - log2 :: Int -> Int -- cache the common ones - log2 1 = 0 - log2 2 = 1 - log2 4 = 2 - log2 8 = 3 - log2 n = 1 + log2 (n `quot` 2) - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance Outputable Instr where - ppr instr = pprInstr instr - - -pprReg :: Format -> Reg -> SDoc -pprReg f r - = case r of - RegReal (RealRegSingle i) -> - sdocWithPlatform $ \platform -> - if target32Bit platform then ppr32_reg_no f i - else ppr64_reg_no f i - RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u - RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u - RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u - - where - ppr32_reg_no :: Format -> Int -> SDoc - ppr32_reg_no II8 = ppr32_reg_byte - ppr32_reg_no II16 = ppr32_reg_word - ppr32_reg_no _ = ppr32_reg_long - - ppr32_reg_byte i = ptext - (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - _ -> sLit $ "very naughty I386 byte register: " ++ show i - }) - - ppr32_reg_word i = ptext - (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - _ -> sLit "very naughty I386 word register" - }) - - ppr32_reg_long i = ptext - (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; - _ -> ppr_reg_float i - }) - - ppr64_reg_no :: Format -> Int -> SDoc - ppr64_reg_no II8 = ppr64_reg_byte - ppr64_reg_no II16 = ppr64_reg_word - ppr64_reg_no II32 = ppr64_reg_long - ppr64_reg_no _ = ppr64_reg_quad - - ppr64_reg_byte i = ptext - (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs! - 6 -> sLit "%bpl"; 7 -> sLit "%spl"; - 8 -> sLit "%r8b"; 9 -> sLit "%r9b"; - 10 -> sLit "%r10b"; 11 -> sLit "%r11b"; - 12 -> sLit "%r12b"; 13 -> sLit "%r13b"; - 14 -> sLit "%r14b"; 15 -> sLit "%r15b"; - _ -> sLit $ "very naughty x86_64 byte register: " ++ show i - }) - - ppr64_reg_word i = ptext - (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - 8 -> sLit "%r8w"; 9 -> sLit "%r9w"; - 10 -> sLit "%r10w"; 11 -> sLit "%r11w"; - 12 -> sLit "%r12w"; 13 -> sLit "%r13w"; - 14 -> sLit "%r14w"; 15 -> sLit "%r15w"; - _ -> sLit "very naughty x86_64 word register" - }) - - ppr64_reg_long i = ptext - (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; - 8 -> sLit "%r8d"; 9 -> sLit "%r9d"; - 10 -> sLit "%r10d"; 11 -> sLit "%r11d"; - 12 -> sLit "%r12d"; 13 -> sLit "%r13d"; - 14 -> sLit "%r14d"; 15 -> sLit "%r15d"; - _ -> sLit "very naughty x86_64 register" - }) - - ppr64_reg_quad i = ptext - (case i of { - 0 -> sLit "%rax"; 1 -> sLit "%rbx"; - 2 -> sLit "%rcx"; 3 -> sLit "%rdx"; - 4 -> sLit "%rsi"; 5 -> sLit "%rdi"; - 6 -> sLit "%rbp"; 7 -> sLit "%rsp"; - 8 -> sLit "%r8"; 9 -> sLit "%r9"; - 10 -> sLit "%r10"; 11 -> sLit "%r11"; - 12 -> sLit "%r12"; 13 -> sLit "%r13"; - 14 -> sLit "%r14"; 15 -> sLit "%r15"; - _ -> ppr_reg_float i - }) - -ppr_reg_float :: Int -> PtrString -ppr_reg_float i = case i of - 16 -> sLit "%xmm0" ; 17 -> sLit "%xmm1" - 18 -> sLit "%xmm2" ; 19 -> sLit "%xmm3" - 20 -> sLit "%xmm4" ; 21 -> sLit "%xmm5" - 22 -> sLit "%xmm6" ; 23 -> sLit "%xmm7" - 24 -> sLit "%xmm8" ; 25 -> sLit "%xmm9" - 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11" - 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13" - 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15" - _ -> sLit "very naughty x86 register" - -pprFormat :: Format -> SDoc -pprFormat x - = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "w" - II32 -> sLit "l" - II64 -> sLit "q" - FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) - FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) - ) - -pprFormat_x87 :: Format -> SDoc -pprFormat_x87 x - = ptext $ case x of - FF32 -> sLit "s" - FF64 -> sLit "l" - _ -> panic "X86.Ppr.pprFormat_x87" - - -pprCond :: Cond -> SDoc -pprCond c - = ptext (case c of { - GEU -> sLit "ae"; LU -> sLit "b"; - EQQ -> sLit "e"; GTT -> sLit "g"; - GE -> sLit "ge"; GU -> sLit "a"; - LTT -> sLit "l"; LE -> sLit "le"; - LEU -> sLit "be"; NE -> sLit "ne"; - NEG -> sLit "s"; POS -> sLit "ns"; - CARRY -> sLit "c"; OFLO -> sLit "o"; - PARITY -> sLit "p"; NOTPARITY -> sLit "np"; - ALWAYS -> sLit "mp"}) - - -pprImm :: Imm -> SDoc -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = ppr l -pprImm (ImmIndex l i) = ppr l <> char '+' <> int i -pprImm (ImmLit s) = s - -pprImm (ImmFloat _) = text "naughty float immediate" -pprImm (ImmDouble _) = text "naughty double immediate" - -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen - - - -pprAddr :: AddrMode -> SDoc -pprAddr (ImmAddr imm off) - = let pp_imm = pprImm imm - in - if (off == 0) then - pp_imm - else if (off < 0) then - pp_imm <> int off - else - pp_imm <> char '+' <> int off - -pprAddr (AddrBaseIndex base index displacement) - = sdocWithPlatform $ \platform -> - let - pp_disp = ppr_disp displacement - pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg (archWordFormat (target32Bit platform)) r - in - case (base, index) of - (EABaseNone, EAIndexNone) -> pp_disp - (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b) - (EABaseRip, EAIndexNone) -> pp_off (text "%rip") - (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i) - (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r - <> comma <> int i) - _ -> panic "X86.Ppr.pprAddr: no match" - - where - ppr_disp (ImmInt 0) = empty - ppr_disp imm = pprImm imm - --- | Print section header and appropriate alignment for that section. -pprSectionAlign :: Section -> SDoc -pprSectionAlign (Section (OtherSection _) _) = - panic "X86.Ppr.pprSectionAlign: unknown section" -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - sdocWithPlatform $ \platform -> - text ".align " <> - case platformOS platform of - -- Darwin: alignments are given as shifts. - OSDarwin - | target32Bit platform -> - case seg of - ReadOnlyData16 -> int 4 - CString -> int 1 - _ -> int 2 - | otherwise -> - case seg of - ReadOnlyData16 -> int 4 - CString -> int 1 - _ -> int 3 - -- Other: alignments are given as bytes. - _ - | target32Bit platform -> - case seg of - Text -> text "4,0x90" - ReadOnlyData16 -> int 16 - CString -> int 1 - _ -> int 4 - | otherwise -> - case seg of - ReadOnlyData16 -> int 16 - CString -> int 1 - _ -> int 8 - -pprDataItem :: CmmLit -> SDoc -pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit - -pprDataItem' :: DynFlags -> CmmLit -> SDoc -pprDataItem' dflags lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit) - where - platform = targetPlatform dflags - imm = litToImm lit - - -- These seem to be common: - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II16 _ = [text "\t.word\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] - - ppr_item FF32 (CmmFloat r _) - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - - ppr_item II64 _ - = case platformOS platform of - OSDarwin - | target32Bit platform -> - case lit of - CmmInt x _ -> - [text "\t.long\t" - <> int (fromIntegral (fromIntegral x :: Word32)), - text "\t.long\t" - <> int (fromIntegral - (fromIntegral (x `shiftR` 32) :: Word32))] - _ -> panic "X86.Ppr.ppr_item: no match for II64" - | otherwise -> - [text "\t.quad\t" <> pprImm imm] - _ - | target32Bit platform -> - [text "\t.quad\t" <> pprImm imm] - | otherwise -> - -- x86_64: binutils can't handle the R_X86_64_PC64 - -- relocation type, which means we can't do - -- pc-relative 64-bit addresses. Fortunately we're - -- assuming the small memory model, in which all such - -- offsets will fit into 32 bits, so we have to stick - -- to 32-bit offset fields and modify the RTS - -- appropriately - -- - -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h - -- - case lit of - -- A relative relocation: - CmmLabelDiffOff _ _ _ _ -> - [text "\t.long\t" <> pprImm imm, - text "\t.long\t0"] - _ -> - [text "\t.quad\t" <> pprImm imm] - - ppr_item _ _ - = panic "X86.Ppr.ppr_item: no match" - - -asmComment :: SDoc -> SDoc -asmComment c = whenPprDebug $ text "# " <> c - -pprInstr :: Instr -> SDoc - -pprInstr (COMMENT s) - = asmComment (ftext s) - -pprInstr (LOCATION file line col _name) - = text "\t.loc " <> ppr file <+> ppr line <+> ppr col - -pprInstr (DELTA d) - = asmComment $ text ("\tdelta = " ++ show d) - -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" - -pprInstr (UNWIND lbl d) - = asmComment (text "\tunwind = " <> ppr d) - $$ ppr lbl <> colon - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - -{- -pprInstr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char ' ', - pprUserReg reg, - comma, - text "SLOT" <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - text "\tRELOAD", - char ' ', - text "SLOT" <> parens (int slot), - comma, - pprUserReg reg] --} - --- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper. --- The code generator catches most of these already, but not all. -pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _)) - = pprInstr (XOR format' dst dst) - where format' = case format of - II64 -> II32 -- 32-bit version is equivalent, and smaller - _ -> format -pprInstr (MOV format src dst) - = pprFormatOpOp (sLit "mov") format src dst - -pprInstr (CMOV cc format src dst) - = pprCondOpReg (sLit "cmov") format cc src dst - -pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst - -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple - -- movl. But we represent it as a MOVZxL instruction, because - -- the reg alloc would tend to throw away a plain reg-to-reg - -- move, and we still want it to do that. - -pprInstr (MOVZxL formats src dst) - = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst - -- zero-extension only needs to extend to 32 bits: on x86_64, - -- the remaining zero-extension to 64 bits is automatic, and the 32-bit - -- instruction is shorter. - -pprInstr (MOVSxL formats src dst) - = sdocWithPlatform $ \platform -> - pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst - --- here we do some patching, since the physical registers are only set late --- in the code generation. -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) - | reg1 == reg3 - = pprFormatOpOp (sLit "add") format (OpReg reg2) dst - -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) - | reg2 == reg3 - = pprFormatOpOp (sLit "add") format (OpReg reg1) dst - -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) - | reg1 == reg3 - = pprInstr (ADD format (OpImm displ) dst) - -pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst - -pprInstr (ADD format (OpImm (ImmInt (-1))) dst) - = pprFormatOp (sLit "dec") format dst -pprInstr (ADD format (OpImm (ImmInt 1)) dst) - = pprFormatOp (sLit "inc") format dst -pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst -pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst -pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst -pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst -pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2 - -pprInstr (ADD_CC format src dst) - = pprFormatOpOp (sLit "add") format src dst -pprInstr (SUB_CC format src dst) - = pprFormatOpOp (sLit "sub") format src dst - -{- A hack. The Intel documentation says that "The two and three - operand forms [of IMUL] may also be used with unsigned operands - because the lower half of the product is the same regardless if - (sic) the operands are signed or unsigned. The CF and OF flags, - however, cannot be used to determine if the upper half of the - result is non-zero." So there. --} - --- Use a 32-bit instruction when possible as it saves a byte. --- Notably, extracting the tag bits of a pointer has this form. --- TODO: we could save a byte in a subsequent CMP instruction too, --- but need something like a peephole pass for this -pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst) - | 0 <= mask && mask < 0xffffffff - = pprInstr (AND II32 src dst) -pprInstr (AND FF32 src dst) = pprOpOp (sLit "andps") FF32 src dst -pprInstr (AND FF64 src dst) = pprOpOp (sLit "andpd") FF64 src dst -pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst -pprInstr (OR format src dst) = pprFormatOpOp (sLit "or") format src dst - -pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst -pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst -pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor") format src dst - -pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst) -pprInstr (LZCNT format src dst) = pprOpOp (sLit "lzcnt") format src (OpReg dst) -pprInstr (TZCNT format src dst) = pprOpOp (sLit "tzcnt") format src (OpReg dst) -pprInstr (BSF format src dst) = pprOpOp (sLit "bsf") format src (OpReg dst) -pprInstr (BSR format src dst) = pprOpOp (sLit "bsr") format src (OpReg dst) - -pprInstr (PDEP format src mask dst) = pprFormatOpOpReg (sLit "pdep") format src mask dst -pprInstr (PEXT format src mask dst) = pprFormatOpOpReg (sLit "pext") format src mask dst - -pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src -pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src -pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src -pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src - -pprInstr (NOT format op) = pprFormatOp (sLit "not") format op -pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op) -pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op - -pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst -pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst -pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst - -pprInstr (BT format imm src) = pprFormatImmOp (sLit "bt") format imm src - -pprInstr (CMP format src dst) - | isFloatFormat format = pprFormatOpOp (sLit "ucomi") format src dst -- SSE2 - | otherwise = pprFormatOpOp (sLit "cmp") format src dst - -pprInstr (TEST format src dst) = sdocWithPlatform $ \platform -> - let format' = case (src,dst) of - -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. - -- We can replace them by equivalent, but smaller instructions - -- by reducing the size of the immediate operand as far as possible. - -- (We could handle masks larger than a single byte too, - -- but it would complicate the code considerably - -- and tag checks are by far the most common case.) - -- The mask must have the high bit clear for this smaller encoding - -- to be completely equivalent to the original; in particular so - -- that the signed comparison condition bits are the same as they - -- would be if doing a full word comparison. See #13425. - (OpImm (ImmInteger mask), OpReg dstReg) - | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg - _ -> format - in pprFormatOpOp (sLit "test") format' src dst - where - minSizeOfReg platform (RegReal (RealRegSingle i)) - | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl - | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp - | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b - minSizeOfReg _ _ = format -- other - -pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op -pprInstr (POP format op) = pprFormatOp (sLit "pop") format op - --- both unused (SDM): --- pprInstr PUSHA = text "\tpushal" --- pprInstr POPA = text "\tpopal" - -pprInstr NOP = text "\tnop" -pprInstr (CLTD II8) = text "\tcbtw" -pprInstr (CLTD II16) = text "\tcwtd" -pprInstr (CLTD II32) = text "\tcltd" -pprInstr (CLTD II64) = text "\tcqto" -pprInstr (CLTD x) = panic $ "pprInstr: " ++ show x - -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) - -pprInstr (JXX cond blockid) - = pprCondInstr (sLit "j") cond (ppr lab) - where lab = blockLbl blockid - -pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) - -pprInstr (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm -pprInstr (JMP op _) = sdocWithPlatform $ \platform -> - text "\tjmp *" - <> pprOperand (archWordFormat (target32Bit platform)) op -pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op []) -pprInstr (CALL (Left imm) _) = text "\tcall " <> pprImm imm -pprInstr (CALL (Right reg) _) = sdocWithPlatform $ \platform -> - text "\tcall *" - <> pprReg (archWordFormat (target32Bit platform)) reg - -pprInstr (IDIV fmt op) = pprFormatOp (sLit "idiv") fmt op -pprInstr (DIV fmt op) = pprFormatOp (sLit "div") fmt op -pprInstr (IMUL2 fmt op) = pprFormatOp (sLit "imul") fmt op - --- x86_64 only -pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2 -pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op - -pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2 -pprInstr (SQRT format op1 op2) = pprFormatOpReg (sLit "sqrt") format op1 op2 - -pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to -pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to -pprInstr (CVTSI2SS fmt from to) = pprFormatOpReg (sLit "cvtsi2ss") fmt from to -pprInstr (CVTSI2SD fmt from to) = pprFormatOpReg (sLit "cvtsi2sd") fmt from to - - -- FETCHGOT for PIC on ELF platforms -pprInstr (FETCHGOT reg) - = vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg II32 reg ], - hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", - pprReg II32 reg ] - ] - - -- FETCHPC for PIC on Darwin/x86 - -- get the instruction pointer into a register - -- (Terminology note: the IP is called Program Counter on PPC, - -- and it's a good thing to use the same name on both platforms) -pprInstr (FETCHPC reg) - = vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg II32 reg ] - ] - - --- the --- GST fmt src addr ==> FLD dst ; FSTPsz addr -pprInstr g@(X87Store fmt addr) - = pprX87 g (hcat [gtab, - text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr]) - - --- Atomics - -pprInstr (LOCK i) = text "\tlock" $$ pprInstr i - -pprInstr MFENCE = text "\tmfence" - -pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst - -pprInstr (CMPXCHG format src dst) - = pprFormatOpOp (sLit "cmpxchg") format src dst - - - --------------------------- --- some left over - - - -gtab :: SDoc -gtab = char '\t' - -gsp :: SDoc -gsp = char ' ' - - - -pprX87 :: Instr -> SDoc -> SDoc -pprX87 fake actual - = (char '#' <> pprX87Instr fake) $$ actual - -pprX87Instr :: Instr -> SDoc -pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst -pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" - -pprDollImm :: Imm -> SDoc -pprDollImm i = text "$" <> pprImm i - - -pprOperand :: Format -> Operand -> SDoc -pprOperand f (OpReg r) = pprReg f r -pprOperand _ (OpImm i) = pprDollImm i -pprOperand _ (OpAddr ea) = pprAddr ea - - -pprMnemonic_ :: PtrString -> SDoc -pprMnemonic_ name = - char '\t' <> ptext name <> space - - -pprMnemonic :: PtrString -> Format -> SDoc -pprMnemonic name format = - char '\t' <> ptext name <> pprFormat format <> space - - -pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc -pprFormatImmOp name format imm op1 - = hcat [ - pprMnemonic name format, - char '$', - pprImm imm, - comma, - pprOperand format op1 - ] - - -pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc -pprFormatOp_ name format op1 - = hcat [ - pprMnemonic_ name , - pprOperand format op1 - ] - -pprFormatOp :: PtrString -> Format -> Operand -> SDoc -pprFormatOp name format op1 - = hcat [ - pprMnemonic name format, - pprOperand format op1 - ] - - -pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc -pprFormatOpOp name format op1 op2 - = hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprOperand format op2 - ] - - -pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc -pprOpOp name format op1 op2 - = hcat [ - pprMnemonic_ name, - pprOperand format op1, - comma, - pprOperand format op2 - ] - - - -pprRegReg :: PtrString -> Reg -> Reg -> SDoc -pprRegReg name reg1 reg2 - = sdocWithPlatform $ \platform -> - hcat [ - pprMnemonic_ name, - pprReg (archWordFormat (target32Bit platform)) reg1, - comma, - pprReg (archWordFormat (target32Bit platform)) reg2 - ] - - -pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc -pprFormatOpReg name format op1 reg2 - = sdocWithPlatform $ \platform -> - hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprReg (archWordFormat (target32Bit platform)) reg2 - ] - -pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc -pprCondOpReg name format cond op1 reg2 - = hcat [ - char '\t', - ptext name, - pprCond cond, - space, - pprOperand format op1, - comma, - pprReg format reg2 - ] - -pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc -pprFormatFormatOpReg name format1 format2 op1 reg2 - = hcat [ - pprMnemonic name format2, - pprOperand format1 op1, - comma, - pprReg format2 reg2 - ] - -pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc -pprFormatOpOpReg name format op1 op2 reg3 - = hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprOperand format op2, - comma, - pprReg format reg3 - ] - - - -pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc -pprFormatAddr name format op - = hcat [ - pprMnemonic name format, - comma, - pprAddr op - ] - -pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc -pprShift name format src dest - = hcat [ - pprMnemonic name format, - pprOperand II8 src, -- src is 8-bit sized - comma, - pprOperand format dest - ] - - -pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc -pprFormatOpOpCoerce name format1 format2 op1 op2 - = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space, - pprOperand format1 op1, - comma, - pprOperand format2 op2 - ] - - -pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc -pprCondInstr name cond arg - = hcat [ char '\t', ptext name, pprCond cond, space, arg] diff --git a/nativeGen/X86/RegInfo.hs b/nativeGen/X86/RegInfo.hs deleted file mode 100644 --- a/nativeGen/X86/RegInfo.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE CPP #-} -module X86.RegInfo ( - mkVirtualReg, - regDotColor -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import Format -import Reg - -import Outputable -import GHC.Platform -import Unique - -import UniqFM -import X86.Regs - - -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - = case format of - FF32 -> VirtualRegD u - -- for scalar F32, we use the same xmm as F64! - -- this is a hack that needs some improvement. - -- For now we map both to being allocated as "Double" Registers - -- on X86/X86_64 - FF64 -> VirtualRegD u - _other -> VirtualRegI u - -regDotColor :: Platform -> RealReg -> SDoc -regDotColor platform reg - = case (lookupUFM (regColors platform) reg) of - Just str -> text str - _ -> panic "Register not assigned a color" - -regColors :: Platform -> UniqFM [Char] -regColors platform = listToUFM (normalRegColors platform) - -normalRegColors :: Platform -> [(Reg,String)] -normalRegColors platform = - zip (map regSingle [0..lastint platform]) colors - ++ zip (map regSingle [firstxmm..lastxmm platform]) greys - where - -- 16 colors - enough for amd64 gp regs - colors = ["#800000","#ff0000","#808000","#ffff00","#008000" - ,"#00ff00","#008080","#00ffff","#000080","#0000ff" - ,"#800080","#ff00ff","#87005f","#875f00","#87af00" - ,"#ff00af"] - - -- 16 shades of grey, enough for the currently supported - -- SSE extensions. - greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646" - ,"#545454","#626262","#707070","#7e7e7e","#8c8c8c" - ,"#9a9a9a","#a8a8a8","#b6b6b6","#c4c4c4","#d2d2d2" - ,"#e0e0e0"] - - - --- 32 shades of grey - use for avx 512 if we ever need it --- greys = ["#070707","#0e0e0e","#151515","#1c1c1c" --- ,"#232323","#2a2a2a","#313131","#383838","#3f3f3f" --- ,"#464646","#4d4d4d","#545454","#5b5b5b","#626262" --- ,"#696969","#707070","#777777","#7e7e7e","#858585" --- ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8" --- ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb" --- ,"#d2d2d2","#d9d9d9","#e0e0e0"] - - diff --git a/nativeGen/X86/Regs.hs b/nativeGen/X86/Regs.hs deleted file mode 100644 --- a/nativeGen/X86/Regs.hs +++ /dev/null @@ -1,442 +0,0 @@ -{-# LANGUAGE CPP #-} - -module X86.Regs ( - -- squeese functions for the graph allocator - virtualRegSqueeze, - realRegSqueeze, - - -- immediates - Imm(..), - strImmLit, - litToImm, - - -- addressing modes - AddrMode(..), - addrOffset, - - -- registers - spRel, - argRegs, - allArgRegs, - allIntArgRegs, - callClobberedRegs, - instrClobberedRegs, - allMachRegNos, - classOfRealReg, - showReg, - - -- machine specific - EABase(..), EAIndex(..), addrModeRegs, - - eax, ebx, ecx, edx, esi, edi, ebp, esp, - - - rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp, - r8, r9, r10, r11, r12, r13, r14, r15, - lastint, - xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, - xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15, - xmm, - firstxmm, lastxmm, - - ripRel, - allFPArgRegs, - - allocatableRegs -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Platform.Regs -import Reg -import RegClass - -import Cmm -import CLabel ( CLabel ) -import DynFlags -import Outputable -import GHC.Platform - -import qualified Data.Array as A - --- | regSqueeze_class reg --- Calculate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int - -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegD{} -> 1 - VirtualRegF{} -> 0 - _other -> 0 - - - _other -> 0 - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < firstxmm -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo >= firstxmm -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - - _other -> 0 - --- ----------------------------------------------------------------------------- --- Immediates - -data Imm - = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - -litToImm :: CmmLit -> Imm -litToImm (CmmInt i w) = ImmInteger (narrowS w i) - -- narrow to the width: a CmmInt might be out of - -- range, but we assume that ImmInteger only contains - -- in-range values. A signed value should be fine here. -litToImm (CmmFloat f W32) = ImmFloat f -litToImm (CmmFloat f W64) = ImmDouble f -litToImm (CmmLabel l) = ImmCLbl l -litToImm (CmmLabelOff l off) = ImmIndex l off -litToImm (CmmLabelDiffOff l1 l2 off _) - = ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) -litToImm _ = panic "X86.Regs.litToImm: no match" - --- addressing modes ------------------------------------------------------------ - -data AddrMode - = AddrBaseIndex EABase EAIndex Displacement - | ImmAddr Imm Int - -data EABase = EABaseNone | EABaseReg Reg | EABaseRip -data EAIndex = EAIndexNone | EAIndex Reg Int -type Displacement = Imm - - -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) - - AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off))) - AddrBaseIndex r i (ImmInteger n) - -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off)))) - - AddrBaseIndex r i (ImmCLbl lbl) - -> Just (AddrBaseIndex r i (ImmIndex lbl off)) - - AddrBaseIndex r i (ImmIndex lbl ix) - -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off))) - - _ -> Nothing -- in theory, shouldn't happen - - -addrModeRegs :: AddrMode -> [Reg] -addrModeRegs (AddrBaseIndex b i _) = b_regs ++ i_regs - where - b_regs = case b of { EABaseReg r -> [r]; _ -> [] } - i_regs = case i of { EAIndex r _ -> [r]; _ -> [] } -addrModeRegs _ = [] - - --- registers ------------------------------------------------------------------- - --- @spRel@ gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. @fpRel@, where --- applicable, is the same but for the frame pointer. - - -spRel :: DynFlags - -> Int -- ^ desired stack offset in bytes, positive or negative - -> AddrMode -spRel dflags n - | target32Bit (targetPlatform dflags) - = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n) - | otherwise - = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n) - --- The register numbers must fit into 32 bits on x86, so that we can --- use a Word32 to represent the set of free registers in the register --- allocator. - - - -firstxmm :: RegNo -firstxmm = 16 - --- on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available -lastxmm :: Platform -> RegNo -lastxmm platform - | target32Bit platform = firstxmm + 7 -- xmm0 - xmmm7 - | otherwise = firstxmm + 15 -- xmm0 -xmm15 - -lastint :: Platform -> RegNo -lastint platform - | target32Bit platform = 7 -- not %r8..%r15 - | otherwise = 15 - -intregnos :: Platform -> [RegNo] -intregnos platform = [0 .. lastint platform] - - - -xmmregnos :: Platform -> [RegNo] -xmmregnos platform = [firstxmm .. lastxmm platform] - -floatregnos :: Platform -> [RegNo] -floatregnos platform = xmmregnos platform - --- argRegs is the set of regs which are read for an n-argument call to C. --- For archs which pass all args on the stack (x86), is empty. --- Sparc passes up to the first 6 args in regs. -argRegs :: RegNo -> [Reg] -argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" - --- | The complete set of machine registers. -allMachRegNos :: Platform -> [RegNo] -allMachRegNos platform = intregnos platform ++ floatregnos platform - --- | Take the class of a register. -{-# INLINE classOfRealReg #-} -classOfRealReg :: Platform -> RealReg -> RegClass --- On x86, we might want to have an 8-bit RegClass, which would --- contain just regs 1-4 (the others don't have 8-bit versions). --- However, we can get away without this at the moment because the --- only allocatable integer regs are also 8-bit compatible (1, 3, 4). -classOfRealReg platform reg - = case reg of - RealRegSingle i - | i <= lastint platform -> RcInteger - | i <= lastxmm platform -> RcDouble - | otherwise -> panic "X86.Reg.classOfRealReg registerSingle too high" - _ -> panic "X86.Regs.classOfRealReg: RegPairs on this arch" - --- | Get the name of the register with this number. --- NOTE: fixme, we dont track which "way" the XMM registers are used -showReg :: Platform -> RegNo -> String -showReg platform n - | n >= firstxmm && n <= lastxmm platform = "%xmm" ++ show (n-firstxmm) - | n >= 8 && n < firstxmm = "%r" ++ show n - | otherwise = regNames platform A.! n - -regNames :: Platform -> A.Array Int String -regNames platform - = if target32Bit platform - then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"] - else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"] - - - --- machine specific ------------------------------------------------------------ - - -{- -Intel x86 architecture: -- All registers except 7 (esp) are available for use. -- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). -- Registers 0-7 have 16-bit counterparts (ax, bx etc.) -- Registers 0-3 have 8 bit counterparts (ah, bh etc.) - -The fp registers are all Double registers; we don't have any RcFloat class -regs. @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should -never generate them. - -TODO: cleanup modelling float vs double registers and how they are the same class. --} - - -eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg - -eax = regSingle 0 -ebx = regSingle 1 -ecx = regSingle 2 -edx = regSingle 3 -esi = regSingle 4 -edi = regSingle 5 -ebp = regSingle 6 -esp = regSingle 7 - - - - -{- -AMD x86_64 architecture: -- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values: - - 8 16 32 64 - --------------------- - al ax eax rax - bl bx ebx rbx - cl cx ecx rcx - dl dx edx rdx - sil si esi rsi - dil si edi rdi - bpl bp ebp rbp - spl sp esp rsp - r10b r10w r10d r10 - r11b r11w r11d r11 - r12b r12w r12d r12 - r13b r13w r13d r13 - r14b r14w r14d r14 - r15b r15w r15d r15 --} - -rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, - r8, r9, r10, r11, r12, r13, r14, r15, - xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, - xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg - -rax = regSingle 0 -rbx = regSingle 1 -rcx = regSingle 2 -rdx = regSingle 3 -rsi = regSingle 4 -rdi = regSingle 5 -rbp = regSingle 6 -rsp = regSingle 7 -r8 = regSingle 8 -r9 = regSingle 9 -r10 = regSingle 10 -r11 = regSingle 11 -r12 = regSingle 12 -r13 = regSingle 13 -r14 = regSingle 14 -r15 = regSingle 15 -xmm0 = regSingle 16 -xmm1 = regSingle 17 -xmm2 = regSingle 18 -xmm3 = regSingle 19 -xmm4 = regSingle 20 -xmm5 = regSingle 21 -xmm6 = regSingle 22 -xmm7 = regSingle 23 -xmm8 = regSingle 24 -xmm9 = regSingle 25 -xmm10 = regSingle 26 -xmm11 = regSingle 27 -xmm12 = regSingle 28 -xmm13 = regSingle 29 -xmm14 = regSingle 30 -xmm15 = regSingle 31 - -ripRel :: Displacement -> AddrMode -ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm - - - -- so we can re-use some x86 code: -{- -eax = rax -ebx = rbx -ecx = rcx -edx = rdx -esi = rsi -edi = rdi -ebp = rbp -esp = rsp --} - -xmm :: RegNo -> Reg -xmm n = regSingle (firstxmm+n) - - - - --- | these are the regs which we cannot assume stay alive over a C call. -callClobberedRegs :: Platform -> [Reg] --- caller-saves registers -callClobberedRegs platform - | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform) - | platformOS platform == OSMinGW32 - = [rax,rcx,rdx,r8,r9,r10,r11] - -- Only xmm0-5 are caller-saves registers on 64bit windows. - -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage ) - -- For details check the Win64 ABI. - ++ map xmm [0 .. 5] - | otherwise - -- all xmm regs are caller-saves - -- caller-saves registers - = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] - ++ map regSingle (floatregnos platform) - -allArgRegs :: Platform -> [(Reg, Reg)] -allArgRegs platform - | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9] - (map regSingle [firstxmm ..]) - | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch" - -allIntArgRegs :: Platform -> [Reg] -allIntArgRegs platform - | (platformOS platform == OSMinGW32) || target32Bit platform - = panic "X86.Regs.allIntArgRegs: not defined for this platform" - | otherwise = [rdi,rsi,rdx,rcx,r8,r9] - - --- | on 64bit platforms we pass the first 8 float/double arguments --- in the xmm registers. -allFPArgRegs :: Platform -> [Reg] -allFPArgRegs platform - | platformOS platform == OSMinGW32 - = panic "X86.Regs.allFPArgRegs: not defined for this platform" - | otherwise = map regSingle [firstxmm .. firstxmm + 7 ] - - --- Machine registers which might be clobbered by instructions that --- generate results into fixed registers, or need arguments in a fixed --- register. -instrClobberedRegs :: Platform -> [Reg] -instrClobberedRegs platform - | target32Bit platform = [ eax, ecx, edx ] - | otherwise = [ rax, rcx, rdx ] - --- - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: Platform -> [RealReg] -allocatableRegs platform - = let isFree i = freeReg platform i - in map RealRegSingle $ filter isFree (allMachRegNos platform) - diff --git a/parser/ApiAnnotation.hs b/parser/ApiAnnotation.hs deleted file mode 100644 --- a/parser/ApiAnnotation.hs +++ /dev/null @@ -1,364 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module ApiAnnotation ( - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments,getAndRemoveAnnotationComments, - ApiAnns, - ApiAnnKey, - AnnKeywordId(..), - AnnotationComment(..), - IsUnicodeSyntax(..), - unicodeAnn, - HasE(..), - LRdrName -- Exists for haddocks only - ) where - -import GhcPrelude - -import RdrName -import Outputable -import SrcLoc -import qualified Data.Map as Map -import Data.Data - - -{- -Note [Api annotations] -~~~~~~~~~~~~~~~~~~~~~~ -Given a parse tree of a Haskell module, how can we reconstruct -the original Haskell source code, retaining all whitespace and -source code comments? We need to track the locations of all -elements from the original source: this includes keywords such as -'let' / 'in' / 'do' etc as well as punctuation such as commas and -braces, and also comments. We collectively refer to this -metadata as the "API annotations". - -Rather than annotate the resulting parse tree with these locations -directly (this would be a major change to some fairly core data -structures in GHC), we instead capture locations for these elements in a -structure separate from the parse tree, and returned in the -pm_annotations field of the ParsedModule type. - -The full ApiAnns type is - -> type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] -- non-comments -> , Map.Map SrcSpan [Located AnnotationComment]) -- comments - -NON-COMMENT ELEMENTS - -Intuitively, every AST element directly contains a bag of keywords -(keywords can show up more than once in a node: a semicolon i.e. newline -can show up multiple times before the next AST element), each of which -needs to be associated with its location in the original source code. - -Consequently, the structure that records non-comment elements is logically -a two level map, from the SrcSpan of the AST element containing it, to -a map from keywords ('AnnKeyWord') to all locations of the keyword directly -in the AST element: - -> type ApiAnnKey = (SrcSpan,AnnKeywordId) -> -> Map.Map ApiAnnKey [SrcSpan] - -So - -> let x = 1 in 2 *x - -would result in the AST element - - L span (HsLet (binds for x = 1) (2 * x)) - -and the annotations - - (span,AnnLet) having the location of the 'let' keyword - (span,AnnEqual) having the location of the '=' sign - (span,AnnIn) having the location of the 'in' keyword - -For any given element in the AST, there is only a set number of -keywords that are applicable for it (e.g., you'll never see an -'import' keyword associated with a let-binding.) The set of allowed -keywords is documented in a comment associated with the constructor -of a given AST element, although the ground truth is in Parser -and RdrHsSyn (which actually add the annotations; see #13012). - -COMMENT ELEMENTS - -Every comment is associated with a *located* AnnotationComment. -We associate comments with the lowest (most specific) AST element -enclosing them: - -> Map.Map SrcSpan [Located AnnotationComment] - -PARSER STATE - -There are three fields in PState (the parser state) which play a role -with annotations. - -> annotations :: [(ApiAnnKey,[SrcSpan])], -> comment_q :: [Located AnnotationComment], -> annotations_comments :: [(SrcSpan,[Located AnnotationComment])] - -The 'annotations' and 'annotations_comments' fields are simple: they simply -accumulate annotations that will end up in 'ApiAnns' at the end -(after they are passed to Map.fromList). - -The 'comment_q' field captures comments as they are seen in the token stream, -so that when they are ready to be allocated via the parser they are -available (at the time we lex a comment, we don't know what the enclosing -AST node of it is, so we can't associate it with a SrcSpan in -annotations_comments). - -PARSER EMISSION OF ANNOTATIONS - -The parser interacts with the lexer using the function - -> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () - -which takes the AST element SrcSpan, the annotation keyword and the -target SrcSpan. - -This adds the annotation to the `annotations` field of `PState` and -transfers any comments in `comment_q` WHICH ARE ENCLOSED by -the SrcSpan of this element to the `annotations_comments` -field. (Comments which are outside of this annotation are deferred -until later. 'allocateComments' in 'Lexer' is responsible for -making sure we only attach comments that actually fit in the 'SrcSpan'.) - -The wiki page describing this feature is -https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations - --} --- --------------------------------------------------------------------- - --- If you update this, update the Note [Api annotations] above -type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] - , Map.Map SrcSpan [Located AnnotationComment]) - --- If you update this, update the Note [Api annotations] above -type ApiAnnKey = (SrcSpan,AnnKeywordId) - - --- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' --- of the annotated AST element, and the known type of the annotation. -getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan] -getAnnotation (anns,_) span ann - = case Map.lookup (span,ann) anns of - Nothing -> [] - Just ss -> ss - --- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' --- of the annotated AST element, and the known type of the annotation. --- The list is removed from the annotations. -getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId - -> ([SrcSpan],ApiAnns) -getAndRemoveAnnotation (anns,cs) span ann - = case Map.lookup (span,ann) anns of - Nothing -> ([],(anns,cs)) - Just ss -> (ss,(Map.delete (span,ann) anns,cs)) - --- |Retrieve the comments allocated to the current 'SrcSpan' --- --- Note: A given 'SrcSpan' may appear in multiple AST elements, --- beware of duplicates -getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment] -getAnnotationComments (_,anns) span = - case Map.lookup span anns of - Just cs -> cs - Nothing -> [] - --- |Retrieve the comments allocated to the current 'SrcSpan', and --- remove them from the annotations -getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan - -> ([Located AnnotationComment],ApiAnns) -getAndRemoveAnnotationComments (anns,canns) span = - case Map.lookup span canns of - Just cs -> (cs,(anns,Map.delete span canns)) - Nothing -> ([],(anns,canns)) - --- -------------------------------------------------------------------- - --- | API Annotations exist so that tools can perform source to source --- conversions of Haskell code. They are used to keep track of the --- various syntactic keywords that are not captured in the existing --- AST. --- --- The annotations, together with original source comments are made --- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@. --- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in --- @'DynFlags.DynFlags'@ before parsing. --- --- The wiki page describing this feature is --- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations --- --- Note: in general the names of these are taken from the --- corresponding token, unless otherwise noted --- See note [Api annotations] above for details of the usage -data AnnKeywordId - = AnnAnyclass - | AnnAs - | AnnAt - | AnnBang -- ^ '!' - | AnnBackquote -- ^ '`' - | AnnBy - | AnnCase -- ^ case or lambda case - | AnnClass - | AnnClose -- ^ '\#)' or '\#-}' etc - | AnnCloseB -- ^ '|)' - | AnnCloseBU -- ^ '|)', unicode variant - | AnnCloseC -- ^ '}' - | AnnCloseQ -- ^ '|]' - | AnnCloseQU -- ^ '|]', unicode variant - | AnnCloseP -- ^ ')' - | AnnCloseS -- ^ ']' - | AnnColon - | AnnComma -- ^ as a list separator - | AnnCommaTuple -- ^ in a RdrName for a tuple - | AnnDarrow -- ^ '=>' - | AnnDarrowU -- ^ '=>', unicode variant - | AnnData - | AnnDcolon -- ^ '::' - | AnnDcolonU -- ^ '::', unicode variant - | AnnDefault - | AnnDeriving - | AnnDo - | AnnDot -- ^ '.' - | AnnDotdot -- ^ '..' - | AnnElse - | AnnEqual - | AnnExport - | AnnFamily - | AnnForall - | AnnForallU -- ^ Unicode variant - | AnnForeign - | AnnFunId -- ^ for function name in matches where there are - -- multiple equations for the function. - | AnnGroup - | AnnHeader -- ^ for CType - | AnnHiding - | AnnIf - | AnnImport - | AnnIn - | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' - | AnnInstance - | AnnLam - | AnnLarrow -- ^ '<-' - | AnnLarrowU -- ^ '<-', unicode variant - | AnnLet - | AnnMdo - | AnnMinus -- ^ '-' - | AnnModule - | AnnNewtype - | AnnName -- ^ where a name loses its location in the AST, this carries it - | AnnOf - | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc - | AnnOpenB -- ^ '(|' - | AnnOpenBU -- ^ '(|', unicode variant - | AnnOpenC -- ^ '{' - | AnnOpenE -- ^ '[e|' or '[e||' - | AnnOpenEQ -- ^ '[|' - | AnnOpenEQU -- ^ '[|', unicode variant - | AnnOpenP -- ^ '(' - | AnnOpenPE -- ^ '$(' - | AnnOpenPTE -- ^ '$$(' - | AnnOpenS -- ^ '[' - | AnnPackageName - | AnnPattern - | AnnProc - | AnnQualified - | AnnRarrow -- ^ '->' - | AnnRarrowU -- ^ '->', unicode variant - | AnnRec - | AnnRole - | AnnSafe - | AnnSemi -- ^ ';' - | AnnSimpleQuote -- ^ ''' - | AnnSignature - | AnnStatic -- ^ 'static' - | AnnStock - | AnnThen - | AnnThIdSplice -- ^ '$' - | AnnThIdTySplice -- ^ '$$' - | AnnThTyQuote -- ^ double ''' - | AnnTilde -- ^ '~' - | AnnType - | AnnUnit -- ^ '()' for types - | AnnUsing - | AnnVal -- ^ e.g. INTEGER - | AnnValStr -- ^ String value, will need quotes when output - | AnnVbar -- ^ '|' - | AnnVia -- ^ 'via' - | AnnWhere - | Annlarrowtail -- ^ '-<' - | AnnlarrowtailU -- ^ '-<', unicode variant - | Annrarrowtail -- ^ '->' - | AnnrarrowtailU -- ^ '->', unicode variant - | AnnLarrowtail -- ^ '-<<' - | AnnLarrowtailU -- ^ '-<<', unicode variant - | AnnRarrowtail -- ^ '>>-' - | AnnRarrowtailU -- ^ '>>-', unicode variant - | AnnEofPos - deriving (Eq, Ord, Data, Show) - -instance Outputable AnnKeywordId where - ppr x = text (show x) - --- --------------------------------------------------------------------- - -data AnnotationComment = - -- Documentation annotations - AnnDocCommentNext String -- ^ something beginning '-- |' - | AnnDocCommentPrev String -- ^ something beginning '-- ^' - | AnnDocCommentNamed String -- ^ something beginning '-- $' - | AnnDocSection Int String -- ^ a section heading - | AnnDocOptions String -- ^ doc options (prune, ignore-exports, etc) - | AnnLineComment String -- ^ comment starting by "--" - | AnnBlockComment String -- ^ comment in {- -} - deriving (Eq, Ord, Data, Show) --- Note: these are based on the Token versions, but the Token type is --- defined in Lexer.x and bringing it in here would create a loop - -instance Outputable AnnotationComment where - ppr x = text (show x) - --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma', --- 'ApiAnnotation.AnnRarrow' --- 'ApiAnnotation.AnnTilde' --- - May have 'ApiAnnotation.AnnComma' when in a list -type LRdrName = Located RdrName - - --- | Certain tokens can have alternate representations when unicode syntax is --- enabled. This flag is attached to those tokens in the lexer so that the --- original source representation can be reproduced in the corresponding --- 'ApiAnnotation' -data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax - deriving (Eq, Ord, Data, Show) - --- | Convert a normal annotation into its unicode equivalent one -unicodeAnn :: AnnKeywordId -> AnnKeywordId -unicodeAnn AnnForall = AnnForallU -unicodeAnn AnnDcolon = AnnDcolonU -unicodeAnn AnnLarrow = AnnLarrowU -unicodeAnn AnnRarrow = AnnRarrowU -unicodeAnn AnnDarrow = AnnDarrowU -unicodeAnn Annlarrowtail = AnnlarrowtailU -unicodeAnn Annrarrowtail = AnnrarrowtailU -unicodeAnn AnnLarrowtail = AnnLarrowtailU -unicodeAnn AnnRarrowtail = AnnRarrowtailU -unicodeAnn AnnOpenB = AnnOpenBU -unicodeAnn AnnCloseB = AnnCloseBU -unicodeAnn AnnOpenEQ = AnnOpenEQU -unicodeAnn AnnCloseQ = AnnCloseQU -unicodeAnn ann = ann - - --- | Some template haskell tokens have two variants, one with an `e` the other --- not: --- --- > [| or [e| --- > [|| or [e|| --- --- This type indicates whether the 'e' is present or not. -data HasE = HasE | NoE - deriving (Eq, Ord, Data, Show) diff --git a/parser/Ctype.hs b/parser/Ctype.hs deleted file mode 100644 --- a/parser/Ctype.hs +++ /dev/null @@ -1,215 +0,0 @@ --- Character classification -{-# LANGUAGE CPP #-} -module Ctype - ( is_ident -- Char# -> Bool - , is_symbol -- Char# -> Bool - , is_any -- Char# -> Bool - , is_space -- Char# -> Bool - , is_lower -- Char# -> Bool - , is_upper -- Char# -> Bool - , is_digit -- Char# -> Bool - , is_alphanum -- Char# -> Bool - - , is_decdigit, is_hexdigit, is_octdigit, is_bindigit - , hexDigit, octDecDigit - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Data.Bits ( Bits((.&.),(.|.)) ) -import Data.Char ( ord, chr ) -import Data.Word -import Panic - --- Bit masks - -cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Word8 -cIdent = 1 -cSymbol = 2 -cAny = 4 -cSpace = 8 -cLower = 16 -cUpper = 32 -cDigit = 64 - --- | The predicates below look costly, but aren't, GHC+GCC do a great job --- at the big case below. - -{-# INLINABLE is_ctype #-} -is_ctype :: Word8 -> Char -> Bool -is_ctype mask c = (charType c .&. mask) /= 0 - -is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, - is_alphanum :: Char -> Bool -is_ident = is_ctype cIdent -is_symbol = is_ctype cSymbol -is_any = is_ctype cAny -is_space = is_ctype cSpace -is_lower = is_ctype cLower -is_upper = is_ctype cUpper -is_digit = is_ctype cDigit -is_alphanum = is_ctype (cLower+cUpper+cDigit) - --- Utils - -hexDigit :: Char -> Int -hexDigit c | is_decdigit c = ord c - ord '0' - | otherwise = ord (to_lower c) - ord 'a' + 10 - -octDecDigit :: Char -> Int -octDecDigit c = ord c - ord '0' - -is_decdigit :: Char -> Bool -is_decdigit c - = c >= '0' && c <= '9' - -is_hexdigit :: Char -> Bool -is_hexdigit c - = is_decdigit c - || (c >= 'a' && c <= 'f') - || (c >= 'A' && c <= 'F') - -is_octdigit :: Char -> Bool -is_octdigit c = c >= '0' && c <= '7' - -is_bindigit :: Char -> Bool -is_bindigit c = c == '0' || c == '1' - -to_lower :: Char -> Char -to_lower c - | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) - | otherwise = c - -charType :: Char -> Word8 -charType c = case c of - '\0' -> 0 -- \000 - '\1' -> 0 -- \001 - '\2' -> 0 -- \002 - '\3' -> 0 -- \003 - '\4' -> 0 -- \004 - '\5' -> 0 -- \005 - '\6' -> 0 -- \006 - '\7' -> 0 -- \007 - '\8' -> 0 -- \010 - '\9' -> cSpace -- \t (not allowed in strings, so !cAny) - '\10' -> cSpace -- \n (ditto) - '\11' -> cSpace -- \v (ditto) - '\12' -> cSpace -- \f (ditto) - '\13' -> cSpace -- ^M (ditto) - '\14' -> 0 -- \016 - '\15' -> 0 -- \017 - '\16' -> 0 -- \020 - '\17' -> 0 -- \021 - '\18' -> 0 -- \022 - '\19' -> 0 -- \023 - '\20' -> 0 -- \024 - '\21' -> 0 -- \025 - '\22' -> 0 -- \026 - '\23' -> 0 -- \027 - '\24' -> 0 -- \030 - '\25' -> 0 -- \031 - '\26' -> 0 -- \032 - '\27' -> 0 -- \033 - '\28' -> 0 -- \034 - '\29' -> 0 -- \035 - '\30' -> 0 -- \036 - '\31' -> 0 -- \037 - '\32' -> cAny .|. cSpace -- - '\33' -> cAny .|. cSymbol -- ! - '\34' -> cAny -- " - '\35' -> cAny .|. cSymbol -- # - '\36' -> cAny .|. cSymbol -- $ - '\37' -> cAny .|. cSymbol -- % - '\38' -> cAny .|. cSymbol -- & - '\39' -> cAny .|. cIdent -- ' - '\40' -> cAny -- ( - '\41' -> cAny -- ) - '\42' -> cAny .|. cSymbol -- * - '\43' -> cAny .|. cSymbol -- + - '\44' -> cAny -- , - '\45' -> cAny .|. cSymbol -- - - '\46' -> cAny .|. cSymbol -- . - '\47' -> cAny .|. cSymbol -- / - '\48' -> cAny .|. cIdent .|. cDigit -- 0 - '\49' -> cAny .|. cIdent .|. cDigit -- 1 - '\50' -> cAny .|. cIdent .|. cDigit -- 2 - '\51' -> cAny .|. cIdent .|. cDigit -- 3 - '\52' -> cAny .|. cIdent .|. cDigit -- 4 - '\53' -> cAny .|. cIdent .|. cDigit -- 5 - '\54' -> cAny .|. cIdent .|. cDigit -- 6 - '\55' -> cAny .|. cIdent .|. cDigit -- 7 - '\56' -> cAny .|. cIdent .|. cDigit -- 8 - '\57' -> cAny .|. cIdent .|. cDigit -- 9 - '\58' -> cAny .|. cSymbol -- : - '\59' -> cAny -- ; - '\60' -> cAny .|. cSymbol -- < - '\61' -> cAny .|. cSymbol -- = - '\62' -> cAny .|. cSymbol -- > - '\63' -> cAny .|. cSymbol -- ? - '\64' -> cAny .|. cSymbol -- @ - '\65' -> cAny .|. cIdent .|. cUpper -- A - '\66' -> cAny .|. cIdent .|. cUpper -- B - '\67' -> cAny .|. cIdent .|. cUpper -- C - '\68' -> cAny .|. cIdent .|. cUpper -- D - '\69' -> cAny .|. cIdent .|. cUpper -- E - '\70' -> cAny .|. cIdent .|. cUpper -- F - '\71' -> cAny .|. cIdent .|. cUpper -- G - '\72' -> cAny .|. cIdent .|. cUpper -- H - '\73' -> cAny .|. cIdent .|. cUpper -- I - '\74' -> cAny .|. cIdent .|. cUpper -- J - '\75' -> cAny .|. cIdent .|. cUpper -- K - '\76' -> cAny .|. cIdent .|. cUpper -- L - '\77' -> cAny .|. cIdent .|. cUpper -- M - '\78' -> cAny .|. cIdent .|. cUpper -- N - '\79' -> cAny .|. cIdent .|. cUpper -- O - '\80' -> cAny .|. cIdent .|. cUpper -- P - '\81' -> cAny .|. cIdent .|. cUpper -- Q - '\82' -> cAny .|. cIdent .|. cUpper -- R - '\83' -> cAny .|. cIdent .|. cUpper -- S - '\84' -> cAny .|. cIdent .|. cUpper -- T - '\85' -> cAny .|. cIdent .|. cUpper -- U - '\86' -> cAny .|. cIdent .|. cUpper -- V - '\87' -> cAny .|. cIdent .|. cUpper -- W - '\88' -> cAny .|. cIdent .|. cUpper -- X - '\89' -> cAny .|. cIdent .|. cUpper -- Y - '\90' -> cAny .|. cIdent .|. cUpper -- Z - '\91' -> cAny -- [ - '\92' -> cAny .|. cSymbol -- backslash - '\93' -> cAny -- ] - '\94' -> cAny .|. cSymbol -- ^ - '\95' -> cAny .|. cIdent .|. cLower -- _ - '\96' -> cAny -- ` - '\97' -> cAny .|. cIdent .|. cLower -- a - '\98' -> cAny .|. cIdent .|. cLower -- b - '\99' -> cAny .|. cIdent .|. cLower -- c - '\100' -> cAny .|. cIdent .|. cLower -- d - '\101' -> cAny .|. cIdent .|. cLower -- e - '\102' -> cAny .|. cIdent .|. cLower -- f - '\103' -> cAny .|. cIdent .|. cLower -- g - '\104' -> cAny .|. cIdent .|. cLower -- h - '\105' -> cAny .|. cIdent .|. cLower -- i - '\106' -> cAny .|. cIdent .|. cLower -- j - '\107' -> cAny .|. cIdent .|. cLower -- k - '\108' -> cAny .|. cIdent .|. cLower -- l - '\109' -> cAny .|. cIdent .|. cLower -- m - '\110' -> cAny .|. cIdent .|. cLower -- n - '\111' -> cAny .|. cIdent .|. cLower -- o - '\112' -> cAny .|. cIdent .|. cLower -- p - '\113' -> cAny .|. cIdent .|. cLower -- q - '\114' -> cAny .|. cIdent .|. cLower -- r - '\115' -> cAny .|. cIdent .|. cLower -- s - '\116' -> cAny .|. cIdent .|. cLower -- t - '\117' -> cAny .|. cIdent .|. cLower -- u - '\118' -> cAny .|. cIdent .|. cLower -- v - '\119' -> cAny .|. cIdent .|. cLower -- w - '\120' -> cAny .|. cIdent .|. cLower -- x - '\121' -> cAny .|. cIdent .|. cLower -- y - '\122' -> cAny .|. cIdent .|. cLower -- z - '\123' -> cAny -- { - '\124' -> cAny .|. cSymbol -- | - '\125' -> cAny -- } - '\126' -> cAny .|. cSymbol -- ~ - '\127' -> 0 -- \177 - _ -> panic ("charType: " ++ show c) diff --git a/parser/HaddockUtils.hs b/parser/HaddockUtils.hs deleted file mode 100644 --- a/parser/HaddockUtils.hs +++ /dev/null @@ -1,34 +0,0 @@ - -module HaddockUtils where - -import GhcPrelude - -import GHC.Hs -import SrcLoc - -import Control.Monad - --- ----------------------------------------------------------------------------- --- Adding documentation to record fields (used in parsing). - -addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a -addFieldDoc (L l fld) doc - = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) - -addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] -addFieldDocs [] _ = [] -addFieldDocs (x:xs) doc = addFieldDoc x doc : xs - - -addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a -addConDoc decl Nothing = decl -addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) - -addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] -addConDocs [] _ = [] -addConDocs [x] doc = [addConDoc x doc] -addConDocs (x:xs) doc = x : addConDocs xs doc - -addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] -addConDocFirst [] _ = [] -addConDocFirst (x:xs) doc = addConDoc x doc : xs diff --git a/parser/Lexer.x b/parser/Lexer.x deleted file mode 100644 --- a/parser/Lexer.x +++ /dev/null @@ -1,3160 +0,0 @@ ------------------------------------------------------------------------------ --- (c) The University of Glasgow, 2006 --- --- GHC's lexer for Haskell 2010 [1]. --- --- This is a combination of an Alex-generated lexer [2] from a regex --- definition, with some hand-coded bits. [3] --- --- Completely accurate information about token-spans within the source --- file is maintained. Every token has a start and end RealSrcLoc --- attached to it. --- --- References: --- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html --- [2] http://www.haskell.org/alex/ --- [3] https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/parser --- ------------------------------------------------------------------------------ - --- ToDo / known bugs: --- - parsing integers is a bit slow --- - readRational is a bit slow --- --- Known bugs, that were also in the previous version: --- - M... should be 3 tokens, not 1. --- - pragma-end should be only valid in a pragma - --- qualified operator NOTES. --- --- - If M.(+) is a single lexeme, then.. --- - Probably (+) should be a single lexeme too, for consistency. --- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. --- - But we have to rule out reserved operators, otherwise (..) becomes --- a different lexeme. --- - Should we therefore also rule out reserved operators in the qualified --- form? This is quite difficult to achieve. We don't do it for --- qualified varids. - - --- ----------------------------------------------------------------------------- --- Alex "Haskell code fragment top" - -{ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -funbox-strict-fields #-} - -module Lexer ( - Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), - P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..), - appendWarning, - appendError, - allocateComments, - MonadP(..), - getRealSrcLoc, getPState, withThisPackage, - failLocMsgP, srcParseFail, - getErrorMessages, getMessages, - popContext, pushModuleContext, setLastToken, setSrcLoc, - activeContext, nextIsEOF, - getLexState, popLexState, pushLexState, - ExtBits(..), - xtest, - lexTokenStream, - AddAnn(..),mkParensApiAnn, - addAnnsAt, - commentToAnnotation - ) where - -import GhcPrelude - --- base -import Control.Monad -import Control.Monad.Fail as MonadFail -import Data.Bits -import Data.Char -import Data.List -import Data.Maybe -import Data.Word - -import EnumSet (EnumSet) -import qualified EnumSet - --- ghc-boot -import qualified GHC.LanguageExtensions as LangExt - --- bytestring -import Data.ByteString (ByteString) - --- containers -import Data.Map (Map) -import qualified Data.Map as Map - --- compiler/utils -import Bag -import Outputable -import StringBuffer -import FastString -import UniqFM -import Util ( readRational, readHexRational ) - --- compiler/main -import ErrUtils -import DynFlags - --- compiler/basicTypes -import SrcLoc -import Module -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), - IntegralLit(..), FractionalLit(..), - SourceText(..) ) - --- compiler/parser -import Ctype - -import ApiAnnotation -} - --- ----------------------------------------------------------------------------- --- Alex "Character set macros" - --- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs --- Any changes here should likely be reflected there. -$unispace = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex]. -$nl = [\n\r\f] -$whitechar = [$nl\v\ $unispace] -$white_no_nl = $whitechar # \n -- TODO #8424 -$tab = \t - -$ascdigit = 0-9 -$unidigit = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex]. -$decdigit = $ascdigit -- for now, should really be $digit (ToDo) -$digit = [$ascdigit $unidigit] - -$special = [\(\)\,\;\[\]\`\{\}] -$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] -$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex]. -$symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] - -$unilarge = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex]. -$asclarge = [A-Z] -$large = [$asclarge $unilarge] - -$unismall = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex]. -$ascsmall = [a-z] -$small = [$ascsmall $unismall \_] - -$unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex]. -$graphic = [$small $large $symbol $digit $special $unigraphic \"\'] - -$binit = 0-1 -$octit = 0-7 -$hexit = [$decdigit A-F a-f] - -$uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex]. -$idchar = [$small $large $digit $uniidchar \'] - -$pragmachar = [$small $large $digit] - -$docsym = [\| \^ \* \$] - - --- ----------------------------------------------------------------------------- --- Alex "Regular expression macros" - -@varid = $small $idchar* -- variable identifiers -@conid = $large $idchar* -- constructor identifiers - -@varsym = ($symbol # \:) $symbol* -- variable (operator) symbol -@consym = \: $symbol* -- constructor (operator) symbol - --- See Note [Lexing NumericUnderscores extension] and #14473 -@numspc = _* -- numeric spacer (#14473) -@decimal = $decdigit(@numspc $decdigit)* -@binary = $binit(@numspc $binit)* -@octal = $octit(@numspc $octit)* -@hexadecimal = $hexit(@numspc $hexit)* -@exponent = @numspc [eE] [\-\+]? @decimal -@bin_exponent = @numspc [pP] [\-\+]? @decimal - -@qual = (@conid \.)+ -@qvarid = @qual @varid -@qconid = @qual @conid -@qvarsym = @qual @varsym -@qconsym = @qual @consym - -@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent -@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent - --- normal signed numerical literals can only be explicitly negative, --- not explicitly positive (contrast @exponent) -@negative = \- -@signed = @negative ? - - --- ----------------------------------------------------------------------------- --- Alex "Identifier" - -haskell :- - - --- ----------------------------------------------------------------------------- --- Alex "Rules" - --- everywhere: skip whitespace -$white_no_nl+ ; -$tab { warnTab } - --- Everywhere: deal with nested comments. We explicitly rule out --- pragmas, "{-#", so that we don't accidentally treat them as comments. --- (this can happen even though pragmas will normally take precedence due to --- longest-match, because pragmas aren't valid in every state, but comments --- are). We also rule out nested Haddock comments, if the -haddock flag is --- set. - -"{-" / { isNormalComment } { nested_comment lexToken } - --- Single-line comments are a bit tricky. Haskell 98 says that two or --- more dashes followed by a symbol should be parsed as a varsym, so we --- have to exclude those. - --- Since Haddock comments aren't valid in every state, we need to rule them --- out here. - --- The following two rules match comments that begin with two dashes, but --- continue with a different character. The rules test that this character --- is not a symbol (in which case we'd have a varsym), and that it's not a --- space followed by a Haddock comment symbol (docsym) (in which case we'd --- have a Haddock comment). The rules then munch the rest of the line. - -"-- " ~$docsym .* { lineCommentToken } -"--" [^$symbol \ ] .* { lineCommentToken } - --- Next, match Haddock comments if no -haddock flag - -"-- " $docsym .* / { alexNotPred (ifExtension HaddockBit) } { lineCommentToken } - --- Now, when we've matched comments that begin with 2 dashes and continue --- with a different character, we need to match comments that begin with three --- or more dashes (which clearly can't be Haddock comments). We only need to --- make sure that the first non-dash character isn't a symbol, and munch the --- rest of the line. - -"---"\-* ~$symbol .* { lineCommentToken } - --- Since the previous rules all match dashes followed by at least one --- character, we also need to match a whole line filled with just dashes. - -"--"\-* / { atEOL } { lineCommentToken } - --- We need this rule since none of the other single line comment rules --- actually match this case. - -"-- " / { atEOL } { lineCommentToken } - --- 'bol' state: beginning of a line. Slurp up all the whitespace (including --- blank lines) until we find a non-whitespace character, then do layout --- processing. --- --- One slight wibble here: what if the line begins with {-#? In --- theory, we have to lex the pragma to see if it's one we recognise, --- and if it is, then we backtrack and do_bol, otherwise we treat it --- as a nested comment. We don't bother with this: if the line begins --- with {-#, then we'll assume it's a pragma we know about and go for do_bol. - { - \n ; - ^\# line { begin line_prag1 } - ^\# / { followedByDigit } { begin line_prag1 } - ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently - ^\# \! .* \n ; -- #!, for scripts - () { do_bol } -} - --- after a layout keyword (let, where, do, of), we begin a new layout --- context if the curly brace is missing. --- Careful! This stuff is quite delicate. - { - \{ / { notFollowedBy '-' } { hopefully_open_brace } - -- we might encounter {-# here, but {- has been handled already - \n ; - ^\# (line)? { begin line_prag1 } -} - --- after an 'if', a vertical bar starts a layout context for MultiWayIf - { - \| / { notFollowedBySymbol } { new_layout_context True dontGenerateSemic ITvbar } - () { pop } -} - --- do is treated in a subtly different way, see new_layout_context - () { new_layout_context True generateSemic ITvocurly } - () { new_layout_context False generateSemic ITvocurly } - --- after a new layout context which was found to be to the left of the --- previous context, we have generated a '{' token, and we now need to --- generate a matching '}' token. - () { do_layout_left } - -<0,option_prags> \n { begin bol } - -"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags } - { dispatch_pragmas linePrags } - --- single-line line pragmas, of the form --- # "" \n - { - @decimal $white_no_nl+ \" [$graphic \ ]* \" { setLineAndFile line_prag1a } - () { failLinePrag1 } -} - .* { popLinePrag1 } - --- Haskell-style line pragmas, of the form --- {-# LINE "" #-} - { - @decimal $white_no_nl+ \" [$graphic \ ]* \" { setLineAndFile line_prag2a } -} - "#-}"|"-}" { pop } - -- NOTE: accept -} at the end of a LINE pragma, for compatibility - -- with older versions of GHC which generated these. - --- Haskell-style column pragmas, of the form --- {-# COLUMN #-} - @decimal $whitechar* "#-}" { setColumn } - -<0,option_prags> { - "{-#" $whitechar* $pragmachar+ - $whitechar+ $pragmachar+ / { known_pragma twoWordPrags } - { dispatch_pragmas twoWordPrags } - - "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags } - { dispatch_pragmas oneWordPrags } - - -- We ignore all these pragmas, but don't generate a warning for them - "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags } - { dispatch_pragmas ignoredPrags } - - -- ToDo: should only be valid inside a pragma: - "#-}" { endPrag } -} - - { - "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } - { dispatch_pragmas fileHeaderPrags } -} - -<0> { - -- In the "0" mode we ignore these pragmas - "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } - { nested_comment lexToken } -} - -<0,option_prags> { - "{-#" { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") - (nested_comment lexToken) } -} - --- '0' state: ordinary lexemes - --- Haddock comments - -<0,option_prags> { - "-- " $docsym / { ifExtension HaddockBit } { multiline_doc_comment } - "{-" \ ? $docsym / { ifExtension HaddockBit } { nested_doc_comment } -} - --- "special" symbols - -<0> { - "[|" / { ifExtension ThQuotesBit } { token (ITopenExpQuote NoE NormalSyntax) } - "[||" / { ifExtension ThQuotesBit } { token (ITopenTExpQuote NoE) } - "[e|" / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) } - "[e||" / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) } - "[p|" / { ifExtension ThQuotesBit } { token ITopenPatQuote } - "[d|" / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote } - "[t|" / { ifExtension ThQuotesBit } { token ITopenTypQuote } - "|]" / { ifExtension ThQuotesBit } { token (ITcloseQuote NormalSyntax) } - "||]" / { ifExtension ThQuotesBit } { token ITcloseTExpQuote } - \$ @varid / { ifExtension ThBit } { skip_one_varid ITidEscape } - "$$" @varid / { ifExtension ThBit } { skip_two_varid ITidTyEscape } - "$(" / { ifExtension ThBit } { token ITparenEscape } - "$$(" / { ifExtension ThBit } { token ITparenTyEscape } - - "[" @varid "|" / { ifExtension QqBit } { lex_quasiquote_tok } - - -- qualified quasi-quote (#5555) - "[" @qvarid "|" / { ifExtension QqBit } { lex_qquasiquote_tok } - - $unigraphic -- ⟦ - / { ifCurrentChar '⟦' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit } - { token (ITopenExpQuote NoE UnicodeSyntax) } - $unigraphic -- ⟧ - / { ifCurrentChar '⟧' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit } - { token (ITcloseQuote UnicodeSyntax) } -} - - -- See Note [Lexing type applications] -<0> { - [^ $idchar \) ] ^ - "@" - / { ifExtension TypeApplicationsBit `alexAndPred` notFollowedBySymbol } - { token ITtypeApp } -} - -<0> { - "(|" - / { ifExtension ArrowsBit `alexAndPred` - notFollowedBySymbol } - { special (IToparenbar NormalSyntax) } - "|)" - / { ifExtension ArrowsBit } - { special (ITcparenbar NormalSyntax) } - - $unigraphic -- ⦇ - / { ifCurrentChar '⦇' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit } - { special (IToparenbar UnicodeSyntax) } - $unigraphic -- ⦈ - / { ifCurrentChar '⦈' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit } - { special (ITcparenbar UnicodeSyntax) } -} - -<0> { - \? @varid / { ifExtension IpBit } { skip_one_varid ITdupipvarid } -} - -<0> { - "#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid } -} - -<0> { - "(#" / { ifExtension UnboxedTuplesBit `alexOrPred` - ifExtension UnboxedSumsBit } - { token IToubxparen } - "#)" / { ifExtension UnboxedTuplesBit `alexOrPred` - ifExtension UnboxedSumsBit } - { token ITcubxparen } -} - -<0,option_prags> { - \( { special IToparen } - \) { special ITcparen } - \[ { special ITobrack } - \] { special ITcbrack } - \, { special ITcomma } - \; { special ITsemi } - \` { special ITbackquote } - - \{ { open_brace } - \} { close_brace } -} - -<0,option_prags> { - @qvarid { idtoken qvarid } - @qconid { idtoken qconid } - @varid { varid } - @conid { idtoken conid } -} - -<0> { - @qvarid "#"+ / { ifExtension MagicHashBit } { idtoken qvarid } - @qconid "#"+ / { ifExtension MagicHashBit } { idtoken qconid } - @varid "#"+ / { ifExtension MagicHashBit } { varid } - @conid "#"+ / { ifExtension MagicHashBit } { idtoken conid } -} - --- ToDo: - move `var` and (sym) into lexical syntax? --- - remove backquote from $special? -<0> { - @qvarsym { idtoken qvarsym } - @qconsym { idtoken qconsym } - @varsym { varsym } - @consym { consym } -} - --- For the normal boxed literals we need to be careful --- when trying to be close to Haskell98 - --- Note [Lexing NumericUnderscores extension] (#14473) --- --- NumericUnderscores extension allows underscores in numeric literals. --- Multiple underscores are represented with @numspc macro. --- To be simpler, we have only the definitions with underscores. --- And then we have a separate function (tok_integral and tok_frac) --- that validates the literals. --- If extensions are not enabled, check that there are no underscores. --- -<0> { - -- Normal integral literals (:: Num a => a, from Integer) - @decimal { tok_num positive 0 0 decimal } - 0[bB] @numspc @binary / { ifExtension BinaryLiteralsBit } { tok_num positive 2 2 binary } - 0[oO] @numspc @octal { tok_num positive 2 2 octal } - 0[xX] @numspc @hexadecimal { tok_num positive 2 2 hexadecimal } - @negative @decimal / { ifExtension NegativeLiteralsBit } { tok_num negative 1 1 decimal } - @negative 0[bB] @numspc @binary / { ifExtension NegativeLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_num negative 3 3 binary } - @negative 0[oO] @numspc @octal / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 octal } - @negative 0[xX] @numspc @hexadecimal / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 hexadecimal } - - -- Normal rational literals (:: Fractional a => a, from Rational) - @floating_point { tok_frac 0 tok_float } - @negative @floating_point / { ifExtension NegativeLiteralsBit } { tok_frac 0 tok_float } - 0[xX] @numspc @hex_floating_point / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float } - @negative 0[xX] @numspc @hex_floating_point - / { ifExtension HexFloatLiteralsBit `alexAndPred` - ifExtension NegativeLiteralsBit } { tok_frac 0 tok_hex_float } -} - -<0> { - -- Unboxed ints (:: Int#) and words (:: Word#) - -- It's simpler (and faster?) to give separate cases to the negatives, - -- especially considering octal/hexadecimal prefixes. - @decimal \# / { ifExtension MagicHashBit } { tok_primint positive 0 1 decimal } - 0[bB] @numspc @binary \# / { ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_primint positive 2 3 binary } - 0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 octal } - 0[xX] @numspc @hexadecimal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 hexadecimal } - @negative @decimal \# / { ifExtension MagicHashBit } { tok_primint negative 1 2 decimal } - @negative 0[bB] @numspc @binary \# / { ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_primint negative 3 4 binary } - @negative 0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint negative 3 4 octal } - @negative 0[xX] @numspc @hexadecimal \# - / { ifExtension MagicHashBit } { tok_primint negative 3 4 hexadecimal } - - @decimal \# \# / { ifExtension MagicHashBit } { tok_primword 0 2 decimal } - 0[bB] @numspc @binary \# \# / { ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_primword 2 4 binary } - 0[oO] @numspc @octal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 octal } - 0[xX] @numspc @hexadecimal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 hexadecimal } - - -- Unboxed floats and doubles (:: Float#, :: Double#) - -- prim_{float,double} work with signed literals - @signed @floating_point \# / { ifExtension MagicHashBit } { tok_frac 1 tok_primfloat } - @signed @floating_point \# \# / { ifExtension MagicHashBit } { tok_frac 2 tok_primdouble } -} - --- Strings and chars are lexed by hand-written code. The reason is --- that even if we recognise the string or char here in the regex --- lexer, we would still have to parse the string afterward in order --- to convert it to a String. -<0> { - \' { lex_char_tok } - \" { lex_string_tok } -} - --- Note [Lexing type applications] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The desired syntax for type applications is to prefix the type application --- with '@', like this: --- --- foo @Int @Bool baz bum --- --- This, of course, conflicts with as-patterns. The conflict arises because --- expressions and patterns use the same parser, and also because we want --- to allow type patterns within expression patterns. --- --- Disambiguation is accomplished by requiring *something* to appear between --- type application and the preceding token. This something must end with --- a character that cannot be the end of the variable bound in an as-pattern. --- Currently (June 2015), this means that the something cannot end with a --- $idchar or a close-paren. (The close-paren is necessary if the as-bound --- identifier is symbolic.) --- --- Note that looking for whitespace before the '@' is insufficient, because --- of this pathological case: --- --- foo {- hi -}@Int --- --- This design is predicated on the fact that as-patterns are generally --- whitespace-free, and also that this whole thing is opt-in, with the --- TypeApplications extension. - --- ----------------------------------------------------------------------------- --- Alex "Haskell code fragment bottom" - -{ - --- ----------------------------------------------------------------------------- --- The token type - -data Token - = ITas -- Haskell keywords - | ITcase - | ITclass - | ITdata - | ITdefault - | ITderiving - | ITdo - | ITelse - | IThiding - | ITforeign - | ITif - | ITimport - | ITin - | ITinfix - | ITinfixl - | ITinfixr - | ITinstance - | ITlet - | ITmodule - | ITnewtype - | ITof - | ITqualified - | ITthen - | ITtype - | ITwhere - - | ITforall IsUnicodeSyntax -- GHC extension keywords - | ITexport - | ITlabel - | ITdynamic - | ITsafe - | ITinterruptible - | ITunsafe - | ITstdcallconv - | ITccallconv - | ITcapiconv - | ITprimcallconv - | ITjavascriptcallconv - | ITmdo - | ITfamily - | ITrole - | ITgroup - | ITby - | ITusing - | ITpattern - | ITstatic - | ITstock - | ITanyclass - | ITvia - - -- Backpack tokens - | ITunit - | ITsignature - | ITdependency - | ITrequires - - -- Pragmas, see note [Pragma source text] in BasicTypes - | ITinline_prag SourceText InlineSpec RuleMatchInfo - | ITspec_prag SourceText -- SPECIALISE - | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) - | ITsource_prag SourceText - | ITrules_prag SourceText - | ITwarning_prag SourceText - | ITdeprecated_prag SourceText - | ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit' - | ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit' - | ITscc_prag SourceText - | ITgenerated_prag SourceText - | ITcore_prag SourceText -- hdaume: core annotations - | ITunpack_prag SourceText - | ITnounpack_prag SourceText - | ITann_prag SourceText - | ITcomplete_prag SourceText - | ITclose_prag - | IToptions_prag String - | ITinclude_prag String - | ITlanguage_prag - | ITminimal_prag SourceText - | IToverlappable_prag SourceText -- instance overlap mode - | IToverlapping_prag SourceText -- instance overlap mode - | IToverlaps_prag SourceText -- instance overlap mode - | ITincoherent_prag SourceText -- instance overlap mode - | ITctype SourceText - | ITcomment_line_prag -- See Note [Nested comment line pragmas] - - | ITdotdot -- reserved symbols - | ITcolon - | ITdcolon IsUnicodeSyntax - | ITequal - | ITlam - | ITlcase - | ITvbar - | ITlarrow IsUnicodeSyntax - | ITrarrow IsUnicodeSyntax - | ITat - | ITtilde - | ITdarrow IsUnicodeSyntax - | ITminus - | ITbang - | ITstar IsUnicodeSyntax - | ITdot - - | ITbiglam -- GHC-extension symbols - - | ITocurly -- special symbols - | ITccurly - | ITvocurly - | ITvccurly - | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParallelArrays - | ITcpabrack -- :], for parallel arrays with -XParallelArrays - | ITcbrack - | IToparen - | ITcparen - | IToubxparen - | ITcubxparen - | ITsemi - | ITcomma - | ITunderscore - | ITbackquote - | ITsimpleQuote -- ' - - | ITvarid FastString -- identifiers - | ITconid FastString - | ITvarsym FastString - | ITconsym FastString - | ITqvarid (FastString,FastString) - | ITqconid (FastString,FastString) - | ITqvarsym (FastString,FastString) - | ITqconsym (FastString,FastString) - - | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITlabelvarid FastString -- Overloaded label: #x - - | ITchar SourceText Char -- Note [Literal source text] in BasicTypes - | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes - | ITinteger IntegralLit -- Note [Literal source text] in BasicTypes - | ITrational FractionalLit - - | ITprimchar SourceText Char -- Note [Literal source text] in BasicTypes - | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes - | ITprimint SourceText Integer -- Note [Literal source text] in BasicTypes - | ITprimword SourceText Integer -- Note [Literal source text] in BasicTypes - | ITprimfloat FractionalLit - | ITprimdouble FractionalLit - - -- Template Haskell extension tokens - | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote IsUnicodeSyntax -- |] - | ITopenTExpQuote HasE -- [|| or [e|| - | ITcloseTExpQuote -- ||] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITidTyEscape FastString -- $$x - | ITparenTyEscape -- $$( - | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,RealSrcSpan) - -- ITquasiQuote(quoter, quote, loc) - -- represents a quasi-quote of the form - -- [quoter| quote |] - | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) - -- ITqQuasiQuote(Qual, quoter, quote, loc) - -- represents a qualified quasi-quote of the form - -- [Qual.quoter| quote |] - - -- Arrow notation extension - | ITproc - | ITrec - | IToparenbar IsUnicodeSyntax -- ^ @(|@ - | ITcparenbar IsUnicodeSyntax -- ^ @|)@ - | ITlarrowtail IsUnicodeSyntax -- ^ @-<@ - | ITrarrowtail IsUnicodeSyntax -- ^ @>-@ - | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ - | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ - - -- | Type application '@' (lexed differently than as-pattern '@', - -- due to checking for preceding whitespace) - | ITtypeApp - - - | ITunknown String -- ^ Used when the lexer can't make sense of it - | ITeof -- ^ end of file token - - -- Documentation annotations - | ITdocCommentNext String -- ^ something beginning @-- |@ - | ITdocCommentPrev String -- ^ something beginning @-- ^@ - | ITdocCommentNamed String -- ^ something beginning @-- $@ - | ITdocSection Int String -- ^ a section heading - | ITdocOptions String -- ^ doc options (prune, ignore-exports, etc) - | ITlineComment String -- ^ comment starting by "--" - | ITblockComment String -- ^ comment in {- -} - - deriving Show - -instance Outputable Token where - ppr x = text (show x) - - --- the bitmap provided as the third component indicates whether the --- corresponding extension keyword is valid under the extension options --- provided to the compiler; if the extension corresponding to *any* of the --- bits set in the bitmap is enabled, the keyword is valid (this setup --- facilitates using a keyword in two different extensions that can be --- activated independently) --- -reservedWordsFM :: UniqFM (Token, ExtsBitmap) -reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - - ( "forall", ITforall NormalSyntax, 0), - ( "mdo", ITmdo, xbit RecursiveDoBit), - -- See Note [Lexing type pseudo-keywords] - ( "family", ITfamily, 0 ), - ( "role", ITrole, 0 ), - ( "pattern", ITpattern, xbit PatternSynonymsBit), - ( "static", ITstatic, xbit StaticPointersBit ), - ( "stock", ITstock, 0 ), - ( "anyclass", ITanyclass, 0 ), - ( "via", ITvia, 0 ), - ( "group", ITgroup, xbit TransformComprehensionsBit), - ( "by", ITby, xbit TransformComprehensionsBit), - ( "using", ITusing, xbit TransformComprehensionsBit), - - ( "foreign", ITforeign, xbit FfiBit), - ( "export", ITexport, xbit FfiBit), - ( "label", ITlabel, xbit FfiBit), - ( "dynamic", ITdynamic, xbit FfiBit), - ( "safe", ITsafe, xbit FfiBit .|. - xbit SafeHaskellBit), - ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), - ( "unsafe", ITunsafe, xbit FfiBit), - ( "stdcall", ITstdcallconv, xbit FfiBit), - ( "ccall", ITccallconv, xbit FfiBit), - ( "capi", ITcapiconv, xbit CApiFfiBit), - ( "prim", ITprimcallconv, xbit FfiBit), - ( "javascript", ITjavascriptcallconv, xbit FfiBit), - - ( "unit", ITunit, 0 ), - ( "dependency", ITdependency, 0 ), - ( "signature", ITsignature, 0 ), - - ( "rec", ITrec, xbit ArrowsBit .|. - xbit RecursiveDoBit), - ( "proc", ITproc, xbit ArrowsBit) - ] - -{----------------------------------- -Note [Lexing type pseudo-keywords] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -One might think that we wish to treat 'family' and 'role' as regular old -varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. -But, there is no need to do so. These pseudo-keywords are not stolen syntax: -they are only used after the keyword 'type' at the top-level, where varids are -not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that -type families and role annotations are never declared without their extensions -on. In fact, by unconditionally lexing these pseudo-keywords as special, we -can get better error messages. - -Also, note that these are included in the `varid` production in the parser -- -a key detail to make all this work. --------------------------------------} - -reservedSymsFM :: UniqFM (Token, IsUnicodeSyntax, ExtsBitmap) -reservedSymsFM = listToUFM $ - map (\ (x,w,y,z) -> (mkFastString x,(w,y,z))) - [ ("..", ITdotdot, NormalSyntax, 0 ) - -- (:) is a reserved op, meaning only list cons - ,(":", ITcolon, NormalSyntax, 0 ) - ,("::", ITdcolon NormalSyntax, NormalSyntax, 0 ) - ,("=", ITequal, NormalSyntax, 0 ) - ,("\\", ITlam, NormalSyntax, 0 ) - ,("|", ITvbar, NormalSyntax, 0 ) - ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) - ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) - ,("@", ITat, NormalSyntax, 0 ) - ,("~", ITtilde, NormalSyntax, 0 ) - ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) - ,("-", ITminus, NormalSyntax, 0 ) - ,("!", ITbang, NormalSyntax, 0 ) - - ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) - - -- For 'forall a . t' - ,(".", ITdot, NormalSyntax, 0 ) - - ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - ,(">>-", ITRarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - - ,("∷", ITdcolon UnicodeSyntax, UnicodeSyntax, 0 ) - ,("⇒", ITdarrow UnicodeSyntax, UnicodeSyntax, 0 ) - ,("∀", ITforall UnicodeSyntax, UnicodeSyntax, 0 ) - ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) - ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) - - ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - ,("⤜", ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - - ,("★", ITstar UnicodeSyntax, UnicodeSyntax, xbit StarIsTypeBit) - - -- ToDo: ideally, → and ∷ should be "specials", so that they cannot - -- form part of a large operator. This would let us have a better - -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). - ] - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) - -special :: Token -> Action -special tok span _buf _len = return (L span tok) - -token, layout_token :: Token -> Action -token t span _buf _len = return (L span t) -layout_token t span _buf _len = pushLexState layout >> return (L span t) - -idtoken :: (StringBuffer -> Int -> Token) -> Action -idtoken f span buf len = return (L span $! (f buf len)) - -skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len - = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) - -skip_two_varid :: (FastString -> Token) -> Action -skip_two_varid f span buf len - = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) - -strtoken :: (String -> Token) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -begin :: Int -> Action -begin code _span _str _len = do pushLexState code; lexToken - -pop :: Action -pop _span _buf _len = do _ <- popLexState - lexToken --- See Note [Nested comment line pragmas] -failLinePrag1 :: Action -failLinePrag1 span _buf _len = do - b <- getBit InNestedCommentBit - if b then return (L span ITcomment_line_prag) - else lexError "lexical error in pragma" - --- See Note [Nested comment line pragmas] -popLinePrag1 :: Action -popLinePrag1 span _buf _len = do - b <- getBit InNestedCommentBit - if b then return (L span ITcomment_line_prag) else do - _ <- popLexState - lexToken - -hopefully_open_brace :: Action -hopefully_open_brace span buf len - = do relaxed <- getBit RelaxedLayoutBit - ctx <- getContext - (AI l _) <- getInput - let offset = srcLocCol l - isOK = relaxed || - case ctx of - Layout prev_off _ : _ -> prev_off < offset - _ -> True - if isOK then pop_and open_brace span buf len - else addFatalError (RealSrcSpan span) (text "Missing block") - -pop_and :: Action -> Action -pop_and act span buf len = do _ <- popLexState - act span buf len - -{-# INLINE nextCharIs #-} -nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIs buf p = not (atEnd buf) && p (currentChar buf) - -{-# INLINE nextCharIsNot #-} -nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIsNot buf p = not (nextCharIs buf p) - -notFollowedBy :: Char -> AlexAccPred ExtsBitmap -notFollowedBy char _ _ _ (AI _ buf) - = nextCharIsNot buf (== char) - -notFollowedBySymbol :: AlexAccPred ExtsBitmap -notFollowedBySymbol _ _ _ (AI _ buf) - = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") - -followedByDigit :: AlexAccPred ExtsBitmap -followedByDigit _ _ _ (AI _ buf) - = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) - -ifCurrentChar :: Char -> AlexAccPred ExtsBitmap -ifCurrentChar char _ (AI _ buf) _ _ - = nextCharIs buf (== char) - --- We must reject doc comments as being ordinary comments everywhere. --- In some cases the doc comment will be selected as the lexeme due to --- maximal munch, but not always, because the nested comment rule is --- valid in all states, but the doc-comment rules are only valid in --- the non-layout states. -isNormalComment :: AlexAccPred ExtsBitmap -isNormalComment bits _ _ (AI _ buf) - | HaddockBit `xtest` bits = notFollowedByDocOrPragma - | otherwise = nextCharIsNot buf (== '#') - where - notFollowedByDocOrPragma - = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) - -afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool -afterOptionalSpace buf p - = if nextCharIs buf (== ' ') - then p (snd (nextChar buf)) - else p buf - -atEOL :: AlexAccPred ExtsBitmap -atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' - -ifExtension :: ExtBits -> AlexAccPred ExtsBitmap -ifExtension extBits bits _ _ _ = extBits `xtest` bits - -alexNotPred p userState in1 len in2 - = not (p userState in1 len in2) - -alexOrPred p1 p2 userState in1 len in2 - = p1 userState in1 len in2 || p2 userState in1 len in2 - -multiline_doc_comment :: Action -multiline_doc_comment span buf _len = withLexedDocType (worker "") - where - worker commentAcc input docType checkNextLine = case alexGetChar' input of - Just ('\n', input') - | checkNextLine -> case checkIfCommentLine input' of - Just input -> worker ('\n':commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - | otherwise -> docCommentEnd input commentAcc docType buf span - Just (c, input) -> worker (c:commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - - -- Check if the next line of input belongs to this doc comment as well. - -- A doc comment continues onto the next line when the following - -- conditions are met: - -- * The line starts with "--" - -- * The line doesn't start with "---". - -- * The line doesn't start with "-- $", because that would be the - -- start of a /new/ named haddock chunk (#10398). - checkIfCommentLine :: AlexInput -> Maybe AlexInput - checkIfCommentLine input = check (dropNonNewlineSpace input) - where - check input = do - ('-', input) <- alexGetChar' input - ('-', input) <- alexGetChar' input - (c, after_c) <- alexGetChar' input - case c of - '-' -> Nothing - ' ' -> case alexGetChar' after_c of - Just ('$', _) -> Nothing - _ -> Just input - _ -> Just input - - dropNonNewlineSpace input = case alexGetChar' input of - Just (c, input') - | isSpace c && c /= '\n' -> dropNonNewlineSpace input' - | otherwise -> input - Nothing -> input - -lineCommentToken :: Action -lineCommentToken span buf len = do - b <- getBit RawTokenStreamBit - if b then strtoken ITlineComment span buf len else lexToken - -{- - nested comments require traversing by hand, they can't be parsed - using regular expressions. --} -nested_comment :: P (RealLocated Token) -> Action -nested_comment cont span buf len = do - input <- getInput - go (reverse $ lexemeToString buf len) (1::Int) input - where - go commentAcc 0 input = do - setInput input - b <- getBit RawTokenStreamBit - if b - then docCommentEnd input commentAcc ITblockComment buf span - else cont - go commentAcc n input = case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' - Just (_,_) -> go ('-':commentAcc) n input - Just ('\123',input) -> case alexGetChar' input of -- '{' char - Nothing -> errBrace input span - Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input - Just (_,_) -> go ('\123':commentAcc) n input - -- See Note [Nested comment line pragmas] - Just ('\n',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input - go (parsedAcc ++ '\n':commentAcc) n input - Just (_,_) -> go ('\n':commentAcc) n input - Just (c,input) -> go (c:commentAcc) n input - -nested_doc_comment :: Action -nested_doc_comment span buf _len = withLexedDocType (go "") - where - go commentAcc input docType _ = case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('\125',input) -> - docCommentEnd input commentAcc docType buf span - Just (_,_) -> go ('-':commentAcc) input docType False - Just ('\123', input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('-',input) -> do - setInput input - let cont = do input <- getInput; go commentAcc input docType False - nested_comment cont span buf _len - Just (_,_) -> go ('\123':commentAcc) input docType False - -- See Note [Nested comment line pragmas] - Just ('\n',input) -> case alexGetChar' input of - Nothing -> errBrace input span - Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input - go (parsedAcc ++ '\n':commentAcc) input docType False - Just (_,_) -> go ('\n':commentAcc) input docType False - Just (c,input) -> go (c:commentAcc) input docType False - --- See Note [Nested comment line pragmas] -parseNestedPragma :: AlexInput -> P (String,AlexInput) -parseNestedPragma input@(AI _ buf) = do - origInput <- getInput - setInput input - setExts (.|. xbit InNestedCommentBit) - pushLexState bol - lt <- lexToken - _ <- popLexState - setExts (.&. complement (xbit InNestedCommentBit)) - postInput@(AI _ postBuf) <- getInput - setInput origInput - case unRealSrcSpan lt of - ITcomment_line_prag -> do - let bytes = byteDiff buf postBuf - diff = lexemeToString buf bytes - return (reverse diff, postInput) - lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt')) - -{- -Note [Nested comment line pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to ignore cpp-preprocessor-generated #line pragmas if they were inside -nested comments. - -Now, when parsing a nested comment, if we encounter a line starting with '#' we -call parseNestedPragma, which executes the following: -1. Save the current lexer input (loc, buf) for later -2. Set the current lexer input to the beginning of the line starting with '#' -3. Turn the 'InNestedComment' extension on -4. Push the 'bol' lexer state -5. Lex a token. Due to (2), (3), and (4), this should always lex a single line - or less and return the ITcomment_line_prag token. This may set source line - and file location if a #line pragma is successfully parsed -6. Restore lexer input and state to what they were before we did all this -7. Return control to the function parsing a nested comment, informing it of - what the lexer parsed - -Regarding (5) above: -Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1) -checks if the 'InNestedComment' extension is set. If it is, that function will -return control to parseNestedPragma by returning the ITcomment_line_prag token. - -See #314 for more background on the bug this fixes. --} - -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) - -> P (RealLocated Token) -withLexedDocType lexDocComment = do - input@(AI _ buf) <- getInput - case prevChar buf ' ' of - -- The `Bool` argument to lexDocComment signals whether or not the next - -- line of input might also belong to this doc comment. - '|' -> lexDocComment input ITdocCommentNext True - '^' -> lexDocComment input ITdocCommentPrev True - '$' -> lexDocComment input ITdocCommentNamed True - '*' -> lexDocSection 1 input - _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection n input = case alexGetChar' input of - Just ('*', input) -> lexDocSection (n+1) input - Just (_, _) -> lexDocComment input (ITdocSection n) False - Nothing -> do setInput input; lexToken -- eof reached, lex it normally - --- RULES pragmas turn on the forall and '.' keywords, and we turn them --- off again at the end of the pragma. -rulePrag :: Action -rulePrag span buf len = do - setExts (.|. xbit InRulePragBit) - let !src = lexemeToString buf len - return (L span (ITrules_prag (SourceText src))) - --- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead --- of updating the position in 'PState' -linePrag :: Action -linePrag span buf len = do - usePosPrags <- getBit UsePosPragsBit - if usePosPrags - then begin line_prag2 span buf len - else let !src = lexemeToString buf len - in return (L span (ITline_prag (SourceText src))) - --- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead --- of updating the position in 'PState' -columnPrag :: Action -columnPrag span buf len = do - usePosPrags <- getBit UsePosPragsBit - let !src = lexemeToString buf len - if usePosPrags - then begin column_prag span buf len - else let !src = lexemeToString buf len - in return (L span (ITcolumn_prag (SourceText src))) - -endPrag :: Action -endPrag span _buf _len = do - setExts (.&. complement (xbit InRulePragBit)) - return (L span ITclose_prag) - --- docCommentEnd -------------------------------------------------------------------------------- --- This function is quite tricky. We can't just return a new token, we also --- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so --- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. - -docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - RealSrcSpan -> P (RealLocated Token) -docCommentEnd input commentAcc docType buf span = do - setInput input - let (AI loc nextBuf) = input - comment = reverse commentAcc - span' = mkRealSrcSpan (realSrcSpanStart span) loc - last_len = byteDiff buf nextBuf - - span `seq` setLastToken span' last_len - return (L span' (docType comment)) - -errBrace :: AlexInput -> RealSrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" - -open_brace, close_brace :: Action -open_brace span _str _len = do - ctx <- getContext - setContext (NoLayout:ctx) - return (L span ITocurly) -close_brace span _str _len = do - popContext - return (L span ITccurly) - -qvarid, qconid :: StringBuffer -> Int -> Token -qvarid buf len = ITqvarid $! splitQualName buf len False -qconid buf len = ITqconid $! splitQualName buf len False - -splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) --- takes a StringBuffer and a length, and returns the module name --- and identifier parts of a qualified name. Splits at the *last* dot, --- because of hierarchical module names. -splitQualName orig_buf len parens = split orig_buf orig_buf - where - split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf - where - (c,buf') = nextChar buf - - -- careful, we might get names like M.... - -- so, if the character after the dot is not upper-case, this is - -- the end of the qualifier part. - found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf - where - (c,buf') = nextChar buf - - done dot_buf = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) - then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) - else lexemeToFastString dot_buf (len - qual_size)) - where - qual_size = orig_buf `byteDiff` dot_buf - -varid :: Action -varid span buf len = - case lookupUFM reservedWordsFM fs of - Just (ITcase, _) -> do - lastTk <- getLastTk - keyword <- case lastTk of - Just ITlam -> do - lambdaCase <- getBit LambdaCaseBit - unless lambdaCase $ do - pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text - "Illegal lambda-case (use LambdaCase)" - return ITlcase - _ -> return ITcase - maybe_layout keyword - return $ L span keyword - Just (keyword, 0) -> do - maybe_layout keyword - return $ L span keyword - Just (keyword, i) -> do - exts <- getExts - if exts .&. i /= 0 - then do - maybe_layout keyword - return $ L span keyword - else - return $ L span $ ITvarid fs - Nothing -> - return $ L span $ ITvarid fs - where - !fs = lexemeToFastString buf len - -conid :: StringBuffer -> Int -> Token -conid buf len = ITconid $! lexemeToFastString buf len - -qvarsym, qconsym :: StringBuffer -> Int -> Token -qvarsym buf len = ITqvarsym $! splitQualName buf len False -qconsym buf len = ITqconsym $! splitQualName buf len False - -varsym, consym :: Action -varsym = sym ITvarsym -consym = sym ITconsym - -sym :: (FastString -> Token) -> Action -sym con span buf len = - case lookupUFM reservedSymsFM fs of - Just (keyword, NormalSyntax, 0) -> - return $ L span keyword - Just (keyword, NormalSyntax, i) -> do - exts <- getExts - if exts .&. i /= 0 - then return $ L span keyword - else return $ L span (con fs) - Just (keyword, UnicodeSyntax, 0) -> do - exts <- getExts - if xtest UnicodeSyntaxBit exts - then return $ L span keyword - else return $ L span (con fs) - Just (keyword, UnicodeSyntax, i) -> do - exts <- getExts - if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts - then return $ L span keyword - else return $ L span (con fs) - Nothing -> - return $ L span $! con fs - where - !fs = lexemeToFastString buf len - --- Variations on the integral numeric literal. -tok_integral :: (SourceText -> Integer -> Token) - -> (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char -> Int)) - -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do - numericUnderscores <- getBit NumericUnderscoresBit -- #14473 - let src = lexemeToString buf len - when ((not numericUnderscores) && ('_' `elem` src)) $ do - pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text - "Use NumericUnderscores to allow underscores in integer literals" - return $ L span $ itint (SourceText src) - $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int - -tok_num :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_num = tok_integral $ \case - st@(SourceText ('-':_)) -> itint st (const True) - st@(SourceText _) -> itint st (const False) - st@NoSourceText -> itint st (< 0) - where - itint :: SourceText -> (Integer -> Bool) -> Integer -> Token - itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val) - -tok_primint :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primint = tok_integral ITprimint - - -tok_primword :: Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primword = tok_integral ITprimword positive -positive, negative :: (Integer -> Integer) -positive = id -negative = negate -decimal, octal, hexadecimal :: (Integer, Char -> Int) -decimal = (10,octDecDigit) -binary = (2,octDecDigit) -octal = (8,octDecDigit) -hexadecimal = (16,hexDigit) - --- readRational can understand negative rationals, exponents, everything. -tok_frac :: Int -> (String -> Token) -> Action -tok_frac drop f span buf len = do - numericUnderscores <- getBit NumericUnderscoresBit -- #14473 - let src = lexemeToString buf (len-drop) - when ((not numericUnderscores) && ('_' `elem` src)) $ do - pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text - "Use NumericUnderscores to allow underscores in floating literals" - return (L span $! (f $! src)) - -tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readFractionalLit str -tok_hex_float str = ITrational $! readHexFractionalLit str -tok_primfloat str = ITprimfloat $! readFractionalLit str -tok_primdouble str = ITprimdouble $! readFractionalLit str - -readFractionalLit :: String -> FractionalLit -readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str - where is_neg = case str of ('-':_) -> True - _ -> False -readHexFractionalLit :: String -> FractionalLit -readHexFractionalLit str = - FL { fl_text = SourceText str - , fl_neg = case str of - '-' : _ -> True - _ -> False - , fl_value = readHexRational str - } - --- ----------------------------------------------------------------------------- --- Layout processing - --- we're at the first token on a line, insert layout tokens if necessary -do_bol :: Action -do_bol span _str _len = do - -- See Note [Nested comment line pragmas] - b <- getBit InNestedCommentBit - if b then return (L span ITcomment_line_prag) else do - (pos, gen_semic) <- getOffside - case pos of - LT -> do - --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ | gen_semic -> do - --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - _ -> do - _ <- popLexState - lexToken - --- certain keywords put us in the "layout" state, where we might --- add an opening curly brace. -maybe_layout :: Token -> P () -maybe_layout t = do -- If the alternative layout rule is enabled then - -- we never create an implicit layout context here. - -- Layout is handled XXX instead. - -- The code for closing implicit contexts, or - -- inserting implicit semi-colons, is therefore - -- irrelevant as it only applies in an implicit - -- context. - alr <- getBit AlternativeLayoutRuleBit - unless alr $ f t - where f ITdo = pushLexState layout_do - f ITmdo = pushLexState layout_do - f ITof = pushLexState layout - f ITlcase = pushLexState layout - f ITlet = pushLexState layout - f ITwhere = pushLexState layout - f ITrec = pushLexState layout - f ITif = pushLexState layout_if - f _ = return () - --- Pushing a new implicit layout context. If the indentation of the --- next token is not greater than the previous layout context, then --- Haskell 98 says that the new layout context should be empty; that is --- the lexer must generate {}. --- --- We are slightly more lenient than this: when the new context is started --- by a 'do', then we allow the new context to be at the same indentation as --- the previous context. This is what the 'strict' argument is for. -new_layout_context :: Bool -> Bool -> Token -> Action -new_layout_context strict gen_semic tok span _buf len = do - _ <- popLexState - (AI l _) <- getInput - let offset = srcLocCol l - len - ctx <- getContext - nondecreasing <- getBit NondecreasingIndentationBit - let strict' = strict || not nondecreasing - case ctx of - Layout prev_off _ : _ | - (strict' && prev_off >= offset || - not strict' && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span tok) - _ -> do setContext (Layout offset gen_semic : ctx) - return (L span tok) - -do_layout_left :: Action -do_layout_left span _buf _len = do - _ <- popLexState - pushLexState bol -- we must be at the start of a line - return (L span ITvccurly) - --- ----------------------------------------------------------------------------- --- LINE pragmas - -setLineAndFile :: Int -> Action -setLineAndFile code span buf len = do - let src = lexemeToString buf (len - 1) -- drop trailing quotation mark - linenumLen = length $ head $ words src - linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit - file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src - -- skip everything through first quotation mark to get to the filename - where go ('\\':c:cs) = c : go cs - go (c:cs) = c : go cs - go [] = [] - -- decode escapes in the filename. e.g. on Windows - -- when our filenames have backslashes in, gcc seems to - -- escape the backslashes. One symptom of not doing this - -- is that filenames in error messages look a bit strange: - -- C:\\foo\bar.hs - -- only the first backslash is doubled, because we apply - -- System.FilePath.normalise before printing out - -- filenames and it does not remove duplicate - -- backslashes after the drive letter (should it?). - setAlrLastLoc $ alrInitialLoc file - setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) - -- subtract one: the line number refers to the *following* line - addSrcFile file - _ <- popLexState - pushLexState code - lexToken - -setColumn :: Action -setColumn span buf len = do - let column = - case reads (lexemeToString buf len) of - [(column, _)] -> column - _ -> error "setColumn: expected integer" -- shouldn't happen - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) - (fromIntegral (column :: Integer))) - _ <- popLexState - lexToken - -alrInitialLoc :: FastString -> RealSrcSpan -alrInitialLoc file = mkRealSrcSpan loc loc - where -- This is a hack to ensure that the first line in a file - -- looks like it is after the initial location: - loc = mkRealSrcLoc file (-1) (-1) - --- ----------------------------------------------------------------------------- --- Options, includes and language pragmas. - -lex_string_prag :: (String -> Token) -> Action -lex_string_prag mkTok span _buf _len - = do input <- getInput - start <- getRealSrcLoc - tok <- go [] input - end <- getRealSrcLoc - return (L (mkRealSrcSpan start end) tok) - where go acc input - = if isString input "#-}" - then do setInput input - return (mkTok (reverse acc)) - else case alexGetChar input of - Just (c,i) -> go (c:acc) i - Nothing -> err input - isString _ [] = True - isString i (x:xs) - = case alexGetChar i of - Just (c,i') | c == x -> isString i' xs - _other -> False - err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" - - --- ----------------------------------------------------------------------------- --- Strings & Chars - --- This stuff is horrible. I hates it. - -lex_string_tok :: Action -lex_string_tok span buf _len = do - tok <- lex_string "" - (AI end bufEnd) <- getInput - let - tok' = case tok of - ITprimstring _ bs -> ITprimstring (SourceText src) bs - ITstring _ s -> ITstring (SourceText src) s - _ -> panic "lex_string_tok" - src = lexemeToString buf (cur bufEnd - cur buf) - return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') - -lex_string :: String -> P Token -lex_string s = do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i - - Just ('"',i) -> do - setInput i - let s' = reverse s - magicHash <- getBit MagicHashBit - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - when (any (> '\xFF') s') $ do - pState <- getPState - addError (RealSrcSpan (last_loc pState)) $ text - "primitive string literal must contain only characters <= \'\\xFF\'" - return (ITprimstring (SourceText s') (unsafeMkByteString s')) - _other -> - return (ITstring (SourceText s') (mkFastString s')) - else - return (ITstring (SourceText s') (mkFastString s')) - - Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do - -- is_space only works for <= '\x7f' (#3751, #5425) - setInput i; lex_stringgap s - where next = alexGetChar' i - - Just (c, i1) -> do - case c of - '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) - c | isAny c -> do setInput i1; lex_string (c:s) - _other -> lit_error i - -lex_stringgap :: String -> P Token -lex_stringgap s = do - i <- getInput - c <- getCharOrFail i - case c of - '\\' -> lex_string s - c | c <= '\x7f' && is_space c -> lex_stringgap s - -- is_space only works for <= '\x7f' (#3751, #5425) - _other -> lit_error i - - -lex_char_tok :: Action --- Here we are basically parsing character literals, such as 'x' or '\n' --- but we additionally spot 'x and ''T, returning ITsimpleQuote and --- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part --- (the parser does that). --- So we have to do two characters of lookahead: when we see 'x we need to --- see if there's a trailing quote -lex_char_tok span buf _len = do -- We've seen ' - i1 <- getInput -- Look ahead to first character - let loc = realSrcSpanStart span - case alexGetChar' i1 of - Nothing -> lit_error i1 - - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - setInput i2 - return (L (mkRealSrcSpan loc end2) ITtyQuote) - - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape - i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok buf loc lit_ch - else lit_error i3 - - Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> - - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok buf loc c - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- Just parse the quote only - let (AI end _) = i1 - return (L (mkRealSrcSpan loc end) ITsimpleQuote) - -finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) -finish_char_tok buf loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- getBit MagicHashBit - i@(AI end bufEnd) <- getInput - let src = lexemeToString buf (cur bufEnd - cur buf) - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkRealSrcSpan loc end) - (ITprimchar (SourceText src) ch)) - _other -> - return (L (mkRealSrcSpan loc end) - (ITchar (SourceText src) ch)) - else do - return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) - -isAny :: Char -> Bool -isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c - -lex_escape :: P Char -lex_escape = do - i0 <- getInput - c <- getCharOrFail i0 - case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - '^' -> do i1 <- getInput - c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> - case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 - -readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char -readNum is_digit base conv = do - i <- getInput - c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i - -readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char -readNum2 is_digit base conv i = do - input <- getInput - read i input - where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do - let i' = i*base + conv c - if i' > 0x10ffff - then setInput input >> lexError "numeric escape sequence out of range" - else read i' input' - _other -> do - setInput input; return (chr i) - - -silly_escape_chars :: [(String, Char)] -silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] - --- before calling lit_error, ensure that the current input is pointing to --- the position of the error in the buffer. This is so that we can report --- a correct location to the user, but also so we can detect UTF-8 decoding --- errors if they occur. -lit_error :: AlexInput -> P a -lit_error i = do setInput i; lexError "lexical error in string/character literal" - -getCharOrFail :: AlexInput -> P Char -getCharOrFail i = do - case alexGetChar' i of - Nothing -> lexError "unexpected end-of-file in string/character literal" - Just (c,i) -> do setInput i; return c - --- ----------------------------------------------------------------------------- --- QuasiQuote - -lex_qquasiquote_tok :: Action -lex_qquasiquote_tok span buf len = do - let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False - quoteStart <- getRealSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getRealSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) - (ITqQuasiQuote (qual, - quoter, - mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) - -lex_quasiquote_tok :: Action -lex_quasiquote_tok span buf len = do - let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getRealSrcLoc - quote <- lex_quasiquote quoteStart "" - end <- getRealSrcLoc - return (L (mkRealSrcSpan (realSrcSpanStart span) end) - (ITquasiQuote (mkFastString quoter, - mkFastString (reverse quote), - mkRealSrcSpan quoteStart end))) - -lex_quasiquote :: RealSrcLoc -> String -> P String -lex_quasiquote start s = do - i <- getInput - case alexGetChar' i of - Nothing -> quasiquote_error start - - -- NB: The string "|]" terminates the quasiquote, - -- with absolutely no escaping. See the extensive - -- discussion on #5348 for why there is no - -- escape handling. - Just ('|',i) - | Just (']',i) <- alexGetChar' i - -> do { setInput i; return s } - - Just (c, i) -> do - setInput i; lex_quasiquote start (c : s) - -quasiquote_error :: RealSrcLoc -> P a -quasiquote_error start = do - (AI end buf) <- getInput - reportLexError start end buf "unterminated quasiquotation" - --- ----------------------------------------------------------------------------- --- Warnings - -warnTab :: Action -warnTab srcspan _buf _len = do - addTabWarning srcspan - lexToken - -warnThen :: WarningFlag -> SDoc -> Action -> Action -warnThen option warning action srcspan buf len = do - addWarning option (RealSrcSpan srcspan) warning - action srcspan buf len - --- ----------------------------------------------------------------------------- --- The Parse Monad - --- | Do we want to generate ';' layout tokens? In some cases we just want to --- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates --- alternatives (unlike a `case` expression where we need ';' to as a separator --- between alternatives). -type GenSemic = Bool - -generateSemic, dontGenerateSemic :: GenSemic -generateSemic = True -dontGenerateSemic = False - -data LayoutContext - = NoLayout - | Layout !Int !GenSemic - deriving Show - --- | The result of running a parser. -data ParseResult a - = POk -- ^ The parser has consumed a (possibly empty) prefix - -- of the input and produced a result. Use 'getMessages' - -- to check for accumulated warnings and non-fatal errors. - PState -- ^ The resulting parsing state. Can be used to resume parsing. - a -- ^ The resulting value. - | PFailed -- ^ The parser has consumed a (possibly empty) prefix - -- of the input and failed. - PState -- ^ The parsing state right before failure, including the fatal - -- parse error. 'getMessages' and 'getErrorMessages' must return - -- a non-empty bag of errors. - --- | Test whether a 'WarningFlag' is set -warnopt :: WarningFlag -> ParserFlags -> Bool -warnopt f options = f `EnumSet.member` pWarningFlags options - --- | The subset of the 'DynFlags' used by the parser. --- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this. -data ParserFlags = ParserFlags { - pWarningFlags :: EnumSet WarningFlag - , pThisPackage :: UnitId -- ^ key of package currently being compiled - , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions - } - -data PState = PState { - buffer :: StringBuffer, - options :: ParserFlags, - -- This needs to take DynFlags as an argument until - -- we have a fix for #10143 - messages :: DynFlags -> Messages, - tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file - tab_count :: !Int, -- number of tab warnings in the file - last_tk :: Maybe Token, - last_loc :: RealSrcSpan, -- pos of previous token - last_len :: !Int, -- len of previous token - loc :: RealSrcLoc, -- current loc (end of prev token + 1) - context :: [LayoutContext], - lex_state :: [Int], - srcfiles :: [FastString], - -- Used in the alternative layout rule: - -- These tokens are the next ones to be sent out. They are - -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [RealLocated Token], - -- This is the next token to be considered or, if it is Nothing, - -- we need to get the next token from the input stream: - alr_next_token :: Maybe (RealLocated Token), - -- This is what we consider to be the location of the last token - -- emitted: - alr_last_loc :: RealSrcSpan, - -- The stack of layout contexts: - alr_context :: [ALRContext], - -- Are we expecting a '{'? If it's Just, then the ALRLayout tells - -- us what sort of layout the '{' will open: - alr_expecting_ocurly :: Maybe ALRLayout, - -- Have we just had the '}' for a let block? If so, than an 'in' - -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool, - - -- The next three are used to implement Annotations giving the - -- locations of 'noise' tokens in the source, so that users of - -- the GHC API can do source to source conversions. - -- See note [Api annotations] in ApiAnnotation.hs - annotations :: [(ApiAnnKey,[SrcSpan])], - comment_q :: [Located AnnotationComment], - annotations_comments :: [(SrcSpan,[Located AnnotationComment])] - } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). - -data ALRContext = ALRNoLayout Bool{- does it contain commas? -} - Bool{- is it a 'let' block? -} - | ALRLayout ALRLayout Int -data ALRLayout = ALRLayoutLet - | ALRLayoutWhere - | ALRLayoutOf - | ALRLayoutDo - --- | The parsing monad, isomorphic to @StateT PState Maybe@. -newtype P a = P { unP :: PState -> ParseResult a } - -instance Functor P where - fmap = liftM - -instance Applicative P where - pure = returnP - (<*>) = ap - -instance Monad P where - (>>=) = thenP -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - -instance MonadFail.MonadFail P where - fail = failMsgP - -returnP :: a -> P a -returnP a = a `seq` (P $ \s -> POk s a) - -thenP :: P a -> (a -> P b) -> P b -(P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed s1 -> PFailed s1 - -failMsgP :: String -> P a -failMsgP msg = do - pState <- getPState - addFatalError (RealSrcSpan (last_loc pState)) (text msg) - -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a -failLocMsgP loc1 loc2 str = - addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) - -getPState :: P PState -getPState = P $ \s -> POk s s - -withThisPackage :: (UnitId -> a) -> P a -withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o)) - -getExts :: P ExtsBitmap -getExts = P $ \s -> POk s (pExtsBitmap . options $ s) - -setExts :: (ExtsBitmap -> ExtsBitmap) -> P () -setExts f = P $ \s -> POk s { - options = - let p = options s - in p { pExtsBitmap = f (pExtsBitmap p) } - } () - -setSrcLoc :: RealSrcLoc -> P () -setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () - -getRealSrcLoc :: P RealSrcLoc -getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc - -addSrcFile :: FastString -> P () -addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () - -setLastToken :: RealSrcSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, - last_len=len - } () - -setLastTk :: Token -> P () -setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () - -getLastTk :: P (Maybe Token) -getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk - -data AlexInput = AI RealSrcLoc StringBuffer - -{- -Note [Unicode in Alex] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Although newer versions of Alex support unicode, this grammar is processed with -the old style '--latin1' behaviour. This means that when implementing the -functions - - alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) - alexInputPrevChar :: AlexInput -> Char - -which Alex uses to take apart our 'AlexInput', we must - - * return a latin1 character in the 'Word8' that 'alexGetByte' expects - * return a latin1 character in 'alexInputPrevChar'. - -We handle this in 'adjustChar' by squishing entire classes of unicode -characters into single bytes. --} - -{-# INLINE adjustChar #-} -adjustChar :: Char -> Word8 -adjustChar c = fromIntegral $ ord adj_c - where non_graphic = '\x00' - upper = '\x01' - lower = '\x02' - digit = '\x03' - symbol = '\x04' - space = '\x05' - other_graphic = '\x06' - uniidchar = '\x07' - - adj_c - | c <= '\x07' = non_graphic - | c <= '\x7f' = c - -- Alex doesn't handle Unicode, so when Unicode - -- character is encountered we output these values - -- with the actual character value hidden in the state. - | otherwise = - -- NB: The logic behind these definitions is also reflected - -- in basicTypes/Lexeme.hs - -- Any changes here should likely be reflected there. - - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> uniidchar -- see #10196 - OtherLetter -> lower -- see #1103 - NonSpacingMark -> uniidchar -- see #7650 - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> other_graphic - OtherNumber -> digit -- see #4373 - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic - --- Getting the previous 'Char' isn't enough here - we need to convert it into --- the same format that 'alexGetByte' would have produced. --- --- See Note [Unicode in Alex] and #13986. -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc)) - where pc = prevChar buf '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - --- See Note [Unicode in Alex] -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (AI loc s) - | atEnd s = Nothing - | otherwise = byte `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (byte, (AI loc' s')) - where (c,s') = nextChar s - loc' = advanceSrcLoc loc c - byte = adjustChar c - --- This version does not squash unicode characters, it is used when --- lexing strings. -alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) - | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) - where (c,s') = nextChar s - loc' = advanceSrcLoc loc c - -getInput :: P AlexInput -getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) - -setInput :: AlexInput -> P () -setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () - -nextIsEOF :: P Bool -nextIsEOF = do - AI _ s <- getInput - return $ atEnd s - -pushLexState :: Int -> P () -pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () - -popLexState :: P Int -popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls - -getLexState :: P Int -getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls - -popNextToken :: P (Maybe (RealLocated Token)) -popNextToken - = P $ \s@PState{ alr_next_token = m } -> - POk (s {alr_next_token = Nothing}) m - -activeContext :: P Bool -activeContext = do - ctxt <- getALRContext - expc <- getAlrExpectingOCurly - impt <- implicitTokenPending - case (ctxt,expc) of - ([],Nothing) -> return impt - _other -> return True - -setAlrLastLoc :: RealSrcSpan -> P () -setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () - -getAlrLastLoc :: P RealSrcSpan -getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l - -getALRContext :: P [ALRContext] -getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs - -setALRContext :: [ALRContext] -> P () -setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () - -getJustClosedExplicitLetBlock :: P Bool -getJustClosedExplicitLetBlock - = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b - -setJustClosedExplicitLetBlock :: Bool -> P () -setJustClosedExplicitLetBlock b - = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () - -setNextToken :: RealLocated Token -> P () -setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () - -implicitTokenPending :: P Bool -implicitTokenPending - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s False - _ -> POk s True - -popPendingImplicitToken :: P (Maybe (RealLocated Token)) -popPendingImplicitToken - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s Nothing - (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) - -setPendingImplicitTokens :: [RealLocated Token] -> P () -setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () - -getAlrExpectingOCurly :: P (Maybe ALRLayout) -getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b - -setAlrExpectingOCurly :: Maybe ALRLayout -> P () -setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () - --- | For reasons of efficiency, boolean parsing flags (eg, language extensions --- or whether we are currently in a @RULE@ pragma) are represented by a bitmap --- stored in a @Word64@. -type ExtsBitmap = Word64 - -xbit :: ExtBits -> ExtsBitmap -xbit = bit . fromEnum - -xtest :: ExtBits -> ExtsBitmap -> Bool -xtest ext xmap = testBit xmap (fromEnum ext) - --- | Various boolean flags, mostly language extensions, that impact lexing and --- parsing. Note that a handful of these can change during lexing/parsing. -data ExtBits - -- Flags that are constant once parsing starts - = FfiBit - | InterruptibleFfiBit - | CApiFfiBit - | ArrowsBit - | ThBit - | ThQuotesBit - | IpBit - | OverloadedLabelsBit -- #x overloaded labels - | ExplicitForallBit -- the 'forall' keyword - | BangPatBit -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) - | PatternSynonymsBit -- pattern synonyms - | HaddockBit-- Lex and parse Haddock comments - | MagicHashBit -- "#" in both functions and operators - | RecursiveDoBit -- mdo - | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc - | UnboxedTuplesBit -- (# and #) - | UnboxedSumsBit -- (# and #) - | DatatypeContextsBit - | MonadComprehensionsBit - | TransformComprehensionsBit - | QqBit -- enable quasiquoting - | RawTokenStreamBit -- producing a token stream with all comments included - | AlternativeLayoutRuleBit - | ALRTransitionalBit - | RelaxedLayoutBit - | NondecreasingIndentationBit - | SafeHaskellBit - | TraditionalRecordSyntaxBit - | ExplicitNamespacesBit - | LambdaCaseBit - | BinaryLiteralsBit - | NegativeLiteralsBit - | HexFloatLiteralsBit - | TypeApplicationsBit - | StaticPointersBit - | NumericUnderscoresBit - | StarIsTypeBit - | BlockArgumentsBit - | NPlusKPatternsBit - | DoAndIfThenElseBit - | MultiWayIfBit - | GadtSyntaxBit - | ImportQualifiedPostBit - - -- Flags that are updated once parsing starts - | InRulePragBit - | InNestedCommentBit -- See Note [Nested comment line pragmas] - | UsePosPragsBit - -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' - -- update the internal position. Otherwise, those pragmas are lexed as - -- tokens of their own. - deriving Enum - - - - - --- PState for parsing options pragmas --- -pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState -pragState dynflags buf loc = (mkPState dynflags buf loc) { - lex_state = [bol, option_prags, 0] - } - -{-# INLINE mkParserFlags' #-} -mkParserFlags' - :: EnumSet WarningFlag -- ^ warnings flags enabled - -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled - -> UnitId -- ^ key of package currently being compiled - -> Bool -- ^ are safe imports on? - -> Bool -- ^ keeping Haddock comment tokens - -> Bool -- ^ keep regular comment tokens - - -> Bool - -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update - -- the internal position kept by the parser. Otherwise, those pragmas are - -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. - - -> ParserFlags --- ^ Given exactly the information needed, set up the 'ParserFlags' -mkParserFlags' warningFlags extensionFlags thisPackage - safeImports isHaddock rawTokStream usePosPrags = - ParserFlags { - pWarningFlags = warningFlags - , pThisPackage = thisPackage - , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits - } - where - safeHaskellBit = SafeHaskellBit `setBitIf` safeImports - langExtBits = - FfiBit `xoptBit` LangExt.ForeignFunctionInterface - .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI - .|. CApiFfiBit `xoptBit` LangExt.CApiFFI - .|. ArrowsBit `xoptBit` LangExt.Arrows - .|. ThBit `xoptBit` LangExt.TemplateHaskell - .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes - .|. QqBit `xoptBit` LangExt.QuasiQuotes - .|. IpBit `xoptBit` LangExt.ImplicitParams - .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels - .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll - .|. BangPatBit `xoptBit` LangExt.BangPatterns - .|. MagicHashBit `xoptBit` LangExt.MagicHash - .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo - .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax - .|. UnboxedTuplesBit `xoptBit` LangExt.UnboxedTuples - .|. UnboxedSumsBit `xoptBit` LangExt.UnboxedSums - .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts - .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp - .|. MonadComprehensionsBit `xoptBit` LangExt.MonadComprehensions - .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule - .|. ALRTransitionalBit `xoptBit` LangExt.AlternativeLayoutRuleTransitional - .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout - .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation - .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax - .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces - .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase - .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals - .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals - .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals - .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms - .|. TypeApplicationsBit `xoptBit` LangExt.TypeApplications - .|. StaticPointersBit `xoptBit` LangExt.StaticPointers - .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores - .|. StarIsTypeBit `xoptBit` LangExt.StarIsType - .|. BlockArgumentsBit `xoptBit` LangExt.BlockArguments - .|. NPlusKPatternsBit `xoptBit` LangExt.NPlusKPatterns - .|. DoAndIfThenElseBit `xoptBit` LangExt.DoAndIfThenElse - .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf - .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax - .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost - optBits = - HaddockBit `setBitIf` isHaddock - .|. RawTokenStreamBit `setBitIf` rawTokStream - .|. UsePosPragsBit `setBitIf` usePosPrags - - xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags - - setBitIf :: ExtBits -> Bool -> ExtsBitmap - b `setBitIf` cond | cond = xbit b - | otherwise = 0 - --- | Extracts the flag information needed for parsing -mkParserFlags :: DynFlags -> ParserFlags -mkParserFlags = - mkParserFlags' - <$> DynFlags.warningFlags - <*> DynFlags.extensionFlags - <*> DynFlags.thisPackage - <*> safeImportsOn - <*> gopt Opt_Haddock - <*> gopt Opt_KeepRawTokenStream - <*> const True - --- | Creates a parse state from a 'DynFlags' value -mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState -mkPState flags = mkPStatePure (mkParserFlags flags) - --- | Creates a parse state from a 'ParserFlags' value -mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState -mkPStatePure options buf loc = - PState { - buffer = buf, - options = options, - messages = const emptyMessages, - tab_first = Nothing, - tab_count = 0, - last_tk = Nothing, - last_loc = mkRealSrcSpan loc loc, - last_len = 0, - loc = loc, - context = [], - lex_state = [bol, 0], - srcfiles = [], - alr_pending_implicit_tokens = [], - alr_next_token = Nothing, - alr_last_loc = alrInitialLoc (fsLit ""), - alr_context = [], - alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False, - annotations = [], - comment_q = [], - annotations_comments = [] - } - --- | An mtl-style class for monads that support parsing-related operations. --- For example, sometimes we make a second pass over the parsing results to validate, --- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume --- input but can report parsing errors, check for extension bits, and accumulate --- parsing annotations. Both P and PV are instances of MonadP. --- --- MonadP grants us convenient overloading. The other option is to have separate operations --- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on. --- -class Monad m => MonadP m where - -- | Add a non-fatal error. Use this when the parser can produce a result - -- despite the error. - -- - -- For example, when GHC encounters a @forall@ in a type, - -- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ - -- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to - -- the accumulator. - -- - -- Control flow wise, non-fatal errors act like warnings: they are added - -- to the accumulator and parsing continues. This allows GHC to report - -- more than one parse error per file. - -- - addError :: SrcSpan -> SDoc -> m () - -- | Add a warning to the accumulator. - -- Use 'getMessages' to get the accumulated warnings. - addWarning :: WarningFlag -> SrcSpan -> SDoc -> m () - -- | Add a fatal error. This will be the last error reported by the parser, and - -- the parser will not produce any result, ending in a 'PFailed' state. - addFatalError :: SrcSpan -> SDoc -> m a - -- | Check if a given flag is currently set in the bitmap. - getBit :: ExtBits -> m Bool - -- | Given a location and a list of AddAnn, apply them all to the location. - addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct - -> AnnKeywordId -- The first two parameters are the key - -> SrcSpan -- The location of the keyword itself - -> m () - -appendError - :: SrcSpan - -> SDoc - -> (DynFlags -> Messages) - -> (DynFlags -> Messages) -appendError srcspan msg m = - \d -> - let (ws, es) = m d - errormsg = mkErrMsg d srcspan alwaysQualify msg - es' = es `snocBag` errormsg - in (ws, es') - -appendWarning - :: ParserFlags - -> WarningFlag - -> SrcSpan - -> SDoc - -> (DynFlags -> Messages) - -> (DynFlags -> Messages) -appendWarning o option srcspan warning m = - \d -> - let (ws, es) = m d - warning' = makeIntoWarning (Reason option) $ - mkWarnMsg d srcspan alwaysQualify warning - ws' = if warnopt option o then ws `snocBag` warning' else ws - in (ws', es) - -instance MonadP P where - addError srcspan msg - = P $ \s@PState{messages=m} -> - POk s{messages=appendError srcspan msg m} () - addWarning option srcspan warning - = P $ \s@PState{messages=m, options=o} -> - POk s{messages=appendWarning o option srcspan warning m} () - addFatalError span msg = - addError span msg >> P PFailed - getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) - in b `seq` POk s b - addAnnotation l a v = do - addAnnotationOnly l a v - allocateCommentsP l - -addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m () -addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v) - -addTabWarning :: RealSrcSpan -> P () -addTabWarning srcspan - = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> - let tf' = if isJust tf then tf else Just srcspan - tc' = tc + 1 - s' = if warnopt Opt_WarnTabs o - then s{tab_first = tf', tab_count = tc'} - else s - in POk s' () - -mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg -mkTabWarning PState{tab_first=tf, tab_count=tc} d = - let middle = if tc == 1 - then text "" - else text ", and in" <+> speakNOf (tc - 1) (text "further location") - message = text "Tab character found here" - <> middle - <> text "." - $+$ text "Please use spaces instead." - in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ - mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf - --- | Get a bag of the errors that have been accumulated so far. --- Does not take -Werror into account. -getErrorMessages :: PState -> DynFlags -> ErrorMessages -getErrorMessages PState{messages=m} d = - let (_, es) = m d in es - --- | Get the warnings and errors accumulated so far. --- Does not take -Werror into account. -getMessages :: PState -> DynFlags -> Messages -getMessages p@PState{messages=m} d = - let (ws, es) = m d - tabwarning = mkTabWarning p d - ws' = maybe ws (`consBag` ws) tabwarning - in (ws', es) - -getContext :: P [LayoutContext] -getContext = P $ \s@PState{context=ctx} -> POk s ctx - -setContext :: [LayoutContext] -> P () -setContext ctx = P $ \s -> POk s{context=ctx} () - -popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, - last_len = len, last_loc = last_loc }) -> - case ctx of - (_:tl) -> - POk s{ context = tl } () - [] -> - unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s - --- Push a new layout context at the indentation of the last token read. -pushCurrentContext :: GenSemic -> P () -pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> - POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} () - --- This is only used at the outer level of a module when the 'module' keyword is --- missing. -pushModuleContext :: P () -pushModuleContext = pushCurrentContext generateSemic - -getOffside :: P (Ordering, Bool) -getOffside = P $ \s@PState{last_loc=loc, context=stk} -> - let offs = srcSpanStartCol loc in - let ord = case stk of - Layout n gen_semic : _ -> - --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ - (compare offs n, gen_semic) - _ -> - (GT, dontGenerateSemic) - in POk s ord - --- --------------------------------------------------------------------------- --- Construct a parse error - -srcParseErr - :: ParserFlags - -> StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token - -> MsgDoc -srcParseErr options buf len - = if null token - then text "parse error (possibly incorrect indentation or mismatched brackets)" - else text "parse error on input" <+> quotes (text token) - $$ ppWhen (not th_enabled && token == "$") -- #7396 - (text "Perhaps you intended to use TemplateHaskell") - $$ ppWhen (token == "<-") - (if mdoInLast100 - then text "Perhaps you intended to use RecursiveDo" - else text "Perhaps this statement should be within a 'do' block?") - $$ ppWhen (token == "=" && doInLast100) -- #15849 - (text "Perhaps you need a 'let' in a 'do' block?" - $$ text "e.g. 'let x = 5' instead of 'x = 5'") - $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429 - (text "Perhaps you intended to use PatternSynonyms") - where token = lexemeToString (offsetBytes (-len) buf) len - pattern = decodePrevNChars 8 buf - last100 = decodePrevNChars 100 buf - doInLast100 = "do" `isInfixOf` last100 - mdoInLast100 = "mdo" `isInfixOf` last100 - th_enabled = ThBit `xtest` pExtsBitmap options - ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options - --- Report a parse failure, giving the span of the previous token as --- the location of the error. This is the entry point for errors --- detected during parsing. -srcParseFail :: P a -srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, - last_loc = last_loc } -> - unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s - --- A lexical error is reported at a particular position in the source file, --- not over a token range. -lexError :: String -> P a -lexError str = do - loc <- getRealSrcLoc - (AI end buf) <- getInput - reportLexError loc end buf str - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -lexer :: Bool -> (Located Token -> P a) -> P a -lexer queueComments cont = do - alr <- getBit AlternativeLayoutRuleBit - let lexTokenFun = if alr then lexTokenAlr else lexToken - (L span tok) <- lexTokenFun - --trace ("token: " ++ show tok) $ do - - case tok of - ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span) - _ -> return () - - if (queueComments && isDocComment tok) - then queueComment (L (RealSrcSpan span) tok) - else return () - - if (queueComments && isComment tok) - then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont - else cont (L (RealSrcSpan span) tok) - -lexTokenAlr :: P (RealLocated Token) -lexTokenAlr = do mPending <- popPendingImplicitToken - t <- case mPending of - Nothing -> - do mNext <- popNextToken - t <- case mNext of - Nothing -> lexToken - Just next -> return next - alternativeLayoutRuleToken t - Just t -> - return t - setAlrLastLoc (getRealSrcSpan t) - case unRealSrcSpan t of - ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) - ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) - ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) - ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf) - ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) - _ -> return () - return t - -alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) -alternativeLayoutRuleToken t - = do context <- getALRContext - lastLoc <- getAlrLastLoc - mExpectingOCurly <- getAlrExpectingOCurly - transitional <- getBit ALRTransitionalBit - justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock - setJustClosedExplicitLetBlock False - let thisLoc = getRealSrcSpan t - thisCol = srcSpanStartCol thisLoc - newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc - case (unRealSrcSpan t, context, mExpectingOCurly) of - -- This case handles a GHC extension to the original H98 - -- layout rule... - (ITocurly, _, Just alrLayout) -> - do setAlrExpectingOCurly Nothing - let isLet = case alrLayout of - ALRLayoutLet -> True - _ -> False - setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) - return t - -- ...and makes this case unnecessary - {- - -- I think our implicit open-curly handling is slightly - -- different to John's, in how it interacts with newlines - -- and "in" - (ITocurly, _, Just _) -> - do setAlrExpectingOCurly Nothing - setNextToken t - lexTokenAlr - -} - (_, ALRLayout _ col : _ls, Just expectingOCurly) - | (thisCol > col) || - (thisCol == col && - isNonDecreasingIndentation expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITvocurly) - | otherwise -> - do setAlrExpectingOCurly Nothing - setPendingImplicitTokens [L lastLoc ITvccurly] - setNextToken t - return (L lastLoc ITvocurly) - (_, _, Just expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITvocurly) - -- We do the [] cases earlier than in the spec, as we - -- have an actual EOF token - (ITeof, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - (ITeof, _, _) -> - return t - -- the other ITeof case omitted; general case below covers it - (ITin, _, _) - | justClosedExplicitLetBlock -> - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) - | newLine -> - do setPendingImplicitTokens [t] - setALRContext ls - return (L thisLoc ITvccurly) - -- This next case is to handle a transitional issue: - (ITwhere, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) - (transitionalAlternativeLayoutWarning - "`where' clause at the same depth as implicit layout block") - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITvccurly) - -- This next case is to handle a transitional issue: - (ITvbar, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - (RealSrcSpan thisLoc) - (transitionalAlternativeLayoutWarning - "`|' at the same depth as implicit layout block") - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITvccurly) - (_, ALRLayout _ col : ls, _) - | newLine && thisCol == col -> - do setNextToken t - let loc = realSrcSpanStart thisLoc - zeroWidthLoc = mkRealSrcSpan loc loc - return (L zeroWidthLoc ITsemi) - | newLine && thisCol < col -> - do setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITvccurly) - -- We need to handle close before open, as 'then' is both - -- an open and a close - (u, _, _) - | isALRclose u -> - case context of - ALRLayout _ _ : ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - ALRNoLayout _ isLet : ls -> - do let ls' = if isALRopen u - then ALRNoLayout (containsCommas u) False : ls - else ls - setALRContext ls' - when isLet $ setJustClosedExplicitLetBlock True - return t - [] -> - do let ls = if isALRopen u - then [ALRNoLayout (containsCommas u) False] - else [] - setALRContext ls - -- XXX This is an error in John's code, but - -- it looks reachable to me at first glance - return t - (u, _, _) - | isALRopen u -> - do setALRContext (ALRNoLayout (containsCommas u) False : context) - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITvccurly) - (ITin, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - -- the other ITin case omitted; general case below covers it - (ITcomma, ALRLayout _ _ : ls, _) - | topNoLayoutContainsCommas ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITvccurly) - -- the other ITwhere case omitted; general case below covers it - (_, _, _) -> return t - -transitionalAlternativeLayoutWarning :: String -> SDoc -transitionalAlternativeLayoutWarning msg - = text "transitional layout will not be accepted in the future:" - $$ text msg - -isALRopen :: Token -> Bool -isALRopen ITcase = True -isALRopen ITif = True -isALRopen ITthen = True -isALRopen IToparen = True -isALRopen ITobrack = True -isALRopen ITocurly = True --- GHC Extensions: -isALRopen IToubxparen = True -isALRopen ITparenEscape = True -isALRopen ITparenTyEscape = True -isALRopen _ = False - -isALRclose :: Token -> Bool -isALRclose ITof = True -isALRclose ITthen = True -isALRclose ITelse = True -isALRclose ITcparen = True -isALRclose ITcbrack = True -isALRclose ITccurly = True --- GHC Extensions: -isALRclose ITcubxparen = True -isALRclose _ = False - -isNonDecreasingIndentation :: ALRLayout -> Bool -isNonDecreasingIndentation ALRLayoutDo = True -isNonDecreasingIndentation _ = False - -containsCommas :: Token -> Bool -containsCommas IToparen = True -containsCommas ITobrack = True --- John doesn't have {} as containing commas, but records contain them, --- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs --- (defaultInstallDirs). -containsCommas ITocurly = True --- GHC Extensions: -containsCommas IToubxparen = True -containsCommas _ = False - -topNoLayoutContainsCommas :: [ALRContext] -> Bool -topNoLayoutContainsCommas [] = False -topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls -topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b - -lexToken :: P (RealLocated Token) -lexToken = do - inp@(AI loc1 buf) <- getInput - sc <- getLexState - exts <- getExts - case alexScanUser exts inp sc of - AlexEOF -> do - let span = mkRealSrcSpan loc1 loc1 - setLastToken span 0 - return (L span ITeof) - AlexError (AI loc2 buf) -> - reportLexError loc1 loc2 buf "lexical error" - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(AI end buf2) _ t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - let bytes = byteDiff buf buf2 - span `seq` setLastToken span bytes - lt <- t span buf bytes - case unRealSrcSpan lt of - ITlineComment _ -> return lt - ITblockComment _ -> return lt - lt' -> do - setLastTk lt' - return lt - -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a -reportLexError loc1 loc2 buf str - | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") - | otherwise = - let c = fst (nextChar buf) - in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") - else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) - -lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] -lexTokenStream buf loc dflags = unP go initState{ options = opts' } - where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream - initState@PState{ options = opts } = mkPState dflags' buf loc - opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts } - go = do - ltok <- lexer False return - case ltok of - L _ ITeof -> return [] - _ -> liftM (ltok:) go - -linePrags = Map.singleton "line" linePrag - -fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), - ("options_ghc", lex_string_prag IToptions_prag), - ("options_haddock", lex_string_prag ITdocOptions), - ("language", token ITlanguage_prag), - ("include", lex_string_prag ITinclude_prag)]) - -ignoredPrags = Map.fromList (map ignored pragmas) - where ignored opt = (opt, nested_comment lexToken) - impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] - options_pragmas = map ("options_" ++) impls - -- CFILES is a hugs-only thing. - pragmas = options_pragmas ++ ["cfiles", "contract"] - -oneWordPrags = Map.fromList [ - ("rules", rulePrag), - ("inline", - strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), - ("inlinable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), - ("inlineable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), - -- Spelling variant - ("notinline", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), - ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), - ("source", strtoken (\s -> ITsource_prag (SourceText s))), - ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), - ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), - ("scc", strtoken (\s -> ITscc_prag (SourceText s))), - ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))), - ("core", strtoken (\s -> ITcore_prag (SourceText s))), - ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), - ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), - ("ann", strtoken (\s -> ITann_prag (SourceText s))), - ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), - ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), - ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), - ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), - ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), - ("ctype", strtoken (\s -> ITctype (SourceText s))), - ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))), - ("column", columnPrag) - ] - -twoWordPrags = Map.fromList [ - ("inline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), - ("notinline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), - ("specialize inline", - strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), - ("specialize notinline", - strtoken (\s -> (ITspec_inline_prag (SourceText s) False))) - ] - -dispatch_pragmas :: Map String Action -> Action -dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of - Just found -> found span buf len - Nothing -> lexError "unknown pragma" - -known_pragma :: Map String Action -> AlexAccPred ExtsBitmap -known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) - = isKnown && nextCharIsNot curbuf pragmaNameChar - where l = lexemeToString startbuf (byteDiff startbuf curbuf) - isKnown = isJust $ Map.lookup (clean_pragma l) prags - pragmaNameChar c = isAlphaNum c || c == '_' - -clean_pragma :: String -> String -clean_pragma prag = canon_ws (map toLower (unprefix prag)) - where unprefix prag' = case stripPrefix "{-#" prag' of - Just rest -> rest - Nothing -> prag' - canonical prag' = case prag' of - "noinline" -> "notinline" - "specialise" -> "specialize" - "constructorlike" -> "conlike" - _ -> prag' - canon_ws s = unwords (map canonical (words s)) - - - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ --} - --- | Encapsulated call to addAnnotation, requiring only the SrcSpan of --- the AST construct the annotation belongs to; together with the --- AnnKeywordId, this is the key of the annotation map. --- --- This type is useful for places in the parser where it is not yet --- known what SrcSpan an annotation should be added to. The most --- common situation is when we are parsing a list: the annotations --- need to be associated with the AST element that *contains* the --- list, not the list itself. 'AddAnn' lets us defer adding the --- annotations until we finish parsing the list and are now parsing --- the enclosing element; we then apply the 'AddAnn' to associate --- the annotations. Another common situation is where a common fragment of --- the AST has been factored out but there is no separate AST node for --- this fragment (this occurs in class and data declarations). In this --- case, the annotation belongs to the parent data declaration. --- --- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") --- function, and then it can be discharged using the 'ams' function. -data AddAnn = AddAnn AnnKeywordId SrcSpan - -addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () -addAnnotationOnly l a v = P $ \s -> POk s { - annotations = ((l,a), [v]) : annotations s - } () - --- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate --- 'AddAnn' values for the opening and closing bordering on the start --- and end of the span -mkParensApiAnn :: SrcSpan -> [AddAnn] -mkParensApiAnn (UnhelpfulSpan _) = [] -mkParensApiAnn s@(RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc] - where - f = srcSpanFile ss - sl = srcSpanStartLine ss - sc = srcSpanStartCol ss - el = srcSpanEndLine ss - ec = srcSpanEndCol ss - lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) - lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) - -queueComment :: Located Token -> P() -queueComment c = P $ \s -> POk s { - comment_q = commentToAnnotation c : comment_q s - } () - --- | Go through the @comment_q@ in @PState@ and remove all comments --- that belong within the given span -allocateCommentsP :: SrcSpan -> P () -allocateCommentsP ss = P $ \s -> - let (comment_q', newAnns) = allocateComments ss (comment_q s) in - POk s { - comment_q = comment_q' - , annotations_comments = newAnns ++ (annotations_comments s) - } () - -allocateComments - :: SrcSpan - -> [Located AnnotationComment] - -> ([Located AnnotationComment], [(SrcSpan,[Located AnnotationComment])]) -allocateComments ss comment_q = - let - (before,rest) = break (\(L l _) -> isSubspanOf l ss) comment_q - (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest - comment_q' = before ++ after - newAnns = if null middle then [] - else [(ss,middle)] - in - (comment_q', newAnns) - - -commentToAnnotation :: Located Token -> Located AnnotationComment -commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) -commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) -commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) -commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) -commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) -commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) -commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) -commentToAnnotation _ = panic "commentToAnnotation" - --- --------------------------------------------------------------------- - -isComment :: Token -> Bool -isComment (ITlineComment _) = True -isComment (ITblockComment _) = True -isComment _ = False - -isDocComment :: Token -> Bool -isDocComment (ITdocCommentNext _) = True -isDocComment (ITdocCommentPrev _) = True -isDocComment (ITdocCommentNamed _) = True -isDocComment (ITdocSection _ _) = True -isDocComment (ITdocOptions _) = True -isDocComment _ = False -} diff --git a/parser/Parser.y b/parser/Parser.y deleted file mode 100644 --- a/parser/Parser.y +++ /dev/null @@ -1,4132 +0,0 @@ --- -*-haskell-*- --- --------------------------------------------------------------------------- --- (c) The University of Glasgow 1997-2003 ---- --- The GHC grammar. --- --- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 --- --------------------------------------------------------------------------- - -{ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module provides the generated Happy parser for Haskell. It exports --- a number of parsers which may be used in any library that uses the GHC API. --- A common usage pattern is to initialize the parser state with a given string --- and then parse that string: --- --- @ --- runParser :: DynFlags -> String -> P a -> ParseResult a --- runParser flags str parser = unP parser parseState --- where --- filename = "\" --- location = mkRealSrcLoc (mkFastString filename) 1 1 --- buffer = stringToStringBuffer str --- parseState = mkPState flags buffer location --- @ -module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack, - parseDeclaration, parseExpression, parsePattern, - parseTypeSignature, - parseStmt, parseIdentifier, - parseType, parseHeader) where - --- base -import Control.Monad ( unless, liftM, when, (<=<) ) -import GHC.Exts -import Data.Char -import Data.Maybe ( maybeToList ) -import Control.Monad ( mplus ) -import Control.Applicative ((<$)) -import qualified Prelude -- for happy-generated code - --- compiler/hsSyn -import GHC.Hs - --- compiler/main -import DriverPhases ( HscSource(..) ) -import HscTypes ( IsBootInterface, WarningTxt(..) ) -import DynFlags -import BkpSyn -import PackageConfig - --- compiler/utils -import OrdList -import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) -import FastString -import Maybes ( isJust, orElse ) -import Outputable - --- compiler/basicTypes -import RdrName -import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) -import DataCon ( DataCon, dataConName ) -import SrcLoc -import Module -import BasicTypes - --- compiler/types -import Type ( funTyCon ) -import Class ( FunDep ) - --- compiler/parser -import RdrHsSyn -import Lexer -import HaddockUtils -import ApiAnnotation - --- compiler/typecheck -import TcEvidence ( emptyTcEvBinds ) - --- compiler/prelude -import ForeignCall -import TysPrim ( eqPrimTyCon ) -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, - unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) - --- compiler/utils -import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) -import GhcPrelude -} - -%expect 236 -- shift/reduce conflicts - -{- Last updated: 04 June 2018 - -If you modify this parser and add a conflict, please update this comment. -You can learn more about the conflicts by passing 'happy' the -i flag: - - happy -agc --strict compiler/parser/Parser.y -idetailed-info - -How is this section formatted? Look up the state the conflict is -reported at, and copy the list of applicable rules (at the top, without the -rule numbers). Mark *** for the rule that is the conflicting reduction (that -is, the interpretation which is NOT taken). NB: Happy doesn't print a rule -in a state if it is empty, but you should include it in the list (you can -look these up in the Grammar section of the info file). - -Obviously the state numbers are not stable across modifications to the parser, -the idea is to reproduce enough information on each conflict so you can figure -out what happened if the states were renumbered. Try not to gratuitously move -productions around in this file. - -------------------------------------------------------------------------------- - -state 0 contains 1 shift/reduce conflicts. - - Conflicts: DOCNEXT (empty missing_module_keyword reduces) - -Ambiguity when the source file starts with "-- | doc". We need another -token of lookahead to determine if a top declaration or the 'module' keyword -follows. Shift parses as if the 'module' keyword follows. - -------------------------------------------------------------------------------- - -state 60 contains 1 shift/reduce conflict. - - context -> btype . - *** type -> btype . - type -> btype . '->' ctype - - Conflicts: '->' - -------------------------------------------------------------------------------- - -state 61 contains 47 shift/reduce conflicts. - - *** btype -> tyapps . - tyapps -> tyapps . tyapp - - Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' TYPEAPP - SIMPLEQUOTE VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM - STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE - and all the special ids. - -Example ambiguity: - 'if x then y else z :: F a' - -Shift parses as (per longest-parse rule): - 'if x then y else z :: (F a)' - -------------------------------------------------------------------------------- - -state 143 contains 15 shift/reduce conflicts. - - exp -> infixexp . '::' sigtype - exp -> infixexp . '-<' exp - exp -> infixexp . '>-' exp - exp -> infixexp . '-<<' exp - exp -> infixexp . '>>-' exp - *** exp -> infixexp . - infixexp -> infixexp . qop exp10 - - Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-' - '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM - -Examples of ambiguity: - 'if x then y else z -< e' - 'if x then y else z :: T' - 'if x then y else z + 1' (NB: '+' is in VARSYM) - -Shift parses as (per longest-parse rule): - 'if x then y else (z -< T)' - 'if x then y else (z :: T)' - 'if x then y else (z + 1)' - -------------------------------------------------------------------------------- - -state 148 contains 67 shift/reduce conflicts. - - *** exp10 -> fexp . - fexp -> fexp . aexp - fexp -> fexp . TYPEAPP atype - - Conflicts: TYPEAPP and all the tokens that can start an aexp - -Examples of ambiguity: - 'if x then y else f z' - 'if x then y else f @ z' - -Shift parses as (per longest-parse rule): - 'if x then y else (f z)' - 'if x then y else (f @ z)' - -------------------------------------------------------------------------------- - -state 203 contains 27 shift/reduce conflicts. - - aexp2 -> TH_TY_QUOTE . tyvar - aexp2 -> TH_TY_QUOTE . gtycon - *** aexp2 -> TH_TY_QUOTE . - - Conflicts: two single quotes is error syntax with specific error message. - -Example of ambiguity: - 'x = ''' - 'x = ''a' - 'x = ''T' - -Shift parses as (per longest-parse rule): - 'x = ''a' - 'x = ''T' - -------------------------------------------------------------------------------- - -state 299 contains 1 shift/reduce conflicts. - - rule -> STRING . rule_activation rule_forall infixexp '=' exp - - Conflict: '[' (empty rule_activation reduces) - -We don't know whether the '[' starts the activation or not: it -might be the start of the declaration with the activation being -empty. --SDM 1/4/2002 - -Example ambiguity: - '{-# RULE [0] f = ... #-}' - -We parse this as having a [0] rule activation for rewriting 'f', rather -a rule instructing how to rewrite the expression '[0] f'. - -------------------------------------------------------------------------------- - -state 309 contains 1 shift/reduce conflict. - - *** type -> btype . - type -> btype . '->' ctype - - Conflict: '->' - -Same as state 61 but without contexts. - -------------------------------------------------------------------------------- - -state 353 contains 1 shift/reduce conflicts. - - tup_exprs -> commas . tup_tail - sysdcon_nolist -> '(' commas . ')' - commas -> commas . ',' - - Conflict: ')' (empty tup_tail reduces) - -A tuple section with NO free variables '(,,)' is indistinguishable -from the Haskell98 data constructor for a tuple. Shift resolves in -favor of sysdcon, which is good because a tuple section will get rejected -if -XTupleSections is not specified. - -See also Note [ExplicitTuple] in GHC.Hs.Expr. - -------------------------------------------------------------------------------- - -state 408 contains 1 shift/reduce conflicts. - - tup_exprs -> commas . tup_tail - sysdcon_nolist -> '(#' commas . '#)' - commas -> commas . ',' - - Conflict: '#)' (empty tup_tail reduces) - -Same as State 354 for unboxed tuples. - -------------------------------------------------------------------------------- - -state 416 contains 67 shift/reduce conflicts. - - *** exp10 -> '-' fexp . - fexp -> fexp . aexp - fexp -> fexp . TYPEAPP atype - -Same as 149 but with a unary minus. - -------------------------------------------------------------------------------- - -state 481 contains 1 shift/reduce conflict. - - oqtycon -> '(' qtyconsym . ')' - *** qtyconop -> qtyconsym . - - Conflict: ')' - -Example ambiguity: 'foo :: (:%)' - -Shift means '(:%)' gets parsed as a type constructor, rather than than a -parenthesized infix type expression of length 1. - -------------------------------------------------------------------------------- - -state 678 contains 1 shift/reduce conflicts. - - *** aexp2 -> ipvar . - dbind -> ipvar . '=' exp - - Conflict: '=' - -Example ambiguity: 'let ?x ...' - -The parser can't tell whether the ?x is the lhs of a normal binding or -an implicit binding. Fortunately, resolving as shift gives it the only -sensible meaning, namely the lhs of an implicit binding. - -------------------------------------------------------------------------------- - -state 756 contains 1 shift/reduce conflicts. - - rule -> STRING rule_activation . rule_forall infixexp '=' exp - - Conflict: 'forall' (empty rule_forall reduces) - -Example ambiguity: '{-# RULES "name" forall = ... #-}' - -'forall' is a valid variable name---we don't know whether -to treat a forall on the input as the beginning of a quantifier -or the beginning of the rule itself. Resolving to shift means -it's always treated as a quantifier, hence the above is disallowed. -This saves explicitly defining a grammar for the rule lhs that -doesn't include 'forall'. - -------------------------------------------------------------------------------- - -state 992 contains 1 shift/reduce conflicts. - - transformqual -> 'then' 'group' . 'using' exp - transformqual -> 'then' 'group' . 'by' exp 'using' exp - *** special_id -> 'group' . - - Conflict: 'by' - -------------------------------------------------------------------------------- - -state 1089 contains 1 shift/reduce conflicts. - - rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.' - *** rule_foralls -> 'forall' rule_vars '.' . - - Conflict: 'forall' - -Example ambigutiy: '{-# RULES "name" forall a. forall ... #-}' - -Here the parser cannot tell whether the second 'forall' is the beginning of -a term-level quantifier, for example: - -'{-# RULES "name" forall a. forall x. id @a x = x #-}' - -or a valid variable named 'forall', for example a function @:: Int -> Int@ - -'{-# RULES "name" forall a. forall 0 = 0 #-}' - -Shift means the parser only allows the former. Also see conflict 753 above. - -------------------------------------------------------------------------------- - -state 1390 contains 1 shift/reduce conflict. - - *** atype -> tyvar . - tv_bndr -> '(' tyvar . '::' kind ')' - - Conflict: '::' - -Example ambiguity: 'class C a where type D a = ( a :: * ...' - -Here the parser cannot tell whether this is specifying a default for the -associated type like: - -'class C a where type D a = ( a :: * ); type D a' - -or it is an injectivity signature like: - -'class C a where type D a = ( r :: * ) | r -> a' - -Shift means the parser only allows the latter. - -------------------------------------------------------------------------------- --- API Annotations --- - -A lot of the productions are now cluttered with calls to -aa,am,ams,amms etc. - -These are helper functions to make sure that the locations of the -various keywords such as do / let / in are captured for use by tools -that want to do source to source conversions, such as refactorers or -structured editors. - -The helper functions are defined at the bottom of this file. - -See - https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and - https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations -for some background. - -If you modify the parser and want to ensure that the API annotations are processed -correctly, see the README in (REPO)/utils/check-api-annotations for details on -how to set up a test using the check-api-annotations utility, and interpret the -output it generates. - -Note [Parsing lists] ---------------------- -You might be wondering why we spend so much effort encoding our lists this -way: - -importdecls - : importdecls ';' importdecl - | importdecls ';' - | importdecl - | {- empty -} - -This might seem like an awfully roundabout way to declare a list; plus, to add -insult to injury you have to reverse the results at the end. The answer is that -left recursion prevents us from running out of stack space when parsing long -sequences. See: https://www.haskell.org/happy/doc/html/sec-sequences.html for -more guidance. - -By adding/removing branches, you can affect what lists are accepted. Here -are the most common patterns, rewritten as regular expressions for clarity: - - -- Equivalent to: ';'* (x ';'+)* x? (can be empty, permits leading/trailing semis) - xs : xs ';' x - | xs ';' - | x - | {- empty -} - - -- Equivalent to x (';' x)* ';'* (non-empty, permits trailing semis) - xs : xs ';' x - | xs ';' - | x - - -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis) - alts : alts1 - | ';' alts - alts1 : alts1 ';' alt - | alts1 ';' - | alt - - -- Equivalent to x (',' x)+ (non-empty, no trailing semis) - xs : x - | x ',' xs - --- ----------------------------------------------------------------------------- - --} - -%token - '_' { L _ ITunderscore } -- Haskell keywords - 'as' { L _ ITas } - 'case' { L _ ITcase } - 'class' { L _ ITclass } - 'data' { L _ ITdata } - 'default' { L _ ITdefault } - 'deriving' { L _ ITderiving } - 'do' { L _ ITdo } - 'else' { L _ ITelse } - 'hiding' { L _ IThiding } - 'if' { L _ ITif } - 'import' { L _ ITimport } - 'in' { L _ ITin } - 'infix' { L _ ITinfix } - 'infixl' { L _ ITinfixl } - 'infixr' { L _ ITinfixr } - 'instance' { L _ ITinstance } - 'let' { L _ ITlet } - 'module' { L _ ITmodule } - 'newtype' { L _ ITnewtype } - 'of' { L _ ITof } - 'qualified' { L _ ITqualified } - 'then' { L _ ITthen } - 'type' { L _ ITtype } - 'where' { L _ ITwhere } - - 'forall' { L _ (ITforall _) } -- GHC extension keywords - 'foreign' { L _ ITforeign } - 'export' { L _ ITexport } - 'label' { L _ ITlabel } - 'dynamic' { L _ ITdynamic } - 'safe' { L _ ITsafe } - 'interruptible' { L _ ITinterruptible } - 'unsafe' { L _ ITunsafe } - 'mdo' { L _ ITmdo } - 'family' { L _ ITfamily } - 'role' { L _ ITrole } - 'stdcall' { L _ ITstdcallconv } - 'ccall' { L _ ITccallconv } - 'capi' { L _ ITcapiconv } - 'prim' { L _ ITprimcallconv } - 'javascript' { L _ ITjavascriptcallconv } - 'proc' { L _ ITproc } -- for arrow notation extension - 'rec' { L _ ITrec } -- for arrow notation extension - 'group' { L _ ITgroup } -- for list transform extension - 'by' { L _ ITby } -- for list transform extension - 'using' { L _ ITusing } -- for list transform extension - 'pattern' { L _ ITpattern } -- for pattern synonyms - 'static' { L _ ITstatic } -- for static pointers extension - 'stock' { L _ ITstock } -- for DerivingStrategies extension - 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension - 'via' { L _ ITvia } -- for DerivingStrategies extension - - 'unit' { L _ ITunit } - 'signature' { L _ ITsignature } - 'dependency' { L _ ITdependency } - - '{-# INLINE' { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE - '{-# SPECIALISE' { L _ (ITspec_prag _) } - '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) } - '{-# SOURCE' { L _ (ITsource_prag _) } - '{-# RULES' { L _ (ITrules_prag _) } - '{-# CORE' { L _ (ITcore_prag _) } -- hdaume: annotated core - '{-# SCC' { L _ (ITscc_prag _)} - '{-# GENERATED' { L _ (ITgenerated_prag _) } - '{-# DEPRECATED' { L _ (ITdeprecated_prag _) } - '{-# WARNING' { L _ (ITwarning_prag _) } - '{-# UNPACK' { L _ (ITunpack_prag _) } - '{-# NOUNPACK' { L _ (ITnounpack_prag _) } - '{-# ANN' { L _ (ITann_prag _) } - '{-# MINIMAL' { L _ (ITminimal_prag _) } - '{-# CTYPE' { L _ (ITctype _) } - '{-# OVERLAPPING' { L _ (IToverlapping_prag _) } - '{-# OVERLAPPABLE' { L _ (IToverlappable_prag _) } - '{-# OVERLAPS' { L _ (IToverlaps_prag _) } - '{-# INCOHERENT' { L _ (ITincoherent_prag _) } - '{-# COMPLETE' { L _ (ITcomplete_prag _) } - '#-}' { L _ ITclose_prag } - - '..' { L _ ITdotdot } -- reserved symbols - ':' { L _ ITcolon } - '::' { L _ (ITdcolon _) } - '=' { L _ ITequal } - '\\' { L _ ITlam } - 'lcase' { L _ ITlcase } - '|' { L _ ITvbar } - '<-' { L _ (ITlarrow _) } - '->' { L _ (ITrarrow _) } - '@' { L _ ITat } - '~' { L _ ITtilde } - '=>' { L _ (ITdarrow _) } - '-' { L _ ITminus } - '!' { L _ ITbang } - '*' { L _ (ITstar _) } - '-<' { L _ (ITlarrowtail _) } -- for arrow notation - '>-' { L _ (ITrarrowtail _) } -- for arrow notation - '-<<' { L _ (ITLarrowtail _) } -- for arrow notation - '>>-' { L _ (ITRarrowtail _) } -- for arrow notation - '.' { L _ ITdot } - TYPEAPP { L _ ITtypeApp } - - '{' { L _ ITocurly } -- special symbols - '}' { L _ ITccurly } - vocurly { L _ ITvocurly } -- virtual open curly (from layout) - vccurly { L _ ITvccurly } -- virtual close curly (from layout) - '[' { L _ ITobrack } - ']' { L _ ITcbrack } - '[:' { L _ ITopabrack } - ':]' { L _ ITcpabrack } - '(' { L _ IToparen } - ')' { L _ ITcparen } - '(#' { L _ IToubxparen } - '#)' { L _ ITcubxparen } - '(|' { L _ (IToparenbar _) } - '|)' { L _ (ITcparenbar _) } - ';' { L _ ITsemi } - ',' { L _ ITcomma } - '`' { L _ ITbackquote } - SIMPLEQUOTE { L _ ITsimpleQuote } -- 'x - - VARID { L _ (ITvarid _) } -- identifiers - CONID { L _ (ITconid _) } - VARSYM { L _ (ITvarsym _) } - CONSYM { L _ (ITconsym _) } - QVARID { L _ (ITqvarid _) } - QCONID { L _ (ITqconid _) } - QVARSYM { L _ (ITqvarsym _) } - QCONSYM { L _ (ITqconsym _) } - - IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension - LABELVARID { L _ (ITlabelvarid _) } - - CHAR { L _ (ITchar _ _) } - STRING { L _ (ITstring _ _) } - INTEGER { L _ (ITinteger _) } - RATIONAL { L _ (ITrational _) } - - PRIMCHAR { L _ (ITprimchar _ _) } - PRIMSTRING { L _ (ITprimstring _ _) } - PRIMINTEGER { L _ (ITprimint _ _) } - PRIMWORD { L _ (ITprimword _ _) } - PRIMFLOAT { L _ (ITprimfloat _) } - PRIMDOUBLE { L _ (ITprimdouble _) } - - DOCNEXT { L _ (ITdocCommentNext _) } - DOCPREV { L _ (ITdocCommentPrev _) } - DOCNAMED { L _ (ITdocCommentNamed _) } - DOCSECTION { L _ (ITdocSection _ _) } - --- Template Haskell -'[|' { L _ (ITopenExpQuote _ _) } -'[p|' { L _ ITopenPatQuote } -'[t|' { L _ ITopenTypQuote } -'[d|' { L _ ITopenDecQuote } -'|]' { L _ (ITcloseQuote _) } -'[||' { L _ (ITopenTExpQuote _) } -'||]' { L _ ITcloseTExpQuote } -TH_ID_SPLICE { L _ (ITidEscape _) } -- $x -'$(' { L _ ITparenEscape } -- $( exp ) -TH_ID_TY_SPLICE { L _ (ITidTyEscape _) } -- $$x -'$$(' { L _ ITparenTyEscape } -- $$( exp ) -TH_TY_QUOTE { L _ ITtyQuote } -- ''T -TH_QUASIQUOTE { L _ (ITquasiQuote _) } -TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } - -%monad { P } { >>= } { return } -%lexer { (lexer True) } { L _ ITeof } -%tokentype { (Located Token) } - --- Exported parsers -%name parseModule module -%name parseSignature signature -%name parseImport importdecl -%name parseStatement e_stmt -%name parseDeclaration topdecl -%name parseExpression exp -%name parsePattern pat -%name parseTypeSignature sigdecl -%name parseStmt maybe_stmt -%name parseIdentifier identifier -%name parseType ktype -%name parseBackpack backpack -%partial parseHeader header -%% - ------------------------------------------------------------------------------ --- Identifiers; one of the entry points -identifier :: { Located RdrName } - : qvar { $1 } - | qcon { $1 } - | qvarop { $1 } - | qconop { $1 } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) - [mop $1,mu AnnRarrow $2,mcp $3] } - | '->' {% ams (sLL $1 $> $ getRdrName funTyCon) - [mu AnnRarrow $1] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) - [mop $1,mj AnnTilde $2,mcp $3] } - ------------------------------------------------------------------------------ --- Backpack stuff - -backpack :: { [LHsUnit PackageName] } - : implicit_top units close { fromOL $2 } - | '{' units '}' { fromOL $2 } - -units :: { OrdList (LHsUnit PackageName) } - : units ';' unit { $1 `appOL` unitOL $3 } - | units ';' { $1 } - | unit { unitOL $1 } - -unit :: { LHsUnit PackageName } - : 'unit' pkgname 'where' unitbody - { sL1 $1 $ HsUnit { hsunitName = $2 - , hsunitBody = fromOL $4 } } - -unitid :: { LHsUnitId PackageName } - : pkgname { sL1 $1 $ HsUnitId $1 [] } - | pkgname '[' msubsts ']' { sLL $1 $> $ HsUnitId $1 (fromOL $3) } - -msubsts :: { OrdList (LHsModuleSubst PackageName) } - : msubsts ',' msubst { $1 `appOL` unitOL $3 } - | msubsts ',' { $1 } - | msubst { unitOL $1 } - -msubst :: { LHsModuleSubst PackageName } - : modid '=' moduleid { sLL $1 $> $ ($1, $3) } - | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) } - -moduleid :: { LHsModuleId PackageName } - : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 } - | unitid ':' modid { sLL $1 $> $ HsModuleId $1 $3 } - -pkgname :: { Located PackageName } - : STRING { sL1 $1 $ PackageName (getSTRING $1) } - | litpkgname { sL1 $1 $ PackageName (unLoc $1) } - -litpkgname_segment :: { Located FastString } - : VARID { sL1 $1 $ getVARID $1 } - | CONID { sL1 $1 $ getCONID $1 } - | special_id { $1 } - -litpkgname :: { Located FastString } - : litpkgname_segment { $1 } - -- a bit of a hack, means p - b is parsed same as p-b, enough for now. - | litpkgname_segment '-' litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) } - -mayberns :: { Maybe [LRenaming] } - : {- empty -} { Nothing } - | '(' rns ')' { Just (fromOL $2) } - -rns :: { OrdList LRenaming } - : rns ',' rn { $1 `appOL` unitOL $3 } - | rns ',' { $1 } - | rn { unitOL $1 } - -rn :: { LRenaming } - : modid 'as' modid { sLL $1 $> $ Renaming $1 (Just $3) } - | modid { sL1 $1 $ Renaming $1 Nothing } - -unitbody :: { OrdList (LHsUnitDecl PackageName) } - : '{' unitdecls '}' { $2 } - | vocurly unitdecls close { $2 } - -unitdecls :: { OrdList (LHsUnitDecl PackageName) } - : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 } - | unitdecls ';' { $1 } - | unitdecl { unitOL $1 } - -unitdecl :: { LHsUnitDecl PackageName } - : maybedocheader 'module' maybe_src modid maybemodwarning maybeexports 'where' body - -- XXX not accurate - { sL1 $2 $ DeclD - (case snd $3 of - False -> HsSrcFile - True -> HsBootFile) - $4 - (Just $ sL1 $2 (HsModule (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) } - | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body - { sL1 $2 $ DeclD - HsigFile - $3 - (Just $ sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1)) } - -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict - -- will prevent us from parsing both forms. - | maybedocheader 'module' maybe_src modid - { sL1 $2 $ DeclD (case snd $3 of - False -> HsSrcFile - True -> HsBootFile) $4 Nothing } - | maybedocheader 'signature' modid - { sL1 $2 $ DeclD HsigFile $3 Nothing } - | 'dependency' unitid mayberns - { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 - , idModRenaming = $3 - , idSignatureInclude = False }) } - | 'dependency' 'signature' unitid - { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3 - , idModRenaming = Nothing - , idSignatureInclude = True }) } - ------------------------------------------------------------------------------ --- Module Header - --- The place for module deprecation is really too restrictive, but if it --- was allowed at its natural place just before 'module', we get an ugly --- s/r conflict with the second alternative. Another solution would be the --- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, --- either, and DEPRECATED is only expected to be used by people who really --- know what they are doing. :-) - -signature :: { Located (HsModule GhcPs) } - : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body - {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) - (snd $ snd $7) $4 $1) - ) - ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } - -module :: { Located (HsModule GhcPs) } - : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body - {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) - (snd $ snd $7) $4 $1) - ) - ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } - | body2 - {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule Nothing Nothing - (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) - (fst $1) } - -maybedocheader :: { Maybe LHsDocString } - : moduleheader { $1 } - | {- empty -} { Nothing } - -missing_module_keyword :: { () } - : {- empty -} {% pushModuleContext } - -implicit_top :: { () } - : {- empty -} {% pushModuleContext } - -maybemodwarning :: { Maybe (Located WarningTxt) } - : '{-# DEPRECATED' strings '#-}' - {% ajs (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2)) - (mo $1:mc $3: (fst $ unLoc $2)) } - | '{-# WARNING' strings '#-}' - {% ajs (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2)) - (mo $1:mc $3 : (fst $ unLoc $2)) } - | {- empty -} { Nothing } - -body :: { ([AddAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } - : '{' top '}' { (moc $1:mcc $3:(fst $2) - , snd $2) } - | vocurly top close { (fst $2, snd $2) } - -body2 :: { ([AddAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } - : '{' top '}' { (moc $1:mcc $3 - :(fst $2), snd $2) } - | missing_module_keyword top close { ([],snd $2) } - - -top :: { ([AddAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } - : semis top1 { ($1, $2) } - -top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } - : importdecls_semi topdecls_semi { (reverse $1, cvTopDecls $2) } - | importdecls_semi topdecls { (reverse $1, cvTopDecls $2) } - | importdecls { (reverse $1, []) } - ------------------------------------------------------------------------------ --- Module declaration & imports only - -header :: { Located (HsModule GhcPs) } - : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body - {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 - )) [mj AnnModule $2,mj AnnWhere $6] } - | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body - {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 - )) [mj AnnModule $2,mj AnnWhere $6] } - | header_body2 - {% fileSrcSpan >>= \ loc -> - return (cL loc (HsModule Nothing Nothing $1 [] Nothing - Nothing)) } - -header_body :: { [LImportDecl GhcPs] } - : '{' header_top { $2 } - | vocurly header_top { $2 } - -header_body2 :: { [LImportDecl GhcPs] } - : '{' header_top { $2 } - | missing_module_keyword header_top { $2 } - -header_top :: { [LImportDecl GhcPs] } - : semis header_top_importdecls { $2 } - -header_top_importdecls :: { [LImportDecl GhcPs] } - : importdecls_semi { $1 } - | importdecls { $1 } - ------------------------------------------------------------------------------ --- The Export List - -maybeexports :: { (Maybe (Located [LIE GhcPs])) } - : '(' exportlist ')' {% amsL (comb2 $1 $>) [mop $1,mcp $3] >> - return (Just (sLL $1 $> (fromOL $2))) } - | {- empty -} { Nothing } - -exportlist :: { OrdList (LIE GhcPs) } - : expdoclist ',' expdoclist {% addAnnotation (oll $1) AnnComma (gl $2) - >> return ($1 `appOL` $3) } - | exportlist1 { $1 } - -exportlist1 :: { OrdList (LIE GhcPs) } - : expdoclist export expdoclist ',' exportlist1 - {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3)) - AnnComma (gl $4) ) >> - return ($1 `appOL` $2 `appOL` $3 `appOL` $5) } - | expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 } - | expdoclist { $1 } - -expdoclist :: { OrdList (LIE GhcPs) } - : exp_doc expdoclist { $1 `appOL` $2 } - | {- empty -} { nilOL } - -exp_doc :: { OrdList (LIE GhcPs) } - : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup noExtField n doc)) } - | docnamed { unitOL (sL1 $1 (IEDocNamed noExtField ((fst . unLoc) $1))) } - | docnext { unitOL (sL1 $1 (IEDoc noExtField (unLoc $1))) } - - - -- No longer allow things like [] and (,,,) to be exported - -- They are built in syntax, always available -export :: { OrdList (LIE GhcPs) } - : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) - >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } - | 'module' modid {% amsu (sLL $1 $> (IEModuleContents noExtField $2)) - [mj AnnModule $1] } - | 'pattern' qcon {% amsu (sLL $1 $> (IEVar noExtField (sLL $1 $> (IEPattern $2)))) - [mj AnnPattern $1] } - -export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } - : {- empty -} { sL0 ([],ImpExpAbs) } - | '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2)) - >>= \(as,ie) -> return $ sLL $1 $> - (as ++ [mop $1,mcp $3] ++ fst $2, ie) } - - -qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } - : {- empty -} { ([],[]) } - | qcnames1 { $1 } - -qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list - : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(dL->L _ ImpExpQcWildcard) -> - return ([mj AnnComma $2, mj AnnDotdot l] - ,(snd (unLoc $3) : snd $1)) - l -> (ams (head (snd $1)) [mj AnnComma $2] >> - return (fst $1 ++ fst (unLoc $3), - snd (unLoc $3) : snd $1)) } - - - -- Annotations re-added in mkImpExpSubSpec - | qcname_ext_w_wildcard { (fst (unLoc $1),[snd (unLoc $1)]) } - --- Variable, data constructor or wildcard --- or tagged type constructor -qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) } - : qcname_ext { sL1 $1 ([],$1) } - | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) } - -qcname_ext :: { Located ImpExpQcSpec } - : qcname { sL1 $1 (ImpExpQcName $1) } - | 'type' oqtycon {% do { n <- mkTypeImpExp $2 - ; ams (sLL $1 $> (ImpExpQcType n)) - [mj AnnType $1] } } - -qcname :: { Located RdrName } -- Variable or type constructor - : qvar { $1 } -- Things which look like functions - -- Note: This includes record selectors but - -- also (-.->), see #11432 - | oqtycon_no_varcon { $1 } -- see Note [Type constructors in export list] - ------------------------------------------------------------------------------ --- Import Declarations - --- importdecls and topdecls must contain at least one declaration; --- top handles the fact that these may be optional. - --- One or more semicolons -semis1 :: { [AddAnn] } -semis1 : semis1 ';' { mj AnnSemi $2 : $1 } - | ';' { [mj AnnSemi $1] } - --- Zero or more semicolons -semis :: { [AddAnn] } -semis : semis ';' { mj AnnSemi $2 : $1 } - | {- empty -} { [] } - --- No trailing semicolons, non-empty -importdecls :: { [LImportDecl GhcPs] } -importdecls - : importdecls_semi importdecl - { $2 : $1 } - --- May have trailing semicolons, can be empty -importdecls_semi :: { [LImportDecl GhcPs] } -importdecls_semi - : importdecls_semi importdecl semis1 - {% ams $2 $3 >> return ($2 : $1) } - | {- empty -} { [] } - -importdecl :: { LImportDecl GhcPs } - : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec - {% do { - ; let { ; mPreQual = unLoc $4 - ; mPostQual = unLoc $7 } - ; checkImportDecl mPreQual mPostQual - ; ams (cL (comb5 $1 $6 $7 (snd $8) $9) $ - ImportDecl { ideclExt = noExtField - , ideclSourceSrc = snd $ fst $2 - , ideclName = $6, ideclPkgQual = snd $5 - , ideclSource = snd $2, ideclSafe = snd $3 - , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual - , ideclImplicit = False - , ideclAs = unLoc (snd $8) - , ideclHiding = unLoc $9 }) - (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList mPreQual) - ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst $8) - } - } - - -maybe_src :: { (([AddAnn],SourceText),IsBootInterface) } - : '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1) - , True) } - | {- empty -} { (([],NoSourceText),False) } - -maybe_safe :: { ([AddAnn],Bool) } - : 'safe' { ([mj AnnSafe $1],True) } - | {- empty -} { ([],False) } - -maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } - : STRING {% do { let { pkgFS = getSTRING $1 } - ; unless (looksLikePackageName (unpackFS pkgFS)) $ - addError (getLoc $1) $ vcat [ - text "Parse error" <> colon <+> quotes (ppr pkgFS), - text "Version number or non-alphanumeric" <+> - text "character in package name"] - ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } } - | {- empty -} { ([],Nothing) } - -optqualified :: { Located (Maybe (Located Token)) } - : 'qualified' { sL1 $1 (Just $1) } - | {- empty -} { noLoc Nothing } - -maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) } - : 'as' modid { ([mj AnnAs $1] - ,sLL $1 $> (Just $2)) } - | {- empty -} { ([],noLoc Nothing) } - -maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } - : impspec {% let (b, ie) = unLoc $1 in - checkImportSpec ie - >>= \checkedIe -> - return (cL (gl $1) (Just (b, checkedIe))) } - | {- empty -} { noLoc Nothing } - -impspec :: { Located (Bool, Located [LIE GhcPs]) } - : '(' exportlist ')' {% ams (sLL $1 $> (False, - sLL $1 $> $ fromOL $2)) - [mop $1,mcp $3] } - | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True, - sLL $1 $> $ fromOL $3)) - [mj AnnHiding $1,mop $2,mcp $4] } - ------------------------------------------------------------------------------ --- Fixity Declarations - -prec :: { Located (SourceText,Int) } - : {- empty -} { noLoc (NoSourceText,9) } - | INTEGER - { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) } - -infix :: { Located FixityDirection } - : 'infix' { sL1 $1 InfixN } - | 'infixl' { sL1 $1 InfixL } - | 'infixr' { sL1 $1 InfixR } - -ops :: { Located (OrdList (Located RdrName)) } - : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))} - | op { sL1 $1 (unitOL $1) } - ------------------------------------------------------------------------------ --- Top-Level Declarations - --- No trailing semicolons, non-empty -topdecls :: { OrdList (LHsDecl GhcPs) } - : topdecls_semi topdecl { $1 `snocOL` $2 } - --- May have trailing semicolons, can be empty -topdecls_semi :: { OrdList (LHsDecl GhcPs) } - : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) } - | {- empty -} { nilOL } - -topdecl :: { LHsDecl GhcPs } - : cl_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } - | ty_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } - | standalone_kind_sig { sL1 $1 (KindSigD noExtField (unLoc $1)) } - | inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) } - | stand_alone_deriving { sLL $1 $> (DerivD noExtField (unLoc $1)) } - | role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) } - | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD noExtField (DefaultDecl noExtField $3))) - [mj AnnDefault $1 - ,mop $2,mcp $4] } - | 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2)) - (mj AnnForeign $1:(fst $ unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getDEPRECATED_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getWARNING_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD noExtField (HsRules noExtField (getRULES_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | annotation { $1 } - | decl_no_th { $1 } - - -- Template Haskell Extension - -- The $(..) form is one possible form of infixexp - -- but we treat an arbitrary expression just as if - -- it had a $(..) wrapped around it - | infixexp_top {% runECP_P $1 >>= \ $1 -> - return $ sLL $1 $> $ mkSpliceDecl $1 } - --- Type classes --- -cl_decl :: { LTyClDecl GhcPs } - : 'class' tycl_hdr fds where_cls - {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)) - (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) } - --- Type declarations (toplevel) --- -ty_decl :: { LTyClDecl GhcPs } - -- ordinary type synonyms - : 'type' type '=' ktypedoc - -- Note ktypedoc, not sigtype, on the right of '=' - -- We allow an explicit for-all but we don't insert one - -- in type Foo a = (b,b) - -- Instead we just say b is out of scope - -- - -- Note the use of type for the head; this allows - -- infix type constructors to be declared - {% amms (mkTySynonym (comb2 $1 $4) $2 $4) - [mj AnnType $1,mj AnnEqual $3] } - - -- type family declarations - | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info - where_type_family - -- Note the use of type for the head; this allows - -- infix type constructors to be declared - {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3 - (snd $ unLoc $4) (snd $ unLoc $5)) - (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4) - ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } - - -- ordinary data type or newtype declaration - | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings - {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 - Nothing (reverse (snd $ unLoc $4)) - (fmap reverse $5)) - -- We need the location on tycl_hdr in case - -- constrs and deriving are both empty - ((fst $ unLoc $1):(fst $ unLoc $4)) } - - -- ordinary GADT declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig - gadt_constrlist - maybe_derivings - {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 - (snd $ unLoc $4) (snd $ unLoc $5) - (fmap reverse $6) ) - -- We need the location on tycl_hdr in case - -- constrs and deriving are both empty - ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } - - -- data/newtype family - | 'data' 'family' type opt_datafam_kind_sig - {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 - (snd $ unLoc $4) Nothing) - (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } - --- standalone kind signature -standalone_kind_sig :: { LStandaloneKindSig GhcPs } - : 'type' sks_vars '::' ktypedoc - {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4) - [mj AnnType $1,mu AnnDcolon $3] } - --- See also: sig_vars -sks_vars :: { Located [Located RdrName] } -- Returned in reverse order - : sks_vars ',' oqtycon - {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | oqtycon { sL1 $1 [$1] } - -inst_decl :: { LInstDecl GhcPs } - : 'instance' overlap_pragma inst_type where_inst - {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) - ; let cid = ClsInstDecl { cid_ext = noExtField - , cid_poly_ty = $3, cid_binds = binds - , cid_sigs = mkClassOpSigs sigs - , cid_tyfam_insts = ats - , cid_overlap_mode = $2 - , cid_datafam_insts = adts } - ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) - (mj AnnInstance $1 : (fst $ unLoc $4)) } } - - -- type instance declarations - | 'type' 'instance' ty_fam_inst_eqn - {% ams $3 (fst $ unLoc $3) - >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) - (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } - - -- data/newtype instance declaration - | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs - maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4) - Nothing (reverse (snd $ unLoc $5)) - (fmap reverse $6)) - ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) } - - -- GADT instance declaration - | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig - gadt_constrlist - maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4) - (snd $ unLoc $5) (snd $ unLoc $6) - (fmap reverse $7)) - ((fst $ unLoc $1):mj AnnInstance $2 - :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) } - -overlap_pragma :: { Maybe (Located OverlapMode) } - : '{-# OVERLAPPABLE' '#-}' {% ajs (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) - [mo $1,mc $2] } - | '{-# OVERLAPPING' '#-}' {% ajs (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) - [mo $1,mc $2] } - | '{-# OVERLAPS' '#-}' {% ajs (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) - [mo $1,mc $2] } - | '{-# INCOHERENT' '#-}' {% ajs (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) - [mo $1,mc $2] } - | {- empty -} { Nothing } - -deriv_strategy_no_via :: { LDerivStrategy GhcPs } - : 'stock' {% ams (sL1 $1 StockStrategy) - [mj AnnStock $1] } - | 'anyclass' {% ams (sL1 $1 AnyclassStrategy) - [mj AnnAnyclass $1] } - | 'newtype' {% ams (sL1 $1 NewtypeStrategy) - [mj AnnNewtype $1] } - -deriv_strategy_via :: { LDerivStrategy GhcPs } - : 'via' type {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2))) - [mj AnnVia $1] } - -deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } - : 'stock' {% ajs (sL1 $1 StockStrategy) - [mj AnnStock $1] } - | 'anyclass' {% ajs (sL1 $1 AnyclassStrategy) - [mj AnnAnyclass $1] } - | 'newtype' {% ajs (sL1 $1 NewtypeStrategy) - [mj AnnNewtype $1] } - | deriv_strategy_via { Just $1 } - | {- empty -} { Nothing } - --- Injective type families - -opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn GhcPs)) } - : {- empty -} { noLoc ([], Nothing) } - | '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1] - , Just ($2)) } - -injectivity_cond :: { LInjectivityAnn GhcPs } - : tyvarid '->' inj_varids - {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3)))) - [mu AnnRarrow $2] } - -inj_varids :: { Located [Located RdrName] } - : inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) } - | tyvarid { sLL $1 $> [$1] } - --- Closed type families - -where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) } - : {- empty -} { noLoc ([],OpenTypeFamily) } - | 'where' ty_fam_inst_eqn_list - { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) - ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) } - -ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } - : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] - ,Just (unLoc $2)) } - | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in - cL loc ([],Just (unLoc $2)) } - | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 - ,mcc $3],Nothing) } - | vocurly '..' close { let (dL->L loc _) = $2 in - cL loc ([mj AnnDotdot $2],Nothing) } - -ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } - : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% let (dL->L loc (anns, eqn)) = $3 in - asl (unLoc $1) $2 (cL loc eqn) - >> ams $3 anns - >> return (sLL $1 $> (cL loc eqn : unLoc $1)) } - | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in - ams $1 anns - >> return (sLL $1 $> [cL loc eqn]) } - | {- empty -} { noLoc [] } - -ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } - : 'forall' tv_bndrs '.' type '=' ktype - {% do { hintExplicitForall $1 - ; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6 - ; return (sLL $1 $> - (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } } - | type '=' ktype - {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3 - ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } } - -- Note the use of type for the head; this allows - -- infix type constructors and type patterns - --- Associated type family declarations --- --- * They have a different syntax than on the toplevel (no family special --- identifier). --- --- * They also need to be separate from instances; otherwise, data family --- declarations without a kind signature cause parsing conflicts with empty --- data declarations. --- -at_decl_cls :: { LHsDecl GhcPs } - : -- data family declarations, with optional 'family' keyword - 'data' opt_family type opt_datafam_kind_sig - {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 - (snd $ unLoc $4) Nothing)) - (mj AnnData $1:$2++(fst $ unLoc $4)) } - - -- type family declarations, with optional 'family' keyword - -- (can't use opt_instance because you get shift/reduce errors - | 'type' type opt_at_kind_inj_sig - {% amms (liftM mkTyClD - (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 - (fst . snd $ unLoc $3) - (snd . snd $ unLoc $3))) - (mj AnnType $1:(fst $ unLoc $3)) } - | 'type' 'family' type opt_at_kind_inj_sig - {% amms (liftM mkTyClD - (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 - (fst . snd $ unLoc $4) - (snd . snd $ unLoc $4))) - (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) } - - -- default type instances, with optional 'instance' keyword - | 'type' ty_fam_inst_eqn - {% ams $2 (fst $ unLoc $2) >> - amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))) - (mj AnnType $1:(fst $ unLoc $2)) } - | 'type' 'instance' ty_fam_inst_eqn - {% ams $3 (fst $ unLoc $3) >> - amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))) - (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } - -opt_family :: { [AddAnn] } - : {- empty -} { [] } - | 'family' { [mj AnnFamily $1] } - -opt_instance :: { [AddAnn] } - : {- empty -} { [] } - | 'instance' { [mj AnnInstance $1] } - --- Associated type instances --- -at_decl_inst :: { LInstDecl GhcPs } - -- type instance declarations, with optional 'instance' keyword - : 'type' opt_instance ty_fam_inst_eqn - -- Note the use of type for the head; this allows - -- infix type constructors and type patterns - {% ams $3 (fst $ unLoc $3) >> - amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) - (mj AnnType $1:$2++(fst $ unLoc $3)) } - - -- data/newtype instance declaration, with optional 'instance' keyword - | data_or_newtype opt_instance capi_ctype tycl_hdr_inst constrs maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4) - Nothing (reverse (snd $ unLoc $5)) - (fmap reverse $6)) - ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) } - - -- GADT instance declaration, with optional 'instance' keyword - | data_or_newtype opt_instance capi_ctype tycl_hdr_inst opt_kind_sig - gadt_constrlist - maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 - (snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6) - (fmap reverse $7)) - ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) } - -data_or_newtype :: { Located (AddAnn, NewOrData) } - : 'data' { sL1 $1 (mj AnnData $1,DataType) } - | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } - --- Family result/return kind signatures - -opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) } - : { noLoc ([] , Nothing) } - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) } - -opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } - : { noLoc ([] , noLoc (NoSig noExtField) )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))} - -opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } - : { noLoc ([] , noLoc (NoSig noExtField) )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))} - | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExtField $2))} - -opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs - , Maybe (LInjectivityAnn GhcPs)))} - : { noLoc ([], (noLoc (NoSig noExtField), Nothing)) } - | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] - , (sLL $2 $> (KindSig noExtField $2), Nothing)) } - | '=' tv_bndr '|' injectivity_cond - { sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] - , (sLL $1 $2 (TyVarSig noExtField $2), Just $4))} - --- tycl_hdr parses the header of a class or data type decl, --- which takes the form --- T a b --- Eq a => T a --- (Eq a, Ord b) => T a b --- T Int [a] -- for associated types --- Rather a lot of inlining here, else we get reduce/reduce errors -tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) } - : context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> (return (sLL $1 $> (Just $1, $3))) - } - | type { sL1 $1 (Nothing, $1) } - -tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)) } - : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1 - >> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5) - >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] - , (Just $4, Just $2, $6))) - ) - } - | 'forall' tv_bndrs '.' type {% hintExplicitForall $1 - >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] - , (Nothing, Just $2, $4))) - } - | context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> (return (sLL $1 $>([], (Just $1, Nothing, $3)))) - } - | type { sL1 $1 ([], (Nothing, Nothing, $1)) } - - -capi_ctype :: { Maybe (Located CType) } -capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% ajs (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRINGs $3,getSTRING $3))) - [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] } - - | '{-# CTYPE' STRING '#-}' - {% ajs (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))) - [mo $1,mj AnnVal $2,mc $3] } - - | { Nothing } - ------------------------------------------------------------------------------ --- Stand-alone deriving - --- Glasgow extension: stand-alone deriving declarations -stand_alone_deriving :: { LDerivDecl GhcPs } - : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type - {% do { let { err = text "in the stand-alone deriving instance" - <> colon <+> quotes (ppr $5) } - ; ams (sLL $1 (hsSigType $>) - (DerivDecl noExtField (mkHsWildCardBndrs $5) $2 $4)) - [mj AnnDeriving $1, mj AnnInstance $3] } } - ------------------------------------------------------------------------------ --- Role annotations - -role_annot :: { LRoleAnnotDecl GhcPs } -role_annot : 'type' 'role' oqtycon maybe_roles - {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4))) - [mj AnnType $1,mj AnnRole $2] } - --- Reversed! -maybe_roles :: { Located [Located (Maybe FastString)] } -maybe_roles : {- empty -} { noLoc [] } - | roles { $1 } - -roles :: { Located [Located (Maybe FastString)] } -roles : role { sLL $1 $> [$1] } - | roles role { sLL $1 $> $ $2 : unLoc $1 } - --- read it in as a varid for better error messages -role :: { Located (Maybe FastString) } -role : VARID { sL1 $1 $ Just $ getVARID $1 } - | '_' { sL1 $1 Nothing } - --- Pattern synonyms - --- Glasgow extension: pattern synonyms -pattern_synonym_decl :: { LHsDecl GhcPs } - : 'pattern' pattern_synonym_lhs '=' pat - {% let (name, args,as ) = $2 in - ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 - ImplicitBidirectional) - (as ++ [mj AnnPattern $1, mj AnnEqual $3]) - } - - | 'pattern' pattern_synonym_lhs '<-' pat - {% let (name, args, as) = $2 in - ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional) - (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) } - - | 'pattern' pattern_synonym_lhs '<-' pat where_decls - {% do { let (name, args, as) = $2 - ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) - ; ams (sLL $1 $> . ValD noExtField $ - mkPatSynBind name args $4 (ExplicitBidirectional mg)) - (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) ) - }} - -pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) } - : con vars0 { ($1, PrefixCon $2, []) } - | varid conop varid { ($2, InfixCon $1 $3, []) } - | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) } - -vars0 :: { [Located RdrName] } - : {- empty -} { [] } - | varid vars0 { $1 : $2 } - -cvars1 :: { [RecordPatSynField (Located RdrName)] } - : var { [RecordPatSynField $1 $1] } - | var ',' cvars1 {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >> - return ((RecordPatSynField $1 $1) : $3 )} - -where_decls :: { Located ([AddAnn] - , Located (OrdList (LHsDecl GhcPs))) } - : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 - :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } - | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) - ,sL1 $3 (snd $ unLoc $3)) } - -pattern_synonym_sig :: { LSig GhcPs } - : 'pattern' con_list '::' sigtypedoc - {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) (mkLHsSigType $4)) - [mj AnnPattern $1, mu AnnDcolon $3] } - ------------------------------------------------------------------------------ --- Nested declarations - --- Declaration in class bodies --- -decl_cls :: { LHsDecl GhcPs } -decl_cls : at_decl_cls { $1 } - | decl { $1 } - - -- A 'default' signature used with the generic-programming extension - | 'default' infixexp '::' sigtypedoc - {% runECP_P $2 >>= \ $2 -> - do { v <- checkValSigLhs $2 - ; let err = text "in default signature" <> colon <+> - quotes (ppr $2) - ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $ mkLHsSigType $4) - [mj AnnDefault $1,mu AnnDcolon $3] } } - -decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed - : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - , unitOL $3)) - else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] - >> return (sLL $1 $> (fst $ unLoc $1 - ,(snd $ unLoc $1) `appOL` unitOL $3)) } - | decls_cls ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1)) - else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl_cls { sL1 $1 ([], unitOL $1) } - | {- empty -} { noLoc ([],nilOL) } - -decllist_cls - :: { Located ([AddAnn] - , OrdList (LHsDecl GhcPs)) } -- Reversed - : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,snd $ unLoc $2) } - | vocurly decls_cls close { $2 } - --- Class body --- -where_cls :: { Located ([AddAnn] - ,(OrdList (LHsDecl GhcPs))) } -- Reversed - -- No implicit parameters - -- May have type declarations - : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) - ,snd $ unLoc $2) } - | {- empty -} { noLoc ([],nilOL) } - --- Declarations in instance bodies --- -decl_inst :: { Located (OrdList (LHsDecl GhcPs)) } -decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) } - | decl { sLL $1 $> (unitOL $1) } - -decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed - : decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - , unLoc $3)) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return - (sLL $1 $> (fst $ unLoc $1 - ,(snd $ unLoc $1) `appOL` unLoc $3)) } - | decls_inst ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1)) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl_inst { sL1 $1 ([],unLoc $1) } - | {- empty -} { noLoc ([],nilOL) } - -decllist_inst - :: { Located ([AddAnn] - , OrdList (LHsDecl GhcPs)) } -- Reversed - : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } - | vocurly decls_inst close { cL (gl $2) (unLoc $2) } - --- Instance body --- -where_inst :: { Located ([AddAnn] - , OrdList (LHsDecl GhcPs)) } -- Reversed - -- No implicit parameters - -- May have type declarations - : 'where' decllist_inst { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) - ,(snd $ unLoc $2)) } - | {- empty -} { noLoc ([],nilOL) } - --- Declarations in binding groups other than classes and instances --- -decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } - : decls ';' decl {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - , unitOL $3)) - else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return ( - let { this = unitOL $3; - rest = snd $ unLoc $1; - these = rest `appOL` this } - in rest `seq` this `seq` these `seq` - (sLL $1 $> (fst $ unLoc $1,these))) } - | decls ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1))) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl { sL1 $1 ([], unitOL $1) } - | {- empty -} { noLoc ([],nilOL) } - -decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,sL1 $2 $ snd $ unLoc $2) } - | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } - --- Binding groups other than those of class and instance declarations --- -binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } - -- May have implicit parameters - -- No type declarations - : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) - ; return (sL1 $1 (fst $ unLoc $1 - ,sL1 $1 $ HsValBinds noExtField val_binds)) } } - - | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } - - | vocurly dbinds close { cL (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } - - -wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } - -- May have implicit parameters - -- No type declarations - : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2) - ,snd $ unLoc $2) } - | {- empty -} { noLoc ([],noLoc emptyLocalBinds) } - - ------------------------------------------------------------------------------ --- Transformation Rules - -rules :: { OrdList (LRuleDecl GhcPs) } - : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `snocOL` $3) } - | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } - | rule { unitOL $1 } - | {- empty -} { nilOL } - -rule :: { LRuleDecl GhcPs } - : STRING rule_activation rule_foralls infixexp '=' exp - {%runECP_P $4 >>= \ $4 -> - runECP_P $6 >>= \ $6 -> - ams (sLL $1 $> $ HsRule { rd_ext = noExtField - , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) - , rd_act = (snd $2) `orElse` AlwaysActive - , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 - , rd_lhs = $4, rd_rhs = $6 }) - (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) } - --- Rules can be specified to be NeverActive, unlike inline/specialize pragmas -rule_activation :: { ([AddAnn],Maybe Activation) } - : {- empty -} { ([],Nothing) } - | rule_explicit_activation { (fst $1,Just (snd $1)) } - -rule_explicit_activation :: { ([AddAnn] - ,Activation) } -- In brackets - : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] - ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } - | '[' '~' INTEGER ']' { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4] - ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } - | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3] - ,NeverActive) } - -rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs]) } - : 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2 - in hintExplicitForall $1 - >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2) - >> return ([mu AnnForall $1,mj AnnDot $3, - mu AnnForall $4,mj AnnDot $6], - Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) } - | 'forall' rule_vars '.' { ([mu AnnForall $1,mj AnnDot $3], - Nothing, mkRuleBndrs $2) } - | {- empty -} { ([], Nothing, []) } - -rule_vars :: { [LRuleTyTmVar] } - : rule_var rule_vars { $1 : $2 } - | {- empty -} { [] } - -rule_var :: { LRuleTyTmVar } - : varid { sLL $1 $> (RuleTyTmVar $1 Nothing) } - | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleTyTmVar $2 (Just $4))) - [mop $1,mu AnnDcolon $3,mcp $5] } - -{- Note [Parsing explicit foralls in Rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We really want the above definition of rule_foralls to be: - - rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.' - | 'forall' rule_vars '.' - | {- empty -} - -where rule_vars (term variables) can be named "forall", "family", or "role", -but tv_vars (type variables) cannot be. However, such a definition results -in a reduce/reduce conflict. For example, when parsing: -> {-# RULE "name" forall a ... #-} -before the '...' it is impossible to determine whether we should be in the -first or second case of the above. - -This is resolved by using rule_vars (which is more general) for both, and -ensuring that type-level quantified variables do not have the names "forall", -"family", or "role" in the function 'checkRuleTyVarBndrNames' in RdrHsSyn.hs -Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative -to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. --} - ------------------------------------------------------------------------------ --- Warnings and deprecations (c.f. rules) - -warnings :: { OrdList (LWarnDecl GhcPs) } - : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `appOL` $3) } - | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } - | warning { $1 } - | {- empty -} { nilOL } - --- SUP: TEMPORARY HACK, not checking for `module Foo' -warning :: { OrdList (LWarnDecl GhcPs) } - : namelist strings - {% amsu (sLL $1 $> (Warning noExtField (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) - (fst $ unLoc $2) } - -deprecations :: { OrdList (LWarnDecl GhcPs) } - : deprecations ';' deprecation - {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `appOL` $3) } - | deprecations ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } - | deprecation { $1 } - | {- empty -} { nilOL } - --- SUP: TEMPORARY HACK, not checking for `module Foo' -deprecation :: { OrdList (LWarnDecl GhcPs) } - : namelist strings - {% amsu (sLL $1 $> $ (Warning noExtField (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) - (fst $ unLoc $2) } - -strings :: { Located ([AddAnn],[Located StringLiteral]) } - : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) } - | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } - -stringlist :: { Located (OrdList (Located StringLiteral)) } - : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> (unLoc $1 `snocOL` - (cL (gl $3) (getStringLiteral $3)))) } - | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) } - | {- empty -} { noLoc nilOL } - ------------------------------------------------------------------------------ --- Annotations -annotation :: { LHsDecl GhcPs } - : '{-# ANN' name_var aexp '#-}' {% runECP_P $3 >>= \ $3 -> - ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField - (getANN_PRAGs $1) - (ValueAnnProvenance $2) $3)) - [mo $1,mc $4] } - - | '{-# ANN' 'type' tycon aexp '#-}' {% runECP_P $4 >>= \ $4 -> - ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField - (getANN_PRAGs $1) - (TypeAnnProvenance $3) $4)) - [mo $1,mj AnnType $2,mc $5] } - - | '{-# ANN' 'module' aexp '#-}' {% runECP_P $3 >>= \ $3 -> - ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField - (getANN_PRAGs $1) - ModuleAnnProvenance $3)) - [mo $1,mj AnnModule $2,mc $4] } - - ------------------------------------------------------------------------------ --- Foreign import and export declarations - -fdecl :: { Located ([AddAnn],HsDecl GhcPs) } -fdecl : 'import' callconv safety fspec - {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> - return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } - | 'import' callconv fspec - {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3); - return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }} - | 'export' callconv fspec - {% mkExport $2 (snd $ unLoc $3) >>= \i -> - return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) } - -callconv :: { Located CCallConv } - : 'stdcall' { sLL $1 $> StdCallConv } - | 'ccall' { sLL $1 $> CCallConv } - | 'capi' { sLL $1 $> CApiConv } - | 'prim' { sLL $1 $> PrimCallConv} - | 'javascript' { sLL $1 $> JavaScriptCallConv } - -safety :: { Located Safety } - : 'unsafe' { sLL $1 $> PlayRisky } - | 'safe' { sLL $1 $> PlaySafe } - | 'interruptible' { sLL $1 $> PlayInterruptible } - -fspec :: { Located ([AddAnn] - ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } - : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] - ,(cL (getLoc $1) - (getStringLiteral $1), $2, mkLHsSigType $4)) } - | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] - ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } - -- if the entity string is missing, it defaults to the empty string; - -- the meaning of an empty entity string depends on the calling - -- convention - ------------------------------------------------------------------------------ --- Type signatures - -opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) } - : {- empty -} { ([],Nothing) } - | '::' sigtype { ([mu AnnDcolon $1],Just $2) } - -opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } - : {- empty -} { ([], Nothing) } - | '::' gtycon { ([mu AnnDcolon $1], Just $2) } - -sigtype :: { LHsType GhcPs } - : ctype { $1 } - -sigtypedoc :: { LHsType GhcPs } - : ctypedoc { $1 } - - -sig_vars :: { Located [Located RdrName] } -- Returned in reversed order - : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) - AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | var { sL1 $1 [$1] } - -sigtypes1 :: { (OrdList (LHsSigType GhcPs)) } - : sigtype { unitOL (mkLHsSigType $1) } - | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return (unitOL (mkLHsSigType $1) `appOL` $3) } - ------------------------------------------------------------------------------ --- Types - -unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) } - : '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) } - | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) } - -forall_vis_flag :: { (AddAnn, ForallVisFlag) } - : '.' { (mj AnnDot $1, ForallInvis) } - | '->' { (mu AnnRarrow $1, ForallVis) } - --- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation -ktype :: { LHsType GhcPs } - : ctype { $1 } - | ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3) - [mu AnnDcolon $2] } - -ktypedoc :: { LHsType GhcPs } - : ctypedoc { $1 } - | ctypedoc '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3) - [mu AnnDcolon $2] } - --- A ctype is a for-all type -ctype :: { LHsType GhcPs } - : 'forall' tv_bndrs forall_vis_flag ctype - {% let (fv_ann, fv_flag) = $3 in - hintExplicitForall $1 *> - ams (sLL $1 $> $ - HsForAllTy { hst_fvf = fv_flag - , hst_bndrs = $2 - , hst_xforall = noExtField - , hst_body = $4 }) - [mu AnnForall $1,fv_ann] } - | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> return (sLL $1 $> $ - HsQualTy { hst_ctxt = $1 - , hst_xqual = noExtField - , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3)) - [mu AnnDcolon $2] } - | type { $1 } - --- Note [ctype and ctypedoc] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- It would have been nice to simplify the grammar by unifying `ctype` and --- ctypedoc` into one production, allowing comments on types everywhere (and --- rejecting them after parsing, where necessary). This is however not possible --- since it leads to ambiguity. The reason is the support for comments on record --- fields: --- data R = R { field :: Int -- ^ comment on the field } --- If we allow comments on types here, it's not clear if the comment applies --- to 'field' or to 'Int'. So we must use `ctype` to describe the type. - -ctypedoc :: { LHsType GhcPs } - : 'forall' tv_bndrs forall_vis_flag ctypedoc - {% let (fv_ann, fv_flag) = $3 in - hintExplicitForall $1 *> - ams (sLL $1 $> $ - HsForAllTy { hst_fvf = fv_flag - , hst_bndrs = $2 - , hst_xforall = noExtField - , hst_body = $4 }) - [mu AnnForall $1,fv_ann] } - | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> return (sLL $1 $> $ - HsQualTy { hst_ctxt = $1 - , hst_xqual = noExtField - , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3)) - [mu AnnDcolon $2] } - | typedoc { $1 } - ----------------------- --- Notes for 'context' --- We parse a context as a btype so that we don't get reduce/reduce --- errors in ctype. The basic problem is that --- (Eq a, Ord a) --- looks so much like a tuple type. We can't tell until we find the => - -context :: { LHsContext GhcPs } - : btype {% do { (anns,ctx) <- checkContext $1 - ; if null (unLoc ctx) - then addAnnotation (gl $1) AnnUnit (gl $1) - else return () - ; ams ctx anns - } } - --- See Note [Constr variatons of non-terminals] -constr_context :: { LHsContext GhcPs } - : constr_btype {% do { (anns,ctx) <- checkContext $1 - ; if null (unLoc ctx) - then addAnnotation (gl $1) AnnUnit (gl $1) - else return () - ; ams ctx anns - } } - -{- Note [GADT decl discards annotations] -~~~~~~~~~~~~~~~~~~~~~ -The type production for - - btype `->` ctypedoc - btype docprev `->` ctypedoc - -add the AnnRarrow annotation twice, in different places. - -This is because if the type is processed as usual, it belongs on the annotations -for the type as a whole. - -But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and -the top-level annotation will be disconnected. Hence for this specific case it -is connected to the first type too. --} - -type :: { LHsType GhcPs } - : btype { $1 } - | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField $1 $3) - [mu AnnRarrow $2] } - - -typedoc :: { LHsType GhcPs } - : btype { $1 } - | btype docprev { sLL $1 $> $ HsDocTy noExtField $1 $2 } - | docnext btype { sLL $1 $> $ HsDocTy noExtField $2 $1 } - | btype '->' ctypedoc {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField $1 $3) - [mu AnnRarrow $2] } - | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ - HsFunTy noExtField (cL (comb2 $1 $2) - (HsDocTy noExtField $1 $2)) - $4) - [mu AnnRarrow $3] } - | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ - HsFunTy noExtField (cL (comb2 $1 $2) - (HsDocTy noExtField $2 $1)) - $4) - [mu AnnRarrow $3] } - --- See Note [Constr variatons of non-terminals] -constr_btype :: { LHsType GhcPs } - : constr_tyapps {% mergeOps (unLoc $1) } - --- See Note [Constr variatons of non-terminals] -constr_tyapps :: { Located [Located TyEl] } -- NB: This list is reversed - : constr_tyapp { sL1 $1 [$1] } - | constr_tyapps constr_tyapp { sLL $1 $> $ $2 : (unLoc $1) } - --- See Note [Constr variatons of non-terminals] -constr_tyapp :: { Located TyEl } - : tyapp { $1 } - | docprev { sL1 $1 $ TyElDocPrev (unLoc $1) } - -btype :: { LHsType GhcPs } - : tyapps {% mergeOps $1 } - -tyapps :: { [Located TyEl] } -- NB: This list is reversed - : tyapp { [$1] } - | tyapps tyapp { $2 : $1 } - -tyapp :: { Located TyEl } - : atype { sL1 $1 $ TyElOpd (unLoc $1) } - | TYPEAPP atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) } - | qtyconop { sL1 $1 $ if isBangRdr (unLoc $1) then TyElBang else - if isTildeRdr (unLoc $1) then TyElTilde else - TyElOpr (unLoc $1) } - | tyvarop { sL1 $1 $ TyElOpr (unLoc $1) } - | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) - [mj AnnSimpleQuote $1,mj AnnVal $2] } - | SIMPLEQUOTE varop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) - [mj AnnSimpleQuote $1,mj AnnVal $2] } - | unpackedness { sL1 $1 $ TyElUnpackedness (unLoc $1) } - -atype :: { LHsType GhcPs } - : ntgtycon { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- Not including unit tuples - | tyvar { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- (See Note [Unit tuples]) - | '*' {% do { warnStarIsType (getLoc $1) - ; return $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } } - | '{' fielddecls '}' {% amms (checkRecordSyntax - (sLL $1 $> $ HsRecTy noExtField $2)) - -- Constructor sigs only - [moc $1,mcc $3] } - | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExtField - HsBoxedOrConstraintTuple []) - [mop $1,mcp $2] } - | '(' ktype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma - (gl $3) >> - ams (sLL $1 $> $ HsTupleTy noExtField - - HsBoxedOrConstraintTuple ($2 : $4)) - [mop $1,mcp $5] } - | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple []) - [mo $1,mc $2] } - | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple $2) - [mo $1,mc $3] } - | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExtField $2) - [mo $1,mc $3] } - | '[' ktype ']' {% ams (sLL $1 $> $ HsListTy noExtField $2) [mos $1,mcs $3] } - | '(' ktype ')' {% ams (sLL $1 $> $ HsParTy noExtField $2) [mop $1,mcp $3] } - | quasiquote { mapLoc (HsSpliceTy noExtField) $1 } - | splice_untyped { mapLoc (HsSpliceTy noExtField) $1 } - -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE '(' ktype ',' comma_types1 ')' - {% addAnnotation (gl $3) AnnComma (gl $4) >> - ams (sLL $1 $> $ HsExplicitTupleTy noExtField ($3 : $5)) - [mj AnnSimpleQuote $1,mop $2,mcp $6] } - | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExtField IsPromoted $3) - [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) - [mj AnnSimpleQuote $1,mj AnnName $2] } - - -- Two or more [ty, ty, ty] must be a promoted list type, just as - -- if you had written '[ty, ty, ty] - -- (One means a list type, zero means the list type constructor, - -- so you have to quote those.) - | '[' ktype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma - (gl $3) >> - ams (sLL $1 $> $ HsExplicitListTy noExtField NotPromoted ($2 : $4)) - [mos $1,mcs $5] } - | INTEGER { sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1) - (il_value (getINTEGER $1)) } - | STRING { sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1) - (getSTRING $1) } - | '_' { sL1 $1 $ mkAnonWildCardTy } - --- An inst_type is what occurs in the head of an instance decl --- e.g. (Foo a, Gaz b) => Wibble a b --- It's kept as a single type for convenience. -inst_type :: { LHsSigType GhcPs } - : sigtype { mkLHsSigType $1 } - -deriv_types :: { [LHsSigType GhcPs] } - : ktypedoc { [mkLHsSigType $1] } - - | ktypedoc ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) - >> return (mkLHsSigType $1 : $3) } - -comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty - : comma_types1 { $1 } - | {- empty -} { [] } - -comma_types1 :: { [LHsType GhcPs] } -- One or more: ty,ty,ty - : ktype { [$1] } - | ktype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return ($1 : $3) } - -bar_types2 :: { [LHsType GhcPs] } -- Two or more: ty|ty|ty - : ktype '|' ktype {% addAnnotation (gl $1) AnnVbar (gl $2) - >> return [$1,$3] } - | ktype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2) - >> return ($1 : $3) } - -tv_bndrs :: { [LHsTyVarBndr GhcPs] } - : tv_bndr tv_bndrs { $1 : $2 } - | {- empty -} { [] } - -tv_bndr :: { LHsTyVarBndr GhcPs } - : tyvar { sL1 $1 (UserTyVar noExtField $1) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExtField $2 $4)) - [mop $1,mu AnnDcolon $3 - ,mcp $5] } - -fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) } - : {- empty -} { noLoc ([],[]) } - | '|' fds1 { (sLL $1 $> ([mj AnnVbar $1] - ,reverse (unLoc $2))) } - -fds1 :: { Located [Located (FunDep (Located RdrName))] } - : fds1 ',' fd {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | fd { sL1 $1 [$1] } - -fd :: { Located (FunDep (Located RdrName)) } - : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3) - (reverse (unLoc $1), reverse (unLoc $3))) - [mu AnnRarrow $2] } - -varids0 :: { Located [Located RdrName] } - : {- empty -} { noLoc [] } - | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) } - ------------------------------------------------------------------------------ --- Kinds - -kind :: { LHsKind GhcPs } - : ctype { $1 } - -{- Note [Promotion] - ~~~~~~~~~~~~~~~~ - -- Syntax of promoted qualified names -We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified -names. Moreover ticks are only allowed in types, not in kinds, for a -few reasons: - 1. we don't need quotes since we cannot define names in kinds - 2. if one day we merge types and kinds, tick would mean look in DataName - 3. we don't have a kind namespace anyway - -- Name resolution -When the user write Zero instead of 'Zero in types, we parse it a -HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We -deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not -bounded in the type level, then we look for it in the term level (we -change its namespace to DataName, see Note [Demotion] in OccName). And -both become a HsTyVar ("Zero", DataName) after the renamer. - --} - - ------------------------------------------------------------------------------ --- Datatype declarations - -gadt_constrlist :: { Located ([AddAnn] - ,[LConDecl GhcPs]) } -- Returned in order - - : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ - cL (comb2 $1 $3) - ([mj AnnWhere $1 - ,moc $2 - ,mcc $4] - , unLoc $3) } - | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $ - cL (comb2 $1 $3) - ([mj AnnWhere $1] - , unLoc $3) } - | {- empty -} { noLoc ([],[]) } - -gadt_constrs :: { Located [LConDecl GhcPs] } - : gadt_constr_with_doc ';' gadt_constrs - {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr_with_doc { cL (gl $1) [$1] } - | {- empty -} { noLoc [] } - --- We allow the following forms: --- C :: Eq a => a -> T a --- C :: forall a. Eq a => !a -> T a --- D { x,y :: a } :: T a --- forall a. Eq a => D { x,y :: a } :: T a - -gadt_constr_with_doc :: { LConDecl GhcPs } -gadt_constr_with_doc - : maybe_docnext ';' gadt_constr - {% return $ addConDoc $3 $1 } - | gadt_constr - {% return $1 } - -gadt_constr :: { LConDecl GhcPs } - -- see Note [Difference in parsing GADT and data constructors] - -- Returns a list because of: C,D :: ty - : con_list '::' sigtypedoc - {% let (gadt,anns) = mkGadtDecl (unLoc $1) $3 - in ams (sLL $1 $> gadt) - (mu AnnDcolon $2:anns) } - -{- Note [Difference in parsing GADT and data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GADT constructors have simpler syntax than usual data constructors: -in GADTs, types cannot occur to the left of '::', so they cannot be mixed -with constructor names (see Note [Parsing data constructors is hard]). - -Due to simplified syntax, GADT constructor names (left-hand side of '::') -use simpler grammar production than usual data constructor names. As a -consequence, GADT constructor names are resticted (names like '(*)' are -allowed in usual data constructors, but not in GADTs). --} - -constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } - : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2] - ,addConDocs (unLoc $3) $1)} - -constrs1 :: { Located [LConDecl GhcPs] } - : constrs1 maybe_docnext '|' maybe_docprev constr - {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3) - >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) } - | constr { sL1 $1 [$1] } - -{- Note [Constr variatons of non-terminals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In record declarations we assume that 'ctype' used to parse the type will not -consume the trailing docprev: - - data R = R { field :: Int -- ^ comment on the field } - -In 'R' we expect the comment to apply to the entire field, not to 'Int'. The -same issue is detailed in Note [ctype and ctypedoc]. - -So, we do not want 'ctype' to consume 'docprev', therefore - we do not want 'btype' to consume 'docprev', therefore - we do not want 'tyapps' to consume 'docprev'. - -At the same time, when parsing a 'constr', we do want to consume 'docprev': - - data T = C Int -- ^ comment on Int - Bool -- ^ comment on Bool - -So, we do want 'constr_stuff' to consume 'docprev'. - -The problem arises because the clauses in 'constr' have the following -structure: - - (a) context '=>' constr_stuff (e.g. data T a = Ord a => C a) - (b) constr_stuff (e.g. data T a = C a) - -and to avoid a reduce/reduce conflict, 'context' and 'constr_stuff' must be -compatible. And for 'context' to be compatible with 'constr_stuff', it must -consume 'docprev'. - -So, we want 'context' to consume 'docprev', therefore - we want 'btype' to consume 'docprev', therefore - we want 'tyapps' to consume 'docprev'. - -Our requirements end up conflicting: for parsing record types, we want 'tyapps' -to leave 'docprev' alone, but for parsing constructors, we want it to consume -'docprev'. - -As the result, we maintain two parallel hierarchies of non-terminals that -either consume 'docprev' or not: - - tyapps constr_tyapps - btype constr_btype - context constr_context - ... - -They must be kept identical except for their treatment of 'docprev'. - --} - -constr :: { LConDecl GhcPs } - : maybe_docnext forall constr_context '=>' constr_stuff - {% ams (let (con,details,doc_prev) = unLoc $5 in - addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con - (snd $ unLoc $2) - (Just $3) - details)) - ($1 `mplus` doc_prev)) - (mu AnnDarrow $4:(fst $ unLoc $2)) } - | maybe_docnext forall constr_stuff - {% ams ( let (con,details,doc_prev) = unLoc $3 in - addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con - (snd $ unLoc $2) - Nothing -- No context - details)) - ($1 `mplus` doc_prev)) - (fst $ unLoc $2) } - -forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) } - : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } - | {- empty -} { noLoc ([], Nothing) } - -constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) } - : constr_tyapps {% do { c <- mergeDataCon (unLoc $1) - ; return $ sL1 $1 c } } - -fielddecls :: { [LConDeclField GhcPs] } - : {- empty -} { [] } - | fielddecls1 { $1 } - -fielddecls1 :: { [LConDeclField GhcPs] } - : fielddecl maybe_docnext ',' maybe_docprev fielddecls1 - {% addAnnotation (gl $1) AnnComma (gl $3) >> - return ((addFieldDoc $1 $4) : addFieldDocs $5 $2) } - | fielddecl { [$1] } - -fielddecl :: { LConDeclField GhcPs } - -- A list because of f,g :: Int - : maybe_docnext sig_vars '::' ctype maybe_docprev - {% ams (cL (comb2 $2 $4) - (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5))) - [mu AnnDcolon $3] } - --- Reversed! -maybe_derivings :: { HsDeriving GhcPs } - : {- empty -} { noLoc [] } - | derivings { $1 } - --- A list of one or more deriving clauses at the end of a datatype -derivings :: { HsDeriving GhcPs } - : derivings deriving { sLL $1 $> $ $2 : unLoc $1 } - | deriving { sLL $1 $> [$1] } - --- The outer Located is just to allow the caller to --- know the rightmost extremity of the 'deriving' clause -deriving :: { LHsDerivingClause GhcPs } - : 'deriving' deriv_clause_types - {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField Nothing $2) - [mj AnnDeriving $1] } - - | 'deriving' deriv_strategy_no_via deriv_clause_types - {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField (Just $2) $3) - [mj AnnDeriving $1] } - - | 'deriving' deriv_clause_types deriv_strategy_via - {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField (Just $3) $2) - [mj AnnDeriving $1] } - -deriv_clause_types :: { Located [LHsSigType GhcPs] } - : qtycondoc { sL1 $1 [mkLHsSigType $1] } - | '(' ')' {% ams (sLL $1 $> []) - [mop $1,mcp $2] } - | '(' deriv_types ')' {% ams (sLL $1 $> $2) - [mop $1,mcp $3] } - -- Glasgow extension: allow partial - -- applications in derivings - ------------------------------------------------------------------------------ --- Value definitions - -{- Note [Declaration/signature overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's an awkward overlap with a type signature. Consider - f :: Int -> Int = ...rhs... - Then we can't tell whether it's a type signature or a value - definition with a result signature until we see the '='. - So we have to inline enough to postpone reductions until we know. --} - -{- - ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var - instead of qvar, we get another shift/reduce-conflict. Consider the - following programs: - - { (^^) :: Int->Int ; } Type signature; only var allowed - - { (^^) :: Int->Int = ... ; } Value defn with result signature; - qvar allowed (because of instance decls) - - We can't tell whether to reduce var to qvar until after we've read the signatures. --} - -docdecl :: { LHsDecl GhcPs } - : docdecld { sL1 $1 (DocD noExtField (unLoc $1)) } - -docdecld :: { LDocDecl } - : docnext { sL1 $1 (DocCommentNext (unLoc $1)) } - | docprev { sL1 $1 (DocCommentPrev (unLoc $1)) } - | docnamed { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) } - | docsection { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } - -decl_no_th :: { LHsDecl GhcPs } - : sigdecl { $1 } - - | '!' aexp rhs {% runECP_P $2 >>= \ $2 -> - do { let { e = patBuilderBang (getLoc $1) $2 - ; l = comb2 $1 $> }; - (ann, r) <- checkValDef SrcStrict e Nothing $3 ; - runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [FunBind vs PatBind] - case r of { - (FunBind _ n _ _ _) -> - amsL l [mj AnnFunId n] >> return () ; - (PatBind _ (dL->L l _) _rhs _) -> - amsL l [] >> return () } ; - - _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; - return $! (sL l $ ValD noExtField r) } } - - | infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 -> - do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3; - let { l = comb2 $1 $> }; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [FunBind vs PatBind] - case r of { - (FunBind _ n _ _ _) -> - amsL l (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind _ (dL->L lh _lhs) _rhs _) -> - amsL lh (fst $2) >> return () } ; - _ <- amsL l (ann ++ (fst $ unLoc $3)); - return $! (sL l $ ValD noExtField r) } } - | pattern_synonym_decl { $1 } - | docdecl { $1 } - -decl :: { LHsDecl GhcPs } - : decl_no_th { $1 } - - -- Why do we only allow naked declaration splices in top-level - -- declarations and not here? Short answer: because readFail009 - -- fails terribly with a panic in cvBindsAndSigs otherwise. - | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } - -rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } - : '=' exp wherebinds {% runECP_P $2 >>= \ $2 -> return $ - sL (comb3 $1 $2 $3) - ((mj AnnEqual $1 : (fst $ unLoc $3)) - ,GRHSs noExtField (unguardedRHS (comb3 $1 $2 $3) $2) - (snd $ unLoc $3)) } - | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 - ,GRHSs noExtField (reverse (unLoc $1)) - (snd $ unLoc $2)) } - -gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } - : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } - | gdrh { sL1 $1 [$1] } - -gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } - : '|' guardquals '=' exp {% runECP_P $4 >>= \ $4 -> - ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4) - [mj AnnVbar $1,mj AnnEqual $3] } - -sigdecl :: { LHsDecl GhcPs } - : - -- See Note [Declaration/signature overlap] for why we need infixexp here - infixexp_top '::' sigtypedoc - {% do { $1 <- runECP_P $1 - ; v <- checkValSigLhs $1 - ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD noExtField $ - TypeSig noExtField [v] (mkLHsSigWcType $3))} } - - | var ',' sig_vars '::' sigtypedoc - {% do { let sig = TypeSig noExtField ($1 : reverse (unLoc $3)) - (mkLHsSigWcType $5) - ; addAnnotation (gl $1) AnnComma (gl $2) - ; ams ( sLL $1 $> $ SigD noExtField sig ) - [mu AnnDcolon $4] } } - - | infix prec ops - {% checkPrecP $2 $3 >> - ams (sLL $1 $> $ SigD noExtField - (FixSig noExtField (FixitySig noExtField (fromOL $ unLoc $3) - (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) - [mj AnnInfix $1,mj AnnVal $2] } - - | pattern_synonym_sig { sLL $1 $> . SigD noExtField . unLoc $ $1 } - - | '{-# COMPLETE' con_list opt_tyconsig '#-}' - {% let (dcolon, tc) = $3 - in ams - (sLL $1 $> - (SigD noExtField (CompleteMatchSig noExtField (getCOMPLETE_PRAGs $1) $2 tc))) - ([ mo $1 ] ++ dcolon ++ [mc $4]) } - - -- This rule is for both INLINE and INLINABLE pragmas - | '{-# INLINE' activation qvar '#-}' - {% ams ((sLL $1 $> $ SigD noExtField (InlineSig noExtField $3 - (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) - (snd $2))))) - ((mo $1:fst $2) ++ [mc $4]) } - - | '{-# SCC' qvar '#-}' - {% ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 Nothing))) - [mo $1, mc $3] } - - | '{-# SCC' qvar STRING '#-}' - {% do { scc <- getSCC $3 - ; let str_lit = StringLiteral (getSTRINGs $3) scc - ; ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) - [mo $1, mc $4] } } - - | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' - {% ams ( - let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) - (NoUserInline, FunLike) (snd $2) - in sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) inl_prag)) - (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } - - | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - {% ams (sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) - (mkInlinePragma (getSPEC_INLINE_PRAGs $1) - (getSPEC_INLINE $1) (snd $2)))) - (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } - - | '{-# SPECIALISE' 'instance' inst_type '#-}' - {% ams (sLL $1 $> - $ SigD noExtField (SpecInstSig noExtField (getSPEC_PRAGs $1) $3)) - [mo $1,mj AnnInstance $2,mc $4] } - - -- A minimal complete definition - | '{-# MINIMAL' name_boolformula_opt '#-}' - {% ams (sLL $1 $> $ SigD noExtField (MinimalSig noExtField (getMINIMAL_PRAGs $1) $2)) - [mo $1,mc $3] } - -activation :: { ([AddAnn],Maybe Activation) } - : {- empty -} { ([],Nothing) } - | explicit_activation { (fst $1,Just (snd $1)) } - -explicit_activation :: { ([AddAnn],Activation) } -- In brackets - : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] - ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } - | '[' '~' INTEGER ']' { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3 - ,mj AnnCloseS $4] - ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } - ------------------------------------------------------------------------------ --- Expressions - -quasiquote :: { Located (HsSplice GhcPs) } - : TH_QUASIQUOTE { let { loc = getLoc $1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 - ; quoterId = mkUnqual varName quoter } - in sL1 $1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } - | TH_QQUASIQUOTE { let { loc = getLoc $1 - ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 - ; quoterId = mkQual varName (qual, quoter) } - in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } - -exp :: { ECP } - : infixexp '::' sigtype { ECP $ - runECP_PV $1 >>= \ $1 -> - amms (mkHsTySigPV (comb2 $1 $>) $1 $3) - [mu AnnDcolon $2] } - | infixexp '-<' exp {% runECP_P $1 >>= \ $1 -> - runECP_P $3 >>= \ $3 -> - fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3 - HsFirstOrderApp True) - [mu Annlarrowtail $2] } - | infixexp '>-' exp {% runECP_P $1 >>= \ $1 -> - runECP_P $3 >>= \ $3 -> - fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1 - HsFirstOrderApp False) - [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% runECP_P $1 >>= \ $1 -> - runECP_P $3 >>= \ $3 -> - fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3 - HsHigherOrderApp True) - [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% runECP_P $1 >>= \ $1 -> - runECP_P $3 >>= \ $3 -> - fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1 - HsHigherOrderApp False) - [mu AnnRarrowtail $2] } - | infixexp { $1 } - -infixexp :: { ECP } - : exp10 { $1 } - | infixexp qop exp10 { ECP $ - superInfixOp $ - $2 >>= \ $2 -> - runECP_PV $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) - [mj AnnVal $2] } - -- AnnVal annotation for NPlusKPat, which discards the operator - -infixexp_top :: { ECP } - : exp10_top { $1 } - | infixexp_top qop exp10_top - { ECP $ - superInfixOp $ - $2 >>= \ $2 -> - runECP_PV $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) - [mj AnnVal $2] } - -exp10_top :: { ECP } - : '-' fexp { ECP $ - runECP_PV $2 >>= \ $2 -> - amms (mkHsNegAppPV (comb2 $1 $>) $2) - [mj AnnMinus $1] } - - - | hpc_annot exp {% runECP_P $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsTickPragma noExtField (snd $ fst $ fst $ unLoc $1) - (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) - (fst $ fst $ fst $ unLoc $1) } - - | '{-# CORE' STRING '#-}' exp {% runECP_P $4 >>= \ $4 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsCoreAnn noExtField (getCORE_PRAGs $1) (getStringLiteral $2) $4) - [mo $1,mj AnnVal $2 - ,mc $3] } - -- hdaume: core annotation - | fexp { $1 } - -exp10 :: { ECP } - : exp10_top { $1 } - | scc_annot exp {% runECP_P $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsSCC noExtField (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) - (fst $ fst $ unLoc $1) } - -optSemi :: { ([Located Token],Bool) } - : ';' { ([$1],True) } - | {- empty -} { ([],False) } - -scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) } - : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 - ; return $ sLL $1 $> - (([mo $1,mj AnnValStr $2 - ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) } - | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 - ,mc $3],getSCC_PRAGs $1) - ,(StringLiteral NoSourceText (getVARID $2))) } - -hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), - ((SourceText,SourceText),(SourceText,SourceText)) - ) } - : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - { sLL $1 $> $ ((([mo $1,mj AnnVal $2 - ,mj AnnVal $3,mj AnnColon $4 - ,mj AnnVal $5,mj AnnMinus $6 - ,mj AnnVal $7,mj AnnColon $8 - ,mj AnnVal $9,mc $10], - getGENERATED_PRAGs $1) - ,((getStringLiteral $2) - ,( fromInteger $ il_value $ getINTEGER $3 - , fromInteger $ il_value $ getINTEGER $5 - ) - ,( fromInteger $ il_value $ getINTEGER $7 - , fromInteger $ il_value $ getINTEGER $9 - ) - )) - , (( getINTEGERs $3 - , getINTEGERs $5 - ) - ,( getINTEGERs $7 - , getINTEGERs $9 - ))) - } - -fexp :: { ECP } - : fexp aexp { ECP $ - superFunArg $ - runECP_PV $1 >>= \ $1 -> - runECP_PV $2 >>= \ $2 -> - mkHsAppPV (comb2 $1 $>) $1 $2 } - | fexp TYPEAPP atype {% runECP_P $1 >>= \ $1 -> - runPV (checkExpBlockArguments $1) >>= \_ -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsAppType noExtField $1 (mkHsWildCardBndrs $3)) - [mj AnnAt $2] } - | 'static' aexp {% runECP_P $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsStatic noExtField $2) - [mj AnnStatic $1] } - | aexp { $1 } - -aexp :: { ECP } - : qvar '@' aexp { ECP $ - runECP_PV $3 >>= \ $3 -> - amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } - -- If you change the parsing, make sure to understand - -- Note [Lexing type applications] in Lexer.x - - | '~' aexp { ECP $ - runECP_PV $2 >>= \ $2 -> - amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] } - - | '\\' apat apats '->' exp - { ECP $ - runECP_PV $5 >>= \ $5 -> - amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_ext = noExtField - , m_ctxt = LambdaExpr - , m_pats = $2:$3 - , m_grhss = unguardedGRHSs $5 }])) - [mj AnnLam $1, mu AnnRarrow $4] } - | 'let' binds 'in' exp { ECP $ - runECP_PV $4 >>= \ $4 -> - amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4) - (mj AnnLet $1:mj AnnIn $3 - :(fst $ unLoc $2)) } - | '\\' 'lcase' altslist - {% runPV $3 >>= \ $3 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsLamCase noExtField - (mkMatchGroup FromSource (snd $ unLoc $3))) - (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } - | 'if' exp optSemi 'then' exp optSemi 'else' exp - {% runECP_P $2 >>= \ $2 -> - return $ ECP $ - runECP_PV $5 >>= \ $5 -> - runECP_PV $8 >>= \ $8 -> - amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8) - (mj AnnIf $1:mj AnnThen $4 - :mj AnnElse $7 - :(map (\l -> mj AnnSemi l) (fst $3)) - ++(map (\l -> mj AnnSemi l) (fst $6))) } - | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsMultiIf noExtField - (reverse $ snd $ unLoc $2)) - (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% runECP_P $2 >>= \ $2 -> - return $ ECP $ - $4 >>= \ $4 -> - amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup - FromSource (snd $ unLoc $4))) - (mj AnnCase $1:mj AnnOf $3 - :(fst $ unLoc $4)) } - | 'do' stmtlist { ECP $ - $2 >>= \ $2 -> - amms (mkHsDoPV (comb2 $1 $2) (mapLoc snd $2)) - (mj AnnDo $1:(fst $ unLoc $2)) } - | 'mdo' stmtlist {% runPV $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (cL (comb2 $1 $2) - (mkHsDo MDoExpr (snd $ unLoc $2))) - (mj AnnMdo $1:(fst $ unLoc $2)) } - | 'proc' aexp '->' exp - {% (checkPattern <=< runECP_P) $2 >>= \ p -> - runECP_P $4 >>= \ $4@cmd -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsProc noExtField p (sLL $1 $> $ HsCmdTop noExtField cmd)) - -- TODO: is LL right here? - [mj AnnProc $1,mu AnnRarrow $3] } - - | aexp1 { $1 } - -aexp1 :: { ECP } - : aexp1 '{' fbinds '}' { ECP $ - runECP_PV $1 >>= \ $1 -> - $3 >>= \ $3 -> - amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) - (moc $2:mcc $4:(fst $3)) } - | aexp2 { $1 } - -aexp2 :: { ECP } - : qvar { ECP $ mkHsVarPV $! $1 } - | qcon { ECP $ mkHsVarPV $! $1 } - | ipvar { ecpFromExp $ sL1 $1 (HsIPVar noExtField $! unLoc $1) } - | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExtField Nothing $! unLoc $1) } - | literal { ECP $ mkHsLitPV $! $1 } --- This will enable overloaded strings permanently. Normally the renamer turns HsString --- into HsOverLit when -foverloaded-strings is on. --- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) --- (getSTRING $1) noExtField) } - | INTEGER { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) } - | RATIONAL { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) } - - -- N.B.: sections get parsed by these next two productions. - -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't - -- correct Haskell (you'd have to write '((+ 3), (4 -))') - -- but the less cluttered version fell out of having texps. - | '(' texp ')' { ECP $ - runECP_PV $2 >>= \ $2 -> - amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] } - | '(' tup_exprs ')' { ECP $ - $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2)) - ((mop $1:fst $2) ++ [mcp $3]) } - - | '(#' texp '#)' { ECP $ - runECP_PV $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)])) - [mo $1,mc $3] } - | '(#' tup_exprs '#)' { ECP $ - $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (snd $2)) - ((mo $1:fst $2) ++ [mc $3]) } - - | '[' list ']' { ECP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] } - | '_' { ECP $ mkHsWildCardPV (getLoc $1) } - - -- Template Haskell Extension - | splice_untyped { ECP $ mkHsSplicePV $1 } - | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noExtField) $1 } - - | SIMPLEQUOTE qvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) } - | '[|' exp '|]' {% runECP_P $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (ExpBr noExtField $2)) - (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] - else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% runECP_P $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (TExpBr noExtField $2)) - (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ktype '|]' {% fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (TypBr noExtField $2)) [mo $1,mu AnnCloseQ $3] } - | '[p|' infixexp '|]' {% (checkPattern <=< runECP_P) $2 >>= \p -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (PatBr noExtField p)) - [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (DecBrL noExtField (snd $2))) - (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { ECP $ mkHsSplicePV $1 } - - -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% runECP_P $2 >>= \ $2 -> - fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrForm noExtField $2 Prefix - Nothing (reverse $3)) - [mu AnnOpenB $1,mu AnnCloseB $4] } - -splice_exp :: { LHsExpr GhcPs } - : splice_untyped { mapLoc (HsSpliceE noExtField) $1 } - | splice_typed { mapLoc (HsSpliceE noExtField) $1 } - -splice_untyped :: { Located (HsSplice GhcPs) } - : TH_ID_SPLICE {% ams (sL1 $1 $ mkUntypedSplice HasDollar - (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName - (getTH_ID_SPLICE $1))))) - [mj AnnThIdSplice $1] } - | '$(' exp ')' {% runECP_P $2 >>= \ $2 -> - ams (sLL $1 $> $ mkUntypedSplice HasParens $2) - [mj AnnOpenPE $1,mj AnnCloseP $3] } - -splice_typed :: { Located (HsSplice GhcPs) } - : TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkTypedSplice HasDollar - (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName - (getTH_ID_TY_SPLICE $1))))) - [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% runECP_P $2 >>= \ $2 -> - ams (sLL $1 $> $ mkTypedSplice HasParens $2) - [mj AnnOpenPTE $1,mj AnnCloseP $3] } - -cmdargs :: { [LHsCmdTop GhcPs] } - : cmdargs acmd { $2 : $1 } - | {- empty -} { [] } - -acmd :: { LHsCmdTop GhcPs } - : aexp2 {% runECP_P $1 >>= \ cmd -> - return (sL1 cmd $ HsCmdTop noExtField cmd) } - -cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } - : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 - ,mj AnnCloseC $3],$2) } - | vocurly cvtopdecls0 close { ([],$2) } - -cvtopdecls0 :: { [LHsDecl GhcPs] } - : topdecls_semi { cvTopDecls $1 } - | topdecls { cvTopDecls $1 } - ------------------------------------------------------------------------------ --- Tuple expressions - --- "texp" is short for tuple expressions: --- things that can appear unparenthesized as long as they're --- inside parens or delimitted by commas -texp :: { ECP } - : exp { $1 } - - -- Note [Parsing sections] - -- ~~~~~~~~~~~~~~~~~~~~~~~ - -- We include left and right sections here, which isn't - -- technically right according to the Haskell standard. - -- For example (3 +, True) isn't legal. - -- However, we want to parse bang patterns like - -- (!x, !y) - -- and it's convenient to do so here as a section - -- Then when converting expr to pattern we unravel it again - -- Meanwhile, the renamer checks that real sections appear - -- inside parens. - | infixexp qop {% runECP_P $1 >>= \ $1 -> - runPV $2 >>= \ $2 -> - return $ ecpFromExp $ - sLL $1 $> $ SectionL noExtField $1 $2 } - | qopm infixexp { ECP $ - superInfixOp $ - runECP_PV $2 >>= \ $2 -> - $1 >>= \ $1 -> - mkHsSectionR_PV (comb2 $1 $>) $1 $2 } - - -- View patterns get parenthesized above - | exp '->' texp { ECP $ - runECP_PV $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] } - --- Always at least one comma or bar. --- Though this can parse just commas (without any expressions), it won't --- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple] --- in GHC.Hs.Expr. -tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) } - : texp commas_tup_tail - { runECP_PV $1 >>= \ $1 -> - $2 >>= \ $2 -> - do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } } - - | texp bars { runECP_PV $1 >>= \ $1 -> return $ - (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } - - | commas tup_tail - { $2 >>= \ $2 -> - do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) - ; return - ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } } - - | bars texp bars0 - { runECP_PV $2 >>= \ $2 -> return $ - (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } - --- Always starts with commas; always follows an expr -commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))]) } -commas_tup_tail : commas tup_tail - { $2 >>= \ $2 -> - do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) - ; return ( - (head $ fst $1 - ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } } - --- Always follows a comma -tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } - : texp commas_tup_tail { runECP_PV $1 >>= \ $1 -> - $2 >>= \ $2 -> - addAnnotation (gl $1) AnnComma (fst $2) >> - return ((cL (gl $1) (Just $1)) : snd $2) } - | texp { runECP_PV $1 >>= \ $1 -> - return [cL (gl $1) (Just $1)] } - | {- empty -} { return [noLoc Nothing] } - ------------------------------------------------------------------------------ --- List expressions - --- The rules below are little bit contorted to keep lexps left-recursive while --- avoiding another shift/reduce-conflict. --- Never empty. -list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) } - : texp { \loc -> runECP_PV $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] } - | lexps { \loc -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) } - | texp '..' { \loc -> runECP_PV $1 >>= \ $1 -> - ams (cL loc $ ArithSeq noExtField Nothing (From $1)) - [mj AnnDotdot $2] - >>= ecpFromExp' } - | texp ',' exp '..' { \loc -> - runECP_PV $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromThen $1 $3)) - [mj AnnComma $2,mj AnnDotdot $4] - >>= ecpFromExp' } - | texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromTo $1 $3)) - [mj AnnDotdot $2] - >>= ecpFromExp' } - | texp ',' exp '..' exp { \loc -> - runECP_PV $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - runECP_PV $5 >>= \ $5 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5)) - [mj AnnComma $2,mj AnnDotdot $4] - >>= ecpFromExp' } - | texp '|' flattenedpquals - { \loc -> - checkMonadComp >>= \ ctxt -> - runECP_PV $1 >>= \ $1 -> - ams (cL loc $ mkHsComp ctxt (unLoc $3) $1) - [mj AnnVbar $2] - >>= ecpFromExp' } - -lexps :: { forall b. DisambECP b => PV [Located b] } - : lexps ',' texp { $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - addAnnotation (gl $ head $ $1) - AnnComma (gl $2) >> - return (((:) $! $3) $! $1) } - | texp ',' texp { runECP_PV $1 >>= \ $1 -> - runECP_PV $3 >>= \ $3 -> - addAnnotation (gl $1) AnnComma (gl $2) >> - return [$3,$1] } - ------------------------------------------------------------------------------ --- List Comprehensions - -flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } - : pquals { case (unLoc $1) of - [qs] -> sL1 $1 qs - -- We just had one thing in our "parallel" list so - -- we simply return that thing directly - - qss -> sL1 $1 [sL1 $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | - qs <- qss] - noExpr noSyntaxExpr] - -- We actually found some actual parallel lists so - -- we wrap them into as a ParStmt - } - -pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] } - : squals '|' pquals - {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> - return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } - | squals { cL (getLoc $1) [reverse (unLoc $1)] } - -squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last - -- one can "grab" the earlier ones - : squals ',' transformqual - {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - amsL (comb2 $1 $>) (fst $ unLoc $3) >> - return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) } - | squals ',' qual - {% runPV $3 >>= \ $3 -> - addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | transformqual {% ams $1 (fst $ unLoc $1) >> - return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) } - | qual {% runPV $1 >>= \ $1 -> - return $ sL1 $1 [$1] } --- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } --- | '{|' pquals '|}' { sL1 $1 [$2] } - --- It is possible to enable bracketing (associating) qualifier lists --- by uncommenting the lines with {| |} above. Due to a lack of --- consensus on the syntax, this feature is not being used until we --- get user demand. - -transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } - -- Function is applied to a list of stmts *in order* - : 'then' exp {% runECP_P $2 >>= \ $2 -> return $ - sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } - | 'then' exp 'by' exp {% runECP_P $2 >>= \ $2 -> - runECP_P $4 >>= \ $4 -> - return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy $3], - \ss -> (mkTransformByStmt ss $2 $4)) } - | 'then' 'group' 'using' exp - {% runECP_P $4 >>= \ $4 -> - return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], - \ss -> (mkGroupUsingStmt ss $4)) } - - | 'then' 'group' 'by' exp 'using' exp - {% runECP_P $4 >>= \ $4 -> - runECP_P $6 >>= \ $6 -> - return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], - \ss -> (mkGroupByUsingStmt ss $4 $6)) } - --- Note that 'group' is a special_id, which means that you can enable --- TransformListComp while still using Data.List.group. However, this --- introduces a shift/reduce conflict. Happy chooses to resolve the conflict --- in by choosing the "group by" variant, which is what we want. - ------------------------------------------------------------------------------ --- Guards - -guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } - : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) } - -guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } - : guardquals1 ',' qual {% runPV $3 >>= \ $3 -> - addAnnotation (gl $ head $ unLoc $1) AnnComma - (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | qual {% runPV $1 >>= \ $1 -> - return $ sL1 $1 [$1] } - ------------------------------------------------------------------------------ --- Case alternatives - -altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } - : '{' alts '}' { $2 >>= \ $2 -> return $ - sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) - ,(reverse (snd $ unLoc $2))) } - | vocurly alts close { $2 >>= \ $2 -> return $ - cL (getLoc $2) (fst $ unLoc $2 - ,(reverse (snd $ unLoc $2))) } - | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) } - | vocurly close { return $ noLoc ([],[]) } - -alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } - : alts1 { $1 >>= \ $1 -> return $ - sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { $2 >>= \ $2 -> return $ - sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) - ,snd $ unLoc $2) } - -alts1 :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } - : alts1 ';' alt { $1 >>= \ $1 -> - $3 >>= \ $3 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,[$3])) - else (ams (head $ snd $ unLoc $1) - (mj AnnSemi $2:(fst $ unLoc $1)) - >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) } - | alts1 ';' { $1 >>= \ $1 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1)) - else (ams (head $ snd $ unLoc $1) - (mj AnnSemi $2:(fst $ unLoc $1)) - >> return (sLL $1 $> ([],snd $ unLoc $1))) } - | alt { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) } - -alt :: { forall b. DisambECP b => PV (LMatch GhcPs (Located b)) } - : pat alt_rhs { $2 >>= \ $2 -> - ams (sLL $1 $> (Match { m_ext = noExtField - , m_ctxt = CaseAlt - , m_pats = [$1] - , m_grhss = snd $ unLoc $2 })) - (fst $ unLoc $2)} - -alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b))) } - : ralt wherebinds { $1 >>= \alt -> - return $ sLL alt $> (fst $ unLoc $2, GRHSs noExtField (unLoc alt) (snd $ unLoc $2)) } - -ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } - : '->' exp { runECP_PV $2 >>= \ $2 -> - ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) - [mu AnnRarrow $1] } - | gdpats { $1 >>= \gdpats -> - return $ sL1 gdpats (reverse (unLoc gdpats)) } - -gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } - : gdpats gdpat { $1 >>= \gdpats -> - $2 >>= \gdpat -> - return $ sLL gdpats gdpat (gdpat : unLoc gdpats) } - | gdpat { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] } - --- layout for MultiWayIf doesn't begin with an open brace, because it's hard to --- generate the open brace in addition to the vertical bar in the lexer, and --- we don't need it. -ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } - : '{' gdpats '}' {% runPV $2 >>= \ $2 -> - return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) } - | gdpats close {% runPV $1 >>= \ $1 -> - return $ sL1 $1 ([],unLoc $1) } - -gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) } - : '|' guardquals '->' exp - { runECP_PV $4 >>= \ $4 -> - ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4) - [mj AnnVbar $1,mu AnnRarrow $3] } - --- 'pat' recognises a pattern, including one with a bang at the top --- e.g. "!x" or "!(x,y)" or "C a b" etc --- Bangs inside are parsed as infix operator applications, so that --- we parse them right when bang-patterns are off -pat :: { LPat GhcPs } -pat : exp {% (checkPattern <=< runECP_P) $1 } - | '!' aexp {% runECP_P $2 >>= \ $2 -> - amms (checkPattern (patBuilderBang (getLoc $1) $2)) - [mj AnnBang $1] } - -bindpat :: { LPat GhcPs } -bindpat : exp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn - checkPattern_msg (text "Possibly caused by a missing 'do'?") - (runECP_PV $1) } - | '!' aexp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn - amms (checkPattern_msg (text "Possibly caused by a missing 'do'?") - (patBuilderBang (getLoc $1) `fmap` runECP_PV $2)) - [mj AnnBang $1] } - -apat :: { LPat GhcPs } -apat : aexp {% (checkPattern <=< runECP_P) $1 } - | '!' aexp {% runECP_P $2 >>= \ $2 -> - amms (checkPattern (patBuilderBang (getLoc $1) $2)) - [mj AnnBang $1] } - -apats :: { [LPat GhcPs] } - : apat apats { $1 : $2 } - | {- empty -} { [] } - ------------------------------------------------------------------------------ --- Statement sequences - -stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } - : '{' stmts '}' { $2 >>= \ $2 -> return $ - sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) - ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? - | vocurly stmts close { $2 >>= \ $2 -> return $ - cL (gl $2) (fst $ unLoc $2 - ,reverse $ snd $ unLoc $2) } - --- do { ;; s ; s ; ; s ;; } --- The last Stmt should be an expression, but that's hard to enforce --- here, because we need too much lookahead if we see do { e ; } --- So we use BodyStmts throughout, and switch the last one over --- in ParseUtils.checkDo instead - -stmts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } - : stmts ';' stmt { $1 >>= \ $1 -> - $3 >>= \ $3 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,$3 : (snd $ unLoc $1))) - else do - { ams (head $ snd $ unLoc $1) [mj AnnSemi $2] - ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }} - - | stmts ';' { $1 >>= \ $1 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1)) - else do - { ams (head $ snd $ unLoc $1) - [mj AnnSemi $2] - ; return $1 } - } - | stmt { $1 >>= \ $1 -> - return $ sL1 $1 ([],[$1]) } - | {- empty -} { return $ noLoc ([],[]) } - - --- For typing stmts at the GHCi prompt, where --- the input may consist of just comments. -maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) } - : stmt {% fmap Just (runPV $1) } - | {- nothing -} { Nothing } - --- For GHC API. -e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } - : stmt {% runPV $1 } - -stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } - : qual { $1 } - | 'rec' stmtlist { $2 >>= \ $2 -> - ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) - (mj AnnRec $1:(fst $ unLoc $2)) } - -qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } - : bindpat '<-' exp { runECP_PV $3 >>= \ $3 -> - ams (sLL $1 $> $ mkBindStmt $1 $3) - [mu AnnLarrow $2] } - | exp { runECP_PV $1 >>= \ $1 -> - return $ sL1 $1 $ mkBodyStmt $1 } - | 'let' binds { ams (sLL $1 $> $ LetStmt noExtField (snd $ unLoc $2)) - (mj AnnLet $1:(fst $ unLoc $2)) } - ------------------------------------------------------------------------------ --- Record Field Update/Construction - -fbinds :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } - : fbinds1 { $1 } - | {- empty -} { return ([],([], Nothing)) } - -fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } - : fbind ',' fbinds1 - { $1 >>= \ $1 -> - $3 >>= \ $3 -> - addAnnotation (gl $1) AnnComma (gl $2) >> - return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } - | fbind { $1 >>= \ $1 -> - return ([],([$1], Nothing)) } - | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) } - -fbind :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) } - : qvar '=' texp { runECP_PV $3 >>= \ $3 -> - ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) - [mj AnnEqual $2] } - -- RHS is a 'texp', allowing view patterns (#6038) - -- and, incidentally, sections. Eg - -- f (R { x = show -> s }) = ... - - | qvar { placeHolderPunRhs >>= \rhs -> - return $ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True } - -- In the punning case, use a place-holder - -- The renamer fills in the final value - ------------------------------------------------------------------------------ --- Implicit Parameter Bindings - -dbinds :: { Located [LIPBind GhcPs] } - : dbinds ';' dbind - {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> - return (let { this = $3; rest = unLoc $1 } - in rest `seq` this `seq` sLL $1 $> (this : rest)) } - | dbinds ';' {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> - return (sLL $1 $> (unLoc $1)) } - | dbind { let this = $1 in this `seq` sL1 $1 [this] } --- | {- empty -} { [] } - -dbind :: { LIPBind GhcPs } -dbind : ipvar '=' exp {% runECP_P $3 >>= \ $3 -> - ams (sLL $1 $> (IPBind noExtField (Left $1) $3)) - [mj AnnEqual $2] } - -ipvar :: { Located HsIPName } - : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } - ------------------------------------------------------------------------------ --- Overloaded labels - -overloaded_label :: { Located FastString } - : LABELVARID { sL1 $1 (getLABELVARID $1) } - ------------------------------------------------------------------------------ --- Warnings and deprecations - -name_boolformula_opt :: { LBooleanFormula (Located RdrName) } - : name_boolformula { $1 } - | {- empty -} { noLoc mkTrue } - -name_boolformula :: { LBooleanFormula (Located RdrName) } - : name_boolformula_and { $1 } - | name_boolformula_and '|' name_boolformula - {% aa $1 (AnnVbar, $2) - >> return (sLL $1 $> (Or [$1,$3])) } - -name_boolformula_and :: { LBooleanFormula (Located RdrName) } - : name_boolformula_and_list - { sLL (head $1) (last $1) (And ($1)) } - -name_boolformula_and_list :: { [LBooleanFormula (Located RdrName)] } - : name_boolformula_atom { [$1] } - | name_boolformula_atom ',' name_boolformula_and_list - {% aa $1 (AnnComma, $2) >> return ($1 : $3) } - -name_boolformula_atom :: { LBooleanFormula (Located RdrName) } - : '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] } - | name_var { sL1 $1 (Var $1) } - -namelist :: { Located [Located RdrName] } -namelist : name_var { sL1 $1 [$1] } - | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> ($1 : unLoc $3)) } - -name_var :: { Located RdrName } -name_var : var { $1 } - | con { $1 } - ------------------------------------------ --- Data constructors --- There are two different productions here as lifted list constructors --- are parsed differently. - -qcon_nowiredlist :: { Located RdrName } - : gen_qcon { $1 } - | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } - -qcon :: { Located RdrName } - : gen_qcon { $1} - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } - -gen_qcon :: { Located RdrName } - : qconid { $1 } - | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - -con :: { Located RdrName } - : conid { $1 } - | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } - -con_list :: { Located [Located RdrName] } -con_list : con { sL1 $1 [$1] } - | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> ($1 : unLoc $3)) } - --- See Note [ExplicitTuple] in GHC.Hs.Expr -sysdcon_nolist :: { Located DataCon } -- Wired in data constructors - : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] } - | '(' commas ')' {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) - (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } - | '(#' commas '#)' {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) - (mo $1:mc $3:(mcommas (fst $2))) } - --- See Note [Empty lists] in GHC.Hs.Expr -sysdcon :: { Located DataCon } - : sysdcon_nolist { $1 } - | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] } - -conop :: { Located RdrName } - : consym { $1 } - | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qconop :: { Located RdrName } - : qconsym { $1 } - | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - ----------------------------------------------------------------------------- --- Type constructors - - --- See Note [Unit tuples] in GHC.Hs.Types for the distinction --- between gtycon and ntgtycon -gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples - : ntgtycon { $1 } - | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) - [mop $1,mcp $2] } - | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) - [mo $1,mc $2] } - -ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples - : oqtycon { $1 } - | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed - (snd $2 + 1))) - (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed - (snd $2 + 1))) - (mo $1:mc $3:(mcommas (fst $2))) } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) - [mop $1,mu AnnRarrow $2,mcp $3] } - | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } - -oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; - -- These can appear in export lists - : qtycon { $1 } - | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - -oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mistaken - -- for variable constructor in export lists - -- see Note [Type constructors in export list] - : qtycon { $1 } - | '(' QCONSYM ')' {% let { name :: Located RdrName - ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) } - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' CONSYM ')' {% let { name :: Located RdrName - ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) } - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' ':' ')' {% let { name :: Located RdrName - ; name = sL1 $2 $! consDataCon_RDR } - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] } - -{- Note [Type constructors in export list] -~~~~~~~~~~~~~~~~~~~~~ -Mixing type constructors and data constructors in export lists introduces -ambiguity in grammar: e.g. (*) may be both a type constructor and a function. - --XExplicitNamespaces allows to disambiguate by explicitly prefixing type -constructors with 'type' keyword. - -This ambiguity causes reduce/reduce conflicts in parser, which are always -resolved in favour of data constructors. To get rid of conflicts we demand -that ambiguous type constructors (those, which are formed by the same -productions as variable constructors) are always prefixed with 'type' keyword. -Unambiguous type constructors may occur both with or without 'type' keyword. - -Note that in the parser we still parse data constructors as type -constructors. As such, they still end up in the type constructor namespace -until after renaming when we resolve the proper namespace for each exported -child. --} - -qtyconop :: { Located RdrName } -- Qualified or unqualified - : qtyconsym { $1 } - | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qtycon :: { Located RdrName } -- Qualified or unqualified - : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } - | tycon { $1 } - -qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar noExtField NotPromoted $1) } - | qtycon docprev { sLL $1 $> (HsDocTy noExtField (sL1 $1 (HsTyVar noExtField NotPromoted $1)) $2) } - -tycon :: { Located RdrName } -- Unqualified - : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } - -qtyconsym :: { Located RdrName } - : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) } - | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) } - | tyconsym { $1 } - -tyconsym :: { Located RdrName } - : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } - | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) } - | ':' { sL1 $1 $! consDataCon_RDR } - | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } - | '!' { sL1 $1 $! mkUnqual tcClsName (fsLit "!") } - | '.' { sL1 $1 $! mkUnqual tcClsName (fsLit ".") } - | '~' { sL1 $1 $ eqTyCon_RDR } - - ------------------------------------------------------------------------------ --- Operators - -op :: { Located RdrName } -- used in infix decls - : varop { $1 } - | conop { $1 } - | '->' { sL1 $1 $ getRdrName funTyCon } - | '~' { sL1 $1 $ eqTyCon_RDR } - -varop :: { Located RdrName } - : varsym { $1 } - | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qop :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections - : qvarop { mkHsVarOpPV $1 } - | qconop { mkHsConOpPV $1 } - | hole_op { $1 } - -qopm :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections - : qvaropm { mkHsVarOpPV $1 } - | qconop { mkHsConOpPV $1 } - | hole_op { $1 } - -hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections -hole_op : '`' '_' '`' { amms (mkHsInfixHolePV (comb2 $1 $>)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qvarop :: { Located RdrName } - : qvarsym { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -qvaropm :: { Located RdrName } - : qvarsym_no_minus { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - ------------------------------------------------------------------------------ --- Type variables - -tyvar :: { Located RdrName } -tyvar : tyvarid { $1 } - -tyvarop :: { Located RdrName } -tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -tyvarid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") } - -- If this changes relative to varid, update 'checkRuleTyVarBndrNames' in RdrHsSyn.hs - -- See Note [Parsing explicit foralls in Rules] - ------------------------------------------------------------------------------ --- Variables - -var :: { Located RdrName } - : varid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - - -- Lexing type applications depends subtly on what characters can possibly - -- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar. - -- If you're changing this, please see Note [Lexing type applications] in - -- Lexer.x. -qvar :: { Located RdrName } - : qvarid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } --- We've inlined qvarsym here so that the decision about --- whether it's a qvar or a var can be postponed until --- *after* we see the close paren. - -qvarid :: { Located RdrName } - : varid { $1 } - | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } - --- Note that 'role' and 'family' get lexed separately regardless of --- the use of extensions. However, because they are listed here, --- this is OK and they can be used as normal varids. --- See Note [Lexing type pseudo-keywords] in Lexer.x -varid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible")} - | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") } - | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") } - | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") } - -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames' in RdrHsSyn.hs - -- See Note [Parsing explicit foralls in Rules] - -qvarsym :: { Located RdrName } - : varsym { $1 } - | qvarsym1 { $1 } - -qvarsym_no_minus :: { Located RdrName } - : varsym_no_minus { $1 } - | qvarsym1 { $1 } - -qvarsym1 :: { Located RdrName } -qvarsym1 : QVARSYM { sL1 $1 $ mkQual varName (getQVARSYM $1) } - -varsym :: { Located RdrName } - : varsym_no_minus { $1 } - | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") } - -varsym_no_minus :: { Located RdrName } -- varsym not including '-' - : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) } - | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) } - - --- These special_ids are treated as keywords in various places, --- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and --- 'anyclass', whose treatment differs depending on context -special_id :: { Located FastString } -special_id - : 'as' { sL1 $1 (fsLit "as") } - | 'qualified' { sL1 $1 (fsLit "qualified") } - | 'hiding' { sL1 $1 (fsLit "hiding") } - | 'export' { sL1 $1 (fsLit "export") } - | 'label' { sL1 $1 (fsLit "label") } - | 'dynamic' { sL1 $1 (fsLit "dynamic") } - | 'stdcall' { sL1 $1 (fsLit "stdcall") } - | 'ccall' { sL1 $1 (fsLit "ccall") } - | 'capi' { sL1 $1 (fsLit "capi") } - | 'prim' { sL1 $1 (fsLit "prim") } - | 'javascript' { sL1 $1 (fsLit "javascript") } - | 'group' { sL1 $1 (fsLit "group") } - | 'stock' { sL1 $1 (fsLit "stock") } - | 'anyclass' { sL1 $1 (fsLit "anyclass") } - | 'via' { sL1 $1 (fsLit "via") } - | 'unit' { sL1 $1 (fsLit "unit") } - | 'dependency' { sL1 $1 (fsLit "dependency") } - | 'signature' { sL1 $1 (fsLit "signature") } - -special_sym :: { Located FastString } -special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } - | '.' { sL1 $1 (fsLit ".") } - | '*' { sL1 $1 (fsLit (starSym (isUnicode $1))) } - ------------------------------------------------------------------------------ --- Data constructors - -qconid :: { Located RdrName } -- Qualified or unqualified - : conid { $1 } - | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) } - -conid :: { Located RdrName } - : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) } - -qconsym :: { Located RdrName } -- Qualified or unqualified - : consym { $1 } - | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) } - -consym :: { Located RdrName } - : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) } - - -- ':' means only list cons - | ':' { sL1 $1 $ consDataCon_RDR } - - ------------------------------------------------------------------------------ --- Literals - -literal :: { Located (HsLit GhcPs) } - : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 } - | STRING { sL1 $1 $ HsString (getSTRINGs $1) - $ getSTRING $1 } - | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1) - $ getPRIMINTEGER $1 } - | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1) - $ getPRIMWORD $1 } - | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1) - $ getPRIMCHAR $1 } - | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1) - $ getPRIMSTRING $1 } - | PRIMFLOAT { sL1 $1 $ HsFloatPrim noExtField $ getPRIMFLOAT $1 } - | PRIMDOUBLE { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 } - ------------------------------------------------------------------------------ --- Layout - -close :: { () } - : vccurly { () } -- context popped in lexer. - | error {% popContext } - ------------------------------------------------------------------------------ --- Miscellaneous (mostly renamings) - -modid :: { Located ModuleName } - : CONID { sL1 $1 $ mkModuleNameFS (getCONID $1) } - | QCONID { sL1 $1 $ let (mod,c) = getQCONID $1 in - mkModuleNameFS - (mkFastString - (unpackFS mod ++ '.':unpackFS c)) - } - -commas :: { ([SrcSpan],Int) } -- One or more commas - : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) } - | ',' { ([gl $1],1) } - -bars0 :: { ([SrcSpan],Int) } -- Zero or more bars - : bars { $1 } - | { ([], 0) } - -bars :: { ([SrcSpan],Int) } -- One or more bars - : bars '|' { ((fst $1)++[gl $2],snd $1 + 1) } - | '|' { ([gl $1],1) } - ------------------------------------------------------------------------------ --- Documentation comments - -docnext :: { LHsDocString } - : DOCNEXT {% return (sL1 $1 (mkHsDocString (getDOCNEXT $1))) } - -docprev :: { LHsDocString } - : DOCPREV {% return (sL1 $1 (mkHsDocString (getDOCPREV $1))) } - -docnamed :: { Located (String, HsDocString) } - : DOCNAMED {% - let string = getDOCNAMED $1 - (name, rest) = break isSpace string - in return (sL1 $1 (name, mkHsDocString rest)) } - -docsection :: { Located (Int, HsDocString) } - : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in - return (sL1 $1 (n, mkHsDocString doc)) } - -moduleheader :: { Maybe LHsDocString } - : DOCNEXT {% let string = getDOCNEXT $1 in - return (Just (sL1 $1 (mkHsDocString string))) } - -maybe_docprev :: { Maybe LHsDocString } - : docprev { Just $1 } - | {- empty -} { Nothing } - -maybe_docnext :: { Maybe LHsDocString } - : docnext { Just $1 } - | {- empty -} { Nothing } - -{ -happyError :: P a -happyError = srcParseFail - -getVARID (dL->L _ (ITvarid x)) = x -getCONID (dL->L _ (ITconid x)) = x -getVARSYM (dL->L _ (ITvarsym x)) = x -getCONSYM (dL->L _ (ITconsym x)) = x -getQVARID (dL->L _ (ITqvarid x)) = x -getQCONID (dL->L _ (ITqconid x)) = x -getQVARSYM (dL->L _ (ITqvarsym x)) = x -getQCONSYM (dL->L _ (ITqconsym x)) = x -getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x -getLABELVARID (dL->L _ (ITlabelvarid x)) = x -getCHAR (dL->L _ (ITchar _ x)) = x -getSTRING (dL->L _ (ITstring _ x)) = x -getINTEGER (dL->L _ (ITinteger x)) = x -getRATIONAL (dL->L _ (ITrational x)) = x -getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x -getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x -getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x -getPRIMWORD (dL->L _ (ITprimword _ x)) = x -getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x -getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x -getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x -getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x -getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) -getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) -getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x - -getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x -getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x -getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x -getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x) - -getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src -getCHARs (dL->L _ (ITchar src _)) = src -getSTRINGs (dL->L _ (ITstring src _)) = src -getPRIMCHARs (dL->L _ (ITprimchar src _)) = src -getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src -getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src -getPRIMWORDs (dL->L _ (ITprimword src _)) = src - --- See Note [Pragma source text] in BasicTypes for the following -getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src -getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src -getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src -getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src -getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src -getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src -getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src -getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src -getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src -getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src -getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src -getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src -getANN_PRAGs (dL->L _ (ITann_prag src)) = src -getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src -getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src -getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src -getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src -getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src -getCTYPEs (dL->L _ (ITctype src)) = src - -getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) - -isUnicode :: Located Token -> Bool -isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax -isUnicode _ = False - -hasE :: Located Token -> Bool -hasE (dL->L _ (ITopenExpQuote HasE _)) = True -hasE (dL->L _ (ITopenTExpQuote HasE)) = True -hasE _ = False - -getSCC :: Located Token -> P FastString -getSCC lt = do let s = getSTRING lt - err = "Spaces are not allowed in SCCs" - -- We probably actually want to be more restrictive than this - if ' ' `elem` unpackFS s - then addFatalError (getLoc lt) (text err) - else return s - --- Utilities for combining source spans -comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan -comb2 a b = a `seq` b `seq` combineLocs a b - -comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> c -> SrcSpan -comb3 a b c = a `seq` b `seq` c `seq` - combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) - -comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) => - a -> b -> c -> d -> SrcSpan -comb4 a b c d = a `seq` b `seq` c `seq` d `seq` - (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ - combineSrcSpans (getLoc c) (getLoc d)) - -comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan -comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq` - (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ - combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e)) - --- strict constructor version: -{-# INLINE sL #-} -sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -sL span a = span `seq` a `seq` cL span a - --- See Note [Adding location info] for how these utility functions are used - --- replaced last 3 CPP macros in this file -{-# INLINE sL0 #-} -sL0 :: HasSrcSpan a => SrcSpanLess a -> a -sL0 = cL noSrcSpan -- #define L0 L noSrcSpan - -{-# INLINE sL1 #-} -sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b -sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sLL #-} -sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> SrcSpanLess c -> c -sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) - -{- Note [Adding location info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This is done using the three functions below, sL0, sL1 -and sLL. Note that these functions were mechanically -converted from the three macros that used to exist before, -namely L0, L1 and LL. - -They each add a SrcSpan to their argument. - - sL0 adds 'noSrcSpan', used for empty productions - -- This doesn't seem to work anymore -=chak - - sL1 for a production with a single token on the lhs. Grabs the SrcSpan - from that token. - - sLL for a production with >1 token on the lhs. Makes up a SrcSpan from - the first and last tokens. - -These suffice for the majority of cases. However, we must be -especially careful with empty productions: sLL won't work if the first -or last token on the lhs can represent an empty span. In these cases, -we have to calculate the span using more of the tokens from the lhs, eg. - - | 'newtype' tycl_hdr '=' newconstr deriving - { L (comb3 $1 $4 $5) - (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } - -We provide comb3 and comb4 functions which are useful in such cases. - -Be careful: there's no checking that you actually got this right, the -only symptom will be that the SrcSpans of your syntax will be -incorrect. - --} - --- Make a source location for the file. We're a bit lazy here and just --- make a point SrcSpan at line 1, column 0. Strictly speaking we should --- try to find the span of the whole file (ToDo). -fileSrcSpan :: P SrcSpan -fileSrcSpan = do - l <- getRealSrcLoc; - let loc = mkSrcLoc (srcLocFile l) 1 1; - return (mkSrcSpan loc loc) - --- Hint about the MultiWayIf extension -hintMultiWayIf :: SrcSpan -> P () -hintMultiWayIf span = do - mwiEnabled <- getBit MultiWayIfBit - unless mwiEnabled $ addError span $ - text "Multi-way if-expressions need MultiWayIf turned on" - --- Hint about explicit-forall -hintExplicitForall :: Located Token -> P () -hintExplicitForall tok = do - forall <- getBit ExplicitForallBit - rulePrag <- getBit InRulePragBit - unless (forall || rulePrag) $ addError (getLoc tok) $ vcat - [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type" - , text "Perhaps you intended to use RankNTypes or a similar language" - , text "extension to enable explicit-forall syntax:" <+> - forallSymDoc <+> text ". " - ] - where - forallSymDoc = text (forallSym (isUnicode tok)) - --- When two single quotes don't followed by tyvar or gtycon, we report the --- error as empty character literal, or TH quote that missing proper type --- variable or constructor. See #13450. -reportEmptyDoubleQuotes :: SrcSpan -> P a -reportEmptyDoubleQuotes span = do - thQuotes <- getBit ThQuotesBit - if thQuotes - then addFatalError span $ vcat - [ text "Parser error on `''`" - , text "Character literals may not be empty" - , text "Or perhaps you intended to use quotation syntax of TemplateHaskell," - , text "but the type variable or constructor is missing" - ] - else addFatalError span $ vcat - [ text "Parser error on `''`" - , text "Character literals may not be empty" - ] - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ - -For the general principles of the following routines, see Note [Api annotations] -in ApiAnnotation.hs - --} - --- |Construct an AddAnn from the annotation keyword and the location --- of the keyword itself -mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn -mj a l = AddAnn a (gl l) - -mjL :: AnnKeywordId -> SrcSpan -> AddAnn -mjL = AddAnn - - - --- |Construct an AddAnn from the annotation keyword and the Located Token. If --- the token has a unicode equivalent and this has been used, provide the --- unicode variant of the annotation. -mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l - --- | If the 'Token' is using its unicode variant return the unicode variant of --- the annotation -toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId -toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a - -gl :: HasSrcSpan a => a -> SrcSpan -gl = getLoc - --- |Add an annotation to the located element, and return the located --- element as a pass through -aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a -aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a - --- |Add an annotation to a located element resulting from a monadic action -am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a -am a (b,s) = do - av@(dL->L l _) <- a - addAnnotation l b (gl s) - return av - --- | Add a list of AddAnns to the given AST element. For example, --- the parsing rule for @let@ looks like: --- --- @ --- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) --- (mj AnnLet $1:mj AnnIn $3 --- :(fst $ unLoc $2)) } --- @ --- --- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well --- as any annotations that may arise in the binds. This will include open --- and closing braces if they are used to delimit the let expressions. --- -ams :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m a -ams a@(dL->L l _) bs = addAnnsAt l bs >> return a - -amsL :: SrcSpan -> [AddAnn] -> P () -amsL sp bs = addAnnsAt sp bs >> return () - --- |Add all [AddAnn] to an AST element, and wrap it in a 'Just' -ajs :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m (Maybe a) -ajs a bs = Just <$> ams a bs - --- |Add a list of AddAnns to the given AST element, where the AST element is the --- result of a monadic action -amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a -amms a bs = do { av@(dL->L l _) <- a - ; addAnnsAt l bs - ; return av } - --- |Add a list of AddAnns to the AST element, and return the element as a --- OrdList -amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a) -amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a) - --- |Synonyms for AddAnn versions of AnnOpen and AnnClose -mo,mc :: Located Token -> AddAnn -mo ll = mj AnnOpen ll -mc ll = mj AnnClose ll - -moc,mcc :: Located Token -> AddAnn -moc ll = mj AnnOpenC ll -mcc ll = mj AnnCloseC ll - -mop,mcp :: Located Token -> AddAnn -mop ll = mj AnnOpenP ll -mcp ll = mj AnnCloseP ll - -mos,mcs :: Located Token -> AddAnn -mos ll = mj AnnOpenS ll -mcs ll = mj AnnCloseS ll - --- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma --- entry for each SrcSpan -mcommas :: [SrcSpan] -> [AddAnn] -mcommas ss = map (mjL AnnCommaTuple) ss - --- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar --- entry for each SrcSpan -mvbars :: [SrcSpan] -> [AddAnn] -mvbars ss = map (mjL AnnVbar) ss - --- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: HasSrcSpan a => OrdList a -> SrcSpan -oll l = - if isNilOL l then noSrcSpan - else getLoc (lastOL l) - --- |Add a semicolon annotation in the right place in a list. If the --- leading list is empty, add it to the tail -asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P() -asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls -asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls -} diff --git a/parser/RdrHsSyn.hs b/parser/RdrHsSyn.hs deleted file mode 100644 --- a/parser/RdrHsSyn.hs +++ /dev/null @@ -1,3280 +0,0 @@ --- --- (c) The University of Glasgow 2002-2006 --- - --- Functions over HsSyn specialised to RdrName. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module RdrHsSyn ( - mkHsOpApp, - mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkSpliceDecl, - mkRoleAnnotDecl, - mkClassDecl, - mkTyData, mkDataFamInst, - mkTySynonym, mkTyFamInstEqn, - mkStandaloneKindSig, - mkTyFamInst, - mkFamDecl, mkLHsSigType, - mkInlinePragma, - mkPatSynMatchGroup, - mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkTyClD, mkInstD, - mkRdrRecordCon, mkRdrRecordUpd, - setRdrNameSpace, - filterCTuple, - - cvBindGroup, - cvBindsAndSigs, - cvTopDecls, - placeHolderPunRhs, - - -- Stuff to do with Foreign declarations - mkImport, - parseCImport, - mkExport, - mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName - mkConDeclH98, - - -- Bunch of functions in the parser monad for - -- checking and constructing values - checkImportDecl, - checkExpBlockArguments, - checkPrecP, -- Int -> P Int - checkContext, -- HsType -> P HsContext - checkPattern, -- HsExp -> P HsPat - checkPattern_msg, - isBangRdr, - isTildeRdr, - checkMonadComp, -- P (HsStmtContext RdrName) - checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - checkValSigLhs, - LRuleTyTmVar, RuleTyTmVar(..), - mkRuleBndrs, mkRuleTyVarBndrs, - checkRuleTyVarBndrNames, - checkRecordSyntax, - checkEmptyGADTs, - addFatalError, hintBangPat, - TyEl(..), mergeOps, mergeDataCon, - - -- Help with processing exports - ImpExpSubSpec(..), - ImpExpQcSpec(..), - mkModuleImpExp, - mkTypeImpExp, - mkImpExpSubSpec, - checkImportSpec, - - -- Token symbols - forallSym, - starSym, - - -- Warnings and errors - warnStarIsType, - warnPrepositiveQualifiedModule, - failOpFewArgs, - failOpNotEnabledImportQualifiedPost, - failOpImportQualifiedTwice, - - SumOrTuple (..), - - -- Expression/command/pattern ambiguity resolution - PV, - runPV, - ECP(ECP, runECP_PV), - runECP_P, - DisambInfixOp(..), - DisambECP(..), - ecpFromExp, - ecpFromCmd, - PatBuilder, - patBuilderBang, - - ) where - -import GhcPrelude -import GHC.Hs -- Lots of it -import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import DataCon ( DataCon, dataConTyCon ) -import ConLike ( ConLike(..) ) -import CoAxiom ( Role, fsFromRole ) -import RdrName -import Name -import BasicTypes -import TcEvidence ( idHsWrapper ) -import Lexer -import Lexeme ( isLexCon ) -import Type ( TyThing(..), funTyCon ) -import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, - nilDataConName, nilDataConKey, - listTyConName, listTyConKey, eqTyCon_RDR, - tupleTyConName, cTupleTyConNameArity_maybe ) -import ForeignCall -import PrelNames ( allNameStrings ) -import SrcLoc -import Unique ( hasKey ) -import OrdList ( OrdList, fromOL ) -import Bag ( emptyBag, consBag ) -import Outputable -import FastString -import Maybes -import Util -import ApiAnnotation -import Data.List -import DynFlags ( WarningFlag(..), DynFlags ) -import ErrUtils ( Messages ) - -import Control.Monad -import Text.ParserCombinators.ReadP as ReadP -import Data.Char -import qualified Data.Monoid as Monoid -import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) - -#include "HsVersions.h" - - -{- ********************************************************************** - - Construction functions for Rdr stuff - - ********************************************************************* -} - --- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and --- datacon by deriving them from the name of the class. We fill in the names --- for the tycon and datacon corresponding to the class, by deriving them --- from the name of the class itself. This saves recording the names in the --- interface file (which would be equally good). - --- Similarly for mkConDecl, mkClassOpSig and default-method names. - --- *** See Note [The Naming story] in GHC.Hs.Decls **** - -mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d) - -mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkInstD (dL->L loc d) = cL loc (InstD noExtField d) - -mkClassDecl :: SrcSpan - -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) - -> Located (a,[LHsFunDep GhcPs]) - -> OrdList (LHsDecl GhcPs) - -> P (LTyClDecl GhcPs) - -mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls - = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls - ; let cxt = fromMaybe (noLoc []) mcxt - ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams - ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt - , tcdLName = cls, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdFDs = snd (unLoc fds) - , tcdSigs = mkClassOpSigs sigs - , tcdMeths = binds - , tcdATs = ats, tcdATDefs = at_defs - , tcdDocs = docs })) } - -mkTyData :: SrcSpan - -> NewOrData - -> Maybe (Located CType) - -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) - -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] - -> HsDeriving GhcPs - -> P (LTyClDecl GhcPs) -mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) - ksig data_cons maybe_deriv - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataDecl { tcdDExt = noExtField, - tcdLName = tc, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn })) } - -mkDataDefn :: NewOrData - -> Maybe (Located CType) - -> Maybe (LHsContext GhcPs) - -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] - -> HsDeriving GhcPs - -> P (HsDataDefn GhcPs) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - = do { checkDatatypeContext mcxt - ; let cxt = fromMaybe (noLoc []) mcxt - ; return (HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = cxt - , dd_cons = data_cons - , dd_kindSig = ksig - , dd_derivs = maybe_deriv }) } - - -mkTySynonym :: SrcSpan - -> LHsType GhcPs -- LHS - -> LHsType GhcPs -- RHS - -> P (LTyClDecl GhcPs) -mkTySynonym loc lhs rhs - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (SynDecl { tcdSExt = noExtField - , tcdLName = tc, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdRhs = rhs })) } - -mkStandaloneKindSig - :: SrcSpan - -> Located [Located RdrName] -- LHS - -> LHsKind GhcPs -- RHS - -> P (LStandaloneKindSig GhcPs) -mkStandaloneKindSig loc lhs rhs = - do { vs <- mapM check_lhs_name (unLoc lhs) - ; v <- check_singular_lhs (reverse vs) - ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } - where - check_lhs_name v@(unLoc->name) = - if isUnqual name && isTcOcc (rdrNameOcc name) - then return v - else addFatalError (getLoc v) $ - hang (text "Expected an unqualified type constructor:") 2 (ppr v) - check_singular_lhs vs = - case vs of - [] -> panic "mkStandaloneKindSig: empty left-hand side" - [v] -> return v - _ -> addFatalError (getLoc lhs) $ - vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") - 2 (pprWithCommas ppr vs) - , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] - -mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] - -> LHsType GhcPs - -> LHsType GhcPs - -> P (TyFamInstEqn GhcPs,[AddAnn]) -mkTyFamInstEqn bndrs lhs rhs - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; return (mkHsImplicitBndrs - (FamEqn { feqn_ext = noExtField - , feqn_tycon = tc - , feqn_bndrs = bndrs - , feqn_pats = tparams - , feqn_fixity = fixity - , feqn_rhs = rhs }), - ann) } - -mkDataFamInst :: SrcSpan - -> NewOrData - -> Maybe (Located CType) - -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs] - , LHsType GhcPs) - -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] - -> HsDeriving GhcPs - -> P (LInstDecl GhcPs) -mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) - ksig data_cons maybe_deriv - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs - (FamEqn { feqn_ext = noExtField - , feqn_tycon = tc - , feqn_bndrs = bndrs - , feqn_pats = tparams - , feqn_fixity = fixity - , feqn_rhs = defn }))))) } - -mkTyFamInst :: SrcSpan - -> TyFamInstEqn GhcPs - -> P (LInstDecl GhcPs) -mkTyFamInst loc eqn - = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn))) - -mkFamDecl :: SrcSpan - -> FamilyInfo GhcPs - -> LHsType GhcPs -- LHS - -> Located (FamilyResultSig GhcPs) -- Optional result signature - -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation - -> P (LTyClDecl GhcPs) -mkFamDecl loc info lhs ksig injAnn - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (FamDecl noExtField (FamilyDecl - { fdExt = noExtField - , fdInfo = info, fdLName = tc - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = ksig - , fdInjectivityAnn = injAnn }))) } - where - equals_or_where = case info of - DataFamily -> empty - OpenTypeFamily -> empty - ClosedTypeFamily {} -> whereDots - -mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs --- If the user wrote --- [pads| ... ] then return a QuasiQuoteD --- $(e) then return a SpliceD --- but if she wrote, say, --- f x then behave as if she'd written $(f x) --- ie a SpliceD --- --- Typed splices are not allowed at the top level, thus we do not represent them --- as spliced declaration. See #10945 -mkSpliceDecl lexpr@(dL->L loc expr) - | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) - - | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) - - | otherwise - = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice NoParens lexpr)) - ImplicitSplice) - -mkRoleAnnotDecl :: SrcSpan - -> Located RdrName -- type being annotated - -> [Located (Maybe FastString)] -- roles - -> P (LRoleAnnotDecl GhcPs) -mkRoleAnnotDecl loc tycon roles - = do { roles' <- mapM parse_role roles - ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' } - where - role_data_type = dataTypeOf (undefined :: Role) - all_roles = map fromConstr $ dataTypeConstrs role_data_type - possible_roles = [(fsFromRole role, role) | role <- all_roles] - - parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing - parse_role (dL->L loc_role (Just role)) - = case lookup role possible_roles of - Just found_role -> return $ cL loc_role $ Just found_role - Nothing -> - let nearby = fuzzyLookup (unpackFS role) - (mapFst unpackFS possible_roles) - in - addFatalError loc_role - (text "Illegal role name" <+> quotes (ppr role) $$ - suggestions nearby) - parse_role _ = panic "parse_role: Impossible Match" - -- due to #15884 - - suggestions [] = empty - suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) - -- will this last case ever happen?? - suggestions list = hang (text "Perhaps you meant one of these:") - 2 (pprWithCommas (quotes . ppr) list) - -{- ********************************************************************** - - #cvBinds-etc# Converting to @HsBinds@, etc. - - ********************************************************************* -} - --- | Function definitions are restructured here. Each is assumed to be recursive --- initially, and non recursive definitions are discovered by the dependency --- analyser. - - --- | Groups together bindings for a single function -cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] -cvTopDecls decls = go (fromOL decls) - where - go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] - go [] = [] - go ((dL->L l (ValD x b)) : ds) - = cL l' (ValD x b') : go ds' - where (dL->L l' b', ds') = getMonoBind (cL l b) ds - go (d : ds) = d : go ds - --- Declaration list may only contain value bindings and signatures. -cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) -cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts - , dfam_insts, _) <- cvBindsAndSigs binding - ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) - return $ ValBinds noExtField mbs sigs } - -cvBindsAndSigs :: OrdList (LHsDecl GhcPs) - -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] - , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) --- Input decls contain just value bindings and signatures --- and in case of class or instance declarations also --- associated type declarations. They might also contain Haddock comments. -cvBindsAndSigs fb = go (fromOL fb) - where - go [] = return (emptyBag, [], [], [], [], []) - go ((dL->L l (ValD _ b)) : ds) - = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' - ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } - where - (b', ds') = getMonoBind (cL l b) ds - go ((dL->L l decl) : ds) - = do { (bs, ss, ts, tfis, dfis, docs) <- go ds - ; case decl of - SigD _ s - -> return (bs, cL l s : ss, ts, tfis, dfis, docs) - TyClD _ (FamDecl _ t) - -> return (bs, ss, cL l t : ts, tfis, dfis, docs) - InstD _ (TyFamInstD { tfid_inst = tfi }) - -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) - InstD _ (DataFamInstD { dfid_inst = dfi }) - -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) - DocD _ d - -> return (bs, ss, ts, tfis, dfis, cL l d : docs) - SpliceD _ d - -> addFatalError l $ - hang (text "Declaration splices are allowed only" <+> - text "at the top level:") - 2 (ppr d) - _ -> pprPanic "cvBindsAndSigs" (ppr decl) } - ------------------------------------------------------------------------------ --- Group function bindings into equation groups - -getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] - -> (LHsBind GhcPs, [LHsDecl GhcPs]) --- Suppose (b',ds') = getMonoBind b ds --- ds is a list of parsed bindings --- b is a MonoBinds that has just been read off the front - --- Then b' is the result of grouping more equations from ds that --- belong with b into a single MonoBinds, and ds' is the depleted --- list of parsed bindings. --- --- All Haddock comments between equations inside the group are --- discarded. --- --- No AndMonoBinds or EmptyMonoBinds here; just single equations - -getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) - , fun_matches = - MG { mg_alts = (dL->L _ mtchs1) } })) - binds - | has_args mtchs1 - = go mtchs1 loc1 binds [] - where - go mtchs loc - ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) - , fun_matches = - MG { mg_alts = (dL->L _ mtchs2) } }))) - : binds) _ - | f1 == f2 = go (mtchs2 ++ mtchs) - (combineSrcSpans loc loc2) binds [] - go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls - = let doc_decls' = doc_decl : doc_decls - in go mtchs (combineSrcSpans loc loc2) binds doc_decls' - go mtchs loc binds doc_decls - = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) - , (reverse doc_decls) ++ binds) - -- Reverse the final matches, to get it back in the right order - -- Do the same thing with the trailing doc comments - -getMonoBind bind binds = (bind, binds) - -has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool -has_args [] = panic "RdrHsSyn:has_args" -has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) - -- Don't group together FunBinds if they have - -- no arguments. This is necessary now that variable bindings - -- with no arguments are now treated as FunBinds rather - -- than pattern bindings (tests/rename/should_fail/rnfail002). -has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec -has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 - -{- ********************************************************************** - - #PrefixToHS-utils# Utilities for conversion - - ********************************************************************* -} - -{- Note [Parsing data constructors is hard] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The problem with parsing data constructors is that they look a lot like types. -Compare: - - (s1) data T = C t1 t2 - (s2) type T = C t1 t2 - -Syntactically, there's little difference between these declarations, except in -(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. - -This similarity would pose no problem if we knew ahead of time if we are -parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple -(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing -data constructors, and in other contexts (e.g. 'type' declarations) assume we -are parsing type constructors. - -This simple rule does not work because of two problematic cases: - - (p1) data T = C t1 t2 :+ t3 - (p2) data T = C t1 t2 => t3 - -In (p1) we encounter (:+) and it turns out we are parsing an infix data -declaration, so (C t1 t2) is a type and 'C' is a type constructor. -In (p2) we encounter (=>) and it turns out we are parsing an existential -context, so (C t1 t2) is a constraint and 'C' is a type constructor. - -As the result, in order to determine whether (C t1 t2) declares a data -constructor, a type, or a context, we would need unlimited lookahead which -'happy' is not so happy with. - -To further complicate matters, the interpretation of (!) and (~) is different -in constructors and types: - - (b1) type T = C ! D - (b2) data T = C ! D - (b3) data T = C ! D => E - -In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At -the same time, in (b2) it is a strictness annotation: 'C' is a data constructor -with a single strict argument 'D'. For the programmer, these cases are usually -easy to tell apart due to whitespace conventions: - - (b2) data T = C !D -- no space after the bang hints that - -- it is a strictness annotation - -For the parser, on the other hand, this whitespace does not matter. We cannot -tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited -lookahead. - -The solution that accounts for all of these issues is to initially parse data -declarations and types as a reversed list of TyEl: - - data TyEl = TyElOpr RdrName - | TyElOpd (HsType GhcPs) - | TyElBang | TyElTilde - | ... - -For example, both occurences of (C ! D) in the following example are parsed -into equal lists of TyEl: - - data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D") - , TyElBang - , TyElOpd (HsTyVar "C") ] - -Note that elements are in reverse order. Also, 'C' is parsed as a type -constructor (HsTyVar) even when it is a data constructor. We fix this in -`tyConToDataCon`. - -By the time the list of TyEl is assembled, we have looked ahead enough to -decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for -data constructors). These functions are where the actual job of parsing is -done. - --} - --- | Reinterpret a type constructor, including type operators, as a data --- constructor. --- See Note [Parsing data constructors is hard] -tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) -tyConToDataCon loc tc - | isTcOcc occ || isDataOcc occ - , isLexCon (occNameFS occ) - = return (cL loc (setRdrNameSpace tc srcDataName)) - - | otherwise - = Left (loc, msg) - where - occ = rdrNameOcc tc - msg = text "Not a data constructor:" <+> quotes (ppr tc) - -mkPatSynMatchGroup :: Located RdrName - -> Located (OrdList (LHsDecl GhcPs)) - -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = - do { matches <- mapM fromDecl (fromOL decls) - ; when (null matches) (wrongNumberErr loc) - ; return $ mkMatchGroup FromSource matches } - where - fromDecl (dL->L loc decl@(ValD _ (PatBind _ - pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) - rhs _))) = - do { unless (name == patsyn_name) $ - wrongNameBindingErr loc decl - ; match <- case details of - PrefixCon pats -> return $ Match { m_ext = noExtField - , m_ctxt = ctxt, m_pats = pats - , m_grhss = rhs } - where - ctxt = FunRhs { mc_fun = ln - , mc_fixity = Prefix - , mc_strictness = NoSrcStrict } - - InfixCon p1 p2 -> return $ Match { m_ext = noExtField - , m_ctxt = ctxt - , m_pats = [p1, p2] - , m_grhss = rhs } - where - ctxt = FunRhs { mc_fun = ln - , mc_fixity = Infix - , mc_strictness = NoSrcStrict } - - RecCon{} -> recordPatSynErr loc pat - ; return $ cL loc match } - fromDecl (dL->L loc decl) = extraDeclErr loc decl - - extraDeclErr loc decl = - addFatalError loc $ - text "pattern synonym 'where' clause must contain a single binding:" $$ - ppr decl - - wrongNameBindingErr loc decl = - addFatalError loc $ - text "pattern synonym 'where' clause must bind the pattern synonym's name" - <+> quotes (ppr patsyn_name) $$ ppr decl - - wrongNumberErr loc = - addFatalError loc $ - text "pattern synonym 'where' clause cannot be empty" $$ - text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) - -recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a -recordPatSynErr loc pat = - addFatalError loc $ - text "record syntax not supported for pattern synonym declarations:" $$ - ppr pat - -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] - -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs - -> ConDecl GhcPs - -mkConDeclH98 name mb_forall mb_cxt args - = ConDeclH98 { con_ext = noExtField - , con_name = name - , con_forall = noLoc $ isJust mb_forall - , con_ex_tvs = mb_forall `orElse` [] - , con_mb_cxt = mb_cxt - , con_args = args - , con_doc = Nothing } - -mkGadtDecl :: [Located RdrName] - -> LHsType GhcPs -- Always a HsForAllTy - -> (ConDecl GhcPs, [AddAnn]) -mkGadtDecl names ty - = (ConDeclGADT { con_g_ext = noExtField - , con_names = names - , con_forall = cL l $ isLHsForAllTy ty' - , con_qvars = mkHsQTvs tvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty - , con_doc = Nothing } - , anns1 ++ anns2) - where - (ty'@(dL->L l _),anns1) = peel_parens ty [] - (tvs, rho) = splitLHsForAllTyInvis ty' - (mcxt, tau, anns2) = split_rho rho [] - - split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann - = (Just cxt, tau, ann) - split_rho (dL->L l (HsParTy _ ty)) ann - = split_rho ty (ann++mkParensApiAnn l) - split_rho tau ann - = (Nothing, tau, ann) - - (args, res_ty) = split_tau tau - - -- See Note [GADT abstract syntax] in GHC.Hs.Decls - split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) - = (RecCon (cL loc rf), res_ty) - split_tau tau - = (PrefixCon [], tau) - - peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty - (ann++mkParensApiAnn l) - peel_parens ty ann = (ty, ann) - - -setRdrNameSpace :: RdrName -> NameSpace -> RdrName --- ^ This rather gruesome function is used mainly by the parser. --- When parsing: --- --- > data T a = T | T1 Int --- --- we parse the data constructors as /types/ because of parser ambiguities, --- so then we need to change the /type constr/ to a /data constr/ --- --- The exact-name case /can/ occur when parsing: --- --- > data [] a = [] | a : [a] --- --- For the exact-name case we return an original name. -setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) -setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) -setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns - | Just thing <- wiredInNameTyThing_maybe n - = setWiredInNameSpace thing ns - -- Preserve Exact Names for wired-in things, - -- notably tuples and lists - - | isExternalName n - = Orig (nameModule n) occ - - | otherwise -- This can happen when quoting and then - -- splicing a fixity declaration for a type - = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) - where - occ = setOccNameSpace ns (nameOccName n) - -setWiredInNameSpace :: TyThing -> NameSpace -> RdrName -setWiredInNameSpace (ATyCon tc) ns - | isDataConNameSpace ns - = ty_con_data_con tc - | isTcClsNameSpace ns - = Exact (getName tc) -- No-op - -setWiredInNameSpace (AConLike (RealDataCon dc)) ns - | isTcClsNameSpace ns - = data_con_ty_con dc - | isDataConNameSpace ns - = Exact (getName dc) -- No-op - -setWiredInNameSpace thing ns - = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) - -ty_con_data_con :: TyCon -> RdrName -ty_con_data_con tc - | isTupleTyCon tc - , Just dc <- tyConSingleDataCon_maybe tc - = Exact (getName dc) - - | tc `hasKey` listTyConKey - = Exact nilDataConName - - | otherwise -- See Note [setRdrNameSpace for wired-in names] - = Unqual (setOccNameSpace srcDataName (getOccName tc)) - -data_con_ty_con :: DataCon -> RdrName -data_con_ty_con dc - | let tc = dataConTyCon dc - , isTupleTyCon tc - = Exact (getName tc) - - | dc `hasKey` nilDataConKey - = Exact listTyConName - - | otherwise -- See Note [setRdrNameSpace for wired-in names] - = Unqual (setOccNameSpace tcClsName (getOccName dc)) - --- | Replaces constraint tuple names with corresponding boxed ones. -filterCTuple :: RdrName -> RdrName -filterCTuple (Exact n) - | Just arity <- cTupleTyConNameArity_maybe n - = Exact $ tupleTyConName BoxedTuple arity -filterCTuple rdr = rdr - - -{- Note [setRdrNameSpace for wired-in names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC.Types, which declares (:), we have - infixr 5 : -The ambiguity about which ":" is meant is resolved by parsing it as a -data constructor, but then using dataTcOccs to try the type constructor too; -and that in turn calls setRdrNameSpace to change the name-space of ":" to -tcClsName. There isn't a corresponding ":" type constructor, but it's painful -to make setRdrNameSpace partial, so we just make an Unqual name instead. It -really doesn't matter! --} - -eitherToP :: Either (SrcSpan, SDoc) a -> P a --- Adapts the Either monad to the P monad -eitherToP (Left (loc, doc)) = addFatalError loc doc -eitherToP (Right thing) = return thing - -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] - -> P ( LHsQTyVars GhcPs -- the synthesized type variables - , [AddAnn] ) -- action which adds annotations --- ^ Check whether the given list of type parameters are all type variables --- (possibly with a kind signature). -checkTyVars pp_what equals_or_where tc tparms - = do { (tvs, anns) <- fmap unzip $ mapM check tparms - ; return (mkHsQTvs tvs, concat anns) } - where - check (HsTypeArg _ ki@(L loc _)) - = addFatalError loc $ - vcat [ text "Unexpected type application" <+> - text "@" <> ppr ki - , text "In the" <+> pp_what <+> - ptext (sLit "declaration for") <+> quotes (ppr tc)] - check (HsValArg ty) = chkParens [] ty - check (HsArgPar sp) = addFatalError sp $ - vcat [text "Malformed" <+> pp_what - <+> text "declaration for" <+> quotes (ppr tc)] - -- Keep around an action for adjusting the annotations of extra parens - chkParens :: [AddAnn] -> LHsType GhcPs - -> P (LHsTyVarBndr GhcPs, [AddAnn]) - chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l - ++ acc) ty - chkParens acc ty = do - tv <- chk ty - return (tv, reverse acc) - - -- Check that the name space is correct! - chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) - chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) - | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k)) - chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) - | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv))) - chk t@(dL->L loc _) - = addFatalError loc $ - vcat [ text "Unexpected type" <+> quotes (ppr t) - , text "In the" <+> pp_what - <+> ptext (sLit "declaration for") <+> quotes tc' - , vcat[ (text "A" <+> pp_what - <+> ptext (sLit "declaration should have form")) - , nest 2 - (pp_what - <+> tc' - <+> hsep (map text (takeList tparms allNameStrings)) - <+> equals_or_where) ] ] - - -- Avoid printing a constraint tuple in the error message. Print - -- a plain old tuple instead (since that's what the user probably - -- wrote). See #14907 - tc' = ppr $ fmap filterCTuple tc - - - -whereDots, equalsDots :: SDoc --- Second argument to checkTyVars -whereDots = text "where ..." -equalsDots = text "= ..." - -checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () -checkDatatypeContext Nothing = return () -checkDatatypeContext (Just c) - = do allowed <- getBit DatatypeContextsBit - unless allowed $ - addError (getLoc c) - (text "Illegal datatype context (use DatatypeContexts):" - <+> pprLHsContext c) - -type LRuleTyTmVar = Located RuleTyTmVar -data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) --- ^ Essentially a wrapper for a @RuleBndr GhcPs@ - --- turns RuleTyTmVars into RuleBnrs - this is straightforward -mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] -mkRuleBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v - cvt_one (RuleTyTmVar v (Just sig)) = - RuleBndrSig noExtField v (mkLHsSigWcType sig) - --- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting -mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] -mkRuleTyVarBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExtField (fmap tm_to_ty v) - cvt_one (RuleTyTmVar v (Just sig)) - = KindedTyVar noExtField (fmap tm_to_ty v) sig - -- takes something in namespace 'varName' to something in namespace 'tvName' - tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) - tm_to_ty _ = panic "mkRuleTyVarBndrs" - --- See note [Parsing explicit foralls in Rules] in Parser.y -checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () -checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) - where check (dL->L loc (Unqual occ)) = do - when ((occNameString occ ==) `any` ["forall","family","role"]) - (addFatalError loc (text $ "parse error on input " - ++ occNameString occ)) - check _ = panic "checkRuleTyVarBndrNames" - -checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) -checkRecordSyntax lr@(dL->L loc r) - = do allowed <- getBit TraditionalRecordSyntaxBit - unless allowed $ addError loc $ - text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r - return lr - --- | Check if the gadt_constrlist is empty. Only raise parse error for --- `data T where` to avoid affecting existing error message, see #8258. -checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) - -> P (Located ([AddAnn], [LConDecl GhcPs])) -checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. - = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax - unless gadtSyntax $ addError span $ vcat - [ text "Illegal keyword 'where' in data declaration" - , text "Perhaps you intended to use GADTs or a similar language" - , text "extension to enable syntax: data T where" - ] - return gadts -checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. - -checkTyClHdr :: Bool -- True <=> class header - -- False <=> type header - -> LHsType GhcPs - -> P (Located RdrName, -- the head symbol (type or class name) - [LHsTypeArg GhcPs], -- parameters of head symbol - LexicalFixity, -- the declaration is in infix format - [AddAnn]) -- API Annotation for HsParTy when stripping parens --- Well-formedness check and decomposition of type and class heads. --- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) --- Int :*: Bool into (:*:, [Int, Bool]) --- returning the pieces -checkTyClHdr is_cls ty - = goL ty [] [] Prefix - where - goL (dL->L l ty) acc ann fix = go l ty acc ann fix - - -- workaround to define '*' despite StarIsType - go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix - = do { warnStarBndr l - ; let name = mkOccName tcClsName (starSym isUni) - ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } - - go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix - | isRdrTc tc = return (ltc, acc, fix, ann) - go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix - | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann) - go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix - go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix - go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix - go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann) - where - arity = length ts - tup_name | is_cls = cTupleTyConName arity - | otherwise = getName (tupleTyCon Boxed arity) - -- See Note [Unit tuples] in GHC.Hs.Types (TODO: is this still relevant?) - go l _ _ _ _ - = addFatalError l (text "Malformed head of type or class declaration:" - <+> ppr ty) - --- | Yield a parse error if we have a function applied directly to a do block --- etc. and BlockArguments is not enabled. -checkExpBlockArguments :: LHsExpr GhcPs -> PV () -checkCmdBlockArguments :: LHsCmd GhcPs -> PV () -(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) - where - checkExpr :: LHsExpr GhcPs -> PV () - checkExpr expr = case unLoc expr of - HsDo _ DoExpr _ -> check "do block" expr - HsDo _ MDoExpr _ -> check "mdo block" expr - HsLam {} -> check "lambda expression" expr - HsCase {} -> check "case expression" expr - HsLamCase {} -> check "lambda-case expression" expr - HsLet {} -> check "let expression" expr - HsIf {} -> check "if expression" expr - HsProc {} -> check "proc expression" expr - _ -> return () - - checkCmd :: LHsCmd GhcPs -> PV () - checkCmd cmd = case unLoc cmd of - HsCmdLam {} -> check "lambda command" cmd - HsCmdCase {} -> check "case command" cmd - HsCmdIf {} -> check "if command" cmd - HsCmdLet {} -> check "let command" cmd - HsCmdDo {} -> check "do command" cmd - _ -> return () - - check :: (HasSrcSpan a, Outputable a) => String -> a -> PV () - check element a = do - blockArguments <- getBit BlockArgumentsBit - unless blockArguments $ - addError (getLoc a) $ - text "Unexpected " <> text element <> text " in function application:" - $$ nest 4 (ppr a) - $$ text "You could write it with parentheses" - $$ text "Or perhaps you meant to enable BlockArguments?" - --- | Validate the context constraints and break up a context into a list --- of predicates. --- --- @ --- (Eq a, Ord b) --> [Eq a, Ord b] --- Eq a --> [Eq a] --- (Eq a) --> [Eq a] --- (((Eq a))) --> [Eq a] --- @ -checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) -checkContext (dL->L l orig_t) - = check [] (cL l orig_t) - where - check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) - -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can - -- be used as context constraints. - = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto () - - check anns (dL->L lp1 (HsParTy _ ty)) - -- to be sure HsParTy doesn't get into the way - = check anns' ty - where anns' = if l == lp1 then anns - else (anns ++ mkParensApiAnn lp1) - - -- no need for anns, returning original - check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t]) - - msg = text "data constructor context" - --- | Check recursively if there are any 'HsDocTy's in the given type. --- This only works on a subset of types produced by 'btype_no_ops' -checkNoDocs :: SDoc -> LHsType GhcPs -> P () -checkNoDocs msg ty = go ty - where - go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki - go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 - go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep - [ text "Unexpected haddock", quotes (ppr ds) - , text "on", msg, quotes (ppr t) ] - go _ = pure () - -checkImportDecl :: Maybe (Located Token) - -> Maybe (Located Token) - -> P () -checkImportDecl mPre mPost = do - let whenJust mg f = maybe (pure ()) f mg - - importQualifiedPostEnabled <- getBit ImportQualifiedPostBit - - -- Error if 'qualified' found in postpostive position and - -- 'ImportQualifiedPost' is not in effect. - whenJust mPost $ \post -> - when (not importQualifiedPostEnabled) $ - failOpNotEnabledImportQualifiedPost (getLoc post) - - -- Error if 'qualified' occurs in both pre and postpositive - -- positions. - whenJust mPost $ \post -> - when (isJust mPre) $ - failOpImportQualifiedTwice (getLoc post) - - -- Warn if 'qualified' found in prepositive position and - -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. - whenJust mPre $ \pre -> - warnPrepositiveQualifiedModule (getLoc pre) - --- ------------------------------------------------------------------------- --- Checking Patterns. - --- We parse patterns as expressions and check for valid patterns below, --- converting the expression into a pattern at the same time. - -checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) -checkPattern = runPV . checkLPat - -checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) -checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) - -checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) -checkLPat e@(dL->L l _) = checkPat l e [] - -checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] - -> PV (LPat GhcPs) -checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args - | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) - | not (null args) && patIsRec c = - localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ - patFail l (ppr e) -checkPat loc e args -- OK to let this happen even if bang-patterns - -- are not enabled, because there is no valid - -- non-bang-pattern parse of (C ! e) - | Just (e', args') <- splitBang e - = do { args'' <- mapM checkLPat args' - ; checkPat loc e' (args'' ++ args) } -checkPat loc (dL->L _ (PatBuilderApp f e)) args - = do p <- checkLPat e - checkPat loc f (p : args) -checkPat loc (dL->L _ e) [] - = do p <- checkAPat loc e - return (cL loc p) -checkPat loc e _ - = patFail loc (ppr e) - -checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) -checkAPat loc e0 = do - nPlusKPatterns <- getBit NPlusKPatternsBit - case e0 of - PatBuilderPat p -> return p - PatBuilderVar x -> return (VarPat noExtField x) - - -- Overloaded numeric patterns (e.g. f 0 x = x) - -- Negation is recorded separately, so that the literal is zero or +ve - -- NB. Negative *primitive* literals are already handled by the lexer - PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) - - PatBuilderBang lb e -- (! x) - -> do { hintBangPat loc e0 - ; e' <- checkLPat e - ; addAnnotation loc AnnBang lb - ; return (BangPat noExtField e') } - - -- n+k patterns - PatBuilderOpApp - (dL->L nloc (PatBuilderVar (dL->L _ n))) - (dL->L _ plus) - (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | nPlusKPatterns && (plus == plus_RDR) - -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) - - PatBuilderOpApp l (dL->L cl c) r - | isRdrDataCon c -> do - l <- checkLPat l - r <- checkLPat r - return (ConPatIn (cL cl c) (InfixCon l r)) - - PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) - _ -> patFail loc (ppr e0) - -placeHolderPunRhs :: DisambECP b => PV (Located b) --- The RHS of a punned record field will be filled in by the renamer --- It's better not to make it an error, in case we want to print it when --- debugging -placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) - -plus_RDR, pun_RDR :: RdrName -plus_RDR = mkUnqual varName (fsLit "+") -- Hack -pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") - -isBangRdr, isTildeRdr :: RdrName -> Bool -isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" -isBangRdr _ = False -isTildeRdr = (==eqTyCon_RDR) - -checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) - -> PV (LHsRecField GhcPs (LPat GhcPs)) -checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) - return (cL l (fld { hsRecFieldArg = p })) - -patFail :: SrcSpan -> SDoc -> PV a -patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e - -patIsRec :: RdrName -> Bool -patIsRec e = e == mkUnqual varName (fsLit "rec") - ---------------------------------------------------------------------------- --- Check Equation Syntax - -checkValDef :: SrcStrictness - -> Located (PatBuilder GhcPs) - -> Maybe (LHsType GhcPs) - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) - -checkValDef _strictness lhs (Just sig) grhss - -- x :: ty = rhs parses as a *pattern* binding - = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat - checkPatBind lhs' grhss - -checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) - = do { mb_fun <- isFunLhs lhs - ; case mb_fun of - Just (fun, is_infix, pats, ann) -> - checkFunBind strictness ann (getLoc lhs) - fun is_infix pats (cL l grhss) - Nothing -> do - lhs' <- checkPattern lhs - checkPatBind lhs' g } - -checkFunBind :: SrcStrictness - -> [AddAnn] - -> SrcSpan - -> Located RdrName - -> LexicalFixity - -> [Located (PatBuilder GhcPs)] - -> Located (GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) -checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) - = do ps <- mapM checkPattern pats - let match_span = combineSrcSpans lhs_loc rhs_span - -- Add back the annotations stripped from any HsPar values in the lhs - -- mapM_ (\a -> a match_span) ann - return (ann, makeFunBind fun - [cL match_span (Match { m_ext = noExtField - , m_ctxt = FunRhs - { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })]) - -- The span of the match covers the entire equation. - -- That isn't quite right, but it'll do for now. - -makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] - -> HsBind GhcPs --- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too -makeFunBind fn ms - = FunBind { fun_ext = noExtField, - fun_id = fn, - fun_matches = mkMatchGroup FromSource ms, - fun_co_fn = idHsWrapper, - fun_tick = [] } - -checkPatBind :: LPat GhcPs - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) -checkPatBind lhs (dL->L _ (_,grhss)) - = return ([],PatBind noExtField lhs grhss ([],[])) - -checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) - | isUnqual v - , not (isDataOcc (rdrNameOcc v)) - = return lrdr - -checkValSigLhs lhs@(dL->L l _) - = addFatalError l ((text "Invalid type signature:" <+> - ppr lhs <+> text ":: ...") - $$ text hint) - where - hint | foreign_RDR `looks_like` lhs - = "Perhaps you meant to use ForeignFunctionInterface?" - | default_RDR `looks_like` lhs - = "Perhaps you meant to use DefaultSignatures?" - | pattern_RDR `looks_like` lhs - = "Perhaps you meant to use PatternSynonyms?" - | otherwise - = "Should be of form :: " - - -- A common error is to forget the ForeignFunctionInterface flag - -- so check for that, and suggest. cf #3805 - -- Sadly 'foreign import' still barfs 'parse error' because - -- 'import' is a keyword - looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s - looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs - looks_like _ _ = False - - foreign_RDR = mkUnqual varName (fsLit "foreign") - default_RDR = mkUnqual varName (fsLit "default") - pattern_RDR = mkUnqual varName (fsLit "pattern") - -checkDoAndIfThenElse - :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) - => a -> Bool -> b -> Bool -> c -> PV () -checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr - | semiThen || semiElse - = do doAndIfThenElse <- getBit DoAndIfThenElseBit - unless doAndIfThenElse $ do - addError (combineLocs guardExpr elseExpr) - (text "Unexpected semi-colons in conditional:" - $$ nest 4 expr - $$ text "Perhaps you meant to use DoAndIfThenElse?") - | otherwise = return () - where pprOptSemi True = semi - pprOptSemi False = empty - expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> - text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> - text "else" <+> ppr elseExpr - - - -- The parser left-associates, so there should - -- not be any OpApps inside the e's -splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) --- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg)) - | isBangRdr (unLoc op) - = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns) - where - l' = combineLocs op arg1 - (arg1,argns) = split_bang r_arg [] - split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es) - split_bang e es = (e,es) -splitBang _ = Nothing - --- See Note [isFunLhs vs mergeDataCon] -isFunLhs :: Located (PatBuilder GhcPs) - -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) --- A variable binding is parsed as a FunBind. --- Just (fun, is_infix, arg_pats) if e is a function LHS --- --- The whole LHS is parsed as a single expression. --- Any infix operators on the LHS will parse left-associatively --- E.g. f !x y !z --- will parse (rather strangely) as --- (f ! x y) ! z --- It's up to isFunLhs to sort out the mess --- --- a .!. !b - -isFunLhs e = go e [] [] - where - go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann - | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) - go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann - go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) - - -- Things of the form `!x` are also FunBinds - -- See Note [FunBind vs PatBind] - go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann - | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) - - -- For infix function defns, there should be only one infix *function* - -- (though there may be infix *datacons* involved too). So we don't - -- need fixity info to figure out which function is being defined. - -- a `K1` b `op` c `K2` d - -- must parse as - -- (a `K1` b) `op` (c `K2` d) - -- The renamer checks later that the precedences would yield such a parse. - -- - -- There is a complication to deal with bang patterns. - -- - -- ToDo: what about this? - -- x + 1 `op` y = ... - - go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann - | Just (e',es') <- splitBang e - = do { bang_on <- getBit BangPatBit - ; if bang_on then go e' (es' ++ es) ann - else return (Just (cL loc' op, Infix, (l:r:es), ann)) } - -- No bangs; behave just like the next case - | not (isRdrDataCon op) -- We have found the function! - = return (Just (cL loc' op, Infix, (l:r:es), ann)) - | otherwise -- Infix data con; keep going - = do { mb_l <- go l es ann - ; case mb_l of - Just (op', Infix, j : k : es', ann') - -> return (Just (op', Infix, j : op_app : es', ann')) - where - op_app = cL loc (PatBuilderOpApp k - (cL loc' op) r) - _ -> return Nothing } - go _ _ _ = return Nothing - --- | Either an operator or an operand. -data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) - | TyElKindApp SrcSpan (LHsType GhcPs) - -- See Note [TyElKindApp SrcSpan interpretation] - | TyElTilde | TyElBang - | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) - | TyElDocPrev HsDocString - - -{- Note [TyElKindApp SrcSpan interpretation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A TyElKindApp captures type application written in haskell as - - @ Foo - -where Foo is some type. - -The SrcSpan reflects both elements, and there are AnnAt and AnnVal API -Annotations attached to this SrcSpan for the specific locations of -each within it. --} - -instance Outputable TyEl where - ppr (TyElOpr name) = ppr name - ppr (TyElOpd ty) = ppr ty - ppr (TyElKindApp _ ki) = text "@" <> ppr ki - ppr TyElTilde = text "~" - ppr TyElBang = text "!" - ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk - ppr (TyElDocPrev doc) = ppr doc - -tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness) -tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy) -tyElStrictness TyElBang = Just (AnnBang, SrcStrict) -tyElStrictness _ = Nothing - --- | Extract a strictness/unpackedness annotation from the front of a reversed --- 'TyEl' list. -pStrictMark - :: [Located TyEl] -- reversed TyEl - -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} - , [AddAnn] - , [Located TyEl] {- remaining TyEl -}) -pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs) - | Just (strAnnId, str) <- tyElStrictness x1 - , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 - = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) - , unpkAnns ++ [AddAnn strAnnId l1] - , xs ) -pStrictMark ((dL->L l x1) : xs) - | Just (strAnnId, str) <- tyElStrictness x1 - = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) - , [AddAnn strAnnId l] - , xs ) -pStrictMark ((dL->L l x1) : xs) - | TyElUnpackedness (anns, prag, unpk) <- x1 - = Just ( cL l (HsSrcBang prag unpk NoSrcStrict) - , anns - , xs ) -pStrictMark _ = Nothing - -pBangTy - :: LHsType GhcPs -- a type to be wrapped inside HsBangTy - -> [Located TyEl] -- reversed TyEl - -> ( Bool {- has a strict mark been consumed? -} - , LHsType GhcPs {- the resulting BangTy -} - , P () {- add annotations -} - , [Located TyEl] {- remaining TyEl -}) -pBangTy lt@(dL->L l1 _) xs = - case pStrictMark xs of - Nothing -> (False, lt, pure (), xs) - Just (dL->L l2 strictMark, anns, xs') -> - let bl = combineSrcSpans l1 l2 - bt = HsBangTy noExtField strictMark lt - in (True, cL bl bt, addAnnsAt bl anns, xs') - --- | Merge a /reversed/ and /non-empty/ soup of operators and operands --- into a type. --- --- User input: @F x y + G a b * X@ --- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F] --- Output corresponds to what the user wrote assuming all operators are of the --- same fixity and right-associative. --- --- It's a bit silly that we're doing it at all, as the renamer will have to --- rearrange this, and it'd be easier to keep things separate. --- --- See Note [Parsing data constructors is hard] -mergeOps :: [Located TyEl] -> P (LHsType GhcPs) -mergeOps ((dL->L l1 (TyElOpd t)) : xs) - | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs - , null xs' -- We accept a BangTy only when there are no preceding TyEl. - = addAnns >> return t' -mergeOps all_xs = go (0 :: Int) [] id all_xs - where - -- NB. When modifying clauses in 'go', make sure that the reasoning in - -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct. - - -- clause [unpk]: - -- handle (NO)UNPACK pragmas - go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = - if not (null acc) && null xs - then do { acc' <- eitherToP $ mergeOpsAcc acc - ; let a = ops_acc acc' - strictMark = HsSrcBang unpkSrc unpk NoSrcStrict - bl = combineSrcSpans l (getLoc a) - bt = HsBangTy noExtField strictMark a - ; addAnnsAt bl anns - ; return (cL bl bt) } - else addFatalError l unpkError - where - unpkSDoc = case unpkSrc of - NoSourceText -> ppr unpk - SourceText str -> text str <> text " #-}" - unpkError - | not (null xs) = unpkSDoc <+> text "cannot appear inside a type." - | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type." - | otherwise = - -- See Note [Impossible case in mergeOps clause [unpk]] - panic "mergeOps.UNPACK: impossible position" - - -- clause [doc]: - -- we do not expect to encounter any docs - go _ _ _ ((dL->L l (TyElDocPrev _)):_) = - failOpDocPrev l - - -- to improve error messages, we do a bit of guesswork to determine if the - -- user intended a '!' or a '~' as a strictness annotation - go k acc ops_acc ((dL->L l x) : xs) - | Just (_, str) <- tyElStrictness x - , let guess [] = True - guess ((dL->L _ (TyElOpd _)):_) = False - guess ((dL->L _ (TyElOpr _)):_) = True - guess ((dL->L _ (TyElKindApp _ _)):_) = False - guess ((dL->L _ (TyElTilde)):_) = True - guess ((dL->L _ (TyElBang)):_) = True - guess ((dL->L _ (TyElUnpackedness _)):_) = True - guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs' - guess _ = panic "mergeOps.go.guess: Impossible Match" - -- due to #15884 - in guess xs - = if not (null acc) && (k > 1 || length acc > 1) - then do { a <- eitherToP (mergeOpsAcc acc) - ; failOpStrictnessCompound (cL l str) (ops_acc a) } - else failOpStrictnessPosition (cL l str) - - -- clause [opr]: - -- when we encounter an operator, we must have accumulated - -- something for its rhs, and there must be something left - -- to build its lhs. - go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = - if null acc || null (filter isTyElOpd xs) - then failOpFewArgs (cL l op) - else do { acc' <- eitherToP (mergeOpsAcc acc) - ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs } - where - isTyElOpd (dL->L _ (TyElOpd _)) = True - isTyElOpd _ = False - - -- clause [opr.1]: interpret 'TyElTilde' as an operator - go k acc ops_acc ((dL->L l TyElTilde):xs) = - let op = eqTyCon_RDR - in go k acc ops_acc (cL l (TyElOpr op):xs) - - -- clause [opr.2]: interpret 'TyElBang' as an operator - go k acc ops_acc ((dL->L l TyElBang):xs) = - let op = mkUnqual tcClsName (fsLit "!") - in go k acc ops_acc (cL l (TyElOpr op):xs) - - -- clause [opd]: - -- whenever an operand is encountered, it is added to the accumulator - go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs - - -- clause [tyapp]: - -- whenever a type application is encountered, it is added to the accumulator - go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs - - -- clause [end] - -- See Note [Non-empty 'acc' in mergeOps clause [end]] - go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc) - ; return (ops_acc acc') } - - go _ _ _ _ = panic "mergeOps.go: Impossible Match" - -- due to #15884 - -mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] - -> Either (SrcSpan, SDoc) (LHsType GhcPs) -mergeOpsAcc [] = panic "mergeOpsAcc: empty input" -mergeOpsAcc (HsTypeArg _ (L loc ki):_) - = Left (loc, text "Unexpected type application:" <+> ppr ki) -mergeOpsAcc (HsValArg ty : xs) = go1 ty xs - where - go1 :: LHsType GhcPs - -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)] - -> Either (SrcSpan, SDoc) (LHsType GhcPs) - go1 lhs [] = Right lhs - go1 lhs (x:xs) = case x of - HsValArg ty -> go1 (mkHsAppTy lhs ty) xs - HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki - in go1 ty xs - HsArgPar _ -> go1 lhs xs -mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs - -{- Note [Impossible case in mergeOps clause [unpk]] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This case should never occur. Let us consider all possible -variations of 'acc', 'xs', and 'k': - - acc xs k -============================== - null | null 0 -- "must be applied to a type" - null | not null 0 -- "must be applied to a type" -not null | null 0 -- successful parse -not null | not null 0 -- "cannot appear inside a type" - null | null >0 -- handled in clause [opr] - null | not null >0 -- "cannot appear inside a type" -not null | null >0 -- successful parse -not null | not null >0 -- "cannot appear inside a type" - -The (null acc && null xs && k>0) case is handled in clause [opr] -by the following check: - - if ... || null (filter isTyElOpd xs) - then failOpFewArgs (L l op) - -We know that this check has been performed because k>0, and by -the time we reach the end of the list (null xs), the only way -for (null acc) to hold is that there was not a single TyElOpd -between the operator and the end of the list. But this case is -caught by the check and reported as 'failOpFewArgs'. --} - -{- Note [Non-empty 'acc' in mergeOps clause [end]] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc' -without a check. - -Running 'mergeOps' with an empty input list is forbidden, so we do not consider -this possibility. This means we'll hit at least one other clause before we -reach clause [end]. - -* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit - clause [end] from there. -* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc' - will be non-empty. -* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going - to hit clause [opd] at least once before we reach clause [end], making 'acc' - non-empty. -* There are no other clauses. - -Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause -[end]. - --} - -pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) -pInfixSide ((dL->L l (TyElOpd t)):xs) - | (True, t', addAnns, xs') <- pBangTy (cL l t) xs - = Just (t', addAnns, xs') -pInfixSide (el:xs1) - | Just t1 <- pLHsTypeArg el - = go [t1] xs1 - where - go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] - -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) - go acc (el:xs) - | Just t <- pLHsTypeArg el - = go (t:acc) xs - go acc xs = case mergeOpsAcc acc of - Left _ -> Nothing - Right acc' -> Just (acc', pure (), xs) -pInfixSide _ = Nothing - -pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) -pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a)) -pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a) -pLHsTypeArg _ = Nothing - -pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) -pDocPrev = go Nothing - where - go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = - go (mTrailingDoc `mplus` Just (cL l doc)) xs - go mTrailingDoc xs = (mTrailingDoc, xs) - -orErr :: Maybe a -> b -> Either b a -orErr (Just a) _ = Right a -orErr Nothing b = Left b - -{- Note [isFunLhs vs mergeDataCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When parsing a function LHS, we do not know whether to treat (!) as -a strictness annotation or an infix operator: - - f ! a = ... - -Without -XBangPatterns, this parses as (!) f a = ... - with -XBangPatterns, this parses as f (!a) = ... - -So in function declarations we opted to always parse as if -XBangPatterns -were off, and then rejig in 'isFunLhs'. - -There are two downsides to this approach: - -1. It is not particularly elegant, as there's a point in our pipeline where - the representation is awfully incorrect. For instance, - f !a b !c = ... - will be first parsed as - (f ! a b) ! c = ... - -2. There are cases that it fails to cover, for instance infix declarations: - !a + !b = ... - will trigger an error. - -Unfortunately, we cannot define different productions in the 'happy' grammar -depending on whether -XBangPatterns are enabled. - -When parsing data constructors, we face a similar issue: - (a) data T1 = C ! D - (b) data T2 = C ! D => ... - -In (a) the first bang is a strictness annotation, but in (b) it is a type -operator. A 'happy'-based parser does not have unlimited lookahead to check for -=>, so we must first parse (C ! D) into a common representation. - -If we tried to mirror the approach used in functions, we would parse both sides -of => as types, and then rejig. However, we take a different route and use an -intermediate data structure, a reversed list of 'TyEl'. -See Note [Parsing data constructors is hard] for details. - -This approach does not suffer from the issues of 'isFunLhs': - -1. A sequence of 'TyEl' is a dedicated intermediate representation, not an - incorrectly parsed type. Therefore, we do not have confusing states in our - pipeline. (Except for representing data constructors as type variables). - -2. We can handle infix data constructors with strictness annotations: - data T a b = !a :+ !b - --} - - --- | Merge a /reversed/ and /non-empty/ soup of operators and operands --- into a data constructor. --- --- User input: @C !A B -- ^ doc@ --- Input to 'mergeDataCon': ["doc", B, !, A, C] --- Output: (C, PrefixCon [!A, B], "doc") --- --- See Note [Parsing data constructors is hard] --- See Note [isFunLhs vs mergeDataCon] -mergeDataCon - :: [Located TyEl] - -> P ( Located RdrName -- constructor name - , HsConDeclDetails GhcPs -- constructor field information - , Maybe LHsDocString -- docstring to go on the constructor - ) -mergeDataCon all_xs = - do { (addAnns, a) <- eitherToP res - ; addAnns - ; return a } - where - -- We start by splitting off the trailing documentation comment, - -- if any exists. - (mTrailingDoc, all_xs') = pDocPrev all_xs - - -- Determine whether the trailing documentation comment exists and is the - -- only docstring in this constructor declaration. - -- - -- When true, it means that it applies to the constructor itself: - -- data T = C - -- A - -- B -- ^ Comment on C (singleDoc == True) - -- - -- When false, it means that it applies to the last field: - -- data T = C -- ^ Comment on C - -- A -- ^ Comment on A - -- B -- ^ Comment on B (singleDoc == False) - singleDoc = isJust mTrailingDoc && - null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] - - -- The result of merging the list of reversed TyEl into a - -- data constructor, along with [AddAnn]. - res = goFirst all_xs' - - -- Take the trailing docstring into account when interpreting - -- the docstring near the constructor. - -- - -- data T = C -- ^ docstring right after C - -- A - -- B -- ^ trailing docstring - -- - -- 'mkConDoc' must be applied to the docstring right after C, so that it - -- falls back to the trailing docstring when appropriate (see singleDoc). - mkConDoc mDoc | singleDoc = mDoc `mplus` mTrailingDoc - | otherwise = mDoc - - -- The docstring for the last field of a data constructor. - trailingFieldDoc | singleDoc = Nothing - | otherwise = mTrailingDoc - - goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] - = do { data_con <- tyConToDataCon l tc - ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } - goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) - | (mConDoc, xs') <- pDocPrev xs - , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' - = do { data_con <- tyConToDataCon l' tc - ; let mDoc = mTrailingDoc `mplus` mConDoc - ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } - goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] - = return ( pure () - , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) - , PrefixCon ts - , mTrailingDoc ) ) - goFirst ((dL->L l (TyElOpd t)):xs) - | (_, t', addAnns, xs') <- pBangTy (cL l t) xs - = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' - goFirst (L l (TyElKindApp _ _):_) - = goInfix Monoid.<> Left (l, kindAppErr) - goFirst xs - = go (pure ()) mTrailingDoc [] xs - - go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] - = do { data_con <- tyConToDataCon l tc - ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } - go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) = - go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs - go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs) - | (_, t', addAnns', xs') <- pBangTy (cL l t) xs - , t'' <- mkLHsDocTyMaybe t' mLastDoc - = go (addAnns >> addAnns') Nothing (t'':ts) xs' - go _ _ _ ((dL->L _ (TyElOpr _)):_) = - -- Encountered an operator: backtrack to the beginning and attempt - -- to parse as an infix definition. - goInfix - go _ _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) - go _ _ _ _ = Left malformedErr - where - malformedErr = - ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') - , text "Cannot parse data constructor" <+> - text "in a data/newtype declaration:" $$ - nest 2 (hsep . reverse $ map ppr all_xs')) - - goInfix = - do { let xs0 = all_xs' - ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr - ; let (mOpDoc, xs2) = pDocPrev xs1 - ; (op, xs3) <- case xs2 of - (dL->L l (TyElOpr op)) : xs3 -> - do { data_con <- tyConToDataCon l op - ; return (data_con, xs3) } - _ -> Left malformedErr - ; let (mLhsDoc, xs4) = pDocPrev xs3 - ; (lhs_t, lhs_addAnns, xs5) <- pInfixSide xs4 `orErr` malformedErr - ; unless (null xs5) (Left malformedErr) - ; let rhs = mkLHsDocTyMaybe rhs_t trailingFieldDoc - lhs = mkLHsDocTyMaybe lhs_t mLhsDoc - addAnns = lhs_addAnns >> rhs_addAnns - ; return (addAnns, (op, InfixCon lhs rhs, mkConDoc mOpDoc)) } - where - malformedErr = - ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') - , text "Cannot parse an infix data constructor" <+> - text "in a data/newtype declaration:" $$ - nest 2 (hsep . reverse $ map ppr all_xs')) - - kindAppErr = - text "Unexpected kind application" <+> - text "in a data/newtype declaration:" $$ - nest 2 (hsep . reverse $ map ppr all_xs') - ---------------------------------------------------------------------------- --- | Check for monad comprehensions --- --- If the flag MonadComprehensions is set, return a 'MonadComp' context, --- otherwise use the usual 'ListComp' context - -checkMonadComp :: PV (HsStmtContext Name) -checkMonadComp = do - monadComprehensions <- getBit MonadComprehensionsBit - return $ if monadComprehensions - then MonadComp - else ListComp - --- ------------------------------------------------------------------------- --- Expression/command/pattern ambiguity. --- See Note [Ambiguous syntactic categories] --- - --- See Note [Parser-Validator] --- See Note [Ambiguous syntactic categories] -newtype ECP = - ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) } - -runECP_P :: DisambECP b => ECP -> P (Located b) -runECP_P p = runPV (runECP_PV p) - -ecpFromExp :: LHsExpr GhcPs -> ECP -ecpFromExp a = ECP (ecpFromExp' a) - -ecpFromCmd :: LHsCmd GhcPs -> ECP -ecpFromCmd a = ECP (ecpFromCmd' a) - --- | Disambiguate infix operators. --- See Note [Ambiguous syntactic categories] -class DisambInfixOp b where - mkHsVarOpPV :: Located RdrName -> PV (Located b) - mkHsConOpPV :: Located RdrName -> PV (Located b) - mkHsInfixHolePV :: SrcSpan -> PV (Located b) - -instance p ~ GhcPs => DisambInfixOp (HsExpr p) where - mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v) - mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v) - mkHsInfixHolePV l = return $ cL l hsHoleExpr - -instance DisambInfixOp RdrName where - mkHsConOpPV (dL->L l v) = return $ cL l v - mkHsVarOpPV (dL->L l v) = return $ cL l v - mkHsInfixHolePV l = - addFatalError l $ text "Invalid infix hole, expected an infix operator" - --- | Disambiguate constructs that may appear when we do not know ahead of time whether we are --- parsing an expression, a command, or a pattern. --- See Note [Ambiguous syntactic categories] -class b ~ (Body b) GhcPs => DisambECP b where - -- | See Note [Body in DisambECP] - type Body b :: * -> * - -- | Return a command without ambiguity, or fail in a non-command context. - ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) - -- | Return an expression without ambiguity, or fail in a non-expression context. - ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) - -- | Disambiguate "\... -> ..." (lambda) - mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) - -- | Disambiguate "let ... in ..." - mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) - -- | Infix operator representation - type InfixOp b - -- | Bring superclass constraints on FunArg into scope. - -- See Note [UndecidableSuperClasses for associated types] - superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) - -- | Disambiguate "f # x" (infix operator) - mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) - -- | Disambiguate "case ... of ..." - mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) - -- | Function argument representation - type FunArg b - -- | Bring superclass constraints on FunArg into scope. - -- See Note [UndecidableSuperClasses for associated types] - superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) - -- | Disambiguate "f x" (function application) - mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) - -- | Disambiguate "if ... then ... else ..." - mkHsIfPV :: SrcSpan - -> LHsExpr GhcPs - -> Bool -- semicolon? - -> Located b - -> Bool -- semicolon? - -> Located b - -> PV (Located b) - -- | Disambiguate "do { ... }" (do notation) - mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b) - -- | Disambiguate "( ... )" (parentheses) - mkHsParPV :: SrcSpan -> Located b -> PV (Located b) - -- | Disambiguate a variable "f" or a data constructor "MkF". - mkHsVarPV :: Located RdrName -> PV (Located b) - -- | Disambiguate a monomorphic literal - mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) - -- | Disambiguate an overloaded literal - mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b) - -- | Disambiguate a wildcard - mkHsWildCardPV :: SrcSpan -> PV (Located b) - -- | Disambiguate "a :: t" (type annotation) - mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) - -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) - -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) - mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) - -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) - mkHsRecordPV :: - SrcSpan -> - SrcSpan -> - Located b -> - ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> - PV (Located b) - -- | Disambiguate "-a" (negation) - mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) - -- | Disambiguate "(# a)" (right operator section) - mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) - -- | Disambiguate "(a -> b)" (view pattern) - mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) - -- | Disambiguate "a@b" (as-pattern) - mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) - -- | Disambiguate "~a" (lazy pattern) - mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) - -- | Disambiguate tuple sections and unboxed sums - mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) - -{- Note [UndecidableSuperClasses for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Assume we have a class C with an associated type T: - - class C a where - type T a - ... - -If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: - - {-# LANGUAGE UndecidableSuperClasses #-} - class C (T a) => C a where - type T a - ... - -Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes -making GHC loop. The workaround is to bring this constraint into scope -manually with a helper method: - - class C a where - type T a - superT :: (C (T a) => r) -> r - -In order to avoid ambiguous types, 'r' must mention 'a'. - -For consistency, we use this approach for all constraints on associated types, -even when -XUndecidableSuperClasses are not required. --} - -{- Note [Body in DisambECP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that -require their argument to take a form of (body GhcPs) for some (body :: * -> -*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the -superclass constraints of DisambECP. - -The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop -this requirement. It is possible and would allow removing the type index of -PatBuilder, but leads to worse type inference, breaking some code in the -typechecker. --} - -instance p ~ GhcPs => DisambECP (HsCmd p) where - type Body (HsCmd p) = HsCmd - ecpFromCmd' = return - ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) - mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg) - mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e) - type InfixOp (HsCmd p) = HsExpr p - superInfixOp m = m - mkHsOpAppPV l c1 op c2 = do - let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c - return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] - mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg) - type FunArg (HsCmd p) = HsExpr p - superFunArg m = m - mkHsAppPV l c e = do - checkCmdBlockArguments c - checkExpBlockArguments e - return $ cL l (HsCmdApp noExtField c e) - mkHsIfPV l c semi1 a semi2 b = do - checkDoAndIfThenElse c semi1 a semi2 b - return $ cL l (mkHsCmdIf c a b) - mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts) - mkHsParPV l c = return $ cL l (HsCmdPar noExtField c) - mkHsVarPV (dL->L l v) = cmdFail l (ppr v) - mkHsLitPV (dL->L l a) = cmdFail l (ppr a) - mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) - mkHsWildCardPV l = cmdFail l (text "_") - mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) - mkHsExplicitListPV l xs = cmdFail l $ - brackets (fsep (punctuate comma (map ppr xs))) - mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp) - mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ - ppr a <+> ppr (mk_rec_fields fbinds ddLoc) - mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) - mkHsSectionR_PV l op c = cmdFail l $ - let pp_op = fromMaybe (panic "cannot print infix operator") - (ppr_infix_expr (unLoc op)) - in pp_op <> ppr c - mkHsViewPatPV l a b = cmdFail l $ - ppr a <+> text "->" <+> ppr b - mkHsAsPatPV l v c = cmdFail l $ - pprPrefixOcc (unLoc v) <> text "@" <> ppr c - mkHsLazyPatPV l c = cmdFail l $ - text "~" <> ppr c - mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) - -cmdFail :: SrcSpan -> SDoc -> PV a -cmdFail loc e = addFatalError loc $ - hang (text "Parse error in command:") 2 (ppr e) - -instance p ~ GhcPs => DisambECP (HsExpr p) where - type Body (HsExpr p) = HsExpr - ecpFromCmd' (dL -> L l c) = do - addError l $ vcat - [ text "Arrow command found where an expression was expected:", - nest 2 (ppr c) ] - return (cL l hsHoleExpr) - ecpFromExp' = return - mkHsLamPV l mg = return $ cL l (HsLam noExtField mg) - mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c) - type InfixOp (HsExpr p) = HsExpr p - superInfixOp m = m - mkHsOpAppPV l e1 op e2 = do - return $ cL l $ OpApp noExtField e1 op e2 - mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg) - type FunArg (HsExpr p) = HsExpr p - superFunArg m = m - mkHsAppPV l e1 e2 = do - checkExpBlockArguments e1 - checkExpBlockArguments e2 - return $ cL l (HsApp noExtField e1 e2) - mkHsIfPV l c semi1 a semi2 b = do - checkDoAndIfThenElse c semi1 a semi2 b - return $ cL l (mkHsIf c a b) - mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts) - mkHsParPV l e = return $ cL l (HsPar noExtField e) - mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v) - mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a) - mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a) - mkHsWildCardPV l = return $ cL l hsHoleExpr - mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) - mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs) - mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp - mkHsRecordPV l lrec a (fbinds, ddLoc) = do - r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) - checkRecordSyntax (cL l r) - mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr) - mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e) - mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty - mkHsAsPatPV l v e = do - opt_TypeApplications <- getBit TypeApplicationsBit - let msg | opt_TypeApplications - = "Type application syntax requires a space before '@'" - | otherwise - = "Did you mean to enable TypeApplications?" - patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg) - mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty - mkSumOrTuplePV = mkSumOrTupleExpr - -patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) -patSynErr l e explanation = - do { addError l $ - sep [text "Pattern syntax in expression context:", - nest 4 (ppr e)] $$ - explanation - ; return (cL l hsHoleExpr) } - -hsHoleExpr :: HsExpr (GhcPass id) -hsHoleExpr = HsUnboundVar noExtField (TrueExprHole (mkVarOcc "_")) - --- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] -data PatBuilder p - = PatBuilderPat (Pat p) - | PatBuilderBang SrcSpan (Located (PatBuilder p)) - | PatBuilderPar (Located (PatBuilder p)) - | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) - | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) - | PatBuilderVar (Located RdrName) - | PatBuilderOverLit (HsOverLit GhcPs) - -patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p) -patBuilderBang bang p = - cL (bang `combineSrcSpans` getLoc p) $ - PatBuilderBang bang p - -instance Outputable (PatBuilder GhcPs) where - ppr (PatBuilderPat p) = ppr p - ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p - ppr (PatBuilderPar (L _ p)) = parens (ppr p) - ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 - ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 - ppr (PatBuilderVar v) = ppr v - ppr (PatBuilderOverLit l) = ppr l - -instance DisambECP (PatBuilder GhcPs) where - type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (dL-> L l c) = - addFatalError l $ - text "Command syntax in pattern:" <+> ppr c - ecpFromExp' (dL-> L l e) = - addFatalError l $ - text "Expression syntax in pattern:" <+> ppr e - mkHsLamPV l _ = addFatalError l $ - text "Lambda-syntax in pattern." $$ - text "Pattern matching on functions is not possible." - mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" - type InfixOp (PatBuilder GhcPs) = RdrName - superInfixOp m = m - mkHsOpAppPV l p1 op p2 = do - warnSpaceAfterBang op (getLoc p2) - return $ cL l $ PatBuilderOpApp p1 op p2 - mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" - type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs - superFunArg m = m - mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2) - mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" - mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" - mkHsParPV l p = return $ cL l (PatBuilderPar p) - mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) - mkHsLitPV lit@(dL->L l a) = do - checkUnboxedStringLitPat lit - return $ cL l (PatBuilderPat (LitPat noExtField a)) - mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) - mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField)) - mkHsTySigPV l b sig = do - p <- checkLPat b - return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) - mkHsExplicitListPV l xs = do - ps <- traverse checkLPat xs - return (cL l (PatBuilderPat (ListPat noExtField ps))) - mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp)) - mkHsRecordPV l _ a (fbinds, ddLoc) = do - r <- mkPatRec a (mk_rec_fields fbinds ddLoc) - checkRecordSyntax (cL l r) - mkHsNegAppPV l (dL->L lp p) = do - lit <- case p of - PatBuilderOverLit pos_lit -> return (cL lp pos_lit) - _ -> patFail l (text "-" <> ppr p) - return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) - mkHsSectionR_PV l op p - | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p - | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p) - mkHsViewPatPV l a b = do - p <- checkLPat b - return $ cL l (PatBuilderPat (ViewPat noExtField a p)) - mkHsAsPatPV l v e = do - p <- checkLPat e - return $ cL l (PatBuilderPat (AsPat noExtField v p)) - mkHsLazyPatPV l e = do - p <- checkLPat e - return $ cL l (PatBuilderPat (LazyPat noExtField p)) - mkSumOrTuplePV = mkSumOrTuplePat - -checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () -checkUnboxedStringLitPat (dL->L loc lit) = - case lit of - HsStringPrim _ _ -- Trac #13260 - -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) - _ -> return () - -mkPatRec :: - Located (PatBuilder GhcPs) -> - HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> - PV (PatBuilder GhcPs) -mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) - | isRdrDataCon (unLoc c) - = do fs <- mapM checkPatField fs - return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd)))) -mkPatRec p _ = - addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p - --- | Warn about missing space after bang -warnSpaceAfterBang :: Located RdrName -> SrcSpan -> PV () -warnSpaceAfterBang (dL->L opLoc op) argLoc = do - bang_on <- getBit BangPatBit - when (not bang_on && noSpace && isBangRdr op) $ - addWarning Opt_WarnSpaceAfterBang span msg - where - span = combineSrcSpans opLoc argLoc - noSpace = srcSpanEnd opLoc == srcSpanStart argLoc - msg = text "Did you forget to enable BangPatterns?" $$ - text "If you mean to bind (!) then perhaps you want" $$ - text "to add a space after the bang for clarity." - -{- Note [Ambiguous syntactic categories] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are places in the grammar where we do not know whether we are parsing an -expression or a pattern without unlimited lookahead (which we do not have in -'happy'): - -View patterns: - - f (Con a b ) = ... -- 'Con a b' is a pattern - f (Con a b -> x) = ... -- 'Con a b' is an expression - -do-notation: - - do { Con a b <- x } -- 'Con a b' is a pattern - do { Con a b } -- 'Con a b' is an expression - -Guards: - - x | True <- p && q = ... -- 'True' is a pattern - x | True = ... -- 'True' is an expression - -Top-level value/function declarations (FunBind/PatBind): - - f !a -- TH splice - f !a = ... -- function declaration - - Until we encounter the = sign, we don't know if it's a top-level - TemplateHaskell splice where ! is an infix operator, or if it's a function - declaration where ! is a strictness annotation. - -There are also places in the grammar where we do not know whether we are -parsing an expression or a command: - - proc x -> do { (stuff) -< x } -- 'stuff' is an expression - proc x -> do { (stuff) } -- 'stuff' is a command - - Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' - as an expression or a command. - -In fact, do-notation is subject to both ambiguities: - - proc x -> do { (stuff) -< x } -- 'stuff' is an expression - proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern - proc x -> do { (stuff) } -- 'stuff' is a command - -There are many possible solutions to this problem. For an overview of the ones -we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] - -The solution that keeps basic definitions (such as HsExpr) clean, keeps the -concerns local to the parser, and does not require duplication of hsSyn types, -or an extra pass over the entire AST, is to parse into an overloaded -parser-validator (a so-called tagless final encoding): - - class DisambECP b where ... - instance p ~ GhcPs => DisambECP (HsCmd p) where ... - instance p ~ GhcPs => DisambECP (HsExp p) where ... - instance p ~ GhcPs => DisambECP (PatBuilder p) where ... - -The 'DisambECP' class contains functions to build and validate 'b'. For example, -to add parentheses we have: - - mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) - -'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for -expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, -see Note [PatBuilder]). - -Consider the 'alts' production used to parse case-of alternatives: - - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } - : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -We abstract over LHsExpr GhcPs, and it becomes: - - alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } - : alts1 { $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -Compared to the initial definition, the added bits are: - - forall b. DisambECP b => PV ( ... ) -- in the type signature - $1 >>= \ $1 -> return $ -- in one reduction rule - $2 >>= \ $2 -> return $ -- in another reduction rule - -The overhead is constant relative to the size of the rest of the reduction -rule, so this approach scales well to large parser productions. - --} - - -{- Note [Resolving parsing ambiguities: non-taken alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Alternative I, extra constructors in GHC.Hs.Expr ------------------------------------------------- -We could add extra constructors to HsExpr to represent command-specific and -pattern-specific syntactic constructs. Under this scheme, we parse patterns -and commands as expressions and rejig later. This is what GHC used to do, and -it polluted 'HsExpr' with irrelevant constructors: - - * for commands: 'HsArrForm', 'HsArrApp' - * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' - -(As of now, we still do that for patterns, but we plan to fix it). - -There are several issues with this: - - * The implementation details of parsing are leaking into hsSyn definitions. - - * Code that uses HsExpr has to panic on these impossible-after-parsing cases. - - * HsExpr is arbitrarily selected as the extension basis. Why not extend - HsCmd or HsPat with extra constructors instead? - - * We cannot handle corner cases. For instance, the following function - declaration LHS is not a valid expression (see #1087): - - !a + !b = ... - - * There are points in the pipeline where the representation was awfully - incorrect. For instance, - - f !a b !c = ... - - is first parsed as - - (f ! a b) ! c = ... - - -Alternative II, extra constructors in GHC.Hs.Expr for GhcPs ------------------------------------------------------------ -We could address some of the problems with Alternative I by using Trees That -Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to -the output of parsing, not to its intermediate results, so we wouldn't want -them there either. - -Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs ---------------------------------------------------------------- -We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. -Unfortunately, creating a new pass would significantly bloat conversion code -and slow down the compiler by adding another linear-time pass over the entire -AST. For example, in order to build HsExpr GhcPrePs, we would need to build -HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds -GhcPrePs. - - -Alternative IV, sum type and bottom-up data flow ------------------------------------------------- -Expressions and commands are disjoint. There are no user inputs that could be -interpreted as either an expression or a command depending on outer context: - - 5 -- definitely an expression - x -< y -- definitely a command - -Even though we have both 'HsLam' and 'HsCmdLam', we can look at -the body to disambiguate: - - \p -> 5 -- definitely an expression - \p -> x -< y -- definitely a command - -This means we could use a bottom-up flow of information to determine -whether we are parsing an expression or a command, using a sum type -for intermediate results: - - Either (LHsExpr GhcPs) (LHsCmd GhcPs) - -There are two problems with this: - - * We cannot handle the ambiguity between expressions and - patterns, which are not disjoint. - - * Bottom-up flow of information leads to poor error messages. Consider - - if ... then 5 else (x -< y) - - Do we report that '5' is not a valid command or that (x -< y) is not a - valid expression? It depends on whether we want the entire node to be - 'HsIf' or 'HsCmdIf', and this information flows top-down, from the - surrounding parsing context (are we in 'proc'?) - -Alternative V, backtracking with parser combinators ---------------------------------------------------- -One might think we could sidestep the issue entirely by using a backtracking -parser and doing something along the lines of (try pExpr <|> pPat). - -Turns out, this wouldn't work very well, as there can be patterns inside -expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns -(e.g. view patterns). To handle this, we would need to backtrack while -backtracking, and unbound levels of backtracking lead to very fragile -performance. - -Alternative VI, an intermediate data type ------------------------------------------ -There are common syntactic elements of expressions, commands, and patterns -(e.g. all of them must have balanced parentheses), and we can capture this -common structure in an intermediate data type, Frame: - -data Frame - = FrameVar RdrName - -- ^ Identifier: Just, map, BS.length - | FrameTuple [LTupArgFrame] Boxity - -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) - | FrameTySig LFrame (LHsSigWcType GhcPs) - -- ^ Type signature: x :: ty - | FramePar (SrcSpan, SrcSpan) LFrame - -- ^ Parentheses - | FrameIf LFrame LFrame LFrame - -- ^ If-expression: if p then x else y - | FrameCase LFrame [LFrameMatch] - -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } - | FrameDo (HsStmtContext Name) [LFrameStmt] - -- ^ Do-expression: do { s1; a <- s2; s3 } - ... - | FrameExpr (HsExpr GhcPs) -- unambiguously an expression - | FramePat (HsPat GhcPs) -- unambiguously a pattern - | FrameCommand (HsCmd GhcPs) -- unambiguously a command - -To determine which constructors 'Frame' needs to have, we take the union of -intersections between HsExpr, HsCmd, and HsPat. - -The intersection between HsPat and HsExpr: - - HsPat = VarPat | TuplePat | SigPat | ParPat | ... - HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... - ------------------------------------------------------------------- - Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... - -The intersection between HsCmd and HsExpr: - - HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar - HsExpr = HsIf | HsCase | HsDo | HsPar - ------------------------------------------------ - Frame = FrameIf | FrameCase | FrameDo | FramePar - -The intersection between HsCmd and HsPat: - - HsPat = ParPat | ... - HsCmd = HsCmdPar | ... - ----------------------- - Frame = FramePar | ... - -Take the union of each intersection and this yields the final 'Frame' data -type. The problem with this approach is that we end up duplicating a good -portion of hsSyn: - - Frame for HsExpr, HsPat, HsCmd - TupArgFrame for HsTupArg - FrameMatch for Match - FrameStmt for StmtLR - FrameGRHS for GRHS - FrameGRHSs for GRHSs - ... - -Alternative VII, a product type -------------------------------- -We could avoid the intermediate representation of Alternative VI by parsing -into a product of interpretations directly: - - -- See Note [Parser-Validator] - type ExpCmdPat = ( PV (LHsExpr GhcPs) - , PV (LHsCmd GhcPs) - , PV (LHsPat GhcPs) ) - -This means that in positions where we do not know whether to produce -expression, a pattern, or a command, we instead produce a parser-validator for -each possible option. - -Then, as soon as we have parsed far enough to resolve the ambiguity, we pick -the appropriate component of the product, discarding the rest: - - checkExpOf3 (e, _, _) = e -- interpret as an expression - checkCmdOf3 (_, c, _) = c -- interpret as a command - checkPatOf3 (_, _, p) = p -- interpret as a pattern - -We can easily define ambiguities between arbitrary subsets of interpretations. -For example, when we know ahead of type that only an expression or a command is -possible, but not a pattern, we can use a smaller type: - - -- See Note [Parser-Validator] - type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) - - checkExpOf2 (e, _) = e -- interpret as an expression - checkCmdOf2 (_, c) = c -- interpret as a command - -However, there is a slight problem with this approach, namely code duplication -in parser productions. Consider the 'alts' production used to parse case-of -alternatives: - - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } - : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -Under the new scheme, we have to completely duplicate its type signature and -each reduction rule: - - alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression - , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command - ) } - : alts1 - { ( checkExpOf2 $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) - , checkCmdOf2 $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) - ) } - | ';' alts - { ( checkExpOf2 $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) - , checkCmdOf2 $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) - ) } - -And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', -'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! - -Alternative VIII, a function from a GADT ----------------------------------------- -We could avoid code duplication of the Alternative VII by representing the product -as a function from a GADT: - - data ExpCmdG b where - ExpG :: ExpCmdG HsExpr - CmdG :: ExpCmdG HsCmd - - type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) - - checkExp :: ExpCmd -> PV (LHsExpr GhcPs) - checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) - checkExp f = f ExpG -- interpret as an expression - checkCmd f = f CmdG -- interpret as a command - -Consider the 'alts' production used to parse case-of alternatives: - - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } - : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -We abstract over LHsExpr, and it becomes: - - alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } - : alts1 - { \tag -> $1 tag >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts - { \tag -> $2 tag >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -Note that 'ExpCmdG' is a singleton type, the value is completely -determined by the type: - - when (b~HsExpr), tag = ExpG - when (b~HsCmd), tag = CmdG - -This is a clear indication that we can use a class to pass this value behind -the scenes: - - class ExpCmdI b where expCmdG :: ExpCmdG b - instance ExpCmdI HsExpr where expCmdG = ExpG - instance ExpCmdI HsCmd where expCmdG = CmdG - -And now the 'alts' production is simplified, as we no longer need to -thread 'tag' explicitly: - - alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } - : alts1 { $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -This encoding works well enough, but introduces an extra GADT unlike the -tagless final encoding, and there's no need for this complexity. - --} - -{- Note [PatBuilder] -~~~~~~~~~~~~~~~~~~~~ -Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms, -so we introduce the notion of a PatBuilder. - -Consider a pattern like this: - - Con a b c - -We parse arguments to "Con" one at a time in the fexp aexp parser production, -building the result with mkHsAppPV, so the intermediate forms are: - - 1. Con - 2. Con a - 3. Con a b - 4. Con a b c - -In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like -this (pseudocode): - - 1. "Con" - 2. HsApp "Con" "a" - 3. HsApp (HsApp "Con" "a") "b" - 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" - -Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have -instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for -the intermediate forms. - -Worse yet, some intermediate forms are not valid patterns at all. For example: - - Con !a !b c - -This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then -rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid -patterns, so we cannot represent them as Pat. - -We also need an intermediate representation to postpone disambiguation between -FunBind and PatBind. Consider: - - a `Con` b = ... - a `fun` b = ... - -How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We -learn this by inspecting an intermediate representation in 'isFunLhs' and -seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate -representation capable of representing both a FunBind and a PatBind, so Pat is -insufficient. - -PatBuilder is an extension of Pat that is capable of representing intermediate -parsing results for patterns and function bindings: - - data PatBuilder p - = PatBuilderPat (Pat p) - | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) - | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) - ... - -It can represent any pattern via 'PatBuilderPat', but it also has a variety of -other constructors which were added by following a simple principle: we never -pattern match on the pattern stored inside 'PatBuilderPat'. - -For example, in 'splitBang' we need to match on space-separated and -bang-separated patterns, so these are represented with dedicated constructors -'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on -variables, so we have a dedicated 'PatBuilderVar' constructor for this despite -the existence of 'VarPat'. --} - ---------------------------------------------------------------------------- --- Miscellaneous utilities - --- | Check if a fixity is valid. We support bypassing the usual bound checks --- for some special operators. -checkPrecP - :: Located (SourceText,Int) -- ^ precedence - -> Located (OrdList (Located RdrName)) -- ^ operators - -> P () -checkPrecP (dL->L l (_,i)) (dL->L _ ol) - | 0 <= i, i <= maxPrecedence = pure () - | all specialOp ol = pure () - | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) - where - specialOp op = unLoc op `elem` [ eqTyCon_RDR - , getRdrName funTyCon ] - -mkRecConstrOrUpdate - :: LHsExpr GhcPs - -> SrcSpan - -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) - -> PV (HsExpr GhcPs) - -mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) - | isRdrDataCon c - = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp _ (fs,dd) - | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") - | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) - -mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs -mkRdrRecordUpd exp flds - = RecordUpd { rupd_ext = noExtField - , rupd_expr = exp - , rupd_flds = flds } - -mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs -mkRdrRecordCon con flds - = RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds } - -mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg -mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } -mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs - , rec_dotdot = Just (cL s (length fs)) } - -mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) - = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun -mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _) - = noExtCon nec -mk_rec_upd_field (HsRecField _ _ _) - = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 - -mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation - -> InlinePragma --- The (Maybe Activation) is because the user can omit --- the activation spec (and usually does) -mkInlinePragma src (inl, match_info) mb_act - = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes - , inl_inline = inl - , inl_sat = Nothing - , inl_act = act - , inl_rule = match_info } - where - act = case mb_act of - Just act -> act - Nothing -> -- No phase specified - case inl of - NoInline -> NeverActive - _other -> AlwaysActive - ------------------------------------------------------------------------------ --- utilities for foreign declarations - --- construct a foreign import declaration --- -mkImport :: Located CCallConv - -> Located Safety - -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) - -> P (HsDecl GhcPs) -mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = - case unLoc cconv of - CCallConv -> mkCImport - CApiConv -> mkCImport - StdCallConv -> mkCImport - PrimCallConv -> mkOtherImport - JavaScriptCallConv -> mkOtherImport - where - -- Parse a C-like entity string of the following form: - -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" - -- If 'cid' is missing, the function name 'v' is used instead as symbol - -- name (cf section 8.5.1 in Haskell 2010 report). - mkCImport = do - let e = unpackFS entity - case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of - Nothing -> addFatalError loc (text "Malformed entity string") - Just importSpec -> returnSpec importSpec - - -- currently, all the other import conventions only support a symbol name in - -- the entity string. If it is missing, we use the function name instead. - mkOtherImport = returnSpec importSpec - where - entity' = if nullFS entity - then mkExtName (unLoc v) - else entity - funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) - - returnSpec spec = return $ ForD noExtField $ ForeignImport - { fd_i_ext = noExtField - , fd_name = v - , fd_sig_ty = ty - , fd_fi = spec - } - - - --- the string "foo" is ambiguous: either a header or a C identifier. The --- C identifier case comes first in the alternatives below, so we pick --- that one. -parseCImport :: Located CCallConv -> Located Safety -> FastString -> String - -> Located SourceText - -> Maybe ForeignImport -parseCImport cconv safety nm str sourceText = - listToMaybe $ map fst $ filter (null.snd) $ - readP_to_S parse str - where - parse = do - skipSpaces - r <- choice [ - string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), - string "wrapper" >> return (mk Nothing CWrapper), - do optional (token "static" >> skipSpaces) - ((mk Nothing <$> cimp nm) +++ - (do h <- munch1 hdr_char - skipSpaces - mk (Just (Header (SourceText h) (mkFastString h))) - <$> cimp nm)) - ] - skipSpaces - return r - - token str = do _ <- string str - toks <- look - case toks of - c : _ - | id_char c -> pfail - _ -> return () - - mk h n = CImport cconv safety h n sourceText - - hdr_char c = not (isSpace c) - -- header files are filenames, which can contain - -- pretty much any char (depending on the platform), - -- so just accept any non-space character - id_first_char c = isAlpha c || c == '_' - id_char c = isAlphaNum c || c == '_' - - cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ (do isFun <- case unLoc cconv of - CApiConv -> - option True - (do token "value" - skipSpaces - return False) - _ -> return True - cid' <- cid - return (CFunction (StaticTarget NoSourceText cid' - Nothing isFun))) - where - cid = return nm +++ - (do c <- satisfy id_first_char - cs <- many (satisfy id_char) - return (mkFastString (c:cs))) - - --- construct a foreign export declaration --- -mkExport :: Located CCallConv - -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) - -> P (HsDecl GhcPs) -mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) - = return $ ForD noExtField $ - ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty - , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) - (cL le esrc) } - where - entity' | nullFS entity = mkExtName (unLoc v) - | otherwise = entity - --- Supplying the ext_name in a foreign decl is optional; if it --- isn't there, the Haskell name is assumed. Note that no transformation --- of the Haskell name is then performed, so if you foreign export (++), --- it's external name will be "++". Too bad; it's important because we don't --- want z-encoding (e.g. names with z's in them shouldn't be doubled) --- -mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) - --------------------------------------------------------------------------------- --- Help with module system imports/exports - -data ImpExpSubSpec = ImpExpAbs - | ImpExpAll - | ImpExpList [Located ImpExpQcSpec] - | ImpExpAllWith [Located ImpExpQcSpec] - -data ImpExpQcSpec = ImpExpQcName (Located RdrName) - | ImpExpQcType (Located RdrName) - | ImpExpQcWildcard - -mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp (dL->L l specname) subs = - case subs of - ImpExpAbs - | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar noExtField (cL l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExtField . cL l <$> nameT - ImpExpAll -> IEThingAll noExtField . cL l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith noExtField (cL l newName) - NoIEWildcard (wrapped xs) []) <$> nameT - ImpExpAllWith xs -> - do allowed <- getBit PatternSynonymsBit - if allowed - then - let withs = map unLoc xs - pos = maybe NoIEWildcard IEWildcard - (findIndex isImpExpQcWildcard withs) - ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs - in (\newName - -> IEThingWith noExtField (cL l newName) pos ies []) - <$> nameT - else addFatalError l - (text "Illegal export form (use PatternSynonyms to enable)") - where - name = ieNameVal specname - nameT = - if isVarNameSpace (rdrNameSpace name) - then addFatalError l - (text "Expecting a type constructor but found a variable," - <+> quotes (ppr name) <> text "." - $$ if isSymOcc $ rdrNameOcc name - then text "If" <+> quotes (ppr name) - <+> text "is a type constructor" - <+> text "then enable ExplicitNamespaces and use the 'type' keyword." - else empty) - else return $ ieNameFromSpec specname - - ieNameVal (ImpExpQcName ln) = unLoc ln - ieNameVal (ImpExpQcType ln) = unLoc ln - ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - - ieNameFromSpec (ImpExpQcName ln) = IEName ln - ieNameFromSpec (ImpExpQcType ln) = IEType ln - ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - - wrapped = map (onHasSrcSpan ieNameFromSpec) - -mkTypeImpExp :: Located RdrName -- TcCls or Var name space - -> P (Located RdrName) -mkTypeImpExp name = - do allowed <- getBit ExplicitNamespacesBit - unless allowed $ addError (getLoc name) $ - text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" - return (fmap (`setRdrNameSpace` tcClsName) name) - -checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) -checkImportSpec ie@(dL->L _ specs) = - case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of - [] -> return ie - (l:_) -> importSpecError l - where - importSpecError l = - addFatalError l - (text "Illegal import form, this syntax can only be used to bundle" - $+$ text "pattern synonyms with types in module exports.") - --- In the correct order -mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) -mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = - return ([], ImpExpAll) -mkImpExpSubSpec xs = - if (any (isImpExpQcWildcard . unLoc) xs) - then return $ ([], ImpExpAllWith xs) - else return $ ([], ImpExpList xs) - -isImpExpQcWildcard :: ImpExpQcSpec -> Bool -isImpExpQcWildcard ImpExpQcWildcard = True -isImpExpQcWildcard _ = False - ------------------------------------------------------------------------------ --- Warnings and failures - -warnPrepositiveQualifiedModule :: SrcSpan -> P () -warnPrepositiveQualifiedModule span = - addWarning Opt_WarnPrepositiveQualifiedModule span msg - where - msg = text "Found" <+> quotes (text "qualified") - <+> text "in prepositive position" - $$ text "Suggested fix: place " <+> quotes (text "qualified") - <+> text "after the module name instead." - -failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () -failOpNotEnabledImportQualifiedPost loc = addError loc msg - where - msg = text "Found" <+> quotes (text "qualified") - <+> text "in postpositive position. " - $$ text "To allow this, enable language extension 'ImportQualifiedPost'" - -failOpImportQualifiedTwice :: SrcSpan -> P () -failOpImportQualifiedTwice loc = addError loc msg - where - msg = text "Multiple occurences of 'qualified'" - -warnStarIsType :: SrcSpan -> P () -warnStarIsType span = addWarning Opt_WarnStarIsType span msg - where - msg = text "Using" <+> quotes (text "*") - <+> text "(or its Unicode variant) to mean" - <+> quotes (text "Data.Kind.Type") - $$ text "relies on the StarIsType extension, which will become" - $$ text "deprecated in the future." - $$ text "Suggested fix: use" <+> quotes (text "Type") - <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." - -warnStarBndr :: SrcSpan -> P () -warnStarBndr span = addWarning Opt_WarnStarBinder span msg - where - msg = text "Found binding occurrence of" <+> quotes (text "*") - <+> text "yet StarIsType is enabled." - $$ text "NB. To use (or export) this operator in" - <+> text "modules with StarIsType," - $$ text " including the definition module, you must qualify it." - -failOpFewArgs :: Located RdrName -> P a -failOpFewArgs (dL->L loc op) = - do { star_is_type <- getBit StarIsTypeBit - ; let msg = too_few $$ starInfo star_is_type op - ; addFatalError loc msg } - where - too_few = text "Operator applied to too few arguments:" <+> ppr op - -failOpDocPrev :: SrcSpan -> P a -failOpDocPrev loc = addFatalError loc msg - where - msg = text "Unexpected documentation comment." - -failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a -failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg - where - msg = text "Strictness annotation applied to a compound type." $$ - text "Did you mean to add parentheses?" $$ - nest 2 (ppr str <> parens (ppr ty)) - -failOpStrictnessPosition :: Located SrcStrictness -> P a -failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg - where - msg = text "Strictness annotation cannot appear in this position." - ------------------------------------------------------------------------------ --- Misc utils - -data PV_Context = - PV_Context - { pv_options :: ParserFlags - , pv_hint :: SDoc -- See Note [Parser-Validator Hint] - } - -data PV_Accum = - PV_Accum - { pv_messages :: DynFlags -> Messages - , pv_annotations :: [(ApiAnnKey,[SrcSpan])] - , pv_comment_q :: [Located AnnotationComment] - , pv_annotations_comments :: [(SrcSpan,[Located AnnotationComment])] - } - -data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum - --- See Note [Parser-Validator] -newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } - -instance Functor PV where - fmap = liftM - -instance Applicative PV where - pure a = a `seq` PV (\_ acc -> PV_Ok acc a) - (<*>) = ap - -instance Monad PV where - m >>= f = PV $ \ctx acc -> - case unPV m ctx acc of - PV_Ok acc' a -> unPV (f a) ctx acc' - PV_Failed acc' -> PV_Failed acc' - -runPV :: PV a -> P a -runPV = runPV_msg empty - -runPV_msg :: SDoc -> PV a -> P a -runPV_msg msg m = - P $ \s -> - let - pv_ctx = PV_Context - { pv_options = options s - , pv_hint = msg } - pv_acc = PV_Accum - { pv_messages = messages s - , pv_annotations = annotations s - , pv_comment_q = comment_q s - , pv_annotations_comments = annotations_comments s } - mkPState acc' = - s { messages = pv_messages acc' - , annotations = pv_annotations acc' - , comment_q = pv_comment_q acc' - , annotations_comments = pv_annotations_comments acc' } - in - case unPV m pv_ctx pv_acc of - PV_Ok acc' a -> POk (mkPState acc') a - PV_Failed acc' -> PFailed (mkPState acc') - -localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a -localPV_msg f m = - let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in - PV (\ctx acc -> unPV m (modifyHint ctx) acc) - -instance MonadP PV where - addError srcspan msg = - PV $ \ctx acc@PV_Accum{pv_messages=m} -> - let msg' = msg $$ pv_hint ctx in - PV_Ok acc{pv_messages=appendError srcspan msg' m} () - addWarning option srcspan warning = - PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} -> - PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} () - addFatalError srcspan msg = - addError srcspan msg >> PV (const PV_Failed) - getBit ext = - PV $ \ctx acc -> - let b = ext `xtest` pExtsBitmap (pv_options ctx) in - PV_Ok acc $! b - addAnnotation l a v = - PV $ \_ acc -> - let - (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc) - annotations_comments' = new_ann_comments ++ pv_annotations_comments acc - annotations' = ((l,a), [v]) : pv_annotations acc - acc' = acc - { pv_annotations = annotations' - , pv_comment_q = comment_q' - , pv_annotations_comments = annotations_comments' } - in - PV_Ok acc' () - -{- Note [Parser-Validator] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When resolving ambiguities, we need to postpone failure to make a choice later. -For example, if we have ambiguity between some A and B, our parser could be - - abParser :: P (Maybe A, Maybe B) - -This way we can represent four possible outcomes of parsing: - - (Just a, Nothing) -- definitely A - (Nothing, Just b) -- definitely B - (Just a, Just b) -- either A or B - (Nothing, Nothing) -- neither A nor B - -However, if we want to report informative parse errors, accumulate warnings, -and add API annotations, we are better off using 'P' instead of 'Maybe': - - abParser :: P (P A, P B) - -So we have an outer layer of P that consumes the input and builds the inner -layer, which validates the input. - -For clarity, we introduce the notion of a parser-validator: a parser that does -not consume any input, but may fail or use other effects. Thus we have: - - abParser :: P (PV A, PV B) - --} - -{- Note [Parser-Validator Hint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A PV computation is parametrized by a hint for error messages, which can be set -depending on validation context. We use this in checkPattern to fix #984. - -Consider this example, where the user has forgotten a 'do': - - f _ = do - x <- computation - case () of - _ -> - result <- computation - case () of () -> undefined - -GHC parses it as follows: - - f _ = do - x <- computation - (case () of - _ -> - result) <- computation - case () of () -> undefined - -Note that this fragment is parsed as a pattern: - - case () of - _ -> - result - -We attempt to detect such cases and add a hint to the error messages: - - T984.hs:6:9: - Parse error in pattern: case () of { _ -> result } - Possibly caused by a missing 'do'? - -The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed -as the 'pv_hint' field 'PV_Context'. When validating in a context other than -'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has -no effect on the error messages. - --} - --- | Hint about bang patterns, assuming @BangPatterns@ is off. -hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV () -hintBangPat span e = do - bang_on <- getBit BangPatBit - unless bang_on $ - addFatalError span - (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) - -data SumOrTuple b - = Sum ConTag Arity (Located b) - | Tuple [Located (Maybe (Located b))] - -pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc -pprSumOrTuple boxity = \case - Sum alt arity e -> - parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) - <+> parClose - Tuple xs -> - parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs) - <> parClose - where - ppr_bars n = hsep (replicate n (Outputable.char '|')) - (parOpen, parClose) = - case boxity of - Boxed -> (text "(", text ")") - Unboxed -> (text "(#", text "#)") - -mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) - --- Tuple -mkSumOrTupleExpr l boxity (Tuple es) = - return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity) - where - toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs - toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) - --- Sum -mkSumOrTupleExpr l Unboxed (Sum alt arity e) = - return $ cL l (ExplicitSum noExtField alt arity e) -mkSumOrTupleExpr l Boxed a@Sum{} = - addFatalError l (hang (text "Boxed sums not supported:") 2 - (pprSumOrTuple Boxed a)) - -mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) - --- Tuple -mkSumOrTuplePat l boxity (Tuple ps) = do - ps' <- traverse toTupPat ps - return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity)) - where - toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) - -- Ignore the element location so that the error message refers to the - -- entire tuple. See #19504 (and the discussion) for details. - toTupPat (dL -> L _ p) = case p of - Nothing -> addFatalError l (text "Tuple section in pattern context") - Just p' -> checkLPat p' - --- Sum -mkSumOrTuplePat l Unboxed (Sum alt arity p) = do - p' <- checkLPat p - return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity)) -mkSumOrTuplePat l Boxed a@Sum{} = - addFatalError l (hang (text "Boxed sums not supported:") 2 - (pprSumOrTuple Boxed a)) - -mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs -mkLHsOpTy x op y = - let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y - in cL loc (mkHsOpTy x op y) - -mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs -mkLHsDocTy t doc = - let loc = getLoc t `combineSrcSpans` getLoc doc - in cL loc (HsDocTy noExtField t doc) - -mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs -mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) - ------------------------------------------------------------------------------ --- Token symbols - -starSym :: Bool -> String -starSym True = "★" -starSym False = "*" - -forallSym :: Bool -> String -forallSym True = "∀" -forallSym False = "forall" diff --git a/parser/cutils.c b/parser/cutils.c deleted file mode 100644 --- a/parser/cutils.c +++ /dev/null @@ -1,24 +0,0 @@ -/* -These utility routines are used various -places in the GHC library. -*/ - -#include - -#include - -void -enableTimingStats( void ) /* called from the driver */ -{ - RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; -} - -void -setHeapSize( HsInt size ) -{ - RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; - if (RtsFlags.GcFlags.maxHeapSize != 0 && - RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { - RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; - } -} diff --git a/prelude/ForeignCall.hs b/prelude/ForeignCall.hs deleted file mode 100644 --- a/prelude/ForeignCall.hs +++ /dev/null @@ -1,355 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Foreign]{Foreign calls} --} - -{-# LANGUAGE DeriveDataTypeable #-} - -module ForeignCall ( - ForeignCall(..), isSafeForeignCall, - Safety(..), playSafe, playInterruptible, - - CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, - CCallSpec(..), - CCallTarget(..), isDynamicTarget, - CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, - - Header(..), CType(..), - ) where - -import GhcPrelude - -import FastString -import Binary -import Outputable -import Module -import BasicTypes ( SourceText, pprWithSourceText ) - -import Data.Char -import Data.Data -import {-# SOURCE #-} TyCon (PrimRep) - -{- -************************************************************************ -* * -\subsubsection{Data types} -* * -************************************************************************ --} - -newtype ForeignCall = CCall CCallSpec - deriving Eq - -isSafeForeignCall :: ForeignCall -> Bool -isSafeForeignCall (CCall (CCallSpec _ _ safe _ _)) = playSafe safe - --- We may need more clues to distinguish foreign calls --- but this simple printer will do for now -instance Outputable ForeignCall where - ppr (CCall cc) = ppr cc - -data Safety - = PlaySafe -- Might invoke Haskell GC, or do a call back, or - -- switch threads, etc. So make sure things are - -- tidy before the call. Additionally, in the threaded - -- RTS we arrange for the external call to be executed - -- by a separate OS thread, i.e., _concurrently_ to the - -- execution of other Haskell threads. - - | PlayInterruptible -- Like PlaySafe, but additionally - -- the worker thread running this foreign call may - -- be unceremoniously killed, so it must be scheduled - -- on an unbound thread. - - | PlayRisky -- None of the above can happen; the call will return - -- without interacting with the runtime system at all - deriving ( Eq, Show, Data ) - -- Show used just for Show Lex.Token, I think - -instance Outputable Safety where - ppr PlaySafe = text "safe" - ppr PlayInterruptible = text "interruptible" - ppr PlayRisky = text "unsafe" - -playSafe :: Safety -> Bool -playSafe PlaySafe = True -playSafe PlayInterruptible = True -playSafe PlayRisky = False - -playInterruptible :: Safety -> Bool -playInterruptible PlayInterruptible = True -playInterruptible _ = False - -{- -************************************************************************ -* * -\subsubsection{Calling C} -* * -************************************************************************ --} - -data CExportSpec - = CExportStatic -- foreign export ccall foo :: ty - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C Name of exported function - CCallConv - deriving Data - -data CCallSpec - = CCallSpec CCallTarget -- What to call - CCallConv -- Calling convention to use. - Safety - PrimRep -- result - [PrimRep] -- args - deriving( Eq ) - --- The call target: - --- | How to call a particular function in C-land. -data CCallTarget - -- An "unboxed" ccall# to named function in a particular package. - = StaticTarget - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C-land name of label. - - (Maybe UnitId) -- What package the function is in. - -- If Nothing, then it's taken to be in the current package. - -- Note: This information is only used for PrimCalls on Windows. - -- See CLabel.labelDynamic and CoreToStg.coreToStgApp - -- for the difference in representation between PrimCalls - -- and ForeignCalls. If the CCallTarget is representing - -- a regular ForeignCall then it's safe to set this to Nothing. - - -- The first argument of the import is the name of a function pointer (an Addr#). - -- Used when importing a label as "foreign import ccall "dynamic" ..." - Bool -- True => really a function - -- False => a value; only - -- allowed in CAPI imports - | DynamicTarget - - deriving( Eq, Data ) - -isDynamicTarget :: CCallTarget -> Bool -isDynamicTarget DynamicTarget = True -isDynamicTarget _ = False - -{- -Stuff to do with calling convention: - -ccall: Caller allocates parameters, *and* deallocates them. - -stdcall: Caller allocates parameters, callee deallocates. - Function name has @N after it, where N is number of arg bytes - e.g. _Foo@8. This convention is x86 (win32) specific. - -See: http://www.programmersheaven.com/2/Calling-conventions --} - --- any changes here should be replicated in the CallConv type in template haskell -data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv - deriving (Eq, Data) - -instance Outputable CCallConv where - ppr StdCallConv = text "stdcall" - ppr CCallConv = text "ccall" - ppr CApiConv = text "capi" - ppr PrimCallConv = text "prim" - ppr JavaScriptCallConv = text "javascript" - -defaultCCallConv :: CCallConv -defaultCCallConv = CCallConv - -ccallConvToInt :: CCallConv -> Int -ccallConvToInt StdCallConv = 0 -ccallConvToInt CCallConv = 1 -ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" -ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" -ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" - -{- -Generate the gcc attribute corresponding to the given -calling convention (used by PprAbsC): --} - -ccallConvAttribute :: CCallConv -> SDoc -ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" -ccallConvAttribute CCallConv = empty -ccallConvAttribute CApiConv = empty -ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" -ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" - -type CLabelString = FastString -- A C label, completely unencoded - -pprCLabelString :: CLabelString -> SDoc -pprCLabelString lbl = ftext lbl - -isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label -isCLabelString lbl - = all ok (unpackFS lbl) - where - ok c = isAlphaNum c || c == '_' || c == '.' - -- The '.' appears in e.g. "foo.so" in the - -- module part of a ExtName. Maybe it should be separate - --- Printing into C files: - -instance Outputable CExportSpec where - ppr (CExportStatic _ str _) = pprCLabelString str - -instance Outputable CCallSpec where - ppr (CCallSpec fun cconv safety _ret_ty _arg_tys) - = hcat [ whenPprDebug callconv, ppr_fun fun ] - where - callconv = text "{-" <> ppr cconv <> text "-}" - - gc_suf | playSafe safety = text "_GC" - | otherwise = empty - - ppr_fun (StaticTarget st _fn mPkgId isFun) - = text (if isFun then "__pkg_ccall" - else "__pkg_ccall_value") - <> gc_suf - <+> (case mPkgId of - Nothing -> empty - Just pkgId -> ppr pkgId) - <+> (pprWithSourceText st empty) - - ppr_fun DynamicTarget - = text "__dyn_ccall" <> gc_suf <+> text "\"\"" - --- The filename for a C header file --- Note [Pragma source text] in BasicTypes -data Header = Header SourceText FastString - deriving (Eq, Data) - -instance Outputable Header where - ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) - --- | A C type, used in CAPI FFI calls --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, --- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', --- 'ApiAnnotation.AnnClose' @'\#-}'@, - --- For details on above see note [Api annotations] in ApiAnnotation -data CType = CType SourceText -- Note [Pragma source text] in BasicTypes - (Maybe Header) -- header to include for this type - (SourceText,FastString) -- the type itself - deriving (Eq, Data) - -instance Outputable CType where - ppr (CType stp mh (stct,ct)) - = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc - <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" - where hDoc = case mh of - Nothing -> empty - Just h -> ppr h - -{- -************************************************************************ -* * -\subsubsection{Misc} -* * -************************************************************************ --} - -instance Binary ForeignCall where - put_ bh (CCall aa) = put_ bh aa - get bh = do aa <- get bh; return (CCall aa) - -instance Binary Safety where - put_ bh PlaySafe = do - putByte bh 0 - put_ bh PlayInterruptible = do - putByte bh 1 - put_ bh PlayRisky = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return PlaySafe - 1 -> do return PlayInterruptible - _ -> do return PlayRisky - -instance Binary CExportSpec where - put_ bh (CExportStatic ss aa ab) = do - put_ bh ss - put_ bh aa - put_ bh ab - get bh = do - ss <- get bh - aa <- get bh - ab <- get bh - return (CExportStatic ss aa ab) - -instance Binary CCallSpec where - put_ bh (CCallSpec aa ab ac ad ae) = do - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh ad - put_ bh ae - get bh = do - aa <- get bh - ab <- get bh - ac <- get bh - ad <- get bh - ae <- get bh - return (CCallSpec aa ab ac ad ae) - -instance Binary CCallTarget where - put_ bh (StaticTarget ss aa ab ac) = do - putByte bh 0 - put_ bh ss - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh DynamicTarget = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do ss <- get bh - aa <- get bh - ab <- get bh - ac <- get bh - return (StaticTarget ss aa ab ac) - _ -> do return DynamicTarget - -instance Binary CCallConv where - put_ bh CCallConv = do - putByte bh 0 - put_ bh StdCallConv = do - putByte bh 1 - put_ bh PrimCallConv = do - putByte bh 2 - put_ bh CApiConv = do - putByte bh 3 - put_ bh JavaScriptCallConv = do - putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> do return CCallConv - 1 -> do return StdCallConv - 2 -> do return PrimCallConv - 3 -> do return CApiConv - _ -> do return JavaScriptCallConv - -instance Binary CType where - put_ bh (CType s mh fs) = do put_ bh s - put_ bh mh - put_ bh fs - get bh = do s <- get bh - mh <- get bh - fs <- get bh - return (CType s mh fs) - -instance Binary Header where - put_ bh (Header s h) = put_ bh s >> put_ bh h - get bh = do s <- get bh - h <- get bh - return (Header s h) diff --git a/prelude/KnownUniques.hs b/prelude/KnownUniques.hs deleted file mode 100644 --- a/prelude/KnownUniques.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | This is where we define a mapping from Uniques to their associated --- known-key Names for things associated with tuples and sums. We use this --- mapping while deserializing known-key Names in interface file symbol tables, --- which are encoded as their Unique. See Note [Symbol table representation of --- names] for details. --- - -module KnownUniques - ( -- * Looking up known-key names - knownUniqueName - - -- * Getting the 'Unique's of 'Name's - -- ** Anonymous sums - , mkSumTyConUnique - , mkSumDataConUnique - -- ** Tuples - -- *** Vanilla - , mkTupleTyConUnique - , mkTupleDataConUnique - -- *** Constraint - , mkCTupleTyConUnique - , mkCTupleDataConUnique - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TysWiredIn -import TyCon -import DataCon -import Id -import BasicTypes -import Outputable -import Unique -import Name -import Util - -import Data.Bits -import Data.Maybe - --- | Get the 'Name' associated with a known-key 'Unique'. -knownUniqueName :: Unique -> Maybe Name -knownUniqueName u = - case tag of - 'z' -> Just $ getUnboxedSumName n - '4' -> Just $ getTupleTyConName Boxed n - '5' -> Just $ getTupleTyConName Unboxed n - '7' -> Just $ getTupleDataConName Boxed n - '8' -> Just $ getTupleDataConName Unboxed n - 'k' -> Just $ getCTupleTyConName n - 'm' -> Just $ getCTupleDataConUnique n - _ -> Nothing - where - (tag, n) = unpkUnique u - --------------------------------------------------- --- Anonymous sums --- --- Sum arities start from 2. The encoding is a bit funny: we break up the --- integral part into bitfields for the arity, an alternative index (which is --- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a --- tag (used to identify the sum's TypeRep binding). --- --- This layout is chosen to remain compatible with the usual unique allocation --- for wired-in data constructors described in Unique.hs --- --- TyCon for sum of arity k: --- 00000000 kkkkkkkk 11111100 - --- TypeRep of TyCon for sum of arity k: --- 00000000 kkkkkkkk 11111101 --- --- DataCon for sum of arity k and alternative n (zero-based): --- 00000000 kkkkkkkk nnnnnn00 --- --- TypeRep for sum DataCon of arity k and alternative n (zero-based): --- 00000000 kkkkkkkk nnnnnn10 - -mkSumTyConUnique :: Arity -> Unique -mkSumTyConUnique arity = - ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the - -- alternative - mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) - -mkSumDataConUnique :: ConTagZ -> Arity -> Unique -mkSumDataConUnique alt arity - | alt >= arity - = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) - | otherwise - = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} - -getUnboxedSumName :: Int -> Name -getUnboxedSumName n - | n .&. 0xfc == 0xfc - = case tag of - 0x0 -> tyConName $ sumTyCon arity - 0x1 -> getRep $ sumTyCon arity - _ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag) - | tag == 0x0 - = dataConName $ sumDataCon (alt + 1) arity - | tag == 0x1 - = getName $ dataConWrapId $ sumDataCon (alt + 1) arity - | tag == 0x2 - = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity - | otherwise - = pprPanic "getUnboxedSumName" (ppr n) - where - arity = n `shiftR` 8 - alt = (n .&. 0xfc) `shiftR` 2 - tag = 0x3 .&. n - getRep tycon = - fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon)) - $ tyConRepName_maybe tycon - --- Note [Uniques for tuple type and data constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon --- --- Wired-in tuple data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon - --------------------------------------------------- --- Constraint tuples - -mkCTupleTyConUnique :: Arity -> Unique -mkCTupleTyConUnique a = mkUnique 'k' (2*a) - -mkCTupleDataConUnique :: Arity -> Unique -mkCTupleDataConUnique a = mkUnique 'm' (3*a) - -getCTupleTyConName :: Int -> Name -getCTupleTyConName n = - case n `divMod` 2 of - (arity, 0) -> cTupleTyConName arity - (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity - _ -> panic "getCTupleTyConName: impossible" - -getCTupleDataConUnique :: Int -> Name -getCTupleDataConUnique n = - case n `divMod` 3 of - (arity, 0) -> cTupleDataConName arity - (_arity, 1) -> panic "getCTupleDataConName: no worker" - (arity, 2) -> mkPrelTyConRepName $ cTupleDataConName arity - _ -> panic "getCTupleDataConName: impossible" - --------------------------------------------------- --- Normal tuples - -mkTupleDataConUnique :: Boxity -> Arity -> Unique -mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- may be used in C labels -mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) - -mkTupleTyConUnique :: Boxity -> Arity -> Unique -mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) -mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) - -getTupleTyConName :: Boxity -> Int -> Name -getTupleTyConName boxity n = - case n `divMod` 2 of - (arity, 0) -> tyConName $ tupleTyCon boxity arity - (arity, 1) -> fromMaybe (panic "getTupleTyConName") - $ tyConRepName_maybe $ tupleTyCon boxity arity - _ -> panic "getTupleTyConName: impossible" - -getTupleDataConName :: Boxity -> Int -> Name -getTupleDataConName boxity n = - case n `divMod` 3 of - (arity, 0) -> dataConName $ tupleDataCon boxity arity - (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity - (arity, 2) -> fromMaybe (panic "getTupleDataCon") - $ tyConRepName_maybe $ promotedTupleDataCon boxity arity - _ -> panic "getTupleDataConName: impossible" diff --git a/prelude/KnownUniques.hs-boot b/prelude/KnownUniques.hs-boot deleted file mode 100644 --- a/prelude/KnownUniques.hs-boot +++ /dev/null @@ -1,18 +0,0 @@ -module KnownUniques where - -import GhcPrelude -import Unique -import Name -import BasicTypes - --- Needed by TysWiredIn -knownUniqueName :: Unique -> Maybe Name - -mkSumTyConUnique :: Arity -> Unique -mkSumDataConUnique :: ConTagZ -> Arity -> Unique - -mkCTupleTyConUnique :: Arity -> Unique -mkCTupleDataConUnique :: Arity -> Unique - -mkTupleTyConUnique :: Boxity -> Arity -> Unique -mkTupleDataConUnique :: Boxity -> Arity -> Unique diff --git a/prelude/PrelInfo.hs b/prelude/PrelInfo.hs deleted file mode 100644 --- a/prelude/PrelInfo.hs +++ /dev/null @@ -1,291 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - -{-# LANGUAGE CPP #-} - --- | The @PrelInfo@ interface to the compiler's prelude knowledge. --- --- This module serves as the central gathering point for names which the --- compiler knows something about. This includes functions for, --- --- * discerning whether a 'Name' is known-key --- --- * given a 'Unique', looking up its corresponding known-key 'Name' --- --- See Note [Known-key names] and Note [About wired-in things] for information --- about the two types of prelude things in GHC. --- -module PrelInfo ( - -- * Known-key names - isKnownKeyName, - lookupKnownKeyName, - lookupKnownNameInfo, - - -- ** Internal use - -- | 'knownKeyNames' is exported to seed the original name cache only; - -- if you find yourself wanting to look at it you might consider using - -- 'lookupKnownKeyName' or 'isKnownKeyName'. - knownKeyNames, - - -- * Miscellaneous - wiredInIds, ghcPrimIds, - primOpRules, builtinRules, - - ghcPrimExports, - primOpId, - - -- * Random other things - maybeCharLikeCon, maybeIntLikeCon, - - -- * Class categories - isNumericClass, isStandardClass - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import KnownUniques -import Unique ( isValidKnownKeyUnique ) - -import ConLike ( ConLike(..) ) -import THNames ( templateHaskellNames ) -import PrelNames -import PrelRules -import Avail -import PrimOp -import DataCon -import BasicTypes -import Id -import Name -import NameEnv -import MkId -import Outputable -import TysPrim -import TysWiredIn -import HscTypes -import Class -import TyCon -import UniqFM -import Util -import TcTypeNats ( typeNatTyCons ) - -import Control.Applicative ((<|>)) -import Data.List ( intercalate ) -import Data.Array -import Data.Maybe - -{- -************************************************************************ -* * -\subsection[builtinNameInfo]{Lookup built-in names} -* * -************************************************************************ - -Note [About wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Wired-in things are Ids\/TyCons that are completely known to the compiler. - They are global values in GHC, (e.g. listTyCon :: TyCon). - -* A wired in Name contains the thing itself inside the Name: - see Name.wiredInNameTyThing_maybe - (E.g. listTyConName contains listTyCon. - -* The name cache is initialised with (the names of) all wired-in things - (except tuples and sums; see Note [Known-]) - -* The type environment itself contains no wired in things. The type - checker sees if the Name is wired in before looking up the name in - the type environment. - -* MkIface prunes out wired-in things before putting them in an interface file. - So interface files never contain wired-in things. --} - - --- | This list is used to ensure that when you say "Prelude.map" in your source --- code, or in an interface file, you get a Name with the correct known key (See --- Note [Known-key names] in PrelNames) -knownKeyNames :: [Name] -knownKeyNames - | debugIsOn - , Just badNamesStr <- knownKeyNamesOkay all_names - = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) - -- NB: We can't use ppr here, because this is sometimes evaluated in a - -- context where there are no DynFlags available, leading to a cryptic - -- "<
>" error. (This seems to happen only in the - -- stage 2 compiler, for reasons I [Richard] have no clue of.) - | otherwise - = all_names - where - all_names = - -- We exclude most tuples from this list—see - -- Note [Infinite families of known-key names] in GHC.Builtin.Names. - -- We make an exception for Unit (i.e., the boxed 1-tuple), since it does - -- not use special syntax like other tuples. - -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) - -- in GHC.Builtin.Types. - tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 : - concat [ wired_tycon_kk_names funTyCon - , concatMap wired_tycon_kk_names primTyCons - , concatMap wired_tycon_kk_names wiredInTyCons - , concatMap wired_tycon_kk_names typeNatTyCons - , map idName wiredInIds - , map (idName . primOpId) allThePrimOps - , map (idName . primOpWrapperId) allThePrimOps - , basicKnownKeyNames - , templateHaskellNames - ] - -- All of the names associated with a wired-in TyCon. - -- This includes the TyCon itself, its DataCons and promoted TyCons. - wired_tycon_kk_names :: TyCon -> [Name] - wired_tycon_kk_names tc = - tyConName tc : (rep_names tc ++ implicits) - where implicits = concatMap thing_kk_names (implicitTyConThings tc) - - wired_datacon_kk_names :: DataCon -> [Name] - wired_datacon_kk_names dc = - dataConName dc : rep_names (promoteDataCon dc) - - thing_kk_names :: TyThing -> [Name] - thing_kk_names (ATyCon tc) = wired_tycon_kk_names tc - thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc - thing_kk_names thing = [getName thing] - - -- The TyConRepName for a known-key TyCon has a known key, - -- but isn't itself an implicit thing. Yurgh. - -- NB: if any of the wired-in TyCons had record fields, the record - -- field names would be in a similar situation. Ditto class ops. - -- But it happens that there aren't any - rep_names tc = case tyConRepName_maybe tc of - Just n -> [n] - Nothing -> [] - --- | Check the known-key names list of consistency. -knownKeyNamesOkay :: [Name] -> Maybe String -knownKeyNamesOkay all_names - | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names - = Just $ " Out-of-range known-key uniques: [" - ++ intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" - | null badNamesPairs - = Nothing - | otherwise - = Just badNamesStr - where - namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n) - emptyUFM all_names - badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv - badNamesPairs = nonDetUFMToList badNamesEnv - -- It's OK to use nonDetUFMToList here because the ordering only affects - -- the message when we get a panic - badNamesStrs = map pairToStr badNamesPairs - badNamesStr = unlines badNamesStrs - - pairToStr (uniq, ns) = " " ++ - show uniq ++ - ": [" ++ - intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" - --- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a --- known-key thing. -lookupKnownKeyName :: Unique -> Maybe Name -lookupKnownKeyName u = - knownUniqueName u <|> lookupUFM knownKeysMap u - --- | Is a 'Name' known-key? -isKnownKeyName :: Name -> Bool -isKnownKeyName n = - isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap - -knownKeysMap :: UniqFM Name -knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ] - --- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by --- GHCi's ':info' command. -lookupKnownNameInfo :: Name -> SDoc -lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of - -- If we do find a doc, we add comment delimeters to make the output - -- of ':info' valid Haskell. - Nothing -> empty - Just doc -> vcat [text "{-", doc, text "-}"] - --- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390) -knownNamesInfo :: NameEnv SDoc -knownNamesInfo = unitNameEnv coercibleTyConName $ - vcat [ text "Coercible is a special constraint with custom solving rules." - , text "It is not a class." - , text "Please see section `The Coercible constraint`" - , text "of the user's guide for details." ] - -{- -We let a lot of "non-standard" values be visible, so that we can make -sense of them in interface pragmas. It's cool, though they all have -"non-standard" names, so they won't get past the parser in user code. - -************************************************************************ -* * - PrimOpIds -* * -************************************************************************ --} - -primOpIds :: Array Int Id --- A cache of the PrimOp Ids, indexed by PrimOp tag -primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps ] - -primOpId :: PrimOp -> Id -primOpId op = primOpIds ! primOpTag op - -{- -************************************************************************ -* * - Export lists for pseudo-modules (GHC.Prim) -* * -************************************************************************ - -GHC.Prim "exports" all the primops and primitive types, some -wired-in Ids. --} - -ghcPrimExports :: [IfaceExport] -ghcPrimExports - = map (avail . idName) ghcPrimIds ++ - map (avail . idName . primOpId) allThePrimOps ++ - [ AvailTC n [n] [] - | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc ] - -{- -************************************************************************ -* * - Built-in keys -* * -************************************************************************ - -ToDo: make it do the ``like'' part properly (as in 0.26 and before). --} - -maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool -maybeCharLikeCon con = con `hasKey` charDataConKey -maybeIntLikeCon con = con `hasKey` intDataConKey - -{- -************************************************************************ -* * - Class predicates -* * -************************************************************************ --} - -isNumericClass, isStandardClass :: Class -> Bool - -isNumericClass clas = classKey clas `is_elem` numericClassKeys -isStandardClass clas = classKey clas `is_elem` standardClassKeys - -is_elem :: Eq a => a -> [a] -> Bool -is_elem = isIn "is_X_Class" diff --git a/prelude/PrelNames.hs b/prelude/PrelNames.hs deleted file mode 100644 --- a/prelude/PrelNames.hs +++ /dev/null @@ -1,2489 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[PrelNames]{Definitions of prelude modules and names} - - -Nota Bene: all Names defined in here should come from the base package - - - ModuleNames for prelude modules, - e.g. pREL_BASE_Name :: ModuleName - - - Modules for prelude modules - e.g. pREL_Base :: Module - - - Uniques for Ids, DataCons, TyCons and Classes that the compiler - "knows about" in some way - e.g. intTyConKey :: Unique - minusClassOpKey :: Unique - - - Names for Ids, DataCons, TyCons and Classes that the compiler - "knows about" in some way - e.g. intTyConName :: Name - minusName :: Name - One of these Names contains - (a) the module and occurrence name of the thing - (b) its Unique - The way the compiler "knows about" one of these things is - where the type checker or desugarer needs to look it up. For - example, when desugaring list comprehensions the desugarer - needs to conjure up 'foldr'. It does this by looking up - foldrName in the environment. - - - RdrNames for Ids, DataCons etc that the compiler may emit into - generated code (e.g. for deriving). It's not necessary to know - the uniques for these guys, only their names - - -Note [Known-key names] -~~~~~~~~~~~~~~~~~~~~~~ -It is *very* important that the compiler gives wired-in things and -things with "known-key" names the correct Uniques wherever they -occur. We have to be careful about this in exactly two places: - - 1. When we parse some source code, renaming the AST better yield an - AST whose Names have the correct uniques - - 2. When we read an interface file, the read-in gubbins better have - the right uniques - -This is accomplished through a combination of mechanisms: - - 1. When parsing source code, the RdrName-decorated AST has some - RdrNames which are Exact. These are wired-in RdrNames where the - we could directly tell from the parsed syntax what Name to - use. For example, when we parse a [] in a type we can just insert - an Exact RdrName Name with the listTyConKey. - - Currently, I believe this is just an optimisation: it would be - equally valid to just output Orig RdrNames that correctly record - the module etc we expect the final Name to come from. However, - were we to eliminate isBuiltInOcc_maybe it would become essential - (see point 3). - - 2. The knownKeyNames (which consist of the basicKnownKeyNames from - the module, and those names reachable via the wired-in stuff from - TysWiredIn) are used to initialise the "OrigNameCache" in - IfaceEnv. This initialization ensures that when the type checker - or renamer (both of which use IfaceEnv) look up an original name - (i.e. a pair of a Module and an OccName) for a known-key name - they get the correct Unique. - - This is the most important mechanism for ensuring that known-key - stuff gets the right Unique, and is why it is so important to - place your known-key names in the appropriate lists. - - 3. For "infinite families" of known-key names (i.e. tuples and sums), we - have to be extra careful. Because there are an infinite number of - these things, we cannot add them to the list of known-key names - used to initialise the OrigNameCache. Instead, we have to - rely on never having to look them up in that cache. See - Note [Infinite families of known-key names] for details. - - -Note [Infinite families of known-key names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Infinite families of known-key things (e.g. tuples and sums) pose a tricky -problem: we can't add them to the knownKeyNames finite map which we use to -ensure that, e.g., a reference to (,) gets assigned the right unique (if this -doesn't sound familiar see Note [Known-key names] above). - -We instead handle tuples and sums separately from the "vanilla" known-key -things, - - a) The parser recognises them specially and generates an Exact Name (hence not - looked up in the orig-name cache) - - b) The known infinite families of names are specially serialised by - BinIface.putName, with that special treatment detected when we read back to - ensure that we get back to the correct uniques. See Note [Symbol table - representation of names] in BinIface and Note [How tuples work] in - TysWiredIn. - -Most of the infinite families cannot occur in source code, so mechanisms (a) and (b) -suffice to ensure that they always have the right Unique. In particular, -implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned -by the user. For those things that *can* appear in source programs, - - c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax - directly onto the corresponding name, rather than trying to find it in the - original-name cache. - - See also Note [Built-in syntax and the OrigNameCache] - -Note that one-tuples are an exception to the rule, as they do get assigned -known keys. See -Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) -in GHC.Builtin.Types. - -Note [The integer library] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Clearly, we need to know the names of various definitions of the integer -library, e.g. the type itself, `mkInteger` etc. But there are two possible -implementations of the integer library: - - * integer-gmp (fast, but uses libgmp, which may not be available on all - targets and is GPL licensed) - * integer-simple (slow, but pure Haskell and BSD-licensed) - -We want the compiler to work with either one. The way we achieve this is: - - * When compiling the integer-{gmp,simple} library, we pass - -this-unit-id integer-wired-in - to GHC (see the cabal file libraries/integer-{gmp,simple}. - * This way, GHC can use just this UnitID (see Module.integerUnitId) when - generating code, and the linker will succeed. - -Unfortuately, the abstraction is not complete: When using integer-gmp, we -really want to use the S# constructor directly. This is controlled by -the `integerLibrary` field of `DynFlags`: If it is IntegerGMP, we use -this constructor directly (see CorePrep.lookupIntegerSDataConName) - -When GHC reads the package data base, it (internally only) pretends it has UnitId -`integer-wired-in` instead of the actual UnitId (which includes the version -number); just like for `base` and other packages, as described in -Note [Wired-in packages] in Module. This is done in Packages.findWiredInPackages. --} - -{-# LANGUAGE CPP #-} - -module PrelNames ( - Unique, Uniquable(..), hasKey, -- Re-exported for convenience - - ----------------------------------------------------------- - module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName - -- (b) Uniques e.g. intTyConKey - -- (c) Groups of classes and types - -- (d) miscellaneous things - -- So many that we export them all - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Module -import OccName -import RdrName -import Unique -import Name -import SrcLoc -import FastString - -{- -************************************************************************ -* * - allNameStrings -* * -************************************************************************ --} - -allNameStrings :: [String] --- Infinite list of a,b,c...z, aa, ab, ac, ... etc -allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] - -{- -************************************************************************ -* * -\subsection{Local Names} -* * -************************************************************************ - -This *local* name is used by the interactive stuff --} - -itName :: Unique -> SrcSpan -> Name -itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc - --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: OccName -> Name -mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan - -isUnboundName :: Name -> Bool -isUnboundName name = name `hasKey` unboundKey - -{- -************************************************************************ -* * -\subsection{Known key Names} -* * -************************************************************************ - -This section tells what the compiler knows about the association of -names with uniques. These ones are the *non* wired-in ones. The -wired in ones are defined in TysWiredIn etc. --} - -basicKnownKeyNames :: [Name] -- See Note [Known-key names] -basicKnownKeyNames - = genericTyConNames - ++ [ -- Classes. *Must* include: - -- classes that are grabbed by key (e.g., eqClassKey) - -- classes in "Class.standardClassKeys" (quite a few) - eqClassName, -- mentioned, derivable - ordClassName, -- derivable - boundedClassName, -- derivable - numClassName, -- mentioned, numeric - enumClassName, -- derivable - monadClassName, - functorClassName, - realClassName, -- numeric - integralClassName, -- numeric - fractionalClassName, -- numeric - floatingClassName, -- numeric - realFracClassName, -- numeric - realFloatClassName, -- numeric - dataClassName, - isStringClassName, - applicativeClassName, - alternativeClassName, - foldableClassName, - traversableClassName, - semigroupClassName, sappendName, - monoidClassName, memptyName, mappendName, mconcatName, - - -- The IO type - -- See Note [TyConRepNames for non-wired-in TyCons] - ioTyConName, ioDataConName, - runMainIOName, - runRWName, - - -- Type representation types - trModuleTyConName, trModuleDataConName, - trNameTyConName, trNameSDataConName, trNameDDataConName, - trTyConTyConName, trTyConDataConName, - - -- Typeable - typeableClassName, - typeRepTyConName, - someTypeRepTyConName, - someTypeRepDataConName, - kindRepTyConName, - kindRepTyConAppDataConName, - kindRepVarDataConName, - kindRepAppDataConName, - kindRepFunDataConName, - kindRepTYPEDataConName, - kindRepTypeLitSDataConName, - kindRepTypeLitDDataConName, - typeLitSortTyConName, - typeLitSymbolDataConName, - typeLitNatDataConName, - typeRepIdName, - mkTrTypeName, - mkTrConName, - mkTrAppName, - mkTrFunName, - typeSymbolTypeRepName, typeNatTypeRepName, - trGhcPrimModuleName, - - -- KindReps for common cases - starKindRepName, - starArrStarKindRepName, - starArrStarArrStarKindRepName, - - -- Dynamic - toDynName, - - -- Numeric stuff - negateName, minusName, geName, eqName, - - -- Conversion functions - rationalTyConName, - ratioTyConName, ratioDataConName, - fromRationalName, fromIntegerName, - toIntegerName, toRationalName, - fromIntegralName, realToFracName, - - -- Int# stuff - divIntName, modIntName, - - -- String stuff - fromStringName, - - -- Enum stuff - enumFromName, enumFromThenName, - enumFromThenToName, enumFromToName, - - -- Applicative stuff - pureAName, apAName, thenAName, - - -- Functor stuff - fmapName, - - -- Monad stuff - thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, - returnMName, joinMName, - - -- MonadFail - monadFailClassName, failMName, - - -- MonadFix - monadFixClassName, mfixName, - - -- Arrow stuff - arrAName, composeAName, firstAName, - appAName, choiceAName, loopAName, - - -- Ix stuff - ixClassName, - - -- Show stuff - showClassName, - - -- Read stuff - readClassName, - - -- Stable pointers - newStablePtrName, - - -- GHC Extensions - groupWithName, - - -- Strings and lists - unpackCStringName, - unpackCStringFoldrName, unpackCStringUtf8Name, - - -- Overloaded lists - isListClassName, - fromListName, - fromListNName, - toListName, - - -- List operations - concatName, filterName, mapName, - zipName, foldrName, buildName, augmentName, appendName, - - -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, - int8TyConName, int16TyConName, int32TyConName, int64TyConName, - word16TyConName, word32TyConName, word64TyConName, - - -- Others - otherwiseIdName, inlineIdName, - eqStringName, assertName, breakpointName, breakpointCondName, - opaqueTyConName, - assertErrorName, traceName, - printName, fstName, sndName, - dollarName, - - -- Integer - integerTyConName, mkIntegerName, - integerToWord64Name, integerToInt64Name, - word64ToIntegerName, int64ToIntegerName, - plusIntegerName, timesIntegerName, smallIntegerName, - wordToIntegerName, - integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, - absIntegerName, signumIntegerName, - leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, - compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, divIntegerName, modIntegerName, - floatFromIntegerName, doubleFromIntegerName, - encodeFloatIntegerName, encodeDoubleIntegerName, - decodeDoubleIntegerName, - gcdIntegerName, lcmIntegerName, - andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName, bitIntegerName, - integerSDataConName,naturalSDataConName, - - -- Natural - naturalTyConName, - naturalFromIntegerName, naturalToIntegerName, - plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName, - wordToNaturalName, - - -- Float/Double - rationalToFloatName, - rationalToDoubleName, - - -- Other classes - randomClassName, randomGenClassName, monadPlusClassName, - - -- Type-level naturals - knownNatClassName, knownSymbolClassName, - - -- Overloaded labels - isLabelClassName, - - -- Implicit Parameters - ipClassName, - - -- Overloaded record fields - hasFieldClassName, - - -- Call Stacks - callStackTyConName, - emptyCallStackName, pushCallStackName, - - -- Source Locations - srcLocDataConName, - - -- Annotation type checking - toAnnotationWrapperName - - -- The SPEC type for SpecConstr - , specTyConName - - -- The Either type - , eitherTyConName, leftDataConName, rightDataConName - - -- Plugins - , pluginTyConName - , frontendPluginTyConName - - -- Generics - , genClassName, gen1ClassName - , datatypeClassName, constructorClassName, selectorClassName - - -- Monad comprehensions - , guardMName - , liftMName - , mzipName - - -- GHCi Sandbox - , ghciIoClassName, ghciStepIoMName - - -- StaticPtr - , makeStaticName - , staticPtrTyConName - , staticPtrDataConName, staticPtrInfoDataConName - , fromStaticPtrName - - -- Fingerprint - , fingerprintDataConName - - -- Custom type errors - , errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - - ] - -genericTyConNames :: [Name] -genericTyConNames = [ - v1TyConName, u1TyConName, par1TyConName, rec1TyConName, - k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, - d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName, uRecTyConName, - uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName, - prefixIDataConName, infixIDataConName, leftAssociativeDataConName, - rightAssociativeDataConName, notAssociativeDataConName, - sourceUnpackDataConName, sourceNoUnpackDataConName, - noSourceUnpackednessDataConName, sourceLazyDataConName, - sourceStrictDataConName, noSourceStrictnessDataConName, - decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, - metaDataDataConName, metaConsDataConName, metaSelDataConName - ] - -{- -************************************************************************ -* * -\subsection{Module names} -* * -************************************************************************ - - ---MetaHaskell Extension Add a new module here --} - -pRELUDE :: Module -pRELUDE = mkBaseModule_ pRELUDE_NAME - -gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM, - gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL, - gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING, - dATA_FOLDABLE, dATA_TRAVERSABLE, - gHC_CONC, gHC_IO, gHC_IO_Exception, - gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, - gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, - tYPEABLE, tYPEABLE_INTERNAL, gENERICS, - rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, - aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, - cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY, - dATA_COERCE, dEBUG_TRACE :: Module - -gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values -gHC_TYPES = mkPrimModule (fsLit "GHC.Types") -gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") -gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") -gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") -gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers") - -gHC_BASE = mkBaseModule (fsLit "GHC.Base") -gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") -gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") -gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers") -gHC_SHOW = mkBaseModule (fsLit "GHC.Show") -gHC_READ = mkBaseModule (fsLit "GHC.Read") -gHC_NUM = mkBaseModule (fsLit "GHC.Num") -gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe") -gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") -gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural") -gHC_LIST = mkBaseModule (fsLit "GHC.List") -gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") -dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") -dATA_EITHER = mkBaseModule (fsLit "Data.Either") -dATA_LIST = mkBaseModule (fsLit "Data.List") -dATA_STRING = mkBaseModule (fsLit "Data.String") -dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") -dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") -gHC_CONC = mkBaseModule (fsLit "GHC.Conc") -gHC_IO = mkBaseModule (fsLit "GHC.IO") -gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") -gHC_ST = mkBaseModule (fsLit "GHC.ST") -gHC_IX = mkBaseModule (fsLit "GHC.Ix") -gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") -gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") -gHC_ERR = mkBaseModule (fsLit "GHC.Err") -gHC_REAL = mkBaseModule (fsLit "GHC.Real") -gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") -gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") -sYSTEM_IO = mkBaseModule (fsLit "System.IO") -dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") -tYPEABLE = mkBaseModule (fsLit "Data.Typeable") -tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") -gENERICS = mkBaseModule (fsLit "Data.Data") -rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") -lEX = mkBaseModule (fsLit "Text.Read.Lex") -gHC_INT = mkBaseModule (fsLit "GHC.Int") -gHC_WORD = mkBaseModule (fsLit "GHC.Word") -mONAD = mkBaseModule (fsLit "Control.Monad") -mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") -mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") -mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail") -aRROW = mkBaseModule (fsLit "Control.Arrow") -cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") -gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") -rANDOM = mkBaseModule (fsLit "System.Random") -gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") -cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") -gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") -gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") -gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats") -dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") -dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") -dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace") - -gHC_SRCLOC :: Module -gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") - -gHC_STACK, gHC_STACK_TYPES :: Module -gHC_STACK = mkBaseModule (fsLit "GHC.Stack") -gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types") - -gHC_STATICPTR :: Module -gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") - -gHC_STATICPTR_INTERNAL :: Module -gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal") - -gHC_FINGERPRINT_TYPE :: Module -gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") - -gHC_OVER_LABELS :: Module -gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels") - -gHC_RECORDS :: Module -gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") - -mAIN, rOOT_MAIN :: Module -mAIN = mkMainModule_ mAIN_NAME -rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation - -mkInteractiveModule :: Int -> Module --- (mkInteractiveMoudule 9) makes module 'interactive:M9' -mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n)) - -pRELUDE_NAME, mAIN_NAME :: ModuleName -pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") -mAIN_NAME = mkModuleNameFS (fsLit "Main") - -dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName -dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") -dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") - -mkPrimModule :: FastString -> Module -mkPrimModule m = mkModule primUnitId (mkModuleNameFS m) - -mkIntegerModule :: FastString -> Module -mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m) - -mkBaseModule :: FastString -> Module -mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m) - -mkBaseModule_ :: ModuleName -> Module -mkBaseModule_ m = mkModule baseUnitId m - -mkThisGhcModule :: FastString -> Module -mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m) - -mkThisGhcModule_ :: ModuleName -> Module -mkThisGhcModule_ m = mkModule thisGhcUnitId m - -mkMainModule :: FastString -> Module -mkMainModule m = mkModule mainUnitId (mkModuleNameFS m) - -mkMainModule_ :: ModuleName -> Module -mkMainModule_ m = mkModule mainUnitId m - -{- -************************************************************************ -* * - RdrNames -* * -************************************************************************ --} - -main_RDR_Unqual :: RdrName -main_RDR_Unqual = mkUnqual varName (fsLit "main") - -- We definitely don't want an Orig RdrName, because - -- main might, in principle, be imported into module Main - -eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, - ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName -eq_RDR = nameRdrName eqName -ge_RDR = nameRdrName geName -le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") -lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") -gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") -compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") -ltTag_RDR = nameRdrName ordLTDataConName -eqTag_RDR = nameRdrName ordEQDataConName -gtTag_RDR = nameRdrName ordGTDataConName - -eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR - :: RdrName -eqClass_RDR = nameRdrName eqClassName -numClass_RDR = nameRdrName numClassName -ordClass_RDR = nameRdrName ordClassName -enumClass_RDR = nameRdrName enumClassName -monadClass_RDR = nameRdrName monadClassName - -map_RDR, append_RDR :: RdrName -map_RDR = nameRdrName mapName -append_RDR = nameRdrName appendName - -foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR - :: RdrName -foldr_RDR = nameRdrName foldrName -build_RDR = nameRdrName buildName -returnM_RDR = nameRdrName returnMName -bindM_RDR = nameRdrName bindMName -failM_RDR = nameRdrName failMName - -left_RDR, right_RDR :: RdrName -left_RDR = nameRdrName leftDataConName -right_RDR = nameRdrName rightDataConName - -fromEnum_RDR, toEnum_RDR :: RdrName -fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") -toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") - -enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName -enumFrom_RDR = nameRdrName enumFromName -enumFromTo_RDR = nameRdrName enumFromToName -enumFromThen_RDR = nameRdrName enumFromThenName -enumFromThenTo_RDR = nameRdrName enumFromThenToName - -ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName -ratioDataCon_RDR = nameRdrName ratioDataConName -plusInteger_RDR = nameRdrName plusIntegerName -timesInteger_RDR = nameRdrName timesIntegerName - -ioDataCon_RDR :: RdrName -ioDataCon_RDR = nameRdrName ioDataConName - -eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, - unpackCStringUtf8_RDR :: RdrName -eqString_RDR = nameRdrName eqStringName -unpackCString_RDR = nameRdrName unpackCStringName -unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName -unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name - -newStablePtr_RDR :: RdrName -newStablePtr_RDR = nameRdrName newStablePtrName - -bindIO_RDR, returnIO_RDR :: RdrName -bindIO_RDR = nameRdrName bindIOName -returnIO_RDR = nameRdrName returnIOName - -fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName -fromInteger_RDR = nameRdrName fromIntegerName -fromRational_RDR = nameRdrName fromRationalName -minus_RDR = nameRdrName minusName -times_RDR = varQual_RDR gHC_NUM (fsLit "*") -plus_RDR = varQual_RDR gHC_NUM (fsLit "+") - -toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName -toInteger_RDR = nameRdrName toIntegerName -toRational_RDR = nameRdrName toRationalName -fromIntegral_RDR = nameRdrName fromIntegralName - -stringTy_RDR, fromString_RDR :: RdrName -stringTy_RDR = tcQual_RDR gHC_BASE (fsLit "String") -fromString_RDR = nameRdrName fromStringName - -fromList_RDR, fromListN_RDR, toList_RDR :: RdrName -fromList_RDR = nameRdrName fromListName -fromListN_RDR = nameRdrName fromListNName -toList_RDR = nameRdrName toListName - -compose_RDR :: RdrName -compose_RDR = varQual_RDR gHC_BASE (fsLit ".") - -not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, - and_RDR, range_RDR, inRange_RDR, index_RDR, - unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName -and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") -not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") -getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") -succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") -pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") -minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") -maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") -range_RDR = varQual_RDR gHC_IX (fsLit "range") -inRange_RDR = varQual_RDR gHC_IX (fsLit "inRange") -index_RDR = varQual_RDR gHC_IX (fsLit "index") -unsafeIndex_RDR = varQual_RDR gHC_IX (fsLit "unsafeIndex") -unsafeRangeSize_RDR = varQual_RDR gHC_IX (fsLit "unsafeRangeSize") - -readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, - readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName -readList_RDR = varQual_RDR gHC_READ (fsLit "readList") -readListDefault_RDR = varQual_RDR gHC_READ (fsLit "readListDefault") -readListPrec_RDR = varQual_RDR gHC_READ (fsLit "readListPrec") -readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault") -readPrec_RDR = varQual_RDR gHC_READ (fsLit "readPrec") -parens_RDR = varQual_RDR gHC_READ (fsLit "parens") -choose_RDR = varQual_RDR gHC_READ (fsLit "choose") -lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP") -expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP") - -readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName -readField_RDR = varQual_RDR gHC_READ (fsLit "readField") -readFieldHash_RDR = varQual_RDR gHC_READ (fsLit "readFieldHash") -readSymField_RDR = varQual_RDR gHC_READ (fsLit "readSymField") - -punc_RDR, ident_RDR, symbol_RDR :: RdrName -punc_RDR = dataQual_RDR lEX (fsLit "Punc") -ident_RDR = dataQual_RDR lEX (fsLit "Ident") -symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") - -step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName -step_RDR = varQual_RDR rEAD_PREC (fsLit "step") -alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") -reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") -prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") -pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") - -showsPrec_RDR, shows_RDR, showString_RDR, - showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName -showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") -shows_RDR = varQual_RDR gHC_SHOW (fsLit "shows") -showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") -showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") -showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") -showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") - -undefined_RDR :: RdrName -undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") - -error_RDR :: RdrName -error_RDR = varQual_RDR gHC_ERR (fsLit "error") - --- Generics (constructors and functions) -u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, - k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, - prodDataCon_RDR, comp1DataCon_RDR, - unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, - from_RDR, from1_RDR, to_RDR, to1_RDR, - datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, - conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, - prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, - rightAssocDataCon_RDR, notAssocDataCon_RDR, - uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, - uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, - uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, - uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName - -u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") -par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") -rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") -k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") -m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") - -l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") -r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") - -prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") -comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") - -unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") -unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") -unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") -unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") - -from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") -from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") -to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") -to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") - -datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") -moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") -packageName_RDR = varQual_RDR gHC_GENERICS (fsLit "packageName") -isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype") -selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") -conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") -conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") -conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") - -prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") -infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") -leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName -rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName -notAssocDataCon_RDR = nameRdrName notAssociativeDataConName - -uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr") -uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar") -uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble") -uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat") -uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt") -uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord") - -uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#") -uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#") -uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#") -uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") -uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") -uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#") - -fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, - foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, - mappend_RDR :: RdrName -fmap_RDR = nameRdrName fmapName -replace_RDR = varQual_RDR gHC_BASE (fsLit "<$") -pure_RDR = nameRdrName pureAName -ap_RDR = nameRdrName apAName -liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2") -foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") -foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") -null_RDR = varQual_RDR dATA_FOLDABLE (fsLit "null") -all_RDR = varQual_RDR dATA_FOLDABLE (fsLit "all") -traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") -mempty_RDR = nameRdrName memptyName -mappend_RDR = nameRdrName mappendName - ----------------------- -varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR - :: Module -> FastString -> RdrName -varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) -tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) -clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) -dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) - -{- -************************************************************************ -* * -\subsection{Known-key names} -* * -************************************************************************ - -Many of these Names are not really "built in", but some parts of the -compiler (notably the deriving mechanism) need to mention their names, -and it's convenient to write them all down in one place. --} - -wildCardName :: Name -wildCardName = mkSystemVarName wildCardKey (fsLit "wild") - -runMainIOName, runRWName :: Name -runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey -runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey - -orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name -orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey -ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey -ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey -ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey - -specTyConName :: Name -specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey - -eitherTyConName, leftDataConName, rightDataConName :: Name -eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey -leftDataConName = dcQual dATA_EITHER (fsLit "Left") leftDataConKey -rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey - --- Generics (types) -v1TyConName, u1TyConName, par1TyConName, rec1TyConName, - k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, - d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName, uRecTyConName, - uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName, - prefixIDataConName, infixIDataConName, leftAssociativeDataConName, - rightAssociativeDataConName, notAssociativeDataConName, - sourceUnpackDataConName, sourceNoUnpackDataConName, - noSourceUnpackednessDataConName, sourceLazyDataConName, - sourceStrictDataConName, noSourceStrictnessDataConName, - decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, - metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name - -v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey -u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey -par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey -rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey -k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey -m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey - -sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey -prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey -compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey - -rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey -dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey -cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey -sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey - -rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey -d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey -c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey -s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey -noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey - -repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey -rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey - -uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey -uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey -uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey -uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey -uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey -uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey -uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey - -prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey -infixIDataConName = dcQual gHC_GENERICS (fsLit "InfixI") infixIDataConKey -leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey -rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey -notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey - -sourceUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey -sourceNoUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey -noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey -sourceLazyDataConName = dcQual gHC_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey -sourceStrictDataConName = dcQual gHC_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey -noSourceStrictnessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey -decidedLazyDataConName = dcQual gHC_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey -decidedStrictDataConName = dcQual gHC_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey -decidedUnpackDataConName = dcQual gHC_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey - -metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey -metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey -metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey - --- Primitive Int -divIntName, modIntName :: Name -divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey -modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey - --- Base strings Strings -unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, eqStringName :: Name -unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey -unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey -eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey - --- The 'inline' function -inlineIdName :: Name -inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey - --- Base classes (Eq, Ord, Functor) -fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name -eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey -eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey -ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey -geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey -functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey -fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey - --- Class Monad -monadClassName, thenMName, bindMName, returnMName :: Name -monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey -thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey -bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey -returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey - --- Class MonadFail -monadFailClassName, failMName :: Name -monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey -failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey - --- Class Applicative -applicativeClassName, pureAName, apAName, thenAName :: Name -applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey -apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey -pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey -thenAName = varQual gHC_BASE (fsLit "*>") thenAClassOpKey - --- Classes (Foldable, Traversable) -foldableClassName, traversableClassName :: Name -foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey -traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey - --- Classes (Semigroup, Monoid) -semigroupClassName, sappendName :: Name -semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey -sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey -monoidClassName, memptyName, mappendName, mconcatName :: Name -monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey -memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey -mappendName = varQual gHC_BASE (fsLit "mappend") mappendClassOpKey -mconcatName = varQual gHC_BASE (fsLit "mconcat") mconcatClassOpKey - - - --- AMP additions - -joinMName, alternativeClassName :: Name -joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey -alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey - --- -joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, - alternativeClassKey :: Unique -joinMIdKey = mkPreludeMiscIdUnique 750 -apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> -pureAClassOpKey = mkPreludeMiscIdUnique 752 -thenAClassOpKey = mkPreludeMiscIdUnique 753 -alternativeClassKey = mkPreludeMiscIdUnique 754 - - --- Functions for GHC extensions -groupWithName :: Name -groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey - --- Random PrelBase functions -fromStringName, otherwiseIdName, foldrName, buildName, augmentName, - mapName, appendName, assertName, - breakpointName, breakpointCondName, - opaqueTyConName, dollarName :: Name -dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey -otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey -foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey -buildName = varQual gHC_BASE (fsLit "build") buildIdKey -augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey -mapName = varQual gHC_BASE (fsLit "map") mapIdKey -appendName = varQual gHC_BASE (fsLit "++") appendIdKey -assertName = varQual gHC_BASE (fsLit "assert") assertIdKey -breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey -breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey -opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey -fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey - --- PrelTup -fstName, sndName :: Name -fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey -sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey - --- Module GHC.Num -numClassName, fromIntegerName, minusName, negateName :: Name -numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey -fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey -minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey -negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey - -integerTyConName, mkIntegerName, integerSDataConName, - integerToWord64Name, integerToInt64Name, - word64ToIntegerName, int64ToIntegerName, - plusIntegerName, timesIntegerName, smallIntegerName, - wordToIntegerName, - integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, - absIntegerName, signumIntegerName, - leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, - compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, divIntegerName, modIntegerName, - floatFromIntegerName, doubleFromIntegerName, - encodeFloatIntegerName, encodeDoubleIntegerName, - decodeDoubleIntegerName, - gcdIntegerName, lcmIntegerName, - andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name -integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey -integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit "S#") integerSDataConKey -mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey -integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey -integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey -word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey -int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey -plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey -timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey -smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey -wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey -integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey -integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey -minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey -negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey -eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey -neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey -absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey -signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey -leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey -gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey -ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey -geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey -compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey -quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey -divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey -quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey -remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey -divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey -modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey -floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey -doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey -encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey -encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey -decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey -gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey -lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey -andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey -orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey -xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey -complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey -shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey -shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey -bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey - --- GHC.Natural types -naturalTyConName, naturalSDataConName :: Name -naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey -naturalSDataConName = dcQual gHC_NATURAL (fsLit "NatS#") naturalSDataConKey - -naturalFromIntegerName :: Name -naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey - -naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName, - mkNaturalName, wordToNaturalName :: Name -naturalToIntegerName = varQual gHC_NATURAL (fsLit "naturalToInteger") naturalToIntegerIdKey -plusNaturalName = varQual gHC_NATURAL (fsLit "plusNatural") plusNaturalIdKey -minusNaturalName = varQual gHC_NATURAL (fsLit "minusNatural") minusNaturalIdKey -timesNaturalName = varQual gHC_NATURAL (fsLit "timesNatural") timesNaturalIdKey -mkNaturalName = varQual gHC_NATURAL (fsLit "mkNatural") mkNaturalIdKey -wordToNaturalName = varQual gHC_NATURAL (fsLit "wordToNatural#") wordToNaturalIdKey - --- GHC.Real types and classes -rationalTyConName, ratioTyConName, ratioDataConName, realClassName, - integralClassName, realFracClassName, fractionalClassName, - fromRationalName, toIntegerName, toRationalName, fromIntegralName, - realToFracName :: Name -rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey -ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey -ratioDataConName = dcQual gHC_REAL (fsLit ":%") ratioDataConKey -realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey -integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey -realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey -fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey -fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey -toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey -toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey -fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey -realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey - --- PrelFloat classes -floatingClassName, realFloatClassName :: Name -floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey -realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey - --- other GHC.Float functions -rationalToFloatName, rationalToDoubleName :: Name -rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey -rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey - --- Class Ix -ixClassName :: Name -ixClassName = clsQual gHC_IX (fsLit "Ix") ixClassKey - --- Typeable representation types -trModuleTyConName - , trModuleDataConName - , trNameTyConName - , trNameSDataConName - , trNameDDataConName - , trTyConTyConName - , trTyConDataConName - :: Name -trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey -trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey -trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey -trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey -trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey -trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey -trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey - -kindRepTyConName - , kindRepTyConAppDataConName - , kindRepVarDataConName - , kindRepAppDataConName - , kindRepFunDataConName - , kindRepTYPEDataConName - , kindRepTypeLitSDataConName - , kindRepTypeLitDDataConName - :: Name -kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey -kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey -kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey -kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey -kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey -kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey -kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey -kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey - -typeLitSortTyConName - , typeLitSymbolDataConName - , typeLitNatDataConName - :: Name -typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey -typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey -typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey - --- Class Typeable, and functions for constructing `Typeable` dictionaries -typeableClassName - , typeRepTyConName - , someTypeRepTyConName - , someTypeRepDataConName - , mkTrTypeName - , mkTrConName - , mkTrAppName - , mkTrFunName - , typeRepIdName - , typeNatTypeRepName - , typeSymbolTypeRepName - , trGhcPrimModuleName - :: Name -typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey -typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey -someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey -someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey -typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey -mkTrTypeName = varQual tYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey -mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey -mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey -mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey -typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey -typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey --- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) --- See Note [Grand plan for Typeable] in TcTypeable. -trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey - --- Typeable KindReps for some common cases -starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name -starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey -starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey -starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey - --- Custom type errors -errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - :: Name - -errorMessageTypeErrorFamName = - tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey - -typeErrorTextDataConName = - dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey - -typeErrorAppendDataConName = - dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey - -typeErrorVAppendDataConName = - dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey - -typeErrorShowTypeDataConName = - dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey - - - --- Dynamic -toDynName :: Name -toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey - --- Class Data -dataClassName :: Name -dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey - --- Error module -assertErrorName :: Name -assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey - --- Debug.Trace -traceName :: Name -traceName = varQual dEBUG_TRACE (fsLit "trace") traceKey - --- Enum module (Enum, Bounded) -enumClassName, enumFromName, enumFromToName, enumFromThenName, - enumFromThenToName, boundedClassName :: Name -enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey -enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey -enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey -enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey -enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey -boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey - --- List functions -concatName, filterName, zipName :: Name -concatName = varQual gHC_LIST (fsLit "concat") concatIdKey -filterName = varQual gHC_LIST (fsLit "filter") filterIdKey -zipName = varQual gHC_LIST (fsLit "zip") zipIdKey - --- Overloaded lists -isListClassName, fromListName, fromListNName, toListName :: Name -isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey -fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey -fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey -toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey - --- Class Show -showClassName :: Name -showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey - --- Class Read -readClassName :: Name -readClassName = clsQual gHC_READ (fsLit "Read") readClassKey - --- Classes Generic and Generic1, Datatype, Constructor and Selector -genClassName, gen1ClassName, datatypeClassName, constructorClassName, - selectorClassName :: Name -genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey -gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey - -datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey -constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey -selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey - -genericClassNames :: [Name] -genericClassNames = [genClassName, gen1ClassName] - --- GHCi things -ghciIoClassName, ghciStepIoMName :: Name -ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey -ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey - --- IO things -ioTyConName, ioDataConName, - thenIOName, bindIOName, returnIOName, failIOName :: Name -ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey -ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey -thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey -bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey -returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey -failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey - --- IO things -printName :: Name -printName = varQual sYSTEM_IO (fsLit "print") printIdKey - --- Int, Word, and Addr things -int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name -int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey -int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey -int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey -int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey - --- Word module -word16TyConName, word32TyConName, word64TyConName :: Name -word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey -word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey -word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey - --- PrelPtr module -ptrTyConName, funPtrTyConName :: Name -ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey -funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey - --- Foreign objects and weak pointers -stablePtrTyConName, newStablePtrName :: Name -stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey -newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey - --- Recursive-do notation -monadFixClassName, mfixName :: Name -monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey -mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey - --- Arrow notation -arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name -arrAName = varQual aRROW (fsLit "arr") arrAIdKey -composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey -firstAName = varQual aRROW (fsLit "first") firstAIdKey -appAName = varQual aRROW (fsLit "app") appAIdKey -choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey -loopAName = varQual aRROW (fsLit "loop") loopAIdKey - --- Monad comprehensions -guardMName, liftMName, mzipName :: Name -guardMName = varQual mONAD (fsLit "guard") guardMIdKey -liftMName = varQual mONAD (fsLit "liftM") liftMIdKey -mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey - - --- Annotation type checking -toAnnotationWrapperName :: Name -toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey - --- Other classes, needed for type defaulting -monadPlusClassName, randomClassName, randomGenClassName, - isStringClassName :: Name -monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey -randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey -isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey - --- Type-level naturals -knownNatClassName :: Name -knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey -knownSymbolClassName :: Name -knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey - --- Overloaded labels -isLabelClassName :: Name -isLabelClassName - = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey - --- Implicit Parameters -ipClassName :: Name -ipClassName - = clsQual gHC_CLASSES (fsLit "IP") ipClassKey - --- Overloaded record fields -hasFieldClassName :: Name -hasFieldClassName - = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey - --- Source Locations -callStackTyConName, emptyCallStackName, pushCallStackName, - srcLocDataConName :: Name -callStackTyConName - = tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey -emptyCallStackName - = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey -pushCallStackName - = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey -srcLocDataConName - = dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey - --- plugins -pLUGINS :: Module -pLUGINS = mkThisGhcModule (fsLit "Plugins") -pluginTyConName :: Name -pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey -frontendPluginTyConName :: Name -frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey - --- Static pointers -makeStaticName :: Name -makeStaticName = - varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey - -staticPtrInfoTyConName :: Name -staticPtrInfoTyConName = - tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey - -staticPtrInfoDataConName :: Name -staticPtrInfoDataConName = - dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey - -staticPtrTyConName :: Name -staticPtrTyConName = - tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey - -staticPtrDataConName :: Name -staticPtrDataConName = - dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey - -fromStaticPtrName :: Name -fromStaticPtrName = - varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey - -fingerprintDataConName :: Name -fingerprintDataConName = - dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey - -{- -************************************************************************ -* * -\subsection{Local helpers} -* * -************************************************************************ - -All these are original names; hence mkOrig --} - -varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name -varQual = mk_known_key_name varName -tcQual = mk_known_key_name tcName -clsQual = mk_known_key_name clsName -dcQual = mk_known_key_name dataName - -mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name -mk_known_key_name space modu str unique - = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan - - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} -* * -************************************************************************ ---MetaHaskell extension hand allocate keys here --} - -boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, - fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, - functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, - realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique -boundedClassKey = mkPreludeClassUnique 1 -enumClassKey = mkPreludeClassUnique 2 -eqClassKey = mkPreludeClassUnique 3 -floatingClassKey = mkPreludeClassUnique 5 -fractionalClassKey = mkPreludeClassUnique 6 -integralClassKey = mkPreludeClassUnique 7 -monadClassKey = mkPreludeClassUnique 8 -dataClassKey = mkPreludeClassUnique 9 -functorClassKey = mkPreludeClassUnique 10 -numClassKey = mkPreludeClassUnique 11 -ordClassKey = mkPreludeClassUnique 12 -readClassKey = mkPreludeClassUnique 13 -realClassKey = mkPreludeClassUnique 14 -realFloatClassKey = mkPreludeClassUnique 15 -realFracClassKey = mkPreludeClassUnique 16 -showClassKey = mkPreludeClassUnique 17 -ixClassKey = mkPreludeClassUnique 18 - -typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey, - typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey - :: Unique -typeableClassKey = mkPreludeClassUnique 20 -typeable1ClassKey = mkPreludeClassUnique 21 -typeable2ClassKey = mkPreludeClassUnique 22 -typeable3ClassKey = mkPreludeClassUnique 23 -typeable4ClassKey = mkPreludeClassUnique 24 -typeable5ClassKey = mkPreludeClassUnique 25 -typeable6ClassKey = mkPreludeClassUnique 26 -typeable7ClassKey = mkPreludeClassUnique 27 - -monadFixClassKey :: Unique -monadFixClassKey = mkPreludeClassUnique 28 - -monadFailClassKey :: Unique -monadFailClassKey = mkPreludeClassUnique 29 - -monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique -monadPlusClassKey = mkPreludeClassUnique 30 -randomClassKey = mkPreludeClassUnique 31 -randomGenClassKey = mkPreludeClassUnique 32 - -isStringClassKey :: Unique -isStringClassKey = mkPreludeClassUnique 33 - -applicativeClassKey, foldableClassKey, traversableClassKey :: Unique -applicativeClassKey = mkPreludeClassUnique 34 -foldableClassKey = mkPreludeClassUnique 35 -traversableClassKey = mkPreludeClassUnique 36 - -genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, - selectorClassKey :: Unique -genClassKey = mkPreludeClassUnique 37 -gen1ClassKey = mkPreludeClassUnique 38 - -datatypeClassKey = mkPreludeClassUnique 39 -constructorClassKey = mkPreludeClassUnique 40 -selectorClassKey = mkPreludeClassUnique 41 - --- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in TcEvidence -knownNatClassNameKey :: Unique -knownNatClassNameKey = mkPreludeClassUnique 42 - --- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in TcEvidence -knownSymbolClassNameKey :: Unique -knownSymbolClassNameKey = mkPreludeClassUnique 43 - -ghciIoClassKey :: Unique -ghciIoClassKey = mkPreludeClassUnique 44 - -isLabelClassNameKey :: Unique -isLabelClassNameKey = mkPreludeClassUnique 45 - -semigroupClassKey, monoidClassKey :: Unique -semigroupClassKey = mkPreludeClassUnique 46 -monoidClassKey = mkPreludeClassUnique 47 - --- Implicit Parameters -ipClassKey :: Unique -ipClassKey = mkPreludeClassUnique 48 - --- Overloaded record fields -hasFieldClassNameKey :: Unique -hasFieldClassNameKey = mkPreludeClassUnique 49 - - ----------------- Template Haskell ------------------- --- THNames.hs: USES ClassUniques 200-299 ------------------------------------------------------ - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} -* * -************************************************************************ --} - -addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, - byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, - doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, - intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, - int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, - int64PrimTyConKey, int64TyConKey, - integerTyConKey, naturalTyConKey, - listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, - weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, - mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, - ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, - stablePtrTyConKey, eqTyConKey, heqTyConKey, - smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique -addrPrimTyConKey = mkPreludeTyConUnique 1 -arrayPrimTyConKey = mkPreludeTyConUnique 3 -boolTyConKey = mkPreludeTyConUnique 4 -byteArrayPrimTyConKey = mkPreludeTyConUnique 5 -charPrimTyConKey = mkPreludeTyConUnique 7 -charTyConKey = mkPreludeTyConUnique 8 -doublePrimTyConKey = mkPreludeTyConUnique 9 -doubleTyConKey = mkPreludeTyConUnique 10 -floatPrimTyConKey = mkPreludeTyConUnique 11 -floatTyConKey = mkPreludeTyConUnique 12 -funTyConKey = mkPreludeTyConUnique 13 -intPrimTyConKey = mkPreludeTyConUnique 14 -intTyConKey = mkPreludeTyConUnique 15 -int8PrimTyConKey = mkPreludeTyConUnique 16 -int8TyConKey = mkPreludeTyConUnique 17 -int16PrimTyConKey = mkPreludeTyConUnique 18 -int16TyConKey = mkPreludeTyConUnique 19 -int32PrimTyConKey = mkPreludeTyConUnique 20 -int32TyConKey = mkPreludeTyConUnique 21 -int64PrimTyConKey = mkPreludeTyConUnique 22 -int64TyConKey = mkPreludeTyConUnique 23 -integerTyConKey = mkPreludeTyConUnique 24 -naturalTyConKey = mkPreludeTyConUnique 25 - -listTyConKey = mkPreludeTyConUnique 26 -foreignObjPrimTyConKey = mkPreludeTyConUnique 27 -maybeTyConKey = mkPreludeTyConUnique 28 -weakPrimTyConKey = mkPreludeTyConUnique 29 -mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 -mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 -orderingTyConKey = mkPreludeTyConUnique 32 -mVarPrimTyConKey = mkPreludeTyConUnique 33 -ratioTyConKey = mkPreludeTyConUnique 34 -rationalTyConKey = mkPreludeTyConUnique 35 -realWorldTyConKey = mkPreludeTyConUnique 36 -stablePtrPrimTyConKey = mkPreludeTyConUnique 37 -stablePtrTyConKey = mkPreludeTyConUnique 38 -eqTyConKey = mkPreludeTyConUnique 40 -heqTyConKey = mkPreludeTyConUnique 41 -arrayArrayPrimTyConKey = mkPreludeTyConUnique 42 -mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 43 - -statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, - mutVarPrimTyConKey, ioTyConKey, - wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, - word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, - word64PrimTyConKey, word64TyConKey, - liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, - typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, - eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey, - compactPrimTyConKey :: Unique -statePrimTyConKey = mkPreludeTyConUnique 50 -stableNamePrimTyConKey = mkPreludeTyConUnique 51 -stableNameTyConKey = mkPreludeTyConUnique 52 -eqPrimTyConKey = mkPreludeTyConUnique 53 -eqReprPrimTyConKey = mkPreludeTyConUnique 54 -eqPhantPrimTyConKey = mkPreludeTyConUnique 55 -mutVarPrimTyConKey = mkPreludeTyConUnique 56 -ioTyConKey = mkPreludeTyConUnique 57 -voidPrimTyConKey = mkPreludeTyConUnique 58 -wordPrimTyConKey = mkPreludeTyConUnique 59 -wordTyConKey = mkPreludeTyConUnique 60 -word8PrimTyConKey = mkPreludeTyConUnique 61 -word8TyConKey = mkPreludeTyConUnique 62 -word16PrimTyConKey = mkPreludeTyConUnique 63 -word16TyConKey = mkPreludeTyConUnique 64 -word32PrimTyConKey = mkPreludeTyConUnique 65 -word32TyConKey = mkPreludeTyConUnique 66 -word64PrimTyConKey = mkPreludeTyConUnique 67 -word64TyConKey = mkPreludeTyConUnique 68 -liftedConKey = mkPreludeTyConUnique 69 -unliftedConKey = mkPreludeTyConUnique 70 -anyBoxConKey = mkPreludeTyConUnique 71 -kindConKey = mkPreludeTyConUnique 72 -boxityConKey = mkPreludeTyConUnique 73 -typeConKey = mkPreludeTyConUnique 74 -threadIdPrimTyConKey = mkPreludeTyConUnique 75 -bcoPrimTyConKey = mkPreludeTyConUnique 76 -ptrTyConKey = mkPreludeTyConUnique 77 -funPtrTyConKey = mkPreludeTyConUnique 78 -tVarPrimTyConKey = mkPreludeTyConUnique 79 -compactPrimTyConKey = mkPreludeTyConUnique 80 - --- dotnet interop -objectTyConKey :: Unique -objectTyConKey = mkPreludeTyConUnique 83 - -eitherTyConKey :: Unique -eitherTyConKey = mkPreludeTyConUnique 84 - --- Kind constructors -liftedTypeKindTyConKey, tYPETyConKey, - constraintKindTyConKey, runtimeRepTyConKey, - vecCountTyConKey, vecElemTyConKey :: Unique -liftedTypeKindTyConKey = mkPreludeTyConUnique 87 -tYPETyConKey = mkPreludeTyConUnique 88 -constraintKindTyConKey = mkPreludeTyConUnique 92 -runtimeRepTyConKey = mkPreludeTyConUnique 95 -vecCountTyConKey = mkPreludeTyConUnique 96 -vecElemTyConKey = mkPreludeTyConUnique 97 - -pluginTyConKey, frontendPluginTyConKey :: Unique -pluginTyConKey = mkPreludeTyConUnique 102 -frontendPluginTyConKey = mkPreludeTyConUnique 103 - -unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, - opaqueTyConKey :: Unique -unknownTyConKey = mkPreludeTyConUnique 129 -unknown1TyConKey = mkPreludeTyConUnique 130 -unknown2TyConKey = mkPreludeTyConUnique 131 -unknown3TyConKey = mkPreludeTyConUnique 132 -opaqueTyConKey = mkPreludeTyConUnique 133 - --- Generics (Unique keys) -v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, - k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, - compTyConKey, rTyConKey, dTyConKey, - cTyConKey, sTyConKey, rec0TyConKey, - d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, - repTyConKey, rep1TyConKey, uRecTyConKey, - uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, - uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique - -v1TyConKey = mkPreludeTyConUnique 135 -u1TyConKey = mkPreludeTyConUnique 136 -par1TyConKey = mkPreludeTyConUnique 137 -rec1TyConKey = mkPreludeTyConUnique 138 -k1TyConKey = mkPreludeTyConUnique 139 -m1TyConKey = mkPreludeTyConUnique 140 - -sumTyConKey = mkPreludeTyConUnique 141 -prodTyConKey = mkPreludeTyConUnique 142 -compTyConKey = mkPreludeTyConUnique 143 - -rTyConKey = mkPreludeTyConUnique 144 -dTyConKey = mkPreludeTyConUnique 146 -cTyConKey = mkPreludeTyConUnique 147 -sTyConKey = mkPreludeTyConUnique 148 - -rec0TyConKey = mkPreludeTyConUnique 149 -d1TyConKey = mkPreludeTyConUnique 151 -c1TyConKey = mkPreludeTyConUnique 152 -s1TyConKey = mkPreludeTyConUnique 153 -noSelTyConKey = mkPreludeTyConUnique 154 - -repTyConKey = mkPreludeTyConUnique 155 -rep1TyConKey = mkPreludeTyConUnique 156 - -uRecTyConKey = mkPreludeTyConUnique 157 -uAddrTyConKey = mkPreludeTyConUnique 158 -uCharTyConKey = mkPreludeTyConUnique 159 -uDoubleTyConKey = mkPreludeTyConUnique 160 -uFloatTyConKey = mkPreludeTyConUnique 161 -uIntTyConKey = mkPreludeTyConUnique 162 -uWordTyConKey = mkPreludeTyConUnique 163 - --- Type-level naturals -typeNatKindConNameKey, typeSymbolKindConNameKey, - typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, - typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey - , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey - , typeNatDivTyFamNameKey - , typeNatModTyFamNameKey - , typeNatLogTyFamNameKey - :: Unique -typeNatKindConNameKey = mkPreludeTyConUnique 164 -typeSymbolKindConNameKey = mkPreludeTyConUnique 165 -typeNatAddTyFamNameKey = mkPreludeTyConUnique 166 -typeNatMulTyFamNameKey = mkPreludeTyConUnique 167 -typeNatExpTyFamNameKey = mkPreludeTyConUnique 168 -typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169 -typeNatSubTyFamNameKey = mkPreludeTyConUnique 170 -typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171 -typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172 -typeNatDivTyFamNameKey = mkPreludeTyConUnique 173 -typeNatModTyFamNameKey = mkPreludeTyConUnique 174 -typeNatLogTyFamNameKey = mkPreludeTyConUnique 175 - --- Custom user type-errors -errorMessageTypeErrorFamKey :: Unique -errorMessageTypeErrorFamKey = mkPreludeTyConUnique 176 - - - -ntTyConKey:: Unique -ntTyConKey = mkPreludeTyConUnique 177 -coercibleTyConKey :: Unique -coercibleTyConKey = mkPreludeTyConUnique 178 - -proxyPrimTyConKey :: Unique -proxyPrimTyConKey = mkPreludeTyConUnique 179 - -specTyConKey :: Unique -specTyConKey = mkPreludeTyConUnique 180 - -anyTyConKey :: Unique -anyTyConKey = mkPreludeTyConUnique 181 - -smallArrayPrimTyConKey = mkPreludeTyConUnique 182 -smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 183 - -staticPtrTyConKey :: Unique -staticPtrTyConKey = mkPreludeTyConUnique 184 - -staticPtrInfoTyConKey :: Unique -staticPtrInfoTyConKey = mkPreludeTyConUnique 185 - -callStackTyConKey :: Unique -callStackTyConKey = mkPreludeTyConUnique 186 - --- Typeables -typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique -typeRepTyConKey = mkPreludeTyConUnique 187 -someTypeRepTyConKey = mkPreludeTyConUnique 188 -someTypeRepDataConKey = mkPreludeTyConUnique 189 - - -typeSymbolAppendFamNameKey :: Unique -typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190 - ----------------- Template Haskell ------------------- --- THNames.hs: USES TyConUniques 200-299 ------------------------------------------------------ - ------------------------ SIMD ------------------------ --- USES TyConUniques 300-399 ------------------------------------------------------ - -#include "primop-vector-uniques.hs-incl" - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} -* * -************************************************************************ --} - -charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, - floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, - ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey, - coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique - -charDataConKey = mkPreludeDataConUnique 1 -consDataConKey = mkPreludeDataConUnique 2 -doubleDataConKey = mkPreludeDataConUnique 3 -falseDataConKey = mkPreludeDataConUnique 4 -floatDataConKey = mkPreludeDataConUnique 5 -intDataConKey = mkPreludeDataConUnique 6 -integerSDataConKey = mkPreludeDataConUnique 7 -nothingDataConKey = mkPreludeDataConUnique 8 -justDataConKey = mkPreludeDataConUnique 9 -eqDataConKey = mkPreludeDataConUnique 10 -nilDataConKey = mkPreludeDataConUnique 11 -ratioDataConKey = mkPreludeDataConUnique 12 -word8DataConKey = mkPreludeDataConUnique 13 -stableNameDataConKey = mkPreludeDataConUnique 14 -trueDataConKey = mkPreludeDataConUnique 15 -wordDataConKey = mkPreludeDataConUnique 16 -ioDataConKey = mkPreludeDataConUnique 17 -integerDataConKey = mkPreludeDataConUnique 18 -heqDataConKey = mkPreludeDataConUnique 19 - --- Generic data constructors -crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique -crossDataConKey = mkPreludeDataConUnique 20 -inlDataConKey = mkPreludeDataConUnique 21 -inrDataConKey = mkPreludeDataConUnique 22 -genUnitDataConKey = mkPreludeDataConUnique 23 - -leftDataConKey, rightDataConKey :: Unique -leftDataConKey = mkPreludeDataConUnique 25 -rightDataConKey = mkPreludeDataConUnique 26 - -ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique -ordLTDataConKey = mkPreludeDataConUnique 27 -ordEQDataConKey = mkPreludeDataConUnique 28 -ordGTDataConKey = mkPreludeDataConUnique 29 - - -coercibleDataConKey = mkPreludeDataConUnique 32 - -staticPtrDataConKey :: Unique -staticPtrDataConKey = mkPreludeDataConUnique 33 - -staticPtrInfoDataConKey :: Unique -staticPtrInfoDataConKey = mkPreludeDataConUnique 34 - -fingerprintDataConKey :: Unique -fingerprintDataConKey = mkPreludeDataConUnique 35 - -srcLocDataConKey :: Unique -srcLocDataConKey = mkPreludeDataConUnique 37 - -trTyConTyConKey, trTyConDataConKey, - trModuleTyConKey, trModuleDataConKey, - trNameTyConKey, trNameSDataConKey, trNameDDataConKey, - trGhcPrimModuleKey, kindRepTyConKey, - typeLitSortTyConKey :: Unique -trTyConTyConKey = mkPreludeDataConUnique 40 -trTyConDataConKey = mkPreludeDataConUnique 41 -trModuleTyConKey = mkPreludeDataConUnique 42 -trModuleDataConKey = mkPreludeDataConUnique 43 -trNameTyConKey = mkPreludeDataConUnique 44 -trNameSDataConKey = mkPreludeDataConUnique 45 -trNameDDataConKey = mkPreludeDataConUnique 46 -trGhcPrimModuleKey = mkPreludeDataConUnique 47 -kindRepTyConKey = mkPreludeDataConUnique 48 -typeLitSortTyConKey = mkPreludeDataConUnique 49 - -typeErrorTextDataConKey, - typeErrorAppendDataConKey, - typeErrorVAppendDataConKey, - typeErrorShowTypeDataConKey - :: Unique -typeErrorTextDataConKey = mkPreludeDataConUnique 50 -typeErrorAppendDataConKey = mkPreludeDataConUnique 51 -typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 -typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 - -prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, - rightAssociativeDataConKey, notAssociativeDataConKey, - sourceUnpackDataConKey, sourceNoUnpackDataConKey, - noSourceUnpackednessDataConKey, sourceLazyDataConKey, - sourceStrictDataConKey, noSourceStrictnessDataConKey, - decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, - metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique -prefixIDataConKey = mkPreludeDataConUnique 54 -infixIDataConKey = mkPreludeDataConUnique 55 -leftAssociativeDataConKey = mkPreludeDataConUnique 56 -rightAssociativeDataConKey = mkPreludeDataConUnique 57 -notAssociativeDataConKey = mkPreludeDataConUnique 58 -sourceUnpackDataConKey = mkPreludeDataConUnique 59 -sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 -noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 -sourceLazyDataConKey = mkPreludeDataConUnique 62 -sourceStrictDataConKey = mkPreludeDataConUnique 63 -noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 -decidedLazyDataConKey = mkPreludeDataConUnique 65 -decidedStrictDataConKey = mkPreludeDataConUnique 66 -decidedUnpackDataConKey = mkPreludeDataConUnique 67 -metaDataDataConKey = mkPreludeDataConUnique 68 -metaConsDataConKey = mkPreludeDataConUnique 69 -metaSelDataConKey = mkPreludeDataConUnique 70 - -vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique -vecRepDataConKey = mkPreludeDataConUnique 71 -tupleRepDataConKey = mkPreludeDataConUnique 72 -sumRepDataConKey = mkPreludeDataConUnique 73 - --- See Note [Wiring in RuntimeRep] in TysWiredIn -runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] -liftedRepDataConKey :: Unique -runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) - = map mkPreludeDataConUnique [74..88] - -unliftedRepDataConKeys = vecRepDataConKey : - tupleRepDataConKey : - sumRepDataConKey : - unliftedSimpleRepDataConKeys - --- See Note [Wiring in RuntimeRep] in TysWiredIn --- VecCount -vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [89..94] - --- See Note [Wiring in RuntimeRep] in TysWiredIn --- VecElem -vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [95..104] - --- Typeable things -kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, - kindRepFunDataConKey, kindRepTYPEDataConKey, - kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey - :: Unique -kindRepTyConAppDataConKey = mkPreludeDataConUnique 105 -kindRepVarDataConKey = mkPreludeDataConUnique 106 -kindRepAppDataConKey = mkPreludeDataConUnique 107 -kindRepFunDataConKey = mkPreludeDataConUnique 108 -kindRepTYPEDataConKey = mkPreludeDataConUnique 109 -kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110 -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111 - -typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique -typeLitSymbolDataConKey = mkPreludeDataConUnique 112 -typeLitNatDataConKey = mkPreludeDataConUnique 113 - - ----------------- Template Haskell ------------------- --- THNames.hs: USES DataUniques 200-250 ------------------------------------------------------ - - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} -* * -************************************************************************ --} - -wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, - buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey, - seqIdKey, eqStringIdKey, - noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, - runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, - realWorldPrimIdKey, recConErrorIdKey, - unpackCStringUtf8IdKey, unpackCStringAppendIdKey, - unpackCStringFoldrIdKey, unpackCStringIdKey, - typeErrorIdKey, divIntIdKey, modIntIdKey, - absentSumFieldErrorIdKey :: Unique - -wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] -absentErrorIdKey = mkPreludeMiscIdUnique 1 -augmentIdKey = mkPreludeMiscIdUnique 2 -appendIdKey = mkPreludeMiscIdUnique 3 -buildIdKey = mkPreludeMiscIdUnique 4 -errorIdKey = mkPreludeMiscIdUnique 5 -foldrIdKey = mkPreludeMiscIdUnique 6 -recSelErrorIdKey = mkPreludeMiscIdUnique 7 -seqIdKey = mkPreludeMiscIdUnique 8 -eqStringIdKey = mkPreludeMiscIdUnique 10 -noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 -runtimeErrorIdKey = mkPreludeMiscIdUnique 13 -patErrorIdKey = mkPreludeMiscIdUnique 14 -realWorldPrimIdKey = mkPreludeMiscIdUnique 15 -recConErrorIdKey = mkPreludeMiscIdUnique 16 -unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 -unpackCStringIdKey = mkPreludeMiscIdUnique 20 -voidPrimIdKey = mkPreludeMiscIdUnique 21 -typeErrorIdKey = mkPreludeMiscIdUnique 22 -divIntIdKey = mkPreludeMiscIdUnique 23 -modIntIdKey = mkPreludeMiscIdUnique 24 -absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 - -unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, - returnIOIdKey, newStablePtrIdKey, - printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, - fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique -unsafeCoerceIdKey = mkPreludeMiscIdUnique 30 -concatIdKey = mkPreludeMiscIdUnique 31 -filterIdKey = mkPreludeMiscIdUnique 32 -zipIdKey = mkPreludeMiscIdUnique 33 -bindIOIdKey = mkPreludeMiscIdUnique 34 -returnIOIdKey = mkPreludeMiscIdUnique 35 -newStablePtrIdKey = mkPreludeMiscIdUnique 36 -printIdKey = mkPreludeMiscIdUnique 37 -failIOIdKey = mkPreludeMiscIdUnique 38 -nullAddrIdKey = mkPreludeMiscIdUnique 39 -voidArgIdKey = mkPreludeMiscIdUnique 40 -fstIdKey = mkPreludeMiscIdUnique 41 -sndIdKey = mkPreludeMiscIdUnique 42 -otherwiseIdKey = mkPreludeMiscIdUnique 43 -assertIdKey = mkPreludeMiscIdUnique 44 - -mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, - integerToWordIdKey, integerToIntIdKey, - integerToWord64IdKey, integerToInt64IdKey, - word64ToIntegerIdKey, int64ToIntegerIdKey, - plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, - negateIntegerIdKey, - eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey, - leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey, - compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, - quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey, - floatFromIntegerIdKey, doubleFromIntegerIdKey, - encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, - decodeDoubleIntegerIdKey, - gcdIntegerIdKey, lcmIntegerIdKey, - andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, - shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique -mkIntegerIdKey = mkPreludeMiscIdUnique 60 -smallIntegerIdKey = mkPreludeMiscIdUnique 61 -integerToWordIdKey = mkPreludeMiscIdUnique 62 -integerToIntIdKey = mkPreludeMiscIdUnique 63 -integerToWord64IdKey = mkPreludeMiscIdUnique 64 -integerToInt64IdKey = mkPreludeMiscIdUnique 65 -plusIntegerIdKey = mkPreludeMiscIdUnique 66 -timesIntegerIdKey = mkPreludeMiscIdUnique 67 -minusIntegerIdKey = mkPreludeMiscIdUnique 68 -negateIntegerIdKey = mkPreludeMiscIdUnique 69 -eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70 -neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71 -absIntegerIdKey = mkPreludeMiscIdUnique 72 -signumIntegerIdKey = mkPreludeMiscIdUnique 73 -leIntegerPrimIdKey = mkPreludeMiscIdUnique 74 -gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75 -ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76 -geIntegerPrimIdKey = mkPreludeMiscIdUnique 77 -compareIntegerIdKey = mkPreludeMiscIdUnique 78 -quotIntegerIdKey = mkPreludeMiscIdUnique 79 -remIntegerIdKey = mkPreludeMiscIdUnique 80 -divIntegerIdKey = mkPreludeMiscIdUnique 81 -modIntegerIdKey = mkPreludeMiscIdUnique 82 -divModIntegerIdKey = mkPreludeMiscIdUnique 83 -quotRemIntegerIdKey = mkPreludeMiscIdUnique 84 -floatFromIntegerIdKey = mkPreludeMiscIdUnique 85 -doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86 -encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87 -encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88 -gcdIntegerIdKey = mkPreludeMiscIdUnique 89 -lcmIntegerIdKey = mkPreludeMiscIdUnique 90 -andIntegerIdKey = mkPreludeMiscIdUnique 91 -orIntegerIdKey = mkPreludeMiscIdUnique 92 -xorIntegerIdKey = mkPreludeMiscIdUnique 93 -complementIntegerIdKey = mkPreludeMiscIdUnique 94 -shiftLIntegerIdKey = mkPreludeMiscIdUnique 95 -shiftRIntegerIdKey = mkPreludeMiscIdUnique 96 -wordToIntegerIdKey = mkPreludeMiscIdUnique 97 -word64ToIntegerIdKey = mkPreludeMiscIdUnique 98 -int64ToIntegerIdKey = mkPreludeMiscIdUnique 99 -decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100 - -rootMainKey, runMainKey :: Unique -rootMainKey = mkPreludeMiscIdUnique 101 -runMainKey = mkPreludeMiscIdUnique 102 - -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique -thenIOIdKey = mkPreludeMiscIdUnique 103 -lazyIdKey = mkPreludeMiscIdUnique 104 -assertErrorIdKey = mkPreludeMiscIdUnique 105 -oneShotKey = mkPreludeMiscIdUnique 106 -runRWKey = mkPreludeMiscIdUnique 107 - -traceKey :: Unique -traceKey = mkPreludeMiscIdUnique 108 - -breakpointIdKey, breakpointCondIdKey :: Unique -breakpointIdKey = mkPreludeMiscIdUnique 110 -breakpointCondIdKey = mkPreludeMiscIdUnique 111 - -inlineIdKey, noinlineIdKey :: Unique -inlineIdKey = mkPreludeMiscIdUnique 120 --- see below - -mapIdKey, groupWithIdKey, dollarIdKey :: Unique -mapIdKey = mkPreludeMiscIdUnique 121 -groupWithIdKey = mkPreludeMiscIdUnique 122 -dollarIdKey = mkPreludeMiscIdUnique 123 - -coercionTokenIdKey :: Unique -coercionTokenIdKey = mkPreludeMiscIdUnique 124 - -noinlineIdKey = mkPreludeMiscIdUnique 125 - -rationalToFloatIdKey, rationalToDoubleIdKey :: Unique -rationalToFloatIdKey = mkPreludeMiscIdUnique 130 -rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 - --- dotnet interop -unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, - unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique -unmarshalObjectIdKey = mkPreludeMiscIdUnique 150 -marshalObjectIdKey = mkPreludeMiscIdUnique 151 -marshalStringIdKey = mkPreludeMiscIdUnique 152 -unmarshalStringIdKey = mkPreludeMiscIdUnique 153 -checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 - -undefinedKey :: Unique -undefinedKey = mkPreludeMiscIdUnique 155 - -magicDictKey :: Unique -magicDictKey = mkPreludeMiscIdUnique 156 - -coerceKey :: Unique -coerceKey = mkPreludeMiscIdUnique 157 - -{- -Certain class operations from Prelude classes. They get their own -uniques so we can look them up easily when we want to conjure them up -during type checking. --} - --- Just a placeholder for unbound variables produced by the renamer: -unboundKey :: Unique -unboundKey = mkPreludeMiscIdUnique 158 - -fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, - enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, - enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, - bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey - :: Unique -fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 -minusClassOpKey = mkPreludeMiscIdUnique 161 -fromRationalClassOpKey = mkPreludeMiscIdUnique 162 -enumFromClassOpKey = mkPreludeMiscIdUnique 163 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 -enumFromToClassOpKey = mkPreludeMiscIdUnique 165 -enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 -eqClassOpKey = mkPreludeMiscIdUnique 167 -geClassOpKey = mkPreludeMiscIdUnique 168 -negateClassOpKey = mkPreludeMiscIdUnique 169 -bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) -thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) -fmapClassOpKey = mkPreludeMiscIdUnique 173 -returnMClassOpKey = mkPreludeMiscIdUnique 174 - --- Recursive do notation -mfixIdKey :: Unique -mfixIdKey = mkPreludeMiscIdUnique 175 - --- MonadFail operations -failMClassOpKey :: Unique -failMClassOpKey = mkPreludeMiscIdUnique 176 - --- Arrow notation -arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, - loopAIdKey :: Unique -arrAIdKey = mkPreludeMiscIdUnique 180 -composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> -firstAIdKey = mkPreludeMiscIdUnique 182 -appAIdKey = mkPreludeMiscIdUnique 183 -choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| -loopAIdKey = mkPreludeMiscIdUnique 185 - -fromStringClassOpKey :: Unique -fromStringClassOpKey = mkPreludeMiscIdUnique 186 - --- Annotation type checking -toAnnotationWrapperIdKey :: Unique -toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 - --- Conversion functions -fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique -fromIntegralIdKey = mkPreludeMiscIdUnique 190 -realToFracIdKey = mkPreludeMiscIdUnique 191 -toIntegerClassOpKey = mkPreludeMiscIdUnique 192 -toRationalClassOpKey = mkPreludeMiscIdUnique 193 - --- Monad comprehensions -guardMIdKey, liftMIdKey, mzipIdKey :: Unique -guardMIdKey = mkPreludeMiscIdUnique 194 -liftMIdKey = mkPreludeMiscIdUnique 195 -mzipIdKey = mkPreludeMiscIdUnique 196 - --- GHCi -ghciStepIoMClassOpKey :: Unique -ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 - --- Overloaded lists -isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique -isListClassKey = mkPreludeMiscIdUnique 198 -fromListClassOpKey = mkPreludeMiscIdUnique 199 -fromListNClassOpKey = mkPreludeMiscIdUnique 500 -toListClassOpKey = mkPreludeMiscIdUnique 501 - -proxyHashKey :: Unique -proxyHashKey = mkPreludeMiscIdUnique 502 - ----------------- Template Haskell ------------------- --- THNames.hs: USES IdUniques 200-499 ------------------------------------------------------ - --- Used to make `Typeable` dictionaries -mkTyConKey - , mkTrTypeKey - , mkTrConKey - , mkTrAppKey - , mkTrFunKey - , typeNatTypeRepKey - , typeSymbolTypeRepKey - , typeRepIdKey - :: Unique -mkTyConKey = mkPreludeMiscIdUnique 503 -mkTrTypeKey = mkPreludeMiscIdUnique 504 -mkTrConKey = mkPreludeMiscIdUnique 505 -mkTrAppKey = mkPreludeMiscIdUnique 506 -typeNatTypeRepKey = mkPreludeMiscIdUnique 507 -typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 -typeRepIdKey = mkPreludeMiscIdUnique 509 -mkTrFunKey = mkPreludeMiscIdUnique 510 - --- Representations for primitive types -trTYPEKey - ,trTYPE'PtrRepLiftedKey - , trRuntimeRepKey - , tr'PtrRepLiftedKey - :: Unique -trTYPEKey = mkPreludeMiscIdUnique 511 -trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512 -trRuntimeRepKey = mkPreludeMiscIdUnique 513 -tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514 - --- KindReps for common cases -starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique -starKindRepKey = mkPreludeMiscIdUnique 520 -starArrStarKindRepKey = mkPreludeMiscIdUnique 521 -starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 - --- Dynamic -toDynIdKey :: Unique -toDynIdKey = mkPreludeMiscIdUnique 523 - - -bitIntegerIdKey :: Unique -bitIntegerIdKey = mkPreludeMiscIdUnique 550 - -heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique -eqSCSelIdKey = mkPreludeMiscIdUnique 551 -heqSCSelIdKey = mkPreludeMiscIdUnique 552 -coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 - -sappendClassOpKey :: Unique -sappendClassOpKey = mkPreludeMiscIdUnique 554 - -memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique -memptyClassOpKey = mkPreludeMiscIdUnique 555 -mappendClassOpKey = mkPreludeMiscIdUnique 556 -mconcatClassOpKey = mkPreludeMiscIdUnique 557 - -emptyCallStackKey, pushCallStackKey :: Unique -emptyCallStackKey = mkPreludeMiscIdUnique 558 -pushCallStackKey = mkPreludeMiscIdUnique 559 - -fromStaticPtrClassOpKey :: Unique -fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 - -makeStaticKey :: Unique -makeStaticKey = mkPreludeMiscIdUnique 561 - --- Natural -naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey, - minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey, - naturalSDataConKey, wordToNaturalIdKey :: Unique -naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562 -naturalToIntegerIdKey = mkPreludeMiscIdUnique 563 -plusNaturalIdKey = mkPreludeMiscIdUnique 564 -minusNaturalIdKey = mkPreludeMiscIdUnique 565 -timesNaturalIdKey = mkPreludeMiscIdUnique 566 -mkNaturalIdKey = mkPreludeMiscIdUnique 567 -naturalSDataConKey = mkPreludeMiscIdUnique 568 -wordToNaturalIdKey = mkPreludeMiscIdUnique 569 - -{- -************************************************************************ -* * -\subsection[Class-std-groups]{Standard groups of Prelude classes} -* * -************************************************************************ - -NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ -even though every numeric class has these two as a superclass, -because the list of ambiguous dictionaries hasn't been simplified. --} - -numericClassKeys :: [Unique] -numericClassKeys = - [ numClassKey - , realClassKey - , integralClassKey - ] - ++ fractionalClassKeys - -fractionalClassKeys :: [Unique] -fractionalClassKeys = - [ fractionalClassKey - , floatingClassKey - , realFracClassKey - , realFloatClassKey - ] - --- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), --- and are: "classes defined in the Prelude or a standard library" -standardClassKeys :: [Unique] -standardClassKeys = derivableClassKeys ++ numericClassKeys - ++ [randomClassKey, randomGenClassKey, - functorClassKey, - monadClassKey, monadPlusClassKey, monadFailClassKey, - semigroupClassKey, monoidClassKey, - isStringClassKey, - applicativeClassKey, foldableClassKey, - traversableClassKey, alternativeClassKey - ] - -{- -@derivableClassKeys@ is also used in checking \tr{deriving} constructs -(@TcDeriv@). --} - -derivableClassKeys :: [Unique] -derivableClassKeys - = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, - boundedClassKey, showClassKey, readClassKey ] - - --- These are the "interactive classes" that are consulted when doing --- defaulting. Does not include Num or IsString, which have special --- handling. -interactiveClassNames :: [Name] -interactiveClassNames - = [ showClassName, eqClassName, ordClassName, foldableClassName - , traversableClassName ] - -interactiveClassKeys :: [Unique] -interactiveClassKeys = map getUnique interactiveClassNames - -{- -************************************************************************ -* * - Semi-builtin names -* * -************************************************************************ - -The following names should be considered by GHCi to be in scope always. - --} - -pretendNameIsInScope :: Name -> Bool -pretendNameIsInScope n - = any (n `hasKey`) - [ liftedTypeKindTyConKey, tYPETyConKey - , runtimeRepTyConKey, liftedRepDataConKey ] diff --git a/prelude/PrelNames.hs-boot b/prelude/PrelNames.hs-boot deleted file mode 100644 --- a/prelude/PrelNames.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module PrelNames where - -import Module -import Unique - -mAIN :: Module -liftedTypeKindTyConKey :: Unique diff --git a/prelude/PrelRules.hs b/prelude/PrelRules.hs deleted file mode 100644 --- a/prelude/PrelRules.hs +++ /dev/null @@ -1,2200 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[ConFold]{Constant Folder} - -Conceptually, constant folding should be parameterized with the kind -of target machine to get identical behaviour during compilation time -and runtime. We cheat a little bit here... - -ToDo: - check boundaries before folding, e.g. we can fold the Float addition - (i1 + i2) only if it results in a valid Float. --} - -{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards, - DeriveFunctor #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} - -module PrelRules - ( primOpRules - , builtinRules - , caseRules - ) -where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) - -import CoreSyn -import MkCore -import Id -import Literal -import CoreOpt ( exprIsLiteral_maybe ) -import PrimOp ( PrimOp(..), tagToEnumKey ) -import TysWiredIn -import TysPrim -import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon - , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons - , tyConFamilySize ) -import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId ) -import CoreUtils ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType, stripTicksTop, stripTicksTopT, mkTicks ) -import CoreUnfold ( exprIsConApp_maybe ) -import Type -import OccName ( occNameFS ) -import PrelNames -import Maybes ( orElse ) -import Name ( Name, nameOccName ) -import Outputable -import FastString -import BasicTypes -import DynFlags -import GHC.Platform -import Util -import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) - -import Control.Applicative ( Alternative(..) ) - -import Control.Monad -import qualified Control.Monad.Fail as MonadFail -import Data.Bits as Bits -import qualified Data.ByteString as BS -import Data.Int -import Data.Ratio -import Data.Word - -{- -Note [Constant folding] -~~~~~~~~~~~~~~~~~~~~~~~ -primOpRules generates a rewrite rule for each primop -These rules do what is often called "constant folding" -E.g. the rules for +# might say - 4 +# 5 = 9 -Well, of course you'd need a lot of rules if you did it -like that, so we use a BuiltinRule instead, so that we -can match in any two literal values. So the rule is really -more like - (Lit x) +# (Lit y) = Lit (x+#y) -where the (+#) on the rhs is done at compile time - -That is why these rules are built in here. --} - -primOpRules :: Name -> PrimOp -> Maybe CoreRule - -- ToDo: something for integer-shift ops? - -- NotOp -primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ] -primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] - --- Int operations -primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) - , identityDynFlags zeroi - , numFoldingRules IntAddOp intPrimOps - ] -primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) - , rightIdentityDynFlags zeroi - , equalArgs >> retLit zeroi - , numFoldingRules IntSubOp intPrimOps - ] -primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) - , identityCDynFlags zeroi ] -primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) - , rightIdentityCDynFlags zeroi - , equalArgs >> retLitNoC zeroi ] -primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) - , zeroElem zeroi - , identityDynFlags onei - , numFoldingRules IntMulOp intPrimOps - ] -primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) - , leftZero zeroi - , rightIdentityDynFlags onei - , equalArgs >> retLit onei ] -primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) - , leftZero zeroi - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onei dflags) - retLit zeroi - , equalArgs >> retLit zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) - , idempotent - , zeroElem zeroi ] -primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) - , idempotent - , identityDynFlags zeroi ] -primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) - , identityDynFlags zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotIOp ] -primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp IntNegOp ] -primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical - , rightIdentityDynFlags zeroi ] - --- Word operations -primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) - , identityDynFlags zerow - , numFoldingRules WordAddOp wordPrimOps - ] -primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) - , rightIdentityDynFlags zerow - , equalArgs >> retLit zerow - , numFoldingRules WordSubOp wordPrimOps - ] -primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) - , identityCDynFlags zerow ] -primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) - , rightIdentityCDynFlags zerow - , equalArgs >> retLitNoC zerow ] -primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) - , identityDynFlags onew - , numFoldingRules WordMulOp wordPrimOps - ] -primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) - , rightIdentityDynFlags onew ] -primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) - , leftZero zerow - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onew dflags) - retLit zerow - , equalArgs >> retLit zerow ] -primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) - , idempotent - , zeroElem zerow ] -primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) - , idempotent - , identityDynFlags zerow ] -primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) - , identityDynFlags zerow - , equalArgs >> retLit zerow ] -primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotOp ] -primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] -primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] - --- coercions -primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit - , inversePrimOp Int2WordOp ] -primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit - , inversePrimOp Word2IntOp ] -primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit - , subsumedByPrimOp Narrow8IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ] -primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ] -primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , subsumedByPrimOp Narrow32IntOp - , removeOp32 ] -primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit - , subsumedByPrimOp Narrow8WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ] -primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ] -primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , subsumedByPrimOp Narrow32WordOp - , removeOp32 ] -primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit - , inversePrimOp ChrOp ] -primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs - guard (litFitsInChar lit) - liftLit int2CharLit - , inversePrimOp OrdOp ] -primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] -primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] -primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] -primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] --- SUP: Not sure what the standard says about precision in the following 2 cases -primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] -primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ] - --- Float -primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) - , identity zerof ] -primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) - , rightIdentity zerof ] -primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) - , identity onef - , strengthReduction twof FloatAddOp ] - -- zeroElem zerof doesn't hold because of NaN -primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) - , rightIdentity onef ] -primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp FloatNegOp ] - --- Double -primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) - , identity zerod ] -primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) - , rightIdentity zerod ] -primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) - , identity oned - , strengthReduction twod DoubleAddOp ] - -- zeroElem zerod doesn't hold because of NaN -primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) - , rightIdentity oned ] -primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp DoubleNegOp ] - --- Relational operators - -primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] -primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] -primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ] - -primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ] -primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ] - -primOpRules _ _ = Nothing - -{- -************************************************************************ -* * -\subsection{Doing the business} -* * -************************************************************************ --} - --- useful shorthands -mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) - -mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) - -> [RuleM CoreExpr] -> Maybe CoreRule -mkRelOpRule nm cmp extra - = mkPrimOpRule nm 2 $ - binaryCmpLit cmp : equal_rule : extra - where - -- x `cmp` x does not depend on x, so - -- compute it for the arbitrary value 'True' - -- and use that result - equal_rule = do { equalArgs - ; dflags <- getDynFlags - ; return (if cmp True True - then trueValInt dflags - else falseValInt dflags) } - -{- Note [Rules for floating-point comparisons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need different rules for floating-point values because for floats -it is not true that x = x (for NaNs); so we do not want the equal_rule -rule that mkRelOpRule uses. - -Note also that, in the case of equality/inequality, we do /not/ -want to switch to a case-expression. For example, we do not want -to convert - case (eqFloat# x 3.8#) of - True -> this - False -> that -to - case x of - 3.8#::Float# -> this - _ -> that -See #9238. Reason: comparing floating-point values for equality -delicate, and we don't want to implement that delicacy in the code for -case expressions. So we make it an invariant of Core that a case -expression never scrutinises a Float# or Double#. - -This transformation is what the litEq rule does; -see Note [The litEq rule: converting equality to case]. -So we /refrain/ from using litEq for mkFloatingRelOpRule. --} - -mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) - -> Maybe CoreRule --- See Note [Rules for floating-point comparisons] -mkFloatingRelOpRule nm cmp - = mkPrimOpRule nm 2 [binaryCmpLit cmp] - --- common constants -zeroi, onei, zerow, onew :: DynFlags -> Literal -zeroi dflags = mkLitInt dflags 0 -onei dflags = mkLitInt dflags 1 -zerow dflags = mkLitWord dflags 0 -onew dflags = mkLitWord dflags 1 - -zerof, onef, twof, zerod, oned, twod :: Literal -zerof = mkLitFloat 0.0 -onef = mkLitFloat 1.0 -twof = mkLitFloat 2.0 -zerod = mkLitDouble 0.0 -oned = mkLitDouble 1.0 -twod = mkLitDouble 2.0 - -cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) - -> Literal -> Literal -> Maybe CoreExpr -cmpOp dflags cmp = go - where - done True = Just $ trueValInt dflags - done False = Just $ falseValInt dflags - - -- These compares are at different types - go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) - go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) - go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) - go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _) - | nt1 /= nt2 = Nothing - | otherwise = done (i1 `cmp` i2) - go _ _ = Nothing - --------------------------- - -negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate -negOp _ (LitFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp dflags (LitFloat f) = Just (mkFloatVal dflags (-f)) -negOp _ (LitDouble 0.0) = Nothing -negOp dflags (LitDouble d) = Just (mkDoubleVal dflags (-d)) -negOp dflags (LitNumber nt i t) - | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t)) -negOp _ _ = Nothing - -complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement -complementOp dflags (LitNumber nt i t) = - Just (Lit (mkLitNumberWrap dflags nt (complement i) t)) -complementOp _ _ = Nothing - --------------------------- -intOp2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2 = intOp2' . const - -intOp2' :: (Integral a, Integral b) - => (DynFlags -> a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = - let o = op dflags - in intResult dflags (fromInteger i1 `o` fromInteger i2) -intOp2' _ _ _ _ = Nothing -- Could find LitLit - -intOpC2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do - intCResult dflags (fromInteger i1 `op` fromInteger i2) -intOpC2 _ _ _ _ = Nothing -- Could find LitLit - -shiftRightLogical :: DynFlags -> Integer -> Int -> Integer --- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do --- Do this by converting to Word and back. Obviously this won't work for big --- values, but its ok as we use it here -shiftRightLogical dflags x n = - case platformWordSize (targetPlatform dflags) of - PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32) - PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64) - --------------------------- -retLit :: (DynFlags -> Literal) -> RuleM CoreExpr -retLit l = do dflags <- getDynFlags - return $ Lit $ l dflags - -retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr -retLitNoC l = do dflags <- getDynFlags - let lit = l dflags - let ty = literalType lit - return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)] - -wordOp2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) - = wordResult dflags (fromInteger w1 `op` fromInteger w2) -wordOp2 _ _ _ _ = Nothing -- Could find LitLit - -wordOpC2 :: (Integral a, Integral b) - => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = - wordCResult dflags (fromInteger w1 `op` fromInteger w2) -wordOpC2 _ _ _ _ = Nothing -- Could find LitLit - -shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr --- Shifts take an Int; hence third arg of op is Int --- Used for shift primops --- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word# --- SllOp, SrlOp :: Word# -> Int# -> Word# -shiftRule shift_op - = do { dflags <- getDynFlags - ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs - ; case e1 of - _ | shift_len == 0 - -> return e1 - -- See Note [Guarding against silly shifts] - | shift_len < 0 || shift_len > wordSizeInBits dflags - -> return $ Lit $ mkLitNumberWrap dflags LitNumInt 0 (exprType e1) - - -- Do the shift at type Integer, but shift length is Int - Lit (LitNumber nt x t) - | 0 < shift_len - , shift_len <= wordSizeInBits dflags - -> let op = shift_op dflags - y = x `op` fromInteger shift_len - in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t)) - - _ -> mzero } - -wordSizeInBits :: DynFlags -> Integer -wordSizeInBits dflags = toInteger (platformWordSizeInBits (targetPlatform dflags)) - --------------------------- -floatOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal - -> Maybe (Expr CoreBndr) -floatOp2 op dflags (LitFloat f1) (LitFloat f2) - = Just (mkFloatVal dflags (f1 `op` f2)) -floatOp2 _ _ _ _ = Nothing - --------------------------- -doubleOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal - -> Maybe (Expr CoreBndr) -doubleOp2 op dflags (LitDouble f1) (LitDouble f2) - = Just (mkDoubleVal dflags (f1 `op` f2)) -doubleOp2 _ _ _ _ = Nothing - --------------------------- -{- Note [The litEq rule: converting equality to case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This stuff turns - n ==# 3# -into - case n of - 3# -> True - m -> False - -This is a Good Thing, because it allows case-of case things -to happen, and case-default absorption to happen. For -example: - - if (n ==# 3#) || (n ==# 4#) then e1 else e2 -will transform to - case n of - 3# -> e1 - 4# -> e1 - m -> e2 -(modulo the usual precautions to avoid duplicating e1) --} - -litEq :: Bool -- True <=> equality, False <=> inequality - -> RuleM CoreExpr -litEq is_eq = msum - [ do [Lit lit, expr] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr - , do [expr, Lit lit] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr ] - where - do_lit_eq dflags lit expr = do - guard (not (litIsLifted lit)) - return (mkWildCase expr (literalType lit) intPrimTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) - where - val_if_eq | is_eq = trueValInt dflags - | otherwise = falseValInt dflags - val_if_neq | is_eq = falseValInt dflags - | otherwise = trueValInt dflags - - --- | Check if there is comparison with minBound or maxBound, that is --- always true or false. For instance, an Int cannot be smaller than its --- minBound, so we can replace such comparison with False. -boundsCmp :: Comparison -> RuleM CoreExpr -boundsCmp op = do - dflags <- getDynFlags - [a, b] <- getArgs - liftMaybe $ mkRuleFn dflags op a b - -data Comparison = Gt | Ge | Lt | Le - -mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr -mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn _ _ _ _ = Nothing - -isMinBound :: DynFlags -> Literal -> Bool -isMinBound _ (LitChar c) = c == minBound -isMinBound dflags (LitNumber nt i _) = case nt of - LitNumInt -> i == tARGET_MIN_INT dflags - LitNumInt64 -> i == toInteger (minBound :: Int64) - LitNumWord -> i == 0 - LitNumWord64 -> i == 0 - LitNumNatural -> i == 0 - LitNumInteger -> False -isMinBound _ _ = False - -isMaxBound :: DynFlags -> Literal -> Bool -isMaxBound _ (LitChar c) = c == maxBound -isMaxBound dflags (LitNumber nt i _) = case nt of - LitNumInt -> i == tARGET_MAX_INT dflags - LitNumInt64 -> i == toInteger (maxBound :: Int64) - LitNumWord -> i == tARGET_MAX_WORD dflags - LitNumWord64 -> i == toInteger (maxBound :: Word64) - LitNumNatural -> False - LitNumInteger -> False -isMaxBound _ _ = False - --- | Create an Int literal expression while ensuring the given Integer is in the --- target Int range -intResult :: DynFlags -> Integer -> Maybe CoreExpr -intResult dflags result = Just (intResult' dflags result) - -intResult' :: DynFlags -> Integer -> CoreExpr -intResult' dflags result = Lit (mkLitIntWrap dflags result) - --- | Create an unboxed pair of an Int literal expression, ensuring the given --- Integer is in the target Int range and the corresponding overflow flag --- (@0#@/@1#@) if it wasn't. -intCResult :: DynFlags -> Integer -> Maybe CoreExpr -intCResult dflags result = Just (mkPair [Lit lit, Lit c]) - where - mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] - (lit, b) = mkLitIntWrapC dflags result - c = if b then onei dflags else zeroi dflags - --- | Create a Word literal expression while ensuring the given Integer is in the --- target Word range -wordResult :: DynFlags -> Integer -> Maybe CoreExpr -wordResult dflags result = Just (wordResult' dflags result) - -wordResult' :: DynFlags -> Integer -> CoreExpr -wordResult' dflags result = Lit (mkLitWordWrap dflags result) - --- | Create an unboxed pair of a Word literal expression, ensuring the given --- Integer is in the target Word range and the corresponding carry flag --- (@0#@/@1#@) if it wasn't. -wordCResult :: DynFlags -> Integer -> Maybe CoreExpr -wordCResult dflags result = Just (mkPair [Lit lit, Lit c]) - where - mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] - (lit, b) = mkLitWordWrapC dflags result - c = if b then onei dflags else zeroi dflags - -inversePrimOp :: PrimOp -> RuleM CoreExpr -inversePrimOp primop = do - [Var primop_id `App` e] <- getArgs - matchPrimOpId primop primop_id - return e - -subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr -this `subsumesPrimOp` that = do - [Var primop_id `App` e] <- getArgs - matchPrimOpId that primop_id - return (Var (mkPrimOpId this) `App` e) - -subsumedByPrimOp :: PrimOp -> RuleM CoreExpr -subsumedByPrimOp primop = do - [e@(Var primop_id `App` _)] <- getArgs - matchPrimOpId primop primop_id - return e - -idempotent :: RuleM CoreExpr -idempotent = do [e1, e2] <- getArgs - guard $ cheapEqExpr e1 e2 - return e1 - -{- -Note [Guarding against silly shifts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code: - - import Data.Bits( (.|.), shiftL ) - chunkToBitmap :: [Bool] -> Word32 - chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] - -This optimises to: -Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> - case w1_sCT of _ { - [] -> 0##; - : x_aAW xs_aAX -> - case x_aAW of _ { - GHC.Types.False -> - case w_sCS of wild2_Xh { - __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; - 9223372036854775807 -> 0## }; - GHC.Types.True -> - case GHC.Prim.>=# w_sCS 64 of _ { - GHC.Types.False -> - case w_sCS of wild3_Xh { - __DEFAULT -> - case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> - GHC.Prim.or# (GHC.Prim.narrow32Word# - (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) - ww_sCW - }; - 9223372036854775807 -> - GHC.Prim.narrow32Word# -!!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) - }; - GHC.Types.True -> - case w_sCS of wild3_Xh { - __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; - 9223372036854775807 -> 0## - } } } } - -Note the massive shift on line "!!!!". It can't happen, because we've checked -that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this! -Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we -can't constant fold it, but if it gets to the assember we get - Error: operand type mismatch for `shl' - -So the best thing to do is to rewrite the shift with a call to error, -when the second arg is large. However, in general we cannot do this; consider -this case - - let x = I# (uncheckedIShiftL# n 80) - in ... - -Here x contains an invalid shift and consequently we would like to rewrite it -as follows: - - let x = I# (error "invalid shift) - in ... - -This was originally done in the fix to #16449 but this breaks the let/app -invariant (see Note [CoreSyn let/app invariant] in CoreSyn) as noted in #16742. -For the reasons discussed in Note [Checking versus non-checking primops] (in -the PrimOp module) there is no safe way rewrite the argument of I# such that -it bottoms. - -Consequently we instead take advantage of the fact that large shifts are -undefined behavior (see associated documentation in primops.txt.pp) and -transform the invalid shift into an "obviously incorrect" value. - -There are two cases: - -- Shifting fixed-width things: the primops ISll, Sll, etc - These are handled by shiftRule. - - We are happy to shift by any amount up to wordSize but no more. - -- Shifting Integers: the function shiftLInteger, shiftRInteger - from the 'integer' library. These are handled by rule_shift_op, - and match_Integer_shift_op. - - Here we could in principle shift by any amount, but we arbitary - limit the shift to 4 bits; in particualr we do not want shift by a - huge amount, which can happen in code like that above. - -The two cases are more different in their code paths that is comfortable, -but that is only a historical accident. - - -************************************************************************ -* * -\subsection{Vaguely generic functions} -* * -************************************************************************ --} - -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule --- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope } - -newtype RuleM r = RuleM - { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r } - deriving (Functor) - -instance Applicative RuleM where - pure x = RuleM $ \_ _ _ -> Just x - (<*>) = ap - -instance Monad RuleM where - RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of - Nothing -> Nothing - Just r -> runRuleM (g r) dflags iu e -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - -instance MonadFail.MonadFail RuleM where - fail _ = mzero - -instance Alternative RuleM where - empty = RuleM $ \_ _ _ -> Nothing - RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args -> - f1 dflags iu args <|> f2 dflags iu args - -instance MonadPlus RuleM - -instance HasDynFlags RuleM where - getDynFlags = RuleM $ \dflags _ _ -> Just dflags - -liftMaybe :: Maybe a -> RuleM a -liftMaybe Nothing = mzero -liftMaybe (Just x) = return x - -liftLit :: (Literal -> Literal) -> RuleM CoreExpr -liftLit f = liftLitDynFlags (const f) - -liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr -liftLitDynFlags f = do - dflags <- getDynFlags - [Lit lit] <- getArgs - return $ Lit (f dflags lit) - -removeOp32 :: RuleM CoreExpr -removeOp32 = do - dflags <- getDynFlags - case platformWordSize (targetPlatform dflags) of - PW4 -> do - [e] <- getArgs - return e - PW8 -> - mzero - -getArgs :: RuleM [CoreExpr] -getArgs = RuleM $ \_ _ args -> Just args - -getInScopeEnv :: RuleM InScopeEnv -getInScopeEnv = RuleM $ \_ iu _ -> Just iu - --- return the n-th argument of this rule, if it is a literal --- argument indices start from 0 -getLiteral :: Int -> RuleM Literal -getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of - (Lit l:_) -> Just l - _ -> Nothing - -unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr -unaryLit op = do - dflags <- getDynFlags - [Lit l] <- getArgs - liftMaybe $ op dflags (convFloating dflags l) - -binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr -binaryLit op = do - dflags <- getDynFlags - [Lit l1, Lit l2] <- getArgs - liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) - -binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr -binaryCmpLit op = do - dflags <- getDynFlags - binaryLit (\_ -> cmpOp dflags op) - -leftIdentity :: Literal -> RuleM CoreExpr -leftIdentity id_lit = leftIdentityDynFlags (const id_lit) - -rightIdentity :: Literal -> RuleM CoreExpr -rightIdentity id_lit = rightIdentityDynFlags (const id_lit) - -identity :: Literal -> RuleM CoreExpr -identity lit = leftIdentity lit `mplus` rightIdentity lit - -leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -leftIdentityDynFlags id_lit = do - dflags <- getDynFlags - [Lit l1, e2] <- getArgs - guard $ l1 == id_lit dflags - return e2 - --- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in --- addition to the result, we have to indicate that no carry/overflow occured. -leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -leftIdentityCDynFlags id_lit = do - dflags <- getDynFlags - [Lit l1, e2] <- getArgs - guard $ l1 == id_lit dflags - let no_c = Lit (zeroi dflags) - return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) - -rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -rightIdentityDynFlags id_lit = do - dflags <- getDynFlags - [e1, Lit l2] <- getArgs - guard $ l2 == id_lit dflags - return e1 - --- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in --- addition to the result, we have to indicate that no carry/overflow occured. -rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -rightIdentityCDynFlags id_lit = do - dflags <- getDynFlags - [e1, Lit l2] <- getArgs - guard $ l2 == id_lit dflags - let no_c = Lit (zeroi dflags) - return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) - -identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -identityDynFlags lit = - leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit - --- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition --- to the result, we have to indicate that no carry/overflow occured. -identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -identityCDynFlags lit = - leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit - -leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr -leftZero zero = do - dflags <- getDynFlags - [Lit l1, _] <- getArgs - guard $ l1 == zero dflags - return $ Lit l1 - -rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr -rightZero zero = do - dflags <- getDynFlags - [_, Lit l2] <- getArgs - guard $ l2 == zero dflags - return $ Lit l2 - -zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr -zeroElem lit = leftZero lit `mplus` rightZero lit - -equalArgs :: RuleM () -equalArgs = do - [e1, e2] <- getArgs - guard $ e1 `cheapEqExpr` e2 - -nonZeroLit :: Int -> RuleM () -nonZeroLit n = getLiteral n >>= guard . not . isZeroLit - --- When excess precision is not requested, cut down the precision of the --- Rational value to that of Float/Double. We confuse host architecture --- and target architecture here, but it's convenient (and wrong :-). -convFloating :: DynFlags -> Literal -> Literal -convFloating dflags (LitFloat f) | not (gopt Opt_ExcessPrecision dflags) = - LitFloat (toRational (fromRational f :: Float )) -convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) = - LitDouble (toRational (fromRational d :: Double)) -convFloating _ l = l - -guardFloatDiv :: RuleM () -guardFloatDiv = do - [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs - guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] - && f2 /= 0 -- avoid NaN and Infinity/-Infinity - -guardDoubleDiv :: RuleM () -guardDoubleDiv = do - [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs - guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] - && d2 /= 0 -- avoid NaN and Infinity/-Infinity --- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to --- zero, but we might want to preserve the negative zero here which --- is representable in Float/Double but not in (normalised) --- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? - -strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr -strengthReduction two_lit add_op = do -- Note [Strength reduction] - arg <- msum [ do [arg, Lit mult_lit] <- getArgs - guard (mult_lit == two_lit) - return arg - , do [Lit mult_lit, arg] <- getArgs - guard (mult_lit == two_lit) - return arg ] - return $ Var (mkPrimOpId add_op) `App` arg `App` arg - --- Note [Strength reduction] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This rule turns floating point multiplications of the form 2.0 * x and --- x * 2.0 into x + x addition, because addition costs less than multiplication. --- See #7116 - --- Note [What's true and false] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- trueValInt and falseValInt represent true and false values returned by --- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. --- True is represented as an unboxed 1# literal, while false is represented --- as 0# literal. --- We still need Bool data constructors (True and False) to use in a rule --- for constant folding of equal Strings - -trueValInt, falseValInt :: DynFlags -> Expr CoreBndr -trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] -falseValInt dflags = Lit $ zeroi dflags - -trueValBool, falseValBool :: Expr CoreBndr -trueValBool = Var trueDataConId -- see Note [What's true and false] -falseValBool = Var falseDataConId - -ltVal, eqVal, gtVal :: Expr CoreBndr -ltVal = Var ordLTDataConId -eqVal = Var ordEQDataConId -gtVal = Var ordGTDataConId - -mkIntVal :: DynFlags -> Integer -> Expr CoreBndr -mkIntVal dflags i = Lit (mkLitInt dflags i) -mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr -mkFloatVal dflags f = Lit (convFloating dflags (LitFloat f)) -mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr -mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d)) - -matchPrimOpId :: PrimOp -> Id -> RuleM () -matchPrimOpId op id = do - op' <- liftMaybe $ isPrimOpId_maybe id - guard $ op == op' - -{- -************************************************************************ -* * -\subsection{Special rules for seq, tagToEnum, dataToTag} -* * -************************************************************************ - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude but it works. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -We used to make this check in the type inference engine, but it's quite -ugly to do so, because the delayed constraint solving means that we don't -really know what's going on until the end. It's very much a corner case -because we don't expect the user to call tagToEnum# at all; we merely -generate calls in derived instances of Enum. So we compromise: a -rewrite rule rewrites a bad instance of tagToEnum# to an error call, -and emits a warning. --} - -tagToEnumRule :: RuleM CoreExpr --- If data T a = A | B | C --- then tag2Enum# (T ty) 2# --> B ty -tagToEnumRule = do - [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs - case splitTyConApp_maybe ty of - Just (tycon, tc_args) | isEnumerationTyCon tycon -> do - let tag = fromInteger i - correct_tag dc = (dataConTagZ dc) == tag - (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) - ASSERT(null rest) return () - return $ mkTyApps (Var (dataConWorkId dc)) tc_args - - -- See Note [tagToEnum#] - _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) - return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" - ------------------------------- -dataToTagRule :: RuleM CoreExpr --- See Note [dataToTag#] in primops.txt.pp -dataToTagRule = a `mplus` b - where - -- dataToTag (tagToEnum x) ==> x - a = do - [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs - guard $ tag_to_enum `hasKey` tagToEnumKey - guard $ ty1 `eqType` ty2 - return tag - - -- dataToTag (K e1 e2) ==> tag-of K - -- This also works (via exprIsConApp_maybe) for - -- dataToTag x - -- where x's unfolding is a constructor application - b = do - dflags <- getDynFlags - [_, val_arg] <- getArgs - in_scope <- getInScopeEnv - (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg - ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () - return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) - -{- Note [dataToTag# magic] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The primop dataToTag# is unusual because it evaluates its argument. -Only `SeqOp` shares that property. (Other primops do not do anything -as fancy as argument evaluation.) The special handling for dataToTag# -is: - -* CoreUtils.exprOkForSpeculation has a special case for DataToTagOp, - (actually in app_ok). Most primops with lifted arguments do not - evaluate those arguments, but DataToTagOp and SeqOp are two - exceptions. We say that they are /never/ ok-for-speculation, - regardless of the evaluated-ness of their argument. - See CoreUtils Note [exprOkForSpeculation and SeqOp/DataToTagOp] - -* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr, - that evaluates its argument and then extracts the tag from - the returned value. - -* An application like (dataToTag# (Just x)) is optimised by - dataToTagRule in PrelRules. - -* A case expression like - case (dataToTag# e) of - gets transformed t - case e of - by PrelRules.caseRules; see Note [caseRules for dataToTag] - -See #15696 for a long saga. - - -************************************************************************ -* * -\subsection{Rules for seq# and spark#} -* * -************************************************************************ --} - -{- Note [seq# magic] -~~~~~~~~~~~~~~~~~~~~ -The primop - seq# :: forall a s . a -> State# s -> (# State# s, a #) - -is /not/ the same as the Prelude function seq :: a -> b -> b -as you can see from its type. In fact, seq# is the implementation -mechanism for 'evaluate' - - evaluate :: a -> IO a - evaluate a = IO $ \s -> seq# a s - -The semantics of seq# is - * evaluate its first argument - * and return it - -Things to note - -* Why do we need a primop at all? That is, instead of - case seq# x s of (# x, s #) -> blah - why not instead say this? - case x of { DEFAULT -> blah) - - Reason (see #5129): if we saw - catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler - - then we'd drop the 'case x' because the body of the case is bottom - anyway. But we don't want to do that; the whole /point/ of - seq#/evaluate is to evaluate 'x' first in the IO monad. - - In short, we /always/ evaluate the first argument and never - just discard it. - -* Why return the value? So that we can control sharing of seq'd - values: in - let x = e in x `seq` ... x ... - We don't want to inline x, so better to represent it as - let x = e in case seq# x RW of (# _, x' #) -> ... x' ... - also it matches the type of rseq in the Eval monad. - -Implementing seq#. The compiler has magic for SeqOp in - -- PrelRules.seqRule: eliminate (seq# s) - -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - -- CoreUtils.exprOkForSpeculation; - see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in CoreUtils - -- Simplify.addEvals records evaluated-ness for the result; see - Note [Adding evaluatedness info to pattern-bound variables] - in Simplify --} - -seqRule :: RuleM CoreExpr -seqRule = do - [Type ty_a, Type _ty_s, a, s] <- getArgs - guard $ exprIsHNF a - return $ mkCoreUbxTup [exprType s, ty_a] [s, a] - --- spark# :: forall a s . a -> State# s -> (# State# s, a #) -sparkRule :: RuleM CoreExpr -sparkRule = seqRule -- reduce on HNF, just the same - -- XXX perhaps we shouldn't do this, because a spark eliminated by - -- this rule won't be counted as a dud at runtime? - -{- -************************************************************************ -* * -\subsection{Built in rules} -* * -************************************************************************ - -Note [Scoping for Builtin rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When compiling a (base-package) module that defines one of the -functions mentioned in the RHS of a built-in rule, there's a danger -that we'll see - - f = ...(eq String x).... - - ....and lower down... - - eqString = ... - -Then a rewrite would give - - f = ...(eqString x)... - ....and lower down... - eqString = ... - -and lo, eqString is not in scope. This only really matters when we get to code -generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole -set of bindings, which sorts out the dependency. Without -O we don't do any rule -rewriting so again we are fine. - -(This whole thing doesn't show up for non-built-in rules because their dependencies -are explicit.) --} - -builtinRules :: [CoreRule] --- Rules for non-primops that can't be expressed using a RULE pragma -builtinRules - = [BuiltinRule { ru_name = fsLit "AppendLitString", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_append_lit }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, - ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }, - mkBasicRule divIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 div) - , leftZero zeroi - , do - [arg, Lit (LitNumber LitNumInt d _)] <- getArgs - Just n <- return $ exactLog2 d - dflags <- getDynFlags - return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n - ], - mkBasicRule modIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 mod) - , leftZero zeroi - , do - [arg, Lit (LitNumber LitNumInt d _)] <- getArgs - Just _ <- return $ exactLog2 d - dflags <- getDynFlags - return $ Var (mkPrimOpId AndIOp) - `App` arg `App` mkIntVal dflags (d - 1) - ] - ] - ++ builtinIntegerRules - ++ builtinNaturalRules -{-# NOINLINE builtinRules #-} --- there is no benefit to inlining these yet, despite this, GHC produces --- unfoldings for this regardless since the floated list entries look small. - -builtinIntegerRules :: [CoreRule] -builtinIntegerRules = - [rule_IntToInteger "smallInteger" smallIntegerName, - rule_WordToInteger "wordToInteger" wordToIntegerName, - rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, - rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, - rule_convert "integerToWord" integerToWordName mkWordLitWord, - rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), - rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), - rule_binop "plusInteger" plusIntegerName (+), - rule_binop "minusInteger" minusIntegerName (-), - rule_binop "timesInteger" timesIntegerName (*), - rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), - rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), - rule_unop "absInteger" absIntegerName abs, - rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Prim "leInteger#" leIntegerPrimName (<=), - rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), - rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), - rule_binop_Prim "geInteger#" geIntegerPrimName (>=), - rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, - rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), - rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, - rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, - rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), - rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, - rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, - rule_binop "gcdInteger" gcdIntegerName gcd, - rule_binop "lcmInteger" lcmIntegerName lcm, - rule_binop "andInteger" andIntegerName (.&.), - rule_binop "orInteger" orIntegerName (.|.), - rule_binop "xorInteger" xorIntegerName xor, - rule_unop "complementInteger" complementIntegerName complement, - rule_shift_op "shiftLInteger" shiftLIntegerName shiftL, - rule_shift_op "shiftRInteger" shiftRIntegerName shiftR, - rule_bitInteger "bitInteger" bitIntegerName, - -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs - rule_divop_one "quotInteger" quotIntegerName quot, - rule_divop_one "remInteger" remIntegerName rem, - rule_divop_one "divInteger" divIntegerName div, - rule_divop_one "modInteger" modIntegerName mod, - rule_divop_both "divModInteger" divModIntegerName divMod, - rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, - -- These rules below don't actually have to be built in, but if we - -- put them in the Haskell source then we'd have to duplicate them - -- between all Integer implementations - rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, - rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, - rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, - rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, - rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, - rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, - rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp - ] - where rule_convert str name convert - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_convert convert } - rule_IntToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntToInteger } - rule_WordToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_WordToInteger } - rule_Int64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Int64ToInteger } - rule_Word64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Word64ToInteger } - rule_unop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_unop op } - rule_bitInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_bitInteger } - rule_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop op } - rule_divop_both str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_both op } - rule_divop_one str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_one op } - rule_shift_op str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_shift_op op } - rule_binop_Prim str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Prim op } - rule_binop_Ordering str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Ordering op } - rule_encodeFloat str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_Int_encodeFloat op } - rule_decodeDouble str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_decodeDouble } - rule_XToIntegerToX str name toIntegerName - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_XToIntegerToX toIntegerName } - rule_smallIntegerTo str name primOp - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_smallIntegerTo primOp } - rule_rationalTo str name mkLit - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_rationalTo mkLit } - -builtinNaturalRules :: [CoreRule] -builtinNaturalRules = - [rule_binop "plusNatural" plusNaturalName (+) - ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing) - ,rule_binop "timesNatural" timesNaturalName (*) - ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName - ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName - ,rule_WordToNatural "wordToNatural" wordToNaturalName - ] - where rule_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Natural_binop op } - rule_partial_binop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Natural_partial_binop op } - rule_NaturalToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_NaturalToInteger } - rule_NaturalFromInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_NaturalFromInteger } - rule_WordToNatural str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_WordToNatural } - ---------------------------------------------------- --- The rule is this: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) --- = unpackFoldrCString# "foobaz" c n - -match_append_lit :: RuleFun -match_append_lit _ id_unf _ - [ Type ty1 - , lit1 - , c1 - , e2 - ] - -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the - -- `lit` and `c` arguments, lest this may fail to fire when building with - -- -g3. See #16740. - | (strTicks, Var unpk `App` Type ty2 - `App` lit2 - `App` c2 - `App` n) <- stripTicksTop tickishFloatable e2 - , unpk `hasKey` unpackCStringFoldrIdKey - , cheapEqExpr' tickishFloatable c1 c2 - , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 - , c2Ticks <- stripTicksTopT tickishFloatable c2 - , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 - = ASSERT( ty1 `eqType` ty2 ) - Just $ mkTicks strTicks - $ Var unpk `App` Type ty1 - `App` Lit (LitString (s1 `BS.append` s2)) - `App` mkTicks (c1Ticks ++ c2Ticks) c1' - `App` n - -match_append_lit _ _ _ _ = Nothing - ---------------------------------------------------- --- The rule is this: --- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 - -match_eq_string :: RuleFun -match_eq_string _ id_unf _ - [Var unpk1 `App` lit1, Var unpk2 `App` lit2] - | unpk1 `hasKey` unpackCStringIdKey - , unpk2 `hasKey` unpackCStringIdKey - , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 - = Just (if s1 == s2 then trueValBool else falseValBool) - -match_eq_string _ _ _ _ = Nothing - - ---------------------------------------------------- --- The rule is this: --- inline f_ty (f a b c) = a b c --- (if f has an unfolding, EVEN if it's a loop breaker) --- --- It's important to allow the argument to 'inline' to have args itself --- (a) because its more forgiving to allow the programmer to write --- inline f a b c --- or inline (f a b c) --- (b) because a polymorphic f wll get a type argument that the --- programmer can't avoid --- --- Also, don't forget about 'inline's type argument! -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) - | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! - = Just (mkApps unf args1) - -match_inline _ = Nothing - - --- See Note [magicDictId magic] in `basicTypes/MkId.hs` --- for a description of what is going on here. -match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] - | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap - , Just (dictTy, _) <- splitFunTy_maybe fieldTy - , Just dictTc <- tyConAppTyCon_maybe dictTy - , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc - = Just - $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) - `App` y - -match_magicDict _ = Nothing - -------------------------------------------------- --- Integer rules --- smallInteger (79::Int#) = 79::Integer --- wordToInteger (79::Word#) = 79::Integer --- Similarly Int64, Word64 - -match_IntToInteger :: RuleFun -match_IntToInteger = match_IntToInteger_unop id - -match_WordToInteger :: RuleFun -match_WordToInteger _ id_unf id [xl] - | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_WordToInteger: Id has the wrong type" -match_WordToInteger _ _ _ _ = Nothing - -match_Int64ToInteger :: RuleFun -match_Int64ToInteger _ id_unf id [xl] - | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_Int64ToInteger: Id has the wrong type" -match_Int64ToInteger _ _ _ _ = Nothing - -match_Word64ToInteger :: RuleFun -match_Word64ToInteger _ id_unf id [xl] - | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_Word64ToInteger: Id has the wrong type" -match_Word64ToInteger _ _ _ _ = Nothing - -match_NaturalToInteger :: RuleFun -match_NaturalToInteger _ id_unf id [xl] - | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> - Just (Lit (LitNumber LitNumInteger x naturalTy)) - _ -> - panic "match_NaturalToInteger: Id has the wrong type" -match_NaturalToInteger _ _ _ _ = Nothing - -match_NaturalFromInteger :: RuleFun -match_NaturalFromInteger _ id_unf id [xl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , x >= 0 - = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> - Just (Lit (LitNumber LitNumNatural x naturalTy)) - _ -> - panic "match_NaturalFromInteger: Id has the wrong type" -match_NaturalFromInteger _ _ _ _ = Nothing - -match_WordToNatural :: RuleFun -match_WordToNatural _ id_unf id [xl] - | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> - Just (Lit (LitNumber LitNumNatural x naturalTy)) - _ -> - panic "match_WordToNatural: Id has the wrong type" -match_WordToNatural _ _ _ _ = Nothing - -------------------------------------------------- -{- Note [Rewriting bitInteger] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For most types the bitInteger operation can be implemented in terms of shifts. -The integer-gmp package, however, can do substantially better than this if -allowed to provide its own implementation. However, in so doing it previously lost -constant-folding (see #8832). The bitInteger rule above provides constant folding -specifically for this function. - -There is, however, a bit of trickiness here when it comes to ranges. While the -AST encodes all integers as Integers, `bit` expects the bit -index to be given as an Int. Hence we coerce to an Int in the rule definition. -This will behave a bit funny for constants larger than the word size, but the user -should expect some funniness given that they will have at very least ignored a -warning in this case. --} - -match_bitInteger :: RuleFun --- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer -match_bitInteger dflags id_unf fn [arg] - | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg - , x >= 0 - , x <= (wordSizeInBits dflags - 1) - -- Make sure x is small enough to yield a decently small iteger - -- Attempting to construct the Integer for - -- (bitInteger 9223372036854775807#) - -- would be a bad idea (#14959) - , let x_int = fromIntegral x :: Int - = case splitFunTy_maybe (idType fn) of - Just (_, integerTy) - -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy)) - _ -> panic "match_IntToInteger_unop: Id has the wrong type" - -match_bitInteger _ _ _ _ = Nothing - - -------------------------------------------------- -match_Integer_convert :: Num a - => (DynFlags -> a -> Expr CoreBndr) - -> RuleFun -match_Integer_convert convert dflags id_unf _ [xl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert dflags (fromInteger x)) -match_Integer_convert _ _ _ _ _ = Nothing - -match_Integer_unop :: (Integer -> Integer) -> RuleFun -match_Integer_unop unop _ id_unf _ [xl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (LitNumber LitNumInteger (unop x) i)) -match_Integer_unop _ _ _ _ _ = Nothing - -match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun -match_IntToInteger_unop unop _ id_unf fn [xl] - | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType fn) of - Just (_, integerTy) -> - Just (Lit (LitNumber LitNumInteger (unop x) integerTy)) - _ -> - panic "match_IntToInteger_unop: Id has the wrong type" -match_IntToInteger_unop _ _ _ _ _ = Nothing - -match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitInteger (x `binop` y) i)) -match_Integer_binop _ _ _ _ _ = Nothing - -match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun -match_Natural_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitNatural (x `binop` y) i)) -match_Natural_binop _ _ _ _ _ = Nothing - -match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun -match_Natural_partial_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl - , Just z <- x `binop` y - = Just (Lit (mkLitNatural z i)) -match_Natural_partial_binop _ _ _ _ _ = Nothing - --- This helper is used for the quotRem and divMod functions -match_Integer_divop_both - :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun -match_Integer_divop_both divop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - , (r,s) <- x `divop` y - = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)] -match_Integer_divop_both _ _ _ _ _ = Nothing - --- This helper is used for the quot and rem functions -match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_divop_one divop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (Lit (mkLitInteger (x `divop` y) i)) -match_Integer_divop_one _ _ _ _ _ = Nothing - -match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun --- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer --- See Note [Guarding against silly shifts] -match_Integer_shift_op binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl - , y >= 0 - , y <= 4 -- Restrict constant-folding of shifts on Integers, somewhat - -- arbitrary. We can get huge shifts in inaccessible code - -- (#15673) - = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i)) -match_Integer_shift_op _ _ _ _ _ = Nothing - -match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun -match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) -match_Integer_binop_Prim _ _ _ _ _ = Nothing - -match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun -match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just $ case x `binop` y of - LT -> ltVal - EQ -> eqVal - GT -> gtVal -match_Integer_binop_Ordering _ _ _ _ _ = Nothing - -match_Integer_Int_encodeFloat :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl - = Just (mkLit $ encodeFloat x (fromInteger y)) -match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing - ---------------------------------------------------- --- constant folding for Float/Double --- --- This turns --- rationalToFloat n d --- into a literal Float, and similarly for Doubles. --- --- it's important to not match d == 0, because that may represent a --- literal "0/0" or similar, and we can't produce a literal value for --- NaN or +-Inf -match_rationalTo :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_rationalTo mkLit _ id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (mkLit (fromRational (x % y))) -match_rationalTo _ _ _ _ _ = Nothing - -match_decodeDouble :: RuleFun -match_decodeDouble dflags id_unf fn [xl] - | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType fn) of - Just (_, res) - | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res - -> case decodeFloat (fromRational x :: Double) of - (y, z) -> - Just $ mkCoreUbxTup [integerTy, intHashTy] - [Lit (mkLitInteger y integerTy), - Lit (mkLitInt dflags (toInteger z))] - _ -> - pprPanic "match_decodeDouble: Id has the wrong type" - (ppr fn <+> dcolon <+> ppr (idType fn)) -match_decodeDouble _ _ _ _ = Nothing - -match_XToIntegerToX :: Name -> RuleFun -match_XToIntegerToX n _ _ _ [App (Var x) y] - | idName x == n - = Just y -match_XToIntegerToX _ _ _ _ _ = Nothing - -match_smallIntegerTo :: PrimOp -> RuleFun -match_smallIntegerTo primOp _ _ _ [App (Var x) y] - | idName x == smallIntegerName - = Just $ App (Var (mkPrimOpId primOp)) y -match_smallIntegerTo _ _ _ _ _ = Nothing - - - --------------------------------------------------------- --- Note [Constant folding through nested expressions] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We use rewrites rules to perform constant folding. It means that we don't --- have a global view of the expression we are trying to optimise. As a --- consequence we only perform local (small-step) transformations that either: --- 1) reduce the number of operations --- 2) rearrange the expression to increase the odds that other rules will --- match --- --- We don't try to handle more complex expression optimisation cases that would --- require a global view. For example, rewriting expressions to increase --- sharing (e.g., Horner's method); optimisations that require local --- transformations increasing the number of operations; rearrangements to --- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). --- --- We already have rules to perform constant folding on expressions with the --- following shape (where a and/or b are literals): --- --- D) op --- /\ --- / \ --- / \ --- a b --- --- To support nested expressions, we match three other shapes of expression --- trees: --- --- A) op1 B) op1 C) op1 --- /\ /\ /\ --- / \ / \ / \ --- / \ / \ / \ --- a op2 op2 c op2 op3 --- /\ /\ /\ /\ --- / \ / \ / \ / \ --- b c a b a b c d --- --- --- R1) +/- simplification: --- ops = + or -, two literals (not siblings) --- --- Examples: --- A: 5 + (10-x) ==> 15-x --- B: (10+x) + 5 ==> 15+x --- C: (5+a)-(5-b) ==> 0+(a+b) --- --- R2) * simplification --- ops = *, two literals (not siblings) --- --- Examples: --- A: 5 * (10*x) ==> 50*x --- B: (10*x) * 5 ==> 50*x --- C: (5*a)*(5*b) ==> 25*(a*b) --- --- R3) * distribution over +/- --- op1 = *, op2 = + or -, two literals (not siblings) --- --- This transformation doesn't reduce the number of operations but switches --- the outer and the inner operations so that the outer is (+) or (-) instead --- of (*). It increases the odds that other rules will match after this one. --- --- Examples: --- A: 5 * (10-x) ==> 50 - (5*x) --- B: (10+x) * 5 ==> 50 + (5*x) --- C: Not supported as it would increase the number of operations: --- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b --- --- R4) Simple factorization --- --- op1 = + or -, op2/op3 = *, --- one literal for each innermost * operation (except in the D case), --- the two other terms are equals --- --- Examples: --- A: x - (10*x) ==> (-9)*x --- B: (10*x) + x ==> 11*x --- C: (5*x)-(x*3) ==> 2*x --- D: x+x ==> 2*x --- --- R5) +/- propagation --- --- ops = + or -, one literal --- --- This transformation doesn't reduce the number of operations but propagates --- the constant to the outer level. It increases the odds that other rules --- will match after this one. --- --- Examples: --- A: x - (10-y) ==> (x+y) - 10 --- B: (10+x) - y ==> 10 + (x-y) --- C: N/A (caught by the A and B cases) --- --------------------------------------------------------- - --- | Rules to perform constant folding into nested expressions --- ---See Note [Constant folding through nested expressions] -numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr -numFoldingRules op dict = do - [e1,e2] <- getArgs - dflags <- getDynFlags - let PrimOps{..} = dict dflags - if not (gopt Opt_NumConstantFolding dflags) - then mzero - else case BinOpApp e1 op e2 of - -- R1) +/- simplification - x :++: (y :++: v) -> return $ mkL (x+y) `add` v - x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v - x :++: (v :-: L y) -> return $ mkL (x-y) `add` v - L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v - L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v - L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v - - (y :++: v) :-: L x -> return $ mkL (y-x) `add` v - (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v - (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v - - (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v) - (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v) - (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v) - (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v) - (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w) - (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v) - (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w) - (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v) - (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w) - - (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w) - (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w) - (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w) - (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v) - (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v) - (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v) - (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w) - (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w) - (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w) - - -- R2) * simplification - x :**: (y :**: v) -> return $ mkL (x*y) `mul` v - (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) - - -- R3) * distribution over +/- - x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v) - x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v) - x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y) - - -- R4) Simple factorization - v :+: w - | w `cheapEqExpr` v -> return $ mkL 2 `mul` v - w :+: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v - w :-: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v - (y :**: v) :+: w - | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v - (y :**: v) :-: w - | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v - (x :**: w) :+: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v - (x :**: w) :-: (y :**: v) - | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v - - -- R5) +/- propagation - w :+: (y :++: v) -> return $ mkL y `add` (w `add` v) - (y :++: v) :+: w -> return $ mkL y `add` (w `add` v) - w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y - (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w) - w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y - (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v) - w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v) - w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y - (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v) - (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y - - _ -> mzero - - - --- | Match the application of a binary primop -pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr -pattern BinOpApp x op y = OpVal op `App` x `App` y - --- | Match a primop -pattern OpVal :: PrimOp -> Arg CoreBndr -pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where - OpVal op = Var (mkPrimOpId op) - - - --- | Match a literal -pattern L :: Integer -> Arg CoreBndr -pattern L l <- Lit (isLitValue_maybe -> Just l) - --- | Match an addition -pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr -pattern x :+: y <- BinOpApp x (isAddOp -> True) y - --- | Match an addition with a literal (handle commutativity) -pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr -pattern l :++: x <- (isAdd -> Just (l,x)) - -isAdd :: CoreExpr -> Maybe (Integer,CoreExpr) -isAdd e = case e of - L l :+: x -> Just (l,x) - x :+: L l -> Just (l,x) - _ -> Nothing - --- | Match a multiplication -pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr -pattern x :*: y <- BinOpApp x (isMulOp -> True) y - --- | Match a multiplication with a literal (handle commutativity) -pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr -pattern l :**: x <- (isMul -> Just (l,x)) - -isMul :: CoreExpr -> Maybe (Integer,CoreExpr) -isMul e = case e of - L l :*: x -> Just (l,x) - x :*: L l -> Just (l,x) - _ -> Nothing - - --- | Match a subtraction -pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr -pattern x :-: y <- BinOpApp x (isSubOp -> True) y - -isSubOp :: PrimOp -> Bool -isSubOp IntSubOp = True -isSubOp WordSubOp = True -isSubOp _ = False - -isAddOp :: PrimOp -> Bool -isAddOp IntAddOp = True -isAddOp WordAddOp = True -isAddOp _ = False - -isMulOp :: PrimOp -> Bool -isMulOp IntMulOp = True -isMulOp WordMulOp = True -isMulOp _ = False - --- | Explicit "type-class"-like dictionary for numeric primops --- --- Depends on DynFlags because creating a literal value depends on DynFlags -data PrimOps = PrimOps - { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers - , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers - , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers - , mkL :: Integer -> CoreExpr -- ^ Create a literal value - } - -intPrimOps :: DynFlags -> PrimOps -intPrimOps dflags = PrimOps - { add = \x y -> BinOpApp x IntAddOp y - , sub = \x y -> BinOpApp x IntSubOp y - , mul = \x y -> BinOpApp x IntMulOp y - , mkL = intResult' dflags - } - -wordPrimOps :: DynFlags -> PrimOps -wordPrimOps dflags = PrimOps - { add = \x y -> BinOpApp x WordAddOp y - , sub = \x y -> BinOpApp x WordSubOp y - , mul = \x y -> BinOpApp x WordMulOp y - , mkL = wordResult' dflags - } - - --------------------------------------------------------- --- Constant folding through case-expressions --- --- cf Scrutinee Constant Folding in simplCore/SimplUtils --------------------------------------------------------- - --- | Match the scrutinee of a case and potentially return a new scrutinee and a --- function to apply to each literal alternative. -caseRules :: DynFlags - -> CoreExpr -- Scrutinee - -> Maybe ( CoreExpr -- New scrutinee - , AltCon -> Maybe AltCon -- How to fix up the alt pattern - -- Nothing <=> Unreachable - -- See Note [Unreachable caseRules alternatives] - , Id -> CoreExpr) -- How to reconstruct the original scrutinee - -- from the new case-binder --- e.g case e of b { --- ...; --- con bs -> rhs; --- ... } --- ==> --- case e' of b' { --- ...; --- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; --- ... } - -caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x# - | Just op <- isPrimOpId_maybe f - , Just x <- isLitValue_maybe l - , Just adjust_lit <- adjustDyadicRight op x - = Just (v, tx_lit_con dflags adjust_lit - , \v -> (App (App (Var f) (Var v)) (Lit l))) - -caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v - | Just op <- isPrimOpId_maybe f - , Just x <- isLitValue_maybe l - , Just adjust_lit <- adjustDyadicLeft x op - = Just (v, tx_lit_con dflags adjust_lit - , \v -> (App (App (Var f) (Lit l)) (Var v))) - - -caseRules dflags (App (Var f) v ) -- op v - | Just op <- isPrimOpId_maybe f - , Just adjust_lit <- adjustUnary op - = Just (v, tx_lit_con dflags adjust_lit - , \v -> App (Var f) (Var v)) - --- See Note [caseRules for tagToEnum] -caseRules dflags (App (App (Var f) type_arg) v) - | Just TagToEnumOp <- isPrimOpId_maybe f - = Just (v, tx_con_tte dflags - , \v -> (App (App (Var f) type_arg) (Var v))) - --- See Note [caseRules for dataToTag] -caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f - , Just (tc, _) <- tcSplitTyConApp_maybe ty - , isAlgTyCon tc - = Just (v, tx_con_dtt ty - , \v -> App (App (Var f) (Type ty)) (Var v)) - -caseRules _ _ = Nothing - - -tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon -tx_lit_con _ _ DEFAULT = Just DEFAULT -tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l) -tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) - -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the - -- literal alternatives remain in Word/Int target ranges - -- (See Note [Word/Int underflow/overflow] in Literal and #13172). - -adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) --- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x -adjustDyadicRight op lit - = case op of - WordAddOp -> Just (\y -> y-lit ) - IntAddOp -> Just (\y -> y-lit ) - WordSubOp -> Just (\y -> y+lit ) - IntSubOp -> Just (\y -> y+lit ) - XorOp -> Just (\y -> y `xor` lit) - XorIOp -> Just (\y -> y `xor` lit) - _ -> Nothing - -adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) --- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x -adjustDyadicLeft lit op - = case op of - WordAddOp -> Just (\y -> y-lit ) - IntAddOp -> Just (\y -> y-lit ) - WordSubOp -> Just (\y -> lit-y ) - IntSubOp -> Just (\y -> lit-y ) - XorOp -> Just (\y -> y `xor` lit) - XorIOp -> Just (\y -> y `xor` lit) - _ -> Nothing - - -adjustUnary :: PrimOp -> Maybe (Integer -> Integer) --- Given (op x) return a function 'f' s.t. f (op x) = x -adjustUnary op - = case op of - NotOp -> Just (\y -> complement y) - NotIOp -> Just (\y -> complement y) - IntNegOp -> Just (\y -> negate y ) - _ -> Nothing - -tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon -tx_con_tte _ DEFAULT = Just DEFAULT -tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) -tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum] - = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc - -tx_con_dtt :: Type -> AltCon -> Maybe AltCon -tx_con_dtt _ DEFAULT = Just DEFAULT -tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _)) - | tag >= 0 - , tag < n_data_cons - = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) - | otherwise - = Nothing - where - tag = fromInteger i :: ConTagZ - tc = tyConAppTyCon ty - n_data_cons = tyConFamilySize tc - data_cons = tyConDataCons tc - -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) - - -{- Note [caseRules for tagToEnum] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to transform - case tagToEnum x of - False -> e1 - True -> e2 -into - case x of - 0# -> e1 - 1# -> e2 - -This rule eliminates a lot of boilerplate. For - if (x>y) then e2 else e1 -we generate - case tagToEnum (x ># y) of - False -> e1 - True -> e2 -and it is nice to then get rid of the tagToEnum. - -Beware (#14768): avoid the temptation to map constructor 0 to -DEFAULT, in the hope of getting this - case (x ># y) of - DEFAULT -> e1 - 1# -> e2 -That fails utterly in the case of - data Colour = Red | Green | Blue - case tagToEnum x of - DEFAULT -> e1 - Red -> e2 - -We don't want to get this! - case x of - DEFAULT -> e1 - DEFAULT -> e2 - -Instead, we deal with turning one branch into DEFAULT in SimplUtils -(add_default in mkCase3). - -Note [caseRules for dataToTag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [dataToTag#] in primpops.txt.pp - -We want to transform - case dataToTag x of - DEFAULT -> e1 - 1# -> e2 -into - case x of - DEFAULT -> e1 - (:) _ _ -> e2 - -Note the need for some wildcard binders in -the 'cons' case. - -For the time, we only apply this transformation when the type of `x` is a type -headed by a normal tycon. In particular, we do not apply this in the case of a -data family tycon, since that would require carefully applying coercion(s) -between the data family and the data family instance's representation type, -which caseRules isn't currently engineered to handle (#14680). - -Note [Unreachable caseRules alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Take care if we see something like - case dataToTag x of - DEFAULT -> e1 - -1# -> e2 - 100 -> e3 -because there isn't a data constructor with tag -1 or 100. In this case the -out-of-range alterantive is dead code -- we know the range of tags for x. - -Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating -an alternative that is unreachable. - -You may wonder how this can happen: check out #15436. --} diff --git a/prelude/PrimOp.hs b/prelude/PrimOp.hs deleted file mode 100644 --- a/prelude/PrimOp.hs +++ /dev/null @@ -1,697 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[PrimOp]{Primitive operations (machine-level)} --} - -{-# LANGUAGE CPP #-} - -module PrimOp ( - PrimOp(..), PrimOpVecCat(..), allThePrimOps, - primOpType, primOpSig, - primOpTag, maxPrimOpTag, primOpOcc, - primOpWrapperId, - - tagToEnumKey, - - primOpOutOfLine, primOpCodeSize, - primOpOkForSpeculation, primOpOkForSideEffects, - primOpIsCheap, primOpFixity, - - getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), - - PrimCall(..) - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TysPrim -import TysWiredIn - -import CmmType -import Demand -import Id ( Id, mkVanillaGlobalWithInfo ) -import IdInfo ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) -import Name -import PrelNames ( gHC_PRIMOPWRAPPERS ) -import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) -import Type -import RepType ( typePrimRep1, tyConPrimRep1 ) -import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), - SourceText(..) ) -import SrcLoc ( wiredInSrcSpan ) -import ForeignCall ( CLabelString ) -import Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) -import Outputable -import FastString -import Module ( UnitId ) - -{- -************************************************************************ -* * -\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} -* * -************************************************************************ - -These are in \tr{state-interface.verb} order. --} - --- supplies: --- data PrimOp = ... -#include "primop-data-decl.hs-incl" - --- supplies --- primOpTag :: PrimOp -> Int -#include "primop-tag.hs-incl" -primOpTag _ = error "primOpTag: unknown primop" - - -instance Eq PrimOp where - op1 == op2 = primOpTag op1 == primOpTag op2 - -instance Ord PrimOp where - op1 < op2 = primOpTag op1 < primOpTag op2 - op1 <= op2 = primOpTag op1 <= primOpTag op2 - op1 >= op2 = primOpTag op1 >= primOpTag op2 - op1 > op2 = primOpTag op1 > primOpTag op2 - op1 `compare` op2 | op1 < op2 = LT - | op1 == op2 = EQ - | otherwise = GT - -instance Outputable PrimOp where - ppr op = pprPrimOp op - -data PrimOpVecCat = IntVec - | WordVec - | FloatVec - --- An @Enum@-derived list would be better; meanwhile... (ToDo) - -allThePrimOps :: [PrimOp] -allThePrimOps = -#include "primop-list.hs-incl" - -tagToEnumKey :: Unique -tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) - -{- -************************************************************************ -* * -\subsection[PrimOp-info]{The essential info about each @PrimOp@} -* * -************************************************************************ - -The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may -refer to the primitive operation. The conventional \tr{#}-for- -unboxed ops is added on later. - -The reason for the funny characters in the names is so we do not -interfere with the programmer's Haskell name spaces. - -We use @PrimKinds@ for the ``type'' information, because they're -(slightly) more convenient to use than @TyCons@. --} - -data PrimOpInfo - = Dyadic OccName -- string :: T -> T -> T - Type - | Monadic OccName -- string :: T -> T - Type - | Compare OccName -- string :: T -> T -> Int# - Type - | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T - [TyVar] - [Type] - Type - -mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo -mkDyadic str ty = Dyadic (mkVarOccFS str) ty -mkMonadic str ty = Monadic (mkVarOccFS str) ty -mkCompare str ty = Compare (mkVarOccFS str) ty - -mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo -mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty - -{- -************************************************************************ -* * -\subsubsection{Strictness} -* * -************************************************************************ - -Not all primops are strict! --} - -primOpStrictness :: PrimOp -> Arity -> StrictSig - -- See Demand.StrictnessInfo for discussion of what the results - -- The arity should be the arity of the primop; that's why - -- this function isn't exported. -#include "primop-strictness.hs-incl" - -{- -************************************************************************ -* * -\subsubsection{Fixity} -* * -************************************************************************ --} - -primOpFixity :: PrimOp -> Maybe Fixity -#include "primop-fixity.hs-incl" - -{- -************************************************************************ -* * -\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} -* * -************************************************************************ - -@primOpInfo@ gives all essential information (from which everything -else, notably a type, can be constructed) for each @PrimOp@. --} - -primOpInfo :: PrimOp -> PrimOpInfo -#include "primop-primop-info.hs-incl" -primOpInfo _ = error "primOpInfo: unknown primop" - -{- -Here are a load of comments from the old primOp info: - -A @Word#@ is an unsigned @Int#@. - -@decodeFloat#@ is given w/ Integer-stuff (it's similar). - -@decodeDouble#@ is given w/ Integer-stuff (it's similar). - -Decoding of floating-point numbers is sorta Integer-related. Encoding -is done with plain ccalls now (see PrelNumExtra.hs). - -A @Weak@ Pointer is created by the @mkWeak#@ primitive: - - mkWeak# :: k -> v -> f -> State# RealWorld - -> (# State# RealWorld, Weak# v #) - -In practice, you'll use the higher-level - - data Weak v = Weak# v - mkWeak :: k -> v -> IO () -> IO (Weak v) - -The following operation dereferences a weak pointer. The weak pointer -may have been finalized, so the operation returns a result code which -must be inspected before looking at the dereferenced value. - - deRefWeak# :: Weak# v -> State# RealWorld -> - (# State# RealWorld, v, Int# #) - -Only look at v if the Int# returned is /= 0 !! - -The higher-level op is - - deRefWeak :: Weak v -> IO (Maybe v) - -Weak pointers can be finalized early by using the finalize# operation: - - finalizeWeak# :: Weak# v -> State# RealWorld -> - (# State# RealWorld, Int#, IO () #) - -The Int# returned is either - - 0 if the weak pointer has already been finalized, or it has no - finalizer (the third component is then invalid). - - 1 if the weak pointer is still alive, with the finalizer returned - as the third component. - -A {\em stable name/pointer} is an index into a table of stable name -entries. Since the garbage collector is told about stable pointers, -it is safe to pass a stable pointer to external systems such as C -routines. - -\begin{verbatim} -makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld -deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# -\end{verbatim} - -It may seem a bit surprising that @makeStablePtr#@ is a @IO@ -operation since it doesn't (directly) involve IO operations. The -reason is that if some optimisation pass decided to duplicate calls to -@makeStablePtr#@ and we only pass one of the stable pointers over, a -massive space leak can result. Putting it into the IO monad -prevents this. (Another reason for putting them in a monad is to -ensure correct sequencing wrt the side-effecting @freeStablePtr@ -operation.) - -An important property of stable pointers is that if you call -makeStablePtr# twice on the same object you get the same stable -pointer back. - -Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, -besides, it's not likely to be used from Haskell) so it's not a -primop. - -Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] - -Stable Names -~~~~~~~~~~~~ - -A stable name is like a stable pointer, but with three important differences: - - (a) You can't deRef one to get back to the original object. - (b) You can convert one to an Int. - (c) You don't need to 'freeStableName' - -The existence of a stable name doesn't guarantee to keep the object it -points to alive (unlike a stable pointer), hence (a). - -Invariants: - - (a) makeStableName always returns the same value for a given - object (same as stable pointers). - - (b) if two stable names are equal, it implies that the objects - from which they were created were the same. - - (c) stableNameToInt always returns the same Int for a given - stable name. - - -These primops are pretty weird. - - tagToEnum# :: Int -> a (result type must be an enumerated type) - -The constraints aren't currently checked by the front end, but the -code generator will fall over if they aren't satisfied. - -************************************************************************ -* * - Which PrimOps are out-of-line -* * -************************************************************************ - -Some PrimOps need to be called out-of-line because they either need to -perform a heap check or they block. --} - -primOpOutOfLine :: PrimOp -> Bool -#include "primop-out-of-line.hs-incl" - -{- -************************************************************************ -* * - Failure and side effects -* * -************************************************************************ - -Note [Checking versus non-checking primops] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - In GHC primops break down into two classes: - - a. Checking primops behave, for instance, like division. In this - case the primop may throw an exception (e.g. division-by-zero) - and is consequently is marked with the can_fail flag described below. - The ability to fail comes at the expense of precluding some optimizations. - - b. Non-checking primops behavior, for instance, like addition. While - addition can overflow it does not produce an exception. So can_fail is - set to False, and we get more optimisation opportunities. But we must - never throw an exception, so we cannot rewrite to a call to error. - - It is important that a non-checking primop never be transformed in a way that - would cause it to bottom. Doing so would violate Core's let/app invariant - (see Note [CoreSyn let/app invariant] in CoreSyn) which is critical to - the simplifier's ability to float without fear of changing program meaning. - - -Note [PrimOp can_fail and has_side_effects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Both can_fail and has_side_effects mean that the primop has -some effect that is not captured entirely by its result value. - ----------- has_side_effects --------------------- -A primop "has_side_effects" if it has some *write* effect, visible -elsewhere - - writing to the world (I/O) - - writing to a mutable data structure (writeIORef) - - throwing a synchronous Haskell exception - -Often such primops have a type like - State -> input -> (State, output) -so the state token guarantees ordering. In general we rely *only* on -data dependencies of the state token to enforce write-effect ordering - - * NB1: if you inline unsafePerformIO, you may end up with - side-effecting ops whose 'state' output is discarded. - And programmers may do that by hand; see #9390. - That is why we (conservatively) do not discard write-effecting - primops even if both their state and result is discarded. - - * NB2: We consider primops, such as raiseIO#, that can raise a - (Haskell) synchronous exception to "have_side_effects" but not - "can_fail". We must be careful about not discarding such things; - see the paper "A semantics for imprecise exceptions". - - * NB3: *Read* effects (like reading an IORef) don't count here, - because it doesn't matter if we don't do them, or do them more than - once. *Sequencing* is maintained by the data dependency of the state - token. - ----------- can_fail ---------------------------- -A primop "can_fail" if it can fail with an *unchecked* exception on -some elements of its input domain. Main examples: - division (fails on zero demoninator) - array indexing (fails if the index is out of bounds) - -An "unchecked exception" is one that is an outright error, (not -turned into a Haskell exception,) such as seg-fault or -divide-by-zero error. Such can_fail primops are ALWAYS surrounded -with a test that checks for the bad cases, but we need to be -very careful about code motion that might move it out of -the scope of the test. - -Note [Transformations affected by can_fail and has_side_effects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The can_fail and has_side_effects properties have the following effect -on program transformations. Summary table is followed by details. - - can_fail has_side_effects -Discard YES NO -Float in YES YES -Float out NO NO -Duplicate YES NO - -* Discarding. case (a `op` b) of _ -> rhs ===> rhs - You should not discard a has_side_effects primop; e.g. - case (writeIntArray# a i v s of (# _, _ #) -> True - Arguably you should be able to discard this, since the - returned stat token is not used, but that relies on NEVER - inlining unsafePerformIO, and programmers sometimes write - this kind of stuff by hand (#9390). So we (conservatively) - never discard a has_side_effects primop. - - However, it's fine to discard a can_fail primop. For example - case (indexIntArray# a i) of _ -> True - We can discard indexIntArray#; it has can_fail, but not - has_side_effects; see #5658 which was all about this. - Notice that indexIntArray# is (in a more general handling of - effects) read effect, but we don't care about that here, and - treat read effects as *not* has_side_effects. - - Similarly (a `/#` b) can be discarded. It can seg-fault or - cause a hardware exception, but not a synchronous Haskell - exception. - - - - Synchronous Haskell exceptions, e.g. from raiseIO#, are treated - as has_side_effects and hence are not discarded. - -* Float in. You can float a can_fail or has_side_effects primop - *inwards*, but not inside a lambda (see Duplication below). - -* Float out. You must not float a can_fail primop *outwards* lest - you escape the dynamic scope of the test. Example: - case d ># 0# of - True -> case x /# d of r -> r +# 1 - False -> 0 - Here we must not float the case outwards to give - case x/# d of r -> - case d ># 0# of - True -> r +# 1 - False -> 0 - - Nor can you float out a has_side_effects primop. For example: - if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 - else s0 - Notice that s0 is mentioned in both branches of the 'if', but - only one of these two will actually be consumed. But if we - float out to - case writeMutVar# v True s0 of (# s1 #) -> - if blah then s1 else s0 - the writeMutVar will be performed in both branches, which is - utterly wrong. - -* Duplication. You cannot duplicate a has_side_effect primop. You - might wonder how this can occur given the state token threading, but - just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get - something like this - p = case readMutVar# s v of - (# s', r #) -> (S# s', r) - s' = case p of (s', r) -> s' - r = case p of (s', r) -> r - - (All these bindings are boxed.) If we inline p at its two call - sites, we get a catastrophe: because the read is performed once when - s' is demanded, and once when 'r' is demanded, which may be much - later. Utterly wrong. #3207 is real example of this happening. - - However, it's fine to duplicate a can_fail primop. That is really - the only difference between can_fail and has_side_effects. - -Note [Implementation: how can_fail/has_side_effects affect transformations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How do we ensure that that floating/duplication/discarding are done right -in the simplifier? - -Two main predicates on primpops test these flags: - primOpOkForSideEffects <=> not has_side_effects - primOpOkForSpeculation <=> not (has_side_effects || can_fail) - - * The "no-float-out" thing is achieved by ensuring that we never - let-bind a can_fail or has_side_effects primop. The RHS of a - let-binding (which can float in and out freely) satisfies - exprOkForSpeculation; this is the let/app invariant. And - exprOkForSpeculation is false of can_fail and has_side_effects. - - * So can_fail and has_side_effects primops will appear only as the - scrutinees of cases, and that's why the FloatIn pass is capable - of floating case bindings inwards. - - * The no-duplicate thing is done via primOpIsCheap, by making - has_side_effects things (very very very) not-cheap! --} - -primOpHasSideEffects :: PrimOp -> Bool -#include "primop-has-side-effects.hs-incl" - -primOpCanFail :: PrimOp -> Bool -#include "primop-can-fail.hs-incl" - -primOpOkForSpeculation :: PrimOp -> Bool - -- See Note [PrimOp can_fail and has_side_effects] - -- See comments with CoreUtils.exprOkForSpeculation - -- primOpOkForSpeculation => primOpOkForSideEffects -primOpOkForSpeculation op - = primOpOkForSideEffects op - && not (primOpOutOfLine op || primOpCanFail op) - -- I think the "out of line" test is because out of line things can - -- be expensive (eg sine, cosine), and so we may not want to speculate them - -primOpOkForSideEffects :: PrimOp -> Bool -primOpOkForSideEffects op - = not (primOpHasSideEffects op) - -{- -Note [primOpIsCheap] -~~~~~~~~~~~~~~~~~~~~ -@primOpIsCheap@, as used in \tr{SimplUtils.hs}. For now (HACK -WARNING), we just borrow some other predicates for a -what-should-be-good-enough test. "Cheap" means willing to call it more -than once, and/or push it inside a lambda. The latter could change the -behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. --} - -primOpIsCheap :: PrimOp -> Bool --- See Note [PrimOp can_fail and has_side_effects] -primOpIsCheap op = primOpOkForSpeculation op --- In March 2001, we changed this to --- primOpIsCheap op = False --- thereby making *no* primops seem cheap. But this killed eta --- expansion on case (x ==# y) of True -> \s -> ... --- which is bad. In particular a loop like --- doLoop n = loop 0 --- where --- loop i | i == n = return () --- | otherwise = bar i >> loop (i+1) --- allocated a closure every time round because it doesn't eta expand. --- --- The problem that originally gave rise to the change was --- let x = a +# b *# c in x +# x --- were we don't want to inline x. But primopIsCheap doesn't control --- that (it's exprIsDupable that does) so the problem doesn't occur --- even if primOpIsCheap sometimes says 'True'. - -{- -************************************************************************ -* * - PrimOp code size -* * -************************************************************************ - -primOpCodeSize -~~~~~~~~~~~~~~ -Gives an indication of the code size of a primop, for the purposes of -calculating unfolding sizes; see CoreUnfold.sizeExpr. --} - -primOpCodeSize :: PrimOp -> Int -#include "primop-code-size.hs-incl" - -primOpCodeSizeDefault :: Int -primOpCodeSizeDefault = 1 - -- CoreUnfold.primOpSize already takes into account primOpOutOfLine - -- and adds some further costs for the args in that case. - -primOpCodeSizeForeignCall :: Int -primOpCodeSizeForeignCall = 4 - -{- -************************************************************************ -* * - PrimOp types -* * -************************************************************************ --} - -primOpType :: PrimOp -> Type -- you may want to use primOpSig instead -primOpType op - = case primOpInfo op of - Dyadic _occ ty -> dyadic_fun_ty ty - Monadic _occ ty -> monadic_fun_ty ty - Compare _occ ty -> compare_fun_ty ty - - GenPrimOp _occ tyvars arg_tys res_ty -> - mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) - -primOpOcc :: PrimOp -> OccName -primOpOcc op = case primOpInfo op of - Dyadic occ _ -> occ - Monadic occ _ -> occ - Compare occ _ -> occ - GenPrimOp occ _ _ _ -> occ - -{- Note [Primop wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously hasNoBinding would claim that PrimOpIds didn't have a curried -function definition. This caused quite some trouble as we would be forced to -eta expand unsaturated primop applications very late in the Core pipeline. Not -only would this produce unnecessary thunks, but it would also result in nasty -inconsistencies in CAFfy-ness determinations (see #16846 and -Note [CAFfyness inconsistencies due to late eta expansion] in TidyPgm). - -However, it was quite unnecessary for hasNoBinding to claim this; primops in -fact *do* have curried definitions which are found in GHC.PrimopWrappers, which -is auto-generated by utils/genprimops from prelude/primops.txt.pp. These wrappers -are standard Haskell functions mirroring the types of the primops they wrap. -For instance, in the case of plusInt# we would have: - - module GHC.PrimopWrappers where - import GHC.Prim as P - plusInt# a b = P.plusInt# a b - -We now take advantage of these curried definitions by letting hasNoBinding -claim that PrimOpIds have a curried definition and then rewrite any unsaturated -PrimOpId applications that we find during CoreToStg as applications of the -associated wrapper (e.g. `GHC.Prim.plusInt# 3#` will get rewritten to -`GHC.PrimopWrappers.plusInt# 3#`).` The Id of the wrapper for a primop can be -found using 'PrimOp.primOpWrapperId'. - -Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's -used by GHCi, which does not implement primops direct at all. - --} - --- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'. --- See Note [Primop wrappers]. -primOpWrapperId :: PrimOp -> Id -primOpWrapperId op = mkVanillaGlobalWithInfo name ty info - where - info = setCafInfo vanillaIdInfo NoCafRefs - name = mkExternalName uniq gHC_PRIMOPWRAPPERS (primOpOcc op) wiredInSrcSpan - uniq = mkPrimOpWrapperUnique (primOpTag op) - ty = primOpType op - -isComparisonPrimOp :: PrimOp -> Bool -isComparisonPrimOp op = case primOpInfo op of - Compare {} -> True - _ -> False - --- primOpSig is like primOpType but gives the result split apart: --- (type variables, argument types, result type) --- It also gives arity, strictness info - -primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) -primOpSig op - = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) - where - arity = length arg_tys - (tyvars, arg_tys, res_ty) - = case (primOpInfo op) of - Monadic _occ ty -> ([], [ty], ty ) - Dyadic _occ ty -> ([], [ty,ty], ty ) - Compare _occ ty -> ([], [ty,ty], intPrimTy) - GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) - -data PrimOpResultInfo - = ReturnsPrim PrimRep - | ReturnsAlg TyCon - --- Some PrimOps need not return a manifest primitive or algebraic value --- (i.e. they might return a polymorphic value). These PrimOps *must* --- be out of line, or the code generator won't work. - -getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo -getPrimOpResultInfo op - = case (primOpInfo op) of - Dyadic _ ty -> ReturnsPrim (typePrimRep1 ty) - Monadic _ ty -> ReturnsPrim (typePrimRep1 ty) - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) - | otherwise -> ReturnsAlg tc - where - tc = tyConAppTyCon ty - -- All primops return a tycon-app result - -- The tycon can be an unboxed tuple or sum, though, - -- which gives rise to a ReturnAlg - -{- -We do not currently make use of whether primops are commutable. - -We used to try to move constants to the right hand side for strength -reduction. --} - -{- -commutableOp :: PrimOp -> Bool -#include "primop-commutable.hs-incl" --} - --- Utils: - -dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type -dyadic_fun_ty ty = mkVisFunTys [ty, ty] ty -monadic_fun_ty ty = mkVisFunTy ty ty -compare_fun_ty ty = mkVisFunTys [ty, ty] intPrimTy - --- Output stuff: - -pprPrimOp :: PrimOp -> SDoc -pprPrimOp other_op = pprOccName (primOpOcc other_op) - -{- -************************************************************************ -* * -\subsubsection[PrimCall]{User-imported primitive calls} -* * -************************************************************************ --} - -data PrimCall = PrimCall CLabelString UnitId - -instance Outputable PrimCall where - ppr (PrimCall lbl pkgId) - = text "__primcall" <+> ppr pkgId <+> ppr lbl diff --git a/prelude/PrimOp.hs-boot b/prelude/PrimOp.hs-boot deleted file mode 100644 --- a/prelude/PrimOp.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module PrimOp where - -import GhcPrelude () - -data PrimOp diff --git a/prelude/THNames.hs b/prelude/THNames.hs deleted file mode 100644 --- a/prelude/THNames.hs +++ /dev/null @@ -1,1108 +0,0 @@ --- %************************************************************************ --- %* * --- The known-key names for Template Haskell --- %* * --- %************************************************************************ - -module THNames where - -import GhcPrelude () - -import PrelNames( mk_known_key_name ) -import Module( Module, mkModuleNameFS, mkModule, thUnitId ) -import Name( Name ) -import OccName( tcName, clsName, dataName, varName ) -import RdrName( RdrName, nameRdrName ) -import Unique -import FastString - --- To add a name, do three things --- --- 1) Allocate a key --- 2) Make a "Name" --- 3) Add the name to templateHaskellNames - -templateHaskellNames :: [Name] --- The names that are implicitly mentioned by ``bracket'' --- Should stay in sync with the import list of DsMeta - -templateHaskellNames = [ - returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, - mkNameSName, - liftStringName, - unTypeName, - unTypeQName, - unsafeTExpCoerceName, - - -- Lit - charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, - charPrimLName, - -- Pat - litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, - conPName, tildePName, bangPName, infixPName, - asPName, wildPName, recPName, listPName, sigPName, viewPName, - -- FieldPat - fieldPatName, - -- Match - matchName, - -- Clause - clauseName, - -- Exp - varEName, conEName, litEName, appEName, appTypeEName, infixEName, - infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, - tupEName, unboxedTupEName, unboxedSumEName, - condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName, - fromEName, fromThenEName, fromToEName, fromThenToEName, - listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, - labelEName, implicitParamVarEName, - -- FieldExp - fieldExpName, - -- Body - guardedBName, normalBName, - -- Guard - normalGEName, patGEName, - -- Stmt - bindSName, letSName, noBindSName, parSName, recSName, - -- Dec - funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceWithOverlapDName, - standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, - pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, - dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, - dataInstDName, newtypeInstDName, tySynInstDName, - infixLDName, infixRDName, infixNDName, - roleAnnotDName, patSynDName, patSynSigDName, - implicitParamBindDName, - -- Cxt - cxtName, - - -- SourceUnpackedness - noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, - -- SourceStrictness - noSourceStrictnessName, sourceLazyName, sourceStrictName, - -- Con - normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName, - -- Bang - bangName, - -- BangType - bangTypeName, - -- VarBangType - varBangTypeName, - -- PatSynDir (for pattern synonyms) - unidirPatSynName, implBidirPatSynName, explBidirPatSynName, - -- PatSynArgs (for pattern synonyms) - prefixPatSynName, infixPatSynName, recordPatSynName, - -- Type - forallTName, forallVisTName, varTName, conTName, infixTName, appTName, - appKindTName, equalityTName, tupleTName, unboxedTupleTName, - unboxedSumTName, arrowTName, listTName, sigTName, litTName, - promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, - wildCardTName, implicitParamTName, - -- TyLit - numTyLitName, strTyLitName, - -- TyVarBndr - plainTVName, kindedTVName, - -- Role - nominalRName, representationalRName, phantomRName, inferRName, - -- Kind - varKName, conKName, tupleKName, arrowKName, listKName, appKName, - starKName, constraintKName, - -- FamilyResultSig - noSigName, kindSigName, tyVarSigName, - -- InjectivityAnn - injectivityAnnName, - -- Callconv - cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, - -- Safety - unsafeName, - safeName, - interruptibleName, - -- Inline - noInlineDataConName, inlineDataConName, inlinableDataConName, - -- RuleMatch - conLikeDataConName, funLikeDataConName, - -- Phases - allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, - -- Overlap - overlappableDataConName, overlappingDataConName, overlapsDataConName, - incoherentDataConName, - -- DerivStrategy - stockStrategyName, anyclassStrategyName, - newtypeStrategyName, viaStrategyName, - -- TExp - tExpDataConName, - -- RuleBndr - ruleVarName, typedRuleVarName, - -- FunDep - funDepName, - -- TySynEqn - tySynEqnName, - -- AnnTarget - valueAnnotationName, typeAnnotationName, moduleAnnotationName, - -- DerivClause - derivClauseName, - - -- The type classes - liftClassName, - - -- And the tycons - qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, - clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, - stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName, - varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName, - patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, - predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, - roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName, - overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName, - - -- Quasiquoting - quoteDecName, quoteTypeName, quoteExpName, quotePatName] - -thSyn, thLib, qqLib :: Module -thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") -thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal") -qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") - -mkTHModule :: FastString -> Module -mkTHModule m = mkModule thUnitId (mkModuleNameFS m) - -libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name -libFun = mk_known_key_name OccName.varName thLib -libTc = mk_known_key_name OccName.tcName thLib -thFun = mk_known_key_name OccName.varName thSyn -thTc = mk_known_key_name OccName.tcName thSyn -thCls = mk_known_key_name OccName.clsName thSyn -thCon = mk_known_key_name OccName.dataName thSyn -qqFun = mk_known_key_name OccName.varName qqLib - --------------------- TH.Syntax ----------------------- -liftClassName :: Name -liftClassName = thCls (fsLit "Lift") liftClassKey - -qTyConName, nameTyConName, fieldExpTyConName, patTyConName, - fieldPatTyConName, expTyConName, decTyConName, typeTyConName, - matchTyConName, clauseTyConName, funDepTyConName, predTyConName, - tExpTyConName, injAnnTyConName, overlapTyConName :: Name -qTyConName = thTc (fsLit "Q") qTyConKey -nameTyConName = thTc (fsLit "Name") nameTyConKey -fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey -patTyConName = thTc (fsLit "Pat") patTyConKey -fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey -expTyConName = thTc (fsLit "Exp") expTyConKey -decTyConName = thTc (fsLit "Dec") decTyConKey -typeTyConName = thTc (fsLit "Type") typeTyConKey -matchTyConName = thTc (fsLit "Match") matchTyConKey -clauseTyConName = thTc (fsLit "Clause") clauseTyConKey -funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey -predTyConName = thTc (fsLit "Pred") predTyConKey -tExpTyConName = thTc (fsLit "TExp") tExpTyConKey -injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey -overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey - -returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName, - unsafeTExpCoerceName, liftTypedName :: Name -returnQName = thFun (fsLit "returnQ") returnQIdKey -bindQName = thFun (fsLit "bindQ") bindQIdKey -sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey -newNameName = thFun (fsLit "newName") newNameIdKey -liftName = thFun (fsLit "lift") liftIdKey -liftStringName = thFun (fsLit "liftString") liftStringIdKey -mkNameName = thFun (fsLit "mkName") mkNameIdKey -mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey -mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey -mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey -mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey -mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey -unTypeName = thFun (fsLit "unType") unTypeIdKey -unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey -unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey -liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey - - --------------------- TH.Lib ----------------------- --- data Lit = ... -charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, - charPrimLName :: Name -charLName = libFun (fsLit "charL") charLIdKey -stringLName = libFun (fsLit "stringL") stringLIdKey -integerLName = libFun (fsLit "integerL") integerLIdKey -intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey -wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey -floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey -doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey -rationalLName = libFun (fsLit "rationalL") rationalLIdKey -stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey -charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey - --- data Pat = ... -litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, - infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, - sigPName, viewPName :: Name -litPName = libFun (fsLit "litP") litPIdKey -varPName = libFun (fsLit "varP") varPIdKey -tupPName = libFun (fsLit "tupP") tupPIdKey -unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey -unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey -conPName = libFun (fsLit "conP") conPIdKey -infixPName = libFun (fsLit "infixP") infixPIdKey -tildePName = libFun (fsLit "tildeP") tildePIdKey -bangPName = libFun (fsLit "bangP") bangPIdKey -asPName = libFun (fsLit "asP") asPIdKey -wildPName = libFun (fsLit "wildP") wildPIdKey -recPName = libFun (fsLit "recP") recPIdKey -listPName = libFun (fsLit "listP") listPIdKey -sigPName = libFun (fsLit "sigP") sigPIdKey -viewPName = libFun (fsLit "viewP") viewPIdKey - --- type FieldPat = ... -fieldPatName :: Name -fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey - --- data Match = ... -matchName :: Name -matchName = libFun (fsLit "match") matchIdKey - --- data Clause = ... -clauseName :: Name -clauseName = libFun (fsLit "clause") clauseIdKey - --- data Exp = ... -varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName, - sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, - unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, - caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName, - labelEName, implicitParamVarEName :: Name -varEName = libFun (fsLit "varE") varEIdKey -conEName = libFun (fsLit "conE") conEIdKey -litEName = libFun (fsLit "litE") litEIdKey -appEName = libFun (fsLit "appE") appEIdKey -appTypeEName = libFun (fsLit "appTypeE") appTypeEIdKey -infixEName = libFun (fsLit "infixE") infixEIdKey -infixAppName = libFun (fsLit "infixApp") infixAppIdKey -sectionLName = libFun (fsLit "sectionL") sectionLIdKey -sectionRName = libFun (fsLit "sectionR") sectionRIdKey -lamEName = libFun (fsLit "lamE") lamEIdKey -lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey -tupEName = libFun (fsLit "tupE") tupEIdKey -unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey -unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey -condEName = libFun (fsLit "condE") condEIdKey -multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey -letEName = libFun (fsLit "letE") letEIdKey -caseEName = libFun (fsLit "caseE") caseEIdKey -doEName = libFun (fsLit "doE") doEIdKey -mdoEName = libFun (fsLit "mdoE") mdoEIdKey -compEName = libFun (fsLit "compE") compEIdKey --- ArithSeq skips a level -fromEName, fromThenEName, fromToEName, fromThenToEName :: Name -fromEName = libFun (fsLit "fromE") fromEIdKey -fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey -fromToEName = libFun (fsLit "fromToE") fromToEIdKey -fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey --- end ArithSeq -listEName, sigEName, recConEName, recUpdEName :: Name -listEName = libFun (fsLit "listE") listEIdKey -sigEName = libFun (fsLit "sigE") sigEIdKey -recConEName = libFun (fsLit "recConE") recConEIdKey -recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey -staticEName = libFun (fsLit "staticE") staticEIdKey -unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey -labelEName = libFun (fsLit "labelE") labelEIdKey -implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey - --- type FieldExp = ... -fieldExpName :: Name -fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey - --- data Body = ... -guardedBName, normalBName :: Name -guardedBName = libFun (fsLit "guardedB") guardedBIdKey -normalBName = libFun (fsLit "normalB") normalBIdKey - --- data Guard = ... -normalGEName, patGEName :: Name -normalGEName = libFun (fsLit "normalGE") normalGEIdKey -patGEName = libFun (fsLit "patGE") patGEIdKey - --- data Stmt = ... -bindSName, letSName, noBindSName, parSName, recSName :: Name -bindSName = libFun (fsLit "bindS") bindSIdKey -letSName = libFun (fsLit "letS") letSIdKey -noBindSName = libFun (fsLit "noBindS") noBindSIdKey -parSName = libFun (fsLit "parS") parSIdKey -recSName = libFun (fsLit "recS") recSIdKey - --- data Dec = ... -funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, - instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, - pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, - pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, - dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, - openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, - infixNDName, roleAnnotDName, patSynDName, patSynSigDName, - pragCompleteDName, implicitParamBindDName :: Name -funDName = libFun (fsLit "funD") funDIdKey -valDName = libFun (fsLit "valD") valDIdKey -dataDName = libFun (fsLit "dataD") dataDIdKey -newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey -tySynDName = libFun (fsLit "tySynD") tySynDIdKey -classDName = libFun (fsLit "classD") classDIdKey -instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey -standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey -sigDName = libFun (fsLit "sigD") sigDIdKey -kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey -defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey -forImpDName = libFun (fsLit "forImpD") forImpDIdKey -pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey -pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey -pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey -pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey -pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey -pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey -pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey -dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey -newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey -tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey -closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey -dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey -infixLDName = libFun (fsLit "infixLD") infixLDIdKey -infixRDName = libFun (fsLit "infixRD") infixRDIdKey -infixNDName = libFun (fsLit "infixND") infixNDIdKey -roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey -patSynDName = libFun (fsLit "patSynD") patSynDIdKey -patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey -implicitParamBindDName = libFun (fsLit "implicitParamBindD") implicitParamBindDIdKey - --- type Ctxt = ... -cxtName :: Name -cxtName = libFun (fsLit "cxt") cxtIdKey - --- data SourceUnpackedness = ... -noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name -noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey -sourceNoUnpackName = libFun (fsLit "sourceNoUnpack") sourceNoUnpackKey -sourceUnpackName = libFun (fsLit "sourceUnpack") sourceUnpackKey - --- data SourceStrictness = ... -noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name -noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey -sourceLazyName = libFun (fsLit "sourceLazy") sourceLazyKey -sourceStrictName = libFun (fsLit "sourceStrict") sourceStrictKey - --- data Con = ... -normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name -normalCName = libFun (fsLit "normalC" ) normalCIdKey -recCName = libFun (fsLit "recC" ) recCIdKey -infixCName = libFun (fsLit "infixC" ) infixCIdKey -forallCName = libFun (fsLit "forallC" ) forallCIdKey -gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey -recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey - --- data Bang = ... -bangName :: Name -bangName = libFun (fsLit "bang") bangIdKey - --- type BangType = ... -bangTypeName :: Name -bangTypeName = libFun (fsLit "bangType") bangTKey - --- type VarBangType = ... -varBangTypeName :: Name -varBangTypeName = libFun (fsLit "varBangType") varBangTKey - --- data PatSynDir = ... -unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name -unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey -implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey -explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey - --- data PatSynArgs = ... -prefixPatSynName, infixPatSynName, recordPatSynName :: Name -prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey -infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey -recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey - --- data Type = ... -forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, - unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName, - appKindTName, sigTName, equalityTName, litTName, promotedTName, - promotedTupleTName, promotedNilTName, promotedConsTName, - wildCardTName, implicitParamTName :: Name -forallTName = libFun (fsLit "forallT") forallTIdKey -forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey -varTName = libFun (fsLit "varT") varTIdKey -conTName = libFun (fsLit "conT") conTIdKey -tupleTName = libFun (fsLit "tupleT") tupleTIdKey -unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey -unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey -arrowTName = libFun (fsLit "arrowT") arrowTIdKey -listTName = libFun (fsLit "listT") listTIdKey -appTName = libFun (fsLit "appT") appTIdKey -appKindTName = libFun (fsLit "appKindT") appKindTIdKey -sigTName = libFun (fsLit "sigT") sigTIdKey -equalityTName = libFun (fsLit "equalityT") equalityTIdKey -litTName = libFun (fsLit "litT") litTIdKey -promotedTName = libFun (fsLit "promotedT") promotedTIdKey -promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey -promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey -promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey -wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey -infixTName = libFun (fsLit "infixT") infixTIdKey -implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey - --- data TyLit = ... -numTyLitName, strTyLitName :: Name -numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey -strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey - --- data TyVarBndr = ... -plainTVName, kindedTVName :: Name -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey - --- data Role = ... -nominalRName, representationalRName, phantomRName, inferRName :: Name -nominalRName = libFun (fsLit "nominalR") nominalRIdKey -representationalRName = libFun (fsLit "representationalR") representationalRIdKey -phantomRName = libFun (fsLit "phantomR") phantomRIdKey -inferRName = libFun (fsLit "inferR") inferRIdKey - --- data Kind = ... -varKName, conKName, tupleKName, arrowKName, listKName, appKName, - starKName, constraintKName :: Name -varKName = libFun (fsLit "varK") varKIdKey -conKName = libFun (fsLit "conK") conKIdKey -tupleKName = libFun (fsLit "tupleK") tupleKIdKey -arrowKName = libFun (fsLit "arrowK") arrowKIdKey -listKName = libFun (fsLit "listK") listKIdKey -appKName = libFun (fsLit "appK") appKIdKey -starKName = libFun (fsLit "starK") starKIdKey -constraintKName = libFun (fsLit "constraintK") constraintKIdKey - --- data FamilyResultSig = ... -noSigName, kindSigName, tyVarSigName :: Name -noSigName = libFun (fsLit "noSig") noSigIdKey -kindSigName = libFun (fsLit "kindSig") kindSigIdKey -tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey - --- data InjectivityAnn = ... -injectivityAnnName :: Name -injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey - --- data Callconv = ... -cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name -cCallName = libFun (fsLit "cCall") cCallIdKey -stdCallName = libFun (fsLit "stdCall") stdCallIdKey -cApiCallName = libFun (fsLit "cApi") cApiCallIdKey -primCallName = libFun (fsLit "prim") primCallIdKey -javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey - --- data Safety = ... -unsafeName, safeName, interruptibleName :: Name -unsafeName = libFun (fsLit "unsafe") unsafeIdKey -safeName = libFun (fsLit "safe") safeIdKey -interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey - --- newtype TExp a = ... -tExpDataConName :: Name -tExpDataConName = thCon (fsLit "TExp") tExpDataConKey - --- data RuleBndr = ... -ruleVarName, typedRuleVarName :: Name -ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey -typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey - --- data FunDep = ... -funDepName :: Name -funDepName = libFun (fsLit "funDep") funDepIdKey - --- data TySynEqn = ... -tySynEqnName :: Name -tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey - --- data AnnTarget = ... -valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name -valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey -typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey -moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey - --- type DerivClause = ... -derivClauseName :: Name -derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey - --- data DerivStrategy = ... -stockStrategyName, anyclassStrategyName, newtypeStrategyName, - viaStrategyName :: Name -stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey -anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey -newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey -viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey - -matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, - decQTyConName, conQTyConName, bangTypeQTyConName, - varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName, - patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, - ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName, - derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName, - derivStrategyQTyConName :: Name -matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey -clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey -expQTyConName = libTc (fsLit "ExpQ") expQTyConKey -stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey -decQTyConName = libTc (fsLit "DecQ") decQTyConKey -decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] -conQTyConName = libTc (fsLit "ConQ") conQTyConKey -bangTypeQTyConName = libTc (fsLit "BangTypeQ") bangTypeQTyConKey -varBangTypeQTyConName = libTc (fsLit "VarBangTypeQ") varBangTypeQTyConKey -typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey -fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey -patQTyConName = libTc (fsLit "PatQ") patQTyConKey -fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey -predQTyConName = libTc (fsLit "PredQ") predQTyConKey -ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey -tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey -roleTyConName = libTc (fsLit "Role") roleTyConKey -derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey -kindQTyConName = libTc (fsLit "KindQ") kindQTyConKey -tyVarBndrQTyConName = libTc (fsLit "TyVarBndrQ") tyVarBndrQTyConKey -derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey - --- quasiquoting -quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey -quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey - --- data Inline = ... -noInlineDataConName, inlineDataConName, inlinableDataConName :: Name -noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey -inlineDataConName = thCon (fsLit "Inline") inlineDataConKey -inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey - --- data RuleMatch = ... -conLikeDataConName, funLikeDataConName :: Name -conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey -funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey - --- data Phases = ... -allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name -allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey -fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey -beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey - --- data Overlap = ... -overlappableDataConName, - overlappingDataConName, - overlapsDataConName, - incoherentDataConName :: Name -overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey -overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey -overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey -incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey - -{- ********************************************************************* -* * - Class keys -* * -********************************************************************* -} - --- ClassUniques available: 200-299 --- Check in PrelNames if you want to change this - -liftClassKey :: Unique -liftClassKey = mkPreludeClassUnique 200 - -{- ********************************************************************* -* * - TyCon keys -* * -********************************************************************* -} - --- TyConUniques available: 200-299 --- Check in PrelNames if you want to change this - -expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, - decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, - stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, - tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey, - fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, - fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, - predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, - roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey, - overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique -expTyConKey = mkPreludeTyConUnique 200 -matchTyConKey = mkPreludeTyConUnique 201 -clauseTyConKey = mkPreludeTyConUnique 202 -qTyConKey = mkPreludeTyConUnique 203 -expQTyConKey = mkPreludeTyConUnique 204 -decQTyConKey = mkPreludeTyConUnique 205 -patTyConKey = mkPreludeTyConUnique 206 -matchQTyConKey = mkPreludeTyConUnique 207 -clauseQTyConKey = mkPreludeTyConUnique 208 -stmtQTyConKey = mkPreludeTyConUnique 209 -conQTyConKey = mkPreludeTyConUnique 210 -typeQTyConKey = mkPreludeTyConUnique 211 -typeTyConKey = mkPreludeTyConUnique 212 -decTyConKey = mkPreludeTyConUnique 213 -bangTypeQTyConKey = mkPreludeTyConUnique 214 -varBangTypeQTyConKey = mkPreludeTyConUnique 215 -fieldExpTyConKey = mkPreludeTyConUnique 216 -fieldPatTyConKey = mkPreludeTyConUnique 217 -nameTyConKey = mkPreludeTyConUnique 218 -patQTyConKey = mkPreludeTyConUnique 219 -fieldPatQTyConKey = mkPreludeTyConUnique 220 -fieldExpQTyConKey = mkPreludeTyConUnique 221 -funDepTyConKey = mkPreludeTyConUnique 222 -predTyConKey = mkPreludeTyConUnique 223 -predQTyConKey = mkPreludeTyConUnique 224 -tyVarBndrQTyConKey = mkPreludeTyConUnique 225 -decsQTyConKey = mkPreludeTyConUnique 226 -ruleBndrQTyConKey = mkPreludeTyConUnique 227 -tySynEqnQTyConKey = mkPreludeTyConUnique 228 -roleTyConKey = mkPreludeTyConUnique 229 -tExpTyConKey = mkPreludeTyConUnique 230 -injAnnTyConKey = mkPreludeTyConUnique 231 -kindQTyConKey = mkPreludeTyConUnique 232 -overlapTyConKey = mkPreludeTyConUnique 233 -derivClauseQTyConKey = mkPreludeTyConUnique 234 -derivStrategyQTyConKey = mkPreludeTyConUnique 235 - -{- ********************************************************************* -* * - DataCon keys -* * -********************************************************************* -} - --- DataConUniques available: 100-150 --- If you want to change this, make sure you check in PrelNames - --- data Inline = ... -noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique -noInlineDataConKey = mkPreludeDataConUnique 200 -inlineDataConKey = mkPreludeDataConUnique 201 -inlinableDataConKey = mkPreludeDataConUnique 202 - --- data RuleMatch = ... -conLikeDataConKey, funLikeDataConKey :: Unique -conLikeDataConKey = mkPreludeDataConUnique 203 -funLikeDataConKey = mkPreludeDataConUnique 204 - --- data Phases = ... -allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique -allPhasesDataConKey = mkPreludeDataConUnique 205 -fromPhaseDataConKey = mkPreludeDataConUnique 206 -beforePhaseDataConKey = mkPreludeDataConUnique 207 - --- newtype TExp a = ... -tExpDataConKey :: Unique -tExpDataConKey = mkPreludeDataConUnique 208 - --- data Overlap = .. -overlappableDataConKey, - overlappingDataConKey, - overlapsDataConKey, - incoherentDataConKey :: Unique -overlappableDataConKey = mkPreludeDataConUnique 209 -overlappingDataConKey = mkPreludeDataConUnique 210 -overlapsDataConKey = mkPreludeDataConUnique 211 -incoherentDataConKey = mkPreludeDataConUnique 212 - -{- ********************************************************************* -* * - Id keys -* * -********************************************************************* -} - --- IdUniques available: 200-499 --- If you want to change this, make sure you check in PrelNames - -returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, - mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, - mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey, - unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique -returnQIdKey = mkPreludeMiscIdUnique 200 -bindQIdKey = mkPreludeMiscIdUnique 201 -sequenceQIdKey = mkPreludeMiscIdUnique 202 -liftIdKey = mkPreludeMiscIdUnique 203 -newNameIdKey = mkPreludeMiscIdUnique 204 -mkNameIdKey = mkPreludeMiscIdUnique 205 -mkNameG_vIdKey = mkPreludeMiscIdUnique 206 -mkNameG_dIdKey = mkPreludeMiscIdUnique 207 -mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 -mkNameLIdKey = mkPreludeMiscIdUnique 209 -mkNameSIdKey = mkPreludeMiscIdUnique 210 -unTypeIdKey = mkPreludeMiscIdUnique 211 -unTypeQIdKey = mkPreludeMiscIdUnique 212 -unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 -liftTypedIdKey = mkPreludeMiscIdUnique 214 - - --- data Lit = ... -charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, - floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey, - charPrimLIdKey:: Unique -charLIdKey = mkPreludeMiscIdUnique 220 -stringLIdKey = mkPreludeMiscIdUnique 221 -integerLIdKey = mkPreludeMiscIdUnique 222 -intPrimLIdKey = mkPreludeMiscIdUnique 223 -wordPrimLIdKey = mkPreludeMiscIdUnique 224 -floatPrimLIdKey = mkPreludeMiscIdUnique 225 -doublePrimLIdKey = mkPreludeMiscIdUnique 226 -rationalLIdKey = mkPreludeMiscIdUnique 227 -stringPrimLIdKey = mkPreludeMiscIdUnique 228 -charPrimLIdKey = mkPreludeMiscIdUnique 229 - -liftStringIdKey :: Unique -liftStringIdKey = mkPreludeMiscIdUnique 230 - --- data Pat = ... -litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey, - infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, - listPIdKey, sigPIdKey, viewPIdKey :: Unique -litPIdKey = mkPreludeMiscIdUnique 240 -varPIdKey = mkPreludeMiscIdUnique 241 -tupPIdKey = mkPreludeMiscIdUnique 242 -unboxedTupPIdKey = mkPreludeMiscIdUnique 243 -unboxedSumPIdKey = mkPreludeMiscIdUnique 244 -conPIdKey = mkPreludeMiscIdUnique 245 -infixPIdKey = mkPreludeMiscIdUnique 246 -tildePIdKey = mkPreludeMiscIdUnique 247 -bangPIdKey = mkPreludeMiscIdUnique 248 -asPIdKey = mkPreludeMiscIdUnique 249 -wildPIdKey = mkPreludeMiscIdUnique 250 -recPIdKey = mkPreludeMiscIdUnique 251 -listPIdKey = mkPreludeMiscIdUnique 252 -sigPIdKey = mkPreludeMiscIdUnique 253 -viewPIdKey = mkPreludeMiscIdUnique 254 - --- type FieldPat = ... -fieldPatIdKey :: Unique -fieldPatIdKey = mkPreludeMiscIdUnique 260 - --- data Match = ... -matchIdKey :: Unique -matchIdKey = mkPreludeMiscIdUnique 261 - --- data Clause = ... -clauseIdKey :: Unique -clauseIdKey = mkPreludeMiscIdUnique 262 - - --- data Exp = ... -varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, - infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, - tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey, - letEIdKey, caseEIdKey, doEIdKey, compEIdKey, - fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, - listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, - unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique -varEIdKey = mkPreludeMiscIdUnique 270 -conEIdKey = mkPreludeMiscIdUnique 271 -litEIdKey = mkPreludeMiscIdUnique 272 -appEIdKey = mkPreludeMiscIdUnique 273 -appTypeEIdKey = mkPreludeMiscIdUnique 274 -infixEIdKey = mkPreludeMiscIdUnique 275 -infixAppIdKey = mkPreludeMiscIdUnique 276 -sectionLIdKey = mkPreludeMiscIdUnique 277 -sectionRIdKey = mkPreludeMiscIdUnique 278 -lamEIdKey = mkPreludeMiscIdUnique 279 -lamCaseEIdKey = mkPreludeMiscIdUnique 280 -tupEIdKey = mkPreludeMiscIdUnique 281 -unboxedTupEIdKey = mkPreludeMiscIdUnique 282 -unboxedSumEIdKey = mkPreludeMiscIdUnique 283 -condEIdKey = mkPreludeMiscIdUnique 284 -multiIfEIdKey = mkPreludeMiscIdUnique 285 -letEIdKey = mkPreludeMiscIdUnique 286 -caseEIdKey = mkPreludeMiscIdUnique 287 -doEIdKey = mkPreludeMiscIdUnique 288 -compEIdKey = mkPreludeMiscIdUnique 289 -fromEIdKey = mkPreludeMiscIdUnique 290 -fromThenEIdKey = mkPreludeMiscIdUnique 291 -fromToEIdKey = mkPreludeMiscIdUnique 292 -fromThenToEIdKey = mkPreludeMiscIdUnique 293 -listEIdKey = mkPreludeMiscIdUnique 294 -sigEIdKey = mkPreludeMiscIdUnique 295 -recConEIdKey = mkPreludeMiscIdUnique 296 -recUpdEIdKey = mkPreludeMiscIdUnique 297 -staticEIdKey = mkPreludeMiscIdUnique 298 -unboundVarEIdKey = mkPreludeMiscIdUnique 299 -labelEIdKey = mkPreludeMiscIdUnique 300 -implicitParamVarEIdKey = mkPreludeMiscIdUnique 301 -mdoEIdKey = mkPreludeMiscIdUnique 302 - --- type FieldExp = ... -fieldExpIdKey :: Unique -fieldExpIdKey = mkPreludeMiscIdUnique 305 - --- data Body = ... -guardedBIdKey, normalBIdKey :: Unique -guardedBIdKey = mkPreludeMiscIdUnique 306 -normalBIdKey = mkPreludeMiscIdUnique 307 - --- data Guard = ... -normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 308 -patGEIdKey = mkPreludeMiscIdUnique 309 - --- data Stmt = ... -bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique -bindSIdKey = mkPreludeMiscIdUnique 310 -letSIdKey = mkPreludeMiscIdUnique 311 -noBindSIdKey = mkPreludeMiscIdUnique 312 -parSIdKey = mkPreludeMiscIdUnique 313 -recSIdKey = mkPreludeMiscIdUnique 314 - --- data Dec = ... -funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, - instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, - pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, - pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, - openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, - newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, - infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, - patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, - kiSigDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 320 -valDIdKey = mkPreludeMiscIdUnique 321 -dataDIdKey = mkPreludeMiscIdUnique 322 -newtypeDIdKey = mkPreludeMiscIdUnique 323 -tySynDIdKey = mkPreludeMiscIdUnique 324 -classDIdKey = mkPreludeMiscIdUnique 325 -instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326 -instanceDIdKey = mkPreludeMiscIdUnique 327 -sigDIdKey = mkPreludeMiscIdUnique 328 -forImpDIdKey = mkPreludeMiscIdUnique 329 -pragInlDIdKey = mkPreludeMiscIdUnique 330 -pragSpecDIdKey = mkPreludeMiscIdUnique 331 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 332 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 333 -pragRuleDIdKey = mkPreludeMiscIdUnique 334 -pragAnnDIdKey = mkPreludeMiscIdUnique 335 -dataFamilyDIdKey = mkPreludeMiscIdUnique 336 -openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337 -dataInstDIdKey = mkPreludeMiscIdUnique 338 -newtypeInstDIdKey = mkPreludeMiscIdUnique 339 -tySynInstDIdKey = mkPreludeMiscIdUnique 340 -closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341 -infixLDIdKey = mkPreludeMiscIdUnique 342 -infixRDIdKey = mkPreludeMiscIdUnique 343 -infixNDIdKey = mkPreludeMiscIdUnique 344 -roleAnnotDIdKey = mkPreludeMiscIdUnique 345 -standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 -defaultSigDIdKey = mkPreludeMiscIdUnique 347 -patSynDIdKey = mkPreludeMiscIdUnique 348 -patSynSigDIdKey = mkPreludeMiscIdUnique 349 -pragCompleteDIdKey = mkPreludeMiscIdUnique 350 -implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 -kiSigDIdKey = mkPreludeMiscIdUnique 352 - --- type Cxt = ... -cxtIdKey :: Unique -cxtIdKey = mkPreludeMiscIdUnique 361 - --- data SourceUnpackedness = ... -noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique -noSourceUnpackednessKey = mkPreludeMiscIdUnique 362 -sourceNoUnpackKey = mkPreludeMiscIdUnique 363 -sourceUnpackKey = mkPreludeMiscIdUnique 364 - --- data SourceStrictness = ... -noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique -noSourceStrictnessKey = mkPreludeMiscIdUnique 365 -sourceLazyKey = mkPreludeMiscIdUnique 366 -sourceStrictKey = mkPreludeMiscIdUnique 367 - --- data Con = ... -normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey, - recGadtCIdKey :: Unique -normalCIdKey = mkPreludeMiscIdUnique 368 -recCIdKey = mkPreludeMiscIdUnique 369 -infixCIdKey = mkPreludeMiscIdUnique 370 -forallCIdKey = mkPreludeMiscIdUnique 371 -gadtCIdKey = mkPreludeMiscIdUnique 372 -recGadtCIdKey = mkPreludeMiscIdUnique 373 - --- data Bang = ... -bangIdKey :: Unique -bangIdKey = mkPreludeMiscIdUnique 374 - --- type BangType = ... -bangTKey :: Unique -bangTKey = mkPreludeMiscIdUnique 375 - --- type VarBangType = ... -varBangTKey :: Unique -varBangTKey = mkPreludeMiscIdUnique 376 - --- data PatSynDir = ... -unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique -unidirPatSynIdKey = mkPreludeMiscIdUnique 377 -implBidirPatSynIdKey = mkPreludeMiscIdUnique 378 -explBidirPatSynIdKey = mkPreludeMiscIdUnique 379 - --- data PatSynArgs = ... -prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique -prefixPatSynIdKey = mkPreludeMiscIdUnique 380 -infixPatSynIdKey = mkPreludeMiscIdUnique 381 -recordPatSynIdKey = mkPreludeMiscIdUnique 382 - --- data Type = ... -forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey, - unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, - appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, - promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, - wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 390 -forallVisTIdKey = mkPreludeMiscIdUnique 391 -varTIdKey = mkPreludeMiscIdUnique 392 -conTIdKey = mkPreludeMiscIdUnique 393 -tupleTIdKey = mkPreludeMiscIdUnique 394 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 395 -unboxedSumTIdKey = mkPreludeMiscIdUnique 396 -arrowTIdKey = mkPreludeMiscIdUnique 397 -listTIdKey = mkPreludeMiscIdUnique 398 -appTIdKey = mkPreludeMiscIdUnique 399 -appKindTIdKey = mkPreludeMiscIdUnique 400 -sigTIdKey = mkPreludeMiscIdUnique 401 -equalityTIdKey = mkPreludeMiscIdUnique 402 -litTIdKey = mkPreludeMiscIdUnique 403 -promotedTIdKey = mkPreludeMiscIdUnique 404 -promotedTupleTIdKey = mkPreludeMiscIdUnique 405 -promotedNilTIdKey = mkPreludeMiscIdUnique 406 -promotedConsTIdKey = mkPreludeMiscIdUnique 407 -wildCardTIdKey = mkPreludeMiscIdUnique 408 -implicitParamTIdKey = mkPreludeMiscIdUnique 409 -infixTIdKey = mkPreludeMiscIdUnique 410 - --- data TyLit = ... -numTyLitIdKey, strTyLitIdKey :: Unique -numTyLitIdKey = mkPreludeMiscIdUnique 411 -strTyLitIdKey = mkPreludeMiscIdUnique 412 - --- data TyVarBndr = ... -plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 413 -kindedTVIdKey = mkPreludeMiscIdUnique 414 - --- data Role = ... -nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique -nominalRIdKey = mkPreludeMiscIdUnique 415 -representationalRIdKey = mkPreludeMiscIdUnique 416 -phantomRIdKey = mkPreludeMiscIdUnique 417 -inferRIdKey = mkPreludeMiscIdUnique 418 - --- data Kind = ... -varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, - starKIdKey, constraintKIdKey :: Unique -varKIdKey = mkPreludeMiscIdUnique 419 -conKIdKey = mkPreludeMiscIdUnique 420 -tupleKIdKey = mkPreludeMiscIdUnique 421 -arrowKIdKey = mkPreludeMiscIdUnique 422 -listKIdKey = mkPreludeMiscIdUnique 423 -appKIdKey = mkPreludeMiscIdUnique 424 -starKIdKey = mkPreludeMiscIdUnique 425 -constraintKIdKey = mkPreludeMiscIdUnique 426 - --- data FamilyResultSig = ... -noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique -noSigIdKey = mkPreludeMiscIdUnique 427 -kindSigIdKey = mkPreludeMiscIdUnique 428 -tyVarSigIdKey = mkPreludeMiscIdUnique 429 - --- data InjectivityAnn = ... -injectivityAnnIdKey :: Unique -injectivityAnnIdKey = mkPreludeMiscIdUnique 430 - --- data Callconv = ... -cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, - javaScriptCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 431 -stdCallIdKey = mkPreludeMiscIdUnique 432 -cApiCallIdKey = mkPreludeMiscIdUnique 433 -primCallIdKey = mkPreludeMiscIdUnique 434 -javaScriptCallIdKey = mkPreludeMiscIdUnique 435 - --- data Safety = ... -unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 440 -safeIdKey = mkPreludeMiscIdUnique 441 -interruptibleIdKey = mkPreludeMiscIdUnique 442 - --- data FunDep = ... -funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 445 - --- data TySynEqn = ... -tySynEqnIdKey :: Unique -tySynEqnIdKey = mkPreludeMiscIdUnique 460 - --- quasiquoting -quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 470 -quotePatKey = mkPreludeMiscIdUnique 471 -quoteDecKey = mkPreludeMiscIdUnique 472 -quoteTypeKey = mkPreludeMiscIdUnique 473 - --- data RuleBndr = ... -ruleVarIdKey, typedRuleVarIdKey :: Unique -ruleVarIdKey = mkPreludeMiscIdUnique 480 -typedRuleVarIdKey = mkPreludeMiscIdUnique 481 - --- data AnnTarget = ... -valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique -valueAnnotationIdKey = mkPreludeMiscIdUnique 490 -typeAnnotationIdKey = mkPreludeMiscIdUnique 491 -moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 - --- type DerivPred = ... -derivClauseIdKey :: Unique -derivClauseIdKey = mkPreludeMiscIdUnique 493 - --- data DerivStrategy = ... -stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey, - viaStrategyIdKey :: Unique -stockStrategyIdKey = mkPreludeDataConUnique 494 -anyclassStrategyIdKey = mkPreludeDataConUnique 495 -newtypeStrategyIdKey = mkPreludeDataConUnique 496 -viaStrategyIdKey = mkPreludeDataConUnique 497 - -{- -************************************************************************ -* * - RdrNames -* * -************************************************************************ --} - -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName -lift_RDR = nameRdrName liftName -liftTyped_RDR = nameRdrName liftTypedName -mkNameG_dRDR = nameRdrName mkNameG_dName -mkNameG_vRDR = nameRdrName mkNameG_vName - --- data Exp = ... -conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName -conE_RDR = nameRdrName conEName -litE_RDR = nameRdrName litEName -appE_RDR = nameRdrName appEName -infixApp_RDR = nameRdrName infixAppName - --- data Lit = ... -stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR, - doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName -stringL_RDR = nameRdrName stringLName -intPrimL_RDR = nameRdrName intPrimLName -wordPrimL_RDR = nameRdrName wordPrimLName -floatPrimL_RDR = nameRdrName floatPrimLName -doublePrimL_RDR = nameRdrName doublePrimLName -stringPrimL_RDR = nameRdrName stringPrimLName -charPrimL_RDR = nameRdrName charPrimLName diff --git a/prelude/TysPrim.hs b/prelude/TysPrim.hs deleted file mode 100644 --- a/prelude/TysPrim.hs +++ /dev/null @@ -1,1104 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1994-1998 - - -\section[TysPrim]{Wired-in knowledge about primitive types} --} - -{-# LANGUAGE CPP #-} - --- | This module defines TyCons that can't be expressed in Haskell. --- They are all, therefore, wired-in TyCons. C.f module TysWiredIn -module TysPrim( - mkPrimTyConName, -- For implicit parameters in TysWiredIn only - - mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom, - mkTemplateKiTyVars, mkTemplateKiTyVar, - - mkTemplateTyConBinders, mkTemplateKindTyConBinders, - mkTemplateAnonTyConBinders, - - alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, - alphaTys, alphaTy, betaTy, gammaTy, deltaTy, - alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep, - alphaTysUnliftedRep, alphaTyUnliftedRep, - runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, - openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, - - -- Kind constructors... - tYPETyCon, tYPETyConName, - - -- Kinds - tYPE, primRepToRuntimeRep, - - funTyCon, funTyConName, - unexposedPrimTyCons, exposedPrimTyCons, primTyCons, - - charPrimTyCon, charPrimTy, charPrimTyConName, - intPrimTyCon, intPrimTy, intPrimTyConName, - wordPrimTyCon, wordPrimTy, wordPrimTyConName, - addrPrimTyCon, addrPrimTy, addrPrimTyConName, - floatPrimTyCon, floatPrimTy, floatPrimTyConName, - doublePrimTyCon, doublePrimTy, doublePrimTyConName, - - voidPrimTyCon, voidPrimTy, - statePrimTyCon, mkStatePrimTy, - realWorldTyCon, realWorldTy, realWorldStatePrimTy, - - proxyPrimTyCon, mkProxyPrimTy, - - arrayPrimTyCon, mkArrayPrimTy, - byteArrayPrimTyCon, byteArrayPrimTy, - arrayArrayPrimTyCon, mkArrayArrayPrimTy, - smallArrayPrimTyCon, mkSmallArrayPrimTy, - mutableArrayPrimTyCon, mkMutableArrayPrimTy, - mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, - mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy, - smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, - mutVarPrimTyCon, mkMutVarPrimTy, - - mVarPrimTyCon, mkMVarPrimTy, - tVarPrimTyCon, mkTVarPrimTy, - stablePtrPrimTyCon, mkStablePtrPrimTy, - stableNamePrimTyCon, mkStableNamePrimTy, - compactPrimTyCon, compactPrimTy, - bcoPrimTyCon, bcoPrimTy, - weakPrimTyCon, mkWeakPrimTy, - threadIdPrimTyCon, threadIdPrimTy, - - int8PrimTyCon, int8PrimTy, int8PrimTyConName, - word8PrimTyCon, word8PrimTy, word8PrimTyConName, - - int16PrimTyCon, int16PrimTy, int16PrimTyConName, - word16PrimTyCon, word16PrimTy, word16PrimTyConName, - - int32PrimTyCon, int32PrimTy, int32PrimTyConName, - word32PrimTyCon, word32PrimTy, word32PrimTyConName, - - int64PrimTyCon, int64PrimTy, int64PrimTyConName, - word64PrimTyCon, word64PrimTy, word64PrimTyConName, - - eqPrimTyCon, -- ty1 ~# ty2 - eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) - eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) - equalityTyCon, - - -- * SIMD -#include "primop-vector-tys-exports.hs-incl" - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TysWiredIn - ( runtimeRepTy, unboxedTupleKind, liftedTypeKind - , vecRepDataConTyCon, tupleRepDataConTyCon - , liftedRepDataConTy, unliftedRepDataConTy - , intRepDataConTy - , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy - , wordRepDataConTy - , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy - , addrRepDataConTy - , floatRepDataConTy, doubleRepDataConTy - , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy - , vec64DataConTy - , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy - , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy - , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy - , doubleElemRepDataConTy - , mkPromotedListTy ) - -import Var ( TyVar, mkTyVar ) -import Name -import TyCon -import SrcLoc -import Unique -import PrelNames -import FastString -import Outputable -import TyCoRep -- Doesn't need special access, but this is easier to avoid - -- import loops which show up if you import Type instead - -import Data.Char - -{- -************************************************************************ -* * -\subsection{Primitive type constructors} -* * -************************************************************************ --} - -primTyCons :: [TyCon] -primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons - --- | Primitive 'TyCon's that are defined in "GHC.Prim" but not exposed. --- It's important to keep these separate as we don't want users to be able to --- write them (see #15209) or see them in GHCi's @:browse@ output --- (see #12023). -unexposedPrimTyCons :: [TyCon] -unexposedPrimTyCons - = [ eqPrimTyCon - , eqReprPrimTyCon - , eqPhantPrimTyCon - ] - --- | Primitive 'TyCon's that are defined in, and exported from, "GHC.Prim". -exposedPrimTyCons :: [TyCon] -exposedPrimTyCons - = [ addrPrimTyCon - , arrayPrimTyCon - , byteArrayPrimTyCon - , arrayArrayPrimTyCon - , smallArrayPrimTyCon - , charPrimTyCon - , doublePrimTyCon - , floatPrimTyCon - , intPrimTyCon - , int8PrimTyCon - , int16PrimTyCon - , int32PrimTyCon - , int64PrimTyCon - , bcoPrimTyCon - , weakPrimTyCon - , mutableArrayPrimTyCon - , mutableByteArrayPrimTyCon - , mutableArrayArrayPrimTyCon - , smallMutableArrayPrimTyCon - , mVarPrimTyCon - , tVarPrimTyCon - , mutVarPrimTyCon - , realWorldTyCon - , stablePtrPrimTyCon - , stableNamePrimTyCon - , compactPrimTyCon - , statePrimTyCon - , voidPrimTyCon - , proxyPrimTyCon - , threadIdPrimTyCon - , wordPrimTyCon - , word8PrimTyCon - , word16PrimTyCon - , word32PrimTyCon - , word64PrimTyCon - - , tYPETyCon - -#include "primop-vector-tycons.hs-incl" - ] - -mkPrimTc :: FastString -> Unique -> TyCon -> Name -mkPrimTc fs unique tycon - = mkWiredInName gHC_PRIM (mkTcOccFS fs) - unique - (ATyCon tycon) -- Relevant TyCon - UserSyntax - -mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name -mkBuiltInPrimTc fs unique tycon - = mkWiredInName gHC_PRIM (mkTcOccFS fs) - unique - (ATyCon tycon) -- Relevant TyCon - BuiltInSyntax - - -charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name -charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon -intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon -int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon -int16PrimTyConName = mkPrimTc (fsLit "Int16#") int16PrimTyConKey int16PrimTyCon -int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon -int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon -wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon -word8PrimTyConName = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon -word16PrimTyConName = mkPrimTc (fsLit "Word16#") word16PrimTyConKey word16PrimTyCon -word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon -word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon -addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon -floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon -doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon -statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon -voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon -proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon -eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon -eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon -eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon -realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon -arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon -byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon -arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon -smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon -mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon -mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon -mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon -smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon -mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon -mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon -tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon -stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon -stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon -compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon -bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon -weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon -threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon - -{- -************************************************************************ -* * -\subsection{Support code} -* * -************************************************************************ - -alphaTyVars is a list of type variables for use in templates: - ["a", "b", ..., "z", "t1", "t2", ... ] --} - -mkTemplateKindVar :: Kind -> TyVar -mkTemplateKindVar = mkTyVar (mk_tv_name 0 "k") - -mkTemplateKindVars :: [Kind] -> [TyVar] --- k0 with unique (mkAlphaTyVarUnique 0) --- k1 with unique (mkAlphaTyVarUnique 1) --- ... etc -mkTemplateKindVars [kind] = [mkTemplateKindVar kind] - -- Special case for one kind: just "k" -mkTemplateKindVars kinds - = [ mkTyVar (mk_tv_name u ('k' : show u)) kind - | (kind, u) <- kinds `zip` [0..] ] -mk_tv_name :: Int -> String -> Name -mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u) - (mkTyVarOccFS (mkFastString s)) - noSrcSpan - -mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] --- a with unique (mkAlphaTyVarUnique n) --- b with unique (mkAlphaTyVarUnique n+1) --- ... etc --- Typically called as --- mkTemplateTyVarsFrom (length kv_bndrs) kinds --- where kv_bndrs are the kind-level binders of a TyCon -mkTemplateTyVarsFrom n kinds - = [ mkTyVar name kind - | (kind, index) <- zip kinds [0..], - let ch_ord = index + ord 'a' - name_str | ch_ord <= ord 'z' = [chr ch_ord] - | otherwise = 't':show index - name = mk_tv_name (index + n) name_str - ] - -mkTemplateTyVars :: [Kind] -> [TyVar] -mkTemplateTyVars = mkTemplateTyVarsFrom 1 - -mkTemplateTyConBinders - :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars - -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] - -- same length as first arg - -- Result is anon arg kinds - -> [TyConBinder] -mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds - = kv_bndrs ++ tv_bndrs - where - kv_bndrs = mkTemplateKindTyConBinders kind_var_kinds - anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs)) - tv_bndrs = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds - -mkTemplateKiTyVars - :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars - -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] - -- same length as first arg - -- Result is anon arg kinds [ak1, .., akm] - -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] --- Example: if you want the tyvars for --- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah --- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *]) -mkTemplateKiTyVars kind_var_kinds mk_arg_kinds - = kv_bndrs ++ tv_bndrs - where - kv_bndrs = mkTemplateKindVars kind_var_kinds - anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs) - tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds - -mkTemplateKiTyVar - :: Kind -- [k1, .., kn] Kind of kind-forall'd var - -> (Kind -> [Kind]) -- Arg is kv1:k1 - -- Result is anon arg kinds [ak1, .., akm] - -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] --- Example: if you want the tyvars for --- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah --- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *]) -mkTemplateKiTyVar kind mk_arg_kinds - = kv_bndr : tv_bndrs - where - kv_bndr = mkTemplateKindVar kind - anon_kinds = mk_arg_kinds (mkTyVarTy kv_bndr) - tv_bndrs = mkTemplateTyVarsFrom 1 anon_kinds - -mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] --- Makes named, Specified binders -mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] - -mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] -mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds) - -mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] -mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds) - -alphaTyVars :: [TyVar] -alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind - -alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar -(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars - -alphaTys :: [Type] -alphaTys = mkTyVarTys alphaTyVars -alphaTy, betaTy, gammaTy, deltaTy :: Type -(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys - -alphaTyVarsUnliftedRep :: [TyVar] -alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepDataConTy) - -alphaTyVarUnliftedRep :: TyVar -(alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep - -alphaTysUnliftedRep :: [Type] -alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep -alphaTyUnliftedRep :: Type -(alphaTyUnliftedRep:_) = alphaTysUnliftedRep - -runtimeRep1TyVar, runtimeRep2TyVar :: TyVar -(runtimeRep1TyVar : runtimeRep2TyVar : _) - = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' - -runtimeRep1Ty, runtimeRep2Ty :: Type -runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar -runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar - -openAlphaTyVar, openBetaTyVar :: TyVar -[openAlphaTyVar,openBetaTyVar] - = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] - -openAlphaTy, openBetaTy :: Type -openAlphaTy = mkTyVarTy openAlphaTyVar -openBetaTy = mkTyVarTy openBetaTyVar - -{- -************************************************************************ -* * - FunTyCon -* * -************************************************************************ --} - -funTyConName :: Name -funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon - --- | The @(->)@ type constructor. --- --- @ --- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). --- TYPE rep1 -> TYPE rep2 -> * --- @ -funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm - where - tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar - , mkNamedTyConBinder Inferred runtimeRep2TyVar ] - ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty - , tYPE runtimeRep2Ty - ] - tc_rep_nm = mkPrelTyConRepName funTyConName - -{- -************************************************************************ -* * - Kinds -* * -************************************************************************ - -Note [TYPE and RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -All types that classify values have a kind of the form (TYPE rr), where - - data RuntimeRep -- Defined in ghc-prim:GHC.Types - = LiftedRep - | UnliftedRep - | IntRep - | FloatRep - .. etc .. - - rr :: RuntimeRep - - TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in - -So for example: - Int :: TYPE 'LiftedRep - Array# Int :: TYPE 'UnliftedRep - Int# :: TYPE 'IntRep - Float# :: TYPE 'FloatRep - Maybe :: TYPE 'LiftedRep -> TYPE 'LiftedRep - (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) - -We abbreviate '*' specially: - type * = TYPE 'LiftedRep - -The 'rr' parameter tells us how the value is represented at runime. - -Generally speaking, you can't be polymorphic in 'rr'. E.g - f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a] - f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ... -This is no good: we could not generate code code for 'f', because the -calling convention for 'f' varies depending on whether the argument is -a a Int, Int#, or Float#. (You could imagine generating specialised -code, one for each instantiation of 'rr', but we don't do that.) - -Certain functions CAN be runtime-rep-polymorphic, because the code -generator never has to manipulate a value of type 'a :: TYPE rr'. - -* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a - Code generator never has to manipulate the return value. - -* unsafeCoerce#, defined in MkId.unsafeCoerceId: - Always inlined to be a no-op - unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b - -* Unboxed tuples, and unboxed sums, defined in TysWiredIn - Always inlined, and hence specialised to the call site - (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b -> TYPE ('TupleRep '[r1, r2]) - -Note [PrimRep and kindPrimRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As part of its source code, in TyCon, GHC has - data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc... - -Notice that - * RuntimeRep is part of the syntax tree of the program being compiled - (defined in a library: ghc-prim:GHC.Types) - * PrimRep is part of GHC's source code. - (defined in TyCon) - -We need to get from one to the other; that is what kindPrimRep does. -Suppose we have a value - (v :: t) where (t :: k) -Given this kind - k = TyConApp "TYPE" [rep] -GHC needs to be able to figure out how 'v' is represented at runtime. -It expects 'rep' to be form - TyConApp rr_dc args -where 'rr_dc' is a promoteed data constructor from RuntimeRep. So -now we need to go from 'dc' to the corresponding PrimRep. We store this -PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo. - --} - -tYPETyCon :: TyCon -tYPETyConName :: Name - -tYPETyCon = mkKindTyCon tYPETyConName - (mkTemplateAnonTyConBinders [runtimeRepTy]) - liftedTypeKind - [Nominal] - (mkPrelTyConRepName tYPETyConName) - --------------------------- --- ... and now their names - --- If you edit these, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon - -mkPrimTyConName :: FastString -> Unique -> TyCon -> Name -mkPrimTyConName = mkPrimTcName BuiltInSyntax - -- All of the super kinds and kinds are defined in Prim, - -- and use BuiltInSyntax, because they are never in scope in the source - -mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name -mkPrimTcName built_in_syntax occ key tycon - = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax - ------------------------------ --- | Given a RuntimeRep, applies TYPE to it. --- see Note [TYPE and RuntimeRep] -tYPE :: Type -> Type -tYPE rr = TyConApp tYPETyCon [rr] - -{- -************************************************************************ -* * -\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} -* * -************************************************************************ --} - --- only used herein -pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon -pcPrimTyCon name roles rep - = mkPrimTyCon name binders result_kind roles - where - binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) - result_kind = tYPE (primRepToRuntimeRep rep) - --- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep --- Defined here to avoid (more) module loops -primRepToRuntimeRep :: PrimRep -> Type -primRepToRuntimeRep rep = case rep of - VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] - LiftedRep -> liftedRepDataConTy - UnliftedRep -> unliftedRepDataConTy - IntRep -> intRepDataConTy - Int8Rep -> int8RepDataConTy - Int16Rep -> int16RepDataConTy - Int32Rep -> int32RepDataConTy - Int64Rep -> int64RepDataConTy - WordRep -> wordRepDataConTy - Word8Rep -> word8RepDataConTy - Word16Rep -> word16RepDataConTy - Word32Rep -> word32RepDataConTy - Word64Rep -> word64RepDataConTy - AddrRep -> addrRepDataConTy - FloatRep -> floatRepDataConTy - DoubleRep -> doubleRepDataConTy - VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] - where - n' = case n of - 2 -> vec2DataConTy - 4 -> vec4DataConTy - 8 -> vec8DataConTy - 16 -> vec16DataConTy - 32 -> vec32DataConTy - 64 -> vec64DataConTy - _ -> pprPanic "Disallowed VecCount" (ppr n) - - elem' = case elem of - Int8ElemRep -> int8ElemRepDataConTy - Int16ElemRep -> int16ElemRepDataConTy - Int32ElemRep -> int32ElemRepDataConTy - Int64ElemRep -> int64ElemRepDataConTy - Word8ElemRep -> word8ElemRepDataConTy - Word16ElemRep -> word16ElemRepDataConTy - Word32ElemRep -> word32ElemRepDataConTy - Word64ElemRep -> word64ElemRepDataConTy - FloatElemRep -> floatElemRepDataConTy - DoubleElemRep -> doubleElemRepDataConTy - -pcPrimTyCon0 :: Name -> PrimRep -> TyCon -pcPrimTyCon0 name rep - = pcPrimTyCon name [] rep - -charPrimTy :: Type -charPrimTy = mkTyConTy charPrimTyCon -charPrimTyCon :: TyCon -charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep - -intPrimTy :: Type -intPrimTy = mkTyConTy intPrimTyCon -intPrimTyCon :: TyCon -intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep - -int8PrimTy :: Type -int8PrimTy = mkTyConTy int8PrimTyCon -int8PrimTyCon :: TyCon -int8PrimTyCon = pcPrimTyCon0 int8PrimTyConName Int8Rep - -int16PrimTy :: Type -int16PrimTy = mkTyConTy int16PrimTyCon -int16PrimTyCon :: TyCon -int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName Int16Rep - -int32PrimTy :: Type -int32PrimTy = mkTyConTy int32PrimTyCon -int32PrimTyCon :: TyCon -int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName Int32Rep - -int64PrimTy :: Type -int64PrimTy = mkTyConTy int64PrimTyCon -int64PrimTyCon :: TyCon -int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep - -wordPrimTy :: Type -wordPrimTy = mkTyConTy wordPrimTyCon -wordPrimTyCon :: TyCon -wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep - -word8PrimTy :: Type -word8PrimTy = mkTyConTy word8PrimTyCon -word8PrimTyCon :: TyCon -word8PrimTyCon = pcPrimTyCon0 word8PrimTyConName Word8Rep - -word16PrimTy :: Type -word16PrimTy = mkTyConTy word16PrimTyCon -word16PrimTyCon :: TyCon -word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName Word16Rep - -word32PrimTy :: Type -word32PrimTy = mkTyConTy word32PrimTyCon -word32PrimTyCon :: TyCon -word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep - -word64PrimTy :: Type -word64PrimTy = mkTyConTy word64PrimTyCon -word64PrimTyCon :: TyCon -word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep - -addrPrimTy :: Type -addrPrimTy = mkTyConTy addrPrimTyCon -addrPrimTyCon :: TyCon -addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep - -floatPrimTy :: Type -floatPrimTy = mkTyConTy floatPrimTyCon -floatPrimTyCon :: TyCon -floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep - -doublePrimTy :: Type -doublePrimTy = mkTyConTy doublePrimTyCon -doublePrimTyCon :: TyCon -doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep - -{- -************************************************************************ -* * -\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} -* * -************************************************************************ - -Note [The equality types story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC sports a veritable menagerie of equality types: - - Type or Lifted? Hetero? Role Built in Defining module - class? L/U TyCon ------------------------------------------------------------------------------------------ -~# T U hetero nominal eqPrimTyCon GHC.Prim -~~ C L hetero nominal heqTyCon GHC.Types -~ C L homo nominal eqTyCon GHC.Types -:~: T L homo nominal (not built-in) Data.Type.Equality -:~~: T L hetero nominal (not built-in) Data.Type.Equality - -~R# T U hetero repr eqReprPrimTy GHC.Prim -Coercible C L homo repr coercibleTyCon GHC.Types -Coercion T L homo repr (not built-in) Data.Type.Coercion -~P# T U hetero phantom eqPhantPrimTyCon GHC.Prim - -Recall that "hetero" means the equality can related types of different -kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2) -also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2). - -To produce less confusion for end users, when not dumping and without --fprint-equality-relations, each of these groups is printed as the bottommost -listed equality. That is, (~#) and (~~) are both rendered as (~) in -error messages, and (~R#) is rendered as Coercible. - -Let's take these one at a time: - - -------------------------- - (~#) :: forall k1 k2. k1 -> k2 -> # - -------------------------- -This is The Type Of Equality in GHC. It classifies nominal coercions. -This type is used in the solver for recording equality constraints. -It responds "yes" to Type.isEqPrimPred and classifies as an EqPred in -Type.classifyPredType. - -All wanted constraints of this type are built with coercion holes. -(See Note [Coercion holes] in TyCoRep.) But see also -Note [Deferred errors for coercion holes] in TcErrors to see how -equality constraints are deferred. - -Within GHC, ~# is called eqPrimTyCon, and it is defined in TysPrim. - - - -------------------------- - (~~) :: forall k1 k2. k1 -> k2 -> Constraint - -------------------------- -This is (almost) an ordinary class, defined as if by - class a ~# b => a ~~ b - instance a ~# b => a ~~ b -Here's what's unusual about it: - - * We can't actually declare it that way because we don't have syntax for ~#. - And ~# isn't a constraint, so even if we could write it, it wouldn't kind - check. - - * Users cannot write instances of it. - - * It is "naturally coherent". This means that the solver won't hesitate to - solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the - context. (Normally, it waits to learn more, just in case the given - influences what happens next.) See Note [Naturally coherent classes] - in TcInteract. - - * It always terminates. That is, in the UndecidableInstances checks, we - don't worry if a (~~) constraint is too big, as we know that solving - equality terminates. - -On the other hand, this behaves just like any class w.r.t. eager superclass -unpacking in the solver. So a lifted equality given quickly becomes an unlifted -equality given. This is good, because the solver knows all about unlifted -equalities. There is some special-casing in TcInteract.matchClassInst to -pretend that there is an instance of this class, as we can't write the instance -in Haskell. - -Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn. - - - -------------------------- - (~) :: forall k. k -> k -> Constraint - -------------------------- -This is /exactly/ like (~~), except with a homogeneous kind. -It is an almost-ordinary class defined as if by - class a ~# b => (a :: k) ~ (b :: k) - instance a ~# b => a ~ b - - * All the bullets for (~~) apply - - * In addition (~) is magical syntax, as ~ is a reserved symbol. - It cannot be exported or imported. - -Within GHC, ~ is called eqTyCon, and it is defined in TysWiredIn. - -Historical note: prior to July 18 (~) was defined as a - more-ordinary class with (~~) as a superclass. But that made it - special in different ways; and the extra superclass selections to - get from (~) to (~#) via (~~) were tiresome. Now it's defined - uniformly with (~~) and Coercible; much nicer.) - - - -------------------------- - (:~:) :: forall k. k -> k -> * - (:~~:) :: forall k1 k2. k1 -> k2 -> * - -------------------------- -These are perfectly ordinary GADTs, wrapping (~) and (~~) resp. -They are not defined within GHC at all. - - - -------------------------- - (~R#) :: forall k1 k2. k1 -> k2 -> # - -------------------------- -The is the representational analogue of ~#. This is the type of representational -equalities that the solver works on. All wanted constraints of this type are -built with coercion holes. - -Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in TysPrim. - - - -------------------------- - Coercible :: forall k. k -> k -> Constraint - -------------------------- -This is quite like (~~) in the way it's defined and treated within GHC, but -it's homogeneous. Homogeneity helps with type inference (as GHC can solve one -kind from the other) and, in my (Richard's) estimation, will be more intuitive -for users. - -An alternative design included HCoercible (like (~~)) and Coercible (like (~)). -One annoyance was that we want `coerce :: Coercible a b => a -> b`, and -we need the type of coerce to be fully wired-in. So the HCoercible/Coercible -split required that both types be fully wired-in. Instead of doing this, -I just got rid of HCoercible, as I'm not sure who would use it, anyway. - -Within GHC, Coercible is called coercibleTyCon, and it is defined in -TysWiredIn. - - - -------------------------- - Coercion :: forall k. k -> k -> * - -------------------------- -This is a perfectly ordinary GADT, wrapping Coercible. It is not defined -within GHC at all. - - - -------------------------- - (~P#) :: forall k1 k2. k1 -> k2 -> # - -------------------------- -This is the phantom analogue of ~# and it is barely used at all. -(The solver has no idea about this one.) Here is the motivation: - - data Phant a = MkPhant - type role Phant phantom - - Phant _P :: Phant Int ~P# Phant Bool - -We just need to have something to put on that last line. You probably -don't need to worry about it. - - - -Note [The State# TyCon] -~~~~~~~~~~~~~~~~~~~~~~~ -State# is the primitive, unlifted type of states. It has one type parameter, -thus - State# RealWorld -or - State# s - -where s is a type variable. The only purpose of the type parameter is to -keep different state threads separate. It is represented by nothing at all. - -The type parameter to State# is intended to keep separate threads separate. -Even though this parameter is not used in the definition of State#, it is -given role Nominal to enforce its intended use. --} - -mkStatePrimTy :: Type -> Type -mkStatePrimTy ty = TyConApp statePrimTyCon [ty] - -statePrimTyCon :: TyCon -- See Note [The State# TyCon] -statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep - -{- -RealWorld is deeply magical. It is *primitive*, but it is not -*unlifted* (hence ptrArg). We never manipulate values of type -RealWorld; it's only used in the type system, to parameterise State#. --} - -realWorldTyCon :: TyCon -realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind [] -realWorldTy :: Type -realWorldTy = mkTyConTy realWorldTyCon -realWorldStatePrimTy :: Type -realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld - --- Note: the ``state-pairing'' types are not truly primitive, --- so they are defined in \tr{TysWiredIn.hs}, not here. - - -voidPrimTy :: Type -voidPrimTy = TyConApp voidPrimTyCon [] - -voidPrimTyCon :: TyCon -voidPrimTyCon = pcPrimTyCon voidPrimTyConName [] VoidRep - -mkProxyPrimTy :: Type -> Type -> Type -mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] - -proxyPrimTyCon :: TyCon -proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom] - where - -- Kind: forall k. k -> TYPE (Tuple '[]) - binders = mkTemplateTyConBinders [liftedTypeKind] id - res_kind = unboxedTupleKind [] - - -{- ********************************************************************* -* * - Primitive equality constraints - See Note [The equality types story] -* * -********************************************************************* -} - -eqPrimTyCon :: TyCon -- The representation type for equality predicates - -- See Note [The equality types story] -eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles - where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] - roles = [Nominal, Nominal, Nominal, Nominal] - --- like eqPrimTyCon, but the type for *Representational* coercions --- this should only ever appear as the type of a covar. Its role is --- interpreted in coercionRole -eqReprPrimTyCon :: TyCon -- See Note [The equality types story] -eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles - where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] - roles = [Nominal, Nominal, Representational, Representational] - --- like eqPrimTyCon, but the type for *Phantom* coercions. --- This is only used to make higher-order equalities. Nothing --- should ever actually have this type! -eqPhantPrimTyCon :: TyCon -eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles - where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] - roles = [Nominal, Nominal, Phantom, Phantom] - --- | Given a Role, what TyCon is the type of equality predicates at that role? -equalityTyCon :: Role -> TyCon -equalityTyCon Nominal = eqPrimTyCon -equalityTyCon Representational = eqReprPrimTyCon -equalityTyCon Phantom = eqPhantPrimTyCon - -{- ********************************************************************* -* * - The primitive array types -* * -********************************************************************* -} - -arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, - byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, - smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] UnliftedRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] UnliftedRep -byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName UnliftedRep -arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName UnliftedRep -mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep -smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] UnliftedRep -smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep - -mkArrayPrimTy :: Type -> Type -mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] -byteArrayPrimTy :: Type -byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon -mkArrayArrayPrimTy :: Type -mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon -mkSmallArrayPrimTy :: Type -> Type -mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt] -mkMutableArrayPrimTy :: Type -> Type -> Type -mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] -mkMutableByteArrayPrimTy :: Type -> Type -mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] -mkMutableArrayArrayPrimTy :: Type -> Type -mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] -mkSmallMutableArrayPrimTy :: Type -> Type -> Type -mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] - - -{- ********************************************************************* -* * - The mutable variable type -* * -********************************************************************* -} - -mutVarPrimTyCon :: TyCon -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep - -mkMutVarPrimTy :: Type -> Type -> Type -mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] - -{- -************************************************************************ -* * -\subsection[TysPrim-synch-var]{The synchronizing variable type} -* * -************************************************************************ --} - -mVarPrimTyCon :: TyCon -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep - -mkMVarPrimTy :: Type -> Type -> Type -mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] - -{- -************************************************************************ -* * -\subsection[TysPrim-stm-var]{The transactional variable type} -* * -************************************************************************ --} - -tVarPrimTyCon :: TyCon -tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep - -mkTVarPrimTy :: Type -> Type -> Type -mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] - -{- -************************************************************************ -* * -\subsection[TysPrim-stable-ptrs]{The stable-pointer type} -* * -************************************************************************ --} - -stablePtrPrimTyCon :: TyCon -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep - -mkStablePtrPrimTy :: Type -> Type -mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] - -{- -************************************************************************ -* * -\subsection[TysPrim-stable-names]{The stable-name type} -* * -************************************************************************ --} - -stableNamePrimTyCon :: TyCon -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Phantom] UnliftedRep - -mkStableNamePrimTy :: Type -> Type -mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] - -{- -************************************************************************ -* * -\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type} -* * -************************************************************************ --} - -compactPrimTyCon :: TyCon -compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep - -compactPrimTy :: Type -compactPrimTy = mkTyConTy compactPrimTyCon - -{- -************************************************************************ -* * -\subsection[TysPrim-BCOs]{The ``bytecode object'' type} -* * -************************************************************************ --} - -bcoPrimTy :: Type -bcoPrimTy = mkTyConTy bcoPrimTyCon -bcoPrimTyCon :: TyCon -bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep - -{- -************************************************************************ -* * -\subsection[TysPrim-Weak]{The ``weak pointer'' type} -* * -************************************************************************ --} - -weakPrimTyCon :: TyCon -weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep - -mkWeakPrimTy :: Type -> Type -mkWeakPrimTy v = TyConApp weakPrimTyCon [v] - -{- -************************************************************************ -* * -\subsection[TysPrim-thread-ids]{The ``thread id'' type} -* * -************************************************************************ - -A thread id is represented by a pointer to the TSO itself, to ensure -that they are always unique and we can always find the TSO for a given -thread id. However, this has the unfortunate consequence that a -ThreadId# for a given thread is treated as a root by the garbage -collector and can keep TSOs around for too long. - -Hence the programmer API for thread manipulation uses a weak pointer -to the thread id internally. --} - -threadIdPrimTy :: Type -threadIdPrimTy = mkTyConTy threadIdPrimTyCon -threadIdPrimTyCon :: TyCon -threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep - -{- -************************************************************************ -* * -\subsection{SIMD vector types} -* * -************************************************************************ --} - -#include "primop-vector-tys.hs-incl" diff --git a/prelude/TysWiredIn.hs b/prelude/TysWiredIn.hs deleted file mode 100644 --- a/prelude/TysWiredIn.hs +++ /dev/null @@ -1,1702 +0,0 @@ -{- -(c) The GRASP Project, Glasgow University, 1994-1998 - -\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - --- | This module is about types that can be defined in Haskell, but which --- must be wired into the compiler nonetheless. C.f module TysPrim -module TysWiredIn ( - -- * Helper functions defined here - mkWiredInTyConName, -- This is used in TcTypeNats to define the - -- built-in functions for evaluation. - - mkWiredInIdName, -- used in MkId - - -- * All wired in things - wiredInTyCons, isBuiltInOcc_maybe, - - -- * Bool - boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, - trueDataCon, trueDataConId, true_RDR, - falseDataCon, falseDataConId, false_RDR, - promotedFalseDataCon, promotedTrueDataCon, - - -- * Ordering - orderingTyCon, - ordLTDataCon, ordLTDataConId, - ordEQDataCon, ordEQDataConId, - ordGTDataCon, ordGTDataConId, - promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, - - -- * Boxing primitive types - boxingDataCon_maybe, - - -- * Char - charTyCon, charDataCon, charTyCon_RDR, - charTy, stringTy, charTyConName, - - -- * Double - doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, - - -- * Float - floatTyCon, floatDataCon, floatTy, floatTyConName, - - -- * Int - intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, - intTy, - - -- * Word - wordTyCon, wordDataCon, wordTyConName, wordTy, - - -- * Word8 - word8TyCon, word8DataCon, word8TyConName, word8Ty, - - -- * List - listTyCon, listTyCon_RDR, listTyConName, listTyConKey, - nilDataCon, nilDataConName, nilDataConKey, - consDataCon_RDR, consDataCon, consDataConName, - promotedNilDataCon, promotedConsDataCon, - mkListTy, mkPromotedListTy, - - -- * Maybe - maybeTyCon, maybeTyConName, - nothingDataCon, nothingDataConName, promotedNothingDataCon, - justDataCon, justDataConName, promotedJustDataCon, - - -- * Tuples - mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr, - tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName, - promotedTupleDataCon, - unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, - pairTyCon, - unboxedUnitTyCon, unboxedUnitDataCon, - unboxedTupleKind, unboxedSumKind, - - -- ** Constraint tuples - cTupleTyConName, cTupleTyConNames, isCTupleTyConName, - cTupleTyConNameArity_maybe, - cTupleDataConName, cTupleDataConNames, - - -- * Any - anyTyCon, anyTy, anyTypeOfKind, - - -- * Recovery TyCon - makeRecoveryTyCon, - - -- * Sums - mkSumTy, sumTyCon, sumDataCon, - - -- * Kinds - typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, - isLiftedTypeKindTyConName, liftedTypeKind, - typeToTypeKind, constraintKind, - liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName, - liftedTypeKindTyConName, - - -- * Equality predicates - heqTyCon, heqTyConName, heqClass, heqDataCon, - eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR, - coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, - - -- * RuntimeRep and friends - runtimeRepTyCon, vecCountTyCon, vecElemTyCon, - - runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, - - vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, - - liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, - int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, - wordRepDataConTy, - word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, - addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy, - - vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy, - - int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) - --- friends: -import PrelNames -import TysPrim -import {-# SOURCE #-} KnownUniques - --- others: -import CoAxiom -import Id -import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) -import Module ( Module ) -import Type -import RepType -import DataCon -import {-# SOURCE #-} ConLike -import TyCon -import Class ( Class, mkClass ) -import RdrName -import Name -import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) -import NameSet ( NameSet, mkNameSet, elemNameSet ) -import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ, - SourceText(..) ) -import ForeignCall -import SrcLoc ( noSrcSpan ) -import Unique -import Data.Array -import FastString -import Outputable -import Util -import BooleanFormula ( mkAnd ) - -import qualified Data.ByteString.Char8 as BS - -import Data.List ( elemIndex ) - -alpha_tyvar :: [TyVar] -alpha_tyvar = [alphaTyVar] - -alpha_ty :: [Type] -alpha_ty = [alphaTy] - -{- -Note [Wiring in RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, -making it a pain to wire in. To ease the pain somewhat, we use lists of -the different bits, like Uniques, Names, DataCons. These lists must be -kept in sync with each other. The rule is this: use the order as declared -in GHC.Types. All places where such lists exist should contain a reference -to this Note, so a search for this Note's name should find all the lists. - -See also Note [Getting from RuntimeRep to PrimRep] in RepType. - -************************************************************************ -* * -\subsection{Wired in type constructors} -* * -************************************************************************ - -If you change which things are wired in, make sure you change their -names in PrelNames, so they use wTcQual, wDataQual, etc --} - --- This list is used only to define PrelInfo.wiredInThings. That in turn --- is used to initialise the name environment carried around by the renamer. --- This means that if we look up the name of a TyCon (or its implicit binders) --- that occurs in this list that name will be assigned the wired-in key we --- define here. --- --- Because of their infinite nature, this list excludes --- * tuples, including boxed, unboxed and constraint tuples ---- (mkTupleTyCon, unitTyCon, pairTyCon) --- * unboxed sums (sumTyCon) --- See Note [Infinite families of known-key names] in GHC.Builtin.Names --- --- See also Note [Known-key names] -wiredInTyCons :: [TyCon] - -wiredInTyCons = [ -- Units are not treated like other tuples, because they - -- are defined in GHC.Base, and there's only a few of them. We - -- put them in wiredInTyCons so that they will pre-populate - -- the name cache, so the parser in isBuiltInOcc_maybe doesn't - -- need to look out for them. - unitTyCon - , unboxedUnitTyCon - , anyTyCon - , boolTyCon - , charTyCon - , doubleTyCon - , floatTyCon - , intTyCon - , wordTyCon - , word8TyCon - , listTyCon - , orderingTyCon - , maybeTyCon - , heqTyCon - , eqTyCon - , coercibleTyCon - , typeNatKindCon - , typeSymbolKindCon - , runtimeRepTyCon - , vecCountTyCon - , vecElemTyCon - , constraintKindTyCon - , liftedTypeKindTyCon - ] - -mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name -mkWiredInTyConName built_in modu fs unique tycon - = mkWiredInName modu (mkTcOccFS fs) unique - (ATyCon tycon) -- Relevant TyCon - built_in - -mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name -mkWiredInDataConName built_in modu fs unique datacon - = mkWiredInName modu (mkDataOccFS fs) unique - (AConLike (RealDataCon datacon)) -- Relevant DataCon - built_in - -mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name -mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax - --- See Note [Kind-changing of (~) and Coercible] --- in libraries/ghc-prim/GHC/Types.hs -eqTyConName, eqDataConName, eqSCSelIdName :: Name -eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon -eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon -eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId - -eqTyCon_RDR :: RdrName -eqTyCon_RDR = nameRdrName eqTyConName - --- See Note [Kind-changing of (~) and Coercible] --- in libraries/ghc-prim/GHC/Types.hs -heqTyConName, heqDataConName, heqSCSelIdName :: Name -heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon -heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon -heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId - --- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs -coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name -coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon -coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon -coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId - -charTyConName, charDataConName, intTyConName, intDataConName :: Name -charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon -charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon -intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon -intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon - -boolTyConName, falseDataConName, trueDataConName :: Name -boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon -falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon -trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon - -listTyConName, nilDataConName, consDataConName :: Name -listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon -nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon -consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - -maybeTyConName, nothingDataConName, justDataConName :: Name -maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe") - maybeTyConKey maybeTyCon -nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing") - nothingDataConKey nothingDataCon -justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just") - justDataConKey justDataCon - -wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name -wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon -wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon -word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon -word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon - -floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name -floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon -floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon -doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon -doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon - --- Any - -{- -Note [Any types] -~~~~~~~~~~~~~~~~ -The type constructor Any, - - type family Any :: k where { } - -It has these properties: - - * Note that 'Any' is kind polymorphic since in some program we may - need to use Any to fill in a type variable of some kind other than * - (see #959 for examples). Its kind is thus `forall k. k``. - - * It is defined in module GHC.Types, and exported so that it is - available to users. For this reason it's treated like any other - wired-in type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache - - * It is a *closed* type family, with no instances. This means that - if ty :: '(k1, k2) we add a given coercion - g :: ty ~ (Fst ty, Snd ty) - If Any was a *data* type, then we'd get inconsistency because 'ty' - could be (Any '(k1,k2)) and then we'd have an equality with Any on - one side and '(,) on the other. See also #9097 and #9636. - - * When instantiated at a lifted type it is inhabited by at least one value, - namely bottom - - * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. - - * It is wired-in so we can easily refer to it where we don't have a name - environment (e.g. see Rules.matchRule for one example) - - * If (Any k) is the type of a value, it must be a /lifted/ value. So - if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See - Note [TYPE and RuntimeRep] in TysPrim. This is a convenient - invariant, and makes isUnliftedTyCon well-defined; otherwise what - would (isUnliftedTyCon Any) be? - -It's used to instantiate un-constrained type variables after type checking. For -example, 'length' has type - - length :: forall a. [a] -> Int - -and the list datacon for the empty list has type - - [] :: forall a. [a] - -In order to compose these two terms as @length []@ a type -application is required, but there is no constraint on the -choice. In this situation GHC uses 'Any', - -> length (Any *) ([] (Any *)) - -Above, we print kinds explicitly, as if with --fprint-explicit-kinds. - -The Any tycon used to be quite magic, but we have since been able to -implement it merely with an empty kind polymorphic type family. See #10886 for a -bit of history. --} - - -anyTyConName :: Name -anyTyConName = - mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon - -anyTyCon :: TyCon -anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing - (ClosedSynFamilyTyCon Nothing) - Nothing - NotInjective - where - binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] - res_kind = mkTyVarTy (binderVar kv) - -anyTy :: Type -anyTy = mkTyConTy anyTyCon - -anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp anyTyCon [kind] - --- | Make a fake, recovery 'TyCon' from an existing one. --- Used when recovering from errors in type declarations -makeRecoveryTyCon :: TyCon -> TyCon -makeRecoveryTyCon tc - = mkTcTyCon (tyConName tc) - bndrs res_kind - noTcTyConScopedTyVars - True -- Fully generalised - flavour -- Keep old flavour - where - flavour = tyConFlavour tc - [kv] = mkTemplateKindVars [liftedTypeKind] - (bndrs, res_kind) - = case flavour of - PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv) - _ -> (tyConBinders tc, tyConResKind tc) - -- For data types we have already validated their kind, so it - -- makes sense to keep it. For promoted data constructors we haven't, - -- so we recover with kind (forall k. k). Otherwise consider - -- data T a where { MkT :: Show a => T a } - -- If T is for some reason invalid, we don't want to fall over - -- at (promoted) use-sites of MkT. - --- Kinds -typeNatKindConName, typeSymbolKindConName :: Name -typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon -typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon - -constraintKindTyConName :: Name -constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon - -liftedTypeKindTyConName :: Name -liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon - -runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name -runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon -vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon -tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon -sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon - --- See Note [Wiring in RuntimeRep] -runtimeRepSimpleDataConNames :: [Name] -runtimeRepSimpleDataConNames - = zipWith3Lazy mk_special_dc_name - [ fsLit "LiftedRep", fsLit "UnliftedRep" - , fsLit "IntRep" - , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep" - , fsLit "WordRep" - , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep" - , fsLit "AddrRep" - , fsLit "FloatRep", fsLit "DoubleRep" - ] - runtimeRepSimpleDataConKeys - runtimeRepSimpleDataCons - -vecCountTyConName :: Name -vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon - --- See Note [Wiring in RuntimeRep] -vecCountDataConNames :: [Name] -vecCountDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" - , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] - vecCountDataConKeys - vecCountDataCons - -vecElemTyConName :: Name -vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon - --- See Note [Wiring in RuntimeRep] -vecElemDataConNames :: [Name] -vecElemDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" - , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" - , fsLit "Word32ElemRep", fsLit "Word64ElemRep" - , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] - vecElemDataConKeys - vecElemDataCons - -mk_special_dc_name :: FastString -> Unique -> DataCon -> Name -mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc - -boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, - intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName -boolTyCon_RDR = nameRdrName boolTyConName -false_RDR = nameRdrName falseDataConName -true_RDR = nameRdrName trueDataConName -intTyCon_RDR = nameRdrName intTyConName -charTyCon_RDR = nameRdrName charTyConName -intDataCon_RDR = nameRdrName intDataConName -listTyCon_RDR = nameRdrName listTyConName -consDataCon_RDR = nameRdrName consDataConName - -{- -************************************************************************ -* * -\subsection{mkWiredInTyCon} -* * -************************************************************************ --} - --- This function assumes that the types it creates have all parameters at --- Representational role, and that there is no kind polymorphism. -pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon -pcTyCon name cType tyvars cons - = mkAlgTyCon name - (mkAnonTyConBinders VisArg tyvars) - liftedTypeKind - (map (const Representational) tyvars) - cType - [] -- No stupid theta - (mkDataTyConRhs cons) - (VanillaAlgTyCon (mkPrelTyConRepName name)) - False -- Not in GADT syntax - -pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon n univs = pcDataConWithFixity False n univs - [] -- no ex_tvs - univs -- the univs are precisely the user-written tyvars - -pcDataConWithFixity :: Bool -- ^ declared infix? - -> Name -- ^ datacon name - -> [TyVar] -- ^ univ tyvars - -> [TyCoVar] -- ^ ex tycovars - -> [TyCoVar] -- ^ user-written tycovars - -> [Type] -- ^ args - -> TyCon - -> DataCon -pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n)) - NoRRI --- The Name's unique is the first of two free uniques; --- the first is used for the datacon itself, --- the second is used for the "worker name" --- --- To support this the mkPreludeDataConUnique function "allocates" --- one DataCon unique per pair of Ints. - -pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo - -> [TyVar] -> [TyCoVar] -> [TyCoVar] - -> [Type] -> TyCon -> DataCon --- The Name should be in the DataName name space; it's the name --- of the DataCon itself. - -pcDataConWithFixity' declared_infix dc_name wrk_key rri - tyvars ex_tyvars user_tyvars arg_tys tycon - = data_con - where - tag_map = mkTyConTagMap tycon - -- This constructs the constructor Name to ConTag map once per - -- constructor, which is quadratic. It's OK here, because it's - -- only called for wired in data types that don't have a lot of - -- constructors. It's also likely that GHC will lift tag_map, since - -- we call pcDataConWithFixity' with static TyCons in the same module. - -- See Note [Constructor tag allocation] and #14657 - data_con = mkDataCon dc_name declared_infix prom_info - (map (const no_bang) arg_tys) - [] -- No labelled fields - tyvars ex_tyvars - (mkTyCoVarBinders Specified user_tyvars) - [] -- No equality spec - [] -- No theta - arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) - rri - tycon - (lookupNameEnv_NF tag_map dc_name) - [] -- No stupid theta - (mkDataConWorkId wrk_name data_con) - NoDataConRep -- Wired-in types are too simple to need wrappers - - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - wrk_name = mkDataConWorkerName data_con wrk_key - - prom_info = mkPrelTyConRepName dc_name - -mkDataConWorkerName :: DataCon -> Unique -> Name -mkDataConWorkerName data_con wrk_key = - mkWiredInName modu wrk_occ wrk_key - (AnId (dataConWorkId data_con)) UserSyntax - where - modu = ASSERT( isExternalName dc_name ) - nameModule dc_name - dc_name = dataConName data_con - dc_occ = nameOccName dc_name - wrk_occ = mkDataConWorkerOcc dc_occ - --- used for RuntimeRep and friends -pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon -pcSpecialDataCon dc_name arg_tys tycon rri - = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri - [] [] [] arg_tys tycon - -{- -************************************************************************ -* * - Kinds -* * -************************************************************************ --} - -typeNatKindCon, typeSymbolKindCon :: TyCon --- data Nat --- data Symbol -typeNatKindCon = pcTyCon typeNatKindConName Nothing [] [] -typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] - -typeNatKind, typeSymbolKind :: Kind -typeNatKind = mkTyConTy typeNatKindCon -typeSymbolKind = mkTyConTy typeSymbolKindCon - -constraintKindTyCon :: TyCon -constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] - -liftedTypeKind, typeToTypeKind, constraintKind :: Kind -liftedTypeKind = tYPE liftedRepTy -typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind -constraintKind = mkTyConApp constraintKindTyCon [] - -{- -************************************************************************ -* * - Stuff for dealing with tuples -* * -************************************************************************ - -Note [How tuples work] See also Note [Known-key names] in PrelNames -~~~~~~~~~~~~~~~~~~~~~~ -* There are three families of tuple TyCons and corresponding - DataCons, expressed by the type BasicTypes.TupleSort: - data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple - -* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon - -* BoxedTuples - - A wired-in type - - Data type declarations in GHC.Tuple - - The data constructors really have an info table - -* UnboxedTuples - - A wired-in type - - Have a pretend DataCon, defined in GHC.Prim, - but no actual declaration and no info table - -* ConstraintTuples - - Are known-key rather than wired-in. Reason: it's awkward to - have all the superclass selectors wired-in. - - Declared as classes in GHC.Classes, e.g. - class (c1,c2) => (c1,c2) - - Given constraints: the superclasses automatically become available - - Wanted constraints: there is a built-in instance - instance (c1,c2) => (c1,c2) - See TcInteract.matchCTuple - - Currently just go up to 62; beyond that - you have to use manual nesting - - Their OccNames look like (%,,,%), so they can easily be - distinguished from term tuples. But (following Haskell) we - pretty-print saturated constraint tuples with round parens; - see BasicTypes.tupleParens. - -* In quite a lot of places things are restrcted just to - BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish - E.g. tupleTyCon has a Boxity argument - -* When looking up an OccName in the original-name cache - (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure - we get the right wired-in name. This guy can't tell the difference - between BoxedTuple and ConstraintTuple (same OccName!), so tuples - are not serialised into interface files using OccNames at all. - -* Serialization to interface files works via the usual mechanism for known-key - things: instead of serializing the OccName we just serialize the key. During - deserialization we lookup the Name associated with the unique with the logic - in KnownUniques. See Note [Symbol table representation of names] for details. - -Note [One-tuples] -~~~~~~~~~~~~~~~~~ -GHC supports both boxed and unboxed one-tuples: - - Unboxed one-tuples are sometimes useful when returning a - single value after CPR analysis - - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when - there is just one binder -Basically it keeps everythig uniform. - -However the /naming/ of the type/data constructors for one-tuples is a -bit odd: - 3-tuples: (,,) (,,)# - 2-tuples: (,) (,)# - 1-tuples: ?? - 0-tuples: () ()# - -Zero-tuples have used up the logical name. So we use 'Unit' and 'Unit#' -for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: - data () = () - data Unit a = Unit a - data (a,b) = (a,b) - -There is no way to write a boxed one-tuple in Haskell using tuple syntax. -They can, however, be written using other methods: - -1. They can be written directly by importing them from GHC.Tuple. -2. They can be generated by way of Template Haskell or in `deriving` code. - -There is nothing special about one-tuples in Core; in particular, they have no -custom pretty-printing, just using `Unit`. - -Note that there is *not* a unary constraint tuple, unlike for other forms of -tuples. See [Ignore unary constraint tuples] in TcHsType for more -details. - -See also Note [Flattening one-tuples] in MkCore and -Note [Don't flatten tuples from HsSyn] in MkCore. - ------ --- Wrinkle: Make boxed one-tuple names have known keys ------ - -We make boxed one-tuple names have known keys so that `data Unit a = Unit a`, -defined in GHC.Tuple, will be used when one-tuples are spliced in through -Template Haskell. This program (from #18097) crucially relies on this: - - case $( tupE [ [| "ok" |] ] ) of Unit x -> putStrLn x - -Unless Unit has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an -ExplicitTuple of length 1) will not match the type of Unit (an ordinary -data constructor used in a pattern). Making Unit known-key allows GHC to make -this connection. - -Unlike Unit, every other tuple is /not/ known-key -(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The -main reason for this exception is that other tuples are written with special -syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe` -function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache). -In contrast, Unit is just an ordinary data type with no special syntax, so it -doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Unit -known-key is the next-best way to teach the internals of the compiler about it. --} - --- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names --- with BuiltInSyntax. However, this should only be necessary while resolving --- names produced by Template Haskell splices since we take care to encode --- built-in syntax names specially in interface files. See --- Note [Symbol table representation of names]. --- --- Moreover, there is no need to include names of things that the user can't --- write (e.g. type representation bindings like $tc(,,,)). -isBuiltInOcc_maybe :: OccName -> Maybe Name -isBuiltInOcc_maybe occ = - case name of - "[]" -> Just $ choose_ns listTyConName nilDataConName - ":" -> Just consDataConName - - -- equality tycon - "~" -> Just eqTyConName - - -- function tycon - "->" -> Just funTyConName - - -- boxed tuple data/tycon - -- We deliberately exclude Unit (the boxed 1-tuple). - -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) - "()" -> Just $ tup_name Boxed 0 - _ | Just rest <- "(" `BS.stripPrefix` name - , (commas, rest') <- BS.span (==',') rest - , ")" <- rest' - -> Just $ tup_name Boxed (1+BS.length commas) - - -- unboxed tuple data/tycon - "(##)" -> Just $ tup_name Unboxed 0 - "Unit#" -> Just $ tup_name Unboxed 1 - _ | Just rest <- "(#" `BS.stripPrefix` name - , (commas, rest') <- BS.span (==',') rest - , "#)" <- rest' - -> Just $ tup_name Unboxed (1+BS.length commas) - - -- unboxed sum tycon - _ | Just rest <- "(#" `BS.stripPrefix` name - , (pipes, rest') <- BS.span (=='|') rest - , "#)" <- rest' - -> Just $ tyConName $ sumTyCon (1+BS.length pipes) - - -- unboxed sum datacon - _ | Just rest <- "(#" `BS.stripPrefix` name - , (pipes1, rest') <- BS.span (=='|') rest - , Just rest'' <- "_" `BS.stripPrefix` rest' - , (pipes2, rest''') <- BS.span (=='|') rest'' - , "#)" <- rest''' - -> let arity = BS.length pipes1 + BS.length pipes2 + 1 - alt = BS.length pipes1 + 1 - in Just $ dataConName $ sumDataCon alt arity - _ -> Nothing - where - name = bytesFS $ occNameFS occ - - choose_ns :: Name -> Name -> Name - choose_ns tc dc - | isTcClsNameSpace ns = tc - | isDataConNameSpace ns = dc - | otherwise = pprPanic "tup_name" (ppr occ) - where ns = occNameSpace occ - - tup_name boxity arity - = choose_ns (getName (tupleTyCon boxity arity)) - (getName (tupleDataCon boxity arity)) - -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName --- No need to cache these, the caching is done in mk_tuple -mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar) -mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar) - -mkCTupleOcc :: NameSpace -> Arity -> OccName -mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) - -mkTupleStr :: Boxity -> Arity -> String -mkTupleStr Boxed = mkBoxedTupleStr -mkTupleStr Unboxed = mkUnboxedTupleStr - -mkBoxedTupleStr :: Arity -> String -mkBoxedTupleStr 0 = "()" -mkBoxedTupleStr 1 = "Unit" -- See Note [One-tuples] -mkBoxedTupleStr ar = '(' : commas ar ++ ")" - -mkUnboxedTupleStr :: Arity -> String -mkUnboxedTupleStr 0 = "(##)" -mkUnboxedTupleStr 1 = "Unit#" -- See Note [One-tuples] -mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)" - -mkConstraintTupleStr :: Arity -> String -mkConstraintTupleStr 0 = "(%%)" -mkConstraintTupleStr 1 = "Unit%" -- See Note [One-tuples] -mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)" - -commas :: Arity -> String -commas ar = take (ar-1) (repeat ',') - -cTupleTyConName :: Arity -> Name -cTupleTyConName arity - = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES - (mkCTupleOcc tcName arity) noSrcSpan - -cTupleTyConNames :: [Name] -cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) - -cTupleTyConNameSet :: NameSet -cTupleTyConNameSet = mkNameSet cTupleTyConNames - -isCTupleTyConName :: Name -> Bool --- Use Type.isCTupleClass where possible -isCTupleTyConName n - = ASSERT2( isExternalName n, ppr n ) - nameModule n == gHC_CLASSES - && n `elemNameSet` cTupleTyConNameSet - --- | If the given name is that of a constraint tuple, return its arity. --- Note that this is inefficient. -cTupleTyConNameArity_maybe :: Name -> Maybe Arity -cTupleTyConNameArity_maybe n - | not (isCTupleTyConName n) = Nothing - | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames) - where - -- Since `cTupleTyConNames` jumps straight from the `0` to the `2` - -- case, we have to adjust accordingly our calculated arity. - adjustArity a = if a > 0 then a + 1 else a - -cTupleDataConName :: Arity -> Name -cTupleDataConName arity - = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES - (mkCTupleOcc dataName arity) noSrcSpan - -cTupleDataConNames :: [Name] -cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) - -tupleTyCon :: Boxity -> Arity -> TyCon -tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially -tupleTyCon Boxed i = fst (boxedTupleArr ! i) -tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) - -tupleTyConName :: TupleSort -> Arity -> Name -tupleTyConName ConstraintTuple a = cTupleTyConName a -tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) -tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) - -promotedTupleDataCon :: Boxity -> Arity -> TyCon -promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) - -tupleDataCon :: Boxity -> Arity -> DataCon -tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially -tupleDataCon Boxed i = snd (boxedTupleArr ! i) -tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) - -tupleDataConName :: Boxity -> Arity -> Name -tupleDataConName sort i = dataConName (tupleDataCon sort i) - -boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) -boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] -unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] - --- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed --- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type --- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep --- [IntRep, LiftedRep])@ -unboxedTupleSumKind :: TyCon -> [Type] -> Kind -unboxedTupleSumKind tc rr_tys - = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) - --- | Specialization of 'unboxedTupleSumKind' for tuples -unboxedTupleKind :: [Type] -> Kind -unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon - -mk_tuple :: Boxity -> Int -> (TyCon,DataCon) -mk_tuple Boxed arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con - BoxedTuple flavour - - tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) - tc_res_kind = liftedTypeKind - tc_arity = arity - flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) - - dc_tvs = binderVars tc_binders - dc_arg_tys = mkTyVarTys dc_tvs - tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon - - boxity = Boxed - modu = gHC_TUPLE - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity - -mk_tuple Unboxed arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con - UnboxedTuple flavour - - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> # - tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) - (\ks -> map tYPE ks) - - tc_res_kind = unboxedTupleKind rr_tys - - tc_arity = arity * 2 - flavour = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name) - - dc_tvs = binderVars tc_binders - (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) - tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon - - boxity = Unboxed - modu = gHC_PRIM - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity - -unitTyCon :: TyCon -unitTyCon = tupleTyCon Boxed 0 - -unitTyConKey :: Unique -unitTyConKey = getUnique unitTyCon - -unitDataCon :: DataCon -unitDataCon = head (tyConDataCons unitTyCon) - -unitDataConId :: Id -unitDataConId = dataConWorkId unitDataCon - -pairTyCon :: TyCon -pairTyCon = tupleTyCon Boxed 2 - -unboxedUnitTyCon :: TyCon -unboxedUnitTyCon = tupleTyCon Unboxed 0 - -unboxedUnitDataCon :: DataCon -unboxedUnitDataCon = tupleDataCon Unboxed 0 - - -{- ********************************************************************* -* * - Unboxed sums -* * -********************************************************************* -} - --- | OccName for n-ary unboxed sum type constructor. -mkSumTyConOcc :: Arity -> OccName -mkSumTyConOcc n = mkOccName tcName str - where - -- No need to cache these, the caching is done in mk_sum - str = '(' : '#' : bars ++ "#)" - bars = replicate (n-1) '|' - --- | OccName for i-th alternative of n-ary unboxed sum data constructor. -mkSumDataConOcc :: ConTag -> Arity -> OccName -mkSumDataConOcc alt n = mkOccName dataName str - where - -- No need to cache these, the caching is done in mk_sum - str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)" - bars i = replicate i '|' - --- | Type constructor for n-ary unboxed sum. -sumTyCon :: Arity -> TyCon -sumTyCon arity - | arity > mAX_SUM_SIZE - = fst (mk_sum arity) -- Build one specially - - | arity < 2 - = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") - - | otherwise - = fst (unboxedSumArr ! arity) - --- | Data constructor for i-th alternative of a n-ary unboxed sum. -sumDataCon :: ConTag -- Alternative - -> Arity -- Arity - -> DataCon -sumDataCon alt arity - | alt > arity - = panic ("sumDataCon: index out of bounds: alt: " - ++ show alt ++ " > arity " ++ show arity) - - | alt <= 0 - = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt - ++ ", arity: " ++ show arity ++ ")") - - | arity < 2 - = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt - ++ ", arity: " ++ show arity ++ ")") - - | arity > mAX_SUM_SIZE - = snd (mk_sum arity) ! (alt - 1) -- Build one specially - - | otherwise - = snd (unboxedSumArr ! arity) ! (alt - 1) - --- | Cached type and data constructors for sums. The outer array is --- indexed by the arity of the sum and the inner array is indexed by --- the alternative. -unboxedSumArr :: Array Int (TyCon, Array Int DataCon) -unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] - --- | Specialization of 'unboxedTupleSumKind' for sums -unboxedSumKind :: [Type] -> Kind -unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon - --- | Create type constructor and data constructors for n-ary unboxed sum. -mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) -mk_sum arity = (tycon, sum_cons) - where - tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) - (UnboxedAlgTyCon rep_name) - - -- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276. - rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name - - tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) - (\ks -> map tYPE ks) - - tyvars = binderVars tc_binders - - tc_res_kind = unboxedSumKind rr_tys - - (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars) - - tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - - sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] - sum_con i = let dc = pcDataCon dc_name - tyvars -- univ tyvars - [tyvar_tys !! i] -- arg types - tycon - - dc_name = mkWiredInName gHC_PRIM - (mkSumDataConOcc i arity) - (dc_uniq i) - (AConLike (RealDataCon dc)) - BuiltInSyntax - in dc - - tc_uniq = mkSumTyConUnique arity - dc_uniq i = mkSumDataConUnique i arity - -{- -************************************************************************ -* * - Equality types and classes -* * -********************************************************************* -} - --- See Note [The equality types story] in TysPrim --- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) --- --- It's tempting to put functional dependencies on (~~), but it's not --- necessary because the functional-dependency coverage check looks --- through superclasses, and (~#) is handled in that check. - -eqTyCon, heqTyCon, coercibleTyCon :: TyCon -eqClass, heqClass, coercibleClass :: Class -eqDataCon, heqDataCon, coercibleDataCon :: DataCon -eqSCSelId, heqSCSelId, coercibleSCSelId :: Id - -(eqTyCon, eqClass, eqDataCon, eqSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon eqTyConName binders roles - rhs klass - (mkPrelTyConRepName eqTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon eqDataConName tvs [sc_pred] tycon - - -- Kind: forall k. k -> k -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) - roles = [Nominal, Nominal, Nominal] - rhs = mkDataTyConRhs [datacon] - - tvs@[k,a,b] = binderVars binders - sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b]) - sc_sel_id = mkDictSelId eqSCSelIdName klass - -(heqTyCon, heqClass, heqDataCon, heqSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon heqTyConName binders roles - rhs klass - (mkPrelTyConRepName heqTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon heqDataConName tvs [sc_pred] tycon - - -- Kind: forall k1 k2. k1 -> k2 -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - roles = [Nominal, Nominal, Nominal, Nominal] - rhs = mkDataTyConRhs [datacon] - - tvs = binderVars binders - sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) - sc_sel_id = mkDictSelId heqSCSelIdName klass - -(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon coercibleTyConName binders roles - rhs klass - (mkPrelTyConRepName coercibleTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon - - -- Kind: forall k. k -> k -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) - roles = [Nominal, Representational, Representational] - rhs = mkDataTyConRhs [datacon] - - tvs@[k,a,b] = binderVars binders - sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) - sc_sel_id = mkDictSelId coercibleSCSelIdName klass - -mk_class :: TyCon -> PredType -> Id -> Class -mk_class tycon sc_pred sc_sel_id - = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] - [] [] (mkAnd []) tycon - - - -{- ********************************************************************* -* * - Kinds and RuntimeRep -* * -********************************************************************* -} - --- For information about the usage of the following type, --- see Note [TYPE and RuntimeRep] in module TysPrim -runtimeRepTy :: Type -runtimeRepTy = mkTyConTy runtimeRepTyCon - --- Type synonyms; see Note [TYPE and RuntimeRep] in TysPrim --- type Type = tYPE 'LiftedRep -liftedTypeKindTyCon :: TyCon -liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName - [] liftedTypeKind [] - (tYPE liftedRepTy) - -runtimeRepTyCon :: TyCon -runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] - (vecRepDataCon : tupleRepDataCon : - sumRepDataCon : runtimeRepSimpleDataCons) - -vecRepDataCon :: DataCon -vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon - , mkTyConTy vecElemTyCon ] - runtimeRepTyCon - (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in RepType - prim_rep_fun [count, elem] - | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) - , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) - = [VecRep n e] - prim_rep_fun args - = pprPanic "vecRepDataCon" (ppr args) - -vecRepDataConTyCon :: TyCon -vecRepDataConTyCon = promoteDataCon vecRepDataCon - -tupleRepDataCon :: DataCon -tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in RepType - prim_rep_fun [rr_ty_list] - = concatMap (runtimeRepPrimRep doc) rr_tys - where - rr_tys = extractPromotedList rr_ty_list - doc = text "tupleRepDataCon" <+> ppr rr_tys - prim_rep_fun args - = pprPanic "tupleRepDataCon" (ppr args) - -tupleRepDataConTyCon :: TyCon -tupleRepDataConTyCon = promoteDataCon tupleRepDataCon - -sumRepDataCon :: DataCon -sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in RepType - prim_rep_fun [rr_ty_list] - = map slotPrimRep (ubxSumRepType prim_repss) - where - rr_tys = extractPromotedList rr_ty_list - doc = text "sumRepDataCon" <+> ppr rr_tys - prim_repss = map (runtimeRepPrimRep doc) rr_tys - prim_rep_fun args - = pprPanic "sumRepDataCon" (ppr args) - -sumRepDataConTyCon :: TyCon -sumRepDataConTyCon = promoteDataCon sumRepDataCon - --- See Note [Wiring in RuntimeRep] --- See Note [Getting from RuntimeRep to PrimRep] in RepType -runtimeRepSimpleDataCons :: [DataCon] -liftedRepDataCon :: DataCon -runtimeRepSimpleDataCons@(liftedRepDataCon : _) - = zipWithLazy mk_runtime_rep_dc - [ LiftedRep, UnliftedRep - , IntRep - , Int8Rep, Int16Rep, Int32Rep, Int64Rep - , WordRep - , Word8Rep, Word16Rep, Word32Rep, Word64Rep - , AddrRep - , FloatRep, DoubleRep - ] - runtimeRepSimpleDataConNames - where - mk_runtime_rep_dc primrep name - = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) - --- See Note [Wiring in RuntimeRep] -liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, - int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, - wordRepDataConTy, - word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, - addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type -[liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, - int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, - wordRepDataConTy, - word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, - addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy - ] - = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons - -vecCountTyCon :: TyCon -vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons - --- See Note [Wiring in RuntimeRep] -vecCountDataCons :: [DataCon] -vecCountDataCons = zipWithLazy mk_vec_count_dc - [ 2, 4, 8, 16, 32, 64 ] - vecCountDataConNames - where - mk_vec_count_dc n name - = pcSpecialDataCon name [] vecCountTyCon (VecCount n) - --- See Note [Wiring in RuntimeRep] -vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy :: Type -[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons - -vecElemTyCon :: TyCon -vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons - --- See Note [Wiring in RuntimeRep] -vecElemDataCons :: [DataCon] -vecElemDataCons = zipWithLazy mk_vec_elem_dc - [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep - , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep - , FloatElemRep, DoubleElemRep ] - vecElemDataConNames - where - mk_vec_elem_dc elem name - = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) - --- See Note [Wiring in RuntimeRep] -int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy :: Type -[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) - vecElemDataCons - -liftedRepDataConTyCon :: TyCon -liftedRepDataConTyCon = promoteDataCon liftedRepDataCon - --- The type ('LiftedRep) -liftedRepTy :: Type -liftedRepTy = liftedRepDataConTy - -{- ********************************************************************* -* * - The boxed primitive types: Char, Int, etc -* * -********************************************************************* -} - -boxingDataCon_maybe :: TyCon -> Maybe DataCon --- boxingDataCon_maybe Char# = C# --- boxingDataCon_maybe Int# = I# --- ... etc ... --- See Note [Boxing primitive types] -boxingDataCon_maybe tc - = lookupNameEnv boxing_constr_env (tyConName tc) - -boxing_constr_env :: NameEnv DataCon -boxing_constr_env - = mkNameEnv [(charPrimTyConName , charDataCon ) - ,(intPrimTyConName , intDataCon ) - ,(wordPrimTyConName , wordDataCon ) - ,(floatPrimTyConName , floatDataCon ) - ,(doublePrimTyConName, doubleDataCon) ] - -{- Note [Boxing primitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a handful of primitive types (Int, Char, Word, Flaot, Double), -we can readily box and an unboxed version (Int#, Char# etc) using -the corresponding data constructor. This is useful in a couple -of places, notably let-floating -} - - -charTy :: Type -charTy = mkTyConTy charTyCon - -charTyCon :: TyCon -charTyCon = pcTyCon charTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsChar"))) - [] [charDataCon] -charDataCon :: DataCon -charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon - -stringTy :: Type -stringTy = mkListTy charTy -- convenience only - -intTy :: Type -intTy = mkTyConTy intTyCon - -intTyCon :: TyCon -intTyCon = pcTyCon intTyConName - (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) - [] [intDataCon] -intDataCon :: DataCon -intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon - -wordTy :: Type -wordTy = mkTyConTy wordTyCon - -wordTyCon :: TyCon -wordTyCon = pcTyCon wordTyConName - (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) - [] [wordDataCon] -wordDataCon :: DataCon -wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon - -word8Ty :: Type -word8Ty = mkTyConTy word8TyCon - -word8TyCon :: TyCon -word8TyCon = pcTyCon word8TyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsWord8"))) [] - [word8DataCon] -word8DataCon :: DataCon -word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon - -floatTy :: Type -floatTy = mkTyConTy floatTyCon - -floatTyCon :: TyCon -floatTyCon = pcTyCon floatTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsFloat"))) [] - [floatDataCon] -floatDataCon :: DataCon -floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon - -doubleTy :: Type -doubleTy = mkTyConTy doubleTyCon - -doubleTyCon :: TyCon -doubleTyCon = pcTyCon doubleTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsDouble"))) [] - [doubleDataCon] - -doubleDataCon :: DataCon -doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon - -{- -************************************************************************ -* * - The Bool type -* * -************************************************************************ - -An ordinary enumeration type, but deeply wired in. There are no -magical operations on @Bool@ (just the regular Prelude code). - -{\em BEGIN IDLE SPECULATION BY SIMON} - -This is not the only way to encode @Bool@. A more obvious coding makes -@Bool@ just a boxed up version of @Bool#@, like this: -\begin{verbatim} -type Bool# = Int# -data Bool = MkBool Bool# -\end{verbatim} - -Unfortunately, this doesn't correspond to what the Report says @Bool@ -looks like! Furthermore, we get slightly less efficient code (I -think) with this coding. @gtInt@ would look like this: - -\begin{verbatim} -gtInt :: Int -> Int -> Bool -gtInt x y = case x of I# x# -> - case y of I# y# -> - case (gtIntPrim x# y#) of - b# -> MkBool b# -\end{verbatim} - -Notice that the result of the @gtIntPrim@ comparison has to be turned -into an integer (here called @b#@), and returned in a @MkBool@ box. - -The @if@ expression would compile to this: -\begin{verbatim} -case (gtInt x y) of - MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } -\end{verbatim} - -I think this code is a little less efficient than the previous code, -but I'm not certain. At all events, corresponding with the Report is -important. The interesting thing is that the language is expressive -enough to describe more than one alternative; and that a type doesn't -necessarily need to be a straightforwardly boxed version of its -primitive counterpart. - -{\em END IDLE SPECULATION BY SIMON} --} - -boolTy :: Type -boolTy = mkTyConTy boolTyCon - -boolTyCon :: TyCon -boolTyCon = pcTyCon boolTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsBool"))) - [] [falseDataCon, trueDataCon] - -falseDataCon, trueDataCon :: DataCon -falseDataCon = pcDataCon falseDataConName [] [] boolTyCon -trueDataCon = pcDataCon trueDataConName [] [] boolTyCon - -falseDataConId, trueDataConId :: Id -falseDataConId = dataConWorkId falseDataCon -trueDataConId = dataConWorkId trueDataCon - -orderingTyCon :: TyCon -orderingTyCon = pcTyCon orderingTyConName Nothing - [] [ordLTDataCon, ordEQDataCon, ordGTDataCon] - -ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon -ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon -ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon -ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon - -ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id -ordLTDataConId = dataConWorkId ordLTDataCon -ordEQDataConId = dataConWorkId ordEQDataCon -ordGTDataConId = dataConWorkId ordGTDataCon - -{- -************************************************************************ -* * - The List type - Special syntax, deeply wired in, - but otherwise an ordinary algebraic data type -* * -************************************************************************ - - data [] a = [] | a : (List a) --} - -mkListTy :: Type -> Type -mkListTy ty = mkTyConApp listTyCon [ty] - -listTyCon :: TyCon -listTyCon = - buildAlgTyCon listTyConName alpha_tyvar [Representational] - Nothing [] - (mkDataTyConRhs [nilDataCon, consDataCon]) - False - (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName) - --- See also Note [Empty lists] in GHC.Hs.Expr. -nilDataCon :: DataCon -nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon - -consDataCon :: DataCon -consDataCon = pcDataConWithFixity True {- Declared infix -} - consDataConName - alpha_tyvar [] alpha_tyvar - [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon --- Interesting: polymorphic recursion would help here. --- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy --- gets the over-specific type (Type -> Type) - --- Wired-in type Maybe - -maybeTyCon :: TyCon -maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar - [nothingDataCon, justDataCon] - -nothingDataCon :: DataCon -nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon - -justDataCon :: DataCon -justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon - -{- -** ********************************************************************* -* * - The tuple types -* * -************************************************************************ - -The tuple types are definitely magic, because they form an infinite -family. - -\begin{itemize} -\item -They have a special family of type constructors, of type @TyCon@ -These contain the tycon arity, but don't require a Unique. - -\item -They have a special family of constructors, of type -@Id@. Again these contain their arity but don't need a Unique. - -\item -There should be a magic way of generating the info tables and -entry code for all tuples. - -But at the moment we just compile a Haskell source -file\srcloc{lib/prelude/...} containing declarations like: -\begin{verbatim} -data Tuple0 = Tup0 -data Tuple2 a b = Tup2 a b -data Tuple3 a b c = Tup3 a b c -data Tuple4 a b c d = Tup4 a b c d -... -\end{verbatim} -The print-names associated with the magic @Id@s for tuple constructors -``just happen'' to be the same as those generated by these -declarations. - -\item -The instance environment should have a magic way to know -that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and -so on. \ToDo{Not implemented yet.} - -\item -There should also be a way to generate the appropriate code for each -of these instances, but (like the info tables and entry code) it is -done by enumeration\srcloc{lib/prelude/InTup?.hs}. -\end{itemize} --} - --- | Make a tuple type. The list of types should /not/ include any --- RuntimeRep specifications. Boxed 1-tuples are flattened. --- See Note [One-tuples] -mkTupleTy :: Boxity -> [Type] -> Type --- Special case for *boxed* 1-tuples, which are represented by the type itself -mkTupleTy Boxed [ty] = ty -mkTupleTy boxity tys = mkTupleTy1 boxity tys - --- | Make a tuple type. The list of types should /not/ include any --- RuntimeRep specifications. Boxed 1-tuples are *not* flattened. --- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn] --- in MkCore -mkTupleTy1 :: Boxity -> [Type] -> Type -mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys -mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) - (map getRuntimeRep tys ++ tys) - --- | Build the type of a small tuple that holds the specified type of thing --- Flattens 1-tuples. See Note [One-tuples]. -mkBoxedTupleTy :: [Type] -> Type -mkBoxedTupleTy tys = mkTupleTy Boxed tys - -unitTy :: Type -unitTy = mkTupleTy Boxed [] - -{- ********************************************************************* -* * - The sum types -* * -************************************************************************ --} - -mkSumTy :: [Type] -> Type -mkSumTy tys = mkTyConApp (sumTyCon (length tys)) - (map getRuntimeRep tys ++ tys) - --- Promoted Booleans - -promotedFalseDataCon, promotedTrueDataCon :: TyCon -promotedTrueDataCon = promoteDataCon trueDataCon -promotedFalseDataCon = promoteDataCon falseDataCon - --- Promoted Maybe -promotedNothingDataCon, promotedJustDataCon :: TyCon -promotedNothingDataCon = promoteDataCon nothingDataCon -promotedJustDataCon = promoteDataCon justDataCon - --- Promoted Ordering - -promotedLTDataCon - , promotedEQDataCon - , promotedGTDataCon - :: TyCon -promotedLTDataCon = promoteDataCon ordLTDataCon -promotedEQDataCon = promoteDataCon ordEQDataCon -promotedGTDataCon = promoteDataCon ordGTDataCon - --- Promoted List -promotedConsDataCon, promotedNilDataCon :: TyCon -promotedConsDataCon = promoteDataCon consDataCon -promotedNilDataCon = promoteDataCon nilDataCon - --- | Make a *promoted* list. -mkPromotedListTy :: Kind -- ^ of the elements of the list - -> [Type] -- ^ elements - -> Type -mkPromotedListTy k tys - = foldr cons nil tys - where - cons :: Type -- element - -> Type -- list - -> Type - cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] - - nil :: Type - nil = mkTyConApp promotedNilDataCon [k] - --- | Extract the elements of a promoted list. Panics if the type is not a --- promoted list -extractPromotedList :: Type -- ^ The promoted list - -> [Type] -extractPromotedList tys = go tys - where - go list_ty - | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty - = ASSERT( tc `hasKey` consDataConKey ) - t : go ts - - | Just (tc, [_k]) <- splitTyConApp_maybe list_ty - = ASSERT( tc `hasKey` nilDataConKey ) - [] - - | otherwise - = pprPanic "extractPromotedList" (ppr tys) diff --git a/prelude/TysWiredIn.hs-boot b/prelude/TysWiredIn.hs-boot deleted file mode 100644 --- a/prelude/TysWiredIn.hs-boot +++ /dev/null @@ -1,48 +0,0 @@ -module TysWiredIn where - -import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TyCoRep (Type, Kind) - -import BasicTypes (Arity, TupleSort) -import Name (Name) -import Unique (Unique) - -listTyCon :: TyCon -typeNatKind, typeSymbolKind :: Type -mkBoxedTupleTy :: [Type] -> Type - -coercibleTyCon, heqTyCon :: TyCon - -unitTy :: Type - -liftedTypeKind :: Kind -constraintKind :: Kind - -runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon -runtimeRepTy :: Type - -liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon - -liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, - int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, - wordRepDataConTy, - word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, - addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type - -vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy :: Type - -int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy :: Type - -anyTypeOfKind :: Kind -> Type -unboxedTupleKind :: [Type] -> Type -mkPromotedListTy :: Type -> [Type] -> Type - -tupleTyConName :: TupleSort -> Arity -> Name - -unitTyConKey :: Unique diff --git a/profiling/CostCentre.hs b/profiling/CostCentre.hs deleted file mode 100644 --- a/profiling/CostCentre.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module CostCentre ( - CostCentre(..), CcName, CCFlavour(..), - -- All abstract except to friend: ParseIface.y - - CostCentreStack, - CollectedCCs, emptyCollectedCCs, collectCC, - currentCCS, dontCareCCS, - isCurrentCCS, - maybeSingletonCCS, - - mkUserCC, mkAutoCC, mkAllCafsCC, - mkSingletonCCS, - isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, - - pprCostCentreCore, - costCentreUserName, costCentreUserNameFS, - costCentreSrcSpan, - - cmpCostCentre -- used for removing dups in a list - ) where - -import GhcPrelude - -import Binary -import Var -import Name -import Module -import Unique -import Outputable -import SrcLoc -import FastString -import Util -import CostCentreState - -import Data.Data - ------------------------------------------------------------------------------ --- Cost Centres - --- | A Cost Centre is a single @{-# SCC #-}@ annotation. - -data CostCentre - = NormalCC { - cc_flavour :: CCFlavour, - -- ^ Two cost centres may have the same name and - -- module but different SrcSpans, so we need a way to - -- distinguish them easily and give them different - -- object-code labels. So every CostCentre has an - -- associated flavour that indicates how it was - -- generated, and flavours that allow multiple instances - -- of the same name and module have a deterministic 0-based - -- index. - cc_name :: CcName, -- ^ Name of the cost centre itself - cc_mod :: Module, -- ^ Name of module defining this CC. - cc_loc :: SrcSpan - } - - | AllCafsCC { - cc_mod :: Module, -- Name of module defining this CC. - cc_loc :: SrcSpan - } - deriving Data - -type CcName = FastString - --- | The flavour of a cost centre. --- --- Index fields represent 0-based indices giving source-code ordering of --- centres with the same module, name, and flavour. -data CCFlavour = CafCC -- ^ Auto-generated top-level thunk - | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression - | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration - | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage - deriving (Eq, Ord, Data) - --- | Extract the index from a flavour -flavourIndex :: CCFlavour -> Int -flavourIndex CafCC = 0 -flavourIndex (ExprCC x) = unCostCentreIndex x -flavourIndex (DeclCC x) = unCostCentreIndex x -flavourIndex (HpcCC x) = unCostCentreIndex x - -instance Eq CostCentre where - c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } - -instance Ord CostCentre where - compare = cmpCostCentre - -cmpCostCentre :: CostCentre -> CostCentre -> Ordering - -cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) - = m1 `compare` m2 - -cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} - NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} - -- first key is module name, then centre name, then flavour - = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) - -cmpCostCentre other_1 other_2 - = let - tag1 = tag_CC other_1 - tag2 = tag_CC other_2 - in - if tag1 < tag2 then LT else GT - where - tag_CC :: CostCentre -> Int - tag_CC (NormalCC {}) = 0 - tag_CC (AllCafsCC {}) = 1 - - ------------------------------------------------------------------------------ --- Predicates on CostCentre - -isCafCC :: CostCentre -> Bool -isCafCC (AllCafsCC {}) = True -isCafCC (NormalCC {cc_flavour = CafCC}) = True -isCafCC _ = False - --- | Is this a cost-centre which records scc counts -isSccCountCC :: CostCentre -> Bool -isSccCountCC cc | isCafCC cc = False - | otherwise = True - --- | Is this a cost-centre which can be sccd ? -sccAbleCC :: CostCentre -> Bool -sccAbleCC cc | isCafCC cc = False - | otherwise = True - -ccFromThisModule :: CostCentre -> Module -> Bool -ccFromThisModule cc m = cc_mod cc == m - - ------------------------------------------------------------------------------ --- Building cost centres - -mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre -mkUserCC cc_name mod loc flavour - = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, - cc_flavour = flavour - } - -mkAutoCC :: Id -> Module -> CostCentre -mkAutoCC id mod - = NormalCC { cc_name = str, cc_mod = mod, - cc_loc = nameSrcSpan (getName id), - cc_flavour = CafCC - } - where - name = getName id - -- beware: only external names are guaranteed to have unique - -- Occnames. If the name is not external, we must append its - -- Unique. - -- See bug #249, tests prof001, prof002, also #2411 - str | isExternalName name = occNameFS (getOccName id) - | otherwise = occNameFS (getOccName id) - `appendFS` - mkFastString ('_' : show (getUnique name)) -mkAllCafsCC :: Module -> SrcSpan -> CostCentre -mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } - ------------------------------------------------------------------------------ --- Cost Centre Stacks - --- | A Cost Centre Stack is something that can be attached to a closure. --- This is either: --- --- * the current cost centre stack (CCCS) --- * a pre-defined cost centre stack (there are several --- pre-defined CCSs, see below). - -data CostCentreStack - = CurrentCCS -- Pinned on a let(rec)-bound - -- thunk/function/constructor, this says that the - -- cost centre to be attached to the object, when it - -- is allocated, is whatever is in the - -- current-cost-centre-stack register. - - | DontCareCCS -- We need a CCS to stick in static closures - -- (for data), but we *don't* expect them to - -- accumulate any costs. But we still need - -- the placeholder. This CCS is it. - - | SingletonCCS CostCentre - - deriving (Eq, Ord) -- needed for Ord on CLabel - - --- synonym for triple which describes the cost centre info in the generated --- code for a module. -type CollectedCCs - = ( [CostCentre] -- local cost-centres that need to be decl'd - , [CostCentreStack] -- pre-defined "singleton" cost centre stacks - ) - -emptyCollectedCCs :: CollectedCCs -emptyCollectedCCs = ([], []) - -collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs -collectCC cc ccs (c, cs) = (cc : c, ccs : cs) - -currentCCS, dontCareCCS :: CostCentreStack - -currentCCS = CurrentCCS -dontCareCCS = DontCareCCS - ------------------------------------------------------------------------------ --- Predicates on Cost-Centre Stacks - -isCurrentCCS :: CostCentreStack -> Bool -isCurrentCCS CurrentCCS = True -isCurrentCCS _ = False - -isCafCCS :: CostCentreStack -> Bool -isCafCCS (SingletonCCS cc) = isCafCC cc -isCafCCS _ = False - -maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre -maybeSingletonCCS (SingletonCCS cc) = Just cc -maybeSingletonCCS _ = Nothing - -mkSingletonCCS :: CostCentre -> CostCentreStack -mkSingletonCCS cc = SingletonCCS cc - - ------------------------------------------------------------------------------ --- Printing Cost Centre Stacks. - --- The outputable instance for CostCentreStack prints the CCS as a C --- expression. - -instance Outputable CostCentreStack where - ppr CurrentCCS = text "CCCS" - ppr DontCareCCS = text "CCS_DONT_CARE" - ppr (SingletonCCS cc) = ppr cc <> text "_ccs" - - ------------------------------------------------------------------------------ --- Printing Cost Centres --- --- There are several different ways in which we might want to print a --- cost centre: --- --- - the name of the cost centre, for profiling output (a C string) --- - the label, i.e. C label for cost centre in .hc file. --- - the debugging name, for output in -ddump things --- - the interface name, for printing in _scc_ exprs in iface files. --- --- The last 3 are derived from costCentreStr below. The first is given --- by costCentreName. - -instance Outputable CostCentre where - ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) - --- Printing in Core -pprCostCentreCore :: CostCentre -> SDoc -pprCostCentreCore (AllCafsCC {cc_mod = m}) - = text "__sccC" <+> braces (ppr m) -pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, - cc_mod = m, cc_loc = loc}) - = text "__scc" <+> braces (hsep [ - ppr m <> char '.' <> ftext n, - pprFlavourCore flavour, - whenPprDebug (ppr loc) - ]) - --- ^ Print a flavour in Core -pprFlavourCore :: CCFlavour -> SDoc -pprFlavourCore CafCC = text "__C" -pprFlavourCore f = pprIdxCore $ flavourIndex f - --- ^ Print a flavour's index in Core -pprIdxCore :: Int -> SDoc -pprIdxCore 0 = empty -pprIdxCore idx = whenPprDebug $ ppr idx - --- Printing as a C label -ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" -ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) - = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> - ppFlavourLblComponent f <> text "_cc" - --- ^ Print the flavour component of a C label -ppFlavourLblComponent :: CCFlavour -> SDoc -ppFlavourLblComponent CafCC = text "CAF" -ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i -ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i -ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i - --- ^ Print the flavour index component of a C label -ppIdxLblComponent :: CostCentreIndex -> SDoc -ppIdxLblComponent n = - case unCostCentreIndex n of - 0 -> empty - n -> ppr n - --- This is the name to go in the user-displayed string, --- recorded in the cost centre declaration -costCentreUserName :: CostCentre -> String -costCentreUserName = unpackFS . costCentreUserNameFS - -costCentreUserNameFS :: CostCentre -> FastString -costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" -costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) - = case is_caf of - CafCC -> mkFastString "CAF:" `appendFS` name - _ -> name - -costCentreSrcSpan :: CostCentre -> SrcSpan -costCentreSrcSpan = cc_loc - -instance Binary CCFlavour where - put_ bh CafCC = do - putByte bh 0 - put_ bh (ExprCC i) = do - putByte bh 1 - put_ bh i - put_ bh (DeclCC i) = do - putByte bh 2 - put_ bh i - put_ bh (HpcCC i) = do - putByte bh 3 - put_ bh i - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - 1 -> ExprCC <$> get bh - 2 -> DeclCC <$> get bh - _ -> HpcCC <$> get bh - -instance Binary CostCentre where - put_ bh (NormalCC aa ab ac _ad) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh (AllCafsCC ae _af) = do - putByte bh 1 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - return (NormalCC aa ab ac noSrcSpan) - _ -> do ae <- get bh - return (AllCafsCC ae noSrcSpan) - - -- We ignore the SrcSpans in CostCentres when we serialise them, - -- and set the SrcSpans to noSrcSpan when deserialising. This is - -- ok, because we only need the SrcSpan when declaring the - -- CostCentre in the original module, it is not used by importing - -- modules. diff --git a/profiling/CostCentreState.hs b/profiling/CostCentreState.hs deleted file mode 100644 --- a/profiling/CostCentreState.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module CostCentreState ( CostCentreState, newCostCentreState - , CostCentreIndex, unCostCentreIndex, getCCIndex - ) where - -import GhcPrelude -import FastString -import FastStringEnv - -import Data.Data -import Binary - --- | Per-module state for tracking cost centre indices. --- --- See documentation of 'CostCentre.cc_flavour' for more details. -newtype CostCentreState = CostCentreState (FastStringEnv Int) - --- | Initialize cost centre state. -newCostCentreState :: CostCentreState -newCostCentreState = CostCentreState emptyFsEnv - --- | An index into a given cost centre module,name,flavour set -newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } - deriving (Eq, Ord, Data, Binary) - --- | Get a new index for a given cost centre name. -getCCIndex :: FastString - -> CostCentreState - -> (CostCentreIndex, CostCentreState) -getCCIndex nm (CostCentreState m) = - (CostCentreIndex idx, CostCentreState m') - where - m_idx = lookupFsEnv m nm - idx = maybe 0 id m_idx - m' = extendFsEnv m nm (idx + 1) diff --git a/profiling/ProfInit.hs b/profiling/ProfInit.hs deleted file mode 100644 --- a/profiling/ProfInit.hs +++ /dev/null @@ -1,64 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2011 --- --- Generate code to initialise cost centres --- --- ----------------------------------------------------------------------------- - -module ProfInit (profilingInitCode) where - -import GhcPrelude - -import CLabel -import CostCentre -import DynFlags -import Outputable -import Module - --- ----------------------------------------------------------------------------- --- Initialising cost centres - --- We must produce declarations for the cost-centres defined in this --- module; - -profilingInitCode :: Module -> CollectedCCs -> SDoc -profilingInitCode this_mod (local_CCs, singleton_CCSs) - = sdocWithDynFlags $ \dflags -> - if not (gopt Opt_SccProfilingOn dflags) - then empty - else vcat - $ map emit_cc_decl local_CCs - ++ map emit_ccs_decl singleton_CCSs - ++ [emit_cc_list local_CCs] - ++ [emit_ccs_list singleton_CCSs] - ++ [ text "static void prof_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void prof_init_" <> ppr this_mod <> text "(void)" - , braces (vcat - [ text "registerCcList" <> parens local_cc_list_label <> semi - , text "registerCcsList" <> parens singleton_cc_list_label <> semi - ]) - ] - where - emit_cc_decl cc = - text "extern CostCentre" <+> cc_lbl <> text "[];" - where cc_lbl = ppr (mkCCLabel cc) - local_cc_list_label = text "local_cc_" <> ppr this_mod - emit_cc_list ccs = - text "static CostCentre *" <> local_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma - | cc <- ccs - ] ++ [text "NULL"]) - <> semi - - emit_ccs_decl ccs = - text "extern CostCentreStack" <+> ccs_lbl <> text "[];" - where ccs_lbl = ppr (mkCCSLabel ccs) - singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod - emit_ccs_list ccs = - text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma - | cc <- ccs - ] ++ [text "NULL"]) - <> semi diff --git a/rename/RnBinds.hs b/rename/RnBinds.hs deleted file mode 100644 --- a/rename/RnBinds.hs +++ /dev/null @@ -1,1334 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnBinds]{Renaming and dependency analysis of bindings} - -This module does renaming and dependency analysis on value bindings in -the abstract syntax. It does {\em not} do cycle-checks on class or -type-synonym declarations; those cannot be done at this stage because -they may be affected by renaming (which isn't fully worked out yet). --} - -module RnBinds ( - -- Renaming top-level bindings - rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS, - - -- Renaming local bindings - rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - - -- Other bindings - rnMethodBinds, renameSigs, - rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, - makeMiniFixityEnv, MiniFixityEnv, - HsSigCtxt(..) - ) where - -import GhcPrelude - -import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) - -import GHC.Hs -import TcRnMonad -import RnTypes -import RnPat -import RnNames -import RnEnv -import RnFixity -import RnUtils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn - , checkDupRdrNames, warnUnusedLocalBinds, - checkUnusedRecordWildcard - , checkDupAndShadowedNames, bindLocalNamesFV ) -import DynFlags -import Module -import Name -import NameEnv -import NameSet -import RdrName ( RdrName, rdrNameOcc ) -import SrcLoc -import ListSetOps ( findDupsEq ) -import BasicTypes ( RecFlag(..), TypeOrKind(..) ) -import Digraph ( SCC(..) ) -import Bag -import Util -import Outputable -import UniqSet -import Maybes ( orElse ) -import OrdList -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition, sort ) -import Data.List.NonEmpty ( NonEmpty(..) ) - -{- --- ToDo: Put the annotations into the monad, so that they arrive in the proper --- place and can be used when complaining. - -The code tree received by the function @rnBinds@ contains definitions -in where-clauses which are all apparently mutually recursive, but which may -not really depend upon each other. For example, in the top level program -\begin{verbatim} -f x = y where a = x - y = x -\end{verbatim} -the definitions of @a@ and @y@ do not depend on each other at all. -Unfortunately, the typechecker cannot always check such definitions. -\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive -definitions. In Proceedings of the International Symposium on Programming, -Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} -However, the typechecker usually can check definitions in which only the -strongly connected components have been collected into recursive bindings. -This is precisely what the function @rnBinds@ does. - -ToDo: deal with case where a single monobinds binds the same variable -twice. - -The vertag tag is a unique @Int@; the tags only need to be unique -within one @MonoBinds@, so that unique-Int plumbing is done explicitly -(heavy monad machinery not needed). - - -************************************************************************ -* * -* naming conventions * -* * -************************************************************************ - -\subsection[name-conventions]{Name conventions} - -The basic algorithm involves walking over the tree and returning a tuple -containing the new tree plus its free variables. Some functions, such -as those walking polymorphic bindings (HsBinds) and qualifier lists in -list comprehensions (@Quals@), return the variables bound in local -environments. These are then used to calculate the free variables of the -expression evaluated in these environments. - -Conventions for variable names are as follows: -\begin{itemize} -\item -new code is given a prime to distinguish it from the old. - -\item -a set of variables defined in @Exp@ is written @dvExp@ - -\item -a set of variables free in @Exp@ is written @fvExp@ -\end{itemize} - -************************************************************************ -* * -* analysing polymorphic bindings (HsBindGroup, HsBind) -* * -************************************************************************ - -\subsubsection[dep-HsBinds]{Polymorphic bindings} - -Non-recursive expressions are reconstructed without any changes at top -level, although their component expressions may have to be altered. -However, non-recursive expressions are currently not expected as -\Haskell{} programs, and this code should not be executed. - -Monomorphic bindings contain information that is returned in a tuple -(a @FlatMonoBinds@) containing: - -\begin{enumerate} -\item -a unique @Int@ that serves as the ``vertex tag'' for this binding. - -\item -the name of a function or the names in a pattern. These are a set -referred to as @dvLhs@, the defined variables of the left hand side. - -\item -the free variables of the body. These are referred to as @fvBody@. - -\item -the definition's actual code. This is referred to as just @code@. -\end{enumerate} - -The function @nonRecDvFv@ returns two sets of variables. The first is -the set of variables defined in the set of monomorphic bindings, while the -second is the set of free variables in those bindings. - -The set of variables defined in a non-recursive binding is just the -union of all of them, as @union@ removes duplicates. However, the -free variables in each successive set of cumulative bindings is the -union of those in the previous set plus those of the newest binding after -the defined variables of the previous set have been removed. - -@rnMethodBinds@ deals only with the declarations in class and -instance declarations. It expects only to see @FunMonoBind@s, and -it expects the global environment to contain bindings for the binders -(which are all class operations). - -************************************************************************ -* * -\subsubsection{ Top-level bindings} -* * -************************************************************************ --} - --- for top-level bindings, we need to make top-level names, --- so we have a different entry point than for local bindings -rnTopBindsLHS :: MiniFixityEnv - -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) -rnTopBindsLHS fix_env binds - = rnValBindsLHS (topRecNameMaker fix_env) binds - -rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs - -> RnM (HsValBinds GhcRn, DefUses) --- A hs-boot file has no bindings. --- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBinds _ mbinds sigs) - = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs - ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } -rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) - -{- -********************************************************* -* * - HsLocalBinds -* * -********************************************************* --} - -rnLocalBindsAndThen :: HsLocalBinds GhcPs - -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) --- This version (a) assumes that the binding vars are *not* already in scope --- (b) removes the binders from the free vars of the thing inside --- The parser doesn't produce ThenBinds -rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside = - thing_inside (EmptyLocalBinds x) emptyNameSet - -rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside - = rnLocalValBindsAndThen val_binds $ \ val_binds' -> - thing_inside (HsValBinds x val_binds') - -rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do - (binds',fv_binds) <- rnIPBinds binds - (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds - return (thing, fvs_thing `plusFV` fv_binds) - -rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec - -rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) -rnIPBinds (IPBinds _ ip_binds ) = do - (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds - return (IPBinds noExtField ip_binds', plusFVs fvs_s) -rnIPBinds (XHsIPBinds nec) = noExtCon nec - -rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) -rnIPBind (IPBind _ ~(Left n) expr) = do - (expr',fvExpr) <- rnLExpr expr - return (IPBind noExtField (Left n) expr', fvExpr) -rnIPBind (XIPBind nec) = noExtCon nec - -{- -************************************************************************ -* * - ValBinds -* * -************************************************************************ --} - --- Renaming local binding groups --- Does duplicate/shadow check -rnLocalValBindsLHS :: MiniFixityEnv - -> HsValBinds GhcPs - -> RnM ([Name], HsValBindsLR GhcRn GhcPs) -rnLocalValBindsLHS fix_env binds - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds - - -- Check for duplicates and shadowing - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in GHC.Hs.Utils - - -- We need to check for dups here because we - -- don't don't bind all of the variables from the ValBinds at once - -- with bindLocatedLocals any more. - -- - -- Note that we don't want to do this at the top level, since - -- sorting out duplicates and shadowing there happens elsewhere. - -- The behavior is even different. For example, - -- import A(f) - -- f = ... - -- should not produce a shadowing warning (but it will produce - -- an ambiguity warning if you use f), but - -- import A(f) - -- g = let f = ... in f - -- should. - ; let bound_names = collectHsValBinders binds' - -- There should be only Ids, but if there are any bogus - -- pattern synonyms, we'll collect them anyway, so that - -- we don't generate subsequent out-of-scope messages - ; envs <- getRdrEnvs - ; checkDupAndShadowedNames envs bound_names - - ; return (bound_names, binds') } - --- renames the left-hand sides --- generic version used both at the top level and for local binds --- does some error checking, but not what gets done elsewhere at the top level -rnValBindsLHS :: NameMaker - -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBinds x mbinds sigs) - = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds - ; return $ ValBinds x mbinds' sigs } - where - bndrs = collectHsBindsBinders mbinds - doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs - -rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) - --- General version used both from the top-level and for local things --- Assumes the LHS vars are in scope --- --- Does not bind the local fixity declarations -rnValBindsRHS :: HsSigCtxt - -> HsValBindsLR GhcRn GhcPs - -> RnM (HsValBinds GhcRn, DefUses) - -rnValBindsRHS ctxt (ValBinds _ mbinds sigs) - = do { (sigs', sig_fvs) <- renameSigs ctxt sigs - ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds - ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus - - ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ - getPatSynBinds anal_binds - -- The uses in binds_w_dus for PatSynBinds do not include - -- variables used in the patsyn builders; see - -- Note [Pattern synonym builders don't yield dependencies] - -- But psb_fvs /does/ include those builder fvs. So we - -- add them back in here to avoid bogus warnings about - -- unused variables (#12548) - - valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs - `plusDU` usesOnly patsyn_fvs - -- Put the sig uses *after* the bindings - -- so that the binders are removed from - -- the uses in the sigs - - ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } - -rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) - --- Wrapper for local binds --- --- The *client* of this function is responsible for checking for unused binders; --- it doesn't (and can't: we don't have the thing inside the binds) happen here --- --- The client is also responsible for bringing the fixities into scope -rnLocalValBindsRHS :: NameSet -- names bound by the LHSes - -> HsValBindsLR GhcRn GhcPs - -> RnM (HsValBinds GhcRn, DefUses) -rnLocalValBindsRHS bound_names binds - = rnValBindsRHS (LocalBindCtxt bound_names) binds - --- for local binds --- wrapper that does both the left- and right-hand sides --- --- here there are no local fixity decls passed in; --- the local fixity decls come from the ValBinds sigs -rnLocalValBindsAndThen - :: HsValBinds GhcPs - -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) -rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside - = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [ L loc sig - | L loc (FixSig _ sig) <- sigs] - - -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds - - -- ...and bring them (and their fixities) into scope - ; bindLocalNamesFV bound_names $ - addLocalFixities new_fixities bound_names $ do - - { -- (C) Do the RHS and thing inside - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs - ; (result, result_fvs) <- thing_inside binds' (allUses dus) - - -- Report unused bindings based on the (accurate) - -- findUses. E.g. - -- let x = x in 3 - -- should report 'x' unused - ; let real_uses = findUses dus result_fvs - -- Insert fake uses for variables introduced implicitly by - -- wildcards (#4404) - rec_uses = hsValBindsImplicits binds' - implicit_uses = mkNameSet $ concatMap snd - $ rec_uses - ; mapM_ (\(loc, ns) -> - checkUnusedRecordWildcard loc real_uses (Just ns)) - rec_uses - ; warnUnusedLocalBinds bound_names - (real_uses `unionNameSet` implicit_uses) - - ; let - -- The variables "used" in the val binds are: - -- (1) the uses of the binds (allUses) - -- (2) the FVs of the thing-inside - all_uses = allUses dus `plusFV` result_fvs - -- Note [Unused binding hack] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Note that *in contrast* to the above reporting of - -- unused bindings, (1) above uses duUses to return *all* - -- the uses, even if the binding is unused. Otherwise consider: - -- x = 3 - -- y = let p = x in 'x' -- NB: p not used - -- If we don't "see" the dependency of 'y' on 'x', we may put the - -- bindings in the wrong order, and the type checker will complain - -- that x isn't in scope - -- - -- But note that this means we won't report 'x' as unused, - -- whereas we would if we had { x = 3; p = x; y = 'x' } - - ; return (result, all_uses) }} - -- The bound names are pruned out of all_uses - -- by the bindLocalNamesFV call above - -rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) - - ---------------------- - --- renaming a single bind - -rnBindLHS :: NameMaker - -> SDoc - -> HsBind GhcPs - -- returns the renamed left-hand side, - -- and the FreeVars *of the LHS* - -- (i.e., any free variables of the pattern) - -> RnM (HsBindLR GhcRn GhcPs) - -rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) - = do - -- we don't actually use the FV processing of rnPatsAndThen here - (pat',pat'_fvs) <- rnBindPat name_maker pat - return (bind { pat_lhs = pat', pat_ext = pat'_fvs }) - -- We temporarily store the pat's FVs in bind_fvs; - -- gets updated to the FVs of the whole bind - -- when doing the RHS below - -rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) - = do { name <- applyNameMaker name_maker rdr_name - ; return (bind { fun_id = name - , fun_ext = noExtField }) } - -rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) - | isTopRecNameMaker name_maker - = do { addLocM checkConName rdrname - ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already - ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } - - | otherwise -- Pattern synonym, not at top level - = do { addErr localPatternSynonymErr -- Complain, but make up a fake - -- name so that we can carry on - ; name <- applyNameMaker name_maker rdrname - ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } - where - localPatternSynonymErr :: SDoc - localPatternSynonymErr - = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) - 2 (text "Pattern synonym declarations are only valid at top level") - -rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) - -rnLBind :: (Name -> [Name]) -- Signature tyvar function - -> LHsBindLR GhcRn GhcPs - -> RnM (LHsBind GhcRn, [Name], Uses) -rnLBind sig_fn (L loc bind) - = setSrcSpan loc $ - do { (bind', bndrs, dus) <- rnBind sig_fn bind - ; return (L loc bind', bndrs, dus) } - --- assumes the left-hands-side vars are in scope -rnBind :: (Name -> [Name]) -- Signature tyvar function - -> HsBindLR GhcRn GhcPs - -> RnM (HsBind GhcRn, [Name], Uses) -rnBind _ bind@(PatBind { pat_lhs = pat - , pat_rhs = grhss - -- pat fvs were stored in bind_fvs - -- after processing the LHS - , pat_ext = pat_fvs }) - = do { mod <- getModule - ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss - - -- No scoped type variables for pattern bindings - ; let all_fvs = pat_fvs `plusFV` rhs_fvs - fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - bndrs = collectPatBinders pat - bind' = bind { pat_rhs = grhss' - , pat_ext = fvs' } - - ok_nobind_pat - = -- See Note [Pattern bindings that bind no variables] - case unLoc pat of - WildPat {} -> True - BangPat {} -> True -- #9127, #13646 - SplicePat {} -> True - _ -> False - - -- Warn if the pattern binds no variables - -- See Note [Pattern bindings that bind no variables] - ; whenWOptM Opt_WarnUnusedPatternBinds $ - when (null bndrs && not ok_nobind_pat) $ - addWarn (Reason Opt_WarnUnusedPatternBinds) $ - unusedPatBindWarn bind' - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', bndrs, all_fvs) } - -rnBind sig_fn bind@(FunBind { fun_id = name - , fun_matches = matches }) - -- invariant: no free vars here when it's a FunBind - = do { let plain_name = unLoc name - - ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - -- bindSigTyVars tests for LangExt.ScopedTyVars - rnMatchGroup (mkPrefixFunRhs name) - rnLExpr matches - ; let is_infix = isInfixFunBind bind - ; when is_infix $ checkPrecMatch plain_name matches' - - ; mod <- getModule - ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind { fun_matches = matches' - , fun_ext = fvs' }, - [plain_name], rhs_fvs) - } - -rnBind sig_fn (PatSynBind x bind) - = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind - ; return (PatSynBind x bind', name, fvs) } - -rnBind _ b = pprPanic "rnBind" (ppr b) - -{- Note [Pattern bindings that bind no variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally, we want to warn about pattern bindings like - Just _ = e -because they don't do anything! But we have three exceptions: - -* A wildcard pattern - _ = rhs - which (a) is not that different from _v = rhs - (b) is sometimes used to give a type sig for, - or an occurrence of, a variable on the RHS - -* A strict pattern binding; that is, one with an outermost bang - !Just _ = e - This can fail, so unlike the lazy variant, it is not a no-op. - Moreover, #13646 argues that even for single constructor - types, you might want to write the constructor. See also #9127. - -* A splice pattern - $(th-lhs) = rhs - It is impossible to determine whether or not th-lhs really - binds any variable. We should disable the warning for any pattern - which contain splices, but that is a more expensive check. - -Note [Free-variable space leak] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have - fvs' = trim fvs -and we seq fvs' before turning it as part of a record. - -The reason is that trim is sometimes something like - \xs -> intersectNameSet (mkNameSet bound_names) xs -and we don't want to retain the list bound_names. This showed up in -trac ticket #1136. --} - -{- ********************************************************************* -* * - Dependency analysis and other support functions -* * -********************************************************************* -} - -depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses) - -> ([(RecFlag, LHsBinds GhcRn)], DefUses) --- Dependency analysis; this is important so that --- unused-binding reporting is accurate -depAnalBinds binds_w_dus - = (map get_binds sccs, toOL $ map get_du sccs) - where - sccs = depAnal (\(_, defs, _) -> defs) - (\(_, _, uses) -> nonDetEltsUniqSet uses) - -- It's OK to use nonDetEltsUniqSet here as explained in - -- Note [depAnal determinism] in NameEnv. - (bagToList binds_w_dus) - - get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) - get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) - - get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) - get_du (CyclicSCC binds_w_dus) = (Just defs, uses) - where - defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] - uses = unionNameSets [u | (_,_,u) <- binds_w_dus] - ---------------------- --- Bind the top-level forall'd type variables in the sigs. --- E.g f :: forall a. a -> a --- f = rhs --- The 'a' scopes over the rhs --- --- NB: there'll usually be just one (for a function binding) --- but if there are many, one may shadow the rest; too bad! --- e.g x :: forall a. [a] -> [a] --- y :: forall a. [(a,a)] -> a --- (x,y) = e --- In e, 'a' will be in scope, and it'll be the one from 'y'! - -mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name]) --- Return a lookup function that maps an Id Name to the names --- of the type variables that should scope over its body. -mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` [] - where - env = mkHsSigEnv get_scoped_tvs sigs - - get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) - -- Returns (binders, scoped tvs for those binders) - get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) - = Just (names, hsScopedTvs sig_ty) - get_scoped_tvs (L _ (TypeSig _ names sig_ty)) - = Just (names, hsWcScopedTvs sig_ty) - get_scoped_tvs (L _ (PatSynSig _ names sig_ty)) - = Just (names, hsScopedTvs sig_ty) - get_scoped_tvs _ = Nothing - --- Process the fixity declarations, making a FastString -> (Located Fixity) map --- (We keep the location around for reporting duplicate fixity declarations.) --- --- Checks for duplicates, but not that only locally defined things are fixed. --- Note: for local fixity declarations, duplicates would also be checked in --- check_sigs below. But we also use this function at the top level. - -makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv - -makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls - where - add_one_sig env (L loc (FixitySig _ names fixity)) = - foldlM add_one env [ (loc,name_loc,name,fixity) - | L name_loc name <- names ] - add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec - - add_one env (loc, name_loc, name,fixity) = do - { -- this fixity decl is a duplicate iff - -- the ReaderName's OccName's FastString is already in the env - -- (we only need to check the local fix_env because - -- definitions of non-local will be caught elsewhere) - let { fs = occNameFS (rdrNameOcc name) - ; fix_item = L loc fixity }; - - case lookupFsEnv env fs of - Nothing -> return $ extendFsEnv env fs fix_item - Just (L loc' _) -> do - { setSrcSpan loc $ - addErrAt name_loc (dupFixityDecl loc' name) - ; return env} - } - -dupFixityDecl :: SrcSpan -> RdrName -> SDoc -dupFixityDecl loc rdr_name - = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] - - -{- ********************************************************************* -* * - Pattern synonym bindings -* * -********************************************************************* -} - -rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function - -> PatSynBind GhcRn GhcPs - -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) -rnPatSynBind sig_fn bind@(PSB { psb_id = L l name - , psb_args = details - , psb_def = pat - , psb_dir = dir }) - -- invariant: no free vars here when it's a FunBind - = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms - ; unless pattern_synonym_ok (addErr patternSynonymErr) - ; let scoped_tvs = sig_fn name - - ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ - rnPat PatSyn pat $ \pat' -> - -- We check the 'RdrName's instead of the 'Name's - -- so that the binding locations are reported - -- from the left-hand side - case details of - PrefixCon vars -> - do { checkDupRdrNames vars - ; names <- mapM lookupPatSynBndr vars - ; return ( (pat', PrefixCon names) - , mkFVs (map unLoc names)) } - InfixCon var1 var2 -> - do { checkDupRdrNames [var1, var2] - ; name1 <- lookupPatSynBndr var1 - ; name2 <- lookupPatSynBndr var2 - -- ; checkPrecMatch -- TODO - ; return ( (pat', InfixCon name1 name2) - , mkFVs (map unLoc [name1, name2])) } - RecCon vars -> - do { checkDupRdrNames (map recordPatSynSelectorId vars) - ; let rnRecordPatSynField - (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = do { visible' <- lookupLocatedTopBndrRn visible - ; hidden' <- lookupPatSynBndr hidden - ; return $ RecordPatSynField { recordPatSynSelectorId = visible' - , recordPatSynPatVar = hidden' } } - ; names <- mapM rnRecordPatSynField vars - ; return ( (pat', RecCon names) - , mkFVs (map (unLoc . recordPatSynPatVar) names)) } - - ; (dir', fvs2) <- case dir of - Unidirectional -> return (Unidirectional, emptyFVs) - ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) - ExplicitBidirectional mg -> - do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $ - rnMatchGroup (mkPrefixFunRhs (L l name)) - rnLExpr mg - ; return (ExplicitBidirectional mg', fvs) } - - ; mod <- getModule - ; let fvs = fvs1 `plusFV` fvs2 - fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - - bind' = bind{ psb_args = details' - , psb_def = pat' - , psb_dir = dir' - , psb_ext = fvs' } - selector_names = case details' of - RecCon names -> - map (unLoc . recordPatSynSelectorId) names - _ -> [] - - ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', name : selector_names , fvs1) - -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] - } - where - -- See Note [Renaming pattern synonym variables] - lookupPatSynBndr = wrapLocM lookupLocalOccRn - - patternSynonymErr :: SDoc - patternSynonymErr - = hang (text "Illegal pattern synonym declaration") - 2 (text "Use -XPatternSynonyms to enable this extension") - -rnPatSynBind _ (XPatSynBind nec) = noExtCon nec - -{- -Note [Renaming pattern synonym variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We rename pattern synonym declaractions backwards to normal to reuse -the logic already implemented for renaming patterns. - -We first rename the RHS of a declaration which brings into -scope the variables bound by the pattern (as they would be -in normal function definitions). We then lookup the variables -which we want to bind in this local environment. - -It is crucial that we then only lookup in the *local* environment which -only contains the variables brought into scope by the pattern and nothing -else. Amazingly no-one encountered this bug for 3 GHC versions but -it was possible to define a pattern synonym which referenced global -identifiers and worked correctly. - -``` -x = 5 - -pattern P :: Int -> () -pattern P x <- _ - -f (P x) = x - -> f () = 5 -``` - -See #13470 for the original report. - -Note [Pattern synonym builders don't yield dependencies] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When renaming a pattern synonym that has an explicit builder, -references in the builder definition should not be used when -calculating dependencies. For example, consider the following pattern -synonym definition: - -pattern P x <- C1 x where - P x = f (C1 x) - -f (P x) = C2 x - -In this case, 'P' needs to be typechecked in two passes: - -1. Typecheck the pattern definition of 'P', which fully determines the - type of 'P'. This step doesn't require knowing anything about 'f', - since the builder definition is not looked at. - -2. Typecheck the builder definition, which needs the typechecked - definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind - in TcBinds.tcValBinds. - -This behaviour is implemented in 'tcValBinds', but it crucially -depends on 'P' not being put in a recursive group with 'f' (which -would make it look like a recursive pattern synonym a la 'pattern P = -P' which is unsound and rejected). - -So: - * We do not include builder fvs in the Uses returned by rnPatSynBind - (which is then used for dependency analysis) - * But we /do/ include them in the psb_fvs for the PatSynBind - * In rnValBinds we record these builder uses, to avoid bogus - unused-variable warnings (#12548) --} - -{- ********************************************************************* -* * - Class/instance method bindings -* * -********************************************************************* -} - -{- @rnMethodBinds@ is used for the method bindings of a class and an instance -declaration. Like @rnBinds@ but without dependency analysis. - -NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. -That's crucial when dealing with an instance decl: -\begin{verbatim} - instance Foo (T a) where - op x = ... -\end{verbatim} -This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, -and unless @op@ occurs we won't treat the type signature of @op@ in the class -decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, -in many ways the @op@ in an instance decl is just like an occurrence, not -a binder. --} - -rnMethodBinds :: Bool -- True <=> is a class declaration - -> Name -- Class name - -> [Name] -- Type variables from the class/instance header - -> LHsBinds GhcPs -- Binds - -> [LSig GhcPs] -- and signatures/pragmas - -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) --- Used for --- * the default method bindings in a class decl --- * the method bindings in an instance decl -rnMethodBinds is_cls_decl cls ktv_names binds sigs - = do { checkDupRdrNames (collectMethodBinders binds) - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration; and we use rnMethodBinds - -- for instance decls too - - -- Rename the bindings LHSs - ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds - - -- Rename the pragmas and signatures - -- Annoyingly the type variables /are/ in scope for signatures, but - -- /are not/ in scope in the SPECIALISE instance pramas; e.g. - -- instance Eq a => Eq (T a) where - -- (==) :: a -> a -> a - -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} - ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs - bound_nms = mkNameSet (collectHsBindsBinders binds') - sig_ctxt | is_cls_decl = ClsDeclCtxt cls - | otherwise = InstDeclCtxt bound_nms - ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags - ; (other_sigs', sig_fvs) <- extendTyVarEnvFVRn ktv_names $ - renameSigs sig_ctxt other_sigs - - -- Rename the bindings RHSs. Again there's an issue about whether the - -- type variables from the class/instance head are in scope. - -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables - ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables - ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ - do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds' - ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) - emptyFVs binds_w_dus - ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } - - ; return ( binds'', spec_inst_prags' ++ other_sigs' - , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } - where - -- For the method bindings in class and instance decls, we extend - -- the type variable environment iff -XScopedTypeVariables - maybe_extend_tyvar_env scoped_tvs thing_inside - | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside - | otherwise = thing_inside - -rnMethodBindLHS :: Bool -> Name - -> LHsBindLR GhcPs GhcPs - -> LHsBindsLR GhcRn GhcPs - -> RnM (LHsBindsLR GhcRn GhcPs) -rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest - = setSrcSpan loc $ do - do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name - -- We use the selector name as the binder - ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } - ; return (L loc bind' `consBag` rest ) } - --- Report error for all other forms of bindings --- This is why we use a fold rather than map -rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt loc $ - vcat [ what <+> text "not allowed in" <+> decl_sort - , nest 2 (ppr bind) ] - ; return rest } - where - decl_sort | is_cls_decl = text "class declaration:" - | otherwise = text "instance declaration:" - what = case bind of - PatBind {} -> text "Pattern bindings (except simple variables)" - PatSynBind {} -> text "Pattern synonyms" - -- Associated pattern synonyms are not implemented yet - _ -> pprPanic "rnMethodBind" (ppr bind) - -{- -************************************************************************ -* * -\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} -* * -************************************************************************ - -@renameSigs@ checks for: -\begin{enumerate} -\item more than one sig for one thing; -\item signatures given for things not bound here; -\end{enumerate} - -At the moment we don't gather free-var info from the types in -signatures. We'd only need this if we wanted to report unused tyvars. --} - -renameSigs :: HsSigCtxt - -> [LSig GhcPs] - -> RnM ([LSig GhcRn], FreeVars) --- Renames the signatures and performs error checks -renameSigs ctxt sigs - = do { mapM_ dupSigDeclErr (findDupSigs sigs) - - ; checkDupMinimalSigs sigs - - ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs - - ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' - ; mapM_ misplacedSigErr bad_sigs -- Misplaced - - ; return (good_sigs, sig_fvs) } - ----------------------- --- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory --- because this won't work for: --- instance Foo T where --- {-# INLINE op #-} --- Baz.op = ... --- We'll just rename the INLINE prag to refer to whatever other 'op' --- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) --- Doesn't seem worth much trouble to sort this. - -renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) -renameSig _ (IdSig _ x) - = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs - -renameSig ctxt sig@(TypeSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; let doc = TypeSigCtx (ppr_sig_bndrs vs) - ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty - ; return (TypeSig noExtField new_vs new_ty, fvs) } - -renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) - = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures - ; when (is_deflt && not defaultSigs_on) $ - addErr (defaultSigErr sig) - ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty - ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } - where - (v1:_) = vs - ty_ctxt = GenericCtx (text "a class method signature for" - <+> quotes (ppr v1)) - -renameSig _ (SpecInstSig _ src ty) - = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty - ; return (SpecInstSig noExtField src new_ty,fvs) } - --- {-# SPECIALISE #-} pragmas can refer to imported Ids --- so, in the top-level case (when mb_names is Nothing) --- we use lookupOccRn. If there's both an imported and a local 'f' --- then the SPECIALISE pragma is ambiguous, unlike all other signatures -renameSig ctxt sig@(SpecSig _ v tys inl) - = do { new_v <- case ctxt of - TopSigCtxt {} -> lookupLocatedOccRn v - _ -> lookupSigOccRn ctxt sig v - ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys - ; return (SpecSig noExtField new_v new_ty inl, fvs) } - where - ty_ctxt = GenericCtx (text "a SPECIALISE signature for" - <+> quotes (ppr v)) - do_one (tys,fvs) ty - = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty - ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } - -renameSig ctxt sig@(InlineSig _ v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig noExtField new_v s, emptyFVs) } - -renameSig ctxt (FixSig _ fsig) - = do { new_fsig <- rnSrcFixityDecl ctxt fsig - ; return (FixSig noExtField new_fsig, emptyFVs) } - -renameSig ctxt sig@(MinimalSig _ s (L l bf)) - = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf - return (MinimalSig noExtField s (L l new_bf), emptyFVs) - -renameSig ctxt sig@(PatSynSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty - ; return (PatSynSig noExtField new_vs ty', fvs) } - where - ty_ctxt = GenericCtx (text "a pattern synonym signature for" - <+> ppr_sig_bndrs vs) - -renameSig ctxt sig@(SCCFunSig _ st v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (SCCFunSig noExtField st new_v s, emptyFVs) } - --- COMPLETE Sigs can refer to imported IDs which is why we use --- lookupLocatedOccRn rather than lookupSigOccRn -renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) - = do new_bf <- traverse lookupLocatedOccRn bf - new_mty <- traverse lookupLocatedOccRn mty - - this_mod <- fmap tcg_mod getGblEnv - unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do - -- Why 'any'? See Note [Orphan COMPLETE pragmas] - addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - - return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs) - where - orphanError :: SDoc - orphanError = - text "Orphan COMPLETE pragmas not supported" $$ - text "A COMPLETE pragma must mention at least one data constructor" $$ - text "or pattern synonym defined in the same module." - -renameSig _ (XSig nec) = noExtCon nec - -{- -Note [Orphan COMPLETE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We define a COMPLETE pragma to be a non-orphan if it includes at least -one conlike defined in the current module. Why is this sufficient? -Well if you have a pattern match - - case expr of - P1 -> ... - P2 -> ... - P3 -> ... - -any COMPLETE pragma which mentions a conlike other than P1, P2 or P3 -will not be of any use in verifying that the pattern match is -exhaustive. So as we have certainly read the interface files that -define P1, P2 and P3, we will have loaded all non-orphan COMPLETE -pragmas that could be relevant to this pattern match. - -For now we simply disallow orphan COMPLETE pragmas, as the added -complexity of supporting them properly doesn't seem worthwhile. --} - -ppr_sig_bndrs :: [Located RdrName] -> SDoc -ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) - -okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool -okHsSig ctxt (L _ sig) - = case (sig, ctxt) of - (ClassOpSig {}, ClsDeclCtxt {}) -> True - (ClassOpSig {}, InstDeclCtxt {}) -> True - (ClassOpSig {}, _) -> False - - (TypeSig {}, ClsDeclCtxt {}) -> False - (TypeSig {}, InstDeclCtxt {}) -> False - (TypeSig {}, _) -> True - - (PatSynSig {}, TopSigCtxt{}) -> True - (PatSynSig {}, _) -> False - - (FixSig {}, InstDeclCtxt {}) -> False - (FixSig {}, _) -> True - - (IdSig {}, TopSigCtxt {}) -> True - (IdSig {}, InstDeclCtxt {}) -> True - (IdSig {}, _) -> False - - (InlineSig {}, HsBootCtxt {}) -> False - (InlineSig {}, _) -> True - - (SpecSig {}, TopSigCtxt {}) -> True - (SpecSig {}, LocalBindCtxt {}) -> True - (SpecSig {}, InstDeclCtxt {}) -> True - (SpecSig {}, _) -> False - - (SpecInstSig {}, InstDeclCtxt {}) -> True - (SpecInstSig {}, _) -> False - - (MinimalSig {}, ClsDeclCtxt {}) -> True - (MinimalSig {}, _) -> False - - (SCCFunSig {}, HsBootCtxt {}) -> False - (SCCFunSig {}, _) -> True - - (CompleteMatchSig {}, TopSigCtxt {} ) -> True - (CompleteMatchSig {}, _) -> False - - (XSig nec, _) -> noExtCon nec - -------------------- -findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] --- Check for duplicates on RdrName version, --- because renamed version has unboundName for --- not-in-scope binders, which gives bogus dup-sig errors --- NB: in a class decl, a 'generic' sig is not considered --- equal to an ordinary sig, so we allow, say --- class C a where --- op :: a -> a --- default op :: Eq a => a -> a -findDupSigs sigs - = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) - where - expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) - expand_sig sig@(InlineSig _ n _) = [(n,sig)] - expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] - expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] - expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] - expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] - expand_sig _ = [] - - matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 - mtch (FixSig {}) (FixSig {}) = True - mtch (InlineSig {}) (InlineSig {}) = True - mtch (TypeSig {}) (TypeSig {}) = True - mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2 - mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True - mtch (SCCFunSig{}) (SCCFunSig{}) = True - mtch _ _ = False - --- Warn about multiple MINIMAL signatures -checkDupMinimalSigs :: [LSig GhcPs] -> RnM () -checkDupMinimalSigs sigs - = case filter isMinimalLSig sigs of - minSigs@(_:_:_) -> dupMinimalSigErr minSigs - _ -> return () - -{- -************************************************************************ -* * -\subsection{Match} -* * -************************************************************************ --} - -rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> MatchGroup GhcPs (Located (body GhcPs)) - -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) - = do { empty_case_ok <- xoptM LangExt.EmptyCase - ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) - ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms - ; return (mkMatchGroup origin new_ms, ms_fvs) } -rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec - -rnMatch :: Outputable (body GhcPs) => HsMatchContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> LMatch GhcPs (Located (body GhcPs)) - -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) -rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) - -rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> Match GhcPs (Located (body GhcPs)) - -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) -rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) - = do { -- Note that there are no local fixity decls for matches - ; rnPats ctxt pats $ \ pats' -> do - { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss - ; let mf' = case (ctxt, mf) of - (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) - -> mf { mc_fun = L lf funid } - _ -> ctxt - ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' - , m_grhss = grhss'}, grhss_fvs ) }} -rnMatch' _ _ (XMatch nec) = noExtCon nec - -emptyCaseErr :: HsMatchContext Name -> SDoc -emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) - 2 (text "Use EmptyCase to allow this") - where - pp_ctxt = case ctxt of - CaseAlt -> text "case expression" - LambdaExpr -> text "\\case expression" - _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt - -{- -************************************************************************ -* * -\subsubsection{Guarded right-hand sides (GRHSs)} -* * -************************************************************************ --} - -rnGRHSs :: HsMatchContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> GRHSs GhcPs (Located (body GhcPs)) - -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) -rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) - = rnLocalBindsAndThen binds $ \ binds' _ -> do - (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss - return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) -rnGRHSs _ _ (XGRHSs nec) = noExtCon nec - -rnGRHS :: HsMatchContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> LGRHS GhcPs (Located (body GhcPs)) - -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) -rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) - -rnGRHS' :: HsMatchContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> GRHS GhcPs (Located (body GhcPs)) - -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) -rnGRHS' ctxt rnBody (GRHS _ guards rhs) - = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> - rnBody rhs - - ; unless (pattern_guards_allowed || is_standard_guard guards') - (addWarn NoReason (nonStdGuardErr guards')) - - ; return (GRHS noExtField guards' rhs', fvs) } - where - -- Standard Haskell 1.4 guards are just a single boolean - -- expression, rather than a list of qualifiers as in the - -- Glasgow extension - is_standard_guard [] = True - is_standard_guard [L _ (BodyStmt {})] = True - is_standard_guard _ = False -rnGRHS' _ _ (XGRHS nec) = noExtCon nec - -{- -********************************************************* -* * - Source-code fixity declarations -* * -********************************************************* --} - -rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn) --- Rename a fixity decl, so we can put --- the renamed decl in the renamed syntax tree --- Errors if the thing being fixed is not defined locally. -rnSrcFixityDecl sig_ctxt = rn_decl - where - rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn) - -- GHC extension: look up both the tycon and data con - -- for con-like things; hence returning a list - -- If neither are in scope, report an error; otherwise - -- return a fixity sig for each (slightly odd) - rn_decl (FixitySig _ fnames fixity) - = do names <- concatMapM lookup_one fnames - return (FixitySig noExtField names fixity) - rn_decl (XFixitySig nec) = noExtCon nec - - lookup_one :: Located RdrName -> RnM [Located Name] - lookup_one (L name_loc rdr_name) - = setSrcSpan name_loc $ - -- This lookup will fail if the name is not defined in the - -- same binding group as this fixity declaration. - do names <- lookupLocalTcNames sig_ctxt what rdr_name - return [ L name_loc name | (_, name) <- names ] - what = text "fixity signature" - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM () -dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt loc $ - vcat [ text "Duplicate" <+> what_it_is - <> text "s for" <+> quotes (ppr name) - , text "at" <+> vcat (map ppr $ sort - $ map (getLoc . fst) - $ toList pairs) - ] - where - what_it_is = hsSigDoc sig - -misplacedSigErr :: LSig GhcRn -> RnM () -misplacedSigErr (L loc sig) - = addErrAt loc $ - sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] - -defaultSigErr :: Sig GhcPs -> SDoc -defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") - 2 (ppr sig) - , text "Use DefaultSignatures to enable default signatures" ] - -bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc -bindsInHsBootFile mbinds - = hang (text "Bindings in hs-boot files are not allowed") - 2 (ppr mbinds) - -nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc -nonStdGuardErr guards - = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") - 4 (interpp'SP guards) - -unusedPatBindWarn :: HsBind GhcRn -> SDoc -unusedPatBindWarn bind - = hang (text "This pattern-binding binds no variables:") - 2 (ppr bind) - -dupMinimalSigErr :: [LSig GhcPs] -> RnM () -dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt loc $ - vcat [ text "Multiple minimal complete definitions" - , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs) - , text "Combine alternative minimal complete definitions with `|'" ] -dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/rename/RnEnv.hs b/rename/RnEnv.hs deleted file mode 100644 --- a/rename/RnEnv.hs +++ /dev/null @@ -1,1699 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 - -RnEnv contains functions which convert RdrNames into Names. - --} - -{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-} - -module RnEnv ( - newTopSrcBinder, - lookupLocatedTopBndrRn, lookupTopBndrRn, - lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, - lookupLocalOccRn_maybe, lookupInfoOccRn, - lookupLocalOccThLvl_maybe, lookupLocalOccRn, - lookupTypeOccRn, - lookupGlobalOccRn, lookupGlobalOccRn_maybe, - lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc, - - ChildLookupResult(..), - lookupSubBndrOcc_helper, - combineChildLookupResult, -- Called by lookupChildrenExport - - HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, - lookupSigCtxtOccRn, - - lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, - lookupConstructorFields, - - lookupGreAvailRn, - - -- Rebindable Syntax - lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames, - lookupIfThenElse, - - -- Constructing usage information - addUsedGRE, addUsedGREs, addUsedDataCons, - - - - dataTcOccs, --TODO: Move this somewhere, into utils? - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import LoadIface ( loadInterfaceForName, loadSrcInterface_maybe ) -import IfaceEnv -import GHC.Hs -import RdrName -import HscTypes -import TcEnv -import TcRnMonad -import RdrHsSyn ( filterCTuple, setRdrNameSpace ) -import TysWiredIn -import Name -import NameSet -import NameEnv -import Avail -import Module -import ConLike -import DataCon -import TyCon -import ErrUtils ( MsgDoc ) -import PrelNames ( rOOT_MAIN ) -import BasicTypes ( pprWarningTxtForMsg, TopLevelFlag(..)) -import SrcLoc -import Outputable -import UniqSet ( uniqSetAny ) -import Util -import Maybes -import DynFlags -import FastString -import Control.Monad -import ListSetOps ( minusList ) -import qualified GHC.LanguageExtensions as LangExt -import RnUnbound -import RnUtils -import qualified Data.Semigroup as Semi -import Data.Either ( partitionEithers ) -import Data.List (find) - -{- -********************************************************* -* * - Source-code binders -* * -********************************************************* - -Note [Signature lazy interface loading] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC's lazy interface loading can be a bit confusing, so this Note is an -empirical description of what happens in one interesting case. When -compiling a signature module against an its implementation, we do NOT -load interface files associated with its names until after the type -checking phase. For example: - - module ASig where - data T - f :: T -> T - -Suppose we compile this with -sig-of "A is ASig": - - module B where - data T = T - f T = T - - module A(module B) where - import B - -During type checking, we'll load A.hi because we need to know what the -RdrEnv for the module is, but we DO NOT load the interface for B.hi! -It's wholly unnecessary: our local definition 'data T' in ASig is all -the information we need to finish type checking. This is contrast to -type checking of ordinary Haskell files, in which we would not have the -local definition "data T" and would need to consult B.hi immediately. -(Also, this situation never occurs for hs-boot files, since you're not -allowed to reexport from another module.) - -After type checking, we then check that the types we provided are -consistent with the backing implementation (in checkHiBootOrHsigIface). -At this point, B.hi is loaded, because we need something to compare -against. - -I discovered this behavior when trying to figure out why type class -instances for Data.Map weren't in the EPS when I was type checking a -test very much like ASig (sigof02dm): the associated interface hadn't -been loaded yet! (The larger issue is a moot point, since an instance -declared in a signature can never be a duplicate.) - -This behavior might change in the future. Consider this -alternate module B: - - module B where - {-# DEPRECATED T, f "Don't use" #-} - data T = T - f T = T - -One might conceivably want to report deprecation warnings when compiling -ASig with -sig-of B, in which case we need to look at B.hi to find the -deprecation warnings during renaming. At the moment, you don't get any -warning until you use the identifier further downstream. This would -require adjusting addUsedGRE so that during signature compilation, -we do not report deprecation warnings for LocalDef. See also -Note [Handling of deprecations] --} - -newTopSrcBinder :: Located RdrName -> RnM Name -newTopSrcBinder (L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = -- This is here to catch - -- (a) Exact-name binders created by Template Haskell - -- (b) The PrelBase defn of (say) [] and similar, for which - -- the parser reads the special syntax and returns an Exact RdrName - -- We are at a binding site for the name, so check first that it - -- the current module is the correct one; otherwise GHC can get - -- very confused indeed. This test rejects code like - -- data T = (,) Int Int - -- unless we are in GHC.Tup - if isExternalName name then - do { this_mod <- getModule - ; unless (this_mod == nameModule name) - (addErrAt loc (badOrigBinding rdr_name)) - ; return name } - else -- See Note [Binders in Template Haskell] in Convert.hs - do { this_mod <- getModule - ; externaliseName this_mod name } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { this_mod <- getModule - ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (addErrAt loc (badOrigBinding rdr_name)) - -- When reading External Core we get Orig names as binders, - -- but they should agree with the module gotten from the monad - -- - -- We can get built-in syntax showing up here too, sadly. If you type - -- data T = (,,,) - -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon - -- uses setRdrNameSpace to make it into a data constructors. At that point - -- the nice Exact name for the TyCon gets swizzled to an Orig name. - -- Hence the badOrigBinding error message. - -- - -- Except for the ":Main.main = ..." definition inserted into - -- the Main module; ugh! - - -- Because of this latter case, we call newGlobalBinder with a module from - -- the RdrName, not from the environment. In principle, it'd be fine to - -- have an arbitrary mixture of external core definitions in a single module, - -- (apart from module-initialisation issues, perhaps). - ; newGlobalBinder rdr_mod rdr_occ loc } - - | otherwise - = do { when (isQual rdr_name) - (addErrAt loc (badQualBndrErr rdr_name)) - -- Binders should not be qualified; if they are, and with a different - -- module name, we get a confusing "M.T is not in scope" error later - - ; stage <- getStage - ; if isBrackStage stage then - -- We are inside a TH bracket, so make an *Internal* name - -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames - do { uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - else - do { this_mod <- getModule - ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc) - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } - } - -{- -********************************************************* -* * - Source code occurrences -* * -********************************************************* - -Looking up a name in the RnEnv. - -Note [Type and class operator definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to reject all of these unless we have -XTypeOperators (#3265) - data a :*: b = ... - class a :*: b where ... - data (:*:) a b = .... - class (:*:) a b where ... -The latter two mean that we are not just looking for a -*syntactically-infix* declaration, but one that uses an operator -OccName. We use OccName.isSymOcc to detect that case, which isn't -terribly efficient, but there seems to be no better way. --} - --- Can be made to not be exposed --- Only used unwrapped in rnAnnProvenance -lookupTopBndrRn :: RdrName -> RnM Name -lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n - case nopt of - Just n' -> return n' - Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n) - unboundName WL_LocalTop n - -lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) -lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn - -lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) --- Look up a top-level source-code binder. We may be looking up an unqualified 'f', --- and there may be several imported 'f's too, which must not confuse us. --- For example, this is OK: --- import Foo( f ) --- infix 9 f -- The 'f' here does not need to be qualified --- f x = x -- Nor here, of course --- So we have to filter out the non-local ones. --- --- A separate function (importsFromLocalDecls) reports duplicate top level --- decls, so here it's safe just to choose an arbitrary one. --- --- There should never be a qualified name in a binding position in Haskell, --- but there can be if we have read in an external-Core file. --- The Haskell parser checks for the illegal qualified name in Haskell --- source files, so we don't need to do so here. - -lookupTopBndrRn_maybe rdr_name = - lookupExactOrOrig rdr_name Just $ - do { -- Check for operators in type or class declarations - -- See Note [Type and class operator definitions] - let occ = rdrNameOcc rdr_name - ; when (isTcOcc occ && isSymOcc occ) - (do { op_ok <- xoptM LangExt.TypeOperators - ; unless op_ok (addErr (opDeclErr rdr_name)) }) - - ; env <- getGlobalRdrEnv - ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of - [gre] -> return (Just (gre_name gre)) - _ -> return Nothing -- Ambiguous (can't happen) or unbound - } - ------------------------------------------------ --- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. --- This adds an error if the name cannot be found. -lookupExactOcc :: Name -> RnM Name -lookupExactOcc name - = do { result <- lookupExactOcc_either name - ; case result of - Left err -> do { addErr err - ; return name } - Right name' -> return name' } - --- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. --- This never adds an error, but it may return one. -lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) --- See Note [Looking up Exact RdrNames] -lookupExactOcc_either name - | Just thing <- wiredInNameTyThing_maybe name - , Just tycon <- case thing of - ATyCon tc -> Just tc - AConLike (RealDataCon dc) -> Just (dataConTyCon dc) - _ -> Nothing - , isTupleTyCon tycon - = do { checkTupSize (tyConArity tycon) - ; return (Right name) } - - | isExternalName name - = return (Right name) - - | otherwise - = do { env <- getGlobalRdrEnv - ; let -- See Note [Splicing Exact names] - main_occ = nameOccName name - demoted_occs = case demoteOccName main_occ of - Just occ -> [occ] - Nothing -> [] - gres = [ gre | occ <- main_occ : demoted_occs - , gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] - ; case gres of - [gre] -> return (Right (gre_name gre)) - - [] -> -- See Note [Splicing Exact names] - do { lcl_env <- getLocalRdrEnv - ; if name `inLocalRdrEnvScope` lcl_env - then return (Right name) - else - do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; th_topnames <- readTcRef th_topnames_var - ; if name `elemNameSet` th_topnames - then return (Right name) - else return (Left exact_nm_err) - } - } - gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] - } - where - exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) - 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " - , text "perhaps via newName, but did not bind it" - , text "If that's it, then -ddump-splices might be useful" ]) - -sameNameErr :: [GlobalRdrElt] -> MsgDoc -sameNameErr [] = panic "addSameNameErr: empty list" -sameNameErr gres@(_ : _) - = hang (text "Same exact name in multiple name-spaces:") - 2 (vcat (map pp_one sorted_names) $$ th_hint) - where - sorted_names = sortWith nameSrcLoc (map gre_name gres) - pp_one name - = hang (pprNameSpace (occNameSpace (getOccName name)) - <+> quotes (ppr name) <> comma) - 2 (text "declared at:" <+> ppr (nameSrcLoc name)) - - th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU)," - , text "perhaps via newName, in different name-spaces." - , text "If that's it, then -ddump-splices might be useful" ] - - ------------------------------------------------ -lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name --- This is called on the method name on the left-hand side of an --- instance declaration binding. eg. instance Functor T where --- fmap = ... --- ^^^^ called on this --- Regardless of how many unqualified fmaps are in scope, we want --- the one that comes from the Functor class. --- --- Furthermore, note that we take no account of whether the --- name is only in scope qualified. I.e. even if method op is --- in scope as M.op, we still allow plain 'op' on the LHS of --- an instance decl --- --- The "what" parameter says "method" or "associated type", --- depending on what we are looking up -lookupInstDeclBndr cls what rdr - = do { when (isQual rdr) - (addErr (badQualBndrErr rdr)) - -- In an instance decl you aren't allowed - -- to use a qualified name for the method - -- (Although it'd make perfect sense.) - ; mb_name <- lookupSubBndrOcc - False -- False => we don't give deprecated - -- warnings when a deprecated class - -- method is defined. We only warn - -- when it's used - cls doc rdr - ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr) } - Right nm -> return nm } - where - doc = what <+> text "of class" <+> quotes (ppr cls) - ------------------------------------------------ -lookupFamInstName :: Maybe Name -> Located RdrName - -> RnM (Located Name) --- Used for TyData and TySynonym family instances only, --- See Note [Family instance binders] -lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind - = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr -lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRn tc_rdr - ------------------------------------------------ -lookupConstructorFields :: Name -> RnM [FieldLabel] --- Look up the fields of a given constructor --- * For constructors from this module, use the record field env, --- which is itself gathered from the (as yet un-typechecked) --- data type decls --- --- * For constructors from imported modules, use the *type* environment --- since imported modles are already compiled, the info is conveniently --- right there - -lookupConstructorFields con_name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod con_name then - do { field_env <- getRecFieldEnv - ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) - ; return (lookupNameEnv field_env con_name `orElse` []) } - else - do { con <- tcLookupConLike con_name - ; traceTc "lookupCF 2" (ppr con) - ; return (conLikeFieldLabels con) } } - - --- In CPS style as `RnM r` is monadic -lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r -lookupExactOrOrig rdr_name res k - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = res <$> lookupExactOcc n - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = res <$> lookupOrig rdr_mod rdr_occ - | otherwise = k - - - ------------------------------------------------ --- | Look up an occurrence of a field in record construction or pattern --- matching (but not update). When the -XDisambiguateRecordFields --- flag is on, take account of the data constructor name to --- disambiguate which field to use. --- --- See Note [DisambiguateRecordFields]. -lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual - -- Just con => use data con to disambiguate - -> RdrName - -> RnM Name -lookupRecFieldOcc mb_con rdr_name - | Just con <- mb_con - , isUnboundName con -- Avoid error cascade - = return (mkUnboundNameRdr rdr_name) - | Just con <- mb_con - = do { flds <- lookupConstructorFields con - ; env <- getGlobalRdrEnv - ; let lbl = occNameFS (rdrNameOcc rdr_name) - mb_field = do fl <- find ((== lbl) . flLabel) flds - -- We have the label, now check it is in - -- scope (with the correct qualifier if - -- there is one, hence calling pickGREs). - gre <- lookupGRE_FieldLabel env fl - guard (not (isQual rdr_name - && null (pickGREs rdr_name [gre]))) - return (fl, gre) - ; case mb_field of - Just (fl, gre) -> do { addUsedGRE True gre - ; return (flSelector fl) } - Nothing -> lookupGlobalOccRn rdr_name } - -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] - | otherwise - -- This use of Global is right as we are looking up a selector which - -- can only be defined at the top level. - = lookupGlobalOccRn rdr_name - -{- Note [DisambiguateRecordFields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are looking up record fields in record construction or pattern -matching, we can take advantage of the data constructor name to -resolve fields that would otherwise be ambiguous (provided the --XDisambiguateRecordFields flag is on). - -For example, consider: - - data S = MkS { x :: Int } - data T = MkT { x :: Int } - - e = MkS { x = 3 } - -When we are renaming the occurrence of `x` in `e`, instead of looking -`x` up directly (and finding both fields), lookupRecFieldOcc will -search the fields of `MkS` to find the only possible `x` the user can -mean. - -Of course, we still have to check the field is in scope, using -lookupGRE_FieldLabel. The handling of qualified imports is slightly -subtle: the occurrence may be unqualified even if the field is -imported only qualified (but if the occurrence is qualified, the -qualifier must be correct). For example: - - module A where - data S = MkS { x :: Int } - data T = MkT { x :: Int } - - module B where - import qualified A (S(..)) - import A (T(MkT)) - - e1 = MkT { x = 3 } -- x not in scope, so fail - e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail - e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) - -In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, -lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard -will fail because the field RdrName `B.x` is qualified and pickGREs -rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the -GRE for `A.x` and the guard will succeed because the field RdrName `x` -is unqualified. - - -Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Whenever we fail to find the field or it is not in scope, mb_field -will be False, and we fall back on looking it up normally using -lookupGlobalOccRn. We don't report an error immediately because the -actual problem might be located elsewhere. For example (#9975): - - data Test = Test { x :: Int } - pattern Test wat = Test { x = wat } - -Here there are multiple declarations of Test (as a data constructor -and as a pattern synonym), which will be reported as an error. We -shouldn't also report an error about the occurrence of `x` in the -pattern synonym RHS. However, if the pattern synonym gets added to -the environment first, we will try and fail to find `x` amongst the -(nonexistent) fields of the pattern synonym. - -Alternatively, the scope check can fail due to Template Haskell. -Consider (#12130): - - module Foo where - import M - b = $(funny) - - module M(funny) where - data T = MkT { x :: Int } - funny :: Q Exp - funny = [| MkT { x = 3 } |] - -When we splice, `MkT` is not lexically in scope, so -lookupGRE_FieldLabel will fail. But there is no need for -disambiguation anyway, because `x` is an original name, and -lookupGlobalOccRn will find it. --} - - - --- | Used in export lists to lookup the children. -lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName - -> RnM ChildLookupResult -lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name - | isUnboundName parent - -- Avoid an error cascade - = return (FoundName NoParent (mkUnboundNameRdr rdr_name)) - - | otherwise = do - gre_env <- getGlobalRdrEnv - - let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) - -- Disambiguate the lookup based on the parent information. - -- The remaining GREs are things that we *could* export here, note that - -- this includes things which have `NoParent`. Those are sorted in - -- `checkPatSynParent`. - traceRn "parent" (ppr parent) - traceRn "lookupExportChild original_gres:" (ppr original_gres) - traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres) - case picked_gres original_gres of - NoOccurrence -> - noMatchingParentErr original_gres - UniqueOccurrence g -> - if must_have_parent then noMatchingParentErr original_gres - else checkFld g - DisambiguatedOccurrence g -> - checkFld g - AmbiguousOccurrence gres -> - mkNameClashErr gres - where - -- Convert into FieldLabel if necessary - checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name, gre_par} = do - addUsedGRE warn_if_deprec g - return $ case gre_par of - FldParent _ mfs -> - FoundFL (fldParentToFieldLabel gre_name mfs) - _ -> FoundName gre_par gre_name - - fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel - fldParentToFieldLabel name mfs = - case mfs of - Nothing -> - let fs = occNameFS (nameOccName name) - in FieldLabel fs False name - Just fs -> FieldLabel fs True name - - -- Called when we find no matching GREs after disambiguation but - -- there are three situations where this happens. - -- 1. There were none to begin with. - -- 2. None of the matching ones were the parent but - -- a. They were from an overloaded record field so we can report - -- a better error - -- b. The original lookup was actually ambiguous. - -- For example, the case where overloading is off and two - -- record fields are in scope from different record - -- constructors, neither of which is the parent. - noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult - noMatchingParentErr original_gres = do - overload_ok <- xoptM LangExt.DuplicateRecordFields - case original_gres of - [] -> return NameNotFound - [g] -> return $ IncorrectParent parent - (gre_name g) (ppr $ gre_name g) - [p | Just p <- [getParent g]] - gss@(g:_:_) -> - if all isRecFldGRE gss && overload_ok - then return $ - IncorrectParent parent - (gre_name g) - (ppr $ expectJust "noMatchingParentErr" (greLabel g)) - [p | x <- gss, Just p <- [getParent x]] - else mkNameClashErr gss - - mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult - mkNameClashErr gres = do - addNameClashErrRn rdr_name gres - return (FoundName (gre_par (head gres)) (gre_name (head gres))) - - getParent :: GlobalRdrElt -> Maybe Name - getParent (GRE { gre_par = p } ) = - case p of - ParentIs cur_parent -> Just cur_parent - FldParent { par_is = cur_parent } -> Just cur_parent - NoParent -> Nothing - - picked_gres :: [GlobalRdrElt] -> DisambigInfo - -- For Unqual, find GREs that are in scope qualified or unqualified - -- For Qual, find GREs that are in scope with that qualification - picked_gres gres - | isUnqual rdr_name - = mconcat (map right_parent gres) - | otherwise - = mconcat (map right_parent (pickGREs rdr_name gres)) - - right_parent :: GlobalRdrElt -> DisambigInfo - right_parent p - = case getParent p of - Just cur_parent - | parent == cur_parent -> DisambiguatedOccurrence p - | otherwise -> NoOccurrence - Nothing -> UniqueOccurrence p - - --- This domain specific datatype is used to record why we decided it was --- possible that a GRE could be exported with a parent. -data DisambigInfo - = NoOccurrence - -- The GRE could never be exported. It has the wrong parent. - | UniqueOccurrence GlobalRdrElt - -- The GRE has no parent. It could be a pattern synonym. - | DisambiguatedOccurrence GlobalRdrElt - -- The parent of the GRE is the correct parent - | AmbiguousOccurrence [GlobalRdrElt] - -- For example, two normal identifiers with the same name are in - -- scope. They will both be resolved to "UniqueOccurrence" and the - -- monoid will combine them to this failing case. - -instance Outputable DisambigInfo where - ppr NoOccurrence = text "NoOccurence" - ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre - ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre - ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres - -instance Semi.Semigroup DisambigInfo where - -- This is the key line: We prefer disambiguated occurrences to other - -- names. - _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' - DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' - - NoOccurrence <> m = m - m <> NoOccurrence = m - UniqueOccurrence g <> UniqueOccurrence g' - = AmbiguousOccurrence [g, g'] - UniqueOccurrence g <> AmbiguousOccurrence gs - = AmbiguousOccurrence (g:gs) - AmbiguousOccurrence gs <> UniqueOccurrence g' - = AmbiguousOccurrence (g':gs) - AmbiguousOccurrence gs <> AmbiguousOccurrence gs' - = AmbiguousOccurrence (gs ++ gs') - -instance Monoid DisambigInfo where - mempty = NoOccurrence - mappend = (Semi.<>) - --- Lookup SubBndrOcc can never be ambiguous --- --- Records the result of looking up a child. -data ChildLookupResult - = NameNotFound -- We couldn't find a suitable name - | IncorrectParent Name -- Parent - Name -- Name of thing we were looking for - SDoc -- How to print the name - [Name] -- List of possible parents - | FoundName Parent Name -- We resolved to a normal name - | FoundFL FieldLabel -- We resolved to a FL - --- | Specialised version of msum for RnM ChildLookupResult -combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult -combineChildLookupResult [] = return NameNotFound -combineChildLookupResult (x:xs) = do - res <- x - case res of - NameNotFound -> combineChildLookupResult xs - _ -> return res - -instance Outputable ChildLookupResult where - ppr NameNotFound = text "NameNotFound" - ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n - ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls - ppr (IncorrectParent p n td ns) = text "IncorrectParent" - <+> hsep [ppr p, ppr n, td, ppr ns] - -lookupSubBndrOcc :: Bool - -> Name -- Parent - -> SDoc - -> RdrName - -> RnM (Either MsgDoc Name) --- Find all the things the rdr-name maps to --- and pick the one with the right parent namep -lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do - res <- - lookupExactOrOrig rdr_name (FoundName NoParent) $ - -- This happens for built-in classes, see mod052 for example - lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name - case res of - NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) - FoundName _p n -> return (Right n) - FoundFL fl -> return (Right (flSelector fl)) - IncorrectParent {} - -- See [Mismatched class methods and associated type families] - -- in TcInstDecls. - -> return $ Left (unknownSubordinateErr doc rdr_name) - -{- -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family F a - data instance F T = X1 | X2 - -The 'data instance' decl has an *occurrence* of F (and T), and *binds* -X1 and X2. (This is unlike a normal data type declaration which would -bind F too.) So we want an AvailTC F [X1,X2]. - -Now consider a similar pair: - class C a where - data G a - instance C S where - data G S = Y1 | Y2 - -The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. - -But there is a small complication: in an instance decl, we don't use -qualified names on the LHS; instead we use the class to disambiguate. -Thus: - module M where - import Blib( G ) - class C a where - data G a - instance C S where - data G S = Y1 | Y2 -Even though there are two G's in scope (M.G and Blib.G), the occurrence -of 'G' in the 'instance C S' decl is unambiguous, because C has only -one associated type called G. This is exactly what happens for methods, -and it is only consistent to do the same thing for types. That's the -role of the function lookupTcdName; the (Maybe Name) give the class of -the encloseing instance decl, if any. - -Note [Looking up Exact RdrNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames are generated by Template Haskell. See Note [Binders -in Template Haskell] in Convert. - -For data types and classes have Exact system Names in the binding -positions for constructors, TyCons etc. For example - [d| data T = MkT Int |] -when we splice in and Convert to HsSyn RdrName, we'll get - data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... -These System names are generated by Convert.thRdrName - -But, constructors and the like need External Names, not System Names! -So we do the following - - * In RnEnv.newTopSrcBinder we spot Exact RdrNames that wrap a - non-External Name, and make an External name for it. This is - the name that goes in the GlobalRdrEnv - - * When looking up an occurrence of an Exact name, done in - RnEnv.lookupExactOcc, we find the Name with the right unique in the - GlobalRdrEnv, and use the one from the envt -- it will be an - External Name in the case of the data type/constructor above. - - * Exact names are also use for purely local binders generated - by TH, such as \x_33. x_33 - Both binder and occurrence are Exact RdrNames. The occurrence - gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and - misses, because lookupLocalRdrEnv always returns Nothing for - an Exact Name. Now we fall through to lookupExactOcc, which - will find the Name is not in the GlobalRdrEnv, so we just use - the Exact supplied Name. - -Note [Splicing Exact names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the splice $(do { x <- newName "x"; return (VarE x) }) -This will generate a (HsExpr RdrName) term that mentions the -Exact RdrName "x_56" (or whatever), but does not bind it. So -when looking such Exact names we want to check that it's in scope, -otherwise the type checker will get confused. To do this we need to -keep track of all the Names in scope, and the LocalRdrEnv does just that; -we consult it with RdrName.inLocalRdrEnvScope. - -There is another wrinkle. With TH and -XDataKinds, consider - $( [d| data Nat = Zero - data T = MkT (Proxy 'Zero) |] ) -After splicing, but before renaming we get this: - data Nat_77{tc} = Zero_78{d} - data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) -The occurrence of 'Zero in the data type for T has the right unique, -but it has a TcClsName name-space in its OccName. (This is set by -the ctxt_ns argument of Convert.thRdrName.) When we check that is -in scope in the GlobalRdrEnv, we need to look up the DataName namespace -too. (An alternative would be to make the GlobalRdrEnv also have -a Name -> GRE mapping.) - -Note [Template Haskell ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The GlobalRdrEnv invariant says that if - occ -> [gre1, ..., gren] -then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). -This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). - -So how can we get multiple gres in lookupExactOcc_maybe? Because in -TH we might use the same TH NameU in two different name spaces. -eg (#7241): - $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) -Here we generate a type constructor and data constructor with the same -unique, but different name spaces. - -It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would -mean looking up the OccName in every name-space, just in case, and that -seems a bit brutal. So it's just done here on lookup. But we might -need to revisit that choice. - -Note [Usage for sub-bndrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have this - import qualified M( C( f ) ) - instance M.C T where - f x = x -then is the qualified import M.f used? Obviously yes. -But the RdrName used in the instance decl is unqualified. In effect, -we fill in the qualification by looking for f's whose class is M.C -But when adding to the UsedRdrNames we must make that qualification -explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". - -So we make up a suitable (fake) RdrName. But be careful - import qualified M - import M( C(f) ) - instance C T where - f x = x -Here we want to record a use of 'f', not of 'M.f', otherwise -we'll miss the fact that the qualified import is redundant. - --------------------------------------------------- --- Occurrences --------------------------------------------------- --} - - -lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedOccRn = wrapLocM lookupOccRn - -lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Just look in the local environment -lookupLocalOccRn_maybe rdr_name - = do { local_env <- getLocalRdrEnv - ; return (lookupLocalRdrEnv local_env rdr_name) } - -lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) --- Just look in the local environment -lookupLocalOccThLvl_maybe name - = do { lcl_env <- getLclEnv - ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } - --- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn :: RdrName -> RnM Name -lookupOccRn rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> reportUnboundName rdr_name } - --- Only used in one place, to rename pattern synonym binders. --- See Note [Renaming pattern synonym variables] in RnBinds -lookupLocalOccRn :: RdrName -> RnM Name -lookupLocalOccRn rdr_name - = do { mb_name <- lookupLocalOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> unboundName WL_LocalOnly rdr_name } - --- lookupPromotedOccRn looks up an optionally promoted RdrName. -lookupTypeOccRn :: RdrName -> RnM Name --- see Note [Demotion] -lookupTypeOccRn rdr_name - | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] - = badVarInType rdr_name - | otherwise - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> lookup_demoted rdr_name } - -lookup_demoted :: RdrName -> RnM Name -lookup_demoted rdr_name - | Just demoted_rdr <- demoteRdrName rdr_name - -- Maybe it's the name of a *data* constructor - = do { data_kinds <- xoptM LangExt.DataKinds - ; star_is_type <- xoptM LangExt.StarIsType - ; let star_info = starInfo star_is_type rdr_name - ; if data_kinds - then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr - ; case mb_demoted_name of - Nothing -> unboundNameX WL_Any rdr_name star_info - Just demoted_name -> - do { whenWOptM Opt_WarnUntickedPromotedConstructors $ - addWarn - (Reason Opt_WarnUntickedPromotedConstructors) - (untickedPromConstrWarn demoted_name) - ; return demoted_name } } - else do { -- We need to check if a data constructor of this name is - -- in scope to give good error messages. However, we do - -- not want to give an additional error if the data - -- constructor happens to be out of scope! See #13947. - mb_demoted_name <- discardErrs $ - lookupOccRn_maybe demoted_rdr - ; let suggestion | isJust mb_demoted_name = suggest_dk - | otherwise = star_info - ; unboundNameX WL_Any rdr_name suggestion } } - - | otherwise - = reportUnboundName rdr_name - - where - suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?" - untickedPromConstrWarn name = - text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot - $$ - hsep [ text "Use" - , quotes (char '\'' <> ppr name) - , text "instead of" - , quotes (ppr name) <> dot ] - -badVarInType :: RdrName -> RnM Name -badVarInType rdr_name - = do { addErr (text "Illegal promoted term variable in a type:" - <+> ppr rdr_name) - ; return (mkUnboundNameRdr rdr_name) } - -{- Note [Promoted variables in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#12686): - x = True - data Bad = Bad 'x - -The parser treats the quote in 'x as saying "use the term -namespace", so we'll get (Bad x{v}), with 'x' in the -VarName namespace. If we don't test for this, the renamer -will happily rename it to the x bound at top level, and then -the typecheck falls over because it doesn't have 'x' in scope -when kind-checking. - -Note [Demotion] -~~~~~~~~~~~~~~~ -When the user writes: - data Nat = Zero | Succ Nat - foo :: f Zero -> Int - -'Zero' in the type signature of 'foo' is parsed as: - HsTyVar ("Zero", TcClsName) - -When the renamer hits this occurrence of 'Zero' it's going to realise -that it's not in scope. But because it is renaming a type, it knows -that 'Zero' might be a promoted data constructor, so it will demote -its namespace to DataName and do a second lookup. - -The final result (after the renamer) will be: - HsTyVar ("Zero", DataName) --} - -lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName - -> RnM (Maybe r) -lookupOccRnX_maybe globalLookup wrapper rdr_name - = runMaybeT . msum . map MaybeT $ - [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name - , globalLookup rdr_name ] - -lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) -lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id - -lookupOccRn_overloaded :: Bool -> RdrName - -> RnM (Maybe (Either Name [Name])) -lookupOccRn_overloaded overload_ok - = lookupOccRnX_maybe global_lookup Left - where - global_lookup :: RdrName -> RnM (Maybe (Either Name [Name])) - global_lookup n = - runMaybeT . msum . map MaybeT $ - [ lookupGlobalOccRn_overloaded overload_ok n - , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ] - - - -lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Looks up a RdrName occurrence in the top-level --- environment, including using lookupQualifiedNameGHCi --- for the GHCi case --- No filter function; does not report an error on failure --- Uses addUsedRdrName to record use and deprecations -lookupGlobalOccRn_maybe rdr_name = - lookupExactOrOrig rdr_name Just $ - runMaybeT . msum . map MaybeT $ - [ fmap gre_name <$> lookupGreRn_maybe rdr_name - , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ] - -- This test is not expensive, - -- and only happens for failed lookups - -lookupGlobalOccRn :: RdrName -> RnM Name --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. Adds an error message if the RdrName is not in scope. --- You usually want to use "lookupOccRn" which also looks in the local --- environment. -lookupGlobalOccRn rdr_name - = do { mb_name <- lookupGlobalOccRn_maybe rdr_name - ; case mb_name of - Just n -> return n - Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) - ; unboundName WL_Global rdr_name } } - -lookupInfoOccRn :: RdrName -> RnM [Name] --- lookupInfoOccRn is intended for use in GHCi's ":info" command --- It finds all the GREs that RdrName could mean, not complaining --- about ambiguity, but rather returning them all --- C.f. #9881 --- lookupInfoOccRn is also used in situations where we check for --- at least one definition of the RdrName, not complaining about --- multiple definitions. (See #17832) -lookupInfoOccRn rdr_name = - lookupExactOrOrig rdr_name (:[]) $ - do { rdr_env <- getGlobalRdrEnv - ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) - ; qual_ns <- lookupQualifiedNameGHCi rdr_name - ; return (ns ++ (qual_ns `minusList` ns)) } - --- | Like 'lookupOccRn_maybe', but with a more informative result if --- the 'RdrName' happens to be a record selector: --- --- * Nothing -> name not in scope (no error reported) --- * Just (Left x) -> name uniquely refers to x, --- or there is a name clash (reported) --- * Just (Right xs) -> name refers to one or more record selectors; --- if overload_ok was False, this list will be --- a singleton. - -lookupGlobalOccRn_overloaded :: Bool -> RdrName - -> RnM (Maybe (Either Name [Name])) -lookupGlobalOccRn_overloaded overload_ok rdr_name = - lookupExactOrOrig rdr_name (Just . Left) $ - do { res <- lookupGreRn_helper rdr_name - ; case res of - GreNotFound -> return Nothing - OneNameMatch gre -> do - let wrapper = if isRecFldGRE gre then Right . (:[]) else Left - return $ Just (wrapper (gre_name gre)) - MultipleNames gres | all isRecFldGRE gres && overload_ok -> - -- Don't record usage for ambiguous selectors - -- until we know which is meant - return $ Just (Right (map gre_name gres)) - MultipleNames gres -> do - addNameClashErrRn rdr_name gres - return (Just (Left (gre_name (head gres)))) } - - --------------------------------------------------- --- Lookup in the Global RdrEnv of the module --------------------------------------------------- - -data GreLookupResult = GreNotFound - | OneNameMatch GlobalRdrElt - | MultipleNames [GlobalRdrElt] - -lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) --- Look up the RdrName in the GlobalRdrEnv --- Exactly one binding: records it as "used", return (Just gre) --- No bindings: return Nothing --- Many bindings: report "ambiguous", return an arbitrary (Just gre) --- Uses addUsedRdrName to record use and deprecations -lookupGreRn_maybe rdr_name - = do - res <- lookupGreRn_helper rdr_name - case res of - OneNameMatch gre -> return $ Just gre - MultipleNames gres -> do - traceRn "lookupGreRn_maybe:NameClash" (ppr gres) - addNameClashErrRn rdr_name gres - return $ Just (head gres) - GreNotFound -> return Nothing - -{- - -Note [ Unbound vs Ambiguous Names ] - -lookupGreRn_maybe deals with failures in two different ways. If a name -is unbound then we return a `Nothing` but if the name is ambiguous -then we raise an error and return a dummy name. - -The reason for this is that when we call `lookupGreRn_maybe` we are -speculatively looking for whatever we are looking up. If we don't find it, -then we might have been looking for the wrong thing and can keep trying. -On the other hand, if we find a clash then there is no way to recover as -we found the thing we were looking for but can no longer resolve which -the correct one is. - -One example of this is in `lookupTypeOccRn` which first looks in the type -constructor namespace before looking in the data constructor namespace to -deal with `DataKinds`. - -There is however, as always, one exception to this scheme. If we find -an ambiguous occurence of a record selector and DuplicateRecordFields -is enabled then we defer the selection until the typechecker. - --} - - - - --- Internal Function -lookupGreRn_helper :: RdrName -> RnM GreLookupResult -lookupGreRn_helper rdr_name - = do { env <- getGlobalRdrEnv - ; case lookupGRE_RdrName rdr_name env of - [] -> return GreNotFound - [gre] -> do { addUsedGRE True gre - ; return (OneNameMatch gre) } - gres -> return (MultipleNames gres) } - -lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) --- Used in export lists --- If not found or ambiguous, add error message, and fake with UnboundName --- Uses addUsedRdrName to record use and deprecations -lookupGreAvailRn rdr_name - = do - mb_gre <- lookupGreRn_helper rdr_name - case mb_gre of - GreNotFound -> - do - traceRn "lookupGreAvailRn" (ppr rdr_name) - name <- unboundName WL_Global rdr_name - return (name, avail name) - MultipleNames gres -> - do - addNameClashErrRn rdr_name gres - let unbound_name = mkUnboundNameRdr rdr_name - return (unbound_name, avail unbound_name) - -- Returning an unbound name here prevents an error - -- cascade - OneNameMatch gre -> - return (gre_name gre, availFromGRE gre) - - -{- -********************************************************* -* * - Deprecations -* * -********************************************************* - -Note [Handling of deprecations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We report deprecations at each *occurrence* of the deprecated thing - (see #5867) - -* We do not report deprecations for locally-defined names. For a - start, we may be exporting a deprecated thing. Also we may use a - deprecated thing in the defn of another deprecated things. We may - even use a deprecated thing in the defn of a non-deprecated thing, - when changing a module's interface. - -* addUsedGREs: we do not report deprecations for sub-binders: - - the ".." completion for records - - the ".." in an export item 'T(..)' - - the things exported by a module export 'module M' --} - -addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () --- Remember use of in-scope data constructors (#7969) -addUsedDataCons rdr_env tycon - = addUsedGREs [ gre - | dc <- tyConDataCons tycon - , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] - -addUsedGRE :: Bool -> GlobalRdrElt -> RnM () --- Called for both local and imported things --- Add usage *and* warn if deprecated -addUsedGRE warn_if_deprec gre - = do { when warn_if_deprec (warnIfDeprecated gre) - ; unless (isLocalGRE gre) $ - do { env <- getGblEnv - ; traceRn "addUsedGRE" (ppr gre) - ; updMutVar (tcg_used_gres env) (gre :) } } - -addUsedGREs :: [GlobalRdrElt] -> RnM () --- Record uses of any *imported* GREs --- Used for recording used sub-bndrs --- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] -addUsedGREs gres - | null imp_gres = return () - | otherwise = do { env <- getGblEnv - ; traceRn "addUsedGREs" (ppr imp_gres) - ; updMutVar (tcg_used_gres env) (imp_gres ++) } - where - imp_gres = filterOut isLocalGRE gres - -warnIfDeprecated :: GlobalRdrElt -> RnM () -warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) - | (imp_spec : _) <- iss - = do { dflags <- getDynFlags - ; this_mod <- getModule - ; when (wopt Opt_WarnWarningsDeprecations dflags && - not (nameIsLocalOrFrom this_mod name)) $ - -- See Note [Handling of deprecations] - do { iface <- loadInterfaceForName doc name - ; case lookupImpDeprec iface gre of - Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations) - (mk_msg imp_spec txt) - Nothing -> return () } } - | otherwise - = return () - where - occ = greOccName gre - name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") - - mk_msg imp_spec txt - = sep [ sep [ text "In the use of" - <+> pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ) - , parens imp_msg <> colon ] - , pprWarningTxtForMsg txt ] - where - imp_mod = importSpecModule imp_spec - imp_msg = text "imported from" <+> ppr imp_mod <> extra - extra | imp_mod == moduleName name_mod = Outputable.empty - | otherwise = text ", but defined in" <+> ppr name_mod - -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt -lookupImpDeprec iface gre - = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, - case gre_par gre of -- or its parent, is warn'd - ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) - FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p) - NoParent -> Nothing - -{- -Note [Used names with interface not loaded] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's (just) possible to find a used -Name whose interface hasn't been loaded: - -a) It might be a WiredInName; in that case we may not load - its interface (although we could). - -b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger - These are seen as "used" by the renamer (if -XRebindableSyntax) - is on), but the typechecker may discard their uses - if in fact the in-scope fromRational is GHC.Read.fromRational, - (see tcPat.tcOverloadedLit), and the typechecker sees that the type - is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). - In that obscure case it won't force the interface in. - -In both cases we simply don't permit deprecations; -this is, after all, wired-in stuff. - - -********************************************************* -* * - GHCi support -* * -********************************************************* - -A qualified name on the command line can refer to any module at -all: we try to load the interface if we don't already have it, just -as if there was an "import qualified M" declaration for every -module. - -For example, writing `Data.List.sort` will load the interface file for -`Data.List` as if the user had written `import qualified Data.List`. - -If we fail we just return Nothing, rather than bleating -about "attempting to use module ‘D’ (./D.hs) which is not loaded" -which is what loadSrcInterface does. - -It is enabled by default and disabled by the flag -`-fno-implicit-import-qualified`. - -Note [Safe Haskell and GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We DON'T do this Safe Haskell as we need to check imports. We can -and should instead check the qualified import but at the moment -this requires some refactoring so leave as a TODO --} - - - -lookupQualifiedNameGHCi :: RdrName -> RnM [Name] -lookupQualifiedNameGHCi rdr_name - = -- We want to behave as we would for a source file import here, - -- and respect hiddenness of modules/packages, hence loadSrcInterface. - do { dflags <- getDynFlags - ; is_ghci <- getIsGHCi - ; go_for_it dflags is_ghci } - - where - go_for_it dflags is_ghci - | Just (mod,occ) <- isQual_maybe rdr_name - , is_ghci - , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour - , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] - = do { res <- loadSrcInterface_maybe doc mod False Nothing - ; case res of - Succeeded iface - -> return [ name - | avail <- mi_exports iface - , name <- availNames avail - , nameOccName name == occ ] - - _ -> -- Either we couldn't load the interface, or - -- we could but we didn't find the name in it - do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) - ; return [] } } - - | otherwise - = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) - ; return [] } - - doc = text "Need to find" <+> ppr rdr_name - -{- -Note [Looking up signature names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -lookupSigOccRn is used for type signatures and pragmas -Is this valid? - module A - import M( f ) - f :: Int -> Int - f x = x -It's clear that the 'f' in the signature must refer to A.f -The Haskell98 report does not stipulate this, but it will! -So we must treat the 'f' in the signature in the same way -as the binding occurrence of 'f', using lookupBndrRn - -However, consider this case: - import M( f ) - f :: Int -> Int - g x = x -We don't want to say 'f' is out of scope; instead, we want to -return the imported 'f', so that later on the renamer will -correctly report "misplaced type sig". - -Note [Signatures for top level things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -data HsSigCtxt = ... | TopSigCtxt NameSet | .... - -* The NameSet says what is bound in this group of bindings. - We can't use isLocalGRE from the GlobalRdrEnv, because of this: - f x = x - $( ...some TH splice... ) - f :: Int -> Int - When we encounter the signature for 'f', the binding for 'f' - will be in the GlobalRdrEnv, and will be a LocalDef. Yet the - signature is mis-placed - -* For type signatures the NameSet should be the names bound by the - value bindings; for fixity declarations, the NameSet should also - include class sigs and record selectors - - infix 3 `f` -- Yes, ok - f :: C a => a -> a -- No, not ok - class C a where - f :: a -> a --} - -data HsSigCtxt - = TopSigCtxt NameSet -- At top level, binding these names - -- See Note [Signatures for top level things] - | LocalBindCtxt NameSet -- In a local binding, binding these names - | ClsDeclCtxt Name -- Class decl for this class - | InstDeclCtxt NameSet -- Instance decl whose user-written method - -- bindings are for these methods - | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names - | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types - -- in the group - -instance Outputable HsSigCtxt where - ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns - ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns - ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n - ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns - ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns - ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns - -lookupSigOccRn :: HsSigCtxt - -> Sig GhcPs - -> Located RdrName -> RnM (Located Name) -lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) - --- | Lookup a name in relation to the names in a 'HsSigCtxt' -lookupSigCtxtOccRn :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> Located RdrName -> RnM (Located Name) -lookupSigCtxtOccRn ctxt what - = wrapLocM $ \ rdr_name -> - do { mb_name <- lookupBindGroupOcc ctxt what rdr_name - ; case mb_name of - Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } - Right name -> return name } - -lookupBindGroupOcc :: HsSigCtxt - -> SDoc - -> RdrName -> RnM (Either MsgDoc Name) --- Looks up the RdrName, expecting it to resolve to one of the --- bound names passed in. If not, return an appropriate error message --- --- See Note [Looking up signature names] -lookupBindGroupOcc ctxt what rdr_name - | Just n <- isExact_maybe rdr_name - = lookupExactOcc_either n -- allow for the possibility of missing Exacts; - -- see Note [dataTcOccs and Exact Names] - -- Maybe we should check the side conditions - -- but it's a pain, and Exact things only show - -- up when you know what you are doing - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n' <- lookupOrig rdr_mod rdr_occ - ; return (Right n') } - - | otherwise - = case ctxt of - HsBootCtxt ns -> lookup_top (`elemNameSet` ns) - TopSigCtxt ns -> lookup_top (`elemNameSet` ns) - RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) - LocalBindCtxt ns -> lookup_group ns - ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 - then return (Right $ mkUnboundNameRdr rdr_name) - else lookup_top (`elemNameSet` ns) - where - lookup_cls_op cls - = lookupSubBndrOcc True cls doc rdr_name - where - doc = text "method of class" <+> quotes (ppr cls) - - lookup_top keep_me - = do { env <- getGlobalRdrEnv - ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - names_in_scope = -- If rdr_name lacks a binding, only - -- recommend alternatives from related - -- namespaces. See #17593. - filter (\n -> nameSpacesRelated - (rdrNameSpace rdr_name) - (nameNameSpace n)) - $ map gre_name - $ filter isLocalGRE - $ globalRdrEnvElts env - candidates_msg = candidates names_in_scope - ; case filter (keep_me . gre_name) all_gres of - [] | null all_gres -> bale_out_with candidates_msg - | otherwise -> bale_out_with local_msg - (gre:_) -> return (Right (gre_name gre)) } - - lookup_group bound_names -- Look in the local envt (not top level) - = do { mname <- lookupLocalOccRn_maybe rdr_name - ; env <- getLocalRdrEnv - ; let candidates_msg = candidates $ localRdrEnvElts env - ; case mname of - Just n - | n `elemNameSet` bound_names -> return (Right n) - | otherwise -> bale_out_with local_msg - Nothing -> bale_out_with candidates_msg } - - bale_out_with msg - = return (Left (sep [ text "The" <+> what - <+> text "for" <+> quotes (ppr rdr_name) - , nest 2 $ text "lacks an accompanying binding"] - $$ nest 2 msg)) - - local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where") - <+> quotes (ppr rdr_name) <+> text "is declared" - - -- Identify all similar names and produce a message listing them - candidates :: [Name] -> MsgDoc - candidates names_in_scope - = case similar_names of - [] -> Outputable.empty - [n] -> text "Perhaps you meant" <+> pp_item n - _ -> sep [ text "Perhaps you meant one of these:" - , nest 2 (pprWithCommas pp_item similar_names) ] - where - similar_names - = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) - $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) - names_in_scope - - pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) - - ---------------- -lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] --- GHC extension: look up both the tycon and data con or variable. --- Used for top-level fixity signatures and deprecations. --- Complain if neither is in scope. --- See Note [Fixity signature lookup] -lookupLocalTcNames ctxt what rdr_name - = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) - ; let (errs, names) = partitionEithers mb_gres - ; when (null names) $ addErr (head errs) -- Bleat about one only - ; return names } - where - lookup rdr = do { this_mod <- getModule - ; nameEither <- lookupBindGroupOcc ctxt what rdr - ; return (guard_builtin_syntax this_mod rdr nameEither) } - - -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 - guard_builtin_syntax this_mod rdr (Right name) - | Just _ <- isBuiltInOcc_maybe (occName rdr) - , this_mod /= nameModule name - = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr]) - | otherwise - = Right (rdr, name) - guard_builtin_syntax _ _ (Left err) = Left err - -dataTcOccs :: RdrName -> [RdrName] --- Return both the given name and the same name promoted to the TcClsName --- namespace. This is useful when we aren't sure which we are looking at. --- See also Note [dataTcOccs and Exact Names] -dataTcOccs rdr_name - | isDataOcc occ || isVarOcc occ - = [rdr_name, rdr_name_tc] - | otherwise - = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - -{- -Note [dataTcOccs and Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames can occur in code generated by Template Haskell, and generally -those references are, well, exact. However, the TH `Name` type isn't expressive -enough to always track the correct namespace information, so we sometimes get -the right Unique but wrong namespace. Thus, we still have to do the double-lookup -for Exact RdrNames. - -There is also an awkward situation for built-in syntax. Example in GHCi - :info [] -This parses as the Exact RdrName for nilDataCon, but we also want -the list type constructor. - -Note that setRdrNameSpace on an Exact name requires the Name to be External, -which it always is for built in syntax. --} - - - -{- -************************************************************************ -* * - Rebindable names - Dealing with rebindable syntax is driven by the - Opt_RebindableSyntax dynamic flag. - - In "deriving" code we don't want to use rebindable syntax - so we switch off the flag locally - -* * -************************************************************************ - -Haskell 98 says that when you say "3" you get the "fromInteger" from the -Standard Prelude, regardless of what is in scope. However, to experiment -with having a language that is less coupled to the standard prelude, we're -trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" -happens to be in scope. Then you can - import Prelude () - import MyPrelude as Prelude -to get the desired effect. - -At the moment this just happens for - * fromInteger, fromRational on literals (in expressions and patterns) - * negate (in expressions) - * minus (arising from n+k patterns) - * "do" notation - -We store the relevant Name in the HsSyn tree, in - * HsIntegral/HsFractional/HsIsString - * NegApp - * NPlusKPat - * HsDo -respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, -fromRationalName etc), but the renamer changes this to the appropriate user -name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. - -We treat the original (standard) names as free-vars too, because the type checker -checks the type of the user thing against the type of the standard thing. --} - -lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) --- Different to lookupSyntaxName because in the non-rebindable --- case we desugar directly rather than calling an existing function --- Hence the (Maybe (SyntaxExpr GhcRn)) return type -lookupIfThenElse - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on - then return (Nothing, emptyFVs) - else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) - ; return ( Just (mkRnSyntaxExpr ite) - , unitFV ite ) } } - -lookupSyntaxName' :: Name -- ^ The standard name - -> RnM Name -- ^ Possibly a non-standard name -lookupSyntaxName' std_name - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return std_name - else - -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) } - -lookupSyntaxName :: Name -- The standard name - -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard - -- name -lookupSyntaxName std_name - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return (mkRnSyntaxExpr std_name, emptyFVs) - else - -- Get the similarly named thing from the local environment - do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) - ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } } - -lookupSyntaxNames :: [Name] -- Standard names - -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames - -- this works with CmdTop, which wants HsExprs, not SyntaxExprs -lookupSyntaxNames std_names - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return (map (HsVar noExtField . noLoc) std_names, emptyFVs) - else - do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } } - --- Error messages - - -opDeclErr :: RdrName -> SDoc -opDeclErr n - = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) - 2 (text "Use TypeOperators to declare operators in type and declarations") - -badOrigBinding :: RdrName -> SDoc -badOrigBinding name - | Just _ <- isBuiltInOcc_maybe occ - = text "Illegal binding of built-in syntax:" <+> ppr occ - -- Use an OccName here because we don't want to print Prelude.(,) - | otherwise - = text "Cannot redefine a Name retrieved by a Template Haskell quote:" - <+> ppr name - -- This can happen when one tries to use a Template Haskell splice to - -- define a top-level identifier with an already existing name, e.g., - -- - -- $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) - -- - -- (See #13968.) - where - occ = rdrNameOcc $ filterCTuple name diff --git a/rename/RnExpr.hs b/rename/RnExpr.hs deleted file mode 100644 --- a/rename/RnExpr.hs +++ /dev/null @@ -1,2223 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnExpr]{Renaming of expressions} - -Basically dependency analysis. - -Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In -general, all of these functions return a renamed thing, and a set of -free variables. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module RnExpr ( - rnLExpr, rnExpr, rnStmts - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - rnMatchGroup, rnGRHS, makeMiniFixityEnv) -import GHC.Hs -import TcEnv ( isBrackStage ) -import TcRnMonad -import Module ( getModule ) -import RnEnv -import RnFixity -import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames - , bindLocalNames - , mapMaybeFvRn, mapFvRn - , warnUnusedLocalBinds, typeAppErr - , checkUnusedRecordWildcard ) -import RnUnbound ( reportUnboundName ) -import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName ) -import RnTypes -import RnPat -import DynFlags -import PrelNames - -import BasicTypes -import Name -import NameSet -import RdrName -import UniqSet -import Data.List -import Util -import ListSetOps ( removeDups ) -import ErrUtils -import Outputable -import SrcLoc -import FastString -import Control.Monad -import TysWiredIn ( nilDataConName ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Ord -import Data.Array -import qualified Data.List.NonEmpty as NE - -import Unique ( mkVarOccUnique ) - -{- -************************************************************************ -* * -\subsubsection{Expressions} -* * -************************************************************************ --} - -rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) -rnExprs ls = rnExprs' ls emptyUniqSet - where - rnExprs' [] acc = return ([], acc) - rnExprs' (expr:exprs) acc = - do { (expr', fvExpr) <- rnLExpr expr - -- Now we do a "seq" on the free vars because typically it's small - -- or empty, especially in very long lists of constants - ; let acc' = acc `plusFV` fvExpr - ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' - ; return (expr':exprs', fvExprs) } - --- Variables. We look up the variable and return the resulting name. - -rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) -rnLExpr = wrapLocFstM rnExpr - -rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) - -finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) --- Separated from rnExpr because it's also used --- when renaming infix expressions -finishHsVar (L l name) - = do { this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod name) $ - checkThLocalName name - ; return (HsVar noExtField (L l name), unitFV name) } - -rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) -rnUnboundVar v - = do { if isUnqual v - then -- Treat this as a "hole" - -- Do not fail right now; instead, return HsUnboundVar - -- and let the type checker report the error - do { let occ = rdrNameOcc v - ; uv <- if startsWithUnderscore occ - then return (TrueExprHole occ) - else OutOfScope occ <$> getGlobalRdrEnv - ; return (HsUnboundVar noExtField uv, emptyFVs) } - - else -- Fail immediately (qualified name) - do { n <- reportUnboundName v - ; return (HsVar noExtField (noLoc n), emptyFVs) } } - -rnExpr (HsVar _ (L l v)) - = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields - ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v - ; dflags <- getDynFlags - ; case mb_name of { - Nothing -> rnUnboundVar v ; - Just (Left name) - | name == nilDataConName -- Treat [] as an ExplicitList, so that - -- OverloadedLists works correctly - -- Note [Empty lists] in GHC.Hs.Expr - , xopt LangExt.OverloadedLists dflags - -> rnExpr (ExplicitList noExtField Nothing []) - - | otherwise - -> finishHsVar (L l name) ; - Just (Right [s]) -> - return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ; - Just (Right fs@(_:_:_)) -> - return ( HsRecFld noExtField (Ambiguous noExtField (L l v)) - , mkFVs fs); - Just (Right []) -> panic "runExpr/HsVar" } } - -rnExpr (HsIPVar x v) - = return (HsIPVar x v, emptyFVs) - -rnExpr (HsUnboundVar x v) - = return (HsUnboundVar x v, emptyFVs) - -rnExpr (HsOverLabel x _ v) - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if rebindable_on - then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) - ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } - else return (HsOverLabel x Nothing v, emptyFVs) } - -rnExpr (HsLit x lit@(HsString src s)) - = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings - ; if opt_OverloadedStrings then - rnExpr (HsOverLit x (mkHsIsString src s)) - else do { - ; rnLit lit - ; return (HsLit x (convertLit lit), emptyFVs) } } - -rnExpr (HsLit x lit) - = do { rnLit lit - ; return (HsLit x(convertLit lit), emptyFVs) } - -rnExpr (HsOverLit x lit) - = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] - ; case mb_neg of - Nothing -> return (HsOverLit x lit', fvs) - Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) - , fvs ) } - -rnExpr (HsApp x fun arg) - = do { (fun',fvFun) <- rnLExpr fun - ; (arg',fvArg) <- rnLExpr arg - ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } - -rnExpr (HsAppType x fun arg) - = do { type_app <- xoptM LangExt.TypeApplications - ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg - ; (fun',fvFun) <- rnLExpr fun - ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) } - -rnExpr (OpApp _ e1 op e2) - = do { (e1', fv_e1) <- rnLExpr e1 - ; (e2', fv_e2) <- rnLExpr e2 - ; (op', fv_op) <- rnLExpr op - - -- Deal with fixity - -- When renaming code synthesised from "deriving" declarations - -- we used to avoid fixity stuff, but we can't easily tell any - -- more, so I've removed the test. Adding HsPars in TcGenDeriv - -- should prevent bad things happening. - ; fixity <- case op' of - L _ (HsVar _ (L _ n)) -> lookupFixityRn n - L _ (HsRecFld _ f) -> lookupFieldFixityRn f - _ -> return (Fixity NoSourceText minPrecedence InfixL) - -- c.f. lookupFixity for unbound - - ; final_e <- mkOpAppRn e1' op' fixity e2' - ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } - -rnExpr (NegApp _ e _) - = do { (e', fv_e) <- rnLExpr e - ; (neg_name, fv_neg) <- lookupSyntaxName negateName - ; final_e <- mkNegAppRn e' neg_name - ; return (final_e, fv_e `plusFV` fv_neg) } - ------------------------------------------- --- Template Haskell extensions -rnExpr e@(HsBracket _ br_body) = rnBracket e br_body - -rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice - ---------------------------------------------- --- Sections --- See Note [Parsing sections] in Parser.y -rnExpr (HsPar x (L loc (section@(SectionL {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar x (L loc section'), fvs) } - -rnExpr (HsPar x (L loc (section@(SectionR {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar x (L loc section'), fvs) } - -rnExpr (HsPar x e) - = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar x e', fvs_e) } - -rnExpr expr@(SectionL {}) - = do { addErr (sectionErr expr); rnSection expr } -rnExpr expr@(SectionR {}) - = do { addErr (sectionErr expr); rnSection expr } - ---------------------------------------------- -rnExpr (HsCoreAnn x src ann expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn x src ann expr', fvs_expr) } - -rnExpr (HsSCC x src lbl expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC x src lbl expr', fvs_expr) } -rnExpr (HsTickPragma x src info srcInfo expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma x src info srcInfo expr', fvs_expr) } - -rnExpr (HsLam x matches) - = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches - ; return (HsLam x matches', fvMatch) } - -rnExpr (HsLamCase x matches) - = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsLamCase x matches', fvs_ms) } - -rnExpr (HsCase x expr matches) - = do { (new_expr, e_fvs) <- rnLExpr expr - ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } - -rnExpr (HsLet x (L l binds) expr) - = rnLocalBindsAndThen binds $ \binds' _ -> do - { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet x (L l binds') expr', fvExpr) } - -rnExpr (HsDo x do_or_lc (L l stmts)) - = do { ((stmts', _), fvs) <- - rnStmtsWithPostProcessing do_or_lc rnLExpr - postProcessStmtsForApplicativeDo stmts - (\ _ -> return ((), emptyFVs)) - ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } - -rnExpr (ExplicitList x _ exps) - = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists - ; (exps', fvs) <- rnExprs exps - ; if opt_OverloadedLists - then do { - ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList x (Just from_list_n_name) exps' - , fvs `plusFV` fvs') } - else - return (ExplicitList x Nothing exps', fvs) } - -rnExpr (ExplicitTuple x tup_args boxity) - = do { checkTupleSection tup_args - ; checkTupSize (length tup_args) - ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args - ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } - where - rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e - ; return (L l (Present x e'), fvs) } - rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) - , emptyFVs) - rnTupArg (L _ (XTupArg nec)) = noExtCon nec - -rnExpr (ExplicitSum x alt arity expr) - = do { (expr', fvs) <- rnLExpr expr - ; return (ExplicitSum x alt arity expr', fvs) } - -rnExpr (RecordCon { rcon_con_name = con_id - , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) - = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id - ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds - ; (flds', fvss) <- mapAndUnzipM rn_field flds - ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } - ; return (RecordCon { rcon_ext = noExtField - , rcon_con_name = con_lname, rcon_flds = rec_binds' } - , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } - where - mk_hs_var l n = HsVar noExtField (L l n) - rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } - -rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) - = do { (expr', fvExpr) <- rnLExpr expr - ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr' - , rupd_flds = rbinds' } - , fvExpr `plusFV` fvRbinds) } - -rnExpr (ExprWithTySig _ expr pty) - = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty - ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ - rnLExpr expr - ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } - -rnExpr (HsIf x _ p b1 b2) - = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } - -rnExpr (HsMultiIf x alts) - = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts - -- ; return (HsMultiIf ty alts', fvs) } - ; return (HsMultiIf x alts', fvs) } - -rnExpr (ArithSeq x _ seq) - = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists - ; (new_seq, fvs) <- rnArithSeq seq - ; if opt_OverloadedLists - then do { - ; (from_list_name, fvs') <- lookupSyntaxName fromListName - ; return (ArithSeq x (Just from_list_name) new_seq - , fvs `plusFV` fvs') } - else - return (ArithSeq x Nothing new_seq, fvs) } - -{- -************************************************************************ -* * - Static values -* * -************************************************************************ - -For the static form we check that it is not used in splices. -We also collect the free variables of the term which come from -this module. See Note [Grand plan for static forms] in StaticPtrTable. --} - -rnExpr e@(HsStatic _ expr) = do - -- Normally, you wouldn't be able to construct a static expression without - -- first enabling -XStaticPointers in the first place, since that extension - -- is what makes the parser treat `static` as a keyword. But this is not a - -- sufficient safeguard, as one can construct static expressions by another - -- mechanism: Template Haskell (see #14204). To ensure that GHC is - -- absolutely prepared to cope with static forms, we check for - -- -XStaticPointers here as well. - unlessXOptM LangExt.StaticPointers $ - addErr $ hang (text "Illegal static expression:" <+> ppr e) - 2 (text "Use StaticPointers to enable this extension") - (expr',fvExpr) <- rnLExpr expr - stage <- getStage - case stage of - Splice _ -> addErr $ sep - [ text "static forms cannot be used in splices:" - , nest 2 $ ppr e - ] - _ -> return () - mod <- getModule - let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr - return (HsStatic fvExpr' expr', fvExpr) - -{- -************************************************************************ -* * - Arrow notation -* * -************************************************************************ --} - -rnExpr (HsProc x pat body) - = newArrowScope $ - rnPat ProcExpr pat $ \ pat' -> do - { (body',fvBody) <- rnCmdTop body - ; return (HsProc x pat' body', fvBody) } - -rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- HsWrap - ----------------------- --- See Note [Parsing sections] in Parser.y -rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -rnSection section@(SectionR x op expr) - = do { (op', fvs_op) <- rnLExpr op - ; (expr', fvs_expr) <- rnLExpr expr - ; checkSectionPrec InfixR section op' expr' - ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } - -rnSection section@(SectionL x expr op) - = do { (expr', fvs_expr) <- rnLExpr expr - ; (op', fvs_op) <- rnLExpr op - ; checkSectionPrec InfixL section op' expr' - ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } - -rnSection other = pprPanic "rnSection" (ppr other) - -{- -************************************************************************ -* * - Arrow commands -* * -************************************************************************ --} - -rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars) -rnCmdArgs [] = return ([], emptyFVs) -rnCmdArgs (arg:args) - = do { (arg',fvArg) <- rnCmdTop arg - ; (args',fvArgs) <- rnCmdArgs args - ; return (arg':args', fvArg `plusFV` fvArgs) } - -rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) -rnCmdTop = wrapLocFstM rnCmdTop' - where - rnCmdTop' (HsCmdTop _ cmd) - = do { (cmd', fvCmd) <- rnLCmd cmd - ; let cmd_names = [arrAName, composeAName, firstAName] ++ - nameSetElemsStable (methodNamesCmd (unLoc cmd')) - -- Generate the rebindable syntax for the monad - ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - - ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', - fvCmd `plusFV` cmd_fvs) } - rnCmdTop' (XCmdTop nec) = noExtCon nec - -rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) -rnLCmd = wrapLocFstM rnCmd - -rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) - -rnCmd (HsCmdArrApp x arrow arg ho rtl) - = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) - ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp x arrow' arg' ho rtl, - fvArrow `plusFV` fvArg) } - where - select_arrow_scope tc = case ho of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - -- See Note [Escaping the arrow scope] in TcRnTypes - -- Before renaming 'arrow', use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside 'arrow'. In the higher-order case (-<<), they are. - --- infix form -rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) - = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) - ; let L _ (HsVar _ (L _ op_name)) = op' - ; (arg1',fv_arg1) <- rnCmdTop arg1 - ; (arg2',fv_arg2) <- rnCmdTop arg2 - -- Deal with fixity - ; fixity <- lookupFixityRn op_name - ; final_e <- mkOpFormRn arg1' op' fixity arg2' - ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } - -rnCmd (HsCmdArrForm x op f fixity cmds) - = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) - ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } - -rnCmd (HsCmdApp x fun arg) - = do { (fun',fvFun) <- rnLCmd fun - ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } - -rnCmd (HsCmdLam x matches) - = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam x matches', fvMatch) } - -rnCmd (HsCmdPar x e) - = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar x e', fvs_e) } - -rnCmd (HsCmdCase x expr matches) - = do { (new_expr, e_fvs) <- rnLExpr expr - ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } - -rnCmd (HsCmdIf x _ p b1 b2) - = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLCmd b1 - ; (b2', fvB2) <- rnLCmd b2 - ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} - -rnCmd (HsCmdLet x (L l binds) cmd) - = rnLocalBindsAndThen binds $ \ binds' _ -> do - { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet x (L l binds') cmd', fvExpr) } - -rnCmd (HsCmdDo x (L l stmts)) - = do { ((stmts', _), fvs) <- - rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo x (L l stmts'), fvs ) } - -rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) -rnCmd (XCmd nec) = noExtCon nec - ---------------------------------------------------- -type CmdNeeds = FreeVars -- Only inhabitants are - -- appAName, choiceAName, loopAName - --- find what methods the Cmd needs (loop, choice, apply) -methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds -methodNamesLCmd = methodNamesCmd . unLoc - -methodNamesCmd :: HsCmd GhcRn -> CmdNeeds - -methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) - = emptyFVs -methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) - = unitFV appAName -methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd - -methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c - -methodNamesCmd (HsCmdIf _ _ _ c1 c2) - = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName - -methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts -methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c -methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match - -methodNamesCmd (HsCmdCase _ _ matches) - = methodNamesMatch matches `addOneFV` choiceAName - -methodNamesCmd (XCmd nec) = noExtCon nec - ---methodNamesCmd _ = emptyFVs - -- Other forms can't occur in commands, but it's not convenient - -- to error here so we just do what's convenient. - -- The type checker will complain later - ---------------------------------------------------- -methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars -methodNamesMatch (MG { mg_alts = L _ ms }) - = plusFVs (map do_one ms) - where - do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss - do_one (L _ (XMatch nec)) = noExtCon nec -methodNamesMatch (XMatchGroup nec) = noExtCon nec - -------------------------------------------------- --- gaw 2004 -methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars -methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) -methodNamesGRHSs (XGRHSs nec) = noExtCon nec - -------------------------------------------------- - -methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds -methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs -methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec - ---------------------------------------------------- -methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars -methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) - ---------------------------------------------------- -methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars -methodNamesLStmt = methodNamesStmt . unLoc - -methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars -methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd -methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd -methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd -methodNamesStmt (RecStmt { recS_stmts = stmts }) = - methodNamesStmts stmts `addOneFV` loopAName -methodNamesStmt (LetStmt {}) = emptyFVs -methodNamesStmt (ParStmt {}) = emptyFVs -methodNamesStmt (TransStmt {}) = emptyFVs -methodNamesStmt ApplicativeStmt{} = emptyFVs - -- ParStmt and TransStmt can't occur in commands, but it's not - -- convenient to error here so we just do what's convenient -methodNamesStmt (XStmtLR nec) = noExtCon nec - -{- -************************************************************************ -* * - Arithmetic sequences -* * -************************************************************************ --} - -rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) -rnArithSeq (From expr) - = do { (expr', fvExpr) <- rnLExpr expr - ; return (From expr', fvExpr) } - -rnArithSeq (FromThen expr1 expr2) - = do { (expr1', fvExpr1) <- rnLExpr expr1 - ; (expr2', fvExpr2) <- rnLExpr expr2 - ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } - -rnArithSeq (FromTo expr1 expr2) - = do { (expr1', fvExpr1) <- rnLExpr expr1 - ; (expr2', fvExpr2) <- rnLExpr expr2 - ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } - -rnArithSeq (FromThenTo expr1 expr2 expr3) - = do { (expr1', fvExpr1) <- rnLExpr expr1 - ; (expr2', fvExpr2) <- rnLExpr expr2 - ; (expr3', fvExpr3) <- rnLExpr expr3 - ; return (FromThenTo expr1' expr2' expr3', - plusFVs [fvExpr1, fvExpr2, fvExpr3]) } - -{- -************************************************************************ -* * -\subsubsection{@Stmt@s: in @do@ expressions} -* * -************************************************************************ --} - -{- -Note [Deterministic ApplicativeDo and RecursiveDo desugaring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Both ApplicativeDo and RecursiveDo need to create tuples not -present in the source text. - -For ApplicativeDo we create: - - (a,b,c) <- (\c b a -> (a,b,c)) <$> - -For RecursiveDo we create: - - mfix (\ ~(a,b,c) -> do ...; return (a',b',c')) - -The order of the components in those tuples needs to be stable -across recompilations, otherwise they can get optimized differently -and we end up with incompatible binaries. -To get a stable order we use nameSetElemsStable. -See Note [Deterministic UniqFM] to learn more about nondeterminism. --} - --- | Rename some Stmts -rnStmts :: Outputable (body GhcPs) - => HsStmtContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> [LStmt GhcPs (Located (body GhcPs))] - -- ^ Statements - -> ([Name] -> RnM (thing, FreeVars)) - -- ^ if these statements scope over something, this renames it - -- and returns the result. - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) -rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts - --- | like 'rnStmts' but applies a post-processing step to the renamed Stmts -rnStmtsWithPostProcessing - :: Outputable (body GhcPs) - => HsStmtContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> (HsStmtContext Name - -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) - -- ^ postprocess the statements - -> [LStmt GhcPs (Located (body GhcPs))] - -- ^ Statements - -> ([Name] -> RnM (thing, FreeVars)) - -- ^ if these statements scope over something, this renames it - -- and returns the result. - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) -rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside - = do { ((stmts', thing), fvs) <- - rnStmtsWithFreeVars ctxt rnBody stmts thing_inside - ; (pp_stmts, fvs') <- ppStmts ctxt stmts' - ; return ((pp_stmts, thing), fvs `plusFV` fvs') - } - --- | maybe rearrange statements according to the ApplicativeDo transformation -postProcessStmtsForApplicativeDo - :: HsStmtContext Name - -> [(ExprLStmt GhcRn, FreeVars)] - -> RnM ([ExprLStmt GhcRn], FreeVars) -postProcessStmtsForApplicativeDo ctxt stmts - = do { - -- rearrange the statements using ApplicativeStmt if - -- -XApplicativeDo is on. Also strip out the FreeVars attached - -- to each Stmt body. - ado_is_on <- xoptM LangExt.ApplicativeDo - ; let is_do_expr | DoExpr <- ctxt = True - | otherwise = False - -- don't apply the transformation inside TH brackets, because - -- DsMeta does not handle ApplicativeDo. - ; in_th_bracket <- isBrackStage <$> getStage - ; if ado_is_on && is_do_expr && not in_th_bracket - then do { traceRn "ppsfa" (ppr stmts) - ; rearrangeForApplicativeDo ctxt stmts } - else noPostProcessStmts ctxt stmts } - --- | strip the FreeVars annotations from statements -noPostProcessStmts - :: HsStmtContext Name - -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) -noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) - - -rnStmtsWithFreeVars :: Outputable (body GhcPs) - => HsStmtContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) - , FreeVars) --- Each Stmt body is annotated with its FreeVars, so that --- we can rearrange statements for ApplicativeDo. --- --- Variables bound by the Stmts, and mentioned in thing_inside, --- do not appear in the result FreeVars - -rnStmtsWithFreeVars ctxt _ [] thing_inside - = do { checkEmptyStmts ctxt - ; (thing, fvs) <- thing_inside [] - ; return (([], thing), fvs) } - -rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo - = -- Behave like do { rec { ...all but last... }; last } - do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> - do { last_stmt' <- checkLastStmt MDoExpr last_stmt - ; rnStmt MDoExpr rnBody last_stmt' thing_inside } - ; return (((stmts1 ++ stmts2), thing), fvs) } - where - Just (all_but_last, last_stmt) = snocView stmts - -rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside - | null lstmts - = setSrcSpan loc $ - do { lstmt' <- checkLastStmt ctxt lstmt - ; rnStmt ctxt rnBody lstmt' thing_inside } - - | otherwise - = do { ((stmts1, (stmts2, thing)), fvs) - <- setSrcSpan loc $ - do { checkStmt ctxt lstmt - ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> - rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> - thing_inside (bndrs1 ++ bndrs2) } - ; return (((stmts1 ++ stmts2), thing), fvs) } - ----------------------- - -{- -Note [Failing pattern matches in Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Many things desugar to HsStmts including monadic things like `do` and `mdo` -statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an -exhaustive list). How we deal with pattern match failure is context-dependent. - - * In the case of list comprehensions and pattern guards we don't need any 'fail' - function; the desugarer ignores the fail function field of 'BindStmt' entirely. - * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo - expressions) we want pattern match failure to be desugared to the appropriate - 'fail' function (either that of Monad or MonadFail, depending on whether - -XMonadFailDesugaring is enabled.) - -At one point we failed to make this distinction, leading to #11216. --} - -rnStmt :: Outputable (body GhcPs) - => HsStmtContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -- ^ How to rename the body of the statement - -> LStmt GhcPs (Located (body GhcPs)) - -- ^ The statement - -> ([Name] -> RnM (thing, FreeVars)) - -- ^ Rename the stuff that this statement scopes over - -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) - , FreeVars) --- Variables bound by the Stmt, and mentioned in thing_inside, --- do not appear in the result FreeVars - -rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- if isMonadCompContext ctxt - then lookupStmtName ctxt returnMName - else return (noSyntaxExpr, emptyFVs) - -- The 'return' in a LastStmt is used only - -- for MonadComp; and we don't want to report - -- "non in scope: return" in other cases - -- #15607 - - ; (thing, fvs3) <- thing_inside [] - ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)] - , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } - -rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (then_op, fvs1) <- lookupStmtName ctxt thenMName - - ; (guard_op, fvs2) <- if isComprehensionContext ctxt - then lookupStmtName ctxt guardMName - else return (noSyntaxExpr, emptyFVs) - -- Only list/monad comprehensions use 'guard' - -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] - -- Here "gd" is a guard - - ; (thing, fvs3) <- thing_inside [] - ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] - , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } - -rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName - - ; (fail_op, fvs2) <- monadFailOp pat ctxt - - ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do - { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op) - , fv_expr )] - , thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} - -- fv_expr shouldn't really be filtered by the rnPatsAndThen - -- but it does not matter because the names are unique - -rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside - = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do - { (thing, fvs) <- thing_inside (collectLocalBinders binds') - ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) - , fvs) } } - -rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName - ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName - ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName - ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op - , recS_mfix_fn = mfix_op - , recS_bind_fn = bind_op } - - -- Step1: Bring all the binders of the mdo into scope - -- (Remember that this also removes the binders from the - -- finally-returned free-vars.) - -- And rename each individual stmt, making a - -- singleton segment. At this stage the FwdRefs field - -- isn't finished: it's empty for all except a BindStmt - -- for which it's the fwd refs within the bind itself - -- (This set may not be empty, because we're in a recursive - -- context.) - ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do - { let bndrs = nameSetElemsStable $ - foldr (unionNameSet . (\(ds,_,_,_) -> ds)) - emptyNameSet - segs - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - ; (thing, fvs_later) <- thing_inside bndrs - ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later - -- We aren't going to try to group RecStmts with - -- ApplicativeDo, so attaching empty FVs is fine. - ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) - , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } - -rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside - = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName - ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName - ; (return_op, fvs3) <- lookupStmtName ctxt returnMName - ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside - ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing) - , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } - -rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form - , trS_using = using })) thing_inside - = do { -- Rename the 'using' expression in the context before the transform is begun - (using', fvs1) <- rnLExpr using - - -- Rename the stmts and the 'by' expression - -- Keep track of the variables mentioned in the 'by' expression - ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> - do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by - ; (thing, fvs_thing) <- thing_inside bndrs - ; let fvs = fvs_by `plusFV` fvs_thing - used_bndrs = filter (`elemNameSet` fvs) bndrs - -- The paper (Fig 5) has a bug here; we must treat any free variable - -- of the "thing inside", **or of the by-expression**, as used - ; return ((by', used_bndrs, thing), fvs) } - - -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions - ; (return_op, fvs3) <- lookupStmtName ctxt returnMName - ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName - ; (fmap_op, fvs5) <- case form of - ThenForm -> return (noExpr, emptyFVs) - _ -> lookupStmtNamePoly ctxt fmapName - - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - `plusFV` fvs4 `plusFV` fvs5 - bndr_map = used_bndrs `zip` used_bndrs - -- See Note [TransStmt binder map] in GHC.Hs.Expr - - ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) - ; return (([(L loc (TransStmt { trS_ext = noExtField - , trS_stmts = stmts', trS_bndrs = bndr_map - , trS_by = by', trS_using = using', trS_form = form - , trS_ret = return_op, trS_bind = bind_op - , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } - -rnStmt _ _ (L _ ApplicativeStmt{}) _ = - panic "rnStmt: ApplicativeStmt" - -rnStmt _ _ (L _ (XStmtLR nec)) _ = - noExtCon nec - -rnParallelStmts :: forall thing. HsStmtContext Name - -> SyntaxExpr GhcRn - -> [ParStmtBlock GhcPs GhcPs] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) --- Note [Renaming parallel Stmts] -rnParallelStmts ctxt return_op segs thing_inside - = do { orig_lcl_env <- getLocalRdrEnv - ; rn_segs orig_lcl_env [] segs } - where - rn_segs :: LocalRdrEnv - -> [Name] -> [ParStmtBlock GhcPs GhcPs] - -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) - rn_segs _ bndrs_so_far [] - = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far - ; mapM_ dupErr dups - ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') - ; return (([], thing), fvs) } - - rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) - = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> - setLocalRdrEnv env $ do - { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs - ; let used_bndrs = filter (`elemNameSet` fvs) bndrs - ; return ((used_bndrs, segs', thing), fvs) } - - ; let seg' = ParStmtBlock x stmts' used_bndrs return_op - ; return ((seg':segs', thing), fvs) } - rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec - - cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" - <+> quotes (ppr (NE.head vs))) - -lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) --- Like lookupSyntaxName, but respects contexts -lookupStmtName ctxt n - | rebindableContext ctxt - = lookupSyntaxName n - | otherwise - = return (mkRnSyntaxExpr n, emptyFVs) - -lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars) -lookupStmtNamePoly ctxt name - | rebindableContext ctxt - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if rebindable_on - then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar noExtField (noLoc fm), unitFV fm) } - else not_rebindable } - | otherwise - = not_rebindable - where - not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs) - --- | Is this a context where we respect RebindableSyntax? --- but ListComp are never rebindable --- Neither is ArrowExpr, which has its own desugarer in DsArrows -rebindableContext :: HsStmtContext Name -> Bool -rebindableContext ctxt = case ctxt of - ListComp -> False - ArrowExpr -> False - PatGuard {} -> False - - DoExpr -> True - MDoExpr -> True - MonadComp -> True - GhciStmtCtxt -> True -- I suppose? - - ParStmtCtxt c -> rebindableContext c -- Look inside to - TransStmtCtxt c -> rebindableContext c -- the parent context - -{- -Note [Renaming parallel Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Renaming parallel statements is painful. Given, say - [ a+c | a <- as, bs <- bss - | c <- bs, a <- ds ] -Note that - (a) In order to report "Defined but not used" about 'bs', we must - rename each group of Stmts with a thing_inside whose FreeVars - include at least {a,c} - - (b) We want to report that 'a' is illegally bound in both branches - - (c) The 'bs' in the second group must obviously not be captured by - the binding in the first group - -To satisfy (a) we nest the segements. -To satisfy (b) we check for duplicates just before thing_inside. -To satisfy (c) we reset the LocalRdrEnv each time. - -************************************************************************ -* * -\subsubsection{mdo expressions} -* * -************************************************************************ --} - -type FwdRefs = NameSet -type Segment stmts = (Defs, - Uses, -- May include defs - FwdRefs, -- A subset of uses that are - -- (a) used before they are bound in this segment, or - -- (b) used here, and bound in subsequent segments - stmts) -- Either Stmt or [Stmt] - - --- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: Outputable (body GhcPs) => - (Located (body GhcPs) - -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] - -- assumes that the FreeVars returned includes - -- the FreeVars of the Segments - -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] - -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnRecStmtsAndThen rnBody s cont - = do { -- (A) Make the mini fixity env for all of the stmts - fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) - - -- (B) Do the LHSes - ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s - - -- ...bring them and their fixities into scope - ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) - -- Fake uses of variables introduced implicitly (warning suppression, see #4404) - rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) - implicit_uses = mkNameSet $ concatMap snd $ rec_uses - ; bindLocalNamesFV bound_names $ - addLocalFixities fix_env bound_names $ do - - -- (C) do the right-hand-sides and thing-inside - { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv - ; (res, fvs) <- cont segs - ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns)) - rec_uses - ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses) - ; return (res, fvs) }} - --- get all the fixity decls in any Let stmt -collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] -collectRecStmtsFixities l = - foldr (\ s -> \acc -> case s of - (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> - foldr (\ sig -> \ acc -> case sig of - (L loc (FixSig _ s)) -> (L loc s) : acc - _ -> acc) acc sigs - _ -> acc) [] l - --- left-hand sides - -rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv - -> LStmt GhcPs body - -- rename LHS, and return its FVs - -- Warning: we will only need the FreeVars below in the case of a BindStmt, - -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] - -rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) - = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] - -rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a)) - = return [(L loc (LastStmt noExtField body noret a), emptyFVs)] - -rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b)) - = do - -- should the ctxt be MDo instead? - (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt noExtField pat' body a b), fv_pat)] - -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) - = failWith (badIpBinds (text "an mdo expression") binds) - -rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) - = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))), - -- Warning: this is bogus; see function invariant - emptyFVs - )] - --- XXX Do we need to do something with the return and mfix names? -rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec - = rn_rec_stmts_lhs fix_env stmts - -rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) - = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec)))) - = noExtCon nec -rn_rec_stmt_lhs _ (L _ (XStmtLR nec)) - = noExtCon nec - -rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt GhcPs body] - -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] -rn_rec_stmts_lhs fix_env stmts - = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts - ; let boundNames = collectLStmtsBinders (map fst ls) - -- First do error checking: we need to check for dups here because we - -- don't bind all of the variables from the Stmt at once - -- with bindLocatedLocals. - ; checkDupNames boundNames - ; return ls } - - --- right-hand-sides - -rn_rec_stmt :: (Outputable (body GhcPs)) => - (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> [Name] - -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) - -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] - -- Rename a Stmt that is inside a RecStmt (or mdo) - -- Assumes all binders are already in scope - -- Turns each stmt into a singleton Stmt -rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _) - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupSyntaxName returnMName - ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, - L loc (LastStmt noExtField body' noret ret_op))] } - -rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _) - = do { (body', fvs) <- rnBody body - ; (then_op, fvs1) <- lookupSyntaxName thenMName - ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } - -rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat) - = do { (body', fv_expr) <- rnBody body - ; (bind_op, fvs1) <- lookupSyntaxName bindMName - - ; (fail_op, fvs2) <- getMonadFailOp - - ; let bndrs = mkNameSet (collectPatBinders pat') - fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 - ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt noExtField pat' body' bind_op fail_op))] } - -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) - = failWith (badIpBinds (text "an mdo expression") binds) - -rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) - = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' - -- fixities and unused are handled above in rnRecStmtsAndThen - ; let fvs = allUses du_binds - ; return [(duDefs du_binds, fvs, emptyNameSet, - L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } - --- no RecStmt case because they get flattened above when doing the LHSes -rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) - = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) - -rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) - -rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) - -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _) - = noExtCon nec - -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) - = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" - -rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) - = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) - -rn_rec_stmt _ _ (L _ (XStmtLR nec), _) - = noExtCon nec - -rn_rec_stmts :: Outputable (body GhcPs) => - (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> [Name] - -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] - -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] -rn_rec_stmts rnBody bndrs stmts - = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts - ; return (concat segs_s) } - ---------------------------------------------- -segmentRecStmts :: SrcSpan -> HsStmtContext Name - -> Stmt GhcRn body - -> [Segment (LStmt GhcRn body)] -> FreeVars - -> ([LStmt GhcRn body], FreeVars) - -segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later - | null segs - = ([], fvs_later) - - | MDoExpr <- ctxt - = segsToStmts empty_rec_stmt grouped_segs fvs_later - -- Step 4: Turn the segments into Stmts - -- Use RecStmt when and only when there are fwd refs - -- Also gather up the uses from the end towards the - -- start, so we can tell the RecStmt which things are - -- used 'after' the RecStmt - - | otherwise - = ([ L loc $ - empty_rec_stmt { recS_stmts = ss - , recS_later_ids = nameSetElemsStable - (defs `intersectNameSet` fvs_later) - , recS_rec_ids = nameSetElemsStable - (defs `intersectNameSet` uses) }] - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - , uses `plusFV` fvs_later) - - where - (defs_s, uses_s, _, ss) = unzip4 segs - defs = plusFVs defs_s - uses = plusFVs uses_s - - -- Step 2: Fill in the fwd refs. - -- The segments are all singletons, but their fwd-ref - -- field mentions all the things used by the segment - -- that are bound after their use - segs_w_fwd_refs = addFwdRefs segs - - -- Step 3: Group together the segments to make bigger segments - -- Invariant: in the result, no segment uses a variable - -- bound in a later segment - grouped_segs = glomSegments ctxt segs_w_fwd_refs - ----------------------------- -addFwdRefs :: [Segment a] -> [Segment a] --- So far the segments only have forward refs *within* the Stmt --- (which happens for bind: x <- ...x...) --- This function adds the cross-seg fwd ref info - -addFwdRefs segs - = fst (foldr mk_seg ([], emptyNameSet) segs) - where - mk_seg (defs, uses, fwds, stmts) (segs, later_defs) - = (new_seg : segs, all_defs) - where - new_seg = (defs, uses, new_fwds, stmts) - all_defs = later_defs `unionNameSet` defs - new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs) - -- Add the downstream fwd refs here - -{- -Note [Segmenting mdo] -~~~~~~~~~~~~~~~~~~~~~ -NB. June 7 2012: We only glom segments that appear in an explicit mdo; -and leave those found in "do rec"'s intact. See -https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion -leading to this design choice. Hence the test in segmentRecStmts. - -Note [Glomming segments] -~~~~~~~~~~~~~~~~~~~~~~~~ -Glomming the singleton segments of an mdo into minimal recursive groups. - -At first I thought this was just strongly connected components, but -there's an important constraint: the order of the stmts must not change. - -Consider - mdo { x <- ...y... - p <- z - y <- ...x... - q <- x - z <- y - r <- x } - -Here, the first stmt mention 'y', which is bound in the third. -But that means that the innocent second stmt (p <- z) gets caught -up in the recursion. And that in turn means that the binding for -'z' has to be included... and so on. - -Start at the tail { r <- x } -Now add the next one { z <- y ; r <- x } -Now add one more { q <- x ; z <- y ; r <- x } -Now one more... but this time we have to group a bunch into rec - { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } -Now one more, which we can add on without a rec - { p <- z ; - rec { y <- ...x... ; q <- x ; z <- y } ; - r <- x } -Finally we add the last one; since it mentions y we have to -glom it together with the first two groups - { rec { x <- ...y...; p <- z ; y <- ...x... ; - q <- x ; z <- y } ; - r <- x } --} - -glomSegments :: HsStmtContext Name - -> [Segment (LStmt GhcRn body)] - -> [Segment [LStmt GhcRn body]] - -- Each segment has a non-empty list of Stmts --- See Note [Glomming segments] - -glomSegments _ [] = [] -glomSegments ctxt ((defs,uses,fwds,stmt) : segs) - -- Actually stmts will always be a singleton - = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others - where - segs' = glomSegments ctxt segs - (extras, others) = grab uses segs' - (ds, us, fs, ss) = unzip4 extras - - seg_defs = plusFVs ds `plusFV` defs - seg_uses = plusFVs us `plusFV` uses - seg_fwds = plusFVs fs `plusFV` fwds - seg_stmts = stmt : concat ss - - grab :: NameSet -- The client - -> [Segment a] - -> ([Segment a], -- Needed by the 'client' - [Segment a]) -- Not needed by the client - -- The result is simply a split of the input - grab uses dus - = (reverse yeses, reverse noes) - where - (noes, yeses) = span not_needed (reverse dus) - not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) - ----------------------------------------------------- -segsToStmts :: Stmt GhcRn body - -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt GhcRn body]] - -- Each Segment has a non-empty list of Stmts - -> FreeVars -- Free vars used 'later' - -> ([LStmt GhcRn body], FreeVars) - -segsToStmts _ [] fvs_later = ([], fvs_later) -segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later - = ASSERT( not (null ss) ) - (new_stmt : later_stmts, later_uses `plusFV` uses) - where - (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later - new_stmt | non_rec = head ss - | otherwise = cL (getLoc (head ss)) rec_stmt - rec_stmt = empty_rec_stmt { recS_stmts = ss - , recS_later_ids = nameSetElemsStable used_later - , recS_rec_ids = nameSetElemsStable fwds } - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - non_rec = isSingleton ss && isEmptyNameSet fwds - used_later = defs `intersectNameSet` later_uses - -- The ones needed after the RecStmt - -{- -************************************************************************ -* * -ApplicativeDo -* * -************************************************************************ - -Note [ApplicativeDo] - -= Example = - -For a sequence of statements - - do - x <- A - y <- B x - z <- C - return (f x y z) - -We want to transform this to - - (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C - -It would be easy to notice that "y <- B x" and "z <- C" are -independent and do something like this: - - do - x <- A - (y,z) <- (,) <$> B x <*> C - return (f x y z) - -But this isn't enough! A and C were also independent, and this -transformation loses the ability to do A and C in parallel. - -The algorithm works by first splitting the sequence of statements into -independent "segments", and a separate "tail" (the final statement). In -our example above, the segements would be - - [ x <- A - , y <- B x ] - - [ z <- C ] - -and the tail is: - - return (f x y z) - -Then we take these segments and make an Applicative expression from them: - - (\(x,y) z -> return (f x y z)) - <$> do { x <- A; y <- B x; return (x,y) } - <*> C - -Finally, we recursively apply the transformation to each segment, to -discover any nested parallelism. - -= Syntax & spec = - - expr ::= ... | do {stmt_1; ..; stmt_n} expr | ... - - stmt ::= pat <- expr - | (arg_1 | ... | arg_n) -- applicative composition, n>=1 - | ... -- other kinds of statement (e.g. let) - - arg ::= pat <- expr - | {stmt_1; ..; stmt_n} {var_1..var_n} - -(note that in the actual implementation,the expr in a do statement is -represented by a LastStmt as the final stmt, this is just a -representational issue and may change later.) - -== Transformation to introduce applicative stmts == - -ado {} tail = tail -ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr' -ado {one} tail = one : tail -ado stmts tail - | n == 1 = ado before (ado after tail) - where (before,after) = split(stmts_1) - | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail - where - {stmts_1 .. stmts_n} = segments(stmts) - -segments(stmts) = - -- divide stmts into segments with no interdependencies - -mkArg({pat <- expr}) = (pat <- expr) -mkArg({stmt_1; ...; stmt_n}) = - {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)} - -split({stmt_1; ..; stmt_n) = - ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n}) - -- 1 <= i <= n - -- i is a good place to insert a bind - -== Desugaring for do == - -dsDo {} expr = expr - -dsDo {pat <- rhs; stmts} expr = - rhs >>= \pat -> dsDo stmts expr - -dsDo {(arg_1 | ... | arg_n)} (return expr) = - (\argpat (arg_1) .. argpat(arg_n) -> expr) - <$> argexpr(arg_1) - <*> ... - <*> argexpr(arg_n) - -dsDo {(arg_1 | ... | arg_n); stmts} expr = - join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr) - <$> argexpr(arg_1) - <*> ... - <*> argexpr(arg_n) - -= Relevant modules in the rest of the compiler = - -ApplicativeDo touches a few phases in the compiler: - -* Renamer: The journey begins here in the renamer, where do-blocks are - scheduled as outlined above and transformed into applicative - combinators. However, the code is still represented as a do-block - with special forms of applicative statements. This allows us to - recover the original do-block when e.g. printing type errors, where - we don't want to show any of the applicative combinators since they - don't exist in the source code. - See ApplicativeStmt and ApplicativeArg in HsExpr. - -* Typechecker: ApplicativeDo passes through the typechecker much like any - other form of expression. The only crux is that the typechecker has to - be aware of the special ApplicativeDo statements in the do-notation, and - typecheck them appropriately. - Relevant module: TcMatches - -* Desugarer: Any do-block which contains applicative statements is desugared - as outlined above, to use the Applicative combinators. - Relevant module: DsExpr - --} - --- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and --- 'pureName' due to @RebindableSyntax@. -data MonadNames = MonadNames { return_name, pure_name :: Name } - -instance Outputable MonadNames where - ppr (MonadNames {return_name=return_name,pure_name=pure_name}) = - hcat - [text "MonadNames { return_name = " - ,ppr return_name - ,text ", pure_name = " - ,ppr pure_name - ,text "}" - ] - --- | rearrange a list of statements using ApplicativeDoStmt. See --- Note [ApplicativeDo]. -rearrangeForApplicativeDo - :: HsStmtContext Name - -> [(ExprLStmt GhcRn, FreeVars)] - -> RnM ([ExprLStmt GhcRn], FreeVars) - -rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) -rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) -rearrangeForApplicativeDo ctxt stmts0 = do - optimal_ado <- goptM Opt_OptimalApplicativeDo - let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts - | otherwise = mkStmtTreeHeuristic stmts - traceRn "rearrangeForADo" (ppr stmt_tree) - return_name <- lookupSyntaxName' returnMName - pure_name <- lookupSyntaxName' pureAName - let monad_names = MonadNames { return_name = return_name - , pure_name = pure_name } - stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs - where - (stmts,(last,last_fvs)) = findLast stmts0 - findLast [] = error "findLast" - findLast [last] = ([],last) - findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs - --- | A tree of statements using a mixture of applicative and bind constructs. -data StmtTree a - = StmtTreeOne a - | StmtTreeBind (StmtTree a) (StmtTree a) - | StmtTreeApplicative [StmtTree a] - -instance Outputable a => Outputable (StmtTree a) where - ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x) - ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind") - 2 (sep [ppr x, ppr y])) - ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative") - 2 (vcat (map ppr xs))) - -flattenStmtTree :: StmtTree a -> [a] -flattenStmtTree t = go t [] - where - go (StmtTreeOne a) as = a : as - go (StmtTreeBind l r) as = go l (go r as) - go (StmtTreeApplicative ts) as = foldr go as ts - -type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) -type Cost = Int - --- | Turn a sequence of statements into an ExprStmtTree using a --- heuristic algorithm. /O(n^2)/ -mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree -mkStmtTreeHeuristic [one] = StmtTreeOne one -mkStmtTreeHeuristic stmts = - case segments stmts of - [one] -> split one - segs -> StmtTreeApplicative (map split segs) - where - split [one] = StmtTreeOne one - split stmts = - StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after) - where (before, after) = splitSegment stmts - --- | Turn a sequence of statements into an ExprStmtTree optimally, --- using dynamic programming. /O(n^3)/ -mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree -mkStmtTreeOptimal stmts = - ASSERT(not (null stmts)) -- the empty case is handled by the caller; - -- we don't support empty StmtTrees. - fst (arr ! (0,n)) - where - n = length stmts - 1 - stmt_arr = listArray (0,n) stmts - - -- lazy cache of optimal trees for subsequences of the input - arr :: Array (Int,Int) (ExprStmtTree, Cost) - arr = array ((0,0),(n,n)) - [ ((lo,hi), tree lo hi) - | lo <- [0..n] - , hi <- [lo..n] ] - - -- compute the optimal tree for the sequence [lo..hi] - tree lo hi - | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) - | otherwise = - case segments [ stmt_arr ! i | i <- [lo..hi] ] of - [] -> panic "mkStmtTree" - [_one] -> split lo hi - segs -> (StmtTreeApplicative trees, maximum costs) - where - bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs - (trees,costs) = unzip (map (uncurry split) (tail bounds)) - - -- find the best place to split the segment [lo..hi] - split :: Int -> Int -> (ExprStmtTree, Cost) - split lo hi - | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) - | otherwise = (StmtTreeBind before after, c1+c2) - where - -- As per the paper, for a sequence s1...sn, we want to find - -- the split with the minimum cost, where the cost is the - -- sum of the cost of the left and right subsequences. - -- - -- As an optimisation (also in the paper) if the cost of - -- s1..s(n-1) is different from the cost of s2..sn, we know - -- that the optimal solution is the lower of the two. Only - -- in the case that these two have the same cost do we need - -- to do the exhaustive search. - -- - ((before,c1),(after,c2)) - | hi - lo == 1 - = ((StmtTreeOne (stmt_arr ! lo), 1), - (StmtTreeOne (stmt_arr ! hi), 1)) - | left_cost < right_cost - = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) - | left_cost > right_cost - = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) - | otherwise = minimumBy (comparing cost) alternatives - where - (left, left_cost) = arr ! (lo,hi-1) - (right, right_cost) = arr ! (lo+1,hi) - cost ((_,c1),(_,c2)) = c1 + c2 - alternatives = [ (arr ! (lo,k), arr ! (k+1,hi)) - | k <- [lo .. hi-1] ] - - --- | Turn the ExprStmtTree back into a sequence of statements, using --- ApplicativeStmt where necessary. -stmtTreeToStmts - :: MonadNames - -> HsStmtContext Name - -> ExprStmtTree - -> [ExprLStmt GhcRn] -- ^ the "tail" - -> FreeVars -- ^ free variables of the tail - -> RnM ( [ExprLStmt GhcRn] -- ( output statements, - , FreeVars ) -- , things we needed - --- If we have a single bind, and we can do it without a join, transform --- to an ApplicativeStmt. This corresponds to the rule --- dsBlock [pat <- rhs] (return expr) = expr <$> rhs --- In the spec, but we do it here rather than in the desugarer, --- because we need the typechecker to typecheck the <$> form rather than --- the bind form, which would give rise to a Monad constraint. -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _)) - tail _tail_fvs - | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail - -- See Note [ApplicativeDo and strict patterns] - = mkApplicativeStmt ctxt [ApplicativeArgOne - { xarg_app_arg_one = noExtField - , app_arg_pattern = pat - , arg_expr = rhs - , is_body_stmt = False - , fail_operator = fail_op}] - False tail' -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) - tail _tail_fvs - | (False,tail') <- needJoin monad_names tail - = mkApplicativeStmt ctxt - [ApplicativeArgOne - { xarg_app_arg_one = noExtField - , app_arg_pattern = nlWildPatName - , arg_expr = rhs - , is_body_stmt = True - , fail_operator = noSyntaxExpr}] False tail' - -stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = - return (s : tail, emptyNameSet) - -stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do - (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs - let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after)) - (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs - return (stmts2, fvs1 `plusFV` fvs2) - -stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do - pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees - let (stmts', fvss) = unzip pairs - let (need_join, tail') = - -- See Note [ApplicativeDo and refutable patterns] - if any hasRefutablePattern stmts' - then (True, tail) - else needJoin monad_names tail - - (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' - return (stmts, unionNameSets (fvs:fvss)) - where - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _)) - = return (ApplicativeArgOne - { xarg_app_arg_one = noExtField - , app_arg_pattern = pat - , arg_expr = exp - , is_body_stmt = False - , fail_operator = fail_op - }, emptyFVs) - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = - return (ApplicativeArgOne - { xarg_app_arg_one = noExtField - , app_arg_pattern = nlWildPatName - , arg_expr = exp - , is_body_stmt = True - , fail_operator = noSyntaxExpr - }, emptyFVs) - stmtTreeArg ctxt tail_fvs tree = do - let stmts = flattenStmtTree tree - pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) - `intersectNameSet` tail_fvs - pvars = nameSetElemsStable pvarset - -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - pat = mkBigLHsVarPatTup pvars - tup = mkBigLHsVarTup pvars - (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset - (mb_ret, fvs1) <- - if | L _ ApplicativeStmt{} <- last stmts' -> - return (unLoc tup, emptyNameSet) - | otherwise -> do - ret <- lookupSyntaxName' returnMName - let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup - return (expr, emptyFVs) - return ( ApplicativeArgMany - { xarg_app_arg_many = noExtField - , app_stmts = stmts' - , final_expr = mb_ret - , bv_pattern = pat - } - , fvs1 `plusFV` fvs2) - - --- | Divide a sequence of statements into segments, where no segment --- depends on any variables defined by a statement in another segment. -segments - :: [(ExprLStmt GhcRn, FreeVars)] - -> [[(ExprLStmt GhcRn, FreeVars)]] -segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) - where - allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) - - -- We would rather not have a segment that just has LetStmts in - -- it, so combine those with an adjacent segment where possible. - merge [] = [] - merge (seg : segs) - = case rest of - [] -> [(seg,all_lets)] - ((s,s_lets):ss) | all_lets || s_lets - -> (seg ++ s, all_lets && s_lets) : ss - _otherwise -> (seg,all_lets) : rest - where - rest = merge segs - all_lets = all (isLetStmt . fst) seg - - -- walk splits the statement sequence into segments, traversing - -- the sequence from the back to the front, and keeping track of - -- the set of free variables of the current segment. Whenever - -- this set of free variables is empty, we have a complete segment. - walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] - walk [] = [] - walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest - where (seg,rest) = chunter fvs' stmts - (_, fvs') = stmtRefs stmt fvs - - chunter _ [] = ([], []) - chunter vars ((stmt,fvs) : rest) - | not (isEmptyNameSet vars) - || isStrictPatternBind stmt - -- See Note [ApplicativeDo and strict patterns] - = ((stmt,fvs) : chunk, rest') - where (chunk,rest') = chunter vars' rest - (pvars, evars) = stmtRefs stmt fvs - vars' = (vars `minusNameSet` pvars) `unionNameSet` evars - chunter _ rest = ([], rest) - - stmtRefs stmt fvs - | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) - | otherwise = (pvars, fvs') - where fvs' = fvs `intersectNameSet` allvars - pvars = mkNameSet (collectStmtBinders (unLoc stmt)) - - isStrictPatternBind :: ExprLStmt GhcRn -> Bool - isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat - isStrictPatternBind _ = False - -{- -Note [ApplicativeDo and strict patterns] - -A strict pattern match is really a dependency. For example, - -do - (x,y) <- A - z <- B - return C - -The pattern (_,_) must be matched strictly before we do B. If we -allowed this to be transformed into - - (\(x,y) -> \z -> C) <$> A <*> B - -then it could be lazier than the standard desuraging using >>=. See #13875 -for more examples. - -Thus, whenever we have a strict pattern match, we treat it as a -dependency between that statement and the following one. The -dependency prevents those two statements from being performed "in -parallel" in an ApplicativeStmt, but doesn't otherwise affect what we -can do with the rest of the statements in the same "do" expression. --} - -isStrictPattern :: LPat (GhcPass p) -> Bool -isStrictPattern lpat = - case unLoc lpat of - WildPat{} -> False - VarPat{} -> False - LazyPat{} -> False - AsPat _ _ p -> isStrictPattern p - ParPat _ p -> isStrictPattern p - ViewPat _ _ p -> isStrictPattern p - SigPat _ p _ -> isStrictPattern p - BangPat{} -> True - ListPat{} -> True - TuplePat{} -> True - SumPat{} -> True - ConPatIn{} -> True - ConPatOut{} -> True - LitPat{} -> True - NPat{} -> True - NPlusKPat{} -> True - SplicePat{} -> True - _otherwise -> panic "isStrictPattern" - -{- -Note [ApplicativeDo and refutable patterns] - -Refutable patterns in do blocks are desugared to use the monadic 'fail' operation. -This means that sometimes an applicative block needs to be wrapped in 'join' simply because -of a refutable pattern, in order for the types to work out. - --} - -hasRefutablePattern :: ApplicativeArg GhcRn -> Bool -hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat - , is_body_stmt = False}) = not (isIrrefutableHsPat pat) -hasRefutablePattern _ = False - -isLetStmt :: LStmt a b -> Bool -isLetStmt (L _ LetStmt{}) = True -isLetStmt _ = False - --- | Find a "good" place to insert a bind in an indivisible segment. --- This is the only place where we use heuristics. The current --- heuristic is to peel off the first group of independent statements --- and put the bind after those. -splitSegment - :: [(ExprLStmt GhcRn, FreeVars)] - -> ( [(ExprLStmt GhcRn, FreeVars)] - , [(ExprLStmt GhcRn, FreeVars)] ) -splitSegment [one,two] = ([one],[two]) - -- there is no choice when there are only two statements; this just saves - -- some work in a common case. -splitSegment stmts - | Just (lets,binds,rest) <- slurpIndependentStmts stmts - = if not (null lets) - then (lets, binds++rest) - else (lets++binds, rest) - | otherwise - = case stmts of - (x:xs) -> ([x],xs) - _other -> (stmts,[]) - -slurpIndependentStmts - :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts - , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts - , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) -slurpIndependentStmts stmts = go [] [] emptyNameSet stmts - where - -- If we encounter a BindStmt that doesn't depend on a previous BindStmt - -- in this group, then add it to the group. We have to be careful about - -- strict patterns though; splitSegments expects that if we return Just - -- then we have actually done some splitting. Otherwise it will go into - -- an infinite loop (#14163). - go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest) - | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) - = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep) - bndrs' rest - where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) - -- If we encounter a LetStmt that doesn't depend on a BindStmt in this - -- group, then move it to the beginning, so that it doesn't interfere with - -- grouping more BindStmts. - -- TODO: perhaps we shouldn't do this if there are any strict bindings, - -- because we might be moving evaluation earlier. - go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest) - | isEmptyNameSet (bndrs `intersectNameSet` fvs) - = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest - go _ [] _ _ = Nothing - go _ [_] _ _ = Nothing - go lets indep _ stmts = Just (reverse lets, reverse indep, stmts) - --- | Build an ApplicativeStmt, and strip the "return" from the tail --- if necessary. --- --- For example, if we start with --- do x <- E1; y <- E2; return (f x y) --- then we get --- do (E1[x] | E2[y]); f x y --- --- the LastStmt in this case has the return removed, but we set the --- flag on the LastStmt to indicate this, so that we can print out the --- original statement correctly in error messages. It is easier to do --- it this way rather than try to ignore the return later in both the --- typechecker and the desugarer (I tried it that way first!). -mkApplicativeStmt - :: HsStmtContext Name - -> [ApplicativeArg GhcRn] -- ^ The args - -> Bool -- ^ True <=> need a join - -> [ExprLStmt GhcRn] -- ^ The body statements - -> RnM ([ExprLStmt GhcRn], FreeVars) -mkApplicativeStmt ctxt args need_join body_stmts - = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName - ; (ap_op, fvs2) <- lookupStmtName ctxt apAName - ; (mb_join, fvs3) <- - if need_join then - do { (join_op, fvs) <- lookupStmtName ctxt joinMName - ; return (Just join_op, fvs) } - else - return (Nothing, emptyNameSet) - ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField - (zip (fmap_op : repeat ap_op) args) - mb_join - ; return ( applicative_stmt : body_stmts - , fvs1 `plusFV` fvs2 `plusFV` fvs3) } - --- | Given the statements following an ApplicativeStmt, determine whether --- we need a @join@ or not, and remove the @return@ if necessary. -needJoin :: MonadNames - -> [ExprLStmt GhcRn] - -> (Bool, [ExprLStmt GhcRn]) -needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg -needJoin monad_names [L loc (LastStmt _ e _ t)] - | Just arg <- isReturnApp monad_names e = - (False, [L loc (LastStmt noExtField arg True t)]) -needJoin _monad_names stmts = (True, stmts) - --- | @Just e@, if the expression is @return e@ or @return $ e@, --- otherwise @Nothing@ -isReturnApp :: MonadNames - -> LHsExpr GhcRn - -> Maybe (LHsExpr GhcRn) -isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr -isReturnApp monad_names (L _ e) = case e of - OpApp _ l op r | is_return l, is_dollar op -> Just r - HsApp _ f arg | is_return f -> Just arg - _otherwise -> Nothing - where - is_var f (L _ (HsPar _ e)) = is_var f e - is_var f (L _ (HsAppType _ e _)) = is_var f e - is_var f (L _ (HsVar _ (L _ r))) = f r - -- TODO: I don't know how to get this right for rebindable syntax - is_var _ _ = False - - is_return = is_var (\n -> n == return_name monad_names - || n == pure_name monad_names) - is_dollar = is_var (`hasKey` dollarIdKey) - -{- -************************************************************************ -* * -\subsubsection{Errors} -* * -************************************************************************ --} - -checkEmptyStmts :: HsStmtContext Name -> RnM () --- We've seen an empty sequence of Stmts... is that ok? -checkEmptyStmts ctxt - = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) - -okEmpty :: HsStmtContext a -> Bool -okEmpty (PatGuard {}) = True -okEmpty _ = False - -emptyErr :: HsStmtContext Name -> SDoc -emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" -emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" -emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt - ----------------------- -checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name - -> LStmt GhcPs (Located (body GhcPs)) - -> RnM (LStmt GhcPs (Located (body GhcPs))) -checkLastStmt ctxt lstmt@(L loc stmt) - = case ctxt of - ListComp -> check_comp - MonadComp -> check_comp - ArrowExpr -> check_do - DoExpr -> check_do - MDoExpr -> check_do - _ -> check_other - where - check_do -- Expect BodyStmt, and change it to LastStmt - = case stmt of - BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) - LastStmt {} -> return lstmt -- "Deriving" clauses may generate a - -- LastStmt directly (unlike the parser) - _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } - last_error = (text "The last statement in" <+> pprAStmtContext ctxt - <+> text "must be an expression") - - check_comp -- Expect LastStmt; this should be enforced by the parser! - = case stmt of - LastStmt {} -> return lstmt - _ -> pprPanic "checkLastStmt" (ppr lstmt) - - check_other -- Behave just as if this wasn't the last stmt - = do { checkStmt ctxt lstmt; return lstmt } - --- Checking when a particular Stmt is ok -checkStmt :: HsStmtContext Name - -> LStmt GhcPs (Located (body GhcPs)) - -> RnM () -checkStmt ctxt (L _ stmt) - = do { dflags <- getDynFlags - ; case okStmt dflags ctxt stmt of - IsValid -> return () - NotValid extra -> addErr (msg $$ extra) } - where - msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") - , text "in" <+> pprAStmtContext ctxt ] - -pprStmtCat :: Stmt (GhcPass a) body -> SDoc -pprStmtCat (TransStmt {}) = text "transform" -pprStmtCat (LastStmt {}) = text "return expression" -pprStmtCat (BodyStmt {}) = text "body" -pprStmtCat (BindStmt {}) = text "binding" -pprStmtCat (LetStmt {}) = text "let" -pprStmtCat (RecStmt {}) = text "rec" -pprStmtCat (ParStmt {}) = text "parallel" -pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" -pprStmtCat (XStmtLR nec) = noExtCon nec - ------------- -emptyInvalid :: Validity -- Payload is the empty document -emptyInvalid = NotValid Outputable.empty - -okStmt, okDoStmt, okCompStmt, okParStmt - :: DynFlags -> HsStmtContext Name - -> Stmt GhcPs (Located (body GhcPs)) -> Validity --- Return Nothing if OK, (Just extra) if not ok --- The "extra" is an SDoc that is appended to a generic error message - -okStmt dflags ctxt stmt - = case ctxt of - PatGuard {} -> okPatGuardStmt stmt - ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt - DoExpr -> okDoStmt dflags ctxt stmt - MDoExpr -> okDoStmt dflags ctxt stmt - ArrowExpr -> okDoStmt dflags ctxt stmt - GhciStmtCtxt -> okDoStmt dflags ctxt stmt - ListComp -> okCompStmt dflags ctxt stmt - MonadComp -> okCompStmt dflags ctxt stmt - TransStmtCtxt ctxt -> okStmt dflags ctxt stmt - -------------- -okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity -okPatGuardStmt stmt - = case stmt of - BodyStmt {} -> IsValid - BindStmt {} -> IsValid - LetStmt {} -> IsValid - _ -> emptyInvalid - -------------- -okParStmt dflags ctxt stmt - = case stmt of - LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid - _ -> okStmt dflags ctxt stmt - ----------------- -okDoStmt dflags ctxt stmt - = case stmt of - RecStmt {} - | LangExt.RecursiveDo `xopt` dflags -> IsValid - | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' - | otherwise -> NotValid (text "Use RecursiveDo") - BindStmt {} -> IsValid - LetStmt {} -> IsValid - BodyStmt {} -> IsValid - _ -> emptyInvalid - ----------------- -okCompStmt dflags _ stmt - = case stmt of - BindStmt {} -> IsValid - LetStmt {} -> IsValid - BodyStmt {} -> IsValid - ParStmt {} - | LangExt.ParallelListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (text "Use ParallelListComp") - TransStmt {} - | LangExt.TransformListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (text "Use TransformListComp") - RecStmt {} -> emptyInvalid - LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) - ApplicativeStmt {} -> emptyInvalid - XStmtLR nec -> noExtCon nec - ---------- -checkTupleSection :: [LHsTupArg GhcPs] -> RnM () -checkTupleSection args - = do { tuple_section <- xoptM LangExt.TupleSections - ; checkErr (all tupArgPresent args || tuple_section) msg } - where - msg = text "Illegal tuple section: use TupleSections" - ---------- -sectionErr :: HsExpr GhcPs -> SDoc -sectionErr expr - = hang (text "A section must be enclosed in parentheses") - 2 (text "thus:" <+> (parens (ppr expr))) - -badIpBinds :: Outputable a => SDoc -> a -> SDoc -badIpBinds what binds - = hang (text "Implicit-parameter bindings illegal in" <+> what) - 2 (ppr binds) - ---------- - -monadFailOp :: LPat GhcPs - -> HsStmtContext Name - -> RnM (SyntaxExpr GhcRn, FreeVars) -monadFailOp pat ctxt - -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) - -- we should not need to fail. - | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs) - - -- For non-monadic contexts (e.g. guard patterns, list - -- comprehensions, etc.) we should not need to fail. See Note - -- [Failing pattern matches in Stmts] - | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs) - - | otherwise = getMonadFailOp - -{- -Note [Monad fail : Rebindable syntax, overloaded strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Given the code - foo x = do { Just y <- x; return y } - -we expect it to desugar as - foo x = x >>= \r -> case r of - Just y -> return y - Nothing -> fail "Pattern match error" - -But with RebindableSyntax and OverloadedStrings, we really want -it to desugar thus: - foo x = x >>= \r -> case r of - Just y -> return y - Nothing -> fail (fromString "Patterm match error") - -So, in this case, we synthesize the function - \x -> fail (fromString x) - -(rather than plain 'fail') for the 'fail' operation. This is done in -'getMonadFailOp'. --} -getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op -getMonadFailOp - = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags - ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags - ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings - } - where - reallyGetMonadFailOp rebindableSyntax overloadedStrings - | rebindableSyntax && overloadedStrings = do - (failExpr, failFvs) <- lookupSyntaxName failMName - (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName - let arg_lit = fsLit "arg" - arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit - arg_syn_expr = mkRnSyntaxExpr arg_name - let body :: LHsExpr GhcRn = - nlHsApp (noLoc $ syn_expr failExpr) - (nlHsApp (noLoc $ syn_expr fromStringExpr) - (noLoc $ syn_expr arg_syn_expr)) - let failAfterFromStringExpr :: HsExpr GhcRn = - unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body - let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = - mkSyntaxExpr failAfterFromStringExpr - return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) - | otherwise = lookupSyntaxName failMName diff --git a/rename/RnExpr.hs-boot b/rename/RnExpr.hs-boot deleted file mode 100644 --- a/rename/RnExpr.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module RnExpr where -import Name -import GHC.Hs -import NameSet ( FreeVars ) -import TcRnTypes -import SrcLoc ( Located ) -import Outputable ( Outputable ) - -rnLExpr :: LHsExpr GhcPs - -> RnM (LHsExpr GhcRn, FreeVars) - -rnStmts :: --forall thing body. - Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) diff --git a/rename/RnFixity.hs b/rename/RnFixity.hs deleted file mode 100644 --- a/rename/RnFixity.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -{- - -This module contains code which maintains and manipulates the -fixity environment during renaming. - --} -module RnFixity ( MiniFixityEnv, - addLocalFixities, - lookupFixityRn, lookupFixityRn_help, - lookupFieldFixityRn, lookupTyFixityRn ) where - -import GhcPrelude - -import LoadIface -import GHC.Hs -import RdrName -import HscTypes -import TcRnMonad -import Name -import NameEnv -import Module -import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, - defaultFixity, SourceText(..) ) -import SrcLoc -import Outputable -import Maybes -import Data.List -import Data.Function ( on ) -import RnUnbound - -{- -********************************************************* -* * - Fixities -* * -********************************************************* - -Note [Fixity signature lookup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A fixity declaration like - - infixr 2 ? - -can refer to a value-level operator, e.g.: - - (?) :: String -> String -> String - -or a type-level operator, like: - - data (?) a b = A a | B b - -so we extend the lookup of the reader name '?' to the TcClsName namespace, as -well as the original namespace. - -The extended lookup is also used in other places, like resolution of -deprecation declarations, and lookup of names in GHCi. --} - --------------------------------- -type MiniFixityEnv = FastStringEnv (Located Fixity) - -- Mini fixity env for the names we're about - -- to bind, in a single binding group - -- - -- It is keyed by the *FastString*, not the *OccName*, because - -- the single fixity decl infix 3 T - -- affects both the data constructor T and the type constrctor T - -- - -- We keep the location so that if we find - -- a duplicate, we can report it sensibly - --------------------------------- --- Used for nested fixity decls to bind names along with their fixities. --- the fixities are given as a UFM from an OccName's FastString to a fixity decl - -addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a -addLocalFixities mini_fix_env names thing_inside - = extendFixityEnv (mapMaybe find_fixity names) thing_inside - where - find_fixity name - = case lookupFsEnv mini_fix_env (occNameFS occ) of - Just lfix -> Just (name, FixItem occ (unLoc lfix)) - Nothing -> Nothing - where - occ = nameOccName name - -{- --------------------------------- -lookupFixity is a bit strange. - -* Nested local fixity decls are put in the local fixity env, which we - find with getFixtyEnv - -* Imported fixities are found in the PIT - -* Top-level fixity decls in this module may be for Names that are - either Global (constructors, class operations) - or Local/Exported (everything else) - (See notes with RnNames.getLocalDeclBinders for why we have this split.) - We put them all in the local fixity environment --} - -lookupFixityRn :: Name -> RnM Fixity -lookupFixityRn name = lookupFixityRn' name (nameOccName name) - -lookupFixityRn' :: Name -> OccName -> RnM Fixity -lookupFixityRn' name = fmap snd . lookupFixityRn_help' name - --- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' --- in a local environment or from an interface file. Otherwise, it returns --- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without --- user-supplied fixity declarations). -lookupFixityRn_help :: Name - -> RnM (Bool, Fixity) -lookupFixityRn_help name = - lookupFixityRn_help' name (nameOccName name) - -lookupFixityRn_help' :: Name - -> OccName - -> RnM (Bool, Fixity) -lookupFixityRn_help' name occ - | isUnboundName name - = return (False, Fixity NoSourceText minPrecedence InfixL) - -- Minimise errors from ubound names; eg - -- a>0 `foo` b>0 - -- where 'foo' is not in scope, should not give an error (#7937) - - | otherwise - = do { local_fix_env <- getFixityEnv - ; case lookupNameEnv local_fix_env name of { - Just (FixItem _ fix) -> return (True, fix) ; - Nothing -> - - do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - -- Local (and interactive) names are all in the - -- fixity env, and don't have entries in the HPT - then return (False, defaultFixity) - else lookup_imported } } } - where - lookup_imported - -- For imported names, we have to get their fixities by doing a - -- loadInterfaceForName, and consulting the Ifaces that comes back - -- from that, because the interface file for the Name might not - -- have been loaded yet. Why not? Suppose you import module A, - -- which exports a function 'f', thus; - -- module CurrentModule where - -- import A( f ) - -- module A( f ) where - -- import B( f ) - -- Then B isn't loaded right away (after all, it's possible that - -- nothing from B will be used). When we come across a use of - -- 'f', we need to know its fixity, and it's then, and only - -- then, that we load B.hi. That is what's happening here. - -- - -- loadInterfaceForName will find B.hi even if B is a hidden module, - -- and that's what we want. - = do { iface <- loadInterfaceForName doc name - ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ - ; let msg = case mb_fix of - Nothing -> - text "looking up name" <+> ppr name - <+> text "in iface, but found no fixity for it." - <+> text "Using default fixity instead." - Just f -> - text "looking up name in iface and found:" - <+> vcat [ppr name, ppr f] - ; traceRn "lookupFixityRn_either:" msg - ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } - - doc = text "Checking fixity for" <+> ppr name - ---------------- -lookupTyFixityRn :: Located Name -> RnM Fixity -lookupTyFixityRn = lookupFixityRn . unLoc - --- | Look up the fixity of a (possibly ambiguous) occurrence of a record field --- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as --- the field label, which might be different to the 'OccName' of the selector --- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are --- multiple possible selectors with different fixities, generate an error. -lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (Unambiguous n lrdr) - = lookupFixityRn' n (rdrNameOcc (unLoc lrdr)) -lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr) - where - get_ambiguous_fixity :: RdrName -> RnM Fixity - get_ambiguous_fixity rdr_name = do - traceRn "get_ambiguous_fixity" (ppr rdr_name) - rdr_env <- getGlobalRdrEnv - let elts = lookupGRE_RdrName rdr_name rdr_env - - fixities <- groupBy ((==) `on` snd) . zip elts - <$> mapM lookup_gre_fixity elts - - case fixities of - -- There should always be at least one fixity. - -- Something's very wrong if there are no fixity candidates, so panic - [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" - [ (_, fix):_ ] -> return fix - ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) - >> return (Fixity NoSourceText minPrecedence InfixL) - - lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) - - ambiguous_fixity_err rn ambigs - = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) - , hang (text "Conflicts: ") 2 . vcat . - map format_ambig $ concat ambigs ] - - format_ambig (elt, fix) = hang (ppr fix) - 2 (pprNameProvenance elt) -lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec diff --git a/rename/RnHsDoc.hs b/rename/RnHsDoc.hs deleted file mode 100644 --- a/rename/RnHsDoc.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where - -import GhcPrelude - -import TcRnTypes -import GHC.Hs -import SrcLoc - - -rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) -rnMbLHsDoc mb_doc = case mb_doc of - Just doc -> do - doc' <- rnLHsDoc doc - return (Just doc') - Nothing -> return Nothing - -rnLHsDoc :: LHsDocString -> RnM LHsDocString -rnLHsDoc (dL->L pos doc) = do - doc' <- rnHsDoc doc - return (cL pos doc') - -rnHsDoc :: HsDocString -> RnM HsDocString -rnHsDoc = pure diff --git a/rename/RnNames.hs b/rename/RnNames.hs deleted file mode 100644 --- a/rename/RnNames.hs +++ /dev/null @@ -1,1825 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnNames]{Extracting imported and top-level names in scope} --} - -{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module RnNames ( - rnImports, getLocalNonValBinders, newRecordSelector, - extendGlobalRdrEnvRn, - gresFromAvails, - calculateAvails, - reportUnusedNames, - checkConName, - mkChildEnv, - findChildren, - dodgyMsg, - dodgyMsgInsert, - findImportUsage, - getMinimalImports, - printMinimalImports, - ImportDeclUsage - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import TyCoPpr -import GHC.Hs -import TcEnv -import RnEnv -import RnFixity -import RnUtils ( warnUnusedTopBinds, mkFieldEnv ) -import LoadIface ( loadSrcInterface ) -import TcRnMonad -import PrelNames -import Module -import Name -import NameEnv -import NameSet -import Avail -import FieldLabel -import HscTypes -import RdrName -import RdrHsSyn ( setRdrNameSpace ) -import Outputable -import Maybes -import SrcLoc -import BasicTypes ( TopLevelFlag(..), StringLiteral(..) ) -import Util -import FastString -import FastStringEnv -import Id -import Type -import PatSyn -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Either ( partitionEithers, isRight, rights ) -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Ord ( comparing ) -import Data.List ( partition, (\\), find, sortBy ) -import qualified Data.Set as S -import System.FilePath (()) - -import System.IO - -{- -************************************************************************ -* * -\subsection{rnImports} -* * -************************************************************************ - -Note [Tracking Trust Transitively] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we import a package as well as checking that the direct imports are safe -according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] -we must also check that these rules hold transitively for all dependent modules -and packages. Doing this without caching any trust information would be very -slow as we would need to touch all packages and interface files a module depends -on. To avoid this we make use of the property that if a modules Safe Haskell -mode changes, this triggers a recompilation from that module in the dependcy -graph. So we can just worry mostly about direct imports. - -There is one trust property that can change for a package though without -recompliation being triggered: package trust. So we must check that all -packages a module tranitively depends on to be trusted are still trusted when -we are compiling this module (as due to recompilation avoidance some modules -below may not be considered trusted any more without recompilation being -triggered). - -We handle this by augmenting the existing transitive list of packages a module M -depends on with a bool for each package that says if it must be trusted when the -module M is being checked for trust. This list of trust required packages for a -single import is gathered in the rnImportDecl function and stored in an -ImportAvails data structure. The union of these trust required packages for all -imports is done by the rnImports function using the combine function which calls -the plusImportAvails function that is a union operation for the ImportAvails -type. This gives us in an ImportAvails structure all packages required to be -trusted for the module we are currently compiling. Checking that these packages -are still trusted (and that direct imports are trusted) is done in -HscMain.checkSafeImports. - -See the note below, [Trust Own Package] for a corner case in this method and -how its handled. - - -Note [Trust Own Package] -~~~~~~~~~~~~~~~~~~~~~~~~ -There is a corner case of package trust checking that the usual transitive check -doesn't cover. (For how the usual check operates see the Note [Tracking Trust -Transitively] below). The case is when you import a -XSafe module M and M -imports a -XTrustworthy module N. If N resides in a different package than M, -then the usual check works as M will record a package dependency on N's package -and mark it as required to be trusted. If N resides in the same package as M -though, then importing M should require its own package be trusted due to N -(since M is -XSafe so doesn't create this requirement by itself). The usual -check fails as a module doesn't record a package dependency of its own package. -So instead we now have a bool field in a modules interface file that simply -states if the module requires its own package to be trusted. This field avoids -us having to load all interface files that the module depends on to see if one -is trustworthy. - - -Note [Trust Transitive Property] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -So there is an interesting design question in regards to transitive trust -checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch -of modules and packages, some packages it requires to be trusted as its using --XTrustworthy modules from them. Now if I have a module A that doesn't use safe -haskell at all and simply imports B, should A inherit all the trust -requirements from B? Should A now also require that a package p is trusted since -B required it? - -We currently say no but saying yes also makes sense. The difference is, if a -module M that doesn't use Safe Haskell imports a module N that does, should all -the trusted package requirements be dropped since M didn't declare that it cares -about Safe Haskell (so -XSafe is more strongly associated with the module doing -the importing) or should it be done still since the author of the module N that -uses Safe Haskell said they cared (so -XSafe is more strongly associated with -the module that was compiled that used it). - -Going with yes is a simpler semantics we think and harder for the user to stuff -up but it does mean that Safe Haskell will affect users who don't care about -Safe Haskell as they might grab a package from Cabal which uses safe haskell (say -network) and that packages imports -XTrustworthy modules from another package -(say bytestring), so requires that package is trusted. The user may now get -compilation errors in code that doesn't do anything with Safe Haskell simply -because they are using the network package. They will have to call 'ghc-pkg -trust network' to get everything working. Due to this invasive nature of going -with yes we have gone with no for now. --} - --- | Process Import Decls. See 'rnImportDecl' for a description of what --- the return types represent. --- Note: Do the non SOURCE ones first, so that we get a helpful warning --- for SOURCE ones that are unnecessary -rnImports :: [LImportDecl GhcPs] - -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImports imports = do - tcg_env <- getGblEnv - -- NB: want an identity module here, because it's OK for a signature - -- module to import from its implementor - let this_mod = tcg_mod tcg_env - let (source, ordinary) = partition is_source_import imports - is_source_import d = ideclSource (unLoc d) - stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary - stuff2 <- mapAndReportM (rnImportDecl this_mod) source - -- Safe Haskell: See Note [Tracking Trust Transitively] - let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) - return (decls, rdr_env, imp_avails, hpc_usage) - - where - -- See Note [Combining ImportAvails] - combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] - -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) - combine ss = - let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr - plus - ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) - ss - in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, - hpc_usage) - - plus (decl, gbl_env1, imp_avails1, hpc_usage1) - (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set) - = ( decl:decls, - gbl_env1 `plusGlobalRdrEnv` gbl_env2, - imp_avails1' `plusImportAvails` imp_avails2, - hpc_usage1 || hpc_usage2, - extendModuleSetList finsts_set new_finsts ) - where - imp_avails1' = imp_avails1 { imp_finsts = [] } - new_finsts = imp_finsts imp_avails1 - -{- -Note [Combining ImportAvails] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -imp_finsts in ImportAvails is a list of family instance modules -transitively depended on by an import. imp_finsts for a currently -compiled module is a union of all the imp_finsts of imports. -Computing the union of two lists of size N is O(N^2) and if we -do it to M imports we end up with O(M*N^2). That can get very -expensive for bigger module hierarchies. - -Union can be optimized to O(N log N) if we use a Set. -imp_finsts is converted back and forth between dep_finsts, so -changing a type of imp_finsts means either paying for the conversions -or changing the type of dep_finsts as well. - -I've measured that the conversions would cost 20% of allocations on my -test case, so that can be ruled out. - -Changing the type of dep_finsts forces checkFamInsts to -get the module lists in non-deterministic order. If we wanted to restore -the deterministic order, we'd have to sort there, which is an additional -cost. As far as I can tell, using a non-deterministic order is fine there, -but that's a brittle nonlocal property which I'd like to avoid. - -Additionally, dep_finsts is read from an interface file, so its "natural" -type is a list. Which makes it a natural type for imp_finsts. - -Since rnImports.combine is really the only place that would benefit from -it being a Set, it makes sense to optimize the hot loop in rnImports.combine -without changing the representation. - -So here's what we do: instead of naively merging ImportAvails with -plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts -and compute the union on the side using Sets. When we're done, we can -convert it back to a list. One nice side effect of this approach is that -if there's a lot of overlap in the imp_finsts of imports, the -Set doesn't really need to grow and we don't need to allocate. - -Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in -23s before, and 11s after. --} - - - --- | Given a located import declaration @decl@ from @this_mod@, --- calculate the following pieces of information: --- --- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in --- the entity lists have been resolved into 'Name's, --- --- 2. A 'GlobalRdrEnv' representing the new identifiers that were --- brought into scope (taking into account module qualification --- and hiding), --- --- 3. 'ImportAvails' summarizing the identifiers that were imported --- by this declaration, and --- --- 4. A boolean 'AnyHpcUsage' which is true if the imported module --- used HPC. -rnImportDecl :: Module -> LImportDecl GhcPs - -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImportDecl this_mod - (L loc decl@(ImportDecl { ideclExt = noExtField - , ideclName = loc_imp_mod_name - , ideclPkgQual = mb_pkg - , ideclSource = want_boot, ideclSafe = mod_safe - , ideclQualified = qual_style, ideclImplicit = implicit - , ideclAs = as_mod, ideclHiding = imp_details })) - = setSrcSpan loc $ do - - when (isJust mb_pkg) $ do - pkg_imports <- xoptM LangExt.PackageImports - when (not pkg_imports) $ addErr packageImportErr - - let qual_only = isImportDeclQualified qual_style - - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - let imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> text "is directly imported" - - -- Check for self-import, which confuses the typechecker (#9032) - -- ghc --make rejects self-import cycles already, but batch-mode may not - -- at least not until TcIface.tcHiBootIface, which is too late to avoid - -- typechecker crashes. (Indirect self imports are not caught until - -- TcIface, see #10337 tracking how to make this error better.) - -- - -- Originally, we also allowed 'import {-# SOURCE #-} M', but this - -- caused bug #10182: in one-shot mode, we should never load an hs-boot - -- file for the module we are compiling into the EPS. In principle, - -- it should be possible to support this mode of use, but we would have to - -- extend Provenance to support a local definition in a qualified location. - -- For now, we don't support it, but see #10336 - when (imp_mod_name == moduleName this_mod && - (case mb_pkg of -- If we have import "" M, then we should - -- check that "" is "this" (which is magic) - -- or the name of this_mod's package. Yurgh! - -- c.f. GHC.findModule, and #9997 - Nothing -> True - Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || - fsToUnitId pkg_fs == moduleUnitId this_mod)) - (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) - - -- Check for a missing import list (Opt_WarnMissingImportList also - -- checks for T(..) items but that is done in checkDodgyImport below) - case imp_details of - Just (False, _) -> return () -- Explicit import list - _ | implicit -> return () -- Do not bleat for implicit imports - | qual_only -> return () - | otherwise -> whenWOptM Opt_WarnMissingImportList $ - addWarn (Reason Opt_WarnMissingImportList) - (missingImportListWarn imp_mod_name) - - iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) - - -- Compiler sanity check: if the import didn't say - -- {-# SOURCE #-} we should not get a hi-boot file - WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do - - -- Issue a user warning for a redundant {- SOURCE -} import - -- NB that we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports. - -- - -- in --make and GHCi, the compilation manager checks for this, - -- and indeed we shouldn't do it here because the existence of - -- the non-boot module depends on the compilation order, which - -- is not deterministic. The hs-boot test can show this up. - dflags <- getDynFlags - warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) - (warnRedundantSourceImport imp_mod_name) - when (mod_safe && not (safeImportsOn dflags)) $ - addErr (text "safe import can't be used as Safe Haskell isn't on!" - $+$ ptext (sLit $ "please enable Safe Haskell through either " - ++ "Safe, Trustworthy or Unsafe")) - - let - qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name - imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = loc, is_as = qual_mod_name } - - -- filter the imports according to the import declaration - (new_imp_details, gres) <- filterImports iface imp_spec imp_details - - -- for certain error messages, we’d like to know what could be imported - -- here, if everything were imported - potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing - - let gbl_env = mkGlobalRdrEnv gres - - is_hiding | Just (True,_) <- imp_details = True - | otherwise = False - - -- should the import be safe? - mod_safe' = mod_safe - || (not implicit && safeDirectImpsReq dflags) - || (implicit && safeImplicitImpsReq dflags) - - let imv = ImportedModsVal - { imv_name = qual_mod_name - , imv_span = loc - , imv_is_safe = mod_safe' - , imv_is_hiding = is_hiding - , imv_all_exports = potential_gres - , imv_qualified = qual_only - } - imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv) - - -- Complain if we import a deprecated module - whenWOptM Opt_WarnWarningsDeprecations ( - case (mi_warns iface) of - WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations) - (moduleWarn imp_mod_name txt) - _ -> return () - ) - - -- Complain about -Wcompat-unqualified-imports violations. - warnUnqualifiedImport decl iface - - let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe' - , ideclHiding = new_imp_details }) - - return (new_imp_decl, gbl_env, imports, mi_hpc iface) -rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec - --- | Calculate the 'ImportAvails' induced by an import of a particular --- interface, but without 'imp_mods'. -calculateAvails :: DynFlags - -> ModIface - -> IsSafeImport - -> IsBootInterface - -> ImportedBy - -> ImportAvails -calculateAvails dflags iface mod_safe' want_boot imported_by = - let imp_mod = mi_module iface - imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan (mi_final_exts iface) - has_finsts = mi_finsts (mi_final_exts iface) - deps = mi_deps iface - trust = getSafeMode $ mi_trust iface - trust_pkg = mi_trust_pkg iface - - -- If the module exports anything defined in this module, just - -- ignore it. Reason: otherwise it looks as if there are two - -- local definition sites for the thing, and an error gets - -- reported. Easiest thing is just to filter them out up - -- front. This situation only arises if a module imports - -- itself, or another module that imported it. (Necessarily, - -- this invoves a loop.) - -- - -- We do this *after* filterImports, so that if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you won't get a 'B does not export AType' message. - - - -- Compute new transitive dependencies - -- - -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module - -- itself, but we DO need to include this module in 'imp_orphs' and - -- 'imp_finsts' if it defines an orphan or instance family; thus the - -- orph_iface/has_iface tests. - - orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) - imp_sem_mod : dep_orphs deps - | otherwise = dep_orphs deps - - finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) - imp_sem_mod : dep_finsts deps - | otherwise = dep_finsts deps - - pkg = moduleUnitId (mi_module iface) - ipkg = toInstalledUnitId pkg - - -- Does this import mean we now require our own pkg - -- to be trusted? See Note [Trust Own Package] - ptrust = trust == Sf_Trustworthy || trust_pkg - - (dependent_mods, dependent_pkgs, pkg_trust_req) - | pkg == thisPackage dflags = - -- Imported module is from the home package - -- Take its dependent modules and add imp_mod itself - -- Take its dependent packages unchanged - -- - -- NB: (dep_mods deps) might include a hi-boot file - -- for the module being compiled, CM. Do *not* filter - -- this out (as we used to), because when we've - -- finished dealing with the direct imports we want to - -- know if any of them depended on CM.hi-boot, in - -- which case we should do the hi-boot consistency - -- check. See LoadIface.loadHiBootInterface - ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust) - - | otherwise = - -- Imported module is from another package - -- Dump the dependent modules - -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps)) - , ppr ipkg <+> ppr (dep_pkgs deps) ) - ([], (ipkg, False) : dep_pkgs deps, False) - - in ImportAvails { - imp_mods = unitModuleEnv (mi_module iface) [imported_by], - imp_orphs = orphans, - imp_finsts = finsts, - imp_dep_mods = mkModDeps dependent_mods, - imp_dep_pkgs = S.fromList . map fst $ dependent_pkgs, - -- Add in the imported modules trusted package - -- requirements. ONLY do this though if we import the - -- module as a safe import. - -- See Note [Tracking Trust Transitively] - -- and Note [Trust Transitive Property] - imp_trust_pkgs = if mod_safe' - then S.fromList . map fst $ filter snd dependent_pkgs - else S.empty, - -- Do we require our own pkg to be trusted? - -- See Note [Trust Own Package] - imp_trust_own_pkg = pkg_trust_req - } - - --- | Issue a warning if the user imports Data.List without either an import --- list or `qualified`. This is part of the migration plan for the --- `Data.List.singleton` proposal. See #17244. -warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () -warnUnqualifiedImport decl iface = - whenWOptM Opt_WarnCompatUnqualifiedImports - $ when bad_import - $ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning - where - mod = mi_module iface - loc = getLoc $ ideclName decl - - is_qual = isImportDeclQualified (ideclQualified decl) - has_import_list = - -- We treat a `hiding` clause as not having an import list although - -- it's not entirely clear this is the right choice. - case ideclHiding decl of - Just (False, _) -> True - _ -> False - bad_import = - mod `elemModuleSet` qualifiedMods - && not is_qual - && not has_import_list - - warning = vcat - [ text "To ensure compatibility with future core libraries changes" - , text "imports to" <+> ppr (ideclName decl) <+> text "should be" - , text "either qualified or have an explicit import list." - ] - - -- Modules for which we warn if we see unqualified imports - qualifiedMods = mkModuleSet [ dATA_LIST ] - - -warnRedundantSourceImport :: ModuleName -> SDoc -warnRedundantSourceImport mod_name - = text "Unnecessary {-# SOURCE #-} in the import of module" - <+> quotes (ppr mod_name) - -{- -************************************************************************ -* * -\subsection{importsFromLocalDecls} -* * -************************************************************************ - -From the top-level declarations of this module produce - * the lexical environment - * the ImportAvails -created by its bindings. - -Note [Top-level Names in Template Haskell decl quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: Note [Interactively-bound Ids in GHCi] in HscTypes - Note [Looking up Exact RdrNames] in RnEnv - -Consider a Template Haskell declaration quotation like this: - module M where - f x = h [d| f = 3 |] -When renaming the declarations inside [d| ...|], we treat the -top level binders specially in two ways - -1. We give them an Internal Name, not (as usual) an External one. - This is done by RnEnv.newTopSrcBinder. - -2. We make them *shadow* the outer bindings. - See Note [GlobalRdrEnv shadowing] - -3. We find out whether we are inside a [d| ... |] by testing the TH - stage. This is a slight hack, because the stage field was really - meant for the type checker, and here we are not interested in the - fields of Brack, hence the error thunks in thRnBrack. --} - -extendGlobalRdrEnvRn :: [AvailInfo] - -> MiniFixityEnv - -> RnM (TcGblEnv, TcLclEnv) --- Updates both the GlobalRdrEnv and the FixityEnv --- We return a new TcLclEnv only because we might have to --- delete some bindings from it; --- see Note [Top-level Names in Template Haskell decl quotes] - -extendGlobalRdrEnvRn avails new_fixities - = do { (gbl_env, lcl_env) <- getEnvs - ; stage <- getStage - ; isGHCi <- getIsGHCi - ; let rdr_env = tcg_rdr_env gbl_env - fix_env = tcg_fix_env gbl_env - th_bndrs = tcl_th_bndrs lcl_env - th_lvl = thLevel stage - - -- Delete new_occs from global and local envs - -- If we are in a TemplateHaskell decl bracket, - -- we are going to shadow them - -- See Note [GlobalRdrEnv shadowing] - inBracket = isBrackStage stage - - lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs } - -- See Note [GlobalRdrEnv shadowing] - - lcl_env2 | inBracket = lcl_env_TH - | otherwise = lcl_env - - -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] - want_shadowing = isGHCi || inBracket - rdr_env1 | want_shadowing = shadowNames rdr_env new_names - | otherwise = rdr_env - - lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs - [ (n, (TopLevel, th_lvl)) - | n <- new_names ] } - - ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres - - ; let fix_env' = foldl' extend_fix_env fix_env new_gres - gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } - - ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) - ; return (gbl_env', lcl_env3) } - where - new_names = concatMap availNames avails - new_occs = map nameOccName new_names - - -- If there is a fixity decl for the gre, add it to the fixity env - extend_fix_env fix_env gre - | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) - = extendNameEnv fix_env name (FixItem occ fi) - | otherwise - = fix_env - where - name = gre_name gre - occ = greOccName gre - - new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails - new_gres = concatMap localGREsFromAvail avails - - add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv - -- Extend the GlobalRdrEnv with a LocalDef GRE - -- If there is already a LocalDef GRE with the same OccName, - -- report an error and discard the new GRE - -- This establishes INVARIANT 1 of GlobalRdrEnvs - add_gre env gre - | not (null dups) -- Same OccName defined twice - = do { addDupDeclErr (gre : dups); return env } - - | otherwise - = return (extendGlobalRdrEnv env gre) - where - occ = greOccName gre - dups = filter isDupGRE (lookupGlobalRdrEnv env occ) - -- Duplicate GREs are those defined locally with the same OccName, - -- except cases where *both* GREs are DuplicateRecordFields (#17965). - isDupGRE gre' = isLocalGRE gre' - && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') - - -{- ********************************************************************* -* * - getLocalDeclBindersd@ returns the names for an HsDecl - It's used for source code. - - *** See Note [The Naming story] in GHC.Hs.Decls **** -* * -********************************************************************* -} - -getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs - -> RnM ((TcGblEnv, TcLclEnv), NameSet) --- Get all the top-level binders bound the group *except* --- for value bindings, which are treated separately --- Specifically we return AvailInfo for --- * type decls (incl constructors and record selectors) --- * class decls (including class ops) --- * associated types --- * foreign imports --- * value signatures (in hs-boot files only) - -getLocalNonValBinders fixity_env - (HsGroup { hs_valds = binds, - hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) - = do { -- Process all type/class decls *except* family instances - ; let inst_decls = tycl_decls >>= group_instds - ; overload_ok <- xoptM LangExt.DuplicateRecordFields - ; (tc_avails, tc_fldss) - <- fmap unzip $ mapM (new_tc overload_ok) - (tyClGroupTyClDecls tycl_decls) - ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) - ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env - ; setEnvs envs $ do { - -- Bring these things into scope first - -- See Note [Looking up family names in family instances] - - -- Process all family instances - -- to bring new data constructors into scope - ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok) - inst_decls - - -- Finish off with value binders: - -- foreign decls and pattern synonyms for an ordinary module - -- type sigs in case of a hs-boot file only - ; is_boot <- tcIsHsBootOrSig - ; let val_bndrs | is_boot = hs_boot_sig_bndrs - | otherwise = for_hs_bndrs - ; val_avails <- mapM new_simple val_bndrs - - ; let avails = concat nti_availss ++ val_avails - new_bndrs = availsToNameSetWithSelectors avails `unionNameSet` - availsToNameSetWithSelectors tc_avails - flds = concat nti_fldss ++ concat tc_fldss - ; traceRn "getLocalNonValBinders 2" (ppr avails) - ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env - - -- Extend tcg_field_env with new fields (this used to be the - -- work of extendRecordFieldEnv) - ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds - envs = (tcg_env { tcg_field_env = field_env }, tcl_env) - - ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) - ; return (envs, new_bndrs) } } - where - ValBinds _ _val_binds val_sigs = binds - - for_hs_bndrs :: [Located RdrName] - for_hs_bndrs = hsForeignDeclsBinders foreign_decls - - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders - hs_boot_sig_bndrs = [ L decl_loc (unLoc n) - | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] - - -- the SrcSpan attached to the input should be the span of the - -- declaration, not just the name - new_simple :: Located RdrName -> RnM AvailInfo - new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name - ; return (avail nm) } - - new_tc :: Bool -> LTyClDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_tc overload_ok tc_decl -- NOT for type/data instances - = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl - ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds - ; let fld_env = case unLoc tc_decl of - DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' - _ -> [] - ; return (AvailTC main_name names flds', fld_env) } - - - -- Calculate the mapping from constructor names to fields, which - -- will go in tcg_field_env. It's convenient to do this here where - -- we are working with a single datatype definition. - mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] - -> [(Name, [FieldLabel])] - mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) - where - find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr - , con_args = RecCon cdflds })) - = [( find_con_name rdr - , concatMap find_con_decl_flds (unLoc cdflds) )] - find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_args = RecCon flds })) - = [ ( find_con_name rdr - , concatMap find_con_decl_flds (unLoc flds)) - | L _ rdr <- rdrs ] - - find_con_flds _ = [] - - find_con_name rdr - = expectJust "getLocalNonValBinders/find_con_name" $ - find (\ n -> nameOccName n == rdrNameOcc rdr) names - find_con_decl_flds (L _ x) - = map find_con_decl_fld (cd_fld_names x) - - find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) - = expectJust "getLocalNonValBinders/find_con_decl_fld" $ - find (\ fl -> flLabel fl == lbl) flds - where lbl = occNameFS (rdrNameOcc rdr) - find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec - - new_assoc :: Bool -> LInstDecl GhcPs - -> RnM ([AvailInfo], [(Name, [FieldLabel])]) - new_assoc _ (L _ (TyFamInstD {})) = return ([], []) - -- type instances don't bind new names - - new_assoc overload_ok (L _ (DataFamInstD _ d)) - = do { (avail, flds) <- new_di overload_ok Nothing d - ; return ([avail], flds) } - new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty - , cid_datafam_insts = adts }))) - = do -- First, attempt to grab the name of the class from the instance. - -- This step could fail if the instance is not headed by a class, - -- such as in the following examples: - -- - -- (1) The class is headed by a bang pattern, such as in - -- `instance !Show Int` (#3811c) - -- (2) The class is headed by a type variable, such as in - -- `instance c` (#16385) - -- - -- If looking up the class name fails, then mb_cls_nm will - -- be Nothing. - mb_cls_nm <- runMaybeT $ do - -- See (1) above - L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty - -- See (2) above - MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr - -- Assuming the previous step succeeded, process any associated data - -- family instances. If the previous step failed, bail out. - case mb_cls_nm of - Nothing -> pure ([], []) - Just cls_nm -> do - (avails, fldss) - <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts - pure (avails, concat fldss) - new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec - new_assoc _ (L _ (XInstDecl nec)) = noExtCon nec - - new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn = - HsIB { hsib_body = ti_decl }}) - = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) - ; let (bndrs, flds) = hsDataFamInstBinders dfid - ; sub_names <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds - ; let avail = AvailTC (unLoc main_name) sub_names flds' - -- main_name is not bound here! - fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' - ; return (avail, fld_env) } - new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec - - new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d -getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec - -newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel -newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec -newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) - = do { selName <- newTopSrcBinder $ L loc $ field - ; return $ qualFieldLbl { flSelector = selName } } - where - fieldOccName = occNameFS $ rdrNameOcc fld - qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok - field | isExact fld = fld - -- use an Exact RdrName as is to preserve the bindings - -- of an already renamer-resolved field and its use - -- sites. This is needed to correctly support record - -- selectors in Template Haskell. See Note [Binders in - -- Template Haskell] in Convert.hs and Note [Looking up - -- Exact RdrNames] in RnEnv.hs. - | otherwise = mkRdrUnqual (flSelector qualFieldLbl) - -{- -Note [Looking up family names in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - module M where - type family T a :: * - type instance M.T Int = Bool - -We might think that we can simply use 'lookupOccRn' when processing the type -instance to look up 'M.T'. Alas, we can't! The type family declaration is in -the *same* HsGroup as the type instance declaration. Hence, as we are -currently collecting the binders declared in that HsGroup, these binders will -not have been added to the global environment yet. - -Solution is simple: process the type family declarations first, extend -the environment, and then process the type instances. - - -************************************************************************ -* * -\subsection{Filtering imports} -* * -************************************************************************ - -@filterImports@ takes the @ExportEnv@ telling what the imported module makes -available, and filters it through the import spec (if any). - -Note [Dealing with imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For import M( ies ), we take the mi_exports of M, and make - imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) -One entry for each Name that M exports; the AvailInfo is the -AvailInfo exported from M that exports that Name. - -The situation is made more complicated by associated types. E.g. - module M where - class C a where { data T a } - instance C Int where { data T Int = T1 | T2 } - instance C Bool where { data T Int = T3 } -Then M's export_avails are (recall the AvailTC invariant from Avails.hs) - C(C,T), T(T,T1,T2,T3) -Notice that T appears *twice*, once as a child and once as a parent. From -this list we construct a raw list including - T -> (T, T( T1, T2, T3 ), Nothing) - T -> (C, C( C, T ), Nothing) -and we combine these (in function 'combine' in 'imp_occ_env' in -'filterImports') to get - T -> (T, T(T,T1,T2,T3), Just C) - -So the overall imp_occ_env is - C -> (C, C(C,T), Nothing) - T -> (T, T(T,T1,T2,T3), Just C) - T1 -> (T1, T(T,T1,T2,T3), Nothing) -- similarly T2,T3 - -If we say - import M( T(T1,T2) ) -then we get *two* Avails: C(T), T(T1,T2) - -Note that the imp_occ_env will have entries for data constructors too, -although we never look up data constructors. --} - -filterImports - :: ModIface - -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, Located [LIE GhcPs]) -- Import spec; True => hiding - -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names - [GlobalRdrElt]) -- Same again, but in GRE form -filterImports iface decl_spec Nothing - = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) - where - imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - -filterImports iface decl_spec (Just (want_hiding, L l import_items)) - = do -- check for errors, convert RdrNames to Names - items1 <- mapM lookup_lie import_items - - let items2 :: [(LIE GhcRn, AvailInfo)] - items2 = concat items1 - -- NB the AvailInfo may have duplicates, and several items - -- for the same parent; e.g N(x) and N(y) - - names = availsToNameSetWithSelectors (map snd items2) - keep n = not (n `elemNameSet` names) - pruned_avails = filterAvails keep all_avails - hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails - | otherwise = concatMap (gresFromIE decl_spec) items2 - - return (Just (want_hiding, L l (map fst items2)), gres) - where - all_avails = mi_exports iface - - -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (Name, -- the name - AvailInfo, -- the export item providing the name - Maybe Name) -- the parent of associated types - imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing)) - | a <- all_avails - , (n, occ) <- availNamesWithOccs a] - where - -- See Note [Dealing with imports] - -- 'combine' is only called for associated data types which appear - -- twice in the all_avails. In the example, we combine - -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) - -- NB: the AvailTC can have fields as well as data constructors (#12127) - combine (name1, a1@(AvailTC p1 _ _), mp1) - (name2, a2@(AvailTC p2 _ _), mp2) - = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 - , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) - if p1 == name1 then (name1, a1, Just p2) - else (name1, a2, Just p1) - combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) - - lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) - lookup_name ie rdr - | isQual rdr = failLookupWith (QualImportError rdr) - | Just succ <- mb_success = return succ - | otherwise = failLookupWith (BadImport ie) - where - mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) - - lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] - lookup_lie (L loc ieRdr) - = do (stuff, warns) <- setSrcSpan loc $ - liftM (fromMaybe ([],[])) $ - run_lookup (lookup_ie ieRdr) - mapM_ emit_warning warns - return [ (L loc ie, avail) | (ie,avail) <- stuff ] - where - -- Warn when importing T(..) if T was exported abstractly - emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n) - emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr) - emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ - addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) - - run_lookup :: IELookupM a -> TcRn (Maybe a) - run_lookup m = case m of - Failed err -> addErr (lookup_err_msg err) >> return Nothing - Succeeded a -> return (Just a) - - lookup_err_msg err = case err of - BadImport ie -> badImportItemErr iface decl_spec ie all_avails - IllegalImport -> illegalImportItemErr - QualImportError rdr -> qualImportItemErr rdr - - -- For each import item, we convert its RdrNames to Names, - -- and at the same time construct an AvailInfo corresponding - -- to what is actually imported by this item. - -- Returns Nothing on error. - -- We return a list here, because in the case of an import - -- item like C, if we are hiding, then C refers to *both* a - -- type/class and a data constructor. Moreover, when we import - -- data constructors of an associated family, we need separate - -- AvailInfos for the data constructors and the family (as they have - -- different parents). See Note [Dealing with imports] - lookup_ie :: IE GhcPs - -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) - lookup_ie ie = handle_bad_import $ do - case ie of - IEVar _ (L l n) -> do - (name, avail, _) <- lookup_name ie $ ieWrappedName n - return ([(IEVar noExtField (L l (replaceWrappedName n name)), - trimAvail avail name)], []) - - IEThingAll _ (L l tc) -> do - (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc - let warns = case avail of - Avail {} -- e.g. f(..) - -> [DodgyImport $ ieWrappedName tc] - - AvailTC _ subs fs - | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym - -> [DodgyImport $ ieWrappedName tc] - - | not (is_qual decl_spec) -- e.g. import M( T(..) ) - -> [MissingImportList] - - | otherwise - -> [] - - renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name)) - sub_avails = case avail of - Avail {} -> [] - AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)] - case mb_parent of - Nothing -> return ([(renamed_ie, avail)], warns) - -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns) - -- associated type - - IEThingAbs _ (L l tc') - | want_hiding -- hiding ( C ) - -- Here the 'C' can be a data constructor - -- *or* a type/class, or even both - -> let tc = ieWrappedName tc' - tc_name = lookup_name ie tc - dc_name = lookup_name ie (setRdrNameSpace tc srcDataName) - in - case catIELookupM [ tc_name, dc_name ] of - [] -> failLookupWith (BadImport ie) - names -> return ([mkIEThingAbs tc' l name | name <- names], []) - | otherwise - -> do nameAvail <- lookup_name ie (ieWrappedName tc') - return ([mkIEThingAbs tc' l nameAvail] - , []) - - IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs -> - ASSERT2(null rdr_fs, ppr rdr_fs) do - (name, avail, mb_parent) - <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc) - - let (ns,subflds) = case avail of - AvailTC _ ns' subflds' -> (ns',subflds') - Avail _ -> panic "filterImports" - - -- Look up the children in the sub-names of the parent - let subnames = case ns of -- The tc is first in ns, - [] -> [] -- if it is there at all - -- See the AvailTC Invariant in Avail.hs - (n1:ns1) | n1 == name -> ns1 - | otherwise -> ns - case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of - - Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs [])) - -- We are trying to import T( a,b,c,d ), and failed - -- to find 'b' and 'd'. So we make up an import item - -- to report as failing, namely T( b, d ). - -- c.f. #15412 - - Succeeded (childnames, childflds) -> - case mb_parent of - -- non-associated ty/cls - Nothing - -> return ([(IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC name (name:map unLoc childnames) (map unLoc childflds))], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - -- childnames' = postrn_ies childnames - -- associated ty - Just parent - -> return ([(IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC parent [name] [])], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - - _other -> failLookupWith IllegalImport - -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed - -- all errors. - - where - mkIEThingAbs tc l (n, av, Nothing ) - = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n) - mkIEThingAbs tc l (n, _, Just parent) - = (IEThingAbs noExtField (L l (replaceWrappedName tc n)) - , AvailTC parent [n] []) - - handle_bad_import m = catchIELookup m $ \err -> case err of - BadImport ie | want_hiding -> return ([], [BadImportW ie]) - _ -> failLookupWith err - -type IELookupM = MaybeErr IELookupError - -data IELookupWarning - = BadImportW (IE GhcPs) - | MissingImportList - | DodgyImport RdrName - -- NB. use the RdrName for reporting a "dodgy" import - -data IELookupError - = QualImportError RdrName - | BadImport (IE GhcPs) - | IllegalImport - -failLookupWith :: IELookupError -> IELookupM a -failLookupWith err = Failed err - -catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a -catchIELookup m h = case m of - Succeeded r -> return r - Failed err -> h err - -catIELookupM :: [IELookupM a] -> [a] -catIELookupM ms = [ a | Succeeded a <- ms ] - -{- -************************************************************************ -* * -\subsection{Import/Export Utils} -* * -************************************************************************ --} - --- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. -gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] -gresFromIE decl_spec (L loc ie, avail) - = gresFromAvail prov_fn avail - where - is_explicit = case ie of - IEThingAll _ name -> \n -> n == lieWrappedName name - _ -> \_ -> True - prov_fn name - = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) - where - item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } - - -{- -Note [Children for duplicate record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the module - - {-# LANGUAGE DuplicateRecordFields #-} - module M (F(foo, MkFInt, MkFBool)) where - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool } - -The `foo` in the export list refers to *both* selectors! For this -reason, lookupChildren builds an environment that maps the FastString -to a list of items, rather than a single item. --} - -mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] -mkChildEnv gres = foldr add emptyNameEnv gres - where - add gre env = case gre_par gre of - FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre - ParentIs p -> extendNameEnv_Acc (:) singleton env p gre - NoParent -> env - -findChildren :: NameEnv [a] -> Name -> [a] -findChildren env n = lookupNameEnv env n `orElse` [] - -lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName] - -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed - ([Located Name], [Located FieldLabel]) --- (lookupChildren all_kids rdr_items) maps each rdr_item to its --- corresponding Name all_kids, if the former exists --- The matching is done by FastString, not OccName, so that --- Cls( meth, AssocTy ) --- will correctly find AssocTy among the all_kids of Cls, even though --- the RdrName for AssocTy may have a (bogus) DataName namespace --- (Really the rdr_items should be FastStrings in the first place.) -lookupChildren all_kids rdr_items - | null fails - = Succeeded (fmap concat (partitionEithers oks)) - -- This 'fmap concat' trickily applies concat to the /second/ component - -- of the pair, whose type is ([Located Name], [[Located FieldLabel]]) - | otherwise - = Failed fails - where - mb_xs = map doOne rdr_items - fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] - oks = [ ok | Succeeded ok <- mb_xs ] - oks :: [Either (Located Name) [Located FieldLabel]] - - doOne item@(L l r) - = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [Left n] -> Succeeded (Left (L l n)) - Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs))) - _ -> Failed item - - -- See Note [Children for duplicate record fields] - kid_env = extendFsEnvList_C (++) emptyFsEnv - [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] - - - -------------------------------- - -{- -********************************************************* -* * -\subsection{Unused names} -* * -********************************************************* --} - -reportUnusedNames :: TcGblEnv -> HscSource -> RnM () -reportUnusedNames gbl_env hsc_src - = do { keep <- readTcRef (tcg_keep gbl_env) - ; traceRn "RUN" (ppr (tcg_dus gbl_env)) - ; warnUnusedImportDecls gbl_env hsc_src - ; warnUnusedTopBinds $ unused_locals keep - ; warnMissingSignatures gbl_env } - where - used_names :: NameSet -> NameSet - used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep - -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used - -- Hence findUses - - -- Collect the defined names from the in-scope environment - defined_names :: [GlobalRdrElt] - defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) - - kids_env = mkChildEnv defined_names - -- This is done in mkExports too; duplicated work - - gre_is_used :: NameSet -> GlobalRdrElt -> Bool - gre_is_used used_names (GRE {gre_name = name}) - = name `elemNameSet` used_names - || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name) - -- A use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - - -- Filter out the ones that are - -- (a) defined in this module, and - -- (b) not defined by a 'deriving' clause - -- The latter have an Internal Name, so we can filter them out easily - unused_locals :: NameSet -> [GlobalRdrElt] - unused_locals keep = - let -- Note that defined_and_used, defined_but_not_used - -- are both [GRE]; that's why we need defined_and_used - -- rather than just used_names - _defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (_defined_and_used, defined_but_not_used) - = partition (gre_is_used (used_names keep)) defined_names - - in filter is_unused_local defined_but_not_used - is_unused_local :: GlobalRdrElt -> Bool - is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) - -{- ********************************************************************* -* * - Missing signatures -* * -********************************************************************* -} - --- | Warn the user about top level binders that lack type signatures. --- Called /after/ type inference, so that we can report the --- inferred type of the function -warnMissingSignatures :: TcGblEnv -> RnM () -warnMissingSignatures gbl_env - = do { let exports = availsToNameSet (tcg_exports gbl_env) - sig_ns = tcg_sigs gbl_env - -- We use sig_ns to exclude top-level bindings that are generated by GHC - binds = collectHsBindsBinders $ tcg_binds gbl_env - pat_syns = tcg_patsyns gbl_env - - -- Warn about missing signatures - -- Do this only when we have a type to offer - ; warn_missing_sigs <- woptM Opt_WarnMissingSignatures - ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures - ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures - - ; let add_sig_warns - | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures - | warn_missing_sigs = add_warns Opt_WarnMissingSignatures - | warn_pat_syns = add_warns Opt_WarnMissingPatternSynonymSignatures - | otherwise = return () - - add_warns flag - = when warn_pat_syns - (mapM_ add_pat_syn_warn pat_syns) >> - when (warn_missing_sigs || warn_only_exported) - (mapM_ add_bind_warn binds) - where - add_pat_syn_warn p - = add_warn name $ - hang (text "Pattern synonym with no type signature:") - 2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty) - where - name = patSynName p - pp_ty = pprPatSynType p - - add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) () - add_bind_warn id - = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? - ; let name = idName id - (_, ty) = tidyOpenType env (idType id) - ty_msg = pprSigmaType ty - ; add_warn name $ - hang (text "Top-level binding with no type signature:") - 2 (pprPrefixName name <+> dcolon <+> ty_msg) } - - add_warn name msg - = when (name `elemNameSet` sig_ns && export_check name) - (addWarnAt (Reason flag) (getSrcSpan name) msg) - - export_check name - = not warn_only_exported || name `elemNameSet` exports - - ; add_sig_warns } - - -{- -********************************************************* -* * -\subsection{Unused imports} -* * -********************************************************* - -This code finds which import declarations are unused. The -specification and implementation notes are here: - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports - -See also Note [Choosing the best import declaration] in RdrName --} - -type ImportDeclUsage - = ( LImportDecl GhcRn -- The import declaration - , [GlobalRdrElt] -- What *is* used (normalised) - , [Name] ) -- What is imported but *not* used - -warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM () -warnUnusedImportDecls gbl_env hsc_src - = do { uses <- readMutVar (tcg_used_gres gbl_env) - ; let user_imports = filterOut - (ideclImplicit . unLoc) - (tcg_rn_imports gbl_env) - -- This whole function deals only with *user* imports - -- both for warning about unnecessary ones, and for - -- deciding the minimal ones - rdr_env = tcg_rdr_env gbl_env - fld_env = mkFieldEnv rdr_env - - ; let usage :: [ImportDeclUsage] - usage = findImportUsage user_imports uses - - ; traceRn "warnUnusedImportDecls" $ - (vcat [ text "Uses:" <+> ppr uses - , text "Import usage" <+> ppr usage]) - - ; whenWOptM Opt_WarnUnusedImports $ - mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage - - ; whenGOptM Opt_D_dump_minimal_imports $ - printMinimalImports hsc_src usage } - -findImportUsage :: [LImportDecl GhcRn] - -> [GlobalRdrElt] - -> [ImportDeclUsage] - -findImportUsage imports used_gres - = map unused_decl imports - where - import_usage :: ImportMap - import_usage = mkImportMap used_gres - - unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) - = (decl, used_gres, nameSetElemsStable unused_imps) - where - used_gres = Map.lookup (srcSpanEnd loc) import_usage - -- srcSpanEnd: see Note [The ImportMap] - `orElse` [] - - used_names = mkNameSet (map gre_name used_gres) - used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) - - unused_imps -- Not trivial; see eg #7454 - = case imps of - Just (False, L _ imp_ies) -> - foldr (add_unused . unLoc) emptyNameSet imp_ies - _other -> emptyNameSet -- No explicit import list => no unused-name list - - add_unused :: IE GhcRn -> NameSet -> NameSet - add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc - add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc - add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc - add_unused (IEThingWith _ p wc ns fs) acc = - add_wc_all (add_unused_with pn xs acc) - where pn = lieWrappedName p - xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs - add_wc_all = case wc of - NoIEWildcard -> id - IEWildcard _ -> add_unused_all pn - add_unused _ acc = acc - - add_unused_name n acc - | n `elemNameSet` used_names = acc - | otherwise = acc `extendNameSet` n - add_unused_all n acc - | n `elemNameSet` used_names = acc - | n `elemNameSet` used_parents = acc - | otherwise = acc `extendNameSet` n - add_unused_with p ns acc - | all (`elemNameSet` acc1) ns = add_unused_name p acc1 - | otherwise = acc1 - where - acc1 = foldr add_unused_name acc ns - -- If you use 'signum' from Num, then the user may well have - -- imported Num(signum). We don't want to complain that - -- Num is not itself mentioned. Hence the two cases in add_unused_with. - unused_decl (L _ (XImportDecl nec)) = noExtCon nec - - -{- Note [The ImportMap] -~~~~~~~~~~~~~~~~~~~~~~~ -The ImportMap is a short-lived intermediate data structure records, for -each import declaration, what stuff brought into scope by that -declaration is actually used in the module. - -The SrcLoc is the location of the END of a particular 'import' -declaration. Why *END*? Because we don't want to get confused -by the implicit Prelude import. Consider (#7476) the module - import Foo( foo ) - main = print foo -There is an implicit 'import Prelude(print)', and it gets a SrcSpan -of line 1:1 (just the point, not a span). If we use the *START* of -the SrcSpan to identify the import decl, we'll confuse the implicit -import Prelude with the explicit 'import Foo'. So we use the END. -It's just a cheap hack; we could equally well use the Span too. - -The [GlobalRdrElt] are the things imported from that decl. --} - -type ImportMap = Map SrcLoc [GlobalRdrElt] -- See [The ImportMap] - -- If loc :-> gres, then - -- 'loc' = the end loc of the bestImport of each GRE in 'gres' - -mkImportMap :: [GlobalRdrElt] -> ImportMap --- For each of a list of used GREs, find all the import decls that brought --- it into scope; choose one of them (bestImport), and record --- the RdrName in that import decl's entry in the ImportMap -mkImportMap gres - = foldr add_one Map.empty gres - where - add_one gre@(GRE { gre_imp = imp_specs }) imp_map - = Map.insertWith add decl_loc [gre] imp_map - where - best_imp_spec = bestImport imp_specs - decl_loc = srcSpanEnd (is_dloc (is_decl best_imp_spec)) - -- For srcSpanEnd see Note [The ImportMap] - add _ gres = gre : gres - -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) - -> ImportDeclUsage -> RnM () -warnUnusedImport flag fld_env (L loc decl, used, unused) - - -- Do not warn for 'import M()' - | Just (False,L _ []) <- ideclHiding decl - = return () - - -- Note [Do not warn about Prelude hiding] - | Just (True, L _ hides) <- ideclHiding decl - , not (null hides) - , pRELUDE_NAME == unLoc (ideclName decl) - = return () - - -- Nothing used; drop entire declaration - | null used - = addWarnAt (Reason flag) loc msg1 - - -- Everything imported is used; nop - | null unused - = return () - - -- Some imports are unused - | otherwise - = addWarnAt (Reason flag) loc msg2 - - where - msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant - , nest 2 (text "except perhaps to import instances from" - <+> quotes pp_mod) - , text "To import instances alone, use:" - <+> text "import" <+> pp_mod <> parens Outputable.empty ] - msg2 = sep [ pp_herald <+> quotes sort_unused - , text "from module" <+> quotes pp_mod <+> is_redundant] - pp_herald = text "The" <+> pp_qual <+> text "import of" - pp_qual - | isImportDeclQualified (ideclQualified decl)= text "qualified" - | otherwise = Outputable.empty - pp_mod = ppr (unLoc (ideclName decl)) - is_redundant = text "is redundant" - - -- In warning message, pretty-print identifiers unqualified unconditionally - -- to improve the consistent for ambiguous/unambiguous identifiers. - -- See trac#14881. - ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld) - Nothing -> pprNameUnqualified n - - -- Print unused names in a deterministic (lexicographic) order - sort_unused :: SDoc - sort_unused = pprWithCommas ppr_possible_field $ - sortBy (comparing nameOccName) unused - -{- -Note [Do not warn about Prelude hiding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not warn about - import Prelude hiding( x, y ) -because even if nothing else from Prelude is used, it may be essential to hide -x,y to avoid name-shadowing warnings. Example (#9061) - import Prelude hiding( log ) - f x = log where log = () - - - -Note [Printing minimal imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To print the minimal imports we walk over the user-supplied import -decls, and simply trim their import lists. NB that - - * We do *not* change the 'qualified' or 'as' parts! - - * We do not disard a decl altogether; we might need instances - from it. Instead we just trim to an empty import list --} - -getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] -getMinimalImports = mapM mk_minimal - where - mk_minimal (L l decl, used_gres, unused) - | null unused - , Just (False, _) <- ideclHiding decl - = return (L l decl) - | otherwise - = do { let ImportDecl { ideclName = L _ mod_name - , ideclSource = is_boot - , ideclPkgQual = mb_pkg } = decl - ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg) - ; let used_avails = gresToAvailInfo used_gres - lies = map (L l) (concatMap (to_ie iface) used_avails) - ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } - where - doc = text "Compute minimal imports for" <+> ppr decl - - to_ie :: ModIface -> AvailInfo -> [IE GhcRn] - -- The main trick here is that if we're importing all the constructors - -- we want to say "T(..)", but if we're importing only a subset we want - -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail n) - = [IEVar noExtField (to_ie_post_rn $ noLoc n)] - to_ie _ (AvailTC n [m] []) - | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] - to_ie iface (AvailTC n ns fs) - = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface - , x == n - , x `elem` xs -- Note [Partial export] - ] of - [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)] - | otherwise -> - [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] - -- Note [Overloaded field import] - _other | all_non_overloaded fs - -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns - ++ map flSelector fs - | otherwise -> - [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] - where - - fld_lbls = map flLabel fs - - all_used (avail_occs, avail_flds) - = all (`elem` ns) avail_occs - && all (`elem` fld_lbls) (map flLabel avail_flds) - - all_non_overloaded = all (not . flIsOverloaded) - -printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () --- See Note [Printing minimal imports] -printMinimalImports hsc_src imports_w_usage - = do { imports' <- getMinimalImports imports_w_usage - ; this_mod <- getModule - ; dflags <- getDynFlags - ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> - printForUser dflags h neverQualify (vcat (map ppr imports')) - -- The neverQualify is important. We are printing Names - -- but they are in the context of an 'import' decl, and - -- we never qualify things inside there - -- E.g. import Blag( f, b ) - -- not import Blag( Blag.f, Blag.g )! - } - where - mkFilename dflags this_mod - | Just d <- dumpDir dflags = d basefn - | otherwise = basefn - where - suffix = case hsc_src of - HsBootFile -> ".imports-boot" - HsSrcFile -> ".imports" - HsigFile -> ".imports" - basefn = moduleNameString (moduleName this_mod) ++ suffix - - -to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name -to_ie_post_rn_var (L l n) - | isDataOcc $ occName n = L l (IEPattern (L l n)) - | otherwise = L l (IEName (L l n)) - - -to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name -to_ie_post_rn (L l n) - | isTcOcc occ && isSymOcc occ = L l (IEType (L l n)) - | otherwise = L l (IEName (L l n)) - where occ = occName n - -{- -Note [Partial export] -~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - module A( op ) where - class C a where - op :: a -> a - - module B where - import A - f = ..op... - -Then the minimal import for module B is - import A( op ) -not - import A( C( op ) ) -which we would usually generate if C was exported from B. Hence -the (x `elem` xs) test when deciding what to generate. - - -Note [Overloaded field import] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On the other hand, if we have - - {-# LANGUAGE DuplicateRecordFields #-} - module A where - data T = MkT { foo :: Int } - - module B where - import A - f = ...foo... - -then the minimal import for module B must be - import A ( T(foo) ) -because when DuplicateRecordFields is enabled, field selectors are -not in scope without their enclosing datatype. - - -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -qualImportItemErr :: RdrName -> SDoc -qualImportItemErr rdr - = hang (text "Illegal qualified name in import item:") - 2 (ppr rdr) - -badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc -badImportItemErrStd iface decl_spec ie - = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import, - text "does not export", quotes (ppr ie)] - where - source_import | mi_boot iface = text "(hi-boot interface)" - | otherwise = Outputable.empty - -badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs - -> SDoc -badImportItemErrDataCon dataType_occ iface decl_spec ie - = vcat [ text "In module" - <+> quotes (ppr (is_mod decl_spec)) - <+> source_import <> colon - , nest 2 $ quotes datacon - <+> text "is a data constructor of" - <+> quotes dataType - , text "To import it use" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> parens_sp datacon) - , text "or" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> text "(..)") - ] - where - datacon_occ = rdrNameOcc $ ieName ie - datacon = parenSymOcc datacon_occ (ppr datacon_occ) - dataType = parenSymOcc dataType_occ (ppr dataType_occ) - source_import | mi_boot iface = text "(hi-boot interface)" - | otherwise = Outputable.empty - parens_sp d = parens (space <> d <> space) -- T( f,g ) - -badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc -badImportItemErr iface decl_spec ie avails - = case find checkIfDataCon avails of - Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie - Nothing -> badImportItemErrStd iface decl_spec ie - where - checkIfDataCon (AvailTC _ ns _) = - case find (\n -> importedFS == nameOccNameFS n) ns of - Just n -> isDataConName n - Nothing -> False - checkIfDataCon _ = False - availOccName = nameOccName . availName - nameOccNameFS = occNameFS . nameOccName - importedFS = occNameFS . rdrNameOcc $ ieName ie - -illegalImportItemErr :: SDoc -illegalImportItemErr = text "Illegal import item" - -dodgyImportWarn :: RdrName -> SDoc -dodgyImportWarn item - = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs) - -dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc -dodgyMsg kind tc ie - = sep [ text "The" <+> kind <+> ptext (sLit "item") - -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) - <+> quotes (ppr ie) - <+> text "suggests that", - quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", - text "but it has none" ] - -dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) -dodgyMsgInsert tc = IEThingAll noExtField ii - where - ii :: LIEWrappedName (IdP (GhcPass p)) - ii = noLoc (IEName $ noLoc tc) - - -addDupDeclErr :: [GlobalRdrElt] -> TcRn () -addDupDeclErr [] = panic "addDupDeclErr: empty list" -addDupDeclErr gres@(gre : _) - = addErrAt (getSrcSpan (last sorted_names)) $ - -- Report the error at the later location - vcat [text "Multiple declarations of" <+> - quotes (ppr (greOccName gre)), - -- NB. print the OccName, not the Name, because the - -- latter might not be in scope in the RdrEnv and so will - -- be printed qualified. - text "Declared at:" <+> - vcat (map (ppr . nameSrcLoc) sorted_names)] - where - sorted_names = sortWith nameSrcLoc (map gre_name gres) - - - -missingImportListWarn :: ModuleName -> SDoc -missingImportListWarn mod - = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") - -missingImportListItem :: IE GhcPs -> SDoc -missingImportListItem ie - = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") - -moduleWarn :: ModuleName -> WarningTxt -> SDoc -moduleWarn mod (WarningTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"), - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] -moduleWarn mod (DeprecatedTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) - <+> text "is deprecated:", - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] - -packageImportErr :: SDoc -packageImportErr - = text "Package-qualified imports are not enabled; use PackageImports" - --- This data decl will parse OK --- data T = a Int --- treating "a" as the constructor. --- It is really hard to make the parser spot this malformation. --- So the renamer has to check that the constructor is legal --- --- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int --- from interface files, which always print in prefix form - -checkConName :: RdrName -> TcRn () -checkConName name = checkErr (isRdrDataCon name) (badDataCon name) - -badDataCon :: RdrName -> SDoc -badDataCon name - = hsep [text "Illegal data constructor name", quotes (ppr name)] diff --git a/rename/RnPat.hs b/rename/RnPat.hs deleted file mode 100644 --- a/rename/RnPat.hs +++ /dev/null @@ -1,900 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnPat]{Renaming of patterns} - -Basically dependency analysis. - -Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In -general, all of these functions return a renamed thing, and a set of -free variables. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveFunctor #-} - -module RnPat (-- main entry points - rnPat, rnPats, rnBindPat, rnPatAndThen, - - NameMaker, applyNameMaker, -- a utility for making names: - localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, - -- sometimes we want to make top (qualified) names. - isTopRecNameMaker, - - rnHsRecFields, HsRecFieldContext(..), - rnHsRecUpdFields, - - -- CpsRn monad - CpsRn, liftCps, - - -- Literals - rnLit, rnOverLit, - - -- Pattern Error messages that are also used elsewhere - checkTupSize, patSigErr - ) where - --- ENH: thin imports to only what is necessary for patterns - -import GhcPrelude - -import {-# SOURCE #-} RnExpr ( rnLExpr ) -import {-# SOURCE #-} RnSplice ( rnSplicePat ) - -#include "HsVersions.h" - -import GHC.Hs -import TcRnMonad -import TcHsSyn ( hsOverLitName ) -import RnEnv -import RnFixity -import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames - , warnUnusedMatches, newLocalBndrRn - , checkUnusedRecordWildcard - , checkDupNames, checkDupAndShadowedNames - , checkTupSize , unknownSubordinateErr ) -import RnTypes -import PrelNames -import Name -import NameSet -import RdrName -import BasicTypes -import Util -import ListSetOps ( removeDups ) -import Outputable -import SrcLoc -import Literal ( inCharRange ) -import TysWiredIn ( nilDataCon ) -import DataCon -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad ( when, ap, guard ) -import qualified Data.List.NonEmpty as NE -import Data.Ratio - -{- -********************************************************* -* * - The CpsRn Monad -* * -********************************************************* - -Note [CpsRn monad] -~~~~~~~~~~~~~~~~~~ -The CpsRn monad uses continuation-passing style to support this -style of programming: - - do { ... - ; ns <- bindNames rs - ; ...blah... } - - where rs::[RdrName], ns::[Name] - -The idea is that '...blah...' - a) sees the bindings of ns - b) returns the free variables it mentions - so that bindNames can report unused ones - -In particular, - mapM rnPatAndThen [p1, p2, p3] -has a *left-to-right* scoping: it makes the binders in -p1 scope over p2,p3. --} - -newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) - -> RnM (r, FreeVars) } - deriving (Functor) - -- See Note [CpsRn monad] - -instance Applicative CpsRn where - pure x = CpsRn (\k -> k x) - (<*>) = ap - -instance Monad CpsRn where - (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k)) - -runCps :: CpsRn a -> RnM (a, FreeVars) -runCps (CpsRn m) = m (\r -> return (r, emptyFVs)) - -liftCps :: RnM a -> CpsRn a -liftCps rn_thing = CpsRn (\k -> rn_thing >>= k) - -liftCpsFV :: RnM (a, FreeVars) -> CpsRn a -liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing - ; (r,fvs2) <- k v - ; return (r, fvs1 `plusFV` fvs2) }) - -wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b --- Set the location, and also wrap it around the value returned -wrapSrcSpanCps fn (dL->L loc a) - = CpsRn (\k -> setSrcSpan loc $ - unCpsRn (fn a) $ \v -> - k (cL loc v)) - -lookupConCps :: Located RdrName -> CpsRn (Located Name) -lookupConCps con_rdr - = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr - ; (r, fvs) <- k con_name - ; return (r, addOneFV fvs (unLoc con_name)) }) - -- We add the constructor name to the free vars - -- See Note [Patterns are uses] - -{- -Note [Patterns are uses] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - module Foo( f, g ) where - data T = T1 | T2 - - f T1 = True - f T2 = False - - g _ = T1 - -Arguably we should report T2 as unused, even though it appears in a -pattern, because it never occurs in a constructed position. See -#7336. -However, implementing this in the face of pattern synonyms would be -less straightforward, since given two pattern synonyms - - pattern P1 <- P2 - pattern P2 <- () - -we need to observe the dependency between P1 and P2 so that type -checking can be done in the correct order (just like for value -bindings). Dependencies between bindings is analyzed in the renamer, -where we don't know yet whether P2 is a constructor or a pattern -synonym. So for now, we do report conid occurrences in patterns as -uses. - -********************************************************* -* * - Name makers -* * -********************************************************* - -Externally abstract type of name makers, -which is how you go from a RdrName to a Name --} - -data NameMaker - = LamMk -- Lambdas - Bool -- True <=> report unused bindings - -- (even if True, the warning only comes out - -- if -Wunused-matches is on) - - | LetMk -- Let bindings, incl top level - -- Do *not* check for unused bindings - TopLevelFlag - MiniFixityEnv - -topRecNameMaker :: MiniFixityEnv -> NameMaker -topRecNameMaker fix_env = LetMk TopLevel fix_env - -isTopRecNameMaker :: NameMaker -> Bool -isTopRecNameMaker (LetMk TopLevel _) = True -isTopRecNameMaker _ = False - -localRecNameMaker :: MiniFixityEnv -> NameMaker -localRecNameMaker fix_env = LetMk NotTopLevel fix_env - -matchNameMaker :: HsMatchContext a -> NameMaker -matchNameMaker ctxt = LamMk report_unused - where - -- Do not report unused names in interactive contexts - -- i.e. when you type 'x <- e' at the GHCi prompt - report_unused = case ctxt of - StmtCtxt GhciStmtCtxt -> False - -- also, don't warn in pattern quotes, as there - -- is no RHS where the variables can be used! - ThPatQuote -> False - _ -> True - -rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) -rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) - -newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) -newPatLName name_maker rdr_name@(dL->L loc _) - = do { name <- newPatName name_maker rdr_name - ; return (cL loc name) } - -newPatName :: NameMaker -> Located RdrName -> CpsRn Name -newPatName (LamMk report_unused) rdr_name - = CpsRn (\ thing_inside -> - do { name <- newLocalBndrRn rdr_name - ; (res, fvs) <- bindLocalNames [name] (thing_inside name) - ; when report_unused $ warnUnusedMatches [name] fvs - ; return (res, name `delFV` fvs) }) - -newPatName (LetMk is_top fix_env) rdr_name - = CpsRn (\ thing_inside -> - do { name <- case is_top of - NotTopLevel -> newLocalBndrRn rdr_name - TopLevel -> newTopSrcBinder rdr_name - ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here - -- See Note [View pattern usage] - addLocalFixities fix_env [name] $ - thing_inside name }) - - -- Note: the bindLocalNames is somewhat suspicious - -- because it binds a top-level name as a local name. - -- however, this binding seems to work, and it only exists for - -- the duration of the patterns and the continuation; - -- then the top-level name is added to the global env - -- before going on to the RHSes (see RnSource.hs). - -{- -Note [View pattern usage] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let (r, (r -> x)) = x in ... -Here the pattern binds 'r', and then uses it *only* in the view pattern. -We want to "see" this use, and in let-bindings we collect all uses and -report unused variables at the binding level. So we must use bindLocalNames -here, *not* bindLocalNameFV. #3943. - - -Note [Don't report shadowing for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is one special context where a pattern doesn't introduce any new binders - -pattern synonym declarations. Therefore we don't check to see if pattern -variables shadow existing identifiers as they are never bound to anything -and have no scope. - -Without this check, there would be quite a cryptic warning that the `x` -in the RHS of the pattern synonym declaration shadowed the top level `x`. - -``` -x :: () -x = () - -pattern P x = Just x -``` - -See #12615 for some more examples. - -********************************************************* -* * - External entry points -* * -********************************************************* - -There are various entry points to renaming patterns, depending on - (1) whether the names created should be top-level names or local names - (2) whether the scope of the names is entirely given in a continuation - (e.g., in a case or lambda, but not in a let or at the top-level, - because of the way mutually recursive bindings are handled) - (3) whether the a type signature in the pattern can bind - lexically-scoped type variables (for unpacking existential - type vars in data constructors) - (4) whether we do duplicate and unused variable checking - (5) whether there are fixity declarations associated with the names - bound by the patterns that need to be brought into scope with them. - - Rather than burdening the clients of this module with all of these choices, - we export the three points in this design space that we actually need: --} - --- ----------- Entry point 1: rnPats ------------------- --- Binds local names; the scope of the bindings is entirely in the thing_inside --- * allows type sigs to bind type vars --- * local namemaker --- * unused and duplicate checking --- * no fixities -rnPats :: HsMatchContext Name -- for error messages - -> [LPat GhcPs] - -> ([LPat GhcRn] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnPats ctxt pats thing_inside - = do { envs_before <- getRdrEnvs - - -- (1) rename the patterns, bringing into scope all of the term variables - -- (2) then do the thing inside. - ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do - { -- Check for duplicated and shadowed names - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in GHC.Hs.Utils - -- Because we don't bind the vars all at once, we can't - -- check incrementally for duplicates; - -- Nor can we check incrementally for shadowing, else we'll - -- complain *twice* about duplicates e.g. f (x,x) = ... - -- - -- See note [Don't report shadowing for pattern synonyms] - ; let bndrs = collectPatsBinders pats' - ; addErrCtxt doc_pat $ - if isPatSynCtxt ctxt - then checkDupNames bndrs - else checkDupAndShadowedNames envs_before bndrs - ; thing_inside pats' } } - where - doc_pat = text "In" <+> pprMatchContext ctxt - -rnPat :: HsMatchContext Name -- for error messages - -> LPat GhcPs - -> (LPat GhcRn -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -- Variables bound by pattern do not - -- appear in the result FreeVars -rnPat ctxt pat thing_inside - = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') - -applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name) -applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) - ; return n } - --- ----------- Entry point 2: rnBindPat ------------------- --- Binds local names; in a recursive scope that involves other bound vars --- e.g let { (x, Just y) = e1; ... } in ... --- * does NOT allows type sig to bind type vars --- * local namemaker --- * no unused and duplicate checking --- * fixities might be coming in -rnBindPat :: NameMaker - -> LPat GhcPs - -> RnM (LPat GhcRn, FreeVars) - -- Returned FreeVars are the free variables of the pattern, - -- of course excluding variables bound by this pattern - -rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) - -{- -********************************************************* -* * - The main event -* * -********************************************************* --} - --- ----------- Entry point 3: rnLPatAndThen ------------------- --- General version: parametrized by how you make new names - -rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] -rnLPatsAndThen mk = mapM (rnLPatAndThen mk) - -- Despite the map, the monad ensures that each pattern binds - -- variables that may be mentioned in subsequent patterns in the list - --------------------- --- The workhorse -rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) -rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat - -rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) -rnPatAndThen _ (WildPat _) = return (WildPat noExtField) -rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat - ; return (ParPat x pat') } -rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat - ; return (LazyPat x pat') } -rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat - ; return (BangPat x pat') } -rnPatAndThen mk (VarPat x (dL->L l rdr)) - = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (cL loc rdr) - ; return (VarPat x (cL l name)) } - -- we need to bind pattern variables for view pattern expressions - -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) - -rnPatAndThen mk (SigPat x pat sig) - -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is - -- important to rename its type signature _before_ renaming the rest of the - -- pattern, so that type variables are first bound by the _outermost_ pattern - -- type signature they occur in. This keeps the type checker happy when - -- pattern type signatures happen to be nested (#7827) - -- - -- f ((Just (x :: a) :: Maybe a) - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here - -- ~~~~~~~~~~~~~~~^ the same `a' then used here - = do { sig' <- rnHsSigCps sig - ; pat' <- rnLPatAndThen mk pat - ; return (SigPat x pat' sig' ) } - -rnPatAndThen mk (LitPat x lit) - | HsString src s <- lit - = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) - ; if ovlStr - then rnPatAndThen mk - (mkNPat (noLoc (mkHsIsString src s)) - Nothing) - else normal_lit } - | otherwise = normal_lit - where - normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } - -rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) - = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit - ; mb_neg' -- See Note [Negative zero] - <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName - ; return (Just neg, fvs) } - positive = return (Nothing, emptyFVs) - in liftCpsFV $ case (mb_neg , mb_neg') of - (Nothing, Just _ ) -> negative - (Just _ , Nothing) -> negative - (Nothing, Nothing) -> positive - (Just _ , Just _ ) -> positive - ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat x (cL l lit') mb_neg' eq') } - -rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) - = do { new_name <- newPatName mk rdr - ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] - -- We skip negateName as - -- negative zero doesn't make - -- sense in n + k patterns - ; minus <- liftCpsFV $ lookupSyntaxName minusName - ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name) - (cL l lit') lit' ge minus) } - -- The Report says that n+k patterns must be in Integral - -rnPatAndThen mk (AsPat x rdr pat) - = do { new_name <- newPatLName mk rdr - ; pat' <- rnLPatAndThen mk pat - ; return (AsPat x new_name pat') } - -rnPatAndThen mk p@(ViewPat x expr pat) - = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns - ; checkErr vp_flag (badViewPat p) } - -- Because of the way we're arranging the recursive calls, - -- this will be in the right context - ; expr' <- liftCpsFV $ rnLExpr expr - ; pat' <- rnLPatAndThen mk pat - -- Note: at this point the PreTcType in ty can only be a placeHolder - -- ; return (ViewPat expr' pat' ty) } - ; return (ViewPat x expr' pat') } - -rnPatAndThen mk (ConPatIn con stuff) - -- rnConPatAndThen takes care of reconstructing the pattern - -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. - = case unLoc con == nameRdrName (dataConName nilDataCon) of - True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists - ; if ol_flag then rnPatAndThen mk (ListPat noExtField []) - else rnConPatAndThen mk con stuff} - False -> rnConPatAndThen mk con stuff - -rnPatAndThen mk (ListPat _ pats) - = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists - ; pats' <- rnLPatsAndThen mk pats - ; case opt_OverloadedLists of - True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName - ; return (ListPat (Just to_list_name) pats')} - False -> return (ListPat Nothing pats') } - -rnPatAndThen mk (TuplePat x pats boxed) - = do { liftCps $ checkTupSize (length pats) - ; pats' <- rnLPatsAndThen mk pats - ; return (TuplePat x pats' boxed) } - -rnPatAndThen mk (SumPat x pat alt arity) - = do { pat <- rnLPatAndThen mk pat - ; return (SumPat x pat alt arity) - } - --- If a splice has been run already, just rename the result. -rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat))) - = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat - -rnPatAndThen mk (SplicePat _ splice) - = do { eith <- liftCpsFV $ rnSplicePat splice - ; case eith of -- See Note [rnSplicePat] in RnSplice - Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed - Right already_renamed -> return already_renamed } - -rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) - - --------------------- -rnConPatAndThen :: NameMaker - -> Located RdrName -- the constructor - -> HsConPatDetails GhcPs - -> CpsRn (Pat GhcRn) - -rnConPatAndThen mk con (PrefixCon pats) - = do { con' <- lookupConCps con - ; pats' <- rnLPatsAndThen mk pats - ; return (ConPatIn con' (PrefixCon pats')) } - -rnConPatAndThen mk con (InfixCon pat1 pat2) - = do { con' <- lookupConCps con - ; pat1' <- rnLPatAndThen mk pat1 - ; pat2' <- rnLPatAndThen mk pat2 - ; fixity <- liftCps $ lookupFixityRn (unLoc con') - ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } - -rnConPatAndThen mk con (RecCon rpats) - = do { con' <- lookupConCps con - ; rpats' <- rnHsRecPatsAndThen mk con' rpats - ; return (ConPatIn con' (RecCon rpats')) } - -checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn () -checkUnusedRecordWildcardCps loc dotdot_names = - CpsRn (\thing -> do - (r, fvs) <- thing () - checkUnusedRecordWildcard loc fvs dotdot_names - return (r, fvs) ) --------------------- -rnHsRecPatsAndThen :: NameMaker - -> Located Name -- Constructor - -> HsRecFields GhcPs (LPat GhcPs) - -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) -rnHsRecPatsAndThen mk (dL->L _ con) - hs_rec_fields@(HsRecFields { rec_dotdot = dd }) - = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat - hs_rec_fields - ; flds' <- mapM rn_field (flds `zip` [1..]) - ; check_unused_wildcard (implicit_binders flds' <$> dd) - ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } - where - mkVarPat l n = VarPat noExtField (cL l n) - rn_field (dL->L l fld, n') = - do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldArg = arg' })) } - - loc = maybe noSrcSpan getLoc dd - - -- Get the arguments of the implicit binders - implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats - where - implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs) - - -- Don't warn for let P{..} = ... in ... - check_unused_wildcard = case mk of - LetMk{} -> const (return ()) - LamMk{} -> checkUnusedRecordWildcardCps loc - - -- Suppress unused-match reporting for fields introduced by ".." - nested_mk Nothing mk _ = mk - nested_mk (Just _) mk@(LetMk {}) _ = mk - nested_mk (Just (unLoc -> n)) (LamMk report_unused) n' - = LamMk (report_unused && (n' <= n)) - -{- -************************************************************************ -* * - Record fields -* * -************************************************************************ --} - -data HsRecFieldContext - = HsRecFieldCon Name - | HsRecFieldPat Name - | HsRecFieldUpd - -rnHsRecFields - :: forall arg. HasSrcSpan arg => - HsRecFieldContext - -> (SrcSpan -> RdrName -> SrcSpanLess arg) - -- When punning, use this to build a new field - -> HsRecFields GhcPs arg - -> RnM ([LHsRecField GhcRn arg], FreeVars) - --- This surprisingly complicated pass --- a) looks up the field name (possibly using disambiguation) --- b) fills in puns and dot-dot stuff --- When we've finished, we've renamed the LHS, but not the RHS, --- of each x=e binding --- --- This is used for record construction and pattern-matching, but not updates. - -rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) - = do { pun_ok <- xoptM LangExt.RecordPuns - ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields - ; let parent = guard disambig_ok >> mb_con - ; flds1 <- mapM (rn_fld pun_ok parent) flds - ; mapM_ (addErr . dupFieldErr ctxt) dup_flds - ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 - ; let all_flds | null dotdot_flds = flds1 - | otherwise = flds1 ++ dotdot_flds - ; return (all_flds, mkFVs (getFieldIds all_flds)) } - where - mb_con = case ctxt of - HsRecFieldCon con -> Just con - HsRecFieldPat con -> Just con - _ {- update -} -> Nothing - - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg - -> RnM (LHsRecField GhcRn arg) - rn_fld pun_ok parent (dL->L l - (HsRecField - { hsRecFieldLbl = - (dL->L loc (FieldOcc _ (dL->L ll lbl))) - , hsRecFieldArg = arg - , hsRecPun = pun })) - = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl - ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (mk_arg loc arg_rdr)) } - else return arg - ; return (cL l (HsRecField - { hsRecFieldLbl = (cL loc (FieldOcc - sel (cL ll lbl))) - , hsRecFieldArg = arg' - , hsRecPun = pun })) } - rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) - = panic "rnHsRecFields" - rn_fld _ _ _ = panic "rn_fld: Impossible Match" - -- due to #15884 - - - rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat - -> Maybe Name -- The constructor (Nothing for an - -- out of scope constructor) - -> [LHsRecField GhcRn arg] -- Explicit fields - -> RnM ([LHsRecField GhcRn arg]) -- Field Labels we need to fill in - rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match - | not (isUnboundName con) -- This test is because if the constructor - -- isn't in scope the constructor lookup will add - -- an error but still return an unbound name. We - -- don't want that to screw up the dot-dot fill-in stuff. - = ASSERT( flds `lengthIs` n ) - do { dd_flag <- xoptM LangExt.RecordWildCards - ; checkErr dd_flag (needFlagDotDot ctxt) - ; (rdr_env, lcl_env) <- getRdrEnvs - ; con_fields <- lookupConstructorFields con - ; when (null con_fields) (addErr (badDotDotCon con)) - ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds) - - -- For constructor uses (but not patterns) - -- the arg should be in scope locally; - -- i.e. not top level or imported - -- Eg. data R = R { x,y :: Int } - -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} - arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env - - (dot_dot_fields, dot_dot_gres) - = unzip [ (fl, gre) - | fl <- con_fields - , let lbl = mkVarOccFS (flLabel fl) - , not (lbl `elemOccSet` present_flds) - , Just gre <- [lookupGRE_FieldLabel rdr_env fl] - -- Check selector is in scope - , case ctxt of - HsRecFieldCon {} -> arg_in_scope lbl - _other -> True ] - - ; addUsedGREs dot_dot_gres - ; return [ cL loc (HsRecField - { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr)) - , hsRecFieldArg = cL loc (mk_arg loc arg_rdr) - , hsRecPun = False }) - | fl <- dot_dot_fields - , let sel = flSelector fl - , let arg_rdr = mkVarUnqual (flLabel fl) ] } - - rn_dotdot _dotdot _mb_con _flds - = return [] - -- _dotdot = Nothing => No ".." at all - -- _mb_con = Nothing => Record update - -- _mb_con = Just unbound => Out of scope data constructor - - dup_flds :: [NE.NonEmpty RdrName] - -- Each list represents a RdrName that occurred more than once - -- (the list contains all occurrences) - -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldLbls flds) - - --- NB: Consider this: --- module Foo where { data R = R { fld :: Int } } --- module Odd where { import Foo; fld x = x { fld = 3 } } --- Arguably this should work, because the reference to 'fld' is --- unambiguous because there is only one field id 'fld' in scope. --- But currently it's rejected. - -rnHsRecUpdFields - :: [LHsRecUpdField GhcPs] - -> RnM ([LHsRecUpdField GhcRn], FreeVars) -rnHsRecUpdFields flds - = do { pun_ok <- xoptM LangExt.RecordPuns - ; overload_ok <- xoptM LangExt.DuplicateRecordFields - ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds - ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds - - -- Check for an empty record update e {} - -- NB: don't complain about e { .. }, because rn_dotdot has done that already - ; when (null flds) $ addErr emptyUpdateErr - - ; return (flds1, plusFVs fvss) } - where - doc = text "constructor field name" - - rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs - -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f - , hsRecFieldArg = arg - , hsRecPun = pun })) - = do { let lbl = rdrNameAmbiguousFieldOcc f - ; sel <- setSrcSpan loc $ - -- Defer renaming of overloaded fields to the typechecker - -- See Note [Disambiguating record fields] in TcExpr - if overload_ok - then do { mb <- lookupGlobalOccRn_overloaded - overload_ok lbl - ; case mb of - Nothing -> - do { addErr - (unknownSubordinateErr doc lbl) - ; return (Right []) } - Just r -> return r } - else fmap Left $ lookupGlobalOccRn lbl - ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) } - else return arg - ; (arg'', fvs) <- rnLExpr arg' - - ; let fvs' = case sel of - Left sel_name -> fvs `addOneFV` sel_name - Right [sel_name] -> fvs `addOneFV` sel_name - Right _ -> fvs - lbl' = case sel of - Left sel_name -> - cL loc (Unambiguous sel_name (cL loc lbl)) - Right [sel_name] -> - cL loc (Unambiguous sel_name (cL loc lbl)) - Right _ -> cL loc (Ambiguous noExtField (cL loc lbl)) - - ; return (cL l (HsRecField { hsRecFieldLbl = lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } - - dup_flds :: [NE.NonEmpty RdrName] - -- Each list represents a RdrName that occurred more than once - -- (the list contains all occurrences) - -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldUpdLbls flds) - - - -getFieldIds :: [LHsRecField GhcRn arg] -> [Name] -getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds - -getFieldLbls :: [LHsRecField id arg] -> [RdrName] -getFieldLbls flds - = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds - -getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] -getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds - -needFlagDotDot :: HsRecFieldContext -> SDoc -needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, - text "Use RecordWildCards to permit this"] - -badDotDotCon :: Name -> SDoc -badDotDotCon con - = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) - , nest 2 (text "The constructor has no labelled fields") ] - -emptyUpdateErr :: SDoc -emptyUpdateErr = text "Empty record update" - -badPun :: Located RdrName -> SDoc -badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld), - text "Use NamedFieldPuns to permit this"] - -dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc -dupFieldErr ctxt dups - = hsep [text "duplicate field name", - quotes (ppr (NE.head dups)), - text "in record", pprRFC ctxt] - -pprRFC :: HsRecFieldContext -> SDoc -pprRFC (HsRecFieldCon {}) = text "construction" -pprRFC (HsRecFieldPat {}) = text "pattern" -pprRFC (HsRecFieldUpd {}) = text "update" - -{- -************************************************************************ -* * -\subsubsection{Literals} -* * -************************************************************************ - -When literals occur we have to make sure -that the types and classes they involve -are made available. --} - -rnLit :: HsLit p -> RnM () -rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) -rnLit _ = return () - --- Turn a Fractional-looking literal which happens to be an integer into an --- Integer-looking literal. -generalizeOverLitVal :: OverLitVal -> OverLitVal -generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val})) - | denominator val == 1 = HsIntegral (IL { il_text=src - , il_neg=neg - , il_value=numerator val}) -generalizeOverLitVal lit = lit - -isNegativeZeroOverLit :: HsOverLit t -> Bool -isNegativeZeroOverLit lit - = case ol_val lit of - HsIntegral i -> 0 == il_value i && il_neg i - HsFractional f -> 0 == fl_value f && fl_neg f - _ -> False - -{- -Note [Negative zero] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There were problems with negative zero in conjunction with Negative Literals -extension. Numeric literal value is contained in Integer and Rational types -inside IntegralLit and FractionalLit. These types cannot represent negative -zero value. So we had to add explicit field 'neg' which would hold information -about literal sign. Here in rnOverLit we use it to detect negative zeroes and -in this case return not only literal itself but also negateName so that users -can apply it explicitly. In this case it stays negative zero. #13211 --} - -rnOverLit :: HsOverLit t -> - RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) -rnOverLit origLit - = do { opt_NumDecimals <- xoptM LangExt.NumDecimals - ; let { lit@(OverLit {ol_val=val}) - | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)} - | otherwise = origLit - } - ; let std_name = hsOverLitName val - ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) - <- lookupSyntaxName std_name - ; let rebindable = case from_thing_name of - HsVar _ lv -> (unLoc lv) /= std_name - _ -> panic "rnOverLit" - ; let lit' = lit { ol_witness = from_thing_name - , ol_ext = rebindable } - ; if isNegativeZeroOverLit lit' - then do { (SyntaxExpr { syn_expr = negate_name }, fvs2) - <- lookupSyntaxName negateName - ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name) - , fvs1 `plusFV` fvs2) } - else return ((lit', Nothing), fvs1) } - -{- -************************************************************************ -* * -\subsubsection{Errors} -* * -************************************************************************ --} - -patSigErr :: Outputable a => a -> SDoc -patSigErr ty - = (text "Illegal signature in pattern:" <+> ppr ty) - $$ nest 4 (text "Use ScopedTypeVariables to permit it") - -bogusCharError :: Char -> SDoc -bogusCharError c - = text "character literal out of range: '\\" <> char c <> char '\'' - -badViewPat :: Pat GhcPs -> SDoc -badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, - text "Use ViewPatterns to enable view patterns"] diff --git a/rename/RnSource.hs b/rename/RnSource.hs deleted file mode 100644 --- a/rename/RnSource.hs +++ /dev/null @@ -1,2419 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnSource]{Main pass of renamer} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module RnSource ( - rnSrcDecls, addTcgDUs, findSplice - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} RnExpr( rnLExpr ) -import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) - -import GHC.Hs -import FieldLabel -import RdrName -import RnTypes -import RnBinds -import RnEnv -import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames - , checkDupRdrNames, inHsDocContext, bindLocalNamesFV - , checkShadowedRdrNames, warnUnusedTypePatterns - , extendTyVarEnvFVRn, newLocalBndrsRn - , withHsDocContext ) -import RnUnbound ( mkUnboundName, notInScopeErr ) -import RnNames -import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) -import TcAnnotations ( annCtxt ) -import TcRnMonad - -import ForeignCall ( CCallTarget(..) ) -import Module -import HscTypes ( Warnings(..), plusWarns ) -import PrelNames ( applicativeClassName, pureAName, thenAName - , monadClassName, returnMName, thenMName - , semigroupClassName, sappendName - , monoidClassName, mappendName - ) -import Name -import NameSet -import NameEnv -import Avail -import Outputable -import Bag -import BasicTypes ( pprRuleName, TypeOrKind(..) ) -import FastString -import SrcLoc -import DynFlags -import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith ) -import HscTypes ( HscEnv, hsc_dflags ) -import ListSetOps ( findDupsEq, removeDups, equivClasses ) -import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) - , stronglyConnCompFromEdgedVerticesUniq ) -import UniqSet -import OrdList -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Control.Arrow ( first ) -import Data.List ( mapAccumL ) -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) -import qualified Data.Set as Set ( difference, fromList, toList, null ) -import Data.Function ( on ) - -{- | @rnSourceDecl@ "renames" declarations. -It simultaneously performs dependency analysis and precedence parsing. -It also does the following error checks: - -* Checks that tyvars are used properly. This includes checking - for undefined tyvars, and tyvars in contexts that are ambiguous. - (Some of this checking has now been moved to module @TcMonoType@, - since we don't have functional dependency information at this point.) - -* Checks that all variable occurrences are defined. - -* Checks the @(..)@ etc constraints in the export list. - -Brings the binders of the group into scope in the appropriate places; -does NOT assume that anything is in scope already --} -rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) --- Rename a top-level HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls group@(HsGroup { hs_valds = val_decls, - hs_splcds = splice_decls, - hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = warn_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_docs = docs }) - = do { - -- (A) Process the fixity declarations, creating a mapping from - -- FastStrings to FixItems. - -- Also checks for duplicates. - local_fix_env <- makeMiniFixityEnv fix_decls ; - - -- (B) Bring top level binders (and their fixities) into scope, - -- *except* for the value bindings, which get done in step (D) - -- with collectHsIdBinders. However *do* include - -- - -- * Class ops, data constructors, and record fields, - -- because they do not have value declarations. - -- - -- * For hs-boot files, include the value signatures - -- Again, they have no value declarations - -- - (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; - - - setEnvs tc_envs $ do { - - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations - - -- (D1) Bring pattern synonyms into scope. - -- Need to do this before (D2) because rnTopBindsLHS - -- looks up those pattern synonyms (#9889) - - extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { - - -- (D2) Rename the left-hand sides of the value bindings. - -- This depends on everything from (B) being in scope. - -- It uses the fixity env from (A) to bind fixities for view patterns. - new_lhs <- rnTopBindsLHS local_fix_env val_decls ; - - -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders - -- They are already in scope - traceRn "rnSrcDecls" (ppr id_bndrs) ; - tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; - setEnvs tc_envs $ do { - - -- Now everything is in scope, as the remaining renaming assumes. - - -- (E) Rename type and class decls - -- (note that value LHSes need to be in scope for default methods) - -- - -- You might think that we could build proper def/use information - -- for type and class declarations, but they can be involved - -- in mutual recursion across modules, and we only do the SCC - -- analysis for them in the type checker. - -- So we content ourselves with gathering uses only; that - -- means we'll only report a declaration as unused if it isn't - -- mentioned at all. Ah well. - traceRn "Start rnTyClDecls" (ppr tycl_decls) ; - (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; - - -- (F) Rename Value declarations right-hand sides - traceRn "Start rnmono" empty ; - let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; - is_boot <- tcIsHsBootOrSig ; - (rn_val_decls, bind_dus) <- if is_boot - -- For an hs-boot, use tc_bndrs (which collects how we're renamed - -- signatures), since val_bndr_set is empty (there are no x = ... - -- bindings in an hs-boot.) - then rnTopBindsBoot tc_bndrs new_lhs - else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; - traceRn "finish rnmono" (ppr rn_val_decls) ; - - -- (G) Rename Fixity and deprecations - - -- Rename fixity declarations and error if we try to - -- fix something from another module (duplicates were checked in (A)) - let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; - rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) - fix_decls ; - - -- Rename deprec decls; - -- check for duplicates and ensure that deprecated things are defined locally - -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; - - -- (H) Rename Everything else - - (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ - rnList rnHsRuleDecls rule_decls ; - -- Inside RULES, scoped type variables are on - (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; - (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; - (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; - (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; - -- Haddock docs; no free vars - rn_docs <- mapM (wrapLocM rnDocDecl) docs ; - - last_tcg_env <- getGblEnv ; - -- (I) Compute the results and return - let {rn_group = HsGroup { hs_ext = noExtField, - hs_valds = rn_val_decls, - hs_splcds = rn_splice_decls, - hs_tyclds = rn_tycl_decls, - hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_warnds = [], -- warns are returned in the tcg_env - -- (see below) not in the HsGroup - hs_fords = rn_foreign_decls, - hs_annds = rn_ann_decls, - hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_docs = rn_docs } ; - - tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; - other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] ; - -- It is tiresome to gather the binders from type and class decls - - src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; - -- Instance decls may have occurrences of things bound in bind_dus - -- so we must put other_fvs last - - final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) - in -- we return the deprecs in the env, not in the HsGroup above - tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; - } ; - traceRn "finish rnSrc" (ppr rn_group) ; - traceRn "finish Dus" (ppr src_dus ) ; - return (final_tcg_env, rn_group) - }}}} -rnSrcDecls (XHsGroup nec) = noExtCon nec - -addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv --- This function could be defined lower down in the module hierarchy, --- but there doesn't seem anywhere very logical to put it. -addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } - -rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) -rnList f xs = mapFvRn (wrapLocFstM f) xs - -{- -********************************************************* -* * - HsDoc stuff -* * -********************************************************* --} - -rnDocDecl :: DocDecl -> RnM DocDecl -rnDocDecl (DocCommentNext doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentNext rn_doc) -rnDocDecl (DocCommentPrev doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentPrev rn_doc) -rnDocDecl (DocCommentNamed str doc) = do - rn_doc <- rnHsDoc doc - return (DocCommentNamed str rn_doc) -rnDocDecl (DocGroup lev doc) = do - rn_doc <- rnHsDoc doc - return (DocGroup lev rn_doc) - -{- -********************************************************* -* * - Source-code deprecations declarations -* * -********************************************************* - -Check that the deprecated names are defined, are defined locally, and -that there are no duplicate deprecations. - -It's only imported deprecations, dealt with in RnIfaces, that we -gather them together. --} - --- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings -rnSrcWarnDecls _ [] - = return NoWarnings - -rnSrcWarnDecls bndr_set decls' - = do { -- check for duplicates - ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups - in addErrAt loc (dupWarnDecl lrdr' rdr)) - warn_rdr_dups - ; pairs_s <- mapM (addLocM rn_deprec) decls - ; return (WarnSome ((concat pairs_s))) } - where - decls = concatMap (wd_warnings . unLoc) decls' - - sig_ctxt = TopSigCtxt bndr_set - - rn_deprec (Warning _ rdr_names txt) - -- ensures that the names are defined locally - = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) - rdr_names - ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } - rn_deprec (XWarnDecl nec) = noExtCon nec - - what = text "deprecation" - - warn_rdr_dups = findDupRdrNames - $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls - -findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] -findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) - --- look for duplicates among the OccNames; --- we check that the names are defined above --- invt: the lists returned by findDupsEq always have at least two elements - -dupWarnDecl :: Located RdrName -> RdrName -> SDoc --- Located RdrName -> DeprecDecl RdrName -> SDoc -dupWarnDecl d rdr_name - = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr (getLoc d)] - -{- -********************************************************* -* * -\subsection{Annotation declarations} -* * -********************************************************* --} - -rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) -rnAnnDecl ann@(HsAnnotation _ s provenance expr) - = addErrCtxt (annCtxt ann) $ - do { (provenance', provenance_fvs) <- rnAnnProvenance provenance - ; (expr', expr_fvs) <- setStage (Splice Untyped) $ - rnLExpr expr - ; return (HsAnnotation noExtField s provenance' expr', - provenance_fvs `plusFV` expr_fvs) } -rnAnnDecl (XAnnDecl nec) = noExtCon nec - -rnAnnProvenance :: AnnProvenance RdrName - -> RnM (AnnProvenance Name, FreeVars) -rnAnnProvenance provenance = do - provenance' <- traverse lookupTopBndrRn provenance - return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) - -{- -********************************************************* -* * -\subsection{Default declarations} -* * -********************************************************* --} - -rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) -rnDefaultDecl (DefaultDecl _ tys) - = do { (tys', fvs) <- rnLHsTypes doc_str tys - ; return (DefaultDecl noExtField tys', fvs) } - where - doc_str = DefaultDeclCtx -rnDefaultDecl (XDefaultDecl nec) = noExtCon nec - -{- -********************************************************* -* * -\subsection{Foreign declarations} -* * -********************************************************* --} - -rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) -rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) - = do { topEnv :: HscEnv <- getTopEnv - ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty - - -- Mark any PackageTarget style imports as coming from the current package - ; let unitId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport unitId spec - - ; return (ForeignImport { fd_i_ext = noExtField - , fd_name = name', fd_sig_ty = ty' - , fd_fi = spec' }, fvs) } - -rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) - = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty - ; return (ForeignExport { fd_e_ext = noExtField - , fd_name = name', fd_sig_ty = ty' - , fd_fe = spec } - , fvs `addOneFV` unLoc name') } - -- NB: a foreign export is an *occurrence site* for name, so - -- we add it to the free-variable list. It might, for example, - -- be imported from another module - -rnHsForeignDecl (XForeignDecl nec) = noExtCon nec - --- | For Windows DLLs we need to know what packages imported symbols are from --- to generate correct calls. Imported symbols are tagged with the current --- package, so if they get inlined across a package boundary we'll still --- know where they're from. --- -patchForeignImport :: UnitId -> ForeignImport -> ForeignImport -patchForeignImport unitId (CImport cconv safety fs spec src) - = CImport cconv safety fs (patchCImportSpec unitId spec) src - -patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec -patchCImportSpec unitId spec - = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget - _ -> spec - -patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget -patchCCallTarget unitId callTarget = - case callTarget of - StaticTarget src label Nothing isFun - -> StaticTarget src label (Just unitId) isFun - _ -> callTarget - -{- -********************************************************* -* * -\subsection{Instance declarations} -* * -********************************************************* --} - -rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) -rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) - = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi - ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } - -rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) - = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi - ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } - -rnSrcInstDecl (ClsInstD { cid_inst = cid }) - = do { traceRn "rnSrcIstDecl {" (ppr cid) - ; (cid', fvs) <- rnClsInstDecl cid - ; traceRn "rnSrcIstDecl end }" empty - ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } - -rnSrcInstDecl (XInstDecl nec) = noExtCon nec - --- | Warn about non-canonical typeclass instance declarations --- --- A "non-canonical" instance definition can occur for instances of a --- class which redundantly defines an operation its superclass --- provides as well (c.f. `return`/`pure`). In such cases, a canonical --- instance is one where the subclass inherits its method --- implementation from its superclass instance (usually the subclass --- has a default method implementation to that effect). Consequently, --- a non-canonical instance occurs when this is not the case. --- --- See also descriptions of 'checkCanonicalMonadInstances' and --- 'checkCanonicalMonoidInstances' -checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () -checkCanonicalInstances cls poly_ty mbinds = do - whenWOptM Opt_WarnNonCanonicalMonadInstances - checkCanonicalMonadInstances - - whenWOptM Opt_WarnNonCanonicalMonoidInstances - checkCanonicalMonoidInstances - - where - -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance - -- declarations. Specifically, the following conditions are verified: - -- - -- In 'Monad' instances declarations: - -- - -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) - -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) - -- - -- In 'Applicative' instance declarations: - -- - -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). - -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). - -- - checkCanonicalMonadInstances - | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = (dL->L _ name) - , fun_matches = mg } - | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonadInstances "pure" "return" - - | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" - - _ -> return () - - | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = (dL->L _ name) - , fun_matches = mg } - | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 - Opt_WarnNonCanonicalMonadInstances "return" "pure" - - | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 - Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" - - _ -> return () - - | otherwise = return () - - -- | Check whether Monoid(mappend) is defined in terms of - -- Semigroup((<>)) (and not the other way round). Specifically, - -- the following conditions are verified: - -- - -- In 'Monoid' instances declarations: - -- - -- * If 'mappend' is overridden it must be canonical - -- (i.e. @mappend = (<>)@) - -- - -- In 'Semigroup' instance declarations: - -- - -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). - -- - checkCanonicalMonoidInstances - | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = (dL->L _ name) - , fun_matches = mg } - | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 - Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" - - _ -> return () - - | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do - case mbind of - FunBind { fun_id = (dL->L _ name) - , fun_matches = mg } - | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2NoDefault - Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" - - _ -> return () - - | otherwise = return () - - -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" - -- binding, and return @Just rhsName@ if this is the case - isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name - isAliasMG MG {mg_alts = (dL->L _ - [dL->L _ (Match { m_pats = [] - , m_grhss = grhss })])} - | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss - , EmptyLocalBinds _ <- unLoc lbinds - , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) - isAliasMG _ = Nothing - - -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Move definition from" <+> - quotes (text rhs) <+> - text "to" <+> quotes (text lhs) - ] - - -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - ] - - -- like above, but method has no default impl - addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do - addWarn (Reason flag) $ vcat - [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - ] - - -- stolen from TcInstDcls - instDeclCtxt1 :: LHsSigType GhcRn -> SDoc - instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - - inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (text "in the instance declaration for") - 2 (quotes doc <> text ".") - - -rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) -rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds - , cid_sigs = uprags, cid_tyfam_insts = ats - , cid_overlap_mode = oflag - , cid_datafam_insts = adts }) - = do { (inst_ty', inst_fvs) - <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty - ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' - ; cls <- - case hsTyGetAppHead_maybe head_ty' of - Just (dL->L _ cls) -> pure cls - Nothing -> do - -- The instance is malformed. We'd still like - -- to make *some* progress (rather than failing outright), so - -- we report an error and continue for as long as we can. - -- Importantly, this error should be thrown before we reach the - -- typechecker, lest we encounter different errors that are - -- hopelessly confusing (such as the one in #16114). - addErrAt (getLoc (hsSigType inst_ty)) $ - hang (text "Illegal class instance:" <+> quotes (ppr inst_ty)) - 2 (vcat [ text "Class instances must be of the form" - , nest 2 $ text "context => C ty_1 ... ty_n" - , text "where" <+> quotes (char 'C') - <+> text "is a class" - ]) - pure $ mkUnboundName (mkTcOccFS (fsLit "")) - - -- Rename the bindings - -- The typechecker (not the renamer) checks that all - -- the bindings are for the right class - -- (Slightly strangely) when scoped type variables are on, the - -- forall-d tyvars scope over the method bindings too - ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags - - ; checkCanonicalInstances cls inst_ty' mbinds' - - -- Rename the associated types, and type signatures - -- Both need to have the instance type variables in scope - ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) - ; ((ats', adts'), more_fvs) - <- extendTyVarEnvFVRn ktv_names $ - do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats - ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts - ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } - - ; let all_fvs = meth_fvs `plusFV` more_fvs - `plusFV` inst_fvs - ; return (ClsInstDecl { cid_ext = noExtField - , cid_poly_ty = inst_ty', cid_binds = mbinds' - , cid_sigs = uprags', cid_tyfam_insts = ats' - , cid_overlap_mode = oflag - , cid_datafam_insts = adts' }, - all_fvs) } - -- We return the renamed associated data type declarations so - -- that they can be entered into the list of type declarations - -- for the binding group, but we also keep a copy in the instance. - -- The latter is needed for well-formedness checks in the type - -- checker (eg, to ensure that all ATs of the instance actually - -- receive a declaration). - -- NB: Even the copies in the instance declaration carry copies of - -- the instance context after renaming. This is a bit - -- strange, but should not matter (and it would be more work - -- to remove the context). -rnClsInstDecl (XClsInstDecl nec) = noExtCon nec - -rnFamInstEqn :: HsDocContext - -> AssocTyFamInfo - -> [Located RdrName] -- Kind variables from the equation's RHS - -> FamInstEqn GhcPs rhs - -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (FamInstEqn GhcRn rhs', FreeVars) -rnFamInstEqn doc atfi rhs_kvars - (HsIB { hsib_body = FamEqn { feqn_tycon = tycon - , feqn_bndrs = mb_bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = payload }}) rn_payload - = do { let mb_cls = case atfi of - NonAssocTyFamEqn -> Nothing - AssocTyFamDeflt cls -> Just cls - AssocTyFamInst cls _ -> Just cls - ; tycon' <- lookupFamInstName mb_cls tycon - ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats - -- Use the "...Dups" form because it's needed - -- below to report unsed binder on the LHS - - -- Implicitly bound variables, empty if we have an explicit 'forall' according - -- to the "forall-or-nothing" rule. - ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups - | otherwise = [] - ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars - - ; let bndrs = fromMaybe [] mb_bndrs - bnd_vars = map hsLTyVarLocName bndrs - payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars - -- Make sure to filter out the kind variables that were explicitly - -- bound in the type patterns. - ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars - - -- all names not bound in an explict forall - ; let all_imp_var_names = imp_var_names ++ payload_kvar_names - - -- All the free vars of the family patterns - -- with a sensible binding location - ; ((bndrs', pats', payload'), fvs) - <- bindLocalNamesFV all_imp_var_names $ - bindLHsTyVarBndrs doc (Just $ inHsDocContext doc) - Nothing bndrs $ \bndrs' -> - -- Note: If we pass mb_cls instead of Nothing here, - -- bindLHsTyVarBndrs will use class variables for any names - -- the user meant to bring in scope here. This is an explicit - -- forall, so we want fresh names, not class variables. - -- Thus: always pass Nothing - do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats - ; (payload', rhs_fvs) <- rn_payload doc payload - - -- Report unused binders on the LHS - -- See Note [Unused type variables in family instances] - ; let groups :: [NonEmpty (Located RdrName)] - groups = equivClasses cmpLocated $ - pat_kity_vars_with_dups - ; nms_dups <- mapM (lookupOccRn . unLoc) $ - [ tv | (tv :| (_:_)) <- groups ] - -- Add to the used variables - -- a) any variables that appear *more than once* on the LHS - -- e.g. F a Int a = Bool - -- b) for associated instances, the variables - -- of the instance decl. See - -- Note [Unused type variables in family instances] - ; let nms_used = extendNameSetList rhs_fvs $ - inst_tvs ++ nms_dups - inst_tvs = case atfi of - NonAssocTyFamEqn -> [] - AssocTyFamDeflt _ -> [] - AssocTyFamInst _ inst_tvs -> inst_tvs - all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' - ; warnUnusedTypePatterns all_nms nms_used - - ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) } - - ; let all_fvs = fvs `addOneFV` unLoc tycon' - -- type instance => use, hence addOneFV - - ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] - , hsib_body - = FamEqn { feqn_ext = noExtField - , feqn_tycon = tycon' - , feqn_bndrs = bndrs' <$ mb_bndrs - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = payload' } }, - all_fvs) } -rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec -rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec - -rnTyFamInstDecl :: AssocTyFamInfo - -> TyFamInstDecl GhcPs - -> RnM (TyFamInstDecl GhcRn, FreeVars) -rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn }) - = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } - --- | Tracks whether we are renaming: --- --- 1. A type family equation that is not associated --- with a parent type class ('NonAssocTyFamEqn') --- --- 2. An associated type family default delcaration ('AssocTyFamDeflt') --- --- 3. An associated type family instance declaration ('AssocTyFamInst') -data AssocTyFamInfo - = NonAssocTyFamEqn - | AssocTyFamDeflt Name -- Name of the parent class - | AssocTyFamInst Name -- Name of the parent class - [Name] -- Names of the tyvars of the parent instance decl - --- | Tracks whether we are renaming an equation in a closed type family --- equation ('ClosedTyFam') or not ('NotClosedTyFam'). -data ClosedTyFamInfo - = NotClosedTyFam - | ClosedTyFam (Located RdrName) Name - -- The names (RdrName and Name) of the closed type family - -rnTyFamInstEqn :: AssocTyFamInfo - -> ClosedTyFamInfo - -> TyFamInstEqn GhcPs - -> RnM (TyFamInstEqn GhcRn, FreeVars) -rnTyFamInstEqn atfi ctf_info - eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon - , feqn_rhs = rhs }}) - = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs - ; (eqn'@(HsIB { hsib_body = - FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs) - <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn - ; case ctf_info of - NotClosedTyFam -> pure () - ClosedTyFam fam_rdr_name fam_name -> - checkTc (fam_name == tycon') $ - withHsDocContext (TyFamilyCtx fam_rdr_name) $ - wrongTyFamName fam_name tycon' - ; pure (eqn', fvs) } -rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec -rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec - -rnTyFamDefltDecl :: Name - -> TyFamDefltDecl GhcPs - -> RnM (TyFamDefltDecl GhcRn, FreeVars) -rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) - -rnDataFamInstDecl :: AssocTyFamInfo - -> DataFamInstDecl GhcPs - -> RnM (DataFamInstDecl GhcRn, FreeVars) -rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = - FamEqn { feqn_tycon = tycon - , feqn_rhs = rhs }})}) - = do { let rhs_kvs = extractDataDefnKindVars rhs - ; (eqn', fvs) <- - rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn - ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } -rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec))) - = noExtCon nec -rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec - --- Renaming of the associated types in instances. - --- Rename associated type family decl in class -rnATDecls :: Name -- Class - -> [LFamilyDecl GhcPs] - -> RnM ([LFamilyDecl GhcRn], FreeVars) -rnATDecls cls at_decls - = rnList (rnFamDecl (Just cls)) at_decls - -rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames - decl GhcPs -> -- an instance. rnTyFamInstDecl - RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl - -> Name -- Class - -> [Name] - -> [Located (decl GhcPs)] - -> RnM ([Located (decl GhcRn)], FreeVars) --- Used for data and type family defaults in a class decl --- and the family instance declarations in an instance --- --- NB: We allow duplicate associated-type decls; --- See Note [Associated type instances] in TcInstDcls -rnATInstDecls rnFun cls tv_ns at_insts - = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts - -- See Note [Renaming associated types] - -{- Note [Wildcards in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wild cards can be used in type/data family instance declarations to indicate -that the name of a type variable doesn't matter. Each wild card will be -replaced with a new unique type variable. For instance: - - type family F a b :: * - type instance F Int _ = Int - -is the same as - - type family F a b :: * - type instance F Int b = Int - -This is implemented as follows: Unnamed wildcards remain unchanged after -the renamer, and then given fresh meta-variables during typechecking, and -it is handled pretty much the same way as the ones in partial type signatures. -We however don't want to emit hole constraints on wildcards in family -instances, so we turn on PartialTypeSignatures and turn off warning flag to -let typechecker know this. -See related Note [Wildcards in visible kind application] in TcHsType.hs - -Note [Unused type variables in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the flag -fwarn-unused-type-patterns is on, the compiler reports -warnings about unused type variables in type-family instances. A -tpye variable is considered used (i.e. cannot be turned into a wildcard) -when - - * it occurs on the RHS of the family instance - e.g. type instance F a b = a -- a is used on the RHS - - * it occurs multiple times in the patterns on the LHS - e.g. type instance F a a = Int -- a appears more than once on LHS - - * it is one of the instance-decl variables, for associated types - e.g. instance C (a,b) where - type T (a,b) = a - Here the type pattern in the type instance must be the same as that - for the class instance, so - type T (a,_) = a - would be rejected. So we should not complain about an unused variable b - -As usual, the warnings are not reported for type variables with names -beginning with an underscore. - -Extra-constraints wild cards are not supported in type/data family -instance declarations. - -Relevant tickets: #3699, #10586, #10982 and #11451. - -Note [Renaming associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check that the RHS of the decl mentions only type variables that are explicitly -bound on the LHS. For example, this is not ok - class C a b where - type F a x :: * - instance C (p,q) r where - type F (p,q) x = (x, r) -- BAD: mentions 'r' -c.f. #5515 - -Kind variables, on the other hand, are allowed to be implicitly or explicitly -bound. As examples, this (#9574) is acceptable: - class Funct f where - type Codomain f :: * - instance Funct ('KProxy :: KProxy o) where - -- o is implicitly bound by the kind signature - -- of the LHS type pattern ('KProxy) - type Codomain 'KProxy = NatTr (Proxy :: o -> *) -And this (#14131) is also acceptable: - data family Nat :: k -> k -> * - -- k is implicitly bound by an invisible kind pattern - newtype instance Nat :: (k -> *) -> (k -> *) -> * where - Nat :: (forall xx. f xx -> g xx) -> Nat f g -We could choose to disallow this, but then associated type families would not -be able to be as expressive as top-level type synonyms. For example, this type -synonym definition is allowed: - type T = (Nothing :: Maybe a) -So for parity with type synonyms, we also allow: - type family T :: Maybe a - type instance T = (Nothing :: Maybe a) - -All this applies only for *instance* declarations. In *class* -declarations there is no RHS to worry about, and the class variables -can all be in scope (#5862): - class Category (x :: k -> k -> *) where - type Ob x :: k -> Constraint - id :: Ob x a => x a a - (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c -Here 'k' is in scope in the kind signature, just like 'x'. - -Although type family equations can bind type variables with explicit foralls, -it need not be the case that all variables that appear on the RHS must be bound -by a forall. For instance, the following is acceptable: - - class C a where - type T a b - instance C (Maybe a) where - type forall b. T (Maybe a) b = Either a b - -Even though `a` is not bound by the forall, this is still accepted because `a` -was previously bound by the `instance C (Maybe a)` part. (see #16116). - -In each case, the function which detects improperly bound variables on the RHS -is TcValidity.checkValidFamPats. --} - - -{- -********************************************************* -* * -\subsection{Stand-alone deriving declarations} -* * -********************************************************* --} - -rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) -rnSrcDerivDecl (DerivDecl _ ty mds overlap) - = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving - ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; (mds', ty', fvs) - <- rnLDerivStrategy DerivDeclCtx mds $ - rnHsSigWcType BindUnlessForall DerivDeclCtx ty - ; warnNoDerivStrat mds' loc - ; return (DerivDecl noExtField ty' mds' overlap, fvs) } - where - loc = getLoc $ hsib_body $ hswc_body ty -rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec - -standaloneDerivErr :: SDoc -standaloneDerivErr - = hang (text "Illegal standalone deriving declaration") - 2 (text "Use StandaloneDeriving to enable this extension") - -{- -********************************************************* -* * -\subsection{Rules} -* * -********************************************************* --} - -rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) -rnHsRuleDecls (HsRules { rds_src = src - , rds_rules = rules }) - = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules - ; return (HsRules { rds_ext = noExtField - , rds_src = src - , rds_rules = rn_rules }, fvs) } -rnHsRuleDecls (XRuleDecls nec) = noExtCon nec - -rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) -rnHsRuleDecl (HsRule { rd_name = rule_name - , rd_act = act - , rd_tyvs = tyvs - , rd_tmvs = tmvs - , rd_lhs = lhs - , rd_rhs = rhs }) - = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs - ; checkDupRdrNames rdr_names_w_loc - ; checkShadowedRdrNames rdr_names_w_loc - ; names <- newLocalBndrsRn rdr_names_w_loc - ; let doc = RuleCtx (snd $ unLoc rule_name) - ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' -> - bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> - do { (lhs', fv_lhs') <- rnLExpr lhs - ; (rhs', fv_rhs') <- rnLExpr rhs - ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' - ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs' - , rd_name = rule_name - , rd_act = act - , rd_tyvs = tyvs' - , rd_tmvs = tmvs' - , rd_lhs = lhs' - , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } - where - get_var (RuleBndrSig _ v _) = v - get_var (RuleBndr _ v) = v - get_var (XRuleBndr nec) = noExtCon nec - in_rule = text "in the rule" <+> pprFullRuleName rule_name -rnHsRuleDecl (XRuleDecl nec) = noExtCon nec - -bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs - -> [LRuleBndr GhcPs] -> [Name] - -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindRuleTmVars doc tyvs vars names thing_inside - = go vars names $ \ vars' -> - bindLocalNamesFV names (thing_inside vars') - where - go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside - = go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars') - - go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars) - (n : ns) thing_inside - = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> - go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars') - - go [] [] thing_inside = thing_inside [] - go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) - - bind_free_tvs = case tyvs of Nothing -> AlwaysBind - Just _ -> NeverBind - -bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] - -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindRuleTyVars doc in_doc (Just bndrs) thing_inside - = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) -bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing - -{- -Note [Rule LHS validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check the shape of a transformation rule LHS. Currently we only allow -LHSs of the form @(f e1 .. en)@, where @f@ is not one of the -@forall@'d variables. - -We used restrict the form of the 'ei' to prevent you writing rules -with LHSs with a complicated desugaring (and hence unlikely to match); -(e.g. a case expression is not allowed: too elaborate.) - -But there are legitimate non-trivial args ei, like sections and -lambdas. So it seems simmpler not to check at all, and that is why -check_e is commented out. --} - -checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () -checkValidRule rule_name ids lhs' fv_lhs' - = do { -- Check for the form of the LHS - case (validRuleLhs ids lhs') of - Nothing -> return () - Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) - - -- Check that LHS vars are all bound - ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mapM_ (addErr . badRuleVar rule_name) bad_vars } - -validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) --- Nothing => OK --- Just e => Not ok, and e is the offending sub-expression -validRuleLhs foralls lhs - = checkl lhs - where - checkl = check . unLoc - - check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 - `mplus` checkl_e e2 - check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType _ e _) = checkl e - check (HsVar _ lv) - | (unLoc lv) `notElem` foralls = Nothing - check other = Just other -- Failure - - -- Check an argument - checkl_e _ = Nothing - -- Was (check_e e); see Note [Rule LHS validity checking] - -{- Commented out; see Note [Rule LHS validity checking] above - check_e (HsVar v) = Nothing - check_e (HsPar e) = checkl_e e - check_e (HsLit e) = Nothing - check_e (HsOverLit e) = Nothing - - check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 - check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 - check_e (NegApp e _) = checkl_e e - check_e (ExplicitList _ es) = checkl_es es - check_e other = Just other -- Fails - - checkl_es es = foldr (mplus . checkl_e) Nothing es --} - -badRuleVar :: FastString -> Name -> SDoc -badRuleVar name var - = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, - text "Forall'd variable" <+> quotes (ppr var) <+> - text "does not appear on left hand side"] - -badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc -badRuleLhsErr name lhs bad_e - = sep [text "Rule" <+> pprRuleName name <> colon, - nest 2 (vcat [err, - text "in left-hand side:" <+> ppr lhs])] - $$ - text "LHS must be of form (f e1 .. en) where f is not forall'd" - where - err = case bad_e of - HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv)) - _ -> text "Illegal expression:" <+> ppr bad_e - -{- ************************************************************** - * * - Renaming type, class, instance and role declarations -* * -***************************************************************** - -@rnTyDecl@ uses the `global name function' to create a new type -declaration in which local names have been replaced by their original -names, reporting any unknown names. - -Renaming type variables is a pain. Because they now contain uniques, -it is necessary to pass in an association list which maps a parsed -tyvar to its @Name@ representation. -In some cases (type signatures of values), -it is even necessary to go over the type first -in order to get the set of tyvars used by it, make an assoc list, -and then go over it again to rename the tyvars! -However, we can also do some scoping checks at the same time. - -Note [Dependency analysis of type, class, and instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyClGroup represents a strongly connected components of -type/class/instance decls, together with the role annotations for the -type/class declarations. The renamer uses strongly connected -comoponent analysis to build these groups. We do this for a number of -reasons: - -* Improve kind error messages. Consider - - data T f a = MkT f a - data S f a = MkS f (T f a) - - This has a kind error, but the error message is better if you - check T first, (fixing its kind) and *then* S. If you do kind - inference together, you might get an error reported in S, which - is jolly confusing. See #4875 - - -* Increase kind polymorphism. See TcTyClsDecls - Note [Grouping of type and class declarations] - -Why do the instance declarations participate? At least two reasons - -* Consider (#11348) - - type family F a - type instance F Int = Bool - - data R = MkR (F Int) - - type Foo = 'MkR 'True - - For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't - know that unless we've looked at the type instance declaration for F - before kind-checking Foo. - -* Another example is this (#3990). - - data family Complex a - data instance Complex Double = CD {-# UNPACK #-} !Double - {-# UNPACK #-} !Double - - data T = T {-# UNPACK #-} !(Complex Double) - - Here, to generate the right kind of unpacked implementation for T, - we must have access to the 'data instance' declaration. - -* Things become more complicated when we introduce transitive - dependencies through imported definitions, like in this scenario: - - A.hs - type family Closed (t :: Type) :: Type where - Closed t = Open t - - type family Open (t :: Type) :: Type - - B.hs - data Q where - Q :: Closed Bool -> Q - - type instance Open Int = Bool - - type S = 'Q 'True - - Somehow, we must ensure that the instance Open Int = Bool is checked before - the type synonym S. While we know that S depends upon 'Q depends upon Closed, - we have no idea that Closed depends upon Open! - - To accomodate for these situations, we ensure that an instance is checked - before every @TyClDecl@ on which it does not depend. That's to say, instances - are checked as early as possible in @tcTyAndClassDecls@. - ------------------------------------- -So much for WHY. What about HOW? It's pretty easy: - -(1) Rename the type/class, instance, and role declarations - individually - -(2) Do strongly-connected component analysis of the type/class decls, - We'll make a TyClGroup for each SCC - - In this step we treat a reference to a (promoted) data constructor - K as a dependency on its parent type. Thus - data T = K1 | K2 - data S = MkS (Proxy 'K1) - Here S depends on 'K1 and hence on its parent T. - - In this step we ignore instances; see - Note [No dependencies on data instances] - -(3) Attach roles to the appropriate SCC - -(4) Attach instances to the appropriate SCC. - We add an instance decl to SCC when: - all its free types/classes are bound in this SCC or earlier ones - -(5) We make an initial TyClGroup, with empty group_tyclds, for any - (orphan) instances that affect only imported types/classes - -Steps (3) and (4) are done by the (mapAccumL mk_group) call. - -Note [No dependencies on data instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family D a - data instance D Int = D1 - data S = MkS (Proxy 'D1) - -Here the declaration of S depends on the /data instance/ declaration -for 'D Int'. That makes things a lot more complicated, especially -if the data instance is an associated type of an enclosing class instance. -(And the class instance might have several associated type instances -with different dependency structure!) - -Ugh. For now we simply don't allow promotion of data constructors for -data instances. See Note [AFamDataCon: not promoting data family -constructors] in TcEnv --} - - -rnTyClDecls :: [TyClGroup GhcPs] - -> RnM ([TyClGroup GhcRn], FreeVars) --- Rename the declarations and do dependency analysis on them -rnTyClDecls tycl_ds - = do { -- Rename the type/class, instance, and role declaraations - ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds) - ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) - ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) - ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) - ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) - - -- Do SCC analysis on the type/class decls - ; rdr_env <- getGlobalRdrEnv - ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs - role_annot_env = mkRoleAnnotEnv role_annots - (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs - - inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs - (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map - - first_group - | null init_inst_ds = [] - | otherwise = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [] - , group_instds = init_inst_ds }] - - (final_inst_ds, groups) - = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs - - all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` - foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` - foldr (plusFV . snd) emptyFVs kisigs_w_fvs - - all_groups = first_group ++ groups - - ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map - $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds ) - - ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) - ; return (all_groups, all_fvs) } - where - mk_group :: RoleAnnotEnv - -> KindSigEnv - -> InstDeclFreeVarsMap - -> SCC (LTyClDecl GhcRn) - -> (InstDeclFreeVarsMap, TyClGroup GhcRn) - mk_group role_env kisig_env inst_map scc - = (inst_map', group) - where - tycl_ds = flattenSCC scc - bndrs = map (tcdName . unLoc) tycl_ds - roles = getRoleAnnots bndrs role_env - kisigs = getKindSigs bndrs kisig_env - (inst_ds, inst_map') = getInsts bndrs inst_map - group = TyClGroup { group_ext = noExtField - , group_tyclds = tycl_ds - , group_kisigs = kisigs - , group_roles = roles - , group_instds = inst_ds } - --- | Free variables of standalone kind signatures. -newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) - -lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars -lookupKindSig_FV_Env (KindSig_FV_Env e) name - = fromMaybe emptyFVs (lookupNameEnv e name) - --- | Standalone kind signatures. -type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) - -mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) -mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) - where - kisig_env = mapNameEnv fst compound_env - kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) - compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) - = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs - -getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] -getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs - -rnStandaloneKindSignatures - :: NameSet -- names of types and classes in the current TyClGroup - -> [LStandaloneKindSig GhcPs] - -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] -rnStandaloneKindSignatures tc_names kisigs - = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs - get_name = standaloneKindSigName . unLoc - ; mapM_ dupKindSig_Err dup_kisigs - ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups - } - -rnStandaloneKindSignature - :: NameSet -- names of types and classes in the current TyClGroup - -> StandaloneKindSig GhcPs - -> RnM (StandaloneKindSig GhcRn, FreeVars) -rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) - = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures - ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr - ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v - ; let doc = StandaloneKindSigCtx (ppr v) - ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki - ; return (StandaloneKindSig noExtField new_v new_ki, fvs) - } - where - standaloneKiSigErr :: SDoc - standaloneKiSigErr = - hang (text "Illegal standalone kind signature") - 2 (text "Did you mean to enable StandaloneKindSignatures?") -rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec - -depAnalTyClDecls :: GlobalRdrEnv - -> KindSig_FV_Env - -> [(LTyClDecl GhcRn, FreeVars)] - -> [SCC (LTyClDecl GhcRn)] --- See Note [Dependency analysis of type, class, and instance decls] -depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs - = stronglyConnCompFromEdgedVerticesUniq edges - where - edges :: [ Node Name (LTyClDecl GhcRn) ] - edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) - | (d, fvs) <- ds_w_fvs, - let { name = tcdName (unLoc d) - ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name - ; deps = fvs `plusFV` kisig_fvs - } - ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic - -- even if the edges are in nondeterministic order as explained - -- in Note [Deterministic SCC] in Digraph. - -toParents :: GlobalRdrEnv -> NameSet -> NameSet -toParents rdr_env ns - = nonDetFoldUniqSet add emptyNameSet ns - -- It's OK to use nonDetFoldUFM because we immediately forget the - -- ordering by creating a set - where - add n s = extendNameSet s (getParent rdr_env n) - -getParent :: GlobalRdrEnv -> Name -> Name -getParent rdr_env n - = case lookupGRE_Name rdr_env n of - Just gre -> case gre_par gre of - ParentIs { par_is = p } -> p - FldParent { par_is = p } -> p - _ -> n - Nothing -> n - - -{- ****************************************************** -* * - Role annotations -* * -****************************************************** -} - --- | Renames role annotations, returning them as the values in a NameEnv --- and checks for duplicate role annotations. --- It is quite convenient to do both of these in the same place. --- See also Note [Role annotations in the renamer] -rnRoleAnnots :: NameSet - -> [LRoleAnnotDecl GhcPs] - -> RnM [LRoleAnnotDecl GhcRn] -rnRoleAnnots tc_names role_annots - = do { -- Check for duplicates *before* renaming, to avoid - -- lumping together all the unboundNames - let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots - get_name = roleAnnotDeclName . unLoc - ; mapM_ dupRoleAnnotErr dup_annots - ; mapM (wrapLocM rn_role_annot1) no_dups } - where - rn_role_annot1 (RoleAnnotDecl _ tycon roles) - = do { -- the name is an *occurrence*, but look it up only in the - -- decls defined in this group (see #10263) - tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) - (text "role annotation") - tycon - ; return $ RoleAnnotDecl noExtField tycon' roles } - rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec - -dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () -dupRoleAnnotErr list - = addErrAt loc $ - hang (text "Duplicate role annotations for" <+> - quotes (ppr $ roleAnnotDeclName first_decl) <> colon) - 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_annot list - ((dL->L loc first_decl) :| _) = sorted_list - - pp_role_annot (dL->L loc decl) = hang (ppr decl) - 4 (text "-- written at" <+> ppr loc) - - cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 - -dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () -dupKindSig_Err list - = addErrAt loc $ - hang (text "Duplicate standalone kind signatures for" <+> - quotes (ppr $ standaloneKindSigName first_decl) <> colon) - 2 (vcat $ map pp_kisig $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_loc list - ((dL->L loc first_decl) :| _) = sorted_list - - pp_kisig (dL->L loc decl) = - hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - - cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 - -{- Note [Role annotations in the renamer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must ensure that a type's role annotation is put in the same group as the -proper type declaration. This is because role annotations are needed during -type-checking when creating the type's TyCon. So, rnRoleAnnots builds a -NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that -type, if any. Then, this map can be used to add the role annotations to the -groups after dependency analysis. - -This process checks for duplicate role annotations, where we must be careful -to do the check *before* renaming to avoid calling all unbound names duplicates -of one another. - -The renaming process, as usual, might identify and report errors for unbound -names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using -lookupGlobalOccRn led to #8485). --} - - -{- ****************************************************** -* * - Dependency info for instances -* * -****************************************************** -} - ----------------------------------------------------------- --- | 'InstDeclFreeVarsMap is an association of an --- @InstDecl@ with @FreeVars@. The @FreeVars@ are --- the tycon names that are both --- a) free in the instance declaration --- b) bound by this group of type/class/instance decls -type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] - --- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the --- @FreeVars@ which are *not* the binders of a @TyClDecl@. -mkInstDeclFreeVarsMap :: GlobalRdrEnv - -> NameSet - -> [(LInstDecl GhcRn, FreeVars)] - -> InstDeclFreeVarsMap -mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs - = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) - | (inst_decl, fvs) <- inst_ds_fvs ] - --- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the --- @InstDeclFreeVarsMap@ with these entries removed. --- We call (getInsts tcs instd_map) when we've completed the declarations --- for 'tcs'. The call returns (inst_decls, instd_map'), where --- inst_decls are the instance declarations all of --- whose free vars are now defined --- instd_map' is the inst-decl map with 'tcs' removed from --- the free-var set -getInsts :: [Name] -> InstDeclFreeVarsMap - -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) -getInsts bndrs inst_decl_map - = partitionWith pick_me inst_decl_map - where - pick_me :: (LInstDecl GhcRn, FreeVars) - -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) - pick_me (decl, fvs) - | isEmptyNameSet depleted_fvs = Left decl - | otherwise = Right (decl, depleted_fvs) - where - depleted_fvs = delFVs bndrs fvs - -{- ****************************************************** -* * - Renaming a type or class declaration -* * -****************************************************** -} - -rnTyClDecl :: TyClDecl GhcPs - -> RnM (TyClDecl GhcRn, FreeVars) - --- All flavours of top-level type family declarations ("type family", "newtype --- family", and "data family") -rnTyClDecl (FamDecl { tcdFam = fam }) - = do { (fam', fvs) <- rnFamDecl Nothing fam - ; return (FamDecl noExtField fam', fvs) } - -rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, tcdRhs = rhs }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = extractHsTyRdrTyVarsKindVars rhs - doc = TySynCtx tycon - ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> - do { (rhs', fvs) <- rnTySyn doc rhs - ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } - --- "data", "newtype" declarations -rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec -rnTyClDecl (DataDecl - { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data - , dd_kindSig = kind_sig} }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = extractDataDefnKindVars defn - doc = TyDataCtx tycon - ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> - do { (defn', fvs) <- rnDataDefn doc defn - ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig - ; let rn_info = DataDeclRn { tcdDataCusk = cusk - , tcdFVs = fvs } - ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) - ; return (DataDecl { tcdLName = tycon' - , tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdDataDefn = defn' - , tcdDExt = rn_info }, fvs) } } - -rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFixity = fixity, - tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = docs}) - = do { lcls' <- lookupLocatedTopBndrRn lcls - ; let cls' = unLoc lcls' - kvs = [] -- No scoped kind vars except those in - -- kind signatures on the tyvars - - -- Tyvars scope over superclass context and method signatures - ; ((tyvars', context', fds', ats'), stuff_fvs) - <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do - -- Checks for distinct tyvars - { (context', cxt_fvs) <- rnContext cls_doc context - ; fds' <- rnFds fds - -- The fundeps have no free variables - ; (ats', fv_ats) <- rnATDecls cls' ats - ; let fvs = cxt_fvs `plusFV` - fv_ats - ; return ((tyvars', context', fds', ats'), fvs) } - - ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs - - -- No need to check for duplicate associated type decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - -- Check the signatures - -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = - [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs - , op <- ops] - ; checkDupRdrNames sig_rdr_names_w_locs - -- Typechecker is responsible for checking that we only - -- give default-method bindings for things in this class. - -- The renamer *could* check this for class decls, but can't - -- for instance decls. - - -- The newLocals call is tiresome: given a generic class decl - -- class C a where - -- op :: a -> a - -- op {| x+y |} (Inl a) = ... - -- op {| x+y |} (Inr b) = ... - -- op {| a*b |} (a*b) = ... - -- we want to name both "x" tyvars with the same unique, so that they are - -- easy to group together in the typechecker. - ; (mbinds', sigs', meth_fvs) - <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs - -- No need to check for duplicate method signatures - -- since that is done by RnNames.extendGlobalRdrEnvRn - -- and the methods are already in scope - - -- Haddock docs - ; docs' <- mapM (wrapLocM rnDocDecl) docs - - ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs - ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', - tcdTyVars = tyvars', tcdFixity = fixity, - tcdFDs = fds', tcdSigs = sigs', - tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs', tcdCExt = all_fvs }, - all_fvs ) } - where - cls_doc = ClassDeclCtx lcls - -rnTyClDecl (XTyClDecl nec) = noExtCon nec - --- Does the data type declaration include a CUSK? -data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool -data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do - { -- See Note [Unlifted Newtypes and CUSKs], and for a broader - -- picture, see Note [Implementation of UnliftedNewtypes]. - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let non_cusk_newtype - | NewType <- new_or_data = - unlifted_newtypes && isNothing kind_sig - | otherwise = False - -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls - ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype - } - -{- Note [Unlifted Newtypes and CUSKs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When unlifted newtypes are enabled, a newtype must have a kind signature -in order to be considered have a CUSK. This is because the flow of -kind inference works differently. Consider: - - newtype Foo = FooC Int - -When UnliftedNewtypes is disabled, we decide that Foo has kind -`TYPE 'LiftedRep` without looking inside the data constructor. So, we -can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, -we fill in the kind of Foo as a metavar that gets solved by unification -with the kind of the field inside FooC (that is, Int, whose kind is -`TYPE 'LiftedRep`). But since we have to look inside the data constructors -to figure out the kind signature of Foo, it does not have a CUSK. - -See Note [Implementation of UnliftedNewtypes] for where this fits in to -the broader picture of UnliftedNewtypes. --} - --- "type" and "type instance" declarations -rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnTySyn doc rhs = rnLHsType doc rhs - -rnDataDefn :: HsDocContext -> HsDataDefn GhcPs - -> RnM (HsDataDefn GhcRn, FreeVars) -rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context, dd_cons = condecls - , dd_kindSig = m_sig, dd_derivs = derivs }) - = do { checkTc (h98_style || null (unLoc context)) - (badGadtStupidTheta doc) - - ; (m_sig', sig_fvs) <- case m_sig of - Just sig -> first Just <$> rnLHsKind doc sig - Nothing -> return (Nothing, emptyFVs) - ; (context', fvs1) <- rnContext doc context - ; (derivs', fvs3) <- rn_derivs derivs - - -- For the constructor declarations, drop the LocalRdrEnv - -- in the GADT case, where the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let { zap_lcl_env | h98_style = \ thing -> thing - | otherwise = setLocalRdrEnv emptyLocalRdrEnv } - ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` - con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context', dd_kindSig = m_sig' - , dd_cons = condecls' - , dd_derivs = derivs' } - , all_fvs ) - } - where - h98_style = case condecls of -- Note [Stupid theta] - (dL->L _ (ConDeclGADT {})) : _ -> False - _ -> True - - rn_derivs (dL->L loc ds) - = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies - ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) - multipleDerivClausesErr - ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (cL loc ds', fvs) } -rnDataDefn _ (XHsDataDefn nec) = noExtCon nec - -warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) - -> SrcSpan - -> RnM () -warnNoDerivStrat mds loc - = do { dyn_flags <- getDynFlags - ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ - case mds of - Nothing -> addWarnAt - (Reason Opt_WarnMissingDerivingStrategies) - loc - (if xopt LangExt.DerivingStrategies dyn_flags - then no_strat_warning - else no_strat_warning $+$ deriv_strat_nenabled - ) - _ -> pure () - } - where - no_strat_warning :: SDoc - no_strat_warning = text "No deriving strategy specified. Did you want stock" - <> text ", newtype, or anyclass?" - deriv_strat_nenabled :: SDoc - deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy." - -rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs - -> RnM (LHsDerivingClause GhcRn, FreeVars) -rnLHsDerivingClause doc - (dL->L loc (HsDerivingClause - { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs - , deriv_clause_tys = (dL->L loc' dct) })) - = do { (dcs', dct', fvs) - <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct - ; warnNoDerivStrat dcs' loc - ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs' - , deriv_clause_tys = cL loc' dct' }) - , fvs ) } -rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec)) - = noExtCon nec -rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" - -- due to #15884 - -rnLDerivStrategy :: forall a. - HsDocContext - -> Maybe (LDerivStrategy GhcPs) - -> RnM (a, FreeVars) - -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) -rnLDerivStrategy doc mds thing_inside - = case mds of - Nothing -> boring_case Nothing - Just (dL->L loc ds) -> - setSrcSpan loc $ do - (ds', thing, fvs) <- rn_deriv_strat ds - pure (Just (cL loc ds'), thing, fvs) - where - rn_deriv_strat :: DerivStrategy GhcPs - -> RnM (DerivStrategy GhcRn, a, FreeVars) - rn_deriv_strat ds = do - let extNeeded :: LangExt.Extension - extNeeded - | ViaStrategy{} <- ds - = LangExt.DerivingVia - | otherwise - = LangExt.DerivingStrategies - - unlessXOptM extNeeded $ - failWith $ illegalDerivStrategyErr ds - - case ds of - StockStrategy -> boring_case StockStrategy - AnyclassStrategy -> boring_case AnyclassStrategy - NewtypeStrategy -> boring_case NewtypeStrategy - ViaStrategy via_ty -> - do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty - let HsIB { hsib_ext = via_imp_tvs - , hsib_body = via_body } = via_ty' - (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body - via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs - via_tvs = via_imp_tvs ++ via_exp_tvs - (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside - pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) - - boring_case :: ds -> RnM (ds, a, FreeVars) - boring_case ds = do - (thing, fvs) <- thing_inside - pure (ds, thing, fvs) - -badGadtStupidTheta :: HsDocContext -> SDoc -badGadtStupidTheta _ - = vcat [text "No context is allowed on a GADT-style data declaration", - text "(You can put a context on each constructor, though.)"] - -illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc -illegalDerivStrategyErr ds - = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds - , text enableStrategy ] - - where - enableStrategy :: String - enableStrategy - | ViaStrategy{} <- ds - = "Use DerivingVia to enable this extension" - | otherwise - = "Use DerivingStrategies to enable this extension" - -multipleDerivClausesErr :: SDoc -multipleDerivClausesErr - = vcat [ text "Illegal use of multiple, consecutive deriving clauses" - , text "Use DerivingStrategies to allow this" ] - -rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested - -- inside an *class decl* for cls - -- used for associated types - -> FamilyDecl GhcPs - -> RnM (FamilyDecl GhcRn, FreeVars) -rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars - , fdFixity = fixity - , fdInfo = info, fdResultSig = res_sig - , fdInjectivityAnn = injectivity }) - = do { tycon' <- lookupLocatedTopBndrRn tycon - ; ((tyvars', res_sig', injectivity'), fv1) <- - bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ -> - do { let rn_sig = rnFamResultSig doc - ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig - ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') - injectivity - ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } - ; (info', fv2) <- rn_info tycon' info - ; return (FamilyDecl { fdExt = noExtField - , fdLName = tycon', fdTyVars = tyvars' - , fdFixity = fixity - , fdInfo = info', fdResultSig = res_sig' - , fdInjectivityAnn = injectivity' } - , fv1 `plusFV` fv2) } - where - doc = TyFamilyCtx tycon - kvs = extractRdrKindSigVars res_sig - - ---------------------- - rn_info :: Located Name - -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) - rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns)) - = do { (eqns', fvs) - <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) - -- no class context - eqns - ; return (ClosedTypeFamily (Just eqns'), fvs) } - rn_info _ (ClosedTypeFamily Nothing) - = return (ClosedTypeFamily Nothing, emptyFVs) - rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs) - rn_info _ DataFamily = return (DataFamily, emptyFVs) -rnFamDecl _ (XFamilyDecl nec) = noExtCon nec - -rnFamResultSig :: HsDocContext - -> FamilyResultSig GhcPs - -> RnM (FamilyResultSig GhcRn, FreeVars) -rnFamResultSig _ (NoSig _) - = return (NoSig noExtField, emptyFVs) -rnFamResultSig doc (KindSig _ kind) - = do { (rndKind, ftvs) <- rnLHsKind doc kind - ; return (KindSig noExtField rndKind, ftvs) } -rnFamResultSig doc (TyVarSig _ tvbndr) - = do { -- `TyVarSig` tells us that user named the result of a type family by - -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to - -- be sure that the supplied result name is not identical to an - -- already in-scope type variable from an enclosing class. - -- - -- Example of disallowed declaration: - -- class C a b where - -- type F b = a | a -> b - rdr_env <- getLocalRdrEnv - ; let resName = hsLTyVarName tvbndr - ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLoc tvbndr) $ - (hsep [ text "Type variable", quotes (ppr resName) <> comma - , text "naming a type family result," - ] $$ - text "shadows an already bound type variable") - - ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for - -- scoping checks that are irrelevant here - tvbndr $ \ tvbndr' -> - return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) } -rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec - --- Note [Renaming injectivity annotation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- During renaming of injectivity annotation we have to make several checks to --- make sure that it is well-formed. At the moment injectivity annotation --- consists of a single injectivity condition, so the terms "injectivity --- annotation" and "injectivity condition" might be used interchangeably. See --- Note [Injectivity annotation] for a detailed discussion of currently allowed --- injectivity annotations. --- --- Checking LHS is simple because the only type variable allowed on the LHS of --- injectivity condition is the variable naming the result in type family head. --- Example of disallowed annotation: --- --- type family Foo a b = r | b -> a --- --- Verifying RHS of injectivity consists of checking that: --- --- 1. only variables defined in type family head appear on the RHS (kind --- variables are also allowed). Example of disallowed annotation: --- --- type family Foo a = r | r -> b --- --- 2. for associated types the result variable does not shadow any of type --- class variables. Example of disallowed annotation: --- --- class Foo a b where --- type F a = b | b -> a --- --- Breaking any of these assumptions results in an error. - --- | Rename injectivity annotation. Note that injectivity annotation is just the --- part after the "|". Everything that appears before it is renamed in --- rnFamDecl. -rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in - -- type family head - -> LFamilyResultSig GhcRn -- ^ Result signature - -> LInjectivityAnn GhcPs -- ^ Injectivity annotation - -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) - (dL->L srcSpan (InjectivityAnn injFrom injTo)) - = do - { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors) - <- askNoErrs $ - bindLocalNames [hsLTyVarName resTv] $ - -- The return type variable scopes over the injectivity annotation - -- e.g. type family F a = (r::*) | r -> a - do { injFrom' <- rnLTyVar injFrom - ; injTo' <- mapM rnLTyVar injTo - ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') } - - ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs - resName = hsLTyVarName resTv - -- See Note [Renaming injectivity annotation] - lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) - rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames - - -- if renaming of type variables ended with errors (eg. there were - -- not-in-scope variables) don't check the validity of injectivity - -- annotation. This gives better error messages. - ; when (noRnErrors && not lhsValid) $ - addErrAt (getLoc injFrom) - ( vcat [ text $ "Incorrect type variable on the LHS of " - ++ "injectivity condition" - , nest 5 - ( vcat [ text "Expected :" <+> ppr resName - , text "Actual :" <+> ppr injFrom ])]) - - ; when (noRnErrors && not (Set.null rhsValid)) $ - do { let errorVars = Set.toList rhsValid - ; addErrAt srcSpan $ ( hsep - [ text "Unknown type variable" <> plural errorVars - , text "on the RHS of injectivity condition:" - , interpp'SP errorVars ] ) } - - ; return injDecl' } - --- We can only hit this case when the user writes injectivity annotation without --- naming the result: --- --- type family F a | result -> a --- type family F a :: * | result -> a --- --- So we rename injectivity annotation like we normally would except that --- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) = - setSrcSpan srcSpan $ do - (injDecl', _) <- askNoErrs $ do - injFrom' <- rnLTyVar injFrom - injTo' <- mapM rnLTyVar injTo - return $ cL srcSpan (InjectivityAnn injFrom' injTo') - return $ injDecl' - -{- -Note [Stupid theta] -~~~~~~~~~~~~~~~~~~~ -#3850 complains about a regression wrt 6.10 for - data Show a => T a -There is no reason not to allow the stupid theta if there are no data -constructors. It's still stupid, but does no harm, and I don't want -to cause programs to break unnecessarily (notably HList). So if there -are no data constructors we allow h98_style = True --} - - -{- ***************************************************** -* * - Support code for type/data declarations -* * -***************************************************** -} - ---------------- -wrongTyFamName :: Name -> Name -> SDoc -wrongTyFamName fam_tc_name eqn_tc_name - = hang (text "Mismatched type name in type family instance.") - 2 (vcat [ text "Expected:" <+> ppr fam_tc_name - , text " Actual:" <+> ppr eqn_tc_name ]) - ------------------ -rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) -rnConDecls = mapFvRn (wrapLocFstM rnConDecl) - -rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) -rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs - , con_mb_cxt = mcxt, con_args = args - , con_doc = mb_doc }) - = do { _ <- addLocM checkConName name - ; new_name <- lookupLocatedTopBndrRn name - ; mb_doc' <- rnMbLHsDoc mb_doc - - -- We bind no implicit binders here; this is just like - -- a nested HsForAllTy. E.g. consider - -- data T a = forall (b::k). MkT (...) - -- The 'k' will already be in scope from the bindHsQTyVars - -- for the data decl itself. So we'll get - -- data T {k} a = ... - -- And indeed we may later discover (a::k). But that's the - -- scoping we get. So no implicit binders at the existential forall - - ; let ctxt = ConDeclCtx [new_name] - ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt)) - Nothing ex_tvs $ \ new_ex_tvs -> - do { (new_context, fvs1) <- rnMbContext ctxt mcxt - ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args - ; let all_fvs = fvs1 `plusFV` fvs2 - ; traceRn "rnConDecl" (ppr name <+> vcat - [ text "ex_tvs:" <+> ppr ex_tvs - , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) - - ; return (decl { con_ext = noExtField - , con_name = new_name, con_ex_tvs = new_ex_tvs - , con_mb_cxt = new_context, con_args = new_args - , con_doc = mb_doc' }, - all_fvs) }} - -rnConDecl decl@(ConDeclGADT { con_names = names - , con_forall = (dL->L _ explicit_forall) - , con_qvars = qtvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty - , con_doc = mb_doc }) - = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names - ; mb_doc' <- rnMbLHsDoc mb_doc - - ; let explicit_tkvs = hsQTvExplicit qtvs - theta = hsConDeclTheta mcxt - arg_tys = hsConDeclArgTys args - - -- We must ensure that we extract the free tkvs in left-to-right - -- order of their appearance in the constructor type. - -- That order governs the order the implicitly-quantified type - -- variable, and hence the order needed for visible type application - -- See #14808. - free_tkvs = extractHsTvBndrs explicit_tkvs $ - extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) - - ctxt = ConDeclCtx new_names - mb_ctxt = Just (inHsDocContext ctxt) - - ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall ) - ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs -> - bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs -> - do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt - ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args - ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty - - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - (args', res_ty') - = case args of - InfixCon {} -> pprPanic "rnConDecl" (ppr names) - RecCon {} -> (new_args, new_res_ty) - PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty - -> ASSERT( null as ) - -- See Note [GADT abstract syntax] in GHC.Hs.Decls - (PrefixCon arg_tys, final_res_ty) - - new_qtvs = HsQTvs { hsq_ext = implicit_tkvs - , hsq_explicit = explicit_tkvs } - - ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) - ; return (decl { con_g_ext = noExtField, con_names = new_names - , con_qvars = new_qtvs, con_mb_cxt = new_cxt - , con_args = args', con_res_ty = res_ty' - , con_doc = mb_doc' }, - all_fvs) } } - -rnConDecl (XConDecl nec) = noExtCon nec - - -rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) - -> RnM (Maybe (LHsContext GhcRn), FreeVars) -rnMbContext _ Nothing = return (Nothing, emptyFVs) -rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt - ; return (Just ctx',fvs) } - -rnConDeclDetails - :: Name - -> HsDocContext - -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) - -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), - FreeVars) -rnConDeclDetails _ doc (PrefixCon tys) - = do { (new_tys, fvs) <- rnLHsTypes doc tys - ; return (PrefixCon new_tys, fvs) } - -rnConDeclDetails _ doc (InfixCon ty1 ty2) - = do { (new_ty1, fvs1) <- rnLHsType doc ty1 - ; (new_ty2, fvs2) <- rnLHsType doc ty2 - ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } - -rnConDeclDetails con doc (RecCon (dL->L l fields)) - = do { fls <- lookupConstructorFields con - ; (new_fields, fvs) <- rnConDeclFields doc fls fields - -- No need to check for duplicate fields - -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon (cL l new_fields), fvs) } - -------------------------------------------------- - --- | Brings pattern synonym names and also pattern synonym selectors --- from record pattern synonyms into scope. -extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv - -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a -extendPatSynEnv val_decls local_fix_env thing = do { - names_with_fls <- new_ps val_decls - ; let pat_syn_bndrs = concat [ name: map flSelector fields - | (name, fields) <- names_with_fls ] - ; let avails = map avail pat_syn_bndrs - ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env - - ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls - final_gbl_env = gbl_env { tcg_field_env = field_env' } - ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } - where - new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] - new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds - new_ps _ = panic "new_ps" - - new_ps' :: LHsBindLR GhcPs GhcPs - -> [(Name, [FieldLabel])] - -> TcM [(Name, [FieldLabel])] - new_ps' bind names - | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n) - , psb_args = RecCon as }))) <- bind - = do - bnd_name <- newTopSrcBinder (cL bind_loc n) - let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name)) - field_occs = map mkFieldOcc rnames - flds <- mapM (newRecordSelector False [bnd_name]) field_occs - return ((bnd_name, flds): names) - | (dL->L bind_loc (PatSynBind _ - (PSB { psb_id = (dL->L _ n)}))) <- bind - = do - bnd_name <- newTopSrcBinder (cL bind_loc n) - return ((bnd_name, []): names) - | otherwise - = return names - -{- -********************************************************* -* * -\subsection{Support code to rename types} -* * -********************************************************* --} - -rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] -rnFds fds - = mapM (wrapLocM rn_fds) fds - where - rn_fds (tys1, tys2) - = do { tys1' <- rnHsTyVars tys1 - ; tys2' <- rnHsTyVars tys2 - ; return (tys1', tys2') } - -rnHsTyVars :: [Located RdrName] -> RnM [Located Name] -rnHsTyVars tvs = mapM rnHsTyVar tvs - -rnHsTyVar :: Located RdrName -> RnM (Located Name) -rnHsTyVar (dL->L l tyvar) = do - tyvar' <- lookupOccRn tyvar - return (cL l tyvar') - -{- -********************************************************* -* * - findSplice -* * -********************************************************* - -This code marches down the declarations, looking for the first -Template Haskell splice. As it does so it - a) groups the declarations into a HsGroup - b) runs any top-level quasi-quotes --} - -findSplice :: [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -findSplice ds = addl emptyRdrGroup ds - -addl :: HsGroup GhcPs -> [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) --- This stuff reverses the declarations (again) but it doesn't matter -addl gp [] = return (gp, Nothing) -addl gp ((dL->L l d) : ds) = add gp l d ds - - -add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) - --- #10047: Declaration QuasiQuoters are expanded immediately, without --- causing a group split -add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds - = do { (ds', _) <- rnTopSpliceDecls qq - ; addl gp (ds' ++ ds) - } - -add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds - = do { -- We've found a top-level splice. If it is an *implicit* one - -- (i.e. a naked top level expression) - case flag of - ExplicitSplice -> return () - ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell - ; unless th_on $ setSrcSpan loc $ - failWith badImplicitSplice } - - ; return (gp, Just (splice, ds)) } - where - badImplicitSplice = text "Parse error: module header, import declaration" - $$ text "or top-level declaration expected." - -- The compiler should suggest the above, and not using - -- TemplateHaskell since the former suggestion is more - -- relevant to the larger base of users. - -- See #12146 for discussion. - --- Class declarations: pull out the fixity signatures to the top -add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds - | isClassDecl d - = let fsigs = [ cL l f - | (dL->L l (FixSig _ f)) <- tcdSigs d ] in - addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds - | otherwise - = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds - --- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds - = addl (gp {hs_fixds = cL l f : ts}) ds - --- Standalone kind signatures: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds - = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds - -add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds - = addl (gp {hs_valds = add_sig (cL l d) ts}) ds - --- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds - = addl (gp { hs_valds = add_bind (cL l d) ts }) ds - --- Role annotations: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds - = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds - --- NB instance declarations go into TyClGroups. We throw them into the first --- group, just as we do for the TyClD case. The renamer will go on to group --- and order them later. -add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds - = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds - --- The rest are routine -add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds - = addl (gp { hs_derivds = cL l d : ts }) ds -add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds - = addl (gp { hs_defds = cL l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds - = addl (gp { hs_fords = cL l d : ts }) ds -add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds - = addl (gp { hs_warnds = cL l d : ts }) ds -add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds - = addl (gp { hs_annds = cL l d : ts }) ds -add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds - = addl (gp { hs_ruleds = cL l d : ts }) ds -add gp l (DocD _ d) ds - = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds -add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec -add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec -add (XHsGroup nec) _ _ _ = noExtCon nec - -add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] -add_tycld d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [d] - , group_kisigs = [] - , group_roles = [] - , group_instds = [] - } - ] -add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) - = ds { group_tyclds = d : tyclds } : dss -add_tycld _ (XTyClGroup nec: _) = noExtCon nec - -add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] -add_instd d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [] - , group_instds = [d] - } - ] -add_instd d (ds@(TyClGroup { group_instds = instds }):dss) - = ds { group_instds = d : instds } : dss -add_instd _ (XTyClGroup nec: _) = noExtCon nec - -add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] -add_role_annot d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [d] - , group_instds = [] - } - ] -add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) - = tycls { group_roles = d : roles } : rest -add_role_annot _ (XTyClGroup nec: _) = noExtCon nec - -add_kisig :: LStandaloneKindSig (GhcPass p) - -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] -add_kisig d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [d] - , group_roles = [] - , group_instds = [] - } - ] -add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) - = tycls { group_kisigs = d : kisigs } : rest -add_kisig _ (XTyClGroup nec : _) = noExtCon nec - -add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs -add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind" - -add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) -add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig" diff --git a/rename/RnSplice.hs b/rename/RnSplice.hs deleted file mode 100644 --- a/rename/RnSplice.hs +++ /dev/null @@ -1,902 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module RnSplice ( - rnTopSpliceDecls, - rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, - rnBracket, - checkThLocalName - , traceSplice, SpliceInfo(..) - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Name -import NameSet -import GHC.Hs -import RdrName -import TcRnMonad - -import RnEnv -import RnUtils ( HsDocContext(..), newLocalBndrRn ) -import RnUnbound ( isUnboundName ) -import RnSource ( rnSrcDecls, findSplice ) -import RnPat ( rnPat ) -import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) -import Outputable -import Module -import SrcLoc -import RnTypes ( rnLHsType ) - -import Control.Monad ( unless, when ) - -import {-# SOURCE #-} RnExpr ( rnLExpr ) - -import TcEnv ( checkWellStaged ) -import THNames ( liftName ) - -import DynFlags -import FastString -import ErrUtils ( dumpIfSet_dyn_printer ) -import TcEnv ( tcMetaTy ) -import Hooks -import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName - , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) - -import {-# SOURCE #-} TcExpr ( tcPolyExpr ) -import {-# SOURCE #-} TcSplice - ( runMetaD - , runMetaE - , runMetaP - , runMetaT - , tcTopSpliceExpr - ) - -import TcHsSyn - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) - -import qualified GHC.LanguageExtensions as LangExt - -{- -************************************************************************ -* * - Template Haskell brackets -* * -************************************************************************ --} - -rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars) -rnBracket e br_body - = addErrCtxt (quotationCtxtDoc br_body) $ - do { -- Check that -XTemplateHaskellQuotes is enabled and available - thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes - ; unless thQuotesEnabled $ - failWith ( vcat - [ text "Syntax error on" <+> ppr e - , text ("Perhaps you intended to use TemplateHaskell" - ++ " or TemplateHaskellQuotes") ] ) - - -- Check for nested brackets - ; cur_stage <- getStage - ; case cur_stage of - { Splice Typed -> checkTc (isTypedBracket br_body) - illegalUntypedBracket - ; Splice Untyped -> checkTc (not (isTypedBracket br_body)) - illegalTypedBracket - ; RunSplice _ -> - -- See Note [RunSplice ThLevel] in "TcRnTypes". - pprPanic "rnBracket: Renaming bracket when running a splice" - (ppr e) - ; Comp -> return () - ; Brack {} -> failWithTc illegalBracket - } - - -- Brackets are desugared to code that mentions the TH package - ; recordThUse - - ; case isTypedBracket br_body of - True -> do { traceRn "Renaming typed TH bracket" empty - ; (body', fvs_e) <- - setStage (Brack cur_stage RnPendingTyped) $ - rn_bracket cur_stage br_body - ; return (HsBracket noExtField body', fvs_e) } - - False -> do { traceRn "Renaming untyped TH bracket" empty - ; ps_var <- newMutVar [] - ; (body', fvs_e) <- - setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ - rn_bracket cur_stage br_body - ; pendings <- readMutVar ps_var - ; return (HsRnBracketOut noExtField body' pendings, fvs_e) } - } - -rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) -rn_bracket outer_stage br@(VarBr x flg rdr_name) - = do { name <- lookupOccRn rdr_name - ; this_mod <- getModule - - ; when (flg && nameIsLocalOrFrom this_mod name) $ - -- Type variables can be quoted in TH. See #5721. - do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name - ; case mb_bind_lvl of - { Nothing -> return () -- Can happen for data constructors, - -- but nothing needs to be done for them - - ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] - | isTopLevel top_lvl - -> when (isExternalName name) (keepAlive name) - | otherwise - -> do { traceRn "rn_bracket VarBr" - (ppr name <+> ppr bind_lvl - <+> ppr outer_stage) - ; checkTc (thLevel outer_stage + 1 == bind_lvl) - (quotedNameStageErr br) } - } - } - ; return (VarBr x flg name, unitFV name) } - -rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr x e', fvs) } - -rn_bracket _ (PatBr x p) - = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) - -rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr x t', fvs) } - -rn_bracket _ (DecBrL x decls) - = do { group <- groupDecls decls - ; gbl_env <- getGblEnv - ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } - -- The emptyDUs is so that we just collect uses for this - -- group alone in the call to rnSrcDecls below - ; (tcg_env, group') <- setGblEnv new_gbl_env $ - rnSrcDecls group - - -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$ - ppr (duUses (tcg_dus tcg_env))) - ; return (DecBrG x group', duUses (tcg_dus tcg_env)) } - where - groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) - groupDecls decls - = do { (group, mb_splice) <- findSplice decls - ; case mb_splice of - { Nothing -> return group - ; Just (splice, rest) -> - do { group' <- groupDecls rest - ; let group'' = appendGroups group group' - ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } - } - }} - -rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" - -rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e - ; return (TExpBr x e', fvs) } - -rn_bracket _ (XBracket nec) = noExtCon nec - -quotationCtxtDoc :: HsBracket GhcPs -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (ppr br_body) - -illegalBracket :: SDoc -illegalBracket = - text "Template Haskell brackets cannot be nested" <+> - text "(without intervening splices)" - -illegalTypedBracket :: SDoc -illegalTypedBracket = - text "Typed brackets may only appear in typed splices." - -illegalUntypedBracket :: SDoc -illegalUntypedBracket = - text "Untyped brackets may only appear in untyped splices." - -quotedNameStageErr :: HsBracket GhcPs -> SDoc -quotedNameStageErr br - = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br - , text "must be used at the same stage at which it is bound" ] - - -{- -********************************************************* -* * - Splices -* * -********************************************************* - -Note [Free variables of typed splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider renaming this: - f = ... - h = ...$(thing "f")... - -where the splice is a *typed* splice. The splice can expand into -literally anything, so when we do dependency analysis we must assume -that it might mention 'f'. So we simply treat all locally-defined -names as mentioned by any splice. This is terribly brutal, but I -don't see what else to do. For example, it'll mean that every -locally-defined thing will appear to be used, so no unused-binding -warnings. But if we miss the dependency, then we might typecheck 'h' -before 'f', and that will crash the type checker because 'f' isn't in -scope. - -Currently, I'm not treating a splice as also mentioning every import, -which is a bit inconsistent -- but there are a lot of them. We might -thereby get some bogus unused-import warnings, but we won't crash the -type checker. Not very satisfactory really. - -Note [Renamer errors] -~~~~~~~~~~~~~~~~~~~~~ -It's important to wrap renamer calls in checkNoErrs, because the -renamer does not fail for out of scope variables etc. Instead it -returns a bogus term/type, so that it can report more than one error. -We don't want the type checker to see these bogus unbound variables. --} - -rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars)) - -- Outside brackets, run splice - -> (HsSplice GhcRn -> (PendingRnSplice, a)) - -- Inside brackets, make it pending - -> HsSplice GhcPs - -> RnM (a, FreeVars) -rnSpliceGen run_splice pend_splice splice - = addErrCtxt (spliceCtxt splice) $ do - { stage <- getStage - ; case stage of - Brack pop_stage RnPendingTyped - -> do { checkTc is_typed_splice illegalUntypedSplice - ; (splice', fvs) <- setStage pop_stage $ - rnSplice splice - ; let (_pending_splice, result) = pend_splice splice' - ; return (result, fvs) } - - Brack pop_stage (RnPendingUntyped ps_var) - -> do { checkTc (not is_typed_splice) illegalTypedSplice - ; (splice', fvs) <- setStage pop_stage $ - rnSplice splice - ; let (pending_splice, result) = pend_splice splice' - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pending_splice : ps) - ; return (result, fvs) } - - _ -> do { (splice', fvs1) <- checkNoErrs $ - setStage (Splice splice_type) $ - rnSplice splice - -- checkNoErrs: don't attempt to run the splice if - -- renaming it failed; otherwise we get a cascade of - -- errors from e.g. unbound variables - ; (result, fvs2) <- run_splice splice' - ; return (result, fvs1 `plusFV` fvs2) } } - where - is_typed_splice = isTypedSplice splice - splice_type = if is_typed_splice - then Typed - else Untyped - ------------------- - --- | Returns the result of running a splice and the modFinalizers collected --- during the execution. --- --- See Note [Delaying modFinalizers in untyped splices]. -runRnSplice :: UntypedSpliceFlavour - -> (LHsExpr GhcTc -> TcRn res) - -> (res -> SDoc) -- How to pretty-print res - -- Usually just ppr, but not for [Decl] - -> HsSplice GhcRn -- Always untyped - -> TcRn (res, [ForeignRef (TH.Q ())]) -runRnSplice flavour run_meta ppr_res splice - = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) - - ; let the_expr = case splice' of - HsUntypedSplice _ _ _ e -> e - HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str - HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) - HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) - HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice) - XSplice nec -> noExtCon nec - - -- Typecheck the expression - ; meta_exp_ty <- tcMetaTy meta_ty_name - ; zonked_q_expr <- zonkTopLExpr =<< - tcTopSpliceExpr Untyped - (tcPolyExpr the_expr meta_exp_ty) - - -- Run the expression - ; mod_finalizers_ref <- newTcRef [] - ; result <- setStage (RunSplice mod_finalizers_ref) $ - run_meta zonked_q_expr - ; mod_finalizers <- readTcRef mod_finalizers_ref - ; traceSplice (SpliceInfo { spliceDescription = what - , spliceIsDecl = is_decl - , spliceSource = Just the_expr - , spliceGenerated = ppr_res result }) - - ; return (result, mod_finalizers) } - - where - meta_ty_name = case flavour of - UntypedExpSplice -> expQTyConName - UntypedPatSplice -> patQTyConName - UntypedTypeSplice -> typeQTyConName - UntypedDeclSplice -> decsQTyConName - what = case flavour of - UntypedExpSplice -> "expression" - UntypedPatSplice -> "pattern" - UntypedTypeSplice -> "type" - UntypedDeclSplice -> "declarations" - is_decl = case flavour of - UntypedDeclSplice -> True - _ -> False - ------------------- -makePending :: UntypedSpliceFlavour - -> HsSplice GhcRn - -> PendingRnSplice -makePending flavour (HsUntypedSplice _ _ n e) - = PendingRnSplice flavour n e -makePending flavour (HsQuasiQuote _ n quoter q_span quote) - = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) -makePending _ splice@(HsTypedSplice {}) - = pprPanic "makePending" (ppr splice) -makePending _ splice@(HsSpliced {}) - = pprPanic "makePending" (ppr splice) -makePending _ splice@(HsSplicedT {}) - = pprPanic "makePending" (ppr splice) -makePending _ (XSplice nec) - = noExtCon nec - ------------------- -mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString - -> LHsExpr GhcRn --- Return the expression (quoter "...quote...") --- which is what we must run in a quasi-quote -mkQuasiQuoteExpr flavour quoter q_span quote - = cL q_span $ HsApp noExtField (cL q_span - $ HsApp noExtField (cL q_span (HsVar noExtField (cL q_span quote_selector))) - quoterExpr) - quoteExpr - where - quoterExpr = cL q_span $! HsVar noExtField $! (cL q_span quoter) - quoteExpr = cL q_span $! HsLit noExtField $! HsString NoSourceText quote - quote_selector = case flavour of - UntypedExpSplice -> quoteExpName - UntypedPatSplice -> quotePatName - UntypedTypeSplice -> quoteTypeName - UntypedDeclSplice -> quoteDecName - ---------------------- -rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) --- Not exported...used for all -rnSplice (HsTypedSplice x hasParen splice_name expr) - = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) - ; (expr', fvs) <- rnLExpr expr - ; return (HsTypedSplice x hasParen n' expr', fvs) } - -rnSplice (HsUntypedSplice x hasParen splice_name expr) - = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) - ; (expr', fvs) <- rnLExpr expr - ; return (HsUntypedSplice x hasParen n' expr', fvs) } - -rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) - = do { loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (cL loc splice_name) - - -- Rename the quoter; akin to the HsVar case of rnExpr - ; quoter' <- lookupOccRn quoter - ; this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod quoter') $ - checkThLocalName quoter' - - ; return (HsQuasiQuote x splice_name' quoter' q_loc quote - , unitFV quoter') } - -rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) -rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice) -rnSplice (XSplice nec) = noExtCon nec - ---------------------- -rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) -rnSpliceExpr splice - = rnSpliceGen run_expr_splice pend_expr_splice splice - where - pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) - pend_expr_splice rn_splice - = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice) - - run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) - run_expr_splice rn_splice - | isTypedSplice rn_splice -- Run it later, in the type checker - = do { -- Ugh! See Note [Splices] above - traceRn "rnSpliceExpr: typed expression splice" empty - ; lcl_rdr <- getLocalRdrEnv - ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr - , isLocalGRE gre] - lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - - ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) } - - | otherwise -- Run it here, see Note [Running splices in the Renamer] - = do { traceRn "rnSpliceExpr: untyped expression splice" empty - ; (rn_expr, mod_finalizers) <- - runRnSplice UntypedExpSplice runMetaE ppr rn_splice - ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) - -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsPar noExtField $ HsSpliceE noExtField - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedExpr <$> - lexpr3 - , fvs) - } - -{- Note [Running splices in the Renamer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Splices used to be run in the typechecker, which led to (#4364). Since the -renamer must decide which expressions depend on which others, and it cannot -reliably do this for arbitrary splices, we used to conservatively say that -splices depend on all other expressions in scope. Unfortunately, this led to -the problem of cyclic type declarations seen in (#4364). Instead, by -running splices in the renamer, we side-step the problem of determining -dependencies: by the time the dependency analysis happens, any splices have -already been run, and expression dependencies can be determined as usual. - -However, see (#9813), for an example where we would like to run splices -*after* performing dependency analysis (that is, after renaming). It would be -desirable to typecheck "non-splicy" expressions (those expressions that do not -contain splices directly or via dependence on an expression that does) before -"splicy" expressions, such that types/expressions within the same declaration -group would be available to `reify` calls, for example consider the following: - -> module M where -> data D = C -> f = 1 -> g = $(mapM reify ['f, 'D, ''C] ...) - -Compilation of this example fails since D/C/f are not in the type environment -and thus cannot be reified as they have not been typechecked by the time the -splice is renamed and thus run. - -These requirements are at odds: we do not want to run splices in the renamer as -we wish to first determine dependencies and typecheck certain expressions, -making them available to reify, but cannot accurately determine dependencies -without running splices in the renamer! - -Indeed, the conclusion of (#9813) was that it is not worth the complexity -to try and - a) implement and maintain the code for renaming/typechecking non-splicy - expressions before splicy expressions, - b) explain to TH users which expressions are/not available to reify at any - given point. - --} - -{- Note [Delaying modFinalizers in untyped splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When splices run in the renamer, 'reify' does not have access to the local -type environment (#11832, [1]). - -For instance, in - -> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |]) - -'reify' cannot find @x@, because the local type environment is not yet -populated. To address this, we allow 'reify' execution to be deferred with -'addModFinalizer'. - -> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print) - [| return () |] - ) - -The finalizer is run with the local type environment when type checking is -complete. - -Since the local type environment is not available in the renamer, we annotate -the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where -@e@ is the result of splicing and @finalizers@ are the finalizers that have been -collected during evaluation of the splice [3]. In our example, - -> HsLet -> (x = e) -> (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print] -> (HsSplicedExpr $ return ()) -> ) - -When the typechecker finds the annotation, it inserts the finalizers in the -global environment and exposes the current local environment to them [4, 5, 6]. - -> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print] - -References: - -[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify -[2] 'rnSpliceExpr' -[3] 'TcSplice.qAddModFinalizer' -[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) -[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) -[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...)) - --} - ----------------------- -rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) -rnSpliceType splice - = rnSpliceGen run_type_splice pend_type_splice splice - where - pend_type_splice rn_splice - = ( makePending UntypedTypeSplice rn_splice - , HsSpliceTy noExtField rn_splice) - - run_type_splice rn_splice - = do { traceRn "rnSpliceType: untyped type splice" empty - ; (hs_ty2, mod_finalizers) <- - runRnSplice UntypedTypeSplice runMetaT ppr rn_splice - ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 - ; checkNoErrs $ rnLHsType doc hs_ty2 } - -- checkNoErrs: see Note [Renamer errors] - -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsParTy noExtField - $ HsSpliceTy noExtField - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedTy <$> - hs_ty3 - , fvs - ) } - -- Wrap the result of the splice in parens so that we don't - -- lose the outermost location set by runQuasiQuote (#7918) - -{- Note [Partial Type Splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial Type Signatures are partially supported in TH type splices: only -anonymous wild cards are allowed. - - -- ToDo: SLPJ says: I don't understand all this - -Normally, named wild cards are collected before renaming a (partial) type -signature. However, TH type splices are run during renaming, i.e. after the -initial traversal, leading to out of scope errors for named wild cards. We -can't just extend the initial traversal to collect the named wild cards in TH -type splices, as we'd need to expand them, which is supposed to happen only -once, during renaming. - -Similarly, the extra-constraints wild card is handled right before renaming -too, and is therefore also not supported in a TH type splice. Another reason -to forbid extra-constraints wild cards in TH type splices is that a single -signature can contain many TH type splices, whereas it mustn't contain more -than one extra-constraints wild card. Enforcing would this be hard the way -things are currently organised. - -Anonymous wild cards pose no problem, because they start out without names and -are given names during renaming. These names are collected right after -renaming. The names generated for anonymous wild cards in TH type splices will -thus be collected as well. - -For more details about renaming wild cards, see RnTypes.rnHsSigWcType - -Note that partial type signatures are fully supported in TH declaration -splices, e.g.: - - [d| foo :: _ => _ - foo x y = x == y |] - -This is because in this case, the partial type signature can be treated as a -whole signature, instead of as an arbitrary type. - --} - - ----------------------- --- | Rename a splice pattern. See Note [rnSplicePat] -rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) - , FreeVars) -rnSplicePat splice - = rnSpliceGen run_pat_splice pend_pat_splice splice - where - pend_pat_splice :: HsSplice GhcRn -> - (PendingRnSplice, Either b (Pat GhcRn)) - pend_pat_splice rn_splice - = (makePending UntypedPatSplice rn_splice - , Right (SplicePat noExtField rn_splice)) - - run_pat_splice :: HsSplice GhcRn -> - RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars) - run_pat_splice rn_splice - = do { traceRn "rnSplicePat: untyped pattern splice" empty - ; (pat, mod_finalizers) <- - runRnSplice UntypedPatSplice runMetaP ppr rn_splice - -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedPat) `onHasSrcSpan` - pat - , emptyFVs - ) } - -- Wrap the result of the quasi-quoter in parens so that we don't - -- lose the outermost location set by runQuasiQuote (#7918) - ----------------------- -rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg) - = rnSpliceGen run_decl_splice pend_decl_splice splice - where - pend_decl_splice rn_splice - = ( makePending UntypedDeclSplice rn_splice - , SpliceDecl noExtField (cL loc rn_splice) flg) - - run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) -rnSpliceDecl (XSpliceDecl nec) = noExtCon nec - -rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) --- Declaration splice at the very top level of the module -rnTopSpliceDecls splice - = do { (rn_splice, fvs) <- checkNoErrs $ - setStage (Splice Untyped) $ - rnSplice splice - -- As always, be sure to checkNoErrs above lest we end up with - -- holes making it to typechecking, hence #12584. - -- - -- Note that we cannot call checkNoErrs for the whole duration - -- of rnTopSpliceDecls. The reason is that checkNoErrs changes - -- the local environment to temporarily contain a new - -- reference to store errors, and add_mod_finalizers would - -- cause this reference to be stored after checkNoErrs finishes. - -- This is checked by test TH_finalizer. - ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty - ; (decls, mod_finalizers) <- checkNoErrs $ - runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice - ; add_mod_finalizers_now mod_finalizers - ; return (decls,fvs) } - where - ppr_decls :: [LHsDecl GhcPs] -> SDoc - ppr_decls ds = vcat (map ppr ds) - - -- Adds finalizers to the global environment instead of delaying them - -- to the type checker. - -- - -- Declaration splices do not have an interesting local environment so - -- there is no point in delaying them. - -- - -- See Note [Delaying modFinalizers in untyped splices]. - add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn () - add_mod_finalizers_now [] = return () - add_mod_finalizers_now mod_finalizers = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - env <- getLclEnv - updTcRef th_modfinalizers_var $ \fins -> - (env, ThModFinalizers mod_finalizers) : fins - - -{- -Note [rnSplicePat] -~~~~~~~~~~~~~~~~~~ -Renaming a pattern splice is a bit tricky, because we need the variables -bound in the pattern to be in scope in the RHS of the pattern. This scope -management is effectively done by using continuation-passing style in -RnPat, through the CpsRn monad. We don't wish to be in that monad here -(it would create import cycles and generally conflict with renaming other -splices), so we really want to return a (Pat RdrName) -- the result of -running the splice -- which can then be further renamed in RnPat, in -the CpsRn monad. - -The problem is that if we're renaming a splice within a bracket, we -*don't* want to run the splice now. We really do just want to rename -it to an HsSplice Name. Of course, then we can't know what variables -are bound within the splice. So we accept any unbound variables and -rename them again when the bracket is spliced in. If a variable is brought -into scope by a pattern splice all is fine. If it is not then an error is -reported. - -In any case, when we're done in rnSplicePat, we'll either have a -Pat RdrName (the result of running a top-level splice) or a Pat Name -(the renamed nested splice). Thus, the awkward return type of -rnSplicePat. --} - -spliceCtxt :: HsSplice GhcPs -> SDoc -spliceCtxt splice - = hang (text "In the" <+> what) 2 (ppr splice) - where - what = case splice of - HsUntypedSplice {} -> text "untyped splice:" - HsTypedSplice {} -> text "typed splice:" - HsQuasiQuote {} -> text "quasi-quotation:" - HsSpliced {} -> text "spliced expression:" - HsSplicedT {} -> text "spliced expression:" - XSplice {} -> text "spliced expression:" - --- | The splice data to be logged -data SpliceInfo - = SpliceInfo - { spliceDescription :: String - , spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls - -- added by addTopDecls - , spliceIsDecl :: Bool -- True <=> put the generate code in a file - -- when -dth-dec-file is on - , spliceGenerated :: SDoc - } - -- Note that 'spliceSource' is *renamed* but not *typechecked* - -- Reason (a) less typechecking crap - -- (b) data constructors after type checking have been - -- changed to their *wrappers*, and that makes them - -- print always fully qualified - --- | outputs splice information for 2 flags which have different output formats: --- `-ddump-splices` and `-dth-dec-file` -traceSplice :: SpliceInfo -> TcM () -traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src - , spliceGenerated = gen, spliceIsDecl = is_decl }) - = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (dL->L loc _) -> return loc - ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) - - ; when is_decl $ -- Raw material for -dth-dec-file - do { dflags <- getDynFlags - ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file - (spliceCodeDoc loc) } } - where - -- `-ddump-splices` - spliceDebugDoc :: SrcSpan -> SDoc - spliceDebugDoc loc - = let code = case mb_src of - Nothing -> ending - Just e -> nest 2 (ppr e) : ending - ending = [ text "======>", nest 2 gen ] - in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) - 2 (sep code) - - -- `-dth-dec-file` - spliceCodeDoc :: SrcSpan -> SDoc - spliceCodeDoc loc - = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd - , gen ] - -illegalTypedSplice :: SDoc -illegalTypedSplice = text "Typed splices may not appear in untyped brackets" - -illegalUntypedSplice :: SDoc -illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" - -checkThLocalName :: Name -> RnM () -checkThLocalName name - | isUnboundName name -- Do not report two errors for - = return () -- $(not_in_scope args) - - | otherwise - = do { traceRn "checkThLocalName" (ppr name) - ; mb_local_use <- getStageAndBindLevel name - ; case mb_local_use of { - Nothing -> return () ; -- Not a locally-bound thing - Just (top_lvl, bind_lvl, use_stage) -> - do { let use_lvl = thLevel use_stage - ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl - ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl - <+> ppr use_stage - <+> ppr use_lvl) - ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } } - --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel - -> Name -> TcM () --- We are inside brackets, and (use_lvl > bind_lvl) --- Now we must check whether there's a cross-stage lift to do --- Examples \x -> [| x |] --- [| map |] --- --- This code is similar to checkCrossStageLifting in TcExpr, but --- this is only run on *untyped* brackets. - -checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name - | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets - , use_lvl > bind_lvl -- Cross-stage condition - = check_cross_stage_lifting top_lvl name ps_var - | otherwise - = return () - -check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () -check_cross_stage_lifting top_lvl name ps_var - | isTopLevel top_lvl - -- Top-level identifiers in this module, - -- (which have External Names) - -- are just like the imported case: - -- no need for the 'lifting' treatment - -- E.g. this is fine: - -- f x = x - -- g y = [| f 3 |] - = when (isExternalName name) (keepAlive name) - -- See Note [Keeping things alive for Template Haskell] - - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the SplicePointName, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same SplicePointName, but that doesn't - -- matter, although it's a mite untidy. - do { traceRn "checkCrossStageLifting" (ppr name) - - -- Construct the (lift x) expression - ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) - pend_splice = PendingRnSplice UntypedExpSplice name lift_expr - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pend_splice : ps) } - -{- -Note [Keeping things alive for Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = x+1 - g y = [| f 3 |] - -Here 'f' is referred to from inside the bracket, which turns into data -and mentions only f's *name*, not 'f' itself. So we need some other -way to keep 'f' alive, lest it get dropped as dead code. That's what -keepAlive does. It puts it in the keep-alive set, which subsequently -ensures that 'f' stays as a top level binding. - -This must be done by the renamer, not the type checker (as of old), -because the type checker doesn't typecheck the body of untyped -brackets (#8540). - -A thing can have a bind_lvl of outerLevel, but have an internal name: - foo = [d| op = 3 - bop = op + 1 |] -Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is -bound inside a bracket. That is because we don't even even record -binding levels for top-level things; the binding levels are in the -LocalRdrEnv. - -So the occurrence of 'op' in the rhs of 'bop' looks a bit like a -cross-stage thing, but it isn't really. And in fact we never need -to do anything here for top-level bound things, so all is fine, if -a bit hacky. - -For these chaps (which have Internal Names) we don't want to put -them in the keep-alive set. - -Note [Quoting names] -~~~~~~~~~~~~~~~~~~~~ -A quoted name 'n is a bit like a quoted expression [| n |], except that we -have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing -the use-level to account for the brackets, the cases are: - - bind > use Error - bind = use+1 OK - bind < use - Imported things OK - Top-level things OK - Non-top-level Error - -where 'use' is the binding level of the 'n quote. (So inside the implied -bracket the level would be use+1.) - -Examples: - - f 'map -- OK; also for top-level defns of this module - - \x. f 'x -- Not ok (bind = 1, use = 1) - -- (whereas \x. f [| x |] might have been ok, by - -- cross-stage lifting - - \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) - - [| \x. $(f 'x) |] -- OK (bind = 2, use = 1) --} diff --git a/rename/RnSplice.hs-boot b/rename/RnSplice.hs-boot deleted file mode 100644 --- a/rename/RnSplice.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module RnSplice where - -import GhcPrelude -import GHC.Hs -import TcRnMonad -import NameSet - - -rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) -rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) - , FreeVars ) -rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) - -rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) diff --git a/rename/RnTypes.hs b/rename/RnTypes.hs deleted file mode 100644 --- a/rename/RnTypes.hs +++ /dev/null @@ -1,1788 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnSource]{Main pass of renamer} --} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module RnTypes ( - -- Type related stuff - rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsKind, rnLHsKind, rnLHsTypeArgs, - rnHsSigType, rnHsWcType, - HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, - newTyVarNameRn, - rnConDeclFields, - rnLTyVar, - - -- Precence related stuff - mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec, - - -- Binding related stuff - bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs, - bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, - extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, - extractHsTysRdrTyVarsDups, - extractRdrKindSigVars, extractDataDefnKindVars, - extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup, - nubL, elemRdr - ) where - -import GhcPrelude - -import {-# SOURCE #-} RnSplice( rnSpliceType ) - -import DynFlags -import GHC.Hs -import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) -import RnEnv -import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn - , pprHsDocContext, bindLocalNamesFV, typeAppErr - , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames ) -import RnFixity ( lookupFieldFixityRn, lookupFixityRn - , lookupTyFixityRn ) -import TcRnMonad -import RdrName -import PrelNames -import TysPrim ( funTyConName ) -import Name -import SrcLoc -import NameSet -import FieldLabel - -import Util -import ListSetOps ( deleteBys ) -import BasicTypes ( compareFixity, funTyFixity, negateFixity - , Fixity(..), FixityDirection(..), LexicalFixity(..) - , TypeOrKind(..) ) -import Outputable -import FastString -import Maybes -import qualified GHC.LanguageExtensions as LangExt - -import Data.List ( nubBy, partition, (\\) ) -import Control.Monad ( unless, when ) - -#include "HsVersions.h" - -{- -These type renamers are in a separate module, rather than in (say) RnSource, -to break several loop. - -********************************************************* -* * - HsSigWcType (i.e with wildcards) -* * -********************************************************* --} - -data HsSigWcTypeScoping = AlwaysBind - -- ^ Always bind any free tyvars of the given type, - -- regardless of whether we have a forall at the top - | BindUnlessForall - -- ^ Unless there's forall at the top, do the same - -- thing as 'AlwaysBind' - | NeverBind - -- ^ Never bind any free tyvars - -rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs - -> RnM (LHsSigWcType GhcRn, FreeVars) -rnHsSigWcType scoping doc sig_ty - = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' -> - return (sig_ty', emptyFVs) - -rnHsSigWcTypeScoped :: HsSigWcTypeScoping - -- AlwaysBind: for pattern type sigs and rules we /do/ want - -- to bring those type variables into scope, even - -- if there's a forall at the top which usually - -- stops that happening - -- e.g \ (x :: forall a. a-> b) -> e - -- Here we do bring 'b' into scope - -> HsDocContext -> LHsSigWcType GhcPs - -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- Used for --- - Signatures on binders in a RULE --- - Pattern type signatures --- Wildcards are allowed --- type signatures on binders only allowed with ScopedTypeVariables -rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside - = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables - ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) - ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside - } - -rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs - -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- rn_hs_sig_wc_type is used for source-language type signatures -rn_hs_sig_wc_type scoping ctxt - (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) - thing_inside - = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty - ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars - ; let nwc_rdrs = nubL nwc_rdrs' - bind_free_tvs = case scoping of - AlwaysBind -> True - BindUnlessForall -> not (isLHsForAllTy hs_ty) - NeverBind -> False - ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars -> - do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' } - ib_ty' = HsIB { hsib_ext = vars - , hsib_body = hs_ty' } - ; (res, fvs2) <- thing_inside sig_ty' - ; return (res, fvs1 `plusFV` fvs2) } } -rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _ - = noExtCon nec -rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _ - = noExtCon nec - -rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) -rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) - = do { free_vars <- extractFilteredRdrTyVars hs_ty - ; (nwc_rdrs, _) <- partition_nwcs free_vars - ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } - ; return (sig_ty', fvs) } -rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec - -rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs - -> RnM ([Name], LHsType GhcRn, FreeVars) -rnWcBody ctxt nwc_rdrs hs_ty - = do { nwcs <- mapM newLocalBndrRn nwc_rdrs - ; let env = RTKE { rtke_level = TypeLevel - , rtke_what = RnTypeBody - , rtke_nwcs = mkNameSet nwcs - , rtke_ctxt = ctxt } - ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ - rn_lty env hs_ty - ; return (nwcs, hs_ty', fvs) } - where - rn_lty env (dL->L loc hs_ty) - = setSrcSpan loc $ - do { (hs_ty', fvs) <- rn_ty env hs_ty - ; return (cL loc hs_ty', fvs) } - - rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) - -- A lot of faff just to allow the extra-constraints wildcard to appear - rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs - , hst_body = hs_body }) - = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> - do { (hs_body', fvs) <- rn_lty env hs_body - ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs', hst_body = hs_body' } - , fvs) } - - rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt - , hst_body = hs_ty }) - | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last - = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 - ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 - ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)] - ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' } - , fvs1 `plusFV` fvs2) } - - | otherwise - = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt - ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt' - , hst_body = hs_ty' } - , fvs1 `plusFV` fvs2) } - - rn_ty env hs_ty = rnHsTyKi env hs_ty - - rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) - - -checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM () --- Rename the extra-constraint spot in a type signature --- (blah, _) => type --- Check that extra-constraints are allowed at all, and --- if so that it's an anonymous wildcard -checkExtraConstraintWildCard env hs_ctxt - = checkWildCard env mb_bad - where - mb_bad | not (extraConstraintWildCardsAllowed env) - = Just base_msg - -- Currently, we do not allow wildcards in their full glory in - -- standalone deriving declarations. We only allow a single - -- extra-constraints wildcard à la: - -- - -- deriving instance _ => Eq (Foo a) - -- - -- i.e., we don't support things like - -- - -- deriving instance (Eq a, _) => Eq (Foo a) - | DerivDeclCtx {} <- rtke_ctxt env - , not (null hs_ctxt) - = Just deriv_decl_msg - | otherwise - = Nothing - - base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard - <+> text "not allowed" - - deriv_decl_msg - = hang base_msg - 2 (vcat [ text "except as the sole constraint" - , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]) - -extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool -extraConstraintWildCardsAllowed env - = case rtke_ctxt env of - TypeSigCtx {} -> True - ExprWithTySigCtx {} -> True - DerivDeclCtx {} -> True - StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls - _ -> False - --- | Finds free type and kind variables in a type, --- without duplicates, and --- without variables that are already in scope in LocalRdrEnv --- NB: this includes named wildcards, which look like perfectly --- ordinary type variables at this point -extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups -extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty) - --- | Finds free type and kind variables in a type, --- with duplicates, but --- without variables that are already in scope in LocalRdrEnv --- NB: this includes named wildcards, which look like perfectly --- ordinary type variables at this point -extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups -extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty) - --- | When the NamedWildCards extension is enabled, partition_nwcs --- removes type variables that start with an underscore from the --- FreeKiTyVars in the argument and returns them in a separate list. --- When the extension is disabled, the function returns the argument --- and empty list. See Note [Renaming named wild cards] -partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars) -partition_nwcs free_vars - = do { wildcards_enabled <- xoptM LangExt.NamedWildCards - ; return $ - if wildcards_enabled - then partition is_wildcard free_vars - else ([], free_vars) } - where - is_wildcard :: Located RdrName -> Bool - is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) - -{- Note [Renaming named wild cards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Identifiers starting with an underscore are always parsed as type variables. -It is only here in the renamer that we give the special treatment. -See Note [The wildcard story for types] in GHC.Hs.Types. - -It's easy! When we collect the implicitly bound type variables, ready -to bring them into scope, and NamedWildCards is on, we partition the -variables into the ones that start with an underscore (the named -wildcards) and the rest. Then we just add them to the hswc_wcs field -of the HsWildCardBndrs structure, and we are done. - - -********************************************************* -* * - HsSigtype (i.e. no wildcards) -* * -****************************************************** -} - -rnHsSigType :: HsDocContext - -> TypeOrKind - -> LHsSigType GhcPs - -> RnM (LHsSigType GhcRn, FreeVars) --- Used for source-language type signatures --- that cannot have wildcards -rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) - = do { traceRn "rnHsSigType" (ppr hs_ty) - ; vars <- extractFilteredRdrTyVarsDups hs_ty - ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars -> - do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty - - ; return ( HsIB { hsib_ext = vars - , hsib_body = body' } - , fvs ) } } -rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec - -rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables - -- E.g. f :: forall a. a->b - -- we do not want to bring 'b' into scope, hence False - -- But f :: a -> b - -- we want to bring both 'a' and 'b' into scope - -> FreeKiTyVarsWithDups - -- Free vars of hs_ty (excluding wildcards) - -- May have duplicates, which is - -- checked here - -> ([Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnImplicitBndrs bind_free_tvs - fvs_with_dups - thing_inside - = do { let fvs = nubL fvs_with_dups - real_fvs | bind_free_tvs = fvs - | otherwise = [] - - ; traceRn "rnImplicitBndrs" $ - vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] - - ; loc <- getSrcSpanM - ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs - - ; bindLocalNamesFV vars $ - thing_inside vars } - -{- ****************************************************** -* * - LHsType and HsType -* * -****************************************************** -} - -{- -rnHsType is here because we call it from loadInstDecl, and I didn't -want a gratuitous knot. - -Note [Context quantification] ------------------------------ -Variables in type signatures are implicitly quantified -when (1) they are in a type signature not beginning -with "forall" or (2) in any qualified type T => R. -We are phasing out (2) since it leads to inconsistencies -(#4426): - -data A = A (a -> a) is an error -data A = A (Eq a => a -> a) binds "a" -data A = A (Eq a => a -> b) binds "a" and "b" -data A = A (() => a -> b) binds "a" and "b" -f :: forall a. a -> b is an error -f :: forall a. () => a -> b is an error -f :: forall a. a -> (() => b) binds "a" and "b" - -This situation is now considered to be an error. See rnHsTyKi for case -HsForAllTy Qualified. - -Note [QualTy in kinds] -~~~~~~~~~~~~~~~~~~~~~~ -I was wondering whether QualTy could occur only at TypeLevel. But no, -we can have a qualified type in a kind too. Here is an example: - - type family F a where - F Bool = Nat - F Nat = Type - - type family G a where - G Type = Type -> Type - G () = Nat - - data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where - MkX :: X 'True '() - -See that k1 becomes Bool and k2 becomes (), so the equality is -satisfied. If I write MkX :: X 'True 'False, compilation fails with a -suitable message: - - MkX :: X 'True '() - • Couldn't match kind ‘G Bool’ with ‘Nat’ - Expected kind: G Bool - Actual kind: F Bool - -However: in a kind, the constraints in the QualTy must all be -equalities; or at least, any kinds with a class constraint are -uninhabited. --} - -data RnTyKiEnv - = RTKE { rtke_ctxt :: HsDocContext - , rtke_level :: TypeOrKind -- Am I renaming a type or a kind? - , rtke_what :: RnTyKiWhat -- And within that what am I renaming? - , rtke_nwcs :: NameSet -- These are the in-scope named wildcards - } - -data RnTyKiWhat = RnTypeBody - | RnTopConstraint -- Top-level context of HsSigWcTypes - | RnConstraint -- All other constraints - -instance Outputable RnTyKiEnv where - ppr (RTKE { rtke_level = lev, rtke_what = what - , rtke_nwcs = wcs, rtke_ctxt = ctxt }) - = text "RTKE" - <+> braces (sep [ ppr lev, ppr what, ppr wcs - , pprHsDocContext ctxt ]) - -instance Outputable RnTyKiWhat where - ppr RnTypeBody = text "RnTypeBody" - ppr RnTopConstraint = text "RnTopConstraint" - ppr RnConstraint = text "RnConstraint" - -mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv -mkTyKiEnv cxt level what - = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet - , rtke_what = what, rtke_ctxt = cxt } - -isRnKindLevel :: RnTyKiEnv -> Bool -isRnKindLevel (RTKE { rtke_level = KindLevel }) = True -isRnKindLevel _ = False - --------------- -rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty - -rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) -rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys - -rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty - -rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) -rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind - -rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) -rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind - --- renaming a type only, not a kind -rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs - -> RnM (LHsTypeArg GhcRn, FreeVars) -rnLHsTypeArg ctxt (HsValArg ty) - = do { (tys_rn, fvs) <- rnLHsType ctxt ty - ; return (HsValArg tys_rn, fvs) } -rnLHsTypeArg ctxt (HsTypeArg l ki) - = do { (kis_rn, fvs) <- rnLHsKind ctxt ki - ; return (HsTypeArg l kis_rn, fvs) } -rnLHsTypeArg _ (HsArgPar sp) - = return (HsArgPar sp, emptyFVs) - -rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs] - -> RnM ([LHsTypeArg GhcRn], FreeVars) -rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args - --------------- -rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs - -> RnM (LHsContext GhcRn, FreeVars) -rnTyKiContext env (dL->L loc cxt) - = do { traceRn "rncontext" (ppr cxt) - ; let env' = env { rtke_what = RnConstraint } - ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt - ; return (cL loc cxt', fvs) } - -rnContext :: HsDocContext -> LHsContext GhcPs - -> RnM (LHsContext GhcRn, FreeVars) -rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta - --------------- -rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsTyKi env (dL->L loc ty) - = setSrcSpan loc $ - do { (ty', fvs) <- rnHsTyKi env ty - ; return (cL loc ty', fvs) } - -rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) - -rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars - , hst_body = tau }) - = do { checkPolyKinds env ty - ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) - Nothing tyvars $ \ tyvars' -> - do { (tau', fvs) <- rnLHsTyKi env tau - ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tyvars' , hst_body = tau' } - , fvs) } } - -rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) - = do { checkPolyKinds env ty -- See Note [QualTy in kinds] - ; (ctxt', fvs1) <- rnTyKiContext env lctxt - ; (tau', fvs2) <- rnLHsTyKi env tau - ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' - , hst_body = tau' } - , fvs1 `plusFV` fvs2) } - -rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) - = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ - unlessXOptM LangExt.PolyKinds $ addErr $ - withHsDocContext (rtke_ctxt env) $ - vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) - , text "Perhaps you intended to use PolyKinds" ] - -- Any type variable at the kind level is illegal without the use - -- of PolyKinds (see #14710) - ; name <- rnTyVar env rdr_name - ; return (HsTyVar noExtField ip (cL loc name), unitFV name) } - -rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) - = setSrcSpan (getLoc l_op) $ - do { (l_op', fvs1) <- rnHsTyOp env ty l_op - ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs2) <- rnLHsTyKi env ty1 - ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2) - (unLoc l_op') fix ty1' ty2' - ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } - -rnHsTyKi env (HsParTy _ ty) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsParTy noExtField ty', fvs) } - -rnHsTyKi env (HsBangTy _ b ty) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsBangTy noExtField b ty', fvs) } - -rnHsTyKi env ty@(HsRecTy _ flds) - = do { let ctxt = rtke_ctxt env - ; fls <- get_fields ctxt - ; (flds', fvs) <- rnConDeclFields ctxt fls flds - ; return (HsRecTy noExtField flds', fvs) } - where - get_fields (ConDeclCtx names) - = concatMapM (lookupConstructorFields . unLoc) names - get_fields _ - = do { addErr (hang (text "Record syntax is illegal here:") - 2 (ppr ty)) - ; return [] } - -rnHsTyKi env (HsFunTy _ ty1 ty2) - = do { (ty1', fvs1) <- rnLHsTyKi env ty1 - -- Might find a for-all as the arg of a function type - ; (ty2', fvs2) <- rnLHsTyKi env ty2 - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a - - -- Check for fixity rearrangements - ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2' - ; return (res_ty, fvs1 `plusFV` fvs2) } - -rnHsTyKi env listTy@(HsListTy _ ty) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env listTy)) - ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsListTy noExtField ty', fvs) } - -rnHsTyKi env t@(HsKindSig _ ty k) - = do { checkPolyKinds env t - ; kind_sigs_ok <- xoptM LangExt.KindSignatures - ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) - ; (ty', lhs_fvs) <- rnLHsTyKi env ty - ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k - ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) } - --- Unboxed tuples are allowed to have poly-typed arguments. These --- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env tupleTy)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsTupleTy noExtField tup_con tys', fvs) } - -rnHsTyKi env sumTy@(HsSumTy _ tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env sumTy)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsSumTy noExtField tys', fvs) } - --- Ensure that a type-level integer is nonnegative (#8306, #8412) -rnHsTyKi env tyLit@(HsTyLit _ t) - = do { data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env tyLit)) - ; when (negLit t) (addErr negLitErr) - ; checkPolyKinds env tyLit - ; return (HsTyLit noExtField t, emptyFVs) } - where - negLit (HsStrTy _ _) = False - negLit (HsNumTy _ i) = i < 0 - negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit - -rnHsTyKi env (HsAppTy _ ty1 ty2) - = do { (ty1', fvs1) <- rnLHsTyKi env ty1 - ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } - -rnHsTyKi env (HsAppKindTy l ty k) - = do { kind_app <- xoptM LangExt.TypeApplications - ; unless kind_app (addErr (typeAppErr "kind" k)) - ; (ty', fvs1) <- rnLHsTyKi env ty - ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k - ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } - -rnHsTyKi env t@(HsIParamTy _ n ty) - = do { notInKinds env t - ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsIParamTy noExtField n ty', fvs) } - -rnHsTyKi _ (HsStarTy _ isUni) - = return (HsStarTy noExtField isUni, emptyFVs) - -rnHsTyKi _ (HsSpliceTy _ sp) - = rnSpliceType sp - -rnHsTyKi env (HsDocTy _ ty haddock_doc) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; haddock_doc' <- rnLHsDoc haddock_doc - ; return (HsDocTy noExtField ty' haddock_doc', fvs) } - -rnHsTyKi _ (XHsType (NHsCoreTy ty)) - = return (XHsType (NHsCoreTy ty), emptyFVs) - -- The emptyFVs probably isn't quite right - -- but I don't think it matters - -rnHsTyKi env ty@(HsExplicitListTy _ ip tys) - = do { checkPolyKinds env ty - ; data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitListTy noExtField ip tys', fvs) } - -rnHsTyKi env ty@(HsExplicitTupleTy _ tys) - = do { checkPolyKinds env ty - ; data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitTupleTy noExtField tys', fvs) } - -rnHsTyKi env (HsWildCardTy _) - = do { checkAnonWildCard env - ; return (HsWildCardTy noExtField, emptyFVs) } - --------------- -rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name -rnTyVar env rdr_name - = do { name <- lookupTypeOccRn rdr_name - ; checkNamedWildCard env name - ; return name } - -rnLTyVar :: Located RdrName -> RnM (Located Name) --- Called externally; does not deal with wildards -rnLTyVar (dL->L loc rdr_name) - = do { tyvar <- lookupTypeOccRn rdr_name - ; return (cL loc tyvar) } - --------------- -rnHsTyOp :: Outputable a - => RnTyKiEnv -> a -> Located RdrName - -> RnM (Located Name, FreeVars) -rnHsTyOp env overall_ty (dL->L loc op) - = do { ops_ok <- xoptM LangExt.TypeOperators - ; op' <- rnTyVar env op - ; unless (ops_ok || op' `hasKey` eqTyConKey) $ - addErr (opTyErr op overall_ty) - ; let l_op' = cL loc op' - ; return (l_op', unitFV op') } - --------------- -notAllowed :: SDoc -> SDoc -notAllowed doc - = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") - -checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () -checkWildCard env (Just doc) - = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] -checkWildCard _ Nothing - = return () - -checkAnonWildCard :: RnTyKiEnv -> RnM () --- Report an error if an anonymous wildcard is illegal here -checkAnonWildCard env - = checkWildCard env mb_bad - where - mb_bad :: Maybe SDoc - mb_bad | not (wildCardsAllowed env) - = Just (notAllowed pprAnonWildCard) - | otherwise - = case rtke_what env of - RnTypeBody -> Nothing - RnTopConstraint -> Just constraint_msg - RnConstraint -> Just constraint_msg - - constraint_msg = hang - (notAllowed pprAnonWildCard <+> text "in a constraint") - 2 hint_msg - hint_msg = vcat [ text "except as the last top-level constraint of a type signature" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] - -checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () --- Report an error if a named wildcard is illegal here -checkNamedWildCard env name - = checkWildCard env mb_bad - where - mb_bad | not (name `elemNameSet` rtke_nwcs env) - = Nothing -- Not a wildcard - | not (wildCardsAllowed env) - = Just (notAllowed (ppr name)) - | otherwise - = case rtke_what env of - RnTypeBody -> Nothing -- Allowed - RnTopConstraint -> Nothing -- Allowed; e.g. - -- f :: (Eq _a) => _a -> Int - -- g :: (_a, _b) => T _a _b -> Int - -- The named tyvars get filled in from elsewhere - RnConstraint -> Just constraint_msg - constraint_msg = notAllowed (ppr name) <+> text "in a constraint" - -wildCardsAllowed :: RnTyKiEnv -> Bool --- ^ In what contexts are wildcards permitted -wildCardsAllowed env - = case rtke_ctxt env of - TypeSigCtx {} -> True - TypBrCtx {} -> True -- Template Haskell quoted type - SpliceTypeCtx {} -> True -- Result of a Template Haskell splice - ExprWithTySigCtx {} -> True - PatCtx {} -> True - RuleCtx {} -> True - FamPatCtx {} -> True -- Not named wildcards though - GHCiCtx {} -> True - HsTypeCtx {} -> True - StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls - _ -> False - - - ---------------- --- | Ensures either that we're in a type or that -XPolyKinds is set -checkPolyKinds :: Outputable ty - => RnTyKiEnv - -> ty -- ^ type - -> RnM () -checkPolyKinds env ty - | isRnKindLevel env - = do { polykinds <- xoptM LangExt.PolyKinds - ; unless polykinds $ - addErr (text "Illegal kind:" <+> ppr ty $$ - text "Did you mean to enable PolyKinds?") } -checkPolyKinds _ _ = return () - -notInKinds :: Outputable ty - => RnTyKiEnv - -> ty - -> RnM () -notInKinds env ty - | isRnKindLevel env - = addErr (text "Illegal kind:" <+> ppr ty) -notInKinds _ _ = return () - -{- ***************************************************** -* * - Binding type variables -* * -***************************************************** -} - -bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) --- Used just before renaming the defn of a function --- with a separate type signature, to bring its tyvars into scope --- With no -XScopedTypeVariables, this is a no-op -bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } - --- | Simply bring a bunch of RdrNames into scope. No checking for --- validity, at all. The binding location is taken from the location --- on each name. -bindLRdrNames :: [Located RdrName] - -> ([Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindLRdrNames rdrs thing_inside - = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs - ; bindLocalNamesFV var_names $ - thing_inside var_names } - ---------------- -bindHsQTyVars :: forall a b. - HsDocContext - -> Maybe SDoc -- Just d => check for unused tvs - -- d is a phrase like "in the type ..." - -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Kind variables from scope, no dups - -> (LHsQTyVars GhcPs) - -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)) - -- The Bool is True <=> all kind variables used in the - -- kind signature are bound on the left. Reason: - -- the last clause of Note [CUSKs: Complete user-supplied - -- kind signatures] in GHC.Hs.Decls - -> RnM (b, FreeVars) - --- See Note [bindHsQTyVars examples] --- (a) Bring kind variables into scope --- both (i) passed in body_kv_occs --- and (ii) mentioned in the kinds of hsq_bndrs --- (b) Bring type variables into scope --- -bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside - = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs - bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs - - ; let -- See Note [bindHsQTyVars examples] for what - -- all these various things are doing - bndrs, kv_occs, implicit_kvs :: [Located RdrName] - bndrs = map hsLTyVarLocName hs_tv_bndrs - kv_occs = nubL (bndr_kv_occs ++ body_kv_occs) - -- Make sure to list the binder kvs before the - -- body kvs, as mandated by - -- Note [Ordering of implicit variables] - implicit_kvs = filter_occs bndrs kv_occs - del = deleteBys eqLocated - all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs) - - ; traceRn "checkMixedVars3" $ - vcat [ text "kv_occs" <+> ppr kv_occs - , text "bndrs" <+> ppr hs_tv_bndrs - , text "bndr_kv_occs" <+> ppr bndr_kv_occs - , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs) - ] - - ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs - - ; bindLocalNamesFV implicit_kv_nms $ - bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs -> - do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) - ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms - , hsq_explicit = rn_bndrs }) - all_bound_on_lhs } } - - where - filter_occs :: [Located RdrName] -- Bound here - -> [Located RdrName] -- Potential implicit binders - -> [Located RdrName] -- Final implicit binders - -- Filter out any potential implicit binders that are either - -- already in scope, or are explicitly bound in the same HsQTyVars - filter_occs bndrs occs - = filterOut is_in_scope occs - where - is_in_scope locc = locc `elemRdr` bndrs - -{- Note [bindHsQTyVars examples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data T k (a::k1) (b::k) :: k2 -> k1 -> * - -Then: - hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables - bndrs = [k,a,b] - - bndr_kv_occs = [k,k1], kind variables free in kind signatures - of hs_tv_bndrs - - body_kv_occs = [k2,k1], kind variables free in the - result kind signature - - implicit_kvs = [k1,k2], kind variables free in kind signatures - of hs_tv_bndrs, and not bound by bndrs - -* We want to quantify add implicit bindings for implicit_kvs - -* If implicit_body_kvs is non-empty, then there is a kind variable - mentioned in the kind signature that is not bound "on the left". - That's one of the rules for a CUSK, so we pass that info on - as the second argument to thing_inside. - -* Order is not important in these lists. All we are doing is - bring Names into scope. - -Finally, you may wonder why filter_occs removes in-scope variables -from bndr/body_kv_occs. How can anything be in scope? Answer: -HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax -ConDecls - data T a = forall (b::k). MkT a b -The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire -ConDecl. Hence the local RdrEnv may be non-empty and we must filter -out 'a' from the free vars. (Mind you, in this situation all the -implicit kind variables are bound at the data type level, so there -are none to bind in the ConDecl, so there are no implicitly bound -variables at all. - -Note [Kind variable scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - data T (a :: k) k = ... -we report "k is out of scope" for (a::k). Reason: k is not brought -into scope until the explicit k-binding that follows. It would be -terribly confusing to bring into scope an /implicit/ k for a's kind -and a distinct, shadowing explicit k that follows, something like - data T {k1} (a :: k1) k = ... - -So the rule is: - - the implicit binders never include any - of the explicit binders in the group - -Note that in the denerate case - data T (a :: a) = blah -we get a complaint the second 'a' is not in scope. - -That applies to foralls too: e.g. - forall (a :: k) k . blah - -But if the foralls are split, we treat the two groups separately: - forall (a :: k). forall k. blah -Here we bring into scope an implicit k, which is later shadowed -by the explicit k. - -In implementation terms - -* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete - the binders {a,k}, and so end with no implicit binders. Then we - rename the binders left-to-right, and hence see that 'k' is out of - scope in the kind of 'a'. - -* Similarly in extract_hs_tv_bndrs - -Note [Variables used as both types and kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We bind the type variables tvs, and kvs is the set of free variables of the -kinds in the scope of the binding. Here is one typical example: - - forall a b. a -> (b::k) -> (c::a) - -Here, tvs will be {a,b}, and kvs {k,a}. - -We must make sure that kvs includes all of variables in the kinds of type -variable bindings. For instance: - - forall k (a :: k). Proxy a - -If we only look in the body of the `forall` type, we will mistakenly conclude -that kvs is {}. But in fact, the type variable `k` is also used as a kind -variable in (a :: k), later in the binding. (This mistake lead to #14710.) -So tvs is {k,a} and kvs is {k}. - -NB: we do this only at the binding site of 'tvs'. --} - -bindLHsTyVarBndrs :: HsDocContext - -> Maybe SDoc -- Just d => check for unused tvs - -- d is a phrase like "in the type ..." - -> Maybe a -- Just _ => an associated type decl - -> [LHsTyVarBndr GhcPs] -- User-written tyvars - -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside - = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; checkDupRdrNames tv_names_w_loc - ; go tv_bndrs thing_inside } - where - tv_names_w_loc = map hsLTyVarLocName tv_bndrs - - go [] thing_inside = thing_inside [] - go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' -> - do { (res, fvs) <- go bs $ \ bs' -> - thing_inside (b' : bs') - ; warn_unused b' fvs - ; return (res, fvs) } - - warn_unused tv_bndr fvs = case mb_in_doc of - Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs - Nothing -> return () - -bindLHsTyVarBndr :: HsDocContext - -> Maybe a -- associated class - -> LHsTyVarBndr GhcPs - -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (dL->L loc - (UserTyVar x - lrdr@(dL->L lv _))) thing_inside - = do { nm <- newTyVarNameRn mb_assoc lrdr - ; bindLocalNamesFV [nm] $ - thing_inside (cL loc (UserTyVar x (cL lv nm))) } - -bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind)) - thing_inside - = do { sig_ok <- xoptM LangExt.KindSignatures - ; unless sig_ok (badKindSigErr doc kind) - ; (kind', fvs1) <- rnLHsKind doc kind - ; tv_nm <- newTyVarNameRn mb_assoc lrdr - ; (b, fvs2) <- bindLocalNamesFV [tv_nm] - $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind')) - ; return (b, fvs1 `plusFV` fvs2) } - -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec -bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match" - -- due to #15884 - -newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name -newTyVarNameRn mb_assoc (dL->L loc rdr) - = do { rdr_env <- getLocalRdrEnv - ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of - (Just _, Just n) -> return n - -- Use the same Name as the parent class decl - - _ -> newLocalBndrRn (cL loc rdr) } -{- -********************************************************* -* * - ConDeclField -* * -********************************************************* - -When renaming a ConDeclField, we have to find the FieldLabel -associated with each field. But we already have all the FieldLabels -available (since they were brought into scope by -RnNames.getLocalNonValBinders), so we just take the list as an -argument, build a map and look them up. --} - -rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] - -> RnM ([LConDeclField GhcRn], FreeVars) --- Also called from RnSource --- No wildcards can appear in record fields -rnConDeclFields ctxt fls fields - = mapFvRn (rnField fl_env env) fields - where - env = mkTyKiEnv ctxt TypeLevel RnTypeBody - fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] - -rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs - -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc)) - = do { let new_names = map (fmap lookupField) names - ; (new_ty, fvs) <- rnLHsTyKi env ty - ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc) - , fvs) } - where - lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (dL->L lr rdr)) = - FieldOcc (flSelector fl) (cL lr rdr) - where - lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "rnField" $ lookupFsEnv fl_env lbl - lookupField (XFieldOcc nec) = noExtCon nec -rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec -rnField _ _ _ = panic "rnField: Impossible Match" - -- due to #15884 - -{- -************************************************************************ -* * - Fixities and precedence parsing -* * -************************************************************************ - -@mkOpAppRn@ deals with operator fixities. The argument expressions -are assumed to be already correctly arranged. It needs the fixities -recorded in the OpApp nodes, because fixity info applies to the things -the programmer actually wrote, so you can't find it out from the Name. - -Furthermore, the second argument is guaranteed not to be another -operator application. Why? Because the parser parses all -operator applications left-associatively, EXCEPT negation, which -we need to handle specially. -Infix types are read in a *right-associative* way, so that - a `op` b `op` c -is always read in as - a `op` (b `op` c) - -mkHsOpTyRn rearranges where necessary. The two arguments -have already been renamed and rearranged. It's made rather tiresome -by the presence of ->, which is a separate syntactic construct. --} - ---------------- --- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) - -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn - -> RnM (HsType GhcRn) - -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22)) - = do { fix2 <- lookupTyFixityRn op2 - ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy noExtField t1 op2 t2) - (unLoc op2) fix2 ty21 ty22 loc2 } - -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22)) - = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 - -mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment - = return (mk1 ty1 ty2) - ---------------- -mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) - -> Name -> Fixity -> LHsType GhcRn - -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) - -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan - -> RnM (HsType GhcRn) -mk_hs_op_ty mk1 op1 fix1 ty1 - mk2 op2 fix2 ty21 ty22 loc2 - | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) - ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) } - | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) - | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) - new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 - ; return (mk2 (noLoc new_ty) ty22) } - where - (nofix_error, associate_right) = compareFixity fix1 fix2 - - ---------------------------- -mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged - -> LHsExpr GhcRn -> Fixity -- Operator and fixity - -> LHsExpr GhcRn -- Right operand (not an OpApp, but might - -- be a NegApp) - -> RnM (HsExpr GhcRn) - --- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 - | nofix_error - = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (OpApp fix2 e1 op2 e2) - - | associate_right = do - new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp fix1 e11 op1 (cL loc' new_e)) - where - loc'= combineLocs e12 e2 - (nofix_error, associate_right) = compareFixity fix1 fix2 - ---------------------------- --- (- neg_arg) `op` e2 -mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 - | nofix_error - = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) - return (OpApp fix2 e1 op2 e2) - - | associate_right - = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp noExtField (cL loc' new_e) neg_name) - where - loc' = combineLocs neg_arg e2 - (nofix_error, associate_right) = compareFixity negateFixity fix2 - ---------------------------- --- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right - | not associate_right -- We *want* right association - = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) - return (OpApp fix1 e1 op1 e2) - where - (_, associate_right) = compareFixity fix1 negateFixity - ---------------------------- --- Default case -mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT2( right_op_ok fix (unLoc e2), - ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 - ) - return (OpApp fix e1 op e2) - ----------------------------- - --- | Name of an operator in an operator application or section -data OpName = NormalOp Name -- ^ A normal identifier - | NegateOp -- ^ Prefix negation - | UnboundOp UnboundVar -- ^ An unbound indentifier - | RecFldOp (AmbiguousFieldOcc GhcRn) - -- ^ A (possibly ambiguous) record field occurrence - -instance Outputable OpName where - ppr (NormalOp n) = ppr n - ppr NegateOp = ppr negateName - ppr (UnboundOp uv) = ppr uv - ppr (RecFldOp fld) = ppr fld - -get_op :: LHsExpr GhcRn -> OpName --- An unbound name could be either HsVar or HsUnboundVar --- See RnExpr.rnUnboundVar -get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n) -get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) - --- Parser left-associates everything, but --- derived instances may have correctly-associated things to --- in the right operand. So we just check that the right operand is OK -right_op_ok :: Fixity -> HsExpr GhcRn -> Bool -right_op_ok fix1 (OpApp fix2 _ _ _) - = not error_please && associate_right - where - (error_please, associate_right) = compareFixity fix1 fix2 -right_op_ok _ _ - = True - --- Parser initially makes negation bind more tightly than any other operator --- And "deriving" code should respect this (use HsPar if not) -mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) - -> RnM (HsExpr (GhcPass id)) -mkNegAppRn neg_arg neg_name - = ASSERT( not_op_app (unLoc neg_arg) ) - return (NegApp noExtField neg_arg neg_name) - -not_op_app :: HsExpr id -> Bool -not_op_app (OpApp {}) = False -not_op_app _ = True - ---------------------------- -mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged - -> LHsExpr GhcRn -> Fixity -- Operator and fixity - -> LHsCmdTop GhcRn -- Right operand (not an infix) - -> RnM (HsCmd GhcRn) - --- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(dL->L loc - (HsCmdTop _ - (dL->L _ (HsCmdArrForm x op1 f (Just fix1) - [a11,a12])))) - op2 fix2 a2 - | nofix_error - = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsCmdArrForm x op2 f (Just fix2) [a1, a2]) - - | associate_right - = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsCmdArrForm noExtField op1 f (Just fix1) - [a11, cL loc (HsCmdTop [] (cL loc new_c))]) - -- TODO: locs are wrong - where - (nofix_error, associate_right) = compareFixity fix1 fix2 - --- Default case -mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2]) - - --------------------------------------- -mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn - -> RnM (Pat GhcRn) - -mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = do { fix1 <- lookupFixityRn (unLoc op1) - ; let (nofix_error, associate_right) = compareFixity fix1 fix2 - - ; if nofix_error then do - { precParseErr (NormalOp (unLoc op1),fix1) - (NormalOp (unLoc op2),fix2) - ; return (ConPatIn op2 (InfixCon p1 p2)) } - - else if associate_right then do - { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) } - -- XXX loc right? - else return (ConPatIn op2 (InfixCon p1 p2)) } - -mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment - = ASSERT( not_op_pat (unLoc p2) ) - return (ConPatIn op (InfixCon p1 p2)) - -not_op_pat :: Pat GhcRn -> Bool -not_op_pat (ConPatIn _ (InfixCon _ _)) = False -not_op_pat _ = True - --------------------------------------- -checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () - -- Check precedence of a function binding written infix - -- eg a `op` b `C` c = ... - -- See comments with rnExpr (OpApp ...) about "deriving" - -checkPrecMatch op (MG { mg_alts = (dL->L _ ms) }) - = mapM_ check ms - where - check (dL->L _ (Match { m_pats = (dL->L l1 p1) - : (dL->L l2 p2) - : _ })) - = setSrcSpan (combineSrcSpans l1 l2) $ - do checkPrec op p1 False - checkPrec op p2 True - - check _ = return () - -- This can happen. Consider - -- a `op` True = ... - -- op = ... - -- The infix flag comes from the first binding of the group - -- but the second eqn has no args (an error, but not discovered - -- until the type checker). So we don't want to crash on the - -- second eqn. -checkPrecMatch _ (XMatchGroup nec) = noExtCon nec - -checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do - op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op - op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) - let - inf_ok = op1_prec > op_prec || - (op1_prec == op_prec && - (op1_dir == InfixR && op_dir == InfixR && right || - op1_dir == InfixL && op_dir == InfixL && not right)) - - info = (NormalOp op, op_fix) - info1 = (NormalOp (unLoc op1), op1_fix) - (infol, infor) = if right then (info, info1) else (info1, info) - unless inf_ok (precParseErr infol infor) - -checkPrec _ _ _ - = return () - --- Check precedence of (arg op) or (op arg) respectively --- If arg is itself an operator application, then either --- (a) its precedence must be higher than that of op --- (b) its precedency & associativity must be the same as that of op -checkSectionPrec :: FixityDirection -> HsExpr GhcPs - -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () -checkSectionPrec direction section op arg - = case unLoc arg of - OpApp fix _ op' _ -> go_for_it (get_op op') fix - NegApp _ _ _ -> go_for_it NegateOp negateFixity - _ -> return () - where - op_name = get_op op - go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do - op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name - unless (op_prec < arg_prec - || (op_prec == arg_prec && direction == assoc)) - (sectionPrecErr (get_op op, op_fix) - (arg_op, arg_fix) section) - --- | Look up the fixity for an operator name. Be careful to use --- 'lookupFieldFixityRn' for (possibly ambiguous) record fields --- (see #13132). -lookupFixityOp :: OpName -> RnM Fixity -lookupFixityOp (NormalOp n) = lookupFixityRn n -lookupFixityOp NegateOp = lookupFixityRn negateName -lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u)) -lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f - - --- Precedence-related error messages - -precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () -precParseErr op1@(n1,_) op2@(n2,_) - | is_unbound n1 || is_unbound n2 - = return () -- Avoid error cascade - | otherwise - = addErr $ hang (text "Precedence parsing error") - 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), - ppr_opfix op2, - text "in the same infix expression"]) - -sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () -sectionPrecErr op@(n1,_) arg_op@(n2,_) section - | is_unbound n1 || is_unbound n2 - = return () -- Avoid error cascade - | otherwise - = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"), - nest 4 (sep [text "must have lower precedence than that of the operand,", - nest 2 (text "namely" <+> ppr_opfix arg_op)]), - nest 4 (text "in the section:" <+> quotes (ppr section))] - -is_unbound :: OpName -> Bool -is_unbound (NormalOp n) = isUnboundName n -is_unbound UnboundOp{} = True -is_unbound _ = False - -ppr_opfix :: (OpName, Fixity) -> SDoc -ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) - where - pp_op | NegateOp <- op = text "prefix `-'" - | otherwise = quotes (ppr op) - - -{- ***************************************************** -* * - Errors -* * -***************************************************** -} - -unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc -unexpectedTypeSigErr ty - = hang (text "Illegal type signature:" <+> quotes (ppr ty)) - 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") - -badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () -badKindSigErr doc (dL->L loc ty) - = setSrcSpan loc $ addErr $ - withHsDocContext doc $ - hang (text "Illegal kind signature:" <+> quotes (ppr ty)) - 2 (text "Perhaps you intended to use KindSignatures") - -dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc -dataKindsErr env thing - = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) - 2 (text "Perhaps you intended to use DataKinds") - where - pp_what | isRnKindLevel env = text "kind" - | otherwise = text "type" - -inTypeDoc :: HsType GhcPs -> SDoc -inTypeDoc ty = text "In the type" <+> quotes (ppr ty) - -warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () -warnUnusedForAll in_doc (dL->L loc tv) used_names - = whenWOptM Opt_WarnUnusedForalls $ - unless (hsTyVarName tv `elemNameSet` used_names) $ - addWarnAt (Reason Opt_WarnUnusedForalls) loc $ - vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) - , in_doc ] - -opTyErr :: Outputable a => RdrName -> a -> SDoc -opTyErr op overall_ty - = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) - 2 (text "Use TypeOperators to allow operators in types") - -{- -************************************************************************ -* * - Finding the free type variables of a (HsType RdrName) -* * -************************************************************************ - - -Note [Kind and type-variable binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type signature we may implicitly bind type/kind variables. For example: - * f :: a -> a - f = ... - Here we need to find the free type variables of (a -> a), - so that we know what to quantify - - * class C (a :: k) where ... - This binds 'k' in ..., as well as 'a' - - * f (x :: a -> [a]) = .... - Here we bind 'a' in .... - - * f (x :: T a -> T (b :: k)) = ... - Here we bind both 'a' and the kind variable 'k' - - * type instance F (T (a :: Maybe k)) = ...a...k... - Here we want to constrain the kind of 'a', and bind 'k'. - -To do that, we need to walk over a type and find its free type/kind variables. -We preserve the left-to-right order of each variable occurrence. -See Note [Ordering of implicit variables]. - -Clients of this code can remove duplicates with nubL. - -Note [Ordering of implicit variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the advent of -XTypeApplications, GHC makes promises about the ordering -of implicit variable quantification. Specifically, we offer that implicitly -quantified variables (such as those in const :: a -> b -> a, without a `forall`) -will occur in left-to-right order of first occurrence. Here are a few examples: - - const :: a -> b -> a -- forall a b. ... - f :: Eq a => b -> a -> a -- forall a b. ... contexts are included - - type a <-< b = b -> a - g :: a <-< b -- forall a b. ... type synonyms matter - - class Functor f where - fmap :: (a -> b) -> f a -> f b -- forall f a b. ... - -- The f is quantified by the class, so only a and b are considered in fmap - -This simple story is complicated by the possibility of dependency: all variables -must come after any variables mentioned in their kinds. - - typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... - -The k comes first because a depends on k, even though the k appears later than -the a in the code. Thus, GHC does ScopedSort on the variables. -See Note [ScopedSort] in Type. - -Implicitly bound variables are collected by any function which returns a -FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably -includes the `extract-` family of functions (extractHsTysRdrTyVarsDups, -extractHsTyVarBndrsKVs, etc.). -These functions thus promise to keep left-to-right ordering. - -Note [Implicit quantification in type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We typically bind type/kind variables implicitly when they are in a kind -annotation on the LHS, for example: - - data Proxy (a :: k) = Proxy - type KindOf (a :: k) = k - -Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and -we want to implicitly quantify over it. This is easy: just extract all free -variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs - -By contrast, on the RHS we can't simply collect *all* free variables. Which of -the following are allowed? - - type TySyn1 = a :: Type - type TySyn2 = 'Nothing :: Maybe a - type TySyn3 = 'Just ('Nothing :: Maybe a) - type TySyn4 = 'Left a :: Either Type a - -After some design deliberations (see non-taken alternatives below), the answer -is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now. -We implicitly quantify over free variables of the outermost kind signature, if -one exists: - - * In TySyn1, the outermost kind signature is (:: Type), and it does not have - any free variables. - * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a - free variable 'a', which we implicitly quantify over. - * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature - is hidden inside 'Just. - * In TySyn4, the outermost kind signature is (:: Either Type a), it contains - a free variable 'a', which we implicitly quantify over. That is why we can - also use it to the left of the double colon: 'Left a - -The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type -synonyms and type family instances. - -This is something of a stopgap solution until we can explicitly bind invisible -type/kind variables: - - type TySyn3 :: forall a. Maybe a - type TySyn3 @a = 'Just ('Nothing :: Maybe a) - -Note [Implicit quantification in type synonyms: non-taken alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Alternative I: No quantification --------------------------------- -We could offer no implicit quantification on the RHS, accepting none of the -TySyn examples. The user would have to bind the variables explicitly: - - type TySyn1 a = a :: Type - type TySyn2 a = 'Nothing :: Maybe a - type TySyn3 a = 'Just ('Nothing :: Maybe a) - type TySyn4 a = 'Left a :: Either Type a - -However, this would mean that one would have to specify 'a' at call sites every -time, which could be undesired. - -Alternative II: Indiscriminate quantification ---------------------------------------------- -We could implicitly quantify over all free variables on the RHS just like we do -on the LHS. Then we would infer the following kinds: - - TySyn1 :: forall {a}. Type - TySyn2 :: forall {a}. Maybe a - TySyn3 :: forall {a}. Maybe (Maybe a) - TySyn4 :: forall {a}. Either Type a - -This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable -is free-floating, not fixed by anything. - -Alternative III: reportFloatingKvs ----------------------------------- -We could augment Alternative II by hunting down free-floating variables during -type checking. While viable, this would mean we'd end up accepting this: - - data Prox k (a :: k) - type T = Prox k - --} - --- See Note [Kind and type-variable binders] --- These lists are guaranteed to preserve left-to-right ordering of --- the types the variables were extracted from. See also --- Note [Ordering of implicit variables]. -type FreeKiTyVars = [Located RdrName] - --- | A 'FreeKiTyVars' list that is allowed to have duplicate variables. -type FreeKiTyVarsWithDups = FreeKiTyVars - --- | A 'FreeKiTyVars' list that contains no duplicate variables. -type FreeKiTyVarsNoDups = FreeKiTyVars - -filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) - -filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars -filterInScopeM vars - = do { rdr_env <- getLocalRdrEnv - ; return (filterInScope rdr_env vars) } - -inScope :: LocalRdrEnv -> RdrName -> Bool -inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env - -extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_tyarg (HsValArg ty) acc = extract_lty ty acc -extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc -extract_tyarg (HsArgPar _) acc = acc - -extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_tyargs args acc = foldr extract_tyarg acc args - -extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -extractHsTyArgRdrKiTyVarsDup args - = extract_tyargs args [] - --- | 'extractHsTyRdrTyVars' finds the type/kind variables --- of a HsType/HsKind. --- It's used when making the @forall@s explicit. --- When the same name occurs multiple times in the types, only the first --- occurrence is returned. --- See Note [Kind and type-variable binders] -extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups -extractHsTyRdrTyVars ty - = nubL (extractHsTyRdrTyVarsDups ty) - --- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables --- of a HsType/HsKind. --- It's used when making the @forall@s explicit. --- When the same name occurs multiple times in the types, all occurrences --- are returned. -extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups -extractHsTyRdrTyVarsDups ty - = extract_lty ty [] - --- | Extracts the free type/kind variables from the kind signature of a HsType. --- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. --- When the same name occurs multiple times in the type, only the first --- occurrence is returned, and the left-to-right order of variables is --- preserved. --- See Note [Kind and type-variable binders] and --- Note [Ordering of implicit variables] and --- Note [Implicit quantification in type synonyms]. -extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups -extractHsTyRdrTyVarsKindVars (unLoc -> ty) = - case ty of - HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty - HsKindSig _ _ ki -> extractHsTyRdrTyVars ki - _ -> [] - --- | Extracts free type and kind variables from types in a list. --- When the same name occurs multiple times in the types, all occurrences --- are returned. -extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups -extractHsTysRdrTyVarsDups tys - = extract_ltys tys [] - --- Returns the free kind variables of any explictly-kinded binders, returning --- variable occurrences in left-to-right order. --- See Note [Ordering of implicit variables]. --- NB: Does /not/ delete the binders themselves. --- However duplicates are removed --- E.g. given [k1, a:k1, b:k2] --- the function returns [k1,k2], even though k1 is bound here -extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups -extractHsTyVarBndrsKVs tv_bndrs - = nubL (extract_hs_tv_bndrs_kvs tv_bndrs) - --- Returns the free kind variables in a type family result signature, returning --- variable occurrences in left-to-right order. --- See Note [Ordering of implicit variables]. -extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -extractRdrKindSigVars (dL->L _ resultSig) - | KindSig _ k <- resultSig = extractHsTyRdrTyVars k - | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k - | otherwise = [] - --- Get type/kind variables mentioned in the kind signature, preserving --- left-to-right order and without duplicates: --- --- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1] --- * data T a (b :: k1) -- result: [] --- --- See Note [Ordering of implicit variables]. -extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups -extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) - = maybe [] extractHsTyRdrTyVars ksig -extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec - -extract_lctxt :: LHsContext GhcPs - -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lctxt ctxt = extract_ltys (unLoc ctxt) - -extract_ltys :: [LHsType GhcPs] - -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_ltys tys acc = foldr extract_lty acc tys - -extract_lty :: LHsType GhcPs - -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lty (dL->L _ ty) acc - = case ty of - HsTyVar _ _ ltv -> extract_tv ltv acc - HsBangTy _ _ ty -> extract_lty ty acc - HsRecTy _ flds -> foldr (extract_lty - . cd_fld_type . unLoc) acc - flds - HsAppTy _ ty1 ty2 -> extract_lty ty1 $ - extract_lty ty2 acc - HsAppKindTy _ ty k -> extract_lty ty $ - extract_lty k acc - HsListTy _ ty -> extract_lty ty acc - HsTupleTy _ _ tys -> extract_ltys tys acc - HsSumTy _ tys -> extract_ltys tys acc - HsFunTy _ ty1 ty2 -> extract_lty ty1 $ - extract_lty ty2 acc - HsIParamTy _ _ ty -> extract_lty ty acc - HsOpTy _ ty1 tv ty2 -> extract_tv tv $ - extract_lty ty1 $ - extract_lty ty2 acc - HsParTy _ ty -> extract_lty ty acc - HsSpliceTy {} -> acc -- Type splices mention no tvs - HsDocTy _ ty _ -> extract_lty ty acc - HsExplicitListTy _ _ tys -> extract_ltys tys acc - HsExplicitTupleTy _ tys -> extract_ltys tys acc - HsTyLit _ _ -> acc - HsStarTy _ _ -> acc - HsKindSig _ ty ki -> extract_lty ty $ - extract_lty ki acc - HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc $ - extract_lty ty [] - HsQualTy { hst_ctxt = ctxt, hst_body = ty } - -> extract_lctxt ctxt $ - extract_lty ty acc - XHsType {} -> acc - -- We deal with these separately in rnLHsTypeWithWildCards - HsWildCardTy {} -> acc - -extractHsTvBndrs :: [LHsTyVarBndr GhcPs] - -> FreeKiTyVarsWithDups -- Free in body - -> FreeKiTyVarsWithDups -- Free in result -extractHsTvBndrs tv_bndrs body_fvs - = extract_hs_tv_bndrs tv_bndrs [] body_fvs - -extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] - -> FreeKiTyVarsWithDups -- Accumulator - -> FreeKiTyVarsWithDups -- Free in body - -> FreeKiTyVarsWithDups --- In (forall (a :: Maybe e). a -> b) we have --- 'a' is bound by the forall --- 'b' is a free type variable --- 'e' is a free kind variable -extract_hs_tv_bndrs tv_bndrs acc_vars body_vars - | null tv_bndrs = body_vars ++ acc_vars - | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars - -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars. - -- See Note [Kind variable scoping] - where - bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs - tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs - -extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] --- Returns the free kind variables of any explictly-kinded binders, returning --- variable occurrences in left-to-right order. --- See Note [Ordering of implicit variables]. --- NB: Does /not/ delete the binders themselves. --- Duplicates are /not/ removed --- E.g. given [k1, a:k1, b:k2] --- the function returns [k1,k2], even though k1 is bound here -extract_hs_tv_bndrs_kvs tv_bndrs = - foldr extract_lty [] - [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs] - -extract_tv :: Located RdrName - -> [Located RdrName] -> [Located RdrName] -extract_tv tv acc = - if isRdrTyVar (unLoc tv) then tv:acc else acc - --- Deletes duplicates in a list of Located things. --- --- Importantly, this function is stable with respect to the original ordering --- of things in the list. This is important, as it is a property that GHC --- relies on to maintain the left-to-right ordering of implicitly quantified --- type variables. --- See Note [Ordering of implicit variables]. -nubL :: Eq a => [Located a] -> [Located a] -nubL = nubBy eqLocated - -elemRdr :: Located RdrName -> [Located RdrName] -> Bool -elemRdr x = any (eqLocated x) diff --git a/rename/RnUnbound.hs b/rename/RnUnbound.hs deleted file mode 100644 --- a/rename/RnUnbound.hs +++ /dev/null @@ -1,381 +0,0 @@ -{- - -This module contains helper functions for reporting and creating -unbound variables. - --} -module RnUnbound ( mkUnboundName - , mkUnboundNameRdr - , isUnboundName - , reportUnboundName - , unknownNameSuggestions - , WhereLooking(..) - , unboundName - , unboundNameX - , notInScopeErr ) where - -import GhcPrelude - -import RdrName -import HscTypes -import TcRnMonad -import Name -import Module -import SrcLoc -import Outputable -import PrelNames ( mkUnboundName, isUnboundName, getUnique) -import Util -import Maybes -import DynFlags -import FastString -import Data.List -import Data.Function ( on ) -import UniqDFM (udfmToList) - -{- -************************************************************************ -* * - What to do when a lookup fails -* * -************************************************************************ --} - -data WhereLooking = WL_Any -- Any binding - | WL_Global -- Any top-level binding (local or imported) - | WL_LocalTop -- Any top-level binding in this module - | WL_LocalOnly - -- Only local bindings - -- (pattern synonyms declaractions, - -- see Note [Renaming pattern synonym variables]) - -mkUnboundNameRdr :: RdrName -> Name -mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) - -reportUnboundName :: RdrName -> RnM Name -reportUnboundName rdr = unboundName WL_Any rdr - -unboundName :: WhereLooking -> RdrName -> RnM Name -unboundName wl rdr = unboundNameX wl rdr Outputable.empty - -unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name -unboundNameX where_look rdr_name extra - = do { dflags <- getDynFlags - ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags - err = notInScopeErr rdr_name $$ extra - ; if not show_helpful_errors - then addErr err - else do { local_env <- getLocalRdrEnv - ; global_env <- getGlobalRdrEnv - ; impInfo <- getImports - ; currmod <- getModule - ; hpt <- getHpt - ; let suggestions = unknownNameSuggestions_ where_look - dflags hpt currmod global_env local_env impInfo - rdr_name - ; addErr (err $$ suggestions) } - ; return (mkUnboundNameRdr rdr_name) } - -notInScopeErr :: RdrName -> SDoc -notInScopeErr rdr_name - = hang (text "Not in scope:") - 2 (what <+> quotes (ppr rdr_name)) - where - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - -type HowInScope = Either SrcSpan ImpDeclSpec - -- Left loc => locally bound at loc - -- Right ispec => imported as specified by ispec - - --- | Called from the typechecker (TcErrors) when we find an unbound variable -unknownNameSuggestions :: DynFlags - -> HomePackageTable -> Module - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc -unknownNameSuggestions = unknownNameSuggestions_ WL_Any - -unknownNameSuggestions_ :: WhereLooking -> DynFlags - -> HomePackageTable -> Module - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc -unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env - imports tried_rdr_name = - similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$ - importSuggestions where_look global_env hpt - curr_mod imports tried_rdr_name $$ - extensionSuggestions tried_rdr_name - - -similarNameSuggestions :: WhereLooking -> DynFlags - -> GlobalRdrEnv -> LocalRdrEnv - -> RdrName -> SDoc -similarNameSuggestions where_look dflags global_env - local_env tried_rdr_name - = case suggest of - [] -> Outputable.empty - [p] -> perhaps <+> pp_item p - ps -> sep [ perhaps <+> text "one of these:" - , nest 2 (pprWithCommas pp_item ps) ] - where - all_possibilities :: [(String, (RdrName, HowInScope))] - all_possibilities - = [ (showPpr dflags r, (r, Left loc)) - | (r,loc) <- local_possibilities local_env ] - ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] - - suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities - perhaps = text "Perhaps you meant" - - pp_item :: (RdrName, HowInScope) -> SDoc - pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined - where loc' = case loc of - UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l)) - pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported - parens (text "imported from" <+> ppr (is_mod is)) - - pp_ns :: RdrName -> SDoc - pp_ns rdr | ns /= tried_ns = pprNameSpace ns - | otherwise = Outputable.empty - where ns = rdrNameSpace rdr - - tried_occ = rdrNameOcc tried_rdr_name - tried_is_sym = isSymOcc tried_occ - tried_ns = occNameSpace tried_occ - tried_is_qual = isQual tried_rdr_name - - correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns - && isSymOcc occ == tried_is_sym - -- Treat operator and non-operators as non-matching - -- This heuristic avoids things like - -- Not in scope 'f'; perhaps you meant '+' (from Prelude) - - local_ok = case where_look of { WL_Any -> True - ; WL_LocalOnly -> True - ; _ -> False } - local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] - local_possibilities env - | tried_is_qual = [] - | not local_ok = [] - | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) - | name <- localRdrEnvElts env - , let occ = nameOccName name - , correct_name_space occ] - - global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] - global_possibilities global_env - | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) - | gre <- globalRdrEnvElts global_env - , isGreOk where_look gre - , let name = gre_name gre - occ = nameOccName name - , correct_name_space occ - , (mod, how) <- qualsInScope gre - , let rdr_qual = mkRdrQual mod occ ] - - | otherwise = [ (rdr_unqual, pair) - | gre <- globalRdrEnvElts global_env - , isGreOk where_look gre - , let name = gre_name gre - occ = nameOccName name - rdr_unqual = mkRdrUnqual occ - , correct_name_space occ - , pair <- case (unquals_in_scope gre, quals_only gre) of - (how:_, _) -> [ (rdr_unqual, how) ] - ([], pr:_) -> [ pr ] -- See Note [Only-quals] - ([], []) -> [] ] - - -- Note [Only-quals] - -- The second alternative returns those names with the same - -- OccName as the one we tried, but live in *qualified* imports - -- e.g. if you have: - -- - -- > import qualified Data.Map as Map - -- > foo :: Map - -- - -- then we suggest @Map.Map@. - - -------------------- - unquals_in_scope :: GlobalRdrElt -> [HowInScope] - unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) - | lcl = [ Left (nameSrcSpan n) ] - | otherwise = [ Right ispec - | i <- is, let ispec = is_decl i - , not (is_qual ispec) ] - - - -------------------- - quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] - -- Ones for which *only* the qualified version is in scope - quals_only (GRE { gre_name = n, gre_imp = is }) - = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) - | i <- is, let ispec = is_decl i, is_qual ispec ] - --- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. -importSuggestions :: WhereLooking - -> GlobalRdrEnv - -> HomePackageTable -> Module - -> ImportAvails -> RdrName -> SDoc -importSuggestions where_look global_env hpt currMod imports rdr_name - | WL_LocalOnly <- where_look = Outputable.empty - | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty - | null interesting_imports - , Just name <- mod_name - , show_not_imported_line name - = hsep - [ text "No module named" - , quotes (ppr name) - , text "is imported." - ] - | is_qualified - , null helpful_imports - , [(mod,_)] <- interesting_imports - = hsep - [ text "Module" - , quotes (ppr mod) - , text "does not export" - , quotes (ppr occ_name) <> dot - ] - | is_qualified - , null helpful_imports - , not (null interesting_imports) - , mods <- map fst interesting_imports - = hsep - [ text "Neither" - , quotedListWithNor (map ppr mods) - , text "exports" - , quotes (ppr occ_name) <> dot - ] - | [(mod,imv)] <- helpful_imports_non_hiding - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to the import list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_non_hiding) - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to one of these import lists:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_non_hiding - ]) - | [(mod,imv)] <- helpful_imports_hiding - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the explicit hiding list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_hiding) - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the hiding clauses" - , text "in one of these imports:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_hiding - ]) - | otherwise - = Outputable.empty - where - is_qualified = isQual rdr_name - (mod_name, occ_name) = case rdr_name of - Unqual occ_name -> (Nothing, occ_name) - Qual mod_name occ_name -> (Just mod_name, occ_name) - _ -> error "importSuggestions: dead code" - - - -- What import statements provide "Mod" at all - -- or, if this is an unqualified name, are not qualified imports - interesting_imports = [ (mod, imp) - | (mod, mod_imports) <- moduleEnvToList (imp_mods imports) - , Just imp <- return $ pick (importedByUser mod_imports) - ] - - -- We want to keep only one for each original module; preferably one with an - -- explicit import list (for no particularly good reason) - pick :: [ImportedModsVal] -> Maybe ImportedModsVal - pick = listToMaybe . sortBy (compare `on` prefer) . filter select - where select imv = case mod_name of Just name -> imv_name imv == name - Nothing -> not (imv_qualified imv) - prefer imv = (imv_is_hiding imv, imv_span imv) - - -- Which of these would export a 'foo' - -- (all of these are restricted imports, because if they were not, we - -- wouldn't have an out-of-scope error in the first place) - helpful_imports = filter helpful interesting_imports - where helpful (_,imv) - = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name - - -- Which of these do that because of an explicit hiding list resp. an - -- explicit import list - (helpful_imports_hiding, helpful_imports_non_hiding) - = partition (imv_is_hiding . snd) helpful_imports - - -- See note [When to show/hide the module-not-imported line] - show_not_imported_line :: ModuleName -> Bool -- #15611 - show_not_imported_line modnam - | modnam `elem` globMods = False -- #14225 -- 1 - | moduleName currMod == modnam = False -- 2.1 - | is_last_loaded_mod modnam hpt_uniques = False -- 2.2 - | otherwise = True - where - hpt_uniques = map fst (udfmToList hpt) - is_last_loaded_mod _ [] = False - is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam - globMods = nub [ mod - | gre <- globalRdrEnvElts global_env - , isGreOk where_look gre - , (mod, _) <- qualsInScope gre - ] - -extensionSuggestions :: RdrName -> SDoc -extensionSuggestions rdrName - | rdrName == mkUnqual varName (fsLit "mdo") || - rdrName == mkUnqual varName (fsLit "rec") - = text "Perhaps you meant to use RecursiveDo" - | otherwise = Outputable.empty - -qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] --- Ones for which the qualified version is in scope -qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is } - | lcl = case nameModule_maybe n of - Nothing -> [] - Just m -> [(moduleName m, Left (nameSrcSpan n))] - | otherwise = [ (is_as ispec, Right ispec) - | i <- is, let ispec = is_decl i ] - -isGreOk :: WhereLooking -> GlobalRdrElt -> Bool -isGreOk where_look = case where_look of - WL_LocalTop -> isLocalGRE - WL_LocalOnly -> const False - _ -> const True - -{- Note [When to show/hide the module-not-imported line] -- #15611 -For the error message: - Not in scope X.Y - Module X does not export Y - No module named ‘X’ is imported: -there are 2 cases, where we hide the last "no module is imported" line: -1. If the module X has been imported. -2. If the module X is the current module. There are 2 subcases: - 2.1 If the unknown module name is in a input source file, - then we can use the getModule function to get the current module name. - (See test T15611a) - 2.2 If the unknown module name has been entered by the user in GHCi, - then the getModule function returns something like "interactive:Ghci1", - and we have to check the current module in the last added entry of - the HomePackageTable. (See test T15611b) --} diff --git a/rename/RnUtils.hs b/rename/RnUtils.hs deleted file mode 100644 --- a/rename/RnUtils.hs +++ /dev/null @@ -1,514 +0,0 @@ -{- - -This module contains miscellaneous functions related to renaming. - --} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module RnUtils ( - checkDupRdrNames, checkShadowedRdrNames, - checkDupNames, checkDupAndShadowedNames, dupNamesErr, - checkTupSize, - addFvRn, mapFvRn, mapMaybeFvRn, - warnUnusedMatches, warnUnusedTypePatterns, - warnUnusedTopBinds, warnUnusedLocalBinds, - checkUnusedRecordWildcard, - mkFieldEnv, - unknownSubordinateErr, badQualBndrErr, typeAppErr, - HsDocContext(..), pprHsDocContext, - inHsDocContext, withHsDocContext, - - newLocalBndrRn, newLocalBndrsRn, - - bindLocalNames, bindLocalNamesFV, - - addNameClashErrRn, extendTyVarEnvFVRn - -) - -where - - -import GhcPrelude - -import GHC.Hs -import RdrName -import HscTypes -import TcEnv -import TcRnMonad -import Name -import NameSet -import NameEnv -import DataCon -import SrcLoc -import Outputable -import Util -import BasicTypes ( TopLevelFlag(..) ) -import ListSetOps ( removeDups ) -import DynFlags -import FastString -import Control.Monad -import Data.List -import Constants ( mAX_TUPLE_SIZE ) -import qualified Data.List.NonEmpty as NE -import qualified GHC.LanguageExtensions as LangExt - -{- -********************************************************* -* * -\subsection{Binding} -* * -********************************************************* --} - -newLocalBndrRn :: Located RdrName -> RnM Name --- Used for non-top-level binders. These should --- never be qualified. -newLocalBndrRn (dL->L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = return name -- This happens in code generated by Template Haskell - -- See Note [Binders in Template Haskell] in Convert.hs - | otherwise - = do { unless (isUnqual rdr_name) - (addErrAt loc (badQualBndrErr rdr_name)) - ; uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - -newLocalBndrsRn :: [Located RdrName] -> RnM [Name] -newLocalBndrsRn = mapM newLocalBndrRn - -bindLocalNames :: [Name] -> RnM a -> RnM a -bindLocalNames names enclosed_scope - = do { lcl_env <- getLclEnv - ; let th_level = thLevel (tcl_th_ctxt lcl_env) - th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) - [ (n, (NotTopLevel, th_level)) | n <- names ] - rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names - ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' - , tcl_rdr = rdr_env' }) - enclosed_scope } - -bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -bindLocalNamesFV names enclosed_scope - = do { (result, fvs) <- bindLocalNames names enclosed_scope - ; return (result, delFVs names fvs) } - -------------------------------------- - -extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside - -------------------------------------- -checkDupRdrNames :: [Located RdrName] -> RnM () --- Check for duplicated names in a binding group -checkDupRdrNames rdr_names_w_loc - = mapM_ (dupNamesErr getLoc) dups - where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc - -checkDupNames :: [Name] -> RnM () --- Check for duplicated names in a binding group -checkDupNames names = check_dup_names (filterOut isSystemName names) - -- See Note [Binders in Template Haskell] in Convert - -check_dup_names :: [Name] -> RnM () -check_dup_names names - = mapM_ (dupNamesErr nameSrcSpan) dups - where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names - ---------------------- -checkShadowedRdrNames :: [Located RdrName] -> RnM () -checkShadowedRdrNames loc_rdr_names - = do { envs <- getRdrEnvs - ; checkShadowedOccs envs get_loc_occ filtered_rdrs } - where - filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr) - -checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () -checkDupAndShadowedNames envs names - = do { check_dup_names filtered_names - ; checkShadowedOccs envs get_loc_occ filtered_names } - where - filtered_names = filterOut isSystemName names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ name = (nameSrcSpan name, nameOccName name) - -------------------------------------- -checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) - -> (a -> (SrcSpan, OccName)) - -> [a] -> RnM () -checkShadowedOccs (global_env,local_env) get_loc_occ ns - = whenWOptM Opt_WarnNameShadowing $ - do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) - ; mapM_ check_shadow ns } - where - check_shadow n - | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" - -- See #3262 - | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] - | otherwise = do { gres' <- filterM is_shadowed_gre gres - ; complain (map pprNameProvenance gres') } - where - (loc,occ) = get_loc_occ n - mb_local = lookupLocalRdrOcc local_env occ - gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env - -- Make an Unqualified RdrName and look that up, so that - -- we don't find any GREs that are in scope qualified-only - - complain [] = return () - complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) - loc - (shadowedNameWarn occ pp_locs) - - is_shadowed_gre :: GlobalRdrElt -> RnM Bool - -- Returns False for record selectors that are shadowed, when - -- punning or wild-cards are on (cf #2723) - is_shadowed_gre gre | isRecFldGRE gre - = do { dflags <- getDynFlags - ; return $ not (xopt LangExt.RecordPuns dflags - || xopt LangExt.RecordWildCards dflags) } - is_shadowed_gre _other = return True - - -{- -************************************************************************ -* * -\subsection{Free variable manipulation} -* * -************************************************************************ --} - --- A useful utility -addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) -addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside - ; return (res, fvs1 `plusFV` fvs2) } - -mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) -mapFvRn f xs = do stuff <- mapM f xs - case unzip stuff of - (ys, fvs_s) -> return (ys, plusFVs fvs_s) - -mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) -mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) -mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } - -{- -************************************************************************ -* * -\subsection{Envt utility functions} -* * -************************************************************************ --} - -warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () -warnUnusedTopBinds gres - = whenWOptM Opt_WarnUnusedTopBinds - $ do env <- getGblEnv - let isBoot = tcg_src env == HsBootFile - let noParent gre = case gre_par gre of - NoParent -> True - _ -> False - -- Don't warn about unused bindings with parents in - -- .hs-boot files, as you are sometimes required to give - -- unused bindings (trac #3449). - -- HOWEVER, in a signature file, you are never obligated to put a - -- definition in the main text. Thus, if you define something - -- and forget to export it, we really DO want to warn. - gres' = if isBoot then filter noParent gres - else gres - warnUnusedGREs gres' - - --- | Checks to see if we need to warn for -Wunused-record-wildcards or --- -Wredundant-record-wildcards -checkUnusedRecordWildcard :: SrcSpan - -> FreeVars - -> Maybe [Name] - -> RnM () -checkUnusedRecordWildcard _ _ Nothing = return () -checkUnusedRecordWildcard loc _ (Just []) = do - -- Add a new warning if the .. pattern binds no variables - setSrcSpan loc $ warnRedundantRecordWildcard -checkUnusedRecordWildcard loc fvs (Just dotdot_names) = - setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs - - --- | Produce a warning when the `..` pattern binds no new --- variables. --- --- @ --- data P = P { x :: Int } --- --- foo (P{x, ..}) = x --- @ --- --- The `..` here doesn't bind any variables as `x` is already bound. -warnRedundantRecordWildcard :: RnM () -warnRedundantRecordWildcard = - whenWOptM Opt_WarnRedundantRecordWildcards - (addWarn (Reason Opt_WarnRedundantRecordWildcards) - redundantWildcardWarning) - - --- | Produce a warning when no variables bound by a `..` pattern are used. --- --- @ --- data P = P { x :: Int } --- --- foo (P{..}) = () --- @ --- --- The `..` pattern binds `x` but it is not used in the RHS so we issue --- a warning. -warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM () -warnUnusedRecordWildcard ns used_names = do - let used = filter (`elemNameSet` used_names) ns - traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) - warnIfFlag Opt_WarnUnusedRecordWildcards (null used) - unusedRecordWildcardWarning - - - -warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns - :: [Name] -> FreeVars -> RnM () -warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds -warnUnusedMatches = check_unused Opt_WarnUnusedMatches -warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns - -check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () -check_unused flag bound_names used_names - = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) - bound_names)) - -------------------------- --- Helpers -warnUnusedGREs :: [GlobalRdrElt] -> RnM () -warnUnusedGREs gres = mapM_ warnUnusedGRE gres - -warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = do - fld_env <- mkFieldEnv <$> getGlobalRdrEnv - mapM_ (warnUnused1 flag fld_env) names - -warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () -warnUnused1 flag fld_env name - = when (reportable name occ) $ - addUnusedWarning flag - occ (nameSrcSpan name) - (text $ "Defined but not used" ++ opt_str) - where - occ = case lookupNameEnv fld_env name of - Just (fl, _) -> mkVarOccFS fl - Nothing -> nameOccName name - opt_str = case flag of - Opt_WarnUnusedTypePatterns -> " on the right hand side" - _ -> "" - -warnUnusedGRE :: GlobalRdrElt -> RnM () -warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) - | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv - warnUnused1 Opt_WarnUnusedTopBinds fld_env name - | otherwise = when (reportable name occ) (mapM_ warn is) - where - occ = greOccName gre - warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg - where - span = importSpecLoc spec - pp_mod = quotes (ppr (importSpecModule spec)) - msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") - --- | Make a map from selector names to field labels and parent tycon --- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) -mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) - | gres <- occEnvElts rdr_env - , gre <- gres - , Just lbl <- [greLabel gre] - ] - --- | Should we report the fact that this 'Name' is unused? The --- 'OccName' may differ from 'nameOccName' due to --- DuplicateRecordFields. -reportable :: Name -> OccName -> Bool -reportable name occ - | isWiredInName name = False -- Don't report unused wired-in names - -- Otherwise we get a zillion warnings - -- from Data.Tuple - | otherwise = not (startsWithUnderscore occ) - -addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning flag occ span msg - = addWarnAt (Reason flag) span $ - sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ)] - -unusedRecordWildcardWarning :: SDoc -unusedRecordWildcardWarning = - wildcardDoc $ text "No variables bound in the record wildcard match are used" - -redundantWildcardWarning :: SDoc -redundantWildcardWarning = - wildcardDoc $ text "Record wildcard does not bind any new variables" - -wildcardDoc :: SDoc -> SDoc -wildcardDoc herald = - herald - $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" - <+> quotes (text "..")) - -addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () -addNameClashErrRn rdr_name gres - | all isLocalGRE gres && not (all isRecFldGRE gres) - -- If there are two or more *local* defns, we'll have reported - = return () -- that already, and we don't want an error cascade - | otherwise - = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) - , text "It could refer to" - , nest 3 (vcat (msg1 : msgs)) ]) - where - (np1:nps) = gres - msg1 = text "either" <+> ppr_gre np1 - msgs = [text " or" <+> ppr_gre np | np <- nps] - ppr_gre gre = sep [ pp_gre_name gre <> comma - , pprNameProvenance gre] - - -- When printing the name, take care to qualify it in the same - -- way as the provenance reported by pprNameProvenance, namely - -- the head of 'gre_imp'. Otherwise we get confusing reports like - -- Ambiguous occurrence ‘null’ - -- It could refer to either ‘T15487a.null’, - -- imported from ‘Prelude’ at T15487.hs:1:8-13 - -- or ... - -- See #15487 - pp_gre_name gre@(GRE { gre_name = name, gre_par = parent - , gre_lcl = lcl, gre_imp = iss }) - | FldParent { par_lbl = Just lbl } <- parent - = text "the field" <+> quotes (ppr lbl) - | otherwise - = quotes (pp_qual <> dot <> ppr (nameOccName name)) - where - pp_qual | lcl - = ppr (nameModule name) - | imp : _ <- iss -- This 'imp' is the one that - -- pprNameProvenance chooses - , ImpDeclSpec { is_as = mod } <- is_decl imp - = ppr mod - | otherwise - = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) - -- Invariant: either 'lcl' is True or 'iss' is non-empty - -shadowedNameWarn :: OccName -> [SDoc] -> SDoc -shadowedNameWarn occ shadowed_locs - = sep [text "This binding for" <+> quotes (ppr occ) - <+> text "shadows the existing binding" <> plural shadowed_locs, - nest 2 (vcat shadowed_locs)] - - -unknownSubordinateErr :: SDoc -> RdrName -> SDoc -unknownSubordinateErr doc op -- Doc is "method of class" or - -- "field of constructor" - = quotes (ppr op) <+> text "is not a (visible)" <+> doc - - -dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () -dupNamesErr get_loc names - = addErrAt big_loc $ - vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), - locations] - where - locs = map get_loc (NE.toList names) - big_loc = foldr1 combineSrcSpans locs - locations = text "Bound at:" <+> vcat (map ppr (sort locs)) - -badQualBndrErr :: RdrName -> SDoc -badQualBndrErr rdr_name - = text "Qualified name in binding position:" <+> ppr rdr_name - -typeAppErr :: String -> LHsType GhcPs -> SDoc -typeAppErr what (L _ k) - = hang (text "Illegal visible" <+> text what <+> text "application" - <+> quotes (char '@' <> ppr k)) - 2 (text "Perhaps you intended to use TypeApplications") - -checkTupSize :: Int -> RnM () -checkTupSize tup_size - | tup_size <= mAX_TUPLE_SIZE - = return () - | otherwise - = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), - nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), - nest 2 (text "Workaround: use nested tuples or define a data type")]) - - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | StandaloneKindSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (Located RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (Located RdrName) - | TySynCtx (Located RdrName) - | TyFamilyCtx (Located RdrName) - | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [Located Name] - | ClassDeclCtx (Located RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | GHCiCtx - | SpliceTypeCtx (LHsType GhcPs) - | ClassInstanceCtx - | GenericCtx SDoc -- Maybe we want to use this more! - -withHsDocContext :: HsDocContext -> SDoc -> SDoc -withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt - -inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt - -pprHsDocContext :: HsDocContext -> SDoc -pprHsDocContext (GenericCtx doc) = doc -pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc -pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc -pprHsDocContext PatCtx = text "a pattern type-signature" -pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" -pprHsDocContext DefaultDeclCtx = text "a `default' declaration" -pprHsDocContext DerivDeclCtx = text "a deriving declaration" -pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name -pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) -pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) -pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) -pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) -pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) -pprHsDocContext ExprWithTySigCtx = text "an expression type signature" -pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" -pprHsDocContext HsTypeCtx = text "a type argument" -pprHsDocContext GHCiCtx = text "GHCi input" -pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" - -pprHsDocContext (ForeignDeclCtx name) - = text "the foreign declaration for" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx [name]) - = text "the definition of data constructor" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx names) - = text "the definition of data constructors" <+> interpp'SP names diff --git a/simplCore/CSE.hs b/simplCore/CSE.hs deleted file mode 100644 --- a/simplCore/CSE.hs +++ /dev/null @@ -1,743 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section{Common subexpression} --} - -{-# LANGUAGE CPP #-} - -module CSE (cseProgram, cseOneExpr) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSubst -import Var ( Var ) -import VarEnv ( elemInScopeSet, mkInScopeSet ) -import Id ( Id, idType, isDeadBinder, idHasRules - , idInlineActivation, setInlineActivation - , zapIdOccInfo, zapIdUsageInfo, idInlinePragma - , isJoinId, isJoinId_maybe ) -import CoreUtils ( mkAltExpr, eqExpr - , exprIsTickedString - , stripTicksE, stripTicksT, mkTicks ) -import CoreFVs ( exprFreeVars ) -import Type ( tyConAppArgs ) -import CoreSyn -import Outputable -import BasicTypes -import CoreMap -import Util ( filterOut ) -import Data.List ( mapAccumL ) - -{- - Simple common sub-expression - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see - x1 = C a b - x2 = C x1 b -we build up a reverse mapping: C a b -> x1 - C x1 b -> x2 -and apply that to the rest of the program. - -When we then see - y1 = C a b - y2 = C y1 b -we replace the C a b with x1. But then we *dont* want to -add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 -so that a subsequent binding - y2 = C y1 b -will get transformed to C x1 b, and then to x2. - -So we carry an extra var->var substitution which we apply *before* looking up in the -reverse mapping. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -We have to be careful about shadowing. -For example, consider - f = \x -> let y = x+x in - h = \x -> x+x - in ... - -Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no -shadowing, but it doesn't any more (it proved too hard), so we clone as we go. -We can simply add clones to the substitution already described. - - -Note [CSE for bindings] -~~~~~~~~~~~~~~~~~~~~~~~ -Let-bindings have two cases, implemented by addBinding. - -* SUBSTITUTE: applies when the RHS is a variable - - let x = y in ...(h x).... - - Here we want to extend the /substitution/ with x -> y, so that the - (h x) in the body might CSE with an enclosing (let v = h y in ...). - NB: the substitution maps InIds, so we extend the substitution with - a binding for the original InId 'x' - - How can we have a variable on the RHS? Doesn't the simplifier inline them? - - - First, the original RHS might have been (g z) which has CSE'd - with an enclosing (let y = g z in ...). This is super-important. - See #5996: - x1 = C a b - x2 = C x1 b - y1 = C a b - y2 = C y1 b - Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to - the substitution so that we can CSE the binding for y2. - - - Second, we use addBinding for case expression scrutinees too; - see Note [CSE for case expressions] - -* EXTEND THE REVERSE MAPPING: applies in all other cases - - let x = h y in ...(h y)... - - Here we want to extend the /reverse mapping (cs_map)/ so that - we CSE the (h y) call to x. - - Note that we use EXTEND even for a trivial expression, provided it - is not a variable or literal. In particular this /includes/ type - applications. This can be important (#13156); e.g. - case f @ Int of { r1 -> - case f @ Int of { r2 -> ... - Here we want to common-up the two uses of (f @ Int) so we can - remove one of the case expressions. - - See also Note [Corner case for case expressions] for another - reason not to use SUBSTITUTE for all trivial expressions. - -Notice that - - The SUBSTITUTE situation extends the substitution (cs_subst) - - The EXTEND situation extends the reverse mapping (cs_map) - -Notice also that in the SUBSTITUTE case we leave behind a binding - x = y -even though we /also/ carry a substitution x -> y. Can we just drop -the binding instead? Well, not at top level! See SimplUtils -Note [Top level and postInlineUnconditionally]; and in any case CSE -applies only to the /bindings/ of the program, and we leave it to the -simplifier to propate effects to the RULES. Finally, it doesn't seem -worth the effort to discard the nested bindings because the simplifier -will do it next. - -Note [CSE for case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case scrut_expr of x { ...alts... } -This is very like a strict let-binding - let !x = scrut_expr in ... -So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a -result all the stuff under Note [CSE for bindings] applies directly. - -For example: - -* Trivial scrutinee - f = \x -> case x of wild { - (a:as) -> case a of wild1 { - (p,q) -> ...(wild1:as)... - - Here, (wild1:as) is morally the same as (a:as) and hence equal to - wild. But that's not quite obvious. In the rest of the compiler we - want to keep it as (wild1:as), but for CSE purpose that's a bad - idea. - - By using addBinding we add the binding (wild1 -> a) to the substitution, - which does exactly the right thing. - - (Notice this is exactly backwards to what the simplifier does, which - is to try to replaces uses of 'a' with uses of 'wild1'.) - - This is the main reason that addBinding is called with a trivial rhs. - -* Non-trivial scrutinee - case (f x) of y { pat -> ...let z = f x in ... } - - By using addBinding we'll add (f x :-> y) to the cs_map, and - thereby CSE the inner (f x) to y. - -Note [CSE for INLINE and NOINLINE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are some subtle interactions of CSE with functions that the user -has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.) -Consider - - yes :: Int {-# NOINLINE yes #-} - yes = undefined - - no :: Int {-# NOINLINE no #-} - no = undefined - - foo :: Int -> Int -> Int {-# NOINLINE foo #-} - foo m n = n - - {-# RULES "foo/no" foo no = id #-} - - bar :: Int -> Int - bar = foo yes - -We do not expect the rule to fire. But if we do CSE, then we risk -getting yes=no, and the rule does fire. Actually, it won't because -NOINLINE means that 'yes' will never be inlined, not even if we have -yes=no. So that's fine (now; perhaps in the olden days, yes=no would -have substituted even if 'yes' was NOINLINE). - -But we do need to take care. Consider - - {-# NOINLINE bar #-} - bar = -- Same rhs as foo - - foo = - -If CSE produces - foo = bar -then foo will never be inlined to (when it should be, if -is small). The conclusion here is this: - - We should not add - :-> bar - to the CSEnv if 'bar' has any constraints on when it can inline; - that is, if its 'activation' not always active. Otherwise we - might replace by 'bar', and then later be unable to see that it - really was . - -An except to the rule is when the INLINE pragma is not from the user, e.g. from -WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec -is then true. - -Note that we do not (currently) do CSE on the unfolding stored inside -an Id, even if it is a 'stable' unfolding. That means that when an -unfolding happens, it is always faithful to what the stable unfolding -originally was. - -Note [CSE for stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - {-# Unf = Stable (\pq. build blah) #-} - foo = x - -Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial. -(Turns out that this actually happens for the enumFromTo method of -the Integer instance of Enum in GHC.Enum.) Suppose moreover that foo's -stable unfolding originates from an INLINE or INLINEABLE pragma on foo. -Then we obviously do NOT want to extend the substitution with (foo->x), -because we promised to inline foo as what the user wrote. See similar -SimplUtils Note [Stable unfoldings and postInlineUnconditionally]. - -Nor do we want to change the reverse mapping. Suppose we have - - {-# Unf = Stable (\pq. build blah) #-} - foo = - bar = - -There could conceivably be merit in rewriting the RHS of bar: - bar = foo -but now bar's inlining behaviour will change, and importing -modules might see that. So it seems dodgy and we don't do it. - -Stable unfoldings are also created during worker/wrapper when we decide -that a function's definition is so small that it should always inline. -In this case we still want to do CSE (#13340). Hence the use of -isAnyInlinePragma rather than isStableUnfolding. - -Note [Corner case for case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is another reason that we do not use SUBSTITUTE for -all trivial expressions. Consider - case x |> co of (y::Array# Int) { ... } - -We do not want to extend the substitution with (y -> x |> co); since y -is of unlifted type, this would destroy the let/app invariant if (x |> -co) was not ok-for-speculation. - -But surely (x |> co) is ok-for-speculation, becasue it's a trivial -expression, and x's type is also unlifted, presumably. Well, maybe -not if you are using unsafe casts. I actually found a case where we -had - (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int) - -Note [CSE for join points?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must not be naive about join points in CSE: - join j = e in - if b then jump j else 1 + e -The expression (1 + jump j) is not good (see Note [Invariants on join points] in -CoreSyn). This seems to come up quite seldom, but it happens (first seen -compiling ppHtml in Haddock.Backends.Xhtml). - -We could try and be careful by tracking which join points are still valid at -each subexpression, but since join points aren't allocated or shared, there's -less to gain by trying to CSE them. (#13219) - -Note [Look inside join-point binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Another way how CSE for joint points is tricky is - - let join foo x = (x, 42) - join bar x = (x, 42) - in … jump foo 1 … jump bar 2 … - -naively, CSE would turn this into - - let join foo x = (x, 42) - join bar = foo - in … jump foo 1 … jump bar 2 … - -but now bar is a join point that claims arity one, but its right-hand side -is not a lambda, breaking the join-point invariant (this was #15002). - -So `cse_bind` must zoom past the lambdas of a join point (using -`collectNBinders`) and resume searching for CSE opportunities only in -the body of the join point. - -Note [CSE for recursive bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = \x ... f.... - g = \y ... g ... -where the "..." are identical. Could we CSE them? In full generality -with mutual recursion it's quite hard; but for self-recursive bindings -(which are very common) it's rather easy: - -* Maintain a separate cs_rec_map, that maps - (\f. (\x. ...f...) ) -> f - Note the \f in the domain of the mapping! - -* When we come across the binding for 'g', look up (\g. (\y. ...g...)) - Bingo we get a hit. So we can replace the 'g' binding with - g = f - -We can't use cs_map for this, because the key isn't an expression of -the program; it's a kind of synthetic key for recursive bindings. - - -************************************************************************ -* * -\section{Common subexpression} -* * -************************************************************************ --} - -cseProgram :: CoreProgram -> CoreProgram -cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds) - -cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind toplevel env (NonRec b e) - = (env2, NonRec b2 e2) - where - (env1, b1) = addBinder env b - (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1 - -cseBind toplevel env (Rec [(in_id, rhs)]) - | noCSE in_id - = (env1, Rec [(out_id, rhs')]) - - -- See Note [CSE for recursive bindings] - | Just previous <- lookupCSRecEnv env out_id rhs'' - , let previous' = mkTicks ticks previous - out_id' = delayInlining toplevel out_id - = -- We have a hit in the recursive-binding cache - (extendCSSubst env1 in_id previous', NonRec out_id' previous') - - | otherwise - = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) - - where - (env1, [out_id]) = addRecBinders env [in_id] - rhs' = cseExpr env1 rhs - rhs'' = stripTicksE tickishFloatable rhs' - ticks = stripTicksT tickishFloatable rhs' - id_expr' = varToCoreExpr out_id - zapped_id = zapIdUsageInfo out_id - -cseBind toplevel env (Rec pairs) - = (env2, Rec pairs') - where - (env1, bndrs1) = addRecBinders env (map fst pairs) - (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) - - do_one env (pr, b1) = cse_bind toplevel env pr b1 - --- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer --- to @in_id@ (@out_id@, created from addBinder or addRecBinders), --- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd) --- binding to the 'CSEnv', so that we attempt to CSE any expressions --- which are equal to @out_rhs@. -cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr)) -cse_bind toplevel env (in_id, in_rhs) out_id - | isTopLevel toplevel, exprIsTickedString in_rhs - -- See Note [Take care with literal strings] - = (env', (out_id', in_rhs)) - - | Just arity <- isJoinId_maybe in_id - -- See Note [Look inside join-point binders] - = let (params, in_body) = collectNBinders arity in_rhs - (env', params') = addBinders env params - out_body = tryForCSE env' in_body - in (env, (out_id, mkLams params' out_body)) - - | otherwise - = (env', (out_id'', out_rhs)) - where - (env', out_id') = addBinding env in_id out_id out_rhs - (cse_done, out_rhs) = try_for_cse env in_rhs - out_id'' | cse_done = delayInlining toplevel out_id' - | otherwise = out_id' - -delayInlining :: TopLevelFlag -> Id -> Id --- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already --- See Note [Delay inlining after CSE] -delayInlining top_lvl bndr - | isTopLevel top_lvl - , isAlwaysActive (idInlineActivation bndr) - , idHasRules bndr -- Only if the Id has some RULES, - -- which might otherwise get lost - -- These rules are probably auto-generated specialisations, - -- since Ids with manual rules usually have manually-inserted - -- delayed inlining anyway - = bndr `setInlineActivation` activeAfterInitial - | otherwise - = bndr - -addBinding :: CSEnv -- Includes InId->OutId cloning - -> InVar -- Could be a let-bound type - -> OutId -> OutExpr -- Processed binding - -> (CSEnv, OutId) -- Final env, final bndr --- Extend the CSE env with a mapping [rhs -> out-id] --- unless we can instead just substitute [in-id -> rhs] --- --- It's possible for the binder to be a type variable (see --- Note [Type-let] in CoreSyn), in which case we can just substitute. -addBinding env in_id out_id rhs' - | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) - | noCSE in_id = (env, out_id) - | use_subst = (extendCSSubst env in_id rhs', out_id) - | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) - where - id_expr' = varToCoreExpr out_id - zapped_id = zapIdUsageInfo out_id - -- Putting the Id into the cs_map makes it possible that - -- it'll become shared more than it is now, which would - -- invalidate (the usage part of) its demand info. - -- This caused #100218. - -- Easiest thing is to zap the usage info; subsequently - -- performing late demand-analysis will restore it. Don't zap - -- the strictness info; it's not necessary to do so, and losing - -- it is bad for performance if you don't do late demand - -- analysis - - -- Should we use SUBSTITUTE or EXTEND? - -- See Note [CSE for bindings] - use_subst = case rhs' of - Var {} -> True - _ -> False - --- | Given a binder `let x = e`, this function --- determines whether we should add `e -> x` to the cs_map -noCSE :: InId -> Bool -noCSE id = not (isAlwaysActive (idInlineActivation id)) && - not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) - -- See Note [CSE for INLINE and NOINLINE] - || isAnyInlinePragma (idInlinePragma id) - -- See Note [CSE for stable unfoldings] - || isJoinId id - -- See Note [CSE for join points?] - - -{- Note [Take care with literal strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example: - - x = "foo"# - y = "foo"# - ...x...y...x...y.... - -We would normally turn this into: - - x = "foo"# - y = x - ...x...x...x...x.... - -But this breaks an invariant of Core, namely that the RHS of a top-level binding -of type Addr# must be a string literal, not another variable. See Note -[CoreSyn top-level string literals] in CoreSyn. - -For this reason, we special case top-level bindings to literal strings and leave -the original RHS unmodified. This produces: - - x = "foo"# - y = "foo"# - ...x...x...x...x.... - -Now 'y' will be discarded as dead code, and we are done. - -The net effect is that for the y-binding we want to - - Use SUBSTITUTE, by extending the substitution with y :-> x - - but leave the original binding for y undisturbed - -This is done by cse_bind. I got it wrong the first time (#13367). - -Note [Delay inlining after CSE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (#15445) we have - f,g :: Num a => a -> a - f x = ...f (x-1)..... - g y = ...g (y-1) .... - -and we make some specialisations of 'g', either automatically, or via -a SPECIALISE pragma. Then CSE kicks in and notices that the RHSs of -'f' and 'g' are identical, so we get - f x = ...f (x-1)... - g = f - {-# RULES g @Int _ = $sg #-} - -Now there is terrible danger that, in an importing module, we'll inline -'g' before we have a chance to run its specialisation! - -Solution: during CSE, afer a "hit" in the CSE cache - * when adding a binding - g = f - * for a top-level function g - * and g has specialisation RULES -add a NOINLINE[2] activation to it, to ensure it's not inlined -right away. - -Notes: -* Why top level only? Because for nested bindings we are already past - phase 2 and will never return there. - -* Why "only if g has RULES"? Because there is no point in - doing this if there are no RULES; and other things being - equal it delays optimisation to delay inlining (#17409) - - ----- Historical note --- - -This patch is simpler and more direct than an earlier -version: - - commit 2110738b280543698407924a16ac92b6d804dc36 - Author: Simon Peyton Jones - Date: Mon Jul 30 13:43:56 2018 +0100 - - Don't inline functions with RULES too early - -We had to revert this patch because it made GHC itself slower. - -Why? It delayed inlining of /all/ functions with RULES, and that was -very bad in TcFlatten.flatten_ty_con_app - -* It delayed inlining of liftM -* That delayed the unravelling of the recursion in some dictionary - bindings. -* That delayed some eta expansion, leaving - flatten_ty_con_app = \x y. let in \z. blah -* That allowed the float-out pass to put sguff between - the \y and \z. -* And that permanently stopped eta expasion of the function, - even once was simplified. - --} - -tryForCSE :: CSEnv -> InExpr -> OutExpr -tryForCSE env expr = snd (try_for_cse env expr) - -try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr) --- (False, e') => We did not CSE the entire expression, --- but we might have CSE'd some sub-expressions, --- yielding e' --- --- (True, te') => We CSE'd the entire expression, --- yielding the trivial expression te' -try_for_cse env expr - | Just e <- lookupCSEnv env expr'' = (True, mkTicks ticks e) - | otherwise = (False, expr') - -- The varToCoreExpr is needed if we have - -- case e of xco { ...case e of yco { ... } ... } - -- Then CSE will substitute yco -> xco; - -- but these are /coercion/ variables - where - expr' = cseExpr env expr - expr'' = stripTicksE tickishFloatable expr' - ticks = stripTicksT tickishFloatable expr' - -- We don't want to lose the source notes when a common sub - -- expression gets eliminated. Hence we push all (!) of them on - -- top of the replaced sub-expression. This is probably not too - -- useful in practice, but upholds our semantics. - --- | Runs CSE on a single expression. --- --- This entry point is not used in the compiler itself, but is provided --- as a convenient entry point for users of the GHC API. -cseOneExpr :: InExpr -> OutExpr -cseOneExpr e = cseExpr env e - where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } - -cseExpr :: CSEnv -> InExpr -> OutExpr -cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) -cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) -cseExpr _ (Lit lit) = Lit lit -cseExpr env (Var v) = lookupSubst env v -cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr env (Tick t e) = Tick t (cseExpr env e) -cseExpr env (Cast e co) = Cast (tryForCSE env e) (substCo (csEnvSubst env) co) -cseExpr env (Lam b e) = let (env', b') = addBinder env b - in Lam b' (cseExpr env' e) -cseExpr env (Let bind e) = let (env', bind') = cseBind NotTopLevel env bind - in Let bind' (cseExpr env' e) -cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts - -cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr -cseCase env scrut bndr ty alts - = Case scrut1 bndr3 ty' $ - combineAlts alt_env (map cse_alt alts) - where - ty' = substTy (csEnvSubst env) ty - scrut1 = tryForCSE env scrut - - bndr1 = zapIdOccInfo bndr - -- Zapping the OccInfo is needed because the extendCSEnv - -- in cse_alt may mean that a dead case binder - -- becomes alive, and Lint rejects that - (env1, bndr2) = addBinder env bndr1 - (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 - -- addBinding: see Note [CSE for case expressions] - - con_target :: OutExpr - con_target = lookupSubst alt_env bndr - - arg_tys :: [OutType] - arg_tys = tyConAppArgs (idType bndr3) - - -- Given case x of { K y z -> ...K y z... } - -- CSE K y z into x... - cse_alt (DataAlt con, args, rhs) - | not (null args) - -- ... but don't try CSE if there are no args; it just increases the number - -- of live vars. E.g. - -- case x of { True -> ....True.... } - -- Don't replace True by x! - -- Hence the 'null args', which also deal with literals and DEFAULT - = (DataAlt con, args', tryForCSE new_env rhs) - where - (env', args') = addBinders alt_env args - new_env = extendCSEnv env' con_expr con_target - con_expr = mkAltExpr (DataAlt con) args' arg_tys - - cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) - where - (env', args') = addBinders alt_env args - -combineAlts :: CSEnv -> [InAlt] -> [InAlt] --- See Note [Combine case alternatives] -combineAlts env ((_,bndrs1,rhs1) : rest_alts) - | all isDeadBinder bndrs1 - = (DEFAULT, [], rhs1) : filtered_alts - where - in_scope = substInScope (csEnvSubst env) - filtered_alts = filterOut identical rest_alts - identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs - ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope) - -combineAlts _ alts = alts -- Default case - -{- Note [Combine case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -combineAlts is just a more heavyweight version of the use of -combineIdenticalAlts in SimplUtils.prepareAlts. The basic idea is -to transform - - DEFAULT -> e1 - K x -> e1 - W y z -> e2 -===> - DEFAULT -> e1 - W y z -> e2 - -In the simplifier we use cheapEqExpr, because it is called a lot. -But here in CSE we use the full eqExpr. After all, two alternatives usually -differ near the root, so it probably isn't expensive to compare the full -alternative. It seems like the same kind of thing that CSE is supposed -to be doing, which is why I put it here. - -I acutally saw some examples in the wild, where some inlining made e1 too -big for cheapEqExpr to catch it. - - -************************************************************************ -* * -\section{The CSE envt} -* * -************************************************************************ --} - -data CSEnv - = CS { cs_subst :: Subst -- Maps InBndrs to OutExprs - -- The substitution variables to - -- /trivial/ OutExprs, not arbitrary expressions - - , cs_map :: CoreMap OutExpr -- The reverse mapping - -- Maps a OutExpr to a /trivial/ OutExpr - -- The key of cs_map is stripped of all Ticks - - , cs_rec_map :: CoreMap OutExpr - -- See Note [CSE for recursive bindings] - } - -emptyCSEnv :: CSEnv -emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap - , cs_subst = emptySubst } - -lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = csmap }) expr - = lookupCoreMap csmap expr - -extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv -extendCSEnv cse expr triv_expr - = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr } - where - sexpr = stripTicksE tickishFloatable expr - -extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv --- See Note [CSE for recursive bindings] -extendCSRecEnv cse bndr expr triv_expr - = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr } - -lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr --- See Note [CSE for recursive bindings] -lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr - = lookupCoreMap csmap (Lam bndr expr) - -csEnvSubst :: CSEnv -> Subst -csEnvSubst = cs_subst - -lookupSubst :: CSEnv -> Id -> OutExpr -lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x - -extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv -extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } - --- | Add clones to the substitution to deal with shadowing. See --- Note [Shadowing] for more details. You should call this whenever --- you go under a binder. -addBinder :: CSEnv -> Var -> (CSEnv, Var) -addBinder cse v = (cse { cs_subst = sub' }, v') - where - (sub', v') = substBndr (cs_subst cse) v - -addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) -addBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substBndrs (cs_subst cse) vs - -addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substRecBndrs (cs_subst cse) vs diff --git a/simplCore/CallArity.hs b/simplCore/CallArity.hs deleted file mode 100644 --- a/simplCore/CallArity.hs +++ /dev/null @@ -1,763 +0,0 @@ --- --- Copyright (c) 2014 Joachim Breitner --- - -module CallArity - ( callArityAnalProgram - , callArityRHS -- for testing - ) where - -import GhcPrelude - -import VarSet -import VarEnv -import DynFlags ( DynFlags ) - -import BasicTypes -import CoreSyn -import Id -import CoreArity ( typeArity ) -import CoreUtils ( exprIsCheap, exprIsTrivial ) -import UnVarGraph -import Demand -import Util - -import Control.Arrow ( first, second ) - - -{- -%************************************************************************ -%* * - Call Arity Analysis -%* * -%************************************************************************ - -Note [Call Arity: The goal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The goal of this analysis is to find out if we can eta-expand a local function, -based on how it is being called. The motivating example is this code, -which comes up when we implement foldl using foldr, and do list fusion: - - let go = \x -> let d = case ... of - False -> go (x+1) - True -> id - in \z -> d (x + z) - in go 1 0 - -If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of -partial function applications, which would be bad. - -The function `go` has a type of arity two, but only one lambda is manifest. -Furthermore, an analysis that only looks at the RHS of go cannot be sufficient -to eta-expand go: If `go` is ever called with one argument (and the result used -multiple times), we would be doing the work in `...` multiple times. - -So `callArityAnalProgram` looks at the whole let expression to figure out if -all calls are nice, i.e. have a high enough arity. It then stores the result in -the `calledArity` field of the `IdInfo` of `go`, which the next simplifier -phase will eta-expand. - -The specification of the `calledArity` field is: - - No work will be lost if you eta-expand me to the arity in `calledArity`. - -What we want to know for a variable ------------------------------------ - -For every let-bound variable we'd like to know: - 1. A lower bound on the arity of all calls to the variable, and - 2. whether the variable is being called at most once or possible multiple - times. - -It is always ok to lower the arity, or pretend that there are multiple calls. -In particular, "Minimum arity 0 and possible called multiple times" is always -correct. - - -What we want to know from an expression ---------------------------------------- - -In order to obtain that information for variables, we analyze expression and -obtain bits of information: - - I. The arity analysis: - For every variable, whether it is absent, or called, - and if called, which what arity. - - II. The Co-Called analysis: - For every two variables, whether there is a possibility that both are being - called. - We obtain as a special case: For every variables, whether there is a - possibility that it is being called twice. - -For efficiency reasons, we gather this information only for a set of -*interesting variables*, to avoid spending time on, e.g., variables from pattern matches. - -The two analysis are not completely independent, as a higher arity can improve -the information about what variables are being called once or multiple times. - -Note [Analysis I: The arity analysis] ------------------------------------- - -The arity analysis is quite straight forward: The information about an -expression is an - VarEnv Arity -where absent variables are bound to Nothing and otherwise to a lower bound to -their arity. - -When we analyze an expression, we analyze it with a given context arity. -Lambdas decrease and applications increase the incoming arity. Analysizing a -variable will put that arity in the environment. In lets or cases all the -results from the various subexpressions are lubed, which takes the point-wise -minimum (considering Nothing an infinity). - - -Note [Analysis II: The Co-Called analysis] ------------------------------------------- - -The second part is more sophisticated. For reasons explained below, it is not -sufficient to simply know how often an expression evaluates a variable. Instead -we need to know which variables are possibly called together. - -The data structure here is an undirected graph of variables, which is provided -by the abstract - UnVarGraph - -It is safe to return a larger graph, i.e. one with more edges. The worst case -(i.e. the least useful and always correct result) is the complete graph on all -free variables, which means that anything can be called together with anything -(including itself). - -Notation for the following: -C(e) is the co-called result for e. -G₁∪G₂ is the union of two graphs -fv is the set of free variables (conveniently the domain of the arity analysis result) -S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ } -S² is the complete graph on the set of variables S, S² = S×S -C'(e) is a variant for bound expression: - If e is called at most once, or it is and stays a thunk (after the analysis), - it is simply C(e). Otherwise, the expression can be called multiple times - and we return (fv e)² - -The interesting cases of the analysis: - * Var v: - No other variables are being called. - Return {} (the empty graph) - * Lambda v e, under arity 0: - This means that e can be evaluated many times and we cannot get - any useful co-call information. - Return (fv e)² - * Case alternatives alt₁,alt₂,...: - Only one can be execuded, so - Return (alt₁ ∪ alt₂ ∪...) - * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: - We get the results from both sides, with the argument evaluated at most once. - Additionally, anything called by e₁ can possibly be called with anything - from e₂. - Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂) - * App e₁ x: - As this is already in A-normal form, CorePrep will not separately lambda - bind (and hence share) x. So we conservatively assume multiple calls to x here - Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} - * Let v = rhs in body: - In addition to the results from the subexpressions, add all co-calls from - everything that the body calls together with v to everthing that is called - by v. - Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} - * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body - Tricky. - We assume that it is really mutually recursive, i.e. that every variable - calls one of the others, and that this is strongly connected (otherwise we - return an over-approximation, so that's ok), see note [Recursion and fixpointing]. - - Let V = {v₁,...vₙ}. - Assume that the vs have been analysed with an incoming demand and - cardinality consistent with the final result (this is the fixed-pointing). - Again we can use the results from all subexpressions. - In addition, for every variable vᵢ, we need to find out what it is called - with (call this set Sᵢ). There are two cases: - * If vᵢ is a function, we need to go through all right-hand-sides and bodies, - and collect every variable that is called together with any variable from V: - Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } - * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to - exclude it from this set: - Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } - Finally, combine all this: - Return: C(body) ∪ - C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ - (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ) - -Using the result: Eta-Expansion -------------------------------- - -We use the result of these two analyses to decide whether we can eta-expand the -rhs of a let-bound variable. - -If the variable is already a function (exprIsCheap), and all calls to the -variables have a higher arity than the current manifest arity (i.e. the number -of lambdas), expand. - -If the variable is a thunk we must be careful: Eta-Expansion will prevent -sharing of work, so this is only safe if there is at most one call to the -function. Therefore, we check whether {v,v} ∈ G. - - Example: - - let n = case .. of .. -- A thunk! - in n 0 + n 1 - - vs. - - let n = case .. of .. - in case .. of T -> n 0 - F -> n 1 - - We are only allowed to eta-expand `n` if it is going to be called at most - once in the body of the outer let. So we need to know, for each variable - individually, that it is going to be called at most once. - - -Why the co-call graph? ----------------------- - -Why is it not sufficient to simply remember which variables are called once and -which are called multiple times? It would be in the previous example, but consider - - let n = case .. of .. - in case .. of - True -> let go = \y -> case .. of - True -> go (y + n 1) - False > n - in go 1 - False -> n - -vs. - - let n = case .. of .. - in case .. of - True -> let go = \y -> case .. of - True -> go (y+1) - False > n - in go 1 - False -> n - -In both cases, the body and the rhs of the inner let call n at most once. -But only in the second case that holds for the whole expression! The -crucial difference is that in the first case, the rhs of `go` can call -*both* `go` and `n`, and hence can call `n` multiple times as it recurses, -while in the second case find out that `go` and `n` are not called together. - - -Why co-call information for functions? --------------------------------------- - -Although for eta-expansion we need the information only for thunks, we still -need to know whether functions are being called once or multiple times, and -together with what other functions. - - Example: - - let n = case .. of .. - f x = n (x+1) - in f 1 + f 2 - - vs. - - let n = case .. of .. - f x = n (x+1) - in case .. of T -> f 0 - F -> f 1 - - Here, the body of f calls n exactly once, but f itself is being called - multiple times, so eta-expansion is not allowed. - - -Note [Analysis type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The work-hourse of the analysis is the function `callArityAnal`, with the -following type: - - type CallArityRes = (UnVarGraph, VarEnv Arity) - callArityAnal :: - Arity -> -- The arity this expression is called with - VarSet -> -- The set of interesting variables - CoreExpr -> -- The expression to analyse - (CallArityRes, CoreExpr) - -and the following specification: - - ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr - - <=> - - Assume the expression `expr` is being passed `arity` arguments. Then it holds that - * The domain of `callArityEnv` is a subset of `interestingIds`. - * Any variable from `interestingIds` that is not mentioned in the `callArityEnv` - is absent, i.e. not called at all. - * Every call from `expr` to a variable bound to n in `callArityEnv` has at - least n value arguments. - * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`, - then in no execution of `expr` both are being called. - Furthermore, expr' is expr with the callArity field of the `IdInfo` updated. - - -Note [Which variables are interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The analysis would quickly become prohibitive expensive if we would analyse all -variables; for most variables we simply do not care about how often they are -called, i.e. variables bound in a pattern match. So interesting are variables that are - * top-level or let bound - * and possibly functions (typeArity > 0) - -Note [Taking boring variables into account] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If we decide that the variable bound in `let x = e1 in e2` is not interesting, -the analysis of `e2` will not report anything about `x`. To ensure that -`callArityBind` does still do the right thing we have to take that into account -everytime we would be lookup up `x` in the analysis result of `e2`. - * Instead of calling lookupCallArityRes, we return (0, True), indicating - that this variable might be called many times with no arguments. - * Instead of checking `calledWith x`, we assume that everything can be called - with it. - * In the recursive case, when calclulating the `cross_calls`, if there is - any boring variable in the recursive group, we ignore all co-call-results - and directly go to a very conservative assumption. - -The last point has the nice side effect that the relatively expensive -integration of co-call results in a recursive groups is often skipped. This -helped to avoid the compile time blowup in some real-world code with large -recursive groups (#10293). - -Note [Recursion and fixpointing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For a mutually recursive let, we begin by - 1. analysing the body, using the same incoming arity as for the whole expression. - 2. Then we iterate, memoizing for each of the bound variables the last - analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes. - 3. We combine the analysis result from the body and the memoized results for - the arguments (if already present). - 4. For each variable, we find out the incoming arity and whether it is called - once, based on the current analysis result. If this differs from the - memoized results, we re-analyse the rhs and update the memoized table. - 5. If nothing had to be reanalyzed, we are done. - Otherwise, repeat from step 3. - - -Note [Thunks in recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We never eta-expand a thunk in a recursive group, on the grounds that if it is -part of a recursive group, then it will be called multiple times. - -This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not -t1) in the following code: - - let go x = t1 - t1 = if ... then t2 else ... - t2 = if ... then go 1 else ... - in go 0 - -Detecting this would require finding out what variables are only ever called -from thunks. While this is certainly possible, we yet have to see this to be -relevant in the wild. - - -Note [Analysing top-level binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We can eta-expand top-level-binds if they are not exported, as we see all calls -to them. The plan is as follows: Treat the top-level binds as nested lets around -a body representing “all external calls”, which returns a pessimistic -CallArityRes (the co-call graph is the complete graph, all arityies 0). - -Note [Trimming arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the Call Arity papers, we are working on an untyped lambda calculus with no -other id annotations, where eta-expansion is always possible. But this is not -the case for Core! - 1. We need to ensure the invariant - callArity e <= typeArity (exprType e) - for the same reasons that exprArity needs this invariant (see Note - [exprArity invariant] in CoreArity). - - If we are not doing that, a too-high arity annotation will be stored with - the id, confusing the simplifier later on. - - 2. Eta-expanding a right hand side might invalidate existing annotations. In - particular, if an id has a strictness annotation of <...><...>b, then - passing two arguments to it will definitely bottom out, so the simplifier - will throw away additional parameters. This conflicts with Call Arity! So - we ensure that we never eta-expand such a value beyond the number of - arguments mentioned in the strictness signature. - See #10176 for a real-world-example. - -Note [What is a thunk] -~~~~~~~~~~~~~~~~~~~~~~ - -Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a -thunk, not eta-expanded, to avoid losing any sharing. This is also how the -published papers on Call Arity describe it. - -In practice, there are thunks that do a just little work, such as -pattern-matching on a variable, and the benefits of eta-expansion likely -outweigh the cost of doing that repeatedly. Therefore, this implementation of -Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk. - -Note [Call Arity and Join Points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The Call Arity analysis does not care about join points, and treats them just -like normal functions. This is ok. - -The analysis *could* make use of the fact that join points are always evaluated -in the same context as the join-binding they are defined in and are always -one-shot, and handle join points separately, as suggested in -https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870. -This *might* be more efficient (for example, join points would not have to be -considered interesting variables), but it would also add redundant code. So for -now we do not do that. - -The simplifier never eta-expands join points (it instead pushes extra arguments from -an eta-expanded context into the join point’s RHS), so the call arity -annotation on join points is not actually used. As it would be equally valid -(though less efficient) to eta-expand join points, this is the simplifier's -choice, and hence Call Arity sets the call arity for join points as well. --} - --- Main entry point - -callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram -callArityAnalProgram _dflags binds = binds' - where - (_, binds') = callArityTopLvl [] emptyVarSet binds - --- See Note [Analysing top-level-binds] -callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) -callArityTopLvl exported _ [] - = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported]) - , [] ) -callArityTopLvl exported int1 (b:bs) - = (ae2, b':bs') - where - int2 = bindersOf b - exported' = filter isExportedId int2 ++ exported - int' = int1 `addInterestingBinds` b - (ae1, bs') = callArityTopLvl exported' int' bs - (ae2, b') = callArityBind (boringBinds b) ae1 int1 b - - -callArityRHS :: CoreExpr -> CoreExpr -callArityRHS = snd . callArityAnal 0 emptyVarSet - --- The main analysis function. See Note [Analysis type signature] -callArityAnal :: - Arity -> -- The arity this expression is called with - VarSet -> -- The set of interesting variables - CoreExpr -> -- The expression to analyse - (CallArityRes, CoreExpr) - -- How this expression uses its interesting variables - -- and the expression with IdInfo updated - --- The trivial base cases -callArityAnal _ _ e@(Lit _) - = (emptyArityRes, e) -callArityAnal _ _ e@(Type _) - = (emptyArityRes, e) -callArityAnal _ _ e@(Coercion _) - = (emptyArityRes, e) --- The transparent cases -callArityAnal arity int (Tick t e) - = second (Tick t) $ callArityAnal arity int e -callArityAnal arity int (Cast e co) - = second (\e -> Cast e co) $ callArityAnal arity int e - --- The interesting case: Variables, Lambdas, Lets, Applications, Cases -callArityAnal arity int e@(Var v) - | v `elemVarSet` int - = (unitArityRes v arity, e) - | otherwise - = (emptyArityRes, e) - --- Non-value lambdas are ignored -callArityAnal arity int (Lam v e) | not (isId v) - = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e - --- We have a lambda that may be called multiple times, so its free variables --- can all be co-called. -callArityAnal 0 int (Lam v e) - = (ae', Lam v e') - where - (ae, e') = callArityAnal 0 (int `delVarSet` v) e - ae' = calledMultipleTimes ae --- We have a lambda that we are calling. decrease arity. -callArityAnal arity int (Lam v e) - = (ae, Lam v e') - where - (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e - --- Application. Increase arity for the called expression, nothing to know about --- the second -callArityAnal arity int (App e (Type t)) - = second (\e -> App e (Type t)) $ callArityAnal arity int e -callArityAnal arity int (App e1 e2) - = (final_ae, App e1' e2') - where - (ae1, e1') = callArityAnal (arity + 1) int e1 - (ae2, e2') = callArityAnal 0 int e2 - -- If the argument is trivial (e.g. a variable), then it will _not_ be - -- let-bound in the Core to STG transformation (CorePrep actually), - -- so no sharing will happen here, and we have to assume many calls. - ae2' | exprIsTrivial e2 = calledMultipleTimes ae2 - | otherwise = ae2 - final_ae = ae1 `both` ae2' - --- Case expression. -callArityAnal arity int (Case scrut bndr ty alts) - = -- pprTrace "callArityAnal:Case" - -- (vcat [ppr scrut, ppr final_ae]) - (final_ae, Case scrut' bndr ty alts') - where - (alt_aes, alts') = unzip $ map go alts - go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e - in (ae, (dc, bndrs, e')) - alt_ae = lubRess alt_aes - (scrut_ae, scrut') = callArityAnal 0 int scrut - final_ae = scrut_ae `both` alt_ae - --- For lets, use callArityBind -callArityAnal arity int (Let bind e) - = -- pprTrace "callArityAnal:Let" - -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ]) - (final_ae, Let bind' e') - where - int_body = int `addInterestingBinds` bind - (ae_body, e') = callArityAnal arity int_body e - (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind - --- Which bindings should we look at? --- See Note [Which variables are interesting] -isInteresting :: Var -> Bool -isInteresting v = not $ null (typeArity (idType v)) - -interestingBinds :: CoreBind -> [Var] -interestingBinds = filter isInteresting . bindersOf - -boringBinds :: CoreBind -> VarSet -boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf - -addInterestingBinds :: VarSet -> CoreBind -> VarSet -addInterestingBinds int bind - = int `delVarSetList` bindersOf bind -- Possible shadowing - `extendVarSetList` interestingBinds bind - --- Used for both local and top-level binds --- Second argument is the demand from the body -callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind) --- Non-recursive let -callArityBind boring_vars ae_body int (NonRec v rhs) - | otherwise - = -- pprTrace "callArityBind:NonRec" - -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) - (final_ae, NonRec v' rhs') - where - is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] - -- If v is boring, we will not find it in ae_body, but always assume (0, False) - boring = v `elemVarSet` boring_vars - - (arity, called_once) - | boring = (0, False) -- See Note [Taking boring variables into account] - | otherwise = lookupCallArityRes ae_body v - safe_arity | called_once = arity - | is_thunk = 0 -- A thunk! Do not eta-expand - | otherwise = arity - - -- See Note [Trimming arity] - trimmed_arity = trimArity v safe_arity - - (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs - - - ae_rhs'| called_once = ae_rhs - | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once - | otherwise = calledMultipleTimes ae_rhs - - called_by_v = domRes ae_rhs' - called_with_v - | boring = domRes ae_body - | otherwise = calledWith ae_body v `delUnVarSet` v - final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body - - v' = v `setIdCallArity` trimmed_arity - - --- Recursive let. See Note [Recursion and fixpointing] -callArityBind boring_vars ae_body int b@(Rec binds) - = -- (if length binds > 300 then - -- pprTrace "callArityBind:Rec" - -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ - (final_ae, Rec binds') - where - -- See Note [Taking boring variables into account] - any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds] - - int_body = int `addInterestingBinds` b - (ae_rhs, binds') = fix initial_binds - final_ae = bindersOf b `resDelList` ae_rhs - - initial_binds = [(i,Nothing,e) | (i,e) <- binds] - - fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) - fix ann_binds - | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ - any_change - = fix ann_binds' - | otherwise - = (ae, map (\(i, _, e) -> (i, e)) ann_binds') - where - aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ] - ae = callArityRecEnv any_boring aes_old ae_body - - rerun (i, mbLastRun, rhs) - | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae) - -- No call to this yet, so do nothing - = (False, (i, Nothing, rhs)) - - | Just (old_called_once, old_arity, _) <- mbLastRun - , called_once == old_called_once - , new_arity == old_arity - -- No change, no need to re-analyze - = (False, (i, mbLastRun, rhs)) - - | otherwise - -- We previously analyzed this with a different arity (or not at all) - = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk] - - safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] - | otherwise = new_arity - - -- See Note [Trimming arity] - trimmed_arity = trimArity i safe_arity - - (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs - - ae_rhs' | called_once = ae_rhs - | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once - | otherwise = calledMultipleTimes ae_rhs - - i' = i `setIdCallArity` trimmed_arity - - in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs')) - where - -- See Note [Taking boring variables into account] - (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False) - | otherwise = lookupCallArityRes ae i - - (changes, ann_binds') = unzip $ map rerun ann_binds - any_change = or changes - --- Combining the results from body and rhs, (mutually) recursive case --- See Note [Analysis II: The Co-Called analysis] -callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes -callArityRecEnv any_boring ae_rhss ae_body - = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $ - ae_new - where - vars = map fst ae_rhss - - ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body - - cross_calls - -- See Note [Taking boring variables into account] - | any_boring = completeGraph (domRes ae_combined) - -- Also, calculating cross_calls is expensive. Simply be conservative - -- if the mutually recursive group becomes too large. - | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined) - | otherwise = unionUnVarGraphs $ map cross_call ae_rhss - cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v - where - is_thunk = idCallArity v == 0 - -- What rhs are relevant as happening before (or after) calling v? - -- If v is a thunk, everything from all the _other_ variables - -- If v is not a thunk, everything can happen. - ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body - | otherwise = ae_combined - -- What do we want to know from these? - -- Which calls can happen next to any recursive call. - called_with_v - = unionUnVarSets $ map (calledWith ae_before_v) vars - called_by_v = domRes ae_rhs - - ae_new = first (cross_calls `unionUnVarGraph`) ae_combined - --- See Note [Trimming arity] -trimArity :: Id -> Arity -> Arity -trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] - where - max_arity_by_type = length (typeArity (idType v)) - max_arity_by_strsig - | isBotRes result_info = length demands - | otherwise = a - - (demands, result_info) = splitStrictSig (idStrictness v) - ---------------------------------------- --- Functions related to CallArityRes -- ---------------------------------------- - --- Result type for the two analyses. --- See Note [Analysis I: The arity analysis] --- and Note [Analysis II: The Co-Called analysis] -type CallArityRes = (UnVarGraph, VarEnv Arity) - -emptyArityRes :: CallArityRes -emptyArityRes = (emptyUnVarGraph, emptyVarEnv) - -unitArityRes :: Var -> Arity -> CallArityRes -unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) - -resDelList :: [Var] -> CallArityRes -> CallArityRes -resDelList vs ae = foldr resDel ae vs - -resDel :: Var -> CallArityRes -> CallArityRes -resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v) - -domRes :: CallArityRes -> UnVarSet -domRes (_, ae) = varEnvDom ae - --- In the result, find out the minimum arity and whether the variable is called --- at most once. -lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool) -lookupCallArityRes (g, ae) v - = case lookupVarEnv ae v of - Just a -> (a, not (g `hasLoopAt` v)) - Nothing -> (0, False) - -calledWith :: CallArityRes -> Var -> UnVarSet -calledWith (g, _) v = neighbors g v - -addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes -addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`) - --- Replaces the co-call graph by a complete graph (i.e. no information) -calledMultipleTimes :: CallArityRes -> CallArityRes -calledMultipleTimes res = first (const (completeGraph (domRes res))) res - --- Used for application and cases -both :: CallArityRes -> CallArityRes -> CallArityRes -both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2 - --- Used when combining results from alternative cases; take the minimum -lubRes :: CallArityRes -> CallArityRes -> CallArityRes -lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2) - -lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity -lubArityEnv = plusVarEnv_C min - -lubRess :: [CallArityRes] -> CallArityRes -lubRess = foldl' lubRes emptyArityRes diff --git a/simplCore/CoreMonad.hs b/simplCore/CoreMonad.hs deleted file mode 100644 --- a/simplCore/CoreMonad.hs +++ /dev/null @@ -1,830 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[CoreMonad]{The core pipeline monad} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module CoreMonad ( - -- * Configuration of the core-to-core passes - CoreToDo(..), runWhen, runMaybe, - SimplMode(..), - FloatOutSwitches(..), - pprPassDetails, - - -- * Plugins - CorePluginPass, bindsOnlyPass, - - -- * Counting - SimplCount, doSimplTick, doFreeSimplTick, simplCountN, - pprSimplCount, plusSimplCount, zeroSimplCount, - isZeroSimplCount, hasDetailedCounts, Tick(..), - - -- * The monad - CoreM, runCoreM, - - -- ** Reading from the monad - getHscEnv, getRuleBase, getModule, - getDynFlags, getOrigNameCache, getPackageFamInstEnv, - getVisibleOrphanMods, getUniqMask, - getPrintUnqualified, getSrcSpanM, - - -- ** Writing to the monad - addSimplCount, - - -- ** Lifting into the monad - liftIO, liftIOWithCount, - - -- ** Dealing with annotations - getAnnotations, getFirstAnnotations, - - -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, - fatalErrorMsg, fatalErrorMsgS, - debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn - ) where - -import GhcPrelude hiding ( read ) - -import CoreSyn -import HscTypes -import Module -import DynFlags -import BasicTypes ( CompilerPhase(..) ) -import Annotations - -import IOEnv hiding ( liftIO, failM, failWithM ) -import qualified IOEnv ( liftIO ) -import Var -import Outputable -import FastString -import qualified ErrUtils as Err -import ErrUtils( Severity(..) ) -import UniqSupply -import UniqFM ( UniqFM, mapUFM, filterUFM ) -import MonadUtils -import NameCache -import SrcLoc -import Data.List (intersperse, groupBy, sortBy) -import Data.Ord -import Data.Dynamic -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict -import Data.Word -import Control.Monad -import Control.Applicative ( Alternative(..) ) -import Panic (throwGhcException, GhcException(..)) - -{- -************************************************************************ -* * - The CoreToDo type and related types - Abstraction of core-to-core passes to run. -* * -************************************************************************ --} - -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify -- The core-to-core simplifier. - Int -- Max iterations - SimplMode - | CoreDoPluginPass String CorePluginPass - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoCallArity - | CoreDoExitify - | CoreDoStrictness - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreCSE - | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules - -- matching this string - | CoreDoNothing -- Useful when building up - | CoreDoPasses [CoreToDo] -- lists of these things - - | CoreDesugar -- Right after desugaring, no simple optimisation yet! - | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces - -- Core output, and hence useful to pass to endPass - - | CoreTidy - | CorePrep - | CoreOccurAnal - -instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = text "Simplifier" - ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s - ppr CoreDoFloatInwards = text "Float inwards" - ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) - ppr CoreLiberateCase = text "Liberate case" - ppr CoreDoStaticArgs = text "Static argument" - ppr CoreDoCallArity = text "Called arity analysis" - ppr CoreDoExitify = text "Exitification transformation" - ppr CoreDoStrictness = text "Demand analysis" - ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" - ppr CoreDoSpecialising = text "Specialise" - ppr CoreDoSpecConstr = text "SpecConstr" - ppr CoreCSE = text "Common sub-expression" - ppr CoreDesugar = text "Desugar (before optimization)" - ppr CoreDesugarOpt = text "Desugar (after optimization)" - ppr CoreTidy = text "Tidy Core" - ppr CorePrep = text "CorePrep" - ppr CoreOccurAnal = text "Occurrence analysis" - ppr CoreDoPrintCore = text "Print core" - ppr (CoreDoRuleCheck {}) = text "Rule check" - ppr CoreDoNothing = text "CoreDoNothing" - ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes - -pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n - , ppr md ] -pprPassDetails _ = Outputable.empty - -data SimplMode -- See comments in SimplMonad - = SimplMode - { sm_names :: [String] -- Name(s) of the phase - , sm_phase :: CompilerPhase - , sm_dflags :: DynFlags -- Just for convenient non-monadic - -- access; we don't override these - , sm_rules :: Bool -- Whether RULES are enabled - , sm_inline :: Bool -- Whether inlining is enabled - , sm_case_case :: Bool -- Whether case-of-case is enabled - , sm_eta_expand :: Bool -- Whether eta-expansion is enabled - } - -instance Outputable SimplMode where - ppr (SimplMode { sm_phase = p, sm_names = ss - , sm_rules = r, sm_inline = i - , sm_eta_expand = eta, sm_case_case = cc }) - = text "SimplMode" <+> braces ( - sep [ text "Phase =" <+> ppr p <+> - brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag i (sLit "inline") <> comma - , pp_flag r (sLit "rules") <> comma - , pp_flag eta (sLit "eta-expand") <> comma - , pp_flag cc (sLit "case-of-case") ]) - where - pp_flag f s = ppUnless f (text "no") <+> ptext s - -data FloatOutSwitches = FloatOutSwitches { - floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if - -- doing so will abstract over n or fewer - -- value variables - -- Nothing <=> float all lambdas to top level, - -- regardless of how many free variables - -- Just 0 is the vanilla case: float a lambda - -- iff it has no free vars - - floatOutConstants :: Bool, -- ^ True <=> float constants to top level, - -- even if they do not escape a lambda - floatOutOverSatApps :: Bool, - -- ^ True <=> float out over-saturated applications - -- based on arity information. - -- See Note [Floating over-saturated applications] - -- in SetLevels - floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. - } -instance Outputable FloatOutSwitches where - ppr = pprFloatOutSwitches - -pprFloatOutSwitches :: FloatOutSwitches -> SDoc -pprFloatOutSwitches sw - = text "FOS" <+> (braces $ - sep $ punctuate comma $ - [ text "Lam =" <+> ppr (floatOutLambdas sw) - , text "Consts =" <+> ppr (floatOutConstants sw) - , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) - --- The core-to-core pass ordering is derived from the DynFlags: -runWhen :: Bool -> CoreToDo -> CoreToDo -runWhen True do_this = do_this -runWhen False _ = CoreDoNothing - -runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo -runMaybe (Just x) f = f x -runMaybe Nothing _ = CoreDoNothing - -{- - -************************************************************************ -* * - Types for Plugins -* * -************************************************************************ --} - --- | A description of the plugin pass itself -type CorePluginPass = ModGuts -> CoreM ModGuts - -bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts -bindsOnlyPass pass guts - = do { binds' <- pass (mg_binds guts) - ; return (guts { mg_binds = binds' }) } - -{- -************************************************************************ -* * - Counting and logging -* * -************************************************************************ --} - -getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = getPprDebug -- For now, anyway - -zeroSimplCount :: DynFlags -> SimplCount -isZeroSimplCount :: SimplCount -> Bool -hasDetailedCounts :: SimplCount -> Bool -pprSimplCount :: SimplCount -> SDoc -doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount -doFreeSimplTick :: Tick -> SimplCount -> SimplCount -plusSimplCount :: SimplCount -> SimplCount -> SimplCount - -data SimplCount - = VerySimplCount !Int -- Used when don't want detailed stats - - | SimplCount { - ticks :: !Int, -- Total ticks - details :: !TickCounts, -- How many of each type - - n_log :: !Int, -- N - log1 :: [Tick], -- Last N events; <= opt_HistorySize, - -- most recent first - log2 :: [Tick] -- Last opt_HistorySize events before that - -- Having log1, log2 lets us accumulate the - -- recent history reasonably efficiently - } - -type TickCounts = Map Tick Int - -simplCountN :: SimplCount -> Int -simplCountN (VerySimplCount n) = n -simplCountN (SimplCount { ticks = n }) = n - -zeroSimplCount dflags - -- This is where we decide whether to do - -- the VerySimpl version or the full-stats version - | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = Map.empty, - n_log = 0, log1 = [], log2 = []} - | otherwise - = VerySimplCount 0 - -isZeroSimplCount (VerySimplCount n) = n==0 -isZeroSimplCount (SimplCount { ticks = n }) = n==0 - -hasDetailedCounts (VerySimplCount {}) = False -hasDetailedCounts (SimplCount {}) = True - -doFreeSimplTick tick sc@SimplCount { details = dts } - = sc { details = dts `addTick` tick } -doFreeSimplTick _ sc = sc - -doSimplTick dflags tick - sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) - | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } - where - sc1 = sc { ticks = tks+1, details = dts `addTick` tick } - -doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) - - -addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = MapStrict.insertWith (+) tick 1 fm - -plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) - sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2 - , details = MapStrict.unionWith (+) dts1 dts2 } - where - -- A hackish way of getting recent log info - log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 - | null (log2 sc2) = sc2 { log2 = log1 sc1 } - | otherwise = sc2 - -plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) -plusSimplCount lhs rhs = - throwGhcException . PprProgramError "plusSimplCount" $ vcat - [ text "lhs" - , pprSimplCount lhs - , text "rhs" - , pprSimplCount rhs - ] - -- We use one or the other consistently - -pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n -pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [text "Total ticks: " <+> int tks, - blankLine, - pprTickCounts dts, - getVerboseSimplStats $ \dbg -> if dbg - then - vcat [blankLine, - text "Log (most recent first)", - nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] - else Outputable.empty - ] - -{- Note [Which transformations are innocuous] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one point (Jun 18) I wondered if some transformations (ticks) -might be "innocuous", in the sense that they do not unlock a later -transformation that does not occur in the same pass. If so, we could -refrain from bumping the overall tick-count for such innocuous -transformations, and perhaps terminate the simplifier one pass -earlier. - -BUt alas I found that virtually nothing was innocuous! This Note -just records what I learned, in case anyone wants to try again. - -These transformations are not innocuous: - -*** NB: I think these ones could be made innocuous - EtaExpansion - LetFloatFromLet - -LetFloatFromLet - x = K (let z = e2 in Just z) - prepareRhs transforms to - x2 = let z=e2 in Just z - x = K xs - And now more let-floating can happen in the - next pass, on x2 - -PreInlineUnconditionally - Example in spectral/cichelli/Auxil - hinsert = ...let lo = e in - let j = ...lo... in - case x of - False -> () - True -> case lo of I# lo' -> - ...j... - When we PreInlineUnconditionally j, lo's occ-info changes to once, - so it can be PreInlineUnconditionally in the next pass, and a - cascade of further things can happen. - -PostInlineUnconditionally - let x = e in - let y = ...x.. in - case .. of { A -> ...x...y... - B -> ...x...y... } - Current postinlineUnconditinaly will inline y, and then x; sigh. - - But PostInlineUnconditionally might also unlock subsequent - transformations for the same reason as PreInlineUnconditionally, - so it's probably not innocuous anyway. - -KnownBranch, BetaReduction: - May drop chunks of code, and thereby enable PreInlineUnconditionally - for some let-binding which now occurs once - -EtaExpansion: - Example in imaginary/digits-of-e1 - fail = \void. e where e :: IO () - --> etaExpandRhs - fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) - --> Next iteration of simplify - fail1 = \void. \s. (e |> g) s - fail = fail1 |> Void#->sym g - And now inline 'fail' - -CaseMerge: - case x of y { - DEFAULT -> case y of z { pi -> ei } - alts2 } - ---> CaseMerge - case x of { pi -> let z = y in ei - ; alts2 } - The "let z=y" case-binder-swap gets dealt with in the next pass --} - -pprTickCounts :: Map Tick Int -> SDoc -pprTickCounts counts - = vcat (map pprTickGroup groups) - where - groups :: [[(Tick,Int)]] -- Each group shares a comon tag - -- toList returns common tags adjacent - groups = groupBy same_tag (Map.toList counts) - same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 - -pprTickGroup :: [(Tick, Int)] -> SDoc -pprTickGroup group@((tick1,_):_) - = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) - 2 (vcat [ int n <+> pprTickCts tick - -- flip as we want largest first - | (tick,n) <- sortBy (flip (comparing snd)) group]) -pprTickGroup [] = panic "pprTickGroup" - -data Tick -- See Note [Which transformations are innocuous] - = PreInlineUnconditionally Id - | PostInlineUnconditionally Id - - | UnfoldingDone Id - | RuleFired FastString -- Rule name - - | LetFloatFromLet - | EtaExpansion Id -- LHS binder - | EtaReduction Id -- Binder on outer lambda - | BetaReduction Id -- Lambda binder - - - | CaseOfCase Id -- Bndr on *inner* case - | KnownBranch Id -- Case binder - | CaseMerge Id -- Binder on outer case - | AltMerge Id -- Case binder - | CaseElim Id -- Case binder - | CaseIdentity Id -- Case binder - | FillInCaseDefault Id -- Case binder - - | SimplifierDone -- Ticked at each iteration of the simplifier - -instance Outputable Tick where - ppr tick = text (tickString tick) <+> pprTickCts tick - -instance Eq Tick where - a == b = case a `cmpTick` b of - EQ -> True - _ -> False - -instance Ord Tick where - compare = cmpTick - -tickToTag :: Tick -> Int -tickToTag (PreInlineUnconditionally _) = 0 -tickToTag (PostInlineUnconditionally _) = 1 -tickToTag (UnfoldingDone _) = 2 -tickToTag (RuleFired _) = 3 -tickToTag LetFloatFromLet = 4 -tickToTag (EtaExpansion _) = 5 -tickToTag (EtaReduction _) = 6 -tickToTag (BetaReduction _) = 7 -tickToTag (CaseOfCase _) = 8 -tickToTag (KnownBranch _) = 9 -tickToTag (CaseMerge _) = 10 -tickToTag (CaseElim _) = 11 -tickToTag (CaseIdentity _) = 12 -tickToTag (FillInCaseDefault _) = 13 -tickToTag SimplifierDone = 16 -tickToTag (AltMerge _) = 17 - -tickString :: Tick -> String -tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" -tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" -tickString (UnfoldingDone _) = "UnfoldingDone" -tickString (RuleFired _) = "RuleFired" -tickString LetFloatFromLet = "LetFloatFromLet" -tickString (EtaExpansion _) = "EtaExpansion" -tickString (EtaReduction _) = "EtaReduction" -tickString (BetaReduction _) = "BetaReduction" -tickString (CaseOfCase _) = "CaseOfCase" -tickString (KnownBranch _) = "KnownBranch" -tickString (CaseMerge _) = "CaseMerge" -tickString (AltMerge _) = "AltMerge" -tickString (CaseElim _) = "CaseElim" -tickString (CaseIdentity _) = "CaseIdentity" -tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString SimplifierDone = "SimplifierDone" - -pprTickCts :: Tick -> SDoc -pprTickCts (PreInlineUnconditionally v) = ppr v -pprTickCts (PostInlineUnconditionally v)= ppr v -pprTickCts (UnfoldingDone v) = ppr v -pprTickCts (RuleFired v) = ppr v -pprTickCts LetFloatFromLet = Outputable.empty -pprTickCts (EtaExpansion v) = ppr v -pprTickCts (EtaReduction v) = ppr v -pprTickCts (BetaReduction v) = ppr v -pprTickCts (CaseOfCase v) = ppr v -pprTickCts (KnownBranch v) = ppr v -pprTickCts (CaseMerge v) = ppr v -pprTickCts (AltMerge v) = ppr v -pprTickCts (CaseElim v) = ppr v -pprTickCts (CaseIdentity v) = ppr v -pprTickCts (FillInCaseDefault v) = ppr v -pprTickCts _ = Outputable.empty - -cmpTick :: Tick -> Tick -> Ordering -cmpTick a b = case (tickToTag a `compare` tickToTag b) of - GT -> GT - EQ -> cmpEqTick a b - LT -> LT - -cmpEqTick :: Tick -> Tick -> Ordering -cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b -cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b -cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b -cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b -cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b -cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b -cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b -cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b -cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b -cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b -cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b -cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b -cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b -cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b -cmpEqTick _ _ = EQ - -{- -************************************************************************ -* * - Monad and carried data structure definitions -* * -************************************************************************ --} - -data CoreReader = CoreReader { - cr_hsc_env :: HscEnv, - cr_rule_base :: RuleBase, - cr_module :: Module, - cr_print_unqual :: PrintUnqualified, - cr_loc :: SrcSpan, -- Use this for log/error messages so they - -- are at least tagged with the right source file - cr_visible_orphan_mods :: !ModuleSet, - cr_uniq_mask :: !Char -- Mask for creating unique values -} - --- Note: CoreWriter used to be defined with data, rather than newtype. If it --- is defined that way again, the cw_simpl_count field, at least, must be --- strict to avoid a space leak (#7702). -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -emptyWriter :: DynFlags -> CoreWriter -emptyWriter dflags = CoreWriter { - cw_simpl_count = zeroSimplCount dflags - } - -plusWriter :: CoreWriter -> CoreWriter -> CoreWriter -plusWriter w1 w2 = CoreWriter { - cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) - } - -type CoreIOEnv = IOEnv CoreReader - --- | The monad used by Core-to-Core passes to register simplification statistics. --- Also used to have common state (in the form of UniqueSupply) for generating Uniques. -newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } - deriving (Functor) - -instance Monad CoreM where - mx >>= f = CoreM $ do - (x, w1) <- unCoreM mx - (y, w2) <- unCoreM (f x) - let w = w1 `plusWriter` w2 - return $ seq w (y, w) - -- forcing w before building the tuple avoids a space leak - -- (#7702) - -instance Applicative CoreM where - pure x = CoreM $ nop x - (<*>) = ap - m *> k = m >>= \_ -> k - -instance Alternative CoreM where - empty = CoreM Control.Applicative.empty - m <|> n = CoreM (unCoreM m <|> unCoreM n) - -instance MonadPlus CoreM - -instance MonadUnique CoreM where - getUniqueSupplyM = do - mask <- read cr_uniq_mask - liftIO $! mkSplitUniqSupply mask - - getUniqueM = do - mask <- read cr_uniq_mask - liftIO $! uniqFromMask mask - -runCoreM :: HscEnv - -> RuleBase - -> Char -- ^ Mask - -> Module - -> ModuleSet - -> PrintUnqualified - -> SrcSpan - -> CoreM a - -> IO (a, SimplCount) -runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m - = liftM extract $ runIOEnv reader $ unCoreM m - where - reader = CoreReader { - cr_hsc_env = hsc_env, - cr_rule_base = rule_base, - cr_module = mod, - cr_visible_orphan_mods = orph_imps, - cr_print_unqual = print_unqual, - cr_loc = loc, - cr_uniq_mask = mask - } - - extract :: (a, CoreWriter) -> (a, SimplCount) - extract (value, writer) = (value, cw_simpl_count writer) - -{- -************************************************************************ -* * - Core combinators, not exported -* * -************************************************************************ --} - -nop :: a -> CoreIOEnv (a, CoreWriter) -nop x = do - r <- getEnv - return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) - -read :: (CoreReader -> a) -> CoreM a -read f = CoreM $ getEnv >>= (\r -> nop (f r)) - -write :: CoreWriter -> CoreM () -write w = CoreM $ return ((), w) - --- \subsection{Lifting IO into the monad} - --- | Lift an 'IOEnv' operation into 'CoreM' -liftIOEnv :: CoreIOEnv a -> CoreM a -liftIOEnv mx = CoreM (mx >>= (\x -> nop x)) - -instance MonadIO CoreM where - liftIO = liftIOEnv . IOEnv.liftIO - --- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' -liftIOWithCount :: IO (SimplCount, a) -> CoreM a -liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) - -{- -************************************************************************ -* * - Reader, writer and state accessors -* * -************************************************************************ --} - -getHscEnv :: CoreM HscEnv -getHscEnv = read cr_hsc_env - -getRuleBase :: CoreM RuleBase -getRuleBase = read cr_rule_base - -getVisibleOrphanMods :: CoreM ModuleSet -getVisibleOrphanMods = read cr_visible_orphan_mods - -getPrintUnqualified :: CoreM PrintUnqualified -getPrintUnqualified = read cr_print_unqual - -getSrcSpanM :: CoreM SrcSpan -getSrcSpanM = read cr_loc - -addSimplCount :: SimplCount -> CoreM () -addSimplCount count = write (CoreWriter { cw_simpl_count = count }) - -getUniqMask :: CoreM Char -getUniqMask = read cr_uniq_mask - --- Convenience accessors for useful fields of HscEnv - -instance HasDynFlags CoreM where - getDynFlags = fmap hsc_dflags getHscEnv - -instance HasModule CoreM where - getModule = read cr_module - --- | The original name cache is the current mapping from 'Module' and --- 'OccName' to a compiler-wide unique 'Name' -getOrigNameCache :: CoreM OrigNameCache -getOrigNameCache = do - nameCacheRef <- fmap hsc_NC getHscEnv - liftIO $ fmap nsNames $ readIORef nameCacheRef - -getPackageFamInstEnv :: CoreM PackageFamInstEnv -getPackageFamInstEnv = do - hsc_env <- getHscEnv - eps <- liftIO $ hscEPS hsc_env - return $ eps_fam_inst_env eps - -{- -************************************************************************ -* * - Dealing with annotations -* * -************************************************************************ --} - --- | Get all annotations of a given type. This happens lazily, that is --- no deserialization will take place until the [a] is actually demanded and --- the [a] can also be empty (the UniqFM is not filtered). --- --- This should be done once at the start of a Core-to-Core pass that uses --- annotations. --- --- See Note [Annotations] -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) -getAnnotations deserialize guts = do - hsc_env <- getHscEnv - ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) - return (deserializeAnns deserialize ann_env) - --- | Get at most one annotation of a given type per Unique. -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) -getFirstAnnotations deserialize guts - = liftM (mapUFM head . filterUFM (not . null)) - $ getAnnotations deserialize guts - -{- -Note [Annotations] -~~~~~~~~~~~~~~~~~~ -A Core-to-Core pass that wants to make use of annotations calls -getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with -annotations of a specific type. This produces all annotations from interface -files read so far. However, annotations from interface files read during the -pass will not be visible until getAnnotations is called again. This is similar -to how rules work and probably isn't too bad. - -The current implementation could be optimised a bit: when looking up -annotations for a thing from the HomePackageTable, we could search directly in -the module where the thing is defined rather than building one UniqFM which -contains all annotations we know of. This would work because annotations can -only be given to things defined in the same module. However, since we would -only want to deserialise every annotation once, we would have to build a cache -for every module in the HTP. In the end, it's probably not worth it as long as -we aren't using annotations heavily. - -************************************************************************ -* * - Direct screen output -* * -************************************************************************ --} - -msg :: Severity -> WarnReason -> SDoc -> CoreM () -msg sev reason doc - = do { dflags <- getDynFlags - ; loc <- getSrcSpanM - ; unqual <- getPrintUnqualified - ; let sty = case sev of - SevError -> err_sty - SevWarning -> err_sty - SevDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle dflags unqual - user_sty = mkUserStyle dflags unqual AllTheWay - dump_sty = mkDumpStyle dflags unqual - ; liftIO $ putLogMsg dflags reason sev loc sty doc } - --- | Output a String message to the screen -putMsgS :: String -> CoreM () -putMsgS = putMsg . text - --- | Output a message to the screen -putMsg :: SDoc -> CoreM () -putMsg = msg SevInfo NoReason - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsgS :: String -> CoreM () -errorMsgS = errorMsg . text - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsg :: SDoc -> CoreM () -errorMsg = msg SevError NoReason - -warnMsg :: WarnReason -> SDoc -> CoreM () -warnMsg = msg SevWarning - --- | Output a fatal error to the screen. Does not cause the compiler to die. -fatalErrorMsgS :: String -> CoreM () -fatalErrorMsgS = fatalErrorMsg . text - --- | Output a fatal error to the screen. Does not cause the compiler to die. -fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg SevFatal NoReason - --- | Output a string debugging message at verbosity level of @-v@ or higher -debugTraceMsgS :: String -> CoreM () -debugTraceMsgS = debugTraceMsg . text - --- | Outputs a debugging message at verbosity level of @-v@ or higher -debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg SevDump NoReason - --- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher -dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () -dumpIfSet_dyn flag str doc - = do { dflags <- getDynFlags - ; unqual <- getPrintUnqualified - ; when (dopt flag dflags) $ liftIO $ - Err.dumpSDoc dflags unqual flag str doc } diff --git a/simplCore/CoreMonad.hs-boot b/simplCore/CoreMonad.hs-boot deleted file mode 100644 --- a/simplCore/CoreMonad.hs-boot +++ /dev/null @@ -1,30 +0,0 @@ --- Created this hs-boot file to remove circular dependencies from the use of --- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core --- transformations. --- However CoreMonad does much more than defining these, and because Plugins are --- activated in various modules, the imports become circular. To solve this I --- extracted CoreToDo and CoreM into this file. --- I needed to write the whole definition of these types, otherwise it created --- a data-newtype conflict. - -module CoreMonad ( CoreToDo, CoreM ) where - -import GhcPrelude - -import IOEnv ( IOEnv ) - -type CoreIOEnv = IOEnv CoreReader - -data CoreReader - -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -data SimplCount - -newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } - -instance Monad CoreM - -data CoreToDo diff --git a/simplCore/Exitify.hs b/simplCore/Exitify.hs deleted file mode 100644 --- a/simplCore/Exitify.hs +++ /dev/null @@ -1,499 +0,0 @@ -module Exitify ( exitifyProgram ) where - -{- -Note [Exitification] -~~~~~~~~~~~~~~~~~~~~ - -This module implements Exitification. The goal is to pull as much code out of -recursive functions as possible, as the simplifier is better at inlining into -call-sites that are not in recursive functions. - -Example: - - let t = foo bar - joinrec go 0 x y = t (x*x) - go (n-1) x y = jump go (n-1) (x+y) - in … - -We’d like to inline `t`, but that does not happen: Because t is a thunk and is -used in a recursive function, doing so might lose sharing in general. In -this case, however, `t` is on the _exit path_ of `go`, so called at most once. -How do we make this clearly visible to the simplifier? - -A code path (i.e., an expression in a tail-recursive position) in a recursive -function is an exit path if it does not contain a recursive call. We can bind -this expression outside the recursive function, as a join-point. - -Example result: - - let t = foo bar - join exit x = t (x*x) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -Now `t` is no longer in a recursive function, and good things happen! --} - -import GhcPrelude -import Var -import Id -import IdInfo -import CoreSyn -import CoreUtils -import State -import Unique -import VarSet -import VarEnv -import CoreFVs -import FastString -import Type -import Util( mapSnd ) - -import Data.Bifunctor -import Control.Monad - --- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them. --- The really interesting function is exitifyRec -exitifyProgram :: CoreProgram -> CoreProgram -exitifyProgram binds = map goTopLvl binds - where - goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e) - goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs) - -- Top-level bindings are never join points - - in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds - - go :: InScopeSet -> CoreExpr -> CoreExpr - go _ e@(Var{}) = e - go _ e@(Lit {}) = e - go _ e@(Type {}) = e - go _ e@(Coercion {}) = e - go in_scope (Cast e' c) = Cast (go in_scope e') c - go in_scope (Tick t e') = Tick t (go in_scope e') - go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2) - - go in_scope (Lam v e') - = Lam v (go in_scope' e') - where in_scope' = in_scope `extendInScopeSet` v - - go in_scope (Case scrut bndr ty alts) - = Case (go in_scope scrut) bndr ty (map go_alt alts) - where - in_scope1 = in_scope `extendInScopeSet` bndr - go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs) - where in_scope' = in_scope1 `extendInScopeSetList` pats - - go in_scope (Let (NonRec bndr rhs) body) - = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body) - where - in_scope' = in_scope `extendInScopeSet` bndr - - go in_scope (Let (Rec pairs) body) - | is_join_rec = mkLets (exitifyRec in_scope' pairs') body' - | otherwise = Let (Rec pairs') body' - where - is_join_rec = any (isJoinId . fst) pairs - in_scope' = in_scope `extendInScopeSetList` bindersOf (Rec pairs) - pairs' = mapSnd (go in_scope') pairs - body' = go in_scope' body - - --- | State Monad used inside `exitify` -type ExitifyM = State [(JoinId, CoreExpr)] - --- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as --- join-points outside the joinrec. -exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind] -exitifyRec in_scope pairs - = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs'] - where - -- We need the set of free variables of many subexpressions here, so - -- annotate the AST with them - -- see Note [Calculating free variables] - ann_pairs = map (second freeVars) pairs - - -- Which are the recursive calls? - recursive_calls = mkVarSet $ map fst pairs - - (pairs',exits) = (`runState` []) $ do - forM ann_pairs $ \(x,rhs) -> do - -- go past the lambdas of the join point - let (args, body) = collectNAnnBndrs (idJoinArity x) rhs - body' <- go args body - let rhs' = mkLams args body' - return (x, rhs') - - --------------------- - -- 'go' is the main working function. - -- It goes through the RHS (tail-call positions only), - -- checks if there are no more recursive calls, if so, abstracts over - -- variables bound on the way and lifts it out as a join point. - -- - -- ExitifyM is a state monad to keep track of floated binds - go :: [Var] -- ^ Variables that are in-scope here, but - -- not in scope at the joinrec; that is, - -- we must potentially abstract over them. - -- Invariant: they are kept in dependency order - -> CoreExprWithFVs -- ^ Current expression in tail position - -> ExitifyM CoreExpr - - -- We first look at the expression (no matter what it shape is) - -- and determine if we can turn it into a exit join point - go captured ann_e - | -- An exit expression has no recursive calls - let fvs = dVarSetToVarSet (freeVarsOf ann_e) - , disjointVarSet fvs recursive_calls - = go_exit captured (deAnnotate ann_e) fvs - - -- We could not turn it into a exit joint point. So now recurse - -- into all expression where eligible exit join points might sit, - -- i.e. into all tail-call positions: - - -- Case right hand sides are in tail-call position - go captured (_, AnnCase scrut bndr ty alts) = do - alts' <- forM alts $ \(dc, pats, rhs) -> do - rhs' <- go (captured ++ [bndr] ++ pats) rhs - return (dc, pats, rhs') - return $ Case (deAnnotate scrut) bndr ty alts' - - go captured (_, AnnLet ann_bind body) - -- join point, RHS and body are in tail-call position - | AnnNonRec j rhs <- ann_bind - , Just join_arity <- isJoinId_maybe j - = do let (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ params) join_body - let rhs' = mkLams params join_body' - body' <- go (captured ++ [j]) body - return $ Let (NonRec j rhs') body' - - -- rec join point, RHSs and body are in tail-call position - | AnnRec pairs <- ann_bind - , isJoinId (fst (head pairs)) - = do let js = map fst pairs - pairs' <- forM pairs $ \(j,rhs) -> do - let join_arity = idJoinArity j - (params, join_body) = collectNAnnBndrs join_arity rhs - join_body' <- go (captured ++ js ++ params) join_body - let rhs' = mkLams params join_body' - return (j, rhs') - body' <- go (captured ++ js) body - return $ Let (Rec pairs') body' - - -- normal Let, only the body is in tail-call position - | otherwise - = do body' <- go (captured ++ bindersOf bind ) body - return $ Let bind body' - where bind = deAnnBind ann_bind - - -- Cannot be turned into an exit join point, but also has no - -- tail-call subexpression. Nothing to do here. - go _ ann_e = return (deAnnotate ann_e) - - --------------------- - go_exit :: [Var] -- Variables captured locally - -> CoreExpr -- An exit expression - -> VarSet -- Free vars of the expression - -> ExitifyM CoreExpr - -- go_exit deals with a tail expression that is floatable - -- out as an exit point; that is, it mentions no recursive calls - go_exit captured e fvs - -- Do not touch an expression that is already a join jump where all arguments - -- are captured variables. See Note [Idempotency] - -- But _do_ float join jumps with interesting arguments. - -- See Note [Jumps can be interesting] - | (Var f, args) <- collectArgs e - , isJoinId f - , all isCapturedVarArg args - = return e - - -- Do not touch a boring expression (see Note [Interesting expression]) - | not is_interesting - = return e - - -- Cannot float out if local join points are used, as - -- we cannot abstract over them - | captures_join_points - = return e - - -- We have something to float out! - | otherwise - = do { -- Assemble the RHS of the exit join point - let rhs = mkLams abs_vars e - avoid = in_scope `extendInScopeSetList` captured - -- Remember this binding under a suitable name - ; v <- addExit avoid (length abs_vars) rhs - -- And jump to it from here - ; return $ mkVarApps (Var v) abs_vars } - - where - -- Used to detect exit expressoins that are already proper exit jumps - isCapturedVarArg (Var v) = v `elem` captured - isCapturedVarArg _ = False - - -- An interesting exit expression has free, non-imported - -- variables from outside the recursive group - -- See Note [Interesting expression] - is_interesting = anyVarSet isLocalId $ - fvs `minusVarSet` mkVarSet captured - - -- The arguments of this exit join point - -- See Note [Picking arguments to abstract over] - abs_vars = snd $ foldr pick (fvs, []) captured - where - pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc) - | otherwise = (fvs', acc) - - -- We are going to abstract over these variables, so we must - -- zap any IdInfo they have; see #15005 - -- cf. SetLevels.abstractVars - zap v | isId v = setIdInfo v vanillaIdInfo - | otherwise = v - - -- We cannot abstract over join points - captures_join_points = any isJoinId abs_vars - - --- Picks a new unique, which is disjoint from --- * the free variables of the whole joinrec --- * any bound variables (captured) --- * any exit join points created so far. -mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId -mkExitJoinId in_scope ty join_arity = do - fs <- get - let avoid = in_scope `extendInScopeSetList` (map fst fs) - `extendInScopeSet` exit_id_tmpl -- just cosmetics - return (uniqAway avoid exit_id_tmpl) - where - exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty - `asJoinId` join_arity - -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_arity rhs = do - -- Pick a suitable name - let ty = exprType rhs - v <- mkExitJoinId in_scope ty join_arity - fs <- get - put ((v,rhs):fs) - return v - -{- -Note [Interesting expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want this to happen: - - joinrec go 0 x y = x - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x = x - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -because the floated exit path (`x`) is simply a parameter of `go`; there are -not useful interactions exposed this way. - -Neither do we want this to happen - - joinrec go 0 x y = x+x - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x = x+x - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -where the floated expression `x+x` is a bit more complicated, but still not -intersting. - -Expressions are interesting when they move an occurrence of a variable outside -the recursive `go` that can benefit from being obviously called once, for example: - * a local thunk that can then be inlined (see example in note [Exitification]) - * the parameter of a function, where the demand analyzer then can then - see that it is called at most once, and hence improve the function’s - strictness signature - -So we only hoist an exit expression out if it mentiones at least one free, -non-imported variable. - -Note [Jumps can be interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A jump to a join point can be interesting, if its arguments contain free -non-exported variables (z in the following example): - - joinrec go 0 x y = jump j (x+z) - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x y = jump j (x+z) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - - -The join point itself can be interesting, even if none if its -arguments have free variables free in the joinrec. For example - - join j p = case p of (x,y) -> x+y - joinrec go 0 x y = jump j (x,y) - go (n-1) x y = jump go (n-1) (x+y) y - in … - -Here, `j` would not be inlined because we do not inline something that looks -like an exit join point (see Note [Do not inline exit join points]). But -if we exitify the 'jump j (x,y)' we get - - join j p = case p of (x,y) -> x+y - join exit x y = jump j (x,y) - joinrec go 0 x y = jump exit x y - go (n-1) x y = jump go (n-1) (x+y) y - in … - -and now 'j' can inline, and we get rid of the pair. Here's another -example (assume `g` to be an imported function that, on its own, -does not make this interesting): - - join j y = map f y - joinrec go 0 x y = jump j (map g x) - go (n-1) x y = jump go (n-1) (x+y) - in … - -Again, `j` would not be inlined because we do not inline something that looks -like an exit join point (see Note [Do not inline exit join points]). - -But after exitification we have - - join j y = map f y - join exit x = jump j (map g x) - joinrec go 0 x y = jump j (map g x) - go (n-1) x y = jump go (n-1) (x+y) - in … - -and now we can inline `j` and this will allow `map/map` to fire. - - -Note [Idempotency] -~~~~~~~~~~~~~~~~~~ - -We do not want this to happen, where we replace the floated expression with -essentially the same expression: - - join exit x = t (x*x) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … -==> - join exit x = t (x*x) - join exit' x = jump exit x - joinrec go 0 x y = jump exit' x - go (n-1) x y = jump go (n-1) (x+y) - in … - -So when the RHS is a join jump, and all of its arguments are captured variables, -then we leave it in place. - -Note that `jump exit x` in this example looks interesting, as `exit` is a free -variable. Therefore, idempotency does not simply follow from floating only -interesting expressions. - -Note [Calculating free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have two options where to annotate the tree with free variables: - - A) The whole tree. - B) Each individual joinrec as we come across it. - -Downside of A: We pay the price on the whole module, even outside any joinrecs. -Downside of B: We pay the price per joinrec, possibly multiple times when -joinrecs are nested. - -Further downside of A: If the exitify function returns annotated expressions, -it would have to ensure that the annotations are correct. - -We therefore choose B, and calculate the free variables in `exitify`. - - -Note [Do not inline exit join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have - - let t = foo bar - join exit x = t (x*x) - joinrec go 0 x y = jump exit x - go (n-1) x y = jump go (n-1) (x+y) - in … - -we do not want the simplifier to simply inline `exit` back in (which it happily -would). - -To prevent this, we need to recognize exit join points, and then disable -inlining. - -Exit join points, recognizeable using `isExitJoinId` are join points with an -occurence in a recursive group, and can be recognized (after the occurence -analyzer ran!) using `isExitJoinId`. -This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, -because the lambdas of a non-recursive join point are not considered for -`occ_in_lam`. For example, in the following code, `j1` is /not/ marked -occ_in_lam, because `j2` is called only once. - - join j1 x = x+1 - join j2 y = join j1 (y+2) - -To prevent inlining, we check for isExitJoinId -* In `preInlineUnconditionally` directly. -* In `simplLetUnfolding` we simply give exit join points no unfolding, which - prevents inlining in `postInlineUnconditionally` and call sites. - -Note [Placement of the exitification pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I (Joachim) experimented with multiple positions for the Exitification pass in -the Core2Core pipeline: - - A) Before the `simpl_phases` - B) Between the `simpl_phases` and the "main" simplifier pass - C) After demand_analyser - D) Before the final simplification phase - -Here is the table (this is without inlining join exit points in the final -simplifier run): - - Program | Allocs | Instrs - | ABCD.log A.log B.log C.log D.log | ABCD.log A.log B.log C.log D.log -----------------|---------------------------------------------------|------------------------------------------------- - fannkuch-redux | -99.9% +0.0% -99.9% -99.9% -99.9% | -3.9% +0.5% -3.0% -3.9% -3.9% - fasta | -0.0% +0.0% +0.0% -0.0% -0.0% | -8.5% +0.0% +0.0% -0.0% -8.5% - fem | 0.0% 0.0% 0.0% 0.0% +0.0% | -2.2% -0.1% -0.1% -2.1% -2.1% - fish | 0.0% 0.0% 0.0% 0.0% +0.0% | -3.1% +0.0% -1.1% -1.1% -0.0% - k-nucleotide | -91.3% -91.0% -91.0% -91.3% -91.3% | -6.3% +11.4% +11.4% -6.3% -6.2% - scs | -0.0% -0.0% -0.0% -0.0% -0.0% | -3.4% -3.0% -3.1% -3.3% -3.3% - simple | -6.0% 0.0% -6.0% -6.0% +0.0% | -3.4% +0.0% -5.2% -3.4% -0.1% - spectral-norm | -0.0% 0.0% 0.0% -0.0% +0.0% | -2.7% +0.0% -2.7% -5.4% -5.4% -----------------|---------------------------------------------------|------------------------------------------------- - Min | -95.0% -91.0% -95.0% -95.0% -95.0% | -8.5% -3.0% -5.2% -6.3% -8.5% - Max | +0.2% +0.2% +0.2% +0.2% +1.5% | +0.4% +11.4% +11.4% +0.4% +1.5% - Geometric Mean | -4.7% -2.1% -4.7% -4.7% -4.6% | -0.4% +0.1% -0.1% -0.3% -0.2% - -Position A is disqualified, as it does not get rid of the allocations in -fannkuch-redux. -Position A and B are disqualified because it increases instructions in k-nucleotide. -Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta. - -Assuming we have a budget of _one_ run of Exitification, then C wins (but we -could get more from running it multiple times, as seen in fish). - -Note [Picking arguments to abstract over] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When we create an exit join point, so we need to abstract over those of its -free variables that are be out-of-scope at the destination of the exit join -point. So we go through the list `captured` and pick those that are actually -free variables of the join point. - -We do not just `filter (`elemVarSet` fvs) captured`, as there might be -shadowing, and `captured` may contain multiple variables with the same Unique. I -these cases we want to abstract only over the last occurence, hence the `foldr` -(with emphasis on the `r`). This is #15110. - --} diff --git a/simplCore/FloatIn.hs b/simplCore/FloatIn.hs deleted file mode 100644 --- a/simplCore/FloatIn.hs +++ /dev/null @@ -1,771 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -************************************************************************ -* * -\section[FloatIn]{Floating Inwards pass} -* * -************************************************************************ - -The main purpose of @floatInwards@ is floating into branches of a -case, so that we don't allocate things, save them on the stack, and -then discover that they aren't needed in the chosen branch. --} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fprof-auto #-} - -module FloatIn ( floatInwards ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import MkCore hiding ( wrapFloats ) -import HscTypes ( ModGuts(..) ) -import CoreUtils -import CoreFVs -import CoreMonad ( CoreM ) -import Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) -import Var -import Type -import VarSet -import Util -import DynFlags -import Outputable --- import Data.List ( mapAccumL ) -import BasicTypes ( RecFlag(..), isRec ) - -{- -Top-level interface function, @floatInwards@. Note that we do not -actually float any bindings downwards from the top-level. --} - -floatInwards :: ModGuts -> CoreM ModGuts -floatInwards pgm@(ModGuts { mg_binds = binds }) - = do { dflags <- getDynFlags - ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) } - where - fi_top_bind dflags (NonRec binder rhs) - = NonRec binder (fiExpr dflags [] (freeVars rhs)) - fi_top_bind dflags (Rec pairs) - = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ] - - -{- -************************************************************************ -* * -\subsection{Mail from Andr\'e [edited]} -* * -************************************************************************ - -{\em Will wrote: What??? I thought the idea was to float as far -inwards as possible, no matter what. This is dropping all bindings -every time it sees a lambda of any kind. Help! } - -You are assuming we DO DO full laziness AFTER floating inwards! We -have to [not float inside lambdas] if we don't. - -If we indeed do full laziness after the floating inwards (we could -check the compilation flags for that) then I agree we could be more -aggressive and do float inwards past lambdas. - -Actually we are not doing a proper full laziness (see below), which -was another reason for not floating inwards past a lambda. - -This can easily be fixed. The problem is that we float lets outwards, -but there are a few expressions which are not let bound, like case -scrutinees and case alternatives. After floating inwards the -simplifier could decide to inline the let and the laziness would be -lost, e.g. - -\begin{verbatim} -let a = expensive ==> \b -> case expensive of ... -in \ b -> case a of ... -\end{verbatim} -The fix is -\begin{enumerate} -\item -to let bind the algebraic case scrutinees (done, I think) and -the case alternatives (except the ones with an -unboxed type)(not done, I think). This is best done in the -SetLevels.hs module, which tags things with their level numbers. -\item -do the full laziness pass (floating lets outwards). -\item -simplify. The simplifier inlines the (trivial) lets that were - created but were not floated outwards. -\end{enumerate} - -With the fix I think Will's suggestion that we can gain even more from -strictness by floating inwards past lambdas makes sense. - -We still gain even without going past lambdas, as things may be -strict in the (new) context of a branch (where it was floated to) or -of a let rhs, e.g. -\begin{verbatim} -let a = something case x of -in case x of alt1 -> case something of a -> a + a - alt1 -> a + a ==> alt2 -> b - alt2 -> b - -let a = something let b = case something of a -> a + a -in let b = a + a ==> in (b,b) -in (b,b) -\end{verbatim} -Also, even if a is not found to be strict in the new context and is -still left as a let, if the branch is not taken (or b is not entered) -the closure for a is not built. - -************************************************************************ -* * -\subsection{Main floating-inwards code} -* * -************************************************************************ --} - -type FreeVarSet = DIdSet -type BoundVarSet = DIdSet - -data FloatInBind = FB BoundVarSet FreeVarSet FloatBind - -- The FreeVarSet is the free variables of the binding. In the case - -- of recursive bindings, the set doesn't include the bound - -- variables. - -type FloatInBinds = [FloatInBind] - -- In reverse dependency order (innermost binder first) - -fiExpr :: DynFlags - -> FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreExprWithFVs -- Input expr - -> CoreExpr -- Result - -fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) - -- See Note [Dead bindings] -fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) -fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr dflags to_drop (_, AnnCast expr (co_ann, co)) - = wrapFloats (drop_here ++ co_drop) $ - Cast (fiExpr dflags e_drop expr) co - where - [drop_here, e_drop, co_drop] - = sepBindsByDropPoint dflags False - [freeVarsOf expr, freeVarsOfAnn co_ann] - to_drop - -{- -Applications: we do float inside applications, mainly because we -need to get at all the arguments. The next simplifier run will -pull out any silly ones. --} - -fiExpr dflags to_drop ann_expr@(_,AnnApp {}) - = wrapFloats drop_here $ wrapFloats extra_drop $ - mkTicks ticks $ - mkApps (fiExpr dflags fun_drop ann_fun) - (zipWith (fiExpr dflags) arg_drops ann_args) - where - (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr - fun_ty = exprType (deAnnotate ann_fun) - fun_fvs = freeVarsOf ann_fun - arg_fvs = map freeVarsOf ann_args - - (drop_here : extra_drop : fun_drop : arg_drops) - = sepBindsByDropPoint dflags False - (extra_fvs : fun_fvs : arg_fvs) - to_drop - -- Shortcut behaviour: if to_drop is empty, - -- sepBindsByDropPoint returns a suitable bunch of empty - -- lists without evaluating extra_fvs, and hence without - -- peering into each argument - - (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args - extra_fvs0 = case ann_fun of - (_, AnnVar _) -> fun_fvs - _ -> emptyDVarSet - -- Don't float the binding for f into f x y z; see Note [Join points] - -- for why we *can't* do it when f is a join point. (If f isn't a - -- join point, floating it in isn't especially harmful but it's - -- useless since the simplifier will immediately float it back out.) - - add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet) - add_arg (fun_ty, extra_fvs) (_, AnnType ty) - = (piResultTy fun_ty ty, extra_fvs) - - add_arg (fun_ty, extra_fvs) (arg_fvs, arg) - | noFloatIntoArg arg arg_ty - = (res_ty, extra_fvs `unionDVarSet` arg_fvs) - | otherwise - = (res_ty, extra_fvs) - where - (arg_ty, res_ty) = splitFunTy fun_ty - -{- Note [Dead bindings] -~~~~~~~~~~~~~~~~~~~~~~~ -At a literal we won't usually have any floated bindings; the -only way that can happen is if the binding wrapped the literal -/in the original input program/. e.g. - case x of { DEFAULT -> 1# } -But, while this may be unusual it is not actually wrong, and it did -once happen (#15696). - -Note [Do not destroy the let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Watch out for - f (x +# y) -We don't want to float bindings into here - f (case ... of { x -> x +# y }) -because that might destroy the let/app invariant, which requires -unlifted function arguments to be ok-for-speculation. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -Generally, we don't need to worry about join points - there are places we're -not allowed to float them, but since they can't have occurrences in those -places, we're not tempted. - -We do need to be careful about jumps, however: - - joinrec j x y z = ... in - jump j a b c - -Previous versions often floated the definition of a recursive function into its -only non-recursive occurrence. But for a join point, this is a disaster: - - (joinrec j x y z = ... in - jump j) a b c -- wrong! - -Every jump must be exact, so the jump to j must have three arguments. Hence -we're careful not to float into the target of a jump (though we can float into -the arguments just fine). - -Note [Floating in past a lambda group] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We must be careful about floating inside a value lambda. - That risks losing laziness. - The float-out pass might rescue us, but then again it might not. - -* We must be careful about type lambdas too. At one time we did, and - there is no risk of duplicating work thereby, but we do need to be - careful. In particular, here is a bad case (it happened in the - cichelli benchmark: - let v = ... - in let f = /\t -> \a -> ... - ==> - let f = /\t -> let v = ... in \a -> ... - This is bad as now f is an updatable closure (update PAP) - and has arity 0. - -* Hack alert! We only float in through one-shot lambdas, - not (as you might guess) through lone big lambdas. - Reason: we float *out* past big lambdas (see the test in the Lam - case of FloatOut.floatExpr) and we don't want to float straight - back in again. - - It *is* important to float into one-shot lambdas, however; - see the remarks with noFloatIntoRhs. - -So we treat lambda in groups, using the following rule: - - Float in if (a) there is at least one Id, - and (b) there are no non-one-shot Ids - - Otherwise drop all the bindings outside the group. - -This is what the 'go' function in the AnnLam case is doing. - -(Join points are handled similarly: a join point is considered one-shot iff -it's non-recursive, so we float only into non-recursive join points.) - -Urk! if all are tyvars, and we don't float in, we may miss an - opportunity to float inside a nested case branch - - -Note [Floating coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We could, in principle, have a coercion binding like - case f x of co { DEFAULT -> e1 e2 } -It's not common to have a function that returns a coercion, but nothing -in Core prohibits it. If so, 'co' might be mentioned in e1 or e2 -/only in a type/. E.g. suppose e1 was - let (x :: Int |> co) = blah in blah2 - - -But, with coercions appearing in types, there is a complication: we -might be floating in a "strict let" -- that is, a case. Case expressions -mention their return type. We absolutely can't float a coercion binding -inward to the point that the type of the expression it's about to wrap -mentions the coercion. So we include the union of the sets of free variables -of the types of all the drop points involved. If any of the floaters -bind a coercion variable mentioned in any of the types, that binder must -be dropped right away. - --} - -fiExpr dflags to_drop lam@(_, AnnLam _ _) - | noFloatIntoLam bndrs -- Dump it all here - -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088 - = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body)) - - | otherwise -- Float inside - = mkLams bndrs (fiExpr dflags to_drop body) - - where - (bndrs, body) = collectAnnBndrs lam - -{- -We don't float lets inwards past an SCC. - ToDo: keep info on current cc, and when passing - one, if it is not the same, annotate all lets in binds with current - cc, change current cc to the new one and float binds into expr. --} - -fiExpr dflags to_drop (_, AnnTick tickish expr) - | tickish `tickishScopesLike` SoftScope - = Tick tickish (fiExpr dflags to_drop expr) - - | otherwise -- Wimp out for now - we could push values in - = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr)) - -{- -For @Lets@, the possible ``drop points'' for the \tr{to_drop} -bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, -or~(b2), in each of the RHSs of the pairs of a @Rec@. - -Note that we do {\em weird things} with this let's binding. Consider: -\begin{verbatim} -let - w = ... -in { - let v = ... w ... - in ... v .. w ... -} -\end{verbatim} -Look at the inner \tr{let}. As \tr{w} is used in both the bind and -body of the inner let, we could panic and leave \tr{w}'s binding where -it is. But \tr{v} is floatable further into the body of the inner let, and -{\em then} \tr{w} will also be only in the body of that inner let. - -So: rather than drop \tr{w}'s binding here, we add it onto the list of -things to drop in the outer let's body, and let nature take its -course. - -Note [extra_fvs (1): avoid floating into RHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider let x=\y....t... in body. We do not necessarily want to float -a binding for t into the RHS, because it'll immediately be floated out -again. (It won't go inside the lambda else we risk losing work.) -In letrec, we need to be more careful still. We don't want to transform - let x# = y# +# 1# - in - letrec f = \z. ...x#...f... - in ... -into - letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... -because now we can't float the let out again, because a letrec -can't have unboxed bindings. - -So we make "extra_fvs" which is the rhs_fvs of such bindings, and -arrange to dump bindings that bind extra_fvs before the entire let. - -Note [extra_fvs (2): free variables of rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let x{rule mentioning y} = rhs in body -Here y is not free in rhs or body; but we still want to dump bindings -that bind y outside the let. So we augment extra_fvs with the -idRuleAndUnfoldingVars of x. No need for type variables, hence not using -idFreeVars. --} - -fiExpr dflags to_drop (_,AnnLet bind body) - = fiExpr dflags (after ++ new_float : before) body - -- to_drop is in reverse dependency order - where - (before, new_float, after) = fiBind dflags to_drop bind body_fvs - body_fvs = freeVarsOf body - -{- Note [Floating primops] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try to float-in a case expression over an unlifted type. The -motivating example was #5658: in particular, this change allows -array indexing operations, which have a single DEFAULT alternative -without any binders, to be floated inward. - -SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed -scalars also need to be floated inward, but unpacks have a single non-DEFAULT -alternative that binds the elements of the tuple. We now therefore also support -floating in cases with a single alternative that may bind values. - -But there are wrinkles - -* Which unlifted cases do we float? See PrimOp.hs - Note [PrimOp can_fail and has_side_effects] which explains: - - We can float-in can_fail primops, but we can't float them out. - - But we can float a has_side_effects primop, but NOT inside a lambda, - so for now we don't float them at all. - Hence exprOkForSideEffects - -* Because we can float can-fail primops (array indexing, division) inwards - but not outwards, we must be careful not to transform - case a /# b of r -> f (F# r) - ===> - f (case a /# b of r -> F# r) - because that creates a new thunk that wasn't there before. And - because it can't be floated out (can_fail), the thunk will stay - there. Disaster! (This happened in nofib 'simple' and 'scs'.) - - Solution: only float cases into the branches of other cases, and - not into the arguments of an application, or the RHS of a let. This - is somewhat conservative, but it's simple. And it still hits the - cases like #5658. This is implemented in sepBindsByJoinPoint; - if is_case is False we dump all floating cases right here. - -* #14511 is another example of why we want to restrict float-in - of case-expressions. Consider - case indexArray# a n of (# r #) -> writeArray# ma i (f r) - Now, floating that indexing operation into the (f r) thunk will - not create any new thunks, but it will keep the array 'a' alive - for much longer than the programmer expected. - - So again, not floating a case into a let or argument seems like - the Right Thing - -For @Case@, the possible drop points for the 'to_drop' -bindings are: - (a) inside the scrutinee - (b) inside one of the alternatives/default (default FVs always /first/!). - --} - -fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) - | isUnliftedType (idType case_bndr) - , exprOkForSideEffects (deAnnotate scrut) - -- See Note [Floating primops] - = wrapFloats shared_binds $ - fiExpr dflags (case_float : rhs_binds) rhs - where - case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs - (FloatCase scrut' case_bndr con alt_bndrs) - scrut' = fiExpr dflags scrut_binds scrut - rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) - scrut_fvs = freeVarsOf scrut - - [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint dflags False - [scrut_fvs, rhs_fvs] - to_drop - -fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) - = wrapFloats drop_here1 $ - wrapFloats drop_here2 $ - Case (fiExpr dflags scrut_drops scrut) case_bndr ty - (zipWith fi_alt alts_drops_s alts) - where - -- Float into the scrut and alts-considered-together just like App - [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint dflags False - [scrut_fvs, all_alts_fvs] - to_drop - - -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) - | [ _ ] <- alts = [] : [alts_drops] - | otherwise = sepBindsByDropPoint dflags True alts_fvs alts_drops - - scrut_fvs = freeVarsOf scrut - alts_fvs = map alt_fvs alts - all_alts_fvs = unionDVarSets alts_fvs - alt_fvs (_con, args, rhs) - = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) - -- Delete case_bndr and args from free vars of rhs - -- to get free vars of alt - - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs) - ------------------- -fiBind :: DynFlags - -> FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreBindWithFVs -- Input binding - -> DVarSet -- Free in scope of binding - -> ( FloatInBinds -- Land these before - , FloatInBind -- The binding itself - , FloatInBinds) -- Land these after - -fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs - = ( extra_binds ++ shared_binds -- Land these before - -- See Note [extra_fvs (1,2)] - , FB (unitDVarSet id) rhs_fvs' -- The new binding itself - (FloatLet (NonRec id rhs')) - , body_binds ) -- Land these after - - where - body_fvs2 = body_fvs `delDVarSet` id - - rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] - extra_fvs | noFloatIntoRhs NonRecursive id rhs - = rule_fvs `unionDVarSet` rhs_fvs - | otherwise - = rule_fvs - -- See Note [extra_fvs (1): avoid floating into RHS] - -- No point in floating in only to float straight out again - -- We *can't* float into ok-for-speculation unlifted RHSs - -- But do float into join points - - [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint dflags False - [extra_fvs, rhs_fvs, body_fvs2] - to_drop - - -- Push rhs_binds into the right hand side of the binding - rhs' = fiRhs dflags rhs_binds id ann_rhs - rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs - -- Don't forget the rule_fvs; the binding mentions them! - -fiBind dflags to_drop (AnnRec bindings) body_fvs - = ( extra_binds ++ shared_binds - , FB (mkDVarSet ids) rhs_fvs' - (FloatLet (Rec (fi_bind rhss_binds bindings))) - , body_binds ) - where - (ids, rhss) = unzip bindings - rhss_fvs = map freeVarsOf rhss - - -- See Note [extra_fvs (1,2)] - rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids - extra_fvs = rule_fvs `unionDVarSet` - unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings - , noFloatIntoRhs Recursive bndr rhs ] - - (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint dflags False - (extra_fvs:body_fvs:rhss_fvs) - to_drop - - rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` - unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` - rule_fvs -- Don't forget the rule variables! - - -- Push rhs_binds into the right hand side of the binding - fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss - -> [(Id, CoreExprWithFVs)] - -> [(Id, CoreExpr)] - - fi_bind to_drops pairs - = [ (binder, fiRhs dflags to_drop binder rhs) - | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] - ------------------- -fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr -fiRhs dflags to_drop bndr rhs - | Just join_arity <- isJoinId_maybe bndr - , let (bndrs, body) = collectNAnnBndrs join_arity rhs - = mkLams bndrs (fiExpr dflags to_drop body) - | otherwise - = fiExpr dflags to_drop rhs - ------------------- -noFloatIntoLam :: [Var] -> Bool -noFloatIntoLam bndrs = any bad bndrs - where - bad b = isId b && not (isOneShotBndr b) - -- Don't float inside a non-one-shot lambda - -noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool --- ^ True if it's a bad idea to float bindings into this RHS -noFloatIntoRhs is_rec bndr rhs - | isJoinId bndr - = isRec is_rec -- Joins are one-shot iff non-recursive - - | otherwise - = noFloatIntoArg rhs (idType bndr) - -noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool -noFloatIntoArg expr expr_ty - | isUnliftedType expr_ty - = True -- See Note [Do not destroy the let/app invariant] - - | AnnLam bndr e <- expr - , (bndrs, _) <- collectAnnBndrs e - = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a) - || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b) - -- See Note [noFloatInto considerations] wrinkle 2 - - | otherwise -- Note [noFloatInto considerations] wrinkle 2 - = exprIsTrivial deann_expr || exprIsHNF deann_expr - where - deann_expr = deAnnotate' expr - -{- Note [noFloatInto considerations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When do we want to float bindings into - - noFloatIntoRHs: the RHS of a let-binding - - noFloatIntoArg: the argument of a function application - -Definitely don't float in if it has unlifted type; that -would destroy the let/app invariant. - -* Wrinkle 1: do not float in if - (a) any non-one-shot value lambdas - or (b) all type lambdas - In both cases we'll float straight back out again - NB: Must line up with fiExpr (AnnLam...); see #7088 - - (a) is important: we /must/ float into a one-shot lambda group - (which includes join points). This makes a big difference - for things like - f x# = let x = I# x# - in let j = \() -> ...x... - in if then normal-path else j () - If x is used only in the error case join point, j, we must float the - boxing constructor into it, else we box it every time which is very - bad news indeed. - -* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right - back out again... not tragic, but a waste of time. - - For function arguments we will still end up with this - in-then-out stuff; consider - letrec x = e in f x - Here x is not a HNF, so we'll produce - f (letrec x = e in x) - which is OK... it's not that common, and we'll end up - floating out again, in CorePrep if not earlier. - Still, we use exprIsTrivial to catch this case (sigh) - - -************************************************************************ -* * -\subsection{@sepBindsByDropPoint@} -* * -************************************************************************ - -This is the crucial function. The idea is: We have a wad of bindings -that we'd like to distribute inside a collection of {\em drop points}; -insides the alternatives of a \tr{case} would be one example of some -drop points; the RHS and body of a non-recursive \tr{let} binding -would be another (2-element) collection. - -So: We're given a list of sets-of-free-variables, one per drop point, -and a list of floating-inwards bindings. If a binding can go into -only one drop point (without suddenly making something out-of-scope), -in it goes. If a binding is used inside {\em multiple} drop points, -then it has to go in a you-must-drop-it-above-all-these-drop-points -point. - -We have to maintain the order on these drop-point-related lists. --} - --- pprFIB :: FloatInBinds -> SDoc --- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] - -sepBindsByDropPoint - :: DynFlags - -> Bool -- True <=> is case expression - -> [FreeVarSet] -- One set of FVs per drop point - -- Always at least two long! - -> FloatInBinds -- Candidate floaters - -> [FloatInBinds] -- FIRST one is bindings which must not be floated - -- inside any drop point; the rest correspond - -- one-to-one with the input list of FV sets - --- Every input floater is returned somewhere in the result; --- none are dropped, not even ones which don't seem to be --- free in *any* of the drop-point fvs. Why? Because, for example, --- a binding (let x = E in B) might have a specialised version of --- x (say x') stored inside x, but x' isn't free in E or B. - -type DropBox = (FreeVarSet, FloatInBinds) - -sepBindsByDropPoint dflags is_case drop_pts floaters - | null floaters -- Shortcut common case - = [] : [[] | _ <- drop_pts] - - | otherwise - = ASSERT( drop_pts `lengthAtLeast` 2 ) - go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts)) - where - n_alts = length drop_pts - - go :: FloatInBinds -> [DropBox] -> [FloatInBinds] - -- The *first* one in the argument list is the drop_here set - -- The FloatInBinds in the lists are in the reverse of - -- the normal FloatInBinds order; that is, they are the right way round! - - go [] drop_boxes = map (reverse . snd) drop_boxes - - go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) - = go binds new_boxes - where - -- "here" means the group of bindings dropped at the top of the fork - - (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs - | (fvs, _) <- drop_boxes] - - drop_here = used_here || cant_push - - n_used_alts = count id used_in_flags -- returns number of Trues in list. - - cant_push - | is_case = n_used_alts == n_alts -- Used in all, don't push - -- Remember n_alts > 1 - || (n_used_alts > 1 && not (floatIsDupable dflags bind)) - -- floatIsDupable: see Note [Duplicating floats] - - | otherwise = floatIsCase bind || n_used_alts > 1 - -- floatIsCase: see Note [Floating primops] - - new_boxes | drop_here = (insert here_box : fork_boxes) - | otherwise = (here_box : new_fork_boxes) - - new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe - fork_boxes used_in_flags - - insert :: DropBox -> DropBox - insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops) - - insert_maybe box True = insert box - insert_maybe box False = box - - go _ _ = panic "sepBindsByDropPoint/go" - - -{- Note [Duplicating floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For case expressions we duplicate the binding if it is reasonably -small, and if it is not used in all the RHSs This is good for -situations like - let x = I# y in - case e of - C -> error x - D -> error x - E -> ...not mentioning x... - -If the thing is used in all RHSs there is nothing gained, -so we don't duplicate then. --} - -floatedBindsFVs :: FloatInBinds -> FreeVarSet -floatedBindsFVs binds = mapUnionDVarSet fbFVs binds - -fbFVs :: FloatInBind -> DVarSet -fbFVs (FB _ fvs _) = fvs - -wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr --- Remember FloatInBinds is in *reverse* dependency order -wrapFloats [] e = e -wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) - -floatIsDupable :: DynFlags -> FloatBind -> Bool -floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut -floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs -floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r - -floatIsCase :: FloatBind -> Bool -floatIsCase (FloatCase {}) = True -floatIsCase (FloatLet {}) = False diff --git a/simplCore/FloatOut.hs b/simplCore/FloatOut.hs deleted file mode 100644 --- a/simplCore/FloatOut.hs +++ /dev/null @@ -1,755 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[FloatOut]{Float bindings outwards (towards the top level)} - -``Long-distance'' floating of bindings towards the top level. --} - -{-# LANGUAGE CPP #-} - -module FloatOut ( floatOutwards ) where - -import GhcPrelude - -import CoreSyn -import CoreUtils -import MkCore -import CoreArity ( etaExpand ) -import CoreMonad ( FloatOutSwitches(..) ) - -import DynFlags -import ErrUtils ( dumpIfSet_dyn ) -import Id ( Id, idArity, idType, isBottomingId, - isJoinId, isJoinId_maybe ) -import SetLevels -import UniqSupply ( UniqSupply ) -import Bag -import Util -import Maybes -import Outputable -import Type -import qualified Data.IntMap as M - -import Data.List ( partition ) - -#include "HsVersions.h" - -{- - ----------------- - Overall game plan - ----------------- - -The Big Main Idea is: - - To float out sub-expressions that can thereby get outside - a non-one-shot value lambda, and hence may be shared. - - -To achieve this we may need to do two things: - - a) Let-bind the sub-expression: - - f (g x) ==> let lvl = f (g x) in lvl - - Now we can float the binding for 'lvl'. - - b) More than that, we may need to abstract wrt a type variable - - \x -> ... /\a -> let v = ...a... in .... - - Here the binding for v mentions 'a' but not 'x'. So we - abstract wrt 'a', to give this binding for 'v': - - vp = /\a -> ...a... - v = vp a - - Now the binding for vp can float out unimpeded. - I can't remember why this case seemed important enough to - deal with, but I certainly found cases where important floats - didn't happen if we did not abstract wrt tyvars. - -With this in mind we can also achieve another goal: lambda lifting. -We can make an arbitrary (function) binding float to top level by -abstracting wrt *all* local variables, not just type variables, leaving -a binding that can be floated right to top level. Whether or not this -happens is controlled by a flag. - - -Random comments -~~~~~~~~~~~~~~~ - -At the moment we never float a binding out to between two adjacent -lambdas. For example: - -@ - \x y -> let t = x+x in ... -===> - \x -> let t = x+x in \y -> ... -@ -Reason: this is less efficient in the case where the original lambda -is never partially applied. - -But there's a case I've seen where this might not be true. Consider: -@ -elEm2 x ys - = elem' x ys - where - elem' _ [] = False - elem' x (y:ys) = x==y || elem' x ys -@ -It turns out that this generates a subexpression of the form -@ - \deq x ys -> let eq = eqFromEqDict deq in ... -@ -which might usefully be separated to -@ - \deq -> let eq = eqFromEqDict deq in \xy -> ... -@ -Well, maybe. We don't do this at the moment. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -Every occurrence of a join point must be a tail call (see Note [Invariants on -join points] in CoreSyn), so we must be careful with how far we float them. The -mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling] -in SetLevels. For us, the significance is that a binder might be marked to be -dropped at the nearest boundary between tail calls and non-tail calls. For -example: - - (< join j = ... in - let x = < ... > in - case < ... > of - A -> ... - B -> ... - >) < ... > < ... > - -Here the join ceilings are marked with angle brackets. Either side of an -application is a join ceiling, as is the scrutinee position of a case -expression or the RHS of a let binding (but not a join point). - -Why do we *want* do float join points at all? After all, they're never -allocated, so there's no sharing to be gained by floating them. However, the -other benefit of floating is making RHSes small, and this can have a significant -impact. In particular, stream fusion has been known to produce nested loops like -this: - - joinrec j1 x1 = - joinrec j2 x2 = - joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... - in jump j3 x2 - in jump j2 x1 - in jump j1 x - -(Assume x1 and x2 do *not* occur free in j3.) - -Here j1 and j2 are wholly superfluous---each of them merely forwards its -argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make -everything one big mutual recursion: - - joinrec j1 x1 = jump j2 x1 - j2 x2 = jump j3 x2 - j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ... - in jump j1 x - -Now the simplifier will happily inline the trivial j1 and j2, leaving only j3. -Without floating, we're stuck with three loops instead of one. - -************************************************************************ -* * -\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} -* * -************************************************************************ --} - -floatOutwards :: FloatOutSwitches - -> DynFlags - -> UniqSupply - -> CoreProgram -> IO CoreProgram - -floatOutwards float_sws dflags us pgm - = do { - let { annotated_w_levels = setLevels float_sws pgm us ; - (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) - } ; - - dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" - (vcat (map ppr annotated_w_levels)); - - let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - - dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" - (hcat [ int tlets, text " Lets floated to top level; ", - int ntlets, text " Lets floated elsewhere; from ", - int lams, text " Lambda groups"]); - - return (bagToList (unionManyBags binds_s')) - } - -floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) -floatTopBind bind - = case (floatBind bind) of { (fs, floats, bind') -> - let float_bag = flattenTopFloats floats - in case bind' of - -- bind' can't have unlifted values or join points, so can only be one - -- value bind, rec or non-rec (see comment on floatBind) - [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) - [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e) - _ -> pprPanic "floatTopBind" (ppr bind') } - -{- -************************************************************************ -* * -\subsection[FloatOut-Bind]{Floating in a binding (the business end)} -* * -************************************************************************ --} - -floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) - -- Returns a list with either - -- * A single non-recursive binding (value or join point), or - -- * The following, in order: - -- * Zero or more non-rec unlifted bindings - -- * One or both of: - -- * A recursive group of join binds - -- * A recursive group of value binds - -- See Note [Floating out of Rec rhss] for why things get arranged this way. -floatBind (NonRec (TB var _) rhs) - = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> - - -- A tiresome hack: - -- see Note [Bottoming floats: eta expansion] in SetLevels - let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' - | otherwise = rhs' - - in (fs, rhs_floats, [NonRec var rhs'']) } - -floatBind (Rec pairs) - = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> - let (new_ul_pairss, new_other_pairss) = unzip new_pairs - (new_join_pairs, new_l_pairs) = partition (isJoinId . fst) - (concat new_other_pairss) - -- Can't put the join points and the values in the same rec group - new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ] - | null new_l_pairs = [ Rec new_join_pairs ] - | otherwise = [ Rec new_l_pairs - , Rec new_join_pairs ] - new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ] - in - (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) } - where - do_pair :: (LevelledBndr, LevelledExpr) - -> (FloatStats, FloatBinds, - ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings - [(Id,CoreExpr)])) -- Join points and lifted value bindings - do_pair (TB name spec, rhs) - | isTopLvl dest_lvl -- See Note [floatBind for top level] - = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> - (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats) - [(name, rhs')]))} - | otherwise -- Note [Floating out of Rec rhss] - = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') -> - case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> - case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) -> - let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in - (fs, rhs_floats', (ul_pairs, pairs')) }}} - where - dest_lvl = floatSpecLevel spec - -splitRecFloats :: Bag FloatBind - -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings - [(Id,CoreExpr)], -- Join points and lifted value bindings - Bag FloatBind) -- A tail of further bindings --- The "tail" begins with a case --- See Note [Floating out of Rec rhss] -splitRecFloats fs - = go [] [] (bagToList fs) - where - go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b) - , not (isJoinId b) - = go ((b,r):ul_prs) prs fs - | otherwise - = go ul_prs ((b,r):prs) fs - go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs - go ul_prs prs fs = (reverse ul_prs, prs, - listToBag fs) - -- Order only matters for - -- non-rec - -installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr --- Note [Floating out of Rec rhss] -installUnderLambdas floats e - | isEmptyBag floats = e - | otherwise = go e - where - go (Lam b e) = Lam b (go e) - go e = install floats e - ---------------- -floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) -floatList _ [] = (zeroStats, emptyFloats, []) -floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> - case floatList f as of { (fs_as, binds_as, bs) -> - (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} - -{- -Note [Floating out of Rec rhss] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider Rec { f<1,0> = \xy. body } -From the body we may get some floats. The ones with level <1,0> must -stay here, since they may mention f. Ideally we'd like to make them -part of the Rec block pairs -- but we can't if there are any -FloatCases involved. - -Nor is it a good idea to dump them in the rhs, but outside the lambda - f = case x of I# y -> \xy. body -because now f's arity might get worse, which is Not Good. (And if -there's an SCC around the RHS it might not get better again. -See #5342.) - -So, gruesomely, we split the floats into - * the outer FloatLets, which can join the Rec, and - * an inner batch starting in a FloatCase, which are then - pushed *inside* the lambdas. -This loses full-laziness the rare situation where there is a -FloatCase and a Rec interacting. - -If there are unlifted FloatLets (that *aren't* join points) among the floats, -we can't add them to the recursive group without angering Core Lint, but since -they must be ok-for-speculation, they can't actually be making any recursive -calls, so we can safely pull them out and keep them non-recursive. - -(Why is something getting floated to <1,0> that doesn't make a recursive call? -The case that came up in testing was that f *and* the unlifted binding were -getting floated *to the same place*: - - \x<2,0> -> - ... <3,0> - letrec { f> = - ... let x'> = x +# 1# in ... - } in ... - -Everything gets labeled "float to <2,0>" because it all depends on x, but this -makes f and x' look mutually recursive when they're not. - -The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the -wip/join-points branch. - -TODO: This can probably be solved somehow in SetLevels. The difference between -"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very -important.) - -Note [floatBind for top level] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus - letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } -The binding for bar will be in the "tops" part of the floating binds, -and thus not partioned by floatBody. - -We could perhaps get rid of the 'tops' component of the floating binds, -but this case works just as well. - - -************************************************************************ - -\subsection[FloatOut-Expr]{Floating in expressions} -* * -************************************************************************ --} - -floatBody :: Level - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) - -floatBody lvl arg -- Used rec rhss, and case-alternative rhss - = case (floatExpr arg) of { (fsa, floats, arg') -> - case (partitionByLevel lvl floats) of { (floats', heres) -> - -- Dump bindings are bound here - (fsa, floats', install heres arg') }} - ------------------ - -{- Note [Floating past breakpoints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We used to disallow floating out of breakpoint ticks (see #10052). However, I -think this is too restrictive. - -Consider the case of an expression scoped over by a breakpoint tick, - - tick<...> (let x = ... in f x) - -In this case it is completely legal to float out x, despite the fact that -breakpoint ticks are scoped, - - let x = ... in (tick<...> f x) - -The reason here is that we know that the breakpoint will still be hit when the -expression is entered since the tick still scopes over the RHS. - --} - -floatExpr :: LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) -floatExpr (Var v) = (zeroStats, emptyFloats, Var v) -floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) -floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) -floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) - -floatExpr (App e a) - = case (atJoinCeiling $ floatExpr e) of { (fse, floats_e, e') -> - case (atJoinCeiling $ floatExpr a) of { (fsa, floats_a, a') -> - (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} - -floatExpr lam@(Lam (TB _ lam_spec) _) - = let (bndrs_w_lvls, body) = collectBinders lam - bndrs = [b | TB b _ <- bndrs_w_lvls] - bndr_lvl = asJoinCeilLvl (floatSpecLevel lam_spec) - -- All the binders have the same level - -- See SetLevels.lvlLamBndrs - -- Use asJoinCeilLvl to make this the join ceiling - in - case (floatBody bndr_lvl body) of { (fs, floats, body') -> - (add_to_stats fs floats, floats, mkLams bndrs body') } - -floatExpr (Tick tickish expr) - | tickish `tickishScopesLike` SoftScope -- not scoped, can just float - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } - - | not (tickishCounts tickish) || tickishCanSplit tickish - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - let -- Annotate bindings floated outwards past an scc expression - -- with the cc. We mark that cc as "duplicated", though. - annotated_defns = wrapTick (mkNoCount tickish) floating_defns - in - (fs, annotated_defns, Tick tickish expr') } - - -- Note [Floating past breakpoints] - | Breakpoint{} <- tickish - = case (floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Tick tickish expr') } - - | otherwise - = pprPanic "floatExpr tick" (ppr tickish) - -floatExpr (Cast expr co) - = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') -> - (fs, floating_defns, Cast expr' co) } - -floatExpr (Let bind body) - = case bind_spec of - FloatMe dest_lvl - -> case (floatBind bind) of { (fsb, bind_floats, binds') -> - case (floatExpr body) of { (fse, body_floats, body') -> - let new_bind_floats = foldr plusFloats emptyFloats - (map (unitLetFloat dest_lvl) binds') in - ( add_stats fsb fse - , bind_floats `plusFloats` new_bind_floats - `plusFloats` body_floats - , body') }} - - StayPut bind_lvl -- See Note [Avoiding unnecessary floating] - -> case (floatBind bind) of { (fsb, bind_floats, binds') -> - case (floatBody bind_lvl body) of { (fse, body_floats, body') -> - ( add_stats fsb fse - , bind_floats `plusFloats` body_floats - , foldr Let body' binds' ) }} - where - bind_spec = case bind of - NonRec (TB _ s) _ -> s - Rec ((TB _ s, _) : _) -> s - Rec [] -> panic "floatExpr:rec" - -floatExpr (Case scrut (TB case_bndr case_spec) ty alts) - = case case_spec of - FloatMe dest_lvl -- Case expression moves - | [(con@(DataAlt {}), bndrs, rhs)] <- alts - -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> - case floatExpr rhs of { (fsb, fdb, rhs') -> - let - float = unitCaseFloat dest_lvl scrut' - case_bndr con [b | TB b _ <- bndrs] - in - (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} - | otherwise - -> pprPanic "Floating multi-case" (ppr alts) - - StayPut bind_lvl -- Case expression stays put - -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> - case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> - (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') - }} - where - float_alt bind_lvl (con, bs, rhs) - = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } - -floatRhs :: CoreBndr - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) -floatRhs bndr rhs - | Just join_arity <- isJoinId_maybe bndr - , Just (bndrs, body) <- try_collect join_arity rhs [] - = case bndrs of - [] -> floatExpr rhs - (TB _ lam_spec):_ -> - let lvl = floatSpecLevel lam_spec in - case floatBody lvl body of { (fs, floats, body') -> - (fs, floats, mkLams [b | TB b _ <- bndrs] body') } - | otherwise - = atJoinCeiling $ floatExpr rhs - where - try_collect 0 expr acc = Just (reverse acc, expr) - try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc) - try_collect _ _ _ = Nothing - -{- -Note [Avoiding unnecessary floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we want to avoid floating a let unnecessarily, because -it might worsen strictness: - let - x = ...(let y = e in y+y).... -Here y is demanded. If we float it outside the lazy 'x=..' then -we'd have to zap its demand info, and it may never be restored. - -So at a 'let' we leave the binding right where the are unless -the binding will escape a value lambda, e.g. - -(\x -> let y = fac 100 in y) - -That's what the partitionByMajorLevel does in the floatExpr (Let ...) -case. - -Notice, though, that we must take care to drop any bindings -from the body of the let that depend on the staying-put bindings. - -We used instead to do the partitionByMajorLevel on the RHS of an '=', -in floatRhs. But that was quite tiresome. We needed to test for -values or trival rhss, because (in particular) we don't want to insert -new bindings between the "=" and the "\". E.g. - f = \x -> let in -We do not want - f = let in \x -> -(a) The simplifier will immediately float it further out, so we may - as well do so right now; in general, keeping rhss as manifest - values is good -(b) If a float-in pass follows immediately, it might add yet more - bindings just after the '='. And some of them might (correctly) - be strict even though the 'let f' is lazy, because f, being a value, - gets its demand-info zapped by the simplifier. -And even all that turned out to be very fragile, and broke -altogether when profiling got in the way. - -So now we do the partition right at the (Let..) itself. - -************************************************************************ -* * -\subsection{Utility bits for floating stats} -* * -************************************************************************ - -I didn't implement this with unboxed numbers. I don't want to be too -strict in this stuff, as it is rarely turned on. (WDP 95/09) --} - -data FloatStats - = FlS Int -- Number of top-floats * lambda groups they've been past - Int -- Number of non-top-floats * lambda groups they've been past - Int -- Number of lambda (groups) seen - -get_stats :: FloatStats -> (Int, Int, Int) -get_stats (FlS a b c) = (a, b, c) - -zeroStats :: FloatStats -zeroStats = FlS 0 0 0 - -sum_stats :: [FloatStats] -> FloatStats -sum_stats xs = foldr add_stats zeroStats xs - -add_stats :: FloatStats -> FloatStats -> FloatStats -add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) - = FlS (a1 + a2) (b1 + b2) (c1 + c2) - -add_to_stats :: FloatStats -> FloatBinds -> FloatStats -add_to_stats (FlS a b c) (FB tops ceils others) - = FlS (a + lengthBag tops) - (b + lengthBag ceils + lengthBag (flattenMajor others)) - (c + 1) - -{- -************************************************************************ -* * -\subsection{Utility bits for floating} -* * -************************************************************************ - -Note [Representation of FloatBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The FloatBinds types is somewhat important. We can get very large numbers -of floating bindings, often all destined for the top level. A typical example -is x = [4,2,5,2,5, .... ] -Then we get lots of small expressions like (fromInteger 4), which all get -lifted to top level. - -The trouble is that - (a) we partition these floating bindings *at every binding site* - (b) SetLevels introduces a new bindings site for every float -So we had better not look at each binding at each binding site! - -That is why MajorEnv is represented as a finite map. - -We keep the bindings destined for the *top* level separate, because -we float them out even if they don't escape a *value* lambda; see -partitionByMajorLevel. --} - -type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted -type MajorEnv = M.IntMap MinorEnv -- Keyed by major level -type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level - -data FloatBinds = FB !(Bag FloatLet) -- Destined for top level - !(Bag FloatBind) -- Destined for join ceiling - !MajorEnv -- Other levels - -- See Note [Representation of FloatBinds] - -instance Outputable FloatBinds where - ppr (FB fbs ceils defs) - = text "FB" <+> (braces $ vcat - [ text "tops =" <+> ppr fbs - , text "ceils =" <+> ppr ceils - , text "non-tops =" <+> ppr defs ]) - -flattenTopFloats :: FloatBinds -> Bag CoreBind -flattenTopFloats (FB tops ceils defs) - = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) - ASSERT2( isEmptyBag ceils, ppr ceils ) - tops - -addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -addTopFloatPairs float_bag prs - = foldr add prs float_bag - where - add (NonRec b r) prs = (b,r):prs - add (Rec prs1) prs2 = prs1 ++ prs2 - -flattenMajor :: MajorEnv -> Bag FloatBind -flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag - -flattenMinor :: MinorEnv -> Bag FloatBind -flattenMinor = M.foldr unionBags emptyBag - -emptyFloats :: FloatBinds -emptyFloats = FB emptyBag emptyBag M.empty - -unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds -unitCaseFloat (Level major minor t) e b con bs - | t == JoinCeilLvl - = FB emptyBag floats M.empty - | otherwise - = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats)) - where - floats = unitBag (FloatCase e b con bs) - -unitLetFloat :: Level -> FloatLet -> FloatBinds -unitLetFloat lvl@(Level major minor t) b - | isTopLvl lvl = FB (unitBag b) emptyBag M.empty - | t == JoinCeilLvl = FB emptyBag floats M.empty - | otherwise = FB emptyBag emptyBag (M.singleton major - (M.singleton minor floats)) - where - floats = unitBag (FloatLet b) - -plusFloats :: FloatBinds -> FloatBinds -> FloatBinds -plusFloats (FB t1 c1 l1) (FB t2 c2 l2) - = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2) - -plusMajor :: MajorEnv -> MajorEnv -> MajorEnv -plusMajor = M.unionWith plusMinor - -plusMinor :: MinorEnv -> MinorEnv -> MinorEnv -plusMinor = M.unionWith unionBags - -install :: Bag FloatBind -> CoreExpr -> CoreExpr -install defn_groups expr - = foldr wrapFloat expr defn_groups - -partitionByLevel - :: Level -- Partitioning level - -> FloatBinds -- Defns to be divided into 2 piles... - -> (FloatBinds, -- Defns with level strictly < partition level, - Bag FloatBind) -- The rest - -{- --- ---- partitionByMajorLevel ---- --- Float it if we escape a value lambda, --- *or* if we get to the top level --- *or* if it's a case-float and its minor level is < current --- --- If we can get to the top level, say "yes" anyway. This means that --- x = f e --- transforms to --- lvl = e --- x = f lvl --- which is as it should be - -partitionByMajorLevel (Level major _) (FB tops defns) - = (FB tops outer, heres `unionBags` flattenMajor inner) - where - (outer, mb_heres, inner) = M.splitLookup major defns - heres = case mb_heres of - Nothing -> emptyBag - Just h -> flattenMinor h --} - -partitionByLevel (Level major minor typ) (FB tops ceils defns) - = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min), - here_min `unionBags` here_ceil - `unionBags` flattenMinor inner_min - `unionBags` flattenMajor inner_maj) - - where - (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns - (outer_min, mb_here_min, inner_min) = case mb_here_maj of - Nothing -> (M.empty, Nothing, M.empty) - Just min_defns -> M.splitLookup minor min_defns - here_min = mb_here_min `orElse` emptyBag - (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag) - | otherwise = (emptyBag, ceils) - --- Like partitionByLevel, but instead split out the bindings that are marked --- to float to the nearest join ceiling (see Note [Join points]) -partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind) -partitionAtJoinCeiling (FB tops ceils defs) - = (FB tops emptyBag defs, ceils) - --- Perform some action at a join ceiling, i.e., don't let join points float out --- (see Note [Join points]) -atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr) - -> (FloatStats, FloatBinds, CoreExpr) -atJoinCeiling (fs, floats, expr') - = (fs, floats', install ceils expr') - where - (floats', ceils) = partitionAtJoinCeiling floats - -wrapTick :: Tickish Id -> FloatBinds -> FloatBinds -wrapTick t (FB tops ceils defns) - = FB (mapBag wrap_bind tops) (wrap_defns ceils) - (M.map (M.map wrap_defns) defns) - where - wrap_defns = mapBag wrap_one - - wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) - wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) - - wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) - wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs - - maybe_tick e | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e - -- we don't need to wrap a tick around an HNF when we float it - -- outside a tick: that is an invariant of the tick semantics - -- Conversely, inlining of HNFs inside an SCC is allowed, and - -- indeed the HNF we're floating here might well be inlined back - -- again, and we don't want to end up with duplicate ticks. diff --git a/simplCore/LiberateCase.hs b/simplCore/LiberateCase.hs deleted file mode 100644 --- a/simplCore/LiberateCase.hs +++ /dev/null @@ -1,442 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} --} - -{-# LANGUAGE CPP #-} -module LiberateCase ( liberateCase ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import CoreSyn -import CoreUnfold ( couldBeSmallEnoughToInline ) -import TysWiredIn ( unitDataConId ) -import Id -import VarEnv -import Util ( notNull ) - -{- -The liberate-case transformation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This module walks over @Core@, and looks for @case@ on free variables. -The criterion is: - if there is case on a free on the route to the recursive call, - then the recursive call is replaced with an unfolding. - -Example - - f = \ t -> case v of - V a b -> a : f t - -=> the inner f is replaced. - - f = \ t -> case v of - V a b -> a : (letrec - f = \ t -> case v of - V a b -> a : f t - in f) t -(note the NEED for shadowing) - -=> Simplify - - f = \ t -> case v of - V a b -> a : (letrec - f = \ t -> a : f t - in f t) - -Better code, because 'a' is free inside the inner letrec, rather -than needing projection from v. - -Note that this deals with *free variables*. SpecConstr deals with -*arguments* that are of known form. E.g. - - last [] = error - last (x:[]) = x - last (x:xs) = last xs - - -Note [Scrutinee with cast] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - f = \ t -> case (v `cast` co) of - V a b -> a : f t - -Exactly the same optimisation (unrolling one call to f) will work here, -despite the cast. See mk_alt_env in the Case branch of libCase. - - -To think about (Apr 94) -~~~~~~~~~~~~~~ -Main worry: duplicating code excessively. At the moment we duplicate -the entire binding group once at each recursive call. But there may -be a group of recursive calls which share a common set of evaluated -free variables, in which case the duplication is a plain waste. - -Another thing we could consider adding is some unfold-threshold thing, -so that we'll only duplicate if the size of the group rhss isn't too -big. - -Data types -~~~~~~~~~~ -The ``level'' of a binder tells how many -recursive defns lexically enclose the binding -A recursive defn "encloses" its RHS, not its -scope. For example: -\begin{verbatim} - letrec f = let g = ... in ... - in - let h = ... - in ... -\end{verbatim} -Here, the level of @f@ is zero, the level of @g@ is one, -and the level of @h@ is zero (NB not one). - - -************************************************************************ -* * - Top-level code -* * -************************************************************************ --} - -liberateCase :: DynFlags -> CoreProgram -> CoreProgram -liberateCase dflags binds = do_prog (initEnv dflags) binds - where - do_prog _ [] = [] - do_prog env (bind:binds) = bind' : do_prog env' binds - where - (env', bind') = libCaseBind env bind - -{- -************************************************************************ -* * - Main payload -* * -************************************************************************ - -Bindings -~~~~~~~~ --} - -libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) - -libCaseBind env (NonRec binder rhs) - = (addBinders env [binder], NonRec binder (libCase env rhs)) - -libCaseBind env (Rec pairs) - = (env_body, Rec pairs') - where - binders = map fst pairs - - env_body = addBinders env binders - - pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] - - -- We extend the rec-env by binding each Id to its rhs, first - -- processing the rhs with an *un-extended* environment, so - -- that the same process doesn't occur for ever! - env_rhs | is_dupable_bind = addRecBinds env dup_pairs - | otherwise = env - - dup_pairs = [ (localiseId binder, libCase env_body rhs) - | (binder, rhs) <- pairs ] - -- localiseID : see Note [Need to localiseId in libCaseBind] - - is_dupable_bind = small_enough && all ok_pair pairs - - -- Size: we are going to duplicate dup_pairs; to find their - -- size, build a fake binding (let { dup_pairs } in (), - -- and find the size of that - -- See Note [Small enough] - small_enough = case bombOutSize env of - Nothing -> True -- Infinity - Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $ - Let (Rec dup_pairs) (Var unitDataConId) - - ok_pair (id,_) - = idArity id > 0 -- Note [Only functions!] - && not (isBottomingId id) -- Note [Not bottoming ids] - -{- Note [Not bottoming Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not specialise error-functions (this is unusual, but I once saw it, -(acually in Data.Typable.Internal) - -Note [Only functions!] -~~~~~~~~~~~~~~~~~~~~~~ -Consider the following code - - f = g (case v of V a b -> a : t f) - -where g is expensive. If we aren't careful, liberate case will turn this into - - f = g (case v of - V a b -> a : t (letrec f = g (case v of V a b -> a : f t) - in f) - ) - -Yikes! We evaluate g twice. This leads to a O(2^n) explosion -if g calls back to the same code recursively. - -Solution: make sure that we only do the liberate-case thing on *functions* - -Note [Small enough] -~~~~~~~~~~~~~~~~~~~ -Consider - \fv. letrec - f = \x. BIG...(case fv of { (a,b) -> ...g.. })... - g = \y. SMALL...f... - -Then we *can* in principle do liberate-case on 'g' (small RHS) but not -for 'f' (too big). But doing so is not profitable, because duplicating -'g' at its call site in 'f' doesn't get rid of any cases. So we just -ask for the whole group to be small enough. - -Note [Need to localiseId in libCaseBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The call to localiseId is needed for two subtle reasons -(a) Reset the export flags on the binders so - that we don't get name clashes on exported things if the - local binding floats out to top level. This is most unlikely - to happen, since the whole point concerns free variables. - But resetting the export flag is right regardless. - -(b) Make the name an Internal one. External Names should never be - nested; if it were floated to the top level, we'd get a name - clash at code generation time. - -Expressions -~~~~~~~~~~~ --} - -libCase :: LibCaseEnv - -> CoreExpr - -> CoreExpr - -libCase env (Var v) = libCaseApp env v [] -libCase _ (Lit lit) = Lit lit -libCase _ (Type ty) = Type ty -libCase _ (Coercion co) = Coercion co -libCase env e@(App {}) | let (fun, args) = collectArgs e - , Var v <- fun - = libCaseApp env v args -libCase env (App fun arg) = App (libCase env fun) (libCase env arg) -libCase env (Tick tickish body) = Tick tickish (libCase env body) -libCase env (Cast e co) = Cast (libCase env e) co - -libCase env (Lam binder body) - = Lam binder (libCase (addBinders env [binder]) body) - -libCase env (Let bind body) - = Let bind' (libCase env_body body) - where - (env_body, bind') = libCaseBind env bind - -libCase env (Case scrut bndr ty alts) - = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) - where - env_alts = addBinders (mk_alt_env scrut) [bndr] - mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var - mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] - mk_alt_env _ = env - -libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) - -> (AltCon, [CoreBndr], CoreExpr) -libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) - -{- -Ids -~~~ - -To unfold, we can't just wrap the id itself in its binding if it's a join point: - - jump j a b c => (joinrec j x y z = ... in jump j) a b c -- wrong!!! - -Every jump must provide all arguments, so we have to be careful to wrap the -whole jump instead: - - jump j a b c => joinrec j x y z = ... in jump j a b c -- right - --} - -libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr -libCaseApp env v args - | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing - , notNull free_scruts -- with free vars scrutinised in RHS - = Let the_bind expr' - - | otherwise - = expr' - - where - rec_id_level = lookupLevel env v - free_scruts = freeScruts env rec_id_level - expr' = mkApps (Var v) (map (libCase env) args) - -freeScruts :: LibCaseEnv - -> LibCaseLevel -- Level of the recursive Id - -> [Id] -- Ids that are scrutinised between the binding - -- of the recursive Id and here -freeScruts env rec_bind_lvl - = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env - , scrut_bind_lvl <= rec_bind_lvl - , scrut_at_lvl > rec_bind_lvl] - -- Note [When to specialise] - -- Note [Avoiding fruitless liberate-case] - -{- -Note [When to specialise] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = \x. letrec g = \y. case x of - True -> ... (f a) ... - False -> ... (g b) ... - -We get the following levels - f 0 - x 1 - g 1 - y 2 - -Then 'x' is being scrutinised at a deeper level than its binding, so -it's added to lc_sruts: [(x,1)] - -We do *not* want to specialise the call to 'f', because 'x' is not free -in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). - -We *do* want to specialise the call to 'g', because 'x' is free in g. -Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). - -Note [Avoiding fruitless liberate-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider also: - f = \x. case top_lvl_thing of - I# _ -> let g = \y. ... g ... - in ... - -Here, top_lvl_thing is scrutinised at a level (1) deeper than its -binding site (0). Nevertheless, we do NOT want to specialise the call -to 'g' because all the structure in its free variables is already -visible at the definition site for g. Hence, when considering specialising -an occurrence of 'g', we want to check that there's a scruted-var v st - - a) v's binding site is *outside* g - b) v's scrutinisation site is *inside* g - - -************************************************************************ -* * - Utility functions -* * -************************************************************************ --} - -addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv -addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders - = env { lc_lvl_env = lvl_env' } - where - lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl) - -addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv -addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, - lc_rec_env = rec_env}) pairs - = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' } - where - lvl' = lvl + 1 - lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] - rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] - -addScrutedVar :: LibCaseEnv - -> Id -- This Id is being scrutinised by a case expression - -> LibCaseEnv - -addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, - lc_scruts = scruts }) scrut_var - | bind_lvl < lvl - = env { lc_scruts = scruts' } - -- Add to scruts iff the scrut_var is being scrutinised at - -- a deeper level than its defn - - | otherwise = env - where - scruts' = (scrut_var, bind_lvl, lvl) : scruts - bind_lvl = case lookupVarEnv lvl_env scrut_var of - Just lvl -> lvl - Nothing -> topLevel - -lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind -lookupRecId env id = lookupVarEnv (lc_rec_env env) id - -lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel -lookupLevel env id - = case lookupVarEnv (lc_lvl_env env) id of - Just lvl -> lvl - Nothing -> topLevel - -{- -************************************************************************ -* * - The environment -* * -************************************************************************ --} - -type LibCaseLevel = Int - -topLevel :: LibCaseLevel -topLevel = 0 - -data LibCaseEnv - = LibCaseEnv { - lc_dflags :: DynFlags, - - lc_lvl :: LibCaseLevel, -- Current level - -- The level is incremented when (and only when) going - -- inside the RHS of a (sufficiently small) recursive - -- function. - - lc_lvl_env :: IdEnv LibCaseLevel, - -- Binds all non-top-level in-scope Ids (top-level and - -- imported things have a level of zero) - - lc_rec_env :: IdEnv CoreBind, - -- Binds *only* recursively defined ids, to their own - -- binding group, and *only* in their own RHSs - - lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] - -- Each of these Ids was scrutinised by an enclosing - -- case expression, at a level deeper than its binding - -- level. - -- - -- The first LibCaseLevel is the *binding level* of - -- the scrutinised Id, - -- The second is the level *at which it was scrutinised*. - -- (see Note [Avoiding fruitless liberate-case]) - -- The former is a bit redundant, since you could always - -- look it up in lc_lvl_env, but it's just cached here - -- - -- The order is insignificant; it's a bag really - -- - -- There's one element per scrutinisation; - -- in principle the same Id may appear multiple times, - -- although that'd be unusual: - -- case x of { (a,b) -> ....(case x of ...) .. } - } - -initEnv :: DynFlags -> LibCaseEnv -initEnv dflags - = LibCaseEnv { lc_dflags = dflags, - lc_lvl = 0, - lc_lvl_env = emptyVarEnv, - lc_rec_env = emptyVarEnv, - lc_scruts = [] } - --- Bomb-out size for deciding if --- potential liberatees are too big. --- (passed in from cmd-line args) -bombOutSize :: LibCaseEnv -> Maybe Int -bombOutSize = liberateCaseThreshold . lc_dflags diff --git a/simplCore/OccurAnal.hs b/simplCore/OccurAnal.hs deleted file mode 100644 --- a/simplCore/OccurAnal.hs +++ /dev/null @@ -1,2900 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -************************************************************************ -* * -\section[OccurAnal]{Occurrence analysis pass} -* * -************************************************************************ - -The occurrence analyser re-typechecks a core expression, returning a new -core expression with (hopefully) improved usage information. --} - -{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-} - -module OccurAnal ( - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreFVs -import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - stripTicksTopE, mkTicks ) -import CoreArity ( joinRhsArity ) -import Id -import IdInfo -import Name( localiseName ) -import BasicTypes -import Module( Module ) -import Coercion -import Type - -import VarSet -import VarEnv -import Var -import Demand ( argOneShots, argsOneShots ) -import Digraph ( SCC(..), Node(..) - , stronglyConnCompFromEdgedVerticesUniq - , stronglyConnCompFromEdgedVerticesUniqR ) -import Unique -import UniqFM -import UniqSet -import Util -import Outputable -import Data.List -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap -* * -************************************************************************ - -Here's the externally-callable interface: --} - -occurAnalysePgm :: Module -- Used only in debug output - -> (Id -> Bool) -- Active unfoldings - -> (Activation -> Bool) -- Active rules - -> [CoreRule] - -> CoreProgram -> CoreProgram -occurAnalysePgm this_mod active_unf active_rule imp_rules binds - | isEmptyDetails final_usage - = occ_anald_binds - - | otherwise -- See Note [Glomming] - = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) - 2 (ppr final_usage ) ) - occ_anald_glommed_binds - where - init_env = initOccEnv { occ_rule_act = active_rule - , occ_unf_act = active_unf } - - (final_usage, occ_anald_binds) = go init_env binds - (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel - imp_rule_edges - (flattenBinds binds) - initial_uds - -- It's crucial to re-analyse the glommed-together bindings - -- so that we establish the right loop breakers. Otherwise - -- we can easily create an infinite loop (#9583 is an example) - -- - -- Also crucial to re-analyse the /original/ bindings - -- in case the first pass accidentally discarded as dead code - -- a binding that was actually needed (albeit before its - -- definition site). #17724 threw this up. - - initial_uds = addManyOccsSet emptyDetails - (rulesFreeVars imp_rules) - -- The RULES declarations keep things alive! - - -- Note [Preventing loops due to imported functions rules] - imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv - [ mapVarEnv (const maps_to) $ - getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) - | imp_rule <- imp_rules - , not (isBuiltinRule imp_rule) -- See Note [Plugin rules] - , let maps_to = exprFreeIds (ru_rhs imp_rule) - `delVarSetList` ru_bndrs imp_rule - , arg <- ru_args imp_rule ] - - go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) - go _ [] - = (initial_uds, []) - go env (bind:binds) - = (final_usage, bind' ++ binds') - where - (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind - bs_usage - -occurAnalyseExpr :: CoreExpr -> CoreExpr - -- Do occurrence analysis, and discard occurrence info returned -occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap - -occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr -occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap - -occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr -occurAnalyseExpr' enable_binder_swap expr - = snd (occAnal env expr) - where - env = initOccEnv { occ_binder_swap = enable_binder_swap } - -{- Note [Plugin rules] -~~~~~~~~~~~~~~~~~~~~~~ -Conal Elliott (#11651) built a GHC plugin that added some -BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to -do some domain-specific transformations that could not be expressed -with an ordinary pattern-matching CoreRule. But then we can't extract -the dependencies (in imp_rule_edges) from ru_rhs etc, because a -BuiltinRule doesn't have any of that stuff. - -So we simply assume that BuiltinRules have no dependencies, and filter -them out from the imp_rule_edges comprehension. --} - -{- -************************************************************************ -* * - Bindings -* * -************************************************************************ - -Note [Recursive bindings: the grand plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come across a binding group - Rec { x1 = r1; ...; xn = rn } -we treat it like this (occAnalRecBind): - -1. Occurrence-analyse each right hand side, and build a - "Details" for each binding to capture the results. - - Wrap the details in a Node (details, node-id, dep-node-ids), - where node-id is just the unique of the binder, and - dep-node-ids lists all binders on which this binding depends. - We'll call these the "scope edges". - See Note [Forming the Rec groups]. - - All this is done by makeNode. - -2. Do SCC-analysis on these Nodes. Each SCC will become a new Rec or - NonRec. The key property is that every free variable of a binding - is accounted for by the scope edges, so that when we are done - everything is still in scope. - -3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we - identify suitable loop-breakers to ensure that inlining terminates. - This is done by occAnalRec. - -4. To do so we form a new set of Nodes, with the same details, but - different edges, the "loop-breaker nodes". The loop-breaker nodes - have both more and fewer dependencies than the scope edges - (see Note [Choosing loop breakers]) - - More edges: if f calls g, and g has an active rule that mentions h - then we add an edge from f -> h - - Fewer edges: we only include dependencies on active rules, on rule - RHSs (not LHSs) and if there is an INLINE pragma only - on the stable unfolding (and vice versa). The scope - edges must be much more inclusive. - -5. The "weak fvs" of a node are, by definition: - the scope fvs - the loop-breaker fvs - See Note [Weak loop breakers], and the nd_weak field of Details - -6. Having formed the loop-breaker nodes - -Note [Dead code] -~~~~~~~~~~~~~~~~ -Dropping dead code for a cyclic Strongly Connected Component is done -in a very simple way: - - the entire SCC is dropped if none of its binders are mentioned - in the body; otherwise the whole thing is kept. - -The key observation is that dead code elimination happens after -dependency analysis: so 'occAnalBind' processes SCCs instead of the -original term's binding groups. - -Thus 'occAnalBind' does indeed drop 'f' in an example like - - letrec f = ...g... - g = ...(...g...)... - in - ...g... - -when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in -'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes -'AcyclicSCC f', where 'body_usage' won't contain 'f'. - ------------------------------------------------------------- -Note [Forming Rec groups] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We put bindings {f = ef; g = eg } in a Rec group if "f uses g" -and "g uses f", no matter how indirectly. We do a SCC analysis -with an edge f -> g if "f uses g". - -More precisely, "f uses g" iff g should be in scope wherever f is. -That is, g is free in: - a) the rhs 'ef' - b) or the RHS of a rule for f (Note [Rules are extra RHSs]) - c) or the LHS or a rule for f (Note [Rule dependency info]) - -These conditions apply regardless of the activation of the RULE (eg it might be -inactive in this phase but become active later). Once a Rec is broken up -it can never be put back together, so we must be conservative. - -The principle is that, regardless of rule firings, every variable is -always in scope. - - * Note [Rules are extra RHSs] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" - keeps the specialised "children" alive. If the parent dies - (because it isn't referenced any more), then the children will die - too (unless they are already referenced directly). - - To that end, we build a Rec group for each cyclic strongly - connected component, - *treating f's rules as extra RHSs for 'f'*. - More concretely, the SCC analysis runs on a graph with an edge - from f -> g iff g is mentioned in - (a) f's rhs - (b) f's RULES - These are rec_edges. - - Under (b) we include variables free in *either* LHS *or* RHS of - the rule. The former might seems silly, but see Note [Rule - dependency info]. So in Example [eftInt], eftInt and eftIntFB - will be put in the same Rec, even though their 'main' RHSs are - both non-recursive. - - * Note [Rule dependency info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The VarSet in a RuleInfo is used for dependency analysis in the - occurrence analyser. We must track free vars in *both* lhs and rhs. - Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. - Why both? Consider - x = y - RULE f x = v+4 - Then if we substitute y for x, we'd better do so in the - rule's LHS too, so we'd better ensure the RULE appears to mention 'x' - as well as 'v' - - * Note [Rules are visible in their own rec group] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We want the rules for 'f' to be visible in f's right-hand side. - And we'd like them to be visible in other functions in f's Rec - group. E.g. in Note [Specialisation rules] we want f' rule - to be visible in both f's RHS, and fs's RHS. - - This means that we must simplify the RULEs first, before looking - at any of the definitions. This is done by Simplify.simplRecBind, - when it calls addLetIdInfo. - ------------------------------------------------------------- -Note [Choosing loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Loop breaking is surprisingly subtle. First read the section 4 of -"Secrets of the GHC inliner". This describes our basic plan. -We avoid infinite inlinings by choosing loop breakers, and -ensuring that a loop breaker cuts each loop. - -See also Note [Inlining and hs-boot files] in ToIface, which deals -with a closely related source of infinite loops. - -Fundamentally, we do SCC analysis on a graph. For each recursive -group we choose a loop breaker, delete all edges to that node, -re-analyse the SCC, and iterate. - -But what is the graph? NOT the same graph as was used for Note -[Forming Rec groups]! In particular, a RULE is like an equation for -'f' that is *always* inlined if it is applicable. We do *not* disable -rules for loop-breakers. It's up to whoever makes the rules to make -sure that the rules themselves always terminate. See Note [Rules for -recursive functions] in Simplify.hs - -Hence, if - f's RHS (or its INLINE template if it has one) mentions g, and - g has a RULE that mentions h, and - h has a RULE that mentions f - -then we *must* choose f to be a loop breaker. Example: see Note -[Specialisation rules]. - -In general, take the free variables of f's RHS, and augment it with -all the variables reachable by RULES from those starting points. That -is the whole reason for computing rule_fv_env in occAnalBind. (Of -course we only consider free vars that are also binders in this Rec -group.) See also Note [Finding rule RHS free vars] - -Note that when we compute this rule_fv_env, we only consider variables -free in the *RHS* of the rule, in contrast to the way we build the -Rec group in the first place (Note [Rule dependency info]) - -Note that if 'g' has RHS that mentions 'w', we should add w to -g's loop-breaker edges. More concretely there is an edge from f -> g -iff - (a) g is mentioned in f's RHS `xor` f's INLINE rhs - (see Note [Inline rules]) - (b) or h is mentioned in f's RHS, and - g appears in the RHS of an active RULE of h - or a transitive sequence of active rules starting with h - -Why "active rules"? See Note [Finding rule RHS free vars] - -Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is -chosen as a loop breaker, because their RHSs don't mention each other. -And indeed both can be inlined safely. - -Note again that the edges of the graph we use for computing loop breakers -are not the same as the edges we use for computing the Rec blocks. -That's why we compute - -- rec_edges for the Rec block analysis -- loop_breaker_nodes for the loop breaker analysis - - * Note [Finding rule RHS free vars] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider this real example from Data Parallel Haskell - tagZero :: Array Int -> Array Tag - {-# INLINE [1] tagZeroes #-} - tagZero xs = pmap (\x -> fromBool (x==0)) xs - - {-# RULES "tagZero" [~1] forall xs n. - pmap fromBool = tagZero xs #-} - So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. - However, tagZero can only be inlined in phase 1 and later, while - the RULE is only active *before* phase 1. So there's no problem. - - To make this work, we look for the RHS free vars only for - *active* rules. That's the reason for the occ_rule_act field - of the OccEnv. - - * Note [Weak loop breakers] - ~~~~~~~~~~~~~~~~~~~~~~~~~ - There is a last nasty wrinkle. Suppose we have - - Rec { f = f_rhs - RULE f [] = g - - h = h_rhs - g = h - ...more... - } - - Remember that we simplify the RULES before any RHS (see Note - [Rules are visible in their own rec group] above). - - So we must *not* postInlineUnconditionally 'g', even though - its RHS turns out to be trivial. (I'm assuming that 'g' is - not choosen as a loop breaker.) Why not? Because then we - drop the binding for 'g', which leaves it out of scope in the - RULE! - - Here's a somewhat different example of the same thing - Rec { g = h - ; h = ...f... - ; f = f_rhs - RULE f [] = g } - Here the RULE is "below" g, but we *still* can't postInlineUnconditionally - g, because the RULE for f is active throughout. So the RHS of h - might rewrite to h = ...g... - So g must remain in scope in the output program! - - We "solve" this by: - - Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) - iff g is a "missing free variable" of the Rec group - - A "missing free variable" x is one that is mentioned in an RHS or - INLINE or RULE of a binding in the Rec group, but where the - dependency on x may not show up in the loop_breaker_nodes (see - note [Choosing loop breakers} above). - - A normal "strong" loop breaker has IAmLoopBreaker False. So - - Inline postInlineUnconditionally - strong IAmLoopBreaker False no no - weak IAmLoopBreaker True yes no - other yes yes - - The **sole** reason for this kind of loop breaker is so that - postInlineUnconditionally does not fire. Ugh. (Typically it'll - inline via the usual callSiteInline stuff, so it'll be dead in the - next pass, so the main Ugh is the tiresome complication.) - -Note [Rules for imported functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - f = /\a. B.g a - RULE B.g Int = 1 + f Int -Note that - * The RULE is for an imported function. - * f is non-recursive -Now we -can get - f Int --> B.g Int Inlining f - --> 1 + f Int Firing RULE -and so the simplifier goes into an infinite loop. This -would not happen if the RULE was for a local function, -because we keep track of dependencies through rules. But -that is pretty much impossible to do for imported Ids. Suppose -f's definition had been - f = /\a. C.h a -where (by some long and devious process), C.h eventually inlines to -B.g. We could only spot such loops by exhaustively following -unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) -f. - -Note that RULES for imported functions are important in practice; they -occur a lot in the libraries. - -We regard this potential infinite loop as a *programmer* error. -It's up the programmer not to write silly rules like - RULE f x = f x -and the example above is just a more complicated version. - -Note [Preventing loops due to imported functions rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - import GHC.Base (foldr) - - {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} - filter p xs = build (\c n -> foldr (filterFB c p) n xs) - filterFB c p = ... - - f = filter p xs - -Note that filter is not a loop-breaker, so what happens is: - f = filter p xs - = {inline} build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -We are in an infinite loop. - -A more elaborate example (that I actually saw in practice when I went to -mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: - {-# LANGUAGE RankNTypes #-} - module GHCList where - - import Prelude hiding (filter) - import GHC.Base (build) - - {-# INLINABLE filter #-} - filter :: (a -> Bool) -> [a] -> [a] - filter p [] = [] - filter p (x:xs) = if p x then x : filter p xs else filter p xs - - {-# NOINLINE [0] filterFB #-} - filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b - filterFB c p x r | p x = x `c` r - | otherwise = r - - {-# RULES - "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr - (filterFB c p) n xs) - "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p - #-} - -Then (because RULES are applied inside INLINABLE unfoldings, but inlinings -are not), the unfolding given to "filter" in the interface file will be: - filter p [] = [] - filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs - -Note that because this unfolding does not mention "filter", filter is not -marked as a strong loop breaker. Therefore at a use site in another module: - filter p xs - = {inline} - case xs of [] -> [] - (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs) - - build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -And we are in an infinite loop again, except that this time the loop is producing an -infinitely large *term* (an unrolling of filter) and so the simplifier finally -dies with "ticks exhausted" - -Because of this problem, we make a small change in the occurrence analyser -designed to mark functions like "filter" as strong loop breakers on the basis that: - 1. The RHS of filter mentions the local function "filterFB" - 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS - -So for each RULE for an *imported* function we are going to add -dependency edges between the *local* FVS of the rule LHS and the -*local* FVS of the rule RHS. We don't do anything special for RULES on -local functions because the standard occurrence analysis stuff is -pretty good at getting loop-breakerness correct there. - -It is important to note that even with this extra hack we aren't always going to get -things right. For example, it might be that the rule LHS mentions an imported Id, -and another module has a RULE that can rewrite that imported Id to one of our local -Ids. - -Note [Specialising imported functions] (referred to from Specialise) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT for *automatically-generated* rules, the programmer can't be -responsible for the "programmer error" in Note [Rules for imported -functions]. In paricular, consider specialising a recursive function -defined in another module. If we specialise a recursive function B.g, -we get - g_spec = .....(B.g Int)..... - RULE B.g Int = g_spec -Here, g_spec doesn't look recursive, but when the rule fires, it -becomes so. And if B.g was mutually recursive, the loop might -not be as obvious as it is here. - -To avoid this, - * When specialising a function that is a loop breaker, - give a NOINLINE pragma to the specialised function - -Note [Glomming] -~~~~~~~~~~~~~~~ -RULES for imported Ids can make something at the top refer to something at the bottom: - f = \x -> B.g (q x) - h = \y -> 3 - - RULE: B.g (q x) = h x - -Applying this rule makes f refer to h, although f doesn't appear to -depend on h. (And, as in Note [Rules for imported functions], the -dependency might be more indirect. For example, f might mention C.t -rather than B.g, where C.t eventually inlines to B.g.) - -NOTICE that this cannot happen for rules whose head is a -locally-defined function, because we accurately track dependencies -through RULES. It only happens for rules whose head is an imported -function (B.g in the example above). - -Solution: - - When simplifying, bring all top level identifiers into - scope at the start, ignoring the Rec/NonRec structure, so - that when 'h' pops up in f's rhs, we find it in the in-scope set - (as the simplifier generally expects). This happens in simplTopBinds. - - - In the occurrence analyser, if there are any out-of-scope - occurrences that pop out of the top, which will happen after - firing the rule: f = \x -> h x - h = \y -> 3 - then just glom all the bindings into a single Rec, so that - the *next* iteration of the occurrence analyser will sort - them all out. This part happens in occurAnalysePgm. - ------------------------------------------------------------- -Note [Inline rules] -~~~~~~~~~~~~~~~~~~~ -None of the above stuff about RULES applies to Inline Rules, -stored in a CoreUnfolding. The unfolding, if any, is simplified -at the same time as the regular RHS of the function (ie *not* like -Note [Rules are visible in their own rec group]), so it should be -treated *exactly* like an extra RHS. - -Or, rather, when computing loop-breaker edges, - * If f has an INLINE pragma, and it is active, we treat the - INLINE rhs as f's rhs - * If it's inactive, we treat f as having no rhs - * If it has no INLINE pragma, we look at f's actual rhs - - -There is a danger that we'll be sub-optimal if we see this - f = ...f... - [INLINE f = ..no f...] -where f is recursive, but the INLINE is not. This can just about -happen with a sufficiently odd set of rules; eg - - foo :: Int -> Int - {-# INLINE [1] foo #-} - foo x = x+1 - - bar :: Int -> Int - {-# INLINE [1] bar #-} - bar x = foo x + 1 - - {-# RULES "foo" [~1] forall x. foo x = bar x #-} - -Here the RULE makes bar recursive; but it's INLINE pragma remains -non-recursive. It's tempting to then say that 'bar' should not be -a loop breaker, but an attempt to do so goes wrong in two ways: - a) We may get - $df = ...$cfoo... - $cfoo = ...$df.... - [INLINE $cfoo = ...no-$df...] - But we want $cfoo to depend on $df explicitly so that we - put the bindings in the right order to inline $df in $cfoo - and perhaps break the loop altogether. (Maybe this - b) - - -Example [eftInt] -~~~~~~~~~~~~~~~ -Example (from GHC.Enum): - - eftInt :: Int# -> Int# -> [Int] - eftInt x y = ...(non-recursive)... - - {-# INLINE [0] eftIntFB #-} - eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r - eftIntFB c n x y = ...(non-recursive)... - - {-# RULES - "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) - "eftIntList" [1] eftIntFB (:) [] = eftInt - #-} - -Note [Specialisation rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this group, which is typical of what SpecConstr builds: - - fs a = ....f (C a).... - f x = ....f (C a).... - {-# RULE f (C a) = fs a #-} - -So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). - -But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify - - fs is inlined (say it's small) - - now there's another opportunity to apply the RULE - -This showed up when compiling Control.Concurrent.Chan.getChanContents. - ------------------------------------------------------------- -Note [Finding join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's the occurrence analyser's job to find bindings that we can turn into join -points, but it doesn't perform that transformation right away. Rather, it marks -the eligible bindings as part of their occurrence data, leaving it to the -simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. -The simplifier then eta-expands the RHS if needed and then updates the -occurrence sites. Dividing the work this way means that the occurrence analyser -still only takes one pass, yet one can always tell the difference between a -function call and a jump by looking at the occurrence (because the same pass -changes the 'IdDetails' and propagates the binders to their occurrence sites). - -To track potential join points, we use the 'occ_tail' field of OccInfo. A value -of `AlwaysTailCalled n` indicates that every occurrence of the variable is a -tail call with `n` arguments (counting both value and type arguments). Otherwise -'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the -rest of 'OccInfo' until it goes on the binder. - -Note [Rules and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Things get fiddly with rules. Suppose we have: - - let j :: Int -> Int - j y = 2 * y - k :: Int -> Int -> Int - {-# RULES "SPEC k 0" k 0 = j #-} - k x y = x + 2 * y - in ... - -Now suppose that both j and k appear only as saturated tail calls in the body. -Thus we would like to make them both join points. The rule complicates matters, -though, as its RHS has an unapplied occurrence of j. *However*, if we were to -eta-expand the rule, all would be well: - - {-# RULES "SPEC k 0" forall a. k 0 a = j a #-} - -So conceivably we could notice that a potential join point would have an -"undersaturated" rule and account for it. This would mean we could make -something that's been specialised a join point, for instance. But local bindings -are rarely specialised, and being overly cautious about rules only -costs us anything when, for some `j`: - - * Before specialisation, `j` has non-tail calls, so it can't be a join point. - * During specialisation, `j` gets specialised and thus acquires rules. - * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), - and so now `j` *could* become a join point. - -This appears to be very rare in practice. TODO Perhaps we should gather -statistics to be sure. - ------------------------------------------------------------- -Note [Adjusting right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a bit of a dance we need to do after analysing a lambda expression or -a right-hand side. In particular, we need to - - a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot - lambda, or a non-recursive join point; and - b) call 'markAllNonTailCalled' *unless* the binding is for a join point. - -Some examples, with how the free occurrences in e (assumed not to be a value -lambda) get marked: - - inside lam non-tail-called - ------------------------------------------------------------ - let x = e No Yes - let f = \x -> e Yes Yes - let f = \x{OneShot} -> e No Yes - \x -> e Yes Yes - join j x = e No No - joinrec j x = e Yes No - -There are a few other caveats; most importantly, if we're marking a binding as -'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so -that the effect cascades properly. Consequently, at the time the RHS is -analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must -return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once -join-point-hood has been decided. - -Thus the overall sequence taking place in 'occAnalNonRecBind' and -'occAnalRecBind' is as follows: - - 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. - 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make - the binding a join point. - 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when - recursive.) - -(In the recursive case, this logic is spread between 'makeNode' and -'occAnalRec'.) --} - ------------------------------------------------------------------- --- occAnalBind ------------------------------------------------------------------- - -occAnalBind :: OccEnv -- The incoming OccEnv - -> TopLevelFlag - -> ImpRuleEdges - -> CoreBind - -> UsageDetails -- Usage details of scope - -> (UsageDetails, -- Of the whole let(rec) - [CoreBind]) - -occAnalBind env lvl top_env (NonRec binder rhs) body_usage - = occAnalNonRecBind env lvl top_env binder rhs body_usage -occAnalBind env lvl top_env (Rec pairs) body_usage - = occAnalRecBind env lvl top_env pairs body_usage - ------------------ -occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr - -> UsageDetails -> (UsageDetails, [CoreBind]) -occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage - | isTyVar binder -- A type let; we don't gather usage info - = (body_usage, [NonRec binder rhs]) - - | not (binder `usedIn` body_usage) -- It's not mentioned - = (body_usage, []) - - | otherwise -- It's mentioned in the body - = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs']) - where - (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder - mb_join_arity = willBeJoinId_maybe tagged_binder - - (bndrs, body) = collectBinders rhs - - (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body - rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' - -- For a /non-recursive/ join point we can mark all - -- its join-lambda as one-shot; and it's a good idea to do so - - -- Unfoldings - -- See Note [Unfoldings and join points] - rhs_usage2 = case occAnalUnfolding env NonRecursive binder of - Just unf_usage -> rhs_usage1 `andUDs` unf_usage - Nothing -> rhs_usage1 - - -- Rules - -- See Note [Rules are extra RHSs] and Note [Rule dependency info] - rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder - rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds - rhs_usage3 = foldr andUDs rhs_usage2 rule_uds - rhs_usage4 = case lookupVarEnv imp_rule_edges binder of - Nothing -> rhs_usage3 - Just vs -> addManyOccsSet rhs_usage3 vs - -- See Note [Preventing loops due to imported functions rules] - - -- Final adjustment - rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4 - ------------------ -occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] - -> UsageDetails -> (UsageDetails, [CoreBind]) -occAnalRecBind env lvl imp_rule_edges pairs body_usage - = foldr (occAnalRec env lvl) (body_usage, []) sccs - -- For a recursive group, we - -- * occ-analyse all the RHSs - -- * compute strongly-connected components - -- * feed those components to occAnalRec - -- See Note [Recursive bindings: the grand plan] - where - sccs :: [SCC Details] - sccs = {-# SCC "occAnalBind.scc" #-} - stronglyConnCompFromEdgedVerticesUniq nodes - - nodes :: [LetrecNode] - nodes = {-# SCC "occAnalBind.assoc" #-} - map (makeNode env imp_rule_edges bndr_set) pairs - - bndr_set = mkVarSet (map fst pairs) - -{- -Note [Unfoldings and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We assume that anything in an unfolding occurs multiple times, since unfoldings -are often copied (that's the whole point!). But we still need to track tail -calls for the purpose of finding join points. --} - ------------------------------ -occAnalRec :: OccEnv -> TopLevelFlag - -> SCC Details - -> (UsageDetails, [CoreBind]) - -> (UsageDetails, [CoreBind]) - - -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs - , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs })) - (body_uds, binds) - | not (bndr `usedIn` body_uds) - = (body_uds, binds) -- See Note [Dead code] - - | otherwise -- It's mentioned in the body - = (body_uds' `andUDs` rhs_uds', - NonRec tagged_bndr rhs : binds) - where - (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr - rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive - rhs_bndrs rhs_uds - - -- The Rec case is the interesting one - -- See Note [Recursive bindings: the grand plan] - -- See Note [Loop breaking] -occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds) - | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds - = (body_uds, binds) -- See Note [Dead code] - - | otherwise -- At this point we always build a single Rec - = -- pprTrace "occAnalRec" (vcat - -- [ text "weak_fvs" <+> ppr weak_fvs - -- , text "lb nodes" <+> ppr loop_breaker_nodes]) - (final_uds, Rec pairs : binds) - - where - bndrs = map nd_bndr details_s - bndr_set = mkVarSet bndrs - - ------------------------------ - -- See Note [Choosing loop breakers] for loop_breaker_nodes - final_uds :: UsageDetails - loop_breaker_nodes :: [LetrecNode] - (final_uds, loop_breaker_nodes) - = mkLoopBreakerNodes env lvl bndr_set body_uds details_s - - ------------------------------ - weak_fvs :: VarSet - weak_fvs = mapUnionVarSet nd_weak details_s - - --------------------------- - -- Now reconstruct the cycle - pairs :: [(Id,CoreExpr)] - pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs loop_breaker_nodes [] - | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes [] - -- If weak_fvs is empty, the loop_breaker_nodes will include - -- all the edges in the original scope edges [remember, - -- weak_fvs is the difference between scope edges and - -- lb-edges], so a fresh SCC computation would yield a - -- single CyclicSCC result; and reOrderNodes deals with - -- exactly that case - - ------------------------------------------------------------------- --- Loop breaking ------------------------------------------------------------------- - -type Binding = (Id,CoreExpr) - -loopBreakNodes :: Int - -> VarSet -- All binders - -> VarSet -- Binders whose dependencies may be "missing" - -- See Note [Weak loop breakers] - -> [LetrecNode] - -> [Binding] -- Append these to the end - -> [Binding] -{- -loopBreakNodes is applied to the list of nodes for a cyclic strongly -connected component (there's guaranteed to be a cycle). It returns -the same nodes, but - a) in a better order, - b) with some of the Ids having a IAmALoopBreaker pragma - -The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means -that the simplifier can guarantee not to loop provided it never records an inlining -for these no-inline guys. - -Furthermore, the order of the binds is such that if we neglect dependencies -on the no-inline Ids then the binds are topologically sorted. This means -that the simplifier will generally do a good job if it works from top bottom, -recording inlinings for any Ids which aren't marked as "no-inline" as it goes. --} - --- Return the bindings sorted into a plausible order, and marked with loop breakers. -loopBreakNodes depth bndr_set weak_fvs nodes binds - = -- pprTrace "loopBreakNodes" (ppr nodes) $ - go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds - where - go [] binds = binds - go (scc:sccs) binds = loop_break_scc scc (go sccs binds) - - loop_break_scc scc binds - = case scc of - AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds - CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds - ----------------------------------- -reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding] - -- Choose a loop breaker, mark it no-inline, - -- and call loopBreakNodes on the rest -reOrderNodes _ _ _ [] _ = panic "reOrderNodes" -reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds -reOrderNodes depth bndr_set weak_fvs (node : nodes) binds - = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen - -- , text "chosen" <+> ppr chosen_nodes ]) $ - loopBreakNodes new_depth bndr_set weak_fvs unchosen $ - (map mk_loop_breaker chosen_nodes ++ binds) - where - (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb - (nd_score (node_payload node)) - [node] [] nodes - - approximate_lb = depth >= 2 - new_depth | approximate_lb = 0 - | otherwise = depth+1 - -- After two iterations (d=0, d=1) give up - -- and approximate, returning to d=0 - -mk_loop_breaker :: LetrecNode -> Binding -mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs}) - = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs) - where - tail_info = tailCallInfo (idOccInfo bndr) - -mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding --- See Note [Weak loop breakers] -mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr - , nd_rhs = rhs}) - | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs) - | otherwise = (bndr, rhs) - where - occ' = weakLoopBreaker { occ_tail = tail_info } - tail_info = tailCallInfo (idOccInfo bndr) - ----------------------------------- -chooseLoopBreaker :: Bool -- True <=> Too many iterations, - -- so approximate - -> NodeScore -- Best score so far - -> [LetrecNode] -- Nodes with this score - -> [LetrecNode] -- Nodes with higher scores - -> [LetrecNode] -- Unprocessed nodes - -> ([LetrecNode], [LetrecNode]) - -- This loop looks for the bind with the lowest score - -- to pick as the loop breaker. The rest accumulate in -chooseLoopBreaker _ _ loop_nodes acc [] - = (loop_nodes, acc) -- Done - - -- If approximate_loop_breaker is True, we pick *all* - -- nodes with lowest score, else just one - -- See Note [Complexity of loop breaking] -chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) - | approx_lb - , rank sc == rank loop_sc - = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes - - | sc `betterLB` loop_sc -- Better score so pick this new one - = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes - - | otherwise -- Worse score so don't pick it - = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes - where - sc = nd_score (node_payload node) - -{- -Note [Complexity of loop breaking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The loop-breaking algorithm knocks out one binder at a time, and -performs a new SCC analysis on the remaining binders. That can -behave very badly in tightly-coupled groups of bindings; in the -worst case it can be (N**2)*log N, because it does a full SCC -on N, then N-1, then N-2 and so on. - -To avoid this, we switch plans after 2 (or whatever) attempts: - Plan A: pick one binder with the lowest score, make it - a loop breaker, and try again - Plan B: pick *all* binders with the lowest score, make them - all loop breakers, and try again -Since there are only a small finite number of scores, this will -terminate in a constant number of iterations, rather than O(N) -iterations. - -You might thing that it's very unlikely, but RULES make it much -more likely. Here's a real example from #1969: - Rec { $dm = \d.\x. op d - {-# RULES forall d. $dm Int d = $s$dm1 - forall d. $dm Bool d = $s$dm2 #-} - - dInt = MkD .... opInt ... - dInt = MkD .... opBool ... - opInt = $dm dInt - opBool = $dm dBool - - $s$dm1 = \x. op dInt - $s$dm2 = \x. op dBool } -The RULES stuff means that we can't choose $dm as a loop breaker -(Note [Choosing loop breakers]), so we must choose at least (say) -opInt *and* opBool, and so on. The number of loop breakders is -linear in the number of instance declarations. - -Note [Loop breakers and INLINE/INLINABLE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Avoid choosing a function with an INLINE pramga as the loop breaker! -If such a function is mutually-recursive with a non-INLINE thing, -then the latter should be the loop-breaker. - -It's vital to distinguish between INLINE and INLINABLE (the -Bool returned by hasStableCoreUnfolding_maybe). If we start with - Rec { {-# INLINABLE f #-} - f x = ...f... } -and then worker/wrapper it through strictness analysis, we'll get - Rec { {-# INLINABLE $wf #-} - $wf p q = let x = (p,q) in ...f... - - {-# INLINE f #-} - f x = case x of (p,q) -> $wf p q } - -Now it is vital that we choose $wf as the loop breaker, so we can -inline 'f' in '$wf'. - -Note [DFuns should not be loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's particularly bad to make a DFun into a loop breaker. See -Note [How instance declarations are translated] in TcInstDcls - -We give DFuns a higher score than ordinary CONLIKE things because -if there's a choice we want the DFun to be the non-loop breaker. Eg - -rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) - - $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) - {-# DFUN #-} - $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) - } - -Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it -if we can't unravel the DFun first. - -Note [Constructor applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really really important to inline dictionaries. Real -example (the Enum Ordering instance from GHC.Base): - - rec f = \ x -> case d of (p,q,r) -> p x - g = \ x -> case d of (p,q,r) -> q x - d = (v, f, g) - -Here, f and g occur just once; but we can't inline them into d. -On the other hand we *could* simplify those case expressions if -we didn't stupidly choose d as the loop breaker. -But we won't because constructor args are marked "Many". -Inlining dictionaries is really essential to unravelling -the loops in static numeric dictionaries, see GHC.Float. - -Note [Closure conversion] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. -The immediate motivation came from the result of a closure-conversion transformation -which generated code like this: - - data Clo a b = forall c. Clo (c -> a -> b) c - - ($:) :: Clo a b -> a -> b - Clo f env $: x = f env x - - rec { plus = Clo plus1 () - - ; plus1 _ n = Clo plus2 n - - ; plus2 Zero n = n - ; plus2 (Succ m) n = Succ (plus $: m $: n) } - -If we inline 'plus' and 'plus1', everything unravels nicely. But if -we choose 'plus1' as the loop breaker (which is entirely possible -otherwise), the loop does not unravel nicely. - - -@occAnalUnfolding@ deals with the question of bindings where the Id is marked -by an INLINE pragma. For these we record that anything which occurs -in its RHS occurs many times. This pessimistically assumes that this -inlined binder also occurs many times in its scope, but if it doesn't -we'll catch it next time round. At worst this costs an extra simplifier pass. -ToDo: try using the occurrence info for the inline'd binder. - -[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. -[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. - - -************************************************************************ -* * - Making nodes -* * -************************************************************************ --} - -type ImpRuleEdges = IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs - -noImpRuleEdges :: ImpRuleEdges -noImpRuleEdges = emptyVarEnv - -type LetrecNode = Node Unique Details -- Node comes from Digraph - -- The Unique key is gotten from the Id -data Details - = ND { nd_bndr :: Id -- Binder - , nd_rhs :: CoreExpr -- RHS, already occ-analysed - , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS - -- INVARIANT: (nd_rhs_bndrs nd, _) == - -- collectBinders (nd_rhs nd) - - , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings - -- ignoring phase (ie assuming all are active) - -- See Note [Forming Rec groups] - - , nd_inl :: IdSet -- Free variables of - -- the stable unfolding (if present and active) - -- or the RHS (if not) - -- but excluding any RULES - -- This is the IdSet that may be used if the Id is inlined - - , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds - -- but are *not* in nd_inl. These are the ones whose - -- dependencies might not be respected by loop_breaker_nodes - -- See Note [Weak loop breakers] - - , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES - - , nd_score :: NodeScore - } - -instance Outputable Details where - ppr nd = text "ND" <> braces - (sep [ text "bndr =" <+> ppr (nd_bndr nd) - , text "uds =" <+> ppr (nd_uds nd) - , text "inl =" <+> ppr (nd_inl nd) - , text "weak =" <+> ppr (nd_weak nd) - , text "rule =" <+> ppr (nd_active_rule_fvs nd) - , text "score =" <+> ppr (nd_score nd) - ]) - --- The NodeScore is compared lexicographically; --- e.g. lower rank wins regardless of size -type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker - , Int -- Size of rhs: higher => more likely to be picked as LB - -- Maxes out at maxExprSize; we just use it to prioritise - -- small functions - , Bool ) -- Was it a loop breaker before? - -- True => more likely to be picked - -- Note [Loop breakers, node scoring, and stability] - -rank :: NodeScore -> Int -rank (r, _, _) = r - -makeNode :: OccEnv -> ImpRuleEdges -> VarSet - -> (Var, CoreExpr) -> LetrecNode --- See Note [Recursive bindings: the grand plan] -makeNode env imp_rule_edges bndr_set (bndr, rhs) - = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs) - -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR - -- is still deterministic with edges in nondeterministic order as - -- explained in Note [Deterministic SCC] in Digraph. - where - details = ND { nd_bndr = bndr - , nd_rhs = rhs' - , nd_rhs_bndrs = bndrs' - , nd_uds = rhs_usage3 - , nd_inl = inl_fvs - , nd_weak = node_fvs `minusVarSet` inl_fvs - , nd_active_rule_fvs = active_rule_fvs - , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } - - -- Constructing the edges for the main Rec computation - -- See Note [Forming Rec groups] - (bndrs, body) = collectBinders rhs - (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body - rhs' = mkLams bndrs' body' - rhs_usage2 = foldr andUDs rhs_usage1 rule_uds - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - rhs_usage3 = case mb_unf_uds of - Just unf_uds -> rhs_usage2 `andUDs` unf_uds - Nothing -> rhs_usage2 - node_fvs = udFreeVars bndr_set rhs_usage3 - - -- Finding the free variables of the rules - is_active = occ_rule_act env :: Activation -> Bool - - rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr - - rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs - rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) - (lookupVarEnv imp_rule_edges bndr) - -- See Note [Preventing loops due to imported functions rules] - [ (ru_act rule, udFreeVars bndr_set rhs_uds) - | (rule, _, rhs_uds) <- rules_w_uds ] - rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds - active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs - , is_active a] - - -- Finding the usage details of the INLINE pragma (if any) - mb_unf_uds = occAnalUnfolding env Recursive bndr - - -- Find the "nd_inl" free vars; for the loop-breaker phase - inl_fvs = case mb_unf_uds of - Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS - Just unf_uds -> udFreeVars bndr_set unf_uds - -- We could check for an *active* INLINE (returning - -- emptyVarSet for an inactive one), but is_active - -- isn't the right thing (it tells about - -- RULE activation), so we'd need more plumbing - -mkLoopBreakerNodes :: OccEnv -> TopLevelFlag - -> VarSet - -> UsageDetails -- for BODY of let - -> [Details] - -> (UsageDetails, -- adjusted - [LetrecNode]) --- Does four things --- a) tag each binder with its occurrence info --- b) add a NodeScore to each node --- c) make a Node with the right dependency edges for --- the loop-breaker SCC analysis --- d) adjust each RHS's usage details according to --- the binder's (new) shotness and join-point-hood -mkLoopBreakerNodes env lvl bndr_set body_uds details_s - = (final_uds, zipWith mk_lb_node details_s bndrs') - where - (final_uds, bndrs') = tagRecBinders lvl body_uds - [ ((nd_bndr nd) - ,(nd_uds nd) - ,(nd_rhs_bndrs nd)) - | nd <- details_s ] - mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr' - = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps) - -- It's OK to use nonDetKeysUniqSet here as - -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges - -- in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. - where - nd' = nd { nd_bndr = bndr', nd_score = score } - score = nodeScore env bndr bndr' rhs lb_deps - lb_deps = extendFvs_ rule_fv_env inl_fvs - - rule_fv_env :: IdEnv IdSet - -- Maps a variable f to the variables from this group - -- mentioned in RHS of active rules for f - -- Domain is *subset* of bound vars (others have no rule fvs) - rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) - init_rule_fvs -- See Note [Finding rule RHS free vars] - = [ (b, trimmed_rule_fvs) - | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s - , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set - , not (isEmptyVarSet trimmed_rule_fvs) ] - - ------------------------------------------- -nodeScore :: OccEnv - -> Id -- Binder has old occ-info (just for loop-breaker-ness) - -> Id -- Binder with new occ-info - -> CoreExpr -- RHS - -> VarSet -- Loop-breaker dependencies - -> NodeScore -nodeScore env old_bndr new_bndr bind_rhs lb_deps - | not (isId old_bndr) -- A type or cercion variable is never a loop breaker - = (100, 0, False) - - | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers - = (0, 0, True) -- See Note [Self-recursion and loop breakers] - - | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has - = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker - - | exprIsTrivial rhs - = mk_score 10 -- Practically certain to be inlined - -- Used to have also: && not (isExportedId bndr) - -- But I found this sometimes cost an extra iteration when we have - -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } - -- where df is the exported dictionary. Then df makes a really - -- bad choice for loop breaker - - | DFunUnfolding { df_args = args } <- id_unfolding - -- Never choose a DFun as a loop breaker - -- Note [DFuns should not be loop breakers] - = (9, length args, is_lb) - - -- Data structures are more important than INLINE pragmas - -- so that dictionary/method recursion unravels - - | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding - = mk_score 6 - - | is_con_app rhs -- Data types help with cases: - = mk_score 5 -- Note [Constructor applications] - - | isStableUnfolding id_unfolding - , can_unfold - = mk_score 3 - - | isOneOcc (idOccInfo new_bndr) - = mk_score 2 -- Likely to be inlined - - | can_unfold -- The Id has some kind of unfolding - = mk_score 1 - - | otherwise - = (0, 0, is_lb) - - where - mk_score :: Int -> NodeScore - mk_score rank = (rank, rhs_size, is_lb) - - is_lb = isStrongLoopBreaker (idOccInfo old_bndr) - rhs = case id_unfolding of - CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } - | isStableSource src - -> unf_rhs - _ -> bind_rhs - -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding - rhs_size = case id_unfolding of - CoreUnfolding { uf_guidance = guidance } - | UnfIfGoodArgs { ug_size = size } <- guidance - -> size - _ -> cheapExprSize rhs - - can_unfold = canUnfold id_unfolding - id_unfolding = realIdUnfolding old_bndr - -- realIdUnfolding: Ignore loop-breaker-ness here because - -- that is what we are setting! - - -- Checking for a constructor application - -- Cheap and cheerful; the simplifier moves casts out of the way - -- The lambda case is important to spot x = /\a. C (f a) - -- which comes up when C is a dictionary constructor and - -- f is a default method. - -- Example: the instance for Show (ST s a) in GHC.ST - -- - -- However we *also* treat (\x. C p q) as a con-app-like thing, - -- Note [Closure conversion] - is_con_app (Var v) = isConLikeId v - is_con_app (App f _) = is_con_app f - is_con_app (Lam _ e) = is_con_app e - is_con_app (Tick _ e) = is_con_app e - is_con_app _ = False - -maxExprSize :: Int -maxExprSize = 20 -- Rather arbitrary - -cheapExprSize :: CoreExpr -> Int --- Maxes out at maxExprSize -cheapExprSize e - = go 0 e - where - go n e | n >= maxExprSize = n - | otherwise = go1 n e - - go1 n (Var {}) = n+1 - go1 n (Lit {}) = n+1 - go1 n (Type {}) = n - go1 n (Coercion {}) = n - go1 n (Tick _ e) = go1 n e - go1 n (Cast e _) = go1 n e - go1 n (App f a) = go (go1 n f) a - go1 n (Lam b e) - | isTyVar b = go1 n e - | otherwise = go (n+1) e - go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) - go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) - - gos n [] = n - gos n (e:es) | n >= maxExprSize = n - | otherwise = gos (go1 n e) es - -betterLB :: NodeScore -> NodeScore -> Bool --- If n1 `betterLB` n2 then choose n1 as the loop breaker -betterLB (rank1, size1, lb1) (rank2, size2, _) - | rank1 < rank2 = True - | rank1 > rank2 = False - | size1 < size2 = False -- Make the bigger n2 into the loop breaker - | size1 > size2 = True - | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it - | otherwise = False -- See Note [Loop breakers, node scoring, and stability] - -{- Note [Self-recursion and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - rec { f = ...f...g... - ; g = .....f... } -then 'f' has to be a loop breaker anyway, so we may as well choose it -right away, so that g can inline freely. - -This is really just a cheap hack. Consider - rec { f = ...g... - ; g = ..f..h... - ; h = ...f....} -Here f or g are better loop breakers than h; but we might accidentally -choose h. Finding the minimal set of loop breakers is hard. - -Note [Loop breakers, node scoring, and stability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To choose a loop breaker, we give a NodeScore to each node in the SCC, -and pick the one with the best score (according to 'betterLB'). - -We need to be jolly careful (#12425, #12234) about the stability -of this choice. Suppose we have - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...f.. - False -> ..f... - -In each iteration of the simplifier the occurrence analyser OccAnal -chooses a loop breaker. Suppose in iteration 1 it choose g as the loop -breaker. That means it is free to inline f. - -Suppose that GHC decides to inline f in the branches of the case, but -(for some reason; eg it is not saturated) in the rhs of g. So we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...g...g..... - False -> ..g..g.... - -Now suppose that, for some reason, in the next iteration the occurrence -analyser chooses f as the loop breaker, so it can freely inline g. And -again for some reason the simplifier inlines g at its calls in the case -branches, but not in the RHS of f. Then we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...(...f...f...)...(...f..f..)..... - False -> ..(...f...f...)...(..f..f...).... - -You can see where this is going! Each iteration of the simplifier -doubles the number of calls to f or g. No wonder GHC is slow! - -(In the particular example in comment:3 of #12425, f and g are the two -mutually recursive fmap instances for CondT and Result. They are both -marked INLINE which, oddly, is why they don't inline in each other's -RHS, because the call there is not saturated.) - -The root cause is that we flip-flop on our choice of loop breaker. I -always thought it didn't matter, and indeed for any single iteration -to terminate, it doesn't matter. But when we iterate, it matters a -lot!! - -So The Plan is this: - If there is a tie, choose the node that - was a loop breaker last time round - -Hence the is_lb field of NodeScore - -************************************************************************ -* * - Right hand sides -* * -************************************************************************ --} - -occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRhs env Recursive _ bndrs body - = occAnalRecRhs env bndrs body -occAnalRhs env NonRecursive id bndrs body - = occAnalNonRecRhs env id bndrs body - -occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body - -occAnalNonRecRhs :: OccEnv - -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body - -- Binder is already tagged with occurrence info - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalNonRecRhs env bndr bndrs body - = occAnalLamOrRhs rhs_env bndrs body - where - env1 | is_join_point = env -- See Note [Join point RHSs] - | certainly_inline = env -- See Note [Cascading inlines] - | otherwise = rhsCtxt env - - -- See Note [Sources of one-shot information] - rhs_env = env1 { occ_one_shots = argOneShots dmd } - - certainly_inline -- See Note [Cascading inlines] - = case occ of - OneOcc { occ_in_lam = in_lam, occ_n_br = n_br } - -> not in_lam && n_br == 1 && active && not_stable - _ -> False - - is_join_point = isAlwaysTailCalled occ - -- Like (isJoinId bndr) but happens one step earlier - -- c.f. willBeJoinId_maybe - - occ = idOccInfo bndr - dmd = idDemandInfo bndr - active = isAlwaysActive (idInlineActivation bndr) - not_stable = not (isStableUnfolding (idUnfolding bndr)) - -occAnalUnfolding :: OccEnv - -> RecFlag - -> Id - -> Maybe UsageDetails - -- Just the analysis, not a new unfolding. The unfolding - -- got analysed when it was created and we don't need to - -- update it. -occAnalUnfolding env rec_flag id - = case realIdUnfolding id of -- ignore previous loop-breaker flag - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | not (isStableSource src) - -> Nothing - | otherwise - -> Just $ markAllMany usage - where - (bndrs, body) = collectBinders rhs - (usage, _, _) = occAnalRhs env rec_flag id bndrs body - - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just $ zapDetails (delDetailsList usage bndrs) - where - usage = andUDsList (map (fst . occAnal env) args) - - _ -> Nothing - -occAnalRules :: OccEnv - -> Maybe JoinArity -- If the binder is (or MAY become) a join - -- point, what its join arity is (or WOULD - -- become). See Note [Rules and join points]. - -> RecFlag - -> Id - -> [(CoreRule, -- Each (non-built-in) rule - UsageDetails, -- Usage details for LHS - UsageDetails)] -- Usage details for RHS -occAnalRules env mb_expected_join_arity rec_flag id - = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id - , let (lhs_uds, rhs_uds) = occ_anal_rule rule ] - where - occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = (lhs_uds, final_rhs_uds) - where - lhs_uds = addManyOccsSet emptyDetails $ - (exprsFreeVars args `delVarSetList` bndrs) - (rhs_bndrs, rhs_body) = collectBinders rhs - (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - final_rhs_uds = adjust_tail_info args $ markAllMany $ - (rhs_uds `delDetailsList` bndrs) - occ_anal_rule _ - = (emptyDetails, emptyDetails) - - adjust_tail_info args uds -- see Note [Rules and join points] - = case mb_expected_join_arity of - Just ar | args `lengthIs` ar -> uds - _ -> markAllNonTailCalled uds -{- Note [Join point RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = e - join j = Just x - -We want to inline x into j right away, so we don't want to give -the join point a RhsCtxt (#14137). It's not a huge deal, because -the FloatIn pass knows to float into join point RHSs; and the simplifier -does not float things out of join point RHSs. But it's a simple, cheap -thing to do. See #14137. - -Note [Cascading inlines] -~~~~~~~~~~~~~~~~~~~~~~~~ -By default we use an rhsCtxt for the RHS of a binding. This tells the -occ anal n that it's looking at an RHS, which has an effect in -occAnalApp. In particular, for constructor applications, it makes -the arguments appear to have NoOccInfo, so that we don't inline into -them. Thus x = f y - k = Just x -we do not want to inline x. - -But there's a problem. Consider - x1 = a0 : [] - x2 = a1 : x1 - x3 = a2 : x2 - g = f x3 -First time round, it looks as if x1 and x2 occur as an arg of a -let-bound constructor ==> give them a many-occurrence. -But then x3 is inlined (unconditionally as it happens) and -next time round, x2 will be, and the next time round x1 will be -Result: multiple simplifier iterations. Sigh. - -So, when analysing the RHS of x3 we notice that x3 will itself -definitely inline the next time round, and so we analyse x3's rhs in -an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. - -Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally. -If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and - (b) certainly_inline says "yes" when preInlineUnconditionally says "no" -then the simplifier iterates indefinitely: - x = f y - k = Just x -- We decide that k is 'certainly_inline' - v = ...k... -- but preInlineUnconditionally doesn't inline it -inline ==> - k = Just (f y) - v = ...k... -float ==> - x1 = f y - k = Just x1 - v = ...k... - -This is worse than the slow cascade, so we only want to say "certainly_inline" -if it really is certain. Look at the note with preInlineUnconditionally -for the various clauses. - - -************************************************************************ -* * - Expressions -* * -************************************************************************ --} - -occAnal :: OccEnv - -> CoreExpr - -> (UsageDetails, -- Gives info only about the "interesting" Ids - CoreExpr) - -occAnal _ expr@(Type _) = (emptyDetails, expr) -occAnal _ expr@(Lit _) = (emptyDetails, expr) -occAnal env expr@(Var _) = occAnalApp env (expr, [], []) - -- At one stage, I gathered the idRuleVars for the variable here too, - -- which in a way is the right thing to do. - -- But that went wrong right after specialisation, when - -- the *occurrences* of the overloaded function didn't have any - -- rules in them, so the *specialised* versions looked as if they - -- weren't used at all. - -occAnal _ (Coercion co) - = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co) - -- See Note [Gather occurrences of coercion variables] - -{- -Note [Gather occurrences of coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to gather info about what coercion variables appear, so that -we can sort them into the right place when doing dependency analysis. --} - -occAnal env (Tick tickish body) - | SourceNote{} <- tickish - = (usage, Tick tickish body') - -- SourceNotes are best-effort; so we just proceed as usual. - -- If we drop a tick due to the issues described below it's - -- not the end of the world. - - | tickish `tickishScopesLike` SoftScope - = (markAllNonTailCalled usage, Tick tickish body') - - | Breakpoint _ ids <- tickish - = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body') - -- never substitute for any of the Ids in a Breakpoint - - | otherwise - = (usage_lam, Tick tickish body') - where - !(usage,body') = occAnal env body - -- for a non-soft tick scope, we can inline lambdas only - usage_lam = markAllNonTailCalled (markAllInsideLam usage) - -- TODO There may be ways to make ticks and join points play - -- nicer together, but right now there are problems: - -- let j x = ... in tick (j 1) - -- Making j a join point may cause the simplifier to drop t - -- (if the tick is put into the continuation). So we don't - -- count j 1 as a tail call. - -- See #14242. - -occAnal env (Cast expr co) - = case occAnal env expr of { (usage, expr') -> - let usage1 = zapDetailsIf (isRhsEnv env) usage - -- usage1: if we see let x = y `cast` co - -- then mark y as 'Many' so that we don't - -- immediately inline y again. - usage2 = addManyOccsSet usage1 (coVarsOfCo co) - -- usage2: see Note [Gather occurrences of coercion variables] - in (markAllNonTailCalled usage2, Cast expr' co) - } - -occAnal env app@(App _ _) - = occAnalApp env (collectArgsTicks tickishFloatable app) - --- Ignore type variables altogether --- (a) occurrences inside type lambdas only not marked as InsideLam --- (b) type variables not in environment - -occAnal env (Lam x body) - | isTyVar x - = case occAnal env body of { (body_usage, body') -> - (markAllNonTailCalled body_usage, Lam x body') - } - --- For value lambdas we do a special hack. Consider --- (\x. \y. ...x...) --- If we did nothing, x is used inside the \y, so would be marked --- as dangerous to dup. But in the common case where the abstraction --- is applied to two arguments this is over-pessimistic. --- So instead, we just mark each binder with its occurrence --- info in the *body* of the multiple lambda. --- Then, the simplifier is careful when partially applying lambdas. - -occAnal env expr@(Lam _ _) - = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') -> - let - expr' = mkLams tagged_binders body' - usage1 = markAllNonTailCalled usage - one_shot_gp = all isOneShotBndr tagged_binders - final_usage | one_shot_gp = usage1 - | otherwise = markAllInsideLam usage1 - in - (final_usage, expr') } - where - (binders, body) = collectBinders expr - -occAnal env (Case scrut bndr ty alts) - = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> - case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> - let - alts_usage = foldr orUDs emptyDetails alts_usage_s - (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr - total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1 - -- Alts can have tail calls, but the scrutinee can't - in - total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} - where - alt_env = mkAltEnv env scrut bndr - occ_anal_alt = occAnalAlt alt_env - - occ_anal_scrut (Var v) (alt1 : other_alts) - | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v True 0, Var v) - -- The 'True' says that the variable occurs in an interesting - -- context; the case has at least one non-default alternative - occ_anal_scrut (Tick t e) alts - | t `tickishScopesLike` SoftScope - -- No reason to not look through all ticks here, but only - -- for soft-scoped ticks we can do so without having to - -- update returned occurance info (see occAnal) - = second (Tick t) $ occ_anal_scrut e alts - - occ_anal_scrut scrut _alts - = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt - -occAnal env (Let bind body) - = case occAnal env body of { (body_usage, body') -> - case occAnalBind env NotTopLevel - noImpRuleEdges bind - body_usage of { (final_usage, new_binds) -> - (final_usage, mkLets new_binds body') }} - -occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) -occAnalArgs _ [] _ - = (emptyDetails, []) - -occAnalArgs env (arg:args) one_shots - | isTypeArg arg - = case occAnalArgs env args one_shots of { (uds, args') -> - (uds, arg:args') } - - | otherwise - = case argCtxt env one_shots of { (arg_env, one_shots') -> - case occAnal arg_env arg of { (uds1, arg') -> - case occAnalArgs env args one_shots' of { (uds2, args') -> - (uds1 `andUDs` uds2, arg':args') }}} - -{- -Applications are dealt with specially because we want -the "build hack" to work. - -Note [Arguments of let-bound constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let y = expensive x in - let z = (True,y) in - (case z of {(p,q)->q}, case z of {(p,q)->q}) -We feel free to duplicate the WHNF (True,y), but that means -that y may be duplicated thereby. - -If we aren't careful we duplicate the (expensive x) call! -Constructors are rather like lambdas in this way. --} - -occAnalApp :: OccEnv - -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) - -> (UsageDetails, Expr CoreBndr) -occAnalApp env (Var fun, args, ticks) - | null ticks = (uds, mkApps (Var fun) args') - | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') - where - uds = fun_uds `andUDs` final_args_uds - - !(args_uds, args') = occAnalArgs env args one_shots - !final_args_uds - | isRhsEnv env && is_exp = markAllNonTailCalled $ - markAllInsideLam args_uds - | otherwise = markAllNonTailCalled args_uds - -- We mark the free vars of the argument of a constructor or PAP - -- as "inside-lambda", if it is the RHS of a let(rec). - -- This means that nothing gets inlined into a constructor or PAP - -- argument position, which is what we want. Typically those - -- constructor arguments are just variables, or trivial expressions. - -- We use inside-lam because it's like eta-expanding the PAP. - -- - -- This is the *whole point* of the isRhsEnv predicate - -- See Note [Arguments of let-bound constructors] - - n_val_args = valArgCount args - n_args = length args - fun_uds = mkOneOcc env fun (n_val_args > 0) n_args - is_exp = isExpandableApp fun n_val_args - -- See Note [CONLIKE pragma] in BasicTypes - -- The definition of is_exp should match that in Simplify.prepareRhs - - one_shots = argsOneShots (idStrictness fun) guaranteed_val_args - guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo - (occ_one_shots env)) - -- See Note [Sources of one-shot information], bullet point A'] - -occAnalApp env (fun, args, ticks) - = (markAllNonTailCalled (fun_uds `andUDs` args_uds), - mkTicks ticks $ mkApps fun' args') - where - !(fun_uds, fun') = occAnal (addAppCtxt env args) fun - -- The addAppCtxt is a bit cunning. One iteration of the simplifier - -- often leaves behind beta redexs like - -- (\x y -> e) a1 a2 - -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some True items - -- onto the context stack. - !(args_uds, args') = occAnalArgs env args [] - -zapDetailsIf :: Bool -- If this is true - -> UsageDetails -- Then do zapDetails on this - -> UsageDetails -zapDetailsIf True uds = zapDetails uds -zapDetailsIf False uds = uds - -{- -Note [Sources of one-shot information] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The occurrence analyser obtains one-shot-lambda information from two sources: - -A: Saturated applications: eg f e1 .. en - - In general, given a call (f e1 .. en) we can propagate one-shot info from - f's strictness signature into e1 .. en, but /only/ if n is enough to - saturate the strictness signature. A strictness signature like - - f :: C1(C1(L))LS - - means that *if f is applied to three arguments* then it will guarantee to - call its first argument at most once, and to call the result of that at - most once. But if f has fewer than three arguments, all bets are off; e.g. - - map (f (\x y. expensive) e2) xs - - Here the \x y abstraction may be called many times (once for each element of - xs) so we should not mark x and y as one-shot. But if it was - - map (f (\x y. expensive) 3 2) xs - - then the first argument of f will be called at most once. - - The one-shot info, derived from f's strictness signature, is - computed by 'argsOneShots', called in occAnalApp. - -A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) - where f is as above. - - In this case, f is only manifestly applied to one argument, so it does not - look saturated. So by the previous point, we should not use its strictness - signature to learn about the one-shotness of \x y. But in this case we can: - build is fully applied, so we may use its strictness signature; and from - that we learn that build calls its argument with two arguments *at most once*. - - So there is really only one call to f, and it will have three arguments. In - that sense, f is saturated, and we may proceed as described above. - - Hence the computation of 'guaranteed_val_args' in occAnalApp, using - '(occ_one_shots env)'. See also #13227, comment:9 - -B: Let-bindings: eg let f = \c. let ... in \n -> blah - in (build f, build f) - - Propagate one-shot info from the demanand-info on 'f' to the - lambdas in its RHS (which may not be syntactically at the top) - - This information must have come from a previous run of the demanand - analyser. - -Previously, the demand analyser would *also* set the one-shot information, but -that code was buggy (see #11770), so doing it only in on place, namely here, is -saner. - -Note [OneShots] -~~~~~~~~~~~~~~~ -When analysing an expression, the occ_one_shots argument contains information -about how the function is being used. The length of the list indicates -how many arguments will eventually be passed to the analysed expression, -and the OneShotInfo indicates whether this application is once or multiple times. - -Example: - - Context of f occ_one_shots when analysing f - - f 1 2 [OneShot, OneShot] - map (f 1) [OneShot, NoOneShotInfo] - build f [OneShot, OneShot] - f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] - -Note [Binders in case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case x of y { (a,b) -> f y } -We treat 'a', 'b' as dead, because they don't physically occur in the -case alternative. (Indeed, a variable is dead iff it doesn't occur in -its scope in the output of OccAnal.) It really helps to know when -binders are unused. See esp the call to isDeadBinder in -Simplify.mkDupableAlt - -In this example, though, the Simplifier will bring 'a' and 'b' back to -life, beause it binds 'y' to (a,b) (imagine got inlined and -scrutinised y). --} - -occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr - -> (UsageDetails, [CoreBndr], CoreExpr) -occAnalLamOrRhs env [] body - = case occAnal env body of (body_usage, body') -> (body_usage, [], body') - -- RHS of thunk or nullary join point -occAnalLamOrRhs env (bndr:bndrs) body - | isTyVar bndr - = -- Important: Keep the environment so that we don't inline into an RHS like - -- \(@ x) -> C @x (f @x) - -- (see the beginning of Note [Cascading inlines]). - case occAnalLamOrRhs env bndrs body of - (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') -occAnalLamOrRhs env binders body - = case occAnal env_body body of { (body_usage, body') -> - let - (final_usage, tagged_binders) = tagLamBinders body_usage binders' - -- Use binders' to put one-shot info on the lambdas - in - (final_usage, tagged_binders, body') } - where - (env_body, binders') = oneShotGroup env binders - -occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) - -> CoreAlt - -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt (env, scrut_bind) (con, bndrs, rhs) - = case occAnal env rhs of { (rhs_usage1, rhs1) -> - let - (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs - -- See Note [Binders in case alternatives] - (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 - in - (alt_usg', (con, tagged_bndrs, rhs2)) } - -wrapAltRHS :: OccEnv - -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv - -> UsageDetails -- usage for entire alt (p -> rhs) - -> [Var] -- alt binders - -> CoreExpr -- alt RHS - -> (UsageDetails, CoreExpr) -wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs - | occ_binder_swap env - , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this - -- handles condition (a) in Note [Binder swap] - , not captured -- See condition (b) in Note [Binder swap] - = ( alt_usg' `andUDs` let_rhs_usg - , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) - where - captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b) - - -- The rhs of the let may include coercion variables - -- if the scrutinee was a cast, so we must gather their - -- usage. See Note [Gather occurrences of coercion variables] - -- Moreover, the rhs of the let may mention the case-binder, and - -- we want to gather its occ-info as well - (let_rhs_usg, let_rhs') = occAnal env let_rhs - - (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var - -wrapAltRHS _ _ alt_usg _ alt_rhs - = (alt_usg, alt_rhs) - -{- -************************************************************************ -* * - OccEnv -* * -************************************************************************ --} - -data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_one_shots :: !OneShots -- See Note [OneShots] - , occ_gbl_scrut :: GlobalScruts - - , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active - - , occ_rule_act :: Activation -> Bool -- Which rules are active - -- See Note [Finding rule RHS free vars] - - , occ_binder_swap :: !Bool -- enable the binder_swap - -- See CorePrep Note [Dead code in CorePrep] - } - -type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] - ------------------------------ --- OccEncl is used to control whether to inline into constructor arguments --- For example: --- x = (p,q) -- Don't inline p or q --- y = /\a -> (p a, q a) -- Still don't inline p or q --- z = f (p,q) -- Do inline p,q; it may make a rule fire --- So OccEncl tells enough about the context to know what to do when --- we encounter a constructor application or PAP. - -data OccEncl - = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - -- Don't inline into constructor args here - | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. - -- Do inline into constructor args here - -instance Outputable OccEncl where - ppr OccRhs = text "occRhs" - ppr OccVanilla = text "occVanilla" - --- See note [OneShots] -type OneShots = [OneShotInfo] - -initOccEnv :: OccEnv -initOccEnv - = OccEnv { occ_encl = OccVanilla - , occ_one_shots = [] - , occ_gbl_scrut = emptyVarSet - -- To be conservative, we say that all - -- inlines and rules are active - , occ_unf_act = \_ -> True - , occ_rule_act = \_ -> True - , occ_binder_swap = True } - -vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } - -rhsCtxt :: OccEnv -> OccEnv -rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } - -argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) -argCtxt env [] - = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) -argCtxt env (one_shots:one_shots_s) - = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) - -isRhsEnv :: OccEnv -> Bool -isRhsEnv (OccEnv { occ_encl = OccRhs }) = True -isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False - -oneShotGroup :: OccEnv -> [CoreBndr] - -> ( OccEnv - , [CoreBndr] ) - -- The result binders have one-shot-ness set that they might not have had originally. - -- This happens in (build (\c n -> e)). Here the occurrence analyser - -- linearity context knows that c,n are one-shot, and it records that fact in - -- the binder. This is useful to guide subsequent float-in/float-out tranformations - -oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs - = go ctxt bndrs [] - where - go ctxt [] rev_bndrs - = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } - , reverse rev_bndrs ) - - go [] bndrs rev_bndrs - = ( env { occ_one_shots = [], occ_encl = OccVanilla } - , reverse rev_bndrs ++ bndrs ) - - go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs - | isId bndr = go ctxt' bndrs (bndr': rev_bndrs) - | otherwise = go ctxt bndrs (bndr : rev_bndrs) - where - bndr' = updOneShotInfo bndr one_shot - -- Use updOneShotInfo, not setOneShotInfo, as pre-existing - -- one-shot info might be better than what we can infer, e.g. - -- due to explicit use of the magic 'oneShot' function. - -- See Note [The oneShot function] - - -markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var] --- Mark the lambdas of a non-recursive join point as one-shot. --- This is good to prevent gratuitous float-out etc -markJoinOneShots mb_join_arity bndrs - = case mb_join_arity of - Nothing -> bndrs - Just n -> go n bndrs - where - go 0 bndrs = bndrs - go _ [] = [] -- This can legitimately happen. - -- e.g. let j = case ... in j True - -- This will become an arity-1 join point after the - -- simplifier has eta-expanded it; but it may not have - -- enough lambdas /yet/. (Lint checks that JoinIds do - -- have enough lambdas.) - go n (b:bs) = b' : go (n-1) bs - where - b' | isId b = setOneShotLambda b - | otherwise = b - -addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args - = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } - -transClosureFV :: UniqFM VarSet -> UniqFM VarSet --- If (f,g), (g,h) are in the input, then (f,h) is in the output --- as well as (f,g), (g,h) -transClosureFV env - | no_change = env - | otherwise = transClosureFV (listToUFM new_fv_list) - where - (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) - -- It's OK to use nonDetUFMToList here because we'll forget the - -- ordering by creating a new set with listToUFM - bump no_change (b,fvs) - | no_change_here = (no_change, (b,fvs)) - | otherwise = (False, (b,new_fvs)) - where - (new_fvs, no_change_here) = extendFvs env fvs - -------------- -extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet -extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag - -extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) --- (extendFVs env s) returns --- (s `union` env(s), env(s) `subset` s) -extendFvs env s - | isNullUFM env - = (s, True) - | otherwise - = (s `unionVarSet` extras, extras `subVarSet` s) - where - extras :: VarSet -- env(s) - extras = nonDetFoldUFM unionVarSet emptyVarSet $ - -- It's OK to use nonDetFoldUFM here because unionVarSet commutes - intersectUFM_C (\x _ -> x) env (getUniqSet s) - -{- -************************************************************************ -* * - Binder swap -* * -************************************************************************ - -Note [Binder swap] -~~~~~~~~~~~~~~~~~~ -The "binder swap" tranformation swaps occurence of the -scrutinee of a case for occurrences of the case-binder: - - (1) case x of b { pi -> ri } - ==> - case x of b { pi -> let x=b in ri } - - (2) case (x |> co) of b { pi -> ri } - ==> - case (x |> co) of b { pi -> let x = b |> sym co in ri } - -In both cases, the trivial 'let' can be eliminated by the -immediately following simplifier pass. - -There are two reasons for making this swap: - -(A) It reduces the number of occurrences of the scrutinee, x. - That in turn might reduce its occurrences to one, so we - can inline it and save an allocation. E.g. - let x = factorial y in case x of b { I# v -> ...x... } - If we replace 'x' by 'b' in the alternative we get - let x = factorial y in case x of b { I# v -> ...b... } - and now we can inline 'x', thus - case (factorial y) of b { I# v -> ...b... } - -(B) The case-binder b has unfolding information; in the - example above we know that b = I# v. That in turn allows - nested cases to simplify. Consider - case x of b { I# v -> - ...(case x of b2 { I# v2 -> rhs })... - If we replace 'x' by 'b' in the alternative we get - case x of b { I# v -> - ...(case b of b2 { I# v2 -> rhs })... - and now it is trivial to simplify the inner case: - case x of b { I# v -> - ...(let b2 = b in rhs)... - - The same can happen even if the scrutinee is a variable - with a cast: see Note [Case of cast] - -In both cases, in a particular alternative (pi -> ri), we only -add the binding if - (a) x occurs free in (pi -> ri) - (ie it occurs in ri, but is not bound in pi) - (b) the pi does not bind b (or the free vars of co) -We need (a) and (b) for the inserted binding to be correct. - -For the alternatives where we inject the binding, we can transfer -all x's OccInfo to b. And that is the point. - -Notice that - * The deliberate shadowing of 'x'. - * That (a) rapidly becomes false, so no bindings are injected. - -The reason for doing these transformations /here in the occurrence -analyser/ is because it allows us to adjust the OccInfo for 'x' and -'b' as we go. - - * Suppose the only occurrences of 'x' are the scrutinee and in the - ri; then this transformation makes it occur just once, and hence - get inlined right away. - - * If instead we do this in the Simplifier, we don't know whether 'x' - is used in ri, so we are forced to pessimistically zap b's OccInfo - even though it is typically dead (ie neither it nor x appear in - the ri). There's nothing actually wrong with zapping it, except - that it's kind of nice to know which variables are dead. My nose - tells me to keep this information as robustly as possible. - -The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding -{x=b}; it's Nothing if the binder-swap doesn't happen. - -There is a danger though. Consider - let v = x +# y - in case (f v) of w -> ...v...v... -And suppose that (f v) expands to just v. Then we'd like to -use 'w' instead of 'v' in the alternative. But it may be too -late; we may have substituted the (cheap) x+#y for v in the -same simplifier pass that reduced (f v) to v. - -I think this is just too bad. CSE will recover some of it. - -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (x `cast` co) of b { I# -> - ... (case (x `cast` co) of {...}) ... -We'd like to eliminate the inner case. That is the motivation for -equation (2) in Note [Binder swap]. When we get to the inner case, we -inline x, cancel the casts, and away we go. - -Note [Binder swap on GlobalId scrutinees] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the scrutinee is a GlobalId we must take care in two ways - - i) In order to *know* whether 'x' occurs free in the RHS, we need its - occurrence info. BUT, we don't gather occurrence info for - GlobalIds. That's the reason for the (small) occ_gbl_scrut env in - OccEnv is for: it says "gather occurrence info for these". - - ii) We must call localiseId on 'x' first, in case it's a GlobalId, or - has an External Name. See, for example, SimplEnv Note [Global Ids in - the substitution]. - -Note [Zap case binders in proxy bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From the original - case x of cb(dead) { p -> ...x... } -we will get - case x of cb(live) { p -> let x = cb in ...x... } - -Core Lint never expects to find an *occurrence* of an Id marked -as Dead, so we must zap the OccInfo on cb before making the -binding x = cb. See #5028. - -NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier -doesn't use it. So this is only to satisfy the perhpas-over-picky Lint. - -Historical note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We *used* to suppress the binder-swap in case expressions when --fno-case-of-case is on. Old remarks: - "This happens in the first simplifier pass, - and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) - If we eliminate the inner case, we trap it inside the I# v -> arm, - which might prevent some full laziness happening. I've seen this - in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] - Hence the check for NoCaseOfCase." -However, now the full-laziness pass itself reverses the binder-swap, so this -check is no longer necessary. - -Historical note [Suppressing the case binder-swap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This old note describes a problem that is also fixed by doing the -binder-swap in OccAnal: - - There is another situation when it might make sense to suppress the - case-expression binde-swap. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - - We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - - But there is no point in doing it for the inner case, because w1 can't - be inlined anyway. Furthermore, doing the case-swapping involves - zapping w2's occurrence info (see paragraphs that follow), and that - forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - - This is plain silly in the common case where w2 is dead. - - Even so, I can't see a good way to implement this idea. I tried - not doing the binder-swap if the scrutinee was already evaluated - but that failed big-time: - - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - - Notice that because MkT is strict, x is marked "evaluated". But to - eliminate the last case, we must either make sure that x (as well as - x1) has unfolding MkT y1. The straightforward thing to do is to do - the binder-swap. So this whole note is a no-op. - -It's fixed by doing the binder-swap in OccAnal because we can do the -binder-swap unconditionally and still get occurrence analysis -information right. --} - -mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) --- Does three things: a) makes the occ_one_shots = OccVanilla --- b) extends the GlobalScruts if possible --- c) returns a proxy mapping, binding the scrutinee --- to the case binder, if possible -mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr - = case stripTicksTopE (const True) scrut of - Var v -> add_scrut v case_bndr' - Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) - -- See Note [Case of cast] - _ -> (env { occ_encl = OccVanilla }, Nothing) - - where - add_scrut v rhs - | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing) - | otherwise = ( env { occ_encl = OccVanilla - , occ_gbl_scrut = pe `extendVarSet` v } - , Just (localise v, rhs) ) - -- ToDO: this isGlobalId stuff is a TEMPORARY FIX - -- to avoid the binder-swap for GlobalIds - -- See #16346 - - case_bndr' = Var (zapIdOccInfo case_bndr) - -- See Note [Zap case binders in proxy bindings] - - -- Localise the scrut_var before shadowing it; we're making a - -- new binding for it, and it might have an External Name, or - -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLINE or NOINLINE pragmas! - localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) - (idType scrut_var) - -{- -************************************************************************ -* * -\subsection[OccurAnal-types]{OccEnv} -* * -************************************************************************ - -Note [UsageDetails and zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -On many occasions, we must modify all gathered occurrence data at once. For -instance, all occurrences underneath a (non-one-shot) lambda set the -'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but -that takes O(n) time and we will do this often---in particular, there are many -places where tail calls are not allowed, and each of these causes all variables -to get marked with 'NoTailCallInfo'. - -Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along -with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" -recording which variables have been zapped in some way. Zapping all occurrence -info then simply means setting the corresponding zapped set to the whole -'OccInfoEnv', a fast O(1) operation. --} - -type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage - -- INVARIANT: never IAmDead - -- (Deadness is signalled by not being in the map at all) - -type ZappedSet = OccInfoEnv -- Values are ignored - -data UsageDetails - = UD { ud_env :: !OccInfoEnv - , ud_z_many :: ZappedSet -- apply 'markMany' to these - , ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these - , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these - -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv - -instance Outputable UsageDetails where - ppr ud = ppr (ud_env (flattenUsageDetails ud)) - -------------------- --- UsageDetails API - -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails -andUDs = combineUsageDetailsWith addOccInfo -orUDs = combineUsageDetailsWith orOccInfo - -andUDsList :: [UsageDetails] -> UsageDetails -andUDsList = foldl' andUDs emptyDetails - -mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails -mkOneOcc env id int_cxt arity - | isLocalId id - = singleton $ OneOcc { occ_in_lam = False - , occ_n_br = 1 - , occ_int_cxt = int_cxt - , occ_tail = AlwaysTailCalled arity } - | id `elemVarSet` occ_gbl_scrut env - = singleton noOccInfo - - | otherwise - = emptyDetails - where - singleton info = emptyDetails { ud_env = unitVarEnv id info } - -addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails -addOneOcc ud id info - = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info } - `alterZappedSets` (`delVarEnv` id) - where - plus_zapped old new = doZapping ud id old `addOccInfo` new - -addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails -addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set - -- It's OK to use nonDetFoldUFM here because addManyOccs commutes - --- Add several occurrences, assumed not to be tail calls -addManyOccs :: Var -> UsageDetails -> UsageDetails -addManyOccs v u | isId v = addOneOcc u v noOccInfo - | otherwise = u - -- Give a non-committal binder info (i.e noOccInfo) because - -- a) Many copies of the specialised thing can appear - -- b) We don't want to substitute a BIG expression inside a RULE - -- even if that's the only occurrence of the thing - -- (Same goes for INLINE.) - -delDetails :: UsageDetails -> Id -> UsageDetails -delDetails ud bndr - = ud `alterUsageDetails` (`delVarEnv` bndr) - -delDetailsList :: UsageDetails -> [Id] -> UsageDetails -delDetailsList ud bndrs - = ud `alterUsageDetails` (`delVarEnvList` bndrs) - -emptyDetails :: UsageDetails -emptyDetails = UD { ud_env = emptyVarEnv - , ud_z_many = emptyVarEnv - , ud_z_in_lam = emptyVarEnv - , ud_z_no_tail = emptyVarEnv } - -isEmptyDetails :: UsageDetails -> Bool -isEmptyDetails = isEmptyVarEnv . ud_env - -markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails - :: UsageDetails -> UsageDetails -markAllMany ud = ud { ud_z_many = ud_env ud } -markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } -markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud } - -zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo - -lookupDetails :: UsageDetails -> Id -> OccInfo -lookupDetails ud id - | isCoVar id -- We do not currenly gather occurrence info (from types) - = noOccInfo -- for CoVars, so we must conservatively mark them as used - -- See Note [DoO not mark CoVars as dead] - | otherwise - = case lookupVarEnv (ud_env ud) id of - Just occ -> doZapping ud id occ - Nothing -> IAmDead - -usedIn :: Id -> UsageDetails -> Bool -v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud - -udFreeVars :: VarSet -> UsageDetails -> VarSet --- Find the subset of bndrs that are mentioned in uds -udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud) - -{- Note [Do not mark CoVars as dead] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's obviously wrong to mark CoVars as dead if they are used. -Currently we don't traverse types to gather usase info for CoVars, -so we had better treat them as having noOccInfo. - -This showed up in #15696 we had something like - case eq_sel d of co -> ...(typeError @(...co...) "urk")... - -Then 'd' was substitued by a dictionary, so the expression -simpified to - case (Coercion ) of co -> ...(typeError @(...co...) "urk")... - -But then the "drop the case altogether" equation of rebuildCase -thought that 'co' was dead, and discarded the entire case. Urk! - -I have no idea how we managed to avoid this pitfall for so long! --} - -------------------- --- Auxiliary functions for UsageDetails implementation - -combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) - -> UsageDetails -> UsageDetails -> UsageDetails -combineUsageDetailsWith plus_occ_info ud1 ud2 - | isEmptyDetails ud1 = ud2 - | isEmptyDetails ud2 = ud1 - | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) - , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) - , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) - , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } - -doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo -doZapping ud var occ - = doZappingByUnique ud (varUnique var) occ - -doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo -doZappingByUnique ud uniq - = (if | in_subset ud_z_many -> markMany - | in_subset ud_z_in_lam -> markInsideLam - | otherwise -> id) . - (if | in_subset ud_z_no_tail -> markNonTailCalled - | otherwise -> id) - where - in_subset field = uniq `elemVarEnvByKey` field ud - -alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails -alterZappedSets ud f - = ud { ud_z_many = f (ud_z_many ud) - , ud_z_in_lam = f (ud_z_in_lam ud) - , ud_z_no_tail = f (ud_z_no_tail ud) } - -alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails -alterUsageDetails ud f - = ud { ud_env = f (ud_env ud) } - `alterZappedSets` f - -flattenUsageDetails :: UsageDetails -> UsageDetails -flattenUsageDetails ud - = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) } - `alterZappedSets` const emptyVarEnv - -------------------- --- See Note [Adjusting right-hand sides] -adjustRhsUsage :: Maybe JoinArity -> RecFlag - -> [CoreBndr] -- Outer lambdas, AFTER occ anal - -> UsageDetails -> UsageDetails -adjustRhsUsage mb_join_arity rec_flag bndrs usage - = maybe_mark_lam (maybe_drop_tails usage) - where - maybe_mark_lam ud | one_shot = ud - | otherwise = markAllInsideLam ud - maybe_drop_tails ud | exact_join = ud - | otherwise = markAllNonTailCalled ud - - one_shot = case mb_join_arity of - Just join_arity - | isRec rec_flag -> False - | otherwise -> all isOneShotBndr (drop join_arity bndrs) - Nothing -> all isOneShotBndr bndrs - - exact_join = case mb_join_arity of - Just join_arity -> bndrs `lengthIs` join_arity - _ -> False - -type IdWithOccInfo = Id - -tagLamBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [IdWithOccInfo]) -- Tagged binders -tagLamBinders usage binders - = usage' `seq` (usage', bndrs') - where - (usage', bndrs') = mapAccumR tagLamBinder usage binders - -tagLamBinder :: UsageDetails -- Of scope - -> Id -- Binder - -> (UsageDetails, -- Details with binder removed - IdWithOccInfo) -- Tagged binders --- Used for lambda and case binders --- It copes with the fact that lambda bindings can have a --- stable unfolding, used for join points -tagLamBinder usage bndr - = (usage2, bndr') - where - occ = lookupDetails usage bndr - bndr' = setBinderOcc (markNonTailCalled occ) bndr - -- Don't try to make an argument into a join point - usage1 = usage `delDetails` bndr - usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr) - -- This is effectively the RHS of a - -- non-join-point binding, so it's okay to use - -- addManyOccsSet, which assumes no tail calls - | otherwise = usage1 - -tagNonRecBinder :: TopLevelFlag -- At top level? - -> UsageDetails -- Of scope - -> CoreBndr -- Binder - -> (UsageDetails, -- Details with binder removed - IdWithOccInfo) -- Tagged binder - -tagNonRecBinder lvl usage binder - = let - occ = lookupDetails usage binder - will_be_join = decideJoinPointHood lvl usage [binder] - occ' | will_be_join = -- must already be marked AlwaysTailCalled - ASSERT(isAlwaysTailCalled occ) occ - | otherwise = markNonTailCalled occ - binder' = setBinderOcc occ' binder - usage' = usage `delDetails` binder - in - usage' `seq` (usage', binder') - -tagRecBinders :: TopLevelFlag -- At top level? - -> UsageDetails -- Of body of let ONLY - -> [(CoreBndr, -- Binder - UsageDetails, -- RHS usage details - [CoreBndr])] -- Lambdas in new RHS - -> (UsageDetails, -- Adjusted details for whole scope, - -- with binders removed - [IdWithOccInfo]) -- Tagged binders --- Substantially more complicated than non-recursive case. Need to adjust RHS --- details *before* tagging binders (because the tags depend on the RHSes). -tagRecBinders lvl body_uds triples - = let - (bndrs, rhs_udss, _) = unzip3 triples - - -- 1. Determine join-point-hood of whole group, as determined by - -- the *unadjusted* usage details - unadj_uds = foldr andUDs body_uds rhs_udss - will_be_joins = decideJoinPointHood lvl unadj_uds bndrs - - -- 2. Adjust usage details of each RHS, taking into account the - -- join-point-hood decision - rhs_udss' = map adjust triples - adjust (bndr, rhs_uds, rhs_bndrs) - = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds - where - -- Can't use willBeJoinId_maybe here because we haven't tagged the - -- binder yet (the tag depends on these adjustments!) - mb_join_arity - | will_be_joins - , let occ = lookupDetails unadj_uds bndr - , AlwaysTailCalled arity <- tailCallInfo occ - = Just arity - | otherwise - = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if - Nothing -- we are making join points! - - -- 3. Compute final usage details from adjusted RHS details - adj_uds = foldr andUDs body_uds rhs_udss' - - -- 4. Tag each binder with its adjusted details - bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr - | bndr <- bndrs ] - - -- 5. Drop the binders from the adjusted details and return - usage' = adj_uds `delDetailsList` bndrs - in - (usage', bndrs') - -setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr -setBinderOcc occ_info bndr - | isTyVar bndr = bndr - | isExportedId bndr = if isManyOccs (idOccInfo bndr) - then bndr - else setIdOccInfo bndr noOccInfo - -- Don't use local usage info for visible-elsewhere things - -- BUT *do* erase any IAmALoopBreaker annotation, because we're - -- about to re-generate it and it shouldn't be "sticky" - - | otherwise = setIdOccInfo bndr occ_info - --- | Decide whether some bindings should be made into join points or not. --- Returns `False` if they can't be join points. Note that it's an --- all-or-nothing decision, as if multiple binders are given, they're --- assumed to be mutually recursive. --- --- It must, however, be a final decision. If we say "True" for 'f', --- and then subsequently decide /not/ make 'f' into a join point, then --- the decision about another binding 'g' might be invalidated if (say) --- 'f' tail-calls 'g'. --- --- See Note [Invariants on join points] in CoreSyn. -decideJoinPointHood :: TopLevelFlag -> UsageDetails - -> [CoreBndr] - -> Bool -decideJoinPointHood TopLevel _ _ - = False -decideJoinPointHood NotTopLevel usage bndrs - | isJoinId (head bndrs) - = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> - ppr bndrs) - all_ok - | otherwise - = all_ok - where - -- See Note [Invariants on join points]; invariants cited by number below. - -- Invariant 2 is always satisfiable by the simplifier by eta expansion. - all_ok = -- Invariant 3: Either all are join points or none are - all ok bndrs - - ok bndr - | -- Invariant 1: Only tail calls, all same join arity - AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) - - , -- Invariant 1 as applied to LHSes of rules - all (ok_rule arity) (idCoreRules bndr) - - -- Invariant 2a: stable unfoldings - -- See Note [Join points and INLINE pragmas] - , ok_unfolding arity (realIdUnfolding bndr) - - -- Invariant 4: Satisfies polymorphism rule - , isValidJoinPointType arity (idType bndr) - = True - - | otherwise - = False - - ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans - ok_rule join_arity (Rule { ru_args = args }) - = args `lengthIs` join_arity - -- Invariant 1 as applied to LHSes of rules - - -- ok_unfolding returns False if we should /not/ convert a non-join-id - -- into a join-id, even though it is AlwaysTailCalled - ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) - = not (isStableSource src && join_arity > joinRhsArity rhs) - ok_unfolding _ (DFunUnfolding {}) - = False - ok_unfolding _ _ - = True - -willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity -willBeJoinId_maybe bndr - = case tailCallInfo (idOccInfo bndr) of - AlwaysTailCalled arity -> Just arity - _ -> isJoinId_maybe bndr - - -{- Note [Join points and INLINE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let g = \x. not -- Arity 1 - {-# INLINE g #-} - in case x of - A -> g True True - B -> g True False - C -> blah2 - -Here 'g' is always tail-called applied to 2 args, but the stable -unfolding captured by the INLINE pragma has arity 1. If we try to -convert g to be a join point, its unfolding will still have arity 1 -(since it is stable, and we don't meddle with stable unfoldings), and -Lint will complain (see Note [Invariants on join points], (2a), in -CoreSyn. #13413. - -Moreover, since g is going to be inlined anyway, there is no benefit -from making it a join point. - -If it is recursive, and uselessly marked INLINE, this will stop us -making it a join point, which is annoying. But occasionally -(notably in class methods; see Note [Instances and loop breakers] in -TcInstDcls) we mark recursive things as INLINE but the recursion -unravels; so ignoring INLINE pragmas on recursive things isn't good -either. - -See Invariant 2a of Note [Invariants on join points] in CoreSyn - - -************************************************************************ -* * -\subsection{Operations over OccInfo} -* * -************************************************************************ --} - -markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo - -markMany IAmDead = IAmDead -markMany occ = ManyOccs { occ_tail = occ_tail occ } - -markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = True } -markInsideLam occ = occ - -markNonTailCalled IAmDead = IAmDead -markNonTailCalled occ = occ { occ_tail = NoTailCallInfo } - -addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo - -addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } - -- Both branches are at least One - -- (Argument is never IAmDead) - --- (orOccInfo orig new) is used --- when combining occurrence info from branches of a case - -orOccInfo (OneOcc { occ_in_lam = in_lam1 - , occ_n_br = nbr1 - , occ_int_cxt = int_cxt1 - , occ_tail = tail1 }) - (OneOcc { occ_in_lam = in_lam2 - , occ_n_br = nbr2 - , occ_int_cxt = int_cxt2 - , occ_tail = tail2 }) - = OneOcc { occ_n_br = nbr1 + nbr2 - , occ_in_lam = in_lam1 || in_lam2 - , occ_int_cxt = int_cxt1 && int_cxt2 - , occ_tail = tail1 `andTailCallInfo` tail2 } - -orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } - -andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo -andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) - | arity1 == arity2 = info -andTailCallInfo _ _ = NoTailCallInfo diff --git a/simplCore/SAT.hs b/simplCore/SAT.hs deleted file mode 100644 --- a/simplCore/SAT.hs +++ /dev/null @@ -1,433 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -************************************************************************ - - Static Argument Transformation pass - -************************************************************************ - -May be seen as removing invariants from loops: -Arguments of recursive functions that do not change in recursive -calls are removed from the recursion, which is done locally -and only passes the arguments which effectively change. - -Example: -map = /\ ab -> \f -> \xs -> case xs of - [] -> [] - (a:b) -> f a : map f b - -as map is recursively called with the same argument f (unmodified) -we transform it to - -map = /\ ab -> \f -> \xs -> let map' ys = case ys of - [] -> [] - (a:b) -> f a : map' b - in map' xs - -Notice that for a compiler that uses lambda lifting this is -useless as map' will be transformed back to what map was. - -We could possibly do the same for big lambdas, but we don't as -they will eventually be removed in later stages of the compiler, -therefore there is no penalty in keeping them. - -We only apply the SAT when the number of static args is > 2. This -produces few bad cases. See - should_transform -in saTransform. - -Here are the headline nofib results: - Size Allocs Runtime -Min +0.0% -13.7% -21.4% -Max +0.1% +0.0% +5.4% -Geometric Mean +0.0% -0.2% -6.9% - -The previous patch, to fix polymorphic floatout demand signatures, is -essential to make this work well! --} - -{-# LANGUAGE CPP #-} -module SAT ( doStaticArgs ) where - -import GhcPrelude - -import Var -import CoreSyn -import CoreUtils -import Type -import Coercion -import Id -import Name -import VarEnv -import UniqSupply -import Util -import UniqFM -import VarSet -import Unique -import UniqSet -import Outputable - -import Data.List (mapAccumL) -import FastString - -#include "HsVersions.h" - -doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram -doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds - where - sat_bind_threaded_us us bind = - let (us1, us2) = splitUniqSupply us - in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet)) - --- We don't bother to SAT recursive groups since it can lead --- to massive code expansion: see Andre Santos' thesis for details. --- This means we only apply the actual SAT to Rec groups of one element, --- but we want to recurse into the others anyway to discover other binds -satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo) -satBind (NonRec binder expr) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (NonRec binder expr', finalizeApp expr_app sat_info_expr) -satBind (Rec [(binder, rhs)]) interesting_ids = do - let interesting_ids' = interesting_ids `addOneToUniqSet` binder - (rhs_binders, rhs_body) = collectBinders rhs - (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids' - let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders) - sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body - - shadowing = binder `elementOfUniqSet` interesting_ids - sat_info_rhs'' = if shadowing - then sat_info_rhs' `delFromUFM` binder -- For safety - else sat_info_rhs' - - bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder) - rhs_binders rhs_body' - return (bind', sat_info_rhs'') -satBind (Rec pairs) interesting_ids = do - let (binders, rhss) = unzip pairs - rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss - let (rhss', sat_info_rhss') = unzip rhss_SATed - return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') - -data App = VarApp Id | TypeApp Type | CoApp Coercion -data Staticness a = Static a | NotStatic - -type IdAppInfo = (Id, SATInfo) - -type SATInfo = [Staticness App] -type IdSATInfo = IdEnv SATInfo -emptyIdSATInfo :: IdSATInfo -emptyIdSATInfo = emptyUFM - -{- -pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) - where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) --} - -pprSATInfo :: SATInfo -> SDoc -pprSATInfo staticness = hcat $ map pprStaticness staticness - -pprStaticness :: Staticness App -> SDoc -pprStaticness (Static (VarApp _)) = text "SV" -pprStaticness (Static (TypeApp _)) = text "ST" -pprStaticness (Static (CoApp _)) = text "SC" -pprStaticness NotStatic = text "NS" - - -mergeSATInfo :: SATInfo -> SATInfo -> SATInfo -mergeSATInfo l r = zipWith mergeSA l r - where - mergeSA NotStatic _ = NotStatic - mergeSA _ NotStatic = NotStatic - mergeSA (Static (VarApp v)) (Static (VarApp v')) - | v == v' = Static (VarApp v) - | otherwise = NotStatic - mergeSA (Static (TypeApp t)) (Static (TypeApp t')) - | t `eqType` t' = Static (TypeApp t) - | otherwise = NotStatic - mergeSA (Static (CoApp c)) (Static (CoApp c')) - | c `eqCoercion` c' = Static (CoApp c) - | otherwise = NotStatic - mergeSA _ _ = pprPanic "mergeSATInfo" $ - text "Left:" - <> pprSATInfo l <> text ", " - <> text "Right:" - <> pprSATInfo r - -mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo -mergeIdSATInfo = plusUFM_C mergeSATInfo - -mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo -mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo - -bindersToSATInfo :: [Id] -> SATInfo -bindersToSATInfo vs = map (Static . binderToApp) vs - where binderToApp v | isId v = VarApp v - | isTyVar v = TypeApp $ mkTyVarTy v - | otherwise = CoApp $ mkCoVarCo v - -finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo -finalizeApp Nothing id_sat_info = id_sat_info -finalizeApp (Just (v, sat_info')) id_sat_info = - let sat_info'' = case lookupUFM id_sat_info v of - Nothing -> sat_info' - Just sat_info -> mergeSATInfo sat_info sat_info' - in extendVarEnv id_sat_info v sat_info'' - -satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo) -satTopLevelExpr expr interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (expr', finalizeApp expr_app sat_info_expr) - -satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) -satExpr var@(Var v) interesting_ids = do - let app_info = if v `elementOfUniqSet` interesting_ids - then Just (v, []) - else Nothing - return (var, emptyIdSATInfo, app_info) - -satExpr lit@(Lit _) _ = do - return (lit, emptyIdSATInfo, Nothing) - -satExpr (Lam binders body) interesting_ids = do - (body', sat_info, this_app) <- satExpr body interesting_ids - return (Lam binders body', finalizeApp this_app sat_info, Nothing) - -satExpr (App fn arg) interesting_ids = do - (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids - let satRemainder = boring fn' sat_info_fn - case fn_app of - Nothing -> satRemainder Nothing - Just (fn_id, fn_app_info) -> - -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) - let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) - in case arg of - Type t -> satRemainderWithStaticness $ Static (TypeApp t) - Coercion c -> satRemainderWithStaticness $ Static (CoApp c) - Var v -> satRemainderWithStaticness $ Static (VarApp v) - _ -> satRemainderWithStaticness $ NotStatic - where - boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) - boring fn' sat_info_fn app_info = - do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids - let sat_info_arg' = finalizeApp arg_app sat_info_arg - sat_info = mergeIdSATInfo sat_info_fn sat_info_arg' - return (App fn' arg', sat_info, app_info) - -satExpr (Case expr bndr ty alts) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - let sat_info_expr' = finalizeApp expr_app sat_info_expr - - zipped_alts' <- mapM satAlt alts - let (alts', sat_infos_alts) = unzip zipped_alts' - return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) - where - satAlt (con, bndrs, expr) = do - (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids - return ((con, bndrs, expr'), sat_info_expr) - -satExpr (Let bind body) interesting_ids = do - (body', sat_info_body, body_app) <- satExpr body interesting_ids - (bind', sat_info_bind) <- satBind bind interesting_ids - return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app) - -satExpr (Tick tickish expr) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (Tick tickish expr', sat_info_expr, expr_app) - -satExpr ty@(Type _) _ = do - return (ty, emptyIdSATInfo, Nothing) - -satExpr co@(Coercion _) _ = do - return (co, emptyIdSATInfo, Nothing) - -satExpr (Cast expr coercion) interesting_ids = do - (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids - return (Cast expr' coercion, sat_info_expr, expr_app) - -{- -************************************************************************ - - Static Argument Transformation Monad - -************************************************************************ --} - -type SatM result = UniqSM result - -runSAT :: UniqSupply -> SatM a -> a -runSAT = initUs_ - -newUnique :: SatM Unique -newUnique = getUniqueM - -{- -************************************************************************ - - Static Argument Transformation Monad - -************************************************************************ - -To do the transformation, the game plan is to: - -1. Create a small nonrecursive RHS that takes the - original arguments to the function but discards - the ones that are static and makes a call to the - SATed version with the remainder. We intend that - this will be inlined later, removing the overhead - -2. Bind this nonrecursive RHS over the original body - WITH THE SAME UNIQUE as the original body so that - any recursive calls to the original now go via - the small wrapper - -3. Rebind the original function to a new one which contains - our SATed function and just makes a call to it: - we call the thing making this call the local body - -Example: transform this - - map :: forall a b. (a->b) -> [a] -> [b] - map = /\ab. \(f:a->b) (as:[a]) -> body[map] -to - map :: forall a b. (a->b) -> [a] -> [b] - map = /\ab. \(f:a->b) (as:[a]) -> - letrec map' :: [a] -> [b] - -- The "worker function - map' = \(as:[a]) -> - let map :: forall a' b'. (a -> b) -> [a] -> [b] - -- The "shadow function - map = /\a'b'. \(f':(a->b) (as:[a]). - map' as - in body[map] - in map' as - -Note [Shadow binding] -~~~~~~~~~~~~~~~~~~~~~ -The calls to the inner map inside body[map] should get inlined -by the local re-binding of 'map'. We call this the "shadow binding". - -But we can't use the original binder 'map' unchanged, because -it might be exported, in which case the shadow binding won't be -discarded as dead code after it is inlined. - -So we use a hack: we make a new SysLocal binder with the *same* unique -as binder. (Another alternative would be to reset the export flag.) - -Note [Binder type capture] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that in the inner map (the "shadow function"), the static arguments -are discarded -- it's as if they were underscores. Instead, mentions -of these arguments (notably in the types of dynamic arguments) are bound -by the *outer* lambdas of the main function. So we must make up fresh -names for the static arguments so that they do not capture variables -mentioned in the types of dynamic args. - -In the map example, the shadow function must clone the static type -argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a' -is bound by the outer forall. We clone f' too for consistency, but -that doesn't matter either way because static Id arguments aren't -mentioned in the shadow binding at all. - -If we don't we get something like this: - -[Exported] -[Arity 3] -GHC.Base.until = - \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Types.Bool) - (f_a6V :: a_aiK -> a_aiK) - (x_a6X :: a_aiK) -> - letrec { - sat_worker_s1aU :: a_aiK -> a_aiK - [] - sat_worker_s1aU = - \ (x_a6X :: a_aiK) -> - let { - sat_shadow_r17 :: forall a_a3O. - (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O - [] - sat_shadow_r17 = - \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Types.Bool) - (f_a6V :: a_aiK -> a_aiK) - (x_a6X :: a_aiK) -> - sat_worker_s1aU x_a6X } in - case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { - GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); - GHC.Types.True -> x_a6X - }; } in - sat_worker_s1aU x_a6X - -Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK -type argument. This is bad because it means the application sat_worker_s1aU x_a6X -is not well typed. --} - -saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind -saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body - | Just arg_staticness <- maybe_arg_staticness - , should_transform arg_staticness - = saTransform binder arg_staticness rhs_binders rhs_body - | otherwise - = return (Rec [(binder, mkLams rhs_binders rhs_body)]) - where - should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT - where - n_static_args = count isStaticValue staticness - -saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind -saTransform binder arg_staticness rhs_binders rhs_body - = do { shadow_lam_bndrs <- mapM clone binders_w_staticness - ; uniq <- newUnique - ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } - where - -- Running example: foldr - -- foldr \alpha \beta c n xs = e, for some e - -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic] - -- rhs_binders = [\alpha, \beta, c, n, xs] - -- rhs_body = e - - binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) - -- Any extra args are assumed NotStatic - - non_static_args :: [Var] - -- non_static_args = [xs] - -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] - non_static_args = [v | (v, NotStatic) <- binders_w_staticness] - - clone (bndr, NotStatic) = return bndr - clone (bndr, _ ) = do { uniq <- newUnique - ; return (setVarUnique bndr uniq) } - - -- new_rhs = \alpha beta c n xs -> - -- let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs -> - -- sat_worker xs - -- in e - -- in sat_worker xs - mk_new_rhs uniq shadow_lam_bndrs - = mkLams rhs_binders $ - Let (Rec [(rec_body_bndr, rec_body)]) - local_body - where - local_body = mkVarApps (Var rec_body_bndr) non_static_args - - rec_body = mkLams non_static_args $ - Let (NonRec shadow_bndr shadow_rhs) rhs_body - - -- See Note [Binder type capture] - shadow_rhs = mkLams shadow_lam_bndrs local_body - -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs - - rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body) - -- rec_body_bndr = sat_worker - - -- See Note [Shadow binding]; make a SysLocal - shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) - (idUnique binder) - (exprType shadow_rhs) - -isStaticValue :: Staticness App -> Bool -isStaticValue (Static (VarApp _)) = True -isStaticValue _ = False diff --git a/simplCore/SetLevels.hs b/simplCore/SetLevels.hs deleted file mode 100644 --- a/simplCore/SetLevels.hs +++ /dev/null @@ -1,1775 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{SetLevels} - - *************************** - Overview - *************************** - -1. We attach binding levels to Core bindings, in preparation for floating - outwards (@FloatOut@). - -2. We also let-ify many expressions (notably case scrutinees), so they - will have a fighting chance of being floated sensible. - -3. Note [Need for cloning during float-out] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We clone the binders of any floatable let-binding, so that when it is - floated out it will be unique. Example - (let x=2 in x) + (let x=3 in x) - we must clone before floating so we get - let x1=2 in - let x2=3 in - x1+x2 - - NOTE: this can't be done using the uniqAway idea, because the variable - must be unique in the whole program, not just its current scope, - because two variables in different scopes may float out to the - same top level place - - NOTE: Very tiresomely, we must apply this substitution to - the rules stored inside a variable too. - - We do *not* clone top-level bindings, because some of them must not change, - but we *do* clone bindings that are heading for the top level - -4. Note [Binder-swap during float-out] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - In the expression - case x of wild { p -> ...wild... } - we substitute x for wild in the RHS of the case alternatives: - case x of wild { p -> ...x... } - This means that a sub-expression involving x is not "trapped" inside the RHS. - And it's not inconvenient because we already have a substitution. - - Note that this is EXACTLY BACKWARDS from the what the simplifier does. - The simplifier tries to get rid of occurrences of x, in favour of wild, - in the hope that there will only be one remaining occurrence of x, namely - the scrutinee of the case, and we can inline it. --} - -{-# LANGUAGE CPP, MultiWayIf #-} -module SetLevels ( - setLevels, - - Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl, - LevelledBind, LevelledExpr, LevelledBndr, - FloatSpec(..), floatSpecLevel, - - incMinorLvl, ltMajLvl, ltLvl, isTopLvl - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreMonad ( FloatOutSwitches(..) ) -import CoreUtils ( exprType, exprIsHNF - , exprOkForSpeculation - , exprIsTopLevelBindable - , isExprLevPoly - , collectMakeStaticArgs - ) -import CoreArity ( exprBotStrictness_maybe ) -import CoreFVs -- all of it -import CoreSubst -import MkCore ( sortQuantVars ) - -import Id -import IdInfo -import Var -import VarSet -import UniqSet ( nonDetFoldUniqSet ) -import UniqDSet ( getUniqDSet ) -import VarEnv -import Literal ( litIsTrivial ) -import Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) -import Name ( getOccName, mkSystemVarName ) -import OccName ( occNameString ) -import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType - , mightBeUnliftedType, closeOverKindsDSet ) -import BasicTypes ( Arity, RecFlag(..), isRec ) -import DataCon ( dataConOrigResTy ) -import TysWiredIn -import UniqSupply -import Util -import Outputable -import FastString -import UniqDFM -import FV -import Data.Maybe -import MonadUtils ( mapAccumLM ) - -{- -************************************************************************ -* * -\subsection{Level numbers} -* * -************************************************************************ --} - -type LevelledExpr = TaggedExpr FloatSpec -type LevelledBind = TaggedBind FloatSpec -type LevelledBndr = TaggedBndr FloatSpec - -data Level = Level Int -- Level number of enclosing lambdas - Int -- Number of big-lambda and/or case expressions and/or - -- context boundaries between - -- here and the nearest enclosing lambda - LevelType -- Binder or join ceiling? -data LevelType = BndrLvl | JoinCeilLvl deriving (Eq) - -data FloatSpec - = FloatMe Level -- Float to just inside the binding - -- tagged with this level - | StayPut Level -- Stay where it is; binding is - -- tagged with this level - -floatSpecLevel :: FloatSpec -> Level -floatSpecLevel (FloatMe l) = l -floatSpecLevel (StayPut l) = l - -{- -The {\em level number} on a (type-)lambda-bound variable is the -nesting depth of the (type-)lambda which binds it. The outermost lambda -has level 1, so (Level 0 0) means that the variable is bound outside any lambda. - -On an expression, it's the maximum level number of its free -(type-)variables. On a let(rec)-bound variable, it's the level of its -RHS. On a case-bound variable, it's the number of enclosing lambdas. - -Top-level variables: level~0. Those bound on the RHS of a top-level -definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown -as ``subscripts'')... -\begin{verbatim} -a_0 = let b_? = ... in - x_1 = ... b ... in ... -\end{verbatim} - -The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@). -That's meant to be the level number of the enclosing binder in the -final (floated) program. If the level number of a sub-expression is -less than that of the context, then it might be worth let-binding the -sub-expression so that it will indeed float. - -If you can float to level @Level 0 0@ worth doing so because then your -allocation becomes static instead of dynamic. We always start with -context @Level 0 0@. - - -Note [FloatOut inside INLINE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose: -to say "don't float anything out of here". That's exactly what we -want for the body of an INLINE, where we don't want to float anything -out at all. See notes with lvlMFE below. - -But, check this out: - --- At one time I tried the effect of not floating anything out of an InlineMe, --- but it sometimes works badly. For example, consider PrelArr.done. It --- has the form __inline (\d. e) --- where e doesn't mention d. If we float this to --- __inline (let x = e in \d. x) --- things are bad. The inliner doesn't even inline it because it doesn't look --- like a head-normal form. So it seems a lesser evil to let things float. --- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe --- which discourages floating out. - -So the conclusion is: don't do any floating at all inside an InlineMe. -(In the above example, don't float the {x=e} out of the \d.) - -One particular case is that of workers: we don't want to float the -call to the worker outside the wrapper, otherwise the worker might get -inlined into the floated expression, and an importing module won't see -the worker at all. - -Note [Join ceiling] -~~~~~~~~~~~~~~~~~~~ -Join points can't float very far; too far, and they can't remain join points -So, suppose we have: - - f x = (joinrec j y = ... x ... in jump j x) + 1 - -One may be tempted to float j out to the top of f's RHS, but then the jump -would not be a tail call. Thus we keep track of a level called the *join -ceiling* past which join points are not allowed to float. - -The troublesome thing is that, unlike most levels to which something might -float, there is not necessarily an identifier to which the join ceiling is -attached. Fortunately, if something is to be floated to a join ceiling, it must -be dropped at the *nearest* join ceiling. Thus each level is marked as to -whether it is a join ceiling, so that FloatOut can tell which binders are being -floated to the nearest join ceiling and which to a particular binder (or set of -binders). --} - -instance Outputable FloatSpec where - ppr (FloatMe l) = char 'F' <> ppr l - ppr (StayPut l) = ppr l - -tOP_LEVEL :: Level -tOP_LEVEL = Level 0 0 BndrLvl - -incMajorLvl :: Level -> Level -incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl - -incMinorLvl :: Level -> Level -incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl - -asJoinCeilLvl :: Level -> Level -asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl - -maxLvl :: Level -> Level -> Level -maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _) - | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 - | otherwise = l2 - -ltLvl :: Level -> Level -> Bool -ltLvl (Level maj1 min1 _) (Level maj2 min2 _) - = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) - -ltMajLvl :: Level -> Level -> Bool - -- Tells if one level belongs to a difft *lambda* level to another -ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2 - -isTopLvl :: Level -> Bool -isTopLvl (Level 0 0 _) = True -isTopLvl _ = False - -isJoinCeilLvl :: Level -> Bool -isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl - -instance Outputable Level where - ppr (Level maj min typ) - = hcat [ char '<', int maj, char ',', int min, char '>' - , ppWhen (typ == JoinCeilLvl) (char 'C') ] - -instance Eq Level where - (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2 - -{- -************************************************************************ -* * -\subsection{Main level-setting code} -* * -************************************************************************ --} - -setLevels :: FloatOutSwitches - -> CoreProgram - -> UniqSupply - -> [LevelledBind] - -setLevels float_lams binds us - = initLvl us (do_them init_env binds) - where - init_env = initialEnv float_lams - - do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] - do_them _ [] = return [] - do_them env (b:bs) - = do { (lvld_bind, env') <- lvlTopBind env b - ; lvld_binds <- do_them env' bs - ; return (lvld_bind : lvld_binds) } - -lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) -lvlTopBind env (NonRec bndr rhs) - = do { rhs' <- lvl_top env NonRecursive bndr rhs - ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr] - ; return (NonRec bndr' rhs', env') } - -lvlTopBind env (Rec pairs) - = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL - (map fst pairs) - ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs - ; return (Rec (bndrs' `zip` rhss'), env') } - -lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr -lvl_top env is_rec bndr rhs - = lvlRhs env is_rec - (isBottomingId bndr) - Nothing -- Not a join point - (freeVars rhs) - -{- -************************************************************************ -* * -\subsection{Setting expression levels} -* * -************************************************************************ - -Note [Floating over-saturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (f x y), and (f x) is a redex (ie f's arity is 1), -we call (f x) an "over-saturated application" - -Should we float out an over-sat app, if can escape a value lambda? -It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2). -But we don't want to do it for class selectors, because the work saved -is minimal, and the extra local thunks allocated cost money. - -Arguably we could float even class-op applications if they were going to -top level -- but then they must be applied to a constant dictionary and -will almost certainly be optimised away anyway. --} - -lvlExpr :: LevelEnv -- Context - -> CoreExprWithFVs -- Input expression - -> LvlM LevelledExpr -- Result expression - -{- -The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing -binder. Here's an example - - v = \x -> ...\y -> let r = case (..x..) of - ..x.. - in .. - -When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's -the level of @r@, even though it's inside a level-2 @\y@. It's -important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we -don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE ---- because it isn't a *maximal* free expression. - -If there were another lambda in @r@'s rhs, it would get level-2 as well. --} - -lvlExpr env (_, AnnType ty) = return (Type (CoreSubst.substTy (le_subst env) ty)) -lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) -lvlExpr env (_, AnnVar v) = return (lookupVar env v) -lvlExpr _ (_, AnnLit lit) = return (Lit lit) - -lvlExpr env (_, AnnCast expr (_, co)) = do - expr' <- lvlNonTailExpr env expr - return (Cast expr' (substCo (le_subst env) co)) - -lvlExpr env (_, AnnTick tickish expr) = do - expr' <- lvlNonTailExpr env expr - let tickish' = substTickish (le_subst env) tickish - return (Tick tickish' expr') - -lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr) - --- We don't split adjacent lambdas. That is, given --- \x y -> (x+1,y) --- we don't float to give --- \x -> let v = x+1 in \y -> (v,y) --- Why not? Because partial applications are fairly rare, and splitting --- lambdas makes them more expensive. - -lvlExpr env expr@(_, AnnLam {}) - = do { new_body <- lvlNonTailMFE new_env True body - ; return (mkLams new_bndrs new_body) } - where - (bndrs, body) = collectAnnBndrs expr - (env1, bndrs1) = substBndrsSL NonRecursive env bndrs - (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1 - -- At one time we called a special version of collectBinders, - -- which ignored coercions, because we don't want to split - -- a lambda like this (\x -> coerce t (\s -> ...)) - -- This used to happen quite a bit in state-transformer programs, - -- but not nearly so much now non-recursive newtypes are transparent. - -- [See SetLevels rev 1.50 for a version with this approach.] - -lvlExpr env (_, AnnLet bind body) - = do { (bind', new_env) <- lvlBind env bind - ; body' <- lvlExpr new_env body - -- No point in going via lvlMFE here. If the binding is alive - -- (mentioned in body), and the whole let-expression doesn't - -- float, then neither will the body - ; return (Let bind' body') } - -lvlExpr env (_, AnnCase scrut case_bndr ty alts) - = do { scrut' <- lvlNonTailMFE env True scrut - ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts } - -lvlNonTailExpr :: LevelEnv -- Context - -> CoreExprWithFVs -- Input expression - -> LvlM LevelledExpr -- Result expression -lvlNonTailExpr env expr - = lvlExpr (placeJoinCeiling env) expr - -------------------------------------------- -lvlApp :: LevelEnv - -> CoreExprWithFVs - -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application - -> LvlM LevelledExpr -- Result expression -lvlApp env orig_expr ((_,AnnVar fn), args) - | floatOverSat env -- See Note [Floating over-saturated applications] - , arity > 0 - , arity < n_val_args - , Nothing <- isClassOpId_maybe fn - = do { rargs' <- mapM (lvlNonTailMFE env False) rargs - ; lapp' <- lvlNonTailMFE env False lapp - ; return (foldl' App lapp' rargs') } - - | otherwise - = do { (_, args') <- mapAccumLM lvl_arg stricts args - -- Take account of argument strictness; see - -- Note [Floating to the top] - ; return (foldl' App (lookupVar env fn) args') } - where - n_val_args = count (isValArg . deAnnotate) args - arity = idArity fn - - stricts :: [Demand] -- True for strict /value/ arguments - stricts = case splitStrictSig (idStrictness fn) of - (arg_ds, _) | arg_ds `lengthExceeds` n_val_args - -> [] - | otherwise - -> arg_ds - - -- Separate out the PAP that we are floating from the extra - -- arguments, by traversing the spine until we have collected - -- (n_val_args - arity) value arguments. - (lapp, rargs) = left (n_val_args - arity) orig_expr [] - - left 0 e rargs = (e, rargs) - left n (_, AnnApp f a) rargs - | isValArg (deAnnotate a) = left (n-1) f (a:rargs) - | otherwise = left n f (a:rargs) - left _ _ _ = panic "SetLevels.lvlExpr.left" - - is_val_arg :: CoreExprWithFVs -> Bool - is_val_arg (_, AnnType {}) = False - is_val_arg _ = True - - lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr) - lvl_arg strs arg | (str1 : strs') <- strs - , is_val_arg arg - = do { arg' <- lvlMFE env (isStrictDmd str1) arg - ; return (strs', arg') } - | otherwise - = do { arg' <- lvlMFE env False arg - ; return (strs, arg') } - -lvlApp env _ (fun, args) - = -- No PAPs that we can float: just carry on with the - -- arguments and the function. - do { args' <- mapM (lvlNonTailMFE env False) args - ; fun' <- lvlNonTailExpr env fun - ; return (foldl' App fun' args') } - -------------------------------------------- -lvlCase :: LevelEnv -- Level of in-scope names/tyvars - -> DVarSet -- Free vars of input scrutinee - -> LevelledExpr -- Processed scrutinee - -> Id -> Type -- Case binder and result type - -> [CoreAltWithFVs] -- Input alternatives - -> LvlM LevelledExpr -- Result expression -lvlCase env scrut_fvs scrut' case_bndr ty alts - -- See Note [Floating single-alternative cases] - | [(con@(DataAlt {}), bs, body)] <- alts - , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] - , not (isTopLvl dest_lvl) -- Can't have top-level cases - , not (floatTopLvlOnly env) -- Can float anywhere - = -- Always float the case if possible - -- Unlike lets we don't insist that it escapes a value lambda - do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) - ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' - ; body' <- lvlMFE rhs_env True body - ; let alt' = (con, map (stayPut dest_lvl) bs', body') - ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } - - | otherwise -- Stays put - = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr] - alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut' - ; alts' <- mapM (lvl_alt alts_env) alts - ; return (Case scrut' case_bndr' ty' alts') } - where - ty' = substTy (le_subst env) ty - - incd_lvl = incMinorLvl (le_ctxt_lvl env) - dest_lvl = maxFvLevel (const True) env scrut_fvs - -- Don't abstract over type variables, hence const True - - lvl_alt alts_env (con, bs, rhs) - = do { rhs' <- lvlMFE new_env True rhs - ; return (con, bs', rhs') } - where - (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs - -{- Note [Floating single-alternative cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - data T a = MkT !a - f :: T Int -> blah - f x vs = case x of { MkT y -> - let f vs = ...(case y of I# w -> e)...f.. - in f vs - -Here we can float the (case y ...) out, because y is sure -to be evaluated, to give - f x vs = case x of { MkT y -> - case y of I# w -> - let f vs = ...(e)...f.. - in f vs - -That saves unboxing it every time round the loop. It's important in -some DPH stuff where we really want to avoid that repeated unboxing in -the inner loop. - -Things to note: - - * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation. - - - exrpIsHNF catches the key case of an evaluated variable - - - exprOkForSpeculation is /false/ of an evaluated variable; - See Note [exprOkForSpeculation and evaluated variables] in CoreUtils - So we'd actually miss the key case! - - - Nothing is gained from the extra generality of exprOkForSpeculation - since we only consider floating a case whose single alternative - is a DataAlt K a b -> rhs - - * We can't float a case to top level - - * It's worth doing this float even if we don't float - the case outside a value lambda. Example - case x of { - MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) - If we floated the cases out we could eliminate one of them. - - * We only do this with a single-alternative case - - -Note [Setting levels when floating single-alternative cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Handling level-setting when floating a single-alternative case binding -is a bit subtle, as evidenced by #16978. In particular, we must keep -in mind that we are merely moving the case and its binders, not the -body. For example, suppose 'a' is known to be evaluated and we have - - \z -> case a of - (x,_) -> - -After floating we may have: - - case a of - (x,_) -> \z -> - {- some expression involving x and z -} - -When analysing we want to use the /ambient/ level, -and /not/ the desitnation level of the 'case a of (x,-) ->' binding. - -#16978 was caused by us setting the context level to the destination -level of `x` when analysing . This led us to conclude that we -needed to quantify over some of its free variables (e.g. z), resulting -in shadowing and very confusing Core Lint failures. - - -Note [Check the output scrutinee for exprIsHNF] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - case x of y { - A -> ....(case y of alts).... - } - -Because of the binder-swap, the inner case will get substituted to -(case x of ..). So when testing whether the scrutinee is in HNF we -must be careful to test the *result* scrutinee ('x' in this case), not -the *input* one 'y'. The latter *is* in HNF here (because y is -evaluated), but the former is not -- and indeed we can't float the -inner case out, at least not unless x is also evaluated at its binding -site. See #5453. - -That's why we apply exprIsHNF to scrut' and not to scrut. - -See Note [Floating single-alternative cases] for why -we use exprIsHNF in the first place. --} - -lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars - -> Bool -- True <=> strict context [body of case - -- or let] - -> CoreExprWithFVs -- input expression - -> LvlM LevelledExpr -- Result expression -lvlNonTailMFE env strict_ctxt ann_expr - = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr - -lvlMFE :: LevelEnv -- Level of in-scope names/tyvars - -> Bool -- True <=> strict context [body of case or let] - -> CoreExprWithFVs -- input expression - -> LvlM LevelledExpr -- Result expression --- lvlMFE is just like lvlExpr, except that it might let-bind --- the expression, so that it can itself be floated. - -lvlMFE env _ (_, AnnType ty) - = return (Type (CoreSubst.substTy (le_subst env) ty)) - --- No point in floating out an expression wrapped in a coercion or note --- If we do we'll transform lvl = e |> co --- to lvl' = e; lvl = lvl' |> co --- and then inline lvl. Better just to float out the payload. -lvlMFE env strict_ctxt (_, AnnTick t e) - = do { e' <- lvlMFE env strict_ctxt e - ; let t' = substTickish (le_subst env) t - ; return (Tick t' e') } - -lvlMFE env strict_ctxt (_, AnnCast e (_, co)) - = do { e' <- lvlMFE env strict_ctxt e - ; return (Cast e' (substCo (le_subst env) co)) } - -lvlMFE env strict_ctxt e@(_, AnnCase {}) - | strict_ctxt -- Don't share cases in a strict context - = lvlExpr env e -- See Note [Case MFEs] - -lvlMFE env strict_ctxt ann_expr - | floatTopLvlOnly env && not (isTopLvl dest_lvl) - -- Only floating to the top level is allowed. - || hasFreeJoin env fvs -- If there is a free join, don't float - -- See Note [Free join points] - || isExprLevPoly expr - -- We can't let-bind levity polymorphic expressions - -- See Note [Levity polymorphism invariants] in CoreSyn - || notWorthFloating expr abs_vars - || not float_me - = -- Don't float it out - lvlExpr env ann_expr - - | float_is_new_lam || exprIsTopLevelBindable expr expr_ty - -- No wrapping needed if the type is lifted, or is a literal string - -- or if we are wrapping it in one or more value lambdas - = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive - (isJust mb_bot_str) - join_arity_maybe - ann_expr - -- Treat the expr just like a right-hand side - ; var <- newLvlVar expr1 join_arity_maybe is_mk_static - ; let var2 = annotateBotStr var float_n_lams mb_bot_str - ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1) - (mkVarApps (Var var2) abs_vars)) } - - -- OK, so the float has an unlifted type (not top-level bindable) - -- and no new value lambdas (float_is_new_lam is False) - -- Try for the boxing strategy - -- See Note [Floating MFEs of unlifted type] - | escapes_value_lam - , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions - -- See Note [Test cheapness with exprOkForSpeculation] - , Just (tc, _) <- splitTyConApp_maybe expr_ty - , Just dc <- boxingDataCon_maybe tc - , let dc_res_ty = dataConOrigResTy dc -- No free type variables - [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty] - = do { expr1 <- lvlExpr rhs_env ann_expr - ; let l1r = incMinorLvlFrom rhs_env - float_rhs = mkLams abs_vars_w_lvls $ - Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] - - ; var <- newLvlVar float_rhs Nothing is_mk_static - ; let l1u = incMinorLvlFrom env - use_expr = Case (mkVarApps (Var var) abs_vars) - (stayPut l1u bx_bndr) expr_ty - [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] - ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) - use_expr) } - - | otherwise -- e.g. do not float unboxed tuples - = lvlExpr env ann_expr - - where - expr = deAnnotate ann_expr - expr_ty = exprType expr - fvs = freeVarsOf ann_expr - fvs_ty = tyCoVarsOfType expr_ty - is_bot = isBottomThunk mb_bot_str - is_function = isFunction ann_expr - mb_bot_str = exprBotStrictness_maybe expr - -- See Note [Bottoming floats] - -- esp Bottoming floats (2) - expr_ok_for_spec = exprOkForSpeculation expr - dest_lvl = destLevel env fvs fvs_ty is_function is_bot False - abs_vars = abstractVars dest_lvl env fvs - - -- float_is_new_lam: the floated thing will be a new value lambda - -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is - -- allocation saved. The benefit is to get it to the top level - -- and hence out of the body of this function altogether, making - -- it smaller and more inlinable - float_is_new_lam = float_n_lams > 0 - float_n_lams = count isId abs_vars - - (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars - - join_arity_maybe = Nothing - - is_mk_static = isJust (collectMakeStaticArgs expr) - -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable - - -- A decision to float entails let-binding this thing, and we only do - -- that if we'll escape a value lambda, or will go to the top level. - float_me = saves_work || saves_alloc || is_mk_static - - -- We can save work if we can move a redex outside a value lambda - -- But if float_is_new_lam is True, then the redex is wrapped in a - -- a new lambda, so no work is saved - saves_work = escapes_value_lam && not float_is_new_lam - - escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) - -- See Note [Escaping a value lambda] - - -- See Note [Floating to the top] - saves_alloc = isTopLvl dest_lvl - && floatConsts env - && (not strict_ctxt || is_bot || exprIsHNF expr) - -hasFreeJoin :: LevelEnv -> DVarSet -> Bool --- Has a free join point which is not being floated to top level. --- (In the latter case it won't be a join point any more.) --- Not treating top-level ones specially had a massive effect --- on nofib/minimax/Prog.prog -hasFreeJoin env fvs - = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) - -isBottomThunk :: Maybe (Arity, s) -> Bool --- See Note [Bottoming floats] (2) -isBottomThunk (Just (0, _)) = True -- Zero arity -isBottomThunk _ = False - -{- Note [Floating to the top] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are keen to float something to the top level, even if it does not -escape a value lambda (and hence save work), for two reasons: - - * Doing so makes the function smaller, by floating out - bottoming expressions, or integer or string literals. That in - turn makes it easier to inline, with less duplication. - - * (Minor) Doing so may turn a dynamic allocation (done by machine - instructions) into a static one. Minor because we are assuming - we are not escaping a value lambda. - -But do not so if: - - the context is a strict, and - - the expression is not a HNF, and - - the expression is not bottoming - -Exammples: - -* Bottoming - f x = case x of - 0 -> error - _ -> x+1 - Here we want to float (error ) to top level, abstracting - over 'x', so as to make f's RHS smaller. - -* HNF - f = case y of - True -> p:q - False -> blah - We may as well float the (p:q) so it becomes a static data structure. - -* Case scrutinee - f = case g True of .... - Don't float (g True) to top level; then we have the admin of a - top-level thunk to worry about, with zero gain. - -* Case alternative - h = case y of - True -> g True - False -> False - Don't float (g True) to the top level - -* Arguments - t = f (g True) - If f is lazy, we /do/ float (g True) because then we can allocate - the thunk statically rather than dynamically. But if f is strict - we don't (see the use of idStrictness in lvlApp). It's not clear - if this test is worth the bother: it's only about CAFs! - -It's controlled by a flag (floatConsts), because doing this too -early loses opportunities for RULES which (needless to say) are -important in some nofib programs (gcd is an example). [SPJ note: -I think this is obselete; the flag seems always on.] - -Note [Floating join point bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we only float a join point if it can /stay/ a join point. But -there is one exception: if it can go to the top level (#13286). -Consider - f x = joinrec j y n = <...j y' n'...> - in jump j x 0 - -Here we may just as well produce - j y n = <....j y' n'...> - f x = j x 0 - -and now there is a chance that 'f' will be inlined at its call sites. -It shouldn't make a lot of difference, but thes tests - perf/should_run/MethSharing - simplCore/should_compile/spec-inline -and one nofib program, all improve if you do float to top, because -of the resulting inlining of f. So ok, let's do it. - -Note [Free join points] -~~~~~~~~~~~~~~~~~~~~~~~ -We never float a MFE that has a free join-point variable. You mght think -this can never occur. After all, consider - join j x = ... - in ....(jump j x).... -How might we ever want to float that (jump j x)? - * If it would escape a value lambda, thus - join j x = ... in (\y. ...(jump j x)... ) - then 'j' isn't a valid join point in the first place. - -But consider - join j x = .... in - joinrec j2 y = ...(jump j x)...(a+b).... - -Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec. -But it is emphatically /not/ good to float the (jump j x) out: - (a) 'j' will stop being a join point - (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no - work would be saved by floating it out of the \y. - -Even if we floated 'j' to top level, (b) would still hold. - -Bottom line: never float a MFE that has a free JoinId. - -Note [Floating MFEs of unlifted type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - case f x of (r::Int#) -> blah -we'd like to float (f x). But it's not trivial because it has type -Int#, and we don't want to evaluate it too early. But we can instead -float a boxed version - y = case f x of r -> I# r -and replace the original (f x) with - case (case y of I# r -> r) of r -> blah - -Being able to float unboxed expressions is sometimes important; see -#12603. I'm not sure how /often/ it is important, but it's -not hard to achieve. - -We only do it for a fixed collection of types for which we have a -convenient boxing constructor (see boxingDataCon_maybe). In -particular we /don't/ do it for unboxed tuples; it's better to float -the components of the tuple individually. - -I did experiment with a form of boxing that works for any type, namely -wrapping in a function. In our example - - let y = case f x of r -> \v. f x - in case y void of r -> blah - -It works fine, but it's 50% slower (based on some crude benchmarking). -I suppose we could do it for types not covered by boxingDataCon_maybe, -but it's more code and I'll wait to see if anyone wants it. - -Note [Test cheapness with exprOkForSpeculation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to float very cheap expressions by boxing and unboxing. -But we use exprOkForSpeculation for the test, not exprIsCheap. -Why? Because it's important /not/ to transform - f (a /# 3) -to - f (case bx of I# a -> a /# 3) -and float bx = I# (a /# 3), because the application of f no -longer obeys the let/app invariant. But (a /# 3) is ok-for-spec -due to a special hack that says division operators can't fail -when the denominator is definitely non-zero. And yet that -same expression says False to exprIsCheap. Simplest way to -guarantee the let/app invariant is to use the same function! - -If an expression is okay for speculation, we could also float it out -*without* boxing and unboxing, since evaluating it early is okay. -However, it turned out to usually be better not to float such expressions, -since they tend to be extremely cheap things like (x +# 1#). Even the -cost of spilling the let-bound variable to the stack across a call may -exceed the cost of recomputing such an expression. (And we can't float -unlifted bindings to top-level.) - -We could try to do something smarter here, and float out expensive yet -okay-for-speculation things, such as division by non-zero constants. -But I suspect it's a narrow target. - -Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~ -If we see - f = \x. g (error "urk") -we'd like to float the call to error, to get - lvl = error "urk" - f = \x. g lvl - -But, as ever, we need to be careful: - -(1) We want to float a bottoming - expression even if it has free variables: - f = \x. g (let v = h x in error ("urk" ++ v)) - Then we'd like to abstract over 'x' can float the whole arg of g: - lvl = \x. let v = h x in error ("urk" ++ v) - f = \x. g (lvl x) - To achieve this we pass is_bot to destLevel - -(2) We do not do this for lambdas that return - bottom. Instead we treat the /body/ of such a function specially, - via point (1). For example: - f = \x. ....(\y z. if x then error y else error z).... - ===> - lvl = \x z y. if b then error y else error z - f = \x. ...(\y z. lvl x z y)... - (There is no guarantee that we'll choose the perfect argument order.) - -(3) If we have a /binding/ that returns bottom, we want to float it to top - level, even if it has free vars (point (1)), and even it has lambdas. - Example: - ... let { v = \y. error (show x ++ show y) } in ... - We want to abstract over x and float the whole thing to top: - lvl = \xy. errror (show x ++ show y) - ...let {v = lvl x} in ... - - Then of course we don't want to separately float the body (error ...) - as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot - argument. - -See Maessen's paper 1999 "Bottom extraction: factoring error handling out -of functional programs" (unpublished I think). - -When we do this, we set the strictness and arity of the new bottoming -Id, *immediately*, for three reasons: - - * To prevent the abstracted thing being immediately inlined back in again - via preInlineUnconditionally. The latter has a test for bottoming Ids - to stop inlining them, so we'd better make sure it *is* a bottoming Id! - - * So that it's properly exposed as such in the interface file, even if - this is all happening after strictness analysis. - - * In case we do CSE with the same expression that *is* marked bottom - lvl = error "urk" - x{str=bot) = error "urk" - Here we don't want to replace 'x' with 'lvl', else we may get Lint - errors, e.g. via a case with empty alternatives: (case x of {}) - Lint complains unless the scrutinee of such a case is clearly bottom. - - This was reported in #11290. But since the whole bottoming-float - thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure - that it'll nail all such cases. - -Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tiresomely, though, the simplifier has an invariant that the manifest -arity of the RHS should be the same as the arity; but we can't call -etaExpand during SetLevels because it works over a decorated form of -CoreExpr. So we do the eta expansion later, in FloatOut. - -Note [Case MFEs] -~~~~~~~~~~~~~~~~ -We don't float a case expression as an MFE from a strict context. Why not? -Because in doing so we share a tiny bit of computation (the switch) but -in exchange we build a thunk, which is bad. This case reduces allocation -by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. -Doesn't change any other allocation at all. - -We will make a separate decision for the scrutinee and alternatives. - -However this can have a knock-on effect for fusion: consider - \v -> foldr k z (case x of I# y -> build ..y..) -Perhaps we can float the entire (case x of ...) out of the \v. Then -fusion will not happen, but we will get more sharing. But if we don't -float the case (as advocated here) we won't float the (build ...y..) -either, so fusion will happen. It can be a big effect, esp in some -artificial benchmarks (e.g. integer, queens), but there is no perfect -answer. - --} - -annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id --- See Note [Bottoming floats] for why we want to add --- bottoming information right now --- --- n_extra are the number of extra value arguments added during floating -annotateBotStr id n_extra mb_str - = case mb_str of - Nothing -> id - Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdStrictness` (increaseStrictSigArity n_extra sig) - -notWorthFloating :: CoreExpr -> [Var] -> Bool --- Returns True if the expression would be replaced by --- something bigger than it is now. For example: --- abs_vars = tvars only: return True if e is trivial, --- but False for anything bigger --- abs_vars = [x] (an Id): return True for trivial, or an application (f x) --- but False for (f x x) --- --- One big goal is that floating should be idempotent. Eg if --- we replace e with (lvl79 x y) and then run FloatOut again, don't want --- to replace (lvl79 x y) with (lvl83 x y)! - -notWorthFloating e abs_vars - = go e (count isId abs_vars) - where - go (Var {}) n = n >= 0 - go (Lit lit) n = ASSERT( n==0 ) - litIsTrivial lit -- Note [Floating literals] - go (Tick t e) n = not (tickishIsCode t) && go e n - go (Cast e _) n = go e n - go (App e arg) n - -- See Note [Floating applications to coercions] - | Type {} <- arg = go e n - | n==0 = False - | is_triv arg = go e (n-1) - | otherwise = False - go _ _ = False - - is_triv (Lit {}) = True -- Treat all literals as trivial - is_triv (Var {}) = True -- (ie not worth floating) - is_triv (Cast e _) = is_triv e - is_triv (App e (Type {})) = is_triv e -- See Note [Floating applications to coercions] - is_triv (Tick t e) = not (tickishIsCode t) && is_triv e - is_triv _ = False - -{- -Note [Floating literals] -~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to float Integer literals, so that they get shared, -rather than being allocated every time round the loop. -Hence the litIsTrivial. - -Ditto literal strings (LitString), which we'd like to float to top -level, which is now possible. - -Note [Floating applications to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don’t float out variables applied only to type arguments, since the -extra binding would be pointless: type arguments are completely erased. -But *coercion* arguments aren’t (see Note [Coercion tokens] in -CoreToStg.hs and Note [Count coercion arguments in boring contexts] in -CoreUnfold.hs), so we still want to float out variables applied only to -coercion arguments. - -Note [Escaping a value lambda] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to float even cheap expressions out of value lambdas, -because that saves allocation. Consider - f = \x. .. (\y.e) ... -Then we'd like to avoid allocating the (\y.e) every time we call f, -(assuming e does not mention x). An example where this really makes a -difference is simplrun009. - -Another reason it's good is because it makes SpecContr fire on functions. -Consider - f = \x. ....(f (\y.e)).... -After floating we get - lvl = \y.e - f = \x. ....(f lvl)... -and that is much easier for SpecConstr to generate a robust -specialisation for. - -However, if we are wrapping the thing in extra value lambdas (in -abs_vars), then nothing is saved. E.g. - f = \xyz. ...(e1[y],e2).... -If we float - lvl = \y. (e1[y],e2) - f = \xyz. ...(lvl y)... -we have saved nothing: one pair will still be allocated for each -call of 'f'. Hence the (not float_is_lam) in float_me. - - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ - -The binding stuff works for top level too. --} - -lvlBind :: LevelEnv - -> CoreBindWithFVs - -> LvlM (LevelledBind, LevelEnv) - -lvlBind env (AnnNonRec bndr rhs) - | isTyVar bndr -- Don't do anything for TyVar binders - -- (simplifier gets rid of them pronto) - || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) - -- so we will ignore this case for now - || not (profitableFloat env dest_lvl) - || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty)) - -- We can't float an unlifted binding to top level (except - -- literal strings), so we don't float it at all. It's a - -- bit brutal, but unlifted bindings aren't expensive either - - = -- No float - do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs - ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) - (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] - ; return (NonRec bndr' rhs', env') } - - -- Otherwise we are going to float - | null abs_vars - = do { -- No type abstraction; clone existing binder - rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive - is_bot mb_join_arity rhs - ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] - ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } - - | otherwise - = do { -- Yes, type abstraction; create a new binder, extend substitution, etc - rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive - is_bot mb_join_arity rhs - ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] - ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str - ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } - - where - bndr_ty = idType bndr - ty_fvs = tyCoVarsOfType bndr_ty - rhs_fvs = freeVarsOf rhs - bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr - abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join - - deann_rhs = deAnnotate rhs - mb_bot_str = exprBotStrictness_maybe deann_rhs - is_bot = isJust mb_bot_str - -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) - - n_extra = count isId abs_vars - mb_join_arity = isJoinId_maybe bndr - is_join = isJust mb_join_arity - -lvlBind env (AnnRec pairs) - | floatTopLvlOnly env && not (isTopLvl dest_lvl) - -- Only floating to the top level is allowed. - || not (profitableFloat env dest_lvl) - || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs) - -- This mightBeUnliftedType stuff is the same test as in the non-rec case - -- You might wonder whether we can have a recursive binding for - -- an unlifted value -- but we can if it's a /join binding/ (#16978) - -- (Ultimately I think we should not use SetLevels to - -- float join bindings at all, but that's another story.) - = -- No float - do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) - (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs - lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r - ; rhss' <- mapM lvl_rhs pairs - ; return (Rec (bndrs' `zip` rhss'), env') } - - -- Otherwise we are going to float - | null abs_vars - = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs - ; new_rhss <- mapM (do_rhs new_env) pairs - ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) - , new_env) } - --- ToDo: when enabling the floatLambda stuff, --- I think we want to stop doing this - | [(bndr,rhs)] <- pairs - , count isId abs_vars > 1 - = do -- Special case for self recursion where there are - -- several variables carried around: build a local loop: - -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars - -- This just makes the closures a bit smaller. If we don't do - -- this, allocation rises significantly on some programs - -- - -- We could elaborate it for the case where there are several - -- mutually recursive functions, but it's quite a bit more complicated - -- - -- This all seems a bit ad hoc -- sigh - let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars - rhs_lvl = le_ctxt_lvl rhs_env - - (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] - let - (lam_bndrs, rhs_body) = collectAnnBndrs rhs - (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs - (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 - new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body - (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] - return (Rec [(TB poly_bndr (FloatMe dest_lvl) - , mkLams abs_vars_w_lvls $ - mkLams lam_bndrs2 $ - Let (Rec [( TB new_bndr (StayPut rhs_lvl) - , mkLams lam_bndrs2 new_rhs_body)]) - (mkVarApps (Var new_bndr) lam_bndrs1))] - , poly_env) - - | otherwise -- Non-null abs_vars - = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs - ; new_rhss <- mapM (do_rhs new_env) pairs - ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) - , new_env) } - - where - (bndrs,rhss) = unzip pairs - is_join = isJoinId (head bndrs) - -- bndrs is always non-empty and if one is a join they all are - -- Both are checked by Lint - is_fun = all isFunction rhss - is_bot = False -- It's odd to have an unconditionally divergent - -- function in a Rec, and we don't much care what - -- happens to it. False is simple! - - do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive - is_bot (get_join bndr) - rhs - - get_join bndr | need_zap = Nothing - | otherwise = isJoinId_maybe bndr - need_zap = dest_lvl `ltLvl` joinCeilingLevel env - - -- Finding the free vars of the binding group is annoying - bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) - `unionDVarSet` - (fvDVarSet $ unionsFV [ idFVs bndr - | (bndr, (_,_)) <- pairs])) - `delDVarSetList` - bndrs - - ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs - dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join - abs_vars = abstractVars dest_lvl env bind_fvs - -profitableFloat :: LevelEnv -> Level -> Bool -profitableFloat env dest_lvl - = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda - || isTopLvl dest_lvl -- Going all the way to top level - - ----------------------------------------------------- --- Three help functions for the type-abstraction case - -lvlRhs :: LevelEnv - -> RecFlag - -> Bool -- Is this a bottoming function - -> Maybe JoinArity - -> CoreExprWithFVs - -> LvlM LevelledExpr -lvlRhs env rec_flag is_bot mb_join_arity expr - = lvlFloatRhs [] (le_ctxt_lvl env) env - rec_flag is_bot mb_join_arity expr - -lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag - -> Bool -- Binding is for a bottoming function - -> Maybe JoinArity - -> CoreExprWithFVs - -> LvlM (Expr LevelledBndr) --- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline -lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs - = do { body' <- if not is_bot -- See Note [Floating from a RHS] - && any isId bndrs - then lvlMFE body_env True body - else lvlExpr body_env body - ; return (mkLams bndrs' body') } - where - (bndrs, body) | Just join_arity <- mb_join_arity - = collectNAnnBndrs join_arity rhs - | otherwise - = collectAnnBndrs rhs - (env1, bndrs1) = substBndrsSL NonRecursive env bndrs - all_bndrs = abs_vars ++ bndrs1 - (body_env, bndrs') | Just _ <- mb_join_arity - = lvlJoinBndrs env1 dest_lvl rec all_bndrs - | otherwise - = case lvlLamBndrs env1 dest_lvl all_bndrs of - (env2, bndrs') -> (placeJoinCeiling env2, bndrs') - -- The important thing here is that we call lvlLamBndrs on - -- all these binders at once (abs_vars and bndrs), so they - -- all get the same major level. Otherwise we create stupid - -- let-bindings inside, joyfully thinking they can float; but - -- in the end they don't because we never float bindings in - -- between lambdas - -{- Note [Floating from a RHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When floating the RHS of a let-binding, we don't always want to apply -lvlMFE to the body of a lambda, as we usually do, because the entire -binding body is already going to the right place (dest_lvl). - -A particular example is the top level. Consider - concat = /\ a -> foldr ..a.. (++) [] -We don't want to float the body of the lambda to get - lvl = /\ a -> foldr ..a.. (++) [] - concat = /\ a -> lvl a -That would be stupid. - -Previously this was avoided in a much nastier way, by testing strict_ctxt -in float_me in lvlMFE. But that wasn't even right because it would fail -to float out the error sub-expression in - f = \x. case x of - True -> error ("blah" ++ show x) - False -> ... - -But we must be careful: - -* If we had - f = \x -> factorial 20 - we /would/ want to float that (factorial 20) out! Functions are treated - differently: see the use of isFunction in the calls to destLevel. If - there are only type lambdas, then destLevel will say "go to top, and - abstract over the free tyvars" and we don't want that here. - -* But if we had - f = \x -> error (...x....) - we would NOT want to float the bottoming expression out to give - lvl = \x -> error (...x...) - f = \x -> lvl x - -Conclusion: use lvlMFE if there are - * any value lambdas in the original function, and - * this is not a bottoming function (the is_bot argument) -Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice -(e.g. #13369). --} - -{- -************************************************************************ -* * -\subsection{Deciding floatability} -* * -************************************************************************ --} - -substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) -substAndLvlBndrs is_rec env lvl bndrs - = lvlBndrs subst_env lvl subst_bndrs - where - (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs - -substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) --- So named only to avoid the name clash with CoreSubst.substBndrs -substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs - = ( env { le_subst = subst' - , le_env = foldl' add_id id_env (bndrs `zip` bndrs') } - , bndrs') - where - (subst', bndrs') = case is_rec of - NonRecursive -> substBndrs subst bndrs - Recursive -> substRecBndrs subst bndrs - -lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) --- Compute the levels for the binders of a lambda group -lvlLamBndrs env lvl bndrs - = lvlBndrs env new_lvl bndrs - where - new_lvl | any is_major bndrs = incMajorLvl lvl - | otherwise = incMinorLvl lvl - - is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) - -- The "probably" part says "don't float things out of a - -- probable one-shot lambda" - -- See Note [Computing one-shot info] in Demand.hs - -lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] - -> (LevelEnv, [LevelledBndr]) -lvlJoinBndrs env lvl rec bndrs - = lvlBndrs env new_lvl bndrs - where - new_lvl | isRec rec = incMajorLvl lvl - | otherwise = incMinorLvl lvl - -- Non-recursive join points are one-shot; recursive ones are not - -lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) --- The binders returned are exactly the same as the ones passed, --- apart from applying the substitution, but they are now paired --- with a (StayPut level) --- --- The returned envt has le_ctxt_lvl updated to the new_lvl --- --- All the new binders get the same level, because --- any floating binding is either going to float past --- all or none. We never separate binders. -lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs - = ( env { le_ctxt_lvl = new_lvl - , le_join_ceil = new_lvl - , le_lvl_env = addLvls new_lvl lvl_env bndrs } - , map (stayPut new_lvl) bndrs) - -stayPut :: Level -> OutVar -> LevelledBndr -stayPut new_lvl bndr = TB bndr (StayPut new_lvl) - - -- Destination level is the max Id level of the expression - -- (We'll abstract the type variables, if any.) -destLevel :: LevelEnv - -> DVarSet -- Free vars of the term - -> TyCoVarSet -- Free in the /type/ of the term - -- (a subset of the previous argument) - -> Bool -- True <=> is function - -> Bool -- True <=> is bottom - -> Bool -- True <=> is a join point - -> Level --- INVARIANT: if is_join=True then result >= join_ceiling -destLevel env fvs fvs_ty is_function is_bot is_join - | isTopLvl max_fv_id_level -- Float even joins if they get to top level - -- See Note [Floating join point bindings] - = tOP_LEVEL - - | is_join -- Never float a join point past the join ceiling - -- See Note [Join points] in FloatOut - = if max_fv_id_level `ltLvl` join_ceiling - then join_ceiling - else max_fv_id_level - - | is_bot -- Send bottoming bindings to the top - = as_far_as_poss -- regardless; see Note [Bottoming floats] - -- Esp Bottoming floats (1) - - | Just n_args <- floatLams env - , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case - , is_function - , countFreeIds fvs <= n_args - = as_far_as_poss -- Send functions to top level; see - -- the comments with isFunction - - | otherwise = max_fv_id_level - where - join_ceiling = joinCeilingLevel env - max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the - -- tyvars will be abstracted - - as_far_as_poss = maxFvLevel' isId env fvs_ty - -- See Note [Floating and kind casts] - -{- Note [Floating and kind casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - case x of - K (co :: * ~# k) -> let v :: Int |> co - v = e - in blah - -Then, even if we are abstracting over Ids, or if e is bottom, we can't -float v outside the 'co' binding. Reason: if we did we'd get - v' :: forall k. (Int ~# Age) => Int |> co -and now 'co' isn't in scope in that type. The underlying reason is -that 'co' is a value-level thing and we can't abstract over that in a -type (else we'd get a dependent type). So if v's /type/ mentions 'co' -we can't float it out beyond the binding site of 'co'. - -That's why we have this as_far_as_poss stuff. Usually as_far_as_poss -is just tOP_LEVEL; but occasionally a coercion variable (which is an -Id) mentioned in type prevents this. - -Example #14270 comment:15. --} - - -isFunction :: CoreExprWithFVs -> Bool --- The idea here is that we want to float *functions* to --- the top level. This saves no work, but --- (a) it can make the host function body a lot smaller, --- and hence inlinable. --- (b) it can also save allocation when the function is recursive: --- h = \x -> letrec f = \y -> ...f...y...x... --- in f x --- becomes --- f = \x y -> ...(f x)...y...x... --- h = \x -> f x x --- No allocation for f now. --- We may only want to do this if there are sufficiently few free --- variables. We certainly only want to do it for values, and not for --- constructors. So the simple thing is just to look for lambdas -isFunction (_, AnnLam b e) | isId b = True - | otherwise = isFunction e --- isFunction (_, AnnTick _ e) = isFunction e -- dubious -isFunction _ = False - -countFreeIds :: DVarSet -> Int -countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet - -- It's OK to use nonDetFoldUDFM here because we're just counting things. - where - add :: Var -> Int -> Int - add v n | isId v = n+1 - | otherwise = n - -{- -************************************************************************ -* * -\subsection{Free-To-Level Monad} -* * -************************************************************************ --} - -data LevelEnv - = LE { le_switches :: FloatOutSwitches - , le_ctxt_lvl :: Level -- The current level - , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids - , le_join_ceil:: Level -- Highest level to which joins float - -- Invariant: always >= le_ctxt_lvl - - -- See Note [le_subst and le_env] - , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids - -- The Id -> CoreExpr in the Subst is ignored - -- (since we want to substitute a LevelledExpr for - -- an Id via le_env) but we do use the Co/TyVar substs - , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids - } - -{- Note [le_subst and le_env] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We clone let- and case-bound variables so that they are still distinct -when floated out; hence the le_subst/le_env. (see point 3 of the -module overview comment). We also use these envs when making a -variable polymorphic because we want to float it out past a big -lambda. - -The le_subst and le_env always implement the same mapping, - in_x :-> out_x a b -where out_x is an OutVar, and a,b are its arguments (when -we perform abstraction at the same time as floating). - - le_subst maps to CoreExpr - le_env maps to LevelledExpr - -Since the range is always a variable or application, there is never -any difference between the two, but sadly the types differ. The -le_subst is used when substituting in a variable's IdInfo; the le_env -when we find a Var. - -In addition the le_env records a [OutVar] of variables free in the -OutExpr/LevelledExpr, just so we don't have to call freeVars -repeatedly. This list is always non-empty, and the first element is -out_x - -The domain of the both envs is *pre-cloned* Ids, though - -The domain of the le_lvl_env is the *post-cloned* Ids --} - -initialEnv :: FloatOutSwitches -> LevelEnv -initialEnv float_lams - = LE { le_switches = float_lams - , le_ctxt_lvl = tOP_LEVEL - , le_join_ceil = panic "initialEnv" - , le_lvl_env = emptyVarEnv - , le_subst = emptySubst - , le_env = emptyVarEnv } - -addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level -addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl - -addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level -addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs - -floatLams :: LevelEnv -> Maybe Int -floatLams le = floatOutLambdas (le_switches le) - -floatConsts :: LevelEnv -> Bool -floatConsts le = floatOutConstants (le_switches le) - -floatOverSat :: LevelEnv -> Bool -floatOverSat le = floatOutOverSatApps (le_switches le) - -floatTopLvlOnly :: LevelEnv -> Bool -floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) - -incMinorLvlFrom :: LevelEnv -> Level -incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env) - --- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can --- See Note [Binder-swap during float-out] -extendCaseBndrEnv :: LevelEnv - -> Id -- Pre-cloned case binder - -> Expr LevelledBndr -- Post-cloned scrutinee - -> LevelEnv -extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) - case_bndr (Var scrut_var) - = le { le_subst = extendSubstWithVar subst case_bndr scrut_var - , le_env = add_id id_env (case_bndr, scrut_var) } -extendCaseBndrEnv env _ _ = env - --- See Note [Join ceiling] -placeJoinCeiling :: LevelEnv -> LevelEnv -placeJoinCeiling le@(LE { le_ctxt_lvl = lvl }) - = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' } - where - lvl' = asJoinCeilLvl (incMinorLvl lvl) - -maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level -maxFvLevel max_me env var_set - = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set - -maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level --- Same but for TyCoVarSet -maxFvLevel' max_me env var_set - = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set - -maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level -maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl - = case lookupVarEnv id_env in_var of - Just (abs_vars, _) -> foldr max_out lvl abs_vars - Nothing -> max_out in_var lvl - where - max_out out_var lvl - | max_me out_var = case lookupVarEnv lvl_env out_var of - Just lvl' -> maxLvl lvl' lvl - Nothing -> lvl - | otherwise = lvl -- Ignore some vars depending on max_me - -lookupVar :: LevelEnv -> Id -> LevelledExpr -lookupVar le v = case lookupVarEnv (le_env le) v of - Just (_, expr) -> expr - _ -> Var v - --- Level to which join points are allowed to float (boundary of current tail --- context). See Note [Join ceiling] -joinCeilingLevel :: LevelEnv -> Level -joinCeilingLevel = le_join_ceil - -abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] - -- Find the variables in fvs, free vars of the target expression, - -- whose level is greater than the destination level - -- These are the ones we are going to abstract out - -- - -- Note that to get reproducible builds, the variables need to be - -- abstracted in deterministic order, not dependent on the values of - -- Uniques. This is achieved by using DVarSets, deterministic free - -- variable computation and deterministic sort. - -- See Note [Unique Determinism] in Unique for explanation of why - -- Uniques are not deterministic. -abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs - = -- NB: sortQuantVars might not put duplicates next to each other - map zap $ sortQuantVars $ - filter abstract_me $ - dVarSetElems $ - closeOverKindsDSet $ - substDVarSet subst in_fvs - -- NB: it's important to call abstract_me only on the OutIds the - -- come from substDVarSet (not on fv, which is an InId) - where - abstract_me v = case lookupVarEnv lvl_env v of - Just lvl -> dest_lvl `ltLvl` lvl - Nothing -> False - - -- We are going to lambda-abstract, so nuke any IdInfo, - -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || - not (isEmptyRuleInfo (idSpecialisation v)), - text "absVarsOf: discarding info on" <+> ppr v ) - setIdInfo v vanillaIdInfo - | otherwise = v - -type LvlM result = UniqSM result - -initLvl :: UniqSupply -> UniqSM a -> a -initLvl = initUs_ - -newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] - -> LvlM (LevelEnv, [OutId]) --- The envt is extended to bind the new bndrs to dest_lvl, but --- the le_ctxt_lvl is unaffected -newPolyBndrs dest_lvl - env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) - abs_vars bndrs - = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer. - do { uniqs <- getUniquesM - ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs - bndr_prs = bndrs `zip` new_bndrs - env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs - , le_subst = foldl' add_subst subst bndr_prs - , le_env = foldl' add_id id_env bndr_prs } - ; return (env', new_bndrs) } - where - add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) - add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) - - mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.hs - transfer_join_info bndr $ - mkSysLocalOrCoVar (mkFastString str) uniq poly_ty - where - str = "poly_" ++ occNameString (getOccName bndr) - poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr)) - - -- If we are floating a join point to top level, it stops being - -- a join point. Otherwise it continues to be a join point, - -- but we may need to adjust its arity - dest_is_top = isTopLvl dest_lvl - transfer_join_info bndr new_bndr - | Just join_arity <- isJoinId_maybe bndr - , not dest_is_top - = new_bndr `asJoinId` join_arity + length abs_vars - | otherwise - = new_bndr - -newLvlVar :: LevelledExpr -- The RHS of the new binding - -> Maybe JoinArity -- Its join arity, if it is a join point - -> Bool -- True <=> the RHS looks like (makeStatic ...) - -> LvlM Id -newLvlVar lvld_rhs join_arity_maybe is_mk_static - = do { uniq <- getUniqueM - ; return (add_join_info (mk_id uniq rhs_ty)) - } - where - add_join_info var = var `asJoinId_maybe` join_arity_maybe - de_tagged_rhs = deTagExpr lvld_rhs - rhs_ty = exprType de_tagged_rhs - - mk_id uniq rhs_ty - -- See Note [Grand plan for static forms] in StaticPtrTable. - | is_mk_static - = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) - rhs_ty - | otherwise - = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty - --- | Clone the binders bound by a single-alternative case. -cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) -cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) - new_lvl vs - = do { us <- getUniqueSupplyM - ; let (subst', vs') = cloneBndrs subst us vs - -- N.B. We are not moving the body of the case, merely its case - -- binders. Consequently we should *not* set le_ctxt_lvl and - -- le_join_ceil. See Note [Setting levels when floating - -- single-alternative cases]. - env' = env { le_lvl_env = addLvls new_lvl lvl_env vs' - , le_subst = subst' - , le_env = foldl' add_id id_env (vs `zip` vs') } - - ; return (env', vs') } - -cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] - -> LvlM (LevelEnv, [OutVar]) --- See Note [Need for cloning during float-out] --- Works for Ids bound by let(rec) --- The dest_lvl is attributed to the binders in the new env, --- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env -cloneLetVars is_rec - env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) - dest_lvl vs - = do { us <- getUniqueSupplyM - ; let vs1 = map zap vs - -- See Note [Zapping the demand info] - (subst', vs2) = case is_rec of - NonRecursive -> cloneBndrs subst us vs1 - Recursive -> cloneRecIdBndrs subst us vs1 - prs = vs `zip` vs2 - env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 - , le_subst = subst' - , le_env = foldl' add_id id_env prs } - - ; return (env', vs2) } - where - zap :: Var -> Var - zap v | isId v = zap_join (zapIdDemandInfo v) - | otherwise = v - - zap_join | isTopLvl dest_lvl = zapJoinId - | otherwise = id - -add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) -add_id id_env (v, v1) - | isTyVar v = delVarEnv id_env v - | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1) - -{- -Note [Zapping the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -VERY IMPORTANT: we must zap the demand info if the thing is going to -float out, because it may be less demanded than at its original -binding site. Eg - f :: Int -> Int - f x = let v = 3*4 in v+x -Here v is strict; but if we float v to top level, it isn't any more. - -Similarly, if we're floating a join point, it won't be one anymore, so we zap -join point information as well. --} diff --git a/simplCore/SimplCore.hs b/simplCore/SimplCore.hs deleted file mode 100644 --- a/simplCore/SimplCore.hs +++ /dev/null @@ -1,1024 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[SimplCore]{Driver for simplifying @Core@ programs} --} - -{-# LANGUAGE CPP #-} - -module SimplCore ( core2core, simplifyExpr ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import CoreSyn -import HscTypes -import CSE ( cseProgram ) -import Rules ( mkRuleBase, unionRuleBase, - extendRuleBaseList, ruleCheckProgram, addRuleInfo, - getRules ) -import PprCore ( pprCoreBindings, pprCoreExpr ) -import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import IdInfo -import CoreStats ( coreBindsSize, coreBindsStats, exprSize ) -import CoreUtils ( mkTicks, stripTicksTop ) -import CoreLint ( endPass, lintPassResult, dumpPassResult, - lintAnnots ) -import Simplify ( simplTopBinds, simplExpr, simplRules ) -import SimplUtils ( simplEnvForGHCi, activeRule, activeUnfolding ) -import SimplEnv -import SimplMonad -import CoreMonad -import qualified ErrUtils as Err -import FloatIn ( floatInwards ) -import FloatOut ( floatOutwards ) -import FamInstEnv -import Id -import ErrUtils ( withTiming, withTimingD ) -import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) -import VarSet -import VarEnv -import LiberateCase ( liberateCase ) -import SAT ( doStaticArgs ) -import Specialise ( specProgram) -import SpecConstr ( specConstrProgram) -import DmdAnal ( dmdAnalProgram ) -import CallArity ( callArityAnalProgram ) -import Exitify ( exitifyProgram ) -import WorkWrap ( wwTopBinds ) -import SrcLoc -import Util -import Module -import Plugins ( withPlugins, installCoreToDos ) -import DynamicLoading -- ( initializePlugins ) - -import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) -import UniqFM -import Outputable -import Control.Monad -import qualified GHC.LanguageExtensions as LangExt -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -core2core :: HscEnv -> ModGuts -> IO ModGuts -core2core hsc_env guts@(ModGuts { mg_module = mod - , mg_loc = loc - , mg_deps = deps - , mg_rdr_env = rdr_env }) - = do { -- make sure all plugins are loaded - - ; let builtin_passes = getCoreToDo dflags - orph_mods = mkModuleSet (mod : dep_orphs deps) - uniq_mask = 's' - ; - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod - orph_mods print_unqual loc $ - do { hsc_env' <- getHscEnv - ; dflags' <- liftIO $ initializePlugins hsc_env' - (hsc_dflags hsc_env') - ; all_passes <- withPlugins dflags' - installCoreToDos - builtin_passes - ; runCorePasses all_passes guts } - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats - "Grand total simplifier statistics" - (pprSimplCount stats) - - ; return guts2 } - where - dflags = hsc_dflags hsc_env - home_pkg_rules = hptRules hsc_env (dep_mods deps) - hpt_rule_base = mkRuleBase home_pkg_rules - print_unqual = mkPrintUnqualified dflags rdr_env - -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. - -- This is very convienent for the users of the monad (e.g. plugins do not have to - -- consume the ModGuts to find the module) but somewhat ugly because mg_module may - -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which - -- would mean our cached value would go out of date. - -{- -************************************************************************ -* * - Generating the main optimisation pipeline -* * -************************************************************************ --} - -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags - = flatten_todos core_todo - where - opt_level = optLevel dflags - phases = simplPhases dflags - max_iter = maxSimplIterations dflags - rule_check = ruleCheck dflags - call_arity = gopt Opt_CallArity dflags - exitification = gopt Opt_Exitification dflags - strictness = gopt Opt_Strictness dflags - full_laziness = gopt Opt_FullLaziness dflags - do_specialise = gopt Opt_Specialise dflags - do_float_in = gopt Opt_FloatIn dflags - cse = gopt Opt_CSE dflags - spec_constr = gopt Opt_SpecConstr dflags - liberate_case = gopt Opt_LiberateCase dflags - late_dmd_anal = gopt Opt_LateDmdAnal dflags - late_specialise = gopt Opt_LateSpecialise dflags - static_args = gopt Opt_StaticArgumentTransformation dflags - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - ww_on = gopt Opt_WorkerWrapper dflags - static_ptrs = xopt LangExt.StaticPointers dflags - - maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - - maybe_strictness_before phase - = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness - - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_dflags = dflags - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_inline = True - , sm_case_case = True } - - simpl_phase phase names iter - = CoreDoPasses - $ [ maybe_strictness_before phase - , CoreDoSimplify iter - (base_mode { sm_phase = Phase phase - , sm_names = names }) - - , maybe_rule_check (Phase phase) ] - - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter - | phase <- [phases, phases-1 .. 1] ] - - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify max_iter - (base_mode { sm_phase = InitialPhase - , sm_names = ["Gentle"] - , sm_rules = rules_on -- Note [RULEs enabled in SimplGently] - , sm_inline = True - -- See Note [Inline in InitialPhase] - , sm_case_case = False }) - -- Don't do case-of-case transformations. - -- This makes full laziness work better - - strictness_pass = if ww_on - then [CoreDoStrictness,CoreDoWorkerWrapper] - else [CoreDoStrictness] - - - -- New demand analyser - demand_analyser = (CoreDoPasses ( - strictness_pass ++ - [simpl_phase 0 ["post-worker-wrapper"] max_iter] - )) - - -- Static forms are moved to the top level with the FloatOut pass. - -- See Note [Grand plan for static forms] in StaticPtrTable. - static_ptrs_float_outwards = - runWhen static_ptrs $ CoreDoPasses - [ simpl_gently -- Float Out can't handle type lets (sometimes created - -- by simpleOptPgm via mkParallelBindings) - , CoreDoFloatOutwards FloatOutSwitches - { floatOutLambdas = Just 0 - , floatOutConstants = True - , floatOutOverSatApps = False - , floatToTopLevelOnly = True - } - ] - - core_todo = - if opt_level == 0 then - [ static_ptrs_float_outwards, - CoreDoSimplify max_iter - (base_mode { sm_phase = Phase 0 - , sm_names = ["Non-opt simplification"] }) - ] - - else {- opt_level >= 1 -} [ - - -- We want to do the static argument transform before full laziness as it - -- may expose extra opportunities to float things outwards. However, to fix - -- up the output of the transformation we need at do at least one simplify - -- after this before anything else - runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently, - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - runWhen do_specialise CoreDoSpecialising, - - if full_laziness then - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = Just 0, - floatOutConstants = True, - floatOutOverSatApps = False, - floatToTopLevelOnly = False } - -- Was: gentleFloatOutSwitches - -- - -- I have no idea why, but not floating constants to - -- top level is very bad in some cases. - -- - -- Notably: p_ident in spectral/rewrite - -- Changing from "gentle" to "constantsOnly" - -- improved rewrite's allocation by 19%, and - -- made 0.0% difference to any other nofib - -- benchmark - -- - -- Not doing floatOutOverSatApps yet, we'll do - -- that later on when we've had a chance to get more - -- accurate arity information. In fact it makes no - -- difference at all to performance if we do it here, - -- but maybe we save some unnecessary to-and-fro in - -- the simplifier. - else - -- Even with full laziness turned off, we still need to float static - -- forms to the top level. See Note [Grand plan for static forms] in - -- StaticPtrTable. - static_ptrs_float_outwards, - - simpl_phases, - - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simplifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), - - runWhen do_float_in CoreDoFloatInwards, - -- Run float-inwards immediately before the strictness analyser - -- Doing so pushes bindings nearer their use site and hence makes - -- them more likely to be strict. These bindings might only show - -- up after the inlining from simplification. Example in fulsom, - -- Csg.calc, where an arg of timesDouble thereby becomes strict. - - runWhen call_arity $ CoreDoPasses - [ CoreDoCallArity - , simpl_phase 0 ["post-call-arity"] max_iter - ], - - runWhen strictness demand_analyser, - - runWhen exitification CoreDoExitify, - -- See note [Placement of the exitification pass] - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = floatLamArgs dflags, - floatOutConstants = True, - floatOutOverSatApps = True, - floatToTopLevelOnly = False }, - -- 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) - - - runWhen cse CoreCSE, - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - runWhen do_float_in CoreDoFloatInwards, - - maybe_rule_check (Phase 0), - - -- Case-liberation for -O2. This should be after - -- strictness analysis and the simplification which follows it. - runWhen liberate_case (CoreDoPasses [ - CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter - ]), -- Run the simplifier after LiberateCase to vastly - -- reduce the possibility of shadowing - -- Reason: see Note [Shadowing] in SpecConstr.hs - - runWhen spec_constr CoreDoSpecConstr, - - maybe_rule_check (Phase 0), - - runWhen late_specialise - (CoreDoPasses [ CoreDoSpecialising - , simpl_phase 0 ["post-late-spec"] max_iter]), - - -- LiberateCase can yield new CSE opportunities because it peels - -- off one layer of a recursive function (concretely, I saw this - -- in wheel-sieve1), and I'm guessing that SpecConstr can too - -- And CSE is a very cheap pass. So it seems worth doing here. - runWhen ((liberate_case || spec_constr) && cse) CoreCSE, - - -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter, - - runWhen late_dmd_anal $ CoreDoPasses ( - strictness_pass ++ - [simpl_phase 0 ["post-late-ww"] max_iter] - ), - - -- Final run of the demand_analyser, ensures that one-shot thunks are - -- really really one-shot thunks. Only needed if the demand analyser - -- has run at all. See Note [Final Demand Analyser run] in DmdAnal - -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution - -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) CoreDoStrictness, - - maybe_rule_check (Phase 0) - ] - - -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity. - flatten_todos [] = [] - flatten_todos (CoreDoNothing : rest) = flatten_todos rest - flatten_todos (CoreDoPasses passes : rest) = - flatten_todos passes ++ flatten_todos rest - flatten_todos (todo : rest) = todo : flatten_todos rest - -{- Note [Inline in InitialPhase] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is -confusing for users because when they say INLINE they expect the function to inline -right away. - -So now we do inlining immediately, even in the InitialPhase, assuming that the -Id's Activation allows it. - -This is a surprisingly big deal. Compiler performance improved a lot -when I made this change: - - perf/compiler/T5837.run T5837 [stat too good] (normal) - perf/compiler/parsing001.run parsing001 [stat too good] (normal) - perf/compiler/T12234.run T12234 [stat too good] (optasm) - perf/compiler/T9020.run T9020 [stat too good] (optasm) - perf/compiler/T3064.run T3064 [stat too good] (normal) - perf/compiler/T9961.run T9961 [stat too good] (normal) - perf/compiler/T13056.run T13056 [stat too good] (optasm) - perf/compiler/T9872d.run T9872d [stat too good] (normal) - perf/compiler/T783.run T783 [stat too good] (normal) - perf/compiler/T12227.run T12227 [stat too good] (normal) - perf/should_run/lazy-bs-alloc.run lazy-bs-alloc [stat too good] (normal) - perf/compiler/T1969.run T1969 [stat too good] (normal) - perf/compiler/T9872a.run T9872a [stat too good] (normal) - perf/compiler/T9872c.run T9872c [stat too good] (normal) - perf/compiler/T9872b.run T9872b [stat too good] (normal) - perf/compiler/T9872d.run T9872d [stat too good] (normal) - -Note [RULEs enabled in SimplGently] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -RULES are enabled when doing "gentle" simplification. Two reasons: - - * We really want the class-op cancellation to happen: - op (df d1 d2) --> $cop3 d1 d2 - because this breaks the mutual recursion between 'op' and 'df' - - * I wanted the RULE - lift String ===> ... - to work in Template Haskell when simplifying - splices, so we get simpler code for literal strings - -But watch out: list fusion can prevent floating. So use phase control -to switch off those rules until after floating. - -************************************************************************ -* * - The CoreToDo interpreter -* * -************************************************************************ --} - -runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts -runCorePasses passes guts - = foldM do_pass guts passes - where - do_pass guts CoreDoNothing = return guts - do_pass guts (CoreDoPasses ps) = runCorePasses ps guts - do_pass guts pass = do - withTimingD (ppr pass <+> brackets (ppr mod)) - (const ()) $ do - { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts - ; endPass pass (mg_binds guts') (mg_rules guts') - ; return guts' } - - mod = mg_module guts - -doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts -doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} - simplifyPgm pass - -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - doPass cseProgram - -doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - doPassD liberateCase - -doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - floatInwards - -doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards f) - -doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - doPassU doStaticArgs - -doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} - doPassD callArityAnalProgram - -doCorePass CoreDoExitify = {-# SCC "Exitify" #-} - doPass exitifyProgram - -doCorePass CoreDoStrictness = {-# SCC "NewStranal" #-} - doPassDFM dmdAnalProgram - -doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - doPassDFU wwTopBinds - -doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - specProgram - -doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - specConstrProgram - -doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat -doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = runCorePasses passes - -doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass - -doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) - -{- -************************************************************************ -* * -\subsection{Core pass combinators} -* * -************************************************************************ --} - -printCore :: DynFlags -> CoreProgram -> IO () -printCore dflags binds - = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) - -ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheckPass current_phase pat guts = - withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) - (const ()) $ do - { rb <- getRuleBase - ; dflags <- getDynFlags - ; vis_orphs <- getVisibleOrphanMods - ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn - ++ (mg_rules guts) - ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (ruleCheckProgram current_phase pat - rule_fn (mg_binds guts)) - ; return guts } - -doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDUM do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - us <- getUniqueSupplyM - liftIO $ do_pass dflags us binds - -doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) - -doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) - -doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) - -doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassU do_pass = doPassDU (const do_pass) - -doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFM do_pass guts = do - dflags <- getDynFlags - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPassM (liftIO . do_pass dflags fam_envs) guts - -doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFU do_pass guts = do - dflags <- getDynFlags - us <- getUniqueSupplyM - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPass (do_pass dflags fam_envs us) guts - --- Most passes return no stats and don't change rules: these combinators --- let us lift them to the full blown ModGuts+CoreM world -doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts -doPassM bind_f guts = do - binds' <- bind_f (mg_binds guts) - return (guts { mg_binds = binds' }) - -doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } - --- Observer passes just peek; don't modify the bindings at all -observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts -observe do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - _ <- liftIO $ do_pass dflags binds - return binds - -{- -************************************************************************ -* * - Gentle simplification -* * -************************************************************************ --} - -simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr --- simplifyExpr is called by the driver to simplify an --- expression typed in at the interactive prompt --- --- Also used by Template Haskell -simplifyExpr dflags expr - = withTiming dflags (text "Simplify [expr]") (const ()) $ - do { - ; us <- mkSplitUniqSupply 's' - - ; let sz = exprSize expr - - ; (expr', counts) <- initSmpl dflags emptyRuleEnv - emptyFamInstEnvs us sz - (simplExprGently (simplEnvForGHCi dflags) expr) - - ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics" (pprSimplCount counts) - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" - (pprCoreExpr expr') - - ; return expr' - } - -simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- Simplifies an expression --- does occurrence analysis, then simplification --- and repeats (twice currently) because one pass --- alone leaves tons of crud. --- Used (a) for user expressions typed in at the interactive prompt --- (b) the LHS and RHS of a RULE --- (c) Template Haskell splices --- --- The name 'Gently' suggests that the SimplMode is SimplGently, --- and in fact that is so.... but the 'Gently' in simplExprGently doesn't --- enforce that; it just simplifies the expression twice - --- It's important that simplExprGently does eta reduction; see --- Note [Simplifying the left-hand side of a RULE] above. The --- simplifier does indeed do eta reduction (it's in Simplify.completeLam) --- but only if -O is on. - -simplExprGently env expr = do - expr1 <- simplExpr env (occurAnalyseExpr expr) - simplExpr env (occurAnalyseExpr expr1) - -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts -simplifyPgm pass guts - = do { hsc_env <- getHscEnv - ; us <- getUniqueSupplyM - ; rb <- getRuleBase - ; liftIOWithCount $ - simplifyPgmIO pass hsc_env us rb guts } - -simplifyPgmIO :: CoreToDo - -> HscEnv - -> UniqSupply - -> RuleBase - -> ModGuts - -> IO (SimplCount, ModGuts) -- New bindings - -simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) - hsc_env us hpt_rule_base - guts@(ModGuts { mg_module = this_mod - , mg_rdr_env = rdr_env - , mg_deps = deps - , mg_binds = binds, mg_rules = rules - , mg_fam_inst_env = fam_inst_env }) - = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration us 1 [] binds rules - - ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && - dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr it_count - <+> text "iterations", - blankLine, - pprSimplCount counts_out]) - - ; return (counts_out, guts') - } - where - dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env - simpl_env = mkSimplEnv mode - active_rule = activeRule mode - active_unf = activeUnfolding mode - - do_iteration :: UniqSupply - -> Int -- Counts iterations - -> [SimplCount] -- Counts from earlier iterations, reversed - -> CoreProgram -- Bindings in - -> [CoreRule] -- and orphan rules - -> IO (String, Int, SimplCount, ModGuts) - - do_iteration us iteration_no counts_so_far binds rules - -- iteration_no is the number of the iteration we are - -- about to begin, with '1' for the first - | iteration_no > max_iterations -- Stop if we've run out of iterations - = WARN( debugIsOn && (max_iterations > 2) - , hang (text "Simplifier bailing out after" <+> int max_iterations - <+> text "iterations" - <+> (brackets $ hsep $ punctuate comma $ - map (int . simplCountN) (reverse counts_so_far))) - 2 (text "Size =" <+> ppr (coreBindsStats binds))) - - -- Subtract 1 from iteration_no to get the - -- number of iterations we actually completed - return ( "Simplifier baled out", iteration_no - 1 - , totalise counts_so_far - , guts { mg_binds = binds, mg_rules = rules } ) - - -- Try and force thunks off the binds; significantly reduces - -- space usage, especially with -O. JRS, 000620. - | let sz = coreBindsSize binds - , () <- sz `seq` () -- Force it - = do { - -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_unf active_rule rules - binds - } ; - Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings tagged_binds); - - -- Get any new rules, and extend the rule base - -- See Note [Overall plumbing for rules] in Rules.hs - -- We need to do this regularly, because simplification can - -- poke on IdInfo thunks, which in turn brings in new rules - -- behind the scenes. Otherwise there's a danger we'll simply - -- miss the rules for Ids hidden inside imported inlinings - eps <- hscEPS hsc_env ; - let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) - ; rule_base2 = extendRuleBaseList rule_base1 rules - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) - ; vis_orphs = this_mod : dep_orphs deps } ; - - -- Simplify the program - ((binds1, rules1), counts1) <- - initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $ - do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_binds - - -- Apply the substitution to rules defined in this module - -- for imported Ids. Eg RULE map my_f = blah - -- If we have a substitution my_f :-> other_f, we'd better - -- apply it to the rule to, or it'll never match - ; rules1 <- simplRules env1 Nothing rules Nothing - - ; return (getTopFloatBinds floats, rules1) } ; - - -- Stop if nothing happened; don't dump output - -- See Note [Which transformations are innocuous] in CoreMonad - if isZeroSimplCount counts1 then - return ( "Simplifier reached fixed point", iteration_no - , totalise (counts1 : counts_so_far) -- Include "free" ticks - , guts { mg_binds = binds1, mg_rules = rules1 } ) - else do { - -- Short out indirections - -- We do this *after* at least one run of the simplifier - -- because indirection-shorting uses the export flag on *occurrences* - -- and that isn't guaranteed to be ok until after the first run propagates - -- stuff from the binding site to its occurrences - -- - -- ToDo: alas, this means that indirection-shorting does not happen at all - -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; - - -- Dump the result of this iteration - dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; - lintPassResult hsc_env pass binds2 ; - - -- Loop - do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 - } } - | otherwise = panic "do_iteration" - where - (us1, us2) = splitUniqSupply us - - -- Remember the counts_so_far are reversed - totalise :: [SimplCount] -> SimplCount - totalise = foldr (\c acc -> acc `plusSimplCount` c) - (zeroSimplCount dflags) - -simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" - -------------------- -dump_end_iteration :: DynFlags -> PrintUnqualified -> Int - -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration dflags print_unqual iteration_no counts binds rules - = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules - where - mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations - | otherwise = Nothing - -- Show details if Opt_D_dump_simpl_iterations is on - - hdr = text "Simplifier iteration=" <> int iteration_no - pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr - , pprSimplCount counts - , text "---- End of simplifier counts for" <+> hdr ] - -{- -************************************************************************ -* * - Shorting out indirections -* * -************************************************************************ - -If we have this: - - x_local = - ...bindings... - x_exported = x_local - -where x_exported is exported, and x_local is not, then we replace it with this: - - x_exported = - x_local = x_exported - ...bindings... - -Without this we never get rid of the x_exported = x_local thing. This -save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and -makes strictness information propagate better. This used to happen in -the final phase, but it's tidier to do it here. - -Note [Messing up the exported Id's RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must be careful about discarding (obviously) or even merging the -RULES on the exported Id. The example that went bad on me at one stage -was this one: - - iterate :: (a -> a) -> a -> [a] - [Exported] - iterate = iterateList - - iterateFB c f x = x `c` iterateFB c f (f x) - iterateList f x = x : iterateList f (f x) - [Not exported] - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList - #-} - -This got shorted out to: - - iterateList :: (a -> a) -> a -> [a] - iterateList = iterate - - iterateFB c f x = x `c` iterateFB c f (f x) - iterate f x = x : iterate f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate - #-} - -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x - -Old "solution": - use rule switching-off pragmas to get rid - of iterateList in the first place - -But in principle the user *might* want rules that only apply to the Id -he says. And inline pragmas are similar - {-# NOINLINE f #-} - f = local - local = -Then we do not want to get rid of the NOINLINE. - -Hence hasShortableIdinfo. - - -Note [Rules and indirection-zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: what if x_exported has a RULE that mentions something in ...bindings...? -Then the things mentioned can be out of scope! Solution - a) Make sure that in this pass the usage-info from x_exported is - available for ...bindings... - b) If there are any such RULES, rec-ify the entire top-level. - It'll get sorted out next time round - -Other remarks -~~~~~~~~~~~~~ -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} -Hence,there's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might elminate a binding that's mentioned in the -unfolding for something. - -Note [Indirection zapping and ticks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unfortunately this is another place where we need a special case for -ticks. The following happens quite regularly: - - x_local = - x_exported = tick x_local - -Which we want to become: - - x_exported = tick - -As it makes no sense to keep the tick and the expression on separate -bindings. Note however that that this might increase the ticks scoping -over the execution of x_local, so we can only do this for floatable -ticks. More often than not, other references will be unfoldings of -x_exported, and therefore carry the tick anyway. --} - -type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks - -shortOutIndirections :: CoreProgram -> CoreProgram -shortOutIndirections binds - | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff - where - ind_env = makeIndEnv binds - -- These exported Ids are the subjects of the indirection-elimination - exp_ids = map fst $ nonDetEltsUFM ind_env - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- by immediately converting to a set or check if all the elements - -- satisfy a predicate. - exp_id_set = mkVarSet exp_ids - no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids - binds' = concatMap zap binds - - zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] - zap (Rec pairs) = [Rec (concatMap zapPair pairs)] - - zapPair (bndr, rhs) - | bndr `elemVarSet` exp_id_set - = [] -- Kill the exported-id binding - - | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr - , (exp_id', lcl_id') <- transferIdInfo exp_id bndr - = -- Turn a local-id binding into two bindings - -- exp_id = rhs; lcl_id = exp_id - [ (exp_id', mkTicks ticks rhs), - (lcl_id', Var exp_id') ] - - | otherwise - = [(bndr,rhs)] - -makeIndEnv :: [CoreBind] -> IndEnv -makeIndEnv binds - = foldl' add_bind emptyVarEnv binds - where - add_bind :: IndEnv -> CoreBind -> IndEnv - add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) - add_bind env (Rec pairs) = foldl' add_pair env pairs - - add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv - add_pair env (exported_id, exported) - | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported - , shortMeOut env exported_id local_id - = extendVarEnv env local_id (exported_id, ticks) - add_pair env _ = env - ------------------ -shortMeOut :: IndEnv -> Id -> Id -> Bool -shortMeOut ind_env exported_id local_id --- The if-then-else stuff is just so I can get a pprTrace to see --- how often I don't get shorting out because of IdInfo stuff - = if isExportedId exported_id && -- Only if this is exported - - isLocalId local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for - then - if hasShortableIdInfo exported_id - then True -- See Note [Messing up the exported Id's IdInfo] - else WARN( True, text "Not shorting out:" <+> ppr exported_id ) - False - else - False - ------------------ -hasShortableIdInfo :: Id -> Bool --- True if there is no user-attached IdInfo on exported_id, --- so we can safely discard it --- See Note [Messing up the exported Id's IdInfo] -hasShortableIdInfo id - = isEmptyRuleInfo (ruleInfo info) - && isDefaultInlinePragma (inlinePragInfo info) - && not (isStableUnfolding (unfoldingInfo info)) - where - info = idInfo id - ------------------ -{- Note [Transferring IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - lcl_id = e; exp_id = lcl_id - -and lcl_id has useful IdInfo, we don't want to discard it by going - gbl_id = e; lcl_id = gbl_id - -Instead, transfer IdInfo from lcl_id to exp_id, specifically -* (Stable) unfolding -* Strictness -* Rules -* Inline pragma - -Overwriting, rather than merging, seems to work ok. - -We also zap the InlinePragma on the lcl_id. It might originally -have had a NOINLINE, which we have now transferred; and we really -want the lcl_id to inline now that its RHS is trivial! --} - -transferIdInfo :: Id -> Id -> (Id, Id) --- See Note [Transferring IdInfo] -transferIdInfo exported_id local_id - = ( modifyIdInfo transfer exported_id - , local_id `setInlinePragma` defaultInlinePragma ) - where - local_info = idInfo local_id - transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info - `setUnfoldingInfo` unfoldingInfo local_info - `setInlinePragInfo` inlinePragInfo local_info - `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info - new_info = setRuleInfoHead (idName exported_id) - (ruleInfo local_info) - -- Remember to set the function-name field of the - -- rules as we transfer them from one function to another diff --git a/simplCore/SimplEnv.hs b/simplCore/SimplEnv.hs deleted file mode 100644 --- a/simplCore/SimplEnv.hs +++ /dev/null @@ -1,938 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[SimplMonad]{The simplifier Monad} --} - -{-# LANGUAGE CPP #-} - -module SimplEnv ( - -- * The simplifier mode - setMode, getMode, updMode, seDynFlags, - - -- * Environments - SimplEnv(..), pprSimplEnv, -- Temp not abstract - mkSimplEnv, extendIdSubst, - SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, - zapSubstEnv, setSubstEnv, - getInScope, setInScopeFromE, setInScopeFromF, - setInScopeSet, modifyInScope, addNewInScopeIds, - getSimplRules, - - -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, - - -- * Simplifying 'Id' binders - simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, - simplBinder, simplBinders, - substTy, substTyVar, getTCvSubst, - substCo, substCoVar, - - -- * Floats - SimplFloats(..), emptyFloats, mkRecFloats, - mkFloatBind, addLetFloats, addJoinFloats, addFloats, - extendFloats, wrapFloats, - doFloatFromRhs, getTopFloatBinds, - - -- * LetFloats - LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, - addLetFlts, mapLetFloats, - - -- * JoinFloats - JoinFloat, JoinFloats, emptyJoinFloats, - wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import SimplMonad -import CoreMonad ( SimplMode(..) ) -import CoreSyn -import CoreUtils -import Var -import VarEnv -import VarSet -import OrdList -import Id -import MkCore ( mkWildValBinder ) -import DynFlags ( DynFlags ) -import TysWiredIn -import qualified Type -import Type hiding ( substTy, substTyVar, substTyVarBndr ) -import qualified Coercion -import Coercion hiding ( substCo, substCoVar, substCoVarBndr ) -import BasicTypes -import MonadUtils -import Outputable -import Util -import UniqFM ( pprUniqFM ) - -import Data.List (mapAccumL) - -{- -************************************************************************ -* * -\subsubsection{The @SimplEnv@ type} -* * -************************************************************************ --} - -data SimplEnv - = SimplEnv { - ----------- Static part of the environment ----------- - -- Static in the sense of lexically scoped, - -- wrt the original expression - - seMode :: SimplMode - - -- The current substitution - , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType - , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion - , seIdSubst :: SimplIdSubst -- InId |--> OutExpr - - ----------- Dynamic part of the environment ----------- - -- Dynamic in the sense of describing the setup where - -- the expression finally ends up - - -- The current set of in-scope variables - -- They are all OutVars, and all bound in this module - , seInScope :: InScopeSet -- OutVars only - } - -data SimplFloats - = SimplFloats - { -- Ordinary let bindings - sfLetFloats :: LetFloats - -- See Note [LetFloats] - - -- Join points - , sfJoinFloats :: JoinFloats - -- Handled separately; they don't go very far - -- We consider these to be /inside/ sfLetFloats - -- because join points can refer to ordinary bindings, - -- but not vice versa - - -- Includes all variables bound by sfLetFloats and - -- sfJoinFloats, plus at least whatever is in scope where - -- these bindings land up. - , sfInScope :: InScopeSet -- All OutVars - } - -instance Outputable SimplFloats where - ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) - = text "SimplFloats" - <+> braces (vcat [ text "lets: " <+> ppr lf - , text "joins:" <+> ppr jf - , text "in_scope:" <+> ppr is ]) - -emptyFloats :: SimplEnv -> SimplFloats -emptyFloats env - = SimplFloats { sfLetFloats = emptyLetFloats - , sfJoinFloats = emptyJoinFloats - , sfInScope = seInScope env } - -pprSimplEnv :: SimplEnv -> SDoc --- Used for debugging; selective -pprSimplEnv env - = vcat [text "TvSubst:" <+> ppr (seTvSubst env), - text "CvSubst:" <+> ppr (seCvSubst env), - text "IdSubst:" <+> id_subst_doc, - text "InScope:" <+> in_scope_vars_doc - ] - where - id_subst_doc = pprUniqFM ppr (seIdSubst env) - in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) - (vcat . map ppr_one) - ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) - | otherwise = ppr v - -type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr - -- See Note [Extending the Subst] in CoreSubst - --- | A substitution result. -data SimplSR - = DoneEx OutExpr (Maybe JoinArity) - -- If x :-> DoneEx e ja is in the SimplIdSubst - -- then replace occurrences of x by e - -- and ja = Just a <=> x is a join-point of arity a - -- See Note [Join arity in SimplIdSubst] - - - | DoneId OutId - -- If x :-> DoneId v is in the SimplIdSubst - -- then replace occurrences of x by v - -- and v is a join-point of arity a - -- <=> x is a join-point of arity a - - | ContEx TvSubstEnv -- A suspended substitution - CvSubstEnv - SimplIdSubst - InExpr - -- If x :-> ContEx tv cv id e is in the SimplISubst - -- then replace occurrences of x by (subst (tv,cv,id) e) - -instance Outputable SimplSR where - ppr (DoneId v) = text "DoneId" <+> ppr v - ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e - where - pp_mj = case mj of - Nothing -> empty - Just n -> parens (int n) - - ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, - ppr (filter_env tv), ppr (filter_env id) -}] - -- where - -- fvs = exprFreeVars e - -- filter_env env = filterVarEnv_Directly keep env - -- keep uniq _ = uniq `elemUFM_Directly` fvs - -{- -Note [SimplEnv invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -seInScope: - The in-scope part of Subst includes *all* in-scope TyVars and Ids - The elements of the set may have better IdInfo than the - occurrences of in-scope Ids, and (more important) they will - have a correctly-substituted type. So we use a lookup in this - set to replace occurrences - - The Ids in the InScopeSet are replete with their Rules, - and as we gather info about the unfolding of an Id, we replace - it in the in-scope set. - - The in-scope set is actually a mapping OutVar -> OutVar, and - in case expressions we sometimes bind - -seIdSubst: - The substitution is *apply-once* only, because InIds and OutIds - can overlap. - For example, we generally omit mappings - a77 -> a77 - from the substitution, when we decide not to clone a77, but it's quite - legitimate to put the mapping in the substitution anyway. - - Furthermore, consider - let x = case k of I# x77 -> ... in - let y = case k of I# x77 -> ... in ... - and suppose the body is strict in both x and y. Then the simplifier - will pull the first (case k) to the top; so the second (case k) will - cancel out, mapping x77 to, well, x77! But one is an in-Id and the - other is an out-Id. - - Of course, the substitution *must* applied! Things in its domain - simply aren't necessarily bound in the result. - -* substId adds a binding (DoneId new_id) to the substitution if - the Id's unique has changed - - Note, though that the substitution isn't necessarily extended - if the type of the Id changes. Why not? Because of the next point: - -* We *always, always* finish by looking up in the in-scope set - any variable that doesn't get a DoneEx or DoneVar hit in the substitution. - Reason: so that we never finish up with a "old" Id in the result. - An old Id might point to an old unfolding and so on... which gives a space - leak. - - [The DoneEx and DoneVar hits map to "new" stuff.] - -* It follows that substExpr must not do a no-op if the substitution is empty. - substType is free to do so, however. - -* When we come to a let-binding (say) we generate new IdInfo, including an - unfolding, attach it to the binder, and add this newly adorned binder to - the in-scope set. So all subsequent occurrences of the binder will get - mapped to the full-adorned binder, which is also the one put in the - binding site. - -* The in-scope "set" usually maps x->x; we use it simply for its domain. - But sometimes we have two in-scope Ids that are synomyms, and should - map to the same target: x->x, y->x. Notably: - case y of x { ... } - That's why the "set" is actually a VarEnv Var - -Note [Join arity in SimplIdSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to remember which incoming variables are join points: the occurrences -may not be marked correctly yet, and we're in change of propagating the change if -OccurAnal makes something a join point). - -Normally the in-scope set is where we keep the latest information, but -the in-scope set tracks only OutVars; if a binding is unconditionally -inlined (via DoneEx), it never makes it into the in-scope set, and we -need to know at the occurrence site that the variable is a join point -so that we know to drop the context. Thus we remember which join -points we're substituting. -} - -mkSimplEnv :: SimplMode -> SimplEnv -mkSimplEnv mode - = SimplEnv { seMode = mode - , seInScope = init_in_scope - , seTvSubst = emptyVarEnv - , seCvSubst = emptyVarEnv - , seIdSubst = emptyVarEnv } - -- The top level "enclosing CC" is "SUBSUMED". - -init_in_scope :: InScopeSet -init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) - -- See Note [WildCard binders] - -{- -Note [WildCard binders] -~~~~~~~~~~~~~~~~~~~~~~~ -The program to be simplified may have wild binders - case e of wild { p -> ... } -We want to *rename* them away, so that there are no -occurrences of 'wild-id' (with wildCardKey). The easy -way to do that is to start of with a representative -Id in the in-scope set - -There can be *occurrences* of wild-id. For example, -MkCore.mkCoreApp transforms - e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } -This is ok provided 'wild' isn't free in 'e', and that's the delicate -thing. Generally, you want to run the simplifier to get rid of the -wild-ids before doing much else. - -It's a very dark corner of GHC. Maybe it should be cleaned up. --} - -getMode :: SimplEnv -> SimplMode -getMode env = seMode env - -seDynFlags :: SimplEnv -> DynFlags -seDynFlags env = sm_dflags (seMode env) - -setMode :: SimplMode -> SimplEnv -> SimplEnv -setMode mode env = env { seMode = mode } - -updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv -updMode upd env = env { seMode = upd (seMode env) } - ---------------------- -extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv -extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res - = ASSERT2( isId var && not (isCoVar var), ppr var ) - env { seIdSubst = extendVarEnv subst var res } - -extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res - = ASSERT2( isTyVar var, ppr var $$ ppr res ) - env {seTvSubst = extendVarEnv tsubst var res} - -extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv -extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co - = ASSERT( isCoVar var ) - env {seCvSubst = extendVarEnv csubst var co} - ---------------------- -getInScope :: SimplEnv -> InScopeSet -getInScope env = seInScope env - -setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv -setInScopeSet env in_scope = env {seInScope = in_scope} - -setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv --- See Note [Setting the right in-scope set] -setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } - -setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv -setInScopeFromF env floats = env { seInScope = sfInScope floats } - -addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv - -- The new Ids are guaranteed to be freshly allocated -addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs - = env { seInScope = in_scope `extendInScopeSetList` vs, - seIdSubst = id_subst `delVarEnvList` vs } - -- Why delete? Consider - -- let x = a*b in (x, \x -> x+3) - -- We add [x |-> a*b] to the substitution, but we must - -- _delete_ it from the substitution when going inside - -- the (\x -> ...)! - -modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv --- The variable should already be in scope, but --- replace the existing version with this new one --- which has more information -modifyInScope env@(SimplEnv {seInScope = in_scope}) v - = env {seInScope = extendInScopeSet in_scope v} - -{- Note [Setting the right in-scope set] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - \x. (let x = e in b) arg[x] -where the let shadows the lambda. Really this means something like - \x1. (let x2 = e in b) arg[x1] - -- When we capture the 'arg' in an ApplyToVal continuation, we capture - the environment, which says what 'x' is bound to, namely x1 - -- Then that continuation gets pushed under the let - -- Finally we simplify 'arg'. We want - - the static, lexical environment bindig x :-> x1 - - the in-scopeset from "here", under the 'let' which includes - both x1 and x2 - -It's important to have the right in-scope set, else we may rename a -variable to one that is already in scope. So we must pick up the -in-scope set from "here", but otherwise use the environment we -captured along with 'arg'. This transfer of in-scope set is done by -setInScopeFromE. --} - ---------------------- -zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} - -setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv -setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } - -mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e - -{- -************************************************************************ -* * -\subsection{LetFloats} -* * -************************************************************************ - -Note [LetFloats] -~~~~~~~~~~~~~~~~ -The LetFloats is a bunch of bindings, classified by a FloatFlag. - -* All of them satisfy the let/app invariant - -Examples - - NonRec x (y:ys) FltLifted - Rec [(x,rhs)] FltLifted - - NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? - NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n - - NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge - -Can't happen: - NonRec x# (a /# b) -- Might fail; does not satisfy let/app - NonRec x# (f y) -- Might diverge; does not satisfy let/app --} - -data LetFloats = LetFloats (OrdList OutBind) FloatFlag - -- See Note [LetFloats] - -type JoinFloat = OutBind -type JoinFloats = OrdList JoinFloat - -data FloatFlag - = FltLifted -- All bindings are lifted and lazy *or* - -- consist of a single primitive string literal - -- Hence ok to float to top level, or recursive - - | FltOkSpec -- All bindings are FltLifted *or* - -- strict (perhaps because unlifted, - -- perhaps because of a strict binder), - -- *and* ok-for-speculation - -- Hence ok to float out of the RHS - -- of a lazy non-recursive let binding - -- (but not to top level, or into a rec group) - - | FltCareful -- At least one binding is strict (or unlifted) - -- and not guaranteed cheap - -- Do not float these bindings out of a lazy let - -instance Outputable LetFloats where - ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) - -instance Outputable FloatFlag where - ppr FltLifted = text "FltLifted" - ppr FltOkSpec = text "FltOkSpec" - ppr FltCareful = text "FltCareful" - -andFF :: FloatFlag -> FloatFlag -> FloatFlag -andFF FltCareful _ = FltCareful -andFF FltOkSpec FltCareful = FltCareful -andFF FltOkSpec _ = FltOkSpec -andFF FltLifted flt = flt - -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool --- If you change this function look also at FloatIn.noFloatFromRhs -doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs - = not (isNilOL fs) && want_to_float && can_float - where - want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs - -- See Note [Float when cheap or expandable] - can_float = case ff of - FltLifted -> True - FltOkSpec -> isNotTopLevel lvl && isNonRec rec - FltCareful -> isNotTopLevel lvl && isNonRec rec && str - -{- -Note [Float when cheap or expandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to float a let from a let if the residual RHS is - a) cheap, such as (\x. blah) - b) expandable, such as (f b) if f is CONLIKE -But there are - - cheap things that are not expandable (eg \x. expensive) - - expandable things that are not cheap (eg (f b) where b is CONLIKE) -so we must take the 'or' of the two. --} - -emptyLetFloats :: LetFloats -emptyLetFloats = LetFloats nilOL FltLifted - -emptyJoinFloats :: JoinFloats -emptyJoinFloats = nilOL - -unitLetFloat :: OutBind -> LetFloats --- This key function constructs a singleton float with the right form -unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) - LetFloats (unitOL bind) (flag bind) - where - flag (Rec {}) = FltLifted - flag (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprIsTickedString rhs = FltLifted - -- String literals can be floated freely. - -- See Note [CoreSyn top-level string literals] in CoreSyn. - | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) - | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) - FltCareful - -- Unlifted binders can only be let-bound if exprOkForSpeculation holds - -unitJoinFloat :: OutBind -> JoinFloats -unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind)) - unitOL bind - -mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) --- Make a singleton SimplFloats, and --- extend the incoming SimplEnv's in-scope set with its binders --- These binders may already be in the in-scope set, --- but may have by now been augmented with more IdInfo -mkFloatBind env bind - = (floats, env { seInScope = in_scope' }) - where - floats - | isJoinBind bind - = SimplFloats { sfLetFloats = emptyLetFloats - , sfJoinFloats = unitJoinFloat bind - , sfInScope = in_scope' } - | otherwise - = SimplFloats { sfLetFloats = unitLetFloat bind - , sfJoinFloats = emptyJoinFloats - , sfInScope = in_scope' } - - in_scope' = seInScope env `extendInScopeSetBind` bind - -extendFloats :: SimplFloats -> OutBind -> SimplFloats --- Add this binding to the floats, and extend the in-scope env too -extendFloats (SimplFloats { sfLetFloats = floats - , sfJoinFloats = jfloats - , sfInScope = in_scope }) - bind - | isJoinBind bind - = SimplFloats { sfInScope = in_scope' - , sfLetFloats = floats - , sfJoinFloats = jfloats' } - | otherwise - = SimplFloats { sfInScope = in_scope' - , sfLetFloats = floats' - , sfJoinFloats = jfloats } - where - in_scope' = in_scope `extendInScopeSetBind` bind - floats' = floats `addLetFlts` unitLetFloat bind - jfloats' = jfloats `addJoinFlts` unitJoinFloat bind - -addLetFloats :: SimplFloats -> LetFloats -> SimplFloats --- Add the let-floats for env2 to env1; --- *plus* the in-scope set for env2, which is bigger --- than that for env1 -addLetFloats floats let_floats@(LetFloats binds _) - = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats - , sfInScope = foldlOL extendInScopeSetBind - (sfInScope floats) binds } - -addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats -addJoinFloats floats join_floats - = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats - , sfInScope = foldlOL extendInScopeSetBind - (sfInScope floats) join_floats } - -extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet -extendInScopeSetBind in_scope bind - = extendInScopeSetList in_scope (bindersOf bind) - -addFloats :: SimplFloats -> SimplFloats -> SimplFloats --- Add both let-floats and join-floats for env2 to env1; --- *plus* the in-scope set for env2, which is bigger --- than that for env1 -addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) - (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) - = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 - , sfJoinFloats = jf1 `addJoinFlts` jf2 - , sfInScope = in_scope } - -addLetFlts :: LetFloats -> LetFloats -> LetFloats -addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) - = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) - -letFloatBinds :: LetFloats -> [CoreBind] -letFloatBinds (LetFloats bs _) = fromOL bs - -addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats -addJoinFlts = appOL - -mkRecFloats :: SimplFloats -> SimplFloats --- Flattens the floats from env2 into a single Rec group, --- They must either all be lifted LetFloats or all JoinFloats -mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff - , sfJoinFloats = jbs - , sfInScope = in_scope }) - = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) - ASSERT2( isNilOL bs || isNilOL jbs, ppr floats ) - SimplFloats { sfLetFloats = floats' - , sfJoinFloats = jfloats' - , sfInScope = in_scope } - where - floats' | isNilOL bs = emptyLetFloats - | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) - jfloats' | isNilOL jbs = emptyJoinFloats - | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) - -wrapFloats :: SimplFloats -> OutExpr -> OutExpr --- Wrap the floats around the expression; they should all --- satisfy the let/app invariant, so mkLets should do the job just fine -wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ - , sfJoinFloats = jbs }) body - = foldrOL Let (wrapJoinFloats jbs body) bs - -- Note: Always safe to put the joins on the inside - -- since the values can't refer to them - -wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) --- Wrap the sfJoinFloats of the env around the expression, --- and take them out of the SimplEnv -wrapJoinFloatsX floats body - = ( floats { sfJoinFloats = emptyJoinFloats } - , wrapJoinFloats (sfJoinFloats floats) body ) - -wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr --- Wrap the sfJoinFloats of the env around the expression, --- and take them out of the SimplEnv -wrapJoinFloats join_floats body - = foldrOL Let body join_floats - -getTopFloatBinds :: SimplFloats -> [CoreBind] -getTopFloatBinds (SimplFloats { sfLetFloats = lbs - , sfJoinFloats = jbs}) - = ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings - letFloatBinds lbs - -mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats -mapLetFloats (LetFloats fs ff) fun - = LetFloats (mapOL app fs) ff - where - app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' - app (Rec bs) = Rec (map fun bs) - -{- -************************************************************************ -* * - Substitution of Vars -* * -************************************************************************ - -Note [Global Ids in the substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We look up even a global (eg imported) Id in the substitution. Consider - case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } -The binder-swap in the occurrence analyser will add a binding -for a LocalId version of g (with the same unique though): - case X.g_34 of b { (a,b) -> let g_34 = b in - ... case X.g_34 of { (p,q) -> ...} ... } -So we want to look up the inner X.g_34 in the substitution, where we'll -find that it has been substituted by b. (Or conceivably cloned.) --} - -substId :: SimplEnv -> InId -> SimplSR --- Returns DoneEx only on a non-Var expression -substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] - Nothing -> DoneId (refineFromInScope in_scope v) - Just (DoneId v) -> DoneId (refineFromInScope in_scope v) - Just res -> res -- DoneEx non-var, or ContEx - - -- Get the most up-to-date thing from the in-scope set - -- Even though it isn't in the substitution, it may be in - -- the in-scope set with better IdInfo. - -- - -- See also Note [In-scope set as a substitution] in Simplify. - -refineFromInScope :: InScopeSet -> Var -> Var -refineFromInScope in_scope v - | isLocalId v = case lookupInScope in_scope v of - Just v' -> v' - Nothing -> WARN( True, ppr v ) v -- This is an error! - | otherwise = v - -lookupRecBndr :: SimplEnv -> InId -> OutId --- Look up an Id which has been put into the envt by simplRecBndrs, --- but where we have not yet done its RHS -lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - = case lookupVarEnv ids v of - Just (DoneId v) -> v - Just _ -> pprPanic "lookupRecBndr" (ppr v) - Nothing -> refineFromInScope in_scope v - -{- -************************************************************************ -* * -\section{Substituting an Id binder} -* * -************************************************************************ - - -These functions are in the monad only so that they can be made strict via seq. - -Note [Return type for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - (join j :: Char -> Int -> Int) 77 - ( j x = \y. y + ord x ) - (in case v of ) - ( A -> j 'x' ) - ( B -> j 'y' ) - ( C -> ) - -The simplifier pushes the "apply to 77" continuation inwards to give - - join j :: Char -> Int - j x = (\y. y + ord x) 77 - in case v of - A -> j 'x' - B -> j 'y' - C -> 77 - -Notice that the "apply to 77" continuation went into the RHS of the -join point. And that meant that the return type of the join point -changed!! - -That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr -takes a (Just res_ty) argument so that it knows to do the type-changing -thing. --} - -simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplBinders env bndrs = mapAccumLM simplBinder env bndrs - -------------- -simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Used for lambda and case-bound variables --- Clone Id if necessary, substitute type --- Return with IdInfo already substituted, but (fragile) occurrence info zapped --- The substitution is extended only if the variable is cloned, because --- we *don't* need to use it to track occurrence info. -simplBinder env bndr - | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr - ; seqTyVar tv `seq` return (env', tv) } - | otherwise = do { let (env', id) = substIdBndr Nothing env bndr - ; seqId id `seq` return (env', id) } - ---------------- -simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- A non-recursive let binder -simplNonRecBndr env id - = do { let (env1, id1) = substIdBndr Nothing env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr - -> SimplM (SimplEnv, OutBndr) --- A non-recursive let binder for a join point; --- context being pushed inward may change the type --- See Note [Return type for join points] -simplNonRecJoinBndr env res_ty id - = do { let (env1, id1) = substIdBndr (Just res_ty) env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv --- Recursive let binders -simplRecBndrs env@(SimplEnv {}) ids - = ASSERT(all (not . isJoinId) ids) - do { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids - ; seqIds ids1 `seq` return env1 } - ---------------- -simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv --- Recursive let binders for join points; --- context being pushed inward may change types --- See Note [Return type for join points] -simplRecJoinBndrs env@(SimplEnv {}) res_ty ids - = ASSERT(all isJoinId ids) - do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids - ; seqIds ids1 `seq` return env1 } - ---------------- -substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr) --- Might be a coercion variable -substIdBndr new_res_ty env bndr - | isCoVar bndr = substCoVarBndr env bndr - | otherwise = substNonCoVarIdBndr new_res_ty env bndr - ---------------- -substNonCoVarIdBndr - :: Maybe OutType -- New result type, if a join binder - -- See Note [Return type for join points] - -> SimplEnv - -> InBndr -- Env and binder to transform - -> (SimplEnv, OutBndr) --- Clone Id if necessary, substitute its type --- Return an Id with its --- * Type substituted --- * UnfoldingInfo, Rules, WorkerInfo zapped --- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] --- * Robust info, retained especially arity and demand info, --- so that they are available to occurrences that occur in an --- earlier binding of a letrec --- --- For the robust info, see Note [Arity robustness] --- --- Augment the substitution if the unique changed --- Extend the in-scope set with the new Id --- --- Similar to CoreSubst.substIdBndr, except that --- the type of id_subst differs --- all fragile info is zapped -substNonCoVarIdBndr new_res_ty - env@(SimplEnv { seInScope = in_scope - , seIdSubst = id_subst }) - old_id - = ASSERT2( not (isCoVar old_id), ppr old_id ) - (env { seInScope = in_scope `extendInScopeSet` new_id, - seIdSubst = new_subst }, new_id) - where - id1 = uniqAway in_scope old_id - id2 = substIdType env id1 - - id3 | Just res_ty <- new_res_ty - = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2) - -- See Note [Return type for join points] - | otherwise - = id2 - - new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding - -- and fragile OccInfo - - -- Extend the substitution if the unique has changed, - -- or there's some useful occurrence information - -- See the notes with substTyVarBndr for the delSubstEnv - new_subst | new_id /= old_id - = extendVarEnv id_subst old_id (DoneId new_id) - | otherwise - = delVarEnv id_subst old_id - ------------------------------------- -seqTyVar :: TyVar -> () -seqTyVar b = b `seq` () - -seqId :: Id -> () -seqId id = seqType (idType id) `seq` - idInfo id `seq` - () - -seqIds :: [Id] -> () -seqIds [] = () -seqIds (id:ids) = seqId id `seq` seqIds ids - -{- -Note [Arity robustness] -~~~~~~~~~~~~~~~~~~~~~~~ -We *do* transfer the arity from from the in_id of a let binding to the -out_id. This is important, so that the arity of an Id is visible in -its own RHS. For example: - f = \x. ....g (\y. f y).... -We can eta-reduce the arg to g, because f is a value. But that -needs to be visible. - -This interacts with the 'state hack' too: - f :: Bool -> IO Int - f = \x. case x of - True -> f y - False -> \s -> ... -Can we eta-expand f? Only if we see that f has arity 1, and then we -take advantage of the 'state hack' on the result of -(f y) :: State# -> (State#, Int) to expand the arity one more. - -There is a disadvantage though. Making the arity visible in the RHS -allows us to eta-reduce - f = \x -> f x -to - f = f -which technically is not sound. This is very much a corner case, so -I'm not worried about it. Another idea is to ensure that f's arity -never decreases; its arity started as 1, and we should never eta-reduce -below that. - - -Note [Robust OccInfo] -~~~~~~~~~~~~~~~~~~~~~ -It's important that we *do* retain the loop-breaker OccInfo, because -that's what stops the Id getting inlined infinitely, in the body of -the letrec. --} - - -{- -************************************************************************ -* * - Impedance matching to type substitution -* * -************************************************************************ --} - -getTCvSubst :: SimplEnv -> TCvSubst -getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env - , seCvSubst = cv_env }) - = mkTCvSubst in_scope (tv_env, cv_env) - -substTy :: SimplEnv -> Type -> Type -substTy env ty = Type.substTy (getTCvSubst env) ty - -substTyVar :: SimplEnv -> TyVar -> Type -substTyVar env tv = Type.substTyVar (getTCvSubst env) tv - -substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) -substTyVarBndr env tv - = case Type.substTyVarBndr (getTCvSubst env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') - -substCoVar :: SimplEnv -> CoVar -> Coercion -substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv - -substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) -substCoVarBndr env cv - = case Coercion.substCoVarBndr (getTCvSubst env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') - -substCo :: SimplEnv -> Coercion -> Coercion -substCo env co = Coercion.substCo (getTCvSubst env) co - ------------------- -substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) - || noFreeVarsOfType old_ty - = id - | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) - -- The tyCoVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself - where - old_ty = idType id diff --git a/simplCore/SimplMonad.hs b/simplCore/SimplMonad.hs deleted file mode 100644 --- a/simplCore/SimplMonad.hs +++ /dev/null @@ -1,251 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[SimplMonad]{The simplifier Monad} --} - -{-# LANGUAGE DeriveFunctor #-} -module SimplMonad ( - -- The monad - SimplM, - initSmpl, traceSmpl, - getSimplRules, getFamEnvs, - - -- Unique supply - MonadUnique(..), newId, newJoinId, - - -- Counting - SimplCount, tick, freeTick, checkedTick, - getSimplCount, zeroSimplCount, pprSimplCount, - plusSimplCount, isZeroSimplCount - ) where - -import GhcPrelude - -import Var ( Var, isId, mkLocalVar ) -import Name ( mkSystemVarName ) -import Id ( Id, mkSysLocalOrCoVar ) -import IdInfo ( IdDetails(..), vanillaIdInfo, setArityInfo ) -import Type ( Type, mkLamTypes ) -import FamInstEnv ( FamInstEnv ) -import CoreSyn ( RuleEnv(..) ) -import UniqSupply -import DynFlags -import CoreMonad -import Outputable -import FastString -import MonadUtils -import ErrUtils as Err -import Util ( count ) -import Panic (throwGhcExceptionIO, GhcException (..)) -import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf ) -import Control.Monad ( ap ) - -{- -************************************************************************ -* * -\subsection{Monad plumbing} -* * -************************************************************************ - -For the simplifier monad, we want to {\em thread} a unique supply and a counter. -(Command-line switches move around through the explicitly-passed SimplEnv.) --} - -newtype SimplM result - = SM { unSM :: SimplTopEnv -- Envt that does not change much - -> UniqSupply -- We thread the unique supply because - -- constantly splitting it is rather expensive - -> SimplCount - -> IO (result, UniqSupply, SimplCount)} - -- we only need IO here for dump output - deriving (Functor) - -data SimplTopEnv - = STE { st_flags :: DynFlags - , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run - , st_rules :: RuleEnv - , st_fams :: (FamInstEnv, FamInstEnv) } - -initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) - -> UniqSupply -- No init count; set to 0 - -> Int -- Size of the bindings, used to limit - -- the number of ticks we allow - -> SimplM a - -> IO (a, SimplCount) - -initSmpl dflags rules fam_envs us size m - = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) - return (result, count) - where - env = STE { st_flags = dflags, st_rules = rules - , st_max_ticks = computeMaxTicks dflags size - , st_fams = fam_envs } - -computeMaxTicks :: DynFlags -> Int -> IntWithInf --- Compute the max simplifier ticks as --- (base-size + pgm-size) * magic-multiplier * tick-factor/100 --- where --- magic-multiplier is a constant that gives reasonable results --- base-size is a constant to deal with size-zero programs -computeMaxTicks dflags size - = treatZeroAsInf $ - fromInteger ((toInteger (size + base_size) - * toInteger (tick_factor * magic_multiplier)) - `div` 100) - where - tick_factor = simplTickFactor dflags - base_size = 100 - magic_multiplier = 40 - -- MAGIC NUMBER, multiplies the simplTickFactor - -- We can afford to be generous; this is really - -- just checking for loops, and shouldn't usually fire - -- A figure of 20 was too small: see #5539. - -{-# INLINE thenSmpl #-} -{-# INLINE thenSmpl_ #-} -{-# INLINE returnSmpl #-} - - -instance Applicative SimplM where - pure = returnSmpl - (<*>) = ap - (*>) = thenSmpl_ - -instance Monad SimplM where - (>>) = (*>) - (>>=) = thenSmpl - -returnSmpl :: a -> SimplM a -returnSmpl e = SM (\_st_env us sc -> return (e, us, sc)) - -thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b -thenSmpl_ :: SimplM a -> SimplM b -> SimplM b - -thenSmpl m k - = SM $ \st_env us0 sc0 -> do - (m_result, us1, sc1) <- unSM m st_env us0 sc0 - unSM (k m_result) st_env us1 sc1 - -thenSmpl_ m k - = SM $ \st_env us0 sc0 -> do - (_, us1, sc1) <- unSM m st_env us0 sc0 - unSM k st_env us1 sc1 - --- TODO: this specializing is not allowed --- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} --- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} --- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} - -traceSmpl :: String -> SDoc -> SimplM () -traceSmpl herald doc - = do { dflags <- getDynFlags - ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" - (hang (text herald) 2 doc) } - -{- -************************************************************************ -* * -\subsection{The unique supply} -* * -************************************************************************ --} - -instance MonadUnique SimplM where - getUniqueSupplyM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (us1, us2, sc)) - - getUniqueM - = SM (\_st_env us sc -> case takeUniqFromSupply us of - (u, us') -> return (u, us', sc)) - - getUniquesM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (uniqsFromSupply us1, us2, sc)) - -instance HasDynFlags SimplM where - getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc)) - -instance MonadIO SimplM where - liftIO m = SM $ \_ us sc -> do - x <- m - return (x, us, sc) - -getSimplRules :: SimplM RuleEnv -getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) - -getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) -getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) - -newId :: FastString -> Type -> SimplM Id -newId fs ty = do uniq <- getUniqueM - return (mkSysLocalOrCoVar fs uniq ty) - -newJoinId :: [Var] -> Type -> SimplM Id -newJoinId bndrs body_ty - = do { uniq <- getUniqueM - ; let name = mkSystemVarName uniq (fsLit "$j") - join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] - arity = count isId bndrs - -- arity: See Note [Invariants on join points] invariant 2b, in CoreSyn - join_arity = length bndrs - details = JoinId join_arity - id_info = vanillaIdInfo `setArityInfo` arity --- `setOccInfo` strongLoopBreaker - - ; return (mkLocalVar details name join_id_ty id_info) } - -{- -************************************************************************ -* * -\subsection{Counting up what we've done} -* * -************************************************************************ --} - -getSimplCount :: SimplM SimplCount -getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) - -tick :: Tick -> SimplM () -tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) - -checkedTick :: Tick -> SimplM () --- Try to take a tick, but fail if too many -checkedTick t - = SM (\st_env us sc -> - if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) - then throwGhcExceptionIO $ - PprProgramError "Simplifier ticks exhausted" (msg sc) - else let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), us, sc')) - where - msg sc = vcat - [ text "When trying" <+> ppr t - , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)." - , space - , text "If you need to increase the limit substantially, please file a" - , text "bug report and indicate the factor you needed." - , space - , text "If GHC was unable to complete compilation even" - <+> text "with a very large factor" - , text "(a thousand or more), please consult the" - <+> doubleQuotes (text "Known bugs or infelicities") - , text "section in the Users Guide before filing a report. There are a" - , text "few situations unlikely to occur in practical programs for which" - , text "simplifier non-termination has been judged acceptable." - , space - , pp_details sc - , pprSimplCount sc ] - pp_details sc - | hasDetailedCounts sc = empty - | otherwise = text "To see detailed counts use -ddump-simpl-stats" - - -freeTick :: Tick -> SimplM () --- Record a tick, but don't add to the total tick count, which is --- used to decide when nothing further has happened -freeTick t - = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc - in sc' `seq` return ((), us, sc')) diff --git a/simplCore/SimplUtils.hs b/simplCore/SimplUtils.hs deleted file mode 100644 --- a/simplCore/SimplUtils.hs +++ /dev/null @@ -1,2435 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[SimplUtils]{The simplifier utilities} --} - -{-# LANGUAGE CPP #-} - -module SimplUtils ( - -- Rebuilding - mkLam, mkCase, prepareAlts, tryEtaExpandRhs, - - -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, - activeUnfolding, activeRule, - getUnfoldingInRuleMatch, - simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, - - -- The continuation type - SimplCont(..), DupFlag(..), StaticEnv, - isSimplified, contIsStop, - contIsDupable, contResultType, contHoleType, - contIsTrivial, contArgs, - countArgs, - mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, - - -- ArgInfo - ArgInfo(..), ArgSpec(..), mkArgInfo, - addValArgTo, addCastTo, addTyArgTo, - argInfoExpr, argInfoAppArgs, pushSimplifiedArgs, - isStrictArgInfo, lazyArgContext, - - abstractFloats, - - -- Utilities - isExitJoinId - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import SimplEnv -import CoreMonad ( SimplMode(..), Tick(..) ) -import DynFlags -import CoreSyn -import qualified CoreSubst -import PprCore -import TyCoPpr ( pprParendType ) -import CoreFVs -import CoreUtils -import CoreArity -import CoreUnfold -import Name -import Id -import IdInfo -import Var -import Demand -import SimplMonad -import Type hiding( substTy ) -import Coercion hiding( substCo ) -import DataCon ( dataConWorkId, isNullaryRepDataCon ) -import VarSet -import BasicTypes -import Util -import OrdList ( isNilOL ) -import MonadUtils -import Outputable -import Pair -import PrelRules -import FastString ( fsLit ) - -import Control.Monad ( when ) -import Data.List ( sortBy ) - -{- -************************************************************************ -* * - The SimplCont and DupFlag types -* * -************************************************************************ - -A SimplCont allows the simplifier to traverse the expression in a -zipper-like fashion. The SimplCont represents the rest of the expression, -"above" the point of interest. - -You can also think of a SimplCont as an "evaluation context", using -that term in the way it is used for operational semantics. This is the -way I usually think of it, For example you'll often see a syntax for -evaluation context looking like - C ::= [] | C e | case C of alts | C `cast` co -That's the kind of thing we are doing here, and I use that syntax in -the comments. - - -Key points: - * A SimplCont describes a *strict* context (just like - evaluation contexts do). E.g. Just [] is not a SimplCont - - * A SimplCont describes a context that *does not* bind - any variables. E.g. \x. [] is not a SimplCont --} - -data SimplCont - = Stop -- Stop[e] = e - OutType -- Type of the - CallCtxt -- Tells if there is something interesting about - -- the context, and hence the inliner - -- should be a bit keener (see interestingCallContext) - -- Specifically: - -- This is an argument of a function that has RULES - -- Inlining the call might allow the rule to fire - -- Never ValAppCxt (use ApplyToVal instead) - -- or CaseCtxt (use Select instead) - - | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] - OutCoercion -- The coercion simplified - -- Invariant: never an identity coercion - SimplCont - - | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_arg :: InExpr -- The argument, - , sc_env :: StaticEnv -- see Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] - { sc_arg_ty :: OutType -- Argument type - , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) - -- See Note [The hole type in ApplyToTy] - , sc_cont :: SimplCont } - - | Select -- (Select alts K)[e] = K[ case e of alts ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId -- case binder - , sc_alts :: [InAlt] -- Alternatives - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - -- The two strict forms have no DupFlag, because we never duplicate them - | StrictBind -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b] - -- or, equivalently, = K[ (\x xs.b) e ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId - , sc_bndrs :: [InBndr] - , sc_body :: InExpr - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] - { sc_dup :: DupFlag -- Always Simplified or OkToDup - , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc - -- plus demands and discount flags for *this* arg - -- and further args - -- So ai_dmds and ai_discs are never empty - , sc_cont :: SimplCont } - - | TickIt -- (TickIt t K)[e] = K[ tick t e ] - (Tickish Id) -- Tick tickish - SimplCont - -type StaticEnv = SimplEnv -- Just the static part is relevant - -data DupFlag = NoDup -- Unsimplified, might be big - | Simplified -- Simplified - | OkToDup -- Simplified and small - -isSimplified :: DupFlag -> Bool -isSimplified NoDup = False -isSimplified _ = True -- Invariant: the subst-env is empty - -perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type -perhapsSubstTy dup env ty - | isSimplified dup = ty - | otherwise = substTy env ty - -{- Note [StaticEnv invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pair up an InExpr or InAlts with a StaticEnv, which establishes the -lexical scope for that InExpr. When we simplify that InExpr/InAlts, we -use - - Its captured StaticEnv - - Overriding its InScopeSet with the larger one at the - simplification point. - -Why override the InScopeSet? Example: - (let y = ey in f) ex -By the time we simplify ex, 'y' will be in scope. - -However the InScopeSet in the StaticEnv is not irrelevant: it should -include all the free vars of applying the substitution to the InExpr. -Reason: contHoleType uses perhapsSubstTy to apply the substitution to -the expression, and that (rightly) gives ASSERT failures if the InScopeSet -isn't big enough. - -Note [DupFlag invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In both (ApplyToVal dup _ env k) - and (Select dup _ _ env k) -the following invariants hold - - (a) if dup = OkToDup, then continuation k is also ok-to-dup - (b) if dup = OkToDup or Simplified, the subst-env is empty - (and and hence no need to re-simplify) --} - -instance Outputable DupFlag where - ppr OkToDup = text "ok" - ppr NoDup = text "nodup" - ppr Simplified = text "simpl" - -instance Outputable SimplCont where - ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty - ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont - ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont - ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) - = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont - ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont }) - = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg) - $$ ppr cont - ppr (StrictBind { sc_bndr = b, sc_cont = cont }) - = (text "StrictBind" <+> ppr b) $$ ppr cont - ppr (StrictArg { sc_fun = ai, sc_cont = cont }) - = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont - ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = (text "Select" <+> ppr dup <+> ppr bndr) $$ - whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont - - -{- Note [The hole type in ApplyToTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_hole_ty field of ApplyToTy records the type of the "hole" in the -continuation. It is absolutely necessary to compute contHoleType, but it is -not used for anything else (and hence may not be evaluated). - -Why is it necessary for contHoleType? Consider the continuation - ApplyToType Int (Stop Int) -corresponding to - ( @Int) :: Int -What is the type of ? It could be (forall a. Int) or (forall a. a), -and there is no way to know which, so we must record it. - -In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType -for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably -doesn't matter because we'll never compute them all. - -************************************************************************ -* * - ArgInfo and ArgSpec -* * -************************************************************************ --} - -data ArgInfo - = ArgInfo { - ai_fun :: OutId, -- The function - ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) - - ai_type :: OutType, -- Type of (f a1 ... an) - - ai_rules :: FunRules, -- Rules for this function - - ai_encl :: Bool, -- Flag saying whether this function - -- or an enclosing one has rules (recursively) - -- True => be keener to inline in all args - - ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) - -- Usually infinite, but if it is finite it guarantees - -- that the function diverges after being given - -- that number of args - - ai_discs :: [Int] -- Discounts for remaining value arguments (beyong ai_args) - -- non-zero => be keener to inline - -- Always infinite - } - -data ArgSpec - = ValArg { as_dmd :: Demand -- Demand placed on this argument - , as_arg :: OutExpr } -- Apply to this (coercion or value); c.f. ApplyToVal - - | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy - , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) - - | CastBy OutCoercion -- Cast by this; c.f. CastIt - -instance Outputable ArgInfo where - ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds }) - = text "ArgInfo" <+> braces - (sep [ text "fun =" <+> ppr fun - , text "dmds =" <+> ppr dmds - , text "args =" <+> ppr args ]) - -instance Outputable ArgSpec where - ppr (ValArg { as_arg = e }) = text "ValArg" <+> ppr e - ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty - ppr (CastBy c) = text "CastBy" <+> ppr c - -addValArgTo :: ArgInfo -> OutExpr -> ArgInfo -addValArgTo ai arg - | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules, ai_type = ty } <- ai - -- Pop the top demand and and discounts off - , let arg_spec = ValArg { as_arg = arg - , as_dmd = dmd } - = ai { ai_args = arg_spec : ai_args ai - , ai_dmds = dmds - , ai_discs = discs - , ai_rules = decRules rules - , ai_type = applyTypeToArg ty arg - } - | otherwise - = pprPanic "addValArgTo" (ppr ai $$ ppr arg) - -- There should always be enough demands and discounts - -addTyArgTo :: ArgInfo -> OutType -> ArgInfo -addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai - , ai_type = piResultTy poly_fun_ty arg_ty - , ai_rules = decRules (ai_rules ai) } - where - poly_fun_ty = ai_type ai - arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty } - -addCastTo :: ArgInfo -> OutCoercion -> ArgInfo -addCastTo ai co = ai { ai_args = CastBy co : ai_args ai - , ai_type = pSnd (coercionKind co) } - -isStrictArgInfo :: ArgInfo -> Bool --- True if the function is strict in the next argument -isStrictArgInfo (ArgInfo { ai_dmds = dmds }) - | dmd:_ <- dmds = isStrictDmd dmd - | otherwise = False - -argInfoAppArgs :: [ArgSpec] -> [OutExpr] -argInfoAppArgs [] = [] -argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast -argInfoAppArgs (ValArg { as_arg = e } : as) = e : argInfoAppArgs as -argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as - -pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont -pushSimplifiedArgs _env [] k = k -pushSimplifiedArgs env (arg : args) k - = case arg of - TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } - -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } - ValArg { as_arg = e } -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest } - CastBy c -> CastIt c rest - where - rest = pushSimplifiedArgs env args k - -- The env has an empty SubstEnv - -argInfoExpr :: OutId -> [ArgSpec] -> OutExpr --- NB: the [ArgSpec] is reversed so that the first arg --- in the list is the last one in the application -argInfoExpr fun rev_args - = go rev_args - where - go [] = Var fun - go (ValArg { as_arg = a } : as) = go as `App` a - go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty - go (CastBy co : as) = mkCast (go as) co - - -type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function - -- Nothing => No rules - -- Just (n, rules) => some rules, requiring at least n more type/value args - -decRules :: FunRules -> FunRules -decRules (Just (n, rules)) = Just (n-1, rules) -decRules Nothing = Nothing - -mkFunRules :: [CoreRule] -> FunRules -mkFunRules [] = Nothing -mkFunRules rs = Just (n_required, rs) - where - n_required = maximum (map ruleArity rs) - -{- -************************************************************************ -* * - Functions on SimplCont -* * -************************************************************************ --} - -mkBoringStop :: OutType -> SimplCont -mkBoringStop ty = Stop ty BoringCtxt - -mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in CoreUnfold -mkRhsStop ty = Stop ty RhsCtxt - -mkLazyArgStop :: OutType -> CallCtxt -> SimplCont -mkLazyArgStop ty cci = Stop ty cci - -------------------- -contIsRhsOrArg :: SimplCont -> Bool -contIsRhsOrArg (Stop {}) = True -contIsRhsOrArg (StrictBind {}) = True -contIsRhsOrArg (StrictArg {}) = True -contIsRhsOrArg _ = False - -contIsRhs :: SimplCont -> Bool -contIsRhs (Stop _ RhsCtxt) = True -contIsRhs _ = False - -------------------- -contIsStop :: SimplCont -> Bool -contIsStop (Stop {}) = True -contIsStop _ = False - -contIsDupable :: SimplCont -> Bool -contIsDupable (Stop {}) = True -contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k -contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] -contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (CastIt _ k) = contIsDupable k -contIsDupable _ = False - -------------------- -contIsTrivial :: SimplCont -> Bool -contIsTrivial (Stop {}) = True -contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k -contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k -contIsTrivial (CastIt _ k) = contIsTrivial k -contIsTrivial _ = False - -------------------- -contResultType :: SimplCont -> OutType -contResultType (Stop ty _) = ty -contResultType (CastIt _ k) = contResultType k -contResultType (StrictBind { sc_cont = k }) = contResultType k -contResultType (StrictArg { sc_cont = k }) = contResultType k -contResultType (Select { sc_cont = k }) = contResultType k -contResultType (ApplyToTy { sc_cont = k }) = contResultType k -contResultType (ApplyToVal { sc_cont = k }) = contResultType k -contResultType (TickIt _ k) = contResultType k - -contHoleType :: SimplCont -> OutType -contHoleType (Stop ty _) = ty -contHoleType (TickIt _ k) = contHoleType k -contHoleType (CastIt co _) = pFst (coercionKind co) -contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) - = perhapsSubstTy dup se (idType b) -contHoleType (StrictArg { sc_fun = ai }) = funArgTy (ai_type ai) -contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] -contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k }) - = mkVisFunTy (perhapsSubstTy dup se (exprType e)) - (contHoleType k) -contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) - = perhapsSubstTy d se (idType b) - -------------------- -countArgs :: SimplCont -> Int --- Count all arguments, including types, coercions, and other values -countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont -countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont -countArgs _ = 0 - -contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) --- Summarises value args, discards type args and coercions --- The returned continuation of the call is only used to --- answer questions like "are you interesting?" -contArgs cont - | lone cont = (True, [], cont) - | otherwise = go [] cont - where - lone (ApplyToTy {}) = False -- See Note [Lone variables] in CoreUnfold - lone (ApplyToVal {}) = False -- NB: even a type application or cast - lone (CastIt {}) = False -- stops it being "lone" - lone _ = True - - go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (is_interesting arg se : args) k - go args (ApplyToTy { sc_cont = k }) = go args k - go args (CastIt _ k) = go args k - go args k = (False, reverse args, k) - - is_interesting arg se = interestingArg se arg - -- Do *not* use short-cutting substitution here - -- because we want to get as much IdInfo as possible - - -------------------- -mkArgInfo :: SimplEnv - -> Id - -> [CoreRule] -- Rules for function - -> Int -- Number of value args - -> SimplCont -- Context of the call - -> ArgInfo - -mkArgInfo env fun rules n_val_args call_cont - | n_val_args < idArity fun -- Note [Unsaturated functions] - = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty - , ai_rules = fun_rules - , ai_encl = False - , ai_dmds = vanilla_dmds - , ai_discs = vanilla_discounts } - | otherwise - = ArgInfo { ai_fun = fun - , ai_args = [] - , ai_type = fun_ty - , ai_rules = fun_rules - , ai_encl = interestingArgContext rules call_cont - , ai_dmds = add_type_strictness fun_ty arg_dmds - , ai_discs = arg_discounts } - where - fun_ty = idType fun - fun_rules = mkFunRules rules - - vanilla_discounts, arg_discounts :: [Int] - vanilla_discounts = repeat 0 - arg_discounts = case idUnfolding fun of - CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} - -> discounts ++ vanilla_discounts - _ -> vanilla_discounts - - vanilla_dmds, arg_dmds :: [Demand] - vanilla_dmds = repeat topDmd - - arg_dmds - | not (sm_inline (seMode env)) - = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] - | otherwise - = -- add_type_str fun_ty $ - case splitStrictSig (idStrictness fun) of - (demands, result_info) - | not (demands `lengthExceeds` n_val_args) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok - -- (see GHC.Core.Op.Simplify.Utils.analyseCont) - if isBotRes result_info then - demands -- Finite => result is bottom - else - demands ++ vanilla_dmds - | otherwise - -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) - <+> ppr n_val_args <+> ppr demands ) - vanilla_dmds -- Not enough args, or no strictness - - add_type_strictness :: Type -> [Demand] -> [Demand] - -- If the function arg types are strict, record that in the 'strictness bits' - -- No need to instantiate because unboxed types (which dominate the strict - -- types) can't instantiate type variables. - -- add_type_strictness is done repeatedly (for each call); - -- might be better once-for-all in the function - -- But beware primops/datacons with no strictness - - add_type_strictness fun_ty dmds - | null dmds = [] - - | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty - = add_type_strictness fun_ty' dmds -- Look through foralls - - | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info - , dmd : rest_dmds <- dmds - , let dmd' = case isLiftedType_maybe arg_ty of - Just False -> strictenDmd dmd - _ -> dmd - = dmd' : add_type_strictness fun_ty' rest_dmds - -- If the type is levity-polymorphic, we can't know whether it's - -- strict. isLiftedType_maybe will return Just False only when - -- we're sure the type is unlifted. - - | otherwise - = dmds - -{- Note [Unsaturated functions] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (test eyeball/inline4) - x = a:as - y = f x -where f has arity 2. Then we do not want to inline 'x', because -it'll just be floated out again. Even if f has lots of discounts -on its first argument -- it must be saturated for these to kick in - -Note [Do not expose strictness if sm_inline=False] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#15163 showed a case in which we had - - {-# INLINE [1] zip #-} - zip = undefined - - {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} - -If we expose zip's bottoming nature when simplifing the LHS of the -RULE we get - {-# RULES "foo" forall as bs. - stream (case zip of {}) = ..blah... #-} -discarding the arguments to zip. Usually this is fine, but on the -LHS of a rule it's not, because 'as' and 'bs' are now not bound on -the LHS. - -This is a pretty pathalogical example, so I'm not losing sleep over -it, but the simplest solution was to check sm_inline; if it is False, -which it is on the LHS of a rule (see updModeForRules), then don't -make use of the strictness info for the function. --} - - -{- -************************************************************************ -* * - Interesting arguments -* * -************************************************************************ - -Note [Interesting call context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to avoid inlining an expression where there can't possibly be -any gain, such as in an argument position. Hence, if the continuation -is interesting (eg. a case scrutinee, application etc.) then we -inline, otherwise we don't. - -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: - - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... - -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. - -Another example: - -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) - -.... case dMonadST _@_ x0 of (a,b,c) -> .... - -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just - - case x of y { DEFAULT -> ... } - -since we can just eliminate this case instead (x is in WHNF). Similar -applies when x is bound to a lambda expression. Hence -contIsInteresting looks for case expressions with just a single -default case. - -Note [No case of case is boring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see - case f x of - -we'd usually treat the context as interesting, to encourage 'f' to -inline. But if case-of-case is off, it's really not so interesting -after all, because we are unlikely to be able to push the case -expression into the branches of any case in f's unfolding. So, to -reduce unnecessary code expansion, we just make the context look boring. -This made a small compile-time perf improvement in perf/compiler/T6048, -and it looks plausible to me. --} - -lazyArgContext :: ArgInfo -> CallCtxt --- Use this for lazy arguments -lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting - -strictArgContext :: ArgInfo -> CallCtxt -strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) --- Use this for strict arguments - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = RhsCtxt - -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we - -- want to be a bit more eager to inline g, because it may - -- expose an eval (on x perhaps) that can be eliminated or - -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 - -- It's worth an 18% improvement in allocation for this - -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' - -interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt --- See Note [Interesting call context] -interestingCallContext env cont - = interesting cont - where - interesting (Select {}) - | sm_case_case (getMode env) = CaseCtxt - | otherwise = BoringCtxt - -- See Note [No case of case is boring] - - interesting (ApplyToVal {}) = ValAppCtxt - -- Can happen if we have (f Int |> co) y - -- If f has an INLINE prag we need to give it some - -- motivation to inline. See Note [Cast then apply] - -- in CoreUnfold - - interesting (StrictArg { sc_fun = fun }) = strictArgContext fun - interesting (StrictBind {}) = BoringCtxt - interesting (Stop _ cci) = cci - interesting (TickIt _ k) = interesting k - interesting (ApplyToTy { sc_cont = k }) = interesting k - interesting (CastIt _ k) = interesting k - -- If this call is the arg of a strict function, the context - -- is a bit interesting. If we inline here, we may get useful - -- evaluation information to avoid repeated evals: e.g. - -- x + (y * z) - -- Here the contIsInteresting makes the '*' keener to inline, - -- which in turn exposes a constructor which makes the '+' inline. - -- Assuming that +,* aren't small enough to inline regardless. - -- - -- It's also very important to inline in a strict context for things - -- like - -- foldr k z (f x) - -- Here, the context of (f x) is strict, and if f's unfolding is - -- a build it's *great* to inline it here. So we must ensure that - -- the context for (f x) is not totally uninteresting. - -interestingArgContext :: [CoreRule] -> SimplCont -> Bool --- If the argument has form (f x y), where x,y are boring, --- and f is marked INLINE, then we don't want to inline f. --- But if the context of the argument is --- g (f x y) --- where g has rules, then we *do* want to inline f, in case it --- exposes a rule that might fire. Similarly, if the context is --- h (g (f x x)) --- where h has rules, then we do want to inline f; hence the --- call_cont argument to interestingArgContext --- --- The ai-rules flag makes this happen; if it's --- set, the inliner gets just enough keener to inline f --- regardless of how boring f's arguments are, if it's marked INLINE --- --- The alternative would be to *always* inline an INLINE function, --- regardless of how boring its context is; but that seems overkill --- For example, it'd mean that wrapper functions were always inlined --- --- The call_cont passed to interestingArgContext is the context of --- the call itself, e.g. g in the example above -interestingArgContext rules call_cont - = notNull rules || enclosing_fn_has_rules - where - enclosing_fn_has_rules = go call_cont - - go (Select {}) = False - go (ApplyToVal {}) = False -- Shouldn't really happen - go (ApplyToTy {}) = False -- Ditto - go (StrictArg { sc_fun = fun }) = ai_encl fun - go (StrictBind {}) = False -- ?? - go (CastIt _ c) = go c - go (Stop _ RuleArgCtxt) = True - go (Stop _ _) = False - go (TickIt _ c) = go c - -{- Note [Interesting arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An argument is interesting if it deserves a discount for unfoldings -with a discount in that argument position. The idea is to avoid -unfolding a function that is applied only to variables that have no -unfolding (i.e. they are probably lambda bound): f x y z There is -little point in inlining f here. - -Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But -we must look through lets, eg (let x = e in C a b), because the let will -float, exposing the value, if we inline. That makes it different to -exprIsHNF. - -Before 2009 we said it was interesting if the argument had *any* structure -at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. - -But we don't regard (f x y) as interesting, unless f is unsaturated. -If it's saturated and f hasn't inlined, then it's probably not going -to now! - -Note [Conlike is interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f d = ...((*) d x y)... - ... f (df d')... -where df is con-like. Then we'd really like to inline 'f' so that the -rule for (*) (df d) can fire. To do this - a) we give a discount for being an argument of a class-op (eg (*) d) - b) we say that a con-like argument (eg (df d)) is interesting --} - -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary --- See Note [Interesting arguments] -interestingArg env e = go env 0 e - where - -- n is # value args to which the expression is applied - go env n (Var v) - = case substId env v of - DoneId v' -> go_var n v' - DoneEx e _ -> go (zapSubstEnv env) n e - ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e - - go _ _ (Lit {}) = ValueArg - go _ _ (Type _) = TrivArg - go _ _ (Coercion _) = TrivArg - go env n (App fn (Type _)) = go env n fn - go env n (App fn _) = go env (n+1) fn - go env n (Tick _ a) = go env n a - go env n (Cast e _) = go env n e - go env n (Lam v e) - | isTyVar v = go env n e - | n>0 = NonTrivArg -- (\x.b) e is NonTriv - | otherwise = ValueArg - go _ _ (Case {}) = NonTrivArg - go env n (Let b e) = case go env' n e of - ValueArg -> ValueArg - _ -> NonTrivArg - where - env' = env `addNewInScopeIds` bindersOf b - - go_var n v - | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that - -- data constructors here - | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding - | n > 0 = NonTrivArg -- Saturated or unknown call - | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding - -- See Note [Conlike is interesting] - | otherwise = TrivArg -- n==0, no useful unfolding - where - conlike_unfolding = isConLikeUnfolding (idUnfolding v) - -{- -************************************************************************ -* * - SimplMode -* * -************************************************************************ - -The SimplMode controls several switches; see its definition in -CoreMonad - sm_rules :: Bool -- Whether RULES are enabled - sm_inline :: Bool -- Whether inlining is enabled - sm_case_case :: Bool -- Whether case-of-case is enabled - sm_eta_expand :: Bool -- Whether eta-expansion is enabled --} - -simplEnvForGHCi :: DynFlags -> SimplEnv -simplEnvForGHCi dflags - = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_dflags = dflags - , sm_rules = rules_on - , sm_inline = False - , sm_eta_expand = eta_expand_on - , sm_case_case = True } - where - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - -- Do not do any inlining, in case we expose some unboxed - -- tuple stuff that confuses the bytecode interpreter - -updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode --- See Note [Simplifying inside stable unfoldings] -updModeForStableUnfoldings inline_rule_act current_mode - = current_mode { sm_phase = phaseFromActivation inline_rule_act - , sm_inline = True - , sm_eta_expand = False } - -- sm_eta_expand: see Note [No eta expansion in stable unfoldings] - -- For sm_rules, just inherit; sm_rules might be "off" - -- because of -fno-enable-rewrite-rules - where - phaseFromActivation (ActiveAfter _ n) = Phase n - phaseFromActivation _ = InitialPhase - -updModeForRules :: SimplMode -> SimplMode --- See Note [Simplifying rules] -updModeForRules current_mode - = current_mode { sm_phase = InitialPhase - , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False] - , sm_rules = False - , sm_eta_expand = False } - -{- Note [Simplifying rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying a rule LHS, refrain from /any/ inlining or applying -of other RULES. - -Doing anything to the LHS is plain confusing, because it means that what the -rule matches is not what the user wrote. c.f. #10595, and #10528. -Moreover, inlining (or applying rules) on rule LHSs risks introducing -Ticks into the LHS, which makes matching trickier. #10665, #10745. - -Doing this to either side confounds tools like HERMIT, which seek to reason -about and apply the RULES as originally written. See #10829. - -There is, however, one case where we are pretty much /forced/ to transform the -LHS of a rule: postInlineUnconditionally. For instance, in the case of - - let f = g @Int in f - -We very much want to inline f into the body of the let. However, to do so (and -be able to safely drop f's binding) we must inline into all occurrences of f, -including those in the LHS of rules. - -This can cause somewhat surprising results; for instance, in #18162 we found -that a rule template contained ticks in its arguments, because -postInlineUnconditionally substituted in a trivial expression that contains -ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for -details. - -Note [No eta expansion in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a stable unfolding - - f :: Ord a => a -> IO () - -- Unfolding template - -- = /\a \(d:Ord a) (x:a). bla - -we do not want to eta-expand to - - f :: Ord a => a -> IO () - -- Unfolding template - -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co - -because not specialisation of the overloading doesn't work properly -(see Note [Specialisation shape] in Specialise), #9509. - -So we disable eta-expansion in stable unfoldings. - -Note [Inlining in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Something is inlined if - (i) the sm_inline flag is on, AND - (ii) the thing has an INLINE pragma, AND - (iii) the thing is inlinable in the earliest phase. - -Example of why (iii) is important: - {-# INLINE [~1] g #-} - g = ... - - {-# INLINE f #-} - f x = g (g x) - -If we were to inline g into f's inlining, then an importing module would -never be able to do - f e --> g (g e) ---> RULE fires -because the stable unfolding for f has had g inlined into it. - -On the other hand, it is bad not to do ANY inlining into an -stable unfolding, because then recursive knots in instance declarations -don't get unravelled. - -However, *sometimes* SimplGently must do no call-site inlining at all -(hence sm_inline = False). Before full laziness we must be careful -not to inline wrappers, because doing so 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. - -The no-inlining thing is also important for Template Haskell. You might be -compiling in one-shot mode with -O2; but when TH compiles a splice before -running it, we don't want to use -O2. Indeed, we don't want to inline -anything, because the byte-code interpreter might get confused about -unboxed tuples and suchlike. - -Note [Simplifying inside stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must take care with simplification inside stable unfoldings (which come from -INLINE pragmas). - -First, consider the following example - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... -Now, if that's the ONLY occurrence of f, it might be inlined inside g, -and thence copied multiple times when g is inlined. HENCE we treat -any occurrence in a stable unfolding as a multiple occurrence, not a single -one; see OccurAnal.addRuleUsage. - -Second, we do want *do* to some modest rules/inlining stuff in stable -unfoldings, partly to eliminate senseless crap, and partly to break -the recursive knots generated by instance declarations. - -However, suppose we have - {-# INLINE f #-} - f = -meaning "inline f in phases p where activation (p) holds". -Then what inlinings/rules can we apply to the copy of captured in -f's stable unfolding? Our model is that literally is substituted for -f when it is inlined. So our conservative plan (implemented by -updModeForStableUnfoldings) is this: - - ------------------------------------------------------------- - When simplifying the RHS of a stable unfolding, set the phase - to the phase in which the stable unfolding first becomes active - ------------------------------------------------------------- - -That ensures that - - a) Rules/inlinings that *cease* being active before p will - not apply to the stable unfolding, consistent with it being - inlined in its *original* form in phase p. - - b) Rules/inlinings that only become active *after* p will - not apply to the stable unfolding, again to be consistent with - inlining the *original* rhs in phase p. - -For example, - {-# INLINE f #-} - f x = ...g... - - {-# NOINLINE [1] g #-} - g y = ... - - {-# RULE h g = ... #-} -Here we must not inline g into f's RHS, even when we get to phase 0, -because when f is later inlined into some other module we want the -rule for h to fire. - -Similarly, consider - {-# INLINE f #-} - f x = ...g... - - g y = ... -and suppose that there are auto-generated specialisations and a strictness -wrapper for g. The specialisations get activation AlwaysActive, and the -strictness wrapper get activation (ActiveAfter 0). So the strictness -wrepper fails the test and won't be inlined into f's stable unfolding. That -means f can inline, expose the specialised call to g, so the specialisation -rules can fire. - -A note about wrappers -~~~~~~~~~~~~~~~~~~~~~ -It's also important not to inline a worker back into a wrapper. -A wrapper looks like - wraper = inline_me (\x -> ...worker... ) -Normally, the inline_me prevents the worker getting inlined into -the wrapper (initially, the worker's only call site!). But, -if the wrapper is sure to be called, the strictness analyser will -mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -continuation. --} - -activeUnfolding :: SimplMode -> Id -> Bool -activeUnfolding mode id - | isCompulsoryUnfolding (realIdUnfolding id) - = True -- Even sm_inline can't override compulsory unfoldings - | otherwise - = isActive (sm_phase mode) (idInlineActivation id) - && sm_inline mode - -- `or` isStableUnfolding (realIdUnfolding id) - -- Inline things when - -- (a) they are active - -- (b) sm_inline says so, except that for stable unfoldings - -- (ie pragmas) we inline anyway - -getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv --- When matching in RULE, we want to "look through" an unfolding --- (to see a constructor) if *rules* are on, even if *inlinings* --- are not. A notable example is DFuns, which really we want to --- match in rules like (op dfun) in gentle mode. Another example --- is 'otherwise' which we want exprIsConApp_maybe to be able to --- see very early on -getUnfoldingInRuleMatch env - = (in_scope, id_unf) - where - in_scope = seInScope env - mode = getMode env - id_unf id | unf_is_active id = idUnfolding id - | otherwise = NoUnfolding - unf_is_active id - | not (sm_rules mode) = -- active_unfolding_minimal id - isStableUnfolding (realIdUnfolding id) - -- Do we even need to test this? I think this InScopeEnv - -- is only consulted if activeRule returns True, which - -- never happens if sm_rules is False - | otherwise = isActive (sm_phase mode) (idInlineActivation id) - ----------------------- -activeRule :: SimplMode -> Activation -> Bool --- Nothing => No rules at all -activeRule mode - | not (sm_rules mode) = \_ -> False -- Rewriting is off - | otherwise = isActive (sm_phase mode) - -{- -************************************************************************ -* * - preInlineUnconditionally -* * -************************************************************************ - -preInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~ -@preInlineUnconditionally@ examines a bndr to see if it is used just -once in a completely safe way, so that it is safe to discard the -binding inline its RHS at the (unique) usage site, REGARDLESS of how -big the RHS might be. If this is the case we don't simplify the RHS -first, but just inline it un-simplified. - -This is much better than first simplifying a perhaps-huge RHS and then -inlining and re-simplifying it. Indeed, it can be at least quadratically -better. Consider - - x1 = e1 - x2 = e2[x1] - x3 = e3[x2] - ...etc... - xN = eN[xN-1] - -We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. -This can happen with cascades of functions too: - - f1 = \x1.e1 - f2 = \xs.e2[f1] - f3 = \xs.e3[f3] - ...etc... - -THE MAIN INVARIANT is this: - - ---- preInlineUnconditionally invariant ----- - IF preInlineUnconditionally chooses to inline x = - THEN doing the inlining should not change the occurrence - info for the free vars of - ---------------------------------------------- - -For example, it's tempting to look at trivial binding like - x = y -and inline it unconditionally. But suppose x is used many times, -but this is the unique occurrence of y. Then inlining x would change -y's occurrence info, which breaks the invariant. It matters: y -might have a BIG rhs, which will now be dup'd at every occurrenc of x. - - -Even RHSs labelled InlineMe aren't caught here, because there might be -no benefit from inlining at the call site. - -[Sept 01] Don't unconditionally inline a top-level thing, because that -can simply make a static thing into something built dynamically. E.g. - x = (a,b) - main = \s -> h x - -[Remember that we treat \s as a one-shot lambda.] No point in -inlining x unless there is something interesting about the call site. - -But watch out: if you aren't careful, some useful foldr/build fusion -can be lost (most notably in spectral/hartel/parstof) because the -foldr didn't see the build. Doing the dynamic allocation isn't a big -deal, in fact, but losing the fusion can be. But the right thing here -seems to be to do a callSiteInline based on the fact that there is -something interesting about the call site (it's strict). Hmm. That -seems a bit fragile. - -Conclusion: inline top level things gaily until Phase 0 (the last -phase), at which point don't. - -Note [pre/postInlineUnconditionally in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in gentle mode we want to do preInlineUnconditionally. The -reason is that too little clean-up happens if you don't inline -use-once things. Also a bit of inlining is *good* for full laziness; -it can expose constant sub-expressions. Example in -spectral/mandel/Mandel.hs, where the mandelset function gets a useful -let-float if you inline windowToViewport - -However, as usual for Gentle mode, do not inline things that are -inactive in the initial stages. See Note [Gentle mode]. - -Note [Stable unfoldings and preInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! -Example - - {-# INLINE f #-} - f :: Eq a => a -> a - f x = ... - - fInt :: Int -> Int - fInt = f Int dEqInt - - ...fInt...fInt...fInt... - -Here f occurs just once, in the RHS of fInt. But if we inline it there -it might make fInt look big, and we'll lose the opportunity to inline f -at each of fInt's call sites. The INLINE pragma will only inline when -the application is saturated for exactly this reason; and we don't -want PreInlineUnconditionally to second-guess it. A live example is -#3736. - c.f. Note [Stable unfoldings and postInlineUnconditionally] - -NB: if the pragma is INLINEABLE, then we don't want to behave in -this special way -- an INLINEABLE pragma just says to GHC "inline this -if you like". But if there is a unique occurrence, we want to inline -the stable unfolding, not the RHS. - -Note [Top-level bottoming Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't inline top-level Ids that are bottoming, even if they are used just -once, because FloatOut has gone to some trouble to extract them out. -Inlining them won't make the program run faster! - -Note [Do not inline CoVars unconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Coercion variables appear inside coercions, and the RHS of a let-binding -is a term (not a coercion) so we can't necessarily inline the latter in -the former. --} - -preInlineUnconditionally - :: SimplEnv -> TopLevelFlag -> InId - -> InExpr -> StaticEnv -- These two go together - -> Maybe SimplEnv -- Returned env has extended substitution --- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn --- Reason: we don't want to inline single uses, or discard dead bindings, --- for unlifted, side-effect-ful bindings -preInlineUnconditionally env top_lvl bndr rhs rhs_env - | not pre_inline_unconditionally = Nothing - | not active = Nothing - | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids] - | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] - | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] - -- in module Exitify - | not (one_occ (idOccInfo bndr)) = Nothing - | not (isStableUnfolding unf) = Just (extend_subst_with rhs) - - -- Note [Stable unfoldings and preInlineUnconditionally] - | isInlinablePragma inline_prag - , Just inl <- maybeUnfoldingTemplate unf = Just (extend_subst_with inl) - | otherwise = Nothing - where - unf = idUnfolding bndr - extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) - - one_occ IAmDead = True -- Happens in ((\x.1) v) - one_occ (OneOcc { occ_n_br = 1 -- One textual occurrence - , occ_in_lam = in_lam - , occ_int_cxt = int_cxt }) - | not in_lam = isNotTopLevel top_lvl || early_phase - | otherwise = int_cxt && canInlineInLam rhs - one_occ _ = False - - pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env) - mode = getMode env - active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag) - -- See Note [pre/postInlineUnconditionally in gentle mode] - inline_prag = idInlinePragma bndr - --- Be very careful before inlining inside a lambda, because (a) we must not --- invalidate occurrence information, and (b) we want to avoid pushing a --- single allocation (here) into multiple allocations (inside lambda). --- Inlining a *function* with a single *saturated* call would be ok, mind you. --- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) --- where --- is_cheap = exprIsCheap rhs --- ok = is_cheap && int_cxt - - -- int_cxt The context isn't totally boring - -- E.g. let f = \ab.BIG in \y. map f xs - -- Don't want to substitute for f, because then we allocate - -- its closure every time the \y is called - -- But: let f = \ab.BIG in \y. map (f y) xs - -- Now we do want to substitute for f, even though it's not - -- saturated, because we're going to allocate a closure for - -- (f y) every time round the loop anyhow. - - -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, - -- so substituting rhs inside a lambda doesn't change the occ info. - -- Sadly, not quite the same as exprIsHNF. - canInlineInLam (Lit _) = True - canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e - canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e - canInlineInLam _ = False - -- not ticks. Counting ticks cannot be duplicated, and non-counting - -- ticks around a Lam will disappear anyway. - - early_phase = case sm_phase mode of - Phase 0 -> False - _ -> True --- If we don't have this early_phase test, consider --- x = length [1,2,3] --- The full laziness pass carefully floats all the cons cells to --- top level, and preInlineUnconditionally floats them all back in. --- Result is (a) static allocation replaced by dynamic allocation --- (b) many simplifier iterations because this tickles --- a related problem; only one inlining per pass --- --- On the other hand, I have seen cases where top-level fusion is --- lost if we don't inline top level thing (e.g. string constants) --- Hence the test for phase zero (which is the phase for all the final --- simplifications). Until phase zero we take no special notice of --- top level things, but then we become more leery about inlining --- them. - -{- -************************************************************************ -* * - postInlineUnconditionally -* * -************************************************************************ - -postInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~~ -@postInlineUnconditionally@ decides whether to unconditionally inline -a thing based on the form of its RHS; in particular if it has a -trivial RHS. If so, we can inline and discard the binding altogether. - -NB: a loop breaker has must_keep_binding = True and non-loop-breakers -only have *forward* references. Hence, it's safe to discard the binding - -NOTE: This isn't our last opportunity to inline. We're at the binding -site right now, and we'll get another opportunity when we get to the -occurrence(s) - -Note that we do this unconditional inlining only for trival RHSs. -Don't inline even WHNFs inside lambdas; doing so may simply increase -allocation when the function is called. This isn't the last chance; see -NOTE above. - -NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? -Because we don't even want to inline them into the RHS of constructor -arguments. See NOTE above - -NB: At one time even NOINLINE was ignored here: if the rhs is trivial -it's best to inline it anyway. We often get a=E; b=a from desugaring, -with both a and b marked NOINLINE. But that seems incompatible with -our new view that inlining is like a RULE, so I'm sticking to the 'active' -story for now. - -NB: unconditional inlining of this sort can introduce ticks in places that -may seem surprising; for instance, the LHS of rules. See Note [Simplfying -rules] for details. --} - -postInlineUnconditionally - :: SimplEnv -> TopLevelFlag - -> OutId -- The binder (*not* a CoVar), including its unfolding - -> OccInfo -- From the InId - -> OutExpr - -> Bool --- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn --- Reason: we don't want to inline single uses, or discard dead bindings, --- for unlifted, side-effect-ful bindings -postInlineUnconditionally env top_lvl bndr occ_info rhs - | not active = False - | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline - -- because it might be referred to "earlier" - | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] - | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] - | exprIsTrivial rhs = True - | otherwise - = case occ_info of - OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br } - -- See Note [Inline small things to avoid creating a thunk] - - -> n_br < 100 -- See Note [Suppress exponential blowup] - - && smallEnoughToInline dflags unfolding -- Small enough to dup - -- ToDo: consider discount on smallEnoughToInline if int_cxt is true - -- - -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1 - -- Reason: doing so risks exponential behaviour. We simplify a big - -- expression, inline it, and simplify it again. But if the - -- very same thing happens in the big expression, we get - -- exponential cost! - -- PRINCIPLE: when we've already simplified an expression once, - -- make sure that we only inline it if it's reasonably small. - - && (not in_lam || - -- Outside a lambda, we want to be reasonably aggressive - -- about inlining into multiple branches of case - -- e.g. let x = - -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } - -- Inlining can be a big win if C3 is the hot-spot, even if - -- the uses in C1, C2 are not 'interesting' - -- An example that gets worse if you add int_cxt here is 'clausify' - - (isCheapUnfolding unfolding && int_cxt)) - -- isCheap => acceptable work duplication; in_lam may be true - -- int_cxt to prevent us inlining inside a lambda without some - -- good reason. See the notes on int_cxt in preInlineUnconditionally - - IAmDead -> True -- This happens; for example, the case_bndr during case of - -- known constructor: case (a,b) of x { (p,q) -> ... } - -- Here x isn't mentioned in the RHS, so we don't want to - -- create the (dead) let-binding let x = (a,b) in ... - - _ -> False - --- Here's an example that we don't handle well: --- let f = if b then Left (\x.BIG) else Right (\y.BIG) --- in \y. ....case f of {...} .... --- Here f is used just once, and duplicating the case work is fine (exprIsCheap). --- But --- - We can't preInlineUnconditionally because that woud invalidate --- the occ info for b. --- - We can't postInlineUnconditionally because the RHS is big, and --- that risks exponential behaviour --- - We can't call-site inline, because the rhs is big --- Alas! - - where - unfolding = idUnfolding bndr - dflags = seDynFlags env - active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) - -- See Note [pre/postInlineUnconditionally in gentle mode] - -{- Note [Inline small things to avoid creating a thunk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The point of examining occ_info here is that for *non-values* that -occur outside a lambda, the call-site inliner won't have a chance -(because it doesn't know that the thing only occurs once). The -pre-inliner won't have gotten it either, if the thing occurs in more -than one branch So the main target is things like - - let x = f y in - case v of - True -> case x of ... - False -> case x of ... - -This is very important in practice; e.g. wheel-seive1 doubles -in allocation if you miss this out. And bits of GHC itself start -to allocate more. An egregious example is test perf/compiler/T14697, -where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more. - -Note [Suppress exponential blowup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #13253, and several related tickets, we got an exponential blowup -in code size from postInlineUnconditionally. The trouble comes when -we have - let j1a = case f y of { True -> p; False -> q } - j1b = case f y of { True -> q; False -> p } - j2a = case f (y+1) of { True -> j1a; False -> j1b } - j2b = case f (y+1) of { True -> j1b; False -> j1a } - ... - in case f (y+10) of { True -> j10a; False -> j10b } - -when there are many branches. In pass 1, postInlineUnconditionally -inlines j10a and j10b (they are both small). Now we have two calls -to j9a and two to j9b. In pass 2, postInlineUnconditionally inlines -all four of these calls, leaving four calls to j8a and j8b. Etc. -Yikes! This is exponential! - -A possible plan: stop doing postInlineUnconditionally -for some fixed, smallish number of branches, say 4. But that turned -out to be bad: see Note [Inline small things to avoid creating a thunk]. -And, as it happened, the problem with #13253 was solved in a -different way (Note [Duplicating StrictArg] in Simplify). - -So I just set an arbitrary, high limit of 100, to stop any -totally exponential behaviour. - -This still leaves the nasty possiblity that /ordinary/ inlining (not -postInlineUnconditionally) might inline these join points, each of -which is individually quiet small. I'm still not sure what to do -about this (e.g. see #15488). - -Note [Top level and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do postInlineUnconditionally for top-level things (even for -ones that are trivial): - - * Doing so will inline top-level error expressions that have been - carefully floated out by FloatOut. More generally, it might - replace static allocation with dynamic. - - * Even for trivial expressions there's a problem. Consider - {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} - blah xs = reverse xs - ruggle = sort - In one simplifier pass we might fire the rule, getting - blah xs = ruggle xs - but in *that* simplifier pass we must not do postInlineUnconditionally - on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' - - If the rhs is trivial it'll be inlined by callSiteInline, and then - the binding will be dead and discarded by the next use of OccurAnal - - * There is less point, because the main goal is to get rid of local - bindings used in multiple case branches. - - * The inliner should inline trivial things at call sites anyway. - - * The Id might be exported. We could check for that separately, - but since we aren't going to postInlineUnconditionally /any/ - top-level bindings, we don't need to test. - -Note [Stable unfoldings and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not do postInlineUnconditionally if the Id has a stable unfolding, -otherwise we lose the unfolding. Example - - -- f has stable unfolding with rhs (e |> co) - -- where 'e' is big - f = e |> co - -Then there's a danger we'll optimise to - - f' = e - f = f' |> co - -and now postInlineUnconditionally, losing the stable unfolding on f. Now f' -won't inline because 'e' is too big. - - c.f. Note [Stable unfoldings and preInlineUnconditionally] - - -************************************************************************ -* * - Rebuilding a lambda -* * -************************************************************************ --} - -mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr --- mkLam tries three things --- a) eta reduction, if that gives a trivial expression --- b) eta expansion [only if there are some value lambdas] - -mkLam _env [] body _cont - = return body -mkLam env bndrs body cont - = do { dflags <- getDynFlags - ; mkLam' dflags bndrs body } - where - mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr - mkLam' dflags bndrs (Cast body co) - | not (any bad bndrs) - -- Note [Casts and lambdas] - = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos Representational bndrs co)) } - where - co_vars = tyCoVarsOfCo co - bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars - - mkLam' dflags bndrs body@(Lam {}) - = mkLam' dflags (bndrs ++ bndrs1) body1 - where - (bndrs1, body1) = collectBinders body - - mkLam' dflags bndrs (Tick t expr) - | tickishFloatable t - = mkTick t <$> mkLam' dflags bndrs expr - - mkLam' dflags bndrs body - | gopt Opt_DoEtaReduction dflags - , Just etad_lam <- tryEtaReduce bndrs body - = do { tick (EtaReduction (head bndrs)) - ; return etad_lam } - - | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] - , sm_eta_expand (getMode env) - , any isRuntimeVar bndrs - , let body_arity = exprEtaExpandArity dflags body - , body_arity > 0 - = do { tick (EtaExpansion (head bndrs)) - ; let res = mkLams bndrs (etaExpand body_arity body) - ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) - , text "after" <+> ppr res]) - ; return res } - - | otherwise - = return (mkLams bndrs body) - -{- -Note [Eta expanding lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *do* want to eta-expand lambdas. Consider - f (\x -> case x of (a,b) -> \s -> blah) -where 's' is a state token, and hence can be eta expanded. This -showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather -important function! - -The eta-expansion will never happen unless we do it now. (Well, it's -possible that CorePrep will do it, but CorePrep only has a half-baked -eta-expander that can't deal with casts. So it's much better to do it -here.) - -However, when the lambda is let-bound, as the RHS of a let, we have a -better eta-expander (in the form of tryEtaExpandRhs), so we don't -bother to try expansion in mkLam in that case; hence the contIsRhs -guard. - -NB: We check the SimplEnv (sm_eta_expand), not DynFlags. - See Note [No eta expansion in stable unfoldings] - -Note [Casts and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\x. (\y. e) `cast` g1) `cast` g2 -There is a danger here that the two lambdas look separated, and the -full laziness pass might float an expression to between the two. - -So this equation in mkLam' floats the g1 out, thus: - (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) -where x:tx. - -In general, this floats casts outside lambdas, where (I hope) they -might meet and cancel with some other cast: - \x. e `cast` co ===> (\x. e) `cast` (tx -> co) - /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) - /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) - (if not (g `in` co)) - -Notice that it works regardless of 'e'. Originally it worked only -if 'e' was itself a lambda, but in some cases that resulted in -fruitless iteration in the simplifier. A good example was when -compiling Text.ParserCombinators.ReadPrec, where we had a definition -like (\x. Get `cast` g) -where Get is a constructor with nonzero arity. Then mkLam eta-expanded -the Get, and the next iteration eta-reduced it, and then eta-expanded -it again. - -Note also the side condition for the case of coercion binders. -It does not make sense to transform - /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) -because the latter is not well-kinded. - -************************************************************************ -* * - Eta expansion -* * -************************************************************************ --} - -tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr - -> SimplM (Arity, Bool, OutExpr) --- See Note [Eta-expanding at let bindings] --- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then --- (a) rhs' has manifest arity n --- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom -tryEtaExpandRhs mode bndr rhs - | Just join_arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs - ; return (count isId join_bndrs, exprIsBottom join_body, rhs) } - -- Note [Do not eta-expand join points] - -- But do return the correct arity and bottom-ness, because - -- these are used to set the bndr's IdInfo (#15517) - -- Note [Invariants on join points] invariant 2b, in CoreSyn - - | otherwise - = do { (new_arity, is_bot, new_rhs) <- try_expand - - ; WARN( new_arity < old_id_arity, - (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity - <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) - -- Note [Arity decrease] in Simplify - return (new_arity, is_bot, new_rhs) } - where - try_expand - | exprIsTrivial rhs - = return (exprArity rhs, False, rhs) - - | sm_eta_expand mode -- Provided eta-expansion is on - , new_arity > old_arity -- And the current manifest arity isn't enough - = do { tick (EtaExpansion bndr) - ; return (new_arity, is_bot, etaExpand new_arity rhs) } - - | otherwise - = return (old_arity, is_bot && new_arity == old_arity, rhs) - - dflags = sm_dflags mode - old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs] - old_id_arity = idArity bndr - - (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity - new_arity2 = idCallArity bndr - new_arity = max new_arity1 new_arity2 - -{- -Note [Eta-expanding at let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We now eta expand at let-bindings, which is where the payoff comes. -The most significant thing is that we can do a simple arity analysis -(in CoreArity.findRhsArity), which we can't do for free-floating lambdas - -One useful consequence of not eta-expanding lambdas is this example: - genMap :: C a => ... - {-# INLINE genMap #-} - genMap f xs = ... - - myMap :: D a => ... - {-# INLINE myMap #-} - myMap = genMap - -Notice that 'genMap' should only inline if applied to two arguments. -In the stable unfolding for myMap we'll have the unfolding - (\d -> genMap Int (..d..)) -We do not want to eta-expand to - (\d f xs -> genMap Int (..d..) f xs) -because then 'genMap' will inline, and it really shouldn't: at least -as far as the programmer is concerned, it's not applied to two -arguments! - -Note [Do not eta-expand join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point -stands well to gain from its outer binding's eta-expansion, and eta-expanding a -join point is fraught with issues like how to deal with a cast: - - let join $j1 :: IO () - $j1 = ... - $j2 :: Int -> IO () - $j2 n = if n > 0 then $j1 - else ... - - => - - let join $j1 :: IO () - $j1 = (\eta -> ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - $j2 :: Int -> IO () - $j2 n = (\eta -> if n > 0 then $j1 - else ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - -The cast here can't be pushed inside the lambda (since it's not casting to a -function type), so the lambda has to stay, but it can't because it contains a -reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather -than try and detect this situation (and whatever other situations crop up!), we -don't bother; again, any surrounding eta-expansion will improve these join -points anyway, since an outer cast can *always* be pushed inside. By the time -CorePrep comes around, the code is very likely to look more like this: - - let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) - $j1 = (...) eta - $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) - $j2 = if n > 0 then $j1 - else (...) eta - -Note [Do not eta-expand PAPs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have old_arity = manifestArity rhs, which meant that we -would eta-expand even PAPs. But this gives no particular advantage, -and can lead to a massive blow-up in code size, exhibited by #9020. -Suppose we have a PAP - foo :: IO () - foo = returnIO () -Then we can eta-expand do - foo = (\eta. (returnIO () |> sym g) eta) |> g -where - g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) - -But there is really no point in doing this, and it generates masses of -coercions and whatnot that eventually disappear again. For T9020, GHC -allocated 6.6G beore, and 0.8G afterwards; and residency dropped from -1.8G to 45M. - -But note that this won't eta-expand, say - f = \g -> map g -Does it matter not eta-expanding such functions? I'm not sure. Perhaps -strictness analysis will have less to bite on? - - -************************************************************************ -* * -\subsection{Floating lets out of big lambdas} -* * -************************************************************************ - -Note [Floating and type abstraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - x = /\a. C e1 e2 -We'd like to float this to - y1 = /\a. e1 - y2 = /\a. e2 - x = /\a. C (y1 a) (y2 a) -for the usual reasons: we want to inline x rather vigorously. - -You may think that this kind of thing is rare. But in some programs it is -common. For example, if you do closure conversion you might get: - - data a :-> b = forall e. (e -> a -> b) :$ e - - f_cc :: forall a. a :-> a - f_cc = /\a. (\e. id a) :$ () - -Now we really want to inline that f_cc thing so that the -construction of the closure goes away. - -So I have elaborated simplLazyBind to understand right-hand sides that look -like - /\ a1..an. body - -and treat them specially. The real work is done in SimplUtils.abstractFloats, -but there is quite a bit of plumbing in simplLazyBind as well. - -The same transformation is good when there are lets in the body: - - /\abc -> let(rec) x = e in b - ==> - let(rec) x' = /\abc -> let x = x' a b c in e - in - /\abc -> let x = x' a b c in b - -This is good because it can turn things like: - - let f = /\a -> letrec g = ... g ... in g -into - letrec g' = /\a -> ... g' a ... - in - let f = /\ a -> g' a - -which is better. In effect, it means that big lambdas don't impede -let-floating. - -This optimisation is CRUCIAL in eliminating the junk introduced by -desugaring mutually recursive definitions. Don't eliminate it lightly! - -[May 1999] If we do this transformation *regardless* then we can -end up with some pretty silly stuff. For example, - - let - st = /\ s -> let { x1=r1 ; x2=r2 } in ... - in .. -becomes - let y1 = /\s -> r1 - y2 = /\s -> r2 - st = /\s -> ...[y1 s/x1, y2 s/x2] - in .. - -Unless the "..." is a WHNF there is really no point in doing this. -Indeed it can make things worse. Suppose x1 is used strictly, -and is of the form - - x1* = case f y of { (a,b) -> e } - -If we abstract this wrt the tyvar we then can't do the case inline -as we would normally do. - -That's why the whole transformation is part of the same process that -floats let-bindings and constructor arguments out of RHSs. In particular, -it is guarded by the doFloatFromRhs call in simplLazyBind. - -Note [Which type variables to abstract over] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Abstract only over the type variables free in the rhs wrt which the -new binding is abstracted. Note that - - * The naive approach of abstracting wrt the - tyvars free in the Id's /type/ fails. Consider: - /\ a b -> let t :: (a,b) = (e1, e2) - x :: a = fst t - in ... - Here, b isn't free in x's type, but we must nevertheless - abstract wrt b as well, because t's type mentions b. - Since t is floated too, we'd end up with the bogus: - poly_t = /\ a b -> (e1, e2) - poly_x = /\ a -> fst (poly_t a *b*) - - * We must do closeOverKinds. Example (#10934): - f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... - Here we want to float 't', but we must remember to abstract over - 'k' as well, even though it is not explicitly mentioned in the RHS, - otherwise we get - t = /\ (f:k->*) (a:k). AccFailure @ (f a) - which is obviously bogus. --} - -abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats - -> OutExpr -> SimplM ([OutBind], OutExpr) -abstractFloats dflags top_lvl main_tvs floats body - = ASSERT( notNull body_floats ) - ASSERT( isNilOL (sfJoinFloats floats) ) - do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats - ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) } - where - is_top_lvl = isTopLevel top_lvl - main_tv_set = mkVarSet main_tvs - body_floats = letFloatBinds (sfLetFloats floats) - empty_subst = CoreSubst.mkEmptySubst (sfInScope floats) - - abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind) - abstract subst (NonRec id rhs) - = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id - ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' - subst' = CoreSubst.extendIdSubst subst id poly_app - ; return (subst', NonRec poly_id2 poly_rhs) } - where - rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs - - -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = scopedSort $ - filter (`elemVarSet` main_tv_set) $ - closeOverKindsList $ - exprSomeFreeVarsList isTyVar rhs' - - abstract subst (Rec prs) - = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids - ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps) - poly_pairs = [ mk_poly2 poly_id tvs_here rhs' - | (poly_id, rhs) <- poly_ids `zip` rhss - , let rhs' = CoreSubst.substExpr (text "abstract_floats") - subst' rhs ] - ; return (subst', Rec poly_pairs) } - where - (ids,rhss) = unzip prs - -- For a recursive group, it's a bit of a pain to work out the minimal - -- set of tyvars over which to abstract: - -- /\ a b c. let x = ...a... in - -- letrec { p = ...x...q... - -- q = .....p...b... } in - -- ... - -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted - -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. - -- Since it's a pain, we just use the whole set, which is always safe - -- - -- If you ever want to be more selective, remember this bizarre case too: - -- x::a = x - -- Here, we must abstract 'x' over 'a'. - tvs_here = scopedSort main_tvs - - mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) - mk_poly1 tvs_here var - = do { uniq <- getUniqueM - ; let poly_name = setNameUnique (idName var) uniq -- Keep same name - poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course - poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs - mkLocalIdOrCoVar poly_name poly_ty - ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } - -- In the olden days, it was crucial to copy the occInfo of the original var, - -- because we were looking at occurrence-analysed but as yet unsimplified code! - -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking - -- at already simplified code, so it doesn't matter - -- - -- It's even right to retain single-occurrence or dead-var info: - -- Suppose we started with /\a -> let x = E in B - -- where x occurs once in B. Then we transform to: - -- let x' = /\a -> E in /\a -> let x* = x' a in B - -- where x* has an INLINE prag on it. Now, once x* is inlined, - -- the occurrences of x' will be just the occurrences originally - -- pinned on x. - - mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) - mk_poly2 poly_id tvs_here rhs - = (poly_id `setIdUnfolding` unf, poly_rhs) - where - poly_rhs = mkLams tvs_here rhs - unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs - - -- We want the unfolding. Consider - -- let - -- x = /\a. let y = ... in Just y - -- in body - -- Then we float the y-binding out (via abstractFloats and addPolyBind) - -- but 'x' may well then be inlined in 'body' in which case we'd like the - -- opportunity to inline 'y' too. - -{- -Note [Abstract over coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the -type variable a. Rather than sort this mess out, we simply bale out and abstract -wrt all the type variables if any of them are coercion variables. - - -Historical note: if you use let-bindings instead of a substitution, beware of this: - - -- Suppose we start with: - -- - -- x = /\ a -> let g = G in E - -- - -- Then we'll float to get - -- - -- x = let poly_g = /\ a -> G - -- in /\ a -> let g = poly_g a in E - -- - -- But now the occurrence analyser will see just one occurrence - -- of poly_g, not inside a lambda, so the simplifier will - -- PreInlineUnconditionally poly_g back into g! Badk to square 1! - -- (I used to think that the "don't inline lone occurrences" stuff - -- would stop this happening, but since it's the *only* occurrence, - -- PreInlineUnconditionally kicks in first!) - -- - -- Solution: put an INLINE note on g's RHS, so that poly_g seems - -- to appear many times. (NB: mkInlineMe eliminates - -- such notes on trivial RHSs, so do it manually.) - -************************************************************************ -* * - prepareAlts -* * -************************************************************************ - -prepareAlts tries these things: - -1. Eliminate alternatives that cannot match, including the - DEFAULT alternative. - -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. - -3. Returns a list of the constructors that cannot holds in the - DEFAULT alternative (if there is one) - -Here "cannot match" includes knowledge from GADTs - -It's a good idea to do this stuff before simplifying the alternatives, to -avoid simplifying alternatives we know can't happen, and to come up with -the list of constructors that are handled, to put into the IdInfo of the -case binder, for use when simplifying the alternatives. - -Eliminating the default alternative in (1) isn't so obvious, but it can -happen: - -data Colour = Red | Green | Blue - -f x = case x of - Red -> .. - Green -> .. - DEFAULT -> h x - -h y = case y of - Blue -> .. - DEFAULT -> [ case y of ... ] - -If we inline h into f, the default case of the inlined h can't happen. -If we don't notice this, we may end up filtering out *all* the cases -of the inner case y, which give us nowhere to go! --} - -prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) --- The returned alternatives can be empty, none are possible -prepareAlts scrut case_bndr' alts - | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr') - -- Case binder is needed just for its type. Note that as an - -- OutId, it has maximum information; this is important. - -- Test simpl013 is an example - = do { us <- getUniquesM - ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts - (yes2, alts2) = refineDefaultAlt us tc tys idcs1 alts1 - (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 - -- "idcs" stands for "impossible default data constructors" - -- i.e. the constructors that can't match the default case - ; when yes2 $ tick (FillInCaseDefault case_bndr') - ; when yes3 $ tick (AltMerge case_bndr') - ; return (idcs3, alts3) } - - | otherwise -- Not a data type, so nothing interesting happens - = return ([], alts) - where - imposs_cons = case scrut of - Var v -> otherCons (idUnfolding v) - _ -> [] - - -{- -************************************************************************ -* * - mkCase -* * -************************************************************************ - -mkCase tries these things - -* Note [Nerge nested cases] -* Note [Eliminate identity case] -* Note [Scrutinee constant folding] - -Note [Merge Nested Cases] -~~~~~~~~~~~~~~~~~~~~~~~~~ - case e of b { ==> case e of b { - p1 -> rhs1 p1 -> rhs1 - ... ... - pm -> rhsm pm -> rhsm - _ -> case b of b' { pn -> let b'=b in rhsn - pn -> rhsn ... - ... po -> let b'=b in rhso - po -> rhso _ -> let b'=b in rhsd - _ -> rhsd - } - -which merges two cases in one case when -- the default alternative of -the outer case scrutises the same variable as the outer case. This -transformation is called Case Merging. It avoids that the same -variable is scrutinised multiple times. - -Note [Eliminate Identity Case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - case e of ===> e - True -> True; - False -> False - -and similar friends. - -Note [Scrutinee Constant Folding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - case x op# k# of _ { ===> case x of _ { - a1# -> e1 (a1# inv_op# k#) -> e1 - a2# -> e2 (a2# inv_op# k#) -> e2 - ... ... - DEFAULT -> ed DEFAULT -> ed - - where (x op# k#) inv_op# k# == x - -And similarly for commuted arguments and for some unary operations. - -The purpose of this transformation is not only to avoid an arithmetic -operation at runtime but to allow other transformations to apply in cascade. - -Example with the "Merge Nested Cases" optimization (from #12877): - - main = case t of t0 - 0## -> ... - DEFAULT -> case t0 `minusWord#` 1## of t1 - 0## -> ... - DEFAUT -> case t1 `minusWord#` 1## of t2 - 0## -> ... - DEFAULT -> case t2 `minusWord#` 1## of _ - 0## -> ... - DEFAULT -> ... - - becomes: - - main = case t of _ - 0## -> ... - 1## -> ... - 2## -> ... - 3## -> ... - DEFAULT -> ... - -There are some wrinkles - -* Do not apply caseRules if there is just a single DEFAULT alternative - case e +# 3# of b { DEFAULT -> rhs } - If we applied the transformation here we would (stupidly) get - case a of b' { DEFAULT -> let b = e +# 3# in rhs } - and now the process may repeat, because that let will really - be a case. - -* The type of the scrutinee might change. E.g. - case tagToEnum (x :: Int#) of (b::Bool) - False -> e1 - True -> e2 - ==> - case x of (b'::Int#) - DEFAULT -> e1 - 1# -> e2 - -* The case binder may be used in the right hand sides, so we need - to make a local binding for it, if it is alive. e.g. - case e +# 10# of b - DEFAULT -> blah...b... - 44# -> blah2...b... - ===> - case e of b' - DEFAULT -> let b = b' +# 10# in blah...b... - 34# -> let b = 44# in blah2...b... - - Note that in the non-DEFAULT cases we know what to bind 'b' to, - whereas in the DEFAULT case we must reconstruct the original value. - But NB: we use b'; we do not duplicate 'e'. - -* In dataToTag we might need to make up some fake binders; - see Note [caseRules for dataToTag] in PrelRules --} - -mkCase, mkCase1, mkCase2, mkCase3 - :: DynFlags - -> OutExpr -> OutId - -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order - -> SimplM OutExpr - --------------------------------------------------- --- 1. Merge Nested Cases --------------------------------------------------- - -mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) - | gopt Opt_CaseMerge dflags - , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) - <- stripTicksTop tickishFloatable deflt_rhs - , inner_scrut_var == outer_bndr - = do { tick (CaseMerge outer_bndr) - - ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) - (con, args, wrap_rhs rhs) - -- Simplifier's no-shadowing invariant should ensure - -- that outer_bndr is not shadowed by the inner patterns - wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs - -- The let is OK even for unboxed binders, - - wrapped_alts | isDeadBinder inner_bndr = inner_alts - | otherwise = map wrap_alt inner_alts - - merged_alts = mergeAlts outer_alts wrapped_alts - -- NB: mergeAlts gives priority to the left - -- case x of - -- A -> e1 - -- DEFAULT -> case x of - -- A -> e2 - -- B -> e3 - -- When we merge, we must ensure that e1 takes - -- precedence over e2 as the value for A! - - ; fmap (mkTicks ticks) $ - mkCase1 dflags scrut outer_bndr alts_ty merged_alts - } - -- Warning: don't call mkCase recursively! - -- Firstly, there's no point, because inner alts have already had - -- mkCase applied to them, so they won't have a case in their default - -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr - -- in munge_rhs may put a case into the DEFAULT branch! - -mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Eliminate Identity Case --------------------------------------------------- - -mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case - | all identity_alt alts - = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } - where - ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) - identity_alt (con, args, rhs) = check_eq rhs con args - - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args - - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False - - arg_tys = tyConAppArgs (idType case_bndr) - - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut - -mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Scrutinee Constant Folding --------------------------------------------------- - -mkCase2 dflags scrut bndr alts_ty alts - | -- See Note [Scrutinee Constant Folding] - case alts of -- Not if there is just a DEFAULT alternative - [(DEFAULT,_,_)] -> False - _ -> True - , gopt Opt_CaseFolding dflags - , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut - = do { bndr' <- newId (fsLit "lwild") (exprType scrut') - - ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts - -- mapMaybeM: discard unreachable alternatives - -- See Note [Unreachable caseRules alternatives] - -- in PrelRules - - ; mkCase3 dflags scrut' bndr' alts_ty $ - add_default (re_sort alts') - } - - | otherwise - = mkCase3 dflags scrut bndr alts_ty alts - where - -- We need to keep the correct association between the scrutinee and its - -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with - -- "let bndr = ... in": - -- - -- case v + 10 of y =====> case v of y - -- 20 -> e1 10 -> let y = 20 in e1 - -- DEFAULT -> e2 DEFAULT -> let y = v + 10 in e2 - -- - -- Other transformations give: =====> case v of y' - -- 10 -> let y = 20 in e1 - -- DEFAULT -> let y = y' + 10 in e2 - -- - -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, - -- to construct an expression equivalent to the original one, for use - -- in the DEFAULT case - - tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id - -> CoreAlt -> SimplM (Maybe CoreAlt) - tx_alt tx_con mk_orig new_bndr (con, bs, rhs) - = case tx_con con of - Nothing -> return Nothing - Just con' -> do { bs' <- mk_new_bndrs new_bndr con' - ; return (Just (con', bs', rhs')) } - where - rhs' | isDeadBinder bndr = rhs - | otherwise = bindNonRec bndr orig_val rhs - - orig_val = case con of - DEFAULT -> mk_orig new_bndr - LitAlt l -> Lit l - DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs - - mk_new_bndrs new_bndr (DataAlt dc) - | not (isNullaryRepDataCon dc) - = -- For non-nullary data cons we must invent some fake binders - -- See Note [caseRules for dataToTag] in PrelRules - do { us <- getUniquesM - ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc - (tyConAppArgs (idType new_bndr)) - ; return (ex_tvs ++ arg_ids) } - mk_new_bndrs _ _ = return [] - - re_sort :: [CoreAlt] -> [CoreAlt] - -- Sort the alternatives to re-establish - -- CoreSyn Note [Case expression invariants] - re_sort alts = sortBy cmpAlt alts - - add_default :: [CoreAlt] -> [CoreAlt] - -- See Note [Literal cases] - add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts - add_default alts = alts - -{- Note [Literal cases] -~~~~~~~~~~~~~~~~~~~~~~~ -If we have - case tagToEnum (a ># b) of - False -> e1 - True -> e2 - -then caseRules for TagToEnum will turn it into - case tagToEnum (a ># b) of - 0# -> e1 - 1# -> e2 - -Since the case is exhaustive (all cases are) we can convert it to - case tagToEnum (a ># b) of - DEFAULT -> e1 - 1# -> e2 - -This may generate sligthtly better code (although it should not, since -all cases are exhaustive) and/or optimise better. I'm not certain that -it's necessary, but currenty we do make this change. We do it here, -NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] -in PrelRules) --} - --------------------------------------------------- --- Catch-all --------------------------------------------------- -mkCase3 _dflags scrut bndr alts_ty alts - = return (Case scrut bndr alts_ty alts) - --- See Note [Exitification] and Note [Do not inline exit join points] in Exitify.hs --- This lives here (and not in Id) because occurrence info is only valid on --- InIds, so it's crucial that isExitJoinId is only called on freshly --- occ-analysed code. It's not a generic function you can call anywhere. -isExitJoinId :: Var -> Bool -isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id) - -{- -Note [Dead binders] -~~~~~~~~~~~~~~~~~~~~ -Note that dead-ness is maintained by the simplifier, so that it is -accurate after simplification as well as before. - - -Note [Cascading case merge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case merging should cascade in one sweep, because it -happens bottom-up - - case e of a { - DEFAULT -> case a of b - DEFAULT -> case b of c { - DEFAULT -> e - A -> ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> case a of b - DEFAULT -> let c = b in e - A -> let c = b in ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> let b = a in let c = b in e - A -> let b = a in let c = b in ea - B -> let b = a in eb - C -> ec - - -However here's a tricky case that we still don't catch, and I don't -see how to catch it in one pass: - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -After occurrence analysis (and its binder-swap) we get this - - case x of c1 { I# a1 -> - let x = c1 in -- Binder-swap addition - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -When we simplify the inner case x, we'll see that -x=c1=I# a1. So we'll bind a2 to a1, and get - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case a1 of ... - -This is corect, but we can't do a case merge in this sweep -because c2 /= a1. Reason: the binding c1=I# a1 went inwards -without getting changed to c1=I# c2. - -I don't think this is worth fixing, even if I knew how. It'll -all come out in the next pass anyway. --} diff --git a/simplCore/Simplify.hs b/simplCore/Simplify.hs deleted file mode 100644 --- a/simplCore/Simplify.hs +++ /dev/null @@ -1,3733 +0,0 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[Simplify]{The main module of the simplifier} --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Simplify ( simplTopBinds, simplExpr, simplRules ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import SimplMonad -import Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) -import SimplEnv -import SimplUtils -import OccurAnal ( occurAnalyseExpr ) -import FamInstEnv ( FamInstEnv ) -import Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 -import Id -import MkId ( seqId ) -import MkCore ( FloatBind, mkImpossibleExpr, castBottomExpr ) -import qualified MkCore as MkCore -import IdInfo -import Name ( mkSystemVarName, isExternalName, getOccFS ) -import Coercion hiding ( substCo, substCoVar ) -import OptCoercion ( optCoercion ) -import FamInstEnv ( topNormaliseType_maybe ) -import DataCon ( DataCon, dataConWorkId, dataConRepStrictness - , dataConRepArgTys, isUnboxedTupleCon - , StrictnessMark (..) ) -import CoreMonad ( Tick(..), SimplMode(..) ) -import CoreSyn -import Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd ) -import PprCore ( pprCoreExpr ) -import CoreUnfold -import CoreUtils -import CoreOpt ( pushCoTyArg, pushCoValArg - , joinPointBinding_maybe, joinPointBindings_maybe ) -import Rules ( mkRuleInfo, lookupRule, getRules ) -import Demand ( mkClosedStrictSig, topDmd, seqDmd, botRes ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, - RecFlag(..), Arity ) -import MonadUtils ( mapAccumLM, liftIO ) -import Var ( isTyCoVar ) -import Maybes ( orElse ) -import Control.Monad -import Outputable -import FastString -import Pair -import Util -import ErrUtils -import Module ( moduleName, pprModuleName ) -import PrimOp ( PrimOp (SeqOp) ) - - -{- -The guts of the simplifier is in this module, but the driver loop for -the simplifier is in SimplCore.hs. - -Note [The big picture] -~~~~~~~~~~~~~~~~~~~~~~ -The general shape of the simplifier is this: - - simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - - * SimplEnv contains - - Simplifier mode (which includes DynFlags for convenience) - - Ambient substitution - - InScopeSet - - * SimplFloats contains - - Let-floats (which includes ok-for-spec case-floats) - - Join floats - - InScopeSet (including all the floats) - - * Expressions - simplExpr :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - The result of simplifying an /expression/ is (floats, expr) - - A bunch of floats (let bindings, join bindings) - - A simplified expression. - The overall result is effectively (let floats in expr) - - * Bindings - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - The result of simplifying a binding is - - A bunch of floats, the last of which is the simplified binding - There may be auxiliary bindings too; see prepareRhs - - An environment suitable for simplifying the scope of the binding - - The floats may also be empty, if the binding is inlined unconditionally; - in that case the returned SimplEnv will have an augmented substitution. - - The returned floats and env both have an in-scope set, and they are - guaranteed to be the same. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -The simplifier used to guarantee that the output had no shadowing, but -it does not do so any more. (Actually, it never did!) The reason is -documented with simplifyArgs. - - -Eta expansion -~~~~~~~~~~~~~~ -For eta expansion, we want to catch things like - - case e of (a,b) -> \x -> case a of (p,q) -> \y -> r - -If the \x was on the RHS of a let, we'd eta expand to bring the two -lambdas together. And in general that's a good thing to do. Perhaps -we should eta expand wherever we find a (value) lambda? Then the eta -expansion at a let RHS can concentrate solely on the PAP case. - -Note [In-scope set as a substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As per Note [Lookups in in-scope set], an in-scope set can act as -a substitution. Specifically, it acts as a substitution from variable to -variables /with the same unique/. - -Why do we need this? Well, during the course of the simplifier, we may want to -adjust inessential properties of a variable. For instance, when performing a -beta-reduction, we change - - (\x. e) u ==> let x = u in e - -We typically want to add an unfolding to `x` so that it inlines to (the -simplification of) `u`. - -We do that by adding the unfolding to the binder `x`, which is added to the -in-scope set. When simplifying occurrences of `x` (every occurrence!), they are -replaced by their “updated” version from the in-scope set, hence inherit the -unfolding. This happens in `SimplEnv.substId`. - -Another example. Consider - - case x of y { Node a b -> ...y... - ; Leaf v -> ...y... } - -In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we -want y's unfolding to be (Leaf v). We achieve this by adding the appropriate -unfolding to y, and re-adding it to the in-scope set. See the calls to -`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. - -It's quite convenient. This way we don't need to manipulate the substitution all -the time: every update to a binder is automatically reflected to its bound -occurrences. - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - -simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) --- See Note [The big picture] -simplTopBinds env0 binds0 - = do { -- Put all the top-level binders into scope at the start - -- so that if a transformation rule has unexpectedly brought - -- anything into scope, then we don't get a complaint about that. - -- It's rather as if the top-level binders were imported. - -- See note [Glomming] in OccurAnal. - ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) - ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 - ; freeTick SimplifierDone - ; return (floats, env2) } - where - -- We need to track the zapped top-level binders, because - -- they should have their fragile IdInfo zapped (notably occurrence info) - -- That's why we run down binds and bndrs' simultaneously. - -- - simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) - simpl_binds env [] = return (emptyFloats env, env) - simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind - ; (floats, env2) <- simpl_binds env1 binds - ; return (float `addFloats` floats, env2) } - - simpl_bind env (Rec pairs) - = simplRecBind env TopLevel Nothing pairs - simpl_bind env (NonRec b r) - = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing - ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r } - -{- -************************************************************************ -* * - Lazy bindings -* * -************************************************************************ - -simplRecBind is used for - * recursive bindings only --} - -simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont - -> [(InId, InExpr)] - -> SimplM (SimplFloats, SimplEnv) -simplRecBind env0 top_lvl mb_cont pairs0 - = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0 - ; (rec_floats, env1) <- go env_with_info triples - ; return (mkRecFloats rec_floats, env1) } - where - add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) - -- Add the (substituted) rules to the binder - add_rules env (bndr, rhs) - = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont - ; return (env', (bndr, bndr', rhs)) } - - go env [] = return (emptyFloats env, env) - - go env ((old_bndr, new_bndr, rhs) : pairs) - = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont - old_bndr new_bndr rhs - ; (floats, env2) <- go env1 pairs - ; return (float `addFloats` floats, env2) } - -{- -simplOrTopPair is used for - * recursive bindings (whether top level or not) - * top-level non-recursive bindings - -It assumes the binder has already been simplified, but not its IdInfo. --} - -simplRecOrTopPair :: SimplEnv - -> TopLevelFlag -> RecFlag -> MaybeJoinCont - -> InId -> OutBndr -> InExpr -- Binder and rhs - -> SimplM (SimplFloats, SimplEnv) - -simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs - | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env - = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} - trace_bind "pre-inline-uncond" $ - do { tick (PreInlineUnconditionally old_bndr) - ; return ( emptyFloats env, env' ) } - - | Just cont <- mb_cont - = {-#SCC "simplRecOrTopPair-join" #-} - ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr ) - trace_bind "join" $ - simplJoinBind env cont old_bndr new_bndr rhs env - - | otherwise - = {-#SCC "simplRecOrTopPair-normal" #-} - trace_bind "normal" $ - simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env - - where - dflags = seDynFlags env - - -- trace_bind emits a trace for each top-level binding, which - -- helps to locate the tracing for inlining and rule firing - trace_bind what thing_inside - | not (dopt Opt_D_verbose_core2core dflags) - = thing_inside - | otherwise - = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside - --------------------------- -simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- Not a JoinId - -- The OutId has IdInfo, except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM (SimplFloats, SimplEnv) --- Precondition: not a JoinId --- Precondition: rhs obeys the let/app invariant --- NOT used for JoinIds -simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = ASSERT( isId bndr ) - ASSERT2( not (isJoinId bndr), ppr bndr ) - -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ - do { let rhs_env = rhs_se `setInScopeFromE` env - (tvs, body) = case collectTyAndValBinders rhs of - (tvs, [], body) - | surely_not_lam body -> (tvs, body) - _ -> ([], rhs) - - surely_not_lam (Lam {}) = False - surely_not_lam (Tick t e) - | not (tickishFloatable t) = surely_not_lam e - -- eta-reduction could float - surely_not_lam _ = True - -- Do not do the "abstract tyvar" thing if there's - -- a lambda inside, because it defeats eta-reduction - -- f = /\a. \x. g a x - -- should eta-reduce. - - - ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs - -- See Note [Floating and type abstraction] in SimplUtils - - -- Simplify the RHS - ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) - ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont - - -- Never float join-floats out of a non-join let-binding - -- So wrap the body in the join-floats right now - -- Hence: body_floats1 consists only of let-floats - ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0 - - -- ANF-ise a constructor or PAP rhs - -- We get at most one float per argument here - ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl - (getOccFS bndr1) (idInfo bndr1) body1 - ; let body_floats2 = body_floats1 `addLetFloats` let_floats - - ; (rhs_floats, rhs') - <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) - then -- No floating, revert to body1 - {-#SCC "simplLazyBind-no-floating" #-} - do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont - ; return (emptyFloats env, rhs') } - - else if null tvs then -- Simple floating - {-#SCC "simplLazyBind-simple-floating" #-} - do { tick LetFloatFromLet - ; return (body_floats2, body2) } - - else -- Do type-abstraction first - {-#SCC "simplLazyBind-type-abstraction-first" #-} - do { tick LetFloatFromLet - ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl - tvs' body_floats2 body2 - ; let floats = foldl' extendFloats (emptyFloats env) poly_binds - ; rhs' <- mkLam env tvs' body3 rhs_cont - ; return (floats, rhs') } - - ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) - top_lvl Nothing bndr bndr1 rhs' - ; return (rhs_floats `addFloats` bind_float, env2) } - --------------------------- -simplJoinBind :: SimplEnv - -> SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, - -- unfolding - -> InExpr -> SimplEnv -- The right hand side and its env - -> SimplM (SimplFloats, SimplEnv) -simplJoinBind env cont old_bndr new_bndr rhs rhs_se - = do { let rhs_env = rhs_se `setInScopeFromE` env - ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' } - --------------------------- -simplNonRecX :: SimplEnv - -> InId -- Old binder; not a JoinId - -> OutExpr -- Simplified RHS - -> SimplM (SimplFloats, SimplEnv) --- A specialised variant of simplNonRec used when the RHS is already --- simplified, notably in knownCon. It uses case-binding where necessary. --- --- Precondition: rhs satisfies the let/app invariant - -simplNonRecX env bndr new_rhs - | ASSERT2( not (isJoinId bndr), ppr bndr ) - isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return (emptyFloats env, env) -- Here c is dead, and we avoid - -- creating the binding c = (a,b) - - | Coercion co <- new_rhs - = return (emptyFloats env, extendCvSubst env bndr co) - - | otherwise - = do { (env', bndr') <- simplBinder env bndr - ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } - -- simplNonRecX is only used for NotTopLevel things - --------------------------- -completeNonRecX :: TopLevelFlag -> SimplEnv - -> Bool - -> InId -- Old binder; not a JoinId - -> OutId -- New binder - -> OutExpr -- Simplified RHS - -> SimplM (SimplFloats, SimplEnv) -- The new binding is in the floats --- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn - -completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs - = ASSERT2( not (isJoinId new_bndr), ppr new_bndr ) - do { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr) - (idInfo new_bndr) new_rhs - ; let floats = emptyFloats env `addLetFloats` prepd_floats - ; (rhs_floats, rhs2) <- - if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1 - then -- Add the floats to the main env - do { tick LetFloatFromLet - ; return (floats, rhs1) } - else -- Do not float; wrap the floats around the RHS - return (emptyFloats env, wrapFloats floats rhs1) - - ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) - NotTopLevel Nothing - old_bndr new_bndr rhs2 - ; return (rhs_floats `addFloats` bind_float, env2) } - - -{- ********************************************************************* -* * - prepareRhs, makeTrivial -* * -************************************************************************ - -Note [prepareRhs] -~~~~~~~~~~~~~~~~~ -prepareRhs takes a putative RHS, checks whether it's a PAP or -constructor application and, if so, converts it to ANF, so that the -resulting thing can be inlined more easily. Thus - x = (f a, g b) -becomes - t1 = f a - t2 = g b - x = (t1,t2) - -We also want to deal well cases like this - v = (f e1 `cast` co) e2 -Here we want to make e1,e2 trivial and get - x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 -That's what the 'go' loop in prepareRhs does --} - -prepareRhs :: SimplMode -> TopLevelFlag - -> FastString -- Base for any new variables - -> IdInfo -- IdInfo for the LHS of this binding - -> OutExpr - -> SimplM (LetFloats, OutExpr) --- Transforms a RHS into a better RHS by adding floats --- e.g x = Just e --- becomes a = e --- x = Just a --- See Note [prepareRhs] -prepareRhs mode top_lvl occ info (Cast rhs co) -- Note [Float coercions] - | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type - , not (isUnliftedType ty1) -- see Note [Float coercions (unlifted)] - = do { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs - ; return (floats, Cast rhs' co) } - where - sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info - `setDemandInfo` demandInfo info - -prepareRhs mode top_lvl occ _ rhs0 - = do { (_is_exp, floats, rhs1) <- go 0 rhs0 - ; return (floats, rhs1) } - where - go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) - go n_val_args (Cast rhs co) - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, floats, Cast rhs' co) } - go n_val_args (App fun (Type ty)) - = do { (is_exp, floats, rhs') <- go n_val_args fun - ; return (is_exp, floats, App rhs' (Type ty)) } - go n_val_args (App fun arg) - = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun - ; case is_exp of - False -> return (False, emptyLetFloats, App fun arg) - True -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg - ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } - go n_val_args (Var fun) - = return (is_exp, emptyLetFloats, Var fun) - where - is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP - -- See Note [CONLIKE pragma] in BasicTypes - -- The definition of is_exp should match that in - -- OccurAnal.occAnalApp - - go n_val_args (Tick t rhs) - -- We want to be able to float bindings past this - -- tick. Non-scoping ticks don't care. - | tickishScoped t == NoScope - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, floats, Tick t rhs') } - - -- On the other hand, for scoping ticks we need to be able to - -- copy them on the floats, which in turn is only allowed if - -- we can obtain non-counting ticks. - | (not (tickishCounts t) || tickishCanSplit t) - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) - floats' = mapLetFloats floats tickIt - ; return (is_exp, floats', Tick t rhs') } - - go _ other - = return (False, emptyLetFloats, other) - -{- -Note [Float coercions] -~~~~~~~~~~~~~~~~~~~~~~ -When we find the binding - x = e `cast` co -we'd like to transform it to - x' = e - x = x `cast` co -- A trivial binding -There's a chance that e will be a constructor application or function, or something -like that, so moving the coercion to the usage site may well cancel the coercions -and lead to further optimisation. Example: - - data family T a :: * - data instance T Int = T Int - - foo :: Int -> Int -> Int - foo m n = ... - where - x = T m - go 0 = 0 - go n = case x of { T m -> go (n-m) } - -- This case should optimise - -Note [Preserve strictness when floating coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the Note [Float coercions] transformation, keep the strictness info. -Eg - f = e `cast` co -- f has strictness SSL -When we transform to - f' = e -- f' also has strictness SSL - f = f' `cast` co -- f still has strictness SSL - -Its not wrong to drop it on the floor, but better to keep it. - -Note [Float coercions (unlifted)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT don't do [Float coercions] if 'e' has an unlifted type. -This *can* happen: - - foo :: Int = (error (# Int,Int #) "urk") - `cast` CoUnsafe (# Int,Int #) Int - -If do the makeTrivial thing to the error call, we'll get - foo = case error (# Int,Int #) "urk" of v -> v `cast` ... -But 'v' isn't in scope! - -These strange casts can happen as a result of case-of-case - bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of - (# p,q #) -> p+q --} - -makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec) -makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd }) - = do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e - ; return (floats, arg { as_arg = e' }) } -makeTrivialArg _ arg - = return (emptyLetFloats, arg) -- CastBy, TyArg - -makeTrivial :: SimplMode -> TopLevelFlag -> Demand - -> FastString -- ^ A "friendly name" to build the new binder from - -> OutExpr -- ^ This expression satisfies the let/app invariant - -> SimplM (LetFloats, OutExpr) --- Binds the expression to a variable, if it's not trivial, returning the variable --- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] -makeTrivial mode top_lvl dmd occ_fs expr - = makeTrivialWithInfo mode top_lvl occ_fs (vanillaIdInfo `setDemandInfo` dmd) expr - -makeTrivialWithInfo :: SimplMode -> TopLevelFlag - -> FastString -- ^ a "friendly name" to build the new binder from - -> IdInfo - -> OutExpr -- ^ This expression satisfies the let/app invariant - -> SimplM (LetFloats, OutExpr) --- Propagate strictness and demand info to the new binder --- Note [Preserve strictness when floating coercions] --- Returned SimplEnv has same substitution as incoming one -makeTrivialWithInfo mode top_lvl occ_fs info expr - | exprIsTrivial expr -- Already trivial - || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - -- See Note [Cannot trivialise] - = return (emptyLetFloats, expr) - - | otherwise - = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr - ; if exprIsTrivial expr1 -- See Note [Trivial after prepareRhs] - then return (floats, expr1) - else do - { uniq <- getUniqueM - ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdOrCoVarWithInfo name expr_ty info - - -- Now something very like completeBind, - -- but without the postInlineUnconditinoally part - ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1 - ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2 - - ; let final_id = addLetBndrInfo var arity is_bot unf - bind = NonRec final_id expr2 - - ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }} - where - expr_ty = exprType expr - -bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool --- True iff we can have a binding of this expression at this level --- Precondition: the type is the type of the expression -bindingOk top_lvl expr expr_ty - | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty - | otherwise = True - -{- Note [Trivial after prepareRhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we call makeTrival on (e |> co), the recursive use of prepareRhs -may leave us with - { a1 = e } and (a1 |> co) -Now the latter is trivial, so we don't want to let-bind it. - -Note [Cannot trivialise] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - f :: Int -> Addr# - - foo :: Bar - foo = Bar (f 3) - -Then we can't ANF-ise foo, even though we'd like to, because -we can't make a top-level binding for the Addr# (f 3). And if -so we don't want to turn it into - foo = let x = f 3 in Bar x -because we'll just end up inlining x back, and that makes the -simplifier loop. Better not to ANF-ise it at all. - -Literal strings are an exception. - - foo = Ptr "blob"# - -We want to turn this into: - - foo1 = "blob"# - foo = Ptr foo1 - -See Note [CoreSyn top-level string literals] in CoreSyn. - -************************************************************************ -* * - Completing a lazy binding -* * -************************************************************************ - -completeBind - * deals only with Ids, not TyVars - * takes an already-simplified binder and RHS - * is used for both recursive and non-recursive bindings - * is used for both top-level and non-top-level bindings - -It does the following: - - tries discarding a dead binding - - tries PostInlineUnconditionally - - add unfolding [this is the only place we add an unfolding] - - add arity - -It does *not* attempt to do let-to-case. Why? Because it is used for - - top-level bindings (when let-to-case is impossible) - - many situations where the "rhs" is known to be a WHNF - (so let-to-case is inappropriate). - -Nor does it do the atomic-argument thing --} - -completeBind :: SimplEnv - -> TopLevelFlag -- Flag stuck into unfolding - -> MaybeJoinCont -- Required only for join point - -> InId -- Old binder - -> OutId -> OutExpr -- New binder and RHS - -> SimplM (SimplFloats, SimplEnv) --- completeBind may choose to do its work --- * by extending the substitution (e.g. let x = y in ...) --- * or by adding to the floats in the envt --- --- Binder /can/ be a JoinId --- Precondition: rhs obeys the let/app invariant -completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs - | isCoVar old_bndr - = case new_rhs of - Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) - _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) - - | otherwise - = ASSERT( isId new_bndr ) - do { let old_info = idInfo old_bndr - old_unf = unfoldingInfo old_info - occ_info = occInfo old_info - - -- Do eta-expansion on the RHS of the binding - -- See Note [Eta-expanding at let bindings] in SimplUtils - ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env) - new_bndr new_rhs - - -- Simplify the unfolding - ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr - final_rhs (idType new_bndr) old_unf - - ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding - -- See Note [In-scope set as a substitution] - - ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs - - then -- Inline and discard the binding - do { tick (PostInlineUnconditionally old_bndr) - ; return ( emptyFloats env - , extendIdSubst env old_bndr $ - DoneEx final_rhs (isJoinId_maybe new_bndr)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding - - else -- Keep the binding - -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ - return (mkFloatBind env (NonRec final_bndr final_rhs)) } - -addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId -addLetBndrInfo new_bndr new_arity is_bot new_unf - = new_bndr `setIdInfo` info5 - where - info1 = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info: Note [Setting the new unfolding] - info2 = info1 `setUnfoldingInfo` new_unf - - -- Demand info: Note [Setting the demand info] - -- We also have to nuke demand info if for some reason - -- eta-expansion *reduces* the arity of the binding to less - -- than that of the strictness sig. This can happen: see Note [Arity decrease]. - info3 | isEvaldUnfolding new_unf - || (case strictnessInfo info2 of - StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) - = zapDemandInfo info2 `orElse` info2 - | otherwise - = info2 - - -- Bottoming bindings: see Note [Bottoming bindings] - info4 | is_bot = info3 `setStrictnessInfo` - mkClosedStrictSig (replicate new_arity topDmd) botRes - | otherwise = info3 - - -- Zap call arity info. We have used it by now (via - -- `tryEtaExpandRhs`), and the simplifier can invalidate this - -- information, leading to broken code later (e.g. #13479) - info5 = zapCallArityInfo info4 - - -{- Note [Arity decrease] -~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking the arity of a binding should not decrease. But it *can* -legitimately happen because of RULES. Eg - f = g Int -where g has arity 2, will have arity 2. But if there's a rewrite rule - g Int --> h -where h has arity 1, then f's arity will decrease. Here's a real-life example, -which is in the output of Specialise: - - Rec { - $dm {Arity 2} = \d.\x. op d - {-# RULES forall d. $dm Int d = $s$dm #-} - - dInt = MkD .... opInt ... - opInt {Arity 1} = $dm dInt - - $s$dm {Arity 0} = \x. op dInt } - -Here opInt has arity 1; but when we apply the rule its arity drops to 0. -That's why Specialise goes to a little trouble to pin the right arity -on specialised functions too. - -Note [Bottoming bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - let x = error "urk" - in ...(case x of )... -or - let f = \x. error (x ++ "urk") - in ...(case f "foo" of )... - -Then we'd like to drop the dead immediately. So it's good to -propagate the info that x's RHS is bottom to x's IdInfo as rapidly as -possible. - -We use tryEtaExpandRhs on every binding, and it turns ou that the -arity computation it performs (via CoreArity.findRhsArity) already -does a simple bottoming-expression analysis. So all we need to do -is propagate that info to the binder's IdInfo. - -This showed up in #12150; see comment:16. - -Note [Setting the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the unfolding is a value, the demand info may -go pear-shaped, so we nuke it. Example: - let x = (a,b) in - case x of (p,q) -> h p q x -Here x is certainly demanded. But after we've nuked -the case, we'll get just - let x = (a,b) in h a b x -and now x is not demanded (I'm assuming h is lazy) -This really happens. Similarly - let f = \x -> e in ...f..f... -After inlining f at some of its call sites the original binding may -(for example) be no longer strictly demanded. -The solution here is a bit ad hoc... - - -************************************************************************ -* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} -* * -************************************************************************ - -The reason for this OutExprStuff stuff is that we want to float *after* -simplifying a RHS, not before. If we do so naively we get quadratic -behaviour as things float out. - -To see why it's important to do it after, consider this (real) example: - - let t = f x - in fst t -==> - let t = let a = e1 - b = e2 - in (a,b) - in fst t -==> - let a = e1 - b = e2 - t = (a,b) - in - a -- Can't inline a this round, cos it appears twice -==> - e1 - -Each of the ==> steps is a round of simplification. We'd save a -whole round if we float first. This can cascade. Consider - - let f = g d - in \x -> ...f... -==> - let f = let d1 = ..d.. in \y -> e - in \x -> ...f... -==> - let d1 = ..d.. - in \x -> ...(\y ->e)... - -Only in this second round can the \y be applied, and it -might do the same again. --} - -simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr env (Type ty) - = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] - ; return (Type ty') } - -simplExpr env expr - = simplExprC env expr (mkBoringStop expr_out_ty) - where - expr_out_ty :: OutType - expr_out_ty = substTy env (exprType expr) - -- NB: Since 'expr' is term-valued, not (Type ty), this call - -- to exprType will succeed. exprType fails on (Type ty). - -simplExprC :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM OutExpr - -- Simplify an expression, given a continuation -simplExprC env expr cont - = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $ - do { (floats, expr') <- simplExprF env expr cont - ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ - -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ - -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ - return (wrapFloats floats expr') } - --------------------------------------------------- -simplExprF :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF env e cont - = {- pprTrace "simplExprF" (vcat - [ ppr e - , text "cont =" <+> ppr cont - , text "inscope =" <+> ppr (seInScope env) - , text "tvsubst =" <+> ppr (seTvSubst env) - , text "idsubst =" <+> ppr (seIdSubst env) - , text "cvsubst =" <+> ppr (seCvSubst env) - ]) $ -} - simplExprF1 env e cont - -simplExprF1 :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF1 _ (Type ty) _ - = pprPanic "simplExprF: type" (ppr ty) - -- simplExprF does only with term-valued expressions - -- The (Type ty) case is handled separately by simplExpr - -- and by the other callers of simplExprF - -simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont -simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont -simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont -simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont -simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont - -simplExprF1 env (App fun arg) cont - = {-#SCC "simplExprF1-App" #-} case arg of - Type ty -> do { -- The argument type will (almost) certainly be used - -- in the output program, so just force it now. - -- See Note [Avoiding space leaks in OutType] - arg' <- simplType env ty - - -- But use substTy, not simplType, to avoid forcing - -- the hole type; it will likely not be needed. - -- See Note [The hole type in ApplyToTy] - ; let hole' = substTy env (exprType fun) - - ; simplExprF env fun $ - ApplyToTy { sc_arg_ty = arg' - , sc_hole_ty = hole' - , sc_cont = cont } } - _ -> simplExprF env fun $ - ApplyToVal { sc_arg = arg, sc_env = env - , sc_dup = NoDup, sc_cont = cont } - -simplExprF1 env expr@(Lam {}) cont - = {-#SCC "simplExprF1-Lam" #-} - simplLam env zapped_bndrs body cont - -- The main issue here is under-saturated lambdas - -- (\x1. \x2. e) arg1 - -- Here x1 might have "occurs-once" occ-info, because occ-info - -- is computed assuming that a group of lambdas is applied - -- all at once. If there are too few args, we must zap the - -- occ-info, UNLESS the remaining binders are one-shot - where - (bndrs, body) = collectBinders expr - zapped_bndrs | need_to_zap = map zap bndrs - | otherwise = bndrs - - need_to_zap = any zappable_bndr (drop n_args bndrs) - n_args = countArgs cont - -- NB: countArgs counts all the args (incl type args) - -- and likewise drop counts all binders (incl type lambdas) - - zappable_bndr b = isId b && not (isOneShotBndr b) - zap b | isTyVar b = b - | otherwise = zapLamIdInfo b - -simplExprF1 env (Case scrut bndr _ alts) cont - = {-#SCC "simplExprF1-Case" #-} - simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr - , sc_alts = alts - , sc_env = env, sc_cont = cont }) - -simplExprF1 env (Let (Rec pairs) body) cont - | Just pairs' <- joinPointBindings_maybe pairs - = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont - - | otherwise - = {-#SCC "simplRecE" #-} simplRecE env pairs body cont - -simplExprF1 env (Let (NonRec bndr rhs) body) cont - | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) - = {-#SCC "simplExprF1-NonRecLet-Type" #-} - ASSERT( isTyVar bndr ) - do { ty' <- simplType env ty - ; simplExprF (extendTvSubst env bndr ty') body cont } - - | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs - = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont - - | otherwise - = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont - -{- Note [Avoiding space leaks in OutType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the simplifier is run for multiple iterations, we need to ensure -that any thunks in the output of one simplifier iteration are forced -by the evaluation of the next simplifier iteration. Otherwise we may -retain multiple copies of the Core program and leak a terrible amount -of memory (as in #13426). - -The simplifier is naturally strict in the entire "Expr part" of the -input Core program, because any expression may contain binders, which -we must find in order to extend the SimplEnv accordingly. But types -do not contain binders and so it is tempting to write things like - - simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! - -This is Bad because the result includes a thunk (substTy env ty) which -retains a reference to the whole simplifier environment; and the next -simplifier iteration will not force this thunk either, because the -line above is not strict in ty. - -So instead our strategy is for the simplifier to fully evaluate -OutTypes when it emits them into the output Core program, for example - - simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good - ; return (Type ty') } - -where the only difference from above is that simplType calls seqType -on the result of substTy. - -However, SimplCont can also contain OutTypes and it's not necessarily -a good idea to force types on the way in to SimplCont, because they -may end up not being used and forcing them could be a lot of wasted -work. T5631 is a good example of this. - -- For ApplyToTy's sc_arg_ty, we force the type on the way in because - the type will almost certainly appear as a type argument in the - output program. - -- For the hole types in Stop and ApplyToTy, we force the type when we - emit it into the output program, after obtaining it from - contResultType. (The hole type in ApplyToTy is only directly used - to form the result type in a new Stop continuation.) --} - ---------------------------------- --- Simplify a join point, adding the context. --- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: --- \x1 .. xn -> e => \x1 .. xn -> E[e] --- Note that we need the arity of the join point, since e may be a lambda --- (though this is unlikely). See Note [Case-of-case and join points]. -simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont - -> SimplM OutExpr -simplJoinRhs env bndr expr cont - | Just arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders arity expr - ; (env', join_bndrs') <- simplLamBndrs env join_bndrs - ; join_body' <- simplExprC env' join_body cont - ; return $ mkLams join_bndrs' join_body' } - - | otherwise - = pprPanic "simplJoinRhs" (ppr bndr) - ---------------------------------- -simplType :: SimplEnv -> InType -> SimplM OutType - -- Kept monadic just so we can do the seqType - -- See Note [Avoiding space leaks in OutType] -simplType env ty - = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` return new_ty - where - new_ty = substTy env ty - ---------------------------------- -simplCoercionF :: SimplEnv -> InCoercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCoercionF env co cont - = do { co' <- simplCoercion env co - ; rebuild env (Coercion co') cont } - -simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion -simplCoercion env co - = do { dflags <- getDynFlags - ; let opt_co = optCoercion dflags (getTCvSubst env) co - ; seqCo opt_co `seq` return opt_co } - ------------------------------------ --- | Push a TickIt context outwards past applications and cases, as --- long as this is a non-scoping tick, to let case and application --- optimisations apply. - -simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplTick env tickish expr cont - -- A scoped tick turns into a continuation, so that we can spot - -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do - -- it this way, then it would take two passes of the simplifier to - -- reduce ((scc t (\x . e)) e'). - -- NB, don't do this with counting ticks, because if the expr is - -- bottom, then rebuildCall will discard the continuation. - --- XXX: we cannot do this, because the simplifier assumes that --- the context can be pushed into a case with a single branch. e.g. --- scc case expensive of p -> e --- becomes --- case expensive of p -> scc e --- --- So I'm disabling this for now. It just means we will do more --- simplifier iterations that necessary in some cases. - --- | tickishScoped tickish && not (tickishCounts tickish) --- = simplExprF env expr (TickIt tickish cont) - - -- For unscoped or soft-scoped ticks, we are allowed to float in new - -- cost, so we simply push the continuation inside the tick. This - -- has the effect of moving the tick to the outside of a case or - -- application context, allowing the normal case and application - -- optimisations to fire. - | tickish `tickishScopesLike` SoftScope - = do { (floats, expr') <- simplExprF env expr cont - ; return (floats, mkTick tickish expr') - } - - -- Push tick inside if the context looks like this will allow us to - -- do a case-of-case - see Note [case-of-scc-of-case] - | Select {} <- cont, Just expr' <- push_tick_inside - = simplExprF env expr' cont - - -- We don't want to move the tick, but we might still want to allow - -- floats to pass through with appropriate wrapping (or not, see - -- wrap_floats below) - --- | not (tickishCounts tickish) || tickishCanSplit tickish - -- = wrap_floats - - | otherwise - = no_floating_past_tick - - where - - -- Try to push tick inside a case, see Note [case-of-scc-of-case]. - push_tick_inside = - case expr0 of - Case scrut bndr ty alts - -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) - _other -> Nothing - where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) - movable t = not (tickishCounts t) || - t `tickishScopesLike` NoScope || - tickishCanSplit t - tickScrut e = foldr mkTick e ticks - -- Alternatives get annotated with all ticks that scope in some way, - -- but we don't want to count entries. - tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) - ts_scope = map mkNoCount $ - filter (not . (`tickishScopesLike` NoScope)) ticks - - no_floating_past_tick = - do { let (inc,outc) = splitCont cont - ; (floats, expr1) <- simplExprF env expr inc - ; let expr2 = wrapFloats floats expr1 - tickish' = simplTickish env tickish - ; rebuild env (mkTick tickish' expr2) outc - } - --- Alternative version that wraps outgoing floats with the tick. This --- results in ticks being duplicated, as we don't make any attempt to --- eliminate the tick if we re-inline the binding (because the tick --- semantics allows unrestricted inlining of HNFs), so I'm not doing --- this any more. FloatOut will catch any real opportunities for --- floating. --- --- wrap_floats = --- do { let (inc,outc) = splitCont cont --- ; (env', expr') <- simplExprF (zapFloats env) expr inc --- ; let tickish' = simplTickish env tickish --- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), --- mkTick (mkNoCount tickish') rhs) --- -- when wrapping a float with mkTick, we better zap the Id's --- -- strictness info and arity, because it might be wrong now. --- ; let env'' = addFloats env (mapFloats env' wrap_float) --- ; rebuild env'' expr' (TickIt tickish' outc) --- } - - - simplTickish env tickish - | Breakpoint n ids <- tickish - = Breakpoint n (map (getDoneId . substId env) ids) - | otherwise = tickish - - -- Push type application and coercion inside a tick - splitCont :: SimplCont -> (SimplCont, SimplCont) - splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) - where (inc,outc) = splitCont tail - splitCont (CastIt co c) = (CastIt co inc, outc) - where (inc,outc) = splitCont c - splitCont other = (mkBoringStop (contHoleType other), other) - - getDoneId (DoneId id) = id - getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst - getDoneId other = pprPanic "getDoneId" (ppr other) - --- Note [case-of-scc-of-case] --- It's pretty important to be able to transform case-of-case when --- there's an SCC in the way. For example, the following comes up --- in nofib/real/compress/Encode.hs: --- --- case scctick --- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje --- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> --- (ww1_s13f, ww2_s13g, ww3_s13h) --- } --- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> --- tick --- (ww_s12Y, --- ww1_s12Z, --- PTTrees.PT --- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) --- } --- --- We really want this case-of-case to fire, because then the 3-tuple --- will go away (indeed, the CPR optimisation is relying on this --- happening). But the scctick is in the way - we need to push it --- inside to expose the case-of-case. So we perform this --- transformation on the inner case: --- --- scctick c (case e of { p1 -> e1; ...; pn -> en }) --- ==> --- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } --- --- So we've moved a constant amount of work out of the scc to expose --- the case. We only do this when the continuation is interesting: in --- for now, it has to be another Case (maybe generalise this later). - -{- -************************************************************************ -* * -\subsection{The main rebuilder} -* * -************************************************************************ --} - -rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) --- At this point the substitution in the SimplEnv should be irrelevant; --- only the in-scope set matters -rebuild env expr cont - = case cont of - Stop {} -> return (emptyFloats env, expr) - TickIt t cont -> rebuild env (mkTick t expr) cont - CastIt co cont -> rebuild env (mkCast expr co) cont - -- NB: mkCast implements the (Coercion co |> g) optimisation - - Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } - -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont - - StrictArg { sc_fun = fun, sc_cont = cont } - -> rebuildCall env (fun `addValArgTo` expr) cont - StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body - , sc_env = se, sc_cont = cont } - -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr - -- expr satisfies let/app since it started life - -- in a call to simplNonRecE - ; (floats2, expr') <- simplLam env' bs body cont - ; return (floats1 `addFloats` floats2, expr') } - - ApplyToTy { sc_arg_ty = ty, sc_cont = cont} - -> rebuild env (App expr (Type ty)) cont - - ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} - -- See Note [Avoid redundant simplification] - -> do { (_, _, arg') <- simplArg env dup_flag se arg - ; rebuild env (App expr arg') cont } - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -{- Note [Optimising reflexivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important (for compiler performance) to get rid of reflexivity as soon -as it appears. See #11735, #14737, and #15019. - -In particular, we want to behave well on - - * e |> co1 |> co2 - where the two happen to cancel out entirely. That is quite common; - e.g. a newtype wrapping and unwrapping cancel. - - - * (f |> co) @t1 @t2 ... @tn x1 .. xm - Here we wil use pushCoTyArg and pushCoValArg successively, which - build up NthCo stacks. Silly to do that if co is reflexive. - -However, we don't want to call isReflexiveCo too much, because it uses -type equality which is expensive on big types (#14737 comment:7). - -A good compromise (determined experimentally) seems to be to call -isReflexiveCo - * when composing casts, and - * at the end - -In investigating this I saw missed opportunities for on-the-fly -coercion shrinkage. See #15090. --} - - -simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 - ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 cont0 - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } - where - -- If the first parameter is MRefl, then simplifying revealed a - -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont - addCoerceM MRefl cont = return cont - addCoerceM (MCo co) cont = addCoerce co cont - - addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont - addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] - | isReflexiveCo co' = return cont - | otherwise = addCoerce co' cont - where - co' = mkTransCo co1 co2 - - addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty - -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is - -- only needed by `sc_hole_ty` which is often not forced. - -- Consequently it is worthwhile using a lazy pattern match here to - -- avoid unnecessary coercionKind evaluations. - , ~(Pair hole_ty _) <- coercionKind co - = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' tail - ; return (cont { sc_arg_ty = arg_ty' - , sc_hole_ty = hole_ty -- NB! As the cast goes past, the - -- type of the hole changes (#16312) - , sc_cont = tail' }) } - - addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail }) - | Just (co1, m_co2) <- pushCoValArg co - , Pair _ new_ty <- coercionKind co1 - , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg - -- See Note [Levity polymorphism invariants] in CoreSyn - -- test: typecheck/should_run/EtaExpandLevPoly - = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 tail - ; if isReflCo co1 - then return (cont { sc_cont = tail' }) - -- Avoid simplifying if possible; - -- See Note [Avoiding exponential behaviour] - else do - { (dup', arg_se', arg') <- simplArg env dup arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' - , sc_dup = dup' - , sc_cont = tail' }) } } - - addCoerce co cont - | isReflexiveCo co = return cont -- Having this at the end makes a huge - -- difference in T12227, for some reason - -- See Note [Optimising reflexivity] - | otherwise = return (CastIt co cont) - -simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr - -> SimplM (DupFlag, StaticEnv, OutExpr) -simplArg env dup_flag arg_env arg - | isSimplified dup_flag - = return (dup_flag, arg_env, arg) - | otherwise - = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg - ; return (Simplified, zapSubstEnv arg_env, arg') } - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplLam env [] body cont - = simplExprF env body cont - -simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) - = do { tick (BetaReduction bndr) - ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } - -simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont, sc_dup = dup }) - | isSimplified dup -- Don't re-simplify if we've simplified it once - -- See Note [Avoiding exponential behaviour] - = do { tick (BetaReduction bndr) - ; (floats1, env') <- simplNonRecX env zapped_bndr arg - ; (floats2, expr') <- simplLam env' bndrs body cont - ; return (floats1 `addFloats` floats2, expr') } - - | otherwise - = do { tick (BetaReduction bndr) - ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont } - where - zapped_bndr -- See Note [Zap unfolding when beta-reducing] - | isId bndr = zapStableUnfolding bndr - | otherwise = bndr - - -- Discard a non-counting tick on a lambda. This may change the - -- cost attribution slightly (moving the allocation of the - -- lambda elsewhere), but we don't care: optimisation changes - -- cost attribution all the time. -simplLam env bndrs body (TickIt tickish cont) - | not (tickishCounts tickish) - = simplLam env bndrs body cont - - -- Not enough args, so there are real lambdas left to put in the result -simplLam env bndrs body cont - = do { (env', bndrs') <- simplLamBndrs env bndrs - ; body' <- simplExpr env' body - ; new_lam <- mkLam env bndrs' body' cont - ; rebuild env' new_lam cont } - -------------- -simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Used for lambda binders. These sometimes have unfoldings added by --- the worker/wrapper pass that must be preserved, because they can't --- be reconstructed from context. For example: --- f x = case x of (a,b) -> fw a b x --- fw a b x{=(a,b)} = ... --- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. -simplLamBndr env bndr - | isId bndr && isFragileUnfolding old_unf -- Special case - = do { (env1, bndr1) <- simplBinder env bndr - ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr - old_unf (idType bndr1) - ; let bndr2 = bndr1 `setIdUnfolding` unf' - ; return (modifyInScope env1 bndr2, bndr2) } - - | otherwise - = simplBinder env bndr -- Normal case - where - old_unf = idUnfolding bndr - -simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs - ------------------- -simplNonRecE :: SimplEnv - -> InId -- The binder, always an Id - -- Never a join point - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> ([InBndr], InExpr) -- Body of the let/lambda - -- \xs.e - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplNonRecE is used for --- * non-top-level non-recursive non-join-point lets in expressions --- * beta reduction --- --- simplNonRec env b (rhs, rhs_se) (bs, body) k --- = let env in --- cont< let b = rhs_se(rhs) in \bs.body > --- --- It deals with strict bindings, via the StrictBind continuation, --- which may abort the whole process --- --- Precondition: rhs satisfies the let/app invariant --- Note [CoreSyn let/app invariant] in CoreSyn --- --- The "body" of the binding comes as a pair of ([InId],InExpr) --- representing a lambda; so we recurse back to simplLam --- Why? Because of the binder-occ-info-zapping done before --- the call to simplLam in simplExprF (Lam ...) - -simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont - | ASSERT( isId bndr && not (isJoinId bndr) ) True - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se - = do { tick (PreInlineUnconditionally bndr) - ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ - simplLam env' bndrs body cont } - - -- Deal with strict bindings - | isStrictId bndr -- Includes coercions, and unlifted types - , sm_case_case (getMode env) - = simplExprF (rhs_se `setInScopeFromE` env) rhs - (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body - , sc_env = env, sc_cont = cont, sc_dup = NoDup }) - - -- Deal with lazy bindings - | otherwise - = ASSERT( not (isTyVar bndr) ) - do { (env1, bndr1) <- simplNonRecBndr env bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing - ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; (floats2, expr') <- simplLam env3 bndrs body cont - ; return (floats1 `addFloats` floats2, expr') } - ------------------- -simplRecE :: SimplEnv - -> [(InId, InExpr)] - -> InExpr - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplRecE is used for --- * non-top-level recursive lets in expressions -simplRecE env pairs body cont - = do { let bndrs = map fst pairs - ; MASSERT(all (not . isJoinId) bndrs) - ; env1 <- simplRecBndrs env bndrs - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs - ; (floats2, expr') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, expr') } - -{- Note [Avoiding exponential behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One way in which we can get exponential behaviour is if we simplify a -big expression, and the re-simplify it -- and then this happens in a -deeply-nested way. So we must be jolly careful about re-simplifying -an expression. That is why completeNonRecX does not try -preInlineUnconditionally. - -Example: - f BIG, where f has a RULE -Then - * We simplify BIG before trying the rule; but the rule does not fire - * We inline f = \x. x True - * So if we did preInlineUnconditionally we'd re-simplify (BIG True) - -However, if BIG has /not/ already been simplified, we'd /like/ to -simplify BIG True; maybe good things happen. That is why - -* simplLam has - - a case for (isSimplified dup), which goes via simplNonRecX, and - - a case for the un-simplified case, which goes via simplNonRecE - -* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, - in at least two places - - In simplCast/addCoerce, where we check for isReflCo - - In rebuildCall we avoid simplifying arguments before we have to - (see Note [Trying rewrite rules]) - - -Note [Zap unfolding when beta-reducing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Lambda-bound variables can have stable unfoldings, such as - $j = \x. \b{Unf=Just x}. e -See Note [Case binders and join points] below; the unfolding for lets -us optimise e better. However when we beta-reduce it we want to -revert to using the actual value, otherwise we can end up in the -stupid situation of - let x = blah in - let b{Unf=Just x} = y - in ...b... -Here it'd be far better to drop the unfolding and use the actual RHS. - -************************************************************************ -* * - Join points -* * -********************************************************************* -} - -{- Note [Rules and unfolding for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - simplExpr (join j x = rhs ) cont - ( {- RULE j (p:ps) = blah -} ) - ( {- StableUnfolding j = blah -} ) - (in blah ) - -Then we will push 'cont' into the rhs of 'j'. But we should *also* push -'cont' into the RHS of - * Any RULEs for j, e.g. generated by SpecConstr - * Any stable unfolding for j, e.g. the result of an INLINE pragma - -Simplifying rules and stable-unfoldings happens a bit after -simplifying the right-hand side, so we remember whether or not it -is a join point, and what 'cont' is, in a value of type MaybeJoinCont - -#13900 wsa caused by forgetting to push 'cont' into the RHS -of a SpecConstr-generated RULE for a join point. --} - -type MaybeJoinCont = Maybe SimplCont - -- Nothing => Not a join point - -- Just k => This is a join binding with continuation k - -- See Note [Rules and unfolding for join points] - -simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont - | ASSERT( isJoinId bndr ) True - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env - = do { tick (PreInlineUnconditionally bndr) - ; simplExprF env' body cont } - - | otherwise - = wrapJoinCont env cont $ \ env cont -> - do { -- We push join_cont into the join RHS and the body; - -- and wrap wrap_cont around the whole thing - ; let res_ty = contResultType cont - ; (env1, bndr1) <- simplNonRecJoinBndr env res_ty bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (Just cont) - ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env - ; (floats2, body') <- simplExprF env3 body cont - ; return (floats1 `addFloats` floats2, body') } - - ------------------- -simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont env cont $ \ env cont -> - do { let bndrs = map fst pairs - res_ty = contResultType cont - ; env1 <- simplRecJoinBndrs env res_ty bndrs - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 NotTopLevel (Just cont) pairs - ; (floats2, body') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, body') } - --------------------- -wrapJoinCont :: SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) - -> SimplM (SimplFloats, OutExpr) --- Deal with making the continuation duplicable if necessary, --- and with the no-case-of-case situation. -wrapJoinCont env cont thing_inside - | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont - - | not (sm_case_case (getMode env)) - -- See Note [Join points wih -fno-case-of-case] - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) - ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 - ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont - ; return (floats2 `addFloats` floats3, expr3) } - - | otherwise - -- Normal case; see Note [Join points and case-of-case] - = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' - ; return (floats1 `addFloats` floats2, result) } - - --------------------- -trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont --- Drop outer context from join point invocation (jump) --- See Note [Join points and case-of-case] - -trimJoinCont _ Nothing cont - = cont -- Not a jump -trimJoinCont var (Just arity) cont - = trim arity cont - where - trim 0 cont@(Stop {}) - = cont - trim 0 cont - = mkBoringStop (contResultType cont) - trim n cont@(ApplyToVal { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } - trim n cont@(ApplyToTy { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } -- join arity counts types! - trim _ cont - = pprPanic "completeCall" $ ppr var $$ ppr cont - - -{- Note [Join points and case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we perform the case-of-case transform (or otherwise push continuations -inward), we want to treat join points specially. Since they're always -tail-called and we want to maintain this invariant, we can do this (for any -evaluation context E): - - E[join j = e - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> f 3] - - --> - - join j = E[e] - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> E[f 3] - -As is evident from the example, there are two components to this behavior: - - 1. When entering the RHS of a join point, copy the context inside. - 2. When a join point is invoked, discard the outer context. - -We need to be very careful here to remain consistent---neither part is -optional! - -We need do make the continuation E duplicable (since we are duplicating it) -with mkDuableCont. - - -Note [Join points wih -fno-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose case-of-case is switched off, and we are simplifying - - case (join j x = in - case y of - A -> j 1 - B -> j 2 - C -> e) of - -Usually, we'd push the outer continuation (case . of ) into -both the RHS and the body of the join point j. But since we aren't doing -case-of-case we may then end up with this totally bogus result - - join x = case of in - case (case y of - A -> j 1 - B -> j 2 - C -> e) of - -This would be OK in the language of the paper, but not in GHC: j is no longer -a join point. We can only do the "push contination into the RHS of the -join point j" if we also push the contination right down to the /jumps/ to -j, so that it can evaporate there. If we are doing case-of-case, we'll get to - - join x = case of in - case y of - A -> j 1 - B -> j 2 - C -> case e of - -which is great. - -Bottom line: if case-of-case is off, we must stop pushing the continuation -inwards altogether at any join point. Instead simplify the (join ... in ...) -with a Stop continuation, and wrap the original continuation around the -outside. Surprisingly tricky! - - -************************************************************************ -* * - Variables -* * -************************************************************************ --} - -simplVar :: SimplEnv -> InVar -> SimplM OutExpr --- Look up an InVar in the environment -simplVar env var - | isTyVar var = return (Type (substTyVar env var)) - | isCoVar var = return (Coercion (substCoVar env var)) - | otherwise - = case substId env var of - ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e - DoneId var1 -> return (Var var1) - DoneEx e _ -> return e - -simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplIdF env var cont - = case substId env var of - ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont - -- Don't trim; haven't already simplified e, - -- so the cont is not embodied in e - - DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont) - - DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont) - -- Note [zapSubstEnv] - -- The template is already simplified, so don't re-substitute. - -- This is VITAL. Consider - -- let x = e in - -- let y = \z -> ...x... in - -- \ x -> ...y... - -- We'll clone the inner \x, adding x->x' in the id_subst - -- Then when we inline y, we must *not* replace x by x' in - -- the inlined copy!! - ---------------------------------------------------------- --- Dealing with a call site - -completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) -completeCall env var cont - | Just expr <- callSiteInline dflags var active_unf - lone_variable arg_infos interesting_cont - -- Inline the variable's RHS - = do { checkedTick (UnfoldingDone var) - ; dump_inline expr cont - ; simplExprF (zapSubstEnv env) expr cont } - - | otherwise - -- Don't inline; instead rebuild the call - = do { rule_base <- getSimplRules - ; let info = mkArgInfo env var (getRules rule_base var) - n_val_args call_cont - ; rebuildCall env info cont } - - where - dflags = seDynFlags env - (lone_variable, arg_infos, call_cont) = contArgs cont - n_val_args = length arg_infos - interesting_cont = interestingCallContext env call_cont - active_unf = activeUnfolding (getMode env) var - - dump_inline unfolding cont - | not (dopt Opt_D_dump_inlinings dflags) = return () - | not (dopt Opt_D_verbose_core2core dflags) - = when (isExternalName (idName var)) $ - liftIO $ printOutputForUser dflags alwaysQualify $ - sep [text "Inlining done:", nest 4 (ppr var)] - | otherwise - = liftIO $ printOutputForUser dflags alwaysQualify $ - sep [text "Inlining done: " <> ppr var, - nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr cont])] - -rebuildCall :: SimplEnv - -> ArgInfo - -> SimplCont - -> SimplM (SimplFloats, OutExpr) --- We decided not to inline, so --- - simplify the arguments --- - try rewrite rules --- - and rebuild - ----------- Bottoming applications -------------- -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see SimplUtils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont - ----------- Try rewrite RULES -------------- --- See Note [Trying rewrite rules] -rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args - , ai_rules = Just (nr_wanted, rules) }) cont - | nr_wanted == 0 || no_more_args - , let info' = info { ai_rules = Nothing } - = -- We've accumulated a simplified call in - -- so try rewrite rules; see Note [RULEs apply to simplified arguments] - -- See also Note [Rules for recursive functions] - do { mb_match <- tryRules env rules fun (reverse rev_args) cont - ; case mb_match of - Just (env', rhs, cont') -> simplExprF env' rhs cont' - Nothing -> rebuildCall env info' cont } - where - no_more_args = case cont of - ApplyToTy {} -> False - ApplyToVal {} -> False - _ -> True - - ----------- Simplify applications and casts -------------- -rebuildCall env info (CastIt co cont) - = rebuildCall env (addCastTo info co) cont - -rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) - = rebuildCall env (addTyArgTo info arg_ty) cont - -rebuildCall env fun_info - (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup_flag, sc_cont = cont }) - | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo fun_info arg) cont - - -- Strict argument - | isStrictArgInfo fun_info - , sm_case_case (getMode env) - = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ - simplExprF (arg_se `setInScopeFromE` env) arg - (StrictArg { sc_fun = fun_info - , sc_dup = Simplified, sc_cont = cont }) - -- Note [Shadowing] - - | otherwise -- Lazy argument - -- DO NOT float anything outside, hence simplExprC - -- There is no benefit (unlike in a let-binding), and we'd - -- have to be very careful about bogus strictness through - -- floating a demanded let. - = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg - (mkLazyArgStop arg_ty (lazyArgContext fun_info)) - ; rebuildCall env (addValArgTo fun_info arg') cont } - where - fun_ty = ai_type fun_info - arg_ty = funArgTy fun_ty - - ----------- No further useful info, revert to generic rebuild ------------ -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont - = rebuild env (argInfoExpr fun rev_args) cont - -{- Note [Trying rewrite rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet -simplified. We want to simplify enough arguments to allow the rules -to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone -is sufficient. Example: class ops - (+) dNumInt e2 e3 -If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the -latter's strictness when simplifying e2, e3. Moreover, suppose we have - RULE f Int = \x. x True - -Then given (f Int e1) we rewrite to - (\x. x True) e1 -without simplifying e1. Now we can inline x into its unique call site, -and absorb the True into it all in the same pass. If we simplified -e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. - -So we try to apply rules if either - (a) no_more_args: we've run out of argument that the rules can "see" - (b) nr_wanted: none of the rules wants any more arguments - - -Note [RULES apply to simplified arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very desirable to try RULES once the arguments have been simplified, because -doing so ensures that rule cascades work in one pass. Consider - {-# RULES g (h x) = k x - f (k x) = x #-} - ...f (g (h x))... -Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If -we match f's rules against the un-simplified RHS, it won't match. This -makes a particularly big difference when superclass selectors are involved: - op ($p1 ($p2 (df d))) -We want all this to unravel in one sweep. - -Note [Avoid redundant simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because RULES apply to simplified arguments, there's a danger of repeatedly -simplifying already-simplified arguments. An important example is that of - (>>=) d e1 e2 -Here e1, e2 are simplified before the rule is applied, but don't really -participate in the rule firing. So we mark them as Simplified to avoid -re-simplifying them. - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -This part of the simplifier may break the no-shadowing invariant -Consider - f (...(\a -> e)...) (case y of (a,b) -> e') -where f is strict in its second arg -If we simplify the innermost one first we get (...(\a -> e)...) -Simplifying the second arg makes us float the case out, so we end up with - case y of (a,b) -> f (...(\a -> e)...) e' -So the output does not have the no-shadowing invariant. However, there is -no danger of getting name-capture, because when the first arg was simplified -we used an in-scope set that at least mentioned all the variables free in its -static environment, and that is enough. - -We can't just do innermost first, or we'd end up with a dual problem: - case x of (a,b) -> f e (...(\a -> e')...) - -I spent hours trying to recover the no-shadowing invariant, but I just could -not think of an elegant way to do it. The simplifier is already knee-deep in -continuations. We have to keep the right in-scope set around; AND we have -to get the effect that finding (error "foo") in a strict arg position will -discard the entire application and replace it with (error "foo"). Getting -all this at once is TOO HARD! - - -************************************************************************ -* * - Rewrite rules -* * -************************************************************************ --} - -tryRules :: SimplEnv -> [CoreRule] - -> Id -> [ArgSpec] - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) - -tryRules env rules fn args call_cont - | null rules - = return Nothing - -{- Disabled until we fix #8326 - | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] - , [_type_arg, val_arg] <- args - , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont - , isDeadBinder bndr - = do { let enum_to_tag :: CoreAlt -> CoreAlt - -- Takes K -> e into tagK# -> e - -- where tagK# is the tag of constructor K - enum_to_tag (DataAlt con, [], rhs) - = ASSERT( isEnumerationTyCon (dataConTyCon con) ) - (LitAlt tag, [], rhs) - where - tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG)) - enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) - - new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts - new_bndr = setIdType bndr intPrimTy - -- The binder is dead, but should have the right type - ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } --} - - | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env) - (activeRule (getMode env)) fn - (argInfoAppArgs args) rules - -- Fire a rule for the function - = do { checkedTick (RuleFired (ruleName rule)) - ; let cont' = pushSimplifiedArgs zapped_env - (drop (ruleArity rule) args) - call_cont - -- (ruleArity rule) says how - -- many args the rule consumed - - occ_anald_rhs = occurAnalyseExpr rule_rhs - -- See Note [Occurrence-analyse after rule firing] - ; dump rule rule_rhs - ; return (Just (zapped_env, occ_anald_rhs, cont')) } - -- The occ_anald_rhs and cont' are all Out things - -- hence zapping the environment - - | otherwise -- No rule fires - = do { nodump -- This ensures that an empty file is written - ; return Nothing } - - where - dflags = seDynFlags env - zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] - - printRuleModule rule - = parens (maybe (text "BUILTIN") - (pprModuleName . moduleName) - (ruleModule rule)) - - dump rule rule_rhs - | dopt Opt_D_dump_rule_rewrites dflags - = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat - [ text "Rule:" <+> ftext (ruleName rule) - , text "Module:" <+> printRuleModule rule - , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> pprCoreExpr rule_rhs - , text "Cont: " <+> ppr call_cont ] - - | dopt Opt_D_dump_rule_firings dflags - = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ - ftext (ruleName rule) - <+> printRuleModule rule - - | otherwise - = return () - - nodump - | dopt Opt_D_dump_rule_rewrites dflags - = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty - - | dopt Opt_D_dump_rule_firings dflags - = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty - - | otherwise - = return () - - log_rule dflags flag hdr details - = liftIO . dumpSDoc dflags alwaysQualify flag "" $ - sep [text hdr, nest 4 details] - -trySeqRules :: SimplEnv - -> OutExpr -> InExpr -- Scrutinee and RHS - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) --- See Note [User-defined RULES for seq] -trySeqRules in_env scrut rhs cont - = do { rule_base <- getSimplRules - ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } - where - no_cast_scrut = drop_casts scrut - scrut_ty = exprType no_cast_scrut - seq_id_ty = idType seqId - res1_ty = piResultTy seq_id_ty rhs_rep - res2_ty = piResultTy res1_ty scrut_ty - rhs_ty = substTy in_env (exprType rhs) - rhs_rep = getRuntimeRep rhs_ty - out_args = [ TyArg { as_arg_ty = rhs_rep - , as_hole_ty = seq_id_ty } - , TyArg { as_arg_ty = scrut_ty - , as_hole_ty = res1_ty } - , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = res2_ty } - , ValArg { as_arg = no_cast_scrut - , as_dmd = seqDmd } ] - rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs - , sc_env = in_env, sc_cont = cont } - -- Lazily evaluated, so we don't do most of this - - drop_casts (Cast e _) = drop_casts e - drop_casts e = e - -{- Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - case (scrut |> co) of _ -> rhs -look for rules that match the expression - seq @t1 @t2 scrut -where scrut :: t1 - rhs :: t2 - -If you find a match, rewrite it, and apply to 'rhs'. - -Notice that we can simply drop casts on the fly here, which -makes it more likely that a rule will match. - -See Note [User-defined RULES for seq] in MkId. - -Note [Occurrence-analyse after rule firing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After firing a rule, we occurrence-analyse the instantiated RHS before -simplifying it. Usually this doesn't make much difference, but it can -be huge. Here's an example (simplCore/should_compile/T7785) - - map f (map f (map f xs) - -= -- Use build/fold form of map, twice - map f (build (\cn. foldr (mapFB c f) n - (build (\cn. foldr (mapFB c f) n xs)))) - -= -- Apply fold/build rule - map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) - -= -- Beta-reduce - -- Alas we have no occurrence-analysed, so we don't know - -- that c is used exactly once - map f (build (\cn. let c1 = mapFB c f in - foldr (mapFB c1 f) n xs)) - -= -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) - -- We can do this because (mapFB c n) is a PAP and hence expandable - map f (build (\cn. let c1 = mapFB c n in - foldr (mapFB c (f.f)) n x)) - -This is not too bad. But now do the same with the outer map, and -we get another use of mapFB, and t can interact with /both/ remaining -mapFB calls in the above expression. This is stupid because actually -that 'c1' binding is dead. The outer map introduces another c2. If -there is a deep stack of maps we get lots of dead bindings, and lots -of redundant work as we repeatedly simplify the result of firing rules. - -The easy thing to do is simply to occurrence analyse the result of -the rule firing. Note that this occ-anals not only the RHS of the -rule, but also the function arguments, which by now are OutExprs. -E.g. - RULE f (g x) = x+1 - -Call f (g BIG) --> (\x. x+1) BIG - -The rule binders are lambda-bound and applied to the OutExpr arguments -(here BIG) which lack all internal occurrence info. - -Is this inefficient? Not really: we are about to walk over the result -of the rule firing to simplify it, so occurrence analysis is at most -a constant factor. - -Possible improvement: occ-anal the rules when putting them in the -database; and in the simplifier just occ-anal the OutExpr arguments. -But that's more complicated and the rule RHS is usually tiny; so I'm -just doing the simple thing. - -Historical note: previously we did occ-anal the rules in Rule.hs, -but failed to occ-anal the OutExpr arguments, which led to the -nasty performance problem described above. - - -Note [Optimising tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an enumeration data type: - - data Foo = A | B | C - -Then we want to transform - - case tagToEnum# x of ==> case x of - A -> e1 DEFAULT -> e1 - B -> e2 1# -> e2 - C -> e3 2# -> e3 - -thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT -alternative we retain it (remember it comes first). If not the case must -be exhaustive, and we reflect that in the transformed version by adding -a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. -See #8317. - -Note [Rules for recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that we shouldn't apply rules for a loop breaker: -doing so might give rise to an infinite loop, because a RULE is -rather like an extra equation for the function: - RULE: f (g x) y = x+y - Eqn: f a y = a-y - -But it's too drastic to disable rules for loop breakers. -Even the foldr/build rule would be disabled, because foldr -is recursive, and hence a loop breaker: - foldr k z (build g) = g k z -So it's up to the programmer: rules can cause divergence - - -************************************************************************ -* * - Rebuilding a case expression -* * -************************************************************************ - -Note [Case elimination] -~~~~~~~~~~~~~~~~~~~~~~~ -The case-elimination transformation discards redundant case expressions. -Start with a simple situation: - - case x# of ===> let y# = x# in e - y# -> e - -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -The code in SimplUtils.prepareAlts has the effect of generalise this -idea to look for a case where we're scrutinising a variable, and we -know that only the default case can match. For example: - - case x of - 0# -> ... - DEFAULT -> ...(case x of - 0# -> ... - DEFAULT -> ...) ... - -Here the inner case is first trimmed to have only one alternative, the -DEFAULT, after which it's an instance of the previous case. This -really only shows up in eliminating error-checking code. - -Note that SimplUtils.mkCase combines identical RHSs. So - - case e of ===> case e of DEFAULT -> r - True -> r - False -> r - -Now again the case may be elminated by the CaseElim transformation. -This includes things like (==# a# b#)::Bool so that we simplify - case ==# a# b# of { True -> x; False -> x } -to just - x -This particular example shows up in default methods for -comparison operations (e.g. in (>=) for Int.Int32) - -Note [Case to let transformation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a case over a lifted type has a single alternative, and is being -used as a strict 'let' (all isDeadBinder bndrs), we may want to do -this transformation: - - case e of r ===> let r = e in ...r... - _ -> ...r... - -We treat the unlifted and lifted cases separately: - -* Unlifted case: 'e' satisfies exprOkForSpeculation - (ok-for-spec is needed to satisfy the let/app invariant). - This turns case a +# b of r -> ...r... - into let r = a +# b in ...r... - and thence .....(a +# b).... - - However, if we have - case indexArray# a i of r -> ...r... - we might like to do the same, and inline the (indexArray# a i). - But indexArray# is not okForSpeculation, so we don't build a let - in rebuildCase (lest it get floated *out*), so the inlining doesn't - happen either. Annoying. - -* Lifted case: we need to be sure that the expression is already - evaluated (exprIsHNF). If it's not already evaluated - - we risk losing exceptions, divergence or - user-specified thunk-forcing - - even if 'e' is guaranteed to converge, we don't want to - create a thunk (call by need) instead of evaluating it - right away (call by value) - - However, we can turn the case into a /strict/ let if the 'r' is - used strictly in the body. Then we won't lose divergence; and - we won't build a thunk because the let is strict. - See also Note [Case-to-let for strictly-used binders] - - NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore. - We want to turn - case (absentError "foo") of r -> ...MkT r... - into - let r = absentError "foo" in ...MkT r... - - -Note [Case-to-let for strictly-used binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have this: - case of r { _ -> ..r.. } - -where 'r' is used strictly in (..r..), we can safely transform to - let r = in ...r... - -This is a Good Thing, because 'r' might be dead (if the body just -calls error), or might be used just once (in which case it can be -inlined); or we might be able to float the let-binding up or down. -E.g. #15631 has an example. - -Note that this can change the error behaviour. For example, we might -transform - case x of { _ -> error "bad" } - --> error "bad" -which is might be puzzling if 'x' currently lambda-bound, but later gets -let-bound to (error "good"). - -Nevertheless, the paper "A semantics for imprecise exceptions" allows -this transformation. If you want to fix the evaluation order, use -'pseq'. See #8900 for an example where the loss of this -transformation bit us in practice. - -See also Note [Empty case alternatives] in CoreSyn. - -Historical notes - -There have been various earlier versions of this patch: - -* By Sept 18 the code looked like this: - || scrut_is_demanded_var scrut - - scrut_is_demanded_var :: CoreExpr -> Bool - scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s - scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) - scrut_is_demanded_var _ = False - - This only fired if the scrutinee was a /variable/, which seems - an unnecessary restriction. So in #15631 I relaxed it to allow - arbitrary scrutinees. Less code, less to explain -- but the change - had 0.00% effect on nofib. - -* Previously, in Jan 13 the code looked like this: - || case_bndr_evald_next rhs - - case_bndr_evald_next :: CoreExpr -> Bool - -- See Note [Case binder next] - case_bndr_evald_next (Var v) = v == case_bndr - case_bndr_evald_next (Cast e _) = case_bndr_evald_next e - case_bndr_evald_next (App e _) = case_bndr_evald_next e - case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e - case_bndr_evald_next _ = False - - This patch was part of fixing #7542. See also - Note [Eta reduction of an eval'd function] in CoreUtils.) - - -Further notes about case elimination -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: test :: Integer -> IO () - test = print - -Turns out that this compiles to: - Print.test - = \ eta :: Integer - eta1 :: Void# -> - case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> - case hPutStr stdout - (PrelNum.jtos eta ($w[] @ Char)) - eta1 - of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} - -Notice the strange '<' which has no effect at all. This is a funny one. -It started like this: - -f x y = if x < 0 then jtos x - else if y==0 then "" else jtos x - -At a particular call site we have (f v 1). So we inline to get - - if v < 0 then jtos x - else if 1==0 then "" else jtos x - -Now simplify the 1==0 conditional: - - if v<0 then jtos v else jtos v - -Now common-up the two branches of the case: - - case (v<0) of DEFAULT -> jtos v - -Why don't we drop the case? Because it's strict in v. It's technically -wrong to drop even unnecessary evaluations, and in practice they -may be a result of 'seq' so we *definitely* don't want to drop those. -I don't really know how to improve this situation. - - -Note [FloatBinds from constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have FloatBinds coming from the constructor wrapper -(as in Note [exprIsConApp_maybe on data constructors with wrappers]), -ew cannot float past them. We'd need to float the FloatBind -together with the simplify floats, unfortunately the -simplifier doesn't have case-floats. The simplest thing we can -do is to wrap all the floats here. The next iteration of the -simplifier will take care of all these cases and lets. - -Given data T = MkT !Bool, this allows us to simplify -case $WMkT b of { MkT x -> f x } -to -case b of { b' -> f b' }. - -We could try and be more clever (like maybe wfloats only contain -let binders, so we could float them). But the need for the -extra complication is not clear. --} - ---------------------------------------------------------- --- Eliminate the case if possible - -rebuildCase, reallyRebuildCase - :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Alternatives (increasing order) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --------------------------------------------------- --- 1. Eliminate the case if there's a known constructor --------------------------------------------------- - -rebuildCase env scrut case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors - -- because literals are inlined more vigorously - , not (litIsLifted lit) - = do { tick (KnownBranch case_bndr) - ; case findAlt (LitAlt lit) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } - - | Just (in_scope', wfloats, con, ty_args, other_args) - <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - , let env0 = setInScopeSet env in_scope' - = do { tick (KnownBranch case_bndr) - ; case findAlt (DataAlt con) alts of - Nothing -> missingAlt env0 case_bndr alts cont - Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) - `mkTyApps` ty_args - `mkApps` other_args - in simple_rhs env0 wfloats con_app bs rhs - Just (_, bs, rhs) -> knownCon env0 scrut wfloats con ty_args other_args - case_bndr bs rhs cont - } - where - simple_rhs env wfloats scrut' bs rhs = - ASSERT( null bs ) - do { (floats1, env') <- simplNonRecX env case_bndr scrut' - -- scrut is a constructor application, - -- hence satisfies let/app invariant - ; (floats2, expr') <- simplExprF env' rhs cont - ; case wfloats of - [] -> return (floats1 `addFloats` floats2, expr') - _ -> return - -- See Note [FloatBinds from constructor wrappers] - ( emptyFloats env, - MkCore.wrapFloats wfloats $ - wrapFloats (floats1 `addFloats` floats2) expr' )} - - --------------------------------------------------- --- 2. Eliminate the case if scrutinee is evaluated --------------------------------------------------- - -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont - -- See if we can get rid of the case altogether - -- See Note [Case elimination] - -- mkCase made sure that if all the alternatives are equal, - -- then there is now only one (DEFAULT) rhs - - -- 2a. Dropping the case altogether, if - -- a) it binds nothing (so it's really just a 'seq') - -- b) evaluating the scrutinee has no side effects - | is_plain_seq - , exprOkForSideEffects scrut - -- The entire case is dead, so we can drop it - -- if the scrutinee converges without having imperative - -- side effects or raising a Haskell exception - -- See Note [PrimOp can_fail and has_side_effects] in PrimOp - = simplExprF env rhs cont - - -- 2b. Turn the case into a let, if - -- a) it binds only the case-binder - -- b) unlifted case: the scrutinee is ok-for-speculation - -- lifted case: the scrutinee is in HNF (or will later be demanded) - -- See Note [Case to let transformation] - | all_dead_bndrs - , doCaseToLet scrut case_bndr - = do { tick (CaseElim case_bndr) - ; (floats1, env') <- simplNonRecX env case_bndr scrut - ; (floats2, expr') <- simplExprF env' rhs cont - ; return (floats1 `addFloats` floats2, expr') } - - -- 2c. Try the seq rules if - -- a) it binds only the case binder - -- b) a rule for seq applies - -- See Note [User-defined RULES for seq] in MkId - | is_plain_seq - = do { mb_rule <- trySeqRules env scrut rhs cont - ; case mb_rule of - Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } - where - all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] - is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect - -rebuildCase env scrut case_bndr alts cont - = reallyRebuildCase env scrut case_bndr alts cont - - -doCaseToLet :: OutExpr -- Scrutinee - -> InId -- Case binder - -> Bool --- The situation is case scrut of b { DEFAULT -> body } --- Can we transform thus? let { b = scrut } in body -doCaseToLet scrut case_bndr - | isTyCoVar case_bndr -- Respect CoreSyn - = isTyCoArg scrut -- Note [CoreSyn type and coercion invariant] - - | isUnliftedType (idType case_bndr) - = exprOkForSpeculation scrut - - | otherwise -- Scrut has a lifted type - = exprIsHNF scrut - || isStrictDmd (idDemandInfo case_bndr) - -- See Note [Case-to-let for strictly-used binders] - --------------------------------------------------- --- 3. Catch-all case --------------------------------------------------- - -reallyRebuildCase env scrut case_bndr alts cont - | not (sm_case_case (getMode env)) - = do { case_expr <- simplAlts env scrut case_bndr alts - (mkBoringStop (contHoleType cont)) - ; rebuild env case_expr cont } - - | otherwise - = do { (floats, cont') <- mkDupableCaseCont env alts cont - ; case_expr <- simplAlts (env `setInScopeFromF` floats) - scrut case_bndr alts cont' - ; return (floats, case_expr) } - -{- -simplCaseBinder checks whether the scrutinee is a variable, v. If so, -try to eliminate uses of v in the RHSs in favour of case_bndr; that -way, there's a chance that v will now only be used once, and hence -inlined. - -Historical note: we use to do the "case binder swap" in the Simplifier -so there were additional complications if the scrutinee was a variable. -Now the binder-swap stuff is done in the occurrence analyser; see -OccurAnal Note [Binder swap]. - -Note [knownCon occ info] -~~~~~~~~~~~~~~~~~~~~~~~~ -If the case binder is not dead, then neither are the pattern bound -variables: - case of x { (a,b) -> - case x of { (p,q) -> p } } -Here (a,b) both look dead, but come alive after the inner case is eliminated. -The point is that we bring into the envt a binding - let x = (a,b) -after the outer case, and that makes (a,b) alive. At least we do unless -the case binder is guaranteed dead. - -Note [Case alternative occ info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are simply reconstructing a case (the common case), we always -zap the occurrence info on the binders in the alternatives. Even -if the case binder is dead, the scrutinee is usually a variable, and *that* -can bring the case-alternative binders back to life. -See Note [Add unfolding for scrutinee] - -Note [Improving seq] -~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: * -> * - type instance F Int = Int - -We'd like to transform - case e of (x :: F Int) { DEFAULT -> rhs } -===> - case e `cast` co of (x'::Int) - I# x# -> let x = x' `cast` sym co - in rhs - -so that 'rhs' can take advantage of the form of x'. Notice that Note -[Case of cast] (in OccurAnal) may then apply to the result. - -We'd also like to eliminate empty types (#13468). So if - - data Void - type instance F Bool = Void - -then we'd like to transform - case (x :: F Bool) of { _ -> error "urk" } -===> - case (x |> co) of (x' :: Void) of {} - -Nota Bene: we used to have a built-in rule for 'seq' that dropped -casts, so that - case (x |> co) of { _ -> blah } -dropped the cast; in order to improve the chances of trySeqRules -firing. But that works in the /opposite/ direction to Note [Improving -seq] so there's a danger of flip/flopping. Better to make trySeqRules -insensitive to the cast, which is now is. - -The need for [Improving seq] showed up in Roman's experiments. Example: - foo :: F Int -> Int -> Int - foo t n = t `seq` bar n - where - bar 0 = 0 - bar n = bar (n - case t of TI i -> i) -Here we'd like to avoid repeated evaluating t inside the loop, by -taking advantage of the `seq`. - -At one point I did transformation in LiberateCase, but it's more -robust here. (Otherwise, there's a danger that we'll simply drop the -'seq' altogether, before LiberateCase gets to see it.) --} - -simplAlts :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Non-empty - -> SimplCont - -> SimplM OutExpr -- Returns the complete simplified case expression - -simplAlts env0 scrut case_bndr alts cont' - = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr - , text "cont':" <+> ppr cont' - , text "in_scope" <+> ppr (seInScope env0) ]) - ; (env1, case_bndr1) <- simplBinder env0 case_bndr - ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding - env2 = modifyInScope env1 case_bndr2 - -- See Note [Case binder evaluated-ness] - - ; fam_envs <- getFamEnvs - ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut - case_bndr case_bndr2 alts - - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts - -- NB: it's possible that the returned in_alts is empty: this is handled - -- by the caller (rebuildCase) in the missingAlt function - - ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts - ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ - - ; let alts_ty' = contResultType cont' - -- See Note [Avoiding space leaks in OutType] - ; seqType alts_ty' `seq` - mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' } - - ------------------------------------- -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv - -> OutExpr -> InId -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) --- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - -improveSeq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - - ------------------------------------- -simplAlt :: SimplEnv - -> Maybe OutExpr -- The scrutinee - -> [AltCon] -- These constructors can't be present when - -- matching the DEFAULT alternative - -> OutId -- The case binder - -> SimplCont - -> InAlt - -> SimplM OutAlt - -simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) - = ASSERT( null bndrs ) - do { let env' = addBinderUnfolding env case_bndr' - (mkOtherCon imposs_deflt_cons) - -- Record the constructors that the case-binder *can't* be. - ; rhs' <- simplExprC env' rhs cont' - ; return (DEFAULT, [], rhs') } - -simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) - = ASSERT( null bndrs ) - do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) - ; rhs' <- simplExprC env' rhs cont' - ; return (LitAlt lit, [], rhs') } - -simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) - = do { -- See Note [Adding evaluatedness info to pattern-bound variables] - let vs_with_evals = addEvals scrut' con vs - ; (env', vs') <- simplLamBndrs env vs_with_evals - - -- Bind the case-binder to (con args) - ; let inst_tys' = tyConAppArgs (idType case_bndr') - con_app :: OutExpr - con_app = mkConApp2 con inst_tys' vs' - - ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app - ; rhs' <- simplExprC env'' rhs cont' - ; return (DataAlt con, vs', rhs') } - -{- Note [Adding evaluatedness info to pattern-bound variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -addEvals records the evaluated-ness of the bound variables of -a case pattern. This is *important*. Consider - - data T = T !Int !Int - - case x of { T a b -> T (a+1) b } - -We really must record that b is already evaluated so that we don't -go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in MkId.hs - -NB: simplLamBinders preserves this eval info - -In addition to handling data constructor fields with !s, addEvals -also records the fact that the result of seq# is always in WHNF. -See Note [seq# magic] in PrelRules. Example (#15226): - - case seq# v s of - (# s', v' #) -> E - -we want the compiler to be aware that v' is in WHNF in E. - -Open problem: we don't record that v itself is in WHNF (and we can't -do it here). The right thing is to do some kind of binder-swap; -see #15226 for discussion. --} - -addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] --- See Note [Adding evaluatedness info to pattern-bound variables] -addEvals scrut con vs - -- Deal with seq# applications - | Just scr <- scrut - , isUnboxedTupleCon con - , [s,x] <- vs - -- Use stripNArgs rather than collectArgsTicks to avoid building - -- a list of arguments only to throw it away immediately. - , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f - , let x' = zapIdOccInfoAndSetEvald MarkedStrict x - = [s, x'] - - -- Deal with banged datacon fields -addEvals _scrut con vs = go vs the_strs - where - the_strs = dataConRepStrictness con - - go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs - go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs - go _ _ = pprPanic "Simplify.addEvals" - (ppr con $$ - ppr vs $$ - ppr_with_length (map strdisp the_strs) $$ - ppr_with_length (dataConRepArgTys con) $$ - ppr_with_length (dataConRepStrictness con)) - where - ppr_with_length list - = ppr list <+> parens (text "length =" <+> ppr (length list)) - strdisp MarkedStrict = "MarkedStrict" - strdisp NotMarkedStrict = "NotMarkedStrict" - -zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id -zapIdOccInfoAndSetEvald str v = - setCaseBndrEvald str $ -- Add eval'dness info - zapIdOccInfo v -- And kill occ info; - -- see Note [Case alternative occ info] - -addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv -addAltUnfoldings env scrut case_bndr con_app - = do { let con_app_unf = mk_simple_unf con_app - env1 = addBinderUnfolding env case_bndr con_app_unf - - -- See Note [Add unfolding for scrutinee] - env2 = case scrut of - Just (Var v) -> addBinderUnfolding env1 v con_app_unf - Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ - mk_simple_unf (Cast con_app (mkSymCo co)) - _ -> env1 - - ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) - ; return env2 } - where - mk_simple_unf = mkSimpleUnfolding (seDynFlags env) - -addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv -addBinderUnfolding env bndr unf - | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf - = WARN( not (eqType (idType bndr) (exprType tmpl)), - ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) - modifyInScope env (bndr `setIdUnfolding` unf) - - | otherwise - = modifyInScope env (bndr `setIdUnfolding` unf) - -zapBndrOccInfo :: Bool -> Id -> Id --- Consider case e of b { (a,b) -> ... } --- Then if we bind b to (a,b) in "...", and b is not dead, --- then we must zap the deadness info on a,b -zapBndrOccInfo keep_occ_info pat_id - | keep_occ_info = pat_id - | otherwise = zapIdOccInfo pat_id - -{- Note [Case binder evaluated-ness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin on a (OtherCon []) unfolding to the case-binder of a Case, -even though it'll be over-ridden in every case alternative with a more -informative unfolding. Why? Because suppose a later, less clever, pass -simply replaces all occurrences of the case binder with the binder itself; -then Lint may complain about the let/app invariant. Example - case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in .... - ; K -> blah } - -The let/app invariant requires that y is evaluated in the call to -reallyUnsafePtrEq#, which it is. But we still want that to be true if we -propagate binders to occurrences. - -This showed up in #13027. - -Note [Add unfolding for scrutinee] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general it's unlikely that a variable scrutinee will appear -in the case alternatives case x of { ...x unlikely to appear... } -because the binder-swap in OccAnal has got rid of all such occurrences -See Note [Binder swap] in OccAnal. - -BUT it is still VERY IMPORTANT to add a suitable unfolding for a -variable scrutinee, in simplAlt. Here's why - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -There is no occurrence of 'b' in the (...(f y)...). But y gets -the unfolding (a,b), and *that* mentions b. If f has a RULE - RULE f (p, I# q) = ... -we want that rule to match, so we must extend the in-scope env with a -suitable unfolding for 'y'. It's *essential* for rule matching; but -it's also good for case-elimintation -- suppose that 'f' was inlined -and did multi-level case analysis, then we'd solve it in one -simplifier sweep instead of two. - -Exactly the same issue arises in SpecConstr; -see Note [Add scrutinee to ValueEnv too] in SpecConstr - -HOWEVER, given - case x of y { Just a -> r1; Nothing -> r2 } -we do not want to add the unfolding x -> y to 'x', which might seem cool, -since 'y' itself has different unfoldings in r1 and r2. Reason: if we -did that, we'd have to zap y's deadness info and that is a very useful -piece of information. - -So instead we add the unfolding x -> Just a, and x -> Nothing in the -respective RHSs. - - -************************************************************************ -* * -\subsection{Known constructor} -* * -************************************************************************ - -We are a bit careful with occurrence info. Here's an example - - (\x* -> case x of (a*, b) -> f a) (h v, e) - -where the * means "occurs once". This effectively becomes - case (h v, e) of (a*, b) -> f a) -and then - let a* = h v; b = e in f a -and then - f (h v) - -All this should happen in one sweep. --} - -knownCon :: SimplEnv - -> OutExpr -- The scrutinee - -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) - -> InId -> [InBndr] -> InExpr -- The alternative - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont - = do { (floats1, env1) <- bind_args env bs dc_args - ; (floats2, env2) <- bind_case_bndr env1 - ; (floats3, expr') <- simplExprF env2 rhs cont - ; case dc_floats of - [] -> - return (floats1 `addFloats` floats2 `addFloats` floats3, expr') - _ -> - return ( emptyFloats env - -- See Note [FloatBinds from constructor wrappers] - , MkCore.wrapFloats dc_floats $ - wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } - where - zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId - - -- Ugh! - bind_args env' [] _ = return (emptyFloats env', env') - - bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyVar b ) - bind_args (extendTvSubst env' b ty) bs' args - - bind_args env' (b:bs') (Coercion co : args) - = ASSERT( isCoVar b ) - bind_args (extendCvSubst env' b co) bs' args - - bind_args env' (b:bs') (arg : args) - = ASSERT( isId b ) - do { let b' = zap_occ b - -- Note that the binder might be "dead", because it doesn't - -- occur in the RHS; and simplNonRecX may therefore discard - -- it via postInlineUnconditionally. - -- Nevertheless we must keep it if the case-binder is alive, - -- because it may be used in the con_app. See Note [knownCon occ info] - ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let/app invariant - ; (floats2, env3) <- bind_args env2 bs' args - ; return (floats1 `addFloats` floats2, env3) } - - bind_args _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ - text "scrut:" <+> ppr scrut - - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bind_case_bndr env - | isDeadBinder bndr = return (emptyFloats env, env) - | exprIsTrivial scrut = return (emptyFloats env - , extendIdSubst env bndr (DoneEx scrut Nothing)) - | otherwise = do { dc_args <- mapM (simplVar env) bs - -- dc_ty_args are aready OutTypes, - -- but bs are InBndrs - ; let con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` dc_args - ; simplNonRecX env bndr con_app } - -------------------- -missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -- This isn't strictly an error, although it is unusual. - -- It's possible that the simplifier might "see" that - -- an inner case has no accessible alternatives before - -- it "sees" that the entire branch of an outer case is - -- inaccessible. So we simply put an error case here instead. -missingAlt env case_bndr _ cont - = WARN( True, text "missingAlt" <+> ppr case_bndr ) - -- See Note [Avoiding space leaks in OutType] - let cont_ty = contResultType cont - in seqType cont_ty `seq` - return (emptyFloats env, mkImpossibleExpr cont_ty) - -{- -************************************************************************ -* * -\subsection{Duplicating continuations} -* * -************************************************************************ - -Consider - let x* = case e of { True -> e1; False -> e2 } - in b -where x* is a strict binding. Then mkDupableCont will be given -the continuation - case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop -and will split it into - dupable: case [] of { True -> $j1; False -> $j2 } ; stop - join floats: $j1 = e1, $j2 = e2 - non_dupable: let x* = [] in b; stop - -Putting this back together would give - let x* = let { $j1 = e1; $j2 = e2 } in - case e of { True -> $j1; False -> $j2 } - in b -(Of course we only do this if 'e' wants to duplicate that continuation.) -Note how important it is that the new join points wrap around the -inner expression, and not around the whole thing. - -In contrast, any let-bindings introduced by mkDupableCont can wrap -around the entire thing. - -Note [Bottom alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have - case (case x of { A -> error .. ; B -> e; C -> error ..) - of alts -then we can just duplicate those alts because the A and C cases -will disappear immediately. This is more direct than creating -join points and inlining them away. See #4930. --} - --------------------- -mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (SimplFloats, SimplCont) -mkDupableCaseCont env alts cont - | altsWouldDup alts = mkDupableCont env cont - | otherwise = return (emptyFloats env, cont) - -altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative -altsWouldDup [] = False -- See Note [Bottom alternatives] -altsWouldDup [_] = False -altsWouldDup (alt:alts) - | is_bot_alt alt = altsWouldDup alts - | otherwise = not (all is_bot_alt alts) - where - is_bot_alt (_,_,rhs) = exprIsBottom rhs - -------------------------- -mkDupableCont :: SimplEnv - -> SimplCont - -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with - -- extra let/join-floats and in-scope variables - , SimplCont) -- dup_cont: duplicable continuation -mkDupableCont env cont - = mkDupableContWithDmds env (repeat topDmd) cont - -mkDupableContWithDmds - :: SimplEnv -> [Demand] -- Demands on arguments; always infinite - -> SimplCont -> SimplM ( SimplFloats, SimplCont) - -mkDupableContWithDmds env _ cont - | contIsDupable cont - = return (emptyFloats env, cont) - -mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn - -mkDupableContWithDmds env dmds (CastIt ty cont) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, CastIt ty cont') } - --- Duplicating ticks for now, not sure if this is good or not -mkDupableContWithDmds env dmds (TickIt t cont) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, TickIt t cont') } - -mkDupableContWithDmds env _ - (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs - , sc_body = body, sc_env = se, sc_cont = cont}) --- See Note [Duplicating StrictBind] --- K[ let x = <> in b ] --> join j x = K[ b ] --- j <> - = do { let sb_env = se `setInScopeFromE` env - ; (sb_env1, bndr') <- simplBinder sb_env bndr - ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont - -- No need to use mkDupableCont before simplLam; we - -- use cont once here, and then share the result if necessary - - ; let join_body = wrapFloats floats1 join_inner - res_ty = contResultType cont - - ; mkDupableStrictBind env bndr' join_body res_ty } - -mkDupableContWithDmds env _ - (StrictArg { sc_fun = fun, sc_cont = cont }) - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - | thumbsUpPlanA cont - = -- Use Plan A of Note [Duplicating StrictArg] - do { let (_ : dmds) = ai_dmds fun - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont - -- Use the demands from the function to add the right - -- demand info on any bindings we make for further args - ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env)) - (ai_args fun) - ; return ( foldl' addLetFloats floats1 floats_s - , StrictArg { sc_fun = fun { ai_args = args' } - , sc_cont = cont' - , sc_dup = OkToDup} ) } - - | otherwise - = -- Use Plan B of Note [Duplicating StrictArg] - -- K[ f a b <> ] --> join j x = K[ f a b x ] - -- j <> - do { let fun_ty = ai_type fun - ; let arg_ty = funArgTy fun_ty - rhs_ty = contResultType cont - ; arg_bndr <- newId (fsLit "arg") arg_ty -- ToDo: check this linearity argument - ; let env' = env `addNewInScopeIds` [arg_bndr] - ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr)) cont - ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } - where - thumbsUpPlanA (StrictArg {}) = False - thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k - thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k - thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k - thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k - thumbsUpPlanA (Select {}) = True - thumbsUpPlanA (StrictBind {}) = True - thumbsUpPlanA (Stop {}) = True - -mkDupableContWithDmds env dmds - (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, ApplyToTy { sc_cont = cont' - , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } - -mkDupableContWithDmds env dmds - (ApplyToVal { sc_arg = arg, sc_dup = dup - , sc_env = se, sc_cont = cont }) - = -- e.g. [...hole...] (...arg...) - -- ==> - -- let a = ...arg... - -- in [...hole...] a - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont - ; let env' = env `setInScopeFromF` floats1 - ; (_, se', arg') <- simplArg env' dup se arg - ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel dmd (fsLit "karg") arg' - ; let all_floats = floats1 `addLetFloats` let_floats2 - ; return ( all_floats - , ApplyToVal { sc_arg = arg'' - , sc_env = se' `setInScopeFromF` all_floats - -- Ensure that sc_env includes the free vars of - -- arg'' in its in-scope set, even if makeTrivial - -- has turned arg'' into a fresh variable - -- See Note [StaticEnv invariant] in SimplUtils - , sc_dup = OkToDup, sc_cont = cont' }) } - -mkDupableContWithDmds env _ - (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = -- e.g. (case [...hole...] of { pi -> ei }) - -- ===> - -- let ji = \xij -> ei - -- in case [...hole...] of { pi -> ji xij } - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { tick (CaseOfCase case_bndr) - ; (floats, alt_cont) <- mkDupableCaseCont env alts cont - -- NB: We call mkDupableCaseCont here to make cont duplicable - -- (if necessary, depending on the number of alts) - -- And this is important: see Note [Fusing case continuations] - - ; let alt_env = se `setInScopeFromF` floats - ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr - ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts - -- Safe to say that there are no handled-cons for the DEFAULT case - -- NB: simplBinder does not zap deadness occ-info, so - -- a dead case_bndr' will still advertise its deadness - -- This is really important because in - -- case e of b { (# p,q #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), - -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. - -- In the new alts we build, we have the new case binder, so it must retain - -- its deadness. - -- NB: we don't use alt_env further; it has the substEnv for - -- the alternatives, and we don't want that - - ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr') - emptyJoinFloats alts' - - ; let all_floats = floats `addJoinFloats` join_floats - -- Note [Duplicated env] - ; return (all_floats - , Select { sc_dup = OkToDup - , sc_bndr = case_bndr' - , sc_alts = alts'' - , sc_env = zapSubstEnv se `setInScopeFromF` all_floats - -- See Note [StaticEnv invariant] in SimplUtils - , sc_cont = mkBoringStop (contResultType cont) } ) } - -mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType - -> SimplM (SimplFloats, SimplCont) -mkDupableStrictBind env arg_bndr join_rhs res_ty - | exprIsDupable (seDynFlags env) join_rhs - = return (emptyFloats env - , StrictBind { sc_bndr = arg_bndr, sc_bndrs = [] - , sc_body = join_rhs - , sc_env = zapSubstEnv env - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_dup = OkToDup - , sc_cont = mkBoringStop res_ty } ) - | otherwise - = do { join_bndr <- newJoinId [arg_bndr] res_ty - ; let arg_info = ArgInfo { ai_fun = join_bndr - , ai_type = idType join_bndr - , ai_rules = Nothing, ai_args = [] - , ai_encl = False, ai_dmds = repeat topDmd - , ai_discs = repeat 0 } - ; return ( addJoinFloats (emptyFloats env) $ - unitJoinFloat $ - NonRec join_bndr $ - Lam (setOneShotLambda arg_bndr) join_rhs - , StrictArg { sc_dup = OkToDup - , sc_fun = arg_info - , sc_cont = mkBoringStop res_ty - } ) } - -mkDupableAlt :: DynFlags -> OutId - -> JoinFloats -> OutAlt - -> SimplM (JoinFloats, OutAlt) -mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs') - | exprIsDupable dflags rhs' -- Note [Small alternative rhs] - = return (jfloats, (con, bndrs', rhs')) - - | otherwise - = do { let rhs_ty' = exprType rhs' - scrut_ty = idType case_bndr - case_bndr_w_unf - = case con of - DEFAULT -> case_bndr - DataAlt dc -> setIdUnfolding case_bndr unf - where - -- See Note [Case binders and join points] - unf = mkInlineUnfolding rhs - rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' - - LitAlt {} -> WARN( True, text "mkDupableAlt" - <+> ppr case_bndr <+> ppr con ) - case_bndr - -- The case binder is alive but trivial, so why has - -- it not been substituted away? - - final_bndrs' - | isDeadBinder case_bndr = filter abstract_over bndrs' - | otherwise = bndrs' ++ [case_bndr_w_unf] - - abstract_over bndr - | isTyVar bndr = True -- Abstract over all type variables just in case - | otherwise = not (isDeadBinder bndr) - -- The deadness info on the new Ids is preserved by simplBinders - final_args = varsToCoreExprs final_bndrs' - -- Note [Join point abstraction] - - -- We make the lambdas into one-shot-lambdas. The - -- join point is sure to be applied at most once, and doing so - -- prevents the body of the join point being floated out by - -- the full laziness pass - really_final_bndrs = map one_shot final_bndrs' - one_shot v | isId v = setOneShotLambda v - | otherwise = v - join_rhs = mkLams really_final_bndrs rhs' - - ; join_bndr <- newJoinId final_bndrs' rhs_ty' - - ; let join_call = mkApps (Var join_bndr) final_args - alt' = (con, bndrs', join_call) - - ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) - , alt') } - -- See Note [Duplicated env] - -{- -Note [Fusing case continuations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to fuse two successive case continuations when the -first has one alternative. That's why we call prepareCaseCont here. -Consider this, which arises from thunk splitting (see Note [Thunk -splitting] in WorkWrap): - - let - x* = case (case v of {pn -> rn}) of - I# a -> I# a - in body - -The simplifier will find - (Var v) with continuation - Select (pn -> rn) ( - Select [I# a -> I# a] ( - StrictBind body Stop - -So we'll call mkDupableCont on - Select [I# a -> I# a] (StrictBind body Stop) -There is just one alternative in the first Select, so we want to -simplify the rhs (I# a) with continuation (StrictBind body Stop) -Supposing that body is big, we end up with - let $j a = - in case v of { pn -> case rn of - I# a -> $j a } -This is just what we want because the rn produces a box that -the case rn cancels with. - -See #4957 a fuller example. - -Note [Case binders and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - case (case .. ) of c { - I# c# -> ....c.... - -If we make a join point with c but not c# we get - $j = \c -> ....c.... - -But if later inlining scrutinises the c, thus - - $j = \c -> ... case c of { I# y -> ... } ... - -we won't see that 'c' has already been scrutinised. This actually -happens in the 'tabulate' function in wave4main, and makes a significant -difference to allocation. - -An alternative plan is this: - - $j = \c# -> let c = I# c# in ...c.... - -but that is bad if 'c' is *not* later scrutinised. - -So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -(a stable unfolding) that it's really I# c#, thus - - $j = \c# -> \c[=I# c#] -> ...c.... - -Absence analysis may later discard 'c'. - -NB: take great care when doing strictness analysis; - see Note [Lambda-bound unfoldings] in DmdAnal. - -Also note that we can still end up passing stuff that isn't used. Before -strictness analysis we have - let $j x y c{=(x,y)} = (h c, ...) - in ... -After strictness analysis we see that h is strict, we end up with - let $j x y c{=(x,y)} = ($wh x y, ...) -and c is unused. - -Note [Duplicated env] -~~~~~~~~~~~~~~~~~~~~~ -Some of the alternatives are simplified, but have not been turned into a join point -So they *must* have a zapped subst-env. So we can't use completeNonRecX to -bind the join point, because it might to do PostInlineUnconditionally, and -we'd lose that when zapping the subst-env. We could have a per-alt subst-env, -but zapping it (as we do in mkDupableCont, the Select case) is safe, and -at worst delays the join-point inlining. - -Note [Small alternative rhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is worth checking for a small RHS because otherwise we -get extra let bindings that may cause an extra iteration of the simplifier to -inline back in place. Quite often the rhs is just a variable or constructor. -The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra -iterations because the version with the let bindings looked big, and so wasn't -inlined, but after the join points had been inlined it looked smaller, and so -was inlined. - -NB: we have to check the size of rhs', not rhs. -Duplicating a small InAlt might invalidate occurrence information -However, if it *is* dupable, we return the *un* simplified alternative, -because otherwise we'd need to pair it up with an empty subst-env.... -but we only have one env shared between all the alts. -(Remember we must zap the subst-env before re-simplifying something). -Rather than do this we simply agree to re-simplify the original (small) thing later. - -Note [Funky mkLamTypes] -~~~~~~~~~~~~~~~~~~~~~~ -Notice the funky mkLamTypes. If the constructor has existentials -it's possible that the join point will be abstracted over -type variables as well as term variables. - Example: Suppose we have - data T = forall t. C [t] - Then faced with - case (case e of ...) of - C t xs::[t] -> rhs - We get the join point - let j :: forall t. [t] -> ... - j = /\t \xs::[t] -> rhs - in - case (case e of ...) of - C t xs::[t] -> j t xs - -Note [Duplicating StrictArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dealing with making a StrictArg continuation duplicable has turned out -to be one of the trickiest corners of the simplifier, giving rise -to several cases in which the simplier expanded the program's size -*exponentially*. They include - #13253 exponential inlining - #10421 ditto - #18140 strict constructors - #18282 another nested-function call case - -Suppose we have a call - f e1 (case x of { True -> r1; False -> r2 }) e3 -and f is strict in its second argument. Then we end up in -mkDupableCont with a StrictArg continuation for (f e1 <> e3). -There are two ways to make it duplicable. - -* Plan A: move the entire call inwards, being careful not - to duplicate e1 or e3, thus: - let a1 = e1 - a3 = e3 - in case x of { True -> f a1 r1 a3 - ; False -> f a1 r2 a3 } - -* Plan B: make a join point: - join $j x = f e1 x e3 - in case x of { True -> jump $j r1 - ; False -> jump $j r2 } - Notice that Plan B is very like the way we handle strict - bindings; see Note [Duplicating StrictBind]. - -Plan A is good. Here's an example from #3116 - go (n+1) (case l of - 1 -> bs' - _ -> Chunk p fpc (o+1) (l-1) bs') - -If we pushed the entire call for 'go' inside the case, we get -call-pattern specialisation for 'go', which is *crucial* for -this particular program. - -Here is another example. - && E (case x of { T -> F; F -> T }) - -Pushing the call inward (being careful not to duplicate E) - let a = E - in case x of { T -> && a F; F -> && a T } - -and now the (&& a F) etc can optimise. Moreover there might -be a RULE for the function that can fire when it "sees" the -particular case alterantive. - -But Plan A can have terrible, terrible behaviour. Here is a classic -case: - f (f (f (f (f True)))) - -Suppose f is strict, and has a body that is small enough to inline. -The innermost call inlines (seeing the True) to give - f (f (f (f (case v of { True -> e1; False -> e2 })))) - -Now, suppose we naively push the entire continuation into both -case branches (it doesn't look large, just f.f.f.f). We get - case v of - True -> f (f (f (f e1))) - False -> f (f (f (f e2))) - -And now the process repeats, so we end up with an exponentially large -number of copies of f. No good! - -CONCLUSION: we want Plan A in general, but do Plan B is there a -danger of this nested call behaviour. The function that decides -this is called thumbsUpPlanA. - -Note [Keeping demand info in StrictArg Plan A] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Following on from Note [Duplicating StrictArg], another common code -pattern that can go bad is this: - f (case x1 of { T -> F; F -> T }) - (case x2 of { T -> F; F -> T }) - ...etc... -when f is strict in all its arguments. (It might, for example, be a -strict data constructor whose wrapper has not yet been inlined.) - -We use Plan A (because there is no nesting) giving - let a2 = case x2 of ... - a3 = case x3 of ... - in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } - -Now we must be careful! a2 and a3 are small, and the OneOcc code in -postInlineUnconditionally may inline them both at both sites; see Note -Note [Inline small things to avoid creating a thunk] in -Simplify.Utils. But if we do inline them, the entire process will -repeat -- back to exponential behaviour. - -So we are careful to keep the demand-info on a2 and a3. Then they'll -be /strict/ let-bindings, which will be dealt with by StrictBind. -That's why contIsDupableWithDmds is careful to propagage demand -info to the auxiliary bindings it creates. See the Demand argument -to makeTrivial. - -Note [Duplicating StrictBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We make a StrictBind duplicable in a very similar way to -that for case expressions. After all, - let x* = e in b is similar to case e of x -> b - -So we potentially make a join-point for the body, thus: - let x = <> in b ==> join j x = b - in j <> - -Just like StrictArg in fact -- and indeed they share code. - -Note [Join point abstraction] Historical note -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This note is now historical, describing how (in the past) we used -to add a void argument to nullary join points. But now that "join -point" is not a fuzzy concept but a formal syntactic construct (as -distinguished by the JoinId constructor of IdDetails), each of these -concerns is handled separately, with no need for a vestigial extra -argument. - -Join points always have at least one value argument, -for several reasons - -* If we try to lift a primitive-typed something out - for let-binding-purposes, we will *caseify* it (!), - with potentially-disastrous strictness results. So - instead we turn it into a function: \v -> e - where v::Void#. The value passed to this function is void, - which generates (almost) no code. - -* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now - we make the join point into a function whenever used_bndrs' - is empty. This makes the join-point more CPR friendly. - Consider: let j = if .. then I# 3 else I# 4 - in case .. of { A -> j; B -> j; C -> ... } - - Now CPR doesn't w/w j because it's a thunk, so - that means that the enclosing function can't w/w either, - which is a lose. Here's the example that happened in practice: - kgmod :: Int -> Int -> Int - kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 - then 78 - else 5 - -* Let-no-escape. We want a join point to turn into a let-no-escape - so that it is implemented as a jump, and one of the conditions - for LNE is that it's not updatable. In CoreToStg, see - Note [What is a non-escaping let] - -* Floating. Since a join point will be entered once, no sharing is - gained by floating out, but something might be lost by doing - so because it might be allocated. - -I have seen a case alternative like this: - True -> \v -> ... -It's a bit silly to add the realWorld dummy arg in this case, making - $j = \s v -> ... - True -> $j s -(the \v alone is enough to make CPR happy) but I think it's rare - -There's a slight infelicity here: we pass the overall -case_bndr to all the join points if it's used in *any* RHS, -because we don't know its usage in each RHS separately - - - -************************************************************************ -* * - Unfoldings -* * -************************************************************************ --} - -simplLetUnfolding :: SimplEnv-> TopLevelFlag - -> MaybeJoinCont - -> InId - -> OutExpr -> OutType - -> Unfolding -> SimplM Unfolding -simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf - | isStableUnfolding unf - = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty - | isExitJoinId id - = return noUnfolding -- See Note [Do not inline exit join points] in Exitify - | otherwise - = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs - -------------------- -mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource - -> InId -> OutExpr -> SimplM Unfolding -mkLetUnfolding dflags top_lvl src id new_rhs - = is_bottoming `seq` -- See Note [Force bottoming field] - return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs) - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In TidyPgm we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. - where - is_top_lvl = isTopLevel top_lvl - is_bottoming = isBottomingId id - -------------------- -simplStableUnfolding :: SimplEnv -> TopLevelFlag - -> MaybeJoinCont -- Just k => a join point with continuation k - -> InId - -> Unfolding -> OutType -> SimplM Unfolding --- Note [Setting the new unfolding] -simplStableUnfolding env top_lvl mb_cont id unf rhs_ty - = case unf of - NoUnfolding -> return unf - BootUnfolding -> return unf - OtherCon {} -> return unf - - DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } - -> do { (env', bndrs') <- simplBinders unf_env bndrs - ; args' <- mapM (simplExpr env') args - ; return (mkDFunUnfolding bndrs' con args') } - - CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } - | isStableSource src - -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points] - Just cont -> simplJoinRhs unf_env id expr cont - Nothing -> simplExprC unf_env expr (mkBoringStop rhs_ty) - ; case guide of - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , ug_boring_ok = boring_ok - } - -- Happens for INLINE things - -> let guide' = - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , ug_boring_ok = - boring_ok || inlineBoringOk expr' - } - -- Refresh the boring-ok flag, in case expr' - -- has got small. This happens, notably in the inlinings - -- for dfuns for single-method classes; see - -- Note [Single-method classes] in TcInstDcls. - -- A test case is #4138 - -- But retain a previous boring_ok of True; e.g. see - -- the way it is set in calcUnfoldingGuidanceWithArity - in return (mkCoreUnfolding src is_top_lvl expr' guide') - -- See Note [Top-level flag on inline rules] in CoreUnfold - - _other -- Happens for INLINABLE things - -> mkLetUnfolding dflags top_lvl src id expr' } - -- If the guidance is UnfIfGoodArgs, this is an INLINABLE - -- unfolding, and we need to make sure the guidance is kept up - -- to date with respect to any changes in the unfolding. - - | otherwise -> return noUnfolding -- Discard unstable unfoldings - where - dflags = seDynFlags env - is_top_lvl = isTopLevel top_lvl - act = idInlineActivation id - unf_env = updMode (updModeForStableUnfoldings act) env - -- See Note [Simplifying inside stable unfoldings] in SimplUtils - -{- -Note [Force bottoming field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to force bottoming, or the new unfolding holds -on to the old unfolding (which is part of the id). - -Note [Setting the new unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* If there's an INLINE pragma, we simplify the RHS gently. Maybe we - should do nothing at all, but simplifying gently might get rid of - more crap. - -* If not, we make an unfolding from the new RHS. But *only* for - non-loop-breakers. Making loop breakers not have an unfolding at all - means that we can avoid tests in exprIsConApp, for example. This is - important: if exprIsConApp says 'yes' for a recursive thing, then we - can get into an infinite loop - -If there's a stable unfolding on a loop breaker (which happens for -INLINABLE), we hang on to the inlining. It's pretty dodgy, but the -user did say 'INLINE'. May need to revisit this choice. - -************************************************************************ -* * - Rules -* * -************************************************************************ - -Note [Rules in a letrec] -~~~~~~~~~~~~~~~~~~~~~~~~ -After creating fresh binders for the binders of a letrec, we -substitute the RULES and add them back onto the binders; this is done -*before* processing any of the RHSs. This is important. Manuel found -cases where he really, really wanted a RULE for a recursive function -to apply in that function's own right-hand side. - -See Note [Forming Rec groups] in OccurAnal --} - -addBndrRules :: SimplEnv -> InBndr -> OutBndr - -> MaybeJoinCont -- Just k for a join point binder - -- Nothing otherwise - -> SimplM (SimplEnv, OutBndr) --- Rules are added back into the bin -addBndrRules env in_id out_id mb_cont - | null old_rules - = return (env, out_id) - | otherwise - = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont - ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules - ; return (modifyInScope env final_id, final_id) } - where - old_rules = ruleInfoRules (idSpecialisation in_id) - -simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] - -> MaybeJoinCont -> SimplM [CoreRule] -simplRules env mb_new_id rules mb_cont - = mapM simpl_rule rules - where - simpl_rule rule@(BuiltinRule {}) - = return rule - - simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs }) - = do { (env', bndrs') <- simplBinders env bndrs - ; let rhs_ty = substTy env' (exprType rhs) - rhs_cont = case mb_cont of -- See Note [Rules and unfolding for join points] - Nothing -> mkBoringStop rhs_ty - Just cont -> ASSERT2( join_ok, bad_join_msg ) - cont - rule_env = updMode updModeForRules env' - fn_name' = case mb_new_id of - Just id -> idName id - Nothing -> fn_name - - -- join_ok is an assertion check that the join-arity of the - -- binder matches that of the rule, so that pushing the - -- continuation into the RHS makes sense - join_ok = case mb_new_id of - Just id | Just join_arity <- isJoinId_maybe id - -> length args == join_arity - _ -> False - bad_join_msg = vcat [ ppr mb_new_id, ppr rule - , ppr (fmap isJoinId_maybe mb_new_id) ] - - ; args' <- mapM (simplExpr rule_env) args - ; rhs' <- simplExprC rule_env rhs rhs_cont - ; return (rule { ru_bndrs = bndrs' - , ru_fn = fn_name' - , ru_args = args' - , ru_rhs = rhs' }) } diff --git a/simplStg/RepType.hs b/simplStg/RepType.hs deleted file mode 100644 --- a/simplStg/RepType.hs +++ /dev/null @@ -1,589 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module RepType - ( - -- * Code generator views onto Types - UnaryType, NvUnaryType, isNvUnaryType, - unwrapType, - - -- * Predicates on types - isVoidTy, - - -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, - PrimRep(..), primRepToType, - countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1, - - -- * Unboxed sum representation type - ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), - slotPrimRep, primRepSlot, - - mkCCallSpec - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import BasicTypes (Arity, RepArity) -import DataCon -import Outputable -import PrelNames -import Coercion -import TyCon -import TyCoRep -import Type -import Util -import TysPrim -import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind, unitTyConKey ) -import {-# SOURCE #-} TcType (tcSplitIOType_maybe) - -import Data.List (sort) -import qualified Data.IntSet as IS - -import ForeignCall (CCallSpec(..), CCallTarget(..), CCallConv(..), Safety(..), CCallTarget(..)) - -mkCCallSpec :: CCallTarget -> CCallConv -> Safety -> Type -> [Type] -> CCallSpec -mkCCallSpec t c s r as = CCallSpec t c s (myTypePrimRep r') (map myTypePrimRep as') - where r'= case tcSplitIOType_maybe r of - Just (_ioTyCon, res_ty) -> res_ty - Nothing -> r - - -- for dynamic targets, we want to drop the first - -- represetnation, as that is the stable pointer to - -- the fucntion we are invocing, which is irrelevant - -- for the argument repsenstation. - as' = case t of - DynamicTarget -> tail as - _ -> as - - typeTyCon :: Type -> TyCon - typeTyCon ty - | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) - = tc - | otherwise - = pprPanic "DsForeign.typeTyCon" (ppr ty) - - myTypePrimRep :: Type -> PrimRep - myTypePrimRep t = case typePrimRep t of - [] -> VoidRep - [LiftedRep] -> case getUnique (typeTyCon t) of - key | key == int8TyConKey -> Int8Rep - | key == int16TyConKey -> Int16Rep - | key == int32TyConKey -> Int32Rep - | key == int64TyConKey -> Int64Rep - | key == word8TyConKey -> Word8Rep - | key == word16TyConKey -> Word16Rep - | key == word32TyConKey -> Word32Rep - | key == word64TyConKey -> Word64Rep - | key == intTyConKey -> IntRep - | key == wordTyConKey -> WordRep - | key == floatTyConKey -> FloatRep - | key == doubleTyConKey -> DoubleRep - | key == unitTyConKey -> VoidRep - _ -> LiftedRep - [rep] -> rep - -- Anything, else e.g. tuples, ..., those will - -- need to be passed as structs or unions or - -- some other datastructure, for which we only have - -- address pointers in C. - _ -> AddrRep - - -{- ********************************************************************** -* * - Representation types -* * -********************************************************************** -} - -type NvUnaryType = Type -type UnaryType = Type - -- Both are always a value type; i.e. its kind is TYPE rr - -- for some rr; moreover the rr is never a variable. - -- - -- NvUnaryType : never an unboxed tuple or sum, or void - -- - -- UnaryType : never an unboxed tuple or sum; - -- can be Void# or (# #) - -isNvUnaryType :: Type -> Bool -isNvUnaryType ty - | [_] <- typePrimRep ty - = True - | otherwise - = False - --- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] -typePrimRepArgs ty - | [] <- reps - = [VoidRep] - | otherwise - = reps - where - reps = typePrimRep ty - --- | Gets rid of the stuff that prevents us from understanding the --- runtime representation of a type. Including: --- 1. Casts --- 2. Newtypes --- 3. Foralls --- 4. Synonyms --- But not type/data families, because we don't have the envs to hand. -unwrapType :: Type -> Type -unwrapType ty - | Just (_, unwrapped) - <- topNormaliseTypeX stepper mappend inner_ty - = unwrapped - | otherwise - = inner_ty - where - inner_ty = go ty - - go t | Just t' <- coreView t = go t' - go (ForAllTy _ t) = go t - go (CastTy t _) = go t - go t = t - - -- cf. Coercion.unwrapNewTypeStepper - stepper rec_nts tc tys - | Just (ty', _) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of - Just rec_nts' -> NS_Step rec_nts' (go ty') () - Nothing -> NS_Abort -- infinite newtypes - | otherwise - = NS_Done - -countFunRepArgs :: Arity -> Type -> RepArity -countFunRepArgs 0 _ - = 0 -countFunRepArgs n ty - | FunTy _ arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res - | otherwise - = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) - -countConRepArgs :: DataCon -> RepArity -countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) - where - go :: Arity -> Type -> RepArity - go 0 _ - = 0 - go n ty - | FunTy _ arg res <- unwrapType ty - = length (typePrimRep arg) + go (n - 1) res - | otherwise - = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) - --- | True if the type has zero width. -isVoidTy :: Type -> Bool -isVoidTy = null . typePrimRep - - -{- ********************************************************************** -* * - Unboxed sums - See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs -* * -********************************************************************** -} - -type SortedSlotTys = [SlotTy] - --- | Given the arguments of a sum type constructor application, --- return the unboxed sum rep type. --- --- E.g. --- --- (# Int# | Maybe Int | (# Int#, Float# #) #) --- --- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`, --- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot] --- --- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head --- of the list we have the slot for the tag. -ubxSumRepType :: [[PrimRep]] -> [SlotTy] -ubxSumRepType constrs0 - -- These first two cases never classify an actual unboxed sum, which always - -- has at least two disjuncts. But it could happen if a user writes, e.g., - -- forall (a :: TYPE (SumRep [IntRep])). ... - -- which could never be instantiated. We still don't want to panic. - | constrs0 `lengthLessThan` 2 - = [WordSlot] - - | otherwise - = let - combine_alts :: [SortedSlotTys] -- slots of constructors - -> SortedSlotTys -- final slots - combine_alts constrs = foldl' merge [] constrs - - merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys - merge existing_slots [] - = existing_slots - merge [] needed_slots - = needed_slots - merge (es : ess) (s : ss) - | Just s' <- s `fitsIn` es - = -- found a slot, use it - s' : merge ess ss - | s < es - = -- we need a new slot and this is the right place for it - s : merge (es : ess) ss - | otherwise - = -- keep searching for a slot - es : merge ess (s : ss) - - -- Nesting unboxed tuples and sums is OK, so we need to flatten first. - rep :: [PrimRep] -> SortedSlotTys - rep ty = sort (map primRepSlot ty) - - sumRep = WordSlot : combine_alts (map rep constrs0) - -- WordSlot: for the tag of the sum - in - sumRep - -layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag. - -- We assume that they are in increasing order - -> [SlotTy] -- Slot types of things we want to map to locations in the - -- sum layout - -> [Int] -- Where to map 'things' in the sum layout -layoutUbxSum sum_slots0 arg_slots0 = - go arg_slots0 IS.empty - where - go :: [SlotTy] -> IS.IntSet -> [Int] - go [] _ - = [] - go (arg : args) used - = let slot_idx = findSlot arg 0 sum_slots0 used - in slot_idx : go args (IS.insert slot_idx used) - - findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int - findSlot arg slot_idx (slot : slots) useds - | not (IS.member slot_idx useds) - , Just slot == arg `fitsIn` slot - = slot_idx - | otherwise - = findSlot arg (slot_idx + 1) slots useds - findSlot _ _ [] _ - = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0) - --------------------------------------------------------------------------------- - --- We have 3 kinds of slots: --- --- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e. --- boxed objects). These come in two variants: Lifted and unlifted (see --- #19645). --- --- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep. --- --- - Float slots: Shared between floating point types. --- --- - Void slots: Shared between void types. Not used in sums. --- --- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit --- values, so that we can pack things more tightly. -data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot - deriving (Eq, Ord) - -- Constructor order is important! If slot A could fit into slot B - -- then slot A must occur first. E.g. FloatSlot before DoubleSlot - -- - -- We are assuming that WordSlot is smaller than or equal to Word64Slot - -- (would not be true on a 128-bit machine) - -instance Outputable SlotTy where - ppr PtrLiftedSlot = text "PtrLiftedSlot" - ppr PtrUnliftedSlot = text "PtrUnliftedSlot" - ppr Word64Slot = text "Word64Slot" - ppr WordSlot = text "WordSlot" - ppr DoubleSlot = text "DoubleSlot" - ppr FloatSlot = text "FloatSlot" - -typeSlotTy :: UnaryType -> Maybe SlotTy -typeSlotTy ty - | isVoidTy ty - = Nothing - | otherwise - = Just (primRepSlot (typePrimRep1 ty)) - -primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") -primRepSlot LiftedRep = PtrLiftedSlot -primRepSlot UnliftedRep = PtrUnliftedSlot -primRepSlot IntRep = WordSlot -primRepSlot Int8Rep = WordSlot -primRepSlot Int16Rep = WordSlot -primRepSlot Int32Rep = WordSlot -primRepSlot Int64Rep = Word64Slot -primRepSlot WordRep = WordSlot -primRepSlot Word8Rep = WordSlot -primRepSlot Word16Rep = WordSlot -primRepSlot Word32Rep = WordSlot -primRepSlot Word64Rep = Word64Slot -primRepSlot AddrRep = WordSlot -primRepSlot FloatRep = FloatSlot -primRepSlot DoubleRep = DoubleSlot -primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") - -slotPrimRep :: SlotTy -> PrimRep -slotPrimRep PtrLiftedSlot = LiftedRep -slotPrimRep PtrUnliftedSlot = UnliftedRep -slotPrimRep Word64Slot = Word64Rep -slotPrimRep WordSlot = WordRep -slotPrimRep DoubleSlot = DoubleRep -slotPrimRep FloatSlot = FloatRep - --- | Returns the bigger type if one fits into the other. (commutative) --- --- Note that lifted and unlifted pointers are *not* in a fits-in relation for --- the reasons described in Note [Don't merge lifted and unlifted slots] in --- GHC.Stg.Unarise. -fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy -fitsIn ty1 ty2 - | ty1 == ty2 - = Just ty1 - | isWordSlot ty1 && isWordSlot ty2 - = Just (max ty1 ty2) - | isFloatSlot ty1 && isFloatSlot ty2 - = Just (max ty1 ty2) - | otherwise - = Nothing - where - isWordSlot Word64Slot = True - isWordSlot WordSlot = True - isWordSlot _ = False - - isFloatSlot DoubleSlot = True - isFloatSlot FloatSlot = True - isFloatSlot _ = False - - -{- ********************************************************************** -* * - PrimRep -* * -************************************************************************* - -Note [RuntimeRep and PrimRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note describes the relationship between GHC.Types.RuntimeRep -(of levity-polymorphism fame) and TyCon.PrimRep, as these types -are closely related. - -A "primitive entity" is one that can be - * stored in one register - * manipulated with one machine instruction - - -Examples include: - * a 32-bit integer - * a 32-bit float - * a 64-bit float - * a machine address (heap pointer), etc. - * a quad-float (on a machine with SIMD register and instructions) - * ...etc... - -The "representation or a primitive entity" specifies what kind of register is -needed and how many bits are required. The data type TyCon.PrimRep -enumerates all the possiblities. - -data PrimRep - = VoidRep - | LiftedRep -- ^ Lifted pointer - | UnliftedRep -- ^ Unlifted pointer - | Int8Rep -- ^ Signed, 8-bit value - | Int16Rep -- ^ Signed, 16-bit value - ...etc... - | VecRep Int PrimElemRep -- ^ SIMD fixed-width vector - -The Haskell source language is a bit more flexible: a single value may need multiple PrimReps. -For example - - utup :: (# Int, Int #) -> Bool - utup x = ... - -Here x :: (# Int, Int #), and that takes two registers, and two instructions to move around. -Unboxed sums are similar. - -Every Haskell expression e has a type ty, whose kind is of form TYPE rep - e :: ty :: TYPE rep -where rep :: RuntimeRep. Here rep describes the runtime representation for e's value, -but RuntimeRep has some extra cases: - -data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type - | TupleRep [RuntimeRep] -- ^ An unboxed tuple of the given reps - | SumRep [RuntimeRep] -- ^ An unboxed sum of the given reps - | LiftedRep -- ^ lifted; represented by a pointer - | UnliftedRep -- ^ unlifted; represented by a pointer - | IntRep -- ^ signed, word-sized value - ...etc... - -It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep, -which describe unboxed products and sums respectively. RuntimeRep is defined -in the library ghc-prim:GHC.Types. It is also "wired-in" to GHC: see -TysWiredIn.runtimeRepTyCon. The unarisation pass, in StgUnarise, transforms the -program, so that that every variable has a type that has a PrimRep. For -example, unarisation transforms our utup function above, to take two Int -arguments instead of one (# Int, Int #) argument. - -See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. - -Note [VoidRep] -~~~~~~~~~~~~~~ -PrimRep contains a constructor VoidRep, while RuntimeRep does -not. Yet representations are often characterised by a list of PrimReps, -where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) - -However, after the unariser, all identifiers have exactly one PrimRep, but -void arguments still exist. Thus, PrimRep includes VoidRep to describe these -binders. Perhaps post-unariser representations (which need VoidRep) should be -a different type than pre-unariser representations (which use a list and do -not need VoidRep), but we have what we have. - -RuntimeRep instead uses TupleRep '[] to denote a void argument. When -converting a TupleRep '[] into a list of PrimReps, we get an empty list. - -Note [Getting from RuntimeRep to PrimRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep]. - -How do we get from an Id to the the list or PrimReps used to store it? We get -the Id's type ty (using idType), then ty's kind ki (using typeKind), then -pattern-match on ki to extract rep (in kindPrimRep), then extract the PrimRep -from the RuntimeRep (in runtimeRepPrimRep). - -We now must convert the RuntimeRep to a list of PrimReps. Let's look at two -examples: - - 1. x :: Int# - 2. y :: (# Int, Word# #) - -With these types, we can extract these kinds: - - 1. Int# :: TYPE IntRep - 2. (# Int, Word# #) :: TYPE (TupleRep [LiftedRep, WordRep]) - -In the end, we will get these PrimReps: - - 1. [IntRep] - 2. [LiftedRep, WordRep] - -It would thus seem that we should have a function somewhere of -type `RuntimeRep -> [PrimRep]`. This doesn't work though: when we -look at the argument of TYPE, we get something of type Type (of course). -RuntimeRep exists in the user's program, but not in GHC as such. -Instead, we must decompose the Type of kind RuntimeRep into tycons and -extract the PrimReps from the TyCons. This is what runtimeRepPrimRep does: -it takes a Type and returns a [PrimRep] - -runtimeRepPrimRep works by using tyConRuntimeRepInfo. That function -should be passed the TyCon produced by promoting one of the constructors -of RuntimeRep into type-level data. The RuntimeRep promoted datacons are -associated with a RuntimeRepInfo (stored directly in the PromotedDataCon -constructor of TyCon). This pairing happens in TysWiredIn. A RuntimeRepInfo -usually(*) contains a function from [Type] to [PrimRep]: the [Type] are -the arguments to the promoted datacon. These arguments are necessary -for the TupleRep and SumRep constructors, so that this process can recur, -producing a flattened list of PrimReps. Calling this extracted function -happens in runtimeRepPrimRep; the functions themselves are defined in -tupleRepDataCon and sumRepDataCon, both in TysWiredIn. - -The (*) above is to support vector representations. RuntimeRep refers -to VecCount and VecElem, whose promoted datacons have nuggets of information -related to vectors; these form the other alternatives for RuntimeRepInfo. - -Returning to our examples, the Types we get (after stripping off TYPE) are - - 1. TyConApp (PromotedDataCon "IntRep") [] - 2. TyConApp (PromotedDataCon "TupleRep") - [TyConApp (PromotedDataCon ":") - [ TyConApp (AlgTyCon "RuntimeRep") [] - , TyConApp (PromotedDataCon "LiftedRep") [] - , TyConApp (PromotedDataCon ":") - [ TyConApp (AlgTyCon "RuntimeRep") [] - , TyConApp (PromotedDataCon "WordRep") [] - , TyConApp (PromotedDataCon "'[]") - [TyConApp (AlgTyCon "RuntimeRep") []]]]] - -runtimeRepPrimRep calls tyConRuntimeRepInfo on (PromotedDataCon "IntRep"), resp. -(PromotedDataCon "TupleRep"), extracting a function that will produce the PrimReps. -In example 1, this function is passed an empty list (the empty list of args to IntRep) -and returns the PrimRep IntRep. (See the definition of runtimeRepSimpleDataCons in -TysWiredIn and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted -list as the one argument to the extracted function. The extracted function is defined -as prim_rep_fun within tupleRepDataCon in TysWiredIn. It takes one argument, decomposes -the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep -to process the LiftedRep and WordRep, concatentating the results. - --} - --- | Discovers the primitive representation of a 'Type'. Returns --- a list of 'PrimRep': it's a list because of the possibility of --- no runtime representation (void) or multiple (unboxed tuple/sum) --- See also Note [Getting from RuntimeRep to PrimRep] -typePrimRep :: HasDebugCallStack => Type -> [PrimRep] -typePrimRep ty = kindPrimRep (text "typePrimRep" <+> - parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) - (typeKind ty) - --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; --- an empty list of PrimReps becomes a VoidRep. --- This assumption holds after unarise, see Note [Post-unarisation invariants]. --- Before unarise it may or may not hold. --- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep -typePrimRep1 ty = case typePrimRep ty of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) - --- | Find the runtime representation of a 'TyCon'. Defined here to --- avoid module loops. Returns a list of the register shapes necessary. --- See also Note [Getting from RuntimeRep to PrimRep] -tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] -tyConPrimRep tc - = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) - res_kind - where - res_kind = tyConResKind tc - --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output --- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's --- of values of types of this kind. --- See also Note [Getting from RuntimeRep to PrimRep] -kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] -kindPrimRep doc ki - | Just ki' <- coreView ki - = kindPrimRep doc ki' -kindPrimRep doc (TyConApp typ [runtime_rep]) - = ASSERT( typ `hasKey` tYPETyConKey ) - runtimeRepPrimRep doc runtime_rep -kindPrimRep doc ki - = pprPanic "kindPrimRep" (ppr ki $$ doc) - --- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that --- it encodes. See also Note [Getting from RuntimeRep to PrimRep] -runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] -runtimeRepPrimRep doc rr_ty - | Just rr_ty' <- coreView rr_ty - = runtimeRepPrimRep doc rr_ty' - | TyConApp rr_dc args <- rr_ty - , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc - = fun args - | otherwise - = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) - --- | Convert a PrimRep back to a Type. Used only in the unariser to give types --- to fresh Ids. Really, only the type's representation matters. --- See also Note [RuntimeRep and PrimRep] -primRepToType :: PrimRep -> Type -primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep diff --git a/simplStg/SimplStg.hs b/simplStg/SimplStg.hs deleted file mode 100644 --- a/simplStg/SimplStg.hs +++ /dev/null @@ -1,141 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[SimplStg]{Driver for simplifying @STG@ programs} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module SimplStg ( stg2stg ) where - -#include "HsVersions.h" - -import GhcPrelude - -import StgSyn - -import StgLint ( lintStgTopBindings ) -import StgStats ( showStgStats ) -import UnariseStg ( unarise ) -import StgCse ( stgCse ) -import StgLiftLams ( stgLiftLams ) -import Module ( Module ) - -import DynFlags -import ErrUtils -import UniqSupply -import Outputable -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.State.Strict - -newtype StgM a = StgM { _unStgM :: StateT Char IO a } - deriving (Functor, Applicative, Monad, MonadIO) - -instance MonadUnique StgM where - getUniqueSupplyM = StgM $ do { mask <- get - ; liftIO $! mkSplitUniqSupply mask} - getUniqueM = StgM $ do { mask <- get - ; liftIO $! uniqFromMask mask} - -runStgM :: Char -> StgM a -> IO a -runStgM mask (StgM m) = evalStateT m mask - -stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do - -> Module -- module being compiled - -> [StgTopBinding] -- input program - -> IO [StgTopBinding] -- output program - -stg2stg dflags this_mod binds - = do { dump_when Opt_D_dump_stg "STG:" binds - ; showPass dflags "Stg2Stg" - -- Do the main business! - ; binds' <- runStgM 'g' $ - foldM do_stg_pass binds (getStgToDo dflags) - - ; dump_when Opt_D_dump_stg_final "Final STG:" binds' - - ; return binds' - } - - where - stg_linter unarised - | gopt Opt_DoStgLinting dflags - = lintStgTopBindings dflags this_mod unarised - | otherwise - = \ _whodunnit _binds -> return () - - ------------------------------------------- - do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding] - do_stg_pass binds to_do - = case to_do of - StgDoNothing -> - return binds - - StgStats -> - trace (showStgStats binds) (return binds) - - StgCSE -> do - let binds' = {-# SCC "StgCse" #-} stgCse binds - end_pass "StgCse" binds' - - StgLiftLams -> do - us <- getUniqueSupplyM - let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds - end_pass "StgLiftLams" binds' - - StgUnarise -> do - us <- getUniqueSupplyM - liftIO (stg_linter False "Pre-unarise" binds) - let binds' = unarise us binds - liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds') - liftIO (stg_linter True "Unarise" binds') - return binds' - - dump_when flag header binds - = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds) - - end_pass what binds2 - = liftIO $ do -- report verbosely, if required - dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what - (vcat (map ppr binds2)) - stg_linter False what binds2 - return binds2 - --- ----------------------------------------------------------------------------- --- StgToDo: abstraction of stg-to-stg passes to run. - --- | Optional Stg-to-Stg passes. -data StgToDo - = StgCSE - -- ^ Common subexpression elimination - | StgLiftLams - -- ^ Lambda lifting closure variables, trading stack/register allocation for - -- heap allocation - | StgStats - | StgUnarise - -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders - | StgDoNothing - -- ^ Useful for building up 'getStgToDo' - deriving Eq - --- | Which Stg-to-Stg passes to run. Depends on flags, ways etc. -getStgToDo :: DynFlags -> [StgToDo] -getStgToDo dflags = - filter (/= StgDoNothing) - [ mandatory StgUnarise - -- Important that unarisation comes first - -- See Note [StgCse after unarisation] in StgCse - , optional Opt_StgCSE StgCSE - , optional Opt_StgLiftLams StgLiftLams - , optional Opt_StgStats StgStats - ] where - optional opt = runWhen (gopt opt dflags) - mandatory = id - -runWhen :: Bool -> StgToDo -> StgToDo -runWhen True todo = todo -runWhen _ _ = StgDoNothing diff --git a/simplStg/StgCse.hs b/simplStg/StgCse.hs deleted file mode 100644 --- a/simplStg/StgCse.hs +++ /dev/null @@ -1,483 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{-| -Note [CSE for Stg] -~~~~~~~~~~~~~~~~~~ -This module implements a simple common subexpression elimination pass for STG. -This is useful because there are expressions that we want to common up (because -they are operationally equivalent), but that we cannot common up in Core, because -their types differ. -This was originally reported as #9291. - -There are two types of common code occurrences that we aim for, see -note [Case 1: CSEing allocated closures] and -note [Case 2: CSEing case binders] below. - - -Note [Case 1: CSEing allocated closures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The first kind of CSE opportunity we aim for is generated by this Haskell code: - - bar :: a -> (Either Int a, Either Bool a) - bar x = (Right x, Right x) - -which produces this Core: - - bar :: forall a. a -> (Either Int a, Either Bool a) - bar @a x = (Right @Int @a x, Right @Bool @a x) - -where the two components of the tuple are different terms, and cannot be -commoned up (easily). On the STG level we have - - bar [x] = let c1 = Right [x] - c2 = Right [x] - in (c1,c2) - -and now it is obvious that we can write - - bar [x] = let c1 = Right [x] - in (c1,c1) - -instead. - - -Note [Case 2: CSEing case binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The second kind of CSE opportunity we aim for is more interesting, and -came up in #9291 and #5344: The Haskell code - - foo :: Either Int a -> Either Bool a - foo (Right x) = Right x - foo _ = Left False - -produces this Core - - foo :: forall a. Either Int a -> Either Bool a - foo @a e = case e of b { Left n -> … - , Right x -> Right @Bool @a x } - -where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have -different types. But in STG we have - - foo [e] = case e of b { Left [n] -> … - , Right [x] -> Right [x] } - -and nothing stops us from transforming that to - - foo [e] = case e of b { Left [n] -> … - , Right [x] -> b} - - -Note [StgCse after unarisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider two unboxed sum terms: - - (# 1 | #) :: (# Int | Int# #) - (# 1 | #) :: (# Int | Int #) - -These two terms are not equal as they unarise to different unboxed -tuples. However if we run StgCse before Unarise, it'll think the two -terms (# 1 | #) are equal, and replace one of these with a binder to -the other. That's bad -- #15300. - -Solution: do unarise first. - --} - -module StgCse (stgCse) where - -import GhcPrelude - -import DataCon -import Id -import StgSyn -import Outputable -import VarEnv -import CoreSyn (AltCon(..)) -import Data.List (mapAccumL) -import Data.Maybe (fromMaybe) -import CoreMap -import NameEnv -import Control.Monad( (>=>) ) - --------------- --- The Trie -- --------------- - --- A lookup trie for data constructor applications, i.e. --- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap. - -data StgArgMap a = SAM - { sam_var :: DVarEnv a - , sam_lit :: LiteralMap a - } - -instance TrieMap StgArgMap where - type Key StgArgMap = StgArg - emptyTM = SAM { sam_var = emptyTM - , sam_lit = emptyTM } - lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var - lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit - alterTM (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f } - alterTM (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f } - foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m) - mapTM f (SAM {sam_var = varm, sam_lit = litm}) = - SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm } - -newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } - -instance TrieMap ConAppMap where - type Key ConAppMap = (DataCon, [StgArg]) - emptyTM = CAM emptyTM - lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args - alterTM (dataCon, args) f m = - m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } - foldTM k = un_cam >.> foldTM (foldTM k) - mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM - ------------------ --- The CSE Env -- ------------------ - --- | The CSE environment. See note [CseEnv Example] -data CseEnv = CseEnv - { ce_conAppMap :: ConAppMap OutId - -- ^ The main component of the environment is the trie that maps - -- data constructor applications (with their `OutId` arguments) - -- to an in-scope name that can be used instead. - -- This name is always either a let-bound variable or a case binder. - , ce_subst :: IdEnv OutId - -- ^ This substitution is applied to the code as we traverse it. - -- Entries have one of two reasons: - -- - -- * The input might have shadowing (see Note [Shadowing]), so we have - -- to rename some binders as we traverse the tree. - -- * If we remove `let x = Con z` because `let y = Con z` is in scope, - -- we note this here as x ↦ y. - , ce_bndrMap :: IdEnv OutId - -- ^ If we come across a case expression case x as b of … with a trivial - -- binder, we add b ↦ x to this. - -- This map is *only* used when looking something up in the ce_conAppMap. - -- See Note [Trivial case scrutinee] - , ce_in_scope :: InScopeSet - -- ^ The third component is an in-scope set, to rename away any - -- shadowing binders - } - -{-| -Note [CseEnv Example] -~~~~~~~~~~~~~~~~~~~~~ -The following tables shows how the CseEnvironment changes as code is traversed, -as well as the changes to that code. - - InExpr OutExpr - conAppMap subst in_scope - ─────────────────────────────────────────────────────────── - -- empty {} {} - case … as a of {Con x y -> case … as a of {Con x y -> - -- Con x y ↦ a {} {a,x,y} - let b = Con x y (removed) - -- Con x y ↦ a b↦a {a,x,y,b} - let c = Bar a let c = Bar a - -- Con x y ↦ a, Bar a ↦ c b↦a {a,x,y,b,c} - let c = some expression let c' = some expression - -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', {a,x,y,b,c,c'} - let d = Bar b (removed) - -- Con x y ↦ a, Bar a ↦ c b↦a, c↦c', d↦c {a,x,y,b,c,c',d} - (a, b, c d) (a, a, c' c) --} - -initEnv :: InScopeSet -> CseEnv -initEnv in_scope = CseEnv - { ce_conAppMap = emptyTM - , ce_subst = emptyVarEnv - , ce_bndrMap = emptyVarEnv - , ce_in_scope = in_scope - } - -envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId -envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env) - where args' = map go args -- See Note [Trivial case scrutinee] - go (StgVarArg v ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v) - go (StgLitArg lit) = StgLitArg lit - -addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv --- do not bother with nullary data constructors, they are static anyways -addDataCon _ _ [] env = env -addDataCon bndr dataCon args env = env { ce_conAppMap = new_env } - where - new_env = insertTM (dataCon, args) bndr (ce_conAppMap env) - -forgetCse :: CseEnv -> CseEnv -forgetCse env = env { ce_conAppMap = emptyTM } - -- See note [Free variables of an StgClosure] - -addSubst :: OutId -> OutId -> CseEnv -> CseEnv -addSubst from to env - = env { ce_subst = extendVarEnv (ce_subst env) from to } - -addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv -addTrivCaseBndr from to env - = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to } - -substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] -substArgs env = map (substArg env) - -substArg :: CseEnv -> InStgArg -> OutStgArg -substArg env (StgVarArg from) = StgVarArg (substVar env from) -substArg _ (StgLitArg lit) = StgLitArg lit - -substVar :: CseEnv -> InId -> OutId -substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id - --- Functions to enter binders - --- This is much simpler than the equivalent code in CoreSubst: --- * We do not substitute type variables, and --- * There is nothing relevant in IdInfo at this stage --- that needs substitutions. --- Therefore, no special treatment for a recursive group is required. - -substBndr :: CseEnv -> InId -> (CseEnv, OutId) -substBndr env old_id - = (new_env, new_id) - where - new_id = uniqAway (ce_in_scope env) old_id - no_change = new_id == old_id - env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id } - new_env | no_change = env' - | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id } - -substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar]) -substBndrs env bndrs = mapAccumL substBndr env bndrs - -substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)]) -substPairs env bndrs = mapAccumL go env bndrs - where go env (id, x) = let (env', id') = substBndr env id - in (env', (id', x)) - --- Main entry point - -stgCse :: [InStgTopBinding] -> [OutStgTopBinding] -stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds - --- Top level bindings. --- --- We do not CSE these, as top-level closures are allocated statically anyways. --- Also, they might be exported. --- But we still have to collect the set of in-scope variables, otherwise --- uniqAway might shadow a top-level closure. - -stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding) -stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t) -stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs)) - = (in_scope' - , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs))) - where in_scope' = in_scope `extendInScopeSet` bndr - -stgCseTopLvl in_scope (StgTopLifted (StgRec eqs)) - = ( in_scope' - , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ])) - where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] - -stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs -stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body) - = let body' = stgCseExpr (initEnv in_scope) body - in StgRhsClosure ext ccs upd args body' -stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args) - = StgRhsCon ccs dataCon args - ------------------------------- --- The actual AST traversal -- ------------------------------- - --- Trivial cases -stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr -stgCseExpr env (StgApp fun args) - = StgApp fun' args' - where fun' = substVar env fun - args' = substArgs env args -stgCseExpr _ (StgLit lit) - = StgLit lit -stgCseExpr env (StgOpApp op args tys) - = StgOpApp op args' tys - where args' = substArgs env args -stgCseExpr _ (StgLam _ _) - = pprPanic "stgCseExp" (text "StgLam") -stgCseExpr env (StgTick tick body) - = let body' = stgCseExpr env body - in StgTick tick body' -stgCseExpr env (StgCase scrut bndr ty alts) - = mkStgCase scrut' bndr' ty alts' - where - scrut' = stgCseExpr env scrut - (env1, bndr') = substBndr env bndr - env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1 - -- See Note [Trivial case scrutinee] - | otherwise = env1 - alts' = map (stgCseAlt env2 ty bndr') alts - - --- A constructor application. --- To be removed by a variable use when found in the CSE environment -stgCseExpr env (StgConApp dataCon args tys) - | Just bndr' <- envLookup dataCon args' env - = StgApp bndr' [] - | otherwise - = StgConApp dataCon args' tys - where args' = substArgs env args - --- Let bindings --- The binding might be removed due to CSE (we do not want trivial bindings on --- the STG level), so use the smart constructor `mkStgLet` to remove the binding --- if empty. -stgCseExpr env (StgLet ext binds body) - = let (binds', env') = stgCseBind env binds - body' = stgCseExpr env' body - in mkStgLet (StgLet ext) binds' body' -stgCseExpr env (StgLetNoEscape ext binds body) - = let (binds', env') = stgCseBind env binds - body' = stgCseExpr env' body - in mkStgLet (StgLetNoEscape ext) binds' body' - --- Case alternatives --- Extend the CSE environment -stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt -stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs) - = let (env1, args') = substBndrs env args - env2 - -- To avoid dealing with unboxed sums StgCse runs after unarise and - -- should maintain invariants listed in Note [Post-unarisation - -- invariants]. One of the invariants is that some binders are not - -- used (unboxed tuple case binders) which is what we check with - -- `stgCaseBndrInScope` here. If the case binder is not in scope we - -- don't add it to the CSE env. See also #15300. - | stgCaseBndrInScope ty True -- CSE runs after unarise - = addDataCon case_bndr dataCon (map StgVarArg args') env1 - | otherwise - = env1 - -- see note [Case 2: CSEing case binders] - rhs' = stgCseExpr env2 rhs - in (DataAlt dataCon, args', rhs') -stgCseAlt env _ _ (altCon, args, rhs) - = let (env1, args') = substBndrs env args - rhs' = stgCseExpr env1 rhs - in (altCon, args', rhs') - --- Bindings -stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv) -stgCseBind env (StgNonRec b e) - = let (env1, b') = substBndr env b - in case stgCseRhs env1 b' e of - (Nothing, env2) -> (Nothing, env2) - (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2) -stgCseBind env (StgRec pairs) - = let (env1, pairs1) = substPairs env pairs - in case stgCsePairs env1 pairs1 of - ([], env2) -> (Nothing, env2) - (pairs2, env2) -> (Just (StgRec pairs2), env2) - -stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv) -stgCsePairs env [] = ([], env) -stgCsePairs env0 ((b,e):pairs) - = let (pairMB, env1) = stgCseRhs env0 b e - (pairs', env2) = stgCsePairs env1 pairs - in (pairMB `mbCons` pairs', env2) - where - mbCons = maybe id (:) - --- The RHS of a binding. --- If it is a constructor application, either short-cut it or extend the environment -stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) -stgCseRhs env bndr (StgRhsCon ccs dataCon args) - | Just other_bndr <- envLookup dataCon args' env - = let env' = addSubst bndr other_bndr env - in (Nothing, env') - | otherwise - = let env' = addDataCon bndr dataCon args' env - -- see note [Case 1: CSEing allocated closures] - pair = (bndr, StgRhsCon ccs dataCon args') - in (Just pair, env') - where args' = substArgs env args -stgCseRhs env bndr (StgRhsClosure ext ccs upd args body) - = let (env1, args') = substBndrs env args - env2 = forgetCse env1 -- See note [Free variables of an StgClosure] - body' = stgCseExpr env2 body - in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env) - - -mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr -mkStgCase scrut bndr ty alts | all isBndr alts = scrut - | otherwise = StgCase scrut bndr ty alts - - where - -- see Note [All alternatives are the binder] - isBndr (_, _, StgApp f []) = f == bndr - isBndr _ = False - - --- Utilities - --- | This function short-cuts let-bindings that are now obsolete -mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b -mkStgLet _ Nothing body = body -mkStgLet stgLet (Just binds) body = stgLet binds body - - -{- -Note [All alternatives are the binder] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When all alternatives simply refer to the case binder, then we do not have -to bother with the case expression at all (#13588). CoreSTG does this as well, -but sometimes, types get into the way: - - newtype T = MkT Int - f :: (Int, Int) -> (T, Int) - f (x, y) = (MkT x, y) - -Core cannot just turn this into - - f p = p - -as this would not be well-typed. But to STG, where MkT is no longer in the way, -we can. - -Note [Trivial case scrutinee] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to be able to handle nested reconstruction of constructors as in - - nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) - nested (Right (Right v)) = Right (Right v) - nested _ = Left True - -So if we come across - - case x of r1 - Right a -> case a of r2 - Right b -> let v = Right b - in Right v - -we first replace v with r2. Next we want to replace Right r2 with r1. But the -ce_conAppMap contains Right a! - -Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use -this substitution before looking Right r2 up in ce_conAppMap, and everything -works out. - -Note [Free variables of an StgClosure] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -StgClosures (function and thunks) have an explicit list of free variables: - -foo [x] = - let not_a_free_var = Left [x] - let a_free_var = Right [x] - let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var - in closure - -If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`, -then the list of free variables would be wrong, so for now, we do not CSE -across such a closure, simply because I (Joachim) was not sure about possible -knock-on effects. If deemed safe and worth the slight code complication of -re-calculating this list during or after this pass, this can surely be done. --} diff --git a/simplStg/StgLiftLams.hs b/simplStg/StgLiftLams.hs deleted file mode 100644 --- a/simplStg/StgLiftLams.hs +++ /dev/null @@ -1,102 +0,0 @@ --- | Implements a selective lambda lifter, running late in the optimisation --- pipeline. --- --- The transformation itself is implemented in "StgLiftLams.Transformation". --- If you are interested in the cost model that is employed to decide whether --- to lift a binding or not, look at "StgLiftLams.Analysis". --- "StgLiftLams.LiftM" contains the transformation monad that hides away some --- plumbing of the transformation. -module StgLiftLams ( - -- * Late lambda lifting in STG - -- $note - Transformation.stgLiftLams - ) where - -import qualified StgLiftLams.Transformation as Transformation - --- Note [Late lambda lifting in STG] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- $note --- See also the --- and #9476. --- --- The basic idea behind lambda lifting is to turn locally defined functions --- into top-level functions. Free variables are then passed as additional --- arguments at *call sites* instead of having a closure allocated for them at --- *definition site*. Example: --- --- @ --- let x = ...; y = ... in --- let f = {x y} \a -> a + x + y in --- let g = {f x} \b -> f b + x in --- g 5 --- @ --- --- Lambda lifting @f@ would --- --- 1. Turn @f@'s free variables into formal parameters --- 2. Update @f@'s call site within @g@ to @f x y b@ --- 3. Update @g@'s closure: Add @y@ as an additional free variable, while --- removing @f@, because @f@ no longer allocates and can be floated to --- top-level. --- 4. Actually float the binding of @f@ to top-level, eliminating the @let@ --- in the process. --- --- This results in the following program (with free var annotations): --- --- @ --- f x y a = a + x + y; --- let x = ...; y = ... in --- let g = {x y} \b -> f x y b + x in --- g 5 --- @ --- --- This optimisation is all about lifting only when it is beneficial to do so. --- The above seems like a worthwhile lift, judging from heap allocation: --- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while --- not changing the size of @g@'s closure. --- --- You can probably sense that there's some kind of cost model at play here. --- And you are right! But we also employ a couple of other heuristics for the --- lifting decision which are outlined in "StgLiftLams.Analysis#when". --- --- The transformation is done in "StgLiftLams.Transformation", which calls out --- to 'StgLiftLams.Analysis.goodToLift' for its lifting decision. --- It relies on "StgLiftLams.LiftM", which abstracts some subtle STG invariants --- into a monadic substrate. --- --- Suffice to say: We trade heap allocation for stack allocation. --- The additional arguments have to passed on the stack (or in registers, --- depending on architecture) every time we call the function to save a single --- heap allocation when entering the let binding. Nofib suggests a mean --- improvement of about 1% for this pass, so it seems like a worthwhile thing to --- do. Compile-times went up by 0.6%, so all in all a very modest change. --- --- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith' --- that is ultimately compiled to something like this --- (module desugaring/lowering to actual STG): --- --- @ --- propagate dt = ...; --- runExperiment ... = --- let xs = ... in --- let ys = ... in --- let go = {dt go} \xs ys -> case (xs, ys) of --- ([], []) -> [] --- (x:xs', y:ys') -> propagate dt x y : go xs' ys' --- in go xs ys --- @ --- --- This will lambda lift @go@ to top-level, speeding up the resulting program --- by roughly one percent: --- --- @ --- propagate dt = ...; --- go dt xs ys = case (xs, ys) of --- ([], []) -> [] --- (x:xs', y:ys') -> propagate dt x y : go dt xs' ys' --- runExperiment ... = --- let xs = ... in --- let ys = ... in --- in go dt xs ys --- @ diff --git a/simplStg/StgLiftLams/Analysis.hs b/simplStg/StgLiftLams/Analysis.hs deleted file mode 100644 --- a/simplStg/StgLiftLams/Analysis.hs +++ /dev/null @@ -1,565 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} - --- | Provides the heuristics for when it's beneficial to lambda lift bindings. --- Most significantly, this employs a cost model to estimate impact on heap --- allocations, by looking at an STG expression's 'Skeleton'. -module StgLiftLams.Analysis ( - -- * #when# When to lift - -- $when - - -- * #clogro# Estimating closure growth - -- $clogro - - -- * AST annotation - Skeleton(..), BinderInfo(..), binderInfoBndr, - LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind, - -- * Lifting decision - goodToLift, - closureGrowth -- Exported just for the docs - ) where - -import GhcPrelude - -import BasicTypes -import Demand -import DynFlags -import Id -import SMRep ( WordOff ) -import StgSyn -import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep -import qualified GHC.StgToCmm.Closure as StgToCmm.Closure -import qualified GHC.StgToCmm.Layout as StgToCmm.Layout -import Outputable -import Util -import VarSet - -import Data.Maybe ( mapMaybe ) - --- Note [When to lift] --- ~~~~~~~~~~~~~~~~~~~ --- $when --- The analysis proceeds in two steps: --- --- 1. It tags the syntax tree with analysis information in the form of --- 'BinderInfo' at each binder and 'Skeleton's at each let-binding --- by 'tagSkeletonTopBind' and friends. --- 2. The resulting syntax tree is treated by the "StgLiftLams.Transformation" --- module, calling out to 'goodToLift' to decide if a binding is worthwhile --- to lift. --- 'goodToLift' consults argument occurrence information in 'BinderInfo' --- and estimates 'closureGrowth', for which it needs the 'Skeleton'. --- --- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift', --- which employs a number of heuristics to identify and exclude lambda lifting --- opportunities deemed non-beneficial: --- --- [Top-level bindings] can't be lifted. --- [Thunks] and data constructors shouldn't be lifted in order not to destroy --- sharing. --- [Argument occurrences] #arg_occs# of binders prohibit them to be lifted. --- Doing the lift would re-introduce the very allocation at call sites that --- we tried to get rid off in the first place. We capture analysis --- information in 'BinderInfo'. Note that we also consider a nullary --- application as argument occurrence, because it would turn into an n-ary --- partial application created by a generic apply function. This occurs in --- CPS-heavy code like the CS benchmark. --- [Join points] should not be lifted, simply because there's no reduction in --- allocation to be had. --- [Abstracting over join points] destroys join points, because they end up as --- arguments to the lifted function. --- [Abstracting over known local functions] turns a known call into an unknown --- call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off --- with @-fstg-lift-lams-known@. --- [Calling convention] Don't lift when the resulting function would have a --- higher arity than available argument registers for the calling convention. --- Can be influenced with @-fstg-lift-(non)rec-args(-any)@. --- [Closure growth] introduced when former free variables have to be available --- at call sites may actually lead to an increase in overall allocations --- resulting from a lift. Estimating closure growth is described in --- "StgLiftLams.Analysis#clogro" and is what most of this module is ultimately --- concerned with. --- --- There's a with --- some more background and history. - --- Note [Estimating closure growth] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- $clogro --- We estimate closure growth by abstracting the syntax tree into a 'Skeleton', --- capturing only syntactic details relevant to 'closureGrowth', such as --- --- * 'ClosureSk', representing closure allocation. --- * 'RhsSk', representing a RHS of a binding and how many times it's called --- by an appropriate 'DmdShell'. --- * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element. --- --- This abstraction is mostly so that the main analysis function 'closureGrowth' --- can stay simple and focused. Also, skeletons tend to be much smaller than --- the syntax tree they abstract, so it makes sense to construct them once and --- and operate on them instead of the actual syntax tree. --- --- A more detailed treatment of computing closure growth, including examples, --- can be found in the paper referenced from the --- . - -llTrace :: String -> SDoc -> a -> a -llTrace _ _ c = c --- llTrace a b c = pprTrace a b c - -type instance BinderP 'LiftLams = BinderInfo -type instance XRhsClosure 'LiftLams = DIdSet -type instance XLet 'LiftLams = Skeleton -type instance XLetNoEscape 'LiftLams = Skeleton - -freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet -freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] -freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs - --- | Captures details of the syntax tree relevant to the cost model, such as --- closures, multi-shot lambdas and case expressions. -data Skeleton - = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton - | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton - | AltSk !Skeleton !Skeleton - | BothSk !Skeleton !Skeleton - | NilSk - -bothSk :: Skeleton -> Skeleton -> Skeleton -bothSk NilSk b = b -bothSk a NilSk = a -bothSk a b = BothSk a b - -altSk :: Skeleton -> Skeleton -> Skeleton -altSk NilSk b = b -altSk a NilSk = a -altSk a b = AltSk a b - -rhsSk :: DmdShell -> Skeleton -> Skeleton -rhsSk _ NilSk = NilSk -rhsSk body_dmd skel = RhsSk body_dmd skel - --- | The type used in binder positions in 'GenStgExpr's. -data BinderInfo - = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag - -- indicating whether it occurs as an argument - -- or in a nullary application - -- (see "StgLiftLams.Analysis#arg_occs"). - | BoringBinder !Id -- ^ Every other kind of binder - --- | Gets the bound 'Id' out a 'BinderInfo'. -binderInfoBndr :: BinderInfo -> Id -binderInfoBndr (BoringBinder bndr) = bndr -binderInfoBndr (BindsClosure bndr _) = bndr - --- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating --- occurrences as argument or in a nullary applications otherwise. -binderInfoOccursAsArg :: BinderInfo -> Maybe Bool -binderInfoOccursAsArg BoringBinder{} = Nothing -binderInfoOccursAsArg (BindsClosure _ b) = Just b - -instance Outputable Skeleton where - ppr NilSk = text "" - ppr (AltSk l r) = vcat - [ text "{ " <+> ppr l - , text "ALT" - , text " " <+> ppr r - , text "}" - ] - ppr (BothSk l r) = ppr l $$ ppr r - ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body) - ppr (RhsSk body_dmd body) = hcat - [ text "λ[" - , ppr str - , text ", " - , ppr use - , text "]. " - , ppr body - ] - where - str - | isStrictDmd body_dmd = '1' - | otherwise = '0' - use - | isAbsDmd body_dmd = '0' - | isUsedOnce body_dmd = '1' - | otherwise = 'ω' - -instance Outputable BinderInfo where - ppr = ppr . binderInfoBndr - -instance OutputableBndr BinderInfo where - pprBndr b = pprBndr b . binderInfoBndr - pprPrefixOcc = pprPrefixOcc . binderInfoBndr - pprInfixOcc = pprInfixOcc . binderInfoBndr - bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr - -mkArgOccs :: [StgArg] -> IdSet -mkArgOccs = mkVarSet . mapMaybe stg_arg_var - where - stg_arg_var (StgVarArg occ) = Just occ - stg_arg_var _ = Nothing - --- | Tags every binder with its 'BinderInfo' and let bindings with their --- 'Skeleton's. -tagSkeletonTopBind :: CgStgBinding -> LlStgBinding --- NilSk is OK when tagging top-level bindings. Also, top-level things are never --- lambda-lifted, so no need to track their argument occurrences. They can also --- never be let-no-escapes (thus we pass False). -tagSkeletonTopBind bind = bind' - where - (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind - --- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with --- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder --- occurrences in argument and nullary application position --- (cf. "StgLiftLams.Analysis#arg_occs"). -tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr) -tagSkeletonExpr (StgLit lit) - = (NilSk, emptyVarSet, StgLit lit) -tagSkeletonExpr (StgConApp con args tys) - = (NilSk, mkArgOccs args, StgConApp con args tys) -tagSkeletonExpr (StgOpApp op args ty) - = (NilSk, mkArgOccs args, StgOpApp op args ty) -tagSkeletonExpr (StgApp f args) - = (NilSk, arg_occs, StgApp f args) - where - arg_occs - -- This checks for nullary applications, which we treat the same as - -- argument occurrences, see "StgLiftLams.Analysis#arg_occs". - | null args = unitVarSet f - | otherwise = mkArgOccs args -tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") -tagSkeletonExpr (StgCase scrut bndr ty alts) - = (skel, arg_occs, StgCase scrut' bndr' ty alts') - where - (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut - (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts - skel = bothSk scrut_skel (foldr altSk NilSk alt_skels) - arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr - bndr' = BoringBinder bndr -tagSkeletonExpr (StgTick t e) - = (skel, arg_occs, StgTick t e') - where - (skel, arg_occs, e') = tagSkeletonExpr e -tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind -tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind - -mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr -mkLet True = StgLetNoEscape -mkLet _ = StgLet - -tagSkeletonLet - :: Bool - -- ^ Is the binding a let-no-escape? - -> CgStgExpr - -- ^ Let body - -> CgStgBinding - -- ^ Binding group - -> (Skeleton, IdSet, LlStgExpr) - -- ^ RHS skeletons, argument occurrences and annotated binding -tagSkeletonLet is_lne body bind - = (let_skel, arg_occs, mkLet is_lne scope bind' body') - where - (body_skel, body_arg_occs, body') = tagSkeletonExpr body - (let_skel, arg_occs, scope, bind') - = tagSkeletonBinding is_lne body_skel body_arg_occs bind - -tagSkeletonBinding - :: Bool - -- ^ Is the binding a let-no-escape? - -> Skeleton - -- ^ Let body skeleton - -> IdSet - -- ^ Argument occurrences in the body - -> CgStgBinding - -- ^ Binding group - -> (Skeleton, IdSet, Skeleton, LlStgBinding) - -- ^ Let skeleton, argument occurrences, scope skeleton of binding and - -- the annotated binding -tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs) - = (let_skel, arg_occs, scope, bind') - where - (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs - arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr - bind_skel - | is_lne = rhs_skel -- no closure is allocated for let-no-escapes - | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel - let_skel = bothSk body_skel bind_skel - occurs_as_arg = bndr `elemVarSet` body_arg_occs - -- Compared to the recursive case, this exploits the fact that @bndr@ is - -- never free in @rhs@. - scope = body_skel - bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs' -tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs) - = (let_skel, arg_occs, scope, StgRec pairs') - where - (bndrs, _) = unzip pairs - -- Local recursive STG bindings also regard the defined binders as free - -- vars. We want to delete those for our cost model, as these are known - -- calls anyway when we add them to the same top-level recursive group as - -- the top-level binding currently being analysed. - skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs - rhss_arg_occs = map sndOf3 skel_occs_rhss' - scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs) - arg_occs = scope_occs `delVarSetList` bndrs - -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment, - -- but we also need the un-wrapped skeletons for calculating the @scope@ - -- of the group, as the outer closures don't contribute to closure growth - -- when we lift this specific binding. - scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss' - -- Now we can build the actual Skeleton for the expression just by - -- iterating over each bind pair. - (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss') - let_skel = foldr bothSk body_skel bind_skels - single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs')) - where - -- Here, we finally add the closure around each @skel_rhs@. - bind_skel - | is_lne = skel_rhs -- no closure is allocated for let-no-escapes - | otherwise = ClosureSk bndr fvs skel_rhs - fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs - bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs) - -tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs) -tagSkeletonRhs _ (StgRhsCon ccs dc args) - = (NilSk, mkArgOccs args, StgRhsCon ccs dc args) -tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body) - = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body') - where - bndrs' = map BoringBinder bndrs - (body_skel, body_arg_occs, body') = tagSkeletonExpr body - rhs_skel = rhsSk (rhsDmdShell bndr) body_skel - --- | How many times will the lambda body of the RHS bound to the given --- identifier be evaluated, relative to its defining context? This function --- computes the answer in form of a 'DmdShell'. -rhsDmdShell :: Id -> DmdShell -rhsDmdShell bndr - | is_thunk = oneifyDmd ds - | otherwise = peelManyCalls (idArity bndr) cd - where - is_thunk = idArity bndr == 0 - -- Let's pray idDemandInfo is still OK after unarise... - (ds, cd) = toCleanDmd (idDemandInfo bndr) - -tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt) -tagSkeletonAlt (con, bndrs, rhs) - = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs')) - where - (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs - arg_occs = alt_arg_occs `delVarSetList` bndrs - --- | Combines several heuristics to decide whether to lambda-lift a given --- @let@-binding to top-level. See "StgLiftLams.Analysis#when" for details. -goodToLift - :: DynFlags - -> TopLevelFlag - -> RecFlag - -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into - -- 'OutId's. See 'StgLiftLams.LiftM.liftedIdsExpander'. - -> [(BinderInfo, LlStgRhs)] - -> Skeleton - -> Maybe DIdSet -- ^ @Just abs_ids@ <=> This binding is beneficial to - -- lift and @abs_ids@ are the variables it would - -- abstract over -goodToLift dflags top_lvl rec_flag expander pairs scope = decide - [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift] - , ("memoized", any_memoized) - , ("argument occurrences", arg_occs) - , ("join point", is_join_point) - , ("abstracts join points", abstracts_join_ids) - , ("abstracts known local function", abstracts_known_local_fun) - , ("args spill on stack", args_spill_on_stack) - , ("increases allocation", inc_allocs) - ] where - decide deciders - | not (fancy_or deciders) - = llTrace "stgLiftLams:lifting" - (ppr bndrs <+> ppr abs_ids $$ - ppr allocs $$ - ppr scope) $ - Just abs_ids - | otherwise - = Nothing - ppr_deciders = vcat . map (text . fst) . filter snd - fancy_or deciders - = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $ - any snd deciders - - bndrs = map (binderInfoBndr . fst) pairs - bndrs_set = mkVarSet bndrs - rhss = map snd pairs - - -- First objective: Calculate @abs_ids@, e.g. the former free variables - -- the lifted binding would abstract over. We have to merge the free - -- variables of all RHS to get the set of variables that will have to be - -- passed through parameters. - fvs = unionDVarSets (map freeVarsOfRhs rhss) - -- To lift the binding to top-level, we want to delete the lifted binders - -- themselves from the free var set. Local let bindings track recursive - -- occurrences in their free variable set. We neither want to apply our - -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters - -- when lifted, as these are known calls. We call the resulting set the - -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's. - -- We will save the set in 'LiftM.e_expansions' for each of the variables - -- if we perform the lift. - abs_ids = expander (delDVarSetList fvs bndrs) - - -- We don't lift updatable thunks or constructors - any_memoized = any is_memoized_rhs rhss - is_memoized_rhs StgRhsCon{} = True - is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd - - -- Don't lift binders occuring as arguments. This would result in complex - -- argument expressions which would have to be given a name, reintroducing - -- the very allocation at each call site that we wanted to get rid off in - -- the first place. - arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs) - - -- These don't allocate anyway. - is_join_point = any isJoinId bndrs - - -- Abstracting over join points/let-no-escapes spoils them. - abstracts_join_ids = any isJoinId (dVarSetElems abs_ids) - - -- Abstracting over known local functions that aren't floated themselves - -- turns a known, fast call into an unknown, slow call: - -- - -- let f x = ... - -- g y = ... f x ... -- this was a known call - -- in g 4 - -- - -- After lifting @g@, but not @f@: - -- - -- l_g f y = ... f y ... -- this is now an unknown call - -- let f x = ... - -- in l_g f 4 - -- - -- We can abuse the results of arity analysis for this: - -- idArity f > 0 ==> known - known_fun id = idArity id > 0 - abstracts_known_local_fun - = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids) - - -- Number of arguments of a RHS in the current binding group if we decide - -- to lift it - n_args - = length - . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm - . (dVarSetElems abs_ids ++) - . rhsLambdaBndrs - max_n_args - | isRec rec_flag = liftLamsRecArgs dflags - | otherwise = liftLamsNonRecArgs dflags - -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess - -- args are passed on the stack, which means slow memory accesses - args_spill_on_stack - | Just n <- max_n_args = maximum (map n_args rhss) > n - | otherwise = False - - -- We only perform the lift if allocations didn't increase. - -- Note that @clo_growth@ will be 'infinity' if there was positive growth - -- under a multi-shot lambda. - -- Also, abstracting over LNEs is unacceptable. LNEs might return - -- unlifted tuples, which idClosureFootprint can't cope with. - inc_allocs = abstracts_join_ids || allocs > 0 - allocs = clo_growth + mkIntWithInf (negate closuresSize) - -- We calculate and then add up the size of each binding's closure. - -- GHC does not currently share closure environments, and we either lift - -- the entire recursive binding group or none of it. - closuresSize = sum $ flip map rhss $ \rhs -> - closureSize dflags - . dVarSetElems - . expander - . flip dVarSetMinusVarSet bndrs_set - $ freeVarsOfRhs rhs - clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope - -rhsLambdaBndrs :: LlStgRhs -> [Id] -rhsLambdaBndrs StgRhsCon{} = [] -rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs - --- | The size in words of a function closure closing over the given 'Id's, --- including the header. -closureSize :: DynFlags -> [Id] -> WordOff -closureSize dflags ids = words + sTD_HDR_SIZE dflags - -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't - -- optimise differently when profiling is enabled. - where - (words, _, _) - -- Functions have a StdHeader (as opposed to ThunkHeader). - = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader - . StgToCmm.Closure.addIdReps - . StgToCmm.Closure.nonVoidIds - $ ids - --- | The number of words a single 'Id' adds to a closure's size. --- Note that this can't handle unboxed tuples (which may still be present in --- let-no-escapes, even after Unarise), in which case --- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. -idClosureFootprint:: DynFlags -> Id -> WordOff -idClosureFootprint dflags - = StgToCmm.ArgRep.argRepSizeW dflags - . StgToCmm.ArgRep.idArgRep - --- | @closureGrowth expander sizer f fvs@ computes the closure growth in words --- as a result of lifting @f@ to top-level. If there was any growing closure --- under a multi-shot lambda, the result will be 'infinity'. --- Also see "StgLiftLams.Analysis#clogro". -closureGrowth - :: (DIdSet -> DIdSet) - -- ^ Expands outer free ids that were lifted to their free vars - -> (Id -> Int) - -- ^ Computes the closure footprint of an identifier - -> IdSet - -- ^ Binding group for which lifting is to be decided - -> DIdSet - -- ^ Free vars of the whole binding group prior to lifting it. These must be - -- available at call sites if we decide to lift the binding group. - -> Skeleton - -- ^ Abstraction of the scope of the function - -> IntWithInf - -- ^ Closure growth. 'infinity' indicates there was growth under a - -- (multi-shot) lambda. -closureGrowth expander sizer group abs_ids = go - where - go NilSk = 0 - go (BothSk a b) = go a + go b - go (AltSk a b) = max (go a) (go b) - go (ClosureSk _ clo_fvs rhs) - -- If no binder of the @group@ occurs free in the closure, the lifting - -- won't have any effect on it and we can omit the recursive call. - | n_occs == 0 = 0 - -- Otherwise, we account the cost of allocating the closure and add it to - -- the closure growth of its RHS. - | otherwise = mkIntWithInf cost + go rhs - where - n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group) - -- What we close over considering prior lifting decisions - clo_fvs' = expander clo_fvs - -- Variables that would additionally occur free in the closure body if - -- we lift @f@ - newbies = abs_ids `minusDVarSet` clo_fvs' - -- Lifting @f@ removes @f@ from the closure but adds all @newbies@ - cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs - go (RhsSk body_dmd body) - -- The conservative assumption would be that - -- 1. Every RHS with positive growth would be called multiple times, - -- modulo thunks. - -- 2. Every RHS with negative growth wouldn't be called at all. - -- - -- In the first case, we'd have to return 'infinity', while in the - -- second case, we'd have to return 0. But we can do far better - -- considering information from the demand analyser, which provides us - -- with conservative estimates on minimum and maximum evaluation - -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of - -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body - -- relative to its defining context. - | isAbsDmd body_dmd = 0 - | cg <= 0 = if isStrictDmd body_dmd then cg else 0 - | isUsedOnce body_dmd = cg - | otherwise = infinity - where - cg = go body diff --git a/simplStg/StgLiftLams/LiftM.hs b/simplStg/StgLiftLams/LiftM.hs deleted file mode 100644 --- a/simplStg/StgLiftLams/LiftM.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - --- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM' --- monad. -module StgLiftLams.LiftM ( - decomposeStgBinding, mkStgBinding, - Env (..), - -- * #floats# Handling floats - -- $floats - FloatLang (..), collectFloats, -- Exported just for the docs - -- * Transformation monad - LiftM, runLiftM, withCaffyness, - -- ** Adding bindings - startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding, - -- ** Substitution and binders - withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs, - -- ** Occurrences - substOcc, isLifted, formerFreeVars, liftedIdsExpander - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import BasicTypes -import CostCentre ( isCurrentCCS, dontCareCCS ) -import DynFlags -import FastString -import Id -import IdInfo -import Name -import Outputable -import OrdList -import StgSubst -import StgSyn -import Type -import UniqSupply -import Util -import VarEnv -import VarSet - -import Control.Arrow ( second ) -import Control.Monad.Trans.Class -import Control.Monad.Trans.RWS.Strict ( RWST, runRWST ) -import qualified Control.Monad.Trans.RWS.Strict as RWS -import Control.Monad.Trans.Cont ( ContT (..) ) -import Data.ByteString ( ByteString ) - --- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@ -decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)]) -decomposeStgBinding (StgRec pairs) = (Recursive, pairs) -decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)]) - -mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass -mkStgBinding Recursive = StgRec -mkStgBinding NonRecursive = uncurry StgNonRec . head - --- | Environment threaded around in a scoped, @Reader@-like fashion. -data Env - = Env - { e_dflags :: !DynFlags - -- ^ Read-only. - , e_subst :: !Subst - -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId', - -- because shadowing might make a closure's free variables unavailable at its - -- call sites. Consider: - -- @ - -- let f y = x + y in let x = 4 in f x - -- @ - -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't - -- available at its call site. - , e_expansions :: !(IdEnv DIdSet) - -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because - -- they are bound at the top-level. Every occurrence must supply the formerly - -- free variables of the lifted 'Id', so they in turn become free variables of - -- the call sites. This environment tracks this expansion from lifted 'Id's to - -- their free variables. - -- - -- 'InId's to 'OutId's. - -- - -- Invariant: 'Id's not present in this map won't be substituted. - , e_in_caffy_context :: !Bool - -- ^ Are we currently analysing within a caffy context (e.g. the containing - -- top-level binder's 'idCafInfo' is 'MayHaveCafRefs')? If not, we can safely - -- assume that functions we lift out aren't caffy either. - } - -emptyEnv :: DynFlags -> Env -emptyEnv dflags = Env dflags emptySubst emptyVarEnv False - - --- Note [Handling floats] --- ~~~~~~~~~~~~~~~~~~~~~~ --- $floats --- Consider the following expression: --- --- @ --- f x = --- let g y = ... f y ... --- in g x --- @ --- --- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@ --- binding above the binding for @f@: --- --- @ --- g f y = ... f y ... --- f x = g f x --- @ --- --- But this very unnecessarily turns a known call to @f@ into an unknown one, in --- addition to complicating matters for the analysis. --- Instead, we'd really like to put both functions in the same recursive group, --- thereby preserving the known call: --- --- @ --- Rec { --- g y = ... f y ... --- f x = g x --- } --- @ --- --- But we don't want this to happen for just /any/ binding. That would create --- possibly huge recursive groups in the process, calling for an occurrence --- analyser on STG. --- So, we need to track when we lift a binding out of a recursive RHS and add --- the binding to the same recursive group as the enclosing recursive binding --- (which must have either already been at the top-level or decided to be --- lifted itself in order to preserve the known call). --- --- This is done by expressing this kind of nesting structure as a 'Writer' over --- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to --- 'collectFloats'. --- API-wise, the analysis will not need to know about the whole 'FloatLang' --- business and will just manipulate it indirectly through actions in 'LiftM'. - --- | We need to detect when we are lifting something out of the RHS of a --- recursive binding (c.f. "StgLiftLams.LiftM#floats"), in which case that --- binding needs to be added to the same top-level recursive group. This --- requires we detect a certain nesting structure, which is encoded by --- 'StartBindingGroup' and 'EndBindingGroup'. --- --- Although 'collectFloats' will only ever care if the current binding to be --- lifted (through 'LiftedBinding') will occur inside such a binding group or --- not, e.g. doesn't care about the nesting level as long as its greater than 0. -data FloatLang - = StartBindingGroup - | EndBindingGroup - | PlainTopBinding OutStgTopBinding - | LiftedBinding OutStgBinding - -instance Outputable FloatLang where - ppr StartBindingGroup = char '(' - ppr EndBindingGroup = char ')' - ppr (PlainTopBinding StgTopStringLit{}) = text "" - ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b) - ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs) - where - (rec, pairs) = decomposeStgBinding bind - --- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats. --- Important pre-conditions: The nesting of opening 'StartBindinGroup's and --- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding --- group has at least one recursive binding inside. Otherwise there's no point --- in announcing the binding group in the first place and an @ASSERT@ will --- trigger. -collectFloats :: [FloatLang] -> [OutStgTopBinding] -collectFloats = go (0 :: Int) [] - where - go 0 [] [] = [] - go _ _ [] = pprPanic "collectFloats" (text "unterminated group") - go n binds (f:rest) = case f of - StartBindingGroup -> go (n+1) binds rest - EndBindingGroup - | n == 0 -> pprPanic "collectFloats" (text "no group to end") - | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest - | otherwise -> go (n-1) binds rest - PlainTopBinding top_bind - | n == 0 -> top_bind : go n binds rest - | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group") - LiftedBinding bind - | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest - | otherwise -> go n (bind:binds) rest - - map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding - rm_cccs = map_rhss removeRhsCCCS - merge_binds binds = ASSERT( any is_rec binds ) - StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds) - is_rec StgRec{} = True - is_rec _ = False - --- | Omitting this makes for strange closure allocation schemes that crash the --- GC. -removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass -removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body) - | isCurrentCCS ccs - = StgRhsClosure ext dontCareCCS upd bndrs body -removeRhsCCCS (StgRhsCon ccs con args) - | isCurrentCCS ccs - = StgRhsCon dontCareCCS con args -removeRhsCCCS rhs = rhs - --- | The analysis monad consists of the following 'RWST' components: --- --- * 'Env': Reader-like context. Contains a substitution, info about how --- how lifted identifiers are to be expanded into applications and details --- such as 'DynFlags' and a flag helping with determining if a lifted --- binding is caffy. --- --- * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program. --- --- * No pure state component --- --- * But wrapping around 'UniqSM' for generating fresh lifted binders. --- (The @uniqAway@ approach could give the same name to two different --- lifted binders, so this is necessary.) -newtype LiftM a - = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a } - deriving (Functor, Applicative, Monad) - -instance HasDynFlags LiftM where - getDynFlags = LiftM (RWS.asks e_dflags) - -instance MonadUnique LiftM where - getUniqueSupplyM = LiftM (lift getUniqueSupplyM) - getUniqueM = LiftM (lift getUniqueM) - getUniquesM = LiftM (lift getUniquesM) - -runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding] -runLiftM dflags us (LiftM m) = collectFloats (fromOL floats) - where - (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ()) - --- | Assumes a given caffyness for the execution of the passed action, which --- influences the 'cafInfo' of lifted bindings. -withCaffyness :: Bool -> LiftM a -> LiftM a -withCaffyness caffy action - = LiftM (RWS.local (\e -> e { e_in_caffy_context = caffy }) (unwrapLiftM action)) - --- | Writes a plain 'StgTopStringLit' to the output. -addTopStringLit :: OutId -> ByteString -> LiftM () -addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id - --- | Starts a recursive binding group. See #floats# and 'collectFloats'. -startBindingGroup :: LiftM () -startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup - --- | Ends a recursive binding group. See #floats# and 'collectFloats'. -endBindingGroup :: LiftM () -endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup - --- | Lifts a binding to top-level. Depending on whether it's declared inside --- a recursive RHS (see #floats# and 'collectFloats'), this might be added to --- an existing recursive top-level binding group. -addLiftedBinding :: OutStgBinding -> LiftM () -addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding - --- | Takes a binder and a continuation which is called with the substituted --- binder. The continuation will be evaluated in a 'LiftM' context in which that --- binder is deemed in scope. Think of it as a 'RWS.local' computation: After --- the continuation finishes, the new binding won't be in scope anymore. -withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a -withSubstBndr bndr inner = LiftM $ do - subst <- RWS.asks e_subst - let (bndr', subst') = substBndr bndr subst - RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr')) - --- | See 'withSubstBndr'. -withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a -withSubstBndrs = runContT . traverse (ContT . withSubstBndr) - --- | Similarly to 'withSubstBndr', this function takes a set of variables to --- abstract over, the binder to lift (and generate a fresh, substituted name --- for) and a continuation in which that fresh, lifted binder is in scope. --- --- It takes care of all the details involved with copying and adjusting the --- binder, fresh name generation and caffyness. -withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a -withLiftedBndr abs_ids bndr inner = do - uniq <- getUniqueM - let str = "$l" ++ occNameString (getOccName bndr) - let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) - -- When the enclosing top-level binding is not caffy, then the lifted - -- binding will not be caffy either. If we don't recognize this, non-caffy - -- things call caffy things and then codegen screws up. - in_caffy_ctxt <- LiftM (RWS.asks e_in_caffy_context) - let caf_info = if in_caffy_ctxt then MayHaveCafRefs else NoCafRefs - let bndr' - -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least - -- for arity information. - = transferPolyIdInfo bndr (dVarSetElems abs_ids) - -- Otherwise we confuse code gen if bndr was not caffy: the new bndr is - -- assumed to be caffy and will need an SRT. Transitive call sites might - -- not be caffy themselves and subsequently will miss a static link - -- field in their closure. Chaos ensues. - . flip setIdCafInfo caf_info - . mkSysLocalOrCoVar (mkFastString str) uniq - $ ty - LiftM $ RWS.local - (\e -> e - { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e - , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids - }) - (unwrapLiftM (inner bndr')) - --- | See 'withLiftedBndr'. -withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a -withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids) - --- | Substitutes a binder /occurrence/, which was brought in scope earlier by --- 'withSubstBndr'\/'withLiftedBndr'. -substOcc :: Id -> LiftM Id -substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst)) - --- | Whether the given binding was decided to be lambda lifted. -isLifted :: InId -> LiftM Bool -isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions)) - --- | Returns an empty list for a binding that was not lifted and the list of all --- local variables the binding abstracts over (so, exactly the additional --- arguments at adjusted call sites) otherwise. -formerFreeVars :: InId -> LiftM [OutId] -formerFreeVars f = LiftM $ do - expansions <- RWS.asks e_expansions - pure $ case lookupVarEnv expansions f of - Nothing -> [] - Just fvs -> dVarSetElems fvs - --- | Creates an /expander function/ for the current set of lifted binders. --- This expander function will replace any 'InId' by their corresponding 'OutId' --- and, in addition, will expand any lifted binders by the former free variables --- it abstracts over. -liftedIdsExpander :: LiftM (DIdSet -> DIdSet) -liftedIdsExpander = LiftM $ do - expansions <- RWS.asks e_expansions - subst <- RWS.asks e_subst - -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope" - -- warnings generated by 'lookupIdSubst' due to local bindings within RHS. - -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in - -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much - -- trouble. - let go set fv = case lookupVarEnv expansions fv of - Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted - Just fvs' -> unionDVarSet set fvs' - let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs) - pure expander diff --git a/simplStg/StgLiftLams/Transformation.hs b/simplStg/StgLiftLams/Transformation.hs deleted file mode 100644 --- a/simplStg/StgLiftLams/Transformation.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | (Mostly) textbook instance of the lambda lifting transformation, --- selecting which bindings to lambda lift by consulting 'goodToLift'. -module StgLiftLams.Transformation (stgLiftLams) where - -#include "HsVersions.h" - -import GhcPrelude - -import BasicTypes -import DynFlags -import Id -import IdInfo -import StgFVs ( annBindingFreeVars ) -import StgLiftLams.Analysis -import StgLiftLams.LiftM -import StgSyn -import Outputable -import UniqSupply -import Util -import VarSet -import Control.Monad ( when ) -import Data.Maybe ( isNothing ) - --- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift'). -stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding] -stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ()) - -liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM () -liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do - addTopStringLit bndr' lit - rest -liftTopLvl (StgTopLifted bind) rest = do - let is_rec = isRec $ fst $ decomposeStgBinding bind - when is_rec startBindingGroup - let bind_w_fvs = annBindingFreeVars bind - withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do - -- We signal lifting of a binding through returning Nothing. - -- Should never happen for a top-level binding, though, since we are already - -- at top-level. - case mb_bind' of - Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding") - Just bind' -> addLiftedBinding bind' - when is_rec endBindingGroup - rest - -withLiftedBind - :: TopLevelFlag - -> LlStgBinding - -> Skeleton - -> (Maybe OutStgBinding -> LiftM a) - -> LiftM a -withLiftedBind top_lvl bind scope k - | isTopLevel top_lvl - = withCaffyness (is_caffy pairs) go - | otherwise - = go - where - (rec, pairs) = decomposeStgBinding bind - is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst) - go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec)) - -withLiftedBindPairs - :: TopLevelFlag - -> RecFlag - -> [(BinderInfo, LlStgRhs)] - -> Skeleton - -> (Maybe [(Id, OutStgRhs)] -> LiftM a) - -> LiftM a -withLiftedBindPairs top rec pairs scope k = do - let (infos, rhss) = unzip pairs - let bndrs = map binderInfoBndr infos - expander <- liftedIdsExpander - dflags <- getDynFlags - case goodToLift dflags top rec expander pairs scope of - -- @abs_ids@ is the set of all variables that need to become parameters. - Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do - -- Within this block, all binders in @bndrs@ will be noted as lifted, so - -- that the return value of @liftedIdsExpander@ in this context will also - -- expand the bindings in @bndrs@ to their free variables. - -- Now we can recurse into the RHSs and see if we can lift any further - -- bindings. We pass the set of expanded free variables (thus OutIds) on - -- to @liftRhs@ so that it can add them as parameter binders. - when (isRec rec) startBindingGroup - rhss' <- traverse (liftRhs (Just abs_ids)) rhss - let pairs' = zip bndrs' rhss' - addLiftedBinding (mkStgBinding rec pairs') - when (isRec rec) endBindingGroup - k Nothing - Nothing -> withSubstBndrs bndrs $ \bndrs' -> do - -- Don't lift the current binding, but possibly some bindings in their - -- RHSs. - rhss' <- traverse (liftRhs Nothing) rhss - let pairs' = zip bndrs' rhss' - k (Just pairs') - -liftRhs - :: Maybe (DIdSet) - -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@ - -- as lambda binders, discarding all free vars. - -> LlStgRhs - -> LiftM OutStgRhs -liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args) - = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs) - StgRhsCon ccs con <$> traverse liftArgs args -liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do - -- This RHS wasn't lifted. - withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> - StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body -liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do - -- This RHS was lifted. Insert extra binders for @former_fvs@. - withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do - let bndrs'' = dVarSetElems former_fvs ++ bndrs' - StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body - -liftArgs :: InStgArg -> LiftM OutStgArg -liftArgs a@(StgLitArg _) = pure a -liftArgs (StgVarArg occ) = do - ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ ) - StgVarArg <$> substOcc occ - -liftExpr :: LlStgExpr -> LiftM OutStgExpr -liftExpr (StgLit lit) = pure (StgLit lit) -liftExpr (StgTick t e) = StgTick t <$> liftExpr e -liftExpr (StgApp f args) = do - f' <- substOcc f - args' <- traverse liftArgs args - fvs' <- formerFreeVars f - let top_lvl_args = map StgVarArg fvs' ++ args' - pure (StgApp f' top_lvl_args) -liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys -liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty -liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") -liftExpr (StgCase scrut info ty alts) = do - scrut' <- liftExpr scrut - withSubstBndr (binderInfoBndr info) $ \bndr' -> do - alts' <- traverse liftAlt alts - pure (StgCase scrut' bndr' ty alts') -liftExpr (StgLet scope bind body) - = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do - body' <- liftExpr body - case mb_bind' of - Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats - Just bind' -> pure (StgLet noExtFieldSilent bind' body') -liftExpr (StgLetNoEscape scope bind body) - = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do - body' <- liftExpr body - case mb_bind' of - Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs") - Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body') - -liftAlt :: LlStgAlt -> LiftM OutStgAlt -liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> - (,,) con bndrs' <$> liftExpr rhs diff --git a/simplStg/StgStats.hs b/simplStg/StgStats.hs deleted file mode 100644 --- a/simplStg/StgStats.hs +++ /dev/null @@ -1,173 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[StgStats]{Gathers statistical information about programs} - - -The program gather statistics about -\begin{enumerate} -\item number of boxed cases -\item number of unboxed cases -\item number of let-no-escapes -\item number of non-updatable lets -\item number of updatable lets -\item number of applications -\item number of primitive applications -\item number of closures (does not include lets bound to constructors) -\item number of free variables in closures -%\item number of top-level functions -%\item number of top-level CAFs -\item number of constructors -\end{enumerate} --} - -{-# LANGUAGE CPP #-} - -module StgStats ( showStgStats ) where - -#include "HsVersions.h" - -import GhcPrelude - -import StgSyn - -import Id (Id) -import Panic - -import Data.Map (Map) -import qualified Data.Map as Map - -data CounterType - = Literals - | Applications - | ConstructorApps - | PrimitiveApps - | LetNoEscapes - | StgCases - | FreeVariables - | ConstructorBinds Bool{-True<=>top-level-} - | ReEntrantBinds Bool{-ditto-} - | SingleEntryBinds Bool{-ditto-} - | UpdatableBinds Bool{-ditto-} - deriving (Eq, Ord) - -type Count = Int -type StatEnv = Map CounterType Count - -emptySE :: StatEnv -emptySE = Map.empty - -combineSE :: StatEnv -> StatEnv -> StatEnv -combineSE = Map.unionWith (+) - -combineSEs :: [StatEnv] -> StatEnv -combineSEs = foldr combineSE emptySE - -countOne :: CounterType -> StatEnv -countOne c = Map.singleton c 1 - -{- -************************************************************************ -* * -\subsection{Top-level list of bindings (a ``program'')} -* * -************************************************************************ --} - -showStgStats :: [StgTopBinding] -> String - -showStgStats prog - = "STG Statistics:\n\n" - ++ concat (map showc (Map.toList (gatherStgStats prog))) - where - showc (x,n) = (showString (s x) . shows n) "\n" - - s Literals = "Literals " - s Applications = "Applications " - s ConstructorApps = "ConstructorApps " - s PrimitiveApps = "PrimitiveApps " - s LetNoEscapes = "LetNoEscapes " - s StgCases = "StgCases " - s FreeVariables = "FreeVariables " - s (ConstructorBinds True) = "ConstructorBinds_Top " - s (ReEntrantBinds True) = "ReEntrantBinds_Top " - s (SingleEntryBinds True) = "SingleEntryBinds_Top " - s (UpdatableBinds True) = "UpdatableBinds_Top " - s (ConstructorBinds _) = "ConstructorBinds_Nested " - s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested " - s (SingleEntryBinds _) = "SingleEntryBinds_Nested " - s (UpdatableBinds _) = "UpdatableBinds_Nested " - -gatherStgStats :: [StgTopBinding] -> StatEnv -gatherStgStats binds = combineSEs (map statTopBinding binds) - -{- -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - -statTopBinding :: StgTopBinding -> StatEnv -statTopBinding (StgTopStringLit _ _) = countOne Literals -statTopBinding (StgTopLifted bind) = statBinding True bind - -statBinding :: Bool -- True <=> top-level; False <=> nested - -> StgBinding - -> StatEnv - -statBinding top (StgNonRec b rhs) - = statRhs top (b, rhs) - -statBinding top (StgRec pairs) - = combineSEs (map (statRhs top) pairs) - -statRhs :: Bool -> (Id, StgRhs) -> StatEnv - -statRhs top (_, StgRhsCon _ _ _) - = countOne (ConstructorBinds top) - -statRhs top (_, StgRhsClosure _ _ u _ body) - = statExpr body `combineSE` - countOne ( - case u of - ReEntrant -> ReEntrantBinds top - Updatable -> UpdatableBinds top - SingleEntry -> SingleEntryBinds top - ) - -{- -************************************************************************ -* * -\subsection{Expressions} -* * -************************************************************************ --} - -statExpr :: StgExpr -> StatEnv - -statExpr (StgApp _ _) = countOne Applications -statExpr (StgLit _) = countOne Literals -statExpr (StgConApp _ _ _)= countOne ConstructorApps -statExpr (StgOpApp _ _ _) = countOne PrimitiveApps -statExpr (StgTick _ e) = statExpr e - -statExpr (StgLetNoEscape _ binds body) - = statBinding False{-not top-level-} binds `combineSE` - statExpr body `combineSE` - countOne LetNoEscapes - -statExpr (StgLet _ binds body) - = statBinding False{-not top-level-} binds `combineSE` - statExpr body - -statExpr (StgCase expr _ _ alts) - = statExpr expr `combineSE` - stat_alts alts `combineSE` - countOne StgCases - where - stat_alts alts - = combineSEs (map statExpr [ e | (_,_,e) <- alts ]) - -statExpr (StgLam {}) = panic "statExpr StgLam" diff --git a/simplStg/UnariseStg.hs b/simplStg/UnariseStg.hs deleted file mode 100644 --- a/simplStg/UnariseStg.hs +++ /dev/null @@ -1,808 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-2012 - -Note [Unarisation] -~~~~~~~~~~~~~~~~~~ -The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum -binders. So for example: - - f (x :: (# Int, Bool #)) = f x + f (# 1, True #) - - ==> - - f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True - -It is important that we do this at the STG level and NOT at the Core level -because it would be very hard to make this pass Core-type-preserving. In this -example the type of 'f' changes, for example. - -STG fed to the code generators *must* be unarised because the code generators do -not support unboxed tuple and unboxed sum binders natively. - -In more detail: (see next note for unboxed sums) - -Suppose that a variable x : (# t1, t2 #). - - * At the binding site for x, make up fresh vars x1:t1, x2:t2 - - * Extend the UnariseEnv x :-> MultiVal [x1,x2] - - * Replace the binding with a curried binding for x1,x2 - - Lambda: \x.e ==> \x1 x2. e - Case alt: MkT a b x c d -> e ==> MkT a b x1 x2 c d -> e - - * Replace argument occurrences with a sequence of args via a lookup in - UnariseEnv - - f a b x c d ==> f a b x1 x2 c d - - * Replace tail-call occurrences with an unboxed tuple via a lookup in - UnariseEnv - - x ==> (# x1, x2 #) - - So, for example - - f x = x ==> f x1 x2 = (# x1, x2 #) - - * We /always/ eliminate a case expression when - - - It scrutinises an unboxed tuple or unboxed sum - - - The scrutinee is a variable (or when it is an explicit tuple, but the - simplifier eliminates those) - - The case alternative (there can be only one) can be one of these two - things: - - - An unboxed tuple pattern. e.g. - - case v of x { (# x1, x2, x3 #) -> ... } - - Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the - environment with - - x :-> MultiVal [t1,t2,t3] - x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3 - - - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3 - -By the end of this pass, we only have unboxed tuples in return positions. -Unboxed sums are completely eliminated, see next note. - -Note [Translating unboxed sums to unboxed tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unarise also eliminates unboxed sum binders, and translates unboxed sums in -return positions to unboxed tuples. We want to overlap fields of a sum when -translating it to a tuple to have efficient memory layout. When translating a -sum pattern to a tuple pattern, we need to translate it so that binders of sum -alternatives will be mapped to right arguments after the term translation. So -translation of sum DataCon applications to tuple DataCon applications and -translation of sum patterns to tuple patterns need to be in sync. - -These translations work like this. Suppose we have - - (# x1 | | ... #) :: (# t1 | t2 | ... #) - -remember that t1, t2 ... can be sums and tuples too. So we first generate -layouts of those. Then we "merge" layouts of each alternative, which gives us a -sum layout with best overlapping possible. - -Layout of a flat type 'ty1' is just [ty1]. -Layout of a tuple is just concatenation of layouts of its fields. - -For layout of a sum type, - - - We first get layouts of all alternatives. - - We sort these layouts based on their "slot types". - - We merge all the alternatives. - -For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #) - - - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ] - - Sorted: [ [Ptr, Word], [Word, Word], [Word] ] - - Merge all alternatives together: [ Ptr, Word, Word ] - -We add a slot for the tag to the first position. So our tuple type is - - (# Tag#, Any, Word#, Word# #) - (we use Any for pointer slots) - -Now, any term of this sum type needs to generate a tuple of this type instead. -The translation works by simply putting arguments to first slots that they fit -in. Suppose we had - - (# (# 42#, 'c' #) | | #) - -42# fits in Word#, 'c' fits in Any, so we generate this application: - - (# 1#, 'c', 42#, rubbish #) - -Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#, -3# fits in Word #, so we get: - - (# 2#, rubbish, 2#, 3# #). - - -Note [Don't merge lifted and unlifted slots] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When merging slots, one might be tempted to collapse lifted and unlifted -pointers. However, as seen in #19645, this is wrong. Imagine that you have -the program: - - test :: (# Char | ByteArray# #) -> ByteArray# - test (# c | #) = doSomething c - test (# | ba #) = ba - -Collapsing the Char and ByteArray# slots would produce STG like: - - test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray# - = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ] - case tag of tag' - 1# -> doSomething slot0 - 2# -> slot0; - -Note how `slot0` has a lifted type, despite being bound to an unlifted -ByteArray# in the 2# alternative. This liftedness would cause the code generator to -attempt to enter it upon returning. As unlifted objects do not have entry code, -this causes a runtime crash. - -For this reason, Unarise treats unlifted and lifted things as distinct slot -types, despite both being GC pointers. This approach is a slight pessimisation -(since we need to pass more arguments) but appears to be the simplest way to -avoid #19645. Other alternatives considered include: - - a. Giving unlifted objects "trivial" entry code. However, we ultimately - concluded that the value of the "unlifted things are never entered" invariant - outweighed the simplicity of this approach. - - b. Annotating occurrences with calling convention information instead of - relying on the binder's type. This seemed like a very complicated - way to fix what is ultimately a corner-case. - - -Note [Types in StgConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have this unboxed sum term: - - (# 123 | #) - -What will be the unboxed tuple representation? We can't tell without knowing the -type of this term. For example, these are all valid tuples for this: - - (# 1#, 123 #) -- when type is (# Int | String #) - (# 1#, 123, rubbish #) -- when type is (# Int | Float# #) - (# 1#, 123, rubbish, rubbish #) - -- when type is (# Int | (# Int, Int, Int #) #) - -So we pass type arguments of the DataCon's TyCon in StgConApp to decide what -layout to use. Note that unlifted values can't be let-bound, so we don't need -types in StgRhsCon. - -Note [UnariseEnv can map to literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To avoid redundant case expressions when unarising unboxed sums, UnariseEnv -needs to map variables to literals too. Suppose we have this Core: - - f (# x | #) - - ==> (CorePrep) - - case (# x | #) of y { - _ -> f y - } - - ==> (MultiVal) - - case (# 1#, x #) of [x1, x2] { - _ -> f x1 x2 - } - -To eliminate this case expression we need to map x1 to 1# in UnariseEnv: - - x1 :-> UnaryVal 1#, x2 :-> UnaryVal x - -so that `f x1 x2` becomes `f 1# x`. - -Note [Unarisation and arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of unarisation, the arity that will be recorded in the generated info -table for an Id may be larger than the idArity. Instead we record what we call -the RepArity, which is the Arity taking into account any expanded arguments, and -corresponds to the number of (possibly-void) *registers* arguments will arrive -in. - -Note [Post-unarisation invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -STG programs after unarisation have these invariants: - - * No unboxed sums at all. - - * No unboxed tuple binders. Tuples only appear in return position. - - * DataCon applications (StgRhsCon and StgConApp) don't have void arguments. - This means that it's safe to wrap `StgArg`s of DataCon applications with - `GHC.StgToCmm.Env.NonVoid`, for example. - - * Alt binders (binders in patterns) are always non-void. - - * Binders always have zero (for void arguments) or one PrimRep. --} - -{-# LANGUAGE CPP, TupleSections #-} - -module UnariseStg (unarise) where - -#include "HsVersions.h" - -import GhcPrelude - -import BasicTypes -import CoreSyn -import DataCon -import FastString (FastString, mkFastString) -import Id -import Literal -import MkCore (aBSENT_SUM_FIELD_ERROR_ID) -import MkId (voidPrimId, voidArgId) -import MonadUtils (mapAccumLM) -import Outputable -import RepType -import StgSyn -import Type -import TysPrim (intPrimTy,wordPrimTy,word64PrimTy) -import TysWiredIn -import UniqSupply -import Util -import VarEnv - -import Data.Bifunctor (second) -import Data.Maybe (mapMaybe) -import qualified Data.IntMap as IM - --------------------------------------------------------------------------------- - --- | A mapping from binders to the Ids they were expanded/renamed to. --- --- x :-> MultiVal [a,b,c] in rho --- --- iff x's typePrimRep is not a singleton, or equivalently --- x's type is an unboxed tuple, sum or void. --- --- x :-> UnaryVal x' --- --- iff x's RepType is UnaryRep or equivalently --- x's type is not unboxed tuple, sum or void. --- --- So --- x :-> MultiVal [a] in rho --- means x is represented by singleton tuple. --- --- x :-> MultiVal [] in rho --- means x is void. --- --- INVARIANT: OutStgArgs in the range only have NvUnaryTypes --- (i.e. no unboxed tuples, sums or voids) --- -type UnariseEnv = VarEnv UnariseVal - -data UnariseVal - = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). - | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation]. - -instance Outputable UnariseVal where - ppr (MultiVal args) = text "MultiVal" <+> ppr args - ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg - --- | Extend the environment, checking the UnariseEnv invariant. -extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv -extendRho rho x (MultiVal args) - = ASSERT(all (isNvUnaryType . stgArgType) args) - extendVarEnv rho x (MultiVal args) -extendRho rho x (UnaryVal val) - = ASSERT(isNvUnaryType (stgArgType val)) - extendVarEnv rho x (UnaryVal val) - --------------------------------------------------------------------------------- - -unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding] -unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds) - -unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding -unariseTopBinding rho (StgTopLifted bind) - = StgTopLifted <$> unariseBinding rho bind -unariseTopBinding _ bind@StgTopStringLit{} = return bind - -unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding -unariseBinding rho (StgNonRec x rhs) - = StgNonRec x <$> unariseRhs rho rhs -unariseBinding rho (StgRec xrhss) - = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss - -unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs -unariseRhs rho (StgRhsClosure ext ccs update_flag args expr) - = do (rho', args1) <- unariseFunArgBinders rho args - expr' <- unariseExpr rho' expr - return (StgRhsClosure ext ccs update_flag args1 expr') - -unariseRhs rho (StgRhsCon ccs con args) - = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con)) - return (StgRhsCon ccs con (unariseConArgs rho args)) - --------------------------------------------------------------------------------- - -unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr - -unariseExpr rho e@(StgApp f []) - = case lookupVarEnv rho f of - Just (MultiVal args) -- Including empty tuples - -> return (mkTuple args) - Just (UnaryVal (StgVarArg f')) - -> return (StgApp f' []) - Just (UnaryVal (StgLitArg f')) - -> return (StgLit f') - Nothing - -> return e - -unariseExpr rho e@(StgApp f args) - = return (StgApp f' (unariseFunArgs rho args)) - where - f' = case lookupVarEnv rho f of - Just (UnaryVal (StgVarArg f')) -> f' - Nothing -> f - err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err) - -- Can't happen because 'args' is non-empty, and - -- a tuple or sum cannot be applied to anything - -unariseExpr _ (StgLit l) - = return (StgLit l) - -unariseExpr rho (StgConApp dc args ty_args) - | Just args' <- unariseMulti_maybe rho dc args ty_args - = return (mkTuple args') - - | otherwise - , let args' = unariseConArgs rho args - = return (StgConApp dc args' (map stgArgType args')) - -unariseExpr rho (StgOpApp op args ty) - = return (StgOpApp op (unariseFunArgs rho args) ty) - -unariseExpr _ e@StgLam{} - = pprPanic "unariseExpr: found lambda" (ppr e) - -unariseExpr rho (StgCase scrut bndr alt_ty alts) - -- tuple/sum binders in the scrutinee can always be eliminated - | StgApp v [] <- scrut - , Just (MultiVal xs) <- lookupVarEnv rho v - = elimCase rho xs bndr alt_ty alts - - -- Handle strict lets for tuples and sums: - -- case (# a,b #) of r -> rhs - -- and analogously for sums - | StgConApp dc args ty_args <- scrut - , Just args' <- unariseMulti_maybe rho dc args ty_args - = elimCase rho args' bndr alt_ty alts - - -- general case - | otherwise - = do scrut' <- unariseExpr rho scrut - alts' <- unariseAlts rho alt_ty bndr alts - return (StgCase scrut' bndr alt_ty alts') - -- bndr may have a unboxed sum/tuple type but it will be - -- dead after unarise (checked in StgLint) - -unariseExpr rho (StgLet ext bind e) - = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e - -unariseExpr rho (StgLetNoEscape ext bind e) - = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e - -unariseExpr rho (StgTick tick e) - = StgTick tick <$> unariseExpr rho e - --- Doesn't return void args. -unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] -unariseMulti_maybe rho dc args ty_args - | isUnboxedTupleCon dc - = Just (unariseConArgs rho args) - - | isUnboxedSumCon dc - , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args) - = Just (mkUbxSum dc ty_args args1) - - | otherwise - = Nothing - --------------------------------------------------------------------------------- - -elimCase :: UnariseEnv - -> [OutStgArg] -- non-void args - -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr - -elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)] - = do let rho1 = extendRho rho bndr (MultiVal args) - rho2 - | isUnboxedTupleBndr bndr - = mapTupleIdBinders bndrs args rho1 - | otherwise - = ASSERT(isUnboxedSumBndr bndr) - if null bndrs then rho1 - else mapSumIdBinders bndrs args rho1 - - unariseExpr rho2 rhs - -elimCase rho args bndr (MultiValAlt _) alts - | isUnboxedSumBndr bndr - = do let (tag_arg : real_args) = args - tag_bndr <- mkId (mkFastString "tag") tagTy - -- this won't be used but we need a binder anyway - let rho1 = extendRho rho bndr (MultiVal args) - scrut' = case tag_arg of - StgVarArg v -> StgApp v [] - StgLitArg l -> StgLit l - - alts' <- unariseSumAlts rho1 real_args alts - return (StgCase scrut' tag_bndr tagAltTy alts') - -elimCase _ args bndr alt_ty alts - = pprPanic "elimCase - unhandled case" - (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts) - --------------------------------------------------------------------------------- - -unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt] -unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)] - | isUnboxedTupleBndr bndr - = do (rho', ys) <- unariseConArgBinder rho bndr - e' <- unariseExpr rho' e - return [(DataAlt (tupleDataCon Unboxed n), ys, e')] - -unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)] - | isUnboxedTupleBndr bndr - = do (rho', ys1) <- unariseConArgBinders rho ys - MASSERT(ys1 `lengthIs` n) - let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1)) - e' <- unariseExpr rho'' e - return [(DataAlt (tupleDataCon Unboxed n), ys1, e')] - -unariseAlts _ (MultiValAlt _) bndr alts - | isUnboxedTupleBndr bndr - = pprPanic "unariseExpr: strange multi val alts" (ppr alts) - --- In this case we don't need to scrutinize the tag bit -unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)] - | isUnboxedSumBndr bndr - = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr - rhs' <- unariseExpr rho_sum_bndrs rhs - return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')] - -unariseAlts rho (MultiValAlt _) bndr alts - | isUnboxedSumBndr bndr - = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr - alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts - let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts' - return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)), - scrt_bndrs, - inner_case) ] - -unariseAlts rho _ _ alts - = mapM (\alt -> unariseAlt rho alt) alts - -unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt -unariseAlt rho (con, xs, e) - = do (rho', xs') <- unariseConArgBinders rho xs - (con, xs',) <$> unariseExpr rho' e - --------------------------------------------------------------------------------- - --- | Make alternatives that match on the tag of a sum --- (i.e. generate LitAlts for the tag) -unariseSumAlts :: UnariseEnv - -> [StgArg] -- sum components _excluding_ the tag bit. - -> [StgAlt] -- original alternative with sum LHS - -> UniqSM [StgAlt] -unariseSumAlts env args alts - = do alts' <- mapM (unariseSumAlt env args) alts - return (mkDefaultLitAlt alts') - -unariseSumAlt :: UnariseEnv - -> [StgArg] -- sum components _excluding_ the tag bit. - -> StgAlt -- original alternative with sum LHS - -> UniqSM StgAlt -unariseSumAlt rho _ (DEFAULT, _, e) - = ( DEFAULT, [], ) <$> unariseExpr rho e - -unariseSumAlt rho args (DataAlt sumCon, bs, e) - = do let rho' = mapSumIdBinders bs args rho - e' <- unariseExpr rho' e - return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' ) - -unariseSumAlt _ scrt alt - = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt) - --------------------------------------------------------------------------------- - -mapTupleIdBinders - :: [InId] -- Un-processed binders of a tuple alternative. - -- Can have void binders. - -> [OutStgArg] -- Arguments that form the tuple (after unarisation). - -- Can't have void args. - -> UnariseEnv - -> UnariseEnv -mapTupleIdBinders ids args0 rho0 - = ASSERT(not (any (isVoidTy . stgArgType) args0)) - let - ids_unarised :: [(Id, [PrimRep])] - ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids - - map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv - map_ids rho [] _ = rho - map_ids rho ((x, x_reps) : xs) args = - let - x_arity = length x_reps - (x_args, args') = - ASSERT(args `lengthAtLeast` x_arity) - splitAt x_arity args - - rho' - | x_arity == 1 - = ASSERT(x_args `lengthIs` 1) - extendRho rho x (UnaryVal (head x_args)) - | otherwise - = extendRho rho x (MultiVal x_args) - in - map_ids rho' xs args' - in - map_ids rho0 ids_unarised args0 - -mapSumIdBinders - :: [InId] -- Binder of a sum alternative (remember that sum patterns - -- only have one binder, so this list should be a singleton) - -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). - -- Can't have void args. - -> UnariseEnv - -> UnariseEnv - -mapSumIdBinders [id] args rho0 - = ASSERT(not (any (isVoidTy . stgArgType) args)) - let - arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args - id_slots = map primRepSlot $ typePrimRep (idType id) - layout1 = layoutUbxSum arg_slots id_slots - in - if isMultiValBndr id - then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) - else ASSERT(layout1 `lengthIs` 1) - extendRho rho0 id (UnaryVal (args !! head layout1)) - -mapSumIdBinders ids sum_args _ - = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args) - --- | Build a unboxed sum term from arguments of an alternative. --- --- Example, for (# x | #) :: (# (# #) | Int #) we call --- --- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] --- --- which returns --- --- [ 1#, rubbish ] --- -mkUbxSum - :: DataCon -- Sum data con - -> [Type] -- Type arguments of the sum data con - -> [OutStgArg] -- Actual arguments of the alternative. - -> [OutStgArg] -- Final tuple arguments -mkUbxSum dc ty_args args0 - = let - (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) - -- drop tag slot - - tag = dataConTag dc - - layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) - tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy) - arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) - - mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] - mkTupArgs _ [] _ - = [] - mkTupArgs arg_idx (slot : slots_left) arg_map - | Just stg_arg <- IM.lookup arg_idx arg_map - = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map - | otherwise - = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map - - slotRubbishArg :: SlotTy -> StgArg - slotRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID - slotRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID - -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore - slotRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy) - slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy) - slotRubbishArg FloatSlot = StgLitArg (LitFloat 0) - slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0) - in - tag_arg : mkTupArgs 0 sum_slots arg_idxs - --------------------------------------------------------------------------------- - -{- -For arguments (StgArg) and binders (Id) we have two kind of unarisation: - - - When unarising function arg binders and arguments, we don't want to remove - void binders and arguments. For example, - - f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ... - f x y z = - - Here after unarise we should still get a function with arity 3. Similarly - in the call site we shouldn't remove void arguments: - - f (# (# #), (# #) #) voidId rw - - When unarising , we extend the environment with these binders: - - x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal [] - - Because their rep types are `MultiRep []` (aka. void). This means that when - we see `x` in a function argument position, we actually replace it with a - void argument. When we see it in a DataCon argument position, we just get - rid of it, because DataCon applications in STG are always saturated. - - - When unarising case alternative binders we remove void binders, but we - still update the environment the same way, because those binders may be - used in the RHS. Example: - - case x of y { - (# x1, x2, x3 #) -> - } - - We know that y can't be void, because we don't scrutinize voids, so x will - be unarised to some number of arguments, and those arguments will have at - least one non-void thing. So in the rho we will have something like: - - x :-> MultiVal [xu1, xu2] - - Now, after we eliminate void binders in the pattern, we get exactly the same - number of binders, and extend rho again with these: - - x1 :-> UnaryVal xu1 - x2 :-> MultiVal [] -- x2 is void - x3 :-> UnaryVal xu2 - - Now when we see x2 in a function argument position or in return position, we - generate void#. In constructor argument position, we just remove it. - -So in short, when we have a void id, - - - We keep it if it's a lambda argument binder or - in argument position of an application. - - - We remove it if it's a DataCon field binder or - in argument position of a DataCon application. --} - -unariseArgBinder - :: Bool -- data con arg? - -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) -unariseArgBinder is_con_arg rho x = - case typePrimRep (idType x) of - [] - | is_con_arg - -> return (extendRho rho x (MultiVal []), []) - | otherwise -- fun arg, do not remove void binders - -> return (extendRho rho x (MultiVal []), [voidArgId]) - - [rep] - -- Arg represented as single variable, but original type may still be an - -- unboxed sum/tuple, e.g. (# Void# | Void# #). - -- - -- While not unarising the binder in this case does not break any programs - -- (because it unarises to a single variable), it triggers StgLint as we - -- break the the post-unarisation invariant that says unboxed tuple/sum - -- binders should vanish. See Note [Post-unarisation invariants]. - | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x) - -> do x' <- mkId (mkFastString "us") (primRepToType rep) - return (extendRho rho x (MultiVal [StgVarArg x']), [x']) - | otherwise - -> return (rho, [x]) - - reps -> do - xs <- mkIds (mkFastString "us") (map primRepToType reps) - return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) - --------------------------------------------------------------------------------- - --- | MultiVal a function argument. Never returns an empty list. -unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] -unariseFunArg rho (StgVarArg x) = - case lookupVarEnv rho x of - Just (MultiVal []) -> [voidArg] -- NB: do not remove void args - Just (MultiVal as) -> as - Just (UnaryVal arg) -> [arg] - Nothing -> [StgVarArg x] -unariseFunArg _ arg = [arg] - -unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg] -unariseFunArgs = concatMap . unariseFunArg - -unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) -unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs - --- Result list of binders is never empty -unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) -unariseFunArgBinder = unariseArgBinder False - --------------------------------------------------------------------------------- - --- | MultiVal a DataCon argument. Returns an empty list when argument is void. -unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] -unariseConArg rho (StgVarArg x) = - case lookupVarEnv rho x of - Just (UnaryVal arg) -> [arg] - Just (MultiVal as) -> as -- 'as' can be empty - Nothing - | isVoidTy (idType x) -> [] -- e.g. C realWorld# - -- Here realWorld# is not in the envt, but - -- is a void, and so should be eliminated - | otherwise -> [StgVarArg x] -unariseConArg _ arg@(StgLitArg lit) = - ASSERT(not (isVoidTy (literalType lit))) -- We have no void literals - [arg] - -unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg] -unariseConArgs = concatMap . unariseConArg - -unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) -unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs - --- Different from `unariseFunArgBinder`: result list of binders may be empty. --- See DataCon applications case in Note [Post-unarisation invariants]. -unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) -unariseConArgBinder = unariseArgBinder True - --------------------------------------------------------------------------------- - -mkIds :: FastString -> [UnaryType] -> UniqSM [Id] -mkIds fs tys = mapM (mkId fs) tys - -mkId :: FastString -> UnaryType -> UniqSM Id -mkId = mkSysLocalOrCoVarM - -isMultiValBndr :: Id -> Bool -isMultiValBndr id - | [_] <- typePrimRep (idType id) - = False - | otherwise - = True - -isUnboxedSumBndr :: Id -> Bool -isUnboxedSumBndr = isUnboxedSumType . idType - -isUnboxedTupleBndr :: Id -> Bool -isUnboxedTupleBndr = isUnboxedTupleType . idType - -mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args) - -tagAltTy :: AltType -tagAltTy = PrimAlt IntRep - -tagTy :: Type -tagTy = intPrimTy - -voidArg :: StgArg -voidArg = StgVarArg voidPrimId - -mkDefaultLitAlt :: [StgAlt] -> [StgAlt] --- We have an exhauseive list of literal alternatives --- 1# -> e1 --- 2# -> e2 --- Since they are exhaustive, we can replace one with DEFAULT, to avoid --- generating a final test. Remember, the DEFAULT comes first if it exists. -mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts") -mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts -mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts -mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts) diff --git a/specialise/Rules.hs b/specialise/Rules.hs deleted file mode 100644 --- a/specialise/Rules.hs +++ /dev/null @@ -1,1263 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[CoreRules]{Transformation rules} --} - -{-# LANGUAGE CPP #-} - --- | Functions for collecting together and applying rewrite rules to a module. --- The 'CoreRule' datatype itself is declared elsewhere. -module Rules ( - -- ** Constructing - emptyRuleBase, mkRuleBase, extendRuleBaseList, - unionRuleBase, pprRuleBase, - - -- ** Checking rule applications - ruleCheckProgram, - - -- ** Manipulating 'RuleInfo' rules - mkRuleInfo, extendRuleInfo, addRuleInfo, - addIdSpecialisations, - - -- * Misc. CoreRule helpers - rulesOfBinds, getRules, pprRulesForUser, - - lookupRule, mkRule, roughTopNames - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -- All of it -import Module ( Module, ModuleSet, elemModuleSet ) -import CoreSubst -import CoreOpt ( exprIsLambda_maybe ) -import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars - , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) -import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, - stripTicksTopT, stripTicksTopE, - isJoinBind ) -import PprCore ( pprRules ) -import Type ( Type, TCvSubst, extendTvSubst, extendCvSubst - , mkEmptyTCvSubst, substTy ) -import TcType ( tcSplitTyConApp_maybe ) -import TysWiredIn ( anyTypeOfKind ) -import Coercion -import CoreTidy ( tidyRules ) -import Id -import IdInfo ( RuleInfo( RuleInfo ) ) -import Var -import VarEnv -import VarSet -import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) -import NameSet -import NameEnv -import UniqFM -import Unify ( ruleMatchTyKiX ) -import BasicTypes -import DynFlags ( DynFlags ) -import Outputable -import FastString -import Maybes -import Bag -import Util -import Data.List -import Data.Ord -import Control.Monad ( guard ) - -{- -Note [Overall plumbing for rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* After the desugarer: - - The ModGuts initially contains mg_rules :: [CoreRule] of - locally-declared rules for imported Ids. - - Locally-declared rules for locally-declared Ids are attached to - the IdInfo for that Id. See Note [Attach rules to local ids] in - DsBinds - -* TidyPgm strips off all the rules from local Ids and adds them to - mg_rules, so that the ModGuts has *all* the locally-declared rules. - -* The HomePackageTable contains a ModDetails for each home package - module. Each contains md_rules :: [CoreRule] of rules declared in - that module. The HomePackageTable grows as ghc --make does its - up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules - are treated by the "external" route, discussed next, regardless of - which package they come from. - -* The ExternalPackageState has a single eps_rule_base :: RuleBase for - Ids in other packages. This RuleBase simply grow monotonically, as - ghc --make compiles one module after another. - - During simplification, interface files may get demand-loaded, - as the simplifier explores the unfoldings for Ids it has in - its hand. (Via an unsafePerformIO; the EPS is really a cache.) - That in turn may make the EPS rule-base grow. In contrast, the - HPT never grows in this way. - -* The result of all this is that during Core-to-Core optimisation - there are four sources of rules: - - (a) Rules in the IdInfo of the Id they are a rule for. These are - easy: fast to look up, and if you apply a substitution then - it'll be applied to the IdInfo as a matter of course. - - (b) Rules declared in this module for imported Ids, kept in the - ModGuts. If you do a substitution, you'd better apply the - substitution to these. There are seldom many of these. - - (c) Rules declared in the HomePackageTable. These never change. - - (d) Rules in the ExternalPackageTable. These can grow in response - to lazy demand-loading of interfaces. - -* At the moment (c) is carried in a reader-monad way by the CoreMonad. - The HomePackageTable doesn't have a single RuleBase because technically - we should only be able to "see" rules "below" this module; so we - generate a RuleBase for (c) by combing rules from all the modules - "below" us. That's why we can't just select the home-package RuleBase - from HscEnv. - - [NB: we are inconsistent here. We should do the same for external - packages, but we don't. Same for type-class instances.] - -* So in the outer simplifier loop, we combine (b-d) into a single - RuleBase, reading - (b) from the ModGuts, - (c) from the CoreMonad, and - (d) from its mutable variable - [Of coures this means that we won't see new EPS rules that come in - during a single simplifier iteration, but that probably does not - matter.] - - -************************************************************************ -* * -\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} -* * -************************************************************************ - -A @CoreRule@ holds details of one rule for an @Id@, which -includes its specialisations. - -For example, if a rule for @f@ contains the mapping: -\begin{verbatim} - forall a b d. [Type (List a), Type b, Var d] ===> f' a b -\end{verbatim} -then when we find an application of f to matching types, we simply replace -it by the matching RHS: -\begin{verbatim} - f (List Int) Bool dict ===> f' Int Bool -\end{verbatim} -All the stuff about how many dictionaries to discard, and what types -to apply the specialised function to, are handled by the fact that the -Rule contains a template for the result of the specialisation. - -There is one more exciting case, which is dealt with in exactly the same -way. If the specialised value is unboxed then it is lifted at its -definition site and unlifted at its uses. For example: - - pi :: forall a. Num a => a - -might have a specialisation - - [Int#] ===> (case pi' of Lift pi# -> pi#) - -where pi' :: Lift Int# is the specialised version of pi. --} - -mkRule :: Module -> Bool -> Bool -> RuleName -> Activation - -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule --- ^ Used to make 'CoreRule' for an 'Id' defined in the module being --- compiled. See also 'CoreSyn.CoreRule' -mkRule this_mod is_auto is_local name act fn bndrs args rhs - = Rule { ru_name = name, ru_fn = fn, ru_act = act, - ru_bndrs = bndrs, ru_args = args, - ru_rhs = rhs, - ru_rough = roughTopNames args, - ru_origin = this_mod, - ru_orphan = orph, - ru_auto = is_auto, ru_local = is_local } - where - -- Compute orphanhood. See Note [Orphans] in InstEnv - -- A rule is an orphan only if none of the variables - -- mentioned on its left-hand side are locally defined - lhs_names = extendNameSet (exprsOrphNames args) fn - - -- Since rules get eventually attached to one of the free names - -- from the definition when compiling the ABI hash, we should make - -- it deterministic. This chooses the one with minimal OccName - -- as opposed to uniq value. - local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names - orph = chooseOrphanAnchor local_lhs_names - --------------- -roughTopNames :: [CoreExpr] -> [Maybe Name] --- ^ Find the \"top\" free names of several expressions. --- Such names are either: --- --- 1. The function finally being applied to in an application chain --- (if that name is a GlobalId: see "Var#globalvslocal"), or --- --- 2. The 'TyCon' if the expression is a 'Type' --- --- This is used for the fast-match-check for rules; --- if the top names don't match, the rest can't -roughTopNames args = map roughTopName args - -roughTopName :: CoreExpr -> Maybe Name -roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> Just (getName tc) - Nothing -> Nothing -roughTopName (Coercion _) = Nothing -roughTopName (App f _) = roughTopName f -roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] - , isDataConWorkId f || idArity f > 0 - = Just (idName f) -roughTopName (Tick t e) | tickishFloatable t - = roughTopName e -roughTopName _ = Nothing - -ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool --- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ --- definitely can't match @tpl@ by instantiating @tpl@. --- It's only a one-way match; unlike instance matching we --- don't consider unification. --- --- Notice that [_$_] --- @ruleCantMatch [Nothing] [Just n2] = False@ --- Reason: a template variable can be instantiated by a constant --- Also: --- @ruleCantMatch [Just n1] [Nothing] = False@ --- Reason: a local variable @v@ in the actuals might [_$_] - -ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as -ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as -ruleCantMatch _ _ = False - -{- -Note [Care with roughTopName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - module M where { x = a:b } - module N where { ...f x... - RULE f (p:q) = ... } -You'd expect the rule to match, because the matcher can -look through the unfolding of 'x'. So we must avoid roughTopName -returning 'M.x' for the call (f x), or else it'll say "can't match" -and we won't even try!! - -However, suppose we have - RULE g (M.h x) = ... - foo = ...(g (M.k v)).... -where k is a *function* exported by M. We never really match -functions (lambdas) except by name, so in this case it seems like -a good idea to treat 'M.k' as a roughTopName of the call. --} - -pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc --- (a) tidy the rules --- (b) sort them into order based on the rule name --- (c) suppress uniques (unless -dppr-debug is on) --- This combination makes the output stable so we can use in testing --- It's here rather than in PprCore because it calls tidyRules -pprRulesForUser dflags rules - = withPprStyle (defaultUserStyle dflags) $ - pprRules $ - sortBy (comparing ruleName) $ - tidyRules emptyTidyEnv rules - -{- -************************************************************************ -* * - RuleInfo: the rules in an IdInfo -* * -************************************************************************ --} - --- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable --- for putting into an 'IdInfo' -mkRuleInfo :: [CoreRule] -> RuleInfo -mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) - -extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo -extendRuleInfo (RuleInfo rs1 fvs1) rs2 - = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) - -addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo -addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) - = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) - -addIdSpecialisations :: Id -> [CoreRule] -> Id -addIdSpecialisations id rules - | null rules - = id - | otherwise - = setIdSpecialisation id $ - extendRuleInfo (idSpecialisation id) rules - --- | Gather all the rules for locally bound identifiers from the supplied bindings -rulesOfBinds :: [CoreBind] -> [CoreRule] -rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds - -getRules :: RuleEnv -> Id -> [CoreRule] --- See Note [Where rules are found] -getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn - = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules - where - imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] - -ruleIsVisible :: ModuleSet -> CoreRule -> Bool -ruleIsVisible _ BuiltinRule{} = True -ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } - = notOrphan orph || origin `elemModuleSet` vis_orphs - -{- Note [Where rules are found] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The rules for an Id come from two places: - (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), - (b) rules added in other modules, stored in the global RuleBase (imp_rules) - -It's tempting to think that - - LocalIds have only (a) - - non-LocalIds have only (b) - -but that isn't quite right: - - - PrimOps and ClassOps are born with a bunch of rules inside the Id, - even when they are imported - - - The rules in PrelRules.builtinRules should be active even - in the module defining the Id (when it's a LocalId), but - the rules are kept in the global RuleBase - - -************************************************************************ -* * - RuleBase -* * -************************************************************************ --} - --- RuleBase itself is defined in CoreSyn, along with CoreRule - -emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv - -mkRuleBase :: [CoreRule] -> RuleBase -mkRuleBase rules = extendRuleBaseList emptyRuleBase rules - -extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase -extendRuleBaseList rule_base new_guys - = foldl' extendRuleBase rule_base new_guys - -unionRuleBase :: RuleBase -> RuleBase -> RuleBase -unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 - -extendRuleBase :: RuleBase -> CoreRule -> RuleBase -extendRuleBase rule_base rule - = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule - -pprRuleBase :: RuleBase -> SDoc -pprRuleBase rules = pprUFM rules $ \rss -> - vcat [ pprRules (tidyRules emptyTidyEnv rs) - | rs <- rss ] - -{- -************************************************************************ -* * - Matching -* * -************************************************************************ --} - --- | The main rule matching function. Attempts to apply all (active) --- supplied rules to this instance of an application in a given --- context, returning the rule applied and the resulting expression if --- successful. -lookupRule :: DynFlags -> InScopeEnv - -> (Activation -> Bool) -- When rule is active - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) - --- See Note [Extra args in rule matching] --- See comments on matchRule -lookupRule dflags in_scope is_active fn args rules - = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ - case go [] rules of - [] -> Nothing - (m:ms) -> Just (findBest (fn,args') m ms) - where - rough_args = map roughTopName args - - -- Strip ticks from arguments, see note [Tick annotations in RULE - -- matching]. We only collect ticks if a rule actually matches - - -- this matters for performance tests. - args' = map (stripTicksTopE tickishFloatable) args - ticks = concatMap (stripTicksTopT tickishFloatable) args - - go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] - go ms [] = ms - go ms (r:rs) - | Just e <- matchRule dflags in_scope is_active fn args' rough_args r - = go ((r,mkTicks ticks e):ms) rs - | otherwise - = -- pprTrace "match failed" (ppr r $$ ppr args $$ - -- ppr [ (arg_id, unfoldingTemplate unf) - -- | Var arg_id <- args - -- , let unf = idUnfolding arg_id - -- , isCheapUnfolding unf] ) - go ms rs - -findBest :: (Id, [CoreExpr]) - -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) --- All these pairs matched the expression --- Return the pair the most specific rule --- The (fn,args) is just for overlap reporting - -findBest _ (rule,ans) [] = (rule,ans) -findBest target (rule1,ans1) ((rule2,ans2):prs) - | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs - | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs - | debugIsOn = let pp_rule rule - = ifPprDebug (ppr rule) - (doubleQuotes (ftext (ruleName rule))) - in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [ whenPprDebug $ - text "Expression to match:" <+> ppr fn - <+> sep (map ppr args) - , text "Rule 1:" <+> pp_rule rule1 - , text "Rule 2:" <+> pp_rule rule2]) $ - findBest target (rule1,ans1) prs - | otherwise = findBest target (rule1,ans1) prs - where - (fn,args) = target - -isMoreSpecific :: CoreRule -> CoreRule -> Bool --- This tests if one rule is more specific than another --- We take the view that a BuiltinRule is less specific than --- anything else, because we want user-define rules to "win" --- In particular, class ops have a built-in rule, but we --- any user-specific rules to win --- eg (#4397) --- truncate :: (RealFrac a, Integral b) => a -> b --- {-# RULES "truncate/Double->Int" truncate = double2Int #-} --- double2Int :: Double -> Int --- We want the specific RULE to beat the built-in class-op rule -isMoreSpecific (BuiltinRule {}) _ = False -isMoreSpecific (Rule {}) (BuiltinRule {}) = True -isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) - (Rule { ru_bndrs = bndrs2, ru_args = args2 - , ru_name = rule_name2, ru_rhs = rhs }) - = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs) - where - id_unfolding_fun _ = NoUnfolding -- Don't expand in templates - in_scope = mkInScopeSet (mkVarSet bndrs1) - -- Actually we should probably include the free vars - -- of rule1's args, but I can't be bothered - -noBlackList :: Activation -> Bool -noBlackList _ = False -- Nothing is black listed - -{- -Note [Extra args in rule matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find a matching rule, we return (Just (rule, rhs)), -but the rule firing has only consumed as many of the input args -as the ruleArity says. It's up to the caller to keep track -of any left-over args. E.g. if you call - lookupRule ... f [e1, e2, e3] -and it returns Just (r, rhs), where r has ruleArity 2 -then the real rewrite is - f e1 e2 e3 ==> rhs e3 - -You might think it'd be cleaner for lookupRule to deal with the -leftover arguments, by applying 'rhs' to them, but the main call -in the Simplifier works better as it is. Reason: the 'args' passed -to lookupRule are the result of a lazy substitution --} - ------------------------------------- -matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) - -> Id -> [CoreExpr] -> [Maybe Name] - -> CoreRule -> Maybe CoreExpr - --- If (matchRule rule args) returns Just (name,rhs) --- then (f args) matches the rule, and the corresponding --- rewritten RHS is rhs --- --- The returned expression is occurrence-analysed --- --- Example --- --- The rule --- forall f g x. map f (map g x) ==> map (f . g) x --- is stored --- CoreRule "map/map" --- [f,g,x] -- tpl_vars --- [f,map g x] -- tpl_args --- map (f.g) x) -- rhs --- --- Then the call: matchRule the_rule [e1,map e2 e3] --- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) --- --- Any 'surplus' arguments in the input are simply put on the end --- of the output. - -matchRule dflags rule_env _is_active fn args _rough_args - (BuiltinRule { ru_try = match_fn }) --- Built-in rules can't be switched off, it seems - = case match_fn dflags rule_env fn args of - Nothing -> Nothing - Just expr -> Just expr - -matchRule _ in_scope is_active _ args rough_args - (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops - , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) - | not (is_active act) = Nothing - | ruleCantMatch tpl_tops rough_args = Nothing - | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs - ---------------------------------------- -matchN :: InScopeEnv - -> RuleName -> [Var] -> [CoreExpr] - -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template - -> Maybe CoreExpr --- For a given match template and context, find bindings to wrap around --- the entire result and what should be substituted for each template variable. --- Fail if there are two few actual arguments from the target to match the template - -matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs - = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es - ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) - (mkEmptyTCvSubst in_scope) $ - tmpl_vars `zip` tmpl_vars1 - bind_wrapper = rs_binds rule_subst - -- Floated bindings; see Note [Matching lets] - ; return (bind_wrapper $ - mkLams tmpl_vars rhs `mkApps` matched_es) } - where - (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars - -- See Note [Cloning the template binders] - - init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 - , rv_lcl = init_rn_env - , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) - , rv_unf = id_unf } - - go _ subst [] _ = Just subst - go _ _ _ [] = Nothing -- Fail if too few actual args - go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e - ; go menv subst1 ts es } - - lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) - -- Need to return a RuleSubst solely for the benefit of mk_fake_ty - lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) - tcv_subst (tmpl_var, tmpl_var1) - | isId tmpl_var1 - = case lookupVarEnv id_subst tmpl_var1 of - Just e | Coercion co <- e - -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) - | otherwise - -> (tcv_subst, e) - Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 - , let co = Coercion.substCo tcv_subst refl_co - -> -- See Note [Unbound RULE binders] - (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) - | otherwise - -> unbound tmpl_var - - | otherwise - = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') - where - ty' = case lookupVarEnv tv_subst tmpl_var1 of - Just ty -> ty - Nothing -> fake_ty -- See Note [Unbound RULE binders] - fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) - -- This substitution is the sole reason we accumulate - -- TCvSubst in lookup_tmpl - - unbound tmpl_var - = pprPanic "Template variable unbound in rewrite rule" $ - vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) - , text "Rule" <+> pprRuleName rule_name - , text "Rule bndrs:" <+> ppr tmpl_vars - , text "LHS args:" <+> ppr tmpl_es - , text "Actual args:" <+> ppr target_es ] - - -{- Note [Unbound RULE binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be the case that the binder in a rule is not actually -bound on the LHS: - -* Type variables. Type synonyms with phantom args can give rise to - unbound template type variables. Consider this (#10689, - simplCore/should_compile/T10689): - - type Foo a b = b - - f :: Eq a => a -> Bool - f x = x==x - - {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} - finkle = f 'c' - - The rule looks like - forall (a::*) (d::Eq Char) (x :: Foo a Char). - f (Foo a Char) d x = True - - Matching the rule won't bind 'a', and legitimately so. We fudge by - pretending that 'a' is bound to (Any :: *). - -* Coercion variables. On the LHS of a RULE for a local binder - we might have - RULE forall (c :: a~b). f (x |> c) = e - Now, if that binding is inlined, so that a=b=Int, we'd get - RULE forall (c :: Int~Int). f (x |> c) = e - and now when we simplify the LHS (Simplify.simplRule) we - optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: - RULE forall (c :: Int~Int). f (x |> ) = e - and then perhaps drop it altogether. Now 'c' is unbound. - - It's tricky to be sure this never happens, so instead I - say it's OK to have an unbound coercion binder in a RULE - provided its type is (c :: t~t). Then, when the RULE - fires we can substitute for c. - - This actually happened (in a RULE for a local function) - in #13410, and also in test T10602. - -Note [Cloning the template binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following match (example 1): - Template: forall x. f x - Target: f (x+1) -This should succeed, because the template variable 'x' has nothing to -do with the 'x' in the target. - -Likewise this one (example 2): - Template: forall x. f (\x.x) - Target: f (\y.y) - -We achieve this simply by using rnBndrL to clone the template -binders if they are already in scope. - ------- Historical note ------- -At one point I tried simply adding the template binders to the -in-scope set /without/ cloning them, but that failed in a horribly -obscure way in #14777. Problem was that during matching we look -up target-term variables in the in-scope set (see Note [Lookup -in-scope]). If a target-term variable happens to name-clash with a -template variable, that lookup will find the template variable, which -is /utterly/ bogus. In #14777, this transformed a term variable -into a type variable, and then crashed when we wanted its idInfo. ------- End of historical note ------- - - -************************************************************************ -* * - The main matcher -* * -********************************************************************* -} - --- * The domain of the TvSubstEnv and IdSubstEnv are the template --- variables passed into the match. --- --- * The BindWrapper in a RuleSubst are the bindings floated out --- from nested matches; see the Let case of match, below --- -data RuleMatchEnv - = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* - -- (lambda/case) - , rv_tmpls :: VarSet -- Template variables - -- (after applying envL of rv_lcl) - , rv_fltR :: Subst -- Renamings for floated let-bindings - -- (domain disjoint from envR of rv_lcl) - -- See Note [Matching lets] - , rv_unf :: IdUnfoldingFun - } - -rvInScopeEnv :: RuleMatchEnv -> InScopeEnv -rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) - -data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the - , rs_id_subst :: IdSubstEnv -- template variables - , rs_binds :: BindWrapper -- Floated bindings - , rs_bndrs :: VarSet -- Variables bound by floated lets - } - -type BindWrapper = CoreExpr -> CoreExpr - -- See Notes [Matching lets] and [Matching cases] - -- we represent the floated bindings as a core-to-core function - -emptyRuleSubst :: RuleSubst -emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv - , rs_binds = \e -> e, rs_bndrs = emptyVarSet } - --- At one stage I tried to match even if there are more --- template args than real args. - --- I now think this is probably a bad idea. --- Should the template (map f xs) match (map g)? I think not. --- For a start, in general eta expansion wastes work. --- SLPJ July 99 - -match :: RuleMatchEnv - -> RuleSubst - -> CoreExpr -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst - --- We look through certain ticks. See Note [Tick annotations in RULE matching] -match renv subst e1 (Tick t e2) - | tickishFloatable t - = match renv subst' e1 e2 - where subst' = subst { rs_binds = rs_binds subst . mkTick t } -match renv subst (Tick t e1) e2 - -- Ignore ticks in rule template. - | tickishFloatable t - = match renv subst e1 e2 -match _ _ e@Tick{} _ - = pprPanic "Tick in rule" (ppr e) - --- See the notes with Unify.match, which matches types --- Everything is very similar for terms - --- Interesting examples: --- Consider matching --- \x->f against \f->f --- When we meet the lambdas we must remember to rename f to f' in the --- second expression. The RnEnv2 does that. --- --- Consider matching --- forall a. \b->b against \a->3 --- We must rename the \a. Otherwise when we meet the lambdas we --- might substitute [a/b] in the template, and then erroneously --- succeed in matching what looks like the template variable 'a' against 3. - --- The Var case follows closely what happens in Unify.match -match renv subst (Var v1) e2 - = match_var renv subst v1 e2 - -match renv subst e1 (Var v2) -- Note [Expanding variables] - | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] - , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') - = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' - where - v2' = lookupRnInScope rn_env v2 - rn_env = rv_lcl renv - -- Notice that we look up v2 in the in-scope set - -- See Note [Lookup in-scope] - -- No need to apply any renaming first (hence no rnOccR) - -- because of the not-inRnEnvR - -match renv subst e1 (Let bind e2) - | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ - not (isJoinBind bind) -- can't float join point out of argument position - , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] - = match (renv { rv_fltR = flt_subst' }) - (subst { rs_binds = rs_binds subst . Let bind' - , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) - e1 e2 - where - flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) - (flt_subst', bind') = substBind flt_subst bind - new_bndrs = bindersOf bind' - -{- Disabled: see Note [Matching cases] below -match renv (tv_subst, id_subst, binds) e1 - (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) - | exprOkForSpeculation scrut -- See Note [Matching cases] - , okToFloat rn_env bndrs (exprFreeVars scrut) - = match (renv { me_env = rn_env' }) - (tv_subst, id_subst, binds . case_wrap) - e1 rhs - where - rn_env = me_env renv - rn_env' = extendRnInScopeList rn_env bndrs - bndrs = case_bndr : alt_bndrs - case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] --} - -match _ subst (Lit lit1) (Lit lit2) - | lit1 == lit2 - = Just subst - -match renv subst (App f1 a1) (App f2 a2) - = do { subst' <- match renv subst f1 f2 - ; match renv subst' a1 a2 } - -match renv subst (Lam x1 e1) e2 - | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 - = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 - , rv_fltR = delBndr (rv_fltR renv) x2 } - subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } - in match renv' subst' e1 e2 - -match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) - = do { subst1 <- match_ty renv subst ty1 ty2 - ; subst2 <- match renv subst1 e1 e2 - ; let renv' = rnMatchBndr2 renv subst x1 x2 - ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted - } - -match renv subst (Type ty1) (Type ty2) - = match_ty renv subst ty1 ty2 -match renv subst (Coercion co1) (Coercion co2) - = match_co renv subst co1 co2 - -match renv subst (Cast e1 co1) (Cast e2 co2) - = do { subst1 <- match_co renv subst co1 co2 - ; match renv subst1 e1 e2 } - --- Everything else fails -match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ - Nothing - -------------- -match_co :: RuleMatchEnv - -> RuleSubst - -> Coercion - -> Coercion - -> Maybe RuleSubst -match_co renv subst co1 co2 - | Just cv <- getCoVar_maybe co1 - = match_var renv subst cv (Coercion co2) - | Just (ty1, r1) <- isReflCo_maybe co1 - = do { (ty2, r2) <- isReflCo_maybe co2 - ; guard (r1 == r2) - ; match_ty renv subst ty1 ty2 } -match_co renv subst co1 co2 - | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 - = case splitTyConAppCo_maybe co2 of - Just (tc2, cos2) - | tc1 == tc2 - -> match_cos renv subst cos1 cos2 - _ -> Nothing -match_co renv subst co1 co2 - | Just (arg1, res1) <- splitFunCo_maybe co1 - = case splitFunCo_maybe co2 of - Just (arg2, res2) - -> match_cos renv subst [arg1, res1] [arg2, res2] - _ -> Nothing -match_co _ _ _co1 _co2 - -- Currently just deals with CoVarCo, TyConAppCo and Refl -#if defined(DEBUG) - = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing -#else - = Nothing -#endif - -match_cos :: RuleMatchEnv - -> RuleSubst - -> [Coercion] - -> [Coercion] - -> Maybe RuleSubst -match_cos renv subst (co1:cos1) (co2:cos2) = - do { subst' <- match_co renv subst co1 co2 - ; match_cos renv subst' cos1 cos2 } -match_cos _ subst [] [] = Just subst -match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing - -------------- -rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv -rnMatchBndr2 renv subst x1 x2 - = renv { rv_lcl = rnBndr2 rn_env x1 x2 - , rv_fltR = delBndr (rv_fltR renv) x2 } - where - rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) - -- Typically this is a no-op, but it may matter if - -- there are some floated let-bindings - ------------------------------------------- -match_alts :: RuleMatchEnv - -> RuleSubst - -> [CoreAlt] -- Template - -> [CoreAlt] -- Target - -> Maybe RuleSubst -match_alts _ subst [] [] - = return subst -match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) - | c1 == c2 - = do { subst1 <- match renv' subst r1 r2 - ; match_alts renv subst1 alts1 alts2 } - where - renv' = foldl' mb renv (vs1 `zip` vs2) - mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 - -match_alts _ _ _ _ - = Nothing - ------------------------------------------- -okToFloat :: RnEnv2 -> VarSet -> Bool -okToFloat rn_env bind_fvs - = allVarSet not_captured bind_fvs - where - not_captured fv = not (inRnEnvR rn_env fv) - ------------------------------------------- -match_var :: RuleMatchEnv - -> RuleSubst - -> Var -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst -match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) - subst v1 e2 - | v1' `elemVarSet` tmpls - = match_tmpl_var renv subst v1' e2 - - | otherwise -- v1' is not a template variable; check for an exact match with e2 - = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR - Var v2 | v1' == rnOccR rn_env v2 - -> Just subst - - | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 - , v1' == v2' - -> Just subst - - _ -> Nothing - - where - v1' = rnOccL rn_env v1 - -- If the template is - -- forall x. f x (\x -> x) = ... - -- Then the x inside the lambda isn't the - -- template x, so we must rename first! - ------------------------------------------- -match_tmpl_var :: RuleMatchEnv - -> RuleSubst - -> Var -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst - -match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) - subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) - v1' e2 - | any (inRnEnvR rn_env) (exprFreeVarsList e2) - = Nothing -- Occurs check failure - -- e.g. match forall a. (\x-> a x) against (\y. y y) - - | Just e1' <- lookupVarEnv id_subst v1' - = if eqExpr (rnInScopeSet rn_env) e1' e2' - then Just subst - else Nothing - - | otherwise - = -- Note [Matching variable types] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- However, we must match the *types*; e.g. - -- forall (c::Char->Int) (x::Char). - -- f (c x) = "RULE FIRED" - -- We must only match on args that have the right type - -- It's actually quite difficult to come up with an example that shows - -- you need type matching, esp since matching is left-to-right, so type - -- args get matched first. But it's possible (e.g. simplrun008) and - -- this is the Right Thing to do - do { subst' <- match_ty renv subst (idType v1') (exprType e2) - ; return (subst' { rs_id_subst = id_subst' }) } - where - -- e2' is the result of applying flt_env to e2 - e2' | isEmptyVarSet let_bndrs = e2 - | otherwise = substExpr (text "match_tmpl_var") flt_env e2 - - id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' - -- No further renaming to do on e2', - -- because no free var of e2' is in the rnEnvR of the envt - ------------------------------------------- -match_ty :: RuleMatchEnv - -> RuleSubst - -> Type -- Template - -> Type -- Target - -> Maybe RuleSubst --- Matching Core types: use the matcher in TcType. --- Notice that we treat newtypes as opaque. For example, suppose --- we have a specialised version of a function at a newtype, say --- newtype T = MkT Int --- We only want to replace (f T) with f', not (f Int). - -match_ty renv subst ty1 ty2 - = do { tv_subst' - <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 - ; return (subst { rs_tv_subst = tv_subst' }) } - where - tv_subst = rs_tv_subst subst - -{- -Note [Expanding variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is another Very Important rule: if the term being matched is a -variable, we expand it so long as its unfolding is "expandable". (Its -occurrence information is not necessarily up to date, so we don't use -it.) By "expandable" we mean a WHNF or a "constructor-like" application. -This is the key reason for "constructor-like" Ids. If we have - {-# NOINLINE [1] CONLIKE g #-} - {-# RULE f (g x) = h x #-} -then in the term - let v = g 3 in ....(f v).... -we want to make the rule fire, to replace (f v) with (h 3). - -Note [Do not expand locally-bound variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do *not* expand locally-bound variables, else there's a worry that the -unfolding might mention variables that are themselves renamed. -Example - case x of y { (p,q) -> ...y... } -Don't expand 'y' to (p,q) because p,q might themselves have been -renamed. Essentially we only expand unfoldings that are "outside" -the entire match. - -Hence, (a) the guard (not (isLocallyBoundR v2)) - (b) when we expand we nuke the renaming envt (nukeRnEnvR). - -Note [Tick annotations in RULE matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We used to unconditionally look through ticks in both template and -expression being matched. This is actually illegal for counting or -cost-centre-scoped ticks, because we have no place to put them without -changing entry counts and/or costs. So now we just fail the match in -these cases. - -On the other hand, where we are allowed to insert new cost into the -tick scope, we can float them upwards to the rule application site. - -Moreover, we may encounter ticks in the template of a rule. There are a few -ways in which these may be introduced (e.g. #18162, #17619). Such ticks are -ignored by the matcher. See Note [Simplifying rules] in -GHC.Core.Opt.Simplify.Utils for details. - -cf Note [Notes in call patterns] in GHC.Core.Opt.SpecConstr - -Note [Matching lets] -~~~~~~~~~~~~~~~~~~~~ -Matching a let-expression. Consider - RULE forall x. f (g x) = -and target expression - f (let { w=R } in g E)) -Then we'd like the rule to match, to generate - let { w=R } in (\x. ) E -In effect, we want to float the let-binding outward, to enable -the match to happen. This is the WHOLE REASON for accumulating -bindings in the RuleSubst - -We can only do this if the free variables of R are not bound by the -part of the target expression outside the let binding; e.g. - f (\v. let w = v+1 in g E) -Here we obviously cannot float the let-binding for w. Hence the -use of okToFloat. - -There are a couple of tricky points. - (a) What if floating the binding captures a variable? - f (let v = x+1 in v) v - --> NOT! - let v = x+1 in f (x+1) v - - (b) What if two non-nested let bindings bind the same variable? - f (let v = e1 in b1) (let v = e2 in b2) - --> NOT! - let v = e1 in let v = e2 in (f b2 b2) - See testsuite test "RuleFloatLet". - -Our cunning plan is this: - * Along with the growing substitution for template variables - we maintain a growing set of floated let-bindings (rs_binds) - plus the set of variables thus bound. - - * The RnEnv2 in the MatchEnv binds only the local binders - in the term (lambdas, case) - - * When we encounter a let in the term to be matched, we - check that does not mention any locally bound (lambda, case) - variables. If so we fail - - * We use CoreSubst.substBind to freshen the binding, using an - in-scope set that is the original in-scope variables plus the - rs_bndrs (currently floated let-bindings). So in (a) above - we'll freshen the 'v' binding; in (b) above we'll freshen - the *second* 'v' binding. - - * We apply that freshening substitution, in a lexically-scoped - way to the term, although lazily; this is the rv_fltR field. - - -Note [Matching cases] -~~~~~~~~~~~~~~~~~~~~~ -{- NOTE: This idea is currently disabled. It really only works if - the primops involved are OkForSpeculation, and, since - they have side effects readIntOfAddr and touch are not. - Maybe we'll get back to this later . -} - -Consider - f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> - case touch# fp s# of { _ -> - I# n# } } ) -This happened in a tight loop generated by stream fusion that -Roman encountered. We'd like to treat this just like the let -case, because the primops concerned are ok-for-speculation. -That is, we'd like to behave as if it had been - case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> - case touch# fp s# of { _ -> - f (I# n# } } ) - -Note [Lookup in-scope] -~~~~~~~~~~~~~~~~~~~~~~ -Consider this example - foo :: Int -> Maybe Int -> Int - foo 0 (Just n) = n - foo m (Just n) = foo (m-n) (Just n) - -SpecConstr sees this fragment: - - case w_smT of wild_Xf [Just A] { - Data.Maybe.Nothing -> lvl_smf; - Data.Maybe.Just n_acT [Just S(L)] -> - case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> - $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf - }}; - -and correctly generates the rule - - RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# - sc_snn :: GHC.Prim.Int#} - $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) - = $s$wfoo_sno y_amr sc_snn ;] - -BUT we must ensure that this rule matches in the original function! -Note that the call to $wfoo is - $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf - -During matching we expand wild_Xf to (Just n_acT). But then we must also -expand n_acT to (I# y_amr). And we can only do that if we look up n_acT -in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding -at all. - -That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' -is so important. - - -************************************************************************ -* * - Rule-check the program -* * -************************************************************************ - - We want to know what sites have rules that could have fired but didn't. - This pass runs over the tree (without changing it) and reports such. --} - --- | Report partial matches for rules beginning with the specified --- string for the purposes of error reporting -ruleCheckProgram :: CompilerPhase -- ^ Rule activation test - -> String -- ^ Rule pattern - -> (Id -> [CoreRule]) -- ^ Rules for an Id - -> CoreProgram -- ^ Bindings to check in - -> SDoc -- ^ Resulting check message -ruleCheckProgram phase rule_pat rules binds - | isEmptyBag results - = text "Rule check results: no rule application sites" - | otherwise - = vcat [text "Rule check results:", - line, - vcat [ p $$ line | p <- bagToList results ] - ] - where - env = RuleCheckEnv { rc_is_active = isActive phase - , rc_id_unf = idUnfolding -- Not quite right - -- Should use activeUnfolding - , rc_pattern = rule_pat - , rc_rules = rules } - results = unionManyBags (map (ruleCheckBind env) binds) - line = text (replicate 20 '-') - -data RuleCheckEnv = RuleCheckEnv { - rc_is_active :: Activation -> Bool, - rc_id_unf :: IdUnfoldingFun, - rc_pattern :: String, - rc_rules :: Id -> [CoreRule] -} - -ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc - -- The Bag returned has one SDoc for each call site found -ruleCheckBind env (NonRec _ r) = ruleCheck env r -ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] - -ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc -ruleCheck _ (Var _) = emptyBag -ruleCheck _ (Lit _) = emptyBag -ruleCheck _ (Type _) = emptyBag -ruleCheck _ (Coercion _) = emptyBag -ruleCheck env (App f a) = ruleCheckApp env (App f a) [] -ruleCheck env (Tick _ e) = ruleCheck env e -ruleCheck env (Cast e _) = ruleCheck env e -ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e -ruleCheck env (Lam _ e) = ruleCheck env e -ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | (_,_,r) <- as] - -ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc -ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) -ruleCheckApp env (Var f) as = ruleCheckFun env f as -ruleCheckApp env other _ = ruleCheck env other - -ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc --- Produce a report for all rules matching the predicate --- saying why it doesn't match the specified application - -ruleCheckFun env fn args - | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) - where - name_match_rules = filter match (rc_rules env fn) - match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) - -ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc -ruleAppCheck_help env fn args rules - = -- The rules match the pattern, so we want to print something - vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), - vcat (map check_rule rules)] - where - n_args = length args - i_args = args `zip` [1::Int ..] - rough_args = map roughTopName args - - check_rule rule = sdocWithDynFlags $ \dflags -> - rule_herald rule <> colon <+> rule_info dflags rule - - rule_herald (BuiltinRule { ru_name = name }) - = text "Builtin rule" <+> doubleQuotes (ftext name) - rule_herald (Rule { ru_name = name }) - = text "Rule" <+> doubleQuotes (ftext name) - - rule_info dflags rule - | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) - noBlackList fn args rough_args rule - = text "matches (which is very peculiar!)" - - rule_info _ (BuiltinRule {}) = text "does not match" - - rule_info _ (Rule { ru_act = act, - ru_bndrs = rule_bndrs, ru_args = rule_args}) - | not (rc_is_active env act) = text "active only in later phase" - | n_args < n_rule_args = text "too few arguments" - | n_mismatches == n_rule_args = text "no arguments match" - | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" - | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" - where - n_rule_args = length rule_args - n_mismatches = length mismatches - mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, - not (isJust (match_fn rule_arg arg))] - - lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars - match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg - where - in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) - renv = RV { rv_lcl = mkRnEnv2 in_scope - , rv_tmpls = mkVarSet rule_bndrs - , rv_fltR = mkEmptySubst in_scope - , rv_unf = rc_id_unf env } diff --git a/specialise/SpecConstr.hs b/specialise/SpecConstr.hs deleted file mode 100644 --- a/specialise/SpecConstr.hs +++ /dev/null @@ -1,2356 +0,0 @@ -{- -ToDo [Oct 2013] -~~~~~~~~~~~~~~~ -1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) -2. Nuke NoSpecConstr - - -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[SpecConstr]{Specialise over constructors} --} - -{-# LANGUAGE CPP #-} - -module SpecConstr( - specConstrProgram, - SpecConstrAnnotation(..) - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreSubst -import CoreUtils -import CoreUnfold ( couldBeSmallEnoughToInline ) -import CoreFVs ( exprsFreeVarsList ) -import CoreMonad -import Literal ( litIsLifted ) -import HscTypes ( ModGuts(..) ) -import WwLib ( isWorkerSmallEnough, mkWorkerArgs ) -import DataCon -import Coercion hiding( substCo ) -import Rules -import Type hiding ( substTy ) -import TyCon ( tyConName ) -import Id -import PprCore ( pprParendExpr ) -import MkCore ( mkImpossibleExpr ) -import VarEnv -import VarSet -import Name -import BasicTypes -import DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) - , gopt, hasPprDebug ) -import Maybes ( orElse, catMaybes, isJust, isNothing ) -import Demand -import GHC.Serialized ( deserializeWithData ) -import Util -import Pair -import UniqSupply -import Outputable -import FastString -import UniqFM -import MonadUtils -import Control.Monad ( zipWithM ) -import Data.List -import PrelNames ( specTyConName ) -import Module -import TyCon ( TyCon ) -import GHC.Exts( SpecConstrAnnotation(..) ) -import Data.Ord( comparing ) - -{- ------------------------------------------------------ - Game plan ------------------------------------------------------ - -Consider - drop n [] = [] - drop 0 xs = [] - drop n (x:xs) = drop (n-1) xs - -After the first time round, we could pass n unboxed. This happens in -numerical code too. Here's what it looks like in Core: - - drop n xs = case xs of - [] -> [] - (y:ys) -> case n of - I# n# -> case n# of - 0 -> [] - _ -> drop (I# (n# -# 1#)) xs - -Notice that the recursive call has an explicit constructor as argument. -Noticing this, we can make a specialised version of drop - - RULE: drop (I# n#) xs ==> drop' n# xs - - drop' n# xs = let n = I# n# in ...orig RHS... - -Now the simplifier will apply the specialisation in the rhs of drop', giving - - drop' n# xs = case xs of - [] -> [] - (y:ys) -> case n# of - 0 -> [] - _ -> drop' (n# -# 1#) xs - -Much better! - -We'd also like to catch cases where a parameter is carried along unchanged, -but evaluated each time round the loop: - - f i n = if i>0 || i>n then i else f (i*2) n - -Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. -In Core, by the time we've w/wd (f is strict in i) we get - - f i# n = case i# ># 0 of - False -> I# i# - True -> case n of { I# n# -> - case i# ># n# of - False -> I# i# - True -> f (i# *# 2#) n - -At the call to f, we see that the argument, n is known to be (I# n#), -and n is evaluated elsewhere in the body of f, so we can play the same -trick as above. - - -Note [Reboxing] -~~~~~~~~~~~~~~~ -We must be careful not to allocate the same constructor twice. Consider - f p = (...(case p of (a,b) -> e)...p..., - ...let t = (r,s) in ...t...(f t)...) -At the recursive call to f, we can see that t is a pair. But we do NOT want -to make a specialised copy: - f' a b = let p = (a,b) in (..., ...) -because now t is allocated by the caller, then r and s are passed to the -recursive call, which allocates the (r,s) pair again. - -This happens if - (a) the argument p is used in other than a case-scrutinisation way. - (b) the argument to the call is not a 'fresh' tuple; you have to - look into its unfolding to see that it's a tuple - -Hence the "OR" part of Note [Good arguments] below. - -ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves -allocation, but does perhaps save evals. In the RULE we'd have -something like - - f (I# x#) = f' (I# x#) x# - -If at the call site the (I# x) was an unfolding, then we'd have to -rely on CSE to eliminate the duplicate allocation.... This alternative -doesn't look attractive enough to pursue. - -ALTERNATIVE 3: ignore the reboxing problem. The trouble is that -the conservative reboxing story prevents many useful functions from being -specialised. Example: - foo :: Maybe Int -> Int -> Int - foo (Just m) 0 = 0 - foo x@(Just m) n = foo x (n-m) -Here the use of 'x' will clearly not require boxing in the specialised function. - -The strictness analyser has the same problem, in fact. Example: - f p@(a,b) = ... -If we pass just 'a' and 'b' to the worker, it might need to rebox the -pair to create (a,b). A more sophisticated analysis might figure out -precisely the cases in which this could happen, but the strictness -analyser does no such analysis; it just passes 'a' and 'b', and hopes -for the best. - -So my current choice is to make SpecConstr similarly aggressive, and -ignore the bad potential of reboxing. - - -Note [Good arguments] -~~~~~~~~~~~~~~~~~~~~~ -So we look for - -* A self-recursive function. Ignore mutual recursion for now, - because it's less common, and the code is simpler for self-recursion. - -* EITHER - - a) At a recursive call, one or more parameters is an explicit - constructor application - AND - That same parameter is scrutinised by a case somewhere in - the RHS of the function - - OR - - b) At a recursive call, one or more parameters has an unfolding - that is an explicit constructor application - AND - That same parameter is scrutinised by a case somewhere in - the RHS of the function - AND - Those are the only uses of the parameter (see Note [Reboxing]) - - -What to abstract over -~~~~~~~~~~~~~~~~~~~~~ -There's a bit of a complication with type arguments. If the call -site looks like - - f p = ...f ((:) [a] x xs)... - -then our specialised function look like - - f_spec x xs = let p = (:) [a] x xs in ....as before.... - -This only makes sense if either - a) the type variable 'a' is in scope at the top of f, or - b) the type variable 'a' is an argument to f (and hence fs) - -Actually, (a) may hold for value arguments too, in which case -we may not want to pass them. Suppose 'x' is in scope at f's -defn, but xs is not. Then we'd like - - f_spec xs = let p = (:) [a] x xs in ....as before.... - -Similarly (b) may hold too. If x is already an argument at the -call, no need to pass it again. - -Finally, if 'a' is not in scope at the call site, we could abstract -it as we do the term variables: - - f_spec a x xs = let p = (:) [a] x xs in ...as before... - -So the grand plan is: - - * abstract the call site to a constructor-only pattern - e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) - - * Find the free variables of the abstracted pattern - - * Pass these variables, less any that are in scope at - the fn defn. But see Note [Shadowing] below. - - -NOTICE that we only abstract over variables that are not in scope, -so we're in no danger of shadowing variables used in "higher up" -in f_spec's RHS. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -In this pass we gather up usage information that may mention variables -that are bound between the usage site and the definition site; or (more -seriously) may be bound to something different at the definition site. -For example: - - f x = letrec g y v = let x = ... - in ...(g (a,b) x)... - -Since 'x' is in scope at the call site, we may make a rewrite rule that -looks like - RULE forall a,b. g (a,b) x = ... -But this rule will never match, because it's really a different 'x' at -the call site -- and that difference will be manifest by the time the -simplifier gets to it. [A worry: the simplifier doesn't *guarantee* -no-shadowing, so perhaps it may not be distinct?] - -Anyway, the rule isn't actually wrong, it's just not useful. One possibility -is to run deShadowBinds before running SpecConstr, but instead we run the -simplifier. That gives the simplest possible program for SpecConstr to -chew on; and it virtually guarantees no shadowing. - -Note [Specialising for constant parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This one is about specialising on a *constant* (but not necessarily -constructor) argument - - foo :: Int -> (Int -> Int) -> Int - foo 0 f = 0 - foo m f = foo (f m) (+1) - -It produces - - lvl_rmV :: GHC.Base.Int -> GHC.Base.Int - lvl_rmV = - \ (ds_dlk :: GHC.Base.Int) -> - case ds_dlk of wild_alH { GHC.Base.I# x_alG -> - GHC.Base.I# (GHC.Prim.+# x_alG 1) - - T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> - GHC.Prim.Int# - T.$wfoo = - \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> - case ww_sme of ds_Xlw { - __DEFAULT -> - case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> - T.$wfoo ww1_Xmz lvl_rmV - }; - 0 -> 0 - } - -The recursive call has lvl_rmV as its argument, so we could create a specialised copy -with that argument baked in; that is, not passed at all. Now it can perhaps be inlined. - -When is this worth it? Call the constant 'lvl' -- If 'lvl' has an unfolding that is a constructor, see if the corresponding - parameter is scrutinised anywhere in the body. - -- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding - parameter is applied (...to enough arguments...?) - - Also do this is if the function has RULES? - -Also - -Note [Specialising for lambda parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - foo :: Int -> (Int -> Int) -> Int - foo 0 f = 0 - foo m f = foo (f m) (\n -> n-m) - -This is subtly different from the previous one in that we get an -explicit lambda as the argument: - - T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> - GHC.Prim.Int# - T.$wfoo = - \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> - case ww_sm8 of ds_Xlr { - __DEFAULT -> - case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> - T.$wfoo - ww1_Xmq - (\ (n_ad3 :: GHC.Base.Int) -> - case n_ad3 of wild_alB { GHC.Base.I# x_alA -> - GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) - }) - }; - 0 -> 0 - } - -I wonder if SpecConstr couldn't be extended to handle this? After all, -lambda is a sort of constructor for functions and perhaps it already -has most of the necessary machinery? - -Furthermore, there's an immediate win, because you don't need to allocate the lambda -at the call site; and if perchance it's called in the recursive call, then you -may avoid allocating it altogether. Just like for constructors. - -Looks cool, but probably rare...but it might be easy to implement. - - -Note [SpecConstr for casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a :: * - data instance T Int = T Int - - foo n = ... - where - go (T 0) = 0 - go (T n) = go (T (n-1)) - -The recursive call ends up looking like - go (T (I# ...) `cast` g) -So we want to spot the constructor application inside the cast. -That's why we have the Cast case in argToPat - -Note [Local recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a *local* recursive group, we can see all the calls to the -function, so we seed the specialisation loop from the calls in the -body, not from the calls in the RHS. Consider: - - bar m n = foo n (n,n) (n,n) (n,n) (n,n) - where - foo n p q r s - | n == 0 = m - | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s } - | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s } - | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s } - | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) } - -If we start with the RHSs of 'foo', we get lots and lots of specialisations, -most of which are not needed. But if we start with the (single) call -in the rhs of 'bar' we get exactly one fully-specialised copy, and all -the recursive calls go to this fully-specialised copy. Indeed, the original -function is later collected as dead code. This is very important in -specialising the loops arising from stream fusion, for example in NDP where -we were getting literally hundreds of (mostly unused) specialisations of -a local function. - -In a case like the above we end up never calling the original un-specialised -function. (Although we still leave its code around just in case.) - -However, if we find any boring calls in the body, including *unsaturated* -ones, such as - letrec foo x y = ....foo... - in map foo xs -then we will end up calling the un-specialised function, so then we *should* -use the calls in the un-specialised RHS as seeds. We call these -"boring call patterns", and callsToPats reports if it finds any of these. - -Note [Seeding top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This seeding is done in the binding for seed_calls in specRec. - -1. If all the bindings in a top-level recursive group are local (not - exported), then all the calls are in the rest of the top-level - bindings. This means we can specialise with those call patterns - ONLY, and NOT with the RHSs of the recursive group (exactly like - Note [Local recursive groups]) - -2. But if any of the bindings are exported, the function may be called - with any old arguments, so (for lack of anything better) we specialise - based on - (a) the call patterns in the RHS - (b) the call patterns in the rest of the top-level bindings - NB: before Apr 15 we used (a) only, but Dimitrios had an example - where (b) was crucial, so I added that. - Adding (b) also improved nofib allocation results: - multiplier: 4% better - minimax: 2.8% better - -Actually in case (2), instead of using the calls from the RHS, it -would be better to specialise in the importing module. We'd need to -add an INLINABLE pragma to the function, and then it can be -specialised in the importing scope, just as is done for type classes -in Specialise.specImports. This remains to be done (#10346). - -Note [Top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To get the call usage information from "the rest of the top level -bindings" (c.f. Note [Seeding top-level recursive groups]), we work -backwards through the top-level bindings so we see the usage before we -get to the binding of the function. Before we can collect the usage -though, we go through all the bindings and add them to the -environment. This is necessary because usage is only tracked for -functions in the environment. These two passes are called - 'go' and 'goEnv' -in specConstrProgram. (Looks a bit revolting to me.) - -Note [Do not specialise diverging functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Specialising a function that just diverges is a waste of code. -Furthermore, it broke GHC (simpl014) thus: - {-# STR Sb #-} - f = \x. case x of (a,b) -> f x -If we specialise f we get - f = \x. case x of (a,b) -> fspec a b -But fspec doesn't have decent strictness info. As it happened, -(f x) :: IO t, so the state hack applied and we eta expanded fspec, -and hence f. But now f's strictness is less than its arity, which -breaks an invariant. - - -Note [Forcing specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With stream fusion and in other similar cases, we want to fully -specialise some (but not necessarily all!) loops regardless of their -size and the number of specialisations. - -We allow a library to do this, in one of two ways (one which is -deprecated): - - 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. - - 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, - and then add *that* type as a parameter to the loop body - -The reason #2 is deprecated is because it requires GHCi, which isn't -available for things like a cross compiler using stage1. - -Here's a (simplified) example from the `vector` package. You may bring -the special 'force specialization' type into scope by saying: - - import GHC.Types (SPEC(..)) - -or by defining your own type (again, deprecated): - - data SPEC = SPEC | SPEC2 - {-# ANN type SPEC ForceSpecConstr #-} - -(Note this is the exact same definition of GHC.Types.SPEC, just -without the annotation.) - -After that, you say: - - foldl :: (a -> b -> a) -> a -> Stream b -> a - {-# INLINE foldl #-} - foldl f z (Stream step s _) = foldl_loop SPEC z s - where - foldl_loop !sPEC z s = case step s of - Yield x s' -> foldl_loop sPEC (f z x) s' - Skip -> foldl_loop sPEC z s' - Done -> z - -SpecConstr will spot the SPEC parameter and always fully specialise -foldl_loop. Note that - - * We have to prevent the SPEC argument from being removed by - w/w which is why (a) SPEC is a sum type, and (b) we have to seq on - the SPEC argument. - - * And lastly, the SPEC argument is ultimately eliminated by - SpecConstr itself so there is no runtime overhead. - -This is all quite ugly; we ought to come up with a better design. - -ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set -sc_force to True when calling specLoop. This flag does four things: - - * Ignore specConstrThreshold, to specialise functions of arbitrary size - (see scTopBind) - * Ignore specConstrCount, to make arbitrary numbers of specialisations - (see specialise) - * Specialise even for arguments that are not scrutinised in the loop - (see argToPat; #4448) - * Only specialise on recursive types a finite number of times - (see is_too_recursive; #5550; Note [Limit recursive specialisation]) - -The flag holds only for specialising a single binding group, and NOT -for nested bindings. (So really it should be passed around explicitly -and not stored in ScEnv.) #14379 turned out to be caused by - f SPEC x = let g1 x = ... - in ... -We force-specialise f (because of the SPEC), but that generates a specialised -copy of g1 (as well as the original). Alas g1 has a nested binding g2; and -in each copy of g1 we get an unspecialised and specialised copy of g2; and so -on. Result, exponential. So the force-spec flag now only applies to one -level of bindings at a time. - -Mechanism for this one-level-only thing: - - - Switch it on at the call to specRec, in scExpr and scTopBinds - - Switch it off when doing the RHSs; - this can be done very conveniently in decreaseSpecCount - -What alternatives did I consider? - -* Annotating the loop itself doesn't work because (a) it is local and - (b) it will be w/w'ed and having w/w propagating annotations somehow - doesn't seem like a good idea. The types of the loop arguments - really seem to be the most persistent thing. - -* Annotating the types that make up the loop state doesn't work, - either, because (a) it would prevent us from using types like Either - or tuples here, (b) we don't want to restrict the set of types that - can be used in Stream states and (c) some types are fixed by the - user (e.g., the accumulator here) but we still want to specialise as - much as possible. - -Alternatives to ForceSpecConstr -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of giving the loop an extra argument of type SPEC, we -also considered *wrapping* arguments in SPEC, thus - data SPEC a = SPEC a | SPEC2 - - loop = \arg -> case arg of - SPEC state -> - case state of (x,y) -> ... loop (SPEC (x',y')) ... - S2 -> error ... -The idea is that a SPEC argument says "specialise this argument -regardless of whether the function case-analyses it". But this -doesn't work well: - * SPEC must still be a sum type, else the strictness analyser - eliminates it - * But that means that 'loop' won't be strict in its real payload -This loss of strictness in turn screws up specialisation, because -we may end up with calls like - loop (SPEC (case z of (p,q) -> (q,p))) -Without the SPEC, if 'loop' were strict, the case would move out -and we'd see loop applied to a pair. But if 'loop' isn't strict -this doesn't look like a specialisable call. - -Note [Limit recursive specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible for ForceSpecConstr to cause an infinite loop of specialisation. -Because there is no limit on the number of specialisations, a recursive call with -a recursive constructor as an argument (for example, list cons) will generate -a specialisation for that constructor. If the resulting specialisation also -contains a recursive call with the constructor, this could proceed indefinitely. - -For example, if ForceSpecConstr is on: - loop :: [Int] -> [Int] -> [Int] - loop z [] = z - loop z (x:xs) = loop (x:z) xs -this example will create a specialisation for the pattern - loop (a:b) c = loop' a b c - - loop' a b [] = (a:b) - loop' a b (x:xs) = loop (x:(a:b)) xs -and a new pattern is found: - loop (a:(b:c)) d = loop'' a b c d -which can continue indefinitely. - -Roman's suggestion to fix this was to stop after a couple of times on recursive types, -but still specialising on non-recursive types as much as possible. - -To implement this, we count the number of times we have gone round the -"specialise recursively" loop ('go' in 'specRec'). Once have gone round -more than N times (controlled by -fspec-constr-recursive=N) we check - - - If sc_force is off, and sc_count is (Just max) then we don't - need to do anything: trim_pats will limit the number of specs - - - Otherwise check if any function has now got more than (sc_count env) - specialisations. If sc_count is "no limit" then we arbitrarily - choose 10 as the limit (ugh). - -See #5550. Also #13623, where this test had become over-aggressive, -and we lost a wonderful specialisation that we really wanted! - -Note [NoSpecConstr] -~~~~~~~~~~~~~~~~~~~ -The ignoreDataCon stuff allows you to say - {-# ANN type T NoSpecConstr #-} -to mean "don't specialise on arguments of this type". It was added -before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised -regardless of size; and then we needed a way to turn that *off*. Now -that we have ForceSpecConstr, this NoSpecConstr is probably redundant. -(Used only for PArray, TODO: remove?) - ------------------------------------------------------ - Stuff not yet handled ------------------------------------------------------ - -Here are notes arising from Roman's work that I don't want to lose. - -Example 1 -~~~~~~~~~ - data T a = T !a - - foo :: Int -> T Int -> Int - foo 0 t = 0 - foo x t | even x = case t of { T n -> foo (x-n) t } - | otherwise = foo (x-1) t - -SpecConstr does no specialisation, because the second recursive call -looks like a boxed use of the argument. A pity. - - $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# - $wfoo_sFw = - \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> - case ww_sFo of ds_Xw6 [Just L] { - __DEFAULT -> - case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { - __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; - 0 -> - case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> - case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> - $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy - } } }; - 0 -> 0 - -Example 2 -~~~~~~~~~ - data a :*: b = !a :*: !b - data T a = T !a - - foo :: (Int :*: T Int) -> Int - foo (0 :*: t) = 0 - foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) } - | otherwise = foo ((x-1) :*: t) - -Very similar to the previous one, except that the parameters are now in -a strict tuple. Before SpecConstr, we have - - $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# - $wfoo_sG3 = - \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T - GHC.Base.Int) -> - case ww_sFU of ds_Xws [Just L] { - __DEFAULT -> - case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { - __DEFAULT -> - case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 - }; - 0 -> - case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> - case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 - } } }; - 0 -> 0 } - -We get two specialisations: -"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) - = Foo.$s$wfoo1 a_sFB sc_sGC ; -"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) - = Foo.$s$wfoo y_aFp sc_sGC ; - -But perhaps the first one isn't good. After all, we know that tpl_B2 is -a T (I# x) really, because T is strict and Int has one constructor. (We can't -unbox the strict fields, because T is polymorphic!) - -************************************************************************ -* * -\subsection{Top level wrapper stuff} -* * -************************************************************************ --} - -specConstrProgram :: ModGuts -> CoreM ModGuts -specConstrProgram guts - = do - dflags <- getDynFlags - us <- getUniqueSupplyM - annos <- getFirstAnnotations deserializeWithData guts - this_mod <- getModule - let binds' = reverse $ fst $ initUs us $ do - -- Note [Top-level recursive groups] - (env, binds) <- goEnv (initScEnv dflags this_mod annos) - (mg_binds guts) - -- binds is identical to (mg_binds guts), except that the - -- binders on the LHS have been replaced by extendBndr - -- (SPJ this seems like overkill; I don't think the binders - -- will change at all; and we don't substitute in the RHSs anyway!!) - go env nullUsage (reverse binds) - - return (guts { mg_binds = binds' }) - where - -- See Note [Top-level recursive groups] - goEnv env [] = return (env, []) - goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind - (env'', binds') <- goEnv env' binds - return (env'', bind' : binds') - - -- Arg list of bindings is in reverse order - go _ _ [] = return [] - go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind - binds' <- go env usg' binds - return (bind' : binds') - -{- -************************************************************************ -* * -\subsection{Environment: goes downwards} -* * -************************************************************************ - -Note [Work-free values only in environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_vals field keeps track of in-scope value bindings, so -that if we come across (case x of Just y ->...) we can reduce the -case from knowing that x is bound to a pair. - -But only *work-free* values are ok here. For example if the envt had - x -> Just (expensive v) -then we do NOT want to expand to - let y = expensive v in ... -because the x-binding still exists and we've now duplicated (expensive v). - -This seldom happens because let-bound constructor applications are -ANF-ised, but it can happen as a result of on-the-fly transformations in -SpecConstr itself. Here is #7865: - - let { - a'_shr = - case xs_af8 of _ { - [] -> acc_af6; - : ds_dgt [Dmd=] ds_dgu [Dmd=] -> - (expensive x_af7, x_af7 - } } in - let { - ds_sht = - case a'_shr of _ { (p'_afd, q'_afe) -> - TSpecConstr_DoubleInline.recursive - (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) - } } in - -When processed knowing that xs_af8 was bound to a cons, we simplify to - a'_shr = (expensive x_af7, x_af7) -and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. -(There are other occurrences of a'_shr.) No no no. - -It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned -into a work-free value again, thus - a1 = expensive x_af7 - a'_shr = (a1, x_af7) -but that's more work, so until its shown to be important I'm going to -leave it for now. - -Note [Making SpecConstr keener] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this, in (perf/should_run/T9339) - last (filter odd [1..1000]) - -After optimisation, including SpecConstr, we get: - f :: Int# -> Int -> Int - f x y = case case remInt# x 2# of - __DEFAULT -> case x of - __DEFAULT -> f (+# wild_Xp 1#) (I# x) - 1000000# -> ... - 0# -> case x of - __DEFAULT -> f (+# wild_Xp 1#) y - 1000000# -> y - -Not good! We build an (I# x) box every time around the loop. -SpecConstr (as described in the paper) does not specialise f, despite -the call (f ... (I# x)) because 'y' is not scrutinied in the body. -But it is much better to specialise f for the case where the argument -is of form (I# x); then we build the box only when returning y, which -is on the cold path. - -Another example: - - f x = ...(g x).... - -Here 'x' is not scrutinised in f's body; but if we did specialise 'f' -then the call (g x) might allow 'g' to be specialised in turn. - -So sc_keen controls whether or not we take account of whether argument is -scrutinised in the body. True <=> ignore that, and speicalise whenever -the function is applied to a data constructor. --} - -data ScEnv = SCE { sc_dflags :: DynFlags, - sc_module :: !Module, - sc_size :: Maybe Int, -- Size threshold - -- Nothing => no limit - - sc_count :: Maybe Int, -- Max # of specialisations for any one fn - -- Nothing => no limit - -- See Note [Avoiding exponential blowup] - - sc_recursive :: Int, -- Max # of specialisations over recursive type. - -- Stops ForceSpecConstr from diverging. - - sc_keen :: Bool, -- Specialise on arguments that are known - -- constructors, even if they are not - -- scrutinised in the body. See - -- Note [Making SpecConstr keener] - - sc_force :: Bool, -- Force specialisation? - -- See Note [Forcing specialisation] - - sc_subst :: Subst, -- Current substitution - -- Maps InIds to OutExprs - - sc_how_bound :: HowBoundEnv, - -- Binds interesting non-top-level variables - -- Domain is OutVars (*after* applying the substitution) - - sc_vals :: ValueEnv, - -- Domain is OutIds (*after* applying the substitution) - -- Used even for top-level bindings (but not imported ones) - -- The range of the ValueEnv is *work-free* values - -- such as (\x. blah), or (Just v) - -- but NOT (Just (expensive v)) - -- See Note [Work-free values only in environment] - - sc_annotations :: UniqFM SpecConstrAnnotation - } - ---------------------- -type HowBoundEnv = VarEnv HowBound -- Domain is OutVars - ---------------------- -type ValueEnv = IdEnv Value -- Domain is OutIds -data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors - -- The AltCon is never DEFAULT - | LambdaVal -- Inlinable lambdas or PAPs - -instance Outputable Value where - ppr (ConVal con args) = ppr con <+> interpp'SP args - ppr LambdaVal = text "" - ---------------------- -initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv -initScEnv dflags this_mod anns - = SCE { sc_dflags = dflags, - sc_module = this_mod, - sc_size = specConstrThreshold dflags, - sc_count = specConstrCount dflags, - sc_recursive = specConstrRecursive dflags, - sc_keen = gopt Opt_SpecConstrKeen dflags, - sc_force = False, - sc_subst = emptySubst, - sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv, - sc_annotations = anns } - -data HowBound = RecFun -- These are the recursive functions for which - -- we seek interesting call patterns - - | RecArg -- These are those functions' arguments, or their sub-components; - -- we gather occurrence information for these - -instance Outputable HowBound where - ppr RecFun = text "RecFun" - ppr RecArg = text "RecArg" - -scForce :: ScEnv -> Bool -> ScEnv -scForce env b = env { sc_force = b } - -lookupHowBound :: ScEnv -> Id -> Maybe HowBound -lookupHowBound env id = lookupVarEnv (sc_how_bound env) id - -scSubstId :: ScEnv -> Id -> CoreExpr -scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v - -scSubstTy :: ScEnv -> Type -> Type -scSubstTy env ty = substTy (sc_subst env) ty - -scSubstCo :: ScEnv -> Coercion -> Coercion -scSubstCo env co = substCo (sc_subst env) co - -zapScSubst :: ScEnv -> ScEnv -zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } - -extendScInScope :: ScEnv -> [Var] -> ScEnv - -- Bring the quantified variables into scope -extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars } - - -- Extend the substitution -extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv -extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } - -extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv -extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs } - -extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv -extendHowBound env bndrs how_bound - = env { sc_how_bound = extendVarEnvList (sc_how_bound env) - [(bndr,how_bound) | bndr <- bndrs] } - -extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) -extendBndrsWith how_bound env bndrs - = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') - where - (subst', bndrs') = substBndrs (sc_subst env) bndrs - hb_env' = sc_how_bound env `extendVarEnvList` - [(bndr,how_bound) | bndr <- bndrs'] - -extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) -extendBndrWith how_bound env bndr - = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr - hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound - -extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) -extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') - where - (subst', bndrs') = substRecBndrs (sc_subst env) bndrs - -extendBndr :: ScEnv -> Var -> (ScEnv, Var) -extendBndr env bndr = (env { sc_subst = subst' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr - -extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv -extendValEnv env _ Nothing = env -extendValEnv env id (Just cv) - | valueIsWorkFree cv -- Don't duplicate work!! #7865 - = env { sc_vals = extendVarEnv (sc_vals env) id cv } -extendValEnv env _ _ = env - -extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) --- When we encounter --- case scrut of b --- C x y -> ... --- we want to bind b, to (C x y) --- NB1: Extends only the sc_vals part of the envt --- NB2: Kill the dead-ness info on the pattern binders x,y, since --- they are potentially made alive by the [b -> C x y] binding -extendCaseBndrs env scrut case_bndr con alt_bndrs - = (env2, alt_bndrs') - where - live_case_bndr = not (isDeadBinder case_bndr) - env1 | Var v <- stripTicksTopE (const True) scrut - = extendValEnv env v cval - | otherwise = env -- See Note [Add scrutinee to ValueEnv too] - env2 | live_case_bndr = extendValEnv env1 case_bndr cval - | otherwise = env1 - - alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } - = map zap alt_bndrs - | otherwise - = alt_bndrs - - cval = case con of - DEFAULT -> Nothing - LitAlt {} -> Just (ConVal con []) - DataAlt {} -> Just (ConVal con vanilla_args) - where - vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ - varsToCoreExprs alt_bndrs - - zap v | isTyVar v = v -- See NB2 above - | otherwise = zapIdOccInfo v - - -decreaseSpecCount :: ScEnv -> Int -> ScEnv --- See Note [Avoiding exponential blowup] -decreaseSpecCount env n_specs - = env { sc_force = False -- See Note [Forcing specialisation] - , sc_count = case sc_count env of - Nothing -> Nothing - Just n -> Just (n `div` (n_specs + 1)) } - -- The "+1" takes account of the original function; - -- See Note [Avoiding exponential blowup] - ---------------------------------------------------- --- See Note [Forcing specialisation] -ignoreType :: ScEnv -> Type -> Bool -ignoreDataCon :: ScEnv -> DataCon -> Bool -forceSpecBndr :: ScEnv -> Var -> Bool - -ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) - -ignoreType env ty - = case tyConAppTyCon_maybe ty of - Just tycon -> ignoreTyCon env tycon - _ -> False - -ignoreTyCon :: ScEnv -> TyCon -> Bool -ignoreTyCon env tycon - = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr - -forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var - -forceSpecFunTy :: ScEnv -> Type -> Bool -forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys - -forceSpecArgTy :: ScEnv -> Type -> Bool -forceSpecArgTy env ty - | Just ty' <- coreView ty = forceSpecArgTy env ty' - -forceSpecArgTy env ty - | Just (tycon, tys) <- splitTyConApp_maybe ty - , tycon /= funTyCon - = tyConName tycon == specTyConName - || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr - || any (forceSpecArgTy env) tys - -forceSpecArgTy _ _ = False - -{- -Note [Add scrutinee to ValueEnv too] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -By the time we get to the call (f y), the ValueEnv -will have a binding for y, and for c - y -> (a,b) - c -> I# v -BUT that's not enough! Looking at the call (f y) we -see that y is pair (a,b), but we also need to know what 'b' is. -So in extendCaseBndrs we must *also* add the binding - b -> I# v -else we lose a useful specialisation for f. This is necessary even -though the simplifier has systematically replaced uses of 'x' with 'y' -and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came -from outside the case. See #4908 for the live example. - -Note [Avoiding exponential blowup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_count field of the ScEnv says how many times we are prepared to -duplicate a single function. But we must take care with recursive -specialisations. Consider - - let $j1 = let $j2 = let $j3 = ... - in - ...$j3... - in - ...$j2... - in - ...$j1... - -If we specialise $j1 then in each specialisation (as well as the original) -we can specialise $j2, and similarly $j3. Even if we make just *one* -specialisation of each, because we also have the original we'll get 2^n -copies of $j3, which is not good. - -So when recursively specialising we divide the sc_count by the number of -copies we are making at this level, including the original. - - -************************************************************************ -* * -\subsection{Usage information: flows upwards} -* * -************************************************************************ --} - -data ScUsage - = SCU { - scu_calls :: CallEnv, -- Calls - -- The functions are a subset of the - -- RecFuns in the ScEnv - - scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences - } -- The domain is OutIds - -type CallEnv = IdEnv [Call] -data Call = Call Id [CoreArg] ValueEnv - -- The arguments of the call, together with the - -- env giving the constructor bindings at the call site - -- We keep the function mainly for debug output - -instance Outputable ScUsage where - ppr (SCU { scu_calls = calls, scu_occs = occs }) - = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls - , text "occs =" <+> ppr occs ]) - -instance Outputable Call where - ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) - -nullUsage :: ScUsage -nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } - -combineCalls :: CallEnv -> CallEnv -> CallEnv -combineCalls = plusVarEnv_C (++) - where --- plus cs ds | length res > 1 --- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs --- , text "ds:" <+> ppr ds]) --- res --- | otherwise = res --- where --- res = cs ++ ds - -combineUsage :: ScUsage -> ScUsage -> ScUsage -combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), - scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } - -combineUsages :: [ScUsage] -> ScUsage -combineUsages [] = nullUsage -combineUsages us = foldr1 combineUsage us - -lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) -lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs - = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, - [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) - -data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument - | UnkOcc -- Used in some unknown way - - | ScrutOcc -- See Note [ScrutOcc] - (DataConEnv [ArgOcc]) -- How the sub-components are used - -type DataConEnv a = UniqFM a -- Keyed by DataCon - -{- Note [ScrutOcc] -~~~~~~~~~~~~~~~~~~~ -An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, -is *only* taken apart or applied. - - Functions, literal: ScrutOcc emptyUFM - Data constructors: ScrutOcc subs, - -where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, -The domain of the UniqFM is the Unique of the data constructor - -The [ArgOcc] is the occurrences of the *pattern-bound* components -of the data structure. E.g. - data T a = forall b. MkT a b (b->a) -A pattern binds b, x::a, y::b, z::b->a, but not 'a'! - --} - -instance Outputable ArgOcc where - ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs - ppr UnkOcc = text "unk-occ" - ppr NoOcc = text "no-occ" - -evalScrutOcc :: ArgOcc -evalScrutOcc = ScrutOcc emptyUFM - --- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so --- that if the thing is scrutinised anywhere then we get to see that --- in the overall result, even if it's also used in a boxed way --- This might be too aggressive; see Note [Reboxing] Alternative 3 -combineOcc :: ArgOcc -> ArgOcc -> ArgOcc -combineOcc NoOcc occ = occ -combineOcc occ NoOcc = occ -combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) -combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys -combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs -combineOcc UnkOcc UnkOcc = UnkOcc - -combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] -combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys - -setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage --- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee --- is a variable, and an interesting variable -setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ -setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ -setScrutOcc env usg (Var v) occ - | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } - | otherwise = usg -setScrutOcc _env usg _other _occ -- Catch-all - = usg - -{- -************************************************************************ -* * -\subsection{The main recursive function} -* * -************************************************************************ - -The main recursive function gathers up usage information, and -creates specialised versions of functions. --} - -scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) - -- The unique supply is needed when we invent - -- a new name for the specialised function and its args - -scExpr env e = scExpr' env e - -scExpr' env (Var v) = case scSubstId env v of - Var v' -> return (mkVarUsage env v' [], Var v') - e' -> scExpr (zapScSubst env) e' - -scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) -scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) -scExpr' _ e@(Lit {}) = return (nullUsage, e) -scExpr' env (Tick t e) = do (usg, e') <- scExpr env e - return (usg, Tick t e') -scExpr' env (Cast e co) = do (usg, e') <- scExpr env e - return (usg, mkCast e' (scSubstCo env co)) - -- Important to use mkCast here - -- See Note [SpecConstr call patterns] -scExpr' env e@(App _ _) = scApp env (collectArgs e) -scExpr' env (Lam b e) = do let (env', b') = extendBndr env b - (usg, e') <- scExpr env' e - return (usg, Lam b' e') - -scExpr' env (Case scrut b ty alts) - = do { (scrut_usg, scrut') <- scExpr env scrut - ; case isValue (sc_vals env) scrut' of - Just (ConVal con args) -> sc_con_app con args scrut' - _other -> sc_vanilla scrut_usg scrut' - } - where - sc_con_app con args scrut' -- Known constructor; simplify - = do { let (_, bs, rhs) = findAlt con alts - `orElse` (DEFAULT, [], mkImpossibleExpr ty) - alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) - ; scExpr alt_env' rhs } - - sc_vanilla scrut_usg scrut' -- Normal case - = do { let (alt_env,b') = extendBndrWith RecArg env b - -- Record RecArg for the components - - ; (alt_usgs, alt_occs, alts') - <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts - - ; let scrut_occ = foldr combineOcc NoOcc alt_occs - scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ - -- The combined usage of the scrutinee is given - -- by scrut_occ, which is passed to scScrut, which - -- in turn treats a bare-variable scrutinee specially - - ; return (foldr combineUsage scrut_usg' alt_usgs, - Case scrut' b' (scSubstTy env ty) alts') } - - sc_alt env scrut' b' (con,bs,rhs) - = do { let (env1, bs1) = extendBndrsWith RecArg env bs - (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 - ; (usg, rhs') <- scExpr env2 rhs - ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) - scrut_occ = case con of - DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) - _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } - -scExpr' env (Let (NonRec bndr rhs) body) - | isTyVar bndr -- Type-lets may be created by doBeta - = scExpr' (extendScSubst env bndr rhs) body - - | otherwise - = do { let (body_env, bndr') = extendBndr env bndr - ; rhs_info <- scRecRhs env (bndr',rhs) - - ; let body_env2 = extendHowBound body_env [bndr'] RecFun - -- Note [Local let bindings] - rhs' = ri_new_rhs rhs_info - body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') - - ; (body_usg, body') <- scExpr body_env3 body - - -- NB: For non-recursive bindings we inherit sc_force flag from - -- the parent function (see Note [Forcing specialisation]) - ; (spec_usg, specs) <- specNonRec env body_usg rhs_info - - ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } - `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg] - mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body') - } - - --- A *local* recursive group: see Note [Local recursive groups] -scExpr' env (Let (Rec prs) body) - = do { let (bndrs,rhss) = unzip prs - (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun - force_spec = any (forceSpecBndr env) bndrs' - -- Note [Forcing specialisation] - - ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; (body_usg, body') <- scExpr rhs_env2 body - - -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec) - body_usg rhs_infos - -- Do not unconditionally generate specialisations from rhs_usgs - -- Instead use them only if we find an unspecialised call - -- See Note [Local recursive groups] - - ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg] - bind' = Rec (concat (zipWith ruleInfoBinds rhs_infos specs)) - - ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, - Let bind' body') } - -{- -Note [Local let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is not uncommon to find this - - let $j = \x. in ...$j True...$j True... - -Here $j is an arbitrary let-bound function, but it often comes up for -join points. We might like to specialise $j for its call patterns. -Notice the difference from a letrec, where we look for call patterns -in the *RHS* of the function. Here we look for call patterns in the -*body* of the let. - -At one point I predicated this on the RHS mentioning the outer -recursive function, but that's not essential and might even be -harmful. I'm not sure. --} - -scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) - -scApp env (Var fn, args) -- Function is a variable - = ASSERT( not (null args) ) - do { args_w_usgs <- mapM (scExpr env) args - ; let (arg_usgs, args') = unzip args_w_usgs - arg_usg = combineUsages arg_usgs - ; case scSubstId env fn of - fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') - -- Do beta-reduction and try again - - Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', - mkApps (Var fn') args') - - other_fn' -> return (arg_usg, mkApps other_fn' args') } - -- NB: doing this ignores any usage info from the substituted - -- function, but I don't think that matters. If it does - -- we can fix it. - where - doBeta :: OutExpr -> [OutExpr] -> OutExpr - -- ToDo: adjust for System IF - doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) - doBeta fn args = mkApps fn args - --- The function is almost always a variable, but not always. --- In particular, if this pass follows float-in, --- which it may, we can get --- (let f = ...f... in f) arg1 arg2 -scApp env (other_fn, args) - = do { (fn_usg, fn') <- scExpr env other_fn - ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args - ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } - ----------------------- -mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage -mkVarUsage env fn args - = case lookupHowBound env fn of - Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] - , scu_occs = emptyVarEnv } - Just RecArg -> SCU { scu_calls = emptyVarEnv - , scu_occs = unitVarEnv fn arg_occ } - Nothing -> nullUsage - where - -- I rather think we could use UnkOcc all the time - arg_occ | null args = UnkOcc - | otherwise = evalScrutOcc - ----------------------- -scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) -scTopBindEnv env (Rec prs) - = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs RecFun - - prs' = zip bndrs' rhss - ; return (rhs_env2, Rec prs') } - where - (bndrs,rhss) = unzip prs - -scTopBindEnv env (NonRec bndr rhs) - = do { let (env1, bndr') = extendBndr env bndr - env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) - ; return (env2, NonRec bndr' rhs) } - ----------------------- -scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) - -{- -scTopBind _ usage _ - | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False - = error "false" --} - -scTopBind env body_usage (Rec prs) - | Just threshold <- sc_size env - , not force_spec - , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) - -- No specialisation - = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ - do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss - ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) } - - | otherwise -- Do specialisation - = do { rhs_infos <- mapM (scRecRhs env) prs - - ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec) - body_usage rhs_infos - - ; return (body_usage `combineUsage` spec_usage, - Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) } - where - (bndrs,rhss) = unzip prs - force_spec = any (forceSpecBndr env) bndrs - -- Note [Forcing specialisation] - -scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions - = do { (rhs_usg', rhs') <- scExpr env rhs - ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } - ----------------------- -scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo -scRecRhs env (bndr,rhs) - = do { let (arg_bndrs,body) = collectBinders rhs - (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs - ; (body_usg, body') <- scExpr body_env body - ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' - ; return (RI { ri_rhs_usg = rhs_usg - , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' - , ri_lam_bndrs = arg_bndrs, ri_lam_body = body - , ri_arg_occs = arg_occs }) } - -- The arg_occs says how the visible, - -- lambda-bound binders of the RHS are used - -- (including the TyVar binders) - -- Two pats are the same if they match both ways - ----------------------- -ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] -ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) - (SI { si_specs = specs }) - = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++ - -- First the specialised bindings - - [(fn `addIdSpecialisations` rules, new_rhs)] - -- And now the original binding - where - rules = [r | OS { os_rule = r } <- specs] - -{- -************************************************************************ -* * - The specialiser itself -* * -************************************************************************ --} - -data RhsInfo - = RI { ri_fn :: OutId -- The binder - , ri_new_rhs :: OutExpr -- The specialised RHS (in current envt) - , ri_rhs_usg :: ScUsage -- Usage info from specialising RHS - - , ri_lam_bndrs :: [InVar] -- The *original* RHS (\xs.body) - , ri_lam_body :: InExpr -- Note [Specialise original body] - , ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body - } - -data SpecInfo -- Info about specialisations for a particular Id - = SI { si_specs :: [OneSpec] -- The specialisations we have generated - - , si_n_specs :: Int -- Length of si_specs; used for numbering them - - , si_mb_unspec :: Maybe ScUsage -- Just cs => we have not yet used calls in the - } -- from calls in the *original* RHS as - -- seeds for new specialisations; - -- if you decide to do so, here is the - -- RHS usage (which has not yet been - -- unleashed) - -- Nothing => we have - -- See Note [Local recursive groups] - -- See Note [spec_usg includes rhs_usg] - - -- One specialisation: Rule plus definition -data OneSpec = - OS { os_pat :: CallPat -- Call pattern that generated this specialisation - , os_rule :: CoreRule -- Rule connecting original id with the specialisation - , os_id :: OutId -- Spec id - , os_rhs :: OutExpr } -- Spec rhs - -noSpecInfo :: SpecInfo -noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing } - ----------------------- -specNonRec :: ScEnv - -> ScUsage -- Body usage - -> RhsInfo -- Structure info usage info for un-specialised RHS - -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) - -- plus details of specialisations - -specNonRec env body_usg rhs_info - = specialise env (scu_calls body_usg) rhs_info - (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) }) - ----------------------- -specRec :: TopLevelFlag -> ScEnv - -> ScUsage -- Body usage - -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs - -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not) - -- plus details of specialisations - -specRec top_lvl env body_usg rhs_infos - = go 1 seed_calls nullUsage init_spec_infos - where - (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] - | isTopLevel top_lvl - , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs - = (all_calls, [noSpecInfo | _ <- rhs_infos]) - | otherwise -- Seed from body only - = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) } - | ri <- rhs_infos]) - - calls_in_body = scu_calls body_usg - calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos - all_calls = calls_in_rhss `combineCalls` calls_in_body - - -- Loop, specialising, until you get no new specialisations - go :: Int -- Which iteration of the "until no new specialisations" - -- loop we are on; first iteration is 1 - -> CallEnv -- Seed calls - -- Two accumulating parameters: - -> ScUsage -- Usage from earlier specialisations - -> [SpecInfo] -- Details of specialisations so far - -> UniqSM (ScUsage, [SpecInfo]) - go n_iter seed_calls usg_so_far spec_infos - | isEmptyVarEnv seed_calls - = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos) - -- , ppr seed_calls - -- , ppr body_usg ]) $ - return (usg_so_far, spec_infos) - - -- Limit recursive specialisation - -- See Note [Limit recursive specialisation] - | n_iter > sc_recursive env -- Too many iterations of the 'go' loop - , sc_force env || isNothing (sc_count env) - -- If both of these are false, the sc_count - -- threshold will prevent non-termination - , any ((> the_limit) . si_n_specs) spec_infos - = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ - return (usg_so_far, spec_infos) - - | otherwise - = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos) - -- , text "iteration" <+> int n_iter - -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) - -- ]) $ - do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos - ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg - extra_usg = combineUsages extra_usg_s - all_usg = usg_so_far `combineUsage` extra_usg - ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos } - - -- See Note [Limit recursive specialisation] - the_limit = case sc_count env of - Nothing -> 10 -- Ugh! - Just max -> max - - ----------------------- -specialise - :: ScEnv - -> CallEnv -- Info on newly-discovered calls to this function - -> RhsInfo - -> SpecInfo -- Original RHS plus patterns dealt with - -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage - --- See Note [spec_usg includes rhs_usg] - --- Note: this only generates *specialised* bindings --- The original binding is added by ruleInfoBinds --- --- Note: the rhs here is the optimised version of the original rhs --- So when we make a specialised copy of the RHS, we're starting --- from an RHS whose nested functions have been optimised already. - -specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs - , ri_lam_body = body, ri_arg_occs = arg_occs }) - spec_info@(SI { si_specs = specs, si_n_specs = spec_count - , si_mb_unspec = mb_unspec }) - | isBottomingId fn -- Note [Do not specialise diverging functions] - -- and do not generate specialisation seeds from its RHS - = -- pprTrace "specialise bot" (ppr fn) $ - return (nullUsage, spec_info) - - | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation] - || null arg_bndrs -- Only specialise functions - = -- pprTrace "specialise inactive" (ppr fn) $ - case mb_unspec of -- Behave as if there was a single, boring call - Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) - -- See Note [spec_usg includes rhs_usg] - Nothing -> return (nullUsage, spec_info) - - | Just all_calls <- lookupVarEnv bind_calls fn - = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ - do { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls - - ; let n_pats = length new_pats --- ; if (not (null new_pats) || isJust mb_unspec) then --- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" --- , text "mb_unspec" <+> ppr (isJust mb_unspec) --- , text "arg_occs" <+> ppr arg_occs --- , text "good pats" <+> ppr new_pats]) $ --- return () --- else return () - - ; let spec_env = decreaseSpecCount env n_pats - ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) - (new_pats `zip` [spec_count..]) - -- See Note [Specialise original body] - - ; let spec_usg = combineUsages spec_usgs - - -- If there were any boring calls among the seeds (= all_calls), then those - -- calls will call the un-specialised function. So we should use the seeds - -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning - -- then in new_usg. - (new_usg, mb_unspec') - = case mb_unspec of - Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) - _ -> (spec_usg, mb_unspec) - --- ; pprTrace "specialise return }" --- (vcat [ ppr fn --- , text "boring_call:" <+> ppr boring_call --- , text "new calls:" <+> ppr (scu_calls new_usg)]) $ --- return () - - ; return (new_usg, SI { si_specs = new_specs ++ specs - , si_n_specs = spec_count + n_pats - , si_mb_unspec = mb_unspec' }) } - - | otherwise -- No new seeds, so return nullUsage - = return (nullUsage, spec_info) - - - - ---------------------- -spec_one :: ScEnv - -> OutId -- Function - -> [InVar] -- Lambda-binders of RHS; should match patterns - -> InExpr -- Body of the original function - -> (CallPat, Int) - -> UniqSM (ScUsage, OneSpec) -- Rule and binding - --- spec_one creates a specialised copy of the function, together --- with a rule for using it. I'm very proud of how short this --- function is, considering what it does :-). - -{- - Example - - In-scope: a, x::a - f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... - [c::*, v::(b,c) are presumably bound by the (...) part] - ==> - f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> - (...entire body of f...) [b -> (b,c), - y -> ((:) (a,(b,c)) (x,v) hw)] - - RULE: forall b::* c::*, -- Note, *not* forall a, x - v::(b,c), - hw::[(a,(b,c))] . - - f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw --} - -spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) - = do { spec_uniq <- getUniqueM - ; let spec_env = extendScSubstList (extendScInScope env qvars) - (arg_bndrs `zip` pats) - fn_name = idName fn - fn_loc = nameSrcSpan fn_name - fn_occ = nameOccName fn_name - spec_occ = mkSpecOcc fn_occ - -- We use fn_occ rather than fn in the rule_name string - -- as we don't want the uniq to end up in the rule, and - -- hence in the ABI, as that can cause spurious ABI - -- changes (#4012). - rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) - spec_name = mkInternalName spec_uniq spec_occ fn_loc --- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn --- <+> ppr pats <+> text "-->" <+> ppr spec_name) $ --- return () - - -- Specialise the body - ; (spec_usg, spec_body) <- scExpr spec_env body - --- ; pprTrace "done spec_one}" (ppr fn) $ --- return () - - -- And build the results - ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) - qvars body_ty - -- Usual w/w hack to avoid generating - -- a spec_rhs of unlifted type and no args - - spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args - -- Annotate the variables with the strictness information from - -- the function (see Note [Strictness information in worker binders]) - - spec_join_arity | isJoinId fn = Just (length spec_lam_args) - | otherwise = Nothing - spec_id = mkLocalIdOrCoVar spec_name - (mkLamTypes spec_lam_args body_ty) - -- See Note [Transfer strictness] - `setIdStrictness` spec_str - `setIdArity` count isId spec_lam_args - `asJoinId_maybe` spec_join_arity - spec_str = calcSpecStrictness fn spec_lam_args pats - - - -- Conditionally use result of new worker-wrapper transform - spec_rhs = mkLams spec_lam_args_str spec_body - body_ty = exprType spec_body - rule_rhs = mkVarApps (Var spec_id) spec_call_args - inline_act = idInlineActivation fn - this_mod = sc_module spec_env - rule = mkRule this_mod True {- Auto -} True {- Local -} - rule_name inline_act fn_name qvars pats rule_rhs - -- See Note [Transfer activation] - ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule - , os_id = spec_id - , os_rhs = spec_rhs }) } - - --- See Note [Strictness information in worker binders] -handOutStrictnessInformation :: [Demand] -> [Var] -> [Var] -handOutStrictnessInformation = go - where - go _ [] = [] - go [] vs = vs - go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs - go dmds (v:vs) = v : go dmds vs - -calcSpecStrictness :: Id -- The original function - -> [Var] -> [CoreExpr] -- Call pattern - -> StrictSig -- Strictness of specialised thing --- See Note [Transfer strictness] -calcSpecStrictness fn qvars pats - = mkClosedStrictSig spec_dmds topRes - where - spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] - StrictSig (DmdType _ dmds _) = idStrictness fn - - dmd_env = go emptyVarEnv dmds pats - - go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv - go env ds (Type {} : pats) = go env ds pats - go env ds (Coercion {} : pats) = go env ds pats - go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats - go env _ _ = env - - go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv - go_one env d (Var v) = extendVarEnv_C bothDmd env v d - go_one env d e - | Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict - , (Var _, args) <- collectArgs e = go env ds args - go_one env _ _ = env - -{- -Note [spec_usg includes rhs_usg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In calls to 'specialise', the returned ScUsage must include the rhs_usg in -the passed-in SpecInfo, unless there are no calls at all to the function. - -The caller can, indeed must, assume this. He should not combine in rhs_usg -himself, or he'll get rhs_usg twice -- and that can lead to an exponential -blowup of duplicates in the CallEnv. This is what gave rise to the massive -performance loss in #8852. - -Note [Specialise original body] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RhsInfo for a binding keeps the *original* body of the binding. We -must specialise that, *not* the result of applying specExpr to the RHS -(which is also kept in RhsInfo). Otherwise we end up specialising a -specialised RHS, and that can lead directly to exponential behaviour. - -Note [Transfer activation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - This note is for SpecConstr, but exactly the same thing - happens in the overloading specialiser; see - Note [Auto-specialisation and RULES] in Specialise. - -In which phase should the specialise-constructor rules be active? -Originally I made them always-active, but Manuel found that this -defeated some clever user-written rules. Then I made them active only -in Phase 0; after all, currently, the specConstr transformation is -only run after the simplifier has reached Phase 0, but that meant -that specialisations didn't fire inside wrappers; see test -simplCore/should_compile/spec-inline. - -So now I just use the inline-activation of the parent Id, as the -activation for the specialisation RULE, just like the main specialiser; - -This in turn means there is no point in specialising NOINLINE things, -so we test for that. - -Note [Transfer strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must transfer strictness information from the original function to -the specialised one. Suppose, for example - - f has strictness SS - and a RULE f (a:as) b = f_spec a as b - -Now we want f_spec to have strictness LLS, otherwise we'll use call-by-need -when calling f_spec instead of call-by-value. And that can result in -unbounded worsening in space (cf the classic foldl vs foldl') - -See #3437 for a good example. - -The function calcSpecStrictness performs the calculation. - -Note [Strictness information in worker binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -After having calculated the strictness annotation for the worker (see Note -[Transfer strictness] above), we also want to have this information attached to -the worker’s arguments, for the benefit of later passes. The function -handOutStrictnessInformation decomposes the strictness annotation calculated by -calcSpecStrictness and attaches them to the variables. - -************************************************************************ -* * -\subsection{Argument analysis} -* * -************************************************************************ - -This code deals with analysing call-site arguments to see whether -they are constructor applications. - -Note [Free type variables of the qvar types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a call (f @a x True), that we want to specialise, what variables should -we quantify over. Clearly over 'a' and 'x', but what about any type variables -free in x's type? In fact we don't need to worry about them because (f @a) -can only be a well-typed application if its type is compatible with x, so any -variables free in x's type must be free in (f @a), and hence either be gathered -via 'a' itself, or be in scope at f's defn. Hence we just take - (exprsFreeVars pats). - -BUT phantom type synonyms can mess this reasoning up, - eg x::T b with type T b = Int -So we apply expandTypeSynonyms to the bound Ids. -See # 5458. Yuk. - -Note [SpecConstr call patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "call patterns" that we collect is going to become the LHS of a RULE. -It's important that it doesn't have - e |> Refl -or - e |> g1 |> g2 -because both of these will be optimised by Simplify.simplRule. In the -former case such optimisation benign, because the rule will match more -terms; but in the latter we may lose a binding of 'g1' or 'g2', and -end up with a rule LHS that doesn't bind the template variables -(#10602). - -The simplifier eliminates such things, but SpecConstr itself constructs -new terms by substituting. So the 'mkCast' in the Cast case of scExpr -is very important! - -Note [Choosing patterns] -~~~~~~~~~~~~~~~~~~~~~~~~ -If we get lots of patterns we may not want to make a specialisation -for each of them (code bloat), so we choose as follows, implemented -by trim_pats. - -* The flag -fspec-constr-count-N sets the sc_count field - of the ScEnv to (Just n). This limits the total number - of specialisations for a given function to N. - -* -fno-spec-constr-count sets the sc_count field to Nothing, - which switches of the limit. - -* The ghastly ForceSpecConstr trick also switches of the limit - for a particular function - -* Otherwise we sort the patterns to choose the most general - ones first; more general => more widely applicable. - -Note [SpecConstr and casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14270) a call like - - let f = e - in ... f (K @(a |> co)) ... - -where 'co' is a coercion variable not in scope at f's definition site. -If we aren't caereful we'll get - - let $sf a co = e (K @(a |> co)) - RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co - f = e - in ... - -But alas, when we match the call we won't bind 'co', because type-matching -(for good reasons) discards casts). - -I don't know how to solve this, so for now I'm just discarding any -call patterns that - * Mentions a coercion variable in a type argument - * That is not in scope at the binding of the function - -I think this is very rare. - -It is important (e.g. #14936) that this /only/ applies to -coercions mentioned in casts. We don't want to be discombobulated -by casts in terms! For example, consider - f ((e1,e2) |> sym co) -where, say, - f :: Foo -> blah - co :: Foo ~R (Int,Int) - -Here we definitely do want to specialise for that pair! We do not -match on the structre of the coercion; instead we just match on a -coercion variable, so the RULE looks like - - forall (x::Int, y::Int, co :: (Int,Int) ~R Foo) - f ((x,y) |> co) = $sf x y co - -Often the body of f looks like - f arg = ...(case arg |> co' of - (x,y) -> blah)... - -so that the specialised f will turn into - $sf x y co = let arg = (x,y) |> co - in ...(case arg>| co' of - (x,y) -> blah).... - -which will simplify to not use 'co' at all. But we can't guarantee -that co will end up unused, so we still pass it. Absence analysis -may remove it later. - -Note that this /also/ discards the call pattern if we have a cast in a -/term/, although in fact Rules.match does make a very flaky and -fragile attempt to match coercions. e.g. a call like - f (Maybe Age) (Nothing |> co) blah - where co :: Maybe Int ~ Maybe Age -will be discarded. It's extremely fragile to match on the form of a -coercion, so I think it's better just not to try. A more complicated -alternative would be to discard calls that mention coercion variables -only in kind-casts, but I'm doing the simple thing for now. --} - -type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments - -- See Note [SpecConstr call patterns] - -callsToNewPats :: ScEnv -> Id - -> SpecInfo - -> [ArgOcc] -> [Call] - -> UniqSM (Bool, [CallPat]) - -- Result has no duplicate patterns, - -- nor ones mentioned in done_pats - -- Bool indicates that there was at least one boring pattern -callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls - = do { mb_pats <- mapM (callToPats env bndr_occs) calls - - ; let have_boring_call = any isNothing mb_pats - - good_pats :: [CallPat] - good_pats = catMaybes mb_pats - - -- Remove patterns we have already done - new_pats = filterOut is_done good_pats - is_done p = any (samePat p . os_pat) done_specs - - -- Remove duplicates - non_dups = nubBy samePat new_pats - - -- Remove ones that have too many worker variables - small_pats = filterOut too_big non_dups - too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars) - -- We are about to construct w/w pair in 'spec_one'. - -- Omit specialisation leading to high arity workers. - -- See Note [Limit w/w arity] in WwLib - - -- Discard specialisations if there are too many of them - trimmed_pats = trim_pats env fn spec_info small_pats - --- ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls --- , text "done_specs:" <+> ppr (map os_pat done_specs) --- , text "good_pats:" <+> ppr good_pats ]) $ --- return () - - ; return (have_boring_call, trimmed_pats) } - - -trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat] --- See Note [Choosing patterns] -trim_pats env fn (SI { si_n_specs = done_spec_count }) pats - | sc_force env - || isNothing mb_scc - || n_remaining >= n_pats - = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) - pats -- No need to trim - - | otherwise - = emit_trace $ -- Need to trim, so keep the best ones - take n_remaining sorted_pats - - where - n_pats = length pats - spec_count' = n_pats + done_spec_count - n_remaining = max_specs - done_spec_count - mb_scc = sc_count env - Just max_specs = mb_scc - - sorted_pats = map fst $ - sortBy (comparing snd) $ - [(pat, pat_cons pat) | pat <- pats] - -- Sort in order of increasing number of constructors - -- (i.e. decreasing generality) and pick the initial - -- segment of this list - - pat_cons :: CallPat -> Int - -- How many data constructors of literals are in - -- the pattern. More data-cons => less general - pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps - where - q_set = mkVarSet qs - n_cons (Var v) | v `elemVarSet` q_set = 0 - | otherwise = 1 - n_cons (Cast e _) = n_cons e - n_cons (App e1 e2) = n_cons e1 + n_cons e2 - n_cons (Lit {}) = 1 - n_cons _ = 0 - - emit_trace result - | debugIsOn || hasPprDebug (sc_dflags env) - -- Suppress this scary message for ordinary users! #5125 - = pprTrace "SpecConstr" msg result - | otherwise - = result - msg = vcat [ sep [ text "Function" <+> quotes (ppr fn) - , nest 2 (text "has" <+> - speakNOf spec_count' (text "call pattern") <> comma <+> - text "but the limit is" <+> int max_specs) ] - , text "Use -fspec-constr-count=n to set the bound" - , text "done_spec_count =" <+> int done_spec_count - , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats - , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] - - -callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) - -- The [Var] is the variables to quantify over in the rule - -- Type variables come first, since they may scope - -- over the following term variables - -- The [CoreExpr] are the argument patterns for the rule -callToPats env bndr_occs call@(Call _ args con_env) - | args `ltLength` bndr_occs -- Check saturated - = return Nothing - | otherwise - = do { let in_scope = substInScope (sc_subst env) - ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs - ; let pat_fvs = exprsFreeVarsList pats - -- To get determinism we need the list of free variables in - -- deterministic order. Otherwise we end up creating - -- lambdas with different argument orders. See - -- determinism/simplCore/should_compile/spec-inline-determ.hs - -- for an example. For explanation of determinism - -- considerations See Note [Unique Determinism] in Unique. - - in_scope_vars = getInScopeVars in_scope - is_in_scope v = v `elemVarSet` in_scope_vars - qvars = filterOut is_in_scope pat_fvs - -- Quantify over variables that are not in scope - -- at the call site - -- See Note [Free type variables of the qvar types] - -- See Note [Shadowing] at the top - - (ktvs, ids) = partition isTyVar qvars - qvars' = scopedSort ktvs ++ map sanitise ids - -- Order into kind variables, type variables, term variables - -- The kind of a type variable may mention a kind variable - -- and the type of a term variable may mention a type variable - - sanitise id = id `setIdType` expandTypeSynonyms (idType id) - -- See Note [Free type variables of the qvar types] - - -- Bad coercion variables: see Note [SpecConstr and casts] - bad_covars :: CoVarSet - bad_covars = mapUnionVarSet get_bad_covars pats - get_bad_covars :: CoreArg -> CoVarSet - get_bad_covars (Type ty) - = filterVarSet (\v -> isId v && not (is_in_scope v)) $ - tyCoVarsOfType ty - get_bad_covars _ - = emptyVarSet - - ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ - WARN( not (isEmptyVarSet bad_covars) - , text "SpecConstr: bad covars:" <+> ppr bad_covars - $$ ppr call ) - if interesting && isEmptyVarSet bad_covars - then return (Just (qvars', pats)) - else return Nothing } - - -- argToPat takes an actual argument, and returns an abstracted - -- version, consisting of just the "constructor skeleton" of the - -- argument, with non-constructor sub-expression replaced by new - -- placeholder variables. For example: - -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) - -argToPat :: ScEnv - -> InScopeSet -- What's in scope at the fn defn site - -> ValueEnv -- ValueEnv at the call site - -> CoreArg -- A call arg (or component thereof) - -> ArgOcc - -> UniqSM (Bool, CoreArg) - --- Returns (interesting, pat), --- where pat is the pattern derived from the argument --- interesting=True if the pattern is non-trivial (not a variable or type) --- E.g. x:xs --> (True, x:xs) --- f xs --> (False, w) where w is a fresh wildcard --- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard --- \x. x+y --> (True, \x. x+y) --- lvl7 --> (True, lvl7) if lvl7 is bound --- somewhere further out - -argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ - = return (False, arg) - -argToPat env in_scope val_env (Tick _ arg) arg_occ - = argToPat env in_scope val_env arg arg_occ - -- Note [Notes in call patterns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Ignore Notes. In particular, we want to ignore any InlineMe notes - -- Perhaps we should not ignore profiling notes, but I'm going to - -- ride roughshod over them all for now. - --- See Note [Notes in RULE matching] in Rules - -argToPat env in_scope val_env (Let _ arg) arg_occ - = argToPat env in_scope val_env arg arg_occ - -- See Note [Matching lets] in Rule.hs - -- Look through let expressions - -- e.g. f (let v = rhs in (v,w)) - -- Here we can specialise for f (v,w) - -- because the rule-matcher will look through the let. - -{- Disabled; see Note [Matching cases] in Rule.hs -argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs - = argToPat env in_scope val_env rhs arg_occ --} - -argToPat env in_scope val_env (Cast arg co) arg_occ - | not (ignoreType env ty2) - = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ - ; if not interesting then - wildCardPat ty2 - else do - { -- Make a wild-card pattern for the coercion - uniq <- getUniqueM - ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } - where - Pair ty1 ty2 = coercionKind co - - - -{- Disabling lambda specialisation for now - It's fragile, and the spec_loop can be infinite -argToPat in_scope val_env arg arg_occ - | is_value_lam arg - = return (True, arg) - where - is_value_lam (Lam v e) -- Spot a value lambda, even if - | isId v = True -- it is inside a type lambda - | otherwise = is_value_lam e - is_value_lam other = False --} - - -- Check for a constructor application - -- NB: this *precedes* the Var case, so that we catch nullary constrs -argToPat env in_scope val_env arg arg_occ - | Just (ConVal (DataAlt dc) args) <- isValue val_env arg - , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] - , Just arg_occs <- mb_scrut dc - = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args - ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs - ; return (True, - mkConApp dc (ty_args ++ args')) } - where - mb_scrut dc = case arg_occ of - ScrutOcc bs | Just occs <- lookupUFM bs dc - -> Just (occs) -- See Note [Reboxing] - _other | sc_force env || sc_keen env - -> Just (repeat UnkOcc) - | otherwise - -> Nothing - - -- Check if the argument is a variable that - -- (a) is used in an interesting way in the function body - -- (b) we know what its value is - -- In that case it counts as "interesting" -argToPat env in_scope val_env (Var v) arg_occ - | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value, -- (b) - -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] - -- So sc_keen focused just on f (I# x), where we have freshly-allocated - -- box that we can eliminate in the caller - not (ignoreType env (varType v)) - = return (True, Var v) - where - is_value - | isLocalId v = v `elemInScopeSet` in_scope - && isJust (lookupVarEnv val_env v) - -- Local variables have values in val_env - | otherwise = isValueUnfolding (idUnfolding v) - -- Imports have unfoldings - --- I'm really not sure what this comment means --- And by not wild-carding we tend to get forall'd --- variables that are in scope, which in turn can --- expose the weakness in let-matching --- See Note [Matching lets] in Rules - - -- Check for a variable bound inside the function. - -- Don't make a wild-card, because we may usefully share - -- e.g. f a = let x = ... in f (x,x) - -- NB: this case follows the lambda and con-app cases!! --- argToPat _in_scope _val_env (Var v) _arg_occ --- = return (False, Var v) - -- SLPJ : disabling this to avoid proliferation of versions - -- also works badly when thinking about seeding the loop - -- from the body of the let - -- f x y = letrec g z = ... in g (x,y) - -- We don't want to specialise for that *particular* x,y - - -- The default case: make a wild-card - -- We use this for coercions too -argToPat _env _in_scope _val_env arg _arg_occ - = wildCardPat (exprType arg) - -wildCardPat :: Type -> UniqSM (Bool, CoreArg) -wildCardPat ty - = do { uniq <- getUniqueM - ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty - ; return (False, varToCoreExpr id) } - -argsToPats :: ScEnv -> InScopeSet -> ValueEnv - -> [CoreArg] -> [ArgOcc] -- Should be same length - -> UniqSM (Bool, [CoreArg]) -argsToPats env in_scope val_env args occs - = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs - ; let (interesting_s, args') = unzip stuff - ; return (or interesting_s, args') } - -isValue :: ValueEnv -> CoreExpr -> Maybe Value -isValue _env (Lit lit) - | litIsLifted lit = Nothing - | otherwise = Just (ConVal (LitAlt lit) []) - -isValue env (Var v) - | Just cval <- lookupVarEnv env v - = Just cval -- You might think we could look in the idUnfolding here - -- but that doesn't take account of which branch of a - -- case we are in, which is the whole point - - | not (isLocalId v) && isCheapUnfolding unf - = isValue env (unfoldingTemplate unf) - where - unf = idUnfolding v - -- However we do want to consult the unfolding - -- as well, for let-bound constructors! - -isValue env (Lam b e) - | isTyVar b = case isValue env e of - Just _ -> Just LambdaVal - Nothing -> Nothing - | otherwise = Just LambdaVal - -isValue env (Tick t e) - | not (tickishIsCode t) - = isValue env e - -isValue _env expr -- Maybe it's a constructor application - | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr - = case isDataConWorkId_maybe fun of - - Just con | args `lengthAtLeast` dataConRepArity con - -- Check saturated; might be > because the - -- arity excludes type args - -> Just (ConVal (DataAlt con) args) - - _other | valArgCount args < idArity fun - -- Under-applied function - -> Just LambdaVal -- Partial application - - _other -> Nothing - -isValue _env _expr = Nothing - -valueIsWorkFree :: Value -> Bool -valueIsWorkFree LambdaVal = True -valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args - -samePat :: CallPat -> CallPat -> Bool -samePat (vs1, as1) (vs2, as2) - = all2 same as1 as2 - where - same (Var v1) (Var v2) - | v1 `elem` vs1 = v2 `elem` vs2 - | v2 `elem` vs2 = False - | otherwise = v1 == v2 - - same (Lit l1) (Lit l2) = l1==l2 - same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 - - same (Type {}) (Type {}) = True -- Note [Ignore type differences] - same (Coercion {}) (Coercion {}) = True - same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes - same (Cast e1 _) e2 = same e1 e2 - same e1 (Tick _ e2) = same e1 e2 - same e1 (Cast e2 _) = same e1 e2 - - same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) - False -- Let, lambda, case should not occur - bad (Case {}) = True - bad (Let {}) = True - bad (Lam {}) = True - bad _other = False - -{- -Note [Ignore type differences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to generate specialisations where the call patterns -differ only in their type arguments! Not only is it utterly useless, -but it also means that (with polymorphic recursion) we can generate -an infinite number of specialisations. Example is Data.Sequence.adjustTree, -I think. --} diff --git a/specialise/Specialise.hs b/specialise/Specialise.hs deleted file mode 100644 --- a/specialise/Specialise.hs +++ /dev/null @@ -1,2965 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ViewPatterns #-} -module Specialise ( specProgram, specUnfolding ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Id -import TcType hiding( substTy ) -import Type hiding( substTy, extendTvSubstList ) -import Predicate -import Module( Module, HasModule(..) ) -import Coercion( Coercion ) -import CoreMonad -import qualified CoreSubst as Core -import CoreUnfold -import Var ( isLocalVar ) -import VarSet -import VarEnv -import CoreSyn -import Rules -import CoreOpt ( collectBindersPushingCo ) -import CoreUtils ( exprIsTrivial, mkCast, exprType, getIdFromTrivialExpr_maybe ) -import CoreFVs -import CoreArity ( etaExpandToJoinPointRule ) -import UniqSupply -import Name -import MkId ( voidArgId, voidPrimId ) -import TysPrim ( voidPrimTy ) -import Maybes ( mapMaybe, maybeToList, isJust ) -import MonadUtils ( foldlM ) -import BasicTypes -import HscTypes -import Bag -import DynFlags -import Util -import Outputable -import FastString -import State -import UniqDFM -import TyCoRep (TyCoBinder (..)) - -import Control.Monad -import qualified Control.Monad.Fail as MonadFail - -{- -************************************************************************ -* * -\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} -* * -************************************************************************ - -These notes describe how we implement specialisation to eliminate -overloading. - -The specialisation pass works on Core -syntax, complete with all the explicit dictionary application, -abstraction and construction as added by the type checker. The -existing type checker remains largely as it is. - -One important thought: the {\em types} passed to an overloaded -function, and the {\em dictionaries} passed are mutually redundant. -If the same function is applied to the same type(s) then it is sure to -be applied to the same dictionary(s)---or rather to the same {\em -values}. (The arguments might look different but they will evaluate -to the same value.) - -Second important thought: we know that we can make progress by -treating dictionary arguments as static and worth specialising on. So -we can do without binding-time analysis, and instead specialise on -dictionary arguments and no others. - -The basic idea -~~~~~~~~~~~~~~ -Suppose we have - - let f = - in - -and suppose f is overloaded. - -STEP 1: CALL-INSTANCE COLLECTION - -We traverse , accumulating all applications of f to types and -dictionaries. - -(Might there be partial applications, to just some of its types and -dictionaries? In principle yes, but in practice the type checker only -builds applications of f to all its types and dictionaries, so partial -applications could only arise as a result of transformation, and even -then I think it's unlikely. In any case, we simply don't accumulate such -partial applications.) - - -STEP 2: EQUIVALENCES - -So now we have a collection of calls to f: - f t1 t2 d1 d2 - f t3 t4 d3 d4 - ... -Notice that f may take several type arguments. To avoid ambiguity, we -say that f is called at type t1/t2 and t3/t4. - -We take equivalence classes using equality of the *types* (ignoring -the dictionary args, which as mentioned previously are redundant). - -STEP 3: SPECIALISATION - -For each equivalence class, choose a representative (f t1 t2 d1 d2), -and create a local instance of f, defined thus: - - f@t1/t2 = t1 t2 d1 d2 - -f_rhs presumably has some big lambdas and dictionary lambdas, so lots -of simplification will now result. However we don't actually *do* that -simplification. Rather, we leave it for the simplifier to do. If we -*did* do it, though, we'd get more call instances from the specialised -RHS. We can work out what they are by instantiating the call-instance -set from f's RHS with the types t1, t2. - -Add this new id to f's IdInfo, to record that f has a specialised version. - -Before doing any of this, check that f's IdInfo doesn't already -tell us about an existing instance of f at the required type/s. -(This might happen if specialisation was applied more than once, or -it might arise from user SPECIALIZE pragmas.) - -Recursion -~~~~~~~~~ -Wait a minute! What if f is recursive? Then we can't just plug in -its right-hand side, can we? - -But it's ok. The type checker *always* creates non-recursive definitions -for overloaded recursive functions. For example: - - f x = f (x+x) -- Yes I know its silly - -becomes - - f a (d::Num a) = let p = +.sel a d - in - letrec fl (y::a) = fl (p y y) - in - fl - -We still have recursion for non-overloaded functions which we -specialise, but the recursive call should get specialised to the -same recursive version. - - -Polymorphism 1 -~~~~~~~~~~~~~~ - -All this is crystal clear when the function is applied to *constant -types*; that is, types which have no type variables inside. But what if -it is applied to non-constant types? Suppose we find a call of f at type -t1/t2. There are two possibilities: - -(a) The free type variables of t1, t2 are in scope at the definition point -of f. In this case there's no problem, we proceed just as before. A common -example is as follows. Here's the Haskell: - - g y = let f x = x+x - in f y + f y - -After typechecking we have - - g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x - in +.sel a d (f a d y) (f a d y) - -Notice that the call to f is at type type "a"; a non-constant type. -Both calls to f are at the same type, so we can specialise to give: - - g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x - in +.sel a d (f@a y) (f@a y) - - -(b) The other case is when the type variables in the instance types -are *not* in scope at the definition point of f. The example we are -working with above is a good case. There are two instances of (+.sel a d), -but "a" is not in scope at the definition of +.sel. Can we do anything? -Yes, we can "common them up", a sort of limited common sub-expression deal. -This would give: - - g a (d::Num a) (y::a) = let +.sel@a = +.sel a d - f@a (x::a) = +.sel@a x x - in +.sel@a (f@a y) (f@a y) - -This can save work, and can't be spotted by the type checker, because -the two instances of +.sel weren't originally at the same type. - -Further notes on (b) - -* There are quite a few variations here. For example, the defn of - +.sel could be floated ouside the \y, to attempt to gain laziness. - It certainly mustn't be floated outside the \d because the d has to - be in scope too. - -* We don't want to inline f_rhs in this case, because -that will duplicate code. Just commoning up the call is the point. - -* Nothing gets added to +.sel's IdInfo. - -* Don't bother unless the equivalence class has more than one item! - -Not clear whether this is all worth it. It is of course OK to -simply discard call-instances when passing a big lambda. - -Polymorphism 2 -- Overloading -~~~~~~~~~~~~~~ -Consider a function whose most general type is - - f :: forall a b. Ord a => [a] -> b -> b - -There is really no point in making a version of g at Int/Int and another -at Int/Bool, because it's only instantiating the type variable "a" which -buys us any efficiency. Since g is completely polymorphic in b there -ain't much point in making separate versions of g for the different -b types. - -That suggests that we should identify which of g's type variables -are constrained (like "a") and which are unconstrained (like "b"). -Then when taking equivalence classes in STEP 2, we ignore the type args -corresponding to unconstrained type variable. In STEP 3 we make -polymorphic versions. Thus: - - f@t1/ = /\b -> t1 b d1 d2 - -We do this. - - -Dictionary floating -~~~~~~~~~~~~~~~~~~~ -Consider this - - f a (d::Num a) = let g = ... - in - ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... - -Here, g is only called at one type, but the dictionary isn't in scope at the -definition point for g. Usually the type checker would build a -definition for d1 which enclosed g, but the transformation system -might have moved d1's defn inward. Solution: float dictionary bindings -outwards along with call instances. - -Consider - - f x = let g p q = p==q - h r s = (r+s, g r s) - in - h x x - - -Before specialisation, leaving out type abstractions we have - - f df x = let g :: Eq a => a -> a -> Bool - g dg p q = == dg p q - h :: Num a => a -> a -> (a, Bool) - h dh r s = let deq = eqFromNum dh - in (+ dh r s, g deq r s) - in - h df x x - -After specialising h we get a specialised version of h, like this: - - h' r s = let deq = eqFromNum df - in (+ df r s, g deq r s) - -But we can't naively make an instance for g from this, because deq is not in scope -at the defn of g. Instead, we have to float out the (new) defn of deq -to widen its scope. Notice that this floating can't be done in advance -- it only -shows up when specialisation is done. - -User SPECIALIZE pragmas -~~~~~~~~~~~~~~~~~~~~~~~ -Specialisation pragmas can be digested by the type checker, and implemented -by adding extra definitions along with that of f, in the same way as before - - f@t1/t2 = t1 t2 d1 d2 - -Indeed the pragmas *have* to be dealt with by the type checker, because -only it knows how to build the dictionaries d1 and d2! For example - - g :: Ord a => [a] -> [a] - {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} - -Here, the specialised version of g is an application of g's rhs to the -Ord dictionary for (Tree Int), which only the type checker can conjure -up. There might not even *be* one, if (Tree Int) is not an instance of -Ord! (All the other specialision has suitable dictionaries to hand -from actual calls.) - -Problem. The type checker doesn't have to hand a convenient , because -it is buried in a complex (as-yet-un-desugared) binding group. -Maybe we should say - - f@t1/t2 = f* t1 t2 d1 d2 - -where f* is the Id f with an IdInfo which says "inline me regardless!". -Indeed all the specialisation could be done in this way. -That in turn means that the simplifier has to be prepared to inline absolutely -any in-scope let-bound thing. - - -Again, the pragma should permit polymorphism in unconstrained variables: - - h :: Ord a => [a] -> b -> b - {-# SPECIALIZE h :: [Int] -> b -> b #-} - -We *insist* that all overloaded type variables are specialised to ground types, -(and hence there can be no context inside a SPECIALIZE pragma). -We *permit* unconstrained type variables to be specialised to - - a ground type - - or left as a polymorphic type variable -but nothing in between. So - - {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} - -is *illegal*. (It can be handled, but it adds complication, and gains the -programmer nothing.) - - -SPECIALISING INSTANCE DECLARATIONS -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance Foo a => Foo [a] where - ... - {-# SPECIALIZE instance Foo [Int] #-} - -The original instance decl creates a dictionary-function -definition: - - dfun.Foo.List :: forall a. Foo a -> Foo [a] - -The SPECIALIZE pragma just makes a specialised copy, just as for -ordinary function definitions: - - dfun.Foo.List@Int :: Foo [Int] - dfun.Foo.List@Int = dfun.Foo.List Int dFooInt - -The information about what instance of the dfun exist gets added to -the dfun's IdInfo in the same way as a user-defined function too. - - -Automatic instance decl specialisation? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can instance decls be specialised automatically? It's tricky. -We could collect call-instance information for each dfun, but -then when we specialised their bodies we'd get new call-instances -for ordinary functions; and when we specialised their bodies, we might get -new call-instances of the dfuns, and so on. This all arises because of -the unrestricted mutual recursion between instance decls and value decls. - -Still, there's no actual problem; it just means that we may not do all -the specialisation we could theoretically do. - -Furthermore, instance decls are usually exported and used non-locally, -so we'll want to compile enough to get those specialisations done. - -Lastly, there's no such thing as a local instance decl, so we can -survive solely by spitting out *usage* information, and then reading that -back in as a pragma when next compiling the file. So for now, -we only specialise instance decls in response to pragmas. - - -SPITTING OUT USAGE INFORMATION -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To spit out usage information we need to traverse the code collecting -call-instance information for all imported (non-prelude?) functions -and data types. Then we equivalence-class it and spit it out. - -This is done at the top-level when all the call instances which escape -must be for imported functions and data types. - -*** Not currently done *** - - -Partial specialisation by pragmas -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What about partial specialisation: - - k :: (Ord a, Eq b) => [a] -> b -> b -> [a] - {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} - -or even - - {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} - -Seems quite reasonable. Similar things could be done with instance decls: - - instance (Foo a, Foo b) => Foo (a,b) where - ... - {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} - {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} - -Ho hum. Things are complex enough without this. I pass. - - -Requirements for the simplifier -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The simplifier has to be able to take advantage of the specialisation. - -* When the simplifier finds an application of a polymorphic f, it looks in -f's IdInfo in case there is a suitable instance to call instead. This converts - - f t1 t2 d1 d2 ===> f_t1_t2 - -Note that the dictionaries get eaten up too! - -* Dictionary selection operations on constant dictionaries must be - short-circuited: - - +.sel Int d ===> +Int - -The obvious way to do this is in the same way as other specialised -calls: +.sel has inside it some IdInfo which tells that if it's applied -to the type Int then it should eat a dictionary and transform to +Int. - -In short, dictionary selectors need IdInfo inside them for constant -methods. - -* Exactly the same applies if a superclass dictionary is being - extracted: - - Eq.sel Int d ===> dEqInt - -* Something similar applies to dictionary construction too. Suppose -dfun.Eq.List is the function taking a dictionary for (Eq a) to -one for (Eq [a]). Then we want - - dfun.Eq.List Int d ===> dEq.List_Int - -Where does the Eq [Int] dictionary come from? It is built in -response to a SPECIALIZE pragma on the Eq [a] instance decl. - -In short, dfun Ids need IdInfo with a specialisation for each -constant instance of their instance declaration. - -All this uses a single mechanism: the SpecEnv inside an Id - - -What does the specialisation IdInfo look like? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The SpecEnv of an Id maps a list of types (the template) to an expression - - [Type] |-> Expr - -For example, if f has this RuleInfo: - - [Int, a] -> \d:Ord Int. f' a - -it means that we can replace the call - - f Int t ===> (\d. f' t) - -This chucks one dictionary away and proceeds with the -specialised version of f, namely f'. - - -What can't be done this way? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no way, post-typechecker, to get a dictionary for (say) -Eq a from a dictionary for Eq [a]. So if we find - - ==.sel [t] d - -we can't transform to - - eqList (==.sel t d') - -where - eqList :: (a->a->Bool) -> [a] -> [a] -> Bool - -Of course, we currently have no way to automatically derive -eqList, nor to connect it to the Eq [a] instance decl, but you -can imagine that it might somehow be possible. Taking advantage -of this is permanently ruled out. - -Still, this is no great hardship, because we intend to eliminate -overloading altogether anyway! - -A note about non-tyvar dictionaries -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some Ids have types like - - forall a,b,c. Eq a -> Ord [a] -> tau - -This seems curious at first, because we usually only have dictionary -args whose types are of the form (C a) where a is a type variable. -But this doesn't hold for the functions arising from instance decls, -which sometimes get arguments with types of form (C (T a)) for some -type constructor T. - -Should we specialise wrt this compound-type dictionary? We used to say -"no", saying: - "This is a heuristic judgement, as indeed is the fact that we - specialise wrt only dictionaries. We choose *not* to specialise - wrt compound dictionaries because at the moment the only place - they show up is in instance decls, where they are simply plugged - into a returned dictionary. So nothing is gained by specialising - wrt them." - -But it is simpler and more uniform to specialise wrt these dicts too; -and in future GHC is likely to support full fledged type signatures -like - f :: Eq [(a,b)] => ... - - -************************************************************************ -* * -\subsubsection{The new specialiser} -* * -************************************************************************ - -Our basic game plan is this. For let(rec) bound function - f :: (C a, D c) => (a,b,c,d) -> Bool - -* Find any specialised calls of f, (f ts ds), where - ts are the type arguments t1 .. t4, and - ds are the dictionary arguments d1 .. d2. - -* Add a new definition for f1 (say): - - f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 - - Note that we abstract over the unconstrained type arguments. - -* Add the mapping - - [t1,b,t3,d] |-> \d1 d2 -> f1 b d - - to the specialisations of f. This will be used by the - simplifier to replace calls - (f t1 t2 t3 t4) da db - by - (\d1 d1 -> f1 t2 t4) da db - - All the stuff about how many dictionaries to discard, and what types - to apply the specialised function to, are handled by the fact that the - SpecEnv contains a template for the result of the specialisation. - -We don't build *partial* specialisations for f. For example: - - f :: Eq a => a -> a -> Bool - {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} - -Here, little is gained by making a specialised copy of f. -There's a distinct danger that the specialised version would -first build a dictionary for (Eq b, Eq c), and then select the (==) -method from it! Even if it didn't, not a great deal is saved. - -We do, however, generate polymorphic, but not overloaded, specialisations: - - f :: Eq a => [a] -> b -> b -> b - ... SPECIALISE f :: [Int] -> b -> b -> b ... - -Hence, the invariant is this: - - *** no specialised version is overloaded *** - - -************************************************************************ -* * -\subsubsection{The exported function} -* * -************************************************************************ --} - --- | Specialise calls to type-class overloaded functions occuring in a program. -specProgram :: ModGuts -> CoreM ModGuts -specProgram guts@(ModGuts { mg_module = this_mod - , mg_rules = local_rules - , mg_binds = binds }) - = do { dflags <- getDynFlags - - -- Specialise the bindings of this module - ; (binds', uds) <- runSpecM dflags this_mod (go binds) - - ; (spec_rules, spec_binds) <- specImports dflags this_mod top_env - local_rules uds - - ; return (guts { mg_binds = spec_binds ++ binds' - , mg_rules = spec_rules ++ local_rules }) } - where - -- We need to start with a Subst that knows all the things - -- that are in scope, so that the substitution engine doesn't - -- accidentally re-use a unique that's already in use - -- Easiest thing is to do it all at once, as if all the top-level - -- decls were mutually recursive - top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $ - bindersOfBinds binds - , se_interesting = emptyVarSet } - - go [] = return ([], emptyUDs) - go (bind:binds) = do (binds', uds) <- go binds - (bind', uds') <- specBind top_env bind uds - return (bind' ++ binds', uds') - -{- -Note [Wrap bindings returned by specImports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'specImports' returns a set of specialized bindings. However, these are lacking -necessary floated dictionary bindings, which are returned by -UsageDetails(ud_binds). These dictionaries need to be brought into scope with -'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, -for instance, the 'specImports' call in 'specProgram'. - - -Note [Disabling cross-module specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since GHC 7.10 we have performed specialisation of INLINABLE bindings living -in modules outside of the current module. This can sometimes uncover user code -which explodes in size when aggressively optimized. The --fno-cross-module-specialise option was introduced to allow users to being -bitten by such instances to revert to the pre-7.10 behavior. - -See #10491 --} - - -{- ********************************************************************* -* * - Specialising imported functions -* * -********************************************************************* -} - -specImports :: DynFlags -> Module -> SpecEnv - -> [CoreRule] - -> UsageDetails - -> CoreM ([CoreRule], [CoreBind]) -specImports dflags this_mod top_env local_rules - (MkUD { ud_binds = dict_binds, ud_calls = calls }) - | not $ gopt Opt_CrossModuleSpecialise dflags - -- See Note [Disabling cross-module specialisation] - = return ([], wrapDictBinds dict_binds []) - - | otherwise - = do { hpt_rules <- getRuleBase - ; let rule_base = extendRuleBaseList hpt_rules local_rules - - ; (spec_rules, spec_binds) <- spec_imports dflags this_mod top_env - [] rule_base - dict_binds calls - - -- Don't forget to wrap the specialized bindings with - -- bindings for the needed dictionaries. - -- See Note [Wrap bindings returned by specImports] - -- and Note [Glom the bindings if imported functions are specialised] - ; let final_binds - | null spec_binds = wrapDictBinds dict_binds [] - | otherwise = [Rec $ flattenBinds $ - wrapDictBinds dict_binds spec_binds] - - ; return (spec_rules, final_binds) - } - --- | Specialise a set of calls to imported bindings -spec_imports :: DynFlags - -> Module - -> SpecEnv -- Passed in so that all top-level Ids are in scope - -> [Id] -- Stack of imported functions being specialised - -- See Note [specImport call stack] - -> RuleBase -- Rules from this module and the home package - -- (but not external packages, which can change) - -> Bag DictBind -- Dict bindings, used /only/ for filterCalls - -- See Note [Avoiding loops in specImports] - -> CallDetails -- Calls for imported things - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings -spec_imports dflags this_mod top_env - callers rule_base dict_binds calls - = do { let import_calls = dVarEnvElts calls - -- ; debugTraceMsg (text "specImports {" <+> - -- vcat [ text "calls:" <+> ppr import_calls - -- , text "dict_binds:" <+> ppr dict_binds ]) - ; (rules, spec_binds) <- go rule_base import_calls - -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls) - - ; return (rules, spec_binds) } - where - go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) - go _ [] = return ([], []) - go rb (cis : other_calls) - = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) - ; (rules1, spec_binds1) <- spec_import dflags this_mod top_env - callers rb dict_binds cis - -- ; debugTraceMsg (text "specImport }" <+> ppr cis) - - ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls - ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } - -spec_import :: DynFlags - -> Module - -> SpecEnv -- Passed in so that all top-level Ids are in scope - -> [Id] -- Stack of imported functions being specialised - -- See Note [specImport call stack] - -> RuleBase -- Rules from this module - -> Bag DictBind -- Dict bindings, used /only/ for filterCalls - -- See Note [Avoiding loops in specImports] - -> CallInfoSet -- Imported function and calls for it - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings -spec_import dflags this_mod top_env callers - rb dict_binds cis@(CIS fn _) - | isIn "specImport" fn callers - = return ([], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, because - -- the RHS of the specialised function contains a recursive - -- call to the original function - - | null good_calls - = do { -- debugTraceMsg (text "specImport:no valid calls") - ; return ([], []) } - - | wantSpecImport dflags unfolding - , Just rhs <- maybeUnfoldingTemplate unfolding - = do { -- Get rules from the external package state - -- We keep doing this in case we "page-fault in" - -- more rules as we go along - ; hsc_env <- getHscEnv - ; eps <- liftIO $ hscEPS hsc_env - ; vis_orphs <- getVisibleOrphanMods - ; let full_rb = unionRuleBase rb (eps_rule_base eps) - rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn - - ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) - <- do { -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) - ; runSpecM dflags this_mod $ - specCalls (Just this_mod) top_env rules_for_fn good_calls fn rhs } - ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] - -- After the rules kick in we may get recursion, but - -- we rely on a global GlomBinds to sort that out later - -- See Note [Glom the bindings if imported functions are specialised] - - -- Now specialise any cascaded calls - -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1)) - ; (rules2, spec_binds2) <- spec_imports dflags this_mod top_env - (fn:callers) - (extendRuleBaseList rb rules1) - (dict_binds `unionBags` dict_binds1) - new_calls - - ; let final_binds = wrapDictBinds dict_binds1 $ - spec_binds2 ++ spec_binds1 - - ; return (rules2 ++ rules1, final_binds) } - - | otherwise - = do { tryWarnMissingSpecs dflags callers fn good_calls - ; return ([], [])} - - where - unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers - good_calls = filterCalls cis dict_binds - -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn - -- See Note [Avoiding loops in specImports] - --- | Returns whether or not to show a missed-spec warning. --- If -Wall-missed-specializations is on, show the warning. --- Otherwise, if -Wmissed-specializations is on, only show a warning --- if there is at least one imported function being specialized, --- and if all imported functions are marked with an inline pragma --- Use the most specific warning as the reason. -tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () --- See Note [Warning about missed specialisations] -tryWarnMissingSpecs dflags callers fn calls_for_fn - | wopt Opt_WarnMissedSpecs dflags - && not (null callers) - && allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs - | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ Reason Opt_WarnAllMissedSpecs - | otherwise = return () - where - allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers - doWarn reason = - warnMsg reason - (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) - 2 (vcat [ text "when specialising" <+> quotes (ppr caller) - | caller <- callers]) - , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) - , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) - -wantSpecImport :: DynFlags -> Unfolding -> Bool --- See Note [Specialise imported INLINABLE things] -wantSpecImport dflags unf - = case unf of - NoUnfolding -> False - BootUnfolding -> False - OtherCon {} -> False - DFunUnfolding {} -> True - CoreUnfolding { uf_src = src, uf_guidance = _guidance } - | gopt Opt_SpecialiseAggressively dflags -> True - | isStableSource src -> True - -- Specialise even INLINE things; it hasn't inlined yet, - -- so perhaps it never will. Moreover it may have calls - -- inside it that we want to specialise - | otherwise -> False -- Stable, not INLINE, hence INLINABLE - -{- Note [Avoiding loops in specImports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must take great care when specialising instance declarations -(functions like $fOrdList) lest we accidentally build a recursive -dictionary. See Note [Avoiding loops]. - -The basic strategy of Note [Avoiding loops] is to use filterCalls -to discard loopy specialisations. But to do that we must ensure -that the in-scope dict-binds (passed to filterCalls) contains -all the needed dictionary bindings. In particular, in the recursive -call to spec_imorpts in spec_import, we must include the dict-binds -from the parent. Lacking this caused #17151, a really nasty bug. - -Here is what happened. -* Class struture: - Source is a superclass of Mut - Index is a superclass of Source - -* We started with these dict binds - dSource = $fSourcePix @Int $fIndexInt - dIndex = sc_sel dSource - dMut = $fMutPix @Int dIndex - and these calls to specialise - $fMutPix @Int dIndex - $fSourcePix @Int $fIndexInt - -* We specialised the call ($fMutPix @Int dIndex) - ==> new call ($fSourcePix @Int dIndex) - (because Source is a superclass of Mut) - -* We specialised ($fSourcePix @Int dIndex) - ==> produces specialised dict $s$fSourcePix, - a record with dIndex as a field - plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix - *** This is the bogus step *** - -* Now we decide not to specialise the call - $fSourcePix @Int $fIndexInt - because we alredy have a RULE that matches it - -* Finally the simplifer rewrites - dSource = $fSourcePix @Int $fIndexInt - ==> dSource = $s$fSourcePix - -Disaster. Now we have - -Rewrite dSource's RHS to $s$fSourcePix Disaster - dSource = $s$fSourcePix - dIndex = sc_sel dSource - $s$fSourcePix = MkSource dIndex ... - -Solution: filterCalls should have stopped the bogus step, -by seeing that dIndex transitively uses $fSourcePix. But -it can only do that if it sees all the dict_binds. Wow. - --------------- -Here's another example (#13429). Suppose we have - class Monoid v => C v a where ... - -We start with a call - f @ [Integer] @ Integer $fC[]Integer - -Specialising call to 'f' gives dict bindings - $dMonoid_1 :: Monoid [Integer] - $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer - - $dC_1 :: C [Integer] (Node [Integer] Integer) - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - -...plus a recursive call to - f @ [Integer] @ (Node [Integer] Integer) $dC_1 - -Specialising that call gives - $dMonoid_2 :: Monoid [Integer] - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - - $dC_2 :: C [Integer] (Node [Integer] Integer) - $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 - -Now we have two calls to the imported function - M.$fCvNode :: Monoid v => C v a - M.$fCvNode @v @a m = C m some_fun - -But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) -for specialisation, else we get: - - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - $s$fCvNode = C $dMonoid_2 ... - RULE M.$fCvNode [Integer] _ _ = $s$fCvNode - -Now use the rule to rewrite the call in the RHS of $dC_1 -and we get a loop! - - -Note [specImport call stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When specialising an imports function 'f', we may get new calls -of an imported fuction 'g', which we want to specialise in turn, -and similarly specialising 'g' might expose a new call to 'h'. - -We track the stack of enclosing functions. So when specialising 'h' we -haev a specImport call stack of [g,f]. We do this for two reasons: -* Note [Warning about missed specialisations] -* Note [Avoiding recursive specialisation] - -Note [Warning about missed specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose - * In module Lib, you carefully mark a function 'foo' INLINABLE - * Import Lib(foo) into another module M - * Call 'foo' at some specialised type in M -Then you jolly well expect it to be specialised in M. But what if -'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be -specialised too. But if 'bar' is not marked INLINABLE it may well -not be specialised. The warning Opt_WarnMissedSpecs warns about this. - -It's more noisy to warning about a missed specialisation opportunity -for /every/ overloaded imported function, but sometimes useful. That -is what Opt_WarnAllMissedSpecs does. - -ToDo: warn about missed opportunities for local functions. - -Note [Avoiding recursive specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise 'f' we may find new overloaded calls to 'g', 'h' in -'f's RHS. So we want to specialise g,h. But we don't want to -specialise f any more! It's possible that f's RHS might have a -recursive yet-more-specialised call, so we'd diverge in that case. -And if the call is to the same type, one specialisation is enough. -Avoiding this recursive specialisation loop is one reason for the -'callers' stack passed to specImports and specImport. - -Note [Specialise imported INLINABLE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What imported functions do we specialise? The basic set is - * DFuns and things with INLINABLE pragmas. -but with -fspecialise-aggressively we add - * Anything with an unfolding template - -#8874 has a good example of why we want to auto-specialise DFuns. - -We have the -fspecialise-aggressively flag (usually off), because we -risk lots of orphan modules from over-vigorous specialisation. -However it's not a big deal: anything non-recursive with an -unfolding-template will probably have been inlined already. - -Note [Glom the bindings if imported functions are specialised] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an imported, *recursive*, INLINABLE function - f :: Eq a => a -> a - f = /\a \d x. ...(f a d)... -In the module being compiled we have - g x = f (x::Int) -Now we'll make a specialised function - f_spec :: Int -> Int - f_spec = \x -> ...(f Int dInt)... - {-# RULE f Int _ = f_spec #-} - g = \x. f Int dInt x -Note that f_spec doesn't look recursive -After rewriting with the RULE, we get - f_spec = \x -> ...(f_spec)... -BUT since f_spec was non-recursive before it'll *stay* non-recursive. -The occurrence analyser never turns a NonRec into a Rec. So we must -make sure that f_spec is recursive. Easiest thing is to make all -the specialisations for imported bindings recursive. - - - -************************************************************************ -* * -\subsubsection{@specExpr@: the main function} -* * -************************************************************************ --} - -data SpecEnv - = SE { se_subst :: Core.Subst - -- We carry a substitution down: - -- a) we must clone any binding that might float outwards, - -- to avoid name clashes - -- b) we carry a type substitution to use when analysing - -- the RHS of specialised bindings (no type-let!) - - - , se_interesting :: VarSet - -- Dict Ids that we know something about - -- and hence may be worth specialising against - -- See Note [Interesting dictionary arguments] - } - -instance Outputable SpecEnv where - ppr (SE { se_subst = subst, se_interesting = interesting }) - = text "SE" <+> braces (sep $ punctuate comma - [ text "subst =" <+> ppr subst - , text "interesting =" <+> ppr interesting ]) - -specVar :: SpecEnv -> Id -> CoreExpr -specVar env v = Core.lookupIdSubst (text "specVar") (se_subst env) v - -specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) - ----------------- First the easy cases -------------------- -specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) -specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) -specExpr env (Var v) = return (specVar env v, emptyUDs) -specExpr _ (Lit lit) = return (Lit lit, emptyUDs) -specExpr env (Cast e co) - = do { (e', uds) <- specExpr env e - ; return ((mkCast e' (substCo env co)), uds) } -specExpr env (Tick tickish body) - = do { (body', uds) <- specExpr env body - ; return (Tick (specTickish env tickish) body', uds) } - ----------------- Applications might generate a call instance -------------------- -specExpr env expr@(App {}) - = go expr [] - where - go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg - (fun', uds_app) <- go fun (arg':args) - return (App fun' arg', uds_arg `plusUDs` uds_app) - - go (Var f) args = case specVar env f of - Var f' -> return (Var f', mkCallUDs env f' args) - e' -> return (e', emptyUDs) -- I don't expect this! - go other _ = specExpr env other - ----------------- Lambda/case require dumping of usage details -------------------- -specExpr env e@(Lam _ _) = do - (body', uds) <- specExpr env' body - let (free_uds, dumped_dbs) = dumpUDs bndrs' uds - return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds) - where - (bndrs, body) = collectBinders e - (env', bndrs') = substBndrs env bndrs - -- More efficient to collect a group of binders together all at once - -- and we don't want to split a lambda group with dumped bindings - -specExpr env (Case scrut case_bndr ty alts) - = do { (scrut', scrut_uds) <- specExpr env scrut - ; (scrut'', case_bndr', alts', alts_uds) - <- specCase env scrut' case_bndr alts - ; return (Case scrut'' case_bndr' (substTy env ty) alts' - , scrut_uds `plusUDs` alts_uds) } - ----------------- Finally, let is the interesting case -------------------- -specExpr env (Let bind body) - = do { -- Clone binders - (rhs_env, body_env, bind') <- cloneBindSM env bind - - -- Deal with the body - ; (body', body_uds) <- specExpr body_env body - - -- Deal with the bindings - ; (binds', uds) <- specBind rhs_env bind' body_uds - - -- All done - ; return (foldr Let body' binds', uds) } - --------------- -specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) --- The binders have been substituted, but the body has not -specLam env bndrs body - | null bndrs - = specExpr env body - | otherwise - = do { (body', uds) <- specExpr env body - ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds - ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } - --------------- -specTickish :: SpecEnv -> Tickish Id -> Tickish Id -specTickish env (Breakpoint ix ids) - = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] - -- drop vars from the list if they have a non-variable substitution. - -- should never happen, but it's harmless to drop them anyway. -specTickish _ other_tickish = other_tickish - --------------- -specCase :: SpecEnv - -> CoreExpr -- Scrutinee, already done - -> Id -> [CoreAlt] - -> SpecM ( CoreExpr -- New scrutinee - , Id - , [CoreAlt] - , UsageDetails) -specCase env scrut' case_bndr [(con, args, rhs)] - | isDictId case_bndr -- See Note [Floating dictionaries out of cases] - , interestingDict env scrut' - , not (isDeadBinder case_bndr && null sc_args') - = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') - - ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [(con, args', Var sc_arg')] - | sc_arg' <- sc_args' ] - - -- Extend the substitution for RHS to map the *original* binders - -- to their floated versions. - mb_sc_flts :: [Maybe DictId] - mb_sc_flts = map (lookupVarEnv clone_env) args' - clone_env = zipVarEnv sc_args' sc_args_flt - subst_prs = (case_bndr, Var case_bndr_flt) - : [ (arg, Var sc_flt) - | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] - env_rhs' = env_rhs { se_subst = Core.extendIdSubstList (se_subst env_rhs) subst_prs - , se_interesting = se_interesting env_rhs `extendVarSetList` - (case_bndr_flt : sc_args_flt) } - - ; (rhs', rhs_uds) <- specExpr env_rhs' rhs - ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') - case_bndr_set = unitVarSet case_bndr_flt - sc_binds = [(NonRec sc_arg_flt sc_rhs, case_bndr_set) - | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] - flt_binds = scrut_bind : sc_binds - (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds - all_uds = flt_binds `addDictBinds` free_uds - alt' = (con, args', wrapDictBindsE dumped_dbs rhs') - ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } - where - (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) - sc_args' = filter is_flt_sc_arg args' - - clone_me bndr = do { uniq <- getUniqueM - ; return (mkUserLocalOrCoVar occ uniq ty loc) } - where - name = idName bndr - ty = idType bndr - occ = nameOccName name - loc = getSrcSpan name - - arg_set = mkVarSet args' - is_flt_sc_arg var = isId var - && not (isDeadBinder var) - && isDictTy var_ty - && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set) - where - var_ty = idType var - - -specCase env scrut case_bndr alts - = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts - ; return (scrut, case_bndr', alts', uds_alts) } - where - (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (con, args, rhs) = do - (rhs', uds) <- specExpr env_rhs rhs - let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) - where - (env_rhs, args') = substBndrs env_alt args - -{- -Note [Floating dictionaries out of cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - g = \d. case d of { MkD sc ... -> ...(f sc)... } -Naively we can't float d2's binding out of the case expression, -because 'sc' is bound by the case, and that in turn means we can't -specialise f, which seems a pity. - -So we invert the case, by floating out a binding -for 'sc_flt' thus: - sc_flt = case d of { MkD sc ... -> sc } -Now we can float the call instance for 'f'. Indeed this is just -what'll happen if 'sc' was originally bound with a let binding, -but case is more efficient, and necessary with equalities. So it's -good to work with both. - -You might think that this won't make any difference, because the -call instance will only get nuked by the \d. BUT if 'g' itself is -specialised, then transitively we should be able to specialise f. - -In general, given - case e of cb { MkD sc ... -> ...(f sc)... } -we transform to - let cb_flt = e - sc_flt = case cb_flt of { MkD sc ... -> sc } - in - case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } - -The "_flt" things are the floated binds; we use the current substitution -to substitute sc -> sc_flt in the RHS - -************************************************************************ -* * - Dealing with a binding -* * -************************************************************************ --} - -specBind :: SpecEnv -- Use this for RHSs - -> CoreBind -- Binders are already cloned by cloneBindSM, - -- but RHSs are un-processed - -> UsageDetails -- Info on how the scope of the binding - -> SpecM ([CoreBind], -- New bindings - UsageDetails) -- And info to pass upstream - --- Returned UsageDetails: --- No calls for binders of this bind -specBind rhs_env (NonRec fn rhs) body_uds - = do { (rhs', rhs_uds) <- specExpr rhs_env rhs - - ; let zapped_fn = zapIdDemandInfo fn - -- We zap the demand info because the binding may float, - -- which would invaidate the demand info (see #17810 for example). - -- Destroying demand info is not terrible; specialisation is - -- always followed soon by demand analysis. - ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs - - ; let pairs = spec_defns ++ [(fn', rhs')] - -- fn' mentions the spec_defns in its rules, - -- so put the latter first - - combined_uds = body_uds1 `plusUDs` rhs_uds - - (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds - - final_binds :: [DictBind] - -- See Note [From non-recursive to recursive] - final_binds - | not (isEmptyBag dump_dbs) - , not (null spec_defns) - = [recWithDumpedDicts pairs dump_dbs] - | otherwise - = [mkDB $ NonRec b r | (b,r) <- pairs] - ++ bagToList dump_dbs - - ; if float_all then - -- Rather than discard the calls mentioning the bound variables - -- we float this (dictionary) binding along with the others - return ([], free_uds `snocDictBinds` final_binds) - else - -- No call in final_uds mentions bound variables, - -- so we can just leave the binding here - return (map fst final_binds, free_uds) } - - -specBind rhs_env (Rec pairs) body_uds - -- Note [Specialising a recursive group] - = do { let (bndrs,rhss) = unzip pairs - ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss - ; let scope_uds = body_uds `plusUDs` rhs_uds - -- Includes binds and calls arising from rhss - - ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs - - ; (bndrs3, spec_defns3, uds3) - <- if null spec_defns1 -- Common case: no specialisation - then return (bndrs1, [], uds1) - else do { -- Specialisation occurred; do it again - (bndrs2, spec_defns2, uds2) - <- specDefns rhs_env uds1 (bndrs1 `zip` rhss) - ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } - - ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 - final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') - dumped_dbs - - ; if float_all then - return ([], final_uds `snocDictBind` final_bind) - else - return ([fst final_bind], final_uds) } - - ---------------------------- -specDefns :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS - -> SpecM ([OutId], -- Original Ids with RULES added - [(OutId,OutExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - --- Specialise a list of bindings (the contents of a Rec), but flowing usages --- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } --- Then if the input CallDetails has a specialised call for 'g', whose specialisation --- in turn generates a specialised call for 'f', we catch that in this one sweep. --- But not vice versa (it's a fixpoint problem). - -specDefns _env uds [] - = return ([], [], uds) -specDefns env uds ((bndr,rhs):pairs) - = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs - ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs - ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } - ---------------------------- -specDefn :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> OutId -> InExpr -- The thing being bound and its un-processed RHS - -> SpecM (Id, -- Original Id with added RULES - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - -specDefn env body_uds fn rhs - = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds - rules_for_me = idCoreRules fn - ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me - calls_for_me fn rhs - ; return ( fn `addIdSpecialisations` rules - , spec_defns - , body_uds_without_me `plusUDs` spec_uds) } - -- It's important that the `plusUDs` is this way - -- round, because body_uds_without_me may bind - -- dictionaries that are used in calls_for_me passed - -- to specDefn. So the dictionary bindings in - -- spec_uds may mention dictionaries bound in - -- body_uds_without_me - ---------------------------- -specCalls :: Maybe Module -- Just this_mod => specialising imported fn - -- Nothing => specialising local fn - -> SpecEnv - -> [CoreRule] -- Existing RULES for the fn - -> [CallInfo] - -> OutId -> InExpr - -> SpecM SpecInfo -- New rules, specialised bindings, and usage details - --- This function checks existing rules, and does not create --- duplicate ones. So the caller does not need to do this filtering. --- See 'already_covered' - -type SpecInfo = ( [CoreRule] -- Specialisation rules - , [(Id,CoreExpr)] -- Specialised definition - , UsageDetails ) -- Usage details from specialised RHSs - -specCalls mb_mod env existing_rules calls_for_me fn rhs - -- The first case is the interesting one - | notNull calls_for_me -- And there are some calls to specialise - && not (isNeverActive (idInlineActivation fn)) - -- Don't specialise NOINLINE things - -- See Note [Auto-specialisation and RULES] - --- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small --- See Note [Inline specialisation] for why we do not --- switch off specialisation for inline functions - - = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ - foldlM spec_call ([], [], emptyUDs) calls_for_me - - | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, - text "Missed specialisation opportunity for" - <+> ppr fn $$ _trace_doc ) - -- Note [Specialisation shape] - -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ - return ([], [], emptyUDs) - where - _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ] - - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here - inl_prag = idInlinePragma fn - inl_act = inlinePragmaActivation inl_prag - is_local = isLocalId fn - is_dfun = isDFunId fn - - -- Figure out whether the function has an INLINE pragma - -- See Note [Inline specialisations] - - (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs - -- See Note [Account for casts in binding] - - in_scope = Core.substInScope (se_subst env) - - already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool - already_covered dflags new_rules args -- Note [Specialisations already covered] - = isJust (lookupRule dflags (in_scope, realIdUnfolding) - (const True) fn args - (new_rules ++ existing_rules)) - -- NB: we look both in the new_rules (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - - ---------------------------------------------------------- - -- Specialise to one particular call pattern - spec_call :: SpecInfo -- Accumulating parameter - -> CallInfo -- Call instance - -> SpecM SpecInfo - spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args }) - = -- See Note [Specialising Calls] - do { let all_call_args | is_dfun = call_args ++ repeat UnspecArg - | otherwise = call_args - -- See Note [Specialising DFuns] - ; ( useful, rhs_env2, leftover_bndrs - , rule_bndrs, rule_lhs_args - , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args - --- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci --- , text "useful: " <+> ppr useful --- , text "rule_bndrs:" <+> ppr rule_bndrs --- , text "lhs_args: " <+> ppr rule_lhs_args --- , text "spec_bndrs:" <+> ppr spec_bndrs1 --- , text "spec_args: " <+> ppr spec_args --- , text "dx_binds: " <+> ppr dx_binds --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () - - ; dflags <- getDynFlags - ; if not useful -- No useful specialisation - || already_covered dflags rules_acc rule_lhs_args - then return spec_acc - else - do { -- Run the specialiser on the specialised RHS - -- The "1" suffix is before we maybe add the void arg - ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body - ; let spec_fn_ty1 = exprType spec_rhs1 - - -- Maybe add a void arg to the specialised function, - -- to avoid unlifted bindings - -- See Note [Specialisations Must Be Lifted] - -- C.f. GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs - add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) - (spec_bndrs, spec_rhs, spec_fn_ty) - | add_void_arg = ( voidPrimId : spec_bndrs1 - , Lam voidArgId spec_rhs1 - , mkVisFunTy voidPrimTy spec_fn_ty1) - | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) - - join_arity_decr = length rule_lhs_args - length spec_bndrs - spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn - = Just (orig_join_arity - join_arity_decr) - | otherwise - = Nothing - - ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity - ; this_mod <- getModule - ; let - -- The rule to put in the function's specialisation is: - -- forall x @b d1' d2'. - -- f x @T1 @b @T2 d1' d2' = f1 x @b - -- See Note [Specialising Calls] - herald = case mb_mod of - Nothing -- Specialising local fn - -> text "SPEC" - Just this_mod -- Specialising imported fn - -> text "SPEC/" <> ppr this_mod - - rule_name = mkFastString $ showSDoc dflags $ - herald <+> ftext (occNameFS (getOccName fn)) - <+> hsep (mapMaybe ppr_call_key_ty call_args) - -- This name ends up in interface files, so use occNameString. - -- Otherwise uniques end up there, making builds - -- less deterministic (See #4012 comment:61 ff) - - rule_wout_eta = mkRule - this_mod - True {- Auto generated -} - is_local - rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - rule_bndrs - rule_lhs_args - (mkVarApps (Var spec_fn) spec_bndrs) - - spec_rule - = case isJoinId_maybe fn of - Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta - Nothing -> rule_wout_eta - - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - -- See Note [Specialising Calls] - spec_uds = foldr consDictBind rhs_uds dx_binds - - -------------------------------------- - -- Add a suitable unfolding if the spec_inl_prag says so - -- See Note [Inline specialisations] - (spec_inl_prag, spec_unf) - | not is_local && isStrongLoopBreaker (idOccInfo fn) - = (neverInlinePragma, noUnfolding) - -- See Note [Specialising imported functions] in OccurAnal - - | InlinePragma { inl_inline = Inlinable } <- inl_prag - = (inl_prag { inl_inline = NoUserInline }, noUnfolding) - - | otherwise - = (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args) - rule_lhs_args fn_unf) - - -------------------------------------- - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_fn - arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs - spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr) - `setInlinePragma` spec_inl_prag - `setIdUnfolding` spec_unf - `asJoinId_maybe` spec_join_arity - - _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type - , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty - , ppr rhs_bndrs, ppr call_args - , ppr spec_rule - ] - - ; -- pprTrace "spec_call: rule" _rule_trace_doc - return ( spec_rule : rules_acc - , (spec_f_w_arity, spec_rhs) : pairs_acc - , spec_uds `plusUDs` uds_acc - ) } } - -{- Note [Specialising DFuns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DFuns have a special sort of unfolding (DFunUnfolding), and these are -hard to specialise a DFunUnfolding to give another DFunUnfolding -unless the DFun is fully applied (#18120). So, in the case of DFunIds -we simply extend the CallKey with trailing UnspecArgs, so we'll -generate a rule that completely saturates the DFun. - -There is an ASSERT that checks this, in the DFunUnfolding case of -GHC.Core.Unfold.specUnfolding. - -Note [Specialisation Must Preserve Sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a function: - - f :: forall a. Eq a => a -> blah - f = - if expensive - then f1 - else f2 - -As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' -at 'Int', eg: - - $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) - - RULE "SPEC f" - forall (d :: Eq Int). - f Int _ = $sfIntf - -We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! - -To avoid this, we only generate specialisations for functions whose arity is -enough to bind all of the arguments we need to specialise. This ensures our -specialised functions don't do any work before receiving all of their dicts, -and thus avoids the 'f' case above. - -Note [Specialisations Must Be Lifted] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a function 'f': - - f = forall a. Eq a => Array# a - -used like - - case x of - True -> ...f @Int dEqInt... - False -> 0 - -Naively, we might generate an (expensive) specialisation - - $sfInt :: Array# Int - -even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to -the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to -preserve laziness. - -Note [Specialising Calls] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a function with a complicated type: - - f :: forall a b c. Int -> Eq a => Show b => c -> Blah - f @a @b @c i dEqA dShowA x = blah - -and suppose it is called at: - - f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3 - -This call is described as a 'CallInfo' whose 'ci_key' is: - - [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1 - , SpecDict ($dfShow dShowT2), UnspecArg ] - -Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? -Because we must specialise the function on type variables that appear -free in its *dictionary* arguments; but not on type variables that do not -appear in any dictionaries, i.e. are fully polymorphic. - -Because this call has dictionaries applied, we'd like to specialise -the call on any type argument that appears free in those dictionaries. -In this case, those are [a :-> T1, b :-> T2]. - -We also need to substitute the dictionary binders with their -specialised dictionaries. The simplest substitution would be -[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates -work, since `$dfShow dShowT2` is a function application. Therefore, we -also want to *float the dictionary out* (via bindAuxiliaryDict), -creating a new dict binding - - dShow1 = $dfShow dShowT2 - -and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1]. - -With the substitutions in hand, we can generate a specialised function: - - $sf :: forall c. Int -> c -> Blah - $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) - -Note that the substitution is applied to the whole thing. This is -convenient, but just slightly fragile. Notably: - * There had better be no name clashes in a/b/c - -We must construct a rewrite rule: - - RULE "SPEC f @T1 @T2 _" - forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). - f @T1 @T2 @c i d1 d2 = $sf @c i - -In the rule, d1 and d2 are just wildcards, not used in the RHS. Note -additionally that 'x' isn't captured by this rule --- we bind only -enough etas in order to capture all of the *specialised* arguments. - -Note [Drop dead args from specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When specialising a function, it’s possible some of the arguments may -actually be dead. For example, consider: - - f :: forall a. () -> Show a => a -> String - f x y = show y ++ "!" - -We might generate the following CallInfo for `f @Int`: - - [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] - -Normally we’d include both the x and y arguments in the -specialisation, since we’re not specialising on either of them. But -that’s silly, since x is actually unused! So we might as well drop it -in the specialisation: - - $sf :: Int -> String - $sf y = show y ++ "!" - - {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} - -This doesn’t save us much, since the arg would be removed later by -worker/wrapper, anyway, but it’s easy to do. Note, however, that we -only drop dead arguments if: - - 1. We don’t specialise on them. - 2. They come before an argument we do specialise on. - -Doing the latter would require eta-expanding the RULE, which could -make it match less often, so it’s not worth it. Doing the former could -be more useful --- it would stop us from generating pointless -specialisations --- but it’s more involved to implement and unclear if -it actually provides much benefit in practice. - -Note [Zap occ info in rule binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we generate a specialisation RULE, we need to drop occurrence -info on the binders. If we don’t, things go wrong when we specialise a -function like - - f :: forall a. () -> Show a => a -> String - f x y = show y ++ "!" - -since we’ll generate a RULE like - - RULE "SPEC f @Int" forall x [Occ=Dead]. - f @Int x $dShow = $sf - -and Core Lint complains, even though x only appears on the LHS (due to -Note [Drop dead args from specialisations]). - -Why is that a Lint error? Because the arguments on the LHS of a rule -are syntactically expressions, not patterns, so Lint treats the -appearance of x as a use rather than a binding. Fortunately, the -solution is simple: we just make sure to zap the occ info before -using ids as wildcard binders in a rule. - -Note [Account for casts in binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: Eq a => a -> IO () - {-# INLINABLE f - StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g - #-} - f = ... - -In f's stable unfolding we have done some modest simplification which -has pushed the cast to the outside. (I wonder if this is the Right -Thing, but it's what happens now; see SimplUtils Note [Casts and -lambdas].) Now that stable unfolding must be specialised, so we want -to push the cast back inside. It would be terrible if the cast -defeated specialisation! Hence the use of collectBindersPushingCo. - -Note [Evidence foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (#12212) that we are specialising - f :: forall a b. (Num a, F a ~ F b) => blah -with a=b=Int. Then the RULE will be something like - RULE forall (d:Num Int) (g :: F Int ~ F Int). - f Int Int d g = f_spec -But both varToCoreExpr (when constructing the LHS args), and the -simplifier (when simplifying the LHS args), will transform to - RULE forall (d:Num Int) (g :: F Int ~ F Int). - f Int Int d = f_spec -by replacing g with Refl. So now 'g' is unbound, which results in a later -crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a Refl - * exprsFreeIdsList returns the Ids bound by the args, - which won't include g - -You might wonder if this will match as often, but the simplifier replaces -complicated Refl coercions with Refl pretty aggressively. - -Note [Orphans and auto-generated rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise an INLINABLE function, or when we have --fspecialise-aggressively, we auto-generate RULES that are orphans. -We don't want to warn about these, or we'd generate a lot of warnings. -Thus, we only warn about user-specified orphan rules. - -Indeed, we don't even treat the module as an orphan module if it has -auto-generated *rule* orphans. Orphan modules are read every time we -compile, so they are pretty obtrusive and slow down every compilation, -even non-optimised ones. (Reason: for type class instances it's a -type correctness issue.) But specialisation rules are strictly for -*optimisation* only so it's fine not to read the interface. - -What this means is that a SPEC rules from auto-specialisation in -module M will be used in other modules only if M.hi has been read for -some other reason, which is actually pretty likely. - -Note [From non-recursive to recursive] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in the non-recursive case, if any dict-binds depend on 'fn' we might -have built a recursive knot - - f a d x = - MkUD { ud_binds = NonRec d7 (MkD ..f..) - , ud_calls = ...(f T d7)... } - -The we generate - - Rec { fs x = [T/a, d7/d] - f a d x = - RULE f T _ = fs - d7 = ...f... } - -Here the recursion is only through the RULE. - -However we definitely should /not/ make the Rec in this wildly common -case: - d = ... - MkUD { ud_binds = NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -Here we want simply to add d to the floats, giving - MkUD { ud_binds = NonRec d (...) - NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -In general, we need only make this Rec if - - there are some specialisations (spec_binds non-empty) - - there are some dict_binds that depend on f (dump_dbs non-empty) - -Note [Avoiding loops] -~~~~~~~~~~~~~~~~~~~~~ -When specialising /dictionary functions/ we must be very careful to -avoid building loops. Here is an example that bit us badly: #3591 - - class Eq a => C a - instance Eq [a] => C [a] - -This translates to - dfun :: Eq [a] -> C [a] - dfun a d = MkD a d (meth d) - - d4 :: Eq [T] = - d2 :: C [T] = dfun T d4 - d1 :: Eq [T] = $p1 d2 - d3 :: C [T] = dfun T d1 - -None of these definitions is recursive. What happened was that we -generated a specialisation: - RULE forall d. dfun T d = dT :: C [T] - dT = (MkD a d (meth d)) [T/a, d1/d] - = MkD T d1 (meth d1) - -But now we use the RULE on the RHS of d2, to get - d2 = dT = MkD d1 (meth d1) - d1 = $p1 d2 - -and now d1 is bottom! The problem is that when specialising 'dfun' we -should first dump "below" the binding all floated dictionary bindings -that mention 'dfun' itself. So d2 and d3 (and hence d1) must be -placed below 'dfun', and thus unavailable to it when specialising -'dfun'. That in turn means that the call (dfun T d1) must be -discarded. On the other hand, the call (dfun T d4) is fine, assuming -d4 doesn't mention dfun. - -Solution: - Discard all calls that mention dictionaries that depend - (directly or indirectly) on the dfun we are specialising. - This is done by 'filterCalls' - --------------- -Here's yet another example - - class C a where { foo,bar :: [a] -> [a] } - - instance C Int where - foo x = r_bar x - bar xs = reverse xs - - r_bar :: C a => [a] -> [a] - r_bar xs = bar (xs ++ xs) - -That translates to: - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs } - -The call (r_bar $fCInt) mentions $fCInt, - which mentions foo_help, - which mentions r_bar -But we DO want to specialise r_bar at Int: - - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - RULE r_bar Int _ = r_bar_Int - - r_bar_Int xs = bar Int $fCInt (xs ++ xs) - } - -Note that, because of its RULE, r_bar joins the recursive -group. (In this case it'll unravel a short moment later.) - - -Note [Specialising a recursive group] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let rec { f x = ...g x'... - ; g y = ...f y'.... } - in f 'a' -Here we specialise 'f' at Char; but that is very likely to lead to -a specialisation of 'g' at Char. We must do the latter, else the -whole point of specialisation is lost. - -But we do not want to keep iterating to a fixpoint, because in the -presence of polymorphic recursion we might generate an infinite number -of specialisations. - -So we use the following heuristic: - * Arrange the rec block in dependency order, so far as possible - (the occurrence analyser already does this) - - * Specialise it much like a sequence of lets - - * Then go through the block a second time, feeding call-info from - the RHSs back in the bottom, as it were - -In effect, the ordering maxmimises the effectiveness of each sweep, -and we do just two sweeps. This should catch almost every case of -monomorphic recursion -- the exception could be a very knotted-up -recursion with multiple cycles tied up together. - -This plan is implemented in the Rec case of specBindItself. - -Note [Specialisations already covered] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We obviously don't want to generate two specialisations for the same -argument pattern. There are two wrinkles - -1. We do the already-covered test in specDefn, not when we generate -the CallInfo in mkCallUDs. We used to test in the latter place, but -we now iterate the specialiser somewhat, and the Id at the call site -might therefore not have all the RULES that we can see in specDefn - -2. What about two specialisations where the second is an *instance* -of the first? If the more specific one shows up first, we'll generate -specialisations for both. If the *less* specific one shows up first, -we *don't* currently generate a specialisation for the more specific -one. (See the call to lookupRule in already_covered.) Reasons: - (a) lookupRule doesn't say which matches are exact (bad reason) - (b) if the earlier specialisation is user-provided, it's - far from clear that we should auto-specialise further - -Note [Auto-specialisation and RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - g :: Num a => a -> a - g = ... - - f :: (Int -> Int) -> Int - f w = ... - {-# RULE f g = 0 #-} - -Suppose that auto-specialisation makes a specialised version of -g::Int->Int That version won't appear in the LHS of the RULE for f. -So if the specialisation rule fires too early, the rule for f may -never fire. - -It might be possible to add new rules, to "complete" the rewrite system. -Thus when adding - RULE forall d. g Int d = g_spec -also add - RULE f g_spec = 0 - -But that's a bit complicated. For now we ask the programmer's help, -by *copying the INLINE activation pragma* to the auto-specialised -rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule -will also not be active until phase 2. And that's what programmers -should jolly well do anyway, even aside from specialisation, to ensure -that g doesn't inline too early. - -This in turn means that the RULE would never fire for a NOINLINE -thing so not much point in generating a specialisation at all. - -Note [Specialisation shape] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only specialise a function if it has visible top-level lambdas -corresponding to its overloading. E.g. if - f :: forall a. Eq a => .... -then its body must look like - f = /\a. \d. ... - -Reason: when specialising the body for a call (f ty dexp), we want to -substitute dexp for d, and pick up specialised calls in the body of f. - -This doesn't always work. One example I came across was this: - newtype Gen a = MkGen{ unGen :: Int -> a } - - choose :: Eq a => a -> Gen a - choose n = MkGen (\r -> n) - - oneof = choose (1::Int) - -It's a silly example, but we get - choose = /\a. g `cast` co -where choose doesn't have any dict arguments. Thus far I have not -tried to fix this (wait till there's a real example). - -Mind you, then 'choose' will be inlined (since RHS is trivial) so -it doesn't matter. This comes up with single-method classes - - class C a where { op :: a -> a } - instance C a => C [a] where .... -==> - $fCList :: C a => C [a] - $fCList = $copList |> (...coercion>...) - ....(uses of $fCList at particular types)... - -So we suppress the WARN if the rhs is trivial. - -Note [Inline specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is what we do with the InlinePragma of the original function - * Activation/RuleMatchInfo: both transferred to the - specialised function - * InlineSpec: - (a) An INLINE pragma is transferred - (b) An INLINABLE pragma is *not* transferred - -Why (a): transfer INLINE pragmas? The point of INLINE was precisely to -specialise the function at its call site, and arguably that's not so -important for the specialised copies. BUT *pragma-directed* -specialisation now takes place in the typechecker/desugarer, with -manually specified INLINEs. The specialisation here is automatic. -It'd be very odd if a function marked INLINE was specialised (because -of some local use), and then forever after (including importing -modules) the specialised version wasn't INLINEd. After all, the -programmer said INLINE! - -You might wonder why we specialise INLINE functions at all. After -all they should be inlined, right? Two reasons: - - * Even INLINE functions are sometimes not inlined, when they aren't - applied to interesting arguments. But perhaps the type arguments - alone are enough to specialise (even though the args are too boring - to trigger inlining), and it's certainly better to call the - specialised version. - - * The RHS of an INLINE function might call another overloaded function, - and we'd like to generate a specialised version of that function too. - This actually happens a lot. Consider - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINABLE replicateM_ #-} - replicateM_ d x ma = ... - The strictness analyser may transform to - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINE replicateM_ #-} - replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma - - $wreplicateM_ :: (Monad m) => Int# -> m a -> m () - {-# INLINABLE $wreplicateM_ #-} - $wreplicateM_ = ... - Now an importing module has a specialised call to replicateM_, say - (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! - This particular example had a huge effect on the call to replicateM_ - in nofib/shootout/n-body. - -Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples. -Suppose we have - {-# INLINABLE f #-} - f :: Ord a => [a] -> Int - f xs = letrec f' = ...f'... in f' -Then, when f is specialised and optimised we might get - wgo :: [Int] -> Int# - wgo = ...wgo... - f_spec :: [Int] -> Int - f_spec xs = case wgo xs of { r -> I# r } -and we clearly want to inline f_spec at call sites. But if we still -have the big, un-optimised of f (albeit specialised) captured in an -INLINABLE pragma for f_spec, we won't get that optimisation. - -So we simply drop INLINABLE pragmas when specialising. It's not really -a complete solution; ignoring specialisation for now, INLINABLE functions -don't get properly strictness analysed, for example. But it works well -for examples involving specialisation, which is the dominant use of -INLINABLE. See #4874. --} - -{- ********************************************************************* -* * - SpecArg, and specHeader -* * -********************************************************************* -} - --- | An argument that we might want to specialise. --- See Note [Specialising Calls] for the nitty gritty details. -data SpecArg - = - -- | Type arguments that should be specialised, due to appearing - -- free in the type of a 'SpecDict'. - SpecType Type - - -- | Type arguments that should remain polymorphic. - | UnspecType - - -- | Dictionaries that should be specialised. mkCallUDs ensures - -- that only "interesting" dictionary arguments get a SpecDict; - -- see Note [Interesting dictionary arguments] - | SpecDict DictExpr - - -- | Value arguments that should not be specialised. - | UnspecArg - -instance Outputable SpecArg where - ppr (SpecType t) = text "SpecType" <+> ppr t - ppr UnspecType = text "UnspecType" - ppr (SpecDict d) = text "SpecDict" <+> ppr d - ppr UnspecArg = text "UnspecArg" - -specArgFreeVars :: SpecArg -> VarSet -specArgFreeVars (SpecType ty) = tyCoVarsOfType ty -specArgFreeVars (SpecDict dx) = exprFreeVars dx -specArgFreeVars UnspecType = emptyVarSet -specArgFreeVars UnspecArg = emptyVarSet - -isSpecDict :: SpecArg -> Bool -isSpecDict (SpecDict {}) = True -isSpecDict _ = False - --- | Given binders from an original function 'f', and the 'SpecArg's --- corresponding to its usage, compute everything necessary to build --- a specialisation. --- --- We will use the running example from Note [Specialising Calls]: --- --- f :: forall a b c. Int -> Eq a => Show b => c -> Blah --- f @a @b @c i dEqA dShowA x = blah --- --- Suppose we decide to specialise it at the following pattern: --- --- [ SpecType T1, SpecType T2, UnspecType, UnspecArg --- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ] --- --- We'd eventually like to build the RULE --- --- RULE "SPEC f @T1 @T2 _" --- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). --- f @T1 @T2 @c i d1 d2 = $sf @c i --- --- and the specialisation '$sf' --- --- $sf :: forall c. Int -> c -> Blah --- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) --- --- where dShow1 is a floated binding created by bindAuxiliaryDict. --- --- The cases for 'specHeader' below are presented in the same order as this --- running example. The result of 'specHeader' for this example is as follows: --- --- ( -- Returned arguments --- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] --- , [x] --- --- -- RULE helpers --- , [c, i, d1, d2] --- , [T1, T2, c, i, d1, d2] --- --- -- Specialised function helpers --- , [c, i, x] --- , [dShow1 = $dfShow dShowT2] --- , [T1, T2, c, i, dEqT1, dShow1] --- ) -specHeader - :: SpecEnv - -> [InBndr] -- The binders from the original function 'f' - -> [SpecArg] -- From the CallInfo - -> SpecM ( Bool -- True <=> some useful specialisation happened - -- Not the same as any (isSpecDict args) because - -- the args might be longer than bndrs - - -- Returned arguments - , SpecEnv -- Substitution to apply to the body of 'f' - , [OutBndr] -- Leftover binders from the original function 'f' - -- that don’t have a corresponding SpecArg - - -- RULE helpers - , [OutBndr] -- Binders for the RULE - , [OutExpr] -- Args for the LHS of the rule - - -- Specialised function helpers - , [OutBndr] -- Binders for $sf - , [DictBind] -- Auxiliary dictionary bindings - , [OutExpr] -- Specialised arguments for unfolding - -- Same length as "args for LHS of rule" - ) - --- We want to specialise on type 'T1', and so we must construct a substitution --- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding --- details. -specHeader env (bndr : bndrs) (SpecType t : args) - = do { let env' = extendTvSubstList env [(bndr, t)] - ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( useful - , env'' - , leftover_bndrs - , rule_bs - , Type t : rule_es - , bs' - , dx - , Type t : spec_args - ) - } - --- Next we have a type that we don't want to specialise. We need to perform --- a substitution on it (in case the type refers to 'a'). Additionally, we need --- to produce a binder, LHS argument and RHS argument for the resulting rule, --- /and/ a binder for the specialised body. -specHeader env (bndr : bndrs) (UnspecType : args) - = do { let (env', bndr') = substBndr env bndr - ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( useful - , env'' - , leftover_bndrs - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , bndr' : bs' - , dx - , varToCoreExpr bndr' : spec_args - ) - } - --- Next we want to specialise the 'Eq a' dict away. We need to construct --- a wildcard binder to match the dictionary (See Note [Specialising Calls] for --- the nitty-gritty), as a LHS rule and unfolding details. -specHeader env (bndr : bndrs) (SpecDict d : args) - = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders] - ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d - ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( True -- Ha! A useful specialisation! - , env'' - , leftover_bndrs - -- See Note [Evidence foralls] - , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs - , varToCoreExpr bndr' : rule_es - , bs' - , maybeToList dx_bind ++ dx - , spec_dict : spec_args - ) - } - --- Finally, we have the unspecialised argument 'i'. We need to produce --- a binder, LHS and RHS argument for the RULE, and a binder for the --- specialised body. --- --- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is --- why 'i' doesn't appear in our RULE above. But we have no guarantee that --- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so --- this case must be here. -specHeader env (bndr : bndrs) (UnspecArg : args) - = do { -- see Note [Zap occ info in rule binders] - let (env', bndr') = substBndr env (zapIdOccInfo bndr) - ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( useful - , env'' - , leftover_bndrs - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , if isDeadBinder bndr - then bs' -- see Note [Drop dead args from specialisations] - else bndr' : bs' - , dx - , varToCoreExpr bndr' : spec_args - ) - } - --- If we run out of binders, stop immediately --- See Note [Specialisation Must Preserve Sharing] -specHeader env [] _ = pure (False, env, [], [], [], [], [], []) - --- Return all remaining binders from the original function. These have the --- invariant that they should all correspond to unspecialised arguments, so --- it's safe to stop processing at this point. -specHeader env bndrs [] - = pure (False, env', bndrs', [], [], [], [], []) - where - (env', bndrs') = substBndrs env bndrs - - --- | Binds a dictionary argument to a fresh name, to preserve sharing -bindAuxiliaryDict - :: SpecEnv - -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression - -> ( SpecEnv -- Substitute for orig_dict_id - , Maybe DictBind -- Auxiliary dict binding, if any - , OutExpr) -- Witnessing expression (always trivial) -bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting }) - orig_dict_id fresh_dict_id dict_expr - - -- If the dictionary argument is trivial, - -- don’t bother creating a new dict binding; just substitute - | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr - = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr - `Core.extendInScope` dict_id - -- See Note [Keep the old dictionaries interesting] - , se_interesting = interesting `extendVarSet` dict_id } - in (env', Nothing, dict_expr) - - | otherwise -- Non-trivial dictionary arg; make an auxiliary binding - = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr) - env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id) - `Core.extendInScope` fresh_dict_id - -- See Note [Make the new dictionaries interesting] - , se_interesting = interesting `extendVarSet` fresh_dict_id } - in (env', Just dict_bind, Var fresh_dict_id) - -{- -Note [Make the new dictionaries interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Important! We're going to substitute dx_id1 for d -and we want it to look "interesting", else we won't gather *any* -consequential calls. E.g. - f d = ...g d.... -If we specialise f for a call (f (dfun dNumInt)), we'll get -a consequent call (g d') with an auxiliary definition - d' = df dNumInt -We want that consequent call to look interesting - -Note [Keep the old dictionaries interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In bindAuxiliaryDict, we don’t bother creating a new dict binding if -the dict expression is trivial. For example, if we have - - f = \ @m1 (d1 :: Monad m1) -> ... - -and we specialize it at the pattern - - [SpecType IO, SpecArg $dMonadIO] - -it would be silly to create a new binding for $dMonadIO; it’s already -a binding! So we just extend the substitution directly: - - m1 :-> IO - d1 :-> $dMonadIO - -But this creates a new subtlety: the dict expression might be a dict -binding we floated out while specializing another function. For -example, we might have - - d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict - $sg = h @IO d2 - h = \ @m2 (d2 :: Applicative m2) -> ... - -and end up specializing h at the following pattern: - - [SpecType IO, SpecArg d2] - -When we created the d2 binding in the first place, we locally marked -it as interesting while specializing g as described above by -Note [Make the new dictionaries interesting]. But when we go to -specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the -knowledge that we should specialize on it. - -To fix this, we have to explicitly add d2 *back* to the interesting -set. That way, it will still be considered interesting while -specializing the body of h. See !2913. --} - - -{- ********************************************************************* -* * - UsageDetails and suchlike -* * -********************************************************************* -} - -data UsageDetails - = MkUD { - ud_binds :: !(Bag DictBind), - -- See Note [Floated dictionary bindings] - -- The order is important; - -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 - -- (Remember, Bags preserve order in GHC.) - - ud_calls :: !CallDetails - - -- INVARIANT: suppose bs = bindersOf ud_binds - -- Then 'calls' may *mention* 'bs', - -- but there should be no calls *for* bs - } - --- | A 'DictBind' is a binding along with a cached set containing its free --- variables (both type variables and dictionaries) -type DictBind = (CoreBind, VarSet) - -{- Note [Floated dictionary bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We float out dictionary bindings for the reasons described under -"Dictionary floating" above. But not /just/ dictionary bindings. -Consider - - f :: Eq a => blah - f a d = rhs - - $c== :: T -> T -> Bool - $c== x y = ... - - $df :: Eq T - $df = Eq $c== ... - - gurgle = ...(f @T $df)... - -We gather the call info for (f @T $df), and we don't want to drop it -when we come across the binding for $df. So we add $df to the floats -and continue. But then we have to add $c== to the floats, and so on. -These all float above the binding for 'f', and and now we can -successfully specialise 'f'. - -So the DictBinds in (ud_binds :: Bag DictBind) may contain -non-dictionary bindings too. --} - -instance Outputable UsageDetails where - ppr (MkUD { ud_binds = dbs, ud_calls = calls }) - = text "MkUD" <+> braces (sep (punctuate comma - [text "binds" <+> equals <+> ppr dbs, - text "calls" <+> equals <+> ppr calls])) - -emptyUDs :: UsageDetails -emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } - ------------------------------------------------------------- -type CallDetails = DIdEnv CallInfoSet - -- The order of specialized binds and rules depends on how we linearize - -- CallDetails, so to get determinism we must use a deterministic set here. - -- See Note [Deterministic UniqFM] in UniqDFM - -data CallInfoSet = CIS Id (Bag CallInfo) - -- The list of types and dictionaries is guaranteed to - -- match the type of f - -- The Bag may contain duplicate calls (i.e. f @T and another f @T) - -- These dups are eliminated by already_covered in specCalls - -data CallInfo - = CI { ci_key :: [SpecArg] -- All arguments - , ci_fvs :: VarSet -- Free vars of the ci_key - -- call (including tyvars) - -- [*not* include the main id itself, of course] - } - -type DictExpr = CoreExpr - -ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet -ciSetFilter p (CIS id a) = CIS id (filterBag p a) - -instance Outputable CallInfoSet where - ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) - 2 (ppr map) - -pprCallInfo :: Id -> CallInfo -> SDoc -pprCallInfo fn (CI { ci_key = key }) - = ppr fn <+> ppr key - -ppr_call_key_ty :: SpecArg -> Maybe SDoc -ppr_call_key_ty (SpecType ty) = Just $ char '@' <+> pprParendType ty -ppr_call_key_ty UnspecType = Just $ char '_' -ppr_call_key_ty (SpecDict _) = Nothing -ppr_call_key_ty UnspecArg = Nothing - -instance Outputable CallInfo where - ppr (CI { ci_key = key, ci_fvs = fvs }) - = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ]) - -unionCalls :: CallDetails -> CallDetails -> CallDetails -unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 - -unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet -unionCallInfoSet (CIS f calls1) (CIS _ calls2) = - CIS f (calls1 `unionBags` calls2) - -callDetailsFVs :: CallDetails -> VarSet -callDetailsFVs calls = - nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls - -- It's OK to use nonDetFoldUDFM here because we forget the ordering - -- immediately by converting to a nondeterministic set. - -callInfoFVs :: CallInfoSet -> VarSet -callInfoFVs (CIS _ call_info) = - foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info - -getTheta :: [TyCoBinder] -> [PredType] -getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) - - ------------------------------------------------------------- -singleCall :: Id -> [SpecArg] -> UsageDetails -singleCall id args - = MkUD {ud_binds = emptyBag, - ud_calls = unitDVarEnv id $ CIS id $ - unitBag (CI { ci_key = args -- used to be tys - , ci_fvs = call_fvs }) } - where - call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args - -- The type args (tys) are guaranteed to be part of the dictionary - -- types, because they are just the constrained types, - -- and the dictionary is therefore sure to be bound - -- inside the binding for any type variables free in the type; - -- hence it's safe to neglect tyvars free in tys when making - -- the free-var set for this call - -- BUT I don't trust this reasoning; play safe and include tys_fvs - -- - -- We don't include the 'id' itself. - -mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails -mkCallUDs env f args - = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) - res - where - res = mkCallUDs' env f args - -mkCallUDs' env f args - | not (want_calls_for f) -- Imported from elsewhere - || null ci_key -- No useful specialisation - -- See also Note [Specialisations already covered] - = -- pprTrace "mkCallUDs: discarding" _trace_doc - emptyUDs - - | otherwise - = -- pprTrace "mkCallUDs: keeping" _trace_doc - singleCall f ci_key - where - _trace_doc = vcat [ppr f, ppr args, ppr ci_key] - pis = fst $ splitPiTys $ idType f - constrained_tyvars = tyCoVarsOfTypes $ getTheta pis - - ci_key :: [SpecArg] - ci_key = dropWhileEndLE (not . isSpecDict) $ - zipWith mk_spec_arg args pis - -- Drop trailing args until we get to a SpecDict - -- In this way the RULE has as few args as possible, - -- which broadens its applicability, since rules only - -- fire when saturated - - mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg - mk_spec_arg arg (Named bndr) - | binderVar bndr `elemVarSet` constrained_tyvars - = case arg of - Type ty -> SpecType ty - _ -> pprPanic "ci_key" $ ppr arg - | otherwise = UnspecType - - -- For "InvisArg", which are the type-class dictionaries, - -- we decide on a case by case basis if we want to specialise - -- on this argument; if so, SpecDict, if not UnspecArg - mk_spec_arg arg (Anon InvisArg pred) - | type_determines_value pred - , interestingDict env arg -- Note [Interesting dictionary arguments] - = SpecDict arg - | otherwise = UnspecArg - - mk_spec_arg _ (Anon VisArg _) - = UnspecArg - - want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) - -- For imported things, we gather call instances if - -- there is an unfolding that we could in principle specialise - -- We might still decide not to use it (consulting dflags) - -- in specImports - -- Use 'realIdUnfolding' to ignore the loop-breaker flag! - - type_determines_value pred -- See Note [Type determines value] - = case classifyPredType pred of - ClassPred cls _ -> not (isIPClass cls) -- Superclasses can't be IPs - EqPred {} -> True - IrredPred {} -> True -- Things like (D []) where D is a - -- Constraint-ranged family; #7785 - ForAllPred {} -> True - -{- -Note [Type determines value] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only specialise on non-IP *class* params, because these are the ones -whose *type* determines their *value*. In particular, with implicit -params, the type args *don't* say what the value of the implicit param -is! See #7101. - -So we treat implicit params just like ordinary arguments for the -purposes of specialisation. Note that we still want to specialise -functions with implicit params if they have *other* dicts which are -class params; see #17930. - -One apparent additional complexity involves type families. For -example, consider - type family D (v::*->*) :: Constraint - type instance D [] = () - f :: D v => v Char -> Int -If we see a call (f "foo"), we'll pass a "dictionary" - () |> (g :: () ~ D []) -and it's good to specialise f at this dictionary. - -So the question is: can an implicit parameter "hide inside" a -type-family constraint like (D a). Well, no. We don't allow - type instance D Maybe = ?x:Int -Hence the IrredPred case in type_determines_value. See #7785. - -Note [Interesting dictionary arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - \a.\d:Eq a. let f = ... in ...(f d)... -There really is not much point in specialising f wrt the dictionary d, -because the code for the specialised f is not improved at all, because -d is lambda-bound. We simply get junk specialisations. - -What is "interesting"? Just that it has *some* structure. But what about -variables? - - * A variable might be imported, in which case its unfolding - will tell us whether it has useful structure - - * Local variables are cloned on the way down (to avoid clashes when - we float dictionaries), and cloning drops the unfolding - (cloneIdBndr). Moreover, we make up some new bindings, and it's a - nuisance to give them unfoldings. So we keep track of the - "interesting" dictionaries as a VarSet in SpecEnv. - We have to take care to put any new interesting dictionary - bindings in the set. - -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables don't have unfoldings. But makes a -massive difference in a few cases, eg #5113. For nofib as a -whole it's only a small win: 2.2% improvement in allocation for ansi, -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. --} - -interestingDict :: SpecEnv -> CoreExpr -> Bool --- A dictionary argument is interesting if it has *some* structure --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case -interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - || v `elemVarSet` se_interesting env -interestingDict _ (Type _) = False -interestingDict _ (Coercion _) = False -interestingDict env (App fn (Type _)) = interestingDict env fn -interestingDict env (App fn (Coercion _)) = interestingDict env fn -interestingDict env (Tick _ a) = interestingDict env a -interestingDict env (Cast e _) = interestingDict env e -interestingDict _ _ = True - -plusUDs :: UsageDetails -> UsageDetails -> UsageDetails -plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) - (MkUD {ud_binds = db2, ud_calls = calls2}) - = MkUD { ud_binds = db1 `unionBags` db2 - , ud_calls = calls1 `unionCalls` calls2 } - ------------------------------ -_dictBindBndrs :: Bag DictBind -> [Id] -_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs - --- | Construct a 'DictBind' from a 'CoreBind' -mkDB :: CoreBind -> DictBind -mkDB bind = (bind, bind_fvs bind) - --- | Identify the free variables of a 'CoreBind' -bind_fvs :: CoreBind -> VarSet -bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) -bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs - where - bndrs = map fst prs - rhs_fvs = unionVarSets (map pair_fvs prs) - -pair_fvs :: (Id, CoreExpr) -> VarSet -pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs - `unionVarSet` idFreeVars bndr - -- idFreeVars: don't forget variables mentioned in - -- the rules of the bndr. C.f. OccAnal.addRuleUsage - -- Also tyvars mentioned in its type; they may not appear - -- in the RHS - -- type T a = Int - -- x :: T a = 3 - where - interesting :: InterestingVarFun - interesting v = isLocalVar v || (isId v && isDFunId v) - -- Very important: include DFunIds /even/ if it is imported - -- Reason: See Note [Avoiding loops], the second exmaple - -- involving an imported dfun. We must know whether - -- a dictionary binding depends on an imported dfun, - -- in case we try to specialise that imported dfun - -- #13429 illustrates - --- | Flatten a set of "dumped" 'DictBind's, and some other binding --- pairs, into a single recursive binding. -recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind -recWithDumpedDicts pairs dbs - = (Rec bindings, fvs) - where - (bindings, fvs) = foldr add - ([], emptyVarSet) - (dbs `snocBag` mkDB (Rec pairs)) - add (NonRec b r, fvs') (pairs, fvs) = - ((b,r) : pairs, fvs `unionVarSet` fvs') - add (Rec prs1, fvs') (pairs, fvs) = - (prs1 ++ pairs, fvs `unionVarSet` fvs') - -snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails --- Add ud_binds to the tail end of the bindings in uds -snocDictBinds uds dbs - = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs } - -consDictBind :: DictBind -> UsageDetails -> UsageDetails -consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } - -addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails -addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds } - -snocDictBind :: UsageDetails -> DictBind -> UsageDetails -snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } - -wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] -wrapDictBinds dbs binds - = foldr add binds dbs - where - add (bind,_) binds = bind : binds - -wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr -wrapDictBindsE dbs expr - = foldr add expr dbs - where - add (bind,_) expr = Let bind expr - ----------------------- -dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) --- Used at a lambda or case binder; just dump anything mentioning the binder -dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - | null bndrs = (uds, emptyBag) -- Common in case alternatives - | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs) - where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor - deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be - -- no calls for any of the dicts in dump_dbs - -dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) --- Used at a let(rec) binding. --- We return a boolean indicating whether the binding itself is mentioned, --- directly or indirectly, by any of the ud_calls; in that case we want to --- float the binding itself; --- See Note [Floated dictionary bindings] -dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs, float_all) - where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsFor bndrs orig_calls - float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls - -callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) -callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace ("callsForMe") - -- (vcat [ppr fn, - -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), - -- text "Orig calls =" <+> ppr orig_calls, - -- text "Dep set =" <+> ppr dep_set, - -- text "Calls for me =" <+> ppr calls_for_me]) $ - (uds_without_me, calls_for_me) - where - uds_without_me = MkUD { ud_binds = orig_dbs - , ud_calls = delDVarEnv orig_calls fn } - calls_for_me = case lookupDVarEnv orig_calls fn of - Nothing -> [] - Just cis -> filterCalls cis orig_dbs - -- filterCalls: drop calls that (directly or indirectly) - -- refer to fn. See Note [Avoiding loops] - ----------------------- -filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo] --- See Note [Avoiding loops] -filterCalls (CIS fn call_bag) dbs - = filter ok_call (bagToList call_bag) - where - dump_set = foldl' go (unitVarSet fn) dbs - -- This dump-set could also be computed by splitDictBinds - -- (_,_,dump_set) = splitDictBinds dbs {fn} - -- But this variant is shorter - - go so_far (db,fvs) | fvs `intersectsVarSet` so_far - = extendVarSetList so_far (bindersOf db) - | otherwise = so_far - - ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set) - ----------------------- -splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) --- splitDictBinds dbs bndrs returns --- (free_dbs, dump_dbs, dump_set) --- where --- * dump_dbs depends, transitively on bndrs --- * free_dbs does not depend on bndrs --- * dump_set = bndrs `union` bndrs(dump_dbs) -splitDictBinds dbs bndr_set - = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs - -- Important that it's foldl' not foldr; - -- we're accumulating the set of dumped ids in dump_set - where - split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) - | dump_idset `intersectsVarSet` fvs -- Dump it - = (free_dbs, dump_dbs `snocBag` db, - extendVarSetList dump_idset (bindersOf bind)) - - | otherwise -- Don't dump it - = (free_dbs `snocBag` db, dump_dbs, dump_idset) - - ----------------------- -deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails --- Remove calls *mentioning* bs in any way -deleteCallsMentioning bs calls - = mapDVarEnv (ciSetFilter keep_call) calls - where - keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs) - -deleteCallsFor :: [Id] -> CallDetails -> CallDetails --- Remove calls *for* bs -deleteCallsFor bs calls = delDVarEnvList calls bs - -{- -************************************************************************ -* * -\subsubsection{Boring helper functions} -* * -************************************************************************ --} - -newtype SpecM a = SpecM (State SpecState a) deriving (Functor) - -data SpecState = SpecState { - spec_uniq_supply :: UniqSupply, - spec_module :: Module, - spec_dflags :: DynFlags - } - -instance Applicative SpecM where - pure x = SpecM $ return x - (<*>) = ap - -instance Monad SpecM where - SpecM x >>= f = SpecM $ do y <- x - case f y of - SpecM z -> - z -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - -instance MonadFail.MonadFail SpecM where - fail str = SpecM $ error str - -instance MonadUnique SpecM where - getUniqueSupplyM - = SpecM $ do st <- get - let (us1, us2) = splitUniqSupply $ spec_uniq_supply st - put $ st { spec_uniq_supply = us2 } - return us1 - - getUniqueM - = SpecM $ do st <- get - let (u,us') = takeUniqFromSupply $ spec_uniq_supply st - put $ st { spec_uniq_supply = us' } - return u - -instance HasDynFlags SpecM where - getDynFlags = SpecM $ liftM spec_dflags get - -instance HasModule SpecM where - getModule = SpecM $ liftM spec_module get - -runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a -runSpecM dflags this_mod (SpecM spec) - = do us <- getUniqueSupplyM - let initialState = SpecState { - spec_uniq_supply = us, - spec_module = this_mod, - spec_dflags = dflags - } - return $ evalState spec initialState - -mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) -mapAndCombineSM _ [] = return ([], emptyUDs) -mapAndCombineSM f (x:xs) = do (y, uds1) <- f x - (ys, uds2) <- mapAndCombineSM f xs - return (y:ys, uds1 `plusUDs` uds2) - -extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv -extendTvSubstList env tv_binds - = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds } - -substTy :: SpecEnv -> Type -> Type -substTy env ty = Core.substTy (se_subst env) ty - -substCo :: SpecEnv -> Coercion -> Coercion -substCo env co = Core.substCo (se_subst env) co - -substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) -substBndr env bs = case Core.substBndr (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) -substBndrs env bs = case Core.substBndrs (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind) --- Clone the binders of the bind; return new bind with the cloned binders --- Return the substitution to use for RHSs, and the one to use for the body -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) - = do { us <- getUniqueSupplyM - ; let (subst', bndr') = Core.cloneIdBndr subst us bndr - interesting' | interestingDict env rhs - = interesting `extendVarSet` bndr' - | otherwise = interesting - ; return (env, env { se_subst = subst', se_interesting = interesting' } - , NonRec bndr' rhs) } - -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) - = do { us <- getUniqueSupplyM - ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs) - env' = env { se_subst = subst' - , se_interesting = interesting `extendVarSetList` - [ v | (v,r) <- pairs, interestingDict env r ] } - ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } - -newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr --- Make up completely fresh binders for the dictionaries --- Their bindings are going to float outwards -newDictBndr env b = do { uniq <- getUniqueM - ; let n = idName b - ty' = substTy env (idType b) - ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) } - -newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id - -- Give the new Id a similar occurrence name to the old one -newSpecIdSM old_id new_ty join_arity_maybe - = do { uniq <- getUniqueM - ; let name = idName old_id - new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name) - `asJoinId_maybe` join_arity_maybe - ; return new_id } - -{- - Old (but interesting) stuff about unboxed bindings - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -What should we do when a value is specialised to a *strict* unboxed value? - - map_*_* f (x:xs) = let h = f x - t = map f xs - in h:t - -Could convert let to case: - - map_*_Int# f (x:xs) = case f x of h# -> - let t = map f xs - in h#:t - -This may be undesirable since it forces evaluation here, but the value -may not be used in all branches of the body. In the general case this -transformation is impossible since the mutual recursion in a letrec -cannot be expressed as a case. - -There is also a problem with top-level unboxed values, since our -implementation cannot handle unboxed values at the top level. - -Solution: Lift the binding of the unboxed value and extract it when it -is used: - - map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# - t = map f xs - in case h of - _Lift h# -> h#:t - -Now give it to the simplifier and the _Lifting will be optimised away. - -The benefit is that we have given the specialised "unboxed" values a -very simple lifted semantics and then leave it up to the simplifier to -optimise it --- knowing that the overheads will be removed in nearly -all cases. - -In particular, the value will only be evaluated in the branches of the -program which use it, rather than being forced at the point where the -value is bound. For example: - - filtermap_*_* p f (x:xs) - = let h = f x - t = ... - in case p x of - True -> h:t - False -> t - ==> - filtermap_*_Int# p f (x:xs) - = let h = case (f x) of h# -> _Lift h# - t = ... - in case p x of - True -> case h of _Lift h# - -> h#:t - False -> t - -The binding for h can still be inlined in the one branch and the -_Lifting eliminated. - - -Question: When won't the _Lifting be eliminated? - -Answer: When they at the top-level (where it is necessary) or when -inlining would duplicate work (or possibly code depending on -options). However, the _Lifting will still be eliminated if the -strictness analyser deems the lifted binding strict. --} diff --git a/stgSyn/CoreToStg.hs b/stgSyn/CoreToStg.hs deleted file mode 100644 --- a/stgSyn/CoreToStg.hs +++ /dev/null @@ -1,961 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor #-} - --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --- - --------------------------------------------------------------- --- Converting Core to STG Syntax --------------------------------------------------------------- - --- And, as we have the info in hand, we may convert some lets to --- let-no-escapes. - -module CoreToStg ( coreToStg ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreUtils ( exprType, findDefault, isJoinBind - , exprIsTickedString_maybe ) -import CoreArity ( manifestArity ) -import StgSyn - -import Type -import RepType -import TyCon -import MkId ( coercionTokenId ) -import Id -import IdInfo -import DataCon -import CostCentre -import VarEnv -import Module -import Name ( isExternalName, nameOccName, nameModule_maybe ) -import OccName ( occNameFS ) -import BasicTypes ( Arity ) -import TysWiredIn ( unboxedUnitDataCon, unitDataConId ) -import Literal -import Outputable -import MonadUtils -import FastString -import Util -import DynFlags -import ForeignCall -import Demand ( isUsedOnce ) -import PrimOp ( PrimCall(..), primOpWrapperId ) -import SrcLoc ( mkGeneralSrcSpan ) - -import Data.List.NonEmpty (nonEmpty, toList) -import Data.Maybe (fromMaybe) -import Control.Monad (ap) - --- Note [Live vs free] --- ~~~~~~~~~~~~~~~~~~~ --- --- The two are not the same. Liveness is an operational property rather --- than a semantic one. A variable is live at a particular execution --- point if it can be referred to directly again. In particular, a dead --- variable's stack slot (if it has one): --- --- - should be stubbed to avoid space leaks, and --- - may be reused for something else. --- --- There ought to be a better way to say this. Here are some examples: --- --- let v = [q] \[x] -> e --- in --- ...v... (but no q's) --- --- Just after the `in', v is live, but q is dead. If the whole of that --- let expression was enclosed in a case expression, thus: --- --- case (let v = [q] \[x] -> e in ...v...) of --- alts[...q...] --- --- (ie `alts' mention `q'), then `q' is live even after the `in'; because --- we'll return later to the `alts' and need it. --- --- Let-no-escapes make this a bit more interesting: --- --- let-no-escape v = [q] \ [x] -> e --- in --- ...v... --- --- Here, `q' is still live at the `in', because `v' is represented not by --- a closure but by the current stack state. In other words, if `v' is --- live then so is `q'. Furthermore, if `e' mentions an enclosing --- let-no-escaped variable, then its free variables are also live if `v' is. - --- Note [What are these SRTs all about?] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider the Core program, --- --- fibs = go 1 1 --- where go a b = let c = a + c --- in c : go b c --- add x = map (\y -> x*y) fibs --- --- In this case we have a CAF, 'fibs', which is quite large after evaluation and --- has only one possible user, 'add'. Consequently, we want to ensure that when --- all references to 'add' die we can garbage collect any bit of 'fibs' that we --- have evaluated. --- --- However, how do we know whether there are any references to 'fibs' still --- around? Afterall, the only reference to it is buried in the code generated --- for 'add'. The answer is that we record the CAFs referred to by a definition --- in its info table, namely a part of it known as the Static Reference Table --- (SRT). --- --- Since SRTs are so common, we use a special compact encoding for them in: we --- produce one table containing a list of CAFs in a module and then include a --- bitmap in each info table describing which entries of this table the closure --- references. --- --- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki. - --- Note [What is a non-escaping let] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- NB: Nowadays this is recognized by the occurrence analyser by turning a --- "non-escaping let" into a join point. The following is then an operational --- account of join points. --- --- Consider: --- --- let x = fvs \ args -> e --- in --- if ... then x else --- if ... then x else ... --- --- `x' is used twice (so we probably can't unfold it), but when it is --- entered, the stack is deeper than it was when the definition of `x' --- happened. Specifically, if instead of allocating a closure for `x', --- we saved all `x's fvs on the stack, and remembered the stack depth at --- that moment, then whenever we enter `x' we can simply set the stack --- pointer(s) to these remembered (compile-time-fixed) values, and jump --- to the code for `x'. --- --- All of this is provided x is: --- 1. non-updatable; --- 2. guaranteed to be entered before the stack retreats -- ie x is not --- buried in a heap-allocated closure, or passed as an argument to --- something; --- 3. all the enters have exactly the right number of arguments, --- no more no less; --- 4. all the enters are tail calls; that is, they return to the --- caller enclosing the definition of `x'. --- --- Under these circumstances we say that `x' is non-escaping. --- --- An example of when (4) does not hold: --- --- let x = ... --- in case x of ...alts... --- --- Here, `x' is certainly entered only when the stack is deeper than when --- `x' is defined, but here it must return to ...alts... So we can't just --- adjust the stack down to `x''s recalled points, because that would lost --- alts' context. --- --- Things can get a little more complicated. Consider: --- --- let y = ... --- in let x = fvs \ args -> ...y... --- in ...x... --- --- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a --- non-escaping way in ...y..., then `y' is non-escaping. --- --- `x' can even be recursive! Eg: --- --- letrec x = [y] \ [v] -> if v then x True else ... --- in --- ...(x b)... - --- Note [Cost-centre initialization plan] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`, --- and the fields were then fixed by a separate pass `stgMassageForProfiling`. --- We now initialize these correctly. The initialization works like this: --- --- - For non-top level bindings always use `currentCCS`. --- --- - For top-level bindings, check if the binding is a CAF --- --- - CAF: If -fcaf-all is enabled, create a new CAF just for this CAF --- and use it. Note that these new cost centres need to be --- collected to be able to generate cost centre initialization --- code, so `coreToTopStgRhs` now returns `CollectedCCs`. --- --- If -fcaf-all is not enabled, use "all CAFs" cost centre. --- --- - Non-CAF: Top-level (static) data is not counted in heap profiles; nor --- do we set CCCS from it; so we just slam in --- dontCareCostCentre. - --- Note [Coercion tokens] --- ~~~~~~~~~~~~~~~~~~~~~~ --- In coreToStgArgs, we drop type arguments completely, but we replace --- coercions with a special coercionToken# placeholder. Why? Consider: --- --- f :: forall a. Int ~# Bool -> a --- f = /\a. \(co :: Int ~# Bool) -> error "impossible" --- --- If we erased the coercion argument completely, we’d end up with just --- f = error "impossible", but then f `seq` () would be ⊥! --- --- This is an artificial example, but back in the day we *did* treat --- coercion lambdas like type lambdas, and we had bug reports as a --- result. So now we treat coercion lambdas like value lambdas, but we --- treat coercions themselves as zero-width arguments — coercionToken# --- has representation VoidRep — which gets the best of both worlds. --- --- (For the gory details, see also the (unpublished) paper, “Practical --- aspects of evidence-based compilation in System FC.”) - --- -------------------------------------------------------------- --- Setting variable info: top-level, binds, RHSs --- -------------------------------------------------------------- - -coreToStg :: DynFlags -> Module -> CoreProgram - -> ([StgTopBinding], CollectedCCs) -coreToStg dflags this_mod pgm - = (pgm', final_ccs) - where - (_, (local_ccs, local_cc_stacks), pgm') - = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm - - prof = WayProf `elem` ways dflags - - final_ccs - | prof && gopt Opt_AutoSccsOnIndividualCafs dflags - = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC - | prof - = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks) - | otherwise - = emptyCollectedCCs - - (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod - -coreTopBindsToStg - :: DynFlags - -> Module - -> IdEnv HowBound -- environment for the bindings - -> CollectedCCs - -> CoreProgram - -> (IdEnv HowBound, CollectedCCs, [StgTopBinding]) - -coreTopBindsToStg _ _ env ccs [] - = (env, ccs, []) -coreTopBindsToStg dflags this_mod env ccs (b:bs) - = (env2, ccs2, b':bs') - where - (env1, ccs1, b' ) = - coreTopBindToStg dflags this_mod env ccs b - (env2, ccs2, bs') = - coreTopBindsToStg dflags this_mod env1 ccs1 bs - -coreTopBindToStg - :: DynFlags - -> Module - -> IdEnv HowBound - -> CollectedCCs - -> CoreBind - -> (IdEnv HowBound, CollectedCCs, StgTopBinding) - -coreTopBindToStg _ _ env ccs (NonRec id e) - | Just str <- exprIsTickedString_maybe e - -- top-level string literal - -- See Note [CoreSyn top-level string literals] in CoreSyn - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet 0 - in (env', ccs, StgTopStringLit id str) - -coreTopBindToStg dflags this_mod env ccs (NonRec id rhs) - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet $! manifestArity rhs - - (stg_rhs, ccs') = - initCts dflags env $ - coreToTopStgRhs dflags ccs this_mod (id,rhs) - - bind = StgTopLifted $ StgNonRec id stg_rhs - in - assertConsistentCafInfo dflags id bind (ppr bind) - -- NB: previously the assertion printed 'rhs' and 'bind' - -- as well as 'id', but that led to a black hole - -- where printing the assertion error tripped the - -- assertion again! - (env', ccs', bind) - -coreTopBindToStg dflags this_mod env ccs (Rec pairs) - = ASSERT( not (null pairs) ) - let - binders = map fst pairs - - extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) - | (b, rhs) <- pairs ] - env' = extendVarEnvList env extra_env' - - -- generate StgTopBindings and CAF cost centres created for CAFs - (ccs', stg_rhss) - = initCts dflags env' $ do - mapAccumLM (\ccs rhs -> do - (rhs', ccs') <- - coreToTopStgRhs dflags ccs this_mod rhs - return (ccs', rhs')) - ccs - pairs - - bind = StgTopLifted $ StgRec (zip binders stg_rhss) - in - assertConsistentCafInfo dflags (head binders) bind (ppr binders) - (env', ccs', bind) - --- | CAF consistency issues will generally result in segfaults and are quite --- difficult to debug (see #16846). We enable checking of the --- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that --- we catch these issues. -assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a -assertConsistentCafInfo dflags id bind err_doc result - | gopt Opt_DoStgLinting dflags || debugIsOn - , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc - | otherwise = result - --- Assertion helper: this checks that the CafInfo on the Id matches --- what CoreToStg has figured out about the binding's SRT. The --- CafInfo will be exact in all cases except when CorePrep has --- floated out a binding, in which case it will be approximate. -consistentCafInfo :: Id -> StgTopBinding -> Bool -consistentCafInfo id bind - = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) - safe - where - safe = id_marked_caffy || not binding_is_caffy - exact = id_marked_caffy == binding_is_caffy - id_marked_caffy = mayHaveCafRefs (idCafInfo id) - binding_is_caffy = topStgBindHasCafRefs bind - is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" - -coreToTopStgRhs - :: DynFlags - -> CollectedCCs - -> Module - -> (Id,CoreExpr) - -> CtsM (StgRhs, CollectedCCs) - -coreToTopStgRhs dflags ccs this_mod (bndr, rhs) - = do { new_rhs <- coreToStgExpr rhs - - ; let (stg_rhs, ccs') = - mkTopStgRhs dflags this_mod ccs bndr new_rhs - stg_arity = - stgRhsArity stg_rhs - - ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, - ccs') } - where - -- It's vital that the arity on a top-level Id matches - -- the arity of the generated STG binding, else an importing - -- module will use the wrong calling convention - -- (#2844 was an example where this happened) - -- NB1: we can't move the assertion further out without - -- blocking the "knot" tied in coreTopBindsToStg - -- NB2: the arity check is only needed for Ids with External - -- Names, because they are externally visible. The CorePrep - -- pass introduces "sat" things with Local Names and does - -- not bother to set their Arity info, so don't fail for those - arity_ok stg_arity - | isExternalName (idName bndr) = id_arity == stg_arity - | otherwise = True - id_arity = idArity bndr - mk_arity_msg stg_arity - = vcat [ppr bndr, - text "Id arity:" <+> ppr id_arity, - text "STG arity:" <+> ppr stg_arity] - --- --------------------------------------------------------------------------- --- Expressions --- --------------------------------------------------------------------------- - -coreToStgExpr - :: CoreExpr - -> CtsM StgExpr - --- The second and third components can be derived in a simple bottom up pass, not --- dependent on any decisions about which variables will be let-no-escaped or --- not. The first component, that is, the decorated expression, may then depend --- on these components, but it in turn is not scrutinised as the basis for any --- decisions. Hence no black holes. - --- No LitInteger's or LitNatural's should be left by the time this is called. --- CorePrep should have converted them all to a real core representation. -coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger" -coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural" -coreToStgExpr (Lit l) = return (StgLit l) -coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) - -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in - -- a STG to Cmm pass. - = coreToStgExpr (Var unitDataConId) -coreToStgExpr (Var v) = coreToStgApp v [] [] -coreToStgExpr (Coercion _) - -- See Note [Coercion tokens] - = coreToStgApp coercionTokenId [] [] - -coreToStgExpr expr@(App _ _) - = coreToStgApp f args ticks - where - (f, args, ticks) = myCollectArgs expr - -coreToStgExpr expr@(Lam _ _) - = let - (args, body) = myCollectBinders expr - args' = filterStgBinders args - in - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do - body' <- coreToStgExpr body - let - result_expr = case nonEmpty args' of - Nothing -> body' - Just args'' -> StgLam args'' body' - - return result_expr - -coreToStgExpr (Tick tick expr) - = do case tick of - HpcTick{} -> return () - ProfNote{} -> return () - SourceNote{} -> return () - Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen" - expr2 <- coreToStgExpr expr - return (StgTick tick expr2) - -coreToStgExpr (Cast expr _) - = coreToStgExpr expr - --- Cases require a little more real work. - -coreToStgExpr (Case scrut _ _ []) - = coreToStgExpr scrut - -- See Note [Empty case alternatives] in CoreSyn If the case - -- alternatives are empty, the scrutinee must diverge or raise an - -- exception, so we can just dive into it. - -- - -- Of course this may seg-fault if the scrutinee *does* return. A - -- belt-and-braces approach would be to move this case into the - -- code generator, and put a return point anyway that calls a - -- runtime system error function. - - -coreToStgExpr (Case scrut bndr _ alts) = do - alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts) - scrut2 <- coreToStgExpr scrut - return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) - where - vars_alt (con, binders, rhs) - | DataAlt c <- con, c == unboxedUnitDataCon - = -- This case is a bit smelly. - -- See Note [Nullary unboxed tuple] in Type.hs - -- where a nullary tuple is mapped to (State# World#) - ASSERT( null binders ) - do { rhs2 <- coreToStgExpr rhs - ; return (DEFAULT, [], rhs2) } - | otherwise - = let -- Remove type variables - binders' = filterStgBinders binders - in - extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do - rhs2 <- coreToStgExpr rhs - return (con, binders', rhs2) - -coreToStgExpr (Let bind body) = do - coreToStgLet bind body - -coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) - -mkStgAltType :: Id -> [CoreAlt] -> AltType -mkStgAltType bndr alts - | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty - = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples - - | otherwise - = case prim_reps of - [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of - Just tc - | isAbstractTyCon tc -> look_for_better_tycon - | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) - PolyAlt - Nothing -> PolyAlt - [unlifted] -> PrimAlt unlifted - not_unary -> MultiValAlt (length not_unary) - where - bndr_ty = idType bndr - prim_reps = typePrimRep bndr_ty - - _is_poly_alt_tycon tc - = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive - || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict - -- function application where argument has a - -- type-family type - - -- Sometimes, the TyCon is a AbstractTyCon which may not have any - -- constructors inside it. Then we may get a better TyCon by - -- grabbing the one from a constructor alternative - -- if one exists. - look_for_better_tycon - | ((DataAlt con, _, _) : _) <- data_alts = - AlgAlt (dataConTyCon con) - | otherwise = - ASSERT(null data_alts) - PolyAlt - where - (data_alts, _deflt) = findDefault alts - --- --------------------------------------------------------------------------- --- Applications --- --------------------------------------------------------------------------- - -coreToStgApp :: Id -- Function - -> [CoreArg] -- Arguments - -> [Tickish Id] -- Debug ticks - -> CtsM StgExpr -coreToStgApp f args ticks = do - (args', ticks') <- coreToStgArgs args - how_bound <- lookupVarCts f - - let - n_val_args = valArgCount args - - -- Mostly, the arity info of a function is in the fn's IdInfo - -- But new bindings introduced by CoreSat may not have no - -- arity info; it would do us no good anyway. For example: - -- let f = \ab -> e in f - -- No point in having correct arity info for f! - -- Hence the hasArity stuff below. - -- NB: f_arity is only consulted for LetBound things - f_arity = stgArity f how_bound - saturated = f_arity <= n_val_args - - res_ty = exprType (mkApps (Var f) args) - app = case idDetails f of - DataConWorkId dc - | saturated -> StgConApp dc args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) - - -- Some primitive operator that might be implemented as a library call. - -- As described in Note [Primop wrappers] in PrimOp.hs, here we - -- turn unsaturated primop applications into applications of - -- the primop's wrapper. - PrimOpId op - | saturated -> StgOpApp (StgPrimOp op) args' res_ty - | otherwise -> StgApp (primOpWrapperId op) args' - - -- A call to some primitive Cmm function. - FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) - PrimCallConv _ _ _)) - -> ASSERT( saturated ) - StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty - - -- A regular foreign call. - FCallId call -> ASSERT( saturated ) - StgOpApp (StgFCallOp call (idType f)) args' res_ty - - TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') - _other -> StgApp f args' - - tapp = foldr StgTick app (ticks ++ ticks') - - -- Forcing these fixes a leak in the code generator, noticed while - -- profiling for trac #4367 - app `seq` return tapp - --- --------------------------------------------------------------------------- --- Argument lists --- This is the guy that turns applications into A-normal form --- --------------------------------------------------------------------------- - -coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id]) -coreToStgArgs [] - = return ([], []) - -coreToStgArgs (Type _ : args) = do -- Type argument - (args', ts) <- coreToStgArgs args - return (args', ts) - -coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion tokens] - = do { (args', ts) <- coreToStgArgs args - ; return (StgVarArg coercionTokenId : args', ts) } - -coreToStgArgs (Tick t e : args) - = ASSERT( not (tickishIsCode t) ) - do { (args', ts) <- coreToStgArgs (e : args) - ; return (args', t:ts) } - -coreToStgArgs (arg : args) = do -- Non-type argument - (stg_args, ticks) <- coreToStgArgs args - arg' <- coreToStgExpr arg - let - (aticks, arg'') = stripStgTicksTop tickishFloatable arg' - stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con [] _ -> StgVarArg (dataConWorkId con) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg) - - -- WARNING: what if we have an argument like (v `cast` co) - -- where 'co' changes the representation type? - -- (This really only happens if co is unsafe.) - -- Then all the getArgAmode stuff in CgBindery will set the - -- cg_rep of the CgIdInfo based on the type of v, rather - -- than the type of 'co'. - -- This matters particularly when the function is a primop - -- or foreign call. - -- Wanted: a better solution than this hacky warning - - dflags <- getDynFlags - let - arg_rep = typePrimRep (exprType arg) - stg_arg_rep = typePrimRep (stgArgType stg_arg) - bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep) - - WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg ) - return (stg_arg : stg_args, ticks ++ aticks) - - --- --------------------------------------------------------------------------- --- The magic for lets: --- --------------------------------------------------------------------------- - -coreToStgLet - :: CoreBind -- bindings - -> CoreExpr -- body - -> CtsM StgExpr -- new let - -coreToStgLet bind body = do - (bind2, body2) - <- do - - ( bind2, env_ext) - <- vars_bind bind - - -- Do the body - extendVarEnvCts env_ext $ do - body2 <- coreToStgExpr body - - return (bind2, body2) - - -- Compute the new let-expression - let - new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2 - | otherwise = StgLet noExtFieldSilent bind2 body2 - - return new_let - where - mk_binding binder rhs - = (binder, LetBound NestedLet (manifestArity rhs)) - - vars_bind :: CoreBind - -> CtsM (StgBinding, - [(Id, HowBound)]) -- extension to environment - - vars_bind (NonRec binder rhs) = do - rhs2 <- coreToStgRhs (binder,rhs) - let - env_ext_item = mk_binding binder rhs - - return (StgNonRec binder rhs2, [env_ext_item]) - - vars_bind (Rec pairs) - = let - binders = map fst pairs - env_ext = [ mk_binding b rhs - | (b,rhs) <- pairs ] - in - extendVarEnvCts env_ext $ do - rhss2 <- mapM coreToStgRhs pairs - return (StgRec (binders `zip` rhss2), env_ext) - -coreToStgRhs :: (Id,CoreExpr) - -> CtsM StgRhs - -coreToStgRhs (bndr, rhs) = do - new_rhs <- coreToStgExpr rhs - return (mkStgRhs bndr new_rhs) - --- Generate a top-level RHS. Any new cost centres generated for CAFs will be --- appended to `CollectedCCs` argument. -mkTopStgRhs :: DynFlags -> Module -> CollectedCCs - -> Id -> StgExpr -> (StgRhs, CollectedCCs) - -mkTopStgRhs dflags this_mod ccs bndr rhs - | StgLam bndrs body <- rhs - = -- StgLam can't have empty arguments, so not CAF - ( StgRhsClosure noExtFieldSilent - dontCareCCS - ReEntrant - (toList bndrs) body - , ccs ) - - | StgConApp con args _ <- unticked_rhs - , -- Dynamic StgConApps are updatable - not (isDllConApp dflags this_mod con args) - = -- CorePrep does this right, but just to make sure - ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con) - , ppr bndr $$ ppr con $$ ppr args) - ( StgRhsCon dontCareCCS con args, ccs ) - - -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. - | gopt Opt_AutoSccsOnIndividualCafs dflags - = ( StgRhsClosure noExtFieldSilent - caf_ccs - upd_flag [] rhs - , collectCC caf_cc caf_ccs ccs ) - - | otherwise - = ( StgRhsClosure noExtFieldSilent - all_cafs_ccs - upd_flag [] rhs - , ccs ) - - where - unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs - - upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable - - -- CAF cost centres generated for -fcaf-all - caf_cc = mkAutoCC bndr modl - caf_ccs = mkSingletonCCS caf_cc - -- careful: the binder might be :Main.main, - -- which doesn't belong to module mod_name. - -- bug #249, tests prof001, prof002 - modl | Just m <- nameModule_maybe (idName bndr) = m - | otherwise = this_mod - - -- default CAF cost centre - (_, all_cafs_ccs) = getAllCAFsCC this_mod - --- Generate a non-top-level RHS. Cost-centre is always currentCCS, --- see Note [Cost-centre initialzation plan]. -mkStgRhs :: Id -> StgExpr -> StgRhs -mkStgRhs bndr rhs - | StgLam bndrs body <- rhs - = StgRhsClosure noExtFieldSilent - currentCCS - ReEntrant - (toList bndrs) body - - | isJoinId bndr -- must be a nullary join point - = ASSERT(idJoinArity bndr == 0) - StgRhsClosure noExtFieldSilent - currentCCS - ReEntrant -- ignored for LNE - [] rhs - - | StgConApp con args _ <- unticked_rhs - = StgRhsCon currentCCS con args - - | otherwise - = StgRhsClosure noExtFieldSilent - currentCCS - upd_flag [] rhs - where - unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs - - upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable - - {- - SDM: disabled. Eval/Apply can't handle functions with arity zero very - well; and making these into simple non-updatable thunks breaks other - assumptions (namely that they will be entered only once). - - upd_flag | isPAP env rhs = ReEntrant - | otherwise = Updatable - --- Detect thunks which will reduce immediately to PAPs, and make them --- non-updatable. This has several advantages: --- --- - the non-updatable thunk behaves exactly like the PAP, --- --- - the thunk is more efficient to enter, because it is --- specialised to the task. --- --- - we save one update frame, one stg_update_PAP, one update --- and lots of PAP_enters. --- --- - in the case where the thunk is top-level, we save building --- a black hole and furthermore the thunk isn't considered to --- be a CAF any more, so it doesn't appear in any SRTs. --- --- We do it here, because the arity information is accurate, and we need --- to do it before the SRT pass to save the SRT entries associated with --- any top-level PAPs. - -isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args - where - arity = stgArity f (lookupBinding env f) -isPAP env _ = False - --} - -{- ToDo: - upd = if isOnceDem dem - then (if isNotTop toplev - then SingleEntry -- HA! Paydirt for "dem" - else - (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $ - Updatable) - else Updatable - -- For now we forbid SingleEntry CAFs; they tickle the - -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, - -- and I don't understand why. There's only one SE_CAF (well, - -- only one that tickled a great gaping bug in an earlier attempt - -- at ClosureInfo.getEntryConvention) in the whole of nofib, - -- specifically Main.lvl6 in spectral/cryptarithm2. - -- So no great loss. KSW 2000-07. --} - --- --------------------------------------------------------------------------- --- A monad for the core-to-STG pass --- --------------------------------------------------------------------------- - --- There's a lot of stuff to pass around, so we use this CtsM --- ("core-to-STG monad") monad to help. All the stuff here is only passed --- *down*. - -newtype CtsM a = CtsM - { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs - -> IdEnv HowBound - -> a - } - deriving (Functor) - -data HowBound - = ImportBound -- Used only as a response to lookupBinding; never - -- exists in the range of the (IdEnv HowBound) - - | LetBound -- A let(rec) in this module - LetInfo -- Whether top level or nested - Arity -- Its arity (local Ids don't have arity info at this point) - - | LambdaBound -- Used for both lambda and case - deriving (Eq) - -data LetInfo - = TopLet -- top level things - | NestedLet - deriving (Eq) - --- For a let(rec)-bound variable, x, we record LiveInfo, the set of --- variables that are live if x is live. This LiveInfo comprises --- (a) dynamic live variables (ones with a non-top-level binding) --- (b) static live variabes (CAFs or things that refer to CAFs) --- --- For "normal" variables (a) is just x alone. If x is a let-no-escaped --- variable then x is represented by a code pointer and a stack pointer --- (well, one for each stack). So all of the variables needed in the --- execution of x are live if x is, and are therefore recorded in the --- LetBound constructor; x itself *is* included. --- --- The set of dynamic live variables is guaranteed ot have no further --- let-no-escaped variables in it. - --- The std monad functions: - -initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a -initCts dflags env m = unCtsM m dflags env - - - -{-# INLINE thenCts #-} -{-# INLINE returnCts #-} - -returnCts :: a -> CtsM a -returnCts e = CtsM $ \_ _ -> e - -thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b -thenCts m k = CtsM $ \dflags env - -> unCtsM (k (unCtsM m dflags env)) dflags env - -instance Applicative CtsM where - pure = returnCts - (<*>) = ap - -instance Monad CtsM where - (>>=) = thenCts - -instance HasDynFlags CtsM where - getDynFlags = CtsM $ \dflags _ -> dflags - --- Functions specific to this monad: - -extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a -extendVarEnvCts ids_w_howbound expr - = CtsM $ \dflags env - -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound) - -lookupVarCts :: Id -> CtsM HowBound -lookupVarCts v = CtsM $ \_ env -> lookupBinding env v - -lookupBinding :: IdEnv HowBound -> Id -> HowBound -lookupBinding env v = case lookupVarEnv env v of - Just xx -> xx - Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound - -getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) -getAllCAFsCC this_mod = - let - span = mkGeneralSrcSpan (mkFastString "") -- XXX do better - all_cafs_cc = mkAllCafsCC this_mod span - all_cafs_ccs = mkSingletonCCS all_cafs_cc - in - (all_cafs_cc, all_cafs_ccs) - --- Misc. - -filterStgBinders :: [Var] -> [Var] -filterStgBinders bndrs = filter isId bndrs - -myCollectBinders :: Expr Var -> ([Var], Expr Var) -myCollectBinders expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs (Cast e _) = go bs e - go bs e = (reverse bs, e) - --- | Precondition: argument expression is an 'App', and there is a 'Var' at the --- head of the 'App' chain. -myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) -myCollectArgs expr - = go expr [] [] - where - go (Var v) as ts = (v, as, ts) - go (App f a) as ts = go f (a:as) ts - go (Tick t e) as ts = ASSERT( all isTypeArg as ) - go e as (t:ts) -- ticks can appear in type apps - go (Cast e _) as ts = go e as ts - go (Lam b e) as ts - | isTyVar b = go e as ts -- Note [Collect args] - go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - --- Note [Collect args] --- ~~~~~~~~~~~~~~~~~~~ --- --- This big-lambda case occurred following a rather obscure eta expansion. --- It all seems a bit yukky to me. - -stgArity :: Id -> HowBound -> Arity -stgArity _ (LetBound _ arity) = arity -stgArity f ImportBound = idArity f -stgArity _ LambdaBound = 0 diff --git a/stgSyn/StgFVs.hs b/stgSyn/StgFVs.hs deleted file mode 100644 --- a/stgSyn/StgFVs.hs +++ /dev/null @@ -1,130 +0,0 @@ --- | Free variable analysis on STG terms. -module StgFVs ( - annTopBindingsFreeVars, - annBindingFreeVars - ) where - -import GhcPrelude - -import StgSyn -import Id -import VarSet -import CoreSyn ( Tickish(Breakpoint) ) -import Outputable -import Util - -import Data.Maybe ( mapMaybe ) - -newtype Env - = Env - { locals :: IdSet - } - -emptyEnv :: Env -emptyEnv = Env emptyVarSet - -addLocals :: [Id] -> Env -> Env -addLocals bndrs env - = env { locals = extendVarSetList (locals env) bndrs } - --- | Annotates a top-level STG binding group with its free variables. -annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding] -annTopBindingsFreeVars = map go - where - go (StgTopStringLit id bs) = StgTopStringLit id bs - go (StgTopLifted bind) - = StgTopLifted (annBindingFreeVars bind) - --- | Annotates an STG binding with its free variables. -annBindingFreeVars :: StgBinding -> CgStgBinding -annBindingFreeVars = fst . binding emptyEnv emptyDVarSet - -boundIds :: StgBinding -> [Id] -boundIds (StgNonRec b _) = [b] -boundIds (StgRec pairs) = map fst pairs - --- Note [Tracking local binders] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- 'locals' contains non-toplevel, non-imported binders. --- We maintain the set in 'expr', 'alt' and 'rhs', which are the only --- places where new local binders are introduced. --- Why do it there rather than in 'binding'? Two reasons: --- --- 1. We call 'binding' from 'annTopBindingsFreeVars', which would --- add top-level bindings to the 'locals' set. --- 2. In the let(-no-escape) case, we need to extend the environment --- prior to analysing the body, but we also need the fvs from the --- body to analyse the RHSs. No way to do this without some --- knot-tying. - --- | This makes sure that only local, non-global free vars make it into the set. -mkFreeVarSet :: Env -> [Id] -> DIdSet -mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env) - -args :: Env -> [StgArg] -> DIdSet -args env = mkFreeVarSet env . mapMaybe f - where - f (StgVarArg occ) = Just occ - f _ = Nothing - -binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet) -binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs) - where - -- See Note [Tacking local binders] - (r', rhs_fvs) = rhs env r - fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs -binding env body_fv (StgRec pairs) = (StgRec pairs', fvs) - where - -- See Note [Tacking local binders] - bndrs = map fst pairs - (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs - pairs' = zip bndrs rhss - fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs - -expr :: Env -> StgExpr -> (CgStgExpr, DIdSet) -expr env = go - where - go (StgApp occ as) - = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ])) - go (StgLit lit) = (StgLit lit, emptyDVarSet) - go (StgConApp dc as tys) = (StgConApp dc as tys, args env as) - go (StgOpApp op as ty) = (StgOpApp op as ty, args env as) - go StgLam{} = pprPanic "StgFVs: StgLam" empty - go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) - where - (scrut', scrut_fvs) = go scrut - -- See Note [Tacking local binders] - (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts - alt_fvs = unionDVarSets alt_fvss - fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr - go (StgLet ext bind body) = go_bind (StgLet ext) bind body - go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body - go (StgTick tick e) = (StgTick tick e', fvs') - where - (e', fvs) = go e - fvs' = unionDVarSet (tickish tick) fvs - tickish (Breakpoint _ ids) = mkDVarSet ids - tickish _ = emptyDVarSet - - go_bind dc bind body = (dc bind' body', fvs) - where - -- See Note [Tacking local binders] - env' = addLocals (boundIds bind) env - (body', body_fvs) = expr env' body - (bind', fvs) = binding env' body_fvs bind - -rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet) -rhs env (StgRhsClosure _ ccs uf bndrs body) - = (StgRhsClosure fvs ccs uf bndrs body', fvs) - where - -- See Note [Tacking local binders] - (body', body_fvs) = expr (addLocals bndrs env) body - fvs = delDVarSetList body_fvs bndrs -rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as) - -alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) -alt env (con, bndrs, e) = ((con, bndrs, e'), fvs) - where - -- See Note [Tacking local binders] - (e', rhs_fvs) = expr (addLocals bndrs env) e - fvs = delDVarSetList rhs_fvs bndrs diff --git a/stgSyn/StgLint.hs b/stgSyn/StgLint.hs deleted file mode 100644 --- a/stgSyn/StgLint.hs +++ /dev/null @@ -1,396 +0,0 @@ -{- | -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -A lint pass to check basic STG invariants: - -- Variables should be defined before used. - -- Let bindings should not have unboxed types (unboxed bindings should only - appear in case), except when they're join points (see Note [CoreSyn let/app - invariant] and #14117). - -- If linting after unarisation, invariants listed in Note [Post-unarisation - invariants]. - -Because we don't have types and coercions in STG we can't really check types -here. - -Some history: - -StgLint used to check types, but it never worked and so it was disabled in 2000 -with this note: - - WARNING: - ~~~~~~~~ - - This module has suffered bit-rot; it is likely to yield lint errors - for Stg code that is currently perfectly acceptable for code - generation. Solution: don't use it! (KSW 2000-05). - -Since then there were some attempts at enabling it again, as summarised in -#14787. It's finally decided that we remove all type checking and only look for -basic properties listed above. --} - -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, - DeriveFunctor #-} - -module StgLint ( lintStgTopBindings ) where - -import GhcPrelude - -import StgSyn - -import DynFlags -import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) -import BasicTypes ( TopLevelFlag(..), isTopLevel ) -import CostCentre ( isCurrentCCS ) -import Id ( Id, idType, isJoinId, idName ) -import VarSet -import DataCon -import CoreSyn ( AltCon(..) ) -import Name ( getSrcLoc, nameIsLocalOrFrom ) -import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) -import Type -import RepType -import SrcLoc -import Outputable -import Module ( Module ) -import qualified ErrUtils as Err -import Control.Applicative ((<|>)) -import Control.Monad - -lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) - => DynFlags - -> Module -- ^ module being compiled - -> Bool -- ^ have we run Unarise yet? - -> String -- ^ who produced the STG? - -> [GenStgTopBinding a] - -> IO () - -lintStgTopBindings dflags this_mod unarised whodunnit binds - = {-# SCC "StgLint" #-} - case initL this_mod unarised top_level_binds (lint_binds binds) of - Nothing -> - return () - Just msg -> do - putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (vcat [ text "*** Stg Lint ErrMsgs: in" <+> - text whodunnit <+> text "***", - msg, - text "*** Offending Program ***", - pprGenStgTopBindings binds, - text "*** End of Offense ***"]) - Err.ghcExit dflags 1 - where - -- Bring all top-level binds into scope because CoreToStg does not generate - -- bindings in dependency order (so we may see a use before its definition). - top_level_binds = mkVarSet (bindersOfTopBinds binds) - - lint_binds :: [GenStgTopBinding a] -> LintM () - - lint_binds [] = return () - lint_binds (bind:binds) = do - binders <- lint_bind bind - addInScopeVars binders $ - lint_binds binds - - lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind - lint_bind (StgTopStringLit v _) = return [v] - -lintStgArg :: StgArg -> LintM () -lintStgArg (StgLitArg _) = return () -lintStgArg (StgVarArg v) = lintStgVar v - -lintStgVar :: Id -> LintM () -lintStgVar id = checkInScope id - -lintStgBinds - :: (OutputablePass a, BinderP a ~ Id) - => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders -lintStgBinds top_lvl (StgNonRec binder rhs) = do - lint_binds_help top_lvl (binder,rhs) - return [binder] - -lintStgBinds top_lvl (StgRec pairs) - = addInScopeVars binders $ do - mapM_ (lint_binds_help top_lvl) pairs - return binders - where - binders = [b | (b,_) <- pairs] - -lint_binds_help - :: (OutputablePass a, BinderP a ~ Id) - => TopLevelFlag - -> (Id, GenStgRhs a) - -> LintM () -lint_binds_help top_lvl (binder, rhs) - = addLoc (RhsOf binder) $ do - when (isTopLevel top_lvl) (checkNoCurrentCCS rhs) - lintStgRhs rhs - -- Check binder doesn't have unlifted type or it's a join point - checkL (isJoinId binder || not (isUnliftedType (idType binder))) - (mkUnliftedTyMsg binder rhs) - --- | Top-level bindings can't inherit the cost centre stack from their --- (static) allocation site. -checkNoCurrentCCS - :: (OutputablePass a, BinderP a ~ Id) - => GenStgRhs a - -> LintM () -checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _) - | isCurrentCCS ccs - = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs) -checkNoCurrentCCS rhs@(StgRhsCon ccs _ _) - | isCurrentCCS ccs - = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs) -checkNoCurrentCCS _ - = return () - -lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () - -lintStgRhs (StgRhsClosure _ _ _ [] expr) - = lintStgExpr expr - -lintStgRhs (StgRhsClosure _ _ _ binders expr) - = addLoc (LambdaBodyOf binders) $ - addInScopeVars binders $ - lintStgExpr expr - -lintStgRhs rhs@(StgRhsCon _ con args) = do - when (isUnboxedTupleCon con || isUnboxedSumCon con) $ - addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ - ppr rhs) - mapM_ lintStgArg args - mapM_ checkPostUnariseConArg args - -lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM () - -lintStgExpr (StgLit _) = return () - -lintStgExpr (StgApp fun args) = do - lintStgVar fun - mapM_ lintStgArg args - -lintStgExpr app@(StgConApp con args _arg_tys) = do - -- unboxed sums should vanish during unarise - lf <- getLintFlags - when (lf_unarised lf && isUnboxedSumCon con) $ - addErrL (text "Unboxed sum after unarise:" $$ - ppr app) - mapM_ lintStgArg args - mapM_ checkPostUnariseConArg args - -lintStgExpr (StgOpApp _ args _) = - mapM_ lintStgArg args - -lintStgExpr lam@(StgLam _ _) = - addErrL (text "Unexpected StgLam" <+> ppr lam) - -lintStgExpr (StgLet _ binds body) = do - binders <- lintStgBinds NotTopLevel binds - addLoc (BodyOfLetRec binders) $ - addInScopeVars binders $ - lintStgExpr body - -lintStgExpr (StgLetNoEscape _ binds body) = do - binders <- lintStgBinds NotTopLevel binds - addLoc (BodyOfLetRec binders) $ - addInScopeVars binders $ - lintStgExpr body - -lintStgExpr (StgTick _ expr) = lintStgExpr expr - -lintStgExpr (StgCase scrut bndr alts_type alts) = do - lintStgExpr scrut - - lf <- getLintFlags - let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf) - - addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts) - -lintAlt - :: (OutputablePass a, BinderP a ~ Id) - => (AltCon, [Id], GenStgExpr a) -> LintM () - -lintAlt (DEFAULT, _, rhs) = - lintStgExpr rhs - -lintAlt (LitAlt _, _, rhs) = - lintStgExpr rhs - -lintAlt (DataAlt _, bndrs, rhs) = do - mapM_ checkPostUnariseBndr bndrs - addInScopeVars bndrs (lintStgExpr rhs) - -{- -************************************************************************ -* * -Utilities -* * -************************************************************************ --} - -bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] -bindersOf (StgNonRec binder _) = [binder] -bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] - -bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] -bindersOfTop (StgTopLifted bind) = bindersOf bind -bindersOfTop (StgTopStringLit binder _) = [binder] - -bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] -bindersOfTopBinds = foldr ((++) . bindersOfTop) [] - -{- -************************************************************************ -* * -The Lint monad -* * -************************************************************************ --} - -newtype LintM a = LintM - { unLintM :: Module - -> LintFlags - -> [LintLocInfo] -- Locations - -> IdSet -- Local vars in scope - -> Bag MsgDoc -- Error messages so far - -> (a, Bag MsgDoc) -- Result and error messages (if any) - } - deriving (Functor) - -data LintFlags = LintFlags { lf_unarised :: !Bool - -- ^ have we run the unariser yet? - } - -data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf [Id] -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders - -dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) -dumpLoc (RhsOf v) = - (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' ) -dumpLoc (LambdaBodyOf bs) = - (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) - -dumpLoc (BodyOfLetRec bs) = - (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' ) - - -pp_binders :: [Id] -> SDoc -pp_binders bs - = sep (punctuate comma (map pp_binder bs)) - where - pp_binder b - = hsep [ppr b, dcolon, ppr (idType b)] - -initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc -initL this_mod unarised locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag - if isEmptyBag errs then - Nothing - else - Just (vcat (punctuate blankLine (bagToList errs))) - -instance Applicative LintM where - pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs) - (<*>) = ap - (*>) = thenL_ - -instance Monad LintM where - (>>=) = thenL - (>>) = (*>) - -thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf loc scope errs - -> case unLintM m mod lf loc scope errs of - (r, errs') -> unLintM (k r) mod lf loc scope errs' - -thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf loc scope errs - -> case unLintM m mod lf loc scope errs of - (_, errs') -> unLintM k mod lf loc scope errs' - -checkL :: Bool -> MsgDoc -> LintM () -checkL True _ = return () -checkL False msg = addErrL msg - --- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders. -checkPostUnariseBndr :: Id -> LintM () -checkPostUnariseBndr bndr = do - lf <- getLintFlags - when (lf_unarised lf) $ - forM_ (checkPostUnariseId bndr) $ \unexpected -> - addErrL $ - text "After unarisation, binder " <> - ppr bndr <> text " has " <> text unexpected <> text " type " <> - ppr (idType bndr) - --- Arguments shouldn't have sum, tuple, or void types. -checkPostUnariseConArg :: StgArg -> LintM () -checkPostUnariseConArg arg = case arg of - StgLitArg _ -> - return () - StgVarArg id -> do - lf <- getLintFlags - when (lf_unarised lf) $ - forM_ (checkPostUnariseId id) $ \unexpected -> - addErrL $ - text "After unarisation, arg " <> - ppr id <> text " has " <> text unexpected <> text " type " <> - ppr (idType id) - --- Post-unarisation args and case alt binders should not have unboxed tuple, --- unboxed sum, or void types. Return what the binder is if it is one of these. -checkPostUnariseId :: Id -> Maybe String -checkPostUnariseId id = - let - id_ty = idType id - is_sum, is_tuple, is_void :: Maybe String - is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum" - is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple" - is_void = guard (isVoidTy id_ty) >> return "void" - in - is_sum <|> is_tuple <|> is_void - -addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc) - -addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc -addErr errs_so_far msg locs - = errs_so_far `snocBag` mk_msg locs - where - mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage SevWarning l (hdr $$ msg) - mk_msg [] = msg - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf loc scope errs - -> unLintM m mod lf (extra_loc:loc) scope errs - -addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf loc scope errs - -> let - new_set = mkVarSet ids - in unLintM m mod lf loc (scope `unionVarSet` new_set) errs - -getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs) - -checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf loc scope errs - -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then - ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id), - text "is out of scope"]) loc) - else - ((), errs) - -mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc -mkUnliftedTyMsg binder rhs - = (text "Let(rec) binder" <+> quotes (ppr binder) <+> - text "has unlifted type" <+> quotes (ppr (idType binder))) - $$ - (text "RHS:" <+> ppr rhs) diff --git a/stgSyn/StgSubst.hs b/stgSyn/StgSubst.hs deleted file mode 100644 --- a/stgSyn/StgSubst.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE CPP #-} - -module StgSubst where - -#include "HsVersions.h" - -import GhcPrelude - -import Id -import VarEnv -import Control.Monad.Trans.State.Strict -import Outputable -import Util - --- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not --- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but --- with the domain being 'Id's instead of entire 'CoreExpr'. -data Subst = Subst InScopeSet IdSubstEnv - -type IdSubstEnv = IdEnv Id - --- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@ -emptySubst :: Subst -emptySubst = mkEmptySubst emptyInScopeSet - --- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet' --- are in scope. -mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv - --- | Substitutes an 'Id' for another one according to the 'Subst' given in a way --- that avoids shadowing the 'InScopeSet', returning the result and an updated --- 'Subst' that should be used by subsequent substitutions. -substBndr :: Id -> Subst -> (Id, Subst) -substBndr id (Subst in_scope env) - = (new_id, Subst new_in_scope new_env) - where - new_id = uniqAway in_scope id - no_change = new_id == id -- in case nothing shadowed - new_in_scope = in_scope `extendInScopeSet` new_id - new_env - | no_change = delVarEnv env id - | otherwise = extendVarEnv env id new_id - --- | @substBndrs = runState . traverse (state . substBndr)@ -substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst) -substBndrs = runState . traverse (state . substBndr) - --- | Substitutes an occurrence of an identifier for its counterpart recorded --- in the 'Subst'. -lookupIdSubst :: HasCallStack => Id -> Subst -> Id -lookupIdSubst id (Subst in_scope env) - | not (isLocalId id) = id - | Just id' <- lookupVarEnv env id = id' - | Just id' <- lookupInScope in_scope id = id' - | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope) - id - --- | Substitutes an occurrence of an identifier for its counterpart recorded --- in the 'Subst'. Does not generate a debug warning if the identifier to --- to substitute wasn't in scope. -noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id -noWarnLookupIdSubst id (Subst in_scope env) - | not (isLocalId id) = id - | Just id' <- lookupVarEnv env id = id' - | Just id' <- lookupInScope in_scope id = id' - | otherwise = id - --- | Add the 'Id' to the in-scope set and remove any existing substitutions for --- it. -extendInScope :: Id -> Subst -> Subst -extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env - --- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the --- in-scope set is such that TyCoSubst Note [The substitution invariant] --- holds after extending the substitution like this. -extendSubst :: Id -> Id -> Subst -> Subst -extendSubst id new_id (Subst in_scope env) - = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope ) - Subst in_scope (extendVarEnv env id new_id) diff --git a/stgSyn/StgSyn.hs b/stgSyn/StgSyn.hs deleted file mode 100644 --- a/stgSyn/StgSyn.hs +++ /dev/null @@ -1,871 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Shared term graph (STG) syntax for spineless-tagless code generation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This data type represents programs just before code generation (conversion to -@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style -being one that happens to be ideally suited to spineless tagless code -generation. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} - -module StgSyn ( - StgArg(..), - - GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), - GenStgAlt, AltType(..), - - StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, - NoExtFieldSilent, noExtFieldSilent, - OutputablePass, - - UpdateFlag(..), isUpdatable, - - -- a set of synonyms for the vanilla parameterisation - StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, - - -- a set of synonyms for the code gen parameterisation - CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt, - - -- a set of synonyms for the lambda lifting parameterisation - LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, - - -- a set of synonyms to distinguish in- and out variants - InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt, - OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, - - -- StgOp - StgOp(..), - - -- utils - topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, - isDllConApp, - stgArgType, - stripStgTicksTop, stripStgTicksTopE, - stgCaseBndrInScope, - - pprStgBinding, pprGenStgTopBindings, pprStgTopBindings - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn ( AltCon, Tickish ) -import CostCentre ( CostCentreStack ) -import Data.ByteString ( ByteString ) -import Data.Data ( Data ) -import Data.List ( intersperse ) -import DataCon -import DynFlags -import ForeignCall ( ForeignCall ) -import Id -import IdInfo ( mayHaveCafRefs ) -import VarSet -import Literal ( Literal, literalType ) -import Module ( Module ) -import Outputable -import Packages ( isDllName ) -import GHC.Platform -import PprCore ( {- instances -} ) -import PrimOp ( PrimOp, PrimCall ) -import TyCon ( PrimRep(..), TyCon ) -import Type ( Type ) -import RepType ( typePrimRep1 ) -import Util - -import Data.List.NonEmpty ( NonEmpty, toList ) - -{- -************************************************************************ -* * -GenStgBinding -* * -************************************************************************ - -As usual, expressions are interesting; other things are boring. Here are the -boring things (except note the @GenStgRhs@), parameterised with respect to -binder and occurrence information (just as in @CoreSyn@): --} - --- | A top-level binding. -data GenStgTopBinding pass --- See Note [CoreSyn top-level string literals] - = StgTopLifted (GenStgBinding pass) - | StgTopStringLit Id ByteString - -data GenStgBinding pass - = StgNonRec (BinderP pass) (GenStgRhs pass) - | StgRec [(BinderP pass, GenStgRhs pass)] - -{- -************************************************************************ -* * -StgArg -* * -************************************************************************ --} - -data StgArg - = StgVarArg Id - | StgLitArg Literal - --- | Does this constructor application refer to anything in a different --- *Windows* DLL? --- If so, we can't allocate it statically -isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool -isDllConApp dflags this_mod con args - | platformOS (targetPlatform dflags) == OSMinGW32 - = isDllName dflags this_mod (dataConName con) || any is_dll_arg args - | otherwise = False - where - -- NB: typePrimRep1 is legit because any free variables won't have - -- unlifted type (there are no unlifted things at top level) - is_dll_arg :: StgArg -> Bool - is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v)) - && isDllName dflags this_mod (idName v) - is_dll_arg _ = False - --- True of machine addresses; these are the things that don't work across DLLs. --- The key point here is that VoidRep comes out False, so that a top level --- nullary GADT constructor is False for isDllConApp --- --- data T a where --- T1 :: T Int --- --- gives --- --- T1 :: forall a. (a~Int) -> T a --- --- and hence the top-level binding --- --- $WT1 :: T Int --- $WT1 = T1 Int (Coercion (Refl Int)) --- --- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep LiftedRep = True -isAddrRep UnliftedRep = True -isAddrRep _ = False - --- | Type of an @StgArg@ --- --- Very half baked because we have lost the type arguments. -stgArgType :: StgArg -> Type -stgArgType (StgVarArg v) = idType v -stgArgType (StgLitArg lit) = literalType lit - - --- | Strip ticks of a given type from an STG expression. -stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) -stripStgTicksTop p = go [] - where go ts (StgTick t e) | p t = go (t:ts) e - go ts other = (reverse ts, other) - --- | Strip ticks of a given type from an STG expression returning only the expression. -stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p -stripStgTicksTopE p = go - where go (StgTick t e) | p t = go e - go other = other - --- | Given an alt type and whether the program is unarised, return whether the --- case binder is in scope. --- --- Case binders of unboxed tuple or unboxed sum type always dead after the --- unariser has run. See Note [Post-unarisation invariants]. -stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool -stgCaseBndrInScope alt_ty unarised = - case alt_ty of - AlgAlt _ -> True - PrimAlt _ -> True - MultiValAlt _ -> not unarised - PolyAlt -> True - -{- -************************************************************************ -* * -STG expressions -* * -************************************************************************ - -The @GenStgExpr@ data type is parameterised on binder and occurrence info, as -before. - -************************************************************************ -* * -GenStgExpr -* * -************************************************************************ - -An application is of a function to a list of atoms (not expressions). -Operationally, we want to push the arguments on the stack and call the function. -(If the arguments were expressions, we would have to build their closures -first.) - -There is no constructor for a lone variable; it would appear as @StgApp var []@. --} - -data GenStgExpr pass - = StgApp - Id -- function - [StgArg] -- arguments; may be empty - -{- -************************************************************************ -* * -StgConApp and StgPrimApp --- saturated applications -* * -************************************************************************ - -There are specialised forms of application, for constructors, primitives, and -literals. --} - - | StgLit Literal - - -- StgConApp is vital for returning unboxed tuples or sums - -- which can't be let-bound - | StgConApp DataCon - [StgArg] -- Saturated - [Type] -- See Note [Types in StgConApp] in UnariseStg - - | StgOpApp StgOp -- Primitive op or foreign call - [StgArg] -- Saturated. - Type -- Result type - -- We need to know this so that we can - -- assign result registers - -{- -************************************************************************ -* * -StgLam -* * -************************************************************************ - -StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it -encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension -to GenStgExpr à la TTG. --} - - | StgLam - (NonEmpty (BinderP pass)) - StgExpr -- Body of lambda - -{- -************************************************************************ -* * -GenStgExpr: case-expressions -* * -************************************************************************ - -This has the same boxed/unboxed business as Core case expressions. --} - - | StgCase - (GenStgExpr pass) -- the thing to examine - (BinderP pass) -- binds the result of evaluating the scrutinee - AltType - [GenStgAlt pass] - -- The DEFAULT case is always *first* - -- if it is there at all - -{- -************************************************************************ -* * -GenStgExpr: let(rec)-expressions -* * -************************************************************************ - -The various forms of let(rec)-expression encode most of the interesting things -we want to do. - -- let-closure x = [free-vars] [args] expr in e - - is equivalent to - - let x = (\free-vars -> \args -> expr) free-vars - - @args@ may be empty (and is for most closures). It isn't under circumstances - like this: - - let x = (\y -> y+z) - - This gets mangled to - - let-closure x = [z] [y] (y+z) - - The idea is that we compile code for @(y+z)@ in an environment in which @z@ is - bound to an offset from Node, and `y` is bound to an offset from the stack - pointer. - - (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) - -- let-constructor x = Constructor [args] in e - - (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) - -- Letrec-expressions are essentially the same deal as let-closure/ - let-constructor, so we use a common structure and distinguish between them - with an @is_recursive@ boolean flag. - -- let-unboxed u = in e - - All the stuff on the RHS must be fully evaluated. No function calls either! - - (We've backed away from this toward case-expressions with suitably-magical - alts ...) - -- Advanced stuff here! Not to start with, but makes pattern matching generate - more efficient code. - - let-escapes-not fail = expr - in e' - - Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, - or pass it to another function. All @e'@ will ever do is tail-call @fail@. - Rather than build a closure for @fail@, all we need do is to record the stack - level at the moment of the @let-escapes-not@; then entering @fail@ is just a - matter of adjusting the stack pointer back down to that point and entering the - code for it. - - Another example: - - f x y = let z = huge-expression in - if y==1 then z else - if y==2 then z else - 1 - - (A let-escapes-not is an @StgLetNoEscape@.) - -- We may eventually want: - - let-literal x = Literal in e - -And so the code for let(rec)-things: --} - - | StgLet - (XLet pass) - (GenStgBinding pass) -- right hand sides (see below) - (GenStgExpr pass) -- body - - | StgLetNoEscape - (XLetNoEscape pass) - (GenStgBinding pass) -- right hand sides (see below) - (GenStgExpr pass) -- body - -{- -************************************************************************* -* * -GenStgExpr: hpc, scc and other debug annotations -* * -************************************************************************* - -Finally for @hpc@ expressions we introduce a new STG construct. --} - - | StgTick - (Tickish Id) - (GenStgExpr pass) -- sub expression - --- END of GenStgExpr - -{- -************************************************************************ -* * -STG right-hand sides -* * -************************************************************************ - -Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for -closures: --} - -data GenStgRhs pass - = StgRhsClosure - (XRhsClosure pass) -- ^ Extension point for non-global free var - -- list just before 'CodeGen'. - CostCentreStack -- ^ CCS to be attached (default is CurrentCCS) - !UpdateFlag -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry' - [BinderP pass] -- ^ arguments; if empty, then not a function; - -- as above, order is important. - (GenStgExpr pass) -- ^ body - -{- -An example may be in order. Consider: - - let t = \x -> \y -> ... x ... y ... p ... q in e - -Pulling out the free vars and stylising somewhat, we get the equivalent: - - let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q - -Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from -@Node@ into the closure, and the code ptr for the closure will be exactly that -in parentheses above. - -The second flavour of right-hand-side is for constructors (simple but -important): --} - - | StgRhsCon - CostCentreStack -- CCS to be attached (default is CurrentCCS). - -- Top-level (static) ones will end up with - -- DontCareCCS, because we don't count static - -- data in heap profiles, and we don't set CCCS - -- from static closure. - DataCon -- Constructor. Never an unboxed tuple or sum, as those - -- are not allocated. - [StgArg] -- Args - --- | Used as a data type index for the stgSyn AST -data StgPass - = Vanilla - | LiftLams - | CodeGen - --- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that --- returns 'empty'. -data NoExtFieldSilent = NoExtFieldSilent - deriving (Data, Eq, Ord) - -instance Outputable NoExtFieldSilent where - ppr _ = empty - --- | Used when constructing a term with an unused extension point that should --- not appear in pretty-printed output at all. -noExtFieldSilent :: NoExtFieldSilent -noExtFieldSilent = NoExtFieldSilent --- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the --- implications on build time... - --- TODO: Do we really want to the extension point type families to have a closed --- domain? -type family BinderP (pass :: StgPass) -type instance BinderP 'Vanilla = Id -type instance BinderP 'CodeGen = Id - -type family XRhsClosure (pass :: StgPass) -type instance XRhsClosure 'Vanilla = NoExtFieldSilent --- | Code gen needs to track non-global free vars -type instance XRhsClosure 'CodeGen = DIdSet - -type family XLet (pass :: StgPass) -type instance XLet 'Vanilla = NoExtFieldSilent -type instance XLet 'CodeGen = NoExtFieldSilent - -type family XLetNoEscape (pass :: StgPass) -type instance XLetNoEscape 'Vanilla = NoExtFieldSilent -type instance XLetNoEscape 'CodeGen = NoExtFieldSilent - -stgRhsArity :: StgRhs -> Int -stgRhsArity (StgRhsClosure _ _ _ bndrs _) - = ASSERT( all isId bndrs ) length bndrs - -- The arity never includes type parameters, but they should have gone by now -stgRhsArity (StgRhsCon _ _ _) = 0 - --- Note [CAF consistency] --- ~~~~~~~~~~~~~~~~~~~~~~ --- --- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in --- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with --- reality. --- --- Specifically, if the RHS mentions any Id that itself is marked --- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the --- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble --- is that `TidyPgm` computed the CAF info on the `Id` but some transformations --- have taken place since then. - -topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool -topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs)) - = topRhsHasCafRefs rhs -topStgBindHasCafRefs (StgTopLifted (StgRec binds)) - = any topRhsHasCafRefs (map snd binds) -topStgBindHasCafRefs StgTopStringLit{} - = False - -topRhsHasCafRefs :: GenStgRhs pass -> Bool -topRhsHasCafRefs (StgRhsClosure _ _ upd _ body) - = -- See Note [CAF consistency] - isUpdatable upd || exprHasCafRefs body -topRhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -exprHasCafRefs :: GenStgExpr pass -> Bool -exprHasCafRefs (StgApp f args) - = stgIdHasCafRefs f || any stgArgHasCafRefs args -exprHasCafRefs StgLit{} - = False -exprHasCafRefs (StgConApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgOpApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgLam _ body) - = exprHasCafRefs body -exprHasCafRefs (StgCase scrt _ _ alts) - = exprHasCafRefs scrt || any altHasCafRefs alts -exprHasCafRefs (StgLet _ bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgLetNoEscape _ bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgTick _ expr) - = exprHasCafRefs expr - -bindHasCafRefs :: GenStgBinding pass -> Bool -bindHasCafRefs (StgNonRec _ rhs) - = rhsHasCafRefs rhs -bindHasCafRefs (StgRec binds) - = any rhsHasCafRefs (map snd binds) - -rhsHasCafRefs :: GenStgRhs pass -> Bool -rhsHasCafRefs (StgRhsClosure _ _ _ _ body) - = exprHasCafRefs body -rhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -altHasCafRefs :: GenStgAlt pass -> Bool -altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs - -stgArgHasCafRefs :: StgArg -> Bool -stgArgHasCafRefs (StgVarArg id) - = stgIdHasCafRefs id -stgArgHasCafRefs _ - = False - -stgIdHasCafRefs :: Id -> Bool -stgIdHasCafRefs id = - -- We are looking for occurrences of an Id that is bound at top level, and may - -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether - -- imported or defined in this module) are GlobalIds, so the test is easy. - isGlobalId id && mayHaveCafRefs (idCafInfo id) - -{- -************************************************************************ -* * -STG case alternatives -* * -************************************************************************ - -Very like in @CoreSyntax@ (except no type-world stuff). - -The type constructor is guaranteed not to be abstract; that is, we can see its -representation. This is important because the code generator uses it to -determine return conventions etc. But it's not trivial where there's a module -loop involved, because some versions of a type constructor might not have all -the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets -the TyCon from the constructors or literals (which are guaranteed to have the -Real McCoy) rather than from the scrutinee type. --} - -type GenStgAlt pass - = (AltCon, -- alts: data constructor, - [BinderP pass], -- constructor's parameters, - GenStgExpr pass) -- ...right-hand side. - -data AltType - = PolyAlt -- Polymorphic (a lifted type variable) - | MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum) - -- the arity could indeed be 1 for unary unboxed tuple - -- or enum-like unboxed sums - | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts - | PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts - -{- -************************************************************************ -* * -The Plain STG parameterisation -* * -************************************************************************ - -This happens to be the only one we use at the moment. --} - -type StgTopBinding = GenStgTopBinding 'Vanilla -type StgBinding = GenStgBinding 'Vanilla -type StgExpr = GenStgExpr 'Vanilla -type StgRhs = GenStgRhs 'Vanilla -type StgAlt = GenStgAlt 'Vanilla - -type LlStgTopBinding = GenStgTopBinding 'LiftLams -type LlStgBinding = GenStgBinding 'LiftLams -type LlStgExpr = GenStgExpr 'LiftLams -type LlStgRhs = GenStgRhs 'LiftLams -type LlStgAlt = GenStgAlt 'LiftLams - -type CgStgTopBinding = GenStgTopBinding 'CodeGen -type CgStgBinding = GenStgBinding 'CodeGen -type CgStgExpr = GenStgExpr 'CodeGen -type CgStgRhs = GenStgRhs 'CodeGen -type CgStgAlt = GenStgAlt 'CodeGen - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the substitution has been applied. - See CoreSyn for precedence in Core land --} - -type InStgTopBinding = StgTopBinding -type InStgBinding = StgBinding -type InStgArg = StgArg -type InStgExpr = StgExpr -type InStgRhs = StgRhs -type InStgAlt = StgAlt -type OutStgTopBinding = StgTopBinding -type OutStgBinding = StgBinding -type OutStgArg = StgArg -type OutStgExpr = StgExpr -type OutStgRhs = StgRhs -type OutStgAlt = StgAlt - -{- - -************************************************************************ -* * -UpdateFlag -* * -************************************************************************ - -This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. - -A @ReEntrant@ closure may be entered multiple times, but should not be updated -or blackholed. An @Updatable@ closure should be updated after evaluation (and -may be blackholed during evaluation). A @SingleEntry@ closure will only be -entered once, and so need not be updated but may safely be blackholed. --} - -data UpdateFlag = ReEntrant | Updatable | SingleEntry - -instance Outputable UpdateFlag where - ppr u = char $ case u of - ReEntrant -> 'r' - Updatable -> 'u' - SingleEntry -> 's' - -isUpdatable :: UpdateFlag -> Bool -isUpdatable ReEntrant = False -isUpdatable SingleEntry = False -isUpdatable Updatable = True - -{- -************************************************************************ -* * -StgOp -* * -************************************************************************ - -An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful -to move these around together, notably in StgOpApp and COpStmt. --} - -data StgOp - = StgPrimOp PrimOp - - | StgPrimCallOp PrimCall - - | StgFCallOp ForeignCall Type - -- The Type, which is obtained from the foreign import declaration - -- itself, is needed by the stg-to-cmm pass to determine the offset to - -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note - -- [Unlifted boxed arguments to foreign calls] - -{- -************************************************************************ -* * -Pretty-printing -* * -************************************************************************ - -Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he -likes terminators instead... Ditto for case alternatives. --} - -type OutputablePass pass = - ( Outputable (XLet pass) - , Outputable (XLetNoEscape pass) - , Outputable (XRhsClosure pass) - , OutputableBndr (BinderP pass) - ) - -pprGenStgTopBinding - :: OutputablePass pass => GenStgTopBinding pass -> SDoc -pprGenStgTopBinding (StgTopStringLit bndr str) - = hang (hsep [pprBndr LetBind bndr, equals]) - 4 (pprHsBytes str <> semi) -pprGenStgTopBinding (StgTopLifted bind) - = pprGenStgBinding bind - -pprGenStgBinding - :: OutputablePass pass => GenStgBinding pass -> SDoc - -pprGenStgBinding (StgNonRec bndr rhs) - = hang (hsep [pprBndr LetBind bndr, equals]) - 4 (ppr rhs <> semi) - -pprGenStgBinding (StgRec pairs) - = vcat [ text "Rec {" - , vcat (intersperse blankLine (map ppr_bind pairs)) - , text "end Rec }" ] - where - ppr_bind (bndr, expr) - = hang (hsep [pprBndr LetBind bndr, equals]) - 4 (ppr expr <> semi) - -pprGenStgTopBindings - :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc -pprGenStgTopBindings binds - = vcat $ intersperse blankLine (map pprGenStgTopBinding binds) - -pprStgBinding :: StgBinding -> SDoc -pprStgBinding = pprGenStgBinding - -pprStgTopBindings :: [StgTopBinding] -> SDoc -pprStgTopBindings = pprGenStgTopBindings - -instance Outputable StgArg where - ppr = pprStgArg - -instance OutputablePass pass => Outputable (GenStgTopBinding pass) where - ppr = pprGenStgTopBinding - -instance OutputablePass pass => Outputable (GenStgBinding pass) where - ppr = pprGenStgBinding - -instance OutputablePass pass => Outputable (GenStgExpr pass) where - ppr = pprStgExpr - -instance OutputablePass pass => Outputable (GenStgRhs pass) where - ppr rhs = pprStgRhs rhs - -pprStgArg :: StgArg -> SDoc -pprStgArg (StgVarArg var) = ppr var -pprStgArg (StgLitArg con) = ppr con - -pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc --- special case -pprStgExpr (StgLit lit) = ppr lit - --- general case -pprStgExpr (StgApp func args) - = hang (ppr func) 4 (sep (map (ppr) args)) - -pprStgExpr (StgConApp con args _) - = hsep [ ppr con, brackets (interppSP args) ] - -pprStgExpr (StgOpApp op args _) - = hsep [ pprStgOp op, brackets (interppSP args)] - -pprStgExpr (StgLam bndrs body) - = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs)) - <+> text "->", - pprStgExpr body ] - where ppr_list = brackets . fsep . punctuate comma - --- special case: let v = --- in --- let ... --- in --- ... --- --- Very special! Suspicious! (SLPJ) - -{- -pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) - expr@(StgLet _ _)) - = ($$) - (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "), - ppr cc, - pp_binder_info bi, - text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"), - ppr upd_flag, text " [", - interppSP args, char ']']) - 8 (sep [hsep [ppr rhs, text "} in"]])) - (ppr expr) --} - --- special case: let ... in let ... - -pprStgExpr (StgLet ext bind expr@StgLet{}) - = ($$) - (sep [hang (text "let" <+> ppr ext <+> text "{") - 2 (hsep [pprGenStgBinding bind, text "} in"])]) - (ppr expr) - --- general case -pprStgExpr (StgLet ext bind expr) - = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind), - hang (text "} in ") 2 (ppr expr)] - -pprStgExpr (StgLetNoEscape ext bind expr) - = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{") - 2 (pprGenStgBinding bind), - hang (text "} in ") - 2 (ppr expr)] - -pprStgExpr (StgTick tickish expr) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressTicks dflags - then pprStgExpr expr - else sep [ ppr tickish, pprStgExpr expr ] - - --- Don't indent for a single case alternative. -pprStgExpr (StgCase expr bndr alt_type [alt]) - = sep [sep [text "case", - nest 4 (hsep [pprStgExpr expr, - whenPprDebug (dcolon <+> ppr alt_type)]), - text "of", pprBndr CaseBind bndr, char '{'], - pprStgAlt False alt, - char '}'] - -pprStgExpr (StgCase expr bndr alt_type alts) - = sep [sep [text "case", - nest 4 (hsep [pprStgExpr expr, - whenPprDebug (dcolon <+> ppr alt_type)]), - text "of", pprBndr CaseBind bndr, char '{'], - nest 2 (vcat (map (pprStgAlt True) alts)), - char '}'] - - -pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc -pprStgAlt indent (con, params, expr) - | indent = hang altPattern 4 (ppr expr <> semi) - | otherwise = sep [altPattern, ppr expr <> semi] - where - altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"]) - - -pprStgOp :: StgOp -> SDoc -pprStgOp (StgPrimOp op) = ppr op -pprStgOp (StgPrimCallOp op)= ppr op -pprStgOp (StgFCallOp op _) = ppr op - -instance Outputable AltType where - ppr PolyAlt = text "Polymorphic" - ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n - ppr (AlgAlt tc) = text "Alg" <+> ppr tc - ppr (PrimAlt tc) = text "Prim" <+> ppr tc - -pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc - -pprStgRhs (StgRhsClosure ext cc upd_flag args body) - = sdocWithDynFlags $ \dflags -> - hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, - if not $ gopt Opt_SuppressStgExts dflags - then ppr ext else empty, - char '\\' <> ppr upd_flag, brackets (interppSP args)]) - 4 (ppr body) - -pprStgRhs (StgRhsCon cc con args) - = hcat [ ppr cc, - space, ppr con, text "! ", brackets (interppSP args)] diff --git a/stranal/DmdAnal.hs b/stranal/DmdAnal.hs deleted file mode 100644 --- a/stranal/DmdAnal.hs +++ /dev/null @@ -1,1586 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - - ----------------- - A demand analysis - ----------------- --} - -{-# LANGUAGE CPP #-} - -module DmdAnal ( dmdAnalProgram ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import WwLib ( findTypeShape, deepSplitProductType_maybe ) -import Demand -- All of it -import CoreSyn -import CoreSeq ( seqBinds ) -import Outputable -import VarEnv -import BasicTypes -import Data.List ( mapAccumL, sortBy ) -import DataCon -import Id -import CoreUtils ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation ) -import TyCon -import Type -import Coercion ( Coercion, coVarsOfCo ) -import FamInstEnv -import Util -import Maybes ( isJust ) -import TysWiredIn -import TysPrim ( realWorldStatePrimTy ) -import ErrUtils ( dumpIfSet_dyn ) -import Name ( getName, stableNameCmp ) -import Data.Function ( on ) -import UniqSet - -{- -************************************************************************ -* * -\subsection{Top level stuff} -* * -************************************************************************ --} - -dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -dmdAnalProgram dflags fam_envs binds - = do { - let { binds_plus_dmds = do_prog binds } ; - dumpIfSet_dyn dflags Opt_D_dump_str_signatures - "Strictness signatures" $ - dumpStrSig binds_plus_dmds ; - -- See Note [Stamp out space leaks in demand analysis] - seqBinds binds_plus_dmds `seq` return binds_plus_dmds - } - where - do_prog :: CoreProgram -> CoreProgram - do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds - --- Analyse a (group of) top-level binding(s) -dmdAnalTopBind :: AnalEnv - -> CoreBind - -> (AnalEnv, CoreBind) -dmdAnalTopBind env (NonRec id rhs) - = (extendAnalEnv TopLevel env id2 (idStrictness id2), NonRec id2 rhs2) - where - ( _, _, rhs1) = dmdAnalRhsLetDown TopLevel Nothing env cleanEvalDmd id rhs - ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin env) cleanEvalDmd id rhs1 - -- Do two passes to improve CPR information - -- See Note [CPR for thunks] - -- See Note [Optimistic CPR in the "virgin" case] - -- See Note [Initial CPR for strict binders] - -dmdAnalTopBind env (Rec pairs) - = (env', Rec pairs') - where - (env', _, pairs') = dmdFix TopLevel env cleanEvalDmd pairs - -- We get two iterations automatically - -- c.f. the NonRec case above - -{- Note [Stamp out space leaks in demand analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand analysis pass outputs a new copy of the Core program in -which binders have been annotated with demand and strictness -information. It's tiresome to ensure that this information is fully -evaluated everywhere that we produce it, so we just run a single -seqBinds over the output before returning it, to ensure that there are -no references holding on to the input Core program. - -This makes a ~30% reduction in peak memory usage when compiling -DynFlags (cf #9675 and #13426). - -This is particularly important when we are doing late demand analysis, -since we don't do a seqBinds at any point thereafter. Hence code -generation would hold on to an extra copy of the Core program, via -unforced thunks in demand or strictness information; and it is the -most memory-intensive part of the compilation process, so this added -seqBinds makes a big difference in peak memory usage. --} - - -{- -************************************************************************ -* * -\subsection{The analyser itself} -* * -************************************************************************ - -Note [Ensure demand is strict] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important not to analyse e with a lazy demand because -a) When we encounter case s of (a,b) -> - we demand s with U(d1d2)... but if the overall demand is lazy - that is wrong, and we'd need to reduce the demand on s, - which is inconvenient -b) More important, consider - f (let x = R in x+x), where f is lazy - We still want to mark x as demanded, because it will be when we - enter the let. If we analyse f's arg with a Lazy demand, we'll - just mark x as Lazy -c) The application rule wouldn't be right either - Evaluating (f x) in a L demand does *not* cause - evaluation of f in a C(L) demand! --} - --- If e is complicated enough to become a thunk, its contents will be evaluated --- at most once, so oneify it. -dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand -dmdTransformThunkDmd e - | exprIsTrivial e = id - | otherwise = oneifyDmd - --- Do not process absent demands --- Otherwise act like in a normal demand analysis --- See ↦* relation in the Cardinality Analysis paper -dmdAnalStar :: AnalEnv - -> Demand -- This one takes a *Demand* - -> CoreExpr -- Should obey the let/app invariatn - -> (BothDmdArg, CoreExpr) -dmdAnalStar env dmd e - | (dmd_shell, cd) <- toCleanDmd dmd - , (dmd_ty, e') <- dmdAnal env cd e - = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) - -- The argument 'e' should satisfy the let/app invariant - -- See Note [Analysing with absent demand] in Demand.hs - (postProcessDmdType dmd_shell dmd_ty, e') - --- Main Demand Analsysis machinery -dmdAnal, dmdAnal' :: AnalEnv - -> CleanDemand -- The main one takes a *CleanDemand* - -> CoreExpr -> (DmdType, CoreExpr) - --- The CleanDemand is always strict and not absent --- See Note [Ensure demand is strict] - -dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ - dmdAnal' env d e - -dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) -dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = (unitDmdType (coercionDmdEnv co), Coercion co) - -dmdAnal' env dmd (Var var) - = (dmdTransform env var dmd, Var var) - -dmdAnal' env dmd (Cast e co) - = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co) - where - (dmd_ty, e') = dmdAnal env dmd e - -dmdAnal' env dmd (Tick t e) - = (dmd_ty, Tick t e') - where - (dmd_ty, e') = dmdAnal env dmd e - -dmdAnal' env dmd (App fun (Type ty)) - = (fun_ty, App fun' (Type ty)) - where - (fun_ty, fun') = dmdAnal env dmd fun - --- Lots of the other code is there to make this --- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCallDmd dmd - (fun_ty, fun') = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg - in --- pprTrace "dmdAnal:app" (vcat --- [ text "dmd =" <+> ppr dmd --- , text "expr =" <+> ppr (App fun arg) --- , text "fun dmd_ty =" <+> ppr fun_ty --- , text "arg dmd =" <+> ppr arg_dmd --- , text "arg dmd_ty =" <+> ppr arg_ty --- , text "res dmd_ty =" <+> ppr res_ty --- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) - (res_ty `bothDmdType` arg_ty, App fun' arg') - -dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - (body_ty, body') = dmdAnal env dmd body - in - (body_ty, Lam var body') - - | otherwise - = let (body_dmd, defer_and_use) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - env' = extendSigsWithLam env var - (body_ty, body') = dmdAnal env' body_dmd body - (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var - in - (postProcessUnsat defer_and_use lam_ty, Lam var' body') - -dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) - -- Only one alternative with a product constructor - | let tycon = dataConTyCon dc - , isJust (isDataProductTyCon_maybe tycon) - , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon - = let - env_w_tc = env { ae_rec_tc = rec_tc' } - env_alt = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs - (rhs_ty, rhs') = dmdAnal env_alt dmd rhs - (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs - (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds - alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2 - | otherwise = alt_ty2 - - -- Compute demand on the scrutinee - -- See Note [Demand on scrutinee of a product case] - scrut_dmd = mkProdDmd id_dmds - (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut - res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty - case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - bndrs' = setBndrsDemandInfo bndrs id_dmds - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --- , text "dmd" <+> ppr dmd --- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') --- , text "id_dmds" <+> ppr id_dmds --- , text "scrut_dmd" <+> ppr scrut_dmd --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')]) - -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts - (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut - (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr - -- NB: Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives - res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_tys" <+> ppr alt_tys --- , text "alt_ty" <+> ppr alt_ty --- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty alts') - --- Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- The following case handle the up variant. --- --- It is very simple. For let x = rhs in body --- * Demand-analyse 'body' in the current environment --- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' --- * Demand-analyse 'rhs' in 'rhs_dmd' --- --- This is used for a non-recursive local let without manifest lambdas. --- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnal' env dmd (Let (NonRec id rhs) body) - | useLetUp id - = (final_ty, Let (NonRec id' rhs') body') - where - (body_ty, body') = dmdAnal env dmd body - (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id - id' = setIdDemandInfo id id_dmd - - (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs - final_ty = body_ty' `bothDmdType` rhs_ty - -dmdAnal' env dmd (Let (NonRec id rhs) body) - = (body_ty2, Let (NonRec id2 rhs') body') - where - (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env dmd id rhs - env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1) - (body_ty, body') = dmdAnal env1 dmd body - (body_ty1, id2) = annotateBndr env body_ty id1 - body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] - - -- If the actual demand is better than the vanilla call - -- demand, you might think that we might do better to re-analyse - -- the RHS with the stronger demand. - -- But (a) That seldom happens, because it means that *every* path in - -- the body of the let has to use that stronger demand - -- (b) It often happens temporarily in when fixpointing, because - -- the recursive function at first seems to place a massive demand. - -- But we don't want to go to extra work when the function will - -- probably iterate to something less demanding. - -- In practice, all the times the actual demand on id2 is more than - -- the vanilla call demand seem to be due to (b). So we don't - -- bother to re-analyse the RHS. - -dmdAnal' env dmd (Let (Rec pairs) body) - = let - (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs - (body_ty, body') = dmdAnal env' dmd body - body_ty1 = deleteFVs body_ty (map fst pairs) - body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] - in - body_ty2 `seq` - (body_ty2, Let (Rec pairs') body') - -io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool --- See Note [IO hack in the demand analyser] -io_hack_reqd scrut con bndrs - | (bndr:_) <- bndrs - , con == tupleDataCon Unboxed 2 - , idType bndr `eqType` realWorldStatePrimTy - , (fun, _) <- collectArgs scrut - = case fun of - Var f -> not (isPrimOpId f) - _ -> True - | otherwise - = False - -dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) -dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) - | null bndrs -- Literals, DEFAULT, and nullary constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs - = (rhs_ty, (con, [], rhs')) - - | otherwise -- Non-nullary data constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs - , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs - , let case_bndr_dmd = findIdDemand alt_ty case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds - = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) - - -{- Note [IO hack in the demand analyser] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a hack here for I/O operations. Consider - - case foo x s of { (# s', r #) -> y } - -Is this strict in 'y'? Often not! If foo x s performs some observable action -(including raising an exception with raiseIO#, modifying a mutable variable, or -even ending the program normally), then we must not force 'y' (which may fail -to terminate) until we have performed foo x s. - -Hackish solution: spot the IO-like situation and add a virtual branch, -as if we had - case foo x s of - (# s, r #) -> y - other -> return () -So the 'y' isn't necessarily going to be evaluated - -A more complete example (#148, #1592) where this shows up is: - do { let len = ; - ; when (...) (exitWith ExitSuccess) - ; print len } - -However, consider - f x s = case getMaskingState# s of - (# s, r #) -> - case x of I# x2 -> ... - -Here it is terribly sad to make 'f' lazy in 's'. After all, -getMaskingState# is not going to diverge or throw an exception! This -situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle -(on an MVar not an Int), and made a material difference. - -So if the scrutinee is a primop call, we *don't* apply the -state hack: - - If it is a simple, terminating one like getMaskingState, - applying the hack is over-conservative. - - If the primop is raise# then it returns bottom, so - the case alternatives are already discarded. - - If the primop can raise a non-IO exception, like - divide by zero or seg-fault (eg writing an array - out of bounds) then we don't mind evaluating 'x' first. - -Note [Demand on the scrutinee of a product case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When figuring out the demand on the scrutinee of a product case, -we use the demands of the case alternative, i.e. id_dmds. -But note that these include the demand on the case binder; -see Note [Demand on case-alternative binders] in Demand.hs. -This is crucial. Example: - f x = case x of y { (a,b) -> k y a } -If we just take scrut_demand = U(L,A), then we won't pass x to the -worker, so the worker will rebuild - x = (a, absent-error) -and that'll crash. - -Note [Aggregated demand for cardinality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use different strategies for strictness and usage/cardinality to -"unleash" demands captured on free variables by bindings. Let us -consider the example: - -f1 y = let {-# NOINLINE h #-} - h = y - in (h, h) - -We are interested in obtaining cardinality demand U1 on |y|, as it is -used only in a thunk, and, therefore, is not going to be updated any -more. Therefore, the demand on |y|, captured and unleashed by usage of -|h| is U1. However, if we unleash this demand every time |h| is used, -and then sum up the effects, the ultimate demand on |y| will be U1 + -U1 = U. In order to avoid it, we *first* collect the aggregate demand -on |h| in the body of let-expression, and only then apply the demand -transformer: - -transf[x](U) = {y |-> U1} - -so the resulting demand on |y| is U1. - -The situation is, however, different for strictness, where this -aggregating approach exhibits worse results because of the nature of -|both| operation for strictness. Consider the example: - -f y c = - let h x = y |seq| x - in case of - True -> h True - False -> y - -It is clear that |f| is strict in |y|, however, the suggested analysis -will infer from the body of |let| that |h| is used lazily (as it is -used in one branch only), therefore lazy demand will be put on its -free variable |y|. Conversely, if the demand on |h| is unleashed right -on the spot, we will get the desired result, namely, that |f| is -strict in |y|. - - -************************************************************************ -* * - Demand transformer -* * -************************************************************************ --} - -dmdTransform :: AnalEnv -- The strictness environment - -> Id -- The function - -> CleanDemand -- The demand on the function - -> DmdType -- The demand type of the function in this context - -- Returned DmdEnv includes the demand on - -- this function plus demand on its free variables - -dmdTransform env var dmd - | isDataConWorkId var -- Data constructor - = dmdTransformDataConSig (idArity var) (idStrictness var) dmd - - | gopt Opt_DmdTxDictSel (ae_dflags env), - Just _ <- isClassOpId_maybe var -- Dictionary component selector - = dmdTransformDictSelSig (idStrictness var) dmd - - | isGlobalId var -- Imported function - = let res = dmdTransformSig (idStrictness var) dmd in --- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) - res - - | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing - , let fn_ty = dmdTransformSig sig dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ - if isTopLevel top_lvl - then fn_ty -- Don't record top level things - else addVarDmd fn_ty var (mkOnceUsedDmd dmd) - - | otherwise -- Local non-letrec-bound thing - = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) - -{- -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - --- Recursive bindings -dmdFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding - -> CleanDemand - -> [(Id,CoreExpr)] - -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info - -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs - where - bndrs = map fst orig_pairs - - -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs - - -- If fixed-point iteration does not yield a result we use this instead - -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - abort = (env, lazy_fv', zapped_pairs) - where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) - -- Note [Lazy and unleashable free variables] - non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' - lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs - zapped_pairs = zapIdStrictness pairs' - - -- The fixed-point varies the idStrictness field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - loop n pairs - | found_fixpoint = (final_anal_env, lazy_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' - where - found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs - first_round = n == 1 - (lazy_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) - step first_round pairs = (lazy_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) - - ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, lazy_fv) (id,rhs) - = ((env', lazy_fv'), (id', rhs')) - where - (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env let_dmd id rhs - lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 - env' = extendAnalEnv top_lvl env id (idStrictness id') - - - zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] - -{- -Note [Safe abortion in the fixed-point iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Fixed-point iteration may fail to terminate. But we cannot simply give up and -return the environment and code unchanged! We still need to do one additional -round, for two reasons: - - * To get information on used free variables (both lazy and strict!) - (see Note [Lazy and unleashable free variables]) - * To ensure that all expressions have been traversed at least once, and any left-over - strictness annotations have been updated. - -This final iteration does not add the variables to the strictness signature -environment, which effectively assigns them 'nopSig' (see "getStrictness") - --} - --- Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- dmdAnalRhsLetDown implements the Down variant: --- * assuming a demand of --- * looking at the definition --- * determining a strictness signature --- --- It is used for toplevel definition, recursive definitions and local --- non-recursive definitions that have manifest lambdas. --- Local non-recursive definitions without a lambda are handled with LetUp. --- --- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalRhsLetDown :: TopLevelFlag - -> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive - -> AnalEnv -> CleanDemand - -> Id -> CoreExpr - -> (DmdEnv, Id, CoreExpr) --- Process the RHS of the binding, add the strictness signature --- to the Id, and augment the environment with the signature as well. -dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs - = (lazy_fv, id', rhs') - where - rhs_arity = idArity id - rhs_dmd - -- See Note [Demand analysis for join points] - -- See Note [Invariants on join points] invariant 2b, in CoreSyn - -- rhs_arity matches the join arity of the join point - | isJoinId id - = mkCallDmds rhs_arity let_dmd - | otherwise - -- NB: rhs_arity - -- See Note [Demand signatures are computed for a threshold demand based on idArity] - = mkRhsDmd env rhs_arity rhs - (DmdType rhs_fv rhs_dmds rhs_res, rhs') - = dmdAnal env rhs_dmd rhs - sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res') - id' = set_idStrictness env id sig - -- See Note [NOINLINE and strictness] - - - -- See Note [Aggregated demand for cardinality] - rhs_fv1 = case rec_flag of - Just bs -> reuseEnv (delVarEnvList rhs_fv bs) - Nothing -> rhs_fv - - -- See Note [Lazy and unleashable free variables] - (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 - - rhs_res' = trimCPRInfo trim_all trim_sums rhs_res - trim_all = is_thunk && not_strict - trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types] - - -- See Note [CPR for thunks] - is_thunk = not (exprIsHNF rhs) && not (isJoinId id) - not_strict - = isTopLevel top_lvl -- Top level and recursive things don't - || isJust rec_flag -- get their demandInfo set at all - || not (isStrictDmd (idDemandInfo id) || ae_virgin env) - -- See Note [Optimistic CPR in the "virgin" case] - --- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for --- unleashing on the given function's @rhs@, by creating a call demand of --- @rhs_arity@ with a body demand appropriate for possible product types. --- See Note [Product demands for function body]. --- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a --- clean usage demand of @C1(C1(U(U,U)))@. -mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand -mkRhsDmd env rhs_arity rhs = - case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of - Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss)) - _ -> mkCallDmds rhs_arity cleanEvalDmd - --- | If given the let-bound 'Id', 'useLetUp' determines whether we should --- process the binding up (body before rhs) or down (rhs before body). --- --- We use LetDown if there is a chance to get a useful strictness signature to --- unleash at call sites. LetDown is generally more precise than LetUp if we can --- correctly guess how it will be used in the body, that is, for which incoming --- demand the strictness signature should be computed, which allows us to --- unleash higher-order demands on arguments at call sites. This is mostly the --- case when --- --- * The binding takes any arguments before performing meaningful work (cf. --- 'idArity'), in which case we are interested to see how it uses them. --- * The binding is a join point, hence acting like a function, not a value. --- As a big plus, we know *precisely* how it will be used in the body; since --- it's always tail-called, we can directly unleash the incoming demand of --- the let binding on its RHS when computing a strictness signature. See --- [Demand analysis for join points]. --- --- Thus, if the binding is not a join point and its arity is 0, we have a thunk --- and use LetUp, implying that we have no usable demand signature available --- when we analyse the let body. --- --- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free --- vars at most once, regardless of how many times it was forced in the body. --- This makes a real difference wrt. usage demands. The other reason is being --- able to unleash a more precise product demand on its RHS once we know how the --- thunk was used in the let body. --- --- Characteristic examples, always assuming a single evaluation: --- --- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that --- the expression uses @y@ at most once. --- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that --- @b@ is absent. --- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that --- the expression uses @y@ strictly, because we have @f@'s demand signature --- available at the call site. --- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => --- LetDown. Compared to LetUp, we find out that the expression uses @y@ --- strictly, because we can unleash @exit@'s signature at each call site. --- * For a more convincing example with join points, see Note [Demand analysis --- for join points]. --- -useLetUp :: Var -> Bool -useLetUp f = idArity f == 0 && not (isJoinId f) - -{- Note [Demand analysis for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - g :: (Int,Int) -> Int - g (p,q) = p+q - - f :: T -> Int -> Int - f x p = g (join j y = (p,y) - in case x of - A -> j 3 - B -> j 4 - C -> (p,7)) - -If j was a vanilla function definition, we'd analyse its body with -evalDmd, and think that it was lazy in p. But for join points we can -do better! We know that j's body will (if called at all) be evaluated -with the demand that consumes the entire join-binding, in this case -the argument demand from g. Whizzo! g evaluates both components of -its argument pair, so p will certainly be evaluated if j is called. - -For f to be strict in p, we need /all/ paths to evaluate p; in this -case the C branch does so too, so we are fine. So, as usual, we need -to transport demands on free variables to the call site(s). Compare -Note [Lazy and unleashable free variables]. - -The implementation is easy. When analysing a join point, we can -analyse its body with the demand from the entire join-binding (written -let_dmd here). - -Another win for join points! #13543. - -However, note that the strictness signature for a join point can -look a little puzzling. E.g. - - (join j x = \y. error "urk") - (in case v of ) - ( A -> j 3 ) x - ( B -> j 4 ) - ( C -> \y. blah ) - -The entire thing is in a C(S) context, so j's strictness signature -will be [A]b -meaning one absent argument, returns bottom. That seems odd because -there's a \y inside. But it's right because when consumed in a C(1) -context the RHS of the join point is indeed bottom. - -Note [Demand signatures are computed for a threshold demand based on idArity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute demand signatures assuming idArity incoming arguments to approximate -behavior for when we have a call site with at least that many arguments. idArity -is /at least/ the number of manifest lambdas, but might be higher for PAPs and -trivial RHS (see Note [Demand analysis for trivial right-hand sides]). - -Because idArity of a function varies independently of its cardinality properties -(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode -the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' -(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to -unleash a demand signature when the incoming number of arguments is less than -that. See Note [What are demand signatures?] for more details on soundness. - -Why idArity arguments? Because that's a conservative estimate of how many -arguments we must feed a function before it does anything interesting with them. -Also it elegantly subsumes the trivial RHS and PAP case. - -There might be functions for which we might want to analyse for more incoming -arguments than idArity. Example: - - f x = - if expensive - then \y -> ... y ... - else \y -> ... y ... - -We'd analyse `f` under a unary call demand C(S), corresponding to idArity -being 1. That's enough to look under the manifest lambda and find out how a -unary call would use `x`, but not enough to look into the lambdas in the if -branches. - -On the other hand, if we analysed for call demand C(C(S)), we'd get useful -strictness info for `y` (and more precise info on `x`) and possibly CPR -information, but - - * We would no longer be able to unleash the signature at unary call sites - * Performing the worker/wrapper split based on this information would be - implicitly eta-expanding `f`, playing fast and loose with divergence and - even being unsound in the presence of newtypes, so we refrain from doing so. - Also see Note [Don't eta expand in w/w] in WorkWrap. - -Since we only compute one signature, we do so for arity 1. Computing multiple -signatures for different arities (i.e., polyvariance) would be entirely -possible, if it weren't for the additional runtime and implementation -complexity. - -Note [idArity varies independently of dmdTypeDepth] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to check in CoreLint that dmdTypeDepth <= idArity for a let-bound -identifier. But that means we would have to zap demand signatures every time we -reset or decrease arity. That's an unnecessary dependency, because - - * The demand signature captures a semantic property that is independent of - what the binding's current arity is - * idArity is analysis information itself, thus volatile - * We already *have* dmdTypeDepth, wo why not just use it to encode the - threshold for when to unleash the signature - (cf. Note [Understanding DmdType and StrictSig] in Demand) - -Consider the following expression, for example: - - (let go x y = `x` seq ... in go) |> co - -`go` might have a strictness signature of ``. The simplifier will identify -`go` as a nullary join point through `joinPointBinding_maybe` and float the -coercion into the binding, leading to an arity decrease: - - join go = (\x y -> `x` seq ...) |> co in go - -With the CoreLint check, we would have to zap `go`'s perfectly viable strictness -signature. - -Note [What are demand signatures?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand analysis interprets expressions in the abstract domain of demand -transformers. Given an incoming demand we put an expression under, its abstract -transformer gives us back a demand type denoting how other things (like -arguments and free vars) were used when the expression was evaluated. -Here's an example: - - f x y = - if x + expensive - then \z -> z + y * ... - else \z -> z * ... - -The abstract transformer (let's call it F_e) of the if expression (let's call it -e) would transform an incoming head demand into a demand type like -{x->,y->}. In pictures: - - Demand ---F_e---> DmdType - {x->,y->} - -Let's assume that the demand transformers we compute for an expression are -correct wrt. to some concrete semantics for Core. How do demand signatures fit -in? They are strange beasts, given that they come with strict rules when to -it's sound to unleash them. - -Fortunately, we can formalise the rules with Galois connections. Consider -f's strictness signature, {}. It's a single-point approximation of -the actual abstract transformer of f's RHS for arity 2. So, what happens is that -we abstract *once more* from the abstract domain we already are in, replacing -the incoming Demand by a simple lattice with two elements denoting incoming -arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom -element). Here's the diagram: - - A_2 -----f_f----> DmdType - ^ | - | α γ | - | v - Demand ---F_f---> DmdType - -With - α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness - α(_) = <2 - γ(ty) = ty -and F_f being the abstract transformer of f's RHS and f_f being the abstracted -abstract transformer computable from our demand signature simply by - - f_f(>=2) = {} - f_f(<2) = postProcessUnsat {} - -where postProcessUnsat makes a proper top element out of the given demand type. - -Note [Demand analysis for trivial right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo = plusInt |> co -where plusInt is an arity-2 function with known strictness. Clearly -we want plusInt's strictness to propagate to foo! But because it has -no manifest lambdas, it won't do so automatically, and indeed 'co' might -have type (Int->Int->Int) ~ T. - -Fortunately, CoreArity gives 'foo' arity 2, which is enough for LetDown to -forward plusInt's demand signature, and all is well (see Note [Newtype arity] in -CoreArity)! A small example is the test case NewtypeArity. - - -Note [Product demands for function body] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This example comes from shootout/binary_trees: - - Main.check' = \ b z ds. case z of z' { I# ip -> - case ds_d13s of - Main.Nil -> z' - Main.Node s14k s14l s14m -> - Main.check' (not b) - (Main.check' b - (case b { - False -> I# (-# s14h s14k); - True -> I# (+# s14h s14k) - }) - s14l) - s14m } } } - -Here we *really* want to unbox z, even though it appears to be used boxed in -the Nil case. Partly the Nil case is not a hot path. But more specifically, -the whole function gets the CPR property if we do. - -So for the demand on the body of a RHS we use a product demand if it's -a product type. - -************************************************************************ -* * -\subsection{Strictness signatures and types} -* * -************************************************************************ --} - -unitDmdType :: DmdEnv -> DmdType -unitDmdType dmd_env = DmdType dmd_env [] topRes - -coercionDmdEnv :: Coercion -> DmdEnv -coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) - -- The VarSet from coVarsOfCo is really a VarEnv Var - -addVarDmd :: DmdType -> Var -> Demand -> DmdType -addVarDmd (DmdType fv ds res) var dmd - = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res - -addLazyFVs :: DmdType -> DmdEnv -> DmdType -addLazyFVs dmd_ty lazy_fvs - = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs - -- Using bothDmdType (rather than just both'ing the envs) - -- is vital. Consider - -- let f = \x -> (x,y) - -- in error (f 3) - -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L - -- demand with the bottom coming up from 'error' - -- - -- I got a loop in the fixpointer without this, due to an interaction - -- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was - -- letrec f n x - -- = letrec g y = x `fatbar` - -- letrec h z = z + ...g... - -- in h (f (n-1) x) - -- in ... - -- In the initial iteration for f, f=Bot - -- Suppose h is found to be strict in z, but the occurrence of g in its RHS - -- is lazy. Now consider the fixpoint iteration for g, esp the demands it - -- places on its free variables. Suppose it places none. Then the - -- x `fatbar` ...call to h... - -- will give a x->V demand for x. That turns into a L demand for x, - -- which floats out of the defn for h. Without the modifyEnv, that - -- L demand doesn't get both'd with the Bot coming up from the inner - -- call to f. So we just get an L demand for x for g. - -{- -Note [Do not strictify the argument dictionaries of a dfun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker can tie recursive knots involving dfuns, so we do the -conservative thing and refrain from strictifying a dfun's argument -dictionaries. --} - -setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) (d:ds) - | isTyVar b = b : setBndrsDemandInfo bs (d:ds) - | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds -setBndrsDemandInfo [] ds = ASSERT( null ds ) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) --- The returned env has the var deleted --- The returned var is annotated with demand info --- according to the result demand of the provided demand type --- No effect on the argument demands -annotateBndr env dmd_ty var - | isId var = (dmd_ty', setIdDemandInfo var dmd) - | otherwise = (dmd_ty, var) - where - (dmd_ty', dmd) = findBndrDmd env False dmd_ty var - -annotateLamIdBndr :: AnalEnv - -> DFunFlag -- is this lambda at the top of the RHS of a dfun? - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> (DmdType, -- Demand type of lambda - Id) -- and binder annotated with demand - -annotateLamIdBndr env arg_of_dfun dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = ASSERT( isId id ) - -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ - (final_ty, setIdDemandInfo id dmd) - where - -- Watch out! See note [Lambda-bound unfoldings] - final_ty = case maybeUnfoldingTemplate (idUnfolding id) of - Nothing -> main_ty - Just unf -> main_ty `bothDmdType` unf_ty - where - (unf_ty, _) = dmdAnalStar env dmd unf - - main_ty = addDemand dmd dmd_ty' - (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id - -deleteFVs :: DmdType -> [Var] -> DmdType -deleteFVs (DmdType fvs dmds res) bndrs - = DmdType (delVarEnvList fvs bndrs) dmds res - -{- -Note [CPR for sum types] -~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we do not do CPR for let-bindings that - * non-top level - * bind a sum type -Reason: I found that in some benchmarks we were losing let-no-escapes, -which messed it all up. Example - let j = \x. .... - in case y of - True -> j False - False -> j True -If we w/w this we get - let j' = \x. .... - in case y of - True -> case j' False of { (# a #) -> Just a } - False -> case j' True of { (# a #) -> Just a } -Notice that j' is not a let-no-escape any more. - -However this means in turn that the *enclosing* function -may be CPR'd (via the returned Justs). But in the case of -sums, there may be Nothing alternatives; and that messes -up the sum-type CPR. - -Conclusion: only do this for products. It's still not -guaranteed OK for products, but sums definitely lose sometimes. - -Note [CPR for thunks] -~~~~~~~~~~~~~~~~~~~~~ -If the rhs is a thunk, we usually forget the CPR info, because -it is presumably shared (else it would have been inlined, and -so we'd lose sharing if w/w'd it into a function). E.g. - - let r = case expensive of - (a,b) -> (b,a) - in ... - -If we marked r as having the CPR property, then we'd w/w into - - let $wr = \() -> case expensive of - (a,b) -> (# b, a #) - r = case $wr () of - (# b,a #) -> (b,a) - in ... - -But now r is a thunk, which won't be inlined, so we are no further ahead. -But consider - - f x = let r = case expensive of (a,b) -> (b,a) - in if foo r then r else (x,x) - -Does f have the CPR property? Well, no. - -However, if the strictness analyser has figured out (in a previous -iteration) that it's strict, then we DON'T need to forget the CPR info. -Instead we can retain the CPR info and do the thunk-splitting transform -(see WorkWrap.splitThunk). - -This made a big difference to PrelBase.modInt, which had something like - modInt = \ x -> let r = ... -> I# v in - ...body strict in r... -r's RHS isn't a value yet; but modInt returns r in various branches, so -if r doesn't have the CPR property then neither does modInt -Another case I found in practice (in Complex.magnitude), looks like this: - let k = if ... then I# a else I# b - in ... body strict in k .... -(For this example, it doesn't matter whether k is returned as part of -the overall result; but it does matter that k's RHS has the CPR property.) -Left to itself, the simplifier will make a join point thus: - let $j k = ...body strict in k... - if ... then $j (I# a) else $j (I# b) -With thunk-splitting, we get instead - let $j x = let k = I#x in ...body strict in k... - in if ... then $j a else $j b -This is much better; there's a good chance the I# won't get allocated. - -The difficulty with this is that we need the strictness type to -look at the body... but we now need the body to calculate the demand -on the variable, so we can decide whether its strictness type should -have a CPR in it or not. Simple solution: - a) use strictness info from the previous iteration - b) make sure we do at least 2 iterations, by doing a second - round for top-level non-recs. Top level recs will get at - least 2 iterations except for totally-bottom functions - which aren't very interesting anyway. - -NB: strictly_demanded is never true of a top-level Id, or of a recursive Id. - -Note [Optimistic CPR in the "virgin" case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand and strictness info are initialized by top elements. However, -this prevents from inferring a CPR property in the first pass of the -analyser, so we keep an explicit flag ae_virgin in the AnalEnv -datatype. - -We can't start with 'not-demanded' (i.e., top) because then consider - f x = let - t = ... I# x - in - if ... then t else I# y else f x' - -In the first iteration we'd have no demand info for x, so assume -not-demanded; then we'd get TopRes for f's CPR info. Next iteration -we'd see that t was demanded, and so give it the CPR property, but by -now f has TopRes, so it will stay TopRes. Instead, by checking the -ae_virgin flag at the first time round, we say 'yes t is demanded' the -first time. - -However, this does mean that for non-recursive bindings we must -iterate twice to be sure of not getting over-optimistic CPR info, -in the case where t turns out to be not-demanded. This is handled -by dmdAnalTopBind. - - -Note [NOINLINE and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The strictness analyser used to have a HACK which ensured that NOINLNE -things were not strictness-analysed. The reason was unsafePerformIO. -Left to itself, the strictness analyser would discover this strictness -for unsafePerformIO: - unsafePerformIO: C(U(AV)) -But then consider this sub-expression - unsafePerformIO (\s -> let r = f x in - case writeIORef v r s of (# s1, _ #) -> - (# s1, r #) -The strictness analyser will now find that r is sure to be eval'd, -and may then hoist it out. This makes tests/lib/should_run/memo002 -deadlock. - -Solving this by making all NOINLINE things have no strictness info is overkill. -In particular, it's overkill for runST, which is perfectly respectable. -Consider - f x = runST (return x) -This should be strict in x. - -So the new plan is to define unsafePerformIO using the 'lazy' combinator: - - unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) - -Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is -magically NON-STRICT, and is inlined after strictness analysis. So -unsafePerformIO will look non-strict, and that's what we want. - -Now we don't need the hack in the strictness analyser. HOWEVER, this -decision does mean that even a NOINLINE function is not entirely -opaque: some aspect of its implementation leaks out, notably its -strictness. For example, if you have a function implemented by an -error stub, but which has RULES, you may want it not to be eliminated -in favour of error! - -Note [Lazy and unleashable free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We put the strict and once-used FVs in the DmdType of the Id, so -that at its call sites we unleash demands on its strict fvs. -An example is 'roll' in imaginary/wheel-sieve2 -Something like this: - roll x = letrec - go y = if ... then roll (x-1) else x+1 - in - go ms -We want to see that roll is strict in x, which is because -go is called. So we put the DmdEnv for x in go's DmdType. - -Another example: - - f :: Int -> Int -> Int - f x y = let t = x+1 - h z = if z==0 then t else - if z==1 then x+1 else - x + h (z-1) - in h y - -Calling h does indeed evaluate x, but we can only see -that if we unleash a demand on x at the call site for t. - -Incidentally, here's a place where lambda-lifting h would -lose the cigar --- we couldn't see the joint strictness in t/x - - ON THE OTHER HAND - -We don't want to put *all* the fv's from the RHS into the -DmdType. Because - - * it makes the strictness signatures larger, and hence slows down fixpointing - -and - - * it is useless information at the call site anyways: - For lazy, used-many times fv's we will never get any better result than - that, no matter how good the actual demand on the function at the call site - is (unless it is always absent, but then the whole binder is useless). - -Therefore we exclude lazy multiple-used fv's from the environment in the -DmdType. - -But now the signature lies! (Missing variables are assumed to be absent.) To -make up for this, the code that analyses the binding keeps the demand on those -variable separate (usually called "lazy_fv") and adds it to the demand of the -whole binding later. - -What if we decide _not_ to store a strictness signature for a binding at all, as -we do when aborting a fixed-point iteration? The we risk losing the information -that the strict variables are being used. In that case, we take all free variables -mentioned in the (unsound) strictness signature, conservatively approximate the -demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". - - -Note [Lambda-bound unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow a lambda-bound variable to carry an unfolding, a facility that is used -exclusively for join points; see Note [Case binders and join points]. If so, -we must be careful to demand-analyse the RHS of the unfolding! Example - \x. \y{=Just x}. -Then if uses 'y', then transitively it uses 'x', and we must not -forget that fact, otherwise we might make 'x' absent when it isn't. - - -************************************************************************ -* * -\subsection{Strictness signatures} -* * -************************************************************************ --} - -type DFunFlag = Bool -- indicates if the lambda being considered is in the - -- sequence of lambdas at the top of the RHS of a dfun -notArgOfDfun :: DFunFlag -notArgOfDfun = False - -data AnalEnv - = AE { ae_dflags :: DynFlags - , ae_sigs :: SigEnv - , ae_virgin :: Bool -- True on first iteration only - -- See Note [Initialising strictness] - , ae_rec_tc :: RecTcChecker - , ae_fam_envs :: FamInstEnvs - } - - -- We use the se_env to tell us whether to - -- record info about a variable in the DmdEnv - -- We do so if it's a LocalId, but not top-level - -- - -- The DmdEnv gives the demand on the free vars of the function - -- when it is given enough args to satisfy the strictness signature - -type SigEnv = VarEnv (StrictSig, TopLevelFlag) - -instance Outputable AnalEnv where - ppr (AE { ae_sigs = env, ae_virgin = virgin }) - = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr virgin - , text "ae_sigs =" <+> ppr env ]) - -emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv -emptyAnalEnv dflags fam_envs - = AE { ae_dflags = dflags - , ae_sigs = emptySigEnv - , ae_virgin = True - , ae_rec_tc = initRecTc - , ae_fam_envs = fam_envs - } - -emptySigEnv :: SigEnv -emptySigEnv = emptyVarEnv - --- | Extend an environment with the strictness IDs attached to the id -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } - -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars] - -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv -extendAnalEnv top_lvl env var sig - = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } - -extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv -extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) - -lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) -lookupSigEnv env id = lookupVarEnv (ae_sigs env) id - -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - -extendSigsWithLam :: AnalEnv -> Id -> AnalEnv --- Extend the AnalEnv when we meet a lambda binder -extendSigsWithLam env id - | isId id - , isStrictDmd (idDemandInfo id) || ae_virgin env - -- See Note [Optimistic CPR in the "virgin" case] - -- See Note [Initial CPR for strict binders] - , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id - = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) - - | otherwise - = env - -extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv --- See Note [CPR in a product case alternative] -extendEnvForProdAlt env scrut case_bndr dc bndrs - = foldl' do_con_arg env1 ids_w_strs - where - env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig - - ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc - case_bndr_sig = cprProdSig (dataConRepArity dc) - fam_envs = ae_fam_envs env - - do_con_arg env (id, str) - | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str - , ae_virgin env || (is_var_scrut && is_strict) -- See Note [CPR in a product case alternative] - , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id - = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) - | otherwise - = env - - is_var_scrut = is_var scrut - is_var (Cast e _) = is_var e - is_var (Var v) = isLocalId v - is_var _ = False - -findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) --- Return the demands on the Ids in the [Var] -findBndrsDmds env dmd_ty bndrs - = go dmd_ty bndrs - where - go dmd_ty [] = (dmd_ty, []) - go dmd_ty (b:bs) - | isId b = let (dmd_ty1, dmds) = go dmd_ty bs - (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b - in (dmd_ty2, dmd : dmds) - | otherwise = go dmd_ty bs - -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) --- See Note [Trimming a demand to a type] in Demand.hs -findBndrDmd env arg_of_dfun dmd_ty id - = (dmd_ty', dmd') - where - dmd' = killUsageDemand (ae_dflags env) $ - strictify $ - trimToType starting_dmd (findTypeShape fam_envs id_ty) - - (dmd_ty', starting_dmd) = peelFV dmd_ty id - - id_ty = idType id - - strictify dmd - | gopt Opt_DictsStrict (ae_dflags env) - -- We never want to strictify a recursive let. At the moment - -- annotateBndr is only call for non-recursive lets; if that - -- changes, we need a RecFlag parameter and another guard here. - , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] - = strictifyDictDmd id_ty dmd - | otherwise - = dmd - - fam_envs = ae_fam_envs env - -set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id -set_idStrictness env id sig - = setIdStrictness id (killUsageSig (ae_dflags env) sig) - -dumpStrSig :: CoreProgram -> SDoc -dumpStrSig binds = vcat (map printId ids) - where - ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) - getIds (NonRec i _) = [ i ] - getIds (Rec bs) = map fst bs - printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id) - | otherwise = empty - -{- Note [CPR in a product case alternative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case alternative for a product type, we want to give some of the -binders the CPR property. Specifically - - * The case binder; inside the alternative, the case binder always has - the CPR property, meaning that a case on it will successfully cancel. - Example: - f True x = case x of y { I# x' -> if x' ==# 3 - then y - else I# 8 } - f False x = I# 3 - - By giving 'y' the CPR property, we ensure that 'f' does too, so we get - f b x = case fw b x of { r -> I# r } - fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } - fw False x = 3 - - Of course there is the usual risk of re-boxing: we have 'x' available - boxed and unboxed, but we return the unboxed version for the wrapper to - box. If the wrapper doesn't cancel with its caller, we'll end up - re-boxing something that we did have available in boxed form. - - * Any strict binders with product type, can use - Note [Initial CPR for strict binders]. But we can go a little - further. Consider - - data T = MkT !Int Int - - f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) - | otherwise = x - - For $wf2 we are going to unbox the MkT *and*, since it is strict, the - first argument of the MkT; see Note [Add demands for strict constructors] - in WwLib. But then we don't want box it up again when returning it! We want - 'f2' to have the CPR property, so we give 'x' the CPR property. - - * It's a bit delicate because if this case is scrutinising something other - than an argument the original function, we really don't have the unboxed - version available. E.g - g v = case foo v of - MkT x y | y>0 -> ... - | otherwise -> x - Here we don't have the unboxed 'x' available. Hence the - is_var_scrut test when making use of the strictness annotation. - Slightly ad-hoc, because even if the scrutinee *is* a variable it - might not be a onre of the arguments to the original function, or a - sub-component thereof. But it's simple, and nothing terrible - happens if we get it wrong. e.g. #10694. - - -Note [Initial CPR for strict binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CPR is initialized for a lambda binder in an optimistic manner, i.e, -if the binder is used strictly and at least some of its components as -a product are used, which is checked by the value of the absence -demand. - -If the binder is marked demanded with a strict demand, then give it a -CPR signature. Here's a concrete example ('f1' in test T10482a), -assuming h is strict: - - f1 :: Int -> Int - f1 x = case h x of - A -> x - B -> f1 (x-1) - C -> x+1 - -If we notice that 'x' is used strictly, we can give it the CPR -property; and hence f1 gets the CPR property too. It's sound (doesn't -change strictness) to give it the CPR property because by the time 'x' -is returned (case A above), it'll have been evaluated (by the wrapper -of 'h' in the example). - -Moreover, if f itself is strict in x, then we'll pass x unboxed to -f1, and so the boxed version *won't* be available; in that case it's -very helpful to give 'x' the CPR property. - -Note that - - * We only want to do this for something that definitely - has product type, else we may get over-optimistic CPR results - (e.g. from \x -> x!). - - * See Note [CPR examples] - -Note [CPR examples] -~~~~~~~~~~~~~~~~~~~~ -Here are some examples (stranal/should_compile/T10482a) of the -usefulness of Note [CPR in a product case alternative]. The main -point: all of these functions can have the CPR property. - - ------- f1 ----------- - -- x is used strictly by h, so it'll be available - -- unboxed before it is returned in the True branch - - f1 :: Int -> Int - f1 x = case h x x of - True -> x - False -> f1 (x-1) - - - ------- f2 ----------- - -- x is a strict field of MkT2, so we'll pass it unboxed - -- to $wf2, so it's available unboxed. This depends on - -- the case expression analysing (a subcomponent of) one - -- of the original arguments to the function, so it's - -- a bit more delicate. - - data T2 = MkT2 !Int Int - - f2 :: T2 -> Int - f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) - | otherwise = x - - - ------- f3 ----------- - -- h is strict in x, so x will be unboxed before it - -- is rerturned in the otherwise case. - - data T3 = MkT3 Int Int - - f1 :: T3 -> Int - f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) - | otherwise = x - - - ------- f4 ----------- - -- Just like f2, but MkT4 can't unbox its strict - -- argument automatically, as f2 can - - data family Foo a - newtype instance Foo Int = Foo Int - - data T4 a = MkT4 !(Foo a) Int - - f4 :: T4 Int -> Int - f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) - | otherwise = v - - -Note [Initialising strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See section 9.2 (Finding fixpoints) of the paper. - -Our basic plan is to initialise the strictness of each Id in a -recursive group to "bottom", and find a fixpoint from there. However, -this group B might be inside an *enclosing* recursive group A, in -which case we'll do the entire fixpoint shebang on for each iteration -of A. This can be illustrated by the following example: - -Example: - - f [] = [] - f (x:xs) = let g [] = f xs - g (y:ys) = y+1 : g ys - in g (h x) - -At each iteration of the fixpoint for f, the analyser has to find a -fixpoint for the enclosed function g. In the meantime, the demand -values for g at each iteration for f are *greater* than those we -encountered in the previous iteration for f. Therefore, we can begin -the fixpoint for g not with the bottom value but rather with the -result of the previous analysis. I.e., when beginning the fixpoint -process for g, we can start from the demand signature computed for g -previously and attached to the binding occurrence of g. - -To speed things up, we initialise each iteration of A (the enclosing -one) from the result of the last one, which is neatly recorded in each -binder. That way we make use of earlier iterations of the fixpoint -algorithm. (Cunning plan.) - -But on the *first* iteration we want to *ignore* the current strictness -of the Id, and start from "bottom". Nowadays the Id can have a current -strictness, because interface files record strictness for nested bindings. -To know when we are in the first iteration, we look at the ae_virgin -field of the AnalEnv. - - -Note [Final Demand Analyser run] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the information that the demand analyser determines is not always -preserved by the simplifier. For example, the simplifier will happily rewrite - \y [Demand=1*U] let x = y in x + x -to - \y [Demand=1*U] y + y -which is quite a lie. - -The once-used information is (currently) only used by the code -generator, though. So: - - * We zap the used-once info in the worker-wrapper; - see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's - not reliable, it's better not to have it at all. - - * Just before TidyCore, we add a pass of the demand analyser, - but WITHOUT subsequent worker/wrapper and simplifier, - right before TidyCore. See SimplCore.getCoreToDo. - - This way, correct information finds its way into the module interface - (strictness signatures!) and the code generator (single-entry thunks!) - -Note that, in contrast, the single-call information (C1(..)) /can/ be -relied upon, as the simplifier tends to be very careful about not -duplicating actual function calls. - -Also see #11731. --} diff --git a/stranal/WorkWrap.hs b/stranal/WorkWrap.hs deleted file mode 100644 --- a/stranal/WorkWrap.hs +++ /dev/null @@ -1,760 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} --} - -{-# LANGUAGE CPP #-} -module WorkWrap ( wwTopBinds ) where - -import GhcPrelude - -import CoreArity ( manifestArity ) -import CoreSyn -import CoreUnfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) -import CoreUtils ( exprType, exprIsHNF ) -import CoreFVs ( exprFreeVars ) -import Var -import Id -import IdInfo -import Type -import UniqSupply -import BasicTypes -import DynFlags -import Demand -import WwLib -import Util -import Outputable -import FamInstEnv -import MonadUtils - -#include "HsVersions.h" - -{- -We take Core bindings whose binders have: - -\begin{enumerate} - -\item Strictness attached (by the front-end of the strictness -analyser), and / or - -\item Constructed Product Result information attached by the CPR -analysis pass. - -\end{enumerate} - -and we return some ``plain'' bindings which have been -worker/wrapper-ified, meaning: - -\begin{enumerate} - -\item Functions have been split into workers and wrappers where -appropriate. If a function has both strictness and CPR properties -then only one worker/wrapper doing both transformations is produced; - -\item Binders' @IdInfos@ have been updated to reflect the existence of -these workers/wrappers (this is where we get STRICTNESS and CPR pragma -info for exported values). -\end{enumerate} --} - -wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram - -wwTopBinds dflags fam_envs us top_binds - = initUs_ us $ do - top_binds' <- mapM (wwBind dflags fam_envs) top_binds - return (concat top_binds') - -{- -************************************************************************ -* * -\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} -* * -************************************************************************ - -@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in -turn. Non-recursive case first, then recursive... --} - -wwBind :: DynFlags - -> FamInstEnvs - -> CoreBind - -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; - -- the caller will convert to Expr/Binding, - -- as appropriate. - -wwBind dflags fam_envs (NonRec binder rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs - new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs - return [NonRec b e | (b,e) <- new_pairs] - -- Generated bindings must be non-recursive - -- because the original binding was. - -wwBind dflags fam_envs (Rec pairs) - = return . Rec <$> concatMapM do_one pairs - where - do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs - tryWW dflags fam_envs Recursive binder new_rhs - -{- -@wwExpr@ basically just walks the tree, looking for appropriate -annotations that can be used. Remember it is @wwBind@ that does the -matching by looking for strict arguments of the correct type. -@wwExpr@ is a version that just returns the ``Plain'' Tree. --} - -wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr - -wwExpr _ _ e@(Type {}) = return e -wwExpr _ _ e@(Coercion {}) = return e -wwExpr _ _ e@(Lit {}) = return e -wwExpr _ _ e@(Var {}) = return e - -wwExpr dflags fam_envs (Lam binder expr) - = Lam new_binder <$> wwExpr dflags fam_envs expr - where new_binder | isId binder = zapIdUsedOnceInfo binder - | otherwise = binder - -- See Note [Zapping Used Once info in WorkWrap] - -wwExpr dflags fam_envs (App f a) - = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a - -wwExpr dflags fam_envs (Tick note expr) - = Tick note <$> wwExpr dflags fam_envs expr - -wwExpr dflags fam_envs (Cast expr co) = do - new_expr <- wwExpr dflags fam_envs expr - return (Cast new_expr co) - -wwExpr dflags fam_envs (Let bind expr) - = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr - -wwExpr dflags fam_envs (Case expr binder ty alts) = do - new_expr <- wwExpr dflags fam_envs expr - new_alts <- mapM ww_alt alts - let new_binder = zapIdUsedOnceInfo binder - -- See Note [Zapping Used Once info in WorkWrap] - return (Case new_expr new_binder ty new_alts) - where - ww_alt (con, binders, rhs) = do - new_rhs <- wwExpr dflags fam_envs rhs - let new_binders = [ if isId b then zapIdUsedOnceInfo b else b - | b <- binders ] - -- See Note [Zapping Used Once info in WorkWrap] - return (con, new_binders, new_rhs) - -{- -************************************************************************ -* * -\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} -* * -************************************************************************ - -@tryWW@ just accumulates arguments, converts strictness info from the -front-end into the proper form, then calls @mkWwBodies@ to do -the business. - -The only reason this is monadised is for the unique supply. - -Note [Don't w/w INLINE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to refrain from w/w-ing an INLINE function (ie one -with a stable unfolding) because the wrapper will then overwrite the -old stable unfolding with the wrapper code. - -Furthermore, if the programmer has marked something as INLINE, -we may lose by w/w'ing it. - -If the strictness analyser is run twice, this test also prevents -wrappers (which are INLINEd) from being re-done. (You can end up with -several liked-named Ids bouncing around at the same time---absolute -mischief.) - -Notice that we refrain from w/w'ing an INLINE function even if it is -in a recursive group. It might not be the loop breaker. (We could -test for loop-breaker-hood, but I'm not sure that ever matters.) - -Note [Worker-wrapper for INLINABLE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - {-# INLINABLE f #-} - f :: Ord a => [a] -> Int -> a - f x y = ....f.... - -where f is strict in y, we might get a more efficient loop by w/w'ing -f. But that would make a new unfolding which would overwrite the old -one! So the function would no longer be INLNABLE, and in particular -will not be specialised at call sites in other modules. - -This comes in practice (#6056). - -Solution: do the w/w for strictness analysis, but transfer the Stable -unfolding to the *worker*. So we will get something like this: - - {-# INLINE[0] f #-} - f :: Ord a => [a] -> Int -> a - f d x y = case y of I# y' -> fw d x y' - - {-# INLINABLE[0] fw #-} - fw :: Ord a => [a] -> Int# -> a - fw d x y' = let y = I# y' in ...f... - -How do we "transfer the unfolding"? Easy: by using the old one, wrapped -in work_fn! See CoreUnfold.mkWorkerUnfolding. - -Note [Worker-wrapper for NOINLINE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to disable worker/wrapper for NOINLINE things, but it turns out -this can cause unnecessary reboxing of values. Consider - - {-# NOINLINE f #-} - f :: Int -> a - f x = error (show x) - - g :: Bool -> Bool -> Int -> Int - g True True p = f p - g False True p = p + 1 - g b False p = g b True p - -the strictness analysis will discover f and g are strict, but because f -has no wrapper, the worker for g will rebox p. So we get - - $wg x y p# = - let p = I# p# in -- Yikes! Reboxing! - case x of - False -> - case y of - False -> $wg False True p# - True -> +# p# 1# - True -> - case y of - False -> $wg True True p# - True -> case f p of { } - - g x y p = case p of (I# p#) -> $wg x y p# - -Now, in this case the reboxing will float into the True branch, and so -the allocation will only happen on the error path. But it won't float -inwards if there are multiple branches that call (f p), so the reboxing -will happen on every call of g. Disaster. - -Solution: do worker/wrapper even on NOINLINE things; but move the -NOINLINE pragma to the worker. - -(See #13143 for a real-world example.) - -It is crucial that we do this for *all* NOINLINE functions. #10069 -demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but -fail to deliver: - - data C = C Int# Int# - - {-# NOINLINE c1 #-} - c1 :: C -> Int# - c1 (C _ n) = n - - {-# NOINLINE fc #-} - fc :: C -> Int# - fc c = 2 *# c1 c - -Failing to w/w `c1`, but still w/wing `fc` leads to the following code: - - c1 :: C -> Int# - c1 (C _ n) = n - - $wfc :: Int# -> Int# - $wfc n = let c = C 0# n in 2 #* c1 c - - fc :: C -> Int# - fc (C _ n) = $wfc n - -Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place. -This generalises to any function that derives its strictness signature from -its callees, so we have to make sure that when a function announces particular -strictness properties, we have to w/w them accordingly, even if it means -splitting a NOINLINE function. - -Note [Worker activation] -~~~~~~~~~~~~~~~~~~~~~~~~ -Follows on from Note [Worker-wrapper for INLINABLE functions] - -It is *vital* that if the worker gets an INLINABLE pragma (from the -original function), then the worker has the same phase activation as -the wrapper (or later). That is necessary to allow the wrapper to -inline into the worker's unfolding: see SimplUtils -Note [Simplifying inside stable unfoldings]. - -If the original is NOINLINE, it's important that the work inherit the -original activation. Consider - - {-# NOINLINE expensive #-} - expensive x = x + 1 - - f y = let z = expensive y in ... - -If expensive's worker inherits the wrapper's activation, -we'll get this (because of the compromise in point (2) of -Note [Wrapper activation]) - - {-# NOINLINE[0] $wexpensive #-} - $wexpensive x = x + 1 - {-# INLINE[0] expensive #-} - expensive x = $wexpensive x - - f y = let z = expensive y in ... - -and $wexpensive will be immediately inlined into expensive, followed by -expensive into f. This effectively removes the original NOINLINE! - -Otherwise, nothing is lost by giving the worker the same activation as the -wrapper, because the worker won't have any chance of inlining until the -wrapper does; there's no point in giving it an earlier activation. - -Note [Don't w/w inline small non-loop-breaker things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, we refrain from w/w-ing *small* functions, which are not -loop breakers, because they'll inline anyway. But we must take care: -it may look small now, but get to be big later after other inlining -has happened. So we take the precaution of adding an INLINE pragma to -any such functions. - -I made this change when I observed a big function at the end of -compilation with a useful strictness signature but no w-w. (It was -small during demand analysis, we refrained from w/w, and then got big -when something was inlined in its rhs.) When I measured it on nofib, -it didn't make much difference; just a few percent improved allocation -on one benchmark (bspt/Euclid.space). But nothing got worse. - -There is an infelicity though. We may get something like - f = g val -==> - g x = case gw x of r -> I# r - - f {- InlineStable, Template = g val -} - f = case gw x of r -> I# r - -The code for f duplicates that for g, without any real benefit. It -won't really be executed, because calls to f will go via the inlining. - -Note [Don't CPR join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There's no point in doing CPR on a join point. If the whole function is getting -CPR'd, then the case expression around the worker function will get pushed into -the join point by the simplifier, which will have the same effect that CPR would -have - the result will be returned in an unboxed tuple. - - f z = let join j x y = (x+1, y+1) - in case z of A -> j 1 2 - B -> j 2 3 - - => - - f z = case $wf z of (# a, b #) -> (a, b) - $wf z = case (let join j x y = (x+1, y+1) - in case z of A -> j 1 2 - B -> j 2 3) of (a, b) -> (# a, b #) - - => - - f z = case $wf z of (# a, b #) -> (a, b) - $wf z = let join j x y = (# x+1, y+1 #) - in case z of A -> j 1 2 - B -> j 2 3 - -Doing CPR on a join point would be tricky anyway, as the worker could not be -a join point because it would not be tail-called. However, doing the *argument* -part of W/W still works for join points, since the wrapper body will make a tail -call: - - f z = let join j x y = x + y - in ... - - => - - f z = let join $wj x# y# = x# +# y# - j x y = case x of I# x# -> - case y of I# y# -> - $wj x# y# - in ... - -Note [Wrapper activation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When should the wrapper inlining be active? - -1. It must not be active earlier than the current Activation of the - Id - -2. It should be active at some point, despite (1) because of - Note [Worker-wrapper for NOINLINE functions] - -3. For ordinary functions with no pragmas we want to inline the - wrapper as early as possible (#15056). Suppose another module - defines f x = g x x - and suppose there is some RULE for (g True True). Then if we have - a call (f True), we'd expect to inline 'f' and the RULE will fire. - But if f is w/w'd (which it might be), we want the inlining to - occur just as if it hadn't been. - - (This only matters if f's RHS is big enough to w/w, but small - enough to inline given the call site, but that can happen.) - -4. We do not want to inline the wrapper before specialisation. - module Foo where - f :: Num a => a -> Int -> a - f n 0 = n -- Strict in the Int, hence wrapper - f n x = f (n+n) (x-1) - - g :: Int -> Int - g x = f x x -- Provokes a specialisation for f - - module Bar where - import Foo - - h :: Int -> Int - h x = f 3 x - - In module Bar we want to give specialisations a chance to fire - before inlining f's wrapper. - -Reminder: Note [Don't w/w INLINE things], so we don't need to worry - about INLINE things here. - -Conclusion: - - If the user said NOINLINE[n], respect that - - If the user said NOINLINE, inline the wrapper as late as - poss (phase 0). This is a compromise driven by (2) above - - Otherwise inline wrapper in phase 2. That allows the - 'gentle' simplification pass to apply specialisation rules - -Historical note: At one stage I tried making the wrapper inlining -always-active, and that had a very bad effect on nofib/imaginary/x2n1; -a wrapper was inlined before the specialisation fired. - -Note [Wrapper NoUserInline] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The use an inl_inline of NoUserInline on the wrapper distinguishes -this pragma from one that was given by the user. In particular, CSE -will not happen if there is a user-specified pragma, but should happen -for w/w’ed things (#14186). --} - -tryWW :: DynFlags - -> FamInstEnvs - -> RecFlag - -> Id -- The fn binder - -> CoreExpr -- The bound rhs; its innards - -- are already ww'd - -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; - -- if one, then no worker (only - -- the orig "wrapper" lives on); - -- if two, then a worker and a - -- wrapper. -tryWW dflags fam_envs is_rec fn_id rhs - -- See Note [Worker-wrapper for NOINLINE functions] - - | Just stable_unf <- certainlyWillInline dflags fn_info - = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] - -- See Note [Don't w/w INLINE things] - -- See Note [Don't w/w inline small non-loop-breaker things] - - | is_fun && is_eta_exp - = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs - - | is_thunk -- See Note [Thunk splitting] - = splitThunk dflags fam_envs is_rec new_fn_id rhs - - | otherwise - = return [ (new_fn_id, rhs) ] - - where - fn_info = idInfo fn_id - (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info) - - new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) - -- See Note [Zapping DmdEnv after Demand Analyzer] and - -- See Note [Zapping Used Once info in WorkWrap] - - is_fun = notNull wrap_dmds || isJoinId fn_id - -- See Note [Don't eta expand in w/w] - is_eta_exp = length wrap_dmds == manifestArity rhs - is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) - && not (isUnliftedType (idType fn_id)) - -{- -Note [Zapping DmdEnv after Demand Analyzer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the worker-wrapper pass we zap the DmdEnv. Why? - (a) it is never used again - (b) it wastes space - (c) it becomes incorrect as things are cloned, because - we don't push the substitution into it - -Why here? - * Because we don’t want to do it in the Demand Analyzer, as we never know - there when we are doing the last pass. - * We want them to be still there at the end of DmdAnal, so that - -ddump-str-anal contains them. - * We don’t want a second pass just for that. - * WorkWrap looks at all bindings anyway. - -We also need to do it in TidyCore.tidyLetBndr to clean up after the -final, worker/wrapper-less run of the demand analyser (see -Note [Final Demand Analyser run] in DmdAnal). - -Note [Zapping Used Once info in WorkWrap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the worker-wrapper pass we zap the used once info in demands and in -strictness signatures. - -Why? - * The simplifier may happen to transform code in a way that invalidates the - data (see #11731 for an example). - * It is not used in later passes, up to code generation. - -So as the data is useless and possibly wrong, we want to remove it. The most -convenient place to do that is the worker wrapper phase, as it runs after every -run of the demand analyser besides the very last one (which is the one where we -want to _keep_ the info for the code generator). - -We do not do it in the demand analyser for the same reasons outlined in -Note [Zapping DmdEnv after Demand Analyzer] above. - -Note [Don't eta expand in w/w] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A binding where the manifestArity of the RHS is less than idArity of the binder -means CoreArity didn't eta expand that binding. When this happens, it does so -for a reason (see Note [exprArity invariant] in CoreArity) and we probably have -a PAP, cast or trivial expression as RHS. - -Performing the worker/wrapper split will implicitly eta-expand the binding to -idArity, overriding CoreArity's decision. Other than playing fast and loose with -divergence, it's also broken for newtypes: - - f = (\xy.blah) |> co - where - co :: (Int -> Int -> Char) ~ T - -Then idArity is 2 (despite the type T), and it can have a StrictSig based on a -threshold of 2. But we can't w/w it without a type error. - -The situation is less grave for PAPs, but the implicit eta expansion caused a -compiler allocation regression in T15164, where huge recursive instance method -groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the -simplifier, when simply waiting for the PAPs to inline arrived at the same -output program. - -Note there is the worry here that such PAPs and trivial RHSs might not *always* -be inlined. That would lead to reboxing, because the analysis tacitly assumes -that we W/W'd for idArity and will propagate analysis information under that -assumption. So far, this doesn't seem to matter in practice. -See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. --} - - ---------------------- -splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr - -> UniqSM [(Id, CoreExpr)] -splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs - = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do - -- The arity should match the signature - stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_res_info - case stuff of - Just (work_demands, join_arity, wrap_fn, work_fn) -> do - work_uniq <- getUniqueM - let work_rhs = work_fn rhs - work_act = case fn_inline_spec of -- See Note [Worker activation] - NoInline -> fn_act - _ -> wrap_act - - work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = fn_inline_spec - , inl_sat = Nothing - , inl_act = work_act - , inl_rule = FunLike } - -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] - -- inl_act: see Note [Worker activation] - -- inl_rule: it does not make sense for workers to be constructorlike. - - work_join_arity | isJoinId fn_id = Just join_arity - | otherwise = Nothing - -- worker is join point iff wrapper is join point - -- (see Note [Don't CPR join points]) - - work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) - `setIdOccInfo` occInfo fn_info - -- Copy over occurrence info from parent - -- Notably whether it's a loop breaker - -- Doesn't matter much, since we will simplify next, but - -- seems right-er to do so - - `setInlinePragma` work_prag - - `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding - -- See Note [Worker-wrapper for INLINABLE functions] - - `setIdStrictness` mkClosedStrictSig work_demands work_res_info - -- Even though we may not be at top level, - -- it's ok to give it an empty DmdEnv - - `setIdDemandInfo` worker_demand - - `setIdArity` work_arity - -- Set the arity so that the Core Lint check that the - -- arity is consistent with the demand type goes - -- through - `asJoinId_maybe` work_join_arity - - work_arity = length work_demands - - -- See Note [Demand on the Worker] - single_call = saturatedByOneShots arity (demandInfo fn_info) - worker_demand | single_call = mkWorkerDemand work_arity - | otherwise = topDmd - - wrap_rhs = wrap_fn work_id - wrap_act = case fn_act of -- See Note [Wrapper activation] - ActiveAfter {} -> fn_act - NeverActive -> activeDuringFinal - _ -> activeAfterInitial - wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = NoUserInline - , inl_sat = Nothing - , inl_act = wrap_act - , inl_rule = rule_match_info } - -- inl_act: see Note [Wrapper activation] - -- inl_inline: see Note [Wrapper NoUserInline] - -- inl_rule: RuleMatchInfo is (and must be) unaffected - - wrap_id = fn_id `setIdUnfolding` mkWwInlineRule dflags wrap_rhs arity - `setInlinePragma` wrap_prag - `setIdOccInfo` noOccInfo - -- Zap any loop-breaker-ness, to avoid bleating from Lint - -- about a loop breaker with an INLINE rule - - - - return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] - -- Worker first, because wrapper mentions it - - Nothing -> return [(fn_id, rhs)] - where - rhs_fvs = exprFreeVars rhs - fn_inl_prag = inlinePragInfo fn_info - fn_inline_spec = inl_inline fn_inl_prag - fn_act = inl_act fn_inl_prag - rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag - fn_unfolding = unfoldingInfo fn_info - arity = arityInfo fn_info - -- The arity is set by the simplifier using exprEtaExpandArity - -- So it may be more than the number of top-level-visible lambdas - - use_res_info | isJoinId fn_id = topRes -- Note [Don't CPR join points] - | otherwise = res_info - work_res_info | isJoinId fn_id = res_info -- Worker remains CPR-able - | otherwise - = case returnsCPR_maybe res_info of - Just _ -> topRes -- Cpr stuff done by wrapper; kill it here - Nothing -> res_info -- Preserve exception/divergence - - -{- -Note [Demand on the worker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If the original function is called once, according to its demand info, then -so is the worker. This is important so that the occurrence analyser can -attach OneShot annotations to the worker’s lambda binders. - - -Example: - - -- Original function - f [Demand=] :: (a,a) -> a - f = \p -> ... - - -- Wrapper - f [Demand=] :: a -> a -> a - f = \p -> case p of (a,b) -> $wf a b - - -- Worker - $wf [Demand=] :: Int -> Int - $wf = \a b -> ... - -We need to check whether the original function is called once, with -sufficiently many arguments. This is done using saturatedByOneShots, which -takes the arity of the original function (resp. the wrapper) and the demand on -the original function. - -The demand on the worker is then calculated using mkWorkerDemand, and always of -the form [Demand=] - - -Note [Do not split void functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this rather common form of binding: - $j = \x:Void# -> ...no use of x... - -Since x is not used it'll be marked as absent. But there is no point -in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs. - -If x has a more interesting type (eg Int, or Int#), there *is* a point -in w/w so that we don't pass the argument at all. - -Note [Thunk splitting] -~~~~~~~~~~~~~~~~~~~~~~ -Suppose x is used strictly (never mind whether it has the CPR -property). - - let - x* = x-rhs - in body - -splitThunk transforms like this: - - let - x* = case x-rhs of { I# a -> I# a } - in body - -Now simplifier will transform to - - case x-rhs of - I# a -> let x* = I# a - in body - -which is what we want. Now suppose x-rhs is itself a case: - - x-rhs = case e of { T -> I# a; F -> I# b } - -The join point will abstract over a, rather than over (which is -what would have happened before) which is fine. - -Notice that x certainly has the CPR property now! - -In fact, splitThunk uses the function argument w/w splitting -function, so that if x's demand is deeper (say U(U(L,L),L)) -then the splitting will go deeper too. --} - --- See Note [Thunk splitting] --- splitThunk converts the *non-recursive* binding --- x = e --- into --- x = let x = e --- in case x of --- I# y -> let x = I# y in x } --- See comments above. Is it not beautifully short? --- Moreover, it works just as well when there are --- several binders, and if the binders are lifted --- E.g. x = e --- --> x = let x = e in --- case x of (a,b) -> let x = (a,b) in x - -splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] -splitThunk dflags fam_envs is_rec fn_id rhs - = ASSERT(not (isJoinId fn_id)) - do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id] - ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] - ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive - return res - else return [(fn_id, rhs)] } diff --git a/stranal/WwLib.hs b/stranal/WwLib.hs deleted file mode 100644 --- a/stranal/WwLib.hs +++ /dev/null @@ -1,1195 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser} --} - -{-# LANGUAGE CPP #-} - -module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs - , deepSplitProductType_maybe, findTypeShape - , isWorkerSmallEnough - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreUtils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) -import Id -import IdInfo ( JoinArity ) -import DataCon -import Demand -import MkCore ( mkAbsentErrorApp, mkCoreUbxTup - , mkCoreApp, mkCoreLet ) -import MkId ( voidArgId, voidPrimId ) -import TysWiredIn ( tupleDataCon ) -import TysPrim ( voidPrimTy ) -import Literal ( absentLiteralOf, rubbishLit ) -import VarEnv ( mkInScopeSet ) -import VarSet ( VarSet ) -import Type -import Predicate ( isClassPred ) -import RepType ( isVoidTy, typePrimRep ) -import Coercion -import FamInstEnv -import BasicTypes ( Boxity(..) ) -import TyCon -import UniqSupply -import Unique -import Maybes -import Util -import Outputable -import DynFlags -import FastString -import ListSetOps - -{- -************************************************************************ -* * -\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} -* * -************************************************************************ - -Here's an example. The original function is: - -\begin{verbatim} -g :: forall a . Int -> [a] -> a - -g = \/\ a -> \ x ys -> - case x of - 0 -> head ys - _ -> head (tail ys) -\end{verbatim} - -From this, we want to produce: -\begin{verbatim} --- wrapper (an unfolding) -g :: forall a . Int -> [a] -> a - -g = \/\ a -> \ x ys -> - case x of - I# x# -> $wg a x# ys - -- call the worker; don't forget the type args! - --- worker -$wg :: forall a . Int# -> [a] -> a - -$wg = \/\ a -> \ x# ys -> - let - x = I# x# - in - case x of -- note: body of g moved intact - 0 -> head ys - _ -> head (tail ys) -\end{verbatim} - -Something we have to be careful about: Here's an example: - -\begin{verbatim} --- "f" strictness: U(P)U(P) -f (I# a) (I# b) = a +# b - -g = f -- "g" strictness same as "f" -\end{verbatim} - -\tr{f} will get a worker all nice and friendly-like; that's good. -{\em But we don't want a worker for \tr{g}}, even though it has the -same strictness as \tr{f}. Doing so could break laziness, at best. - -Consequently, we insist that the number of strictness-info items is -exactly the same as the number of lambda-bound arguments. (This is -probably slightly paranoid, but OK in practice.) If it isn't the -same, we ``revise'' the strictness info, so that we won't propagate -the unusable strictness-info into the interfaces. - - -************************************************************************ -* * -\subsection{The worker wrapper core} -* * -************************************************************************ - -@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. --} - -type WwResult - = ([Demand], -- Demands for worker (value) args - JoinArity, -- Number of worker (type OR value) args - Id -> CoreExpr, -- Wrapper body, lacking only the worker Id - CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs - -mkWwBodies :: DynFlags - -> FamInstEnvs - -> VarSet -- Free vars of RHS - -- See Note [Freshen WW arguments] - -> Id -- The original function - -> [Demand] -- Strictness of original function - -> DmdResult -- Info about function result - -> UniqSM (Maybe WwResult) - --- wrap_fn_args E = \x y -> E --- work_fn_args E = E x y - --- wrap_fn_str E = case x of { (a,b) -> --- case a of { (a1,a2) -> --- E a1 a2 b y }} --- work_fn_str E = \a1 a2 b y -> --- let a = (a1,a2) in --- let x = (a,b) in --- E - -mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info - = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) - -- See Note [Freshen WW arguments] - - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs empty_subst fun_ty demands - ; (useful1, work_args, wrap_fn_str, work_fn_str) - <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args - - -- Do CPR w/w. See Note [Always do CPR w/w] - ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info - - ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty - worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] - wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var - worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args - - ; if isWorkerSmallEnough dflags work_args - && not (too_many_args_for_join_point wrap_args) - && ((useful1 && not only_one_void_argument) || useful2) - then return (Just (worker_args_dmds, length work_call_args, - wrapper_body, worker_body)) - else return Nothing - } - -- We use an INLINE unconditionally, even if the wrapper turns out to be - -- something trivial like - -- fw = ... - -- f = __inline__ (coerce T fw) - -- The point is to propagate the coerce to f's call sites, so even though - -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent - -- fw from being inlined into f's RHS - where - fun_ty = idType fun_id - mb_join_arity = isJoinId_maybe fun_id - has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id) - -- See Note [Do not unpack class dictionaries] - - -- Note [Do not split void functions] - only_one_void_argument - | [d] <- demands - , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty - , isAbsDmd d && isVoidTy arg_ty1 - = True - | otherwise - = False - - -- Note [Join points returning functions] - too_many_args_for_join_point wrap_args - | Just join_arity <- mb_join_arity - , wrap_args `lengthExceeds` join_arity - = WARN(True, text "Unable to worker/wrapper join point with arity " <+> - int join_arity <+> text "but" <+> - int (length wrap_args) <+> text "args") - True - | otherwise - = False - --- See Note [Limit w/w arity] -isWorkerSmallEnough :: DynFlags -> [Var] -> Bool -isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags - -- We count only Free variables (isId) to skip Type, Kind - -- variables which have no runtime representation. - -{- -Note [Always do CPR w/w] -~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we refrained from doing CPR w/w for thunks, on the grounds that -we might duplicate work. But that is already handled by the demand analyser, -which doesn't give the CPR proprety if w/w might waste work: see -Note [CPR for thunks] in DmdAnal. - -And if something *has* been given the CPR property and we don't w/w, it's -a disaster, because then the enclosing function might say it has the CPR -property, but now doesn't and there a cascade of disaster. A good example -is #5920. - -Note [Limit w/w arity] -~~~~~~~~~~~~~~~~~~~~~~~~ -Guard against high worker arity as it generates a lot of stack traffic. -A simplified example is #11565#comment:6 - -Current strategy is very simple: don't perform w/w transformation at all -if the result produces a wrapper with arity higher than -fmax-worker-args=. - -It is a bit all or nothing, consider - - f (x,y) (a,b,c,d,e ... , z) = rhs - -Currently we will remove all w/w ness entirely. But actually we could -w/w on the (x,y) pair... it's the huge product that is the problem. - -Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd -solve f. But we can get a lot of args from deeply-nested products: - - g (a, (b, (c, (d, ...)))) = rhs - -This is harder to spot on an arg-by-arg basis. Previously mkWwStr was -given some "fuel" saying how many arguments it could add; when we ran -out of fuel it would stop w/wing. -Still not very clever because it had a left-right bias. - -************************************************************************ -* * -\subsection{Making wrapper args} -* * -************************************************************************ - -During worker-wrapper stuff we may end up with an unlifted thing -which we want to let-bind without losing laziness. So we -add a void argument. E.g. - - f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z -==> - fw = /\ a -> \void -> E - f = /\ a -> \x y z -> fw realworld - -We use the state-token type which generates no code. --} - -mkWorkerArgs :: DynFlags -> [Var] - -> Type -- Type of body - -> ([Var], -- Lambda bound args - [Var]) -- Args at call site -mkWorkerArgs dflags args res_ty - | any isId args || not needsAValueLambda - = (args, args) - | otherwise - = (args ++ [voidArgId], args ++ [voidPrimId]) - where - -- See "Making wrapper args" section above - needsAValueLambda = - lifted - -- We may encounter a levity-polymorphic result, in which case we - -- conservatively assume that we have laziness that needs preservation. - -- See #15186. - || not (gopt Opt_FunToThunk dflags) - -- see Note [Protecting the last value argument] - - -- Might the result be lifted? - lifted = - case isLiftedType_maybe res_ty of - Just lifted -> lifted - Nothing -> True - -{- -Note [Protecting the last value argument] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the user writes (\_ -> E), they might be intentionally disallowing -the sharing of E. Since absence analysis and worker-wrapper are keen -to remove such unused arguments, we add in a void argument to prevent -the function from becoming a thunk. - -The user can avoid adding the void argument with the -ffun-to-thunk -flag. However, this can create sharing, which may be bad in two ways. 1) It can -create a space leak. 2) It can prevent inlining *under a lambda*. If w/w -removes the last argument from a function f, then f now looks like a thunk, and -so f can't be inlined *under a lambda*. - -Note [Join points and beta-redexes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Originally, the worker would invoke the original function by calling it with -arguments, thus producing a beta-redex for the simplifier to munch away: - - \x y z -> e => (\x y z -> e) wx wy wz - -Now that we have special rules about join points, however, this is Not Good if -the original function is itself a join point, as then it may contain invocations -of other join points: - - join j1 x = ... - join j2 y = if y == 0 then 0 else j1 y - - => - - join j1 x = ... - join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy - join j2 y = case y of I# y# -> jump $wj2 y# - -There can't be an intervening lambda between a join point's declaration and its -occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: - - ... - let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y - ... - -Hence we simply do the beta-reduction here. (This would be harder if we had to -worry about hygiene, but luckily wy is freshly generated.) - -Note [Join points returning functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is crucial that the arity of a join point depends on its *callers,* not its -own syntax. What this means is that a join point can have "extra lambdas": - -f :: Int -> Int -> (Int, Int) -> Int -f x y = join j (z, w) = \(u, v) -> ... - in jump j (x, y) - -Typically this happens with functions that are seen as computing functions, -rather than being curried. (The real-life example was GraphOps.addConflicts.) - -When we create the wrapper, it *must* be in "eta-contracted" form so that the -jump has the right number of arguments: - -f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... - j (z, w) = jump $wj z w - -(See Note [Join points and beta-redexes] for where the lets come from.) If j -were a function, we would instead say - -f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... - j (z, w) (u, v) = $wj z w u v - -Notice that the worker ends up with the same lambdas; it's only the wrapper we -have to be concerned about. - -FIXME Currently the functionality to produce "eta-contracted" wrappers is -unimplemented; we simply give up. - -************************************************************************ -* * -\subsection{Coercion stuff} -* * -************************************************************************ - -We really want to "look through" coerces. -Reason: I've seen this situation: - - let f = coerce T (\s -> E) - in \x -> case x of - p -> coerce T' f - q -> \s -> E2 - r -> coerce T' f - -If only we w/w'd f, we'd get - let f = coerce T (\s -> fw s) - fw = \s -> E - in ... - -Now we'll inline f to get - - let fw = \s -> E - in \x -> case x of - p -> fw - q -> \s -> E2 - r -> fw - -Now we'll see that fw has arity 1, and will arity expand -the \x to get what we want. --} - --- mkWWargs just does eta expansion --- is driven off the function type and arity. --- It chomps bites off foralls, arrows, newtypes --- and keeps repeating that until it's satisfied the supplied arity - -mkWWargs :: TCvSubst -- Freshening substitution to apply to the type - -- See Note [Freshen WW arguments] - -> Type -- The type of the function - -> [Demand] -- Demands and one-shot info for value arguments - -> UniqSM ([Var], -- Wrapper args - CoreExpr -> CoreExpr, -- Wrapper fn - CoreExpr -> CoreExpr, -- Worker fn - Type) -- Type of wrapper body - -mkWWargs subst fun_ty demands - | null demands - = return ([], id, id, substTy subst fun_ty) - - | (dmd:demands') <- demands - , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let arg_ty' = substTy subst arg_ty - id = mk_wrap_arg uniq arg_ty' dmd - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst fun_ty' demands' - ; return (id : wrap_args, - Lam id . wrap_fn_args, - apply_or_bind_then work_fn_args (varToCoreExpr id), - res_ty) } - - | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let (subst', tv') = cloneTyVarBndr subst tv uniq - -- See Note [Freshen WW arguments] - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst' fun_ty' demands - ; return (tv' : wrap_args, - Lam tv' . wrap_fn_args, - apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')), - res_ty) } - - | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty - -- The newtype case is for when the function has - -- a newtype after the arrow (rare) - -- - -- It's also important when we have a function returning (say) a pair - -- wrapped in a newtype, at least if CPR analysis can look - -- through such newtypes, which it probably can since they are - -- simply coerces. - - = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst rep_ty demands - ; let co' = substCo subst co - ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCo co'), - \e -> work_fn_args (Cast e co'), - res_ty) } - - | otherwise - = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand - return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow - where - -- See Note [Join points and beta-redexes] - apply_or_bind_then k arg (Lam bndr body) - = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! - apply_or_bind_then k arg fun - = k $ mkCoreApp (text "mkWWargs") fun arg -applyToVars :: [Var] -> CoreExpr -> CoreExpr -applyToVars vars fn = mkVarApps fn vars - -mk_wrap_arg :: Unique -> Type -> Demand -> Id -mk_wrap_arg uniq ty dmd - = mkSysLocalOrCoVar (fsLit "w") uniq ty - `setIdDemandInfo` dmd - -{- Note [Freshen WW arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wen we do a worker/wrapper split, we must not in-scope names as the arguments -of the worker, else we'll get name capture. E.g. - - -- y1 is in scope from further out - f x = ..y1.. - -If we accidentally choose y1 as a worker argument disaster results: - - fww y1 y2 = let x = (y1,y2) in ...y1... - -To avoid this: - - * We use a fresh unique for both type-variable and term-variable binders - Originally we lacked this freshness for type variables, and that led - to the very obscure #12562. (A type variable in the worker shadowed - an outer term-variable binding.) - - * Because of this cloning we have to substitute in the type/kind of the - new binders. That's why we carry the TCvSubst through mkWWargs. - - So we need a decent in-scope set, just in case that type/kind - itself has foralls. We get this from the free vars of the RHS of the - function since those are the only variables that might be captured. - It's a lazy thunk, which will only be poked if the type/kind has a forall. - - Another tricky case was when f :: forall a. a -> forall a. a->a - (i.e. with shadowing), and then the worker used the same 'a' twice. - -************************************************************************ -* * -\subsection{Strictness stuff} -* * -************************************************************************ --} - -mkWWstr :: DynFlags - -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] - -> [Var] -- Wrapper args; have their demand info on them - -- *Includes type variables* - -> UniqSM (Bool, -- Is this useful - [Var], -- Worker args - CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call - -- and without its lambdas - -- This fn adds the unboxing - - CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, - -- and lacking its lambdas. - -- This fn does the reboxing -mkWWstr dflags fam_envs has_inlineable_prag args - = go args - where - go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg - - go [] = return (False, [], nop_fn, nop_fn) - go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg - ; (useful2, args2, wrap_fn2, work_fn2) <- go args - ; return ( useful1 || useful2 - , args1 ++ args2 - , wrap_fn1 . wrap_fn2 - , work_fn1 . work_fn2) } - -{- -Note [Unpacking arguments with product and polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The argument is unpacked in a case if it has a product type and has a -strict *and* used demand put on it. I.e., arguments, with demands such -as the following ones: - - - - -will be unpacked, but - - or - -will not, because the pieces aren't used. This is quite important otherwise -we end up unpacking massive tuples passed to the bottoming function. Example: - - f :: ((Int,Int) -> String) -> (Int,Int) -> a - f g pr = error (g pr) - - main = print (f fst (1, error "no")) - -Does 'main' print "error 1" or "error no"? We don't really want 'f' -to unbox its second argument. This actually happened in GHC's onwn -source code, in Packages.applyPackageFlag, which ended up un-boxing -the enormous DynFlags tuple, and being strict in the -as-yet-un-filled-in pkgState files. --} - ----------------------- --- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) --- * wrap_fn assumes wrap_arg is in scope, --- brings into scope work_args (via cases) --- * work_fn assumes work_args are in scope, a --- brings into scope wrap_arg (via lets) --- See Note [How to do the worker/wrapper split] -mkWWstr_one :: DynFlags -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] - -> Var - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -mkWWstr_one dflags fam_envs has_inlineable_prag arg - | isTyVar arg - = return (False, [arg], nop_fn, nop_fn) - - | isAbsDmd dmd - , Just work_fn <- mk_absent_let dflags arg - -- Absent case. We can't always handle absence for arbitrary - -- unlifted types, so we need to choose just the cases we can - -- (that's what mk_absent_let does) - = return (True, [], nop_fn, work_fn) - - | isStrictDmd dmd - , Just cs <- splitProdDmd_maybe dmd - -- See Note [Unpacking arguments with product and polymorphic demands] - , not (has_inlineable_prag && isClassPred arg_ty) - -- See Note [Do not unpack class dictionaries] - , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty - , cs `equalLength` inst_con_arg_tys - -- See Note [mkWWstr and unsafeCoerce] - = unbox_one dflags fam_envs arg cs stuff - - | isSeqDmd dmd -- For seqDmd, splitProdDmd_maybe will return Nothing, but - -- it should behave like , for some suitable arity - , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty - , let abs_dmds = map (const absDmd) inst_con_arg_tys - = unbox_one dflags fam_envs arg abs_dmds stuff - - | otherwise -- Other cases - = return (False, [arg], nop_fn, nop_fn) - - where - arg_ty = idType arg - dmd = idDemandInfo arg - -unbox_one :: DynFlags -> FamInstEnvs -> Var - -> [Demand] - -> (DataCon, [Type], [(Type, StrictnessMark)], Coercion) - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -unbox_one dflags fam_envs arg cs - (data_con, inst_tys, inst_con_arg_tys, co) - = do { (uniq1:uniqs) <- getUniquesM - ; let -- See Note [Add demands for strict constructors] - cs' = addDataConStrictness data_con cs - unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs' - unbox_fn = mkUnpackCase (Var arg) co uniq1 - data_con unpk_args - arg_no_unf = zapStableUnfolding arg - -- See Note [Zap unfolding when beta-reducing] - -- in Simplify.hs; and see #13890 - rebox_fn = Let (NonRec arg_no_unf con_app) - con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co - ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args - ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } - -- Don't pass the arg, rebox instead - where - mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd - ----------------------- -nop_fn :: CoreExpr -> CoreExpr -nop_fn body = body - -addDataConStrictness :: DataCon -> [Demand] -> [Demand] --- See Note [Add demands for strict constructors] -addDataConStrictness con ds - = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds ) - zipWith add ds strs - where - strs = dataConRepStrictness con - add dmd str | isMarkedStrict str = strictifyDmd dmd - | otherwise = dmd - -{- Note [How to do the worker/wrapper split] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The worker-wrapper transformation, mkWWstr_one, takes into account -several possibilities to decide if the function is worthy for -splitting: - -1. If an argument is absent, it would be silly to pass it to - the worker. Hence the isAbsDmd case. This case must come - first because a demand like or is possible. - E.g. comes from a function like - f x = error "urk" - and can come from Note [Add demands for strict constructors] - -2. If the argument is evaluated strictly, and we can split the - product demand (splitProdDmd_maybe), then unbox it and w/w its - pieces. For example - - f :: (Int, Int) -> Int - f p = (case p of (a,b) -> a) + 1 - is split to - f :: (Int, Int) -> Int - f p = case p of (a,b) -> $wf a - - $wf :: Int -> Int - $wf a = a + 1 - - and - g :: Bool -> (Int, Int) -> Int - g c p = case p of (a,b) -> - if c then a else b - is split to - g c p = case p of (a,b) -> $gw c a b - $gw c a b = if c then a else b - -2a But do /not/ split if the components are not used; that is, the - usage is just 'Used' rather than 'UProd'. In this case - splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing - a massive tuple which is barely used. Example: - - f :: ((Int,Int) -> String) -> (Int,Int) -> a - f g pr = error (g pr) - - main = print (f fst (1, error "no")) - - Here, f does not take 'pr' apart, and it's stupid to do so. - Imagine that it had millions of fields. This actually happened - in GHC itself where the tuple was DynFlags - -3. A plain 'seqDmd', which is head-strict with usage UHead, can't - be split by splitProdDmd_maybe. But we want it to behave just - like U(AAAA) for suitable number of absent demands. So we have - a special case for it, with arity coming from the data constructor. - -Note [Worker-wrapper for bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used not to split if the result is bottom. -[Justification: there's no efficiency to be gained.] - -But it's sometimes bad not to make a wrapper. Consider - fw = \x# -> let x = I# x# in case e of - p1 -> error_fn x - p2 -> error_fn x - p3 -> the real stuff -The re-boxing code won't go away unless error_fn gets a wrapper too. -[We don't do reboxing now, but in general it's better to pass an -unboxed thing to f, and have it reboxed in the error cases....] - -Note [Add demands for strict constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this program (due to Roman): - - data X a = X !a - - foo :: X Int -> Int -> Int - foo (X a) n = go 0 - where - go i | i < n = a + go (i+1) - | otherwise = 0 - -We want the worker for 'foo' too look like this: - - $wfoo :: Int# -> Int# -> Int# - -with the first argument unboxed, so that it is not eval'd each time -around the 'go' loop (which would otherwise happen, since 'foo' is not -strict in 'a'). It is sound for the wrapper to pass an unboxed arg -because X is strict, so its argument must be evaluated. And if we -*don't* pass an unboxed argument, we can't even repair it by adding a -`seq` thus: - - foo (X a) n = a `seq` go 0 - -because the seq is discarded (very early) since X is strict! - -So here's what we do - -* We leave the demand-analysis alone. The demand on 'a' in the - definition of 'foo' is ; the strictness info is Lazy - because foo's body may or may not evaluate 'a'; but the usage info - says that 'a' is unpacked and its content is used. - -* During worker/wrapper, if we unpack a strict constructor (as we do - for 'foo'), we use 'addDataConStrictness' to bump up the strictness on - the strict arguments of the data constructor. - -* That in turn means that, if the usage info supports doing so - (i.e. splitProdDmd_maybe returns Just), we will unpack that argument - -- even though the original demand (e.g. on 'a') was lazy. - -* What does "bump up the strictness" mean? Just add a head-strict - demand to the strictness! Even for a demand like we can - safely turn it into ; remember case (1) of - Note [How to do the worker/wrapper split]. - -The net effect is that the w/w transformation is more aggressive about -unpacking the strict arguments of a data constructor, when that -eagerness is supported by the usage info. - -There is the usual danger of reboxing, which as usual we ignore. But -if X is monomorphic, and has an UNPACK pragma, then this optimisation -is even more important. We don't want the wrapper to rebox an unboxed -argument, and pass an Int to $wfoo! - -This works in nested situations like - - data family Bar a - data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) - newtype instance Bar Int = Bar Int - - foo :: Bar ((Int, Int), Int) -> Int -> Int - foo f k = case f of BarPair x y -> - case burble of - True -> case x of - BarPair p q -> ... - False -> ... - -The extra eagerness lets us produce a worker of type: - $wfoo :: Int# -> Int# -> Int# -> Int -> Int - $wfoo p# q# y# = ... - -even though the `case x` is only lazily evaluated. - ---------- Historical note ------------ -We used to add data-con strictness demands when demand analysing case -expression. However, it was noticed in #15696 that this misses some cases. For -instance, consider the program (from T10482) - - data family Bar a - data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) - newtype instance Bar Int = Bar Int - - foo :: Bar ((Int, Int), Int) -> Int -> Int - foo f k = - case f of - BarPair x y -> case burble of - True -> case x of - BarPair p q -> ... - False -> ... - -We really should be able to assume that `p` is already evaluated since it came -from a strict field of BarPair. This strictness would allow us to produce a -worker of type: - - $wfoo :: Int# -> Int# -> Int# -> Int -> Int - $wfoo p# q# y# = ... - -even though the `case x` is only lazily evaluated - -Indeed before we fixed #15696 this would happen since we would float the inner -`case x` through the `case burble` to get: - - foo f k = - case f of - BarPair x y -> case x of - BarPair p q -> case burble of - True -> ... - False -> ... - -However, after fixing #15696 this could no longer happen (for the reasons -discussed in ticket:15696#comment:76). This means that the demand placed on `f` -would then be significantly weaker (since the False branch of the case on -`burble` is not strict in `p` or `q`). - -Consequently, we now instead account for data-con strictness in mkWWstr_one, -applying the strictness demands to the final result of DmdAnal. The result is -that we get the strict demand signature we wanted even if we can't float -the case on `x` up through the case on `burble`. - - -Note [mkWWstr and unsafeCoerce] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By using unsafeCoerce, it is possible to make the number of demands fail to -match the number of constructor arguments; this happened in #8037. -If so, the worker/wrapper split doesn't work right and we get a Core Lint -bug. The fix here is simply to decline to do w/w if that happens. - -Note [Record evaluated-ness in worker/wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T = MkT !Int Int - - f :: T -> T - f x = e - -and f's is strict, and has the CPR property. The we are going to generate -this w/w split - - f x = case x of - MkT x1 x2 -> case $wf x1 x2 of - (# r1, r2 #) -> MkT r1 r2 - - $wfw x1 x2 = let x = MkT x1 x2 in - case e of - MkT r1 r2 -> (# r1, r2 #) - -Note that - -* In the worker $wf, inside 'e' we can be sure that x1 will be - evaluated (it came from unpacking the argument MkT. But that's no - immediately apparent in $wf - -* In the wrapper 'f', which we'll inline at call sites, we can be sure - that 'r1' has been evaluated (because it came from unpacking the result - MkT. But that is not immediately apparent from the wrapper code. - -Missing these facts isn't unsound, but it loses possible future -opportunities for optimisation. - -Solution: use setCaseBndrEvald when creating - (A) The arg binders x1,x2 in mkWstr_one - See #13077, test T13077 - (B) The result binders r1,r2 in mkWWcpr_help - See Trace #13077, test T13077a - And #13027 comment:20, item (4) -to record that the relevant binder is evaluated. - - -************************************************************************ -* * - Type scrutiny that is specific to demand analysis -* * -************************************************************************ - -Note [Do not unpack class dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - f :: Ord a => [a] -> Int -> a - {-# INLINABLE f #-} -and we worker/wrapper f, we'll get a worker with an INLINABLE pragma -(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which -can still be specialised by the type-class specialiser, something like - fw :: Ord a => [a] -> Int# -> a - -BUT if f is strict in the Ord dictionary, we might unpack it, to get - fw :: (a->a->Bool) -> [a] -> Int# -> a -and the type-class specialiser can't specialise that. An example is -#6056. - -But in any other situation a dictionary is just an ordinary value, -and can be unpacked. So we track the INLINABLE pragma, and switch -off the unpacking in mkWWstr_one (see the isClassPred test). - -Historical note: #14955 describes how I got this fix wrong -the first time. --} - -deepSplitProductType_maybe - :: FamInstEnvs -> Type - -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion) --- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitProductType_maybe fam_envs ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , Just con <- isDataProductTyCon_maybe tc - , let arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co) -deepSplitProductType_maybe _ _ = Nothing - -deepSplitCprType_maybe - :: FamInstEnvs -> ConTag -> Type - -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion) --- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitCprType_maybe fam_envs con_tag ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , isDataTyCon tc - , let cons = tyConDataCons tc - , cons `lengthAtLeast` con_tag -- This might not be true if we import the - -- type constructor via a .hs-bool file (#8743) - , let con = cons `getNth` (con_tag - fIRST_TAG) - arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co) -deepSplitCprType_maybe _ _ _ = Nothing - -findTypeShape :: FamInstEnvs -> Type -> TypeShape --- Uncover the arrow and product shape of a type --- The data type TypeShape is defined in Demand --- See Note [Trimming a demand to a type] in Demand -findTypeShape fam_envs ty - | Just (tc, tc_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tc - = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args) - - | Just (_, res) <- splitFunTy_maybe ty - = TsFun (findTypeShape fam_envs res) - - | Just (_, ty') <- splitForAllTy_maybe ty - = findTypeShape fam_envs ty' - - | Just (_, ty') <- topNormaliseType_maybe fam_envs ty - = findTypeShape fam_envs ty' - - | otherwise - = TsUnk - -{- -************************************************************************ -* * -\subsection{CPR stuff} -* * -************************************************************************ - - -@mkWWcpr@ takes the worker/wrapper pair produced from the strictness -info and adds in the CPR transformation. The worker returns an -unboxed tuple containing non-CPR components. The wrapper takes this -tuple and re-produces the correct structured output. - -The non-CPR results appear ordered in the unboxed tuple as if by a -left-to-right traversal of the result structure. --} - -mkWWcpr :: Bool - -> FamInstEnvs - -> Type -- function body type - -> DmdResult -- CPR analysis results - -> UniqSM (Bool, -- Is w/w'ing useful? - CoreExpr -> CoreExpr, -- New wrapper - CoreExpr -> CoreExpr, -- New worker - Type) -- Type of worker's body - -mkWWcpr opt_CprAnal fam_envs body_ty res - -- CPR explicitly turned off (or in -O0) - | not opt_CprAnal = return (False, id, id, body_ty) - -- CPR is turned on by default for -O and O2 - | otherwise - = case returnsCPR_maybe res of - Nothing -> return (False, id, id, body_ty) -- No CPR info - Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty - -> mkWWcpr_help stuff - | otherwise - -- See Note [non-algebraic or open body type warning] - -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) - return (False, id, id, body_ty) - -mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion) - -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) - -mkWWcpr_help (data_con, inst_tys, arg_tys, co) - | [arg1@(arg_ty1, _)] <- arg_tys - , isUnliftedType arg_ty1 - -- Special case when there is a single result of unlifted type - -- - -- Wrapper: case (..call worker..) of x -> C x - -- Worker: case ( ..body.. ) of C x -> x - = do { (work_uniq : arg_uniq : _) <- getUniquesM - ; let arg = mk_ww_local arg_uniq arg1 - con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co - - ; return ( True - , \ wkr_call -> mkDefaultCase wkr_call arg con_app - , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg) - -- varToCoreExpr important here: arg can be a coercion - -- Lacking this caused #10658 - , arg_ty1 ) } - - | otherwise -- The general case - -- Wrapper: case (..call worker..) of (# a, b #) -> C a b - -- Worker: case ( ...body... ) of C a b -> (# a, b #) - = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM - ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict) - args = zipWith mk_ww_local uniqs arg_tys - ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args) - con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co - tup_con = tupleDataCon Unboxed (length arg_tys) - - ; return (True - , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild - (DataAlt tup_con) args con_app - , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app - , ubx_tup_ty ) } - -mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr --- (mkUnpackCase e co uniq Con args body) --- returns --- case e |> co of bndr { Con args -> body } - -mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking] - = Tick tickish (mkUnpackCase e co uniq con args body) -mkUnpackCase scrut co uniq boxing_con unpk_args body - = mkSingleAltCase casted_scrut bndr - (DataAlt boxing_con) unpk_args body - where - casted_scrut = scrut `mkCast` co - bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict) - -{- -Note [non-algebraic or open body type warning] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a few cases where the W/W transformation is told that something -returns a constructor, but the type at hand doesn't really match this. One -real-world example involves unsafeCoerce: - foo = IO a - foo = unsafeCoerce c_exit - foreign import ccall "c_exit" c_exit :: IO () -Here CPR will tell you that `foo` returns a () constructor for sure, but trying -to create a worker/wrapper for type `a` obviously fails. -(This was a real example until ee8e792 in libraries/base.) - -It does not seem feasible to avoid all such cases already in the analyser (and -after all, the analysis is not really wrong), so we simply do nothing here in -mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch -other cases where something went avoidably wrong. - - -Note [Profiling and unpacking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the original function looked like - f = \ x -> {-# SCC "foo" #-} E - -then we want the CPR'd worker to look like - \ x -> {-# SCC "foo" #-} (case E of I# x -> x) -and definitely not - \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) - -This transform doesn't move work or allocation -from one cost centre to another. - -Later [SDM]: presumably this is because we want the simplifier to -eliminate the case, and the scc would get in the way? I'm ok with -including the case itself in the cost centre, since it is morally -part of the function (post transformation) anyway. - - -************************************************************************ -* * -\subsection{Utilities} -* * -************************************************************************ - -Note [Absent errors] -~~~~~~~~~~~~~~~~~~~~ -We make a new binding for Ids that are marked absent, thus - let x = absentError "x :: Int" -The idea is that this binding will never be used; but if it -buggily is used we'll get a runtime error message. - -Coping with absence for *unlifted* types is important; see, for -example, #4306 and #15627. In the UnliftedRep case, we can -use LitRubbish, which we need to apply to the required type. -For the unlifted types of singleton kind like Float#, Addr#, etc. we -also find a suitable literal, using Literal.absentLiteralOf. We don't -have literals for every primitive type, so the function is partial. - -Note: I did try the experiment of using an error thunk for unlifted -things too, relying on the simplifier to drop it as dead code. -But this is fragile - - - It fails when profiling is on, which disables various optimisations - - - It fails when reboxing happens. E.g. - data T = MkT Int Int# - f p@(MkT a _) = ...g p.... - where g is /lazy/ in 'p', but only uses the first component. Then - 'f' is /strict/ in 'p', and only uses the first component. So we only - pass that component to the worker for 'f', which reconstructs 'p' to - pass it to 'g'. Alas we can't say - ...f (MkT a (absentError Int# "blah"))... - bacause `MkT` is strict in its Int# argument, so we get an absentError - exception when we shouldn't. Very annoying! - -So absentError is only used for lifted types. --} - --- | Tries to find a suitable dummy RHS to bind the given absent identifier to. --- --- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding --- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be --- found (currently only happens for bindings of 'VecRep' representation). -mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let dflags arg - -- The lifted case: Bind 'absentError' - -- See Note [Absent errors] - | not (isUnliftedType arg_ty) - = Just (Let (NonRec lifted_arg abs_rhs)) - -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@ - -- See Note [Absent errors] - | [UnliftedRep] <- typePrimRep arg_ty - = Just (Let (NonRec arg unlifted_rhs)) - -- The monomorphic unlifted cases: Bind to some literal, if possible - -- See Note [Absent errors] - | Just tc <- tyConAppTyCon_maybe arg_ty - , Just lit <- absentLiteralOf tc - = Just (Let (NonRec arg (Lit lit))) - | arg_ty `eqType` voidPrimTy - = Just (Let (NonRec arg (Var voidPrimId))) - | otherwise - = WARN( True, text "No absent value for" <+> ppr arg_ty ) - Nothing -- Can happen for 'State#' and things of 'VecRep' - where - lifted_arg = arg `setIdStrictness` botSig - -- Note in strictness signature that this is bottoming - -- (for the sake of the "empty case scrutinee not known to - -- diverge for sure lint" warning) - arg_ty = idType arg - abs_rhs = mkAbsentErrorApp arg_ty msg - msg = showSDoc (gopt_set dflags Opt_SuppressUniques) - (ppr arg <+> ppr (idType arg)) - -- We need to suppress uniques here because otherwise they'd - -- end up in the generated code as strings. This is bad for - -- determinism, because with different uniques the strings - -- will have different lengths and hence different costs for - -- the inliner leading to different inlining. - -- See also Note [Unique Determinism] in Unique - unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] - -mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id --- The StrictnessMark comes form the data constructor and says --- whether this field is strict --- See Note [Record evaluated-ness in worker/wrapper] -mk_ww_local uniq (ty,str) - = setCaseBndrEvald str $ - mkSysLocalOrCoVar (fsLit "ww") uniq ty diff --git a/typecheck/ClsInst.hs b/typecheck/ClsInst.hs deleted file mode 100644 --- a/typecheck/ClsInst.hs +++ /dev/null @@ -1,712 +0,0 @@ -{-# LANGUAGE CPP #-} - -module ClsInst ( - matchGlobalInst, - ClsInstResult(..), - InstanceWhat(..), safeOverlap, instanceReturnsDictCon, - AssocInstInfo(..), isNotAssociated - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcEnv -import TcRnMonad -import TcType -import TcTypeable -import TcMType -import TcEvidence -import Predicate -import RnEnv( addUsedGRE ) -import RdrName( lookupGRE_FieldLabel ) -import InstEnv -import Inst( instDFunType ) -import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) - -import TysWiredIn -import TysPrim( eqPrimTyCon, eqReprPrimTyCon ) -import PrelNames - -import Id -import Type -import MkCore ( mkStringExprFS, mkNaturalExpr ) - -import Name ( Name, pprDefinedAt ) -import VarEnv ( VarEnv ) -import DataCon -import TyCon -import Class -import DynFlags -import Outputable -import Util( splitAtList, fstOf3 ) -import Data.Maybe - -{- ******************************************************************* -* * - A helper for associated types within - class instance declarations -* * -**********************************************************************-} - --- | Extra information about the parent instance declaration, needed --- when type-checking associated types. The 'Class' is the enclosing --- class, the [TyVar] are the /scoped/ type variable of the instance decl. --- The @VarEnv Type@ maps class variables to their instance types. -data AssocInstInfo - = NotAssociated - | InClsInst { ai_class :: Class - , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance - -- Why scoped? See bind_me in - -- TcValidity.checkConsistentFamInst - , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types - -- See Note [Matching in the consistent-instantation check] - } - -isNotAssociated :: AssocInstInfo -> Bool -isNotAssociated NotAssociated = True -isNotAssociated (InClsInst {}) = False - - -{- ******************************************************************* -* * - Class lookup -* * -**********************************************************************-} - --- | Indicates if Instance met the Safe Haskell overlapping instances safety --- check. --- --- See Note [Safe Haskell Overlapping Instances] in TcSimplify --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -type SafeOverlapping = Bool - -data ClsInstResult - = NoInstance -- Definitely no instance - - | OneInst { cir_new_theta :: [TcPredType] - , cir_mk_ev :: [EvExpr] -> EvTerm - , cir_what :: InstanceWhat } - - | NotSure -- Multiple matches and/or one or more unifiers - -data InstanceWhat - = BuiltinInstance - | BuiltinEqInstance -- A built-in "equality instance"; see the - -- TcSMonad Note [Solved dictionaries] - | LocalInstance - | TopLevInstance { iw_dfun_id :: DFunId - , iw_safe_over :: SafeOverlapping } - -instance Outputable ClsInstResult where - ppr NoInstance = text "NoInstance" - ppr NotSure = text "NotSure" - ppr (OneInst { cir_new_theta = ev - , cir_what = what }) - = text "OneInst" <+> vcat [ppr ev, ppr what] - -instance Outputable InstanceWhat where - ppr BuiltinInstance = text "a built-in instance" - ppr BuiltinEqInstance = text "a built-in equality instance" - ppr LocalInstance = text "a locally-quantified instance" - ppr (TopLevInstance { iw_dfun_id = dfun }) - = hang (text "instance" <+> pprSigmaType (idType dfun)) - 2 (text "--" <+> pprDefinedAt (idName dfun)) - -safeOverlap :: InstanceWhat -> Bool -safeOverlap (TopLevInstance { iw_safe_over = so }) = so -safeOverlap _ = True - -instanceReturnsDictCon :: InstanceWhat -> Bool --- See Note [Solved dictionaries] in TcSMonad -instanceReturnsDictCon (TopLevInstance {}) = True -instanceReturnsDictCon BuiltinInstance = True -instanceReturnsDictCon BuiltinEqInstance = False -instanceReturnsDictCon LocalInstance = False - -matchGlobalInst :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchGlobalInst dflags short_cut clas tys - | cls_name == knownNatClassName - = matchKnownNat dflags short_cut clas tys - | cls_name == knownSymbolClassName - = matchKnownSymbol dflags short_cut clas tys - | isCTupleClass clas = matchCTuple clas tys - | cls_name == typeableClassName = matchTypeable clas tys - | clas `hasKey` heqTyConKey = matchHeteroEquality tys - | clas `hasKey` eqTyConKey = matchHomoEquality tys - | clas `hasKey` coercibleTyConKey = matchCoercible tys - | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys - | otherwise = matchInstEnv dflags short_cut clas tys - where - cls_name = className clas - - -{- ******************************************************************** -* * - Looking in the instance environment -* * -***********************************************************************-} - - -matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult -matchInstEnv dflags short_cut_solver clas tys - = do { instEnvs <- tcGetInstEnvs - ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] - (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys - safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) - ; traceTc "matchInstEnv" $ - vcat [ text "goal:" <+> ppr clas <+> ppr tys - , text "matches:" <+> ppr matches - , text "unify:" <+> ppr unify ] - ; case (matches, unify, safeHaskFail) of - - -- Nothing matches - ([], [], _) - -> do { traceTc "matchClass not matching" (ppr pred) - ; return NoInstance } - - -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], [], False) - | short_cut_solver -- Called from the short-cut solver - , isOverlappable ispec - -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT - -- then don't let the short-cut solver choose it, because a - -- later instance might overlap it. #14434 is an example - -- See Note [Shortcut solving: overlap] - -> do { traceTc "matchClass: ignoring overlappable" (ppr pred) - ; return NotSure } - - | otherwise - -> do { let dfun_id = instanceDFunId ispec - ; traceTc "matchClass success" $ - vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ] - -- Record that this dfun is needed - ; match_one (null unsafeOverlaps) dfun_id inst_tys } - - -- More than one matches (or Safe Haskell fail!). Defer any - -- reactions of a multitude until we learn more about the reagent - _ -> do { traceTc "matchClass multiple matches, deferring choice" $ - vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches] - ; return NotSure } } - where - pred = mkClassPred clas tys - -match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult - -- See Note [DFunInstType: instantiating types] in InstEnv -match_one so dfun_id mb_inst_tys - = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys) - ; (tys, theta) <- instDFunType dfun_id mb_inst_tys - ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta) - ; return $ OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = TopLevInstance { iw_dfun_id = dfun_id - , iw_safe_over = so } } } - - -{- Note [Shortcut solving: overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - instance {-# OVERLAPPABLE #-} C a where ... -and we are typechecking - f :: C a => a -> a - f = e -- Gives rise to [W] C a - -We don't want to solve the wanted constraint with the overlappable -instance; rather we want to use the supplied (C a)! That was the whole -point of it being overlappable! #14434 wwas an example. - -Alas even if the instance has no overlap flag, thus - instance C a where ... -there is nothing to stop it being overlapped. GHC provides no way to -declare an instance as "final" so it can't be overlapped. But really -only final instances are OK for short-cut solving. Sigh. #15135 -was a puzzling example. --} - - -{- ******************************************************************** -* * - Class lookup for CTuples -* * -***********************************************************************-} - -matchCTuple :: Class -> [Type] -> TcM ClsInstResult -matchCTuple clas tys -- (isCTupleClass clas) holds - = return (OneInst { cir_new_theta = tys - , cir_mk_ev = tuple_ev - , cir_what = BuiltinInstance }) - -- The dfun *is* the data constructor! - where - data_con = tyConSingleDataCon (classTyCon clas) - tuple_ev = evDFunApp (dataConWrapId data_con) tys - -{- ******************************************************************** -* * - Class lookup for Literals -* * -***********************************************************************-} - -{- -Note [KnownNat & KnownSymbol and EvLit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A part of the type-level literals implementation are the classes -"KnownNat" and "KnownSymbol", which provide a "smart" constructor for -defining singleton values. Here is the key stuff from GHC.TypeLits - - class KnownNat (n :: Nat) where - natSing :: SNat n - - newtype SNat (n :: Nat) = SNat Integer - -Conceptually, this class has infinitely many instances: - - instance KnownNat 0 where natSing = SNat 0 - instance KnownNat 1 where natSing = SNat 1 - instance KnownNat 2 where natSing = SNat 2 - ... - -In practice, we solve `KnownNat` predicates in the type-checker -(see typecheck/TcInteract.hs) because we can't have infinitely many instances. -The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`. - -We make the following assumptions about dictionaries in GHC: - 1. The "dictionary" for classes with a single method---like `KnownNat`---is - a newtype for the type of the method, so using a evidence amounts - to a coercion, and - 2. Newtypes use the same representation as their definition types. - -So, the evidence for `KnownNat` is just a value of the representation type, -wrapped in two newtype constructors: one to make it into a `SNat` value, -and another to make it into a `KnownNat` dictionary. - -Also note that `natSing` and `SNat` are never actually exposed from the -library---they are just an implementation detail. Instead, users see -a more convenient function, defined in terms of `natSing`: - - natVal :: KnownNat n => proxy n -> Integer - -The reason we don't use this directly in the class is that it is simpler -and more efficient to pass around an integer rather than an entire function, -especially when the `KnowNat` evidence is packaged up in an existential. - -The story for kind `Symbol` is analogous: - * class KnownSymbol - * newtype SSymbol - * Evidence: a Core literal (e.g. mkNaturalExpr) - - -Note [Fabricating Evidence for Literals in Backpack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Let `T` be a type of kind `Nat`. When solving for a purported instance -of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`, -in which case the evidence `EvLit (EvNum n)` is generated on the -fly. It might appear that this is sufficient as users cannot define -their own instances of `KnownNat`. However, for backpack module this -would not work (see issue #15379). Consider the signature `Abstract` - -> signature Abstract where -> data T :: Nat -> instance KnownNat T - -and a module `Util` that depends on it: - -> module Util where -> import Abstract -> printT :: IO () -> printT = do print $ natVal (Proxy :: Proxy T) - -Clearly, we need to "use" the dictionary associated with `KnownNat T` -in the module `Util`, but it is too early for the compiler to produce -a real dictionary as we still have not fixed what `T` is. Only when we -mixin a concrete module - -> module Concrete where -> type T = 42 - -do we really get hold of the underlying integer. So the strategy that -we follow is the following - -1. If T is indeed available as a type alias for an integer constant, - generate the dictionary on the fly, failing which - -2. Look up the type class environment for the evidence. - -Finally actual code gets generate for Util only when a module like -Concrete gets "mixed-in" in place of the signature Abstract. As a -result all things, including the typeclass instances, in Concrete gets -reexported. So `KnownNat` gets resolved the normal way post-Backpack. - -A similar generation works for `KnownSymbol` as well - --} - -matchKnownNat :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchKnownNat _ _ clas [ty] -- clas = KnownNat - | Just n <- isNumLitTy ty = do - et <- mkNaturalExpr n - makeLitDict clas ty et -matchKnownNat df sc clas tys = matchInstEnv df sc clas tys - -- See Note [Fabricating Evidence for Literals in Backpack] for why - -- this lookup into the instance environment is required. - -matchKnownSymbol :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchKnownSymbol _ _ clas [ty] -- clas = KnownSymbol - | Just s <- isStrLitTy ty = do - et <- mkStringExprFS s - makeLitDict clas ty et -matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys - -- See Note [Fabricating Evidence for Literals in Backpack] for why - -- this lookup into the instance environment is required. - -makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult --- makeLitDict adds a coercion that will convert the literal into a dictionary --- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] --- in TcEvidence. The coercion happens in 2 steps: --- --- Integer -> SNat n -- representation of literal to singleton --- SNat n -> KnownNat n -- singleton to dictionary --- --- The process is mirrored for Symbols: --- String -> SSymbol n --- SSymbol n -> KnownSymbol n -makeLitDict clas ty et - | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] - -- co_dict :: KnownNat n ~ SNat n - , [ meth ] <- classMethods clas - , Just tcRep <- tyConAppTyCon_maybe -- SNat - $ funResultTy -- SNat n - $ dropForAlls -- KnownNat n => SNat n - $ idType meth -- forall n. KnownNat n => SNat n - , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] - -- SNat n ~ Integer - , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) - = return $ OneInst { cir_new_theta = [] - , cir_mk_ev = \_ -> ev_tm - , cir_what = BuiltinInstance } - - | otherwise - = pprPanic "makeLitDict" $ - text "Unexpected evidence for" <+> ppr (className clas) - $$ vcat (map (ppr . idType) (classMethods clas)) - -{- ******************************************************************** -* * - Class lookup for Typeable -* * -***********************************************************************-} - --- | Assumes that we've checked that this is the 'Typeable' class, --- and it was applied to the correct argument. -matchTypeable :: Class -> [Type] -> TcM ClsInstResult -matchTypeable clas [k,t] -- clas = Typeable - -- For the first two cases, See Note [No Typeable for polytypes or qualified types] - | isForAllTy k = return NoInstance -- Polytype - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type - - -- Now cases that do work - | k `eqType` typeNatKind = doTyLit knownNatClassName t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] - | Just (arg,ret) <- splitFunTy_maybe t = doFunTy clas t arg ret - | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] - , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks - | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt - -matchTypeable _ _ = return NoInstance - --- | Representation for a type @ty@ of the form @arg -> ret@. -doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult -doFunTy clas ty arg_ty ret_ty - = return $ OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } - where - preds = map (mk_typeable_pred clas) [arg_ty, ret_ty] - mk_ev [arg_ev, ret_ev] = evTypeable ty $ - EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev) - mk_ev _ = panic "TcInteract.doFunTy" - - --- | Representation for type constructor applied to some kinds. --- 'onlyNamedBndrsApplied' has ensured that this application results in a type --- of monomorphic kind (e.g. all kind variables have been instantiated). -doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult -doTyConApp clas ty tc kind_args - | tyConIsTypeable tc - = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args) - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } - | otherwise - = return NoInstance - where - mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds) - --- | Representation for TyCon applications of a concrete kind. We just use the --- kind itself, but first we must make sure that we've instantiated all kind- --- polymorphism, but no more. -onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool -onlyNamedBndrsApplied tc ks - = all isNamedTyConBinder used_bndrs && - not (any isNamedTyConBinder leftover_bndrs) - where - bndrs = tyConBinders tc - (used_bndrs, leftover_bndrs) = splitAtList ks bndrs - -doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult --- Representation for an application of a type to a type-or-kind. --- This may happen when the type expression starts with a type variable. --- Example (ignoring kind parameter): --- Typeable (f Int Char) --> --- (Typeable (f Int), Typeable Char) --> --- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) --- Typeable f -doTyApp clas ty f tk - | isForAllTy (tcTypeKind f) - = return NoInstance -- We can't solve until we know the ctr. - | otherwise - = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } - where - mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) - mk_ev _ = panic "doTyApp" - - --- Emit a `Typeable` constraint for the given type. -mk_typeable_pred :: Class -> Type -> PredType -mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ] - - -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal - -- we generate a sub-goal for the appropriate class. - -- See Note [Typeable for Nat and Symbol] -doTyLit :: Name -> Type -> TcM ClsInstResult -doTyLit kc t = do { kc_clas <- tcLookupClass kc - ; let kc_pred = mkClassPred kc_clas [ t ] - mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) - mk_ev _ = panic "doTyLit" - ; return (OneInst { cir_new_theta = [kc_pred] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance }) } - -{- Note [Typeable (T a b c)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For type applications we always decompose using binary application, -via doTyApp, until we get to a *kind* instantiation. Example - Proxy :: forall k. k -> * - -To solve Typeable (Proxy (* -> *) Maybe) we - - First decompose with doTyApp, - to get (Typeable (Proxy (* -> *))) and Typeable Maybe - - Then solve (Typeable (Proxy (* -> *))) with doTyConApp - -If we attempt to short-cut by solving it all at once, via -doTyConApp - -(this note is sadly truncated FIXME) - - -Note [No Typeable for polytypes or qualified types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not support impredicative typeable, such as - Typeable (forall a. a->a) - Typeable (Eq a => a -> a) - Typeable (() => Int) - Typeable (((),()) => Int) - -See #9858. For forall's the case is clear: we simply don't have -a TypeRep for them. For qualified but not polymorphic types, like -(Eq a => a -> a), things are murkier. But: - - * We don't need a TypeRep for these things. TypeReps are for - monotypes only. - - * Perhaps we could treat `=>` as another type constructor for `Typeable` - purposes, and thus support things like `Eq Int => Int`, however, - at the current state of affairs this would be an odd exception as - no other class works with impredicative types. - For now we leave it off, until we have a better story for impredicativity. - - -Note [Typeable for Nat and Symbol] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have special Typeable instances for Nat and Symbol. Roughly we -have this instance, implemented here by doTyLit: - instance KnownNat n => Typeable (n :: Nat) where - typeRep = typeNatTypeRep @n -where - Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a - -Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a -runtime value 'n'; it turns it into a string with 'show' and uses -that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon. -See #10348. - -Because of this rule it's inadvisable (see #15322) to have a constraint - f :: (Typeable (n :: Nat)) => blah -in a function signature; it gives rise to overlap problems just as -if you'd written - f :: Eq [a] => blah --} - -{- ******************************************************************** -* * - Class lookup for lifted equality -* * -***********************************************************************-} - --- See also Note [The equality types story] in TysPrim -matchHeteroEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~~ t2) -matchHeteroEquality args - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ] - , cir_mk_ev = evDataConApp heqDataCon args - , cir_what = BuiltinEqInstance }) - -matchHomoEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~ t2) -matchHomoEquality args@[k,t1,t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ] - , cir_mk_ev = evDataConApp eqDataCon args - , cir_what = BuiltinEqInstance }) -matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args) - --- See also Note [The equality types story] in TysPrim -matchCoercible :: [Type] -> TcM ClsInstResult -matchCoercible args@[k, t1, t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] - , cir_mk_ev = evDataConApp coercibleDataCon args - , cir_what = BuiltinEqInstance }) - where - args' = [k, k, t1, t2] -matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args) - - -{- ******************************************************************** -* * - Class lookup for overloaded record fields -* * -***********************************************************************-} - -{- -Note [HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T y = MkT { foo :: [y] } - -and `foo` is in scope. Then GHC will automatically solve a constraint like - - HasField "foo" (T Int) b - -by emitting a new wanted - - T alpha -> [alpha] ~# T Int -> b - -and building a HasField dictionary out of the selector function `foo`, -appropriately cast. - -The HasField class is defined (in GHC.Records) thus: - - class HasField (x :: k) r a | x r -> a where - getField :: r -> a - -Since this is a one-method class, it is represented as a newtype. -Hence we can solve `HasField "foo" (T Int) b` by taking an expression -of type `T Int -> b` and casting it using the newtype coercion. -Note that - - foo :: forall y . T y -> [y] - -so the expression we construct is - - foo @alpha |> co - -where - - co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b - -is built from - - co1 :: (T alpha -> [alpha]) ~# (T Int -> b) - -which is the new wanted, and - - co2 :: (T Int -> b) ~# HasField "foo" (T Int) b - -which can be derived from the newtype coercion. - -If `foo` is not in scope, or has a higher-rank or existentially -quantified type, then the constraint is not solved automatically, but -may be solved by a user-supplied HasField instance. Similarly, if we -encounter a HasField constraint where the field is not a literal -string, or does not belong to the type, then we fall back on the -normal constraint solver behaviour. --} - --- See Note [HasField instances] -matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult -matchHasField dflags short_cut clas tys - = do { fam_inst_envs <- tcGetFamInstEnvs - ; rdr_env <- getGlobalRdrEnv - ; case tys of - -- We are matching HasField {k} x r a... - [_k_ty, x_ty, r_ty, a_ty] - -- x should be a literal string - | Just x <- isStrLitTy x_ty - -- r should be an applied type constructor - , Just (tc, args) <- tcSplitTyConApp_maybe r_ty - -- use representation tycon (if data family); it has the fields - , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) - -- x should be a field of r - , Just fl <- lookupTyConFieldLabel x r_tc - -- the field selector should be in scope - , Just gre <- lookupGRE_FieldLabel rdr_env fl - - -> do { sel_id <- tcLookupId (flSelector fl) - ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id - - -- The first new wanted constraint equates the actual - -- type of the selector with the type (r -> a) within - -- the HasField x r a dictionary. The preds will - -- typically be empty, but if the datatype has a - -- "stupid theta" then we have to include it here. - ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds - - -- Use the equality proof to cast the selector Id to - -- type (r -> a), then use the newtype coercion to cast - -- it to a HasField dictionary. - mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co - where - co = mkTcSubCo (evTermCoercion (EvExpr ev1)) - `mkTcTransCo` mkTcSymCo co2 - mk_ev [] = panic "matchHasField.mk_ev" - - Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) - tys - - tvs = mkTyVarTys (map snd tv_prs) - - -- The selector must not be "naughty" (i.e. the field - -- cannot have an existentially quantified type), and - -- it must not be higher-rank. - ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty - then do { addUsedGRE True gre - ; return OneInst { cir_new_theta = theta - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } } - else matchInstEnv dflags short_cut clas tys } - - _ -> matchInstEnv dflags short_cut clas tys } diff --git a/typecheck/Constraint.hs b/typecheck/Constraint.hs deleted file mode 100644 --- a/typecheck/Constraint.hs +++ /dev/null @@ -1,1832 +0,0 @@ -{- - -This module defines types and simple operations over constraints, -as used in the type-checker and constraint solver. - --} - -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} - -module Constraint ( - -- QCInst - QCInst(..), isPendingScInst, - - -- Canonical constraints - Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, - singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, - isEmptyCts, isCTyEqCan, isCFunEqCan, - isPendingScDict, superClassesMightHelp, getPendingWantedScs, - isCDictCan_Maybe, isCFunEqCan_maybe, - isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, - isUserTypeErrorCt, getUserTypeErrorMsg, - ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, - ctEvId, mkTcEqPredLikeEv, - mkNonCanonical, mkNonCanonicalCt, mkGivens, - mkIrredCt, mkInsolubleCt, - ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, - ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, - tyCoVarsOfCt, tyCoVarsOfCts, - tyCoVarsOfCtList, tyCoVarsOfCtsList, - - WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, - isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, - addInsols, insolublesOnly, addSimples, addImplics, - tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, - tyCoVarsOfWCList, insolubleCt, insolubleEqCt, - isDroppableCt, insolubleImplic, - arisesFromGivens, - - Implication(..), implicationPrototype, - ImplicStatus(..), isInsolubleStatus, isSolvedStatus, - SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, - bumpSubGoalDepth, subGoalDepthExceeded, - CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, - ctLocTypeOrKind_maybe, - ctLocDepth, bumpCtLocDepth, isGivenLoc, - setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, - pprCtLoc, - - -- CtEvidence - CtEvidence(..), TcEvDest(..), - mkKindLoc, toKindLoc, mkGivenLoc, - isWanted, isGiven, isDerived, isGivenOrWDeriv, - ctEvRole, - - wrapType, wrapTypeWithImplication, - - CtFlavour(..), ShadowInfo(..), ctEvFlavour, - CtFlavourRole, ctEvFlavourRole, ctFlavourRole, - eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR, - eqCanDischargeFR, - funEqCanDischarge, funEqCanDischargeF, - - -- Pretty printing - pprEvVarTheta, - pprEvVars, pprEvVarWithType, - - -- holes - Hole(..), holeOcc, - - ) - where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcRnTypes ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel - , setLclEnvLoc, getLclEnvLoc ) - -import GHC.Hs.Expr ( UnboundVar(..), unboundVarOcc ) -import Predicate -import Type -import Coercion -import Class -import TyCon -import Var -import Id - -import TcType -import TcEvidence -import TcOrigin - -import CoreSyn - -import TyCoPpr -import OccName -import FV -import VarSet -import DynFlags -import BasicTypes - -import Outputable -import SrcLoc -import Bag -import Util - -import Control.Monad ( msum ) - -{- -************************************************************************ -* * -* Canonical constraints * -* * -* These are the constraints the low-level simplifier works with * -* * -************************************************************************ --} - --- The syntax of xi (ξ) types: --- xi ::= a | T xis | xis -> xis | ... | forall a. tau --- Two important notes: --- (i) No type families, unless we are under a ForAll --- (ii) Note that xi types can contain unexpanded type synonyms; --- however, the (transitive) expansions of those type synonyms --- will not contain any type functions, unless we are under a ForAll. --- We enforce the structure of Xi types when we flatten (TcCanonical) - -type Xi = Type -- In many comments, "xi" ranges over Xi - -type Cts = Bag Ct - -data Ct - -- Atomic canonical constraints - = CDictCan { -- e.g. Num xi - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - - cc_class :: Class, - cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi - - cc_pend_sc :: Bool -- See Note [The superclass story] in TcCanonical - -- True <=> (a) cc_class has superclasses - -- (b) we have not (yet) added those - -- superclasses as Givens - } - - | CIrredCan { -- These stand for yet-unusable predicates - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_insol :: Bool -- True <=> definitely an error, can never be solved - -- False <=> might be soluble - - -- For the might-be-soluble case, the ctev_pred of the evidence is - -- of form (tv xi1 xi2 ... xin) with a tyvar at the head - -- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails - -- or (F tys ~ ty) where the CFunEqCan kind invariant fails - -- See Note [CIrredCan constraints] - - -- The definitely-insoluble case is for things like - -- Int ~ Bool tycons don't match - -- a ~ [a] occurs check - } - - | CTyEqCan { -- tv ~ rhs - -- Invariants: - -- * See Note [inert_eqs: the inert equalities] in TcSMonad - -- * tv not in tvs(rhs) (occurs check) - -- * If tv is a TauTv, then rhs has no foralls - -- (this avoids substituting a forall for the tyvar in other types) - -- * tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] - -- * rhs may have at most one top-level cast - -- * rhs (perhaps under the one cast) is *almost function-free*, - -- See Note [Almost function-free] - -- * If the equality is representational, rhs has no top-level newtype - -- See Note [No top-level newtypes on RHS of representational - -- equalities] in TcCanonical - -- * If rhs (perhaps under the cast) is also a tv, then it is oriented - -- to give best chance of - -- unification happening; eg if rhs is touchable then lhs is too - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_tyvar :: TcTyVar, - cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) - -- See invariants above - - cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev - } - - | CFunEqCan { -- F xis ~ fsk - -- Invariants: - -- * isTypeFamilyTyCon cc_fun - -- * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant] - -- * always Nominal role - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_fun :: TyCon, -- A type function - - cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) - -- Either under-saturated or exactly saturated - -- *never* over-saturated (because if so - -- we should have decomposed) - - cc_fsk :: TcTyVar -- [G] always a FlatSkolTv - -- [W], [WD], or [D] always a FlatMetaTv - -- See Note [The flattening story] in TcFlatten - } - - | CNonCanonical { -- See Note [NonCanonical Semantics] in TcSMonad - cc_ev :: CtEvidence - } - - | CHoleCan { -- See Note [Hole constraints] - -- Treated as an "insoluble" constraint - -- See Note [Insoluble constraints] - cc_ev :: CtEvidence, - cc_hole :: Hole - } - - | CQuantCan QCInst -- A quantified constraint - -- NB: I expect to make more of the cases in Ct - -- look like this, with the payload in an - -- auxiliary type - ------------- -data QCInst -- A much simplified version of ClsInst - -- See Note [Quantified constraints] in TcCanonical - = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty - -- Always Given - , qci_tvs :: [TcTyVar] -- The tvs - , qci_pred :: TcPredType -- The ty - , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan - -- Invariant: True => qci_pred is a ClassPred - } - -instance Outputable QCInst where - ppr (QCI { qci_ev = ev }) = ppr ev - ------------- --- | An expression or type hole -data Hole = ExprHole UnboundVar - -- ^ Either an out-of-scope variable or a "true" hole in an - -- expression (TypedHoles) - | TypeHole OccName - -- ^ A hole in a type (PartialTypeSignatures) - -instance Outputable Hole where - ppr (ExprHole ub) = ppr ub - ppr (TypeHole occ) = text "TypeHole" <> parens (ppr occ) - -holeOcc :: Hole -> OccName -holeOcc (ExprHole uv) = unboundVarOcc uv -holeOcc (TypeHole occ) = occ - -{- Note [Hole constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -CHoleCan constraints are used for two kinds of holes, -distinguished by cc_hole: - - * For holes in expressions (includings variables not in scope) - e.g. f x = g _ x - - * For holes in type signatures - e.g. f :: _ -> _ - f x = [x,True] - -Note [CIrredCan constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CIrredCan constraints are used for constraints that are "stuck" - - we can't solve them (yet) - - we can't use them to solve other constraints - - but they may become soluble if we substitute for some - of the type variables in the constraint - -Example 1: (c Int), where c :: * -> Constraint. We can't do anything - with this yet, but if later c := Num, *then* we can solve it - -Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable - We don't want to use this to substitute 'b' for 'a', in case - 'k' is subsequently unifed with (say) *->*, because then - we'd have ill-kinded types floating about. Rather we want - to defer using the equality altogether until 'k' get resolved. - -Note [Ct/evidence invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field -of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, - ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) -This holds by construction; look at the unique place where CDictCan is -built (in TcCanonical). - -In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in -the evidence may *not* be fully zonked; we are careful not to look at it -during constraint solving. See Note [Evidence field of CtEvidence]. - -Note [Ct kind invariant] -~~~~~~~~~~~~~~~~~~~~~~~~ -CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind -of the rhs. This is necessary because both constraints are used for substitutions -during solving. If the kinds differed, then the substitution would take a well-kinded -type to an ill-kinded one. - -Note [Almost function-free] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type is *almost function-free* if it has no type functions (something that -responds True to isTypeFamilyTyCon), except (possibly) - * under a forall, or - * in a coercion (either in a CastTy or a CercionTy) - -The RHS of a CTyEqCan must be almost function-free. This is for two reasons: - -1. There cannot be a top-level function. If there were, the equality should - really be a CFunEqCan, not a CTyEqCan. - -2. Nested functions aren't too bad, on the other hand. However, consider this - scenario: - - type family F a = r | r -> a - - [D] F ty1 ~ fsk1 - [D] F ty2 ~ fsk2 - [D] fsk1 ~ [G Int] - [D] fsk2 ~ [G Bool] - - type instance G Int = Char - type instance G Bool = Char - - If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 -- - good! They don't look equal -- but if we aggressively reduce that G Int and - G Bool they would become equal. The "almost function free" makes sure that - these redexes are exposed. - - Note that this equality does *not* depend on casts or coercions, and so - skipping these forms is OK. In addition, the result of a type family cannot - be a polytype, so skipping foralls is OK, too. We skip foralls because we - want the output of the flattener to be almost function-free. See Note - [Flattening under a forall] in TcFlatten. - - As I (Richard E) write this, it is unclear if the scenario pictured above - can happen -- I would expect the G Int and G Bool to be reduced. But - perhaps it can arise somehow, and maintaining almost function-free is cheap. - -Historical note: CTyEqCans used to require only condition (1) above: that no -type family was at the top of an RHS. But work on #16512 suggested that the -injectivity checks were not complete, and adding the requirement that functions -do not appear even in a nested fashion was easy (it was already true, but -unenforced). - -The almost-function-free property is checked by isAlmostFunctionFree in TcType. -The flattener (in TcFlatten) produces types that are almost function-free. - --} - -mkNonCanonical :: CtEvidence -> Ct -mkNonCanonical ev = CNonCanonical { cc_ev = ev } - -mkNonCanonicalCt :: Ct -> Ct -mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } - -mkIrredCt :: CtEvidence -> Ct -mkIrredCt ev = CIrredCan { cc_ev = ev, cc_insol = False } - -mkInsolubleCt :: CtEvidence -> Ct -mkInsolubleCt ev = CIrredCan { cc_ev = ev, cc_insol = True } - -mkGivens :: CtLoc -> [EvId] -> [Ct] -mkGivens loc ev_ids - = map mk ev_ids - where - mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id - , ctev_pred = evVarPred ev_id - , ctev_loc = loc }) - -ctEvidence :: Ct -> CtEvidence -ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev -ctEvidence ct = cc_ev ct - -ctLoc :: Ct -> CtLoc -ctLoc = ctEvLoc . ctEvidence - -setCtLoc :: Ct -> CtLoc -> Ct -setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } } - -ctOrigin :: Ct -> CtOrigin -ctOrigin = ctLocOrigin . ctLoc - -ctPred :: Ct -> PredType --- See Note [Ct/evidence invariant] -ctPred ct = ctEvPred (ctEvidence ct) - -ctEvId :: Ct -> EvVar --- The evidence Id for this Ct -ctEvId ct = ctEvEvId (ctEvidence ct) - --- | Makes a new equality predicate with the same role as the given --- evidence. -mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType -mkTcEqPredLikeEv ev - = case predTypeEqRel pred of - NomEq -> mkPrimEqPred - ReprEq -> mkReprPrimEqPred - where - pred = ctEvPred ev - --- | Get the flavour of the given 'Ct' -ctFlavour :: Ct -> CtFlavour -ctFlavour = ctEvFlavour . ctEvidence - --- | Get the equality relation for the given 'Ct' -ctEqRel :: Ct -> EqRel -ctEqRel = ctEvEqRel . ctEvidence - -instance Outputable Ct where - ppr ct = ppr (ctEvidence ct) <+> parens pp_sort - where - pp_sort = case ct of - CTyEqCan {} -> text "CTyEqCan" - CFunEqCan {} -> text "CFunEqCan" - CNonCanonical {} -> text "CNonCanonical" - CDictCan { cc_pend_sc = pend_sc } - | pend_sc -> text "CDictCan(psc)" - | otherwise -> text "CDictCan" - CIrredCan { cc_insol = insol } - | insol -> text "CIrredCan(insol)" - | otherwise -> text "CIrredCan(sol)" - CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr hole - CQuantCan (QCI { qci_pend_sc = pend_sc }) - | pend_sc -> text "CQuantCan(psc)" - | otherwise -> text "CQuantCan" - -{- -************************************************************************ -* * - Simple functions over evidence variables -* * -************************************************************************ --} - ----------------- Getting free tyvars ------------------------- - --- | Returns free variables of constraints as a non-deterministic set -tyCoVarsOfCt :: Ct -> TcTyCoVarSet -tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt - --- | Returns free variables of constraints as a deterministically ordered. --- list. See Note [Deterministic FV] in FV. -tyCoVarsOfCtList :: Ct -> [TcTyCoVar] -tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt - --- | Returns free variables of constraints as a composable FV computation. --- See Note [Deterministic FV] in FV. -tyCoFVsOfCt :: Ct -> FV -tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) - = tyCoFVsOfType xi `unionFV` FV.unitFV tv - `unionFV` tyCoFVsOfType (tyVarKind tv) -tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) - = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk - `unionFV` tyCoFVsOfType (tyVarKind fsk) -tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys -tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) - --- | Returns free variables of a bag of constraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. -tyCoVarsOfCts :: Cts -> TcTyCoVarSet -tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a deterministically --- odered list. See Note [Deterministic FV] in FV. -tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] -tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a composable FV --- computation. See Note [Deterministic FV] in FV. -tyCoFVsOfCts :: Cts -> FV -tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV - --- | Returns free variables of WantedConstraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. -tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a deterministically --- ordered list. See Note [Deterministic FV] in FV. -tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a composable FV --- computation. See Note [Deterministic FV] in FV. -tyCoFVsOfWC :: WantedConstraints -> FV --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic }) - = tyCoFVsOfCts simple `unionFV` - tyCoFVsOfBag tyCoFVsOfImplic implic - --- | Returns free variables of Implication as a composable FV computation. --- See Note [Deterministic FV] in FV. -tyCoFVsOfImplic :: Implication -> FV --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoFVsOfImplic (Implic { ic_skols = skols - , ic_given = givens - , ic_wanted = wanted }) - | isEmptyWC wanted - = emptyFV - | otherwise - = tyCoFVsVarBndrs skols $ - tyCoFVsVarBndrs givens $ - tyCoFVsOfWC wanted - -tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV -tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV - ---------------------------- -dropDerivedWC :: WantedConstraints -> WantedConstraints --- See Note [Dropping derived constraints] -dropDerivedWC wc@(WC { wc_simple = simples }) - = wc { wc_simple = dropDerivedSimples simples } - -- The wc_impl implications are already (recursively) filtered - --------------------------- -dropDerivedSimples :: Cts -> Cts --- Drop all Derived constraints, but make [W] back into [WD], --- so that if we re-simplify these constraints we will get all --- the right derived constraints re-generated. Forgetting this --- step led to #12936 -dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples - -dropDerivedCt :: Ct -> Maybe Ct -dropDerivedCt ct - = case ctEvFlavour ev of - Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) - Wanted _ -> Just ct' - _ | isDroppableCt ct -> Nothing - | otherwise -> Just ct - where - ev = ctEvidence ct - ev_wd = ev { ctev_nosh = WDeriv } - ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] - -{- Note [Resetting cc_pend_sc] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we discard Derived constraints, in dropDerivedSimples, we must -set the cc_pend_sc flag to True, so that if we re-process this -CDictCan we will re-generate its derived superclasses. Otherwise -we might miss some fundeps. #13662 showed this up. - -See Note [The superclass story] in TcCanonical. --} - -isDroppableCt :: Ct -> Bool -isDroppableCt ct - = isDerived ev && not keep_deriv - -- Drop only derived constraints, and then only if they - -- obey Note [Dropping derived constraints] - where - ev = ctEvidence ct - loc = ctEvLoc ev - orig = ctLocOrigin loc - - keep_deriv - = case ct of - CHoleCan {} -> True - CIrredCan { cc_insol = insoluble } - -> keep_eq insoluble - _ -> keep_eq False - - keep_eq definitely_insoluble - | isGivenOrigin orig -- Arising only from givens - = definitely_insoluble -- Keep only definitely insoluble - | otherwise - = case orig of - KindEqOrigin {} -> True -- See Note [Dropping derived constraints] - - -- See Note [Dropping derived constraints] - -- For fundeps, drop wanted/wanted interactions - FunDepOrigin2 {} -> True -- Top-level/Wanted - FunDepOrigin1 _ orig1 _ _ orig2 _ - | g1 || g2 -> True -- Given/Wanted errors: keep all - | otherwise -> False -- Wanted/Wanted errors: discard - where - g1 = isGivenOrigin orig1 - g2 = isGivenOrigin orig2 - - _ -> False - -arisesFromGivens :: Ct -> Bool -arisesFromGivens ct - = case ctEvidence ct of - CtGiven {} -> True - CtWanted {} -> False - CtDerived { ctev_loc = loc } -> isGivenLoc loc - -isGivenLoc :: CtLoc -> Bool -isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) - -{- Note [Dropping derived constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we discard derived constraints at the end of constraint solving; -see dropDerivedWC. For example - - * Superclasses: if we have an unsolved [W] (Ord a), we don't want to - complain about an unsolved [D] (Eq a) as well. - - * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate - [D] Int ~ Bool, and we don't want to report that because it's - incomprehensible. That is why we don't rewrite wanteds with wanteds! - - * We might float out some Wanteds from an implication, leaving behind - their insoluble Deriveds. For example: - - forall a[2]. [W] alpha[1] ~ Int - [W] alpha[1] ~ Bool - [D] Int ~ Bool - - The Derived is insoluble, but we very much want to drop it when floating - out. - -But (tiresomely) we do keep *some* Derived constraints: - - * Type holes are derived constraints, because they have no evidence - and we want to keep them, so we get the error report - - * Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with - KindEqOrigin, may arise from a type equality a ~ Int#, say. See - Note [Equalities with incompatible kinds] in TcCanonical. - Keeping these around produces better error messages, in practice. - E.g., test case dependent/should_fail/T11471 - - * We keep most derived equalities arising from functional dependencies - - Given/Given interactions (subset of FunDepOrigin1): - The definitely-insoluble ones reflect unreachable code. - - Others not-definitely-insoluble ones like [D] a ~ Int do not - reflect unreachable code; indeed if fundeps generated proofs, it'd - be a useful equality. See #14763. So we discard them. - - - Given/Wanted interacGiven or Wanted interacting with an - instance declaration (FunDepOrigin2) - - - Given/Wanted interactions (FunDepOrigin1); see #9612 - - - But for Wanted/Wanted interactions we do /not/ want to report an - error (#13506). Consider [W] C Int Int, [W] C Int Bool, with - a fundep on class C. We don't want to report an insoluble Int~Bool; - c.f. "wanteds do not rewrite wanteds". - -To distinguish these cases we use the CtOrigin. - -NB: we keep *all* derived insolubles under some circumstances: - - * They are looked at by simplifyInfer, to decide whether to - generalise. Example: [W] a ~ Int, [W] a ~ Bool - We get [D] Int ~ Bool, and indeed the constraints are insoluble, - and we want simplifyInfer to see that, even though we don't - ultimately want to generate an (inexplicable) error message from it - - -************************************************************************ -* * - CtEvidence - The "flavor" of a canonical constraint -* * -************************************************************************ --} - -isWantedCt :: Ct -> Bool -isWantedCt = isWanted . ctEvidence - -isGivenCt :: Ct -> Bool -isGivenCt = isGiven . ctEvidence - -isDerivedCt :: Ct -> Bool -isDerivedCt = isDerived . ctEvidence - -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan (CFunEqCan {}) = False -isCTyEqCan _ = False - -isCDictCan_Maybe :: Ct -> Maybe Class -isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls -isCDictCan_Maybe _ = Nothing - -isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) -isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) -isCFunEqCan_maybe _ = Nothing - -isCFunEqCan :: Ct -> Bool -isCFunEqCan (CFunEqCan {}) = True -isCFunEqCan _ = False - -isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False - -isHoleCt:: Ct -> Bool -isHoleCt (CHoleCan {}) = True -isHoleCt _ = False - -isOutOfScopeCt :: Ct -> Bool --- We treat expression holes representing out-of-scope variables a bit --- differently when it comes to error reporting -isOutOfScopeCt (CHoleCan { cc_hole = ExprHole (OutOfScope {}) }) = True -isOutOfScopeCt _ = False - -isExprHoleCt :: Ct -> Bool -isExprHoleCt (CHoleCan { cc_hole = ExprHole {} }) = True -isExprHoleCt _ = False - -isTypeHoleCt :: Ct -> Bool -isTypeHoleCt (CHoleCan { cc_hole = TypeHole {} }) = True -isTypeHoleCt _ = False - - -{- Note [Custom type errors in constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - -TypeError msg -- The actual constraint is a type error - -TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - -Eq (TypeError msg) -- A class constraint is stuck due to a type error - -F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - -Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. --} - --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: Ct -> Maybe Type -getUserTypeErrorMsg ct = findUserTypeError (ctPred ct) - where - findUserTypeError t = msum ( userTypeError_maybe t - : map findUserTypeError (subTys t) - ) - - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - - - - -isUserTypeErrorCt :: Ct -> Bool -isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of - Just _ -> True - _ -> False - -isPendingScDict :: Ct -> Maybe Ct --- Says whether this is a CDictCan with cc_pend_sc is True, --- AND if so flips the flag -isPendingScDict ct@(CDictCan { cc_pend_sc = True }) - = Just (ct { cc_pend_sc = False }) -isPendingScDict _ = Nothing - -isPendingScInst :: QCInst -> Maybe QCInst --- Same as isPrendinScDict, but for QCInsts -isPendingScInst qci@(QCI { qci_pend_sc = True }) - = Just (qci { qci_pend_sc = False }) -isPendingScInst _ = Nothing - -setPendingScDict :: Ct -> Ct --- Set the cc_pend_sc flag to True -setPendingScDict ct@(CDictCan { cc_pend_sc = False }) - = ct { cc_pend_sc = True } -setPendingScDict ct = ct - -superClassesMightHelp :: WantedConstraints -> Bool --- ^ True if taking superclasses of givens, or of wanteds (to perhaps --- expose more equalities or functional dependencies) might help to --- solve this constraint. See Note [When superclasses help] -superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) - = anyBag might_help_ct simples || anyBag might_help_implic implics - where - might_help_implic ic - | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) - | otherwise = False - - might_help_ct ct = isWantedCt ct && not (is_ip ct) - - is_ip (CDictCan { cc_class = cls }) = isIPClass cls - is_ip _ = False - -getPendingWantedScs :: Cts -> ([Ct], Cts) -getPendingWantedScs simples - = mapAccumBagL get [] simples - where - get acc ct | Just ct' <- isPendingScDict ct - = (ct':acc, ct') - | otherwise - = (acc, ct) - -{- Note [When superclasses help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First read Note [The superclass story] in TcCanonical. - -We expand superclasses and iterate only if there is at unsolved wanted -for which expansion of superclasses (e.g. from given constraints) -might actually help. The function superClassesMightHelp tells if -doing this superclass expansion might help solve this constraint. -Note that - - * We look inside implications; maybe it'll help to expand the Givens - at level 2 to help solve an unsolved Wanted buried inside an - implication. E.g. - forall a. Ord a => forall b. [W] Eq a - - * Superclasses help only for Wanted constraints. Derived constraints - are not really "unsolved" and we certainly don't want them to - trigger superclass expansion. This was a good part of the loop - in #11523 - - * Even for Wanted constraints, we say "no" for implicit parameters. - we have [W] ?x::ty, expanding superclasses won't help: - - Superclasses can't be implicit parameters - - If we have a [G] ?x:ty2, then we'll have another unsolved - [D] ty ~ ty2 (from the functional dependency) - which will trigger superclass expansion. - - It's a bit of a special case, but it's easy to do. The runtime cost - is low because the unsolved set is usually empty anyway (errors - aside), and the first non-imlicit-parameter will terminate the search. - - The special case is worth it (#11480, comment:2) because it - applies to CallStack constraints, which aren't type errors. If we have - f :: (C a) => blah - f x = ...undefined... - we'll get a CallStack constraint. If that's the only unsolved - constraint it'll eventually be solved by defaulting. So we don't - want to emit warnings about hitting the simplifier's iteration - limit. A CallStack constraint really isn't an unsolved - constraint; it can always be solved by defaulting. --} - -singleCt :: Ct -> Cts -singleCt = unitBag - -andCts :: Cts -> Cts -> Cts -andCts = unionBags - -listToCts :: [Ct] -> Cts -listToCts = listToBag - -ctsElts :: Cts -> [Ct] -ctsElts = bagToList - -consCts :: Ct -> Cts -> Cts -consCts = consBag - -snocCts :: Cts -> Ct -> Cts -snocCts = snocBag - -extendCtsList :: Cts -> [Ct] -> Cts -extendCtsList cts xs | null xs = cts - | otherwise = cts `unionBags` listToBag xs - -andManyCts :: [Cts] -> Cts -andManyCts = unionManyBags - -emptyCts :: Cts -emptyCts = emptyBag - -isEmptyCts :: Cts -> Bool -isEmptyCts = isEmptyBag - -pprCts :: Cts -> SDoc -pprCts cts = vcat (map ppr (bagToList cts)) - -{- -************************************************************************ -* * - Wanted constraints - These are forced to be in TcRnTypes because - TcLclEnv mentions WantedConstraints - WantedConstraint mentions CtLoc - CtLoc mentions ErrCtxt - ErrCtxt mentions TcM -* * -v%************************************************************************ --} - -data WantedConstraints - = WC { wc_simple :: Cts -- Unsolved constraints, all wanted - , wc_impl :: Bag Implication - } - -emptyWC :: WantedConstraints -emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag } - -mkSimpleWC :: [CtEvidence] -> WantedConstraints -mkSimpleWC cts - = WC { wc_simple = listToBag (map mkNonCanonical cts) - , wc_impl = emptyBag } - -mkImplicWC :: Bag Implication -> WantedConstraints -mkImplicWC implic - = WC { wc_simple = emptyBag, wc_impl = implic } - -isEmptyWC :: WantedConstraints -> Bool -isEmptyWC (WC { wc_simple = f, wc_impl = i }) - = isEmptyBag f && isEmptyBag i - - --- | Checks whether a the given wanted constraints are solved, i.e. --- that there are no simple constraints left and all the implications --- are solved. -isSolvedWC :: WantedConstraints -> Bool -isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl} = - isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl - -andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints -andWC (WC { wc_simple = f1, wc_impl = i1 }) - (WC { wc_simple = f2, wc_impl = i2 }) - = WC { wc_simple = f1 `unionBags` f2 - , wc_impl = i1 `unionBags` i2 } - -unionsWC :: [WantedConstraints] -> WantedConstraints -unionsWC = foldr andWC emptyWC - -addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints -addSimples wc cts - = wc { wc_simple = wc_simple wc `unionBags` cts } - -- Consider: Put the new constraints at the front, so they get solved first - -addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints -addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } - -addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints -addInsols wc cts - = wc { wc_simple = wc_simple wc `unionBags` cts } - -insolublesOnly :: WantedConstraints -> WantedConstraints --- Keep only the definitely-insoluble constraints -insolublesOnly (WC { wc_simple = simples, wc_impl = implics }) - = WC { wc_simple = filterBag insolubleCt simples - , wc_impl = mapBag implic_insols_only implics } - where - implic_insols_only implic - = implic { ic_wanted = insolublesOnly (ic_wanted implic) } - -isSolvedStatus :: ImplicStatus -> Bool -isSolvedStatus (IC_Solved {}) = True -isSolvedStatus _ = False - -isInsolubleStatus :: ImplicStatus -> Bool -isInsolubleStatus IC_Insoluble = True -isInsolubleStatus IC_BadTelescope = True -isInsolubleStatus _ = False - -insolubleImplic :: Implication -> Bool -insolubleImplic ic = isInsolubleStatus (ic_status ic) - -insolubleWC :: WantedConstraints -> Bool -insolubleWC (WC { wc_impl = implics, wc_simple = simples }) - = anyBag insolubleCt simples - || anyBag insolubleImplic implics - -insolubleCt :: Ct -> Bool --- Definitely insoluble, in particular /excluding/ type-hole constraints --- Namely: a) an equality constraint --- b) that is insoluble --- c) and does not arise from a Given -insolubleCt ct - | isHoleCt ct = isOutOfScopeCt ct -- See Note [Insoluble holes] - | not (insolubleEqCt ct) = False - | arisesFromGivens ct = False -- See Note [Given insolubles] - | otherwise = True - -insolubleEqCt :: Ct -> Bool --- Returns True of /equality/ constraints --- that are /definitely/ insoluble --- It won't detect some definite errors like --- F a ~ T (F a) --- where F is a type family, which actually has an occurs check --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- E.g. It'll reply True for a ~ [a] --- but False for [a] ~ a --- and --- True for Int ~ F a Int --- but False for Maybe Int ~ F a Int Int --- (where F is an arity-1 type function) -insolubleEqCt (CIrredCan { cc_insol = insol }) = insol -insolubleEqCt _ = False - -instance Outputable WantedConstraints where - ppr (WC {wc_simple = s, wc_impl = i}) - = text "WC" <+> braces (vcat - [ ppr_bag (text "wc_simple") s - , ppr_bag (text "wc_impl") i ]) - -ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc -ppr_bag doc bag - | isEmptyBag bag = empty - | otherwise = hang (doc <+> equals) - 2 (foldr (($$) . ppr) empty bag) - -{- Note [Given insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14325, comment:) - class (a~b) => C a b - - foo :: C a c => a -> c - foo x = x - - hm3 :: C (f b) b => b -> f b - hm3 x = foo x - -In the RHS of hm3, from the [G] C (f b) b we get the insoluble -[G] f b ~# b. Then we also get an unsolved [W] C b (f b). -Residual implication looks like - forall b. C (f b) b => [G] f b ~# b - [W] C f (f b) - -We do /not/ want to set the implication status to IC_Insoluble, -because that'll suppress reports of [W] C b (f b). But we -may not report the insoluble [G] f b ~# b either (see Note [Given errors] -in TcErrors), so we may fail to report anything at all! Yikes. - -The same applies to Derived constraints that /arise from/ Givens. -E.g. f :: (C Int [a]) => blah -where a fundep means we get - [D] Int ~ [a] -By the same reasoning we must not suppress other errors (#15767) - -Bottom line: insolubleWC (called in TcSimplify.setImplicationStatus) - should ignore givens even if they are insoluble. - -Note [Insoluble holes] -~~~~~~~~~~~~~~~~~~~~~~ -Hole constraints that ARE NOT treated as truly insoluble: - a) type holes, arising from PartialTypeSignatures, - b) "true" expression holes arising from TypedHoles - -An "expression hole" or "type hole" constraint isn't really an error -at all; it's a report saying "_ :: Int" here. But an out-of-scope -variable masquerading as expression holes IS treated as truly -insoluble, so that it trumps other errors during error reporting. -Yuk! - -************************************************************************ -* * - Implication constraints -* * -************************************************************************ --} - -data Implication - = Implic { -- Invariants for a tree of implications: - -- see TcType Note [TcLevel and untouchable type variables] - - ic_tclvl :: TcLevel, -- TcLevel of unification variables - -- allocated /inside/ this implication - - ic_skols :: [TcTyVar], -- Introduced skolems - ic_info :: SkolemInfo, -- See Note [Skolems in an implication] - -- See Note [Shadowing in a constraint] - - ic_telescope :: Maybe SDoc, -- User-written telescope, if there is one - -- See Note [Checking telescopes] - - ic_given :: [EvVar], -- Given evidence variables - -- (order does not matter) - -- See Invariant (GivenInv) in TcType - - ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure - -- False <=> ic_givens might have equalities - - ic_warn_inaccessible :: Bool, - -- True <=> -Winaccessible-code is enabled - -- at construction. See - -- Note [Avoid -Winaccessible-code when deriving] - -- in TcInstDcls - - ic_env :: TcLclEnv, - -- Records the TcLClEnv at the time of creation. - -- - -- The TcLclEnv gives the source location - -- and error context for the implication, and - -- hence for all the given evidence variables. - - ic_wanted :: WantedConstraints, -- The wanteds - -- See Invariang (WantedInf) in TcType - - ic_binds :: EvBindsVar, -- Points to the place to fill in the - -- abstraction and bindings. - - -- The ic_need fields keep track of which Given evidence - -- is used by this implication or its children - -- NB: including stuff used by nested implications that have since - -- been discarded - -- See Note [Needed evidence variables] - ic_need_inner :: VarSet, -- Includes all used Given evidence - ic_need_outer :: VarSet, -- Includes only the free Given evidence - -- i.e. ic_need_inner after deleting - -- (a) givens (b) binders of ic_binds - - ic_status :: ImplicStatus - } - -implicationPrototype :: Implication -implicationPrototype - = Implic { -- These fields must be initialised - ic_tclvl = panic "newImplic:tclvl" - , ic_binds = panic "newImplic:binds" - , ic_info = panic "newImplic:info" - , ic_env = panic "newImplic:env" - , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" - - -- The rest have sensible default values - , ic_skols = [] - , ic_telescope = Nothing - , ic_given = [] - , ic_wanted = emptyWC - , ic_no_eqs = False - , ic_status = IC_Unsolved - , ic_need_inner = emptyVarSet - , ic_need_outer = emptyVarSet } - -data ImplicStatus - = IC_Solved -- All wanteds in the tree are solved, all the way down - { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed - -- See Note [Tracking redundant constraints] in TcSimplify - - | IC_Insoluble -- At least one insoluble constraint in the tree - - | IC_BadTelescope -- solved, but the skolems in the telescope are out of - -- dependency order - - | IC_Unsolved -- Neither of the above; might go either way - -instance Outputable Implication where - ppr (Implic { ic_tclvl = tclvl, ic_skols = skols - , ic_given = given, ic_no_eqs = no_eqs - , ic_wanted = wanted, ic_status = status - , ic_binds = binds - , ic_need_inner = need_in, ic_need_outer = need_out - , ic_info = info }) - = hang (text "Implic" <+> lbrace) - 2 (sep [ text "TcLevel =" <+> ppr tclvl - , text "Skolems =" <+> pprTyVars skols - , text "No-eqs =" <+> ppr no_eqs - , text "Status =" <+> ppr status - , hang (text "Given =") 2 (pprEvVars given) - , hang (text "Wanted =") 2 (ppr wanted) - , text "Binds =" <+> ppr binds - , whenPprDebug (text "Needed inner =" <+> ppr need_in) - , whenPprDebug (text "Needed outer =" <+> ppr need_out) - , pprSkolInfo info ] <+> rbrace) - -instance Outputable ImplicStatus where - ppr IC_Insoluble = text "Insoluble" - ppr IC_BadTelescope = text "Bad telescope" - ppr IC_Unsolved = text "Unsolved" - ppr (IC_Solved { ics_dead = dead }) - = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) - -{- Note [Checking telescopes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind-checking a /user-written/ type, we might have a "bad telescope" -like this one: - data SameKind :: forall k. k -> k -> Type - type Foo :: forall a k (b :: k). SameKind a b -> Type - -The kind of 'a' mentions 'k' which is bound after 'a'. Oops. - -Knowing this means that unification etc must have happened, so it's -convenient to detect it in the constraint solver: - -* We make a single implication constraint when kind-checking - the 'forall' in Foo's kind, something like - forall a k (b::k). { wanted constraints } - -* Having solved {wanted}, before discarding the now-solved implication, - the costraint solver checks the dependency order of the skolem - variables (ic_skols). This is done in setImplicationStatus. - -* This check is only necessary if the implication was born from a - user-written signature. If, say, it comes from checking a pattern - match that binds existentials, where the type of the data constructor - is known to be valid (it in tcConPat), no need for the check. - - So the check is done if and only if ic_telescope is (Just blah). - -* If ic_telesope is (Just d), the d::SDoc displays the original, - user-written type variables. - -* Be careful /NOT/ to discard an implication with non-Nothing - ic_telescope, even if ic_wanted is empty. We must give the - constraint solver a chance to make that bad-telesope test! Hence - the extra guard in emitResidualTvConstraint; see #16247 - -See also TcHsType Note [Keeping scoped variables in order: Explicit] - -Note [Needed evidence variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Th ic_need_evs field holds the free vars of ic_binds, and all the -ic_binds in nested implications. - - * Main purpose: if one of the ic_givens is not mentioned in here, it - is redundant. - - * solveImplication may drop an implication altogether if it has no - remaining 'wanteds'. But we still track the free vars of its - evidence binds, even though it has now disappeared. - -Note [Shadowing in a constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We assume NO SHADOWING in a constraint. Specifically - * The unification variables are all implicitly quantified at top - level, and are all unique - * The skolem variables bound in ic_skols are all freah when the - implication is created. -So we can safely substitute. For example, if we have - forall a. a~Int => ...(forall b. ...a...)... -we can push the (a~Int) constraint inwards in the "givens" without -worrying that 'b' might clash. - -Note [Skolems in an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The skolems in an implication are not there to perform a skolem escape -check. That happens because all the environment variables are in the -untouchables, and therefore cannot be unified with anything at all, -let alone the skolems. - -Instead, ic_skols is used only when considering floating a constraint -outside the implication in TcSimplify.floatEqualities or -TcSimplify.approximateImplications - -Note [Insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the errors that we get during canonicalization are best -reported when all constraints have been simplified as much as -possible. For instance, assume that during simplification the -following constraints arise: - - [Wanted] F alpha ~ uf1 - [Wanted] beta ~ uf1 beta - -When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail -we will simply see a message: - 'Can't construct the infinite type beta ~ uf1 beta' -and the user has no idea what the uf1 variable is. - -Instead our plan is that we will NOT fail immediately, but: - (1) Record the "frozen" error in the ic_insols field - (2) Isolate the offending constraint from the rest of the inerts - (3) Keep on simplifying/canonicalizing - -At the end, we will hopefully have substituted uf1 := F alpha, and we -will be able to report a more informative error: - 'Can't construct the infinite type beta ~ F alpha beta' - -Insoluble constraints *do* include Derived constraints. For example, -a functional dependency might give rise to [D] Int ~ Bool, and we must -report that. If insolubles did not contain Deriveds, reportErrors would -never see it. - - -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -pprEvVars :: [EvVar] -> SDoc -- Print with their types -pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) - -pprEvVarTheta :: [EvVar] -> SDoc -pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) - -pprEvVarWithType :: EvVar -> SDoc -pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) - - - --- | Wraps the given type with the constraints (via ic_given) in the given --- implication, according to the variables mentioned (via ic_skols) --- in the implication, but taking care to only wrap those variables --- that are mentioned in the type or the implication. -wrapTypeWithImplication :: Type -> Implication -> Type -wrapTypeWithImplication ty impl = wrapType ty mentioned_skols givens - where givens = map idType $ ic_given impl - skols = ic_skols impl - freeVars = fvVarSet $ tyCoFVsOfTypes (ty:givens) - mentioned_skols = filter (`elemVarSet` freeVars) skols - -wrapType :: Type -> [TyVar] -> [PredType] -> Type -wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty - - -{- -************************************************************************ -* * - CtEvidence -* * -************************************************************************ - -Note [Evidence field of CtEvidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During constraint solving we never look at the type of ctev_evar/ctev_dest; -instead we look at the ctev_pred field. The evtm/evar field -may be un-zonked. - -Note [Bind new Givens immediately] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Givens we make new EvVars and bind them immediately. Two main reasons: - * Gain sharing. E.g. suppose we start with g :: C a b, where - class D a => C a b - class (E a, F a) => D a - If we generate all g's superclasses as separate EvTerms we might - get selD1 (selC1 g) :: E a - selD2 (selC1 g) :: F a - selC1 g :: D a - which we could do more economically as: - g1 :: D a = selC1 g - g2 :: E a = selD1 g1 - g3 :: F a = selD2 g1 - - * For *coercion* evidence we *must* bind each given: - class (a~b) => C a b where .... - f :: C a b => .... - Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. - But that superclass selector can't (yet) appear in a coercion - (see evTermCoercion), so the easy thing is to bind it to an Id. - -So a Given has EvVar inside it rather than (as previously) an EvTerm. - --} - --- | A place for type-checking evidence to go after it is generated. --- Wanted equalities are always HoleDest; other wanteds are always --- EvVarDest. -data TcEvDest - = EvVarDest EvVar -- ^ bind this var to the evidence - -- EvVarDest is always used for non-type-equalities - -- e.g. class constraints - - | HoleDest CoercionHole -- ^ fill in this hole with the evidence - -- HoleDest is always used for type-equalities - -- See Note [Coercion holes] in TyCoRep - -data CtEvidence - = CtGiven -- Truly given, not depending on subgoals - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] - , ctev_loc :: CtLoc } - - - | CtWanted -- Wanted goal - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_dest :: TcEvDest - , ctev_nosh :: ShadowInfo -- See Note [Constraint flavours] - , ctev_loc :: CtLoc } - - | CtDerived -- A goal that we don't really have to solve and can't - -- immediately rewrite anything other than a derived - -- (there's no evidence!) but if we do manage to solve - -- it may help in solving other goals. - { ctev_pred :: TcPredType - , ctev_loc :: CtLoc } - -ctEvPred :: CtEvidence -> TcPredType --- The predicate of a flavor -ctEvPred = ctev_pred - -ctEvLoc :: CtEvidence -> CtLoc -ctEvLoc = ctev_loc - -ctEvOrigin :: CtEvidence -> CtOrigin -ctEvOrigin = ctLocOrigin . ctEvLoc - --- | Get the equality relation relevant for a 'CtEvidence' -ctEvEqRel :: CtEvidence -> EqRel -ctEvEqRel = predTypeEqRel . ctEvPred - --- | Get the role relevant for a 'CtEvidence' -ctEvRole :: CtEvidence -> Role -ctEvRole = eqRelRole . ctEvEqRel - -ctEvTerm :: CtEvidence -> EvTerm -ctEvTerm ev = EvExpr (ctEvExpr ev) - -ctEvExpr :: CtEvidence -> EvExpr -ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) - = Coercion $ ctEvCoercion ev -ctEvExpr ev = evId (ctEvEvId ev) - -ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion -ctEvCoercion (CtGiven { ctev_evar = ev_id }) - = mkTcCoVarCo ev_id -ctEvCoercion (CtWanted { ctev_dest = dest }) - | HoleDest hole <- dest - = -- ctEvCoercion is only called on type equalities - -- and they always have HoleDests - mkHoleCo hole -ctEvCoercion ev - = pprPanic "ctEvCoercion" (ppr ev) - -ctEvEvId :: CtEvidence -> EvVar -ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev -ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h -ctEvEvId (CtGiven { ctev_evar = ev }) = ev -ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev) - -instance Outputable TcEvDest where - ppr (HoleDest h) = text "hole" <> ppr h - ppr (EvVarDest ev) = ppr ev - -instance Outputable CtEvidence where - ppr ev = ppr (ctEvFlavour ev) - <+> pp_ev - <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon - -- Show the sub-goal depth too - <+> ppr (ctEvPred ev) - where - pp_ev = case ev of - CtGiven { ctev_evar = v } -> ppr v - CtWanted {ctev_dest = d } -> ppr d - CtDerived {} -> text "_" - -isWanted :: CtEvidence -> Bool -isWanted (CtWanted {}) = True -isWanted _ = False - -isGiven :: CtEvidence -> Bool -isGiven (CtGiven {}) = True -isGiven _ = False - -isDerived :: CtEvidence -> Bool -isDerived (CtDerived {}) = True -isDerived _ = False - -{- -%************************************************************************ -%* * - CtFlavour -%* * -%************************************************************************ - -Note [Constraint flavours] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constraints come in four flavours: - -* [G] Given: we have evidence - -* [W] Wanted WOnly: we want evidence - -* [D] Derived: any solution must satisfy this constraint, but - we don't need evidence for it. Examples include: - - superclasses of [W] class constraints - - equalities arising from functional dependencies - or injectivity - -* [WD] Wanted WDeriv: a single constraint that represents - both [W] and [D] - We keep them paired as one both for efficiency, and because - when we have a finite map F tys -> CFunEqCan, it's inconvenient - to have two CFunEqCans in the range - -The ctev_nosh field of a Wanted distinguishes between [W] and [WD] - -Wanted constraints are born as [WD], but are split into [W] and its -"shadow" [D] in TcSMonad.maybeEmitShadow. - -See Note [The improvement story and derived shadows] in TcSMonad --} - -data CtFlavour -- See Note [Constraint flavours] - = Given - | Wanted ShadowInfo - | Derived - deriving Eq - -data ShadowInfo - = WDeriv -- [WD] This Wanted constraint has no Derived shadow, - -- so it behaves like a pair of a Wanted and a Derived - | WOnly -- [W] It has a separate derived shadow - -- See Note [The improvement story and derived shadows] in TcSMonad - deriving( Eq ) - -isGivenOrWDeriv :: CtFlavour -> Bool -isGivenOrWDeriv Given = True -isGivenOrWDeriv (Wanted WDeriv) = True -isGivenOrWDeriv _ = False - -instance Outputable CtFlavour where - ppr Given = text "[G]" - ppr (Wanted WDeriv) = text "[WD]" - ppr (Wanted WOnly) = text "[W]" - ppr Derived = text "[D]" - -ctEvFlavour :: CtEvidence -> CtFlavour -ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh -ctEvFlavour (CtGiven {}) = Given -ctEvFlavour (CtDerived {}) = Derived - --- | Whether or not one 'Ct' can rewrite another is determined by its --- flavour and its equality relation. See also --- Note [Flavours with roles] in TcSMonad -type CtFlavourRole = (CtFlavour, EqRel) - --- | Extract the flavour, role, and boxity from a 'CtEvidence' -ctEvFlavourRole :: CtEvidence -> CtFlavourRole -ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) - --- | Extract the flavour and role from a 'Ct' -ctFlavourRole :: Ct -> CtFlavourRole --- Uses short-cuts to role for special cases -ctFlavourRole (CDictCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) -ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) - = (ctEvFlavour ev, eq_rel) -ctFlavourRole (CFunEqCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) -ctFlavourRole (CHoleCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) -- NomEq: CHoleCans can be rewritten by - -- by nominal equalities but empahatically - -- not by representational equalities -ctFlavourRole ct - = ctEvFlavourRole (ctEvidence ct) - -{- Note [eqCanRewrite] -~~~~~~~~~~~~~~~~~~~~~~ -(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form -tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of -a can-rewrite relation, see Definition [Can-rewrite relation] in -TcSMonad. - -With the solver handling Coercible constraints like equality constraints, -the rewrite conditions must take role into account, never allowing -a representational equality to rewrite a nominal one. - -Note [Wanteds do not rewrite Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Wanteds to rewrite Wanteds, because that can give rise -to very confusing type error messages. A good example is #8450. -Here's another - f :: a -> Bool - f x = ( [x,'c'], [x,True] ) `seq` True -Here we get - [W] a ~ Char - [W] a ~ Bool -but we do not want to complain about Bool ~ Char! - -Note [Deriveds do rewrite Deriveds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -However we DO allow Deriveds to rewrite Deriveds, because that's how -improvement works; see Note [The improvement story] in TcInteract. - -However, for now at least I'm only letting (Derived,NomEq) rewrite -(Derived,NomEq) and not doing anything for ReprEq. If we have - eqCanRewriteFR (Derived, NomEq) (Derived, _) = True -then we lose property R2 of Definition [Can-rewrite relation] -in TcSMonad - R2. If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 -Consider f1 = (Given, ReprEq) - f2 = (Derived, NomEq) - f = (Derived, ReprEq) - -I thought maybe we could never get Derived ReprEq constraints, but -we can; straight from the Wanteds during improvement. And from a Derived -ReprEq we could conceivably get a Derived NomEq improvement (by decomposing -a type constructor with Nomninal role), and hence unify. --} - -eqCanRewrite :: EqRel -> EqRel -> Bool -eqCanRewrite NomEq _ = True -eqCanRewrite ReprEq ReprEq = True -eqCanRewrite ReprEq NomEq = False - -eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Can fr1 actually rewrite fr2? --- Very important function! --- See Note [eqCanRewrite] --- See Note [Wanteds do not rewrite Wanteds] --- See Note [Deriveds do rewrite Deriveds] -eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 -eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True -eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True -eqCanRewriteFR _ _ = False - -eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Is it /possible/ that fr1 can rewrite fr2? --- This is used when deciding which inerts to kick out, --- at which time a [WD] inert may be split into [W] and [D] -eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 - ------------------ -{- Note [funEqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two CFunEqCans with the same LHS: - (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2) -Can we drop x2 in favour of x1, either unifying -f2 (if it's a flatten meta-var) or adding a new Given -(f1 ~ f2), if x2 is a Given? - -Answer: yes if funEqCanDischarge is true. --} - -funEqCanDischarge - :: CtEvidence -> CtEvidence - -> ( SwapFlag -- NotSwapped => lhs can discharge rhs - -- Swapped => rhs can discharge lhs - , Bool) -- True <=> upgrade non-discharded one - -- from [W] to [WD] --- See Note [funEqCanDischarge] -funEqCanDischarge ev1 ev2 - = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 ) - ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 ) - -- CFunEqCans are all Nominal, hence asserts - funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2) - -funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool) -funEqCanDischargeF Given _ = (NotSwapped, False) -funEqCanDischargeF _ Given = (IsSwapped, False) -funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False) -funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True) -funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False) -funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True) -funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True) -funEqCanDischargeF Derived Derived = (NotSwapped, False) - - -{- Note [eqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two identical CTyEqCan equality constraints -(i.e. both LHS and RHS are the same) - (x1:a~t) `eqCanDischarge` (xs:a~t) -Can we just drop x2 in favour of x1? - -Answer: yes if eqCanDischarge is true. - -Note that we do /not/ allow Wanted to discharge Derived. -We must keep both. Why? Because the Derived may rewrite -other Deriveds in the model whereas the Wanted cannot. - -However a Wanted can certainly discharge an identical Wanted. So -eqCanDischarge does /not/ define a can-rewrite relation in the -sense of Definition [Can-rewrite relation] in TcSMonad. - -We /do/ say that a [W] can discharge a [WD]. In evidence terms it -certainly can, and the /caller/ arranges that the otherwise-lost [D] -is spat out as a new Derived. -} - -eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool --- See Note [eqCanDischarge] -eqCanDischargeFR (f1,r1) (f2, r2) = eqCanRewrite r1 r2 - && eqCanDischargeF f1 f2 - -eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool -eqCanDischargeF Given _ = True -eqCanDischargeF (Wanted _) (Wanted _) = True -eqCanDischargeF (Wanted WDeriv) Derived = True -eqCanDischargeF Derived Derived = True -eqCanDischargeF _ _ = False - - -{- -************************************************************************ -* * - SubGoalDepth -* * -************************************************************************ - -Note [SubGoalDepth] -~~~~~~~~~~~~~~~~~~~ -The 'SubGoalDepth' takes care of stopping the constraint solver from looping. - -The counter starts at zero and increases. It includes dictionary constraints, -equality simplification, and type family reduction. (Why combine these? Because -it's actually quite easy to mistake one for another, in sufficiently involved -scenarios, like ConstraintKinds.) - -The flag -freduction-depth=n fixes the maximium level. - -* The counter includes the depth of type class instance declarations. Example: - [W] d{7} : Eq [Int] - That is d's dictionary-constraint depth is 7. If we use the instance - $dfEqList :: Eq a => Eq [a] - to simplify it, we get - d{7} = $dfEqList d'{8} - where d'{8} : Eq Int, and d' has depth 8. - - For civilised (decidable) instance declarations, each increase of - depth removes a type constructor from the type, so the depth never - gets big; i.e. is bounded by the structural depth of the type. - -* The counter also increments when resolving -equalities involving type functions. Example: - Assume we have a wanted at depth 7: - [W] d{7} : F () ~ a - If there is a type function equation "F () = Int", this would be rewritten to - [W] d{8} : Int ~ a - and remembered as having depth 8. - - Again, without UndecidableInstances, this counter is bounded, but without it - can resolve things ad infinitum. Hence there is a maximum level. - -* Lastly, every time an equality is rewritten, the counter increases. Again, - rewriting an equality constraint normally makes progress, but it's possible - the "progress" is just the reduction of an infinitely-reducing type family. - Hence we need to track the rewrites. - -When compiling a program requires a greater depth, then GHC recommends turning -off this check entirely by setting -freduction-depth=0. This is because the -exact number that works is highly variable, and is likely to change even between -minor releases. Because this check is solely to prevent infinite compilation -times, it seems safe to disable it when a user has ascertained that their program -doesn't loop at the type level. - --} - --- | See Note [SubGoalDepth] -newtype SubGoalDepth = SubGoalDepth Int - deriving (Eq, Ord, Outputable) - -initialSubGoalDepth :: SubGoalDepth -initialSubGoalDepth = SubGoalDepth 0 - -bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth -bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) - -maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth -maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) - -subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool -subGoalDepthExceeded dflags (SubGoalDepth d) - = mkIntWithInf d > reductionDepth dflags - -{- -************************************************************************ -* * - CtLoc -* * -************************************************************************ - -The 'CtLoc' gives information about where a constraint came from. -This is important for decent error message reporting because -dictionaries don't appear in the original source code. -type will evolve... - --} - -data CtLoc = CtLoc { ctl_origin :: CtOrigin - , ctl_env :: TcLclEnv - , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure - , ctl_depth :: !SubGoalDepth } - - -- The TcLclEnv includes particularly - -- source location: tcl_loc :: RealSrcSpan - -- context: tcl_ctxt :: [ErrCtxt] - -- binder stack: tcl_bndrs :: TcBinderStack - -- level: tcl_tclvl :: TcLevel - -mkKindLoc :: TcType -> TcType -- original *types* being compared - -> CtLoc -> CtLoc -mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) - (KindEqOrigin s1 (Just s2) (ctLocOrigin loc) - (ctLocTypeOrKind_maybe loc)) - --- | Take a CtLoc and moves it to the kind level -toKindLoc :: CtLoc -> CtLoc -toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } - -mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc -mkGivenLoc tclvl skol_info env - = CtLoc { ctl_origin = GivenOrigin skol_info - , ctl_env = setLclEnvTcLevel env tclvl - , ctl_t_or_k = Nothing -- this only matters for error msgs - , ctl_depth = initialSubGoalDepth } - -ctLocEnv :: CtLoc -> TcLclEnv -ctLocEnv = ctl_env - -ctLocLevel :: CtLoc -> TcLevel -ctLocLevel loc = getLclEnvTcLevel (ctLocEnv loc) - -ctLocDepth :: CtLoc -> SubGoalDepth -ctLocDepth = ctl_depth - -ctLocOrigin :: CtLoc -> CtOrigin -ctLocOrigin = ctl_origin - -ctLocSpan :: CtLoc -> RealSrcSpan -ctLocSpan (CtLoc { ctl_env = lcl}) = getLclEnvLoc lcl - -ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind -ctLocTypeOrKind_maybe = ctl_t_or_k - -setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc -setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setLclEnvLoc lcl loc) - -bumpCtLocDepth :: CtLoc -> CtLoc -bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } - -setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc -setCtLocOrigin ctl orig = ctl { ctl_origin = orig } - -updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc -updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd - = ctl { ctl_origin = upd orig } - -setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc -setCtLocEnv ctl env = ctl { ctl_env = env } - -pprCtLoc :: CtLoc -> SDoc --- "arising from ... at ..." --- Not an instance of Outputable because of the "arising from" prefix -pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) - = sep [ pprCtOrigin o - , text "at" <+> ppr (getLclEnvLoc lcl)] diff --git a/typecheck/FamInst.hs b/typecheck/FamInst.hs deleted file mode 100644 --- a/typecheck/FamInst.hs +++ /dev/null @@ -1,1054 +0,0 @@ --- The @FamInst@ type: family instance heads - -{-# LANGUAGE CPP, GADTs, ViewPatterns #-} - -module FamInst ( - FamInstEnvs, tcGetFamInstEnvs, - checkFamInstConsistency, tcExtendLocalFamInstEnv, - tcLookupDataFamInst, tcLookupDataFamInst_maybe, - tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, - newFamInst, - - -- * Injectivity - reportInjectivityErrors, reportConflictingInjectivityErrs - ) where - -import GhcPrelude - -import HscTypes -import FamInstEnv -import InstEnv( roughMatchTcs ) -import Coercion -import CoreLint -import TcEvidence -import LoadIface -import TcRnMonad -import SrcLoc -import TyCon -import TcType -import CoAxiom -import DynFlags -import Module -import Outputable -import Util -import RdrName -import DataCon ( dataConName ) -import Maybes -import TyCoRep -import TyCoFVs -import TyCoPpr ( pprWithExplicitKindsWhen ) -import TcMType -import Name -import Panic -import VarSet -import FV -import Bag( Bag, unionBags, unitBag ) -import Control.Monad -import Data.List.NonEmpty ( NonEmpty(..) ) - -import qualified GHC.LanguageExtensions as LangExt - -#include "HsVersions.h" - -{- Note [The type family instance consistency story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To preserve type safety we must ensure that for any given module, all -the type family instances used either in that module or in any module -it directly or indirectly imports are consistent. For example, consider - - module F where - type family F a - - module A where - import F( F ) - type instance F Int = Bool - f :: F Int -> Bool - f x = x - - module B where - import F( F ) - type instance F Int = Char - g :: Char -> F Int - g x = x - - module Bad where - import A( f ) - import B( g ) - bad :: Char -> Int - bad c = f (g c) - -Even though module Bad never mentions the type family F at all, by -combining the functions f and g that were type checked in contradictory -type family instance environments, the function bad is able to coerce -from one type to another. So when we type check Bad we must verify that -the type family instances defined in module A are consistent with those -defined in module B. - -How do we ensure that we maintain the necessary consistency? - -* Call a module which defines at least one type family instance a - "family instance module". This flag `mi_finsts` is recorded in the - interface file. - -* For every module we calculate the set of all of its direct and - indirect dependencies that are family instance modules. This list - `dep_finsts` is also recorded in the interface file so we can compute - this list for a module from the lists for its direct dependencies. - -* When type checking a module M we check consistency of all the type - family instances that are either provided by its `dep_finsts` or - defined in the module M itself. This is a pairwise check, i.e., for - every pair of instances we must check that they are consistent. - - - For family instances coming from `dep_finsts`, this is checked in - checkFamInstConsistency, called from tcRnImports. See Note - [Checking family instance consistency] for details on this check - (and in particular how we avoid having to do all these checks for - every module we compile). - - - That leaves checking the family instances defined in M itself - against instances defined in either M or its `dep_finsts`. This is - checked in `tcExtendLocalFamInstEnv'. - -There are four subtle points in this scheme which have not been -addressed yet. - -* We have checked consistency of the family instances *defined* by M - or its imports, but this is not by definition the same thing as the - family instances *used* by M or its imports. Specifically, we need to - ensure when we use a type family instance while compiling M that this - instance was really defined from either M or one of its imports, - rather than being an instance that we happened to know about from - reading an interface file in the course of compiling an unrelated - module. Otherwise, we'll end up with no record of the fact that M - depends on this family instance and type safety will be compromised. - See #13102. - -* It can also happen that M uses a function defined in another module - which is not transitively imported by M. Examples include the - desugaring of various overloaded constructs, and references inserted - by Template Haskell splices. If that function's definition makes use - of type family instances which are not checked against those visible - from M, type safety can again be compromised. See #13251. - -* When a module C imports a boot module B.hs-boot, we check that C's - type family instances are compatible with those visible from - B.hs-boot. However, C will eventually be linked against a different - module B.hs, which might define additional type family instances which - are inconsistent with C's. This can also lead to loss of type safety. - See #9562. - -* The call to checkFamConsistency for imported functions occurs very - early (in tcRnImports) and that causes problems if the imported - instances use type declared in the module being compiled. - See Note [Loading your own hi-boot file] in LoadIface. --} - -{- -************************************************************************ -* * - Making a FamInst -* * -************************************************************************ --} - --- All type variables in a FamInst must be fresh. This function --- creates the fresh variables and applies the necessary substitution --- It is defined here to avoid a dependency from FamInstEnv on the monad --- code. - -newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst --- Freshen the type variables of the FamInst branches -newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) - = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax ) - ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind ) - -- We used to have an assertion that the tyvars of the RHS were bound - -- by tcv_set, but in error situations like F Int = a that isn't - -- true; a later check in checkValidFamInst rejects it - do { (subst, tvs') <- freshenTyVarBndrs tvs - ; (subst, cvs') <- freshenCoVarBndrsX subst cvs - ; dflags <- getDynFlags - ; let lhs' = substTys subst lhs - rhs' = substTy subst rhs - tcvs' = tvs' ++ cvs' - ; ifErrsM (return ()) $ -- Don't lint when there are errors, because - -- errors might mean TcTyCons. - -- See Note [Recover from validity error] in TcTyClsDecls - when (gopt Opt_DoCoreLinting dflags) $ - -- Check that the types involved in this instance are well formed. - -- Do /not/ expand type synonyms, for the reasons discussed in - -- Note [Linting type synonym applications]. - case lintTypes dflags tcvs' (rhs':lhs') of - Nothing -> pure () - Just fail_msg -> pprPanic "Core Lint error" (vcat [ fail_msg - , ppr fam_tc - , ppr subst - , ppr tvs' - , ppr cvs' - , ppr lhs' - , ppr rhs' ]) - ; return (FamInst { fi_fam = tyConName fam_tc - , fi_flavor = flavor - , fi_tcs = roughMatchTcs lhs - , fi_tvs = tvs' - , fi_cvs = cvs' - , fi_tys = lhs' - , fi_rhs = rhs' - , fi_axiom = axiom }) } - where - lhs_kind = tcTypeKind (mkTyConApp fam_tc lhs) - rhs_kind = tcTypeKind rhs - tcv_set = mkVarSet (tvs ++ cvs) - pp_ax = pprCoAxiom axiom - CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomSingleBranch axiom - - -{- -************************************************************************ -* * - Optimised overlap checking for family instances -* * -************************************************************************ - -Note [Checking family instance consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For any two family instance modules that we import directly or indirectly, we -check whether the instances in the two modules are consistent, *unless* we can -be certain that the instances of the two modules have already been checked for -consistency during the compilation of modules that we import. - -Why do we need to check? Consider - module X1 where module X2 where - data T1 data T2 - type instance F T1 b = Int type instance F a T2 = Char - f1 :: F T1 a -> Int f2 :: Char -> F a T2 - f1 x = x f2 x = x - -Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. -Notice that neither instance is an orphan. - -How do we know which pairs of modules have already been checked? For each -module M we directly import, we look up the family instance modules that M -imports (directly or indirectly), say F1, ..., FN. For any two modules -among M, F1, ..., FN, we know that the family instances defined in those -two modules are consistent--because we checked that when we compiled M. - -For every other pair of family instance modules we import (directly or -indirectly), we check that they are consistent now. (So that we can be -certain that the modules in our `HscTypes.dep_finsts' are consistent.) - -There is some fancy footwork regarding hs-boot module loops, see -Note [Don't check hs-boot type family instances too early] - -Note [Checking family instance optimization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Checking family instance consistency] -we need to ensure that every pair of transitive imports that define type family -instances is consistent. - -Let's define df(A) = transitive imports of A that define type family instances -+ A, if A defines type family instances - -Then for every direct import A, df(A) is already consistent. - -Let's name the current module M. - -We want to make sure that df(M) is consistent. -df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports. - -We perform the check iteratively, maintaining a set of consistent modules 'C' -and trying to add df(D_i) to it. - -The key part is how to ensure that the union C U df(D_i) is consistent. - -Let's consider two modules: A and B from C U df(D_i). -There are nine possible ways to choose A and B from C U df(D_i): - - | A in C only | A in C and B in df(D_i) | A in df(D_i) only --------------------------------------------------------------------------------- -B in C only | Already checked | Already checked | Needs to be checked - | when checking C | when checking C | --------------------------------------------------------------------------------- -B in C and | Already checked | Already checked | Already checked when -B in df(D_i) | when checking C | when checking C | checking df(D_i) --------------------------------------------------------------------------------- -B in df(D_i) | Needs to be | Already checked | Already checked when -only | checked | when checking df(D_i) | checking df(D_i) - -That means to ensure that C U df(D_i) is consistent we need to check every -module from C - df(D_i) against every module from df(D_i) - C and -every module from df(D_i) - C against every module from C - df(D_i). -But since the checks are symmetric it suffices to pick A from C - df(D_i) -and B from df(D_i) - C. - -In other words these are the modules we need to check: - [ (m1, m2) | m1 <- C, m1 not in df(D_i) - , m2 <- df(D_i), m2 not in C ] - -One final thing to note here is that if there's lot of overlap between -subsequent df(D_i)'s then we expect those set differences to be small. -That situation should be pretty common in practice, there's usually -a set of utility modules that every module imports directly or indirectly. - -This is basically the idea from #13092, comment:14. --} - --- This function doesn't check ALL instances for consistency, --- only ones that aren't involved in recursive knot-tying --- loops; see Note [Don't check hs-boot type family instances too early]. --- We don't need to check the current module, this is done in --- tcExtendLocalFamInstEnv. --- See Note [The type family instance consistency story]. -checkFamInstConsistency :: [Module] -> TcM () -checkFamInstConsistency directlyImpMods - = do { (eps, hpt) <- getEpsAndHpt - ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) - ; let { -- Fetch the iface of a given module. Must succeed as - -- all directly imported modules must already have been loaded. - modIface mod = - case lookupIfaceByModule hpt (eps_PIT eps) mod of - Nothing -> panicDoc "FamInst.checkFamInstConsistency" - (ppr mod $$ pprHPT hpt) - Just iface -> iface - - -- Which family instance modules were checked for consistency - -- when we compiled `mod`? - -- Itself (if a family instance module) and its dep_finsts. - -- This is df(D_i) from - -- Note [Checking family instance optimization] - ; modConsistent :: Module -> [Module] - ; modConsistent mod = - if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps - where - deps = dep_finsts . mi_deps . modIface $ mod - - ; hmiModule = mi_module . hm_iface - ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) - | hmi <- eltsHpt hpt] - - } - - ; checkMany hpt_fam_insts modConsistent directlyImpMods - } - where - -- See Note [Checking family instance optimization] - checkMany - :: ModuleEnv FamInstEnv -- home package family instances - -> (Module -> [Module]) -- given A, modules checked when A was checked - -> [Module] -- modules to process - -> TcM () - checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods - where - go :: [Module] -- list of consistent modules - -> ModuleSet -- set of consistent modules, same elements as the - -- list above - -> [Module] -- modules to process - -> TcM () - go _ _ [] = return () - go consistent consistent_set (mod:mods) = do - sequence_ - [ check hpt_fam_insts m1 m2 - | m1 <- to_check_from_mod - -- loop over toCheckFromMod first, it's usually smaller, - -- it may even be empty - , m2 <- to_check_from_consistent - ] - go consistent' consistent_set' mods - where - mod_deps_consistent = modConsistent mod - mod_deps_consistent_set = mkModuleSet mod_deps_consistent - consistent' = to_check_from_mod ++ consistent - consistent_set' = - extendModuleSetList consistent_set to_check_from_mod - to_check_from_consistent = - filterOut (`elemModuleSet` mod_deps_consistent_set) consistent - to_check_from_mod = - filterOut (`elemModuleSet` consistent_set) mod_deps_consistent - -- Why don't we just minusModuleSet here? - -- We could, but doing so means one of two things: - -- - -- 1. When looping over the cartesian product we convert - -- a set into a non-deterministicly ordered list. Which - -- happens to be fine for interface file determinism - -- in this case, today, because the order only - -- determines the order of deferred checks. But such - -- invariants are hard to keep. - -- - -- 2. When looping over the cartesian product we convert - -- a set into a deterministically ordered list - this - -- adds some additional cost of sorting for every - -- direct import. - -- - -- That also explains why we need to keep both 'consistent' - -- and 'consistentSet'. - -- - -- See also Note [ModuleEnv performance and determinism]. - check hpt_fam_insts m1 m2 - = do { env1' <- getFamInsts hpt_fam_insts m1 - ; env2' <- getFamInsts hpt_fam_insts m2 - -- We're checking each element of env1 against env2. - -- The cost of that is dominated by the size of env1, because - -- for each instance in env1 we look it up in the type family - -- environment env2, and lookup is cheap. - -- The code below ensures that env1 is the smaller environment. - ; let sizeE1 = famInstEnvSize env1' - sizeE2 = famInstEnvSize env2' - (env1, env2) = if sizeE1 < sizeE2 then (env1', env2') - else (env2', env1') - -- Note [Don't check hs-boot type family instances too early] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Family instance consistency checking involves checking that - -- the family instances of our imported modules are consistent with - -- one another; this might lead you to think that this process - -- has nothing to do with the module we are about to typecheck. - -- Not so! Consider the following case: - -- - -- -- A.hs-boot - -- type family F a - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- type instance F Int = Bool - -- - -- -- A.hs - -- import B - -- type family F a - -- - -- When typechecking A, we are NOT allowed to poke the TyThing - -- for F until we have typechecked the family. Thus, we - -- can't do consistency checking for the instance in B - -- (checkFamInstConsistency is called during renaming). - -- Failing to defer the consistency check lead to #11062. - -- - -- Additionally, we should also defer consistency checking when - -- type from the hs-boot file of the current module occurs on - -- the left hand side, as we will poke its TyThing when checking - -- for overlap. - -- - -- -- F.hs - -- type family F a - -- - -- -- A.hs-boot - -- import F - -- data T - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- import F - -- type instance F T = Int - -- - -- -- A.hs - -- import B - -- data T = MkT - -- - -- In fact, it is even necessary to defer for occurrences in - -- the RHS, because we may test for *compatibility* in event - -- of an overlap. - -- - -- Why don't we defer ALL of the checks to later? Well, many - -- instances aren't involved in the recursive loop at all. So - -- we might as well check them immediately; and there isn't - -- a good time to check them later in any case: every time - -- we finish kind-checking a type declaration and add it to - -- a context, we *then* consistency check all of the instances - -- which mentioned that type. We DO want to check instances - -- as quickly as possible, so that we aren't typechecking - -- values with inconsistent axioms in scope. - -- - -- See also Note [Tying the knot] - -- for why we are doing this at all. - ; let check_now = famInstEnvElts env1 - ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now - ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now - } - -getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv -getFamInsts hpt_fam_insts mod - | Just env <- lookupModuleEnv hpt_fam_insts mod = return env - | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) - ; eps <- getEps - ; return (expectJust "checkFamInstConsistency" $ - lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } - where - doc = ppr mod <+> text "is a family-instance module" - -{- -************************************************************************ -* * - Lookup -* * -************************************************************************ - --} - --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated --- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion -tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) -tcInstNewTyCon_maybe = instNewTyCon_maybe - --- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if --- there is no data family to unwrap. --- Returns a Representational coercion -tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] - -> (TyCon, [TcType], Coercion) -tcLookupDataFamInst fam_inst_envs tc tc_args - | Just (rep_tc, rep_args, co) - <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - = (rep_tc, rep_args, co) - | otherwise - = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) - -tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] - -> Maybe (TyCon, [TcType], Coercion) --- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) --- and returns a coercion between the two: co :: F [a] ~R FList a. -tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - | isDataFamilyTyCon tc - , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args - , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax - , fi_cvs = cvs }) - , fim_tys = rep_args - , fim_cos = rep_cos } <- match - , let rep_tc = dataFamInstRepTyCon rep_fam - co = mkUnbranchedAxInstCo Representational ax rep_args - (mkCoVarCos cvs) - = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv - Just (rep_tc, rep_args, co) - - | otherwise - = Nothing - --- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, --- potentially looking through newtype /instances/. --- --- It is only used by the type inference engine (specifically, when --- solving representational equality), and hence it is careful to unwrap --- only if the relevant data constructor is in scope. That's why --- it get a GlobalRdrEnv argument. --- --- It is careful not to unwrap data/newtype instances if it can't --- continue unwrapping. Such care is necessary for proper error --- messages. --- --- It does not look through type families. --- It does not normalise arguments to a tycon. --- --- If the result is Just (rep_ty, (co, gres), rep_ty), then --- co : ty ~R rep_ty --- gres are the GREs for the data constructors that --- had to be in scope -tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs - -> GlobalRdrEnv - -> Type - -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) -tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty --- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe - = topNormaliseTypeX stepper plus ty - where - plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) - -> (Bag GlobalRdrElt, TcCoercion) - plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 - , co1 `mkTransCo` co2 ) - - stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) - stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance - - -- For newtype instances we take a double step or nothing, so that - -- we don't return the representation type of the newtype instance, - -- which would lead to terrible error messages - unwrap_newtype_instance rec_nts tc tys - | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys - = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ - unwrap_newtype rec_nts tc' tys' - | otherwise = NS_Done - - unwrap_newtype rec_nts tc tys - | Just con <- newTyConDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - -- This is where we check that the - -- data constructor is in scope - = mapStepResult (\co -> (unitBag gre, co)) $ - unwrapNewTypeStepper rec_nts tc tys - - | otherwise - = NS_Done - -{- -************************************************************************ -* * - Extending the family instance environment -* * -************************************************************************ --} - --- Add new locally-defined family instances, checking consistency with --- previous locally-defined family instances as well as all instances --- available from imported modules. This requires loading all of our --- imports that define family instances (if we haven't loaded them already). -tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a - --- If we weren't actually given any instances to add, then we don't want --- to go to the bother of loading family instance module dependencies. -tcExtendLocalFamInstEnv [] thing_inside = thing_inside - --- Otherwise proceed... -tcExtendLocalFamInstEnv fam_insts thing_inside - = do { -- Load family-instance modules "below" this module, so that - -- allLocalFamInst can check for consistency with them - -- See Note [The type family instance consistency story] - loadDependentFamInstModules fam_insts - - -- Now add the instances one by one - ; env <- getGblEnv - ; (inst_env', fam_insts') <- foldlM addLocalFamInst - (tcg_fam_inst_env env, tcg_fam_insts env) - fam_insts - - ; let env' = env { tcg_fam_insts = fam_insts' - , tcg_fam_inst_env = inst_env' } - ; setGblEnv env' thing_inside - } - -loadDependentFamInstModules :: [FamInst] -> TcM () --- Load family-instance modules "below" this module, so that --- allLocalFamInst can check for consistency with them --- See Note [The type family instance consistency story] -loadDependentFamInstModules fam_insts - = do { env <- getGblEnv - ; let this_mod = tcg_mod env - imports = tcg_imports env - - want_module mod -- See Note [Home package family instances] - | mod == this_mod = False - | home_fams_only = moduleUnitId mod == moduleUnitId this_mod - | otherwise = True - home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts - - ; loadModuleInterfaces (text "Loading family-instance modules") $ - filter want_module (imp_finsts imports) } - -{- Note [Home package family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Optimization: If we're only defining type family instances -for type families *defined in the home package*, then we -only have to load interface files that belong to the home -package. The reason is that there's no recursion between -packages, so modules in other packages can't possibly define -instances for our type families. - -(Within the home package, we could import a module M that -imports us via an hs-boot file, and thereby defines an -instance of a type family defined in this module. So we can't -apply the same logic to avoid reading any interface files at -all, when we define an instances for type family defined in -the current module. --} - --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] --- in FamInstEnv.hs -addLocalFamInst :: (FamInstEnv,[FamInst]) - -> FamInst - -> TcM (FamInstEnv, [FamInst]) -addLocalFamInst (home_fie, my_fis) fam_inst - -- home_fie includes home package and this module - -- my_fies is just the ones from this module - = do { traceTc "addLocalFamInst" (ppr fam_inst) - - -- Unlike the case of class instances, don't override existing - -- instances in GHCi; it's unsound. See #7102. - - ; mod <- getModule - ; traceTc "alfi" (ppr mod) - - -- Fetch imported instances, so that we report - -- overlaps correctly. - -- Really we ought to only check consistency with - -- those instances which are transitively imported - -- by the current module, rather than every instance - -- we've ever seen. Fixing this is part of #13102. - ; eps <- getEps - ; let inst_envs = (eps_fam_inst_env eps, home_fie) - home_fie' = extendFamInstEnv home_fie fam_inst - - -- Check for conflicting instance decls and injectivity violations - ; ((), no_errs) <- askNoErrs $ - do { checkForConflicts inst_envs fam_inst - ; checkForInjectivityConflicts inst_envs fam_inst - ; checkInjectiveEquation fam_inst - } - - ; if no_errs then - return (home_fie', fam_inst : my_fis) - else - return (home_fie, my_fis) } - -{- -************************************************************************ -* * - Checking an instance against conflicts with an instance env -* * -************************************************************************ - -Check whether a single family instance conflicts with those in two instance -environments (one for the EPS and one for the HPT). --} - --- | Checks to make sure no two family instances overlap. -checkForConflicts :: FamInstEnvs -> FamInst -> TcM () -checkForConflicts inst_envs fam_inst - = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst - ; traceTc "checkForConflicts" $ - vcat [ ppr (map fim_instance conflicts) - , ppr fam_inst - -- , ppr inst_envs - ] - ; reportConflictInstErr fam_inst conflicts } - -checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM () - -- see Note [Verifying injectivity annotation] in FamInstEnv, check 1B1. -checkForInjectivityConflicts instEnvs famInst - | isTypeFamilyTyCon tycon -- as opposed to data family tycon - , Injective inj <- tyConInjectivityInfo tycon - = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in - reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst)) - - | otherwise - = return () - - where tycon = famInstTyCon famInst - --- | Check whether a new open type family equation can be added without --- violating injectivity annotation supplied by the user. Returns True when --- this is possible and False if adding this equation would violate injectivity --- annotation. This looks only at the one equation; it does not look for --- interaction between equations. Use checkForInjectivityConflicts for that. --- Does checks (2)-(4) of Note [Verifying injectivity annotation] in FamInstEnv. -checkInjectiveEquation :: FamInst -> TcM () -checkInjectiveEquation famInst - | isTypeFamilyTyCon tycon - -- type family is injective in at least one argument - , Injective inj <- tyConInjectivityInfo tycon = do - { dflags <- getDynFlags - ; let axiom = coAxiomSingleBranch fi_ax - -- see Note [Verifying injectivity annotation] in FamInstEnv - ; reportInjectivityErrors dflags fi_ax axiom inj - } - - -- if there was no injectivity annotation or tycon does not represent a - -- type family we report no conflicts - | otherwise - = return () - - where tycon = famInstTyCon famInst - fi_ax = fi_axiom famInst - --- | Report a list of injectivity errors together with their source locations. --- Looks only at one equation; does not look for conflicts *among* equations. -reportInjectivityErrors - :: DynFlags - -> CoAxiom br -- ^ Type family for which we generate errors - -> CoAxBranch -- ^ Currently checked equation (represented by axiom) - -> [Bool] -- ^ Injectivity annotation - -> TcM () -reportInjectivityErrors dflags fi_ax axiom inj - = ASSERT2( any id inj, text "No injective type variables" ) - do let lhs = coAxBranchLHS axiom - rhs = coAxBranchRHS axiom - fam_tc = coAxiomTyCon fi_ax - (unused_inj_tvs, unused_vis, undec_inst_flag) - = unusedInjTvsInRHS dflags fam_tc lhs rhs - inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs - tf_headed = isTFHeaded rhs - bare_variables = bareTvInRHSViolated lhs rhs - wrong_bare_rhs = not $ null bare_variables - - when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs - unused_vis undec_inst_flag axiom - when tf_headed $ reportTfHeadedErr fam_tc axiom - when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom - --- | Is type headed by a type family application? -isTFHeaded :: Type -> Bool --- See Note [Verifying injectivity annotation], case 3. -isTFHeaded ty | Just ty' <- coreView ty - = isTFHeaded ty' -isTFHeaded ty | (TyConApp tc args) <- ty - , isTypeFamilyTyCon tc - = args `lengthIs` tyConArity tc -isTFHeaded _ = False - - --- | If a RHS is a bare type variable return a set of LHS patterns that are not --- bare type variables. -bareTvInRHSViolated :: [Type] -> Type -> [Type] --- See Note [Verifying injectivity annotation], case 2. -bareTvInRHSViolated pats rhs | isTyVarTy rhs - = filter (not . isTyVarTy) pats -bareTvInRHSViolated _ _ = [] - ------------------------------------------------------------------- --- Checking for the coverage condition for injective type families ------------------------------------------------------------------- - -{- -Note [Coverage condition for injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Injective Type Families paper describes how we can tell whether -or not a type family equation upholds the injectivity condition. -Briefly, consider the following: - - type family F a b = r | r -> a -- NB: b is not injective - - type instance F ty1 ty2 = ty3 - -We need to make sure that all variables mentioned in ty1 are mentioned in ty3 --- that's how we know that knowing ty3 determines ty1. But they can't be -mentioned just anywhere in ty3: they must be in *injective* positions in ty3. -For example: - - type instance F a Int = Maybe (G a) - -This is no good, if G is not injective. However, if G is indeed injective, -then this would appear to meet our needs. There is a trap here, though: while -knowing G a does indeed determine a, trying to compute a from G a might not -terminate. This is precisely the same problem that we have with functional -dependencies and their liberal coverage condition. Here is the test case: - - type family G a = r | r -> a - type instance G [a] = [G a] - [W] G alpha ~ [alpha] - -We see that the equation given applies, because G alpha equals a list. So we -learn that alpha must be [beta] for some beta. We then have - - [W] G [beta] ~ [[beta]] - -This can reduce to - - [W] [G beta] ~ [[beta]] - -which then decomposes to - - [W] G beta ~ [beta] - -right where we started. The equation G [a] = [G a] thus is dangerous: while -it does not violate the injectivity assumption, it might throw us into a loop, -with a particularly dastardly Wanted. - -We thus do what functional dependencies do: require -XUndecidableInstances to -accept this. - -Checking the coverage condition is not terribly hard, but we also want to produce -a nice error message. A nice error message has at least two properties: - -1. If any of the variables involved are invisible or are used in an invisible context, -we want to print invisible arguments (as -fprint-explicit-kinds does). - -2. If we fail to accept the equation because we're worried about non-termination, -we want to suggest UndecidableInstances. - -To gather the right information, we can talk about the *usage* of a variable. Every -variable is used either visibly or invisibly, and it is either not used at all, -in a context where acceptance requires UndecidableInstances, or in a context that -does not require UndecidableInstances. If a variable is used both visibly and -invisibly, then we want to remember the fact that it was used invisibly: printing -out invisibles will be helpful for the user to understand what is going on. -If a variable is used where we need -XUndecidableInstances and where we don't, -we can similarly just remember the latter. - -We thus define Visibility and NeedsUndecInstFlag below. These enumerations are -*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair -of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a -variable is NotPresent, but this extra slack in the representation causes no -harm.) We finally define VarUsages as a mapping from variables to VarUsage. -Its Monoid instance combines two maps, using the Semigroup instance of VarUsage -to combine elements that are represented in both maps. In this way, we can -compositionally analyze types (and portions thereof). - -To do the injectivity check: - -1. We build VarUsages that represent the LHS (rather, the portion of the LHS -that is flagged as injective); each usage on the LHS is NotPresent, because we -hvae not yet looked at the RHS. - -2. We also build a VarUsage for the RHS, done by injTyVarUsages. - -3. We then combine these maps. Now, every variable in the injective components of the LHS -will be mapped to its correct usage (either NotPresent or perhaps needing --XUndecidableInstances in order to be seen as injective). - -4. We look up each var used in an injective argument on the LHS in -the map, making a list of tvs that should be determined by the RHS -but aren't. - -5. We then return the set of bad variables, whether any of the bad -ones were used invisibly, and whether any bad ones need -XUndecidableInstances. -If -XUndecidableInstances is enabled, than a var that needs the flag -won't be bad, so it won't appear in this list. - -6. We use all this information to produce a nice error message, (a) switching -on -fprint-explicit-kinds if appropriate and (b) telling the user about --XUndecidableInstances if appropriate. - --} - --- | Return the set of type variables that a type family equation is --- expected to be injective in but is not. Suppose we have @type family --- F a b = r | r -> a@. Then any variables that appear free in the first --- argument to F in an equation must be fixed by that equation's RHS. --- This function returns all such variables that are not indeed fixed. --- It also returns whether any of these variables appear invisibly --- and whether -XUndecidableInstances would help. --- See Note [Coverage condition for injective type families]. -unusedInjTvsInRHS :: DynFlags - -> TyCon -- type family - -> [Type] -- LHS arguments - -> Type -- the RHS - -> ( TyVarSet - , Bool -- True <=> one or more variable is used invisibly - , Bool ) -- True <=> suggest -XUndecidableInstances --- See Note [Verifying injectivity annotation] in FamInstEnv. --- This function implements check (4) described there, further --- described in Note [Coverage condition for injective type families]. --- In theory (and modulo the -XUndecidableInstances wrinkle), --- instead of implementing this whole check in this way, we could --- attempt to unify equation with itself. We would reject exactly the same --- equations but this method gives us more precise error messages by returning --- precise names of variables that are not mentioned in the RHS. -unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs = - -- Note [Coverage condition for injective type families], step 5 - (bad_vars, any_invisible, suggest_undec) - where - undec_inst = xopt LangExt.UndecidableInstances dflags - - inj_lhs = filterByList inj_list lhs - lhs_vars = tyCoVarsOfTypes inj_lhs - - rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs - - bad_vars = lhs_vars `minusVarSet` rhs_inj_vars - - any_bad = not $ isEmptyVarSet bad_vars - - invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs] - - any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars) - suggest_undec = any_bad && - not undec_inst && - (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs)) - --- When the type family is not injective in any arguments -unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False) - ---------------------------------------- --- Producing injectivity error messages ---------------------------------------- - --- | Report error message for a pair of equations violating an injectivity --- annotation. No error message if there are no branches. -reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () -reportConflictingInjectivityErrs _ [] _ = return () -reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn - = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] - where - herald = text "Type family equation right-hand sides overlap; this violates" $$ - text "the family's injectivity annotation:" - --- | Injectivity error herald common to all injectivity errors. -injectivityErrorHerald :: SDoc -injectivityErrorHerald = - text "Type family equation violates the family's injectivity annotation." - - --- | Report error message for equation with injective type variables unused in --- the RHS. Note [Coverage condition for injective type families], step 6 -reportUnusedInjectiveVarsErr :: TyCon - -> TyVarSet - -> Bool -- True <=> print invisible arguments - -> Bool -- True <=> suggest -XUndecidableInstances - -> CoAxBranch - -> TcM () -reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn - = let (loc, doc) = buildInjectivityError fam_tc - (injectivityErrorHerald $$ - herald $$ - text "In the type family equation:") - (tyfamEqn :| []) - in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) - where - herald = sep [ what <+> text "variable" <> - pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) - , text "cannot be inferred from the right-hand side." ] - $$ extra - - what | has_kinds = text "Type/kind" - | otherwise = text "Type" - - extra | undec_inst = text "Using UndecidableInstances might help" - | otherwise = empty - --- | Report error message for equation that has a type family call at the top --- level of RHS -reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () -reportTfHeadedErr fam_tc branch - = addErrs [buildInjectivityError fam_tc - (injectivityErrorHerald $$ - text "RHS of injective type family equation cannot" <+> - text "be a type family:") - (branch :| [])] - --- | Report error message for equation that has a bare type variable in the RHS --- but LHS pattern is not a bare type variable. -reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () -reportBareVariableInRHSErr fam_tc tys branch - = addErrs [buildInjectivityError fam_tc - (injectivityErrorHerald $$ - text "RHS of injective type family equation is a bare" <+> - text "type variable" $$ - text "but these LHS type and kind patterns are not bare" <+> - text "variables:" <+> pprQuotedList tys) - (branch :| [])] - -buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc) -buildInjectivityError fam_tc herald (eqn1 :| rest_eqns) - = ( coAxBranchSpan eqn1 - , hang herald - 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) ) - -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () -reportConflictInstErr _ [] - = return () -- No conflicts -reportConflictInstErr fam_inst (match1 : _) - | FamInstMatch { fim_instance = conf_inst } <- match1 - , let sorted = sortWith getSpan [fam_inst, conf_inst] - fi1 = head sorted - span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - = setSrcSpan span $ addErr $ - hang (text "Conflicting family instance declarations:") - 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) - | fi <- sorted - , let ax = famInstAxiom fi ]) - where - getSpan = getSrcLoc . famInstAxiom - -- The sortWith just arranges that instances are dislayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users - -tcGetFamInstEnvs :: TcM FamInstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetFamInstEnvs - = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/typecheck/FunDeps.hs b/typecheck/FunDeps.hs deleted file mode 100644 --- a/typecheck/FunDeps.hs +++ /dev/null @@ -1,678 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 2000 - - -FunDeps - functional dependencies - -It's better to read it as: "if we know these, then we're going to know these" --} - -{-# LANGUAGE CPP #-} - -module FunDeps ( - FunDepEqn(..), pprEquation, - improveFromInstEnv, improveFromAnother, - checkInstCoverage, checkFunDeps, - pprFundeps - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Name -import Var -import Class -import Predicate -import Type -import TcType( transSuperClasses ) -import CoAxiom( TypeEqn ) -import Unify -import InstEnv -import VarSet -import VarEnv -import TyCoFVs -import TyCoPpr( pprWithExplicitKindsWhen ) -import FV -import Outputable -import ErrUtils( Validity(..), allValid ) -import SrcLoc -import Util - -import Pair ( Pair(..) ) -import Data.List ( nubBy ) -import Data.Maybe -import Data.Foldable ( fold ) - -{- -************************************************************************ -* * -\subsection{Generate equations from functional dependencies} -* * -************************************************************************ - - -Each functional dependency with one variable in the RHS is responsible -for generating a single equality. For instance: - class C a b | a -> b -The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha -will generate the following FunDepEqn - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } -However notice that a functional dependency may have more than one variable -in the RHS which will create more than one pair of types in fd_eqs. Example: - class C a b c | a -> b c - [Wanted] C Int alpha alpha - [Wanted] C Int Bool beta -Will generate: - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha, Pair alpha beta] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } - -INVARIANT: Corresponding types aren't already equal -That is, there exists at least one non-identity equality in FDEqs. - -Assume: - class C a b c | a -> b c - instance C Int x x -And: [Wanted] C Int Bool alpha -We will /match/ the LHS of fundep equations, producing a matching substitution -and create equations for the RHS sides. In our last example we'd have generated: - ({x}, [fd1,fd2]) -where - fd1 = FDEq 1 Bool x - fd2 = FDEq 2 alpha x -To ``execute'' the equation, make fresh type variable for each tyvar in the set, -instantiate the two types with these fresh variables, and then unify or generate -a new constraint. In the above example we would generate a new unification -variable 'beta' for x and produce the following constraints: - [Wanted] (Bool ~ beta) - [Wanted] (alpha ~ beta) - -Notice the subtle difference between the above class declaration and: - class C a b c | a -> b, a -> c -where we would generate: - ({x},[fd1]),({x},[fd2]) -This means that the template variable would be instantiated to different -unification variables when producing the FD constraints. - -Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' --} - -data FunDepEqn loc - = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars - -- to fresh unification vars, - -- Non-empty only for FunDepEqns arising from instance decls - - , fd_eqs :: [TypeEqn] -- Make these pairs of types equal - , fd_pred1 :: PredType -- The FunDepEqn arose from - , fd_pred2 :: PredType -- combining these two constraints - , fd_loc :: loc } - -{- -Given a bunch of predicates that must hold, such as - - C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 - -improve figures out what extra equations must hold. -For example, if we have - - class C a b | a->b where ... - -then improve will return - - [(t1,t2), (t4,t5)] - -NOTA BENE: - - * improve does not iterate. It's possible that when we make - t1=t2, for example, that will in turn trigger a new equation. - This would happen if we also had - C t1 t7, C t2 t8 - If t1=t2, we also get t7=t8. - - improve does *not* do this extra step. It relies on the caller - doing so. - - * The equations unify types that are not already equal. So there - is no effect iff the result of improve is empty --} - -instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type --- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys) -instFD (ls,rs) tvs tys - = (map lookup ls, map lookup rs) - where - env = zipVarEnv tvs tys - lookup tv = lookupVarEnv_NF env tv - -zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true - -> [Type] -> [Type] - -> [TypeEqn] --- Create a list of (Type,Type) pairs from two lists of types, --- making sure that the types are not already equal -zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2) - | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 - | otherwise = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2 -zipAndComputeFDEqs _ _ _ = [] - --- Improve a class constraint from another class constraint --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -improveFromAnother :: loc - -> PredType -- Template item (usually given, or inert) - -> PredType -- Workitem [that can be improved] - -> [FunDepEqn loc] --- Post: FDEqs always oriented from the other to the workitem --- Equations have empty quantified variables -improveFromAnother loc pred1 pred2 - | Just (cls1, tys1) <- getClassPredTys_maybe pred1 - , Just (cls2, tys2) <- getClassPredTys_maybe pred2 - , cls1 == cls2 - = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc } - | let (cls_tvs, cls_fds) = classTvsFds cls1 - , fd <- cls_fds - , let (ltys1, rs1) = instFD fd cls_tvs tys1 - (ltys2, rs2) = instFD fd cls_tvs tys2 - , eqTypes ltys1 ltys2 -- The LHSs match - , let eqs = zipAndComputeFDEqs eqType rs1 rs2 - , not (null eqs) ] - -improveFromAnother _ _ _ = [] - - --- Improve a class constraint from instance declarations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instance Outputable (FunDepEqn a) where - ppr = pprEquation - -pprEquation :: FunDepEqn a -> SDoc -pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 - | Pair t1 t2 <- pairs])] - -improveFromInstEnv :: InstEnvs - -> (PredType -> SrcSpan -> loc) - -> PredType - -> [FunDepEqn loc] -- Needs to be a FunDepEqn because - -- of quantified variables --- Post: Equations oriented from the template (matching instance) to the workitem! -improveFromInstEnv inst_env mk_loc pred - | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred ) - getClassPredTys_maybe pred - , let (cls_tvs, cls_fds) = classTvsFds cls - instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys - = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs - , fd_pred1 = p_inst, fd_pred2 = pred - , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) } - | fd <- cls_fds -- Iterate through the fundeps first, - -- because there often are none! - , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs - -- Trim the rough_tcs based on the head of the fundep. - -- Remember that instanceCantMatch treats both arguments - -- symmetrically, so it's ok to trim the rough_tcs, - -- rather than trimming each inst_tcs in turn - , ispec <- instances - , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec - tys trimmed_tcs -- NB: orientation - , let p_inst = mkClassPred cls (is_tys ispec) - ] -improveFromInstEnv _ _ _ = [] - - -improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class - -> ClsInst -- An instance template - -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate - -> [([TyCoVar], [TypeEqn])] -- Empty or singleton - -improveClsFD clas_tvs fd - (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) - tys_actual rough_tcs_actual - --- Compare instance {a,b} C sx sp sy sq --- with wanted [W] C tx tp ty tq --- for fundep (x,y -> p,q) from class (C x p y q) --- If (sx,sy) unifies with (tx,ty), take the subst S - --- 'qtvs' are the quantified type variables, the ones which can be instantiated --- to make the types match. For example, given --- class C a b | a->b where ... --- instance C (Maybe x) (Tree x) where .. --- --- and a wanted constraint of form (C (Maybe t1) t2), --- then we will call checkClsFD with --- --- is_qtvs = {x}, is_tys = [Maybe x, Tree x] --- tys_actual = [Maybe t1, t2] --- --- We can instantiate x to t1, and then we want to force --- (Tree x) [t1/x] ~ t2 - - | instanceCantMatch rough_tcs_inst rough_tcs_actual - = [] -- Filter out ones that can't possibly match, - - | otherwise - = ASSERT2( equalLength tys_inst tys_actual && - equalLength tys_inst clas_tvs - , ppr tys_inst <+> ppr tys_actual ) - - case tcMatchTyKis ltys1 ltys2 of - Nothing -> [] - Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) - -- Don't include any equations that already hold. - -- Reason: then we know if any actual improvement has happened, - -- in which case we need to iterate the solver - -- In making this check we must taking account of the fact that any - -- qtvs that aren't already instantiated can be instantiated to anything - -- at all - -- NB: We can't do this 'is-useful-equation' check element-wise - -- because of: - -- class C a b c | a -> b c - -- instance C Int x x - -- [Wanted] C Int alpha Int - -- We would get that x -> alpha (isJust) and x -> Int (isJust) - -- so we would produce no FDs, which is clearly wrong. - -> [] - - | null fdeqs - -> [] - - | otherwise - -> -- pprTrace "iproveClsFD" (vcat - -- [ text "is_tvs =" <+> ppr qtvs - -- , text "tys_inst =" <+> ppr tys_inst - -- , text "tys_actual =" <+> ppr tys_actual - -- , text "ltys1 =" <+> ppr ltys1 - -- , text "ltys2 =" <+> ppr ltys2 - -- , text "subst =" <+> ppr subst ]) $ - [(meta_tvs, fdeqs)] - -- We could avoid this substTy stuff by producing the eqn - -- (qtvs, ls1++rs1, ls2++rs2) - -- which will re-do the ls1/ls2 unification when the equation is - -- executed. What we're doing instead is recording the partial - -- work of the ls1/ls2 unification leaving a smaller unification problem - where - rtys1' = map (substTyUnchecked subst) rtys1 - - fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 - -- Don't discard anything! - -- We could discard equal types but it's an overkill to call - -- eqType again, since we know for sure that /at least one/ - -- equation in there is useful) - - meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv)) - | tv <- qtvs, tv `notElemTCvSubst` subst ] - -- meta_tvs are the quantified type variables - -- that have not been substituted out - -- - -- Eg. class C a b | a -> b - -- instance C Int [y] - -- Given constraint C Int z - -- we generate the equation - -- ({y}, [y], z) - -- - -- But note (a) we get them from the dfun_id, so they are *in order* - -- because the kind variables may be mentioned in the - -- type variabes' kinds - -- (b) we must apply 'subst' to the kinds, in case we have - -- matched out a kind variable, but not a type variable - -- whose kind mentions that kind variable! - -- #6015, #6068 - where - (ltys1, rtys1) = instFD fd clas_tvs tys_inst - (ltys2, rtys2) = instFD fd clas_tvs tys_actual - -{- -%************************************************************************ -%* * - The Coverage condition for instance declarations -* * -************************************************************************ - -Note [Coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Example - class C a b | a -> b - instance theta => C t1 t2 - -For the coverage condition, we check - (normal) fv(t2) `subset` fv(t1) - (liberal) fv(t2) `subset` oclose(fv(t1), theta) - -The liberal version ensures the self-consistency of the instance, but -it does not guarantee termination. Example: - - class Mul a b c | a b -> c where - (.*.) :: a -> b -> c - - instance Mul Int Int Int where (.*.) = (*) - instance Mul Int Float Float where x .*. y = fromIntegral x * y - instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v - -In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). -But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) - -But it is a mistake to accept the instance because then this defn: - f = \ b x y -> if b then x .*. [y] else y -makes instance inference go into a loop, because it requires the constraint - Mul a [b] b --} - -checkInstCoverage :: Bool -- Be liberal - -> Class -> [PredType] -> [Type] - -> Validity --- "be_liberal" flag says whether to use "liberal" coverage of --- See Note [Coverage Condition] below --- --- Return values --- Nothing => no problems --- Just msg => coverage problem described by msg - -checkInstCoverage be_liberal clas theta inst_taus - = allValid (map fundep_ok fds) - where - (tyvars, fds) = classTvsFds clas - fundep_ok fd - | and (isEmptyVarSet <$> undetermined_tvs) = IsValid - | otherwise = NotValid msg - where - (ls,rs) = instFD fd tyvars inst_taus - ls_tvs = tyCoVarsOfTypes ls - rs_tvs = splitVisVarsOfTypes rs - - undetermined_tvs | be_liberal = liberal_undet_tvs - | otherwise = conserv_undet_tvs - - closed_ls_tvs = oclose theta ls_tvs - liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs - conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs - - undet_set = fold undetermined_tvs - - msg = pprWithExplicitKindsWhen - (isEmptyVarSet $ pSnd undetermined_tvs) $ - vcat [ -- text "ls_tvs" <+> ppr ls_tvs - -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) - -- , text "theta" <+> ppr theta - -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) - -- , text "rs_tvs" <+> ppr rs_tvs - sep [ text "The" - <+> ppWhen be_liberal (text "liberal") - <+> text "coverage condition fails in class" - <+> quotes (ppr clas) - , nest 2 $ text "for functional dependency:" - <+> quotes (pprFunDep fd) ] - , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls - , nest 2 $ - (if isSingleton ls - then text "does not" - else text "do not jointly") - <+> text "determine rhs type"<>plural rs - <+> pprQuotedList rs ] - , text "Un-determined variable" <> pluralVarSet undet_set <> colon - <+> pprVarSet undet_set (pprWithCommas ppr) - , ppWhen (not be_liberal && - and (isEmptyVarSet <$> liberal_undet_tvs)) $ - text "Using UndecidableInstances might help" ] - -{- Note [Closing over kinds in coverage] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a fundep (a::k) -> b -Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, -then fixing x really fixes k2 as well, and so k2 should be added to -the lhs tyvars in the fundep check. - -Example (#8391), using liberal coverage - data Foo a = ... -- Foo :: forall k. k -> * - class Bar a b | a -> b - instance Bar a (Foo a) - - In the instance decl, (a:k) does fix (Foo k a), but only if we notice - that (a:k) fixes k. #10109 is another example. - -Here is a more subtle example, from HList-0.4.0.0 (#10564) - - class HasFieldM (l :: k) r (v :: Maybe *) - | l r -> v where ... - class HasFieldM1 (b :: Maybe [*]) (l :: k) r v - | b l r -> v where ... - class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) - | e1 l -> r - - data Label :: k -> * - type family LabelsOf (a :: [*]) :: * - - instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, - HasFieldM1 b l (r xs) v) - => HasFieldM l (r xs) v where - -Is the instance OK? Does {l,r,xs} determine v? Well: - - * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, - plus the fundep "| el l -> r" in class HMameberM, - we get {l,k,xs} -> b - - * Note the 'k'!! We must call closeOverKinds on the seed set - ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b - fundep won't fire. This was the reason for #10564. - - * So starting from seeds {l,r,xs,k} we do oclose to get - first {l,r,xs,k,b}, via the HMemberM constraint, and then - {l,r,xs,k,b,v}, via the HasFieldM1 constraint. - - * And that fixes v. - -However, we must closeOverKinds whenever augmenting the seed set -in oclose! Consider #10109: - - data Succ a -- Succ :: forall k. k -> * - class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab - instance (Add a b ab) => Add (Succ {k1} (a :: k1)) - b - (Succ {k3} (ab :: k3}) - -We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. -Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to -closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all -the variables free in (Succ {k3} ab). - -Bottom line: - * closeOverKinds on initial seeds (done automatically - by tyCoVarsOfTypes in checkInstCoverage) - * and closeOverKinds whenever extending those seeds (in oclose) - -Note [The liberal coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(oclose preds tvs) closes the set of type variables tvs, -wrt functional dependencies in preds. The result is a superset -of the argument set. For example, if we have - class C a b | a->b where ... -then - oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} -because if we know x and y then that fixes z. - -We also use equality predicates in the predicates; if we have an -assumption `t1 ~ t2`, then we use the fact that if we know `t1` we -also know `t2` and the other way. - eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} - -oclose is used (only) when checking the coverage condition for -an instance declaration - -Note [Equality superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class (a ~ [b]) => C a b - -Remember from Note [The equality types story] in TysPrim, that - * (a ~~ b) is a superclass of (a ~ b) - * (a ~# b) is a superclass of (a ~~ b) - -So when oclose expands superclasses we'll get a (a ~# [b]) superclass. -But that's an EqPred not a ClassPred, and we jolly well do want to -account for the mutual functional dependencies implied by (t1 ~# t2). -Hence the EqPred handling in oclose. See #10778. - -Note [Care with type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12803) - class C x y | x -> y - type family F a b - type family G c d = r | r -> d - -Now consider - oclose (C (F a b) (G c d)) {a,b} - -Knowing {a,b} fixes (F a b) regardless of the injectivity of F. -But knowing (G c d) fixes only {d}, because G is only injective -in its second parameter. - -Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. --} - -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet --- See Note [The liberal coverage condition] -oclose preds fixed_tvs - | null tv_fds = fixed_tvs -- Fast escape hatch for common case. - | otherwise = fixVarSet extend fixed_tvs - where - extend fixed_tvs = foldl' add fixed_tvs tv_fds - where - add fixed_tvs (ls,rs) - | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs - | otherwise = fixed_tvs - -- closeOverKinds: see Note [Closing over kinds in coverage] - - tv_fds :: [(TyCoVarSet,TyCoVarSet)] - tv_fds = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs) - -- See Note [Care with type functions] - | pred <- preds - , pred' <- pred : transSuperClasses pred - -- Look for fundeps in superclasses too - , (ls, rs) <- determined pred' ] - - determined :: PredType -> [([Type],[Type])] - determined pred - = case classifyPredType pred of - EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] - -- See Note [Equality superclasses] - ClassPred cls tys -> [ instFD fd cls_tvs tys - | let (cls_tvs, cls_fds) = classTvsFds cls - , fd <- cls_fds ] - _ -> [] - - -{- ********************************************************************* -* * - Check that a new instance decl is OK wrt fundeps -* * -************************************************************************ - -Here is the bad case: - class C a b | a->b where ... - instance C Int Bool where ... - instance C Int Char where ... - -The point is that a->b, so Int in the first parameter must uniquely -determine the second. In general, given the same class decl, and given - - instance C s1 s2 where ... - instance C t1 t2 where ... - -Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). - -Matters are a little more complicated if there are free variables in -the s2/t2. - - class D a b c | a -> b - instance D a b => D [(a,a)] [b] Int - instance D a b => D [a] [b] Bool - -The instance decls don't overlap, because the third parameter keeps -them separate. But we want to make sure that given any constraint - D s1 s2 s3 -if s1 matches - -Note [Bogus consistency check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In checkFunDeps we check that a new ClsInst is consistent with all the -ClsInsts in the environment. - -The bogus aspect is discussed in #10675. Currenty it if the two -types are *contradicatory*, using (isNothing . tcUnifyTys). But all -the papers say we should check if the two types are *equal* thus - not (substTys subst rtys1 `eqTypes` substTys subst rtys2) -For now I'm leaving the bogus form because that's the way it has -been for years. --} - -checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] --- The Consistency Check. --- Check whether adding DFunId would break functional-dependency constraints --- Used only for instance decls defined in the module being compiled --- Returns a list of the ClsInst in InstEnvs that are inconsistent --- with the proposed new ClsInst -checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls - , is_tys = tys1, is_tcs = rough_tcs1 }) - | null fds - = [] - | otherwise - = nubBy eq_inst $ - [ ispec | ispec <- cls_insts - , fd <- fds - , is_inconsistent fd ispec ] - where - cls_insts = classInstances inst_envs cls - (cls_tvs, fds) = classTvsFds cls - qtv_set1 = mkVarSet qtvs1 - - is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) - | instanceCantMatch trimmed_tcs rough_tcs2 - = False - | otherwise - = case tcUnifyTyKis bind_fn ltys1 ltys2 of - Nothing -> False - Just subst - -> isNothing $ -- Bogus legacy test (#10675) - -- See Note [Bogus consistency check] - tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) - - where - trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 - (ltys1, rtys1) = instFD fd cls_tvs tys1 - (ltys2, rtys2) = instFD fd cls_tvs tys2 - qtv_set2 = mkVarSet qtvs2 - bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe - | tv `elemVarSet` qtv_set2 = BindMe - | otherwise = Skolem - - eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 - -- A single instance may appear twice in the un-nubbed conflict list - -- because it may conflict with more than one fundep. E.g. - -- class C a b c | a -> b, a -> c - -- instance C Int Bool Bool - -- instance C Int Char Char - -- The second instance conflicts with the first by *both* fundeps - -trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] --- Computing rough_tcs for a particular fundep --- class C a b c | a -> b where ... --- For each instance .... => C ta tb tc --- we want to match only on the type ta; so our --- rough-match thing must similarly be filtered. --- Hence, we Nothing-ise the tb and tc types right here --- --- Result list is same length as input list, just with more Nothings -trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs - = zipWith select clas_tvs mb_tcs - where - select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = Nothing diff --git a/typecheck/Inst.hs b/typecheck/Inst.hs deleted file mode 100644 --- a/typecheck/Inst.hs +++ /dev/null @@ -1,847 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @Inst@ type: dictionaries or method instances --} - -{-# LANGUAGE CPP, MultiWayIf, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - -module Inst ( - deeplySkolemise, - topInstantiate, topInstantiateInferred, deeplyInstantiate, - instCall, instDFunType, instStupidTheta, instTyVarsWith, - newWanted, newWanteds, - - tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, - - newOverloadedLit, mkOverLit, - - newClsInst, - tcGetInsts, tcGetInstEnvs, getOverlapFlag, - tcExtendLocalInstEnv, - instCallConstraints, newMethodFromName, - tcSyntaxName, - - -- Simple functions over evidence variables - tyCoVarsOfWC, - tyCoVarsOfCt, tyCoVarsOfCts, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} TcUnify( unifyType, unifyKind ) - -import BasicTypes ( IntegralLit(..), SourceText(..) ) -import FastString -import GHC.Hs -import TcHsSyn -import TcRnMonad -import Constraint -import Predicate -import TcOrigin -import TcEnv -import TcEvidence -import InstEnv -import TysWiredIn ( heqDataCon, eqDataCon ) -import CoreSyn ( isOrphan ) -import FunDeps -import TcMType -import Type -import TyCoRep -import TyCoPpr ( debugPprType ) -import TcType -import HscTypes -import Class( Class ) -import MkId( mkDictFunId ) -import CoreSyn( Expr(..) ) -- For the Coercion constructor -import Id -import Name -import Var ( EvVar, tyVarName, VarBndr(..) ) -import DataCon -import VarEnv -import PrelNames -import SrcLoc -import DynFlags -import Util -import Outputable -import BasicTypes ( TypeOrKind(..) ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad( unless ) - -{- -************************************************************************ -* * - Creating and emittind constraints -* * -************************************************************************ --} - -newMethodFromName - :: CtOrigin -- ^ why do we need this? - -> Name -- ^ name of the method - -> [TcRhoType] -- ^ types with which to instantiate the class - -> TcM (HsExpr GhcTcId) --- ^ Used when 'Name' is the wired-in name for a wired-in class method, --- so the caller knows its type for sure, which should be of form --- --- > forall a. C a => --- --- 'newMethodFromName' is supposed to instantiate just the outer --- type variable and constraint - -newMethodFromName origin name ty_args - = do { id <- tcLookupId name - -- Use tcLookupId not tcLookupGlobalId; the method is almost - -- always a class op, but with -XRebindableSyntax GHC is - -- meant to find whatever thing is in scope, and that may - -- be an ordinary function. - - ; let ty = piResultTys (idType id) ty_args - (theta, _caller_knows_this) = tcSplitPhiTy ty - ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) - instCall origin ty_args theta - - ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } - -{- -************************************************************************ -* * - Deep instantiation and skolemisation -* * -************************************************************************ - -Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -deeplySkolemise decomposes and skolemises a type, returning a type -with all its arrows visible (ie not buried under foralls) - -Examples: - - deeplySkolemise (Int -> forall a. Ord a => blah) - = ( wp, [a], [d:Ord a], Int -> blah ) - where wp = \x:Int. /\a. \(d:Ord a). x - - deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) - = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) - where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x - -In general, - if deeplySkolemise ty = (wrap, tvs, evs, rho) - and e :: rho - then wrap e :: ty - and 'wrap' binds tvs, evs - -ToDo: this eta-abstraction plays fast and loose with termination, - because it can introduce extra lambdas. Maybe add a `seq` to - fix this --} - -deeplySkolemise :: TcSigmaType - -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s - , TcRhoType ) - -deeplySkolemise ty - = go init_subst ty - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty - = do { let arg_tys' = substTys subst arg_tys - ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs - ; ev_vars1 <- newEvVars (substTheta subst' theta) - ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' - ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpLams ids1 - <.> mkWpTyLams tvs1 - <.> mkWpLams ev_vars1 - <.> wrap - <.> mkWpEvVarApps ids1 - , tv_prs1 ++ tvs_prs2 - , ev_vars1 ++ ev_vars2 - , mkVisFunTys arg_tys' rho ) } - - | otherwise - = return (idHsWrapper, [], [], substTy subst ty) - -- substTy is a quick no-op on an empty substitution - --- | Instantiate all outer type variables --- and any context. Never looks through arrows. -topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho (that is, wrap :: ty "->" rho) -topInstantiate = top_instantiate True - --- | Instantiate all outer 'Inferred' binders --- and any context. Never looks through arrows or specified type variables. --- Used for visible type application. -topInstantiateInferred :: CtOrigin -> TcSigmaType - -> TcM (HsWrapper, TcSigmaType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho -topInstantiateInferred = top_instantiate False - -top_instantiate :: Bool -- True <=> instantiate *all* variables - -- False <=> instantiate only the inferred ones - -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -top_instantiate inst_all orig ty - | not (null binders && null theta) - = do { let (inst_bndrs, leave_bndrs) = span should_inst binders - (inst_theta, leave_theta) - | null leave_bndrs = (theta, []) - | otherwise = ([], theta) - in_scope = mkInScopeSet (tyCoVarsOfType ty) - empty_subst = mkEmptyTCvSubst in_scope - inst_tvs = binderVars inst_bndrs - ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs - ; let inst_theta' = substTheta subst inst_theta - sigma' = substTy subst (mkForAllTys leave_bndrs $ - mkPhiTy leave_theta rho) - inst_tv_tys' = mkTyVarTys inst_tvs' - - ; wrap1 <- instCall orig inst_tv_tys' inst_theta' - ; traceTc "Instantiating" - (vcat [ text "all tyvars?" <+> ppr inst_all - , text "origin" <+> pprCtOrigin orig - , text "type" <+> debugPprType ty - , text "theta" <+> ppr theta - , text "leave_bndrs" <+> ppr leave_bndrs - , text "with" <+> vcat (map debugPprType inst_tv_tys') - , text "theta:" <+> ppr inst_theta' ]) - - ; (wrap2, rho2) <- - if null leave_bndrs - - -- account for types like forall a. Num a => forall b. Ord b => ... - then top_instantiate inst_all orig sigma' - - -- but don't loop if there were any un-inst'able tyvars - else return (idHsWrapper, sigma') - - ; return (wrap2 <.> wrap1, rho2) } - - | otherwise = return (idHsWrapper, ty) - where - (binders, phi) = tcSplitForAllVarBndrs ty - (theta, rho) = tcSplitPhiTy phi - - should_inst bndr - | inst_all = True - | otherwise = binderArgFlag bndr == Inferred - -deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha --- In general if --- if deeplyInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho --- That is, wrap :: ty ~> rho --- --- If you don't need the HsWrapper returned from this function, consider --- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that --- only computes the returned TcRhoType. - -deeplyInstantiate orig ty = - deeply_instantiate orig - (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))) - ty - -deeply_instantiate :: CtOrigin - -> TCvSubst - -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Internal function to deeply instantiate that builds on an existing subst. --- It extends the input substitution and applies the final subtitution to --- the types on return. See #12549. - -deeply_instantiate orig subst ty - | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty - = do { (subst', tvs') <- newMetaTyVarsX subst tvs - ; let arg_tys' = substTys subst' arg_tys - theta' = substTheta subst' theta - ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' - ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' - ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig - , text "type" <+> ppr ty - , text "with" <+> ppr tvs' - , text "args:" <+> ppr ids1 - , text "theta:" <+> ppr theta' - , text "subst:" <+> ppr subst']) - ; (wrap2, rho2) <- deeply_instantiate orig subst' rho - ; return (mkWpLams ids1 - <.> wrap2 - <.> wrap1 - <.> mkWpEvVarApps ids1, - mkVisFunTys arg_tys' rho2) } - - | otherwise - = do { let ty' = substTy subst ty - ; traceTc "deeply_instantiate final subst" - (vcat [ text "origin:" <+> pprCtOrigin orig - , text "type:" <+> ppr ty - , text "new type:" <+> ppr ty' - , text "subst:" <+> ppr subst ]) - ; return (idHsWrapper, ty') } - - -instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst --- Use this when you want to instantiate (forall a b c. ty) with --- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might --- not yet match (perhaps because there are unsolved constraints; #14154) --- If they don't match, emit a kind-equality to promise that they will --- eventually do so, and thus make a kind-homongeneous substitution. -instTyVarsWith orig tvs tys - = go emptyTCvSubst tvs tys - where - go subst [] [] - = return subst - go subst (tv:tvs) (ty:tys) - | tv_kind `tcEqType` ty_kind - = go (extendTvSubstAndInScope subst tv ty) tvs tys - | otherwise - = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind - ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } - where - tv_kind = substTy subst (tyVarKind tv) - ty_kind = tcTypeKind ty - - go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) - - -{- -************************************************************************ -* * - Instantiating a call -* * -************************************************************************ - -Note [Handling boxed equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The solver deals entirely in terms of unboxed (primitive) equality. -There should never be a boxed Wanted equality. Ever. But, what if -we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality -is boxed, so naive treatment here would emit a boxed Wanted equality. - -So we simply check for this case and make the right boxing of evidence. - --} - ----------------- -instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper --- Instantiate the constraints of a call --- (instCall o tys theta) --- (a) Makes fresh dictionaries as necessary for the constraints (theta) --- (b) Throws these dictionaries into the LIE --- (c) Returns an HsWrapper ([.] tys dicts) - -instCall orig tys theta - = do { dict_app <- instCallConstraints orig theta - ; return (dict_app <.> mkWpTyApps tys) } - ----------------- -instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper --- Instantiates the TcTheta, puts all constraints thereby generated --- into the LIE, and returns a HsWrapper to enclose the call site. - -instCallConstraints orig preds - | null preds - = return idHsWrapper - | otherwise - = do { evs <- mapM go preds - ; traceTc "instCallConstraints" (ppr evs) - ; return (mkWpEvApps evs) } - where - go :: TcPredType -> TcM EvTerm - go pred - | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 - = do { co <- unifyType Nothing ty1 ty2 - ; return (evCoercion co) } - - -- Try short-cut #2 - | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred - , tc `hasKey` heqTyConKey - = do { co <- unifyType Nothing ty1 ty2 - ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) } - - | otherwise - = emitWanted orig pred - -instDFunType :: DFunId -> [DFunInstType] - -> TcM ( [TcType] -- instantiated argument types - , TcThetaType ) -- instantiated constraint --- See Note [DFunInstType: instantiating types] in InstEnv -instDFunType dfun_id dfun_inst_tys - = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys - ; return (inst_tys, substTheta subst dfun_theta) } - where - dfun_ty = idType dfun_id - (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) - -- With quantified constraints, the - -- type of a dfun may not be closed - - go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) - go subst [] [] = return (subst, []) - go subst (tv:tvs) (Just ty : mb_tys) - = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) - tvs - mb_tys - ; return (subst', ty : tys) } - go subst (tv:tvs) (Nothing : mb_tys) - = do { (subst', tv') <- newMetaTyVarX subst tv - ; (subst'', tys) <- go subst' tvs mb_tys - ; return (subst'', mkTyVarTy tv' : tys) } - go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys) - ----------------- -instStupidTheta :: CtOrigin -> TcThetaType -> TcM () --- Similar to instCall, but only emit the constraints in the LIE --- Used exclusively for the 'stupid theta' of a data constructor -instStupidTheta orig theta - = do { _co <- instCallConstraints orig theta -- Discard the coercion - ; return () } - - -{- ********************************************************************* -* * - Instantiating Kinds -* * -********************************************************************* -} - --- | Instantiates up to n invisible binders --- Returns the instantiating types, and body kind -tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind) - -tcInstInvisibleTyBinders 0 kind - = return ([], kind) -tcInstInvisibleTyBinders n ty - = go n empty_subst ty - where - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) - - go n subst kind - | n > 0 - , Just (bndr, body) <- tcSplitPiTy_maybe kind - , isInvisibleBinder bndr - = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr - ; (args, inner_ty) <- go (n-1) subst' body - ; return (arg:args, inner_ty) } - | otherwise - = return ([], substTy subst kind) - --- | Used only in *types* -tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) -tcInstInvisibleTyBinder subst (Named (Bndr tv _)) - = do { (subst', tv') <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy tv') } - -tcInstInvisibleTyBinder subst (Anon af ty) - | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty) - -- Equality is the *only* constraint currently handled in types. - -- See Note [Constraints in kinds] in TyCoRep - = ASSERT( af == InvisArg ) - do { co <- unifyKind Nothing k1 k2 - ; arg' <- mk co - ; return (subst, arg') } - - | otherwise -- This should never happen - -- See TyCoRep Note [Constraints in kinds] - = pprPanic "tcInvisibleTyBinder" (ppr ty) - -------------------------------- -get_eq_tys_maybe :: Type - -> Maybe ( Coercion -> TcM Type - -- given a coercion proving t1 ~# t2, produce the - -- right instantiation for the TyBinder at hand - , Type -- t1 - , Type -- t2 - ) --- See Note [Constraints in kinds] in TyCoRep -get_eq_tys_maybe ty - -- Lifted heterogeneous equality (~~) - | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` heqTyConKey - = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2) - - -- Lifted homogeneous equality (~) - | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` eqTyConKey - = Just (\co -> mkEqBoxTy co k1 k2, k1, k2) - - | otherwise - = Nothing - --- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkHEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - --- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type -mkEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] - where k = tcTypeKind ty1 - -{- -************************************************************************ -* * - Literals -* * -************************************************************************ - --} - -{- -In newOverloadedLit we convert directly to an Int or Integer if we -know that's what we want. This may save some time, by not -temporarily generating overloaded literals, but it won't catch all -cases (the rest are caught in lookupInst). - --} - -newOverloadedLit :: HsOverLit GhcRn - -> ExpRhoType - -> TcM (HsOverLit GhcTcId) -newOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty - | not rebindable - -- all built-in overloaded lits are tau-types, so we can just - -- tauify the ExpType - = do { res_ty <- expTypeToType res_ty - ; dflags <- getDynFlags - ; case shortCutLit dflags val res_ty of - -- Do not generate a LitInst for rebindable syntax. - -- Reason: If we do, tcSimplify will call lookupInst, which - -- will call tcSyntaxName, which does unification, - -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr - , ol_ext = OverLitTc False res_ty }) - Nothing -> newNonTrivialOverloadedLit orig lit - (mkCheckExpType res_ty) } - - | otherwise - = newNonTrivialOverloadedLit orig lit res_ty - where - orig = LiteralOrigin lit -newOverloadedLit (XOverLit nec) _ = noExtCon nec - --- Does not handle things that 'shortCutLit' can handle. See also --- newOverloadedLit in TcUnify -newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit GhcRn - -> ExpRhoType - -> TcM (HsOverLit GhcTcId) -newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) - , ol_ext = rebindable }) res_ty - = do { hs_lit <- mkOverLit val - ; let lit_ty = hsLitType hs_lit - ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) - [synKnownType lit_ty] res_ty $ - \_ -> return () - ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] - ; res_ty <- readExpType res_ty - ; return (lit { ol_witness = witness - , ol_ext = OverLitTc rebindable res_ty }) } -newNonTrivialOverloadedLit _ lit _ - = pprPanic "newNonTrivialOverloadedLit" (ppr lit) - ------------- -mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) -mkOverLit (HsIntegral i) - = do { integer_ty <- tcMetaTy integerTyConName - ; return (HsInteger (il_text i) - (il_value i) integer_ty) } - -mkOverLit (HsFractional r) - = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat noExtField r rat_ty) } - -mkOverLit (HsIsString src s) = return (HsString src s) - -{- -************************************************************************ -* * - Re-mappable syntax - - Used only for arrow syntax -- find a way to nuke this -* * -************************************************************************ - -Suppose we are doing the -XRebindableSyntax thing, and we encounter -a do-expression. We have to find (>>) in the current environment, which is -done by the rename. Then we have to check that it has the same type as -Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had -this: - - (>>) :: HB m n mn => m a -> n b -> mn b - -So the idea is to generate a local binding for (>>), thus: - - let then72 :: forall a b. m a -> m b -> m b - then72 = ...something involving the user's (>>)... - in - ...the do-expression... - -Now the do-expression can proceed using then72, which has exactly -the expected type. - -In fact tcSyntaxName just generates the RHS for then72, because we only -want an actual binding in the do-expression case. For literals, we can -just use the expression inline. --} - -tcSyntaxName :: CtOrigin - -> TcType -- ^ Type to instantiate it at - -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) - -> TcM (Name, HsExpr GhcTcId) - -- ^ (Standard name, suitable expression) --- USED ONLY FOR CmdTop (sigh) *** --- See Note [CmdSyntaxTable] in GHC.Hs.Expr - -tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) - | std_nm == user_nm - = do rhs <- newMethodFromName orig std_nm [ty] - return (std_nm, rhs) - -tcSyntaxName orig ty (std_nm, user_nm_expr) = do - std_id <- tcLookupId std_nm - let - -- C.f. newMethodAtLoc - ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - sigma1 = substTyWith [tv] [ty] tau - -- Actually, the "tau-type" might be a sigma-type in the - -- case of locally-polymorphic methods. - - addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do - - -- Check that the user-supplied thing has the - -- same type as the standard one. - -- Tiresome jiggling because tcCheckSigma takes a located expression - span <- getSrcSpanM - expr <- tcPolyExpr (L span user_nm_expr) sigma1 - return (std_nm, unLoc expr) - -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv - -> TcRn (TidyEnv, SDoc) -syntaxNameCtxt name orig ty tidy_env - = do { inst_loc <- getCtLocM orig (Just TypeLevel) - ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) - <+> text "(needed by a syntactic construct)" - , nest 2 (text "has the required type:" - <+> ppr (tidyType tidy_env ty)) - , nest 2 (pprCtLoc inst_loc) ] - ; return (tidy_env, msg) } - -{- -************************************************************************ -* * - Instances -* * -************************************************************************ --} - -getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag --- Construct the OverlapFlag from the global module flags, --- but if the overlap_mode argument is (Just m), --- set the OverlapMode to 'm' -getOverlapFlag overlap_mode - = do { dflags <- getDynFlags - ; let overlap_ok = xopt LangExt.OverlappingInstances dflags - incoherent_ok = xopt LangExt.IncoherentInstances dflags - use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags - , overlapMode = x } - default_oflag | incoherent_ok = use (Incoherent NoSourceText) - | overlap_ok = use (Overlaps NoSourceText) - | otherwise = use (NoOverlap NoSourceText) - - final_oflag = setOverlapModeMaybe default_oflag overlap_mode - ; return final_oflag } - -tcGetInsts :: TcM [ClsInst] --- Gets the local class instances. -tcGetInsts = fmap tcg_insts getGblEnv - -newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcM ClsInst -newClsInst overlap_mode dfun_name tvs theta clas tys - = do { (subst, tvs') <- freshenTyVarBndrs tvs - -- Be sure to freshen those type variables, - -- so they are sure not to appear in any lookup - ; let tys' = substTys subst tys - - dfun = mkDictFunId dfun_name tvs theta clas tys - -- The dfun uses the original 'tvs' because - -- (a) they don't need to be fresh - -- (b) they may be mentioned in the ib_binds field of - -- an InstInfo, and in TcEnv.pprInstInfoDetails it's - -- helpful to use the same names - - ; oflag <- getOverlapFlag overlap_mode - ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; warnIfFlag Opt_WarnOrphans - (isOrphan (is_orphan inst)) - (instOrphWarn inst) - ; return inst } - -instOrphWarn :: ClsInst -> SDoc -instOrphWarn inst - = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) - $$ text "To avoid this" - $$ nest 4 (vcat possibilities) - where - possibilities = - text "move the instance declaration to the module of the class or of the type, or" : - text "wrap the type with a newtype and declare the instance on the new type." : - [] - -tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a - -- Add new locally-defined instances -tcExtendLocalInstEnv dfuns thing_inside - = do { traceDFuns dfuns - ; env <- getGblEnv - ; (inst_env', cls_insts') <- foldlM addLocalInst - (tcg_inst_env env, tcg_insts env) - dfuns - ; let env' = env { tcg_insts = cls_insts' - , tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- If overwrite_inst, then we can overwrite a direct match -addLocalInst (home_ie, my_insts) ispec - = do { - -- Load imported instances, so that we report - -- duplicates correctly - - -- 'matches' are existing instance declarations that are less - -- specific than the new one - -- 'dups' are those 'matches' that are equal to the new one - ; isGHCi <- getIsGHCi - ; eps <- getEps - ; tcg_env <- getGblEnv - - -- In GHCi, we *override* any identical instances - -- that are also defined in the interactive context - -- See Note [Override identical instances in GHCi] - ; let home_ie' - | isGHCi = deleteFromInstEnv home_ie ispec - | otherwise = home_ie - - global_ie = eps_inst_env eps - inst_envs = InstEnvs { ie_global = global_ie - , ie_local = home_ie' - , ie_visible = tcVisibleOrphanMods tcg_env } - - -- Check for inconsistent functional dependencies - ; let inconsistent_ispecs = checkFunDeps inst_envs ispec - ; unless (null inconsistent_ispecs) $ - funDepErr ispec inconsistent_ispecs - - -- Check for duplicate instance decls. - ; let (_tvs, cls, tys) = instanceHead ispec - (matches, _, _) = lookupInstEnv False inst_envs cls tys - dups = filter (identicalClsInstHead ispec) (map fst matches) - ; unless (null dups) $ - dupInstErr ispec (head dups) - - ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } - -{- -Note [Signature files and type class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instances in signature files do not have an effect when compiling: -when you compile a signature against an implementation, you will -see the instances WHETHER OR NOT the instance is declared in -the file (this is because the signatures go in the EPS and we -can't filter them out easily.) This is also why we cannot -place the instance in the hi file: it would show up as a duplicate, -and we don't have instance reexports anyway. - -However, you might find them useful when typechecking against -a signature: the instance is a way of indicating to GHC that -some instance exists, in case downstream code uses it. - -Implementing this is a little tricky. Consider the following -situation (sigof03): - - module A where - instance C T where ... - - module ASig where - instance C T - -When compiling ASig, A.hi is loaded, which brings its instances -into the EPS. When we process the instance declaration in ASig, -we should ignore it for the purpose of doing a duplicate check, -since it's not actually a duplicate. But don't skip the check -entirely, we still want this to fail (tcfail221): - - module ASig where - instance C T - instance C T - -Note that in some situations, the interface containing the type -class instances may not have been loaded yet at all. The usual -situation when A imports another module which provides the -instances (sigof02m): - - module A(module B) where - import B - -See also Note [Signature lazy interface loading]. We can't -rely on this, however, since sometimes we'll have spurious -type class instances in the EPS, see #9422 (sigof02dm) - -************************************************************************ -* * - Errors and tracing -* * -************************************************************************ --} - -traceDFuns :: [ClsInst] -> TcRn () -traceDFuns ispecs - = traceTc "Adding instances:" (vcat (map pp ispecs)) - where - pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) - 2 (ppr ispec) - -- Print the dfun name itself too - -funDepErr :: ClsInst -> [ClsInst] -> TcRn () -funDepErr ispec ispecs - = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") - (ispec : ispecs) - -dupInstErr :: ClsInst -> ClsInst -> TcRn () -dupInstErr ispec dup_ispec - = addClsInstsErr (text "Duplicate instance declarations:") - [ispec, dup_ispec] - -addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () -addClsInstsErr herald ispecs - = setSrcSpan (getSrcSpan (head sorted)) $ - addErr (hang herald 2 (pprInstances sorted)) - where - sorted = sortWith getSrcLoc ispecs - -- The sortWith just arranges that instances are dislayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users diff --git a/typecheck/TcAnnotations.hs b/typecheck/TcAnnotations.hs deleted file mode 100644 --- a/typecheck/TcAnnotations.hs +++ /dev/null @@ -1,79 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcAnnotations]{Typechecking annotations} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module TcAnnotations ( tcAnnotations, annCtxt ) where - -import GhcPrelude - -import {-# SOURCE #-} TcSplice ( runAnnotation ) -import Module -import DynFlags -import Control.Monad ( when ) - -import GHC.Hs -import Name -import Annotations -import TcRnMonad -import SrcLoc -import Outputable - --- Some platforms don't support the external interpreter, and --- compilation on those platforms shouldn't fail just due to --- annotations -#if !defined(HAVE_INTERNAL_INTERPRETER) -tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] -tcAnnotations anns = do - dflags <- getDynFlags - case gopt Opt_ExternalInterpreter dflags of - True -> tcAnnotations' anns - False -> warnAnns anns -warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] ---- No GHCI; emit a warning (not an error) and ignore. cf #4268 -warnAnns [] = return [] -warnAnns anns@(L loc _ : _) - = do { setSrcSpan loc $ addWarnTc NoReason $ - (text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") - ; return [] } -#else -tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] -tcAnnotations = tcAnnotations' -#endif - -tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation] -tcAnnotations' anns = mapM tcAnnotation anns - -tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation -tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do - -- Work out what the full target of this annotation was - mod <- getModule - let target = annProvenanceToTarget mod provenance - - -- Run that annotation and construct the full Annotation data structure - setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do - -- See #10826 -- Annotations allow one to bypass Safe Haskell. - dflags <- getDynFlags - when (safeLanguageOn dflags) $ failWithTc safeHsErr - runAnnotation target expr - where - safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] -tcAnnotation (L _ (XAnnDecl nec)) = noExtCon nec - -annProvenanceToTarget :: Module -> AnnProvenance Name - -> AnnTarget Name -annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod - -annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc -annCtxt ann - = hang (text "In the annotation:") 2 (ppr ann) diff --git a/typecheck/TcArrows.hs b/typecheck/TcArrows.hs deleted file mode 100644 --- a/typecheck/TcArrows.hs +++ /dev/null @@ -1,441 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Typecheck arrow notation --} - -{-# LANGUAGE RankNTypes, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - -module TcArrows ( tcProc ) where - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) - -import GHC.Hs -import TcMatches -import TcHsSyn( hsLPatType ) -import TcType -import TcMType -import TcBinds -import TcPat -import TcUnify -import TcRnMonad -import TcEnv -import TcOrigin -import TcEvidence -import Id( mkLocalId ) -import Inst -import Name -import TysWiredIn -import VarSet -import TysPrim -import BasicTypes( Arity ) -import SrcLoc -import Outputable -import Util - -import Control.Monad - -{- -Note [Arrow overview] -~~~~~~~~~~~~~~~~~~~~~ -Here's a summary of arrows and how they typecheck. First, here's -a cut-down syntax: - - expr ::= .... - | proc pat cmd - - cmd ::= cmd exp -- Arrow application - | \pat -> cmd -- Arrow abstraction - | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 - | ... -- If, case in the usual way - - cmd_type ::= carg_type --> type - - carg_type ::= () - | (type, carg_type) - -Note that - * The 'exp' in an arrow form can mention only - "arrow-local" variables - - * An "arrow-local" variable is bound by an enclosing - cmd binding form (eg arrow abstraction) - - * A cmd_type is here written with a funny arrow "-->", - The bit on the left is a carg_type (command argument type) - which itself is a nested tuple, finishing with () - - * The arrow-tail operator (e1 -< e2) means - (| e1 <<< arr snd |) e2 - - -************************************************************************ -* * - Proc -* * -************************************************************************ --} - -tcProc :: InPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr - -> ExpRhoType -- Expected type of whole proc expression - -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion) - -tcProc pat cmd exp_ty - = newArrowScope $ - do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows - ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty - ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 - ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $ - tcCmdTop cmd_env cmd (unitTy, res_ty) - ; let res_co = mkTcTransCo co - (mkTcAppCo co1 (mkTcNomReflCo res_ty)) - ; return (pat', cmd', res_co) } - -{- -************************************************************************ -* * - Commands -* * -************************************************************************ --} - --- See Note [Arrow overview] -type CmdType = (CmdArgType, TcTauType) -- cmd_type -type CmdArgType = TcTauType -- carg_type, a nested tuple - -data CmdEnv - = CmdEnv { - cmd_arr :: TcType -- arrow type constructor, of kind *->*->* - } - -mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType -mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] - ---------------------------------------- -tcCmdTop :: CmdEnv - -> LHsCmdTop GhcRn - -> CmdType - -> TcM (LHsCmdTop GhcTcId) - -tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) - = setSrcSpan loc $ - do { cmd' <- tcCmd env cmd cmd_ty - ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } -tcCmdTop _ (L _ (XCmdTop nec)) _ = noExtCon nec - ----------------------------------------- -tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) - -- The main recursive function -tcCmd env (L loc cmd) res_ty - = setSrcSpan loc $ do - { cmd' <- tc_cmd env cmd res_ty - ; return (L loc cmd') } - -tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId) -tc_cmd env (HsCmdPar x cmd) res_ty - = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar x cmd') } - -tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty - = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ - tc_cmd env body res_ty - ; return (HsCmdLet x (L l binds') (L body_loc body')) } - -tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) - = addErrCtxt (cmdCtxt in_cmd) $ do - (scrut', scrut_ty) <- tcInferRho scrut - matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) - return (HsCmdCase x scrut' matches') - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = mc_body } - mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' - ; tcCmd env body (stk, res_ty') } - -tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x Nothing pred' b1' b2') - } - -tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if - = do { pred_ty <- newOpenFlexiTyVarTy - -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r - -- because we're going to apply it to the environment, not - -- the return value. - ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] - ; let r_ty = mkTyVarTy r_tv - ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (text "Predicate type of `ifThenElse' depends on result type") - ; (pred', fun') - <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) - (mkCheckExpType r_ty) $ \ _ -> - tcMonoExpr pred (mkCheckExpType pred_ty) - - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x (Just fun') pred' b1' b2') - } - -------------------------------------------- --- Arrow application --- (f -< a) or (f -<< a) --- --- D |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -< arg :: stk --> t2 --- --- D,G |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -<< arg :: stk --> t2 --- --- (plus -<< requires ArrowApply) - -tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; let fun_ty = mkCmdArrTy env arg_ty res_ty - ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty)) - - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - - ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } - where - -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside f. In the higher-order case (-<<), they are. - -- See Note [Escaping the arrow scope] in TcRnTypes - select_arrow_scope tc = case ho_app of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - -------------------------------------------- --- Command application --- --- D,G |- exp : t --- D;G |-a cmd : (t,stk) --> res --- ----------------------------- --- D;G |-a cmd exp : stk --> res - -tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdApp x fun' arg') } - -------------------------------------------- --- Lambda --- --- D;G,x:t |-a cmd : stk --> res --- ------------------------------ --- D;G |-a (\x.cmd) : (t,stk) --> res - -tc_cmd env - (HsCmdLam x (MG { mg_alts = L l [L mtch_loc - (match@(Match { m_pats = pats, m_grhss = grhss }))], - mg_origin = origin })) - (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match) $ - do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - - -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ - tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - - ; let match' = L mtch_loc (Match { m_ext = noExtField - , m_ctxt = LambdaExpr, m_pats = pats' - , m_grhss = grhss' }) - arg_tys = map hsLPatType pats' - cmd' = HsCmdLam x (MG { mg_alts = L l [match'] - , mg_ext = MatchGroupTc arg_tys res_ty - , mg_origin = origin }) - ; return (mkHsCmdWrap (mkWpCastN co) cmd') } - where - n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? - pg_ctxt = PatGuard match_ctxt - - tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs x grhss' (L l binds')) } - tc_grhss (XGRHSs nec) _ _ = noExtCon nec - - tc_grhs stk_ty res_ty (GRHS x guards body) - = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body - (stk_ty, checkingExpType "tc_grhs" res_ty) - ; return (GRHS x guards' rhs') } - tc_grhs _ _ (XGRHS nec) = noExtCon nec - -------------------------------------------- --- Do notation - -tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) - = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } - - ------------------------------------------------------------------ --- Arrow ``forms'' (| e c1 .. cn |) --- --- D; G |-a1 c1 : stk1 --> r1 --- ... --- D; G |-an cn : stkn --> rn --- D |- e :: forall e. a1 (e, stk1) t1 --- ... --- -> an (e, stkn) tn --- -> a (e, stk) t --- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) --- ---------------------------------------------- --- D; G |-a (| e c1 ... cn |) : stk --> t - -tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args - -- We use alphaTyVar for 'w' - ; let e_ty = mkInvForAllTy alphaTyVar $ - mkVisFunTys cmd_tys $ - mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty - ; expr' <- tcPolyExpr expr e_ty - ; return (HsCmdArrForm x expr' f fixity cmd_args') } - - where - tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) - tc_cmd_arg cmd - = do { arr_ty <- newFlexiTyVarTy arrowTyConKind - ; stk_ty <- newFlexiTyVarTy liftedTypeKind - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let env' = env { cmd_arr = arr_ty } - ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) - ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } - -tc_cmd _ (XCmd nec) _ = noExtCon nec - ------------------------------------------------------------------ --- Base case for illegal commands --- This is where expressions that aren't commands get rejected - -tc_cmd _ cmd _ - = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), - text "was found where an arrow command was expected"]) - - -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) -matchExpectedCmdArgs 0 ty - = return (mkTcNomReflCo ty, [], ty) -matchExpectedCmdArgs n ty - = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty - ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 - ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } - -{- -************************************************************************ -* * - Stmts -* * -************************************************************************ --} - --------------------------------- --- Mdo-notation --- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax - -tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker -tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside - = do { rhs' <- tcCmd env rhs (unitTy, res_ty) - ; thing <- thing_inside (panic "tcArrDoStmt") - ; return (LastStmt x rhs' noret noSyntaxExpr, thing) } - -tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_arr_rhs env rhs - ; thing <- thing_inside res_ty - ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) } - -tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names }) res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - ; tcExtendIdEnv tup_ids $ do - { (stmts', tup_rets) - <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right - zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) - - ; thing <- thing_inside res_ty - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in GHC.Hs.Expr) - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - - ; let rec_rets = takeList rec_names tup_rets - ; let ret_table = zip tup_ids tup_rets - ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] - - ; return (emptyRecStmtId { recS_stmts = stmts' - , recS_later_ids = later_ids - , recS_rec_ids = rec_ids - , recS_ext = unitRecStmtTc - { recS_later_rets = later_rets - , recS_rec_rets = rec_rets - , recS_ret_ty = res_ty} }, thing) - }} - -tcArrDoStmt _ _ stmt _ _ - = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) - -tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType) -tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs (unitTy, ty) - ; return (rhs', ty) } - -{- -************************************************************************ -* * - Helpers -* * -************************************************************************ --} - -mkPairTy :: Type -> Type -> Type -mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] - -arrowTyConKind :: Kind -- *->*->* -arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind - -{- -************************************************************************ -* * - Errors -* * -************************************************************************ --} - -cmdCtxt :: HsCmd GhcRn -> SDoc -cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/typecheck/TcBackpack.hs b/typecheck/TcBackpack.hs deleted file mode 100644 --- a/typecheck/TcBackpack.hs +++ /dev/null @@ -1,1002 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module TcBackpack ( - findExtraSigImports', - findExtraSigImports, - implicitRequirements', - implicitRequirements, - checkUnitId, - tcRnCheckUnitId, - tcRnMergeSignatures, - mergeSignatures, - tcRnInstantiateSignature, - instantiateSignature, -) where - -import GhcPrelude - -import BasicTypes (defaultFixity, TypeOrKind(..)) -import Packages -import TcRnExports -import DynFlags -import GHC.Hs -import RdrName -import TcRnMonad -import TcTyDecls -import InstEnv -import FamInstEnv -import Inst -import TcIface -import TcMType -import TcType -import TcSimplify -import Constraint -import TcOrigin -import LoadIface -import RnNames -import ErrUtils -import Id -import Module -import Name -import NameEnv -import NameSet -import Avail -import SrcLoc -import HscTypes -import Outputable -import Type -import FastString -import RnFixity ( lookupFixityRn ) -import Maybes -import TcEnv -import Var -import IfaceSyn -import PrelNames -import qualified Data.Map as Map - -import Finder -import UniqDSet -import NameShape -import TcErrors -import TcUnify -import RnModIface -import Util - -import Control.Monad -import Data.List (find) - -import {-# SOURCE #-} TcRnDriver - -#include "HsVersions.h" - -fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc -fixityMisMatch real_thing real_fixity sig_fixity = - vcat [ppr real_thing <+> text "has conflicting fixities in the module", - text "and its hsig file", - text "Main module:" <+> ppr_fix real_fixity, - text "Hsig file:" <+> ppr_fix sig_fixity] - where - ppr_fix f = - ppr f <+> - (if f == defaultFixity - then parens (text "default") - else empty) - -checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () -checkHsigDeclM sig_iface sig_thing real_thing = do - let name = getName real_thing - -- TODO: Distinguish between signature merging and signature - -- implementation cases. - checkBootDeclM False sig_thing real_thing - real_fixity <- lookupFixityRn name - let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of - Nothing -> defaultFixity - Just f -> f - when (real_fixity /= sig_fixity) $ - addErrAt (nameSrcSpan name) - (fixityMisMatch real_thing real_fixity sig_fixity) - --- | Given a 'ModDetails' of an instantiated signature (note that the --- 'ModDetails' must be knot-tied consistently with the actual implementation) --- and a 'GlobalRdrEnv' constructed from the implementor of this interface, --- verify that the actual implementation actually matches the original --- interface. --- --- Note that it is already assumed that the implementation *exports* --- a sufficient set of entities, since otherwise the renaming and then --- typechecking of the signature 'ModIface' would have failed. -checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () -checkHsigIface tcg_env gr sig_iface - ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, - md_types = sig_type_env, md_exports = sig_exports } = do - traceTc "checkHsigIface" $ vcat - [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] - mapM_ check_export (map availName sig_exports) - unless (null sig_fam_insts) $ - panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") - -- Delete instances so we don't look them up when - -- checking instance satisfiability - -- TODO: this should not be necessary - tcg_env <- getGblEnv - setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_insts = [], - tcg_fam_insts = [] } $ do - mapM_ check_inst sig_insts - failIfErrsM - where - -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig - -- in package p that defines T; and we implement with himpl:H. Then the - -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just - -- have to look up the right name. - sig_type_occ_env = mkOccEnv - . map (\t -> (nameOccName (getName t), t)) - $ nameEnvElts sig_type_env - dfun_names = map getName sig_insts - check_export name - -- Skip instances, we'll check them later - -- TODO: Actually this should never happen, because DFuns are - -- never exported... - | name `elem` dfun_names = return () - -- See if we can find the type directly in the hsig ModDetails - -- TODO: need to special case wired in names - | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do - -- NB: We use tcLookupImported_maybe because we want to EXCLUDE - -- tcg_env (TODO: but maybe this isn't relevant anymore). - r <- tcLookupImported_maybe name - case r of - Failed err -> addErr err - Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing - - -- The hsig did NOT define this function; that means it must - -- be a reexport. In this case, make sure the 'Name' of the - -- reexport matches the 'Name exported here. - | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = - when (name /= name') $ do - -- See Note [Error reporting bad reexport] - -- TODO: Actually this error swizzle doesn't work - let p (L _ ie) = name `elem` ieNames ie - loc = case tcg_rn_exports tcg_env of - Just es | Just e <- find p (map fst es) - -- TODO: maybe we can be a little more - -- precise here and use the Located - -- info for the *specific* name we matched. - -> getLoc e - _ -> nameSrcSpan name - dflags <- getDynFlags - addErrAt loc - (badReexportedBootThing dflags False name name') - -- This should actually never happen, but whatever... - | otherwise = - addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") - --- Note [Error reporting bad reexport] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- NB: You want to be a bit careful about what location you report on reexports. --- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the --- correct source location. However, if it was *reexported*, obviously the name --- is not going to have the right location. In this case, we need to grovel in --- tcg_rn_exports to figure out where the reexport came from. - - - --- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't --- assume that the implementing file actually implemented the instances (they --- may be reexported from elsewhere). Where should we look for the instances? --- We do the same as we would otherwise: consult the EPS. This isn't perfect --- (we might conclude the module exports an instance when it doesn't, see --- #9422), but we will never refuse to compile something. -check_inst :: ClsInst -> TcM () -check_inst sig_inst = do - -- TODO: This could be very well generalized to support instance - -- declarations in boot files. - tcg_env <- getGblEnv - -- NB: Have to tug on the interface, not necessarily - -- tugged... but it didn't work? - mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) - -- Based off of 'simplifyDeriv' - let ty = idType (instanceDFunId sig_inst) - skol_info = InstSkol - -- Based off of tcSplitDFunTy - (tvs, theta, pred) = - case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, pred) -> - (tvs, theta, pred) }} - origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst - (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - (tclvl,cts) <- pushTcLevelM $ do - wanted <- newWanted origin - (Just TypeLevel) - (substTy skol_subst pred) - givens <- forM theta $ \given -> do - loc <- getCtLocM origin (Just TypeLevel) - let given_pred = substTy skol_subst given - new_ev <- newEvVar given_pred - return CtGiven { ctev_pred = given_pred - -- Doesn't matter, make something up - , ctev_evar = new_ev - , ctev_loc = loc - } - return $ wanted : givens - unsolved <- simplifyWantedsTcM cts - - (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved - reportAllUnsolved (mkImplicWC implic) - --- | Return this list of requirement interfaces that need to be merged --- to form @mod_name@, or @[]@ if this is not a requirement. -requirementMerges :: DynFlags -> ModuleName -> [IndefModule] -requirementMerges dflags mod_name = - fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags))) - --- | For a module @modname@ of type 'HscSource', determine the list --- of extra "imports" of other requirements which should be considered part of --- the import of the requirement, because it transitively depends on those --- requirements by imports of modules from other packages. The situation --- is something like this: --- --- unit p where --- signature A --- signature B --- import A --- --- unit q where --- dependency p[A=,B=] --- signature A --- signature B --- --- Although q's B does not directly import A, we still have to make sure we --- process A first, because the merging process will cause B to indirectly --- import A. This function finds the TRANSITIVE closure of all such imports --- we need to make. -findExtraSigImports' :: HscEnv - -> HscSource - -> ModuleName - -> IO (UniqDSet ModuleName) -findExtraSigImports' hsc_env HsigFile modname = - fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) -> - (initIfaceLoad hsc_env - . withException - $ moduleFreeHolesPrecise (text "findExtraSigImports") - (mkModule (IndefiniteUnitId iuid) mod_name))) - where - reqs = requirementMerges (hsc_dflags hsc_env) modname - -findExtraSigImports' _ _ _ = return emptyUniqDSet - --- | 'findExtraSigImports', but in a convenient form for "GhcMake" and --- "TcRnDriver". -findExtraSigImports :: HscEnv -> HscSource -> ModuleName - -> IO [(Maybe FastString, Located ModuleName)] -findExtraSigImports hsc_env hsc_src modname = do - extra_requirements <- findExtraSigImports' hsc_env hsc_src modname - return [ (Nothing, noLoc mod_name) - | mod_name <- uniqDSetToList extra_requirements ] - --- A version of 'implicitRequirements'' which is more friendly --- for "GhcMake" and "TcRnDriver". -implicitRequirements :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [(Maybe FastString, Located ModuleName)] -implicitRequirements hsc_env normal_imports - = do mns <- implicitRequirements' hsc_env normal_imports - return [ (Nothing, noLoc mn) | mn <- mns ] - --- Given a list of 'import M' statements in a module, figure out --- any extra implicit requirement imports they may have. For --- example, if they 'import M' and M resolves to p[A=], then --- they actually also import the local requirement B. -implicitRequirements' :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [ModuleName] -implicitRequirements' hsc_env normal_imports - = fmap concat $ - forM normal_imports $ \(mb_pkg, L _ imp) -> do - found <- findImportedModule hsc_env imp mb_pkg - case found of - Found _ mod | thisPackage dflags /= moduleUnitId mod -> - return (uniqDSetToList (moduleFreeHoles mod)) - _ -> return [] - where dflags = hsc_dflags hsc_env - --- | Given a 'UnitId', make sure it is well typed. This is because --- unit IDs come from Cabal, which does not know if things are well-typed or --- not; a component may have been filled with implementations for the holes --- that don't actually fulfill the requirements. --- --- INVARIANT: the UnitId is NOT a InstalledUnitId -checkUnitId :: UnitId -> TcM () -checkUnitId uid = do - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef in - forM_ insts $ \(mod_name, mod) -> - -- NB: direct hole instantiations are well-typed by construction - -- (because we FORCE things to be merged in), so don't check them - when (not (isHoleModule mod)) $ do - checkUnitId (moduleUnitId mod) - _ <- mod `checkImplements` IndefModule indef mod_name - return () - _ -> return () -- if it's hashed, must be well-typed - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnCheckUnitId :: - HscEnv -> UnitId -> - IO (Messages, Maybe ()) -tcRnCheckUnitId hsc_env uid = - withTiming dflags - (text "Check unit id" <+> ppr uid) - (const ()) $ - initTc hsc_env - HsigFile -- bogus - False - mAIN -- bogus - (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus - $ checkUnitId uid - where - dflags = hsc_dflags hsc_env - loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) - --- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... - --- | Top-level driver for signature merging (run after typechecking --- an @hsig@ file). -tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages, Maybe TcGblEnv) -tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming dflags - (text "Signature merging" <+> brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ - mergeSignatures hpm orig_tcg_env iface - where - dflags = hsc_dflags hsc_env - this_mod = mi_module iface - real_loc = tcg_top_loc orig_tcg_env - -thinModIface :: [AvailInfo] -> ModIface -> ModIface -thinModIface avails iface = - iface { - mi_exports = avails, - -- mi_fixities = ..., - -- mi_warns = ..., - -- mi_anns = ..., - -- TODO: The use of nameOccName here is a bit dodgy, because - -- perhaps there might be two IfaceTopBndr that are the same - -- OccName but different Name. Requires better understanding - -- of invariants here. - mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls - -- mi_insts = ..., - -- mi_fam_insts = ..., - } - where - decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs - filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) - - exported_occs = mkOccSet [ occName n - | a <- avails - , n <- availNames a ] - exported_decls = filter_decls exported_occs - - non_exported_occs = mkOccSet [ occName n - | (_, d) <- exported_decls - , n <- ifaceDeclNeverExportedRefs d ] - non_exported_decls = filter_decls non_exported_occs - - dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True - dfun_pred _ = False - dfun_decls = filter (dfun_pred . snd) (mi_decls iface) - --- | The list of 'Name's of *non-exported* 'IfaceDecl's which this --- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept --- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps) --- refers to it; we can't decide to keep it by looking at the exports --- of a module after thinning. Keep this synchronized with --- 'rnIfaceDecl'. -ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name] -ifaceDeclNeverExportedRefs d@IfaceFamily{} = - case ifFamFlav d of - IfaceClosedSynFamilyTyCon (Just (n, _)) - -> [n] - _ -> [] -ifaceDeclNeverExportedRefs _ = [] - - --- Note [Blank hsigs for all requirements] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- One invariant that a client of GHC must uphold is that there --- must be an hsig file for every requirement (according to --- @-this-unit-id@); this ensures that for every interface --- file (hi), there is a source file (hsig), which helps grease --- the wheels of recompilation avoidance which assumes that --- source files always exist. - -{- -inheritedSigPvpWarning :: WarningTxt -inheritedSigPvpWarning = - WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))] - where - msg = "Inherited requirements from non-signature libraries (libraries " ++ - "with modules) should not be used, as this mode of use is not " ++ - "compatible with PVP-style version bounds. Instead, copy the " ++ - "declaration to the local hsig file or move the signature to a " ++ - "library of its own and add that library as a dependency." --} - --- Note [Handling never-exported TyThings under Backpack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will --- never be mentioned in the export list of a module (mi_avails). --- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported --- TyThings DO have a standalone IfaceDecl declaration in their --- interface file. --- --- Originally, Backpack was designed under the assumption that anything --- you could declare in a module could also be exported; thus, merging --- the export lists of two signatures is just merging the declarations --- of two signatures writ small. Of course, in GHC Haskell, there are a --- few important things which are not explicitly exported but still can --- be used: in particular, dictionary functions for instances, Typeable --- TyCon bindings, and coercion axioms for type families also count. --- --- When handling these non-exported things, there two primary things --- we need to watch out for: --- --- * Signature matching/merging is done by comparing each --- of the exported entities of a signature and a module. These exported --- entities may refer to non-exported TyThings which must be tested for --- consistency. For example, an instance (ClsInst) will refer to a --- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the --- embedded 'DFunId' in 'is_dfun'. --- --- For this to work at all, we must ensure that pointers in 'is_dfun' refer --- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same. --- Unfortunately, this is the OPPOSITE of how we treat most other references --- to 'Name's, so this case needs to be handled specially. --- --- The details are in the documentation for 'typecheckIfacesForMerging'. --- and the Note [Resolving never-exported Names in TcIface]. --- --- * When we rename modules and signatures, we use the export lists to --- decide how the declarations should be renamed. However, this --- means we don't get any guidance for how to rename non-exported --- entities. Fortunately, we only need to rename these entities --- *consistently*, so that 'typecheckIfacesForMerging' can wire them --- up as needed. --- --- The details are in Note [rnIfaceNeverExported] in 'RnModIface'. --- --- The root cause for all of these complications is the fact that these --- logically "implicit" entities are defined indirectly in an interface --- file. #13151 gives a proposal to make these *truly* implicit. - -merge_msg :: ModuleName -> [IndefModule] -> SDoc -merge_msg mod_name [] = - text "while checking the local signature" <+> ppr mod_name <+> - text "for consistency" -merge_msg mod_name reqs = - hang (text "while merging the signatures from" <> colon) - 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ - bullet <+> text "...and the local signature for" <+> ppr mod_name) - --- | Given a local 'ModIface', merge all inherited requirements --- from 'requirementMerges' into this signature, producing --- a final 'TcGblEnv' that matches the local signature and --- all required signatures. -mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv -mergeSignatures - (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), - hpm_src_files = src_files }) - orig_tcg_env lcl_iface0 = setSrcSpan loc $ do - -- The lcl_iface0 is the ModIface for the local hsig - -- file, which is guaranteed to exist, see - -- Note [Blank hsigs for all requirements] - hsc_env <- getTopEnv - dflags <- getDynFlags - - -- Copy over some things from the original TcGblEnv that - -- we want to preserve - updGblEnv (\env -> env { - -- Renamed imports/declarations are often used - -- by programs that use the GHC API, e.g., Haddock. - -- These won't get filled by the merging process (since - -- we don't actually rename the parsed module again) so - -- we need to take them directly from the previous - -- typechecking. - -- - -- NB: the export declarations aren't in their final - -- form yet. We'll fill those in when we reprocess - -- the export declarations. - tcg_rn_imports = tcg_rn_imports orig_tcg_env, - tcg_rn_decls = tcg_rn_decls orig_tcg_env, - -- Annotations - tcg_ann_env = tcg_ann_env orig_tcg_env, - -- Documentation header - tcg_doc_hdr = tcg_doc_hdr orig_tcg_env - -- tcg_dus? - -- tcg_th_used = tcg_th_used orig_tcg_env, - -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env - -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env - }) $ do - tcg_env <- getGblEnv - - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - mod_name = moduleName (tcg_mod tcg_env) - - -- STEP 1: Figure out all of the external signature interfaces - -- we are going to merge in. - let reqs = requirementMerges dflags mod_name - - addErrCtxt (merge_msg mod_name reqs) $ do - - -- STEP 2: Read in the RAW forms of all of these interfaces - ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) -> - let m = mkModule (IndefiniteUnitId iuid) mod_name - im = fst (splitModuleInsts m) - in fmap fst - . withException - $ findAndReadIface (text "mergeSignatures") im m False - - -- STEP 3: Get the unrenamed exports of all these interfaces, - -- thin it according to the export list, and do shaping on them. - let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as - -- This function gets run on every inherited interface, and - -- it's responsible for: - -- - -- 1. Merging the exports of the interface into @nsubst@, - -- 2. Adding these exports to the "OK to import" set (@oks@) - -- if they came from a package with no exposed modules - -- (this means we won't report a PVP error in this case), and - -- 3. Thinning the interface according to an explicit export - -- list. - -- - gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do - let insts = indefUnitIdInsts iuid - isFromSignaturePackage = - let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid)) - pkg = getInstalledPackageDetails dflags inst_uid - in null (exposedModules pkg) - -- 3(a). Rename the exports according to how the dependency - -- was instantiated. The resulting export list will be accurate - -- except for exports *from the signature itself* (which may - -- be subsequently updated by exports from other signatures in - -- the merge. - as1 <- tcRnModExports insts ireq_iface - -- 3(b). Thin the interface if it comes from a signature package. - (thinned_iface, as2) <- case mb_exports of - Just (L loc _) - -- Check if the package containing this signature is - -- a signature package (i.e., does not expose any - -- modules.) If so, we can thin it. - | isFromSignaturePackage - -> setSrcSpan loc $ do - -- Suppress missing errors; they might be used to refer - -- to entities from other signatures we are merging in. - -- If an identifier truly doesn't exist in any of the - -- signatures that are merged in, we will discover this - -- when we run exports_from_avail on the final merged - -- export list. - (mb_r, msgs) <- tryTc $ do - -- Suppose that we have written in a signature: - -- signature A ( module A ) where {- empty -} - -- If I am also inheriting a signature from a - -- signature package, does 'module A' scope over - -- all of its exports? - -- - -- There are two possible interpretations: - -- - -- 1. For non self-reexports, a module reexport - -- is interpreted only in terms of the local - -- signature module, and not any of the inherited - -- ones. The reason for this is because after - -- typechecking, module exports are completely - -- erased from the interface of a file, so we - -- have no way of "interpreting" a module reexport. - -- Thus, it's only useful for the local signature - -- module (where we have a useful GlobalRdrEnv.) - -- - -- 2. On the other hand, a common idiom when - -- you want to "export everything, plus a reexport" - -- in modules is to say module A ( module A, reex ). - -- This applies to signature modules too; and in - -- particular, you probably still want the entities - -- from the inherited signatures to be preserved - -- too. - -- - -- We think it's worth making a special case for - -- self reexports to make use case (2) work. To - -- do this, we take the exports of the inherited - -- signature @as1@, and bundle them into a - -- GlobalRdrEnv where we treat them as having come - -- from the import @import A@. Thus, we will - -- pick them up if they are referenced explicitly - -- (@foo@) or even if we do a module reexport - -- (@module A@). - let ispec = ImpSpec ImpDeclSpec{ - -- NB: This needs to be mod name - -- of the local signature, not - -- the (original) module name of - -- the inherited signature, - -- because we need module - -- LocalSig (from the local - -- export list) to match it! - is_mod = mod_name, - is_as = mod_name, - is_qual = False, - is_dloc = loc - } ImpAll - rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) - setGblEnv tcg_env { - tcg_rdr_env = rdr_env - } $ exports_from_avail mb_exports rdr_env - -- NB: tcg_imports is also empty! - emptyImportAvails - (tcg_semantic_mod tcg_env) - case mb_r of - Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) - Nothing -> addMessages msgs >> failM - -- We can't think signatures from non signature packages - _ -> return (ireq_iface, as1) - -- 3(c). Only identifiers from signature packages are "ok" to - -- import (that is, they are safe from a PVP perspective.) - -- (NB: This code is actually dead right now.) - let oks' | isFromSignaturePackage - = extendOccSetList oks (exportOccs as2) - | otherwise - = oks - -- 3(d). Extend the name substitution (performing shaping) - mb_r <- extend_ns nsubst as2 - case mb_r of - Left err -> failWithTc err - Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) - nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) - ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) - -- Process each interface, getting the thinned interfaces as well as - -- the final, full set of exports @nsubst@ and the exports which are - -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.) - (nsubst, ok_to_use, rev_thinned_ifaces) - <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) - let thinned_ifaces = reverse rev_thinned_ifaces - exports = nameShapeExports nsubst - rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports) - _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) - warns = NoWarnings - {- - -- TODO: Warnings are transitive, but this is not what we want here: - -- if a module reexports an entity from a signature, that should be OK. - -- Not supported in current warning framework - warns | null warn_occs = NoWarnings - | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs - -} - setGblEnv tcg_env { - -- The top-level GlobalRdrEnv is quite interesting. It consists - -- of two components: - -- 1. First, we reuse the GlobalRdrEnv of the local signature. - -- This is very useful, because it means that if we have - -- to print a message involving some entity that the local - -- signature imported, we'll qualify it accordingly. - -- 2. Second, we need to add all of the declarations we are - -- going to merge in (as they need to be in scope for the - -- final test of the export list.) - tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env, - -- Inherit imports from the local signature, so that module - -- rexports are picked up correctly - tcg_imports = tcg_imports orig_tcg_env, - tcg_exports = exports, - tcg_dus = usesOnly (availsToNameSetWithSelectors exports), - tcg_warns = warns - } $ do - tcg_env <- getGblEnv - - -- Make sure we didn't refer to anything that doesn't actually exist - -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return () - (mb_lies, _) <- exports_from_avail mb_exports rdr_env - (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) - - {- -- NB: This is commented out, because warns above is disabled. - -- If you tried to explicitly export an identifier that has a warning - -- attached to it, that's probably a mistake. Warn about it. - case mb_lies of - Nothing -> return () - Just lies -> - forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) -> - setSrcSpan loc $ - unless (nameOccName n `elemOccSet` ok_to_use) $ - addWarn NoReason $ vcat [ - text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.", - parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.") - ] - -} - - failIfErrsM - - -- Save the exports - setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do - tcg_env <- getGblEnv - - -- STEP 4: Rename the interfaces - ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) -> - tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface - lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 - let ifaces = lcl_iface : ext_ifaces - - -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- concatMap mi_fixities ifaces - , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] - - -- STEP 5: Typecheck the interfaces - let type_env_var = tcg_type_env_var tcg_env - - -- typecheckIfacesForMerging does two things: - -- 1. It merges the all of the ifaces together, and typechecks the - -- result to type_env. - -- 2. It typechecks each iface individually, but with their 'Name's - -- resolving to the merged type_env from (1). - -- See typecheckIfacesForMerging for more details. - (type_env, detailss) <- initIfaceTcRn $ - typecheckIfacesForMerging inner_mod ifaces type_env_var - let infos = zip ifaces detailss - - -- Test for cycles - checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) [] - - -- NB on type_env: it contains NO dfuns. DFuns are recorded inside - -- detailss, and given a Name that doesn't correspond to anything real. See - -- also Note [Signature merging DFuns] - - -- Add the merged type_env to TcGblEnv, so that it gets serialized - -- out when we finally write out the interface. - -- - -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly, - -- rather than use tcExtendGlobalEnv (the normal method to add newly - -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these - -- TyThings to 'tcg_type_env_var', which is consulted when - -- we read in interfaces to tie the knot. But *these TyThings themselves - -- come from interface*, so that would result in deadlock. Don't - -- update it! - setGblEnv tcg_env { - tcg_tcs = typeEnvTyCons type_env, - tcg_patsyns = typeEnvPatSyns type_env, - tcg_type_env = type_env, - tcg_fix_env = fix_env - } $ do - tcg_env <- getGblEnv - - -- STEP 6: Check for compatibility/merge things - tcg_env <- (\x -> foldM x tcg_env infos) - $ \tcg_env (iface, details) -> do - - let check_export name - | Just sig_thing <- lookupTypeEnv (md_types details) name - = case lookupTypeEnv type_env (getName sig_thing) of - Just thing -> checkHsigDeclM iface sig_thing thing - Nothing -> panic "mergeSignatures: check_export" - -- Oops! We're looking for this export but it's - -- not actually in the type environment of the signature's - -- ModDetails. - -- - -- NB: This case happens because the we're iterating - -- over the union of all exports, so some interfaces - -- won't have everything. Note that md_exports is nonsense - -- (it's the same as exports); maybe we should fix this - -- eventually. - | otherwise - = return () - mapM_ check_export (map availName exports) - - -- Note [Signature merging instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Merge instances into the global environment. The algorithm here is - -- dumb and simple: if an instance has exactly the same DFun type - -- (tested by 'memberInstEnv') as an existing instance, we drop it; - -- otherwise, we add it even, even if this would cause overlap. - -- - -- Why don't we deduplicate instances with identical heads? There's no - -- good choice if they have premises: - -- - -- instance K1 a => K (T a) - -- instance K2 a => K (T a) - -- - -- Why not eagerly error in this case? The overlapping head does not - -- necessarily mean that the instances are unimplementable: in fact, - -- they may be implemented without overlap (if, for example, the - -- implementing module has 'instance K (T a)'; both are implemented in - -- this case.) The implements test just checks that the wanteds are - -- derivable assuming the givens. - -- - -- Still, overlapping instances with hypotheses like above are going - -- to be a bad deal, because instance resolution when we're typechecking - -- against the merged signature is going to have a bad time when - -- there are overlapping heads like this: we never backtrack, so it - -- may be difficult to see that a wanted is derivable. For now, - -- we hope that we get lucky / the overlapping instances never - -- get used, but it is not a very good situation to be in. - -- - let merge_inst (insts, inst_env) inst - | memberInstEnv inst_env inst -- test DFun Type equality - = (insts, inst_env) - | otherwise - -- NB: is_dfun_name inst is still nonsense here, - -- see Note [Signature merging DFuns] - = (inst:insts, extendInstEnv inst_env inst) - (insts, inst_env) = foldl' merge_inst - (tcg_insts tcg_env, tcg_inst_env tcg_env) - (md_insts details) - -- This is a HACK to prevent calculateAvails from including imp_mod - -- in the listing. We don't want it because a module is NOT - -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 - iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } - avails = plusImportAvails (tcg_imports tcg_env) $ - calculateAvails dflags iface' False False ImportedBySystem - return tcg_env { - tcg_inst_env = inst_env, - tcg_insts = insts, - tcg_imports = avails, - tcg_merged = - if outer_mod == mi_module iface - -- Don't add ourselves! - then tcg_merged tcg_env - else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env - } - - -- Note [Signature merging DFuns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Once we know all of instances which will be defined by this merged - -- signature, we go through each of the DFuns and rename them with a fresh, - -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing - -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'. - -- - -- We can't do this fixup earlier, because we need a way to identify each - -- source DFun (from each of the signatures we are merging in) so that - -- when we have a ClsInst, we can pull up the correct DFun to check if - -- the types match. - -- - -- See also Note [rnIfaceNeverExported] in RnModIface - dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do - n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) - let dfun = setVarName (is_dfun inst) n - return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) - tcg_env <- return tcg_env { - tcg_insts = map snd dfun_insts, - tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) - } - - addDependentFiles src_files - - return tcg_env - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnInstantiateSignature :: - HscEnv -> Module -> RealSrcSpan -> - IO (Messages, Maybe TcGblEnv) -tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming dflags - (text "Signature instantiation"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature - where - dflags = hsc_dflags hsc_env - -exportOccs :: [AvailInfo] -> [OccName] -exportOccs = concatMap (map occName . availNames) - -impl_msg :: Module -> IndefModule -> SDoc -impl_msg impl_mod (IndefModule req_uid req_mod_name) = - text "while checking that" <+> ppr impl_mod <+> - text "implements signature" <+> ppr req_mod_name <+> - text "in" <+> ppr req_uid - --- | Check if module implements a signature. (The signature is --- always un-hashed, which is why its components are specified --- explicitly.) -checkImplements :: Module -> IndefModule -> TcRn TcGblEnv -checkImplements impl_mod req_mod@(IndefModule uid mod_name) = - addErrCtxt (impl_msg impl_mod req_mod) $ do - let insts = indefUnitIdInsts uid - - -- STEP 1: Load the implementing interface, and make a RdrEnv - -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', - -- so that we treat all orphan instances it provides as visible - -- when we verify that all instances are checked (see #12945), and so that - -- when we eventually write out the interface we record appropriate - -- dependency information. - impl_iface <- initIfaceTcRn $ - loadSysInterface (text "checkImplements 1") impl_mod - let impl_gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports impl_iface)) - nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) - - -- Load all the orphans, so the subsequent 'checkHsigIface' sees - -- all the instances it needs to - loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") - (dep_orphs (mi_deps impl_iface)) - - dflags <- getDynFlags - let avails = calculateAvails dflags - impl_iface False{- safe -} False{- boot -} ImportedBySystem - fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- mi_fixities impl_iface - , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] - updGblEnv (\tcg_env -> tcg_env { - -- Setting tcg_rdr_env to treat all exported entities from - -- the implementing module as in scope improves error messages, - -- as it reduces the amount of qualification we need. Unfortunately, - -- we still end up qualifying references to external modules - -- (see bkpfail07 for an example); we'd need to record more - -- information in ModIface to solve this. - tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr, - tcg_imports = tcg_imports tcg_env `plusImportAvails` avails, - -- This is here so that when we call 'lookupFixityRn' for something - -- directly implemented by the module, we grab the right thing - tcg_fix_env = fix_env - }) $ do - - -- STEP 2: Load the *unrenamed, uninstantiated* interface for - -- the ORIGINAL signature. We are going to eventually rename it, - -- but we must proceed slowly, because it is NOT known if the - -- instantiation is correct. - let sig_mod = mkModule (IndefiniteUnitId uid) mod_name - isig_mod = fst (splitModuleInsts sig_mod) - mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False - isig_iface <- case mb_isig_iface of - Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ - hang (text "Could not find hi interface for signature" <+> - quotes (ppr isig_mod) <> colon) 4 err - - -- STEP 3: Check that the implementing interface exports everything - -- we need. (Notice we IGNORE the Modules in the AvailInfos.) - forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> - case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ quotes (ppr occ) - <+> text "is exported by the hsig file, but not" - <+> text "exported by the implementing module" - <+> quotes (ppr impl_mod) - _ -> return () - failIfErrsM - - -- STEP 4: Now that the export is complete, rename the interface... - sig_iface <- tcRnModIface insts (Just nsubst) isig_iface - - -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst - -- lets us determine how top-level identifiers should be handled.) - sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface - - -- STEP 6: Check that it's sufficient - tcg_env <- getGblEnv - checkHsigIface tcg_env impl_gr sig_iface sig_details - - -- STEP 7: Return the updated 'TcGblEnv' with the signature exports, - -- so we write them out. - return tcg_env { - tcg_exports = mi_exports sig_iface - } - --- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite --- library to use the actual implementations of the relevant entities, --- checking that the implementation matches the signature. -instantiateSignature :: TcRn TcGblEnv -instantiateSignature = do - tcg_env <- getGblEnv - dflags <- getDynFlags - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - -- TODO: setup the local RdrEnv so the error messages look a little better. - -- But this information isn't stored anywhere. Should we RETYPECHECK - -- the local one just to get the information? Hmm... - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - inner_mod `checkImplements` - IndefModule - (newIndefUnitId (thisComponentId dflags) - (thisUnitIdInsts dflags)) - (moduleName outer_mod) diff --git a/typecheck/TcBinds.hs b/typecheck/TcBinds.hs deleted file mode 100644 --- a/typecheck/TcBinds.hs +++ /dev/null @@ -1,1735 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcBinds]{TcBinds} --} - -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds, - tcHsBootSigs, tcPolyCheck, - chooseInferredQuantifiers, - badBootDeclErr ) where - -import GhcPrelude - -import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) -import CoreSyn (Tickish (..)) -import CostCentre (mkUserCC, CCFlavour(DeclCC)) -import DynFlags -import FastString -import GHC.Hs -import TcSigs -import TcRnMonad -import TcOrigin -import TcEnv -import TcUnify -import TcSimplify -import TcEvidence -import TcHsType -import TcPat -import TcMType -import FamInstEnv( normaliseType ) -import FamInst( tcGetFamInstEnvs ) -import TyCon -import TcType -import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) -import TysPrim -import TysWiredIn( mkBoxedTupleTy ) -import Id -import Var -import VarSet -import VarEnv( TidyEnv ) -import Module -import Name -import NameSet -import NameEnv -import SrcLoc -import Bag -import ErrUtils -import Digraph -import Maybes -import Util -import BasicTypes -import Outputable -import PrelNames( ipClassName ) -import TcValidity (checkValidType) -import UniqFM -import UniqSet -import qualified GHC.LanguageExtensions as LangExt -import ConLike - -import Control.Monad -import Data.Foldable (find) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{Type-checking bindings} -* * -************************************************************************ - -@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because -it needs to know something about the {\em usage} of the things bound, -so that it can create specialisations of them. So @tcBindsAndThen@ -takes a function which, given an extended environment, E, typechecks -the scope of the bindings returning a typechecked thing and (most -important) an LIE. It is this LIE which is then used as the basis for -specialising the things bound. - -@tcBindsAndThen@ also takes a "combiner" which glues together the -bindings and the "thing" to make a new "thing". - -The real work is done by @tcBindWithSigsAndThen@. - -Recursive and non-recursive binds are handled in essentially the same -way: because of uniques there are no scoping issues left. The only -difference is that non-recursive bindings can bind primitive values. - -Even for non-recursive binding groups we add typings for each binder -to the LVE for the following reason. When each individual binding is -checked the type of its LHS is unified with that of its RHS; and -type-checking the LHS of course requires that the binder is in scope. - -At the top-level the LIE is sure to contain nothing but constant -dictionaries, which we resolve at the module level. - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. - -NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), -which would make the space leak go away in this case - -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - -Then we get - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm --} - -tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] - -> TcM (TcGblEnv, TcLclEnv) --- The TcGblEnv contains the new tcg_binds and tcg_spects --- The TcLclEnv has an extended type envt for the new bindings -tcTopBinds binds sigs - = do { -- Pattern synonym bindings populate the global environment - (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ - do { gbl <- getGblEnv - ; lcl <- getLclEnv - ; return (gbl, lcl) } - ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids - - ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs - ; traceTc "complete_matches" (ppr binds $$ ppr sigs) - ; traceTc "complete_matches" (ppr complete_matches) - - ; let { tcg_env' = tcg_env { tcg_imp_specs - = specs ++ tcg_imp_specs tcg_env - , tcg_complete_matches - = complete_matches - ++ tcg_complete_matches tcg_env } - `addTypecheckedBinds` map snd binds' } - - ; return (tcg_env', tcl_env) } - -- The top level bindings are flattened into a giant - -- implicitly-mutually-recursive LHsBinds - - --- Note [Typechecking Complete Matches] --- Much like when a user bundled a pattern synonym, the result types of --- all the constructors in the match pragma must be consistent. --- --- If we allowed pragmas with inconsistent types then it would be --- impossible to ever match every constructor in the list and so --- the pragma would be useless. - - - - - --- This is only used in `tcCompleteSig`. We fold over all the conlikes, --- this accumulator keeps track of the first `ConLike` with a concrete --- return type. After fixing the return type, all other constructors with --- a fixed return type must agree with this. --- --- The fields of `Fixed` cache the first conlike and its return type so --- that that we can compare all the other conlikes to it. The conlike is --- stored for error messages. --- --- `Nothing` in the case that the type is fixed by a type signature -data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon - -tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] -tcCompleteSigs sigs = - let - doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) - doOne c@(CompleteMatchSig _ _ lns mtc) - = fmap Just $ do - addErrCtxt (text "In" <+> ppr c) $ - case mtc of - Nothing -> infer_complete_match - Just tc -> check_complete_match tc - where - - checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) - - infer_complete_match = do - (res, cls) <- checkCLTypes AcceptAny - case res of - AcceptAny -> failWithTc ambiguousError - Fixed _ tc -> return $ mkMatch cls tc - - check_complete_match tc_name = do - ty_con <- tcLookupLocatedTyCon tc_name - (_, cls) <- checkCLTypes (Fixed Nothing ty_con) - return $ mkMatch cls ty_con - - mkMatch :: [ConLike] -> TyCon -> CompleteMatch - mkMatch cls ty_con = CompleteMatch { - -- foldM is a left-fold and will have accumulated the ConLikes in - -- the reverse order. foldrM would accumulate in the correct order, - -- but would type-check the last ConLike first, which might also be - -- confusing from the user's perspective. Hence reverse here. - completeMatchConLikes = reverse (map conLikeName cls), - completeMatchTyCon = tyConName ty_con - } - doOne _ = return Nothing - - ambiguousError :: SDoc - ambiguousError = - text "A type signature must be provided for a set of polymorphic" - <+> text "pattern synonyms." - - - -- See note [Typechecking Complete Matches] - checkCLType :: (CompleteSigType, [ConLike]) -> Located Name - -> TcM (CompleteSigType, [ConLike]) - checkCLType (cst, cs) n = do - cl <- addLocM tcLookupConLike n - let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl - res_ty_con = fst <$> splitTyConApp_maybe res_ty - case (cst, res_ty_con) of - (AcceptAny, Nothing) -> return (AcceptAny, cl:cs) - (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs) - (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs) - (Fixed mfcl tc, Just tc') -> - if tc == tc' - then return (Fixed mfcl tc, cl:cs) - else case mfcl of - Nothing -> - addErrCtxt (text "In" <+> ppr cl) $ - failWithTc typeSigErrMsg - Just cl -> failWithTc (errMsg cl) - where - typeSigErrMsg :: SDoc - typeSigErrMsg = - text "Couldn't match expected type" - <+> quotes (ppr tc) - <+> text "with" - <+> quotes (ppr tc') - - errMsg :: ConLike -> SDoc - errMsg fcl = - text "Cannot form a group of complete patterns from patterns" - <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl) - <+> text "as they match different type constructors" - <+> parens (quotes (ppr tc) - <+> text "resp." - <+> quotes (ppr tc')) - -- For some reason I haven't investigated further, the signatures come in - -- backwards wrt. declaration order. So we reverse them here, because it makes - -- a difference for incomplete match suggestions. - in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order - -tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] --- A hs-boot file has only one BindGroup, and it only has type --- signatures in it. The renamer checked all this -tcHsBootSigs binds sigs - = do { checkTc (null binds) badBootDeclErr - ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } - where - tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames - where - f (dL->L _ name) - = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty - ; return (mkVanillaGlobal name sigma_ty) } - -- Notice that we make GlobalIds, not LocalIds - tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) - -badBootDeclErr :: MsgDoc -badBootDeclErr = text "Illegal declarations in an hs-boot file" - ------------------------- -tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing - -> TcM (HsLocalBinds GhcTcId, thing) - -tcLocalBinds (EmptyLocalBinds x) thing_inside - = do { thing <- thing_inside - ; return (EmptyLocalBinds x, thing) } - -tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside - = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } -tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" - -tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside - = do { ipClass <- tcLookupClass ipClassName - ; (given_ips, ip_binds') <- - mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds - - -- If the binding binds ?x = E, we must now - -- discharge any ?x constraints in expr_lie - -- See Note [Implicit parameter untouchables] - ; (ev_binds, result) <- checkConstraints (IPSkol ips) - [] given_ips thing_inside - - ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } - where - ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds] - - -- I wonder if we should do these one at at time - -- Consider ?x = 4 - -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr) - = do { ty <- newOpenFlexiTyVarTy - ; let p = mkStrLitTy $ hsIPNameFS ip - ; ip_id <- newDict ipClass [ p, ty ] - ; expr' <- tcMonoExpr expr (mkCheckExpType ty) - ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } - tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" - tc_ip_bind _ (XIPBind nec) = noExtCon nec - - -- Coerces a `t` into a dictionry for `IP "x" t`. - -- co : t -> IP "x" t - toDict ipClass x ty = mkHsWrap $ mkWpCastR $ - wrapIP $ mkClassPred ipClass [x,ty] - -tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec -tcLocalBinds (XHsLocalBindsLR nec) _ = noExtCon nec - -{- Note [Implicit parameter untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We add the type variables in the types of the implicit parameters -as untouchables, not so much because we really must not unify them, -but rather because we otherwise end up with constraints like this - Num alpha, Implic { wanted = alpha ~ Int } -The constraint solver solves alpha~Int by unification, but then -doesn't float that solved constraint out (it's not an unsolved -wanted). Result disaster: the (Num alpha) is again solved, this -time by defaulting. No no no. - -However [Oct 10] this is all handled automatically by the -untouchable-range idea. --} - -tcValBinds :: TopLevelFlag - -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] - -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) - -tcValBinds top_lvl binds sigs thing_inside - = do { -- Typecheck the signatures - -- It's easier to do so now, once for all the SCCs together - -- because a single signature f,g :: - -- might relate to more than one SCC - ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $ - tcTySigs sigs - - -- Extend the envt right away with all the Ids - -- declared with complete type signatures - -- Do not extend the TcBinderStack; instead - -- we extend it on a per-rhs basis in tcExtendForRhs - ; tcExtendSigIds top_lvl poly_ids $ do - { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do - { thing <- thing_inside - -- See Note [Pattern synonym builders don't yield dependencies] - -- in RnBinds - ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns - ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] - ; return (extra_binds, thing) } - ; return (binds' ++ extra_binds', thing) }} - where - patsyns = getPatSynBinds binds - prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) - ------------------------- -tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv - -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) --- Typecheck a whole lot of value bindings, --- one strongly-connected component at a time --- Here a "strongly connected component" has the strightforward --- meaning of a group of bindings that mention each other, --- ignoring type signatures (that part comes later) - -tcBindGroups _ _ _ [] thing_inside - = do { thing <- thing_inside - ; return ([], thing) } - -tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside - = do { -- See Note [Closed binder groups] - type_env <- getLclTypeEnv - ; let closed = isClosedBndrGroup type_env (snd group) - ; (group', (groups', thing)) - <- tc_group top_lvl sig_fn prag_fn group closed $ - tcBindGroups top_lvl sig_fn prag_fn groups thing_inside - ; return (group' ++ groups', thing) } - --- Note [Closed binder groups] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- A mutually recursive group is "closed" if all of the free variables of --- the bindings are closed. For example --- --- > h = \x -> let f = ...g... --- > g = ....f...x... --- > in ... --- --- Here @g@ is not closed because it mentions @x@; and hence neither is @f@ --- closed. --- --- So we need to compute closed-ness on each strongly connected components, --- before we sub-divide it based on what type signatures it has. --- - ------------------------- -tc_group :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) - --- Typecheck one strongly-connected component of the original program. --- We get a list of groups back, because there may --- be specialisations etc as well - -tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside - -- A single non-recursive binding - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - = do { let bind = case bagToList binds of - [bind] -> bind - [] -> panic "tc_group: empty list of binds" - _ -> panic "tc_group: NonRecursive binds is not a singleton bag" - ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed - thing_inside - ; return ( [(NonRecursive, bind')], thing) } - -tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside - = -- To maximise polymorphism, we do a new - -- strongly-connected-component analysis, this time omitting - -- any references to variables with type signatures. - -- (This used to be optional, but isn't now.) - -- See Note [Polymorphic recursion] in HsBinds. - do { traceTc "tc_group rec" (pprLHsBinds binds) - ; whenIsJust mbFirstPatSyn $ \lpat_syn -> - recursivePatSynErr (getLoc lpat_syn) binds - ; (binds1, thing) <- go sccs - ; return ([(Recursive, binds1)], thing) } - -- Rec them all together - where - mbFirstPatSyn = find (isPatSyn . unLoc) binds - isPatSyn PatSynBind{} = True - isPatSyn _ = False - - sccs :: [SCC (LHsBind GhcRn)] - sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) - - go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing) - go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc - ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn - closed ids1 $ - go sccs - ; return (binds1 `unionBags` binds2, thing) } - go [] = do { thing <- thing_inside; return (emptyBag, thing) } - - tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] - tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds - - tc_sub_group rec_tc binds = - tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds - -recursivePatSynErr :: - OutputableBndrId p => - SrcSpan -- ^ The location of the first pattern synonym binding - -- (for error reporting) - -> LHsBinds (GhcPass p) - -> TcM a -recursivePatSynErr loc binds - = failAt loc $ - hang (text "Recursive pattern synonym definition with following bindings:") - 2 (vcat $ map pprLBind . bagToList $ binds) - where - pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) - <+> pprLoc loc - -tc_single :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> LHsBind GhcRn -> IsGroupClosed -> TcM thing - -> TcM (LHsBinds GhcTcId, thing) -tc_single _top_lvl sig_fn _prag_fn - (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) })) - _ thing_inside - = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) - ; thing <- setGblEnv tcg_env thing_inside - ; return (aux_binds, thing) - } - -tc_single top_lvl sig_fn prag_fn lbind closed thing_inside - = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn - NonRecursive NonRecursive - closed - [lbind] - ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside - ; return (binds1, thing) } - ------------------------- -type BKey = Int -- Just number off the bindings - -mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] --- See Note [Polymorphic recursion] in HsBinds. -mkEdges sig_fn binds - = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), - Just key <- [lookupNameEnv key_map n], no_sig n ] - | (bind, key) <- keyd_binds - ] - -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices - -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. - where - bind_fvs (FunBind { fun_ext = fvs }) = fvs - bind_fvs (PatBind { pat_ext = fvs }) = fvs - bind_fvs _ = emptyNameSet - - no_sig :: Name -> Bool - no_sig n = not (hasCompleteSig sig_fn n) - - keyd_binds = bagToList binds `zip` [0::BKey ..] - - key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds - , bndr <- collectHsBindBinders bind ] - ------------------------- -tcPolyBinds :: TcSigFun -> TcPragEnv - -> RecFlag -- Whether the group is really recursive - -> RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> IsGroupClosed -- Whether the group is closed - -> [LHsBind GhcRn] -- None are PatSynBind - -> TcM (LHsBinds GhcTcId, [TcId]) - --- Typechecks a single bunch of values bindings all together, --- and generalises them. The bunch may be only part of a recursive --- group, because we use type signatures to maximise polymorphism --- --- Returns a list because the input may be a single non-recursive binding, --- in which case the dependency order of the resulting bindings is --- important. --- --- Knows nothing about the scope of the bindings --- None of the bindings are pattern synonyms - -tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list - = setSrcSpan loc $ - recoverM (recoveryCode binder_names sig_fn) $ do - -- Set up main recover; take advantage of any type sigs - - { traceTc "------------------------------------------------" Outputable.empty - ; traceTc "Bindings for {" (ppr binder_names) - ; dflags <- getDynFlags - ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn - ; traceTc "Generalisation plan" (ppr plan) - ; result@(_, poly_ids) <- case plan of - NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list - CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind - - ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group - , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] - ]) - - ; return result } - where - binder_names = collectHsBindListBinders bind_list - loc = foldr1 combineSrcSpans (map getLoc bind_list) - -- The mbinds have been dependency analysed and - -- may no longer be adjacent; so find the narrowest - -- span that includes them all - --------------- --- If typechecking the binds fails, then return with each --- signature-less binder given type (forall a.a), to minimise --- subsequent error messages -recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id]) -recoveryCode binder_names sig_fn - = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) - ; let poly_ids = map mk_dummy binder_names - ; return (emptyBag, poly_ids) } - where - mk_dummy name - | Just sig <- sig_fn name - , Just poly_id <- completeSigPolyId_maybe sig - = poly_id - | otherwise - = mkLocalId name forall_a_a - -forall_a_a :: TcType --- At one point I had (forall r (a :: TYPE r). a), but of course --- that type is ill-formed: its mentions 'r' which escapes r's scope. --- Another alternative would be (forall (a :: TYPE kappa). a), where --- kappa is a unification variable. But I don't think we need that --- complication here. I'm going to just use (forall (a::*). a). --- See #15276 -forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy - -{- ********************************************************************* -* * - tcPolyNoGen -* * -********************************************************************* -} - -tcPolyNoGen -- No generalisation whatsoever - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [TcId]) - -tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list - = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn - (LetGblBndr prag_fn) - bind_list - ; mono_ids' <- mapM tc_mono_info mono_infos - ; return (binds', mono_ids') } - where - tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) - = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) - ; return mono_id } - -- NB: tcPrags generates error messages for - -- specialisation pragmas for non-overloaded sigs - -- Indeed that is why we call it here! - -- So we can safely ignore _specs - - -{- ********************************************************************* -* * - tcPolyCheck -* * -********************************************************************* -} - -tcPolyCheck :: TcPragEnv - -> TcIdSigInfo -- Must be a complete signature - -> LHsBind GhcRn -- Must be a FunBind - -> TcM (LHsBinds GhcTcId, [TcId]) --- There is just one binding, --- it is a Funbind --- it has a complete type signature, -tcPolyCheck prag_fn - (CompleteSig { sig_bndr = poly_id - , sig_ctxt = ctxt - , sig_loc = sig_loc }) - (dL->L loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches })) - = setSrcSpan sig_loc $ - do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) - ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - -- See Note [Instantiate sig with fresh variables] - - ; mono_name <- newNameAt (nameOccName name) nm_loc - ; ev_vars <- newEvVars theta - ; let mono_id = mkLocalId mono_name tau - skol_info = SigSkol ctxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - - ; (ev_binds, (co_fn, matches')) - <- checkConstraints skol_info skol_tvs ev_vars $ - tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ - tcExtendNameTyVarEnv tv_prs $ - setSrcSpan loc $ - tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau) - - ; let prag_sigs = lookupPragEnv prag_fn name - ; spec_prags <- tcSpecPrags poly_id prag_sigs - ; poly_id <- addInlinePrags poly_id prag_sigs - - ; mod <- getModule - ; tick <- funBindTicks nm_loc mono_id mod prag_sigs - ; let bind' = FunBind { fun_id = cL nm_loc mono_id - , fun_matches = matches' - , fun_co_fn = co_fn - , fun_ext = placeHolderNamesTc - , fun_tick = tick } - - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags } - - abs_bind = cL loc $ - AbsBinds { abs_ext = noExtField - , abs_tvs = skol_tvs - , abs_ev_vars = ev_vars - , abs_ev_binds = [ev_binds] - , abs_exports = [export] - , abs_binds = unitBag (cL loc bind') - , abs_sig = True } - - ; return (unitBag abs_bind, [poly_id]) } - -tcPolyCheck _prag_fn sig bind - = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) - -funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] - -> TcM [Tickish TcId] -funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ] - -- this can only be a singleton list, as duplicate pragmas are rejected - -- by the renamer - , let cc_str - | Just cc_str <- mb_cc_str - = sl_fs $ unLoc cc_str - | otherwise - = getOccFS (Var.varName fun_id) - cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str - = do - flavour <- DeclCC <$> getCCIndexM cc_name - let cc = mkUserCC cc_name mod loc flavour - return [ProfNote cc True True] - | otherwise - = return [] - -{- Note [Instantiate sig with fresh variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's vital to instantiate a type signature with fresh variables. -For example: - type T = forall a. [a] -> [a] - f :: T; - f = g where { g :: T; g = } - - We must not use the same 'a' from the defn of T at both places!! -(Instantiation is only necessary because of type synonyms. Otherwise, -it's all cool; each signature has distinct type variables from the renamer.) --} - - -{- ********************************************************************* -* * - tcPolyInfer -* * -********************************************************************* -} - -tcPolyInfer - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> Bool -- True <=> apply the monomorphism restriction - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [TcId]) -tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list - = do { (tclvl, wanted, (binds', mono_infos)) - <- pushLevelAndCaptureConstraints $ - tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list - - ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) - | info <- mono_infos ] - sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] - infer_mode = if mono then ApplyMR else NoRestrictions - - ; mapM_ (checkOverloadedSig mono) sigs - - ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) - ; (qtvs, givens, ev_binds, residual, insoluble) - <- simplifyInfer tclvl infer_mode sigs name_taus wanted - ; emitConstraints residual - - ; let inferred_theta = map evVarPred givens - ; exports <- checkNoErrs $ - mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos - - ; loc <- getSrcSpanM - ; let poly_ids = map abe_poly exports - abs_bind = cL loc $ - AbsBinds { abs_ext = noExtField - , abs_tvs = qtvs - , abs_ev_vars = givens, abs_ev_binds = [ev_binds] - , abs_exports = exports, abs_binds = binds' - , abs_sig = False } - - ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids) } - -- poly_ids are guaranteed zonked by mkExport - --------------- -mkExport :: TcPragEnv - -> Bool -- True <=> there was an insoluble type error - -- when typechecking the bindings - -> [TyVar] -> TcThetaType -- Both already zonked - -> MonoBindInfo - -> TcM (ABExport GhcTc) --- Only called for generalisation plan InferGen, not by CheckGen or NoGen --- --- mkExport generates exports with --- zonked type variables, --- zonked poly_ids --- The former is just because no further unifications will change --- the quantified type variables, so we can fix their final form --- right now. --- The latter is needed because the poly_ids are used to extend the --- type environment; see the invariant on TcEnv.tcExtendIdEnv - --- Pre-condition: the qtvs and theta are already zonked - -mkExport prag_fn insoluble qtvs theta - mono_info@(MBI { mbi_poly_name = poly_name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id }) - = do { mono_ty <- zonkTcType (idType mono_id) - ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty - - -- NB: poly_id has a zonked type - ; poly_id <- addInlinePrags poly_id prag_sigs - ; spec_prags <- tcSpecPrags poly_id prag_sigs - -- tcPrags requires a zonked poly_id - - -- See Note [Impedance matching] - -- NB: we have already done checkValidType, including an ambiguity check, - -- on the type; either when we checked the sig or in mkInferredPolyId - ; let poly_ty = idType poly_id - sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty - -- This type is just going into tcSubType, - -- so Inferred vs. Specified doesn't matter - - ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguous type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ - tcSubType_NC sig_ctxt sel_poly_ty poly_ty - - ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures - ; when warn_missing_sigs $ - localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig - - ; return (ABE { abe_ext = noExtField - , abe_wrap = wrap - -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags }) } - where - prag_sigs = lookupPragEnv prag_fn poly_name - sig_ctxt = InfSigCtxt poly_name - -mkInferredPolyId :: Bool -- True <=> there was an insoluble error when - -- checking the binding group for this Id - -> [TyVar] -> TcThetaType - -> Name -> Maybe TcIdSigInst -> TcType - -> TcM TcId -mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty - | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst - , CompleteSig { sig_bndr = poly_id } <- sig - = return poly_id - - | otherwise -- Either no type sig or partial type sig - = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous - -- we don't carry on to the impedance matching, and generate - -- a duplicate ambiguity error. There is a similar - -- checkNoErrs for complete type signatures too. - do { fam_envs <- tcGetFamInstEnvs - ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty - -- Unification may not have normalised the type, - -- (see Note [Lazy flattening] in TcFlatten) so do it - -- here to make it as uncomplicated as possible. - -- Example: f :: [F Int] -> Bool - -- should be rewritten to f :: [Char] -> Bool, if possible - -- - -- We can discard the coercion _co, because we'll reconstruct - -- it in the call to tcSubType below - - ; (binders, theta') <- chooseInferredQuantifiers inferred_theta - (tyCoVarsOfType mono_ty') qtvs mb_sig_inst - - ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty') - - ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' - , ppr inferred_poly_ty]) - ; unless insoluble $ - addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ - checkValidType (InfSigCtxt poly_name) inferred_poly_ty - -- See Note [Validity of inferred types] - -- If we found an insoluble error in the function definition, don't - -- do this check; otherwise (#14000) we may report an ambiguity - -- error for a rather bogus type. - - ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) } - - -chooseInferredQuantifiers :: TcThetaType -- inferred - -> TcTyVarSet -- tvs free in tau type - -> [TcTyVar] -- inferred quantified tvs - -> Maybe TcIdSigInst - -> TcM ([TyVarBinder], TcThetaType) -chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing - = -- No type signature (partial or complete) for this binder, - do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) - -- Include kind variables! #7916 - my_theta = pickCapturedPreds free_tvs inferred_theta - binders = [ mkTyVarBinder Inferred tv - | tv <- qtvs - , tv `elemVarSet` free_tvs ] - ; return (binders, my_theta) } - -chooseInferredQuantifiers inferred_theta tau_tvs qtvs - (Just (TISI { sig_inst_sig = sig -- Always PartialSig - , sig_inst_wcx = wcx - , sig_inst_theta = annotated_theta - , sig_inst_skols = annotated_tvs })) - = -- Choose quantifiers for a partial type signature - do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs - - -- Check whether the quantified variables of the - -- partial signature have been unified together - -- See Note [Quantified variables in partial type signatures] - ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs) - - -- Check whether a quantified variable of the partial type - -- signature is not actually quantified. How can that happen? - -- See Note [Quantification and partial signatures] Wrinkle 4 - -- in TcSimplify - ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs - , not (tv `elem` qtvs) ] - - ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs) - - ; annotated_theta <- zonkTcTypes annotated_theta - ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx - - ; let keep_me = free_tvs `unionVarSet` psig_qtvs - final_qtvs = [ mkTyVarBinder vis tv - | tv <- qtvs -- Pulling from qtvs maintains original order - , tv `elemVarSet` keep_me - , let vis | tv `elemVarSet` psig_qtvs = Specified - | otherwise = Inferred ] - - ; return (final_qtvs, my_theta) } - where - report_dup_tyvar_tv_err (n1,n2) - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) - <+> text "with" <+> quotes (ppr n2)) - 2 (hang (text "both bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) - - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_tyvar_tv_err" (ppr sig) - - report_mono_sig_tv_err n - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_mono_sig_tv_err" (ppr sig) - - choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType - -> TcM (VarSet, TcThetaType) - choose_psig_context _ annotated_theta Nothing - = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta - `unionVarSet` tau_tvs) - ; return (free_tvs, annotated_theta) } - - choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) - = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) - -- growThetaVars just like the no-type-sig case - -- Omitting this caused #12844 - seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there - `unionVarSet` tau_tvs -- by the user - - ; let keep_me = psig_qtvs `unionVarSet` free_tvs - my_theta = pickCapturedPreds keep_me inferred_theta - - -- Fill in the extra-constraints wildcard hole with inferred_theta, - -- so that the Hole constraint we have already emitted - -- (in tcHsPartialSigType) can report what filled it in. - -- NB: my_theta already includes all the annotated constraints - ; let inferred_diff = [ pred - | pred <- my_theta - , all (not . (`eqType` pred)) annotated_theta ] - ; ctuple <- mk_ctuple inferred_diff - - ; case tcGetCastedTyVar_maybe wc_var_ty of - -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it - -- comes from the checkExpectedKind in TcHsType.tcAnonWildCardOcc. So, to - -- make the kinds work out, we reverse the cast here. - Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co) - Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) - - ; traceTc "completeTheta" $ - vcat [ ppr sig - , ppr annotated_theta, ppr inferred_theta - , ppr inferred_diff ] - ; return (free_tvs, my_theta) } - - mk_ctuple preds = return (mkBoxedTupleTy preds) - -- Hack alert! See TcHsType: - -- Note [Extra-constraint holes in partial type signatures] - - -mk_impedance_match_msg :: MonoBindInfo - -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, SDoc) --- This is a rare but rather awkward error messages -mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) - inf_ty sig_ty tidy_env - = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty - ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty - ; let msg = vcat [ text "When checking that the inferred type" - , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty - , text "is as general as its" <+> what <+> text "signature" - , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] - ; return (tidy_env2, msg) } - where - what = case mb_sig of - Nothing -> text "inferred" - Just sig | isPartialSig sig -> text "(partial)" - | otherwise -> empty - - -mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) -mk_inf_msg poly_name poly_ty tidy_env - = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty - ; let msg = vcat [ text "When checking the inferred type" - , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] - ; return (tidy_env1, msg) } - - --- | Warn the user about polymorphic local binders that lack type signatures. -localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM () -localSigWarn flag id mb_sig - | Just _ <- mb_sig = return () - | not (isSigmaTy (idType id)) = return () - | otherwise = warnMissingSignatures flag msg id - where - msg = text "Polymorphic local binding with no type signature:" - -warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () -warnMissingSignatures flag msg id - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) } - where - mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] - -checkOverloadedSig :: Bool -> TcIdSigInst -> TcM () --- Example: --- f :: Eq a => a -> a --- K f = e --- The MR applies, but the signature is overloaded, and it's --- best to complain about this directly --- c.f #11339 -checkOverloadedSig monomorphism_restriction_applies sig - | not (null (sig_inst_theta sig)) - , monomorphism_restriction_applies - , let orig_sig = sig_inst_sig sig - = setSrcSpan (sig_loc orig_sig) $ - failWith $ - hang (text "Overloaded signature conflicts with monomorphism restriction") - 2 (ppr orig_sig) - | otherwise - = return () - -{- Note [Partial type signatures and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If /any/ of the signatures in the gropu is a partial type signature - f :: _ -> Int -then we *always* use the InferGen plan, and hence tcPolyInfer. -We do this even for a local binding with -XMonoLocalBinds, when -we normally use NoGen. - -Reasons: - * The TcSigInfo for 'f' has a unification variable for the '_', - whose TcLevel is one level deeper than the current level. - (See pushTcLevelM in tcTySig.) But NoGen doesn't increase - the TcLevel like InferGen, so we lose the level invariant. - - * The signature might be f :: forall a. _ -> a - so it really is polymorphic. It's not clear what it would - mean to use NoGen on this, and indeed the ASSERT in tcLhs, - in the (Just sig) case, checks that if there is a signature - then we are using LetLclBndr, and hence a nested AbsBinds with - increased TcLevel - -It might be possible to fix these difficulties somehow, but there -doesn't seem much point. Indeed, adding a partial type signature is a -way to get per-binding inferred generalisation. - -We apply the MR if /all/ of the partial signatures lack a context. -In particular (#11016): - f2 :: (?loc :: Int) => _ - f2 = ?loc -It's stupid to apply the MR here. This test includes an extra-constraints -wildcard; that is, we don't apply the MR if you write - f3 :: _ => blah - -Note [Quantified variables in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a. a -> a -> _ - f x y = g x y - g :: forall b. b -> b -> _ - g x y = [x, y] - -Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b' -together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then -unify with each other. - -But now consider: - f :: forall a b. a -> b -> _ - f x y = [x, y] - -We want to get an error from this, because 'a' and 'b' get unified. -So we make a test, one per parital signature, to check that the -explicitly-quantified type variables have not been unified together. -#14449 showed this up. - - -Note [Validity of inferred types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to check inferred type for validity, in case it uses language -extensions that are not turned on. The principle is that if the user -simply adds the inferred type to the program source, it'll compile fine. -See #8883. - -Examples that might fail: - - the type might be ambiguous - - - an inferred theta that requires type equalities e.g. (F a ~ G b) - or multi-parameter type classes - - an inferred type that includes unboxed tuples - - -Note [Impedance matching] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f 0 x = x - f n x = g [] (not x) - - g [] y = f 10 y - g _ y = f 9 y - -After typechecking we'll get - f_mono_ty :: a -> Bool -> Bool - g_mono_ty :: [b] -> Bool -> Bool -with constraints - (Eq a, Num a) - -Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. -The types we really want for f and g are - f :: forall a. (Eq a, Num a) => a -> Bool -> Bool - g :: forall b. [b] -> Bool -> Bool - -We can get these by "impedance matching": - tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) - tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) - - f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f - g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g - -Suppose the shared quantified tyvars are qtvs and constraints theta. -Then we want to check that - forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype -and the proof is the impedance matcher. - -Notice that the impedance matcher may do defaulting. See #7173. - -It also cleverly does an ambiguity check; for example, rejecting - f :: F a -> F a -where F is a non-injective type function. --} - - -{- -Note [SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no point in a SPECIALISE pragma for a non-overloaded function: - reverse :: [a] -> [a] - {-# SPECIALISE reverse :: [Int] -> [Int] #-} - -But SPECIALISE INLINE *can* make sense for GADTS: - data Arr e where - ArrInt :: !Int -> ByteArray# -> Arr Int - ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) - - (!:) :: Arr e -> Int -> e - {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} - {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} - (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) - (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) - -When (!:) is specialised it becomes non-recursive, and can usefully -be inlined. Scary! So we only warn for SPECIALISE *without* INLINE -for a non-overloaded function. - -************************************************************************ -* * - tcMonoBinds -* * -************************************************************************ - -@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. -The signatures have been dealt with already. --} - -data MonoBindInfo = MBI { mbi_poly_name :: Name - , mbi_sig :: Maybe TcIdSigInst - , mbi_mono_id :: TcId } - -tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes - -- i.e. the binders are mentioned in their RHSs, and - -- we are not rescued by a type signature - -> TcSigFun -> LetBndrSpec - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) -tcMonoBinds is_rec sig_fn no_gen - [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches - , fun_ext = fvs })] - -- Single function binding, - | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS - , Nothing <- sig_fn name -- ...with no type signature - = -- Note [Single function non-recursive binding special-case] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- In this very special case we infer the type of the - -- right hand side first (it may have a higher-rank type) - -- and *then* make the monomorphic Id for the LHS - -- e.g. f = \(x::forall a. a->a) -> - -- We want to infer a higher-rank type for f - setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) - <- tcInferInst $ \ exp_ty -> - -- tcInferInst: see TcUnify, - -- Note [Deep instantiation of InferResult] in TcUnify - tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ - -- We extend the error context even for a non-recursive - -- function so that in type error messages we show the - -- type of the thing whose rhs we are type checking - tcMatchesFun (cL nm_loc name) matches exp_ty - - ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ cL b_loc $ - FunBind { fun_id = cL nm_loc mono_id, - fun_matches = matches', fun_ext = fvs, - fun_co_fn = co_fn, fun_tick = [] }, - [MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }]) } - -tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds - - -- Bring the monomorphic Ids, into scope for the RHSs - ; let mono_infos = getMonoBindInfo tc_binds - rhs_id_env = [ (name, mono_id) - | MBI { mbi_poly_name = name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id } <- mono_infos - , case mb_sig of - Just sig -> isPartialSig sig - Nothing -> True ] - -- A monomorphic binding for each term variable that lacks - -- a complete type sig. (Ones with a sig are already in scope.) - - ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) - | (n,id) <- rhs_id_env] - ; binds' <- tcExtendRecIds rhs_id_env $ - mapM (wrapLocM tcRhs) tc_binds - - ; return (listToBag binds', mono_infos) } - - ------------------------- --- tcLhs typechecks the LHS of the bindings, to construct the environment in which --- we typecheck the RHSs. Basically what we are doing is this: for each binder: --- if there's a signature for it, use the instantiated signature type --- otherwise invent a type variable --- You see that quite directly in the FunBind case. --- --- But there's a complication for pattern bindings: --- data T = MkT (forall a. a->a) --- MkT f = e --- Here we can guess a type variable for the entire LHS (which will be refined to T) --- but we want to get (f::forall a. a->a) as the RHS environment. --- The simplest way to do this is to typecheck the pattern, and then look up the --- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing --- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't - -data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) - | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn)) - TcSigmaType - -tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind --- Only called with plan InferGen (LetBndrSpec = LetLclBndr) --- or NoGen (LetBndrSpec = LetGblBndr) --- CheckGen is used only for functions with a complete type signature, --- and tcPolyCheck doesn't use tcMonoBinds at all - -tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches }) - | Just (TcIdSig sig) <- sig_fn name - = -- There is a type signature. - -- It must be partial; if complete we'd be in tcPolyCheck! - -- e.g. f :: _ -> _ - -- f x = ...g... - -- Just g = ...f... - -- Hence always typechecked with InferGen - do { mono_info <- tcLhsSigId no_gen (name, sig) - ; return (TcFunBind mono_info nm_loc matches) } - - | otherwise -- No type signature - = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name mono_ty - ; let mono_info = MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id } - ; return (TcFunBind mono_info nm_loc matches) } - -tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) - = -- See Note [Typechecking pattern bindings] - do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names - - ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ - [ (mbi_poly_name mbi, mbi_mono_id mbi) - | mbi <- sig_mbis ] - - -- See Note [Existentials in pattern bindings] - ; ((pat', nosig_mbis), pat_ty) - <- addErrCtxt (patMonoBindsCtxt pat grhss) $ - tcInferNoInst $ \ exp_ty -> - tcLetPat inst_sig_fun no_gen pat exp_ty $ - mapM lookup_info nosig_names - - ; let mbis = sig_mbis ++ nosig_mbis - - ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id) - | mbi <- mbis, let id = mbi_mono_id mbi ] - $$ ppr no_gen) - - ; return (TcPatBind mbis pat' grhss pat_ty) } - where - bndr_names = collectPatBinders pat - (nosig_names, sig_names) = partitionWith find_sig bndr_names - - find_sig :: Name -> Either Name (Name, TcIdSigInfo) - find_sig name = case sig_fn name of - Just (TcIdSig sig) -> Right (name, sig) - _ -> Left name - - -- After typechecking the pattern, look up the binder - -- names that lack a signature, which the pattern has brought - -- into scope. - lookup_info :: Name -> TcM MonoBindInfo - lookup_info name - = do { mono_id <- tcLookupId name - ; return (MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }) } - -tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) - -- AbsBind, VarBind impossible - -------------------- -tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo -tcLhsSigId no_gen (name, sig) - = do { inst_sig <- tcInstSig sig - ; mono_id <- newSigLetBndr no_gen name inst_sig - ; return (MBI { mbi_poly_name = name - , mbi_sig = Just inst_sig - , mbi_mono_id = mono_id }) } - ------------- -newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId -newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) - | CompleteSig { sig_bndr = poly_id } <- id_sig - = addInlinePrags poly_id (lookupPragEnv prags name) -newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) - = newLetBndr no_gen name tau - -------------------- -tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId) -tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) - loc matches) - = tcExtendIdBinderStackForRhs [info] $ - tcExtendTyVarEnvForRhs mb_sig $ - do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id)) - matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = cL loc mono_id - , fun_matches = matches' - , fun_co_fn = co_fn - , fun_ext = placeHolderNamesTc - , fun_tick = [] } ) } - -tcRhs (TcPatBind infos pat' grhss pat_ty) - = -- When we are doing pattern bindings we *don't* bring any scoped - -- type variables into scope unlike function bindings - -- Wny not? They are not completely rigid. - -- That's why we have the special case for a single FunBind in tcMonoBinds - tcExtendIdBinderStackForRhs infos $ - do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) - ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ - tcGRHSsPat grhss pat_ty - ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_ext = NPatBindTc placeHolderNamesTc pat_ty - , pat_ticks = ([],[]) } )} - -tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvForRhs Nothing thing_inside - = thing_inside -tcExtendTyVarEnvForRhs (Just sig) thing_inside - = tcExtendTyVarEnvFromSig sig thing_inside - -tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvFromSig sig_inst thing_inside - | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst - = tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv skol_prs $ - thing_inside - -tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a --- Extend the TcBinderStack for the RHS of the binding, with --- the monomorphic Id. That way, if we have, say --- f = \x -> blah --- and something goes wrong in 'blah', we get a "relevant binding" --- looking like f :: alpha -> beta --- This applies if 'f' has a type signature too: --- f :: forall a. [a] -> [a] --- f x = True --- We can't unify True with [a], and a relevant binding is f :: [a] -> [a] --- If we had the *polymorphic* version of f in the TcBinderStack, it --- would not be reported as relevant, because its type is closed -tcExtendIdBinderStackForRhs infos thing_inside - = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel - | MBI { mbi_mono_id = mono_id } <- infos ] - thing_inside - -- NotTopLevel: it's a monomorphic binding - ---------------------- -getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] -getMonoBindInfo tc_binds - = foldr (get_info . unLoc) [] tc_binds - where - get_info (TcFunBind info _ _) rest = info : rest - get_info (TcPatBind infos _ _ _) rest = infos ++ rest - - -{- Note [Typechecking pattern bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at: - - typecheck/should_compile/ExPat - - #12427, typecheck/should_compile/T12427{a,b} - - data T where - MkT :: Integral a => a -> Int -> T - -and suppose t :: T. Which of these pattern bindings are ok? - - E1. let { MkT p _ = t } in - - E2. let { MkT _ q = t } in - - E3. let { MkT (toInteger -> r) _ = t } in - -* (E1) is clearly wrong because the existential 'a' escapes. - What type could 'p' possibly have? - -* (E2) is fine, despite the existential pattern, because - q::Int, and nothing escapes. - -* Even (E3) is fine. The existential pattern binds a dictionary - for (Integral a) which the view pattern can use to convert the - a-valued field to an Integer, so r :: Integer. - -An easy way to see all three is to imagine the desugaring. -For (E2) it would look like - let q = case t of MkT _ q' -> q' - in - - -We typecheck pattern bindings as follows. First tcLhs does this: - - 1. Take each type signature q :: ty, partial or complete, and - instantiate it (with tcLhsSigId) to get a MonoBindInfo. This - gives us a fresh "mono_id" qm :: instantiate(ty), where qm has - a fresh name. - - Any fresh unification variables in instantiate(ty) born here, not - deep under implications as would happen if we allocated them when - we encountered q during tcPat. - - 2. Build a little environment mapping "q" -> "qm" for those Ids - with signatures (inst_sig_fun) - - 3. Invoke tcLetPat to typecheck the pattern. - - - We pass in the current TcLevel. This is captured by - TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in - PatEnv. - - - When tcPat finds an existential constructor, it binds fresh - type variables and dictionaries as usual, increments the TcLevel, - and emits an implication constraint. - - - When we come to a binder (TcPat.tcPatBndr), it looks it up - in the little environment (the pc_sig_fn field of PatCtxt). - - Success => There was a type signature, so just use it, - checking compatibility with the expected type. - - Failure => No type sigature. - Infer case: (happens only outside any constructor pattern) - use a unification variable - at the outer level pc_lvl - - Check case: use promoteTcType to promote the type - to the outer level pc_lvl. This is the - place where we emit a constraint that'll blow - up if existential capture takes place - - Result: the type of the binder is always at pc_lvl. This is - crucial. - - 4. Throughout, when we are making up an Id for the pattern-bound variables - (newLetBndr), we have two cases: - - - If we are generalising (generalisation plan is InferGen or - CheckGen), then the let_bndr_spec will be LetLclBndr. In that case - we want to bind a cloned, local version of the variable, with the - type given by the pattern context, *not* by the signature (even if - there is one; see #7268). The mkExport part of the - generalisation step will do the checking and impedance matching - against the signature. - - - If for some some reason we are not generalising (plan = NoGen), the - LetBndrSpec will be LetGblBndr. In that case we must bind the - global version of the Id, and do so with precisely the type given - in the signature. (Then we unify with the type from the pattern - context type.) - - -And that's it! The implication constraints check for the skolem -escape. It's quite simple and neat, and more expressive than before -e.g. GHC 8.0 rejects (E2) and (E3). - -Example for (E1), starting at level 1. We generate - p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta) -The (a~beta) can't float (because of the 'a'), nor be solved (because -beta is untouchable.) - -Example for (E2), we generate - q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta) -The beta is untouchable, but floats out of the constraint and can -be solved absolutely fine. - - -************************************************************************ -* * - Generalisation -* * -********************************************************************* -} - -data GeneralisationPlan - = NoGen -- No generalisation, no AbsBinds - - | InferGen -- Implicit generalisation; there is an AbsBinds - Bool -- True <=> apply the MR; generalise only unconstrained type vars - - | CheckGen (LHsBind GhcRn) TcIdSigInfo - -- One FunBind with a signature - -- Explicit generalisation - --- A consequence of the no-AbsBinds choice (NoGen) is that there is --- no "polymorphic Id" and "monmomorphic Id"; there is just the one - -instance Outputable GeneralisationPlan where - ppr NoGen = text "NoGen" - ppr (InferGen b) = text "InferGen" <+> ppr b - ppr (CheckGen _ s) = text "CheckGen" <+> ppr s - -decideGeneralisationPlan - :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun - -> GeneralisationPlan -decideGeneralisationPlan dflags lbinds closed sig_fn - | has_partial_sigs = InferGen (and partial_sig_mrs) - | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig - | do_not_generalise closed = NoGen - | otherwise = InferGen mono_restriction - where - binds = map unLoc lbinds - - partial_sig_mrs :: [Bool] - -- One for each partial signature (so empty => no partial sigs) - -- The Bool is True if the signature has no constraint context - -- so we should apply the MR - -- See Note [Partial type signatures and generalisation] - partial_sig_mrs - = [ null theta - | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) - <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, dL->L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ] - - has_partial_sigs = not (null partial_sig_mrs) - - mono_restriction = xopt LangExt.MonomorphismRestriction dflags - && any restricted binds - - do_not_generalise (IsGroupClosed _ True) = False - -- The 'True' means that all of the group's - -- free vars have ClosedTypeId=True; so we can ignore - -- -XMonoLocalBinds, and generalise anyway - do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags - - -- With OutsideIn, all nested bindings are monomorphic - -- except a single function binding with a signature - one_funbind_with_sig - | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds - , Just (TcIdSig sig) <- sig_fn (unLoc v) - = Just (lbind, sig) - | otherwise - = Nothing - - -- The Haskell 98 monomorphism restriction - restricted (PatBind {}) = True - restricted (VarBind { var_id = v }) = no_sig v - restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m - && no_sig (unLoc v) - restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b) - - restricted_match mg = matchGroupArity mg == 0 - -- No args => like a pattern binding - -- Some args => a function binding - - no_sig n = not (hasCompleteSig sig_fn n) - -isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed -isClosedBndrGroup type_env binds - = IsGroupClosed fv_env type_closed - where - type_closed = allUFM (nameSetAll is_closed_type_id) fv_env - - fv_env :: NameEnv NameSet - fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - - bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = (dL->L _ f) - , fun_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(f, open_fvs)] - bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(b, open_fvs) | b <- collectPatBinders pat] - bindFvs _ - = [] - - get_open_fvs fvs = filterNameSet (not . is_closed) fvs - - is_closed :: Name -> ClosedTypeId - is_closed name - | Just thing <- lookupNameEnv type_env name - = case thing of - AGlobal {} -> True - ATcId { tct_info = ClosedLet } -> True - _ -> False - - | otherwise - = True -- The free-var set for a top level binding mentions - - - is_closed_type_id :: Name -> Bool - -- We're already removed Global and ClosedLet Ids - is_closed_type_id name - | Just thing <- lookupNameEnv type_env name - = case thing of - ATcId { tct_info = NonClosedLet _ cl } -> cl - ATcId { tct_info = NotLetBound } -> False - ATyVar {} -> False - -- In-scope type variables are not closed! - _ -> pprPanic "is_closed_id" (ppr name) - - | otherwise - = True -- The free-var set for a top level binding mentions - -- imported things too, so that we can report unused imports - -- These won't be in the local type env. - -- Ditto class method etc from the current module - - -{- ********************************************************************* -* * - Error contexts and messages -* * -********************************************************************* -} - --- This one is called on LHS, when pat and grhss are both Name --- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) - => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc -patMonoBindsCtxt pat grhss - = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/typecheck/TcCanonical.hs b/typecheck/TcCanonical.hs deleted file mode 100644 --- a/typecheck/TcCanonical.hs +++ /dev/null @@ -1,2480 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module TcCanonical( - canonicalize, - unifyDerived, - makeSuperClasses, maybeSym, - StopOrContinue(..), stopWith, continueWith, - solveCallStack -- For TcSimplify - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Constraint -import Predicate -import TcOrigin -import TcUnify( swapOverTyVars, metaTyVarUpdateOK ) -import TcType -import Type -import TcFlatten -import TcSMonad -import TcEvidence -import TcEvTerm -import Class -import TyCon -import TyCoRep -- cleverly decomposes types, good for completeness checking -import Coercion -import CoreSyn -import Id( idType, mkTemplateLocals ) -import FamInstEnv ( FamInstEnvs ) -import FamInst ( tcTopNormaliseNewTypeTF_maybe ) -import Var -import VarEnv( mkInScopeSet ) -import VarSet( delVarSetList ) -import Outputable -import DynFlags( DynFlags ) -import NameSet -import RdrName -import GHC.Hs.Types( HsIPName(..) ) - -import Pair -import Util -import Bag -import MonadUtils -import Control.Monad -import Data.Maybe ( isJust ) -import Data.List ( zip4 ) -import BasicTypes - -import Data.Bifunctor ( bimap ) -import Data.Foldable ( traverse_ ) - -{- -************************************************************************ -* * -* The Canonicaliser * -* * -************************************************************************ - -Note [Canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~ - -Canonicalization converts a simple constraint to a canonical form. It is -unary (i.e. treats individual constraints one at a time). - -Constraints originating from user-written code come into being as -CNonCanonicals (except for CHoleCans, arising from holes). We know nothing -about these constraints. So, first: - - Classify CNonCanoncal constraints, depending on whether they - are equalities, class predicates, or other. - -Then proceed depending on the shape of the constraint. Generally speaking, -each constraint gets flattened and then decomposed into one of several forms -(see type Ct in TcRnTypes). - -When an already-canonicalized constraint gets kicked out of the inert set, -it must be recanonicalized. But we know a bit about its shape from the -last time through, so we can skip the classification step. - --} - --- Top-level canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -canonicalize :: Ct -> TcS (StopOrContinue Ct) -canonicalize (CNonCanonical { cc_ev = ev }) - = {-# SCC "canNC" #-} - case classifyPredType pred of - ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) - canClassNC ev cls tys - EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) - canEqNC ev eq_rel ty1 ty2 - IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) - canIrred ev - ForAllPred _ _ pred -> do traceTcS "canEvNC:forall" (ppr pred) - canForAll ev (isClassPred pred) - where - pred = ctEvPred ev - -canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = canForAll ev pend_sc - -canonicalize (CIrredCan { cc_ev = ev }) - | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev) - = -- For insolubles (all of which are equalities, do /not/ flatten the arguments - -- In #14350 doing so led entire-unnecessary and ridiculously large - -- type function expansion. Instead, canEqNC just applies - -- the substitution to the predicate, and may do decomposition; - -- e.g. a ~ [a], where [G] a ~ [Int], can decompose - canEqNC ev eq_rel ty1 ty2 - - | otherwise - = canIrred ev - -canonicalize (CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis, cc_pend_sc = pend_sc }) - = {-# SCC "canClass" #-} - canClass ev cls xis pend_sc - -canonicalize (CTyEqCan { cc_ev = ev - , cc_tyvar = tv - , cc_rhs = xi - , cc_eq_rel = eq_rel }) - = {-# SCC "canEqLeafTyVarEq" #-} - canEqNC ev eq_rel (mkTyVarTy tv) xi - -- NB: Don't use canEqTyVar because that expects flattened types, - -- and tv and xi may not be flat w.r.t. an updated inert set - -canonicalize (CFunEqCan { cc_ev = ev - , cc_fun = fn - , cc_tyargs = xis1 - , cc_fsk = fsk }) - = {-# SCC "canEqLeafFunEq" #-} - canCFunEqCan ev fn xis1 fsk - -canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole }) - = canHole ev hole - -{- -************************************************************************ -* * -* Class Canonicalization -* * -************************************************************************ --} - -canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) --- "NC" means "non-canonical"; that is, we have got here --- from a NonCanonical constraint, not from a CDictCan --- Precondition: EvVar is class evidence -canClassNC ev cls tys - | isGiven ev -- See Note [Eagerly expand given superclasses] - = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys - ; emitWork sc_cts - ; canClass ev cls tys False } - - | isWanted ev - , Just ip_name <- isCallStackPred cls tys - , OccurrenceOf func <- ctLocOrigin loc - -- If we're given a CallStack constraint that arose from a function - -- call, we need to push the current call-site onto the stack instead - -- of solving it directly from a given. - -- See Note [Overview of implicit CallStacks] in TcEvidence - -- and Note [Solving CallStack constraints] in TcSMonad - = do { -- First we emit a new constraint that will capture the - -- given CallStack. - ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name)) - -- We change the origin to IPOccOrigin so - -- this rule does not fire again. - -- See Note [Overview of implicit CallStacks] - - ; new_ev <- newWantedEvVarNC new_loc pred - - -- Then we solve the wanted by pushing the call-site - -- onto the newly emitted CallStack - ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev) - ; solveCallStack ev ev_cs - - ; canClass new_ev cls tys False } - - | otherwise - = canClass ev cls tys (has_scs cls) - - where - has_scs cls = not (null (classSCTheta cls)) - loc = ctEvLoc ev - pred = ctEvPred ev - -solveCallStack :: CtEvidence -> EvCallStack -> TcS () --- Also called from TcSimplify when defaulting call stacks -solveCallStack ev ev_cs = do - -- We're given ev_cs :: CallStack, but the evidence term should be a - -- dictionary, so we have to coerce ev_cs to a dictionary for - -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] - cs_tm <- evCallStack ev_cs - let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) - setEvBindIfWanted ev ev_tm - -canClass :: CtEvidence - -> Class -> [Type] - -> Bool -- True <=> un-explored superclasses - -> TcS (StopOrContinue Ct) --- Precondition: EvVar is class evidence - -canClass ev cls tys pend_sc - = -- all classes do *nominal* matching - ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) - do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys - ; MASSERT( isTcReflCo _kind_co ) - ; let co = mkTcTyConAppCo Nominal cls_tc cos - xi = mkClassPred cls xis - mk_ct new_ev = CDictCan { cc_ev = new_ev - , cc_tyargs = xis - , cc_class = cls - , cc_pend_sc = pend_sc } - ; mb <- rewriteEvidence ev xi co - ; traceTcS "canClass" (vcat [ ppr ev - , ppr xi, ppr mb ]) - ; return (fmap mk_ct mb) } - where - cls_tc = classTyCon cls - -{- Note [The superclass story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to add superclass constraints for two reasons: - -* For givens [G], they give us a route to proof. E.g. - f :: Ord a => a -> Bool - f x = x == x - We get a Wanted (Eq a), which can only be solved from the superclass - of the Given (Ord a). - -* For wanteds [W], and deriveds [WD], [D], they may give useful - functional dependencies. E.g. - class C a b | a -> b where ... - class C a b => D a b where ... - Now a [W] constraint (D Int beta) has (C Int beta) as a superclass - and that might tell us about beta, via C's fundeps. We can get this - by generating a [D] (C Int beta) constraint. It's derived because - we don't actually have to cough up any evidence for it; it's only there - to generate fundep equalities. - -See Note [Why adding superclasses can help]. - -For these reasons we want to generate superclass constraints for both -Givens and Wanteds. But: - -* (Minor) they are often not needed, so generating them aggressively - is a waste of time. - -* (Major) if we want recursive superclasses, there would be an infinite - number of them. Here is a real-life example (#10318); - - class (Frac (Frac a) ~ Frac a, - Fractional (Frac a), - IntegralDomain (Frac a)) - => IntegralDomain a where - type Frac a :: * - - Notice that IntegralDomain has an associated type Frac, and one - of IntegralDomain's superclasses is another IntegralDomain constraint. - -So here's the plan: - -1. Eagerly generate superclasses for given (but not wanted) - constraints; see Note [Eagerly expand given superclasses]. - This is done using mkStrictSuperClasses in canClassNC, when - we take a non-canonical Given constraint and cannonicalise it. - - However stop if you encounter the same class twice. That is, - mkStrictSuperClasses expands eagerly, but has a conservative - termination condition: see Note [Expanding superclasses] in TcType. - -2. Solve the wanteds as usual, but do no further expansion of - superclasses for canonical CDictCans in solveSimpleGivens or - solveSimpleWanteds; Note [Danger of adding superclasses during solving] - - However, /do/ continue to eagerly expand superlasses for new /given/ - /non-canonical/ constraints (canClassNC does this). As #12175 - showed, a type-family application can expand to a class constraint, - and we want to see its superclasses for just the same reason as - Note [Eagerly expand given superclasses]. - -3. If we have any remaining unsolved wanteds - (see Note [When superclasses help] in Constraint) - try harder: take both the Givens and Wanteds, and expand - superclasses again. See the calls to expandSuperClasses in - TcSimplify.simpl_loop and solveWanteds. - - This may succeed in generating (a finite number of) extra Givens, - and extra Deriveds. Both may help the proof. - -3a An important wrinkle: only expand Givens from the current level. - Two reasons: - - We only want to expand it once, and that is best done at - the level it is bound, rather than repeatedly at the leaves - of the implication tree - - We may be inside a type where we can't create term-level - evidence anyway, so we can't superclass-expand, say, - (a ~ b) to get (a ~# b). This happened in #15290. - -4. Go round to (2) again. This loop (2,3,4) is implemented - in TcSimplify.simpl_loop. - -The cc_pend_sc flag in a CDictCan records whether the superclasses of -this constraint have been expanded. Specifically, in Step 3 we only -expand superclasses for constraints with cc_pend_sc set to true (i.e. -isPendingScDict holds). - -Why do we do this? Two reasons: - -* To avoid repeated work, by repeatedly expanding the superclasses of - same constraint, - -* To terminate the above loop, at least in the -XNoRecursiveSuperClasses - case. If there are recursive superclasses we could, in principle, - expand forever, always encountering new constraints. - -When we take a CNonCanonical or CIrredCan, but end up classifying it -as a CDictCan, we set the cc_pend_sc flag to False. - -Note [Superclass loops] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a - class D a => C a - -Then, when we expand superclasses, we'll get back to the self-same -predicate, so we have reached a fixpoint in expansion and there is no -point in fruitlessly expanding further. This case just falls out from -our strategy. Consider - f :: C a => a -> Bool - f x = x==x -Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses -G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its sc_pend flag set.) -When processing d3 we find a match with d1 in the inert set, and we always -keep the inert item (d1) if possible: see Note [Replacement vs keeping] in -TcInteract. So d3 dies a quick, happy death. - -Note [Eagerly expand given superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step (1) of Note [The superclass story], why do we eagerly expand -Given superclasses by one layer? (By "one layer" we mean expand transitively -until you meet the same class again -- the conservative criterion embodied -in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) -We do this eagerly for Givens mainly because of some very obscure -cases like this: - - instance Bad a => Eq (T a) - - f :: (Ord (T a)) => blah - f x = ....needs Eq (T a), Ord (T a).... - -Here if we can't satisfy (Eq (T a)) from the givens we'll use the -instance declaration; but then we are stuck with (Bad a). Sigh. -This is really a case of non-confluent proofs, but to stop our users -complaining we expand one layer in advance. - -Note [Instance and Given overlap] in TcInteract. - -We also want to do this if we have - - f :: F (T a) => blah - -where - type instance F (T a) = Ord (T a) - -So we may need to do a little work on the givens to expose the -class that has the superclasses. That's why the superclass -expansion for Givens happens in canClassNC. - -Note [Why adding superclasses can help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Examples of how adding superclasses can help: - - --- Example 1 - class C a b | a -> b - Suppose we want to solve - [G] C a b - [W] C a beta - Then adding [D] beta~b will let us solve it. - - -- Example 2 (similar but using a type-equality superclass) - class (F a ~ b) => C a b - And try to sllve: - [G] C a b - [W] C a beta - Follow the superclass rules to add - [G] F a ~ b - [D] F a ~ beta - Now we get [D] beta ~ b, and can solve that. - - -- Example (tcfail138) - class L a b | a -> b - class (G a, L a b) => C a b - - instance C a b' => G (Maybe a) - instance C a b => C (Maybe a) a - instance L (Maybe a) a - - When solving the superclasses of the (C (Maybe a) a) instance, we get - [G] C a b, and hance by superclasses, [G] G a, [G] L a b - [W] G (Maybe a) - Use the instance decl to get - [W] C a beta - Generate its derived superclass - [D] L a beta. Now using fundeps, combine with [G] L a b to get - [D] beta ~ b - which is what we want. - -Note [Danger of adding superclasses during solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a serious, but now out-dated example, from #4497: - - class Num (RealOf t) => Normed t - type family RealOf x - -Assume the generated wanted constraint is: - [W] RealOf e ~ e - [W] Normed e - -If we were to be adding the superclasses during simplification we'd get: - [W] RealOf e ~ e - [W] Normed e - [D] RealOf e ~ fuv - [D] Num fuv -==> - e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv - -While looks exactly like our original constraint. If we add the -superclass of (Normed fuv) again we'd loop. By adding superclasses -definitely only once, during canonicalisation, this situation can't -happen. - -Mind you, now that Wanteds cannot rewrite Derived, I think this particular -situation can't happen. - -} - -makeSuperClasses :: [Ct] -> TcS [Ct] --- Returns strict superclasses, transitively, see Note [The superclasses story] --- See Note [The superclass story] --- The loop-breaking here follows Note [Expanding superclasses] in TcType --- Specifically, for an incoming (C t) constraint, we return all of (C t)'s --- superclasses, up to /and including/ the first repetition of C --- --- Example: class D a => C a --- class C [a] => D a --- makeSuperClasses (C x) will return (D x, C [x]) --- --- NB: the incoming constraints have had their cc_pend_sc flag already --- flipped to False, by isPendingScDict, so we are /obliged/ to at --- least produce the immediate superclasses -makeSuperClasses cts = concatMapM go cts - where - go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = mkStrictSuperClasses ev [] [] cls tys - go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev })) - = ASSERT2( isClassPred pred, ppr pred ) -- The cts should all have - -- class pred heads - mkStrictSuperClasses ev tvs theta cls tys - where - (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) - go ct = pprPanic "makeSuperClasses" (ppr ct) - -mkStrictSuperClasses - :: CtEvidence - -> [TyVar] -> ThetaType -- These two args are non-empty only when taking - -- superclasses of a /quantified/ constraint - -> Class -> [Type] -> TcS [Ct] --- Return constraints for the strict superclasses of --- ev :: forall as. theta => cls tys -mkStrictSuperClasses ev tvs theta cls tys - = mk_strict_superclasses (unitNameSet (className cls)) - ev tvs theta cls tys - -mk_strict_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcS [Ct] --- Always return the immediate superclasses of (cls tys); --- and expand their superclasses, provided none of them are in rec_clss --- nor are repeated -mk_strict_superclasses rec_clss ev tvs theta cls tys - | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev - = concatMapM (do_one_given evar (mk_given_loc loc)) $ - classSCSelIds cls - where - dict_ids = mkTemplateLocals theta - size = sizeTypes tys - - do_one_given evar given_loc sel_id - | isUnliftedType sc_pred - , not (null tvs && null theta) - = -- See Note [Equality superclasses in quantified constraints] - return [] - | otherwise - = do { given_ev <- newGivenEvVar given_loc $ - (given_ty, mk_sc_sel evar sel_id) - ; mk_superclasses rec_clss given_ev tvs theta sc_pred } - where - sc_pred = funResultTy (piResultTys (idType sel_id) tys) - given_ty = mkInfSigmaTy tvs theta sc_pred - - mk_sc_sel evar sel_id - = EvExpr $ mkLams tvs $ mkLams dict_ids $ - Var sel_id `mkTyApps` tys `App` - (evId evar `mkTyApps` mkTyVarTys tvs `mkVarApps` dict_ids) - - mk_given_loc loc - | isCTupleClass cls - = loc -- For tuple predicates, just take them apart, without - -- adding their (large) size into the chain. When we - -- get down to a base predicate, we'll include its size. - -- #10335 - - | GivenOrigin skol_info <- ctLocOrigin loc - -- See Note [Solving superclass constraints] in TcInstDcls - -- for explantation of this transformation for givens - = case skol_info of - InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) } - InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } - _ -> loc - - | otherwise -- Probably doesn't happen, since this function - = loc -- is only used for Givens, but does no harm - -mk_strict_superclasses rec_clss ev tvs theta cls tys - | all noFreeVarsOfType tys - = return [] -- Wanteds with no variables yield no deriveds. - -- See Note [Improvement from Ground Wanteds] - - | otherwise -- Wanted/Derived case, just add Derived superclasses - -- that can lead to improvement. - = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta ) - concatMapM do_one_derived (immSuperClasses cls tys) - where - loc = ctEvLoc ev - - do_one_derived sc_pred - = do { sc_ev <- newDerivedNC loc sc_pred - ; mk_superclasses rec_clss sc_ev [] [] sc_pred } - -mk_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] --- Return this constraint, plus its superclasses, if any -mk_superclasses rec_clss ev tvs theta pred - | ClassPred cls tys <- classifyPredType pred - = mk_superclasses_of rec_clss ev tvs theta cls tys - - | otherwise -- Superclass is not a class predicate - = return [mkNonCanonical ev] - -mk_superclasses_of :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> Class -> [Type] - -> TcS [Ct] --- Always return this class constraint, --- and expand its superclasses -mk_superclasses_of rec_clss ev tvs theta cls tys - | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) - ; return [this_ct] } -- cc_pend_sc of this_ct = True - | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys - , ppr (isCTupleClass cls) - , ppr rec_clss - ]) - ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys - ; return (this_ct : sc_cts) } - -- cc_pend_sc of this_ct = False - where - cls_nm = className cls - loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss - -- Tuples never contribute to recursion, and can be nested - rec_clss' = rec_clss `extendNameSet` cls_nm - - this_ct | null tvs, null theta - = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys - , cc_pend_sc = loop_found } - -- NB: If there is a loop, we cut off, so we have not - -- added the superclasses, hence cc_pend_sc = True - | otherwise - = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys - , qci_ev = ev - , qci_pend_sc = loop_found }) - - -{- Note [Equality superclasses in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15359, #15593, #15625) - f :: (forall a. theta => a ~ b) => stuff - -It's a bit odd to have a local, quantified constraint for `(a~b)`, -but some people want such a thing (see the tickets). And for -Coercible it is definitely useful - f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) - => stuff - -Moreover it's not hard to arrange; we just need to look up /equality/ -constraints in the quantified-constraint environment, which we do in -TcInteract.doTopReactOther. - -There is a wrinkle though, in the case where 'theta' is empty, so -we have - f :: (forall a. a~b) => stuff - -Now, potentially, the superclass machinery kicks in, in -makeSuperClasses, giving us a a second quantified constrait - (forall a. a ~# b) -BUT this is an unboxed value! And nothing has prepared us for -dictionary "functions" that are unboxed. Actually it does just -about work, but the simplier ends up with stuff like - case (/\a. eq_sel d) of df -> ...(df @Int)... -and fails to simplify that any further. And it doesn't satisfy -isPredTy any more. - -So for now we simply decline to take superclasses in the quantified -case. Instead we have a special case in TcInteract.doTopReactOther, -which looks for primitive equalities specially in the quantified -constraints. - -See also Note [Evidence for quantified constraints] in Predicate. - - -************************************************************************ -* * -* Irreducibles canonicalization -* * -************************************************************************ --} - -canIrred :: CtEvidence -> TcS (StopOrContinue Ct) --- Precondition: ty not a tuple and no other evidence form -canIrred ev - = do { let pred = ctEvPred ev - ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { -- Re-classify, in case flattening has improved its shape - ; case classifyPredType (ctEvPred new_ev) of - ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 - _ -> continueWith $ - mkIrredCt new_ev } } - -canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct) -canHole ev hole - = do { let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev - , cc_hole = hole })) - ; stopWith new_ev "Emit insoluble hole" } } - - -{- ********************************************************************* -* * -* Quantified predicates -* * -********************************************************************* -} - -{- Note [Quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The -XQuantifiedConstraints extension allows type-class contexts like this: - - data Rose f x = Rose x (f (Rose f x)) - - instance (Eq a, forall b. Eq b => Eq (f b)) - => Eq (Rose f a) where - (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 - -Note the (forall b. Eq b => Eq (f b)) in the instance contexts. -This quantified constraint is needed to solve the - [W] (Eq (f (Rose f x))) -constraint which arises form the (==) definition. - -The wiki page is - https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints -which in turn contains a link to the GHC Proposal where the change -is specified, and a Haskell Symposium paper about it. - -We implement two main extensions to the design in the paper: - - 1. We allow a variable in the instance head, e.g. - f :: forall m a. (forall b. m b) => D (m a) - Notice the 'm' in the head of the quantified constraint, not - a class. - - 2. We suport superclasses to quantified constraints. - For example (contrived): - f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool - f x y = x==y - Here we need (Eq (m a)); but the quantifed constraint deals only - with Ord. But we can make it work by using its superclass. - -Here are the moving parts - * Language extension {-# LANGUAGE QuantifiedConstraints #-} - and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension - - * A new form of evidence, EvDFun, that is used to discharge - such wanted constraints - - * checkValidType gets some changes to accept forall-constraints - only in the right places. - - * Predicate.Pred gets a new constructor ForAllPred, and - and classifyPredType analyses a PredType to decompose - the new forall-constraints - - * TcSMonad.InertCans gets an extra field, inert_insts, - which holds all the Given forall-constraints. In effect, - such Given constraints are like local instance decls. - - * When trying to solve a class constraint, via - TcInteract.matchInstEnv, use the InstEnv from inert_insts - so that we include the local Given forall-constraints - in the lookup. (See TcSMonad.getInstEnvs.) - - * TcCanonical.canForAll deals with solving a - forall-constraint. See - Note [Solving a Wanted forall-constraint] - - * We augment the kick-out code to kick out an inert - forall constraint if it can be rewritten by a new - type equality; see TcSMonad.kick_out_rewritable - -Note that a quantified constraint is never /inferred/ -(by TcSimplify.simplifyInfer). A function can only have a -quantified constraint in its type if it is given an explicit -type signature. - -Note that we implement --} - -canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct) --- We have a constraint (forall as. blah => C tys) -canForAll ev pend_sc - = do { -- First rewrite it to apply the current substitution - -- Do not bother with type-family reductions; we can't - -- do them under a forall anyway (c.f. Flatten.flatten_one - -- on a forall type) - let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - - do { -- Now decompose into its pieces and solve it - -- (It takes a lot less code to flatten before decomposing.) - ; case classifyPredType (ctEvPred new_ev) of - ForAllPred tv_bndrs theta pred - -> solveForAll new_ev tv_bndrs theta pred pend_sc - _ -> pprPanic "canForAll" (ppr new_ev) - } } - -solveForAll :: CtEvidence -> [TyVarBinder] -> TcThetaType -> PredType -> Bool - -> TcS (StopOrContinue Ct) -solveForAll ev tv_bndrs theta pred pend_sc - | CtWanted { ctev_dest = dest } <- ev - = -- See Note [Solving a Wanted forall-constraint] - do { let skol_info = QuantCtxtSkol - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs - ; given_ev_vars <- mapM newEvVar (substTheta subst theta) - - ; (lvl, (w_id, wanteds)) - <- pushLevelNoWorkList (ppr skol_info) $ - do { wanted_ev <- newWantedEvVarNC loc $ - substTy subst pred - ; return ( ctEvEvId wanted_ev - , unitBag (mkNonCanonical wanted_ev)) } - - ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs - given_ev_vars wanteds - - ; setWantedEvTerm dest $ - EvFun { et_tvs = skol_tvs, et_given = given_ev_vars - , et_binds = ev_binds, et_body = w_id } - - ; stopWith ev "Wanted forall-constraint" } - - | isGiven ev -- See Note [Solving a Given forall-constraint] - = do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } - - | otherwise - = stopWith ev "Derived forall-constraint" - where - loc = ctEvLoc ev - tvs = binderVars tv_bndrs - qci = QCI { qci_ev = ev, qci_tvs = tvs - , qci_pred = pred, qci_pend_sc = pend_sc } - -{- Note [Solving a Wanted forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a wanted forall (quantified) constraint - [W] df :: forall ab. (Eq a, Ord b) => C x a b -is delightfully easy. Just build an implication constraint - forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a -and discharge df thus: - df = /\ab. \g1 g2. let in d -where is filled in by solving the implication constraint. -All the machinery is to hand; there is little to do. - -Note [Solving a Given forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a Given constraint - [G] df :: forall ab. (Eq a, Ord b) => C x a b -we just add it to TcS's local InstEnv of known instances, -via addInertForall. Then, if we look up (C x Int Bool), say, -we'll find a match in the InstEnv. - - -************************************************************************ -* * -* Equalities -* * -************************************************************************ - -Note [Canonicalising equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to canonicalise an equality, we look at the structure of the -two types at hand, looking for similarities. A difficulty is that the -types may look dissimilar before flattening but similar after flattening. -However, we don't just want to jump in and flatten right away, because -this might be wasted effort. So, after looking for similarities and failing, -we flatten and then try again. Of course, we don't want to loop, so we -track whether or not we've already flattened. - -It is conceivable to do a better job at tracking whether or not a type -is flattened, but this is left as future work. (Mar '15) - - -Note [FunTy and decomposing tycon applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked. -This means that we may very well have a FunTy containing a type of some unknown -kind. For instance, we may have, - - FunTy (a :: k) Int - -Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event -that it sees such a type as it cannot determine the RuntimeReps which the (->) -is applied to. Consequently, it is vital that we instead use -tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case. - -When this happens can_eq_nc' will fail to decompose, zonk, and try again. -Zonking should fill the variable k, meaning that decomposition will succeed the -second time around. --} - -canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) -canEqNC ev eq_rel ty1 ty2 - = do { result <- zonk_eq_types ty1 ty2 - ; case result of - Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 - Right ty -> canEqReflexive ev eq_rel ty } - -can_eq_nc - :: Bool -- True => both types are flat - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) -can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - = do { traceTcS "can_eq_nc" $ - vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] - ; rdr_env <- getGlobalRdrEnvTcS - ; fam_insts <- getFamInstEnvs - ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } - -can_eq_nc' - :: Bool -- True => both input types are flattened - -> GlobalRdrEnv -- needed to see which newtypes are in scope - -> FamInstEnvs -- needed to unwrap data instances - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) - --- Expand synonyms first; see Note [Type synonyms and canonicalization] -can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 - --- need to check for reflexivity in the ReprEq case. --- See Note [Eager reflexivity check] --- Check only when flat because the zonk_eq_types check in canEqNC takes --- care of the non-flat case. -can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _ - | ty1 `tcEqType` ty2 - = canEqReflexive ev ReprEq ty1 - --- When working with ReprEq, unwrap newtypes. --- See Note [Unwrap newtypes first] -can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | ReprEq <- eq_rel - , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 - = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2 - - | ReprEq <- eq_rel - , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 - = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1 - --- Then, get rid of casts -can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 - = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 -can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ - = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 - --- NB: pattern match on True: we want only flat types sent to canEqTyVar. --- See also Note [No top-level newtypes on RHS of representational equalities] -can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2 - = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2 - = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1 - ----------------------- --- Otherwise try to decompose ----------------------- - --- Literals -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ - | l1 == l2 - = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1) - ; stopWith ev "Equal LitTy" } - --- Try to decompose type constructor applications --- Including FunTy (s -> t) -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _ - --- See Note [FunTy and decomposing type constructor applications]. - | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2 - , not (isTypeFamilyTyCon tc1) - , not (isTypeFamilyTyCon tc2) - = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - -can_eq_nc' _flat _rdr_env _envs ev eq_rel - s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ - = can_eq_nc_forall ev eq_rel s1 s2 - --- See Note [Canonicalising type applications] about why we require flat types -can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _ - | NomEq <- eq_rel - , Just (t2, s2) <- tcSplitAppTy_maybe ty2 - = can_eq_app ev t1 s1 t2 s2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ - | NomEq <- eq_rel - , Just (t1, s1) <- tcSplitAppTy_maybe ty1 - = can_eq_app ev t1 s1 t2 s2 - --- No similarity in type structure detected. Flatten and try again. -can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } - --- We've flattened and the types don't match. Give up. -can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) - ; case eq_rel of -- See Note [Unsolved equalities] - ReprEq -> continueWith (mkIrredCt ev) - NomEq -> continueWith (mkInsolubleCt ev) } - -- No need to call canEqFailure/canEqHardFailure because they - -- flatten, and the types involved here are already flat - -{- Note [Unsolved equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved equality like - (a b ~R# Int) -that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. -So we want to make it a potentially-soluble Irred not an insoluble one. -Missing this point is what caused #15431 --} - ---------------------------------- -can_eq_nc_forall :: CtEvidence -> EqRel - -> Type -> Type -- LHS and RHS - -> TcS (StopOrContinue Ct) --- (forall as. phi1) ~ (forall bs. phi2) --- Check for length match of as, bs --- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs] --- But remember also to unify the kinds of as and bs --- (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] --- Remember also that we might have forall z (a:z). blah --- so we must proceed one binder at a time (#13879) - -can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev - = do { let free_tvs = tyCoVarsOfTypes [s1,s2] - (bndrs1, phi1) = tcSplitForAllVarBndrs s1 - (bndrs2, phi2) = tcSplitForAllVarBndrs s2 - ; if not (equalLength bndrs1 bndrs2) - then do { traceTcS "Forall failure" $ - vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr (map binderArgFlag bndrs1) - , ppr (map binderArgFlag bndrs2) ] - ; canEqHardFailure ev s1 s2 } - else - do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ - binderVars bndrs1 - - ; let skol_info = UnifyForAllSkol phi1 - phi1' = substTy subst1 phi1 - - -- Unify the kinds, extend the substitution - go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] - -> TcS (TcCoercion, Cts) - go (skol_tv:skol_tvs) subst (bndr2:bndrs2) - = do { let tv2 = binderVar bndr2 - ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv) - (substTy subst (tyVarKind tv2)) - ; let subst' = extendTvSubstAndInScope subst tv2 - (mkCastTy (mkTyVarTy skol_tv) kind_co) - -- skol_tv is already in the in-scope set, but the - -- free vars of kind_co are not; hence "...AndInScope" - ; (co, wanteds2) <- go skol_tvs subst' bndrs2 - ; return ( mkTcForAllCo skol_tv kind_co co - , wanteds1 `unionBags` wanteds2 ) } - - -- Done: unify phi1 ~ phi2 - go [] subst bndrs2 - = ASSERT( null bndrs2 ) - unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) - - go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] - - empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) - - ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - go skol_tvs empty_subst2 bndrs2 - ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds - - ; setWantedEq orig_dest all_co - ; stopWith ev "Deferred polytype equality" } } - - | otherwise - = do { traceTcS "Omitting decomposition of given polytype equality" $ - pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] - ; stopWith ev "Discard given polytype equality" } - - where - unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) - -- This version returns the wanted constraint rather - -- than putting it in the work list - unify loc role ty1 ty2 - | ty1 `tcEqType` ty2 - = return (mkTcReflCo role ty1, emptyBag) - | otherwise - = do { (wanted, co) <- newWantedEq loc role ty1 ty2 - ; return (co, unitBag (mkNonCanonical wanted)) } - ---------------------------------- --- | Compare types for equality, while zonking as necessary. Gives up --- as soon as it finds that two types are not equal. --- This is quite handy when some unification has made two --- types in an inert Wanted to be equal. We can discover the equality without --- flattening, which is sometimes very expensive (in the case of type functions). --- In particular, this function makes a ~20% improvement in test case --- perf/compiler/T5030. --- --- Returns either the (partially zonked) types in the case of --- inequality, or the one type in the case of equality. canEqReflexive is --- a good next step in the 'Right' case. Returning 'Left' is always safe. --- --- NB: This does *not* look through type synonyms. In fact, it treats type --- synonyms as rigid constructors. In the future, it might be convenient --- to look at only those arguments of type synonyms that actually appear --- in the synonym RHS. But we're not there yet. -zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) -zonk_eq_types = go - where - go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 - go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 - go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 - - -- We handle FunTys explicitly here despite the fact that they could also be - -- treated as an application. Why? Well, for one it's cheaper to just look - -- at two types (the argument and result types) than four (the argument, - -- result, and their RuntimeReps). Also, we haven't completely zonked yet, - -- so we may run into an unzonked type variable while trying to compute the - -- RuntimeReps of the argument and result types. This can be observed in - -- testcase tc269. - go ty1 ty2 - | Just (arg1, res1) <- split1 - , Just (arg2, res2) <- split2 - = do { res_a <- go arg1 arg2 - ; res_b <- go res1 res2 - ; return $ combine_rev mkVisFunTy res_b res_a - } - | isJust split1 || isJust split2 - = bale_out ty1 ty2 - where - split1 = tcSplitFunTy_maybe ty1 - split2 = tcSplitFunTy_maybe ty2 - - go ty1 ty2 - | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2 - = if tc1 == tc2 && tys1 `equalLength` tys2 - -- Crucial to check for equal-length args, because - -- we cannot assume that the two args to 'go' have - -- the same kind. E.g go (Proxy * (Maybe Int)) - -- (Proxy (*->*) Maybe) - -- We'll call (go (Maybe Int) Maybe) - -- See #13083 - then tycon tc1 tys1 tys2 - else bale_out ty1 ty2 - - go ty1 ty2 - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - = do { res_a <- go ty1a ty2a - ; res_b <- go ty1b ty2b - ; return $ combine_rev mkAppTy res_b res_a } - - go ty1@(LitTy lit1) (LitTy lit2) - | lit1 == lit2 - = return (Right ty1) - - go ty1 ty2 = bale_out ty1 ty2 - -- We don't handle more complex forms here - - bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) - - tyvar :: SwapFlag -> TcTyVar -> TcType - -> TcS (Either (Pair TcType) TcType) - -- Try to do as little as possible, as anything we do here is redundant - -- with flattening. In particular, no need to zonk kinds. That's why - -- we don't use the already-defined zonking functions - tyvar swapped tv ty - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> give_up - Indirect ty' -> do { trace_indirect tv ty' - ; unSwap swapped go ty' ty } } - _ -> give_up - where - give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty - - tyvar_tyvar tv1 tv2 - | tv1 == tv2 = return (Right (mkTyVarTy tv1)) - | otherwise = do { (ty1', progress1) <- quick_zonk tv1 - ; (ty2', progress2) <- quick_zonk tv2 - ; if progress1 || progress2 - then go ty1' ty2' - else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } - - trace_indirect tv ty - = traceTcS "Following filled tyvar (zonk_eq_types)" - (ppr tv <+> equals <+> ppr ty) - - quick_zonk tv = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> return (TyVarTy tv, False) - Indirect ty' -> do { trace_indirect tv ty' - ; return (ty', True) } } - _ -> return (TyVarTy tv, False) - - -- This happens for type families, too. But recall that failure - -- here just means to try harder, so it's OK if the type function - -- isn't injective. - tycon :: TyCon -> [TcType] -> [TcType] - -> TcS (Either (Pair TcType) TcType) - tycon tc tys1 tys2 - = do { results <- zipWithM go tys1 tys2 - ; return $ case combine_results results of - Left tys -> Left (mkTyConApp tc <$> tys) - Right tys -> Right (mkTyConApp tc tys) } - - combine_results :: [Either (Pair TcType) TcType] - -> Either (Pair [TcType]) [TcType] - combine_results = bimap (fmap reverse) reverse . - foldl' (combine_rev (:)) (Right []) - - -- combine (in reverse) a new result onto an already-combined result - combine_rev :: (a -> b -> c) - -> Either (Pair b) b - -> Either (Pair a) a - -> Either (Pair c) c - combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) - combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) - combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) - combine_rev f (Right tys) (Right ty) = Right (f ty tys) - -{- See Note [Unwrap newtypes first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - newtype N m a = MkN (m a) -Then N will get a conservative, Nominal role for its second parameter 'a', -because it appears as an argument to the unknown 'm'. Now consider - [W] N Maybe a ~R# N Maybe b - -If we decompose, we'll get - [W] a ~N# b - -But if instead we unwrap we'll get - [W] Maybe a ~R# Maybe b -which in turn gives us - [W] a ~R# b -which is easier to satisfy. - -Bottom line: unwrap newtypes before decomposing them! -c.f. #9123 comment:52,53 for a compelling example. - -Note [Newtypes can blow the stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - newtype Y = MkY (Int -> Y) - -and now wish to prove - - [W] X ~R Y - -This Wanted will loop, expanding out the newtypes ever deeper looking -for a solid match or a solid discrepancy. Indeed, there is something -appropriate to this looping, because X and Y *do* have the same representation, -in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized -coercion will ever witness it. This loop won't actually cause GHC to hang, -though, because we check our depth when unwrapping newtypes. - -Note [Eager reflexivity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - -and - - [W] X ~R X - -Naively, we would start unwrapping X and end up in a loop. Instead, -we do this eager reflexivity check. This is necessary only for representational -equality because the flattener technology deals with the similar case -(recursive type families) for nominal equality. - -Note that this check does not catch all cases, but it will catch the cases -we're most worried about, types like X above that are actually inhabited. - -Here's another place where this reflexivity check is key: -Consider trying to prove (f a) ~R (f a). The AppTys in there can't -be decomposed, because representational equality isn't congruent with respect -to AppTy. So, when canonicalising the equality above, we get stuck and -would normally produce a CIrredCan. However, we really do want to -be able to solve (f a) ~R (f a). So, in the representational case only, -we do a reflexivity check. - -(This would be sound in the nominal case, but unnecessary, and I [Richard -E.] am worried that it would slow down the common case.) --} - ------------------------- --- | We're able to unwrap a newtype. Update the bits accordingly. -can_eq_newtype_nc :: CtEvidence -- ^ :: ty1 ~ ty2 - -> SwapFlag - -> TcType -- ^ ty1 - -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' - -> TcType -- ^ ty2 - -> TcType -- ^ ty2, with type synonyms - -> TcS (StopOrContinue Ct) -can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2 - = do { traceTcS "can_eq_newtype_nc" $ - vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ] - - -- check for blowing our stack: - -- See Note [Newtypes can blow the stack] - ; checkReductionDepth (ctEvLoc ev) ty1 - - -- Next, we record uses of newtype constructors, since coercing - -- through newtypes is tantamount to using their constructors. - ; addUsedGREs gre_list - -- If a newtype constructor was imported, don't warn about not - -- importing it... - ; traverse_ keepAlive $ map gre_name gre_list - -- ...and similarly, if a newtype constructor was defined in the same - -- module, don't warn about it being unused. - -- See Note [Tracking unused binding and imports] in TcRnTypes. - - ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2 - (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) - ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } - where - gre_list = bagToList gres - ---------- --- ^ Decompose a type application. --- All input types must be flat. See Note [Canonicalising type applications] --- Nominal equality only! -can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 - -> Xi -> Xi -- s1 t1 - -> Xi -> Xi -- s2 t2 - -> TcS (StopOrContinue Ct) - --- AppTys only decompose for nominal equality, so this case just leads --- to an irreducible constraint; see typecheck/should_compile/T10494 --- See Note [Decomposing equality], note {4} -can_eq_app ev s1 t1 s2 t2 - | CtDerived {} <- ev - = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] - ; stopWith ev "Decomposed [D] AppTy" } - | CtWanted { ctev_dest = dest } <- ev - = do { co_s <- unifyWanted loc Nominal s1 s2 - ; let arg_loc - | isNextArgVisible s1 = loc - | otherwise = updateCtLocOrigin loc toInvisibleOrigin - ; co_t <- unifyWanted arg_loc Nominal t1 t2 - ; let co = mkAppCo co_s co_t - ; setWantedEq dest co - ; stopWith ev "Decomposed [W] AppTy" } - - -- If there is a ForAll/(->) mismatch, the use of the Left coercion - -- below is ill-typed, potentially leading to a panic in splitTyConApp - -- Test case: typecheck/should_run/Typeable1 - -- We could also include this mismatch check above (for W and D), but it's slow - -- and we'll get a better error message not doing it - | s1k `mismatches` s2k - = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) - - | CtGiven { ctev_evar = evar } <- ev - = do { let co = mkTcCoVarCo evar - co_s = mkTcLRCo CLeft co - co_t = mkTcLRCo CRight co - ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 - , evCoercion co_s ) - ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 - , evCoercion co_t ) - ; emitWorkNC [evar_t] - ; canEqNC evar_s NomEq s1 s2 } - - where - loc = ctEvLoc ev - - s1k = tcTypeKind s1 - s2k = tcTypeKind s2 - - k1 `mismatches` k2 - = isForAllTy k1 && not (isForAllTy k2) - || not (isForAllTy k1) && isForAllTy k2 - ------------------------ --- | Break apart an equality over a casted type --- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) -canEqCast :: Bool -- are both types flat? - -> CtEvidence - -> EqRel - -> SwapFlag - -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 - -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty - -> TcS (StopOrContinue Ct) -canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2 - = do { traceTcS "Decomposing cast" (vcat [ ppr ev - , ppr ty1 <+> text "|>" <+> ppr co1 - , ppr ps_ty2 ]) - ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2 - (mkTcGReflRightCo role ty1 co1) - (mkTcReflCo role ps_ty2) - ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 } - where - role = eqRelRole eq_rel - ------------------------- -canTyConApp :: CtEvidence -> EqRel - -> TyCon -> [TcType] - -> TyCon -> [TcType] - -> TcS (StopOrContinue Ct) --- See Note [Decomposing TyConApps] -canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - | tc1 == tc2 - , tys1 `equalLength` tys2 - = do { inerts <- getTcSInerts - ; if can_decompose inerts - then do { traceTcS "canTyConApp" - (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2) - ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 - ; stopWith ev "Decomposed TyConApp" } - else canEqFailure ev eq_rel ty1 ty2 } - - -- See Note [Skolem abstract data] (at tyConSkolem) - | tyConSkolem tc1 || tyConSkolem tc2 - = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) - ; continueWith (mkIrredCt ev) } - - -- Fail straight away for better error messages - -- See Note [Use canEqFailure in canDecomposableTyConApp] - | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational && - isGenerativeTyCon tc2 Representational) - = canEqFailure ev eq_rel ty1 ty2 - | otherwise - = canEqHardFailure ev ty1 ty2 - where - ty1 = mkTyConApp tc1 tys1 - ty2 = mkTyConApp tc2 tys2 - - loc = ctEvLoc ev - pred = ctEvPred ev - - -- See Note [Decomposing equality] - can_decompose inerts - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts)) - -{- -Note [Use canEqFailure in canDecomposableTyConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must use canEqFailure, not canEqHardFailure here, because there is -the possibility of success if working with a representational equality. -Here is one case: - - type family TF a where TF Char = Bool - data family DF a - newtype instance DF Bool = MkDF Int - -Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet -know `a`. This is *not* a hard failure, because we might soon learn -that `a` is, in fact, Char, and then the equality succeeds. - -Here is another case: - - [G] Age ~R Int - -where Age's constructor is not in scope. We don't want to report -an "inaccessible code" error in the context of this Given! - -For example, see typecheck/should_compile/T10493, repeated here: - - import Data.Ord (Down) -- no constructor - - foo :: Coercible (Down Int) Int => Down Int -> Int - foo = coerce - -That should compile, but only because we use canEqFailure and not -canEqHardFailure. - -Note [Decomposing equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a constraint (of any flavour and role) that looks like -T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer, -of course, is "it depends". This Note spells it all out. - -In this Note, "decomposition" refers to taking the constraint - [fl] (T tys1 ~X T tys2) -(for some flavour fl and some role X) and replacing it with - [fls'] (tys1 ~Xs' tys2) -where that notation indicates a list of new constraints, where the -new constraints may have different flavours and different roles. - -The key property to consider is injectivity. When decomposing a Given the -decomposition is sound if and only if T is injective in all of its type -arguments. When decomposing a Wanted, the decomposition is sound (assuming the -correct roles in the produced equality constraints), but it may be a guess -- -that is, an unforced decision by the constraint solver. Decomposing Wanteds -over injective TyCons does not entail guessing. But sometimes we want to -decompose a Wanted even when the TyCon involved is not injective! (See below.) - -So, in broad strokes, we want this rule: - -(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective -at role X. - -Pursuing the details requires exploring three axes: -* Flavour: Given vs. Derived vs. Wanted -* Role: Nominal vs. Representational -* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable - -(So a type variable isn't a TyCon, but it's convenient to put the AppTy case -in the same table.) - -Right away, we can say that Derived behaves just as Wanted for the purposes -of decomposition. The difference between Derived and Wanted is the handling of -evidence. Since decomposition in these cases isn't a matter of soundness but of -guessing, we want the same behavior regardless of evidence. - -Here is a table (discussion following) detailing where decomposition of - (T s1 ... sn) ~r (T t1 .. tn) -is allowed. The first four lines (Data types ... type family) refer -to TyConApps with various TyCons T; the last line is for AppTy, where -there is presumably a type variable at the head, so it's actually - (s s1 ... sn) ~r (t t1 .. tn) - -NOMINAL GIVEN WANTED - -Datatype YES YES -Newtype YES YES -Data family YES YES -Type family YES, in injective args{1} YES, in injective args{1} -Type variable YES YES - -REPRESENTATIONAL GIVEN WANTED - -Datatype YES YES -Newtype NO{2} MAYBE{2} -Data family NO{3} MAYBE{3} -Type family NO NO -Type variable NO{4} NO{4} - -{1}: Type families can be injective in some, but not all, of their arguments, -so we want to do partial decomposition. This is quite different than the way -other decomposition is done, where the decomposed equalities replace the original -one. We thus proceed much like we do with superclasses: emitting new Givens -when "decomposing" a partially-injective type family Given and new Deriveds -when "decomposing" a partially-injective type family Wanted. (As of the time of -writing, 13 June 2015, the implementation of injective type families has not -been merged, but it should be soon. Please delete this parenthetical if the -implementation is indeed merged.) - -{2}: See Note [Decomposing newtypes at representational role] - -{3}: Because of the possibility of newtype instances, we must treat -data families like newtypes. See also Note [Decomposing newtypes at -representational role]. See #10534 and test case -typecheck/should_fail/T10534. - -{4}: Because type variables can stand in for newtypes, we conservatively do not -decompose AppTys over representational equality. - -In the implementation of can_eq_nc and friends, we don't directly pattern -match using lines like in the tables above, as those tables don't cover -all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, -boiling the tables above down to rule (*). The exceptions to rule (*) are for -injective type families, which are handled separately from other decompositions, -and the MAYBE entries above. - -Note [Decomposing newtypes at representational role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note discusses the 'newtype' line in the REPRESENTATIONAL table -in Note [Decomposing equality]. (At nominal role, newtypes are fully -decomposable.) - -Here is a representative example of why representational equality over -newtypes is tricky: - - newtype Nt a = Mk Bool -- NB: a is not used in the RHS, - type role Nt representational -- but the user gives it an R role anyway - -If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to -[W] alpha ~R beta, because it's possible that alpha and beta aren't -representationally equal. Here's another example. - - newtype Nt a = MkNt (Id a) - type family Id a where Id a = a - - [W] Nt Int ~R Nt Age - -Because of its use of a type family, Nt's parameter will get inferred to have -a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which -is unsatisfiable. Unwrapping, though, leads to a solution. - -Conclusion: - * Unwrap newtypes before attempting to decompose them. - This is done in can_eq_nc'. - -It all comes from the fact that newtypes aren't necessarily injective -w.r.t. representational equality. - -Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use -NthCo on representational coercions over newtypes. NthCo comes into play -only when decomposing givens. - -Conclusion: - * Do not decompose [G] N s ~R N t - -Is it sensible to decompose *Wanted* constraints over newtypes? Yes! -It's the only way we could ever prove (IO Int ~R IO Age), recalling -that IO is a newtype. - -However we must be careful. Consider - - type role Nt representational - - [G] Nt a ~R Nt b (1) - [W] NT alpha ~R Nt b (2) - [W] alpha ~ a (3) - -If we focus on (3) first, we'll substitute in (2), and now it's -identical to the given (1), so we succeed. But if we focus on (2) -first, and decompose it, we'll get (alpha ~R b), which is not soluble. -This is exactly like the question of overlapping Givens for class -constraints: see Note [Instance and Given overlap] in TcInteract. - -Conclusion: - * Decompose [W] N s ~R N t iff there no given constraint that could - later solve it. - --} - -canDecomposableTyConAppOK :: CtEvidence -> EqRel - -> TyCon -> [TcType] -> [TcType] - -> TcS () --- Precondition: tys1 and tys2 are the same length, hence "OK" -canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 - = ASSERT( tys1 `equalLength` tys2 ) - case ev of - CtDerived {} - -> unifyDeriveds loc tc_roles tys1 tys2 - - CtWanted { ctev_dest = dest } - -- new_locs and tc_roles are both infinite, so - -- we are guaranteed that cos has the same length - -- as tys1 and tys2 - -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2 - ; setWantedEq dest (mkTyConAppCo role tc cos) } - - CtGiven { ctev_evar = evar } - -> do { let ev_co = mkCoVarCo evar - ; given_evs <- newGivenEvVars loc $ - [ ( mkPrimEqPredRole r ty1 ty2 - , evCoercion $ mkNthCo r i ev_co ) - | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom - , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] - ; emitWorkNC given_evs } - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - - -- infinite, as tyConRolesX returns an infinite tail of Nominal - tc_roles = tyConRolesX role tc - - -- Add nuances to the location during decomposition: - -- * if the argument is a kind argument, remember this, so that error - -- messages say "kind", not "type". This is determined based on whether - -- the corresponding tyConBinder is named (that is, dependent) - -- * if the argument is invisible, note this as well, again by - -- looking at the corresponding binder - -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't - -- do either of these changes. (Forgetting to do so led to #16188) - -- - -- NB: infinite in length - new_locs = [ new_loc - | bndr <- tyConBinders tc - , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc - | otherwise = loc - new_loc | isVisibleTyConBinder bndr - = updateCtLocOrigin new_loc0 toInvisibleOrigin - | otherwise - = new_loc0 ] - ++ repeat loc - --- | Call when canonicalizing an equality fails, but if the equality is --- representational, there is some hope for the future. --- Examples in Note [Use canEqFailure in canDecomposableTyConApp] -canEqFailure :: CtEvidence -> EqRel - -> TcType -> TcType -> TcS (StopOrContinue Ct) -canEqFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqFailure ev ReprEq ty1 ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 - -- We must flatten the types before putting them in the - -- inert set, so that we are sure to kick them out when - -- new equalities become available - ; traceTcS "canEqFailure with ReprEq" $ - vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ] - ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - ; continueWith (mkIrredCt new_ev) } - --- | Call when canonicalizing an equality fails with utterly no hope. -canEqHardFailure :: CtEvidence - -> TcType -> TcType -> TcS (StopOrContinue Ct) --- See Note [Make sure that insolubles are fully rewritten] -canEqHardFailure ev ty1 ty2 - = do { (s1, co1) <- flatten FM_SubstOnly ev ty1 - ; (s2, co2) <- flatten FM_SubstOnly ev ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 - ; continueWith (mkInsolubleCt new_ev) } - -{- -Note [Decomposing TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (T s1 t1 ~ T s2 t2), then we can just decompose to - (s1 ~ s2, t1 ~ t2) -and push those back into the work list. But if - s1 = K k1 s2 = K k2 -then we will just decomopose s1~s2, and it might be better to -do so on the spot. An important special case is where s1=s2, -and we get just Refl. - -So canDecomposableTyCon is a fast-path decomposition that uses -unifyWanted etc to short-cut that work. - -Note [Canonicalising type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (s1 t1) ~ ty2, how should we proceed? -The simple things is to see if ty2 is of form (s2 t2), and -decompose. By this time s1 and s2 can't be saturated type -function applications, because those have been dealt with -by an earlier equation in can_eq_nc, so it is always sound to -decompose. - -However, over-eager decomposition gives bad error messages -for things like - a b ~ Maybe c - e f ~ p -> q -Suppose (in the first example) we already know a~Array. Then if we -decompose the application eagerly, yielding - a ~ Maybe - b ~ c -we get an error "Can't match Array ~ Maybe", -but we'd prefer to get "Can't match Array b ~ Maybe c". - -So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of -replacing (a b) by (Array b), before using try_decompose_app to -decompose it. - -Note [Make sure that insolubles are fully rewritten] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When an equality fails, we still want to rewrite the equality -all the way down, so that it accurately reflects - (a) the mutable reference substitution in force at start of solving - (b) any ty-binds in force at this point in solving -See Note [Rewrite insolubles] in TcSMonad. -And if we don't do this there is a bad danger that -TcSimplify.applyTyVarDefaulting will find a variable -that has in fact been substituted. - -Note [Do not decompose Given polytype equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? -No -- what would the evidence look like? So instead we simply discard -this given evidence. - - -Note [Combining insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As this point we have an insoluble constraint, like Int~Bool. - - * If it is Wanted, delete it from the cache, so that subsequent - Int~Bool constraints give rise to separate error messages - - * But if it is Derived, DO NOT delete from cache. A class constraint - may get kicked out of the inert set, and then have its functional - dependency Derived constraints generated a second time. In that - case we don't want to get two (or more) error messages by - generating two (or more) insoluble fundep constraints from the same - class constraint. - -Note [No top-level newtypes on RHS of representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we're in this situation: - - work item: [W] c1 : a ~R b - inert: [G] c2 : b ~R Id a - -where - newtype Id a = Id a - -We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened -and the Id newtype is unwrapped. This is assured by requiring only flat -types in canEqTyVar *and* having the newtype-unwrapping check above -the tyvar check in can_eq_nc. - -Note [Occurs check error] -~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an occurs check error, are we necessarily hosed? Say our -tyvar is tv1 and the type it appears in is xi2. Because xi2 is function -free, then if we're computing w.r.t. nominal equality, then, yes, we're -hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. -representational equality, this is a little subtler. Once again, (a ~R [a]) -is a bad thing, but (a ~R N a) for a newtype N might be just fine. This -means also that (a ~ b a) might be fine, because `b` might become a newtype. - -So, we must check: does tv1 appear in xi2 under any type constructor -that is generative w.r.t. representational equality? That's what -isInsolubleOccursCheck does. - -See also #10715, which induced this addition. - -Note [canCFunEqCan] -~~~~~~~~~~~~~~~~~~~ -Flattening the arguments to a type family can change the kind of the type -family application. As an easy example, consider (Any k) where (k ~ Type) -is in the inert set. The original (Any k :: k) becomes (Any Type :: Type). -The problem here is that the fsk in the CFunEqCan will have the old kind. - -The solution is to come up with a new fsk/fmv of the right kind. For -givens, this is easy: just introduce a new fsk and update the flat-cache -with the new one. For wanteds, we want to solve the old one if favor of -the new one, so we use dischargeFmv. This also kicks out constraints -from the inert set; this behavior is correct, as the kind-change may -allow more constraints to be solved. - -We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case -if we really need to. Of course `flattenArgsNom` should return `Refl` -whenever possible, but #15577 was an infinite loop because even -though the coercion was homo-kinded, `kind_co` was not `Refl`, so we -made a new (identical) CFunEqCan, and then the entire process repeated. --} - -canCFunEqCan :: CtEvidence - -> TyCon -> [TcType] -- LHS - -> TcTyVar -- RHS - -> TcS (StopOrContinue Ct) --- ^ Canonicalise a CFunEqCan. We know that --- the arg types are already flat, --- and the RHS is a fsk, which we must *not* substitute. --- So just substitute in the LHS -canCFunEqCan ev fn tys fsk - = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys - -- cos :: tys' ~ tys - - ; let lhs_co = mkTcTyConAppCo Nominal fn cos - -- :: F tys' ~ F tys - new_lhs = mkTyConApp fn tys' - - flav = ctEvFlavour ev - ; (ev', fsk') - <- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan] - then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs) - ; let fsk_ty = mkTyVarTy fsk - ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty - lhs_co (mkTcNomReflCo fsk_ty) - ; return (ev', fsk) } - else do { traceTcS "canCFunEqCan: non-refl" $ - vcat [ text "Kind co:" <+> ppr kind_co - , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk) - , text "LHS:" <+> hang (ppr (mkTyConApp fn tys)) - 2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys))) - , text "New LHS" <+> hang (ppr new_lhs) - 2 (dcolon <+> ppr (tcTypeKind new_lhs)) ] - ; (ev', new_co, new_fsk) - <- newFlattenSkolem flav (ctEvLoc ev) fn tys' - ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co - -- sym lhs_co :: F tys ~ F tys' - -- new_co :: F tys' ~ new_fsk - -- co :: F tys ~ (new_fsk |> kind_co) - co = mkTcSymCo lhs_co `mkTcTransCo` - mkTcCoherenceRightCo Nominal - (mkTyVarTy new_fsk) - kind_co - new_co - - ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev) - ; dischargeFunEq ev fsk co xi - ; return (ev', new_fsk) } - - ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev') - ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn - , cc_tyargs = tys', cc_fsk = fsk' }) } - ---------------------- -canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs - -> EqRel -> SwapFlag - -> TcTyVar -- tv1 - -> TcType -- lhs: pretty lhs, already flat - -> TcType -> TcType -- rhs: already flat - -> TcS (StopOrContinue Ct) -canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 - | k1 `tcEqType` k2 - = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 - - -- So the LHS and RHS don't have equal kinds - -- Note [Flattening] in TcFlatten gives us (F2), which says that - -- flattening is always homogeneous (doesn't change kinds). But - -- perhaps by flattening the kinds of the two sides of the equality - -- at hand makes them equal. So let's try that. - | otherwise - = do { (flat_k1, k1_co) <- flattenKind loc flav k1 -- k1_co :: flat_k1 ~N kind(xi1) - ; (flat_k2, k2_co) <- flattenKind loc flav k2 -- k2_co :: flat_k2 ~N kind(xi2) - ; traceTcS "canEqTyVar tried flattening kinds" - (vcat [ sep [ parens (ppr tv1 <+> dcolon <+> ppr k1) - , text "~" - , parens (ppr xi2 <+> dcolon <+> ppr k2) ] - , ppr flat_k1 - , ppr k1_co - , ppr flat_k2 - , ppr k2_co ]) - - -- We know the LHS is a tyvar. So let's dump all the coercions on the RHS - -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and - -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence - -- (as an optimization, so that we don't have to flatten the kinds again) - -- and then emit a kind equality in canEqTyVarHetero. - -- See Note [Equalities with incompatible kinds] - - ; let role = eqRelRole eq_rel - ; if flat_k1 `tcEqType` flat_k2 - then do { let rhs_kind_co = mkTcSymCo k2_co `mkTcTransCo` k1_co - -- :: kind(xi2) ~N kind(xi1) - - new_rhs = xi2 `mkCastTy` rhs_kind_co - ps_rhs = ps_xi2 `mkCastTy` rhs_kind_co - rhs_co = mkTcGReflLeftCo role xi2 rhs_kind_co - - ; new_ev <- rewriteEqEvidence ev swapped xi1 new_rhs - (mkTcReflCo role xi1) rhs_co - -- NB: rewriteEqEvidence executes a swap, if any, so we're - -- NotSwapped now. - ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_xi1 new_rhs ps_rhs } - else - do { let sym_k1_co = mkTcSymCo k1_co -- :: kind(xi1) ~N flat_k1 - sym_k2_co = mkTcSymCo k2_co -- :: kind(xi2) ~N flat_k2 - - new_lhs = xi1 `mkCastTy` sym_k1_co -- :: flat_k1 - new_rhs = xi2 `mkCastTy` sym_k2_co -- :: flat_k2 - ps_rhs = ps_xi2 `mkCastTy` sym_k2_co - - lhs_co = mkTcGReflLeftCo role xi1 sym_k1_co - rhs_co = mkTcGReflLeftCo role xi2 sym_k2_co - -- lhs_co :: (xi1 |> sym k1_co) ~ xi1 - -- rhs_co :: (xi2 |> sym k2_co) ~ xi2 - - ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co - -- no longer swapped, due to rewriteEqEvidence - ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_xi1 - new_rhs flat_k2 ps_rhs } } - where - xi1 = mkTyVarTy tv1 - - k1 = tyVarKind tv1 - k2 = tcTypeKind xi2 - - loc = ctEvLoc ev - flav = ctEvFlavour ev - -canEqTyVarHetero :: CtEvidence -- :: (tv1 |> co1 :: ki1) ~ (xi2 :: ki2) - -> EqRel - -> TcTyVar -> TcCoercionN -> TcKind -- tv1 |> co1 :: ki1 - -> TcType -- pretty tv1 (*without* the coercion) - -> TcType -> TcKind -- xi2 :: ki2 - -> TcType -- pretty xi2 - -> TcS (StopOrContinue Ct) -canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2 - -- See Note [Equalities with incompatible kinds] - | CtGiven { ctev_evar = evar } <- ev - -- unswapped: tm :: (lhs :: ki1) ~ (rhs :: ki2) - -- swapped : tm :: (rhs :: ki2) ~ (lhs :: ki1) - = do { let kind_co = mkTcKindCo (mkTcCoVarCo evar) - ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) - ; let -- kind_ev :: (ki1 :: *) ~ (ki2 :: *) (whether swapped or not) - -- co1 :: kind(tv1) ~N ki1 - -- homo_co :: ki2 ~N kind(tv1) - homo_co = mkTcSymCo (ctEvCoercion kind_ev) `mkTcTransCo` mkTcSymCo co1 - rhs' = mkCastTy xi2 homo_co -- :: kind(tv1) - ps_rhs' = mkCastTy ps_xi2 homo_co -- :: kind(tv1) - rhs_co = mkTcGReflLeftCo role xi2 homo_co - -- rhs_co :: (xi2 |> homo_co :: kind(tv1)) ~ xi2 - - lhs' = mkTyVarTy tv1 -- :: kind(tv1) - lhs_co = mkTcGReflRightCo role lhs' co1 - -- lhs_co :: (tv1 :: kind(tv1)) ~ (tv1 |> co1 :: ki1) - - ; traceTcS "Hetero equality gives rise to given kind equality" - (ppr kind_ev <+> dcolon <+> ppr kind_pty) - ; emitWorkNC [kind_ev] - ; type_ev <- rewriteEqEvidence ev NotSwapped lhs' rhs' lhs_co rhs_co - ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' } - - -- See Note [Equalities with incompatible kinds] - | otherwise -- Wanted and Derived - -- NB: all kind equalities are Nominal - = do { emitNewDerivedEq kind_loc Nominal ki1 ki2 - -- kind_ev :: (ki1 :: *) ~ (ki2 :: *) - ; traceTcS "Hetero equality gives rise to derived kind equality" $ - ppr ev - ; continueWith (mkIrredCt ev) } - - where - kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2 - kind_loc = mkKindLoc (mkTyVarTy tv1 `mkCastTy` co1) xi2 loc - - loc = ctev_loc ev - role = eqRelRole eq_rel - --- guaranteed that tcTypeKind lhs == tcTypeKind rhs -canEqTyVarHomo :: CtEvidence - -> EqRel -> SwapFlag - -> TcTyVar -- lhs: tv1 - -> TcType -- pretty lhs, flat - -> TcType -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) -canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _ - | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2 - , tv1 == tv2 - = canEqReflexive ev eq_rel (mkTyVarTy tv1) - -- we don't need to check co because it must be reflexive - - | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2 - , swapOverTyVars tv1 tv2 - = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten - -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True } - -- Flatten the RHS less vigorously, to avoid gratuitous flattening - -- True <=> xi2 should not itself be a type-function application - - ; let role = eqRelRole eq_rel - sym_co2 = mkTcSymCo co2 - ty1 = mkTyVarTy tv1 - new_lhs = ty1 `mkCastTy` sym_co2 - lhs_co = mkTcGReflLeftCo role ty1 sym_co2 - - new_rhs = mkTyVarTy tv2 - rhs_co = mkTcGReflRightCo role new_rhs co2 - - ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co - - ; dflags <- getDynFlags - ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) } - -canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2 - = do { dflags <- getDynFlags - ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 } - --- The RHS here is either not a casted tyvar, or it's a tyvar but we want --- to rewrite the LHS to the RHS (as per swapOverTyVars) -canEqTyVar2 :: DynFlags - -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs) - -> EqRel - -> SwapFlag - -> TcTyVar -- lhs = tv, flat - -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) --- LHS is an inert type variable, --- and RHS is fully rewritten, but with type synonyms --- preserved as much as possible -canEqTyVar2 dflags ev eq_rel swapped tv1 rhs - | Just rhs' <- metaTyVarUpdateOK dflags tv1 rhs -- No occurs check - -- Must do the occurs check even on tyvar/tyvar - -- equalities, in case have x ~ (y :: ..x...) - -- #12593 - = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2 - ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1 - , cc_rhs = rhs', cc_eq_rel = eq_rel }) } - - | otherwise -- For some reason (occurs check, or forall) we can't unify - -- We must not use it for further rewriting! - = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs) - ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2 - ; if isInsolubleOccursCheck eq_rel tv1 rhs - then continueWith (mkInsolubleCt new_ev) - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - - else continueWith (mkIrredCt new_ev) } - -- A representational equality with an occurs-check problem isn't - -- insoluble! For example: - -- a ~R b a - -- We might learn that b is the newtype Id. - -- But, the occurs-check certainly prevents the equality from being - -- canonical, and we might loop if we were to use it in rewriting. - where - role = eqRelRole eq_rel - - lhs = mkTyVarTy tv1 - - rewrite_co1 = mkTcReflCo role lhs - rewrite_co2 = mkTcReflCo role rhs - --- | Solve a reflexive equality constraint -canEqReflexive :: CtEvidence -- ty ~ ty - -> EqRel - -> TcType -- ty - -> TcS (StopOrContinue Ct) -- always Stop -canEqReflexive ev eq_rel ty - = do { setEvBindIfWanted ev (evCoercion $ - mkTcReflCo (eqRelRole eq_rel) ty) - ; stopWith ev "Solved by reflexivity" } - -{- -Note [Canonical orientation for tyvar/tyvar equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have a ~ b where both 'a' and 'b' are TcTyVars, which way -round should be oriented in the CTyEqCan? The rules, implemented by -canEqTyVarTyVar, are these - - * If either is a flatten-meta-variables, it goes on the left. - - * Put a meta-tyvar on the left if possible - alpha[3] ~ r - - * If both are meta-tyvars, put the more touchable one (deepest level - number) on the left, so there is the best chance of unifying it - alpha[3] ~ beta[2] - - * If both are meta-tyvars and both at the same level, put a TyVarTv - on the right if possible - alpha[2] ~ beta[2](sig-tv) - That way, when we unify alpha := beta, we don't lose the TyVarTv flag. - - * Put a meta-tv with a System Name on the left if possible so it - gets eliminated (improves error messages) - - * If one is a flatten-skolem, put it on the left so that it is - substituted out Note [Eliminate flat-skols] in TcUinfy - fsk ~ a - -Note [Equalities with incompatible kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What do we do when we have an equality - - (tv :: k1) ~ (rhs :: k2) - -where k1 and k2 differ? This Note explores this treacherous area. - -We must proceed differently here depending on whether we have a Wanted -or a Given. Consider this: - - [W] w :: (alpha :: k) ~ (Int :: Type) - -where k is a skolem. One possible way forward is this: - - [W] co :: k ~ Type - [W] w :: (alpha :: k) ~ (Int |> sym co :: k) - -The next step will be to unify - - alpha := Int |> sym co - -Now, consider what error we'll report if we can't solve the "co" -wanted. Its CtOrigin is the w wanted... which now reads (after zonking) -Int ~ Int. The user thus sees that GHC can't solve Int ~ Int, which -is embarrassing. See #11198 for more tales of destruction. - -The reason for this odd behavior is much the same as -Note [Wanteds do not rewrite Wanteds] in Constraint: note that the -new `co` is a Wanted. - -The solution is then not to use `co` to "rewrite" -- that is, cast -- `w`, but -instead to keep `w` heterogeneous and irreducible. Given that we're not using -`co`, there is no reason to collect evidence for it, so `co` is born a -Derived, with a CtOrigin of KindEqOrigin. When the Derived is solved (by -unification), the original wanted (`w`) will get kicked out. We thus get - -[D] _ :: k ~ Type -[W] w :: (alpha :: k) ~ (Int :: Type) - -Note that the Wanted is unchanged and will be irreducible. This all happens -in canEqTyVarHetero. - -Note that, if we had [G] co1 :: k ~ Type available, then we never get -to canEqTyVarHetero: canEqTyVar tries flattening the kinds first. If -we have [G] co1 :: k ~ Type, then flattening the kind of alpha would -rewrite k to Type, and we would end up in canEqTyVarHomo. - -Successive canonicalizations of the same Wanted may produce -duplicate Deriveds. Similar duplications can happen with fundeps, and there -seems to be no easy way to avoid. I expect this case to be rare. - -For Givens, this problem (the Wanteds-rewriting-Wanteds action of -a kind coercion) doesn't bite, so a heterogeneous Given gives -rise to a Given kind equality. No Deriveds here. We thus homogenise -the Given (see the "homo_co" in the Given case in canEqTyVarHetero) and -carry on with a homogeneous equality constraint. - -Note [Type synonyms and canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat type synonym applications as xi types, that is, they do not -count as type function applications. However, we do need to be a bit -careful with type synonyms: like type functions they may not be -generative or injective. However, unlike type functions, they are -parametric, so there is no problem in expanding them whenever we see -them, since we do not need to know anything about their arguments in -order to expand them; this is what justifies not having to treat them -as specially as type function applications. The thing that causes -some subtleties is that we prefer to leave type synonym applications -*unexpanded* whenever possible, in order to generate better error -messages. - -If we encounter an equality constraint with type synonym applications -on both sides, or a type synonym application on one side and some sort -of type application on the other, we simply must expand out the type -synonyms in order to continue decomposing the equality constraint into -primitive equality constraints. For example, suppose we have - - type F a = [Int] - -and we encounter the equality - - F a ~ [b] - -In order to continue we must expand F a into [Int], giving us the -equality - - [Int] ~ [b] - -which we can then decompose into the more primitive equality -constraint - - Int ~ b. - -However, if we encounter an equality constraint with a type synonym -application on one side and a variable on the other side, we should -NOT (necessarily) expand the type synonym, since for the purpose of -good error messages we want to leave type synonyms unexpanded as much -as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar. - --} - -{- -************************************************************************ -* * - Evidence transformation -* * -************************************************************************ --} - -data StopOrContinue a - = ContinueWith a -- The constraint was not solved, although it may have - -- been rewritten - - | Stop CtEvidence -- The (rewritten) constraint was solved - SDoc -- Tells how it was solved - -- Any new sub-goals have been put on the work list - deriving (Functor) - -instance Outputable a => Outputable (StopOrContinue a) where - ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev - ppr (ContinueWith w) = text "ContinueWith" <+> ppr w - -continueWith :: a -> TcS (StopOrContinue a) -continueWith = return . ContinueWith - -stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) -stopWith ev s = return (Stop ev (text s)) - -andWhenContinue :: TcS (StopOrContinue a) - -> (a -> TcS (StopOrContinue b)) - -> TcS (StopOrContinue b) -andWhenContinue tcs1 tcs2 - = do { r <- tcs1 - ; case r of - Stop ev s -> return (Stop ev s) - ContinueWith ct -> tcs2 ct } -infixr 0 `andWhenContinue` -- allow chaining with ($) - -rewriteEvidence :: CtEvidence -- old evidence - -> TcPredType -- new predicate - -> TcCoercion -- Of type :: new predicate ~ - -> TcS (StopOrContinue CtEvidence) --- Returns Just new_ev iff either (i) 'co' is reflexivity --- or (ii) 'co' is not reflexivity, and 'new_pred' not cached --- In either case, there is nothing new to do with new_ev -{- - rewriteEvidence old_ev new_pred co -Main purpose: create new evidence for new_pred; - unless new_pred is cached already -* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev -* If old_ev was wanted, create a binding for old_ev, in terms of new_ev -* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev -* Returns Nothing if new_ev is already cached - - Old evidence New predicate is Return new evidence - flavour of same flavor - ------------------------------------------------------------------- - Wanted Already solved or in inert Nothing - or Derived Not Just new_evidence - - Given Already in inert Nothing - Not Just new_evidence - -Note [Rewriting with Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the coercion is just reflexivity then you may re-use the same -variable. But be careful! Although the coercion is Refl, new_pred -may reflect the result of unification alpha := ty, so new_pred might -not _look_ the same as old_pred, and it's vital to proceed from now on -using new_pred. - -qThe flattener preserves type synonyms, so they should appear in new_pred -as well as in old_pred; that is important for good error messages. - -} - - -rewriteEvidence old_ev@(CtDerived {}) new_pred _co - = -- If derived, don't even look at the coercion. - -- This is very important, DO NOT re-order the equations for - -- rewriteEvidence to put the isTcReflCo test first! - -- Why? Because for *Derived* constraints, c, the coercion, which - -- was produced by flattening, may contain suspended calls to - -- (ctEvExpr c), which fails for Derived constraints. - -- (Getting this wrong caused #7384.) - continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence old_ev new_pred co - | isTcReflCo co -- See Note [Rewriting with Refl] - = continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co - = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) - ; continueWith new_ev } - where - -- mkEvCast optimises ReflCo - new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational - (ctEvRole ev) - (mkTcSymCo co)) - -rewriteEvidence ev@(CtWanted { ctev_dest = dest - , ctev_nosh = si - , ctev_loc = loc }) new_pred co - = do { mb_new_ev <- newWanted_SI si loc new_pred - -- The "_SI" varant ensures that we make a new Wanted - -- with the same shadow-info as the existing one - -- with the same shadow-info as the existing one (#16735) - ; MASSERT( tcCoercionRole co == ctEvRole ev ) - ; setWantedEvTerm dest - (mkEvCast (getEvExpr mb_new_ev) - (tcDowngradeRole Representational (ctEvRole ev) co)) - ; case mb_new_ev of - Fresh new_ev -> continueWith new_ev - Cached _ -> stopWith ev "Cached wanted" } - - -rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) - -- or orhs ~ olhs (swapped) - -> SwapFlag - -> TcType -> TcType -- New predicate nlhs ~ nrhs - -- Should be zonked, because we use tcTypeKind on nlhs/nrhs - -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs - -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs - -> TcS CtEvidence -- Of type nlhs ~ nrhs --- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) --- we generate --- If not swapped --- g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co --- If 'swapped' --- g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co --- --- For (Wanted w) we do the dual thing. --- New w1 : nlhs ~ nrhs --- If not swapped --- w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co --- If swapped --- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co --- --- It's all a form of rewwriteEvidence, specialised for equalities -rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co - | CtDerived {} <- old_ev -- Don't force the evidence for a Derived - = return (old_ev { ctev_pred = new_pred }) - - | NotSwapped <- swapped - , isTcReflCo lhs_co -- See Note [Rewriting with Refl] - , isTcReflCo rhs_co - = return (old_ev { ctev_pred = new_pred }) - - | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = evCoercion (lhs_co - `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) - `mkTcTransCo` mkTcSymCo rhs_co) - ; newGivenEvVar loc' (new_pred, new_tm) } - - | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev - = do { (new_ev, hole_co) <- newWantedEq_SI si loc' (ctEvRole old_ev) nlhs nrhs - -- The "_SI" varant ensures that we make a new Wanted - -- with the same shadow-info as the existing one (#16735) - ; let co = maybeSym swapped $ - mkSymCo lhs_co - `mkTransCo` hole_co - `mkTransCo` rhs_co - ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) - ; return new_ev } - - | otherwise - = panic "rewriteEvidence" - where - new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs - - -- equality is like a type class. Bumping the depth is necessary because - -- of recursive newtypes, where "reducing" a newtype can actually make - -- it bigger. See Note [Newtypes can blow the stack]. - loc = ctEvLoc old_ev - loc' = bumpCtLocDepth loc - -{- Note [unifyWanted and unifyDerived] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When decomposing equalities we often create new wanted constraints for -(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. -Similar remarks apply for Derived. - -Rather than making an equality test (which traverses the structure of the -type, perhaps fruitlessly), unifyWanted traverses the common structure, and -bales out when it finds a difference by creating a new Wanted constraint. -But where it succeeds in finding common structure, it just builds a coercion -to reflect it. --} - -unifyWanted :: CtLoc -> Role - -> TcType -> TcType -> TcS Coercion --- Return coercion witnessing the equality of the two types, --- emitting new work equalities where necessary to achieve that --- Very good short-cut when the two types are equal, or nearly so --- See Note [unifyWanted and unifyDerived] --- The returned coercion's role matches the input parameter -unifyWanted loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) - ; return (mkPhantomCo kind_co ty1 ty2) } - -unifyWanted loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ s1 t1) (FunTy _ s2 t2) - = do { co_s <- unifyWanted loc role s1 s2 - ; co_t <- unifyWanted loc role t1 t2 - ; return (mkFunCo role co_s co_t) } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality - = do { cos <- zipWith3M (unifyWanted loc) - (tyConRolesX role tc1) tys1 tys2 - ; return (mkTyConAppCo role tc1 cos) } - - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2} - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - - go ty1@(CoercionTy {}) (CoercionTy {}) - = return (mkReflCo role ty1) -- we just don't care about coercions! - - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 - -unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 - -unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 - -unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new Derived and put it in the work list --- Should do nothing if the two types are equal --- See Note [unifyWanted and unifyDerived] -unify_derived _ Phantom _ _ = return () -unify_derived loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ s1 t1) (FunTy _ s2 t2) - = do { unify_derived loc role s1 s2 - ; unify_derived loc role t1 t2 } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role - = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2 } - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return () - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 - -maybeSym :: SwapFlag -> TcCoercion -> TcCoercion -maybeSym IsSwapped co = mkTcSymCo co -maybeSym NotSwapped co = co diff --git a/typecheck/TcClassDcl.hs b/typecheck/TcClassDcl.hs deleted file mode 100644 --- a/typecheck/TcClassDcl.hs +++ /dev/null @@ -1,554 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Typechecking class declarations --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcClassDcl ( tcClassSigs, tcClassDecl2, - findMethodBind, instantiateMethod, - tcClassMinimalDef, - HsSigFun, mkHsSigFun, - tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr, - instDeclCtxt1, instDeclCtxt2, instDeclCtxt3, - tcATDefault - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcEnv -import TcSigs -import TcEvidence ( idHsWrapper ) -import TcBinds -import TcUnify -import TcHsType -import TcMType -import Type ( piResultTys ) -import Predicate -import TcOrigin -import TcType -import TcRnMonad -import DriverPhases (HscSource(..)) -import BuildTyCl( TcMethInfo ) -import Class -import Coercion ( pprCoAxiom ) -import DynFlags -import FamInst -import FamInstEnv -import Id -import Name -import NameEnv -import NameSet -import Var -import VarEnv -import Outputable -import SrcLoc -import TyCon -import Maybes -import BasicTypes -import Bag -import FastString -import BooleanFormula -import Util - -import Control.Monad -import Data.List ( mapAccumL, partition ) - -{- -Dictionary handling -~~~~~~~~~~~~~~~~~~~ -Every class implicitly declares a new data type, corresponding to dictionaries -of that class. So, for example: - - class (D a) => C a where - op1 :: a -> a - op2 :: forall b. Ord b => a -> b -> b - -would implicitly declare - - data CDict a = CDict (D a) - (a -> a) - (forall b. Ord b => a -> b -> b) - -(We could use a record decl, but that means changing more of the existing apparatus. -One step at at time!) - -For classes with just one superclass+method, we use a newtype decl instead: - - class C a where - op :: forallb. a -> b -> b - -generates - - newtype CDict a = CDict (forall b. a -> b -> b) - -Now DictTy in Type is just a form of type synomym: - DictTy c t = TyConTy CDict `AppTy` t - -Death to "ExpandingDicts". - - -************************************************************************ -* * - Type-checking the class op signatures -* * -************************************************************************ --} - -illegalHsigDefaultMethod :: Name -> SDoc -illegalHsigDefaultMethod n = - text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" - -tcClassSigs :: Name -- Name of the class - -> [LSig GhcRn] - -> LHsBinds GhcRn - -> TcM [TcMethInfo] -- Exactly one for each method -tcClassSigs clas sigs def_methods - = do { traceTc "tcClassSigs 1" (ppr clas) - - ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs - ; let gen_dm_env :: NameEnv (SrcSpan, Type) - gen_dm_env = mkNameEnv gen_dm_prs - - ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs - - ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] - ; sequence_ [ failWithTc (badMethodErr clas n) - | n <- dm_bind_names, not (n `elemNameSet` op_names) ] - -- Value binding for non class-method (ie no TypeSig) - - ; tcg_env <- getGblEnv - ; if tcg_src tcg_env == HsigFile - then - -- Error if we have value bindings - -- (Generic signatures without value bindings indicate - -- that a default of this form is expected to be - -- provided.) - when (not (null def_methods)) $ - failWithTc (illegalHsigDefaultMethod clas) - else - -- Error for each generic signature without value binding - sequence_ [ failWithTc (badGenericMethod clas n) - | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] - - ; traceTc "tcClassSigs 2" (ppr clas) - ; return op_info } - where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] - dm_bind_names :: [Name] -- These ones have a value binding in the class decl - dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - - skol_info = TyConSkol ClassFlavour clas - - tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) - -> TcM [TcMethInfo] - tc_sig gen_dm_env (op_names, op_hs_ty) - = do { traceTc "ClsSig 1" (ppr op_names) - ; op_ty <- tcClassSigType skol_info op_names op_hs_ty - -- Class tyvars already in scope - - ; traceTc "ClsSig 2" (ppr op_names) - ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } - where - f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) - | nm `elem` dm_bind_names = Just VanillaDM - | otherwise = Nothing - - tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty - ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } - -{- -************************************************************************ -* * - Class Declarations -* * -************************************************************************ --} - -tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration - -> TcM (LHsBinds GhcTcId) - -tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, - tcdMeths = default_binds})) - = recoverM (return emptyLHsBinds) $ - setSrcSpan (getLoc class_name) $ - do { clas <- tcLookupLocatedClass class_name - - -- We make a separate binding for each default method. - -- At one time I used a single AbsBinds for all of them, thus - -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } - -- But that desugars into - -- ds = \d -> (..., ..., ...) - -- dm1 = \d -> case ds d of (a,b,c) -> a - -- And since ds is big, it doesn't get inlined, so we don't get good - -- default methods. Better to make separate AbsBinds for each - ; let (tyvars, _, _, op_items) = classBigSig clas - prag_fn = mkPragEnv sigs default_binds - sig_fn = mkHsSigFun sigs - clas_tyvars = snd (tcSuperSkolTyVars tyvars) - pred = mkClassPred clas (mkTyVarTys clas_tyvars) - ; this_dict <- newEvVar pred - - ; let tc_item = tcDefMeth clas clas_tyvars this_dict - default_binds sig_fn prag_fn - ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ - mapM tc_item op_items - - ; return (unionManyBags dm_binds) } - -tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) - -tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn - -> HsSigFun -> TcPragEnv -> ClassOpItem - -> TcM (LHsBinds GhcTcId) --- Generate code for default methods --- This is incompatible with Hugs, which expects a polymorphic --- default method for every class op, regardless of whether or not --- the programmer supplied an explicit default decl for the class. --- (If necessary we can fix that, but we don't have a convenient Id to hand.) - -tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) - = do { -- No default method - mapM_ (addLocM (badDmPrag sel_id)) - (lookupPragEnv prag_fn (idName sel_id)) - ; return emptyBag } - -tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn - (sel_id, Just (dm_name, dm_spec)) - | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn - = do { -- First look up the default method; it should be there! - -- It can be the orinary default method - -- or the generic-default method. E.g of the latter - -- class C a where - -- op :: a -> a -> Bool - -- default op :: Eq a => a -> a -> Bool - -- op x y = x==y - -- The default method we generate is - -- $gm :: (C a, Eq a) => a -> a -> Bool - -- $gm x y = x==y - - global_dm_id <- tcLookupId dm_name - ; global_dm_id <- addInlinePrags global_dm_id prags - ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc - -- Base the local_dm_name on the selector name, because - -- type errors from tcInstanceMethodBody come from here - - ; spec_prags <- discardConstraints $ - tcSpecPrags global_dm_id prags - ; warnTc NoReason - (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) - - ; let hs_ty = hs_sig_fn sel_name - `orElse` pprPanic "tc_dm" (ppr sel_name) - -- We need the HsType so that we can bring the right - -- type variables into scope - -- - -- Eg. class C a where - -- op :: forall b. Eq b => a -> [b] -> a - -- gen_op :: a -> a - -- generic gen_op :: D a => a -> a - -- The "local_dm_ty" is precisely the type in the above - -- type signatures, ie with no "forall a. C a =>" prefix - - local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) - - lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - warn_redundant = case dm_spec of - GenericDM {} -> True - VanillaDM -> False - -- For GenericDM, warn if the user specifies a signature - -- with redundant constraints; but not for VanillaDM, where - -- the default method may well be 'error' or something - - ctxt = FunSigCtxt sel_name warn_redundant - - ; let local_dm_id = mkLocalId local_dm_name local_dm_ty - local_dm_sig = CompleteSig { sig_bndr = local_dm_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_ty) } - - ; (ev_binds, (tc_bind, _)) - <- checkConstraints skol_info tyvars [this_dict] $ - tcPolyCheck no_prag_fn local_dm_sig - (L bind_loc lm_bind) - - ; let export = ABE { abe_ext = noExtField - , abe_poly = global_dm_id - , abe_mono = local_dm_id - , abe_wrap = idHsWrapper - , abe_prags = IsDefaultMethod } - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = [this_dict] - , abs_exports = [export] - , abs_ev_binds = [ev_binds] - , abs_binds = tc_bind - , abs_sig = True } - - ; return (unitBag (L bind_loc full_bind)) } - - | otherwise = pprPanic "tcDefMeth" (ppr sel_id) - where - skol_info = TyConSkol ClassFlavour (getName clas) - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - ---------------- -tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef -tcClassMinimalDef _clas sigs op_info - = case findMinimalDef sigs of - Nothing -> return defMindef - Just mindef -> do - -- Warn if the given mindef does not imply the default one - -- That is, the given mindef should at least ensure that the - -- class ops without default methods are required, since we - -- have no way to fill them in otherwise - tcg_env <- getGblEnv - -- However, only do this test when it's not an hsig file, - -- since you can't write a default implementation. - when (tcg_src tcg_env /= HsigFile) $ - whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) - return mindef - where - -- By default require all methods without a default implementation - defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLoc (mkVar name) - | (name, _, Nothing) <- op_info ] - -instantiateMethod :: Class -> TcId -> [TcType] -> TcType --- Take a class operation, say --- op :: forall ab. C a => forall c. Ix c => (b,c) -> a --- Instantiate it at [ty1,ty2] --- Return the "local method type": --- forall c. Ix x => (ty2,c) -> ty1 -instantiateMethod clas sel_id inst_tys - = ASSERT( ok_first_pred ) local_meth_ty - where - rho_ty = piResultTys (idType sel_id) inst_tys - (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - ok_first_pred = case getClassPredTys_maybe first_pred of - Just (clas1, _tys) -> clas == clas1 - Nothing -> False - -- The first predicate should be of form (C a b) - -- where C is the class in question - - ---------------------------- -type HsSigFun = Name -> Maybe (LHsSigType GhcRn) - -mkHsSigFun :: [LSig GhcRn] -> HsSigFun -mkHsSigFun sigs = lookupNameEnv env - where - env = mkHsSigEnv get_classop_sig sigs - - get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) - get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) - get_classop_sig _ = Nothing - ---------------------------- -findMethodBind :: Name -- Selector - -> LHsBinds GhcRn -- A group of bindings - -> TcPragEnv - -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) - -- Returns the binding, the binding - -- site of the method binder, and any inline or - -- specialisation pragmas -findMethodBind sel_name binds prag_fn - = foldl' mplus Nothing (mapBag f binds) - where - prags = lookupPragEnv prag_fn sel_name - - f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) - | op_name == sel_name - = Just (bind, bndr_loc, prags) - f _other = Nothing - ---------------------------- -findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef -findMinimalDef = firstJusts . map toMinimalDef - where - toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) - toMinimalDef _ = Nothing - -{- -Note [Polymorphic methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Foo a where - op :: forall b. Ord b => a -> b -> b -> b - instance Foo c => Foo [c] where - op = e - -When typechecking the binding 'op = e', we'll have a meth_id for op -whose type is - op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b - -So tcPolyBinds must be capable of dealing with nested polytypes; -and so it is. See TcBinds.tcMonoBinds (with type-sig case). - -Note [Silly default-method bind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we pass the default method binding to the type checker, it must -look like op2 = e -not $dmop2 = e -otherwise the "$dm" stuff comes out error messages. But we want the -"$dm" to come out in the interface file. So we typecheck the former, -and wrap it in a let, thus - $dmop2 = let op2 = e in op2 -This makes the error messages right. - - -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc -tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, - text "declaration for", quotes (ppr (tcdName decl))] - -tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a -tcAddDeclCtxt decl thing_inside - = addErrCtxt (tcMkDeclCtxt decl) thing_inside - -badMethodErr :: Outputable a => a -> Name -> SDoc -badMethodErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have a method", quotes (ppr op)] - -badGenericMethod :: Outputable a => a -> Name -> SDoc -badGenericMethod clas op - = hsep [text "Class", quotes (ppr clas), - text "has a generic-default signature without a binding", quotes (ppr op)] - -{- -badGenericInstanceType :: LHsBinds Name -> SDoc -badGenericInstanceType binds - = vcat [text "Illegal type pattern in the generic bindings", - nest 2 (ppr binds)] - -missingGenericInstances :: [Name] -> SDoc -missingGenericInstances missing - = text "Missing type patterns for" <+> pprQuotedList missing - -dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc -dupGenericInsts tc_inst_infos - = vcat [text "More than one type pattern for a single generic type constructor:", - nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), - text "All the type patterns for a generic type constructor must be identical" - ] - where - ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) --} -badDmPrag :: TcId -> Sig GhcRn -> TcM () -badDmPrag sel_id prag - = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") - <+> quotes (ppr sel_id) - <+> text "lacks an accompanying binding") - -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc -warningMinimalDefIncomplete mindef - = vcat [ text "The MINIMAL pragma does not require:" - , nest 2 (pprBooleanFormulaNice mindef) - , text "but there is no default implementation." ] - -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc -instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - -instDeclCtxt2 :: Type -> SDoc -instDeclCtxt2 dfun_ty - = instDeclCtxt3 cls tys - where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty - -instDeclCtxt3 :: Class -> [Type] -> SDoc -instDeclCtxt3 cls cls_tys - = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - -tcATDefault :: SrcSpan - -> TCvSubst - -> NameSet - -> ClassATItem - -> TcM [FamInst] --- ^ Construct default instances for any associated types that --- aren't given a user definition --- Returns [] or singleton -tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) - -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats - = return [] - - -- No user instance, have defaults ==> instantiate them - -- Example: class C a where { type F a b :: *; type F a b = () } - -- instance C [x] - -- Then we want to generate the decl: type F [x] b = () - | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) - rhs' = substTyUnchecked subst' rhs_ty - tcv' = tyCoVarsOfTypesList pat_tys' - (tv', cv') = partition isTyVar tcv' - tvs' = scopedSort tv' - cvs' = scopedSort cv' - ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' - fam_tc pat_tys' rhs' - -- NB: no validity check. We check validity of default instances - -- in the class definition. Because type instance arguments cannot - -- be type family applications and cannot be polytypes, the - -- validity check is redundant. - - ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty - , pprCoAxiom axiom ]) - ; fam_inst <- newFamInst SynFamilyInst axiom - ; return [fam_inst] } - - -- No defaults ==> generate a warning - | otherwise -- defs = Nothing - = do { warnMissingAT (tyConName fam_tc) - ; return [] } - where - subst_tv subst tc_tv - | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv - = (subst, ty) - | otherwise - = (extendTvSubst subst tc_tv ty', ty') - where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) - -warnMissingAT :: Name -> TcM () -warnMissingAT name - = do { warn <- woptM Opt_WarnMissingMethods - ; traceTc "warn" (ppr name <+> ppr warn) - ; hsc_src <- fmap tcg_src getGblEnv - -- Warn only if -Wmissing-methods AND not a signature - ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile) - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name)) } diff --git a/typecheck/TcDefaults.hs b/typecheck/TcDefaults.hs deleted file mode 100644 --- a/typecheck/TcDefaults.hs +++ /dev/null @@ -1,110 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcDefaults]{Typechecking \tr{default} declarations} --} -{-# LANGUAGE TypeFamilies #-} - -module TcDefaults ( tcDefaults ) where - -import GhcPrelude - -import GHC.Hs -import Class -import TcRnMonad -import TcEnv -import TcHsType -import TcHsSyn -import TcSimplify -import TcValidity -import TcType -import PrelNames -import SrcLoc -import Outputable -import FastString -import qualified GHC.LanguageExtensions as LangExt - -tcDefaults :: [LDefaultDecl GhcRn] - -> TcM (Maybe [Type]) -- Defaulting types to heave - -- into Tc monad for later use - -- in Disambig. - -tcDefaults [] - = getDeclaredDefaultTys -- No default declaration, so get the - -- default types from the envt; - -- i.e. use the current ones - -- (the caller will put them back there) - -- It's important not to return defaultDefaultTys here (which - -- we used to do) because in a TH program, tcDefaults [] is called - -- repeatedly, once for each group of declarations between top-level - -- splices. We don't want to carefully set the default types in - -- one group, only for the next group to ignore them and install - -- defaultDefaultTys - -tcDefaults [L _ (DefaultDecl _ [])] - = return (Just []) -- Default declaration specifying no types - -tcDefaults [L locn (DefaultDecl _ mono_tys)] - = setSrcSpan locn $ - addErrCtxt defaultDeclCtxt $ - do { ovl_str <- xoptM LangExt.OverloadedStrings - ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules - ; num_class <- tcLookupClass numClassName - ; deflt_str <- if ovl_str - then mapM tcLookupClass [isStringClassName] - else return [] - ; deflt_interactive <- if ext_deflt - then mapM tcLookupClass interactiveClassNames - else return [] - ; let deflt_clss = num_class : deflt_str ++ deflt_interactive - - ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys - - ; return (Just tau_tys) } - -tcDefaults decls@(L locn (DefaultDecl _ _) : _) - = setSrcSpan locn $ - failWithTc (dupDefaultDeclErr decls) -tcDefaults (L _ (XDefaultDecl nec):_) = noExtCon nec - - -tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type -tc_default_ty deflt_clss hs_ty - = do { (ty, _kind) <- solveEqualities $ - tcLHsType hs_ty - ; ty <- zonkTcTypeToType ty -- establish Type invariants - ; checkValidType DefaultDeclCtxt ty - - -- Check that the type is an instance of at least one of the deflt_clss - ; oks <- mapM (check_instance ty) deflt_clss - ; checkTc (or oks) (badDefaultTy ty deflt_clss) - ; return ty } - -check_instance :: Type -> Class -> TcM Bool - -- Check that ty is an instance of cls - -- We only care about whether it worked or not; return a boolean -check_instance ty cls - = do { (_, success) <- discardErrs $ - askNoErrs $ - simplifyDefault [mkClassPred cls [ty]] - ; return success } - -defaultDeclCtxt :: SDoc -defaultDeclCtxt = text "When checking the types in a default declaration" - -dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc -dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) - = hang (text "Multiple default declarations") - 2 (vcat (map pp dup_things)) - where - pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr locn - pp (L _ (XDefaultDecl nec)) = noExtCon nec -dupDefaultDeclErr (L _ (XDefaultDecl nec) : _) = noExtCon nec -dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" - -badDefaultTy :: Type -> [Class] -> SDoc -badDefaultTy ty deflt_clss - = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) - 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/typecheck/TcDeriv.hs b/typecheck/TcDeriv.hs deleted file mode 100644 --- a/typecheck/TcDeriv.hs +++ /dev/null @@ -1,2298 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Handles @deriving@ clauses on @data@ declarations. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} - -module TcDeriv ( tcDeriving, DerivInfo(..) ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import DynFlags - -import TcRnMonad -import FamInst -import TcOrigin -import Predicate -import TcDerivInfer -import TcDerivUtils -import TcValidity( allDistinctTyVars ) -import TcClassDcl( instDeclCtxt3, tcATDefault ) -import TcEnv -import TcGenDeriv -- Deriv stuff -import TcValidity( checkValidInstHead ) -import InstEnv -import Inst -import FamInstEnv -import TcHsType -import TyCoRep -import TyCoPpr ( pprTyVars ) - -import RnNames( extendGlobalRdrEnvRn ) -import RnBinds -import RnEnv -import RnUtils ( bindLocalNamesFV ) -import RnSource ( addTcgDUs ) -import Avail - -import Unify( tcUnifyTy ) -import Class -import Type -import ErrUtils -import DataCon -import Maybes -import RdrName -import Name -import NameSet -import TyCon -import TcType -import Var -import VarEnv -import VarSet -import PrelNames -import SrcLoc -import Util -import Outputable -import FastString -import Bag -import FV (fvVarList, unionFV, mkFVs) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Data.List (partition, find) - -{- -************************************************************************ -* * - Overview -* * -************************************************************************ - -Overall plan -~~~~~~~~~~~~ -1. Convert the decls (i.e. data/newtype deriving clauses, - plus standalone deriving) to [EarlyDerivSpec] - -2. Infer the missing contexts for the InferTheta's - -3. Add the derived bindings, generating InstInfos --} - -data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin]) - | GivenTheta (DerivSpec ThetaType) - -- InferTheta ds => the context for the instance should be inferred - -- In this case ds_theta is the list of all the sets of - -- constraints needed, such as (Eq [a], Eq a), together with a - -- suitable CtLoc to get good error messages. - -- The inference process is to reduce this to a - -- simpler form (e.g. Eq a) - -- - -- GivenTheta ds => the exact context for the instance is supplied - -- by the programmer; it is ds_theta - -- See Note [Inferring the instance context] in TcDerivInfer - -splitEarlyDerivSpec :: [EarlyDerivSpec] - -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType]) -splitEarlyDerivSpec [] = ([],[]) -splitEarlyDerivSpec (InferTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) -splitEarlyDerivSpec (GivenTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) - -instance Outputable EarlyDerivSpec where - ppr (InferTheta spec) = ppr spec <+> text "(Infer)" - ppr (GivenTheta spec) = ppr spec <+> text "(Given)" - -{- -Note [Data decl contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) - -We will need an instance decl like: - - instance (Read a, RealFloat a) => Read (Complex a) where - ... - -The RealFloat in the context is because the read method for Complex is bound -to construct a Complex, and doing that requires that the argument type is -in RealFloat. - -But this ain't true for Show, Eq, Ord, etc, since they don't construct -a Complex; they only take them apart. - -Our approach: identify the offending classes, and add the data type -context to the instance decl. The "offending classes" are - - Read, Enum? - -FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that -pattern matching against a constructor from a data type with a context -gives rise to the constraints for that context -- or at least the thinned -version. So now all classes are "offending". - -Note [Newtype deriving] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - class C a b - instance C [a] Char - newtype T = T Char deriving( C [a] ) - -Notice the free 'a' in the deriving. We have to fill this out to - newtype T = T Char deriving( forall a. C [a] ) - -And then translate it to: - instance C [a] Char => C [a] T where ... - -Note [Unused constructors and deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3221. Consider - data T = T1 | T2 deriving( Show ) -Are T1 and T2 unused? Well, no: the deriving clause expands to mention -both of them. So we gather defs/uses from deriving just like anything else. - --} - --- | Stuff needed to process a datatype's `deriving` clauses -data DerivInfo = DerivInfo { di_rep_tc :: TyCon - -- ^ The data tycon for normal datatypes, - -- or the *representation* tycon for data families - , di_scoped_tvs :: ![(Name,TyVar)] - -- ^ Variables that scope over the deriving clause. - , di_clauses :: [LHsDerivingClause GhcRn] - , di_ctxt :: SDoc -- ^ error context - } - -{- - -************************************************************************ -* * -\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} -* * -************************************************************************ --} - -tcDeriving :: [DerivInfo] -- All `deriving` clauses - -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations - -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn) -tcDeriving deriv_infos deriv_decls - = recoverM (do { g <- getGblEnv - ; return (g, emptyBag, emptyValBindsOut)}) $ - do { -- Fish the "deriving"-related information out of the TcEnv - -- And make the necessary "equations". - early_specs <- makeDerivSpecs deriv_infos deriv_decls - ; traceTc "tcDeriving" (ppr early_specs) - - ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs - ; insts1 <- mapM genInst given_specs - ; insts2 <- mapM genInst infer_specs - - ; dflags <- getDynFlags - - ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) - ; loc <- getSrcSpanM - ; let (binds, famInsts) = genAuxBinds dflags loc - (unionManyBags deriv_stuff) - - ; let mk_inst_infos1 = map fstOf3 insts1 - ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs - - -- We must put all the derived type family instances (from both - -- infer_specs and given_specs) in the local instance environment - -- before proceeding, or else simplifyInstanceContexts might - -- get stuck if it has to reason about any of those family instances. - -- See Note [Staging of tcDeriving] - ; tcExtendLocalFamInstEnv (bagToList famInsts) $ - -- NB: only call tcExtendLocalFamInstEnv once, as it performs - -- validity checking for all of the family instances you give it. - -- If the family instances have errors, calling it twice will result - -- in duplicate error messages! - - do { - -- the stand-alone derived instances (@inst_infos1@) are used when - -- inferring the contexts for "deriving" clauses' instances - -- (@infer_specs@) - ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $ - simplifyInstanceContexts infer_specs - - ; let mk_inst_infos2 = map fstOf3 insts2 - ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs - ; let inst_infos = inst_infos1 ++ inst_infos2 - - ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds - - ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds famInsts)) - - ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) - getGblEnv - ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs) - ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } } - where - ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn - -> Bag FamInst -- ^ Rep type family instances - -> SDoc - ddump_deriving inst_infos extra_binds repFamInsts - = hang (text "Derived class instances:") - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) - $$ ppr extra_binds) - $$ hangP "Derived type family instances:" - (vcat (map pprRepTy (bagToList repFamInsts))) - - hangP s x = text "" $$ hang (ptext (sLit s)) 2 x - - -- Apply the suspended computations given by genInst calls. - -- See Note [Staging of tcDeriving] - apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)] - -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs] - apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds)) - --- Prints the representable type family instance -pprRepTy :: FamInst -> SDoc -pprRepTy fi@(FamInst { fi_tys = lhs }) - = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> - equals <+> ppr rhs - where rhs = famInstRHS fi - -renameDeriv :: [InstInfo GhcPs] - -> Bag (LHsBind GhcPs, LSig GhcPs) - -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses) -renameDeriv inst_infos bagBinds - = discardWarnings $ - -- Discard warnings about unused bindings etc - setXOptM LangExt.EmptyCase $ - -- Derived decls (for empty types) can have - -- case x of {} - setXOptM LangExt.ScopedTypeVariables $ - setXOptM LangExt.KindSignatures $ - -- Derived decls (for newtype-deriving) can use ScopedTypeVariables & - -- KindSignatures - setXOptM LangExt.TypeApplications $ - -- GND/DerivingVia uses TypeApplications in generated code - -- (See Note [Newtype-deriving instances] in TcGenDeriv) - unsetXOptM LangExt.RebindableSyntax $ - -- See Note [Avoid RebindableSyntax when deriving] - setXOptM LangExt.TemplateHaskellQuotes $ - -- DeriveLift makes uses of quotes - do { - -- Bring the extra deriving stuff into scope - -- before renaming the instances themselves - ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) - ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) - ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds - ; let bndrs = collectHsValBinders rn_aux_lhs - ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ; - ; setEnvs envs $ - do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs - ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos - ; return (listToBag rn_inst_infos, rn_aux, - dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } - - where - rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars) - rn_inst_info - inst_info@(InstInfo { iSpec = inst - , iBinds = InstBindings - { ib_binds = binds - , ib_tyvars = tyvars - , ib_pragmas = sigs - , ib_extensions = exts -- Only for type-checking - , ib_derived = sa } }) - = ASSERT( null sigs ) - bindLocalNamesFV tyvars $ - do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds [] - ; let binds' = InstBindings { ib_binds = rn_binds - , ib_tyvars = tyvars - , ib_pragmas = [] - , ib_extensions = exts - , ib_derived = sa } - ; return (inst_info { iBinds = binds' }, fvs) } - -{- -Note [Staging of tcDeriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a tricky corner case for deriving (adapted from #2721): - - class C a where - type T a - foo :: a -> T a - - instance C Int where - type T Int = Int - foo = id - - newtype N = N Int deriving C - -This will produce an instance something like this: - - instance C N where - type T N = T Int - foo = coerce (foo :: Int -> T Int) :: N -> T N - -We must be careful in order to typecheck this code. When determining the -context for the instance (in simplifyInstanceContexts), we need to determine -that T N and T Int have the same representation, but to do that, the T N -instance must be in the local family instance environment. Otherwise, GHC -would be unable to conclude that T Int is representationally equivalent to -T Int, and simplifyInstanceContexts would get stuck. - -Previously, tcDeriving would defer adding any derived type family instances to -the instance environment until the very end, which meant that -simplifyInstanceContexts would get called without all the type family instances -it needed in the environment in order to properly simplify instance like -the C N instance above. - -To avoid this scenario, we carefully structure the order of events in -tcDeriving. We first call genInst on the standalone derived instance specs and -the instance specs obtained from deriving clauses. Note that the return type of -genInst is a triple: - - TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) - -The type family instances are in the BagDerivStuff. The first field of the -triple is a suspended computation which, given an instance context, produces -the rest of the instance. The fact that it is suspended is important, because -right now, we don't have ThetaTypes for the instances that use deriving clauses -(only the standalone-derived ones). - -Now we can can collect the type family instances and extend the local instance -environment. At this point, it is safe to run simplifyInstanceContexts on the -deriving-clause instance specs, which gives us the ThetaTypes for the -deriving-clause instances. Now we can feed all the ThetaTypes to the -suspended computations and obtain our InstInfos, at which point -tcDeriving is done. - -An alternative design would be to split up genInst so that the -family instances are generated separately from the InstInfos. But this would -require carving up a lot of the GHC deriving internals to accommodate the -change. On the other hand, we can keep all of the InstInfo and type family -instance logic together in genInst simply by converting genInst to -continuation-returning style, so we opt for that route. - -Note [Why we don't pass rep_tc into deriveTyData] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc -back into the rep_tc by means of a lookup. And yet we have the rep_tc right -here! Why look it up again? Answer: it's just easier this way. -We drop some number of arguments from the end of the datatype definition -in deriveTyData. The arguments are dropped from the fam_tc. -This action may drop a *different* number of arguments -passed to the rep_tc, depending on how many free variables, etc., the -dropped patterns have. - -Also, this technique carries over the kind substitution from deriveTyData -nicely. - -Note [Avoid RebindableSyntax when deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RebindableSyntax extension interacts awkwardly with the derivation of -any stock class whose methods require the use of string literals. The Show -class is a simple example (see #12688): - - {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} - newtype Text = Text String - fromString :: String -> Text - fromString = Text - - data Foo = Foo deriving Show - -This will generate code to the effect of: - - instance Show Foo where - showsPrec _ Foo = showString "Foo" - -But because RebindableSyntax and OverloadedStrings are enabled, the "Foo" -string literal is now of type Text, not String, which showString doesn't -accept! This causes the generated Show instance to fail to typecheck. - -To avoid this kind of scenario, we simply turn off RebindableSyntax entirely -in derived code. - -************************************************************************ -* * - From HsSyn to DerivSpec -* * -************************************************************************ - -@makeDerivSpecs@ fishes around to find the info about needed derived instances. --} - -makeDerivSpecs :: [DerivInfo] - -> [LDerivDecl GhcRn] - -> TcM [EarlyDerivSpec] -makeDerivSpecs deriv_infos deriv_decls - = do { eqns1 <- sequenceA - [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt - | DerivInfo { di_rep_tc = rep_tc - , di_scoped_tvs = scoped_tvs - , di_clauses = clauses - , di_ctxt = err_ctxt } <- deriv_infos - , L _ (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ preds }) - <- clauses - ] - ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls - ; return $ concat eqns1 ++ catMaybes eqns2 } - ------------------------------------------------------------------- --- | Process the derived classes in a single @deriving@ clause. -deriveClause :: TyCon - -> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars - -- See Note [Scoped tyvars in a TcTyCon] in types/TyCon - -> Maybe (LDerivStrategy GhcRn) - -> [LHsSigType GhcRn] -> SDoc - -> TcM [EarlyDerivSpec] -deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt - = addErrCtxt err_ctxt $ do - traceTc "deriveClause" $ vcat - [ text "tvs" <+> ppr tvs - , text "scoped_tvs" <+> ppr scoped_tvs - , text "tc" <+> ppr tc - , text "tys" <+> ppr tys - , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ] - tcExtendNameTyVarEnv scoped_tvs $ do - (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat - tcExtendTyVarEnv via_tvs $ - -- Moreover, when using DerivingVia one can bind type variables in - -- the `via` type as well, so these type variables must also be - -- brought into scope. - mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds - -- After typechecking the `via` type once, we then typecheck all - -- of the classes associated with that `via` type in the - -- `deriving` clause. - -- See also Note [Don't typecheck too much in DerivingVia]. - where - tvs = tyConTyVars rep_tc - (tc, tys) = case tyConFamInstSig_maybe rep_tc of - -- data family: - Just (fam_tc, pats, _) -> (fam_tc, pats) - -- NB: deriveTyData wants the *user-specified* - -- name. See Note [Why we don't pass rep_tc into deriveTyData] - - _ -> (rep_tc, mkTyVarTys tvs) -- datatype - --- | Process a single predicate in a @deriving@ clause. --- --- This returns a 'Maybe' because the user might try to derive 'Typeable', --- which is a no-op nowadays. -derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar] - -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec) -derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = - -- We carefully set up uses of recoverM to minimize error message - -- cascades. See Note [Recovering from failures in deriving clauses]. - recoverM (pure Nothing) $ - setSrcSpan (getLoc (hsSigType deriv_pred)) $ do - traceTc "derivePred" $ vcat - [ text "tc" <+> ppr tc - , text "tys" <+> ppr tys - , text "deriv_pred" <+> ppr deriv_pred - , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat - , text "via_tvs" <+> ppr via_tvs ] - (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred - when (cls_arg_kinds `lengthIsNot` 1) $ - failWithTc (nonUnaryErr deriv_pred) - let [cls_arg_kind] = cls_arg_kinds - mb_deriv_strat = fmap unLoc mb_lderiv_strat - if (className cls == typeableClassName) - then do warnUselessTypeable - return Nothing - else let deriv_tvs = via_tvs ++ cls_tvs in - Just <$> deriveTyData tc tys mb_deriv_strat - deriv_tvs cls cls_tys cls_arg_kind - -{- -Note [Don't typecheck too much in DerivingVia] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - - data D = ... - deriving (A1 t, ..., A20 t) via T t - -GHC used to be engineered such that it would typecheck the `deriving` -clause like so: - -1. Take the first class in the clause (`A1`). -2. Typecheck the `via` type (`T t`) and bring its bound type variables - into scope (`t`). -3. Typecheck the class (`A1`). -4. Move on to the next class (`A2`) and repeat the process until all - classes have been typechecked. - -This algorithm gets the job done most of the time, but it has two notable -flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked -20 different times, once for each class in the `deriving` clause. This is -unnecessary because we only need to typecheck `T t` once in order to get -access to its bound type variable. - -The other issue with this algorithm arises when there are no classes in the -`deriving` clause, like in the following example: - - data D2 = ... - deriving () via Maybe Maybe - -Because there are no classes, the algorithm above will simply do nothing. -As a consequence, GHC will completely miss the fact that `Maybe Maybe` -is ill-kinded nonsense (#16923). - -To address both of these problems, GHC now uses this algorithm instead: - -1. Typecheck the `via` type and bring its boudn type variables into scope. -2. Take the first class in the `deriving` clause. -3. Typecheck the class. -4. Move on to the next class and repeat the process until all classes have been - typechecked. - -This algorithm ensures that the `via` type is always typechecked, even if there -are no classes in the `deriving` clause. Moreover, it typecheck the `via` type -/exactly/ once and no more, even if there are multiple classes in the clause. - -Note [Recovering from failures in deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider what happens if you run this program (from #10684) without -DeriveGeneric enabled: - - data A = A deriving (Show, Generic) - data B = B A deriving (Show) - -Naturally, you'd expect GHC to give an error to the effect of: - - Can't make a derived instance of `Generic A': - You need -XDeriveGeneric to derive an instance for this class - -And *only* that error, since the other two derived Show instances appear to be -independent of this derived Generic instance. Yet GHC also used to give this -additional error on the program above: - - No instance for (Show A) - arising from the 'deriving' clause of a data type declaration - When deriving the instance for (Show B) - -This was happening because when GHC encountered any error within a single -data type's set of deriving clauses, it would call recoverM and move on -to the next data type's deriving clauses. One unfortunate consequence of -this design is that if A's derived Generic instance failed, its derived -Show instance would be skipped entirely, leading to the "No instance for -(Show A)" error cascade. - -The solution to this problem is to push through uses of recoverM to the -level of the individual derived classes in a particular data type's set of -deriving clauses. That is, if you have: - - newtype C = C D - deriving (E, F, G) - -Then instead of processing instances E through M under the scope of a single -recoverM, as in the following pseudocode: - - recoverM (pure Nothing) $ mapM derivePred [E, F, G] - -We instead use recoverM in each iteration of the loop: - - mapM (recoverM (pure Nothing) . derivePred) [E, F, G] - -And then process each class individually, under its own recoverM scope. That -way, failure to derive one class doesn't cancel out other classes in the -same set of clause-derived classes. --} - ------------------------------------------------------------------- -deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) --- Process a single standalone deriving declaration --- e.g. deriving instance Show a => Show (T a) --- Rather like tcLocalInstDecl --- --- This returns a Maybe because the user might try to derive Typeable, which is --- a no-op nowadays. -deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) - = setSrcSpan loc $ - addErrCtxt (standaloneCtxt deriv_ty) $ - do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; let ctxt = TcOrigin.InstDeclCtxt True - ; traceTc "Deriving strategy (standalone deriving)" $ - vcat [ppr mb_lderiv_strat, ppr deriv_ty] - ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat - ; (cls_tvs, deriv_ctxt, cls, inst_tys) - <- tcExtendTyVarEnv via_tvs $ - tcStandaloneDerivInstType ctxt deriv_ty - ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat - tvs = via_tvs ++ cls_tvs - -- See Note [Unify kinds in deriving] - ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <- - case mb_deriv_strat of - -- Perform an additional unification with the kind of the `via` - -- type and the result of the previous kind unification. - Just (ViaStrategy via_ty) - -- This unification must be performed on the last element of - -- inst_tys, but we have not yet checked for this property. - -- (This is done later in expectNonNullaryClsArgs). For now, - -- simply do nothing if inst_tys is empty, since - -- expectNonNullaryClsArgs will error later if this - -- is the case. - | Just inst_ty <- lastMaybe inst_tys - -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind = tcTypeKind inst_ty - mb_match = tcUnifyTy inst_ty_kind via_kind - - checkTc (isJust mb_match) - (derivingViaKindErr cls inst_ty_kind - via_ty via_kind) - - let Just kind_subst = mb_match - ki_subst_range = getTCvSubstRangeFVs kind_subst - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - tvs - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - (final_deriv_ctxt, final_deriv_ctxt_tys) - = case deriv_ctxt of - InferContext wc -> (InferContext wc, []) - SupplyContext theta -> - let final_theta = substTheta subst theta - in (SupplyContext final_theta, final_theta) - final_inst_tys = substTys subst inst_tys - final_via_ty = substTy subst via_ty - -- See Note [Floating `via` type variables] - final_tvs = tyCoVarsOfTypesWellScoped $ - final_deriv_ctxt_tys ++ final_inst_tys - ++ [final_via_ty] - pure ( final_tvs, final_deriv_ctxt, final_inst_tys - , Just (ViaStrategy final_via_ty) ) - - _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat) - ; traceTc "Standalone deriving;" $ vcat - [ text "tvs':" <+> ppr tvs' - , text "mb_deriv_strat':" <+> ppr mb_deriv_strat' - , text "deriv_ctxt':" <+> ppr deriv_ctxt' - , text "cls:" <+> ppr cls - , text "inst_tys':" <+> ppr inst_tys' ] - -- C.f. TcInstDcls.tcLocalInstDecl1 - - ; if className cls == typeableClassName - then do warnUselessTypeable - return Nothing - else Just <$> mkEqnHelp (fmap unLoc overlap_mode) - tvs' cls inst_tys' - deriv_ctxt' mb_deriv_strat' } -deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec - --- Typecheck the type in a standalone deriving declaration. --- --- This may appear dense, but it's mostly huffing and puffing to recognize --- the special case of a type with an extra-constraints wildcard context, e.g., --- --- deriving instance _ => Eq (Foo a) --- --- If there is such a wildcard, we typecheck this as if we had written --- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@, --- as the 'DerivContext', where loc is the location of the wildcard used for --- error reporting. This indicates that we should infer the context as if we --- were deriving Eq via a deriving clause --- (see Note [Inferring the instance context] in TcDerivInfer). --- --- If there is no wildcard, then proceed as normal, and instead return --- @'SupplyContext' theta@, where theta is the typechecked context. --- --- Note that this will never return @'InferContext' 'Nothing'@, as that can --- only happen with @deriving@ clauses. -tcStandaloneDerivInstType - :: UserTypeCtxt -> LHsSigWcType GhcRn - -> TcM ([TyVar], DerivContext, Class, [Type]) -tcStandaloneDerivInstType ctxt - (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars - , hsib_body = deriv_ty_body })}) - | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body - , L _ [wc_pred] <- theta - , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred - = do dfun_ty <- tcHsClsInstType ctxt $ - HsIB { hsib_ext = vars - , hsib_body - = L (getLoc deriv_ty_body) $ - HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = tvs - , hst_xforall = noExtField - , hst_body = rho }} - let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, InferContext (Just wc_span), cls, inst_tys) - | otherwise - = do dfun_ty <- tcHsClsInstType ctxt deriv_ty - let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, SupplyContext theta, cls, inst_tys) - -tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs nec)) - = noExtCon nec -tcStandaloneDerivInstType _ (XHsWildCardBndrs nec) - = noExtCon nec - -warnUselessTypeable :: TcM () -warnUselessTypeable - = do { warn <- woptM Opt_WarnDerivingTypeable - ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) - $ text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } - ------------------------------------------------------------------- -deriveTyData :: TyCon -> [Type] -- LHS of data or data instance - -- Can be a data instance, hence [Type] args - -- and in that case the TyCon is the /family/ tycon - -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy - -> [TyVar] -- The type variables bound by the derived class - -> Class -- The derived class - -> [Type] -- The derived class's arguments - -> Kind -- The function argument in the derived class's kind. - -- (e.g., if `deriving Functor`, this would be - -- `Type -> Type` since - -- `Functor :: (Type -> Type) -> Constraint`) - -> TcM EarlyDerivSpec --- The deriving clause of a data or newtype declaration --- I.e. not standalone deriving -deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind - = do { -- Given data T a b c = ... deriving( C d ), - -- we want to drop type variables from T so that (C d (T a)) is well-kinded - let (arg_kinds, _) = splitFunTys cls_arg_kind - n_args_to_drop = length arg_kinds - n_args_to_keep = length tc_args - n_args_to_drop - -- See Note [tc_args and tycon arity] - (tc_args_to_keep, args_to_drop) - = splitAt n_args_to_keep tc_args - inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep) - - -- Match up the kinds, and apply the resulting kind substitution - -- to the types. See Note [Unify kinds in deriving] - -- We are assuming the tycon tyvars and the class tyvars are distinct - mb_match = tcUnifyTy inst_ty_kind cls_arg_kind - enough_args = n_args_to_keep >= 0 - - -- Check that the result really is well-kinded - ; checkTc (enough_args && isJust mb_match) - (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) - - ; let -- Returns a singleton-element list if using ViaStrategy and an - -- empty list otherwise. Useful for free-variable calculations. - deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type] - deriv_strat_tys = foldMap (foldDerivStrategy [] (:[])) - - propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' - = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) - where - ki_subst_range = getTCvSubstRangeFVs kind_subst - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - tkvs' - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - final_tc_args = substTys subst tc_args' - final_cls_tys = substTys subst cls_tys' - final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst)) - mb_deriv_strat' - -- See Note [Floating `via` type variables] - final_tkvs = tyCoVarsOfTypesWellScoped $ - final_cls_tys ++ final_tc_args - ++ deriv_strat_tys final_mb_deriv_strat - - ; let tkvs = scopedSort $ fvVarList $ - unionFV (tyCoFVsOfTypes tc_args_to_keep) - (FV.mkFVs deriv_tvs) - Just kind_subst = mb_match - (tkvs', cls_tys', tc_args', mb_deriv_strat') - = propagate_subst kind_subst tkvs cls_tys - tc_args_to_keep mb_deriv_strat - - -- See Note [Unify kinds in deriving] - ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- - case mb_deriv_strat' of - -- Perform an additional unification with the kind of the `via` - -- type and the result of the previous kind unification. - Just (ViaStrategy via_ty) -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind - = tcTypeKind (mkTyConApp tc tc_args') - via_match = tcUnifyTy inst_ty_kind via_kind - - checkTc (isJust via_match) - (derivingViaKindErr cls inst_ty_kind via_ty via_kind) - - let Just via_subst = via_match - pure $ propagate_subst via_subst tkvs' cls_tys' - tc_args' mb_deriv_strat' - - _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat') - - ; traceTc "deriveTyData 1" $ vcat - [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args - , pprTyVars (tyCoVarsOfTypesList tc_args) - , ppr n_args_to_keep, ppr n_args_to_drop - , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match - , ppr final_tc_args, ppr final_cls_tys ] - - ; traceTc "deriveTyData 2" $ vcat - [ ppr final_tkvs ] - - ; let final_tc_app = mkTyConApp tc final_tc_args - final_cls_args = final_cls_tys ++ [final_tc_app] - ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) - (derivingEtaErr cls final_cls_tys final_tc_app) - -- Check that - -- (a) The args to drop are all type variables; eg reject: - -- data instance T a Int = .... deriving( Monad ) - -- (b) The args to drop are all *distinct* type variables; eg reject: - -- class C (a :: * -> * -> *) where ... - -- data instance T a a = ... deriving( C ) - -- (c) The type class args, or remaining tycon args, - -- do not mention any of the dropped type variables - -- newtype T a s = ... deriving( ST s ) - -- newtype instance K a a = ... deriving( Monad ) - -- - -- It is vital that the implementation of allDistinctTyVars - -- expand any type synonyms. - -- See Note [Eta-reducing type synonyms] - - ; checkValidInstHead DerivClauseCtxt cls final_cls_args - -- Check that we aren't deriving an instance of a magical - -- type like (~) or Coercible (#14916). - - ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args - (InferContext Nothing) final_mb_deriv_strat - ; traceTc "deriveTyData 3" (ppr spec) - ; return spec } - - -{- Note [tc_args and tycon arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might wonder if we could use (tyConArity tc) at this point, rather -than (length tc_args). But for data families the two can differ! The -tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which -in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them -from DataFamInstTyCon: - -| DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- No shorter in length than the tyConTyVars of the family TyCon - -- How could it be longer? See [Arity of data families] in FamInstEnv - -Notice that the arg tys might not be the same as the family tycon arity -(= length tyConTyVars). - -Note [Unify kinds in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#8534) - data T a b = MkT a deriving( Functor ) - -- where Functor :: (*->*) -> Constraint - -So T :: forall k. * -> k -> *. We want to get - instance Functor (T * (a:*)) where ... -Notice the '*' argument to T. - -Moreover, as well as instantiating T's kind arguments, we may need to instantiate -C's kind args. Consider (#8865): - newtype T a b = MkT (Either a b) deriving( Category ) -where - Category :: forall k. (k -> k -> *) -> Constraint -We need to generate the instance - instance Category * (Either a) where ... -Notice the '*' argument to Category. - -So we need to - * drop arguments from (T a b) to match the number of - arrows in the (last argument of the) class; - * and then *unify* kind of the remaining type against the - expected kind, to figure out how to instantiate C's and T's - kind arguments. - -In the two examples, - * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) - i.e. (k -> *) ~ (* -> *) to find k:=*. - yielding k:=* - - * we unify kind-of( Either ) ~ kind-of( Category ) - i.e. (* -> * -> *) ~ (k -> k -> k) - yielding k:=* - -Now we get a kind substitution. We then need to: - - 1. Remove the substituted-out kind variables from the quantified kind vars - - 2. Apply the substitution to the kinds of quantified *type* vars - (and extend the substitution to reflect this change) - - 3. Apply that extended substitution to the non-dropped args (types and - kinds) of the type and class - -Forgetting step (2) caused #8893: - data V a = V [a] deriving Functor - data P (x::k->*) (a:k) = P (x a) deriving Functor - data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor - -When deriving Functor for P, we unify k to *, but we then want -an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) -and similarly for C. Notice the modified kind of x, both at binding -and occurrence sites. - -This can lead to some surprising results when *visible* kind binder is -unified (in contrast to the above examples, in which only non-visible kind -binders were considered). Consider this example from #11732: - - data T k (a :: k) = MkT deriving Functor - -Since unification yields k:=*, this results in a generated instance of: - - instance Functor (T *) where ... - -which looks odd at first glance, since one might expect the instance head -to be of the form Functor (T k). Indeed, one could envision an alternative -generated instance of: - - instance (k ~ *) => Functor (T k) where - -But this does not typecheck by design: kind equalities are not allowed to be -bound in types, only terms. But in essence, the two instance declarations are -entirely equivalent, since even though (T k) matches any kind k, the only -possibly value for k is *, since anything else is ill-typed. As a result, we can -just as comfortably use (T *). - -Another way of thinking about is: deriving clauses often infer constraints. -For example: - - data S a = S a deriving Eq - -infers an (Eq a) constraint in the derived instance. By analogy, when we -are deriving Functor, we might infer an equality constraint (e.g., k ~ *). -The only distinction is that GHC instantiates equality constraints directly -during the deriving process. - -Another quirk of this design choice manifests when typeclasses have visible -kind parameters. Consider this code (also from #11732): - - class Cat k (cat :: k -> k -> *) where - catId :: cat a a - catComp :: cat b c -> cat a b -> cat a c - - instance Cat * (->) where - catId = id - catComp = (.) - - newtype Fun a b = Fun (a -> b) deriving (Cat k) - -Even though we requested a derived instance of the form (Cat k Fun), the -kind unification will actually generate (Cat * Fun) (i.e., the same thing as if -the user wrote deriving (Cat *)). - -What happens with DerivingVia, when you have yet another type? Consider: - - newtype Foo (a :: Type) = MkFoo (Proxy a) - deriving Functor via Proxy - -As before, we unify the kind of Foo (* -> *) with the kind of the argument to -Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind -(k -> *), which is more general than what we want. So we must additionally -unify (k -> *) with (* -> *). - -Currently, all of this unification is implemented kludgily with the pure -unifier, which is rather tiresome. #14331 lays out a plan for how this -might be made cleaner. - -Note [Unification of two kind variables in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a special case of the Note above, it is possible to derive an instance of -a poly-kinded typeclass for a poly-kinded datatype. For example: - - class Category (cat :: k -> k -> *) where - newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category - -This case is suprisingly tricky. To see why, let's write out what instance GHC -will attempt to derive (using -fprint-explicit-kinds syntax): - - instance Category k1 (T k2 c) where ... - -GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst) -that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to -the type variable binder for c, since its kind is (k2 -> k2 -> *). - -We used to accomplish this by doing the following: - - unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - -Where all_tkvs contains all kind variables in the class and instance types (in -this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping, -this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped -to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new]. -This is bad, because applying that substitution yields the following instance: - - instance Category k_new (T k1 c) where ... - -In other words, keeping k1 in unmapped_tvks taints the substitution, resulting -in an ill-kinded instance (this caused #11837). - -To prevent this, we need to filter out any variable from all_tkvs which either - -1. Appears in the domain of kind_subst. notElemTCvSubst checks this. -2. Appears in the range of kind_subst. To do this, we compute the free - variable set of the range of kind_subst with getTCvSubstRangeFVs, and check - if a kind variable appears in that set. - -Note [Eta-reducing type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One can instantiate a type in a data family instance with a type synonym that -mentions other type variables: - - type Const a b = a - data family Fam (f :: * -> *) (a :: *) - newtype instance Fam f (Const a f) = Fam (f a) deriving Functor - -It is also possible to define kind synonyms, and they can mention other types in -a datatype declaration. For example, - - type Const a b = a - newtype T f (a :: Const * f) = T (f a) deriving Functor - -When deriving, we need to perform eta-reduction analysis to ensure that none of -the eta-reduced type variables are mentioned elsewhere in the declaration. But -we need to be careful, because if we don't expand through the Const type -synonym, we will mistakenly believe that f is an eta-reduced type variable and -fail to derive Functor, even though the code above is correct (see #11416, -where this was first noticed). For this reason, we expand the type synonyms in -the eta-reduced types before doing any analysis. - -Note [Floating `via` type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When generating a derived instance, it will be of the form: - - instance forall ???. C c_args (D d_args) where ... - -To fill in ???, GHC computes the free variables of `c_args` and `d_args`. -`DerivingVia` adds an extra wrinkle to this formula, since we must also -include the variables bound by the `via` type when computing the binders -used to fill in ???. This might seem strange, since if a `via` type binds -any type variables, then in almost all scenarios it will appear free in -`c_args` or `d_args`. There are certain corner cases where this does not hold, -however, such as in the following example (adapted from #15831): - - newtype Age = MkAge Int - deriving Eq via Const Int a - -In this example, the `via` type binds the type variable `a`, but `a` appears -nowhere in `Eq Age`. Nevertheless, we include it in the generated instance: - - instance forall a. Eq Age where - (==) = coerce @(Const Int a -> Const Int a -> Bool) - @(Age -> Age -> Bool) - (==) - -The use of `forall a` is certainly required here, since the `a` in -`Const Int a` would not be in scope otherwise. This instance is somewhat -strange in that nothing in the instance head `Eq Age` ever determines what `a` -will be, so any code that uses this instance will invariably instantiate `a` -to be `Any`. We refer to this property of `a` as being a "floating" `via` -type variable. Programs with floating `via` type variables are the only known -class of program in which the `via` type quantifies type variables that aren't -mentioned in the instance head in the generated instance. - -Fortunately, the choice to instantiate floating `via` type variables to `Any` -is one that is completely transparent to the user (since the instance will -work as expected regardless of what `a` is instantiated to), so we decide to -permit them. An alternative design would make programs with floating `via` -variables illegal, by requiring that every variable mentioned in the `via` type -is also mentioned in the data header or the derived class. That restriction -would require the user to pick a particular type (the choice does not matter); -for example: - - newtype Age = MkAge Int - -- deriving Eq via Const Int a -- Floating 'a' - deriving Eq via Const Int () -- Choose a=() - deriving Eq via Const Int Any -- Choose a=Any - -No expressiveness would be lost thereby, but stylistically it seems preferable -to allow a type variable to indicate "it doesn't matter". - -Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the -work of instantiating `a` to `Any` at every use site of the instance. An -alternative approach would be to generate an instance that directly defaulted -to `Any`: - - instance Eq Age where - (==) = coerce @(Const Int Any -> Const Int Any -> Bool) - @(Age -> Age -> Bool) - (==) - -We do not implement this approach since it would require a nontrivial amount -of implementation effort to substitute `Any` for the floating `via` type -variables, and since the end result isn't distinguishable from the former -instance (at least from the user's perspective), the amount of engineering -required to obtain the latter instance just isn't worth it. --} - -mkEqnHelp :: Maybe OverlapMode - -> [TyVar] - -> Class -> [Type] - -> DerivContext - -- SupplyContext => context supplied (standalone deriving) - -- InferContext => context inferred (deriving on data decl, or - -- standalone deriving decl with a wildcard) - -> Maybe (DerivStrategy GhcTc) - -> TcRn EarlyDerivSpec --- Make the EarlyDerivSpec for an instance --- forall tvs. theta => cls (tys ++ [ty]) --- where the 'theta' is optional (that's the Maybe part) --- Assumes that this declaration is well-kinded - -mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do - is_boot <- tcIsHsBootOrSig - when is_boot $ - bale_out (text "Cannot derive instances in hs-boot files" - $+$ text "Write an instance declaration instead") - runReaderT mk_eqn deriv_env - where - deriv_env = DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = cls_args - , denv_ctxt = deriv_ctxt - , denv_strat = deriv_strat } - - bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg - - mk_eqn :: DerivM EarlyDerivSpec - mk_eqn = do - DerivEnv { denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - case mb_strat of - Just StockStrategy -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - dit <- expectAlgTyConApp cls_tys inst_ty - mk_eqn_stock dit - - Just AnyclassStrategy -> mk_eqn_anyclass - - Just (ViaStrategy via_ty) -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - mk_eqn_via cls_tys inst_ty via_ty - - Just NewtypeStrategy -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - dit <- expectAlgTyConApp cls_tys inst_ty - unless (isNewTyCon (dit_rep_tc dit)) $ - derivingThingFailWith False gndNonNewtypeErr - mkNewTypeEqn True dit - - Nothing -> mk_eqn_no_strategy - --- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty. --- If so, return @(init inst_tys, last inst_tys)@. --- Otherwise, throw an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) -expectNonNullaryClsArgs inst_tys = - maybe (derivingThingFailWith False derivingNullaryErr) pure $ - snocView inst_tys - --- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application --- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting --- of @cls_tys@ and the constituent pars of @inst_ty@. --- Otherwise, throw an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectAlgTyConApp :: [Type] -- All but the last argument to the class in a - -- derived instance - -> Type -- The last argument to the class in a - -- derived instance - -> DerivM DerivInstTys -expectAlgTyConApp cls_tys inst_ty = do - fam_envs <- lift tcGetFamInstEnvs - case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of - Nothing -> derivingThingFailWith False $ - text "The last argument of the instance must be a" - <+> text "data or newtype application" - Just dit -> do expectNonDataFamTyCon dit - pure dit - --- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation --- type constructor for a data family instance, and if not, --- throws an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectNonDataFamTyCon :: DerivInstTys -> DerivM () -expectNonDataFamTyCon (DerivInstTys { dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc }) = - -- If it's still a data family, the lookup failed; i.e no instance exists - when (isDataFamilyTyCon rep_tc) $ - derivingThingFailWith False $ - text "No family instance for" <+> quotes (pprTypeApp tc tc_args) - -mk_deriv_inst_tys_maybe :: FamInstEnvs - -> [Type] -> Type -> Maybe DerivInstTys -mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty = - fmap lookup $ tcSplitTyConApp_maybe inst_ty - where - lookup :: (TyCon, [Type]) -> DerivInstTys - lookup (tc, tc_args) = - -- Find the instance of a data family - -- Note [Looking up family instances for deriving] - let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args - in DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args } - -{- -Note [Looking up family instances for deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcLookupFamInstExact is an auxiliary lookup wrapper which requires -that looked-up family instances exist. If called with a vanilla -tycon, the old type application is simply returned. - -If we have - data instance F () = ... deriving Eq - data instance F () = ... deriving Eq -then tcLookupFamInstExact will be confused by the two matches; -but that can't happen because tcInstDecls1 doesn't call tcDeriving -if there are any overlaps. - -There are two other things that might go wrong with the lookup. -First, we might see a standalone deriving clause - deriving Eq (F ()) -when there is no data instance F () in scope. - -Note that it's OK to have - data instance F [a] = ... - deriving Eq (F [(a,b)]) -where the match is not exact; the same holds for ordinary data types -with standalone deriving declarations. - -Note [Deriving, type families, and partial applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When there are no type families, it's quite easy: - - newtype S a = MkS [a] - -- :CoS :: S ~ [] -- Eta-reduced - - instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) - instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S - -When type familes are involved it's trickier: - - data family T a b - newtype instance T Int a = MkT [a] deriving( Eq, Monad ) - -- :RT is the representation type for (T Int a) - -- :Co:RT :: :RT ~ [] -- Eta-reduced! - -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! - - instance Eq [a] => Eq (T Int a) -- easy by coercion - -- d1 :: Eq [a] - -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) - - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - -- d1 :: Monad [] - -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) - -Note the need for the eta-reduced rule axioms. After all, we can -write it out - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - return x = MkT [x] - ... etc ... - -See Note [Eta reduction for data families] in FamInstEnv - -%************************************************************************ -%* * - Deriving data types -* * -************************************************************************ --} - --- Once the DerivSpecMechanism is known, we can finally produce an --- EarlyDerivSpec from it. -mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec -mk_eqn_from_mechanism mechanism - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = deriv_ctxt } <- ask - doDerivInstErrorChecks1 mechanism - loc <- lift getSrcSpanM - dfun_name <- lift $ newDFunName cls inst_tys loc - case deriv_ctxt of - InferContext wildcard -> - do { (inferred_constraints, tvs', inst_tys') - <- inferConstraints mechanism - ; return $ InferTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs' - , ds_cls = cls, ds_tys = inst_tys' - , ds_theta = inferred_constraints - , ds_overlap = overlap_mode - , ds_standalone_wildcard = wildcard - , ds_mechanism = mechanism } } - - SupplyContext theta -> - return $ GivenTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_theta = theta - , ds_overlap = overlap_mode - , ds_standalone_wildcard = Nothing - , ds_mechanism = mechanism } - -mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class - -> DerivM EarlyDerivSpec -mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_rep_tc = rep_tc }) - = do DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys - tc rep_tc of - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - StockClassError msg -> derivingThingFailWith False msg - _ -> derivingThingFailWith False (nonStdErr cls) - -mk_eqn_anyclass :: DerivM EarlyDerivSpec -mk_eqn_anyclass - = do dflags <- getDynFlags - case canDeriveAnyClass dflags of - IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass - NotValid msg -> derivingThingFailWith False msg - -mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class - -> Type -- The newtype's representation type - -> DerivM EarlyDerivSpec -mk_eqn_newtype dit rep_ty = - mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit - , dsm_newtype_rep_ty = rep_ty } - -mk_eqn_via :: [Type] -- All arguments to the class besides the last - -> Type -- The last argument to the class - -> Type -- The @via@ type - -> DerivM EarlyDerivSpec -mk_eqn_via cls_tys inst_ty via_ty = - mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys - , dsm_via_inst_ty = inst_ty - , dsm_via_ty = via_ty } - --- Derive an instance without a user-requested deriving strategy. This uses --- heuristics to determine which deriving strategy to use. --- See Note [Deriving strategies]. -mk_eqn_no_strategy :: DerivM EarlyDerivSpec -mk_eqn_no_strategy = do - DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args } <- ask - fam_envs <- lift tcGetFamInstEnvs - - -- First, check if the last argument is an application of a type constructor. - -- If not, fall back to DeriveAnyClass. - if | Just (cls_tys, inst_ty) <- snocView cls_args - , Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty - -> if | isNewTyCon (dit_rep_tc dit) - -- We have a dedicated code path for newtypes (see the - -- documentation for mkNewTypeEqn as to why this is the case) - -> mkNewTypeEqn False dit - - | otherwise - -> do -- Otherwise, our only other options are stock or anyclass. - -- If it is stock, we must confirm that the last argument's - -- type constructor is algebraic. - -- See Note [DerivEnv and DerivSpecMechanism] in TcDerivUtils - whenIsJust (hasStockDeriving cls) $ \_ -> - expectNonDataFamTyCon dit - mk_eqn_originative dit - - | otherwise - -> mk_eqn_anyclass - where - -- Use heuristics (checkOriginativeSideConditions) to determine whether - -- stock or anyclass deriving should be used. - mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec - mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_rep_tc = rep_tc }) = do - DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - - -- See Note [Deriving instances for classes themselves] - let dac_error msg - | isClassTyCon rep_tc - = quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled" - | otherwise - = nonStdErr cls $$ msg - - case checkOriginativeSideConditions dflags deriv_ctxt cls - cls_tys tc rep_tc of - NonDerivableClass msg -> derivingThingFailWith False (dac_error msg) - StockClassError msg -> derivingThingFailWith False msg - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass - -{- -************************************************************************ -* * - Deriving instances for newtypes -* * -************************************************************************ --} - --- Derive an instance for a newtype. We put this logic into its own function --- because --- --- (a) When no explicit deriving strategy is requested, we have special --- heuristics for newtypes to determine which deriving strategy should --- actually be used. See Note [Deriving strategies]. --- (b) We make an effort to give error messages specifically tailored to --- newtypes. -mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@ - -- deriving strategy? - -> DerivInstTys -> DerivM EarlyDerivSpec -mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tycon - , dit_rep_tc = rep_tycon - , dit_rep_tc_args = rep_tc_args }) --- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... - = do DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - - let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags - deriveAnyClass = xopt LangExt.DeriveAnyClass dflags - - bale_out = derivingThingFailWith newtype_deriving - - non_std = nonStdErr cls - suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's" - <+> text "newtype-deriving extension" - - -- Here is the plan for newtype derivings. We see - -- newtype T a1...an = MkT (t ak+1...an) - -- deriving (.., C s1 .. sm, ...) - -- where t is a type, - -- ak+1...an is a suffix of a1..an, and are all tyvars - -- ak+1...an do not occur free in t, nor in the s1..sm - -- (C s1 ... sm) is a *partial applications* of class C - -- with the last parameter missing - -- (T a1 .. ak) matches the kind of C's last argument - -- (and hence so does t) - -- The latter kind-check has been done by deriveTyData already, - -- and tc_args are already trimmed - -- - -- We generate the instance - -- instance forall ({a1..ak} u fvs(s1..sm)). - -- C s1 .. sm t => C s1 .. sm (T a1...ak) - -- where T a1...ap is the partial application of - -- the LHS of the correct kind and p >= k - -- - -- NB: the variables below are: - -- tc_tvs = [a1, ..., an] - -- tyvars_to_keep = [a1, ..., ak] - -- rep_ty = t ak .. an - -- deriv_tvs = fvs(s1..sm) \ tc_tvs - -- tys = [s1, ..., sm] - -- rep_fn' = t - -- - -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) - -- We generate the instance - -- instance Monad (ST s) => Monad (T s) where - - nt_eta_arity = newTyConEtadArity rep_tycon - -- For newtype T a b = MkT (S a a b), the TyCon - -- machinery already eta-reduces the representation type, so - -- we know that - -- T a ~ S a a - -- That's convenient here, because we may have to apply - -- it to fewer than its original complement of arguments - - -- Note [Newtype representation] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Need newTyConRhs (*not* a recursive representation finder) - -- to get the representation type. For example - -- newtype B = MkB Int - -- newtype A = MkA B deriving( Num ) - -- We want the Num instance of B, *not* the Num instance of Int, - -- when making the Num instance of A! - rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args - - ------------------------------------------------------------------- - -- Figuring out whether we can only do this newtype-deriving thing - - -- See Note [Determining whether newtype-deriving is appropriate] - might_be_newtype_derivable - = not (non_coercible_class cls) - && eta_ok --- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - - -- Check that eta reduction is OK - eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity - -- The newtype can be eta-reduced to match the number - -- of type argument actually supplied - -- newtype T a b = MkT (S [a] b) deriving( Monad ) - -- Here the 'b' must be the same in the rep type (S [a] b) - -- And the [a] must not mention 'b'. That's all handled - -- by nt_eta_rity. - - cant_derive_err = ppUnless eta_ok eta_msg - eta_msg = text "cannot eta-reduce the representation type enough" - - MASSERT( cls_tys `lengthIs` (classArity cls - 1) ) - if newtype_strat - then - -- Since the user explicitly asked for GeneralizedNewtypeDeriving, - -- we don't need to perform all of the checks we normally would, - -- such as if the class being derived is known to produce ill-roled - -- coercions (e.g., Traversable), since we can just derive the - -- instance and let it error if need be. - -- See Note [Determining whether newtype-deriving is appropriate] - if eta_ok && newtype_deriving - then mk_eqn_newtype dit rep_inst_ty - else bale_out (cant_derive_err $$ - if newtype_deriving then empty else suggest_gnd) - else - if might_be_newtype_derivable - && ((newtype_deriving && not deriveAnyClass) - || std_class_via_coercible cls) - then mk_eqn_newtype dit rep_inst_ty - else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys - tycon rep_tycon of - StockClassError msg - -- There's a particular corner case where - -- - -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are - -- both enabled at the same time - -- 2. We're deriving a particular stock derivable class - -- (such as Functor) - -- - -- and the previous cases won't catch it. This fixes the bug - -- reported in #10598. - | might_be_newtype_derivable && newtype_deriving - -> mk_eqn_newtype dit rep_inst_ty - -- Otherwise, throw an error for a stock class - | might_be_newtype_derivable && not newtype_deriving - -> bale_out (msg $$ suggest_gnd) - | otherwise - -> bale_out msg - - -- Must use newtype deriving or DeriveAnyClass - NonDerivableClass _msg - -- Too hard, even with newtype deriving - | newtype_deriving -> bale_out cant_derive_err - -- Try newtype deriving! - -- Here we suggest GeneralizedNewtypeDeriving even in cases - -- where it may not be applicable. See #9600. - | otherwise -> bale_out (non_std $$ suggest_gnd) - - -- DeriveAnyClass - CanDeriveAnyClass -> do - -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are - -- enabled, we take the diplomatic approach of defaulting to - -- DeriveAnyClass, but emitting a warning about the choice. - -- See Note [Deriving strategies] - when (newtype_deriving && deriveAnyClass) $ - lift $ whenWOptM Opt_WarnDerivingDefaults $ - addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls - , text "Use DerivingStrategies to pick" - <+> text "a different strategy" - ] - mk_eqn_from_mechanism DerivSpecAnyClass - -- CanDeriveStock - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - -{- -Note [Recursive newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Newtype deriving works fine, even if the newtype is recursive. -e.g. newtype S1 = S1 [T1 ()] - newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) -Remember, too, that type families are currently (conservatively) given -a recursive flag, so this also allows newtype deriving to work -for type famillies. - -We used to exclude recursive types, because we had a rather simple -minded way of generating the instance decl: - newtype A = MkA [A] - instance Eq [A] => Eq A -- Makes typechecker loop! -But now we require a simple context, so it's ok. - -Note [Determining whether newtype-deriving is appropriate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see - newtype NT = MkNT Foo - deriving C -we have to decide how to perform the deriving. Do we do newtype deriving, -or do we do normal deriving? In general, we prefer to do newtype deriving -wherever possible. So, we try newtype deriving unless there's a glaring -reason not to. - -"Glaring reasons not to" include trying to derive a class for which a -coercion-based instance doesn't make sense. These classes are listed in -the definition of non_coercible_class. They include Show (since it must -show the name of the datatype) and Traversable (since a coercion-based -Traversable instance is ill-roled). - -However, non_coercible_class is ignored if the user explicitly requests -to derive an instance with GeneralizedNewtypeDeriving using the newtype -deriving strategy. In such a scenario, GHC will unquestioningly try to -derive the instance via coercions (even if the final generated code is -ill-roled!). See Note [Deriving strategies]. - -Note that newtype deriving might fail, even after we commit to it. This -is because the derived instance uses `coerce`, which must satisfy its -`Coercible` constraint. This is different than other deriving scenarios, -where we're sure that the resulting instance will type-check. - -Note [GND and associated type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for -classes with associated type families. A general recipe is: - - class C x y z where - type T y z x - op :: x -> [y] -> z - - newtype N a = MkN deriving( C ) - - =====> - - instance C x y => C x y (N a) where - type T y (N a) x = T y x - op = coerce (op :: x -> [y] -> ) - -However, we must watch out for three things: - -(a) The class must not contain any data families. If it did, we'd have to - generate a fresh data constructor name for the derived data family - instance, and it's not clear how to do this. - -(b) Each associated type family's type variables must mention the last type - variable of the class. As an example, you wouldn't be able to use GND to - derive an instance of this class: - - class C a b where - type T a - - But you would be able to derive an instance of this class: - - class C a b where - type T b - - The difference is that in the latter T mentions the last parameter of C - (i.e., it mentions b), but the former T does not. If you tried, e.g., - - newtype Foo x = Foo x deriving (C a) - - with the former definition of C, you'd end up with something like this: - - instance C a (Foo x) where - type T a = T ??? - - This T family instance doesn't mention the newtype (or its representation - type) at all, so we disallow such constructions with GND. - -(c) UndecidableInstances might need to be enabled. Here's a case where it is - most definitely necessary: - - class C a where - type T a - newtype Loop = Loop MkLoop deriving C - - =====> - - instance C Loop where - type T Loop = T Loop - - Obviously, T Loop would send the typechecker into a loop. Unfortunately, - you might even need UndecidableInstances even in cases where the - typechecker would be guaranteed to terminate. For example: - - instance C Int where - type C Int = Int - newtype MyInt = MyInt Int deriving C - - =====> - - instance C MyInt where - type T MyInt = T Int - - GHC's termination checker isn't sophisticated enough to conclude that the - definition of T MyInt terminates, so UndecidableInstances is required. - -(d) For the time being, we do not allow the last type variable of the class to - appear in a /kind/ of an associated type family definition. For instance: - - class C a where - type T1 a -- OK - type T2 (x :: a) -- Illegal: a appears in the kind of x - type T3 y :: a -- Illegal: a appears in the kind of (T3 y) - - The reason we disallow this is because our current approach to deriving - associated type family instances—i.e., by unwrapping the newtype's type - constructor as shown above—is ill-equipped to handle the scenario when - the last type variable appears as an implicit argument. In the worst case, - allowing the last variable to appear in a kind can result in improper Core - being generated (see #14728). - - There is hope for this feature being added some day, as one could - conceivably take a newtype axiom (which witnesses a coercion between a - newtype and its representation type) at lift that through each associated - type at the Core level. See #14728, comment:3 for a sketch of how this - might work. Until then, we disallow this featurette wholesale. - -The same criteria apply to DerivingVia. - -************************************************************************ -* * -\subsection[TcDeriv-normal-binds]{Bindings for the various classes} -* * -************************************************************************ - -After all the trouble to figure out the required context for the -derived instance declarations, all that's left is to chug along to -produce them. They will then be shoved into @tcInstDecls2@, which -will do all its usual business. - -There are lots of possibilities for code to generate. Here are -various general remarks. - -PRINCIPLES: -\begin{itemize} -\item -We want derived instances of @Eq@ and @Ord@ (both v common) to be -``you-couldn't-do-better-by-hand'' efficient. - -\item -Deriving @Show@---also pretty common--- should also be reasonable good code. - -\item -Deriving for the other classes isn't that common or that big a deal. -\end{itemize} - -PRAGMATICS: - -\begin{itemize} -\item -Deriving @Ord@ is done mostly with the 1.3 @compare@ method. - -\item -Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. - -\item -We {\em normally} generate code only for the non-defaulted methods; -there are some exceptions for @Eq@ and (especially) @Ord@... - -\item -Sometimes we use a @_con2tag_@ function, which returns a data -constructor's numeric (@Int#@) tag. These are generated by -@gen_tag_n_con_binds@, and the heuristic for deciding if one of -these is around is given by @hasCon2TagFun@. - -The examples under the different sections below will make this -clearer. - -\item -Much less often (really just for deriving @Ix@), we use a -@_tag2con_@ function. See the examples. - -\item -We use the renamer!!! Reason: we're supposed to be -producing @LHsBinds Name@ for the methods, but that means -producing correctly-uniquified code on the fly. This is entirely -possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. -So, instead, we produce @MonoBinds RdrName@ then heave 'em through -the renamer. What a great hack! -\end{itemize} --} - --- Generate the InstInfo for the required instance --- plus any auxiliary bindings required -genInst :: DerivSpec theta - -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]) --- We must use continuation-returning style here to get the order in which we --- typecheck family instances and derived instances right. --- See Note [Staging of tcDeriving] -genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism - , ds_tys = tys, ds_cls = clas, ds_loc = loc - , ds_standalone_wildcard = wildcard }) - = do (meth_binds, deriv_stuff, unusedNames) - <- set_span_and_ctxt $ - genDerivStuff mechanism loc clas tys tvs - let mk_inst_info theta = set_span_and_ctxt $ do - inst_spec <- newDerivClsInst theta spec - doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism - traceTc "newder" (ppr inst_spec) - return $ InstInfo - { iSpec = inst_spec - , iBinds = InstBindings - { ib_binds = meth_binds - , ib_tyvars = map Var.varName tvs - , ib_pragmas = [] - , ib_extensions = extensions - , ib_derived = True } } - return (mk_inst_info, deriv_stuff, unusedNames) - where - extensions :: [LangExt.Extension] - extensions - | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism - -- Both these flags are needed for higher-rank uses of coerce - -- See Note [Newtype-deriving instances] in TcGenDeriv - = [LangExt.ImpredicativeTypes, LangExt.RankNTypes] - | otherwise - = [] - - set_span_and_ctxt :: TcM a -> TcM a - set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys) - --- Checks: --- --- * All of the data constructors for a data type are in scope for a --- standalone-derived instance (for `stock` and `newtype` deriving). --- --- * All of the associated type families of a class are suitable for --- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via` --- deriving). -doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM () -doDerivInstErrorChecks1 mechanism = - case mechanism of - DerivSpecStock{dsm_stock_dit = dit} - -> data_cons_in_scope_check dit - DerivSpecNewtype{dsm_newtype_dit = dit} - -> do atf_coerce_based_error_checks - data_cons_in_scope_check dit - DerivSpecAnyClass{} - -> pure () - DerivSpecVia{} - -> atf_coerce_based_error_checks - where - -- When processing a standalone deriving declaration, check that all of the - -- constructors for the data type are in scope. For instance: - -- - -- import M (T) - -- deriving stock instance Eq T - -- - -- This should be rejected, as the derived Eq instance would need to refer - -- to the constructors for T, which are not in scope. - -- - -- Note that the only strategies that require this check are `stock` and - -- `newtype`. Neither `anyclass` nor `via` require it as the code that they - -- generate does not require using data constructors. - data_cons_in_scope_check :: DerivInstTys -> DerivM () - data_cons_in_scope_check (DerivInstTys { dit_tc = tc - , dit_rep_tc = rep_tc }) = do - standalone <- isStandaloneDeriv - when standalone $ do - let bale_out msg = do err <- derivingThingErrMechanism mechanism msg - lift $ failWithTc err - - rdr_env <- lift getGlobalRdrEnv - let data_con_names = map dataConName (tyConDataCons rep_tc) - hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && - (isAbstractTyCon rep_tc || - any not_in_scope data_con_names) - not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc) - - -- Make sure to also mark the data constructors as used so that GHC won't - -- mistakenly emit -Wunused-imports warnings about them. - lift $ addUsedDataCons rdr_env rep_tc - - unless (not hidden_data_cons) $ - bale_out $ derivingHiddenErr tc - - -- Ensure that a class's associated type variables are suitable for - -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is - -- only required for the `newtype` and `via` strategies. - -- - -- See Note [GND and associated type families] - atf_coerce_based_error_checks :: DerivM () - atf_coerce_based_error_checks = do - cls <- asks denv_cls - let bale_out msg = do err <- derivingThingErrMechanism mechanism msg - lift $ failWithTc err - - cls_tyvars = classTyVars cls - - ats_look_sensible - = -- Check (a) from Note [GND and associated type families] - no_adfs - -- Check (b) from Note [GND and associated type families] - && isNothing at_without_last_cls_tv - -- Check (d) from Note [GND and associated type families] - && isNothing at_last_cls_tv_in_kinds - - (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs - no_adfs = null adf_tcs - -- We cannot newtype-derive data family instances - - at_without_last_cls_tv - = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs - at_last_cls_tv_in_kinds - = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) - (tyConTyVars tc) - || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs - at_last_cls_tv_in_kind kind - = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind - at_tcs = classATs cls - last_cls_tv = ASSERT( notNull cls_tyvars ) - last cls_tyvars - - cant_derive_err - = vcat [ ppUnless no_adfs adfs_msg - , maybe empty at_without_last_cls_tv_msg - at_without_last_cls_tv - , maybe empty at_last_cls_tv_in_kinds_msg - at_last_cls_tv_in_kinds - ] - adfs_msg = text "the class has associated data types" - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") - unless ats_look_sensible $ bale_out cant_derive_err - -doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan - -> DerivSpecMechanism -> TcM () -doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism - = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst) - ; dflags <- getDynFlags - ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures - ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures - - -- Error if PartialTypeSignatures isn't enabled when a user tries - -- to write @deriving instance _ => Eq (Foo a)@. Or, if that - -- extension is enabled, give a warning if -Wpartial-type-signatures - -- is enabled. - ; case wildcard of - Nothing -> pure () - Just span -> setSrcSpan span $ do - checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) - warnTc (Reason Opt_WarnPartialTypeSignatures) - wpartial_sigs partial_sig_msg - - -- Check for Generic instances that are derived with an exotic - -- deriving strategy like DAC - -- See Note [Deriving strategies] - ; when (exotic_mechanism && className clas `elem` genericClassNames) $ - do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } - where - exotic_mechanism = not $ isDerivSpecStock mechanism - - partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) - - pts_suggestion - = text "To use the inferred type, enable PartialTypeSignatures" - - gen_inst_err = text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." - -derivingThingFailWith :: Bool -- If True, add a snippet about how not even - -- GeneralizedNewtypeDeriving would make this - -- declaration work. This only kicks in when - -- an explicit deriving strategy is not given. - -> SDoc -- The error message - -> DerivM a -derivingThingFailWith newtype_deriving msg = do - err <- derivingThingErrM newtype_deriving msg - lift $ failWithTc err - -genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class - -> [Type] -> [TyVar] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) -genDerivStuff mechanism loc clas inst_tys tyvars - = case mechanism of - -- See Note [Bindings for Generalised Newtype Deriving] - DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty} - -> gen_newtype_or_via rhs_ty - - -- Try a stock deriver - DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc} - , dsm_stock_gen_fn = gen_fn } - -> gen_fn loc rep_tc inst_tys - - -- Try DeriveAnyClass - DerivSpecAnyClass -> do - let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env - dflags <- getDynFlags - tyfam_insts <- - -- canDeriveAnyClass should ensure that this code can't be reached - -- unless -XDeriveAnyClass is enabled. - ASSERT2( isValid (canDeriveAnyClass dflags) - , ppr "genDerivStuff: bad derived class" <+> ppr clas ) - mapM (tcATDefault loc mini_subst emptyNameSet) - (classATItems clas) - return ( emptyBag -- No method bindings are needed... - , listToBag (map DerivFamInst (concat tyfam_insts)) - -- ...but we may need to generate binding for associated type - -- family default instances. - -- See Note [DeriveAnyClass and default family instances] - , [] ) - - -- Try DerivingVia - DerivSpecVia{dsm_via_ty = via_ty} - -> gen_newtype_or_via via_ty - where - gen_newtype_or_via ty = do - (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty - return (binds, faminsts, []) - -{- -Note [Bindings for Generalised Newtype Deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Eq a => C a where - f :: a -> a - newtype N a = MkN [a] deriving( C ) - instance Eq (N a) where ... - -The 'deriving C' clause generates, in effect - instance (C [a], Eq a) => C (N a) where - f = coerce (f :: [a] -> [a]) - -This generates a cast for each method, but allows the superclasse to -be worked out in the usual way. In this case the superclass (Eq (N -a)) will be solved by the explicit Eq (N a) instance. We do *not* -create the superclasses by casting the superclass dictionaries for the -representation type. - -See the paper "Safe zero-cost coercions for Haskell". - -Note [DeriveAnyClass and default family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When a class has a associated type family with a default instance, e.g.: - - class C a where - type T a - type T a = Char - -then there are a couple of scenarios in which a user would expect T a to -default to Char. One is when an instance declaration for C is given without -an implementation for T: - - instance C Int - -Another scenario in which this can occur is when the -XDeriveAnyClass extension -is used: - - data Example = Example deriving (C, Generic) - -In the latter case, we must take care to check if C has any associated type -families with default instances, because -XDeriveAnyClass will never provide -an implementation for them. We "fill in" the default instances using the -tcATDefault function from TcClassDcl (which is also used in TcInstDcls to -handle the empty instance declaration case). - -Note [Deriving strategies] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has a notion of deriving strategies, which allow the user to explicitly -request which approach to use when deriving an instance (enabled with the --XDerivingStrategies language extension). For more information, refer to the -original issue (#10598) or the associated wiki page: -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies - -A deriving strategy can be specified in a deriving clause: - - newtype Foo = MkFoo Bar - deriving newtype C - -Or in a standalone deriving declaration: - - deriving anyclass instance C Foo - --XDerivingStrategies also allows the use of multiple deriving clauses per data -declaration so that a user can derive some instance with one deriving strategy -and other instances with another deriving strategy. For example: - - newtype Baz = Baz Quux - deriving (Eq, Ord) - deriving stock (Read, Show) - deriving newtype (Num, Floating) - deriving anyclass C - -Currently, the deriving strategies are: - -* stock: Have GHC implement a "standard" instance for a data type, if possible - (e.g., Eq, Ord, Generic, Data, Functor, etc.) - -* anyclass: Use -XDeriveAnyClass - -* newtype: Use -XGeneralizedNewtypeDeriving - -* via: Use -XDerivingVia - -The latter two strategies (newtype and via) are referred to as the -"coerce-based" strategies, since they generate code that relies on the `coerce` -function. See, for instance, TcDerivInfer.inferConstraintsCoerceBased. - -The former two strategies (stock and anyclass), in contrast, are -referred to as the "originative" strategies, since they create "original" -instances instead of "reusing" old instances (by way of `coerce`). -See, for instance, TcDerivUtils.checkOriginativeSideConditions. - -If an explicit deriving strategy is not given, GHC has an algorithm it uses to -determine which strategy it will actually use. The algorithm is quite long, -so it lives in the Haskell wiki at -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies -("The deriving strategy resolution algorithm" section). - -Internally, GHC uses the DerivStrategy datatype to denote a user-requested -deriving strategy, and it uses the DerivSpecMechanism datatype to denote what -GHC will use to derive the instance after taking the above steps. In other -words, GHC will always settle on a DerivSpecMechnism, even if the user did not -ask for a particular DerivStrategy (using the algorithm linked to above). - -Note [Deriving instances for classes themselves] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Much of the code in TcDeriv assumes that deriving only works on data types. -But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly -reasonable to do something like this: - - {-# LANGUAGE DeriveAnyClass #-} - class C1 (a :: Constraint) where - class C2 where - deriving instance C1 C2 - -- This is equivalent to `instance C1 C2` - -If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock -deriving), we throw a special error message indicating that DeriveAnyClass is -the only way to go. We don't bother throwing this error if an explicit 'stock' -or 'newtype' keyword is used, since both options have their own perfectly -sensible error messages in the case of the above code (as C1 isn't a stock -derivable class, and C2 isn't a newtype). - -************************************************************************ -* * -\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} -* * -************************************************************************ --} - -nonUnaryErr :: LHsSigType GhcRn -> SDoc -nonUnaryErr ct = quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - -nonStdErr :: Class -> SDoc -nonStdErr cls = - quotes (ppr cls) - <+> text "is not a stock derivable class (Eq, Show, etc.)" - -gndNonNewtypeErr :: SDoc -gndNonNewtypeErr = - text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" - -derivingNullaryErr :: MsgDoc -derivingNullaryErr = text "Cannot derive instances for nullary classes" - -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc -derivingKindErr tc cls cls_tys cls_kind enough_args - = sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 gen1_suggestion - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - where - gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args - = text "(Perhaps you intended to use PolyKinds)" - | otherwise = Outputable.empty - -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc -derivingViaKindErr cls cls_kind via_ty via_kind - = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - -derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc -derivingEtaErr cls cls_tys inst_ty - = sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - -derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -derivingThingErr newtype_deriving cls cls_args mb_strat why - = derivingThingErr' newtype_deriving cls cls_args mb_strat - (maybe empty derivStrategyName mb_strat) why - -derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc -derivingThingErrM newtype_deriving why - = do DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why - -derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc -derivingThingErrMechanism mechanism why - = do DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat - (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why - -derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc -derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why - = sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] - where - strat_used = isJust mb_strat - extra | not strat_used, newtype_deriving - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred cls cls_args - via_mechanism | strat_used - = text "with the" <+> strat_msg <+> text "strategy" - | otherwise - = empty - -derivingHiddenErr :: TyCon -> SDoc -derivingHiddenErr tc - = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) - 2 (text "so you cannot derive an instance for it") - -standaloneCtxt :: LHsSigWcType GhcRn -> SDoc -standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") - 2 (quotes (ppr ty)) diff --git a/typecheck/TcDerivInfer.hs b/typecheck/TcDerivInfer.hs deleted file mode 100644 --- a/typecheck/TcDerivInfer.hs +++ /dev/null @@ -1,1071 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Functions for inferring (and simplifying) the context for derived instances. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import BasicTypes -import Class -import DataCon -import ErrUtils -import Inst -import Outputable -import Pair -import PrelNames -import TcDerivUtils -import TcEnv -import TcGenDeriv -import TcGenFunctor -import TcGenGenerics -import TcMType -import TcRnMonad -import TcOrigin -import Constraint -import Predicate -import TcType -import TyCon -import TyCoPpr (pprTyVars) -import Type -import TcSimplify -import TcValidity (validDerivPred) -import TcUnify (buildImplicationFor, checkConstraints) -import TysWiredIn (typeToTypeKind) -import Unify (tcUnifyTy) -import Util -import Var -import VarSet - -import Control.Monad -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.List (sortBy) -import Data.Maybe - ----------------------- - -inferConstraints :: DerivSpecMechanism - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) --- inferConstraints figures out the constraints needed for the --- instance declaration generated by a 'deriving' clause on a --- data type declaration. It also returns the new in-scope type --- variables and instance types, in case they were changed due to --- the presence of functor-like constraints. --- See Note [Inferring the instance context] - --- e.g. inferConstraints --- C Int (T [a]) -- Class and inst_tys --- :RTList a -- Rep tycon and its arg tys --- where T [a] ~R :RTList a --- --- Generate a sufficiently large set of constraints that typechecking the --- generated method definitions should succeed. This set will be simplified --- before being used in the instance declaration -inferConstraints mechanism - = do { DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType]) - infer_constraints = - case mechanism of - DerivSpecStock{dsm_stock_dit = dit} - -> inferConstraintsStock dit - DerivSpecAnyClass - -> infer_constraints_simple inferConstraintsAnyclass - DerivSpecNewtype { dsm_newtype_dit = - DerivInstTys{dit_cls_tys = cls_tys} - , dsm_newtype_rep_ty = rep_ty } - -> infer_constraints_simple $ - inferConstraintsCoerceBased cls_tys rep_ty - DerivSpecVia { dsm_via_cls_tys = cls_tys - , dsm_via_ty = via_ty } - -> infer_constraints_simple $ - inferConstraintsCoerceBased cls_tys via_ty - - -- Most deriving strategies do not need to do anything special to - -- the type variables and arguments to the class in the derived - -- instance, so they can pass through unchanged. The exception to - -- this rule is stock deriving. See - -- Note [Inferring the instance context]. - infer_constraints_simple - :: DerivM [ThetaOrigin] - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) - infer_constraints_simple infer_thetas = do - thetas <- infer_thetas - pure (thetas, tvs, inst_tys) - - -- Constraints arising from superclasses - -- See Note [Superclasses of derived instance] - cls_tvs = classTyVars main_cls - sc_constraints = ASSERT2( equalLength cls_tvs inst_tys - , ppr main_cls <+> ppr inst_tys ) - [ mkThetaOrigin (mkDerivOrigin wildcard) - TypeLevel [] [] [] $ - substTheta cls_subst (classSCTheta main_cls) ] - cls_subst = ASSERT( equalLength cls_tvs inst_tys ) - zipTvSubst cls_tvs inst_tys - - ; (inferred_constraints, tvs', inst_tys') <- infer_constraints - ; lift $ traceTc "inferConstraints" $ vcat - [ ppr main_cls <+> ppr inst_tys' - , ppr inferred_constraints - ] - ; return ( sc_constraints ++ inferred_constraints - , tvs', inst_tys' ) } - --- | Like 'inferConstraints', but used only in the case of the @stock@ deriving --- strategy. The constraints are inferred by inspecting the fields of each data --- constructor. In this example: --- --- > data Foo = MkFoo Int Char deriving Show --- --- We would infer the following constraints ('ThetaOrigin's): --- --- > (Show Int, Show Char) --- --- Note that this function also returns the type variables ('TyVar's) and --- class arguments ('TcType's) for the resulting instance. This is because --- when deriving 'Functor'-like classes, we must sometimes perform kind --- substitutions to ensure the resulting instance is well kinded, which may --- affect the type variables and class arguments. In this example: --- --- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) = --- > Compose (f (g a)) deriving stock Functor --- --- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance --- to be well kinded, so we return @[]@/@[Type, f, g]@ for the --- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. --- See Note [Inferring the instance context]. -inferConstraintsStock :: DerivInstTys - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) -inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args }) - = do DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - wildcard <- isStandaloneWildcardDeriv - - let inst_ty = mkTyConApp tc tc_args - tc_binders = tyConBinders rep_tc - choose_level bndr - | isNamedTyConBinder bndr = KindLevel - | otherwise = TypeLevel - t_or_ks = map choose_level tc_binders ++ repeat TypeLevel - -- want to report *kind* errors when possible - - -- Constraints arising from the arguments of each constructor - con_arg_constraints - :: (CtOrigin -> TypeOrKind - -> Type - -> [([PredOrigin], Maybe TCvSubst)]) - -> ([ThetaOrigin], [TyVar], [TcType]) - con_arg_constraints get_arg_constraints - = let (predss, mbSubsts) = unzip - [ preds_and_mbSubst - | data_con <- tyConDataCons rep_tc - , (arg_n, arg_t_or_k, arg_ty) - <- zip3 [1..] t_or_ks $ - dataConInstOrigArgTys data_con all_rep_tc_args - -- No constraints for unlifted types - -- See Note [Deriving and unboxed types] - , not (isUnliftedType arg_ty) - , let orig = DerivOriginDC data_con arg_n wildcard - , preds_and_mbSubst - <- get_arg_constraints orig arg_t_or_k arg_ty - ] - preds = concat predss - -- If the constraints require a subtype to be of kind - -- (* -> *) (which is the case for functor-like - -- constraints), then we explicitly unify the subtype's - -- kinds with (* -> *). - -- See Note [Inferring the instance context] - subst = foldl' composeTCvSubst - emptyTCvSubst (catMaybes mbSubsts) - unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst - && not (v `isInScope` subst)) tvs - (subst', _) = substTyVarBndrs subst unmapped_tvs - preds' = map (substPredOrigin subst') preds - inst_tys' = substTys subst' inst_tys - tvs' = tyCoVarsOfTypesWellScoped inst_tys' - in ([mkThetaOriginFromPreds preds'], tvs', inst_tys') - - is_generic = main_cls `hasKey` genClassKey - is_generic1 = main_cls `hasKey` gen1ClassKey - -- is_functor_like: see Note [Inferring the instance context] - is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind - || is_generic1 - - get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_gen1_constraints functor_cls orig t_or_k ty - = mk_functor_like_constraints orig t_or_k functor_cls $ - get_gen1_constrained_tys last_tv ty - - get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_std_constrained_tys orig t_or_k ty - | is_functor_like - = mk_functor_like_constraints orig t_or_k main_cls $ - deepSubtypesContaining last_tv ty - | otherwise - = [( [mk_cls_pred orig t_or_k main_cls ty] - , Nothing )] - - mk_functor_like_constraints :: CtOrigin -> TypeOrKind - -> Class -> [Type] - -> [([PredOrigin], Maybe TCvSubst)] - -- 'cls' is usually main_cls (Functor or Traversable etc), but if - -- main_cls = Generic1, then 'cls' can be Functor; see - -- get_gen1_constraints - -- - -- For each type, generate two constraints, - -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results - -- from unifying kind(ty) with * -> *. If the unification is - -- successful, it will ensure that the resulting instance is well - -- kinded. If not, the second constraint will result in an error - -- message which points out the kind mismatch. - -- See Note [Inferring the instance context] - mk_functor_like_constraints orig t_or_k cls - = map $ \ty -> let ki = tcTypeKind ty in - ( [ mk_cls_pred orig t_or_k cls ty - , mkPredOrigin orig KindLevel - (mkPrimEqPred ki typeToTypeKind) ] - , tcUnifyTy ki typeToTypeKind - ) - - rep_tc_tvs = tyConTyVars rep_tc - last_tv = last rep_tc_tvs - -- When we first gather up the constraints to solve, most of them - -- contain rep_tc_tvs, i.e., the type variables from the derived - -- datatype's type constructor. We don't want these type variables - -- to appear in the final instance declaration, so we must - -- substitute each type variable with its counterpart in the derived - -- instance. rep_tc_args lists each of these counterpart types in - -- the same order as the type variables. - all_rep_tc_args - = rep_tc_args ++ map mkTyVarTy - (drop (length rep_tc_args) rep_tc_tvs) - - -- Stupid constraints - stupid_constraints - = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $ - substTheta tc_subst (tyConStupidTheta rep_tc) ] - tc_subst = -- See the comment with all_rep_tc_args for an - -- explanation of this assertion - ASSERT( equalLength rep_tc_tvs all_rep_tc_args ) - zipTvSubst rep_tc_tvs all_rep_tc_args - - -- Extra Data constraints - -- The Data class (only) requires that for - -- instance (...) => Data (T t1 t2) - -- IF t1:*, t2:* - -- THEN (Data t1, Data t2) are among the (...) constraints - -- Reason: when the IF holds, we generate a method - -- dataCast2 f = gcast2 f - -- and we need the Data constraints to typecheck the method - extra_constraints = [mkThetaOriginFromPreds constrs] - where - constrs - | main_cls `hasKey` dataClassKey - , all (isLiftedTypeKind . tcTypeKind) rep_tc_args - = [ mk_cls_pred deriv_origin t_or_k main_cls ty - | (t_or_k, ty) <- zip t_or_ks rep_tc_args] - | otherwise - = [] - - mk_cls_pred orig t_or_k cls ty - -- Don't forget to apply to cls_tys' too - = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty])) - cls_tys' | is_generic1 = [] - -- In the awkward Generic1 case, cls_tys' should be - -- empty, since we are applying the class Functor. - - | otherwise = cls_tys - - deriv_origin = mkDerivOrigin wildcard - - if -- Generic constraints are easy - | is_generic - -> return ([], tvs, inst_tys) - - -- Generic1 needs Functor - -- See Note [Getting base classes] - | is_generic1 - -> ASSERT( rep_tc_tvs `lengthExceeds` 0 ) - -- Generic1 has a single kind variable - ASSERT( cls_tys `lengthIs` 1 ) - do { functorClass <- lift $ tcLookupClass functorClassName - ; pure $ con_arg_constraints - $ get_gen1_constraints functorClass } - - -- The others are a bit more complicated - | otherwise - -> -- See the comment with all_rep_tc_args for an explanation of - -- this assertion - ASSERT2( equalLength rep_tc_tvs all_rep_tc_args - , ppr main_cls <+> ppr rep_tc - $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args ) - do { let (arg_constraints, tvs', inst_tys') - = con_arg_constraints get_std_constrained_tys - ; lift $ traceTc "inferConstraintsStock" $ vcat - [ ppr main_cls <+> ppr inst_tys' - , ppr arg_constraints - ] - ; return ( stupid_constraints ++ extra_constraints - ++ arg_constraints - , tvs', inst_tys') } - --- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, --- which gathers its constraints based on the type signatures of the class's --- methods instead of the types of the data constructor's field. --- --- See Note [Gathering and simplifying constraints for DeriveAnyClass] --- for an explanation of how these constraints are used to determine the --- derived instance context. -inferConstraintsAnyclass :: DerivM [ThetaOrigin] -inferConstraintsAnyclass - = do { DerivEnv { denv_cls = cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - - ; let gen_dms = [ (sel_id, dm_ty) - | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - - cls_tvs = classTyVars cls - - do_one_meth :: (Id, Type) -> TcM ThetaOrigin - -- (Id,Type) are the selector Id and the generic default method type - -- NB: the latter is /not/ quantified over the class variables - -- See Note [Gathering and simplifying constraints for DeriveAnyClass] - do_one_meth (sel_id, gen_dm_ty) - = do { let (sel_tvs, _cls_pred, meth_ty) - = tcSplitMethodTy (varType sel_id) - meth_ty' = substTyWith sel_tvs inst_tys meth_ty - (meth_tvs, meth_theta, meth_tau) - = tcSplitNestedSigmaTys meth_ty' - - gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty - (dm_tvs, dm_theta, dm_tau) - = tcSplitNestedSigmaTys gen_dm_ty' - tau_eq = mkPrimEqPred meth_tau dm_tau - ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel - meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } - - ; theta_origins <- lift $ mapM do_one_meth gen_dms - ; return theta_origins } - --- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and --- @DerivingVia@. Since both strategies generate code involving 'coerce', the --- inferred constraints set up the scaffolding needed to typecheck those uses --- of 'coerce'. In this example: --- --- > newtype Age = MkAge Int deriving newtype Num --- --- We would infer the following constraints ('ThetaOrigin's): --- --- > (Num Int, Coercible Age Int) -inferConstraintsCoerceBased :: [Type] -> Type - -> DerivM [ThetaOrigin] -inferConstraintsCoerceBased cls_tys rep_ty = do - DerivEnv { denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys } <- ask - sa_wildcard <- isStandaloneWildcardDeriv - let -- The following functions are polymorphic over the representation - -- type, since we might either give it the underlying type of a - -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type - -- (for DerivingVia). - rep_tys ty = cls_tys ++ [ty] - rep_pred ty = mkClassPred cls (rep_tys ty) - rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty) - -- rep_pred is the representation dictionary, from where - -- we are going to get all the methods for the final - -- dictionary - deriv_origin = mkDerivOrigin sa_wildcard - - -- Next we collect constraints for the class methods - -- If there are no methods, we don't need any constraints - -- Otherwise we need (C rep_ty), for the representation methods, - -- and constraints to coerce each individual method - meth_preds :: Type -> [PredOrigin] - meth_preds ty - | null meths = [] -- No methods => no constraints - -- (#12814) - | otherwise = rep_pred_o ty : coercible_constraints ty - meths = classMethods cls - coercible_constraints ty - = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard) - TypeLevel (mkReprPrimEqPred t1 t2) - | meth <- meths - , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs - inst_tys ty meth ] - - all_thetas :: Type -> [ThetaOrigin] - all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty] - - pure (all_thetas rep_ty) - -{- Note [Inferring the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are two sorts of 'deriving', as represented by the two constructors -for DerivContext: - - * InferContext mb_wildcard: This can either be: - - The deriving clause for a data type. - (e.g, data T a = T1 a deriving( Eq )) - In this case, mb_wildcard = Nothing. - - A standalone declaration with an extra-constraints wildcard - (e.g., deriving instance _ => Eq (Foo a)) - In this case, mb_wildcard = Just loc, where loc is the location - of the extra-constraints wildcard. - - Here we must infer an instance context, - and generate instance declaration - instance Eq a => Eq (T a) where ... - - * SupplyContext theta: standalone deriving - deriving instance Eq a => Eq (T a) - Here we only need to fill in the bindings; - the instance context (theta) is user-supplied - -For the InferContext case, we must figure out the -instance context (inferConstraintsStock). Suppose we are inferring -the instance context for - C t1 .. tn (T s1 .. sm) -There are two cases - - * (T s1 .. sm) :: * (the normal case) - Then we behave like Eq and guess (C t1 .. tn t) - for each data constructor arg of type t. More - details below. - - * (T s1 .. sm) :: * -> * (the functor-like case) - Then we behave like Functor. - -In both cases we produce a bunch of un-simplified constraints -and them simplify them in simplifyInstanceContexts; see -Note [Simplifying the instance context]. - -In the functor-like case, we may need to unify some kind variables with * in -order for the generated instance to be well-kinded. An example from -#10524: - - newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) - = Compose (f (g a)) deriving Functor - -Earlier in the deriving pipeline, GHC unifies the kind of Compose f g -(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this -alone isn't enough, since k2 wasn't unified with *: - - instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) => - Functor (Compose f g) where ... - -The two Functor constraints are ill-kinded. To ensure this doesn't happen, we: - - 1. Collect all of a datatype's subtypes which require functor-like - constraints. - 2. For each subtype, create a substitution by unifying the subtype's kind - with (* -> *). - 3. Compose all the substitutions into one, then apply that substitution to - all of the in-scope type variables and the instance types. - -Note [Getting base classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Typeable are defined in package 'base', and that is not available -when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in -ghc-prim does not use Functor or Typeable implicitly via these lookups. - -Note [Deriving and unboxed types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have some special hacks to support things like - data T = MkT Int# deriving ( Show ) - -Specifically, we use TcGenDeriv.box to box the Int# into an Int -(which we know how to show), and append a '#'. Parentheses are not required -for unboxed values (`MkT -3#` is a valid expression). - -Note [Superclasses of derived instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, a derived instance decl needs the superclasses of the derived -class too. So if we have - data T a = ...deriving( Ord ) -then the initial context for Ord (T a) should include Eq (T a). Often this is -redundant; we'll also generate an Ord constraint for each constructor argument, -and that will probably generate enough constraints to make the Eq (T a) constraint -be satisfied too. But not always; consider: - - data S a = S - instance Eq (S a) - instance Ord (S a) - - data T a = MkT (S a) deriving( Ord ) - instance Num a => Eq (T a) - -The derived instance for (Ord (T a)) must have a (Num a) constraint! -Similarly consider: - data T a = MkT deriving( Data ) -Here there *is* no argument field, but we must nevertheless generate -a context for the Data instances: - instance Typeable a => Data (T a) where ... - - -************************************************************************ -* * - Finding the fixed point of deriving equations -* * -************************************************************************ - -Note [Simplifying the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T a b = C1 (Foo a) (Bar b) - | C2 Int (T b a) - | C3 (T a a) - deriving (Eq) - -We want to come up with an instance declaration of the form - - instance (Ping a, Pong b, ...) => Eq (T a b) where - x == y = ... - -It is pretty easy, albeit tedious, to fill in the code "...". The -trick is to figure out what the context for the instance decl is, -namely Ping, Pong and friends. - -Let's call the context reqd for the T instance of class C at types -(a,b, ...) C (T a b). Thus: - - Eq (T a b) = (Ping a, Pong b, ...) - -Now we can get a (recursive) equation from the data decl. This part -is done by inferConstraintsStock. - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - -Foo and Bar may have explicit instances for Eq, in which case we can -just substitute for them. Alternatively, either or both may have -their Eq instances given by deriving clauses, in which case they -form part of the system of equations. - -Now all we need do is simplify and solve the equations, iterating to -find the least fixpoint. This is done by simplifyInstanceConstraints. -Notice that the order of the arguments can -switch around, as here in the recursive calls to T. - -Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. - -We start with: - - Eq (T a b) = {} -- The empty set - -Next iteration: - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b u {} u {} u {} - = Eq a u Ping b - -Next iteration: - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b - u (Eq b u Ping a) - u (Eq a u Ping a) - - = Eq a u Ping b u Eq b u Ping a - -The next iteration gives the same result, so this is the fixpoint. We -need to make a canonical form of the RHS to ensure convergence. We do -this by simplifying the RHS to a form in which - - - the classes constrain only tyvars - - the list is sorted by tyvar (major key) and then class (minor key) - - no duplicates, of course - -Note [Deterministic simplifyInstanceContexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting -with nonDetCmpType puts the returned lists in a nondeterministic order. -If we were to return them, we'd get class constraints in -nondeterministic order. - -Consider: - - data ADT a b = Z a b deriving Eq - -The generated code could be either: - - instance (Eq a, Eq b) => Eq (Z a b) where - -Or: - - instance (Eq b, Eq a) => Eq (Z a b) where - -To prevent the order from being nondeterministic we only -canonicalize when comparing and return them in the same order as -simplifyDeriv returned them. -See also Note [nonDetCmpType nondeterminism] --} - - -simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]] - -> TcM [DerivSpec ThetaType] --- Used only for deriving clauses or standalone deriving with an --- extra-constraints wildcard (InferContext) --- See Note [Simplifying the instance context] - -simplifyInstanceContexts [] = return [] - -simplifyInstanceContexts infer_specs - = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs) - ; iterate_deriv 1 initial_solutions } - where - ------------------------------------------------------------------ - -- The initial solutions for the equations claim that each - -- instance has an empty context; this solution is certainly - -- in canonical form. - initial_solutions :: [ThetaType] - initial_solutions = [ [] | _ <- infer_specs ] - - ------------------------------------------------------------------ - -- iterate_deriv calculates the next batch of solutions, - -- compares it with the current one; finishes if they are the - -- same, otherwise recurses with the new solutions. - -- It fails if any iteration fails - iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] - iterate_deriv n current_solns - | n > 20 -- Looks as if we are in an infinite loop - -- This can happen if we have -XUndecidableInstances - -- (See TcSimplify.tcSimplifyDeriv.) - = pprPanic "solveDerivEqns: probable loop" - (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) - | otherwise - = do { -- Extend the inst info from the explicit instance decls - -- with the current set of solutions, and simplify each RHS - inst_specs <- zipWithM newDerivClsInst current_solns infer_specs - ; new_solns <- checkNoErrs $ - extendLocalInstEnv inst_specs $ - mapM gen_soln infer_specs - - ; if (current_solns `eqSolution` new_solns) then - return [ spec { ds_theta = soln } - | (spec, soln) <- zip infer_specs current_solns ] - else - iterate_deriv (n+1) new_solns } - - eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) - -- Canonicalise for comparison - -- See Note [Deterministic simplifyInstanceContexts] - canSolution = map (sortBy nonDetCmpType) - ------------------------------------------------------------------ - gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType - gen_soln (DS { ds_loc = loc, ds_tvs = tyvars - , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) - = setSrcSpan loc $ - addErrCtxt (derivInstCtxt the_pred) $ - do { theta <- simplifyDeriv the_pred tyvars deriv_rhs - -- checkValidInstance tyvars theta clas inst_tys - -- Not necessary; see Note [Exotic derived instance contexts] - - ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) - -- Claim: the result instance declaration is guaranteed valid - -- Hence no need to call: - -- checkValidInstance tyvars theta clas inst_tys - ; return theta } - where - the_pred = mkClassPred clas inst_tys - -derivInstCtxt :: PredType -> MsgDoc -derivInstCtxt pred - = text "When deriving the instance for" <+> parens (ppr pred) - -{- -*********************************************************************************** -* * -* Simplify derived constraints -* * -*********************************************************************************** --} - --- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much --- as possible. Fail if not possible. -simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are - -- deriving. Only used for SkolemInfo. - -> [TyVar] -- ^ The tyvars bound by @inst_ty@. - -> [ThetaOrigin] -- ^ Given and wanted constraints - -> TcM ThetaType -- ^ Needed constraints (after simplification), - -- i.e. @['PredType']@. -simplifyDeriv pred tvs thetas - = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - -- The constraint solving machinery - -- expects *TcTyVars* not TyVars. - -- We use *non-overlappable* (vanilla) skolems - -- See Note [Overlap and deriving] - - ; let skol_set = mkVarSet tvs_skols - skol_info = DerivSkol pred - doc = text "deriving" <+> parens (ppr pred) - - mk_given_ev :: PredType -> TcM EvVar - mk_given_ev given = - let given_pred = substTy skol_subst given - in newEvVar given_pred - - emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM () - emit_wanted_constraints metas_to_be preds - = do { -- We instantiate metas_to_be with fresh meta type - -- variables. Currently, these can only be type variables - -- quantified in generic default type signatures. - -- See Note [Gathering and simplifying constraints for - -- DeriveAnyClass] - (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be - - -- Now make a constraint for each of the instantiated predicates - ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst - mk_wanted_ct (PredOrigin wanted orig t_or_k) - = do { ev <- newWanted orig (Just t_or_k) $ - substTyUnchecked wanted_subst wanted - ; return (mkNonCanonical ev) } - ; cts <- mapM mk_wanted_ct preds - - -- And emit them into the monad - ; emitSimples (listToCts cts) } - - -- Create the implications we need to solve. For stock and newtype - -- deriving, these implication constraints will be simple class - -- constraints like (C a, Ord b). - -- But with DeriveAnyClass, we make an implication constraint. - -- See Note [Gathering and simplifying constraints for DeriveAnyClass] - mk_wanteds :: ThetaOrigin -> TcM WantedConstraints - mk_wanteds (ThetaOrigin { to_anyclass_skols = ac_skols - , to_anyclass_metas = ac_metas - , to_anyclass_givens = ac_givens - , to_wanted_origins = preds }) - = do { ac_given_evs <- mapM mk_given_ev ac_givens - ; (_, wanteds) - <- captureConstraints $ - checkConstraints skol_info ac_skols ac_given_evs $ - -- The checkConstraints bumps the TcLevel, and - -- wraps the wanted constraints in an implication, - -- when (but only when) necessary - emit_wanted_constraints ac_metas preds - ; pure wanteds } - - -- See [STEP DAC BUILD] - -- Generate the implication constraints, one for each method, to solve - -- with the skolemized variables. Start "one level down" because - -- we are going to wrap the result in an implication with tvs_skols, - -- in step [DAC RESIDUAL] - ; (tc_lvl, wanteds) <- pushTcLevelM $ - mapM mk_wanteds thetas - - ; traceTc "simplifyDeriv inputs" $ - vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ] - - -- See [STEP DAC SOLVE] - -- Simplify the constraints, starting at the same level at which - -- they are generated (c.f. the call to runTcSWithEvBinds in - -- simplifyInfer) - ; solved_wanteds <- setTcLevel tc_lvl $ - runTcSDeriveds $ - solveWantedsAndDrop $ - unionsWC wanteds - - -- It's not yet zonked! Obviously zonk it before peering at it - ; solved_wanteds <- zonkWC solved_wanteds - - -- See [STEP DAC HOIST] - -- Split the resulting constraints into bad and good constraints, - -- building an @unsolved :: WantedConstraints@ representing all - -- the constraints we can't just shunt to the predicates. - -- See Note [Exotic derived instance contexts] - ; let residual_simple = approximateWC True solved_wanteds - (bad, good) = partitionBagWith get_good residual_simple - - get_good :: Ct -> Either Ct PredType - get_good ct | validDerivPred skol_set p - , isWantedCt ct - = Right p - -- TODO: This is wrong - -- NB re 'isWantedCt': residual_wanted may contain - -- unsolved CtDerived and we stick them into the - -- bad set so that reportUnsolved may decide what - -- to do with them - | otherwise - = Left ct - where p = ctPred ct - - ; traceTc "simplifyDeriv outputs" $ - vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ] - - -- Return the good unsolved constraints (unskolemizing on the way out.) - ; let min_theta = mkMinimalBySCs id (bagToList good) - -- An important property of mkMinimalBySCs (used above) is that in - -- addition to removing constraints that are made redundant by - -- superclass relationships, it also removes _duplicate_ - -- constraints. - -- See Note [Gathering and simplifying constraints for - -- DeriveAnyClass] - subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs - -- The reverse substitution (sigh) - - -- See [STEP DAC RESIDUAL] - ; min_theta_vars <- mapM newEvVar min_theta - ; (leftover_implic, _) - <- buildImplicationFor tc_lvl skol_info tvs_skols - min_theta_vars solved_wanteds - -- This call to simplifyTop is purely for error reporting - -- See Note [Error reporting for deriving clauses] - -- See also Note [Exotic derived instance contexts], which are caught - -- in this line of code. - ; simplifyTopImplic leftover_implic - - ; return (substTheta subst_skol min_theta) } - -{- -Note [Overlap and deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider some overlapping instances: - instance Show a => Show [a] where .. - instance Show [Char] where ... - -Now a data type with deriving: - data T a = MkT [a] deriving( Show ) - -We want to get the derived instance - instance Show [a] => Show (T a) where... -and NOT - instance Show a => Show (T a) where... -so that the (Show (T Char)) instance does the Right Thing - -It's very like the situation when we're inferring the type -of a function - f x = show [x] -and we want to infer - f :: Show [a] => a -> String - -BOTTOM LINE: use vanilla, non-overlappable skolems when inferring - the context for the derived instance. - Hence tcInstSkolTyVars not tcInstSuperSkolTyVars - -Note [Gathering and simplifying constraints for DeriveAnyClass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DeriveAnyClass works quite differently from stock and newtype deriving in -the way it gathers and simplifies constraints to be used in a derived -instance's context. Stock and newtype deriving gather constraints by looking -at the data constructors of the data type for which we are deriving an -instance. But DeriveAnyClass doesn't need to know about a data type's -definition at all! - -To see why, consider this example of DeriveAnyClass: - - class Foo a where - bar :: forall b. Ix b => a -> b -> String - default bar :: (Show a, Ix c) => a -> c -> String - bar x y = show x ++ show (range (y,y)) - - baz :: Eq a => a -> a -> Bool - default baz :: (Ord a, Show a) => a -> a -> Bool - baz x y = compare x y == EQ - -Because 'bar' and 'baz' have default signatures, this generates a top-level -definition for these generic default methods - - $gdm_bar :: forall a. Foo a - => forall c. (Show a, Ix c) - => a -> c -> String - $gdm_bar x y = show x ++ show (range (y,y)) - -(and similarly for baz). Now consider a 'deriving' clause - data Maybe s = ... deriving Foo - -This derives an instance of the form: - instance (CX) => Foo (Maybe s) where - bar = $gdm_bar - baz = $gdm_baz - -Now it is GHC's job to fill in a suitable instance context (CX). If -GHC were typechecking the binding - bar = $gdm bar -it would - * skolemise the expected type of bar - * instantiate the type of $gdm_bar with meta-type variables - * build an implication constraint - -[STEP DAC BUILD] -So that's what we do. We build the constraint (call it C1) - - forall[2] b. Ix b => (Show (Maybe s), Ix cc, - Maybe s -> b -> String - ~ Maybe s -> cc -> String) - -Here: -* The level of this forall constraint is forall[2], because we are later - going to wrap it in a forall[1] in [STEP DAC RESIDUAL] - -* The 'b' comes from the quantified type variable in the expected type - of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification - variable that comes from instantiating the quantified type variable 'c' in - $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin). - -* The (Ix b) constraint comes from the context of bar's type - (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc) - constraints come from the context of $gdm_bar's type - (i.e., 'to_anyclass_givens' in 'ThetaOrigin'). - -* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String) - comes from marrying up the instantiated type of $gdm_bar with the specified - type of bar. Notice that the type variables from the instance, 's' in this - case, are global to this constraint. - -Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new -unification variable for each iteration of simplifyDeriv. If we re-use the same -unification variable across multiple iterations, then bad things can happen, -such as #14933. - -Similarly for 'baz', givng the constraint C2 - - forall[2]. Eq (Maybe s) => (Ord a, Show a, - Maybe s -> Maybe s -> Bool - ~ Maybe s -> Maybe s -> Bool) - -In this case baz has no local quantification, so the implication -constraint has no local skolems and there are no unification -variables. - -[STEP DAC SOLVE] -We can combine these two implication constraints into a single -constraint (C1, C2), and simplify, unifying cc:=b, to get: - - forall[2] b. Ix b => Show a - /\ - forall[2]. Eq (Maybe s) => (Ord a, Show a) - -[STEP DAC HOIST] -Let's call that (C1', C2'). Now we need to hoist the unsolved -constraints out of the implications to become our candidate for -(CX). That is done by approximateWC, which will return: - - (Show a, Ord a, Show a) - -Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving - - (Show a, Ord a) - -And that's what GHC uses for CX. - -[STEP DAC RESIDUAL] -In this case we have solved all the leftover constraints, but what if -we don't? Simple! We just form the final residual constraint - - forall[1] s. CX => (C1',C2') - -and simplify that. In simple cases it'll succeed easily, because CX -literally contains the constraints in C1', C2', but if there is anything -more complicated it will be reported in a civilised way. - -Note [Error reporting for deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A suprisingly tricky aspect of deriving to get right is reporting sensible -error messages. In particular, if simplifyDeriv reaches a constraint that it -cannot solve, which might include: - -1. Insoluble constraints -2. "Exotic" constraints (See Note [Exotic derived instance contexts]) - -Then we report an error immediately in simplifyDeriv. - -Another possible choice is to punt and let another part of the typechecker -(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead -to worse error messages, so we do it directly in simplifyDeriv. - -simplifyDeriv checks for errors in a clever way. If the deriving machinery -infers the context (Foo a)--that is, if this instance is to be generated: - - instance Foo a => ... - -Then we form an implication of the form: - - forall a. Foo a => - -And pass it to the simplifier. If the context (Foo a) is enough to discharge -all the constraints in , then everything is -hunky-dory. But if contains, say, an insoluble -constraint, then (Foo a) won't be able to solve it, causing GHC to error. - -Note [Exotic derived instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a 'derived' instance declaration, we *infer* the context. It's a -bit unclear what rules we should apply for this; the Haskell report is -silent. Obviously, constraints like (Eq a) are fine, but what about - data T f a = MkT (f a) deriving( Eq ) -where we'd get an Eq (f a) constraint. That's probably fine too. - -One could go further: consider - data T a b c = MkT (Foo a b c) deriving( Eq ) - instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) - -Notice that this instance (just) satisfies the Paterson termination -conditions. Then we *could* derive an instance decl like this: - - instance (C Int a, Eq b, Eq c) => Eq (T a b c) -even though there is no instance for (C Int a), because there just -*might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. - -However, this seems pretty exotic, and it's quite tricky to allow -this, and yet give sensible error messages in the (much more common) -case where we really want that instance decl for C. - -So for now we simply require that the derived instance context -should have only type-variable constraints. - -Here is another example: - data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -XUndecidableInstances we -could derive the instance - instance Eq (f (Fix f)) => Eq (Fix f) -but this is so delicate that I don't think it should happen inside -'deriving'. If you want this, write it yourself! - -NB: if you want to lift this condition, make sure you still meet the -termination conditions! If not, the deriving mechanism generates -larger and larger constraints. Example: - data Succ a = S a - data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show - -Note the lack of a Show instance for Succ. First we'll generate - instance (Show (Succ a), Show a) => Show (Seq a) -and then - instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) -and so on. Instead we want to complain of no instance for (Show (Succ a)). - -The bottom line -~~~~~~~~~~~~~~~ -Allow constraints which consist only of type variables, with no repeats. --} diff --git a/typecheck/TcDerivUtils.hs b/typecheck/TcDerivUtils.hs deleted file mode 100644 --- a/typecheck/TcDerivUtils.hs +++ /dev/null @@ -1,1112 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Error-checking and other utilities for @deriving@ clauses or declarations. --} - -{-# LANGUAGE TypeFamilies #-} - -module TcDerivUtils ( - DerivM, DerivEnv(..), - DerivSpec(..), pprDerivSpec, DerivInstTys(..), - DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, - isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, - DerivContext(..), OriginativeDerivStatus(..), - isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin, - PredOrigin(..), ThetaOrigin(..), mkPredOrigin, - mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, - checkOriginativeSideConditions, hasStockDeriving, - canDeriveAnyClass, - std_class_via_coercible, non_coercible_class, - newDerivClsInst, extendLocalInstEnv - ) where - -import GhcPrelude - -import Bag -import BasicTypes -import Class -import DataCon -import DynFlags -import ErrUtils -import HscTypes (lookupFixity, mi_fix) -import GHC.Hs -import Inst -import InstEnv -import LoadIface (loadInterfaceForName) -import Module (getModule) -import Name -import Outputable -import PrelNames -import SrcLoc -import TcGenDeriv -import TcGenFunctor -import TcGenGenerics -import TcOrigin -import TcRnMonad -import TcType -import THNames (liftClassKey) -import TyCon -import TyCoPpr (pprSourceTyCon) -import Type -import Util -import VarSet - -import Control.Monad.Trans.Reader -import Data.Maybe -import qualified GHC.LanguageExtensions as LangExt -import ListSetOps (assocMaybe) - --- | To avoid having to manually plumb everything in 'DerivEnv' throughout --- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which --- is a simple reader around 'TcRn'. -type DerivM = ReaderT DerivEnv TcRn - --- | Is GHC processing a standalone deriving declaration? -isStandaloneDeriv :: DerivM Bool -isStandaloneDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = True - --- | Is GHC processing a standalone deriving declaration with an --- extra-constraints wildcard as the context? --- (e.g., @deriving instance _ => Eq (Foo a)@) -isStandaloneWildcardDeriv :: DerivM Bool -isStandaloneWildcardDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = False - --- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', --- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. -mkDerivOrigin :: Bool -> CtOrigin -mkDerivOrigin standalone_wildcard - | standalone_wildcard = StandAloneDerivOrigin - | otherwise = DerivClauseOrigin - --- | Contains all of the information known about a derived instance when --- determining what its @EarlyDerivSpec@ should be. --- See @Note [DerivEnv and DerivSpecMechanism]@. -data DerivEnv = DerivEnv - { denv_overlap_mode :: Maybe OverlapMode - -- ^ Is this an overlapping instance? - , denv_tvs :: [TyVar] - -- ^ Universally quantified type variables in the instance - , denv_cls :: Class - -- ^ Class for which we need to derive an instance - , denv_inst_tys :: [Type] - -- ^ All arguments to to 'denv_cls' in the derived instance. - , denv_ctxt :: DerivContext - -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the - -- context of the instance). - -- 'InferContext' for @deriving@ clauses, or for standalone deriving that - -- uses a wildcard constraint. - -- See @Note [Inferring the instance context]@. - , denv_strat :: Maybe (DerivStrategy GhcTc) - -- ^ 'Just' if user requests a particular deriving strategy. - -- Otherwise, 'Nothing'. - } - -instance Outputable DerivEnv where - ppr (DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = ctxt - , denv_strat = mb_strat }) - = hang (text "DerivEnv") - 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode - , text "denv_tvs" <+> ppr tvs - , text "denv_cls" <+> ppr cls - , text "denv_inst_tys" <+> ppr inst_tys - , text "denv_ctxt" <+> ppr ctxt - , text "denv_strat" <+> ppr mb_strat ]) - -data DerivSpec theta = DS { ds_loc :: SrcSpan - , ds_name :: Name -- DFun name - , ds_tvs :: [TyVar] - , ds_theta :: theta - , ds_cls :: Class - , ds_tys :: [Type] - , ds_overlap :: Maybe OverlapMode - , ds_standalone_wildcard :: Maybe SrcSpan - -- See Note [Inferring the instance context] - -- in TcDerivInfer - , ds_mechanism :: DerivSpecMechanism } - -- This spec implies a dfun declaration of the form - -- df :: forall tvs. theta => C tys - -- The Name is the name for the DFun we'll build - -- The tyvars bind all the variables in the theta - - -- the theta is either the given and final theta, in standalone deriving, - -- or the not-yet-simplified list of constraints together with their origin - - -- ds_mechanism specifies the means by which GHC derives the instance. - -- See Note [Deriving strategies] in TcDeriv - -{- -Example: - - newtype instance T [a] = MkT (Tree a) deriving( C s ) -==> - axiom T [a] = :RTList a - axiom :RTList a = Tree a - - DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] - , ds_mechanism = DerivSpecNewtype (Tree a) } --} - -pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc -pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, - ds_tys = tys, ds_theta = rhs, - ds_standalone_wildcard = wildcard, ds_mechanism = mech }) - = hang (text "DerivSpec") - 2 (vcat [ text "ds_loc =" <+> ppr l - , text "ds_name =" <+> ppr n - , text "ds_tvs =" <+> ppr tvs - , text "ds_cls =" <+> ppr c - , text "ds_tys =" <+> ppr tys - , text "ds_theta =" <+> ppr rhs - , text "ds_standalone_wildcard =" <+> ppr wildcard - , text "ds_mechanism =" <+> ppr mech ]) - -instance Outputable theta => Outputable (DerivSpec theta) where - ppr = pprDerivSpec - --- | Information about the arguments to the class in a stock- or --- newtype-derived instance. --- See @Note [DerivEnv and DerivSpecMechanism]@. -data DerivInstTys = DerivInstTys - { dit_cls_tys :: [Type] - -- ^ Other arguments to the class except the last - , dit_tc :: TyCon - -- ^ Type constructor for which the instance is requested - -- (last arguments to the type class) - , dit_tc_args :: [Type] - -- ^ Arguments to the type constructor - , dit_rep_tc :: TyCon - -- ^ The representation tycon for 'dit_tc' - -- (for data family instances). Otherwise the same as 'dit_tc'. - , dit_rep_tc_args :: [Type] - -- ^ The representation types for 'dit_tc_args' - -- (for data family instances). Otherwise the same as 'dit_tc_args'. - } - -instance Outputable DerivInstTys where - ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args - , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args }) - = hang (text "DITTyConHead") - 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys - , text "dit_tc" <+> ppr tc - , text "dit_tc_args" <+> ppr tc_args - , text "dit_rep_tc" <+> ppr rep_tc - , text "dit_rep_tc_args" <+> ppr rep_tc_args ]) - --- | What action to take in order to derive a class instance. --- See @Note [DerivEnv and DerivSpecMechanism]@, as well as --- @Note [Deriving strategies]@ in "TcDeriv". -data DerivSpecMechanism - -- | \"Standard\" classes - = DerivSpecStock - { dsm_stock_dit :: DerivInstTys - -- ^ Information about the arguments to the class in the derived - -- instance, including what type constructor the last argument is - -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. - , dsm_stock_gen_fn :: - SrcSpan -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) - -- ^ This function returns three things: - -- - -- 1. @LHsBinds GhcPs@: The derived instance's function bindings - -- (e.g., @compare (T x) (T y) = compare x y@) - -- - -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived - -- instance. As examples, derived 'Generic' instances require - -- associated type family instances, and derived 'Eq' and 'Ord' - -- instances require top-level @con2tag@ functions. - -- See @Note [Auxiliary binders]@ in "TcGenDeriv". - -- - -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be - -- suppressed. This is used to suppress unused warnings for record - -- selectors when deriving 'Read', 'Show', or 'Generic'. - -- See @Note [Deriving and unused record selectors]@. - } - - -- | @GeneralizedNewtypeDeriving@ - | DerivSpecNewtype - { dsm_newtype_dit :: DerivInstTys - -- ^ Information about the arguments to the class in the derived - -- instance, including what type constructor the last argument is - -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. - , dsm_newtype_rep_ty :: Type - -- ^ The newtype rep type. - } - - -- | @DeriveAnyClass@ - | DerivSpecAnyClass - - -- | @DerivingVia@ - | DerivSpecVia - { dsm_via_cls_tys :: [Type] - -- ^ All arguments to the class besides the last one. - , dsm_via_inst_ty :: Type - -- ^ The last argument to the class. - , dsm_via_ty :: Type - -- ^ The @via@ type - } - --- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. -derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc -derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy -derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy -derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy -derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t - -isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia - :: DerivSpecMechanism -> Bool -isDerivSpecStock (DerivSpecStock{}) = True -isDerivSpecStock _ = False - -isDerivSpecNewtype (DerivSpecNewtype{}) = True -isDerivSpecNewtype _ = False - -isDerivSpecAnyClass DerivSpecAnyClass = True -isDerivSpecAnyClass _ = False - -isDerivSpecVia (DerivSpecVia{}) = True -isDerivSpecVia _ = False - -instance Outputable DerivSpecMechanism where - ppr (DerivSpecStock{dsm_stock_dit = dit}) - = hang (text "DerivSpecStock") - 2 (vcat [ text "dsm_stock_dit" <+> ppr dit ]) - ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty }) - = hang (text "DerivSpecNewtype") - 2 (vcat [ text "dsm_newtype_dit" <+> ppr dit - , text "dsm_newtype_rep_ty" <+> ppr rep_ty ]) - ppr DerivSpecAnyClass = text "DerivSpecAnyClass" - ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty - , dsm_via_ty = via_ty }) - = hang (text "DerivSpecVia") - 2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys - , text "dsm_via_inst_ty" <+> ppr inst_ty - , text "dsm_via_ty" <+> ppr via_ty ]) - -{- -Note [DerivEnv and DerivSpecMechanism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DerivEnv contains all of the bits and pieces that are common to every -deriving strategy. (See Note [Deriving strategies] in TcDeriv.) Some deriving -strategies impose stricter requirements on the types involved in the derived -instance than others, and these differences are factored out into the -DerivSpecMechanism type. Suppose that the derived instance looks like this: - - instance ... => C arg_1 ... arg_n - -Each deriving strategy imposes restrictions on arg_1 through arg_n as follows: - -* stock (DerivSpecStock): - - Stock deriving requires that: - - - n must be a positive number. This is checked by - TcDeriv.expectNonNullaryClsArgs - - arg_n must be an application of an algebraic type constructor. Here, - "algebraic type constructor" means: - - + An ordinary data type constructor, or - + A data family type constructor such that the arguments it is applied to - give rise to a data family instance. - - This is checked by TcDeriv.expectAlgTyConApp. - - This extra structure is witnessed by the DerivInstTys data type, which stores - arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor - (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type - constructor, then dit_rep_tc/dit_rep_tc_args are the same as - dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then - dit_rep_tc is the representation type constructor for the data family - instance, and dit_rep_tc_args are the arguments to the representation type - constructor in the corresponding instance. - -* newtype (DerivSpecNewtype): - - Newtype deriving imposes the same DerivInstTys requirements as stock - deriving. This is necessary because we need to know what the underlying type - that the newtype wraps is, and this information can only be learned by - knowing dit_rep_tc. - -* anyclass (DerivSpecAnyclass): - - DeriveAnyClass is the most permissive deriving strategy of all, as it - essentially imposes no requirements on the derived instance. This is because - DeriveAnyClass simply derives an empty instance, so it does not need any - particular knowledge about the types involved. It can do several things - that stock/newtype deriving cannot do (#13154): - - - n can be 0. That is, one is allowed to anyclass-derive an instance with - no arguments to the class, such as in this example: - - class C - deriving anyclass instance C - - - One can derive an instance for a type that is not headed by a type - constructor, such as in the following example: - - class C (n :: Nat) - deriving instance C 0 - deriving instance C 1 - ... - - - One can derive an instance for a data family with no data family instances, - such as in the following example: - - data family Foo a - class C a - deriving anyclass instance C (Foo a) - -* via (DerivSpecVia): - - Like newtype deriving, DerivingVia requires that n must be a positive number. - This is because when one derives something like this: - - deriving via Foo instance C Bar - - Then the generated code must specifically mention Bar. However, in - contrast with newtype deriving, DerivingVia does *not* require Bar to be - an application of an algebraic type constructor. This is because the - generated code simply defers to invoking `coerce`, which does not need to - know anything in particular about Bar (besides that it is representationally - equal to Foo). This allows DerivingVia to do some things that are not - possible with newtype deriving, such as deriving instances for data families - without data instances (#13154): - - data family Foo a - newtype ByBar a = ByBar a - class Baz a where ... - instance Baz (ByBar a) where ... - deriving via ByBar (Foo a) instance Baz (Foo a) --} - --- | Whether GHC is processing a @deriving@ clause or a standalone deriving --- declaration. -data DerivContext - = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either: - -- - -- * A @deriving@ clause (in which case - -- @mb_wildcard@ is 'Nothing'). - -- - -- * A standalone deriving declaration with - -- an extra-constraints wildcard as the - -- context (in which case @mb_wildcard@ is - -- @'Just' loc@, where @loc@ is the location - -- of the wildcard. - -- - -- GHC should infer the context. - - | SupplyContext ThetaType -- ^ @'SupplyContext' theta@ is a standalone - -- deriving declaration, where @theta@ is the - -- context supplied by the user. - -instance Outputable DerivContext where - ppr (InferContext standalone) = text "InferContext" <+> ppr standalone - ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta - --- | Records whether a particular class can be derived by way of an --- /originative/ deriving strategy (i.e., @stock@ or @anyclass@). --- --- See @Note [Deriving strategies]@ in "TcDeriv". -data OriginativeDerivStatus - = CanDeriveStock -- Stock class, can derive - (SrcSpan -> TyCon -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) - | StockClassError SDoc -- Stock class, but can't do it - | CanDeriveAnyClass -- See Note [Deriving any class] - | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass - --- A stock class is one either defined in the Haskell report or for which GHC --- otherwise knows how to generate code for (possibly requiring the use of a --- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) - --- | A 'PredType' annotated with the origin of the constraint 'CtOrigin', --- and whether or the constraint deals in types or kinds. -data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind - --- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to --- simplify when inferring a derived instance's context. These are used in all --- deriving strategies, but in the particular case of @DeriveAnyClass@, we --- need extra information. In particular, we need: --- --- * 'to_anyclass_skols', the list of type variables bound by a class method's --- regular type signature, which should be rigid. --- --- * 'to_anyclass_metas', the list of type variables bound by a class method's --- default type signature. These can be unified as necessary. --- --- * 'to_anyclass_givens', the list of constraints from a class method's --- regular type signature, which can be used to help solve constraints --- in the 'to_wanted_origins'. --- --- (Note that 'to_wanted_origins' will likely contain type variables from the --- derived type class or data type, neither of which will appear in --- 'to_anyclass_skols' or 'to_anyclass_metas'.) --- --- For all other deriving strategies, it is always the case that --- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are --- empty. --- --- Here is an example to illustrate this: --- --- @ --- class Foo a where --- bar :: forall b. Ix b => a -> b -> String --- default bar :: forall y. (Show a, Ix y) => a -> y -> String --- bar x y = show x ++ show (range (y, y)) --- --- baz :: Eq a => a -> a -> Bool --- default baz :: Ord a => a -> a -> Bool --- baz x y = compare x y == EQ --- --- data Quux q = Quux deriving anyclass Foo --- @ --- --- Then it would generate two 'ThetaOrigin's, one for each method: --- --- @ --- [ ThetaOrigin { to_anyclass_skols = [b] --- , to_anyclass_metas = [y] --- , to_anyclass_givens = [Ix b] --- , to_wanted_origins = [ Show (Quux q), Ix y --- , (Quux q -> b -> String) ~ --- (Quux q -> y -> String) --- ] } --- , ThetaOrigin { to_anyclass_skols = [] --- , to_anyclass_metas = [] --- , to_anyclass_givens = [Eq (Quux q)] --- , to_wanted_origins = [ Ord (Quux q) --- , (Quux q -> Quux q -> Bool) ~ --- (Quux q -> Quux q -> Bool) --- ] } --- ] --- @ --- --- (Note that the type variable @q@ is bound by the data type @Quux@, and thus --- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.) --- --- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@ --- in "TcDerivInfer" for an explanation of how 'to_wanted_origins' are --- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols', --- 'to_anyclass_metas', and 'to_anyclass_givens' are used. -data ThetaOrigin - = ThetaOrigin { to_anyclass_skols :: [TyVar] - , to_anyclass_metas :: [TyVar] - , to_anyclass_givens :: ThetaType - , to_wanted_origins :: [PredOrigin] } - -instance Outputable PredOrigin where - ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging - -instance Outputable ThetaOrigin where - ppr (ThetaOrigin { to_anyclass_skols = ac_skols - , to_anyclass_metas = ac_metas - , to_anyclass_givens = ac_givens - , to_wanted_origins = wanted_origins }) - = hang (text "ThetaOrigin") - 2 (vcat [ text "to_anyclass_skols =" <+> ppr ac_skols - , text "to_anyclass_metas =" <+> ppr ac_metas - , text "to_anyclass_givens =" <+> ppr ac_givens - , text "to_wanted_origins =" <+> ppr wanted_origins ]) - -mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin -mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k - -mkThetaOrigin :: CtOrigin -> TypeOrKind - -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType - -> ThetaOrigin -mkThetaOrigin origin t_or_k skols metas givens - = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k) - --- A common case where the ThetaOrigin only contains wanted constraints, with --- no givens or locally scoped type variables. -mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin -mkThetaOriginFromPreds = ThetaOrigin [] [] [] - -substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin -substPredOrigin subst (PredOrigin pred origin t_or_k) - = PredOrigin (substTy subst pred) origin t_or_k - -{- -************************************************************************ -* * - Class deriving diagnostics -* * -************************************************************************ - -Only certain blessed classes can be used in a deriving clause (without the -assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes -are listed below in the definition of hasStockDeriving. The stockSideConditions -function determines the criteria that needs to be met in order for a particular -stock class to be able to be derived successfully. - -A class might be able to be used in a deriving clause if -XDeriveAnyClass -is willing to support it. The canDeriveAnyClass function checks if this is the -case. --} - -hasStockDeriving - :: Class -> Maybe (SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) -hasStockDeriving clas - = assocMaybe gen_list (getUnique clas) - where - gen_list - :: [(Unique, SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))] - gen_list = [ (eqClassKey, simpleM gen_Eq_binds) - , (ordClassKey, simpleM gen_Ord_binds) - , (enumClassKey, simpleM gen_Enum_binds) - , (boundedClassKey, simple gen_Bounded_binds) - , (ixClassKey, simpleM gen_Ix_binds) - , (showClassKey, read_or_show gen_Show_binds) - , (readClassKey, read_or_show gen_Read_binds) - , (dataClassKey, simpleM gen_Data_binds) - , (functorClassKey, simple gen_Functor_binds) - , (foldableClassKey, simple gen_Foldable_binds) - , (traversableClassKey, simple gen_Traversable_binds) - , (liftClassKey, simple gen_Lift_binds) - , (genClassKey, generic (gen_Generic_binds Gen0)) - , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - - simple gen_fn loc tc _ - = let (binds, deriv_stuff) = gen_fn loc tc - in return (binds, deriv_stuff, []) - - simpleM gen_fn loc tc _ - = do { (binds, deriv_stuff) <- gen_fn loc tc - ; return (binds, deriv_stuff, []) } - - read_or_show gen_fn loc tc _ - = do { fix_env <- getDataConFixityFun tc - ; let (binds, deriv_stuff) = gen_fn fix_env loc tc - field_names = all_field_names tc - ; return (binds, deriv_stuff, field_names) } - - generic gen_fn _ tc inst_tys - = do { (binds, faminst) <- gen_fn tc inst_tys - ; let field_names = all_field_names tc - ; return (binds, unitBag (DerivFamInst faminst), field_names) } - - -- See Note [Deriving and unused record selectors] - all_field_names = map flSelector . concatMap dataConFieldLabels - . tyConDataCons - -{- -Note [Deriving and unused record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (see #13919): - - module Main (main) where - - data Foo = MkFoo {bar :: String} deriving Show - - main :: IO () - main = print (Foo "hello") - -Strictly speaking, the record selector `bar` is unused in this module, since -neither `main` nor the derived `Show` instance for `Foo` mention `bar`. -However, the behavior of `main` is affected by the presence of `bar`, since -it will print different output depending on whether `MkFoo` is defined using -record selectors or not. Therefore, we do not to issue a -"Defined but not used: ‘bar’" warning for this module, since removing `bar` -changes the program's behavior. This is the reason behind the [Name] part of -the return type of `hasStockDeriving`—it tracks all of the record selector -`Name`s for which -Wunused-binds should be suppressed. - -Currently, the only three stock derived classes that require this are Read, -Show, and Generic, as their derived code all depend on the record selectors -of the derived data type's constructors. - -See also Note [Newtype deriving and unused constructors] in TcDeriv for -another example of a similar trick. --} - -getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) --- If the TyCon is locally defined, we want the local fixity env; --- but if it is imported (which happens for standalone deriving) --- we need to get the fixity env from the interface file --- c.f. RnEnv.lookupFixity, and #9830 -getDataConFixityFun tc - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - then do { fix_env <- getFixityEnv - ; return (lookupFixity fix_env) } - else do { iface <- loadInterfaceForName doc name - -- Should already be loaded! - ; return (mi_fix iface . nameOccName) } } - where - name = tyConName tc - doc = text "Data con fixities for" <+> ppr name - ------------------------------------------------------------------- --- Check side conditions that dis-allow derivability for the originative --- deriving strategies (stock and anyclass). --- See Note [Deriving strategies] in TcDeriv for an explanation of what --- "originative" means. --- --- This is *apart* from the coerce-based strategies, newtype and via. --- --- Here we get the representation tycon in case of family instances as it has --- the data constructors - but we need to be careful to fall back to the --- family tycon (with indexes) in error messages. - -checkOriginativeSideConditions - :: DynFlags -> DerivContext -> Class -> [TcType] - -> TyCon -> TyCon - -> OriginativeDerivStatus -checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc - -- First, check if stock deriving is possible... - | Just cond <- stockSideConditions deriv_ctxt cls - = case (cond dflags tc rep_tc) of - NotValid err -> StockClassError err -- Class-specific error - IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) - -- All stock derivable classes are unary in the sense that - -- there should be not types in cls_tys (i.e., no type args - -- other than last). Note that cls_types can contain - -- invisible types as well (e.g., for Generic1, which is - -- poly-kinded), so make sure those are not counted. - , Just gen_fn <- hasStockDeriving cls - -> CanDeriveStock gen_fn - | otherwise -> StockClassError (classArgsErr cls cls_tys) - -- e.g. deriving( Eq s ) - - -- ...if not, try falling back on DeriveAnyClass. - | NotValid err <- canDeriveAnyClass dflags - = NonDerivableClass err -- Neither anyclass nor stock work - - | otherwise - = CanDeriveAnyClass -- DeriveAnyClass should work - -classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" - --- Side conditions (whether the datatype must have at least one constructor, --- required language extensions, etc.) for using GHC's stock deriving --- mechanism on certain classes (as opposed to classes that require --- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a --- class for which stock deriving isn't possible. -stockSideConditions :: DerivContext -> Class -> Maybe Condition -stockSideConditions deriv_ctxt cls - | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) - | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` - cond_vanilla `andCond` - cond_args cls) - | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` - cond_vanilla `andCond` - cond_functorOK True False) - | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` - cond_vanilla `andCond` - cond_functorOK False True) - -- Functor/Fold/Trav works ok - -- for rank-n types - | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` - cond_vanilla `andCond` - cond_functorOK False False) - | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_RepresentableOk) - | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_Representable1Ok) - | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` - cond_vanilla `andCond` - cond_args cls) - | otherwise = Nothing - where - cls_key = getUnique cls - cond_std = cond_stdOK deriv_ctxt False - -- Vanilla data constructors, at least one, and monotype arguments - cond_vanilla = cond_stdOK deriv_ctxt True - -- Vanilla data constructors but allow no data cons or polytype arguments - -canDeriveAnyClass :: DynFlags -> Validity --- IsValid: we can (try to) derive it via an empty instance declaration --- NotValid s: we can't, reason s -canDeriveAnyClass dflags - | not (xopt LangExt.DeriveAnyClass dflags) - = NotValid (text "Try enabling DeriveAnyClass") - | otherwise - = IsValid -- OK! - -type Condition - = DynFlags - - -> TyCon -- ^ The data type's 'TyCon'. For data families, this is the - -- family 'TyCon'. - - -> TyCon -- ^ For data families, this is the representation 'TyCon'. - -- Otherwise, this is the same as the other 'TyCon' argument. - - -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is - -- possible. Otherwise, it's @'NotValid' err@, where @err@ - -- explains what went wrong. - -orCond :: Condition -> Condition -> Condition -orCond c1 c2 dflags tc rep_tc - = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of - (IsValid, _) -> IsValid -- c1 succeeds - (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) - -- Both fail - -andCond :: Condition -> Condition -> Condition -andCond c1 c2 dflags tc rep_tc - = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc - --- | Some common validity checks shared among stock derivable classes. One --- check that absolutely must hold is that if an instance @C (T a)@ is being --- derived, then @T@ must be a tycon for a data type or a newtype. The --- remaining checks are only performed if using a @deriving@ clause (i.e., --- they're ignored if using @StandaloneDeriving@): --- --- 1. The data type must have at least one constructor (this check is ignored --- if using @EmptyDataDeriving@). --- --- 2. The data type cannot have any GADT constructors. --- --- 3. The data type cannot have any constructors with existentially quantified --- type variables. --- --- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@). --- --- 5. The data type cannot have fields with higher-rank types. -cond_stdOK - :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a - -- user-supplied context, 'InferContext' if not. - -- If it is the former, we relax some of the validity checks - -- we would otherwise perform (i.e., "just go for it"). - - -> Bool -- ^ 'True' <=> allow higher rank arguments and empty data - -- types (with no data constructors) even in the absence of - -- the -XEmptyDataDeriving extension. - - -> Condition -cond_stdOK deriv_ctxt permissive dflags tc rep_tc - = valid_ADT `andValid` valid_misc - where - valid_ADT, valid_misc :: Validity - valid_ADT - | isAlgTyCon tc || isDataFamilyTyCon tc - = IsValid - | otherwise - -- Complain about functions, primitive types, and other tycons that - -- stock deriving can't handle. - = NotValid $ text "The last argument of the instance must be a" - <+> text "data or newtype application" - - valid_misc - = case deriv_ctxt of - SupplyContext _ -> IsValid - -- Don't check these conservative conditions for - -- standalone deriving; just generate the code - -- and let the typechecker handle the result - InferContext wildcard - | null data_cons -- 1. - , not permissive - -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid` - NotValid (no_cons_why rep_tc $$ empty_data_suggestion) - | not (null con_whys) - -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard) - | otherwise - -> IsValid - - empty_data_suggestion = - text "Use EmptyDataDeriving to enable deriving for empty data types" - possible_fix_suggestion wildcard - = case wildcard of - Just _ -> - text "Possible fix: fill in the wildcard constraint yourself" - Nothing -> - text "Possible fix: use a standalone deriving declaration instead" - data_cons = tyConDataCons rep_tc - con_whys = getInvalids (map check_con data_cons) - - check_con :: DataCon -> Validity - check_con con - | not (null eq_spec) -- 2. - = bad "is a GADT" - | not (null ex_tvs) -- 3. - = bad "has existential type variables in its type" - | not (null theta) -- 4. - = bad "has constraints in its type" - | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5. - = bad "has a higher-rank type" - | otherwise - = IsValid - where - (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con - bad msg = NotValid (badCon con (text msg)) - -no_cons_why :: TyCon -> SDoc -no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - text "must have at least one data constructor" - -cond_RepresentableOk :: Condition -cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc - -cond_Representable1Ok :: Condition -cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc - -cond_enumOrProduct :: Class -> Condition -cond_enumOrProduct cls = cond_isEnumeration `orCond` - (cond_isProduct `andCond` cond_args cls) - -cond_args :: Class -> Condition --- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types --- by generating specialised code. For others (eg 'Data') we don't. --- For even others (eg 'Lift'), unlifted types aren't even a special --- consideration! -cond_args cls _ _ rep_tc - = case bad_args of - [] -> IsValid - (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) - where - bad_args = [ arg_ty | con <- tyConDataCons rep_tc - , arg_ty <- dataConOrigArgTys con - , isLiftedType_maybe arg_ty /= Just True - , not (ok_ty arg_ty) ] - - cls_key = classKey cls - ok_ty arg_ty - | cls_key == eqClassKey = check_in arg_ty ordOpTbl - | cls_key == ordClassKey = check_in arg_ty ordOpTbl - | cls_key == showClassKey = check_in arg_ty boxConTbl - | cls_key == liftClassKey = True -- Lift is levity-polymorphic - | otherwise = False -- Read, Ix etc - - check_in :: Type -> [(Type,a)] -> Bool - check_in arg_ty tbl = any (eqType arg_ty . fst) tbl - - -cond_isEnumeration :: Condition -cond_isEnumeration _ _ rep_tc - | isEnumerationTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] - -- See Note [Enumeration types] in TyCon - -cond_isProduct :: Condition -cond_isProduct _ _ rep_tc - | isProductTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = quotes (pprSourceTyCon rep_tc) <+> - text "must have precisely one constructor" - -cond_functorOK :: Bool -> Bool -> Condition --- OK for Functor/Foldable/Traversable class --- Currently: (a) at least one argument --- (b) don't use argument contravariantly --- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) --- (d) optionally: don't use function types --- (e) no "stupid context" on data type -cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc - | null tc_tvs - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters") - - | not (null bad_stupid_theta) - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) - - | otherwise - = allValid (map check_con data_cons) - where - tc_tvs = tyConTyVars rep_tc - last_tv = last tc_tvs - bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) - is_bad pred = last_tv `elemVarSet` exactTyCoVarsOfType pred - -- See Note [Check that the type variable is truly universal] - - data_cons = tyConDataCons rep_tc - check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - - check_universal :: DataCon -> Validity - check_universal con - | allowExQuantifiedLastTyVar - = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] - -- in TcGenFunctor - | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) - , tv `elem` dataConUnivTyVars con - , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) - = IsValid -- See Note [Check that the type variable is truly universal] - | otherwise - = NotValid (badCon con existential) - - ft_check :: DataCon -> FFoldType Validity - ft_check con = FT { ft_triv = IsValid, ft_var = IsValid - , ft_co_var = NotValid (badCon con covariant) - , ft_fun = \x y -> if allowFunctions then x `andValid` y - else NotValid (badCon con functions) - , ft_tup = \_ xs -> allValid xs - , ft_ty_app = \_ x -> x - , ft_bad_app = NotValid (badCon con wrong_arg) - , ft_forall = \_ x -> x } - - existential = text "must be truly polymorphic in the last argument of the data type" - covariant = text "must not use the type variable in a function argument" - functions = text "must not contain function types" - wrong_arg = text "must use the type variable only as the last argument of a data type" - -checkFlag :: LangExt.Extension -> Condition -checkFlag flag dflags _ _ - | xopt flag dflags = IsValid - | otherwise = NotValid why - where - why = text "You need " <> text flag_str - <+> text "to derive an instance for this class" - flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of - [s] -> s - other -> pprPanic "checkFlag" (ppr other) - -std_class_via_coercible :: Class -> Bool --- These standard classes can be derived for a newtype --- using the coercible trick *even if no -XGeneralizedNewtypeDeriving --- because giving so gives the same results as generating the boilerplate -std_class_via_coercible clas - = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] - -- Not Read/Show because they respect the type - -- Not Enum, because newtypes are never in Enum - - -non_coercible_class :: Class -> Bool --- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift --- by Coercible, even with -XGeneralizedNewtypeDeriving --- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived --- instance behave differently if there's a non-lawful Applicative out there. --- Besides, with roles, Coercible-deriving Traversable is ill-roled. -non_coercible_class cls - = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey - , genClassKey, gen1ClassKey, typeableClassKey - , traversableClassKey, liftClassKey ]) - -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg - ------------------------------------------------------------------- - -newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst -newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode - , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) - = newClsInst overlap_mode dfun_name tvs theta clas tys - -extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a --- Add new locally-defined instances; don't bother to check --- for functional dependency errors -- that'll happen in TcInstDcls -extendLocalInstEnv dfuns thing_inside - = do { env <- getGblEnv - ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns - env' = env { tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -{- -Note [Deriving any class] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Classic uses of a deriving clause, or a standalone-deriving declaration, are -for: - * a stock class like Eq or Show, for which GHC knows how to generate - the instance code - * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving - -The DeriveAnyClass extension adds a third way to derive instances, based on -empty instance declarations. - -The canonical use case is in combination with GHC.Generics and default method -signatures. These allow us to have instance declarations being empty, but still -useful, e.g. - - data T a = ...blah..blah... deriving( Generic ) - instance C a => C (T a) -- No 'where' clause - -where C is some "random" user-defined class. - -This boilerplate code can be replaced by the more compact - - data T a = ...blah..blah... deriving( Generic, C ) - -if DeriveAnyClass is enabled. - -This is not restricted to Generics; any class can be derived, simply giving -rise to an empty instance. - -See Note [Gathering and simplifying constraints for DeriveAnyClass] in -TcDerivInfer for an explanation hof how the instance context is inferred for -DeriveAnyClass. - -Note [Check that the type variable is truly universal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Functor and Traversable instances, we must check that the *last argument* -of the type constructor is used truly universally quantified. Example - - data T a b where - T1 :: a -> b -> T a b -- Fine! Vanilla H-98 - T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' - T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic - T4 :: Ord b => b -> T a b -- No! 'b' is constrained - T5 :: b -> T b b -- No! 'b' is constrained - T6 :: T a (b,b) -- No! 'b' is constrained - -Notice that only the first of these constructors is vanilla H-98. We only -need to take care about the last argument (b in this case). See #8678. -Eg. for T1-T3 we can write - - fmap f (T1 a b) = T1 a (f b) - fmap f (T2 b c) = T2 (f b) c - fmap f (T3 x) = T3 (f x) - -We need not perform these checks for Foldable instances, however, since -functions in Foldable can only consume existentially quantified type variables, -rather than produce them (as is the case in Functor and Traversable functions.) -As a result, T can have a derived Foldable instance: - - foldr f z (T1 a b) = f b z - foldr f z (T2 b c) = f b z - foldr f z (T3 x) = f x z - foldr f z (T4 x) = f x z - foldr f z (T5 x) = f x z - foldr _ z T6 = z - -See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor. - -For Functor and Traversable, we must take care not to let type synonyms -unfairly reject a type for not being truly universally quantified. An -example of this is: - - type C (a :: Constraint) b = a - data T a b = C (Show a) b => MkT b - -Here, the existential context (C (Show a) b) does technically mention the last -type variable b. But this is OK, because expanding the type synonym C would -give us the context (Show a), which doesn't mention b. Therefore, we must make -sure to expand type synonyms before performing this check. Not doing so led to -#13813. --} diff --git a/typecheck/TcEnv.hs b/typecheck/TcEnv.hs deleted file mode 100644 --- a/typecheck/TcEnv.hs +++ /dev/null @@ -1,1106 +0,0 @@ --- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an - -- orphan -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder -{-# LANGUAGE TypeFamilies #-} - -module TcEnv( - TyThing(..), TcTyThing(..), TcId, - - -- Instance environment, and InstInfo type - InstInfo(..), iDFunId, pprInstInfoDetails, - simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, - InstBindings(..), - - -- Global environment - tcExtendGlobalEnv, tcExtendTyConEnv, - tcExtendGlobalEnvImplicit, setGlobalTypeEnv, - tcExtendGlobalValEnv, - tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, - tcLookupTyCon, tcLookupClass, - tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, - tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, ioLookupDataCon, - addTypecheckedBinds, - - -- Local environment - tcExtendKindEnv, tcExtendKindEnvList, - tcExtendTyVarEnv, tcExtendNameTyVarEnv, - tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds, - tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, - tcExtendBinderStack, tcExtendLocalTypeEnv, - isTypeClosedLetBndr, - - tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupIdMaybe, tcLookupTyVar, - tcLookupTcTyCon, - tcLookupLcl_maybe, - getInLocalScope, - wrongThingErr, pprBinders, - - tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, - getTypeSigNames, - tcExtendRecEnv, -- For knot-tying - - -- Tidying - tcInitTidyEnv, tcInitOpenTidyEnv, - - -- Instances - tcLookupInstance, tcGetInstEnvs, - - -- Rules - tcExtendRules, - - -- Defaults - tcGetDefaultTys, - - -- Template Haskell stuff - checkWellStaged, tcMetaTy, thLevel, - topIdLvl, isBrackStage, - - -- New Ids - newDFunName, newFamInstTyConName, - newFamInstAxiomName, - mkStableIdFromString, mkStableIdFromName, - mkWrapperName - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import IfaceEnv -import TcRnMonad -import TcMType -import TcType -import LoadIface -import PrelNames -import TysWiredIn -import Id -import Var -import RdrName -import InstEnv -import DataCon ( DataCon ) -import PatSyn ( PatSyn ) -import ConLike -import TyCon -import Type -import CoAxiom -import Class -import Name -import NameSet -import NameEnv -import VarEnv -import HscTypes -import DynFlags -import SrcLoc -import BasicTypes hiding( SuccessFlag(..) ) -import Module -import Outputable -import Encoding -import FastString -import Bag -import ListSetOps -import ErrUtils -import Maybes( MaybeErr(..), orElse ) -import qualified GHC.LanguageExtensions as LangExt -import Util ( HasDebugCallStack ) - -import Data.IORef -import Data.List (intercalate) -import Control.Monad - -{- ********************************************************************* -* * - An IO interface to looking up globals -* * -********************************************************************* -} - -lookupGlobal :: HscEnv -> Name -> IO TyThing --- A variant of lookupGlobal_maybe for the clients which are not --- interested in recovering from lookup failure and accept panic. -lookupGlobal hsc_env name - = do { - mb_thing <- lookupGlobal_maybe hsc_env name - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> pprPanic "lookupGlobal" msg - } - -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) --- This may look up an Id that one one has previously looked up. --- If so, we are going to read its interface file, and add its bindings --- to the ExternalPackageTable. -lookupGlobal_maybe hsc_env name - = do { -- Try local envt - let mod = icInteractiveModule (hsc_IC hsc_env) - dflags = hsc_dflags hsc_env - tcg_semantic_mod = canonicalizeModuleIfHome dflags mod - - ; if nameIsLocalOrFrom tcg_semantic_mod name - then (return - (Failed (text "Can't find local name: " <+> ppr name))) - -- Internal names can happen in GHCi - else - -- Try home package table and external package table - lookupImported_maybe hsc_env name - } - -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) --- Returns (Failed err) if we can't find the interface file for the thing -lookupImported_maybe hsc_env name - = do { mb_thing <- lookupTypeHscEnv hsc_env name - ; case mb_thing of - Just thing -> return (Succeeded thing) - Nothing -> importDecl_maybe hsc_env name - } - -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) -importDecl_maybe hsc_env name - | Just thing <- wiredInNameTyThing_maybe name - = do { when (needWiredInHomeIface thing) - (initIfaceLoad hsc_env (loadWiredInHomeIface name)) - -- See Note [Loading instances for wired-in things] - ; return (Succeeded thing) } - | otherwise - = initIfaceLoad hsc_env (importDecl name) - -ioLookupDataCon :: HscEnv -> Name -> IO DataCon -ioLookupDataCon hsc_env name = do - mb_thing <- ioLookupDataCon_maybe hsc_env name - case mb_thing of - Succeeded thing -> return thing - Failed msg -> pprPanic "lookupDataConIO" msg - -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon) -ioLookupDataCon_maybe hsc_env name = do - thing <- lookupGlobal hsc_env name - return $ case thing of - AConLike (RealDataCon con) -> Succeeded con - _ -> Failed $ - pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+> - text "used as a data constructor" - -addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv -addTypecheckedBinds tcg_env binds - | isHsBootOrSig (tcg_src tcg_env) = tcg_env - -- Do not add the code for record-selector bindings - -- when compiling hs-boot files - | otherwise = tcg_env { tcg_binds = foldr unionBags - (tcg_binds tcg_env) - binds } - -{- -************************************************************************ -* * -* tcLookupGlobal * -* * -************************************************************************ - -Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, -unless you know that the SrcSpan in the monad is already set to the -span of the Name. --} - - -tcLookupLocatedGlobal :: Located Name -> TcM TyThing --- c.f. IfaceEnvEnv.tcIfaceGlobal -tcLookupLocatedGlobal name - = addLocM tcLookupGlobal name - -tcLookupGlobal :: Name -> TcM TyThing --- The Name is almost always an ExternalName, but not always --- In GHCi, we may make command-line bindings (ghci> let x = True) --- that bind a GlobalId, but with an InternalName -tcLookupGlobal name - = do { -- Try local envt - env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of { - Just thing -> return thing ; - Nothing -> - - -- Should it have been in the local envt? - -- (NB: use semantic mod here, since names never use - -- identity module, see Note [Identity versus semantic module].) - if nameIsLocalOrFrom (tcg_semantic_mod env) name - then notFound name -- Internal names can happen in GHCi - else - - -- Try home package table and external package table - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> failWithTc msg - }}} - --- Look up only in this module's global env't. Don't look in imports, etc. --- Panic if it's not there. -tcLookupGlobalOnly :: Name -> TcM TyThing -tcLookupGlobalOnly name - = do { env <- getGblEnv - ; return $ case lookupNameEnv (tcg_type_env env) name of - Just thing -> thing - Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) } - -tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon name = do - thing <- tcLookupGlobal name - case thing of - AConLike (RealDataCon con) -> return con - _ -> wrongThingErr "data constructor" (AGlobal thing) name - -tcLookupPatSyn :: Name -> TcM PatSyn -tcLookupPatSyn name = do - thing <- tcLookupGlobal name - case thing of - AConLike (PatSynCon ps) -> return ps - _ -> wrongThingErr "pattern synonym" (AGlobal thing) name - -tcLookupConLike :: Name -> TcM ConLike -tcLookupConLike name = do - thing <- tcLookupGlobal name - case thing of - AConLike cl -> return cl - _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name - -tcLookupClass :: Name -> TcM Class -tcLookupClass name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls - _ -> wrongThingErr "class" (AGlobal thing) name - -tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc -> return tc - _ -> wrongThingErr "type constructor" (AGlobal thing) name - -tcLookupAxiom :: Name -> TcM (CoAxiom Branched) -tcLookupAxiom name = do - thing <- tcLookupGlobal name - case thing of - ACoAxiom ax -> return ax - _ -> wrongThingErr "axiom" (AGlobal thing) name - -tcLookupLocatedGlobalId :: Located Name -> TcM Id -tcLookupLocatedGlobalId = addLocM tcLookupId - -tcLookupLocatedClass :: Located Name -> TcM Class -tcLookupLocatedClass = addLocM tcLookupClass - -tcLookupLocatedTyCon :: Located Name -> TcM TyCon -tcLookupLocatedTyCon = addLocM tcLookupTyCon - --- Find the instance that exactly matches a type class application. The class arguments must be precisely --- the same as in the instance declaration (modulo renaming & casts). --- -tcLookupInstance :: Class -> [Type] -> TcM ClsInst -tcLookupInstance cls tys - = do { instEnv <- tcGetInstEnvs - ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ text "Couldn't match instance:" <+> err - Right (inst, tys) - | uniqueTyVars tys -> return inst - | otherwise -> failWithTc errNotExact - } - where - errNotExact = text "Not an exact match (i.e., some variables get instantiated)" - - uniqueTyVars tys = all isTyVarTy tys - && hasNoDups (map (getTyVar "tcLookupInstance") tys) - -tcGetInstEnvs :: TcM InstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetInstEnvs = do { eps <- getEps - ; env <- getGblEnv - ; return (InstEnvs { ie_global = eps_inst_env eps - , ie_local = tcg_inst_env env - , ie_visible = tcVisibleOrphanMods env }) } - -instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where - lookupThing = tcLookupGlobal - -{- -************************************************************************ -* * - Extending the global environment -* * -************************************************************************ --} - -setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv --- Use this to update the global type env --- It updates both * the normal tcg_type_env field --- * the tcg_type_env_var field seen by interface files -setGlobalTypeEnv tcg_env new_type_env - = do { -- Sync the type-envt variable seen by interface files - writeMutVar (tcg_type_env_var tcg_env) new_type_env - ; return (tcg_env { tcg_type_env = new_type_env }) } - - -tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r - -- Just extend the global environment with some TyThings - -- Do not extend tcg_tcs, tcg_patsyns etc -tcExtendGlobalEnvImplicit things thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things - ; tcg_env' <- setGlobalTypeEnv tcg_env ge' - ; setGblEnv tcg_env' thing_inside } - -tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, - tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit things thing_inside - } - -tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendTyConEnv tycons thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside - } - -tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a - -- Same deal as tcExtendGlobalEnv, but for Ids -tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside - -tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r --- Extend the global environments for the type/class knot tying game --- Just like tcExtendGlobalEnv, except the argument is a list of pairs -tcExtendRecEnv gbl_stuff thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff - tcg_env' = tcg_env { tcg_type_env = ge' } - -- No need for setGlobalTypeEnv (which side-effects the - -- tcg_type_env_var); tcExtendRecEnv is used just - -- when kind-check a group of type/class decls. It would - -- in any case be wrong for an interface-file decl to end up - -- with a TcTyCon in it! - ; setGblEnv tcg_env' thing_inside } - -{- -************************************************************************ -* * -\subsection{The local environment} -* * -************************************************************************ --} - -tcLookupLocated :: Located Name -> TcM TcTyThing -tcLookupLocated = addLocM tcLookup - -tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) -tcLookupLcl_maybe name - = do { local_env <- getLclTypeEnv - ; return (lookupNameEnv local_env name) } - -tcLookup :: Name -> TcM TcTyThing -tcLookup name = do - local_env <- getLclTypeEnv - case lookupNameEnv local_env name of - Just thing -> return thing - Nothing -> AGlobal <$> tcLookupGlobal name - -tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name - = do { thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return tv - _ -> pprPanic "tcLookupTyVar" (ppr name) } - -tcLookupId :: Name -> TcM Id --- Used when we aren't interested in the binding level, nor refinement. --- The "no refinement" part means that we return the un-refined Id regardless --- --- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) -tcLookupId name = do - thing <- tcLookupIdMaybe name - case thing of - Just id -> return id - _ -> pprPanic "tcLookupId" (ppr name) - -tcLookupIdMaybe :: Name -> TcM (Maybe Id) -tcLookupIdMaybe name - = do { thing <- tcLookup name - ; case thing of - ATcId { tct_id = id} -> return $ Just id - AGlobal (AnId id) -> return $ Just id - _ -> return Nothing } - -tcLookupLocalIds :: [Name] -> TcM [TcId] --- We expect the variables to all be bound, and all at --- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns - = do { env <- getLclEnv - ; return (map (lookup (tcl_env env)) ns) } - where - lookup lenv name - = case lookupNameEnv lenv name of - Just (ATcId { tct_id = id }) -> id - _ -> pprPanic "tcLookupLocalIds" (ppr name) - -tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon -tcLookupTcTyCon name = do - thing <- tcLookup name - case thing of - ATcTyCon tc -> return tc - _ -> pprPanic "tcLookupTcTyCon" (ppr name) - -getInLocalScope :: TcM (Name -> Bool) -getInLocalScope = do { lcl_env <- getLclTypeEnv - ; return (`elemNameEnv` lcl_env) } - -tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r --- Used only during kind checking, for TcThings that are --- ATcTyCon or APromotionErr --- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr -tcExtendKindEnvList things thing_inside - = do { traceTc "tcExtendKindEnvList" (ppr things) - ; updLclEnv upd_env thing_inside } - where - upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } - -tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r --- A variant of tcExtendKindEvnList -tcExtendKindEnv extra_env thing_inside - = do { traceTc "tcExtendKindEnv" (ppr extra_env) - ; updLclEnv upd_env thing_inside } - where - upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } - ------------------------ --- Scoped type and kind variables -tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r -tcExtendTyVarEnv tvs thing_inside - = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside - -tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r -tcExtendNameTyVarEnv binds thing_inside - -- this should be used only for explicitly mentioned scoped variables. - -- thus, no coercion variables - = do { tc_extend_local_env NotTopLevel - [(name, ATyVar name tv) | (name, tv) <- binds] $ - tcExtendBinderStack tv_binds $ - thing_inside } - where - tv_binds :: [TcBinder] - tv_binds = [TcTvBndr name tv | (name,tv) <- binds] - -isTypeClosedLetBndr :: Id -> Bool --- See Note [Bindings with closed types] in TcRnTypes -isTypeClosedLetBndr = noFreeVarsOfType . idType - -tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a --- Used for binding the recurive uses of Ids in a binding --- both top-level value bindings and and nested let/where-bindings --- Does not extend the TcBinderStack -tcExtendRecIds pairs thing_inside - = tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = let_id - , tct_info = NonClosedLet emptyNameSet False }) - | (name, let_id) <- pairs ] $ - thing_inside - -tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a --- Used for binding the Ids that have a complete user type signature --- Does not extend the TcBinderStack -tcExtendSigIds top_lvl sig_ids thing_inside - = tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = info }) - | id <- sig_ids - , let closed = isTypeClosedLetBndr id - info = NonClosedLet emptyNameSet closed ] - thing_inside - - -tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed - -> [TcId] -> TcM a -> TcM a --- Used for both top-level value bindings and and nested let/where-bindings --- Adds to the TcBinderStack too -tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) - ids thing_inside - = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $ - tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = mk_tct_info id }) - | id <- ids ] - thing_inside - where - mk_tct_info id - | type_closed && isEmptyNameSet rhs_fvs = ClosedLet - | otherwise = NonClosedLet rhs_fvs type_closed - where - name = idName id - rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet - type_closed = isTypeClosedLetBndr id && - (fv_type_closed || hasCompleteSig sig_fn name) - -tcExtendIdEnv :: [TcId] -> TcM a -> TcM a --- For lambda-bound and case-bound Ids --- Extends the TcBinderStack as well -tcExtendIdEnv ids thing_inside - = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside - -tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a --- Exactly like tcExtendIdEnv2, but for a single (name,id) pair -tcExtendIdEnv1 name id thing_inside - = tcExtendIdEnv2 [(name,id)] thing_inside - -tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -tcExtendIdEnv2 names_w_ids thing_inside - = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel - | (_,mono_id) <- names_w_ids ] $ - tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = id - , tct_info = NotLetBound }) - | (name,id) <- names_w_ids] - thing_inside - -tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a -tc_extend_local_env top_lvl extra_env thing_inside --- Precondition: the argument list extra_env has TcTyThings --- that ATcId or ATyVar, but nothing else --- --- Invariant: the ATcIds are fully zonked. Reasons: --- (a) The kinds of the forall'd type variables are defaulted --- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar) --- (b) There are no via-Indirect occurrences of the bound variables --- in the types, because instantiation does not look through such things --- (c) The call to tyCoVarsOfTypes is ok without looking through refs - --- The second argument of type TyVarSet is a set of type variables --- that are bound together with extra_env and should not be regarded --- as free in the types of extra_env. - = do { traceTc "tc_extend_local_env" (ppr extra_env) - ; env0 <- getLclEnv - ; let env1 = tcExtendLocalTypeEnv env0 extra_env - ; stage <- getStage - ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1 - ; setLclEnv env2 thing_inside } - where - extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv - -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously - -- Reason for extending LocalRdrEnv: after running a TH splice we need - -- to do renaming. - extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env - , tcl_th_bndrs = th_bndrs }) - = env { tcl_rdr = extendLocalRdrEnvList rdr_env - [ n | (n, _) <- pairs, isInternalName n ] - -- The LocalRdrEnv contains only non-top-level names - -- (GlobalRdrEnv handles the top level) - , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs - [(n, thlvl) | (n, ATcId {}) <- pairs] } - -tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv -tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things - = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } - -{- ********************************************************************* -* * - The TcBinderStack -* * -********************************************************************* -} - -tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a -tcExtendBinderStack bndrs thing_inside - = do { traceTc "tcExtendBinderStack" (ppr bndrs) - ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) - thing_inside } - -tcInitTidyEnv :: TcM TidyEnv --- We initialise the "tidy-env", used for tidying types before printing, --- by building a reverse map from the in-scope type variables to the --- OccName that the programmer originally used for them -tcInitTidyEnv - = do { lcl_env <- getLclEnv - ; go emptyTidyEnv (tcl_bndrs lcl_env) } - where - go (env, subst) [] - = return (env, subst) - go (env, subst) (b : bs) - | TcTvBndr name tyvar <- b - = do { let (env', occ') = tidyOccName env (nameOccName name) - name' = tidyNameOcc name occ' - tyvar1 = setTyVarName tyvar name' - ; tyvar2 <- zonkTcTyVarToTyVar tyvar1 - -- Be sure to zonk here! Tidying applies to zonked - -- types, so if we don't zonk we may create an - -- ill-kinded type (#14175) - ; go (env', extendVarEnv subst tyvar tyvar2) bs } - | otherwise - = go (env, subst) bs - --- | Get a 'TidyEnv' that includes mappings for all vars free in the given --- type. Useful when tidying open types. -tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv -tcInitOpenTidyEnv tvs - = do { env1 <- tcInitTidyEnv - ; let env2 = tidyFreeTyCoVars env1 tvs - ; return env2 } - - - -{- ********************************************************************* -* * - Adding placeholders -* * -********************************************************************* -} - -tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a --- See Note [AFamDataCon: not promoting data family constructors] -tcAddDataFamConPlaceholders inst_decls thing_inside - = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) - | lid <- inst_decls, con <- get_cons lid ] - thing_inside - -- Note [AFamDataCon: not promoting data family constructors] - where - -- get_cons extracts the *constructor* bindings of the declaration - get_cons :: LInstDecl GhcRn -> [Name] - get_cons (L _ (TyFamInstD {})) = [] - get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid - get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) - = concatMap (get_fi_cons . unLoc) fids - get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec - get_cons (L _ (XInstDecl nec)) = noExtCon nec - - get_fi_cons :: DataFamInstDecl GhcRn -> [Name] - get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) - = map unLoc $ concatMap (getConNames . unLoc) cons - get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = XHsDataDefn nec }}}) - = noExtCon nec - get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec - get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec - - -tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a --- See Note [Don't promote pattern synonyms] -tcAddPatSynPlaceholders pat_syns thing_inside - = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) - | PSB{ psb_id = L _ name } <- pat_syns ] - thing_inside - -getTypeSigNames :: [LSig GhcRn] -> NameSet --- Get the names that have a user type sig -getTypeSigNames sigs - = foldr get_type_sig emptyNameSet sigs - where - get_type_sig :: LSig GhcRn -> NameSet -> NameSet - get_type_sig sig ns = - case sig of - L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names) - L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names) - _ -> ns - - -{- Note [AFamDataCon: not promoting data family constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a - data instance T Int = MkT - data Proxy (a :: k) - data S = MkS (Proxy 'MkT) - -Is it ok to use the promoted data family instance constructor 'MkT' in -the data declaration for S (where both declarations live in the same module)? -No, we don't allow this. It *might* make sense, but at least it would mean that -we'd have to interleave typechecking instances and data types, whereas at -present we do data types *then* instances. - -So to check for this we put in the TcLclEnv a binding for all the family -constructors, bound to AFamDataCon, so that if we trip over 'MkT' when -type checking 'S' we'll produce a decent error message. - -#12088 describes this limitation. Of course, when MkT and S live in -different modules then all is well. - -Note [Don't promote pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never promote pattern synonyms. - -Consider this (#11265): - pattern A = True - instance Eq A -We want a civilised error message from the occurrence of 'A' -in the instance, yet 'A' really has not yet been type checked. - -Similarly (#9161) - {-# LANGUAGE PatternSynonyms, DataKinds #-} - pattern A = () - b :: A - b = undefined -Here, the type signature for b mentions A. But A is a pattern -synonym, which is typechecked as part of a group of bindings (for very -good reasons; a view pattern in the RHS may mention a value binding). -It is entirely reasonable to reject this, but to do so we need A to be -in the kind environment when kind-checking the signature for B. - -Hence tcAddPatSynPlaceholers adds a binding - A -> APromotionErr PatSynPE -to the environment. Then TcHsType.tcTyVar will find A in the kind -environment, and will give a 'wrongThingErr' as a result. But the -lookup of A won't fail. - - -************************************************************************ -* * -\subsection{Rules} -* * -************************************************************************ --} - -tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a - -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not source - -- Nevertheless, some may be for this module, if we read - -- its interface instead of its source code -tcExtendRules lcl_rules thing_inside - = do { env <- getGblEnv - ; let - env' = env { tcg_rules = lcl_rules ++ tcg_rules env } - ; setGblEnv env' thing_inside } - -{- -************************************************************************ -* * - Meta level -* * -************************************************************************ --} - -checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level (increases inside brackets) - -> ThLevel -- Use stage - -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_lvl - | use_lvl >= bind_lvl -- OK! Used later than bound - = return () -- E.g. \x -> [| $(f x) |] - - | bind_lvl == outerLevel -- GHC restriction on top level splices - = stageRestrictionError pp_thing - - | otherwise -- Badly staged - = failWithTc $ -- E.g. \x -> $(f x) - text "Stage error:" <+> pp_thing <+> - hsep [text "is bound at stage" <+> ppr bind_lvl, - text "but used at stage" <+> ppr use_lvl] - -stageRestrictionError :: SDoc -> TcM a -stageRestrictionError pp_thing - = failWithTc $ - sep [ text "GHC stage restriction:" - , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," - , text "and must be imported, not defined locally"])] - -topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are prcessing the $(f x), the binding for "x" --- will be in the global env, not the local one. -topIdLvl id | isLocalId id = outerLevel - | otherwise = impLevel - -tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, --- return the type --- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name = do - t <- tcLookupTyCon tc_name - return (mkTyConApp t []) - -isBrackStage :: ThStage -> Bool -isBrackStage (Brack {}) = True -isBrackStage _other = False - -{- -************************************************************************ -* * - getDefaultTys -* * -************************************************************************ --} - -tcGetDefaultTys :: TcM ([Type], -- Default types - (Bool, -- True <=> Use overloaded strings - Bool)) -- True <=> Use extended defaulting rules -tcGetDefaultTys - = do { dflags <- getDynFlags - ; let ovl_strings = xopt LangExt.OverloadedStrings dflags - extended_defaults = xopt LangExt.ExtendedDefaultRules dflags - -- See also #1974 - flags = (ovl_strings, extended_defaults) - - ; mb_defaults <- getDeclaredDefaultTys - ; case mb_defaults of { - Just tys -> return (tys, flags) ; - -- User-supplied defaults - Nothing -> do - - -- No use-supplied default - -- Use [Integer, Double], plus modifications - { integer_ty <- tcMetaTy integerTyConName - ; list_ty <- tcMetaTy listTyConName - ; checkWiredInTyCon doubleTyCon - ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] - -- Note [Extended defaults] - ++ [integer_ty, doubleTy] - ++ opt_deflt ovl_strings [stringTy] - ; return (deflt_tys, flags) } } } - where - opt_deflt True xs = xs - opt_deflt False _ = [] - -{- -Note [Extended defaults] -~~~~~~~~~~~~~~~~~~~~~ -In interative mode (or with -XExtendedDefaultRules) we add () as the first type we -try when defaulting. This has very little real impact, except in the following case. -Consider: - Text.Printf.printf "hello" -This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't -want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to -default the 'a' to (), rather than to Integer (which is what would otherwise happen; -and then GHCi doesn't attempt to print the (). So in interactive mode, we add -() to the list of defaulting types. See #1200. - -Additionally, the list type [] is added as a default specialization for -Traversable and Foldable. As such the default default list now has types of -varying kinds, e.g. ([] :: * -> *) and (Integer :: *). - -************************************************************************ -* * -\subsection{The InstInfo type} -* * -************************************************************************ - -The InstInfo type summarises the information in an instance declaration - - instance c => k (t tvs) where b - -It is used just for *local* instance decls (not ones from interface files). -But local instance decls includes - - derived ones - - generic ones -as well as explicit user written ones. --} - -data InstInfo a - = InstInfo - { iSpec :: ClsInst -- Includes the dfun id - , iBinds :: InstBindings a - } - -iDFunId :: InstInfo a -> DFunId -iDFunId info = instanceDFunId (iSpec info) - -data InstBindings a - = InstBindings - { ib_tyvars :: [Name] -- Names of the tyvars from the instance head - -- that are lexically in scope in the bindings - -- Must correspond 1-1 with the forall'd tyvars - -- of the dfun Id. When typechecking, we are - -- going to extend the typechecker's envt with - -- ib_tyvars -> dfun_forall_tyvars - - , ib_binds :: LHsBinds a -- Bindings for the instance methods - - , ib_pragmas :: [LSig a] -- User pragmas recorded for generating - -- specialised instances - - , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should - -- be enabled when type-checking - -- this instance; needed for - -- GeneralizedNewtypeDeriving - - , ib_derived :: Bool - -- True <=> This code was generated by GHC from a deriving clause - -- or standalone deriving declaration - -- Used only to improve error messages - } - -instance (OutputableBndrId a) - => Outputable (InstInfo (GhcPass a)) where - ppr = pprInstInfoDetails - -pprInstInfoDetails :: (OutputableBndrId a) - => InstInfo (GhcPass a) -> SDoc -pprInstInfoDetails info - = hang (pprInstanceHdr (iSpec info) <+> text "where") - 2 (details (iBinds info)) - where - details (InstBindings { ib_binds = b }) = pprLHsBinds b - -simpleInstInfoClsTy :: InstInfo a -> (Class, Type) -simpleInstInfoClsTy info = case instanceHead (iSpec info) of - (_, cls, [ty]) -> (cls, ty) - _ -> panic "simpleInstInfoClsTy" - -simpleInstInfoTy :: InstInfo a -> Type -simpleInstInfoTy info = snd (simpleInstInfoClsTy info) - -simpleInstInfoTyCon :: InstInfo a -> TyCon - -- Gets the type constructor for a simple instance declaration, - -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) - --- | Make a name for the dict fun for an instance decl. It's an *external* --- name, like other top-level names, and hence must be made with --- newGlobalBinder. -newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name -newDFunName clas tys loc - = do { is_boot <- tcIsHsBootOrSig - ; mod <- getModule - ; let info_string = occNameString (getOccName clas) ++ - concatMap (occNameString.getDFunTyKey) tys - ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) - ; newGlobalBinder mod dfun_occ loc } - -newFamInstTyConName :: Located Name -> [Type] -> TcM Name -newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] - -newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name -newFamInstAxiomName (L loc name) branches - = mk_fam_inst_name mkInstTyCoOcc loc name branches - -mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name -mk_fam_inst_name adaptOcc loc tc_name tyss - = do { mod <- getModule - ; let info_string = occNameString (getOccName tc_name) ++ - intercalate "|" ty_strings - ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) - ; newGlobalBinder mod (adaptOcc occ) loc } - where - ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss - -{- -Stable names used for foreign exports and annotations. -For stable names, the name must be unique (see #1533). If the -same thing has several stable Ids based on it, the -top-level bindings generated must not have the same name. -Hence we create an External name (doesn't change), and we -append a Unique to the string right here. --} - -mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromString str sig_ty loc occ_wrapper = do - uniq <- newUnique - mod <- getModule - name <- mkWrapperName "stable" str - let occ = mkVarOccFS name :: OccName - gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name - id = mkExportedVanillaId gnm sig_ty :: Id - return id - -mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromName nm = mkStableIdFromString (getOccString nm) - -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) - => String -> String -> m FastString -mkWrapperName what nameBase - = do dflags <- getDynFlags - thisMod <- getModule - let -- Note [Generating fresh names for ccall wrapper] - wrapperRef = nextWrapperNum dflags - pkg = unitIdString (moduleUnitId thisMod) - mod = moduleNameString (moduleName thisMod) - wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> - let num = lookupWithDefaultModuleEnv mod_env 0 thisMod - mod_env' = extendModuleEnv mod_env thisMod (num+1) - in (mod_env', num) - let components = [what, show wrapperNum, pkg, mod, nameBase] - return $ mkFastString $ zEncodeString $ intercalate ":" components - -{- -Note [Generating fresh names for FFI wrappers] - -We used to use a unique, rather than nextWrapperNum, to distinguish -between FFI wrapper functions. However, the wrapper names that we -generate are external names. This means that if a call to them ends up -in an unfolding, then we can't alpha-rename them, and thus if the -unique randomly changes from one compile to another then we get a -spurious ABI change (#4012). - -The wrapper counter has to be per-module, not global, so that the number we end -up using is not dependent on the modules compiled before the current one. --} - -{- -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -pprBinders :: [Name] -> SDoc --- Used in error messages --- Use quotes for a single one; they look a bit "busy" for several -pprBinders [bndr] = quotes (ppr bndr) -pprBinders bndrs = pprWithCommas ppr bndrs - -notFound :: Name -> TcM TyThing -notFound name - = do { lcl_env <- getLclEnv - ; let stage = tcl_th_ctxt lcl_env - ; case stage of -- See Note [Out of scope might be a staging error] - Splice {} - | isUnboundName name -> failM -- If the name really isn't in scope - -- don't report it again (#11941) - | otherwise -> stageRestrictionError (quotes (ppr name)) - _ -> failWithTc $ - vcat[text "GHC internal error:" <+> quotes (ppr name) <+> - text "is not in scope during type checking, but it passed the renamer", - text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] - -- Take care: printing the whole gbl env can - -- cause an infinite loop, in the case where we - -- are in the middle of a recursive TyCon/Class group; - -- so let's just not print it! Getting a loop here is - -- very unhelpful, because it hides one compiler bug with another - } - -wrongThingErr :: String -> TcTyThing -> Name -> TcM a --- It's important that this only calls pprTcTyThingCategory, which in --- turn does not look at the details of the TcTyThing. --- See Note [Placeholder PatSyn kinds] in TcBinds -wrongThingErr expected thing name - = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) - -{- Note [Out of scope might be a staging error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = 3 - data T = MkT $(foo x) - -where 'foo' is imported from somewhere. - -This is really a staging error, because we can't run code involving 'x'. -But in fact the type checker processes types first, so 'x' won't even be -in the type envt when we look for it in $(foo x). So inside splices we -report something missing from the type env as a staging error. -See #5752 and #5795. --} diff --git a/typecheck/TcEnv.hs-boot b/typecheck/TcEnv.hs-boot deleted file mode 100644 --- a/typecheck/TcEnv.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module TcEnv where - -import TcRnTypes( TcM ) -import VarEnv( TidyEnv ) - --- Annoyingly, there's a recursion between tcInitTidyEnv --- (which does zonking and hence needs TcMType) and --- addErrTc etc which live in TcRnMonad. Rats. -tcInitTidyEnv :: TcM TidyEnv - diff --git a/typecheck/TcErrors.hs b/typecheck/TcErrors.hs deleted file mode 100644 --- a/typecheck/TcErrors.hs +++ /dev/null @@ -1,3127 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -module TcErrors( - reportUnsolved, reportAllUnsolved, warnAllUnsolved, - warnDefaulting, - - solverDepthErrorTcS - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -import TcRnMonad -import Constraint -import Predicate -import TcMType -import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) ) -import TcEnv( tcInitTidyEnv ) -import TcType -import TcOrigin -import RnUnbound ( unknownNameSuggestions ) -import Type -import TyCoRep -import TyCoPpr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) -import Unify ( tcMatchTys ) -import Module -import FamInst -import FamInstEnv ( flattenTys ) -import Inst -import InstEnv -import TyCon -import Class -import DataCon -import TcEvidence -import TcEvTerm -import GHC.Hs.Expr ( UnboundVar(..) ) -import GHC.Hs.Binds ( PatSynBind(..) ) -import Name -import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv - , mkRdrUnqual, isLocalGRE, greSrcSpan ) -import PrelNames ( typeableClassName ) -import Id -import Var -import VarSet -import VarEnv -import NameSet -import Bag -import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg ) -import BasicTypes -import ConLike ( ConLike(..)) -import Util -import FastString -import Outputable -import SrcLoc -import DynFlags -import ListSetOps ( equivClasses ) -import Maybes -import Pair -import qualified GHC.LanguageExtensions as LangExt -import FV ( fvVarList, unionFV ) - -import Control.Monad ( when ) -import Data.Foldable ( toList ) -import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr ) -import qualified Data.Set as Set - -import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits ) - --- import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup - - -{- -************************************************************************ -* * -\section{Errors and contexts} -* * -************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -Note [Deferring coercion errors to runtime] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While developing, sometimes it is desirable to allow compilation to succeed even -if there are type errors in the code. Consider the following case: - - module Main where - - a :: Int - a = 'a' - - main = print "b" - -Even though `a` is ill-typed, it is not used in the end, so if all that we're -interested in is `main` it is handy to be able to ignore the problems in `a`. - -Since we treat type equalities as evidence, this is relatively simple. Whenever -we run into a type mismatch in TcUnify, we normally just emit an error. But it -is always safe to defer the mismatch to the main constraint solver. If we do -that, `a` will get transformed into - - co :: Int ~ Char - co = ... - - a :: Int - a = 'a' `cast` co - -The constraint solver would realize that `co` is an insoluble constraint, and -emit an error with `reportUnsolved`. But we can also replace the right-hand side -of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program -to compile, and it will run fine unless we evaluate `a`. This is what -`deferErrorsToRuntime` does. - -It does this by keeping track of which errors correspond to which coercion -in TcErrors. TcErrors.reportTidyWanteds does not print the errors -and does not fail if -fdefer-type-errors is on, so that we can continue -compilation. The errors are turned into warnings in `reportUnsolved`. --} - --- | Report unsolved goals as errors or warnings. We may also turn some into --- deferred run-time errors if `-fdefer-type-errors` is on. -reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) -reportUnsolved wanted - = do { binds_var <- newTcEvBinds - ; defer_errors <- goptM Opt_DeferTypeErrors - ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 - ; let type_errors | not defer_errors = TypeError - | warn_errors = TypeWarn (Reason Opt_WarnDeferredTypeErrors) - | otherwise = TypeDefer - - ; defer_holes <- goptM Opt_DeferTypedHoles - ; warn_holes <- woptM Opt_WarnTypedHoles - ; let expr_holes | not defer_holes = HoleError - | warn_holes = HoleWarn - | otherwise = HoleDefer - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer - - ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables - ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables - ; let out_of_scope_holes | not defer_out_of_scope = HoleError - | warn_out_of_scope = HoleWarn - | otherwise = HoleDefer - - ; report_unsolved type_errors expr_holes - type_holes out_of_scope_holes - binds_var wanted - - ; ev_binds <- getTcEvBindsMap binds_var - ; return (evBindMapBinds ev_binds)} - --- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on --- However, do not make any evidence bindings, because we don't --- have any convenient place to put them. --- NB: Type-level holes are OK, because there are no bindings. --- See Note [Deferring coercion errors to runtime] --- Used by solveEqualities for kind equalities --- (see Note [Fail fast on kind errors] in TcSimplify) --- and for simplifyDefault. -reportAllUnsolved :: WantedConstraints -> TcM () -reportAllUnsolved wanted - = do { ev_binds <- newNoTcEvBinds - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer - - ; report_unsolved TypeError HoleError type_holes HoleError - ev_binds wanted } - --- | Report all unsolved goals as warnings (but without deferring any errors to --- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in --- TcSimplify -warnAllUnsolved :: WantedConstraints -> TcM () -warnAllUnsolved wanted - = do { ev_binds <- newTcEvBinds - ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn - ev_binds wanted } - --- | Report unsolved goals as errors or warnings. -report_unsolved :: TypeErrorChoice -- Deferred type errors - -> HoleChoice -- Expression holes - -> HoleChoice -- Type holes - -> HoleChoice -- Out of scope holes - -> EvBindsVar -- cec_binds - -> WantedConstraints -> TcM () -report_unsolved type_errors expr_holes - type_holes out_of_scope_holes binds_var wanted - | isEmptyWC wanted - = return () - | otherwise - = do { traceTc "reportUnsolved {" $ - vcat [ text "type errors:" <+> ppr type_errors - , text "expr holes:" <+> ppr expr_holes - , text "type holes:" <+> ppr type_holes - , text "scope holes:" <+> ppr out_of_scope_holes ] - ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) - - ; wanted <- zonkWC wanted -- Zonk to reveal all information - -- If we are deferring we are going to need /all/ evidence around, - -- including the evidence produced by unflattening (zonkWC) - ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs - free_tvs = tyCoVarsOfWCList wanted - - ; traceTc "reportUnsolved (after zonking):" $ - vcat [ text "Free tyvars:" <+> pprTyVars free_tvs - , text "Tidy env:" <+> ppr tidy_env - , text "Wanted:" <+> ppr wanted ] - - ; warn_redundant <- woptM Opt_WarnRedundantConstraints - ; let err_ctxt = CEC { cec_encl = [] - , cec_tidy = tidy_env - , cec_defer_type_errors = type_errors - , cec_expr_holes = expr_holes - , cec_type_holes = type_holes - , cec_out_of_scope_holes = out_of_scope_holes - , cec_suppress = insolubleWC wanted - -- See Note [Suppressing error messages] - -- Suppress low-priority errors if there - -- are insolule errors anywhere; - -- See #15539 and c.f. setting ic_status - -- in TcSimplify.setImplicationStatus - , cec_warn_redundant = warn_redundant - , cec_binds = binds_var } - - ; tc_lvl <- getTcLevel - ; reportWanteds err_ctxt tc_lvl wanted - ; traceTc "reportUnsolved }" empty } - --------------------------------------------- --- Internal functions --------------------------------------------- - --- | An error Report collects messages categorised by their importance. --- See Note [Error report] for details. -data Report - = Report { report_important :: [SDoc] - , report_relevant_bindings :: [SDoc] - , report_valid_hole_fits :: [SDoc] - } - -instance Outputable Report where -- Debugging only - ppr (Report { report_important = imp - , report_relevant_bindings = rel - , report_valid_hole_fits = val }) - = vcat [ text "important:" <+> vcat imp - , text "relevant:" <+> vcat rel - , text "valid:" <+> vcat val ] - -{- Note [Error report] -The idea is that error msgs are divided into three parts: the main msg, the -context block (\"In the second argument of ...\"), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -idea is that the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -The context is added when the Report is passed off to 'mkErrorReport'. -Unfortunately, unlike the context, the relevant bindings are added in -multiple places so they have to be in the Report. --} - -instance Semigroup Report where - Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) - -instance Monoid Report where - mempty = Report [] [] [] - mappend = (Semigroup.<>) - --- | Put a doc into the important msgs block. -important :: SDoc -> Report -important doc = mempty { report_important = [doc] } - --- | Put a doc into the relevant bindings block. -relevant_bindings :: SDoc -> Report -relevant_bindings doc = mempty { report_relevant_bindings = [doc] } - --- | Put a doc into the valid hole fits block. -valid_hole_fits :: SDoc -> Report -valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } - -data TypeErrorChoice -- What to do for type errors found by the type checker - = TypeError -- A type error aborts compilation with an error message - | TypeWarn WarnReason - -- A type error is deferred to runtime, plus a compile-time warning - -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors) - -- but it isn't for the Safe Haskell Overlapping Instances warnings - -- see warnAllUnsolved - | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time - -data HoleChoice - = HoleError -- A hole is a compile-time error - | HoleWarn -- Defer to runtime, emit a compile-time warning - | HoleDefer -- Defer to runtime, no warning - -instance Outputable HoleChoice where - ppr HoleError = text "HoleError" - ppr HoleWarn = text "HoleWarn" - ppr HoleDefer = text "HoleDefer" - -instance Outputable TypeErrorChoice where - ppr TypeError = text "TypeError" - ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason - ppr TypeDefer = text "TypeDefer" - -data ReportErrCtxt - = CEC { cec_encl :: [Implication] -- Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime - - -- cec_expr_holes is a union of: - -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' - -- cec_out_of_scope_holes - a set of variables which are - -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: HoleChoice -- Holes in expressions - , cec_type_holes :: HoleChoice -- Holes in types - , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes - - , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints - - , cec_suppress :: Bool -- True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -instance Outputable ReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_suppress" <+> equals <+> ppr sup ]) - --- | Returns True <=> the ReportErrCtxt indicates that something is deferred -deferringAnyBindings :: ReportErrCtxt -> Bool - -- Don't check cec_type_holes, as these don't cause bindings to be deferred -deferringAnyBindings (CEC { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError }) = False -deferringAnyBindings _ = True - --- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings --- at all. -noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt -noDeferredBindings ctxt = ctxt { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError } - -{- Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The cec_suppress flag says "don't report any errors". Instead, just create -evidence bindings (as usual). It's used when more important errors have occurred. - -Specifically (see reportWanteds) - * If there are insoluble Givens, then we are in unreachable code and all bets - are off. So don't report any further errors. - * If there are any insolubles (eg Int~Bool), here or in a nested implication, - then suppress errors from the simple constraints here. Sometimes the - simple-constraint errors are a knock-on effect of the insolubles. - -This suppression behaviour is controlled by the Bool flag in -ReportErrorSpec, as used in reportWanteds. - -But we need to take care: flags can turn errors into warnings, and we -don't want those warnings to suppress subsequent errors (including -suppressing the essential addTcEvBind for them: #15152). So in -tryReporter we use askNoErrs to see if any error messages were -/actually/ produced; if not, we don't switch on suppression. - -A consequence is that warnings never suppress warnings, so turning an -error into a warning may allow subsequent warnings to appear that were -previously suppressed. (e.g. partial-sigs/should_fail/T14584) --} - -reportImplic :: ReportErrCtxt -> Implication -> TcM () -reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope - , ic_given = given - , ic_wanted = wanted, ic_binds = evb - , ic_status = status, ic_info = info - , ic_tclvl = tc_lvl }) - | BracketSkol <- info - , not insoluble - = return () -- For Template Haskell brackets report only - -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints - - | otherwise - = do { traceTc "reportImplic" (ppr implic') - ; reportWanteds ctxt' tc_lvl wanted - ; when (cec_warn_redundant ctxt) $ - warnRedundantConstraints ctxt' tcl_env info' dead_givens - ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs } - where - tcl_env = ic_env implic - insoluble = isInsolubleStatus status - (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs - info' = tidySkolemInfo env1 info - implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_info = info' } - ctxt1 | CoEvBindsVar{} <- evb = noDeferredBindings ctxt - | otherwise = ctxt - -- If we go inside an implication that has no term - -- evidence (e.g. unifying under a forall), we can't defer - -- type errors. You could imagine using the /enclosing/ - -- bindings (in cec_binds), but that may not have enough stuff - -- in scope for the bindings to be well typed. So we just - -- switch off deferred type errors altogether. See #14605. - - ctxt' = ctxt1 { cec_tidy = env1 - , cec_encl = implic' : cec_encl ctxt - - , cec_suppress = insoluble || cec_suppress ctxt - -- Suppress inessential errors if there - -- are insolubles anywhere in the - -- tree rooted here, or we've come across - -- a suppress-worthy constraint higher up (#11541) - - , cec_binds = evb } - - dead_givens = case status of - IC_Solved { ics_dead = dead } -> dead - _ -> [] - - bad_telescope = case status of - IC_BadTelescope -> True - _ -> False - -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () --- See Note [Tracking redundant constraints] in TcSimplify -warnRedundantConstraints ctxt env info ev_vars - | null redundant_evs - = return () - - | SigSkol {} <- info - = setLclEnv env $ -- We want to add "In the type signature for f" - -- to the error context, which is a bit tiresome - addErrCtxt (text "In" <+> ppr info) $ - do { env <- getLclEnv - ; msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - - | otherwise -- But for InstSkol there already *is* a surrounding - -- "In the instance declaration for Eq [a]" context - -- and we don't want to say it twice. Seems a bit ad-hoc - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - where - doc = text "Redundant constraint" <> plural redundant_evs <> colon - <+> pprEvVarTheta redundant_evs - - redundant_evs = - filterOut is_type_error $ - case info of -- See Note [Redundant constraints in instance decls] - InstSkol -> filterOut (improving . idType) ev_vars - _ -> ev_vars - - -- See #15232 - is_type_error = isJust . userTypeError_maybe . idType - - improving pred -- (transSuperClasses p) does not include p - = any isImprovementPred (pred : transSuperClasses pred) - -reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM () -reportBadTelescope ctxt env (Just telescope) skols - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportError msg } - where - doc = hang (text "These kind and type variables:" <+> telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - - sorted_tvs = scopedSort skols - -reportBadTelescope _ _ Nothing skols - = pprPanic "reportBadTelescope" (ppr skols) - -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations, we don't report unused givens if -they can give rise to improvement. Example (#10100): - class Add a b ab | a b -> ab, a ab -> b - instance Add Zero b b - instance Add a b ab => Add (Succ a) b (Succ ab) -The context (Add a b ab) for the instance is clearly unused in terms -of evidence, since the dictionary has no fields. But it is still -needed! With the context, a wanted constraint - Add (Succ Zero) beta (Succ Zero) -we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. -But without the context we won't find beta := Zero. - -This only matters in instance declarations.. --} - -reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () -reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics }) - = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt)]) - ; traceTc "rw2" (ppr tidy_cts) - - -- First deal with things that are utterly wrong - -- Like Int ~ Bool (incl nullary TyCons) - -- or Int ~ t a (AppTy on one side) - -- These /ones/ are not suppressed by the incoming context - ; let ctxt_for_insols = ctxt { cec_suppress = False } - ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts - - -- Now all the other constraints. We suppress errors here if - -- any of the first batch failed, or if the enclosing context - -- says to suppress - ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 - ; MASSERT2( null leftovers, ppr leftovers ) - - -- All the Derived ones have been filtered out of simples - -- by the constraint solver. This is ok; we don't want - -- to report unsolved Derived goals as errors - -- See Note [Do not report derived but soluble errors] - - ; mapBagM_ (reportImplic ctxt2) implics } - -- NB ctxt1: don't suppress inner insolubles if there's only a - -- wanted insoluble here; but do suppress inner insolubles - -- if there's a *given* insoluble here (= inaccessible code) - where - env = cec_tidy ctxt - tidy_cts = bagToList (mapBag (tidyCt env) simples) - - -- report1: ones that should *not* be suppresed by - -- an insoluble somewhere else in the tree - -- It's crucial that anything that is considered insoluble - -- (see TcRnTypes.insolubleCt) is caught here, otherwise - -- we might suppress its error message, and proceed on past - -- type checking to get a Lint error later - report1 = [ ("Out of scope", is_out_of_scope, True, mkHoleReporter tidy_cts) - , ("Holes", is_hole, False, mkHoleReporter tidy_cts) - , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) - - , given_eq_spec - , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) - , ("skolem eq1", very_wrong, True, mkSkolReporter) - , ("skolem eq2", skolem_eq, True, mkSkolReporter) - , ("non-tv eq", non_tv_eq, True, mkSkolReporter) - - -- The only remaining equalities are alpha ~ ty, - -- where alpha is untouchable; and representational equalities - -- Prefer homogeneous equalities over hetero, because the - -- former might be holding up the latter. - -- See Note [Equalities with incompatible kinds] in TcCanonical - , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) - , ("Other eqs", is_equality, False, mkGroupReporter mkEqErr) ] - - -- report2: we suppress these if there are insolubles elsewhere in the tree - report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) - , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - - -- rigid_nom_eq, rigid_nom_tv_eq, - is_hole, is_dict, - is_equality, is_ip, is_irred :: Ct -> Pred -> Bool - - is_given_eq ct pred - | EqPred {} <- pred = arisesFromGivens ct - | otherwise = False - -- I think all given residuals are equalities - - -- Things like (Int ~N Bool) - utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 - utterly_wrong _ _ = False - - -- Things like (a ~N Int) - very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 - very_wrong _ _ = False - - -- Things like (a ~N b) or (a ~N F Bool) - skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 - skolem_eq _ _ = False - - -- Things like (F a ~N Int) - non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) - non_tv_eq _ _ = False - - is_out_of_scope ct _ = isOutOfScopeCt ct - is_hole ct _ = isHoleCt ct - - is_user_type_error ct _ = isUserTypeErrorCt ct - - is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 - is_homo_equality _ _ = False - - is_equality _ (EqPred {}) = True - is_equality _ _ = False - - is_dict _ (ClassPred {}) = True - is_dict _ _ = False - - is_ip _ (ClassPred cls _) = isIPClass cls - is_ip _ _ = False - - is_irred _ (IrredPred {}) = True - is_irred _ _ = False - - given_eq_spec -- See Note [Given errors] - | has_gadt_match (cec_encl ctxt) - = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) - | otherwise - = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) - -- False means don't suppress subsequent errors - -- Reason: we don't report all given errors - -- (see mkGivenErrorReporter), and we should only suppress - -- subsequent errors if we actually report this one! - -- #13446 is an example - - -- See Note [Given errors] - has_gadt_match [] = False - has_gadt_match (implic : implics) - | PatSkol {} <- ic_info implic - , not (ic_no_eqs implic) - , ic_warn_inaccessible implic - -- Don't bother doing this if -Winaccessible-code isn't enabled. - -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls. - = True - | otherwise - = has_gadt_match implics - ---------------- -isSkolemTy :: TcLevel -> Type -> Bool --- The type is a skolem tyvar -isSkolemTy tc_lvl ty - | Just tv <- getTyVar_maybe ty - = isSkolemTyVar tv - || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) - -- The last case is for touchable TyVarTvs - -- we postpone untouchables to a latter test (too obscure) - - | otherwise - = False - -isTyFun_maybe :: Type -> Maybe TyCon -isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) | isTypeFamilyTyCon tc -> Just tc - _ -> Nothing - --------------------------------------------- --- Reporters --------------------------------------------- - -type Reporter - = ReportErrCtxt -> [Ct] -> TcM () -type ReporterSpec - = ( String -- Name - , Ct -> Pred -> Bool -- Pick these ones - , Bool -- True <=> suppress subsequent reporters - , Reporter) -- The reporter itself - -mkSkolReporter :: Reporter --- Suppress duplicates with either the same LHS, or same location -mkSkolReporter ctxt cts - = mapM_ (reportGroup mkEqErr ctxt) (group cts) - where - group [] = [] - group (ct:cts) = (ct : yeses) : group noes - where - (yeses, noes) = partition (group_with ct) cts - - group_with ct1 ct2 - | EQ <- cmp_loc ct1 ct2 = True - | eq_lhs_type ct1 ct2 = True - | otherwise = False - -mkHoleReporter :: [Ct] -> Reporter --- Reports errors one at a time -mkHoleReporter tidy_simples ctxt - = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct - ; maybeReportHoleError ctxt ct err - ; maybeAddDeferredHoleBinding ctxt err ct } - -mkUserTypeErrorReporter :: Reporter -mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct - ; maybeReportError ctxt err - ; addDeferredBinding ctxt err ct } - -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct - $ important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) - - -mkGivenErrorReporter :: Reporter --- See Note [Given errors] -mkGivenErrorReporter ctxt cts - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; dflags <- getDynFlags - ; let (implic:_) = cec_encl ctxt - -- Always non-empty when mkGivenErrorReporter is called - ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) - -- For given constraints we overwrite the env (and hence src-loc) - -- with one from the immediately-enclosing implication. - -- See Note [Inaccessible code] - - inaccessible_msg = hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - report = important inaccessible_msg `mappend` - relevant_bindings binds_msg - - ; err <- mkEqErr_help dflags ctxt report ct' - Nothing ty1 ty2 - - ; traceTc "mkGivenErrorReporter" (ppr ct) - ; reportWarning (Reason Opt_WarnInaccessibleCode) err } - where - (ct : _ ) = cts -- Never empty - (ty1, ty2) = getEqPredTys (ctPred ct) - -ignoreErrorReporter :: Reporter --- Discard Given errors that don't come from --- a pattern match; maybe we should warn instead? -ignoreErrorReporter ctxt cts - = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) - ; return () } - - -{- Note [Given errors] -~~~~~~~~~~~~~~~~~~~~~~ -Given constraints represent things for which we have (or will have) -evidence, so they aren't errors. But if a Given constraint is -insoluble, this code is inaccessible, and we might want to at least -warn about that. A classic case is - - data T a where - T1 :: T Int - T2 :: T a - T3 :: T Bool - - f :: T Int -> Bool - f T1 = ... - f T2 = ... - f T3 = ... -- We want to report this case as inaccessible - -We'd like to point out that the T3 match is inaccessible. It -will have a Given constraint [G] Int ~ Bool. - -But we don't want to report ALL insoluble Given constraints. See Trac -#12466 for a long discussion. For example, if we aren't careful -we'll complain about - f :: ((Int ~ Bool) => a -> a) -> Int -which arguably is OK. It's more debatable for - g :: (Int ~ Bool) => Int -> Int -but it's tricky to distinguish these cases so we don't report -either. - -The bottom line is this: has_gadt_match looks for an enclosing -pattern match which binds some equality constraints. If we -find one, we report the insoluble Given. --} - -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) - -- Make error message for a group - -> Reporter -- Deal with lots of constraints --- Group together errors from same location, --- and report only the first (to avoid a cascade) -mkGroupReporter mk_err ctxt cts - = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - -eq_lhs_type :: Ct -> Ct -> Bool -eq_lhs_type ct1 ct2 - = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of - (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> - (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) - _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) - -cmp_loc :: Ct -> Ct -> Ordering -cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) - -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt - -> [Ct] -> TcM () -reportGroup mk_err ctxt cts = - case partition isMonadFailInstanceMissing cts of - -- Only warn about missing MonadFail constraint when - -- there are no other missing constraints! - (monadFailCts, []) -> - do { err <- mk_err ctxt monadFailCts - ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err } - - (_, cts') -> do { err <- mk_err ctxt cts' - ; traceTc "About to maybeReportErr" $ - vcat [ text "Constraint:" <+> ppr cts' - , text "cec_suppress =" <+> ppr (cec_suppress ctxt) - , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] - ; maybeReportError ctxt err - -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr cts') - ; mapM_ (addDeferredBinding ctxt err) cts' } - -- Add deferred bindings for all - -- Redundant if we are going to abort compilation, - -- but that's hard to know for sure, and if we don't - -- abort, we need bindings for all (e.g. #12156) - where - isMonadFailInstanceMissing ct = - case ctLocOrigin (ctLoc ct) of - FailablePattern _pat -> True - _otherwise -> False - -maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () --- Unlike maybeReportError, these "hole" errors are --- /not/ suppressed by cec_suppress. We want to see them! -maybeReportHoleError ctxt ct err - -- When -XPartialTypeSignatures is on, warnings (instead of errors) are - -- generated for holes in partial type signatures. - -- Unless -fwarn-partial-type-signatures is not on, - -- in which case the messages are discarded. - | isTypeHoleCt ct - = -- For partial type signatures, generate warnings only, and do that - -- only if -fwarn-partial-type-signatures is on - case cec_type_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err - HoleDefer -> return () - - -- Always report an error for out-of-scope variables - -- Unless -fdefer-out-of-scope-variables is on, - -- in which case the messages are discarded. - -- See #12170, #12406 - | isOutOfScopeCt ct - = -- If deferring, report a warning only if -Wout-of-scope-variables is on - case cec_out_of_scope_holes ctxt of - HoleError -> reportError err - HoleWarn -> - reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err - HoleDefer -> return () - - -- Otherwise this is a typed hole in an expression, - -- but not for an out-of-scope variable - | otherwise - = -- If deferring, report a warning only if -Wtyped-holes is on - case cec_expr_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err - HoleDefer -> return () - -maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () --- Report the error and/or make a deferred binding for it -maybeReportError ctxt err - | cec_suppress ctxt -- Some worse error has occurred; - = return () -- so suppress this error/warning - - | otherwise - = case cec_defer_type_errors ctxt of - TypeDefer -> return () - TypeWarn reason -> reportWarning reason err - TypeError -> reportError err - -addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () --- See Note [Deferring coercion errors to runtime] -addDeferredBinding ctxt err ct - | deferringAnyBindings ctxt - , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct - -- Only add deferred bindings for Wanted constraints - = do { dflags <- getDynFlags - ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" - err_tm = evDelayedError pred err_fs - ev_binds_var = cec_binds ctxt - - ; case dest of - EvVarDest evar - -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm - HoleDest hole - -> do { -- See Note [Deferred errors for coercion holes] - let co_var = coHoleCoVar hole - ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm - ; fillCoercionHole hole (mkTcCoVarCo co_var) }} - - | otherwise -- Do not set any evidence for Given/Derived - = return () - -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -maybeAddDeferredHoleBinding ctxt err ct - | isExprHoleCt ct - = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions - | otherwise -- not for holes in partial type signatures - = return () - -tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) --- Use the first reporter in the list whose predicate says True -tryReporters ctxt reporters cts - = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts - ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) - ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts - ; traceTc "tryReporters }" (ppr cts') - ; return (ctxt', cts') } - where - go ctxt [] vis_cts invis_cts - = return (ctxt, vis_cts ++ invis_cts) - - go ctxt (r : rs) vis_cts invis_cts - -- always look at *visible* Origins before invisible ones - -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts - ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts - ; go ctxt'' rs vis_cts' invis_cts' } - -- Carry on with the rest, because we must make - -- deferred bindings for them if we have -fdefer-type-errors - -- But suppress their error messages - -tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) cts - | null yeses - = return (ctxt, cts) - | otherwise - = do { traceTc "tryReporter{ " (text str <+> ppr yeses) - ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) - ; let suppress_now = not no_errs && suppress_after - -- See Note [Suppressing error messages] - ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } - ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) - ; return (ctxt', nos) } - where - (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts - - -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, Given -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising (GivenOrigin {}) = empty -pprArising orig = pprCtOrigin orig - --- Add the "arising from..." part to a message about bunch of dicts -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> (CtLoc, SDoc) --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = (loc, addArising (ctLocOrigin loc) - (pprTheta [ctPred ct])) - | otherwise - = (loc, vcat (map ppr_one (ct:cts))) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg -mkErrorMsgFromCt ctxt ct report - = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report - -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg -mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) - = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env)) - (errDoc important [context] (relevant_bindings ++ valid_subs)) - } - -type UserGiven = Implication - -getUserGivens :: ReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - -getUserGivensFromImplics :: [Implication] -> [UserGiven] -getUserGivensFromImplics implics - = reverse (filterOut (null . ic_given) implics) - -{- Note [Always warn with -fdefer-type-errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -fdefer-type-errors is on we warn about *all* type errors, even -if cec_suppress is on. This can lead to a lot more warnings than you -would get errors without -fdefer-type-errors, but if we suppress any of -them you might get a runtime error that wasn't warned about at compile -time. - -This is an easy design choice to change; just flip the order of the -first two equations for maybeReportError - -To be consistent, we should also report multiple warnings from a single -location in mkGroupReporter, when -fdefer-type-errors is on. But that -is perhaps a bit *over*-consistent! Again, an easy choice to change. - -With #10283, you can now opt out of deferred type error warnings. - -Note [Deferred errors for coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we need to defer a type error where the destination for the evidence -is a coercion hole. We can't just put the error in the hole, because we can't -make an erroneous coercion. (Remember that coercions are erased for runtime.) -Instead, we invent a new EvVar, bind it to an error and then make a coercion -from that EvVar, filling the hole with that coercion. Because coercions' -types are unlifted, the error is guaranteed to be hit before we get to the -coercion. - -Note [Do not report derived but soluble errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wc_simples include Derived constraints that have not been solved, -but are not insoluble (in that case they'd be reported by 'report1'). -We do not want to report these as errors: - -* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have - an unsolved [D] Eq a, and we do not want to report that; it's just noise. - -* Functional dependencies. For givens, consider - class C a b | a -> b - data T a where - MkT :: C a d => [d] -> T a - f :: C a b => T a -> F Int - f (MkT xs) = length xs - Then we get a [D] b~d. But there *is* a legitimate call to - f, namely f (MkT [True]) :: T Bool, in which b=d. So we should - not reject the program. - - For wanteds, something similar - data T a where - MkT :: C Int b => a -> b -> T a - g :: C Int c => c -> () - f :: T a -> () - f (MkT x y) = g x - Here we get [G] C Int b, [W] C Int a, hence [D] a~b. - But again f (MkT True True) is a legitimate call. - -(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose -derived superclasses between iterations of the solver.) - -For functional dependencies, here is a real example, -stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs - - class C a b | a -> b - g :: C a b => a -> b -> () - f :: C a b => a -> b -> () - f xa xb = - let loop = g xa - in loop xb - -We will first try to infer a type for loop, and we will succeed: - C a b' => b' -> () -Subsequently, we will type check (loop xb) and all is good. But, -recall that we have to solve a final implication constraint: - C a b => (C a b' => .... cts from body of loop .... )) -And now we have a problem as we will generate an equality b ~ b' and fail to -solve it. - - -************************************************************************ -* * - Irreducible predicate errors -* * -************************************************************************ --} - -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIrredErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - ----------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg -mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) }) - -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible - -- in-scope variables in the message, and note inaccessible exact matches - = do { dflags <- getDynFlags - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; let suggs_msg = unknownNameSuggestions dflags hpt curr_mod rdr_env0 - (tcl_rdr lcl_env) imp_info rdr - ; rdr_env <- getGlobalRdrEnv - ; splice_locs <- getTopLevelSpliceLocs - ; let match_msgs = mk_match_msgs rdr_env splice_locs - ; mkErrDocAt (RealSrcSpan err_loc) $ - errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) } - - where - rdr = mkRdrUnqual occ - ct_loc = ctLoc ct - lcl_env = ctLocEnv ct_loc - err_loc = tcl_loc lcl_env - hole_ty = ctEvPred (ctEvidence ct) - boring_type = isTyVarTy hole_ty - - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 (pp_with_type occ hole_ty) - - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - -- Indicate if the out-of-scope variable exactly (and unambiguously) matches - -- a top-level binding in a later inter-splice group; see Note [OutOfScope - -- exact matches] - mk_match_msgs rdr_env splice_locs - = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ) - in case gres of - [gre] - | RealSrcSpan bind_loc <- greSrcSpan gre - -- Find splice between the unbound variable and the match; use - -- lookupLE, not lookupLT, since match could be in the splice - , Just th_loc <- Set.lookupLE bind_loc splice_locs - , err_loc < th_loc - -> [mk_bind_scope_msg bind_loc th_loc] - _ -> [] - - mk_bind_scope_msg bind_loc th_loc - | is_th_bind - = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng)) - 2 (text "is not in scope before line" <+> int th_start_ln) - | otherwise - = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope") - 2 (text "before the splice on" <+> th_rng) - where - bind_rng = parens (text "line" <+> int bind_ln) - th_rng - | th_start_ln == th_end_ln = single - | otherwise = multi - single = text "line" <+> int th_start_ln - multi = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln - bind_ln = srcSpanStartLine bind_loc - th_start_ln = srcSpanStartLine th_loc - th_end_ln = srcSpanEndLine th_loc - is_th_bind = th_loc `containsSpan` bind_loc - -mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole }) - -- Explicit holes, like "_" or "_f" - = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct - -- The 'False' means "don't filter the bindings"; see #8191 - - ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let constraints_msg - | isExprHoleCt ct, show_hole_constraints - = givenConstraintsMsg ctxt - | otherwise = empty - - ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits - ; (ctxt, sub_msg) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples ct - else return (ctxt, empty) - ; mkErrorMsgFromCt ctxt ct $ - important hole_msg `mappend` - relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg} - - where - occ = holeOcc hole - hole_ty = ctEvPred (ctEvidence ct) - hole_kind = tcTypeKind hole_ty - tyvars = tyCoVarsOfTypeList hole_ty - - hole_msg = case hole of - ExprHole {} -> vcat [ hang (text "Found hole:") - 2 (pp_with_type occ hole_ty) - , tyvars_msg, expr_hole_hint ] - TypeHole {} -> vcat [ hang (text "Found type wildcard" <+> - quotes (ppr occ)) - 2 (text "standing for" <+> - quotes pp_hole_type_with_kind) - , tyvars_msg, type_hole_hint ] - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt skol_tvs) - where - (skol_tvs, other_tvs) = partition is_skol tyvars - is_skol tv = isTcTyVar tv && isSkolemTyVar tv - -- Coercion variables can be free in the - -- hole, via kind casts - - type_hole_hint - | HoleError <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitCoercions dflags - then quotes (ppr tv) <+> text "is a coercion variable" - else empty - -mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct) - --- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module --- imports -validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the - -- implications and the tidy environment - -> [Ct] -- Unsolved simple constraints - -> Ct -- The hole constraint. - -> TcM (ReportErrCtxt, SDoc) -- We return the new context - -- with a possibly updated - -- tidy environment, and - -- the message. -validHoleFits ctxt@(CEC {cec_encl = implics - , cec_tidy = lcl_env}) simps ct - = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct - ; return (ctxt {cec_tidy = tidy_env}, msg) } - --- See Note [Constraints include ...] -givenConstraintsMsg :: ReportErrCtxt -> SDoc -givenConstraintsMsg ctxt = - let constraints :: [(Type, RealSrcSpan)] - constraints = - do { implic@Implic{ ic_given = given } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } - - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - - in ppUnless (null constraints) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint constraints) - -pp_with_type :: OccName -> Type -> SDoc -pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty) - ----------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIPErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - preds = map ctPred cts - givens = getUserGivens ctxt - msg | null givens - = addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprParendTheta preds) ] - | otherwise - = couldNotDeduce givens (preds, orig) - - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - -{- - -Note [Constraints include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'givenConstraintsMsg' returns the "Constraints include ..." message enabled by --fshow-hole-constraints. For example, the following hole: - - foo :: (Eq a, Show a) => a -> String - foo x = _ - -would generate the message: - - Constraints include - Eq a (from foo.hs:1:1-36) - Show a (from foo.hs:1:1-36) - -Constraints are displayed in order from innermost (closest to the hole) to -outermost. There's currently no filtering or elimination of duplicates. - - -Note [OutOfScope exact matches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When constructing an out-of-scope error message, we not only generate a list of -possible in-scope alternatives but also search for an exact, unambiguous match -in a later inter-splice group. If we find such a match, we report its presence -(and indirectly, its scope) in the message. For example, if a module A contains -the following declarations, - - foo :: Int - foo = x - - $(return []) -- Empty top-level splice - - x :: Int - x = 23 - -we will issue an error similar to - - A.hs:6:7: error: - • Variable not in scope: x :: Int - • ‘x’ (line 11) is not in scope before the splice on line 8 - -By providing information about the match, we hope to clarify why declaring a -variable after a top-level splice but using it before the splice generates an -out-of-scope error (a situation which is often confusing to Haskell newcomers). - -Note that if we find multiple exact matches to the out-of-scope variable -(hereafter referred to as x), we report nothing. Such matches can only be -duplicate record fields, as the presence of any other duplicate top-level -declarations would have already halted compilation. But if these record fields -are declared in a later inter-splice group, then so too are their corresponding -types. Thus, these types must not occur in the inter-splice group containing x -(any unknown types would have already been reported), and so the matches to the -record fields are most likely coincidental. - -One oddity of the exact match portion of the error message is that we specify -where the match to x is NOT in scope. Why not simply state where the match IS -in scope? It most cases, this would be just as easy and perhaps a little -clearer for the user. But now consider the following example: - - {-# LANGUAGE TemplateHaskell #-} - - module A where - - import Language.Haskell.TH - import Language.Haskell.TH.Syntax - - foo = x - - $(do ------------------------------------------------- - ds <- [d| ok1 = x - |] - addTopDecls ds - return []) - - bar = $(do - ds <- [d| x = 23 - ok2 = x - |] - addTopDecls ds - litE $ stringL "hello") - - $(return []) ----------------------------------------- - - ok3 = x - -Here, x is out-of-scope in the declaration of foo, and so we report - - A.hs:8:7: error: - • Variable not in scope: x - • ‘x’ (line 16) is not in scope before the splice on lines 10-14 - -If we instead reported where x IS in scope, we would have to state that it is in -scope after the second top-level splice as well as among all the top-level -declarations added by both calls to addTopDecls. But doing so would not only -add complexity to the code but also overwhelm the user with unneeded -information. - -The logic which determines where x is not in scope is straightforward: it simply -finds the last top-level splice which occurs after x but before (or at) the -match to x (assuming such a splice exists). In most cases, the check that the -splice occurs after x acts only as a sanity check. For example, when the match -to x is a non-TH top-level declaration and a splice S occurs before the match, -then x must precede S; otherwise, it would be in scope. But when dealing with -addTopDecls, this check serves a practical purpose. Consider the following -declarations: - - $(do - ds <- [d| ok = x - x = 23 - |] - addTopDecls ds - return []) - - foo = x - -In this case, x is not in scope in the declaration for foo. Since x occurs -AFTER the splice containing the match, the logic does not find any splices after -x but before or at its match, and so we report nothing about x's scope. If we -had not checked whether x occurs before the splice, we would have instead -reported that x is not in scope before the splice. While correct, such an error -message is more likely to confuse than to enlighten. --} - -{- -************************************************************************ -* * - Equality errors -* * -************************************************************************ - -Note [Inaccessible code] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - T1 :: T a - T2 :: T Bool - - f :: (a ~ Int) => T a -> Int - f T1 = 3 - f T2 = 4 -- Unreachable code - -Here the second equation is unreachable. The original constraint -(a~Int) from the signature gets rewritten by the pattern-match to -(Bool~Int), so the danger is that we report the error as coming from -the *signature* (#7293). So, for Given errors we replace the -env (and hence src-loc) on its CtLoc with that from the immediately -enclosing implication. - -Note [Error messages for untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#9109) - data G a where { GBool :: G Bool } - foo x = case x of GBool -> True - -Here we can't solve (t ~ Bool), where t is the untouchable result -meta-var 't', because of the (a ~ Bool) from the pattern match. -So we infer the type - f :: forall a t. G a -> t -making the meta-var 't' into a skolem. So when we come to report -the unsolved (t ~ Bool), t won't look like an untouchable meta-var -any more. So we don't assert that it is. --} - --- Don't have multiple equality errors from the same location --- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct -mkEqErr _ [] = panic "mkEqErr" - -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkEqErr1 ctxt ct -- Wanted or derived; - -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; rdr_env <- getGlobalRdrEnv - ; fam_envs <- tcGetFamInstEnvs - ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let (keep_going, is_oriented, wanted_msg) - = mk_wanted_extra (ctLoc ct) exp_syns - coercible_msg = case ctEqRel ct of - NomEq -> empty - ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - ; dflags <- getDynFlags - ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going) - ; let report = mconcat [important wanted_msg, important coercible_msg, - relevant_bindings binds_msg] - ; if keep_going - then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 - else mkErrorMsgFromCt ctxt ct report } - where - (ty1, ty2) = getEqPredTys (ctPred ct) - - -- If the types in the error message are the same as the types - -- we are unifying, don't add the extra expected/actual message - mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc) - mk_wanted_extra loc expandSyns - = case ctLocOrigin loc of - orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig - t_or_k expandSyns - where - t_or_k = ctLocTypeOrKind_maybe loc - - KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k - -> (True, Nothing, msg1 $$ msg2) - where - sub_what = case sub_t_or_k of Just KindLevel -> text "kinds" - _ -> text "types" - msg1 = sdocWithDynFlags $ \dflags -> - case mb_cty2 of - Just cty2 - | gopt Opt_PrintExplicitCoercions dflags - || not (cty1 `pickyEqType` cty2) - -> hang (text "When matching" <+> sub_what) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) - _ -> text "When matching the kind of" <+> quotes (ppr cty1) - msg2 = case sub_o of - TypeEqOrigin {} - | Just cty2 <- mb_cty2 -> - thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k - expandSyns) - _ -> empty - _ -> (True, Nothing, empty) - --- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint --- is left over. -mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> SDoc -mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (tc, tys) <- splitTyConApp_maybe ty2 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (s1, _) <- tcSplitAppTy_maybe ty1 - , Just (s2, _) <- tcSplitAppTy_maybe ty2 - , s1 `eqType` s2 - , has_unknown_roles s1 - = hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr s1) <+> text "have;") - 2 (text "we must assume that the role is nominal") - | otherwise - = empty - where - coercible_msg_for_tycon tc - | isAbstractTyCon tc - = Just $ hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] - | isNewTyCon tc - , [data_con] <- tyConDataCons tc - , let dc_name = dataConName data_con - , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) - | otherwise = Nothing - - has_unknown_roles ty - | Just (tc, tys) <- tcSplitTyConApp_maybe ty - = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon - | Just (s, _) <- tcSplitAppTy_maybe ty - = has_unknown_roles s - | isTyVarTy ty - = True - | otherwise - = False - -{- --- | Make a listing of role signatures for all the parameterised tycons --- used in the provided types - - --- SLPJ Jun 15: I could not convince myself that these hints were really --- useful. Maybe they are, but I think we need more work to make them --- actually helpful. -mkRoleSigs :: Type -> Type -> SDoc -mkRoleSigs ty1 ty2 - = ppUnless (null role_sigs) $ - hang (text "Relevant role signatures:") - 2 (vcat role_sigs) - where - tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2 - role_sigs = mapMaybe ppr_role_sig tcs - - ppr_role_sig tc - | null roles -- if there are no parameters, don't bother printing - = Nothing - | isBuiltInSyntax (tyConName tc) -- don't print roles for (->), etc. - = Nothing - | otherwise - = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles - where - roles = tyConRoles tc --} - -mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -mkEqErr_help dflags ctxt report ct oriented ty1 ty2 - | Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2 - | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr dflags ctxt report ct swapped tv2 co2 ty1 - | otherwise - = reportEqErr ctxt report ct oriented ty1 ty2 - where - swapped = fmap flipSwap oriented - -reportEqErr :: ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -reportEqErr ctxt report ct oriented ty1 ty2 - = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) - where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2 - eqInfo = important $ mkEqInfoMsg ct ty1 ty2 - -mkTyVarEqErr, mkTyVarEqErr' - :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg --- tv1 and ty2 are already tidied -mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2 - = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2) - ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 } - -mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 - | not insoluble_occurs_check -- See Note [Occurs check wins] - , isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; - -- see TcCanonical.canEqTyVarTyVar - || isTyVarTyVar tv1 && not (isTyVarTy ty2) - || ctEqRel ct == ReprEq - -- the cases below don't really apply to ReprEq (except occurs check) - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchOrCND ctxt ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - | MTVU_Occurs <- occ_check_expand - -- We report an "occurs check" even for a ~ F t a, where F is a type - -- function; it's not insoluble (because in principle F could reduce) - -- but we have certainly been unable to solve it - -- See Note [Occurs check error] in TcCanonical - = do { let main_msg = addArising (ctOrigin ct) $ - hang (text "Occurs check: cannot construct the infinite" <+> what <> colon) - 2 (sep [ppr ty1, char '~', ppr ty2]) - - extra2 = important $ mkEqInfoMsg ct ty1 ty2 - - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ - filter isTyVar $ - fvVarList $ - tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - interesting_tyvars) - - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - ; mkErrorMsgFromCt ctxt ct $ - mconcat [important main_msg, extra2, extra3, report] } - - | MTVU_Bad <- occ_check_expand - = do { let msg = vcat [ text "Cannot instantiate unification variable" - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) - , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ] - -- Unlike the other reports, this discards the old 'report_important' - -- instead of augmenting it. This is because the details are not likely - -- to be helpful since this is just an unimplemented feature. - ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } } - - -- check for heterogeneous equality next; see Note [Equalities with incompatible kinds] - -- in TcCanonical - | not (k1 `tcEqType` k2) - = do { let main_msg = addArising (ctOrigin ct) $ - vcat [ hang (text "Kind mismatch: cannot unify" <+> - parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+> - text "with:") - 2 (sep [ppr ty2, dcolon, ppr k2]) - , text "Their kinds differ." ] - cast_msg - | isTcReflexiveCo co1 = empty - | otherwise = text "NB:" <+> ppr tv1 <+> - text "was casted to have kind" <+> - quotes (ppr k1) - - ; mkErrorMsgFromCt ctxt ct (mconcat [important main_msg, important cast_msg, report]) } - - -- If the immediately-enclosing implication has 'tv' a skolem, and - -- we know by now its an InferSkol kind of skolem, then presumably - -- it started life as a TyVarTv, else it'd have been unified, given - -- that there's no occurs-check or forall problem - | (implic:_) <- cec_encl ctxt - , Implic { ic_skols = skols } <- implic - , tv1 `elem` skols - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchMsg ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - -- Check for skolem escape - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_skols = skols, ic_info = skol_info } <- implic - , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols - , not (null esc_skols) - = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] ] - ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } - - -- Nastiest case: attempt to unify an untouchable variable - -- So tv is a meta tyvar (or started that way before we - -- generalised it). So presumably it is an *untouchable* - -- meta tyvar or a TyVarTv, else it'd have been unified - -- See Note [Error messages for untouchables] - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic - = ASSERT2( not (isTouchableMetaTyVar lvl tv1) - , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables] - do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] - tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2 - add_sig = important $ suggestAddSig ctxt ty1 ty2 - ; mkErrorMsgFromCt ctxt ct $ mconcat - [msg, tclvl_extra, tv_extra, add_sig, report] } - - | otherwise - = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2 - -- This *can* happen (#6123, and test T2627b) - -- Consider an ambiguous top-level constraint (a ~ F a) - -- Not an occurs check, because F is a type function. - where - Pair _ k1 = tcCoercionKind co1 - k2 = tcTypeKind ty2 - - ty1 = mkTyVarTy tv1 - occ_check_expand = occCheckForErrors dflags tv1 ty2 - insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 - - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> text "kind" - _ -> text "type" - -mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc --- Report (a) ambiguity if either side is a type function application --- e.g. F a0 ~ Int --- (b) warning about injectivity if both sides are the same --- type function application F a ~ F b --- See Note [Non-injective type functions] -mkEqInfoMsg ct ty1 ty2 - = tyfun_msg $$ ambig_msg - where - mb_fun1 = isTyFun_maybe ty1 - mb_fun2 = isTyFun_maybe ty2 - - ambig_msg | isJust mb_fun1 || isJust mb_fun2 - = snd (mkAmbigMsg False ct) - | otherwise = empty - - tyfun_msg | Just tc1 <- mb_fun1 - , Just tc2 <- mb_fun2 - , tc1 == tc2 - , not (isInjectiveTyCon tc1 Nominal) - = text "NB:" <+> quotes (ppr tc1) - <+> text "is a non-injective type family" - | otherwise = empty - -isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool --- See Note [Reporting occurs-check errors] -isUserSkolem ctxt tv - = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) - where - is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) - = tv `elem` sks && is_user_skol_info skol_info - - is_user_skol_info (InferSkol {}) = False - is_user_skol_info _ = True - -misMatchOrCND :: ReportErrCtxt -> Ct - -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND ctxt ct oriented ty1 ty2 - | null givens || - (isRigidTy ty1 && isRigidTy ty2) || - isGivenCt ct - -- If the equality is unconditionally insoluble - -- or there is no context, don't report the context - = misMatchMsg ct oriented ty1 ty2 - | otherwise - = couldNotDeduce givens ([eq_pred], orig) - where - ev = ctEvidence ct - eq_pred = ctEvPred ev - orig = ctEvOrigin ev - givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)] - -- Keep only UserGivens that have some equalities. - -- See Note [Suppress redundant givens during error reporting] - -couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc -couldNotDeduce givens (wanteds, orig) - = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) - , vcat (pp_givens givens)] - -pp_givens :: [UserGiven] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) - -{- -Note [Suppress redundant givens during error reporting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When GHC is unable to solve a constraint and prints out an error message, it -will print out what given constraints are in scope to provide some context to -the programmer. But we shouldn't print out /every/ given, since some of them -are not terribly helpful to diagnose type errors. Consider this example: - - foo :: Int :~: Int -> a :~: b -> a :~: c - foo Refl Refl = Refl - -When reporting that GHC can't solve (a ~ c), there are two givens in scope: -(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., -redundant), so it's not terribly useful to report it in an error message. -To accomplish this, we discard any Implications that do not bind any -equalities by filtering the `givens` selected in `misMatchOrCND` (based on -the `ic_no_eqs` field of the Implication). - -But this is not enough to avoid all redundant givens! Consider this example, -from #15361: - - goo :: forall (a :: Type) (b :: Type) (c :: Type). - a :~~: b -> a :~~: c - goo HRefl = HRefl - -Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. -The (* ~ *) part arises due the kinds of (:~~:) being unified. More -importantly, (* ~ *) is redundant, so we'd like not to report it. However, -the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its -ic_no_eqs field), so the test above will keep it wholesale. - -To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) -part. This works because mkMinimalBySCs eliminates reflexive equalities in -addition to superclasses (see Note [Remove redundant provided dicts] -in TcPatSyn). --} - -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc --- Add on extra info about skolem constants --- NB: The types themselves are already tidied -extraTyVarEqInfo ctxt tv1 ty2 - = extraTyVarInfo ctxt tv1 $$ ty_extra ty2 - where - ty_extra ty = case tcGetTyVar_maybe ty of - Just tv -> extraTyVarInfo ctxt tv - Nothing -> empty - -extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc -extraTyVarInfo ctxt tv - = ASSERT2( isTyVar tv, ppr tv ) - case tcTyVarDetails tv of - SkolemTv {} -> pprSkols ctxt [tv] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc --- See Note [Suggest adding a type signature] -suggestAddSig ctxt ty1 ty2 - | null inferred_bndrs - = empty - | [bndr] <- inferred_bndrs - = text "Possible fix: add a type signature for" <+> quotes (ppr bndr) - | otherwise - = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) - where - inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) - get_inf ty | Just tv <- tcGetTyVar_maybe ty - , isSkolemTyVar tv - , (implic, _) : _ <- getSkolemInfo (cec_encl ctxt) [tv] - , InferSkol prs <- ic_info implic - = map fst prs - | otherwise - = [] - --------------------- -misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- Types are already tidy --- If oriented then ty1 is actual, ty2 is expected -misMatchMsg ct oriented ty1 ty2 - | Just NotSwapped <- oriented - = misMatchMsg ct (Just IsSwapped) ty2 ty1 - - -- These next two cases are when we're about to report, e.g., that - -- 'LiftedRep doesn't match 'VoidRep. Much better just to say - -- lifted vs. unlifted - | isLiftedRuntimeRep ty1 - = lifted_vs_unlifted - - | isLiftedRuntimeRep ty2 - = lifted_vs_unlifted - - | otherwise -- So now we have Nothing or (Just IsSwapped) - -- For some reason we treat Nothing like IsSwapped - = addArising orig $ - pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $ - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) - , sameOccExtra ty2 ty1 ] - where - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if is_oriented then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if is_oriented then ("actual " ++ what) else "" ] - padding = length herald1 - length herald2 - - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } - is_oriented = isJust oriented - - orig = ctOrigin ct - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> "kind" - _ -> "type" - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) - - lifted_vs_unlifted - = addArising orig $ - text "Couldn't match a lifted type with an unlifted type" - --- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a --- type mismatch occurs to due invisible kind arguments. --- --- This function first checks to see if the 'CtOrigin' argument is a --- 'TypeEqOrigin', and if so, uses the expected/actual types from that to --- check for a kind mismatch (as these types typically have more surrounding --- types and are likelier to be able to glean information about whether a --- mismatch occurred in an invisible argument position or not). If the --- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types --- themselves. -pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin - -> SDoc -> SDoc -pprWithExplicitKindsWhenMismatch ty1 ty2 ct - = pprWithExplicitKindsWhen show_kinds - where - (act_ty, exp_ty) = case ct of - TypeEqOrigin { uo_actual = act - , uo_expected = exp } -> (act, exp) - _ -> (ty1, ty2) - show_kinds = tcEqTypeVis act_ty exp_ty - -- True when the visible bit of the types look the same, - -- so we want to show the kinds in the displayed type - -mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool - -> (Bool, Maybe SwapFlag, SDoc) --- NotSwapped means (actual, expected), IsSwapped is the reverse --- First return val is whether or not to print a herald above this msg -mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = maybe_thing }) - m_level printExpanded - | KindLevel <- level, occurs_check_error = (True, Nothing, empty) - | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2) - | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3) - | tcIsLiftedTypeKind exp = (False, Nothing, msg4) - | Just msg <- num_args_msg = (False, Nothing, msg $$ msg1) - | KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th) - | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty) - | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty) - | otherwise = (True, Nothing, msg1) - where - level = m_level `orElse` TypeLevel - - occurs_check_error - | Just tv <- tcGetTyVar_maybe ty1 - , tv `elemVarSet` tyCoVarsOfType ty2 - = True - | Just tv <- tcGetTyVar_maybe ty2 - , tv `elemVarSet` tyCoVarsOfType ty1 - = True - | otherwise - = False - - sort = case level of - TypeLevel -> text "type" - KindLevel -> text "kind" - - msg1 = case level of - KindLevel - | Just th <- maybe_thing - -> msg5 th - - _ | not (act `pickyEqType` exp) - -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ - vcat [ text "Expected" <+> sort <> colon <+> ppr exp - , text " Actual" <+> sort <> colon <+> ppr act - , if printExpanded then expandedTys else empty ] - - | otherwise - -> empty - - thing_msg = case maybe_thing of - Just thing -> \_ levity -> - quotes thing <+> text "is" <+> levity - Nothing -> \vowel levity -> - text "got a" <> - (if vowel then char 'n' else empty) <+> - levity <+> - text "type" - msg2 = sep [ text "Expecting a lifted type, but" - , thing_msg True (text "unlifted") ] - msg3 = sep [ text "Expecting an unlifted type, but" - , thing_msg False (text "lifted") ] - msg4 = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , maybe (text "found something with kind") - (\thing -> quotes thing <+> text "has kind") - maybe_thing - , quotes (pprWithTYPE act) ] - - msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ - hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes th <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | tcIsConstraintKind exp = text "a constraint" - - -- TYPE t0 - | Just arg <- kindRep_maybe exp - , tcIsTyVarTy arg = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitRuntimeReps dflags - then text "kind" <+> quotes (ppr exp) - else text "a type" - - | otherwise = text "kind" <+> quotes (ppr exp) - - num_args_msg = case level of - KindLevel - | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- maybe_thing - -> Just $ text "Expecting" <+> speakN (abs n) <+> - more <+> quotes thing - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = case num_args_msg of - Nothing -> empty - Just m -> m - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty - - expandedTys = - ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr expTy1 - , text " Actual type:" <+> ppr expTy2 - ] - - (expTy1, expTy2) = expandSynonymsToMatch exp act - -mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg" - -{- Note [Insoluble occurs check wins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble -so we don't use it for rewriting. The Wanted is also insoluble, and -we don't solve it from the Given. It's very confusing to say - Cannot solve a ~ [a] from given constraints a ~ [a] - -And indeed even thinking about the Givens is silly; [W] a ~ [a] is -just as insoluble as Int ~ Bool. - -Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck) -then report it first. - -(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't -want to be as draconian with them.) - -Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) --} - --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- | Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. - let (tys1', tys2') = - unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- | Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- | Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -sameOccExtra :: TcType -> TcType -> SDoc --- See Note [Disambiguating (X ~ X) errors] -sameOccExtra ty1 ty2 - | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 - , let n1 = tyConName tc1 - n2 = tyConName tc2 - same_occ = nameOccName n1 == nameOccName n2 - same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2) - , n1 /= n2 -- Different Names - , same_occ -- but same OccName - = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) - | otherwise - = empty - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnitId) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnitId mod - mod = nameModule nm - loc = nameSrcSpan nm - -{- -Note [Suggest adding a type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The OutsideIn algorithm rejects GADT programs that don't have a principal -type, and indeed some that do. Example: - data T a where - MkT :: Int -> T Int - - f (MkT n) = n - -Does this have type f :: T a -> a, or f :: T a -> Int? -The error that shows up tends to be an attempt to unify an -untouchable type variable. So suggestAddSig sees if the offending -type variable is bound by an *inferred* signature, and suggests -adding a declared signature instead. - -This initially came up in #8968, concerning pattern synonyms. - -Note [Disambiguating (X ~ X) errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #8278 - -Note [Reporting occurs-check errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied -type signature, then the best thing is to report that we can't unify -a with [a], because a is a skolem variable. That avoids the confusing -"occur-check" error message. - -But nowadays when inferring the type of a function with no type signature, -even if there are errors inside, we still generalise its signature and -carry on. For example - f x = x:x -Here we will infer something like - f :: forall a. a -> [a] -with a deferred error of (a ~ [a]). So in the deferred unsolved constraint -'a' is now a skolem, but not one bound by the programmer in the context! -Here we really should report an occurs check. - -So isUserSkolem distinguishes the two. - -Note [Non-injective type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very confusing to get a message like - Couldn't match expected type `Depend s' - against inferred type `Depend s1' -so mkTyFunInfoMsg adds: - NB: `Depend' is type function, and hence may not be injective - -Warn of loopy local equalities that were dropped. - - -************************************************************************ -* * - Type-class errors -* * -************************************************************************ --} - -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkDictErr ctxt cts - = ASSERT( not (null cts) ) - do { inst_envs <- tcGetInstEnvs - ; let (ct1:_) = cts -- ct1 just for its location - min_cts = elim_superclasses cts - lookups = map (lookup_cls_inst inst_envs) min_cts - (no_inst_cts, overlap_cts) = partition is_no_inst lookups - - -- Report definite no-instance errors, - -- or (iff there are none) overlap errors - -- But we report only one of them (hence 'head') because they all - -- have the same source-location origin, to try avoid a cascade - -- of error from one location - ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorMsgFromCt ctxt ct1 (important err) } - where - no_givens = null (getUserGivens ctxt) - - is_no_inst (ct, (matches, unifiers, _)) - = no_givens - && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) - - lookup_cls_inst inst_envs ct - -- Note [Flattening in error message generation] - = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) - where - (clas, tys) = getClassPredTys (ctPred ct) - - - -- When simplifying [W] Ord (Set a), we need - -- [W] Eq a, [W] Ord a - -- but we really only want to report the latter - elim_superclasses cts = mkMinimalBySCs ctPred cts - -mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM (ReportErrCtxt, SDoc) --- Report an overlap error if this class constraint results --- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) - | null matches -- No matches but perhaps several unifiers - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; candidate_insts <- get_candidate_instances - ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) } - - | null unsafe_overlapped -- Some matches => overlap errors - = return (ctxt, overlap_msg) - - | otherwise - = return (ctxt, safe_haskell_msg) - where - orig = ctOrigin ct - pred = ctPred ct - (clas, tys) = getClassPredTys pred - ispecs = [ispec | (ispec, _) <- matches] - unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens - - get_candidate_instances :: TcM [ClsInst] - -- See Note [Report candidate instances] - get_candidate_instances - | [ty] <- tys -- Only try for single-parameter classes - = do { instEnvs <- tcGetInstEnvs - ; return (filter (is_candidate_inst ty) - (classInstances instEnvs clas)) } - | otherwise = return [] - - is_candidate_inst ty inst -- See Note [Report candidate instances] - | [other_ty] <- is_tys inst - , Just (tc1, _) <- tcSplitTyConApp_maybe ty - , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty - = let n1 = tyConName tc1 - n2 = tyConName tc2 - different_names = n1 /= n2 - same_occ_names = nameOccName n1 == nameOccName n2 - in different_names && same_occ_names - | otherwise = False - - cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc - cannot_resolve_msg ct candidate_insts binds_msg - = vcat [ no_inst_msg - , nest 2 extra_note - , vcat (pp_givens useful_givens) - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) - - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambig_tvs pred implics - ++ drv_fixes) - , ppWhen (not (null candidate_insts)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidate_insts))) ] - -- See Note [Report candidate instances] - where - orig = ctOrigin ct - -- See Note [Highlighting ambiguous type variables] - lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) - && not (null unifiers) && null useful_givens - - (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = uncurry (++) (getAmbigTkvs ct) - - no_inst_msg - | lead_with_ambig - = ambig_msg <+> pprArising orig - $$ text "prevents the constraint" <+> quotes (pprParendType pred) - <+> text "from being solved." - - | null useful_givens - = addArising orig $ text "No instance for" - <+> pprParendType pred - - | otherwise - = addArising orig $ text "Could not deduce" - <+> pprParendType pred - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - sdocWithDynFlags $ \dflags -> - getPprStyle $ \sty -> - pprPotentials dflags sty potential_hdr unifiers - - potential_hdr - = vcat [ ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - , text "These potential instance" <> plural unifiers - <+> text "exist:"] - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") - - -- Normal overlap error - overlap_msg - = ASSERT( not (null matches) ) - vcat [ addArising orig (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - - , sdocWithDynFlags $ \dflags -> - getPprStyle $ \sty -> - pprPotentials dflags sty (text "Matching instances:") $ - ispecs ++ unifiers - - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - - matching_givens = mapMaybe matchable useful_givens - - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (tcl_loc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False - - -- Overlap error because of Safe Haskell (first - -- match should be the most specific match) - safe_haskell_msg - = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) ) - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head ispecs)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] - - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - -usefulContext :: [Implication] -> PredType -> [SkolemInfo] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature - -{- Note [Report candidate instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved (Num Int), where `Int` is not the Prelude Int, -but comes from some other module, then it may be helpful to point out -that there are some similarly named instances elsewhere. So we get -something like - No instance for (Num Int) arising from the literal ‘3’ - There are instances for similar types: - instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ -Discussion in #9611. - -Note [Highlighting ambiguous type variables] -~------------------------------------------- -When we encounter ambiguous type variables (i.e. type variables -that remain metavariables after type inference), we need a few more -conditions before we can reason that *ambiguity* prevents constraints -from being solved: - - We can't have any givens, as encountering a typeclass error - with given constraints just means we couldn't deduce - a solution satisfying those constraints and as such couldn't - bind the type variable to a known type. - - If we don't have any unifiers, we don't even have potential - instances from which an ambiguity could arise. - - Lastly, I don't want to mess with error reporting for - unknown runtime types so we just fall back to the old message there. -Once these conditions are satisfied, we can safely say that ambiguity prevents -the constraint from being solved. - -Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... - --} - -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - -pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc --- See Note [Displaying potential instances] -pprPotentials dflags sty herald insts - | null insts - = empty - - | null show_these - = hang herald - 2 (vcat [ not_in_scope_msg empty - , flag_hint ]) - - | otherwise - = hang herald - 2 (vcat [ pprInstances show_these - , ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , not_in_scope_msg (text "...plus") - , flag_hint ]) - where - n_show = 3 :: Int - show_potentials = gopt Opt_PrintPotentialInstances dflags - - (in_scope, not_in_scope) = partition inst_in_scope insts - sorted = sortBy fuzzyClsInstCmp in_scope - show_these | show_potentials = sorted - | otherwise = take n_show sorted - n_in_scope_hidden = length sorted - length show_these - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | isBuiltInSyntax name - = True -- E.g. (->) - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scope_msg herald - | null not_in_scope - = empty - | otherwise - = hang (herald <+> speakNOf (length not_in_scope) (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_potentials (pprInstances not_in_scope)) - - flag_hint = ppUnless (show_potentials || equalLength show_these insts) $ - text "(use -fprint-potential-instances to see them all)" - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus 3 others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - -{- -Note [Flattening in error message generation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (C (Maybe (F x))), where F is a type function, and we have -instances - C (Maybe Int) and C (Maybe a) -Since (F x) might turn into Int, this is an overlap situation, and -indeed (because of flattening) the main solver will have refrained -from solving. But by the time we get to error message generation, we've -un-flattened the constraint. So we must *re*-flatten it before looking -up in the instance environment, lest we only report one matching -instance when in fact there are two. - -Re-flattening is pretty easy, because we don't need to keep track of -evidence. We don't re-use the code in TcCanonical because that's in -the TcS monad, and we are in TcM here. - -Note [Kind arguments in error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be terribly confusing to get an error message like (#9171) - - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ - -The reason may be that the kinds don't match up. Typically you'll get -more useful information, but not when it's as a result of ambiguity. - -To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag -whenever any error message arises due to a kind mismatch. This means that -the above error message would instead be displayed as: - - Couldn't match expected type - ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ - with actual type - ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ - -Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. --} - -mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence - -> Ct -> (Bool, SDoc) -mkAmbigMsg prepend_msg ct - | null ambig_kvs && null ambig_tvs = (False, empty) - | otherwise = (True, msg) - where - (ambig_kvs, ambig_tvs) = getAmbigTkvs ct - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous" - - is_or_are [_] = text "is" - is_or_are _ = text "are" - -pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc -pprSkols ctxt tvs - = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) - where - pp_one (Implic { ic_info = skol_info }, tvs) - | UnkSkol <- skol_info - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown") - | otherwise - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - -getAmbigTkvs :: Ct -> ([Var],[Var]) -getAmbigTkvs ct - = partition (`elemVarSet` dep_tkv_set) ambig_tkvs - where - tkvs = tyCoVarsOfCtList ct - ambig_tkvs = filter isAmbiguousTyVar tkvs - dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - -getSkolemInfo :: [Implication] -> [TcTyVar] - -> [(Implication, [TcTyVar])] --- Get the skolem info for some type variables --- from the implication constraints that bind them --- --- In the returned (implic, tvs) pairs, the 'tvs' part is non-empty -getSkolemInfo _ [] - = [] - -getSkolemInfo [] tvs - = pprPanic "No skolem info:" (ppr tvs) - -getSkolemInfo (implic:implics) tvs - | null tvs_here = getSkolemInfo implics tvs - | otherwise = (implic, tvs_here) : getSkolemInfo implics tvs_other - where - (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs - ------------------------ --- relevantBindings looks at the value environment and finds values whose --- types mention any of the offending type variables. It has to be --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. --- --- We always remove closed top-level bindings, though, --- since they are never relevant (cf #8233) - -relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering - -- See #8191 - -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc, Ct) --- Also returns the zonked and tidied CtOrigin of the constraint -relevantBindings want_filtering ctxt ct - = do { dflags <- getDynFlags - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs - - -- For *kind* errors, report the relevant bindings of the - -- enclosing *type* equality, because that's more useful for the programmer - extra_tvs = case tidy_orig of - KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ - t1 : maybeToList m_t2 - _ -> emptyVarSet - ; traceTc "relevantBindings" $ - vcat [ ppr ct - , pprCtOrigin (ctLocOrigin loc) - , ppr ct_tvs - , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] - , pprWithCommas id - [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - - ; (tidy_env', docs, discards) - <- go dflags env1 ct_tvs (maxRelevantBinds dflags) - emptyVarSet [] False - (removeBindingShadowing $ tcl_bndrs lcl_env) - -- tcl_bndrs has the innermost bindings first, - -- which are probably the most relevant ones - - ; let doc = ppUnless (null docs) $ - hang (text "Relevant bindings include") - 2 (vcat docs $$ ppWhen discards discardMsg) - - -- Put a zonked, tidied CtOrigin into the Ct - loc' = setCtLocOrigin loc tidy_orig - ct' = setCtLoc ct loc' - ctxt' = ctxt { cec_tidy = tidy_env' } - - ; return (ctxt', doc, ct') } - where - ev = ctEvidence ct - loc = ctEvLoc ev - lcl_env = ctLocEnv loc - - run_out :: Maybe Int -> Bool - run_out Nothing = False - run_out (Just n) = n <= 0 - - dec_max :: Maybe Int -> Maybe Int - dec_max = fmap (\n -> n - 1) - - - go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] - -> Bool -- True <=> some filtered out due to lack of fuel - -> [TcBinder] - -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out - -- because of lack of fuel - go _ tidy_env _ _ _ docs discards [] - = return (tidy_env, reverse docs, discards) - go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) - = case tc_bndr of - TcTvBndr {} -> discard_it - TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl - TcIdBndr_ExpType name et top_lvl -> - do { mb_ty <- readExpType_maybe et - -- et really should be filled in by now. But there's a chance - -- it hasn't, if, say, we're reporting a kind error en route to - -- checking a term. See test indexed-types/should_fail/T8129 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just ty -> go2 name ty top_lvl - Nothing -> discard_it -- No info; discard - } - where - discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs - discards tc_bndrs - go2 id_name id_type top_lvl - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type - ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id_name)))] - new_seen = tvs_seen `unionVarSet` id_tvs - - ; if (want_filtering && not (hasPprDebug dflags) - && id_tvs `disjointVarSet` ct_tvs) - -- We want to filter out this binding anyway - -- so discard it silently - then discard_it - - else if isTopLevel top_lvl && not (isNothing n_left) - -- It's a top-level binding and we have not specified - -- -fno-max-relevant-bindings, so discard it silently - then discard_it - - else if run_out n_left && id_tvs `subVarSet` tvs_seen - -- We've run out of n_left fuel and this binding only - -- mentions already-seen type variables, so discard it - then go dflags tidy_env ct_tvs n_left tvs_seen docs - True -- Record that we have now discarded something - tc_bndrs - - -- Keep this binding, decrement fuel - else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen - (doc:docs) discards tc_bndrs } - - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - ------------------------ -warnDefaulting :: [Ct] -> Type -> TcM () -warnDefaulting wanteds default_ty - = do { warn_default <- woptM Opt_WarnTypeDefaults - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 $ - tyCoVarsOfCtsList (listToBag wanteds) - tidy_wanteds = map (tidyCt tidy_env) wanteds - (loc, ppr_wanteds) = pprWithArising tidy_wanteds - warn_msg = - hang (hsep [ text "Defaulting the following" - , text "constraint" <> plural tidy_wanteds - , text "to type" - , quotes (ppr default_ty) ]) - 2 - ppr_wanteds - ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg } - -{- -Note [Runtime skolems] -~~~~~~~~~~~~~~~~~~~~~~ -We want to give a reasonably helpful error message for ambiguity -arising from *runtime* skolems in the debugger. These -are created by in RtClosureInspect.zonkRTTIType. - -************************************************************************ -* * - Error from the canonicaliser - These ones are called *during* constraint simplification -* * -************************************************************************ --} - -solverDepthErrorTcS :: CtLoc -> TcType -> TcM a -solverDepthErrorTcS loc ty - = setCtLocM loc $ - do { ty <- zonkTcType ty - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg - = vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr tidy_ty) - , note ] - ; failWithTcM (tidy_env, msg) } - where - depth = ctLocDepth loc - note = vcat - [ text "Use -freduction-depth=0 to disable this check" - , text "(any upper bound you could choose might fail unpredictably with" - , text " minor updates to GHC, so disabling the check is recommended if" - , text " you're sure that type checking should terminate)" ] diff --git a/typecheck/TcEvTerm.hs b/typecheck/TcEvTerm.hs deleted file mode 100644 --- a/typecheck/TcEvTerm.hs +++ /dev/null @@ -1,70 +0,0 @@ - --- (those who have too heavy dependencies for TcEvidence) -module TcEvTerm - ( evDelayedError, evCallStack ) -where - -import GhcPrelude - -import FastString -import Type -import CoreSyn -import MkCore -import Literal ( Literal(..) ) -import TcEvidence -import HscTypes -import DynFlags -import Name -import Module -import CoreUtils -import PrelNames -import SrcLoc - --- Used with Opt_DeferTypeErrors --- See Note [Deferring coercion errors to runtime] --- in TcSimplify -evDelayedError :: Type -> FastString -> EvTerm -evDelayedError ty msg - = EvExpr $ - Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] - where - errorId = tYPE_ERROR_ID - litMsg = Lit (LitString (bytesFS msg)) - --- Dictionary for CallStack implicit parameters -evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => - EvCallStack -> m EvExpr --- See Note [Overview of implicit CallStacks] in TcEvidence.hs -evCallStack cs = do - df <- getDynFlags - m <- getModule - srcLocDataCon <- lookupDataCon srcLocDataConName - let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> - sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt df (srcSpanStartLine l) - , return $ mkIntExprInt df (srcSpanStartCol l) - , return $ mkIntExprInt df (srcSpanEndLine l) - , return $ mkIntExprInt df (srcSpanEndCol l) - ] - - emptyCS <- Var <$> lookupId emptyCallStackName - - pushCSVar <- lookupId pushCallStackName - let pushCS name loc rest = - mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] - - let mkPush name loc tm = do - nameExpr <- mkStringExprFS name - locExpr <- mkSrcLoc loc - -- at this point tm :: IP sym CallStack - -- but we need the actual CallStack to pass to pushCS, - -- so we use unwrapIP to strip the dictionary wrapper - -- See Note [Overview of implicit CallStacks] - let ip_co = unwrapIP (exprType tm) - return (pushCS nameExpr locExpr (Cast tm ip_co)) - - case cs of - EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm - EvCsEmpty -> return emptyCS diff --git a/typecheck/TcEvidence.hs b/typecheck/TcEvidence.hs deleted file mode 100644 --- a/typecheck/TcEvidence.hs +++ /dev/null @@ -1,1003 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module TcEvidence ( - - -- HsWrapper - HsWrapper(..), - (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, - mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders, - mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper, - pprHsWrapper, - - -- Evidence bindings - TcEvBinds(..), EvBindsVar(..), - EvBindMap(..), emptyEvBindMap, extendEvBinds, - lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap, - isEmptyEvBindMap, - EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, - evBindVar, isCoEvBindsVar, - - -- EvTerm (already a CoreExpr) - EvTerm(..), EvExpr, - evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector, - mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars, - - evTermCoercion, evTermCoercion_maybe, - EvCallStack(..), - EvTypeable(..), - - -- TcCoercion - TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, - TcMCoercion, - Role(..), LeftOrRight(..), pickLR, - mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, - mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, - mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, - tcDowngradeRole, - mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo, - mkTcCoherenceLeftCo, - mkTcCoherenceRightCo, - mkTcKindCo, - tcCoercionKind, coVarsOfTcCo, - mkTcCoVarCo, - isTcReflCo, isTcReflexiveCo, isTcGReflMCo, tcCoToMCo, - tcCoercionRole, - unwrapIP, wrapIP - ) where -#include "HsVersions.h" - -import GhcPrelude - -import Var -import CoAxiom -import Coercion -import PprCore () -- Instance OutputableBndr TyVar -import TcType -import Type -import TyCon -import DataCon( DataCon, dataConWrapId ) -import Class( Class ) -import PrelNames -import DynFlags ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) -import VarEnv -import VarSet -import Predicate -import Name -import Pair - -import CoreSyn -import Class ( classSCSelId ) -import CoreFVs ( exprSomeFreeVars ) - -import Util -import Bag -import qualified Data.Data as Data -import Outputable -import SrcLoc -import Data.IORef( IORef ) -import UniqSet - -{- -Note [TcCoercions] -~~~~~~~~~~~~~~~~~~ -| TcCoercions are a hack used by the typechecker. Normally, -Coercions have free variables of type (a ~# b): we call these -CoVars. However, the type checker passes around equality evidence -(boxed up) at type (a ~ b). - -An TcCoercion is simply a Coercion whose free variables have may be either -boxed or unboxed. After we are done with typechecking the desugarer finds the -boxed free variables, unboxes them, and creates a resulting real Coercion with -kosher free variables. - --} - -type TcCoercion = Coercion -type TcCoercionN = CoercionN -- A Nominal coercion ~N -type TcCoercionR = CoercionR -- A Representational coercion ~R -type TcCoercionP = CoercionP -- a phantom coercion -type TcMCoercion = MCoercion - -mkTcReflCo :: Role -> TcType -> TcCoercion -mkTcSymCo :: TcCoercion -> TcCoercion -mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion -mkTcNomReflCo :: TcType -> TcCoercionN -mkTcRepReflCo :: TcType -> TcCoercionR -mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion -mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex - -> [TcType] -> [TcCoercion] -> TcCoercion -mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] - -> [TcCoercion] -> TcCoercionR -mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion -mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion -mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion -mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion -mkTcSubCo :: TcCoercionN -> TcCoercionR -tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion -mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR -mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP -mkTcKindCo :: TcCoercion -> TcCoercionN -mkTcCoVarCo :: CoVar -> TcCoercion - -tcCoercionKind :: TcCoercion -> Pair TcType -tcCoercionRole :: TcCoercion -> Role -coVarsOfTcCo :: TcCoercion -> TcTyCoVarSet -isTcReflCo :: TcCoercion -> Bool -isTcGReflMCo :: TcMCoercion -> Bool - --- | This version does a slow check, calculating the related types and seeing --- if they are equal. -isTcReflexiveCo :: TcCoercion -> Bool - -mkTcReflCo = mkReflCo -mkTcSymCo = mkSymCo -mkTcTransCo = mkTransCo -mkTcNomReflCo = mkNomReflCo -mkTcRepReflCo = mkRepReflCo -mkTcTyConAppCo = mkTyConAppCo -mkTcAppCo = mkAppCo -mkTcFunCo = mkFunCo -mkTcAxInstCo = mkAxInstCo -mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational -mkTcForAllCo = mkForAllCo -mkTcForAllCos = mkForAllCos -mkTcNthCo = mkNthCo -mkTcLRCo = mkLRCo -mkTcSubCo = mkSubCo -tcDowngradeRole = downgradeRole -mkTcAxiomRuleCo = mkAxiomRuleCo -mkTcGReflRightCo = mkGReflRightCo -mkTcGReflLeftCo = mkGReflLeftCo -mkTcCoherenceLeftCo = mkCoherenceLeftCo -mkTcCoherenceRightCo = mkCoherenceRightCo -mkTcPhantomCo = mkPhantomCo -mkTcKindCo = mkKindCo -mkTcCoVarCo = mkCoVarCo - -tcCoercionKind = coercionKind -tcCoercionRole = coercionRole -coVarsOfTcCo = coVarsOfCo -isTcReflCo = isReflCo -isTcGReflMCo = isGReflMCo -isTcReflexiveCo = isReflexiveCo - -tcCoToMCo :: TcCoercion -> TcMCoercion -tcCoToMCo = coToMCo - --- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. --- Note that the input coercion should always be nominal. -maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion -maybeTcSubCo NomEq = id -maybeTcSubCo ReprEq = mkTcSubCo - - -{- -%************************************************************************ -%* * - HsWrapper -* * -************************************************************************ --} - -data HsWrapper - = WpHole -- The identity coercion - - | WpCompose HsWrapper HsWrapper - -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] - -- - -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) - -- But ([] a) `WpCompose` ([] b) = ([] b a) - - | WpFun HsWrapper HsWrapper TcType SDoc - -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ] - -- So note that if wrap1 :: exp_arg <= act_arg - -- wrap2 :: act_res <= exp_res - -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) - -- This isn't the same as for mkFunCo, but it has to be this way - -- because we can't use 'sym' to flip around these HsWrappers - -- The TcType is the "from" type of the first wrapper - -- The SDoc explains the circumstances under which we have created this - -- WpFun, in case we run afoul of levity polymorphism restrictions in - -- the desugarer. See Note [Levity polymorphism checking] in DsMonad - - | WpCast TcCoercionR -- A cast: [] `cast` co - -- Guaranteed not the identity coercion - -- At role Representational - - -- Evidence abstraction and application - -- (both dictionaries and coercions) - | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable - | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint - -- Kind and Type abstraction and application - | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) - | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) - - - | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, - -- so that the identity coercion is always exactly WpHole - --- Cannot derive Data instance because SDoc is not Data (it stores a function). --- So we do it manually: -instance Data.Data HsWrapper where - gfoldl _ z WpHole = z WpHole - gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2 - gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3 - gfoldl k z (WpCast a1) = z WpCast `k` a1 - gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1 - gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1 - gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 - gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 - gfoldl k z (WpLet a1) = z WpLet `k` a1 - - gunfold k z c = case Data.constrIndex c of - 1 -> z WpHole - 2 -> k (k (z WpCompose)) - 3 -> k (k (k (z wpFunEmpty))) - 4 -> k (z WpCast) - 5 -> k (z WpEvLam) - 6 -> k (z WpEvApp) - 7 -> k (z WpTyLam) - 8 -> k (z WpTyApp) - _ -> k (z WpLet) - - toConstr WpHole = wpHole_constr - toConstr (WpCompose _ _) = wpCompose_constr - toConstr (WpFun _ _ _ _) = wpFun_constr - toConstr (WpCast _) = wpCast_constr - toConstr (WpEvLam _) = wpEvLam_constr - toConstr (WpEvApp _) = wpEvApp_constr - toConstr (WpTyLam _) = wpTyLam_constr - toConstr (WpTyApp _) = wpTyApp_constr - toConstr (WpLet _) = wpLet_constr - - dataTypeOf _ = hsWrapper_dataType - -hsWrapper_dataType :: Data.DataType -hsWrapper_dataType - = Data.mkDataType "HsWrapper" - [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr - , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr - , wpLet_constr] - -wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, - wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr -wpHole_constr = mkHsWrapperConstr "WpHole" -wpCompose_constr = mkHsWrapperConstr "WpCompose" -wpFun_constr = mkHsWrapperConstr "WpFun" -wpCast_constr = mkHsWrapperConstr "WpCast" -wpEvLam_constr = mkHsWrapperConstr "WpEvLam" -wpEvApp_constr = mkHsWrapperConstr "WpEvApp" -wpTyLam_constr = mkHsWrapperConstr "WpTyLam" -wpTyApp_constr = mkHsWrapperConstr "WpTyApp" -wpLet_constr = mkHsWrapperConstr "WpLet" - -mkHsWrapperConstr :: String -> Data.Constr -mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix - -wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper -wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty - -(<.>) :: HsWrapper -> HsWrapper -> HsWrapper -WpHole <.> c = c -c <.> WpHole = c -c1 <.> c2 = c1 `WpCompose` c2 - -mkWpFun :: HsWrapper -> HsWrapper - -> TcType -- the "from" type of the first wrapper - -> TcType -- either type of the second wrapper (used only when the - -- second wrapper is the identity) - -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." - -> HsWrapper -mkWpFun WpHole WpHole _ _ _ = WpHole -mkWpFun WpHole (WpCast co2) t1 _ _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole _ t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) _ _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) -mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d - -mkWpCastR :: TcCoercionR -> HsWrapper -mkWpCastR co - | isTcReflCo co = WpHole - | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) - WpCast co - -mkWpCastN :: TcCoercionN -> HsWrapper -mkWpCastN co - | isTcReflCo co = WpHole - | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co) - WpCast (mkTcSubCo co) - -- The mkTcSubCo converts Nominal to Representational - -mkWpTyApps :: [Type] -> HsWrapper -mkWpTyApps tys = mk_co_app_fn WpTyApp tys - -mkWpEvApps :: [EvTerm] -> HsWrapper -mkWpEvApps args = mk_co_app_fn WpEvApp args - -mkWpEvVarApps :: [EvVar] -> HsWrapper -mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) - -mkWpTyLams :: [TyVar] -> HsWrapper -mkWpTyLams ids = mk_co_lam_fn WpTyLam ids - -mkWpLams :: [Var] -> HsWrapper -mkWpLams ids = mk_co_lam_fn WpEvLam ids - -mkWpLet :: TcEvBinds -> HsWrapper --- This no-op is a quite a common case -mkWpLet (EvBinds b) | isEmptyBag b = WpHole -mkWpLet ev_binds = WpLet ev_binds - -mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper -mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as - -mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper --- For applications, the *first* argument must --- come *last* in the composition sequence -mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as - -idHsWrapper :: HsWrapper -idHsWrapper = WpHole - -isIdHsWrapper :: HsWrapper -> Bool -isIdHsWrapper WpHole = True -isIdHsWrapper _ = False - --- | Is the wrapper erasable, i.e., will not affect runtime semantics? -isErasableHsWrapper :: HsWrapper -> Bool -isErasableHsWrapper = go - where - go WpHole = True - go (WpCompose wrap1 wrap2) = go wrap1 && go wrap2 - -- not so sure about WpFun. But it eta-expands, so... - go WpFun{} = False - go WpCast{} = True - go WpEvLam{} = False -- case in point - go WpEvApp{} = False - go WpTyLam{} = True - go WpTyApp{} = True - go WpLet{} = False - -collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) --- Collect the outer lambda binders of a HsWrapper, --- stopping as soon as you get to a non-lambda binder -collectHsWrapBinders wrap = go wrap [] - where - -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn) - go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) - go (WpEvLam v) wraps = add_lam v (gos wraps) - go (WpTyLam v) wraps = add_lam v (gos wraps) - go (WpCompose w1 w2) wraps = go w1 (w2:wraps) - go wrap wraps = ([], foldl' (<.>) wrap wraps) - - gos [] = ([], WpHole) - gos (w:ws) = go w ws - - add_lam v (vs,w) = (v:vs, w) - -{- -************************************************************************ -* * - Evidence bindings -* * -************************************************************************ --} - -data TcEvBinds - = TcEvBinds -- Mutable evidence bindings - EvBindsVar -- Mutable because they are updated "later" - -- when an implication constraint is solved - - | EvBinds -- Immutable after zonking - (Bag EvBind) - -data EvBindsVar - = EvBindsVar { - ebv_uniq :: Unique, - -- The Unique is for debug printing only - - ebv_binds :: IORef EvBindMap, - -- The main payload: the value-level evidence bindings - -- (dictionaries etc) - -- Some Given, some Wanted - - ebv_tcvs :: IORef CoVarSet - -- The free Given coercion vars needed by Wanted coercions that - -- are solved by filling in their HoleDest in-place. Since they - -- don't appear in ebv_binds, we keep track of their free - -- variables so that we can report unused given constraints - -- See Note [Tracking redundant constraints] in TcSimplify - } - - | CoEvBindsVar { -- See Note [Coercion evidence only] - - -- See above for comments on ebv_uniq, ebv_tcvs - ebv_uniq :: Unique, - ebv_tcvs :: IORef CoVarSet - } - -instance Data.Data TcEvBinds where - -- Placeholder; we can't travers into TcEvBinds - toConstr _ = abstractConstr "TcEvBinds" - gunfold _ _ = error "gunfold" - dataTypeOf _ = Data.mkNoRepType "TcEvBinds" - -{- Note [Coercion evidence only] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Class constraints etc give rise to /term/ bindings for evidence, and -we have nowhere to put term bindings in /types/. So in some places we -use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level -evidence bindings are allowed. Notebly (): - - - Places in types where we are solving kind constraints (all of which - are equalities); see solveEqualities, solveLocalEqualities - - - When unifying forall-types --} - -isCoEvBindsVar :: EvBindsVar -> Bool -isCoEvBindsVar (CoEvBindsVar {}) = True -isCoEvBindsVar (EvBindsVar {}) = False - ------------------ -newtype EvBindMap - = EvBindMap { - ev_bind_varenv :: DVarEnv EvBind - } -- Map from evidence variables to evidence terms - -- We use @DVarEnv@ here to get deterministic ordering when we - -- turn it into a Bag. - -- If we don't do that, when we generate let bindings for - -- dictionaries in dsTcEvBinds they will be generated in random - -- order. - -- - -- For example: - -- - -- let $dEq = GHC.Classes.$fEqInt in - -- let $$dNum = GHC.Num.$fNumInt in ... - -- - -- vs - -- - -- let $dNum = GHC.Num.$fNumInt in - -- let $dEq = GHC.Classes.$fEqInt in ... - -- - -- See Note [Deterministic UniqFM] in UniqDFM for explanation why - -- @UniqFM@ can lead to nondeterministic order. - -emptyEvBindMap :: EvBindMap -emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv } - -extendEvBinds :: EvBindMap -> EvBind -> EvBindMap -extendEvBinds bs ev_bind - = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs) - (eb_lhs ev_bind) - ev_bind } - -isEmptyEvBindMap :: EvBindMap -> Bool -isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m - -lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind -lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs) - -evBindMapBinds :: EvBindMap -> Bag EvBind -evBindMapBinds = foldEvBindMap consBag emptyBag - -foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a -foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) - -filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap -filterEvBindMap k (EvBindMap { ev_bind_varenv = env }) - = EvBindMap { ev_bind_varenv = filterDVarEnv k env } - -instance Outputable EvBindMap where - ppr (EvBindMap m) = ppr m - ------------------ --- All evidence is bound by EvBinds; no side effects -data EvBind - = EvBind { eb_lhs :: EvVar - , eb_rhs :: EvTerm - , eb_is_given :: Bool -- True <=> given - -- See Note [Tracking redundant constraints] in TcSimplify - } - -evBindVar :: EvBind -> EvVar -evBindVar = eb_lhs - -mkWantedEvBind :: EvVar -> EvTerm -> EvBind -mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } - --- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm -mkGivenEvBind :: EvVar -> EvTerm -> EvBind -mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } - - --- An EvTerm is, conceptually, a CoreExpr that implements the constraint. --- Unfortunately, we cannot just do --- type EvTerm = CoreExpr --- Because of staging problems issues around EvTypeable -data EvTerm - = EvExpr EvExpr - - | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) - - | EvFun -- /\as \ds. let binds in v - { et_tvs :: [TyVar] - , et_given :: [EvVar] - , et_binds :: TcEvBinds -- This field is why we need an EvFun - -- constructor, and can't just use EvExpr - , et_body :: EvVar } - - deriving Data.Data - -type EvExpr = CoreExpr - --- An EvTerm is (usually) constructed by any of the constructors here --- and those more complicates ones who were moved to module TcEvTerm - --- | Any sort of evidence Id, including coercions -evId :: EvId -> EvExpr -evId = Var - --- coercion bindings --- See Note [Coercion evidence terms] -evCoercion :: TcCoercion -> EvTerm -evCoercion co = EvExpr (Coercion co) - --- | d |> co -evCast :: EvExpr -> TcCoercion -> EvTerm -evCast et tc | isReflCo tc = EvExpr et - | otherwise = EvExpr (Cast et tc) - --- Dictionary instance application -evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm -evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets - -evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm -evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets - --- Selector id plus the types at which it --- should be instantiated, used for HasField --- dictionaries; see Note [HasField instances] --- in TcInterface -evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr -evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms - --- Dictionary for (Typeable ty) -evTypeable :: Type -> EvTypeable -> EvTerm -evTypeable = EvTypeable - --- | Instructions on how to make a 'Typeable' dictionary. --- See Note [Typeable evidence terms] -data EvTypeable - = EvTypeableTyCon TyCon [EvTerm] - -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of - -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for - -- the applied kinds.. - - | EvTypeableTyApp EvTerm EvTerm - -- ^ Dictionary for @Typeable (s t)@, - -- given a dictionaries for @s@ and @t@. - - | EvTypeableTrFun EvTerm EvTerm - -- ^ Dictionary for @Typeable (s -> t)@, - -- given a dictionaries for @s@ and @t@. - - | EvTypeableTyLit EvTerm - -- ^ Dictionary for a type literal, - -- e.g. @Typeable "foo"@ or @Typeable 3@ - -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ - -- (see #10348) - deriving Data.Data - --- | Evidence for @CallStack@ implicit parameters. -data EvCallStack - -- See Note [Overview of implicit CallStacks] - = EvCsEmpty - | EvCsPushCall Name RealSrcSpan EvExpr - -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at - -- @loc@, in a calling context @stk@. - deriving Data.Data - -{- -Note [Typeable evidence terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The EvTypeable data type looks isomorphic to Type, but the EvTerms -inside can be EvIds. Eg - f :: forall a. Typeable a => a -> TypeRep - f x = typeRep (undefined :: Proxy [a]) -Here for the (Typeable [a]) dictionary passed to typeRep we make -evidence - dl :: Typeable [a] = EvTypeable [a] - (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) -where - d :: Typable a -is the lambda-bound dictionary passed into f. - -Note [Coercion evidence terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "coercion evidence term" takes one of these forms - co_tm ::= EvId v where v :: t1 ~# t2 - | EvCoercion co - | EvCast co_tm co - -We do quite often need to get a TcCoercion from an EvTerm; see -'evTermCoercion'. - -INVARIANT: The evidence for any constraint with type (t1 ~# t2) is -a coercion evidence term. Consider for example - [G] d :: F Int a -If we have - ax7 a :: F Int a ~ (a ~ Bool) -then we do NOT generate the constraint - [G] (d |> ax7 a) :: a ~ Bool -because that does not satisfy the invariant (d is not a coercion variable). -Instead we make a binding - g1 :: a~Bool = g |> ax7 a -and the constraint - [G] g1 :: a~Bool -See #7238 and Note [Bind new Givens immediately] in Constraint - -Note [EvBinds/EvTerm] -~~~~~~~~~~~~~~~~~~~~~ -How evidence is created and updated. Bindings for dictionaries, -and coercions and implicit parameters are carried around in TcEvBinds -which during constraint generation and simplification is always of the -form (TcEvBinds ref). After constraint simplification is finished it -will be transformed to t an (EvBinds ev_bag). - -Evidence for coercions *SHOULD* be filled in using the TcEvBinds -However, all EvVars that correspond to *wanted* coercion terms in -an EvBind must be mutable variables so that they can be readily -inlined (by zonking) after constraint simplification is finished. - -Conclusion: a new wanted coercion variable should be made mutable. -[Notice though that evidence variables that bind coercion terms - from super classes will be "given" and hence rigid] - - -Note [Overview of implicit CallStacks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations) - -The goal of CallStack evidence terms is to reify locations -in the program source as runtime values, without any support -from the RTS. We accomplish this by assigning a special meaning -to constraints of type GHC.Stack.Types.HasCallStack, an alias - - type HasCallStack = (?callStack :: CallStack) - -Implicit parameters of type GHC.Stack.Types.CallStack (the name is not -important) are solved in three steps: - -1. Occurrences of CallStack IPs are solved directly from the given IP, - just like a regular IP. For example, the occurrence of `?stk` in - - error :: (?stk :: CallStack) => String -> a - error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) - - will be solved for the `?stk` in `error`s context as before. - -2. In a function call, instead of simply passing the given IP, we first - append the current call-site to it. For example, consider a - call to the callstack-aware `error` above. - - undefined :: (?stk :: CallStack) => a - undefined = error "undefined!" - - Here we want to take the given `?stk` and append the current - call-site, before passing it to `error`. In essence, we want to - rewrite `error "undefined!"` to - - let ?stk = pushCallStack ?stk - in error "undefined!" - - We achieve this effect by emitting a NEW wanted - - [W] d :: IP "stk" CallStack - - from which we build the evidence term - - EvCsPushCall "error" (EvId d) - - that we use to solve the call to `error`. The new wanted `d` will - then be solved per rule (1), ie as a regular IP. - - (see TcInteract.interactDict) - -3. We default any insoluble CallStacks to the empty CallStack. Suppose - `undefined` did not request a CallStack, ie - - undefinedNoStk :: a - undefinedNoStk = error "undefined!" - - Under the usual IP rules, the new wanted from rule (2) would be - insoluble as there's no given IP from which to solve it, so we - would get an "unbound implicit parameter" error. - - We don't ever want to emit an insoluble CallStack IP, so we add a - defaulting pass to default any remaining wanted CallStacks to the - empty CallStack with the evidence term - - EvCsEmpty - - (see TcSimplify.simpl_top and TcSimplify.defaultCallStacks) - -This provides a lightweight mechanism for building up call-stacks -explicitly, but is notably limited by the fact that the stack will -stop at the first function whose type does not include a CallStack IP. -For example, using the above definition of `undefined`: - - head :: [a] -> a - head [] = undefined - head (x:_) = x - - g = head [] - -the resulting CallStack will include the call to `undefined` in `head` -and the call to `error` in `undefined`, but *not* the call to `head` -in `g`, because `head` did not explicitly request a CallStack. - - -Important Details: -- GHC should NEVER report an insoluble CallStack constraint. - -- GHC should NEVER infer a CallStack constraint unless one was requested - with a partial type signature (See TcType.pickQuantifiablePreds). - -- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], - where the String is the name of the binder that is used at the - SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the - package/module/file name, as well as the full source-span. Both - CallStack and SrcLoc are kept abstract so only GHC can construct new - values. - -- We will automatically solve any wanted CallStack regardless of the - name of the IP, i.e. - - f = show (?stk :: CallStack) - g = show (?loc :: CallStack) - - are both valid. However, we will only push new SrcLocs onto existing - CallStacks when the IP names match, e.g. in - - head :: (?loc :: CallStack) => [a] -> a - head [] = error (show (?stk :: CallStack)) - - the printed CallStack will NOT include head's call-site. This reflects the - standard scoping rules of implicit-parameters. - -- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. - The desugarer will need to unwrap the IP newtype before pushing a new - call-site onto a given stack (See DsBinds.dsEvCallStack) - -- When we emit a new wanted CallStack from rule (2) we set its origin to - `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` - (see TcInteract.interactDict). - - This is a bit shady, but is how we ensure that the new wanted is - solved like a regular IP. - --} - -mkEvCast :: EvExpr -> TcCoercion -> EvTerm -mkEvCast ev lco - | ASSERT2( tcCoercionRole lco == Representational - , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) - isTcReflCo lco = EvExpr ev - | otherwise = evCast ev lco - - -mkEvScSelectors -- Assume class (..., D ty, ...) => C a b - :: Class -> [TcType] -- C ty1 ty2 - -> [(TcPredType, -- D ty[ty1/a,ty2/b] - EvExpr) -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b] - ] -mkEvScSelectors cls tys - = zipWith mk_pr (immSuperClasses cls tys) [0..] - where - mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys) - where - sc_sel_id = classSCSelId cls i -- Zero-indexed - -emptyTcEvBinds :: TcEvBinds -emptyTcEvBinds = EvBinds emptyBag - -isEmptyTcEvBinds :: TcEvBinds -> Bool -isEmptyTcEvBinds (EvBinds b) = isEmptyBag b -isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" - -evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion --- Applied only to EvTerms of type (s~t) --- See Note [Coercion evidence terms] -evTermCoercion_maybe ev_term - | EvExpr e <- ev_term = go e - | otherwise = Nothing - where - go :: EvExpr -> Maybe TcCoercion - go (Var v) = return (mkCoVarCo v) - go (Coercion co) = return co - go (Cast tm co) = do { co' <- go tm - ; return (mkCoCast co' co) } - go _ = Nothing - -evTermCoercion :: EvTerm -> TcCoercion -evTermCoercion tm = case evTermCoercion_maybe tm of - Just co -> co - Nothing -> pprPanic "evTermCoercion" (ppr tm) - - -{- ********************************************************************* -* * - Free variables -* * -********************************************************************* -} - -findNeededEvVars :: EvBindMap -> VarSet -> VarSet --- Find all the Given evidence needed by seeds, --- looking transitively through binds -findNeededEvVars ev_binds seeds - = transCloVarSet also_needs seeds - where - also_needs :: VarSet -> VarSet - also_needs needs = nonDetFoldUniqSet add emptyVarSet needs - -- It's OK to use nonDetFoldUFM here because we immediately - -- forget about the ordering by creating a set - - add :: Var -> VarSet -> VarSet - add v needs - | Just ev_bind <- lookupEvBind ev_binds v - , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind - , is_given - = evVarsOfTerm rhs `unionVarSet` needs - | otherwise - = needs - -evVarsOfTerm :: EvTerm -> VarSet -evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e -evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev -evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] - -evVarsOfTerms :: [EvTerm] -> VarSet -evVarsOfTerms = mapUnionVarSet evVarsOfTerm - -evVarsOfTypeable :: EvTypeable -> VarSet -evVarsOfTypeable ev = - case ev of - EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e - EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTyLit e -> evVarsOfTerm e - - -{- Note [Free vars of EvFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Finding the free vars of an EvFun is made tricky by the fact the -bindings et_binds may be a mutable variable. Fortunately, we -can just squeeze by. Here's how. - -* evVarsOfTerm is used only by TcSimplify.neededEvVars. -* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the - ic_binds field of an Implication -* So we can track usage via the processing for that implication, - (see Note [Tracking redundant constraints] in TcSimplify). - We can ignore usage from the EvFun altogether. - -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -instance Outputable HsWrapper where - ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) - -pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc --- With -fprint-typechecker-elaboration, print the wrapper --- otherwise just print what's inside --- The pp_thing_inside function takes Bool to say whether --- it's in a position that needs parens for a non-atomic thing -pprHsWrapper wrap pp_thing_inside - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags - then help pp_thing_inside wrap False - else pp_thing_inside False - where - help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc - -- True <=> appears in function application position - -- False <=> appears as body of let or lambda - help it WpHole = it - help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> - help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False - help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" - <+> pprParendCo co)] - help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] - help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] - help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] - help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] - help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] - -pprLamBndr :: Id -> SDoc -pprLamBndr v = pprBndr LambdaBind v - -add_parens, no_parens :: SDoc -> Bool -> SDoc -add_parens d True = parens d -add_parens d False = d -no_parens d _ = d - -instance Outputable TcEvBinds where - ppr (TcEvBinds v) = ppr v - ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) - -instance Outputable EvBindsVar where - ppr (EvBindsVar { ebv_uniq = u }) - = text "EvBindsVar" <> angleBrackets (ppr u) - ppr (CoEvBindsVar { ebv_uniq = u }) - = text "CoEvBindsVar" <> angleBrackets (ppr u) - -instance Uniquable EvBindsVar where - getUnique = ebv_uniq - -instance Outputable EvBind where - ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) - = sep [ pp_gw <+> ppr v - , nest 2 $ equals <+> ppr e ] - where - pp_gw = brackets (if is_given then char 'G' else char 'W') - -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing - -instance Outputable EvTerm where - ppr (EvExpr e) = ppr e - ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty - ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w }) - = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow) - 2 (ppr bs $$ ppr w) -- Not very pretty - -instance Outputable EvCallStack where - ppr EvCsEmpty - = text "[]" - ppr (EvCsPushCall name loc tm) - = ppr (name,loc) <+> text ":" <+> ppr tm - -instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts - ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2) - ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 - - ----------------------------------------------------------------------- --- Helper functions for dealing with IP newtype-dictionaries ----------------------------------------------------------------------- - --- | Create a 'Coercion' that unwraps an implicit-parameter or --- overloaded-label dictionary to expose the underlying value. We --- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, --- and return a 'Coercion' `co :: IP sym ty ~ ty` or --- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also --- Note [Type-checking overloaded labels] in TcExpr. -unwrapIP :: Type -> CoercionR -unwrapIP ty = - case unwrapNewTyCon_maybe tc of - Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] - Nothing -> pprPanic "unwrapIP" $ - text "The dictionary for" <+> quotes (ppr tc) - <+> text "is not a newtype!" - where - (tc, tys) = splitTyConApp ty - --- | Create a 'Coercion' that wraps a value in an implicit-parameter --- dictionary. See 'unwrapIP'. -wrapIP :: Type -> CoercionR -wrapIP ty = mkSymCo (unwrapIP ty) diff --git a/typecheck/TcExpr.hs b/typecheck/TcExpr.hs deleted file mode 100644 --- a/typecheck/TcExpr.hs +++ /dev/null @@ -1,2886 +0,0 @@ -{- -% -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcExpr]{Typecheck an expression} --} - -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, - tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, - tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, - tcCheckId, - addExprErrCtxt, - getFixedTyVars ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) -import THNames( liftStringName, liftName ) - -import GHC.Hs -import TcHsSyn -import TcRnMonad -import TcUnify -import BasicTypes -import Inst -import TcBinds ( chooseInferredQuantifiers, tcLocalBinds ) -import TcSigs ( tcUserTypeSig, tcInstSig ) -import TcSimplify ( simplifyInfer, InferMode(..) ) -import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) -import FamInstEnv ( FamInstEnvs ) -import RnEnv ( addUsedGRE ) -import RnUtils ( addNameClashErrRn, unknownSubordinateErr ) -import TcEnv -import TcArrows -import TcMatches -import TcHsType -import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) -import TcPat -import TcMType -import TcOrigin -import TcType -import Id -import IdInfo -import ConLike -import DataCon -import PatSyn -import Name -import NameEnv -import NameSet -import RdrName -import TyCon -import TyCoRep -import TyCoPpr -import TyCoSubst (substTyWithInScope) -import Type -import TcEvidence -import VarSet -import TysWiredIn -import TysPrim( intPrimTy ) -import PrimOp( tagToEnumKey ) -import PrelNames -import DynFlags -import SrcLoc -import Util -import VarEnv ( emptyTidyEnv, mkInScopeSet ) -import ListSetOps -import Maybes -import Outputable -import FastString -import Control.Monad -import Class(classTyCon) -import UniqSet ( nonDetEltsUniqSet ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Function -import Data.List (partition, sortBy, groupBy, intersect) -import qualified Data.Set as Set - -{- -************************************************************************ -* * -\subsection{Main wrappers} -* * -************************************************************************ --} - -tcPolyExpr, tcPolyExprNC - :: LHsExpr GhcRn -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytype) - -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type - --- tcPolyExpr is a convenient place (frequent but not too frequent) --- place to add context information. --- The NC version does not do so, usually because the caller wants --- to do so himself. - -tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty) -tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty) - --- these versions take an ExpType -tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType - -> TcM (LHsExpr GhcTcId) -tc_poly_expr expr res_ty - = addExprErrCtxt expr $ - do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty } - -tc_poly_expr_nc (L loc expr) res_ty - = setSrcSpan loc $ - do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (wrap, expr') - <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ L loc (mkHsWrap wrap expr') } - ---------------- -tcMonoExpr, tcMonoExprNC - :: LHsExpr GhcRn -- Expression to type check - -> ExpRhoType -- Expected type - -- Definitely no foralls at the top - -> TcM (LHsExpr GhcTcId) - -tcMonoExpr expr res_ty - = addErrCtxt (exprCtxt expr) $ - tcMonoExprNC expr res_ty - -tcMonoExprNC (L loc expr) res_ty - = setSrcSpan loc $ - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } - ---------------- -tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId - , TcSigmaType ) --- Infer a *sigma*-type. -tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr) - -tcInferSigmaNC (L loc expr) - = setSrcSpan loc $ - do { (expr', sigma) <- tcInferNoInst (tcExpr expr) - ; return (L loc expr', sigma) } - -tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType) --- Infer a *rho*-type. The return type is always (shallowly) instantiated. -tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) - -tcInferRhoNC expr - = do { (expr', sigma) <- tcInferSigmaNC expr - ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma - ; return (mkLHsWrap wrap expr', rho) } - - -{- -************************************************************************ -* * - tcExpr: the main expression typechecker -* * -************************************************************************ - -NB: The res_ty is always deeply skolemised. --} - -tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty -tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty - -tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty -tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty - -tcExpr e@(HsLit x lit) res_ty - = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } - -tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar x expr') } - -tcExpr (HsSCC x src lbl expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC x src lbl expr') } - -tcExpr (HsTickPragma x src info srcInfo expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma x src info srcInfo expr') } - -tcExpr (HsCoreAnn x src lbl expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn x src lbl expr') } - -tcExpr (HsOverLit x lit) res_ty - = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit x lit') } - -tcExpr (NegApp x expr neg_expr) res_ty - = do { (expr', neg_expr') - <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ - \[arg_ty] -> - tcMonoExpr expr (mkCheckExpType arg_ty) - ; return (NegApp x expr' neg_expr') } - -tcExpr e@(HsIPVar _ x) res_ty - = do { {- Implicit parameters must have a *tau-type* not a - type scheme. We enforce this by creating a fresh - type variable as its type. (Because res_ty may not - be a tau-type.) -} - ip_ty <- newOpenFlexiTyVarTy - ; let ip_name = mkStrLitTy (hsIPNameFS x) - ; ipClass <- tcLookupClass ipClassName - ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult e - (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) - ip_ty res_ty } - where - -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ - unwrapIP $ mkClassPred ipClass [x,ty] - origin = IPOccOrigin x - -tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty - = do { -- See Note [Type-checking overloaded labels] - loc <- getSrcSpanM - ; case mb_fromLabel of - Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty - Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName - ; alpha <- newFlexiTyVarTy liftedTypeKind - ; let pred = mkClassPred isLabelClass [lbl, alpha] - ; loc <- getSrcSpanM - ; var <- emitWantedEvVar origin pred - ; tcWrapResult e - (fromDict pred (HsVar noExtField (L loc var))) - alpha res_ty } } - where - -- Coerces a dictionary for `IsLabel "x" t` into `t`, - -- or `HasField "x" r a into `r -> a`. - fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred - origin = OverLabelOrigin l - lbl = mkStrLitTy l - - applyFromLabel loc fromLabel = - HsAppType noExtField - (L loc (HsVar noExtField (L loc fromLabel))) - (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) - -tcExpr (HsLam x match) res_ty - = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam x match')) } - where - match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = sep [ text "The lambda expression" <+> - quotes (pprSetDepth (PartWay 1) $ - pprMatches match), - -- The pprSetDepth makes the abstraction print briefly - text "has"] - -tcExpr e@(HsLamCase x matches) res_ty - = do { (matches', wrap) - <- tcMatchLambda msg match_ctxt matches res_ty - -- The laziness annotation is because we don't want to fail here - -- if there are multiple arguments - ; return (mkHsWrap wrap $ HsLamCase x matches') } - where - msg = sep [ text "The function" <+> quotes (ppr e) - , text "requires"] - match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } - -tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty - = do { let loc = getLoc (hsSigWcType sig_ty) - ; sig_info <- checkNoErrs $ -- Avoid error cascade - tcUserTypeSig loc sig_ty Nothing - ; (expr', poly_ty) <- tcExprSig expr sig_info - ; let expr'' = ExprWithTySig noExtField expr' sig_ty - ; tcWrapResult e expr'' poly_ty res_ty } - -{- -Note [Type-checking overloaded labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that we have - - module GHC.OverloadedLabels where - class IsLabel (x :: Symbol) a where - fromLabel :: a - -We translate `#foo` to `fromLabel @"foo"`, where we use - - * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not - * `GHC.OverloadedLabels.fromLabel`. - -In the `RebindableSyntax` case, the renamer will have filled in the -first field of `HsOverLabel` with the `fromLabel` function to use, and -we simply apply it to the appropriate visible type argument. - -In the `OverloadedLabels` case, when we see an overloaded label like -`#foo`, we generate a fresh variable `alpha` for the type and emit an -`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a -single method, it is represented by a newtype, so we can coerce -`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). - --} - - -{- -************************************************************************ -* * - Infix operators and sections -* * -************************************************************************ - -Note [Left sections] -~~~~~~~~~~~~~~~~~~~~ -Left sections, like (4 *), are equivalent to - \ x -> (*) 4 x, -or, if PostfixOperators is enabled, just - (*) 4 -With PostfixOperators we don't actually require the function to take -two arguments at all. For example, (x `not`) means (not x); you get -postfix operators! Not Haskell 98, but it's less work and kind of -useful. - -Note [Typing rule for ($)] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -People write - runST $ blah -so much, where - runST :: (forall s. ST s a) -> a -that I have finally given in and written a special type-checking -rule just for saturated applications of ($). - * Infer the type of the first argument - * Decompose it; should be of form (arg2_ty -> res_ty), - where arg2_ty might be a polytype - * Use arg2_ty to typecheck arg2 --} - -tcExpr expr@(OpApp fix arg1 op arg2) res_ty - | (L loc (HsVar _ (L lv op_name))) <- op - , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] - = do { traceTc "Application rule" (ppr op) - ; (arg1', arg1_ty) <- tcInferSigma arg1 - - ; let doc = text "The first argument of ($) takes" - orig1 = lexprCtOrigin arg1 - ; (wrap_arg1, [arg2_sigma], op_res_ty) <- - matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty - - -- We have (arg1 $ arg2) - -- So: arg1_ty = arg2_ty -> op_res_ty - -- where arg2_sigma maybe polymorphic; that's the point - - ; arg2' <- tcArg op arg2 arg2_sigma 2 - - -- Make sure that the argument type has kind '*' - -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b - -- Eg we do not want to allow (D# $ 4.0#) #5570 - -- (which gives a seg fault) - ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) - (tcTypeKind arg2_sigma) liftedTypeKind - -- Ignore the evidence. arg2_sigma must have type * or #, - -- because we know (arg2_sigma -> op_res_ty) is well-kinded - -- (because otherwise matchActualFunTys would fail) - -- So this 'unifyKind' will either succeed with Refl, or will - -- produce an insoluble constraint * ~ #, which we'll report later. - - -- NB: unlike the argument type, the *result* type, op_res_ty can - -- have any kind (#8739), so we don't need to check anything for that - - ; op_id <- tcLookupId op_name - ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty - , arg2_sigma - , op_res_ty]) - (HsVar noExtField (L lv op_id))) - -- arg1' :: arg1_ty - -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) - -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty - - expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' - - ; tcWrapResult expr expr' op_res_ty res_ty } - - | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op - , Just sig_ty <- obviousSig (unLoc arg1) - -- See Note [Disambiguating record fields] - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) - ; tcExpr (OpApp fix arg1 op' arg2) res_ty - } - - | otherwise - = do { traceTc "Non Application rule" (ppr op) - ; (wrap, op', [HsValArg arg1', HsValArg arg2']) - <- tcApp (Just $ mk_op_msg op) - op [HsValArg arg1, HsValArg arg2] res_ty - ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') } - --- Right sections, equivalent to \ x -> x `op` expr, or --- \ x -> op x expr - -tcExpr expr@(SectionR x op arg2) res_ty - = do { (op', op_ty) <- tcInferFun op - ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkVisFunTy arg1_ty op_res_ty) res_ty - ; arg2' <- tcArg op arg2 arg2_ty 2 - ; return ( mkHsWrap wrap_res $ - SectionR x (mkLHsWrap wrap_fun op') arg2' ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(SectionL x arg1 op) res_ty - = do { (op', op_ty) <- tcInferFun op - ; dflags <- getDynFlags -- Note [Left sections] - ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 - | otherwise = 2 - - ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) - n_reqd_args op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkVisFunTys arg_tys op_res_ty) res_ty - ; arg1' <- tcArg op arg1 arg1_ty 1 - ; return ( mkHsWrap wrap_res $ - SectionL x arg1' (mkLHsWrap wrap_fn op') ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty - | all tupArgPresent tup_args - = do { let arity = length tup_args - tup_tc = tupleTyCon boxity arity - -- NB: tupleTyCon doesn't flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in MkCore - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty - -- Unboxed tuples have RuntimeRep vars, which we - -- don't care about here - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; tup_args1 <- tcTupArgs tup_args arg_tys' - ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } - - | otherwise - = -- The tup_args are a mixture of Present and Missing (for tuple sections) - do { let arity = length tup_args - - ; arg_tys <- case boxity of - { Boxed -> newFlexiTyVarTys arity liftedTypeKind - ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } - ; let actual_res_ty - = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args] - (mkTupleTy1 boxity arg_tys) - -- See Note [Don't flatten tuples from HsSyn] in MkCore - - ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple") - (Just expr) - actual_res_ty res_ty - - -- Handle tuple sections where - ; tup_args1 <- tcTupArgs tup_args arg_tys - - ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } - -tcExpr (ExplicitSum _ alt arity expr) res_ty - = do { let sum_tc = sumTyCon arity - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty - ; -- Drop levity vars, we don't care about them here - let arg_tys' = drop arity arg_tys - ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) - ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } - --- This will see the empty list only when -XOverloadedLists. --- See Note [Empty lists] in GHC.Hs.Expr. -tcExpr (ExplicitList _ witness exprs) res_ty - = case witness of - Nothing -> do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } - - Just fln -> do { ((exprs', elt_ty), fln') - <- tcSyntaxOp ListOrigin fln - [synKnownType intTy, SynList] res_ty $ - \ [elt_ty] -> - do { exprs' <- - mapM (tc_elt elt_ty) exprs - ; return (exprs', elt_ty) } - - ; return $ ExplicitList elt_ty (Just fln') exprs' } - where tc_elt elt_ty expr = tcPolyExpr expr elt_ty - -{- -************************************************************************ -* * - Let, case, if, do -* * -************************************************************************ --} - -tcExpr (HsLet x (L l binds) expr) res_ty - = do { (binds', expr') <- tcLocalBinds binds $ - tcMonoExpr expr res_ty - ; return (HsLet x (L l binds') expr') } - -tcExpr (HsCase x scrut matches) res_ty - = do { -- We used to typecheck the case alternatives first. - -- The case patterns tend to give good type info to use - -- when typechecking the scrutinee. For example - -- case (map f) of - -- (x:xs) -> ... - -- will report that map is applied to too few arguments - -- - -- But now, in the GADT world, we need to typecheck the scrutinee - -- first, to get type info that may be refined in the case alternatives - (scrut', scrut_ty) <- tcInferRho scrut - - ; traceTc "HsCase" (ppr scrut_ty) - ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - ; return (HsCase x scrut' matches') } - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = tcBody } - -tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; res_ty <- tauifyExpType res_ty - -- Just like Note [Case branches must never infer a non-tau type] - -- in TcMatches (See #10619) - - ; b1' <- tcMonoExpr b1 res_ty - ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf x Nothing pred' b1' b2') } - -tcExpr (HsIf x (Just fun) pred b1 b2) res_ty - = do { ((pred', b1', b2'), fun') - <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ - \ [pred_ty, b1_ty, b2_ty] -> - do { pred' <- tcPolyExpr pred pred_ty - ; b1' <- tcPolyExpr b1 b1_ty - ; b2' <- tcPolyExpr b2 b2_ty - ; return (pred', b1', b2') } - ; return (HsIf x (Just fun') pred' b1' b2') } - -tcExpr (HsMultiIf _ alts) res_ty - = do { res_ty <- if isSingleton alts - then return res_ty - else tauifyExpType res_ty - -- Just like TcMatches - -- Note [Case branches must never infer a non-tau type] - - ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts - ; res_ty <- readExpType res_ty - ; return (HsMultiIf res_ty alts') } - where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } - -tcExpr (HsDo _ do_or_lc stmts) res_ty - = do { expr' <- tcDoStmts do_or_lc stmts res_ty - ; return expr' } - -tcExpr (HsProc x pat cmd) res_ty - = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } - --- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. --- See Note [Grand plan for static forms] in StaticPtrTable for an overview. --- To type check --- (static e) :: p a --- we want to check (e :: a), --- and wrap (static e) in a call to --- fromStaticPtr :: IsStatic p => StaticPtr a -> p a - -tcExpr (HsStatic fvs expr) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty - ; (expr', lie) <- captureConstraints $ - addErrCtxt (hang (text "In the body of a static form:") - 2 (ppr expr) - ) $ - tcPolyExprNC expr expr_ty - - -- Check that the free variables of the static form are closed. - -- It's OK to use nonDetEltsUniqSet here as the only side effects of - -- checkClosedInStaticForm are error messages. - ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs - - -- Require the type of the argument to be Typeable. - -- The evidence is not used, but asking the constraint ensures that - -- the current implementation is as restrictive as future versions - -- of the StaticPointers extension. - ; typeableClass <- tcLookupClass typeableClassName - ; _ <- emitWantedEvVar StaticOrigin $ - mkTyConApp (classTyCon typeableClass) - [liftedTypeKind, expr_ty] - - -- Insert the constraints of the static form in a global list for later - -- validation. - ; emitStaticConstraints lie - - -- Wrap the static form with the 'fromStaticPtr' call. - ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName - [p_ty] - ; let wrap = mkWpTyApps [expr_ty] - ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp noExtField - (L loc $ mkHsWrap wrap fromStaticPtr) - (L loc (HsStatic fvs expr')) - } - -{- -************************************************************************ -* * - Record construction and update -* * -************************************************************************ --} - -tcExpr expr@(RecordCon { rcon_con_name = L loc con_name - , rcon_flds = rbinds }) res_ty - = do { con_like <- tcLookupConLike con_name - - -- Check for missing fields - ; checkMissingFields con_like rbinds - - ; (con_expr, con_sigma) <- tcInferId con_name - ; (con_wrap, con_tau) <- - topInstantiate (OccurrenceOf con_name) con_sigma - -- a shallow instantiation should really be enough for - -- a data constructor. - ; let arity = conLikeArity con_like - Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - ; case conLikeWrapId_maybe con_like of - Nothing -> nonBidirectionalErr (conLikeName con_like) - Just con_id -> do { - res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon") - (Just expr) actual_res_ty res_ty - ; rbinds' <- tcRecordBinds con_like arg_tys rbinds - ; return $ - mkHsWrap res_wrap $ - RecordCon { rcon_ext = RecordConTc - { rcon_con_like = con_like - , rcon_con_expr = mkHsWrap con_wrap con_expr } - , rcon_con_name = L loc con_id - , rcon_flds = rbinds' } } } - -{- -Note [Type of a record update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The main complication with RecordUpd is that we need to explicitly -handle the *non-updated* fields. Consider: - - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} - -The result type should be (T a b' c) -not (T a b c), because 'b' *is not* mentioned in a non-updated field -not (T a b' c'), because 'c' *is* mentioned in a non-updated field -NB that it's not good enough to look at just one constructor; we must -look at them all; cf #3219 - -After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... - -So we need to give a completely fresh type to the result record, -and then constrain it by the fields that are *not* updated ("p" above). -We call these the "fixed" type variables, and compute them in getFixedTyVars. - -Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints. -Hence the use of 'relevant_cont'. - -Note [Implicit type sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } -So the "real" type of MkT is: forall ab. (a~b) => a -> T a b - -Then consider - upd t x = t { f=x } -We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } -We can't give it the more general type - upd :: T a b -> c -> T c b - -Note [Criteria for update] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow update for existentials etc, provided the updated -field isn't part of the existential. For example, this should be ok. - data T a where { MkT { f1::a, f2::b->b } :: T a } - f :: T a -> b -> T b - f t b = t { f1=b } - -The criterion we use is this: - - The types of the updated fields - mention only the universally-quantified type variables - of the data constructor - -NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in TcTyClsDecls), at least -in the case of GADTs. Consider - data T a where { MkT :: { f :: a } :: T [a] } -Then f is not "naughty" because it has a well-typed record selector. -But we don't allow updates for 'f'. (One could consider trying to -allow this, but it makes my head hurt. Badly. And no one has asked -for it.) - -In principle one could go further, and allow - g :: T a -> T a - g t = t { f2 = \x -> x } -because the expression is polymorphic...but that seems a bridge too far. - -Note [Data family example] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - data instance T (a,b) = MkT { x::a, y::b } - ---> - data :TP a b = MkT { a::a, y::b } - coTP a b :: T (a,b) ~ :TP a b - -Suppose r :: T (t1,t2), e :: t3 -Then r { x=e } :: T (t3,t1) - ---> - case r |> co1 of - MkT x y -> MkT e y |> co2 - where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) -The wrapping with co2 is done by the constructor wrapper for MkT - -Outgoing invariants -~~~~~~~~~~~~~~~~~~~ -In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): - - * cons are the data constructors to be updated - - * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - -Note [Mixed Record Field Updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym. - - data MyRec = MyRec { foo :: Int, qux :: String } - - pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -This allows updates such as the following - - updater :: MyRec -> MyRec - updater a = a {f1 = 1 } - -It would also make sense to allow the following update (which we reject). - - updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" - -This leads to confusing behaviour when the selectors in fact refer the same -field. - - updater a = a {f1 = 1, foo = 2} ==? ??? - -For this reason, we reject a mixture of pattern synonym and normal record -selectors in the same update block. Although of course we still allow the -following. - - updater a = (a {f1 = 1}) {foo = 2} - - > updater (MyRec 0 "str") - MyRec 2 "str" - --} - -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty - = ASSERT( notNull rbnds ) - do { -- STEP -2: typecheck the record_expr, the record to be updated - (record_expr', record_rho) <- tcInferRho record_expr - - -- STEP -1 See Note [Disambiguating record fields] - -- After this we know that rbinds is unambiguous - ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty - ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds - upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds - sel_ids = map selectorAmbiguousFieldOcc upd_flds - -- STEP 0 - -- Check that the field names are really field names - -- and they are all field names for proper records or - -- all field names for pattern synonyms. - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | fld <- rbinds, - -- Excludes class ops - let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), - let fld_name = idName sel_id ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - -- See note [Mixed Record Selectors] - ; let (data_sels, pat_syn_sels) = - partition isDataConRecordSelector sel_ids - ; MASSERT( all isPatSynRecordSelector pat_syn_sels ) - ; checkTc ( null data_sels || null pat_syn_sels ) - ( mixedSelectors data_sels pat_syn_sels ) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - - mtycon :: Maybe TyCon - mtycon = case idDetails sel_id of - RecSelId (RecSelData tycon) _ -> Just tycon - _ -> Nothing - - con_likes :: [ConLike] - con_likes = case idDetails sel_id of - RecSelId (RecSelData tc) _ - -> map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ - -> [PatSynCon ps] - _ -> panic "tcRecordUpd" - -- NB: for a data type family, the tycon is the instance tycon - - relevant_cons = conLikesWithFields con_likes upd_fld_occs - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- Step 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) - - -- Take apart a representative constructor - ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) - = conLikeFullSig con1 - con1_flds = map flLabel $ conLikeFieldLabels con1 - con1_tv_tys = mkTyVarTys con1_tvs - con1_res_ty = case mtycon of - Just tc -> mkFamilyTyConApp tc con1_tv_tys - Nothing -> conLikeResTy con1 con1_tv_tys - - -- Check that we're not dealing with a unidirectional pattern - -- synonym - ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) - - -- STEP 3 Note [Criteria for update] - -- Check that each updated field is polymorphic; that is, its type - -- mentions only the universally-quantified variables of the data con - ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - bad_upd_flds = filter bad_fld flds1_w_tys - con1_tv_set = mkVarSet con1_tvs - bad_fld (fld, ty) = fld `elem` upd_fld_occs && - not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) - - -- STEP 4 Note [Type of a record update] - -- Figure out types for the scrutinee and result - -- Both are of form (T a b c), with fresh type variables, but with - -- common variables where the scrutinee and result must have the same type - -- These are variables that appear in *any* arg of *any* of the - -- relevant constructors *except* in the updated fields - -- - ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons - is_fixed_tv tv = tv `elemVarSet` fixed_tvs - - mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) - -- Deals with instantiation of kind variables - -- c.f. TcMType.newMetaTyVars - mk_inst_ty subst (tv, result_inst_ty) - | is_fixed_tv tv -- Same as result type - = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) - | otherwise -- Fresh type, of correct kind - = do { (subst', new_tv) <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy new_tv) } - - ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs - ; let result_inst_tys = mkTyVarTys con1_tvs' - init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) - - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst - (con1_tvs `zip` result_inst_tys) - - ; let rec_res_ty = TcType.substTy result_subst con1_res_ty - scrut_ty = TcType.substTy scrut_subst con1_res_ty - con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - - ; wrap_res <- tcSubTypeHR (exprCtOrigin expr) - (Just expr) rec_res_ty res_ty - ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty - -- NB: normal unification is OK here (as opposed to subsumption), - -- because for this to work out, both record_rho and scrut_ty have - -- to be normal datatypes -- no contravariant stuff can go on - - -- STEP 5 - -- Typecheck the bindings - ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds - - -- STEP 6: Deal with the stupid theta - ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) - ; instStupidTheta RecordUpdOrigin theta' - - -- Step 7: make a cast for the scrutinee, in the - -- case that it's from a data family - ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty - fam_co | Just tycon <- mtycon - , Just co_con <- tyConFamilyCoercion_maybe tycon - = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) - | otherwise - = idHsWrapper - - -- Step 8: Check that the req constraints are satisfied - -- For normal data constructors req_theta is empty but we must do - -- this check for pattern synonyms. - ; let req_theta' = substThetaUnchecked scrut_subst req_theta - ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' - - -- Phew! - ; return $ - mkHsWrap wrap_res $ - RecordUpd { rupd_expr - = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') - , rupd_flds = rbinds' - , rupd_ext = RecordUpdTc - { rupd_cons = relevant_cons - , rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys - , rupd_wrap = req_wrap }} } - -tcExpr e@(HsRecFld _ f) res_ty - = tcCheckRecSelId e f res_ty - -{- -************************************************************************ -* * - Arithmetic sequences e.g. [a,b..] - and their parallel-array counterparts e.g. [: a,b.. :] - -* * -************************************************************************ --} - -tcExpr (ArithSeq _ witness seq) res_ty - = tcArithSeq witness seq res_ty - -{- -************************************************************************ -* * - Template Haskell -* * -************************************************************************ --} - --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) - res_ty - = do addModFinalizersWithLclEnv mod_finalizers - tcExpr expr res_ty -tcExpr (HsSpliceE _ splice) res_ty - = tcSpliceExpr splice res_ty -tcExpr e@(HsBracket _ brack) res_ty - = tcTypedBracket e brack res_ty -tcExpr e@(HsRnBracketOut _ brack ps) res_ty - = tcUntypedBracket e brack ps res_ty - -{- -************************************************************************ -* * - Catch-all -* * -************************************************************************ --} - -tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) - -- Include ArrForm, ArrApp, which shouldn't appear at all - -- Also HsTcBracketOut, HsQuasiQuoteE - -{- -************************************************************************ -* * - Arithmetic sequences [a..b] etc -* * -************************************************************************ --} - -tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -tcArithSeq witness seq@(From expr) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr' <- tcPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from wit' (From expr') } - -tcArithSeq witness seq@(FromThen expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_then wit' (FromThen expr1' expr2') } - -tcArithSeq witness seq@(FromTo expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_to wit' (FromTo expr1' expr2') } - -tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } - ------------------ -arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType - -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc)) -arithSeqEltType Nothing res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, elt_ty, Nothing) } -arithSeqEltType (Just fl) res_ty - = do { (elt_ty, fl') - <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ - \ [elt_ty] -> return elt_ty - ; return (idHsWrapper, elt_ty, Just fl') } - -{- -************************************************************************ -* * - Applications -* * -************************************************************************ --} - --- HsArg is defined in GHC.Hs.Types - -wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn) - => LHsExpr (GhcPass id) - -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)] - -> LHsExpr (GhcPass id) -wrapHsArgs f [] = f -wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args -wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t) args -wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExtField f) args - -isHsValArg :: HsArg tm ty -> Bool -isHsValArg (HsValArg {}) = True -isHsValArg (HsTypeArg {}) = False -isHsValArg (HsArgPar {}) = False - -isArgPar :: HsArg tm ty -> Bool -isArgPar (HsArgPar {}) = True -isArgPar (HsValArg {}) = False -isArgPar (HsTypeArg {}) = False - -isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d) -isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp -isArgPar_maybe _ = Nothing - -type LHsExprArgIn = HsArg (LHsExpr GhcRn) (LHsWcType GhcRn) -type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn) - -tcApp1 :: HsExpr GhcRn -- either HsApp or HsAppType - -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcApp1 e res_ty - = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty - ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) } - -tcApp :: Maybe SDoc -- like "The function `f' is applied to" - -- or leave out to get exactly that message - -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args - -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - -- (wrap, fun, args). For an ordinary function application, - -- these should be assembled as (wrap (fun args)). - -- But OpApp is slightly different, so that's why the caller - -- must assemble - -tcApp m_herald (L sp (HsPar _ fun)) args res_ty - = tcApp m_herald fun (HsArgPar sp : args) res_ty - -tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty - = tcApp m_herald fun (HsValArg arg1 : args) res_ty - -tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty - = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty - -tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty - | Ambiguous _ lbl <- fld_lbl -- Still ambiguous - , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first - , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) - ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty } - -tcApp _m_herald (L loc (HsVar _ (L _ fun_id))) args res_ty - -- Special typing rule for tagToEnum# - | fun_id `hasKey` tagToEnumKey - , n_val_args == 1 - = tcTagToEnum loc fun_id args res_ty - where - n_val_args = count isHsValArg args - -tcApp m_herald fun args res_ty - = do { (tc_fun, fun_ty) <- tcInferFun fun - ; tcFunApp m_herald fun tc_fun fun_ty args res_ty } - ---------------------- -tcFunApp :: Maybe SDoc -- like "The function `f' is applied to" - -- or leave out to get exactly that message - -> LHsExpr GhcRn -- Renamed function - -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type - -> [LHsExprArgIn] -- Arguments - -> ExpRhoType -- Overall result type - -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - -- (wrapper-for-result, fun, args) - -- For an ordinary function application, - -- these should be assembled as wrap_res[ fun args ] - -- But OpApp is slightly different, so that's why the caller - -- must assemble - --- tcFunApp deals with the general case; --- the special cases are handled by tcApp -tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty - = do { let orig = lexprCtOrigin rn_fun - - ; traceTc "tcFunApp" (ppr rn_fun <+> dcolon <+> ppr fun_sigma $$ ppr rn_args $$ ppr res_ty) - ; (wrap_fun, tc_args, actual_res_ty) - <- tcArgs rn_fun fun_sigma orig rn_args - (m_herald `orElse` mk_app_msg rn_fun rn_args) - - -- this is just like tcWrapResult, but the types don't line - -- up to call that function - ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $ - tcSubTypeDS_NC_O orig GenSigCtxt - (Just $ unLoc $ wrapHsArgs rn_fun rn_args) - actual_res_ty res_ty - - ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) } - -mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc -mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr) - , text "is applied to"] - where - what | null type_app_args = "function" - | otherwise = "expression" - -- Include visible type arguments (but not other arguments) in the herald. - -- See Note [Herald for matchExpectedFunTys] in TcUnify. - expr = mkHsAppTypes fun type_app_args - type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args] - -mk_op_msg :: LHsExpr GhcRn -> SDoc -mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" - ----------------- -tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) --- Infer type of a function -tcInferFun (L loc (HsVar _ (L _ name))) - = do { (fun, ty) <- setSrcSpan loc (tcInferId name) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun (L loc (HsRecFld _ f)) - = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun fun - = tcInferSigma fun - -- NB: tcInferSigma; see TcUnify - -- Note [Deep instantiation of InferResult] in TcUnify - - ----------------- --- | Type-check the arguments to a function, possibly including visible type --- applications -tcArgs :: LHsExpr GhcRn -- ^ The function itself (for err msgs only) - -> TcSigmaType -- ^ the (uninstantiated) type of the function - -> CtOrigin -- ^ the origin for the function's type - -> [LHsExprArgIn] -- ^ the args - -> SDoc -- ^ the herald for matchActualFunTys - -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType) - -- ^ (a wrapper for the function, the tc'd args, result type) -tcArgs fun orig_fun_ty fun_orig orig_args herald - = go [] 1 orig_fun_ty orig_args - where - -- Don't count visible type arguments when determining how many arguments - -- an expression is given in an arity mismatch error, since visible type - -- arguments reported as a part of the expression herald itself. - -- See Note [Herald for matchExpectedFunTys] in TcUnify. - orig_expr_args_arity = count isHsValArg orig_args - - fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = case fun of - L _ (HsUnboundVar {}) -> True - _ -> False - - go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty) - - go acc_args n fun_ty (HsArgPar sp : args) - = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args - ; return (inner_wrap, HsArgPar sp : args', res_ty) - } - - go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args) - | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = go acc_args (n+1) fun_ty args - - | otherwise - = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty - -- wrap1 :: fun_ty "->" upsilon_ty - ; case tcSplitForAllTy_maybe upsilon_ty of - Just (tvb, inner_ty) - | binderArgFlag tvb == Specified -> - -- It really can't be Inferred, because we've justn - -- instantiated those. But, oddly, it might just be Required. - -- See Note [Required quantifiers in the type of a term] - do { let tv = binderVar tvb - kind = tyVarKind tv - ; ty_arg <- tcHsTypeApp hs_ty_arg kind - - ; inner_ty <- zonkTcType inner_ty - -- See Note [Visible type application zonk] - ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) - - insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty - -- NB: tv and ty_arg have the same kind, so this - -- substitution is kind-respecting - ; traceTc "VTA" (vcat [ppr tv, debugPprType kind - , debugPprType ty_arg - , debugPprType (tcTypeKind ty_arg) - , debugPprType inner_ty - , debugPprType insted_ty ]) - - ; (inner_wrap, args', res_ty) - <- go acc_args (n+1) insted_ty args - -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty - ; let inst_wrap = mkWpTyApps [ty_arg] - ; return ( inner_wrap <.> inst_wrap <.> wrap1 - , HsTypeArg l hs_ty_arg : args' - , res_ty ) } - _ -> ty_app_err upsilon_ty hs_ty_arg } - - go acc_args n fun_ty (HsValArg arg : args) - = do { (wrap, [arg_ty], res_ty) - <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty - acc_args orig_expr_args_arity - -- wrap :: fun_ty "->" arg_ty -> res_ty - ; arg' <- tcArg fun arg arg_ty n - ; (inner_wrap, args', inner_res_ty) - <- go (arg_ty : acc_args) (n+1) res_ty args - -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty - ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap - , HsValArg arg' : args' - , inner_res_ty ) } - where - doc = text "When checking the" <+> speakNth n <+> - text "argument to" <+> quotes (ppr fun) - - ty_app_err ty arg - = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty - ; failWith $ - text "Cannot apply expression of type" <+> quotes (ppr ty) $$ - text "to a visible type argument" <+> quotes (ppr arg) } - -{- Note [Required quantifiers in the type of a term] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15859) - - data A k :: k -> Type -- A :: forall k -> k -> Type - type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type - a = (undefind :: KindOf A) @Int - -With ImpredicativeTypes (thin ice, I know), we instantiate -KindOf at type (forall k -> k -> Type), so - KindOf A = forall k -> k -> Type -whose first argument is Required - -We want to reject this type application to Int, but in earlier -GHCs we had an ASSERT that Required could not occur here. - -The ice is thin; c.f. Note [No Required TyCoBinder in terms] -in TyCoRep. - -Note [VTA for out-of-scope functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose 'wurble' is not in scope, and we have - (wurble @Int @Bool True 'x') - -Then the renamer will make (HsUnboundVar "wurble) for 'wurble', -and the typechecker will typecheck it with tcUnboundId, giving it -a type 'alpha', and emitting a deferred CHoleCan constraint, to -be reported later. - -But then comes the visible type application. If we do nothing, we'll -generate an immediate failure (in tc_app_err), saying that a function -of type 'alpha' can't be applied to Bool. That's insane! And indeed -users complain bitterly (#13834, #17150.) - -The right error is the CHoleCan, which has /already/ been emitted by -tcUnboundId. It later reports 'wurble' as out of scope, and tries to -give its type. - -Fortunately in tcArgs we still have access to the function, so we can -check if it is a HsUnboundVar. We use this info to simply skip over -any visible type arguments. We've already inferred the type of the -function, so we'll /already/ have emitted a CHoleCan constraint; -failing preserves that constraint. - -We do /not/ want to fail altogether in this case (via failM) becuase -that may abandon an entire instance decl, which (in the presence of --fdefer-type-errors) leads to leading to #17792. - -Downside; the typechecked term has lost its visible type arguments; we -don't even kind-check them. But let's jump that bridge if we come to -it. Meanwhile, let's not crash! - -Note [Visible type application zonk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). - -* tcHsTypeApp only guarantees that - - ty_arg is zonked - - kind(zonk(tv)) = kind(ty_arg) - (checkExpectedKind zonks as it goes). - -So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) -and inner_ty. Otherwise we can build an ill-kinded type. An example was -#14158, where we had: - id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a -and we had the visible type application - id @(->) - -* We instantiated k := kappa, yielding - forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a -* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). -* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, - Here q1 :: RuntimeRep -* Now we substitute - cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * - but we must first zonk the inner_ty to get - forall (a :: TYPE q1). cat a a - so that the result of substitution is well-kinded - Failing to do so led to #14158. --} - ----------------- -tcArg :: LHsExpr GhcRn -- The function (for error messages) - -> LHsExpr GhcRn -- Actual arguments - -> TcRhoType -- expected arg type - -> Int -- # of argument - -> TcM (LHsExpr GhcTcId) -- Resulting argument -tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcPolyExprNC arg ty - ----------------- -tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId] -tcTupArgs args tys - = ASSERT( equalLength args tys ) mapM go (args `zip` tys) - where - go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) - go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (L l (Present x expr')) } - go (L _ (XTupArg nec), _) = noExtCon nec - ---------------------------- --- See TcType.SyntaxOpType also for commentary -tcSyntaxOp :: CtOrigin - -> SyntaxExpr GhcRn - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpRhoType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr GhcTcId) --- ^ Typecheck a syntax operator --- The operator is a variable or a lambda at this stage (i.e. renamer --- output) -tcSyntaxOp orig expr arg_tys res_ty - = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) - --- | Slightly more general version of 'tcSyntaxOp' that allows the caller --- to specify the shape of the result of the syntax operator -tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr GhcRn - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr GhcTcId) -tcSyntaxOpGen orig op arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op - ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) - ; (result, expr_wrap, arg_wraps, res_wrap) - <- tcSynArgA orig sigma arg_tys res_ty $ - thing_inside - ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) - ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) } - -{- -Note [tcSynArg] -~~~~~~~~~~~~~~~ -Because of the rich structure of SyntaxOpType, we must do the -contra-/covariant thing when working down arrows, to get the -instantiation vs. skolemisation decisions correct (and, more -obviously, the orientation of the HsWrappers). We thus have -two tcSynArgs. --} - --- works on "expected" types, skolemising where necessary --- See Note [tcSynArg] -tcSynArgE :: CtOrigin - -> TcSigmaType - -> SyntaxOpType -- ^ shape it is expected to have - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper) - -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) -tcSynArgE orig sigma_ty syn_ty thing_inside - = do { (skol_wrap, (result, ty_wrapper)) - <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty -> - go rho_ty syn_ty - ; return (result, skol_wrap <.> ty_wrapper) } - where - go rho_ty SynAny - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynRho -- same as SynAny, because we skolemise eagerly - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynList - = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN list_co) } - - go rho_ty (SynFun arg_shape res_shape) - = do { ( ( ( (result, arg_ty, res_ty) - , res_wrapper ) -- :: res_ty_out "->" res_ty - , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out - , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty - <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $ - \ [arg_ty] res_ty -> - do { arg_tc_ty <- expTypeToType arg_ty - ; res_tc_ty <- expTypeToType res_ty - - -- another nested arrow is too much for now, - -- but I bet we'll never need this - ; MASSERT2( case arg_shape of - SynFun {} -> False; - _ -> True - , text "Too many nested arrows in SyntaxOpType" $$ - pprCtOrigin orig ) - - ; tcSynArgA orig arg_tc_ty [] arg_shape $ - \ arg_results -> - tcSynArgE orig res_tc_ty res_shape $ - \ res_results -> - do { result <- thing_inside (arg_results ++ res_results) - ; return (result, arg_tc_ty, res_tc_ty) }} - - ; return ( result - , match_wrapper <.> - mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - arg_ty res_ty doc ) } - where - herald = text "This rebindable syntax expects a function with" - doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig - - go rho_ty (SynType the_ty) - = do { wrap <- tcSubTypeET orig GenSigCtxt the_ty rho_ty - ; result <- thing_inside [] - ; return (result, wrap) } - --- works on "actual" types, instantiating where necessary --- See Note [tcSynArg] -tcSynArgA :: CtOrigin - -> TcSigmaType - -> [SyntaxOpType] -- ^ argument shapes - -> SyntaxOpType -- ^ result shape - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) - -- ^ returns a wrapper to be applied to the original function, - -- wrappers to be applied to arguments - -- and a wrapper to be applied to the overall expression -tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside - = do { (match_wrapper, arg_tys, res_ty) - <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty - -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) - ; ((result, res_wrapper), arg_wrappers) - <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> - tc_syn_arg res_ty res_shape $ \ res_results -> - thing_inside (arg_results ++ res_results) - ; return (result, match_wrapper, arg_wrappers, res_wrapper) } - where - herald = text "This rebindable syntax expects a function with" - - tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] - -> ([TcSigmaType] -> TcM a) - -> TcM (a, [HsWrapper]) - -- the wrappers are for arguments - tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside - = do { ((result, arg_wraps), arg_wrap) - <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> - tc_syn_args_e arg_tys arg_shapes $ \ args_results -> - thing_inside (arg1_results ++ args_results) - ; return (result, arg_wrap : arg_wraps) } - tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] - - tc_syn_arg :: TcSigmaType -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, HsWrapper) - -- the wrapper applies to the overall result - tc_syn_arg res_ty SynAny thing_inside - = do { result <- thing_inside [res_ty] - ; return (result, idHsWrapper) } - tc_syn_arg res_ty SynRho thing_inside - = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; result <- thing_inside [rho_ty] - ; return (result, inst_wrap) } - tc_syn_arg res_ty SynList thing_inside - = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; (list_co, elt_ty) <- matchExpectedListTy rho_ty - -- list_co :: [elt_ty] ~N rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } - tc_syn_arg _ (SynFun {}) _ - = pprPanic "tcSynArgA hits a SynFun" (ppr orig) - tc_syn_arg res_ty (SynType the_ty) thing_inside - = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty - ; result <- thing_inside [] - ; return (result, wrap) } - -{- -Note [Push result type in] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unify with expected result before type-checking the args so that the -info from res_ty percolates to args. This is when we might detect a -too-few args situation. (One can think of cases when the opposite -order would give a better error message.) -experimenting with putting this first. - -Here's an example where it actually makes a real difference - - class C t a b | t a -> b - instance C Char a Bool - - data P t a = forall b. (C t a b) => MkP b - data Q t = MkQ (forall a. P t a) - - f1, f2 :: Q Char; - f1 = MkQ (MkP True) - f2 = MkQ (MkP True :: forall a. P Char a) - -With the change, f1 will type-check, because the 'Char' info from -the signature is propagated into MkQ's argument. With the check -in the other order, the extra signature in f2 is reqd. - -************************************************************************ -* * - Expressions with a type signature - expr :: type -* * -********************************************************************* -} - -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType) -tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - ; given <- newEvVars theta - ; traceTc "tcExprSig: CompleteSig" $ - vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id) - , text "tv_prs:" <+> ppr tv_prs ] - - ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ - tcExtendNameTyVarEnv tv_prs $ - tcPolyExprNC expr tau - - ; let poly_wrap = mkWpTyLams skol_tvs - <.> mkWpLams given - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', idType poly_id) } - -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tclvl, wanted, (expr', sig_inst)) - <- pushLevelAndCaptureConstraints $ - do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ - tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ - tcPolyExprNC expr (sig_inst_tau sig_inst) - ; return (expr', sig_inst) } - -- See Note [Partial expression signatures] - ; let tau = sig_inst_tau sig_inst - infer_mode | null (sig_inst_theta sig_inst) - , isNothing (sig_inst_wcx sig_inst) - = ApplyMR - | otherwise - = NoRestrictions - ; (qtvs, givens, ev_binds, residual, _) - <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted - ; emitConstraints residual - - ; tau <- zonkTcType tau - ; let inferred_theta = map evVarPred givens - tau_tvs = tyCoVarsOfType tau - ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta - tau_tvs qtvs (Just sig_inst) - ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) - ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguous type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma - - ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) - ; let poly_wrap = wrap - <.> mkWpTyLams qtvs - <.> mkWpLams givens - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', my_sigma) } - - -{- Note [Partial expression signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial type signatures on expressions are easy to get wrong. But -here is a guiding principile - e :: ty -should behave like - let x :: ty - x = e - in x - -So for partial signatures we apply the MR if no context is given. So - e :: IO _ apply the MR - e :: _ => IO _ do not apply the MR -just like in TcBinds.decideGeneralisationPlan - -This makes a difference (#11670): - peek :: Ptr a -> IO CLong - peek ptr = peekElemOff undefined 0 :: _ -from (peekElemOff undefined 0) we get - type: IO w - constraints: Storable w - -We must NOT try to generalise over 'w' because the signature specifies -no constraints so we'll complain about not being able to solve -Storable w. Instead, don't generalise; then _ gets instantiated to -CLong, as it should. --} - -{- ********************************************************************* -* * - tcInferId -* * -********************************************************************* -} - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckId name res_ty - = do { (expr, actual_res_ty) <- tcInferId name - ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False (HsVar noExtField (noLoc name)) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr - actual_res_ty res_ty } - -tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty - = do { (expr, actual_res_ty) <- tcInferRecSelId f - ; addFunResCtxt False (HsRecFld noExtField f) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } -tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty - = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of - Nothing -> ambiguousSelector lbl - Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg - ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) - res_ty } -tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec - ------------------------- -tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) -tcInferRecSelId (Unambiguous sel (L _ lbl)) - = do { (expr', ty) <- tc_infer_id lbl sel - ; return (expr', ty) } -tcInferRecSelId (Ambiguous _ lbl) - = ambiguousSelector lbl -tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec - ------------------------- -tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) --- Look up an occurrence of an Id --- Do not instantiate its type -tcInferId id_name - | id_name `hasKey` tagToEnumKey - = failWithTc (text "tagToEnum# must appear applied to one argument") - -- tcApp catches the case (tagToEnum# arg) - - | id_name `hasKey` assertIdKey - = do { dflags <- getDynFlags - ; if gopt Opt_IgnoreAsserts dflags - then tc_infer_id (nameRdrName id_name) id_name - else tc_infer_assert id_name } - - | otherwise - = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name - ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) - ; return (expr, ty) } - -tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) --- Deal with an occurrence of 'assert' --- See Note [Adding the implicit parameter to 'assert'] -tc_infer_assert assert_name - = do { assert_error_id <- tcLookupId assertErrorName - ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) - (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) - } - -tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) -tc_infer_id lbl id_name - = do { thing <- tcLookup id_name - ; case thing of - ATcId { tct_id = id } - -> do { check_naughty id -- Note [Local record selectors] - ; checkThLocalId id - ; return_id id } - - AGlobal (AnId id) - -> do { check_naughty id - ; return_id id } - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- hence no checkTh stuff here - - AGlobal (AConLike cl) -> case cl of - RealDataCon con -> return_data_con con - PatSynCon ps -> tcPatSynBuilderOcc ps - - _ -> failWithTc $ - ppr thing <+> text "used where a value identifier was expected" } - where - return_id id = return (HsVar noExtField (noLoc id), idType id) - - return_data_con con - -- For data constructors, must perform the stupid-theta check - | null stupid_theta - = return (HsConLikeOut noExtField (RealDataCon con), con_ty) - - | otherwise - -- See Note [Instantiating stupid theta] - = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty - ; (subst, tvs') <- newMetaTyVars tvs - ; let tys' = mkTyVarTys tvs' - theta' = substTheta subst theta - rho' = substTy subst rho - ; wrap <- instCall (OccurrenceOf id_name) tys' theta' - ; addDataConStupidTheta con tys' - ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con)) - , rho') } - - where - con_ty = dataConUserType con - stupid_theta = dataConStupidTheta con - - check_naughty id - | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) - | otherwise = return () - - -tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) --- Typecheck an occurrence of an unbound Id --- --- Some of these started life as a true expression hole "_". --- Others might simply be variables that accidentally have no binding site --- --- We turn all of them into HsVar, since HsUnboundVar can't contain an --- Id; and indeed the evidence for the CHoleCan does bind it, so it's --- not unbound any more! -tcUnboundId rn_expr unbound res_ty - = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) - ; let occ = unboundVarOcc unbound - ; name <- newSysName occ - ; let ev = mkLocalId name ty - ; can <- newHoleCt (ExprHole unbound) ev ty - ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr - (HsVar noExtField (noLoc ev)) ty res_ty } - - -{- -Note [Adding the implicit parameter to 'assert'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker transforms (assert e1 e2) to (assertError e1 e2). -This isn't really the Right Thing because there's no way to "undo" -if you want to see the original source code in the typechecker -output. We'll have fix this in due course, when we care more about -being able to reconstruct the exact original program. - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude, because it relies on our -knowing *now* that the type is ok, which in turn relies on the -eager-unification part of the type checker pushing enough information -here. In theory the Right Thing to do is to have a new form of -constraint but I definitely cannot face that! And it works ok as-is. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -When data type families are involved it's a bit more complicated. - data family F a - data instance F [Int] = A | B | C -Then we want to generate something like - tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] -Usually that coercion is hidden inside the wrappers for -constructors of F [Int] but here we have to do it explicitly. - -It's all grotesquely complicated. - -Note [Instantiating stupid theta] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, when we infer the type of an Id, we don't instantiate, -because we wish to allow for visible type application later on. -But if a datacon has a stupid theta, we're a bit stuck. We need -to emit the stupid theta constraints with instantiated types. It's -difficult to defer this to the lazy instantiation, because a stupid -theta has no spot to put it in a type. So we just instantiate eagerly -in this case. Thus, users cannot use visible type application with -a data constructor sporting a stupid theta. I won't feel so bad for -the users that complain. - --} - -tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType - -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) --- tagToEnum# :: forall a. Int# -> a --- See Note [tagToEnum#] Urgh! -tcTagToEnum loc fun_name args res_ty - = do { fun <- tcLookupId fun_name - - ; let pars1 = mapMaybe isArgPar_maybe before - pars2 = mapMaybe isArgPar_maybe after - -- args contains exactly one HsValArg - (before, _:after) = break isHsValArg args - - ; arg <- case filterOut isArgPar args of - [HsTypeArg _ hs_ty_arg, HsValArg term_arg] - -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind - ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty - -- other than influencing res_ty, we just - -- don't care about a type arg passed in. - -- So drop the evidence. - ; return term_arg } - [HsValArg term_arg] -> do { _ <- expTypeToType res_ty - ; return term_arg } - _ -> too_many_args "tagToEnum#" args - - ; res_ty <- readExpType res_ty - ; ty' <- zonkTcType res_ty - - -- Check that the type is algebraic - ; let mb_tc_app = tcSplitTyConApp_maybe ty' - Just (tc, tc_args) = mb_tc_app - ; checkTc (isJust mb_tc_app) - (mk_error ty' doc1) - - -- Look through any type family - ; fam_envs <- tcGetFamInstEnvs - ; let (rep_tc, rep_args, coi) - = tcLookupDataFamInst fam_envs tc tc_args - -- coi :: tc tc_args ~R rep_tc rep_args - - ; checkTc (isEnumerationTyCon rep_tc) - (mk_error ty' doc2) - - ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExtField (L loc fun))) - rep_ty = mkTyConApp rep_tc rep_args - out_args = concat - [ pars1 - , [HsValArg arg'] - , pars2 - ] - - ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) } - -- coi is a Representational coercion - where - doc1 = vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ] - doc2 = text "Result type must be an enumeration type" - - mk_error :: TcType -> SDoc -> SDoc - mk_error ty what - = hang (text "Bad call to tagToEnum#" - <+> text "at type" <+> ppr ty) - 2 what - -too_many_args :: String -> [LHsExprArgIn] -> TcM a -too_many_args fun args - = failWith $ - hang (text "Too many type arguments to" <+> text fun <> colon) - 2 (sep (map pp args)) - where - pp (HsValArg e) = ppr e - pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t - pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec - pp (HsArgPar _) = empty - - -{- -************************************************************************ -* * - Template Haskell checks -* * -************************************************************************ --} - -checkThLocalId :: Id -> TcM () -checkThLocalId id - = do { mb_local_use <- getStageAndBindLevel (idName id) - ; case mb_local_use of - Just (top_lvl, bind_lvl, use_stage) - | thLevel use_stage > bind_lvl - -> checkCrossStageLifting top_lvl id use_stage - _ -> return () -- Not a locally-bound thing, or - -- no cross-stage link - } - --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () --- If we are inside typed brackets, and (use_lvl > bind_lvl) --- we must check whether there's a cross-stage lift to do --- Examples \x -> [|| x ||] --- [|| map ||] --- There is no error-checking to do, because the renamer did that --- --- This is similar to checkCrossStageLifting in RnSplice, but --- this code is applied to *typed* brackets. - -checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var)) - | isTopLevel top_lvl - = when (isExternalName id_name) (keepAlive id_name) - -- See Note [Keeping things alive for Template Haskell] in RnSplice - - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [|| h x ||] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same splice proxy, but that doesn't - -- matter, although it's a mite untidy. - do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (polySpliceErr id) - -- If x is polymorphic, its occurrence sites might - -- have different instantiations, so we can't use plain - -- 'x' as the splice proxy name. I don't know how to - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId THNames.liftStringName - -- See Note [Lifting strings] - ; return (HsVar noExtField (noLoc sid)) } - else - setConstraintVar lie_var $ - -- Put the 'lift' constraint into the right LIE - newMethodFromName (OccurrenceOf id_name) - THNames.liftName - [getRuntimeRep id_ty, id_ty] - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; let pending_splice = PendingTcSplice id_name - (nlHsApp (noLoc lift) (nlHsVar id)) - ; writeMutVar ps_var (pending_splice : ps) - - ; return () } - where - id_name = idName id - -checkCrossStageLifting _ _ _ = return () - -polySpliceErr :: Id -> SDoc -polySpliceErr id - = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) - -{- -Note [Lifting strings] -~~~~~~~~~~~~~~~~~~~~~~ -If we see $(... [| s |] ...) where s::String, we don't want to -generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. -So this conditional short-circuits the lifting mechanism to generate -(liftString "xy") in that case. I didn't want to use overlapping instances -for the Lift class in TH.Syntax, because that can lead to overlapping-instance -errors in a polymorphic situation. - -If this check fails (which isn't impossible) we get another chance; see -Note [Converting strings] in Convert.hs - -Local record selectors -~~~~~~~~~~~~~~~~~~~~~~ -Record selectors for TyCons in this module are ordinary local bindings, -which show up as ATcIds rather than AGlobals. So we need to check for -naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. - - -************************************************************************ -* * -\subsection{Record bindings} -* * -************************************************************************ --} - -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet --- These tyvars must not change across the updates -getFixedTyVars upd_fld_occs univ_tvs cons - = mkVarSet [tv1 | con <- cons - , let (u_tvs, _, eqspec, prov_theta - , req_theta, arg_tys, _) - = conLikeFullSig con - theta = eqSpecPreds eqspec - ++ prov_theta - ++ req_theta - flds = conLikeFieldLabels con - fixed_tvs = exactTyCoVarsOfTypes fixed_tys - -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyCoVarsOfTypes theta - -- Universally-quantified tyvars that - -- appear in any of the *implicit* - -- arguments to the constructor are fixed - -- See Note [Implicit type sharing] - - fixed_tys = [ty | (fl, ty) <- zip flds arg_tys - , not (flLabel fl `elem` upd_fld_occs)] - , (tv1,tv) <- univ_tvs `zip` u_tvs - , tv `elemVarSet` fixed_tvs ] - -{- -Note [Disambiguating record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the -XDuplicateRecordFields extension is used, and the renamer -encounters a record selector or update that it cannot immediately -disambiguate (because it involves fields that belong to multiple -datatypes), it will defer resolution of the ambiguity to the -typechecker. In this case, the `Ambiguous` constructor of -`AmbiguousFieldOcc` is used. - -Consider the following definitions: - - data S = MkS { foo :: Int } - data T = MkT { foo :: Int, bar :: Int } - data U = MkU { bar :: Int, baz :: Int } - -When the renamer sees `foo` as a selector or an update, it will not -know which parent datatype is in use. - -For selectors, there are two possible ways to disambiguate: - -1. Check if the pushed-in type is a function whose domain is a - datatype, for example: - - f s = (foo :: S -> Int) s - - g :: T -> Int - g = foo - - This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. - -2. Check if the selector is applied to an argument that has a type - signature, for example: - - h = foo (s :: S) - - This is checked by `tcApp`. - - -Updates are slightly more complex. The `disambiguateRecordBinds` -function tries to determine the parent datatype in three ways: - -1. Check for types that have all the fields being updated. For example: - - f x = x { foo = 3, bar = 2 } - - Here `f` must be updating `T` because neither `S` nor `U` have - both fields. This may also discover that no possible type exists. - For example the following will be rejected: - - f' x = x { foo = 3, baz = 3 } - -2. Use the type being pushed in, if it is already a TyConApp. The - following are valid updates to `T`: - - g :: T -> T - g x = x { foo = 3 } - - g' x = x { foo = 3 } :: T - -3. Use the type signature of the record expression, if it exists and - is a TyConApp. Thus this is valid update to `T`: - - h x = (x :: T) { foo = 3 } - - -Note that we do not look up the types of variables being updated, and -no constraint-solving is performed, so for example the following will -be rejected as ambiguous: - - let bad (s :: S) = foo s - - let r :: T - r = blah - in r { foo = 3 } - - \r. (r { foo = 3 }, r :: T ) - -We could add further tests, of a more heuristic nature. For example, -rather than looking for an explicit signature, we could try to infer -the type of the argument to a selector or the record expression being -updated, in case we are lucky enough to get a TyConApp straight -away. However, it might be hard for programmers to predict whether a -particular update is sufficiently obvious for the signature to be -omitted. Moreover, this might change the behaviour of typechecker in -non-obvious ways. - -See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. --} - --- Given a RdrName that refers to multiple record fields, and the type --- of its argument, try to determine the name of the selector that is --- meant. -disambiguateSelector :: Located RdrName -> Type -> TcM Name -disambiguateSelector lr@(L _ rdr) parent_type - = do { fam_inst_envs <- tcGetFamInstEnvs - ; case tyConOf fam_inst_envs parent_type of - Nothing -> ambiguousSelector lr - Just p -> - do { xs <- lookupParents rdr - ; let parent = RecSelData p - ; case lookup parent xs of - Just gre -> do { addUsedGRE True gre - ; return (gre_name gre) } - Nothing -> failWithTc (fieldNotInType parent rdr) } } - --- This field name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a -ambiguousSelector (L _ rdr) - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; setErrCtxt [] $ addNameClashErrRn rdr gres - ; failM } - --- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] -disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType - -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -disambiguateRecordBinds record_expr record_rho rbnds res_ty - -- Are all the fields unambiguous? - = case mapM isUnambiguous rbnds of - -- If so, just skip to looking up the Ids - -- Always the case if DuplicateRecordFields is off - Just rbnds' -> mapM lookupSelector rbnds' - Nothing -> -- If not, try to identify a single parent - do { fam_inst_envs <- tcGetFamInstEnvs - -- Look up the possible parents for each field - ; rbnds_with_parents <- getUpdFieldsParents - ; let possible_parents = map (map fst . snd) rbnds_with_parents - -- Identify a single parent - ; p <- identifyParent fam_inst_envs possible_parents - -- Pick the right selector with that parent for each field - ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } - where - -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) - isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of - Unambiguous sel_name _ -> Just (x, sel_name) - Ambiguous{} -> Nothing - XAmbiguousFieldOcc{} -> Nothing - - -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn - , [(RecSelParent, GlobalRdrElt)])] - getUpdFieldsParents - = fmap (zip rbnds) $ mapM - (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc) - rbnds - - -- Given a the lists of possible parents for each field, - -- identify a single parent - identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent - identifyParent fam_inst_envs possible_parents - = case foldr1 intersect possible_parents of - -- No parents for all fields: record update is ill-typed - [] -> failWithTc (noPossibleParents rbnds) - - -- Exactly one datatype with all the fields: use that - [p] -> return p - - -- Multiple possible parents: try harder to disambiguate - -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p) - - -- Does the expression being updated have a type signature? - -- If so, try to extract a parent TyCon from it - | Just {} <- obviousSig (unLoc record_expr) - , Just tc <- tyConOf fam_inst_envs record_rho - -> return (RecSelData tc) - - -- Nothing else we can try... - _ -> failWithTc badOverloadedUpdate - - -- Make a field unambiguous by choosing the given parent. - -- Emits an error if the field cannot have that parent, - -- e.g. if the user writes - -- r { x = e } :: T - -- where T does not have field x. - pickParent :: RecSelParent - -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - pickParent p (upd, xs) - = case lookup p xs of - -- Phew! The parent is valid for this field. - -- Previously ambiguous fields must be marked as - -- used now that we know which one is meant, but - -- unambiguous ones shouldn't be recorded again - -- (giving duplicate deprecation warnings). - Just gre -> do { unless (null (tail xs)) $ do - let L loc _ = hsRecFieldLbl (unLoc upd) - setSrcSpan loc $ addUsedGRE True gre - ; lookupSelector (upd, gre_name gre) } - -- The field doesn't belong to this parent, so report - -- an error but keep going through all the fields - Nothing -> do { addErrTc (fieldNotInType p - (unLoc (hsRecUpdFieldRdr (unLoc upd)))) - ; lookupSelector (upd, gre_name (snd (head xs))) } - - -- Given a (field update, selector name) pair, look up the - -- selector to give a field update with an unambiguous Id - lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - lookupSelector (L l upd, n) - = do { i <- tcLookupId n - ; let L loc af = hsRecFieldLbl upd - lbl = rdrNameAmbiguousFieldOcc af - ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous i (L loc lbl)) } } - - --- Extract the outermost TyCon of a type, if there is one; for --- data families this is the representation tycon (because that's --- where the fields live). -tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon -tyConOf fam_inst_envs ty0 - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) - Nothing -> Nothing - where - (_, _, ty) = tcSplitSigmaTy ty0 - --- Variant of tyConOf that works for ExpTypes -tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon -tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 - --- For an ambiguous record field, find all the candidate record --- selectors (as GlobalRdrElts) and their parents. -lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (gre_name gre) - ; if isRecordSelector id - then return (recordSelectorTyCon id, gre) - else failWithTc (notSelector (gre_name gre)) } - --- A type signature on the argument of an ambiguous record selector or --- the record expression in an update must be "obvious", i.e. the --- outermost constructor ignoring parentheses. -obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig _ _ ty) = Just ty -obviousSig (HsPar _ p) = obviousSig (unLoc p) -obviousSig _ = Nothing - - -{- -Game plan for record bindings -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Find the TyCon for the bindings, from the first field label. - -2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. - -For each binding field = value - -3. Instantiate the field type (from the field label) using the type - envt from step 2. - -4 Type check the value using tcArg, passing the field type as - the expected argument type. - -This extends OK when the field types are universally quantified. --} - -tcRecordBinds - :: ConLike - -> [TcType] -- Expected type for each field - -> HsRecordBinds GhcRn - -> TcM (HsRecordBinds GhcTcId) - -tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) - = do { mb_binds <- mapM do_bind rbinds - ; return (HsRecFields (catMaybes mb_binds) dd) } - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys - - do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = f - , hsRecFieldArg = rhs })) - - = do { mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' - , hsRecFieldArg = rhs' }))) } - -tcRecordUpd - :: ConLike - -> [TcType] -- Expected type for each field - -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -> TcM [LHsRecUpdField GhcTcId] - -tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - - do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecUpdField GhcTcId)) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af - , hsRecFieldArg = rhs })) - = do { let lbl = rdrNameAmbiguousFieldOcc af - sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L loc lbl)) - ; mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> - return (Just - (L l (fld { hsRecFieldLbl - = L loc (Unambiguous - (extFieldOcc (unLoc f')) - (L loc lbl)) - , hsRecFieldArg = rhs' }))) } - -tcRecordField :: ConLike -> Assoc Name Type - -> LFieldOcc GhcRn -> LHsExpr GhcRn - -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs - | Just field_ty <- assocMaybe flds_w_tys sel_name - = addErrCtxt (fieldCtxt field_lbl) $ - do { rhs' <- tcPolyExprNC rhs field_ty - ; let field_id = mkUserLocal (nameOccName sel_name) - (nameUnique sel_name) - field_ty loc - -- Yuk: the field_id has the *unique* of the selector Id - -- (so we can find it easily) - -- but is a LocalId with the appropriate type of the RHS - -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } - | otherwise - = do { addErrTc (badFieldCon con_like field_lbl) - ; return Nothing } - where - field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec - - -checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () -checkMissingFields con_like rbinds - | null field_labels -- Not declared as a record; - -- But C{} is still valid if no strict fields - = if any isBanged field_strs then - -- Illegal if any arg is strict - addErrTc (missingStrictFields con_like []) - else do - warn <- woptM Opt_WarnMissingFields - when (warn && notNull field_strs && null field_labels) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like [])) - - | otherwise = do -- A record - unless (null missing_s_fields) - (addErrTc (missingStrictFields con_like missing_s_fields)) - - warn <- woptM Opt_WarnMissingFields - when (warn && notNull missing_ns_fields) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like missing_ns_fields)) - - where - missing_s_fields - = [ flLabel fl | (fl, str) <- field_info, - isBanged str, - not (fl `elemField` field_names_used) - ] - missing_ns_fields - = [ flLabel fl | (fl, str) <- field_info, - not (isBanged str), - not (fl `elemField` field_names_used) - ] - - field_names_used = hsRecFields rbinds - field_labels = conLikeFieldLabels con_like - - field_info = zipEqual "missingFields" - field_labels - field_strs - - field_strs = conLikeImplBangs con_like - - fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Boring and alphabetical: --} - -addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a -addExprErrCtxt expr = addErrCtxt (exprCtxt expr) - -exprCtxt :: LHsExpr GhcRn -> SDoc -exprCtxt expr - = hang (text "In the expression:") 2 (ppr expr) - -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") - -addFunResCtxt :: Bool -- There is at least one argument - -> HsExpr GhcRn -> TcType -> ExpRhoType - -> TcM a -> TcM a --- When we have a mis-match in the return type of a function --- try to give a helpful message about too many/few arguments --- --- Used for naked variables too; but with has_args = False -addFunResCtxt has_args fun fun_res_ty env_ty - = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) - -- NB: use a landmark error context, so that an empty context - -- doesn't suppress some more useful context - where - mk_msg - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; fun_res' <- zonkTcType fun_res_ty - ; env' <- case mb_env_ty of - Just env_ty -> zonkTcType env_ty - Nothing -> - do { dumping <- doptM Opt_D_dump_tc_trace - ; MASSERT( dumping ) - ; newFlexiTyVarTy liftedTypeKind } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' - -- No need to call tcSplitNestedSigmaTys here, since env_ty is - -- an ExpRhoTy, i.e., it's already deeply instantiated. - (_, _, env_tau) = tcSplitSigmaTy env' - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - n_fun = length args_fun - n_env = length args_env - info | n_fun == n_env = Outputable.empty - | n_fun > n_env - , not_fun res_env - = text "Probable cause:" <+> quotes (ppr fun) - <+> text "is applied to too few arguments" - - | has_args - , not_fun res_fun - = text "Possible cause:" <+> quotes (ppr fun) - <+> text "is applied to too many arguments" - - | otherwise - = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! - ; return info } - where - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False - -{- -Note [Splitting nested sigma types in mismatched function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When one applies a function to too few arguments, GHC tries to determine this -fact if possible so that it may give a helpful error message. It accomplishes -this by checking if the type of the applied function has more argument types -than supplied arguments. - -Previously, GHC computed the number of argument types through tcSplitSigmaTy. -This is incorrect in the face of nested foralls, however! This caused Trac -#13311, for instance: - - f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b - -If one uses `f` like so: - - do { f; putChar 'a' } - -Then tcSplitSigmaTy will decompose the type of `f` into: - - Tyvars: [a] - Context: (Monoid a) - Argument types: [] - Return type: forall b. Monoid b => Maybe a -> Maybe b - -That is, it will conclude that there are *no* argument types, and since `f` -was given no arguments, it won't print a helpful error message. On the other -hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: - - Tyvars: [a, b] - Context: (Monoid a, Monoid b) - Argument types: [Maybe a] - Return type: Maybe b - -So now GHC recognizes that `f` has one more argument type than it was actually -provided. --} - -badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc -badFieldTypes prs - = hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - -badFieldsUpd - :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -- Field names that don't belong to a single datacon - -> [ConLike] -- Data cons of the type which the first field name belongs to - -> SDoc -badFieldsUpd rbinds data_cons - = hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) - -- See Note [Finding the conflicting fields] - where - -- A (preferably small) set of fields such that no constructor contains - -- all of them. See Note [Finding the conflicting fields] - conflictingFields = case nonMembers of - -- nonMember belongs to a different type. - (nonMember, _) : _ -> [aMember, nonMember] - [] -> let - -- All of rbinds belong to one type. In this case, repeatedly add - -- a field to the set until no constructor contains the set. - - -- Each field, together with a list indicating which constructors - -- have all the fields so far. - growingSets :: [(FieldLabelString, [Bool])] - growingSets = scanl1 combine membership - combine (_, setMem) (field, fldMem) - = (field, zipWith (&&) setMem fldMem) - in - -- Fields that don't change the membership status of the set - -- are redundant and can be dropped. - map (fst . head) $ groupBy ((==) `on` snd) growingSets - - aMember = ASSERT( not (null members) ) fst (head members) - (members, nonMembers) = partition (or . snd) membership - - -- For each field, which constructors contain the field? - membership :: [(FieldLabelString, [Bool])] - membership = sortMembership $ - map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ - map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds - - fieldLabelSets :: [Set.Set FieldLabelString] - fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons - - -- Sort in order of increasing number of True, so that a smaller - -- conflicting set can be found. - sortMembership = - map snd . - sortBy (compare `on` fst) . - map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) - - countTrue = count id - -{- -Note [Finding the conflicting fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data A = A {a0, a1 :: Int} - | B {b0, b1 :: Int} -and we see a record update - x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } -Then we'd like to find the smallest subset of fields that no -constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. -We don't really want to report that no constructor has all of -{a0,a1,b0,b1}, because when there are hundreds of fields it's -hard to see what was really wrong. - -We may need more than two fields, though; eg - data T = A { x,y :: Int, v::Int } - | B { y,z :: Int, v::Int } - | C { z,x :: Int, v::Int } -with update - r { x=e1, y=e2, z=e3 }, we - -Finding the smallest subset is hard, so the code here makes -a decent stab, no more. See #7989. --} - -naughtyRecordSel :: RdrName -> SDoc -naughtyRecordSel sel_id - = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> - text "as a function due to escaped type variables" $$ - text "Probable fix: use pattern-matching syntax instead" - -notSelector :: Name -> SDoc -notSelector field - = hsep [quotes (ppr field), text "is not a record selector"] - -mixedSelectors :: [Id] -> [Id] -> SDoc -mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = ptext - (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ - text "Record selectors defined by" - <+> quotes (ppr (tyConName rep_dc)) - <> text ":" - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr (patSynName rep_ps)) - <> text ":" - <+> pprWithCommas ppr pat_syn_sels - where - RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id - RecSelData rep_dc = recordSelectorTyCon dc_rep_id -mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists" - - -missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc -missingStrictFields con fields - = header <> rest - where - rest | null fields = Outputable.empty -- Happens for non-record constructors - -- with strict fields - | otherwise = colon <+> pprWithCommas ppr fields - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" - -missingFields :: ConLike -> [FieldLabelString] -> SDoc -missingFields con fields - = header <> rest - where - rest | null fields = Outputable.empty - | otherwise = colon <+> pprWithCommas ppr fields - header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" - --- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) - -noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc -noPossibleParents rbinds - = hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where - fields = map (hsRecFieldLbl . unLoc) rbinds - -badOverloadedUpdate :: SDoc -badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" - -fieldNotInType :: RecSelParent -> RdrName -> SDoc -fieldNotInType p rdr - = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr - -{- -************************************************************************ -* * -\subsection{Static Pointers} -* * -************************************************************************ --} - --- | A data type to describe why a variable is not closed. -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - --- | Checks if the given name is closed and emits an error if not. --- --- See Note [Not-closed error messages]. -checkClosedInStaticForm :: Name -> TcM () -checkClosedInStaticForm name = do - type_env <- getLclTypeEnv - case checkClosed type_env name of - Nothing -> return () - Just reason -> addErrTc $ explain name reason - where - -- See Note [Checking closedness]. - checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason - checkClosed type_env n = checkLoop type_env (unitNameSet n) n - - checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason - checkLoop type_env visited n = do - -- The @visited@ set is an accumulating parameter that contains the set of - -- visited nodes, so we avoid repeating cycles in the traversal. - case lookupNameEnv type_env n of - Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of - ClosedLet -> Nothing - NotLetBound -> Just NotLetBoundReason - NonClosedLet fvs type_closed -> listToMaybe $ - -- Look for a non-closed variable in fvs - [ NotClosed n' reason - | n' <- nameSetElemsStable fvs - , not (elemNameSet n' visited) - , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] - ] ++ - if type_closed then - [] - else - -- We consider non-let-bound variables easier to figure out than - -- non-closed types, so we report non-closed types to the user - -- only if we cannot spot the former. - [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] - -- The binding is closed. - _ -> Nothing - - -- Converts a reason into a human-readable sentence. - -- - -- @explain name reason@ starts with - -- - -- " is used in a static form but it is not closed because it" - -- - -- and then follows a list of causes. For each id in the path, the text - -- - -- "uses which" - -- - -- is appended, yielding something like - -- - -- "uses which uses which uses which" - -- - -- until the end of the path is reached, which is reported as either - -- - -- "is not let-bound" - -- - -- when the final node is not let-bound, or - -- - -- "has a non-closed type because it contains the type variables: - -- v1, v2, v3" - -- - -- when the final node has a non-closed type. - -- - explain :: Name -> NotClosedReason -> SDoc - explain name reason = - quotes (ppr name) <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ - sep (causes reason) - - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 - --- Note [Not-closed error messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When variables in a static form are not closed, we go through the trouble --- of explaining why they aren't. --- --- Thus, the following program --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > f x = static g --- > where --- > g = h --- > h = x --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which uses 'x' which is not let-bound. --- --- And a program like --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > import Data.Typeable --- > import GHC.StaticPtr --- > --- > f :: Typeable a => a -> StaticPtr TypeRep --- > f x = const (static (g undefined)) (h x) --- > where --- > g = h --- > h = typeOf --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which has a non-closed type because it contains the --- type variables: 'a' --- - --- Note [Checking closedness] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- @checkClosed@ checks if a binding is closed and returns a reason if it is --- not. --- --- The bindings define a graph where the nodes are ids, and there is an edge --- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free --- variables. --- --- When @n@ is not closed, it has to exist in the graph some node reachable --- from @n@ that it is not a let-bound variable or that it has a non-closed --- type. Thus, the "reason" is a path from @n@ to this offending node. --- --- When @n@ is not closed, we traverse the graph reachable from @n@ to build --- the reason. --- diff --git a/typecheck/TcExpr.hs-boot b/typecheck/TcExpr.hs-boot deleted file mode 100644 --- a/typecheck/TcExpr.hs-boot +++ /dev/null @@ -1,42 +0,0 @@ -module TcExpr where -import Name -import GHC.Hs ( HsExpr, LHsExpr, SyntaxExpr ) -import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) -import TcRnTypes( TcM ) -import TcOrigin ( CtOrigin ) -import GHC.Hs.Extension ( GhcRn, GhcTcId ) - -tcPolyExpr :: - LHsExpr GhcRn - -> TcSigmaType - -> TcM (LHsExpr GhcTcId) - -tcMonoExpr, tcMonoExprNC :: - LHsExpr GhcRn - -> ExpRhoType - -> TcM (LHsExpr GhcTcId) - -tcInferSigma :: - LHsExpr GhcRn - -> TcM (LHsExpr GhcTcId, TcSigmaType) - -tcInferRho, tcInferRhoNC :: - LHsExpr GhcRn - -> TcM (LHsExpr GhcTcId, TcRhoType) - -tcSyntaxOp :: CtOrigin - -> SyntaxExpr GhcRn - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr GhcTcId) - -tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr GhcRn - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr GhcTcId) - - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) diff --git a/typecheck/TcFlatten.hs b/typecheck/TcFlatten.hs deleted file mode 100644 --- a/typecheck/TcFlatten.hs +++ /dev/null @@ -1,1926 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} - -module TcFlatten( - FlattenMode(..), - flatten, flattenKind, flattenArgsNom, - rewriteTyVar, - - unflattenWanteds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -import TyCoPpr ( pprTyVar ) -import Constraint -import Predicate -import TcType -import Type -import TcEvidence -import TyCon -import TyCoRep -- performs delicate algorithm on types -import Coercion -import Var -import VarSet -import VarEnv -import Outputable -import TcSMonad as TcS -import BasicTypes( SwapFlag(..) ) - -import Util -import Bag -import Control.Monad -import MonadUtils ( zipWith3M ) -import Data.Foldable ( foldrM ) - -import Control.Arrow ( first ) - -{- -Note [The flattening story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A CFunEqCan is either of form - [G] : F xis ~ fsk -- fsk is a FlatSkolTv - [W] x : F xis ~ fmv -- fmv is a FlatMetaTv - where - x is the witness variable - xis are function-free - fsk/fmv is a flatten skolem; - it is always untouchable (level 0) - -* CFunEqCans can have any flavour: [G], [W], [WD] or [D] - -* KEY INSIGHTS: - - - A given flatten-skolem, fsk, is known a-priori to be equal to - F xis (the LHS), with evidence. The fsk is still a - unification variable, but it is "owned" by its CFunEqCan, and - is filled in (unflattened) only by unflattenGivens. - - - A unification flatten-skolem, fmv, stands for the as-yet-unknown - type to which (F xis) will eventually reduce. It is filled in - - - - All fsk/fmv variables are "untouchable". To make it simple to test, - we simply give them TcLevel=0. This means that in a CTyVarEq, say, - fmv ~ Int - we NEVER unify fmv. - - - A unification flatten-skolem, fmv, ONLY gets unified when either - a) The CFunEqCan takes a step, using an axiom - b) By unflattenWanteds - They are never unified in any other form of equality. - For example [W] ffmv ~ Int is stuck; it does not unify with fmv. - -* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. - That would destroy the invariant about the shape of a CFunEqCan, - and it would risk wanted/wanted interactions. The only way we - learn information about fsk is when the CFunEqCan takes a step. - - However we *do* substitute in the LHS of a CFunEqCan (else it - would never get to fire!) - -* Unflattening: - - We unflatten Givens when leaving their scope (see unflattenGivens) - - We unflatten Wanteds at the end of each attempt to simplify the - wanteds; see unflattenWanteds, called from solveSimpleWanteds. - -* Ownership of fsk/fmv. Each canonical [G], [W], or [WD] - CFunEqCan x : F xis ~ fsk/fmv - "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv. - Why? We make a fresh fsk/fmv when the constraint is born; - and we never rewrite the RHS of a CFunEqCan. - - In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W], - but does not "own" it. If we reduce a [D] F Int ~ fmv, where - say type instance F Int = ty, then we don't discharge fmv := ty. - Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq, - and dischargeFmv) - -* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 - then xis1 /= xis2 - i.e. at most one CFunEqCan with a particular LHS - -* Function applications can occur in the RHS of a CTyEqCan. No reason - not allow this, and it reduces the amount of flattening that must occur. - -* Flattening a type (F xis): - - If we are flattening in a Wanted/Derived constraint - then create new [W] x : F xis ~ fmv - else create new [G] x : F xis ~ fsk - with fresh evidence variable x and flatten-skolem fsk/fmv - - - Add it to the work list - - - Replace (F xis) with fsk/fmv in the type you are flattening - - - You can also add the CFunEqCan to the "flat cache", which - simply keeps track of all the function applications you - have flattened. - - - If (F xis) is in the cache already, just - use its fsk/fmv and evidence x, and emit nothing. - - - No need to substitute in the flat-cache. It's not the end - of the world if we start with, say (F alpha ~ fmv1) and - (F Int ~ fmv2) and then find alpha := Int. Athat will - simply give rise to fmv1 := fmv2 via [Interacting rule] below - -* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv - - Flatten xis (to substitute any tyvars; there are already no functions) - cos :: xis ~ flat_xis - - New wanted x2 :: F flat_xis ~ fsk/fmv - - Add new wanted to flat cache - - Discharge x = F cos ; x2 - -* [Interacting rule] - (inert) [W] x1 : F tys ~ fmv1 - (work item) [W] x2 : F tys ~ fmv2 - Just solve one from the other: - x2 := x1 - fmv2 := fmv1 - This just unites the two fsks into one. - Always solve given from wanted if poss. - -* For top-level reductions, see Note [Top-level reductions for type functions] - in TcInteract - - -Why given-fsks, alone, doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. - - [W] w : alpha ~ [F alpha Int] - ----> flatten - w = ...w'... - [W] w' : alpha ~ [fsk] - [G] : F alpha Int ~ fsk - ---> unify (no occurs check) - alpha := [fsk] - -But since fsk = F alpha Int, this is really an occurs check error. If -that is all we know about alpha, we will succeed in constraint -solving, producing a program with an infinite type. - -Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk) -using axiom, zonking would not see it, so (x::alpha) sitting in the -tree will get zonked to an infinite type. (Zonking always only does -refl stuff.) - -Why flatten-meta-vars, alone doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at Simple13, with unification-fmvs only - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fmv] - [W] x : F a ~ fmv - ---> subst a in x - g' = g;[x] - x = F g' ; x2 - [W] x2 : F [fmv] ~ fmv - -And now we have an evidence cycle between g' and x! - -If we used a given instead (ie current story) - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fsk] - [G] : F a ~ fsk - ----> Substitute for a - [G] g' : a ~ [fsk] - [G] F (sym g'); : F [fsk] ~ fsk - - -Why is it right to treat fmv's differently to ordinary unification vars? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - f :: forall a. a -> a -> Bool - g :: F Int -> F Int -> Bool - -Consider - f (x:Int) (y:Bool) -This gives alpha~Int, alpha~Bool. There is an inconsistency, -but really only one error. SherLoc may tell you which location -is most likely, based on other occurrences of alpha. - -Consider - g (x:Int) (y:Bool) -Here we get (F Int ~ Int, F Int ~ Bool), which flattens to - (fmv ~ Int, fmv ~ Bool) -But there are really TWO separate errors. - - ** We must not complain about Int~Bool. ** - -Moreover these two errors could arise in entirely unrelated parts of -the code. (In the alpha case, there must be *some* connection (eg -v:alpha in common envt).) - -Note [Unflattening can force the solver to iterate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at #10340: - type family Any :: * -- No instances - get :: MonadState s m => m s - instance MonadState s (State s) where ... - - foo :: State Any Any - foo = get - -For 'foo' we instantiate 'get' at types mm ss - [WD] MonadState ss mm, [WD] mm ss ~ State Any Any -Flatten, and decompose - [WD] MonadState ss mm, [WD] Any ~ fmv - [WD] mm ~ State fmv, [WD] fmv ~ ss -Unify mm := State fmv: - [WD] MonadState ss (State fmv) - [WD] Any ~ fmv, [WD] fmv ~ ss -Now we are stuck; the instance does not match!! So unflatten: - fmv := Any - ss := Any (*) - [WD] MonadState Any (State Any) - -The unification (*) represents progress, so we must do a second -round of solving; this time it succeeds. This is done by the 'go' -loop in solveSimpleWanteds. - -This story does not feel right but it's the best I can do; and the -iteration only happens in pretty obscure circumstances. - - -************************************************************************ -* * -* Examples - Here is a long series of examples I had to work through -* * -************************************************************************ - -Simple20 -~~~~~~~~ -axiom F [a] = [F a] - - [G] F [a] ~ a ---> - [G] fsk ~ a - [G] [F a] ~ fsk (nc) ---> - [G] F a ~ fsk2 - [G] fsk ~ [fsk2] - [G] fsk ~ a ---> - [G] F a ~ fsk2 - [G] a ~ [fsk2] - [G] fsk ~ a - ----------------------------------------- -indexed-types/should_compile/T44984 - - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha - -flatten -~~~~~~~ - fmv0 := F Bool - fmv1 := H (F Bool) - fmv2 := H alpha - alpha := F Bool -plus - fmv1 ~ fmv2 - -But these two are equal under the above assumptions. -Solve by Refl. - - ---- under plan B, namely solve fmv1:=fmv2 eagerly --- - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 fmv2 := fmv1 - - fmv0 ~ alpha - -flatten - fmv0 := F Bool - fmv1 := H fmv0 = H (F Bool) - retain H alpha ~ fmv2 - because fmv2 has been filled - alpha := F Bool - - ----------------------------- -indexed-types/should_failt/T4179 - -after solving - [W] fmv_1 ~ fmv_2 - [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) - [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) - ----------------------------------------- -indexed-types/should_fail/T7729a - -a) [W] BasePrimMonad (Rand m) ~ m1 -b) [W] tt m1 ~ BasePrimMonad (Rand m) - ----> process (b) first - BasePrimMonad (Ramd m) ~ fmv_atH - fmv_atH ~ tt m1 - ----> now process (a) - m1 ~ s_atH ~ tt m1 -- An obscure occurs check - - ----------------------------------------- -typecheck/TcTypeNatSimple - -Original constraint - [W] x + y ~ x + alpha (non-canonical) -==> - [W] x + y ~ fmv1 (CFunEqCan) - [W] x + alpha ~ fmv2 (CFuneqCan) - [W] fmv1 ~ fmv2 (CTyEqCan) - -(sigh) - ----------------------------------------- -indexed-types/should_fail/GADTwrong1 - - [G] Const a ~ () -==> flatten - [G] fsk ~ () - work item: Const a ~ fsk -==> fire top rule - [G] fsk ~ () - work item fsk ~ () - -Surely the work item should rewrite to () ~ ()? Well, maybe not; -it'a very special case. More generally, our givens look like -F a ~ Int, where (F a) is not reducible. - - ----------------------------------------- -indexed_types/should_fail/T8227: - -Why using a different can-rewrite rule in CFunEqCan heads -does not work. - -Assuming NOT rewriting wanteds with wanteds - - Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk - [W] fmv_aBk ~ fsk_aBh - - [G] Scalar fsk_aBg ~ fsk_aBh - [G] V a ~ f_aBg - - Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk - fmv_aBi, fmv_aBk are flatten unification variables - - Work item: [W] V fsk_aBh ~ fmv_aBi - -Note that the inert wanteds are cyclic, because we do not rewrite -wanteds with wanteds. - - -Then we go into a loop when normalise the work-item, because we -use rewriteOrSame on the argument of V. - -Conclusion: Don't make canRewrite context specific; instead use -[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. - - ----------------------------------------- - -Here is a somewhat similar case: - - type family G a :: * - - blah :: (G a ~ Bool, Eq (G a)) => a -> a - blah = error "urk" - - foo x = blah x - -For foo we get - [W] Eq (G a), G a ~ Bool -Flattening - [W] G a ~ fmv, Eq fmv, fmv ~ Bool -We can't simplify away the Eq Bool unless we substitute for fmv. -Maybe that doesn't matter: we would still be left with unsolved -G a ~ Bool. - --------------------------- -#9318 has a very simple program leading to - - [W] F Int ~ Int - [W] F Int ~ Bool - -We don't want to get "Error Int~Bool". But if fmv's can rewrite -wanteds, we will - - [W] fmv ~ Int - [W] fmv ~ Bool ----> - [W] Int ~ Bool - - -************************************************************************ -* * -* FlattenEnv & FlatM -* The flattening environment & monad -* * -************************************************************************ - --} - -type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list] - -data FlattenEnv - = FE { fe_mode :: !FlattenMode - , fe_loc :: CtLoc -- See Note [Flattener CtLoc] - -- unbanged because it's bogus in rewriteTyVar - , fe_flavour :: !CtFlavour - , fe_eq_rel :: !EqRel -- See Note [Flattener EqRels] - , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list] - -data FlattenMode -- Postcondition for all three: inert wrt the type substitution - = FM_FlattenAll -- Postcondition: function-free - | FM_SubstOnly -- See Note [Flattening under a forall] - --- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] --- -- Postcondition: --- -- * tyvar is only mentioned in result under a rigid path --- -- e.g. [a] is ok, but F a won't happen --- -- * If flat_top is True, top level is not a function application --- -- (but under type constructors is ok e.g. [F a]) - -instance Outputable FlattenMode where - ppr FM_FlattenAll = text "FM_FlattenAll" - ppr FM_SubstOnly = text "FM_SubstOnly" - -eqFlattenMode :: FlattenMode -> FlattenMode -> Bool -eqFlattenMode FM_FlattenAll FM_FlattenAll = True -eqFlattenMode FM_SubstOnly FM_SubstOnly = True --- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 -eqFlattenMode _ _ = False - --- | The 'FlatM' monad is a wrapper around 'TcS' with the following --- extra capabilities: (1) it offers access to a 'FlattenEnv'; --- and (2) it maintains the flattening worklist. --- See Note [The flattening work list]. -newtype FlatM a - = FlatM { runFlatM :: FlattenEnv -> TcS a } - deriving (Functor) - -instance Monad FlatM where - m >>= k = FlatM $ \env -> - do { a <- runFlatM m env - ; runFlatM (k a) env } - -instance Applicative FlatM where - pure x = FlatM $ const (pure x) - (<*>) = ap - -liftTcS :: TcS a -> FlatM a -liftTcS thing_inside - = FlatM $ const thing_inside - -emitFlatWork :: Ct -> FlatM () --- See Note [The flattening work list] -emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :) - --- convenient wrapper when you have a CtEvidence describing --- the flattening operation -runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a -runFlattenCtEv mode ev - = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) - --- Run thing_inside (which does flattening), and put all --- the work it generates onto the main work list --- See Note [The flattening work list] -runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a -runFlatten mode loc flav eq_rel thing_inside - = do { flat_ref <- newTcRef [] - ; let fmode = FE { fe_mode = mode - , fe_loc = bumpCtLocDepth loc - -- See Note [Flatten when discharging CFunEqCan] - , fe_flavour = flav - , fe_eq_rel = eq_rel - , fe_work = flat_ref } - ; res <- runFlatM thing_inside fmode - ; new_flats <- readTcRef flat_ref - ; updWorkListTcS (add_flats new_flats) - ; return res } - where - add_flats new_flats wl - = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } - - add_funeqs [] wl = wl - add_funeqs (f:fs) wl = add_funeqs fs (f:wl) - -- add_funeqs fs ws = reverse fs ++ ws - -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] - -- = [f3,f2,f1,w1,w2,w3,w4] - -traceFlat :: String -> SDoc -> FlatM () -traceFlat herald doc = liftTcS $ traceTcS herald doc - -getFlatEnvField :: (FlattenEnv -> a) -> FlatM a -getFlatEnvField accessor - = FlatM $ \env -> return (accessor env) - -getEqRel :: FlatM EqRel -getEqRel = getFlatEnvField fe_eq_rel - -getRole :: FlatM Role -getRole = eqRelRole <$> getEqRel - -getFlavour :: FlatM CtFlavour -getFlavour = getFlatEnvField fe_flavour - -getFlavourRole :: FlatM CtFlavourRole -getFlavourRole - = do { flavour <- getFlavour - ; eq_rel <- getEqRel - ; return (flavour, eq_rel) } - -getMode :: FlatM FlattenMode -getMode = getFlatEnvField fe_mode - -getLoc :: FlatM CtLoc -getLoc = getFlatEnvField fe_loc - -checkStackDepth :: Type -> FlatM () -checkStackDepth ty - = do { loc <- getLoc - ; liftTcS $ checkReductionDepth loc ty } - --- | Change the 'EqRel' in a 'FlatM'. -setEqRel :: EqRel -> FlatM a -> FlatM a -setEqRel new_eq_rel thing_inside - = FlatM $ \env -> - if new_eq_rel == fe_eq_rel env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel }) - --- | Change the 'FlattenMode' in a 'FlattenEnv'. -setMode :: FlattenMode -> FlatM a -> FlatM a -setMode new_mode thing_inside - = FlatM $ \env -> - if new_mode `eqFlattenMode` fe_mode env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_mode = new_mode }) - --- | Make sure that flattening actually produces a coercion (in other --- words, make sure our flavour is not Derived) --- Note [No derived kind equalities] -noBogusCoercions :: FlatM a -> FlatM a -noBogusCoercions thing_inside - = FlatM $ \env -> - -- No new thunk is made if the flavour hasn't changed (note the bang). - let !env' = case fe_flavour env of - Derived -> env { fe_flavour = Wanted WDeriv } - _ -> env - in - runFlatM thing_inside env' - -bumpDepth :: FlatM a -> FlatM a -bumpDepth (FlatM thing_inside) - = FlatM $ \env -> do - -- bumpDepth can be called a lot during flattening so we force the - -- new env to avoid accumulating thunks. - { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } - ; thing_inside env' } - -{- -Note [The flattening work list] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "flattening work list", held in the fe_work field of FlattenEnv, -is a list of CFunEqCans generated during flattening. The key idea -is this. Consider flattening (Eq (F (G Int) (H Bool)): - * The flattener recursively calls itself on sub-terms before building - the main term, so it will encounter the terms in order - G Int - H Bool - F (G Int) (H Bool) - flattening to sub-goals - w1: G Int ~ fuv0 - w2: H Bool ~ fuv1 - w3: F fuv0 fuv1 ~ fuv2 - - * Processing w3 first is BAD, because we can't reduce i t,so it'll - get put into the inert set, and later kicked out when w1, w2 are - solved. In #9872 this led to inert sets containing hundreds - of suspended calls. - - * So we want to process w1, w2 first. - - * So you might think that we should just use a FIFO deque for the work-list, - so that putting adding goals in order w1,w2,w3 would mean we processed - w1 first. - - * BUT suppose we have 'type instance G Int = H Char'. Then processing - w1 leads to a new goal - w4: H Char ~ fuv0 - We do NOT want to put that on the far end of a deque! Instead we want - to put it at the *front* of the work-list so that we continue to work - on it. - -So the work-list structure is this: - - * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on - top (extendWorkListFunEq), and take new work from the top - (selectWorkItem). - - * When flattening, emitFlatWork pushes new flattening goals (like - w1,w2,w3) onto the flattening work list, fe_work, another - push-down stack. - - * When we finish flattening, we *reverse* the fe_work stack - onto the wl_funeqs stack (which brings w1 to the top). - -The function runFlatten initialises the fe_work stack, and reverses -it onto wl_fun_eqs at the end. - -Note [Flattener EqRels] -~~~~~~~~~~~~~~~~~~~~~~~ -When flattening, we need to know which equality relation -- nominal -or representation -- we should be respecting. The only difference is -that we rewrite variables by representational equalities when fe_eq_rel -is ReprEq, and that we unwrap newtypes when flattening w.r.t. -representational equality. - -Note [Flattener CtLoc] -~~~~~~~~~~~~~~~~~~~~~~ -The flattener does eager type-family reduction. -Type families might loop, and we -don't want GHC to do so. A natural solution is to have a bounded depth -to these processes. A central difficulty is that such a solution isn't -quite compositional. For example, say it takes F Int 10 steps to get to Bool. -How many steps does it take to get from F Int -> F Int to Bool -> Bool? -10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to -know and hard to track. So, we punt, essentially. We store a CtLoc in -the FlattenEnv and just update the environment when recurring. In the -TyConApp case, where there may be multiple type families to flatten, -we just copy the current CtLoc into each branch. If any branch hits the -stack limit, then the whole thing fails. - -A consequence of this is that setting the stack limits appropriately -will be essentially impossible. So, the official recommendation if a -stack limit is hit is to disable the check entirely. Otherwise, there -will be baffling, unpredictable errors. - -Note [Lazy flattening] -~~~~~~~~~~~~~~~~~~~~~~ -The idea of FM_Avoid mode is to flatten less aggressively. If we have - a ~ [F Int] -there seems to be no great merit in lifting out (F Int). But if it was - a ~ [G a Int] -then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, -which gets rid of the occurs-check problem. (For the flat_top Bool, see -comments above and at call sites.) - -HOWEVER, the lazy flattening actually seems to make type inference go -*slower*, not faster. perf/compiler/T3064 is a case in point; it gets -*dramatically* worse with FM_Avoid. I think it may be because -floating the types out means we normalise them, and that often makes -them smaller and perhaps allows more re-use of previously solved -goals. But to be honest I'm not absolutely certain, so I am leaving -FM_Avoid in the code base. What I'm removing is the unique place -where it is *used*, namely in TcCanonical.canEqTyVar. - -See also Note [Conservative unification check] in TcUnify, which gives -other examples where lazy flattening caused problems. - -Bottom line: FM_Avoid is unused for now (Nov 14). -Note: T5321Fun got faster when I disabled FM_Avoid - T5837 did too, but it's pathalogical anyway - -Note [Phantoms in the flattener] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - -data Proxy p = Proxy - -and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` -is really irrelevant -- it will be ignored when solving for representational -equality later on. So, we omit flattening `ty` entirely. This may -violate the expectation of "xi"s for a bit, but the canonicaliser will -soon throw out the phantoms when decomposing a TyConApp. (Or, the -canonicaliser will emit an insoluble, in which case the unflattened version -yields a better error message anyway.) - -Note [No derived kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A kind-level coercion can appear in types, via mkCastTy. So, whenever -we are generating a coercion in a dependent context (in other words, -in a kind) we need to make sure that our flavour is never Derived -(as Derived constraints have no evidence). The noBogusCoercions function -changes the flavour from Derived just for this purpose. - --} - -{- ********************************************************************* -* * -* Externally callable flattening functions * -* * -* They are all wrapped in runFlatten, so their * -* flattening work gets put into the work list * -* * -********************************************************************* - -Note [rewriteTyVar] -~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an injective function F and - inert_funeqs: F t1 ~ fsk1 - F t2 ~ fsk2 - inert_eqs: fsk1 ~ [a] - a ~ Int - fsk2 ~ [Int] - -We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the -[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans -when trying to find derived equalities arising from injectivity. --} - --- | See Note [Flattening]. --- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty --- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll', --- then 'xi' is almost function-free (Note [Almost function-free] --- in TcRnTypes). -flatten :: FlattenMode -> CtEvidence -> TcType - -> TcS (Xi, TcCoercion) -flatten mode ev ty - = do { traceTcS "flatten {" (ppr mode <+> ppr ty) - ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty) - ; traceTcS "flatten }" (ppr ty') - ; return (ty', co) } - --- Apply the inert set as an *inert generalised substitution* to --- a variable, zonking along the way. --- See Note [inert_eqs: the inert equalities] in TcSMonad. --- Equivalently, this flattens the variable with respect to NomEq --- in a Derived constraint. (Why Derived? Because Derived allows the --- most about of rewriting.) Returns no coercion, because we're --- using Derived constraints. --- See Note [rewriteTyVar] -rewriteTyVar :: TcTyVar -> TcS TcType -rewriteTyVar tv - = do { traceTcS "rewriteTyVar {" (ppr tv) - ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $ - flattenTyVar tv - ; traceTcS "rewriteTyVar }" (ppr ty) - ; return ty } - where - fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv) - --- specialized to flattening kinds: never Derived, always Nominal --- See Note [No derived kind equalities] --- See Note [Flattening] -flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN) -flattenKind loc flav ty - = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty) - ; let flav' = case flav of - Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not - _ -> flav - ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty) - ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic - ; return (ty', co) } - --- See Note [Flattening] -flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN) --- Externally-callable, hence runFlatten --- Flatten a vector of types all at once; in fact they are --- always the arguments of type family or class, so --- ctEvFlavour ev = Nominal --- and we want to flatten all at nominal role --- The kind passed in is the kind of the type family or class, call it T --- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys)) --- --- For Derived constraints the returned coercion may be undefined --- because flattening may use a Derived equality ([D] a ~ ty) -flattenArgsNom ev tc tys - = do { traceTcS "flatten_args {" (vcat (map ppr tys)) - ; (tys', cos, kind_co) - <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys) - ; traceTcS "flatten }" (vcat (map ppr tys')) - ; return (tys', cos, kind_co) } - - -{- ********************************************************************* -* * -* The main flattening functions -* * -********************************************************************* -} - -{- Note [Flattening] -~~~~~~~~~~~~~~~~~~~~ - flatten ty ==> (xi, co) - where - xi has no type functions, unless they appear under ForAlls - has no skolems that are mapped in the inert set - has no filled-in metavariables - co :: xi ~ ty - -Key invariants: - (F0) co :: xi ~ zonk(ty) - (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) - -Note that it is flatten's job to flatten *every type function it sees*. -flatten is only called on *arguments* to type functions, by canEqGiven. - -Flattening also: - * zonks, removing any metavariables, and - * applies the substitution embodied in the inert set - -The result of flattening is *almost function-free*. See -Note [Almost function-free] in TcRnTypes. - -Because flattening zonks and the returned coercion ("co" above) is also -zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, -we can rely on this fact: - - (F0) co :: xi ~ zonk(ty) - -Note that the left-hand type of co is *always* precisely xi. The right-hand -type may or may not be ty, however: if ty has unzonked filled-in metavariables, -then the right-hand type of co will be the zonked version of ty. -It is for this reason that we -occasionally have to explicitly zonk, when (co :: xi ~ ty) is important -even before we zonk the whole program. For example, see the FTRNotFollowed -case in flattenTyVar. - -Why have these invariants on flattening? Because we sometimes use tcTypeKind -during canonicalisation, and we want this kind to be zonked (e.g., see -TcCanonical.canEqTyVar). - -Flattening is always homogeneous. That is, the kind of the result of flattening is -always the same as the kind of the input, modulo zonking. More formally: - - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) - -This invariant means that the kind of a flattened type might not itself be flat. - -Recall that in comments we use alpha[flat = ty] to represent a -flattening skolem variable alpha which has been generated to stand in -for ty. - ------ Example of flattening a constraint: ------ - flatten (List (F (G Int))) ==> (xi, cc) - where - xi = List alpha - cc = { G Int ~ beta[flat = G Int], - F beta ~ alpha[flat = F beta] } -Here - * alpha and beta are 'flattening skolem variables'. - * All the constraints in cc are 'given', and all their coercion terms - are the identity. - -NB: Flattening Skolems only occur in canonical constraints, which -are never zonked, so we don't need to worry about zonking doing -accidental unflattening. - -Note that we prefer to leave type synonyms unexpanded when possible, -so when the flattener encounters one, it first asks whether its -transitive expansion contains any type function applications. If so, -it expands the synonym and proceeds; if not, it simply returns the -unexpanded synonym. - -Note [flatten_args performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In programs with lots of type-level evaluation, flatten_args becomes -part of a tight loop. For example, see test perf/compiler/T9872a, which -calls flatten_args a whopping 7,106,808 times. It is thus important -that flatten_args be efficient. - -Performance testing showed that the current implementation is indeed -efficient. It's critically important that zipWithAndUnzipM be -specialized to TcS, and it's also quite helpful to actually `inline` -it. On test T9872a, here are the allocation stats (Dec 16, 2014): - - * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap - * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap - * Specialized, inlined: 6,281,539,792 bytes allocated in the heap - -To improve performance even further, flatten_args_nom is split off -from flatten_args, as nominal equality is the common case. This would -be natural to write using mapAndUnzipM, but even inlined, that function -is not as performant as a hand-written loop. - - * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap - * hand-written recursion: 5,848,602,848 bytes allocated in the heap - -If you make any change here, pay close attention to the T9872{a,b,c} tests -and T5321Fun. - -If we need to make this yet more performant, a possible way forward is to -duplicate the flattener code for the nominal case, and make that case -faster. This doesn't seem quite worth it, yet. - -Note [flatten_exact_fam_app_fully performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and #15192 for the current state. - -The explicit pattern match in homogenise_result helps with T9872a, b, c. - -Still, it increases the expected allocation of T9872d by ~2%. - -TODO: a step-by-step replay of the refactor to analyze the performance. - --} - -{-# INLINE flatten_args_tc #-} -flatten_args_tc - :: TyCon -- T - -> [Role] -- Role r - -> [Type] -- Arg types [t1,..,tn] - -> FlatM ( [Xi] -- List of flattened args [x1,..,xn] - -- 1-1 corresp with [t1,..,tn] - , [Coercion] -- List of arg coercions [co1,..,con] - -- 1-1 corresp with [t1,..,tn] - -- coi :: xi ~r ti - , CoercionN) -- Result coercion, rco - -- rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con)) -flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet - -- NB: TyCon kinds are always closed - where - (bndrs, named) - = ty_con_binders_ty_binders' (tyConBinders tc) - -- it's possible that the result kind has arrows (for, e.g., a type family) - -- so we must split it - (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc) - !all_bndrs = bndrs `chkAppend` inner_bndrs - !any_named_bndrs = named || inner_named - -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. - -{-# INLINE flatten_args #-} -flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are - -- named. - -> Kind -> TcTyCoVarSet -- function kind; kind's free vars - -> [Role] -> [Type] -- these are in 1-to-1 correspondence - -> FlatM ([Xi], [Coercion], CoercionN) --- Coercions :: Xi ~ Type, at roles given --- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys) --- That is, the third coercion relates the kind of some function (whose kind is --- passed as the first parameter) instantiated at xis to the kind of that --- function instantiated at the tys. This is useful in keeping flattening --- homoegeneous. The list of roles must be at least as long as the list of --- types. -flatten_args orig_binders - any_named_bndrs - orig_inner_ki - orig_fvs - orig_roles - orig_tys - = if any_named_bndrs - then flatten_args_slow orig_binders - orig_inner_ki - orig_fvs - orig_roles - orig_tys - else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys - -{-# INLINE flatten_args_fast #-} --- | fast path flatten_args, in which none of the binders are named and --- therefore we can avoid tracking a lifting context. --- There are many bang patterns in here. It's been observed that they --- greatly improve performance of an optimized build. --- The T9872 test cases are good witnesses of this fact. -flatten_args_fast :: [TyCoBinder] - -> Kind - -> [Role] - -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys - = fmap finish (iterate orig_tys orig_roles orig_binders) - where - - iterate :: [Type] - -> [Role] - -> [TyCoBinder] - -> FlatM ([Xi], [Coercion], [TyCoBinder]) - iterate (ty:tys) (role:roles) (_:binders) = do - (xi, co) <- go role ty - (xis, cos, binders) <- iterate tys roles binders - pure (xi : xis, co : cos, binders) - iterate [] _ binders = pure ([], [], binders) - iterate _ _ _ = pprPanic - "flatten_args wandered into deeper water than usual" (vcat []) - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872{a,c,d}. - {- - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} - - {-# INLINE go #-} - go :: Role - -> Type - -> FlatM (Xi, Coercion) - go role ty - = case role of - -- In the slow path we bind the Xi and Coercion from the recursive - -- call and then use it such - -- - -- let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder) - -- casted_xi = xi `mkCastTy` kind_co - -- casted_co = xi |> kind_co ~r xi ; co - -- - -- but this isn't necessary: - -- mkTcSymCo (Refl a b) = Refl a b, - -- mkCastTy x (Refl _ _) = x - -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co - -- - -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since - -- we've already established that they're all anonymous. - Nominal -> setEqRel NomEq $ flatten_one ty - Representational -> setEqRel ReprEq $ flatten_one ty - Phantom -> -- See Note [Phantoms in the flattener] - do { ty <- liftTcS $ zonkTcType ty - ; return (ty, mkReflCo Phantom ty) } - - - {-# INLINE finish #-} - finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN) - finish (xis, cos, binders) = (xis, cos, kind_co) - where - final_kind = mkPiTys binders orig_inner_ki - kind_co = mkNomReflCo final_kind - -{-# INLINE flatten_args_slow #-} --- | Slow path, compared to flatten_args_fast, because this one must track --- a lifting context. -flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet - -> [Role] -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_args_slow binders inner_ki fvs roles tys --- Arguments used dependently must be flattened with proper coercions, but --- we're not guaranteed to get a proper coercion when flattening with the --- "Derived" flavour. So we must call noBogusCoercions when flattening arguments --- corresponding to binders that are dependent. However, we might legitimately --- have *more* arguments than binders, in the case that the inner_ki is a variable --- that gets instantiated with a Π-type. We conservatively choose not to produce --- bogus coercions for these, too. Note that this might miss an opportunity for --- a Derived rewriting a Derived. The solution would be to generate evidence for --- Deriveds, thus avoiding this whole noBogusCoercions idea. See also --- Note [No derived kind equalities] - = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True) - roles tys - ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) } - where - {-# INLINE fl #-} - fl :: Bool -- must we ensure to produce a real coercion here? - -- see comment at top of function - -> Role -> Type -> FlatM (Xi, Coercion) - fl True r ty = noBogusCoercions $ fl1 r ty - fl False r ty = fl1 r ty - - {-# INLINE fl1 #-} - fl1 :: Role -> Type -> FlatM (Xi, Coercion) - fl1 Nominal ty - = setEqRel NomEq $ - flatten_one ty - - fl1 Representational ty - = setEqRel ReprEq $ - flatten_one ty - - fl1 Phantom ty - -- See Note [Phantoms in the flattener] - = do { ty <- liftTcS $ zonkTcType ty - ; return (ty, mkReflCo Phantom ty) } - ------------------- -flatten_one :: TcType -> FlatM (Xi, Coercion) --- Flatten a type to get rid of type function applications, returning --- the new type-function-free type, and a collection of new equality --- constraints. See Note [Flattening] for more detail. --- --- Postcondition: Coercion :: Xi ~ TcType --- The role on the result coercion matches the EqRel in the FlattenEnv - -flatten_one xi@(LitTy {}) - = do { role <- getRole - ; return (xi, mkReflCo role xi) } - -flatten_one (TyVarTy tv) - = flattenTyVar tv - -flatten_one (AppTy ty1 ty2) - = flatten_app_tys ty1 [ty2] - -flatten_one (TyConApp tc tys) - -- Expand type synonyms that mention type families - -- on the RHS; see Note [Flattening synonyms] - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { mode <- getMode - ; case mode of - FM_FlattenAll | not (isFamFreeTyCon tc) - -> flatten_one expanded_ty - _ -> flatten_ty_con_app tc tys } - - -- Otherwise, it's a type function application, and we have to - -- flatten it away as well, and generate a new given equality constraint - -- between the application and a newly generated flattening skolem variable. - | isTypeFamilyTyCon tc - = flatten_fam_app tc tys - - -- For * a normal data type application - -- * data family application - -- we just recursively flatten the arguments. - | otherwise --- FM_Avoid stuff commented out; see Note [Lazy flattening] --- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid --- FE { fe_mode = FM_Avoid tv _ } --- -> fmode { fe_mode = FM_Avoid tv False } --- _ -> fmode - = flatten_ty_con_app tc tys - -flatten_one ty@(FunTy _ ty1 ty2) - = do { (xi1,co1) <- flatten_one ty1 - ; (xi2,co2) <- flatten_one ty2 - ; role <- getRole - ; return (ty { ft_arg = xi1, ft_res = xi2 } - , mkFunCo role co1 co2) } - -flatten_one ty@(ForAllTy {}) --- TODO (RAE): This is inadequate, as it doesn't flatten the kind of --- the bound tyvar. Doing so will require carrying around a substitution --- and the usual substTyVarBndr-like silliness. Argh. - --- We allow for-alls when, but only when, no type function --- applications inside the forall involve the bound type variables. - = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty - tvs = binderVars bndrs - ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho - -- Substitute only under a forall - -- See Note [Flattening under a forall] - ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } - -flatten_one (CastTy ty g) - = do { (xi, co) <- flatten_one ty - ; (g', _) <- flatten_co g - - ; role <- getRole - ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) } - -flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co - --- | "Flatten" a coercion. Really, just zonk it so we can uphold --- (F1) of Note [Flattening] -flatten_co :: Coercion -> FlatM (Coercion, Coercion) -flatten_co co - = do { co <- liftTcS $ zonkCo co - ; env_role <- getRole - ; let co' = mkTcReflCo env_role (mkCoercionTy co) - ; return (co, co') } - --- flatten (nested) AppTys -flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion) --- commoning up nested applications allows us to look up the function's kind --- only once. Without commoning up like this, we would spend a quadratic amount --- of time looking up functions' types -flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys) -flatten_app_tys fun_ty arg_tys - = do { (fun_xi, fun_co) <- flatten_one fun_ty - ; flatten_app_ty_args fun_xi fun_co arg_tys } - --- Given a flattened function (with the coercion produced by flattening) and --- a bunch of unflattened arguments, flatten the arguments and apply. --- The coercion argument's role matches the role stored in the FlatM monad. --- --- The bang patterns used here were observed to improve performance. If you --- wish to remove them, be sure to check for regeressions in allocations. -flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion) -flatten_app_ty_args fun_xi fun_co [] - -- this will be a common case when called from flatten_fam_app, so shortcut - = return (fun_xi, fun_co) -flatten_app_ty_args fun_xi fun_co arg_tys - = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of - Just (tc, xis) -> - do { let tc_roles = tyConRolesRepresentational tc - arg_roles = dropList xis tc_roles - ; (arg_xis, arg_cos, kind_co) - <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys - - -- Here, we have fun_co :: T xi1 xi2 ~ ty - -- and we need to apply fun_co to the arg_cos. The problem is - -- that using mkAppCo is wrong because that function expects - -- its second coercion to be Nominal, and the arg_cos might - -- not be. The solution is to use transitivity: - -- T arg_cos ;; fun_co - ; eq_rel <- getEqRel - ; let app_xi = mkTyConApp tc (xis ++ arg_xis) - app_co = case eq_rel of - NomEq -> mkAppCos fun_co arg_cos - ReprEq -> mkTcTyConAppCo Representational tc - (zipWith mkReflCo tc_roles xis ++ arg_cos) - `mkTcTransCo` - mkAppCos fun_co (map mkNomReflCo arg_tys) - ; return (app_xi, app_co, kind_co) } - Nothing -> - do { (arg_xis, arg_cos, kind_co) - <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys - ; let arg_xi = mkAppTys fun_xi arg_xis - arg_co = mkAppCos fun_co arg_cos - ; return (arg_xi, arg_co, kind_co) } - - ; role <- getRole - ; return (homogenise_result xi co role kind_co) } - -flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_ty_con_app tc tys - = do { role <- getRole - ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys - ; let tyconapp_xi = mkTyConApp tc xis - tyconapp_co = mkTyConAppCo role tc cos - ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) } - --- Make the result of flattening homogeneous (Note [Flattening] (F2)) -homogenise_result :: Xi -- a flattened type - -> Coercion -- :: xi ~r original ty - -> Role -- r - -> CoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty) - -> (Xi, Coercion) -- (xi |> kind_co, (xi |> kind_co) - -- ~r original ty) -homogenise_result xi co r kind_co - -- the explicit pattern match here improves the performance of T9872a, b, c by - -- ~2% - | isGReflCo kind_co = (xi `mkCastTy` kind_co, co) - | otherwise = (xi `mkCastTy` kind_co - , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co) -{-# INLINE homogenise_result #-} - --- Flatten a vector (list of arguments). -flatten_vector :: Kind -- of the function being applied to these arguments - -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the - -- args have? - -> [Type] -- the args to flatten - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_vector ki roles tys - = do { eq_rel <- getEqRel - ; case eq_rel of - NomEq -> flatten_args bndrs - any_named_bndrs - inner_ki - fvs - (repeat Nominal) - tys - ReprEq -> flatten_args bndrs - any_named_bndrs - inner_ki - fvs - roles - tys - } - where - (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki - fvs = tyCoVarsOfType ki -{-# INLINE flatten_vector #-} - -{- -Note [Flattening synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Not expanding synonyms aggressively improves error messages, and -keeps types smaller. But we need to take care. - -Suppose - type T a = a -> a -and we want to flatten the type (T (F a)). Then we can safely flatten -the (F a) to a skolem, and return (T fsk). We don't need to expand the -synonym. This works because TcTyConAppCo can deal with synonyms -(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. - -But (#8979) for - type T a = (F a, a) where F is a type function -we must expand the synonym in (say) T Int, to expose the type function -to the flattener. - - -Note [Flattening under a forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Under a forall, we - (a) MUST apply the inert substitution - (b) MUST NOT flatten type family applications -Hence FMSubstOnly. - -For (a) consider c ~ a, a ~ T (forall b. (b, [c])) -If we don't apply the c~a substitution to the second constraint -we won't see the occurs-check error. - -For (b) consider (a ~ forall b. F a b), we don't want to flatten -to (a ~ forall b.fsk, F a b ~ fsk) -because now the 'b' has escaped its scope. We'd have to flatten to - (a ~ forall b. fsk b, forall b. F a b ~ fsk b) -and we have not begun to think about how to make that work! - -************************************************************************ -* * - Flattening a type-family application -* * -************************************************************************ --} - -flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) - -- flatten_fam_app can be over-saturated - -- flatten_exact_fam_app is exactly saturated - -- flatten_exact_fam_app_fully lifts out the application to top level - -- Postcondition: Coercion :: Xi ~ F tys -flatten_fam_app tc tys -- Can be over-saturated - = ASSERT2( tys `lengthAtLeast` tyConArity tc - , ppr tc $$ ppr (tyConArity tc) $$ ppr tys) - - do { mode <- getMode - ; case mode of - { FM_SubstOnly -> flatten_ty_con_app tc tys - ; FM_FlattenAll -> - - -- Type functions are saturated - -- The type function might be *over* saturated - -- in which case the remaining arguments should - -- be dealt with by AppTys - do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys - ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1 - -- co1 :: xi1 ~ F tys1 - - ; flatten_app_ty_args xi1 co1 tys_rest } } } - --- the [TcType] exactly saturate the TyCon --- See note [flatten_exact_fam_app_fully performance] -flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_exact_fam_app_fully tc tys - -- See Note [Reduce type family applications eagerly] - -- the following tcTypeKind should never be evaluated, as it's just used in - -- casting, and casts by refl are dropped - = do { mOut <- try_to_reduce_nocache tc tys - ; case mOut of - Just out -> pure out - Nothing -> do - { -- First, flatten the arguments - ; (xis, cos, kind_co) - <- setEqRel NomEq $ -- just do this once, instead of for - -- each arg - flatten_args_tc tc (repeat Nominal) tys - -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys) - ; eq_rel <- getEqRel - ; cur_flav <- getFlavour - ; let role = eqRelRole eq_rel - ret_co = mkTyConAppCo role tc cos - -- ret_co :: F xis ~ F tys; might be heterogeneous - - -- Now, look in the cache - ; mb_ct <- liftTcS $ lookupFlatCache tc xis - ; case mb_ct of - Just (co, rhs_ty, flav) -- co :: F xis ~ fsk - -- flav is [G] or [WD] - -- See Note [Type family equations] in TcSMonad - | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav - -> -- Usable hit in the flat-cache - do { traceFlat "flatten/flat-cache hit" $ - (ppr tc <+> ppr xis $$ ppr rhs_ty) - ; (fsk_xi, fsk_co) <- flatten_one rhs_ty - -- The fsk may already have been unified, so - -- flatten it - -- fsk_co :: fsk_xi ~ fsk - ; let xi = fsk_xi `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co - `mkTransCo` - maybeTcSubCo eq_rel (mkSymCo co) - `mkTransCo` ret_co - ; return (xi, co') - } - -- :: fsk_xi ~ F xis - - -- Try to reduce the family application right now - -- See Note [Reduce type family applications eagerly] - _ -> do { mOut <- try_to_reduce tc - xis - kind_co - (`mkTransCo` ret_co) - ; case mOut of - Just out -> pure out - Nothing -> do - { loc <- getLoc - ; (ev, co, fsk) <- liftTcS $ - newFlattenSkolem cur_flav loc tc xis - - -- The new constraint (F xis ~ fsk) is not - -- necessarily inert (e.g. the LHS may be a - -- redex) so we must put it in the work list - ; let ct = CFunEqCan { cc_ev = ev - , cc_fun = tc - , cc_tyargs = xis - , cc_fsk = fsk } - ; emitFlatWork ct - - ; traceFlat "flatten/flat-cache miss" $ - (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev) - - -- NB: fsk's kind is already flattened because - -- the xis are flattened - ; let fsk_ty = mkTyVarTy fsk - xi = fsk_ty `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co)) - `mkTransCo` ret_co - ; return (xi, co') - } - } - } - } - - where - - -- try_to_reduce and try_to_reduce_nocache (below) could be unified into - -- a more general definition, but it was observed that separating them - -- gives better performance (lower allocation numbers in T9872x). - - try_to_reduce :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> CoercionN -- kind_co :: tcTypeKind(F args) ~N - -- tcTypeKind(F orig_args) - -- where - -- orig_args is what was passed to the outer - -- function - -> ( Coercion -- :: (xi |> kind_co) ~ F args - -> Coercion ) -- what to return from outer function - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce tc tys kind_co update_co - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { traceFlat "Eager T.F. reduction success" $ - vcat [ ppr tc, ppr tys, ppr norm_ty - , ppr norm_co <+> dcolon - <+> ppr (coercionKind norm_co) - ] - ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co - ; flavour <- getFlavour - -- NB: only extend cache with nominal equalities - ; when (eq_rel == NomEq) $ - liftTcS $ - extendFlatCache tc tys ( co, xi, flavour ) - ; let role = eqRelRole eq_rel - xi' = xi `mkCastTy` kind_co - co' = update_co $ - mkTcCoherenceLeftCo role xi kind_co (mkSymCo co) - ; return $ Just (xi', co') } - Nothing -> pure Nothing } - - try_to_reduce_nocache :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce_nocache tc tys - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = mkSymCo (maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co) - ; return $ Just (xi, co) } - Nothing -> pure Nothing } - -{- Note [Reduce type family applications eagerly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we come across a type-family application like (Append (Cons x Nil) t), -then, rather than flattening to a skolem etc, we may as well just reduce -it on the spot to (Cons x t). This saves a lot of intermediate steps. -Examples that are helped are tests T9872, and T5321Fun. - -Performance testing indicates that it's best to try this *twice*, once -before flattening arguments and once after flattening arguments. -Adding the extra reduction attempt before flattening arguments cut -the allocation amounts for the T9872{a,b,c} tests by half. - -An example of where the early reduction appears helpful: - - type family Last x where - Last '[x] = x - Last (h ': t) = Last t - - workitem: (x ~ Last '[1,2,3,4,5,6]) - -Flattening the argument never gets us anywhere, but trying to flatten -it at every step is quadratic in the length of the list. Reducing more -eagerly makes simplifying the right-hand type linear in its length. - -Testing also indicated that the early reduction should *not* use the -flat-cache, but that the later reduction *should*. (Although the -effect was not large.) Hence the Bool argument to try_to_reduce. To -me (SLPJ) this seems odd; I get that eager reduction usually succeeds; -and if don't use the cache for eager reduction, we will miss most of -the opportunities for using it at all. More exploration would be good -here. - -At the end, once we've got a flat rhs, we extend the flatten-cache to record -the result. Doing so can save lots of work when the same redex shows up more -than once. Note that we record the link from the redex all the way to its -*final* value, not just the single step reduction. Interestingly, using the -flat-cache for the first reduction resulted in an increase in allocations -of about 3% for the four T9872x tests. However, using the flat-cache in -the later reduction is a similar gain. I (Richard E) don't currently (Dec '14) -have any knowledge as to *why* these facts are true. - -************************************************************************ -* * - Flattening a type variable -* * -********************************************************************* -} - --- | The result of flattening a tyvar "one step". -data FlattenTvResult - = FTRNotFollowed - -- ^ The inert set doesn't make the tyvar equal to anything else - - | FTRFollowed TcType Coercion - -- ^ The tyvar flattens to a not-necessarily flat other type. - -- co :: new type ~r old type, where the role is determined by - -- the FlattenEnv - -flattenTyVar :: TyVar -> FlatM (Xi, Coercion) -flattenTyVar tv - = do { mb_yes <- flatten_tyvar1 tv - ; case mb_yes of - FTRFollowed ty1 co1 -- Recur - -> do { (ty2, co2) <- flatten_one ty1 - -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2) - ; return (ty2, co2 `mkTransCo` co1) } - - FTRNotFollowed -- Done, but make sure the kind is zonked - -- Note [Flattening] invariant (F0) and (F1) - -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv - ; role <- getRole - ; let ty' = mkTyVarTy tv' - ; return (ty', mkTcReflCo role ty') } } - -flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult --- "Flattening" a type variable means to apply the substitution to it --- Specifically, look up the tyvar in --- * the internal MetaTyVar box --- * the inerts --- See also the documentation for FlattenTvResult - -flatten_tyvar1 tv - = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty -> do { traceFlat "Following filled tyvar" - (ppr tv <+> equals <+> ppr ty) - ; role <- getRole - ; return (FTRFollowed ty (mkReflCo role ty)) } ; - Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv) - ; fr <- getFlavourRole - ; flatten_tyvar2 tv fr } } - -flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult --- The tyvar is not a filled-in meta-tyvar --- Try in the inert equalities --- See Definition [Applying a generalised substitution] in TcSMonad --- See Note [Stability of flattening] in TcSMonad - -flatten_tyvar2 tv fr@(_, eq_rel) - = do { ieqs <- liftTcS $ getInertEqs - ; mode <- getMode - ; case lookupDVarEnv ieqs tv of - Just (ct:_) -- If the first doesn't work, - -- the subsequent ones won't either - | CTyEqCan { cc_ev = ctev, cc_tyvar = tv - , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct - , let ct_fr = (ctEvFlavour ctev, ct_eq_rel) - , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR - -> do { traceFlat "Following inert tyvar" - (ppr mode <+> - ppr tv <+> - equals <+> - ppr rhs_ty $$ ppr ctev) - ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev) - rewrite_co = case (ct_eq_rel, eq_rel) of - (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) - -- if this ASSERT fails, then - -- eqCanRewriteFR answered incorrectly - rewrite_co1 - (NomEq, NomEq) -> rewrite_co1 - (NomEq, ReprEq) -> mkSubCo rewrite_co1 - - ; return (FTRFollowed rhs_ty rewrite_co) } - -- NB: ct is Derived then fmode must be also, hence - -- we are not going to touch the returned coercion - -- so ctEvCoercion is fine. - - _other -> return FTRNotFollowed } - -{- -Note [An alternative story for the inert substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This entire note is just background, left here in case we ever want - to return the previous state of affairs) - -We used (GHC 7.8) to have this story for the inert substitution inert_eqs - - * 'a' is not in fvs(ty) - * They are *inert* in the weaker sense that there is no infinite chain of - (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc - -This means that flattening must be recursive, but it does allow - [G] a ~ [b] - [G] b ~ Maybe c - -This avoids "saturating" the Givens, which can save a modest amount of work. -It is easy to implement, in TcInteract.kick_out, by only kicking out an inert -only if (a) the work item can rewrite the inert AND - (b) the inert cannot rewrite the work item - -This is significantly harder to think about. It can save a LOT of work -in occurs-check cases, but we don't care about them much. #5837 -is an example; all the constraints here are Givens - - [G] a ~ TF (a,Int) - --> - work TF (a,Int) ~ fsk - inert fsk ~ a - - ---> - work fsk ~ (TF a, TF Int) - inert fsk ~ a - - ---> - work a ~ (TF a, TF Int) - inert fsk ~ a - - ---> (attempting to flatten (TF a) so that it does not mention a - work TF a ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (substitute for a) - work TF (fsk2, TF Int) ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (top-level reduction, re-orient) - work fsk2 ~ (TF fsk2, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (attempt to flatten (TF fsk2) to get rid of fsk2 - work TF fsk2 ~ fsk3 - work fsk2 ~ (fsk3, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> - work TF fsk2 ~ fsk3 - inert fsk2 ~ (fsk3, TF Int) - inert a ~ ((fsk3, TF Int), TF Int) - inert fsk ~ ((fsk3, TF Int), TF Int) - -Because the incoming given rewrites all the inert givens, we get more and -more duplication in the inert set. But this really only happens in pathalogical -casee, so we don't care. - - -************************************************************************ -* * - Unflattening -* * -************************************************************************ - -An unflattening example: - [W] F a ~ alpha -flattens to - [W] F a ~ fmv (CFunEqCan) - [W] fmv ~ alpha (CTyEqCan) -We must solve both! --} - -unflattenWanteds :: Cts -> Cts -> TcS Cts -unflattenWanteds tv_eqs funeqs - = do { tclvl <- getTcLevel - - ; traceTcS "Unflattening" $ braces $ - vcat [ text "Funeqs =" <+> pprCts funeqs - , text "Tv eqs =" <+> pprCts tv_eqs ] - - -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check - -- Occurs check: consider [W] alpha ~ [F alpha] - -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] - -- ==> (unify) [W] F [fmv] ~ fmv - -- See Note [Unflatten using funeqs first] - ; funeqs <- foldrM unflatten_funeq emptyCts funeqs - ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) - - -- Step 2: unify the tv_eqs, if possible - ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs - ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) - - -- Step 3: fill any remaining fmvs with fresh unification variables - ; funeqs <- mapBagM finalise_funeq funeqs - ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) - - -- Step 4: remove any tv_eqs that look like ty ~ ty - ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs - - ; let all_flat = tv_eqs `andCts` funeqs - ; traceTcS "Unflattening done" $ braces (pprCts all_flat) - - ; return all_flat } - where - ---------------- - unflatten_funeq :: Ct -> Cts -> TcS Cts - unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis - , cc_fsk = fmv, cc_ev = ev }) rest - = do { -- fmv should be an un-filled flatten meta-tv; - -- we now fix its final value by filling it, being careful - -- to observe the occurs check. Zonking will eliminate it - -- altogether in due course - rhs' <- zonkTcType (mkTyConApp tc xis) - ; case occCheckExpand [fmv] rhs' of - Just rhs'' -- Normal case: fill the tyvar - -> do { setReflEvidence ev NomEq rhs'' - ; unflattenFmv fmv rhs'' - ; return rest } - - Nothing -> -- Occurs check - return (ct `consCts` rest) } - - unflatten_funeq other_ct _ - = pprPanic "unflatten_funeq" (ppr other_ct) - - ---------------- - finalise_funeq :: Ct -> TcS Ct - finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) - = do { demoteUnfilledFmv fmv - ; return (mkNonCanonical ev) } - finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) - - ---------------- - unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts - unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - - | NomEq <- eq_rel -- See Note [Do not unify representational equalities] - -- in TcInteract - , isFmvTyVar tv -- Previously these fmvs were untouchable, - -- but now they are touchable - -- NB: unlike unflattenFmv, filling a fmv here /does/ - -- bump the unification count; it is "improvement" - -- Note [Unflattening can force the solver to iterate] - = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct ) - -- CTyEqCan invariant should ensure this is true - do { is_filled <- isFilledMetaTyVar tv - ; elim <- case is_filled of - False -> do { traceTcS "unflatten_eq 2" (ppr ct) - ; tryFill ev tv rhs } - True -> do { traceTcS "unflatten_eq 3" (ppr ct) - ; try_fill_rhs ev tclvl tv rhs } - ; if elim - then do { setReflEvidence ev eq_rel (mkTyVarTy tv) - ; return rest } - else return (ct `consCts` rest) } - - | otherwise - = return (ct `consCts` rest) - - unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct) - - ---------------- - try_fill_rhs ev tclvl lhs_tv rhs - -- Constraint is lhs_tv ~ rhs_tv, - -- and lhs_tv is filled, so try RHS - | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs - -- co :: kind(rhs_tv) ~ kind(lhs_tv) - , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv - && not (isTyVarTyVar rhs_tv)) - -- LHS is a filled fmv, and so is a type - -- family application, which a TyVarTv should - -- not unify with - = do { is_filled <- isFilledMetaTyVar rhs_tv - ; if is_filled then return False - else tryFill ev rhs_tv - (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) } - - | otherwise - = return False - - ---------------- - finalise_eq :: Ct -> Cts -> TcS Cts - finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - | isFmvTyVar tv - = do { ty1 <- zonkTcTyVar tv - ; rhs' <- zonkTcType rhs - ; if ty1 `tcEqType` rhs' - then do { setReflEvidence ev eq_rel rhs' - ; return rest } - else return (mkNonCanonical ev `consCts` rest) } - - | otherwise - = return (mkNonCanonical ev `consCts` rest) - - finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) - -tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool --- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv --- If tv does not appear in 'rhs', it set tv := rhs, --- binds the evidence (which should be a CtWanted) to Refl --- and return True. Otherwise returns False -tryFill ev tv rhs - = ASSERT2( not (isGiven ev), ppr ev ) - do { rhs' <- zonkTcType rhs - ; case () of - _ | Just tv' <- tcGetTyVar_maybe rhs' - , tv == tv' -- tv == rhs - -> return True - - _ | Just rhs'' <- occCheckExpand [tv] rhs' - -> do { -- Fill the tyvar - unifyTyVar tv rhs'' - ; return True } - - _ | otherwise -- Occurs check - -> return False - } - -setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS () -setReflEvidence ev eq_rel rhs - = setEvBindIfWanted ev (evCoercion refl_co) - where - refl_co = mkTcReflCo (eqRelRole eq_rel) rhs - -{- -Note [Unflatten using funeqs first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - [W] G a ~ Int - [W] F (G a) ~ G a - -do not want to end up with - [W] F Int ~ Int -because that might actually hold! Better to end up with the two above -unsolved constraints. The flat form will be - - G a ~ fmv1 (CFunEqCan) - F fmv1 ~ fmv2 (CFunEqCan) - fmv1 ~ Int (CTyEqCan) - fmv1 ~ fmv2 (CTyEqCan) - -Flatten using the fun-eqs first. --} - --- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at --- least one named binder. -split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) -split_pi_tys' ty = split ty ty - where - split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' - split _ (ForAllTy b res) = let (bs, ty, _) = split res res - in (Named b : bs, ty, True) - split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - = let (bs, ty, named) = split res res - in (Anon af arg : bs, ty, named) - split orig_ty _ = ([], orig_ty, False) -{-# INLINE split_pi_tys' #-} - --- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff --- there is at least one named binder. -ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) -ty_con_binders_ty_binders' = foldr go ([], False) - where - go (Bndr tv (NamedTCB vis)) (bndrs, _) - = (Named (Bndr tv vis) : bndrs, True) - go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon af (tyVarKind tv) : bndrs, n) - {-# INLINE go #-} -{-# INLINE ty_con_binders_ty_binders' #-} diff --git a/typecheck/TcForeign.hs b/typecheck/TcForeign.hs deleted file mode 100644 --- a/typecheck/TcForeign.hs +++ /dev/null @@ -1,571 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - -\section[TcForeign]{Typechecking \tr{foreign} declarations} - -A foreign declaration is used to either give an externally -implemented function a Haskell type (and calling interface) or -give a Haskell function an external calling interface. Either way, -the range of argument and result types these functions can accommodate -is restricted to what the outside world understands (read C), and this -module checks to see if a foreign declaration has got a legal type. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcForeign - ( tcForeignImports - , tcForeignExports - - -- Low-level exports for hooks - , isForeignImport, isForeignExport - , tcFImport, tcFExport - , tcForeignImports' - , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes - , normaliseFfiType - , nonIOok, mustBeIO - , checkSafe, noCheckSafe - , tcForeignExports' - , tcCheckFEType - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs - -import TcRnMonad -import TcHsType -import TcExpr -import TcEnv - -import FamInst -import FamInstEnv -import Coercion -import Type -import ForeignCall -import ErrUtils -import Id -import Name -import RdrName -import DataCon -import TyCon -import TcType -import PrelNames -import DynFlags -import Outputable -import GHC.Platform -import SrcLoc -import Bag -import Hooks -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad - --- Defines a binding -isForeignImport :: LForeignDecl name -> Bool -isForeignImport (L _ (ForeignImport {})) = True -isForeignImport _ = False - --- Exports a binding -isForeignExport :: LForeignDecl name -> Bool -isForeignExport (L _ (ForeignExport {})) = True -isForeignExport _ = False - -{- -Note [Don't recur in normaliseFfiType'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -normaliseFfiType' is the workhorse for normalising a type used in a foreign -declaration. If we have - -newtype Age = MkAge Int - -we want to see that Age -> IO () is the same as Int -> IO (). But, we don't -need to recur on any type parameters, because no paramaterized types (with -interesting parameters) are marshalable! The full list of marshalable types -is in the body of boxedMarshalableTyCon in TcType. The only members of that -list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled -the same way regardless of type parameter. So, no need to recur into -parameters. - -Similarly, we don't need to look in AppTy's, because nothing headed by -an AppTy will be marshalable. - -Note [FFI type roles] -~~~~~~~~~~~~~~~~~~~~~ -The 'go' helper function within normaliseFfiType' always produces -representational coercions. But, in the "children_only" case, we need to -use these coercions in a TyConAppCo. Accordingly, the roles on the coercions -must be twiddled to match the expectation of the enclosing TyCon. However, -we cannot easily go from an R coercion to an N one, so we forbid N roles -on FFI type constructors. Currently, only two such type constructors exist: -IO and FunPtr. Thus, this is not an onerous burden. - -If we ever want to lift this restriction, we would need to make 'go' take -the target role as a parameter. This wouldn't be hard, but it's a complication -not yet necessary and so is not yet implemented. --} - --- normaliseFfiType takes the type from an FFI declaration, and --- evaluates any type synonyms, type functions, and newtypes. However, --- we are only allowed to look through newtypes if the constructor is --- in scope. We return a bag of all the newtype constructors thus found. --- Always returns a Representational coercion -normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType ty - = do fam_envs <- tcGetFamInstEnvs - normaliseFfiType' fam_envs ty - -normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType' env ty0 = go initRecTc ty0 - where - go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) - go rec_nts ty - | Just ty' <- tcView ty -- Expand synonyms - = go rec_nts ty' - - | Just (tc, tys) <- splitTyConApp_maybe ty - = go_tc_app rec_nts tc tys - - | (bndrs, inner_ty) <- splitForAllVarBndrs ty - , not (null bndrs) - = do (coi, nty1, gres1) <- go rec_nts inner_ty - return ( mkHomoForAllCos (binderVars bndrs) coi - , mkForAllTys bndrs nty1, gres1 ) - - | otherwise -- see Note [Don't recur in normaliseFfiType'] - = return (mkRepReflCo ty, ty, emptyBag) - - go_tc_app :: RecTcChecker -> TyCon -> [Type] - -> TcM (Coercion, Type, Bag GlobalRdrElt) - go_tc_app rec_nts tc tys - -- We don't want to look through the IO newtype, even if it is - -- in scope, so we have a special case for it: - | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] - -- These *must not* have nominal roles on their parameters! - -- See Note [FFI type roles] - = children_only - - | isNewTyCon tc -- Expand newtypes - , Just rec_nts' <- checkRecTc rec_nts tc - -- See Note [Expanding newtypes] in TyCon.hs - -- We can't just use isRecursiveTyCon; sometimes recursion is ok: - -- newtype T = T (Ptr T) - -- Here, we don't reject the type for being recursive. - -- If this is a recursive newtype then it will normally - -- be rejected later as not being a valid FFI type. - = do { rdr_env <- getGlobalRdrEnv - ; case checkNewtypeFFI rdr_env tc of - Nothing -> nothing - Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs - ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } - - | isFamilyTyCon tc -- Expand open tycons - , (co, ty) <- normaliseTcApp env Representational tc tys - , not (isReflexiveCo co) - = do (co', ty', gres) <- go rec_nts ty - return (mkTransCo co co', ty', gres) - - | otherwise - = nothing -- see Note [Don't recur in normaliseFfiType'] - where - tc_key = getUnique tc - children_only - = do xs <- mapM (go rec_nts) tys - let (cos, tys', gres) = unzip3 xs - -- the (repeat Representational) is because 'go' always - -- returns R coercions - cos' = zipWith3 downgradeRole (tyConRoles tc) - (repeat Representational) cos - return ( mkTyConAppCo Representational tc cos' - , mkTyConApp tc tys', unionManyBags gres) - nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys [] - nt_rhs = newTyConInstRhs tc tys - - ty = mkTyConApp tc tys - nothing = return (mkRepReflCo ty, ty, emptyBag) - -checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt -checkNewtypeFFI rdr_env tc - | Just con <- tyConSingleDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - = Just gre -- See Note [Newtype constructor usage in foreign declarations] - | otherwise - = Nothing - -{- -Note [Newtype constructor usage in foreign declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC automatically "unwraps" newtype constructors in foreign import/export -declarations. In effect that means that a newtype data constructor is -used even though it is not mentioned expclitly in the source, so we don't -want to report it as "defined but not used" or "imported but not used". -eg newtype D = MkD Int - foreign import foo :: D -> IO () -Here 'MkD' us used. See #7408. - -GHC also expands type functions during this process, so it's not enough -just to look at the free variables of the declaration. -eg type instance F Bool = D - foreign import bar :: F Bool -> IO () -Here again 'MkD' is used. - -So we really have wait until the type checker to decide what is used. -That's why tcForeignImports and tecForeignExports return a (Bag GRE) -for the newtype constructors they see. Then TcRnDriver can add them -to the module's usages. - - -************************************************************************ -* * -\subsection{Imports} -* * -************************************************************************ --} - -tcForeignImports :: [LForeignDecl GhcRn] - -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) -tcForeignImports decls - = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) - -tcForeignImports' :: [LForeignDecl GhcRn] - -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignImports' decls - = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ - filter isForeignImport decls - ; return (ids, decls, unionManyBags gres) } - -tcFImport :: LForeignDecl GhcRn - -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) -tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty - , fd_fi = imp_decl })) - = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) - id = mkLocalId nm sig_ty - -- Use a LocalId to obey the invariant that locally-defined - -- things are LocalIds. However, it does not need zonking, - -- (so TcHsSyn.zonkForeignExports ignores it). - - ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl - -- Can't use sig_ty here because sig_ty :: Type and - -- we need HsType Id hence the undefined - ; let fi_decl = ForeignImport { fd_name = L nloc id - , fd_sig_ty = undefined - , fd_i_ext = mkSymCo norm_co - , fd_fi = imp_decl' } - ; return (id, L dloc fi_decl, gres) } -tcFImport d = pprPanic "tcFImport" (ppr d) - --- ------------ Checking types for foreign import ---------------------- - -tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) - -- Foreign import label - = do checkCg checkCOrAsmOrLlvmOrInterp - -- NB check res_ty not sig_ty! - -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) - cconv' <- checkCConv cconv - return (CImport (L lc cconv') safety mh l src) - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do - -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid - -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. - -- The use of the latter form is DEPRECATED, though. - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of - [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys - checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty - checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty - where - (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) - return (CImport (L lc cconv') safety mh CWrapper src) - -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh - (CFunction target) src) - | isDynamicTarget target = do -- Foreign import dynamic - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of -- The first arg must be Ptr or FunPtr - [] -> - addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) - (arg1_ty:arg_tys) -> do - dflags <- getDynFlags - let curried_res_ty = mkVisFunTys arg_tys res_ty - check (isFFIDynTy curried_res_ty arg1_ty) - (illegalForeignTyErr argument) - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - | cconv == PrimCallConv = do - dflags <- getDynFlags - checkTc (xopt LangExt.GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") - checkCg checkCOrAsmOrLlvmOrInterp - checkCTarget target - checkTc (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") - checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys - -- prim import result is more liberal, allows (#,,#) - checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty - return idecl - | otherwise = do -- Normal foreign import - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - checkCTarget target - dflags <- getDynFlags - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - checkMissingAmpersand dflags arg_tys res_ty - case target of - StaticTarget _ _ _ False - | not (null arg_tys) -> - addErrTc (text "`value' imports cannot have function types") - _ -> return () - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - - --- This makes a convenient place to check --- that the C identifier is valid for C -checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget _ str _ _) = do - checkCg checkCOrAsmOrLlvmOrInterp - checkTc (isCLabelString str) (badCName str) - -checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" - - -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () -checkMissingAmpersand dflags arg_tys res_ty - | null arg_tys && isFunPtrTy res_ty && - wopt Opt_WarnDodgyForeignImports dflags - = addWarn (Reason Opt_WarnDodgyForeignImports) - (text "possible missing & in foreign import of FunPtr") - | otherwise - = return () - -{- -************************************************************************ -* * -\subsection{Exports} -* * -************************************************************************ --} - -tcForeignExports :: [LForeignDecl GhcRn] - -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) -tcForeignExports decls = - getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) - -tcForeignExports' :: [LForeignDecl GhcRn] - -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignExports' decls - = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) - where - combine (binds, fs, gres1) (L loc fe) = do - (b, f, gres2) <- setSrcSpan loc (tcFExport fe) - return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) - -tcFExport :: ForeignDecl GhcRn - -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) -tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) - = addErrCtxt (foreignDeclCtxt fo) $ do - - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - rhs <- tcPolyExpr (nlHsVar nm) sig_ty - - (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - - spec' <- tcCheckFEType norm_sig_ty spec - - -- we're exporting a function, but at a type possibly more - -- constrained than its declared/inferred type. Hence the need - -- to create a local binding which will call the exported function - -- at a particular type (and, maybe, overloading). - - - -- We need to give a name to the new top-level binding that - -- is *stable* (i.e. the compiler won't change it later), - -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return ( mkVarBind id rhs - , ForeignExport { fd_name = L loc id - , fd_sig_ty = undefined - , fd_e_ext = norm_co, fd_fe = spec' } - , gres) -tcFExport d = pprPanic "tcFExport" (ppr d) - --- ------------ Checking argument types for foreign export ---------------------- - -tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport -tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do - checkCg checkCOrAsmOrLlvm - checkTc (isCLabelString str) (badCName str) - cconv' <- checkCConv cconv - checkForeignArgs isFFIExternalTy arg_tys - checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty - return (CExport (L l (CExportStatic esrc str cconv')) src) - where - -- Drop the foralls before inspecting - -- the structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty) - -{- -************************************************************************ -* * -\subsection{Miscellaneous} -* * -************************************************************************ --} - ------------- Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () -checkForeignArgs pred tys = mapM_ go tys - where - go ty = check (pred ty) (illegalForeignTyErr argument) - ------------- Checking result types for foreign calls ---------------------- --- | Check that the type has the form --- (IO t) or (t) , and that t satisfies the given predicate. --- When calling this function, any newtype wrappers (should) have been --- already dealt with by normaliseFfiType. --- --- We also check that the Safe Haskell condition of FFI imports having --- results in the IO monad holds. --- -checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () -checkForeignRes non_io_result_ok check_safe pred_res_ty ty - | Just (_, res_ty) <- tcSplitIOType_maybe ty - = -- Got an IO result type, that's always fine! - check (pred_res_ty res_ty) (illegalForeignTyErr result) - - -- We disallow nested foralls in foreign types - -- (at least, for the time being). See #16702. - | tcIsForAllTy ty - = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall") - - -- Case for non-IO result type with FFI Import - | not non_io_result_ok - = addErrTc $ illegalForeignTyErr result (text "IO result type expected") - - | otherwise - = do { dflags <- getDynFlags - ; case pred_res_ty ty of - -- Handle normal typecheck fail, we want to handle this first and - -- only report safe haskell errors if the normal type check is OK. - NotValid msg -> addErrTc $ illegalForeignTyErr result msg - - -- handle safe infer fail - _ | check_safe && safeInferOn dflags - -> recordUnsafeInfer emptyBag - - -- handle safe language typecheck fail - _ | check_safe && safeLanguageOn dflags - -> addErrTc (illegalForeignTyErr result safeHsErr) - - -- success! non-IO return is fine - _ -> return () } - where - safeHsErr = - text "Safe Haskell is on, all FFI imports must be in the IO monad" - -nonIOok, mustBeIO :: Bool -nonIOok = True -mustBeIO = False - -checkSafe, noCheckSafe :: Bool -checkSafe = True -noCheckSafe = False - --- Checking a supported backend is in use - -checkCOrAsmOrLlvm :: HscTarget -> Validity -checkCOrAsmOrLlvm HscC = IsValid -checkCOrAsmOrLlvm HscAsm = IsValid -checkCOrAsmOrLlvm HscLlvm = IsValid -checkCOrAsmOrLlvm _ - = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") - -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity -checkCOrAsmOrLlvmOrInterp HscC = IsValid -checkCOrAsmOrLlvmOrInterp HscAsm = IsValid -checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid -checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid -checkCOrAsmOrLlvmOrInterp _ - = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") - -checkCg :: (HscTarget -> Validity) -> TcM () -checkCg check = do - dflags <- getDynFlags - let target = hscTarget dflags - case target of - HscNothing -> return () - _ -> - case check target of - IsValid -> return () - NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) - --- Calling conventions - -checkCConv :: CCallConv -> TcM CCallConv -checkCConv CCallConv = return CCallConv -checkCConv CApiConv = return CApiConv -checkCConv StdCallConv = do dflags <- getDynFlags - let platform = targetPlatform dflags - if platformArch platform == ArchX86 - then return StdCallConv - else do -- This is a warning, not an error. see #3336 - when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ - addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") - return CCallConv -checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") - return PrimCallConv -checkCConv JavaScriptCallConv = do dflags <- getDynFlags - if platformArch (targetPlatform dflags) == ArchJavaScript - then return JavaScriptCallConv - else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") - return JavaScriptCallConv - --- Warnings - -check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () -check IsValid _ = return () -check (NotValid doc) err_fn = addErrTc (err_fn doc) - -illegalForeignTyErr :: SDoc -> SDoc -> SDoc -illegalForeignTyErr arg_or_res extra - = hang msg 2 extra - where - msg = hsep [ text "Unacceptable", arg_or_res - , text "type in foreign declaration:"] - --- Used for 'arg_or_res' argument to illegalForeignTyErr -argument, result :: SDoc -argument = text "argument" -result = text "result" - -badCName :: CLabelString -> MsgDoc -badCName target - = sep [quotes (ppr target) <+> text "is not a valid C identifier"] - -foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc -foreignDeclCtxt fo - = hang (text "When checking declaration:") - 2 (ppr fo) diff --git a/typecheck/TcGenDeriv.hs b/typecheck/TcGenDeriv.hs deleted file mode 100644 --- a/typecheck/TcGenDeriv.hs +++ /dev/null @@ -1,2391 +0,0 @@ -{- - % -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcGenDeriv: Generating derived instance declarations - -This module is nominally ``subordinate'' to @TcDeriv@, which is the -``official'' interface to deriving-related things. - -This is where we do all the grimy bindings' generation. --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module TcGenDeriv ( - BagDerivStuff, DerivStuff(..), - - gen_Eq_binds, - gen_Ord_binds, - gen_Enum_binds, - gen_Bounded_binds, - gen_Ix_binds, - gen_Show_binds, - gen_Read_binds, - gen_Data_binds, - gen_Lift_binds, - gen_Newtype_binds, - mkCoerceClassMethEqn, - genAuxBinds, - ordOpTbl, boxConTbl, litConTbl, - mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import GHC.Hs -import RdrName -import BasicTypes -import DataCon -import Name -import Fingerprint -import Encoding - -import DynFlags -import PrelInfo -import FamInst -import FamInstEnv -import PrelNames -import THNames -import MkId ( coerceId ) -import PrimOp -import SrcLoc -import TyCon -import TcEnv -import TcType -import TcValidity ( checkValidCoAxBranch ) -import CoAxiom ( coAxiomSingleBranch ) -import TysPrim -import TysWiredIn -import Type -import Class -import VarSet -import VarEnv -import Util -import Var -import Outputable -import Lexeme -import FastString -import Pair -import Bag - -import Data.List ( find, partition, intersperse ) - -type BagDerivStuff = Bag DerivStuff - -data AuxBindSpec - = DerivCon2Tag TyCon -- The con2Tag for given TyCon - | DerivTag2Con TyCon -- ...ditto tag2Con - | DerivMaxTag TyCon -- ...and maxTag - deriving( Eq ) - -- All these generate ZERO-BASED tag operations - -- I.e first constructor has tag 0 - -data DerivStuff -- Please add this auxiliary stuff - = DerivAuxBind AuxBindSpec - - -- Generics and DeriveAnyClass - | DerivFamInst FamInst -- New type family instances - - -- New top-level auxiliary bindings - | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB - - -{- -************************************************************************ -* * - Eq instances -* * -************************************************************************ - -Here are the heuristics for the code we generate for @Eq@. Let's -assume we have a data type with some (possibly zero) nullary data -constructors and some ordinary, non-nullary ones (the rest, also -possibly zero of them). Here's an example, with both \tr{N}ullary and -\tr{O}rdinary data cons. - - data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... - -* For the ordinary constructors (if any), we emit clauses to do The - Usual Thing, e.g.,: - - (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 - (==) (O2 a1) (O2 a2) = a1 == a2 - (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 - - Note: if we're comparing unlifted things, e.g., if 'a1' and - 'a2' are Float#s, then we have to generate - case (a1 `eqFloat#` a2) of r -> r - for that particular test. - -* If there are a lot of (more than ten) nullary constructors, we emit a - catch-all clause of the form: - - (==) a b = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - case (a# ==# b#) of { - r -> r }}} - - If con2tag gets inlined this leads to join point stuff, so - it's better to use regular pattern matching if there aren't too - many nullary constructors. "Ten" is arbitrary, of course - -* If there aren't any nullary constructors, we emit a simpler - catch-all: - - (==) a b = False - -* For the @(/=)@ method, we normally just use the default method. - If the type is an enumeration type, we could/may/should? generate - special code that calls @con2tag_Foo@, much like for @(==)@ shown - above. - -We thought about doing this: If we're also deriving 'Ord' for this -tycon, we generate: - instance ... Eq (Foo ...) where - (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} - (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } -However, that requires that (Ord ) was put in the context -for the instance decl, which it probably wasn't, so the decls -produced don't get through the typechecker. --} - -gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Eq_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - all_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons - - -- If there are ten or more (arbitrary number) nullary constructors, - -- use the con2tag stuff. For small types it's better to use - -- ordinary pattern matching. - (tag_match_cons, pat_match_cons) - | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) - | otherwise = ([], all_cons) - - no_tag_match_cons = null tag_match_cons - - fall_through_eqn dflags - | no_tag_match_cons -- All constructors have arguments - = case pat_match_cons of - [] -> [] -- No constructors; no fall-though case - [_] -> [] -- One constructor; no fall-though case - _ -> -- Two or more constructors; add fall-through of - -- (==) _ _ = False - [([nlWildPat, nlWildPat], false_Expr)] - - | otherwise -- One or more tag_match cons; add fall-through of - -- extract tags compare for equality - = [([a_Pat, b_Pat], - untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - - aux_binds | no_tag_match_cons = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - method_binds dflags = unitBag (eq_bind dflags) - eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr) - (map pats_etc pat_match_cons - ++ fall_through_eqn dflags) - - ------------------------------------------------------------------ - pats_etc data_con - = let - con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed - con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed - - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con - in - ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) - where - nested_eq_expr [] [] [] = true_Expr - nested_eq_expr tys as bs - = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) - -- Using 'foldr1' here ensures that the derived code is correctly - -- associated. See #10859. - where - nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) - -{- -************************************************************************ -* * - Ord instances -* * -************************************************************************ - -Note [Generating Ord instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose constructors are K1..Kn, and some are nullary. -The general form we generate is: - -* Do case on first argument - case a of - K1 ... -> rhs_1 - K2 ... -> rhs_2 - ... - Kn ... -> rhs_n - _ -> nullary_rhs - -* To make rhs_i - If i = 1, 2, n-1, n, generate a single case. - rhs_2 case b of - K1 {} -> LT - K2 ... -> ...eq_rhs(K2)... - _ -> GT - - Otherwise do a tag compare against the bigger range - (because this is the one most likely to succeed) - rhs_3 case tag b of tb -> - if 3 <# tg then GT - else case b of - K3 ... -> ...eq_rhs(K3).... - _ -> LT - -* To make eq_rhs(K), which knows that - a = K a1 .. av - b = K b1 .. bv - we just want to compare (a1,b1) then (a2,b2) etc. - Take care on the last field to tail-call into comparing av,bv - -* To make nullary_rhs generate this - case con2tag a of a# -> - case con2tag b of -> - a# `compare` b# - -Several special cases: - -* Two or fewer nullary constructors: don't generate nullary_rhs - -* Be careful about unlifted comparisons. When comparing unboxed - values we can't call the overloaded functions. - See function unliftedOrdOp - -Note [Game plan for deriving Ord] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a bad idea to define only 'compare', and build the other binary -comparisons on top of it; see #2130, #4019. Reason: we don't -want to laboriously make a three-way comparison, only to extract a -binary result, something like this: - (>) (I# x) (I# y) = case <# x y of - True -> False - False -> case ==# x y of - True -> False - False -> True - -This being said, we can get away with generating full code only for -'compare' and '<' thus saving us generation of other three operators. -Other operators can be cheaply expressed through '<': -a <= b = not $ b < a -a > b = b < a -a >= b = not $ a < b - -So for sufficiently small types (few constructors, or all nullary) -we generate all methods; for large ones we just use 'compare'. - --} - -data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT - ------------- -ordMethRdr :: OrdOp -> RdrName -ordMethRdr op - = case op of - OrdCompare -> compare_RDR - OrdLT -> lt_RDR - OrdLE -> le_RDR - OrdGE -> ge_RDR - OrdGT -> gt_RDR - ------------- -ltResult :: OrdOp -> LHsExpr GhcPs --- Knowing a LHsExpr GhcPs --- Knowing a=b, what is the result for a `op` b? -eqResult OrdCompare = eqTag_Expr -eqResult OrdLT = false_Expr -eqResult OrdLE = true_Expr -eqResult OrdGE = true_Expr -eqResult OrdGT = false_Expr - ------------- -gtResult :: OrdOp -> LHsExpr GhcPs --- Knowing a>b, what is the result for a `op` b? -gtResult OrdCompare = gtTag_Expr -gtResult OrdLT = false_Expr -gtResult OrdLE = false_Expr -gtResult OrdGE = true_Expr -gtResult OrdGT = true_Expr - ------------- -gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Ord_binds loc tycon = do - dflags <- getDynFlags - return $ if null tycon_data_cons -- No data-cons => invoke bale-out case - then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] - , emptyBag) - else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags - , aux_binds) - where - aux_binds | single_con_type = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - -- Note [Game plan for deriving Ord] - other_ops dflags - | (last_tag - first_tag) <= 2 -- 1-3 constructors - || null non_nullary_cons -- Or it's an enumeration - = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE] - | otherwise - = emptyBag - - negate_expr = nlHsApp (nlHsVar not_RDR) - lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) - gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ - nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr - gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) - - get_tag con = dataConTag con - fIRST_TAG - -- We want *zero-based* tags, because that's what - -- con2Tag returns (generated by untag_Expr)! - - tycon_data_cons = tyConDataCons tycon - single_con_type = isSingleton tycon_data_cons - (first_con : _) = tycon_data_cons - (last_con : _) = reverse tycon_data_cons - first_tag = get_tag first_con - last_tag = get_tag last_con - - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - - - mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs - -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] - (mkOrdOpRhs dflags op) - - mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs - mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op - | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases - = nlHsCase (nlHsVar a_RDR) $ - map (mkOrdOpAlt dflags op) tycon_data_cons - -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... - -- C2 x -> case b of C2 x -> ....comopare x.... } - - | null non_nullary_cons -- All nullary, so go straight to comparing tags - = mkTagCmp dflags op - - | otherwise -- Mixed nullary and non-nullary - = nlHsCase (nlHsVar a_RDR) $ - (map (mkOrdOpAlt dflags op) non_nullary_cons - ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)]) - - - mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon - -> LMatch GhcPs (LHsExpr GhcPs) - -- Make the alternative (Ki a1 a2 .. av -> - mkOrdOpAlt dflags op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) - (mkInnerRhs dflags op data_con) - where - as_needed = take (dataConSourceArity data_con) as_RDRs - data_con_RDR = getRdrName data_con - - mkInnerRhs dflags op data_con - | single_con_type - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] - - | tag == first_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag == first_tag + 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) - (gtResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) - (ltResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag > last_tag `div` 2 -- lower range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) - (gtResult op) $ -- Definitely GT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - - | otherwise -- upper range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) - (ltResult op) $ -- Definitely LT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - where - tag = get_tag data_con - tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) - - mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) - -- First argument 'a' known to be built with K - -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) - mkInnerEqAlt op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ - mkCompareFields op (dataConOrigArgTys data_con) - where - data_con_RDR = getRdrName data_con - bs_needed = take (dataConSourceArity data_con) bs_RDRs - - mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs - -- Both constructors known to be nullary - -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# - mkTagCmp dflags op = - untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ - unliftedOrdOp intPrimTy op ah_RDR bh_RDR - -mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs --- Generates nested comparisons for (a1,a2...) against (b1,b2,...) --- where the ai,bi have the given types -mkCompareFields op tys - = go tys as_RDRs bs_RDRs - where - go [] _ _ = eqResult op - go [ty] (a:_) (b:_) - | isUnliftedType ty = unliftedOrdOp ty op a b - | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) - go (ty:tys) (a:as) (b:bs) = mk_compare ty a b - (ltResult op) - (go tys as bs) - (gtResult op) - go _ _ _ = panic "mkCompareFields" - - -- (mk_compare ty a b) generates - -- (case (compare a b) of { LT -> ; EQ -> ; GT -> }) - -- but with suitable special cases for - mk_compare ty a b lt eq gt - | isUnliftedType ty - = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - | otherwise - = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) - [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, - mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, - mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] - where - a_expr = nlHsVar a - b_expr = nlHsVar b - (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty - -unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs -unliftedOrdOp ty op a b - = case op of - OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr - ltTag_Expr eqTag_Expr gtTag_Expr - OrdLT -> wrap lt_op - OrdLE -> wrap le_op - OrdGE -> wrap ge_op - OrdGT -> wrap gt_op - where - (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty - wrap prim_op = genPrimOpApp a_expr prim_op b_expr - a_expr = nlHsVar a - b_expr = nlHsVar b - -unliftedCompare :: RdrName -> RdrName - -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to cmpare - -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - -- Three results - -> LHsExpr GhcPs --- Return (if a < b then lt else if a == b then eq else gt) -unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ - -- Test (<) first, not (==), because the latter - -- is true less often, so putting it first would - -- mean more tests (dynamically) - nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt - where - ascribeBool e = nlExprWithTySig e boolTy - -nlConWildPat :: DataCon -> LPat GhcPs --- The pattern (K {}) -nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (RecCon (HsRecFields { rec_flds = [] - , rec_dotdot = Nothing }))) - -{- -************************************************************************ -* * - Enum instances -* * -************************************************************************ - -@Enum@ can only be derived for enumeration types. For a type -\begin{verbatim} -data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} - -we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a -@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). - -\begin{verbatim} -instance ... Enum (Foo ...) where - succ x = toEnum (1 + fromEnum x) - pred x = toEnum (fromEnum x - 1) - - toEnum i = tag2con_Foo i - - enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] - - -- or, really... - enumFrom a - = case con2tag_Foo a of - a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) - - enumFromThen a b - = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] - - -- or, really... - enumFromThen a b - = case con2tag_Foo a of { a# -> - case con2tag_Foo b of { b# -> - map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) - }} -\end{verbatim} - -For @enumFromTo@ and @enumFromThenTo@, we use the default methods. --} - -gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Enum_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - method_binds dflags = listToBag - [ succ_enum dflags - , pred_enum dflags - , to_enum dflags - , enum_from dflags - , enum_from_then dflags - , from_enum dflags - ] - aux_binds = listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] - - occ_nm = getOccString tycon - - succ_enum dflags - = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsIntLit 1])) - - pred_enum dflags - = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR - [ nlHsVarApps intDataCon_RDR [ah_RDR] - , nlHsLit (HsInt noExtField - (mkIntegralLit (-1 :: Int)))])) - - to_enum dflags - = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ - nlHsIf (nlHsApps and_RDR - [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], - nlHsApps le_RDR [ nlHsVar a_RDR - , nlHsVar (maxtag_RDR dflags tycon)]]) - (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR]) - (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) - - enum_from dflags - = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsApps map_RDR - [nlHsVar (tag2con_RDR dflags tycon), - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVar (maxtag_RDR dflags tycon)))] - - enum_from_then dflags - = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_then_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR]) - (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsVarApps intDataCon_RDR [bh_RDR]]) - (nlHsIntLit 0) - (nlHsVar (maxtag_RDR dflags tycon)) - )) - - from_enum dflags - = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - (nlHsVarApps intDataCon_RDR [ah_RDR]) - -{- -************************************************************************ -* * - Bounded instances -* * -************************************************************************ --} - -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Bounded_binds loc tycon - | isEnumerationTyCon tycon - = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) - | otherwise - = ASSERT(isSingleton data_cons) - (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) - where - data_cons = tyConDataCons tycon - - ----- enum-flavored: --------------------------- - min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) - - data_con_1 = head data_cons - data_con_N = last data_cons - data_con_1_RDR = getRdrName data_con_1 - data_con_N_RDR = getRdrName data_con_N - - ----- single-constructor-flavored: ------------- - arity = dataConSourceArity data_con_1 - - min_bound_1con = mkHsVarBind loc minBound_RDR $ - nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR) - max_bound_1con = mkHsVarBind loc maxBound_RDR $ - nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR) - -{- -************************************************************************ -* * - Ix instances -* * -************************************************************************ - -Deriving @Ix@ is only possible for enumeration types and -single-constructor types. We deal with them in turn. - -For an enumeration type, e.g., -\begin{verbatim} - data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} -things go not too differently from @Enum@: -\begin{verbatim} -instance ... Ix (Foo ...) where - range (a, b) - = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] - - -- or, really... - range (a, b) - = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - map tag2con_Foo (enumFromTo (I# a#) (I# b#)) - }} - - -- Generate code for unsafeIndex, because using index leads - -- to lots of redundant range tests - unsafeIndex c@(a, b) d - = case (con2tag_Foo d -# con2tag_Foo a) of - r# -> I# r# - - inRange (a, b) c - = let - p_tag = con2tag_Foo c - in - p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b - - -- or, really... - inRange (a, b) c - = case (con2tag_Foo a) of { a_tag -> - case (con2tag_Foo b) of { b_tag -> - case (con2tag_Foo c) of { c_tag -> - if (c_tag >=# a_tag) then - c_tag <=# b_tag - else - False - }}} -\end{verbatim} -(modulo suitable case-ification to handle the unlifted tags) - -For a single-constructor type (NB: this includes all tuples), e.g., -\begin{verbatim} - data Foo ... = MkFoo a b Int Double c c -\end{verbatim} -we follow the scheme given in Figure~19 of the Haskell~1.2 report -(p.~147). --} - -gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) - -gen_Ix_binds loc tycon = do - dflags <- getDynFlags - return $ if isEnumerationTyCon tycon - then (enum_ixes dflags, listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) - else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) - where - -------------------------------------------------------------- - enum_ixes dflags = listToBag - [ enum_range dflags - , enum_index dflags - , enum_inRange dflags - ] - - enum_range dflags - = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR])) - - enum_index dflags - = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [noLoc (AsPat noExtField (noLoc c_RDR) - (nlTuplePat [a_Pat, nlWildPat] Boxed)), - d_Pat] ( - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(d_RDR, dh_RDR)] ( - let - rhs = nlHsVarApps intDataCon_RDR [c_RDR] - in - nlHsCase - (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) - [mkHsCaseAlt (nlVarPat c_RDR) rhs] - )) - ) - - -- This produces something like `(ch >= ah) && (ch <= bh)` - enum_inRange dflags - = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( - untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( - -- This used to use `if`, which interacts badly with RebindableSyntax. - -- See #11396. - nlHsApps and_RDR - [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) - , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) - ] - ))) - - -------------------------------------------------------------- - single_con_ixes - = listToBag [single_con_range, single_con_index, single_con_inRange] - - data_con - = case tyConSingleDataCon_maybe tycon of -- just checking... - Nothing -> panic "get_Ix_binds" - Just dc -> dc - - con_arity = dataConSourceArity data_con - data_con_RDR = getRdrName data_con - - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - cs_needed = take con_arity cs_RDRs - - con_pat xs = nlConVarPat data_con_RDR xs - con_expr = nlHsVarApps data_con_RDR cs_needed - - -------------------------------------------------------------- - single_con_range - = mkSimpleGeneratedFunBind loc range_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - noLoc (mkHsComp ListComp stmts con_expr) - where - stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed - - mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) - (nlHsApp (nlHsVar range_RDR) - (mkLHsVarTuple [a,b])) - - ---------------- - single_con_index - = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] - -- We need to reverse the order we consider the components in - -- so that - -- range (l,u) !! index (l,u) i == i -- when i is in range - -- (from http://haskell.org/onlinereport/ix.html) holds. - (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) - where - -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) - mk_index [] = nlHsIntLit 0 - mk_index [(l,u,i)] = mk_one l u i - mk_index ((l,u,i) : rest) - = genOpApp ( - mk_one l u i - ) plus_RDR ( - genOpApp ( - (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (mkLHsVarTuple [l,u])) - ) times_RDR (mk_index rest) - ) - mk_one l u i - = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] - - ------------------ - single_con_inRange - = mkSimpleGeneratedFunBind loc inRange_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] $ - if con_arity == 0 - -- If the product type has no fields, inRange is trivially true - -- (see #12853). - then true_Expr - else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range - as_needed bs_needed cs_needed) - where - in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] - -{- -************************************************************************ -* * - Read instances -* * -************************************************************************ - -Example - - infix 4 %% - data T = Int %% Int - | T1 { f1 :: Int } - | T2 T - -instance Read T where - readPrec = - parens - ( prec 4 ( - do x <- ReadP.step Read.readPrec - expectP (Symbol "%%") - y <- ReadP.step Read.readPrec - return (x %% y)) - +++ - prec (appPrec+1) ( - -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok - -- Record construction binds even more tightly than application - do expectP (Ident "T1") - expectP (Punc '{') - x <- Read.readField "f1" (ReadP.reset readPrec) - expectP (Punc '}') - return (T1 { f1 = x })) - +++ - prec appPrec ( - do expectP (Ident "T2") - x <- ReadP.step Read.readPrec - return (T2 x)) - ) - - readListPrec = readListPrecDefault - readList = readListDefault - - -Note [Use expectP] -~~~~~~~~~~~~~~~~~~ -Note that we use - expectP (Ident "T1") -rather than - Ident "T1" <- lexP -The latter desugares to inline code for matching the Ident and the -string, and this can be very voluminous. The former is much more -compact. Cf #7258, although that also concerned non-linearity in -the occurrence analyser, a separate issue. - -Note [Read for empty data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we get for this? (#7931) - data Emp deriving( Read ) -- No data constructors - -Here we want - read "[]" :: [Emp] to succeed, returning [] -So we do NOT want - instance Read Emp where - readPrec = error "urk" -Rather we want - instance Read Emp where - readPred = pfail -- Same as choose [] - -Because 'pfail' allows the parser to backtrack, but 'error' doesn't. -These instances are also useful for Read (Either Int Emp), where -we want to be able to parse (Left 3) just fine. --} - -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, BagDerivStuff) - -gen_Read_binds get_fixity loc tycon - = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) - where - ----------------------------------------------------------------------- - default_readlist - = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) - - default_readlistprec - = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) - ----------------------------------------------------------------------- - - data_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - - read_prec = mkHsVarBind loc readPrec_RDR rhs - where - rhs | null data_cons -- See Note [Read for empty data types] - = nlHsVar pfail_RDR - | otherwise - = nlHsApp (nlHsVar parens_RDR) - (foldr1 mk_alt (read_nullary_cons ++ - read_non_nullary_cons)) - - read_non_nullary_cons = map read_non_nullary_con non_nullary_cons - - read_nullary_cons - = case nullary_cons of - [] -> [] - [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] - _ -> [nlHsApp (nlHsVar choose_RDR) - (nlList (map mk_pair nullary_cons))] - -- NB For operators the parens around (:=:) are matched by the - -- enclosing "parens" call, so here we must match the naked - -- data_con_str con - - match_con con | isSym con_str = [symbol_pat con_str] - | otherwise = ident_h_pat con_str - where - con_str = data_con_str con - -- For nullary constructors we must match Ident s for normal constrs - -- and Symbol s for operators - - mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] - - read_non_nullary_con data_con - | is_infix = mk_parser infix_prec infix_stmts body - | is_record = mk_parser record_prec record_stmts body --- Using these two lines instead allows the derived --- read for infix and record bindings to read the prefix form --- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) --- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) - | otherwise = prefix_parser - where - body = result_expr data_con as_needed - con_str = data_con_str data_con - - prefix_parser = mk_parser prefix_prec prefix_stmts body - - read_prefix_con - | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] - | otherwise = ident_h_pat con_str - - read_infix_con - | isSym con_str = [symbol_pat con_str] - | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] - - prefix_stmts -- T a b c - = read_prefix_con ++ read_args - - infix_stmts -- a %% b, or a `T` b - = [read_a1] - ++ read_infix_con - ++ [read_a2] - - record_stmts -- T { f1 = a, f2 = b } - = read_prefix_con - ++ [read_punc "{"] - ++ concat (intersperse [read_punc ","] field_stmts) - ++ [read_punc "}"] - - field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed - - con_arity = dataConSourceArity data_con - labels = map flLabel $ dataConFieldLabels data_con - dc_nm = getName data_con - is_infix = dataConIsInfix data_con - is_record = labels `lengthExceeds` 0 - as_needed = take con_arity as_RDRs - read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) - (read_a1:read_a2:_) = read_args - - prefix_prec = appPrecedence - infix_prec = getPrecedence get_fixity dc_nm - record_prec = appPrecedence + 1 -- Record construction binds even more tightly - -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) - - ------------------------------------------------------------------------ - -- Helpers - ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 - mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) - , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] - con_app con as = nlHsVarApps (getRdrName con) as -- con as - result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) - - -- For constructors and field labels ending in '#', we hackily - -- let the lexer generate two tokens, and look for both in sequence - -- Thus [Ident "I"; Symbol "#"]. See #5041 - ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] - | otherwise = [ ident_pat s ] - - bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p - -- See Note [Use expectP] - ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") - symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") - read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") - - data_con_str con = occNameString (getOccName con) - - read_arg a ty = ASSERT( not (isUnliftedType ty) ) - noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) - - -- When reading field labels we might encounter - -- a = 3 - -- _a = 3 - -- or (#) = 4 - -- Note the parens! - read_field lbl a = - [noLoc - (mkBindStmt - (nlVarPat a) - (nlHsApp - read_field - (nlHsVarApps reset_RDR [readPrec_RDR]) - ) - ) - ] - where - lbl_str = unpackFS lbl - mk_read_field read_field_rdr lbl - = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] - read_field - | isSym lbl_str - = mk_read_field readSymField_RDR lbl_str - | Just (ss, '#') <- snocView lbl_str -- #14918 - = mk_read_field readFieldHash_RDR ss - | otherwise - = mk_read_field readField_RDR lbl_str - -{- -************************************************************************ -* * - Show instances -* * -************************************************************************ - -Example - - infixr 5 :^: - - data Tree a = Leaf a | Tree a :^: Tree a - - instance (Show a) => Show (Tree a) where - - showsPrec d (Leaf m) = showParen (d > app_prec) showStr - where - showStr = showString "Leaf " . showsPrec (app_prec+1) m - - showsPrec d (u :^: v) = showParen (d > up_prec) showStr - where - showStr = showsPrec (up_prec+1) u . - showString " :^: " . - showsPrec (up_prec+1) v - -- Note: right-associativity of :^: ignored - - up_prec = 5 -- Precedence of :^: - app_prec = 10 -- Application has precedence one more than - -- the most tightly-binding operator --} - -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, BagDerivStuff) - -gen_Show_binds get_fixity loc tycon - = (unitBag shows_prec, emptyBag) - where - data_cons = tyConDataCons tycon - shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) - comma_space = nlHsVar showCommaSpace_RDR - - pats_etc data_con - | nullary_con = -- skip the showParen junk... - ASSERT(null bs_needed) - ([nlWildPat, con_pat], mk_showString_app op_con_str) - | otherwise = - ([a_Pat, con_pat], - showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit - (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) - (nlHsPar (nested_compose_Expr show_thingies))) - where - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - bs_needed = take con_arity bs_RDRs - arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed - con_pat = nlConVarPat data_con_RDR bs_needed - nullary_con = con_arity == 0 - labels = map flLabel $ dataConFieldLabels data_con - lab_fields = length labels - record_syntax = lab_fields > 0 - - dc_nm = getName data_con - dc_occ_nm = getOccName data_con - con_str = occNameString dc_occ_nm - op_con_str = wrapOpParens con_str - backquote_str = wrapOpBackquotes con_str - - show_thingies - | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] - | record_syntax = mk_showString_app (op_con_str ++ " {") : - show_record_args ++ [mk_showString_app "}"] - | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args - - show_label l = mk_showString_app (nm ++ " = ") - -- Note the spaces around the "=" sign. If we - -- don't have them then we get Foo { x=-1 } and - -- the "=-" parses as a single lexeme. Only the - -- space after the '=' is necessary, but it - -- seems tidier to have them both sides. - where - nm = wrapOpParens (unpackFS l) - - show_args = zipWith show_arg bs_needed arg_tys - (show_arg1:show_arg2:_) = show_args - show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args - - -- Assumption for record syntax: no of fields == no of - -- labelled fields (and in same order) - show_record_args = concat $ - intersperse [comma_space] $ - [ [show_label lbl, arg] - | (lbl,arg) <- zipEqual "gen_Show_binds" - labels show_args ] - - show_arg :: RdrName -> Type -> LHsExpr GhcPs - show_arg b arg_ty - | isUnliftedType arg_ty - -- See Note [Deriving and unboxed types] in TcDerivInfer - = with_conv $ - nlHsApps compose_RDR - [mk_shows_app boxed_arg, mk_showString_app postfixMod] - | otherwise - = mk_showsPrec_app arg_prec arg - where - arg = nlHsVar b - boxed_arg = box "Show" arg arg_ty - postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty - with_conv expr - | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty = - nested_compose_Expr - [ mk_showString_app ("(" ++ conv ++ " ") - , expr - , mk_showString_app ")" - ] - | otherwise = expr - - -- Fixity stuff - is_infix = dataConIsInfix data_con - con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm - arg_prec | record_syntax = 0 -- Record fields don't need parens - | otherwise = con_prec_plus_one - -wrapOpParens :: String -> String -wrapOpParens s | isSym s = '(' : s ++ ")" - | otherwise = s - -wrapOpBackquotes :: String -> String -wrapOpBackquotes s | isSym s = s - | otherwise = '`' : s ++ "`" - -isSym :: String -> Bool -isSym "" = False -isSym (c : _) = startsVarSym c || startsConSym c - --- | showString :: String -> ShowS -mk_showString_app :: String -> LHsExpr GhcPs -mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) - --- | showsPrec :: Show a => Int -> a -> ShowS -mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs -mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] - --- | shows :: Show a => a -> ShowS -mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs -mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x - -getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer -getPrec is_infix get_fixity nm - | not is_infix = appPrecedence - | otherwise = getPrecedence get_fixity nm - -appPrecedence :: Integer -appPrecedence = fromIntegral maxPrecedence + 1 - -- One more than the precedence of the most - -- tightly-binding operator - -getPrecedence :: (Name -> Fixity) -> Name -> Integer -getPrecedence get_fixity nm - = case get_fixity nm of - Fixity _ x _assoc -> fromIntegral x - -- NB: the Report says that associativity is not taken - -- into account for either Read or Show; hence we - -- ignore associativity here - -{- -************************************************************************ -* * - Data instances -* * -************************************************************************ - -From the data type - - data T a b = T1 a b | T2 - -we generate - - $cT1 = mkDataCon $dT "T1" Prefix - $cT2 = mkDataCon $dT "T2" Prefix - $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] - -- the [] is for field labels. - - instance (Data a, Data b) => Data (T a b) where - gfoldl k z (T1 a b) = z T `k` a `k` b - gfoldl k z T2 = z T2 - -- ToDo: add gmapT,Q,M, gfoldr - - gunfold k z c = case conIndex c of - I# 1# -> k (k (z T1)) - I# 2# -> z T2 - - toConstr (T1 _ _) = $cT1 - toConstr T2 = $cT2 - - dataTypeOf _ = $dT - - dataCast1 = gcast1 -- If T :: * -> * - dataCast2 = gcast2 -- if T :: * -> * -> * --} - -gen_Data_binds :: SrcSpan - -> TyCon -- For data families, this is the - -- *representation* TyCon - -> TcM (LHsBinds GhcPs, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_Data_binds loc rep_tc - = do { dflags <- getDynFlags - - -- Make unique names for the data type and constructor - -- auxiliary bindings. Start with the name of the TyCon/DataCon - -- but that might not be unique: see #12245. - ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc)) - ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName) - (tyConDataCons rep_tc) - ; let dt_rdr = mkRdrUnqual dt_occ - dc_rdrs = map mkRdrUnqual dc_occs - - -- OK, now do the work - ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) } - -gen_data :: DynFlags -> RdrName -> [RdrName] - -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_data dflags data_type_name constr_names loc rep_tc - = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] - `unionBags` gcast_binds, - -- Auxiliary definitions: the data type and constructors - listToBag ( genDataTyCon - : zipWith genDataDataCon data_cons constr_names ) ) - where - data_cons = tyConDataCons rep_tc - n_cons = length data_cons - one_constr = n_cons == 1 - genDataTyCon :: DerivStuff - genDataTyCon -- $dT - = DerivHsBind (mkHsVarBind loc data_type_name rhs, - L loc (TypeSig noExtField [L loc data_type_name] sig_ty)) - - sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) - rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) - `nlHsApp` nlList (map nlHsVar constr_names) - - genDataDataCon :: DataCon -> RdrName -> DerivStuff - genDataDataCon dc constr_name -- $cT1 etc - = DerivHsBind (mkHsVarBind loc constr_name rhs, - L loc (TypeSig noExtField [L loc constr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) - rhs = nlHsApps mkConstr_RDR constr_args - - constr_args - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar (data_type_name) -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- String name - , nlList labels -- Field labels - , nlHsVar fixity ] -- Fixity - - labels = map (nlHsLit . mkHsString . unpackFS . flLabel) - (dataConFieldLabels dc) - dc_occ = getOccName dc - is_infix = isDataSymOcc dc_occ - fixity | is_infix = infix_RDR - | otherwise = prefix_RDR - - ------------ gfoldl - gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) - - gfoldl_eqn con - = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], - foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) - where - con_name :: RdrName - con_name = getRdrName con - as_needed = take (dataConSourceArity con) as_RDRs - mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) - - ------------ gunfold - gunfold_bind = mkSimpleGeneratedFunBind loc - gunfold_RDR - [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] - gunfold_rhs - - gunfold_rhs - | one_constr = mk_unfold_rhs (head data_cons) -- No need for case - | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) - (map gunfold_alt data_cons) - - gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) - mk_unfold_rhs dc = foldr nlHsApp - (z_Expr `nlHsApp` nlHsVar (getRdrName dc)) - (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) - - mk_unfold_pat dc -- Last one is a wild-pat, to avoid - -- redundant test, and annoying warning - | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor - | otherwise = nlConPat intDataCon_RDR - [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] - where - tag = dataConTag dc - - ------------ toConstr - toCon_bind = mkFunBindEC 1 loc toConstr_RDR id - (zipWith to_con_eqn data_cons constr_names) - to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) - - ------------ dataTypeOf - dataTypeOf_bind = mkSimpleGeneratedFunBind - loc - dataTypeOf_RDR - [nlWildPat] - (nlHsVar data_type_name) - - ------------ gcast1/2 - -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * - -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * - -- (or nothing if T has neither of these two types) - - -- But care is needed for data families: - -- If we have data family D a - -- data instance D (a,b,c) = A | B deriving( Data ) - -- and we want instance ... => Data (D [(a,b,c)]) where ... - -- then we need dataCast1 x = gcast1 x - -- because D :: * -> * - -- even though rep_tc has kind * -> * -> * -> * - -- Hence looking for the kind of fam_tc not rep_tc - -- See #4896 - tycon_kind = case tyConFamInst_maybe rep_tc of - Just (fam_tc, _) -> tyConKind fam_tc - Nothing -> tyConKind rep_tc - gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR - | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR - | otherwise = emptyBag - mk_gcast dataCast_RDR gcast_RDR - = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] - (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) - - -kind1, kind2 :: Kind -kind1 = typeToTypeKind -kind2 = liftedTypeKind `mkVisFunTy` kind1 - -gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, - mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, - dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, - constr_RDR, dataType_RDR, - eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , - eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , - eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , - eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , - eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , - eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , - eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, - eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , - eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , - eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, - extendWord8_RDR, extendInt8_RDR, - extendWord16_RDR, extendInt16_RDR :: RdrName -gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") -gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") -toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") -dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") -dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") -gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") -gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") -mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") -constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") -mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") -dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") -conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") -prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") -infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") - -eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") -ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") -leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") -gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") -geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") - -eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") -ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) -leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") -gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) -geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") - -eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#") -ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" ) -leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") -gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) -geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") - -eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") -ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) -leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") -gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) -geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") - -eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") -ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") -leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") -gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") -geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") - -eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") -ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) -leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") -gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) -geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") - -eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") -ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) -leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") -gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) -geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") - -eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") -ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") -leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") -gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") -geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") - -eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") -ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") -leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") -gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") -geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") - -eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") -ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) -leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") -gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) -geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") - -extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#") -extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") - -extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") -extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") - - -{- -************************************************************************ -* * - Lift instances -* * -************************************************************************ - -Example: - - data Foo a = Foo a | a :^: a deriving Lift - - ==> - - instance (Lift a) => Lift (Foo a) where - lift (Foo a) = [| Foo a |] - lift ((:^:) u v) = [| (:^:) u v |] - - liftTyped (Foo a) = [|| Foo a ||] - liftTyped ((:^:) u v) = [|| (:^:) u v ||] --} - - -gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) - where - lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) - (map (pats_etc mk_exp) data_cons) - liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) - (map (pats_etc mk_texp) data_cons) - - mk_exp = ExpBr noExtField - mk_texp = TExpBr noExtField - data_cons = tyConDataCons tycon - - pats_etc mk_bracket data_con - = ([con_pat], lift_Expr) - where - con_pat = nlConVarPat data_con_RDR as_needed - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - as_needed = take con_arity as_RDRs - lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) - br_body = nlHsApps (Exact (dataConName data_con)) - (map nlHsVar as_needed) - -{- -************************************************************************ -* * - Newtype-deriving instances -* * -************************************************************************ - -Note [Newtype-deriving instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take every method in the original instance and `coerce` it to fit -into the derived instance. We need type applications on the argument -to `coerce` to make it obvious what instantiation of the method we're -coercing from. So from, say, - - class C a b where - op :: forall c. a -> [b] -> c -> Int - - newtype T x = MkT - - instance C a => C a (T x) where - op = coerce @ (a -> [] -> c -> Int) - @ (a -> [T x] -> c -> Int) - op :: forall c. a -> [T x] -> c -> Int - -In addition to the type applications, we also have an explicit -type signature on the entire RHS. This brings the method-bound variable -`c` into scope over the two type applications. -See Note [GND and QuantifiedConstraints] for more information on why this -is important. - -Giving 'coerce' two explicitly-visible type arguments grants us finer control -over how it should be instantiated. Recall - - coerce :: Coercible a b => a -> b - -By giving it explicit type arguments we deal with the case where -'op' has a higher rank type, and so we must instantiate 'coerce' with -a polytype. E.g. - - class C a where op :: a -> forall b. b -> b - newtype T x = MkT - instance C => C (T x) where - op = coerce @ ( -> forall b. b -> b) - @ (T x -> forall b. b -> b) - op :: T x -> forall b. b -> b - -The use of type applications is crucial here. If we had tried using only -explicit type signatures, like so: - - instance C => C (T x) where - op = coerce (op :: -> forall b. b -> b) - :: T x -> forall b. b -> b - -Then GHC will attempt to deeply skolemize the two type signatures, which will -wreak havoc with the Coercible solver. Therefore, we instead use type -applications, which do not deeply skolemize and thus avoid this issue. -The downside is that we currently require -XImpredicativeTypes to permit this -polymorphic type instantiation, so we have to switch that flag on locally in -TcDeriv.genInst. See #8503 for more discussion. - -Note [Newtype-deriving trickiness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12768): - class C a where { op :: D a => a -> a } - - instance C a => C [a] where { op = opList } - - opList :: (C a, D [a]) => [a] -> [a] - opList = ... - -Now suppose we try GND on this: - newtype N a = MkN [a] deriving( C ) - -The GND is expecting to get an implementation of op for N by -coercing opList, thus: - - instance C a => C (N a) where { op = opN } - - opN :: (C a, D (N a)) => N a -> N a - opN = coerce @([a] -> [a]) - @([N a] -> [N a] - opList :: D (N a) => [N a] -> [N a] - -But there is no reason to suppose that (D [a]) and (D (N a)) -are inter-coercible; these instances might completely different. -So GHC rightly rejects this code. - -Note [GND and QuantifiedConstraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example from #15290: - - class C m where - join :: m (m a) -> m a - - newtype T m a = MkT (m a) - - deriving instance - (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) - -The code that GHC used to generate for this was: - - instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) where - join = coerce @(forall a. m (m a) -> m a) - @(forall a. T m (T m a) -> T m a) - join - -This instantiates `coerce` at a polymorphic type, a form of impredicative -polymorphism, so we're already on thin ice. And in fact the ice breaks, -as we'll explain: - -The call to `coerce` gives rise to: - - Coercible (forall a. m (m a) -> m a) - (forall a. T m (T m a) -> T m a) - -And that simplified to the following implication constraint: - - forall a . m (T m a) ~R# m (m a) - -But because this constraint is under a `forall`, inside a type, we have to -prove it *without computing any term evidence* (hence the ). Alas, we -*must* generate a term-level evidence binding in order to instantiate the -quantified constraint! In response, GHC currently chooses not to use such -a quantified constraint. -See Note [Instances in no-evidence implications] in TcInteract. - -But this isn't the death knell for combining QuantifiedConstraints with GND. -On the contrary, if we generate GND bindings in a slightly different way, then -we can avoid this situation altogether. Instead of applying `coerce` to two -polymorphic types, we instead let an explicit type signature do the polymorphic -instantiation, and omit the `forall`s in the type applications. -More concretely, we generate the following code instead: - - instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) where - join = coerce @( m (m a) -> m a) - @(T m (T m a) -> T m a) - join :: forall a. T m (T m a) -> T m a - -Now the visible type arguments are both monotypes, so we need do any of this -funny quantified constraint instantiation business. - -You might think that that second @(T m (T m a) -> T m a) argument is redundant -in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type -signature, but in fact leaving it off will break this example (from the -T15290d test case): - - class C a where - c :: Int -> forall b. b -> a - - instance C Int - - instance C Age where - c = coerce @(Int -> forall b. b -> Int) - c :: Int -> forall b. b -> Age - -That is because the explicit type signature deeply skolemizes the forall-bound -`b`, which wreaks havoc with the `Coercible` solver. An additional visible type -argument of @(Int -> forall b. b -> Age) is enough to prevent this. - -Be aware that the use of an explicit type signature doesn't /solve/ this -problem; it just makes it less likely to occur. For example, if a class has -a truly higher-rank type like so: - - class CProblem m where - op :: (forall b. ... (m b) ...) -> Int - -Then the same situation will arise again. But at least it won't arise for the -common case of methods with ordinary, prenex-quantified types. - -Note [GND and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~ -We make an effort to make the code generated through GND be robust w.r.t. -ambiguous type variables. As one example, consider the following example -(from #15637): - - class C a where f :: String - instance C () where f = "foo" - newtype T = T () deriving C - -A naïve attempt and generating a C T instance would be: - - instance C T where - f = coerce @String @String f - :: String - -This isn't going to typecheck, however, since GHC doesn't know what to -instantiate the type variable `a` with in the call to `f` in the method body. -(Note that `f :: forall a. String`!) To compensate for the possibility of -ambiguity here, we explicitly instantiate `a` like so: - - instance C T where - f = coerce @String @String (f @()) - :: String - -All better now. --} - -gen_Newtype_binds :: SrcSpan - -> Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> TcM (LHsBinds GhcPs, BagDerivStuff) --- See Note [Newtype-deriving instances] -gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty - = do let ats = classATs cls - atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) - mapM mk_atf_inst ats - return ( listToBag $ map mk_bind (classMethods cls) - , listToBag $ map DerivFamInst atf_insts ) - where - mk_bind :: Id -> LHsBind GhcPs - mk_bind meth_id - = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch - (mkPrefixFunRhs (L loc meth_RDR)) - [] rhs_expr] - where - Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id - (_, _, from_tau) = tcSplitSigmaTy from_ty - (_, _, to_tau) = tcSplitSigmaTy to_ty - - meth_RDR = getRdrName meth_id - - rhs_expr = nlHsVar (getRdrName coerceId) - `nlHsAppType` from_tau - `nlHsAppType` to_tau - `nlHsApp` meth_app - `nlExprWithTySig` to_ty - - -- The class method, applied to all of the class instance types - -- (including the representation type) to avoid potential ambiguity. - -- See Note [GND and ambiguity] - meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $ - filterOutInferredTypes (classTyCon cls) underlying_inst_tys - -- Filter out any inferred arguments, since they can't be - -- applied with visible type application. - - mk_atf_inst :: TyCon -> TcM FamInst - mk_atf_inst fam_tc = do - rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) - rep_lhs_tys - let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' - fam_tc rep_lhs_tys rep_rhs_ty - -- Check (c) from Note [GND and associated type families] in TcDeriv - checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) - newFamInst SynFamilyInst axiom - where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_env = zipTyEnv cls_tvs inst_tys - lhs_subst = mkTvSubst in_scope lhs_env - rhs_env = zipTyEnv cls_tvs underlying_inst_tys - rhs_subst = mkTvSubst in_scope rhs_env - fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs - rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys - rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys - (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs - rep_tvs' = scopedSort rep_tvs - rep_cvs' = scopedSort rep_cvs - - -- Same as inst_tys, but with the last argument type replaced by the - -- representation type. - underlying_inst_tys :: [Type] - underlying_inst_tys = changeLast inst_tys rhs_ty - -nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) - where - hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) - -nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty - where - hs_ty = mkLHsSigWcType (typeToLHsType s) - -mkCoerceClassMethEqn :: Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> Id -- the method to look at - -> Pair Type --- See Note [Newtype-deriving instances] --- See also Note [Newtype-deriving trickiness] --- The pair is the (from_type, to_type), where to_type is --- the type of the method we are trying to get -mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id - = Pair (substTy rhs_subst user_meth_ty) - (substTy lhs_subst user_meth_ty) - where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) - rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) - (_class_tvs, _class_constraint, user_meth_ty) - = tcSplitMethodTy (varType id) - -{- -************************************************************************ -* * -\subsection{Generating extra binds (@con2tag@ and @tag2con@)} -* * -************************************************************************ - -\begin{verbatim} -data Foo ... = ... - -con2tag_Foo :: Foo ... -> Int# -tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unlifted) -\end{verbatim} - -The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) -fiddling around. --} - -genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec - -> (LHsBind GhcPs, LSig GhcPs) -genAuxBindSpec dflags loc (DerivCon2Tag tycon) - = (mkFunBindSE 0 loc rdr_name eqns, - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - rdr_name = con2tag_RDR dflags tycon - - sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ - mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ - mkParentType tycon `mkVisFunTy` intPrimTy - - lots_of_constructors = tyConFamilySize tycon > 8 - -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS - -- but we don't do vectored returns any more. - - eqns | lots_of_constructors = [get_tag_eqn] - | otherwise = map mk_eqn (tyConDataCons tycon) - - get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) - - mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) - mk_eqn con = ([nlWildConPat con], - nlHsLit (HsIntPrim NoSourceText - (toInteger ((dataConTag con) - fIRST_TAG)))) - -genAuxBindSpec dflags loc (DerivTag2Con tycon) - = (mkFunBindSE 0 loc rdr_name - [([nlConVarPat intDataCon_RDR [a_RDR]], - nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType $ L loc $ - XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ - intTy `mkVisFunTy` mkParentType tycon - - rdr_name = tag2con_RDR dflags tycon - -genAuxBindSpec dflags loc (DerivMaxTag tycon) - = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - rdr_name = maxtag_RDR dflags tycon - sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) - rhs = nlHsApp (nlHsVar intDataCon_RDR) - (nlHsLit (HsIntPrim NoSourceText max_tag)) - max_tag = case (tyConDataCons tycon) of - data_cons -> toInteger ((length data_cons) - fIRST_TAG) - -type SeparateBagsDerivStuff = - -- AuxBinds and SYB bindings - ( Bag (LHsBind GhcPs, LSig GhcPs) - -- Extra family instances (used by Generic and DeriveAnyClass) - , Bag (FamInst) ) - -genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff -genAuxBinds dflags loc b = genAuxBinds' b2 where - (b1,b2) = partitionBagWith splitDerivAuxBind b - splitDerivAuxBind (DerivAuxBind x) = Left x - splitDerivAuxBind x = Right x - - rm_dups = foldr dup_check emptyBag - dup_check a b = if anyBag (== a) b then b else consBag a b - - genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff - genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) - , emptyBag ) - f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff - f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before - f (DerivHsBind b) = add1 b - f (DerivFamInst t) = add2 t - - add1 x (a,b) = (x `consBag` a,b) - add2 x (a,b) = (a,x `consBag` b) - -mkParentType :: TyCon -> Type --- Turn the representation tycon of a family into --- a use of its family constructor -mkParentType tc - = case tyConFamInst_maybe tc of - Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) - Just (fam_tc,tys) -> mkTyConApp fam_tc tys - -{- -************************************************************************ -* * -\subsection{Utility bits for generating bindings} -* * -************************************************************************ --} - --- | Make a function binding. If no equations are given, produce a function --- with the given arity that produces a stock error. -mkFunBindSE :: Arity -> SrcSpan -> RdrName - -> [([LPat GhcPs], LHsExpr GhcPs)] - -> LHsBind GhcPs -mkFunBindSE arity loc fun pats_and_exprs - = mkRdrFunBindSE arity (L loc fun) matches - where - matches = [mkMatch (mkPrefixFunRhs (L loc fun)) - (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) - | (p,e) <-pats_and_exprs] - -mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] - -> LHsBind GhcPs -mkRdrFunBind fun@(L loc _fun_rdr) matches - = L loc (mkFunBind Generated fun matches) - --- | Make a function binding. If no equations are given, produce a function --- with the given arity that uses an empty case expression for the last --- argument that is passes to the given function to produce the right-hand --- side. -mkFunBindEC :: Arity -> SrcSpan -> RdrName - -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> [([LPat GhcPs], LHsExpr GhcPs)] - -> LHsBind GhcPs -mkFunBindEC arity loc fun catch_all pats_and_exprs - = mkRdrFunBindEC arity catch_all (L loc fun) matches - where - matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) - (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) - | (p,e) <- pats_and_exprs ] - --- | Produces a function binding. When no equations are given, it generates --- a binding of the given arity and an empty case expression --- for the last argument that it passes to the given function to produce --- the right-hand side. -mkRdrFunBindEC :: Arity - -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> Located RdrName - -> [LMatch GhcPs (LHsExpr GhcPs)] - -> LHsBind GhcPs -mkRdrFunBindEC arity catch_all - fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') - where - -- Catch-all eqn looks like - -- fmap _ z = case z of {} - -- or - -- traverse _ z = pure (case z of) - -- or - -- foldMap _ z = mempty - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See #4302 - matches' = if null matches - then [mkMatch (mkPrefixFunRhs fun) - (replicate (arity - 1) nlWildPat ++ [z_Pat]) - (catch_all $ nlHsCase z_Expr []) - (noLoc emptyLocalBinds)] - else matches - --- | Produces a function binding. When there are no equations, it generates --- a binding with the given arity that produces an error based on the name of --- the type of the last argument. -mkRdrFunBindSE :: Arity -> Located RdrName -> - [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs -mkRdrFunBindSE arity - fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') - where - -- Catch-all eqn looks like - -- compare _ _ = error "Void compare" - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See #4302 - matches' = if null matches - then [mkMatch (mkPrefixFunRhs fun) - (replicate arity nlWildPat) - (error_Expr str) (noLoc emptyLocalBinds)] - else matches - str = "Void " ++ occNameString (rdrNameOcc fun_rdr) - - -box :: String -- The class involved - -> LHsExpr GhcPs -- The argument - -> Type -- The argument type - -> LHsExpr GhcPs -- Boxed version of the arg --- See Note [Deriving and unboxed types] in TcDerivInfer -box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg - ---------------------- -primOrdOps :: String -- The class involved - -> Type -- The type - -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) --- See Note [Deriving and unboxed types] in TcDerivInfer -primOrdOps str ty = assoc_ty_id str ordOpTbl ty - -ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -ordOpTbl - = [(charPrimTy , (ltChar_RDR , leChar_RDR - , eqChar_RDR , geChar_RDR , gtChar_RDR )) - ,(intPrimTy , (ltInt_RDR , leInt_RDR - , eqInt_RDR , geInt_RDR , gtInt_RDR )) - ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR - , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) - ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR - , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) - ,(wordPrimTy , (ltWord_RDR , leWord_RDR - , eqWord_RDR , geWord_RDR , gtWord_RDR )) - ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR - , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) - ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR - , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) - ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR - , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) - ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR - , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) - ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR - , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] - --- A mapping from a primitive type to a function that constructs its boxed --- version. --- NOTE: Int8#/Word8# will become Int/Word. -boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] -boxConTbl = - [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon)) - , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon)) - , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) - , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) - , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) - , (int8PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar extendInt8_RDR)) - , (word8PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord8_RDR)) - , (int16PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar extendInt16_RDR)) - , (word16PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord16_RDR)) - ] - - --- | A table of postfix modifiers for unboxed values. -postfixModTbl :: [(Type, String)] -postfixModTbl - = [(charPrimTy , "#" ) - ,(intPrimTy , "#" ) - ,(wordPrimTy , "##") - ,(floatPrimTy , "#" ) - ,(doublePrimTy, "##") - ,(int8PrimTy, "#") - ,(word8PrimTy, "##") - ,(int16PrimTy, "#") - ,(word16PrimTy, "##") - ] - -primConvTbl :: [(Type, String)] -primConvTbl = - [ (int8PrimTy, "narrowInt8#") - , (word8PrimTy, "narrowWord8#") - , (int16PrimTy, "narrowInt16#") - , (word16PrimTy, "narrowWord16#") - ] - -litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] -litConTbl - = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) - ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) - . nlHsApp (nlHsApp - (nlHsVar map_RDR) - (compose_RDR `nlHsApps` - [ nlHsVar fromIntegral_RDR - , nlHsVar fromEnum_RDR - ]))) - ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ] - --- | Lookup `Type` in an association list. -assoc_ty_id :: HasCallStack => String -- The class involved - -> [(Type,a)] -- The table - -> Type -- The type - -> a -- The result of the lookup -assoc_ty_id cls_str tbl ty - | Just a <- assoc_ty_id_maybe tbl ty = a - | otherwise = - pprPanic "Error in deriving:" - (text "Can't derive" <+> text cls_str <+> - text "for primitive type" <+> ppr ty) - --- | Lookup `Type` in an association list. -assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a -assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl - ------------------------------------------------------------------------ - -and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -and_Expr a b = genOpApp a and_RDR b - ------------------------------------------------------------------------ - -eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -eq_Expr ty a b - | not (isUnliftedType ty) = genOpApp a eq_RDR b - | otherwise = genPrimOpApp a prim_eq b - where - (_, _, prim_eq, _, _) = primOrdOps "Eq" ty - -untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] - -> LHsExpr GhcPs -> LHsExpr GhcPs -untag_Expr _ _ [] expr = expr -untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr - = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) - [untag_this])) {-of-} - [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] - -enum_from_to_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs -enum_from_then_to_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs - -enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 -enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 - -showParen_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs - -showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 - -nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs - -nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty -nested_compose_Expr [e] = parenify e -nested_compose_Expr (e:es) - = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) - --- impossible_Expr is used in case RHSs that should never happen. --- We generate these to keep the desugarer from complaining that they *might* happen! -error_Expr :: String -> LHsExpr GhcPs -error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) - --- illegal_Expr is used when signalling error conditions in the RHS of a derived --- method. It is currently only used by Enum.{succ,pred} -illegal_Expr :: String -> String -> String -> LHsExpr GhcPs -illegal_Expr meth tp msg = - nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) - --- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you --- to include the value of a_RDR in the error string. -illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs -illegal_toEnum_tag tp maxtag = - nlHsApp (nlHsVar error_RDR) - (nlHsApp (nlHsApp (nlHsVar append_RDR) - (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar a_RDR)) - (nlHsApp (nlHsApp - (nlHsVar append_RDR) - (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar maxtag)) - (nlHsLit (mkHsString ")")))))) - -parenify :: LHsExpr GhcPs -> LHsExpr GhcPs -parenify e@(L _ (HsVar _ _)) = e -parenify e = mkHsPar e - --- genOpApp wraps brackets round the operator application, so that the --- renamer won't subsequently try to re-associate it. -genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs -genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) - -genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs -genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) - -a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR - :: RdrName -a_RDR = mkVarUnqual (fsLit "a") -b_RDR = mkVarUnqual (fsLit "b") -c_RDR = mkVarUnqual (fsLit "c") -d_RDR = mkVarUnqual (fsLit "d") -f_RDR = mkVarUnqual (fsLit "f") -k_RDR = mkVarUnqual (fsLit "k") -z_RDR = mkVarUnqual (fsLit "z") -ah_RDR = mkVarUnqual (fsLit "a#") -bh_RDR = mkVarUnqual (fsLit "b#") -ch_RDR = mkVarUnqual (fsLit "c#") -dh_RDR = mkVarUnqual (fsLit "d#") - -as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] - -a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, - true_Expr, pure_Expr :: LHsExpr GhcPs -a_Expr = nlHsVar a_RDR -b_Expr = nlHsVar b_RDR -c_Expr = nlHsVar c_RDR -z_Expr = nlHsVar z_RDR -ltTag_Expr = nlHsVar ltTag_RDR -eqTag_Expr = nlHsVar eqTag_RDR -gtTag_Expr = nlHsVar gtTag_RDR -false_Expr = nlHsVar false_RDR -true_Expr = nlHsVar true_RDR -pure_Expr = nlHsVar pure_RDR - -a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs -a_Pat = nlVarPat a_RDR -b_Pat = nlVarPat b_RDR -c_Pat = nlVarPat c_RDR -d_Pat = nlVarPat d_RDR -k_Pat = nlVarPat k_RDR -z_Pat = nlVarPat z_RDR - -minusInt_RDR, tagToEnum_RDR :: RdrName -minusInt_RDR = getRdrName (primOpId IntSubOp ) -tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) - -con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName --- Generates Orig s RdrName, for the binding positions -con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc -tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc -maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc - -mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName -mk_tc_deriv_name dflags tycon occ_fun = - mkAuxBinderName dflags (tyConName tycon) occ_fun - -mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName --- ^ Make a top-level binder name for an auxiliary binding for a parent name --- See Note [Auxiliary binders] -mkAuxBinderName dflags parent occ_fun - = mkRdrUnqual (occ_fun stable_parent_occ) - where - stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string - stable_string - | hasPprDebug dflags = parent_stable - | otherwise = parent_stable_hash - parent_stable = nameStableString parent - parent_stable_hash = - let Fingerprint high low = fingerprintString parent_stable - in toBase62 high ++ toBase62Padded low - -- See Note [Base 62 encoding 128-bit integers] in Encoding - parent_occ = nameOccName parent - - -{- -Note [Auxiliary binders] -~~~~~~~~~~~~~~~~~~~~~~~~ -We often want to make a top-level auxiliary binding. E.g. for comparison we haev - - instance Ord T where - compare a b = $con2tag a `compare` $con2tag b - - $con2tag :: T -> Int - $con2tag = ...code.... - -Of course these top-level bindings should all have distinct name, and we are -generating RdrNames here. We can't just use the TyCon or DataCon to distinguish -because with standalone deriving two imported TyCons might both be called T! -(See #7947.) - -So we use package name, module name and the name of the parent -(T in this example) as part of the OccName we generate for the new binding. -To make the symbol names short we take a base62 hash of the full name. - -In the past we used the *unique* from the parent, but that's not stable across -recompilations as uniques are nondeterministic. --} diff --git a/typecheck/TcGenFunctor.hs b/typecheck/TcGenFunctor.hs deleted file mode 100644 --- a/typecheck/TcGenFunctor.hs +++ /dev/null @@ -1,1293 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Functor, Foldable, and Traversable classes -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module TcGenFunctor ( - FFoldType(..), functorLikeTraverse, - deepSubtypesContaining, foldDataConArgs, - - gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds - ) where - -import GhcPrelude - -import Bag -import DataCon -import FastString -import GHC.Hs -import Panic -import PrelNames -import RdrName -import SrcLoc -import State -import TcGenDeriv -import TcType -import TyCon -import TyCoRep -import Type -import Util -import Var -import VarSet -import MkId (coerceId) -import TysWiredIn (true_RDR, false_RDR) - -import Data.Maybe (catMaybes, isJust) - -{- -************************************************************************ -* * - Functor instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -For the data type: - - data T a = T1 Int a | T2 (T a) - -We generate the instance: - - instance Functor T where - fmap f (T1 b1 a) = T1 b1 (f a) - fmap f (T2 ta) = T2 (fmap f ta) - -Notice that we don't simply apply 'fmap' to the constructor arguments. -Rather - - Do nothing to an argument whose type doesn't mention 'a' - - Apply 'f' to an argument of type 'a' - - Apply 'fmap f' to other arguments -That's why we have to recurse deeply into the constructor argument types, -rather than just one level, as we typically do. - -What about types with more than one type parameter? In general, we only -derive Functor for the last position: - - data S a b = S1 [b] | S2 (a, T a b) - instance Functor (S a) where - fmap f (S1 bs) = S1 (fmap f bs) - fmap f (S2 (p,q)) = S2 (a, fmap f q) - -However, we have special cases for - - tuples - - functions - -More formally, we write the derivation of fmap code over type variable -'a for type 'b as ($fmap 'a 'b). In this general notation the derived -instance for T is: - - instance Functor T where - fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) - fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) - - $(fmap 'a 'b) = \x -> x -- when b does not contain a - $(fmap 'a 'a) = f - $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2) - $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2 - $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b)) - -For functions, the type parameter 'a can occur in a contravariant position, -which means we need to derive a function like: - - cofmap :: (a -> b) -> (f b -> f a) - -This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case: - - $(cofmap 'a 'b) = \x -> x -- when b does not contain a - $(cofmap 'a 'a) = error "type variable in contravariant position" - $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) - $(cofmap 'a '[b]) = map $(cofmap 'a 'b) - $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2 - $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b)) - -Note that the code produced by $(fmap _ _) is always a higher order function, -with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern -matching on the type, this means create a lambda function (see the (,) case above). -The resulting code for fmap can look a bit weird, for example: - - data X a = X (a,Int) - -- generated instance - instance Functor X where - fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x - -The optimizer should be able to simplify this code by simple inlining. - -An older version of the deriving code tried to avoid these applied -lambda functions by producing a meta level function. But the function to -be mapped, `f`, is a function on the code level, not on the meta level, -so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion. -It is better to produce too many lambdas than to eta expand, see ticket #7436. --} - -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the argument is phantom, we can use fmap _ = coerce --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Functor_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag fmap_bind, emptyBag) - where - fmap_name = L loc fmap_RDR - fmap_bind = mkRdrFunBind fmap_name fmap_eqns - fmap_eqns = [mkSimpleMatch fmap_match_ctxt - [nlWildPat] - coerce_Expr] - fmap_match_ctxt = mkPrefixFunRhs fmap_name - -gen_Functor_binds loc tycon - = (listToBag [fmap_bind, replace_bind], emptyBag) - where - data_cons = tyConDataCons tycon - fmap_name = L loc fmap_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns - fmap_match_ctxt = mkPrefixFunRhs fmap_name - - fmap_eqn con = flip evalState bs_RDRs $ - match_for_con fmap_match_ctxt [f_Pat] con =<< parts - where - parts = sequence $ foldDataConArgs ft_fmap con - - fmap_eqns = map fmap_eqn data_cons - - ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs)) - ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x - -- fmap f = \x -> x - , ft_var = return f_Expr - -- fmap f = f - , ft_fun = \g h -> do - gg <- g - hh <- h - mkSimpleLam2 $ \x b -> return $ - nlHsApp hh (nlHsApp x (nlHsApp gg b)) - -- fmap f = \x b -> h (x (g b)) - , ft_tup = \t gs -> do - gg <- sequence gs - mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg - -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g - -- fmap f = fmap g - , ft_forall = \_ g -> g - , ft_bad_app = panic "in other argument in ft_fmap" - , ft_co_var = panic "contravariant in ft_fmap" } - - -- See Note [Deriving <$] - replace_name = L loc replace_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns - replace_match_ctxt = mkPrefixFunRhs replace_name - - replace_eqn con = flip evalState bs_RDRs $ - match_for_con replace_match_ctxt [z_Pat] con =<< parts - where - parts = traverse (fmap replace) $ foldDataConArgs ft_replace con - - replace_eqns = map replace_eqn data_cons - - ft_replace :: FFoldType (State [RdrName] Replacer) - ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x - -- (p <$) = \x -> x - , ft_var = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr - -- (p <$) = const p - , ft_fun = \g h -> do - gg <- replace <$> g - hh <- replace <$> h - fmap Nested $ mkSimpleLam2 $ \x b -> return $ - nlHsApp hh (nlHsApp x (nlHsApp gg b)) - -- (<$) p = \x b -> h (x (g b)) - , ft_tup = \t gs -> do - gg <- traverse (fmap replace) gs - fmap Nested . mkSimpleLam $ - mkSimpleTupleCase (match_for_con CaseAlt) t gg - -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ gm -> do - g <- gm - case g of - Nested g' -> pure . Nested $ - nlHsApp fmap_Expr $ g' - Immediate _ -> pure . Nested $ - nlHsApp replace_Expr z_Expr - -- (p <$) = fmap (p <$) - , ft_forall = \_ g -> g - , ft_bad_app = panic "in other argument in ft_replace" - , ft_co_var = panic "contravariant in ft_replace" } - - -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - match_for_con :: HsMatchContext RdrName - -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs] - -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) - match_for_con ctxt = mkSimpleConMatch ctxt $ - \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 .. - --- See Note [Deriving <$] -data Replacer = Immediate {replace :: LHsExpr GhcPs} - | Nested {replace :: LHsExpr GhcPs} - -{- Note [Deriving <$] - ~~~~~~~~~~~~~~~~~~ - -We derive the definition of <$. Allowing this to take the default definition -can lead to memory leaks: mapping over a structure with a constant function can -fill the result structure with trivial thunks that retain the values from the -original structure. The simplifier seems to handle this all right for simple -types, but not for recursive ones. Consider - -data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor - --- fmap _ Tip = Tip --- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) - -Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that -simplifies no further. Why is that? `fmap` is defined recursively, so GHC -cannot inline it. The static argument transformation would turn the definition -into a non-recursive one - --- fmap f = go where --- go Tip = Tip --- go (Bin l v r) = Bin (go l) (f v) (go r) - -which GHC could inline, producing an efficient definion of `<$`. But there are -several problems. First, GHC does not perform the static argument transformation -by default, even with -O2. Second, even when it does perform the static argument -transformation, it does so only when there are at least two static arguments, -which is not the case for fmap. Finally, when the type in question is -non-regular, such as - -data Nesty a = Z a | S (Nesty a) (Nest (a, a)) - -the function argument is no longer (entirely) static, so the static argument -transformation will do nothing for us. - -Applying the default definition of `<$` will produce a tree full of thunks that -look like ((\_ -> x) x0), which represents unnecessary thunk allocation and -also retention of the previous value, potentially leaking memory. Instead, we -derive <$ separately. Two aspects are different from fmap: the case of the -sought type variable (ft_var) and the case of a type application (ft_ty_app). -The interesting one is ft_ty_app. We have to distinguish two cases: the -"immediate" case where the type argument *is* the sought type variable, and -the "nested" case where the type argument *contains* the sought type variable. - -The immediate case: - -Suppose we have - -data Imm a = Imm (F ... a) - -Then we want to define - -x <$ Imm q = Imm (x <$ q) - -The nested case: - -Suppose we have - -data Nes a = Nes (F ... (G a)) - -Then we want to define - -x <$ Nes q = Nes (fmap (x <$) q) - -We use the Replacer type to tag whether the expression derived for applying -<$ to the last type variable was the ft_var case (immediate) or one of the -others (letting ft_forall pass through as usual). - -We could, but do not, give tuples special treatment to improve efficiency -in some cases. Suppose we have - -data Nest a = Z a | S (Nest (a,a)) - -The optimal definition would be - -x <$ Z _ = Z x -x <$ S t = S ((x, x) <$ t) - -which produces a result with maximal internal sharing. The reason we do not -attempt to treat this case specially is that we have no way to give -user-provided tuple-like types similar treatment. If the user changed the -definition to - -data Pair a = Pair a a -data Nest a = Z a | S (Nest (Pair a)) - -they would experience a surprising degradation in performance. -} - - -{- -Utility functions related to Functor deriving. - -Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. -This function works like a fold: it makes a value of type 'a' in a bottom up way. --} - --- Generic traversal for Functor deriving --- See Note [FFoldType and functorLikeTraverse] -data FFoldType a -- Describes how to fold over a Type in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: a - -- ^ The variable itself - , ft_co_var :: a - -- ^ The variable itself, contravariantly - , ft_fun :: a -> a -> a - -- ^ Function type - , ft_tup :: TyCon -> [a] -> a - -- ^ Tuple type - , ft_ty_app :: Type -> a -> a - -- ^ Type app, variable only in last argument - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: TcTyVar -> a -> a - -- ^ Forall type - } - -functorLikeTraverse :: forall a. - TyVar -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> Type -- ^ Type to process - -> a -functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_co_var = caseCoVar, ft_fun = caseFun - , ft_tup = caseTuple, ft_ty_app = caseTyApp - , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) - ty - = fst (go False ty) - where - go :: Bool -- Covariant or contravariant context - -> Type - -> (a, Bool) -- (result of type a, does type contain var) - - go co ty | Just ty' <- tcView ty = go co ty' - go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) - go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) - | InvisArg <- af = go co y - | xc || yc = (caseFun xr yr,True) - where (xr,xc) = go (not co) x - (yr,yc) = go co y - go co (AppTy x y) | xc = (caseWrongArg, True) - | yc = (caseTyApp x yr, True) - where (_, xc) = go co x - (yr,yc) = go co y - go co ty@(TyConApp con args) - | not (or xcs) = (caseTrivial, False) -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | isTupleTyCon con = (caseTuple con xrs, True) - | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty - | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty - = (caseTyApp fun_ty (last xrs), True) - | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) - where - -- When folding over an unboxed tuple, we must explicitly drop the - -- runtime rep arguments, or else GHC will generate twice as many - -- variables in a unboxed tuple pattern match and expression as it - -- actually needs. See #12399 - (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) - go co (ForAllTy (Bndr v vis) x) - | isVisibleArgFlag vis = panic "unexpected visible binder" - | v /= var && xc = (caseForAll v xr,True) - where (xr,xc) = go co x - - go _ _ = (caseTrivial,False) - --- Return all syntactic subterms of ty that contain var somewhere --- These are the things that should appear in instance constraints -deepSubtypesContaining :: TyVar -> Type -> [TcType] -deepSubtypesContaining tv - = functorLikeTraverse tv - (FT { ft_triv = [] - , ft_var = [] - , ft_fun = (++) - , ft_tup = \_ xs -> concat xs - , ft_ty_app = (:) - , ft_bad_app = panic "in other argument in deepSubtypesContaining" - , ft_co_var = panic "contravariant in deepSubtypesContaining" - , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) - - -foldDataConArgs :: FFoldType a -> DataCon -> [a] --- Fold over the arguments of the datacon -foldDataConArgs ft con - = map foldArg (dataConOrigArgTys con) - where - foldArg - = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of - Just tv -> functorLikeTraverse tv ft - Nothing -> const (ft_triv ft) - -- If we are deriving Foldable for a GADT, there is a chance that the last - -- type variable in the data type isn't actually a type variable at all. - -- (for example, this can happen if the last type variable is refined to - -- be a concrete type such as Int). If the last type variable is refined - -- to be a specific type, then getTyVar_maybe will return Nothing. - -- See Note [DeriveFoldable with ExistentialQuantification] - -- - -- The kind checks have ensured the last type parameter is of kind *. - --- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) --- (mkSimpleLam fn) returns (\x. fn(x)) -mkSimpleLam lam = - get >>= \case - n:names -> do - put names - body <- lam (nlHsVar n) - return (mkHsLam [nlVarPat n] body) - _ -> panic "mkSimpleLam" - -mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs - -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) -mkSimpleLam2 lam = - get >>= \case - n1:n2:names -> do - put names - body <- lam (nlHsVar n1) (nlHsVar n2) - return (mkHsLam [nlVarPat n1,nlVarPat n2] body) - _ -> panic "mkSimpleLam2" - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in --- which the LHS pattern-matches on @extra_pats@, followed by a match on the --- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ --- and its arguments, applying an expression (from @insides@) to each of the --- respective arguments of @con@. -mkSimpleConMatch :: Monad m => HsMatchContext RdrName - -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)) - -> [LPat GhcPs] - -> DataCon - -> [LHsExpr GhcPs] - -> m (LMatch GhcPs (LHsExpr GhcPs)) -mkSimpleConMatch ctxt fold extra_pats con insides = do - let con_name = getRdrName con - let vars_needed = takeList insides as_RDRs - let bare_pat = nlConVarPat con_name vars_needed - let pat = if null vars_needed - then bare_pat - else nlParPat bare_pat - rhs <- fold con_name - (zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed) - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" --- --- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to --- 'mkSimpleConMatch', with two key differences: --- --- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a --- @[LHsExpr RdrName]@. This is because it filters out the expressions --- corresponding to arguments whose types do not mention the last type --- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the --- 'Nothing' elements of @insides@). --- --- 2. @fold@ takes an expression as its first argument instead of a --- constructor name. This is because it uses a specialized --- constructor function expression that only takes as many parameters as --- there are argument types that mention the last type variable. --- --- See Note [Generated code for DeriveFoldable and DeriveTraversable] -mkSimpleConMatch2 :: Monad m - => HsMatchContext RdrName - -> (LHsExpr GhcPs -> [LHsExpr GhcPs] - -> m (LHsExpr GhcPs)) - -> [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) -mkSimpleConMatch2 ctxt fold extra_pats con insides = do - let con_name = getRdrName con - vars_needed = takeList insides as_RDRs - pat = nlConVarPat con_name vars_needed - -- Make sure to zip BEFORE invoking catMaybes. We want the variable - -- indicies in each expression to match up with the argument indices - -- in con_expr (defined below). - exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i) - insides vars_needed - -- An element of argTysTyVarInfo is True if the constructor argument - -- with the same index has a type which mentions the last type - -- variable. - argTysTyVarInfo = map isJust insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars - - con_expr - | null asWithTyVar = nlHsApps con_name asWithoutTyVar - | otherwise = - let bs = filterByList argTysTyVarInfo bs_RDRs - vars = filterByLists argTysTyVarInfo bs_Vars as_Vars - in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) - - rhs <- fold con_expr exps - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] - -> m (LMatch GhcPs (LHsExpr GhcPs))) - -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) -mkSimpleTupleCase match_for_con tc insides x - = do { let data_con = tyConSingleDataCon tc - ; match <- match_for_con [] data_con insides - ; return $ nlHsCase x [match] } - -{- -************************************************************************ -* * - Foldable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -Deriving Foldable instances works the same way as Functor instances, -only Foldable instances are not possible for function types at all. -Given (data T a = T a a (T a) deriving Foldable), we get: - - instance Foldable T where - foldr f z (T x1 x2 x3) = - $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) - --XDeriveFoldable is different from -XDeriveFunctor in that it filters out -arguments to the constructor that would produce useless code in a Foldable -instance. For example, the following datatype: - - data Foo a = Foo Int a Int deriving Foldable - -would have the following generated Foldable instance: - - instance Foldable Foo where - foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 - -since neither of the two Int arguments are folded over. - -The cases are: - - $(foldr 'a 'a) = f - $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) - $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 - -Note that the arguments to the real foldr function are the wrong way around, -since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). - -One can envision a case for types that don't contain the last type variable: - - $(foldr 'a 'b) = \x z -> z -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. - -Foldable instances differ from Functor and Traversable instances in that -Foldable instances can be derived for data types in which the last type -variable is existentially quantified. In particular, if the last type variable -is refined to a more specific type in a GADT: - - data GADT a where - G :: a ~ Int => a -> G Int - -then the deriving machinery does not attempt to check that the type a contains -Int, since it is not syntactically equal to a type variable. That is, the -derived Foldable instance for GADT is: - - instance Foldable GADT where - foldr _ z (GADT _) = z - -See Note [DeriveFoldable with ExistentialQuantification]. - -Note [Deriving null] -~~~~~~~~~~~~~~~~~~~~ - -In some cases, deriving the definition of 'null' can produce much better -results than the default definition. For example, with - - data SnocList a = Nil | Snoc (SnocList a) a - -the default definition of 'null' would walk the entire spine of a -nonempty snoc-list before concluding that it is not null. But looking at -the Snoc constructor, we can immediately see that it contains an 'a', and -so 'null' can return False immediately if it matches on Snoc. When we -derive 'null', we keep track of things that cannot be null. The interesting -case is type application. Given - - data Wrap a = Wrap (Foo (Bar a)) - -we use - - null (Wrap fba) = all null fba - -but if we see - - data Wrap a = Wrap (Foo a) - -we can just use - - null (Wrap fa) = null fa - -Indeed, we allow this to happen even for tuples: - - data Wrap a = Wrap (Foo (a, Int)) - -produces - - null (Wrap fa) = null fa - -As explained in Note [Deriving <$], giving tuples special performance treatment -could surprise users if they switch to other types, but Ryan Scott seems to -think it's okay to do it for now. --} - -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the parameter is phantom, we can use foldMap _ _ = mempty --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Foldable_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag foldMap_bind, emptyBag) - where - foldMap_name = L loc foldMap_RDR - foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns - foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt - [nlWildPat, nlWildPat] - mempty_Expr] - foldMap_match_ctxt = mkPrefixFunRhs foldMap_name - -gen_Foldable_binds loc tycon - | null data_cons -- There's no real point producing anything but - -- foldMap for a type with no constructors. - = (unitBag foldMap_bind, emptyBag) - - | otherwise - = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag) - where - data_cons = tyConDataCons tycon - - foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns - eqns = map foldr_eqn data_cons - foldr_eqn con - = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldr con - - foldMap_name = L loc foldMap_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) - foldMap_name foldMap_eqns - - foldMap_eqns = map foldMap_eqn data_cons - - foldMap_eqn con - = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldMap con - - -- Given a list of NullM results, produce Nothing if any of - -- them is NotNull, and otherwise produce a list of Maybes - -- with Justs representing unknowns and Nothings representing - -- things that are definitely null. - convert :: [NullM a] -> Maybe [Maybe a] - convert = traverse go where - go IsNull = Just Nothing - go NotNull = Nothing - go (NullM a) = Just (Just a) - - null_name = L loc null_RDR - null_match_ctxt = mkPrefixFunRhs null_name - null_bind = mkRdrFunBind null_name null_eqns - null_eqns = map null_eqn data_cons - null_eqn con - = flip evalState bs_RDRs $ do - parts <- sequence $ foldDataConArgs ft_null con - case convert parts of - Nothing -> return $ - mkMatch null_match_ctxt [nlParPat (nlWildConPat con)] - false_Expr (noLoc emptyLocalBinds) - Just cp -> match_null [] con cp - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_foldr - = FT { ft_triv = return Nothing - -- foldr f = \x z -> z - , ft_var = return $ Just f_Expr - -- foldr f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam2 $ \x z -> - mkSimpleTupleCase (match_foldr z) t gg x - return (Just lam) - -- foldr f = (\x z -> case x of ...) - , ft_ty_app = \_ g -> do - gg <- g - mapM (\gg' -> mkSimpleLam2 $ \x z -> return $ - nlHsApps foldable_foldr_RDR [gg',z,x]) gg - -- foldr f = (\x z -> foldr g z x) - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_foldr" - , ft_fun = panic "function in ft_foldr" - , ft_bad_app = panic "in other argument in ft_foldr" } - - match_foldr :: LHsExpr GhcPs - -> [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) - match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) - where - -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkFoldr = foldr nlHsApp z - - -- See Note [FFoldType and functorLikeTraverse] - ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_foldMap - = FT { ft_triv = return Nothing - -- foldMap f = \x -> mempty - , ft_var = return (Just f_Expr) - -- foldMap f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg - return (Just lam) - -- foldMap f = \x -> case x of (..,) - , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g - -- foldMap f = foldMap g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_foldMap" - , ft_fun = panic "function in ft_foldMap" - , ft_bad_app = panic "in other argument in ft_foldMap" } - - match_foldMap :: [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) - match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) - where - -- mappend v1 (mappend v2 ..) - mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkFoldMap [] = mempty_Expr - mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs - - -- See Note [FFoldType and functorLikeTraverse] - -- Yields NullM an expression if we're folding over an expression - -- that may or may not be null. Yields IsNull if it's certainly - -- null, and yields NotNull if it's certainly not null. - -- See Note [Deriving null] - ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) - ft_null - = FT { ft_triv = return IsNull - -- null = \_ -> True - , ft_var = return NotNull - -- null = \_ -> False - , ft_tup = \t g -> do - gg <- sequence g - case convert gg of - Nothing -> pure NotNull - Just ggg -> - NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg) - -- null = \x -> case x of (..,) - , ft_ty_app = \_ g -> flip fmap g $ \nestedResult -> - case nestedResult of - -- If e definitely contains the parameter, - -- then we can test if (G e) contains it by - -- simply checking if (G e) is null - NotNull -> NullM null_Expr - -- This case is unreachable--it will actually be - -- caught by ft_triv - IsNull -> IsNull - -- The general case uses (all null), - -- (all (all null)), etc. - NullM nestedTest -> NullM $ - nlHsApp all_Expr nestedTest - -- null fa = null fa, or null fa = all null fa, or null fa = True - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_null" - , ft_fun = panic "function in ft_null" - , ft_bad_app = panic "in other argument in ft_null" } - - match_null :: [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) - match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs) - where - -- v1 && v2 && .. - mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkNull [] = true_Expr - mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs - -data NullM a = - IsNull -- Definitely null - | NotNull -- Definitely not null - | NullM a -- Unknown - -{- -************************************************************************ -* * - Traversable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html -* * -************************************************************************ - -Again, Traversable is much like Functor and Foldable. - -The cases are: - - $(traverse 'a 'a) = f - $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> - liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) - $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 - -Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types -do not mention the last type parameter. Therefore, the following datatype: - - data Foo a = Foo Int a Int - -would have the following derived Traversable instance: - - instance Traversable Foo where - traverse f (Foo x1 x2 x3) = - fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) - -since the two Int arguments do not produce any effects in a traversal. - -One can envision a case for types that do not mention the last type parameter: - - $(traverse 'a 'b) = pure -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. --} - -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the argument is phantom, we can use traverse = pure . coerce --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Traversable_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag traverse_bind, emptyBag) - where - traverse_name = L loc traverse_RDR - traverse_bind = mkRdrFunBind traverse_name traverse_eqns - traverse_eqns = - [mkSimpleMatch traverse_match_ctxt - [nlWildPat, z_Pat] - (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] - traverse_match_ctxt = mkPrefixFunRhs traverse_name - -gen_Traversable_binds loc tycon - = (unitBag traverse_bind, emptyBag) - where - data_cons = tyConDataCons tycon - - traverse_name = L loc traverse_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) - traverse_name traverse_eqns - traverse_eqns = map traverse_eqn data_cons - traverse_eqn con - = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_trav con - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_trav - = FT { ft_triv = return Nothing - -- traverse f = pure x - , ft_var = return (Just f_Expr) - -- traverse f = f x - , ft_tup = \t gs -> do - gg <- sequence gs - lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg - return (Just lam) - -- traverse f = \x -> case x of (a1,a2,..) -> - -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. - , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g - -- traverse f = traverse g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_trav" - , ft_fun = panic "function in ft_trav" - , ft_bad_app = panic "in other argument in ft_trav" } - - -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) - -- (g2 a2) <*> ... - match_for_con :: [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) - match_for_con = mkSimpleConMatch2 CaseAlt $ - \con xs -> return (mkApCon con xs) - where - -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. - mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs - mkApCon con [] = nlHsApps pure_RDR [con] - mkApCon con [x] = nlHsApps fmap_RDR [con,x] - mkApCon con (x1:x2:xs) = - foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs - where appAp x y = nlHsApps ap_RDR [x,y] - ------------------------------------------------------------------------ - -f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr, - traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, - all_Expr, null_Expr :: LHsExpr GhcPs -f_Expr = nlHsVar f_RDR -z_Expr = nlHsVar z_RDR -fmap_Expr = nlHsVar fmap_RDR -replace_Expr = nlHsVar replace_RDR -mempty_Expr = nlHsVar mempty_RDR -foldMap_Expr = nlHsVar foldMap_RDR -traverse_Expr = nlHsVar traverse_RDR -coerce_Expr = nlHsVar (getRdrName coerceId) -pure_Expr = nlHsVar pure_RDR -true_Expr = nlHsVar true_RDR -false_Expr = nlHsVar false_RDR -all_Expr = nlHsVar all_RDR -null_Expr = nlHsVar null_RDR - -f_RDR, z_RDR :: RdrName -f_RDR = mkVarUnqual (fsLit "f") -z_RDR = mkVarUnqual (fsLit "z") - -as_RDRs, bs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] - -as_Vars, bs_Vars :: [LHsExpr GhcPs] -as_Vars = map nlHsVar as_RDRs -bs_Vars = map nlHsVar bs_RDRs - -f_Pat, z_Pat :: LPat GhcPs -f_Pat = nlVarPat f_RDR -z_Pat = nlVarPat z_RDR - -{- -Note [DeriveFoldable with ExistentialQuantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Traversable instances can only be derived for data types whose -last type parameter is truly universally polymorphic. For example: - - data T a b where - T1 :: b -> T a b -- YES, b is unconstrained - T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) - T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) - T4 :: Int -> T a Int -- NO, this is just like T3 - T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even - -- though a is existential - T6 :: Int -> T Int b -- YES, b is unconstrained - -For Foldable instances, however, we can completely lift the constraint that -the last type parameter be truly universally polymorphic. This means that T -(as defined above) can have a derived Foldable instance: - - instance Foldable (T a) where - foldr f z (T1 b) = f b z - foldr f z (T2 b) = f b z - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - foldr f z (T5 a b) = f b z - foldr f z (T6 a) = z - - foldMap f (T1 b) = f b - foldMap f (T2 b) = f b - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - foldMap f (T5 a b) = f b - foldMap f (T6 a) = mempty - -In a Foldable instance, it is safe to fold over an occurrence of the last type -parameter that is not truly universally polymorphic. However, there is a bit -of subtlety in determining what is actually an occurrence of a type parameter. -T3 and T4, as defined above, provide one example: - - data T a b where - ... - T3 :: b ~ Int => b -> T a b - T4 :: Int -> T a Int - ... - - instance Foldable (T a) where - ... - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - ... - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - ... - -Notice that the argument of T3 is folded over, whereas the argument of T4 is -not. This is because we only fold over constructor arguments that -syntactically mention the universally quantified type parameter of that -particular data constructor. See foldDataConArgs for how this is implemented. - -As another example, consider the following data type. The argument of each -constructor has the same type as the last type parameter: - - data E a where - E1 :: (a ~ Int) => a -> E a - E2 :: Int -> E Int - E3 :: (a ~ Int) => a -> E Int - E4 :: (a ~ Int) => Int -> E a - -Only E1's argument is an occurrence of a universally quantified type variable -that is syntactically equivalent to the last type parameter, so only E1's -argument will be folded over in a derived Foldable instance. - -See #10447 for the original discussion on this feature. Also see -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor -for a more in-depth explanation. - -Note [FFoldType and functorLikeTraverse] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Functor, Foldable, and Traversable all require generating expressions -which perform an operation on each argument of a data constructor depending -on the argument's type. In particular, a generated operation can be different -depending on whether the type mentions the last type variable of the datatype -(e.g., if you have data T a = MkT a Int, then a generated foldr expression would -fold over the first argument of MkT, but not the second). - -This pattern is abstracted with the FFoldType datatype, which provides hooks -for the user to specify how a constructor argument should be folded when it -has a type with a particular "shape". The shapes are as follows (assume that -a is the last type variable in a given datatype): - -* ft_triv: The type does not mention the last type variable at all. - Examples: Int, b - -* ft_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a covariant position (see - the Deriving Functor instances section of the user's guide - for an in-depth explanation of covariance vs. contravariance). - Example: a (covariantly) - -* ft_co_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a contravariant position. - Example: a (contravariantly) - -* ft_fun: A function type which mentions the last type variable in - the argument position, result position or both. - Examples: a -> Int, Int -> a, Maybe a -> [a] - -* ft_tup: A tuple type which mentions the last type variable in at least - one of its fields. The TyCon argument of ft_tup represents the - particular tuple's type constructor. - Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) - -* ft_ty_app: A type is being applied to the last type parameter, where the - applied type does not mention the last type parameter (if it - did, it would fall under ft_bad_app). The Type argument to - ft_ty_app represents the applied type. - - Note that functions, tuples, and foralls are distinct cases - and take precedence of ft_ty_app. (For example, (Int -> a) would - fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). - Examples: Maybe a, Either b a - -* ft_bad_app: A type application uses the last type parameter in a position - other than the last argument. This case is singled out because - Functor, Foldable, and Traversable instances cannot be derived - for datatypes containing arguments with such types. - Examples: Either a Int, Const a b - -* ft_forall: A forall'd type mentions the last type parameter on its right- - hand side (and is not quantified on the left-hand side). This - case is present mostly for plumbing purposes. - Example: forall b. Either b a - -If FFoldType describes a strategy for folding subcomponents of a Type, then -functorLikeTraverse is the function that applies that strategy to the entirety -of a Type, returning the final folded-up result. - -foldDataConArgs applies functorLikeTraverse to every argument type of a -constructor, returning a list of the fold results. This makes foldDataConArgs -a natural way to generate the subexpressions in a generated fmap, foldr, -foldMap, or traverse definition (the subexpressions must then be combined in -a method-specific fashion to form the final generated expression). - -Deriving Generic1 also does validity checking by looking for the last type -variable in certain positions of a constructor's argument types, so it also -uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics. - -Note [Generated code for DeriveFoldable and DeriveTraversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on -that of -XDeriveFunctor. However, there an important difference between deriving -the former two typeclasses and the latter one, which is best illustrated by the -following scenario: - - data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) - -The generated code for the Functor instance is straightforward: - - instance Functor WithInt where - fmap f (WithInt a i) = WithInt (f a) i - -But if we use too similar of a strategy for deriving the Foldable and -Traversable instances, we end up with this code: - - instance Foldable WithInt where - foldMap f (WithInt a i) = f a <> mempty - - instance Traversable WithInt where - traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i - -This is unsatisfying for two reasons: - -1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure - expects an argument whose type is of kind *. This effectively prevents - Traversable from being derived for any datatype with an unlifted argument - type (#11174). - -2. The generated code contains superfluous expressions. By the Monoid laws, - we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can - reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). - -We can fix both of these issues by incorporating a slight twist to the usual -algorithm that we use for -XDeriveFunctor. The differences can be summarized -as follows: - -1. In the generated expression, we only fold over arguments whose types - mention the last type parameter. Any other argument types will simply - produce useless 'mempty's or 'pure's, so they can be safely ignored. - -2. In the case of -XDeriveTraversable, instead of applying ConName, - we apply (\b_i ... b_k -> ConName a_1 ... a_n), where - - * ConName has n arguments - * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond - to the arguments whose types mention the last type parameter. As a - consequence, taking the difference of {a_1, ..., a_n} and - {b_i, ..., b_k} yields the all the argument values of ConName whose types - do not mention the last type parameter. Note that [i, ..., k] is a - strictly increasing—but not necessarily consecutive—integer sequence. - - For example, the datatype - - data Foo a = Foo Int a Int a - - would generate the following Traversable instance: - - instance Traversable Foo where - traverse f (Foo a1 a2 a3 a4) = - fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 - -Technically, this approach would also work for -XDeriveFunctor as well, but we -decide not to do so because: - -1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) - instead of (WithInt (f a) i). - -2. There would be certain datatypes for which the above strategy would - generate Functor code that would fail to typecheck. For example: - - data Bar f a = Bar (forall f. Functor f => f a) deriving Functor - - With the conventional algorithm, it would generate something like: - - fmap f (Bar a) = Bar (fmap f a) - - which typechecks. But with the strategy mentioned above, it would generate: - - fmap f (Bar a) = (\b -> Bar b) (fmap f a) - - which does not typecheck, since GHC cannot unify the rank-2 type variables - in the types of b and (fmap f a). - -Note [Phantom types with Functor, Foldable, and Traversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Given a type F :: * -> * whose type argument has a phantom role, we can always -produce lawful Functor and Traversable instances using - - fmap _ = coerce - traverse _ = pure . coerce - -Indeed, these are equivalent to any *strictly lawful* instances one could -write, except that this definition of 'traverse' may be lazier. That is, if -instances obey the laws under true equality (rather than up to some equivalence -relation), then they will be essentially equivalent to these. These definitions -are incredibly cheap, so we want to use them even if it means ignoring some -non-strictly-lawful instance in an embedded type. - -Foldable has far fewer laws to work with, which leaves us unwelcome -freedom in implementing it. At a minimum, we would like to ensure that -a derived foldMap is always at least as good as foldMapDefault with a -derived traverse. To accomplish that, we must define - - foldMap _ _ = mempty - -in these cases. - -This may have different strictness properties from a standard derivation. -Consider - - data NotAList a = Nil | Cons (NotAList a) deriving Foldable - -The usual deriving mechanism would produce - - foldMap _ Nil = mempty - foldMap f (Cons x) = foldMap f x - -which is strict in the entire spine of the NotAList. - -Final point: why do we even care about such types? Users will rarely if ever -map, fold, or traverse over such things themselves, but other derived -instances may: - - data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable - -Note [EmptyDataDecls with Functor, Foldable, and Traversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are some slightly tricky decisions to make about how to handle -Functor, Foldable, and Traversable instances for types with no constructors. -For fmap, the two basic options are - - fmap _ _ = error "Sorry, no constructors" - -or - - fmap _ z = case z of - -In most cases, the latter is more helpful: if the thunk passed to fmap -throws an exception, we're generally going to be much more interested in -that exception than in the fact that there aren't any constructors. - -In order to match the semantics for phantoms (see note above), we need to -be a bit careful about 'traverse'. The obvious definition would be - - traverse _ z = case z of - -but this is stricter than the one for phantoms. We instead use - - traverse _ z = pure $ case z of - -For foldMap, the obvious choices are - - foldMap _ _ = mempty - -or - - foldMap _ z = case z of - -We choose the first one to be consistent with what foldMapDefault does for -a derived Traversable instance. --} diff --git a/typecheck/TcGenGenerics.hs b/typecheck/TcGenGenerics.hs deleted file mode 100644 --- a/typecheck/TcGenGenerics.hs +++ /dev/null @@ -1,1033 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Generic class -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module TcGenGenerics (canDoGenerics, canDoGenerics1, - GenericKind(..), - gen_Generic_binds, get_gen1_constrained_tys) where - -import GhcPrelude - -import GHC.Hs -import Type -import TcType -import TcGenDeriv -import TcGenFunctor -import DataCon -import TyCon -import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) -import FamInst -import Module ( moduleName, moduleNameFS - , moduleUnitId, unitIdFS, getModule ) -import IfaceEnv ( newGlobalBinder ) -import Name hiding ( varName ) -import RdrName -import BasicTypes -import TysPrim -import TysWiredIn -import PrelNames -import TcEnv -import TcRnMonad -import HscTypes -import ErrUtils( Validity(..), andValid ) -import SrcLoc -import Bag -import VarEnv -import VarSet (elemVarSet) -import Outputable -import FastString -import Util - -import Control.Monad (mplus) -import Data.List (zip4, partition) -import Data.Maybe (isJust) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{Bindings for the new generic deriving mechanism} -* * -************************************************************************ - -For the generic representation we need to generate: -\begin{itemize} -\item A Generic instance -\item A Rep type instance -\item Many auxiliary datatypes and instances for them (for the meta-information) -\end{itemize} --} - -gen_Generic_binds :: GenericKind -> TyCon -> [Type] - -> TcM (LHsBinds GhcPs, FamInst) -gen_Generic_binds gk tc inst_tys = do - repTyInsts <- tc_mkRepFamInsts gk tc inst_tys - return (mkBindsRep gk tc, repTyInsts) - -{- -************************************************************************ -* * -\subsection{Generating representation types} -* * -************************************************************************ --} - -get_gen1_constrained_tys :: TyVar -> Type -> [Type] --- called by TcDeriv.inferConstraints; generates a list of types, each of which --- must be a Functor in order for the Generic1 instance to work. -get_gen1_constrained_tys argVar - = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] - , ata_par1 = [], ata_rec1 = const [] - , ata_comp = (:) } - -{- - -Note [Requirements for deriving Generic and Rep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the following, T, Tfun, and Targ are "meta-variables" ranging over type -expressions. - -(Generic T) and (Rep T) are derivable for some type expression T if the -following constraints are satisfied. - - (a) D is a type constructor *value*. In other words, D is either a type - constructor or it is equivalent to the head of a data family instance (up to - alpha-renaming). - - (b) D cannot have a "stupid context". - - (c) The right-hand side of D cannot include existential types, universally - quantified types, or "exotic" unlifted types. An exotic unlifted type - is one which is not listed in the definition of allowedUnliftedTy - (i.e., one for which we have no representation type). - See Note [Generics and unlifted types] - - (d) T :: *. - -(Generic1 T) and (Rep1 T) are derivable for some type expression T if the -following constraints are satisfied. - - (a),(b),(c) As above. - - (d) T must expect arguments, and its last parameter must have kind *. - - We use `a' to denote the parameter of D that corresponds to the last - parameter of T. - - (e) For any type-level application (Tfun Targ) in the right-hand side of D - where the head of Tfun is not a tuple constructor: - - (b1) `a' must not occur in Tfun. - - (b2) If `a' occurs in Targ, then Tfun :: * -> *. - --} - -canDoGenerics :: TyCon -> Validity --- canDoGenerics determines if Generic/Rep can be derived. --- --- Check (a) from Note [Requirements for deriving Generic and Rep] is taken --- care of because canDoGenerics is applied to rep tycons. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics tc - = mergeErrors ( - -- Check (b) from Note [Requirements for deriving Generic and Rep]. - (if (not (null (tyConStupidTheta tc))) - then (NotValid (tc_name <+> text "must not have a datatype context")) - else IsValid) - -- See comment below - : (map bad_con (tyConDataCons tc))) - where - -- The tc can be a representation tycon. When we want to display it to the - -- user (in an error message) we should print its parent - tc_name = ppr $ case tyConFamInst_maybe tc of - Just (ptc, _) -> ptc - _ -> tc - - -- Check (c) from Note [Requirements for deriving Generic and Rep]. - -- - -- If any of the constructors has an exotic unlifted type as argument, - -- then we can't build the embedding-projection pair, because - -- it relies on instantiating *polymorphic* sum and product types - -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) - then (NotValid (ppr dc <+> text - "must not have exotic unlifted or polymorphic arguments")) - else (if (not (isVanillaDataCon dc)) - then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) - else IsValid) - - -- Nor can we do the job if it's an existential data constructor, - -- Nor if the args are polymorphic types (I don't think) - bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty)) - || not (isTauTy ty) - --- Returns True the Type argument is an unlifted type which has a --- corresponding generic representation type. For example, --- (allowedUnliftedTy Int#) would return True since there is the UInt --- representation type. -allowedUnliftedTy :: Type -> Bool -allowedUnliftedTy = isJust . unboxedRepRDRs - -mergeErrors :: [Validity] -> Validity -mergeErrors [] = IsValid -mergeErrors (NotValid s:t) = case mergeErrors t of - IsValid -> NotValid s - NotValid s' -> NotValid (s <> text ", and" $$ s') -mergeErrors (IsValid : t) = mergeErrors t - --- A datatype used only inside of canDoGenerics1. It's the result of analysing --- a type term. -data Check_for_CanDoGenerics1 = CCDG1 - { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in - -- this type? - , _ccdg1_errors :: Validity -- errors generated by this type - } - -{- - -Note [degenerate use of FFoldType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We use foldDataConArgs here only for its ability to treat tuples -specially. foldDataConArgs also tracks covariance (though it assumes all -higher-order type parameters are covariant) and has hooks for special handling -of functions and polytypes, but we do *not* use those. - -The key issue is that Generic1 deriving currently offers no sophisticated -support for functions. For example, we cannot handle - - data F a = F ((a -> Int) -> Int) - -even though a is occurring covariantly. - -In fact, our rule is harsh: a is simply not allowed to occur within the first -argument of (->). We treat (->) the same as any other non-tuple tycon. - -Unfortunately, this means we have to track "the parameter occurs in this type" -explicitly, even though foldDataConArgs is also doing this internally. - --} - --- canDoGenerics1 determines if a Generic1/Rep1 can be derived. --- --- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep] --- are taken care of by the call to canDoGenerics. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics1 :: TyCon -> Validity -canDoGenerics1 rep_tc = - canDoGenerics rep_tc `andValid` additionalChecks - where - additionalChecks - -- check (d) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = NotValid $ - text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" - - | otherwise = mergeErrors $ concatMap check_con data_cons - - data_cons = tyConDataCons rep_tc - check_con con = case check_vanilla con of - j@(NotValid {}) -> [j] - IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con - - bad :: DataCon -> SDoc -> SDoc - bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg - - check_vanilla :: DataCon -> Validity - check_vanilla con | isVanillaDataCon con = IsValid - | otherwise = NotValid (bad con existential) - - bmzero = CCDG1 False IsValid - bmbad con s = CCDG1 True $ NotValid $ bad con s - bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) - - -- check (e) from Note [Requirements for deriving Generic and Rep] - -- See also Note [degenerate use of FFoldType] - ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 - ft_check con = FT - { ft_triv = bmzero - - , ft_var = caseVar, ft_co_var = caseVar - - -- (component_0,component_1,...,component_n) - , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con wrong_arg - else foldr bmplus bmzero components - - -- (dom -> rng), where the head of ty is not a tuple tycon - , ft_fun = \dom rng -> -- cf #8516 - if _ccdg1_hasParam dom - then bmbad con wrong_arg - else bmplus dom rng - - -- (ty arg), where head of ty is neither (->) nor a tuple constructor and - -- the parameter of interest does not occur in ty - , ft_ty_app = \_ arg -> arg - - , ft_bad_app = bmbad con wrong_arg - , ft_forall = \_ body -> body -- polytypes are handled elsewhere - } - where - caseVar = CCDG1 True IsValid - - - existential = text "must not have existential arguments" - wrong_arg = text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - -{- -************************************************************************ -* * -\subsection{Generating the RHS of a generic default method} -* * -************************************************************************ --} - -type US = Int -- Local unique supply, just a plain Int -type Alt = (LPat GhcPs, LHsExpr GhcPs) - --- GenericKind serves to mark if a datatype derives Generic (Gen0) or --- Generic1 (Gen1). -data GenericKind = Gen0 | Gen1 - --- as above, but with a payload of the TyCon's name for "the" parameter -data GenericKind_ = Gen0_ | Gen1_ TyVar - --- as above, but using a single datacon's name for "the" parameter -data GenericKind_DC = Gen0_DC | Gen1_DC TyVar - -forgetArgVar :: GenericKind_DC -> GenericKind -forgetArgVar Gen0_DC = Gen0 -forgetArgVar Gen1_DC{} = Gen1 - --- When working only within a single datacon, "the" parameter's name should --- match that datacon's name for it. -gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC -gk2gkDC Gen0_ _ = Gen0_DC -gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d - - --- Bindings for the Generic instance -mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs -mkBindsRep gk tycon = - unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) - `unionBags` - unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) - where - -- The topmost M1 (the datatype metadata) has the exact same type - -- across all cases of a from/to definition, and can be factored out - -- to save some allocations during typechecking. - -- See Note [Generics compilation speed tricks] - from_eqn = mkHsCaseAlt x_Pat $ mkM1_E - $ nlHsPar $ nlHsCase x_Expr from_matches - to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches - - from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - - (from01_RDR, to01_RDR) = case gk of - Gen0 -> (from_RDR, to_RDR) - Gen1 -> (from1_RDR, to1_RDR) - - -- Recurse over the sum first - from_alts, to_alts :: [Alt] - (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons - where gk_ = case gk of - Gen0 -> Gen0_ - Gen1 -> ASSERT(tyvars `lengthAtLeast` 1) - Gen1_ (last tyvars) - where tyvars = tyConTyVars tycon - --------------------------------------------------------------------------------- --- The type synonym instance and synonym --- type instance Rep (D a b) = Rep_D a b --- type Rep_D a b = ...representation type for D ... --------------------------------------------------------------------------------- - -tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 - -> TyCon -- The type to generate representation for - -> [Type] -- The type(s) to which Generic(1) is applied - -- in the generated instance - -> TcM FamInst -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon inst_tys = - -- Consider the example input tycon `D`, where data D a b = D_ a - -- Also consider `R:DInt`, where { data family D x y :: * -> * - -- ; data instance D Int a b = D_ a } - do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) - fam_tc <- case gk of - Gen0 -> tcLookupTyCon repTyConName - Gen1 -> tcLookupTyCon rep1TyConName - - ; fam_envs <- tcGetFamInstEnvs - - ; let -- If the derived instance is - -- instance Generic (Foo x) - -- then: - -- `arg_ki` = *, `inst_ty` = Foo x :: * - -- - -- If the derived instance is - -- instance Generic1 (Bar x :: k -> *) - -- then: - -- `arg_k` = k, `inst_ty` = Bar x :: k -> * - (arg_ki, inst_ty) = case (gk, inst_tys) of - (Gen0, [inst_t]) -> (liftedTypeKind, inst_t) - (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) - _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) - - ; let mbFamInst = tyConFamInst_maybe tycon - -- If we're examining a data family instance, we grab the parent - -- TyCon (ptc) and use it to determine the type arguments - -- (inst_args) for the data family *instance*'s type variables. - ptc = maybe tycon fst mbFamInst - (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd - $ tcSplitTyConApp inst_ty - - ; let -- `tyvars` = [a,b] - (tyvars, gk_) = case gk of - Gen0 -> (all_tyvars, Gen0_) - Gen1 -> ASSERT(not $ null all_tyvars) - (init all_tyvars, Gen1_ $ last all_tyvars) - where all_tyvars = tyConTyVars tycon - - -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ tycon arg_ki - - -- `rep_name` is a name we generate for the synonym - ; mod <- getModule - ; loc <- getSrcSpanM - ; let tc_occ = nameOccName (tyConName tycon) - rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ - ; rep_name <- newGlobalBinder mod rep_occ loc - - -- We make sure to substitute the tyvars with their user-supplied - -- type arguments before generating the Rep/Rep1 instance, since some - -- of the tyvars might have been instantiated when deriving. - -- See Note [Generating a correctly typed Rep instance]. - ; let (env_tyvars, env_inst_args) - = case gk_ of - Gen0_ -> (tyvars, inst_args) - Gen1_ last_tv - -- See the "wrinkle" in - -- Note [Generating a correctly typed Rep instance] - -> ( last_tv : tyvars - , anyTypeOfKind (tyVarKind last_tv) : inst_args ) - env = zipTyEnv env_tyvars env_inst_args - in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) - subst = mkTvSubst in_scope env - repTy' = substTyUnchecked subst repTy - tcv' = tyCoVarsOfTypeList inst_ty - (tv', cv') = partition isTyVar tcv' - tvs' = scopedSort tv' - cvs' = scopedSort cv' - axiom = mkSingleCoAxiom Nominal rep_name tvs' [] cvs' - fam_tc inst_tys repTy' - - ; newFamInst SynFamilyInst axiom } - --------------------------------------------------------------------------------- --- Type representation --------------------------------------------------------------------------------- - --- | See documentation of 'argTyFold'; that function uses the fields of this --- type to interpret the structure of a type when that type is considered as an --- argument to a constructor that is being represented with 'Rep1'. -data ArgTyAlg a = ArgTyAlg - { ata_rec0 :: (Type -> a) - , ata_par1 :: a, ata_rec1 :: (Type -> a) - , ata_comp :: (Type -> a -> a) - } - --- | @argTyFold@ implements a generalised and safer variant of the @arg@ --- function from Figure 3 in . @arg@ --- is conceptually equivalent to: --- --- > arg t = case t of --- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t --- > App f [t'] | --- > representable1 f && --- > t' == argVar -> Rec1 f --- > App f [t'] | --- > representable1 f && --- > t' has tyvars -> f :.: (arg t') --- > _ -> Rec0 t --- --- where @argVar@ is the last type variable in the data type declaration we are --- finding the representation for. --- --- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to --- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and --- @:.:@. --- --- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for --- some data types. The problematic case is when @t@ is an application of a --- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the --- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in --- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some --- representable1 checks have been relaxed, and others were moved to --- @canDoGenerics1@. -argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a -argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, - ata_par1 = mkPar1, ata_rec1 = mkRec1, - ata_comp = mkComp}) = - -- mkRec0 is the default; use it if there is no interesting structure - -- (e.g. occurrences of parameters or recursive occurrences) - \t -> maybe (mkRec0 t) id $ go t where - go :: Type -> -- type to fold through - Maybe a -- the result (e.g. representation type), unless it's trivial - go t = isParam `mplus` isApp where - - isParam = do -- handles parameters - t' <- getTyVar_maybe t - Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter - else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 - - isApp = do -- handles applications - (phi, beta) <- tcSplitAppTy_maybe t - - let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta - - -- Does it have no interesting structure to represent? - if not interesting then Nothing - else -- Is the argument the parameter? Special case for mkRec1. - if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi - else mkComp phi `fmap` go beta -- It must be a composition. - - -tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 - GenericKind_ - -- The type to generate representation for - -> TyCon - -- The kind of the representation type's argument - -- See Note [Handling kinds in a Rep instance] - -> Kind - -- Generated representation0 type - -> TcM Type -tc_mkRepTy gk_ tycon k = - do - d1 <- tcLookupTyCon d1TyConName - c1 <- tcLookupTyCon c1TyConName - s1 <- tcLookupTyCon s1TyConName - rec0 <- tcLookupTyCon rec0TyConName - rec1 <- tcLookupTyCon rec1TyConName - par1 <- tcLookupTyCon par1TyConName - u1 <- tcLookupTyCon u1TyConName - v1 <- tcLookupTyCon v1TyConName - plus <- tcLookupTyCon sumTyConName - times <- tcLookupTyCon prodTyConName - comp <- tcLookupTyCon compTyConName - uAddr <- tcLookupTyCon uAddrTyConName - uChar <- tcLookupTyCon uCharTyConName - uDouble <- tcLookupTyCon uDoubleTyConName - uFloat <- tcLookupTyCon uFloatTyConName - uInt <- tcLookupTyCon uIntTyConName - uWord <- tcLookupTyCon uWordTyConName - - let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon - - md <- tcLookupPromDataCon metaDataDataConName - mc <- tcLookupPromDataCon metaConsDataConName - ms <- tcLookupPromDataCon metaSelDataConName - pPrefix <- tcLookupPromDataCon prefixIDataConName - pInfix <- tcLookupPromDataCon infixIDataConName - pLA <- tcLookupPromDataCon leftAssociativeDataConName - pRA <- tcLookupPromDataCon rightAssociativeDataConName - pNA <- tcLookupPromDataCon notAssociativeDataConName - pSUpk <- tcLookupPromDataCon sourceUnpackDataConName - pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName - pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName - pSLzy <- tcLookupPromDataCon sourceLazyDataConName - pSStr <- tcLookupPromDataCon sourceStrictDataConName - pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName - pDLzy <- tcLookupPromDataCon decidedLazyDataConName - pDStr <- tcLookupPromDataCon decidedStrictDataConName - pDUpk <- tcLookupPromDataCon decidedUnpackDataConName - - fix_env <- getFixityEnv - - let mkSum' a b = mkTyConApp plus [k,a,b] - mkProd a b = mkTyConApp times [k,a,b] - mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a - mkRec1 a = mkTyConApp rec1 [k,a] - mkPar1 = mkTyConTy par1 - mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] - mkC a = mkTyConApp c1 [ k - , metaConsTy a - , prod (dataConInstOrigArgTys a - . mkTyVarTys . tyConTyVars $ tycon) - (dataConSrcBangs a) - (dataConImplBangs a) - (dataConFieldLabels a)] - mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a] - - -- Sums and products are done in the same way for both Rep and Rep1 - sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l - -- The Bool is True if this constructor has labelled fields - prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type - prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k]) - [ ASSERT(null fl || lengthExceeds fl j) - arg t sb' ib' (if null fl - then Nothing - else Just (fl !! j)) - | (t,sb',ib',j) <- zip4 l sb ib [0..] ] - - arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type - arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of - -- Here we previously used Par0 if t was a type variable, but we - -- realized that we can't always guarantee that we are wrapping-up - -- all type variables in Par0. So we decided to stop using Par0 - -- altogether, and use Rec0 all the time. - Gen0_ -> mkRec0 t - Gen1_ argVar -> argPar argVar t - where - -- Builds argument representation for Rep1 (more complicated due to - -- the presence of composition). - argPar argVar = argTyFold argVar $ ArgTyAlg - {ata_rec0 = mkRec0, ata_par1 = mkPar1, - ata_rec1 = mkRec1, ata_comp = mkComp comp k} - - tyConName_user = case tyConFamInst_maybe tycon of - Just (ptycon, _) -> tyConName ptycon - Nothing -> tyConName tycon - - dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user - mdName = mkStrLitTy . moduleNameFS . moduleName - . nameModule . tyConName $ tycon - pkgName = mkStrLitTy . unitIdFS . moduleUnitId - . nameModule . tyConName $ tycon - isNT = mkTyConTy $ if isNewTyCon tycon - then promotedTrueDataCon - else promotedFalseDataCon - - ctName = mkStrLitTy . occNameFS . nameOccName . dataConName - ctFix c - | dataConIsInfix c - = case lookupFixity fix_env (dataConName c) of - Fixity _ n InfixL -> buildFix n pLA - Fixity _ n InfixR -> buildFix n pRA - Fixity _ n InfixN -> buildFix n pNA - | otherwise = mkTyConTy pPrefix - buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc - , mkNumLitTy (fromIntegral n)] - - isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0 - then promotedTrueDataCon - else promotedFalseDataCon - - selName = mkStrLitTy . flLabel - - mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] - mbSel (Just s) = mkTyConApp promotedJustDataCon - [typeSymbolKind, selName s] - - metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] - metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] - metaSelTy mlbl su ss ib = - mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness] - where - pSUpkness = mkTyConTy $ case su of - SrcUnpack -> pSUpk - SrcNoUnpack -> pSNUpk - NoSrcUnpack -> pNSUpkness - - pSStrness = mkTyConTy $ case ss of - SrcLazy -> pSLzy - SrcStrict -> pSStr - NoSrcStrict -> pNSStrness - - pDStrness = mkTyConTy $ case ib of - HsLazy -> pDLzy - HsStrict -> pDStr - HsUnpack{} -> pDUpk - - return (mkD tycon) - -mkComp :: TyCon -> Kind -> Type -> Type -> Type -mkComp comp k f g - | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] - | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] - where - -- Which of these is the case? - -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- We want to instantiate with k1=k, and k2=* - -- Reason for k2=*: see Note [Handling kinds in a Rep instance] - -- But we need to know which way round! - k1_first = k_first == p_kind_var - [k_first,_,_,_,p] = tyConTyVars comp - Just p_kind_var = getTyVar_maybe (tyVarKind p) - --- Given the TyCons for each URec-related type synonym, check to see if the --- given type is an unlifted type that generics understands. If so, return --- its representation type. Otherwise, return Rec0. --- See Note [Generics and unlifted types] -mkBoxTy :: TyCon -- UAddr - -> TyCon -- UChar - -> TyCon -- UDouble - -> TyCon -- UFloat - -> TyCon -- UInt - -> TyCon -- UWord - -> TyCon -- Rec0 - -> Kind -- What to instantiate Rec0's kind variable with - -> Type - -> Type -mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty - | ty `eqType` addrPrimTy = mkTyConApp uAddr [k] - | ty `eqType` charPrimTy = mkTyConApp uChar [k] - | ty `eqType` doublePrimTy = mkTyConApp uDouble [k] - | ty `eqType` floatPrimTy = mkTyConApp uFloat [k] - | ty `eqType` intPrimTy = mkTyConApp uInt [k] - | ty `eqType` wordPrimTy = mkTyConApp uWord [k] - | otherwise = mkTyConApp rec0 [k,ty] - --------------------------------------------------------------------------------- --- Dealing with sums --------------------------------------------------------------------------------- - -mkSum :: GenericKind_ -- Generic or Generic1? - -> US -- Base for generating unique names - -> [DataCon] -- The data constructors - -> ([Alt], -- Alternatives for the T->Trep "from" function - [Alt]) -- Alternatives for the Trep->T "to" function - --- Datatype without any constructors -mkSum _ _ [] = ([from_alt], [to_alt]) - where - from_alt = (x_Pat, nlHsCase x_Expr []) - to_alt = (x_Pat, nlHsCase x_Expr []) - -- These M1s are meta-information for the datatype - --- Datatype with at least one constructor -mkSum gk_ us datacons = - -- switch the payload of gk_ to be datacon-centric instead of tycon-centric - unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d - | (d,i) <- zip datacons [1..] ] - --- Build the sum for a particular constructor -mk1Sum :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for generating unique names - -> Int -- The index of this constructor - -> Int -- Total number of constructors - -> DataCon -- The data constructor - -> (Alt, -- Alternative for the T->Trep "from" function - Alt) -- Alternative for the Trep->T "to" function -mk1Sum gk_ us i n datacon = (from_alt, to_alt) - where - gk = forgetArgVar gk_ - - -- Existentials already excluded - argTys = dataConOrigArgTys datacon - n_args = dataConSourceArity datacon - - datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys - datacon_vars = map fst datacon_varTys - - datacon_rdr = getRdrName datacon - - from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys) - - to_alt = ( genLR_P i n (mkProd_P gk datacon_varTys) - , to_alt_rhs - ) -- These M1s are meta-information for the datatype - to_alt_rhs = case gk_ of - Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars - Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys - where - argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where - converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . unboxRepRDR, - ata_par1 = nlHsVar unPar1_RDR, - ata_rec1 = const $ nlHsVar unRec1_RDR, - ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) - `nlHsCompose` nlHsVar unComp1_RDR} - - --- Generates the L1/R1 sum pattern -genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs -genLR_P i n p - | n == 0 = error "impossible" - | n == 1 = p - | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] - | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] - where m = div n 2 - --- Generates the L1/R1 sum expression -genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -genLR_E i n e - | n == 0 = error "impossible" - | n == 1 = e - | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E i (div n 2) e) - | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E (i-m) (n-m) e) - where m = div n 2 - --------------------------------------------------------------------------------- --- Dealing with products --------------------------------------------------------------------------------- - --- Build a product expression -mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> [(RdrName, Type)] - -- List of variables matched on the lhs and their types - -> LHsExpr GhcPs -- Resulting product expression -mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars) - -- These M1s are meta-information for the constructor - where - appVars = map (wrapArg_E gk_) varTys - prod a b = prodDataCon_RDR `nlHsApps` [a,b] - -wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs -wrapArg_E Gen0_DC (var, ty) = mkM1_E $ - boxRepRDR ty `nlHsVarApps` [var] - -- This M1 is meta-information for the selector -wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ - converter ty `nlHsApp` nlHsVar var - -- This M1 is meta-information for the selector - where converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . boxRepRDR, - ata_par1 = nlHsVar par1DataCon_RDR, - ata_rec1 = const $ nlHsVar rec1DataCon_RDR, - ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` - (nlHsVar fmap_RDR `nlHsApp` cnv)} - -boxRepRDR :: Type -> RdrName -boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs - -unboxRepRDR :: Type -> RdrName -unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs - --- Retrieve the RDRs associated with each URec data family instance --- constructor. See Note [Generics and unlifted types] -unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) -unboxedRepRDRs ty - | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) - | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) - | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) - | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) - | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) - | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) - | otherwise = Nothing - --- Build a product pattern -mkProd_P :: GenericKind -- Gen0 or Gen1 - -> [(RdrName, Type)] -- List of variables to match, - -- along with their types - -> LPat GhcPs -- Resulting product pattern -mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars) - -- These M1s are meta-information for the constructor - where - appVars = unzipWith (wrapArg_P gk) varTys - prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] - -wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs -wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) - -- This M1 is meta-information for the selector -wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] - -mkGenericLocal :: US -> RdrName -mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) - -x_RDR :: RdrName -x_RDR = mkVarUnqual (fsLit "x") - -x_Expr :: LHsExpr GhcPs -x_Expr = nlHsVar x_RDR - -x_Pat :: LPat GhcPs -x_Pat = nlVarPat x_RDR - -mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs -mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e - -mkM1_P :: LPat GhcPs -> LPat GhcPs -mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] - -nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -nlHsCompose x y = compose_RDR `nlHsApps` [x, y] - --- | Variant of foldr for producing balanced lists -foldBal :: (a -> a -> a) -> a -> [a] -> a -foldBal _ x [] = x -foldBal _ _ [y] = y -foldBal op x l = let (a,b) = splitAt (length l `div` 2) l - in foldBal op x a `op` foldBal op x b - -{- -Note [Generics and unlifted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, all constants are marked with K1/Rec0. The exception to this rule is -when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In -that case, we must use a data family instance of URec (from GHC.Generics) to -mark it. As a result, before we can generate K1 or unK1, we must first check -to see if the type is actually one of the unlifted types for which URec has a -data family instance; if so, we generate that instead. - -See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more -details on why URec is implemented the way it is. - -Note [Generating a correctly typed Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving -Generic(1). That is, it derives the ellipsis in the following: - - instance Generic Foo where - type Rep Foo = ... - -However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which -a Generic(1) instance is being derived, not the fully instantiated type. As a -result, tc_mkRepTy builds the most generalized Rep(1) instance possible using -the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This -can cause problems when the instance has instantiated type variables -(see #11732). As an example: - - data T a = MkT a - deriving instance Generic (T Int) - ==> - instance Generic (T Int) where - type Rep (T Int) = (... (Rec0 a)) -- wrong! - --XStandaloneDeriving is one way for the type variables to become instantiated. -Another way is when Generic1 is being derived for a datatype with a visible -kind binder, e.g., - - data P k (a :: k) = MkP k deriving Generic1 - ==> - instance Generic1 (P *) where - type Rep1 (P *) = (... (Rec0 k)) -- wrong! - -See Note [Unify kinds in deriving] in TcDeriv. - -In any such scenario, we must prevent a discrepancy between the LHS and RHS of -a Rep(1) instance. To do so, we create a type variable substitution that maps -the tyConTyVars of the TyCon to their counterparts in the fully instantiated -type. (For example, using T above as example, you'd map a :-> Int.) We then -apply the substitution to the RHS before generating the instance. - -A wrinkle in all of this: when forming the type variable substitution for -Generic1 instances, we map the last type variable of the tycon to Any. Why? -It's because of wily data types like this one (#15012): - - data T a = MkT (FakeOut a) - type FakeOut a = Int - -If we ignore a, then we'll produce the following Rep1 instance: - - instance Generic1 T where - type Rep1 T = ... (Rec0 (FakeOut a)) - ... - -Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we -ensure that `a` is mapped to Any: - - instance Generic1 T where - type Rep1 T = ... (Rec0 (FakeOut Any)) - ... - -And now all is good. - -Alternatively, we could have avoided this problem by expanding all type -synonyms on the RHSes of Rep1 instances. But we might blow up the size of -these types even further by doing this, so we choose not to do so. - -Note [Handling kinds in a Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Generic1 is poly-kinded, the representation types were generalized to -be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply -the kind of the instance being derived to all the representation type -constructors. For instance, if you have - - data Empty (a :: k) = Empty deriving Generic1 - -Then the generated code is now approximately (with -fprint-explicit-kinds -syntax): - - instance Generic1 k (Empty k) where - type Rep1 k (Empty k) = U1 k - -Most representation types have only one kind variable, making them easy to deal -with. The only non-trivial case is (:.:), which is only used in Generic1 -instances: - - newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = - Comp1 { unComp1 :: f (g p) } - -Here, we do something a bit counter-intuitive: we make k1 be the kind of the -instance being derived, and we always make k2 be *. Why *? It's because -the code that GHC generates using (:.:) is always of the form x :.: Rec1 y -for some types x and y. In other words, the second type to which (:.:) is -applied always has kind k -> *, for some kind k, so k2 cannot possibly be -anything other than * in a generated Generic1 instance. - -Note [Generics compilation speed tricks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Generic(1) is known to have a large constant factor during -compilation, which contributes to noticeable compilation slowdowns when -deriving Generic(1) for large datatypes (see #5642). - -To ease the pain, there is a trick one can play when generating definitions for -to(1) and from(1). If you have a datatype like: - - data Letter = A | B | C | D - -then a naïve Generic instance for Letter would be: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 (L1 (L1 (M1 U1)))) = A - to (M1 (L1 (R1 (M1 U1)))) = B - to (M1 (R1 (L1 (M1 U1)))) = C - to (M1 (R1 (R1 (M1 U1)))) = D - - from A = M1 (L1 (L1 (M1 U1))) - from B = M1 (L1 (R1 (M1 U1))) - from C = M1 (R1 (L1 (M1 U1))) - from D = M1 (R1 (R1 (M1 U1))) - -Notice that in every LHS pattern-match of the 'to' definition, and in every RHS -expression in the 'from' definition, the topmost constructor is M1. This -corresponds to the datatype-specific metadata (the D1 in the Rep Letter -instance). But this is wasteful from a typechecking perspective, since this -definition requires GHC to typecheck an application of M1 in every single case, -leading to an O(n) increase in the number of coercions the typechecker has to -solve, which in turn increases allocations and degrades compilation speed. - -Luckily, since the topmost M1 has the exact same type across every case, we can -factor it out reduce the typechecker's burden: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 x) = case x of - L1 (L1 (M1 U1)) -> A - L1 (R1 (M1 U1)) -> B - R1 (L1 (M1 U1)) -> C - R1 (R1 (M1 U1)) -> D - - from x = M1 (case x of - A -> L1 (L1 (M1 U1)) - B -> L1 (R1 (M1 U1)) - C -> R1 (L1 (M1 U1)) - D -> R1 (R1 (M1 U1))) - -A simple change, but one that pays off, since it goes turns an O(n) amount of -coercions to an O(1) amount. --} diff --git a/typecheck/TcHoleErrors.hs b/typecheck/TcHoleErrors.hs deleted file mode 100644 --- a/typecheck/TcHoleErrors.hs +++ /dev/null @@ -1,1001 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ExistentialQuantification #-} -module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits - , tcCheckHoleFit, tcSubsumes - , withoutUnification - , fromPureHFPlugin - -- Re-exports for convenience - , hfIsLcl - , pprHoleFit, debugHoleFitDispConfig - - -- Re-exported from TcHoleFitTypes - , TypedHole (..), HoleFit (..), HoleFitCandidate (..) - , CandPlugin, FitPlugin - , HoleFitPlugin (..), HoleFitPluginR (..) - ) where - -import GhcPrelude - -import TcRnTypes -import TcRnMonad -import Constraint -import TcOrigin -import TcMType -import TcEvidence -import TcType -import Type -import DataCon -import Name -import RdrName ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) -import PrelNames ( gHC_ERR ) -import Id -import VarSet -import VarEnv -import Bag -import ConLike ( ConLike(..) ) -import Util -import TcEnv (tcLookup) -import Outputable -import DynFlags -import Maybes -import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) - -import Control.Arrow ( (&&&) ) - -import Control.Monad ( filterM, replicateM, foldM ) -import Data.List ( partition, sort, sortOn, nubBy ) -import Data.Graph ( graphFromEdges, topSort ) - - -import TcSimplify ( simpl_top, runTcSDeriveds ) -import TcUnify ( tcSubType_NC ) - -import ExtractDocs ( extractDocs ) -import qualified Data.Map as Map -import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) -import HscTypes ( ModIface_(..) ) -import LoadIface ( loadInterfaceForNameMaybe ) - -import PrelInfo (knownKeyNames) - -import TcHoleFitTypes - - -{- -Note [Valid hole fits include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`findValidHoleFits` returns the "Valid hole fits include ..." message. -For example, look at the following definitions in a file called test.hs: - - import Data.List (inits) - - f :: [String] - f = _ "hello, world" - -The hole in `f` would generate the message: - - • Found hole: _ :: [Char] -> [String] - • In the expression: _ - In the expression: _ "hello, world" - In an equation for ‘f’: f = _ "hello, world" - • Relevant bindings include f :: [String] (bound at test.hs:6:1) - Valid hole fits include - lines :: String -> [String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - words :: String -> [String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - inits :: forall a. [a] -> [[a]] - with inits @Char - (imported from ‘Data.List’ at mpt.hs:4:19-23 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - repeat :: forall a. a -> [a] - with repeat @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.List’)) - fail :: forall (m :: * -> *). Monad m => forall a. String -> m a - with fail @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - return :: forall (m :: * -> *). Monad m => forall a. a -> m a - with return @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a - with pure @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - read :: forall a. Read a => String -> a - with read @[String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘Text.Read’)) - mempty :: forall a. Monoid a => a - with mempty @([Char] -> [String]) - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - -Valid hole fits are found by checking top level identifiers and local bindings -in scope for whether their type can be instantiated to the the type of the hole. -Additionally, we also need to check whether all relevant constraints are solved -by choosing an identifier of that type as well, see Note [Relevant Constraints] - -Since checking for subsumption results in the side-effect of type variables -being unified by the simplifier, we need to take care to restore them after -to being flexible type variables after we've checked for subsumption. -This is to avoid affecting the hole and later checks by prematurely having -unified one of the free unification variables. - -When outputting, we sort the hole fits by the size of the types we'd need to -apply by type application to the type of the fit to to make it fit. This is done -in order to display "more relevant" suggestions first. Another option is to -sort by building a subsumption graph of fits, i.e. a graph of which fits subsume -what other fits, and then outputting those fits which are are subsumed by other -fits (i.e. those more specific than other fits) first. This results in the ones -"closest" to the type of the hole to be displayed first. - -To help users understand how the suggested fit works, we also display the values -that the quantified type variables would take if that fit is used, like -`mempty @([Char] -> [String])` and `pure @[] @String` in the example above. -If -XTypeApplications is enabled, this can even be copied verbatim as a -replacement for the hole. - - -Note [Nested implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For the simplifier to be able to use any givens present in the enclosing -implications to solve relevant constraints, we nest the wanted subsumption -constraints and relevant constraints within the enclosing implications. - -As an example, let's look at the following code: - - f :: Show a => a -> String - f x = show _ - -The hole will result in the hole constraint: - - [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)) - -Here the nested implications are just one level deep, namely: - - [Implic { - TcLevel = 2 - Skolems = a_a1pa[sk:2] - No-eqs = True - Status = Unsolved - Given = $dShow_a1pc :: Show a_a1pa[sk:2] - Wanted = - WC {wc_simple = - [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_)) - [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))} - Binds = EvBindsVar - Needed inner = [] - Needed outer = [] - the type signature for: - f :: forall a. Show a => a -> String }] - -As we can see, the givens say that the information about the skolem -`a_a1pa[sk:2]` fulfills the Show constraint. - -The simples are: - - [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)] - -I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must -fulfill `Show a0_a1pd[tau:2])`. - -So when we run the check, we need to make sure that the - - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical) - -Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits -the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the -meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted -constraints needed by tcSubType_NC and the relevant constraints (see -Note [Relevant Constraints] for more details) in the nested implications, we -can pass the information in the givens along to the simplifier. For our example, -we end up needing to check whether the following constraints are soluble. - - WC {wc_impl = - Implic { - TcLevel = 2 - Skolems = a_a1pa[sk:2] - No-eqs = True - Status = Unsolved - Given = $dShow_a1pc :: Show a_a1pa[sk:2] - Wanted = - WC {wc_simple = - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} - Binds = EvBindsVar - Needed inner = [] - Needed outer = [] - the type signature for: - f :: forall a. Show a => a -> String }} - -But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested -implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up -with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match. - -To avoid side-effects on the nested implications, we create a new EvBindsVar so -that any changes to the ev binds during a check remains localised to that check. - - -Note [Valid refinement hole fits include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the `-frefinement-level-hole-fits=N` flag is given, we additionally look -for "valid refinement hole fits"", i.e. valid hole fits with up to N -additional holes in them. - -With `-frefinement-level-hole-fits=0` (the default), GHC will find all -identifiers 'f' (top-level or nested) that will fit in the hole. - -With `-frefinement-level-hole-fits=1`, GHC will additionally find all -applications 'f _' that will fit in the hole, where 'f' is an in-scope -identifier, applied to single argument. It will also report the type of the -needed argument (a new hole). - -And similarly as the number of arguments increases - -As an example, let's look at the following code: - - f :: [Integer] -> Integer - f = _ - -with `-frefinement-level-hole-fits=1`, we'd get: - - Valid refinement hole fits include - - foldl1 (_ :: Integer -> Integer -> Integer) - with foldl1 @[] @Integer - where foldl1 :: forall (t :: * -> *). - Foldable t => - forall a. (a -> a -> a) -> t a -> a - foldr1 (_ :: Integer -> Integer -> Integer) - with foldr1 @[] @Integer - where foldr1 :: forall (t :: * -> *). - Foldable t => - forall a. (a -> a -> a) -> t a -> a - const (_ :: Integer) - with const @Integer @[Integer] - where const :: forall a b. a -> b -> a - ($) (_ :: [Integer] -> Integer) - with ($) @'GHC.Types.LiftedRep @[Integer] @Integer - where ($) :: forall a b. (a -> b) -> a -> b - fail (_ :: String) - with fail @((->) [Integer]) @Integer - where fail :: forall (m :: * -> *). - Monad m => - forall a. String -> m a - return (_ :: Integer) - with return @((->) [Integer]) @Integer - where return :: forall (m :: * -> *). Monad m => forall a. a -> m a - (Some refinement hole fits suppressed; - use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits) - -Which are hole fits with holes in them. This allows e.g. beginners to -discover the fold functions and similar, but also allows for advanced users -to figure out the valid functions in the Free monad, e.g. - - instance Functor f => Monad (Free f) where - Pure a >>= f = f a - Free f >>= g = Free (fmap _a f) - -Will output (with -frefinment-level-hole-fits=1): - Found hole: _a :: Free f a -> Free f b - Where: ‘a’, ‘b’ are rigid type variables bound by - the type signature for: - (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b - at fms.hs:25:12-14 - ‘f’ is a rigid type variable bound by - ... - Relevant bindings include - g :: a -> Free f b (bound at fms.hs:27:16) - f :: f (Free f a) (bound at fms.hs:27:10) - (>>=) :: Free f a -> (a -> Free f b) -> Free f b - (bound at fms.hs:25:12) - ... - Valid refinement hole fits include - ... - (=<<) (_ :: a -> Free f b) - with (=<<) @(Free f) @a @b - where (=<<) :: forall (m :: * -> *) a b. - Monad m => - (a -> m b) -> m a -> m b - (imported from ‘Prelude’ at fms.hs:5:18-22 - (and originally defined in ‘GHC.Base’)) - ... - -Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`). - -We find these refinement suggestions by considering hole fits that don't -fit the type of the hole, but ones that would fit if given an additional -argument. We do this by creating a new type variable with `newOpenFlexiTyVar` -(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type -`t_a1/m[tau:1] -> v` where `v` is the type of the hole. - -Since the simplifier is free to unify this new type variable with any type, we -can discover any identifiers that would fit if given another identifier of a -suitable type. This is then generalized so that we can consider any number of -additional arguments by setting the `-frefinement-level-hole-fits` flag to any -number, and then considering hole fits like e.g. `foldl _ _` with two additional -arguments. - -To make sure that the refinement hole fits are useful, we check that the types -of the additional holes have a concrete value and not just an invented type -variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`, -and limits the number of less than useful refinement hole fits. - -Additionally, to further aid the user in their implementation, we show the -types of the holes the binding would have to be applied to in order to work. -In the free monad example above, this is demonstrated with -`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to -be applied to an expression of type `a -> Free f b` in order to match. -If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim. - - -Note [Relevant Constraints] -~~~~~~~~~~~~~~~~~~~ - -As highlighted by #14273, we need to check any relevant constraints as well -as checking for subsumption. Relevant constraints are the simple constraints -whose free unification variables are mentioned in the type of the hole. - -In the simplest case, these are all non-hole constraints in the simples, such -as is the case in - - f :: String - f = show _ - -Where the simples will be : - - [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)] - -However, when there are multiple holes, we need to be more careful. As an -example, Let's take a look at the following code: - - f :: Show a => a -> String - f x = show (_b (show _a)) - -Here there are two holes, `_a` and `_b`, and the simple constraints passed to -findValidHoleFits are: - - [[WD] _a_a1pi {0}:: String - -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)), - [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), - [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] - - -Here we have the two hole constraints for `_a` and `_b`, but also additional -constraints that these holes must fulfill. When we are looking for a match for -the hole `_a`, we filter the simple constraints to the "Relevant constraints", -by throwing out all hole constraints and any constraints which do not mention -a variable mentioned in the type of the hole. For hole `_a`, we will then -only require that the `$dShow_a1pp` constraint is solved, since that is -the only non-hole constraint that mentions any free type variables mentioned in -the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the -hole `_b` we only require that the `$dShow_a1pe` constraint is solved. - -Note [Leaking errors] -~~~~~~~~~~~~~~~~~~~ - -When considering candidates, GHC believes that we're checking for validity in -actual source. However, As evidenced by #15321, #15007 and #15202, this can -cause bewildering error messages. The solution here is simple: if a candidate -would cause the type checker to error, it is not a valid hole fit, and thus it -is discarded. - --} - - -data HoleFitDispConfig = HFDC { showWrap :: Bool - , showWrapVars :: Bool - , showType :: Bool - , showProv :: Bool - , showMatches :: Bool } - -debugHoleFitDispConfig :: HoleFitDispConfig -debugHoleFitDispConfig = HFDC True True True False False - - --- We read the various -no-show-*-of-hole-fits flags --- and set the display config accordingly. -getHoleFitDispConfig :: TcM HoleFitDispConfig -getHoleFitDispConfig - = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits - ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits - ; sType <- goptM Opt_ShowTypeOfHoleFits - ; sProv <- goptM Opt_ShowProvOfHoleFits - ; sMatc <- goptM Opt_ShowMatchesOfHoleFits - ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars - , showProv = sProv, showType = sType - , showMatches = sMatc } } - --- Which sorting algorithm to use -data SortingAlg = NoSorting -- Do not sort the fits at all - | BySize -- Sort them by the size of the match - | BySubsumption -- Sort by full subsumption - deriving (Eq, Ord) - -getSortingAlg :: TcM SortingAlg -getSortingAlg = - do { shouldSort <- goptM Opt_SortValidHoleFits - ; subsumSort <- goptM Opt_SortBySubsumHoleFits - ; sizeSort <- goptM Opt_SortBySizeHoleFits - -- We default to sizeSort unless it has been explicitly turned off - -- or subsumption sorting has been turned on. - ; return $ if not shouldSort - then NoSorting - else if subsumSort - then BySubsumption - else if sizeSort - then BySize - else NoSorting } - --- If enabled, we go through the fits and add any associated documentation, --- by looking it up in the module or the environment (for local fits) -addDocs :: [HoleFit] -> TcM [HoleFit] -addDocs fits = - do { showDocs <- goptM Opt_ShowDocsOfHoleFits - ; if showDocs - then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv - ; mapM (upd lclDocs) fits } - else return fits } - where - msg = text "TcHoleErrors addDocs" - lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) - = Map.lookup name dmap - upd lclDocs fit@(HoleFit {hfCand = cand}) = - do { let name = getName cand - ; doc <- if hfIsLcl fit - then pure (Map.lookup name lclDocs) - else do { mbIface <- loadInterfaceForNameMaybe msg name - ; return $ mbIface >>= lookupInIface name } - ; return $ fit {hfDoc = doc} } - upd _ fit = return fit - --- For pretty printing hole fits, we display the name and type of the fit, --- with added '_' to represent any extra arguments in case of a non-zero --- refinement level. -pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc -pprHoleFit _ (RawHoleFit sd) = sd -pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = - hang display 2 provenance - where name = getName hfCand - tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap - where pprArg b arg = case binderArgFlag b of - Specified -> text "@" <> pprParendType arg - -- Do not print type application for inferred - -- variables (#16456) - Inferred -> empty - Required -> pprPanic "pprHoleFit: bad Required" - (ppr b <+> ppr arg) - tyAppVars = sep $ punctuate comma $ - zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> - text "~" <+> pprParendType t) - vars hfWrap - - vars = unwrapTypeVars hfType - where - -- Attempts to get all the quantified type variables in a type, - -- e.g. - -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) - -- into [m, a] - unwrapTypeVars :: Type -> [TyCoVarBinder] - unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, unfunned) -> unwrapTypeVars unfunned - _ -> [] - where (vars, unforalled) = splitForAllVarBndrs t - holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches - holeDisp = if sMs then holeVs - else sep $ replicate (length hfMatches) $ text "_" - occDisp = pprPrefixOcc name - tyDisp = ppWhen sTy $ dcolon <+> ppr hfType - has = not . null - wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) - $ text "with" <+> if sWrp || not sTy - then occDisp <+> tyApp - else tyAppVars - docs = case hfDoc of - Just d -> text "{-^" <> - (vcat . map text . lines . unpackHDS) d - <> text "-}" - _ -> empty - funcInfo = ppWhen (has hfMatches && sTy) $ - text "where" <+> occDisp <+> tyDisp - subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp - display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) - provenance = ppWhen sProv $ parens $ - case hfCand of - GreHFCand gre -> pprNameProvenance gre - _ -> text "bound at" <+> ppr (getSrcLoc name) - -getLocalBindings :: TidyEnv -> Ct -> TcM [Id] -getLocalBindings tidy_orig ct - = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc) - ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) } - where - loc = ctEvLoc (ctEvidence ct) - lcl_env = ctLocEnv loc - - go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id] - go _ sofar [] = return (reverse sofar) - go env sofar (tc_bndr : tc_bndrs) = - case tc_bndr of - TcIdBndr id _ -> keep_it id - _ -> discard_it - where - discard_it = go env sofar tc_bndrs - keep_it id = go env (id:sofar) tc_bndrs - - - --- See Note [Valid hole fits include ...] -findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking - -> [Implication] -- ^ Enclosing implications for givens - -> [Ct] - -- ^ The unsolved simple constraints in the implication for - -- the hole. - -> Ct -- ^ The hole constraint itself - -> TcM (TidyEnv, SDoc) -findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct = - do { rdr_env <- getGlobalRdrEnv - ; lclBinds <- getLocalBindings tidy_env ct - ; maxVSubs <- maxValidHoleFits <$> getDynFlags - ; hfdc <- getHoleFitDispConfig - ; sortingAlg <- getSortingAlg - ; dflags <- getDynFlags - ; hfPlugs <- tcg_hf_plugins <$> getGblEnv - ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs - refLevel = refLevelHoleFits dflags - hole = TyH (listToBag relevantCts) implics (Just ct) - (candidatePlugins, fitPlugins) = - unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs - ; traceTc "findingValidHoleFitsFor { " $ ppr hole - ; traceTc "hole_lvl is:" $ ppr hole_lvl - ; traceTc "simples are: " $ ppr simples - ; traceTc "locals are: " $ ppr lclBinds - ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env) - -- We remove binding shadowings here, but only for the local level. - -- this is so we e.g. suggest the global fmap from the Functor class - -- even though there is a local definition as well, such as in the - -- Free monad example. - locals = removeBindingShadowing $ - map IdHFCand lclBinds ++ map GreHFCand lcl - globals = map GreHFCand gbl - syntax = map NameHFCand builtIns - to_check = locals ++ syntax ++ globals - ; cands <- foldM (flip ($)) to_check candidatePlugins - ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) - ; (searchDiscards, subs) <- - tcFilterHoleFits findVLimit hole (hole_ty, []) cands - ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs - ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs - ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins - ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs - vDiscards = pVDisc || searchDiscards - ; subs_with_docs <- addDocs limited_subs - ; let vMsg = ppUnless (null subs_with_docs) $ - hang (text "Valid hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) subs_with_docs) - $$ ppWhen vDiscards subsDiscardMsg - -- Refinement hole fits. See Note [Valid refinement hole fits include ...] - ; (tidy_env, refMsg) <- if refLevel >= Just 0 then - do { maxRSubs <- maxRefHoleFits <$> getDynFlags - -- We can use from just, since we know that Nothing >= _ is False. - ; let refLvls = [1..(fromJust refLevel)] - -- We make a new refinement type for each level of refinement, where - -- the level of refinement indicates number of additional arguments - -- to allow. - ; ref_tys <- mapM mkRefTy refLvls - ; traceTc "ref_tys are" $ ppr ref_tys - ; let findRLimit = if sortingAlg > NoSorting then Nothing - else maxRSubs - ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) - cands) ref_tys - ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs - ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs - -- For refinement substitutions we want matches - -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t), - -- and others in that vein to appear last, since these are - -- unlikely to be the most relevant fits. - ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty - ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap - (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs - ; plugin_handled_rsubs <- foldM (flip ($)) - (not_exact ++ exact) fitPlugins - ; let (pRDisc, exact_last_rfits) = - possiblyDiscard maxRSubs $ plugin_handled_rsubs - rDiscards = pRDisc || any fst refDs - ; rsubs_with_docs <- addDocs exact_last_rfits - ; return (tidy_env, - ppUnless (null rsubs_with_docs) $ - hang (text "Valid refinement hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) rsubs_with_docs) - $$ ppWhen rDiscards refSubsDiscardMsg) } - else return (tidy_env, empty) - ; traceTc "findingValidHoleFitsFor }" empty - ; return (tidy_env, vMsg $$ refMsg) } - where - -- We extract the type, the tcLevel and the types free variables - -- from from the constraint. - hole_ty :: TcPredType - hole_ty = ctPred ct - hole_fvs :: FV - hole_fvs = tyCoFVsOfType hole_ty - hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct - - -- BuiltInSyntax names like (:) and [] - builtIns :: [Name] - builtIns = filter isBuiltInSyntax knownKeyNames - - -- We make a refinement type by adding a new type variable in front - -- of the type of t h hole, going from e.g. [Integer] -> Integer - -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier - -- to unify the new type variable with any type, allowing us - -- to suggest a "refinement hole fit", like `(foldl1 _)` instead - -- of only concrete hole fits like `sum`. - mkRefTy :: Int -> TcM (TcType, [TcTyVar]) - mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars - where newTyVars = replicateM refLvl $ setLvl <$> - (newOpenTypeKind >>= newFlexiTyVar) - setLvl = flip setMetaTyVarTcLevel hole_lvl - wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty - - sortFits :: SortingAlg -- How we should sort the hole fits - -> [HoleFit] -- The subs to sort - -> TcM [HoleFit] - sortFits NoSorting subs = return subs - sortFits BySize subs - = (++) <$> sortBySize (sort lclFits) - <*> sortBySize (sort gblFits) - where (lclFits, gblFits) = span hfIsLcl subs - - -- To sort by subsumption, we invoke the sortByGraph function, which - -- builds the subsumption graph for the fits and then sorts them using a - -- graph sort. Since we want locals to come first anyway, we can sort - -- them separately. The substitutions are already checked in local then - -- global order, so we can get away with using span here. - -- We use (<*>) to expose the parallelism, in case it becomes useful later. - sortFits BySubsumption subs - = (++) <$> sortByGraph (sort lclFits) - <*> sortByGraph (sort gblFits) - where (lclFits, gblFits) = span hfIsLcl subs - - -- See Note [Relevant Constraints] - relevantCts :: [Ct] - relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then [] - else filter isRelevant simples - where ctFreeVarSet :: Ct -> VarSet - ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred - hole_fv_set = fvVarSet hole_fvs - anyFVMentioned :: Ct -> Bool - anyFVMentioned ct = not $ isEmptyVarSet $ - ctFreeVarSet ct `intersectVarSet` hole_fv_set - -- We filter out those constraints that have no variables (since - -- they won't be solved by finding a type for the type variable - -- representing the hole) and also other holes, since we're not - -- trying to find hole fits for many holes at once. - isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct)) - && anyFVMentioned ct - && not (isHoleCt ct) - - -- We zonk the hole fits so that the output aligns with the rest - -- of the typed hole error message output. - zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) - zonkSubs = zonkSubs' [] - where zonkSubs' zs env [] = return (env, reverse zs) - zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf - ; zonkSubs' (z:zs) env' hfs } - - zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit) - zonkSub env hf@RawHoleFit{} = return (env, hf) - zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp} - = do { (env, ty') <- zonkTidyTcType env ty - ; (env, m') <- zonkTidyTcTypes env m - ; (env, wrp') <- zonkTidyTcTypes env wrp - ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} - ; return (env, zFit ) } - - -- Based on the flags, we might possibly discard some or all the - -- fits we've found. - possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) - possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits) - possiblyDiscard Nothing fits = (False, fits) - - -- Sort by size uses as a measure for relevance the sizes of the - -- different types needed to instantiate the fit to the type of the hole. - -- This is much quicker than sorting by subsumption, and gives reasonable - -- results in most cases. - sortBySize :: [HoleFit] -> TcM [HoleFit] - sortBySize = return . sortOn sizeOfFit - where sizeOfFit :: HoleFit -> TypeSize - sizeOfFit = sizeTypes . nubBy tcEqType . hfWrap - - -- Based on a suggestion by phadej on #ghc, we can sort the found fits - -- by constructing a subsumption graph, and then do a topological sort of - -- the graph. This makes the most specific types appear first, which are - -- probably those most relevant. This takes a lot of work (but results in - -- much more useful output), and can be disabled by - -- '-fno-sort-valid-hole-fits'. - sortByGraph :: [HoleFit] -> TcM [HoleFit] - sortByGraph fits = go [] fits - where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool - tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty) - where fvs = tyCoFVsOfTypes [ht,ty] - go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit] - go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar - ; return $ uncurry (++) - $ partition hfIsLcl topSorted } - where toV (hf, adjs) = (hf, hfId hf, map hfId adjs) - (graph, fromV, _) = graphFromEdges $ map toV sofar - topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph - go sofar (hf:hfs) = - do { adjs <- - filterM (tcSubsumesWCloning (hfType hf) . hfType) fits - ; go ((hf, adjs):sofar) hfs } - --- We don't (as of yet) handle holes in types, only in expressions. -findValidHoleFits env _ _ _ = return (env, empty) - - --- | tcFilterHoleFits filters the candidates by whether, given the implications --- and the relevant constraints, they can be made to match the type by --- running the type checker. Stops after finding limit matches. -tcFilterHoleFits :: Maybe Int - -- ^ How many we should output, if limited - -> TypedHole -- ^ The hole to filter against - -> (TcType, [TcTyVar]) - -- ^ The type to check for fits and a list of refinement - -- variables (free type variables in the type) for emulating - -- additional holes. - -> [HoleFitCandidate] - -- ^ The candidates to check whether fit. - -> TcM (Bool, [HoleFit]) - -- ^ We return whether or not we stopped due to hitting the limit - -- and the fits we found. -tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 -tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates = - do { traceTc "checkingFitsFor {" $ ppr hole_ty - ; (discards, subs) <- go [] emptyVarSet limit ht candidates - ; traceTc "checkingFitsFor }" empty - ; return (discards, subs) } - where - hole_fvs :: FV - hole_fvs = tyCoFVsOfType hole_ty - -- Kickoff the checking of the elements. - -- We iterate over the elements, checking each one in turn for whether - -- it fits, and adding it to the results if it does. - go :: [HoleFit] -- What we've found so far. - -> VarSet -- Ids we've already checked - -> Maybe Int -- How many we're allowed to find, if limited - -> (TcType, [TcTyVar]) -- The type, and its refinement variables. - -> [HoleFitCandidate] -- The elements we've yet to check. - -> TcM (Bool, [HoleFit]) - go subs _ _ _ [] = return (False, reverse subs) - go subs _ (Just 0) _ _ = return (True, reverse subs) - go subs seen maxleft ty (el:elts) = - -- See Note [Leaking errors] - tryTcDiscardingErrs discard_it $ - do { traceTc "lookingUp" $ ppr el - ; maybeThing <- lookup el - ; case maybeThing of - Just id | not_trivial id -> - do { fits <- fitsHole ty (idType id) - ; case fits of - Just (wrp, matches) -> keep_it id wrp matches - _ -> discard_it } - _ -> discard_it } - where - -- We want to filter out undefined and the likes from GHC.Err - not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR - - lookup :: HoleFitCandidate -> TcM (Maybe Id) - lookup (IdHFCand id) = return (Just id) - lookup hfc = do { thing <- tcLookup name - ; return $ case thing of - ATcId {tct_id = id} -> Just id - AGlobal (AnId id) -> Just id - AGlobal (AConLike (RealDataCon con)) -> - Just (dataConWrapId con) - _ -> Nothing } - where name = case hfc of - IdHFCand id -> idName id - GreHFCand gre -> gre_name gre - NameHFCand name -> name - discard_it = go subs seen maxleft ty elts - keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid) - ((\n -> n - 1) <$> maxleft) ty elts - where - fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid) - , hfRefLvl = length (snd ty) - , hfWrap = wrp, hfMatches = ms - , hfDoc = Nothing } - - - - - unfoldWrapper :: HsWrapper -> [Type] - unfoldWrapper = reverse . unfWrp' - where unfWrp' (WpTyApp ty) = [ty] - unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2 - unfWrp' _ = [] - - - -- The real work happens here, where we invoke the type checker using - -- tcCheckHoleFit to see whether the given type fits the hole. - fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the - -- refinement variables created to simulate - -- additional holes (if any), and the list - -- of those variables (possibly empty). - -- As an example: If the actual type of the - -- hole (as specified by the hole - -- constraint CHoleExpr passed to - -- findValidHoleFits) is t and we want to - -- simulate N additional holes, h_ty will - -- be r_1 -> ... -> r_N -> t, and - -- ref_vars will be [r_1, ... , r_N]. - -- In the base case with no additional - -- holes, h_ty will just be t and ref_vars - -- will be []. - -> TcType -- The type we're checking to whether it can be - -- instantiated to the type h_ty. - -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we - -- return Nothing. Otherwise, - -- we Just return the list of - -- types that quantified type - -- variables in ty would take - -- if used in place of h_ty, - -- and the list types of any - -- additional holes simulated - -- with the refinement - -- variables in ref_vars. - fitsHole (h_ty, ref_vars) ty = - -- We wrap this with the withoutUnification to avoid having side-effects - -- beyond the check, but we rely on the side-effects when looking for - -- refinement hole fits, so we can't wrap the side-effects deeper than this. - withoutUnification fvs $ - do { traceTc "checkingFitOf {" $ ppr ty - ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty - ; traceTc "Did it fit?" $ ppr fits - ; traceTc "wrap is: " $ ppr wrp - ; traceTc "checkingFitOf }" empty - ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) - -- We'd like to avoid refinement suggestions like `id _ _` or - -- `head _ _`, and only suggest refinements where our all phantom - -- variables got unified during the checking. This can be disabled - -- with the `-fabstract-refinement-hole-fits` flag. - -- Here we do the additional handling when there are refinement - -- variables, i.e. zonk them to read their final value to check for - -- abstract refinements, and to report what the type of the simulated - -- holes must be for this to be a match. - ; if fits - then if null ref_vars - then return (Just (z_wrp_tys, [])) - else do { let -- To be concrete matches, matches have to - -- be more than just an invented type variable. - fvSet = fvVarSet fvs - notAbstract :: TcType -> Bool - notAbstract t = case getTyVar_maybe t of - Just tv -> tv `elemVarSet` fvSet - _ -> True - allConcrete = all notAbstract z_wrp_tys - ; z_vars <- zonkTcTyVars ref_vars - ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars - ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs - ; allowAbstract <- goptM Opt_AbstractRefHoleFits - ; if allowAbstract || (allFilled && allConcrete ) - then return $ Just (z_wrp_tys, z_vars) - else return Nothing } - else return Nothing } - where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty - hole = TyH tyHRelevantCts tyHImplics Nothing - - -subsDiscardMsg :: SDoc -subsDiscardMsg = - text "(Some hole fits suppressed;" <+> - text "use -fmax-valid-hole-fits=N" <+> - text "or -fno-max-valid-hole-fits)" - -refSubsDiscardMsg :: SDoc -refSubsDiscardMsg = - text "(Some refinement hole fits suppressed;" <+> - text "use -fmax-refinement-hole-fits=N" <+> - text "or -fno-max-refinement-hole-fits)" - - --- | Checks whether a MetaTyVar is flexible or not. -isFlexiTyVar :: TcTyVar -> TcM Bool -isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv -isFlexiTyVar _ = return False - --- | Takes a list of free variables and restores any Flexi type variables in --- free_vars after the action is run. -withoutUnification :: FV -> TcM a -> TcM a -withoutUnification free_vars action = - do { flexis <- filterM isFlexiTyVar fuvs - ; result <- action - -- Reset any mutated free variables - ; mapM_ restore flexis - ; return result } - where restore = flip writeTcRef Flexi . metaTyVarRef - fuvs = fvVarList free_vars - --- | Reports whether first type (ty_a) subsumes the second type (ty_b), --- discarding any errors. Subsumption here means that the ty_b can fit into the --- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. -tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool -tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b - where dummyHole = TyH emptyBag [] Nothing - --- | A tcSubsumes which takes into account relevant constraints, to fix trac --- #14273. This makes sure that when checking whether a type fits the hole, --- the type has to be subsumed by type of the hole as well as fulfill all --- constraints on the type of the hole. --- Note: The simplifier may perform unification, so make sure to restore any --- free type variables to avoid side-effects. -tcCheckHoleFit :: TypedHole -- ^ The hole to check against - -> TcSigmaType - -- ^ The type to check against (possibly modified, e.g. refined) - -> TcSigmaType -- ^ The type to check whether fits. - -> TcM (Bool, HsWrapper) - -- ^ Whether it was a match, and the wrapper from hole_ty to ty. -tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty - = return (True, idHsWrapper) -tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ - do { -- We wrap the subtype constraint in the implications to pass along the - -- givens, and so we must ensure that any nested implications and skolems - -- end up with the correct level. The implications are ordered so that - -- the innermost (the one with the highest level) is first, so it - -- suffices to get the level of the first one (or the current level, if - -- there are no implications involved). - innermost_lvl <- case tyHImplics of - [] -> getTcLevel - -- imp is the innermost implication - (imp:_) -> return (ic_tclvl imp) - ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ - tcSubType_NC ExprSigCtxt ty hole_ty - ; traceTc "Checking hole fit {" empty - ; traceTc "wanteds are: " $ ppr wanted - ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts - then traceTc "}" empty >> return (True, wrp) - else do { fresh_binds <- newTcEvBinds - -- The relevant constraints may contain HoleDests, so we must - -- take care to clone them as well (to avoid #15370). - ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts - -- We wrap the WC in the nested implications, see - -- Note [Nested Implications] - ; let outermost_first = reverse tyHImplics - setWC = setWCAndBinds fresh_binds - -- We add the cloned relevants to the wanteds generated by - -- the call to tcSubType_NC, see Note [Relevant Constraints] - -- There's no need to clone the wanteds, because they are - -- freshly generated by `tcSubtype_NC`. - w_rel_cts = addSimples wanted cloned_relevants - w_givens = foldr setWC w_rel_cts outermost_first - ; traceTc "w_givens are: " $ ppr w_givens - ; rem <- runTcSDeriveds $ simpl_top w_givens - -- We don't want any insoluble or simple constraints left, but - -- solved implications are ok (and neccessary for e.g. undefined) - ; traceTc "rems was:" $ ppr rem - ; traceTc "}" empty - ; return (isSolvedWC rem, wrp) } } - where - setWCAndBinds :: EvBindsVar -- Fresh ev binds var. - -> Implication -- The implication to put WC in. - -> WantedConstraints -- The WC constraints to put implic. - -> WantedConstraints -- The new constraints. - setWCAndBinds binds imp wc - = WC { wc_simple = emptyBag - , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } } - --- | Maps a plugin that needs no state to one with an empty one. -fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR -fromPureHFPlugin plug = - HoleFitPluginR { hfPluginInit = newTcRef () - , hfPluginRun = const plug - , hfPluginStop = const $ return () } diff --git a/typecheck/TcHoleErrors.hs-boot b/typecheck/TcHoleErrors.hs-boot deleted file mode 100644 --- a/typecheck/TcHoleErrors.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ --- This boot file is in place to break the loop where: --- + TcSimplify calls 'TcErrors.reportUnsolved', --- + which calls 'TcHoleErrors.findValidHoleFits` --- + which calls 'TcSimplify.simpl_top' -module TcHoleErrors where - -import TcRnTypes ( TcM ) -import Constraint ( Ct, Implication ) -import Outputable ( SDoc ) -import VarEnv ( TidyEnv ) - -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct - -> TcM (TidyEnv, SDoc) diff --git a/typecheck/TcHoleFitTypes.hs b/typecheck/TcHoleFitTypes.hs deleted file mode 100644 --- a/typecheck/TcHoleFitTypes.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module TcHoleFitTypes ( - TypedHole (..), HoleFit (..), HoleFitCandidate (..), - CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..), - hfIsLcl, pprHoleFitCand - ) where - -import GhcPrelude - -import TcRnTypes -import Constraint -import TcType - -import RdrName - -import GHC.Hs.Doc -import Id - -import Outputable -import Name - -import Data.Function ( on ) - -data TypedHole = TyH { tyHRelevantCts :: Cts - -- ^ Any relevant Cts to the hole - , tyHImplics :: [Implication] - -- ^ The nested implications of the hole with the - -- innermost implication first. - , tyHCt :: Maybe Ct - -- ^ The hole constraint itself, if available. - } - -instance Outputable TypedHole where - ppr (TyH rels implics ct) - = hang (text "TypedHole") 2 - (ppr rels $+$ ppr implics $+$ ppr ct) - - --- | HoleFitCandidates are passed to hole fit plugins and then --- checked whether they fit a given typed-hole. -data HoleFitCandidate = IdHFCand Id -- An id, like locals. - | NameHFCand Name -- A name, like built-in syntax. - | GreHFCand GlobalRdrElt -- A global, like imported ids. - deriving (Eq) - -instance Outputable HoleFitCandidate where - ppr = pprHoleFitCand - -pprHoleFitCand :: HoleFitCandidate -> SDoc -pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid -pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname -pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre - - - - -instance NamedThing HoleFitCandidate where - getName hfc = case hfc of - IdHFCand cid -> idName cid - NameHFCand cname -> cname - GreHFCand cgre -> gre_name cgre - getOccName hfc = case hfc of - IdHFCand cid -> occName cid - NameHFCand cname -> occName cname - GreHFCand cgre -> occName (gre_name cgre) - -instance HasOccName HoleFitCandidate where - occName = getOccName - -instance Ord HoleFitCandidate where - compare = compare `on` getName - --- | HoleFit is the type we use for valid hole fits. It contains the --- element that was checked, the Id of that element as found by `tcLookup`, --- and the refinement level of the fit, which is the number of extra argument --- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`). -data HoleFit = - HoleFit { hfId :: Id -- ^ The elements id in the TcM - , hfCand :: HoleFitCandidate -- ^ The candidate that was checked. - , hfType :: TcType -- ^ The type of the id, possibly zonked. - , hfRefLvl :: Int -- ^ The number of holes in this fit. - , hfWrap :: [TcType] -- ^ The wrapper for the match. - , hfMatches :: [TcType] - -- ^ What the refinement variables got matched with, if anything - , hfDoc :: Maybe HsDocString - -- ^ Documentation of this HoleFit, if available. - } - | RawHoleFit SDoc - -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins - -- can inject any fit they want. - --- We define an Eq and Ord instance to be able to build a graph. -instance Eq HoleFit where - (==) = (==) `on` hfId - -instance Outputable HoleFit where - ppr (RawHoleFit sd) = sd - ppr (HoleFit _ cand ty _ _ mtchs _) = - hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty)) - where name = ppr $ getName cand - holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs - --- We compare HoleFits by their name instead of their Id, since we don't --- want our tests to be affected by the non-determinism of `nonDetCmpVar`, --- which is used to compare Ids. When comparing, we want HoleFits with a lower --- refinement level to come first. -instance Ord HoleFit where - compare (RawHoleFit _) (RawHoleFit _) = EQ - compare (RawHoleFit _) _ = LT - compare _ (RawHoleFit _) = GT - compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b - where cmp = if hfRefLvl a == hfRefLvl b - then compare `on` (getName . hfCand) - else compare `on` hfRefLvl - -hfIsLcl :: HoleFit -> Bool -hfIsLcl hf@(HoleFit {}) = case hfCand hf of - IdHFCand _ -> True - NameHFCand _ -> False - GreHFCand gre -> gre_lcl gre -hfIsLcl _ = False - - --- | A plugin for modifying the candidate hole fits *before* they're checked. -type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate] - --- | A plugin for modifying hole fits *after* they've been found. -type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit] - --- | A HoleFitPlugin is a pair of candidate and fit plugins. -data HoleFitPlugin = HoleFitPlugin - { candPlugin :: CandPlugin - , fitPlugin :: FitPlugin } - --- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can --- track internal state. Note the existential quantification, ensuring that --- the state cannot be modified from outside the plugin. -data HoleFitPluginR = forall s. HoleFitPluginR - { hfPluginInit :: TcM (TcRef s) - -- ^ Initializes the TcRef to be passed to the plugin - , hfPluginRun :: TcRef s -> HoleFitPlugin - -- ^ The function defining the plugin itself - , hfPluginStop :: TcRef s -> TcM () - -- ^ Cleanup of state, guaranteed to be called even on error - } diff --git a/typecheck/TcHoleFitTypes.hs-boot b/typecheck/TcHoleFitTypes.hs-boot deleted file mode 100644 --- a/typecheck/TcHoleFitTypes.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ --- This boot file is in place to break the loop where: --- + TcRnTypes needs 'HoleFitPlugin', --- + which needs 'TcHoleFitTypes' --- + which needs 'TcRnTypes' -module TcHoleFitTypes where - --- Build ordering -import GHC.Base() - -data HoleFitPlugin diff --git a/typecheck/TcHsSyn.hs b/typecheck/TcHsSyn.hs deleted file mode 100644 --- a/typecheck/TcHsSyn.hs +++ /dev/null @@ -1,1943 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker - -This module is an extension of @HsSyn@ syntax, for use in the type -checker. --} - -{-# LANGUAGE CPP, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -module TcHsSyn ( - -- * Extracting types from HsSyn - hsLitType, hsPatType, hsLPatType, - - -- * Other HsSyn functions - mkHsDictLet, mkHsApp, - mkHsAppTy, mkHsCaseAlt, - shortCutLit, hsOverLitName, - conLikeResTy, - - -- * re-exported from TcMonad - TcId, TcIdSet, - - -- * Zonking - -- | For a description of "zonking", see Note [What is zonking?] - -- in TcMType - zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, - ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, - zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, - zonkTyBndrs, zonkTyBndrsX, - zonkTcTypeToType, zonkTcTypeToTypeX, - zonkTcTypesToTypes, zonkTcTypesToTypesX, - zonkTyVarOcc, - zonkCoToCo, - zonkEvBinds, zonkTcEvBinds, - zonkTcMethInfoToMethInfoX, - lookupTyVarOcc - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import Id -import IdInfo -import Predicate -import TcRnMonad -import PrelNames -import BuildTyCl ( TcMethInfo, MethInfo ) -import TcType -import TcMType -import TcEnv ( tcLookupGlobalOnly ) -import TcEvidence -import TyCoPpr ( pprTyVar ) -import TysPrim -import TyCon -import TysWiredIn -import Type -import Coercion -import ConLike -import DataCon -import HscTypes -import Name -import NameEnv -import Var -import VarEnv -import DynFlags -import Literal -import BasicTypes -import Maybes -import SrcLoc -import Bag -import Outputable -import Util -import UniqFM -import CoreSyn - -import {-# SOURCE #-} TcSplice (runTopSplice) - -import Control.Monad -import Data.List ( partition ) -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - Extracting the type from HsSyn -* * -************************************************************************ - --} - -hsLPatType :: LPat GhcTc -> Type -hsLPatType (dL->L _ p) = hsPatType p - -hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ pat) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat _ lvar) = idType (unLoc lvar) -hsPatType (BangPat _ pat) = hsLPatType pat -hsPatType (LazyPat _ pat) = hsLPatType pat -hsPatType (LitPat _ lit) = hsLitType lit -hsPatType (AsPat _ var _) = idType (unLoc var) -hsPatType (ViewPat ty _ _) = ty -hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty -hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty -hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys - -- See Note [Don't flatten tuples from HsSyn] in MkCore -hsPatType (SumPat tys _ _ _ ) = mkSumTy tys -hsPatType (ConPatOut { pat_con = lcon - , pat_arg_tys = tys }) - = conLikeResTy (unLoc lcon) tys -hsPatType (SigPat ty _ _) = ty -hsPatType (NPat ty _ _ _) = ty -hsPatType (NPlusKPat ty _ _ _ _ _) = ty -hsPatType (CoPat _ _ _ ty) = ty -hsPatType (XPat n) = noExtCon n -hsPatType ConPatIn{} = panic "hsPatType: ConPatIn" -hsPatType SplicePat{} = panic "hsPatType: SplicePat" - -hsLitType :: HsLit (GhcPass p) -> TcType -hsLitType (HsChar _ _) = charTy -hsLitType (HsCharPrim _ _) = charPrimTy -hsLitType (HsString _ _) = stringTy -hsLitType (HsStringPrim _ _) = addrPrimTy -hsLitType (HsInt _ _) = intTy -hsLitType (HsIntPrim _ _) = intPrimTy -hsLitType (HsWordPrim _ _) = wordPrimTy -hsLitType (HsInt64Prim _ _) = int64PrimTy -hsLitType (HsWord64Prim _ _) = word64PrimTy -hsLitType (HsInteger _ _ ty) = ty -hsLitType (HsRat _ _ ty) = ty -hsLitType (HsFloatPrim _ _) = floatPrimTy -hsLitType (HsDoublePrim _ _) = doublePrimTy -hsLitType (XLit nec) = noExtCon nec - --- Overloaded literals. Here mainly because it uses isIntTy etc - -shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) -shortCutLit dflags (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && inIntRange dflags i = Just (HsLit noExtField (HsInt noExtField int)) - | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) - | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty - -- The 'otherwise' case is important - -- Consider (3 :: Float). Syntactically it looks like an IntLit, - -- so we'll call shortCutIntLit, but of course it's a float - -- This can make a big difference for programs with a lot of - -- literals, compiled without -O - -shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing - -shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit noExtField (HsString src s)) - | otherwise = Nothing - -mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) - ------------------------------- -hsOverLitName :: OverLitVal -> Name --- Get the canonical 'fromX' name for a particular OverLitVal -hsOverLitName (HsIntegral {}) = fromIntegerName -hsOverLitName (HsFractional {}) = fromRationalName -hsOverLitName (HsIsString {}) = fromStringName - -{- -************************************************************************ -* * -\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} -* * -************************************************************************ - -The rest of the zonking is done *after* typechecking. -The main zonking pass runs over the bindings - - a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc - b) convert unbound TcTyVar to Void - c) convert each TcId to an Id by zonking its type - -The type variables are converted by binding mutable tyvars to immutable ones -and then zonking as normal. - -The Ids are converted by binding them in the normal Tc envt; that -way we maintain sharing; eg an Id is zonked at its binding site and they -all occurrences of that Id point to the common zonked copy - -It's all pretty boring stuff, because HsSyn is such a large type, and -the environment manipulation is tiresome. --} - --- Confused by zonking? See Note [What is zonking?] in TcMType. - --- | See Note [The ZonkEnv] --- Confused by zonking? See Note [What is zonking?] in TcMType. -data ZonkEnv -- See Note [The ZonkEnv] - = ZonkEnv { ze_flexi :: ZonkFlexi - , ze_tv_env :: TyCoVarEnv TyCoVar - , ze_id_env :: IdEnv Id - , ze_meta_tv_env :: TcRef (TyVarEnv Type) } - -{- Note [The ZonkEnv] -~~~~~~~~~~~~~~~~~~~~~ -* ze_flexi :: ZonkFlexi says what to do with a - unification variable that is still un-unified. - See Note [Un-unified unification variables] - -* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site - of a tyvar or covar, we zonk the kind right away and add a mapping - to the env. This prevents re-zonking the kind at every - occurrence. But this is *just* an optimisation. - -* ze_id_env : IdEnv Id promotes sharing among Ids, by making all - occurrences of the Id point to a single zonked copy, built at the - binding site. - - Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. - In a mutually recusive group - rec { f = ...g...; g = ...f... } - we want the occurrence of g to point to the one zonked Id for g, - and the same for f. - - Because it is knot-tied, we must be careful to consult it lazily. - Specifically, zonkIdOcc is not monadic. - -* ze_meta_tv_env: see Note [Sharing when zonking to Type] - - -Notes: - * We must be careful never to put coercion variables (which are Ids, - after all) in the knot-tied ze_id_env, because coercions can - appear in types, and we sometimes inspect a zonked type in this - module. [Question: where, precisely?] - - * In zonkTyVarOcc we consult ze_tv_env in a monadic context, - a second reason that ze_tv_env can't be monadic. - - * An obvious suggestion would be to have one VarEnv Var to - replace both ze_id_env and ze_tv_env, but that doesn't work - because of the knot-tying stuff mentioned above. - -Note [Un-unified unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we do if we find a Flexi unification variable? -There are three possibilities: - -* DefaultFlexi: this is the common case, in situations like - length @alpha ([] @alpha) - It really doesn't matter what type we choose for alpha. But - we must choose a type! We can't leae mutable unification - variables floating around: after typecheck is complete, every - type variable occurrence must have a bindign site. - - So we default it to 'Any' of the right kind. - - All this works for both type and kind variables (indeed - the two are the same thign). - -* SkolemiseFlexi: is a special case for the LHS of RULES. - See Note [Zonking the LHS of a RULE] - -* RuntimeUnkFlexi: is a special case for the GHCi debugger. - It's a way to have a variable that is not a mutuable - unification variable, but doesn't have a binding site - either. --} - -data ZonkFlexi -- See Note [Un-unified unification variables] - = DefaultFlexi -- Default unbound unificaiton variables to Any - | SkolemiseFlexi -- Skolemise unbound unification variables - -- See Note [Zonking the LHS of a RULE] - | RuntimeUnkFlexi -- Used in the GHCi debugger - -instance Outputable ZonkEnv where - ppr (ZonkEnv { ze_tv_env = tv_env - , ze_id_env = id_env }) - = text "ZE" <+> braces (vcat - [ text "ze_tv_env =" <+> ppr tv_env - , text "ze_id_env =" <+> ppr id_env ]) - --- The EvBinds have to already be zonked, but that's usually the case. -emptyZonkEnv :: TcM ZonkEnv -emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi - -mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv -mkEmptyZonkEnv flexi - = do { mtv_env_ref <- newTcRef emptyVarEnv - ; return (ZonkEnv { ze_flexi = flexi - , ze_tv_env = emptyVarEnv - , ze_id_env = emptyVarEnv - , ze_meta_tv_env = mtv_env_ref }) } - -initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b -initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi - ; thing_inside ze } - --- | Extend the knot-tied environment. -extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv -extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids - -- NB: Don't look at the var to decide which env't to put it in. That - -- would end up knot-tying all the env'ts. - = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - -- Given coercion variables will actually end up here. That's OK though: - -- coercion variables are never looked up in the knot-tied env't, so zonking - -- them simply doesn't get optimised. No one gets hurt. An improvement (?) - -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the - -- recursive groups. But perhaps the time it takes to do the analysis is - -- more than the savings. - -extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars - = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] - , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - where - (tycovars, ids) = partition isTyCoVar vars - -extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv -extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id - = ze { ze_id_env = extendVarEnv id_env id id } - -extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv -extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv - = ze { ze_tv_env = extendVarEnv ty_env tv tv } - -setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv -setZonkType ze flexi = ze { ze_flexi = flexi } - -zonkEnvIds :: ZonkEnv -> TypeEnv -zonkEnvIds (ZonkEnv { ze_id_env = id_env}) - = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- immediately by creating a TypeEnv - -zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id -zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env) - -zonkIdOcc :: ZonkEnv -> TcId -> Id --- Ids defined in this module should be in the envt; --- ignore others. (Actually, data constructors are also --- not LocalVars, even when locally defined, but that is fine.) --- (Also foreign-imported things aren't currently in the ZonkEnv; --- that's ok because they don't need zonking.) --- --- Actually, Template Haskell works in 'chunks' of declarations, and --- an earlier chunk won't be in the 'env' that the zonking phase --- carries around. Instead it'll be in the tcg_gbl_env, already fully --- zonked. There's no point in looking it up there (except for error --- checking), and it's not conveniently to hand; hence the simple --- 'orElse' case in the LocalVar branch. --- --- Even without template splices, in module Main, the checking of --- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id - | isLocalVar id = lookupVarEnv id_env id `orElse` - id - | otherwise = id - -zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] -zonkIdOccs env ids = map (zonkIdOcc env) ids - --- zonkIdBndr is used *after* typechecking to get the Id's type --- to its final form. The TyVarEnv give -zonkIdBndr :: ZonkEnv -> TcId -> TcM Id -zonkIdBndr env v - = do ty' <- zonkTcTypeToTypeX env (idType v) - ensureNotLevPoly ty' - (text "In the type of binder" <+> quotes (ppr v)) - - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) - -zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] -zonkIdBndrs env ids = mapM (zonkIdBndr env) ids - -zonkTopBndrs :: [TcId] -> TcM [Id] -zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids - -zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) -zonkFieldOcc env (FieldOcc sel lbl) - = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel -zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec - -zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) -zonkEvBndrsX = mapAccumLM zonkEvBndrX - -zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) --- Works for dictionaries and coercions -zonkEvBndrX env var - = do { var' <- zonkEvBndr env var - ; return (extendZonkEnv env [var'], var') } - -zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar --- Works for dictionaries and coercions --- Does not extend the ZonkEnv -zonkEvBndr env var - = do { let var_ty = varType var - ; ty <- - {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} - zonkTcTypeToTypeX env var_ty - ; return (setVarType var ty) } - -{- -zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm -zonkEvVarOcc env v - | isCoVar v - = EvCoercion <$> zonkCoVarOcc env v - | otherwise - = return (EvId $ zonkIdOcc env v) --} - -zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) -zonkCoreBndrX env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', v') } - | otherwise = zonkTyBndrX env v - -zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var]) -zonkCoreBndrsX = mapAccumLM zonkCoreBndrX - -zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs - -zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrsX = mapAccumLM zonkTyBndrX - -zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) --- This guarantees to return a TyVar (not a TcTyVar) --- then we add it to the envt, so all occurrences are replaced --- --- It does not clone: the new TyVar has the sane Name --- as the old one. This important when zonking the --- TyVarBndrs of a TyCon, whose Names may scope. -zonkTyBndrX env tv - = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) ) - do { ki <- zonkTcTypeToTypeX env (tyVarKind tv) - -- Internal names tidy up better, for iface files. - ; let tv' = mkTyVar (tyVarName tv) ki - ; return (extendTyZonkEnv env tv', tv') } - -zonkTyVarBinders :: [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs - -zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX - -zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis - -> TcM (ZonkEnv, VarBndr TyVar vis) --- Takes a TcTyVar and guarantees to return a TyVar -zonkTyVarBinderX env (Bndr tv vis) - = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', Bndr tv' vis) } - -zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc) -zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e - -zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) -zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e - -zonkTopDecls :: Bag EvBind - -> LHsBinds GhcTcId - -> [LRuleDecl GhcTcId] -> [LTcSpecPrag] - -> [LForeignDecl GhcTcId] - -> TcM (TypeEnv, - Bag EvBind, - LHsBinds GhcTc, - [LForeignDecl GhcTc], - [LTcSpecPrag], - [LRuleDecl GhcTc]) -zonkTopDecls ev_binds binds rules imp_specs fords - = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds - ; (env2, binds') <- zonkRecMonoBinds env1 binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules - ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } - ---------------------------------------------- -zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId - -> TcM (ZonkEnv, HsLocalBinds GhcTc) -zonkLocalBinds env (EmptyLocalBinds x) - = return (env, (EmptyLocalBinds x)) - -zonkLocalBinds _ (HsValBinds _ (ValBinds {})) - = panic "zonkLocalBinds" -- Not in typechecker output - -zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) - = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } - where - go env [] - = return (env, []) - go env ((r,b):bs) - = do { (env1, b') <- zonkRecMonoBinds env b - ; (env2, bs') <- go env1 bs - ; return (env2, (r,b'):bs') } - -zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do - new_binds <- mapM (wrapLocM zonk_ip_bind) binds - let - env1 = extendIdZonkEnvRec env - [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds] - (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds - return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) - where - zonk_ip_bind (IPBind x n e) - = do n' <- mapIPNameTc (zonkIdBndr env) n - e' <- zonkLExpr env e - return (IPBind x n' e') - zonk_ip_bind (XIPBind nec) = noExtCon nec - -zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec)) - = noExtCon nec -zonkLocalBinds _ (XHsLocalBindsLR nec) - = noExtCon nec - ---------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) -zonkRecMonoBinds env binds - = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) - ; binds' <- zonkMonoBinds env1 binds - ; return (env1, binds') }) - ---------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc) -zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds - -zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc) -zonk_lbind env = wrapLocM (zonk_bind env) - -zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = NPatBindTc fvs ty}) - = do { (_env, new_pat) <- zonkPat env pat -- Env already extended - ; new_grhss <- zonkGRHSs env zonkLExpr grhss - ; new_ty <- zonkTcTypeToTypeX env ty - ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss - , pat_ext = NPatBindTc fvs new_ty }) } - -zonk_bind env (VarBind { var_ext = x - , var_id = var, var_rhs = expr, var_inline = inl }) - = do { new_var <- zonkIdBndr env var - ; new_expr <- zonkLExpr env expr - ; return (VarBind { var_ext = x - , var_id = new_var - , var_rhs = new_expr - , var_inline = inl }) } - -zonk_bind env bind@(FunBind { fun_id = (dL->L loc var) - , fun_matches = ms - , fun_co_fn = co_fn }) - = do { new_var <- zonkIdBndr env var - ; (env1, new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = cL loc new_var - , fun_matches = new_ms - , fun_co_fn = new_co_fn }) } - -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs - , abs_ev_binds = ev_binds - , abs_exports = exports - , abs_binds = val_binds - , abs_sig = has_sig }) - = ASSERT( all isImmutableTyVar tyvars ) - do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds - ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> - do { let env3 = extendIdZonkEnvRec env2 $ - collectHsBindsBinders new_val_binds - ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds - ; new_exports <- mapM (zonk_export env3) exports - ; return (new_val_binds, new_exports) } - ; return (AbsBinds { abs_ext = noExtField - , abs_tvs = new_tyvars, abs_ev_vars = new_evs - , abs_ev_binds = new_ev_binds - , abs_exports = new_exports, abs_binds = new_val_bind - , abs_sig = has_sig }) } - where - zonk_val_bind env lbind - | has_sig - , (dL->L loc bind@(FunBind { fun_id = (dL->L mloc mono_id) - , fun_matches = ms - , fun_co_fn = co_fn })) <- lbind - = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id - -- Specifically /not/ zonkIdBndr; we do not - -- want to complain about a levity-polymorphic binder - ; (env', new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ cL loc $ - bind { fun_id = cL mloc new_mono_id - , fun_matches = new_ms - , fun_co_fn = new_co_fn } } - | otherwise - = zonk_lbind env lbind -- The normal case - - zonk_export env (ABE{ abe_ext = x - , abe_wrap = wrap - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = prags }) - = do new_poly_id <- zonkIdBndr env poly_id - (_, new_wrap) <- zonkCoFn env wrap - new_prags <- zonkSpecPrags env prags - return (ABE{ abe_ext = x - , abe_wrap = new_wrap - , abe_poly = new_poly_id - , abe_mono = zonkIdOcc env mono_id - , abe_prags = new_prags }) - zonk_export _ (XABExport nec) = noExtCon nec - -zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) - , psb_args = details - , psb_def = lpat - , psb_dir = dir })) - = do { id' <- zonkIdBndr env id - ; (env1, lpat') <- zonkPat env lpat - ; let details' = zonkPatSynDetails env1 details - ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return $ PatSynBind x $ - bind { psb_id = cL loc id' - , psb_args = details' - , psb_def = lpat' - , psb_dir = dir' } } - -zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec -zonk_bind _ (XHsBindsLR nec) = noExtCon nec - -zonkPatSynDetails :: ZonkEnv - -> HsPatSynDetails (Located TcId) - -> HsPatSynDetails (Located Id) -zonkPatSynDetails env (PrefixCon as) - = PrefixCon (map (zonkLIdOcc env) as) -zonkPatSynDetails env (InfixCon a1 a2) - = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) -zonkPatSynDetails env (RecCon flds) - = RecCon (map (fmap (zonkLIdOcc env)) flds) - -zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId - -> TcM (ZonkEnv, HsPatSynDir GhcTc) -zonkPatSynDir env Unidirectional = return (env, Unidirectional) -zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) -zonkPatSynDir env (ExplicitBidirectional mg) = do - mg' <- zonkMatchGroup env zonkLExpr mg - return (env, ExplicitBidirectional mg') - -zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags -zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod -zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps - ; return (SpecPrags ps') } - -zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] -zonkLTcSpecPrags env ps - = mapM zonk_prag ps - where - zonk_prag (dL->L loc (SpecPrag id co_fn inl)) - = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } - -{- -************************************************************************ -* * -\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} -* * -************************************************************************ --} - -zonkMatchGroup :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> MatchGroup GhcTcId (Located (body GhcTcId)) - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms) - , mg_ext = MatchGroupTc arg_tys res_ty - , mg_origin = origin }) - = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkTcTypesToTypesX env arg_tys - ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = cL l ms' - , mg_ext = MatchGroupTc arg_tys' res_ty' - , mg_origin = origin }) } -zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec - -zonkMatch :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> LMatch GhcTcId (Located (body GhcTcId)) - -> TcM (LMatch GhcTc (Located (body GhcTc))) -zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats - , m_grhss = grhss })) - = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) } -zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec -zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" - -- due to #15884 - -------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> GRHSs GhcTcId (Located (body GhcTcId)) - -> TcM (GRHSs GhcTc (Located (body GhcTc))) - -zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do - (new_env, new_binds) <- zonkLocalBinds env binds - let - zonk_grhs (GRHS xx guarded rhs) - = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded - new_rhs <- zBody env2 rhs - return (GRHS xx new_guarded new_rhs) - zonk_grhs (XGRHS nec) = noExtCon nec - new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (cL l new_binds)) -zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -* * -************************************************************************ --} - -zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc] -zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) -zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) - -zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocM (zonkExpr env) expr - -zonkExpr env (HsVar x (dL->L l id)) - = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (cL l (zonkIdOcc env id))) - -zonkExpr _ e@(HsConLikeOut {}) = return e - -zonkExpr _ (HsIPVar x id) - = return (HsIPVar x id) - -zonkExpr _ e@HsOverLabel{} = return e - -zonkExpr env (HsLit x (HsRat e f ty)) - = do new_ty <- zonkTcTypeToTypeX env ty - return (HsLit x (HsRat e f new_ty)) - -zonkExpr _ (HsLit x lit) - = return (HsLit x lit) - -zonkExpr env (HsOverLit x lit) - = do { lit' <- zonkOverLit env lit - ; return (HsOverLit x lit') } - -zonkExpr env (HsLam x matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLam x new_matches) - -zonkExpr env (HsLamCase x matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase x new_matches) - -zonkExpr env (HsApp x e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (HsApp x new_e1 new_e2) - -zonkExpr env (HsAppType x e t) - = do new_e <- zonkLExpr env e - return (HsAppType x new_e t) - -- NB: the type is an HsType; can't zonk that! - -zonkExpr _ e@(HsRnBracketOut _ _ _) - = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) - -zonkExpr env (HsTcBracketOut x body bs) - = do bs' <- mapM zonk_b bs - return (HsTcBracketOut x body bs') - where - zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e - return (PendingTcSplice n e') - -zonkExpr env (HsSpliceE _ (HsSplicedT s)) = - runTopSplice s >>= zonkExpr env - -zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen - return (HsSpliceE x s) - -zonkExpr env (OpApp fixity e1 op e2) - = do new_e1 <- zonkLExpr env e1 - new_op <- zonkLExpr env op - new_e2 <- zonkLExpr env e2 - return (OpApp fixity new_e1 new_op new_e2) - -zonkExpr env (NegApp x expr op) - = do (env', new_op) <- zonkSyntaxExpr env op - new_expr <- zonkLExpr env' expr - return (NegApp x new_expr new_op) - -zonkExpr env (HsPar x e) - = do new_e <- zonkLExpr env e - return (HsPar x new_e) - -zonkExpr env (SectionL x expr op) - = do new_expr <- zonkLExpr env expr - new_op <- zonkLExpr env op - return (SectionL x new_expr new_op) - -zonkExpr env (SectionR x op expr) - = do new_op <- zonkLExpr env op - new_expr <- zonkLExpr env expr - return (SectionR x new_op new_expr) - -zonkExpr env (ExplicitTuple x tup_args boxed) - = do { new_tup_args <- mapM zonk_tup_arg tup_args - ; return (ExplicitTuple x new_tup_args boxed) } - where - zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (cL l (Present x e')) } - zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t - ; return (cL l (Missing t')) } - zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec - zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" - -- due to #15884 - - -zonkExpr env (ExplicitSum args alt arity expr) - = do new_args <- mapM (zonkTcTypeToTypeX env) args - new_expr <- zonkLExpr env expr - return (ExplicitSum new_args alt arity new_expr) - -zonkExpr env (HsCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLExpr ms - return (HsCase x new_expr new_ms) - -zonkExpr env (HsIf x Nothing e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (HsIf x Nothing new_e1 new_e2 new_e3) - -zonkExpr env (HsIf x (Just fun) e1 e2 e3) - = do (env1, new_fun) <- zonkSyntaxExpr env fun - new_e1 <- zonkLExpr env1 e1 - new_e2 <- zonkLExpr env1 e2 - new_e3 <- zonkLExpr env1 e3 - return (HsIf x (Just new_fun) new_e1 new_e2 new_e3) - -zonkExpr env (HsMultiIf ty alts) - = do { alts' <- mapM (wrapLocM zonk_alt) alts - ; ty' <- zonkTcTypeToTypeX env ty - ; return $ HsMultiIf ty' alts' } - where zonk_alt (GRHS x guard expr) - = do { (env', guard') <- zonkStmts env zonkLExpr guard - ; expr' <- zonkLExpr env' expr - ; return $ GRHS x guard' expr' } - zonk_alt (XGRHS nec) = noExtCon nec - -zonkExpr env (HsLet x (dL->L l binds) expr) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_expr <- zonkLExpr new_env expr - return (HsLet x (cL l new_binds) new_expr) - -zonkExpr env (HsDo ty do_or_lc (dL->L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (cL l new_stmts)) - -zonkExpr env (ExplicitList ty wit exprs) - = do (env1, new_wit) <- zonkWit env wit - new_ty <- zonkTcTypeToTypeX env1 ty - new_exprs <- zonkLExprs env1 exprs - return (ExplicitList new_ty new_wit new_exprs) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) - ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } - , rcon_flds = new_rbinds }) } - -zonkExpr env (RecordUpd { rupd_flds = rbinds - , rupd_expr = expr - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) - = do { new_expr <- zonkLExpr env expr - ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys - ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys - ; new_rbinds <- zonkRecUpdFields env rbinds - ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } - -zonkExpr env (ExprWithTySig _ e ty) - = do { e' <- zonkLExpr env e - ; return (ExprWithTySig noExtField e' ty) } - -zonkExpr env (ArithSeq expr wit info) - = do (env1, new_wit) <- zonkWit env wit - new_expr <- zonkExpr env expr - new_info <- zonkArithSeq env1 info - return (ArithSeq new_expr new_wit new_info) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env (HsSCC x src lbl expr) - = do new_expr <- zonkLExpr env expr - return (HsSCC x src lbl new_expr) - -zonkExpr env (HsTickPragma x src info srcInfo expr) - = do new_expr <- zonkLExpr env expr - return (HsTickPragma x src info srcInfo new_expr) - --- hdaume: core annotations -zonkExpr env (HsCoreAnn x src lbl expr) - = do new_expr <- zonkLExpr env expr - return (HsCoreAnn x src lbl new_expr) - --- arrow notation extensions -zonkExpr env (HsProc x pat body) - = do { (env1, new_pat) <- zonkPat env pat - ; new_body <- zonkCmdTop env1 body - ; return (HsProc x new_pat new_body) } - --- StaticPointers extension -zonkExpr env (HsStatic fvs expr) - = HsStatic fvs <$> zonkLExpr env expr - -zonkExpr env (HsWrap x co_fn expr) - = do (env1, new_co_fn) <- zonkCoFn env co_fn - new_expr <- zonkExpr env1 expr - return (HsWrap x new_co_fn new_expr) - -zonkExpr _ e@(HsUnboundVar {}) = return e - -zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) - -------------------------------------------------------------------------- -{- -Note [Skolems in zonkSyntaxExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider rebindable syntax with something like - - (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' - -The x and y become skolems that are in scope when type-checking the -arguments to the bind. This means that we must extend the ZonkEnv with -these skolems when zonking the arguments to the bind. But the skolems -are different between the two arguments, and so we should theoretically -carry around different environments to use for the different arguments. - -However, this becomes a logistical nightmare, especially in dealing with -the more exotic Stmt forms. So, we simplify by making the critical -assumption that the uniques of the skolems are different. (This assumption -is justified by the use of newUnique in TcMType.instSkolTyCoVarX.) -Now, we can safely just extend one environment. --} - --- See Note [Skolems in zonkSyntaxExpr] -zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId - -> TcM (ZonkEnv, SyntaxExpr GhcTc) -zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = do { (env0, res_wrap') <- zonkCoFn env res_wrap - ; expr' <- zonkExpr env0 expr - ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps - ; return (env1, SyntaxExpr { syn_expr = expr' - , syn_arg_wraps = arg_wraps' - , syn_res_wrap = res_wrap' }) } - -------------------------------------------------------------------------- - -zonkLCmd :: ZonkEnv -> LHsCmd GhcTcId -> TcM (LHsCmd GhcTc) -zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) - -zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd - -zonkCmd env (HsCmdWrap x w cmd) - = do { (env1, w') <- zonkCoFn env w - ; cmd' <- zonkCmd env1 cmd - ; return (HsCmdWrap x w' cmd') } -zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) - -zonkCmd env (HsCmdArrForm x op f fixity args) - = do new_op <- zonkLExpr env op - new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm x new_op f fixity new_args) - -zonkCmd env (HsCmdApp x c e) - = do new_c <- zonkLCmd env c - new_e <- zonkLExpr env e - return (HsCmdApp x new_c new_e) - -zonkCmd env (HsCmdLam x matches) - = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam x new_matches) - -zonkCmd env (HsCmdPar x c) - = do new_c <- zonkLCmd env c - return (HsCmdPar x new_c) - -zonkCmd env (HsCmdCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase x new_expr new_ms) - -zonkCmd env (HsCmdIf x eCond ePred cThen cElse) - = do { (env1, new_eCond) <- zonkWit env eCond - ; new_ePred <- zonkLExpr env1 ePred - ; new_cThen <- zonkLCmd env1 cThen - ; new_cElse <- zonkLCmd env1 cElse - ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } - where - zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w - -zonkCmd env (HsCmdLet x (dL->L l binds) cmd) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (cL l new_binds) new_cmd) - -zonkCmd env (HsCmdDo ty (dL->L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (cL l new_stmts)) - -zonkCmd _ (XCmd nec) = noExtCon nec - - - -zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) -zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd - -zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc) -zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) - = do new_cmd <- zonkLCmd env cmd - new_stack_tys <- zonkTcTypeToTypeX env stack_tys - new_ty <- zonkTcTypeToTypeX env ty - new_ids <- mapSndM (zonkExpr env) ids - - MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) ) - -- desugarer assumes that this is not levity polymorphic... - -- but indeed it should always be lifted due to the typing - -- rules for arrows - - return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) -zonk_cmd_top _ (XCmdTop nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) -zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkTcTypeToTypeX env2 t1 - ; return (env2, WpFun c1' c2' t1' d) } -zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co - ; return (env, WpCast co') } -zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev - ; return (env', WpEvLam ev') } -zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg - ; return (env, WpEvApp arg') } -zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) - do { (env', tv') <- zonkTyBndrX env tv - ; return (env', WpTyLam tv') } -zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty - ; return (env, WpTyApp ty') } -zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs - ; return (env1, WpLet bs') } - -------------------------------------------------------------------------- -zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) -zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) - = do { ty' <- zonkTcTypeToTypeX env ty - ; e' <- zonkExpr env e - ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } - -zonkOverLit _ (XOverLit nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc) - -zonkArithSeq env (From e) - = do new_e <- zonkLExpr env e - return (From new_e) - -zonkArithSeq env (FromThen e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromThen new_e1 new_e2) - -zonkArithSeq env (FromTo e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromTo new_e1 new_e2) - -zonkArithSeq env (FromThenTo e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (FromThenTo new_e1 new_e2 new_e3) - - -------------------------------------------------------------------------- -zonkStmts :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> [LStmt GhcTcId (Located (body GhcTcId))] - -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) -zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s - ; (env2, ss') <- zonkStmts env1 zBody ss - ; return (env2, s' : ss') } - -zonkStmt :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> Stmt GhcTcId (Located (body GhcTcId)) - -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) -zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) - = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty - ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs - ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs - , b <- bs] - env2 = extendIdZonkEnvRec env1 new_binders - ; new_mzip <- zonkExpr env2 mzip_op - ; return (env2 - , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} - where - zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) - = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts - ; (env3, new_return) <- zonkSyntaxExpr env2 return_op - ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) - new_return) } - zonk_branch _ (XParStmtBlock nec) = noExtCon nec - -zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id - , recS_bind_fn = bind_id - , recS_ext = - RecStmtTc { recS_bind_ty = bind_ty - , recS_later_rets = later_rets - , recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty} }) - = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id - ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id - ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id - ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty - ; new_rvs <- zonkIdBndrs env3 rvs - ; new_lvs <- zonkIdBndrs env3 lvs - ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty - ; let env4 = extendIdZonkEnvRec env3 new_rvs - ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts - -- Zonk the ret-expressions in an envt that - -- has the polymorphic bindings in the envt - ; new_later_rets <- mapM (zonkExpr env5) later_rets - ; new_rec_rets <- mapM (zonkExpr env5) rec_rets - ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed - RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs - , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id - , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_ext = RecStmtTc - { recS_bind_ty = new_bind_ty - , recS_later_rets = new_later_rets - , recS_rec_rets = new_rec_rets - , recS_ret_ty = new_ret_ty } }) } - -zonkStmt env zBody (BodyStmt ty body then_op guard_op) - = do (env1, new_then_op) <- zonkSyntaxExpr env then_op - (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op - new_body <- zBody env2 body - new_ty <- zonkTcTypeToTypeX env2 ty - return (env2, BodyStmt new_ty new_body new_then_op new_guard_op) - -zonkStmt env zBody (LastStmt x body noret ret_op) - = do (env1, new_ret) <- zonkSyntaxExpr env ret_op - new_body <- zBody env1 body - return (env, LastStmt x new_body noret new_ret) - -zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_ext = bind_arg_ty - , trS_fmap = liftM_op }) - = do { - ; (env1, bind_op') <- zonkSyntaxExpr env bind_op - ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty - ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts - ; by' <- fmapMaybeM (zonkLExpr env2) by - ; using' <- zonkLExpr env2 using - - ; (env3, return_op') <- zonkSyntaxExpr env2 return_op - ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap - ; liftM_op' <- zonkExpr env3 liftM_op - ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') - ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' - , trS_by = by', trS_form = form, trS_using = using' - , trS_ret = return_op', trS_bind = bind_op' - , trS_ext = bind_arg_ty' - , trS_fmap = liftM_op' }) } - where - zonkBinderMapEntry env (oldBinder, newBinder) = do - let oldBinder' = zonkIdOcc env oldBinder - newBinder' <- zonkIdBndr env newBinder - return (oldBinder', newBinder') - -zonkStmt env _ (LetStmt x (dL->L l binds)) - = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (cL l new_binds)) - -zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) - = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty - ; new_body <- zBody env1 body - ; (env2, new_pat) <- zonkPat env1 pat - ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op - ; return ( env2 - , BindStmt new_bind_ty new_pat new_body new_bind new_fail) } - --- Scopes: join > ops (in reverse order) > pats (in forward order) --- > rest of stmts -zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) - = do { (env1, new_mb_join) <- zonk_join env mb_join - ; (env2, new_args) <- zonk_args env1 args - ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty - ; return ( env2 - , ApplicativeStmt new_body_ty new_args new_mb_join) } - where - zonk_join env Nothing = return (env, Nothing) - zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - - get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat - get_pat (_, ApplicativeArgMany _ _ _ pat) = pat - get_pat (_, XApplicativeArg nec) = noExtCon nec - - replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op) - = (op, ApplicativeArgOne x pat a isBody fail_op) - replace_pat pat (op, ApplicativeArgMany x a b _) - = (op, ApplicativeArgMany x a b pat) - replace_pat _ (_, XApplicativeArg nec) = noExtCon nec - - zonk_args env args - = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) - ; (env2, new_pats) <- zonkPats env1 (map get_pat args) - ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) } - - -- these need to go backward, because if any operators are higher-rank, - -- later operators may introduce skolems that are in scope for earlier - -- arguments - zonk_args_rev env ((op, arg) : args) - = do { (env1, new_op) <- zonkSyntaxExpr env op - ; new_arg <- zonk_arg env1 arg - ; (env2, new_args) <- zonk_args_rev env1 args - ; return (env2, (new_op, new_arg) : new_args) } - zonk_args_rev env [] = return (env, []) - - zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op) - = do { new_expr <- zonkLExpr env expr - ; (_, new_fail) <- zonkSyntaxExpr env fail_op - ; return (ApplicativeArgOne x pat new_expr isBody new_fail) } - zonk_arg env (ApplicativeArgMany x stmts ret pat) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_ret <- zonkExpr env1 ret - ; return (ApplicativeArgMany x new_stmts new_ret pat) } - zonk_arg _ (XApplicativeArg nec) = noExtCon nec - -zonkStmt _ _ (XStmtLR nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) -zonkRecFields env (HsRecFields flds dd) - = do { flds' <- mapM zonk_rbind flds - ; return (HsRecFields flds' dd) } - where - zonk_rbind (dL->L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = new_id - , hsRecFieldArg = new_expr })) } - -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] - -> TcM [LHsRecUpdField GhcTcId] -zonkRecUpdFields env = mapM zonk_rbind - where - zonk_rbind (dL->L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } - -------------------------------------------------------------------------- -mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a - -> TcM (Either (Located HsIPName) b) -mapIPNameTc _ (Left x) = return (Left x) -mapIPNameTc f (Right x) = do r <- f x - return (Right r) - -{- -************************************************************************ -* * -\subsection[BackSubst-Pats]{Patterns} -* * -************************************************************************ --} - -zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc) --- Extend the environment as we go, because it's possible for one --- pattern to bind something that is used in another (inside or --- to the right) -zonkPat env pat = wrapLocSndM (zonk_pat env) pat - -zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat x p) - = do { (env', p') <- zonkPat env p - ; return (env', ParPat x p') } - -zonk_pat env (WildPat ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; ensureNotLevPoly ty' - (text "In a wildcard pattern") - ; return (env, WildPat ty') } - -zonk_pat env (VarPat x (dL->L l v)) - = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', VarPat x (cL l v')) } - -zonk_pat env (LazyPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat x pat') } - -zonk_pat env (BangPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat x pat') } - -zonk_pat env (AsPat x (dL->L loc v) pat) - = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat - ; return (env', AsPat x (cL loc v') pat') } - -zonk_pat env (ViewPat ty expr pat) - = do { expr' <- zonkLExpr env expr - ; (env', pat') <- zonkPat env pat - ; ty' <- zonkTcTypeToTypeX env ty - ; return (env', ViewPat ty' expr' pat') } - -zonk_pat env (ListPat (ListPatTc ty Nothing) pats) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat (ListPatTc ty' Nothing) pats') } - -zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) - = do { (env', wit') <- zonkSyntaxExpr env wit - ; ty2' <- zonkTcTypeToTypeX env' ty2 - ; ty' <- zonkTcTypeToTypeX env' ty - ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') } - -zonk_pat env (TuplePat tys pats boxed) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat tys' pats' boxed) } - -zonk_pat env (SumPat tys pat alt arity ) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pat') <- zonkPat env pat - ; return (env', SumPat tys' pat' alt arity) } - -zonk_pat env p@(ConPatOut { pat_arg_tys = tys - , pat_tvs = tyvars - , pat_dicts = evs - , pat_binds = binds - , pat_args = args - , pat_wrap = wrapper - , pat_con = (dL->L _ con) }) - = ASSERT( all isImmutableTyVar tyvars ) - do { new_tys <- mapM (zonkTcTypeToTypeX env) tys - - -- an unboxed tuple pattern (but only an unboxed tuple pattern) - -- might have levity-polymorphic arguments. Check for this badness. - ; case con of - RealDataCon dc - | isUnboxedTupleTyCon (dataConTyCon dc) - -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) - _ -> return () - - ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars - -- Must zonk the existential variables, because their - -- /kind/ need potential zonking. - -- cf typecheck/should_compile/tc221.hs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_binds) <- zonkTcEvBinds env1 binds - ; (env3, new_wrapper) <- zonkCoFn env2 wrapper - ; (env', new_args) <- zonkConStuff env3 args - ; return (env', p { pat_arg_tys = new_tys, - pat_tvs = new_tyvars, - pat_dicts = new_evs, - pat_binds = new_binds, - pat_args = new_args, - pat_wrap = new_wrapper}) } - where - doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p - -zonk_pat env (LitPat x lit) = return (env, LitPat x lit) - -zonk_pat env (SigPat ty pat hs_ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pat') <- zonkPat env pat - ; return (env', SigPat ty' pat' hs_ty) } - -zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) - = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr - ; (env2, mb_neg') <- case mb_neg of - Nothing -> return (env1, Nothing) - Just n -> second Just <$> zonkSyntaxExpr env1 n - - ; lit' <- zonkOverLit env2 lit - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') } - -zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) - = do { (env1, e1') <- zonkSyntaxExpr env e1 - ; (env2, e2') <- zonkSyntaxExpr env1 e2 - ; n' <- zonkIdBndr env2 n - ; lit1' <- zonkOverLit env2 lit1 - ; lit2' <- zonkOverLit env2 lit2 - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (extendIdZonkEnv env2 n', - NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') } - -zonk_pat env (CoPat x co_fn pat ty) - = do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLoc pat) - ; ty' <- zonkTcTypeToTypeX env'' ty - ; return (env'', CoPat x co_fn' (unLoc pat') ty') } - -zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) - ---------------------------- -zonkConStuff :: ZonkEnv - -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId)) - -> TcM (ZonkEnv, - HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc))) -zonkConStuff env (PrefixCon pats) - = do { (env', pats') <- zonkPats env pats - ; return (env', PrefixCon pats') } - -zonkConStuff env (InfixCon p1 p2) - = do { (env1, p1') <- zonkPat env p1 - ; (env', p2') <- zonkPat env1 p2 - ; return (env', InfixCon p1' p2') } - -zonkConStuff env (RecCon (HsRecFields rpats dd)) - = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(dL->L l rp) p' -> - cL l (rp { hsRecFieldArg = p' })) - rpats pats' - ; return (env', RecCon (HsRecFields rpats' dd)) } - -- Field selectors have declared types; hence no zonking - ---------------------------- -zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc]) -zonkPats env [] = return (env, []) -zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } - -{- -************************************************************************ -* * -\subsection[BackSubst-Foreign]{Foreign exports} -* * -************************************************************************ --} - -zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId] - -> TcM [LForeignDecl GhcTc] -zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls - -zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc) -zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co - , fd_fe = spec }) - = return (ForeignExport { fd_name = zonkLIdOcc env i - , fd_sig_ty = undefined, fd_e_ext = co - , fd_fe = spec }) -zonkForeignExport _ for_imp - = return for_imp -- Foreign imports don't need zonking - -zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc] -zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs - -zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc) -zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} - , rd_lhs = lhs - , rd_rhs = rhs }) - = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs - - ; let env_lhs = setZonkType env_inside SkolemiseFlexi - -- See Note [Zonking the LHS of a RULE] - - ; new_lhs <- zonkLExpr env_lhs lhs - ; new_rhs <- zonkLExpr env_inside rhs - - ; return $ rule { rd_tmvs = new_tm_bndrs - , rd_lhs = new_lhs - , rd_rhs = new_rhs } } - where - zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v))) - = do { (env', v') <- zonk_it env v - ; return (env', cL l (RuleBndr x (cL loc v'))) } - zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec - zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" - -- due to #15884 - - zonk_it env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnvRec env [v'], v') } - | otherwise = ASSERT( isImmutableTyVar v) - zonkTyBndrX env v - -- DV: used to be return (env,v) but that is plain - -- wrong because we may need to go inside the kind - -- of v and zonk there! -zonkRule _ (XRuleDecl nec) = noExtCon nec - -{- -************************************************************************ -* * - Constraints and evidence -* * -************************************************************************ --} - -zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm -zonkEvTerm env (EvExpr e) - = EvExpr <$> zonkCoreExpr env e -zonkEvTerm env (EvTypeable ty ev) - = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev -zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs - , et_binds = ev_binds, et_body = body_id }) - = do { (env0, new_tvs) <- zonkTyBndrsX env tvs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds - ; let new_body_id = zonkIdOcc env2 body_id - ; return (EvFun { et_tvs = new_tvs, et_given = new_evs - , et_binds = new_ev_binds, et_body = new_body_id }) } - -zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr -zonkCoreExpr env (Var v) - | isCoVar v - = Coercion <$> zonkCoVarOcc env v - | otherwise - = return (Var $ zonkIdOcc env v) -zonkCoreExpr _ (Lit l) - = return $ Lit l -zonkCoreExpr env (Coercion co) - = Coercion <$> zonkCoToCo env co -zonkCoreExpr env (Type ty) - = Type <$> zonkTcTypeToTypeX env ty - -zonkCoreExpr env (Cast e co) - = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co -zonkCoreExpr env (Tick t e) - = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks? - -zonkCoreExpr env (App e1 e2) - = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2 -zonkCoreExpr env (Lam v e) - = do { (env1, v') <- zonkCoreBndrX env v - ; Lam v' <$> zonkCoreExpr env1 e } -zonkCoreExpr env (Let bind e) - = do (env1, bind') <- zonkCoreBind env bind - Let bind'<$> zonkCoreExpr env1 e -zonkCoreExpr env (Case scrut b ty alts) - = do scrut' <- zonkCoreExpr env scrut - ty' <- zonkTcTypeToTypeX env ty - b' <- zonkIdBndr env b - let env1 = extendIdZonkEnv env b' - alts' <- mapM (zonkCoreAlt env1) alts - return $ Case scrut' b' ty' alts' - -zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt -zonkCoreAlt env (dc, bndrs, rhs) - = do (env1, bndrs') <- zonkCoreBndrsX env bndrs - rhs' <- zonkCoreExpr env1 rhs - return $ (dc, bndrs', rhs') - -zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) -zonkCoreBind env (NonRec v e) - = do v' <- zonkIdBndr env v - e' <- zonkCoreExpr env e - let env1 = extendIdZonkEnv env v' - return (env1, NonRec v' e') -zonkCoreBind env (Rec pairs) - = do (env1, pairs') <- fixM go - return (env1, Rec pairs') - where - go ~(_, new_pairs) = do - let env1 = extendIdZonkEnvRec env (map fst new_pairs) - pairs' <- mapM (zonkCorePair env1) pairs - return (env1, pairs') - -zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr) -zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e - -zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable -zonkEvTypeable env (EvTypeableTyCon tycon e) - = do { e' <- mapM (zonkEvTerm env) e - ; return $ EvTypeableTyCon tycon e' } -zonkEvTypeable env (EvTypeableTyApp t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTyApp t1' t2') } -zonkEvTypeable env (EvTypeableTrFun t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTrFun t1' t2') } -zonkEvTypeable env (EvTypeableTyLit t1) - = do { t1' <- zonkEvTerm env t1 - ; return (EvTypeableTyLit t1') } - -zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) -zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs - ; return (env, [EvBinds (unionManyBags bs')]) } - -zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) -zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs - ; return (env', EvBinds bs') } - -zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) -zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var -zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs - -zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) -zonkEvBindsVar env (EvBindsVar { ebv_binds = ref }) - = do { bs <- readMutVar ref - ; zonkEvBinds env (evBindMapBinds bs) } -zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag) - -zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) -zonkEvBinds env binds - = {-# SCC "zonkEvBinds" #-} - fixM (\ ~( _, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) - ; binds' <- mapBagM (zonkEvBind env1) binds - ; return (env1, binds') }) - where - collect_ev_bndrs :: Bag EvBind -> [EvVar] - collect_ev_bndrs = foldr add [] - add (EvBind { eb_lhs = var }) vars = var : vars - -zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind -zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) - = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var - - -- Optimise the common case of Refl coercions - -- See Note [Optimise coercion zonking] - -- This has a very big effect on some programs (eg #5030) - - ; term' <- case getEqPredTys_maybe (idType var') of - Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (evCoercion (mkTcReflCo r ty1)) - _other -> zonkEvTerm env term - - ; return (bind { eb_lhs = var', eb_rhs = term' }) } - -{- Note [Optimise coercion zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When optimising evidence binds we may come across situations where -a coercion looks like - cv = ReflCo ty -or cv1 = cv2 -where the type 'ty' is big. In such cases it is a waste of time to zonk both - * The variable on the LHS - * The coercion on the RHS -Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just -use Refl on the right, ignoring the actual coercion on the RHS. - -This can have a very big effect, because the constraint solver sometimes does go -to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) - - -************************************************************************ -* * - Zonking types -* * -************************************************************************ --} - -{- Note [Sharing when zonking to Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: - - In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to - (Indirect zty), see Note [Sharing in zonking] in TcMType. But we - /can't/ do this when zonking a TcType to a Type (#15552, esp - comment:3). Suppose we have - - alpha -> alpha - where - alpha is already unified: - alpha := T{tc-tycon} Int -> Int - and T is knot-tied - - By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, - but the global env contains a mapping "T" :-> T{knot-tied-tc}. See - Note [Type checking recursive type and class declarations] in - TcTyClsDecls. - - Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow - the same path as Note [Sharing in zonking] in TcMType, we'll - update alpha to - alpha := T{knot-tied-tc} Int -> Int - - But alas, if we encounter alpha for a /second/ time, we end up - looking at T{knot-tied-tc} and fall into a black hole. The whole - point of zonkTcTypeToType is that it produces a type full of - knot-tied tycons, and you must not look at the result!! - - To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not - the same as zonkTcTypeToType. (If we distinguished TcType from - Type, this issue would have been a type error!) - -Solution: (see #15552 for other variants) - - One possible solution is simply not to do the short-circuiting. - That has less sharing, but maybe sharing is rare. And indeed, - that turns out to be viable from a perf point of view - - But the code implements something a bit better - - * ZonkEnv contains ze_meta_tv_env, which maps - from a MetaTyVar (unificaion variable) - to a Type (not a TcType) - - * In zonkTyVarOcc, we check this map to see if we have zonked - this variable before. If so, use the previous answer; if not - zonk it, and extend the map. - - * The map is of course stateful, held in a TcRef. (That is unlike - the treatment of lexically-scoped variables in ze_tv_env and - ze_id_env.) - - Is the extra work worth it? Some non-sytematic perf measurements - suggest that compiler allocation is reduced overall (by 0.5% or so) - but compile time really doesn't change. --} - -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType -zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi - , ze_tv_env = tv_env - , ze_meta_tv_env = mtv_env_ref }) tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> lookup_in_tv_env - RuntimeUnk {} -> lookup_in_tv_env - MetaTv { mtv_ref = ref } - -> do { mtv_env <- readTcRef mtv_env_ref - -- See Note [Sharing when zonking to Type] - ; case lookupVarEnv mtv_env tv of - Just ty -> return ty - Nothing -> do { mtv_details <- readTcRef ref - ; zonk_meta mtv_env ref mtv_details } } - | otherwise - = lookup_in_tv_env - - where - lookup_in_tv_env -- Look up in the env just as we do for Ids - = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv - Just tv' -> return (mkTyVarTy tv') - - zonk_meta mtv_env ref Flexi - = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) - ; ty <- commitFlexi flexi tv kind - ; writeMetaTyVarRef tv ref ty -- Belt and braces - ; finish_meta mtv_env ty } - - zonk_meta mtv_env _ (Indirect ty) - = do { zty <- zonkTcTypeToTypeX env ty - ; finish_meta mtv_env zty } - - finish_meta mtv_env ty - = do { let mtv_env' = extendVarEnv mtv_env tv ty - ; writeTcRef mtv_env_ref mtv_env' - ; return ty } - -lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar -lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv - = lookupVarEnv tv_env tv - -commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type --- Only monadic so we can do tc-tracing -commitFlexi flexi tv zonked_kind - = case flexi of - SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) - - DefaultFlexi - | isRuntimeRepTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) - ; return liftedRepTy } - | otherwise - -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) - ; return (anyTypeOfKind zonked_kind) } - - RuntimeUnkFlexi - -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) - ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } - -- This is where RuntimeUnks are born: - -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnks as they leave the - -- typechecker's monad - where - name = tyVarName tv - -zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion -zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv - | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env - = return $ mkCoVarCo cv' - | otherwise - = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') } - -zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion -zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) - = do { contents <- readTcRef ref - ; case contents of - Just co -> do { co' <- zonkCoToCo env co - ; checkCoercionHole cv co' } - - -- This next case should happen only in the presence of - -- (undeferred) type errors. Originally, I put in a panic - -- here, but that caused too many uses of `failIfErrsM`. - Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole) - ; when debugIsOn $ - whenNoErrs $ - MASSERT2( False - , text "Type-correct unfilled coercion hole" - <+> ppr hole ) - ; cv' <- zonkCoVar cv - ; return $ mkCoVarCo cv' } } - -- This will be an out-of-scope variable, but keeping - -- this as a coercion hole led to #15787 - -zonk_tycomapper :: TyCoMapper ZonkEnv TcM -zonk_tycomapper = TyCoMapper - { tcm_tyvar = zonkTyVarOcc - , tcm_covar = zonkCoVarOcc - , tcm_hole = zonkCoHole - , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv - , tcm_tycon = zonkTcTyConToTyCon } - --- Zonk a TyCon by changing a TcTyCon to a regular TyCon -zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon -zonkTcTyConToTyCon tc - | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) - ; case thing of - ATyCon real_tc -> return real_tc - _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } - | otherwise = return tc -- it's already zonked - --- Confused by zonking? See Note [What is zonking?] in TcMType. -zonkTcTypeToType :: TcType -> TcM Type -zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty - -zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type -zonkTcTypeToTypeX = mapType zonk_tycomapper - -zonkTcTypesToTypes :: [TcType] -> TcM [Type] -zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys - -zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] -zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys - -zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -zonkCoToCo = mapCoercion zonk_tycomapper - -zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo -zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; gdm_spec' <- zonk_gdm gdm_spec - ; return (name, ty', gdm_spec') } - where - zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) - -> TcM (Maybe (DefMethSpec (SrcSpan, Type))) - zonk_gdm Nothing = return Nothing - zonk_gdm (Just VanillaDM) = return (Just VanillaDM) - zonk_gdm (Just (GenericDM (loc, ty))) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; return (Just (GenericDM (loc, ty'))) } - ---------------------------------------- -{- Note [Zonking the LHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also DsBinds Note [Free tyvars on rule LHS] - -We need to gather the type variables mentioned on the LHS so we can -quantify over them. Example: - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)) and we do -not want to zap the unbound meta-tyvar 'alpha' to Any, because that -limits the applicability of the rule. Instead, we want to quantify -over it! - -We do this in two stages. - -* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We - do this by using zonkTvSkolemising as the UnboundTyVarZonker in the - ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a - UnboundTyVarZonker.) - -* In DsBinds, we quantify over it. See DsBinds - Note [Free tyvars on rule LHS] - -Quantifying here is awkward because (a) the data type is big and (b) -finding the free type vars of an expression is necessarily monadic -operation. (consider /\a -> f @ b, where b is side-effected to a) --} diff --git a/typecheck/TcHsType.hs b/typecheck/TcHsType.hs deleted file mode 100644 --- a/typecheck/TcHsType.hs +++ /dev/null @@ -1,3643 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcMonoType]{Typechecking user-specified @MonoTypes@} --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcHsType ( - -- Type signatures - kcClassSigType, tcClassSigType, - tcHsSigType, tcHsSigWcType, - tcHsPartialSigType, - tcStandaloneKindSig, - funsSigCtxt, addSigCtxt, pprSigCtxt, - - tcHsClsInstType, - tcHsDeriv, tcDerivStrategy, - tcHsTypeApp, - UserTypeCtxt(..), - bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, - bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, - bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, - bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, - ContextKind(..), - - -- Type checking type and class decls - kcLookupTcTyCon, bindTyClTyVars, - etaExpandAlgTyCon, tcbVisibilities, - - -- tyvars - zonkAndScopedSort, - - -- Kind-checking types - -- No kind generalisation, no checkValidType - InitialKindStrategy(..), - SAKS_or_CUSK(..), - kcDeclHeader, - tcNamedWildCardBinders, - tcHsLiftedType, tcHsOpenType, - tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType, - tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps, - failIfEmitsConstraints, - solveEqualities, -- useful re-export - - typeLevelMode, kindLevelMode, - - kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, - checkExpectedKind_pp, - - -- Sort-checking kinds - tcLHsKindSig, checkDataKindSig, DataSort(..), - checkClassKindSig, - - -- Pattern type signatures - tcHsPatSigType, tcPatSig, - - -- Error messages - funAppCtxt, addTyConFlavCtxt - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcRnMonad -import TcOrigin -import Predicate -import Constraint -import TcEvidence -import TcEnv -import TcMType -import TcValidity -import TcUnify -import TcIface -import TcSimplify -import TcHsSyn -import TyCoRep -import TyCoPpr -import TcErrors ( reportAllUnsolved ) -import TcType -import Inst ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) -import Type -import TysPrim -import RdrName( lookupLocalRdrOcc ) -import Var -import VarSet -import TyCon -import ConLike -import DataCon -import Class -import Name --- import NameSet -import VarEnv -import TysWiredIn -import BasicTypes -import SrcLoc -import Constants ( mAX_CTUPLE_SIZE ) -import ErrUtils( MsgDoc ) -import Unique -import UniqSet -import Util -import UniqSupply -import Outputable -import FastString -import PrelNames hiding ( wildCardName ) -import DynFlags -import qualified GHC.LanguageExtensions as LangExt - -import Maybes -import Data.List ( find ) -import Control.Monad - -{- - ---------------------------- - General notes - ---------------------------- - -Unlike with expressions, type-checking types both does some checking and -desugars at the same time. This is necessary because we often want to perform -equality checks on the types right away, and it would be incredibly painful -to do this on un-desugared types. Luckily, desugared types are close enough -to HsTypes to make the error messages sane. - -During type-checking, we perform as little validity checking as possible. -Generally, after type-checking, you will want to do validity checking, say -with TcValidity.checkValidType. - -Validity checking -~~~~~~~~~~~~~~~~~ -Some of the validity check could in principle be done by the kind checker, -but not all: - -- During desugaring, we normalise by expanding type synonyms. Only - after this step can we check things like type-synonym saturation - e.g. type T k = k Int - type S a = a - Then (T S) is ok, because T is saturated; (T S) expands to (S Int); - and then S is saturated. This is a GHC extension. - -- Similarly, also a GHC extension, we look through synonyms before complaining - about the form of a class or instance declaration - -- Ambiguity checks involve functional dependencies - -Also, in a mutually recursive group of types, we can't look at the TyCon until we've -finished building the loop. So to keep things simple, we postpone most validity -checking until step (3). - -%************************************************************************ -%* * - Check types AND do validity checking -* * -************************************************************************ --} - -funsSigCtxt :: [Located Name] -> UserTypeCtxt --- Returns FunSigCtxt, with no redundant-context-reporting, --- form a list of located names -funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False -funsSigCtxt [] = panic "funSigCtxt" - -addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a -addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLoc hs_ty) $ - addErrCtxt (pprSigCtxt ctxt hs_ty) $ - thing_inside - -pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc --- (pprSigCtxt ctxt ) --- prints In the type signature for 'f': --- f :: --- The is either empty or "the ambiguity check for" -pprSigCtxt ctxt hs_ty - | Just n <- isSigMaybe ctxt - = hang (text "In the type signature:") - 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) - - | otherwise - = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) - 2 (ppr hs_ty) - -tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type --- This one is used when we have a LHsSigWcType, but in --- a place where wildcards aren't allowed. The renamer has --- already checked this, so we can simply ignore it. -tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) - -kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () -kcClassSigType skol_info names sig_ty - = discardResult $ - tcClassSigType skol_info names sig_ty - -- tcClassSigType does a fair amount of extra work that we don't need, - -- such as ordering quantified variables. But we absolutely do need - -- to push the level when checking method types and solve local equalities, - -- and so it seems easier just to call tcClassSigType than selectively - -- extract the lines of code from tc_hs_sig_type that we really need. - -- If we don't push the level, we get #16517, where GHC accepts - -- class C a where - -- meth :: forall k. Proxy (a :: k) -> () - -- Note that k is local to meth -- this is hogwash. - -tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type --- Does not do validity checking -tcClassSigType skol_info names sig_ty - = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) - -- Do not zonk-to-Type, nor perform a validity check - -- We are in a knot with the class and associated types - -- Zonking and validity checking is done by tcClassDecl - -- No need to fail here if the type has an error: - -- If we're in the kind-checking phase, the solveEqualities - -- in kcTyClGroup catches the error - -- If we're in the type-checking phase, the solveEqualities - -- in tcClassDecl1 gets it - -- Failing fast here degrades the error message in, e.g., tcfail135: - -- class Foo f where - -- baa :: f a -> f - -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. - -- It should be that f has kind `k2 -> *`, but we never get a chance - -- to run the solver where the kind of f is touchable. This is - -- painfully delicate. - -tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type --- Does validity checking --- See Note [Recipe for checking a signature] -tcHsSigType ctxt sig_ty - = addSigCtxt ctxt (hsSigType sig_ty) $ - do { traceTc "tcHsSigType {" (ppr sig_ty) - - -- Generalise here: see Note [Kind generalisation] - ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty - (expectedKindInCtxt ctxt) - ; ty <- zonkTcType ty - - ; when insol failM - -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify - - ; checkValidType ctxt ty - ; traceTc "end tcHsSigType }" (ppr ty) - ; return ty } - where - skol_info = SigTypeSkol ctxt - --- Does validity checking and zonking. -tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) -tcStandaloneKindSig (L _ kisig) = case kisig of - StandaloneKindSig _ (L _ name) ksig -> - let ctxt = StandaloneKindSigCtxt name in - addSigCtxt ctxt (hsSigType ksig) $ - do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt) - ; checkValidType ctxt kind - ; return (name, kind) } - XStandaloneKindSig nec -> noExtCon nec - -tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM (Bool, TcType) --- Kind-checks/desugars an 'LHsSigType', --- solve equalities, --- and then kind-generalizes. --- This will never emit constraints, as it uses solveEqualities interally. --- No validity checking or zonking --- Returns also a Bool indicating whether the type induced an insoluble constraint; --- True <=> constraint is insoluble -tc_hs_sig_type skol_info hs_sig_type ctxt_kind - | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type - = do { (tc_lvl, (wanted, (spec_tkvs, ty))) - <- pushTcLevelM $ - solveLocalEqualitiesX "tc_hs_sig_type" $ - bindImplicitTKBndrs_Skol sig_vars $ - do { kind <- newExpectedKind ctxt_kind - ; tc_lhs_type typeLevelMode hs_ty kind } - -- Any remaining variables (unsolved in the solveLocalEqualities) - -- should be in the global tyvars, and therefore won't be quantified - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - ; let ty1 = mkSpecForAllTys spec_tkvs ty - - -- This bit is very much like decideMonoTyVars in TcSimplify, - -- but constraints are so much simpler in kinds, it is much - -- easier here. (In particular, we never quantify over a - -- constraint in a type.) - ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) - ; let should_gen = not . (`elemVarSet` constrained) - - ; kvs <- kindGeneralizeSome should_gen ty1 - ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) - tc_lvl wanted - - ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } - -tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec - -tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type --- tcTopLHsType is used for kind-checking top-level HsType where --- we want to fully solve /all/ equalities, and report errors --- Does zonking, but not validity checking because it's used --- for things (like deriving and instances) that aren't --- ordinary types -tcTopLHsType mode hs_sig_type ctxt_kind - | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type - = do { traceTc "tcTopLHsType {" (ppr hs_ty) - ; (spec_tkvs, ty) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Skol sig_vars $ - do { kind <- newExpectedKind ctxt_kind - ; tc_lhs_type mode hs_ty kind } - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - ; let ty1 = mkSpecForAllTys spec_tkvs ty - ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type - ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1) - ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) - ; return final_ty} - -tcTopLHsType _ (XHsImplicitBndrs nec) _ = noExtCon nec - ------------------ -tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) --- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause --- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments --- E.g. class C (a::*) (b::k->k) --- data T a b = ... deriving( C Int ) --- returns ([k], C, [k, Int], [k->k]) --- Return values are fully zonked -tcHsDeriv hs_ty - = do { ty <- checkNoErrs $ -- Avoid redundant error report - -- with "illegal deriving", below - tcTopLHsType typeLevelMode hs_ty AnyKind - ; let (tvs, pred) = splitForAllTys ty - (kind_args, _) = splitFunTys (tcTypeKind pred) - ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, kind_args) - Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } - --- | Typecheck a deriving strategy. For most deriving strategies, this is a --- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. -tcDerivStrategy :: - Maybe (LDerivStrategy GhcRn) - -- ^ The deriving strategy - -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]) - -- ^ The typechecked deriving strategy and the tyvars that it binds - -- (if using 'ViaStrategy'). -tcDerivStrategy mb_lds - = case mb_lds of - Nothing -> boring_case Nothing - Just (dL->L loc ds) -> - setSrcSpan loc $ do - (ds', tvs) <- tc_deriv_strategy ds - pure (Just (cL loc ds'), tvs) - where - tc_deriv_strategy :: DerivStrategy GhcRn - -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy StockStrategy = boring_case StockStrategy - tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy - tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy - tc_deriv_strategy (ViaStrategy ty) = do - ty' <- checkNoErrs $ tcTopLHsType typeLevelMode ty AnyKind - let (via_tvs, via_pred) = splitForAllTys ty' - pure (ViaStrategy via_pred, via_tvs) - - boring_case :: ds -> TcM (ds, [TyVar]) - boring_case ds = pure (ds, []) - -tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt - -> LHsSigType GhcRn - -> TcM Type --- Like tcHsSigType, but for a class instance declaration -tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $ - do { -- Fail eagerly if tcTopLHsType fails. We are at top level so - -- these constraints will never be solved later. And failing - -- eagerly avoids follow-on errors when checkValidInstance - -- sees an unsolved coercion hole - inst_ty <- checkNoErrs $ - tcTopLHsType typeLevelMode hs_inst_ty (TheKind constraintKind) - ; checkValidInstance user_ctxt hs_inst_ty inst_ty - ; return inst_ty } - ----------------------------------------------- --- | Type-check a visible type application -tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type --- See Note [Recipe for checking a signature] in TcHsType -tcHsTypeApp wc_ty kind - | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty - = do { ty <- solveLocalEqualities "tcHsTypeApp" $ - -- We are looking at a user-written type, very like a - -- signature so we want to solve its equalities right now - unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- See Note [Wildcards in visible type application] - tcNamedWildCardBinders sig_wcs $ \ _ -> - tcCheckLHsType hs_ty kind - -- We do not kind-generalize type applications: we just - -- instantiate with exactly what the user says. - -- See Note [No generalization in type application] - -- We still must call kindGeneralizeNone, though, according - -- to Note [Recipe for checking a signature] - ; kindGeneralizeNone ty - ; ty <- zonkTcType ty - ; checkValidType TypeAppCtxt ty - ; return ty } -tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec - -{- Note [Wildcards in visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so -any unnamed wildcards stay unchanged in hswc_body. When called in -tcHsTypeApp, tcCheckLHsType will call emitAnonWildCardHoleConstraint -on these anonymous wildcards. However, this would trigger -error/warning when an anonymous wildcard is passed in as a visible type -argument, which we do not want because users should be able to write -@_ to skip a instantiating a type variable variable without fuss. The -solution is to switch the PartialTypeSignatures flags here to let the -typechecker know that it's checking a '@_' and do not emit hole -constraints on it. See related Note [Wildcards in visible kind -application] and Note [The wildcard story for types] in GHC.Hs.Types - -Ugh! - -Note [No generalization in type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not kind-generalize type applications. Imagine - - id @(Proxy Nothing) - -If we kind-generalized, we would get - - id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) - -which is very sneakily impredicative instantiation. - -There is also the possibility of mentioning a wildcard -(`id @(Proxy _)`), which definitely should not be kind-generalized. - --} - -{- -************************************************************************ -* * - The main kind checker: no validity checks here -* * -************************************************************************ --} - ---------------------------- -tcHsOpenType, tcHsLiftedType, - tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType --- Used for type signatures --- Do not do validity checking -tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty -tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty - -tcHsOpenTypeNC ty = do { ek <- newOpenTypeKind - ; tc_lhs_type typeLevelMode ty ek } -tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind - --- Like tcHsType, but takes an expected kind -tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType -tcCheckLHsType hs_ty exp_kind - = addTypeCtxt hs_ty $ - tc_lhs_type typeLevelMode hs_ty exp_kind - -tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind) --- Called from outside: set the context -tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) - --- Like tcLHsType, but use it in a context where type synonyms and type families --- do not need to be saturated, like in a GHCi :kind call -tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) -tcLHsTypeUnsaturated hs_ty - | Just (hs_fun_ty, hs_args) <- splitHsAppTys (unLoc hs_ty) - = addTypeCtxt hs_ty $ - do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty - ; tcInferApps_nosat mode hs_fun_ty fun_ty hs_args } - -- Notice the 'nosat'; do not instantiate trailing - -- invisible arguments of a type family. - -- See Note [Dealing with :kind] - - | otherwise - = addTypeCtxt hs_ty $ - tc_infer_lhs_type mode hs_ty - - where - mode = typeLevelMode - -{- Note [Dealing with :kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GHCi command - ghci> type family F :: Either j k - ghci> :kind F - F :: forall {j,k}. Either j k - -We will only get the 'forall' if we /refrain/ from saturating those -invisible binders. But generally we /do/ saturate those invisible -binders (see tcInferApps), and we want to do so for nested application -even in GHCi. Consider for example (#16287) - ghci> type family F :: k - ghci> data T :: (forall k. k) -> Type - ghci> :kind T F -We want to reject this. It's just at the very top level that we want -to switch off saturation. - -So tcLHsTypeUnsaturated does a little special case for top level -applications. Actually the common case is a bare variable, as above. - - -************************************************************************ -* * - Type-checking modes -* * -************************************************************************ - -The kind-checker is parameterised by a TcTyMode, which contains some -information about where we're checking a type. - -The renamer issues errors about what it can. All errors issued here must -concern things that the renamer can't handle. - --} - --- | Info about the context in which we're checking a type. Currently, --- differentiates only between types and kinds, but this will likely --- grow, at least to include the distinction between patterns and --- not-patterns. --- --- To find out where the mode is used, search for 'mode_level' -data TcTyMode = TcTyMode { mode_level :: TypeOrKind } - -typeLevelMode :: TcTyMode -typeLevelMode = TcTyMode { mode_level = TypeLevel } - -kindLevelMode :: TcTyMode -kindLevelMode = TcTyMode { mode_level = KindLevel } - --- switch to kind level -kindLevel :: TcTyMode -> TcTyMode -kindLevel mode = mode { mode_level = KindLevel } - -instance Outputable TcTyMode where - ppr = ppr . mode_level - -{- -Note [Bidirectional type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In expressions, whenever we see a polymorphic identifier, say `id`, we are -free to instantiate it with metavariables, knowing that we can always -re-generalize with type-lambdas when necessary. For example: - - rank2 :: (forall a. a -> a) -> () - x = rank2 id - -When checking the body of `x`, we can instantiate `id` with a metavariable. -Then, when we're checking the application of `rank2`, we notice that we really -need a polymorphic `id`, and then re-generalize over the unconstrained -metavariable. - -In types, however, we're not so lucky, because *we cannot re-generalize*! -There is no lambda. So, we must be careful only to instantiate at the last -possible moment, when we're sure we're never going to want the lost polymorphism -again. This is done in calls to tcInstInvisibleTyBinders. - -To implement this behavior, we use bidirectional type checking, where we -explicitly think about whether we know the kind of the type we're checking -or not. Note that there is a difference between not knowing a kind and -knowing a metavariable kind: the metavariables are TauTvs, and cannot become -forall-quantified kinds. Previously (before dependent types), there were -no higher-rank kinds, and so we could instantiate early and be sure that -no types would have polymorphic kinds, and so we could always assume that -the kind of a type was a fresh metavariable. Not so anymore, thus the -need for two algorithms. - -For HsType forms that can never be kind-polymorphic, we implement only the -"down" direction, where we safely assume a metavariable kind. For HsType forms -that *can* be kind-polymorphic, we implement just the "up" (functions with -"infer" in their name) version, as we gain nothing by also implementing the -"down" version. - -Note [Future-proofing the type checker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As discussed in Note [Bidirectional type checking], each HsType form is -handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions -are mutually recursive, so that either one can work for any type former. -But, we want to make sure that our pattern-matches are complete. So, -we have a bunch of repetitive code just so that we get warnings if we're -missing any patterns. - --} - ------------------------------------------- --- | Check and desugar a type, returning the core type and its --- possibly-polymorphic kind. Much like 'tcInferRho' at the expression --- level. -tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) -tc_infer_lhs_type mode (L span ty) - = setSrcSpan span $ - tc_infer_hs_type mode ty - ---------------------------- --- | Call 'tc_infer_hs_type' and check its result against an expected kind. -tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType -tc_infer_hs_type_ek mode hs_ty ek - = do { (ty, k) <- tc_infer_hs_type mode hs_ty - ; checkExpectedKind hs_ty ty k ek } - ---------------------------- --- | Infer the kind of a type and desugar. This is the "up" type-checker, --- as described in Note [Bidirectional type checking] -tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) - -tc_infer_hs_type mode (HsParTy _ t) - = tc_infer_lhs_type mode t - -tc_infer_hs_type mode ty - | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty - = do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty - ; tcInferApps mode hs_fun_ty fun_ty hs_args } - -tc_infer_hs_type mode (HsKindSig _ ty sig) - = do { sig' <- tcLHsKindSig KindSigCtxt sig - -- We must typecheck the kind signature, and solve all - -- its equalities etc; from this point on we may do - -- things like instantiate its foralls, so it needs - -- to be fully determined (#14904) - ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig') - ; ty' <- tc_lhs_type mode ty sig' - ; return (ty', sig') } - --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate --- the splice location to the typechecker. Here we skip over it in order to have --- the same kind inferred for a given expression whether it was produced from --- splices or not. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) - = tc_infer_hs_type mode ty - -tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty -tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) - = return (ty, tcTypeKind ty) - -tc_infer_hs_type _ (HsExplicitListTy _ _ tys) - | null tys -- this is so that we can use visible kind application with '[] - -- e.g ... '[] @Bool - = return (mkTyConTy promotedNilDataCon, - mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) - -tc_infer_hs_type mode other_ty - = do { kv <- newMetaKindVar - ; ty' <- tc_hs_type mode other_ty kv - ; return (ty', kv) } - ------------------------------------------- -tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType -tc_lhs_type mode (L span ty) exp_kind - = setSrcSpan span $ - tc_hs_type mode ty exp_kind - -tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType --- See Note [Bidirectional type checking] - -tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type _ ty@(HsBangTy _ bang _) _ - -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), - -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of - -- bangs are invalid, so fail. (#7210, #14761) - = do { let bangError err = failWith $ - text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ - text err <+> text "annotation cannot appear nested inside a type" - ; case bang of - HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" - HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" - HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" - HsSrcBang _ _ _ -> bangError "strictness" } -tc_hs_type _ ty@(HsRecTy {}) _ - -- Record types (which only show up temporarily in constructor - -- signatures) should have been removed by now - = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) - --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'. --- Here we get rid of it and add the finalizers to the global environment --- while capturing the local environment. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) - exp_kind - = do addModFinalizersWithLclEnv mod_finalizers - tc_hs_type mode ty exp_kind - --- This should never happen; type splices are expanded by the renamer -tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (text "Unexpected type splice:" <+> ppr ty) - ----------- Functions and applications -tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind - = tc_fun_type mode ty1 ty2 exp_kind - -tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind - | op `hasKey` funTyConKey - = tc_fun_type mode ty1 ty2 exp_kind - ---------- Foralls -tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs - , hst_body = ty }) exp_kind - = do { (tclvl, wanted, (tvs', ty')) - <- pushLevelAndCaptureConstraints $ - bindExplicitTKBndrs_Skol hs_tvs $ - tc_lhs_type mode ty exp_kind - -- Do not kind-generalise here! See Note [Kind generalisation] - -- Why exp_kind? See Note [Body kind of HsForAllTy] - ; let argf = case fvf of - ForallVis -> Required - ForallInvis -> Specified - bndrs = mkTyVarBinders argf tvs' - skol_info = ForAllSkol (ppr forall) - m_telescope = Just (sep (map ppr hs_tvs)) - - ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted - -- See Note [Skolem escape and forall-types] - - ; return (mkForAllTys bndrs ty') } - -tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind - | null (unLoc ctxt) - = tc_lhs_type mode rn_ty exp_kind - - -- See Note [Body kind of a HsQualTy] - | tcIsConstraintKind exp_kind - = do { ctxt' <- tc_hs_context mode ctxt - ; ty' <- tc_lhs_type mode rn_ty constraintKind - ; return (mkPhiTy ctxt' ty') } - - | otherwise - = do { ctxt' <- tc_hs_context mode ctxt - - ; ek <- newOpenTypeKind -- The body kind (result of the function) can - -- be TYPE r, for any r, hence newOpenTypeKind - ; ty' <- tc_lhs_type mode rn_ty ek - ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') - liftedTypeKind exp_kind } - ---------- Lists, arrays, and tuples -tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind - = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind - ; checkWiredInTyCon listTyCon - ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } - --- See Note [Distinguishing tuple kinds] in GHC.Hs.Types --- See Note [Inferring tuple kinds] -tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind - -- (NB: not zonking before looking at exp_k, to avoid left-right bias) - | Just tup_sort <- tupKindSort_maybe exp_kind - = traceTc "tc_hs_type tuple" (ppr hs_tys) >> - tc_tuple rn_ty mode tup_sort hs_tys exp_kind - | otherwise - = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) - ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys - ; kinds <- mapM zonkTcType kinds - -- Infer each arg type separately, because errors can be - -- confusing if we give them a shared kind. Eg #7410 - -- (Either Int, Int), we do not want to get an error saying - -- "the second argument of a tuple should have kind *->*" - - ; let (arg_kind, tup_sort) - = case [ (k,s) | k <- kinds - , Just s <- [tupKindSort_maybe k] ] of - ((k,s) : _) -> (k,s) - [] -> (liftedTypeKind, BoxedTuple) - -- In the [] case, it's not clear what the kind is, so guess * - - ; tys' <- sequence [ setSrcSpan loc $ - checkExpectedKind hs_ty ty kind arg_kind - | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] - - ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } - - -tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind - = tc_tuple rn_ty mode tup_sort tys exp_kind - where - tup_sort = case hs_tup_sort of -- Fourth case dealt with above - HsUnboxedTuple -> UnboxedTuple - HsBoxedTuple -> BoxedTuple - HsConstraintTuple -> ConstraintTuple - _ -> panic "tc_hs_type HsTupleTy" - -tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind - = do { let arity = length hs_tys - ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys - ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds - ; let arg_reps = map kindRep arg_kinds - arg_tys = arg_reps ++ tau_tys - sum_ty = mkTyConApp (sumTyCon arity) arg_tys - sum_kind = unboxedSumKind arg_reps - ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind - } - ---------- Promoted lists and tuples -tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind - = do { tks <- mapM (tc_infer_lhs_type mode) tys - ; (taus', kind) <- unifyKinds tys tks - ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') - ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } - where - mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] - mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] - -tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind - -- using newMetaKindVar means that we force instantiations of any polykinded - -- types. At first, I just used tc_infer_lhs_type, but that led to #11255. - = do { ks <- replicateM arity newMetaKindVar - ; taus <- zipWithM (tc_lhs_type mode) tys ks - ; let kind_con = tupleTyCon Boxed arity - ty_con = promotedTupleDataCon Boxed arity - tup_k = mkTyConApp kind_con ks - ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } - where - arity = length tys - ---------- Constraint types -tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind - = do { MASSERT( isTypeLevel (mode_level mode) ) - ; ty' <- tc_lhs_type mode ty liftedTypeKind - ; let n' = mkStrLitTy $ hsIPNameFS n - ; ipClass <- tcLookupClass ipClassName - ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) - constraintKind exp_kind } - -tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind - -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to - -- handle it in 'coreView' and 'tcView'. - = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind - ---------- Literals -tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon typeNatKindCon - ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } - -tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind - = do { checkWiredInTyCon typeSymbolKindCon - ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } - ---------- Potentially kind-polymorphic types: call the "up" checker --- See Note [Future-proofing the type checker] -tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type _ wc@(HsWildCardTy _) ek = tcAnonWildCardOcc wc ek - ------------------------------------------- -tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind - -> TcM TcType -tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of - TypeLevel -> - do { arg_k <- newOpenTypeKind - ; res_k <- newOpenTypeKind - ; ty1' <- tc_lhs_type mode ty1 arg_k - ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') - liftedTypeKind exp_kind } - KindLevel -> -- no representation polymorphism in kinds. yet. - do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind - ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') - liftedTypeKind exp_kind } - ---------------------------- -tcAnonWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType -tcAnonWildCardOcc wc exp_kind - = do { wc_tv <- newWildTyVar -- The wildcard's kind will be an un-filled-in meta tyvar - - ; part_tysig <- xoptM LangExt.PartialTypeSignatures - ; warning <- woptM Opt_WarnPartialTypeSignatures - - ; unless (part_tysig && not warning) $ - emitAnonWildCardHoleConstraint wc_tv - -- Why the 'unless' guard? - -- See Note [Wildcards in visible kind application] - - ; checkExpectedKind wc (mkTyVarTy wc_tv) - (tyVarKind wc_tv) exp_kind } - -{- Note [Wildcards in visible kind application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are cases where users might want to pass in a wildcard as a visible kind -argument, for instance: - -data T :: forall k1 k2. k1 → k2 → Type where - MkT :: T a b -x :: T @_ @Nat False n -x = MkT - -So we should allow '@_' without emitting any hole constraints, and -regardless of whether PartialTypeSignatures is enabled or not. But how would -the typechecker know which '_' is being used in VKA and which is not when it -calls emitNamedWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? -The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs, -but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. -And whenever we see a '@', we automatically turn on PartialTypeSignatures and -turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint -under these conditions. -See related Note [Wildcards in visible type application] here and -Note [The wildcard story for types] in GHC.Hs.Types - -Note [Skolem escape and forall-types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () - -The Proxy '[a,b] forces a and b to have the same kind. But a's -kind must be bound outside the 'forall a', and hence escapes. -We discover this by building an implication constraint for -each forall. So the inner implication constraint will look like - forall kb (b::kb). kb ~ ka -where ka is a's kind. We can't unify these two, /even/ if ka is -unification variable, because it would be untouchable inside -this inner implication. - -That's what the pushLevelAndCaptureConstraints, plus subsequent -emitResidualTvConstraint is all about, when kind-checking -HsForAllTy. - -Note that we don't need to /simplify/ the constraints here -because we aren't generalising. We just capture them. --} - -{- ********************************************************************* -* * - Tuples -* * -********************************************************************* -} - ---------------------------- -tupKindSort_maybe :: TcKind -> Maybe TupleSort -tupKindSort_maybe k - | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- tcView k = tupKindSort_maybe k' - | tcIsConstraintKind k = Just ConstraintTuple - | tcIsLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing - -tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType -tc_tuple rn_ty mode tup_sort tys exp_kind - = do { arg_kinds <- case tup_sort of - BoxedTuple -> return (replicate arity liftedTypeKind) - UnboxedTuple -> replicateM arity newOpenTypeKind - ConstraintTuple -> return (replicate arity constraintKind) - ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds - ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } - where - arity = length tys - -finish_tuple :: HsType GhcRn - -> TupleSort - -> [TcType] -- ^ argument types - -> [TcKind] -- ^ of these kinds - -> TcKind -- ^ expected kind of the whole tuple - -> TcM TcType -finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do - traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) - case tup_sort of - ConstraintTuple - | [tau_ty] <- tau_tys - -- Drop any uses of 1-tuple constraints here. - -- See Note [Ignore unary constraint tuples] - -> check_expected_kind tau_ty constraintKind - | arity > mAX_CTUPLE_SIZE - -> failWith (bigConstraintTuple arity) - | otherwise - -> do tycon <- tcLookupTyCon (cTupleTyConName arity) - check_expected_kind (mkTyConApp tycon tau_tys) constraintKind - BoxedTuple -> do - let tycon = tupleTyCon Boxed arity - checkWiredInTyCon tycon - check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind - UnboxedTuple -> - let tycon = tupleTyCon Unboxed arity - tau_reps = map kindRep tau_kinds - -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon - arg_tys = tau_reps ++ tau_tys - res_kind = unboxedTupleKind tau_reps in - check_expected_kind (mkTyConApp tycon arg_tys) res_kind - where - arity = length tau_tys - check_expected_kind ty act_kind = - checkExpectedKind rn_ty ty act_kind exp_kind - -bigConstraintTuple :: Arity -> MsgDoc -bigConstraintTuple arity - = hang (text "Constraint tuple arity too large:" <+> int arity - <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) - 2 (text "Instead, use a nested tuple") - -{- -Note [Ignore unary constraint tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in -TysWiredIn) but does *not* provide unary constraint tuples. Why? First, -recall the definition of a unary tuple data type: - - data Unit a = Unit a - -Note that `Unit a` is *not* the same thing as `a`, since Unit is boxed and -lazy. Therefore, the presence of `Unit` matters semantically. On the other -hand, suppose we had a unary constraint tuple: - - class a => Unit% a - -This compiles down a newtype (i.e., a cast) in Core, so `Unit% a` is -semantically equivalent to `a`. Therefore, a 1-tuple constraint would have -no user-visible impact, nor would it allow you to express anything that -you couldn't otherwise. - -We could simply add Unit% for consistency with tuples (Unit) and unboxed -tuples (Unit#), but that would require even more magic to wire in another -magical class, so we opt not to do so. We must be careful, however, since -one can try to sneak in uses of unary constraint tuples through Template -Haskell, such as in this program (from #17511): - - f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] - (ConT ''String))) - -- f :: Unit% (Show Int) => String - f = "abc" - -This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, -and since it is used in a Constraint position, GHC will attempt to treat -it as thought it were a constraint tuple, which can potentially lead to -trouble if one attempts to look up the name of a constraint tuple of arity -1 (as it won't exist). To avoid this trouble, we simply take any unary -constraint tuples discovered when typechecking and drop them—i.e., treat -"Unit% a" as though the user had written "a". This is always safe to do -since the two constraints should be semantically equivalent. --} - -{- ********************************************************************* -* * - Type applications -* * -********************************************************************* -} - -splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) -splitHsAppTys hs_ty - | is_app hs_ty = Just (go (noLoc hs_ty) []) - | otherwise = Nothing - where - is_app :: HsType GhcRn -> Bool - is_app (HsAppKindTy {}) = True - is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey) - -- I'm not sure why this funTyConKey test is necessary - -- Can it even happen? Perhaps for t1 `(->)` t2 - -- but then maybe it's ok to treat that like a normal - -- application rather than using the special rule for HsFunTy - is_app (HsTyVar {}) = True - is_app (HsParTy _ (L _ ty)) = is_app ty - is_app _ = False - - go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) - go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as) - go (L _ (HsOpTy _ l op@(L sp _) r)) as - = ( L sp (HsTyVar noExtField NotPromoted op) - , HsValArg l : HsValArg r : as ) - go f as = (f, as) - ---------------------------- -tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) --- Version of tc_infer_lhs_type specialised for the head of an --- application. In particular, for a HsTyVar (which includes type --- constructors, it does not zoom off into tcInferApps and family --- saturation -tcInferAppHead mode (L _ (HsTyVar _ _ (L _ tv))) - = tcTyVar mode tv -tcInferAppHead mode ty - = tc_infer_lhs_type mode ty - ---------------------------- --- | Apply a type of a given kind to a list of arguments. This instantiates --- invisible parameters as necessary. Always consumes all the arguments, --- using matchExpectedFunKind as necessary. --- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- --- These kinds should be used to instantiate invisible kind variables; --- they come from an enclosing class for an associated type/data family. --- --- tcInferApps also arranges to saturate any trailing invisible arguments --- of a type-family application, which is usually the right thing to do --- tcInferApps_nosat does not do this saturation; it is used only --- by ":kind" in GHCi -tcInferApps, tcInferApps_nosat - :: TcTyMode - -> LHsType GhcRn -- ^ Function (for printing only) - -> TcType -- ^ Function - -> [LHsTypeArg GhcRn] -- ^ Args - -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) -tcInferApps mode hs_ty fun hs_args - = do { (f_args, res_k) <- tcInferApps_nosat mode hs_ty fun hs_args - ; saturateFamApp f_args res_k } - -tcInferApps_nosat mode orig_hs_ty fun orig_hs_args - = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) - ; (f_args, res_k) <- go_init 1 fun orig_hs_args - ; traceTc "tcInferApps }" (ppr f_args <+> dcolon <+> ppr res_k) - ; return (f_args, res_k) } - where - - -- go_init just initialises the auxiliary - -- arguments of the 'go' loop - go_init n fun all_args - = go n fun empty_subst fun_ki all_args - where - fun_ki = tcTypeKind fun - -- We do (tcTypeKind fun) here, even though the caller - -- knows the function kind, to absolutely guarantee - -- INVARIANT for 'go' - -- Note that in a typical application (F t1 t2 t3), - -- the 'fun' is just a TyCon, so tcTypeKind is fast - - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfType fun_ki - - go :: Int -- The # of the next argument - -> TcType -- Function applied to some args - -> TCvSubst -- Applies to function kind - -> TcKind -- Function kind - -> [LHsTypeArg GhcRn] -- Un-type-checked args - -> TcM (TcType, TcKind) -- Result type and its kind - -- INVARIANT: in any call (go n fun subst fun_ki args) - -- tcTypeKind fun = subst(fun_ki) - -- So the 'subst' and 'fun_ki' arguments are simply - -- there to avoid repeatedly calling tcTypeKind. - -- - -- Reason for INVARIANT: to support the Purely Kinded Type Invariant - -- it's important that if fun_ki has a forall, then so does - -- (tcTypeKind fun), because the next thing we are going to do - -- is apply 'fun' to an argument type. - - -- Dispatch on all_args first, for performance reasons - go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of - - ---------------- No user-written args left. We're done! - ([], _) -> return (fun, substTy subst fun_ki) - - ---------------- HsArgPar: We don't care about parens here - (HsArgPar _ : args, _) -> go n fun subst fun_ki args - - ---------------- HsTypeArg: a kind application (fun @ki) - (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> - case ki_binder of - - -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki - Anon InvisArg _ -> instantiate ki_binder inner_ki - - Named (Bndr _ Specified) -> -- Visible kind application - do { traceTc "tcInferApps (vis kind app)" - (vcat [ ppr ki_binder, ppr hs_ki_arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - - ; let exp_kind = substTy subst $ tyBinderType ki_binder - - ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ - unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- Urgh! see Note [Wildcards in visible kind application] - -- ToDo: must kill this ridiculous messing with DynFlags - tc_lhs_type (kindLevel mode) hs_ki_arg exp_kind - - ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg - ; go (n+1) fun' subst' inner_ki hs_args } - - -- Attempted visible kind application (fun @ki), but fun_ki is - -- forall k -> blah or k1 -> k2 - -- So we need a normal application. Error. - _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki - - -- No binder; try applying the substitution, or fail if that's not possible - (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ - ty_app_err ki_arg substed_fun_ki - - ---------------- HsValArg: a nomal argument (fun ty) - (HsValArg arg : args, Just (ki_binder, inner_ki)) - -- next binder is invisible; need to instantiate it - | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; - -- or ForAllTy with Inferred or Specified - -> instantiate ki_binder inner_ki - - -- "normal" case - | otherwise - -> do { traceTc "tcInferApps (vis normal app)" - (vcat [ ppr ki_binder - , ppr arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder - ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ - tc_lhs_type mode arg exp_kind - ; traceTc "tcInferApps (vis normal app) 2" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' - ; go (n+1) fun' subst' inner_ki args } - - -- no binder; try applying the substitution, or infer another arrow in fun kind - (HsValArg _ : _, Nothing) - -> try_again_after_substing_or $ - do { let arrows_needed = n_initial_val_args all_args - ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki - - ; fun' <- zonkTcType (fun `mkTcCastTy` co) - -- This zonk is essential, to expose the fruits - -- of matchExpectedFunKind to the 'go' loop - - ; traceTc "tcInferApps (no binder)" $ - vcat [ ppr fun <+> dcolon <+> ppr fun_ki - , ppr arrows_needed - , ppr co - , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] - ; go_init n fun' all_args } - -- Use go_init to establish go's INVARIANT - where - instantiate ki_binder inner_ki - = do { traceTc "tcInferApps (need to instantiate)" - (vcat [ ppr ki_binder, ppr subst]) - ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder - ; go n (mkAppTy fun arg') subst' inner_ki all_args } - -- Because tcInvisibleTyBinder instantiate ki_binder, - -- the kind of arg' will have the same shape as the kind - -- of ki_binder. So we don't need mkAppTyM here. - - try_again_after_substing_or fallthrough - | not (isEmptyTCvSubst subst) - = go n fun zapped_subst substed_fun_ki all_args - | otherwise - = fallthrough - - zapped_subst = zapTCvSubst subst - substed_fun_ki = substTy subst fun_ki - hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) - - n_initial_val_args :: [HsArg tm ty] -> Arity - -- Count how many leading HsValArgs we have - n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args - n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args - n_initial_val_args _ = 0 - - ty_app_err arg ty - = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) - - -mkAppTyM :: TCvSubst - -> TcType -> TyCoBinder -- fun, plus its top-level binder - -> TcType -- arg - -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) --- Precondition: the application (fun arg) is well-kinded after zonking --- That is, the application makes sense --- --- Precondition: for (mkAppTyM subst fun bndr arg) --- tcTypeKind fun = Pi bndr. body --- That is, fun always has a ForAllTy or FunTy at the top --- and 'bndr' is fun's pi-binder --- --- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type --- invariant, then so does the result type (fun arg) --- --- We do not require that --- tcTypeKind arg = tyVarKind (binderVar bndr) --- This must be true after zonking (precondition 1), but it's not --- required for the (PKTI). -mkAppTyM subst fun ki_binder arg - | -- See Note [mkAppTyM]: Nasty case 2 - TyConApp tc args <- fun - , isTypeSynonymTyCon tc - , args `lengthIs` (tyConArity tc - 1) - , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym - = do { arg' <- zonkTcType arg - ; args' <- zonkTcTypes args - ; let subst' = case ki_binder of - Anon {} -> subst - Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' - ; return (subst', mkTyConApp tc (args' ++ [arg'])) } - - -mkAppTyM subst fun (Anon {}) arg - = return (subst, mk_app_ty fun arg) - -mkAppTyM subst fun (Named (Bndr tv _)) arg - = do { arg' <- if isTrickyTvBinder tv - then -- See Note [mkAppTyM]: Nasty case 1 - zonkTcType arg - else return arg - ; return ( extendTvSubstAndInScope subst tv arg' - , mk_app_ty fun arg' ) } - -mk_app_ty :: TcType -> TcType -> TcType --- This function just adds an ASSERT for mkAppTyM's precondition -mk_app_ty fun arg - = ASSERT2( isPiTy fun_kind - , ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg ) - mkAppTy fun arg - where - fun_kind = tcTypeKind fun - -isTrickyTvBinder :: TcTyVar -> Bool --- NB: isTrickyTvBinder is just an optimisation --- It would be absolutely sound to return True always -isTrickyTvBinder tv = isPiTy (tyVarKind tv) - -{- Note [The Purely Kinded Type Invariant (PKTI)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type inference, we maintain this invariant - - (PKTI) It is legal to call 'tcTypeKind' on any Type ty, - on any sub-term of ty, /without/ zonking ty - - Moreover, any such returned kind - will itself satisfy (PKTI) - -By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". -The way in which tcTypeKind can crash is in applications - (a t1 t2 .. tn) -if 'a' is a type variable whose kind doesn't have enough arrows -or foralls. (The crash is in piResultTys.) - -The loop in tcInferApps has to be very careful to maintain the (PKTI). -For example, suppose - kappa is a unification variable - We have already unified kappa := Type - yielding co :: Refl (Type -> Type) - a :: kappa -then consider the type - (a Int) -If we call tcTypeKind on that, we'll crash, because the (un-zonked) -kind of 'a' is just kappa, not an arrow kind. So we must zonk first. - -So the type inference engine is very careful when building applications. -This happens in tcInferApps. Suppose we are kind-checking the type (a Int), -where (a :: kappa). Then in tcInferApps we'll run out of binders on -a's kind, so we'll call matchExpectedFunKind, and unify - kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) -At this point we must zonk the function type to expose the arrrow, so -that (a Int) will satisfy (PKTI). - -The absence of this caused #14174 and #14520. - -The calls to mkAppTyM is the other place we are very careful. - -Note [mkAppTyM] -~~~~~~~~~~~~~~~ -mkAppTyM is trying to guarantee the Purely Kinded Type Invariant -(PKTI) for its result type (fun arg). There are two ways it can go wrong: - -* Nasty case 1: forall types (polykinds/T14174a) - T :: forall (p :: *->*). p Int -> p Bool - Now kind-check (T x), where x::kappa. - Well, T and x both satisfy the PKTI, but - T x :: x Int -> x Bool - and (x Int) does /not/ satisfy the PKTI. - -* Nasty case 2: type synonyms - type S f a = f a - Even though (S ff aa) would satisfy the (PKTI) if S was a data type - (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) - if S is a type synonym, because the /expansion/ of (S ff aa) is - (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps - (ff :: kappa), where 'kappa' has already been unified with (*->*). - - We check for nasty case 2 on the final argument of a type synonym. - -Notice that in both cases the trickiness only happens if the -bound variable has a pi-type. Hence isTrickyTvBinder. --} - - -saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) --- Precondition for (saturateFamApp ty kind): --- tcTypeKind ty = kind --- --- If 'ty' is an unsaturated family application wtih trailing --- invisible arguments, instanttiate them. --- See Note [saturateFamApp] - -saturateFamApp ty kind - | Just (tc, args) <- tcSplitTyConApp_maybe ty - , mustBeSaturated tc - , let n_to_inst = tyConArity tc - length args - = do { (extra_args, ki') <- tcInstInvisibleTyBinders n_to_inst kind - ; return (ty `mkTcAppTys` extra_args, ki') } - | otherwise - = return (ty, kind) - -{- Note [saturateFamApp] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: Either j k - type instance F @Type = Right Maybe - type instance F @Type = Right Either``` - -Then F :: forall {j,k}. Either j k - -The two type instances do a visible kind application that instantiates -'j' but not 'k'. But we want to end up with instances that look like - type instance F @Type @(*->*) = Right @Type @(*->*) Maybe - -so that F has arity 2. We must instantiate that trailing invisible -binder. In general, Invisible binders precede Specified and Required, -so this is only going to bite for apparently-nullary families. - -Note that - type family F2 :: forall k. k -> * -is quite different and really does have arity 0. - -It's not just type instances where we need to saturate those -unsaturated arguments: see #11246. Hence doing this in tcInferApps. --} - -appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn -appTypeToArg f [] = f -appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args -appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args -appTypeToArg f (HsTypeArg l arg : args) - = appTypeToArg (mkHsAppKindTy l f arg) args - - -{- ********************************************************************* -* * - checkExpectedKind -* * -********************************************************************* -} - --- | This instantiates invisible arguments for the type being checked if it must --- be saturated and is not yet saturated. It then calls and uses the result --- from checkExpectedKindX to build the final type -checkExpectedKind :: HasDebugCallStack - => HsType GhcRn -- ^ type we're checking (for printing) - -> TcType -- ^ type we're checking - -> TcKind -- ^ the known kind of that type - -> TcKind -- ^ the expected kind - -> TcM TcType --- Just a convenience wrapper to save calls to 'ppr' -checkExpectedKind hs_ty ty act exp - = checkExpectedKind_pp (ppr hs_ty) ty act exp - -checkExpectedKind_pp :: HasDebugCallStack - => SDoc -- ^ The thing we are checking - -> TcType -- ^ type we're checking - -> TcKind -- ^ the known kind of that type - -> TcKind -- ^ the expected kind - -> TcM TcType -checkExpectedKind_pp pp_hs_ty ty act_kind exp_kind - = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) - - ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind - - ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind - , uo_thing = Just pp_hs_ty - , uo_visible = True } -- the hs_ty is visible - - ; traceTc "checkExpectedKindX" $ - vcat [ pp_hs_ty - , text "act_kind':" <+> ppr act_kind' - , text "exp_kind:" <+> ppr exp_kind ] - - ; let res_ty = ty `mkTcAppTys` new_args - - ; if act_kind' `tcEqType` exp_kind - then return res_ty -- This is very common - else do { co_k <- uType KindLevel origin act_kind' exp_kind - ; traceTc "checkExpectedKind" (vcat [ ppr act_kind - , ppr exp_kind - , ppr co_k ]) - ; return (res_ty `mkTcCastTy` co_k) } } - where - -- We need to make sure that both kinds have the same number of implicit - -- foralls out front. If the actual kind has more, instantiate accordingly. - -- Otherwise, just pass the type & kind through: the errors are caught - -- in unifyType. - n_exp_invis_bndrs = invisibleTyBndrCount exp_kind - n_act_invis_bndrs = invisibleTyBndrCount act_kind - n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs - - ---------------------------- -tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] -tcHsMbContext Nothing = return [] -tcHsMbContext (Just cxt) = tcHsContext cxt - -tcHsContext :: LHsContext GhcRn -> TcM [PredType] -tcHsContext = tc_hs_context typeLevelMode - -tcLHsPredType :: LHsType GhcRn -> TcM PredType -tcLHsPredType = tc_lhs_pred typeLevelMode - -tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] -tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) - -tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType -tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind - ---------------------------- -tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) --- See Note [Type checking recursive type and class declarations] --- in TcTyClsDecls -tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon - = do { traceTc "lk1" (ppr name) - ; thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) - - ATcTyCon tc_tc - -> do { -- See Note [GADT kind self-reference] - unless (isTypeLevel (mode_level mode)) - (promotionErr name TyConPE) - ; check_tc tc_tc - ; return (mkTyConTy tc_tc, tyConKind tc_tc) } - - AGlobal (ATyCon tc) - -> do { check_tc tc - ; return (mkTyConTy tc, tyConKind tc) } - - AGlobal (AConLike (RealDataCon dc)) - -> do { data_kinds <- xoptM LangExt.DataKinds - ; unless (data_kinds || specialPromotedDc dc) $ - promotionErr name NoDataKindsDC - ; when (isFamInstTyCon (dataConTyCon dc)) $ - -- see #15245 - promotionErr name FamDataConPE - ; let (_, _, _, theta, _, _) = dataConFullSig dc - ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta)) - ; case dc_theta_illegal_constraint theta of - Just pred -> promotionErr name $ - ConstrainedDataConPE pred - Nothing -> pure () - ; let tc = promoteDataCon dc - ; return (mkTyConApp tc [], tyConKind tc) } - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr "type" thing name } - where - check_tc :: TyCon -> TcM () - check_tc tc = do { data_kinds <- xoptM LangExt.DataKinds - ; unless (isTypeLevel (mode_level mode) || - data_kinds || - isKindTyCon tc) $ - promotionErr name NoDataKindsTC } - - -- We cannot promote a data constructor with a context that contains - -- constraints other than equalities, so error if we find one. - -- See Note [Constraints in kinds] in TyCoRep - dc_theta_illegal_constraint :: ThetaType -> Maybe PredType - dc_theta_illegal_constraint = find (not . isEqPred) - -{- -Note [GADT kind self-reference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A promoted type cannot be used in the body of that type's declaration. -#11554 shows this example, which made GHC loop: - - import Data.Kind - data P (x :: k) = Q - data A :: Type where - B :: forall (a :: A). P a -> A - -In order to check the constructor B, we need to have the promoted type A, but in -order to get that promoted type, B must first be checked. To prevent looping, a -TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode. -Any ATcTyCon is a TyCon being defined in the current recursive group (see data -type decl for TcTyThing), and all such TyCons are illegal in kinds. - -#11962 proposes checking the head of a data declaration separately from -its constructors. This would allow the example above to pass. - -Note [Body kind of a HsForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see -typecheck/should_compile/tc170). - -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is either * or #. But this is -wrong. For example: - - class C a b - newtype N = Mk Foo deriving (C a) - -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for * or # here. - -Note [Body kind of a HsQualTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ctxt is non-empty, the HsQualTy really is a /function/, so the -kind of the result really is '*', and in that case the kind of the -body-type can be lifted or unlifted. - -However, consider - instance Eq a => Eq [a] where ... -or - f :: (Eq a => Eq [a]) => blah -Here both body-kind of the HsQualTy is Constraint rather than *. -Rather crudely we tell the difference by looking at exp_kind. It's -very convenient to typecheck instance types like any other HsSigType. - -Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's -better to reject in checkValidType. If we say that the body kind -should be '*' we risk getting TWO error messages, one saying that Eq -[a] doens't have kind '*', and one saying that we need a Constraint to -the left of the outer (=>). - -How do we figure out the right body kind? Well, it's a bit of a -kludge: I just look at the expected kind. If it's Constraint, we -must be in this instance situation context. It's a kludge because it -wouldn't work if any unification was involved to compute that result -kind -- but it isn't. (The true way might be to use the 'mode' -parameter, but that seemed like a sledgehammer to crack a nut.) - -Note [Inferring tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, -we try to figure out whether it's a tuple of kind * or Constraint. - Step 1: look at the expected kind - Step 2: infer argument kinds - -If after Step 2 it's not clear from the arguments that it's -Constraint, then it must be *. Once having decided that we re-check -the arguments to give good error messages in - e.g. (Maybe, Maybe) - -Note that we will still fail to infer the correct kind in this case: - - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint - -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. - -Note [Desugaring types] -~~~~~~~~~~~~~~~~~~~~~~~ -The type desugarer is phase 2 of dealing with HsTypes. Specifically: - - * It transforms from HsType to Type - - * It zonks any kinds. The returned type should have no mutable kind - or type variables (hence returning Type not TcType): - - any unconstrained kind variables are defaulted to (Any *) just - as in TcHsSyn. - - there are no mutable type variables because we are - kind-checking a type - Reason: the returned type may be put in a TyCon or DataCon where - it will never subsequently be zonked. - -You might worry about nested scopes: - ..a:kappa in scope.. - let f :: forall b. T '[a,b] -> Int -In this case, f's type could have a mutable kind variable kappa in it; -and we might then default it to (Any *) when dealing with f's type -signature. But we don't expect this to happen because we can't get a -lexically scoped type variable with a mutable kind variable in it. A -delicate point, this. If it becomes an issue we might need to -distinguish top-level from nested uses. - -Moreover - * it cannot fail, - * it does no unifications - * it does no validity checking, except for structural matters, such as - (a) spurious ! annotations. - (b) a class used as a type - -Note [Kind of a type splice] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these terms, each with TH type splice inside: - [| e1 :: Maybe $(..blah..) |] - [| e2 :: $(..blah..) |] -When kind-checking the type signature, we'll kind-check the splice -$(..blah..); we want to give it a kind that can fit in any context, -as if $(..blah..) :: forall k. k. - -In the e1 example, the context of the splice fixes kappa to *. But -in the e2 example, we'll desugar the type, zonking the kind unification -variables as we go. When we encounter the unconstrained kappa, we -want to default it to '*', not to (Any *). - -Help functions for type applications -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a - -- Wrap a context around only if we want to show that contexts. - -- Omit invisible ones and ones user's won't grok -addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. -addTypeCtxt (L _ ty) thing - = addErrCtxt doc thing - where - doc = text "In the type" <+> quotes (ppr ty) - -{- -************************************************************************ -* * - Type-variable binders -%* * -%************************************************************************ - -Note [Keeping scoped variables in order: Explicit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user writes `forall a b c. blah`, we bring a, b, and c into -scope and then check blah. In the process of checking blah, we might -learn the kinds of a, b, and c, and these kinds might indicate that -b depends on c, and thus that we should reject the user-written type. - -One approach to doing this would be to bring each of a, b, and c into -scope, one at a time, creating an implication constraint and -bumping the TcLevel for each one. This would work, because the kind -of, say, b would be untouchable when c is in scope (and the constraint -couldn't float out because c blocks it). However, it leads to terrible -error messages, complaining about skolem escape. While it is indeed -a problem of skolem escape, we can do better. - -Instead, our approach is to bring the block of variables into scope -all at once, creating one implication constraint for the lot. The -user-written variables are skolems in the implication constraint. In -TcSimplify.setImplicationStatus, we check to make sure that the ordering -is correct, choosing ImplicationStatus IC_BadTelescope if they aren't. -Then, in TcErrors, we report if there is a bad telescope. This way, -we can report a suggested ordering to the user if there is a problem. - -See also Note [Checking telescopes] in Constraint - -Note [Keeping scoped variables in order: Implicit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user implicitly quantifies over variables (say, in a type -signature), we need to come up with some ordering on these variables. -This is done by bumping the TcLevel, bringing the tyvars into scope, -and then type-checking the thing_inside. The constraints are all -wrapped in an implication, which is then solved. Finally, we can -zonk all the binders and then order them with scopedSort. - -It's critical to solve before zonking and ordering in order to uncover -any unifications. You might worry that this eager solving could cause -trouble elsewhere. I don't think it will. Because it will solve only -in an increased TcLevel, it can't unify anything that was mentioned -elsewhere. Additionally, we require that the order of implicitly -quantified variables is manifest by the scope of these variables, so -we're not going to learn more information later that will help order -these variables. - -Note [Recipe for checking a signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Checking a user-written signature requires several steps: - - 1. Generate constraints. - 2. Solve constraints. - 3. Promote tyvars and/or kind-generalize. - 4. Zonk. - 5. Check validity. - -There may be some surprises in here: - -Step 2 is necessary for two reasons: most signatures also bring -implicitly quantified variables into scope, and solving is necessary -to get these in the right order (see Note [Keeping scoped variables in -order: Implicit]). Additionally, solving is necessary in order to -kind-generalize correctly: otherwise, we do not know which metavariables -are left unsolved. - -Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to -kindGeneralize{All,Some,None}. Here, we have to deal with the fact that -metatyvars generated in the type may have a bumped TcLevel, because explicit -foralls raise the TcLevel. To avoid these variables from ever being visible in -the surrounding context, we must obey the following dictum: - - Every metavariable in a type must either be - (A) generalized, or - (B) promoted, or See Note [Promotion in signatures] - (C) zapped to Any See Note [Naughty quantification candidates] in TcMType - -The kindGeneralize functions do not require pre-zonking; they zonk as they -go. - -If you are actually doing kind-generalization, you need to bump the level -before generating constraints, as we will only generalize variables with -a TcLevel higher than the ambient one. - -After promoting/generalizing, we need to zonk again because both -promoting and generalizing fill in metavariables. - -Note [Promotion in signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If an unsolved metavariable in a signature is not generalized -(because we're not generalizing the construct -- e.g., pattern -sig -- or because the metavars are constrained -- see kindGeneralizeSome) -we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables] -in TcType. Note that promotion is identical in effect to generalizing -and the reinstantiating with a fresh metavariable at the current level. -So in some sense, we generalize *all* variables, but then re-instantiate -some of them. - -Here is an example of why we must promote: - foo (x :: forall a. a -> Proxy b) = ... - -In the pattern signature, `b` is unbound, and will thus be brought into -scope. We do not know its kind: it will be assigned kappa[2]. Note that -kappa is at TcLevel 2, because it is invented under a forall. (A priori, -the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel -than the surrounding context.) This kappa cannot be solved for while checking -the pattern signature (which is not kind-generalized). When we are checking -the *body* of foo, though, we need to unify the type of x with the argument -type of bar. At this point, the ambient TcLevel is 1, and spotting a -matavariable with level 2 would violate the (MetaTvInv) invariant of -Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing, -we promote the metavariable to level 1. This is all done in kindGeneralizeNone. - --} - -tcNamedWildCardBinders :: [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a --- Bring into scope the /named/ wildcard binders. Remember that --- plain wildcards _ are anonymous and dealt with by HsWildCardTy --- Soe Note [The wildcard story for types] in GHC.Hs.Types -tcNamedWildCardBinders wc_names thing_inside - = do { wcs <- mapM (const newWildTyVar) wc_names - ; let wc_prs = wc_names `zip` wcs - ; tcExtendNameTyVarEnv wc_prs $ - thing_inside wc_prs } - -newWildTyVar :: TcM TcTyVar --- ^ New unification variable '_' for a wildcard -newWildTyVar - = do { kind <- newMetaKindVar - ; uniq <- newUnique - ; details <- newMetaDetails TauTv - ; let name = mkSysTvName uniq (fsLit "_") - tyvar = mkTcTyVar name kind details - ; traceTc "newWildTyVar" (ppr tyvar) - ; return tyvar } - -{- ********************************************************************* -* * - Kind inference for type declarations -* * -********************************************************************* -} - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -data InitialKindStrategy - = InitialKindCheck SAKS_or_CUSK - | InitialKindInfer - --- Does the declaration have a standalone kind signature (SAKS) or a complete --- user-specified kind (CUSK)? -data SAKS_or_CUSK - = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) - | CUSK -- Complete user-specified kind (CUSK) - -instance Outputable SAKS_or_CUSK where - ppr (SAKS k) = text "SAKS" <+> ppr k - ppr CUSK = text "CUSK" - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -kcDeclHeader - :: InitialKindStrategy - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig -kcDeclHeader InitialKindInfer = kcInferDeclHeader - -{- Note [kcCheckDeclHeader vs kcInferDeclHeader] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind -of a type constructor. - -* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that - case, find the full, final, poly-kinded kind of the TyCon. It's very like a - term-level binding where we have a complete type signature for the function. - -* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a - CUSK. Find a monomorphic kind, with unification variables in it; they will be - generalised later. It's very like a term-level binding where we do not have a - type signature (or, more accurately, where we have a partial type signature), - so we infer the type and generalise. --} - ------------------------------- -kcCheckDeclHeader - :: SAKS_or_CUSK - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig -kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk - -kcCheckDeclHeader_cusk - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader_cusk name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- CUSK case - -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls - = addTyConFlavCtxt name flav $ - do { (scoped_kvs, (tc_tvs, res_kind)) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol kv_ns $ - bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - - -- Now, because we're in a CUSK, - -- we quantify over the mentioned kind vars - ; let spec_req_tkvs = scoped_kvs ++ tc_tvs - all_kinds = res_kind : map tyVarKind spec_req_tkvs - - ; candidates' <- candidateQTyVarsOfKinds all_kinds - -- 'candidates' are all the variables that we are going to - -- skolemise and then quantify over. We do not include spec_req_tvs - -- because they are /already/ skolems - - ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds)) - candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } - inf_candidates = candidates `delCandidates` spec_req_tkvs - - ; inferred <- quantifyTyVars inf_candidates - -- NB: 'inferred' comes back sorted in dependency order - - ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs - ; res_kind <- zonkTcType res_kind - - ; let mentioned_kv_set = candidateKindVars candidates - specified = scopedSort scoped_kvs - -- NB: maintain the L-R order of scoped_kvs - - final_tc_binders = mkNamedTyConBinders Inferred inferred - ++ mkNamedTyConBinders Specified specified - ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs - True -- it is generalised - flav - -- If the ordering from - -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls - -- doesn't work, we catch it here, before an error cascade - ; checkTyConTelescope tycon - - ; traceTc "kcCheckDeclHeader_cusk " $ - vcat [ text "name" <+> ppr name - , text "kv_ns" <+> ppr kv_ns - , text "hs_tvs" <+> ppr hs_tvs - , text "scoped_kvs" <+> ppr scoped_kvs - , text "tc_tvs" <+> ppr tc_tvs - , text "res_kind" <+> ppr res_kind - , text "candidates" <+> ppr candidates - , text "inferred" <+> ppr inferred - , text "specified" <+> ppr specified - , text "final_tc_binders" <+> ppr final_tc_binders - , text "mkTyConKind final_tc_bndrs res_kind" - <+> ppr (mkTyConKind final_tc_binders res_kind) - , text "all_tv_prs" <+> ppr all_tv_prs ] - - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind -kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and --- other kinds). --- --- This function does not do telescope checking. -kcInferDeclHeader - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon -kcInferDeclHeader name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- No standalane kind signature and no CUSK. - -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls - = do { (scoped_kvs, (tc_tvs, res_kind)) - -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - <- bindImplicitTKBndrs_Q_Tv kv_ns $ - bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - -- Why "_Tv" not "_Skol"? See third wrinkle in - -- Note [Inferring kinds for type declarations] in TcTyClsDecls, - - ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they - -- might unify with kind vars in other types in a mutually - -- recursive group. - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - - tc_binders = mkAnonTyConBinders VisArg tc_tvs - -- Also, note that tc_binders has the tyvars from only the - -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] - -- in TcTyClsDecls - -- - -- mkAnonTyConBinder: see Note [No polymorphic recursion] - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - -- NB: bindExplicitTKBndrs_Q_Tv does not clone; - -- ditto Implicit - -- See Note [Non-cloning for tyvar binders] - - tycon = mkTcTyCon name tc_binders res_kind all_tv_prs - False -- not yet generalised - flav - - ; traceTc "kcInferDeclHeader: not-cusk" $ - vcat [ ppr name, ppr kv_ns, ppr hs_tvs - , ppr scoped_kvs - , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - -kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- | Kind-check a declaration header against a standalone kind signature. --- See Note [Arity inference in kcCheckDeclHeader_sig] -kcCheckDeclHeader_sig - :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcCheckDeclHeader_sig kisig name flav - (HsQTvs { hsq_ext = implicit_nms - , hsq_explicit = explicit_nms }) kc_res_ki - = addTyConFlavCtxt name flav $ - do { -- Step 1: zip user-written binders with quantifiers from the kind signature. - -- For example: - -- - -- type F :: forall k -> k -> forall j. j -> Type - -- data F i a b = ... - -- - -- Results in the following 'zipped_binders': - -- - -- TyBinder LHsTyVarBndr - -- --------------------------------------- - -- ZippedBinder forall k -> i - -- ZippedBinder k -> a - -- ZippedBinder forall j. - -- ZippedBinder j -> b - -- - let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms - - -- Report binders that don't have a corresponding quantifier. - -- For example: - -- - -- type T :: Type -> Type - -- data T b1 b2 b3 = ... - -- - -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders. - -- - ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs) - - -- Convert each ZippedBinder to TyConBinder for tyConBinders - -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars - ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders - - ; (implicit_tvs, (invis_binders, r_ki)) - <- pushTcLevelM_ $ - solveEqualities $ -- #16687 - bindImplicitTKBndrs_Tv implicit_nms $ - tcExtendNameTyVarEnv explicit_tv_prs $ - do { -- Check that inline kind annotations on binders are valid. - -- For example: - -- - -- type T :: Maybe k -> Type - -- data T (a :: Maybe j) = ... - -- - -- Here we unify Maybe k ~ Maybe j - mapM_ check_zipped_binder zipped_binders - - -- Kind-check the result kind annotation, if present: - -- - -- data T a b :: res_ki where - -- ^^^^^^^^^ - -- We do it here because at this point the environment has been - -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - ; ctx_k <- kc_res_ki - ; m_res_ki <- case ctx_k of - AnyKind -> return Nothing - _ -> Just <$> newExpectedKind ctx_k - - -- Step 2: split off invisible binders. - -- For example: - -- - -- type F :: forall k1 k2. (k1, k2) -> Type - -- type family F - -- - -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? - -- See Note [Arity inference in kcCheckDeclHeader_sig] - ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki - - -- Check that the inline result kind annotation is valid. - -- For example: - -- - -- type T :: Type -> Maybe k - -- type family T a :: Maybe j where - -- - -- Here we unify Maybe k ~ Maybe j - ; whenIsJust m_res_ki $ \res_ki -> - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind Nothing r_ki res_ki - - ; return (invis_binders, r_ki) } - - -- Zonk the implicitly quantified variables. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - - -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. - ; invis_tcbs <- mapM invis_to_tcb invis_binders - - -- Build the final, generalized TcTyCon - ; let tcbs = vis_tcbs ++ invis_tcbs - implicit_tv_prs = implicit_nms `zip` implicit_tvs - all_tv_prs = implicit_tv_prs ++ explicit_tv_prs - tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav - - ; traceTc "kcCheckDeclHeader_sig done:" $ vcat - [ text "tyConName = " <+> ppr (tyConName tc) - , text "kisig =" <+> debugPprType kisig - , text "tyConKind =" <+> debugPprType (tyConKind tc) - , text "tyConBinders = " <+> ppr (tyConBinders tc) - , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) - , text "tyConResKind" <+> debugPprType (tyConResKind tc) - ] - ; return tc } - where - -- Consider this declaration: - -- - -- type T :: forall a. forall b -> (a~b) => Proxy a -> Type - -- data T x p = MkT - -- - -- Here, we have every possible variant of ZippedBinder: - -- - -- TyBinder LHsTyVarBndr - -- ---------------------------------------------- - -- ZippedBinder forall {k}. - -- ZippedBinder forall (a::k). - -- ZippedBinder forall (b::k) -> x - -- ZippedBinder (a~b) => - -- ZippedBinder Proxy a -> p - -- - -- Given a ZippedBinder zipped_to_tcb produces: - -- - -- * TyConBinder for tyConBinders - -- * (Name, TcTyVar) for tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr - -- - zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)]) - zipped_to_tcb zb = case zb of - - -- Inferred variable, no user-written binder. - -- Example: forall {k}. - ZippedBinder (Named (Bndr v Specified)) Nothing -> - return (mkNamedTyConBinder Specified v, []) - - -- Specified variable, no user-written binder. - -- Example: forall (a::k). - ZippedBinder (Named (Bndr v Inferred)) Nothing -> - return (mkNamedTyConBinder Inferred v, []) - - -- Constraint, no user-written binder. - -- Example: (a~b) => - ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do - name <- newSysName (mkTyVarOccFS (fsLit "ev")) - let tv = mkTyVar name bndr_ki - return (mkAnonTyConBinder InvisArg tv, []) - - -- Non-dependent visible argument with a user-written binder. - -- Example: Proxy a -> - ZippedBinder (Anon VisArg bndr_ki) (Just b) -> - return $ - let v_name = getName b - tv = mkTyVar v_name bndr_ki - tcb = mkAnonTyConBinder VisArg tv - in (tcb, [(v_name, tv)]) - - -- Dependent visible argument with a user-written binder. - -- Example: forall (b::k) -> - ZippedBinder (Named (Bndr v Required)) (Just b) -> - return $ - let v_name = getName b - tcb = mkNamedTyConBinder Required v - in (tcb, [(v_name, v)]) - - -- 'zipBinders' does not produce any other variants of ZippedBinder. - _ -> panic "goVis: invalid ZippedBinder" - - -- Given an invisible binder that comes from 'split_invis', - -- convert it to TyConBinder. - invis_to_tcb :: TyCoBinder -> TcM TyConBinder - invis_to_tcb tb = do - (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing) - MASSERT(null stv) - return tcb - - -- Check that the inline kind annotation on a binder is valid - -- by unifying it with the kind of the quantifier. - check_zipped_binder :: ZippedBinder -> TcM () - check_zipped_binder (ZippedBinder _ Nothing) = return () - check_zipped_binder (ZippedBinder tb (Just b)) = - case unLoc b of - UserTyVar _ _ -> return () - KindedTyVar _ v v_hs_ki -> do - v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just (HsTyVar noExtField NotPromoted v)) - (tyBinderType tb) - v_ki - XTyVarBndr nec -> noExtCon nec - - -- Split the invisible binders that should become a part of 'tyConBinders' - -- rather than 'tyConResKind'. - -- See Note [Arity inference in kcCheckDeclHeader_sig] - split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) - split_invis sig_ki Nothing = - -- instantiate all invisible binders - splitPiTysInvisible sig_ki - split_invis sig_ki (Just res_ki) = - -- subtraction a la checkExpectedKind - let n_res_invis_bndrs = invisibleTyBndrCount res_ki - n_sig_invis_bndrs = invisibleTyBndrCount sig_ki - n_inst = n_sig_invis_bndrs - n_res_invis_bndrs - in splitPiTysInvisibleN n_inst sig_ki - -kcCheckDeclHeader_sig _ _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- A quantifier from a kind signature zipped with a user-written binder for it. -data ZippedBinder = - ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn)) - --- See Note [Arity inference in kcCheckDeclHeader_sig] -zipBinders - :: Kind -- kind signature - -> [LHsTyVarBndr GhcRn] -- user-written binders - -> ([ZippedBinder], -- zipped binders - [LHsTyVarBndr GhcRn], -- remaining user-written binders - Kind) -- remainder of the kind signature -zipBinders = zip_binders [] - where - zip_binders acc ki [] = (reverse acc, [], ki) - zip_binders acc ki (b:bs) = - case tcSplitPiTy_maybe ki of - Nothing -> (reverse acc, b:bs, ki) - Just (tb, ki') -> - let - (zb, bs') | zippable = (ZippedBinder tb (Just b), bs) - | otherwise = (ZippedBinder tb Nothing, b:bs) - zippable = - case tb of - Named (Bndr _ Specified) -> False - Named (Bndr _ Inferred) -> False - Named (Bndr _ Required) -> True - Anon InvisArg _ -> False - Anon VisArg _ -> True - in - zip_binders (zb:acc) ki' bs' - -tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc -tooManyBindersErr ki bndrs = - hang (text "Not a function kind:") - 4 (ppr ki) $$ - hang (text "but extra binders found:") - 4 (fsep (map ppr bndrs)) - -{- Note [Arity inference in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig -verifies that the declaration conforms to the signature. The end result is a -TcTyCon 'tc' such that: - - tyConKind tc == kisig - -This TcTyCon would be rather easy to produce if we didn't have to worry about -arity. Consider these declarations: - - type family S1 :: forall k. k -> Type - type family S2 (a :: k) :: Type - -Both S1 and S2 can be given the same standalone kind signature: - - type S2 :: forall k. k -> Type - -And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from -tyConBinders and tyConResKind, such that - - tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc) - -For S1 and S2, tyConBinders and tyConResKind are different: - - tyConBinders S1 == [] - tyConResKind S1 == forall k. k -> Type - tyConKind S1 == forall k. k -> Type - - tyConBinders S2 == [spec k, anon-vis (a :: k)] - tyConResKind S2 == Type - tyConKind S1 == forall k. k -> Type - -This difference determines the arity: - - tyConArity tc == length (tyConBinders tc) - -That is, the arity of S1 is 0, while the arity of S2 is 2. - -'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone -kind signature into binders and the result kind. It does so in two rounds: - -1. zip user-written binders (vis_tcbs) -2. split off invisible binders (invis_tcbs) - -Consider the following declarations: - - type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family F a b - - type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family G a b :: forall r2. (r1, r2) -> Type - -In step 1 (zip user-written binders), we zip the quantifiers in the signature -with the binders in the header using 'zipBinders'. In both F and G, this results in -the following zipped binders: - - TyBinder LHsTyVarBndr - --------------------------------------- - ZippedBinder Type -> a - ZippedBinder forall j. - ZippedBinder j -> b - - -At this point, we have accumulated three zipped binders which correspond to a -prefix of the standalone kind signature: - - Type -> forall j. j -> ... - -In step 2 (split off invisible binders), we have to decide how much remaining -invisible binders of the standalone kind signature to split off: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split off or not? - -This decision is made in 'split_invis': - -* If a user-written result kind signature is not provided, as in F, - then split off all invisible binders. This is why we need special treatment - for AnyKind. -* If a user-written result kind signature is provided, as in G, - then do as checkExpectedKind does and split off (n_sig - n_res) binders. - That is, split off such an amount of binders that the remainder of the - standalone kind signature and the user-written result kind signature have the - same amount of invisible quantifiers. - -For F, split_invis splits away all invisible binders, and we have 2: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split away both binders - -The resulting arity of F is 3+2=5. (length vis_tcbs = 3, - length invis_tcbs = 2, - length tcbs = 5) - -For G, split_invis decides to split off 1 invisible binder, so that we have the -same amount of invisible quantifiers left: - - res_ki = forall r2. (r1, r2) -> Type - kisig = forall k1 k2. (k1, k2) -> Type - ^^^ - split off this one. - -The resulting arity of G is 3+1=4. (length vis_tcbs = 3, - length invis_tcbs = 1, - length tcbs = 4) - --} - -{- Note [discardResult in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use 'unifyKind' to check inline kind annotations in declaration headers -against the signature. - - type T :: [i] -> Maybe j -> Type - data T (a :: [k1]) (b :: Maybe k2) :: Type where ... - -Here, we will unify: - - [k1] ~ [i] - Maybe k2 ~ Maybe j - Type ~ Type - -The end result is that we fill in unification variables k1, k2: - - k1 := i - k2 := j - -We also validate that the user isn't confused: - - type T :: Type -> Type - data T (a :: Bool) = ... - -This will report that (Type ~ Bool) failed to unify. - -Now, consider the following example: - - type family Id a where Id x = x - type T :: Bool -> Type - type T (a :: Id Bool) = ... - -We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. -However, we are free to discard it, as the kind of 'T' is determined by the -signature, not by the inline kind annotation: - - we have T :: Bool -> Type - rather than T :: Id Bool -> Type - -This (Id Bool) will not show up anywhere after we're done validating it, so we -have no use for the produced coercion. --} - -{- Note [No polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should this kind-check? - data T ka (a::ka) b = MkT (T Type Int Bool) - (T (Type -> Type) Maybe Bool) - -Notice that T is used at two different kinds in its RHS. No! -This should not kind-check. Polymorphic recursion is known to -be a tough nut. - -Previously, we laboriously (with help from the renamer) -tried to give T the polymoprhic kind - T :: forall ka -> ka -> kappa -> Type -where kappa is a unification variable, even in the inferInitialKinds -phase (which is what kcInferDeclHeader is all about). But -that is dangerously fragile (see the ticket). - -Solution: make kcInferDeclHeader give T a straightforward -monomorphic kind, with no quantification whatsoever. That's why -we use mkAnonTyConBinder for all arguments when figuring out -tc_binders. - -But notice that (#16322 comment:3) - -* The algorithm successfully kind-checks this declaration: - data T2 ka (a::ka) = MkT2 (T2 Type a) - - Starting with (inferInitialKinds) - T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> * - we get - kappa4 := kappa1 -- from the (a:ka) kind signature - kappa1 := Type -- From application T2 Type - - These constraints are soluble so generaliseTcTyCon gives - T2 :: forall (k::Type) -> k -> * - - But now the /typechecking/ (aka desugaring, tcTyClDecl) phase - fails, because the call (T2 Type a) in the RHS is ill-kinded. - - We'd really prefer all errors to show up in the kind checking - phase. - -* This algorithm still accepts (in all phases) - data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) - although T3 is really polymorphic-recursive too. - Perhaps we should somehow reject that. - -Note [Kind-checking tyvar binders for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind-checking the type-variable binders for associated - data/newtype decls - family decls -we behave specially for type variables that are already in scope; -that is, bound by the enclosing class decl. This is done in -kcLHsQTyVarBndrs: - * The use of tcImplicitQTKBndrs - * The tcLookupLocal_maybe code in kc_hs_tv - -See Note [Associated type tyvar names] in Class and - Note [TyVar binders for associated decls] in GHC.Hs.Decls - -We must do the same for family instance decls, where the in-scope -variables may be bound by the enclosing class instance decl. -Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen. - -Note [Kind variable ordering for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should be the kind of `T` in the following example? (#15591) - - class C (a :: Type) where - type T (x :: f a) - -As per Note [Ordering of implicit variables] in RnTypes, we want to quantify -the kind variables in left-to-right order of first occurrence in order to -support visible kind application. But we cannot perform this analysis on just -T alone, since its variable `a` actually occurs /before/ `f` if you consider -the fact that `a` was previously bound by the parent class `C`. That is to say, -the kind of `T` should end up being: - - T :: forall a f. f a -> Type - -(It wouldn't necessarily be /wrong/ if the kind ended up being, say, -forall f a. f a -> Type, but that would not be as predictable for users of -visible kind application.) - -In contrast, if `T` were redefined to be a top-level type family, like `T2` -below: - - type family T2 (x :: f (a :: Type)) - -Then `a` first appears /after/ `f`, so the kind of `T2` should be: - - T2 :: forall f a. f a -> Type - -In order to make this distinction, we need to know (in kcCheckDeclHeader) which -type variables have been bound by the parent class (if there is one). With -the class-bound variables in hand, we can ensure that we always quantify -these first. --} - - -{- ********************************************************************* -* * - Expected kinds -* * -********************************************************************* -} - --- | Describes the kind expected in a certain context. -data ContextKind = TheKind Kind -- ^ a specific kind - | AnyKind -- ^ any kind will do - | OpenKind -- ^ something of the form @TYPE _@ - ------------------------ -newExpectedKind :: ContextKind -> TcM Kind -newExpectedKind (TheKind k) = return k -newExpectedKind AnyKind = newMetaKindVar -newExpectedKind OpenKind = newOpenTypeKind - ------------------------ -expectedKindInCtxt :: UserTypeCtxt -> ContextKind --- Depending on the context, we might accept any kind (for instance, in a TH --- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt (TySynCtxt _) = AnyKind -expectedKindInCtxt ThBrackCtxt = AnyKind -expectedKindInCtxt (GhciCtxt {}) = AnyKind --- The types in a 'default' decl can have varying kinds --- See Note [Extended defaults]" in TcEnv -expectedKindInCtxt DefaultDeclCtxt = AnyKind -expectedKindInCtxt TypeAppCtxt = AnyKind -expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind -expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind -expectedKindInCtxt SpecInstCtxt = TheKind constraintKind -expectedKindInCtxt _ = OpenKind - - -{- ********************************************************************* -* * - Bringing type variables into scope -* * -********************************************************************* -} - -{- Note [Non-cloning for tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -bindExplictTKBndrs_Q_Skol, bindExplictTKBndrs_Skol, do not clone; -and nor do the Implicit versions. There is no need. - -bindExplictTKBndrs_Q_Tv does not clone; and similarly Implicit. -We take advantage of this in kcInferDeclHeader: - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) -If we cloned, we'd need to take a bit more care here; not hard. - -The main payoff is that avoidng gratuitious cloning means that we can -almost always take the fast path in swizzleTcTyConBndrs. "Almost -always" means not the case of mutual recursion with polymorphic kinds. - - -Note [Cloning for tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -bindExplicitTKBndrs_Tv does cloning, making up a Name with a fresh Unique, -unlike bindExplicitTKBndrs_Q_Tv. (Nor do the Skol variants clone.) -And similarly for bindImplicit... - -This for a narrow and tricky reason which, alas, I couldn't find a -simpler way round. #16221 is the poster child: - - data SameKind :: k -> k -> * - data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int - -When kind-checking T, we give (a :: kappa1). Then: - -- In kcConDecl we make a TyVarTv unification variable kappa2 for k2 - (as described in Note [Kind-checking for GADTs], even though this - example is an existential) -- So we get (b :: kappa2) via bindExplicitTKBndrs_Tv -- We end up unifying kappa1 := kappa2, because of the (SameKind a b) - -Now we generalise over kappa2. But if kappa2's Name is precisely k2 -(i.e. we did not clone) we'll end up giving T the utterlly final kind - T :: forall k2. k2 -> * -Nothing directly wrong with that but when we typecheck the data constructor -we have k2 in scope; but then it's brought into scope /again/ when we find -the forall k2. This is chaotic, and we end up giving it the type - MkT :: forall k2 (a :: k2) k2 (b :: k2). - SameKind @k2 a b -> Int -> T @{k2} a -which is bogus -- because of the shadowing of k2, we can't -apply T to the kind or a! - -And there no reason /not/ to clone the Name when making a unification -variable. So that's what we do. --} - --------------------------------------- --- Implicit binders --------------------------------------- - -bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, - bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv - :: [Name] -> TcM a -> TcM ([TcTyVar], a) -bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar) -bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar) -bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar -bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX cloneFlexiKindedTyVarTyVar - -- newFlexiKinded... see Note [Non-cloning for tyvar binders] - -- cloneFlexiKindedTyVarTyVar: see Note [Cloning for tyvar binders] - -bindImplicitTKBndrsX - :: (Name -> TcM TcTyVar) -- new_tv function - -> [Name] - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed in [Name] -bindImplicitTKBndrsX new_tv tv_names thing_inside - = do { tkvs <- mapM new_tv tv_names - ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs) - ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) - thing_inside - ; return (tkvs, res) } - -newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar --- Behave like new_tv, except that if the tyvar is in scope, use it -newImplicitTyVarQ new_tv name - = do { mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of - Just (ATyVar _ tv) -> return tv - _ -> new_tv name } - -newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar -newFlexiKindedTyVar new_tv name - = do { kind <- newMetaKindVar - ; new_tv name kind } - -newFlexiKindedSkolemTyVar :: Name -> TcM TyVar -newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar - -newFlexiKindedTyVarTyVar :: Name -> TcM TyVar -newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar - -cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar -cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar - -- See Note [Cloning for tyvar binders] - --------------------------------------- --- Explicit binders --------------------------------------- - -bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) - -bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar) -bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar) - -- newSkolemTyVar: see Note [Non-cloning for tyvar binders] - -- cloneTyVarTyVar: see Note [Cloning for tyvar binders] - -bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv - :: ContextKind - -> [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) - -bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) -bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) - -- See Note [Non-cloning for tyvar binders] - - -bindExplicitTKBndrsX - :: (HsTyVarBndr GhcRn -> TcM TcTyVar) - -> [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed-in [LHsTyVarBndr] -bindExplicitTKBndrsX tc_tv hs_tvs thing_inside - = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) - ; go hs_tvs } - where - go [] = do { res <- thing_inside - ; return ([], res) } - go (L _ hs_tv : hs_tvs) - = do { tv <- tc_tv hs_tv - -- Extend the environment as we go, in case a binder - -- is mentioned in the kind of a later binder - -- e.g. forall k (a::k). blah - -- NB: tv's Name may differ from hs_tv's - -- See TcMType Note [Cloning for tyvar binders] - ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ - go hs_tvs - ; return (tv:tvs, res) } - ------------------ -tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar -tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) - = do { kind <- newMetaKindVar - ; new_tv tv_nm kind } -tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) - = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind - ; new_tv tv_nm kind } -tcHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec - ------------------ -tcHsQTyVarBndr :: ContextKind - -> (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar --- Just like tcHsTyVarBndr, but also --- - uses the in-scope TyVar from class, if it exists --- - takes a ContextKind to use for the no-sig case -tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm)) - = do { mb_tv <- tcLookupLcl_maybe tv_nm - ; case mb_tv of - Just (ATyVar _ tv) -> return tv - _ -> do { kind <- newExpectedKind ctxt_kind - ; new_tv tv_nm kind } } - -tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) - = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind - ; mb_tv <- tcLookupLcl_maybe tv_nm - ; case mb_tv of - Just (ATyVar _ tv) - -> do { discardResult $ unifyKind (Just hs_tv) - kind (tyVarKind tv) - -- This unify rejects: - -- class C (m :: * -> *) where - -- type F (m :: *) = ... - ; return tv } - - _ -> new_tv tv_nm kind } - where - hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm) - -- Used for error messages only - -tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec - --------------------------------------- --- Binding type/class variables in the --- kind-checking and typechecking phases --------------------------------------- - -bindTyClTyVars :: Name - -> ([TyConBinder] -> Kind -> TcM a) -> TcM a --- ^ Used for the type variables of a type or class decl --- in the "kind checking" and "type checking" pass, --- but not in the initial-kind run. -bindTyClTyVars tycon_name thing_inside - = do { tycon <- kcLookupTcTyCon tycon_name - ; let scoped_prs = tcTyConScopedTyVars tycon - res_kind = tyConResKind tycon - binders = tyConBinders tycon - ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs) - ; tcExtendNameTyVarEnv scoped_prs $ - thing_inside binders res_kind } - --- inferInitialKind has made a suitably-shaped kind for the type or class --- Look it up in the local environment. This is used only for tycons --- that we're currently type-checking, so we're sure to find a TcTyCon. -kcLookupTcTyCon :: Name -> TcM TcTyCon -kcLookupTcTyCon nm - = do { tc_ty_thing <- tcLookup nm - ; return $ case tc_ty_thing of - ATcTyCon tc -> tc - _ -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) } - - -{- ********************************************************************* -* * - Kind generalisation -* * -********************************************************************* -} - -zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] -zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs - -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv - - -- Do a stable topological sort, following - -- Note [Ordering of implicit variables] in RnTypes - ; return (scopedSort spec_tkvs) } - --- | Generalize some of the free variables in the given type. --- All such variables should be *kind* variables; any type variables --- should be explicitly quantified (with a `forall`) before now. --- The supplied predicate says which free variables to quantify. --- But in all cases, --- generalize only those variables whose TcLevel is strictly greater --- than the ambient level. This "strictly greater than" means that --- you likely need to push the level before creating whatever type --- gets passed here. Any variable whose level is greater than the --- ambient level but is not selected to be generalized will be --- promoted. (See [Promoting unification variables] in TcSimplify --- and Note [Recipe for checking a signature].) --- The resulting KindVar are the variables to --- quantify over, in the correct, well-scoped order. They should --- generally be Inferred, not Specified, but that's really up to --- the caller of this function. -kindGeneralizeSome :: (TcTyVar -> Bool) - -> TcType -- ^ needn't be zonked - -> TcM [KindVar] -kindGeneralizeSome should_gen kind_or_type - = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type) - - -- use the "Kind" variant here, as any types we see - -- here will already have all type variables quantified; - -- thus, every free variable is really a kv, never a tv. - ; dvs <- candidateQTyVarsOfKind kind_or_type - - -- So 'dvs' are the variables free in kind_or_type, with a level greater - -- than the ambient level, hence candidates for quantification - -- Next: filter out the ones we don't want to generalize (specified by should_gen) - -- and promote them instead - - ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen) - - ; (_, promoted) <- promoteTyVarSet (dVarSetToVarSet to_promote) - ; qkvs <- quantifyTyVars dvs' - - ; traceTc "kindGeneralizeSome }" $ - vcat [ text "Kind or type:" <+> ppr kind_or_type - , text "dvs:" <+> ppr dvs - , text "dvs':" <+> ppr dvs' - , text "to_promote:" <+> pprTyVars (dVarSetElems to_promote) - , text "promoted:" <+> pprTyVars (nonDetEltsUniqSet promoted) - , text "qkvs:" <+> pprTyVars qkvs ] - - ; return qkvs } - --- | Specialized version of 'kindGeneralizeSome', but where all variables --- can be generalized. Use this variant when you can be sure that no more --- constraints on the type's metavariables will arise or be solved. -kindGeneralizeAll :: TcType -- needn't be zonked - -> TcM [KindVar] -kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty - ; kindGeneralizeSome (const True) ty } - --- | Specialized version of 'kindGeneralizeSome', but where no variables --- can be generalized, but perhaps some may neeed to be promoted. --- Use this variant when it is unknowable whether metavariables might --- later be constrained. --- --- To see why this promotion is needed, see --- Note [Recipe for checking a signature], and especially --- Note [Promotion in signatures]. -kindGeneralizeNone :: TcType -- needn't be zonked - -> TcM () -kindGeneralizeNone ty - = do { traceTc "kindGeneralizeNone" empty - ; kvs <- kindGeneralizeSome (const False) ty - ; MASSERT( null kvs ) - } - -{- Note [Levels and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = e -with no type signature. We are currently at level i. -We must - * Push the level to level (i+1) - * Allocate a fresh alpha[i+1] for the result type - * Check that e :: alpha[i+1], gathering constraint WC - * Solve WC as far as possible - * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] - * Find the free variables with level > i, in this case gamma[i] - * Skolemise those free variables and quantify over them, giving - f :: forall g. beta[i-1] -> g - * Emit the residiual constraint wrapped in an implication for g, - thus forall g. WC - -All of this happens for types too. Consider - f :: Int -> (forall a. Proxy a -> Int) - -Note [Kind generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do kind generalisation only at the outer level of a type signature. -For example, consider - T :: forall k. k -> * - f :: (forall a. T a -> Int) -> Int -When kind-checking f's type signature we generalise the kind at -the outermost level, thus: - f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! -and *not* at the inner forall: - f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! -Reason: same as for HM inference on value level declarations, -we want to infer the most general type. The f2 type signature -would be *less applicable* than f1, because it requires a more -polymorphic argument. - -NB: There are no explicit kind variables written in f's signature. -When there are, the renamer adds these kind variables to the list of -variables bound by the forall, so you can indeed have a type that's -higher-rank in its kind. But only by explicit request. - -Note [Kinds of quantified type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsGen quantifies over a specified list of type variables, -*and* over the kind variables mentioned in the kinds of those tyvars. - -Note that we must zonk those kinds (obviously) but less obviously, we -must return type variables whose kinds are zonked too. Example - (a :: k7) where k7 := k9 -> k9 -We must return - [k9, a:k9->k9] -and NOT - [k9, a:k7] -Reason: we're going to turn this into a for-all type, - forall k9. forall (a:k7). blah -which the type checker will then instantiate, and instantiate does not -look through unification variables! - -Hence using zonked_kinds when forming tvs'. - --} - ------------------------------------ -etaExpandAlgTyCon :: [TyConBinder] - -> Kind - -> TcM ([TyConBinder], Kind) --- GADT decls can have a (perhaps partial) kind signature --- e.g. data T a :: * -> * -> * where ... --- This function makes up suitable (kinded) TyConBinders for the --- argument kinds. E.g. in this case it might return --- ([b::*, c::*], *) --- Never emits constraints. --- It's a little trickier than you might think: see --- Note [TyConBinders for the result kind signature of a data type] -etaExpandAlgTyCon tc_bndrs kind - = do { loc <- getSrcSpanM - ; uniqs <- newUniqueSupply - ; rdr_env <- getLocalRdrEnv - ; let new_occs = [ occ - | str <- allNameStrings - , let occ = mkOccName tvName str - , isNothing (lookupLocalRdrOcc rdr_env occ) - -- Note [Avoid name clashes for associated data types] - , not (occ `elem` lhs_occs) ] - new_uniqs = uniqsFromSupply uniqs - subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs)) - ; return (go loc new_occs new_uniqs subst [] kind) } - where - lhs_tvs = map binderVar tc_bndrs - lhs_occs = map getOccName lhs_tvs - - go loc occs uniqs subst acc kind - = case splitPiTy_maybe kind of - Nothing -> (reverse acc, substTy subst kind) - - Just (Anon af arg, kind') - -> go loc occs' uniqs' subst' (tcb : acc) kind' - where - arg' = substTy subst arg - tv = mkTyVar (mkInternalName uniq occ loc) arg' - subst' = extendTCvInScope subst tv - tcb = Bndr tv (AnonTCB af) - (uniq:uniqs') = uniqs - (occ:occs') = occs - - Just (Named (Bndr tv vis), kind') - -> go loc occs uniqs subst' (tcb : acc) kind' - where - (subst', tv') = substTyVarBndr subst tv - tcb = Bndr tv' (NamedTCB vis) - --- | A description of whether something is a --- --- * @data@ or @newtype@ ('DataDeclSort') --- --- * @data instance@ or @newtype instance@ ('DataInstanceSort') --- --- * @data family@ ('DataFamilySort') --- --- At present, this data type is only consumed by 'checkDataKindSig'. -data DataSort - = DataDeclSort NewOrData - | DataInstanceSort NewOrData - | DataFamilySort - --- | Checks that the return kind in a data declaration's kind signature is --- permissible. There are three cases: --- --- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ --- declaration, check that the return kind is @Type@. --- --- If the declaration is a @newtype@ or @newtype instance@ and the --- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so --- that a return kind of the form @TYPE r@ (for some @r@) is permitted. --- See @Note [Implementation of UnliftedNewtypes]@ in "TcTyClsDecls". --- --- If dealing with a @data family@ declaration, check that the return kind is --- either of the form: --- --- 1. @TYPE r@ (for some @r@), or --- --- 2. @k@ (where @k@ is a bare kind variable; see #12369) -checkDataKindSig :: DataSort -> Kind -> TcM () -checkDataKindSig data_sort kind = do - dflags <- getDynFlags - checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags) - where - pp_dec :: SDoc - pp_dec = text $ - case data_sort of - DataDeclSort DataType -> "data type" - DataDeclSort NewType -> "newtype" - DataInstanceSort DataType -> "data instance" - DataInstanceSort NewType -> "newtype instance" - DataFamilySort -> "data family" - - is_newtype :: Bool - is_newtype = - case data_sort of - DataDeclSort new_or_data -> new_or_data == NewType - DataInstanceSort new_or_data -> new_or_data == NewType - DataFamilySort -> False - - is_data_family :: Bool - is_data_family = - case data_sort of - DataDeclSort{} -> False - DataInstanceSort{} -> False - DataFamilySort -> True - - tYPE_ok :: DynFlags -> Bool - tYPE_ok dflags = - (is_newtype && xopt LangExt.UnliftedNewtypes dflags) - -- With UnliftedNewtypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE r` since we don't want to accept - -- Constraint or Nat. - -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls. - || is_data_family - -- If this is a `data family` declaration, we don't need to check if - -- UnliftedNewtypes is enabled, since data family declarations can - -- have return kind `TYPE r` unconditionally (#16827). - - is_TYPE :: Bool - is_TYPE = tcIsRuntimeTypeKind kind - - is_TYPE_or_Type :: DynFlags -> Bool - is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE - | otherwise = tcIsLiftedTypeKind kind - - -- In the particular case of a data family, permit a return kind of the - -- form `:: k` (where `k` is a bare kind variable). - is_kind_var :: Bool - is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind) - | otherwise = False - - err_msg :: DynFlags -> SDoc - err_msg dflags = - sep [ (sep [ text "Kind signature on" <+> pp_dec <+> - text "declaration has non-" <> - (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind) - , (if is_data_family then text "and non-variable" else empty) <+> - text "return kind" <+> quotes (ppr kind) ]) - , if not (tYPE_ok dflags) && is_TYPE && is_newtype && - not (xopt LangExt.UnliftedNewtypes dflags) - then text "Perhaps you intended to use UnliftedNewtypes" - else empty ] - --- | Checks that the result kind of a class is exactly `Constraint`, rejecting --- type synonyms and type families that reduce to `Constraint`. See #16826. -checkClassKindSig :: Kind -> TcM () -checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg - where - err_msg :: SDoc - err_msg = - text "Kind signature on a class must end with" <+> ppr constraintKind $$ - text "unobscured by type families" - -tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] --- Result is in 1-1 correpondence with orig_args -tcbVisibilities tc orig_args - = go (tyConKind tc) init_subst orig_args - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) - go _ _ [] - = [] - - go fun_kind subst all_args@(arg : args) - | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind - = case tcb of - Anon af _ -> AnonTCB af : go inner_kind subst args - Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args - where - subst' = extendTCvSubst subst tv arg - - | not (isEmptyTCvSubst subst) - = go (substTy subst fun_kind) init_subst all_args - - | otherwise - = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) - - -{- Note [TyConBinders for the result kind signature of a data type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - data T (a::*) :: * -> forall k. k -> * -we want to generate the extra TyConBinders for T, so we finally get - (a::*) (b::*) (k::*) (c::k) -The function etaExpandAlgTyCon generates these extra TyConBinders from -the result kind signature. - -We need to take care to give the TyConBinders - (a) OccNames that are fresh (because the TyConBinders of a TyCon - must have distinct OccNames - - (b) Uniques that are fresh (obviously) - -For (a) we need to avoid clashes with the tyvars declared by -the user before the "::"; in the above example that is 'a'. -And also see Note [Avoid name clashes for associated data types]. - -For (b) suppose we have - data T :: forall k. k -> forall k. k -> * -where the two k's are identical even up to their uniques. Surprisingly, -this can happen: see #14515. - -It's reasonably easy to solve all this; just run down the list with a -substitution; hence the recursive 'go' function. But it has to be -done. - -Note [Avoid name clashes for associated data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider class C a b where - data D b :: * -> * -When typechecking the decl for D, we'll invent an extra type variable -for D, to fill out its kind. Ideally we don't want this type variable -to be 'a', because when pretty printing we'll get - class C a b where - data D b a0 -(NB: the tidying happens in the conversion to IfaceSyn, which happens -as part of pretty-printing a TyThing.) - -That's why we look in the LocalRdrEnv to see what's in scope. This is -important only to get nice-looking output when doing ":info C" in GHCi. -It isn't essential for correctness. - - -************************************************************************ -* * - Partial signatures -* * -************************************************************************ - --} - -tcHsPartialSigType - :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , Maybe TcType -- Extra-constraints wildcard - , [(Name,TcTyVar)] -- Original tyvar names, in correspondence with - -- the implicitly and explicitly bound type variables - , TcThetaType -- Theta part - , TcType ) -- Tau part --- See Note [Checking partial type signatures] -tcHsPartialSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_ext = implicit_hs_tvs - , hsib_body = hs_ty } <- ib_ty - , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty - = addSigCtxt ctxt hs_ty $ - do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) - <- solveLocalEqualities "tcHsPartialSigType" $ - -- This solveLocalEqualiltes fails fast if there are - -- insoluble equalities. See TcSimplify - -- Note [Fail fast if there are insoluble kind equalities] - tcNamedWildCardBinders sig_wcs $ \ wcs -> - bindImplicitTKBndrs_Tv implicit_hs_tvs $ - bindExplicitTKBndrs_Tv explicit_hs_tvs $ - do { -- Instantiate the type-class context; but if there - -- is an extra-constraints wildcard, just discard it here - (theta, wcx) <- tcPartialContext hs_ctxt - - ; tau <- tcHsOpenType hs_tau - - ; return (wcs, wcx, theta, tau) } - - -- No kind-generalization here, but perhaps some promotion - ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $ - mkSpecForAllTys explicit_tvs $ - mkPhiTy theta $ - tau) - - -- Spit out the wildcards (including the extra-constraints one) - -- as "hole" constraints, so that they'll be reported if necessary - -- See Note [Extra-constraint holes in partial type signatures] - ; emitNamedWildCardHoleConstraints wcs - - -- Zonk, so that any nested foralls can "see" their occurrences - -- See Note [Checking partial type signatures], in - -- the bullet on Nested foralls. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - ; explicit_tvs <- mapM zonkTcTyVarToTyVar explicit_tvs - ; theta <- mapM zonkTcType theta - ; tau <- zonkTcType tau - - -- We return a proper (Name,TyVar) environment, to be sure that - -- we bring the right name into scope in the function body. - -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvs) - ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs) - - -- NB: checkValidType on the final inferred type will be - -- done later by checkInferredPolyId. We can't do it - -- here because we don't have a complete type to check - - ; traceTc "tcHsPartialSigType" (ppr tv_prs) - ; return (wcs, wcx, tv_prs, theta, tau) } - -tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -tcHsPartialSigType _ (XHsWildCardBndrs nec) = noExtCon nec - -tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) -tcPartialContext hs_theta - | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta - , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- setSrcSpan wc_loc $ - tcAnonWildCardOcc wc constraintKind - ; theta <- mapM tcLHsPredType hs_theta1 - ; return (theta, Just wc_tv_ty) } - | otherwise - = do { theta <- mapM tcLHsPredType hs_theta - ; return (theta, Nothing) } - -{- Note [Checking partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note is about tcHsPartialSigType. See also -Note [Recipe for checking a signature] - -When we have a partial signature like - f :: forall a. a -> _ -we do the following - -* tcHsPartialSigType does not make quantified type (forall a. blah) - and then instantiate it -- it makes no sense to instantiate a type - with wildcards in it. Rather, tcHsPartialSigType just returns the - 'a' and the 'blah' separately. - - Nor, for the same reason, do we push a level in tcHsPartialSigType. - -* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ - a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider - f :: forall a. a -> _ - g :: forall b. _ -> b - f = g - g = f - They are typechecked as a recursive group, with monomorphic types, - so 'a' and 'b' will get unified together. Very like kind inference - for mutually recursive data types (sans CUSKs or SAKS); see - Note [Cloning for tyvar binders] in GHC.Tc.Gen.HsType - -* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike - the companion CompleteSig) contains the original, as-yet-unchecked - source-code LHsSigWcType - -* Then, for f and g /separately/, we call tcInstSig, which in turn - call tchsPartialSig (defined near this Note). It kind-checks the - LHsSigWcType, creating fresh unification variables for each "_" - wildcard. It's important that the wildcards for f and g are distinct - because they might get instantiated completely differently. E.g. - f,g :: forall a. a -> _ - f x = a - g x = True - It's really as if we'd written two distinct signatures. - -* Nested foralls. Consider - f :: forall b. (forall a. a -> _) -> b - We do /not/ allow the "_" to be instantiated to 'a'; but we do - (as before) allow it to be instantiated to the (top level) 'b'. - Why not? Because suppose - f x = (x True, x 'c') - We must instantiate that (forall a. a -> _) when typechecking - f's body, so we must know precisely where all the a's are; they - must not be hidden under (filled-in) unification variables! - - We achieve this in the usual way: we push a level at a forall, - so now the unification variable for the "_" can't unify with - 'a'. - -* Just as for ordinary signatures, we must zonk the type after - kind-checking it, to ensure that all the nested forall binders can - see their occurrenceds - - Just as for ordinary signatures, this zonk also gets any Refl casts - out of the way of instantiation. Example: #18008 had - foo :: (forall a. (Show a => blah) |> Refl) -> _ - and that Refl cast messed things up. See #18062. - -Note [Extra-constraint holes in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (_) => a -> a - f x = ... - -* The renamer leaves '_' untouched. - -* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in - tcWildCardBinders. - -* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar - with the inferred constraints, e.g. (Eq a, Show a) - -* TcErrors.mkHoleError finally reports the error. - -An annoying difficulty happens if there are more than 62 inferred -constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. -Where do we find the TyCon? For good reasons we only have constraint -tuples up to 62 (see Note [How tuples work] in TysWiredIn). So how -can we make a 70-tuple? This was the root cause of #14217. - -It's incredibly tiresome, because we only need this type to fill -in the hole, to communicate to the error reporting machinery. Nothing -more. So I use a HACK: - -* I make an /ordinary/ tuple of the constraints, in - TcBinds.chooseInferredQuantifiers. This is ill-kinded because - ordinary tuples can't contain constraints, but it works fine. And for - ordinary tuples we don't have the same limit as for constraint - tuples (which need selectors and an assocated class). - -* Because it is ill-kinded, it trips an assert in writeMetaTyVar, - so now I disable the assertion if we are writing a type of - kind Constraint. (That seldom/never normally happens so we aren't - losing much.) - -Result works fine, but it may eventually bite us. - - -************************************************************************ -* * - Pattern signatures (i.e signatures that occur in patterns) -* * -********************************************************************* -} - -tcHsPatSigType :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , [(Name, TcTyVar)] -- The new bit of type environment, binding - -- the scoped type variables - , TcType) -- The type --- Used for type-checking type signatures in --- (a) patterns e.g f (x::Int) = e --- (b) RULE forall bndrs e.g. forall (x::Int). f x = x --- --- This may emit constraints --- See Note [Recipe for checking a signature] -tcHsPatSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_ext = sig_ns - , hsib_body = hs_ty } <- ib_ty - = addSigCtxt ctxt hs_ty $ - do { sig_tkv_prs <- mapM new_implicit_tv sig_ns - ; (wcs, sig_ty) - <- solveLocalEqualities "tcHsPatSigType" $ - -- Always solve local equalities if possible, - -- else casts get in the way of deep skolemisation - -- (#16033) - tcNamedWildCardBinders sig_wcs $ \ wcs -> - tcExtendNameTyVarEnv sig_tkv_prs $ - do { sig_ty <- tcHsOpenType hs_ty - ; return (wcs, sig_ty) } - - ; emitNamedWildCardHoleConstraints wcs - - -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty - -- contains a forall). Promote these. - -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... - -- When we instantiate x, we have to compare the kind of the argument - -- to a's kind, which will be a metavariable. - -- kindGeneralizeNone does this: - ; kindGeneralizeNone sig_ty - ; sig_ty <- zonkTcType sig_ty - ; checkValidType ctxt sig_ty - - ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) - ; return (wcs, sig_tkv_prs, sig_ty) } - where - new_implicit_tv name - = do { kind <- newMetaKindVar - ; tv <- case ctxt of - RuleSigCtxt {} -> newSkolemTyVar name kind - _ -> newPatSigTyVar name kind - -- See Note [Pattern signature binders] - -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) - ; return (name, tv) } - -tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -tcHsPatSigType _ (XHsWildCardBndrs nec) = noExtCon nec - -tcPatSig :: Bool -- True <=> pattern binding - -> LHsSigWcType GhcRn - -> ExpSigmaType - -> TcM (TcType, -- The type to use for "inside" the signature - [(Name,TcTyVar)], -- The new bit of type environment, binding - -- the scoped type variables - [(Name,TcTyVar)], -- The wildcards - HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty -tcPatSig in_pat_bind sig res_ty - = do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig - -- sig_tvs are the type variables free in 'sig', - -- and not already in scope. These are the ones - -- that should be brought into scope - - ; if null sig_tvs then do { - -- Just do the subsumption check and return - wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - ; return (sig_ty, [], sig_wcs, wrap) - } else do - -- Type signature binds at least one scoped type variable - - -- A pattern binding cannot bind scoped type variables - -- It is more convenient to make the test here - -- than in the renamer - { when in_pat_bind (addErr (patBindSigErr sig_tvs)) - - -- Now do a subsumption check of the pattern signature against res_ty - ; wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - - -- Phew! - ; return (sig_ty, sig_tvs, sig_wcs, wrap) - } } - where - mk_msg sig_ty tidy_env - = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty - ; res_ty <- readExpType res_ty -- should be filled in by now - ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; let msg = vcat [ hang (text "When checking that the pattern signature:") - 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") - 2 (ppr res_ty)) ] - ; return (tidy_env, msg) } - -patBindSigErr :: [(Name,TcTyVar)] -> SDoc -patBindSigErr sig_tvs - = hang (text "You cannot bind scoped type variable" <> plural sig_tvs - <+> pprQuotedList (map fst sig_tvs)) - 2 (text "in a pattern binding signature") - -{- Note [Pattern signature binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Type variables in the type environment] in TcRnTypes. -Consider - - data T where - MkT :: forall a. a -> (a -> Int) -> T - - f :: T -> ... - f (MkT x (f :: b -> c)) = - -Here - * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', - It must be a skolem so that that it retains its identity, and - TcErrors.getSkolemInfo can thereby find the binding site for the skolem. - - * The type signature pattern (f :: b -> c) makes freshs meta-tyvars - beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the - environment - - * Then unification makes beta := a_sk, gamma := Int - That's why we must make beta and gamma a MetaTv, - not a SkolemTv, so that it can unify to a_sk (or Int, respectively). - - * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, - so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, - -Another example (#13881): - fl :: forall (l :: [a]). Sing l -> Sing l - fl (SNil :: Sing (l :: [y])) = SNil -When we reach the pattern signature, 'l' is in scope from the -outer 'forall': - "a" :-> a_sk :: * - "l" :-> l_sk :: [a_sk] -We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check -the pattern signature - Sing (l :: [y]) -That unifies y_sig := a_sk. We return from tcHsPatSigType with -the pair ("y" :-> y_sig). - -For RULE binders, though, things are a bit different (yuk). - RULE "foo" forall (x::a) (y::[a]). f x y = ... -Here this really is the binding site of the type variable so we'd like -to use a skolem, so that we get a complaint if we unify two of them -together. Hence the new_tv function in tcHsPatSigType. - - -************************************************************************ -* * - Checking kinds -* * -************************************************************************ - --} - -unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) -unifyKinds rn_tys act_kinds - = do { kind <- newMetaKindVar - ; let check rn_ty (ty, act_kind) - = checkExpectedKind (unLoc rn_ty) ty act_kind kind - ; tys' <- zipWithM check rn_tys act_kinds - ; return (tys', kind) } - -{- -************************************************************************ -* * - Sort checking kinds -* * -************************************************************************ - -tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. -It does sort checking and desugaring at the same time, in one single pass. --} - -tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind -tcLHsKindSig ctxt hs_kind --- See Note [Recipe for checking a signature] in TcHsType --- Result is zonked - = do { kind <- solveLocalEqualities "tcLHsKindSig" $ - tc_lhs_kind kindLevelMode hs_kind - ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) - -- No generalization: - ; kindGeneralizeNone kind - ; kind <- zonkTcType kind - -- This zonk is very important in the case of higher rank kinds - -- E.g. #13879 f :: forall (p :: forall z (y::z). ). - -- - -- When instantiating p's kind at occurrences of p in - -- it's crucial that the kind we instantiate is fully zonked, - -- else we may fail to substitute properly - - ; checkValidType ctxt kind - ; traceTc "tcLHsKindSig2" (ppr kind) - ; return kind } - -tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind -tc_lhs_kind mode k - = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ - tc_lhs_type (kindLevel mode) k liftedTypeKind - -promotionErr :: Name -> PromotionErr -> TcM a -promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") - 2 (parens reason)) - where - reason = case err of - ConstrainedDataConPE pred - -> text "it has an unpromotable context" - <+> quotes (ppr pred) - FamDataConPE -> text "it comes from a data family instance" - NoDataKindsTC -> text "perhaps you intended to use DataKinds" - NoDataKindsDC -> text "perhaps you intended to use DataKinds" - PatSynPE -> text "pattern synonyms cannot be promoted" - _ -> text "it is defined and used in the same recursive group" - -{- -************************************************************************ -* * - Error messages and such -* * -************************************************************************ --} - - --- | If the inner action emits constraints, report them as errors and fail; --- otherwise, propagates the return value. Useful as a wrapper around --- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be --- another chance to solve constraints -failIfEmitsConstraints :: TcM a -> TcM a -failIfEmitsConstraints thing_inside - = checkNoErrs $ -- We say that we fail if there are constraints! - -- c.f same checkNoErrs in solveEqualities - do { (res, lie) <- captureConstraints thing_inside - ; reportAllUnsolved lie - ; return res - } - --- | Make an appropriate message for an error in a function argument. --- Used for both expressions and types. -funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc -funAppCtxt fun arg arg_no - = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), - quotes (ppr fun) <> text ", namely"]) - 2 (quotes (ppr arg)) - --- | Add a "In the data declaration for T" or some such. -addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a -addTyConFlavCtxt name flav - = addErrCtxt $ hsep [ text "In the", ppr flav - , text "declaration for", quotes (ppr name) ] diff --git a/typecheck/TcInstDcls.hs b/typecheck/TcInstDcls.hs deleted file mode 100644 --- a/typecheck/TcInstDcls.hs +++ /dev/null @@ -1,2235 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcInstDecls: Typechecking instance declarations --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcBinds -import TcTyClsDecls -import TcTyDecls ( addTyConsToGblEnv ) -import TcClassDcl( tcClassDecl2, tcATDefault, - HsSigFun, mkHsSigFun, badMethodErr, - findMethodBind, instantiateMethod ) -import TcSigs -import TcRnMonad -import TcValidity -import TcHsSyn -import TcMType -import TcType -import Constraint -import TcOrigin -import BuildTyCl -import Inst -import ClsInst( AssocInstInfo(..), isNotAssociated ) -import InstEnv -import FamInst -import FamInstEnv -import TcDeriv -import TcEnv -import TcHsType -import TcUnify -import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams ) -import MkCore ( nO_METHOD_BINDING_ERROR_ID ) -import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) -import Type -import TcEvidence -import TyCon -import CoAxiom -import DataCon -import ConLike -import Class -import Var -import VarEnv -import VarSet -import Bag -import BasicTypes -import DynFlags -import ErrUtils -import FastString -import Id -import ListSetOps -import Name -import NameSet -import Outputable -import SrcLoc -import Util -import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Maybes -import Data.Tuple ( swap ) -import Data.List( mapAccumL ) - - -{- -Typechecking instance declarations is done in two passes. The first -pass, made by @tcInstDecls1@, collects information to be used in the -second pass. - -This pre-processed info includes the as-yet-unprocessed bindings -inside the instance declaration. These are type-checked in the second -pass, when the class-instance envs and GVE contain all the info from -all the instance and value decls. Indeed that's the reason we need -two passes over the instance decls. - - -Note [How instance declarations are translated] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is how we translate instance declarations into Core - -Running example: - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = -===> - -- Method selectors - op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b - op1 = ... - op2 = ... - - -- Default methods get the 'self' dictionary as argument - -- so they can call other methods at the same type - -- Default methods get the same type as their method selector - $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b - $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). - -- NB: type variables 'a' and 'b' are *both* in scope in - -- Note [Tricky type variable scoping] - - -- A top-level definition for each instance method - -- Here op1_i, op2_i are the "instance method Ids" - -- The INLINE pragma comes from the user pragma - {-# INLINE [2] op1_i #-} -- From the instance decl bindings - op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b - op1_i = /\a. \(d:C a). - let this :: C [a] - this = df_i a d - -- Note [Subtle interaction of recursion and overlap] - - local_op1 :: forall b. Ix b => [a] -> b -> b - local_op1 = - -- Source code; run the type checker on this - -- NB: Type variable 'a' (but not 'b') is in scope in - -- Note [Tricky type variable scoping] - - in local_op1 a d - - op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) - - -- The dictionary function itself - {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions - df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) - -- But see Note [Default methods in instances] - -- We can't apply the type checker to the default-method call - - -- Use a RULE to short-circuit applications of the class ops - {-# RULE "op1@C[a]" forall a, d:C a. - op1 [a] (df_i d) = op1_i a d #-} - -Note [Instances and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Note that df_i may be mutually recursive with both op1_i and op2_i. - It's crucial that df_i is not chosen as the loop breaker, even - though op1_i has a (user-specified) INLINE pragma. - -* Instead the idea is to inline df_i into op1_i, which may then select - methods from the MkC record, and thereby break the recursion with - df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at - the same type, it won't mention df_i, so there won't be recursion in - the first place.) - -* If op1_i is marked INLINE by the user there's a danger that we won't - inline df_i in it, and that in turn means that (since it'll be a - loop-breaker because df_i isn't), op1_i will ironically never be - inlined. But this is OK: the recursion breaking happens by way of - a RULE (the magic ClassOp rule above), and RULES work inside InlineRule - unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils - -Note [ClassOp/DFun selection] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One thing we see a lot is stuff like - op2 (df d1 d2) -where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* -'op2' and 'df' to get - case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of - MkD _ op2 _ _ _ -> op2 -And that will reduce to ($cop2 d1 d2) which is what we wanted. - -But it's tricky to make this work in practice, because it requires us to -inline both 'op2' and 'df'. But neither is keen to inline without having -seen the other's result; and it's very easy to get code bloat (from the -big intermediate) if you inline a bit too much. - -Instead we use a cunning trick. - * We arrange that 'df' and 'op2' NEVER inline. - - * We arrange that 'df' is ALWAYS defined in the sylised form - df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... - - * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) - that lists its methods. - - * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return - a suitable constructor application -- inlining df "on the fly" as it - were. - - * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that - extracts the right piece iff its argument satisfies - exprIsConApp_maybe. This is done in MkId mkDictSelId - - * We make 'df' CONLIKE, so that shared uses still match; eg - let d = df d1 d2 - in ...(op2 d)...(op1 d)... - -Note [Single-method classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the class has just one method (or, more accurately, just one element -of {superclasses + methods}), then we use a different strategy. - - class C a where op :: a -> a - instance C a => C [a] where op = - -We translate the class decl into a newtype, which just gives a -top-level axiom. The "constructor" MkC expands to a cast, as does the -class-op selector. - - axiom Co:C a :: C a ~ (a->a) - - op :: forall a. C a -> (a -> a) - op a d = d |> (Co:C a) - - MkC :: forall a. (a->a) -> C a - MkC = /\a.\op. op |> (sym Co:C a) - -The clever RULE stuff doesn't work now, because ($df a d) isn't -a constructor application, so exprIsConApp_maybe won't return -Just . - -Instead, we simply rely on the fact that casts are cheap: - - $df :: forall a. C a => C [a] - {-# INLINE df #-} -- NB: INLINE this - $df = /\a. \d. MkC [a] ($cop_list a d) - = $cop_list |> forall a. C a -> (sym (Co:C [a])) - - $cop_list :: forall a. C a => [a] -> [a] - $cop_list = - -So if we see - (op ($df a d)) -we'll inline 'op' and '$df', since both are simply casts, and -good things happen. - -Why do we use this different strategy? Because otherwise we -end up with non-inlined dictionaries that look like - $df = $cop |> blah -which adds an extra indirection to every use, which seems stupid. See -#4138 for an example (although the regression reported there -wasn't due to the indirection). - -There is an awkward wrinkle though: we want to be very -careful when we have - instance C a => C [a] where - {-# INLINE op #-} - op = ... -then we'll get an INLINE pragma on $cop_list but it's important that -$cop_list only inlines when it's applied to *two* arguments (the -dictionary and the list argument). So we must not eta-expand $df -above. We ensure that this doesn't happen by putting an INLINE -pragma on the dfun itself; after all, it ends up being just a cast. - -There is one more dark corner to the INLINE story, even more deeply -buried. Consider this (#3772): - - class DeepSeq a => C a where - gen :: Int -> a - - instance C a => C [a] where - gen n = ... - - class DeepSeq a where - deepSeq :: a -> b -> b - - instance DeepSeq a => DeepSeq [a] where - {-# INLINE deepSeq #-} - deepSeq xs b = foldr deepSeq b xs - -That gives rise to these defns: - - $cdeepSeq :: DeepSeq a -> [a] -> b -> b - -- User INLINE( 3 args )! - $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... - - $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] - -- DFun (with auto INLINE pragma) - $fDeepSeq[] a d = $cdeepSeq a d |> blah - - $cp1 a d :: C a => DeepSep [a] - -- We don't want to eta-expand this, lest - -- $cdeepSeq gets inlined in it! - $cp1 a d = $fDeepSep[] a (scsel a d) - - $fC[] :: C a => C [a] - -- Ordinary DFun - $fC[] a d = MkC ($cp1 a d) ($cgen a d) - -Here $cp1 is the code that generates the superclass for C [a]. The -issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] -and then $cdeepSeq will inline there, which is definitely wrong. Like -on the dfun, we solve this by adding an INLINE pragma to $cp1. - -Note [Subtle interaction of recursion and overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - class C a where { op1,op2 :: a -> a } - instance C a => C [a] where - op1 x = op2 x ++ op2 x - op2 x = ... - instance C [Int] where - ... - -When type-checking the C [a] instance, we need a C [a] dictionary (for -the call of op2). If we look up in the instance environment, we find -an overlap. And in *general* the right thing is to complain (see Note -[Overlapping instances] in InstEnv). But in *this* case it's wrong to -complain, because we just want to delegate to the op2 of this same -instance. - -Why is this justified? Because we generate a (C [a]) constraint in -a context in which 'a' cannot be instantiated to anything that matches -other overlapping instances, or else we would not be executing this -version of op1 in the first place. - -It might even be a bit disguised: - - nullFail :: C [a] => [a] -> [a] - nullFail x = op2 x ++ op2 x - - instance C a => C [a] where - op1 x = nullFail x - -Precisely this is used in package 'regex-base', module Context.hs. -See the overlapping instances for RegexContext, and the fact that they -call 'nullFail' just like the example above. The DoCon package also -does the same thing; it shows up in module Fraction.hs. - -Conclusion: when typechecking the methods in a C [a] instance, we want to -treat the 'a' as an *existential* type variable, in the sense described -by Note [Binding when looking up instances]. That is why isOverlappableTyVar -responds True to an InstSkol, which is the kind of skolem we use in -tcInstDecl2. - - -Note [Tricky type variable scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In our example - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = - -note that 'a' and 'b' are *both* in scope in , but only 'a' is -in scope in . In particular, we must make sure that 'b' is in -scope when typechecking . This is achieved by subFunTys, -which brings appropriate tyvars into scope. This happens for both - and for , but that doesn't matter: the *renamer* will have -complained if 'b' is mentioned in . - - - -************************************************************************ -* * -\subsection{Extracting instance decls} -* * -************************************************************************ - -Gather up the instance declarations from their various sources --} - -tcInstDecls1 -- Deal with both source-code and imported instance decls - :: [LInstDecl GhcRn] -- Source code instance decls - -> TcM (TcGblEnv, -- The full inst env - [InstInfo GhcRn], -- Source-code instance decls to process; - -- contains all dfuns for this module - [DerivInfo]) -- From data family instances - -tcInstDecls1 inst_decls - = do { -- Do class and family instance declarations - ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls - - ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff - fam_insts = concat fam_insts_s - local_infos = concat local_infos_s - - ; gbl_env <- addClsInsts local_infos $ - addFamInsts fam_insts $ - getGblEnv - - ; return ( gbl_env - , local_infos - , concat datafam_deriv_infos ) } - --- | Use DerivInfo for data family instances (produced by tcInstDecls1), --- datatype declarations (TyClDecl), and standalone deriving declarations --- (DerivDecl) to check and process all derived class instances. -tcInstDeclsDeriv - :: [DerivInfo] - -> [LDerivDecl GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) -tcInstDeclsDeriv deriv_infos derivds - = do th_stage <- getStage -- See Note [Deriving inside TH brackets] - if isBrackStage th_stage - then do { gbl_env <- getGblEnv - ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } - else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds - ; return (tcg_env, bagToList info_bag, valbinds) } - -addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a -addClsInsts infos thing_inside - = tcExtendLocalInstEnv (map iSpec infos) thing_inside - -addFamInsts :: [FamInst] -> TcM a -> TcM a --- Extend (a) the family instance envt --- (b) the type envt with stuff from data type decls -addFamInsts fam_insts thing_inside - = tcExtendLocalFamInstEnv fam_insts $ - tcExtendGlobalEnv axioms $ - do { traceTc "addFamInsts" (pprFamInsts fam_insts) - ; gbl_env <- addTyConsToGblEnv data_rep_tycons - -- Does not add its axiom; that comes - -- from adding the 'axioms' above - ; setGblEnv gbl_env thing_inside } - where - axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts - data_rep_tycons = famInstsRepTyCons fam_insts - -- The representation tycons for 'data instances' declarations - -{- -Note [Deriving inside TH brackets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a declaration bracket - [d| data T = A | B deriving( Show ) |] - -there is really no point in generating the derived code for deriving( -Show) and then type-checking it. This will happen at the call site -anyway, and the type check should never fail! Moreover (#6005) -the scoping of the generated code inside the bracket does not seem to -work out. - -The easy solution is simply not to generate the derived instances at -all. (A less brutal solution would be to generate them with no -bindings.) This will become moot when we shift to the new TH plan, so -the brutal solution will do. --} - -tcLocalInstDecl :: LInstDecl GhcRn - -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) - -- A source-file instance declaration - -- Type-check all the stuff before the "where" - -- - -- We check for respectable instance type, and context -tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) - = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl) - ; return ([], [fam_inst], []) } - -tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) - = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl) - ; return ([], [fam_inst], maybeToList m_deriv_info) } - -tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) - = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) - ; return (insts, fam_insts, deriv_infos) } - -tcLocalInstDecl (L _ (XInstDecl nec)) = noExtCon nec - -tcClsInstDecl :: LClsInstDecl GhcRn - -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) --- The returned DerivInfos are for any associated data families -tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds - , cid_sigs = uprags, cid_tyfam_insts = ats - , cid_overlap_mode = overlap_mode - , cid_datafam_insts = adts })) - = setSrcSpan loc $ - addErrCtxt (instDeclCtxt1 hs_ty) $ - do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty - ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty - -- NB: tcHsClsInstType does checkValidInstance - - ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars - ; let tv_skol_prs = [ (tyVarName tv, skol_tv) - | (tv, skol_tv) <- tyvars `zip` skol_tvs ] - -- Map from the skolemized Names to the original Names. - -- See Note [Associated data family instances and di_scoped_tvs]. - tv_skol_env = mkVarEnv $ map swap tv_skol_prs - n_inferred = countWhile ((== Inferred) . binderArgFlag) $ - fst $ splitForAllVarBndrs dfun_ty - visible_skol_tvs = drop n_inferred skol_tvs - - ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs) - - -- Next, process any associated types. - ; (datafam_stuff, tyfam_insts) - <- tcExtendNameTyVarEnv tv_skol_prs $ - do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env - mb_info = InClsInst { ai_class = clas - , ai_tyvars = visible_skol_tvs - , ai_inst_env = mini_env } - ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts - ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats - - -- Check for missing associated types and build them - -- from their defaults (if available) - ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) - (classATItems clas) - - ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } - - - -- Finally, construct the Core representation of the instance. - -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty)) - -- Dfun location is that of instance *header* - - ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name - tyvars theta clas inst_tys - - ; let inst_binds = InstBindings - { ib_binds = binds - , ib_tyvars = map Var.varName tyvars -- Scope over bindings - , ib_pragmas = uprags - , ib_extensions = [] - , ib_derived = False } - inst_info = InstInfo { iSpec = ispec, iBinds = inst_binds } - - (datafam_insts, m_deriv_infos) = unzip datafam_stuff - deriv_infos = catMaybes m_deriv_infos - all_insts = tyfam_insts ++ datafam_insts - - -- In hs-boot files there should be no bindings - ; is_boot <- tcIsHsBootOrSig - ; let no_binds = isEmptyLHsBinds binds && null uprags - ; failIfTc (is_boot && not no_binds) badBootDeclErr - - ; return ( [inst_info], all_insts, deriv_infos ) } - where - defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) - `unionNameSet` - mkNameSet (map (unLoc . feqn_tycon - . hsib_body - . dfid_eqn - . unLoc) adts) - -tcClsInstDecl (L _ (XClsInstDecl nec)) = noExtCon nec - -{- -************************************************************************ -* * - Type family instances -* * -************************************************************************ - -Family instances are somewhat of a hybrid. They are processed together with -class instance heads, but can contain data constructors and hence they share a -lot of kinding and type checking code with ordinary algebraic data types (and -GADTs). --} - -tcTyFamInstDecl :: AssocInstInfo - -> LTyFamInstDecl GhcRn -> TcM FamInst - -- "type instance" - -- See Note [Associated type instances] -tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) - = setSrcSpan loc $ - tcAddTyFamInstCtxt decl $ - do { let fam_lname = feqn_tycon (hsib_body eqn) - ; fam_tc <- tcLookupLocatedTyCon fam_lname - ; tcFamInstDeclChecks mb_clsinfo fam_tc - - -- (0) Check it's an open type family - ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) - - -- (1) do the work of verifying the synonym group - ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo - (L (getLoc fam_lname) eqn) - - - -- (2) check for validity - ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch - ; checkValidCoAxBranch fam_tc co_ax_branch - - -- (3) construct coercion axiom - ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] - ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch - ; newFamInst SynFamilyInst axiom } - - ---------------------- -tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () --- Used for both type and data families -tcFamInstDeclChecks mb_clsinfo fam_tc - = do { -- Type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file - ; traceTc "tcFamInstDecl" (ppr fam_tc) - ; type_families <- xoptM LangExt.TypeFamilies - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl fam_tc - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Check that it is a family TyCon, and that - -- oplevel type instances are not for associated types. - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - - ; when (isNotAssociated mb_clsinfo && -- Not in a class decl - isTyConAssoc fam_tc) -- but an associated type - (addErr $ assocInClassErr fam_tc) - } - -{- Note [Associated type instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow this: - class C a where - type T x a - instance C Int where - type T (S y) Int = y - type T Z Int = Char - -Note that - a) The variable 'x' is not bound by the class decl - b) 'x' is instantiated to a non-type-variable in the instance - c) There are several type instance decls for T in the instance - -All this is fine. Of course, you can't give any *more* instances -for (T ty Int) elsewhere, because it's an *associated* type. - - -************************************************************************ -* * - Data family instances -* * -************************************************************************ - -For some reason data family instances are a lot more complicated -than type family instances --} - -tcDataFamInstDecl :: - AssocInstInfo - -> TyVarEnv Name -- If this is an associated data family instance, maps the - -- parent class's skolemized type variables to their - -- original Names. If this is a non-associated instance, - -- this will be empty. - -- See Note [Associated data family instances and di_scoped_tvs]. - -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) - -- "newtype instance" and "data instance" -tcDataFamInstDecl mb_clsinfo tv_skol_env - (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars - , hsib_body = - FamEqn { feqn_bndrs = mb_bndrs - , feqn_pats = hs_pats - , feqn_tycon = lfam_name@(L _ fam_name) - , feqn_fixity = fixity - , feqn_rhs = HsDataDefn { dd_ND = new_or_data - , dd_cType = cType - , dd_ctxt = hs_ctxt - , dd_cons = hs_cons - , dd_kindSig = m_ksig - , dd_derivs = derivs } }}})) - = setSrcSpan loc $ - tcAddDataFamInstCtxt decl $ - do { fam_tc <- tcLookupLocatedTyCon lfam_name - - ; tcFamInstDeclChecks mb_clsinfo fam_tc - - -- Check that the family declaration is for the right kind - ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons - -- Do /not/ check that the number of patterns = tyConArity fam_tc - -- See [Arity of data families] in FamInstEnv - ; (qtvs, pats, res_kind, stupid_theta) - <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs - fixity hs_ctxt hs_pats m_ksig hs_cons - new_or_data - - -- Eta-reduce the axiom if possible - -- Quite tricky: see Note [Eta-reduction for data families] - ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats - eta_tvs = map binderVar eta_tcbs - post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs - - full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs - (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) - ++ eta_tcbs - -- Put the eta-removed tyvars at the end - -- Remember, qtvs is in arbitrary order, except kind vars are - -- first, so there is no reason to suppose that the eta_tvs - -- (obtained from the pats) are at the end (#11148) - - -- Eta-expand the representation tycon until it has result - -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we - -- go one step further and ensure that it has kind `TYPE 'LiftedRep`. - -- - -- See also Note [Arity of data families] in FamInstEnv - -- NB: we can do this after eta-reducing the axiom, because if - -- we did it before the "extra" tvs from etaExpandAlgTyCon - -- would always be eta-reduced - ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind - ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind - ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs - all_pats = pats `chkAppend` extra_pats - orig_res_ty = mkTyConApp fam_tc all_pats - ty_binders = full_tcbs `chkAppend` extra_tcbs - - ; traceTc "tcDataFamInstDecl" $ - vcat [ text "Fam tycon:" <+> ppr fam_tc - , text "Pats:" <+> ppr pats - , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats) - , text "all_pats:" <+> ppr all_pats - , text "ty_binders" <+> ppr ty_binders - , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) - , text "eta_pats" <+> ppr eta_pats - , text "eta_tcbs" <+> ppr eta_tcbs ] - - ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { data_cons <- tcExtendTyVarEnv qtvs $ - -- For H98 decls, the tyvars scope - -- over the data constructors - tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind - orig_res_ty hs_cons - - ; rep_tc_name <- newFamInstTyConName lfam_name pats - ; axiom_name <- newFamInstAxiomName lfam_name [pats] - ; tc_rhs <- case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) - - ; let axiom = mkSingleCoAxiom Representational axiom_name - post_eta_qtvs eta_tvs [] fam_tc eta_pats - (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)) - parent = DataFamInstTyCon axiom fam_tc all_pats - - -- NB: Use the full ty_binders from the pats. See bullet toward - -- the end of Note [Data type families] in TyCon - rep_tc = mkAlgTyCon rep_tc_name - ty_binders final_res_kind - (map (const Nominal) ty_binders) - (fmap unLoc cType) stupid_theta - tc_rhs parent - gadt_syntax - -- We always assume that indexed types are recursive. Why? - -- (1) Due to their open nature, we can never be sure that a - -- further instance might not introduce a new recursive - -- dependency. (2) They are always valid loop breakers as - -- they involve a coercion. - ; return (rep_tc, axiom) } - - -- Remember to check validity; no recursion to worry about here - -- Check that left-hand sides are ok (mono-types, no type families, - -- consistent instantiations, etc) - ; let ax_branch = coAxiomSingleBranch axiom - ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch - ; checkValidCoAxBranch fam_tc ax_branch - ; checkValidTyCon rep_tc - - ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc) - m_deriv_info = case derivs of - L _ [] -> Nothing - L _ preds -> - Just $ DerivInfo { di_rep_tc = rep_tc - , di_scoped_tvs = scoped_tvs - , di_clauses = preds - , di_ctxt = tcMkDataFamInstCtxt decl } - - ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom - ; return (fam_inst, m_deriv_info) } - where - eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) - -- See Note [Eta reduction for data families] in FamInstEnv - -- Splits the incoming patterns into two: the [TyVar] - -- are the patterns that can be eta-reduced away. - -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) - -- - -- NB: quadratic algorithm, but types are small here - eta_reduce fam_tc pats - = go (reverse (zip3 pats fvs_s vis_s)) [] - where - vis_s :: [TyConBndrVis] - vis_s = tcbVisibilities fam_tc pats - - fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats - -- Each elt is the free vars of all /earlier/ pats - (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats - add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs) - - go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs - | Just tv <- getTyVar_maybe pat - , not (tv `elemVarSet` fvs_to_the_left) - = go pats (Bndr tv tcb_vis : etad_tvs) - go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) - - -- Create a Name-TyVar mapping to bring into scope when typechecking any - -- deriving clauses this data family instance may have. - -- See Note [Associated data family instances and di_scoped_tvs]. - mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar) - mk_deriv_info_scoped_tv_pr tv = - let n = lookupWithDefaultVarEnv tv_skol_env (tyVarName tv) tv - in (n, tv) - -tcDataFamInstDecl _ _ decl - = pprPanic "tcDataFamInstDecl: This can't happen" (ppr decl) - -{- -Note [Associated data family instances and di_scoped_tvs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some care is required to implement `deriving` correctly for associated data -family instances. Consider this example from #18055: - - class C a where - data D a - - class X a b - - instance C (Maybe a) where - data D (Maybe a) deriving (X a) - -When typechecking the `X a` in `deriving (X a)`, we must ensure that the `a` -from the instance header is brought into scope. This is the role of -di_scoped_tvs, which maps from the original, renamed `a` to the skolemized, -typechecked `a`. When typechecking the `deriving` clause, this mapping will be -consulted when looking up the `a` in `X a`. - -A naïve attempt at creating the di_scoped_tvs is to simply reuse the -tyConTyVars of the representation TyCon for `data D (Maybe a)`. This is only -half correct, however. We do want the typechecked `a`'s Name in the /range/ -of the mapping, but we do not want it in the /domain/ of the mapping. -To ensure that the original `a`'s Name ends up in the domain, we consult a -TyVarEnv (passed as an argument to tcDataFamInstDecl) that maps from the -typechecked `a`'s Name to the original `a`'s Name. In the even that -tcDataFamInstDecl is processing a non-associated data family instance, this -TyVarEnv will simply be empty, and there is nothing to worry about. --} - ------------------------ -tcDataFamInstHeader - :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] - -> LexicalFixity -> LHsContext GhcRn - -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] - -> NewOrData - -> TcM ([TyVar], [Type], Kind, ThetaType) --- The "header" of a data family instance is the part other than --- the data constructors themselves --- e.g. data instance D [a] :: * -> * where ... --- Here the "header" is the bit before the "where" -tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity - hs_ctxt hs_pats m_ksig hs_cons new_or_data - = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty))) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol imp_vars $ - bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ - do { stupid_theta <- tcHsContext hs_ctxt - ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats - - -- Ensure that the instance is consistent - -- with its parent class - ; addConsistencyConstraints mb_clsinfo lhs_ty - - -- Add constraints from the result signature - ; res_kind <- tc_kind_sig m_ksig - - -- Add constraints from the data constructors - ; kcConDecls new_or_data res_kind hs_cons - - ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind - ; return (stupid_theta, lhs_ty) } - - -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts] - -- This code (and the stuff immediately above) is very similar - -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the - -- common code; but for the moment I concluded that it's - -- clearer to duplicate it. Still, if you fix a bug here, - -- check there too! - ; let scoped_tvs = imp_tvs ++ exp_tvs - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars dvs - - -- Zonk the patterns etc into the Type world - ; (ze, qtvs) <- zonkTyBndrs qtvs - -- See Note [Unifying data family kinds] about the discardCast - ; lhs_ty <- zonkTcTypeToTypeX ze (discardCast lhs_ty) - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta - - -- Check that type patterns match the class instance head - -- The call to splitTyConApp_maybe here is just an inlining of - -- the body of unravelFamInstPats. - ; pats <- case splitTyConApp_maybe lhs_ty of - Just (_, pats) -> pure pats - Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) - ; return (qtvs, pats, typeKind lhs_ty, stupid_theta) } - -- See Note [Unifying data family kinds] about why we need typeKind here - where - fam_name = tyConName fam_tc - data_ctxt = DataKindCtxt fam_name - pp_lhs = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt - exp_bndrs = mb_bndrs `orElse` [] - - -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2). - tc_kind_sig Nothing - = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; if unlifted_newtypes && new_or_data == NewType - then newOpenTypeKind - else pure liftedTypeKind - } - - -- See Note [Result kind signature for a data family instance] - tc_kind_sig (Just hs_kind) - = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind - ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind - ; lvl <- getTcLevel - ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs - -- Perhaps surprisingly, we don't need the skolemised tvs themselves - ; return (substTy subst inner_kind) } - -{- Note [Result kind signature for a data family instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expected type might have a forall at the type. Normally, we -can't skolemise in kinds because we don't have type-level lambda. -But here, we're at the top-level of an instance declaration, so -we actually have a place to put the regeneralised variables. -Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise -Examples in indexed-types/should_compile/T12369 - -Note [Unifying data family kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we kind-check a newtype instance with -XUnliftedNewtypes, we must -unify the kind of the data family with any declared kind in the instance -declaration. For example: - - data Color = Red | Blue - type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep - data family Foo (x :: Color) :: TYPE (Interpret x) - newtype instance Foo 'Red :: TYPE IntRep where - FooRedC :: Int# -> Foo 'Red - -We end up unifying `TYPE (Interpret 'Red)` (the kind of Foo, instantiated -with 'Red) and `TYPE IntRep` (the declared kind of the instance). This -unification succeeds, resulting in a coercion. The big question: what to -do with this coercion? Answer: nothing! A kind annotation on a newtype instance -is always redundant (except, perhaps, in that it helps guide unification). We -have a definitive kind for the data family from the data family declaration, -and so we learn nothing really new from the kind signature on an instance. -We still must perform this unification (done in the call to checkExpectedKind -toward the beginning of tcDataFamInstHeader), but the result is unhelpful. If there -is a cast, it will wrap the lhs_ty, and so we just drop it before splitting the -lhs_ty to reveal the underlying patterns. Because of the potential of dropping -a cast like this, we just use typeKind in the result instead of propagating res_kind -from above. - -This Note is wrinkle (3) in Note [Implementation of UnliftedNewtypes] in TcTyClsDecls. - -Note [Eta-reduction for data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data D :: * -> * -> * -> * -> * - - data instance D [(a,b)] p q :: * -> * where - D1 :: blah1 - D2 :: blah2 - -Then we'll generate a representation data type - data Drep a b p q z where - D1 :: blah1 - D2 :: blah2 - -and an axiom to connect them - axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z - -except that we'll eta-reduce the axiom to - axiom AxDrep forall a b. D [(a,b]] = Drep a b -There are several fiddly subtleties lurking here - -* The representation tycon Drep is parameerised over the free - variables of the pattern, in no particular order. So there is no - guarantee that 'p' and 'q' will come last in Drep's parameters, and - in the right order. So, if the /patterns/ of the family insatance - are eta-redcible, we re-order Drep's parameters to put the - eta-reduced type variables last. - -* Although we eta-reduce the axiom, we eta-/expand/ the representation - tycon Drep. The kind of D says it takses four arguments, but the - data instance header only supplies three. But the AlgTyCOn for Drep - itself must have enough TyConBinders so that its result kind is Type. - So, with etaExpandAlgTyCon we make up some extra TyConBinders - -* The result kind in the instance might be a polykind, like this: - data family DP a :: forall k. k -> * - data instance DP [b] :: forall k1 k2. (k1,k2) -> * - - So in type-checking the LHS (DP Int) we need to check that it is - more polymorphic than the signature. To do that we must skolemise - the siganture and istantiate the call of DP. So we end up with - data instance DP [b] @(k1,k2) (z :: (k1,k2)) where - - Note that we must parameterise the representation tycon DPrep over - 'k1' and 'k2', as well as 'b'. - - The skolemise bit is done in tc_kind_sig, while the instantiate bit - is done by tcFamTyPats. - -* Very fiddly point. When we eta-reduce to - axiom AxDrep forall a b. D [(a,b]] = Drep a b - - we want the kind of (D [(a,b)]) to be the same as the kind of - (Drep a b). This ensures that applying the axiom doesn't change the - kind. Why is that hard? Because the kind of (Drep a b) depends on - the TyConBndrVis on Drep's arguments. In particular do we have - (forall (k::*). blah) or (* -> blah)? - - We must match whatever D does! In #15817 we had - data family X a :: forall k. * -> * -- Note: a forall that is not used - data instance X Int b = MkX - - So the data instance is really - data istance X Int @k b = MkX - - The axiom will look like - axiom X Int = Xrep - - and it's important that XRep :: forall k * -> *, following X. - - To achieve this we get the TyConBndrVis flags from tcbVisibilities, - and use those flags for any eta-reduced arguments. Sigh. - -* The final turn of the knife is that tcbVisibilities is itself - tricky to sort out. Consider - data family D k :: k - Then consider D (forall k2. k2 -> k2) Type Type - The visibilty flags on an application of D may affected by the arguments - themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities - does. - --} - - -{- ********************************************************************* -* * - Class instance declarations, pass 2 -* * -********************************************************************* -} - -tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc) --- (a) From each class declaration, --- generate any default-method bindings --- (b) From each instance decl --- generate the dfun binding - -tcInstDecls2 tycl_decls inst_decls - = do { -- (a) Default methods from class decls - let class_decls = filter (isClassDecl . unLoc) tycl_decls - ; dm_binds_s <- mapM tcClassDecl2 class_decls - ; let dm_binds = unionManyBags dm_binds_s - - -- (b) instance declarations - ; let dm_ids = collectHsBindsBinders dm_binds - -- Add the default method Ids (again) - -- (they were arready added in TcTyDecls.tcAddImplicits) - -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls - - -- Done - ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } - -{- Note [Default methods in the type environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The default method Ids are already in the type environment (see Note -[Default method Ids and Template Haskell] in TcTyDcls), BUT they -don't have their InlinePragmas yet. Usually that would not matter, -because the simplifier propagates information from binding site to -use. But, unusually, when compiling instance decls we *copy* the -INLINE pragma from the default method to the method for that -particular operation (see Note [INLINE and default methods] below). - -So right here in tcInstDecls2 we must re-extend the type envt with -the default method Ids replete with their INLINE pragmas. Urk. --} - -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) - -- Returns a binding for the dfun -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ - do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id - ; dfun_ev_vars <- newEvVars dfun_theta - -- We instantiate the dfun_id with superSkolems. - -- See Note [Subtle interaction of recursion and overlap] - -- and Note [Binding when looking up instances] - - ; let (clas, inst_tys) = tcSplitDFunHead inst_head - (class_tyvars, sc_theta, _, op_items) = classBigSig clas - sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta - - ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) - - -- Deal with 'SPECIALISE instance' pragmas - -- See Note [SPECIALISE instance pragmas] - ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds - - -- Typecheck superclasses and methods - -- See Note [Typechecking plan for instance declarations] - ; dfun_ev_binds_var <- newTcEvBinds - ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) - <- pushTcLevelM $ - do { (sc_ids, sc_binds, sc_implics) - <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds - sc_theta' - - -- Typecheck the methods - ; (meth_ids, meth_binds, meth_implics) - <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds spec_inst_info - op_items ibinds - - ; return ( sc_ids ++ meth_ids - , sc_binds `unionBags` meth_binds - , sc_implics `unionBags` meth_implics ) } - - ; imp <- newImplication - ; emitImplication $ - imp { ic_tclvl = tclvl - , ic_skols = inst_tyvars - , ic_given = dfun_ev_vars - , ic_wanted = mkImplicWC sc_meth_implics - , ic_binds = dfun_ev_binds_var - , ic_info = InstSkol } - - -- Create the result bindings - ; self_dict <- newDict clas inst_tys - ; let class_tc = classTyCon clas - [dict_constr] = tyConDataCons class_tc - dict_bind = mkVarBind self_dict (L loc con_app_args) - - -- We don't produce a binding for the dict_constr; instead we - -- rely on the simplifier to unfold this saturated application - -- We do this rather than generate an HsCon directly, because - -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId - -- code rather than needing to be repeated here. - -- con_app_tys = MkD ty1 ty2 - -- con_app_scs = MkD ty1 ty2 sc1 sc2 - -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 - con_app_tys = mkHsWrap (mkWpTyApps inst_tys) - (HsConLikeOut noExtField (RealDataCon dict_constr)) - -- NB: We *can* have covars in inst_tys, in the case of - -- promoted GADT constructors. - - con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids - - app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noExtField (L loc fun) - (L loc (wrapId arg_wrapper meth_id)) - - inst_tv_tys = mkTyVarTys inst_tyvars - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys - - is_newtype = isNewTyCon class_tc - dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids - dfun_spec_prags - | is_newtype = SpecPrags [] - | otherwise = SpecPrags spec_inst_prags - -- Newtype dfuns just inline unconditionally, - -- so don't attempt to specialise them - - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = dfun_id_w_prags - , abe_mono = self_dict - , abe_prags = dfun_spec_prags } - -- NB: see Note [SPECIALISE instance pragmas] - main_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = inst_tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [] - , abs_binds = unitBag dict_bind - , abs_sig = True } - - ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) - } - where - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id - -addDFunPrags :: DFunId -> [Id] -> DFunId --- DFuns need a special Unfolding and InlinePrag --- See Note [ClassOp/DFun selection] --- and Note [Single-method classes] --- It's easiest to create those unfoldings right here, where --- have all the pieces in hand, even though we are messing with --- Core at this point, which the typechecker doesn't usually do --- However we take care to build the unfolding using the TyVars from --- the DFunId rather than from the skolem pieces that the typechecker --- is messing with. -addDFunPrags dfun_id sc_meth_ids - | is_newtype - = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app - `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args - `setInlinePragma` dfunInlinePragma - where - con_app = mkLams dfun_bndrs $ - mkApps (Var (dataConWrapId dict_con)) dict_args - -- mkApps is OK because of the checkForLevPoly call in checkValidClass - -- See Note [Levity polymorphism checking] in DsMonad - dict_args = map Type inst_tys ++ - [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] - - (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) - ev_ids = mkTemplateLocalsNum 1 dfun_theta - dfun_bndrs = dfun_tvs ++ ev_ids - clas_tc = classTyCon clas - [dict_con] = tyConDataCons clas_tc - is_newtype = isNewTyCon clas_tc - -wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id) -wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) - -{- Note [Typechecking plan for instance declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations we generate the following bindings and implication -constraints. Example: - - instance Ord a => Ord [a] where compare = - -generates this: - - Bindings: - -- Method bindings - $ccompare :: forall a. Ord a => a -> a -> Ordering - $ccompare = /\a \(d:Ord a). let in ... - - -- Superclass bindings - $cp1Ord :: forall a. Ord a => Eq [a] - $cp1Ord = /\a \(d:Ord a). let - in dfEqList (dw :: Eq a) - - Constraints: - forall a. Ord a => - -- Method constraint - (forall. (empty) => ) - -- Superclass constraint - /\ (forall. (empty) => dw :: Eq a) - -Notice that - - * Per-meth/sc implication. There is one inner implication per - superclass or method, with no skolem variables or givens. The only - reason for this one is to gather the evidence bindings privately - for this superclass or method. This implication is generated - by checkInstConstraints. - - * Overall instance implication. There is an overall enclosing - implication for the whole instance declaration, with the expected - skolems and givens. We need this to get the correct "redundant - constraint" warnings, gathering all the uses from all the methods - and superclasses. See TcSimplify Note [Tracking redundant - constraints] - - * The given constraints in the outer implication may generate - evidence, notably by superclass selection. Since the method and - superclass bindings are top-level, we want that evidence copied - into *every* method or superclass definition. (Some of it will - be usused in some, but dead-code elimination will drop it.) - - We achieve this by putting the evidence variable for the overall - instance implication into the AbsBinds for each method/superclass. - Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. - (And that in turn is why the abs_ev_binds field of AbBinds is a - [TcEvBinds] rather than simply TcEvBinds. - - This is a bit of a hack, but works very nicely in practice. - - * Note that if a method has a locally-polymorphic binding, there will - be yet another implication for that, generated by tcPolyCheck - in tcMethodBody. E.g. - class C a where - foo :: forall b. Ord b => blah - - -************************************************************************ -* * - Type-checking superclasses -* * -************************************************************************ --} - -tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds - -> TcThetaType - -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) --- Make a new top-level function binding for each superclass, --- something like --- $Ordp1 :: forall a. Ord a => Eq [a] --- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) --- --- See Note [Recursive superclasses] for why this is so hard! --- In effect, we build a special-purpose solver for the first step --- of solving each superclass constraint -tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta - = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) - ; return (ids, listToBag binds, listToBag implics) } - where - loc = getSrcSpan dfun_id - size = sizeTypes inst_tys - tc_super (sc_pred, n) - = do { (sc_implic, ev_binds_var, sc_ev_tm) - <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred - - ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) - ; sc_ev_id <- newEvVar sc_pred - ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInvForAllTys tyvars $ - mkPhiTy (map idType dfun_evs) sc_pred - sc_top_id = mkLocalId sc_top_name sc_top_ty - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = sc_top_id - , abe_mono = sc_ev_id - , abe_prags = noSpecPrags } - local_ev_binds = TcEvBinds ev_binds_var - bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = dfun_evs - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = emptyBag - , abs_sig = False } - ; return (sc_top_id, L loc bind, sc_implic) } - -------------------- -checkInstConstraints :: TcM result - -> TcM (Implication, EvBindsVar, result) --- See Note [Typechecking plan for instance declarations] -checkInstConstraints thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ - thing_inside - - ; ev_binds_var <- newTcEvBinds - ; implic <- newImplication - ; let implic' = implic { ic_tclvl = tclvl - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_info = InstSkol } - - ; return (implic', ev_binds_var, result) } - -{- -Note [Recursive superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3731, #4809, #5751, #5913, #6117, #6161, which all -describe somewhat more complicated situations, but ones -encountered in practice. - -See also tests tcrun020, tcrun021, tcrun033, and #11427. - ------ THE PROBLEM -------- -The problem is that it is all too easy to create a class whose -superclass is bottom when it should not be. - -Consider the following (extreme) situation: - class C a => D a where ... - instance D [a] => D [a] where ... (dfunD) - instance C [a] => C [a] where ... (dfunC) -Although this looks wrong (assume D [a] to prove D [a]), it is only a -more extreme case of what happens with recursive dictionaries, and it -can, just about, make sense because the methods do some work before -recursing. - -To implement the dfunD we must generate code for the superclass C [a], -which we had better not get by superclass selection from the supplied -argument: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (scsel d) .. - -Otherwise if we later encounter a situation where -we have a [Wanted] dw::D [a] we might solve it thus: - dw := dfunD dw -Which is all fine except that now ** the superclass C is bottom **! - -The instance we want is: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... - ------ THE SOLUTION -------- -The basic solution is simple: be very careful about using superclass -selection to generate a superclass witness in a dictionary function -definition. More precisely: - - Superclass Invariant: in every class dictionary, - every superclass dictionary field - is non-bottom - -To achieve the Superclass Invariant, in a dfun definition we can -generate a guaranteed-non-bottom superclass witness from: - (sc1) one of the dictionary arguments itself (all non-bottom) - (sc2) an immediate superclass of a smaller dictionary - (sc3) a call of a dfun (always returns a dictionary constructor) - -The tricky case is (sc2). We proceed by induction on the size of -the (type of) the dictionary, defined by TcValidity.sizeTypes. -Let's suppose we are building a dictionary of size 3, and -suppose the Superclass Invariant holds of smaller dictionaries. -Then if we have a smaller dictionary, its immediate superclasses -will be non-bottom by induction. - -What does "we have a smaller dictionary" mean? It might be -one of the arguments of the instance, or one of its superclasses. -Here is an example, taken from CmmExpr: - class Ord r => UserOfRegs r a where ... -(i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where -(i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - -For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a), -since it is smaller than the thing we are building (UserOfRegs r (Maybe a). - -But for (i2) that isn't the case, so we must add an explicit, and -perhaps surprising, (Ord r) argument to the instance declaration. - -Here's another example from #6161: - - class Super a => Duper a where ... - class Duper (Fam a) => Foo a where ... -(i3) instance Foo a => Duper (Fam a) where ... -(i4) instance Foo Float where ... - -It would be horribly wrong to define - dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3) - dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ... - - dfFooFloat :: Foo Float -- from (i4) - dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ... - -Now the Super superclass of Duper is definitely bottom! - -This won't happen because when processing (i3) we can use the -superclasses of (Foo a), which is smaller, namely Duper (Fam a). But -that is *not* smaller than the target so we can't take *its* -superclasses. As a result the program is rightly rejected, unless you -add (Super (Fam a)) to the context of (i3). - -Note [Solving superclass constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How do we ensure that every superclass witness is generated by -one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]. -Answer: - - * Superclass "wanted" constraints have CtOrigin of (ScOrigin size) - where 'size' is the size of the instance declaration. e.g. - class C a => D a where... - instance blah => D [a] where ... - The wanted superclass constraint for C [a] has origin - ScOrigin size, where size = size( D [a] ). - - * (sc1) When we rewrite such a wanted constraint, it retains its - origin. But if we apply an instance declaration, we can set the - origin to (ScOrigin infinity), thus lifting any restrictions by - making prohibitedSuperClassSolve return False. - - * (sc2) ScOrigin wanted constraints can't be solved from a - superclass selection, except at a smaller type. This test is - implemented by TcInteract.prohibitedSuperClassSolve - - * The "given" constraints of an instance decl have CtOrigin - GivenOrigin InstSkol. - - * When we make a superclass selection from InstSkol we use - a SkolemInfo of (InstSC size), where 'size' is the size of - the constraint whose superclass we are taking. A similarly - when taking the superclass of an InstSC. This is implemented - in TcCanonical.newSCWorkFromFlavored - -Note [Silent superclass arguments] (historical interest only) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB1: this note describes our *old* solution to the - recursive-superclass problem. I'm keeping the Note - for now, just as institutional memory. - However, the code for silent superclass arguments - was removed in late Dec 2014 - -NB2: the silent-superclass solution introduced new problems - of its own, in the form of instance overlap. Tests - SilentParametersOverlapping, T5051, and T7862 are examples - -NB3: the silent-superclass solution also generated tons of - extra dictionaries. For example, in monad-transformer - code, when constructing a Monad dictionary you had to pass - an Applicative dictionary; and to construct that you neede - a Functor dictionary. Yet these extra dictionaries were - often never used. Test T3064 compiled *far* faster after - silent superclasses were eliminated. - -Our solution to this problem "silent superclass arguments". We pass -to each dfun some ``silent superclass arguments’’, which are the -immediate superclasses of the dictionary we are trying to -construct. In our example: - dfun :: forall a. C [a] -> D [a] -> D [a] - dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... -Notice the extra (dc :: C [a]) argument compared to the previous version. - -This gives us: - - ----------------------------------------------------------- - DFun Superclass Invariant - ~~~~~~~~~~~~~~~~~~~~~~~~ - In the body of a DFun, every superclass argument to the - returned dictionary is - either * one of the arguments of the DFun, - or * constant, bound at top level - ----------------------------------------------------------- - -This net effect is that it is safe to treat a dfun application as -wrapping a dictionary constructor around its arguments (in particular, -a dfun never picks superclasses from the arguments under the -dictionary constructor). No superclass is hidden inside a dfun -application. - -The extra arguments required to satisfy the DFun Superclass Invariant -always come first, and are called the "silent" arguments. You can -find out how many silent arguments there are using Id.dfunNSilent; -and then you can just drop that number of arguments to see the ones -that were in the original instance declaration. - -DFun types are built (only) by MkId.mkDictFunId, so that is where we -decide what silent arguments are to be added. --} - -{- -************************************************************************ -* * - Type-checking an instance method -* * -************************************************************************ - -tcMethod -- Make the method bindings, as a [(NonRec, HsBinds)], one per method -- Remembering to use fresh Name (the instance method Name) as the binder -- Bring the instance method Ids into scope, for the benefit of tcInstSig -- Use sig_fn mapping instance method Name -> instance tyvars -- Ditto prag_fn -- Use tcValBinds to do the checking --} - -tcMethods :: DFunId -> Class - -> [TcTyVar] -> [EvVar] - -> [TcType] - -> TcEvBinds - -> ([Located TcSpecPrag], TcPragEnv) - -> [ClassOpItem] - -> InstBindings GhcRn - -> TcM ([Id], LHsBinds GhcTc, Bag Implication) - -- The returned inst_meth_ids all have types starting - -- forall tvs. theta => ... -tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds (spec_inst_prags, prag_fn) op_items - (InstBindings { ib_binds = binds - , ib_tyvars = lexical_tvs - , ib_pragmas = sigs - , ib_extensions = exts - , ib_derived = is_derived }) - = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $ - -- The lexical_tvs scope over the 'where' part - do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) - ; checkMinimalDefinition - ; checkMethBindMembership - ; (ids, binds, mb_implics) <- set_exts exts $ - unset_warnings_deriving $ - mapAndUnzip3M tc_item op_items - ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } - where - set_exts :: [LangExt.Extension] -> TcM a -> TcM a - set_exts es thing = foldr setXOptM thing es - - -- See Note [Avoid -Winaccessible-code when deriving] - unset_warnings_deriving :: TcM a -> TcM a - unset_warnings_deriving - | is_derived = unsetWOptM Opt_WarnInaccessibleCode - | otherwise = id - - hs_sig_fn = mkHsSigFun sigs - inst_loc = getSrcSpan dfun_id - - ---------------------- - tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) - tc_item (sel_id, dm_info) - | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn - = tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived hs_sig_fn - spec_inst_prags prags - sel_id user_bind bndr_loc - | otherwise - = do { traceTc "tc_def" (ppr sel_id) - ; tc_default sel_id dm_info } - - ---------------------- - tc_default :: Id -> DefMethInfo - -> TcM (TcId, LHsBind GhcTc, Maybe Implication) - - tc_default sel_id (Just (dm_name, _)) - = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name - ; tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived hs_sig_fn - spec_inst_prags inline_prags - sel_id meth_bind inst_loc } - - tc_default sel_id Nothing -- No default method at all - = do { traceTc "tc_def: warn" (ppr sel_id) - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - ; dflags <- getDynFlags - ; let meth_bind = mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags) - ; return (meth_id, meth_bind, Nothing) } - where - error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) - error_fun = L inst_loc $ - wrapId (mkWpTyApps - [ getRuntimeRep meth_tau, meth_tau]) - nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText - (unsafeMkByteString (error_string dflags)))) - meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) - error_string dflags = showSDoc dflags - (hcat [ppr inst_loc, vbar, ppr sel_id ]) - lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - - ---------------------- - -- Check if one of the minimal complete definitions is satisfied - checkMinimalDefinition - = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ - warnUnsatisfiedMinimalDefinition - - methodExists meth = isJust (findMethodBind meth binds prag_fn) - - ---------------------- - -- Check if any method bindings do not correspond to the class. - -- See Note [Mismatched class methods and associated type families]. - checkMethBindMembership - = mapM_ (addErrTc . badMethodErr clas) mismatched_meths - where - bind_nms = map unLoc $ collectMethodBinders binds - cls_meth_nms = map (idName . fst) op_items - mismatched_meths = bind_nms `minusList` cls_meth_nms - -{- -Note [Mismatched class methods and associated type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's entirely possible for someone to put methods or associated type family -instances inside of a class in which it doesn't belong. For instance, we'd -want to fail if someone wrote this: - - instance Eq () where - type Rep () = Maybe - compare = undefined - -Since neither the type family `Rep` nor the method `compare` belong to the -class `Eq`. Normally, this is caught in the renamer when resolving RdrNames, -since that would discover that the parent class `Eq` is incorrect. - -However, there is a scenario in which the renamer could fail to catch this: -if the instance was generated through Template Haskell, as in #12387. In that -case, Template Haskell will provide fully resolved names (e.g., -`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going -on. For this reason, we also put an extra validity check for this in the -typechecker as a last resort. - -Note [Avoid -Winaccessible-code when deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --Winaccessible-code can be particularly noisy when deriving instances for -GADTs. Consider the following example (adapted from #8128): - - data T a where - MkT1 :: Int -> T Int - MkT2 :: T Bool - MkT3 :: T Bool - deriving instance Eq (T a) - deriving instance Ord (T a) - -In the derived Ord instance, GHC will generate the following code: - - instance Ord (T a) where - compare x y - = case x of - MkT2 - -> case y of - MkT1 {} -> GT - MkT2 -> EQ - _ -> LT - ... - -However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2 -differ, so if -Winaccessible-code is enabled, then deriving this instance will -result in unwelcome warnings. - -One conceivable approach to fixing this issue would be to change `deriving Ord` -such that it becomes smarter about not generating unreachable cases. This, -however, would be a highly nontrivial refactor, as we'd have to propagate -through typing information everywhere in the algorithm that generates Ord -instances in order to determine which cases were unreachable. This seems like -a lot of work for minimal gain, so we have opted not to go for this approach. - -Instead, we take the much simpler approach of always disabling --Winaccessible-code for derived code. To accomplish this, we do the following: - -1. In tcMethods (which typechecks method bindings), disable - -Winaccessible-code. -2. When creating Implications during typechecking, record this flag - (in ic_warn_inaccessible) at the time of creation. -3. After typechecking comes error reporting, where GHC must decide how to - report inaccessible code to the user, on an Implication-by-Implication - basis. If an Implication's DynFlags indicate that -Winaccessible-code was - disabled, then don't bother reporting it. That's it! --} - ------------------------- -tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds -> Bool - -> HsSigFun - -> [LTcSpecPrag] -> [LSig GhcRn] - -> Id -> LHsBind GhcRn -> SrcSpan - -> TcM (TcId, LHsBind GhcTc, Maybe Implication) -tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived - sig_fn spec_inst_prags prags - sel_id (L bind_loc meth_bind) bndr_loc - = add_meth_ctxt $ - do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) - ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ - mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - - ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - -- taking instance signature into account might change the type of - -- the local_meth_id - ; (meth_implic, ev_binds_var, tc_bind) - <- checkInstConstraints $ - tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) - - ; global_meth_id <- addInlinePrags global_meth_id prags - ; spec_prags <- tcSpecPrags global_meth_id prags - - ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags - export = ABE { abe_ext = noExtField - , abe_poly = global_meth_id - , abe_mono = local_meth_id - , abe_wrap = idHsWrapper - , abe_prags = specs } - - local_ev_binds = TcEvBinds ev_binds_var - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = tc_bind - , abs_sig = True } - - ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } - where - -- For instance decls that come from deriving clauses - -- we want to print out the full source code if there's an error - -- because otherwise the user won't see the code at all - add_meth_ctxt thing - | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing - | otherwise = thing - -tcMethodBodyHelp :: HsSigFun -> Id -> TcId - -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId) -tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind - | Just hs_sig_ty <- hs_sig_fn sel_name - -- There is a signature in the instance - -- See Note [Instance method signatures] - = do { let ctxt = FunSigCtxt sel_name True - ; (sig_ty, hs_wrap) - <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $ - do { inst_sigs <- xoptM LangExt.InstanceSigs - ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) - ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty - ; let local_meth_ty = idType local_meth_id - ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ - tcSubType_NC ctxt sig_ty local_meth_ty - ; return (sig_ty, hs_wrap) } - - ; inner_meth_name <- newName (nameOccName sel_name) - ; let inner_meth_id = mkLocalId inner_meth_name sig_ty - inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_sig_ty) } - - - ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind - - ; let export = ABE { abe_ext = noExtField - , abe_poly = local_meth_id - , abe_mono = inner_id - , abe_wrap = hs_wrap - , abe_prags = noSpecPrags } - - ; return (unitBag $ L (getLoc meth_bind) $ - AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = [] - , abs_exports = [export] - , abs_binds = tc_bind, abs_ev_binds = [] - , abs_sig = True }) } - - | otherwise -- No instance signature - = do { let ctxt = FunSigCtxt sel_name False - -- False <=> don't report redundant constraints - -- The signature is not under the users control! - tc_sig = completeSigFromId ctxt local_meth_id - -- Absent a type sig, there are no new scoped type variables here - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = } - -- In , 'c' is scope but 'b' is not! - - ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind - ; return tc_bind } - - where - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - - ------------------------- -mkMethIds :: Class -> [TcTyVar] -> [EvVar] - -> [TcType] -> Id -> TcM (TcId, TcId) - -- returns (poly_id, local_id), but ignoring any instance signature - -- See Note [Instance method signatures] -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) - ; local_meth_name <- newName sel_occ - -- Base the local_meth_name on the selector name, because - -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty - - ; return (poly_meth_id, local_meth_id) } - where - sel_name = idName sel_id - sel_occ = nameOccName sel_name - local_meth_ty = instantiateMethod clas sel_id inst_tys - poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty - theta = map idType dfun_ev_vars - -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) -methSigCtxt sel_name sig_ty meth_ty env0 - = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty - ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) - 2 (vcat [ text "is more general than its signature in the class" - , text "Instance sig:" <+> ppr sig_ty - , text " Class sig:" <+> ppr meth_ty ]) - ; return (env2, msg) } - -misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc -misplacedInstSig name hs_ty - = vcat [ hang (text "Illegal type signature in instance declaration:") - 2 (hang (pprPrefixName name) - 2 (dcolon <+> ppr hs_ty)) - , text "(Use InstanceSigs to allow this)" ] - -{- Note [Instance method signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XInstanceSigs we allow the user to supply a signature for the -method in an instance declaration. Here is an artificial example: - - data T a = MkT a - instance Ord a => Ord (T a) where - (>) :: forall b. b -> b -> Bool - (>) = error "You can't compare Ts" - -The instance signature can be *more* polymorphic than the instantiated -class method (in this case: Age -> Age -> Bool), but it cannot be less -polymorphic. Moreover, if a signature is given, the implementation -code should match the signature, and type variables bound in the -singature should scope over the method body. - -We achieve this by building a TcSigInfo for the method, whether or not -there is an instance method signature, and using that to typecheck -the declaration (in tcMethodBody). That means, conveniently, -that the type variables bound in the signature will scope over the body. - -What about the check that the instance method signature is more -polymorphic than the instantiated class method type? We just do a -tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like -this (for the example above - - AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a] - , abs_exports - = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool - , gr_lcl :: T a -> T a -> Bool } - , abs_binds - = AbsBind { abs_tvs = [], abs_ev_vars = [] - , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool - , gr_inner :: forall b. b -> b -> Bool } - , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = [] - , ..etc.. } - } } - -Wow! Three nested AbsBinds! - * The outer one abstracts over the tyvars and dicts for the instance - * The middle one is only present if there is an instance signature, - and does the impedance matching for that signature - * The inner one is for the method binding itself against either the - signature from the class, or the instance signature. --} - ----------------------- -mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags - -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id - -- There are two sources: - -- * spec_prags_for_me: {-# SPECIALISE op :: #-} - -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} - -- These ones have the dfun inside, but [perhaps surprisingly] - -- the correct wrapper. - -- See Note [Handling SPECIALISE pragmas] in TcBinds -mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) - where - spec_prags_from_inst - | isInlinePragma (idInlinePragma meth_id) - = [] -- Do not inherit SPECIALISE from the instance if the - -- method is marked INLINE, because then it'll be inlined - -- and the specialisation would do nothing. (Indeed it'll provoke - -- a warning from the desugarer - | otherwise - = [ L inst_loc (SpecPrag meth_id wrap inl) - | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - - -mkDefMethBind :: Class -> [Type] -> Id -> Name - -> TcM (LHsBind GhcRn, [LSig GhcRn]) --- The is a default method (vanailla or generic) defined in the class --- So make a binding op = $dmop @t1 @t2 --- where $dmop is the name of the default method in the class, --- and t1,t2 are the instance types. --- See Note [Default methods in instances] for why we use --- visible type application here -mkDefMethBind clas inst_tys sel_id dm_name - = do { dflags <- getDynFlags - ; dm_id <- tcLookupId dm_name - ; let inline_prag = idInlinePragma dm_id - inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig noExtField fn inline_prag)] - | otherwise - = [] - -- Copy the inline pragma (if any) from the default method - -- to this version. Note [INLINE and default methods] - - fn = noLoc (idName sel_id) - visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys - , tyConBinderArgFlag tcb /= Inferred ] - rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys - bind = noLoc $ mkTopFunBind Generated fn $ - [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" - (vcat [ppr clas <+> ppr inst_tys, - nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - - ; return (bind, inline_prags) } - where - mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy - $ noLoc $ XHsType $ NHsCoreTy ty)) - -- NB: use visible type application - -- See Note [Default methods in instances] - ----------------------- -derivBindCtxt :: Id -> Class -> [Type ] -> SDoc -derivBindCtxt sel_id clas tys - = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) - , nest 2 (text "in a derived instance for" - <+> quotes (pprClassPred clas tys) <> colon) - , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] - -warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () -warnUnsatisfiedMinimalDefinition mindef - = do { warn <- woptM Opt_WarnMissingMethods - ; warnTc (Reason Opt_WarnMissingMethods) warn message - } - where - message = vcat [text "No explicit implementation for" - ,nest 2 $ pprBooleanFormulaNice mindef - ] - -{- -Note [Export helper functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We arrange to export the "helper functions" of an instance declaration, -so that they are not subject to preInlineUnconditionally, even if their -RHS is trivial. Reason: they are mentioned in the DFunUnfolding of -the dict fun as Ids, not as CoreExprs, so we can't substitute a -non-variable for them. - -We could change this by making DFunUnfoldings have CoreExprs, but it -seems a bit simpler this way. - -Note [Default methods in instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - - class Baz v x where - foo :: x -> x - foo y = - - instance Baz Int Int - -From the class decl we get - - $dmfoo :: forall v x. Baz v x => x -> x - $dmfoo y = - -Notice that the type is ambiguous. So we use Visible Type Application -to disambiguate: - - $dBazIntInt = MkBaz fooIntInt - fooIntInt = $dmfoo @Int @Int - -Lacking VTA we'd get ambiguity errors involving the default method. This applies -equally to vanilla default methods (#1061) and generic default methods -(#12220). - -Historical note: before we had VTA we had to generate -post-type-checked code, which took a lot more code, and didn't work for -generic default methods. - -Note [INLINE and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Default methods need special case. They are supposed to behave rather like -macros. For example - - class Foo a where - op1, op2 :: Bool -> a -> a - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - - instance Foo Int where - -- op1 via default method - op2 b x = - -The instance declaration should behave - - just as if 'op1' had been defined with the - code, and INLINE pragma, from its original - definition. - -That is, just as if you'd written - - instance Foo Int where - op2 b x = - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - -So for the above example we generate: - - {-# INLINE $dmop1 #-} - -- $dmop1 has an InlineCompulsory unfolding - $dmop1 d b x = op2 d (not b) x - - $fFooInt = MkD $cop1 $cop2 - - {-# INLINE $cop1 #-} - $cop1 = $dmop1 $fFooInt - - $cop2 = - -Note carefully: - -* We *copy* any INLINE pragma from the default method $dmop1 to the - instance $cop1. Otherwise we'll just inline the former in the - latter and stop, which isn't what the user expected - -* Regardless of its pragma, we give the default method an - unfolding with an InlineCompulsory source. That means - that it'll be inlined at every use site, notably in - each instance declaration, such as $cop1. This inlining - must happen even though - a) $dmop1 is not saturated in $cop1 - b) $cop1 itself has an INLINE pragma - - It's vital that $dmop1 *is* inlined in this way, to allow the mutual - recursion between $fooInt and $cop1 to be broken - -* To communicate the need for an InlineCompulsory to the desugarer - (which makes the Unfoldings), we use the IsDefaultMethod constructor - in TcSpecPrags. - - -************************************************************************ -* * - Specialise instance pragmas -* * -************************************************************************ - -Note [SPECIALISE instance pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance (Ix a, Ix b) => Ix (a,b) where - {-# SPECIALISE instance Ix (Int,Int) #-} - range (x,y) = ... - -We make a specialised version of the dictionary function, AND -specialised versions of each *method*. Thus we should generate -something like this: - - $dfIxPair :: (Ix a, Ix b) => Ix (a,b) - {-# DFUN [$crangePair, ...] #-} - {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} - $dfIxPair da db = Ix ($crangePair da db) (...other methods...) - - $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] - {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} - $crange da db = - -The SPECIALISE pragmas are acted upon by the desugarer, which generate - - dii :: Ix Int - dii = ... - - $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) - {-# DFUN [$crangePair di di, ...] #-} - $s$dfIxPair = Ix ($crangePair di di) (...) - - {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} - - $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] - $c$crangePair = ...specialised RHS of $crangePair... - - {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} - -Note that - - * The specialised dictionary $s$dfIxPair is very much needed, in case we - call a function that takes a dictionary, but in a context where the - specialised dictionary can be used. See #7797. - - * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because - it still has a DFunUnfolding. See Note [ClassOp/DFun selection] - - * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: - --> {ClassOp rule for range} $crangePair Int Int d1 d2 - --> {SPEC rule for $crangePair} $s$crangePair - or thus: - --> {SPEC rule for $dfIxPair} range $s$dfIxPair - --> {ClassOpRule for range} $s$crangePair - It doesn't matter which way. - - * We want to specialise the RHS of both $dfIxPair and $crangePair, - but the SAME HsWrapper will do for both! We can call tcSpecPrag - just once, and pass the result (in spec_inst_info) to tcMethods. --} - -tcSpecInstPrags :: DFunId -> InstBindings GhcRn - -> TcM ([Located TcSpecPrag], TcPragEnv) -tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ - filter isSpecInstLSig uprags - -- The filter removes the pragmas for methods - ; return (spec_inst_prags, mkPragEnv uprags binds) } - ------------------------------- -tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) - = addErrCtxt (spec_ctxt prag) $ - do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty - ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty - ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } - where - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) - -tcSpecInst _ _ = panic "tcSpecInst" - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc -instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - -instDeclCtxt2 :: Type -> SDoc -instDeclCtxt2 dfun_ty - = inst_decl_ctxt (ppr (mkClassPred cls tys)) - where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - -badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr - = text "Illegal family instance in hs-boot file" - -notFamily :: TyCon -> SDoc -notFamily tycon - = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] - -assocInClassErr :: TyCon -> SDoc -assocInClassErr name - = text "Associated type" <+> quotes (ppr name) <+> - text "must be inside a class instance" - -badFamInstDecl :: TyCon -> SDoc -badFamInstDecl tc_name - = vcat [ text "Illegal family instance for" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] - -notOpenFamily :: TyCon -> SDoc -notOpenFamily tc - = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/typecheck/TcInstDcls.hs-boot b/typecheck/TcInstDcls.hs-boot deleted file mode 100644 --- a/typecheck/TcInstDcls.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module TcInstDcls ( tcInstDecls1 ) where - -import GHC.Hs -import TcRnTypes -import TcEnv( InstInfo ) -import TcDeriv - --- We need this because of the mutual recursion --- between TcTyClsDecls and TcInstDcls -tcInstDecls1 :: [LInstDecl GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) diff --git a/typecheck/TcInteract.hs b/typecheck/TcInteract.hs deleted file mode 100644 --- a/typecheck/TcInteract.hs +++ /dev/null @@ -1,2682 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcInteract ( - solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds, -- Solves Cts - ) where - -#include "HsVersions.h" - -import GhcPrelude -import BasicTypes ( SwapFlag(..), isSwapped, - infinity, IntWithInf, intGtLimit ) -import TcCanonical -import TcFlatten -import TcUnify( canSolveByUnification ) -import VarSet -import Type -import InstEnv( DFunInstType ) -import CoAxiom( sfInteractTop, sfInteractInert ) - -import Var -import TcType -import PrelNames ( coercibleTyConKey, - heqTyConKey, eqTyConKey, ipClassKey ) -import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) -import Class -import TyCon -import FunDeps -import FamInst -import ClsInst( InstanceWhat(..), safeOverlap ) -import FamInstEnv -import Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) - -import TcEvidence -import Outputable - -import TcRnTypes -import Constraint -import Predicate -import TcOrigin -import TcSMonad -import Bag -import MonadUtils ( concatMapM, foldlM ) - -import CoreSyn -import Data.List( partition, deleteFirstsBy ) -import SrcLoc -import VarEnv - -import Control.Monad -import Maybes( isJust ) -import Pair (Pair(..)) -import Unique( hasKey ) -import DynFlags -import Util -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe - -{- -********************************************************************** -* * -* Main Interaction Solver * -* * -********************************************************************** - -Note [Basic Simplifier Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Pick an element from the WorkList if there exists one with depth - less than our context-stack depth. - -2. Run it down the 'stage' pipeline. Stages are: - - canonicalization - - inert reactions - - spontaneous reactions - - top-level intreactions - Each stage returns a StopOrContinue and may have sideffected - the inerts or worklist. - - The threading of the stages is as follows: - - If (Stop) is returned by a stage then we start again from Step 1. - - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to - the next stage in the pipeline. -4. If the element has survived (i.e. ContinueWith x) the last stage - then we add him in the inerts and jump back to Step 1. - -If in Step 1 no such element exists, we have exceeded our context-stack -depth and will simply fail. - -Note [Unflatten after solving the simple wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We unflatten after solving the wc_simples of an implication, and before attempting -to float. This means that - - * The fsk/fmv flatten-skolems only survive during solveSimples. We don't - need to worry about them across successive passes over the constraint tree. - (E.g. we don't need the old ic_fsk field of an implication. - - * When floating an equality outwards, we don't need to worry about floating its - associated flattening constraints. - - * Another tricky case becomes easy: #4935 - type instance F True a b = a - type instance F False a b = b - - [w] F c a b ~ gamma - (c ~ True) => a ~ gamma - (c ~ False) => b ~ gamma - - Obviously this is soluble with gamma := F c a b, and unflattening - will do exactly that after solving the simple constraints and before - attempting the implications. Before, when we were not unflattening, - we had to push Wanted funeqs in as new givens. Yuk! - - Another example that becomes easy: indexed_types/should_fail/T7786 - [W] BuriedUnder sub k Empty ~ fsk - [W] Intersect fsk inv ~ s - [w] xxx[1] ~ s - [W] forall[2] . (xxx[1] ~ Empty) - => Intersect (BuriedUnder sub k Empty) inv ~ Empty - -Note [Running plugins on unflattened wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is an annoying mismatch between solveSimpleGivens and -solveSimpleWanteds, because the latter needs to fiddle with the inert -set, unflatten and zonk the wanteds. It passes the zonked wanteds -to runTcPluginsWanteds, which produces a replacement set of wanteds, -some additional insolubles and a flag indicating whether to go round -the loop again. If so, prepareInertsForImplications is used to remove -the previous wanteds (which will still be in the inert set). Note -that prepareInertsForImplications will discard the insolubles, so we -must keep track of them separately. --} - -solveSimpleGivens :: [Ct] -> TcS () -solveSimpleGivens givens - | null givens -- Shortcut for common case - = return () - | otherwise - = do { traceTcS "solveSimpleGivens {" (ppr givens) - ; go givens - ; traceTcS "End solveSimpleGivens }" empty } - where - go givens = do { solveSimples (listToBag givens) - ; new_givens <- runTcPluginsGiven - ; when (notNull new_givens) $ - go new_givens } - -solveSimpleWanteds :: Cts -> TcS WantedConstraints --- NB: 'simples' may contain /derived/ equalities, floated --- out from a nested implication. So don't discard deriveds! --- The result is not necessarily zonked -solveSimpleWanteds simples - = do { traceTcS "solveSimpleWanteds {" (ppr simples) - ; dflags <- getDynFlags - ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) - ; traceTcS "solveSimpleWanteds end }" $ - vcat [ text "iterations =" <+> ppr n - , text "residual =" <+> ppr wc ] - ; return wc } - where - go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) - go n limit wc - | n `intGtLimit` limit - = failTcS (hang (text "solveSimpleWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - , text "Simples =" <+> ppr simples - , text "WC =" <+> ppr wc ])) - - | isEmptyBag (wc_simple wc) - = return (n,wc) - - | otherwise - = do { -- Solve - (unif_count, wc1) <- solve_simple_wanteds wc - - -- Run plugins - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - -- See Note [Running plugins on unflattened wanteds] - - ; if unif_count == 0 && not rerun_plugin - then return (n, wc2) -- Done - else do { traceTcS "solveSimple going round again:" $ - ppr unif_count $$ ppr rerun_plugin - ; go (n+1) limit wc2 } } -- Loop - - -solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints) --- Try solving these constraints --- Affects the unification state (of course) but not the inert set --- The result is not necessarily zonked -solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 }) - = nestTcS $ - do { solveSimples simples1 - ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts - ; (unif_count, unflattened_eqs) <- reportUnifications $ - unflattenWanteds tv_eqs fun_eqs - -- See Note [Unflatten after solving the simple wanteds] - ; return ( unif_count - , WC { wc_simple = others `andCts` unflattened_eqs - , wc_impl = implics1 `unionBags` implics2 }) } - -{- Note [The solveSimpleWanteds loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a bunch of simple constraints is done in a loop, -(the 'go' loop of 'solveSimpleWanteds'): - 1. Try to solve them; unflattening may lead to improvement that - was not exploitable during solving - 2. Try the plugin - 3. If step 1 did improvement during unflattening; or if the plugin - wants to run again, go back to step 1 - -Non-obviously, improvement can also take place during -the unflattening that takes place in step (1). See TcFlatten, -See Note [Unflattening can force the solver to iterate] --} - --- The main solver loop implements Note [Basic Simplifier Plan] ---------------------------------------------------------------- -solveSimples :: Cts -> TcS () --- Returns the final InertSet in TcS --- Has no effect on work-list or residual-implications --- The constraints are initially examined in left-to-right order - -solveSimples cts - = {-# SCC "solveSimples" #-} - do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts) - ; solve_loop } - where - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem - ; case sel of - Nothing -> return () - Just ct -> do { runSolverPipeline thePipeline ct - ; solve_loop } } - --- | Extract the (inert) givens and invoke the plugins on them. --- Remove solved givens from the inert set and emit insolubles, but --- return new work produced so that 'solveSimpleGivens' can feed it back --- into the main solver. -runTcPluginsGiven :: TcS [Ct] -runTcPluginsGiven - = do { plugins <- getTcPlugins - ; if null plugins then return [] else - do { givens <- getInertGivens - ; if null givens then return [] else - do { p <- runTcPlugins plugins (givens,[],[]) - ; let (solved_givens, _, _) = pluginSolvedCts p - insols = pluginBadCts p - ; updInertCans (removeInertCts solved_givens) - ; updInertIrreds (\irreds -> extendCtsList irreds insols) - ; return (pluginNewCts p) } } } - --- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on --- them and produce an updated bag of wanteds (possibly with some new --- work) and a bag of insolubles. The boolean indicates whether --- 'solveSimpleWanteds' should feed the updated wanteds back into the --- main solver. -runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 }) - | isEmptyBag simples1 - = return (False, wc) - | otherwise - = do { plugins <- getTcPlugins - ; if null plugins then return (False, wc) else - - do { given <- getInertGivens - ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs - ; let (wanted, derived) = partition isWantedCt (bagToList simples1) - ; p <- runTcPlugins plugins (given, derived, wanted) - ; let (_, _, solved_wanted) = pluginSolvedCts p - (_, unsolved_derived, unsolved_wanted) = pluginInputCts p - new_wanted = pluginNewCts p - insols = pluginBadCts p - --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) - - ; mapM_ setEv solved_wanted - ; return ( notNull (pluginNewCts p) - , WC { wc_simple = listToBag new_wanted `andCts` - listToBag unsolved_wanted `andCts` - listToBag unsolved_derived `andCts` - listToBag insols - , wc_impl = implics1 } ) } } - where - setEv :: (EvTerm,Ct) -> TcS () - setEv (ev,ct) = case ctEvidence ct of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev - _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" - --- | A triple of (given, derived, wanted) constraints to pass to plugins -type SplitCts = ([Ct], [Ct], [Ct]) - --- | A solved triple of constraints, with evidence for wanteds -type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)]) - --- | Represents collections of constraints generated by typechecker --- plugins -data TcPluginProgress = TcPluginProgress - { pluginInputCts :: SplitCts - -- ^ Original inputs to the plugins with solved/bad constraints - -- removed, but otherwise unmodified - , pluginSolvedCts :: SolvedCts - -- ^ Constraints solved by plugins - , pluginBadCts :: [Ct] - -- ^ Constraints reported as insoluble by plugins - , pluginNewCts :: [Ct] - -- ^ New constraints emitted by plugins - } - -getTcPlugins :: TcS [TcPluginSolver] -getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) } - --- | Starting from a triple of (given, derived, wanted) constraints, --- invoke each of the typechecker plugins in turn and return --- --- * the remaining unmodified constraints, --- * constraints that have been solved, --- * constraints that are insoluble, and --- * new work. --- --- Note that new work generated by one plugin will not be seen by --- other plugins on this pass (but the main constraint solver will be --- re-invoked and they will see it later). There is no check that new --- work differs from the original constraints supplied to the plugin: --- the plugin itself should perform this check if necessary. -runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress -runTcPlugins plugins all_cts - = foldM do_plugin initialProgress plugins - where - do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress - do_plugin p solver = do - result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) - return $ progress p result - - progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress - progress p (TcPluginContradiction bad_cts) = - p { pluginInputCts = discard bad_cts (pluginInputCts p) - , pluginBadCts = bad_cts ++ pluginBadCts p - } - progress p (TcPluginOk solved_cts new_cts) = - p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p) - , pluginSolvedCts = add solved_cts (pluginSolvedCts p) - , pluginNewCts = new_cts ++ pluginNewCts p - } - - initialProgress = TcPluginProgress all_cts ([], [], []) [] [] - - discard :: [Ct] -> SplitCts -> SplitCts - discard cts (xs, ys, zs) = - (xs `without` cts, ys `without` cts, zs `without` cts) - - without :: [Ct] -> [Ct] -> [Ct] - without = deleteFirstsBy eqCt - - eqCt :: Ct -> Ct -> Bool - eqCt c c' = ctFlavour c == ctFlavour c' - && ctPred c `tcEqType` ctPred c' - - add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts - add xs scs = foldl' addOne scs xs - - addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts - addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of - CtGiven {} -> (ct:givens, deriveds, wanteds) - CtDerived{} -> (givens, ct:deriveds, wanteds) - CtWanted {} -> (givens, deriveds, (ev,ct):wanteds) - - -type WorkItem = Ct -type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) - -runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline - -> WorkItem -- The work item - -> TcS () --- Run this item down the pipeline, leaving behind new work and inerts -runSolverPipeline pipeline workItem - = do { wl <- getWorkList - ; inerts <- getTcSInerts - ; tclevel <- getTcLevel - ; traceTcS "----------------------------- " empty - ; traceTcS "Start solver pipeline {" $ - vcat [ text "tclevel =" <+> ppr tclevel - , text "work item =" <+> ppr workItem - , text "inerts =" <+> ppr inerts - , text "rest of worklist =" <+> ppr wl ] - - ; bumpStepCountTcS -- One step for each constraint processed - ; final_res <- run_pipeline pipeline (ContinueWith workItem) - - ; case final_res of - Stop ev s -> do { traceFireTcS ev s - ; traceTcS "End solver pipeline (discharged) }" empty - ; return () } - ContinueWith ct -> do { addInertCan ct - ; traceFireTcS (ctEvidence ct) (text "Kept as inert") - ; traceTcS "End solver pipeline (kept as inert) }" $ - (text "final_item =" <+> ppr ct) } - } - where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct - -> TcS (StopOrContinue Ct) - run_pipeline [] res = return res - run_pipeline _ (Stop ev s) = return (Stop ev s) - run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) - = do { traceTcS ("runStage " ++ stg_name ++ " {") - (text "workitem = " <+> ppr ct) - ; res <- stg ct - ; traceTcS ("end stage " ++ stg_name ++ " }") empty - ; run_pipeline stgs res } - -{- -Example 1: - Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) - Reagent: a ~ [b] (given) - -React with (c~d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t] -React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True [] - -Example 2: - Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty} - Reagent: a ~w [b] - -React with (c ~w d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!) -etc. - -Example 3: - Inert: {a ~ Int, F Int ~ b} (given) - Reagent: F a ~ b (wanted) - -React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] -React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing --} - -thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("canonicalization", TcCanonical.canonicalize) - , ("interact with inerts", interactWithInertsStage) - , ("top-level reactions", topReactionsStage) ] - -{- -********************************************************************************* -* * - The interact-with-inert Stage -* * -********************************************************************************* - -Note [The Solver Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We always add Givens first. So you might think that the solver has -the invariant - - If the work-item is Given, - then the inert item must Given - -But this isn't quite true. Suppose we have, - c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int -After processing the first two, we get - c1: [G] beta ~ [alpha], c2 : [W] blah -Now, c3 does not interact with the given c1, so when we spontaneously -solve c3, we must re-react it with the inert set. So we can attempt a -reaction between inert c2 [W] and work-item c3 [G]. - -It *is* true that [Solver Invariant] - If the work-item is Given, - AND there is a reaction - then the inert item must Given -or, equivalently, - If the work-item is Given, - and the inert item is Wanted/Derived - then there is no reaction --} - --- Interaction result of WorkItem <~> Ct - -interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) --- Precondition: if the workitem is a CTyEqCan then it will not be able to --- react with anything at this stage. - -interactWithInertsStage wi - = do { inerts <- getTcSInerts - ; let ics = inert_cans inerts - ; case wi of - CTyEqCan {} -> interactTyVarEq ics wi - CFunEqCan {} -> interactFunEq ics wi - CIrredCan {} -> interactIrred ics wi - CDictCan {} -> interactDict ics wi - _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CHoleCan are put straight into inert_frozen, so never get here - -- CNonCanonical have been canonicalised - -data InteractResult - = KeepInert -- Keep the inert item, and solve the work item from it - -- (if the latter is Wanted; just discard it if not) - | KeepWork -- Keep the work item, and solve the intert item from it - -instance Outputable InteractResult where - ppr KeepInert = text "keep inert" - ppr KeepWork = text "keep work-item" - -solveOneFromTheOther :: CtEvidence -- Inert - -> CtEvidence -- WorkItem - -> TcS InteractResult --- Precondition: --- * inert and work item represent evidence for the /same/ predicate --- --- We can always solve one from the other: even if both are wanted, --- although we don't rewrite wanteds with wanteds, we can combine --- two wanteds into one by solving one from the other - -solveOneFromTheOther ev_i ev_w - | isDerived ev_w -- Work item is Derived; just discard it - = return KeepInert - - | isDerived ev_i -- The inert item is Derived, we can just throw it away, - = return KeepWork -- The ev_w is inert wrt earlier inert-set items, - -- so it's safe to continue on from this point - - | CtWanted { ctev_loc = loc_w } <- ev_w - , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w - = -- inert must be Given - do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) - ; return KeepWork } - - | CtWanted {} <- ev_w - -- Inert is Given or Wanted - = return KeepInert - - -- From here on the work-item is Given - - | CtWanted { ctev_loc = loc_i } <- ev_i - , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i - = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w) - ; return KeepInert } -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first - - | CtWanted {} <- ev_i - = return KeepWork - - -- From here on both are Given - -- See Note [Replacement vs keeping] - - | lvl_i == lvl_w - = do { ev_binds_var <- getTcEvBindsVar - ; binds <- getTcEvBindsMap ev_binds_var - ; return (same_level_strategy binds) } - - | otherwise -- Both are Given, levels differ - = return different_level_strategy - where - pred = ctEvPred ev_i - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w - ev_id_i = ctEvEvId ev_i - ev_id_w = ctEvEvId ev_w - - different_level_strategy -- Both Given - | isIPPred pred = if lvl_w > lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork - -- See Note [Replacement vs keeping] (the different-level bullet) - -- For the isIPPred case see Note [Shadowing of Implicit Parameters] - - same_level_strategy binds -- Both Given - | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i - = case ctLocOrigin loc_w of - GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork - | otherwise -> KeepInert - _ -> KeepWork - - | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w - = KeepInert - - | has_binding binds ev_id_w - , not (has_binding binds ev_id_i) - , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w)) - = KeepWork - - | otherwise - = KeepInert - - has_binding binds ev_id = isJust (lookupEvBind binds ev_id) - -{- -Note [Replacement vs keeping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have two Given constraints both of type (C tys), say, which should -we keep? More subtle than you might think! - - * Constraints come from different levels (different_level_strategy) - - - For implicit parameters we want to keep the innermost (deepest) - one, so that it overrides the outer one. - See Note [Shadowing of Implicit Parameters] - - - For everything else, we want to keep the outermost one. Reason: that - makes it more likely that the inner one will turn out to be unused, - and can be reported as redundant. See Note [Tracking redundant constraints] - in TcSimplify. - - It transpires that using the outermost one is reponsible for an - 8% performance improvement in nofib cryptarithm2, compared to - just rolling the dice. I didn't investigate why. - - * Constraints coming from the same level (i.e. same implication) - - (a) Always get rid of InstSC ones if possible, since they are less - useful for solving. If both are InstSC, choose the one with - the smallest TypeSize - See Note [Solving superclass constraints] in TcInstDcls - - (b) Keep the one that has a non-trivial evidence binding. - Example: f :: (Eq a, Ord a) => blah - then we may find [G] d3 :: Eq a - [G] d2 :: Eq a - with bindings d3 = sc_sel (d1::Ord a) - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. - Why? See Note [Tracking redundant constraints] in TcSimplify again. - - (c) But don't do (b) if the evidence binding depends transitively on the - one without a binding. Example (with RecursiveSuperClasses) - class C a => D a - class D a => C a - Inert: d1 :: C a, d2 :: D a - Binds: d3 = sc_sel d2, d2 = sc_sel d1 - Work item: d3 :: C a - Then it'd be ridiculous to replace d1 with d3 in the inert set! - Hence the findNeedEvVars test. See #14774. - - * Finally, when there is still a choice, use KeepInert rather than - KeepWork, for two reasons: - - to avoid unnecessary munging of the inert set. - - to cut off superclass loops; see Note [Superclass loops] in TcCanonical - -Doing the depth-check for implicit parameters, rather than making the work item -always override, is important. Consider - - data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } - - f :: (?x::a) => T a -> Int - f T1 = ?x - f T2 = 3 - -We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add -two new givens in the work-list: [G] (?x::Int) - [G] (a ~ Int) -Now consider these steps - - process a~Int, kicking out (?x::a) - - process (?x::Int), the inner given, adding to inert set - - process (?x::a), the outer given, overriding the inner given -Wrong! The depth-check ensures that the inner implicit parameter wins. -(Actually I think that the order in which the work-list is processed means -that this chain of events won't happen, but that's very fragile.) - -********************************************************************************* -* * - interactIrred -* * -********************************************************************************* - -Note [Multiple matching irreds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that it's impossible to have multiple irreds all match the -work item; after all, interactIrred looks for matches and solves one from the -other. However, note that interacting insoluble, non-droppable irreds does not -do this matching. We thus might end up with several insoluble, non-droppable, -matching irreds in the inert set. When another irred comes along that we have -not yet labeled insoluble, we can find multiple matches. These multiple matches -cause no harm, but it would be wrong to ASSERT that they aren't there (as we -once had done). This problem can be tickled by typecheck/should_compile/holes. - --} - --- Two pieces of irreducible evidence: if their types are *exactly identical* --- we can rewrite them. We can never improve using this: --- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not --- mean that (ty1 ~ ty2) -interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) - -interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble }) - | insoluble -- For insolubles, don't allow the constaint to be dropped - -- which can happen with solveOneFromTheOther, so that - -- we get distinct error messages with -fdefer-type-errors - -- See Note [Do not add duplicate derived insolubles] - , not (isDroppableCt workItem) - = continueWith workItem - - | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w - , ((ct_i, swap) : _rest) <- bagToList matching_irreds - -- See Note [Multiple matching irreds] - , let ev_i = ctEvidence ct_i - = do { what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) - ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } - KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) - ; updInertIrreds (\_ -> others) - ; continueWith workItem } } - - | otherwise - = continueWith workItem - - where - swap_me :: SwapFlag -> CtEvidence -> EvTerm - swap_me swap ev - = case swap of - NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev))) - -interactIrred _ wi = pprPanic "interactIrred" (ppr wi) - -findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct) -findMatchingIrreds irreds ev - | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred - -- See Note [Solving irreducible equalities] - = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds - | otherwise - = partitionBagWith match_non_eq irreds - where - pred = ctEvPred ev - match_non_eq ct - | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped) - | otherwise = Right ct - - match_eq eq_rel1 lty1 rty1 ct - | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct) - , eq_rel1 == eq_rel2 - , Just swap <- match_eq_help lty1 rty1 lty2 rty2 - = Left (ct, swap) - | otherwise - = Right ct - - match_eq_help lty1 rty1 lty2 rty2 - | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2 - = Just NotSwapped - | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2 - = Just IsSwapped - | otherwise - = Nothing - -{- Note [Solving irreducible equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14333) - [G] a b ~R# c d - [W] c d ~R# a b -Clearly we should be able to solve this! Even though the constraints are -not decomposable. We solve this when looking up the work-item in the -irreducible constraints to look for an identical one. When doing this -lookup, findMatchingIrreds spots the equality case, and matches either -way around. It has to return a swap-flag so we can generate evidence -that is the right way round too. - -Note [Do not add duplicate derived insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *must* add an insoluble (Int ~ Bool) even if there is -one such there already, because they may come from distinct call -sites. Not only do we want an error message for each, but with --fdefer-type-errors we must generate evidence for each. But for -*derived* insolubles, we only want to report each one once. Why? - -(a) A constraint (C r s t) where r -> s, say, may generate the same fundep - equality many times, as the original constraint is successively rewritten. - -(b) Ditto the successive iterations of the main solver itself, as it traverses - the constraint tree. See example below. - -Also for *given* insolubles we may get repeated errors, as we -repeatedly traverse the constraint tree. These are relatively rare -anyway, so removing duplicates seems ok. (Alternatively we could take -the SrcLoc into account.) - -Note that the test does not need to be particularly efficient because -it is only used if the program has a type error anyway. - -Example of (b): assume a top-level class and instance declaration: - - class D a b | a -> b - instance D [a] [a] - -Assume we have started with an implication: - - forall c. Eq c => { wc_simple = D [c] c [W] } - -which we have simplified to: - - forall c. Eq c => { wc_simple = D [c] c [W] - (c ~ [c]) [D] } - -For some reason, e.g. because we floated an equality somewhere else, -we might try to re-solve this implication. If we do not do a -dropDerivedWC, then we will end up trying to solve the following -constraints the second time: - - (D [c] c) [W] - (c ~ [c]) [D] - -which will result in two Deriveds to end up in the insoluble set: - - wc_simple = D [c] c [W] - (c ~ [c]) [D], (c ~ [c]) [D] --} - -{- -********************************************************************************* -* * - interactDict -* * -********************************************************************************* - -Note [Shortcut solving] -~~~~~~~~~~~~~~~~~~~~~~~ -When we interact a [W] constraint with a [G] constraint that solves it, there is -a possibility that we could produce better code if instead we solved from a -top-level instance declaration (See #12791, #5835). For example: - - class M a b where m :: a -> b - - type C a b = (Num a, M a b) - - f :: C Int b => b -> Int -> Int - f _ x = x + 1 - -The body of `f` requires a [W] `Num Int` instance. We could solve this -constraint from the givens because we have `C Int b` and that provides us a -solution for `Num Int`. This would let us produce core like the following -(with -O2): - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> - + @ Int - (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) - eta1 - A.f1 - -This is bad! We could do /much/ better if we solved [W] `Num Int` directly -from the instance that we have in scope: - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) _ _ (x :: Int) -> - case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } - -** NB: It is important to emphasize that all this is purely an optimization: -** exactly the same programs should typecheck with or without this -** procedure. - -Solving fully -~~~~~~~~~~~~~ -There is a reason why the solver does not simply try to solve such -constraints with top-level instances. If the solver finds a relevant -instance declaration in scope, that instance may require a context -that can't be solved for. A good example of this is: - - f :: Ord [a] => ... - f x = ..Need Eq [a]... - -If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would -be left with the obligation to solve the constraint Eq a, which we cannot. So we -must be conservative in our attempt to use an instance declaration to solve the -[W] constraint we're interested in. - -Our rule is that we try to solve all of the instance's subgoals -recursively all at once. Precisely: We only attempt to solve -constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci -are themselves class constraints of the form `C1', ... Cm' => C' t1' -... tn'` and we only succeed if the entire tree of constraints is -solvable from instances. - -An example that succeeds: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [Int] b => b -> Bool - f x = m x == [] - -We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This -produces the following core: - - f :: forall b. C [Int] b => b -> Bool - f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> - GHC.Classes.$fEq[]_$s$c== - (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) - -An example that fails: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [a] b => b -> Bool - f x = m x == [] - -Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: - - f :: forall a b. C [a] b => b -> Bool - f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> - == - @ [a] - (A.$p1C @ [a] @ b $dC) - (m @ [a] @ b $dC eta) - (GHC.Types.[] @ a) - -Note [Shortcut solving: type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (#13943) - class Take (n :: Nat) where ... - instance {-# OVERLAPPING #-} Take 0 where .. - instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. - -And we have [W] Take 3. That only matches one instance so we get -[W] Take (3-1). Really we should now flatten to reduce the (3-1) to 2, and -so on -- but that is reproducing yet more of the solver. Sigh. For now, -we just give up (remember all this is just an optimisation). - -But we must not just naively try to lookup (Take (3-1)) in the -InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a -unique match on the (Take n) instance. That leads immediately to an -infinite loop. Hence the check that 'preds' have no type families -(isTyFamFree). - -Note [Shortcut solving: incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This optimization relies on coherence of dictionaries to be correct. When we -cannot assume coherence because of IncoherentInstances then this optimization -can change the behavior of the user's code. - -The following four modules produce a program whose output would change depending -on whether we apply this optimization when IncoherentInstances is in effect: - -######### - {-# LANGUAGE MultiParamTypeClasses #-} - module A where - - class A a where - int :: a -> Int - - class A a => C a b where - m :: b -> a -> a - -######### - {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} - module B where - - import A - - instance A a where - int _ = 1 - - instance C a [b] where - m _ = id - -######### - {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} - {-# LANGUAGE IncoherentInstances #-} - module C where - - import A - - instance A Int where - int _ = 2 - - instance C Int [Int] where - m _ = id - - intC :: C Int a => a -> Int -> Int - intC _ x = int x - -######### - module Main where - - import A - import B - import C - - main :: IO () - main = print (intC [] (0::Int)) - -The output of `main` if we avoid the optimization under the effect of -IncoherentInstances is `1`. If we were to do the optimization, the output of -`main` would be `2`. - -Note [Shortcut try_solve_from_instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The workhorse of the short-cut solver is - try_solve_from_instance :: (EvBindMap, DictMap CtEvidence) - -> CtEvidence -- Solve this - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) -Note that: - -* The CtEvidence is the goal to be solved - -* The MaybeT anages early failure if we find a subgoal that - cannot be solved from instances. - -* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional - state that allows try_solve_from_instance to augmennt the evidence - bindings and inert_solved_dicts as it goes. - - If it succeeds, we commit all these bindings and solved dicts to the - main TcS InertSet. If not, we abandon it all entirely. - -Passing along the solved_dicts important for two reasons: - -* We need to be able to handle recursive super classes. The - solved_dicts state ensures that we remember what we have already - tried to solve to avoid looping. - -* As #15164 showed, it can be important to exploit sharing between - goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; - and to solve G2 we may need H. If we don't spot this sharing we may - solve H twice; and if this pattern repeats we may get exponentially bad - behaviour. --} - -interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys - = -- There is a matching dictionary in the inert set - do { -- First to try to solve it /completely/ from top level instances - -- See Note [Shortcut solving] - dflags <- getDynFlags - ; short_cut_worked <- shortCutSolver dflags ev_w ev_i - ; if short_cut_worked - then stopWith ev_w "interactDict/solved from instance" - else - - do { -- Ths short-cut solver didn't fire, so we - -- solve ev_w from the matching inert ev_i we found - what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "lookupInertDict" (ppr what_next) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } - KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) - ; updInertDicts $ \ ds -> delDict ds cls tys - ; continueWith workItem } } } - - | cls `hasKey` ipClassKey - , isGiven ev_w - = interactGivenIP inerts workItem - - | otherwise - = do { addFunDepWork inerts ev_w cls - ; continueWith workItem } - -interactDict _ wi = pprPanic "interactDict" (ppr wi) - --- See Note [Shortcut solving] -shortCutSolver :: DynFlags - -> CtEvidence -- Work item - -> CtEvidence -- Inert we want to try to replace - -> TcS Bool -- True <=> success -shortCutSolver dflags ev_w ev_i - | isWanted ev_w - && isGiven ev_i - -- We are about to solve a [W] constraint from a [G] constraint. We take - -- a moment to see if we can get a better solution using an instance. - -- Note that we only do this for the sake of performance. Exactly the same - -- programs should typecheck regardless of whether we take this step or - -- not. See Note [Shortcut solving] - - && not (xopt LangExt.IncoherentInstances dflags) - -- If IncoherentInstances is on then we cannot rely on coherence of proofs - -- in order to justify this optimization: The proof provided by the - -- [G] constraint's superclass may be different from the top-level proof. - -- See Note [Shortcut solving: incoherence] - - && gopt Opt_SolveConstantDicts dflags - -- Enabled by the -fsolve-constant-dicts flag - = do { ev_binds_var <- getTcEvBindsVar - ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w ) - getTcEvBindsMap ev_binds_var - ; solved_dicts <- getSolvedDicts - - ; mb_stuff <- runMaybeT $ try_solve_from_instance - (ev_binds, solved_dicts) ev_w - - ; case mb_stuff of - Nothing -> return False - Just (ev_binds', solved_dicts') - -> do { setTcEvBindsMap ev_binds_var ev_binds' - ; setSolvedDicts solved_dicts' - ; return True } } - - | otherwise - = return False - where - -- This `CtLoc` is used only to check the well-staged condition of any - -- candidate DFun. Our subgoals all have the same stage as our root - -- [W] constraint so it is safe to use this while solving them. - loc_w = ctEvLoc ev_w - - try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] - :: (EvBindMap, DictMap CtEvidence) -> CtEvidence - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) - try_solve_from_instance (ev_binds, solved_dicts) ev - | let pred = ctEvPred ev - loc = ctEvLoc ev - , ClassPred cls tys <- classifyPredType pred - = do { inst_res <- lift $ matchGlobalInst dflags True cls tys - ; case inst_res of - OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = what } - | safeOverlap what - , all isTyFamFree preds -- Note [Shortcut solving: type families] - -> do { let solved_dicts' = addDict solved_dicts cls tys ev - -- solved_dicts': it is important that we add our goal - -- to the cache before we solve! Otherwise we may end - -- up in a loop while solving recursive dictionaries. - - ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) - ; loc' <- lift $ checkInstanceOK loc what pred - - ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds - -- Emit work for subgoals but use our local cache - -- so we can solve recursive dictionaries. - - ; let ev_tm = mk_ev (map getEvExpr evc_vs) - ev_binds' = extendEvBinds ev_binds $ - mkWantedEvBind (ctEvEvId ev) ev_tm - - ; foldlM try_solve_from_instance - (ev_binds', solved_dicts') - (freshGoals evc_vs) } - - _ -> mzero } - | otherwise = mzero - - - -- Use a local cache of solved dicts while emitting EvVars for new work - -- We bail out of the entire computation if we need to emit an EvVar for - -- a subgoal that isn't a ClassPred. - new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached loc cache pty - | ClassPred cls tys <- classifyPredType pty - = lift $ case findDict cache loc_w cls tys of - Just ctev -> return $ Cached (ctEvExpr ctev) - Nothing -> Fresh <$> newWantedNC loc pty - | otherwise = mzero - -addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () --- Add derived constraints from type-class functional dependencies. -addFunDepWork inerts work_ev cls - | isImprovable work_ev - = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) - -- No need to check flavour; fundeps work between - -- any pair of constraints, regardless of flavour - -- Importantly we don't throw workitem back in the - -- worklist because this can cause loops (see #5236) - | otherwise - = return () - where - work_pred = ctEvPred work_ev - work_loc = ctEvLoc work_ev - - add_fds inert_ct - | isImprovable inert_ev - = do { traceTcS "addFunDepWork" (vcat - [ ppr work_ev - , pprCtLoc work_loc, ppr (isGivenLoc work_loc) - , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) - , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ; - - emitFunDepDeriveds $ - improveFromAnother derived_loc inert_pred work_pred - -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok - -- NB: We do create FDs for given to report insoluble equations that arise - -- from pairs of Givens, and also because of floating when we approximate - -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs - } - | otherwise - = return () - where - inert_ev = ctEvidence inert_ct - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` - ctl_depth inert_loc - , ctl_origin = FunDepOrigin1 work_pred - (ctLocOrigin work_loc) - (ctLocSpan work_loc) - inert_pred - (ctLocOrigin inert_loc) - (ctLocSpan inert_loc) } - -{- -********************************************************************** -* * - Implicit parameters -* * -********************************************************************** --} - -interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Work item is Given (?x:ty) --- See Note [Shadowing of Implicit Parameters] -interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = tys@(ip_str:_) }) - = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } - ; stopWith ev "Given IP" } - where - dicts = inert_dicts inerts - ip_dicts = findDictsByClass dicts cls - other_ip_dicts = filterBag (not . is_this_ip) ip_dicts - filtered_dicts = addDictsByClass dicts cls other_ip_dicts - - -- Pick out any Given constraints for the same implicit parameter - is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ }) - = isGiven ev && ip_str `tcEqType` ip_str' - is_this_ip _ = False - -interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) - -{- Note [Shadowing of Implicit Parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - -f :: (?x :: Char) => Char -f = let ?x = 'a' in ?x - -The "let ?x = ..." generates an implication constraint of the form: - -?x :: Char => ?x :: Char - -Furthermore, the signature for `f` also generates an implication -constraint, so we end up with the following nested implication: - -?x :: Char => (?x :: Char => ?x :: Char) - -Note that the wanted (?x :: Char) constraint may be solved in -two incompatible ways: either by using the parameter from the -signature, or by using the local definition. Our intention is -that the local definition should "shadow" the parameter of the -signature, and we implement this as follows: when we add a new -*given* implicit parameter to the inert set, it replaces any existing -givens for the same implicit parameter. - -Similarly, consider - f :: (?x::a) => Bool -> a - - g v = let ?x::Int = 3 - in (f v, let ?x::Bool = True in f v) - -This should probably be well typed, with - g :: Bool -> (Int, Bool) - -So the inner binding for ?x::Bool *overrides* the outer one. - -See ticket #17104 for a rather tricky example of this overriding -behaviour. - -All this works for the normal cases but it has an odd side effect in -some pathological programs like this: --- This is accepted, the second parameter shadows -f1 :: (?x :: Int, ?x :: Char) => Char -f1 = ?x - --- This is rejected, the second parameter shadows -f2 :: (?x :: Int, ?x :: Char) => Int -f2 = ?x - -Both of these are actually wrong: when we try to use either one, -we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), -which would lead to an error. - -I can think of two ways to fix this: - - 1. Simply disallow multiple constraints for the same implicit - parameter---this is never useful, and it can be detected completely - syntactically. - - 2. Move the shadowing machinery to the location where we nest - implications, and add some code here that will produce an - error if we get multiple givens for the same implicit parameter. - - -********************************************************************** -* * - interactFunEq -* * -********************************************************************** --} - -interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Try interacting the work item with the inert set -interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc - , cc_tyargs = args, cc_fsk = fsk }) - | Just inert_ct@(CFunEqCan { cc_ev = ev_i - , cc_fsk = fsk_i }) - <- findFunEq (inert_funeqs inerts) tc args - , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev - = do { traceTcS "reactFunEq (rewrite inert item):" $ - vcat [ text "work_item =" <+> ppr work_item - , text "inertItem=" <+> ppr ev_i - , text "(swap_flag, upgrade)" <+> ppr pr ] - ; if isSwapped swap_flag - then do { -- Rewrite inert using work-item - let work_item' | upgrade_flag = upgradeWanted work_item - | otherwise = work_item - ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item' - -- Do the updInertFunEqs before the reactFunEq, so that - -- we don't kick out the inertItem as well as consuming it! - ; reactFunEq ev fsk ev_i fsk_i - ; stopWith ev "Work item rewrites inert" } - else do { -- Rewrite work-item using inert - ; when upgrade_flag $ - updInertFunEqs $ \ feqs -> insertFunEq feqs tc args - (upgradeWanted inert_ct) - ; reactFunEq ev_i fsk_i ev fsk - ; stopWith ev "Inert rewrites work item" } } - - | otherwise -- Try improvement - = do { improveLocalFunEqs ev inerts tc args fsk - ; continueWith work_item } - -interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item) - -upgradeWanted :: Ct -> Ct --- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2 --- so upgrade the [W] to [WD] before putting it in the inert set -upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) } - where - upgrade_ev ev = ASSERT2( isWanted ev, ppr ct ) - ev { ctev_nosh = WDeriv } - -improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar - -> TcS () --- Generate derived improvement equalities, by comparing --- the current work item with inert CFunEqs --- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' --- --- See Note [FunDep and implicit parameter reactions] -improveLocalFunEqs work_ev inerts fam_tc args fsk - | isGiven work_ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable work_ev) - = return () - - | otherwise - = do { eqns <- improvement_eqns - ; if not (null eqns) - then do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr eqns - , text "Candidates:" <+> ppr funeqs_for_tc - , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] - ; emitFunDepDeriveds eqns } - else return () } - - where - funeqs = inert_funeqs inerts - funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc - work_loc = ctEvLoc work_ev - work_pred = ctEvPred work_ev - fam_inj_info = tyConInjectivityInfo fam_tc - - -------------------- - improvement_eqns :: TcS [FunDepEqn CtLoc] - improvement_eqns - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = -- Try built-in families, notably for arithmethic - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc } - - | Injective injective_args <- fam_inj_info - = -- Try improvement from type families with injectivity annotations - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc } - - | otherwise - = return [] - - -------------------- - do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev }) - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) } - - do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) - - -------------------- - -- See Note [Type inference for type families with injectivity] - do_one_injective inj_args rhs (CFunEqCan { cc_tyargs = inert_args - , cc_fsk = ifsk, cc_ev = inert_ev }) - | isImprovable inert_ev - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ if rhs `tcEqType` inert_rhs - then mk_fd_eqns inert_ev $ - [ Pair arg iarg - | (arg, iarg, True) <- zip3 args inert_args inj_args ] - else [] } - | otherwise - = return [] - - do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) - - -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc] - mk_fd_eqns inert_ev eqns - | null eqns = [] - | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns - , fd_pred1 = work_pred - , fd_pred2 = ctEvPred inert_ev - , fd_loc = loc } ] - where - inert_loc = ctEvLoc inert_ev - loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } - -------------- -reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 - -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 - -> TcS () -reactFunEq from_this fsk1 solve_this fsk2 - = do { traceTcS "reactFunEq" - (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2]) - ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) - ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ - ppr solve_this $$ ppr fsk2) } - -{- Note [Type inference for type families with injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a type family with an injectivity annotation: - type family F a b = r | r -> b - -Then if we have two CFunEqCan constraints for F with the same RHS - F s1 t1 ~ rhs - F s2 t2 ~ rhs -then we can use the injectivity to get a new Derived constraint on -the injective argument - [D] t1 ~ t2 - -That in turn can help GHC solve constraints that would otherwise require -guessing. For example, consider the ambiguity check for - f :: F Int b -> Int -We get the constraint - [W] F Int b ~ F Int beta -where beta is a unification variable. Injectivity lets us pick beta ~ b. - -Injectivity information is also used at the call sites. For example: - g = f True -gives rise to - [W] F Int b ~ Bool -from which we can derive b. This requires looking at the defining equations of -a type family, ie. finding equation with a matching RHS (Bool in this example) -and infering values of type variables (b in this example) from the LHS patterns -of the matching equation. For closed type families we have to perform -additional apartness check for the selected equation to check that the selected -is guaranteed to fire for given LHS arguments. - -These new constraints are simply *Derived* constraints; they have no evidence. -We could go further and offer evidence from decomposing injective type-function -applications, but that would require new evidence forms, and an extension to -FC, so we don't do that right now (Dec 14). - -See also Note [Injective type families] in TyCon - - -Note [Cache-caused loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very dangerous to cache a rewritten wanted family equation as 'solved' in our -solved cache (which is the default behaviour or xCtEvidence), because the interaction -may not be contributing towards a solution. Here is an example: - -Initial inert set: - [W] g1 : F a ~ beta1 -Work item: - [W] g2 : F a ~ beta2 -The work item will react with the inert yielding the _same_ inert set plus: - (i) Will set g2 := g1 `cast` g3 - (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 - (iii) Will emit [W] g3 : beta1 ~ beta2 -Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 -and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it -will set - g1 := g ; sym g3 -and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but -remember that we have this in our solved cache, and it is ... g2! In short we -created the evidence loop: - - g2 := g1 ; g3 - g3 := refl - g1 := g2 ; sym g3 - -To avoid this situation we do not cache as solved any workitems (or inert) -which did not really made a 'step' towards proving some goal. Solved's are -just an optimization so we don't lose anything in terms of completeness of -solving. - - -Note [Efficient Orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are interacting two FunEqCans with the same LHS: - (inert) ci :: (F ty ~ xi_i) - (work) cw :: (F ty ~ xi_w) -We prefer to keep the inert (else we pass the work item on down -the pipeline, which is a bit silly). If we keep the inert, we -will (a) discharge 'cw' - (b) produce a new equality work-item (xi_w ~ xi_i) -Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): - new_work :: xi_w ~ xi_i - cw := ci ; sym new_work -Why? Consider the simplest case when xi1 is a type variable. If -we generate xi1~xi2, porcessing that constraint will kick out 'ci'. -If we generate xi2~xi1, there is less chance of that happening. -Of course it can and should still happen if xi1=a, xi1=Int, say. -But we want to avoid it happening needlessly. - -Similarly, if we *can't* keep the inert item (because inert is Wanted, -and work is Given, say), we prefer to orient the new equality (xi_i ~ -xi_w). - -Note [Carefully solve the right CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ---- OLD COMMENT, NOW NOT NEEDED - ---- because we now allow multiple - ---- wanted FunEqs with the same head -Consider the constraints - c1 :: F Int ~ a -- Arising from an application line 5 - c2 :: F Int ~ Bool -- Arising from an application line 10 -Suppose that 'a' is a unification variable, arising only from -flattening. So there is no error on line 5; it's just a flattening -variable. But there is (or might be) an error on line 10. - -Two ways to combine them, leaving either (Plan A) - c1 :: F Int ~ a -- Arising from an application line 5 - c3 :: a ~ Bool -- Arising from an application line 10 -or (Plan B) - c2 :: F Int ~ Bool -- Arising from an application line 10 - c4 :: a ~ Bool -- Arising from an application line 5 - -Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error -on the *totally innocent* line 5. An example is test SimpleFail16 -where the expected/actual message comes out backwards if we use -the wrong plan. - -The second is the right thing to do. Hence the isMetaTyVarTy -test when solving pairwise CFunEqCan. - - -********************************************************************** -* * - interactTyVarEq -* * -********************************************************************** --} - -inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag -- Whether we need mkSymCo - , Bool) -- True <=> keep a [D] version - -- of the [WD] constraint -inertsCanDischarge inerts tv rhs fr - | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv - , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr - , rhs_i `tcEqType` rhs ] - = -- Inert: a ~ ty - -- Work item: a ~ ty - Just (ev_i, NotSwapped, keep_deriv ev_i) - - | Just tv_rhs <- getTyVar_maybe rhs - , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv_rhs - , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr - , rhs_i `tcEqType` mkTyVarTy tv ] - = -- Inert: a ~ b - -- Work item: b ~ a - Just (ev_i, IsSwapped, keep_deriv ev_i) - - | otherwise - = Nothing - - where - keep_deriv ev_i - | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] - , (Wanted WDeriv, _) <- fr -- work item is [WD] - = True -- Keep a derived verison of the work item - | otherwise - = False -- Work item is fully discharged - -interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- CTyEqCans are always consumed, so always returns Stop -interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv - , cc_rhs = rhs - , cc_ev = ev - , cc_eq_rel = eq_rel }) - | Just (ev_i, swapped, keep_deriv) - <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel) - = do { setEvBindIfWanted ev $ - evCoercion (maybeSym swapped $ - tcDowngradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) - - ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev - , ctev_loc = ctEvLoc ev } - ; when keep_deriv $ - emitWork [workItem { cc_ev = deriv_ev }] - -- As a Derived it might not be fully rewritten, - -- so we emit it as new work - - ; stopWith ev "Solved from inert" } - - | ReprEq <- eq_rel -- See Note [Do not unify representational equalities] - = do { traceTcS "Not unifying representational equality" (ppr workItem) - ; continueWith workItem } - - | isGiven ev -- See Note [Touchables and givens] - = continueWith workItem - - | otherwise - = do { tclvl <- getTcLevel - ; if canSolveByUnification tclvl tv rhs - then do { solveByUnification ev tv rhs - ; n_kicked <- kickOutAfterUnification tv - ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) } - - else continueWith workItem } - -interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) - -solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () --- Solve with the identity coercion --- Precondition: kind(xi) equals kind(tv) --- Precondition: CtEvidence is Wanted or Derived --- Precondition: CtEvidence is nominal --- Returns: workItem where --- workItem = the new Given constraint --- --- NB: No need for an occurs check here, because solveByUnification always --- arises from a CTyEqCan, a *canonical* constraint. Its invariants --- say that in (a ~ xi), the type variable a does not appear in xi. --- See TcRnTypes.Ct invariants. --- --- Post: tv is unified (by side effect) with xi; --- we often write tv := xi -solveByUnification wd tv xi - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, - text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (tcTypeKind tv_ty), - text "Right Kind is:" <+> ppr (tcTypeKind xi) ] - - ; unifyTyVar tv xi - ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) } - -{- Note [Avoid double unifications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The spontaneous solver has to return a given which mentions the unified unification -variable *on the left* of the equality. Here is what happens if not: - Original wanted: (a ~ alpha), (alpha ~ Int) -We spontaneously solve the first wanted, without changing the order! - given : a ~ alpha [having unified alpha := a] -Now the second wanted comes along, but he cannot rewrite the given, so we simply continue. -At the end we spontaneously solve that guy, *reunifying* [alpha := Int] - -We avoid this problem by orienting the resulting given so that the unification -variable is on the left. [Note that alternatively we could attempt to -enforce this at canonicalization] - -See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding -double unifications is the main reason we disallow touchable -unification variables as RHS of type family equations: F xis ~ alpha. - -Note [Do not unify representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [W] alpha ~R# b -where alpha is touchable. Should we unify alpha := b? - -Certainly not! Unifying forces alpha and be to be the same; but they -only need to be representationally equal types. - -For example, we might have another constraint [W] alpha ~# N b -where - newtype N b = MkN b -and we want to get alpha := N b. - -See also #15144, which was caused by unifying a representational -equality (in the unflattener). - - -************************************************************************ -* * -* Functional dependencies, instantiation of equations -* * -************************************************************************ - -When we spot an equality arising from a functional dependency, -we now use that equality (a "wanted") to rewrite the work-item -constraint right away. This avoids two dangers - - Danger 1: If we send the original constraint on down the pipeline - it may react with an instance declaration, and in delicate - situations (when a Given overlaps with an instance) that - may produce new insoluble goals: see #4952 - - Danger 2: If we don't rewrite the constraint, it may re-react - with the same thing later, and produce the same equality - again --> termination worries. - -To achieve this required some refactoring of FunDeps.hs (nicer -now!). - -Note [FunDep and implicit parameter reactions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, our story of interacting two dictionaries (or a dictionary -and top-level instances) for functional dependencies, and implicit -parameters, is that we simply produce new Derived equalities. So for example - - class D a b | a -> b where ... - Inert: - d1 :g D Int Bool - WorkItem: - d2 :w D Int alpha - - We generate the extra work item - cv :d alpha ~ Bool - where 'cv' is currently unused. However, this new item can perhaps be - spontaneously solved to become given and react with d2, - discharging it in favour of a new constraint d2' thus: - d2' :w D Int Bool - d2 := d2' |> D Int cv - Now d2' can be discharged from d1 - -We could be more aggressive and try to *immediately* solve the dictionary -using those extra equalities, but that requires those equalities to carry -evidence and derived do not carry evidence. - -If that were the case with the same inert set and work item we might dischard -d2 directly: - - cv :w alpha ~ Bool - d2 := d1 |> D Int cv - -But in general it's a bit painful to figure out the necessary coercion, -so we just take the first approach. Here is a better example. Consider: - class C a b c | a -> b -And: - [Given] d1 : C T Int Char - [Wanted] d2 : C T beta Int -In this case, it's *not even possible* to solve the wanted immediately. -So we should simply output the functional dependency and add this guy -[but NOT its superclasses] back in the worklist. Even worse: - [Given] d1 : C T Int beta - [Wanted] d2: C T beta Int -Then it is solvable, but its very hard to detect this on the spot. - -It's exactly the same with implicit parameters, except that the -"aggressive" approach would be much easier to implement. - -Note [Weird fundeps] -~~~~~~~~~~~~~~~~~~~~ -Consider class Het a b | a -> b where - het :: m (f c) -> a -> m b - - class GHet (a :: * -> *) (b :: * -> *) | a -> b - instance GHet (K a) (K [a]) - instance Het a b => GHet (K a) (K b) - -The two instances don't actually conflict on their fundeps, -although it's pretty strange. So they are both accepted. Now -try [W] GHet (K Int) (K Bool) -This triggers fundeps from both instance decls; - [D] K Bool ~ K [a] - [D] K Bool ~ K beta -And there's a risk of complaining about Bool ~ [a]. But in fact -the Wanted matches the second instance, so we never get as far -as the fundeps. - -#7875 is a case in point. --} - -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS () --- See Note [FunDep and implicit parameter reactions] -emitFunDepDeriveds fd_eqns - = mapM_ do_one_FDEqn fd_eqns - where - do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) - | null tvs -- Common shortcut - = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) - ; mapM_ (unifyDerived loc Nominal) eqs } - | otherwise - = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) - ; subst <- instFlexi tvs -- Takes account of kind substitution - ; mapM_ (do_one_eq loc subst) eqs } - - do_one_eq loc subst (Pair ty1 ty2) - = unifyDerived loc Nominal $ - Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) - -{- -********************************************************************** -* * - The top-reaction Stage -* * -********************************************************************** --} - -topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) --- The work item does not react with the inert set, --- so try interaction with top-level instances. Note: -topReactionsStage work_item - = do { traceTcS "doTopReact" (ppr work_item) - ; case work_item of - CDictCan {} -> do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - CFunEqCan {} -> doTopReactFunEq work_item - CIrredCan {} -> doTopReactOther work_item - CTyEqCan {} -> doTopReactOther work_item - _ -> -- Any other work item does not react with any top-level equations - continueWith work_item } - - --------------------- -doTopReactOther :: Ct -> TcS (StopOrContinue Ct) --- Try local quantified constraints for --- CTyEqCan e.g. (a ~# ty) --- and CIrredCan e.g. (c a) --- --- Why equalities? See TcCanonical --- Note [Equality superclasses in quantified constraints] -doTopReactOther work_item - | isGiven ev - = continueWith work_item - - | EqPred eq_rel t1 t2 <- classifyPredType pred - = -- See Note [Looking up primitive equalities in quantified constraints] - case boxEqPred eq_rel t1 t2 of - Nothing -> continueWith work_item - Just (cls, tys) - -> do { res <- matchLocalInst (mkClassPred cls tys) loc - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> chooseInstance work_item - (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) - where - _ -> continueWith work_item } - - | otherwise - = do { res <- matchLocalInst pred loc - ; case res of - OneInst {} -> chooseInstance work_item res - _ -> continueWith work_item } - where - ev = ctEvidence work_item - loc = ctEvLoc ev - pred = ctEvPred ev - - mk_eq_ev cls tys mk_ev evs - = case (mk_ev evs) of - EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) - ev -> pprPanic "mk_eq_ev" (ppr ev) - where - [sc_id] = classSCSelIds cls - -{- Note [Looking up primitive equalities in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For equalities (a ~# b) look up (a ~ b), and then do a superclass -selection. This avoids having to support quantified constraints whose -kind is not Constraint, such as (forall a. F a ~# b) - -See - * Note [Evidence for quantified constraints] in Predicate - * Note [Equality superclasses in quantified constraints] - in TcCanonical - -Note [Flatten when discharging CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have the following scenario (#16512): - -type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where - LV (a ': as) b = a -> LV as b - -[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan) -[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan) -[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan) - -We start with w1. Because LV is injective, we wish to see if the RHS of the -equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an -fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs. -That performs the match, but it allows a type family application (such as the -LV in the RHS of the equation) to match with anything. (See "Injective type -families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which -means we can improve as0 (and b, but that's not interesting here). However, -because the RHS of w1 can't see through fmv2 (we have no way of looking up a -LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough), -we invent a new unification variable here. We thus get (as0 := a : as1). -Rewriting: - -[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1 -[WD] w2 :: fmv1 ~ (a -> fmv2) -[WD] w3 :: LV (a : as1) b ~ fmv2 - -We can now reduce both CFunEqCans, using the equation for LV. We get - -[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b) - -Now we decompose (and flatten) to - -[WD] w4 :: LV as1 (a -> b) ~ fmv3 -[WD] w5 :: fmv3 ~ (a -> fmv1) -[WD] w6 :: LV as1 b ~ fmv4 - -which is exactly where we started. These goals really are insoluble, but -we would prefer not to loop. We thus need to find a way to bump the reduction -depth, so that we can detect the loop and abort. - -The key observation is that we are performing a reduction. We thus wish -to bump the level when discharging a CFunEqCan. Where does this bumped -level go, though? It can't just go on the reduct, as that's a type. Instead, -it must go on any CFunEqCans produced after flattening. We thus flatten -when discharging, making sure that the level is bumped in the new -fun-eqs. The flattening happens in reduce_top_fun_eq and the level -is bumped when setting up the FlatM monad in TcFlatten.runFlatten. -(This bumping will happen for call sites other than this one, but that -makes sense -- any constraints emitted by the flattener are offshoots -the work item and should have a higher level. We don't have any test -cases that require the bumping in this other cases, but it's convenient -and causes no harm to bump at every flatten.) - -Test case: typecheck/should_fail/T16512a - --} - --------------------- -doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc - , cc_tyargs = args, cc_fsk = fsk }) - - | fsk `elemVarSet` tyCoVarsOfTypes args - = no_reduction -- See Note [FunEq occurs-check principle] - - | otherwise -- Note [Reduction for Derived CFunEqCans] - = do { match_res <- matchFam fam_tc args - -- Look up in top-level instances, or built-in axiom - -- See Note [MATCHING-SYNONYMS] - ; case match_res of - Nothing -> no_reduction - Just match_info -> reduce_top_fun_eq old_ev fsk match_info } - where - no_reduction - = do { improveTopFunEqs old_ev fam_tc args fsk - ; continueWith work_item } - -doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) - -reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType) - -> TcS (StopOrContinue Ct) --- We have found an applicable top-level axiom: use it to reduce --- Precondition: fsk is not free in rhs_ty --- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev -reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty) - | not (isDerived old_ev) -- Precondition of shortCutReduction - , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty - , isTypeFamilyTyCon tc - , tc_args `lengthIs` tyConArity tc -- Short-cut - = -- RHS is another type-family application - -- Try shortcut; see Note [Top-level reductions for type functions] - do { shortCutReduction old_ev fsk ax_co tc tc_args - ; stopWith old_ev "Fun/Top (shortcut)" } - - | otherwise - = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) - , ppr old_ev $$ ppr rhs_ty ) - -- Guaranteed by Note [FunEq occurs-check principle] - do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty - -- flatten_co :: rhs_xi ~ rhs_ty - -- See Note [Flatten when discharging CFunEqCan] - ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co - ; dischargeFunEq old_ev fsk total_co rhs_xi - ; traceTcS "doTopReactFunEq" $ - vcat [ text "old_ev:" <+> ppr old_ev - , nest 2 (text ":=") <+> ppr ax_co ] - ; stopWith old_ev "Fun/Top" } - -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS () --- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs ev fam_tc args fsk - | isGiven ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable ev) - = return () - - | otherwise - = do { fam_envs <- getFamInstEnvs - ; rhs <- rewriteTyVar fsk - ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs - ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs - , ppr eqns ]) - ; mapM_ (unifyDerived loc Nominal) eqns } - where - loc = bumpCtLocDepth (ctEvLoc ev) - -- ToDo: this location is wrong; it should be FunDepOrigin2 - -- See #14778 - -improve_top_fun_eqs :: FamInstEnvs - -> TyCon -> [TcType] -> TcType - -> TcS [TypeEqn] -improve_top_fun_eqs fam_envs fam_tc args rhs_ty - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = return (sfInteractTop ops args rhs_ty) - - -- see Note [Type inference for type families with injectivity] - | isOpenTypeFamilyTyCon fam_tc - , Injective injective_args <- tyConInjectivityInfo fam_tc - , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc - = -- it is possible to have several compatible equations in an open type - -- family but we only want to derive equalities from one such equation. - do { let improvs = buildImprovementData fam_insts - fi_tvs fi_tys fi_rhs (const Nothing) - - ; traceTcS "improve_top_fun_eqs2" (ppr improvs) - ; concatMapM (injImproveEqns injective_args) $ - take 1 improvs } - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc - , Injective injective_args <- tyConInjectivityInfo fam_tc - = concatMapM (injImproveEqns injective_args) $ - buildImprovementData (fromBranches (co_ax_branches ax)) - cab_tvs cab_lhs cab_rhs Just - - | otherwise - = return [] - - where - buildImprovementData - :: [a] -- axioms for a TF (FamInst or CoAxBranch) - -> (a -> [TyVar]) -- get bound tyvars of an axiom - -> (a -> [Type]) -- get LHS of an axiom - -> (a -> Type) -- get RHS of an axiom - -> (a -> Maybe CoAxBranch) -- Just => apartness check required - -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )] - -- Result: - -- ( [arguments of a matching axiom] - -- , RHS-unifying substitution - -- , axiom variables without substitution - -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] ) - buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap = - [ (ax_args, subst, unsubstTvs, wrap axiom) - | axiom <- axioms - , let ax_args = axiomLHS axiom - ax_rhs = axiomRHS axiom - ax_tvs = axiomTVs axiom - , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty] - , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) - unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ] - -- The order of unsubstTvs is important; it must be - -- in telescope order e.g. (k:*) (a:k) - - injImproveEqns :: [Bool] - -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch) - -> TcS [TypeEqn] - injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) - = do { subst <- instFlexiX subst unsubstTvs - -- If the current substitution bind [k -> *], and - -- one of the un-substituted tyvars is (a::k), we'd better - -- be sure to apply the current substitution to a's kind. - -- Hence instFlexiX. #13135 was an example. - - ; return [ Pair (substTyUnchecked subst ax_arg) arg - -- NB: the ax_arg part is on the left - -- see Note [Improvement orientation] - | case cabr of - Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' - _ -> True - , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } - - -shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion - -> TyCon -> [TcType] -> TcS () --- See Note [Top-level reductions for type functions] --- Previously, we flattened the tc_args here, but there's no need to do so. --- And, if we did, this function would have all the complication of --- TcCanonical.canCFunEqCan. See Note [canCFunEqCan] -shortCutReduction old_ev fsk ax_co fam_tc tc_args - = ASSERT( ctEvEqRel old_ev == NomEq) - -- ax_co :: F args ~ G tc_args - -- old_ev :: F args ~ fsk - do { new_ev <- case ctEvFlavour old_ev of - Given -> newGivenEvVar deeper_loc - ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - , evCoercion (mkTcSymCo ax_co - `mkTcTransCo` ctEvCoercion old_ev) ) - - Wanted {} -> - do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal - (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co - ; return new_ev } - - Derived -> pprPanic "shortCutReduction" (ppr old_ev) - - ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc - , cc_tyargs = tc_args, cc_fsk = fsk } - ; updWorkListTcS (extendWorkListFunEq new_ct) } - where - deeper_loc = bumpCtLocDepth (ctEvLoc old_ev) - -{- Note [Top-level reductions for type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c.f. Note [The flattening story] in TcFlatten - -Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom. -Here is what we do, in four cases: - -* Wanteds: general firing rule - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ rhs - - Then: - Discharge fmv := rhs - Discharge x := ax_co ; sym x2 - This is *the* way that fmv's get unified; even though they are - "untouchable". - - NB: Given Note [FunEq occurs-check principle], fmv does not appear - in tys, and hence does not appear in the instantiated RHS. So - the unification can't make an infinite type. - -* Wanteds: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fmv for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) - - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv) - - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan) - - Discharge x := ax_co ; G cos ; x2 - -* Givens: general firing rule - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ rhs - - Now add non-canonical given (since rhs is not flat) - [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical) - -* Givens: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fsk for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys: flat_cos : tys ~ flat_tys - - Add new Canonical given - [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan) - -Note [FunEq occurs-check principle] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I have spent a lot of time finding a good way to deal with -CFunEqCan constraints like - F (fuv, a) ~ fuv -where flatten-skolem occurs on the LHS. Now in principle we -might may progress by doing a reduction, but in practice its -hard to find examples where it is useful, and easy to find examples -where we fall into an infinite reduction loop. A rule that works -very well is this: - - *** FunEq occurs-check principle *** - - Do not reduce a CFunEqCan - F tys ~ fsk - if fsk appears free in tys - Instead we treat it as stuck. - -Examples: - -* #5837 has [G] a ~ TF (a,Int), with an instance - type instance TF (a,b) = (TF a, TF b) - This readily loops when solving givens. But with the FunEq occurs - check principle, it rapidly gets stuck which is fine. - -* #12444 is a good example, explained in comment:2. We have - type instance F (Succ x) = Succ (F x) - [W] alpha ~ Succ (F alpha) - If we allow the reduction to happen, we get an infinite loop - -Note [Cached solved FunEqs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to solve, say (FunExpensive big-type ~ ty), it's important -to see if we have reduced (FunExpensive big-type) before, lest we -simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover -we must use `funEqCanDischarge` because both uses might (say) be Wanteds, -and we *still* want to save the re-computation. - -Note [MATCHING-SYNONYMS] -~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to match a dictionary (D tau) to a top-level instance, or a -type family equation (F taus_1 ~ tau_2) to a top-level family instance, -we do *not* need to expand type synonyms because the matcher will do that for us. - -Note [Improvement orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A very delicate point is the orientation of derived equalities -arising from injectivity improvement (#12522). Suppse we have - type family F x = t | t -> x - type instance F (a, Int) = (Int, G a) -where G is injective; and wanted constraints - - [W] TF (alpha, beta) ~ fuv - [W] fuv ~ (Int, ) - -The injectivity will give rise to derived constraints - - [D] gamma1 ~ alpha - [D] Int ~ beta - -The fresh unification variable gamma1 comes from the fact that we -can only do "partial improvement" here; see Section 5.2 of -"Injective type families for Haskell" (HS'15). - -Now, it's very important to orient the equations this way round, -so that the fresh unification variable will be eliminated in -favour of alpha. If we instead had - [D] alpha ~ gamma1 -then we would unify alpha := gamma1; and kick out the wanted -constraint. But when we grough it back in, it'd look like - [W] TF (gamma1, beta) ~ fuv -and exactly the same thing would happen again! Infinite loop. - -This all seems fragile, and it might seem more robust to avoid -introducing gamma1 in the first place, in the case where the -actual argument (alpha, beta) partly matches the improvement -template. But that's a bit tricky, esp when we remember that the -kinds much match too; so it's easier to let the normal machinery -handle it. Instead we are careful to orient the new derived -equality with the template on the left. Delicate, but it works. - -Note [No FunEq improvement for Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do improvements (injectivity etc) for Givens. Why? - -* It generates Derived constraints on skolems, which don't do us - much good, except perhaps identify inaccessible branches. - (They'd be perfectly valid though.) - -* For type-nat stuff the derived constraints include type families; - e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this, - we'll generate a Derived/Wanted CFunEqCan; and, since the same - InertCans (after solving Givens) are used for each iteration, that - massively confused the unflattening step (TcFlatten.unflatten). - - In fact it led to some infinite loops: - indexed-types/should_compile/T10806 - indexed-types/should_compile/T10507 - polykinds/T10742 - -Note [Reduction for Derived CFunEqCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You may wonder if it's important to use top-level instances to -simplify [D] CFunEqCan's. But it is. Here's an example (T10226). - - type instance F Int = Int - type instance FInv Int = Int - -Suppose we have to solve - [WD] FInv (F alpha) ~ alpha - [WD] F alpha ~ Int - - --> flatten - [WD] F alpha ~ fuv0 - [WD] FInv fuv0 ~ fuv1 -- (A) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int -- (B) - - --> Rewwrite (A) with (B), splitting it - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] FInv Int ~ fuv1 -- (C) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> Reduce (C) with top-level instance - **** This is the key step *** - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] fuv1 ~ Int -- (D) - [WD] fuv1 ~ alpha -- (E) - [WD] fuv0 ~ Int - - --> Rewrite (D) with (E) - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] alpha ~ Int -- (F) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> unify (F) alpha := Int, and that solves it - -Another example is indexed-types/should_compile/T10634 --} - -{- ******************************************************************* -* * - Top-level reaction for class constraints (CDictCan) -* * -**********************************************************************-} - -doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) --- Try to use type-class instance declarations to simplify the constraint -doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis }) - | isGiven ev -- Never use instances for Given constraints - = do { try_fundep_improvement - ; continueWith work_item } - - | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached - = do { setEvBindIfWanted ev (ctEvTerm solved_ev) - ; stopWith ev "Dict/Top (cached)" } - - | otherwise -- Wanted or Derived, but not cached - = do { dflags <- getDynFlags - ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc - ; case lkup_res of - OneInst { cir_what = what } - -> do { insertSafeOverlapFailureTcS what work_item - ; addSolvedDict what ev cls xis - ; chooseInstance work_item lkup_res } - _ -> -- NoInstance or NotSure - do { when (isImprovable ev) $ - try_fundep_improvement - ; continueWith work_item } } - where - dict_pred = mkClassPred cls xis - dict_loc = ctEvLoc ev - dict_origin = ctLocOrigin dict_loc - - -- We didn't solve it; so try functional dependencies with - -- the instance environment, and return - -- See also Note [Weird fundeps] - try_fundep_improvement - = do { traceTcS "try_fundeps" (ppr work_item) - ; instEnvs <- getInstEnvs - ; emitFunDepDeriveds $ - improveFromInstEnv instEnvs mk_ct_loc dict_pred } - - mk_ct_loc :: PredType -- From instance decl - -> SrcSpan -- also from instance deol - -> CtLoc - mk_ct_loc inst_pred inst_loc - = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc } - -doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) - - -chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct) -chooseInstance work_item - (OneInst { cir_new_theta = theta - , cir_what = what - , cir_mk_ev = mk_ev }) - = do { traceTcS "doTopReact/found instance for" $ ppr ev - ; deeper_loc <- checkInstanceOK loc what pred - ; if isDerived ev then finish_derived deeper_loc theta - else finish_wanted deeper_loc theta mk_ev } - where - ev = ctEvidence work_item - pred = ctEvPred ev - loc = ctEvLoc ev - - finish_wanted :: CtLoc -> [TcPredType] - -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct) - -- Precondition: evidence term matches the predicate workItem - finish_wanted loc theta mk_ev - = do { evb <- getTcEvBindsVar - ; if isCoEvBindsVar evb - then -- See Note [Instances in no-evidence implications] - continueWith work_item - else - do { evc_vars <- mapM (newWanted loc) theta - ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith ev "Dict/Top (solved wanted)" } } - - finish_derived loc theta - = -- Use type-class instances for Deriveds, in the hope - -- of generating some improvements - -- C.f. Example 3 of Note [The improvement story] - -- It's easy because no evidence is involved - do { emitNewDeriveds loc theta - ; traceTcS "finish_derived" (ppr (ctl_depth loc)) - ; stopWith ev "Dict/Top (solved derived)" } - -chooseInstance work_item lookup_res - = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) - -checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc --- Check that it's OK to use this insstance: --- (a) the use is well staged in the Template Haskell sense --- (b) we have not recursed too deep --- Returns the CtLoc to used for sub-goals -checkInstanceOK loc what pred - = do { checkWellStagedDFun loc what pred - ; checkReductionDepth deeper_loc pred - ; return deeper_loc } - where - deeper_loc = zap_origin (bumpCtLocDepth loc) - origin = ctLocOrigin loc - - zap_origin loc -- After applying an instance we can set ScOrigin to - -- infinity, so that prohibitedSuperClassSolve never fires - | ScOrigin {} <- origin - = setCtLocOrigin loc (ScOrigin infinity) - | otherwise - = loc - -{- Note [Instances in no-evidence implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #15290 we had - [G] forall p q. Coercible p q => Coercible (m p) (m q)) - [W] forall a. m (Int, IntStateT m a) - ~R# - m (Int, StateT Int m a) - -The Given is an ordinary quantified constraint; the Wanted is an implication -equality that arises from - [W] (forall a. t1) ~R# (forall a. t2) - -But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) -we can't generate any term evidence. So we can't actually use that -lovely quantified constraint. Alas! - -This test arranges to ignore the instance-based solution under these -(rare) circumstances. It's sad, but I really don't see what else we can do. --} - - -matchClassInst :: DynFlags -> InertSet - -> Class -> [Type] - -> CtLoc -> TcS ClsInstResult -matchClassInst dflags inerts clas tys loc --- First check whether there is an in-scope Given that could --- match this constraint. In that case, do not use any instance --- whether top level, or local quantified constraints. --- ee Note [Instance and Given overlap] - | not (xopt LangExt.IncoherentInstances dflags) - , not (naturallyCoherentClass clas) - , let matchable_givens = matchableGivens loc pred inerts - , not (isEmptyBag matchable_givens) - = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys - , text "Potential matching givens:" <+> ppr matchable_givens ] - ; return NotSure } - - | otherwise - = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' - ; local_res <- matchLocalInst pred loc - ; case local_res of - OneInst {} -> -- See Note [Local instances and incoherence] - do { traceTcS "} matchClassInst local match" $ ppr local_res - ; return local_res } - - NotSure -> -- In the NotSure case for local instances - -- we don't want to try global instances - do { traceTcS "} matchClassInst local not sure" empty - ; return local_res } - - NoInstance -- No local instances, so try global ones - -> do { global_res <- matchGlobalInst dflags False clas tys - ; traceTcS "} matchClassInst global result" $ ppr global_res - ; return global_res } } - where - pred = mkClassPred clas tys - --- | If a class is "naturally coherent", then we needn't worry at all, in any --- way, about overlapping/incoherent instances. Just solve the thing! --- See Note [Naturally coherent classes] --- See also Note [The equality class story] in TysPrim. -naturallyCoherentClass :: Class -> Bool -naturallyCoherentClass cls - = isCTupleClass cls - || cls `hasKey` heqTyConKey - || cls `hasKey` eqTyConKey - || cls `hasKey` coercibleTyConKey - - -{- Note [Instance and Given overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example, from the OutsideIn(X) paper: - instance P x => Q [x] - instance (x ~ y) => R y [x] - - wob :: forall a b. (Q [b], R b a) => a -> Int - - g :: forall a. Q [a] => [a] -> Int - g x = wob x - -From 'g' we get the impliation constraint: - forall a. Q [a] => (Q [beta], R beta [a]) -If we react (Q [beta]) with its top-level axiom, we end up with a -(P beta), which we have no way of discharging. On the other hand, -if we react R beta [a] with the top-level we get (beta ~ a), which -is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is -now solvable by the given Q [a]. - -The partial solution is that: - In matchClassInst (and thus in topReact), we return a matching - instance only when there is no Given in the inerts which is - unifiable to this particular dictionary. - - We treat any meta-tyvar as "unifiable" for this purpose, - *including* untouchable ones. But not skolems like 'a' in - the implication constraint above. - -The end effect is that, much as we do for overlapping instances, we -delay choosing a class instance if there is a possibility of another -instance OR a given to match our constraint later on. This fixes -#4981 and #5002. - -Other notes: - -* The check is done *first*, so that it also covers classes - with built-in instance solving, such as - - constraint tuples - - natural numbers - - Typeable - -* Flatten-skolems: we do not treat a flatten-skolem as unifiable - for this purpose. - E.g. f :: Eq (F a) => [a] -> [a] - f xs = ....(xs==xs)..... - Here we get [W] Eq [a], and we don't want to refrain from solving - it because of the given (Eq (F a)) constraint! - -* The given-overlap problem is arguably not easy to appear in practice - due to our aggressive prioritization of equality solving over other - constraints, but it is possible. I've added a test case in - typecheck/should-compile/GivenOverlapping.hs - -* Another "live" example is #10195; another is #10177. - -* We ignore the overlap problem if -XIncoherentInstances is in force: - see #6002 for a worked-out example where this makes a - difference. - -* Moreover notice that our goals here are different than the goals of - the top-level overlapping checks. There we are interested in - validating the following principle: - - If we inline a function f at a site where the same global - instance environment is available as the instance environment at - the definition site of f then we should get the same behaviour. - - But for the Given Overlap check our goal is just related to completeness of - constraint solving. - -* The solution is only a partial one. Consider the above example with - g :: forall a. Q [a] => [a] -> Int - g x = let v = wob x - in v - and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most - general type for 'v'. When generalising v's type we'll simplify its - Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we - will use the instance declaration after all. #11948 was a case - in point. - -All of this is disgustingly delicate, so to discourage people from writing -simplifiable class givens, we warn about signatures that contain them; -see TcValidity Note [Simplifiable given constraints]. - -Note [Naturally coherent classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A few built-in classes are "naturally coherent". This term means that -the "instance" for the class is bidirectional with its superclass(es). -For example, consider (~~), which behaves as if it was defined like -this: - class a ~# b => a ~~ b - instance a ~# b => a ~~ b -(See Note [The equality types story] in TysPrim.) - -Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2, -without worrying about Note [Instance and Given overlap]. Why? Because -if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and -so the reduction of the [W] constraint does not risk losing any solutions. - -On the other hand, it can be fatal to /fail/ to reduce such -equalities, on the grounds of Note [Instance and Given overlap], -because many good things flow from [W] t1 ~# t2. - -The same reasoning applies to - -* (~~) heqTyCOn -* (~) eqTyCon -* Coercible coercibleTyCon - -And less obviously to: - -* Tuple classes. For reasons described in TcSMonad - Note [Tuples hiding implicit parameters], we may have a constraint - [W] (?x::Int, C a) - with an exactly-matching Given constraint. We must decompose this - tuple and solve the components separately, otherwise we won't solve - it at all! It is perfectly safe to decompose it, because again the - superclasses invert the instance; e.g. - class (c1, c2) => (% c1, c2 %) - instance (c1, c2) => (% c1, c2 %) - Example in #14218 - -Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b - -PS: the term "naturally coherent" doesn't really seem helpful. -Perhaps "invertible" or something? I left it for now though. - -Note [Local instances and incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) - => c b -> Bool - f x = x==x - -We get [W] Eq (c b), and we must use the local instance to solve it. - -BUT that wanted also unifies with the top-level Eq [a] instance, -and Eq (Maybe a) etc. We want the local instance to "win", otherwise -we can't solve the wanted at all. So we mark it as Incohherent. -According to Note [Rules for instance lookup] in InstEnv, that'll -make it win even if there are other instances that unify. - -Moreover this is not a hack! The evidence for this local instance -will be constructed by GHC at a call site... from the very instances -that unify with it here. It is not like an incoherent user-written -instance which might have utterly different behaviour. - -Consdider f :: Eq a => blah. If we have [W] Eq a, we certainly -get it from the Eq a context, without worrying that there are -lots of top-level instances that unify with [W] Eq a! We'll use -those instances to build evidence to pass to f. That's just the -nullary case of what's happening here. --} - -matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult --- Look up the predicate in Given quantified constraints, --- which are effectively just local instance declarations. -matchLocalInst pred loc - = do { ics <- getInertCans - ; case match_local_inst (inert_insts ics) of - ([], False) -> return NoInstance - ([(dfun_ev, inst_tys)], unifs) - | not unifs - -> do { let dfun_id = ctEvEvId dfun_ev - ; (tys, theta) <- instDFunType dfun_id inst_tys - ; return $ OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = LocalInstance } } - _ -> return NotSure } - where - pred_tv_set = tyCoVarsOfType pred - - match_local_inst :: [QCInst] - -> ( [(CtEvidence, [DFunInstType])] - , Bool ) -- True <=> Some unify but do not match - match_local_inst [] - = ([], False) - match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred - , qci_ev = ev }) - : qcis) - | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) - , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) - emptyTvSubstEnv qpred pred - , let match = (ev, map (lookupVarEnv tv_subst) qtvs) - = (match:matches, unif) - - | otherwise - = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred) - , ppr qci $$ ppr pred ) - -- ASSERT: unification relies on the - -- quantified variables being fresh - (matches, unif || this_unif) - where - qtv_set = mkVarSet qtvs - this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc - (matches, unif) = match_local_inst qcis diff --git a/typecheck/TcMType.hs b/typecheck/TcMType.hs deleted file mode 100644 --- a/typecheck/TcMType.hs +++ /dev/null @@ -1,2359 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Monadic type operations - -This module contains monadic operations over types that contain -mutable type variables. --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} - -module TcMType ( - TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, - - -------------------------------- - -- Creating new mutable type variables - newFlexiTyVar, - newFlexiTyVarTy, -- Kind -> TcM TcType - newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newOpenFlexiTyVarTy, newOpenTypeKind, - newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, - cloneMetaTyVar, - newFmvTyVar, newFskTyVar, - - readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, - - -------------------------------- - -- Expected types - ExpType(..), ExpSigmaType, ExpRhoType, - mkCheckExpType, - newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst, - readExpType, readExpType_maybe, - expTypeToType, checkingExpType_maybe, checkingExpType, - tauifyExpType, inferResultToType, - - -------------------------------- - -- Creating new evidence variables - newEvVar, newEvVars, newDict, - newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC, - emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, - emitDerivedEqs, - newTcEvBinds, newNoTcEvBinds, addTcEvBind, - - newCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, - checkCoercionHole, - - newImplication, - - -------------------------------- - -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, - newMetaTyVarTyVars, newMetaTyVarTyVarX, - newTyVarTyVar, cloneTyVarTyVar, - newPatSigTyVar, newSkolemTyVar, newWildCardX, - tcInstType, - tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, - tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, - - freshenTyVarBndrs, freshenCoVarBndrsX, - - -------------------------------- - -- Zonking and tidying - zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, - tidyEvVar, tidyCt, tidySkolemInfo, - zonkTcTyVar, zonkTcTyVars, - zonkTcTyVarToTyVar, zonkTyVarTyVarPairs, - zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, - zonkTyCoVarsAndFVList, - candidateQTyVarsOfType, candidateQTyVarsOfKind, - candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, - CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, - zonkAndSkolemise, skolemiseQuantifiedTyVar, - defaultTyVar, quantifyTyVars, isQuantifiableTv, - zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, - - zonkEvVar, zonkWC, zonkSimples, - zonkId, zonkCoVar, - zonkCt, zonkSkolemInfo, - - skolemiseUnboundMetaTyVar, - - ------------------------------ - -- Levity polymorphism - ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr - ) where - -#include "HsVersions.h" - --- friends: -import GhcPrelude - -import TyCoRep -import TyCoPpr -import TcType -import Type -import TyCon -import Coercion -import Class -import Var -import Predicate -import TcOrigin - --- others: -import TcRnMonad -- TcType, amongst others -import Constraint -import TcEvidence -import Id -import Name -import VarSet -import TysWiredIn -import TysPrim -import VarEnv -import NameEnv -import PrelNames -import Util -import Outputable -import FastString -import Bag -import Pair -import UniqSet -import DynFlags -import qualified GHC.LanguageExtensions as LangExt -import BasicTypes ( TypeOrKind(..) ) - -import Control.Monad -import Maybes -import Data.List ( mapAccumL ) -import Control.Arrow ( second ) -import qualified Data.Semigroup as Semi - -{- -************************************************************************ -* * - Kind variables -* * -************************************************************************ --} - -mkKindName :: Unique -> Name -mkKindName unique = mkSystemName unique kind_var_occ - -kind_var_occ :: OccName -- Just one for all MetaKindVars - -- They may be jiggled by tidying -kind_var_occ = mkOccName tvName "k" - -newMetaKindVar :: TcM TcKind -newMetaKindVar - = do { details <- newMetaDetails TauTv - ; uniq <- newUnique - ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details - ; traceTc "newMetaKindVar" (ppr kv) - ; return (mkTyVarTy kv) } - -newMetaKindVars :: Int -> TcM [TcKind] -newMetaKindVars n = replicateM n newMetaKindVar - -{- -************************************************************************ -* * - Evidence variables; range over constraints we can abstract over -* * -************************************************************************ --} - -newEvVars :: TcThetaType -> TcM [EvVar] -newEvVars theta = mapM newEvVar theta - --------------- - -newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar --- Creates new *rigid* variables for predicates -newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name ty) } - -newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence --- Deals with both equality and non-equality predicates -newWanted orig t_or_k pty - = do loc <- getCtLocM orig t_or_k - d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole pty - else EvVarDest <$> newEvVar pty - return $ CtWanted { ctev_dest = d - , ctev_pred = pty - , ctev_nosh = WDeriv - , ctev_loc = loc } - -newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] -newWanteds orig = mapM (newWanted orig Nothing) - --- | Create a new 'CHoleCan' 'Ct'. -newHoleCt :: Hole -> Id -> Type -> TcM Ct -newHoleCt hole ev ty = do - loc <- getCtLocM HoleOrigin Nothing - pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty - , ctev_dest = EvVarDest ev - , ctev_nosh = WDeriv - , ctev_loc = loc } - , cc_hole = hole } - ----------------------------------------------- --- Cloning constraints ----------------------------------------------- - -cloneWanted :: Ct -> TcM Ct -cloneWanted ct - | ev@(CtWanted { ctev_dest = HoleDest {}, ctev_pred = pty }) <- ctEvidence ct - = do { co_hole <- newCoercionHole pty - ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } - | otherwise - = return ct - -cloneWC :: WantedConstraints -> TcM WantedConstraints --- Clone all the evidence bindings in --- a) the ic_bind field of any implications --- b) the CoercionHoles of any wanted constraints --- so that solving the WantedConstraints will not have any visible side --- effect, /except/ from causing unifications -cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { simples' <- mapBagM cloneWanted simples - ; implics' <- mapBagM cloneImplication implics - ; return (wc { wc_simple = simples', wc_impl = implics' }) } - -cloneImplication :: Implication -> TcM Implication -cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) - = do { binds' <- cloneEvBindsVar binds - ; inner_wanted' <- cloneWC inner_wanted - ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } - ----------------------------------------------- --- Emitting constraints ----------------------------------------------- - --- | Emits a new Wanted. Deals with both equalities and non-equalities. -emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm -emitWanted origin pty - = do { ev <- newWanted origin Nothing pty - ; emitSimple $ mkNonCanonical ev - ; return $ ctEvTerm ev } - -emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () --- Emit some new derived nominal equalities -emitDerivedEqs origin pairs - | null pairs - = return () - | otherwise - = do { loc <- getCtLocM origin Nothing - ; emitSimples (listToBag (map (mk_one loc) pairs)) } - where - mk_one loc (ty1, ty2) - = mkNonCanonical $ - CtDerived { ctev_pred = mkPrimEqPred ty1 ty2 - , ctev_loc = loc } - --- | Emits a new equality constraint -emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion -emitWantedEq origin t_or_k role ty1 ty2 - = do { hole <- newCoercionHole pty - ; loc <- getCtLocM origin (Just t_or_k) - ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = WDeriv, ctev_loc = loc } - ; return (HoleCo hole) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- | Creates a new EvVar and immediately emits it as a Wanted. --- No equality predicates here. -emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar -emitWantedEvVar origin ty - = do { new_cv <- newEvVar ty - ; loc <- getCtLocM origin Nothing - ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv - , ctev_pred = ty - , ctev_nosh = WDeriv - , ctev_loc = loc } - ; emitSimple $ mkNonCanonical ctev - ; return new_cv } - -emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] -emitWantedEvVars orig = mapM (emitWantedEvVar orig) - -newDict :: Class -> [TcType] -> TcM DictId -newDict cls tys - = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name (mkClassPred cls tys)) } - -predTypeOccName :: PredType -> OccName -predTypeOccName ty = case classifyPredType ty of - ClassPred cls _ -> mkDictOcc (getOccName cls) - EqPred {} -> mkVarOccFS (fsLit "co") - IrredPred {} -> mkVarOccFS (fsLit "irred") - ForAllPred {} -> mkVarOccFS (fsLit "df") - --- | Create a new 'Implication' with as many sensible defaults for its fields --- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do --- /not/ have sensible defaults, so they are initialized with lazy thunks that --- will 'panic' if forced, so one should take care to initialize these fields --- after creation. --- --- This is monadic to look up the 'TcLclEnv', which is used to initialize --- 'ic_env', and to set the -Winaccessible-code flag. See --- Note [Avoid -Winaccessible-code when deriving] in TcInstDcls. -newImplication :: TcM Implication -newImplication - = do env <- getLclEnv - warn_inaccessible <- woptM Opt_WarnInaccessibleCode - return (implicationPrototype { ic_env = env - , ic_warn_inaccessible = warn_inaccessible }) - -{- -************************************************************************ -* * - Coercion holes -* * -************************************************************************ --} - -newCoercionHole :: TcPredType -> TcM CoercionHole -newCoercionHole pred_ty - = do { co_var <- newEvVar pred_ty - ; traceTc "New coercion hole:" (ppr co_var) - ; ref <- newMutVar Nothing - ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } - --- | Put a value in a coercion hole -fillCoercionHole :: CoercionHole -> Coercion -> TcM () -fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co - = do { -#if defined(DEBUG) - ; cts <- readTcRef ref - ; whenIsJust cts $ \old_co -> - pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) -#endif - ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) - ; writeTcRef ref (Just co) } - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref - --- | Retrieve the contents of a coercion hole. Panics if the hole --- is unfilled -unpackCoercionHole :: CoercionHole -> TcM Coercion -unpackCoercionHole hole - = do { contents <- unpackCoercionHole_maybe hole - ; case contents of - Just co -> return co - Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } - --- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) -unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref - --- | Check that a coercion is appropriate for filling a hole. (The hole --- itself is needed only for printing. --- Always returns the checked coercion, but this return value is necessary --- so that the input coercion is forced only when the output is forced. -checkCoercionHole :: CoVar -> Coercion -> TcM Coercion -checkCoercionHole cv co - | debugIsOn - = do { cv_ty <- zonkTcType (varType cv) - -- co is already zonked, but cv might not be - ; return $ - ASSERT2( ok cv_ty - , (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) ) - co } - | otherwise - = return co - - where - (Pair t1 t2, role) = coercionKindRole co - ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty - = t1 `eqType` cv_t1 - && t2 `eqType` cv_t2 - && role == eqRelRole cv_rel - | otherwise - = False - -{- -************************************************************************ -* - Expected types -* -************************************************************************ - -Note [ExpType] -~~~~~~~~~~~~~~ - -An ExpType is used as the "expected type" when type-checking an expression. -An ExpType can hold a "hole" that can be filled in by the type-checker. -This allows us to have one tcExpr that works in both checking mode and -synthesis mode (that is, bidirectional type-checking). Previously, this -was achieved by using ordinary unification variables, but we don't need -or want that generality. (For example, #11397 was caused by doing the -wrong thing with unification variables.) Instead, we observe that these -holes should - -1. never be nested -2. never appear as the type of a variable -3. be used linearly (never be duplicated) - -By defining ExpType, separately from Type, we can achieve goals 1 and 2 -statically. - -See also [wiki:typechecking] - -Note [TcLevel of ExpType] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data G a where - MkG :: G Bool - - foo MkG = True - -This is a classic untouchable-variable / ambiguous GADT return type -scenario. But, with ExpTypes, we'll be inferring the type of the RHS. -And, because there is only one branch of the case, we won't trigger -Note [Case branches must never infer a non-tau type] of TcMatches. -We thus must track a TcLevel in an Inferring ExpType. If we try to -fill the ExpType and find that the TcLevels don't work out, we -fill the ExpType with a tau-tv at the low TcLevel, hopefully to -be worked out later by some means. This is triggered in -test gadt/gadt-escape1. - --} - --- actual data definition is in TcType - --- | Make an 'ExpType' suitable for inferring a type of kind * or #. -newInferExpTypeNoInst :: TcM ExpSigmaType -newInferExpTypeNoInst = newInferExpType False - -newInferExpTypeInst :: TcM ExpRhoType -newInferExpTypeInst = newInferExpType True - -newInferExpType :: Bool -> TcM ExpType -newInferExpType inst - = do { u <- newUnique - ; tclvl <- getTcLevel - ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl) - ; ref <- newMutVar Nothing - ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl - , ir_ref = ref, ir_inst = inst })) } - --- | Extract a type out of an ExpType, if one exists. But one should always --- exist. Unless you're quite sure you know what you're doing. -readExpType_maybe :: ExpType -> TcM (Maybe TcType) -readExpType_maybe (Check ty) = return (Just ty) -readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref - --- | Extract a type out of an ExpType. Otherwise, panics. -readExpType :: ExpType -> TcM TcType -readExpType exp_ty - = do { mb_ty <- readExpType_maybe exp_ty - ; case mb_ty of - Just ty -> return ty - Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } - --- | Returns the expected type when in checking mode. -checkingExpType_maybe :: ExpType -> Maybe TcType -checkingExpType_maybe (Check ty) = Just ty -checkingExpType_maybe _ = Nothing - --- | Returns the expected type when in checking mode. Panics if in inference --- mode. -checkingExpType :: String -> ExpType -> TcType -checkingExpType _ (Check ty) = ty -checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) - -tauifyExpType :: ExpType -> TcM ExpType --- ^ Turn a (Infer hole) type into a (Check alpha), --- where alpha is a fresh unification variable -tauifyExpType (Check ty) = return (Check ty) -- No-op for (Check ty) -tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res - ; return (Check ty) } - --- | Extracts the expected type if there is one, or generates a new --- TauTv if there isn't. -expTypeToType :: ExpType -> TcM TcType -expTypeToType (Check ty) = return ty -expTypeToType (Infer inf_res) = inferResultToType inf_res - -inferResultToType :: InferResult -> TcM Type -inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref }) - = do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) - -- See Note [TcLevel of ExpType] - ; writeMutVar ref (Just tau) - ; traceTc "Forcing ExpType to be monomorphic:" - (ppr u <+> text ":=" <+> ppr tau) - ; return tau } - - -{- ********************************************************************* -* * - SkolemTvs (immutable) -* * -********************************************************************* -} - -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) - -- ^ How to instantiate the type variables - -> Id -- ^ Type to instantiate - -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result - -- (type vars, preds (incl equalities), rho) -tcInstType inst_tyvars id - = case tcSplitForAllTys (idType id) of - ([], rho) -> let -- There may be overloading despite no type variables; - -- (?x :: Int) => Int -> Int - (theta, tau) = tcSplitPhiTy rho - in - return ([], theta, tau) - - (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars - ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) - tv_prs = map tyVarName tyvars `zip` tyvars' - ; return (tv_prs, theta, tau) } - -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) --- Instantiate a type signature with skolem constants. --- We could give them fresh names, but no need to do so -tcSkolDFunType dfun - = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun - ; return (map snd tv_prs, theta, tau) } - -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) --- Make skolem constants, but do *not* give them new names, as above --- Moreover, make them "super skolems"; see comments with superSkolemTv --- see Note [Kind substitution when instantiating] --- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst - -tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) -tcSuperSkolTyVar subst tv - = (extendTvSubstWithClone subst tv new_tv, new_tv) - where - kind = substTyUnchecked subst (tyVarKind tv) - new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv - --- | Given a list of @['TyVar']@, skolemize the type variables, --- returning a substitution mapping the original tyvars to the --- skolems, and the list of newly bound skolems. -tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst - -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False - -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst - -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst - -tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) --- Skolemise one level deeper, hence pushTcLevel --- See Note [Skolemising type variables] -tcInstSkolTyVarsPushLevel overlappable subst tvs - = do { tc_lvl <- getTcLevel - ; let pushed_lvl = pushTcLevel tc_lvl - ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } - -tcInstSkolTyVarsAt :: TcLevel -> Bool - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsAt lvl overlappable subst tvs - = freshenTyCoVarsX new_skol_tv subst tvs - where - details = SkolemTv lvl overlappable - new_skol_tv name kind = mkTcTyVar name kind details - ------------------- -freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) --- ^ Give fresh uniques to a bunch of TyVars, but they stay --- as TyVars, rather than becoming TcTyVars --- Used in FamInst.newFamInst, and Inst.newClsInst -freshenTyVarBndrs = freshenTyCoVars mkTyVar - -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) --- ^ Give fresh uniques to a bunch of CoVars --- Used in FamInst.newFamInst -freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst - ------------------- -freshenTyCoVars :: (Name -> Kind -> TyCoVar) - -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst - -freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> [TyCoVar] - -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) - -freshenTyCoVarX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) --- This a complete freshening operation: --- the skolems have a fresh unique, and a location from the monad --- See Note [Skolemising type variables] -freshenTyCoVarX mk_tcv subst tycovar - = do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let old_name = tyVarName tycovar - new_name = mkInternalName uniq (getOccName old_name) loc - new_kind = substTyUnchecked subst (tyVarKind tycovar) - new_tcv = mk_tcv new_name new_kind - subst1 = extendTCvSubstWithClone subst tycovar new_tcv - ; return (subst1, new_tcv) } - -{- Note [Skolemising type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The tcInstSkolTyVars family of functions instantiate a list of TyVars -to fresh skolem TcTyVars. Important notes: - -a) Level allocation. We generally skolemise /before/ calling - pushLevelAndCaptureConstraints. So we want their level to the level - of the soon-to-be-created implication, which has a level ONE HIGHER - than the current level. Hence the pushTcLevel. It feels like a - slight hack. - -b) The [TyVar] should be ordered (kind vars first) - See Note [Kind substitution when instantiating] - -c) It's a complete freshening operation: the skolems have a fresh - unique, and a location from the monad - -d) The resulting skolems are - non-overlappable for tcInstSkolTyVars, - but overlappable for tcInstSuperSkolTyVars - See TcDerivInfer Note [Overlap and deriving] for an example - of where this matters. - -Note [Kind substitution when instantiating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we instantiate a bunch of kind and type variables, first we -expect them to be topologically sorted. -Then we have to instantiate the kind variables, build a substitution -from old variables to the new variables, then instantiate the type -variables substituting the original kind. - -Exemple: If we want to instantiate - [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] -we want - [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] -instead of the buggous - [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] - - -************************************************************************ -* * - MetaTvs (meta type variables; mutable) -* * -************************************************************************ --} - -{- -Note [TyVarTv] -~~~~~~~~~~~~ - -A TyVarTv can unify with type *variables* only, including other TyVarTvs and -skolems. Sometimes, they can unify with type variables that the user would -rather keep distinct; see #11203 for an example. So, any client of this -function needs to either allow the TyVarTvs to unify with each other or check -that they don't (say, with a call to findDubTyVarTvs). - -Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in -patterns, to make sure these type variables only refer to other type variables, -but this restriction was dropped, and ScopedTypeVariables can now refer to full -types (GHC Proposal 29). - -The remaining uses of newTyVarTyVars are -* In kind signatures, see - TcTyClsDecls Note [Inferring kinds for type declarations] - and Note [Kind checking for GADTs] -* In partial type signatures, see Note [Quantified variables in partial type signatures] --} - -newMetaTyVarName :: FastString -> TcM Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see TcUnify.nicer_to_update_tv1, and --- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2) -newMetaTyVarName str - = do { uniq <- newUnique - ; return (mkSystemName uniq (mkTyVarOccFS str)) } - -cloneMetaTyVarName :: Name -> TcM Name -cloneMetaTyVarName name - = do { uniq <- newUnique - ; return (mkSystemName uniq (nameOccName name)) } - -- See Note [Name of an instantiated type variable] - -{- Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. --} - -newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar --- Make a new meta tyvar out of thin air -newAnonMetaTyVar meta_info kind - = do { let s = case meta_info of - TauTv -> fsLit "t" - FlatMetaTv -> fsLit "fmv" - FlatSkolTv -> fsLit "fsk" - TyVarTv -> fsLit "a" - ; name <- newMetaTyVarName s - ; details <- newMetaDetails meta_info - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newAnonMetaTyVar" (ppr tyvar) - ; return tyvar } - --- makes a new skolem tv -newSkolemTyVar :: Name -> Kind -> TcM TcTyVar -newSkolemTyVar name kind - = do { lvl <- getTcLevel - ; return (mkTcTyVar name kind (SkolemTv lvl False)) } - -newTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Does not clone a fresh unique -newTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newTyVarTyVar" (ppr tyvar) - ; return tyvar } - -cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Clones a fresh unique -cloneTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; uniq <- newUnique - ; let name' = name `setNameUnique` uniq - tyvar = mkTcTyVar name' kind details - -- Don't use cloneMetaTyVar, which makes a SystemName - -- We want to keep the original more user-friendly Name - -- In practical terms that means that in error messages, - -- when the Name is tidied we get 'a' rather than 'a0' - ; traceTc "cloneTyVarTyVar" (ppr tyvar) - ; return tyvar } - -newPatSigTyVar :: Name -> Kind -> TcM TcTyVar -newPatSigTyVar name kind - = do { details <- newMetaDetails TauTv - ; uniq <- newUnique - ; let name' = name `setNameUnique` uniq - tyvar = mkTcTyVar name' kind details - -- Don't use cloneMetaTyVar; - -- same reasoning as in newTyVarTyVar - ; traceTc "newPatSigTyVar" (ppr tyvar) - ; return tyvar } - -cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar --- Make a fresh MetaTyVar, basing the name --- on that of the supplied TyVar -cloneAnonMetaTyVar info tv kind - = do { details <- newMetaDetails info - ; name <- cloneMetaTyVarName (tyVarName tv) - ; let tyvar = mkTcTyVar name kind details - ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) - ; return tyvar } - -newFskTyVar :: TcType -> TcM TcTyVar -newFskTyVar fam_ty - = do { details <- newMetaDetails FlatSkolTv - ; name <- newMetaTyVarName (fsLit "fsk") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } - -newFmvTyVar :: TcType -> TcM TcTyVar --- Very like newMetaTyVar, except sets mtv_tclvl to one less --- so that the fmv is untouchable. -newFmvTyVar fam_ty - = do { details <- newMetaDetails FlatMetaTv - ; name <- newMetaTyVarName (fsLit "s") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } - -newMetaDetails :: MetaInfo -> TcM TcTyVarDetails -newMetaDetails info - = do { ref <- newMutVar Flexi - ; tclvl <- getTcLevel - ; return (MetaTv { mtv_info = info - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -cloneMetaTyVar :: TcTyVar -> TcM TcTyVar -cloneMetaTyVar tv - = ASSERT( isTcTyVar tv ) - do { ref <- newMutVar Flexi - ; name' <- cloneMetaTyVarName (tyVarName tv) - ; let details' = case tcTyVarDetails tv of - details@(MetaTv {}) -> details { mtv_ref = ref } - _ -> pprPanic "cloneMetaTyVar" (ppr tv) - tyvar = mkTcTyVar name' (tyVarKind tv) details' - ; traceTc "cloneMetaTyVar" (ppr tyvar) - ; return tyvar } - --- Works for both type and kind variables -readMetaTyVar :: TyVar -> TcM MetaDetails -readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) - readMutVar (metaTyVarRef tyvar) - -isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) -isFilledMetaTyVar_maybe tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { cts <- readTcRef ref - ; case cts of - Indirect ty -> return (Just ty) - Flexi -> return Nothing } - | otherwise - = return Nothing - -isFilledMetaTyVar :: TyVar -> TcM Bool --- True of a filled-in (Indirect) meta type variable -isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv - -isUnfilledMetaTyVar :: TyVar -> TcM Bool --- True of a un-filled-in (Flexi) meta type variable --- NB: Not the opposite of isFilledMetaTyVar -isUnfilledMetaTyVar tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { details <- readMutVar ref - ; return (isFlexi details) } - | otherwise = return False - --------------------- --- Works with both type and kind variables -writeMetaTyVar :: TcTyVar -> TcType -> TcM () --- Write into a currently-empty MetaTyVar - -writeMetaTyVar tyvar ty - | not debugIsOn - = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty - --- Everything from here on only happens if DEBUG is on - | not (isTcTyVar tyvar) - = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar ) - return () - - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar - = writeMetaTyVarRef tyvar ref ty - - | otherwise - = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar ) - return () - --------------------- -writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () --- Here the tyvar is for error checking only; --- the ref cell must be for the same tyvar -writeMetaTyVarRef tyvar ref ty - | not debugIsOn - = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - <+> text ":=" <+> ppr ty) - ; writeTcRef ref (Indirect ty) } - - -- Everything from here on only happens if DEBUG is on - | otherwise - = do { meta_details <- readMutVar ref; - -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcType tv_kind - ; zonked_ty_kind <- zonkTcType ty_kind - ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind - || tcEqKind zonked_ty_kind zonked_tv_kind - -- Hack alert! tcIsConstraintKind: see TcHsType - -- Note [Extra-constraint holes in partial type signatures] - - kind_msg = hang (text "Ill-kinded update to meta tyvar") - 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) - <+> text ":=" - <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) - - ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - - -- Check for double updates - ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details ) - - -- Check for level OK - -- See Note [Level check when unifying] - ; MASSERT2( level_check_ok, level_check_msg ) - - -- Check Kinds ok - ; MASSERT2( kind_check_ok, kind_msg ) - - -- Do the write - ; writeMutVar ref (Indirect ty) } - where - tv_kind = tyVarKind tyvar - ty_kind = tcTypeKind ty - - tv_lvl = tcTyVarLevel tyvar - ty_lvl = tcTypeLevel ty - - level_check_ok = not (ty_lvl `strictlyDeeperThan` tv_lvl) - level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty - - double_upd_msg details = hang (text "Double update of meta tyvar") - 2 (ppr tyvar $$ ppr details) - -{- Note [Level check when unifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When unifying - alpha:lvl := ty -we expect that the TcLevel of 'ty' will be <= lvl. -However, during unflatting we do - fuv:l := ty:(l+1) -which is usually wrong; hence the check isFmmvTyVar in level_check_ok. -See Note [TcLevel assignment] in TcType. --} - -{- -% Generating fresh variables for pattern match check --} - - -{- -************************************************************************ -* * - MetaTvs: TauTvs -* * -************************************************************************ - -Note [Never need to instantiate coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With coercion variables sloshing around in types, it might seem that we -sometimes need to instantiate coercion variables. This would be problematic, -because coercion variables inhabit unboxed equality (~#), and the constraint -solver thinks in terms only of boxed equality (~). The solution is that -we never need to instantiate coercion variables in the first place. - -The tyvars that we need to instantiate come from the types of functions, -data constructors, and patterns. These will never be quantified over -coercion variables, except for the special case of the promoted Eq#. But, -that can't ever appear in user code, so we're safe! --} - - -newFlexiTyVar :: Kind -> TcM TcTyVar -newFlexiTyVar kind = newAnonMetaTyVar TauTv kind - -newFlexiTyVarTy :: Kind -> TcM TcType -newFlexiTyVarTy kind = do - tc_tyvar <- newFlexiTyVar kind - return (mkTyVarTy tc_tyvar) - -newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] -newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) - -newOpenTypeKind :: TcM TcKind -newOpenTypeKind - = do { rr <- newFlexiTyVarTy runtimeRepTy - ; return (tYPE rr) } - --- | Create a tyvar that can be a lifted or unlifted type. --- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh -newOpenFlexiTyVarTy :: TcM TcType -newOpenFlexiTyVarTy - = do { kind <- newOpenTypeKind - ; newFlexiTyVarTy kind } - -newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Instantiate with META type variables --- Note that this works for a sequence of kind, type, and coercion variables --- variables. Eg [ (k:*), (a:k->k) ] --- Gives [ (k7:*), (a8:k7->k7) ] -newMetaTyVars = newMetaTyVarsX emptyTCvSubst - -- emptyTCvSubst has an empty in-scope set, but that's fine here - -- Since the tyvars are freshly made, they cannot possibly be - -- captured by any existing for-alls. - -newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Just like newMetaTyVars, but start with an existing substitution. -newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst - -newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Make a new unification variable tyvar whose Name and Kind come from --- an existing TyVar. We substitute kind variables in the kind. -newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar - -newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst - -newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar - -newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -newWildCardX subst tv - = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) - ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } - -new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -new_meta_tv_x info subst tv - = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind - ; let subst1 = extendTvSubstWithClone subst tv new_tv - ; return (subst1, new_tv) } - where - substd_kind = substTyUnchecked subst (tyVarKind tv) - -- NOTE: #12549 is fixed so we could use - -- substTy here, but the tc_infer_args problem - -- is not yet fixed so leaving as unchecked for now. - -- OLD NOTE: - -- Unchecked because we call newMetaTyVarX from - -- tcInstTyBinder, which is called from tcInferApps - -- which does not yet take enough trouble to ensure - -- the in-scope set is right; e.g. #12785 trips - -- if we use substTy here - -newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType -newMetaTyVarTyAtLevel tc_lvl kind - = do { ref <- newMutVar Flexi - ; name <- newMetaTyVarName (fsLit "p") - ; let details = MetaTv { mtv_info = TauTv - , mtv_ref = ref - , mtv_tclvl = tc_lvl } - ; return (mkTyVarTy (mkTcTyVar name kind details)) } - -{- ********************************************************************* -* * - Finding variables to quantify over -* * -********************************************************************* -} - -{- Note [Dependent type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell type inference we quantify over type variables; but we only -quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds -we default the kind variables to *. - -So, to support this defaulting, and only for that reason, when -collecting the free vars of a type (in candidateQTyVarsOfType and friends), -prior to quantifying, we must keep the type and kind variables separate. - -But what does that mean in a system where kind variables /are/ type -variables? It's a fairly arbitrary distinction based on how the -variables appear: - - - "Kind variables" appear in the kind of some other free variable - or in the kind of a locally quantified type variable - (forall (a :: kappa). ...) or in the kind of a coercion - (a |> (co :: kappa1 ~ kappa2)). - - These are the ones we default to * if -XPolyKinds is off - - - "Type variables" are all free vars that are not kind variables - -E.g. In the type T k (a::k) - 'k' is a kind variable, because it occurs in the kind of 'a', - even though it also appears at "top level" of the type - 'a' is a type variable, because it doesn't - -We gather these variables using a CandidatesQTvs record: - DV { dv_kvs: Variables free in the kind of a free type variable - or of a forall-bound type variable - , dv_tvs: Variables sytactically free in the type } - -So: dv_kvs are the kind variables of the type - (dv_tvs - dv_kvs) are the type variable of the type - -Note that - -* A variable can occur in both. - T k (x::k) The first occurrence of k makes it - show up in dv_tvs, the second in dv_kvs - -* We include any coercion variables in the "dependent", - "kind-variable" set because we never quantify over them. - -* The "kind variables" might depend on each other; e.g - (k1 :: k2), (k2 :: *) - The "type variables" do not depend on each other; if - one did, it'd be classified as a kind variable! - -Note [CandidatesQTvs determinism and order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Determinism: when we quantify over type variables we decide the - order in which they appear in the final type. Because the order of - type variables in the type can end up in the interface file and - affects some optimizations like worker-wrapper, we want this order to - be deterministic. - - To achieve that we use deterministic sets of variables that can be - converted to lists in a deterministic order. For more information - about deterministic sets see Note [Deterministic UniqFM] in UniqDFM. - -* Order: as well as being deterministic, we use an - accumulating-parameter style for candidateQTyVarsOfType so that we - add variables one at a time, left to right. That means we tend to - produce the variables in left-to-right order. This is just to make - it bit more predictable for the programmer. - -Note [Naughty quantification candidates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14880, dependent/should_compile/T14880-2), suppose -we are trying to generalise this type: - - forall arg. ... (alpha[tau]:arg) ... - -We have a metavariable alpha whose kind mentions a skolem variable -bound inside the very type we are generalising. -This can arise while type-checking a user-written type signature -(see the test case for the full code). - -We cannot generalise over alpha! That would produce a type like - forall {a :: arg}. forall arg. ...blah... -The fact that alpha's kind mentions arg renders it completely -ineligible for generalisation. - -However, we are not going to learn any new constraints on alpha, -because its kind isn't even in scope in the outer context (but see Wrinkle). -So alpha is entirely unconstrained. - -What then should we do with alpha? During generalization, every -metavariable is either (A) promoted, (B) generalized, or (C) zapped -(according again to Note [Recipe for checking a signature] in -TcHsType). - - * We can't generalise it. - * We can't promote it, because its kind prevents that - * We can't simply leave it be, because this type is about to - go into the typing environment (as the type of some let-bound - variable, say), and then chaos erupts when we try to instantiate. - -So, we zap it, eagerly, to Any. We don't have to do this eager zapping -in terms (say, in `length []`) because terms are never re-examined before -the final zonk (which zaps any lingering metavariables to Any). - -We do this eager zapping in candidateQTyVars, which always precedes -generalisation, because at that moment we have a clear picture of what -skolems are in scope within the type itself (e.g. that 'forall arg'). - -Wrinkle: - -We must make absolutely sure that alpha indeed is not -from an outer context. (Otherwise, we might indeed learn more information -about it.) This can be done easily: we just check alpha's TcLevel. -That level must be strictly greater than the ambient TcLevel in order -to treat it as naughty. We say "strictly greater than" because the call to -candidateQTyVars is made outside the bumped TcLevel, as stated in the -comment to candidateQTyVarsOfType. The level check is done in go_tv -in collect_cand_qtvs. Skipping this check caused #16517. - --} - -data CandidatesQTvs - -- See Note [Dependent type variables] - -- See Note [CandidatesQTvs determinism and order] - -- - -- Invariants: - -- * All variables are fully zonked, including their kinds - -- * All variables are at a level greater than the ambient level - -- See Note [Use level numbers for quantification] - -- - -- This *can* contain skolems. For example, in `data X k :: k -> Type` - -- we need to know that the k is a dependent variable. This is done - -- by collecting the candidates in the kind after skolemising. It also - -- comes up when generalizing a associated type instance, where instance - -- variables are skolems. (Recall that associated type instances are generalized - -- independently from their enclosing class instance, and the associated - -- type instance may be generalized by more, fewer, or different variables - -- than the class instance.) - -- - = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) - , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) - -- A variable may appear in both sets - -- E.g. T k (x::k) The first occurrence of k makes it - -- show up in dv_tvs, the second in dv_kvs - -- See Note [Dependent type variables] - - , dv_cvs :: CoVarSet - -- These are covars. Included only so that we don't repeatedly - -- look at covars' kinds in accumulator. Not used by quantifyTyVars. - } - -instance Semi.Semigroup CandidatesQTvs where - (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) - <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) - = DV { dv_kvs = kv1 `unionDVarSet` kv2 - , dv_tvs = tv1 `unionDVarSet` tv2 - , dv_cvs = cv1 `unionVarSet` cv2 } - -instance Monoid CandidatesQTvs where - mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } - mappend = (Semi.<>) - -instance Outputable CandidatesQTvs where - ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) - = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs - , text "dv_tvs =" <+> ppr tvs - , text "dv_cvs =" <+> ppr cvs ]) - - -candidateKindVars :: CandidatesQTvs -> TyVarSet -candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) - -partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs) -partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred - = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) - where - (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs - (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs - extracted = extracted_kvs `unionDVarSet` extracted_tvs - --- | Gathers free variables to use as quantification candidates (in --- 'quantifyTyVars'). This might output the same var --- in both sets, if it's used in both a type and a kind. --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) --- See Note [CandidatesQTvs determinism and order] --- See Note [Dependent type variables] -candidateQTyVarsOfType :: TcType -- not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty - --- | Like 'candidateQTyVarsOfType', but over a list of types --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) -candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs -candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys - --- | Like 'candidateQTyVarsOfType', but consider every free variable --- to be dependent. This is appropriate when generalizing a *kind*, --- instead of a type. (That way, -XNoPolyKinds will default the variables --- to Type.) -candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKind ty = collect_cand_qtvs True emptyVarSet mempty ty - -candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKinds tys = foldM (collect_cand_qtvs True emptyVarSet) mempty tys - -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs -delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars - = DV { dv_kvs = kvs `delDVarSetList` vars - , dv_tvs = tvs `delDVarSetList` vars - , dv_cvs = cvs `delVarSetList` vars } - -collect_cand_qtvs - :: Bool -- True <=> consider every fv in Type to be dependent - -> VarSet -- Bound variables (locals only) - -> CandidatesQTvs -- Accumulating parameter - -> Type -- Not necessarily zonked - -> TcM CandidatesQTvs - --- Key points: --- * Looks through meta-tyvars as it goes; --- no need to zonk in advance --- --- * Needs to be monadic anyway, because it does the zap-naughty --- stuff; see Note [Naughty quantification candidates] --- --- * Returns fully-zonked CandidateQTvs, including their kinds --- so that subsequent dependency analysis (to build a well --- scoped telescope) works correctly - -collect_cand_qtvs is_dep bound dvs ty - = go dvs ty - where - is_bound tv = tv `elemVarSet` bound - - ----------------- - go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs - -- Uses accumulating-parameter style - go dv (AppTy t1 t2) = foldlM go dv [t1, t2] - go dv (TyConApp _ tys) = foldlM go dv tys - go dv (FunTy _ arg res) = foldlM go dv [arg, res] - go dv (LitTy {}) = return dv - go dv (CastTy ty co) = do dv1 <- go dv ty - collect_cand_qtvs_co bound dv1 co - go dv (CoercionTy co) = collect_cand_qtvs_co bound dv co - - go dv (TyVarTy tv) - | is_bound tv = return dv - | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv - ; case m_contents of - Just ind_ty -> go dv ind_ty - Nothing -> go_tv dv tv } - - go dv (ForAllTy (Bndr tv _) ty) - = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv) - ; collect_cand_qtvs is_dep (bound `extendVarSet` tv) dv1 ty } - - ----------------- - go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv - | tv `elemDVarSet` kvs - = return dv -- We have met this tyvar aleady - - | not is_dep - , tv `elemDVarSet` tvs - = return dv -- We have met this tyvar aleady - - | otherwise - = do { tv_kind <- zonkTcType (tyVarKind tv) - -- This zonk is annoying, but it is necessary, both to - -- ensure that the collected candidates have zonked kinds - -- (#15795) and to make the naughty check - -- (which comes next) works correctly - - ; cur_lvl <- getTcLevel - ; if | tcTyVarLevel tv <= cur_lvl - -> return dv -- this variable is from an outer context; skip - -- See Note [Use level numbers ofor quantification] - - | intersectsVarSet bound (tyCoVarsOfType tv_kind) - -- the tyvar must not be from an outer context, but we have - -- already checked for this. - -- See Note [Naughty quantification candidates] - -> do { traceTc "Zapping naughty quantifier" $ - vcat [ ppr tv <+> dcolon <+> ppr tv_kind - , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) - , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet $ - tyCoVarsOfType tv_kind) ] - - ; writeMetaTyVar tv (anyTypeOfKind tv_kind) - - -- See Note [Recurring into kinds for candidateQTyVars] - ; collect_cand_qtvs True bound dv tv_kind } - - | otherwise - -> do { let tv' = tv `setTyVarKind` tv_kind - dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } - | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } - -- See Note [Order of accumulation] - - -- See Note [Recurring into kinds for candidateQTyVars] - ; collect_cand_qtvs True bound dv' tv_kind } } - -collect_cand_qtvs_co :: VarSet -- bound variables - -> CandidatesQTvs -> Coercion - -> TcM CandidatesQTvs -collect_cand_qtvs_co bound = go_co - where - go_co dv (Refl ty) = collect_cand_qtvs True bound dv ty - go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs True bound dv ty - go_mco dv1 mco - go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos - go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (FunCo _ co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos - go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos - go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov - dv2 <- collect_cand_qtvs True bound dv1 t1 - collect_cand_qtvs True bound dv2 t2 - go_co dv (SymCo co) = go_co dv co - go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (NthCo _ _ co) = go_co dv co - go_co dv (LRCo _ co) = go_co dv co - go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (KindCo co) = go_co dv co - go_co dv (SubCo co) = go_co dv co - - go_co dv (HoleCo hole) - = do m_co <- unpackCoercionHole_maybe hole - case m_co of - Just co -> go_co dv co - Nothing -> go_cv dv (coHoleCoVar hole) - - go_co dv (CoVarCo cv) = go_cv dv cv - - go_co dv (ForAllCo tcv kind_co co) - = do { dv1 <- go_co dv kind_co - ; collect_cand_qtvs_co (bound `extendVarSet` tcv) dv1 co } - - go_mco dv MRefl = return dv - go_mco dv (MCo co) = go_co dv co - - go_prov dv UnsafeCoerceProv = return dv - go_prov dv (PhantomProv co) = go_co dv co - go_prov dv (ProofIrrelProv co) = go_co dv co - go_prov dv (PluginProv _) = return dv - - go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs - go_cv dv@(DV { dv_cvs = cvs }) cv - | is_bound cv = return dv - | cv `elemVarSet` cvs = return dv - - -- See Note [Recurring into kinds for candidateQTyVars] - | otherwise = collect_cand_qtvs True bound - (dv { dv_cvs = cvs `extendVarSet` cv }) - (idType cv) - - is_bound tv = tv `elemVarSet` bound - -{- Note [Order of accumulation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might be tempted (like I was) to use unitDVarSet and mappend -rather than extendDVarSet. However, the union algorithm for -deterministic sets depends on (roughly) the size of the sets. The -elements from the smaller set end up to the right of the elements from -the larger one. When sets are equal, the left-hand argument to -`mappend` goes to the right of the right-hand argument. - -In our case, if we use unitDVarSet and mappend, we learn that the free -variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify -over them in that order. (The a comes after the b because we union the -singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, -the size criterion works to our advantage.) This is just annoying to -users, so I use `extendDVarSet`, which unambiguously puts the new -element to the right. - -Note that the unitDVarSet/mappend implementation would not be wrong -against any specification -- just suboptimal and confounding to users. - -Note [Recurring into kinds for candidateQTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First, read Note [Closing over free variable kinds] in TyCoFVs, paying -attention to the end of the Note about using an empty bound set when -traversing a variable's kind. - -That Note concludes with the recommendation that we empty out the bound -set when recurring into the kind of a type variable. Yet, we do not do -this here. I have two tasks in order to convince you that this code is -right. First, I must show why it is safe to ignore the reasoning in that -Note. Then, I must show why is is necessary to contradict the reasoning in -that Note. - -Why it is safe: There can be no -shadowing in the candidateQ... functions: they work on the output of -type inference, which is seeded by the renamer and its insistence to -use different Uniques for different variables. (In contrast, the Core -functions work on the output of optimizations, which may introduce -shadowing.) Without shadowing, the problem studied by -Note [Closing over free variable kinds] in TyCoFVs cannot happen. - -Why it is necessary: -Wiping the bound set would be just plain wrong here. Consider - - forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) - -We really don't want to think k1 and k2 are free here. (It's true that we'll -never be able to fill in `hole`, but we don't want to go off the rails just -because we have an insoluble coercion hole.) So: why is it wrong to wipe -the bound variables here but right in Core? Because the final statement -in Note [Closing over free variable kinds] in TyCoFVs is wrong: not -every variable is either free or bound. A variable can be a hole, too! -The reasoning in that Note then breaks down. - -And the reasoning applies just as well to free non-hole variables, so we -retain the bound set always. - --} - -{- ********************************************************************* -* * - Quantification -* * -************************************************************************ - -Note [quantifyTyVars] -~~~~~~~~~~~~~~~~~~~~~ -quantifyTyVars is given the free vars of a type that we -are about to wrap in a forall. - -It takes these free type/kind variables (partitioned into dependent and -non-dependent variables) skolemises metavariables with a TcLevel greater -than the ambient level (see Note [Use level numbers of quantification]). - -* This function distinguishes between dependent and non-dependent - variables only to keep correct defaulting behavior with -XNoPolyKinds. - With -XPolyKinds, it treats both classes of variables identically. - -* quantifyTyVars never quantifies over - - a coercion variable (or any tv mentioned in the kind of a covar) - - a runtime-rep variable - -Note [Use level numbers for quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The level numbers assigned to metavariables are very useful. Not only -do they track touchability (Note [TcLevel and untouchable type variables] -in TcType), but they also allow us to determine which variables to -generalise. The rule is this: - - When generalising, quantify only metavariables with a TcLevel greater - than the ambient level. - -This works because we bump the level every time we go inside a new -source-level construct. In a traditional generalisation algorithm, we -would gather all free variables that aren't free in an environment. -However, if a variable is in that environment, it will always have a lower -TcLevel: it came from an outer scope. So we can replace the "free in -environment" check with a level-number check. - -Here is an example: - - f x = x + (z True) - where - z y = x * x - -We start by saying (x :: alpha[1]). When inferring the type of z, we'll -quickly discover that z :: alpha[1]. But it would be disastrous to -generalise over alpha in the type of z. So we need to know that alpha -comes from an outer environment. By contrast, the type of y is beta[2], -and we are free to generalise over it. What's the difference between -alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for -generalisation, and so we generalise it. alpha[1] does not, and so -we leave it alone. - -Note that not *every* variable with a higher level will get generalised, -either due to the monomorphism restriction or other quirks. See, for -example, the code in TcSimplify.decideMonoTyVars and in -TcHsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible -variables from being generalised. - -Using level numbers for quantification is implemented in the candidateQTyVars... -functions, by adding only those variables with a level strictly higher than -the ambient level to the set of candidates. - -Note [quantifyTyVars determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The results of quantifyTyVars are wrapped in a forall and can end up in the -interface file. One such example is inferred type signatures. They also affect -the results of optimizations, for example worker-wrapper. This means that to -get deterministic builds quantifyTyVars needs to be deterministic. - -To achieve this CandidatesQTvs is backed by deterministic sets which allows them -to be later converted to a list in a deterministic order. - -For more information about deterministic sets see -Note [Deterministic UniqFM] in UniqDFM. --} - -quantifyTyVars - :: CandidatesQTvs -- See Note [Dependent type variables] - -- Already zonked - -> TcM [TcTyVar] --- See Note [quantifyTyVars] --- Can be given a mixture of TcTyVars and TyVars, in the case of --- associated type declarations. Also accepts covars, but *never* returns any. --- According to Note [Use level numbers for quantification] and the --- invariants on CandidateQTvs, we do not have to filter out variables --- free in the environment here. Just quantify unconditionally, subject --- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) - -- short-circuit common case - | isEmptyDVarSet dep_tkvs - , isEmptyDVarSet nondep_tkvs - = do { traceTc "quantifyTyVars has nothing to quantify" empty - ; return [] } - - | otherwise - = do { traceTc "quantifyTyVars 1" (ppr dvs) - - ; let dep_kvs = scopedSort $ dVarSetElems dep_tkvs - -- scopedSort: put the kind variables into - -- well-scoped order. - -- E.g. [k, (a::k)] not the other way roud - - nondep_tvs = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs) - -- See Note [Dependent type variables] - -- The `minus` dep_tkvs removes any kind-level vars - -- e.g. T k (a::k) Since k appear in a kind it'll - -- be in dv_kvs, and is dependent. So remove it from - -- dv_tvs which will also contain k - -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV - - -- In the non-PolyKinds case, default the kind variables - -- to *, and zonk the tyvars as usual. Notice that this - -- may make quantifyTyVars return a shorter list - -- than it was passed, but that's ok - ; poly_kinds <- xoptM LangExt.PolyKinds - ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs - ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs - ; let final_qtvs = dep_kvs' ++ nondep_tvs' - -- Because of the order, any kind variables - -- mentioned in the kinds of the nondep_tvs' - -- now refer to the dep_kvs' - - ; traceTc "quantifyTyVars 2" - (vcat [ text "nondep:" <+> pprTyVars nondep_tvs - , text "dep:" <+> pprTyVars dep_kvs - , text "dep_kvs'" <+> pprTyVars dep_kvs' - , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ]) - - -- We should never quantify over coercion variables; check this - ; let co_vars = filter isCoVar final_qtvs - ; MASSERT2( null co_vars, ppr co_vars ) - - ; return final_qtvs } - where - -- zonk_quant returns a tyvar if it should be quantified over; - -- otherwise, it returns Nothing. The latter case happens for - -- * Kind variables, with -XNoPolyKinds: don't quantify over these - -- * RuntimeRep variables: we never quantify over these - zonk_quant default_kind tkv - | not (isTyVar tkv) - = return Nothing -- this can happen for a covar that's associated with - -- a coercion hole. Test case: typecheck/should_compile/T2494 - - | not (isTcTyVar tkv) - = return (Just tkv) -- For associated types in a class with a standalone - -- kind signature, we have the class variables in - -- scope, and they are TyVars not TcTyVars - | otherwise - = do { deflt_done <- defaultTyVar default_kind tkv - ; case deflt_done of - True -> return Nothing - False -> do { tv <- skolemiseQuantifiedTyVar tkv - ; return (Just tv) } } - -isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification - -> TcTyVar - -> Bool -isQuantifiableTv outer_tclvl tcv - | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately - = tcTyVarLevel tcv > outer_tclvl - | otherwise - = False - -zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar --- A tyvar binder is never a unification variable (TauTv), --- rather it is always a skolem. It *might* be a TyVarTv. --- (Because non-CUSK type declarations use TyVarTvs.) --- Regardless, it may have a kind that has not yet been zonked, --- and may include kind unification variables. -zonkAndSkolemise tyvar - | isTyVarTyVar tyvar - -- We want to preserve the binding location of the original TyVarTv. - -- This is important for error messages. If we don't do this, then - -- we get bad locations in, e.g., typecheck/should_fail/T2688 - = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar - ; skolemiseQuantifiedTyVar zonked_tyvar } - - | otherwise - = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar ) - zonkTyCoVarKind tyvar - -skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar --- The quantified type variables often include meta type variables --- we want to freeze them into ordinary type variables --- The meta tyvar is updated to point to the new skolem TyVar. Now any --- bound occurrences of the original type variable will get zonked to --- the immutable version. --- --- We leave skolem TyVars alone; they are immutable. --- --- This function is called on both kind and type variables, --- but kind variables *only* if PolyKinds is on. - -skolemiseQuantifiedTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind) } - -- It might be a skolem type variable, - -- for example from a user type signature - - MetaTv {} -> skolemiseUnboundMetaTyVar tv - - _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk - -defaultTyVar :: Bool -- True <=> please default this kind variable to * - -> TcTyVar -- If it's a MetaTyVar then it is unbound - -> TcM Bool -- True <=> defaulted away altogether - -defaultTyVar default_kind tv - | not (isMetaTyVar tv) - = return False - - | isTyVarTyVar tv - -- Do not default TyVarTvs. Doing so would violate the invariants - -- on TyVarTvs; see Note [Signature skolems] in TcType. - -- #13343 is an example; #14555 is another - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - = return False - - - | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var - -- unless it is a TyVarTv, handled earlier - = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) - ; writeMetaTyVar tv liftedRepTy - ; return True } - - | default_kind -- -XNoPolyKinds and this is a kind var - = default_kind_var tv -- so default it to * if possible - - | otherwise - = return False - - where - default_kind_var :: TyVar -> TcM Bool - -- defaultKindVar is used exclusively with -XNoPolyKinds - -- See Note [Defaulting with -XNoPolyKinds] - -- It takes an (unconstrained) meta tyvar and defaults it. - -- Works only on vars of type *; for other kinds, it issues an error. - default_kind_var kv - | isLiftedTypeKind (tyVarKind kv) - = do { traceTc "Defaulting a kind var to *" (ppr kv) - ; writeMetaTyVar kv liftedTypeKind - ; return True } - | otherwise - = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) - -- We failed to default it, so return False to say so. - -- Hence, it'll get skolemised. That might seem odd, but we must either - -- promote, skolemise, or zap-to-Any, to satisfy TcHsType - -- Note [Recipe for checking a signature] - -- Otherwise we get level-number assertion failures. It doesn't matter much - -- because we are in an error siutation anyway. - ; return False - } - where - (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv - -skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar --- We have a Meta tyvar with a ref-cell inside it --- Skolemise it, so that we are totally out of Meta-tyvar-land --- We create a skolem TcTyVar, not a regular TyVar --- See Note [Zonking to Skolem] -skolemiseUnboundMetaTyVar tv - = ASSERT2( isMetaTyVar tv, ppr tv ) - do { when debugIsOn (check_empty tv) - ; here <- getSrcSpanM -- Get the location from "here" - -- ie where we are generalising - ; kind <- zonkTcType (tyVarKind tv) - ; let tv_name = tyVarName tv - -- See Note [Skolemising and identity] - final_name | isSystemName tv_name - = mkInternalName (nameUnique tv_name) - (nameOccName tv_name) here - | otherwise - = tv_name - final_tv = mkTcTyVar final_name kind details - - ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) - ; writeMetaTyVar tv (mkTyVarTy final_tv) - ; return final_tv } - - where - details = SkolemTv (metaTyVarTcLevel tv) False - check_empty tv -- [Sept 04] Check for non-empty. - = when debugIsOn $ -- See note [Silly Type Synonym] - do { cts <- readMetaTyVar tv - ; case cts of - Flexi -> return () - Indirect ty -> WARN( True, ppr tv $$ ppr ty ) - return () } - -{- Note [Defaulting with -XNoPolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Compose f g a = Mk (f (g a)) - -We infer - - Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * - Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). - f (g a) -> Compose k1 k2 f g a - -Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. -What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, -we just defaulted all kind variables to *. But that's no good here, -because the kind variables in 'Mk aren't of kind *, so defaulting to * -is ill-kinded. - -After some debate on #11334, we decided to issue an error in this case. -The code is in defaultKindVar. - -Note [What is a meta variable?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "meta type-variable", also know as a "unification variable" is a placeholder -introduced by the typechecker for an as-yet-unknown monotype. - -For example, when we see a call `reverse (f xs)`, we know that we calling - reverse :: forall a. [a] -> [a] -So we know that the argument `f xs` must be a "list of something". But what is -the "something"? We don't know until we explore the `f xs` a bit more. So we set -out what we do know at the call of `reverse` by instantiating its type with a fresh -meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the -result, is `[alpha]`. The unification variable `alpha` stands for the -as-yet-unknown type of the elements of the list. - -As type inference progresses we may learn more about `alpha`. For example, suppose -`f` has the type - f :: forall b. b -> [Maybe b] -Then we instantiate `f`'s type with another fresh unification variable, say -`beta`; and equate `f`'s result type with reverse's argument type, thus -`[alpha] ~ [Maybe beta]`. - -Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've -refined our knowledge about `alpha`. And so on. - -If you found this Note useful, you may also want to have a look at -Section 5 of "Practical type inference for higher rank types" (Peyton Jones, -Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). - -Note [What is zonking?] -~~~~~~~~~~~~~~~~~~~~~~~ -GHC relies heavily on mutability in the typechecker for efficient operation. -For this reason, throughout much of the type checking process meta type -variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable -variables (known as TcRefs). - -Zonking is the process of ripping out these mutable variables and replacing them -with a real Type. This involves traversing the entire type expression, but the -interesting part of replacing the mutable variables occurs in zonkTyVarOcc. - -There are two ways to zonk a Type: - - * zonkTcTypeToType, which is intended to be used at the end of type-checking - for the final zonk. It has to deal with unfilled metavars, either by filling - it with a value like Any or failing (determined by the UnboundTyVarZonker - used). - - * zonkTcType, which will happily ignore unfilled metavars. This is the - appropriate function to use while in the middle of type-checking. - -Note [Zonking to Skolem] -~~~~~~~~~~~~~~~~~~~~~~~~ -We used to zonk quantified type variables to regular TyVars. However, this -leads to problems. Consider this program from the regression test suite: - - eval :: Int -> String -> String -> String - eval 0 root actual = evalRHS 0 root actual - - evalRHS :: Int -> a - evalRHS 0 root actual = eval 0 root actual - -It leads to the deferral of an equality (wrapped in an implication constraint) - - forall a. () => ((String -> String -> String) ~ a) - -which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck). -In the meantime `a' is zonked and quantified to form `evalRHS's signature. -This has the *side effect* of also zonking the `a' in the deferred equality -(which at this point is being handed around wrapped in an implication -constraint). - -Finally, the equality (with the zonked `a') will be handed back to the -simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop. -If we zonk `a' with a regular type variable, we will have this regular type -variable now floating around in the simplifier, which in many places assumes to -only see proper TcTyVars. - -We can avoid this problem by zonking with a skolem TcTyVar. The -skolem is rigid (which we require for a quantified variable), but is -still a TcTyVar that the simplifier knows how to deal with. - -Note [Skolemising and identity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some places, we make a TyVarTv for a binder. E.g. - class C a where ... -As Note [Inferring kinds for type declarations] discusses, -we make a TyVarTv for 'a'. Later we skolemise it, and we'd -like to retain its identity, location info etc. (If we don't -retain its identity we'll have to do some pointless swizzling; -see TcTyClsDecls.swizzleTcTyConBndrs. If we retain its identity -but not its location we'll lose the detailed binding site info. - -Conclusion: use the Name of the TyVarTv. But we don't want -to do that when skolemising random unification variables; -there the location we want is the skolemisation site. - -Fortunately we can tell the difference: random unification -variables have System Names. That's why final_name is -set based on the isSystemName test. - - -Note [Silly Type Synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - type C u a = u -- Note 'a' unused - - foo :: (forall a. C u a -> C u a) -> u - foo x = ... - - bar :: Num u => u - bar = foo (\t -> t + t) - -* From the (\t -> t+t) we get type {Num d} => d -> d - where d is fresh. - -* Now unify with type of foo's arg, and we get: - {Num (C d a)} => C d a -> C d a - where a is fresh. - -* Now abstract over the 'a', but float out the Num (C d a) constraint - because it does not 'really' mention a. (see exactTyVarsOfType) - The arg to foo becomes - \/\a -> \t -> t+t - -* So we get a dict binding for Num (C d a), which is zonked to give - a = () - [Note Sept 04: now that we are zonking quantified type variables - on construction, the 'a' will be frozen as a regular tyvar on - quantification, so the floated dict will still have type (C d a). - Which renders this whole note moot; happily!] - -* Then the \/\a abstraction has a zonked 'a' in it. - -All very silly. I think its harmless to ignore the problem. We'll end up with -a \/\a in the final result but all the occurrences of a will be zonked to () - -************************************************************************ -* * - Zonking types -* * -************************************************************************ - --} - -zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet --- Zonk a type and take its free variables --- With kind polymorphism it can be essential to zonk *first* --- so that we find the right set of free variables. Eg --- forall k1. forall (a:k2). a --- where k2:=k1 is in the substitution. We don't want --- k2 to look free in this type! -zonkTcTypeAndFV ty - = tyCoVarsOfTypeDSet <$> zonkTcType ty - -zonkTyCoVar :: TyCoVar -> TcM TcType --- Works on TyVars and TcTyVars -zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv - | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv - | otherwise = ASSERT2( isCoVar tv, ppr tv ) - mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv - -- Hackily, when typechecking type and class decls - -- we have TyVars in scope added (only) in - -- TcHsType.bindTyClTyVars, but it seems - -- painful to make them into TcTyVars there - -zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet -zonkTyCoVarsAndFV tycovars - = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) - -- It's OK to use nonDetEltsUniqSet here because we immediately forget about - -- the ordering by turning it into a nondeterministic set and the order - -- of zonking doesn't matter for determinism. - -zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet -zonkDTyCoVarSetAndFV tycovars - = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) - --- Takes a list of TyCoVars, zonks them and returns a --- deterministically ordered list of their free variables. -zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar] -zonkTyCoVarsAndFVList tycovars - = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars - -zonkTcTyVars :: [TcTyVar] -> TcM [TcType] -zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars - ------------------ Types -zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar -zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind') } - -zonkTcTypes :: [TcType] -> TcM [TcType] -zonkTcTypes tys = mapM zonkTcType tys - -{- -************************************************************************ -* * - Zonking constraints -* * -************************************************************************ --} - -zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_skols = skols - , ic_given = given - , ic_wanted = wanted - , ic_info = info }) - = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! - -- as #7230 showed - ; given' <- mapM zonkEvVar given - ; info' <- zonkSkolemInfo info - ; wanted' <- zonkWCRec wanted - ; return (implic { ic_skols = skols' - , ic_given = given' - , ic_wanted = wanted' - , ic_info = info' }) } - -zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = do { ty' <- zonkTcType (varType var) - ; return (setVarType var ty') } - - -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC wc = zonkWCRec wc - -zonkWCRec :: WantedConstraints -> TcM WantedConstraints -zonkWCRec (WC { wc_simple = simple, wc_impl = implic }) - = do { simple' <- zonkSimples simple - ; implic' <- mapBagM zonkImplication implic - ; return (WC { wc_simple = simple', wc_impl = implic' }) } - -zonkSimples :: Cts -> TcM Cts -zonkSimples cts = do { cts' <- mapBagM zonkCt cts - ; traceTc "zonkSimples done:" (ppr cts') - ; return cts' } - -{- Note [zonkCt behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -zonkCt tries to maintain the canonical form of a Ct. For example, - - a CDictCan should stay a CDictCan; - - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.). - - a CHoleCan should stay a CHoleCan - - a CIrredCan should stay a CIrredCan with its cc_insol flag intact - -Why?, for example: -- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the - simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, - constraints are zonked before being passed to the plugin. This means if we - don't preserve a canonical form, @expandSuperClasses@ fails to expand - superclasses. This is what happened in #11525. - -- For CHoleCan, once we forget that it's a hole, we can never recover that info. - -- For CIrredCan we want to see if a constraint is insoluble with insolubleWC - -NB: we do not expect to see any CFunEqCans, because zonkCt is only -called on unflattened constraints. - -NB: Constraints are always re-flattened etc by the canonicaliser in -@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that -are actually in the inert set carry all the guarantees. So it is okay if zonkCt -creates e.g. a CDictCan where the cc_tyars are /not/ function free. --} - -zonkCt :: Ct -> TcM Ct -zonkCt ct@(CHoleCan { cc_ev = ev }) - = do { ev' <- zonkCtEvidence ev - ; return $ ct { cc_ev = ev' } } - -zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) - = do { ev' <- zonkCtEvidence ev - ; args' <- mapM zonkTcType args - ; return $ ct { cc_ev = ev', cc_tyargs = args' } } - -zonkCt (CTyEqCan { cc_ev = ev }) - = mkNonCanonical <$> zonkCtEvidence ev - -- CTyEqCan has some delicate invariants that may be violated by - -- zonking (documented with the Ct type) , so we don't want to create - -- a CTyEqCan here. Besides, this will be canonicalized again anyway, - -- so there is very little benefit in keeping the CTyEqCan constructor. - -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_insol flag - = do { ev' <- zonkCtEvidence ev - ; return (ct { cc_ev = ev' }) } - -zonkCt ct - = ASSERT( not (isCFunEqCan ct) ) - -- We do not expect to see any CFunEqCans, because zonkCt is only called on - -- unflattened constraints. - do { fl' <- zonkCtEvidence (ctEvidence ct) - ; return (mkNonCanonical fl') } - -zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred'}) } -zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest }) - = do { pred' <- zonkTcType pred - ; let dest' = case dest of - EvVarDest ev -> EvVarDest $ setVarType ev pred' - -- necessary in simplifyInfer - HoleDest h -> HoleDest h - ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) } -zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred' }) } - -zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol ntys') } - where - do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfo skol_info = return skol_info - -{- -%************************************************************************ -%* * -\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} -* * -* For internal use only! * -* * -************************************************************************ - --} - --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id - = do { ty' <- zonkTcType (idType id) - ; return (Id.setIdType id ty') } - -zonkCoVar :: CoVar -> TcM CoVar -zonkCoVar = zonkId - --- | A suitable TyCoMapper for zonking a type during type-checking, --- before all metavars are filled in. -zonkTcTypeMapper :: TyCoMapper () TcM -zonkTcTypeMapper = TyCoMapper - { tcm_tyvar = const zonkTcTyVar - , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) - , tcm_hole = hole - , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv - , tcm_tycon = zonkTcTyCon } - where - hole :: () -> CoercionHole -> TcM Coercion - hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) - = do { contents <- readTcRef ref - ; case contents of - Just co -> do { co' <- zonkCo co - ; checkCoercionHole cv co' } - Nothing -> do { cv' <- zonkCoVar cv - ; return $ HoleCo (hole { ch_co_var = cv' }) } } - -zonkTcTyCon :: TcTyCon -> TcM TcTyCon --- Only called on TcTyCons --- A non-poly TcTyCon may have unification --- variables that need zonking, but poly ones cannot -zonkTcTyCon tc - | tcTyConIsPoly tc = return tc - | otherwise = do { tck' <- zonkTcType (tyConKind tc) - ; return (setTcTyConKind tc tck') } - --- For unbound, mutable tyvars, zonkType uses the function given to it --- For tyvars bound at a for-all, zonkType zonks them to an immutable --- type variable and zonks the kind too -zonkTcType :: TcType -> TcM TcType -zonkTcType = mapType zonkTcTypeMapper () - --- | "Zonk" a coercion -- really, just zonk any types in the coercion -zonkCo :: Coercion -> TcM Coercion -zonkCo = mapCoercion zonkTcTypeMapper () - -zonkTcTyVar :: TcTyVar -> TcM TcType --- Simply look through all Flexis -zonkTcTyVar tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> zonk_kind_and_return - RuntimeUnk {} -> zonk_kind_and_return - MetaTv { mtv_ref = ref } - -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> do { zty <- zonkTcType ty - ; writeTcRef ref (Indirect zty) - -- See Note [Sharing in zonking] - ; return zty } } - - | otherwise -- coercion variable - = zonk_kind_and_return - where - zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv - ; return (mkTyVarTy z_tv) } - --- Variant that assumes that any result of zonking is still a TyVar. --- Should be used only on skolems and TyVarTvs -zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar -zonkTcTyVarToTyVar tv - = do { ty <- zonkTcTyVar tv - ; let tv' = case tcGetTyVar_maybe ty of - Just tv' -> tv' - Nothing -> pprPanic "zonkTcTyVarToTyVar" - (ppr tv $$ ppr ty) - ; return tv' } - -zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)] -zonkTyVarTyVarPairs prs - = mapM do_one prs - where - do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv - ; return (nm, tv') } - -{- Note [Sharing in zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - alpha :-> beta :-> gamma :-> ty -where the ":->" means that the unification variable has been -filled in with Indirect. Then when zonking alpha, it'd be nice -to short-circuit beta too, so we end up with - alpha :-> zty - beta :-> zty - gamma :-> zty -where zty is the zonked version of ty. That way, if we come across -beta later, we'll have less work to do. (And indeed the same for -alpha.) - -This is easily achieved: just overwrite (Indirect ty) with (Indirect -zty). Non-systematic perf comparisons suggest that this is a modest -win. - -But c.f Note [Sharing when zonking to Type] in TcHsSyn. - -%************************************************************************ -%* * - Tidying -* * -************************************************************************ --} - -zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) -zonkTidyTcType env ty = do { ty' <- zonkTcType ty - ; return (tidyOpenType env ty') } - -zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType]) -zonkTidyTcTypes = zonkTidyTcTypes' [] - where zonkTidyTcTypes' zs env [] = return (env, reverse zs) - zonkTidyTcTypes' zs env (ty:tys) - = do { (env', ty') <- zonkTidyTcType env ty - ; zonkTidyTcTypes' (ty':zs) env' tys } - -zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) -zonkTidyOrigin env (GivenOrigin skol_info) - = do { skol_info1 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 - ; return (env, GivenOrigin skol_info2) } -zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp }) - = do { (env1, act') <- zonkTidyTcType env act - ; (env2, exp') <- zonkTidyTcType env1 exp - ; return ( env2, orig { uo_actual = act' - , uo_expected = exp' }) } -zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, m_ty2') <- case m_ty2 of - Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 - Nothing -> return (env1, Nothing) - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } -zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) } -zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; (env3, o1') <- zonkTidyOrigin env2 o1 - ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } -zonkTidyOrigin env orig = return (env, orig) - ----------------- -tidyCt :: TidyEnv -> Ct -> Ct --- Used only in error reporting --- Also converts it to non-canonical -tidyCt env ct - = case ct of - CHoleCan { cc_ev = ev } - -> ct { cc_ev = tidy_ev env ev } - _ -> mkNonCanonical (tidy_ev env (ctEvidence ct)) - where - tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence - -- NB: we do not tidy the ctev_evar field because we don't - -- show it in error messages - tidy_ev env ctev@(CtGiven { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtWanted { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtDerived { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - ----------------- -tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = setVarType var (tidyType env (varType var)) - ----------------- -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfo _ info = info - -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfo --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in Origin -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (Bndr tv vis) ty) - = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) - where - (env', tv') = tidy_tv_bndr env tv - - tidy_ty env ty@(FunTy _ arg res) - = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res } - - tidy_ty env ty = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyVarBndr env tv - -------------------------------------------------------------------------- -{- -%************************************************************************ -%* * - Levity polymorphism checks -* * -************************************************************************ - -See Note [Levity polymorphism checking] in DsMonad - --} - --- | According to the rules around representation polymorphism --- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder --- can have a representation-polymorphic type. This check ensures --- that we respect this rule. It is a bit regrettable that this error --- occurs in zonking, after which we should have reported all errors. --- But it's hard to see where else to do it, because this can be discovered --- only after all solving is done. And, perhaps most importantly, this --- isn't really a compositional property of a type system, so it's --- not a terrible surprise that the check has to go in an awkward spot. -ensureNotLevPoly :: Type -- its zonked type - -> SDoc -- where this happened - -> TcM () -ensureNotLevPoly ty doc - = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type - -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForLevPoly doc ty - - -- See Note [Levity polymorphism checking] in DsMonad -checkForLevPoly :: SDoc -> Type -> TcM () -checkForLevPoly = checkForLevPolyX addErr - -checkForLevPolyX :: Monad m - => (SDoc -> m ()) -- how to report an error - -> SDoc -> Type -> m () -checkForLevPolyX add_err extra ty - | isTypeLevPoly ty - = add_err (formatLevPolyErr ty $$ extra) - | otherwise - = return () - -formatLevPolyErr :: Type -- levity-polymorphic type - -> SDoc -formatLevPolyErr ty - = hang (text "A levity-polymorphic type is not allowed here:") - 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty - , text "Kind:" <+> pprWithTYPE tidy_ki ]) - where - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (tcTypeKind ty) diff --git a/typecheck/TcMatches.hs b/typecheck/TcMatches.hs deleted file mode 100644 --- a/typecheck/TcMatches.hs +++ /dev/null @@ -1,1111 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcMatches: Typecheck some @Matches@ --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards #-} - -module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, - tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcGuardStmt - ) where - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho - , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) - -import BasicTypes (LexicalFixity(..)) -import GHC.Hs -import TcRnMonad -import TcEnv -import TcPat -import TcMType -import TcType -import TcBinds -import TcUnify -import TcOrigin -import Name -import TysWiredIn -import Id -import TyCon -import TysPrim -import TcEvidence -import Outputable -import Util -import SrcLoc - --- Create chunkified tuple tybes for monad comprehensions -import MkCore - -import Control.Monad -import Control.Arrow ( second ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{tcMatchesFun, tcMatchesCase} -* * -************************************************************************ - -@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a -@FunMonoBind@. The second argument is the name of the function, which -is used in error messages. It checks that all the equations have the -same number of arguments before using @tcMatches@ to do the work. - -Note [Polymorphic expected type for tcMatchesFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcMatchesFun may be given a *sigma* (polymorphic) type -so it must be prepared to use tcSkolemise to skolemise it. -See Note [sig_tau may be polymorphic] in TcPat. --} - -tcMatchesFun :: Located Name - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType -- Expected type of function - -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) - -- Returns type of body -tcMatchesFun fn@(L _ fun_name) matches exp_ty - = do { -- Check that they all have the same no of arguments - -- Location is in the monad, set the caller so that - -- any inter-equation error messages get some vaguely - -- sensible location. Note: we have to do this odd - -- ann-grabbing, because we don't always have annotations in - -- hand when we call tcMatchesFun... - traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) - ; checkArgs fun_name matches - - ; (wrap_gen, (wrap_fun, group)) - <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho -> - -- Note [Polymorphic expected type for tcMatchesFun] - do { (matches', wrap_fun) - <- matchExpectedFunTys herald arity exp_rho $ - \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty matches - ; return (wrap_fun, matches') } - ; return (wrap_gen <.> wrap_fun, group) } - where - arity = matchGroupArity matches - herald = text "The equation(s) for" - <+> quotes (ppr fun_name) <+> text "have" - what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness } - match_ctxt = MC { mc_what = what, mc_body = tcBody } - strictness - | [L _ match] <- unLoc $ mg_alts matches - , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match - = SrcStrict - | otherwise - = NoSrcStrict - -{- -@tcMatchesCase@ doesn't do the argument-count check because the -parser guarantees that each equation has exactly one argument. --} - -tcMatchesCase :: (Outputable (body GhcRn)) => - TcMatchCtxt body -- Case context - -> TcSigmaType -- Type of scrutinee - -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives - -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) - -- Translated alternatives - -- wrapper goes from MatchGroup's ty to expected ty - -tcMatchesCase ctxt scrut_ty matches res_ty - = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches - -tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify - -> TcMatchCtxt HsExpr - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType -- deeply skolemised - -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper) -tcMatchLambda herald match_ctxt match res_ty - = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty match - where - n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case - | otherwise = matchGroupArity match - --- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. - -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType - -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) --- Used for pattern bindings -tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) - where - match_ctxt = MC { mc_what = PatBindRhs, - mc_body = tcBody } - -{- -************************************************************************ -* * -\subsection{tcMatch} -* * -************************************************************************ - -Note [Case branches must never infer a non-tau type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - case ... of - ... -> \(x :: forall a. a -> a) -> x - ... -> \y -> y - -Should that type-check? The problem is that, if we check the second branch -first, then we'll get a type (b -> b) for the branches, which won't unify -with the polytype in the first branch. If we check the first branch first, -then everything is OK. This order-dependency is terrible. So we want only -proper tau-types in branches (unless a sigma-type is pushed down). -This is what expTypeToType ensures: it replaces an Infer with a fresh -tau-type. - -An even trickier case looks like - - f x True = x undefined - f x False = x () - -Here, we see that the arguments must also be non-Infer. Thus, we must -use expTypeToType on the output of matchExpectedFunTys, not the input. - -But we make a special case for a one-branch case. This is so that - - f = \(x :: forall a. a -> a) -> x - -still gets assigned a polytype. --} - --- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the --- expected type into TauTvs. --- See Note [Case branches must never infer a non-tau type] -tauifyMultipleMatches :: [LMatch id body] - -> [ExpType] -> TcM [ExpType] -tauifyMultipleMatches group exp_tys - | isSingletonMatchGroup group = return exp_tys - | otherwise = mapM tauifyExpType exp_tys - -- NB: In the empty-match case, this ensures we fill in the ExpType - --- | Type-check a MatchGroup. -tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> MatchGroup GhcRn (Located (body GhcRn)) - -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) - -data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is - mc_body :: Located (body GhcRn) -- Type checker for a body of - -- an alternative - -> ExpRhoType - -> TcM (Located (body GhcTcId)) } - -tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches - , mg_origin = origin }) - = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys) - -- See Note [Case branches must never infer a non-tau type] - - ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches - ; pat_tys <- mapM readExpType pat_tys - ; rhs_ty <- readExpType rhs_ty - ; return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc pat_tys rhs_ty - , mg_origin = origin }) } -tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec - -------------- -tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> LMatch GhcRn (Located (body GhcRn)) - -> TcM (LMatch GhcTcId (Located (body GhcTcId))) - -tcMatch ctxt pat_tys rhs_ty match - = wrapLocM (tc_match ctxt pat_tys rhs_ty) match - where - tc_match ctxt pat_tys rhs_ty - match@(Match { m_pats = pats, m_grhss = grhss }) - = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ - tcGRHSs ctxt grhss rhs_ty - ; return (Match { m_ext = noExtField - , m_ctxt = mc_what ctxt, m_pats = pats' - , m_grhss = grhss' }) } - tc_match _ _ _ (XMatch nec) = noExtCon nec - - -- For (\x -> e), tcExpr has already said "In the expression \x->e" - -- so we don't want to add "In the lambda abstraction \x->e" - add_match_ctxt match thing_inside - = case mc_what ctxt of - LambdaExpr -> thing_inside - _ -> addErrCtxt (pprMatchInCtxt match) thing_inside - -------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType - -> TcM (GRHSs GhcTcId (Located (body GhcTcId))) - --- Notice that we pass in the full res_ty, so that we get --- good inference from simple things like --- f = \(x::forall a.a->a) -> --- We used to force it to be a monotype when there was more than one guard --- but we don't need to do that any more - -tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty - = do { (binds', grhss') - <- tcLocalBinds binds $ - mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - - ; return (GRHSs noExtField grhss' (L l binds')) } -tcGRHSs _ (XGRHSs nec) _ = noExtCon nec - -------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) - -> TcM (GRHS GhcTcId (Located (body GhcTcId))) - -tcGRHS ctxt res_ty (GRHS _ guards rhs) - = do { (guards', rhs') - <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ - mc_body ctxt rhs - ; return (GRHS noExtField guards' rhs') } - where - stmt_ctxt = PatGuard (mc_what ctxt) -tcGRHS _ _ (XGRHS nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} -* * -************************************************************************ --} - -tcDoStmts :: HsStmtContext Name - -> Located [LStmt GhcRn (LHsExpr GhcRn)] - -> ExpRhoType - -> TcM (HsExpr GhcTcId) -- Returns a HsDo -tcDoStmts ListComp (L l stmts) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, elt_ty) <- matchExpectedListTy res_ty - ; let list_ty = mkListTy elt_ty - ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts - (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } - -tcDoStmts DoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty DoExpr (L l stmts')) } - -tcDoStmts MDoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MDoExpr (L l stmts')) } - -tcDoStmts MonadComp (L l stmts) res_ty - = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MonadComp (L l stmts')) } - -tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) - -tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId) -tcBody body res_ty - = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty - } - -{- -************************************************************************ -* * -\subsection{tcStmts} -* * -************************************************************************ --} - -type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType -type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType - -type TcStmtChecker body rho_type - = forall thing. HsStmtContext Name - -> Stmt GhcRn (Located (body GhcRn)) - -> rho_type -- Result type for comprehension - -> (rho_type -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing) - -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] - -> rho_type - -> TcM [LStmt GhcTcId (Located (body GhcTcId))] -tcStmts ctxt stmt_chk stmts res_ty - = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ - const (return ()) - ; return stmts' } - -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] - -> rho_type - -> (rho_type -> TcM thing) - -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing) - --- Note the higher-rank type. stmt_chk is applied at different --- types in the equations for tcStmts - -tcStmtsAndThen _ _ [] res_ty thing_inside - = do { thing <- thing_inside res_ty - ; return ([], thing) } - --- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) - res_ty thing_inside - = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } - --- Don't set the error context for an ApplicativeStmt. It ought to be --- possible to do this with a popErrCtxt in the tcStmt case for --- ApplicativeStmt, but it did someting strange and broke a test (ado002). -tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside - | ApplicativeStmt{} <- stmt - = do { (stmt', (stmts', thing)) <- - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - - -- For the vanilla case, handle the location-setting part - | otherwise - = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ - addErrCtxt (pprStmtInCtxt ctxt stmt) $ - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - popErrCtxt $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - ---------------------------------------------------- --- Pattern guards ---------------------------------------------------- - -tcGuardStmt :: TcExprStmtChecker -tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy) - ; thing <- thing_inside res_ty - ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } - -tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRhoNC rhs - -- Stmt has a context already - ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) - pat (mkCheckExpType rhs_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcGuardStmt _ stmt _ _ - = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- List comprehensions --- (no rebindable syntax) ---------------------------------------------------- - --- Dealt with separately, rather than by tcMcStmt, because --- a) We have special desugaring rules for list comprehensions, --- which avoid creating intermediate lists. They in turn --- assume that the bind/return operations are the regular --- polymorphic ones, and in particular don't have any --- coercion matching stuff in them. It's hard to avoid the --- potential for non-trivial coercions in tcMcStmt - -tcLcStmt :: TyCon -- The list type constructor ([]) - -> TcExprStmtChecker - -tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside - = do { body' <- tcMonoExprNC body elt_ty - ; thing <- thing_inside (panic "tcLcStmt: thing_inside") - ; return (LastStmt x body' noret noSyntaxExpr, thing) } - --- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside - = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside elt_ty - ; return (mkTcBindStmt pat' rhs', thing) } - --- A boolean guard -tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside - = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy) - ; thing <- thing_inside elt_ty - ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } - --- ParStmt: See notes with tcMcStmt -tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside - = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } - where - -- loop :: [([LStmt GhcRn], [GhcRn])] - -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop (ParStmtBlock x stmts names _ : pairs) - = do { (stmts', (ids, pairs', thing)) - <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> - do { ids <- tcLookupLocalIds names - ; (pairs', thing) <- loop pairs - ; return (ids, pairs', thing) } - ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } - loop (XParStmtBlock nec:_) = noExtCon nec - -tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts - , trS_bndrs = bindersMap - , trS_by = by, trS_using = using }) elt_ty thing_inside - = do { let (bndr_names, n_bndr_names) = unzip bindersMap - unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) - -- The inner 'stmts' lack a LastStmt, so the element type - -- passed in to tcStmtsAndThen is never looked at - ; (stmts', (bndr_ids, by')) - <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do - { by' <- traverse tcInferRho by - ; bndr_ids <- tcLookupLocalIds bndr_names - ; return (bndr_ids, by') } - - ; let m_app ty = mkTyConApp m_tc [ty] - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) - -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm - ; let n_app = case form of - ThenForm -> (\ty -> ty) - _ -> m_app - - by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present - by_arrow = case by' of - Nothing -> \ty -> ty - Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty - - tup_ty = mkBigCoreVarTupTy bndr_ids - poly_arg_ty = m_app alphaTy - poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = fmap fst by', trS_using = final_using - , trS_ret = noSyntaxExpr - , trS_bind = noSyntaxExpr - , trS_fmap = noExpr - , trS_ext = unitTy - , trS_form = form }, thing) } - -tcLcStmt _ _ stmt _ _ - = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Monad comprehensions --- (supports rebindable syntax) ---------------------------------------------------- - -tcMcStmt :: TcExprStmtChecker - -tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside - = do { (body', return_op') - <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ - \ [a_ty] -> - tcMonoExprNC body (mkCheckExpType a_ty) - ; thing <- thing_inside (panic "tcMcStmt: thing_inside") - ; return (LastStmt x body' noret return_op', thing) } - --- Generators for monad comprehensions ( pat <- rhs ) --- --- [ body | q <- gen ] -> gen :: m a --- q :: a --- - -tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - = do { ((rhs', pat', thing, new_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', thing, new_res_ty) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } - --- Boolean expressions. --- --- [ body | stmts, expr ] -> expr :: m Bool --- -tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- guard_op :: test_ty -> rhs_ty - -- then_op :: rhs_ty -> new_res_ty -> res_ty - -- Where test_ty is, for example, Bool - ; ((thing, rhs', rhs_ty, guard_op'), then_op') - <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { (rhs', guard_op') - <- tcSyntaxOp MCompOrigin guard_op [SynAny] - (mkCheckExpType rhs_ty) $ - \ [test_ty] -> - tcMonoExpr rhs (mkCheckExpType test_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, rhs', rhs_ty, guard_op') } - ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } - --- Grouping statements --- --- [ body | stmts, then group by e using f ] --- -> e :: t --- f :: forall a. (a -> t) -> m a -> m (m a) --- [ body | stmts, then group using f ] --- -> f :: forall a. m a -> m (m a) - --- We type [ body | (stmts, group by e using f), ... ] --- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... --- --- We type the functions as follows: --- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) --- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) --- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) --- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) --- -tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap - , trS_by = by, trS_using = using, trS_form = form - , trS_ret = return_op, trS_bind = bind_op - , trS_fmap = fmap_op }) res_ty thing_inside - = do { m1_ty <- newFlexiTyVarTy typeToTypeKind - ; m2_ty <- newFlexiTyVarTy typeToTypeKind - ; tup_ty <- newFlexiTyVarTy liftedTypeKind - ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm - ; n_app <- case form of - ThenForm -> return (\ty -> ty) - _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind - ; return (n_ty `mkAppTy`) } - ; let by_arrow :: Type -> Type - -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) - -- or res ('by' absent) - by_arrow = case by of - Nothing -> \res -> res - Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res - - poly_arg_ty = m1_ty `mkAppTy` alphaTy - using_arg_ty = m1_ty `mkAppTy` tup_ty - poly_res_ty = m2_ty `mkAppTy` n_app alphaTy - using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let (bndr_names, n_bndr_names) = unzip bindersMap - ; (stmts', (bndr_ids, by', return_op')) <- - tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts - (mkCheckExpType using_arg_ty) $ \res_ty' -> do - { by' <- case by of - Nothing -> return Nothing - Just e -> do { e' <- tcMonoExpr e - (mkCheckExpType by_e_ty) - ; return (Just e') } - - -- Find the Ids (and hence types) of all old binders - ; bndr_ids <- tcLookupLocalIds bndr_names - - -- 'return' is only used for the binders, so we know its type. - -- return :: (a,b,c,..) -> m (a,b,c,..) - ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op - [synKnownType (mkBigCoreVarTupTy bndr_ids)] - res_ty' $ \ _ -> return () - - ; return (bndr_ids, by', return_op') } - - --------------- Typecheck the 'bind' function ------------- - -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType using_res_ty - , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ] - res_ty $ \ _ -> return () - - --------------- Typecheck the 'fmap' function ------------- - ; fmap_op' <- case form of - ThenForm -> return noExpr - _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ - mkInvForAllTy alphaTyVar $ - mkInvForAllTy betaTyVar $ - (alphaTy `mkVisFunTy` betaTy) - `mkVisFunTy` (n_app alphaTy) - `mkVisFunTy` (n_app betaTy) - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' - - --------------- Bulding the bindersMap ---------------- - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids $ - thing_inside (mkCheckExpType new_res_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = by', trS_using = final_using - , trS_ret = return_op', trS_bind = bind_op' - , trS_ext = n_app tup_ty - , trS_fmap = fmap_op', trS_form = form }, thing) } - --- A parallel set of comprehensions --- [ (g x, h x) | ... ; let g v = ... --- | ... ; let h v = ... ] --- --- It's possible that g,h are overloaded, so we need to feed the LIE from the --- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). --- Similarly if we had an existential pattern match: --- --- data T = forall a. Show a => C a --- --- [ (show x, show y) | ... ; C x <- ... --- | ... ; C y <- ... ] --- --- Then we need the LIE from (show x, show y) to be simplified against --- the bindings for x and y. --- --- It's difficult to do this in parallel, so we rely on the renamer to --- ensure that g,h and x,y don't duplicate, and simply grow the environment. --- So the binders of the first parallel group will be in scope in the second --- group. But that's fine; there's no shadowing to worry about. --- --- Note: The `mzip` function will get typechecked via: --- --- ParStmt [st1::t1, st2::t2, st3::t3] --- --- mzip :: m st1 --- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call --- -> m (st1, (st2, st3)) --- -tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside - = do { m_ty <- newFlexiTyVarTy typeToTypeKind - - ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ - (m_ty `mkAppTy` alphaTy) - `mkVisFunTy` - (m_ty `mkAppTy` betaTy) - `mkVisFunTy` - (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty - - -- type dummies since we don't know all binder types yet - ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) - [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] - - -- Typecheck bind: - ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] - tuple_ty = mk_tuple_ty tup_tys - - ; (((blocks', thing), inner_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType (m_ty `mkAppTy` tuple_ty) - , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ - \ [inner_res_ty] -> - do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) - tup_tys bndr_stmts_s - ; return (stuff, inner_res_ty) } - - ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } - - where - mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys - - -- loop :: Type -- m_ty - -- -> ExpRhoType -- inner_res_ty - -- -> [TcType] -- tup_tys - -- -> [ParStmtBlock Name] - -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) - loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty - ; return ([], thing) } - -- matching in the branches - - loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) - (ParStmtBlock x stmts names return_op : pairs) - = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in - ; (stmts', (ids, return_op', pairs', thing)) - <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ - \m_tup_ty' -> - do { ids <- tcLookupLocalIds names - ; let tup_ty = mkBigCoreVarTupTy ids - ; (_, return_op') <- - tcSyntaxOp MCompOrigin return_op - [synKnownType tup_ty] m_tup_ty' $ - \ _ -> return () - ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs - ; return (ids, return_op', pairs', thing) } - ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } - loop _ _ _ _ = panic "tcMcStmt.loop" - -tcMcStmt _ stmt _ _ - = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Do-notation --- (supports rebindable syntax) ---------------------------------------------------- - -tcDoStmt :: TcExprStmtChecker - -tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside - = do { body' <- tcMonoExprNC body res_ty - ; thing <- thing_inside (panic "tcDoStmt: thing_inside") - ; return (LastStmt x body' noret noSyntaxExpr, thing) } - -tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - -- This level of generality is needed for using do-notation - -- in full generality; see #1537 - - ((rhs', pat', new_res_ty, thing), bind_op') - <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', new_res_ty, thing) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } - -tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside - = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ - thing_inside . mkCheckExpType - ; ((pairs', body_ty, thing), mb_join') <- case mb_join of - Nothing -> (, Nothing) <$> tc_app_stmts res_ty - Just join_op -> - second Just <$> - (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ - \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) - - ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } - -tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside - = do { -- Deal with rebindable syntax; - -- (>>) :: rhs_ty -> new_res_ty -> res_ty - ; ((rhs', rhs_ty, thing), then_op') - <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', rhs_ty, thing) } - ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } - -tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names, recS_ret_fn = ret_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) - res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - tup_ty = mkBigCoreTupTy tup_elt_tys - - ; tcExtendIdEnv tup_ids $ do - { ((stmts', (ret_op', tup_rets)), stmts_ty) - <- tcInferInst $ \ exp_ty -> - tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> - do { tup_rets <- zipWithM tcCheckId tup_names - (map mkCheckExpType tup_elt_tys) - -- Unify the types of the "final" Ids (which may - -- be polymorphic) with those of "knot-tied" Ids - ; (_, ret_op') - <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] - inner_res_ty $ \_ -> return () - ; return (ret_op', tup_rets) } - - ; ((_, mfix_op'), mfix_res_ty) - <- tcInferInst $ \ exp_ty -> - tcSyntaxOp DoOrigin mfix_op - [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $ - \ _ -> return () - - ; ((thing, new_res_ty), bind_op') - <- tcSyntaxOp DoOrigin bind_op - [ synKnownType mfix_res_ty - , synKnownType tup_ty `SynFun` SynRho ] - res_ty $ - \ [new_res_ty] -> - do { thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, new_res_ty) } - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), - ppr later_ids <+> ppr (map idType later_ids)] - ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' - , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_ext = RecStmtTc - { recS_bind_ty = new_res_ty - , recS_later_rets = [] - , recS_rec_rets = tup_rets - , recS_ret_ty = stmts_ty} }, thing) - }} - -tcDoStmt _ stmt _ _ - = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) - - - ---------------------------------------------------- --- MonadFail Proposal warnings ---------------------------------------------------- - --- The idea behind issuing MonadFail warnings is that we add them whenever a --- failable pattern is encountered. However, instead of throwing a type error --- when the constraint cannot be satisfied, we only issue a warning in --- TcErrors.hs. - -tcMonadFailOp :: CtOrigin - -> LPat GhcTcId - -> SyntaxExpr GhcRn -- The fail op - -> TcType -- Type of the whole do-expression - -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op --- Get a 'fail' operator expression, to use if the pattern --- match fails. If the pattern is irrefutatable, just return --- noSyntaxExpr; it won't be used -tcMonadFailOp orig pat fail_op res_ty - | isIrrefutableHsPat pat - = return noSyntaxExpr - - | otherwise - = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] - (mkCheckExpType res_ty) $ \_ -> return ()) - -{- -Note [Treat rebindable syntax first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking - do { bar; ... } :: IO () -we want to typecheck 'bar' in the knowledge that it should be an IO thing, -pushing info from the context into the RHS. To do this, we check the -rebindable syntax first, and push that information into (tcMonoExprNC rhs). -Otherwise the error shows up when checking the rebindable syntax, and -the expected/inferred stuff is back to front (see #3613). - -Note [typechecking ApplicativeStmt] - -join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) - -fresh type variables: - pat_ty_1..pat_ty_n - exp_ty_1..exp_ty_n - t_1..t_(n-1) - -body :: body_ty -(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty -pat_i :: pat_ty_i -e_i :: exp_ty_i -<$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1 -<*>_i :: t_(i-1) -> exp_ty_i -> t_i -join :: tn -> res_ty --} - -tcApplicativeStmts - :: HsStmtContext Name - -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] - -> ExpRhoType -- rhs_ty - -> (TcRhoType -> TcM t) -- thing_inside - -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t) - -tcApplicativeStmts ctxt pairs rhs_ty thing_inside - = do { body_ty <- newFlexiTyVarTy liftedTypeKind - ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newInferExpTypeInst - ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; let fun_ty = mkVisFunTys pat_tys body_ty - - -- NB. do the <$>,<*> operators first, we don't want type errors here - -- i.e. goOps before goArgs - -- See Note [Treat rebindable syntax first] - ; let (ops, args) = unzip pairs - ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys) - - -- Typecheck each ApplicativeArg separately - -- See Note [ApplicativeDo and constraints] - ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) - - -- Bring into scope all the things bound by the args, - -- and typecheck the thing_inside - -- See Note [ApplicativeDo and constraints] - ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $ - thing_inside body_ty - - ; return (zip ops' args', body_ty, res) } - where - goOps _ [] = return [] - goOps t_left ((op,t_i,exp_ty) : ops) - = do { (_, op') - <- tcSyntaxOp DoOrigin op - [synKnownType t_left, synKnownType exp_ty] t_i $ - \ _ -> return () - ; t_i <- readExpType t_i - ; ops' <- goOps t_i ops - ; return (op' : ops') } - - goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) - -> TcM (ApplicativeArg GhcTcId) - - goArg body_ty (ApplicativeArgOne - { app_arg_pattern = pat - , arg_expr = rhs - , fail_operator = fail_op - , .. - }, pat_ty, exp_ty) - = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ - addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty - - ; return (ApplicativeArgOne - { app_arg_pattern = pat' - , arg_expr = rhs' - , fail_operator = fail_op' - , .. } - ) } - - goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) - = do { (stmts', (ret',pat')) <- - tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ - \res_ty -> do - { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; return (ret', pat') - } - ; return (ApplicativeArgMany x stmts' ret' pat') } - - goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec - - get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] - get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (XApplicativeArg nec) = noExtCon nec - -{- Note [ApplicativeDo and constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An applicative-do is supposed to take place in parallel, so -constraints bound in one arm can't possibly be available in another -(#13242). Our current rule is this (more details and discussion -on the ticket). Consider - - ...stmts... - ApplicativeStmts [arg1, arg2, ... argN] - ...more stmts... - -where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts. -Now, we say that: - -* Constraints required by the argi can be solved from - constraint bound by ...stmts... - -* Constraints and existentials bound by the argi are not available - to solve constraints required either by argj (where i /= j), - or by ...more stmts.... - -* Within the stmts of each 'argi' individually, however, constraints bound - by earlier stmts can be used to solve later ones. - -To achieve this, we just typecheck each 'argi' separately, bring all -the variables they bind into scope, and typecheck the thing_inside. - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same -number of args are used in each equation. --} - -checkArgs :: Name -> MatchGroup GhcRn body -> TcM () -checkArgs _ (MG { mg_alts = L _ [] }) - = return () -checkArgs fun (MG { mg_alts = L _ (match1:matches) }) - | null bad_matches - = return () - | otherwise - = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> - text "have different numbers of arguments" - , nest 2 (ppr (getLoc match1)) - , nest 2 (ppr (getLoc (head bad_matches)))]) - where - n_args1 = args_in_match match1 - bad_matches = [m | m <- matches, args_in_match m /= n_args1] - - args_in_match :: LMatch GhcRn body -> Int - args_in_match (L _ (Match { m_pats = pats })) = length pats - args_in_match (L _ (XMatch nec)) = noExtCon nec -checkArgs _ (XMatchGroup nec) = noExtCon nec diff --git a/typecheck/TcMatches.hs-boot b/typecheck/TcMatches.hs-boot deleted file mode 100644 --- a/typecheck/TcMatches.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module TcMatches where -import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) -import TcEvidence( HsWrapper ) -import Name ( Name ) -import TcType ( ExpSigmaType, TcRhoType ) -import TcRnTypes( TcM ) -import SrcLoc ( Located ) -import GHC.Hs.Extension ( GhcRn, GhcTcId ) - -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) - -> TcRhoType - -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) - -tcMatchesFun :: Located Name - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType - -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) diff --git a/typecheck/TcOrigin.hs b/typecheck/TcOrigin.hs deleted file mode 100644 --- a/typecheck/TcOrigin.hs +++ /dev/null @@ -1,660 +0,0 @@ -{- - -Describes the provenance of types as they flow through the type-checker. -The datatypes here are mainly used for error message generation. - --} - -{-# LANGUAGE CPP #-} - -module TcOrigin ( - -- UserTypeCtxt - UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, - - -- SkolemInfo - SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, - - -- CtOrigin - CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - isVisibleOrigin, toInvisibleOrigin, - pprCtOrigin, isGivenOrigin - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcType - -import GHC.Hs - -import Id -import DataCon -import ConLike -import TyCon -import InstEnv -import PatSyn - -import Module -import Name -import RdrName -import qualified GHC.LanguageExtensions as LangExt -import DynFlags - -import SrcLoc -import FastString -import Outputable -import BasicTypes - -{- ********************************************************************* -* * - UserTypeCtxt -* * -********************************************************************* -} - -------------------------------------- --- | UserTypeCtxt describes the origin of the polymorphic type --- in the places where we need an expression to have that type -data UserTypeCtxt - = FunSigCtxt -- Function type signature, when checking the type - -- Also used for types in SPECIALISE pragmas - Name -- Name of the function - Bool -- True <=> report redundant constraints - -- This is usually True, but False for - -- * Record selectors (not important here) - -- * Class and instance methods. Here - -- the code may legitimately be more - -- polymorphic than the signature - -- generated from the class - -- declaration - - | InfSigCtxt Name -- Inferred type for function - | ExprSigCtxt -- Expression type signature - | KindSigCtxt -- Kind signature - | StandaloneKindSigCtxt -- Standalone kind signature - Name -- Name of the type/class - | TypeAppCtxt -- Visible type application - | ConArgCtxt Name -- Data constructor argument - | TySynCtxt Name -- RHS of a type synonym decl - | PatSynCtxt Name -- Type sig for a pattern synonym - | PatSigCtxt -- Type sig in pattern - -- eg f (x::t) = ... - -- or (x::t, y) = e - | RuleSigCtxt Name -- LHS of a RULE forall - -- RULE "foo" forall (x :: a -> a). f (Just x) = ... - | ResSigCtxt -- Result type sig - -- f x :: t = .... - | ForSigCtxt Name -- Foreign import or export signature - | DefaultDeclCtxt -- Types in a default declaration - | InstDeclCtxt Bool -- An instance declaration - -- True: stand-alone deriving - -- False: vanilla instance declaration - | SpecInstCtxt -- SPECIALISE instance pragma - | ThBrackCtxt -- Template Haskell type brackets [t| ... |] - | GenSigCtxt -- Higher-rank or impredicative situations - -- e.g. (f e) where f has a higher-rank type - -- We might want to elaborate this - | GhciCtxt Bool -- GHCi command :kind - -- The Bool indicates if we are checking the outermost - -- type application. - -- See Note [Unsaturated type synonyms in GHCi] in - -- TcValidity. - - | ClassSCCtxt Name -- Superclasses of a class - | SigmaCtxt -- Theta part of a normal for-all type - -- f :: => a -> a - | DataTyCtxt Name -- The "stupid theta" part of a data decl - -- data => T a = MkT a - | DerivClauseCtxt -- A 'deriving' clause - | TyVarBndrKindCtxt Name -- The kind of a type variable being bound - | DataKindCtxt Name -- The kind of a data/newtype (instance) - | TySynKindCtxt Name -- The kind of the RHS of a type synonym - | TyFamResKindCtxt Name -- The result kind of a type family - -{- --- Notes re TySynCtxt --- We allow type synonyms that aren't types; e.g. type List = [] --- --- If the RHS mentions tyvars that aren't in scope, we'll --- quantify over them: --- e.g. type T = a->a --- will become type T = forall a. a->a --- --- With gla-exts that's right, but for H98 we should complain. --} - - -pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = text "a RULE for" <+> quotes (ppr n) -pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" -pprUserTypeCtxt KindSigCtxt = text "a kind signature" -pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) -pprUserTypeCtxt TypeAppCtxt = text "a type argument" -pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) -pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" -pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" -pprUserTypeCtxt ResSigCtxt = text "a result type signature" -pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" -pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" -pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" -pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" -pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" -pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" -pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) -pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" -pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) -pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) -pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" -pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) -pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) - -isSigMaybe :: UserTypeCtxt -> Maybe Name -isSigMaybe (FunSigCtxt n _) = Just n -isSigMaybe (ConArgCtxt n) = Just n -isSigMaybe (ForSigCtxt n) = Just n -isSigMaybe (PatSynCtxt n) = Just n -isSigMaybe _ = Nothing - -{- -************************************************************************ -* * - SkolemInfo -* * -************************************************************************ --} - --- SkolemInfo gives the origin of *given* constraints --- a) type variables are skolemised --- b) an implication constraint is generated -data SkolemInfo - = SigSkol -- A skolem that is created by instantiating - -- a programmer-supplied type signature - -- Location of the binding site is on the TyVar - -- See Note [SigSkol SkolemInfo] - UserTypeCtxt -- What sort of signature - TcType -- Original type signature (before skolemisation) - [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar - -- to its instantiated version - - | SigTypeSkol UserTypeCtxt - -- like SigSkol, but when we're kind-checking the *type* - -- hence, we have less info - - | ForAllSkol SDoc -- Bound by a user-written "forall". - - | DerivSkol Type -- Bound by a 'deriving' clause; - -- the type is the instance we are trying to derive - - | InstSkol -- Bound at an instance decl - | InstSC TypeSize -- A "given" constraint obtained by superclass selection. - -- If (C ty1 .. tyn) is the largest class from - -- which we made a superclass selection in the chain, - -- then TypeSize = sizeTypes [ty1, .., tyn] - -- See Note [Solving superclass constraints] in TcInstDcls - - | FamInstSkol -- Bound at a family instance decl - | PatSkol -- An existential type variable bound by a pattern for - ConLike -- a data constructor with an existential type. - (HsMatchContext Name) - -- e.g. data T = forall a. Eq a => MkT a - -- f (MkT x) = ... - -- The pattern MkT x will allocate an existential type - -- variable for 'a'. - - | ArrowSkol -- An arrow form (see TcArrows) - - | IPSkol [HsIPName] -- Binding site of an implicit parameter - - | RuleSkol RuleName -- The LHS of a RULE - - | InferSkol [(Name,TcType)] - -- We have inferred a type for these (mutually-recursivive) - -- polymorphic Ids, and are now checking that their RHS - -- constraints are satisfied. - - | BracketSkol -- Template Haskell bracket - - | UnifyForAllSkol -- We are unifying two for-all types - TcType -- The instantiated type *inside* the forall - - | TyConSkol TyConFlavour Name -- bound in a type declaration of the given flavour - - | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or - -- as any variable in a GADT datacon decl - - | ReifySkol -- Bound during Template Haskell reification - - | QuantCtxtSkol -- Quantified context, e.g. - -- f :: forall c. (forall a. c a => c [a]) => blah - - | UnkSkol -- Unhelpful info (until I improve it) - -instance Outputable SkolemInfo where - ppr = pprSkolInfo - -pprSkolInfo :: SkolemInfo -> SDoc --- Complete the sentence "is a rigid type variable bound by..." -pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty -pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx -pprSkolInfo (ForAllSkol doc) = quotes doc -pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" - <+> pprWithCommas ppr ips -pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) -pprSkolInfo InstSkol = text "the instance declaration" -pprSkolInfo (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n)) -pprSkolInfo FamInstSkol = text "a family instance declaration" -pprSkolInfo BracketSkol = text "a Template Haskell bracket" -pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name -pprSkolInfo ArrowSkol = text "an arrow form" -pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl - , text "in" <+> pprMatchContext mc ] -pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") - 2 (vcat [ ppr name <+> dcolon <+> ppr ty - | (name,ty) <- ids ]) -pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty -pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) -pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name) -pprSkolInfo ReifySkol = text "the type being reified" - -pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" - --- UnkSkol --- For type variables the others are dealt with by pprSkolTvBinding. --- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" - -pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc --- The type is already tidied -pprSigSkolInfo ctxt ty - = case ctxt of - FunSigCtxt f _ -> vcat [ text "the type signature for:" - , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] - PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms] - _ -> vcat [ pprUserTypeCtxt ctxt <> colon - , nest 2 (ppr ty) ] - -pprPatSkolInfo :: ConLike -> SDoc -pprPatSkolInfo (RealDataCon dc) - = sep [ text "a pattern with constructor:" - , nest 2 $ ppr dc <+> dcolon - <+> pprType (dataConUserType dc) <> comma ] - -- pprType prints forall's regardless of -fprint-explicit-foralls - -- which is what we want here, since we might be saying - -- type variable 't' is bound by ... - -pprPatSkolInfo (PatSynCon ps) - = sep [ text "a pattern with pattern synonym:" - , nest 2 $ ppr ps <+> dcolon - <+> pprPatSynType ps <> comma ] - -{- Note [Skolem info for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For pattern synonym SkolemInfo we have - SigSkol (PatSynCtxt p) ty _ -but the type 'ty' is not very helpful. The full pattern-synonym type -has the provided and required pieces, which it is inconvenient to -record and display here. So we simply don't display the type at all, -contenting outselves with just the name of the pattern synonym, which -is fine. We could do more, but it doesn't seem worth it. - -Note [SigSkol SkolemInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we (deeply) skolemise a type - f :: forall a. a -> forall b. b -> a -Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated - a' -> b' -> a. -But when, in an error message, we report that "b is a rigid type -variable bound by the type signature for f", we want to show the foralls -in the right place. So we proceed as follows: - -* In SigSkol we record - - the original signature forall a. a -> forall b. b -> a - - the instantiation mapping [a :-> a', b :-> b'] - -* Then when tidying in TcMType.tidySkolemInfo, we first tidy a' to - whatever it tidies to, say a''; and then we walk over the type - replacing the binder a by the tidied version a'', to give - forall a''. a'' -> forall b''. b'' -> a'' - We need to do this under function arrows, to match what deeplySkolemise - does. - -* Typically a'' will have a nice pretty name like "a", but the point is - that the foral-bound variables of the signature we report line up with - the instantiated skolems lying around in other types. - - -************************************************************************ -* * - CtOrigin -* * -************************************************************************ --} - -data CtOrigin - = GivenOrigin SkolemInfo - - -- All the others are for *wanted* constraints - | OccurrenceOf Name -- Occurrence of an overloaded identifier - | OccurrenceOfRecSel RdrName -- Occurrence of a record selector - | AppOrigin -- An application of some kind - - | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for - -- function or instance - - | TypeEqOrigin { uo_actual :: TcType - , uo_expected :: TcType - , uo_thing :: Maybe SDoc - -- ^ The thing that has type "actual" - , uo_visible :: Bool - -- ^ Is at least one of the three elements above visible? - -- (Errors from the polymorphic subsumption check are considered - -- visible.) Only used for prioritizing error messages. - } - - | KindEqOrigin -- See Note [Equalities with incompatible kinds] in TcCanonical. - TcType (Maybe TcType) -- A kind equality arising from unifying these two types - CtOrigin -- originally arising from this - (Maybe TypeOrKind) -- the level of the eq this arises from - - | IPOccOrigin HsIPName -- Occurrence of an implicit parameter - | OverLabelOrigin FastString -- Occurrence of an overloaded label - - | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal - | NegateOrigin -- Occurrence of syntactic negation - - | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc - | AssocFamPatOrigin -- When matching the patterns of an associated - -- family instance with that of its parent class - | SectionOrigin - | TupleOrigin -- (..,..) - | ExprSigOrigin -- e :: ty - | PatSigOrigin -- p :: ty - | PatOrigin -- Instantiating a polytyped pattern at a constructor - | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature - (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in - -- particular the name and the right-hand side - | RecordUpdOrigin - | ViewPatOrigin - - | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration - -- If the instance head is C ty1 .. tyn - -- then TypeSize = sizeTypes [ty1, .., tyn] - -- See Note [Solving superclass constraints] in TcInstDcls - - | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to - -- standalone deriving). - | DerivOriginDC DataCon Int Bool - -- Checking constraints arising from this data con and field index. The - -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if - -- standalong deriving (with a wildcard constraint) is being used. This - -- is used to inform error messages on how to recommended fixes (e.g., if - -- the argument is True, then don't recommend "use standalone deriving", - -- but rather "fill in the wildcard constraint yourself"). - -- See Note [Inferring the instance context] in TcDerivInfer - | DerivOriginCoerce Id Type Type Bool - -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from - -- `ty1` to `ty2`. - | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for - -- constraints coming from a wildcard constraint, - -- e.g., deriving instance _ => Eq (Foo a) - -- See Note [Inferring the instance context] - -- in TcDerivInfer - | DefaultOrigin -- Typechecking a default decl - | DoOrigin -- Arising from a do expression - | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in - -- a do expression - | MCompOrigin -- Arising from a monad comprehension - | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a - -- monad comprehension - | IfOrigin -- Arising from an if statement - | ProcOrigin -- Arising from a proc expression - | AnnOrigin -- An annotation - - | FunDepOrigin1 -- A functional dependency from combining - PredType CtOrigin RealSrcSpan -- This constraint arising from ... - PredType CtOrigin RealSrcSpan -- and this constraint arising from ... - - | FunDepOrigin2 -- A functional dependency from combining - PredType CtOrigin -- This constraint arising from ... - PredType SrcSpan -- and this top-level instance - -- We only need a CtOrigin on the first, because the location - -- is pinned on the entire error message - - | HoleOrigin - | UnboundOccurrenceOf OccName - | ListOrigin -- An overloaded list - | StaticOrigin -- A static form - | FailablePattern (LPat GhcTcId) -- A failable pattern in do-notation for the - -- MonadFail Proposal (MFP). Obsolete when - -- actual desugaring to MonadFail.fail is - -- live. - | Shouldn'tHappenOrigin String - -- the user should never see this one, - -- unless ImpredicativeTypes is on, where all - -- bets are off - | InstProvidedOrigin Module ClsInst - -- Skolem variable arose when we were testing if an instance - -- is solvable or not. --- An origin is visible if the place where the constraint arises is manifest --- in user code. Currently, all origins are visible except for invisible --- TypeEqOrigins. This is used when choosing which error of --- several to report -isVisibleOrigin :: CtOrigin -> Bool -isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis -isVisibleOrigin (KindEqOrigin _ _ sub_orig _) = isVisibleOrigin sub_orig -isVisibleOrigin _ = True - --- Converts a visible origin to an invisible one, if possible. Currently, --- this works only for TypeEqOrigin -toInvisibleOrigin :: CtOrigin -> CtOrigin -toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False } -toInvisibleOrigin orig = orig - -isGivenOrigin :: CtOrigin -> Bool -isGivenOrigin (GivenOrigin {}) = True -isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2 -isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1 -isGivenOrigin _ = False - -instance Outputable CtOrigin where - ppr = pprCtOrigin - -ctoHerald :: SDoc -ctoHerald = text "arising from" - --- | Extract a suitable CtOrigin from a HsExpr -lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin -lexprCtOrigin (L _ e) = exprCtOrigin e - -exprCtOrigin :: HsExpr GhcRn -> CtOrigin -exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf (unboundVarOcc uv) -exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" -exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) -exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l -exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip -exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit -exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" -exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches -exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms -exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 -exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op -exprCtOrigin (NegApp _ e _) = lexprCtOrigin e -exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin (SectionL _ _ _) = SectionOrigin -exprCtOrigin (SectionR _ _ _) = SectionOrigin -exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" -exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" -exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) -exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" -exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e -exprCtOrigin (HsDo {}) = DoOrigin -exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" -exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" -exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin -exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" -exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" -exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" -exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" -exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" -exprCtOrigin (XExpr nec) = noExtCon nec - --- | Extract a suitable CtOrigin from a MatchGroup -matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin -matchesCtOrigin (MG { mg_alts = alts }) - | L _ [L _ match] <- alts - , Match { m_grhss = grhss } <- match - = grhssCtOrigin grhss - - | otherwise - = Shouldn'tHappenOrigin "multi-way match" -matchesCtOrigin (XMatchGroup nec) = noExtCon nec - --- | Extract a suitable CtOrigin from guarded RHSs -grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin -grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss -grhssCtOrigin (XGRHSs nec) = noExtCon nec - --- | Extract a suitable CtOrigin from a list of guarded RHSs -lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin -lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e -lGRHSCtOrigin [L _ (XGRHS nec)] = noExtCon nec -lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" - -pprCtOrigin :: CtOrigin -> SDoc --- "arising from ..." --- Not an instance of Outputable because of the "arising from" prefix -pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk - -pprCtOrigin (SpecPragOrigin ctxt) - = case ctxt of - FunSigCtxt n _ -> text "for" <+> quotes (ppr n) - SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" - _ -> text "a SPECIALISE pragma" -- Never happens I think - -pprCtOrigin (FunDepOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) - = hang (ctoHerald <+> text "a functional dependency between constraints:") - 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1) - , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) - -pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) - = hang (ctoHerald <+> text "a functional dependency between:") - 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) - 2 (pprCtOrigin orig1 ) - , hang (text "instance" <+> quotes (ppr pred2)) - 2 (text "at" <+> ppr loc2) ]) - -pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) - = hang (ctoHerald <+> text "a kind equality arising from") - 2 (sep [ppr t1, char '~', ppr t2]) - -pprCtOrigin AssocFamPatOrigin - = text "when matching a family LHS with its class instance head" - -pprCtOrigin (KindEqOrigin t1 Nothing _ _) - = hang (ctoHerald <+> text "a kind equality when matching") - 2 (ppr t1) - -pprCtOrigin (UnboundOccurrenceOf name) - = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) - -pprCtOrigin (DerivOriginDC dc n _) - = hang (ctoHerald <+> text "the" <+> speakNth n - <+> text "field of" <+> quotes (ppr dc)) - 2 (parens (text "type" <+> quotes (ppr ty))) - where - ty = dataConOrigArgTys dc !! (n-1) - -pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _) - = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) - 2 (sep [ text "from type" <+> quotes (ppr ty1) - , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) - -pprCtOrigin (DoPatOrigin pat) - = ctoHerald <+> text "a do statement" - $$ - text "with the failable pattern" <+> quotes (ppr pat) - -pprCtOrigin (MCompPatOrigin pat) - = ctoHerald <+> hsep [ text "the failable pattern" - , quotes (ppr pat) - , text "in a statement in a monad comprehension" ] -pprCtOrigin (FailablePattern pat) - = ctoHerald <+> text "the failable pattern" <+> quotes (ppr pat) - $$ - text "(this will become an error in a future GHC release)" - -pprCtOrigin (Shouldn'tHappenOrigin note) - = sdocWithDynFlags $ \dflags -> - if xopt LangExt.ImpredicativeTypes dflags - then text "a situation created by impredicative types" - else - vcat [ text "<< This should not appear in error messages. If you see this" - , text "in an error message, please report a bug mentioning" <+> quotes (text note) <+> text "at" - , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" ] - -pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) - = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") - 2 (text "the signature of" <+> quotes (ppr name)) - -pprCtOrigin (InstProvidedOrigin mod cls_inst) - = vcat [ text "arising when attempting to show that" - , ppr cls_inst - , text "is provided by" <+> quotes (ppr mod)] - -pprCtOrigin simple_origin - = ctoHerald <+> pprCtO simple_origin - --- | Short one-liners -pprCtO :: CtOrigin -> SDoc -pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] -pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] -pprCtO AppOrigin = text "an application" -pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] -pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" - ,quotes (char '#' <> ppr l)] -pprCtO RecordUpdOrigin = text "a record update" -pprCtO ExprSigOrigin = text "an expression type signature" -pprCtO PatSigOrigin = text "a pattern type signature" -pprCtO PatOrigin = text "a pattern" -pprCtO ViewPatOrigin = text "a view pattern" -pprCtO IfOrigin = text "an if expression" -pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] -pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] -pprCtO SectionOrigin = text "an operator section" -pprCtO AssocFamPatOrigin = text "the LHS of a famly instance" -pprCtO TupleOrigin = text "a tuple" -pprCtO NegateOrigin = text "a use of syntactic negation" -pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" - <> whenPprDebug (parens (ppr n)) -pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" -pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" -pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoOrigin = text "a do statement" -pprCtO MCompOrigin = text "a statement in a monad comprehension" -pprCtO ProcOrigin = text "a proc expression" -pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] -pprCtO AnnOrigin = text "an annotation" -pprCtO HoleOrigin = text "a use of" <+> quotes (text "_") -pprCtO ListOrigin = text "an overloaded list" -pprCtO StaticOrigin = text "a static form" -pprCtO _ = panic "pprCtOrigin" diff --git a/typecheck/TcPat.hs b/typecheck/TcPat.hs deleted file mode 100644 --- a/typecheck/TcPat.hs +++ /dev/null @@ -1,1196 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcPat: Typechecking patterns --} - -{-# LANGUAGE CPP, RankNTypes, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..) - , tcPat, tcPat_O, tcPats - , addDataConStupidTheta, badFieldCon, polyPatSig ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) - -import GHC.Hs -import TcHsSyn -import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) -import TcRnMonad -import Inst -import Id -import Var -import Name -import RdrName -import TcEnv -import TcMType -import TcValidity( arityErr ) -import TyCoPpr ( pprTyVars ) -import TcType -import TcUnify -import TcHsType -import TysWiredIn -import TcEvidence -import TcOrigin -import TyCon -import DataCon -import PatSyn -import ConLike -import PrelNames -import BasicTypes hiding (SuccessFlag(..)) -import DynFlags -import SrcLoc -import VarSet -import Util -import Outputable -import qualified GHC.LanguageExtensions as LangExt -import Control.Arrow ( second ) -import ListSetOps ( getNth ) - -{- -************************************************************************ -* * - External interface -* * -************************************************************************ --} - -tcLetPat :: (Name -> Maybe TcId) - -> LetBndrSpec - -> LPat GhcRn -> ExpSigmaType - -> TcM a - -> TcM (LPat GhcTcId, a) -tcLetPat sig_fn no_gen pat pat_ty thing_inside - = do { bind_lvl <- getTcLevel - ; let ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } - penv = PE { pe_lazy = True - , pe_ctxt = ctxt - , pe_orig = PatOrigin } - - ; tc_lpat pat pat_ty penv thing_inside } - ------------------ -tcPats :: HsMatchContext Name - -> [LPat GhcRn] -- Patterns, - -> [ExpSigmaType] -- and their types - -> TcM a -- and the checker for the body - -> TcM ([LPat GhcTcId], a) - --- This is the externally-callable wrapper function --- Typecheck the patterns, extend the environment to bind the variables, --- do the thing inside, use any existentially-bound dictionaries to --- discharge parts of the returning LIE, and deal with pattern type --- signatures - --- 1. Initialise the PatState --- 2. Check the patterns --- 3. Check the body --- 4. Check that no existentials escape - -tcPats ctxt pats pat_tys thing_inside - = tc_lpats penv pats pat_tys thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } - -tcPat :: HsMatchContext Name - -> LPat GhcRn -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat GhcTcId, a) -tcPat ctxt = tcPat_O ctxt PatOrigin - --- | A variant of 'tcPat' that takes a custom origin -tcPat_O :: HsMatchContext Name - -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat GhcRn -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat GhcTcId, a) -tcPat_O ctxt orig pat pat_ty thing_inside - = tc_lpat pat pat_ty penv thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } - - -{- -************************************************************************ -* * - PatEnv, PatCtxt, LetBndrSpec -* * -************************************************************************ --} - -data PatEnv - = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed - , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears - , pe_orig :: CtOrigin -- origin to use if the pat_ty needs inst'ing - } - -data PatCtxt - = LamPat -- Used for lambdas, case etc - (HsMatchContext Name) - - | LetPat -- Used only for let(rec) pattern bindings - -- See Note [Typing patterns in pattern bindings] - { pc_lvl :: TcLevel - -- Level of the binding group - - , pc_sig_fn :: Name -> Maybe TcId - -- Tells the expected type - -- for binders with a signature - - , pc_new :: LetBndrSpec - -- How to make a new binder - } -- for binders without signatures - -data LetBndrSpec - = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds - -- so clone a fresh binder for the local monomorphic Id - - | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going - -- to be an AbsBinds; So we must bind the global version - -- of the binder right away. - -- And here is the inline-pragma information - -instance Outputable LetBndrSpec where - ppr LetLclBndr = text "LetLclBndr" - ppr (LetGblBndr {}) = text "LetGblBndr" - -makeLazy :: PatEnv -> PatEnv -makeLazy penv = penv { pe_lazy = True } - -inPatBind :: PatEnv -> Bool -inPatBind (PE { pe_ctxt = LetPat {} }) = True -inPatBind (PE { pe_ctxt = LamPat {} }) = False - -{- ********************************************************************* -* * - Binders -* * -********************************************************************* -} - -tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId) --- (coi, xp) = tcPatBndr penv x pat_ty --- Then coi : pat_ty ~ typeof(xp) --- -tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } }) - bndr_name exp_pat_ty - -- For the LetPat cases, see - -- Note [Typechecking pattern bindings] in TcBinds - - | Just bndr_id <- sig_fn bndr_name -- There is a signature - = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id) - -- See Note [Subsumption check at pattern variables] - ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) - ; return (wrap, bndr_id) } - - | otherwise -- No signature - = do { (co, bndr_ty) <- case exp_pat_ty of - Check pat_ty -> promoteTcType bind_lvl pat_ty - Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res ) - -- If we were under a constructor that bumped - -- the level, we'd be in checking mode - do { bndr_ty <- inferResultToType infer_res - ; return (mkTcNomReflCo bndr_ty, bndr_ty) } - ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty - ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl - , ppr exp_pat_ty, ppr bndr_ty, ppr co - , ppr bndr_id ]) - ; return (mkWpCastN co, bndr_id) } - -tcPatBndr _ bndr_name pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) - ; return (idHsWrapper, mkLocalId bndr_name pat_ty) } - -- Whether or not there is a sig is irrelevant, - -- as this is local - -newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId --- Make up a suitable Id for the pattern-binder. --- See Note [Typechecking pattern bindings], item (4) in TcBinds --- --- In the polymorphic case when we are going to generalise --- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version" --- of the Id; the original name will be bound to the polymorphic version --- by the AbsBinds --- In the monomorphic case when we are not going to generalise --- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, --- and we use the original name directly -newLetBndr LetLclBndr name ty - = do { mono_name <- cloneLocalName name - ; return (mkLocalId mono_name ty) } -newLetBndr (LetGblBndr prags) name ty - = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name) - -tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt --- Used when typechecking patterns -tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2 - -{- Note [Subsumption check at pattern variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come across a variable with a type signature, we need to do a -subsumption, not equality, check against the context type. e.g. - - data T = MkT (forall a. a->a) - f :: forall b. [b]->[b] - MkT f = blah - -Since 'blah' returns a value of type T, its payload is a polymorphic -function of type (forall a. a->a). And that's enough to bind the -less-polymorphic function 'f', but we need some impedance matching -to witness the instantiation. - - -************************************************************************ -* * - The main worker functions -* * -************************************************************************ - -Note [Nesting] -~~~~~~~~~~~~~~ -tcPat takes a "thing inside" over which the pattern scopes. This is partly -so that tcPat can extend the environment for the thing_inside, but also -so that constraints arising in the thing_inside can be discharged by the -pattern. - -This does not work so well for the ErrCtxt carried by the monad: we don't -want the error-context for the pattern to scope over the RHS. -Hence the getErrCtxt/setErrCtxt stuff in tcMultiple --} - --------------------- -type Checker inp out = forall r. - inp - -> PatEnv - -> TcM r - -> TcM (out, r) - -tcMultiple :: Checker inp out -> Checker [inp] [out] -tcMultiple tc_pat args penv thing_inside - = do { err_ctxt <- getErrCtxt - ; let loop _ [] - = do { res <- thing_inside - ; return ([], res) } - - loop penv (arg:args) - = do { (p', (ps', res)) - <- tc_pat arg penv $ - setErrCtxt err_ctxt $ - loop penv args - -- setErrCtxt: restore context before doing the next pattern - -- See note [Nesting] above - - ; return (p':ps', res) } - - ; loop penv args } - --------------------- -tc_lpat :: LPat GhcRn - -> ExpSigmaType - -> PatEnv - -> TcM a - -> TcM (LPat GhcTcId, a) -tc_lpat (dL->L span pat) pat_ty penv thing_inside - = setSrcSpan span $ - do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) - thing_inside - ; return (cL span pat', res) } - -tc_lpats :: PatEnv - -> [LPat GhcRn] -> [ExpSigmaType] - -> TcM a - -> TcM ([LPat GhcTcId], a) -tc_lpats penv pats tys thing_inside - = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) - tcMultiple (\(p,t) -> tc_lpat p t) - (zipEqual "tc_lpats" pats tys) - penv thing_inside - --------------------- -tc_pat :: PatEnv - -> Pat GhcRn - -> ExpSigmaType -- Fully refined result type - -> TcM a -- Thing inside - -> TcM (Pat GhcTcId, -- Translated pattern - a) -- Result of thing inside - -tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside - = do { (wrap, id) <- tcPatBndr penv name pat_ty - ; res <- tcExtendIdEnv1 name id thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) } - -tc_pat penv (ParPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ParPat x pat', res) } - -tc_pat penv (BangPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (BangPat x pat', res) } - -tc_pat penv (LazyPat x pat) pat_ty thing_inside - = do { (pat', (res, pat_ct)) - <- tc_lpat pat pat_ty (makeLazy penv) $ - captureConstraints thing_inside - -- Ignore refined penv', revert to penv - - ; emitConstraints pat_ct - -- captureConstraints/extendConstraints: - -- see Note [Hopping the LIE in lazy patterns] - - -- Check that the expected pattern type is itself lifted - ; pat_ty <- readExpType pat_ty - ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind - - ; return (LazyPat x pat', res) } - -tc_pat _ (WildPat _) pat_ty thing_inside - = do { res <- thing_inside - ; pat_ty <- expTypeToType pat_ty - ; return (WildPat pat_ty, res) } - -tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside - = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat pat (mkCheckExpType $ idType bndr_id) - penv thing_inside - -- NB: if we do inference on: - -- \ (y@(x::forall a. a->a)) = e - -- we'll fail. The as-pattern infers a monotype for 'y', which then - -- fails to unify with the polymorphic type for 'x'. This could - -- perhaps be fixed, but only with a bit more work. - -- - -- If you fix it, don't forget the bindInstsOfPatIds! - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty, - res) } - -tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside - = do { - -- Expr must have type `forall a1...aN. OPT' -> B` - -- where overall_pat_ty is an instance of OPT'. - ; (expr',expr'_inferred) <- tcInferSigma expr - - -- expression must be a function - ; let expr_orig = lexprCtOrigin expr - herald = text "A view pattern expression expects" - ; (expr_wrap1, [inf_arg_ty], inf_res_ty) - <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred - -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty) - - -- check that overall pattern is more polymorphic than arg type - ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty - -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty - - -- pattern must have inf_res_ty - ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside - - ; overall_pat_ty <- readExpType overall_pat_ty - ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - overall_pat_ty inf_res_ty doc - -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" - -- (overall_pat_ty -> inf_res_ty) - expr_wrap = expr_wrap2' <.> expr_wrap1 - doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} - --- Type signatures in patterns --- See Note [Pattern coercions] below -tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside - = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) - sig_ty pat_ty - -- Using tcExtendNameTyVarEnv is appropriate here - -- because we're not really bringing fresh tyvars into scope. - -- We're *naming* existing tyvars. Note that it is OK for a tyvar - -- from an outer scope to mention one of these tyvars in its kind. - ; (pat', res) <- tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv tv_binds $ - tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } - ------------------------- --- Lists, tuples, arrays -tc_pat penv (ListPat Nothing pats) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi - (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) -} - -tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside - = do { tau_pat_ty <- expTypeToType pat_ty - ; ((pats', res, elt_ty), e') - <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] - SynList $ - \ [elt_ty] -> - do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; return (pats', res, elt_ty) } - ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) -} - -tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside - = do { let arity = length pats - tc = tupleTyCon boxity arity - -- NB: tupleTyCon does not flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in MkCore - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - -- Unboxed tuples have RuntimeRep vars, which we discard: - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) - thing_inside - - ; dflags <- getDynFlags - - -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) - -- so that we can experiment with lazy tuple-matching. - -- This is a pretty odd place to make the switch, but - -- it was easy to do. - ; let - unmangled_result = TuplePat con_arg_tys pats' boxity - -- pat_ty /= pat_ty iff coi /= IdCo - possibly_mangled_result - | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) - | otherwise = unmangled_result - - ; pat_ty <- readExpType pat_ty - ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced - return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) - } - -tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside - = do { let tc = sumTyCon arity - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - ; -- Drop levity vars, we don't care about them here - let con_arg_tys = drop arity arg_tys - ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) - penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty - , res) - } - ------------------------- --- Data constructors -tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside - = tcConPat penv con pat_ty arg_pats thing_inside - ------------------------- --- Literal patterns -tc_pat penv (LitPat x simple_lit) pat_ty thing_inside - = do { let lit_ty = hsLitType simple_lit - ; wrap <- tcSubTypePat penv pat_ty lit_ty - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty - , res) } - ------------------------- --- Overloaded patterns: n, and n+k - --- In the case of a negative literal (the more complicated case), --- we get --- --- case v of (-5) -> blah --- --- becoming --- --- if v == (negate (fromInteger 5)) then blah else ... --- --- There are two bits of rebindable syntax: --- (==) :: pat_ty -> neg_lit_ty -> Bool --- negate :: lit_ty -> neg_lit_ty --- where lit_ty is the type of the overloaded literal 5. --- --- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside - = do { let orig = LiteralOrigin over_lit - ; ((lit', mb_neg'), eq') - <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] - (mkCheckExpType boolTy) $ - \ [neg_lit_ty] -> - let new_over_lit lit_ty = newOverloadedLit over_lit - (mkCheckExpType lit_ty) - in case mb_neg of - Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty - Just neg -> -- Negative literal - -- The 'negate' is re-mappable syntax - second Just <$> - (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ - \ [lit_ty] -> new_over_lit lit_ty) - - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) } - -{- -Note [NPlusK patterns] -~~~~~~~~~~~~~~~~~~~~~~ -From - - case v of x + 5 -> blah - -we get - - if v >= 5 then (\x -> blah) (v - 5) else ... - -There are two bits of rebindable syntax: - (>=) :: pat_ty -> lit1_ty -> Bool - (-) :: pat_ty -> lit2_ty -> var_ty - -lit1_ty and lit2_ty could conceivably be different. -var_ty is the type inferred for x, the variable in the pattern. - -If the pushed-down pattern type isn't a tau-type, the two pat_ty's above -could conceivably be different specializations. But this is very much -like the situation in Note [Case branches must be taus] in TcMatches. -So we tauify the pat_ty before proceeding. - -Note that we need to type-check the literal twice, because it is used -twice, and may be used at different types. The second HsOverLit stored in the -AST is used for the subtraction operation. --} - --- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (dL->L nm_loc name) - (dL->L loc lit) _ ge minus) pat_ty - thing_inside - = do { pat_ty <- expTypeToType pat_ty - ; let orig = LiteralOrigin lit - ; (lit1', ge') - <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] - (mkCheckExpType boolTy) $ - \ [lit1_ty] -> - newOverloadedLit lit (mkCheckExpType lit1_ty) - ; ((lit2', minus_wrap, bndr_id), minus') - <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $ - \ [lit2_ty, var_ty] -> - do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) - ; (wrap, bndr_id) <- setSrcSpan nm_loc $ - tcPatBndr penv name (mkCheckExpType var_ty) - -- co :: var_ty ~ idType bndr_id - - -- minus_wrap is applicable to minus' - ; return (lit2', wrap, bndr_id) } - - -- The Report says that n+k patterns must be in Integral - -- but it's silly to insist on this in the RebindableSyntax case - ; unlessM (xoptM LangExt.RebindableSyntax) $ - do { icls <- tcLookupClass integralClassName - ; instStupidTheta orig [mkClassPred icls [pat_ty]] } - - ; res <- tcExtendIdEnv1 name bndr_id thing_inside - - ; let minus'' = minus' { syn_res_wrap = - minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2' - ge' minus'' - ; return (pat', res) } - --- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat))) - pat_ty thing_inside - = do addModFinalizersWithLclEnv mod_finalizers - tc_pat penv pat pat_ty thing_inside - -tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut - - -{- -Note [Hopping the LIE in lazy patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a lazy pattern, we must *not* discharge constraints from the RHS -from dictionaries bound in the pattern. E.g. - f ~(C x) = 3 -We can't discharge the Num constraint from dictionaries bound by -the pattern C! - -So we have to make the constraints from thing_inside "hop around" -the pattern. Hence the captureConstraints and emitConstraints. - -The same thing ensures that equality constraints in a lazy match -are not made available in the RHS of the match. For example - data T a where { T1 :: Int -> T Int; ... } - f :: T a -> Int -> a - f ~(T1 i) y = y -It's obviously not sound to refine a to Int in the right -hand side, because the argument might not match T1 at all! - -Finally, a lazy pattern should not bind any existential type variables -because they won't be in scope when we do the desugaring - - -************************************************************************ -* * - Most of the work for constructors is here - (the rest is in the ConPatIn case of tc_pat) -* * -************************************************************************ - -[Pattern matching indexed data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following declarations: - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -and a case expression - - case x :: Map (Int, c) w of MapPair m -> ... - -As explained by [Wrappers for data instance tycons] in MkIds.hs, the -worker/wrapper types for MapPair are - - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is -:R123Map, which means the straight use of boxySplitTyConApp would give a type -error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls -boxySplitTyConApp with the family tycon Map instead, which gives us the family -type list {(Int, c), w}. To get the correct split for :R123Map, we need to -unify the family type list {(Int, c), w} with the instance types {(a, b), v} -(provided by tyConFamInst_maybe together with the family tycon). This -unification yields the substitution [a -> Int, b -> c, v -> w], which gives us -the split arguments for the representation tycon :R123Map as {Int, c, w} - -In other words, boxySplitTyConAppWithFamily implicitly takes the coercion - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -moving between representation and family type into account. To produce type -correct Core, this coercion needs to be used to case the type of the scrutinee -from the family to the representation type. This is achieved by -unwrapFamInstScrutinee using a CoPat around the result pattern. - -Now it might appear seem as if we could have used the previous GADT type -refinement infrastructure of refineAlt and friends instead of the explicit -unification and CoPat generation. However, that would be wrong. Why? The -whole point of GADT refinement is that the refinement is local to the case -alternative. In contrast, the substitution generated by the unification of -the family type list and instance types needs to be propagated to the outside. -Imagine that in the above example, the type of the scrutinee would have been -(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the -substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the -instantiation of x with (a, b) must be global; ie, it must be valid in *all* -alternatives of the case expression, whereas in the GADT case it might vary -between alternatives. - -RIP GADT refinement: refinements have been replaced by the use of explicit -equality constraints that are used in conjunction with implication constraints -to express the local scope of GADT refinements. --} - --- Running example: --- MkT :: forall a b c. (a~[b]) => b -> c -> T a --- with scrutinee of type (T ty) - -tcConPat :: PatEnv -> Located Name - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside - = do { con_like <- tcLookupConLike con_name - ; case con_like of - RealDataCon data_con -> tcDataConPat penv con_lname data_con - pat_ty arg_pats thing_inside - PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn - pat_ty arg_pats thing_inside - } - -tcDataConPat :: PatEnv -> Located Name -> DataCon - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcDataConPat penv (dL->L con_span con_name) data_con pat_ty - arg_pats thing_inside - = do { let tycon = dataConTyCon data_con - -- For data families this is the representation tycon - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - header = cL con_span (RealDataCon data_con) - - -- Instantiate the constructor type variables [a->ty] - -- This may involve doing a family-instance coercion, - -- and building a wrapper - ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty - ; pat_ty <- readExpType pat_ty - - -- Add the stupid theta - ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys - - ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - - ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys - -- NB: Do not use zipTvSubst! See #14154 - -- We want to create a well-kinded substitution, so - -- that the instantiated type is well-kinded - - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs - -- Get location from monad, not from ex_tvs - - ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys - -- pat_ty' is type of the actual constructor application - -- pat_ty' /= pat_ty iff coi /= IdCo - - arg_tys' = substTys tenv arg_tys - - ; traceTc "tcConPat" (vcat [ ppr con_name - , pprTyVars univ_tvs - , pprTyVars ex_tvs - , ppr eq_spec - , ppr theta - , pprTyVars ex_tvs' - , ppr ctxt_res_tys - , ppr arg_tys' - , ppr arg_pats ]) - ; if null ex_tvs && null eq_spec && null theta - then do { -- The common case; no class bindings etc - -- (see Note [Arrows and patterns]) - (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' - arg_pats penv thing_inside - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = [], pat_dicts = [], - pat_binds = emptyTcEvBinds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - - else do -- The general case, with existential, - -- and local equality constraints - { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) - -- order is *important* as we generate the list of - -- dictionary binders from theta' - no_equalities = null eq_spec && not (any isEqPred theta) - skol_info = PatSkol (RealDataCon data_con) mc - mc = case pe_ctxt penv of - LamPat mc -> mc - LetPat {} -> PatBindRhs - - ; gadts_on <- xoptM LangExt.GADTs - ; families_on <- xoptM LangExt.TypeFamilies - ; checkTc (no_equalities || gadts_on || families_on) - (text "A pattern match on a GADT requires the" <+> - text "GADTs or TypeFamilies language extension") - -- #2905 decided that a *pattern-match* of a GADT - -- should require the GADT language flag. - -- Re TypeFamilies see also #7156 - - ; given <- newEvVars theta' - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' given $ - tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside - - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = ex_tvs', - pat_dicts = given, - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - ; return (mkHsWrapPat wrap res_pat pat_ty, res) - } } - -tcPatSynPat :: PatEnv -> Located Name -> PatSyn - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside - = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn - - ; (subst, univ_tvs') <- newMetaTyVars univ_tvs - - ; let all_arg_tys = ty : prov_theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs - ; let ty' = substTy tenv ty - arg_tys' = substTys tenv arg_tys - prov_theta' = substTheta tenv prov_theta - req_theta' = substTheta tenv req_theta - - ; wrap <- tcSubTypePat penv pat_ty ty' - ; traceTc "tcPatSynPat" (ppr pat_syn $$ - ppr pat_ty $$ - ppr ty' $$ - ppr ex_tvs' $$ - ppr prov_theta' $$ - ppr req_theta' $$ - ppr arg_tys') - - ; prov_dicts' <- newEvVars prov_theta' - - ; let skol_info = case pe_ctxt penv of - LamPat mc -> PatSkol (PatSynCon pat_syn) mc - LetPat {} -> UnkSkol -- Doesn't matter - - ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' - ; traceTc "instCall" (ppr req_wrap) - - ; traceTc "checkConstraints {" Outputable.empty - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' prov_dicts' $ - tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside - - ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = cL con_span $ PatSynCon pat_syn, - pat_tvs = ex_tvs', - pat_dicts = prov_dicts', - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = mkTyVarTys univ_tvs', - pat_wrap = req_wrap } - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - ----------------------------- --- | Convenient wrapper for calling a matchExpectedXXX function -matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) - -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) --- See Note [Matching polytyped patterns] --- Returns a wrapper : pat_ty ~R inner_ty -matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (co, res) <- inner_match pat_rho - ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) - ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } - ----------------------------- -matchExpectedConTy :: PatEnv - -> TyCon -- The TyCon that this data - -- constructor actually returns - -- In the case of a data family this is - -- the /representation/ TyCon - -> ExpSigmaType -- The type of the pattern; in the case - -- of a data family this would mention - -- the /family/ TyCon - -> TcM (HsWrapper, [TcSigmaType]) --- See Note [Matching constructor patterns] --- Returns a wrapper : pat_ty "->" T ty1 ... tyn -matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty - | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc - -- Comments refer to Note [Matching constructor patterns] - -- co_tc :: forall a. T [a] ~ T7 a - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - - ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) - -- tys = [ty1,ty2] - - ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, - ppr (tyConTyVars data_tc), - ppr fam_tc, ppr fam_args, - ppr exp_pat_ty, - ppr pat_ty, - ppr pat_rho, ppr wrap]) - ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho - -- co1 : T (ty1,ty2) ~N pat_rho - -- could use tcSubType here... but it's the wrong way round - -- for actual vs. expected in error messages. - - ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo co_tc tys' [] - -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 - - full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 - -- full_co :: pat_rho ~R T7 ty1 ty2 - - ; return ( mkWpCastR full_co <.> wrap, tys') } - - | otherwise - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho - ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } - -{- -Note [Matching constructor patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (coi, tys) = matchExpectedConType data_tc pat_ty - - * In the simple case, pat_ty = tc tys - - * If pat_ty is a polytype, we want to instantiate it - This is like part of a subsumption check. Eg - f :: (forall a. [a]) -> blah - f [] = blah - - * In a type family case, suppose we have - data family T a - data instance T (p,q) = A p | B q - Then we'll have internally generated - data T7 p q = A p | B q - axiom coT7 p q :: T (p,q) ~ T7 p q - - So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that - coi = coi2 . coi1 : T7 t ~ pat_ty - coi1 : T (ty1,ty2) ~ pat_ty - coi2 : T7 ty1 ty2 ~ T (ty1,ty2) - - For families we do all this matching here, not in the unifier, - because we never want a whisper of the data_tycon to appear in - error messages; it's a purely internal thing --} - -tcConArgs :: ConLike -> [TcSigmaType] - -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) - -tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside - = do { checkTc (con_arity == no_of_args) -- Check correct arity - (arityErr (text "constructor") con_like con_arity no_of_args) - ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys - ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys - penv thing_inside - ; return (PrefixCon arg_pats', res) } - where - con_arity = conLikeArity con_like - no_of_args = length arg_pats - -tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside - = do { checkTc (con_arity == 2) -- Check correct arity - (arityErr (text "constructor") con_like con_arity 2) - ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check - ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] - penv thing_inside - ; return (InfixCon p1' p2', res) } - where - con_arity = conLikeArity con_like - -tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside - = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside - ; return (RecCon (HsRecFields rpats' dd), res) } - where - tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) - (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (dL->L l (HsRecField (dL->L loc - (FieldOcc sel (dL->L lr rdr))) pat pun)) - penv thing_inside - = do { sel' <- tcLookupId sel - ; pat_ty <- setSrcSpan loc $ find_field_ty sel - (occNameFS $ rdrNameOcc rdr) - ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat' - pun), res) } - tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _ - = panic "tcConArgs" - tc_field _ _ _ = panic "tc_field: Impossible Match" - -- due to #15884 - - - find_field_ty :: Name -> FieldLabelString -> TcM TcType - find_field_ty sel lbl - = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of - - -- No matching field; chances are this field label comes from some - -- other record type (or maybe none). If this happens, just fail, - -- otherwise we get crashes later (#8570), and similar: - -- f (R { foo = (a,b) }) = a+b - -- If foo isn't one of R's fields, we don't want to crash when - -- typechecking the "a+b". - [] -> failWith (badFieldCon con_like lbl) - - -- The normal case, when the field comes from the right constructor - (pat_ty : extras) -> do - traceTc "find_field" (ppr pat_ty <+> ppr extras) - ASSERT( null extras ) (return pat_ty) - - field_tys :: [(FieldLabel, TcType)] - field_tys = zip (conLikeFieldLabels con_like) arg_tys - -- Don't use zipEqual! If the constructor isn't really a record, then - -- dataConFieldLabels will be empty (and each field in the pattern - -- will generate an error below). - -tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc) -tcConArg (arg_pat, arg_ty) penv thing_inside - = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside - -addDataConStupidTheta :: DataCon -> [TcType] -> TcM () --- Instantiate the "stupid theta" of the data con, and throw --- the constraints into the constraint set -addDataConStupidTheta data_con inst_tys - | null stupid_theta = return () - | otherwise = instStupidTheta origin inst_theta - where - origin = OccurrenceOf (dataConName data_con) - -- The origin should always report "occurrence of C" - -- even when C occurs in a pattern - stupid_theta = dataConStupidTheta data_con - univ_tvs = dataConUnivTyVars data_con - tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys) - -- NB: inst_tys can be longer than the univ tyvars - -- because the constructor might have existentials - inst_theta = substTheta tenv stupid_theta - -{- -Note [Arrows and patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -(Oct 07) Arrow notation has the odd property that it involves -"holes in the scope". For example: - expr :: Arrow a => a () Int - expr = proc (y,z) -> do - x <- term -< y - expr' -< x - -Here the 'proc (y,z)' binding scopes over the arrow tails but not the -arrow body (e.g 'term'). As things stand (bogusly) all the -constraints from the proc body are gathered together, so constraints -from 'term' will be seen by the tcPat for (y,z). But we must *not* -bind constraints from 'term' here, because the desugarer will not make -these bindings scope over 'term'. - -The Right Thing is not to confuse these constraints together. But for -now the Easy Thing is to ensure that we do not have existential or -GADT constraints in a 'proc', and to short-cut the constraint -simplification for such vanilla patterns so that it binds no -constraints. Hence the 'fast path' in tcConPat; but it's also a good -plan for ordinary vanilla patterns to bypass the constraint -simplification step. - -************************************************************************ -* * - Note [Pattern coercions] -* * -************************************************************************ - -In principle, these program would be reasonable: - - f :: (forall a. a->a) -> Int - f (x :: Int->Int) = x 3 - - g :: (forall a. [a]) -> Bool - g [] = True - -In both cases, the function type signature restricts what arguments can be passed -in a call (to polymorphic ones). The pattern type signature then instantiates this -type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we -generate the translated term - f = \x' :: (forall a. a->a). let x = x' Int in x 3 - -From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. -And it requires a significant amount of code to implement, because we need to decorate -the translated pattern with coercion functions (generated from the subsumption check -by tcSub). - -So for now I'm just insisting on type *equality* in patterns. No subsumption. - -Old notes about desugaring, at a time when pattern coercions were handled: - -A SigPat is a type coercion and must be handled one at at time. We can't -combine them unless the type of the pattern inside is identical, and we don't -bother to check for that. For example: - - data T = T1 Int | T2 Bool - f :: (forall a. a -> a) -> T -> t - f (g::Int->Int) (T1 i) = T1 (g i) - f (g::Bool->Bool) (T2 b) = T2 (g b) - -We desugar this as follows: - - f = \ g::(forall a. a->a) t::T -> - let gi = g Int - in case t of { T1 i -> T1 (gi i) - other -> - let gb = g Bool - in case t of { T2 b -> T2 (gb b) - other -> fail }} - -Note that we do not treat the first column of patterns as a -column of variables, because the coerced variables (gi, gb) -would be of different types. So we get rather grotty code. -But I don't think this is a common case, and if it was we could -doubtless improve it. - -Meanwhile, the strategy is: - * treat each SigPat coercion (always non-identity coercions) - as a separate block - * deal with the stuff inside, and then wrap a binding round - the result to bind the new variable (gi, gb, etc) - - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Note [Existential check] -~~~~~~~~~~~~~~~~~~~~~~~~ -Lazy patterns can't bind existentials. They arise in two ways: - * Let bindings let { C a b = e } in b - * Twiddle patterns f ~(C a b) = e -The pe_lazy field of PatEnv says whether we are inside a lazy -pattern (perhaps deeply) - -See also Note [Typechecking pattern bindings] in TcBinds --} - -maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b --- Not all patterns are worth pushing a context -maybeWrapPatCtxt pat tcm thing_inside - | not (worth_wrapping pat) = tcm thing_inside - | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside - -- Remember to pop before doing thing_inside - where - worth_wrapping (VarPat {}) = False - worth_wrapping (ParPat {}) = False - worth_wrapping (AsPat {}) = False - worth_wrapping _ = True - msg = hang (text "In the pattern:") 2 (ppr pat) - ------------------------------------------------ -checkExistentials :: [TyVar] -- existentials - -> [Type] -- argument types - -> PatEnv -> TcM () - -- See Note [Existential check]] - -- See Note [Arrows and patterns] -checkExistentials ex_tvs tys _ - | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () -checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = return () -checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat -checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat -checkExistentials _ _ _ = return () - -existentialLazyPat :: SDoc -existentialLazyPat - = hang (text "An existential or GADT data constructor cannot be used") - 2 (text "inside a lazy (~) pattern") - -existentialProcPat :: SDoc -existentialProcPat - = text "Proc patterns cannot use existential or GADT data constructors" - -badFieldCon :: ConLike -> FieldLabelString -> SDoc -badFieldCon con field - = hsep [text "Constructor" <+> quotes (ppr con), - text "does not have field", quotes (ppr field)] - -polyPatSig :: TcType -> SDoc -polyPatSig sig_ty - = hang (text "Illegal polymorphic type signature in pattern:") - 2 (ppr sig_ty) diff --git a/typecheck/TcPatSyn.hs b/typecheck/TcPatSyn.hs deleted file mode 100644 --- a/typecheck/TcPatSyn.hs +++ /dev/null @@ -1,1149 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcPatSyn]{Typechecking pattern synonym declarations} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind - , tcPatSynBuilderOcc, nonBidirectionalErr - ) where - -import GhcPrelude - -import GHC.Hs -import TcPat -import Type( tidyTyCoVarBinders, tidyTypes, tidyType ) -import TcRnMonad -import TcSigs( emptyPragEnv, completeSigFromId ) -import TcEnv -import TcMType -import TcHsSyn -import TysPrim -import Name -import SrcLoc -import PatSyn -import NameSet -import Panic -import Outputable -import FastString -import Var -import VarEnv( emptyTidyEnv, mkInScopeSet ) -import Id -import IdInfo( RecSelParent(..), setLevityInfoWithType ) -import TcBinds -import BasicTypes -import TcSimplify -import TcUnify -import Predicate -import TysWiredIn -import TcType -import TcEvidence -import TcOrigin -import BuildTyCl -import VarSet -import MkId -import TcTyDecls -import ConLike -import FieldLabel -import Bag -import Util -import ErrUtils -import Data.Maybe( mapMaybe ) -import Control.Monad ( zipWithM ) -import Data.List( partition ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Type checking a pattern synonym -* * -************************************************************************ --} - -tcPatSynDecl :: PatSynBind GhcRn GhcRn - -> Maybe TcSigInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynDecl psb mb_sig - = recoverM (recoverPSB psb) $ - case mb_sig of - Nothing -> tcInferPatSynDecl psb - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi - _ -> panic "tcPatSynDecl" - -recoverPSB :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) --- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = (dL->L _ name) - , psb_args = details }) - = do { matcher_name <- newImplicitBinder name mkMatcherOcc - ; let placeholder = AConLike $ PatSynCon $ - mk_placeholder matcher_name - ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv - ; return (emptyBag, gbl_env) } - where - (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details - mk_placeholder matcher_name - = mkPatSyn name is_infix - ([mkTyVarBinder Specified alphaTyVar], []) ([], []) - [] -- Arg tys - alphaTy - (matcher_id, True) Nothing - [] -- Field labels - where - -- The matcher_id is used only by the desugarer, so actually - -- and error-thunk would probably do just as well here. - matcher_id = mkLocalId matcher_name $ - mkSpecForAllTys [alphaTyVar] alphaTy - -recoverPSB (XPatSynBind nec) = noExtCon nec - -{- Note [Pattern synonym error recovery] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If type inference for a pattern synonym fails, we can't continue with -the rest of tc_patsyn_finish, because we may get knock-on errors, or -even a crash. E.g. from - pattern What = True :: Maybe -we get a kind error; and we must stop right away (#15289). - -We stop if there are /any/ unsolved constraints, not just insoluble -ones; because pattern synonyms are top-level things, we will never -solve them later if we can't solve them now. And if we were to carry -on, tc_patsyn_finish does zonkTcTypeToType, which defaults any -unsolved unificatdion variables to Any, which confuses the error -reporting no end (#15685). - -So we use simplifyTop to completely solve the constraint, report -any errors, throw an exception. - -Even in the event of such an error we can recover and carry on, just -as we do for value bindings, provided we plug in placeholder for the -pattern synonym: see recoverPSB. The goal of the placeholder is not -to cause a raft of follow-on errors. I've used the simplest thing for -now, but we might need to elaborate it a bit later. (e.g. I've given -it zero args, which may cause knock-on errors if it is used in a -pattern.) But it'll do for now. - --} - -tcInferPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir }) - = addPatSynCtxt lname $ - do { traceTc "tcInferPatSynDecl {" $ ppr name - - ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - ; (tclvl, wanted, ((lpat', args), pat_ty)) - <- pushLevelAndCaptureConstraints $ - tcInferNoInst $ \ exp_ty -> - tcPat PatSyn lpat exp_ty $ - mapM tcLookupId arg_names - - ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' - - named_taus = (name, pat_ty) : map mk_named_tau args - mk_named_tau arg - = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) - -- The mkSpecForAllTys is important (#14552), albeit - -- slightly artifical (there is no variable with this funny type). - -- We do not want to quantify over variable (alpha::k) - -- that mention the existentially-bound type variables - -- ex_tvs in its kind k. - -- See Note [Type variables whose kind is captured] - - ; (univ_tvs, req_dicts, ev_binds, residual, _) - <- simplifyInfer tclvl NoRestrictions [] named_taus wanted - ; top_ev_binds <- checkNoErrs (simplifyTop residual) - ; addTopEvBinds top_ev_binds $ - - do { prov_dicts <- mapM zonkId prov_dicts - ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts - -- Filtering: see Note [Remove redundant provided dicts] - (prov_theta, prov_evs) - = unzip (mapMaybe mkProvEvidence filtered_prov_dicts) - req_theta = map evVarPred req_dicts - - -- Report coercions that esacpe - -- See Note [Coercions that escape] - ; args <- mapM zonkId args - ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts - , let bad_cos = filterDVarSet isId $ - (tyCoVarsOfTypeDSet (idType arg)) - , not (isEmptyDVarSet bad_cos) ] - ; mapM_ dependentArgErr bad_args - - ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) - ; tc_patsyn_finish lname dir is_infix lpat' - (mkTyVarBinders Inferred univ_tvs - , req_theta, ev_binds, req_dicts) - (mkTyVarBinders Inferred ex_tvs - , mkTyVarTys ex_tvs, prov_theta, prov_evs) - (map nlHsVar args, map idType args) - pat_ty rec_fields } } -tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec - -mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) --- See Note [Equality evidence in pattern synonyms] -mkProvEvidence ev_id - | EqPred r ty1 ty2 <- classifyPredType pred - , let k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - is_homo = k1 `tcEqType` k2 - homo_tys = [k1, ty1, ty2] - hetero_tys = [k1, k2, ty1, ty2] - = case r of - ReprEq | is_homo - -> Just ( mkClassPred coercibleClass homo_tys - , evDataConApp coercibleDataCon homo_tys eq_con_args ) - | otherwise -> Nothing - NomEq | is_homo - -> Just ( mkClassPred eqClass homo_tys - , evDataConApp eqDataCon homo_tys eq_con_args ) - | otherwise - -> Just ( mkClassPred heqClass hetero_tys - , evDataConApp heqDataCon hetero_tys eq_con_args ) - - | otherwise - = Just (pred, EvExpr (evId ev_id)) - where - pred = evVarPred ev_id - eq_con_args = [evId ev_id] - -dependentArgErr :: (Id, DTyCoVarSet) -> TcM () --- See Note [Coercions that escape] -dependentArgErr (arg, bad_cos) - = addErrTc $ - vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" - , hang (text "Pattern-bound variable") - 2 (ppr arg <+> dcolon <+> ppr (idType arg)) - , nest 2 $ - hang (text "has a type that mentions pattern-bound coercion" - <> plural bad_co_list <> colon) - 2 (pprWithCommas ppr bad_co_list) - , text "Hint: use -fprint-explicit-coercions to see the coercions" - , text "Probable fix: add a pattern signature" ] - where - bad_co_list = dVarSetElems bad_cos - -{- Note [Type variables whose kind is captured] -~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data AST a = Sym [a] - class Prj s where { prj :: [a] -> Maybe (s a) - pattern P x <= Sym (prj -> Just x) - -Here we get a matcher with this type - $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r - -No problem. But note that 's' is not fixed by the type of the -pattern (AST a), nor is it existentially bound. It's really only -fixed by the type of the continuation. - -#14552 showed that this can go wrong if the kind of 's' mentions -existentially bound variables. We obviously can't make a type like - $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r) - -> r -> r -But neither is 's' itself existentially bound, so the forall (s::k->*) -can't go in the inner forall either. (What would the matcher apply -the continuation to?) - -Solution: do not quantiify over any unification variable whose kind -mentions the existentials. We can conveniently do that by making the -"taus" passed to simplifyInfer look like - forall ex_tvs. arg_ty - -After that, Note [Naughty quantification candidates] in TcMType takes -over, and zonks any such naughty variables to Any. - -Note [Remove redundant provided dicts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that - HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2) - => a1 :~~: a2 -(NB: technically the (k1~k2) existential dictionary is not necessary, -but it's there at the moment.) - -Now consider (#14394): - pattern Foo = HRefl -in a non-poly-kinded module. We don't want to get - pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b -with that redundant (* ~ *). We'd like to remove it; hence the call to -mkMinimalWithSCs. - -Similarly consider - data S a where { MkS :: Ord a => a -> S a } - pattern Bam x y <- (MkS (x::a), MkS (y::a))) - -The pattern (Bam x y) binds two (Ord a) dictionaries, but we only -need one. Agian mkMimimalWithSCs removes the redundant one. - -Note [Equality evidence in pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data X a where - MkX :: Eq a => [a] -> X (Maybe a) - pattern P x = MkG x - -Then there is a danger that GHC will infer - P :: forall a. () => - forall b. (a ~# Maybe b, Eq b) => [b] -> X a - -The 'builder' for P, which is called in user-code, will then -have type - $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a - -and that is bad because (a ~# Maybe b) is not a predicate type -(see Note [Types for coercions, predicates, and evidence] in TyCoRep -and is not implicitly instantiated. - -So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and -marginally less efficient, if the builder/martcher are not inlined. - -See also Note [Lift equality constaints when quantifying] in TcType - -Note [Coercions that escape] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#14507 showed an example where the inferred type of the matcher -for the pattern synonym was somethign like - $mSO :: forall (r :: TYPE rep) kk (a :: k). - TypeRep k a - -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r) - -> (Void# -> r) - -> r - -What is that co_a2sv :: Bool ~# *?? It was bound (via a superclass -selection) by the pattern being matched; and indeed it is implicit in -the context (Bool ~ k). You could imagine trying to extract it like -this: - $mSO :: forall (r :: TYPE rep) kk (a :: k). - TypeRep k a - -> ( co :: ((Bool :: *) ~ (k :: *)) => - let co_a2sv = sc_sel co - in TypeRep Bool (a |> co_a2sv) -> r) - -> (Void# -> r) - -> r - -But we simply don't allow that in types. Maybe one day but not now. - -How to detect this situation? We just look for free coercion variables -in the types of any of the arguments to the matcher. The error message -is not very helpful, but at least we don't get a Lint error. --} - -tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcPatSynInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir } - TPSI{ patsig_implicit_bndrs = implicit_tvs - , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta - , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta - , patsig_body_ty = sig_body_ty } - = addPatSynCtxt lname $ - do { let decl_arity = length arg_names - (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - - ; traceTc "tcCheckPatSynDecl" $ - vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta - , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ] - - ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of - Right stuff -> return stuff - Left missing -> wrongNumberOfParmsErr name decl_arity missing - - -- Complain about: pattern P :: () => forall x. x -> P x - -- The existential 'x' should not appear in the result type - -- Can't check this until we know P's arity - ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs - ; checkTc (null bad_tvs) $ - hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma - , text "namely" <+> quotes (ppr pat_ty) ]) - 2 (text "mentions existential type variable" <> plural bad_tvs - <+> pprQuotedList bad_tvs) - - -- See Note [The pattern-synonym signature splitting rule] in TcSigs - ; let univ_fvs = closeOverKinds $ - (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) - (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs - univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs - ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs - univ_tvs = binderVars univ_bndrs - ex_tvs = binderVars ex_bndrs - - -- Right! Let's check the pattern against the signature - -- See Note [Checking against a pattern signature] - ; req_dicts <- newEvVars req_theta - ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- - ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) - pushLevelAndCaptureConstraints $ - tcExtendTyVarEnv univ_tvs $ - tcPat PatSyn lpat (mkCheckExpType pat_ty) $ - do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) - empty_subst = mkEmptyTCvSubst in_scope - ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs - -- newMetaTyVarX: see the "Existential type variables" - -- part of Note [Checking against a pattern signature] - ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) - ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) - ; let prov_theta' = substTheta subst prov_theta - -- Add univ_tvs to the in_scope set to - -- satisfy the substitution invariant. There's no need to - -- add 'ex_tvs' as they are already in the domain of the - -- substitution. - -- See also Note [The substitution invariant] in TyCoSubst. - ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' - ; args' <- zipWithM (tc_arg subst) arg_names arg_tys - ; return (ex_tvs', prov_dicts, args') } - - ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] - -- The type here is a bit bogus, but we do not print - -- the type for PatSynCtxt, so it doesn't matter - -- See Note [Skolem info for pattern synonyms] in Origin - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted - - -- Solve the constraints now, because we are about to make a PatSyn, - -- which should not contain unification variables and the like (#10997) - ; simplifyTopImplic implics - - -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct - -- Otherwise we may get a type error when typechecking the builder, - -- when that should be impossible - - ; traceTc "tcCheckPatSynDecl }" $ ppr name - ; tc_patsyn_finish lname dir is_infix lpat' - (univ_bndrs, req_theta, ev_binds, req_dicts) - (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) - (args', arg_tys) - pat_ty rec_fields } - where - tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId) - tc_arg subst arg_name arg_ty - = do { -- Look up the variable actually bound by lpat - -- and check that it has the expected type - arg_id <- tcLookupId arg_name - ; wrap <- tcSubType_NC GenSigCtxt - (idType arg_id) - (substTyUnchecked subst arg_ty) - -- Why do we need tcSubType here? - -- See Note [Pattern synonyms and higher rank types] - ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec - -{- [Pattern synonyms and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT (forall a. a->a) - - pattern P :: (Int -> Int) -> T - pattern P x <- MkT x - -This should work. But in the matcher we must match against MkT, and then -instantiate its argument 'x', to get a function of type (Int -> Int). -Equality is not enough! #13752 was an example. - - -Note [The pattern-synonym signature splitting rule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a pattern signature, we must split - the kind-generalised variables, and - the implicitly-bound variables -into universal and existential. The rule is this -(see discussion on #11224): - - The universal tyvars are the ones mentioned in - - univ_tvs: the user-specified (forall'd) universals - - req_theta - - res_ty - The existential tyvars are all the rest - -For example - - pattern P :: () => b -> T a - pattern P x = ... - -Here 'a' is universal, and 'b' is existential. But there is a wrinkle: -how do we split the arg_tys from req_ty? Consider - - pattern Q :: () => b -> S c -> T a - pattern Q x = ... - -This is an odd example because Q has only one syntactic argument, and -so presumably is defined by a view pattern matching a function. But -it can happen (#11977, #12108). - -We don't know Q's arity from the pattern signature, so we have to wait -until we see the pattern declaration itself before deciding res_ty is, -and hence which variables are existential and which are universal. - -And that in turn is why TcPatSynInfo has a separate field, -patsig_implicit_bndrs, to capture the implicitly bound type variables, -because we don't yet know how to split them up. - -It's a slight compromise, because it means we don't really know the -pattern synonym's real signature until we see its declaration. So, -for example, in hs-boot file, we may need to think what to do... -(eg don't have any implicitly-bound variables). - - -Note [Checking against a pattern signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the actual supplied pattern against the pattern synonym -signature, we need to be quite careful. - ------ Provided constraints -Example - - data T a where - MkT :: Ord a => a -> T a - - pattern P :: () => Eq a => a -> [T a] - pattern P x = [MkT x] - -We must check that the (Eq a) that P claims to bind (and to -make available to matches against P), is derivable from the -actual pattern. For example: - f (P (x::a)) = ...here (Eq a) should be available... -And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs. - ------ Existential type variables -Unusually, we instantiate the existential tyvars of the pattern with -*meta* type variables. For example - - data S where - MkS :: Eq a => [a] -> S - - pattern P :: () => Eq x => x -> S - pattern P x <- MkS x - -The pattern synonym conceals from its client the fact that MkS has a -list inside it. The client just thinks it's a type 'x'. So we must -unify x := [a] during type checking, and then use the instantiating type -[a] (called ex_tys) when building the matcher. In this case we'll get - - $mP :: S -> (forall x. Ex x => x -> r) -> r -> r - $mP x k = case x of - MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a] - dl = $dfunEqList d - in k [a] dl ys - -All this applies when type-checking the /matching/ side of -a pattern synonym. What about the /building/ side? - -* For Unidirectional, there is no builder - -* For ExplicitBidirectional, the builder is completely separate - code, typechecked in tcPatSynBuilderBind - -* For ImplicitBidirectional, the builder is still typechecked in - tcPatSynBuilderBind, by converting the pattern to an expression and - typechecking it. - - At one point, for ImplicitBidirectional I used TyVarTvs (instead of - TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here - is redundant since tcPatSynBuilderBind does the job, (b) it was - still incomplete (TyVarTvs can unify with each other), and (c) it - didn't even work (#13441 was accepted with - ExplicitBidirectional, but rejected if expressed in - ImplicitBidirectional form. Conclusion: trying to be too clever is - a bad idea. --} - -collectPatSynArgInfo :: HsPatSynDetails (Located Name) - -> ([Name], [Name], Bool) -collectPatSynArgInfo details = - case details of - PrefixCon names -> (map unLoc names, [], False) - InfixCon name1 name2 -> (map unLoc [name1, name2], [], True) - RecCon names -> (vars, sels, False) - where - (vars, sels) = unzip (map splitRecordPatSyn names) - where - splitRecordPatSyn :: RecordPatSynField (Located Name) - -> (Name, Name) - splitRecordPatSyn (RecordPatSynField - { recordPatSynPatVar = (dL->L _ patVar) - , recordPatSynSelectorId = (dL->L _ selId) }) - = (patVar, selId) - -addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (dL->L loc name) thing_inside - = setSrcSpan loc $ - addErrCtxt (text "In the declaration for pattern synonym" - <+> quotes (ppr name)) $ - thing_inside - -wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a -wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ - hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has") - <+> speakNOf decl_arity (text "argument")) - 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") - -------------------------- --- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name - -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) - -> Bool -- ^ Whether infix - -> LPat GhcTc -- ^ Pattern of the PatSyn - -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) - -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and - -- types - -> TcType -- ^ Pattern type - -> [Name] -- ^ Selector names - -- ^ Whether fields, empty if not record PatSyn - -> TcM (LHsBinds GhcTc, TcGblEnv) -tc_patsyn_finish lname dir is_infix lpat' - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty field_labels - = do { -- Zonk everything. We are about to build a final PatSyn - -- so there had better be no unification variables in there - - (ze, univ_tvs') <- zonkTyVarBinders univ_tvs - ; req_theta' <- zonkTcTypesToTypesX ze req_theta - ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs - ; prov_theta' <- zonkTcTypesToTypesX ze prov_theta - ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty - ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys - - ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyCoVarBinders env1 ex_tvs' - req_theta = tidyTypes env2 req_theta' - prov_theta = tidyTypes env2 prov_theta' - arg_tys = tidyTypes env2 arg_tys' - pat_ty = tidyType env2 pat_ty' - - ; traceTc "tc_patsyn_finish {" $ - ppr (unLoc lname) $$ ppr (unLoc lpat') $$ - ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ - ppr (ex_tvs, prov_theta, prov_dicts) $$ - ppr args $$ - ppr arg_tys $$ - ppr pat_ty - - -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' - (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) - (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty - - -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname - univ_tvs req_theta - ex_tvs prov_theta - arg_tys pat_ty - - -- TODO: Make this have the proper information - ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name) - , flIsOverloaded = False - , flSelector = name } - field_labels' = map mkFieldLabel field_labels - - - -- Make the PatSyn itself - ; let patSyn = mkPatSyn (unLoc lname) is_infix - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - arg_tys - pat_ty - matcher_id builder_id - field_labels' - - -- Selectors - ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) - tything = AConLike (PatSynCon patSyn) - ; tcg_env <- tcExtendGlobalEnv [tything] $ - tcRecSelBinds rn_rec_sel_binds - - ; traceTc "tc_patsyn_finish }" empty - ; return (matcher_bind, tcg_env) } - -{- -************************************************************************ -* * - Constructing the "matcher" Id and its binding -* * -************************************************************************ --} - -tcPatSynMatcher :: Located Name - -> LPat GhcTc - -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) - -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) - -> ([LHsExpr GhcTcId], [TcType]) - -> TcType - -> TcM ((Id, Bool), LHsBinds GhcTc) --- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynMatcher (dL->L loc name) lpat - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) pat_ty - = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc - ; tv_name <- newNameAt (mkTyVarOcc "r") loc - ; let rr_tv = mkTyVar rr_name runtimeRepTy - rr = mkTyVarTy rr_tv - res_tv = mkTyVar tv_name (tYPE rr) - res_ty = mkTyVarTy res_tv - is_unlifted = null args && null prov_dicts - (cont_args, cont_arg_tys) - | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) - | otherwise = (args, arg_tys) - cont_ty = mkInfSigmaTy ex_tvs prov_theta $ - mkVisFunTys cont_arg_tys res_ty - - fail_ty = mkVisFunTy voidPrimTy res_ty - - ; matcher_name <- newImplicitBinder name mkMatcherOcc - ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty - ; cont <- newSysLocalId (fsLit "cont") cont_ty - ; fail <- newSysLocalId (fsLit "fail") fail_ty - - ; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty - matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau - matcher_id = mkExportedVanillaId matcher_name matcher_sigma - -- See Note [Exported LocalIds] in Id - - inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys - cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args - - fail' = nlHsApps fail [nlHsVar voidPrimId] - - args = map nlVarPat [scrutinee, cont, fail] - lwpat = noLoc $ WildPat pat_ty - cases = if isIrrefutableHsPat lpat - then [mkHsCaseAlt lpat cont'] - else [mkHsCaseAlt lpat cont', - mkHsCaseAlt lwpat fail'] - body = mkLHsWrap (mkWpLet req_ev_binds) $ - cL (getLoc lpat) $ - HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = cL (getLoc lpat) cases - , mg_ext = MatchGroupTc [pat_ty] res_ty - , mg_origin = Generated - } - body' = noLoc $ - HsLam noExtField $ - MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr - args body] - , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty - , mg_origin = Generated - } - match = mkMatch (mkPrefixFunRhs (cL loc name)) [] - (mkHsLams (rr_tv:res_tv:univ_tvs) - req_dicts body') - (noLoc (EmptyLocalBinds noExtField)) - mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = cL (getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty - , mg_origin = Generated - } - - ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = cL loc matcher_id - , fun_matches = mg - , fun_co_fn = idHsWrapper - , fun_tick = [] } - matcher_bind = unitBag (noLoc bind) - - ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) - ; traceTc "tcPatSynMatcher" (ppr matcher_bind) - - ; return ((matcher_id, is_unlifted), matcher_bind) } - -mkPatSynRecSelBinds :: PatSyn - -> [FieldLabel] -- ^ Visible field labels - -> [(Id, LHsBind GhcRn)] -mkPatSynRecSelBinds ps fields - = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl - | fld_lbl <- fields ] - -isUnidirectional :: HsPatSynDir a -> Bool -isUnidirectional Unidirectional = True -isUnidirectional ImplicitBidirectional = False -isUnidirectional ExplicitBidirectional{} = False - -{- -************************************************************************ -* * - Constructing the "builder" Id -* * -************************************************************************ --} - -mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyVarBinder] -> ThetaType - -> [TyVarBinder] -> ThetaType - -> [Type] -> Type - -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (dL->L _ name) - univ_bndrs req_theta ex_bndrs prov_theta - arg_tys pat_ty - | isUnidirectional dir - = return Nothing - | otherwise - = do { builder_name <- newImplicitBinder name mkBuilderOcc - ; let theta = req_theta ++ prov_theta - need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta - builder_sigma = add_void need_dummy_arg $ - mkForAllTys univ_bndrs $ - mkForAllTys ex_bndrs $ - mkPhiTy theta $ - mkVisFunTys arg_tys $ - pat_ty - builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in Id - - builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id - - ; return (Just (builder_id', need_dummy_arg)) } - where - -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc) --- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) - , psb_def = lpat - , psb_dir = dir - , psb_args = details }) - | isUnidirectional dir - = return emptyBag - - | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLoc lpat) $ failWithTc $ - vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr name) <> colon) - 2 why - , text "RHS pattern:" <+> ppr lpat ] - - | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name - ; case patSynBuilder patsyn of { - Nothing -> return emptyBag ; - -- This case happens if we found a type error in the - -- pattern synonym, recovered, and put a placeholder - -- with patSynBuilder=Nothing in the environment - - Just (builder_id, need_dummy_arg) -> -- Normal case - do { -- Bidirectional, so patSynBuilder returns Just - let match_group' | need_dummy_arg = add_dummy_arg match_group - | otherwise = match_group - - bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = cL loc (idName builder_id) - , fun_matches = match_group' - , fun_co_fn = idHsWrapper - , fun_tick = [] } - - sig = completeSigFromId (PatSynCtxt name) builder_id - - ; traceTc "tcPatSynBuilderBind {" $ - ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) - ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds - ; return builder_binds } } } - - | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with - where - mb_match_group - = case dir of - ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) - Unidirectional -> panic "tcPatSynBuilderBind" - - mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated [builder_match] - where - builder_args = [cL loc (VarPat noExtField (cL loc n)) - | (dL->L loc n) <- args] - builder_match = mkMatch (mkPrefixFunRhs (cL loc name)) - builder_args body - (noLoc (EmptyLocalBinds noExtField)) - - args = case details of - PrefixCon args -> args - InfixCon arg1 arg2 -> [arg1, arg2] - RecCon args -> map recordPatSynPatVar args - - add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) - -> MatchGroup GhcRn (LHsExpr GhcRn) - add_dummy_arg mg@(MG { mg_alts = - (dL->L l [dL->L loc - match@(Match { m_pats = pats })]) }) - = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } - add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ - pprMatches other_mg -tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec - -tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) --- monadic only for failure -tcPatSynBuilderOcc ps - | Just (builder_id, add_void_arg) <- builder - , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) - builder_ty = idType builder_id - = return $ - if add_void_arg - then ( builder_expr -- still just return builder_expr; the void# arg is added - -- by dsConLike in the desugarer - , tcFunResultTy builder_ty ) - else (builder_expr, builder_ty) - - | otherwise -- Unidirectional - = nonBidirectionalErr name - where - name = patSynName ps - builder = patSynBuilder ps - -add_void :: Bool -> Type -> Type -add_void need_dummy_arg ty - | need_dummy_arg = mkVisFunTy voidPrimTy ty - | otherwise = ty - -tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn - -> Either MsgDoc (LHsExpr GhcRn) --- Given a /pattern/, return an /expression/ that builds a value --- that matches the pattern. E.g. if the pattern is (Just [x]), --- the expression is (Just [x]). They look the same, but the --- input uses constructors from HsPat and the output uses constructors --- from HsExpr. --- --- Returns (Left r) if the pattern is not invertible, for reason r. --- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr name args pat = go pat - where - lhsVars = mkNameSet (map unLoc args) - - -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat GhcRn] - -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(dL->L loc _) pats - = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExtField (cL loc x) y) - (HsVar noExtField lcon) exprs) } - - mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) - -> Either MsgDoc (HsExpr GhcRn) - mkRecordConExpr con fields - = do { exprFields <- mapM go fields - ; return (RecordCon noExtField con exprFields) } - - go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (dL->L loc p) = cL loc <$> go1 p - - go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) - go1 (ConPatIn con info) - = case info of - PrefixCon ps -> mkPrefixConExpr con ps - InfixCon l r -> mkPrefixConExpr con [l,r] - RecCon fields -> mkRecordConExpr con fields - - go1 (SigPat _ pat _) = go1 (unLoc pat) - -- See Note [Type signatures and the builder expression] - - go1 (VarPat _ (dL->L l var)) - | var `elemNameSet` lhsVars - = return $ HsVar noExtField (cL l var) - | otherwise - = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat - go1 p@(ListPat reb pats) - | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList noExtField Nothing exprs } - | otherwise = notInvertibleListPat p - go1 (TuplePat _ pats box) = do { exprs <- mapM go pats - ; return $ ExplicitTuple noExtField - (map (noLoc . (Present noExtField)) exprs) - box } - go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) - ; return $ ExplicitSum noExtField alt arity - (noLoc expr) - } - go1 (LitPat _ lit) = return $ HsLit noExtField lit - go1 (NPat _ (dL->L _ n) mb_neg _) - | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg - [noLoc (HsOverLit noExtField n)] - | otherwise = return $ HsOverLit noExtField n - go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" - go1 (CoPat{}) = panic "CoPat in output of renamer" - go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) - = go1 pat - go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" - go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety" - - -- The following patterns are not invertible. - go1 p@(BangPat {}) = notInvertible p -- #14112 - go1 p@(LazyPat {}) = notInvertible p - go1 p@(WildPat {}) = notInvertible p - go1 p@(AsPat {}) = notInvertible p - go1 p@(ViewPat {}) = notInvertible p - go1 p@(NPlusKPat {}) = notInvertible p - go1 p@(XPat {}) = notInvertible p - go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p - go1 p@(SplicePat _ (XSplice {})) = notInvertible p - - notInvertible p = Left (not_invertible_msg p) - - not_invertible_msg p - = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" - $+$ hang (text "Suggestion: instead use an explicitly bidirectional" - <+> text "pattern synonym, e.g.") - 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow - <+> ppr pat <+> text "where") - 2 (pp_name <+> pp_args <+> equals <+> text "...")) - where - pp_name = ppr name - pp_args = hsep (map ppr args) - - -- We should really be able to invert list patterns, even when - -- rebindable syntax is on, but doing so involves a bit of - -- refactoring; see #14380. Until then we reject with a - -- helpful error message. - notInvertibleListPat p - = Left (vcat [ not_invertible_msg p - , text "Reason: rebindable syntax is on." - , text "This is fixable: add use-case to #14380" ]) - -{- Note [Builder for a bidirectional pattern synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a bidirectional pattern synonym we need to produce an /expression/ -that matches the supplied /pattern/, given values for the arguments -of the pattern synonym. For example - pattern F x y = (Just x, [y]) -The 'builder' for F looks like - $builderF x y = (Just x, [y]) - -We can't always do this: - * Some patterns aren't invertible; e.g. view patterns - pattern F x = (reverse -> x:_) - - * The RHS pattern might bind more variables than the pattern - synonym, so again we can't invert it - pattern F x = (x,y) - - * Ditto wildcards - pattern F x = (x,_) - - -Note [Redundant constraints for builder] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The builder can have redundant constraints, which are awkard to eliminate. -Consider - pattern P = Just 34 -To match against this pattern we need (Eq a, Num a). But to build -(Just 34) we need only (Num a). Fortunately instTcSigFromId sets -sig_warn_redundant to False. - -************************************************************************ -* * - Helper functions -* * -************************************************************************ - -Note [As-patterns in pattern synonym definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The rationale for rejecting as-patterns in pattern synonym definitions -is that an as-pattern would introduce nonindependent pattern synonym -arguments, e.g. given a pattern synonym like: - - pattern K x y = x@(Just y) - -one could write a nonsensical function like - - f (K Nothing x) = ... - -or - g (K (Just True) False) = ... - -Note [Type signatures and the builder expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - pattern L x = Left x :: Either [a] [b] - -In tc{Infer/Check}PatSynDecl we will check that the pattern has the -specified type. We check the pattern *as a pattern*, so the type -signature is a pattern signature, and so brings 'a' and 'b' into -scope. But we don't have a way to bind 'a, b' in the LHS, as we do -'x', say. Nevertheless, the sigature may be useful to constrain -the type. - -When making the binding for the *builder*, though, we don't want - $buildL x = Left x :: Either [a] [b] -because that wil either mean (forall a b. Either [a] [b]), or we'll -get a complaint that 'a' and 'b' are out of scope. (Actually the -latter; #9867.) No, the job of the signature is done, so when -converting the pattern to an expression (for the builder RHS) we -simply discard the signature. - -Note [Record PatSyn Desugaring] -------------------------------- -It is important that prov_theta comes before req_theta as this ordering is used -when desugaring record pattern synonym updates. - -Any change to this ordering should make sure to change deSugar/DsExpr.hs if you -want to avoid difficult to decipher core lint errors! - -} - - -nonBidirectionalErr :: Outputable name => name -> TcM a -nonBidirectionalErr name = failWithTc $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" - --- Walk the whole pattern and for all ConPatOuts, collect the --- existentially-bound type variables and evidence binding variables. --- --- These are used in computing the type of a pattern synonym and also --- in generating matcher functions, since success continuations need --- to be passed these pattern-bound evidences. -tcCollectEx - :: LPat GhcTc - -> ( [TyVar] -- Existentially-bound type variables - -- in correctly-scoped order; e.g. [ k:*, x:k ] - , [EvVar] ) -- and evidence variables - -tcCollectEx pat = go pat - where - go :: LPat GhcTc -> ([TyVar], [EvVar]) - go = go1 . unLoc - - go1 :: Pat GhcTc -> ([TyVar], [EvVar]) - go1 (LazyPat _ p) = go p - go1 (AsPat _ _ p) = go p - go1 (ParPat _ p) = go p - go1 (BangPat _ p) = go p - go1 (ListPat _ ps) = mergeMany . map go $ ps - go1 (TuplePat _ ps _) = mergeMany . map go $ ps - go1 (SumPat _ p _ _) = go p - go1 (ViewPat _ _ p) = go p - go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ - goConDetails $ pat_args con - go1 (SigPat _ p _) = go p - go1 (CoPat _ _ p _) = go1 p - go1 (NPlusKPat _ n k _ geq subtract) - = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract - go1 _ = empty - - goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) - goConDetails (PrefixCon ps) = mergeMany . map go $ ps - goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 - goConDetails (RecCon HsRecFields{ rec_flds = flds }) - = mergeMany . map goRecFd $ flds - - goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p - - merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) - mergeMany = foldr merge empty - empty = ([], []) diff --git a/typecheck/TcPatSyn.hs-boot b/typecheck/TcPatSyn.hs-boot deleted file mode 100644 --- a/typecheck/TcPatSyn.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -module TcPatSyn where - -import GHC.Hs ( PatSynBind, LHsBinds ) -import TcRnTypes ( TcM, TcSigInfo ) -import TcRnMonad ( TcGblEnv) -import Outputable ( Outputable ) -import GHC.Hs.Extension ( GhcRn, GhcTc ) -import Data.Maybe ( Maybe ) - -tcPatSynDecl :: PatSynBind GhcRn GhcRn - -> Maybe TcSigInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) - -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) - -nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/typecheck/TcPluginM.hs b/typecheck/TcPluginM.hs deleted file mode 100644 --- a/typecheck/TcPluginM.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE CPP #-} --- | This module provides an interface for typechecker plugins to --- access select functions of the 'TcM', principally those to do with --- reading parts of the state. -module TcPluginM ( - -- * Basic TcPluginM functionality - TcPluginM, - tcPluginIO, - tcPluginTrace, - unsafeTcPluginTcM, - - -- * Finding Modules and Names - FindResult(..), - findImportedModule, - lookupOrig, - - -- * Looking up Names in the typechecking environment - tcLookupGlobal, - tcLookupTyCon, - tcLookupDataCon, - tcLookupClass, - tcLookup, - tcLookupId, - - -- * Getting the TcM state - getTopEnv, - getEnvs, - getInstEnvs, - getFamInstEnvs, - matchFam, - - -- * Type variables - newUnique, - newFlexiTyVar, - isTouchableTcPluginM, - - -- * Zonking - zonkTcType, - zonkCt, - - -- * Creating constraints - newWanted, - newDerived, - newGiven, - newCoercionHole, - - -- * Manipulating evidence bindings - newEvVar, - setEvBind, - getEvBindsTcPluginM - ) where - -import GhcPrelude - -import qualified TcRnMonad as TcM -import qualified TcSMonad as TcS -import qualified TcEnv as TcM -import qualified TcMType as TcM -import qualified FamInst as TcM -import qualified IfaceEnv -import qualified Finder - -import FamInstEnv ( FamInstEnv ) -import TcRnMonad ( TcGblEnv, TcLclEnv, TcPluginM - , unsafeTcPluginTcM, getEvBindsTcPluginM - , liftIO, traceTc ) -import Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) -import TcMType ( TcTyVar, TcType ) -import TcEnv ( TcTyThing ) -import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..) - , EvExpr, EvBind, mkGivenEvBind ) -import Var ( EvVar ) - -import Module -import Name -import TyCon -import DataCon -import Class -import HscTypes -import Outputable -import Type -import Id -import InstEnv -import FastString -import Unique - - --- | Perform some IO, typically to interact with an external tool. -tcPluginIO :: IO a -> TcPluginM a -tcPluginIO a = unsafeTcPluginTcM (liftIO a) - --- | Output useful for debugging the compiler. -tcPluginTrace :: String -> SDoc -> TcPluginM () -tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) - - -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult -findImportedModule mod_name mb_pkg = do - hsc_env <- getTopEnv - tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg - -lookupOrig :: Module -> OccName -> TcPluginM Name -lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod - - -tcLookupGlobal :: Name -> TcPluginM TyThing -tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal - -tcLookupTyCon :: Name -> TcPluginM TyCon -tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon - -tcLookupDataCon :: Name -> TcPluginM DataCon -tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon - -tcLookupClass :: Name -> TcPluginM Class -tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass - -tcLookup :: Name -> TcPluginM TcTyThing -tcLookup = unsafeTcPluginTcM . TcM.tcLookup - -tcLookupId :: Name -> TcPluginM Id -tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId - - -getTopEnv :: TcPluginM HscEnv -getTopEnv = unsafeTcPluginTcM TcM.getTopEnv - -getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) -getEnvs = unsafeTcPluginTcM TcM.getEnvs - -getInstEnvs :: TcPluginM InstEnvs -getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs - -getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) -getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs - -matchFam :: TyCon -> [Type] - -> TcPluginM (Maybe (TcCoercion, TcType)) -matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args - -newUnique :: TcPluginM Unique -newUnique = unsafeTcPluginTcM TcM.newUnique - -newFlexiTyVar :: Kind -> TcPluginM TcTyVar -newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar - -isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool -isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM - --- Confused by zonking? See Note [What is zonking?] in TcMType. -zonkTcType :: TcType -> TcPluginM TcType -zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType - -zonkCt :: Ct -> TcPluginM Ct -zonkCt = unsafeTcPluginTcM . TcM.zonkCt - - --- | Create a new wanted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted loc pty - = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty) - --- | Create a new derived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } - --- | Create a new given constraint, with the supplied evidence. This --- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it --- will panic. -newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence -newGiven loc pty evtm = do - new_ev <- newEvVar pty - setEvBind $ mkGivenEvBind new_ev (EvExpr evtm) - return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } - --- | Create a fresh evidence variable. -newEvVar :: PredType -> TcPluginM EvVar -newEvVar = unsafeTcPluginTcM . TcM.newEvVar - --- | Create a fresh coercion hole. -newCoercionHole :: PredType -> TcPluginM CoercionHole -newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole - --- | Bind an evidence variable. This must not be invoked from --- 'tcPluginInit' or 'tcPluginStop', or it will panic. -setEvBind :: EvBind -> TcPluginM () -setEvBind ev_bind = do - tc_evbinds <- getEvBindsTcPluginM - unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind diff --git a/typecheck/TcRnDriver.hs b/typecheck/TcRnDriver.hs deleted file mode 100644 --- a/typecheck/TcRnDriver.hs +++ /dev/null @@ -1,2955 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcRnDriver]{Typechecking a whole module} - -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -module TcRnDriver ( - tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, - isGHCiMonad, - runTcInteractive, -- Used by GHC API clients (#8878) - tcRnLookupName, - tcRnGetInfo, - tcRnModule, tcRnModuleTcRnM, - tcTopSrcDecls, - rnTopSrcDecls, - checkBootDecl, checkHiBootIface', - findExtraSigImports, - implicitRequirements, - checkUnitId, - mergeSignatures, - tcRnMergeSignatures, - instantiateSignature, - tcRnInstantiateSignature, - loadUnqualIfaces, - -- More private... - badReexportedBootThing, - checkBootDeclM, - missingBootThing, - getRenamedStuff, RenamedStuff - ) where - -import GhcPrelude - -import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers ) -import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) -import IfaceEnv( externaliseName ) -import TcHsType -import TcValidity( checkValidType ) -import TcMatches -import Inst( deeplyInstantiate ) -import TcUnify( checkConstraints ) -import RnTypes -import RnExpr -import RnUtils ( HsDocContext(..) ) -import RnFixity ( lookupFixityRn ) -import MkId -import TysWiredIn ( unitTy, mkListTy ) -import Plugins -import DynFlags -import GHC.Hs -import IfaceSyn ( ShowSub(..), showToHeader ) -import IfaceType( ShowForAllFlag(..) ) -import PatSyn( pprPatSynType ) -import PrelNames -import PrelInfo -import RdrName -import TcHsSyn -import TcExpr -import TcRnMonad -import TcRnExports -import TcEvidence -import Constraint -import TcOrigin -import qualified BooleanFormula as BF -import PprTyThing( pprTyThingInContext ) -import CoreFVs( orphNamesOfFamInst ) -import FamInst -import InstEnv -import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons - , famInstEnvElts, extendFamInstEnvList, normaliseType ) -import TcAnnotations -import TcBinds -import MkIface ( coAxiomToIfaceDecl ) -import HeaderInfo ( mkPrelImports ) -import TcDefaults -import TcEnv -import TcRules -import TcForeign -import TcInstDcls -import TcIface -import TcMType -import TcType -import TcSimplify -import TcTyClsDecls -import TcTypeable ( mkTypeableBinds ) -import TcBackpack -import LoadIface -import RnNames -import RnEnv -import RnSource -import ErrUtils -import Id -import IdInfo( IdDetails(..) ) -import VarEnv -import Module -import UniqFM -import Name -import NameEnv -import NameSet -import Avail -import TyCon -import SrcLoc -import HscTypes -import ListSetOps -import Outputable -import ConLike -import DataCon -import Type -import Class -import BasicTypes hiding( SuccessFlag(..) ) -import CoAxiom -import Annotations -import Data.List ( sortBy, sort ) -import Data.Ord -import FastString -import Maybes -import Util -import Bag -import Inst (tcGetInsts) -import qualified GHC.LanguageExtensions as LangExt -import Data.Data ( Data ) -import GHC.Hs.Dump -import qualified Data.Set as S - -import Control.DeepSeq -import Control.Monad - -import TcHoleFitTypes ( HoleFitPluginR (..) ) - - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Typecheck and rename a module -* * -************************************************************************ --} - --- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> ModSummary - -> Bool -- True <=> save renamed syntax - -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) - -tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)} - | RealSrcSpan real_loc <- loc - = withTiming dflags - (text "Renamer/typechecker"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ - - tcRnModuleTcRnM hsc_env mod_sum parsedModule pair - - | otherwise - = return ((emptyBag, unitBag err_msg), Nothing) - - where - hsc_src = ms_hsc_src mod_sum - dflags = hsc_dflags hsc_env - err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ - text "Module does not have a RealSrcSpan:" <+> ppr this_mod - - this_pkg = thisPackage (hsc_dflags hsc_env) - - pair :: (Module, SrcSpan) - pair@(this_mod,_) - | Just (dL->L mod_loc mod) <- hsmodName this_module - = (mkModule this_pkg mod, mod_loc) - - | otherwise -- 'module M where' is omitted - = (mAIN, srcLocSpan (srcSpanStart loc)) - - - - -tcRnModuleTcRnM :: HscEnv - -> ModSummary - -> HsParsedModule - -> (Module, SrcSpan) - -> TcRn TcGblEnv --- Factored out separately from tcRnModule so that a Core plugin can --- call the type checker directly -tcRnModuleTcRnM hsc_env mod_sum - (HsParsedModule { - hpm_module = - (dL->L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec - maybe_doc_hdr)), - hpm_src_files = src_files - }) - (this_mod, prel_imp_loc) - = setSrcSpan loc $ - do { let { explicit_mod_hdr = isJust maybe_mod - ; hsc_src = ms_hsc_src mod_sum } - ; -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - tcg_env <- getGblEnv - ; boot_info <- tcHiBootIface hsc_src this_mod - ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) - $ do - { -- Deal with imports; first add implicit prelude - implicit_prelude <- xoptM LangExt.ImplicitPrelude - ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc - implicit_prelude import_decls } - - ; whenWOptM Opt_WarnImplicitPrelude $ - when (notNull prel_imports) $ - addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) - - ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (dL->L _ idecl) = - ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) - } - ; raw_sig_imports <- liftIO - $ findExtraSigImports hsc_env hsc_src - (moduleName this_mod) - ; raw_req_imports <- liftIO - $ implicitRequirements hsc_env - (map simplifyImport (prel_imports - ++ import_decls)) - ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc - $ (simpleImportDecl mod_name) - { ideclHiding = Just (False, noLoc [])} - ; mkImport _ = panic "mkImport" } - ; let { all_imports = prel_imports ++ import_decls - ++ map mkImport (raw_sig_imports ++ raw_req_imports) } - ; -- OK now finally rename the imports - tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env all_imports - - ; -- If the whole module is warned about or deprecated - -- (via mod_deprec) record that in tcg_warns. If we do thereby add - -- a WarnAll, it will override any subsequent deprecations added to tcg_warns - let { tcg_env1 = case mod_deprec of - Just (dL->L _ txt) -> - tcg_env {tcg_warns = WarnAll txt} - Nothing -> tcg_env - } - ; setGblEnv tcg_env1 - $ do { -- Rename and type check the declarations - traceRn "rn1a" empty - ; tcg_env <- if isHsBootOrSig hsc_src - then tcRnHsBootDecls hsc_src local_decls - else {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr local_decls - ; setGblEnv tcg_env - $ do { -- Process the export list - traceRn "rn4a: before exports" empty - ; tcg_env <- tcRnExports explicit_mod_hdr export_ies - tcg_env - ; traceRn "rn4b: after exports" empty - ; -- When a module header is specified, - -- check that the main module exports a main function. - -- (must be after tcRnExports) - when explicit_mod_hdr $ checkMainExported tcg_env - ; -- Compare hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_info - ; -- The new type env is already available to stuff - -- slurped from interface files, via - -- TcEnv.setGlobalTypeEnv. It's important that this - -- includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for - -- boot_dfuns, which may be mentioned in imported - -- unfoldings. - - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) - ; -- Report unused names - -- Do this /after/ typeinference, so that when reporting - -- a function with no type signature we can give the - -- inferred type - reportUnusedNames tcg_env hsc_src - ; -- add extra source files to tcg_dependent_files - addDependentFiles src_files - -- Ensure plugins run with the same tcg_env that we pass in - ; setGblEnv tcg_env - $ do { tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env - ; -- Dump output and return - tcDump tcg_env - ; return tcg_env - } - } - } - } - } - -implicitPreludeWarn :: SDoc -implicitPreludeWarn - = text "Module `Prelude' implicitly imported" - -{- -************************************************************************ -* * - Import declarations -* * -************************************************************************ --} - -tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv -tcRnImports hsc_env import_decls - = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; - - ; this_mod <- getModule - ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - ; dep_mods = imp_dep_mods imports - - -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- get the instances from this module's hs-boot file. This - -- filtering also ensures that we don't see instances from - -- modules batch (@--make@) compiled before this one, but - -- which are not below this one. - ; want_instances :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; (home_insts, home_fam_insts) = hptInstances hsc_env - want_instances - } ; - - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { - tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn "rn1" (ppr (imp_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module (including orphan family - -- instance-module) interfaces, so that their rules and - -- instance decls will be found. But filter out a - -- self hs-boot: these instances will be checked when - -- we define them locally. - -- (We don't need to load non-orphan family instance - -- modules until we either try to use the instances they - -- define, or define our own family instances, at which - -- point we need to check them for consistency.) - ; loadModuleInterfaces (text "Loading orphan modules") - (filter (/= this_mod) (imp_orphs imports)) - - -- Check type-family consistency between imports. - -- See Note [The type family instance consistency story] - ; traceRn "rn1: checking family instance consistency {" empty - ; let { dir_imp_mods = moduleEnvKeys - . imp_mods - $ imports } - ; checkFamInstConsistency dir_imp_mods - ; traceRn "rn1: } checking family instance consistency" empty - - ; getGblEnv } } - -{- -************************************************************************ -* * - Type-checking the top level of a module -* * -************************************************************************ --} - -tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> [LHsDecl GhcPs] -- Declarations - -> TcM TcGblEnv -tcRnSrcDecls explicit_mod_hdr decls - = do { -- Do all the declarations - ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls - - -- Check for the 'main' declaration - -- Must do this inside the captureTopConstraints - -- NB: always set envs *before* captureTopConstraints - ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $ - captureTopConstraints $ - checkMain explicit_mod_hdr - - ; setEnvs (tcg_env, tcl_env) $ do { - - -- Simplify constraints - -- - -- We do this after checkMain, so that we use the type info - -- that checkMain adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - ; new_ev_binds <- {-# SCC "simplifyTop" #-} - simplifyTop (lie `andWC` lie_main) - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - - - ; traceTc "Tc9" empty - - ; failIfErrsM -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! - ; traceTc "Tc10" empty - - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. - -- This pass also warns about missing type signatures - ; (bind_env, ev_binds', binds', fords', imp_specs', rules') - <- zonkTcGblEnv new_ev_binds tcg_env - - -- Finalizers must run after constraints are simplified, or some types - -- might not be complete when using reify (see #12777). - -- and also after we zonk the first time because we run typed splices - -- in the zonker which gives rise to the finalisers. - ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env) - run_th_modfinalizers - ; finishTH - ; traceTc "Tc11" empty - - ; -- zonk the new bindings arising from running the finalisers. - -- This won't give rise to any more finalisers as you can't nest - -- finalisers inside finalisers. - ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) - <- zonkTcGblEnv emptyBag tcg_env_mf - - - ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env) - (plusTypeEnv bind_env_mf bind_env) - ; tcg_env' = tcg_env_mf - { tcg_binds = binds' `unionBags` binds_mf, - tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf , - tcg_imp_specs = imp_specs' ++ imp_specs_mf , - tcg_rules = rules' ++ rules_mf , - tcg_fords = fords' ++ fords_mf } } ; - - ; setGlobalTypeEnv tcg_env' final_type_env - - } } - -zonkTcGblEnv :: Bag EvBind -> TcGblEnv - -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, - [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) -zonkTcGblEnv new_ev_binds tcg_env = - let TcGblEnv { tcg_binds = binds, - tcg_ev_binds = cur_ev_binds, - tcg_imp_specs = imp_specs, - tcg_rules = rules, - tcg_fords = fords } = tcg_env - - all_ev_binds = cur_ev_binds `unionBags` new_ev_binds - - in {-# SCC "zonkTopDecls" #-} - zonkTopDecls all_ev_binds binds rules imp_specs fords - - --- | Remove accumulated bindings, rules and so on from TcGblEnv -clearTcGblEnv :: TcGblEnv -> TcGblEnv -clearTcGblEnv tcg_env - = tcg_env { tcg_binds = emptyBag, - tcg_ev_binds = emptyBag , - tcg_imp_specs = [], - tcg_rules = [], - tcg_fords = [] } - --- | Runs TH finalizers and renames and typechecks the top-level declarations --- that they could introduce. -run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) -run_th_modfinalizers = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - th_modfinalizers <- readTcRef th_modfinalizers_var - if null th_modfinalizers - then getEnvs - else do - writeTcRef th_modfinalizers_var [] - let run_finalizer (lcl_env, f) = - setLclEnv lcl_env (runRemoteModFinalizers f) - - (_, lie_th) <- captureTopConstraints $ - mapM_ run_finalizer th_modfinalizers - - -- Finalizers can add top-level declarations with addTopDecls, so - -- we have to run tc_rn_src_decls to get them - (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] - - setEnvs (tcg_env, tcl_env) $ do - -- Subsequent rounds of finalizers run after any new constraints are - -- simplified, or some types might not be complete when using reify - -- (see #12777). - new_ev_binds <- {-# SCC "simplifyTop2" #-} - simplifyTop (lie_th `andWC` lie_top_decls) - addTopEvBinds new_ev_binds run_th_modfinalizers - -- addTopDecls can add declarations which add new finalizers. - -tc_rn_src_decls :: [LHsDecl GhcPs] - -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) --- Loops around dealing with each top level inter-splice group --- in turn, until it's dealt with the entire module --- Never emits constraints; calls captureTopConstraints internally -tc_rn_src_decls ds - = {-# SCC "tc_rn_src_decls" #-} - do { (first_group, group_tail) <- findSplice ds - -- If ds is [] we get ([], Nothing) - - -- Deal with decls up to, but not including, the first splice - ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group - -- rnTopSrcDecls fails if there are any errors - - -- Get TH-generated top-level declarations and make sure they don't - -- contain any splices since we don't handle that at the moment - -- - -- The plumbing here is a bit odd: see #10853 - ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - ; th_ds <- readTcRef th_topdecls_var - ; writeTcRef th_topdecls_var [] - - ; (tcg_env, rn_decls) <- - if null th_ds - then return (tcg_env, rn_decls) - else do { (th_group, th_group_tail) <- findSplice th_ds - ; case th_group_tail of - { Nothing -> return () - ; Just (SpliceDecl _ (dL->L loc _) _, _) -> - setSrcSpan loc - $ addErr (text - ("Declaration splices are not " - ++ "permitted inside top-level " - ++ "declarations added with addTopDecls")) - ; Just (XSpliceDecl nec, _) -> noExtCon nec - } - -- Rename TH-generated top-level declarations - ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env - $ rnTopSrcDecls th_group - - -- Dump generated top-level declarations - ; let msg = "top-level declarations added with addTopDecls" - ; traceSplice - $ SpliceInfo { spliceDescription = msg - , spliceIsDecl = True - , spliceSource = Nothing - , spliceGenerated = ppr th_rn_decls } - ; return (tcg_env, appendGroups rn_decls th_rn_decls) - } - - -- Type check all declarations - -- NB: set the env **before** captureTopConstraints so that error messages - -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that - -- the captureTopConstraints must go here, not in tcRnSrcDecls. - ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ - captureTopConstraints $ - tcTopSrcDecls rn_decls - - -- If there is no splice, we're nearly done - ; setEnvs (tcg_env, tcl_env) $ - case group_tail of - { Nothing -> return (tcg_env, tcl_env, lie1) - - -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (dL->L loc splice) _, rest_ds) -> - do { recordTopLevelSpliceLoc loc - - -- Rename the splice expression, and get its supporting decls - ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice - - -- Glue them on the front of the remaining decls and loop - ; (tcg_env, tcl_env, lie2) <- - setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls (spliced_decls ++ rest_ds) - - ; return (tcg_env, tcl_env, lie1 `andWC` lie2) - } - ; Just (XSpliceDecl nec, _) -> noExtCon nec - } - } - -{- -************************************************************************ -* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -* * -************************************************************************ --} - -tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv -tcRnHsBootDecls hsc_src decls - = do { (first_group, group_tail) <- findSplice decls - - -- Rename the declarations - ; (tcg_env, HsGroup { hs_tyclds = tycl_decls - , hs_derivds = deriv_decls - , hs_fords = for_decls - , hs_defds = def_decls - , hs_ruleds = rule_decls - , hs_annds = _ - , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) - <- rnTopSrcDecls first_group - - -- The empty list is for extra dependencies coming from .hs-boot files - -- See Note [Extra dependencies from .hs-boot files] in RnSource - - ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { - -- NB: setGblEnv **before** captureTopConstraints so that - -- if the latter reports errors, it knows what's in scope - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d - Just (XSpliceDecl nec, _) -> noExtCon nec - Nothing -> return () - ; mapM_ (badBootDecl hsc_src "foreign") for_decls - ; mapM_ (badBootDecl hsc_src "default") def_decls - ; mapM_ (badBootDecl hsc_src "rule") rule_decls - - -- Typecheck type/class/instance decls - ; traceTc "Tc2 (boot)" empty - ; (tcg_env, inst_infos, _deriv_binds) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds - ; setGblEnv tcg_env $ do { - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds val_sigs - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 - }}} - ; traceTc "boot" (ppr lie); return gbl_env } - -badBootDecl :: HscSource -> String -> Located decl -> TcM () -badBootDecl hsc_src what (dL->L loc _) - = addErrAt loc (char 'A' <+> text what - <+> text "declaration is not (currently) allowed in a" - <+> (case hsc_src of - HsBootFile -> text "hs-boot" - HsigFile -> text "hsig" - _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> text "file") - -{- -Once we've typechecked the body of the module, we want to compare what -we've found (gathered in a TypeEnv) with the hi-boot details (if any). --} - -checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv --- Compare the hi-boot file for this module (if there is one) --- with the type environment we've just come up with --- In the common case where there is no hi-boot file, the list --- of boot_names is empty. - -checkHiBootIface tcg_env boot_info - | NoSelfBoot <- boot_info -- Common case - = return tcg_env - - | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! - = return tcg_env - - | SelfBoot { sb_mds = boot_details } <- boot_info - , TcGblEnv { tcg_binds = binds - , tcg_insts = local_insts - , tcg_type_env = local_type_env - , tcg_exports = local_exports } <- tcg_env - = do { -- This code is tricky, see Note [DFun knot-tying] - ; dfun_prs <- checkHiBootIface' local_insts local_type_env - local_exports boot_details - - -- Now add the boot-dfun bindings $fxblah = $fblah - -- to (a) the type envt, and (b) the top-level bindings - ; let boot_dfuns = map fst dfun_prs - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - tcg_env_w_binds - = tcg_env { tcg_binds = binds `unionBags` dfun_binds } - - ; type_env' `seq` - -- Why the seq? Without, we will put a TypeEnv thunk in - -- tcg_type_env_var. That thunk will eventually get - -- forced if we are typechecking interfaces, but that - -- is no good if we are trying to typecheck the very - -- DFun we were going to put in. - -- TODO: Maybe setGlobalTypeEnv should be strict. - setGlobalTypeEnv tcg_env_w_binds type_env' } - - | otherwise = panic "checkHiBootIface: unreachable code" - -{- Note [DFun impedance matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We return a list of "impedance-matching" bindings for the dfuns -defined in the hs-boot file, such as - $fxEqT = $fEqT -We need these because the module and hi-boot file might differ in -the name it chose for the dfun: the name of a dfun is not -uniquely determined by its type; there might be multiple dfuns -which, individually, would map to the same name (in which case -we have to disambiguate them.) There's no way for the hi file -to know exactly what disambiguation to use... without looking -at the hi-boot file itself. - -In fact, the names will always differ because we always pick names -prefixed with "$fx" for boot dfuns, and "$f" for real dfuns -(so that this impedance matching is always possible). - -Note [DFun knot-tying] -~~~~~~~~~~~~~~~~~~~~~~ -The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from -typechecking the hi-boot file that we are presently implementing. -Suppose we are typechecking the module A: when we typecheck the -hi-boot file, whenever we see an identifier A.T, we knot-tie this -identifier to the *local* type environment (via if_rec_types.) The -contract then is that we don't *look* at 'SelfBootInfo' until we've -finished typechecking the module and updated the type environment with -the new tycons and ids. - -This most works well, but there is one problem: DFuns! We do not want -to look at the mb_insts of the ModDetails in SelfBootInfo, because a -dfun in one of those ClsInsts is gotten (in TcIface.tcIfaceInst) by a -(lazily evaluated) lookup in the if_rec_types. We could extend the -type env, do a setGloblaTypeEnv etc; but that all seems very indirect. -It is much more directly simply to extract the DFunIds from the -md_types of the SelfBootInfo. - -See #4003, #16038 for why we need to take care here. --} - -checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] - -> ModDetails -> TcM [(Id, Id)] --- Variant which doesn't require a full TcGblEnv; you could get the --- local components from another ModDetails. -checkHiBootIface' - local_insts local_type_env local_exports - (ModDetails { md_types = boot_type_env - , md_fam_insts = boot_fam_insts - , md_exports = boot_exports }) - = do { traceTc "checkHiBootIface" $ vcat - [ ppr boot_type_env, ppr boot_exports] - - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports - - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") - -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... - - -- Check instance declarations - -- and generate an impedance-matching binding - ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns - - ; failIfErrsM - - ; return (catMaybes mb_dfun_prs) } - - where - boot_dfun_names = map idName boot_dfuns - boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env - -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts - -- We don't want to look at md_insts! - -- Why not? See Note [DFun knot-tying] - - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` boot_dfun_names = return () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) - - -- Check that the actual module exports the same thing - | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) - (missingBootThing True (head missing_names) "exported by") - - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) - | isNothing mb_boot_thing = return () - - -- Check that the actual module also defines the thing, and - -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name, - Just boot_thing <- mb_boot_thing - = checkBootDeclM True boot_thing real_thing - - | otherwise - = addErrTc (missingBootThing True name "defined in") - where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - - local_export_env :: NameEnv AvailInfo - local_export_env = availsToNameEnv local_exports - - check_cls_inst :: DFunId -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent - -- real dfun. Delicate (like checkBootDecl) because it depends - -- on the types lining up precisely even to the ordering of - -- the type variables in the foralls. - check_cls_inst boot_dfun - | (real_dfun : _) <- find_real_dfun boot_dfun - , let local_boot_dfun = Id.mkExportedVanillaId - (idName boot_dfun) (idType real_dfun) - = return (Just (local_boot_dfun, real_dfun)) - -- Two tricky points here: - -- - -- * The local_boot_fun should have a Name from the /boot-file/, - -- but type from the dfun defined in /this module/. - -- That ensures that the TyCon etc inside the type are - -- the ones defined in this module, not the ones gotten - -- from the hi-boot file, which may have a lot less info - -- (#8743, comment:10). - -- - -- * The DFunIds from boot_details are /GlobalIds/, because - -- they come from typechecking M.hi-boot. - -- But all bindings in this module should be for /LocalIds/, - -- otherwise dependency analysis fails (#16038). This - -- is another reason for using mkExportedVanillaId, rather - -- that modifying boot_dfun, to make local_boot_fun. - - | otherwise - = setSrcSpan (getLoc (getName boot_dfun)) $ - do { traceTc "check_cls_inst" $ vcat - [ text "local_insts" <+> - vcat (map (ppr . idType . instanceDFunId) local_insts) - , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] - - ; addErrTc (instMisMatch boot_dfun) - ; return Nothing } - - find_real_dfun :: DFunId -> [DFunId] - find_real_dfun boot_dfun - = [dfun | inst <- local_insts - , let dfun = instanceDFunId inst - , idType dfun `eqType` boot_dfun_ty ] - where - boot_dfun_ty = idType boot_dfun - - --- In general, to perform these checks we have to --- compare the TyThing from the .hi-boot file to the TyThing --- in the current source file. We must be careful to allow alpha-renaming --- where appropriate, and also the boot declaration is allowed to omit --- constructors and class methods. --- --- See rnfail055 for a good test of this stuff. - --- | Compares two things for equivalence between boot-file and normal code, --- reporting an error if they don't match up. -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> - addErrAt span - (bootMisMatch is_boot err real_thing boot_thing) - where - -- Here we use the span of the boot thing or, if it doesn't have a sensible - -- span, that of the real thing, - span - | let span = nameSrcSpan (getName boot_thing) - , isGoodSrcSpan span - = span - | otherwise - = nameSrcSpan (getName real_thing) - --- | Compares the two things for equivalence between boot-file and normal --- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ --- failure. If the difference will be apparent to the user, @Just empty@ is --- perfectly suitable. -checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc - -checkBootDecl _ (AnId id1) (AnId id2) - = ASSERT(id1 == id2) - check (idType id1 `eqType` idType id2) - (text "The two types are different") - -checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon is_boot tc1 tc2 - -checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ _ = Just empty -- probably shouldn't happen - --- | Combines two potential error messages -andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc -Nothing `andThenCheck` msg = msg -msg `andThenCheck` Nothing = msg -Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) -infixr 0 `andThenCheck` - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, return the provided check -checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc -checkUnless True _ = Nothing -checkUnless False k = k - --- | Run the check provided for every pair of elements in the lists. --- The provided SDoc should name the element type, in the plural. -checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc - -> Maybe SDoc -checkListBy check_fun as bs whats = go [] as bs - where - herald = text "The" <+> whats <+> text "do not match" - - go [] [] [] = Nothing - go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) - go docs (x:xs) (y:ys) = case check_fun x y of - Just doc -> go (doc:docs) xs ys - Nothing -> go docs xs ys - go _ _ _ = Just (hang (herald <> colon) - 2 (text "There are different numbers of" <+> whats)) - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, fail with the given SDoc. -check :: Bool -> SDoc -> Maybe SDoc -check True _ = Nothing -check False doc = Just doc - --- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. -checkSuccess :: Maybe SDoc -checkSuccess = Nothing - ----------------- -checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc -checkBootTyCon is_boot tc1 tc2 - | not (eqType (tyConKind tc1) (tyConKind tc2)) - = Just $ text "The types have different kinds" -- First off, check the kind - - | Just c1 <- tyConClass_maybe tc1 - , Just c2 <- tyConClass_maybe tc2 - , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) - = classExtraBigSig c1 - (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) - = classExtraBigSig c2 - , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 - = let - eqSig (id1, def_meth1) (id2, def_meth2) - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "are different") `andThenCheck` - check (eqTypeX env op_ty1 op_ty2) - (text "The types of" <+> pname1 <+> - text "are different") `andThenCheck` - if is_boot - then check (eqMaybeBy eqDM def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are different") - else check (subDM op_ty1 def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are not compatible") - where - name1 = idName id1 - name2 = idName id2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - (_, rho_ty1) = splitForAllTys (idType id1) - op_ty1 = funResultTy rho_ty1 - (_, rho_ty2) = splitForAllTys (idType id2) - op_ty2 = funResultTy rho_ty2 - - eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon is_boot tc1 tc2 `andThenCheck` - check (eqATDef def_ats1 def_ats2) - (text "The associated type defaults differ") - - eqDM (_, VanillaDM) (_, VanillaDM) = True - eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 - eqDM _ _ = False - - -- NB: first argument is from hsig, second is from real impl. - -- Order of pattern matching matters. - subDM _ Nothing _ = True - subDM _ _ Nothing = False - -- If the hsig wrote: - -- - -- f :: a -> a - -- default f :: a -> a - -- - -- this should be validly implementable using an old-fashioned - -- vanilla default method. - subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM)) - = eqTypeX env t1 t2 - -- This case can occur when merging signatures - subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True - subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - -- Ignore the location of the defaults - eqATDef Nothing Nothing = True - eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 - eqATDef _ _ = False - - eqFD (as1,bs1) (as2,bs2) = - eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - checkRoles roles1 roles2 `andThenCheck` - -- Checks kind of class - check (eqListBy eqFD clas_fds1 clas_fds2) - (text "The functional dependencies do not match") `andThenCheck` - checkUnless (isAbstractTyCon tc1) $ - check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) - (text "The class constraints do not match") `andThenCheck` - checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` - checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` - check (classMinimalDef c1 `BF.implies` classMinimalDef c2) - (text "The MINIMAL pragmas are not compatible") - - | Just syn_rhs1 <- synTyConRhs_maybe tc1 - , Just syn_rhs2 <- synTyConRhs_maybe tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = ASSERT(tc1 == tc2) - checkRoles roles1 roles2 `andThenCheck` - check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say - -- This allows abstract 'data T a' to be implemented using 'type T = ...' - -- and abstract 'class K a' to be implement using 'type K = ...' - -- See Note [Synonyms implement abstract data] - | not is_boot -- don't support for hs-boot yet - , isAbstractTyCon tc1 - , Just (tvs, ty) <- synTyConDefn_maybe tc2 - , Just (tc2', args) <- tcSplitTyConApp_maybe ty - = checkSynAbsData tvs ty tc2' args - -- TODO: When it's a synonym implementing a class, we really - -- should check if the fundeps are satisfied, but - -- there is not an obvious way to do this for a constraint synonym. - -- So for now, let it all through (it won't cause segfaults, anyway). - -- Tracked at #12704. - - -- This allows abstract 'data T :: Nat' to be implemented using - -- 'type T = 42' Since the kinds already match (we have checked this - -- upfront) all we need to check is that the implementation 'type T - -- = ...' defined an actual literal. See #15138 for the case this - -- handles. - | not is_boot - , isAbstractTyCon tc1 - , Just (_,ty2) <- synTyConDefn_maybe tc2 - , isJust (isLitTy ty2) - = Nothing - - | Just fam_flav1 <- famTyConFlav_maybe tc1 - , Just fam_flav2 <- famTyConFlav_maybe tc2 - = ASSERT(tc1 == tc2) - let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True - eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True - -- This case only happens for hsig merging: - eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True - eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True - eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True - eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) - = eqClosedFamilyAx ax1 ax2 - eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 - eqFamFlav _ _ = False - injInfo1 = tyConInjectivityInfo tc1 - injInfo2 = tyConInjectivityInfo tc2 - in - -- check equality of roles, family flavours and injectivity annotations - -- (NB: Type family roles are always nominal. But the check is - -- harmless enough.) - checkRoles roles1 roles2 `andThenCheck` - check (eqFamFlav fam_flav1 fam_flav2) - (whenPprDebug $ - text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> - text "do not match") `andThenCheck` - check (injInfo1 == injInfo2) (text "Injectivities do not match") - - | isAlgTyCon tc1 && isAlgTyCon tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = ASSERT(tc1 == tc2) - checkRoles roles1 roles2 `andThenCheck` - check (eqListBy (eqTypeX env) - (tyConStupidTheta tc1) (tyConStupidTheta tc2)) - (text "The datatype contexts do not match") `andThenCheck` - eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) - - | otherwise = Just empty -- two very different types -- should be obvious - where - roles1 = tyConRoles tc1 -- the abstract one - roles2 = tyConRoles tc2 - roles_msg = text "The roles do not match." $$ - (text "Roles on abstract types default to" <+> - quotes (text "representational") <+> text "in boot files.") - - roles_subtype_msg = text "The roles are not compatible:" $$ - text "Main module:" <+> ppr roles2 $$ - text "Hsig file:" <+> ppr roles1 - - checkRoles r1 r2 - | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] - = check (r1 == r2) roles_msg - | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg - - -- Note [Role subtyping] - -- ~~~~~~~~~~~~~~~~~~~~~ - -- In the current formulation of roles, role subtyping is only OK if the - -- "abstract" TyCon was not representationally injective. Among the most - -- notable examples of non representationally injective TyCons are abstract - -- data, which can be implemented via newtypes (which are not - -- representationally injective). The key example is - -- in this example from #13140: - -- - -- -- In an hsig file - -- data T a -- abstract! - -- type role T nominal - -- - -- -- Elsewhere - -- foo :: Coercible (T a) (T b) => a -> b - -- foo x = x - -- - -- We must NOT allow foo to typecheck, because if we instantiate - -- T with a concrete data type with a phantom role would cause - -- Coercible (T a) (T b) to be provable. Fortunately, if T is not - -- representationally injective, we cannot make the inference that a ~N b if - -- T a ~R T b. - -- - -- Unconditional role subtyping would be possible if we setup - -- an extra set of roles saying when we can project out coercions - -- (we call these proj-roles); then it would NOT be valid to instantiate T - -- with a data type at phantom since the proj-role subtyping check - -- would fail. See #13140 for more details. - -- - -- One consequence of this is we get no role subtyping for non-abstract - -- data types in signatures. Suppose you have: - -- - -- signature A where - -- type role T nominal - -- data T a = MkT - -- - -- If you write this, we'll treat T as injective, and make inferences - -- like T a ~R T b ==> a ~N b (mkNthCo). But if we can - -- subsequently replace T with one at phantom role, we would then be able to - -- infer things like T Int ~R T Bool which is bad news. - -- - -- We could allow role subtyping here if we didn't treat *any* data types - -- defined in signatures as injective. But this would be a bit surprising, - -- replacing a data type in a module with one in a signature could cause - -- your code to stop typechecking (whereas if you made the type abstract, - -- it is more understandable that the type checker knows less). - -- - -- It would have been best if this was purely a question of defaults - -- (i.e., a user could explicitly ask for one behavior or another) but - -- the current role system isn't expressive enough to do this. - -- Having explict proj-roles would solve this problem. - - rolesSubtypeOf [] [] = True - -- NB: this relation is the OPPOSITE of the subroling relation - rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys - rolesSubtypeOf _ _ = False - - -- Note [Synonyms implement abstract data] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- An abstract data type or class can be implemented using a type synonym, - -- but ONLY if the type synonym is nullary and has no type family - -- applications. This arises from two properties of skolem abstract data: - -- - -- For any T (with some number of paramaters), - -- - -- 1. T is a valid type (it is "curryable"), and - -- - -- 2. T is valid in an instance head (no type families). - -- - -- See also 'HowAbstract' and Note [Skolem abstract data]. - - -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@, - -- check that this synonym is an acceptable implementation of @tc1@. - -- See Note [Synonyms implement abstract data] - checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc - checkSynAbsData tvs ty tc2' args = - check (null (tcTyFamInsts ty)) - (text "Illegal type family application in implementation of abstract data.") - `andThenCheck` - check (null tvs) - (text "Illegal parameterized type synonym in implementation of abstract data." $$ - text "(Try eta reducing your type synonym so that it is nullary.)") - `andThenCheck` - -- Don't report roles errors unless the type synonym is nullary - checkUnless (not (null tvs)) $ - ASSERT( null roles2 ) - -- If we have something like: - -- - -- signature H where - -- data T a - -- module H where - -- data K a b = ... - -- type T = K Int - -- - -- we need to drop the first role of K when comparing! - checkRoles roles1 (drop (length args) (tyConRoles tc2')) -{- - -- Hypothetically, if we were allow to non-nullary type synonyms, here - -- is how you would check the roles - if length tvs == length roles1 - then checkRoles roles1 roles2 - else case tcSplitTyConApp_maybe ty of - Just (tc2', args) -> - checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2) - Nothing -> Just roles_msg --} - - eqAlgRhs _ AbstractTyCon _rhs2 - = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon - eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = - checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") - eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = - eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> - text "definition with a" <+> quotes (text "newtype") <+> - text "definition") - - eqCon c1 c2 - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "differ") `andThenCheck` - check (dataConIsInfix c1 == dataConIsInfix c2) - (text "The fixities of" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) - (text "The strictness annotations for" <+> pname1 <+> - text "differ") `andThenCheck` - check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) - (text "The record label lists for" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqType (dataConUserType c1) (dataConUserType c2)) - (text "The types for" <+> pname1 <+> text "differ") - where - name1 = dataConName c1 - name2 = dataConName c2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - - eqClosedFamilyAx Nothing Nothing = True - eqClosedFamilyAx Nothing (Just _) = False - eqClosedFamilyAx (Just _) Nothing = False - eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) - (Just (CoAxiom { co_ax_branches = branches2 })) - = numBranches branches1 == numBranches branches2 - && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2) - where - branch_list1 = fromBranches branches1 - branch_list2 = fromBranches branches2 - - eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 - , cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 - , cab_lhs = lhs2, cab_rhs = rhs2 }) - | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 - , Just env <- eqVarBndrs env1 cvs1 cvs2 - = eqListBy (eqTypeX env) lhs1 lhs2 && - eqTypeX env rhs1 rhs2 - - | otherwise = False - -emptyRnEnv2 :: RnEnv2 -emptyRnEnv2 = mkRnEnv2 emptyInScopeSet - ----------------- -missingBootThing :: Bool -> Name -> String -> SDoc -missingBootThing is_boot name what - = quotes (ppr name) <+> text "is exported by the" - <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file, but not" - <+> text what <+> text "the module" - -badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc -badReexportedBootThing dflags is_boot name name' - = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat - [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file (re)exports" <+> quotes (ppr name) - , text "but the implementing module exports a different identifier" <+> quotes (ppr name') - ] - -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc -bootMisMatch is_boot extra_info real_thing boot_thing - = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - where - to_doc - = pprTyThingInContext $ showToHeader { ss_forall = - if is_boot - then ShowForAllMust - else ShowForAllWhen } - - real_doc = to_doc real_thing - boot_doc = to_doc boot_thing - - pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - = vcat - [ ppr real_thing <+> - text "has conflicting definitions in the module", - text "and its" <+> - (if is_boot - then text "hs-boot file" - else text "hsig file"), - text "Main module:" <+> real_doc, - (if is_boot - then text "Boot file: " - else text "Hsig file: ") - <+> boot_doc, - extra_info - ] - -instMisMatch :: DFunId -> SDoc -instMisMatch dfun - = hang (text "instance" <+> ppr (idType dfun)) - 2 (text "is defined in the hs-boot file, but not in the module itself") - -{- -************************************************************************ -* * - Type-checking the top level of a module (continued) -* * -************************************************************************ --} - -rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) --- Fails if there are any errors -rnTopSrcDecls group - = do { -- Rename the source decls - traceRn "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; - traceRn "rn13" empty ; - (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; - traceRn "rn13-plugin" empty ; - - -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; - - -- Dump trace of renaming part - rnDump rn_decls ; - return (tcg_env', rn_decls) - } - -tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_valds = hs_val_binds@(XValBindsLR - (NValBinds val_binds val_sigs)) }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2 (src)" empty ; - - -- Source-language instances, including derivings, - -- and import the supporting declarations - traceTc "Tc3" empty ; - (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs)) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; - - setGblEnv tcg_env $ do { - - -- Generate Applicative/Monad proposal (AMP) warnings - traceTc "Tc3b" empty ; - - -- Generate Semigroup/Monoid warnings - traceTc "Tc3c" empty ; - tcSemigroupWarnings ; - - -- Foreign import declarations next. - traceTc "Tc4" empty ; - (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { - - -- Default declarations - traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Value declarations next. - -- It is important that we check the top-level value bindings - -- before the GHC-generated derived bindings, since the latter - -- may be defined in terms of the former. (For instance, - -- the bindings produced in a Data instance.) - traceTc "Tc5" empty ; - tc_envs <- tcTopBinds val_binds val_sigs; - setEnvs tc_envs $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs@(tcg_env, tcl_env) - <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; - setEnvs tc_envs $ do { -- Environment doesn't change now - - -- Second pass over class and instance declarations, - -- now using the kind-checked decls - traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; - - -- Foreign exports - traceTc "Tc7" empty ; - (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; - - -- Annotations - annotations <- tcAnnotations annotation_decls ; - - -- Rules - rules <- tcRules rule_decls ; - - -- Wrap up - traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds - - ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre) - emptyFVs fo_gres - - ; sig_names = mkNameSet (collectHsValBinders hs_val_binds) - `minusNameSet` getTypeSigNames val_sigs - - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds - , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names - , tcg_rules = tcg_rules tcg_env - ++ flattenRuleDecls rules - , tcg_anns = tcg_anns tcg_env ++ annotations - , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations - , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; - -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] - - -- See Note [Newtype constructor usage in foreign declarations] - addUsedGREs (bagToList fo_gres) ; - - return (tcg_env', tcl_env) - }}}}}} - -tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" - - -tcSemigroupWarnings :: TcM () -tcSemigroupWarnings = do - traceTc "tcSemigroupWarnings" empty - let warnFlag = Opt_WarnSemigroup - tcPreludeClashWarn warnFlag sappendName - tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName - - --- | Warn on local definitions of names that would clash with future Prelude --- elements. --- --- A name clashes if the following criteria are met: --- 1. It would is imported (unqualified) from Prelude --- 2. It is locally defined in the current module --- 3. It has the same literal name as the reference function --- 4. It is not identical to the reference function -tcPreludeClashWarn :: WarningFlag - -> Name - -> TcM () -tcPreludeClashWarn warnFlag name = do - { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcPreludeClashWarn/wouldBeImported" empty - -- Is the name imported (unqualified) from Prelude? (Point 4 above) - ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv - -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude - -- will not appear in rnImports automatically if it is set.) - - -- Continue only the name is imported from Prelude - ; when (importedViaPrelude name rnImports) $ do - -- Handle 2.-4. - { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = isLocalDef && nameClashes && isNotInProperModule - where - isLocalDef = gre_lcl x == True - -- Names are identical ... - nameClashes = nameOccName (gre_name x) == nameOccName name - -- ... but not the actual definitions, because we don't want to - -- warn about a bad definition of e.g. <> in Data.Semigroup, which - -- is the (only) proper place where this should be defined - isNotInProperModule = gre_name x /= name - - -- List of all offending definitions - clashingElts :: [GlobalRdrElt] - clashingElts = filter clashes rdrElts - - ; traceTc "tcPreludeClashWarn/prelude_functions" - (hang (ppr name) 4 (sep [ppr clashingElts])) - - ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep - [ text "Local definition of" - , (quotes . ppr . nameOccName . gre_name) x - , text "clashes with a future Prelude name." ] - $$ - text "This will become an error in a future release." ) - ; mapM_ warn_msg clashingElts - }}} - - where - - -- Is the given name imported via Prelude? - -- - -- Possible scenarios: - -- a) Prelude is imported implicitly, issue warnings. - -- b) Prelude is imported explicitly, but without mentioning the name in - -- question. Issue no warnings. - -- c) Prelude is imported hiding the name in question. Issue no warnings. - -- d) Qualified import of Prelude, no warnings. - importedViaPrelude :: Name - -> [ImportDecl GhcRn] - -> Bool - importedViaPrelude name = any importViaPrelude - where - isPrelude :: ImportDecl GhcRn -> Bool - isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME - - -- Implicit (Prelude) import? - isImplicit :: ImportDecl GhcRn -> Bool - isImplicit = ideclImplicit - - -- Unqualified import? - isUnqualified :: ImportDecl GhcRn -> Bool - isUnqualified = not . isImportDeclQualified . ideclQualified - - -- List of explicitly imported (or hidden) Names from a single import. - -- Nothing -> No explicit imports - -- Just (False, ) -> Explicit import list of - -- Just (True , ) -> Explicit hiding of - importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name]) - importListOf = fmap toImportList . ideclHiding - where - toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - - isExplicit :: ImportDecl GhcRn -> Bool - isExplicit x = case importListOf x of - Nothing -> False - Just (False, explicit) - -> nameOccName name `elem` map nameOccName explicit - Just (True, hidden) - -> nameOccName name `notElem` map nameOccName hidden - - -- Check whether the given name would be imported (unqualified) from - -- an import declaration. - importViaPrelude :: ImportDecl GhcRn -> Bool - importViaPrelude x = isPrelude x - && isUnqualified x - && (isImplicit x || isExplicit x) - - --- Notation: is* is for classes the type is an instance of, should* for those --- that it should also be an instance of based on the corresponding --- is*. -tcMissingParentClassWarn :: WarningFlag - -> Name -- ^ Instances of this ... - -> Name -- ^ should also be instances of this - -> TcM () -tcMissingParentClassWarn warnFlag isName shouldName - = do { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcMissingParentClassWarn" empty - ; isClass' <- tcLookupClass_maybe isName - ; shouldClass' <- tcLookupClass_maybe shouldName - ; case (isClass', shouldClass') of - (Just isClass, Just shouldClass) -> do - { localInstances <- tcGetInsts - ; let isInstance m = is_cls m == isClass - isInsts = filter isInstance localInstances - ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts) - ; forM_ isInsts (checkShouldInst isClass shouldClass) - } - (is',should') -> - traceTc "tcMissingParentClassWarn/notIsShould" - (hang (ppr isName <> text "/" <> ppr shouldName) 2 ( - (hsep [ quotes (text "Is"), text "lookup for" - , ppr isName - , text "resulted in", ppr is' ]) - $$ - (hsep [ quotes (text "Should"), text "lookup for" - , ppr shouldName - , text "resulted in", ppr should' ]))) - }} - where - -- Check whether the desired superclass exists in a given environment. - checkShouldInst :: Class -- ^ Class of existing instance - -> Class -- ^ Class there should be an instance of - -> ClsInst -- ^ Existing instance - -> TcM () - checkShouldInst isClass shouldClass isInst - = do { instEnv <- tcGetInstEnvs - ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv False instEnv shouldClass (is_tys isInst) - - ; traceTc "tcMissingParentClassWarn/checkShouldInst" - (hang (ppr isInst) 4 - (sep [ppr instanceMatches, ppr shouldInsts])) - - -- ": Warning: is an instance of but not - -- " e.g. "Foo is an instance of Monad but not Applicative" - ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (Just name:_) = - addWarnAt (Reason warnFlag) instLoc $ - hsep [ (quotes . ppr . nameOccName) name - , text "is an instance of" - , (ppr . nameOccName . className) isClass - , text "but not" - , (ppr . nameOccName . className) shouldClass ] - <> text "." - $$ - hsep [ text "This will become an error in" - , text "a future release." ] - warnMsg _ = pure () - ; when (null shouldInsts && null instanceMatches) $ - warnMsg (is_tcs isInst) - } - - tcLookupClass_maybe :: Name -> TcM (Maybe Class) - tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case - Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls - _else -> pure Nothing - - ---------------------------- -tcTyClsInstDecls :: [TyClGroup GhcRn] - -> [LDerivDecl GhcRn] - -> [(RecFlag, LHsBinds GhcRn)] - -> TcM (TcGblEnv, -- The full inst env - [InstInfo GhcRn], -- Source-code instance decls to - -- process; contains all dfuns for - -- this module - HsValBinds GhcRn) -- Supporting bindings for derived - -- instances - -tcTyClsInstDecls tycl_decls deriv_decls binds - = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ - tcAddPatSynPlaceholders (getPatSynBinds binds) $ - do { (tcg_env, inst_info, deriv_info) - <- tcTyAndClassDecls tycl_decls ; - ; setGblEnv tcg_env $ do { - -- With the @TyClDecl@s and @InstDecl@s checked we're ready to - -- process the deriving clauses, including data family deriving - -- clauses discovered in @tcTyAndClassDecls@. - -- - -- Careful to quit now in case there were instance errors, so that - -- the deriving errors don't pile up as well. - ; failIfErrsM - ; (tcg_env', inst_info', val_binds) - <- tcInstDeclsDeriv deriv_info deriv_decls - ; setGblEnv tcg_env' $ do { - failIfErrsM - ; pure (tcg_env', inst_info' ++ inst_info, val_binds) - }}} - -{- ********************************************************************* -* * - Checking for 'main' -* * -************************************************************************ --} - -checkMain :: Bool -- False => no 'module M(..) where' header at all - -> TcM TcGblEnv --- If we are in module Main, check that 'main' is defined. -checkMain explicit_mod_hdr - = do { dflags <- getDynFlags - ; tcg_env <- getGblEnv - ; check_main dflags tcg_env explicit_mod_hdr } - -check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv -check_main dflags tcg_env explicit_mod_hdr - | mod /= main_mod - = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> - return tcg_env - - | otherwise - = do { mb_main <- lookupGlobalOccRn_maybe main_fn - -- Check that 'main' is in scope - -- It might be imported from another module! - ; case mb_main of { - Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) - ; complain_no_main - ; return tcg_env } ; - Just main_name -> do - - { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) - ; let loc = srcLocSpan (getSrcLoc main_name) - ; ioTyCon <- tcLookupTyCon ioTyConName - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let io_ty = mkTyConApp ioTyCon [res_ty] - skol_info = SigSkol (FunSigCtxt main_name False) io_ty [] - ; (ev_binds, main_expr) - <- checkConstraints skol_info [] [] $ - addErrCtxt mainCtxt $ - tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name))) - (mkCheckExpType io_ty) - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedVanillaId root_main_name - (mkTyConApp ioTyCon [res_ty]) - ; co = mkWpTyApps [res_ty] - -- The ev_binds of the `main` function may contain deferred - -- type error when type of `main` is not `IO a`. The `ev_binds` - -- must be put inside `runMainIO` to ensure the deferred type - -- error can be emitted correctly. See #13838. - ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ - mkHsDictLet ev_binds main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name, - tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, - tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - }) - }}} - where - mod = tcg_mod tcg_env - main_mod = mainModIs dflags - main_fn = getMainFun dflags - interactive = ghcLink dflags == LinkInMemory - - complain_no_main = unless (interactive && not explicit_mod_hdr) - (addErrTc noMainMsg) -- #12906 - -- Without an explicit module header... - -- in interactive mode, don't worry about the absence of 'main'. - -- in other modes, add error message and go on with typechecking. - - mainCtxt = text "When checking the type of the" <+> pp_main_fn - noMainMsg = text "The" <+> pp_main_fn - <+> text "is not defined in module" <+> quotes (ppr main_mod) - pp_main_fn = ppMainFn main_fn - --- | Get the unqualified name of the function to use as the \"main\" for the main module. --- Either returns the default name or the one configured on the command line with -main-is -getMainFun :: DynFlags -> RdrName -getMainFun dflags = case mainFunIs dflags of - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) - Nothing -> main_RDR_Unqual - --- If we are in module Main, check that 'main' is exported. -checkMainExported :: TcGblEnv -> TcM () -checkMainExported tcg_env - = case tcg_main tcg_env of - Nothing -> return () -- not the main module - Just main_name -> - do { dflags <- getDynFlags - ; let main_mod = mainModIs dflags - ; checkTc (main_name `elem` - concatMap availNames (tcg_exports tcg_env)) $ - text "The" <+> ppMainFn (nameRdrName main_name) <+> - text "is not exported by module" <+> quotes (ppr main_mod) } - -ppMainFn :: RdrName -> SDoc -ppMainFn main_fn - | rdrNameOcc main_fn == mainOcc - = text "IO action" <+> quotes (ppr main_fn) - | otherwise - = text "main IO action" <+> quotes (ppr main_fn) - -mainOcc :: OccName -mainOcc = mkVarOccFS (fsLit "main") - -{- -Note [Root-main Id] -~~~~~~~~~~~~~~~~~~~ -The function that the RTS invokes is always :Main.main, which we call -root_main_id. (Because GHC allows the user to have a module not -called Main as the main module, we can't rely on the main function -being called "Main.main". That's why root_main_id has a fixed module -":Main".) - -This is unusual: it's a LocalId whose Name has a Module from another -module. Tiresomely, we must filter it out again in MkIface, les we -get two defns for 'main' in the interface file! - - -********************************************************* -* * - GHCi stuff -* * -********************************************************* --} - -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) --- Initialise the tcg_inst_env with instances from all home modules. --- This mimics the more selective call to hptInstances in tcRnImports -runTcInteractive hsc_env thing_inside - = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ - do { traceTc "setInteractiveContext" $ - vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) - , text "ic_rn_gbl_env (LocalDef)" <+> - vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) - , let local_gres = filter isLocalGRE gres - , not (null local_gres) ]) ] - - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - False mb_pkg) - - ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> - case i of -- force above: see #15111 - IIModule n -> getOrphans n Nothing - IIDecl i -> - let mb_pkg = sl_fs <$> ideclPkgQual i in - getOrphans (unLoc (ideclName i)) mb_pkg - - ; let imports = emptyImportAvails { - imp_orphs = orphs - } - - ; (gbl_env, lcl_env) <- getEnvs - ; let gbl_env' = gbl_env { - tcg_rdr_env = ic_rn_gbl_env icxt - , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) - home_insts - , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts - , tcg_field_env = mkNameEnv con_fields - -- setting tcg_field_env is necessary - -- to make RecordWildCards work (test: ghci049) - , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt - -- must calculate imp_orphs of the ImportAvails - -- so that instance visibility is done correctly - , tcg_imports = imports - } - - lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids - - ; setEnvs (gbl_env', lcl_env') thing_inside } - where - (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) - - icxt = hsc_IC hsc_env - (ic_insts, ic_finsts) = ic_instances icxt - (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) - - is_closed :: TyThing -> Either (Name, TcTyThing) TyThing - -- Put Ids with free type variables (always RuntimeUnks) - -- in the *local* type environment - -- See Note [Initialising the type environment for GHCi] - is_closed thing - | AnId id <- thing - , not (isTypeClosedLetBndr id) - = Left (idName id, ATcId { tct_id = id - , tct_info = NotLetBound }) - | otherwise - = Right thing - - type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) - -- Putting the dfuns in the type_env - -- is just to keep Core Lint happy - - con_fields = [ (dataConName c, dataConFieldLabels c) - | ATyCon t <- top_ty_things - , c <- tyConDataCons t ] - - -{- Note [Initialising the type environment for GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the Ids in ic_things, defined by the user in 'let' stmts, -have closed types. E.g. - ghci> let foo x y = x && not y - -However the GHCi debugger creates top-level bindings for Ids whose -types have free RuntimeUnk skolem variables, standing for unknown -types. If we don't register these free TyVars as global TyVars then -the typechecker will try to quantify over them and fall over in -skolemiseQuantifiedTyVar. so we must add any free TyVars to the -typechecker's global TyVar set. That is done by using -tcExtendLocalTypeEnv. - -We do this by splitting out the Ids with open types, using 'is_closed' -to do the partition. The top-level things go in the global TypeEnv; -the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the -local TypeEnv. - -Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope -things are already in the interactive context's GlobalRdrEnv. -Extending the local RdrEnv isn't terrible, but it means there is an -entry for the same Name in both global and local RdrEnvs, and that -lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). - -We don't bother with the tcl_th_bndrs environment either. --} - --- | The returned [Id] is the list of new Ids bound by this statement. It can --- be used to extend the InteractiveContext via extendInteractiveContext. --- --- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound --- values, coerced to (). -tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) -tcRnStmt hsc_env rdr_stmt - = runTcInteractive hsc_env $ do { - - -- The real work is done here - ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; - zonked_expr <- zonkTopLExpr tc_expr ; - zonked_ids <- zonkTopBndrs bound_ids ; - - failIfErrsM ; -- we can't do the next step if there are levity polymorphism errors - -- test case: ghci/scripts/T13202{,a} - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! - mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ; - - traceTc "tcs 1" empty ; - this_mod <- getModule ; - global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; - -- Note [Interactively-bound Ids in GHCi] in HscTypes - -{- --------------------------------------------- - At one stage I removed any shadowed bindings from the type_env; - they are inaccessible but might, I suppose, cause a space leak if we leave them there. - However, with Template Haskell they aren't necessarily inaccessible. Consider this - GHCi session - Prelude> let f n = n * 2 :: Int - Prelude> fName <- runQ [| f |] - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - 14 - Prelude> let f n = n * 3 :: Int - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - In the last line we use 'fName', which resolves to the *first* 'f' - in scope. If we delete it from the type env, GHCi crashes because - it doesn't expect that. - - Hence this code is commented out - --------------------------------------------------- -} - - traceOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; - - return (global_ids, zonked_expr, fix_env) - } - where - bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -{- --------------------------------------------------------------------------- - Typechecking Stmts in GHCi - -Here is the grand plan, implemented in tcUserStmt - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] - - expr (of non-IO type, - result not showable) ==> error --} - --- | A plan is an attempt to lift some code into the IO monad. -type PlanResult = ([Id], LHsExpr GhcTc) -type Plan = TcM PlanResult - --- | Try the plans in order. If one fails (by raising an exn), try the next. --- If one succeeds, take it. -runPlans :: [Plan] -> TcM PlanResult -runPlans [] = panic "runPlans" -runPlans [p] = p -runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p - --- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the --- GHCi 'environment'. --- --- By 'lift' and 'environment we mean that the code is changed to --- execute properly in an IO monad. See Note [Interactively-bound Ids --- in GHCi] in HscTypes for more details. We do this lifting by trying --- different ways ('plans') of lifting the code into the IO monad and --- type checking each plan until one succeeds. -tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) - --- An expression typed at the prompt is treated very specially -tcUserStmt (dL->L loc (BodyStmt _ expr _ _)) - = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) - -- Don't try to typecheck if the renamer fails! - ; ghciStep <- getGhciStepIO - ; uniq <- newUnique - ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr - (noLoc emptyLocalBinds)] - -- [it = expr] - the_bind = cL loc $ (mkTopFunBind FromSource - (cL loc fresh_it) matches) - { fun_ext = fvs } - -- Care here! In GHCi the expression might have - -- free variables, and they in turn may have free type variables - -- (if we are at a breakpoint, say). We must put those free vars - - -- [let it = expr] - let_stmt = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField - $ XValBindsLR - (NValBinds [(NonRecursive,unitBag the_bind)] []) - - -- [it <- e] - bind_stmt = cL loc $ BindStmt noExtField - (cL loc (VarPat noExtField (cL loc fresh_it))) - (nlHsApp ghciStep rn_expr) - (mkRnSyntaxExpr bindIOName) - noSyntaxExpr - - -- [; print it] - print_it = cL loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) - (nlHsVar fresh_it)) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- NewA - no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName - [rn_expr , nlHsVar interPrintName]) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_b = cL loc $ BodyStmt noExtField (rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_c = cL loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- See Note [GHCi Plans] - - it_plans = [ - -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy $ it_ty) failM - ; return stuff }, - - -- Plan B; a naked bind statement - tcGhciStmts [bind_stmt], - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } ] - - -- Plans where we don't bind "it" - no_it_plans = [ - tcGhciStmts [no_it_a] , - tcGhciStmts [no_it_b] , - tcGhciStmts [no_it_c] ] - - ; generate_it <- goptM Opt_NoIt - - -- We disable `-fdefer-type-errors` in GHCi for naked expressions. - -- See Note [Deferred type errors in GHCi] - - -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` - -- and `-fdefer-out-of-scope-variables`. However the flag - -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and - -- `-fno-defer-out-of-scope-variables`. Thus the later two flags - -- also need to be unset here. - ; plan <- unsetGOptM Opt_DeferTypeErrors $ - unsetGOptM Opt_DeferTypedHoles $ - unsetGOptM Opt_DeferOutOfScopeVariables $ - runPlans $ if generate_it - then no_it_plans - else it_plans - - ; fix_env <- getFixityEnv - ; return (plan, fix_env) } - -{- Note [Deferred type errors in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHCi, we ensure that type errors don't get deferred when type checking the -naked expressions. Deferring type errors here is unhelpful because the -expression gets evaluated right away anyway. It also would potentially emit -two redundant type-error warnings, one from each plan. - -#14963 reveals another bug that when deferred type errors is enabled -in GHCi, any reference of imported/loaded variables (directly or indirectly) -in interactively issued naked expressions will cause ghc panic. See more -detailed dicussion in #14963. - -The interactively issued declarations, statements, as well as the modules -loaded into GHCi, are not affected. That means, for declaration, you could -have - - Prelude> :set -fdefer-type-errors - Prelude> x :: IO (); x = putStrLn True - :14:26: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True - -But for naked expressions, you will have - - Prelude> :set -fdefer-type-errors - Prelude> putStrLn True - :2:10: error: - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘it’: it = putStrLn True - - Prelude> let x = putStrLn True - :2:18: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True --} - -tcUserStmt rdr_stmt@(dL->L loc _) - = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do - fix_env <- getFixityEnv - return (fix_env, emptyFVs) - -- Don't try to typecheck if the renamer fails! - ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) - ; rnDump rn_stmt ; - - ; ghciStep <- getGhciStepIO - ; let gi_stmt - | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt - = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 - | otherwise = rn_stmt - - ; opt_pr_flag <- goptM Opt_PrintBindResult - ; let print_result_plan - | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders gi_stmt -- One binder - = [mk_print_result_plan gi_stmt v] - | otherwise = [] - - -- The plans are: - -- [stmt; print v] if one binder and not v::() - -- [stmt] otherwise - ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) - ; return (plan, fix_env) } - where - mk_print_result_plan stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - where - print_v = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) - (nlHsVar v)) - (mkRnSyntaxExpr thenIOName) noSyntaxExpr - -{- -Note [GHCi Plans] -~~~~~~~~~~~~~~~~~ -When a user types an expression in the repl we try to print it in three different -ways. Also, depending on whether -fno-it is set, we bind a variable called `it` -which can be used to refer to the result of the expression subsequently in the repl. - -The normal plans are : - A. [it <- e; print e] but not if it::() - B. [it <- e] - C. [let it = e; print it] - -When -fno-it is set, the plans are: - A. [e >>= print] - B. [e] - C. [let it = e in print it] - -The reason for -fno-it is explained in #14336. `it` can lead to the repl -leaking memory as it is repeatedly queried. --} - --- | Typecheck the statements given and then return the results of the --- statement in the form 'IO [()]'. -tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult -tcGhciStmts stmts - = do { ioTyCon <- tcLookupTyCon ioTyConName ; - ret_id <- tcLookupId returnIOName ; -- return @ IO - let { - ret_ty = mkListTy unitTy ; - io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts - (mkCheckExpType io_ret_ty) ; - names = collectLStmtsBinders stmts ; - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureTopConstraints $ - tc_io_stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; - let { -- mk_return builds the expression - -- returnIO @ [()] [coerce () x, .., coerce () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy Nothing - (map mk_item ids)) ; - mk_item id = let ty_args = [idType id, unitTy] in - nlHsApp (nlHsTyApp unsafeCoerceId - (map getRuntimeRep ty_args ++ ty_args)) - (nlHsVar id) ; - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] - } ; - return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts))) - } - --- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) -getGhciStepIO :: TcM (LHsExpr GhcRn) -getGhciStepIO = do - ghciTy <- getGHCiMonad - a_tv <- newName (mkTyVarOccFS (fsLit "a")) - let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) - ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - - step_ty = noLoc $ HsForAllTy - { hst_fvf = ForallInvis - , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)] - , hst_xforall = noExtField - , hst_body = nlHsFunTy ghciM ioM } - - stepTy :: LHsSigWcType GhcRn - stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) - - return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) - -isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) -isGHCiMonad hsc_env ty - = runTcInteractive hsc_env $ do - rdrEnv <- getGlobalRdrEnv - let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) - case occIO of - Just [n] -> do - let name = gre_name n - ghciClass <- tcLookupClass ghciIoClassName - userTyCon <- tcLookupTyCon name - let userTy = mkTyConApp userTyCon [] - _ <- tcLookupInstance ghciClass [userTy] - return name - - Just _ -> failWithTc $ text "Ambiguous type!" - Nothing -> failWithTc $ text ("Can't find type:" ++ ty) - --- | How should we infer a type? See Note [TcRnExprMode] -data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type) - | TM_NoInst -- ^ Do not instantiate the type (:type +v) - | TM_Default -- ^ Default the type eagerly (:type +d) - --- | tcRnExpr just finds the type of an expression -tcRnExpr :: HscEnv - -> TcRnExprMode - -> LHsExpr GhcPs - -> IO (Messages, Maybe Type) -tcRnExpr hsc_env mode rdr_expr - = runTcInteractive hsc_env $ - do { - - (rn_expr, _fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; - - -- Now typecheck the expression, and generalise its type - -- it might have a rank-2 type (e.g. :t runST) - uniq <- newUnique ; - let { fresh_it = itName uniq (getLoc rdr_expr) - ; orig = lexprCtOrigin rn_expr } ; - ((tclvl, res_ty), lie) - <- captureTopConstraints $ - pushTcLevelM $ - do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr - ; if inst - then snd <$> deeplyInstantiate orig expr_ty - else return expr_ty } ; - - -- Generalise - (qtvs, dicts, _, residual, _) - <- simplifyInfer tclvl infer_mode - [] {- No sig vars -} - [(fresh_it, res_ty)] - lie ; - - -- Ignore the dictionary bindings - _ <- perhaps_disable_default_warnings $ - simplifyInteractive residual ; - - let { all_expr_ty = mkInvForAllTys qtvs $ - mkPhiTy (map idType dicts) res_ty } ; - ty <- zonkTcType all_expr_ty ; - - -- We normalise type families, so that the type of an expression is the - -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac - -- #10321 for further discussion. - fam_envs <- tcGetFamInstEnvs ; - -- normaliseType returns a coercion which we discard, so the Role is - -- irrelevant - return (snd (normaliseType fam_envs Nominal ty)) - } - where - -- See Note [TcRnExprMode] - (inst, infer_mode, perhaps_disable_default_warnings) = case mode of - TM_Inst -> (True, NoRestrictions, id) - TM_NoInst -> (False, NoRestrictions, id) - TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) - --------------------------- -tcRnImportDecls :: HscEnv - -> [LImportDecl GhcPs] - -> IO (Messages, Maybe GlobalRdrEnv) --- Find the new chunk of GlobalRdrEnv created by this list of import --- decls. In contract tcRnImports *extends* the TcGblEnv. -tcRnImportDecls hsc_env import_decls - = runTcInteractive hsc_env $ - do { gbl_env <- updGblEnv zap_rdr_env $ - tcRnImports hsc_env import_decls - ; return (tcg_rdr_env gbl_env) } - where - zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } - --- tcRnType just finds the kind of a type -tcRnType :: HscEnv - -> ZonkFlexi - -> Bool -- Normalise the returned type - -> LHsType GhcPs - -> IO (Messages, Maybe (Type, Kind)) -tcRnType hsc_env flexi normalise rdr_type - = runTcInteractive hsc_env $ - setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] - do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs) - <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type) - -- The type can have wild cards, but no implicit - -- generalisation; e.g. :kind (T _) - ; failIfErrsM - - -- We follow Note [Recipe for checking a signature] in TcHsType here - - -- Now kind-check the type - -- It can have any rank or kind - -- First bring into scope any wildcards - ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) - ; (ty, kind) <- pushTcLevelM_ $ - -- must push level to satisfy level precondition of - -- kindGeneralize, below - solveEqualities $ - tcNamedWildCardBinders wcs $ \ wcs' -> - do { emitNamedWildCardHoleConstraints wcs' - ; tcLHsTypeUnsaturated rn_type } - - -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralizeAll kind - ; e <- mkEmptyZonkEnv flexi - - ; ty <- zonkTcTypeToTypeX e ty - - -- Do validity checking on type - ; checkValidType (GhciCtxt True) ty - - ; ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs - ; let (_, ty') - = normaliseType fam_envs Nominal ty - ; return ty' } - else return ty ; - - ; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) } - -{- Note [TcRnExprMode] -~~~~~~~~~~~~~~~~~~~~~~ -How should we infer a type when a user asks for the type of an expression e -at the GHCi prompt? We offer 3 different possibilities, described below. Each -considers this example, with -fprint-explicit-foralls enabled: - - foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - :type{,-spec,-def} foo @Int - -:type / TM_Inst - - In this mode, we report the type that would be inferred if a variable - were assigned to expression e, without applying the monomorphism restriction. - This means we deeply instantiate the type and then regeneralize, as discussed - in #11376. - - > :type foo @Int - forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String - - Note that the variables and constraints are reordered here, because this - is possible during regeneralization. Also note that the variables are - reported as Inferred instead of Specified. - -:type +v / TM_NoInst - - This mode is for the benefit of users using TypeApplications. It does no - instantiation whatsoever, sometimes meaning that class constraints are not - solved. - - > :type +v foo @Int - forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String - - Note that Show Int is still reported, because the solver never got a chance - to see it. - -:type +d / TM_Default - - This mode is for the benefit of users who wish to see instantiations of - generalized types, and in particular to instantiate Foldable and Traversable. - In this mode, any type variable that can be defaulted is defaulted. Because - GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are - defaulted. - - > :type +d foo @Int - Int -> [Integer] -> String - - Note that this mode can sometimes lead to a type error, if a type variable is - used with a defaultable class but cannot actually be defaulted: - - bar :: (Num a, Monoid a) => a -> a - > :type +d bar - ** error ** - - The error arises because GHC tries to default a but cannot find a concrete - type in the defaulting list that is both Num and Monoid. (If this list is - modified to include an element that is both Num and Monoid, the defaulting - would succeed, of course.) - -Note [Kind-generalise in tcRnType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We switch on PolyKinds when kind-checking a user type, so that we will -kind-generalise the type, even when PolyKinds is not otherwise on. -This gives the right default behaviour at the GHCi prompt, where if -you say ":k T", and T has a polymorphic kind, you'd like to see that -polymorphism. Of course. If T isn't kind-polymorphic you won't get -anything unexpected, but the apparent *loss* of polymorphism, for -types that you know are polymorphic, is quite surprising. See Trac -#7688 for a discussion. - -Note that the goal is to generalise the *kind of the type*, not -the type itself! Example: - ghci> data SameKind :: k -> k -> Type - ghci> :k SameKind _ - -We want to get `k -> Type`, not `Any -> Type`, which is what we would -get without kind-generalisation. Note that `:k SameKind` is OK, as -GHC will not instantiate SameKind here, and so we see its full kind -of `forall k. k -> k -> Type`. - -************************************************************************ -* * - tcRnDeclsi -* * -************************************************************************ - -tcRnDeclsi exists to allow class, data, and other declarations in GHCi. --} - -tcRnDeclsi :: HscEnv - -> [LHsDecl GhcPs] - -> IO (Messages, Maybe TcGblEnv) -tcRnDeclsi hsc_env local_decls - = runTcInteractive hsc_env $ - tcRnSrcDecls False local_decls - -externaliseAndTidyId :: Module -> Id -> TcM Id -externaliseAndTidyId this_mod id - = do { name' <- externaliseName this_mod (idName id) - ; return $ globaliseId id - `setIdName` name' - `setIdType` tidyTopType (idType id) } - - -{- -************************************************************************ -* * - More GHCi stuff, to do with browsing and getting info -* * -************************************************************************ --} - --- | ASSUMES that the module is either in the 'HomePackageTable' or is --- a package module with an interface on disk. If neither of these is --- true, then the result will be an error indicating the interface --- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) -getModuleInterface hsc_env mod - = runTcInteractive hsc_env $ - loadModuleInterface (text "getModuleInterface") mod - -tcRnLookupRdrName :: HscEnv -> Located RdrName - -> IO (Messages, Maybe [Name]) --- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (dL->L loc rdr_name) - = runTcInteractive hsc_env $ - setSrcSpan loc $ - do { -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let rdr_names = dataTcOccs rdr_name - ; names_s <- mapM lookupInfoOccRn rdr_names - ; let names = concat names_s - ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) - ; return names } - -tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) -tcRnLookupName hsc_env name - = runTcInteractive hsc_env $ - tcRnLookupName' name - --- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. --- But we also want a TyThing, so we have to convert: - -tcRnLookupName' :: Name -> TcRn TyThing -tcRnLookupName' name = do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - -tcRnGetInfo :: HscEnv - -> Name - -> IO ( Messages - , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) - --- Used to implement :info in GHCi --- --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnGetInfo hsc_env name - = runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) - - ; thing <- tcRnLookupName' name - ; fixity <- lookupFixityRn name - ; (cls_insts, fam_insts) <- lookupInsts thing - ; let info = lookupKnownNameInfo name - ; return (thing, fixity, cls_insts, fam_insts, info) } - - --- Lookup all class and family instances for a type constructor. --- --- This function filters all instances in the type environment, so there --- is a lot of duplicated work if it is called many times in the same --- type environment. If this becomes a problem, the NameEnv computed --- in GHC.getNameToInstancesIndex could be cached in TcM and both functions --- could be changed to consult that index. -lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) -lookupInsts (ATyCon tc) - = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - - -- Return only the instances relevant to the given thing, i.e. - -- the instances whose head contains the thing's name. - ; let cls_insts = - [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , instIsVisible vis_mods ispec - , tc_name `elemNameSet` orphNamesOfClsInst ispec ] - ; let fam_insts = - [ fispec - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , tc_name `elemNameSet` orphNamesOfFamInst fispec ] - ; return (cls_insts, fam_insts) } - where - tc_name = tyConName tc - -lookupInsts _ = return ([],[]) - -loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () --- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for --- something -loadUnqualIfaces hsc_env ictxt - = initIfaceTcRn $ do - mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) - where - this_pkg = thisPackage (hsc_dflags hsc_env) - - unqual_mods = [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) - , let name = gre_name gre - , nameIsFromExternalPackage this_pkg name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - doc = text "Need interface for module whose export(s) are in scope unqualified" - - - -{- -************************************************************************ -* * - Debugging output - This is what happens when you do -ddump-types -* * -************************************************************************ --} - -rnDump :: (Outputable a, Data a) => a -> TcRn () --- Dump, with a banner, if -ddump-rn -rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) } - -tcDump :: TcGblEnv -> TcRn () -tcDump env - = do { dflags <- getDynFlags ; - - -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (traceTcRnForUser Opt_D_dump_types short_dump) ; - - -- Dump bindings if -ddump-tc - traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump); - - -- Dump bindings as an hsSyn AST if -ddump-tc-ast - traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump) - } - where - short_dump = pprTcGblEnv env - full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords - ast_dump = showAstData NoBlankSrcSpan (tcg_binds env) - --- It's unpleasant having both pprModGuts and pprModDetails here -pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) - = getPprDebug $ \debug -> - vcat [ ppr_types debug type_env - , ppr_tycons debug fam_insts type_env - , ppr_datacons debug type_env - , ppr_patsyns type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , ppr_rules rules - , text "Dependent modules:" <+> - pprUFM (imp_dep_mods imports) (ppr . sort) - , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_pkgs imports)] - where -- The use of sort is just to reduce unnecessary - -- wobbling in testsuite output - -ppr_rules :: [LRuleDecl GhcTc] -> SDoc -ppr_rules rules - = ppUnless (null rules) $ - hang (text "RULES") - 2 (vcat (map ppr rules)) - -ppr_types :: Bool -> TypeEnv -> SDoc -ppr_types debug type_env - = ppr_things "TYPE SIGNATURES" ppr_sig - (sortBy (comparing getOccName) ids) - where - ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id - | debug = True - | otherwise = hasTopUserName id - && case idDetails id of - VanillaId -> True - RecSelId {} -> True - ClassOpId {} -> True - FCallId {} -> True - _ -> False - -- Data cons (workers and wrappers), pattern synonyms, - -- etc are suppressed (unless -dppr-debug), - -- because they appear elsehwere - - ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id))) - -ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc -ppr_tycons debug fam_insts type_env - = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons - , ppr_things "COERCION AXIOMS" ppr_ax - (typeEnvCoAxioms type_env) ] - where - fi_tycons = famInstsRepTyCons fam_insts - - tycons = sortBy (comparing getOccName) $ - [tycon | tycon <- typeEnvTyCons type_env - , want_tycon tycon] - -- Sort by OccName to reduce unnecessary changes - want_tycon tycon | debug = True - | otherwise = isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) - ppr_tc tc - = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc - <> braces (ppr (tyConArity tc)) <+> dcolon) - 2 (ppr (tidyTopType (tyConKind tc))) - , nest 2 $ - ppWhen show_roles $ - text "roles" <+> (sep (map ppr roles)) ] - where - show_roles = debug || not (all (== boring_role) roles) - roles = tyConRoles tc - boring_role | isClassTyCon tc = Nominal - | otherwise = Representational - -- Matches the choice in IfaceSyn, calls to pprRoles - - ppr_ax ax = ppr (coAxiomToIfaceDecl ax) - -- We go via IfaceDecl rather than using pprCoAxiom - -- This way we get the full axiom (both LHS and RHS) with - -- wildcard binders tidied to _1, _2, etc. - -ppr_datacons :: Bool -> TypeEnv -> SDoc -ppr_datacons debug type_env - = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs - -- The filter gets rid of class data constructors - where - ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc) - all_dcs = typeEnvDataCons type_env - wanted_dcs | debug = all_dcs - | otherwise = filterOut is_cls_dc all_dcs - is_cls_dc dc = isClassTyCon (dataConTyCon dc) - -ppr_patsyns :: TypeEnv -> SDoc -ppr_patsyns type_env - = ppr_things "PATTERN SYNONYMS" ppr_ps - (typeEnvPatSyns type_env) - where - ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps - -ppr_insts :: [ClsInst] -> SDoc -ppr_insts ispecs - = ppr_things "CLASS INSTANCES" pprInstance ispecs - -ppr_fam_insts :: [FamInst] -> SDoc -ppr_fam_insts fam_insts - = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts - -ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc -ppr_things herald ppr_one things - | null things = empty - | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) - -hasTopUserName :: NamedThing x => x -> Bool --- A top-level thing whose name is not "derived" --- Thus excluding things like $tcX, from Typeable boilerplate --- and C:Coll from class-dictionary data constructors -hasTopUserName x - = isExternalName name && not (isDerivedOccName (nameOccName name)) - where - name = getName x - -{- -******************************************************************************** - -Type Checker Plugins - -******************************************************************************** --} - -withTcPlugins :: HscEnv -> TcM a -> TcM a -withTcPlugins hsc_env m = - do let plugins = getTcPlugins (hsc_dflags hsc_env) - case plugins of - [] -> m -- Common fast case - _ -> do ev_binds_var <- newTcEvBinds - (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins - -- This ensures that tcPluginStop is called even if a type - -- error occurs during compilation (Fix of #10078) - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m - mapM_ (flip runTcPluginM ev_binds_var) stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - startPlugin ev_binds_var (TcPlugin start solve stop) = - do s <- runTcPluginM start ev_binds_var - return (solve s, stop s) - -getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin] -getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) - - -withHoleFitPlugins :: HscEnv -> TcM a -> TcM a -withHoleFitPlugins hsc_env m = - case (getHfPlugins (hsc_dflags hsc_env)) of - [] -> m -- Common fast case - plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins - -- This ensures that hfPluginStop is called even if a type - -- error occurs during compilation. - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m - sequence_ stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - startPlugin (HoleFitPluginR init plugin stop) = - do ref <- init - return (plugin ref, stop ref) - -getHfPlugins :: DynFlags -> [HoleFitPluginR] -getHfPlugins dflags = - catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args) - - -runRenamerPlugin :: TcGblEnv - -> HsGroup GhcRn - -> TcM (TcGblEnv, HsGroup GhcRn) -runRenamerPlugin gbl_env hs_group = do - dflags <- getDynFlags - withPlugins dflags - (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g)) - (gbl_env, hs_group) - - --- XXX: should this really be a Maybe X? Check under which circumstances this --- can become a Nothing and decide whether this should instead throw an --- exception/signal an error. -type RenamedStuff = - (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString)) - --- | Extract the renamed information from TcGblEnv. -getRenamedStuff :: TcGblEnv -> RenamedStuff -getRenamedStuff tc_result - = fmap (\decls -> ( decls, tcg_rn_imports tc_result - , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) ) - (tcg_rn_decls tc_result) - -runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv -runTypecheckerPlugin sum hsc_env gbl_env = do - let dflags = hsc_dflags hsc_env - withPlugins dflags - (\p opts env -> mark_plugin_unsafe dflags - >> typeCheckResultAction p opts sum env) - gbl_env - -mark_plugin_unsafe :: DynFlags -> TcM () -mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ - recordUnsafeInfer pluginUnsafe - where - unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan - (Outputable.text unsafeText) ) diff --git a/typecheck/TcRnDriver.hs-boot b/typecheck/TcRnDriver.hs-boot deleted file mode 100644 --- a/typecheck/TcRnDriver.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ -module TcRnDriver where - -import GhcPrelude -import DynFlags (DynFlags) -import Type (TyThing) -import TcRnTypes (TcM) -import Outputable (SDoc) -import Name (Name) - -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> SDoc -badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc diff --git a/typecheck/TcRnExports.hs b/typecheck/TcRnExports.hs deleted file mode 100644 --- a/typecheck/TcRnExports.hs +++ /dev/null @@ -1,854 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcRnExports (tcRnExports, exports_from_avail) where - -import GhcPrelude - -import GHC.Hs -import PrelNames -import RdrName -import TcRnMonad -import TcEnv -import TcType -import RnNames -import RnEnv -import RnUnbound ( reportUnboundName ) -import ErrUtils -import Id -import IdInfo -import Module -import Name -import NameEnv -import NameSet -import Avail -import TyCon -import SrcLoc -import HscTypes -import Outputable -import ConLike -import DataCon -import PatSyn -import Maybes -import UniqSet -import Util (capitalise) -import FastString (fsLit) - -import Control.Monad -import DynFlags -import RnHsDoc ( rnHsDoc ) -import RdrHsSyn ( setRdrNameSpace ) -import Data.Either ( partitionEithers ) - -{- -************************************************************************ -* * -\subsection{Export list processing} -* * -************************************************************************ - -Processing the export list. - -You might think that we should record things that appear in the export -list as ``occurrences'' (using @addOccurrenceName@), but you'd be -wrong. We do check (here) that they are in scope, but there is no -need to slurp in their actual declaration (which is what -@addOccurrenceName@ forces). - -Indeed, doing so would big trouble when compiling @PrelBase@, because -it re-exports @GHC@, which includes @takeMVar#@, whose type includes -@ConcBase.StateAndSynchVar#@, and so on... - -Note [Exports of data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you see (#5306) - module M where - import X( F ) - data instance F Int = FInt -What does M export? AvailTC F [FInt] - or AvailTC F [F,FInt]? -The former is strictly right because F isn't defined in this module. -But then you can never do an explicit import of M, thus - import M( F( FInt ) ) -because F isn't exported by M. Nor can you import FInt alone from here - import M( FInt ) -because we don't have syntax to support that. (It looks like an import of -the type FInt.) - -At one point I implemented a compromise: - * When constructing exports with no export list, or with module M( - module M ), we add the parent to the exports as well. - * But not when you see module M( f ), even if f is a - class method with a parent. - * Nor when you see module M( module N ), with N /= M. - -But the compromise seemed too much of a hack, so we backed it out. -You just have to use an explicit export list: - module M( F(..) ) where ... - -Note [Avails of associated data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you have (#16077) - - {-# LANGUAGE TypeFamilies #-} - module A (module A) where - - class C a where { data T a } - instance C () where { data T () = D } - -Because @A@ is exported explicitly, GHC tries to produce an export list -from the @GlobalRdrEnv@. In this case, it pulls out the following: - - [ C defined at A.hs:4:1 - , T parent:C defined at A.hs:4:23 - , D parent:T defined at A.hs:5:35 ] - -If map these directly into avails, (via 'availFromGRE'), we get -@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@. -That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is -exported, but it isn't the first entry in the avail! - -We work around this issue by expanding GREs where the parent and child -are both type constructors into two GRES. - - T parent:C defined at A.hs:4:23 - - => - - [ T parent:C defined at A.hs:4:23 - , T defined at A.hs:4:23 ] - -Then, we get @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged -into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant). --} - -data ExportAccum -- The type of the accumulating parameter of - -- the main worker function in rnExports - = ExportAccum - ExportOccMap -- Tracks exported occurrence names - (UniqSet ModuleName) -- Tracks (re-)exported module names - -emptyExportAccum :: ExportAccum -emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet - -accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y))) - -> [x] - -> TcRn [y] -accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum - where f' acc x = do - m <- attemptM (f acc x) - pure $ case m of - Just (Just (acc', y)) -> (acc', Just y) - _ -> (acc, Nothing) - -type ExportOccMap = OccEnv (Name, IE GhcPs) - -- Tracks what a particular exported OccName - -- in an export list refers to, and which item - -- it came from. It's illegal to export two distinct things - -- that have the same occurrence name - -tcRnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list - -> TcGblEnv - -> RnM TcGblEnv - - -- Complains if two distinct exports have same OccName - -- Warns about identical exports. - -- Complains about exports items not in scope - -tcRnExports explicit_mod exports - tcg_env@TcGblEnv { tcg_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports, - tcg_src = hsc_src } - = unsetWOptM Opt_WarnWarningsDeprecations $ - -- Do not report deprecations arising from the export - -- list, to avoid bleating about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - do { - ; dflags <- getDynFlags - ; let is_main_mod = mainModIs dflags == this_mod - ; let default_main = case mainFunIs dflags of - Just main_fun - | is_main_mod -> mkUnqual varName (fsLit main_fun) - _ -> main_RDR_Unqual - ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832 - -- If a module has no explicit header, and it has one or more main - -- functions in scope, then add a header like - -- "module Main(main) where ..." #13839 - -- See Note [Modules without a module header] - ; let real_exports - | explicit_mod = exports - | has_main - = Just (noLoc [noLoc (IEVar noExtField - (noLoc (IEName $ noLoc default_main)))]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope - | otherwise = Nothing - - ; let do_it = exports_from_avail real_exports rdr_env imports this_mod - ; (rn_exports, final_avails) - <- if hsc_src == HsigFile - then do (mb_r, msgs) <- tryTc do_it - case mb_r of - Just r -> return r - Nothing -> addMessages msgs >> failM - else checkNoErrs do_it - ; let final_ns = availsToNameSetWithSelectors final_avails - - ; traceRn "rnExports: Exports:" (ppr final_avails) - - ; let new_tcg_env = - tcg_env { tcg_exports = final_avails, - tcg_rn_exports = case tcg_rn_exports tcg_env of - Nothing -> Nothing - Just _ -> rn_exports, - tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly final_ns } - ; failIfErrsM - ; return new_tcg_env } - -exports_from_avail :: Maybe (Located [LIE GhcPs]) - -- ^ 'Nothing' means no explicit export list - -> GlobalRdrEnv - -> ImportAvails - -- ^ Imported modules; this is used to test if a - -- @module Foo@ export is valid (it's not valid - -- if we didn't import @Foo@!) - -> Module - -> RnM (Maybe [(LIE GhcRn, Avails)], Avails) - -- (Nothing, _) <=> no explicit export list - -- if explicit export list is present it contains - -- each renamed export item together with its exported - -- names. - -exports_from_avail Nothing rdr_env _imports _this_mod - -- The same as (module M) where M is the current module name, - -- so that's how we handle it, except we also export the data family - -- when a data instance is exported. - = do { - ; warnMissingExportList <- woptM Opt_WarnMissingExportList - ; warnIfFlag Opt_WarnMissingExportList - warnMissingExportList - (missingModuleExportWarn $ moduleName _this_mod) - ; let avails = - map fix_faminst . gresToAvailInfo - . filter isLocalGRE . globalRdrEnvElts $ rdr_env - ; return (Nothing, avails) } - where - -- #11164: when we define a data instance - -- but not data family, re-export the family - -- Even though we don't check whether this is actually a data family - -- only data families can locally define subordinate things (`ns` here) - -- without locally defining (and instead importing) the parent (`n`) - fix_faminst (AvailTC n ns flds) = - let new_ns = - case ns of - [] -> [n] - (p:_) -> if p == n then ns else n:ns - in AvailTC n new_ns flds - - fix_faminst avail = avail - - -exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod - = do ie_avails <- accumExports do_litem rdr_items - let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families - return (Just ie_avails, final_exports) - where - do_litem :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) - - -- Maps a parent to its in-scope children - kids_env :: NameEnv [GlobalRdrElt] - kids_env = mkChildEnv (globalRdrEnvElts rdr_env) - - -- See Note [Avails of associated data families] - expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] - expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p }) - | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }] - expand_tyty_gre gre = [gre] - - imported_modules = [ imv_name imv - | xs <- moduleEnvElts $ imp_mods imports - , imv <- importedByUser xs ] - - exports_from_item :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - exports_from_item (ExportAccum occs earlier_mods) - (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod))) - | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { warnIfFlag Opt_WarnDuplicateExports True - (dupModuleExport mod) ; - return Nothing } - - | otherwise - = do { let { exportValid = (mod `elem` imported_modules) - || (moduleName this_mod == mod) - ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) - ; new_exports = [ availFromGRE gre' - | (gre, _) <- gre_prs - , gre' <- expand_tyty_gre gre ] - ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs - ; mods = addOneToUniqSet earlier_mods mod - } - - ; checkErr exportValid (moduleNotImported mod) - ; warnIfFlag Opt_WarnDodgyExports - (exportValid && null gre_prs) - (nullModuleExport mod) - - ; traceRn "efa" (ppr mod $$ ppr all_gres) - ; addUsedGREs all_gres - - ; occs' <- check_occs ie occs new_exports - -- This check_occs not only finds conflicts - -- between this item and others, but also - -- internally within this item. That is, if - -- 'M.x' is in scope in several ways, we'll have - -- several members of mod_avails with the same - -- OccName. - ; traceRn "export_mod" - (vcat [ ppr mod - , ppr new_exports ]) - - ; return (Just ( ExportAccum occs' mods - , ( cL loc (IEModuleContents noExtField lmod) - , new_exports))) } - - exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie) - | isDoc ie - = do new_ie <- lookup_doc_ie ie - return (Just (acc, (cL loc new_ie, []))) - - | otherwise - = do (new_ie, avail) <- lookup_ie ie - if isUnboundName (ieName new_ie) - then return Nothing -- Avoid error cascade - else do - - occs' <- check_occs ie occs [avail] - - return (Just ( ExportAccum occs' mods - , (cL loc new_ie, [avail]))) - - ------------- - lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (dL->L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (cL l (replaceWrappedName rdr name)), avail) - - lookup_ie (IEThingAbs _ (dL->L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (cL l (replaceWrappedName rdr name)) - , avail) - - lookup_ie ie@(IEThingAll _ n') - = do - (n, avail, flds) <- lookup_ie_all ie n' - let name = unLoc n - return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) - , AvailTC name (name:avail) flds) - - - lookup_ie ie@(IEThingWith _ l wc sub_rdrs _) - = do - (lname, subs, avails, flds) - <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs - (_, all_avail, all_flds) <- - case wc of - NoIEWildcard -> return (lname, [], []) - IEWildcard _ -> lookup_ie_all ie l - let name = unLoc lname - return (IEThingWith noExtField (replaceLWrappedName l name) wc subs - (flds ++ (map noLoc all_flds)), - AvailTC name (name : avails ++ all_avail) - (map unLoc flds ++ all_flds)) - - - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - - - lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] - -> RnM (Located Name, [LIEWrappedName Name], [Name], - [Located FieldLabel]) - lookup_ie_with (dL->L l rdr) sub_rdrs - = do name <- lookupGlobalOccRn $ ieWrappedName rdr - (non_flds, flds) <- lookupChildrenExport name sub_rdrs - if isUnboundName name - then return (cL l name, [], [name], []) - else return (cL l name, non_flds - , map (ieWrappedName . unLoc) non_flds - , flds) - - lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName - -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (dL->L l rdr) = - do name <- lookupGlobalOccRn $ ieWrappedName rdr - let gres = findChildren kids_env name - (non_flds, flds) = classifyGREs gres - addUsedKids (ieWrappedName rdr) gres - warnDodgyExports <- woptM Opt_WarnDodgyExports - when (null gres) $ - if isTyConName name - then when warnDodgyExports $ - addWarn (Reason Opt_WarnDodgyExports) - (dodgyExportWarn name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (exportItemErr ie) - return (cL l name, non_flds, flds) - - ------------- - lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) - lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc - return (IEGroup noExtField lev rn_doc) - lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc - return (IEDoc noExtField rn_doc) - lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExtField str) - lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier - - -- In an export item M.T(A,B,C), we want to treat the uses of - -- A,B,C as if they were M.A, M.B, M.C - -- Happily pickGREs does just the right thing - addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () - addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) - -classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionEithers . map classifyGRE - -classifyGRE :: GlobalRdrElt -> Either Name FieldLabel -classifyGRE gre = case gre_par gre of - FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) - FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) - _ -> Left n - where - n = gre_name gre - -isDoc :: IE GhcPs -> Bool -isDoc (IEDoc {}) = True -isDoc (IEDocNamed {}) = True -isDoc (IEGroup {}) = True -isDoc _ = False - --- Renaming and typechecking of exports happens after everything else has --- been typechecked. - -{- -Note [Modules without a module header] --------------------------------------------------- - -The Haskell 2010 report says in section 5.1: - ->> An abbreviated form of module, consisting only of the module body, is ->> permitted. If this is used, the header is assumed to be ->> ‘module Main(main) where’. - -For modules without a module header, this is implemented the -following way: - -If the module has a main function in scope: - Then create a module header and export the main function, - as if a module header like ‘module Main(main) where...’ would exist. - This has the effect to mark the main function and all top level - functions called directly or indirectly via main as 'used', - and later on, unused top-level functions can be reported correctly. - There is no distinction between GHC and GHCi. -If the module has several main functions in scope: - Then generate a header as above. The ambiguity is reported later in - module `TcRnDriver.hs` function `check_main`. -If the module has NO main function: - Then export all top-level functions. This marks all top level - functions as 'used'. - In GHCi this has the effect, that we don't get any 'non-used' warnings. - In GHC, however, the 'has-main-module' check in the module - compiler/typecheck/TcRnDriver (functions checkMain / check-main) fires, - and we get the error: - The IO action ‘main’ is not defined in module ‘Main’ --} - - --- Renaming exports lists is a minefield. Five different things can appear in --- children export lists ( T(A, B, C) ). --- 1. Record selectors --- 2. Type constructors --- 3. Data constructors --- 4. Pattern Synonyms --- 5. Pattern Synonym Selectors --- --- However, things get put into weird name spaces. --- 1. Some type constructors are parsed as variables (-.->) for example. --- 2. All data constructors are parsed as type constructors --- 3. When there is ambiguity, we default type constructors to data --- constructors and require the explicit `type` keyword for type --- constructors. --- --- This function first establishes the possible namespaces that an --- identifier might be in (`choosePossibleNameSpaces`). --- --- Then for each namespace in turn, tries to find the correct identifier --- there returning the first positive result or the first terminating --- error. --- - - - -lookupChildrenExport :: Name -> [LIEWrappedName RdrName] - -> RnM ([LIEWrappedName Name], [Located FieldLabel]) -lookupChildrenExport spec_parent rdr_items = - do - xs <- mapAndReportM doOne rdr_items - return $ partitionEithers xs - where - -- Pick out the possible namespaces in order of priority - -- This is a consequence of how the parser parses all - -- data constructors as type constructors. - choosePossibleNamespaces :: NameSpace -> [NameSpace] - choosePossibleNamespaces ns - | ns == varName = [varName, tcName] - | ns == tcName = [dataName, tcName] - | otherwise = [ns] - -- Process an individual child - doOne :: LIEWrappedName RdrName - -> RnM (Either (LIEWrappedName Name) (Located FieldLabel)) - doOne n = do - - let bareName = (ieWrappedName . unLoc) n - lkup v = lookupSubBndrOcc_helper False True - spec_parent (setRdrNameSpace bareName v) - - name <- combineChildLookupResult $ map lkup $ - choosePossibleNamespaces (rdrNameSpace bareName) - traceRn "lookupChildrenExport" (ppr name) - -- Default to data constructors for slightly better error - -- messages - let unboundName :: RdrName - unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName - - case name of - NameNotFound -> do { ub <- reportUnboundName unboundName - ; let l = getLoc n - ; return (Left (cL l (IEName (cL l ub))))} - FoundFL fls -> return $ Right (cL (getLoc n) fls) - FoundName par name -> do { checkPatSynParent spec_parent par name - ; return - $ Left (replaceLWrappedName n name) } - IncorrectParent p g td gs -> failWithDcErr p g td gs - - --- Note: [Typing Pattern Synonym Exports] --- It proved quite a challenge to precisely specify which pattern synonyms --- should be allowed to be bundled with which type constructors. --- In the end it was decided to be quite liberal in what we allow. Below is --- how Simon described the implementation. --- --- "Personally I think we should Keep It Simple. All this talk of --- satisfiability makes me shiver. I suggest this: allow T( P ) in all --- situations except where `P`'s type is ''visibly incompatible'' with --- `T`. --- --- What does "visibly incompatible" mean? `P` is visibly incompatible --- with --- `T` if --- * `P`'s type is of form `... -> S t1 t2` --- * `S` is a data/newtype constructor distinct from `T` --- --- Nothing harmful happens if we allow `P` to be exported with --- a type it can't possibly be useful for, but specifying a tighter --- relationship is very awkward as you have discovered." --- --- Note that this allows *any* pattern synonym to be bundled with any --- datatype type constructor. For example, the following pattern `P` can be --- bundled with any type. --- --- ``` --- pattern P :: (A ~ f) => f --- ``` --- --- So we provide basic type checking in order to help the user out, most --- pattern synonyms are defined with definite type constructors, but don't --- actually prevent a library author completely confusing their users if --- they want to. --- --- So, we check for exactly four things --- 1. The name arises from a pattern synonym definition. (Either a pattern --- synonym constructor or a pattern synonym selector) --- 2. The pattern synonym is only bundled with a datatype or newtype. --- 3. Check that the head of the result type constructor is an actual type --- constructor and not a type variable. (See above example) --- 4. Is so, check that this type constructor is the same as the parent --- type constructor. --- --- --- Note: [Types of TyCon] --- --- This check appears to be overlly complicated, Richard asked why it --- is not simply just `isAlgTyCon`. The answer for this is that --- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. --- (It is either a newtype or data depending on the number of methods) --- - --- | Given a resolved name in the children export list and a parent. Decide --- whether we are allowed to export the child with the parent. --- Invariant: gre_par == NoParent --- See note [Typing Pattern Synonym Exports] -checkPatSynParent :: Name -- ^ Alleged parent type constructor - -- User wrote T( P, Q ) - -> Parent -- The parent of P we discovered - -> Name -- ^ Either a - -- a) Pattern Synonym Constructor - -- b) A pattern synonym selector - -> TcM () -- Fails if wrong parent -checkPatSynParent _ (ParentIs {}) _ - = return () - -checkPatSynParent _ (FldParent {}) _ - = return () - -checkPatSynParent parent NoParent mpat_syn - | isUnboundName parent -- Avoid an error cascade - = return () - - | otherwise - = do { parent_ty_con <- tcLookupTyCon parent - ; mpat_syn_thing <- tcLookupGlobal mpat_syn - - -- 1. Check that the Id was actually from a thing associated with patsyns - ; case mpat_syn_thing of - AnId i | isId i - , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i - -> handle_pat_syn (selErr i) parent_ty_con p - - AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p - - _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] } - where - psErr = exportErrCtxt "pattern synonym" - selErr = exportErrCtxt "pattern synonym record selector" - - assocClassErr :: SDoc - assocClassErr = text "Pattern synonyms can be bundled only with datatypes." - - handle_pat_syn :: SDoc - -> TyCon -- ^ Parent TyCon - -> PatSyn -- ^ Corresponding bundled PatSyn - -- and pretty printed origin - -> TcM () - handle_pat_syn doc ty_con pat_syn - - -- 2. See note [Types of TyCon] - | not $ isTyConWithSrcDataCons ty_con - = addErrCtxt doc $ failWithTc assocClassErr - - -- 3. Is the head a type variable? - | Nothing <- mtycon - = return () - -- 4. Ok. Check they are actually the same type constructor. - - | Just p_ty_con <- mtycon, p_ty_con /= ty_con - = addErrCtxt doc $ failWithTc typeMismatchError - - -- 5. We passed! - | otherwise - = return () - - where - expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) - (_, _, _, _, _, res_ty) = patSynSig pat_syn - mtycon = fst <$> tcSplitTyConApp_maybe res_ty - typeMismatchError :: SDoc - typeMismatchError = - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr expected_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) - - -{-===========================================================================-} -check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] - -> RnM ExportOccMap -check_occs ie occs avails - -- 'names' and 'fls' are the entities specified by 'ie' - = foldlM check occs names_with_occs - where - -- Each Name specified by 'ie', paired with the OccName used to - -- refer to it in the GlobalRdrEnv - -- (see Note [Representing fields in AvailInfo] in Avail). - -- - -- We check for export clashes using the selector Name, but need - -- the field label OccName for presenting error messages. - names_with_occs = availsNamesWithOccs avails - - check occs (name, occ) - = case lookupOccEnv occs name_occ of - Nothing -> return (extendOccEnv occs name_occ (name, ie)) - - Just (name', ie') - | name == name' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIfFlag Opt_WarnDuplicateExports - (not (dupExport_ok name ie ie')) - (dupExportWarn occ ie ie') - ; return occs } - - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env occ name' name ie' ie) ; - return occs } - where - name_occ = nameOccName name - - -dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool --- The Name is exported by both IEs. Is that ok? --- "No" iff the name is mentioned explicitly in both IEs --- or one of the IEs mentions the name *alone* --- "Yes" otherwise --- --- Examples of "no": module M( f, f ) --- module M( fmap, Functor(..) ) --- module M( module Data.List, head ) --- --- Example of "yes" --- module M( module A, module B ) where --- import A( f ) --- import B( f ) --- --- Example of "yes" (#2436) --- module M( C(..), T(..) ) where --- class C a where { data T a } --- instance C Int where { data T Int = TInt } --- --- Example of "yes" (#2436) --- module Foo ( T ) where --- data family T a --- module Bar ( T(..), module Foo ) where --- import Foo --- data instance T Int = TInt - -dupExport_ok n ie1 ie2 - = not ( single ie1 || single ie2 - || (explicit_in ie1 && explicit_in ie2) ) - where - explicit_in (IEModuleContents {}) = False -- module M - explicit_in (IEThingAll _ r) - = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) - explicit_in _ = True - - single IEVar {} = True - single IEThingAbs {} = True - single _ = False - - -dupModuleExport :: ModuleName -> SDoc -dupModuleExport mod - = hsep [text "Duplicate", - quotes (text "Module" <+> ppr mod), - text "in export list"] - -moduleNotImported :: ModuleName -> SDoc -moduleNotImported mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is not imported"] - -nullModuleExport :: ModuleName -> SDoc -nullModuleExport mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "exports nothing"] - -missingModuleExportWarn :: ModuleName -> SDoc -missingModuleExportWarn mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is missing an export list"] - - -dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item - = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn) - -exportErrCtxt :: Outputable o => String -> o -> SDoc -exportErrCtxt herald exp = - text "In the" <+> text (herald ++ ":") <+> ppr exp - - -addExportErrCtxt :: (OutputableBndrId p) - => IE (GhcPass p) -> TcM a -> TcM a -addExportErrCtxt ie = addErrCtxt exportCtxt - where - exportCtxt = text "In the export:" <+> ppr ie - -exportItemErr :: IE GhcPs -> SDoc -exportItemErr export_item - = sep [ text "The export item" <+> quotes (ppr export_item), - text "attempts to export constructors or class methods that are not visible here" ] - - -dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc -dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] - -dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc -dcErrMsg ty_con what_is thing parents = - text "The type constructor" <+> quotes (ppr ty_con) - <+> text "is not the parent of the" <+> text what_is - <+> quotes thing <> char '.' - $$ text (capitalise what_is) - <> text "s can only be exported with their parent type constructor." - $$ (case parents of - [] -> empty - [_] -> text "Parent:" - _ -> text "Parents:") <+> fsep (punctuate comma parents) - -failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a -failWithDcErr parent thing thing_doc parents = do - ty_thing <- tcLookupGlobal thing - failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing) - thing_doc (map ppr parents) - where - tyThingCategory' :: TyThing -> String - tyThingCategory' (AnId i) - | isRecordSelector i = "record selector" - tyThingCategory' i = tyThingCategory i - - -exportClashErr :: GlobalRdrEnv -> OccName - -> Name -> Name - -> IE GhcPs -> IE GhcPs - -> MsgDoc -exportClashErr global_env occ name1 name2 ie1 ie2 - = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export ie1' name1' - , ppr_export ie2' name2' ] - where - ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name name)) - 2 (pprNameProvenance (get_gre name))) - - -- DuplicateRecordFields means that nameOccName might be a mangled - -- $sel-prefixed thing, in which case show the correct OccName alone - ppr_name name - | nameOccName name == occ = ppr name - | otherwise = ppr occ - - -- get_gre finds a GRE for the Name, so that we can show its provenance - get_gre name - = fromMaybe (pprPanic "exportClashErr" (ppr name)) - (lookupGRE_Name_OccName global_env name occ) - get_loc name = greSrcSpan (get_gre name) - (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 - then (name1, ie1, name2, ie2) - else (name2, ie2, name1, ie1) diff --git a/typecheck/TcRnMonad.hs b/typecheck/TcRnMonad.hs deleted file mode 100644 --- a/typecheck/TcRnMonad.hs +++ /dev/null @@ -1,2029 +0,0 @@ -{- -(c) The University of Glasgow 2006 - - -Functions for working with the typechecker environment (setters, getters...). --} - -{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE ViewPatterns #-} - - -module TcRnMonad( - -- * Initalisation - initTc, initTcWithGbl, initTcInteractive, initTcRnIf, - - -- * Simple accessors - discardResult, - getTopEnv, updTopEnv, getGblEnv, updGblEnv, - setGblEnv, getLclEnv, updLclEnv, setLclEnv, - getEnvs, setEnvs, - xoptM, doptM, goptM, woptM, - setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, - whenDOptM, whenGOptM, whenWOptM, - whenXOptM, unlessXOptM, - getGhcMode, - withDoDynamicToo, - getEpsVar, - getEps, - updateEps, updateEps_, - getHpt, getEpsAndHpt, - - -- * Arrow scopes - newArrowScope, escapeArrowScope, - - -- * Unique supply - newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, - newSysName, newSysLocalId, newSysLocalIds, - - -- * Accessing input/output - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- * Debugging - traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser, - traceTcRnWithStyle, - getPrintUnqualified, - printForUserTcRn, - traceIf, traceHiDiffs, traceOptIf, - debugTc, - - -- * Typechecker global environment - getIsGHCi, getGHCiMonad, getInteractivePrintName, - tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, - getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getRecFieldEnv, - getDeclaredDefaultTys, - addDependentFiles, - - -- * Error management - getSrcSpanM, setSrcSpan, addLocM, - wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, - getErrsVar, setErrsVar, - addErr, - failWith, failAt, - addErrAt, addErrs, - checkErr, - addMessages, - discardWarnings, - - -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, - reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, - attemptM, tryTc, - askNoErrs, discardErrs, tryTcDiscardingErrs, - checkNoErrs, whenNoErrs, - ifErrsM, failIfErrsM, - - -- * Context management for the type checker - getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, - addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, - - -- * Error message generation (type checker) - addErrTc, addErrsTc, - addErrTcM, mkErrTcM, mkErrTc, - failWithTc, failWithTcM, - checkTc, checkTcM, - failIfTc, failIfTcM, - warnIfFlag, warnIf, warnTc, warnTcM, - addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, - mkErrInfo, - - -- * Type constraints - newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, - addTcEvBind, addTopEvBinds, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - chooseUniqueOccTc, - getConstraintVar, setConstraintVar, - emitConstraints, emitStaticConstraints, emitSimple, emitSimples, - emitImplication, emitImplications, emitInsoluble, - discardConstraints, captureConstraints, tryCaptureConstraints, - pushLevelAndCaptureConstraints, - pushTcLevelM_, pushTcLevelM, pushTcLevelsM, - getTcLevel, setTcLevel, isTouchableTcM, - getLclTypeEnv, setLclTypeEnv, - traceTcConstraints, - emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint, - - -- * Template Haskell context - recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc, - getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage, - addModFinalizersWithLclEnv, - - -- * Safe Haskell context - recordUnsafeInfer, finalSafeMode, fixSafeInstances, - - -- * Stuff for the renamer's local env - getLocalRdrEnv, setLocalRdrEnv, - - -- * Stuff for interface decls - mkIfLclEnv, - initIfaceTcRn, - initIfaceCheck, - initIfaceLcl, - initIfaceLclWithSubst, - initIfaceLoad, - getIfModule, - failIfM, - forkM_maybe, - forkM, - setImplicitEnvM, - - withException, - - -- * Stuff for cost centres. - ContainsCostCentreState(..), getCCIndexM, - - -- * Types etc. - module TcRnTypes, - module IOEnv - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -- Re-export all -import IOEnv -- Re-export all -import Constraint -import TcEvidence -import TcOrigin - -import GHC.Hs hiding (LIE) -import HscTypes -import Module -import RdrName -import Name -import Type - -import TcType -import InstEnv -import FamInstEnv -import PrelNames - -import Id -import VarSet -import VarEnv -import ErrUtils -import SrcLoc -import NameEnv -import NameSet -import Bag -import Outputable -import UniqSupply -import DynFlags -import FastString -import Panic -import Util -import Annotations -import BasicTypes( TopLevelFlag, TypeOrKind(..) ) -import Maybes -import CostCentreState - -import qualified GHC.LanguageExtensions as LangExt - -import Data.IORef -import Control.Monad -import Data.Set ( Set ) -import qualified Data.Set as Set - -import {-# SOURCE #-} TcEnv ( tcInitTidyEnv ) - -import qualified Data.Map as Map - -{- -************************************************************************ -* * - initTc -* * -************************************************************************ --} - --- | Setup the initial typechecking environment -initTc :: HscEnv - -> HscSource - -> Bool -- True <=> retain renamed syntax trees - -> Module - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) - -- Nothing => error thrown by the thing inside - -- (error messages should have been printed already) - -initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - = do { keep_var <- newIORef emptyNameSet ; - used_gre_var <- newIORef [] ; - th_var <- newIORef False ; - th_splice_var<- newIORef False ; - th_locs_var <- newIORef Set.empty ; - infer_var <- newIORef (True, emptyBag) ; - dfun_n_var <- newIORef emptyOccSet ; - type_env_var <- case hsc_type_env_var hsc_env of { - Just (_mod, te_var) -> return te_var ; - Nothing -> newIORef emptyNameEnv } ; - - dependent_files_var <- newIORef [] ; - static_wc_var <- newIORef emptyWC ; - cc_st_var <- newIORef newCostCentreState ; - th_topdecls_var <- newIORef [] ; - th_foreign_files_var <- newIORef [] ; - th_topnames_var <- newIORef emptyNameSet ; - th_modfinalizers_var <- newIORef [] ; - th_coreplugins_var <- newIORef [] ; - th_state_var <- newIORef Map.empty ; - th_remote_state_var <- newIORef Nothing ; - let { - dflags = hsc_dflags hsc_env ; - - maybe_rn_syntax :: forall a. a -> Maybe a ; - maybe_rn_syntax empty_val - | dopt Opt_D_dump_rn_ast dflags = Just empty_val - - | gopt Opt_WriteHie dflags = Just empty_val - - -- We want to serialize the documentation in the .hi-files, - -- and need to extract it from the renamed syntax first. - -- See 'ExtractDocs.extractDocs'. - | gopt Opt_Haddock dflags = Just empty_val - - | keep_rn_syntax = Just empty_val - | otherwise = Nothing ; - - gbl_env = TcGblEnv { - tcg_th_topdecls = th_topdecls_var, - tcg_th_foreign_files = th_foreign_files_var, - tcg_th_topnames = th_topnames_var, - tcg_th_modfinalizers = th_modfinalizers_var, - tcg_th_coreplugins = th_coreplugins_var, - tcg_th_state = th_state_var, - tcg_th_remote_state = th_remote_state_var, - - tcg_mod = mod, - tcg_semantic_mod = - canonicalizeModuleIfHome dflags mod, - tcg_src = hsc_src, - tcg_rdr_env = emptyGlobalRdrEnv, - tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, - tcg_default = if moduleUnitId mod == primUnitId - then Just [] -- See Note [Default types] - else Nothing, - tcg_type_env = emptyNameEnv, - tcg_type_env_var = type_env_var, - tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_ann_env = emptyAnnEnv, - tcg_th_used = th_var, - tcg_th_splice_used = th_splice_var, - tcg_th_top_level_locs - = th_locs_var, - tcg_exports = [], - tcg_imports = emptyImportAvails, - tcg_used_gres = used_gre_var, - tcg_dus = emptyDUs, - - tcg_rn_imports = [], - tcg_rn_exports = - if hsc_src == HsigFile - -- Always retain renamed syntax, so that we can give - -- better errors. (TODO: how?) - then Just [] - else maybe_rn_syntax [], - tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_tr_module = Nothing, - tcg_binds = emptyLHsBinds, - tcg_imp_specs = [], - tcg_sigs = emptyNameSet, - tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, - tcg_anns = [], - tcg_tcs = [], - tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_patsyns = [], - tcg_merged = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, - tcg_doc_hdr = Nothing, - tcg_hpc = False, - tcg_main = Nothing, - tcg_self_boot = NoSelfBoot, - tcg_safeInfer = infer_var, - tcg_dependent_files = dependent_files_var, - tcg_tc_plugins = [], - tcg_hf_plugins = [], - tcg_top_loc = loc, - tcg_static_wc = static_wc_var, - tcg_complete_matches = [], - tcg_cc_st = cc_st_var - } ; - } ; - - -- OK, here's the business end! - initTcWithGbl hsc_env gbl_env loc do_this - } - --- | Run a 'TcM' action in the context of an existing 'GblEnv'. -initTcWithGbl :: HscEnv - -> TcGblEnv - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) -initTcWithGbl hsc_env gbl_env loc do_this - = do { lie_var <- newIORef emptyWC - ; errs_var <- newIORef (emptyBag, emptyBag) - ; let lcl_env = TcLclEnv { - tcl_errs = errs_var, - tcl_loc = loc, -- Should be over-ridden very soon! - tcl_ctxt = [], - tcl_rdr = emptyLocalRdrEnv, - tcl_th_ctxt = topStage, - tcl_th_bndrs = emptyNameEnv, - tcl_arrow_ctxt = NoArrowCtxt, - tcl_env = emptyNameEnv, - tcl_bndrs = [], - tcl_lie = lie_var, - tcl_tclvl = topTcLevel - } - - ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - do { r <- tryM do_this - ; case r of - Right res -> return (Just res) - Left _ -> return Nothing } - - -- Check for unsolved constraints - -- If we succeed (maybe_res = Just r), there should be - -- no unsolved constraints. But if we exit via an - -- exception (maybe_res = Nothing), we may have skipped - -- solving, so don't panic then (#13466) - ; lie <- readIORef (tcl_lie lcl_env) - ; when (isJust maybe_res && not (isEmptyWC lie)) $ - pprPanic "initTc: unsolved constraints" (ppr lie) - - -- Collect any error messages - ; msgs <- readIORef (tcl_errs lcl_env) - - ; let { final_res | errorsFound dflags msgs = Nothing - | otherwise = maybe_res } - - ; return (msgs, final_res) - } - where dflags = hsc_dflags hsc_env - -initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) --- Initialise the type checker monad for use in GHCi -initTcInteractive hsc_env thing_inside - = initTc hsc_env HsSrcFile False - (icInteractiveModule (hsc_IC hsc_env)) - (realSrcLocSpan interactive_src_loc) - thing_inside - where - interactive_src_loc = mkRealSrcLoc (fsLit "") 1 1 - -{- Note [Default types] -~~~~~~~~~~~~~~~~~~~~~~~ -The Integer type is simply not available in package ghc-prim (it is -declared in integer-gmp). So we set the defaulting types to (Just -[]), meaning there are no default types, rather then Nothing, which -means "use the default default types of Integer, Double". - -If you don't do this, attempted defaulting in package ghc-prim causes -an actual crash (attempting to look up the Integer type). - - -************************************************************************ -* * - Initialisation -* * -************************************************************************ --} - -initTcRnIf :: Char -- ^ Mask for unique supply - -> HscEnv - -> gbl -> lcl - -> TcRnIf gbl lcl a - -> IO a -initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside - = do { let { env = Env { env_top = hsc_env, - env_um = uniq_mask, - env_gbl = gbl_env, - env_lcl = lcl_env} } - - ; runIOEnv env thing_inside - } - -{- -************************************************************************ -* * - Simple accessors -* * -************************************************************************ --} - -discardResult :: TcM a -> TcM () -discardResult a = a >> return () - -getTopEnv :: TcRnIf gbl lcl HscEnv -getTopEnv = do { env <- getEnv; return (env_top env) } - -updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = upd top }) - -getGblEnv :: TcRnIf gbl lcl gbl -getGblEnv = do { Env{..} <- getEnv; return env_gbl } - -updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> - env { env_gbl = upd gbl }) - -setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) - -getLclEnv :: TcRnIf gbl lcl lcl -getLclEnv = do { Env{..} <- getEnv; return env_lcl } - -updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> - env { env_lcl = upd lcl }) - -setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a -setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) - -getEnvs :: TcRnIf gbl lcl (gbl, lcl) -getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } - -setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a -setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) - --- Command-line flags - -xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } - -doptM :: DumpFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } - -goptM :: GeneralFlag -> TcRnIf gbl lcl Bool -goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } - -woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } - -setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) - -unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) - -unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetGOptM flag = - updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) - -unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetWOptM flag = - updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) - --- | Do it flag is true -whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenDOptM flag thing_inside = do b <- doptM flag - when b thing_inside - -whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenGOptM flag thing_inside = do b <- goptM flag - when b thing_inside - -whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenWOptM flag thing_inside = do b <- woptM flag - when b thing_inside - -whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenXOptM flag thing_inside = do b <- xoptM flag - when b thing_inside - -unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -unlessXOptM flag thing_inside = do b <- xoptM flag - unless b thing_inside - -getGhcMode :: TcRnIf gbl lcl GhcMode -getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } - -withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a -withDoDynamicToo = - updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> - top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags }) - -getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) -getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } - -getEps :: TcRnIf gbl lcl ExternalPackageState -getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } - --- | Update the external package state. Returns the second result of the --- modifier function. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) - -> TcRnIf gbl lcl a -updateEps upd_fn = do - traceIf (text "updating EPS") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var upd_fn - --- | Update the external package state. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps_ :: (ExternalPackageState -> ExternalPackageState) - -> TcRnIf gbl lcl () -updateEps_ upd_fn = do - traceIf (text "updating EPS_") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) - -getHpt :: TcRnIf gbl lcl HomePackageTable -getHpt = do { env <- getTopEnv; return (hsc_HPT env) } - -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) -getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) - ; return (eps, hsc_HPT env) } - --- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing --- an exception if it is an error. -withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a -withException do_this = do - r <- do_this - dflags <- getDynFlags - case r of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Succeeded result -> return result - -{- -************************************************************************ -* * - Arrow scopes -* * -************************************************************************ --} - -newArrowScope :: TcM a -> TcM a -newArrowScope - = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } - --- Return to the stored environment (from the enclosing proc) -escapeArrowScope :: TcM a -> TcM a -escapeArrowScope - = updLclEnv $ \ env -> - case tcl_arrow_ctxt env of - NoArrowCtxt -> env - ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt - , tcl_lie = lie - , tcl_rdr = rdr_env } - -{- -************************************************************************ -* * - Unique supply -* * -************************************************************************ --} - -newUnique :: TcRnIf gbl lcl Unique -newUnique - = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! uniqFromMask mask } - -newUniqueSupply :: TcRnIf gbl lcl UniqSupply -newUniqueSupply - = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! mkSplitUniqSupply mask } - -cloneLocalName :: Name -> TcM Name --- Make a fresh Internal name with the same OccName and SrcSpan -cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) - -newName :: OccName -> TcM Name -newName occ = do { loc <- getSrcSpanM - ; newNameAt occ loc } - -newNameAt :: OccName -> SrcSpan -> TcM Name -newNameAt occ span - = do { uniq <- newUnique - ; return (mkInternalName uniq occ span) } - -newSysName :: OccName -> TcRnIf gbl lcl Name -newSysName occ - = do { uniq <- newUnique - ; return (mkSystemName uniq occ) } - -newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId -newSysLocalId fs ty - = do { u <- newUnique - ; return (mkSysLocalOrCoVar fs u ty) } - -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] -newSysLocalIds fs tys - = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) } - -instance MonadUnique (IOEnv (Env gbl lcl)) where - getUniqueM = newUnique - getUniqueSupplyM = newUniqueSupply - -{- -************************************************************************ -* * - Accessing input/output -* * -************************************************************************ --} - -newTcRef :: a -> TcRnIf gbl lcl (TcRef a) -newTcRef = newMutVar - -readTcRef :: TcRef a -> TcRnIf gbl lcl a -readTcRef = readMutVar - -writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () -writeTcRef = writeMutVar - -updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () --- Returns () -updTcRef ref fn = liftIO $ do { old <- readIORef ref - ; writeIORef ref (fn old) } - -{- -************************************************************************ -* * - Debugging -* * -************************************************************************ --} - - --- Typechecker trace -traceTc :: String -> SDoc -> TcRn () -traceTc = - labelledTraceOptTcRn Opt_D_dump_tc_trace - --- Renamer Trace -traceRn :: String -> SDoc -> TcRn () -traceRn = - labelledTraceOptTcRn Opt_D_dump_rn_trace - --- | Trace when a certain flag is enabled. This is like `traceOptTcRn` --- but accepts a string as a label and formats the trace message uniformly. -labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () -labelledTraceOptTcRn flag herald doc = do - traceOptTcRn flag (formatTraceMsg herald doc) - -formatTraceMsg :: String -> SDoc -> SDoc -formatTraceMsg herald doc = hang (text herald) 2 doc - --- | Output a doc if the given 'DumpFlag' is set. --- --- By default this logs to stdout --- However, if the `-ddump-to-file` flag is set, --- then this will dump output to a file --- --- Just a wrapper for 'dumpSDoc' -traceOptTcRn :: DumpFlag -> SDoc -> TcRn () -traceOptTcRn flag doc - = do { dflags <- getDynFlags - ; when (dopt flag dflags) - (traceTcRn flag doc) - } - --- Certain tests (T3017, Roles3, T12763 etc.) expect part of the --- output generated by `-ddump-types` to be in 'PprUser' style. However, --- generally we want all other debugging output to use 'PprDump' --- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this. - --- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style. -traceTcRn :: DumpFlag -> SDoc -> TcRn () -traceTcRn flag doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; let dump_style = mkDumpStyle dflags printer - ; traceTcRnWithStyle dump_style dflags flag doc } - --- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style. -traceTcRnForUser :: DumpFlag -> SDoc -> TcRn () --- Used by 'TcRnDriver.tcDump'. -traceTcRnForUser flag doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; let user_style = mkUserStyle dflags printer AllTheWay - ; traceTcRnWithStyle user_style dflags flag doc } - -traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn () --- ^ Unconditionally dump some trace output --- --- The DumpFlag is used only to set the output filename --- for --dump-to-file, not to decide whether or not to output --- That part is done by the caller -traceTcRnWithStyle sty dflags flag doc - = do { real_doc <- prettyDoc dflags doc - ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc } - where - -- Add current location if -dppr-debug - prettyDoc :: DynFlags -> SDoc -> TcRn SDoc - prettyDoc dflags doc = if hasPprDebug dflags - then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc } - else return doc -- The full location is usually way too much - - -getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified -getPrintUnqualified dflags - = do { rdr_env <- getGlobalRdrEnv - ; return $ mkPrintUnqualified dflags rdr_env } - --- | Like logInfoTcRn, but for user consumption -printForUserTcRn :: SDoc -> TcRn () -printForUserTcRn doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; liftIO (printOutputForUser dflags printer doc) } - -{- -traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is -available. Alas, they behave inconsistently with the other stuff; -e.g. are unaffected by -dump-to-file. --} - -traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () -traceIf = traceOptIf Opt_D_dump_if_trace -traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs - - -traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -traceOptIf flag doc - = whenDOptM flag $ -- No RdrEnv available, so qualify everything - do { dflags <- getDynFlags - ; liftIO (putMsg dflags doc) } - -{- -************************************************************************ -* * - Typechecker global environment -* * -************************************************************************ --} - -getIsGHCi :: TcRn Bool -getIsGHCi = do { mod <- getModule - ; return (isInteractiveModule mod) } - -getGHCiMonad :: TcRn Name -getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } - -getInteractivePrintName :: TcRn Name -getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } - -tcIsHsBootOrSig :: TcRn Bool -tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } - -tcIsHsig :: TcRn Bool -tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } - -tcSelfBootInfo :: TcRn SelfBootInfo -tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } - -getGlobalRdrEnv :: TcRn GlobalRdrEnv -getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } - -getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) -getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } - -getImports :: TcRn ImportAvails -getImports = do { env <- getGblEnv; return (tcg_imports env) } - -getFixityEnv :: TcRn FixityEnv -getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } - -extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a -extendFixityEnv new_bit - = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> - env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) - -getRecFieldEnv :: TcRn RecFieldEnv -getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } - -getDeclaredDefaultTys :: TcRn (Maybe [Type]) -getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } - -addDependentFiles :: [FilePath] -> TcRn () -addDependentFiles fs = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fs ++ dep_files) - -{- -************************************************************************ -* * - Error management -* * -************************************************************************ --} - -getSrcSpanM :: TcRn SrcSpan - -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) } - -setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan real_loc) thing_inside - = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside --- Don't overwrite useful info with useless: -setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside - -addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b -addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a - -wrapLocM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b --- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (cL loc b) } -wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c) -wrapLocFstM fn (dL->L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (cL loc b, c) - -wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) => - (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c) -wrapLocSndM fn (dL->L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (b, cL loc c) - -wrapLocM_ :: HasSrcSpan a => - (SrcSpanLess a -> TcM ()) -> a -> TcM () -wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a) - --- Reporting errors - -getErrsVar :: TcRn (TcRef Messages) -getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } - -setErrsVar :: TcRef Messages -> TcRn a -> TcRn a -setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) - -addErr :: MsgDoc -> TcRn () -addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } - -failWith :: MsgDoc -> TcRn a -failWith msg = addErr msg >> failM - -failAt :: SrcSpan -> MsgDoc -> TcRn a -failAt loc msg = addErrAt loc msg >> failM - -addErrAt :: SrcSpan -> MsgDoc -> TcRn () --- addErrAt is mainly (exclusively?) used by the renamer, where --- tidying is not an issue, but it's all lazy so the extra --- work doesn't matter -addErrAt loc msg = do { ctxt <- getErrCtxt - ; tidy_env <- tcInitTidyEnv - ; err_info <- mkErrInfo tidy_env ctxt - ; addLongErrAt loc msg err_info } - -addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () -addErrs msgs = mapM_ add msgs - where - add (loc,msg) = addErrAt loc msg - -checkErr :: Bool -> MsgDoc -> TcRn () --- Add the error if the bool is False -checkErr ok msg = unless ok (addErr msg) - -addMessages :: Messages -> TcRn () -addMessages msgs1 - = do { errs_var <- getErrsVar ; - msgs0 <- readTcRef errs_var ; - writeTcRef errs_var (unionMessages msgs0 msgs1) } - -discardWarnings :: TcRn a -> TcRn a --- Ignore warnings inside the thing inside; --- used to ignore-unused-variable warnings inside derived code -discardWarnings thing_inside - = do { errs_var <- getErrsVar - ; (old_warns, _) <- readTcRef errs_var - - ; result <- thing_inside - - -- Revert warnings to old_warns - ; (_new_warns, new_errs) <- readTcRef errs_var - ; writeTcRef errs_var (old_warns, new_errs) - - ; return result } - -{- -************************************************************************ -* * - Shared error message stuff: renamer and typechecker -* * -************************************************************************ --} - -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg -mkLongErrAt loc msg extra - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkLongErrMsg dflags loc printer msg extra } - -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg -mkErrDocAt loc errDoc - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkErrDoc dflags loc printer errDoc } - -addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError - -reportErrors :: [ErrMsg] -> TcM () -reportErrors = mapM_ reportError - -reportError :: ErrMsg -> TcRn () -reportError err - = do { traceTc "Adding error:" (pprLocErrMsg err) ; - errs_var <- getErrsVar ; - (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns, errs `snocBag` err) } - -reportWarning :: WarnReason -> ErrMsg -> TcRn () -reportWarning reason err - = do { let warn = makeIntoWarning reason err - -- 'err' was built by mkLongErrMsg or something like that, - -- so it's of error severity. For a warning we downgrade - -- its severity to SevWarning - - ; traceTc "Adding warning:" (pprLocErrMsg warn) - ; errs_var <- getErrsVar - ; (warns, errs) <- readTcRef errs_var - ; writeTcRef errs_var (warns `snocBag` warn, errs) } - - ------------------------ -checkNoErrs :: TcM r -> TcM r --- (checkNoErrs m) succeeds iff m succeeds and generates no errors --- If m fails then (checkNoErrsTc m) fails. --- If m succeeds, it checks whether m generated any errors messages --- (it might have recovered internally) --- If so, it fails too. --- Regardless, any errors generated by m are propagated to the enclosing context. -checkNoErrs main - = do { (res, no_errs) <- askNoErrs main - ; unless no_errs failM - ; return res } - ------------------------ -whenNoErrs :: TcM () -> TcM () -whenNoErrs thing = ifErrsM (return ()) thing - -ifErrsM :: TcRn r -> TcRn r -> TcRn r --- ifErrsM bale_out normal --- does 'bale_out' if there are errors in errors collection --- otherwise does 'normal' -ifErrsM bale_out normal - = do { errs_var <- getErrsVar ; - msgs <- readTcRef errs_var ; - dflags <- getDynFlags ; - if errorsFound dflags msgs then - bale_out - else - normal } - -failIfErrsM :: TcRn () --- Useful to avoid error cascades -failIfErrsM = ifErrsM failM (return ()) - -{- ********************************************************************* -* * - Context management for the type checker -* * -************************************************************************ --} - -getErrCtxt :: TcM [ErrCtxt] -getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } - -setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a -setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) - --- | Add a fixed message to the error context. This message should not --- do any tidying. -addErrCtxt :: MsgDoc -> TcM a -> TcM a -addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) - --- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) - --- | Add a fixed landmark message to the error context. A landmark --- message is always sure to be reported, even if there is a lot of --- context. It also doesn't count toward the maximum number of contexts --- reported. -addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a -addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) - --- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations --- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts) - --- Helper function for the above -updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> - env { tcl_ctxt = upd ctxt }) - -popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) - -getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc -getCtLocM origin t_or_k - = do { env <- getLclEnv - ; return (CtLoc { ctl_origin = origin - , ctl_env = env - , ctl_t_or_k = t_or_k - , ctl_depth = initialSubGoalDepth }) } - -setCtLocM :: CtLoc -> TcM a -> TcM a --- Set the SrcSpan and error context from the CtLoc -setCtLocM (CtLoc { ctl_env = lcl }) thing_inside - = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl - , tcl_bndrs = tcl_bndrs lcl - , tcl_ctxt = tcl_ctxt lcl }) - thing_inside - - -{- ********************************************************************* -* * - Error recovery and exceptions -* * -********************************************************************* -} - -tcTryM :: TcRn r -> TcRn (Maybe r) --- The most basic function: catch the exception --- Nothing => an exception happened --- Just r => no exception, result R --- Errors and constraints are propagated in both cases --- Never throws an exception -tcTryM thing_inside - = do { either_res <- tryM thing_inside - ; return (case either_res of - Left _ -> Nothing - Right r -> Just r) } - -- In the Left case the exception is always the IOEnv - -- built-in in exception; see IOEnv.failM - ------------------------ -capture_constraints :: TcM r -> TcM (r, WantedConstraints) --- capture_constraints simply captures and returns the --- constraints generated by thing_inside --- Precondition: thing_inside must not throw an exception! --- Reason for precondition: an exception would blow past the place --- where we read the lie_var, and we'd lose the constraints altogether -capture_constraints thing_inside - = do { lie_var <- newTcRef emptyWC - ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $ - thing_inside - ; lie <- readTcRef lie_var - ; return (res, lie) } - -capture_messages :: TcM r -> TcM (r, Messages) --- capture_messages simply captures and returns the --- errors arnd warnings generated by thing_inside --- Precondition: thing_inside must not throw an exception! --- Reason for precondition: an exception would blow past the place --- where we read the msg_var, and we'd lose the constraints altogether -capture_messages thing_inside - = do { msg_var <- newTcRef emptyMessages - ; res <- setErrsVar msg_var thing_inside - ; msgs <- readTcRef msg_var - ; return (res, msgs) } - ------------------------ --- (askNoErrs m) runs m --- If m fails, --- then (askNoErrs m) fails, propagating only --- insoluble constraints --- --- If m succeeds with result r, --- then (askNoErrs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- --- Regardless of success or failure, --- propagate any errors/warnings generated by m -askNoErrs :: TcRn a -> TcRn (a, Bool) -askNoErrs thing_inside - = do { ((mb_res, lie), msgs) <- capture_messages $ - capture_constraints $ - tcTryM thing_inside - ; addMessages msgs - - ; case mb_res of - Nothing -> do { emitConstraints (insolublesOnly lie) - ; failM } - - Just res -> do { emitConstraints lie - ; dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs - || insolubleWC lie - ; return (res, not errs_found) } } - ------------------------ -tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints) --- (tryCaptureConstraints_maybe m) runs m, --- and returns the type constraints it generates --- It never throws an exception; instead if thing_inside fails, --- it returns Nothing and the /insoluble/ constraints --- Error messages are propagated -tryCaptureConstraints thing_inside - = do { (mb_res, lie) <- capture_constraints $ - tcTryM thing_inside - - -- See Note [Constraints and errors] - ; let lie_to_keep = case mb_res of - Nothing -> insolublesOnly lie - Just {} -> lie - - ; return (mb_res, lie_to_keep) } - -captureConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureConstraints m) runs m, and returns the type constraints it generates --- If thing_inside fails (throwing an exception), --- then (captureConstraints thing_inside) fails too --- propagating the insoluble constraints only --- Error messages are propagated in either case -captureConstraints thing_inside - = do { (mb_res, lie) <- tryCaptureConstraints thing_inside - - -- See Note [Constraints and errors] - -- If the thing_inside threw an exception, emit the insoluble - -- constraints only (returned by tryCaptureConstraints) - -- so that they are not lost - ; case mb_res of - Nothing -> do { emitConstraints lie; failM } - Just res -> return (res, lie) } - ------------------------ -attemptM :: TcRn r -> TcRn (Maybe r) --- (attemptM thing_inside) runs thing_inside --- If thing_inside succeeds, returning r, --- we return (Just r), and propagate all constraints and errors --- If thing_inside fail, throwing an exception, --- we return Nothing, propagating insoluble constraints, --- and all errors --- attemptM never throws an exception -attemptM thing_inside - = do { (mb_r, lie) <- tryCaptureConstraints thing_inside - ; emitConstraints lie - - -- Debug trace - ; when (isNothing mb_r) $ - traceTc "attemptM recovering with insoluble constraints" $ - (ppr lie) - - ; return mb_r } - ------------------------ -recoverM :: TcRn r -- Recovery action; do this if the main one fails - -> TcRn r -- Main action: do this first; - -- if it generates errors, propagate them all - -> TcRn r --- (recoverM recover thing_inside) runs thing_inside --- If thing_inside fails, propagate its errors and insoluble constraints --- and run 'recover' --- If thing_inside succeeds, propagate all its errors and constraints --- --- Can fail, if 'recover' fails -recoverM recover thing - = do { mb_res <- attemptM thing ; - case mb_res of - Nothing -> recover - Just res -> return res } - ------------------------ - --- | Drop elements of the input that fail, so the result --- list can be shorter than the argument list -mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndRecoverM f xs - = do { mb_rs <- mapM (attemptM . f) xs - ; return [r | Just r <- mb_rs] } - --- | Apply the function to all elements on the input list --- If all succeed, return the list of results --- Othewise fail, propagating all errors -mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndReportM f xs - = do { mb_rs <- mapM (attemptM . f) xs - ; when (any isNothing mb_rs) failM - ; return [r | Just r <- mb_rs] } - --- | The accumulator is not updated if the action fails -foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b -foldAndRecoverM _ acc [] = return acc -foldAndRecoverM f acc (x:xs) = - do { mb_r <- attemptM (f acc x) - ; case mb_r of - Nothing -> foldAndRecoverM f acc xs - Just acc' -> foldAndRecoverM f acc' xs } - ------------------------ -tryTc :: TcRn a -> TcRn (Maybe a, Messages) --- (tryTc m) executes m, and returns --- Just r, if m succeeds (returning r) --- Nothing, if m fails --- It also returns all the errors and warnings accumulated by m --- It always succeeds (never raises an exception) -tryTc thing_inside - = capture_messages (attemptM thing_inside) - ------------------------ -discardErrs :: TcRn a -> TcRn a --- (discardErrs m) runs m, --- discarding all error messages and warnings generated by m --- If m fails, discardErrs fails, and vice versa -discardErrs m - = do { errs_var <- newTcRef emptyMessages - ; setErrsVar errs_var m } - ------------------------ -tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r --- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside'; --- if 'main' succeeds with no error messages, it's the answer --- otherwise discard everything from 'main', including errors, --- and try 'recover' instead. -tryTcDiscardingErrs recover thing_inside - = do { ((mb_res, lie), msgs) <- capture_messages $ - capture_constraints $ - tcTryM thing_inside - ; dflags <- getDynFlags - ; case mb_res of - Just res | not (errorsFound dflags msgs) - , not (insolubleWC lie) - -> -- 'main' succeeed with no errors - do { addMessages msgs -- msgs might still have warnings - ; emitConstraints lie - ; return res } - - _ -> -- 'main' failed, or produced an error message - recover -- Discard all errors and warnings - -- and unsolved constraints entirely - } - -{- -************************************************************************ -* * - Error message generation (type checker) -* * -************************************************************************ - - The addErrTc functions add an error message, but do not cause failure. - The 'M' variants pass a TidyEnv that has already been used to - tidy up the message; we then use it to tidy the context messages --} - -addErrTc :: MsgDoc -> TcM () -addErrTc err_msg = do { env0 <- tcInitTidyEnv - ; addErrTcM (env0, err_msg) } - -addErrsTc :: [MsgDoc] -> TcM () -addErrsTc err_msgs = mapM_ addErrTc err_msgs - -addErrTcM :: (TidyEnv, MsgDoc) -> TcM () -addErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - add_err_tcm tidy_env err_msg loc ctxt } - --- Return the error message, instead of reporting it straight away -mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg -mkErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - err_info <- mkErrInfo tidy_env ctxt ; - mkLongErrAt loc err_msg err_info } - -mkErrTc :: MsgDoc -> TcM ErrMsg -mkErrTc msg = do { env0 <- tcInitTidyEnv - ; mkErrTcM (env0, msg) } - --- The failWith functions add an error message and cause failure - -failWithTc :: MsgDoc -> TcM a -- Add an error message and fail -failWithTc err_msg - = addErrTc err_msg >> failM - -failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail -failWithTcM local_and_msg - = addErrTcM local_and_msg >> failM - -checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true -checkTc True _ = return () -checkTc False err = failWithTc err - -checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () -checkTcM True _ = return () -checkTcM False err = failWithTcM err - -failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false -failIfTc False _ = return () -failIfTc True err = failWithTc err - -failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () - -- Check that the boolean is false -failIfTcM False _ = return () -failIfTcM True err = failWithTcM err - - --- Warnings have no 'M' variant, nor failure - --- | Display a warning if a condition is met, --- and the warning is enabled -warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () -warnIfFlag warn_flag is_bad msg - = do { warn_on <- woptM warn_flag - ; when (warn_on && is_bad) $ - addWarn (Reason warn_flag) msg } - --- | Display a warning if a condition is met. -warnIf :: Bool -> MsgDoc -> TcRn () -warnIf is_bad msg - = when is_bad (addWarn NoReason msg) - --- | Display a warning if a condition is met. -warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () -warnTc reason warn_if_true warn_msg - | warn_if_true = addWarnTc reason warn_msg - | otherwise = return () - --- | Display a warning if a condition is met. -warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () -warnTcM reason warn_if_true warn_msg - | warn_if_true = addWarnTcM reason warn_msg - | otherwise = return () - --- | Display a warning in the current context. -addWarnTc :: WarnReason -> MsgDoc -> TcM () -addWarnTc reason msg - = do { env0 <- tcInitTidyEnv ; - addWarnTcM reason (env0, msg) } - --- | Display a warning in a given context. -addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () -addWarnTcM reason (env0, msg) - = do { ctxt <- getErrCtxt ; - err_info <- mkErrInfo env0 ctxt ; - add_warn reason msg err_info } - --- | Display a warning for the current source location. -addWarn :: WarnReason -> MsgDoc -> TcRn () -addWarn reason msg = add_warn reason msg Outputable.empty - --- | Display a warning for a given source location. -addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () -addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty - --- | Display a warning, with an optional flag, for the current source --- location. -add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () -add_warn reason msg extra_info - = do { loc <- getSrcSpanM - ; add_warn_at reason loc msg extra_info } - --- | Display a warning, with an optional flag, for a given location. -add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -add_warn_at reason loc msg extra_info - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - let { warn = mkLongWarnMsg dflags loc printer - msg extra_info } ; - reportWarning reason warn } - - -{- ------------------------------------ - Other helper functions --} - -add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan - -> [ErrCtxt] - -> TcM () -add_err_tcm tidy_env err_msg loc ctxt - = do { err_info <- mkErrInfo tidy_env ctxt ; - addLongErrAt loc err_msg err_info } - -mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc --- Tidy the error info, trimming excessive contexts -mkErrInfo env ctxts --- = do --- dbg <- hasPprDebug <$> getDynFlags --- if dbg -- In -dppr-debug style the output --- then return empty -- just becomes too voluminous --- else go dbg 0 env ctxts - = go False 0 env ctxts - where - go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc - go _ _ _ [] = return empty - go dbg n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg - = do { (env', msg) <- ctxt env - ; let n' = if is_landmark then n else n+1 - ; rest <- go dbg n' env' ctxts - ; return (msg $$ rest) } - | otherwise - = go dbg n env ctxts - -mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts -mAX_CONTEXTS = 3 - --- debugTc is useful for monadic debugging code - -debugTc :: TcM () -> TcM () -debugTc thing - | debugIsOn = thing - | otherwise = return () - -{- -************************************************************************ -* * - Type constraints -* * -************************************************************************ --} - -addTopEvBinds :: Bag EvBind -> TcM a -> TcM a -addTopEvBinds new_ev_binds thing_inside - =updGblEnv upd_env thing_inside - where - upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env - `unionBags` new_ev_binds } - -newTcEvBinds :: TcM EvBindsVar -newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet - ; uniq <- newUnique - ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) - ; return (EvBindsVar { ebv_binds = binds_ref - , ebv_tcvs = tcvs_ref - , ebv_uniq = uniq }) } - --- | Creates an EvBindsVar incapable of holding any bindings. It still --- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus --- must be made monadically -newNoTcEvBinds :: TcM EvBindsVar -newNoTcEvBinds - = do { tcvs_ref <- newTcRef emptyVarSet - ; uniq <- newUnique - ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) - ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref - , ebv_uniq = uniq }) } - -cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar --- Clone the refs, so that any binding created when --- solving don't pollute the original -cloneEvBindsVar ebv@(EvBindsVar {}) - = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet - ; return (ebv { ebv_binds = binds_ref - , ebv_tcvs = tcvs_ref }) } -cloneEvBindsVar ebv@(CoEvBindsVar {}) - = do { tcvs_ref <- newTcRef emptyVarSet - ; return (ebv { ebv_tcvs = tcvs_ref }) } - -getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet -getTcEvTyCoVars ev_binds_var - = readTcRef (ebv_tcvs ev_binds_var) - -getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap -getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) - = readTcRef ev_ref -getTcEvBindsMap (CoEvBindsVar {}) - = return emptyEvBindMap - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () -setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds - = writeTcRef ev_ref binds -setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds - | isEmptyEvBindMap ev_binds - = return () - | otherwise - = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) - -addTcEvBind :: EvBindsVar -> EvBind -> TcM () --- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind - = do { traceTc "addTcEvBind" $ ppr u $$ - ppr ev_bind - ; bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } -addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind - = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) - -chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName -chooseUniqueOccTc fn = - do { env <- getGblEnv - ; let dfun_n_var = tcg_dfun_n env - ; set <- readTcRef dfun_n_var - ; let occ = fn set - ; writeTcRef dfun_n_var (extendOccSet set occ) - ; return occ } - -getConstraintVar :: TcM (TcRef WantedConstraints) -getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } - -setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a -setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) - -emitStaticConstraints :: WantedConstraints -> TcM () -emitStaticConstraints static_lie - = do { gbl_env <- getGblEnv - ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } - -emitConstraints :: WantedConstraints -> TcM () -emitConstraints ct - | isEmptyWC ct - = return () - | otherwise - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`andWC` ct) } - -emitSimple :: Ct -> TcM () -emitSimple ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` unitBag ct) } - -emitSimples :: Cts -> TcM () -emitSimples cts - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` cts) } - -emitImplication :: Implication -> TcM () -emitImplication ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addImplics` unitBag ct) } - -emitImplications :: Bag Implication -> TcM () -emitImplications ct - = unless (isEmptyBag ct) $ - do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addImplics` ct) } - -emitInsoluble :: Ct -> TcM () -emitInsoluble ct - = do { traceTc "emitInsoluble" (ppr ct) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` unitBag ct) } - -emitInsolubles :: Cts -> TcM () -emitInsolubles cts - | isEmptyBag cts = return () - | otherwise = do { traceTc "emitInsolubles" (ppr cts) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` cts) } - --- | Throw out any constraints emitted by the thing_inside -discardConstraints :: TcM a -> TcM a -discardConstraints thing_inside = fst <$> captureConstraints thing_inside - --- | The name says it all. The returned TcLevel is the *inner* TcLevel. -pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) -pushLevelAndCaptureConstraints thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') - ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $ - captureConstraints thing_inside - ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') - ; return (tclvl', lie, res) } - -pushTcLevelM_ :: TcM a -> TcM a -pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x - -pushTcLevelM :: TcM a -> TcM (TcLevel, a) --- See Note [TcLevel assignment] in TcType -pushTcLevelM thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) - thing_inside - ; return (tclvl', res) } - --- Returns pushed TcLevel -pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) -pushTcLevelsM num_levels thing_inside - = do { env <- getLclEnv - ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $ - thing_inside - ; return (res, tclvl') } - -getTcLevel :: TcM TcLevel -getTcLevel = do { env <- getLclEnv - ; return (tcl_tclvl env) } - -setTcLevel :: TcLevel -> TcM a -> TcM a -setTcLevel tclvl thing_inside - = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside - -isTouchableTcM :: TcTyVar -> TcM Bool -isTouchableTcM tv - = do { lvl <- getTcLevel - ; return (isTouchableMetaTyVar lvl tv) } - -getLclTypeEnv :: TcM TcTypeEnv -getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } - -setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a --- Set the local type envt, but do *not* disturb other fields, --- notably the lie_var -setLclTypeEnv lcl_env thing_inside - = updLclEnv upd thing_inside - where - upd env = env { tcl_env = tcl_env lcl_env } - -traceTcConstraints :: String -> TcM () -traceTcConstraints msg - = do { lie_var <- getConstraintVar - ; lie <- readTcRef lie_var - ; traceOptTcRn Opt_D_dump_tc_trace $ - hang (text (msg ++ ": LIE:")) 2 (ppr lie) - } - -emitAnonWildCardHoleConstraint :: TcTyVar -> TcM () -emitAnonWildCardHoleConstraint tv - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ unitBag $ - CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc } - , cc_hole = TypeHole (mkTyVarOcc "_") } } - -emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () -emitNamedWildCardHoleConstraints wcs - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ listToBag $ - map (do_one ct_loc) wcs } - where - do_one :: CtLoc -> (Name, TcTyVar) -> Ct - do_one ct_loc (name, tv) - = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc' } - , cc_hole = TypeHole (occName name) } - where - real_span = case nameSrcSpan name of - RealSrcSpan span -> span - UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" - (ppr name <+> quotes (ftext str)) - -- Wildcards are defined locally, and so have RealSrcSpans - ct_loc' = setCtLocSpan ct_loc real_span - -{- Note [Constraints and errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#12124): - - foo :: Maybe Int - foo = return (case Left 3 of - Left -> 1 -- Hard error here! - _ -> 0) - -The call to 'return' will generate a (Monad m) wanted constraint; but -then there'll be "hard error" (i.e. an exception in the TcM monad), from -the unsaturated Left constructor pattern. - -We'll recover in tcPolyBinds, using recoverM. But then the final -tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly -un-filled-in, and will emit a misleading error message. - -The underlying problem is that an exception interrupts the constraint -gathering process. Bottom line: if we have an exception, it's best -simply to discard any gathered constraints. Hence in 'attemptM' we -capture the constraints in a fresh variable, and only emit them into -the surrounding context if we exit normally. If an exception is -raised, simply discard the collected constraints... we have a hard -error to report. So this capture-the-emit dance isn't as stupid as it -looks :-). - -However suppose we throw an exception inside an invocation of -captureConstraints, and discard all the constraints. Some of those -constraints might be "variable out of scope" Hole constraints, and that -might have been the actual original cause of the exception! For -example (#12529): - f = p @ Int -Here 'p' is out of scope, so we get an insolube Hole constraint. But -the visible type application fails in the monad (thows an exception). -We must not discard the out-of-scope error. - -So we /retain the insoluble constraints/ if there is an exception. -Hence: - - insolublesOnly in tryCaptureConstraints - - emitConstraints in the Left case of captureConstraints - -However note that freshly-generated constraints like (Int ~ Bool), or -((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as -insoluble. The constraint solver does that. So they'll be discarded. -That's probably ok; but see th/5358 as a not-so-good example: - t1 :: Int - t1 x = x -- Manifestly wrong - - foo = $(...raises exception...) -We report the exception, but not the bug in t1. Oh well. Possible -solution: make TcUnify.uType spot manifestly-insoluble constraints. - - -************************************************************************ -* * - Template Haskell context -* * -************************************************************************ --} - -recordThUse :: TcM () -recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } - -recordThSpliceUse :: TcM () -recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } - --- | When generating an out-of-scope error message for a variable matching a --- binding in a later inter-splice group, the typechecker uses the splice --- locations to provide details in the message about the scope of that binding. -recordTopLevelSpliceLoc :: SrcSpan -> TcM () -recordTopLevelSpliceLoc (RealSrcSpan real_loc) - = do { env <- getGblEnv - ; let locs_var = tcg_th_top_level_locs env - ; locs0 <- readTcRef locs_var - ; writeTcRef locs_var (Set.insert real_loc locs0) } -recordTopLevelSpliceLoc (UnhelpfulSpan _) = return () - -getTopLevelSpliceLocs :: TcM (Set RealSrcSpan) -getTopLevelSpliceLocs - = do { env <- getGblEnv - ; readTcRef (tcg_th_top_level_locs env) } - -keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set -keepAlive name - = do { env <- getGblEnv - ; traceRn "keep alive" (ppr name) - ; updTcRef (tcg_keep env) (`extendNameSet` name) } - -getStage :: TcM ThStage -getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } - -getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) -getStageAndBindLevel name - = do { env <- getLclEnv; - ; case lookupNameEnv (tcl_th_bndrs env) name of - Nothing -> return Nothing - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } - -setStage :: ThStage -> TcM a -> TcRn a -setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) - --- | Adds the given modFinalizers to the global environment and set them to use --- the current local environment. -addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () -addModFinalizersWithLclEnv mod_finalizers - = do lcl_env <- getLclEnv - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - updTcRef th_modfinalizers_var $ \fins -> - (lcl_env, mod_finalizers) : fins - -{- -************************************************************************ -* * - Safe Haskell context -* * -************************************************************************ --} - --- | Mark that safe inference has failed --- See Note [Safe Haskell Overlapping Instances Implementation] --- although this is used for more than just that failure case. -recordUnsafeInfer :: WarningMessages -> TcM () -recordUnsafeInfer warns = - getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) - --- | Figure out the final correct safe haskell mode -finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode -finalSafeMode dflags tcg_env = do - safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) - return $ case safeHaskell dflags of - Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred - | otherwise -> Sf_None - s -> s - --- | Switch instances to safe instances if we're in Safe mode. -fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] -fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id -fixSafeInstances _ = map fixSafe - where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } - in inst { is_flag = new_flag } - -{- -************************************************************************ -* * - Stuff for the renamer's local env -* * -************************************************************************ --} - -getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } - -setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a -setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside - -{- -************************************************************************ -* * - Stuff for interface decls -* * -************************************************************************ --} - -mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv -mkIfLclEnv mod loc boot - = IfLclEnv { if_mod = mod, - if_loc = loc, - if_boot = boot, - if_nsubst = Nothing, - if_implicits_env = Nothing, - if_tv_env = emptyFsEnv, - if_id_env = emptyFsEnv } - --- | Run an 'IfG' (top-level interface monad) computation inside an existing --- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' --- based on 'TcGblEnv'. -initIfaceTcRn :: IfG a -> TcRn a -initIfaceTcRn thing_inside - = do { tcg_env <- getGblEnv - ; dflags <- getDynFlags - ; let !mod = tcg_semantic_mod tcg_env - -- When we are instantiating a signature, we DEFINITELY - -- do not want to knot tie. - is_instantiate = unitIdIsDefinite (thisPackage dflags) && - not (null (thisUnitIdInsts dflags)) - ; let { if_env = IfGblEnv { - if_doc = text "initIfaceTcRn", - if_rec_types = - if is_instantiate - then Nothing - else Just (mod, get_type_env) - } - ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } - ; setEnvs (if_env, ()) thing_inside } - --- Used when sucking in a ModIface into a ModDetails to put in --- the HPT. Notably, unlike initIfaceCheck, this does NOT use --- hsc_type_env_var (since we're not actually going to typecheck, --- so this variable will never get updated!) -initIfaceLoad :: HscEnv -> IfG a -> IO a -initIfaceLoad hsc_env do_this - = do let gbl_env = IfGblEnv { - if_doc = text "initIfaceLoad", - if_rec_types = Nothing - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a --- Used when checking the up-to-date-ness of the old Iface --- Initialise the environment with no useful info at all -initIfaceCheck doc hsc_env do_this - = do let rec_types = case hsc_type_env_var hsc_env of - Just (mod,var) -> Just (mod, readTcRef var) - Nothing -> Nothing - gbl_env = IfGblEnv { - if_doc = text "initIfaceCheck" <+> doc, - if_rec_types = rec_types - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a -initIfaceLcl mod loc_doc hi_boot_file thing_inside - = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside - --- | Initialize interface typechecking, but with a 'NameShape' --- to apply when typechecking top-level 'OccName's (see --- 'lookupIfaceTop') -initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a -initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside - = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside - -getIfModule :: IfL Module -getIfModule = do { env <- getLclEnv; return (if_mod env) } - --------------------- -failIfM :: MsgDoc -> IfL a --- The Iface monad doesn't have a place to accumulate errors, so we --- just fall over fast if one happens; it "shouldn't happen". --- We use IfL here so that we can get context info out of the local env -failIfM msg - = do { env <- getLclEnv - ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; dflags <- getDynFlags - ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan (defaultErrStyle dflags) full_msg) - ; failM } - --------------------- -forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) --- Run thing_inside in an interleaved thread. --- It shares everything with the parent thread, so this is DANGEROUS. --- --- It returns Nothing if the computation fails --- --- It's used for lazily type-checking interface --- signatures, which is pretty benign - -forkM_maybe doc thing_inside - = do { -- see Note [Masking exceptions in forkM_maybe] - ; unsafeInterleaveM $ uninterruptibleMaskM_ $ - do { traceIf (text "Starting fork {" <+> doc) - ; mb_res <- tryM $ - updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ - thing_inside - ; case mb_res of - Right r -> do { traceIf (text "} ending fork" <+> doc) - ; return (Just r) } - Left exn -> do { - - -- Bleat about errors in the forked thread, if -ddump-if-trace is on - -- Otherwise we silently discard errors. Errors can legitimately - -- happen when compiling interface signatures (see tcInterfaceSigs) - whenDOptM Opt_D_dump_if_trace $ do - dflags <- getDynFlags - let msg = hang (text "forkM failed:" <+> doc) - 2 (text (show exn)) - liftIO $ putLogMsg dflags - NoReason - SevFatal - noSrcSpan - (defaultErrStyle dflags) - msg - - ; traceIf (text "} ending fork (badly)" <+> doc) - ; return Nothing } - }} - -forkM :: SDoc -> IfL a -> IfL a -forkM doc thing_inside - = do { mb_res <- forkM_maybe doc thing_inside - ; return (case mb_res of - Nothing -> pgmError "Cannot continue after interface file error" - -- pprPanic "forkM" doc - Just r -> r) } - -setImplicitEnvM :: TypeEnv -> IfL a -> IfL a -setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl - { if_implicits_env = Just tenv }) m - -{- -Note [Masking exceptions in forkM_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When using GHC-as-API it must be possible to interrupt snippets of code -executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible -by throwing an asynchronous interrupt to the GHC thread. However, there is a -subtle problem: runStmt first typechecks the code before running it, and the -exception might interrupt the type checker rather than the code. Moreover, the -typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and -more importantly might be inside an exception handler inside that -unsafeInterleaveIO. If that is the case, the exception handler will rethrow the -asynchronous exception as a synchronous exception, and the exception will end -up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed -discussion). We don't currently know a general solution to this problem, but -we can use uninterruptibleMask_ to avoid the situation. --} - --- | Environments which track 'CostCentreState' -class ContainsCostCentreState e where - extractCostCentreState :: e -> TcRef CostCentreState - -instance ContainsCostCentreState TcGblEnv where - extractCostCentreState = tcg_cc_st - -instance ContainsCostCentreState DsGblEnv where - extractCostCentreState = ds_cc_st - --- | Get the next cost centre index associated with a given name. -getCCIndexM :: (ContainsCostCentreState gbl) - => FastString -> TcRnIf gbl lcl CostCentreIndex -getCCIndexM nm = do - env <- getGblEnv - let cc_st_ref = extractCostCentreState env - cc_st <- readTcRef cc_st_ref - let (idx, cc_st') = getCCIndex nm cc_st - writeTcRef cc_st_ref cc_st' - return idx diff --git a/typecheck/TcRnTypes.hs b/typecheck/TcRnTypes.hs deleted file mode 100644 --- a/typecheck/TcRnTypes.hs +++ /dev/null @@ -1,1728 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-2002 - - -Various types used during typechecking, please see TcRnMonad as well for -operations on these types. You probably want to import it, instead of this -module. - -All the monads exported here are built on top of the same IOEnv monad. The -monad functions like a Reader monad in the way it passes the environment -around. This is done to allow the environment to be manipulated in a stack -like fashion when entering expressions... etc. - -For state that is global and should be returned at the end (e.g not part -of the stack mechanism), you should use a TcRef (= IORef) to store them. --} - -{-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving, - ViewPatterns #-} - -module TcRnTypes( - TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module - TcRef, - - -- The environment types - Env(..), - TcGblEnv(..), TcLclEnv(..), - setLclEnvTcLevel, getLclEnvTcLevel, - setLclEnvLoc, getLclEnvLoc, - IfGblEnv(..), IfLclEnv(..), - tcVisibleOrphanMods, - - -- Frontend types (shouldn't really be here) - FrontendResult(..), - - -- Renamer types - ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin, - ImportAvails(..), emptyImportAvails, plusImportAvails, - WhereFrom(..), mkModDeps, modDepsElts, - - -- Typechecker types - TcTypeEnv, TcBinderStack, TcBinder(..), - TcTyThing(..), PromotionErr(..), - IdBindingInfo(..), ClosedTypeId, RhsNames, - IsGroupClosed(..), - SelfBootInfo(..), - pprTcTyThingCategory, pprPECategory, CompleteMatch(..), - - -- Desugaring types - DsM, DsLclEnv(..), DsGblEnv(..), - DsMetaEnv, DsMetaVal(..), CompleteMatchMap, - mkCompleteMatchMap, extendCompleteMatchMap, - - -- Template Haskell - ThStage(..), SpliceType(..), PendingStuff(..), - topStage, topAnnStage, topSpliceStage, - ThLevel, impLevel, outerLevel, thLevel, - ForeignSrcLang(..), - - -- Arrows - ArrowCtxt(..), - - -- TcSigInfo - TcSigFun, TcSigInfo(..), TcIdSigInfo(..), - TcIdSigInst(..), TcPatSynInfo(..), - isPartialSig, hasCompleteSig, - - -- Misc other types - TcId, TcIdSet, - Hole(..), holeOcc, - NameShape(..), - removeBindingShadowing, - - -- Constraint solver plugins - TcPlugin(..), TcPluginResult(..), TcPluginSolver, - TcPluginM, runTcPluginM, unsafeTcPluginTcM, - getEvBindsTcPluginM, - - -- Role annotations - RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, - lookupRoleAnnot, getRoleAnnots - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import HscTypes -import TcEvidence -import Type -import TyCon ( TyCon, tyConKind ) -import PatSyn ( PatSyn ) -import Id ( idType, idName ) -import FieldLabel ( FieldLabel ) -import TcType -import Constraint -import TcOrigin -import Annotations -import InstEnv -import FamInstEnv -import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Delta) -import IOEnv -import RdrName -import Name -import NameEnv -import NameSet -import Avail -import Var -import VarEnv -import Module -import SrcLoc -import VarSet -import ErrUtils -import UniqFM -import BasicTypes -import Bag -import DynFlags -import Outputable -import ListSetOps -import Fingerprint -import Util -import PrelNames ( isUnboundName ) -import CostCentreState - -import Control.Monad (ap) -import qualified Control.Monad.Fail as MonadFail -import Data.Set ( Set ) -import qualified Data.Set as S - -import Data.List ( sort ) -import Data.Map ( Map ) -import Data.Dynamic ( Dynamic ) -import Data.Typeable ( TypeRep ) -import Data.Maybe ( mapMaybe ) -import GHCi.Message -import GHCi.RemoteTypes - -import {-# SOURCE #-} TcHoleFitTypes ( HoleFitPlugin ) - -import qualified Language.Haskell.TH as TH - --- | A 'NameShape' is a substitution on 'Name's that can be used --- to refine the identities of a hole while we are renaming interfaces --- (see 'RnModIface'). Specifically, a 'NameShape' for --- 'ns_module_name' @A@, defines a mapping from @{A.T}@ --- (for some 'OccName' @T@) to some arbitrary other 'Name'. --- --- The most intruiging thing about a 'NameShape', however, is --- how it's constructed. A 'NameShape' is *implied* by the --- exported 'AvailInfo's of the implementor of an interface: --- if an implementor of signature @@ exports @M.T@, you implicitly --- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' --- is computed from the list of 'AvailInfo's that are exported --- by the implementation of a module, or successively merged --- together by the export lists of signatures which are joining --- together. --- --- It's not the most obvious way to go about doing this, but it --- does seem to work! --- --- NB: Can't boot this and put it in NameShape because then we --- start pulling in too many DynFlags things. -data NameShape = NameShape { - ns_mod_name :: ModuleName, - ns_exports :: [AvailInfo], - ns_map :: OccEnv Name - } - - -{- -************************************************************************ -* * - Standard monad definition for TcRn - All the combinators for the monad can be found in TcRnMonad -* * -************************************************************************ - -The monad itself has to be defined here, because it is mentioned by ErrCtxt --} - -type TcRnIf a b = IOEnv (Env a b) -type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference -type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff -type IfG = IfM () -- Top level -type IfL = IfM IfLclEnv -- Nested -type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring - --- TcRn is the type-checking and renaming monad: the main monad that --- most type-checking takes place in. The global environment is --- 'TcGblEnv', which tracks all of the top-level type-checking --- information we've accumulated while checking a module, while the --- local environment is 'TcLclEnv', which tracks local information as --- we move inside expressions. - --- | Historical "renaming monad" (now it's just 'TcRn'). -type RnM = TcRn - --- | Historical "type-checking monad" (now it's just 'TcRn'). -type TcM = TcRn - --- We 'stack' these envs through the Reader like monad infrastructure --- as we move into an expression (although the change is focused in --- the lcl type). -data Env gbl lcl - = Env { - env_top :: !HscEnv, -- Top-level stuff that never changes - -- Includes all info about imported things - -- BangPattern is to fix leak, see #15111 - - env_um :: !Char, -- Mask for Uniques - - env_gbl :: gbl, -- Info about things defined at the top level - -- of the module being compiled - - env_lcl :: lcl -- Nested stuff; changes as we go into - } - -instance ContainsDynFlags (Env gbl lcl) where - extractDynFlags env = hsc_dflags (env_top env) - -instance ContainsModule gbl => ContainsModule (Env gbl lcl) where - extractModule env = extractModule (env_gbl env) - - -{- -************************************************************************ -* * - The interface environments - Used when dealing with IfaceDecls -* * -************************************************************************ --} - -data IfGblEnv - = IfGblEnv { - -- Some information about where this environment came from; - -- useful for debugging. - if_doc :: SDoc, - -- The type environment for the module being compiled, - -- in case the interface refers back to it via a reference that - -- was originally a hi-boot file. - -- We need the module name so we can test when it's appropriate - -- to look in this env. - -- See Note [Tying the knot] in TcIface - if_rec_types :: Maybe (Module, IfG TypeEnv) - -- Allows a read effect, so it can be in a mutable - -- variable; c.f. handling the external package type env - -- Nothing => interactive stuff, no loops possible - } - -data IfLclEnv - = IfLclEnv { - -- The module for the current IfaceDecl - -- So if we see f = \x -> x - -- it means M.f = \x -> x, where M is the if_mod - -- NB: This is a semantic module, see - -- Note [Identity versus semantic module] - if_mod :: Module, - - -- Whether or not the IfaceDecl came from a boot - -- file or not; we'll use this to choose between - -- NoUnfolding and BootUnfolding - if_boot :: Bool, - - -- The field is used only for error reporting - -- if (say) there's a Lint error in it - if_loc :: SDoc, - -- Where the interface came from: - -- .hi file, or GHCi state, or ext core - -- plus which bit is currently being examined - - if_nsubst :: Maybe NameShape, - - -- This field is used to make sure "implicit" declarations - -- (anything that cannot be exported in mi_exports) get - -- wired up correctly in typecheckIfacesForMerging. Most - -- of the time it's @Nothing@. See Note [Resolving never-exported Names in TcIface] - -- in TcIface. - if_implicits_env :: Maybe TypeEnv, - - if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings - if_id_env :: FastStringEnv Id -- Nested id binding - } - -{- -************************************************************************ -* * - Desugarer monad -* * -************************************************************************ - -Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around -a @UniqueSupply@ and some annotations, which -presumably include source-file location information: --} - -data DsGblEnv - = DsGblEnv - { ds_mod :: Module -- For SCC profiling - , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env - , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef Messages -- Warning messages - , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, - -- possibly-imported things - , ds_complete_matches :: CompleteMatchMap - -- Additional complete pattern matches - , ds_cc_st :: IORef CostCentreState - -- Tracking indices for cost centre annotations - } - -instance ContainsModule DsGblEnv where - extractModule = ds_mod - -data DsLclEnv = DsLclEnv { - dsl_meta :: DsMetaEnv, -- Template Haskell bindings - dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs - - -- See Note [Note [Type and Term Equality Propagation] in Check.hs - -- The oracle state Delta is augmented as we walk inwards, - -- through each pattern match in turn - dsl_delta :: Delta - } - --- Inside [| |] brackets, the desugarer looks --- up variables in the DsMetaEnv -type DsMetaEnv = NameEnv DsMetaVal - -data DsMetaVal - = DsBound Id -- Bound by a pattern inside the [| |]. - -- Will be dynamically alpha renamed. - -- The Id has type THSyntax.Var - - | DsSplice (HsExpr GhcTc) -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut - - -{- -************************************************************************ -* * - Global typechecker environment -* * -************************************************************************ --} - --- | 'FrontendResult' describes the result of running the --- frontend of a Haskell module. Usually, you'll get --- a 'FrontendTypecheck', since running the frontend involves --- typechecking a program, but for an hs-boot merge you'll --- just get a ModIface, since no actual typechecking occurred. --- --- This data type really should be in HscTypes, but it needs --- to have a TcGblEnv which is only defined here. -data FrontendResult - = FrontendTypecheck TcGblEnv - --- Note [Identity versus semantic module] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- When typechecking an hsig file, it is convenient to keep track --- of two different "this module" identifiers: --- --- - The IDENTITY module is simply thisPackage + the module --- name; i.e. it uniquely *identifies* the interface file --- we're compiling. For example, p[A=]:A is an --- identity module identifying the requirement named A --- from library p. --- --- - The SEMANTIC module, which is the actual module that --- this signature is intended to represent (e.g. if --- we have a identity module p[A=base:Data.IORef]:A, --- then the semantic module is base:Data.IORef) --- --- Which one should you use? --- --- - In the desugarer and later phases of compilation, --- identity and semantic modules coincide, since we never compile --- signatures (we just generate blank object files for --- hsig files.) --- --- A corrolary of this is that the following invariant holds at any point --- past desugaring, --- --- if I have a Module, this_mod, in hand representing the module --- currently being compiled, --- then moduleUnitId this_mod == thisPackage dflags --- --- - For any code involving Names, we want semantic modules. --- See lookupIfaceTop in IfaceEnv, mkIface and addFingerprints --- in MkIface, and tcLookupGlobal in TcEnv --- --- - When reading interfaces, we want the identity module to --- identify the specific interface we want (such interfaces --- should never be loaded into the EPS). However, if a --- hole module is requested, we look for A.hi --- in the home library we are compiling. (See LoadIface.) --- Similarly, in RnNames we check for self-imports using --- identity modules, to allow signatures to import their implementor. --- --- - For recompilation avoidance, you want the identity module, --- since that will actually say the specific interface you --- want to track (and recompile if it changes) - --- | 'TcGblEnv' describes the top-level of the module at the --- point at which the typechecker is finished work. --- It is this structure that is handed on to the desugarer --- For state that needs to be updated during the typechecking --- phase and returned at end, use a 'TcRef' (= 'IORef'). -data TcGblEnv - = TcGblEnv { - tcg_mod :: Module, -- ^ Module being compiled - tcg_semantic_mod :: Module, -- ^ If a signature, the backing module - -- See also Note [Identity versus semantic module] - tcg_src :: HscSource, - -- ^ What kind of module (regular Haskell, hs-boot, hsig) - - tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming - tcg_default :: Maybe [Type], - -- ^ Types used for defaulting. @Nothing@ => no @default@ decl - - tcg_fix_env :: FixityEnv, -- ^ Just for things in this module - tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module - -- See Note [The interactive package] in HscTypes - - tcg_type_env :: TypeEnv, - -- ^ Global type env for the module we are compiling now. All - -- TyCons and Classes (for this module) end up in here right away, - -- along with their derived constructors, selectors. - -- - -- (Ids defined in this module start in the local envt, though they - -- move to the global envt during zonking) - -- - -- NB: for what "things in this module" means, see - -- Note [The interactive package] in HscTypes - - tcg_type_env_var :: TcRef TypeEnv, - -- Used only to initialise the interface-file - -- typechecker in initIfaceTcRn, so that it can see stuff - -- bound in this module when dealing with hi-boot recursions - -- Updated at intervals (e.g. after dealing with types and classes) - - tcg_inst_env :: !InstEnv, - -- ^ Instance envt for all /home-package/ modules; - -- Includes the dfuns in tcg_insts - -- NB. BangPattern is to fix a leak, see #15111 - tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances - -- NB. BangPattern is to fix a leak, see #15111 - tcg_ann_env :: AnnEnv, -- ^ And for annotations - - -- Now a bunch of things about this module that are simply - -- accumulated, but never consulted until the end. - -- Nevertheless, it's convenient to accumulate them along - -- with the rest of the info from this module. - tcg_exports :: [AvailInfo], -- ^ What is exported - tcg_imports :: ImportAvails, - -- ^ Information about what was imported from where, including - -- things bound in this module. Also store Safe Haskell info - -- here about transitive trusted package requirements. - -- - -- There are not many uses of this field, so you can grep for - -- all them. - -- - -- The ImportAvails records information about the following - -- things: - -- - -- 1. All of the modules you directly imported (tcRnImports) - -- 2. The orphans (only!) of all imported modules in a GHCi - -- session (runTcInteractive) - -- 3. The module that instantiated a signature - -- 4. Each of the signatures that merged in - -- - -- It is used in the following ways: - -- - imp_orphs is used to determine what orphan modules should be - -- visible in the context (tcVisibleOrphanMods) - -- - imp_finsts is used to determine what family instances should - -- be visible (tcExtendLocalFamInstEnv) - -- - To resolve the meaning of the export list of a module - -- (tcRnExports) - -- - imp_mods is used to compute usage info (mkIfaceTc, deSugar) - -- - imp_trust_own_pkg is used for Safe Haskell in interfaces - -- (mkIfaceTc, as well as in HscMain) - -- - To create the Dependencies field in interface (mkDependencies) - - -- These three fields track unused bindings and imports - -- See Note [Tracking unused binding and imports] - tcg_dus :: DefUses, - tcg_used_gres :: TcRef [GlobalRdrElt], - tcg_keep :: TcRef NameSet, - - tcg_th_used :: TcRef Bool, - -- ^ @True@ <=> Template Haskell syntax used. - -- - -- We need this so that we can generate a dependency on the - -- Template Haskell package, because the desugarer is going - -- to emit loads of references to TH symbols. The reference - -- is implicit rather than explicit, so we have to zap a - -- mutable variable. - - tcg_th_splice_used :: TcRef Bool, - -- ^ @True@ <=> A Template Haskell splice was used. - -- - -- Splices disable recompilation avoidance (see #481) - - tcg_th_top_level_locs :: TcRef (Set RealSrcSpan), - -- ^ Locations of the top-level splices; used for providing details on - -- scope in error messages for out-of-scope variables - - tcg_dfun_n :: TcRef OccSet, - -- ^ Allows us to choose unique DFun names. - - tcg_merged :: [(Module, Fingerprint)], - -- ^ The requirements we merged with; we always have to recompile - -- if any of these changed. - - -- The next fields accumulate the payload of the module - -- The binds, rules and foreign-decl fields are collected - -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - - tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)], - -- Nothing <=> no explicit export list - -- Is always Nothing if we don't want to retain renamed - -- exports. - -- If present contains each renamed export list item - -- together with its exported names. - - tcg_rn_imports :: [LImportDecl GhcRn], - -- Keep the renamed imports regardless. They are not - -- voluminous and are needed if you want to report unused imports - - tcg_rn_decls :: Maybe (HsGroup GhcRn), - -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed - -- decls. - - tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile - - tcg_th_topdecls :: TcRef [LHsDecl GhcPs], - -- ^ Top-level declarations from addTopDecls - - tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)], - -- ^ Foreign files emitted from TH. - - tcg_th_topnames :: TcRef NameSet, - -- ^ Exact names bound in top-level declarations in tcg_th_topdecls - - tcg_th_modfinalizers :: TcRef [(TcLclEnv, ThModFinalizers)], - -- ^ Template Haskell module finalizers. - -- - -- They can use particular local environments. - - tcg_th_coreplugins :: TcRef [String], - -- ^ Core plugins added by Template Haskell code. - - tcg_th_state :: TcRef (Map TypeRep Dynamic), - tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), - -- ^ Template Haskell state - - tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings - - -- Things defined in this module, or (in GHCi) - -- in the declarations for a single GHCi command. - -- For the latter, see Note [The interactive package] in HscTypes - tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module - -- for which every module has a top-level defn - -- except in GHCi in which case we have Nothing - tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module - tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature - tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids - tcg_warns :: Warnings, -- ...Warnings and deprecations - tcg_anns :: [Annotation], -- ...Annotations - tcg_tcs :: [TyCon], -- ...TyCons and Classes - tcg_insts :: [ClsInst], -- ...Instances - tcg_fam_insts :: [FamInst], -- ...Family instances - tcg_rules :: [LRuleDecl GhcTc], -- ...Rules - tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports - tcg_patsyns :: [PatSyn], -- ...Pattern synonyms - - tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs - tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the - -- prog uses hpc instrumentation. - -- NB. BangPattern is to fix a leak, see #15111 - - tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a - -- corresponding hi-boot file - - tcg_main :: Maybe Name, -- ^ The Name of the main - -- function, if this module is - -- the main module. - - tcg_safeInfer :: TcRef (Bool, WarningMessages), - -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell) - -- See Note [Safe Haskell Overlapping Instances Implementation], - -- although this is used for more than just that failure case. - - tcg_tc_plugins :: [TcPluginSolver], - -- ^ A list of user-defined plugins for the constraint solver. - tcg_hf_plugins :: [HoleFitPlugin], - -- ^ A list of user-defined plugins for hole fit suggestions. - - tcg_top_loc :: RealSrcSpan, - -- ^ The RealSrcSpan this module came from - - tcg_static_wc :: TcRef WantedConstraints, - -- ^ Wanted constraints of static forms. - -- See Note [Constraints in static forms]. - tcg_complete_matches :: [CompleteMatch], - - -- ^ Tracking indices for cost centre annotations - tcg_cc_st :: TcRef CostCentreState - } - --- NB: topModIdentity, not topModSemantic! --- Definition sites of orphan identities will be identity modules, not semantic --- modules. - --- Note [Constraints in static forms] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When a static form produces constraints like --- --- f :: StaticPtr (Bool -> String) --- f = static show --- --- we collect them in tcg_static_wc and resolve them at the end --- of type checking. They need to be resolved separately because --- we don't want to resolve them in the context of the enclosing --- expression. Consider --- --- g :: Show a => StaticPtr (a -> String) --- g = static show --- --- If the @Show a0@ constraint that the body of the static form produces was --- resolved in the context of the enclosing expression, then the body of the --- static form wouldn't be closed because the Show dictionary would come from --- g's context instead of coming from the top level. - -tcVisibleOrphanMods :: TcGblEnv -> ModuleSet -tcVisibleOrphanMods tcg_env - = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) - -instance ContainsModule TcGblEnv where - extractModule env = tcg_semantic_mod env - -type RecFieldEnv = NameEnv [FieldLabel] - -- Maps a constructor name *in this module* - -- to the fields for that constructor. - -- This is used when dealing with ".." notation in record - -- construction and pattern matching. - -- The FieldEnv deals *only* with constructors defined in *this* - -- module. For imported modules, we get the same info from the - -- TypeEnv - -data SelfBootInfo - = NoSelfBoot -- No corresponding hi-boot file - | SelfBoot - { sb_mds :: ModDetails -- There was a hi-boot file, - , sb_tcs :: NameSet } -- defining these TyCons, --- What is sb_tcs used for? See Note [Extra dependencies from .hs-boot files] --- in RnSource - - -{- Note [Tracking unused binding and imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We gather three sorts of usage information - - * tcg_dus :: DefUses (defs/uses) - Records what is defined in this module and what is used. - - Records *defined* Names (local, top-level) - and *used* Names (local or imported) - - Used (a) to report "defined but not used" - (see RnNames.reportUnusedNames) - (b) to generate version-tracking usage info in interface - files (see MkIface.mkUsedNames) - This usage info is mainly gathered by the renamer's - gathering of free-variables - - * tcg_used_gres :: TcRef [GlobalRdrElt] - Records occurrences of imported entities. - - Used only to report unused import declarations - - Records each *occurrence* an *imported* (not locally-defined) entity. - The occurrence is recorded by keeping a GlobalRdrElt for it. - These is not the GRE that is in the GlobalRdrEnv; rather it - is recorded *after* the filtering done by pickGREs. So it reflect - /how that occurrence is in scope/. See Note [GRE filtering] in - RdrName. - - * tcg_keep :: TcRef NameSet - Records names of the type constructors, data constructors, and Ids that - are used by the constraint solver. - - The typechecker may use find that some imported or - locally-defined things are used, even though they - do not appear to be mentioned in the source code: - - (a) The to/from functions for generic data types - - (b) Top-level variables appearing free in the RHS of an - orphan rule - - (c) Top-level variables appearing free in a TH bracket - See Note [Keeping things alive for Template Haskell] - in RnSplice - - (d) The data constructor of a newtype that is used - to solve a Coercible instance (e.g. #10347). Example - module T10347 (N, mkN) where - import Data.Coerce - newtype N a = MkN Int - mkN :: Int -> N a - mkN = coerce - - Then we wish to record `MkN` as used, since it is (morally) - used to perform the coercion in `mkN`. To do so, the - Coercible solver updates tcg_keep's TcRef whenever it - encounters a use of `coerce` that crosses newtype boundaries. - - The tcg_keep field is used in two distinct ways: - - * Desugar.addExportFlagsAndRules. Where things like (a-c) are locally - defined, we should give them an an Exported flag, so that the - simplifier does not discard them as dead code, and so that they are - exposed in the interface file (but not to export to the user). - - * RnNames.reportUnusedNames. Where newtype data constructors like (d) - are imported, we don't want to report them as unused. - - -************************************************************************ -* * - The local typechecker environment -* * -************************************************************************ - -Note [The Global-Env/Local-Env story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type checking, we keep in the tcg_type_env - * All types and classes - * All Ids derived from types and classes (constructors, selectors) - -At the end of type checking, we zonk the local bindings, -and as we do so we add to the tcg_type_env - * Locally defined top-level Ids - -Why? Because they are now Ids not TcIds. This final GlobalEnv is - a) fed back (via the knot) to typechecking the - unfoldings of interface signatures - b) used in the ModDetails of this module --} - -data TcLclEnv -- Changes as we move inside an expression - -- Discarded after typecheck/rename; not passed on to desugarer - = TcLclEnv { - tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_tclvl :: TcLevel, -- Birthplace for new unification variables - - tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_th_bndrs :: ThBindEnv, -- and binder info - -- The ThBindEnv records the TH binding level of in-scope Names - -- defined in this module (not imported) - -- We can't put this info in the TypeEnv because it's needed - -- (and extended) in the renamer, for untyed splices - - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context - - tcl_rdr :: LocalRdrEnv, -- Local name envt - -- Maintained during renaming, of course, but also during - -- type checking, solely so that when renaming a Template-Haskell - -- splice we have the right environment for the renamer. - -- - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence constructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - tcl_env :: TcTypeEnv, -- The local type environment: - -- Ids and TyVars defined in this module - - tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, - -- and for tidying types - - tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef Messages -- Place to accumulate errors - } - -setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv -setLclEnvTcLevel env lvl = env { tcl_tclvl = lvl } - -getLclEnvTcLevel :: TcLclEnv -> TcLevel -getLclEnvTcLevel = tcl_tclvl - -setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv -setLclEnvLoc env loc = env { tcl_loc = loc } - -getLclEnvLoc :: TcLclEnv -> RealSrcSpan -getLclEnvLoc = tcl_loc - -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) - -- Monadic so that we have a chance - -- to deal with bound type variables just before error - -- message construction - - -- Bool: True <=> this is a landmark context; do not - -- discard it when trimming for display - --- These are here to avoid module loops: one might expect them --- in Constraint, but they refer to ErrCtxt which refers to TcM. --- Easier to just keep these definitions here, alongside TcM. -pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc -pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc --- Just add information w/o updating the origin! -pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -type TcTypeEnv = NameEnv TcTyThing - -type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) - -- Domain = all Ids bound in this module (ie not imported) - -- The TopLevelFlag tells if the binding is syntactically top level. - -- We need to know this, because the cross-stage persistence story allows - -- cross-stage at arbitrary types if the Id is bound at top level. - -- - -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being - -- bound at top level! See Note [Template Haskell levels] in TcSplice - -{- Note [Given Insts] - ~~~~~~~~~~~~~~~~~~ -Because of GADTs, we have to pass inwards the Insts provided by type signatures -and existential contexts. Consider - data T a where { T1 :: b -> b -> T [b] } - f :: Eq a => T a -> Bool - f (T1 x y) = [x]==[y] - -The constructor T1 binds an existential variable 'b', and we need Eq [b]. -Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we -pass it inwards. - --} - --- | Type alias for 'IORef'; the convention is we'll use this for mutable --- bits of data in 'TcGblEnv' which are updated during typechecking and --- returned at the end. -type TcRef a = IORef a --- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? -type TcId = Id -type TcIdSet = IdSet - ---------------------------- --- The TcBinderStack ---------------------------- - -type TcBinderStack = [TcBinder] - -- This is a stack of locally-bound ids and tyvars, - -- innermost on top - -- Used only in error reporting (relevantBindings in TcError), - -- and in tidying - -- We can't use the tcl_env type environment, because it doesn't - -- keep track of the nesting order - -data TcBinder - = TcIdBndr - TcId - TopLevelFlag -- Tells whether the binding is syntactically top-level - -- (The monomorphic Ids for a recursive group count - -- as not-top-level for this purpose.) - - | TcIdBndr_ExpType -- Variant that allows the type to be specified as - -- an ExpType - Name - ExpType - TopLevelFlag - - | TcTvBndr -- e.g. case x of P (y::a) -> blah - Name -- We bind the lexical name "a" to the type of y, - TyVar -- which might be an utterly different (perhaps - -- existential) tyvar - -instance Outputable TcBinder where - ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) - ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) - ppr (TcTvBndr name tv) = ppr name <+> ppr tv - -instance HasOccName TcBinder where - occName (TcIdBndr id _) = occName (idName id) - occName (TcIdBndr_ExpType name _ _) = occName name - occName (TcTvBndr name _) = occName name - --- fixes #12177 --- Builds up a list of bindings whose OccName has not been seen before --- i.e., If ys = removeBindingShadowing xs --- then --- - ys is obtained from xs by deleting some elements --- - ys has no duplicate OccNames --- - The first duplicated OccName in xs is retained in ys --- Overloaded so that it can be used for both GlobalRdrElt in typed-hole --- substitutions and TcBinder when looking for relevant bindings. -removeBindingShadowing :: HasOccName a => [a] -> [a] -removeBindingShadowing bindings = reverse $ fst $ foldl - (\(bindingAcc, seenNames) binding -> - if occName binding `elemOccSet` seenNames -- if we've seen it - then (bindingAcc, seenNames) -- skip it - else (binding:bindingAcc, extendOccSet seenNames (occName binding))) - ([], emptyOccSet) bindings - ---------------------------- --- Template Haskell stages and levels ---------------------------- - -data SpliceType = Typed | Untyped - -data ThStage -- See Note [Template Haskell state diagram] in TcSplice - = Splice SpliceType -- Inside a top-level splice - -- This code will be run *at compile time*; - -- the result replaces the splice - -- Binding level = 0 - - | RunSplice (TcRef [ForeignRef (TH.Q ())]) - -- Set when running a splice, i.e. NOT when renaming or typechecking the - -- Haskell code for the splice. See Note [RunSplice ThLevel]. - -- - -- Contains a list of mod finalizers collected while executing the splice. - -- - -- 'addModFinalizer' inserts finalizers here, and from here they are taken - -- to construct an @HsSpliced@ annotation for untyped splices. See Note - -- [Delaying modFinalizers in untyped splices] in "RnSplice". - -- - -- For typed splices, the typechecker takes finalizers from here and - -- inserts them in the list of finalizers in the global environment. - -- - -- See Note [Collecting modFinalizers in typed splices] in "TcSplice". - - | Comp -- Ordinary Haskell code - -- Binding level = 1 - - | Brack -- Inside brackets - ThStage -- Enclosing stage - PendingStuff - -data PendingStuff - = RnPendingUntyped -- Renaming the inside of an *untyped* bracket - (TcRef [PendingRnSplice]) -- Pending splices in here - - | RnPendingTyped -- Renaming the inside of a *typed* bracket - - | TcPending -- Typechecking the inside of a typed bracket - (TcRef [PendingTcSplice]) -- Accumulate pending splices here - (TcRef WantedConstraints) -- and type constraints here - -topStage, topAnnStage, topSpliceStage :: ThStage -topStage = Comp -topAnnStage = Splice Untyped -topSpliceStage = Splice Untyped - -instance Outputable ThStage where - ppr (Splice _) = text "Splice" - ppr (RunSplice _) = text "RunSplice" - ppr Comp = text "Comp" - ppr (Brack s _) = text "Brack" <> parens (ppr s) - -type ThLevel = Int - -- NB: see Note [Template Haskell levels] in TcSplice - -- Incremented when going inside a bracket, - -- decremented when going inside a splice - -- NB: ThLevel is one greater than the 'n' in Fig 2 of the - -- original "Template meta-programming for Haskell" paper - -impLevel, outerLevel :: ThLevel -impLevel = 0 -- Imported things; they can be used inside a top level splice -outerLevel = 1 -- Things defined outside brackets - -thLevel :: ThStage -> ThLevel -thLevel (Splice _) = 0 -thLevel (RunSplice _) = - -- See Note [RunSplice ThLevel]. - panic "thLevel: called when running a splice" -thLevel Comp = 1 -thLevel (Brack s _) = thLevel s + 1 - -{- Node [RunSplice ThLevel] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'RunSplice' stage is set when executing a splice, and only when running a -splice. In particular it is not set when the splice is renamed or typechecked. - -'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert -the finalizer (see Note [Delaying modFinalizers in untyped splices]), and -'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to -set 'RunSplice' when renaming or typechecking the splice, where 'Splice', -'Brack' or 'Comp' are used instead. - --} - ---------------------------- --- Arrow-notation context ---------------------------- - -{- Note [Escaping the arrow scope] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In arrow notation, a variable bound by a proc (or enclosed let/kappa) -is not in scope to the left of an arrow tail (-<) or the head of (|..|). -For example - - proc x -> (e1 -< e2) - -Here, x is not in scope in e1, but it is in scope in e2. This can get -a bit complicated: - - let x = 3 in - proc y -> (proc z -> e1) -< e2 - -Here, x and z are in scope in e1, but y is not. - -We implement this by -recording the environment when passing a proc (using newArrowScope), -and returning to that (using escapeArrowScope) on the left of -< and the -head of (|..|). - -All this can be dealt with by the *renamer*. But the type checker needs -to be involved too. Example (arrowfail001) - class Foo a where foo :: a -> () - data Bar = forall a. Foo a => Bar a - get :: Bar -> () - get = proc x -> case x of Bar a -> foo -< a -Here the call of 'foo' gives rise to a (Foo a) constraint that should not -be captured by the pattern match on 'Bar'. Rather it should join the -constraints from further out. So we must capture the constraint bag -from further out in the ArrowCtxt that we push inwards. --} - -data ArrowCtxt -- Note [Escaping the arrow scope] - = NoArrowCtxt - | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) - - ---------------------------- --- TcTyThing ---------------------------- - --- | A typecheckable thing available in a local context. Could be --- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. --- See 'TcEnv' for how to retrieve a 'TyThing' given a 'Name'. -data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup - - | ATcId -- Ids defined in this module; may not be fully zonked - { tct_id :: TcId - , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] - } - - | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] - - | ATcTyCon TyCon -- Used temporarily, during kind checking, for the - -- tycons and clases in this recursive group - -- The TyCon is always a TcTyCon. Its kind - -- can be a mono-kind or a poly-kind; in TcTyClsDcls see - -- Note [Type checking recursive type and class declarations] - - | APromotionErr PromotionErr - -data PromotionErr - = TyConPE -- TyCon used in a kind before we are ready - -- data T :: T -> * where ... - | ClassPE -- Ditto Class - - | FamDataConPE -- Data constructor for a data family - -- See Note [AFamDataCon: not promoting data family constructors] - -- in TcEnv. - | ConstrainedDataConPE PredType - -- Data constructor with a non-equality context - -- See Note [Don't promote data constructors with - -- non-equality contexts] in TcHsType - | PatSynPE -- Pattern synonyms - -- See Note [Don't promote pattern synonyms] in TcEnv - - | RecDataConPE -- Data constructor in a recursive loop - -- See Note [Recursion and promoting data constructors] in TcTyClsDecls - | NoDataKindsTC -- -XDataKinds not enabled (for a tycon) - | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) - -instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = ppr g - ppr elt@(ATcId {}) = text "Identifier" <> - brackets (ppr (tct_id elt) <> dcolon - <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_info elt)) - ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv - <+> dcolon <+> ppr (varType tv) - ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) - ppr (APromotionErr err) = text "APromotionErr" <+> ppr err - --- | IdBindingInfo describes how an Id is bound. --- --- It is used for the following purposes: --- a) for static forms in TcExpr.checkClosedInStaticForm and --- b) to figure out when a nested binding can be generalised, --- in TcBinds.decideGeneralisationPlan. --- -data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId] - = NotLetBound - | ClosedLet - | NonClosedLet - RhsNames -- Used for (static e) checks only - ClosedTypeId -- Used for generalisation checks - -- and for (static e) checks - --- | IsGroupClosed describes a group of mutually-recursive bindings -data IsGroupClosed - = IsGroupClosed - (NameEnv RhsNames) -- Free var info for the RHS of each binding in the goup - -- Used only for (static e) checks - - ClosedTypeId -- True <=> all the free vars of the group are - -- imported or ClosedLet or - -- NonClosedLet with ClosedTypeId=True. - -- In particular, no tyvars, no NotLetBound - -type RhsNames = NameSet -- Names of variables, mentioned on the RHS of - -- a definition, that are not Global or ClosedLet - -type ClosedTypeId = Bool - -- See Note [Meaning of IdBindingInfo and ClosedTypeId] - -{- Note [Meaning of IdBindingInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NotLetBound means that - the Id is not let-bound (e.g. it is bound in a - lambda-abstraction or in a case pattern) - -ClosedLet means that - - The Id is let-bound, - - Any free term variables are also Global or ClosedLet - - Its type has no free variables (NB: a top-level binding subject - to the MR might have free vars in its type) - These ClosedLets can definitely be floated to top level; and we - may need to do so for static forms. - - Property: ClosedLet - is equivalent to - NonClosedLet emptyNameSet True - -(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that - - The Id is let-bound - - - The fvs::RhsNames contains the free names of the RHS, - excluding Global and ClosedLet ones. - - - For the ClosedTypeId field see Note [Bindings with closed types] - -For (static e) to be valid, we need for every 'x' free in 'e', -that x's binding is floatable to the top level. Specifically: - * x's RhsNames must be empty - * x's type has no free variables -See Note [Grand plan for static forms] in StaticPtrTable.hs. -This test is made in TcExpr.checkClosedInStaticForm. -Actually knowing x's RhsNames (rather than just its emptiness -or otherwise) is just so we can produce better error messages - -Note [Bindings with closed types: ClosedTypeId] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - f x = let g ys = map not ys - in ... - -Can we generalise 'g' under the OutsideIn algorithm? Yes, -because all g's free variables are top-level; that is they themselves -have no free type variables, and it is the type variables in the -environment that makes things tricky for OutsideIn generalisation. - -Here's the invariant: - If an Id has ClosedTypeId=True (in its IdBindingInfo), then - the Id's type is /definitely/ closed (has no free type variables). - Specifically, - a) The Id's acutal type is closed (has no free tyvars) - b) Either the Id has a (closed) user-supplied type signature - or all its free variables are Global/ClosedLet - or NonClosedLet with ClosedTypeId=True. - In particular, none are NotLetBound. - -Why is (b) needed? Consider - \x. (x :: Int, let y = x+1 in ...) -Initially x::alpha. If we happen to typecheck the 'let' before the -(x::Int), y's type will have a free tyvar; but if the other way round -it won't. So we treat any let-bound variable with a free -non-let-bound variable as not ClosedTypeId, regardless of what the -free vars of its type actually are. - -But if it has a signature, all is well: - \x. ...(let { y::Int; y = x+1 } in - let { v = y+2 } in ...)... -Here the signature on 'v' makes 'y' a ClosedTypeId, so we can -generalise 'v'. - -Note that: - - * A top-level binding may not have ClosedTypeId=True, if it suffers - from the MR - - * A nested binding may be closed (eg 'g' in the example we started - with). Indeed, that's the point; whether a function is defined at - top level or nested is orthogonal to the question of whether or - not it is closed. - - * A binding may be non-closed because it mentions a lexically scoped - *type variable* Eg - f :: forall a. blah - f x = let g y = ...(y::a)... - -Under OutsideIn we are free to generalise an Id all of whose free -variables have ClosedTypeId=True (or imported). This is an extension -compared to the JFP paper on OutsideIn, which used "top-level" as a -proxy for "closed". (It's not a good proxy anyway -- the MR can make -a top-level binding with a free type variable.) - -Note [Type variables in the type environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type environment has a binding for each lexically-scoped -type variable that is in scope. For example - - f :: forall a. a -> a - f x = (x :: a) - - g1 :: [a] -> a - g1 (ys :: [b]) = head ys :: b - - g2 :: [Int] -> Int - g2 (ys :: [c]) = head ys :: c - -* The forall'd variable 'a' in the signature scopes over f's RHS. - -* The pattern-bound type variable 'b' in 'g1' scopes over g1's - RHS; note that it is bound to a skolem 'a' which is not itself - lexically in scope. - -* The pattern-bound type variable 'c' in 'g2' is bound to - Int; that is, pattern-bound type variables can stand for - arbitrary types. (see - GHC proposal #128 "Allow ScopedTypeVariables to refer to types" - https://github.com/ghc-proposals/ghc-proposals/pull/128, - and the paper - "Type variables in patterns", Haskell Symposium 2018. - - -This is implemented by the constructor - ATyVar Name TcTyVar -in the type environment. - -* The Name is the name of the original, lexically scoped type - variable - -* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes - a unification variable (like in 'g1', 'g2'). We never zonk the - type environment so in the latter case it always stays as a - unification variable, although that variable may be later - unified with a type (such as Int in 'g2'). --} - -instance Outputable IdBindingInfo where - ppr NotLetBound = text "NotLetBound" - ppr ClosedLet = text "TopLevelLet" - ppr (NonClosedLet fvs closed_type) = - text "TopLevelLet" <+> ppr fvs <+> ppr closed_type - -instance Outputable PromotionErr where - ppr ClassPE = text "ClassPE" - ppr TyConPE = text "TyConPE" - ppr PatSynPE = text "PatSynPE" - ppr FamDataConPE = text "FamDataConPE" - ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" - <+> parens (ppr pred) - ppr RecDataConPE = text "RecDataConPE" - ppr NoDataKindsTC = text "NoDataKindsTC" - ppr NoDataKindsDC = text "NoDataKindsDC" - -pprTcTyThingCategory :: TcTyThing -> SDoc -pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing -pprTcTyThingCategory (ATyVar {}) = text "Type variable" -pprTcTyThingCategory (ATcId {}) = text "Local identifier" -pprTcTyThingCategory (ATcTyCon {}) = text "Local tycon" -pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe - -pprPECategory :: PromotionErr -> SDoc -pprPECategory ClassPE = text "Class" -pprPECategory TyConPE = text "Type constructor" -pprPECategory PatSynPE = text "Pattern synonym" -pprPECategory FamDataConPE = text "Data constructor" -pprPECategory ConstrainedDataConPE{} = text "Data constructor" -pprPECategory RecDataConPE = text "Data constructor" -pprPECategory NoDataKindsTC = text "Type constructor" -pprPECategory NoDataKindsDC = text "Data constructor" - -{- -************************************************************************ -* * - Operations over ImportAvails -* * -************************************************************************ --} - --- | 'ImportAvails' summarises what was imported from where, irrespective of --- whether the imported things are actually used or not. It is used: --- --- * when processing the export list, --- --- * when constructing usage info for the interface file, --- --- * to identify the list of directly imported modules for initialisation --- purposes and for optimised overlap checking of family instances, --- --- * when figuring out what things are really unused --- -data ImportAvails - = ImportAvails { - imp_mods :: ImportedMods, - -- = ModuleEnv [ImportedModsVal], - -- ^ Domain is all directly-imported modules - -- - -- See the documentation on ImportedModsVal in HscTypes for the - -- meaning of the fields. - -- - -- We need a full ModuleEnv rather than a ModuleNameEnv here, - -- because we might be importing modules of the same name from - -- different packages. (currently not the case, but might be in the - -- future). - - imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), - -- ^ Home-package modules needed by the module being compiled - -- - -- It doesn't matter whether any of these dependencies - -- are actually /used/ when compiling the module; they - -- are listed if they are below it at all. For - -- example, suppose M imports A which imports X. Then - -- compiling M might not need to consult X.hi, but X - -- is still listed in M's dependencies. - - imp_dep_pkgs :: Set InstalledUnitId, - -- ^ Packages needed by the module being compiled, whether directly, - -- or via other modules in this package, or via modules imported - -- from other packages. - - imp_trust_pkgs :: Set InstalledUnitId, - -- ^ This is strictly a subset of imp_dep_pkgs and records the - -- packages the current module needs to trust for Safe Haskell - -- compilation to succeed. A package is required to be trusted if - -- we are dependent on a trustworthy module in that package. - -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool) - -- where True for the bool indicates the package is required to be - -- trusted is the more logical design, doing so complicates a lot - -- of code not concerned with Safe Haskell. - -- See Note [RnNames . Tracking Trust Transitively] - - imp_trust_own_pkg :: Bool, - -- ^ Do we require that our own package is trusted? - -- This is to handle efficiently the case where a Safe module imports - -- a Trustworthy module that resides in the same package as it. - -- See Note [RnNames . Trust Own Package] - - imp_orphs :: [Module], - -- ^ Orphan modules below us in the import tree (and maybe including - -- us for imported modules) - - imp_finsts :: [Module] - -- ^ Family instance modules below us in the import tree (and maybe - -- including us for imported modules) - } - -mkModDeps :: [(ModuleName, IsBootInterface)] - -> ModuleNameEnv (ModuleName, IsBootInterface) -mkModDeps deps = foldl' add emptyUFM deps - where - add env elt@(m,_) = addToUFM env m elt - -modDepsElts - :: ModuleNameEnv (ModuleName, IsBootInterface) - -> [(ModuleName, IsBootInterface)] -modDepsElts = sort . nonDetEltsUFM - -- It's OK to use nonDetEltsUFM here because sorting by module names - -- restores determinism - -emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_dep_mods = emptyUFM, - imp_dep_pkgs = S.empty, - imp_trust_pkgs = S.empty, - imp_trust_own_pkg = False, - imp_orphs = [], - imp_finsts = [] } - --- | Union two ImportAvails --- --- This function is a key part of Import handling, basically --- for each import we create a separate ImportAvails structure --- and then union them all together with this function. -plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails -plusImportAvails - (ImportAvails { imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, - imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, - imp_orphs = orphs1, imp_finsts = finsts1 }) - (ImportAvails { imp_mods = mods2, - imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, - imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, - imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, - imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, - imp_dep_pkgs = dpkgs1 `S.union` dpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, - imp_trust_own_pkg = tself1 || tself2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } - where - plus_mod_dep r1@(m1, boot1) r2@(m2, boot2) - | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) - boot1 = r2 - | otherwise = r1 - -- If either side can "see" a non-hi-boot interface, use that - -- Reusing existing tuples saves 10% of allocations on test - -- perf/compiler/MultiLayerModules - -{- -************************************************************************ -* * -\subsection{Where from} -* * -************************************************************************ - -The @WhereFrom@ type controls where the renamer looks for an interface file --} - -data WhereFrom - = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) - | ImportBySystem -- Non user import. - | ImportByPlugin -- Importing a plugin; - -- See Note [Care with plugin imports] in LoadIface - -instance Outputable WhereFrom where - ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}" - | otherwise = empty - ppr ImportBySystem = text "{- SYSTEM -}" - ppr ImportByPlugin = text "{- PLUGIN -}" - - -{- ********************************************************************* -* * - Type signatures -* * -********************************************************************* -} - --- These data types need to be here only because --- TcSimplify uses them, and TcSimplify is fairly --- low down in the module hierarchy - -type TcSigFun = Name -> Maybe TcSigInfo - -data TcSigInfo = TcIdSig TcIdSigInfo - | TcPatSynSig TcPatSynInfo - -data TcIdSigInfo -- See Note [Complete and partial type signatures] - = CompleteSig -- A complete signature with no wildcards, - -- so the complete polymorphic type is known. - { sig_bndr :: TcId -- The polymorphic Id with that type - - , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, - -- the Name in the FunSigCtxt is not the same - -- as the TcId; the former is 'op', while the - -- latter is '$dmop' or some such - - , sig_loc :: SrcSpan -- Location of the type signature - } - - | PartialSig -- A partial type signature (i.e. includes one or more - -- wildcards). In this case it doesn't make sense to give - -- the polymorphic Id, because we are going to /infer/ its - -- type, so we can't make the polymorphic Id ab-initio - { psig_name :: Name -- Name of the function; used when report wildcards - , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in - -- HsSyn form - , sig_ctxt :: UserTypeCtxt - , sig_loc :: SrcSpan -- Location of the type signature - } - - -{- Note [Complete and partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature is partial when it contains one or more wildcards -(= type holes). The wildcard can either be: -* A (type) wildcard occurring in sig_theta or sig_tau. These are - stored in sig_wcs. - f :: Bool -> _ - g :: Eq _a => _a -> _a -> Bool -* Or an extra-constraints wildcard, stored in sig_cts: - h :: (Num a, _) => a -> a - -A type signature is a complete type signature when there are no -wildcards in the type signature, i.e. iff sig_wcs is empty and -sig_extra_cts is Nothing. --} - -data TcIdSigInst - = TISI { sig_inst_sig :: TcIdSigInfo - - , sig_inst_skols :: [(Name, TcTyVar)] - -- Instantiated type and kind variables, TyVarTvs - -- The Name is the Name that the renamer chose; - -- but the TcTyVar may come from instantiating - -- the type and hence have a different unique. - -- No need to keep track of whether they are truly lexically - -- scoped because the renamer has named them uniquely - -- See Note [Binding scoped type variables] in TcSigs - -- - -- NB: The order of sig_inst_skols is irrelevant - -- for a CompleteSig, but for a PartialSig see - -- Note [Quantified varaibles in partial type signatures] - - , sig_inst_theta :: TcThetaType - -- Instantiated theta. In the case of a - -- PartialSig, sig_theta does not include - -- the extra-constraints wildcard - - , sig_inst_tau :: TcSigmaType -- Instantiated tau - -- See Note [sig_inst_tau may be polymorphic] - - -- Relevant for partial signature only - , sig_inst_wcs :: [(Name, TcTyVar)] - -- Like sig_inst_skols, but for /named/ wildcards (_a etc). - -- The named wildcards scope over the binding, and hence - -- their Names may appear in type signatures in the binding - - , sig_inst_wcx :: Maybe TcType - -- Extra-constraints wildcard to fill in, if any - -- If this exists, it is surely of the form (meta_tv |> co) - -- (where the co might be reflexive). This is filled in - -- only from the return value of TcHsType.tcAnonWildCardOcc - } - -{- Note [sig_inst_tau may be polymorphic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that "sig_inst_tau" might actually be a polymorphic type, -if the original function had a signature like - forall a. Eq a => forall b. Ord b => .... -But that's ok: tcMatchesFun (called by tcRhs) can deal with that -It happens, too! See Note [Polymorphic methods] in TcClassDcl. - -Note [Quantified varaibles in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a b. _ -> a -> _ -> b - f (x,y) p q = q - -Then we expect f's final type to be - f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b - -Note that x,y are Inferred, and can't be use for visible type -application (VTA). But a,b are Specified, and remain Specified -in the final type, so we can use VTA for them. (Exception: if -it turns out that a's kind mentions b we need to reorder them -with scopedSort.) - -The sig_inst_skols of the TISI from a partial signature records -that original order, and is used to get the variables of f's -final type in the correct order. - - -Note [Wildcards in partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wildcards in psig_wcs may stand for a type mentioning -the universally-quantified tyvars of psig_ty - -E.g. f :: forall a. _ -> a - f x = x -We get sig_inst_skols = [a] - sig_inst_tau = _22 -> a - sig_inst_wcs = [_22] -and _22 in the end is unified with the type 'a' - -Moreover the kind of a wildcard in sig_inst_wcs may mention -the universally-quantified tyvars sig_inst_skols -e.g. f :: t a -> t _ -Here we get - sig_inst_skols = [k:*, (t::k ->*), (a::k)] - sig_inst_tau = t a -> t _22 - sig_inst_wcs = [ _22::k ] --} - -data TcPatSynInfo - = TPSI { - patsig_name :: Name, - patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and - -- implicitly-bound type vars (Specified) - -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn - patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall - patsig_req :: TcThetaType, - patsig_ex_bndrs :: [TyVar], -- Bound by explicit user forall - patsig_prov :: TcThetaType, - patsig_body_ty :: TcSigmaType - } - -instance Outputable TcSigInfo where - ppr (TcIdSig idsi) = ppr idsi - ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi - -instance Outputable TcIdSigInfo where - ppr (CompleteSig { sig_bndr = bndr }) - = ppr bndr <+> dcolon <+> ppr (idType bndr) - ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty }) - = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty - -instance Outputable TcIdSigInst where - ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols - , sig_inst_theta = theta, sig_inst_tau = tau }) - = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) - -instance Outputable TcPatSynInfo where - ppr (TPSI{ patsig_name = name}) = ppr name - -isPartialSig :: TcIdSigInst -> Bool -isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True -isPartialSig _ = False - --- | No signature or a partial signature -hasCompleteSig :: TcSigFun -> Name -> Bool -hasCompleteSig sig_fn name - = case sig_fn name of - Just (TcIdSig (CompleteSig {})) -> True - _ -> False - - -{- -Constraint Solver Plugins -------------------------- --} - -type TcPluginSolver = [Ct] -- given - -> [Ct] -- derived - -> [Ct] -- wanted - -> TcPluginM TcPluginResult - -newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) deriving (Functor) - -instance Applicative TcPluginM where - pure x = TcPluginM (const $ pure x) - (<*>) = ap - -instance Monad TcPluginM where -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - TcPluginM m >>= k = - TcPluginM (\ ev -> do a <- m ev - runTcPluginM (k a) ev) - -instance MonadFail.MonadFail TcPluginM where - fail x = TcPluginM (const $ fail x) - -runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a -runTcPluginM (TcPluginM m) = m - --- | This function provides an escape for direct access to --- the 'TcM` monad. It should not be used lightly, and --- the provided 'TcPluginM' API should be favoured instead. -unsafeTcPluginTcM :: TcM a -> TcPluginM a -unsafeTcPluginTcM = TcPluginM . const - --- | Access the 'EvBindsVar' carried by the 'TcPluginM' during --- constraint solving. Returns 'Nothing' if invoked during --- 'tcPluginInit' or 'tcPluginStop'. -getEvBindsTcPluginM :: TcPluginM EvBindsVar -getEvBindsTcPluginM = TcPluginM return - - -data TcPlugin = forall s. TcPlugin - { tcPluginInit :: TcPluginM s - -- ^ Initialize plugin, when entering type-checker. - - , tcPluginSolve :: s -> TcPluginSolver - -- ^ Solve some constraints. - -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS. - - , tcPluginStop :: s -> TcPluginM () - -- ^ Clean up after the plugin, when exiting the type-checker. - } - -data TcPluginResult - = TcPluginContradiction [Ct] - -- ^ The plugin found a contradiction. - -- The returned constraints are removed from the inert set, - -- and recorded as insoluble. - - | TcPluginOk [(EvTerm,Ct)] [Ct] - -- ^ The first field is for constraints that were solved. - -- These are removed from the inert set, - -- and the evidence for them is recorded. - -- The second field contains new work, that should be processed by - -- the constraint solver. - -{- ********************************************************************* -* * - Role annotations -* * -********************************************************************* -} - -type RoleAnnotEnv = NameEnv (LRoleAnnotDecl GhcRn) - -mkRoleAnnotEnv :: [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv -mkRoleAnnotEnv role_annot_decls - = mkNameEnv [ (name, ra_decl) - | ra_decl <- role_annot_decls - , let name = roleAnnotDeclName (unLoc ra_decl) - , not (isUnboundName name) ] - -- Some of the role annots will be unbound; - -- we don't wish to include these - -emptyRoleAnnotEnv :: RoleAnnotEnv -emptyRoleAnnotEnv = emptyNameEnv - -lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) -lookupRoleAnnot = lookupNameEnv - -getRoleAnnots :: [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn] -getRoleAnnots bndrs role_env - = mapMaybe (lookupRoleAnnot role_env) bndrs diff --git a/typecheck/TcRnTypes.hs-boot b/typecheck/TcRnTypes.hs-boot deleted file mode 100644 --- a/typecheck/TcRnTypes.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module TcRnTypes where - -import TcType -import SrcLoc - -data TcLclEnv - -setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv -getLclEnvTcLevel :: TcLclEnv -> TcLevel - -setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv -getLclEnvLoc :: TcLclEnv -> RealSrcSpan diff --git a/typecheck/TcRules.hs b/typecheck/TcRules.hs deleted file mode 100644 --- a/typecheck/TcRules.hs +++ /dev/null @@ -1,465 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - - -TcRules: Typechecking transformation rules --} - -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module TcRules ( tcRules ) where - -import GhcPrelude - -import GHC.Hs -import TcRnTypes -import TcRnMonad -import TcSimplify -import Constraint -import Predicate -import TcOrigin -import TcMType -import TcType -import TcHsType -import TcExpr -import TcEnv -import TcUnify( buildImplicationFor ) -import TcEvidence( mkTcCoVarCo ) -import Type -import TyCon( isTypeFamilyTyCon ) -import Id -import Var( EvVar ) -import VarSet -import BasicTypes ( RuleName ) -import SrcLoc -import Outputable -import FastString -import Bag - -{- -Note [Typechecking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We *infer* the typ of the LHS, and use that type to *check* the type of -the RHS. That means that higher-rank rules work reasonably well. Here's -an example (test simplCore/should_compile/rule2.hs) produced by Roman: - - foo :: (forall m. m a -> m b) -> m a -> m b - foo f = ... - - bar :: (forall m. m a -> m a) -> m a -> m a - bar f = ... - - {-# RULES "foo/bar" foo = bar #-} - -He wanted the rule to typecheck. - -Note [TcLevel in type checking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Bringing type variables into scope naturally bumps the TcLevel. Thus, we type -check the term-level binders in a bumped level, and we must accordingly bump -the level whenever these binders are in scope. --} - -tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId] -tcRules decls = mapM (wrapLocM tcRuleDecls) decls - -tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId) -tcRuleDecls (HsRules { rds_src = src - , rds_rules = decls }) - = do { tc_decls <- mapM (wrapLocM tcRule) decls - ; return $ HsRules { rds_ext = noExtField - , rds_src = src - , rds_rules = tc_decls } } -tcRuleDecls (XRuleDecls nec) = noExtCon nec - -tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) -tcRule (HsRule { rd_ext = ext - , rd_name = rname@(L _ (_,name)) - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs }) - = addErrCtxt (ruleCtxt name) $ - do { traceTc "---- Rule ------" (pprFullRuleName rname) - - -- Note [Typechecking rules] - ; (tc_lvl, stuff) <- pushTcLevelM $ - generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - - ; let (tv_bndrs, id_bndrs, lhs', lhs_wanted - , rhs', rhs_wanted, rule_ty) = stuff - - ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname - , ppr lhs_wanted - , ppr rhs_wanted ]) - - ; (lhs_evs, residual_lhs_wanted) - <- simplifyRule name tc_lvl lhs_wanted rhs_wanted - - -- SimplfyRule Plan, step 4 - -- Now figure out what to quantify over - -- c.f. TcSimplify.simplifyInfer - -- We quantify over any tyvars free in *either* the rule - -- *or* the bound variables. The latter is important. Consider - -- ss (x,(y,z)) = (x,z) - -- RULE: forall v. fst (ss v) = fst v - -- The type of the rhs of the rule is just a, but v::(a,(b,c)) - -- - -- We also need to get the completely-uconstrained tyvars of - -- the LHS, lest they otherwise get defaulted to Any; but we do that - -- during zonking (see TcHsSyn.zonkRule) - - ; let tpl_ids = lhs_evs ++ id_bndrs - ; forall_tkvs <- candidateQTyVarsOfTypes $ - map (mkSpecForAllTys tv_bndrs) $ -- don't quantify over lexical tyvars - rule_ty : map idType tpl_ids - ; qtkvs <- quantifyTyVars forall_tkvs - ; traceTc "tcRule" (vcat [ pprFullRuleName rname - , ppr forall_tkvs - , ppr qtkvs - , ppr tv_bndrs - , ppr rule_ty - , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] - ]) - - -- SimplfyRule Plan, step 5 - -- Simplify the LHS and RHS constraints: - -- For the LHS constraints we must solve the remaining constraints - -- (a) so that we report insoluble ones - -- (b) so that we bind any soluble ones - ; let all_qtkvs = qtkvs ++ tv_bndrs - skol_info = RuleSkol name - ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs - lhs_evs residual_lhs_wanted - ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs - lhs_evs rhs_wanted - - ; emitImplications (lhs_implic `unionBags` rhs_implic) - ; return $ HsRule { rd_ext = ext - , rd_name = rname - , rd_act = act - , rd_tyvs = ty_bndrs -- preserved for ppr-ing - , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc) - (all_qtkvs ++ tpl_ids) - , rd_lhs = mkHsDictLet lhs_binds lhs' - , rd_rhs = mkHsDictLet rhs_binds rhs' } } -tcRule (XRuleDecl nec) = noExtCon nec - -generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] - -> LHsExpr GhcRn -> LHsExpr GhcRn - -> TcM ( [TyVar] - , [TcId] - , LHsExpr GhcTc, WantedConstraints - , LHsExpr GhcTc, WantedConstraints - , TcType ) -generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ - tcRuleBndrs ty_bndrs tm_bndrs - -- bndr_wanted constraints can include wildcard hole - -- constraints, which we should not forget about. - -- It may mention the skolem type variables bound by - -- the RULE. c.f. #10072 - - ; tcExtendTyVarEnv tv_bndrs $ - tcExtendIdEnv id_bndrs $ - do { -- See Note [Solve order for RULES] - ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) - ; (rhs', rhs_wanted) <- captureConstraints $ - tcMonoExpr rhs (mkCheckExpType rule_ty) - ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted - ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } - --- See Note [TcLevel in type checking rules] -tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] - -> TcM ([TcTyVar], [Id]) -tcRuleBndrs (Just bndrs) xs - = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ - tcRuleTmBndrs xs - ; return (tys1 ++ tys2, tms) } - -tcRuleBndrs Nothing xs - = tcRuleTmBndrs xs - --- See Note [TcLevel in type checking rules] -tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) -tcRuleTmBndrs [] = return ([],[]) -tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) - = do { ty <- newOpenFlexiTyVarTy - ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs - ; return (tyvars, mkLocalId name ty : tmvars) } -tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) --- e.g x :: a->a --- The tyvar 'a' is brought into scope first, just as if you'd written --- a::*, x :: a->a --- If there's an explicit forall, the renamer would have already reported an --- error for each out-of-scope type variable used - = do { let ctxt = RuleSigCtxt name - ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalIdOrCoVar name id_ty - -- See Note [Pattern signature binders] in TcHsType - - -- The type variables scope over subsequent bindings; yuk - ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ - tcRuleTmBndrs rule_bndrs - ; return (map snd tvs ++ tyvars, id : tmvars) } -tcRuleTmBndrs (L _ (XRuleBndr nec) : _) = noExtCon nec - -ruleCtxt :: FastString -> SDoc -ruleCtxt name = text "When checking the transformation rule" <+> - doubleQuotes (ftext name) - - -{- -********************************************************************************* -* * - Constraint simplification for rules -* * -*********************************************************************************** - -Note [The SimplifyRule Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example. Consider the following left-hand side of a rule - f (x == y) (y > z) = ... -If we typecheck this expression we get constraints - d1 :: Ord a, d2 :: Eq a -We do NOT want to "simplify" to the LHS - forall x::a, y::a, z::a, d1::Ord a. - f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... -Instead we want - forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. - f ((==) d2 x y) ((>) d1 y z) = ... - -Here is another example: - fromIntegral :: (Integral a, Num b) => a -> b - {-# RULES "foo" fromIntegral = id :: Int -> Int #-} -In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But -we *dont* want to get - forall dIntegralInt. - fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int -because the scsel will mess up RULE matching. Instead we want - forall dIntegralInt, dNumInt. - fromIntegral Int Int dIntegralInt dNumInt = id Int - -Even if we have - g (x == y) (y == z) = .. -where the two dictionaries are *identical*, we do NOT WANT - forall x::a, y::a, z::a, d1::Eq a - f ((==) d1 x y) ((>) d1 y z) = ... -because that will only match if the dict args are (visibly) equal. -Instead we want to quantify over the dictionaries separately. - -In short, simplifyRuleLhs must *only* squash equalities, leaving -all dicts unchanged, with absolutely no sharing. - -Also note that we can't solve the LHS constraints in isolation: -Example foo :: Ord a => a -> a - foo_spec :: Int -> Int - {-# RULE "foo" foo = foo_spec #-} -Here, it's the RHS that fixes the type variable - -HOWEVER, under a nested implication things are different -Consider - f :: (forall a. Eq a => a->a) -> Bool -> ... - {-# RULES "foo" forall (v::forall b. Eq b => b->b). - f b True = ... - #-} -Here we *must* solve the wanted (Eq a) from the given (Eq a) -resulting from skolemising the argument type of g. So we -revert to SimplCheck when going under an implication. - - ---------- So the SimplifyRule Plan is this ----------------------- - -* Step 0: typecheck the LHS and RHS to get constraints from each - -* Step 1: Simplify the LHS and RHS constraints all together in one bag - We do this to discover all unification equalities - -* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take - advantage of those unifications - -* Setp 3: Partition the LHS constraints into the ones we will - quantify over, and the others. - See Note [RULE quantification over equalities] - -* Step 4: Decide on the type variables to quantify over - -* Step 5: Simplify the LHS and RHS constraints separately, using the - quantified constraints as givens - -Note [Solve order for RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step 1 above, we need to be a bit careful about solve order. -Consider - f :: Int -> T Int - type instance T Int = Bool - - RULE f 3 = True - -From the RULE we get - lhs-constraints: T Int ~ alpha - rhs-constraints: Bool ~ alpha -where 'alpha' is the type that connects the two. If we glom them -all together, and solve the RHS constraint first, we might solve -with alpha := Bool. But then we'd end up with a RULE like - - RULE: f 3 |> (co :: T Int ~ Bool) = True - -which is terrible. We want - - RULE: f 3 = True |> (sym co :: Bool ~ T Int) - -So we are careful to solve the LHS constraints first, and *then* the -RHS constraints. Actually much of this is done by the on-the-fly -constraint solving, so the same order must be observed in -tcRule. - - -Note [RULE quantification over equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deciding which equalities to quantify over is tricky: - * We do not want to quantify over insoluble equalities (Int ~ Bool) - (a) because we prefer to report a LHS type error - (b) because if such things end up in 'givens' we get a bogus - "inaccessible code" error - - * But we do want to quantify over things like (a ~ F b), where - F is a type function. - -The difficulty is that it's hard to tell what is insoluble! -So we see whether the simplification step yielded any type errors, -and if so refrain from quantifying over *any* equalities. - -Note [Quantifying over coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Equality constraints from the LHS will emit coercion hole Wanteds. -These don't have a name, so we can't quantify over them directly. -Instead, because we really do want to quantify here, invent a new -EvVar for the coercion, fill the hole with the invented EvVar, and -then quantify over the EvVar. Not too tricky -- just some -impedance matching, really. - -Note [Simplify cloned constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this stage, we're simplifying constraints only for insolubility -and for unification. Note that all the evidence is quickly discarded. -We use a clone of the real constraint. If we don't do this, -then RHS coercion-hole constraints get filled in, only to get filled -in *again* when solving the implications emitted from tcRule. That's -terrible, so we avoid the problem by cloning the constraints. - --} - -simplifyRule :: RuleName - -> TcLevel -- Level at which to solve the constraints - -> WantedConstraints -- Constraints from LHS - -> WantedConstraints -- Constraints from RHS - -> TcM ( [EvVar] -- Quantify over these LHS vars - , WantedConstraints) -- Residual un-quantified LHS constraints --- See Note [The SimplifyRule Plan] --- NB: This consumes all simple constraints on the LHS, but not --- any LHS implication constraints. -simplifyRule name tc_lvl lhs_wanted rhs_wanted - = do { - -- Note [The SimplifyRule Plan] step 1 - -- First solve the LHS and *then* solve the RHS - -- Crucially, this performs unifications - -- Why clone? See Note [Simplify cloned constraints] - ; lhs_clone <- cloneWC lhs_wanted - ; rhs_clone <- cloneWC rhs_wanted - ; setTcLevel tc_lvl $ - runTcSDeriveds $ - do { _ <- solveWanteds lhs_clone - ; _ <- solveWanteds rhs_clone - -- Why do them separately? - -- See Note [Solve order for RULES] - ; return () } - - -- Note [The SimplifyRule Plan] step 2 - ; lhs_wanted <- zonkWC lhs_wanted - ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted - - -- Note [The SimplifyRule Plan] step 3 - ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts) - - ; traceTc "simplifyRule" $ - vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) - , text "lhs_wanted" <+> ppr lhs_wanted - , text "rhs_wanted" <+> ppr rhs_wanted - , text "quant_cts" <+> ppr quant_cts - , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted - ] - - ; return (quant_evs, residual_lhs_wanted) } - - where - mk_quant_ev :: Ct -> TcM EvVar - mk_quant_ev ct - | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct - = case dest of - EvVarDest ev_id -> return ev_id - HoleDest hole -> -- See Note [Quantifying over coercion holes] - do { ev_id <- newEvVar pred - ; fillCoercionHole hole (mkTcCoVarCo ev_id) - ; return ev_id } - mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) - - -getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints) --- Extract all the constraints we can quantify over, --- also returning the depleted WantedConstraints --- --- NB: we must look inside implications, because with --- -fdefer-type-errors we generate implications rather eagerly; --- see TcUnify.implicationNeeded. Not doing so caused #14732. --- --- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, --- and attempt to solve them from the quantified constraints. That --- nearly works, but fails for a constraint like (d :: Eq Int). --- We /do/ want to quantify over it, but the short-cut solver --- (see TcInteract Note [Shortcut solving]) ignores the quantified --- and instead solves from the top level. --- --- So we must partition the WantedConstraints ourselves --- Not hard, but tiresome. - -getRuleQuantCts wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) - float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics }) - = ( simple_yes `andCts` implic_yes - , WC { wc_simple = simple_no, wc_impl = implics_no }) - where - (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples - (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) - emptyBag implics - - float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) - float_implic skol_tvs yes1 imp - = (yes1 `andCts` yes2, imp { ic_wanted = no }) - where - (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) - new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp - - rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool - rule_quant_ct skol_tvs ct - | EqPred _ t1 t2 <- classifyPredType (ctPred ct) - , not (ok_eq t1 t2) - = False -- Note [RULE quantification over equalities] - | isHoleCt ct - = False -- Don't quantify over type holes, obviously - | otherwise - = tyCoVarsOfCt ct `disjointVarSet` skol_tvs - - ok_eq t1 t2 - | t1 `tcEqType` t2 = False - | otherwise = is_fun_app t1 || is_fun_app t2 - - is_fun_app ty -- ty is of form (F tys) where F is a type function - = case tyConAppTyCon_maybe ty of - Just tc -> isTypeFamilyTyCon tc - Nothing -> False diff --git a/typecheck/TcSMonad.hs b/typecheck/TcSMonad.hs deleted file mode 100644 --- a/typecheck/TcSMonad.hs +++ /dev/null @@ -1,3566 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} - --- Type definitions for the constraint solver -module TcSMonad ( - - -- The work list - WorkList(..), isEmptyWorkList, emptyWorkList, - extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListEq, extendWorkListFunEq, - appendWorkList, - selectNextWorkItem, - workListSize, workListWantedCount, - getWorkList, updWorkListTcS, pushLevelNoWorkList, - - -- The TcS monad - TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, - failTcS, warnTcS, addErrTcS, - runTcSEqualities, - nestTcS, nestImplicTcS, setEvBindsTcS, - emitImplicationTcS, emitTvImplicationTcS, - - runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive, - matchGlobalInst, TcM.ClsInstResult(..), - - QCInst(..), - - -- Tracing etc - panicTcS, traceTcS, - traceFireTcS, bumpStepCountTcS, csTraceTcS, - wrapErrTcS, wrapWarnTcS, - - -- Evidence creation and transformation - MaybeNew(..), freshGoals, isFresh, getEvExpr, - - newTcEvBinds, newNoTcEvBinds, - newWantedEq, newWantedEq_SI, emitNewWantedEq, - newWanted, newWanted_SI, newWantedEvVar, - newWantedNC, newWantedEvVarNC, - newDerivedNC, - newBoundEvVarId, - unifyTyVar, unflattenFmv, reportUnifications, - setEvBind, setWantedEq, - setWantedEvTerm, setEvBindIfWanted, - newEvVar, newGivenEvVar, newGivenEvVars, - emitNewDeriveds, emitNewDerivedEq, - checkReductionDepth, - getSolvedDicts, setSolvedDicts, - - getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, - getTcEvBindsVar, getTcLevel, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - tcLookupClass, tcLookupId, - - -- Inerts - InertSet(..), InertCans(..), - updInertTcS, updInertCans, updInertDicts, updInertIrreds, - getNoGivenEqs, setInertCans, - getInertEqs, getInertCans, getInertGivens, - getInertInsols, - getTcSInerts, setTcSInerts, - matchableGivens, prohibitedSuperClassSolve, mightMatchLater, - getUnsolvedInerts, - removeInertCts, getPendingGivenScs, - addInertCan, insertFunEq, addInertForAll, - emitWorkNC, emitWork, - isImprovable, - - -- The Model - kickOutAfterUnification, - - -- Inert Safe Haskell safe-overlap failures - addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, - getSafeOverlapFailures, - - -- Inert CDictCans - DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict, - addDictsByClass, delDict, foldDicts, filterDicts, findDict, - - -- Inert CTyEqCans - EqualCtList, findTyEqs, foldTyEqs, isInInertEqs, - lookupInertTyVar, - - -- Inert solved dictionaries - addSolvedDict, lookupSolvedDict, - - -- Irreds - foldIrreds, - - -- The flattening cache - lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems - dischargeFunEq, pprKicked, - - -- Inert CFunEqCans - updInertFunEqs, findFunEq, - findFunEqsByTyCon, - - instDFunType, -- Instantiation - - -- MetaTyVars - newFlexiTcSTy, instFlexi, instFlexiX, - cloneMetaTyVar, demoteUnfilledFmv, - tcInstSkolTyVarsX, - - TcLevel, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, - zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, - zonkTyCoVarsAndFVList, - zonkSimples, zonkWC, - zonkTyCoVarKind, - - -- References - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- Misc - getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, - matchFam, matchFamTcM, - checkWellStagedDFun, - pprEq -- Smaller utils, re-exported from TcM - -- TODO (DV): these are only really used in the - -- instance matcher in TcSimplify. I am wondering - -- if the whole instance matcher simply belongs - -- here -) where - -#include "HsVersions.h" - -import GhcPrelude - -import HscTypes - -import qualified Inst as TcM -import InstEnv -import FamInst -import FamInstEnv - -import qualified TcRnMonad as TcM -import qualified TcMType as TcM -import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) ) -import qualified TcEnv as TcM - ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) -import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) -import TcType -import DynFlags -import Type -import Coercion -import Unify - -import TcEvidence -import Class -import TyCon -import TcErrors ( solverDepthErrorTcS ) - -import Name -import Module ( HasModule, getModule ) -import RdrName ( GlobalRdrEnv, GlobalRdrElt ) -import qualified RnEnv as TcM -import Var -import VarEnv -import VarSet -import Outputable -import Bag -import UniqSupply -import Util -import TcRnTypes -import TcOrigin -import Constraint -import Predicate - -import Unique -import UniqFM -import UniqDFM -import Maybes - -import CoreMap -import Control.Monad -import qualified Control.Monad.Fail as MonadFail -import MonadUtils -import Data.IORef -import Data.List ( partition, mapAccumL ) - -#if defined(DEBUG) -import Digraph -import UniqSet -#endif - -{- -************************************************************************ -* * -* Worklists * -* Canonical and non-canonical constraints that the simplifier has to * -* work on. Including their simplification depths. * -* * -* * -************************************************************************ - -Note [WorkList priorities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavors). -Notice that each Ct now has a simplification depth. We may -consider using this depth for prioritization as well in the future. - -As a simple form of priority queue, our worklist separates out - -* equalities (wl_eqs); see Note [Prioritise equalities] -* type-function equalities (wl_funeqs) -* all the rest (wl_rest) - -Note [Prioritise equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to process equalities /first/: - -* (Efficiency) The general reason to do so is that if we process a - class constraint first, we may end up putting it into the inert set - and then kicking it out later. That's extra work compared to just - doing the equality first. - -* (Avoiding fundep iteration) As #14723 showed, it's possible to - get non-termination if we - - Emit the Derived fundep equalities for a class constraint, - generating some fresh unification variables. - - That leads to some unification - - Which kicks out the class constraint - - Which isn't solved (because there are still some more Derived - equalities in the work-list), but generates yet more fundeps - Solution: prioritise derived equalities over class constraints - -* (Class equalities) We need to prioritise equalities even if they - are hidden inside a class constraint; - see Note [Prioritise class equalities] - -* (Kick-out) We want to apply this priority scheme to kicked-out - constraints too (see the call to extendWorkListCt in kick_out_rewritable - E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become - homo-kinded when kicked out, and hence we want to prioritise it. - -* (Derived equalities) Originally we tried to postpone processing - Derived equalities, in the hope that we might never need to deal - with them at all; but in fact we must process Derived equalities - eagerly, partly for the (Efficiency) reason, and more importantly - for (Avoiding fundep iteration). - -Note [Prioritise class equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prioritise equalities in the solver (see selectWorkItem). But class -constraints like (a ~ b) and (a ~~ b) are actually equalities too; -see Note [The equality types story] in TysPrim. - -Failing to prioritise these is inefficient (more kick-outs etc). -But, worse, it can prevent us spotting a "recursive knot" among -Wanted constraints. See comment:10 of #12734 for a worked-out -example. - -So we arrange to put these particular class constraints in the wl_eqs. - - NB: since we do not currently apply the substitution to the - inert_solved_dicts, the knot-tying still seems a bit fragile. - But this makes it better. - --} - --- See Note [WorkList priorities] -data WorkList - = WL { wl_eqs :: [Ct] -- CTyEqCan, CDictCan, CIrredCan - -- Given, Wanted, and Derived - -- Contains both equality constraints and their - -- class-level variants (a~b) and (a~~b); - -- See Note [Prioritise equalities] - -- See Note [Prioritise class equalities] - - , wl_funeqs :: [Ct] - - , wl_rest :: [Ct] - - , wl_implics :: Bag Implication -- See Note [Residual implications] - } - -appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList - (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1 - , wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2 - , wl_implics = implics2 }) - = WL { wl_eqs = eqs1 ++ eqs2 - , wl_funeqs = funeqs1 ++ funeqs2 - , wl_rest = rest1 ++ rest2 - , wl_implics = implics1 `unionBags` implics2 } - -workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) - = length eqs + length funeqs + length rest - -workListWantedCount :: WorkList -> Int --- Count the things we need to solve --- excluding the insolubles (c.f. inert_count) -workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest }) - = count isWantedCt eqs + count is_wanted rest - where - is_wanted ct - | CIrredCan { cc_ev = ev, cc_insol = insol } <- ct - = not insol && isWanted ev - | otherwise - = isWantedCt ct - -extendWorkListEq :: Ct -> WorkList -> WorkList -extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } - -extendWorkListFunEq :: Ct -> WorkList -> WorkList -extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl } - -extendWorkListNonEq :: Ct -> WorkList -> WorkList --- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } - -extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList -extendWorkListDeriveds evs wl - = extendWorkListCts (map mkNonCanonical evs) wl - -extendWorkListImplic :: Implication -> WorkList -> WorkList -extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } - -extendWorkListCt :: Ct -> WorkList -> WorkList --- Agnostic -extendWorkListCt ct wl - = case classifyPredType (ctPred ct) of - EqPred NomEq ty1 _ - | Just tc <- tcTyConAppTyCon_maybe ty1 - , isTypeFamilyTyCon tc - -> extendWorkListFunEq ct wl - - EqPred {} - -> extendWorkListEq ct wl - - ClassPred cls _ -- See Note [Prioritise class equalities] - | isEqPredClass cls - -> extendWorkListEq ct wl - - _ -> extendWorkListNonEq ct wl - -extendWorkListCts :: [Ct] -> WorkList -> WorkList --- Agnostic -extendWorkListCts cts wl = foldr extendWorkListCt wl cts - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs - , wl_rest = rest, wl_implics = implics }) - = null eqs && null rest && null funeqs && isEmptyBag implics - -emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rest = [] - , wl_funeqs = [], wl_implics = emptyBag } - -selectWorkItem :: WorkList -> Maybe (Ct, WorkList) --- See Note [Prioritise equalities] -selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest }) - | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes }) - | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) - | otherwise = Nothing - -getWorkList :: TcS WorkList -getWorkList = do { wl_var <- getTcSWorkListRef - ; wrapTcS (TcM.readTcRef wl_var) } - -selectNextWorkItem :: TcS (Maybe Ct) --- Pick which work item to do next --- See Note [Prioritise equalities] -selectNextWorkItem - = do { wl_var <- getTcSWorkListRef - ; wl <- readTcRef wl_var - ; case selectWorkItem wl of { - Nothing -> return Nothing ; - Just (ct, new_wl) -> - do { -- checkReductionDepth (ctLoc ct) (ctPred ct) - -- This is done by TcInteract.chooseInstance - ; writeTcRef wl_var new_wl - ; return (Just ct) } } } - --- Pretty printing -instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest, wl_implics = implics }) - = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ - text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null feqs) $ - text "Funeqs =" <+> vcat (map ppr feqs) - , ppUnless (null rest) $ - text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (isEmptyBag implics) $ - ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) - (text "(Implics omitted)") - ]) - - -{- ********************************************************************* -* * - InertSet: the inert set -* * -* * -********************************************************************* -} - -data InertSet - = IS { inert_cans :: InertCans - -- Canonical Given, Wanted, Derived - -- Sometimes called "the inert set" - - , inert_fsks :: [(TcTyVar, TcType)] - -- A list of (fsk, ty) pairs; we add one element when we flatten - -- a function application in a Given constraint, creating - -- a new fsk in newFlattenSkolem. When leaving a nested scope, - -- unflattenGivens unifies fsk := ty - -- - -- We could also get this info from inert_funeqs, filtered by - -- level, but it seems simpler and more direct to capture the - -- fsk as we generate them. - - , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) - -- See Note [Type family equations] - -- If F tys :-> (co, rhs, flav), - -- then co :: F tys ~ rhs - -- flav is [G] or [WD] - -- - -- Just a hash-cons cache for use when flattening only - -- These include entirely un-processed goals, so don't use - -- them to solve a top-level goal, else you may end up solving - -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache - -- when allocating a new flatten-skolem. - -- Not necessarily inert wrt top-level equations (or inert_cans) - - -- NB: An ExactFunEqMap -- this doesn't match via loose types! - - , inert_solved_dicts :: DictMap CtEvidence - -- All Wanteds, of form ev :: C t1 .. tn - -- See Note [Solved dictionaries] - -- and Note [Do not add superclasses of solved dictionaries] - } - -instance Outputable InertSet where - ppr (IS { inert_cans = ics - , inert_fsks = ifsks - , inert_solved_dicts = solved_dicts }) - = vcat [ ppr ics - , text "Inert fsks =" <+> ppr ifsks - , ppUnless (null dicts) $ - text "Solved dicts =" <+> vcat (map ppr dicts) ] - where - dicts = bagToList (dictsToBag solved_dicts) - -emptyInertCans :: InertCans -emptyInertCans - = IC { inert_count = 0 - , inert_eqs = emptyDVarEnv - , inert_dicts = emptyDicts - , inert_safehask = emptyDicts - , inert_funeqs = emptyFunEqs - , inert_insts = [] - , inert_irreds = emptyCts } - -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans - , inert_fsks = [] - , inert_flat_cache = emptyExactFunEqs - , inert_solved_dicts = emptyDictMap } - - -{- Note [Solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we apply a top-level instance declaration, we add the "solved" -dictionary to the inert_solved_dicts. In general, we use it to avoid -creating a new EvVar when we have a new goal that we have solved in -the past. - -But in particular, we can use it to create *recursive* dictionaries. -The simplest, degnerate case is - instance C [a] => C [a] where ... -If we have - [W] d1 :: C [x] -then we can apply the instance to get - d1 = $dfCList d - [W] d2 :: C [x] -Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. - d1 = $dfCList d - d2 = d1 - -See Note [Example of recursive dictionaries] - -VERY IMPORTANT INVARIANT: - - (Solved Dictionary Invariant) - Every member of the inert_solved_dicts is the result - of applying an instance declaration that "takes a step" - - An instance "takes a step" if it has the form - dfunDList d1 d2 = MkD (...) (...) (...) - That is, the dfun is lazy in its arguments, and guarantees to - immediately return a dictionary constructor. NB: all dictionary - data constructors are lazy in their arguments. - - This property is crucial to ensure that all dictionaries are - non-bottom, which in turn ensures that the whole "recursive - dictionary" idea works at all, even if we get something like - rec { d = dfunDList d dx } - See Note [Recursive superclasses] in TcInstDcls. - - Reason: - - All instances, except two exceptions listed below, "take a step" - in the above sense - - - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when appling a quantified - constraint led to the ability to define unsafeCoerce - in #17267. - - - Exception 2: the magic built-in instace for (~) has no - such guarantee. It behaves as if we had - class (a ~# b) => (a ~ b) where {} - instance (a ~# b) => (a ~ b) where {} - The "dfun" for the instance is strict in the coercion. - Anyway there's no point in recording a "solved dict" for - (t1 ~ t2); it's not going to allow a recursive dictionary - to be constructed. Ditto (~~) and Coercible. - -THEREFORE we only add a "solved dictionary" - - when applying an instance declaration - - subject to Exceptions 1 and 2 above - -In implementation terms - - TcSMonad.addSolvedDict adds a new solved dictionary, - conditional on the kind of instance - - - It is only called when applying an instance decl, - in TcInteract.doTopReactDict - - - ClsInst.InstanceWhat says what kind of instance was - used to solve the constraint. In particular - * LocalInstance identifies quantified constraints - * BuiltinEqInstance identifies the strange built-in - instances for equality. - - - ClsInst.instanceReturnsDictCon says which kind of - instance guarantees to return a dictionary constructor - -Other notes about solved dictionaries - -* See also Note [Do not add superclasses of solved dictionaries] - -* The inert_solved_dicts field is not rewritten by equalities, - so it may get out of date. - -* The inert_solved_dicts are all Wanteds, never givens - -* We only cache dictionaries from top-level instances, not from - local quantified constraints. Reason: if we cached the latter - we'd need to purge the cache when bringing new quantified - constraints into scope, because quantified constraints "shadow" - top-level instances. - -Note [Do not add superclasses of solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every member of inert_solved_dicts is the result of applying a -dictionary function, NOT of applying superclass selection to anything. -Consider - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Suppose we are trying to solve - [G] d1 : Ord a - [W] d2 : C [a] - -Then we'll use the instance decl to give - - [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 - [W] d3 : Ord [a] - -We must not add d4 : Ord [a] to the 'solved' set (by taking the -superclass of d2), otherwise we'll use it to solve d3, without ever -using d1, which would be a catastrophe. - -Solution: when extending the solved dictionaries, do not add superclasses. -That's why each element of the inert_solved_dicts is the result of applying -a dictionary function. - -Note [Example of recursive dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ---- Example 1 - - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - [W] d1 : Eq (D []) -By instance decl of Eq (D r): - [W] d2 : Eq [D []] where d1 = dfEqD d2 -By instance decl of Eq [a]: - [W] d3 : Eq (D []) where d2 = dfEqList d3 - d1 = dfEqD d2 -Now this wanted can interact with our "solved" d1 to get: - d3 = d1 - --- Example 2: -This code arises in the context of "Scrap Your Boilerplate with Class" - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char -- dfunData1 - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) -- dfunSat - - instance Data Maybe a => Foo a -- dfunFoo1 - instance Foo a => Foo [a] -- dfunFoo2 - instance Foo [Char] -- dfunFoo3 - -Consider generating the superclasses of the instance declaration - instance Foo a => Foo [a] - -So our problem is this - [G] d0 : Foo t - [W] d1 : Data Maybe [t] -- Desired superclass - -We may add the given in the inert set, along with its superclasses - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - WorkList - [W] d1 : Data Maybe [t] - -Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - WorkList: - [W] d2 : Sat (Maybe [t]) - [W] d3 : Data Maybe t - -Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList: - [W] d3 : Data Maybe t - [W] d4 : Foo [t] - -Now, we can just solve d3 from d01; d3 := d01 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList - [W] d4 : Foo [t] - -Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - d4 : Foo [t] - WorkList: - [W] d5 : Foo t - -Now, d5 can be solved! d5 := d0 - -Result - d1 := dfunData2 d2 d3 - d2 := dfunSat d4 - d3 := d01 - d4 := dfunFoo2 d5 - d5 := d0 --} - -{- ********************************************************************* -* * - InertCans: the canonical inerts -* * -* * -********************************************************************* -} - -data InertCans -- See Note [Detailed InertCans Invariants] for more - = IC { inert_eqs :: InertEqs - -- See Note [inert_eqs: the inert equalities] - -- All CTyEqCans; index is the LHS tyvar - -- Domain = skolems and untouchables; a touchable would be unified - - , inert_funeqs :: FunEqMap Ct - -- All CFunEqCans; index is the whole family head type. - -- All Nominal (that's an invarint of all CFunEqCans) - -- LHS is fully rewritten (modulo eqCanRewrite constraints) - -- wrt inert_eqs - -- Can include all flavours, [G], [W], [WD], [D] - -- See Note [Type family equations] - - , inert_dicts :: DictMap Ct - -- Dictionaries only - -- All fully rewritten (modulo flavour constraints) - -- wrt inert_eqs - - , inert_insts :: [QCInst] - - , inert_safehask :: DictMap Ct - -- Failed dictionary resolution due to Safe Haskell overlapping - -- instances restriction. We keep this separate from inert_dicts - -- as it doesn't cause compilation failure, just safe inference - -- failure. - -- - -- ^ See Note [Safe Haskell Overlapping Instances Implementation] - -- in TcSimplify - - , inert_irreds :: Cts - -- Irreducible predicates that cannot be made canonical, - -- and which don't interact with others (e.g. (c a)) - -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - - , inert_count :: Int - -- Number of Wanted goals in - -- inert_eqs, inert_dicts, inert_safehask, inert_irreds - -- Does not include insolubles - -- When non-zero, keep trying to solve - } - -type InertEqs = DTyVarEnv EqualCtList -type EqualCtList = [Ct] -- See Note [EqualCtList invariants] - -{- Note [Detailed InertCans Invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The InertCans represents a collection of constraints with the following properties: - - * All canonical - - * No two dictionaries with the same head - * No two CIrreds with the same type - - * Family equations inert wrt top-level family axioms - - * Dictionaries have no matching top-level instance - - * Given family or dictionary constraints don't mention touchable - unification variables - - * Non-CTyEqCan constraints are fully rewritten with respect - to the CTyEqCan equalities (modulo canRewrite of course; - eg a wanted cannot rewrite a given) - - * CTyEqCan equalities: see Note [inert_eqs: the inert equalities] - -Note [EqualCtList invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * All are equalities - * All these equalities have the same LHS - * The list is never empty - * No element of the list can rewrite any other - * Derived before Wanted - -From the fourth invariant it follows that the list is - - A single [G], or - - Zero or one [D] or [WD], followd by any number of [W] - -The Wanteds can't rewrite anything which is why we put them last - -Note [Type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type-family equations, CFunEqCans, of form (ev : F tys ~ ty), -live in three places - - * The work-list, of course - - * The inert_funeqs are un-solved but fully processed, and in - the InertCans. They can be [G], [W], [WD], or [D]. - - * The inert_flat_cache. This is used when flattening, to get maximal - sharing. Everthing in the inert_flat_cache is [G] or [WD] - - It contains lots of things that are still in the work-list. - E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the - work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work - list. Now if we flatten w2 before we get to w3, we still want to - share that (G a). - Because it contains work-list things, DO NOT use the flat cache to solve - a top-level goal. Eg in the above example we don't want to solve w3 - using w3 itself! - -The CFunEqCan Ownership Invariant: - - * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv - It "owns" that fsk/fmv, in the sense that: - - reducing a [W/WD] CFunEqCan fills in the fmv - - unflattening a [W/WD] CFunEqCan fills in the fmv - (in both cases unless an occurs-check would result) - - * In contrast a [D] CFunEqCan does not "own" its fmv: - - reducing a [D] CFunEqCan does not fill in the fmv; - it just generates an equality - - unflattening ignores [D] CFunEqCans altogether - - -Note [inert_eqs: the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Definition [Can-rewrite relation] -A "can-rewrite" relation between flavours, written f1 >= f2, is a -binary relation with the following properties - - (R1) >= is transitive - (R2) If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 - -Lemma. If f1 >= f then f1 >= f1 -Proof. By property (R2), with f1=f2 - -Definition [Generalised substitution] -A "generalised substitution" S is a set of triples (a -f-> t), where - a is a type variable - t is a type - f is a flavour -such that - (WF1) if (a -f1-> t1) in S - (a -f2-> t2) in S - then neither (f1 >= f2) nor (f2 >= f1) hold - (WF2) if (a -f-> t) is in S, then t /= a - -Definition [Applying a generalised substitution] -If S is a generalised substitution - S(f,a) = t, if (a -fs-> t) in S, and fs >= f - = a, otherwise -Application extends naturally to types S(f,t), modulo roles. -See Note [Flavours with roles]. - -Theorem: S(f,a) is well defined as a function. -Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, - and f1 >= f and f2 >= f - Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) - -Notation: repeated application. - S^0(f,t) = t - S^(n+1)(f,t) = S(f, S^n(t)) - -Definition: inert generalised substitution -A generalised substitution S is "inert" iff - - (IG1) there is an n such that - for every f,t, S^n(f,t) = S^(n+1)(f,t) - -By (IG1) we define S*(f,t) to be the result of exahaustively -applying S(f,_) to t. - ----------------------------------------------------------------- -Our main invariant: - the inert CTyEqCans should be an inert generalised substitution ----------------------------------------------------------------- - -Note that inertness is not the same as idempotence. To apply S to a -type, you may have to apply it recursive. But inertness does -guarantee that this recursive use will terminate. - -Note [Extending the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Main Theorem [Stability under extension] - Suppose we have a "work item" - a -fw-> t - and an inert generalised substitution S, - THEN the extended substitution T = S+(a -fw-> t) - is an inert generalised substitution - PROVIDED - (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) a not in t -- No occurs check in the work item - - AND, for every (b -fs-> s) in S: - (K0) not (fw >= fs) - Reason: suppose we kick out (a -fs-> s), - and add (a -fw-> t) to the inert set. - The latter can't rewrite the former, - so the kick-out achieved nothing - - OR { (K1) not (a = b) - Reason: if fw >= fs, WF1 says we can't have both - a -fw-> t and a -fs-> s - - AND (K2): guarantees inertness of the new substitution - { (K2a) not (fs >= fs) - OR (K2b) fs >= fw - OR (K2d) a not in s } - - AND (K3) See Note [K3: completeness of solving] - { (K3a) If the role of fs is nominal: s /= a - (K3b) If the role of fs is representational: - s is not of form (a t1 .. tn) } } - - -Conditions (T1-T3) are established by the canonicaliser -Conditions (K1-K3) are established by TcSMonad.kickOutRewritable - -The idea is that -* (T1-2) are guaranteed by exhaustively rewriting the work-item - with S(fw,_). - -* T3 is guaranteed by a simple occurs-check on the work item. - This is done during canonicalisation, in canEqTyVar; - (invariant: a CTyEqCan never has an occurs check). - -* (K1-3) are the "kick-out" criteria. (As stated, they are really the - "keep" criteria.) If the current inert S contains a triple that does - not satisfy (K1-3), then we remove it from S by "kicking it out", - and re-processing it. - -* Note that kicking out is a Bad Thing, because it means we have to - re-process a constraint. The less we kick out, the better. - TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed - this but haven't done the empirical study to check. - -* Assume we have G>=G, G>=W and that's all. Then, when performing - a unification we add a new given a -G-> ty. But doing so does NOT require - us to kick out an inert wanted that mentions a, because of (K2a). This - is a common case, hence good not to kick out. - -* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing - Proof: using Definition [Can-rewrite relation], fw can't rewrite anything - and so K0 holds. Intuitively, since fw can't rewrite anything, - adding it cannot cause any loops - This is a common case, because Wanteds cannot rewrite Wanteds. - It's used to avoid even looking for constraint to kick out. - -* Lemma (L1): The conditions of the Main Theorem imply that there is no - (a -fs-> t) in S, s.t. (fs >= fw). - Proof. Suppose the contrary (fs >= fw). Then because of (T1), - S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we - have (a -fs-> a) in S, which contradicts (WF2). - -* The extended substitution satisfies (WF1) and (WF2) - - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). - - (T3) guarantees (WF2). - -* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t), - T^1(f,t), T^2(f,T).... must pass through the new work item infinitely - often, since the substitution without the work item is inert; and must - pass through at least one of the triples in S infinitely often. - - - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f), - and hence this triple never plays a role in application S(f,a). - It is always safe to extend S with such a triple. - - (NB: we could strengten K1) in this way too, but see K3. - - - (K2b): If this holds then, by (T2), b is not in t. So applying the - work item does not generate any new opportunities for applying S - - - (K2c): If this holds, we can't pass through this triple infinitely - often, because if we did then fs>=f, fw>=f, hence by (R2) - * either fw>=fs, contradicting K2c - * or fs>=fw; so by the argument in K2b we can't have a loop - - - (K2d): if a not in s, we hae no further opportunity to apply the - work item, similar to (K2b) - - NB: Dimitrios has a PDF that does this in more detail - -Key lemma to make it watertight. - Under the conditions of the Main Theorem, - forall f st fw >= f, a is not in S^k(f,t), for any k - -Also, consider roles more carefully. See Note [Flavours with roles] - -Note [K3: completeness of solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(K3) is not necessary for the extended substitution -to be inert. In fact K1 could be made stronger by saying - ... then (not (fw >= fs) or not (fs >= fs)) -But it's not enough for S to be inert; we also want completeness. -That is, we want to be able to solve all soluble wanted equalities. -Suppose we have - - work-item b -G-> a - inert-item a -W-> b - -Assuming (G >= W) but not (W >= W), this fulfills all the conditions, -so we could extend the inerts, thus: - - inert-items b -G-> a - a -W-> b - -But if we kicked-out the inert item, we'd get - - work-item a -W-> b - inert-item b -G-> a - -Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. -So we add one more clause to the kick-out criteria - -Another way to understand (K3) is that we treat an inert item - a -f-> b -in the same way as - b -f-> a -So if we kick out one, we should kick out the other. The orientation -is somewhat accidental. - -When considering roles, we also need the second clause (K3b). Consider - - work-item c -G/N-> a - inert-item a -W/R-> b c - -The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. -But we don't kick out the inert item because not (W/R >= W/R). So we just -add the work item. But then, consider if we hit the following: - - work-item b -G/N-> Id - inert-items a -W/R-> b c - c -G/N-> a -where - newtype Id x = Id x - -For similar reasons, if we only had (K3a), we wouldn't kick the -representational inert out. And then, we'd miss solving the inert, which -now reduced to reflexivity. - -The solution here is to kick out representational inerts whenever the -tyvar of a work item is "exposed", where exposed means being at the -head of the top-level application chain (a t1 .. tn). See -TcType.isTyVarHead. This is encoded in (K3b). - -Beware: if we make this test succeed too often, we kick out too much, -and the solver might loop. Consider (#14363) - work item: [G] a ~R f b - inert item: [G] b ~R f a -In GHC 8.2 the completeness tests more aggressive, and kicked out -the inert item; but no rewriting happened and there was an infinite -loop. All we need is to have the tyvar at the head. - -Note [Flavours with roles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The system described in Note [inert_eqs: the inert equalities] -discusses an abstract -set of flavours. In GHC, flavours have two components: the flavour proper, -taken from {Wanted, Derived, Given} and the equality relation (often called -role), taken from {NomEq, ReprEq}. -When substituting w.r.t. the inert set, -as described in Note [inert_eqs: the inert equalities], -we must be careful to respect all components of a flavour. -For example, if we have - - inert set: a -G/R-> Int - b -G/R-> Bool - - type role T nominal representational - -and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT -T Int Bool. The reason is that T's first parameter has a nominal role, and -thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of -substitution means that the proof in Note [The inert equalities] may need -to be revisited, but we don't think that the end conclusion is wrong. --} - -instance Outputable InertCans where - ppr (IC { inert_eqs = eqs - , inert_funeqs = funeqs, inert_dicts = dicts - , inert_safehask = safehask, inert_irreds = irreds - , inert_insts = insts - , inert_count = count }) - = braces $ vcat - [ ppUnless (isEmptyDVarEnv eqs) $ - text "Equalities:" - <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) - , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) - , ppUnless (isEmptyTcAppMap dicts) $ - text "Dictionaries =" <+> pprCts (dictsToBag dicts) - , ppUnless (isEmptyTcAppMap safehask) $ - text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) - , ppUnless (isEmptyCts irreds) $ - text "Irreds =" <+> pprCts irreds - , ppUnless (null insts) $ - text "Given instances =" <+> vcat (map ppr insts) - , text "Unsolved goals =" <+> int count - ] - -{- ********************************************************************* -* * - Shadow constraints and improvement -* * -************************************************************************ - -Note [The improvement story and derived shadows] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not -rewrite Wanteds] in Constraint), we may miss some opportunities for -solving. Here's a classic example (indexed-types/should_fail/T4093a) - - Ambiguity check for f: (Foo e ~ Maybe e) => Foo e - - We get [G] Foo e ~ Maybe e - [W] Foo e ~ Foo ee -- ee is a unification variable - [W] Foo ee ~ Maybe ee - - Flatten: [G] Foo e ~ fsk - [G] fsk ~ Maybe e -- (A) - - [W] Foo ee ~ fmv - [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee - [W] fmv ~ Maybe ee - - --> rewrite (B) with (A) - [W] Foo ee ~ fmv - [W] fmv ~ Maybe e - [W] fmv ~ Maybe ee - - But now we appear to be stuck, since we don't rewrite Wanteds with - Wanteds. This is silly because we can see that ee := e is the - only solution. - -The basic plan is - * generate Derived constraints that shadow Wanted constraints - * allow Derived to rewrite Derived - * in order to cause some unifications to take place - * that in turn solve the original Wanteds - -The ONLY reason for all these Derived equalities is to tell us how to -unify a variable: that is, what Mark Jones calls "improvement". - -The same idea is sometimes also called "saturation"; find all the -equalities that must hold in any solution. - -Or, equivalently, you can think of the derived shadows as implementing -the "model": a non-idempotent but no-occurs-check substitution, -reflecting *all* *Nominal* equalities (a ~N ty) that are not -immediately soluble by unification. - -More specifically, here's how it works (Oct 16): - -* Wanted constraints are born as [WD]; this behaves like a - [W] and a [D] paired together. - -* When we are about to add a [WD] to the inert set, if it can - be rewritten by a [D] a ~ ty, then we split it into [W] and [D], - putting the latter into the work list (see maybeEmitShadow). - -In the example above, we get to the point where we are stuck: - [WD] Foo ee ~ fmv - [WD] fmv ~ Maybe e - [WD] fmv ~ Maybe ee - -But now when [WD] fmv ~ Maybe ee is about to be added, we'll -split it into [W] and [D], since the inert [WD] fmv ~ Maybe e -can rewrite it. Then: - work item: [D] fmv ~ Maybe ee - inert: [W] fmv ~ Maybe ee - [WD] fmv ~ Maybe e -- (C) - [WD] Foo ee ~ fmv - -See Note [Splitting WD constraints]. Now the work item is rewritten -by (C) and we soon get ee := e. - -Additional notes: - - * The derived shadow equalities live in inert_eqs, along with - the Givens and Wanteds; see Note [EqualCtList invariants]. - - * We make Derived shadows only for Wanteds, not Givens. So we - have only [G], not [GD] and [G] plus splitting. See - Note [Add derived shadows only for Wanteds] - - * We also get Derived equalities from functional dependencies - and type-function injectivity; see calls to unifyDerived. - - * This splitting business applies to CFunEqCans too; and then - we do apply type-function reductions to the [D] CFunEqCan. - See Note [Reduction for Derived CFunEqCans] - - * It's worth having [WD] rather than just [W] and [D] because - * efficiency: silly to process the same thing twice - * inert_funeqs, inert_dicts is a finite map keyed by - the type; it's inconvenient for it to map to TWO constraints - -Note [Splitting WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are about to add a [WD] constraint to the inert set; and we -know that the inert set has fully rewritten it. Should we split -it into [W] and [D], and put the [D] in the work list for further -work? - -* CDictCan (C tys) or CFunEqCan (F tys ~ fsk): - Yes if the inert set could rewrite tys to make the class constraint, - or type family, fire. That is, yes if the inert_eqs intersects - with the free vars of tys. For this test we use - (anyRewritableTyVar True) which ignores casts and coercions in tys, - because rewriting the casts or coercions won't make the thing fire - more often. - -* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'. - We need to check both 'a' and 'ty' against the inert set: - - Inert set contains [D] a ~ ty2 - Then we want to put [D] a ~ ty in the worklist, so we'll - get [D] ty ~ ty2 with consequent good things - - - Inert set contains [D] b ~ a, where b is in ty. - We can't just add [WD] a ~ ty[b] to the inert set, because - that breaks the inert-set invariants. If we tried to - canonicalise another [D] constraint mentioning 'a', we'd - get an infinite loop - - Moreover we must use (anyRewritableTyVar False) for the RHS, - because even tyvars in the casts and coercions could give - an infinite loop if we don't expose it - -* CIrredCan: Yes if the inert set can rewrite the constraint. - We used to think splitting irreds was unnecessary, but - see Note [Splitting Irred WD constraints] - -* Others: nothing is gained by splitting. - -Note [Splitting Irred WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Splitting Irred constraints can make a difference. Here is the -scenario: - - a[sk] :: F v -- F is a type family - beta :: alpha - - work item: [WD] a ~ beta - -This is heterogeneous, so we try flattening the kinds. - - co :: F v ~ fmv - [WD] (a |> co) ~ beta - -This is still hetero, so we emit a kind equality and make the work item an -inert Irred. - - work item: [D] fmv ~ alpha - inert: [WD] (a |> co) ~ beta (CIrredCan) - -Can't make progress on the work item. Add to inert set. This kicks out the -old inert, because a [D] can rewrite a [WD]. - - work item: [WD] (a |> co) ~ beta - inert: [D] fmv ~ alpha (CTyEqCan) - -Can't make progress on this work item either (although GHC tries by -decomposing the cast and reflattening... but that doesn't make a difference), -which is still hetero. Emit a new kind equality and add to inert set. But, -critically, we split the Irred. - - work list: - [D] fmv ~ alpha (CTyEqCan) - [D] (a |> co) ~ beta (CIrred) -- this one was split off - inert: - [W] (a |> co) ~ beta - [D] fmv ~ alpha - -We quickly solve the first work item, as it's the same as an inert. - - work item: [D] (a |> co) ~ beta - inert: - [W] (a |> co) ~ beta - [D] fmv ~ alpha - -We decompose the cast, yielding - - [D] a ~ beta - -We then flatten the kinds. The lhs kind is F v, which flattens to fmv which -then rewrites to alpha. - - co' :: F v ~ alpha - [D] (a |> co') ~ beta - -Now this equality is homo-kinded. So we swizzle it around to - - [D] beta ~ (a |> co') - -and set beta := a |> co', and go home happy. - -If we don't split the Irreds, we loop. This is all dangerously subtle. - -This is triggered by test case typecheck/should_compile/SplitWD. - -Note [Examples of how Derived shadows helps completeness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#10009, a very nasty example: - - f :: (UnF (F b) ~ b) => F b -> () - - g :: forall a. (UnF (F a) ~ a) => a -> () - g _ = f (undefined :: F a) - - For g we get [G] UnF (F a) ~ a - [WD] UnF (F beta) ~ beta - [WD] F a ~ F beta - Flatten: - [G] g1: F a ~ fsk1 fsk1 := F a - [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 - [G] g3: fsk2 ~ a - - [WD] w1: F beta ~ fmv1 - [WD] w2: UnF fmv1 ~ fmv2 - [WD] w3: fmv2 ~ beta - [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache - -- and re-orient to put meta-var on left - -Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2 -React that with g2: [D] d2: fmv2 ~ fsk2 -React that with w3: [D] beta ~ fsk2 - and g3: [D] beta ~ a -- Hooray beta := a -And that is enough to solve everything - -Note [Add derived shadows only for Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only add shadows for Wanted constraints. That is, we have -[WD] but not [GD]; and maybeEmitShaodw looks only at [WD] -constraints. - -It does just possibly make sense ot add a derived shadow for a -Given. If we created a Derived shadow of a Given, it could be -rewritten by other Deriveds, and that could, conceivably, lead to a -useful unification. - -But (a) I have been unable to come up with an example of this - happening - (b) see #12660 for how adding the derived shadows - of a Given led to an infinite loop. - (c) It's unlikely that rewriting derived Givens will lead - to a unification because Givens don't mention touchable - unification variables - -For (b) there may be other ways to solve the loop, but simply -reraining from adding derived shadows of Givens is particularly -simple. And it's more efficient too! - -Still, here's one possible reason for adding derived shadows -for Givens. Consider - work-item [G] a ~ [b], inerts has [D] b ~ a. -If we added the derived shadow (into the work list) - [D] a ~ [b] -When we process it, we'll rewrite to a ~ [a] and get an -occurs check. Without it we'll miss the occurs check (reporting -inaccessible code); but that's probably OK. - -Note [Keep CDictCan shadows as CDictCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a b -and [G] D a b, [G] C a in the inert set. Now we insert -[D] b ~ c. We want to kick out a derived shadow for [D] D a b, -so we can rewrite it with the new constraint, and perhaps get -instance reduction or other consequences. - -BUT we do not want to kick out a *non-canonical* (D a b). If we -did, we would do this: - - rewrite it to [D] D a c, with pend_sc = True - - use expandSuperClasses to add C a - - go round again, which solves C a from the givens -This loop goes on for ever and triggers the simpl_loop limit. - -Solution: kick out the CDictCan which will have pend_sc = False, -because we've already added its superclasses. So we won't re-add -them. If we forget the pend_sc flag, our cunning scheme for avoiding -generating superclasses repeatedly will fail. - -See #11379 for a case of this. - -Note [Do not do improvement for WOnly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do improvement between two constraints (e.g. for injectivity -or functional dependencies) only if both are "improvable". And -we improve a constraint wrt the top-level instances only if -it is improvable. - -Improvable: [G] [WD] [D} -Not improvable: [W] - -Reasons: - -* It's less work: fewer pairs to compare - -* Every [W] has a shadow [D] so nothing is lost - -* Consider [WD] C Int b, where 'b' is a skolem, and - class C a b | a -> b - instance C Int Bool - We'll do a fundep on it and emit [D] b ~ Bool - That will kick out constraint [WD] C Int b - Then we'll split it to [W] C Int b (keep in inert) - and [D] C Int b (in work list) - When processing the latter we'll rewrite it to - [D] C Int Bool - At that point it would be /stupid/ to interact it - with the inert [W] C Int b in the inert set; after all, - it's the very constraint from which the [D] C Int Bool - was split! We can avoid this by not doing improvement - on [W] constraints. This came up in #12860. --} - -maybeEmitShadow :: InertCans -> Ct -> TcS Ct --- See Note [The improvement story and derived shadows] -maybeEmitShadow ics ct - | let ev = ctEvidence ct - , CtWanted { ctev_pred = pred, ctev_loc = loc - , ctev_nosh = WDeriv } <- ev - , shouldSplitWD (inert_eqs ics) ct - = do { traceTcS "Emit derived shadow" (ppr ct) - ; let derived_ev = CtDerived { ctev_pred = pred - , ctev_loc = loc } - shadow_ct = ct { cc_ev = derived_ev } - -- Te shadow constraint keeps the canonical shape. - -- This just saves work, but is sometimes important; - -- see Note [Keep CDictCan shadows as CDictCan] - ; emitWork [shadow_ct] - - ; let ev' = ev { ctev_nosh = WOnly } - ct' = ct { cc_ev = ev' } - -- Record that it now has a shadow - -- This is /the/ place we set the flag to WOnly - ; return ct' } - - | otherwise - = return ct - -shouldSplitWD :: InertEqs -> Ct -> Bool --- Precondition: 'ct' is [WD], and is inert --- True <=> we should split ct ito [W] and [D] because --- the inert_eqs can make progress on the [D] --- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- We don't need to split if the tv is the RHS fsk - -shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- NB True: ignore coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty - , cc_eq_rel = eq_rel }) - = tv `elemDVarEnv` inert_eqs - || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty - -- NB False: do not ignore casts and coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev }) - = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev) - -shouldSplitWD _ _ = False -- No point in splitting otherwise - -should_split_match_args :: InertEqs -> [TcType] -> Bool --- True if the inert_eqs can rewrite anything in the argument --- types, ignoring casts and coercions -should_split_match_args inert_eqs tys - = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys - -- NB True: ignore casts coercions - -- See Note [Splitting WD constraints] - -canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool -canRewriteTv inert_eqs eq_rel tv - | Just (ct : _) <- lookupDVarEnv inert_eqs tv - , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct - = eq_rel1 `eqCanRewrite` eq_rel - | otherwise - = False - -isImprovable :: CtEvidence -> Bool --- See Note [Do not do improvement for WOnly] -isImprovable (CtWanted { ctev_nosh = WOnly }) = False -isImprovable _ = True - - -{- ********************************************************************* -* * - Inert equalities -* * -********************************************************************* -} - -addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs -addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv [ct] - where - add_eq old_eqs _ - | isWantedCt ct - , (eq1 : eqs) <- old_eqs - = eq1 : ct : eqs - | otherwise - = ct : old_eqs - -foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b -foldTyEqs k eqs z - = foldDVarEnv (\cts z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> EqualCtList -findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` [] - -delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs -delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv - where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 - isThisOne _ = False - -lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType -lookupInertTyVar ieqs tv - = case lookupDVarEnv ieqs tv of - Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs - _ -> Nothing - -{- ********************************************************************* -* * - Inert instances: inert_insts -* * -********************************************************************* -} - -addInertForAll :: QCInst -> TcS () --- Add a local Given instance, typically arising from a type signature -addInertForAll new_qci - = updInertCans $ \ics -> - ics { inert_insts = add_qci (inert_insts ics) } - where - add_qci :: [QCInst] -> [QCInst] - -- See Note [Do not add duplicate quantified instances] - add_qci qcis | any same_qci qcis = qcis - | otherwise = new_qci : qcis - - same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) - (ctEvPred (qci_ev new_qci)) - -{- Note [Do not add duplicate quantified instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#15244): - - f :: (C g, D g) => .... - class S g => C g where ... - class S g => D g where ... - class (forall a. Eq a => Eq (g a)) => S g where ... - -Then in f's RHS there are two identical quantified constraints -available, one via the superclasses of C and one via the superclasses -of D. The two are identical, and it seems wrong to reject the program -because of that. But without doing duplicate-elimination we will have -two matching QCInsts when we try to solve constraints arising from f's -RHS. - -The simplest thing is simply to eliminate duplicattes, which we do here. --} - -{- ********************************************************************* -* * - Adding an inert -* * -************************************************************************ - -Note [Adding an equality to the InertCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding an equality to the inerts: - -* Split [WD] into [W] and [D] if the inerts can rewrite the latter; - done by maybeEmitShadow. - -* Kick out any constraints that can be rewritten by the thing - we are adding. Done by kickOutRewritable. - -* Note that unifying a:=ty, is like adding [G] a~ty; just use - kickOutRewritable with Nominal, Given. See kickOutAfterUnification. - -Note [Kicking out CFunEqCan for fundeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - New: [D] fmv1 ~ fmv2 - Inert: [W] F alpha ~ fmv1 - [W] F beta ~ fmv2 - -where F is injective. The new (derived) equality certainly can't -rewrite the inerts. But we *must* kick out the first one, to get: - - New: [W] F alpha ~ fmv1 - Inert: [W] F beta ~ fmv2 - [D] fmv1 ~ fmv2 - -and now improvement will discover [D] alpha ~ beta. This is important; -eg in #9587. - -So in kickOutRewritable we look at all the tyvars of the -CFunEqCan, including the fsk. --} - -addInertCan :: Ct -> TcS () -- Constraints *other than* equalities --- Precondition: item /is/ canonical --- See Note [Adding an equality to the InertCans] -addInertCan ct - = do { traceTcS "insertInertCan {" $ - text "Trying to insert new inert item:" <+> ppr ct - - ; ics <- getInertCans - ; ct <- maybeEmitShadow ics ct - ; ics <- maybeKickOut ics ct - ; setInertCans (add_item ics ct) - - ; traceTcS "addInertCan }" $ empty } - -maybeKickOut :: InertCans -> Ct -> TcS InertCans --- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan -maybeKickOut ics ct - | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct - = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics - ; return ics' } - | otherwise - = return ics - -add_item :: InertCans -> Ct -> InertCans -add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) - = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } - -add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) - = ics { inert_eqs = addTyEq (inert_eqs ics) tv item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -add_item ics@(IC { inert_irreds = irreds, inert_count = count }) - item@(CIrredCan { cc_ev = ev, cc_insol = insoluble }) - = ics { inert_irreds = irreds `Bag.snocBag` item - , inert_count = if insoluble - then count -- inert_count does not include insolubles - else bumpUnsolvedCount ev count } - -add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDict (inert_dicts ics) cls tys item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -add_item _ item - = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- Can't be CNonCanonical, CHoleCan, - -- because they only land in inert_irreds - -bumpUnsolvedCount :: CtEvidence -> Int -> Int -bumpUnsolvedCount ev n | isWanted ev = n+1 - | otherwise = n - - ------------------------------------------ -kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> TcS (Int, InertCans) -kickOutRewritable new_fr new_tv ics - = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - ; csTraceTcS $ - hang (text "Kick out, tv =" <+> ppr new_tv) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; return (n_kicked, ics') } - -kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> (WorkList, InertCans) --- See Note [kickOutRewritable] -kick_out_rewritable new_fr new_tv - ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_safehask = safehask - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insts = old_insts - , inert_count = n }) - | not (new_fr `eqMayRewriteFR` new_fr) - = (emptyWorkList, ics) - -- If new_fr can't rewrite itself, it can't rewrite - -- anything else, so no need to kick out anything. - -- (This is a common case: wanteds can't rewrite wanteds) - -- Lemma (L2) in Note [Extending the inert equalities] - - | otherwise - = (kicked_out, inert_cans_in) - where - inert_cans_in = IC { inert_eqs = tv_eqs_in - , inert_dicts = dicts_in - , inert_safehask = safehask -- ?? - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_insts = insts_in - , inert_count = n - workListWantedCount kicked_out } - - kicked_out :: WorkList - -- NB: use extendWorkList to ensure that kicked-out equalities get priority - -- See Note [Prioritise equalities] (Kick-out). - -- The irreds may include non-canonical (hetero-kinded) equality - -- constraints, which perhaps may have become soluble after new_tv - -- is substituted; ditto the dictionaries, which may include (a~b) - -- or (a~~b) constraints. - kicked_out = foldr extendWorkListCt - (emptyWorkList { wl_eqs = tv_eqs_out - , wl_funeqs = feqs_out }) - ((dicts_out `andCts` irs_out) - `extendCtsList` insts_out) - - (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap - -- See Note [Kicking out CFunEqCan for fundeps] - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_ct irreds - -- Kick out even insolubles: See Note [Rewrite insolubles] - -- Of course we must kick out irreducibles like (c a), in case - -- we can rewrite 'c' to something more useful - - -- Kick-out for inert instances - -- See Note [Quantified constraints] in TcCanonical - insts_out :: [Ct] - insts_in :: [QCInst] - (insts_out, insts_in) - | fr_may_rewrite (Given, NomEq) -- All the insts are Givens - = partitionWith kick_out_qci old_insts - | otherwise - = ([], old_insts) - kick_out_qci qci - | let ev = qci_ev qci - , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) - = Left (mkNonCanonical ev) - | otherwise - = Right qci - - (_, new_role) = new_fr - - fr_can_rewrite_ty :: EqRel -> Type -> Bool - fr_can_rewrite_ty role ty = anyRewritableTyVar False role - fr_can_rewrite_tv ty - fr_can_rewrite_tv :: EqRel -> TyVar -> Bool - fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role - && tv == new_tv - - fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs - -- Can the new item rewrite the inert item? - - kick_out_ct :: Ct -> Bool - -- Kick it out if the new CTyEqCan can rewrite the inert one - -- See Note [kickOutRewritable] - kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct - = fr_may_rewrite fs - && fr_can_rewrite_ty role (ctPred ct) - -- False: ignore casts and coercions - -- NB: this includes the fsk of a CFunEqCan. It can't - -- actually be rewritten, but we need to kick it out - -- so we get to take advantage of injectivity - -- See Note [Kicking out CFunEqCan for fundeps] - - kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList) - -> ([Ct], DTyVarEnv EqualCtList) - kick_out_eqs eqs (acc_out, acc_in) - = (eqs_out ++ acc_out, case eqs_in of - [] -> acc_in - (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in) - where - (eqs_out, eqs_in) = partition kick_out_eq eqs - - -- Implements criteria K1-K3 in Note [Extending the inert equalities] - kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty - , cc_ev = ev, cc_eq_rel = eq_rel }) - | not (fr_may_rewrite fs) - = False -- Keep it in the inert set if the new thing can't rewrite it - - -- Below here (fr_may_rewrite fs) is True - | tv == new_tv = True -- (K1) - | kick_out_for_inertness = True - | kick_out_for_completeness = True - | otherwise = False - - where - fs = (ctEvFlavour ev, eq_rel) - kick_out_for_inertness - = (fs `eqMayRewriteFR` fs) -- (K2a) - && not (fs `eqMayRewriteFR` new_fr) -- (K2b) - && fr_can_rewrite_ty eq_rel rhs_ty -- (K2d) - -- (K2c) is guaranteed by the first guard of keep_eq - - kick_out_for_completeness - = case eq_rel of - NomEq -> rhs_ty `eqType` mkTyVarTy new_tv - ReprEq -> isTyVarHead new_tv rhs_ty - - kick_out_eq ct = pprPanic "keep_eq" (ppr ct) - -kickOutAfterUnification :: TcTyVar -> TcS Int -kickOutAfterUnification new_tv - = do { ics <- getInertCans - ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) - new_tv ics - -- Given because the tv := xi is given; NomEq because - -- only nominal equalities are solved by unification - - ; setInertCans ics2 - ; return n_kicked } - -{- Note [kickOutRewritable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [inert_eqs: the inert equalities]. - -When we add a new inert equality (a ~N ty) to the inert set, -we must kick out any inert items that could be rewritten by the -new equality, to maintain the inert-set invariants. - - - We want to kick out an existing inert constraint if - a) the new constraint can rewrite the inert one - b) 'a' is free in the inert constraint (so that it *will*) - rewrite it if we kick it out. - - For (b) we use tyCoVarsOfCt, which returns the type variables /and - the kind variables/ that are directly visible in the type. Hence - we will have exposed all the rewriting we care about to make the - most precise kinds visible for matching classes etc. No need to - kick out constraints that mention type variables whose kinds - contain this variable! - - - A Derived equality can kick out [D] constraints in inert_eqs, - inert_dicts, inert_irreds etc. - - - We don't kick out constraints from inert_solved_dicts, and - inert_solved_funeqs optimistically. But when we lookup we have to - take the substitution into account - - -Note [Rewrite insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an insoluble alpha ~ [alpha], which is insoluble -because an occurs check. And then we unify alpha := [Int]. Then we -really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can -be decomposed. Otherwise we end up with a "Can't match [Int] ~ -[[Int]]" which is true, but a bit confusing because the outer type -constructors match. - -Similarly, if we have a CHoleCan, we'd like to rewrite it with any -Givens, to give as informative an error messasge as possible -(#12468, #11325). - -Hence: - * In the main simlifier loops in TcSimplify (solveWanteds, - simpl_loop), we feed the insolubles in solveSimpleWanteds, - so that they get rewritten (albeit not solved). - - * We kick insolubles out of the inert set, if they can be - rewritten (see TcSMonad.kick_out_rewritable) - - * We rewrite those insolubles in TcCanonical. - See Note [Make sure that insolubles are fully rewritten] --} - - - --------------- -addInertSafehask :: InertCans -> Ct -> InertCans -addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } - -addInertSafehask _ item - = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item - -insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS () --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -insertSafeOverlapFailureTcS what item - | safeOverlap what = return () - | otherwise = updInertCans (\ics -> addInertSafehask ics item) - -getSafeOverlapFailures :: TcS Cts --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -getSafeOverlapFailures - = do { IC { inert_safehask = safehask } <- getInertCans - ; return $ foldDicts consCts safehask emptyCts } - --------------- -addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS () --- Conditionally add a new item in the solved set of the monad --- See Note [Solved dictionaries] -addSolvedDict what item cls tys - | isWanted item - , instanceReturnsDictCon what - = do { traceTcS "updSolvedSetTcs:" $ ppr item - ; updInertTcS $ \ ics -> - ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } - | otherwise - = return () - -getSolvedDicts :: TcS (DictMap CtEvidence) -getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) } - -setSolvedDicts :: DictMap CtEvidence -> TcS () -setSolvedDicts solved_dicts - = updInertTcS $ \ ics -> - ics { inert_solved_dicts = solved_dicts } - - -{- ********************************************************************* -* * - Other inert-set operations -* * -********************************************************************* -} - -updInertTcS :: (InertSet -> InertSet) -> TcS () --- Modify the inert set with the supplied function -updInertTcS upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var - ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } - -getInertCans :: TcS InertCans -getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } - -setInertCans :: InertCans -> TcS () -setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } - -updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a --- Modify the inert set with the supplied function -updRetInertCans upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { inerts <- TcM.readTcRef is_var - ; let (res, cans') = upd_fn (inert_cans inerts) - ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) - ; return res }) } - -updInertCans :: (InertCans -> InertCans) -> TcS () --- Modify the inert set with the supplied function -updInertCans upd_fn - = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } - -updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertDicts upd_fn - = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } - -updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertSafehask upd_fn - = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } - -updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertFunEqs upd_fn - = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) } - -updInertIrreds :: (Cts -> Cts) -> TcS () --- Modify the inert set with the supplied function -updInertIrreds upd_fn - = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } - -getInertEqs :: TcS (DTyVarEnv EqualCtList) -getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } - -getInertInsols :: TcS Cts --- Returns insoluble equality constraints --- specifically including Givens -getInertInsols = do { inert <- getInertCans - ; return (filterBag insolubleEqCt (inert_irreds inert)) } - -getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set, --- with type functions *not* unflattened -getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (:) (inert_funeqs inerts) - $ concat (dVarEnvElts (inert_eqs inerts)) - ; return (filter isGivenCt all_cts) } - -getPendingGivenScs :: TcS [Ct] --- Find all inert Given dictionaries, or quantified constraints, --- whose cc_pend_sc flag is True --- and that belong to the current level --- Set their cc_pend_sc flag to False in the inert set, and return that Ct -getPendingGivenScs = do { lvl <- getTcLevel - ; updRetInertCans (get_sc_pending lvl) } - -get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) -get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) - = ASSERT2( all isGivenCt sc_pending, ppr sc_pending ) - -- When getPendingScDics is called, - -- there are never any Wanteds in the inert set - (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' }) - where - sc_pending = sc_pend_insts ++ sc_pend_dicts - - sc_pend_dicts = foldDicts get_pending dicts [] - dicts' = foldr add dicts sc_pend_dicts - - (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts - - get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True - -- but flipping the flag - get_pending dict dicts - | Just dict' <- isPendingScDict dict - , belongs_to_this_level (ctEvidence dict) - = dict' : dicts - | otherwise - = dicts - - add :: Ct -> DictMap Ct -> DictMap Ct - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts - = addDict dicts cls tys ct - add ct _ = pprPanic "getPendingScDicts" (ppr ct) - - get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) - get_pending_inst cts qci@(QCI { qci_ev = ev }) - | Just qci' <- isPendingScInst qci - , belongs_to_this_level ev - = (CQuantCan qci' : cts, qci') - | otherwise - = (cts, qci) - - belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl - -- We only want Givens from this level; see (3a) in - -- Note [The superclass story] in TcCanonical - -getUnsolvedInerts :: TcS ( Bag Implication - , Cts -- Tyvar eqs: a ~ ty - , Cts -- Fun eqs: F a ~ ty - , Cts ) -- All others --- Return all the unsolved [Wanted] or [Derived] constraints --- --- Post-condition: the returned simple constraints are all fully zonked --- (because they come from the inert set) --- the unsolved implics may not be -getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_dicts = idicts - } <- getInertCans - - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts - unsolved_irreds = Bag.filterBag is_unsolved irreds - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unsolved_irreds `unionBags` unsolved_dicts - - ; implics <- getWorkListImplics - - ; traceTcS "getUnsolvedInerts" $ - vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs - , text "fun eqs =" <+> ppr unsolved_fun_eqs - , text "others =" <+> ppr unsolved_others - , text "implics =" <+> ppr implics ] - - ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) } - where - add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts - | otherwise = cts - - is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived - - -- For CFunEqCans we ignore the Derived ones, and keep - -- only the Wanteds for flattening. The Derived ones - -- share a unification variable with the corresponding - -- Wanted, so we definitely don't want to participate - -- in unflattening - -- See Note [Type family equations] - add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts - | otherwise = cts - -isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool --- True if (a ~N ty) is in the inert set, in either Given or Wanted -isInInertEqs eqs tv rhs - = case lookupDVarEnv eqs tv of - Nothing -> False - Just cts -> any (same_pred rhs) cts - where - same_pred rhs ct - | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct - , NomEq <- eq_rel - , rhs `eqType` rhs2 = True - | otherwise = False - -getNoGivenEqs :: TcLevel -- TcLevel of this implication - -> [TcTyVar] -- Skolems of this implication - -> TcS ( Bool -- True <=> definitely no residual given equalities - , Cts ) -- Insoluble equalities arising from givens --- See Note [When does an implication have given equalities?] -getNoGivenEqs tclvl skol_tvs - = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) - <- getInertCans - ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds - || anyDVarEnv eqs_given_here ieqs - insols = filterBag insolubleEqCt irreds - -- Specifically includes ones that originated in some - -- outer context but were refined to an insoluble by - -- a local equality; so do /not/ add ct_given_here. - - ; traceTcS "getNoGivenEqs" $ - vcat [ if has_given_eqs then text "May have given equalities" - else text "No given equalities" - , text "Skols:" <+> ppr skol_tvs - , text "Inerts:" <+> ppr inerts - , text "Insols:" <+> ppr insols] - ; return (not has_given_eqs, insols) } - where - eqs_given_here :: EqualCtList -> Bool - eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })] - -- Givens are always a sigleton - = not (skolem_bound_here tv) && ct_given_here ct - eqs_given_here _ = False - - ct_given_here :: Ct -> Bool - -- True for a Given bound by the current implication, - -- i.e. the current level - ct_given_here ct = isGiven ev - && tclvl == ctLocLevel (ctEvLoc ev) - where - ev = ctEvidence ct - - skol_tv_set = mkVarSet skol_tvs - skolem_bound_here tv -- See Note [Let-bound skolems] - = case tcTyVarDetails tv of - SkolemTv {} -> tv `elemVarSet` skol_tv_set - _ -> False - --- | Returns Given constraints that might, --- potentially, match the given pred. This is used when checking to see if a --- Given might overlap with an instance. See Note [Instance and Given overlap] --- in TcInteract. -matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred_w (IS { inert_cans = inert_cans }) - = filterBag matchable_given all_relevant_givens - where - -- just look in class constraints and irreds. matchableGivens does get called - -- for ~R constraints, but we don't need to look through equalities, because - -- canonical equalities are used for rewriting. We'll only get caught by - -- non-canonical -- that is, irreducible -- equalities. - all_relevant_givens :: Cts - all_relevant_givens - | Just (clas, _) <- getClassPredTys_maybe pred_w - = findDictsByClass (inert_dicts inert_cans) clas - `unionBags` inert_irreds inert_cans - | otherwise - = inert_irreds inert_cans - - matchable_given :: Ct -> Bool - matchable_given ct - | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = mightMatchLater pred_g loc_g pred_w loc_w - - | otherwise - = False - -mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool -mightMatchLater given_pred given_loc wanted_pred wanted_loc - = not (prohibitedSuperClassSolve given_loc wanted_loc) - && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred]) - where - bind_meta_tv :: TcTyVar -> BindFlag - -- Any meta tyvar may be unified later, so we treat it as - -- bindable when unifying with givens. That ensures that we - -- conservatively assume that a meta tyvar might get unified with - -- something that matches the 'given', until demonstrated - -- otherwise. More info in Note [Instance and Given overlap] - -- in TcInteract - bind_meta_tv tv | isMetaTyVar tv - , not (isFskTyVar tv) = BindMe - | otherwise = Skolem - -prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool --- See Note [Solving superclass constraints] in TcInstDcls -prohibitedSuperClassSolve from_loc solve_loc - | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc - , ScOrigin wanted_size <- ctLocOrigin solve_loc - = given_size >= wanted_size - | otherwise - = False - -{- Note [Unsolved Derived equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In getUnsolvedInerts, we return a derived equality from the inert_eqs -because it is a candidate for floating out of this implication. We -only float equalities with a meta-tyvar on the left, so we only pull -those out here. - -Note [When does an implication have given equalities?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an implication - beta => alpha ~ Int -where beta is a unification variable that has already been unified -to () in an outer scope. Then we can float the (alpha ~ Int) out -just fine. So when deciding whether the givens contain an equality, -we should canonicalise first, rather than just looking at the original -givens (#8644). - -So we simply look at the inert, canonical Givens and see if there are -any equalities among them, the calculation of has_given_eqs. There -are some wrinkles: - - * We must know which ones are bound in *this* implication and which - are bound further out. We can find that out from the TcLevel - of the Given, which is itself recorded in the tcl_tclvl field - of the TcLclEnv stored in the Given (ev_given_here). - - What about interactions between inner and outer givens? - - Outer given is rewritten by an inner given, then there must - have been an inner given equality, hence the “given-eq” flag - will be true anyway. - - - Inner given rewritten by outer, retains its level (ie. The inner one) - - * We must take account of *potential* equalities, like the one above: - beta => ...blah... - If we still don't know what beta is, we conservatively treat it as potentially - becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. - - * When flattening givens, we generate Given equalities like - : F [a] ~ f, - with Refl evidence, and we *don't* want those to count as an equality - in the givens! After all, the entire flattening business is just an - internal matter, and the evidence does not mention any of the 'givens' - of this implication. So we do not treat inert_funeqs as a 'given equality'. - - * See Note [Let-bound skolems] for another wrinkle - - * We do *not* need to worry about representational equalities, because - these do not affect the ability to float constraints. - -Note [Let-bound skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CTyEqCan (a ~ ty) -and * 'a' is a skolem bound in this very implication, - -then: -a) The Given is pretty much a let-binding, like - f :: (a ~ b->c) => a -> a - Here the equality constraint is like saying - let a = b->c in ... - It is not adding any new, local equality information, - and hence can be ignored by has_given_eqs - -b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. Notably, it doesn't need to be - returned as part of 'fsks' - -For an example, see #9211. - -See also TcUnify Note [Deeper level on the left] for how we ensure -that the right variable is on the left of the equality when both are -tyvars. - -You might wonder whether the skokem really needs to be bound "in the -very same implication" as the equuality constraint. -(c.f. #15009) Consider this: - - data S a where - MkS :: (a ~ Int) => S a - - g :: forall a. S a -> a -> blah - g x y = let h = \z. ( z :: Int - , case x of - MkS -> [y,z]) - in ... - -From the type signature for `g`, we get `y::a` . Then when when we -encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the -body of the lambda we'll get - - [W] alpha[1] ~ Int -- From z::Int - [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] - -Now, suppose we decide to float `alpha ~ a` out of the implication -and then unify `alpha := a`. Now we are stuck! But if treat -`alpha ~ Int` first, and unify `alpha := Int`, all is fine. -But we absolutely cannot float that equality or we will get stuck. --} - -removeInertCts :: [Ct] -> InertCans -> InertCans --- ^ Remove inert constraints from the 'InertCans', for use when a --- typechecker plugin wishes to discard a given. -removeInertCts cts icans = foldl' removeInertCt icans cts - -removeInertCt :: InertCans -> Ct -> InertCans -removeInertCt is ct = - case ct of - - CDictCan { cc_class = cl, cc_tyargs = tys } -> - is { inert_dicts = delDict (inert_dicts is) cl tys } - - CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> - is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } - - CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> - is { inert_eqs = delTyEq (inert_eqs is) x ty } - - CQuantCan {} -> panic "removeInertCt: CQuantCan" - CIrredCan {} -> panic "removeInertCt: CIrredEvCan" - CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - CHoleCan {} -> panic "removeInertCt: CHoleCan" - - -lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) -lookupFlatCache fam_tc tys - = do { IS { inert_flat_cache = flat_cache - , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts - ; return (firstJusts [lookup_inerts inert_funeqs, - lookup_flats flat_cache]) } - where - lookup_inerts inert_funeqs - | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis }) - <- findFunEq inert_funeqs fam_tc tys - , tys `eqTypes` xis -- The lookup might find a near-match; see - -- Note [Use loose types in inert set] - = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) - | otherwise = Nothing - - lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys - - -lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) --- Is this exact predicate type cached in the solved or canonicals of the InertSet? -lookupInInerts loc pty - | ClassPred cls tys <- classifyPredType pty - = do { inerts <- getTcSInerts - ; return (lookupSolvedDict inerts loc cls tys `mplus` - lookupInertDict (inert_cans inerts) loc cls tys) } - | otherwise -- NB: No caching for equalities, IPs, holes, or errors - = return Nothing - --- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not --- match the input exactly. Note [Use loose types in inert set]. -lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence -lookupInertDict (IC { inert_dicts = dicts }) loc cls tys - = case findDict dicts loc cls tys of - Just ct -> Just (ctEvidence ct) - _ -> Nothing - --- | Look up a solved inert. NB: the returned 'CtEvidence' might not --- match the input exactly. See Note [Use loose types in inert set]. -lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence --- Returns just if exactly this predicate type exists in the solved. -lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys - = case findDict solved loc cls tys of - Just ev -> Just ev - _ -> Nothing - -{- ********************************************************************* -* * - Irreds -* * -********************************************************************* -} - -foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b -foldIrreds k irreds z = foldr k z irreds - - -{- ********************************************************************* -* * - TcAppMap -* * -************************************************************************ - -Note [Use loose types in inert set] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly -solvable from the other. So, we do lookup in the inert set using -loose types, which omit the kind-check. - -We must be careful when using the result of a lookup because it may -not match the requested info exactly! - --} - -type TcAppMap a = UniqDFM (ListMap LooseTypeMap a) - -- Indexed by tycon then the arg types, using "loose" matching, where - -- we don't require kind equality. This allows, for example, (a |> co) - -- to match (a). - -- See Note [Use loose types in inert set] - -- Used for types and classes; hence UniqDFM - -- See Note [foldTM determinism] for why we use UniqDFM here - -isEmptyTcAppMap :: TcAppMap a -> Bool -isEmptyTcAppMap m = isNullUDFM m - -emptyTcAppMap :: TcAppMap a -emptyTcAppMap = emptyUDFM - -findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a -findTcApp m u tys = do { tys_map <- lookupUDFM m u - ; lookupTM tys tys_map } - -delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a -delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls - -insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a -insertTcApp m cls tys ct = alterUDFM alter_tm m cls - where - alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) - --- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b --- mapTcApp f = mapUDFM (mapTM f) - -filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct -filterTcAppMap f m - = mapUDFM do_tm m - where - do_tm tm = foldTM insert_mb tm emptyTM - insert_mb ct tm - | f ct = insertTM tys ct tm - | otherwise = tm - where - tys = case ct of - CFunEqCan { cc_tyargs = tys } -> tys - CDictCan { cc_tyargs = tys } -> tys - _ -> pprPanic "filterTcAppMap" (ppr ct) - -tcAppMapToBag :: TcAppMap a -> Bag a -tcAppMapToBag m = foldTcAppMap consBag m emptyBag - -foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b -foldTcAppMap k m z = foldUDFM (foldTM k) z m - - -{- ********************************************************************* -* * - DictMap -* * -********************************************************************* -} - - -{- Note [Tuples hiding implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f,g :: (?x::Int, C a) => a -> a - f v = let ?x = 4 in g v - -The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). -We must /not/ solve this from the Given (?x::Int, C a), because of -the intervening binding for (?x::Int). #14218. - -We deal with this by arranging that we always fail when looking up a -tuple constraint that hides an implicit parameter. Not that this applies - * both to the inert_dicts (lookupInertDict) - * and to the solved_dicts (looukpSolvedDict) -An alternative would be not to extend these sets with such tuple -constraints, but it seemed more direct to deal with the lookup. - -Note [Solving CallStack constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose f :: HasCallStack => blah. Then - -* Each call to 'f' gives rise to - [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f - with a CtOrigin that says "OccurrenceOf f". - Remember that HasCallStack is just shorthand for - IP "callStack CallStack - See Note [Overview of implicit CallStacks] in TcEvidence - -* We cannonicalise such constraints, in TcCanonical.canClassNC, by - pushing the call-site info on the stack, and changing the CtOrigin - to record that has been done. - Bind: s1 = pushCallStack s2 - [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin - -* Then, and only then, we can solve the constraint from an enclosing - Given. - -So we must be careful /not/ to solve 's1' from the Givens. Again, -we ensure this by arranging that findDict always misses when looking -up souch constraints. --} - -type DictMap a = TcAppMap a - -emptyDictMap :: DictMap a -emptyDictMap = emptyTcAppMap - -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a -findDict m loc cls tys - | isCTupleClass cls - , any hasIPPred tys -- See Note [Tuples hiding implicit parameters] - = Nothing - - | Just {} <- isCallStackPred cls tys - , OccurrenceOf {} <- ctLocOrigin loc - = Nothing -- See Note [Solving CallStack constraints] - - | otherwise - = findTcApp m (getUnique cls) tys - -findDictsByClass :: DictMap a -> Class -> Bag a -findDictsByClass m cls - | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag - | otherwise = emptyBag - -delDict :: DictMap a -> Class -> [Type] -> DictMap a -delDict m cls tys = delTcApp m (getUnique cls) tys - -addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a -addDict m cls tys item = insertTcApp m (getUnique cls) tys item - -addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct -addDictsByClass m cls items - = addToUDFM m cls (foldr add emptyTM items) - where - add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm - add ct _ = pprPanic "addDictsByClass" (ppr ct) - -filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct -filterDicts f m = filterTcAppMap f m - -partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) -partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) - where - k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) - | otherwise = (yeses, add ct noes) - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m - = addDict m cls tys ct - add ct _ = pprPanic "partitionDicts" (ppr ct) - -dictsToBag :: DictMap a -> Bag a -dictsToBag = tcAppMapToBag - -foldDicts :: (a -> b -> b) -> DictMap a -> b -> b -foldDicts = foldTcAppMap - -emptyDicts :: DictMap a -emptyDicts = emptyTcAppMap - - -{- ********************************************************************* -* * - FunEqMap -* * -********************************************************************* -} - -type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair - -emptyFunEqs :: TcAppMap a -emptyFunEqs = emptyTcAppMap - -findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a -findFunEq m tc tys = findTcApp m (getUnique tc) tys - -funEqsToBag :: FunEqMap a -> Bag a -funEqsToBag m = foldTcAppMap consBag m emptyBag - -findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] --- Get inert function equation constraints that have the given tycon --- in their head. Not that the constraints remain in the inert set. --- We use this to check for derived interactions with built-in type-function --- constructors. -findFunEqsByTyCon m tc - | Just tm <- lookupUDFM m tc = foldTM (:) tm [] - | otherwise = [] - -foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b -foldFunEqs = foldTcAppMap - --- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b --- mapFunEqs = mapTcApp - --- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct --- filterFunEqs = filterTcAppMap - -insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a -insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val - -partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) --- Optimise for the case where the predicate is false --- partitionFunEqs is called only from kick-out, and kick-out usually --- kicks out very few equalities, so we want to optimise for that case -partitionFunEqs f m = (yeses, foldr del m yeses) - where - yeses = foldTcAppMap k m [] - k ct yeses | f ct = ct : yeses - | otherwise = yeses - del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m - = delFunEq m tc tys - del ct _ = pprPanic "partitionFunEqs" (ppr ct) - -delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a -delFunEq m tc tys = delTcApp m (getUnique tc) tys - ------------------------------- -type ExactFunEqMap a = UniqFM (ListMap TypeMap a) - -emptyExactFunEqs :: ExactFunEqMap a -emptyExactFunEqs = emptyUFM - -findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a -findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc) - ; lookupTM tys tys_map } - -insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a -insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc) - where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) - -{- -************************************************************************ -* * -* The TcS solver monad * -* * -************************************************************************ - -Note [The TcS monad] -~~~~~~~~~~~~~~~~~~~~ -The TcS monad is a weak form of the main Tc monad - -All you can do is - * fail - * allocate new variables - * fill in evidence variables - -Filling in a dictionary evidence variable means to create a binding -for it, so TcS carries a mutable location where the binding can be -added. This is initialised from the innermost implication constraint. --} - -data TcSEnv - = TcSEnv { - tcs_ev_binds :: EvBindsVar, - - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero - - tcs_count :: IORef Int, -- Global step count - - tcs_inerts :: IORef InertSet, -- Current inert set - - -- The main work-list and the flattening worklist - -- See Note [Work list priorities] and - tcs_worklist :: IORef WorkList -- Current worklist - } - ---------------- -newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) - -instance Applicative TcS where - pure x = TcS (\_ -> return x) - (<*>) = ap - -instance Monad TcS where -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) - -instance MonadFail.MonadFail TcS where - fail err = TcS (\_ -> fail err) - -instance MonadUnique TcS where - getUniqueSupplyM = wrapTcS getUniqueSupplyM - -instance HasModule TcS where - getModule = wrapTcS getModule - -instance MonadThings TcS where - lookupThing n = wrapTcS (lookupThing n) - --- Basic functionality --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -wrapTcS :: TcM a -> TcS a --- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, --- and TcS is supposed to have limited functionality -wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds - -wrapErrTcS :: TcM a -> TcS a --- The thing wrapped should just fail --- There's no static check; it's up to the user --- Having a variant for each error message is too painful -wrapErrTcS = wrapTcS - -wrapWarnTcS :: TcM a -> TcS a --- The thing wrapped should just add a warning, or no-op --- There's no static check; it's up to the user -wrapWarnTcS = wrapTcS - -failTcS, panicTcS :: SDoc -> TcS a -warnTcS :: WarningFlag -> SDoc -> TcS () -addErrTcS :: SDoc -> TcS () -failTcS = wrapTcS . TcM.failWith -warnTcS flag = wrapTcS . TcM.addWarn (Reason flag) -addErrTcS = wrapTcS . TcM.addErr -panicTcS doc = pprPanic "TcCanonical" doc - -traceTcS :: String -> SDoc -> TcS () -traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) - -runTcPluginTcS :: TcPluginM a -> TcS a -runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar - -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags - -getGlobalRdrEnvTcS :: TcS GlobalRdrEnv -getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv - -bumpStepCountTcS :: TcS () -bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env - ; n <- TcM.readTcRef ref - ; TcM.writeTcRef ref (n+1) } - -csTraceTcS :: SDoc -> TcS () -csTraceTcS doc - = wrapTcS $ csTraceTcM (return doc) - -traceFireTcS :: CtEvidence -> SDoc -> TcS () --- Dump a rule-firing trace -traceFireTcS ev doc - = TcS $ \env -> csTraceTcM $ - do { n <- TcM.readTcRef (tcs_count env) - ; tclvl <- TcM.getTcLevel - ; return (hang (text "Step" <+> int n - <> brackets (text "l:" <> ppr tclvl <> comma <> - text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) - <+> doc <> colon) - 4 (ppr ev)) } - -csTraceTcM :: TcM SDoc -> TcM () --- Constraint-solver tracing, -ddump-cs-trace -csTraceTcM mk_doc - = do { dflags <- getDynFlags - ; when ( dopt Opt_D_dump_cs_trace dflags - || dopt Opt_D_dump_tc_trace dflags ) - ( do { msg <- mk_doc - ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) } - -runTcS :: TcS a -- What to run - -> TcM (a, EvBindMap) -runTcS tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; return (res, ev_binds) } - --- | This variant of 'runTcS' will keep solving, even when only Deriveds --- are left around. It also doesn't return any evidence, as callers won't --- need it. -runTcSDeriveds :: TcS a -> TcM a -runTcSDeriveds tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds ev_binds_var tcs } - --- | This can deal only with equality constraints. -runTcSEqualities :: TcS a -> TcM a -runTcSEqualities thing_inside - = do { ev_binds_var <- TcM.newNoTcEvBinds - ; runTcSWithEvBinds ev_binds_var thing_inside } - -runTcSWithEvBinds :: EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds ev_binds_var tcs - = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef emptyInert - ; wl_var <- TcM.newTcRef emptyWorkList - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_count = step_count - , tcs_inerts = inert_var - , tcs_worklist = wl_var } - - -- Run the computation - ; res <- unTcS tcs env - - ; count <- TcM.readTcRef step_count - ; when (count > 0) $ - csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - - ; unflattenGivens inert_var - -#if defined(DEBUG) - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; checkForCyclicBinds ev_binds -#endif - - ; return res } - ----------------------------- -#if defined(DEBUG) -checkForCyclicBinds :: EvBindMap -> TcM () -checkForCyclicBinds ev_binds_map - | null cycles - = return () - | null coercion_cycles - = TcM.traceTc "Cycle in evidence binds" $ ppr cycles - | otherwise - = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles - where - ev_binds = evBindMapBinds ev_binds_map - - cycles :: [[EvBind]] - cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] - - coercion_cycles = [c | c <- cycles, any is_co_bind c] - is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b) - - edges :: [ Node EvVar EvBind ] - edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs)) - | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic even - -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. -#endif - ----------------------------- -setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a -setEvBindsTcS ref (TcS thing_inside) - = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) - -nestImplicTcS :: EvBindsVar - -> TcLevel -> TcS a - -> TcS a -nestImplicTcS ref inner_tclvl (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count - } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = emptyInert - { inert_cans = inert_cans inerts - , inert_solved_dicts = inert_solved_dicts inerts } - -- See Note [Do not inherit the flat cache] - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_count = count - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env - - ; unflattenGivens new_inert_var - -#if defined(DEBUG) - -- Perform a check that the thing_inside did not cause cycles - ; ev_binds <- TcM.getTcEvBindsMap ref - ; checkForCyclicBinds ev_binds -#endif - ; return res } - -{- Note [Do not inherit the flat cache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to inherit the flat cache when processing nested -implications. Consider - a ~ F b, forall c. b~Int => blah -If we have F b ~ fsk in the flat-cache, and we push that into the -nested implication, we might miss that F b can be rewritten to F Int, -and hence perhpas solve it. Moreover, the fsk from outside is -flattened out after solving the outer level, but and we don't -do that flattening recursively. --} - -nestTcS :: TcS a -> TcS a --- Use the current untouchables, augmenting the current --- evidence bindings, and solved dictionaries --- But have no effect on the InertCans, or on the inert_flat_cache --- (we want to inherit the latter from processing the Givens) -nestTcS (TcS thing_inside) - = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> - do { inerts <- TcM.readTcRef inerts_var - ; new_inert_var <- TcM.newTcRef inerts - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - - ; res <- thing_inside nest_env - - ; new_inerts <- TcM.readTcRef new_inert_var - - -- we want to propogate the safe haskell failures - ; let old_ic = inert_cans inerts - new_ic = inert_cans new_inerts - nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } - - ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] - (inerts { inert_solved_dicts = inert_solved_dicts new_inerts - , inert_cans = nxt_ic }) - - ; return res } - -emitImplicationTcS :: TcLevel -> SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Givens - -> Cts -- Wanteds - -> TcS TcEvBinds --- Add an implication to the TcS monad work-list -emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_given = givens - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp - ; return (TcEvBinds (ic_binds imp)) } - -emitTvImplicationTcS :: TcLevel -> SkolemInfo - -> [TcTyVar] -- Skolems - -> Cts -- Wanteds - -> TcS () --- Just like emitImplicationTcS but no givens and no bindings -emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newNoTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp } - - -{- Note [Propagate the solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really quite important that nestTcS does not discard the solved -dictionaries from the thing_inside. -Consider - Eq [a] - forall b. empty => Eq [a] -We solve the simple (Eq [a]), under nestTcS, and then turn our attention to -the implications. It's definitely fine to use the solved dictionaries on -the inner implications, and it can make a signficant performance difference -if you do so. --} - --- Getters and setters of TcEnv fields --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- Getter of inerts and worklist -getTcSInertsRef :: TcS (IORef InertSet) -getTcSInertsRef = TcS (return . tcs_inerts) - -getTcSWorkListRef :: TcS (IORef WorkList) -getTcSWorkListRef = TcS (return . tcs_worklist) - -getTcSInerts :: TcS InertSet -getTcSInerts = getTcSInertsRef >>= readTcRef - -setTcSInerts :: InertSet -> TcS () -setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics } - -getWorkListImplics :: TcS (Bag Implication) -getWorkListImplics - = do { wl_var <- getTcSWorkListRef - ; wl_curr <- readTcRef wl_var - ; return (wl_implics wl_curr) } - -pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) --- Push the level and run thing_inside --- However, thing_inside should not generate any work items -#if defined(DEBUG) -pushLevelNoWorkList err_doc (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM $ - thing_inside (env { tcs_worklist = wl_panic }) - ) - where - wl_panic = pprPanic "TcSMonad.buildImplication" err_doc - -- This panic checks that the thing-inside - -- does not emit any work-list constraints -#else -pushLevelNoWorkList _ (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check -#endif - -updWorkListTcS :: (WorkList -> WorkList) -> TcS () -updWorkListTcS f - = do { wl_var <- getTcSWorkListRef - ; updTcRef wl_var f } - -emitWorkNC :: [CtEvidence] -> TcS () -emitWorkNC evs - | null evs - = return () - | otherwise - = emitWork (map mkNonCanonical evs) - -emitWork :: [Ct] -> TcS () -emitWork cts - = do { traceTcS "Emitting fresh work" (vcat (map ppr cts)) - ; updWorkListTcS (extendWorkListCts cts) } - -emitImplication :: Implication -> TcS () -emitImplication implic - = updWorkListTcS (extendWorkListImplic implic) - -newTcRef :: a -> TcS (TcRef a) -newTcRef x = wrapTcS (TcM.newTcRef x) - -readTcRef :: TcRef a -> TcS a -readTcRef ref = wrapTcS (TcM.readTcRef ref) - -writeTcRef :: TcRef a -> a -> TcS () -writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) - -updTcRef :: TcRef a -> (a->a) -> TcS () -updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) - -getTcEvBindsVar :: TcS EvBindsVar -getTcEvBindsVar = TcS (return . tcs_ev_binds) - -getTcLevel :: TcS TcLevel -getTcLevel = wrapTcS TcM.getTcLevel - -getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet -getTcEvTyCoVars ev_binds_var - = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var - -getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap -getTcEvBindsMap ev_binds_var - = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () -setTcEvBindsMap ev_binds_var binds - = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds - -unifyTyVar :: TcTyVar -> TcType -> TcS () --- Unify a meta-tyvar with a type --- We keep track of how many unifications have happened in tcs_unified, --- --- We should never unify the same variable twice! -unifyTyVar tv ty - = ASSERT2( isMetaTyVar tv, ppr tv ) - TcS $ \ env -> - do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty - ; TcM.updTcRef (tcs_unified env) (+1) } - -reportUnifications :: TcS a -> TcS (Int, a) -reportUnifications (TcS thing_inside) - = TcS $ \ env -> - do { inner_unified <- TcM.newTcRef 0 - ; res <- thing_inside (env { tcs_unified = inner_unified }) - ; n_unifs <- TcM.readTcRef inner_unified - ; TcM.updTcRef (tcs_unified env) (+ n_unifs) - ; return (n_unifs, res) } - -getDefaultInfo :: TcS ([Type], (Bool, Bool)) -getDefaultInfo = wrapTcS TcM.tcGetDefaultTys - --- Just get some environments needed for instance looking up and matching --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -getInstEnvs :: TcS InstEnvs -getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs - -getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) -getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs - -getTopEnv :: TcS HscEnv -getTopEnv = wrapTcS $ TcM.getTopEnv - -getGblEnv :: TcS TcGblEnv -getGblEnv = wrapTcS $ TcM.getGblEnv - -getLclEnv :: TcS TcLclEnv -getLclEnv = wrapTcS $ TcM.getLclEnv - -tcLookupClass :: Name -> TcS Class -tcLookupClass c = wrapTcS $ TcM.tcLookupClass c - -tcLookupId :: Name -> TcS Id -tcLookupId n = wrapTcS $ TcM.tcLookupId n - --- Setting names as used (used in the deriving of Coercible evidence) --- Too hackish to expose it to TcS? In that case somehow extract the used --- constructors from the result of solveInteract -addUsedGREs :: [GlobalRdrElt] -> TcS () -addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres - -addUsedGRE :: Bool -> GlobalRdrElt -> TcS () -addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre - -keepAlive :: Name -> TcS () -keepAlive = wrapTcS . TcM.keepAlive - --- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS () --- Check that we do not try to use an instance before it is available. E.g. --- instance Eq T where ... --- f x = $( ... (\(p::T) -> p == p)... ) --- Here we can't use the equality function from the instance in the splice - -checkWellStagedDFun loc what pred - | TopLevInstance { iw_dfun_id = dfun_id } <- what - , let bind_lvl = TcM.topIdLvl dfun_id - , bind_lvl > impLevel - = wrapTcS $ TcM.setCtLocM loc $ - do { use_stage <- TcM.getStage - ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } - - | otherwise - = return () -- Fast path for common case - where - pp_thing = text "instance for" <+> quotes (ppr pred) - -pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 - -isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) -isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv) - -isFilledMetaTyVar :: TcTyVar -> TcS Bool -isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) - -zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet -zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs) - -zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] -zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs) - -zonkCo :: Coercion -> TcS Coercion -zonkCo = wrapTcS . TcM.zonkCo - -zonkTcType :: TcType -> TcS TcType -zonkTcType ty = wrapTcS (TcM.zonkTcType ty) - -zonkTcTypes :: [TcType] -> TcS [TcType] -zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys) - -zonkTcTyVar :: TcTyVar -> TcS TcType -zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv) - -zonkSimples :: Cts -> TcS Cts -zonkSimples cts = wrapTcS (TcM.zonkSimples cts) - -zonkWC :: WantedConstraints -> TcS WantedConstraints -zonkWC wc = wrapTcS (TcM.zonkWC wc) - -zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar -zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv) - -{- ********************************************************************* -* * -* Flatten skolems * -* * -********************************************************************* -} - -newFlattenSkolem :: CtFlavour -> CtLoc - -> TyCon -> [TcType] -- F xis - -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk -newFlattenSkolem flav loc tc xis - = do { stuff@(ev, co, fsk) <- new_skolem - ; let fsk_ty = mkTyVarTy fsk - ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) - ; return stuff } - where - fam_ty = mkTyConApp tc xis - - new_skolem - | Given <- flav - = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty) - - -- Extend the inert_fsks list, for use by unflattenGivens - ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is } - - -- Construct the Refl evidence - ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk) - co = mkNomReflCo fam_ty - ; ev <- newGivenEvVar loc (pred, evCoercion co) - ; return (ev, co, fsk) } - - | otherwise -- Generate a [WD] for both Wanted and Derived - -- See Note [No Derived CFunEqCans] - = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty) - ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv) - ; return (ev, hole_co, fmv) } - ----------------------------- -unflattenGivens :: IORef InertSet -> TcM () --- Unflatten all the fsks created by flattening types in Given --- constraints. We must be sure to do this, else we end up with --- flatten-skolems buried in any residual Wanteds --- --- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv) --- is filled in. Nothing else does so. --- --- It's here (rather than in TcFlatten) because the Right Places --- to call it are in runTcSWithEvBinds/nestImplicTcS, where it --- is nicely paired with the creation an empty inert_fsks list. -unflattenGivens inert_var - = do { inerts <- TcM.readTcRef inert_var - ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts)) - ; mapM_ flatten_one (inert_fsks inerts) } - where - flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty - ----------------------------- -extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () -extendFlatCache tc xi_args stuff@(_, ty, fl) - | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache - -- only has [G] and [WD] CFunEqCans - = do { dflags <- getDynFlags - ; when (gopt Opt_FlatCache dflags) $ - do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args - , ppr fl, ppr ty ]) - -- 'co' can be bottom, in the case of derived items - ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> - is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } } - - | otherwise - = return () - ----------------------------- -unflattenFmv :: TcTyVar -> TcType -> TcS () --- Fill a flatten-meta-var, simply by unifying it. --- This does NOT count as a unification in tcs_unified. -unflattenFmv tv ty - = ASSERT2( isMetaTyVar tv, ppr tv ) - TcS $ \ _ -> - do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty } - ----------------------------- -demoteUnfilledFmv :: TcTyVar -> TcS () --- If a flatten-meta-var is still un-filled, --- turn it into an ordinary meta-var -demoteUnfilledFmv fmv - = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv - ; unless is_filled $ - do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) - ; TcM.writeMetaTyVar fmv tv_ty } } - ------------------------------ -dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () --- (dischargeFunEq tv co ty) --- Preconditions --- - ev :: F tys ~ tv is a CFunEqCan --- - tv is a FlatMetaTv of FlatSkolTv --- - co :: F tys ~ xi --- - fmv/fsk `notElem` xi --- - fmv not filled (for Wanteds) --- - xi is flattened (and obeys Note [Almost function-free] in TcRnTypes) --- --- Then for [W] or [WD], we actually fill in the fmv: --- set fmv := xi, --- set ev := co --- kick out any inert things that are now rewritable --- --- For [D], we instead emit an equality that must ultimately hold --- [D] xi ~ fmv --- Does not evaluate 'co' if 'ev' is Derived --- --- For [G], emit this equality --- [G] (sym ev; co) :: fsk ~ xi - --- See TcFlatten Note [The flattening story], --- especially "Ownership of fsk/fmv" -dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi - = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co ) - ; emitWorkNC [new_ev] } - where - new_pred = mkPrimEqPred (mkTyVarTy fsk) xi - new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co - -dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi - = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) - do { setWantedEvTerm dest (evCoercion co) - ; unflattenFmv fmv xi - ; n_kicked <- kickOutAfterUnification fmv - ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) } - -dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi - = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv) - -- FunEqs are always at Nominal role - -pprKicked :: Int -> SDoc -pprKicked 0 = empty -pprKicked n = parens (int n <+> text "kicked out") - -{- ********************************************************************* -* * -* Instantiation etc. -* * -********************************************************************* -} - --- Instantiations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) -instDFunType dfun_id inst_tys - = wrapTcS $ TcM.instDFunType dfun_id inst_tys - -newFlexiTcSTy :: Kind -> TcS TcType -newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) - -cloneMetaTyVar :: TcTyVar -> TcS TcTyVar -cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) - -instFlexi :: [TKVar] -> TcS TCvSubst -instFlexi = instFlexiX emptyTCvSubst - -instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst -instFlexiX subst tvs - = wrapTcS (foldlM instFlexiHelper subst tvs) - -instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst -instFlexiHelper subst tv - = do { uniq <- TcM.newUnique - ; details <- TcM.newMetaDetails TauTv - ; let name = setNameUnique (tyVarName tv) uniq - kind = substTyUnchecked subst (tyVarKind tv) - ty' = mkTyVarTy (mkTcTyVar name kind details) - ; TcM.traceTc "instFlexi" (ppr ty') - ; return (extendTvSubst subst tv ty') } - -matchGlobalInst :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcS TcM.ClsInstResult -matchGlobalInst dflags short_cut cls tys - = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) - -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs - --- Creating and setting evidence variables and CtFlavors --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data MaybeNew = Fresh CtEvidence | Cached EvExpr - -isFresh :: MaybeNew -> Bool -isFresh (Fresh {}) = True -isFresh (Cached {}) = False - -freshGoals :: [MaybeNew] -> [CtEvidence] -freshGoals mns = [ ctev | Fresh ctev <- mns ] - -getEvExpr :: MaybeNew -> EvExpr -getEvExpr (Fresh ctev) = ctEvExpr ctev -getEvExpr (Cached evt) = evt - -setEvBind :: EvBind -> TcS () -setEvBind ev_bind - = do { evb <- getTcEvBindsVar - ; wrapTcS $ TcM.addTcEvBind evb ev_bind } - --- | Mark variables as used filling a coercion hole -useVars :: CoVarSet -> TcS () -useVars co_vars - = do { ev_binds_var <- getTcEvBindsVar - ; let ref = ebv_tcvs ev_binds_var - ; wrapTcS $ - do { tcvs <- TcM.readTcRef ref - ; let tcvs' = tcvs `unionVarSet` co_vars - ; TcM.writeTcRef ref tcvs' } } - --- | Equalities only -setWantedEq :: TcEvDest -> Coercion -> TcS () -setWantedEq (HoleDest hole) co - = do { useVars (coVarsOfCo co) - ; wrapTcS $ TcM.fillCoercionHole hole co } -setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev) - --- | Good for both equalities and non-equalities -setWantedEvTerm :: TcEvDest -> EvTerm -> TcS () -setWantedEvTerm (HoleDest hole) tm - | Just co <- evTermCoercion_maybe tm - = do { useVars (coVarsOfCo co) - ; wrapTcS $ TcM.fillCoercionHole hole co } - | otherwise - = do { let co_var = coHoleCoVar hole - ; setEvBind (mkWantedEvBind co_var tm) - ; wrapTcS $ TcM.fillCoercionHole hole (mkTcCoVarCo co_var) } - -setWantedEvTerm (EvVarDest ev_id) tm - = setEvBind (mkWantedEvBind ev_id tm) - -setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () -setEvBindIfWanted ev tm - = case ev of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm - _ -> return () - -newTcEvBinds :: TcS EvBindsVar -newTcEvBinds = wrapTcS TcM.newTcEvBinds - -newNoTcEvBinds :: TcS EvBindsVar -newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds - -newEvVar :: TcPredType -> TcS EvVar -newEvVar pred = wrapTcS (TcM.newEvVar pred) - -newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence --- Make a new variable of the given PredType, --- immediately bind it to the given term --- and return its CtEvidence --- See Note [Bind new Givens immediately] in Constraint -newGivenEvVar loc (pred, rhs) - = do { new_ev <- newBoundEvVarId pred rhs - ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } - --- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the --- given term -newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar -newBoundEvVarId pred rhs - = do { new_ev <- newEvVar pred - ; setEvBind (mkGivenEvBind new_ev rhs) - ; return new_ev } - -newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] -newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts - -emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion --- | Emit a new Wanted equality into the work-list -emitNewWantedEq loc role ty1 ty2 - = do { (ev, co) <- newWantedEq loc role ty1 ty2 - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) - ; return co } - --- | Make a new equality CtEvidence -newWantedEq :: CtLoc -> Role -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq = newWantedEq_SI WDeriv - -newWantedEq_SI :: ShadowInfo -> CtLoc -> Role - -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq_SI si loc role ty1 ty2 - = do { hole <- wrapTcS $ TcM.newCoercionHole pty - ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) - ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = si - , ctev_loc = loc} - , mkHoleCo hole ) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- no equalities here. Use newWantedEq instead -newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence -newWantedEvVarNC = newWantedEvVarNC_SI WDeriv - -newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence --- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC_SI si loc pty - = do { new_ev <- newEvVar pty - ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ - pprCtLoc loc) - ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev - , ctev_nosh = si - , ctev_loc = loc })} - -newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew -newWantedEvVar = newWantedEvVar_SI WDeriv - -newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew --- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar_SI si loc pty - = do { mb_ct <- lookupInInerts loc pty - ; case mb_ct of - Just ctev - | not (isDerived ctev) - -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return $ Cached (ctEvExpr ctev) } - _ -> do { ctev <- newWantedEvVarNC_SI si loc pty - ; return (Fresh ctev) } } - -newWanted :: CtLoc -> PredType -> TcS MaybeNew --- Deals with both equalities and non equalities. Tries to look --- up non-equalities in the cache -newWanted = newWanted_SI WDeriv - -newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew -newWanted_SI si loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2 - | otherwise - = newWantedEvVar_SI si loc pty - --- deals with both equalities and non equalities. Doesn't do any cache lookups. -newWantedNC :: CtLoc -> PredType -> TcS CtEvidence -newWantedNC loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = fst <$> newWantedEq loc role ty1 ty2 - | otherwise - = newWantedEvVarNC loc pty - -emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS () -emitNewDeriveds loc preds - | null preds - = return () - | otherwise - = do { evs <- mapM (newDerivedNC loc) preds - ; traceTcS "Emitting new deriveds" (ppr evs) - ; updWorkListTcS (extendWorkListDeriveds evs) } - -emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new equality Derived and put it in the work list --- There's no caching, no lookupInInerts -emitNewDerivedEq loc role ty1 ty2 - = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2) - ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc) - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) } - -- Very important: put in the wl_eqs - -- See Note [Prioritise equalities] (Avoiding fundep iteration) - -newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence -newDerivedNC loc pred - = do { -- checkReductionDepth loc pred - ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) } - --- --------- Check done in TcInteract.selectNewWorkItem???? --------- --- | Checks if the depth of the given location is too much. Fails if --- it's too big, with an appropriate error message. -checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced - -> TcS () -checkReductionDepth loc ty - = do { dflags <- getDynFlags - ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $ - wrapErrTcS $ - solverDepthErrorTcS loc ty } - -matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType)) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFam tycon args = wrapTcS $ matchFamTcM tycon args - -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType)) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFamTcM tycon args - = do { fam_envs <- FamInst.tcGetFamInstEnvs - ; let match_fam_result - = reduceTyFamApp_maybe fam_envs Nominal tycon args - ; TcM.traceTc "matchFamTcM" $ - vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) - , ppr_res match_fam_result ] - ; return match_fam_result } - where - ppr_res Nothing = text "Match failed" - ppr_res (Just (co,ty)) = hang (text "Match succeeded:") - 2 (vcat [ text "Rewrites to:" <+> ppr ty - , text "Coercion:" <+> ppr co ]) - -{- -Note [Residual implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wl_implics in the WorkList are the residual implication -constraints that are generated while solving or canonicalising the -current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) -from which we get the implication - (forall a. t1 ~ t2) -See TcSMonad.deferTcSForAllEq --} diff --git a/typecheck/TcSigs.hs b/typecheck/TcSigs.hs deleted file mode 100644 --- a/typecheck/TcSigs.hs +++ /dev/null @@ -1,837 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-2002 - --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcSigs( - TcSigInfo(..), - TcIdSigInfo(..), TcIdSigInst, - TcPatSynInfo(..), - TcSigFun, - - isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, - completeSigPolyId_maybe, - - tcTySigs, tcUserTypeSig, completeSigFromId, - tcInstSig, - - TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, - mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcHsType -import TcRnTypes -import TcRnMonad -import TcOrigin -import TcType -import TcMType -import TcValidity ( checkValidType ) -import TcUnify( tcSkolemise, unifyType ) -import Inst( topInstantiate ) -import TcEnv( tcLookupId ) -import TcEvidence( HsWrapper, (<.>) ) -import Type( mkTyVarBinders ) - -import DynFlags -import Var ( TyVar, tyVarKind ) -import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) -import PrelNames( mkUnboundName ) -import BasicTypes -import Module( getModule ) -import Name -import NameEnv -import Outputable -import SrcLoc -import Util( singleton ) -import Maybes( orElse ) -import Data.Maybe( mapMaybe ) -import Control.Monad( unless ) - - -{- ------------------------------------------------------------- - Note [Overview of type signatures] ----------------------------------------------------------------- -Type signatures, including partial signatures, are jolly tricky, -especially on value bindings. Here's an overview. - - f :: forall a. [a] -> [a] - g :: forall b. _ -> b - - f = ...g... - g = ...f... - -* HsSyn: a signature in a binding starts off as a TypeSig, in - type HsBinds.Sig - -* When starting a mutually recursive group, like f/g above, we - call tcTySig on each signature in the group. - -* tcTySig: Sig -> TcIdSigInfo - - For a /complete/ signature, like 'f' above, tcTySig kind-checks - the HsType, producing a Type, and wraps it in a CompleteSig, and - extend the type environment with this polymorphic 'f'. - - - For a /partial/signature, like 'g' above, tcTySig does nothing - Instead it just wraps the pieces in a PartialSig, to be handled - later. - -* tcInstSig: TcIdSigInfo -> TcIdSigInst - In tcMonoBinds, when looking at an individual binding, we use - tcInstSig to instantiate the signature forall's in the signature, - and attribute that instantiated (monomorphic) type to the - binder. You can see this in TcBinds.tcLhsId. - - The instantiation does the obvious thing for complete signatures, - but for /partial/ signatures it starts from the HsSyn, so it - has to kind-check it etc: tcHsPartialSigType. It's convenient - to do this at the same time as instantiation, because we can - make the wildcards into unification variables right away, raather - than somehow quantifying over them. And the "TcLevel" of those - unification variables is correct because we are in tcMonoBinds. - - -Note [Scoped tyvars] -~~~~~~~~~~~~~~~~~~~~ -The -XScopedTypeVariables flag brings lexically-scoped type variables -into scope for any explicitly forall-quantified type variables: - f :: forall a. a -> a - f x = e -Then 'a' is in scope inside 'e'. - -However, we do *not* support this - - For pattern bindings e.g - f :: forall a. a->a - (f,g) = e - -Note [Binding scoped type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type variables *brought into lexical scope* by a type signature -may be a subset of the *quantified type variables* of the signatures, -for two reasons: - -* With kind polymorphism a signature like - f :: forall f a. f a -> f a - may actually give rise to - f :: forall k. forall (f::k -> *) (a:k). f a -> f a - So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *inital* ones! - -* Even aside from kind polymorphism, there may be more instantiated - type variables than lexically-scoped ones. For example: - type T a = forall b. b -> (a,b) - f :: forall c. T c - Here, the signature for f will have one scoped type variable, c, - but two instantiated type variables, c' and b'. - -However, all of this only applies to the renamer. The typechecker -just puts all of them into the type environment; any lexical-scope -errors were dealt with by the renamer. - --} - - -{- ********************************************************************* -* * - Utility functions for TcSigInfo -* * -********************************************************************* -} - -tcIdSigName :: TcIdSigInfo -> Name -tcIdSigName (CompleteSig { sig_bndr = id }) = idName id -tcIdSigName (PartialSig { psig_name = n }) = n - -tcSigInfoName :: TcSigInfo -> Name -tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi -tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi - -completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId -completeSigPolyId_maybe sig - | TcIdSig sig_info <- sig - , CompleteSig { sig_bndr = id } <- sig_info = Just id - | otherwise = Nothing - - -{- ********************************************************************* -* * - Typechecking user signatures -* * -********************************************************************* -} - -tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) -tcTySigs hs_sigs - = checkNoErrs $ - do { -- Fail if any of the signatures is duff - -- Hence mapAndReportM - -- See Note [Fail eagerly on bad signatures] - ty_sigs_s <- mapAndReportM tcTySig hs_sigs - - ; let ty_sigs = concat ty_sigs_s - poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs - -- The returned [TcId] are the ones for which we have - -- a complete type signature. - -- See Note [Complete and partial type signatures] - env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] - - ; return (poly_ids, lookupNameEnv env) } - -tcTySig :: LSig GhcRn -> TcM [TcSigInfo] -tcTySig (L _ (IdSig _ id)) - = do { let ctxt = FunSigCtxt (idName id) False - -- False: do not report redundant constraints - -- The user has no control over the signature! - sig = completeSigFromId ctxt id - ; return [TcIdSig sig] } - -tcTySig (L loc (TypeSig _ names sig_ty)) - = setSrcSpan loc $ - do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) - | L _ name <- names ] - ; return (map TcIdSig sigs) } - -tcTySig (L loc (PatSynSig _ names sig_ty)) - = setSrcSpan loc $ - do { tpsigs <- sequence [ tcPatSynSig name sig_ty - | L _ name <- names ] - ; return (map TcPatSynSig tpsigs) } - -tcTySig _ = return [] - - -tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name - -> TcM TcIdSigInfo --- A function or expression type signature --- Returns a fully quantified type signature; even the wildcards --- are quantified with ordinary skolems that should be instantiated --- --- The SrcSpan is what to declare as the binding site of the --- any skolems in the signature. For function signatures we --- use the whole `f :: ty' signature; for expression signatures --- just the type part. --- --- Just n => Function type signature name :: type --- Nothing => Expression type signature :: type -tcUserTypeSig loc hs_sig_ty mb_name - | isCompleteHsSig hs_sig_ty - = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty - ; traceTc "tcuser" (ppr sigma_ty) - ; return $ - CompleteSig { sig_bndr = mkLocalId name sigma_ty - , sig_ctxt = ctxt_T - , sig_loc = loc } } - -- Location of the in f :: - - -- Partial sig with wildcards - | otherwise - = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty - , sig_ctxt = ctxt_F, sig_loc = loc }) - where - name = case mb_name of - Just n -> n - Nothing -> mkUnboundName (mkVarOcc "") - ctxt_F = case mb_name of - Just n -> FunSigCtxt n False - Nothing -> ExprSigCtxt - ctxt_T = case mb_name of - Just n -> FunSigCtxt n True - Nothing -> ExprSigCtxt - - - -completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo --- Used for instance methods and record selectors -completeSigFromId ctxt id - = CompleteSig { sig_bndr = id - , sig_ctxt = ctxt - , sig_loc = getSrcSpan id } - -isCompleteHsSig :: LHsSigWcType GhcRn -> Bool --- ^ If there are no wildcards, return a LHsSigType -isCompleteHsSig (HsWC { hswc_ext = wcs - , hswc_body = HsIB { hsib_body = hs_ty } }) - = null wcs && no_anon_wc hs_ty -isCompleteHsSig (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -isCompleteHsSig (XHsWildCardBndrs nec) = noExtCon nec - -no_anon_wc :: LHsType GhcRn -> Bool -no_anon_wc lty = go lty - where - go (L _ ty) = case ty of - HsWildCardTy _ -> False - HsAppTy _ ty1 ty2 -> go ty1 && go ty2 - HsAppKindTy _ ty ki -> go ty && go ki - HsFunTy _ ty1 ty2 -> go ty1 && go ty2 - HsListTy _ ty -> go ty - HsTupleTy _ _ tys -> gos tys - HsSumTy _ tys -> gos tys - HsOpTy _ ty1 _ ty2 -> go ty1 && go ty2 - HsParTy _ ty -> go ty - HsIParamTy _ _ ty -> go ty - HsKindSig _ ty kind -> go ty && go kind - HsDocTy _ ty _ -> go ty - HsBangTy _ _ ty -> go ty - HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys - HsForAllTy { hst_bndrs = bndrs - , hst_body = ty } -> no_anon_wc_bndrs bndrs - && go ty - HsQualTy { hst_ctxt = L _ ctxt - , hst_body = ty } -> gos ctxt && go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty - HsSpliceTy{} -> True - HsTyLit{} -> True - HsTyVar{} -> True - HsStarTy{} -> True - XHsType{} -> True -- Core type, which does not have any wildcard - - gos = all go - -no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool -no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs - where - go (UserTyVar _ _) = True - go (KindedTyVar _ _ ki) = no_anon_wc ki - go (XTyVarBndr nec) = noExtCon nec - -{- Note [Fail eagerly on bad signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a type signature is wrong, fail immediately: - - * the type sigs may bind type variables, so proceeding without them - can lead to a cascade of errors - - * the type signature might be ambiguous, in which case checking - the code against the signature will give a very similar error - to the ambiguity error. - -ToDo: this means we fall over if any top-level type signature in the -module is wrong, because we typecheck all the signatures together -(see TcBinds.tcValBinds). Moreover, because of top-level -captureTopConstraints, only insoluble constraints will be reported. -We typecheck all signatures at the same time because a signature -like f,g :: blah might have f and g from different SCCs. - -So it's a bit awkward to get better error recovery, and no one -has complained! --} - -{- ********************************************************************* -* * - Type checking a pattern synonym signature -* * -************************************************************************ - -Note [Pattern synonym signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Pattern synonym signatures are surprisingly tricky (see #11224 for example). -In general they look like this: - - pattern P :: forall univ_tvs. req_theta - => forall ex_tvs. prov_theta - => arg1 -> .. -> argn -> res_ty - -For parsing and renaming we treat the signature as an ordinary LHsSigType. - -Once we get to type checking, we decompose it into its parts, in tcPatSynSig. - -* Note that 'forall univ_tvs' and 'req_theta =>' - and 'forall ex_tvs' and 'prov_theta =>' - are all optional. We gather the pieces at the top of tcPatSynSig - -* Initially the implicitly-bound tyvars (added by the renamer) include both - universal and existential vars. - -* After we kind-check the pieces and convert to Types, we do kind generalisation. - -Note [solveEqualities in tcPatSynSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important that we solve /all/ the equalities in a pattern -synonym signature, because we are going to zonk the signature to -a Type (not a TcType), in TcPatSyn.tc_patsyn_finish, and that -fails if there are un-filled-in coercion variables mentioned -in the type (#15694). - -The best thing is simply to use solveEqualities to solve all the -equalites, rather than leaving them in the ambient constraints -to be solved later. Pattern synonyms are top-level, so there's -no problem with completely solving them. - -(NB: this solveEqualities wraps newImplicitTKBndrs, which itself -does a solveLocalEqualities; so solveEqualities isn't going to -make any further progress; it'll just report any unsolved ones, -and fail, as it should.) --} - -tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo --- See Note [Pattern synonym signatures] --- See Note [Recipe for checking a signature] in TcHsType -tcPatSynSig name sig_ty - | HsIB { hsib_ext = implicit_hs_tvs - , hsib_body = hs_ty } <- sig_ty - , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty - , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 - = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty)))) - <- pushTcLevelM_ $ - solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] - bindImplicitTKBndrs_Skol implicit_hs_tvs $ - bindExplicitTKBndrs_Skol univ_hs_tvs $ - bindExplicitTKBndrs_Skol ex_hs_tvs $ - do { req <- tcHsContext hs_req - ; prov <- tcHsContext hs_prov - ; body_ty <- tcHsOpenType hs_body_ty - -- A (literal) pattern can be unlifted; - -- e.g. pattern Zero <- 0# (#12094) - ; return (req, prov, body_ty) } - - ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs - req ex_tvs prov body_ty - - -- Kind generalisation - ; kvs <- kindGeneralizeAll ungen_patsyn_ty - ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) - - -- These are /signatures/ so we zonk to squeeze out any kind - -- unification variables. Do this after kindGeneralize which may - -- default kind variables to *. - ; implicit_tvs <- zonkAndScopedSort implicit_tvs - ; univ_tvs <- mapM zonkTyCoVarKind univ_tvs - ; ex_tvs <- mapM zonkTyCoVarKind ex_tvs - ; req <- zonkTcTypes req - ; prov <- zonkTcTypes prov - ; body_ty <- zonkTcType body_ty - - -- Skolems have TcLevels too, though they're used only for debugging. - -- If you don't do this, the debugging checks fail in TcPatSyn. - -- Test case: patsyn/should_compile/T13441 -{- - ; tclvl <- getTcLevel - ; let env0 = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs - (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs - (env2, univ_tvs') = promoteSkolemsX tclvl env1 univ_tvs - (env3, ex_tvs') = promoteSkolemsX tclvl env2 ex_tvs - req' = substTys env3 req - prov' = substTys env3 prov - body_ty' = substTy env3 body_ty --} - ; let implicit_tvs' = implicit_tvs - univ_tvs' = univ_tvs - ex_tvs' = ex_tvs - req' = req - prov' = prov - body_ty' = body_ty - - -- Now do validity checking - ; checkValidType ctxt $ - build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty' - - -- arguments become the types of binders. We thus cannot allow - -- levity polymorphism here - ; let (arg_tys, _) = tcSplitFunTys body_ty' - ; mapM_ (checkForLevPoly empty) arg_tys - - ; traceTc "tcTySig }" $ - vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' - , text "kvs" <+> ppr_tvs kvs - , text "univ_tvs" <+> ppr_tvs univ_tvs' - , text "req" <+> ppr req' - , text "ex_tvs" <+> ppr_tvs ex_tvs' - , text "prov" <+> ppr prov' - , text "body_ty" <+> ppr body_ty' ] - ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ - mkTyVarBinders Specified implicit_tvs' - , patsig_univ_bndrs = univ_tvs' - , patsig_req = req' - , patsig_ex_bndrs = ex_tvs' - , patsig_prov = prov' - , patsig_body_ty = body_ty' }) } - where - ctxt = PatSynCtxt name - - build_patsyn_type kvs imp univ req ex prov body - = mkInvForAllTys kvs $ - mkSpecForAllTys (imp ++ univ) $ - mkPhiTy req $ - mkSpecForAllTys ex $ - mkPhiTy prov $ - body -tcPatSynSig _ (XHsImplicitBndrs nec) = noExtCon nec - -ppr_tvs :: [TyVar] -> SDoc -ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) - | tv <- tvs]) - - -{- ********************************************************************* -* * - Instantiating user signatures -* * -********************************************************************* -} - - -tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst --- Instantiate a type signature; only used with plan InferGen -tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id - -- See Note [Pattern bindings and complete signatures] - - ; return (TISI { sig_inst_sig = sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = [] - , sig_inst_wcx = Nothing - , sig_inst_theta = theta - , sig_inst_tau = tau }) } - -tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty - , sig_ctxt = ctxt - , sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { traceTc "Staring partial sig {" (ppr hs_sig) - ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty - -- See Note [Checking partial type signatures] in TcHsType - ; let inst_sig = TISI { sig_inst_sig = hs_sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = wcs - , sig_inst_wcx = wcx - , sig_inst_theta = theta - , sig_inst_tau = tau } - ; traceTc "End partial sig }" (ppr inst_sig) - ; return inst_sig } - - -{- Note [Pattern bindings and complete signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = MkT a a - f :: forall a. a->a - g :: forall b. b->b - MkT f g = MkT (\x->x) (\y->y) -Here we'll infer a type from the pattern of 'T a', but if we feed in -the signature types for f and g, we'll end up unifying 'a' and 'b' - -So we instantiate f and g's signature with TyVarTv skolems -(newMetaTyVarTyVars) that can unify with each other. If too much -unification takes place, we'll find out when we do the final -impedance-matching check in TcBinds.mkExport - -See Note [Signature skolems] in TcType - -None of this applies to a function binding with a complete -signature, which doesn't use tcInstSig. See TcBinds.tcPolyCheck. --} - -{- ********************************************************************* -* * - Pragmas and PragEnv -* * -********************************************************************* -} - -type TcPragEnv = NameEnv [LSig GhcRn] - -emptyPragEnv :: TcPragEnv -emptyPragEnv = emptyNameEnv - -lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] -lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] - -extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv -extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig - ---------------- -mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv -mkPragEnv sigs binds - = foldl' extendPragEnv emptyNameEnv prs - where - prs = mapMaybe get_sig sigs - - get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) - get_sig (L l (SpecSig x lnm@(L _ nm) ty inl)) - = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl)) - get_sig (L l (InlineSig x lnm@(L _ nm) inl)) - = Just (nm, L l $ InlineSig x lnm (add_arity nm inl)) - get_sig (L l (SCCFunSig x st lnm@(L _ nm) str)) - = Just (nm, L l $ SCCFunSig x st lnm str) - get_sig _ = Nothing - - add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function - | Inline <- inl_inline inl_prag - -- add arity only for real INLINE pragmas, not INLINABLE - = case lookupNameEnv ar_env n of - Just ar -> inl_prag { inl_sat = Just ar } - Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) - -- There really should be a binding for every INLINE pragma - inl_prag - | otherwise - = inl_prag - - -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldr lhsBindArity emptyNameEnv binds - -lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind - - ------------------ -addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId -addInlinePrags poly_id prags_for_me - | inl@(L _ prag) : inls <- inl_prags - = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) - ; unless (null inls) (warn_multiple_inlines inl inls) - ; return (poly_id `setInlinePragma` prag) } - | otherwise - = return poly_id - where - inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] - - warn_multiple_inlines _ [] = return () - - warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) - | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 - , noUserInlineSpec (inlinePragmaSpec prag1) - = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop - -- and inl2 is a user NOINLINE pragma; we don't want to complain - warn_multiple_inlines inl2 inls - | otherwise - = setSrcSpan loc $ - addWarnTc NoReason - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) - - pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - - -{- ********************************************************************* -* * - SPECIALISE pragmas -* * -************************************************************************ - -Note [Handling SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is this: - - foo :: Num a => a -> b -> a - {-# SPECIALISE foo :: Int -> b -> Int #-} - -We check that - (forall a b. Num a => a -> b -> a) - is more polymorphic than - forall b. Int -> b -> Int -(for which we could use tcSubType, but see below), generating a HsWrapper -to connect the two, something like - wrap = /\b. Int b dNumInt -This wrapper is put in the TcSpecPrag, in the ABExport record of -the AbsBinds. - - f :: (Eq a, Ix b) => a -> b -> Bool - {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} - f = - -From this the typechecker generates - - AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds - - SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX - -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) - -From these we generate: - - Rule: forall p, q, (dp:Ix p), (dq:Ix q). - f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq - - Spec bind: f_spec = wrap_fn - -Note that - - * The LHS of the rule may mention dictionary *expressions* (eg - $dfIxPair dp dq), and that is essential because the dp, dq are - needed on the RHS. - - * The RHS of f_spec, has a *copy* of 'binds', so that it - can fully specialise it. - -From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE: - - f_spec :: Int -> b -> Int - f_spec = wrap - - RULE: forall b (d:Num b). f b d = f_spec b - -The RULE is generated by taking apart the HsWrapper, which is a little -delicate, but works. - -Some wrinkles - -1. We don't use full-on tcSubType, because that does co and contra - variance and that in turn will generate too complex a LHS for the - RULE. So we use a single invocation of skolemise / - topInstantiate in tcSpecWrapper. (Actually I think that even - the "deeply" stuff may be too much, because it introduces lambdas, - though I think it can be made to work without too much trouble.) - -2. We need to take care with type families (#5821). Consider - type instance F Int = Bool - f :: Num a => a -> F a - {-# SPECIALISE foo :: Int -> Bool #-} - - We *could* try to generate an f_spec with precisely the declared type: - f_spec :: Int -> Bool - f_spec = Int dNumInt |> co - - RULE: forall d. f Int d = f_spec |> sym co - - but the 'co' and 'sym co' are (a) playing no useful role, and (b) are - hard to generate. At all costs we must avoid this: - RULE: forall d. f Int d |> co = f_spec - because the LHS will never match (indeed it's rejected in - decomposeRuleLhs). - - So we simply do this: - - Generate a constraint to check that the specialised type (after - skolemisation) is equal to the instantiated function type. - - But *discard* the evidence (coercion) for that constraint, - so that we ultimately generate the simpler code - f_spec :: Int -> F Int - f_spec = Int dNumInt - - RULE: forall d. f Int d = f_spec - You can see this discarding happening in tcSpecPrag - -3. Note that the HsWrapper can transform *any* function with the right - type prefix - forall ab. (Eq a, Ix b) => XXX - regardless of XXX. It's sort of polymorphic in XXX. This is - useful: we use the same wrapper to transform each of the class ops, as - well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags --} - -tcSpecPrags :: Id -> [LSig GhcRn] - -> TcM [LTcSpecPrag] --- Add INLINE and SPECIALSE pragmas --- INLINE prags are added to the (polymorphic) Id directly --- SPECIALISE prags are passed to the desugarer via TcSpecPrags --- Pre-condition: the poly_id is zonked --- Reason: required by tcSubExp -tcSpecPrags poly_id prag_sigs - = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) - ; unless (null bad_sigs) warn_discarded_sigs - ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } - where - spec_sigs = filter isSpecLSig prag_sigs - bad_sigs = filter is_bad_sig prag_sigs - is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) - - warn_discarded_sigs - = addWarnTc NoReason - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) - --------------- -tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] -tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) --- See Note [Handling SPECIALISE pragmas] --- --- The Name fun_name in the SpecSig may not be the same as that of the poly_id --- Example: SPECIALISE for a class method: the Name in the SpecSig is --- for the selector Id, but the poly_id is something like $cop --- However we want to use fun_name in the error message, since that is --- what the user wrote (#8537) - = addErrCtxt (spec_ctxt prag) $ - do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) - -- Note [SPECIALISE pragmas] - ; spec_prags <- mapM tc_one hs_tys - ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) - ; return spec_prags } - where - name = idName poly_id - poly_ty = idType poly_id - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) - - tc_one hs_ty - = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty - ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty - ; return (SpecPrag poly_id wrap inl) } - -tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) - --------------- -tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper --- A simpler variant of tcSubType, used for SPECIALISE pragmas --- See Note [Handling SPECIALISE pragmas], wrinkle 1 -tcSpecWrapper ctxt poly_ty spec_ty - = do { (sk_wrap, inst_wrap) - <- tcSkolemise ctxt spec_ty $ \ _ spec_tau -> - do { (inst_wrap, tau) <- topInstantiate orig poly_ty - ; _ <- unifyType Nothing spec_tau tau - -- Deliberately ignore the evidence - -- See Note [Handling SPECIALISE pragmas], - -- wrinkle (2) - ; return inst_wrap } - ; return (sk_wrap <.> inst_wrap) } - where - orig = SpecPragOrigin ctxt - --------------- -tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] --- SPECIALISE pragmas for imported things -tcImpPrags prags - = do { this_mod <- getModule - ; dflags <- getDynFlags - ; if (not_specialising dflags) then - return [] - else do - { pss <- mapAndRecoverM (wrapLocM tcImpSpec) - [L loc (name,prag) - | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags - , not (nameIsLocalOrFrom this_mod name) ] - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } - where - -- Ignore SPECIALISE pragmas for imported things - -- when we aren't specialising, or when we aren't generating - -- code. The latter happens when Haddocking the base library; - -- we don't want complaints about lack of INLINABLE pragmas - not_specialising dflags - | not (gopt Opt_Specialise dflags) = True - | otherwise = case hscTarget dflags of - HscNothing -> True - HscInterpreted -> True - _other -> False - -tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] -tcImpSpec (name, prag) - = do { id <- tcLookupId name - ; if isAnyInlinePragma (idInlinePragma id) - then tcSpecPrag id prag - else do { addWarnTc NoReason (impSpecErr name) - ; return [] } } - -- If there is no INLINE/INLINABLE pragma there will be no unfolding. In - -- that case, just delete the SPECIALISE pragma altogether, lest the - -- desugarer fall over because it can't find the unfolding. See #18118. - -impSpecErr :: Name -> SDoc -impSpecErr name - = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" - , parens $ sep - [ text "or its defining module" <+> quotes (ppr mod) - , text "was compiled without -O"]]) - where - mod = nameModule name diff --git a/typecheck/TcSimplify.hs b/typecheck/TcSimplify.hs deleted file mode 100644 --- a/typecheck/TcSimplify.hs +++ /dev/null @@ -1,2739 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcSimplify( - simplifyInfer, InferMode(..), - growThetaTyVars, - simplifyAmbiguityCheck, - simplifyDefault, - simplifyTop, simplifyTopImplic, - simplifyInteractive, - solveEqualities, solveLocalEqualities, solveLocalEqualitiesX, - simplifyWantedsTcM, - tcCheckSatisfiability, - tcNormalise, - - captureTopConstraints, - - simpl_top, - - promoteTyVar, - promoteTyVarSet, - - -- For Rules we need these - solveWanteds, solveWantedsAndDrop, - approximateWC, runTcSDeriveds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import Class ( Class, classKey, classTyCon ) -import DynFlags -import GHC.Hs.Expr ( UnboundVar(..) ) -import Id ( idType, mkLocalId ) -import Inst -import ListSetOps -import Name -import Outputable -import PrelInfo -import PrelNames -import RdrName ( emptyGlobalRdrEnv ) -import TcErrors -import TcEvidence -import TcInteract -import TcCanonical ( makeSuperClasses, solveCallStack ) -import TcMType as TcM -import TcRnMonad as TcM -import TcSMonad as TcS -import Constraint -import Predicate -import TcOrigin -import TcType -import Type -import TysWiredIn ( liftedRepTy ) -import Unify ( tcMatchTyKi ) -import Util -import Var -import VarSet -import UniqSet -import BasicTypes ( IntWithInf, intGtLimit ) -import ErrUtils ( emptyMessages ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import Maybes ( isJust ) - -{- -********************************************************************************* -* * -* External interface * -* * -********************************************************************************* --} - -captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureTopConstraints m) runs m, and returns the type constraints it --- generates plus the constraints produced by static forms inside. --- If it fails with an exception, it reports any insolubles --- (out of scope variables) before doing so --- --- captureTopConstraints is used exclusively by TcRnDriver at the top --- level of a module. --- --- Importantly, if captureTopConstraints propagates an exception, it --- reports any insoluble constraints first, lest they be lost --- altogether. This is important, because solveLocalEqualities (maybe --- other things too) throws an exception without adding any error --- messages; it just puts the unsolved constraints back into the --- monad. See TcRnMonad Note [Constraints and errors] --- #16376 is an example of what goes wrong if you don't do this. --- --- NB: the caller should bring any environments into scope before --- calling this, so that the reportUnsolved has access to the most --- complete GlobalRdrEnv -captureTopConstraints thing_inside - = do { static_wc_var <- TcM.newTcRef emptyWC ; - ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ - TcM.tryCaptureConstraints thing_inside - ; stWC <- TcM.readTcRef static_wc_var - - -- See TcRnMonad Note [Constraints and errors] - -- If the thing_inside threw an exception, but generated some insoluble - -- constraints, report the latter before propagating the exception - -- Otherwise they will be lost altogether - ; case mb_res of - Just res -> return (res, lie `andWC` stWC) - Nothing -> do { _ <- simplifyTop lie; failM } } - -- This call to simplifyTop is the reason - -- this function is here instead of TcRnMonad - -- We call simplifyTop so that it does defaulting - -- (esp of runtime-reps) before reporting errors - -simplifyTopImplic :: Bag Implication -> TcM () -simplifyTopImplic implics - = do { empty_binds <- simplifyTop (mkImplicWC implics) - - -- Since all the inputs are implications the returned bindings will be empty - ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds ) - - ; return () } - -simplifyTop :: WantedConstraints -> TcM (Bag EvBind) --- Simplify top-level constraints --- Usually these will be implications, --- but when there is nothing to quantify we don't wrap --- in a degenerate implication, so we do that here instead -simplifyTop wanteds - = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds - ; ((final_wc, unsafe_ol), binds1) <- runTcS $ - do { final_wc <- simpl_top wanteds - ; unsafe_ol <- getSafeOverlapFailures - ; return (final_wc, unsafe_ol) } - ; traceTc "End simplifyTop }" empty - - ; binds2 <- reportUnsolved final_wc - - ; traceTc "reportUnsolved (unsafe overlapping) {" empty - ; unless (isEmptyCts unsafe_ol) $ do { - -- grab current error messages and clear, warnAllUnsolved will - -- update error messages which we'll grab and then restore saved - -- messages. - ; errs_var <- getErrsVar - ; saved_msg <- TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var emptyMessages - - ; warnAllUnsolved $ WC { wc_simple = unsafe_ol - , wc_impl = emptyBag } - - ; whyUnsafe <- fst <$> TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var saved_msg - ; recordUnsafeInfer whyUnsafe - } - ; traceTc "reportUnsolved (unsafe overlapping) }" empty - - ; return (evBindMapBinds binds1 `unionBags` binds2) } - - --- | Type-check a thing that emits only equality constraints, solving any --- constraints we can and re-emitting constraints that we can't. The thing_inside --- should generally bump the TcLevel to make sure that this run of the solver --- doesn't affect anything lying around. -solveLocalEqualities :: String -> TcM a -> TcM a -solveLocalEqualities callsite thing_inside - = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside - ; emitConstraints wanted - - -- See Note [Fail fast if there are insoluble kind equalities] - ; when (insolubleWC wanted) $ - failM - - ; return res } - -{- Note [Fail fast if there are insoluble kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather like in simplifyInfer, fail fast if there is an insoluble -constraint. Otherwise we'll just succeed in kind-checking a nonsense -type, with a cascade of follow-up errors. - -For example polykinds/T12593, T15577, and many others. - -Take care to ensure that you emit the insoluble constraints before -failing, because they are what will ulimately lead to the error -messsage! --} - -solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) -solveLocalEqualitiesX callsite thing_inside - = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) - - ; (result, wanted) <- captureConstraints thing_inside - - ; traceTc "solveLocalEqualities: running solver" (ppr wanted) - ; residual_wanted <- runTcSEqualities (solveWanteds wanted) - - ; traceTc "solveLocalEqualitiesX end }" $ - text "residual_wanted =" <+> ppr residual_wanted - - ; return (residual_wanted, result) } - --- | Type-check a thing that emits only equality constraints, then --- solve those constraints. Fails outright if there is trouble. --- Use this if you're not going to get another crack at solving --- (because, e.g., you're checking a datatype declaration) -solveEqualities :: TcM a -> TcM a -solveEqualities thing_inside - = checkNoErrs $ -- See Note [Fail fast on kind errors] - do { lvl <- TcM.getTcLevel - ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl) - - ; (result, wanted) <- captureConstraints thing_inside - - ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted - ; final_wc <- runTcSEqualities $ simpl_top wanted - -- NB: Use simpl_top here so that we potentially default RuntimeRep - -- vars to LiftedRep. This is needed to avoid #14991. - - ; traceTc "End solveEqualities }" empty - ; reportAllUnsolved final_wc - ; return result } - --- | Simplify top-level constraints, but without reporting any unsolved --- constraints nor unsafe overlapping. -simpl_top :: WantedConstraints -> TcS WantedConstraints - -- See Note [Top-level Defaulting Plan] -simpl_top wanteds - = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) - -- This is where the main work happens - ; dflags <- getDynFlags - ; try_tyvar_defaulting dflags wc_first_go } - where - try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints - try_tyvar_defaulting dflags wc - | isEmptyWC wc - = return wc - | insolubleWC wc - , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] - = try_class_defaulting wc - | otherwise - = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) - ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs - -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked - -- filter isMetaTyVar: we might have runtime-skolems in GHCi, - -- and we definitely don't want to try to assign to those! - -- The isTyVar is needed to weed out coercion variables - - ; defaulted <- mapM defaultTyVarTcS meta_tvs -- Has unification side effects - ; if or defaulted - then do { wc_residual <- nestTcS (solveWanteds wc) - -- See Note [Must simplify after defaulting] - ; try_class_defaulting wc_residual } - else try_class_defaulting wc } -- No defaulting took place - - try_class_defaulting :: WantedConstraints -> TcS WantedConstraints - try_class_defaulting wc - | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] - = return wc - | otherwise -- See Note [When to do type-class defaulting] - = do { something_happened <- applyDefaultingRules wc - -- See Note [Top-level Defaulting Plan] - ; if something_happened - then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) - ; try_class_defaulting wc_residual } - -- See Note [Overview of implicit CallStacks] in TcEvidence - else try_callstack_defaulting wc } - - try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints - try_callstack_defaulting wc - | isEmptyWC wc - = return wc - | otherwise - = defaultCallStacks wc - --- | Default any remaining @CallStack@ constraints to empty @CallStack@s. -defaultCallStacks :: WantedConstraints -> TcS WantedConstraints --- See Note [Overview of implicit CallStacks] in TcEvidence -defaultCallStacks wanteds - = do simples <- handle_simples (wc_simple wanteds) - mb_implics <- mapBagM handle_implic (wc_impl wanteds) - return (wanteds { wc_simple = simples - , wc_impl = catBagMaybes mb_implics }) - - where - - handle_simples simples - = catBagMaybes <$> mapBagM defaultCallStack simples - - handle_implic :: Implication -> TcS (Maybe Implication) - -- The Maybe is because solving the CallStack constraint - -- may well allow us to discard the implication entirely - handle_implic implic - | isSolvedStatus (ic_status implic) - = return (Just implic) - | otherwise - = do { wanteds <- setEvBindsTcS (ic_binds implic) $ - -- defaultCallStack sets a binding, so - -- we must set the correct binding group - defaultCallStacks (ic_wanted implic) - ; setImplicationStatus (implic { ic_wanted = wanteds }) } - - defaultCallStack ct - | ClassPred cls tys <- classifyPredType (ctPred ct) - , Just {} <- isCallStackPred cls tys - = do { solveCallStack (ctEvidence ct) EvCsEmpty - ; return Nothing } - - defaultCallStack ct - = return (Just ct) - - -{- Note [Fail fast on kind errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -solveEqualities is used to solve kind equalities when kind-checking -user-written types. If solving fails we should fail outright, rather -than just accumulate an error message, for two reasons: - - * A kind-bogus type signature may cause a cascade of knock-on - errors if we let it pass - - * More seriously, we don't have a convenient term-level place to add - deferred bindings for unsolved kind-equality constraints, so we - don't build evidence bindings (by usine reportAllUnsolved). That - means that we'll be left with with a type that has coercion holes - in it, something like - |> co-hole - where co-hole is not filled in. Eeek! That un-filled-in - hole actually causes GHC to crash with "fvProv falls into a hole" - See #11563, #11520, #11516, #11399 - -So it's important to use 'checkNoErrs' here! - -Note [When to do type-class defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC -was false, on the grounds that defaulting can't help solve insoluble -constraints. But if we *don't* do defaulting we may report a whole -lot of errors that would be solved by defaulting; these errors are -quite spurious because fixing the single insoluble error means that -defaulting happens again, which makes all the other errors go away. -This is jolly confusing: #9033. - -So it seems better to always do type-class defaulting. - -However, always doing defaulting does mean that we'll do it in -situations like this (#5934): - run :: (forall s. GenST s) -> Int - run = fromInteger 0 -We don't unify the return type of fromInteger with the given function -type, because the latter involves foralls. So we're left with - (Num alpha, alpha ~ (forall s. GenST s) -> Int) -Now we do defaulting, get alpha := Integer, and report that we can't -match Integer with (forall s. GenST s) -> Int. That's not totally -stupid, but perhaps a little strange. - -Another potential alternative would be to suppress *all* non-insoluble -errors if there are *any* insoluble errors, anywhere, but that seems -too drastic. - -Note [Must simplify after defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a deeply buried constraint - (t:*) ~ (a:Open) -which we couldn't solve because of the kind incompatibility, and 'a' is free. -Then when we default 'a' we can solve the constraint. And we want to do -that before starting in on type classes. We MUST do it before reporting -errors, because it isn't an error! #7967 was due to this. - -Note [Top-level Defaulting Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have considered two design choices for where/when to apply defaulting. - (i) Do it in SimplCheck mode only /whenever/ you try to solve some - simple constraints, maybe deep inside the context of implications. - This used to be the case in GHC 7.4.1. - (ii) Do it in a tight loop at simplifyTop, once all other constraints have - finished. This is the current story. - -Option (i) had many disadvantages: - a) Firstly, it was deep inside the actual solver. - b) Secondly, it was dependent on the context (Infer a type signature, - or Check a type signature, or Interactive) since we did not want - to always start defaulting when inferring (though there is an exception to - this, see Note [Default while Inferring]). - c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: - f :: Int -> Bool - f x = const True (\y -> let w :: a -> a - w a = const a (y+1) - in w y) - We will get an implication constraint (for beta the type of y): - [untch=beta] forall a. 0 => Num beta - which we really cannot default /while solving/ the implication, since beta is - untouchable. - -Instead our new defaulting story is to pull defaulting out of the solver loop and -go with option (ii), implemented at SimplifyTop. Namely: - - First, have a go at solving the residual constraint of the whole - program - - Try to approximate it with a simple constraint - - Figure out derived defaulting equations for that simple constraint - - Go round the loop again if you did manage to get some equations - -Now, that has to do with class defaulting. However there exists type variable /kind/ -defaulting. Again this is done at the top-level and the plan is: - - At the top-level, once you had a go at solving the constraint, do - figure out /all/ the touchable unification variables of the wanted constraints. - - Apply defaulting to their kinds - -More details in Note [DefaultTyVar]. - -Note [Safe Haskell Overlapping Instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Safe Haskell, we apply an extra restriction to overlapping instances. The -motive is to prevent untrusted code provided by a third-party, changing the -behavior of trusted code through type-classes. This is due to the global and -implicit nature of type-classes that can hide the source of the dictionary. - -Another way to state this is: if a module M compiles without importing another -module N, changing M to import N shouldn't change the behavior of M. - -Overlapping instances with type-classes can violate this principle. However, -overlapping instances aren't always unsafe. They are just unsafe when the most -selected dictionary comes from untrusted code (code compiled with -XSafe) and -overlaps instances provided by other modules. - -In particular, in Safe Haskell at a call site with overlapping instances, we -apply the following rule to determine if it is a 'unsafe' overlap: - - 1) Most specific instance, I1, defined in an `-XSafe` compiled module. - 2) I1 is an orphan instance or a MPTC. - 3) At least one overlapped instance, Ix, is both: - A) from a different module than I1 - B) Ix is not marked `OVERLAPPABLE` - -This is a slightly involved heuristic, but captures the situation of an -imported module N changing the behavior of existing code. For example, if -condition (2) isn't violated, then the module author M must depend either on a -type-class or type defined in N. - -Secondly, when should these heuristics be enforced? We enforced them when the -type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. -This allows `-XUnsafe` modules to operate without restriction, and for Safe -Haskell inferrence to infer modules with unsafe overlaps as unsafe. - -One alternative design would be to also consider if an instance was imported as -a `safe` import or not and only apply the restriction to instances imported -safely. However, since instances are global and can be imported through more -than one path, this alternative doesn't work. - -Note [Safe Haskell Overlapping Instances Implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -How is this implemented? It's complicated! So we'll step through it all: - - 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where - we check if a particular type-class method call is safe or unsafe. We do this - through the return type, `ClsInstLookupResult`, where the last parameter is a - list of instances that are unsafe to overlap. When the method call is safe, - the list is null. - - 2) `TcInteract.matchClassInst` -- This module drives the instance resolution - / dictionary generation. The return type is `ClsInstResult`, which either - says no instance matched, or one found, and if it was a safe or unsafe - overlap. - - 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and - tries to resolve it by calling (in part) `matchClassInst`. The resolving - mechanism has a work list (of constraints) that it process one at a time. If - the constraint can't be resolved, it's added to an inert set. When compiling - an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know - compilation should fail. These are handled as normal constraint resolution - failures from here-on (see step 6). - - Otherwise, we may be inferring safety (or using `-Wunsafe`), and - compilation should succeed, but print warnings and/or mark the compiled module - as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds - the unsafe (but resolved!) constraint to the `inert_safehask` field of - `InertCans`. - - 4) `TcSimplify.simplifyTop`: - * Call simpl_top, the top-level function for driving the simplifier for - constraint resolution. - - * Once finished, call `getSafeOverlapFailures` to retrieve the - list of overlapping instances that were successfully resolved, - but unsafe. Remember, this is only applicable for generating warnings - (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` - cause compilation failure by not resolving the unsafe constraint at all. - - * For unresolved constraints (all types), call `TcErrors.reportUnsolved`, - while for resolved but unsafe overlapping dictionary constraints, call - `TcErrors.warnAllUnsolved`. Both functions convert constraints into a - warning message for the user. - - * In the case of `warnAllUnsolved` for resolved, but unsafe - dictionary constraints, we collect the generated warning - message (pop it) and call `TcRnMonad.recordUnsafeInfer` to - mark the module we are compiling as unsafe, passing the - warning message along as the reason. - - 5) `TcErrors.*Unsolved` -- Generates error messages for constraints by - actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we - know is the constraint that is unresolved or unsafe. For dictionary, all we - know is that we need a dictionary of type C, but not what instances are - available and how they overlap. So we once again call `lookupInstEnv` to - figure that out so we can generate a helpful error message. - - 6) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an - IORef called `tcg_safeInfer`. - - 7) `HscMain.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling - `HscMain.markUnsafeInfer` (passing the reason along) when safe-inferrence - failed. - -Note [No defaulting in the ambiguity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying constraints for the ambiguity check, we use -solveWantedsAndDrop, not simpl_top, so that we do no defaulting. -#11947 was an example: - f :: Num a => Int -> Int -This is ambiguous of course, but we don't want to default the -(Num alpha) constraint to (Num Int)! Doing so gives a defaulting -warning, but no error. - -Note [Defaulting insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a set of wanteds is insoluble, we have no hope of accepting the -program. Yet we do not stop constraint solving, etc., because we may -simplify the wanteds to produce better error messages. So, once -we have an insoluble constraint, everything we do is just about producing -helpful error messages. - -Should we default in this case or not? Let's look at an example (tcfail004): - - (f,g) = (1,2,3) - -With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). -Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) -find the latter more helpful. Several other test cases (e.g. tcfail005) suggest -similarly. So: we should not do class defaulting with insolubles. - -On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: - - f :: Integer i => i - f = 0 - -Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind -TYPE r0 -> Constraint and then complains that r0 is actually untouchable -(presumably, because it can't be sure if `Integer i` entails an equality). -If we default, we are told of a clash between (* -> Constraint) and Constraint. -The latter seems far better, suggesting we *should* do RuntimeRep-defaulting -even on insolubles. - -But, evidently, not always. Witness UnliftedNewtypesInfinite: - - newtype Foo = FooC (# Int#, Foo #) - -This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). -If we default RuntimeRep-vars, we get - - Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted - -which is just plain wrong. - -Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not -want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps -is not set. --} - ------------------- -simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () -simplifyAmbiguityCheck ty wanteds - = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds - -- NB: no defaulting! See Note [No defaulting in the ambiguity check] - - ; traceTc "End simplifyAmbiguityCheck }" empty - - -- Normally report all errors; but with -XAllowAmbiguousTypes - -- report only insoluble ones, since they represent genuinely - -- inaccessible code - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; traceTc "reportUnsolved(ambig) {" empty - ; unless (allow_ambiguous && not (insolubleWC final_wc)) - (discardResult (reportUnsolved final_wc)) - ; traceTc "reportUnsolved(ambig) }" empty - - ; return () } - ------------------- -simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) -simplifyInteractive wanteds - = traceTc "simplifyInteractive" empty >> - simplifyTop wanteds - ------------------- -simplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM () -- Succeeds if the constraint is soluble -simplifyDefault theta - = do { traceTc "simplifyDefault" empty - ; wanteds <- newWanteds DefaultOrigin theta - ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) - ; reportAllUnsolved unsolved - ; return () } - ------------------- -tcCheckSatisfiability :: Bag EvVar -> TcM Bool --- Return True if satisfiable, False if definitely contradictory -tcCheckSatisfiability given_ids - = do { lcl_env <- TcM.getLclEnv - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; (res, _ev_binds) <- runTcS $ - do { traceTcS "checkSatisfiability {" (ppr given_ids) - ; let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - ; solveSimpleGivens given_cts - ; insols <- getInertInsols - ; insols <- try_harder insols - ; traceTcS "checkSatisfiability }" (ppr insols) - ; return (isEmptyBag insols) } - ; return res } - where - try_harder :: Cts -> TcS Cts - -- Maybe we have to search up the superclass chain to find - -- an unsatisfiable constraint. Example: pmcheck/T3927b. - -- At the moment we try just once - try_harder insols - | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable - = return insols -- Hurrah -- stop now. - | otherwise - = do { pending_given <- getPendingGivenScs - ; new_given <- makeSuperClasses pending_given - ; solveSimpleGivens new_given - ; getInertInsols } - --- | Normalise a type as much as possible using the given constraints. --- See @Note [tcNormalise]@. -tcNormalise :: Bag EvVar -> Type -> TcM Type -tcNormalise given_ids ty - = do { lcl_env <- TcM.getLclEnv - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; wanted_ct <- mk_wanted_ct - ; (res, _ev_binds) <- runTcS $ - do { traceTcS "tcNormalise {" (ppr given_ids) - ; let given_cts = mkGivens given_loc (bagToList given_ids) - ; solveSimpleGivens given_cts - ; wcs <- solveSimpleWanteds (unitBag wanted_ct) - -- It's an invariant that this wc_simple will always be - -- a singleton Ct, since that's what we fed in as input. - ; let ty' = case bagToList (wc_simple wcs) of - (ct:_) -> ctEvPred (ctEvidence ct) - cts -> pprPanic "tcNormalise" (ppr cts) - ; traceTcS "tcNormalise }" (ppr ty') - ; pure ty' } - ; return res } - where - mk_wanted_ct :: TcM Ct - mk_wanted_ct = do - let occ = mkVarOcc "$tcNorm" - name <- newSysName occ - let ev = mkLocalId name ty - hole = ExprHole $ OutOfScope occ emptyGlobalRdrEnv - newHoleCt hole ev ty - -{- Note [Superclasses and satisfiability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expand superclasses before starting, because (Int ~ Bool), has -(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) -as a superclass, and it's the latter that is insoluble. See -Note [The equality types story] in TysPrim. - -If we fail to prove unsatisfiability we (arbitrarily) try just once to -find superclasses, using try_harder. Reason: we might have a type -signature - f :: F op (Implements push) => .. -where F is a type function. This happened in #3972. - -We could do more than once but we'd have to have /some/ limit: in the -the recursive case, we would go on forever in the common case where -the constraints /are/ satisfiable (#10592 comment:12!). - -For stratightforard situations without type functions the try_harder -step does nothing. - -Note [tcNormalise] -~~~~~~~~~~~~~~~~~~ -tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas -most invocations of the constraint solver are intended to simplify a set of -constraints or to decide if a particular set of constraints is satisfiable, -the purpose of tcNormalise is to take a type, plus some local constraints, and -normalise the type as much as possible with respect to those constraints. - -It does *not* reduce type or data family applications or look through newtypes. - -Why is this useful? As one example, when coverage-checking an EmptyCase -expression, it's possible that the type of the scrutinee will only reduce -if some local equalities are solved for. See "Wrinkle: Local equalities" -in Note [Type normalisation] in Check. - -To accomplish its stated goal, tcNormalise first feeds the local constraints -into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds -that singleton Ct into solveSimpleWanteds, which reduces the type in the -CHoleCan as much as possible with respect to the local given constraints. When -solveSimpleWanteds is finished, we dig out the type from the CHoleCan and -return that. - -*********************************************************************************** -* * -* Inference -* * -*********************************************************************************** - -Note [Inferring the type of a let-bound variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = rhs - -To infer f's type we do the following: - * Gather the constraints for the RHS with ambient level *one more than* - the current one. This is done by the call - pushLevelAndCaptureConstraints (tcMonoBinds...) - in TcBinds.tcPolyInfer - - * Call simplifyInfer to simplify the constraints and decide what to - quantify over. We pass in the level used for the RHS constraints, - here called rhs_tclvl. - -This ensures that the implication constraint we generate, if any, -has a strictly-increased level compared to the ambient level outside -the let binding. - --} - --- | How should we choose which constraints to quantify over? -data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, - -- never quantifying over any constraints - | EagerDefaulting -- ^ See Note [TcRnExprMode] in TcRnDriver, - -- the :type +d case; this mode refuses - -- to quantify over any defaultable constraint - | NoRestrictions -- ^ Quantify over any constraint that - -- satisfies TcType.pickQuantifiablePreds - -instance Outputable InferMode where - ppr ApplyMR = text "ApplyMR" - ppr EagerDefaulting = text "EagerDefaulting" - ppr NoRestrictions = text "NoRestrictions" - -simplifyInfer :: TcLevel -- Used when generating the constraints - -> InferMode - -> [TcIdSigInst] -- Any signatures (possibly partial) - -> [(Name, TcTauType)] -- Variables to be generalised, - -- and their tau-types - -> WantedConstraints - -> TcM ([TcTyVar], -- Quantify over these type variables - [EvVar], -- ... and these constraints (fully zonked) - TcEvBinds, -- ... binding these evidence variables - WantedConstraints, -- Redidual as-yet-unsolved constraints - Bool) -- True <=> the residual constraints are insoluble - -simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds - | isEmptyWC wanteds - = do { -- When quantifying, we want to preserve any order of variables as they - -- appear in partial signatures. cf. decideQuantifiedTyVars - let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs - , (_,tv) <- sig_inst_skols sig ] - psig_theta = [ pred | sig <- partial_sigs - , pred <- sig_inst_theta sig ] - - ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - ; qtkvs <- quantifyTyVars dep_vars - ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) - ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } - - | otherwise - = do { traceTc "simplifyInfer {" $ vcat - [ text "sigs =" <+> ppr sigs - , text "binds =" <+> ppr name_taus - , text "rhs_tclvl =" <+> ppr rhs_tclvl - , text "infer_mode =" <+> ppr infer_mode - , text "(unzonked) wanted =" <+> ppr wanteds - ] - - ; let psig_theta = concatMap sig_inst_theta partial_sigs - - -- First do full-blown solving - -- NB: we must gather up all the bindings from doing - -- this solving; hence (runTcSWithEvBinds ev_binds_var). - -- And note that since there are nested implications, - -- calling solveWanteds will side-effect their evidence - -- bindings, so we can't just revert to the input - -- constraint. - - ; tc_env <- TcM.getEnv - ; ev_binds_var <- TcM.newTcEvBinds - ; psig_theta_vars <- mapM TcM.newEvVar psig_theta - ; wanted_transformed_incl_derivs - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ - do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ - env_lcl tc_env - psig_givens = mkGivens loc psig_theta_vars - ; _ <- solveSimpleGivens psig_givens - -- See Note [Add signature contexts as givens] - ; solveWanteds wanteds } - - -- Find quant_pred_candidates, the predicates that - -- we'll consider quantifying over - -- NB1: wanted_transformed does not include anything provable from - -- the psig_theta; it's just the extra bit - -- NB2: We do not do any defaulting when inferring a type, this can lead - -- to less polymorphic types, see Note [Default while Inferring] - ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs - ; let definite_error = insolubleWC wanted_transformed_incl_derivs - -- See Note [Quantification with errors] - -- NB: must include derived errors in this test, - -- hence "incl_derivs" - wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs - quant_pred_candidates - | definite_error = [] - | otherwise = ctsPreds (approximateWC False wanted_transformed) - - -- Decide what type variables and constraints to quantify - -- NB: quant_pred_candidates is already fully zonked - -- NB: bound_theta are constraints we want to quantify over, - -- including the psig_theta, which we always quantify over - -- NB: bound_theta are fully zonked - ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl - name_taus partial_sigs - quant_pred_candidates - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta - - -- We must produce bindings for the psig_theta_vars, because we may have - -- used them in evidence bindings constructed by solveWanteds earlier - -- Easiest way to do this is to emit them as new Wanteds (#14643) - ; ct_loc <- getCtLocM AnnOrigin Nothing - ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var - , ctev_dest = EvVarDest psig_theta_var - , ctev_nosh = WDeriv - , ctev_loc = ct_loc } - | psig_theta_var <- psig_theta_vars ] - - -- Now construct the residual constraint - ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs bound_theta_vars - (wanted_transformed `andWC` mkSimpleWC psig_wanted) - - -- All done! - ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates - , text "psig_theta =" <+> ppr psig_theta - , text "bound_theta =" <+> ppr bound_theta - , text "qtvs =" <+> ppr qtvs - , text "definite_error =" <+> ppr definite_error ] - - ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var - , residual_wanted, definite_error ) } - -- NB: bound_theta_vars must be fully zonked - where - partial_sigs = filter isPartialSig sigs - --------------------- -mkResidualConstraints :: TcLevel -> EvBindsVar - -> [(Name, TcTauType)] - -> VarSet -> [TcTyVar] -> [EvVar] - -> WantedConstraints -> TcM WantedConstraints --- Emit the remaining constraints from the RHS. --- See Note [Emitting the residual implication in simplifyInfer] -mkResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs full_theta_vars wanteds - | isEmptyWC wanteds - = return wanteds - - | otherwise - = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds) - ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple - is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars - - ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple) - - ; let inner_wanted = wanteds { wc_simple = inner_simple } - ; implics <- if isEmptyWC inner_wanted - then return emptyBag - else do implic1 <- newImplication - return $ unitBag $ - implic1 { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_telescope = Nothing - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_binds = ev_binds_var - , ic_no_eqs = False - , ic_info = skol_info } - - ; return (WC { wc_simple = outer_simple - , wc_impl = implics })} - where - full_theta = map idType full_theta_vars - skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ] - -- Don't add the quantified variables here, because - -- they are also bound in ic_skols and we want them - -- to be tidied uniformly - --------------------- -ctsPreds :: Cts -> [PredType] -ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts - , let ev = ctEvidence ct ] - -{- Note [Emitting the residual implication in simplifyInfer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = e -where f's type is inferred to be something like (a, Proxy k (Int |> co)) -and we have an as-yet-unsolved, or perhaps insoluble, constraint - [W] co :: Type ~ k -We can't form types like (forall co. blah), so we can't generalise over -the coercion variable, and hence we can't generalise over things free in -its kind, in the case 'k'. But we can still generalise over 'a'. So -we'll generalise to - f :: forall a. (a, Proxy k (Int |> co)) -Now we do NOT want to form the residual implication constraint - forall a. [W] co :: Type ~ k -because then co's eventual binding (which will be a value binding if we -use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose -type mentions 'co'). Instead, just as we don't generalise over 'co', we -should not bury its constraint inside the implication. Instead, we must -put it outside. - -That is the reason for the partitionBag in emitResidualConstraints, -which takes the CoVars free in the inferred type, and pulls their -constraints out. (NB: this set of CoVars should be closed-over-kinds.) - -All rather subtle; see #14584. - -Note [Add signature contexts as givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#11016): - f2 :: (?x :: Int) => _ - f2 = ?x -or this - f3 :: a ~ Bool => (a, _) - f3 = (True, False) -or theis - f4 :: (Ord a, _) => a -> Bool - f4 x = x==x - -We'll use plan InferGen because there are holes in the type. But: - * For f2 we want to have the (?x :: Int) constraint floating around - so that the functional dependencies kick in. Otherwise the - occurrence of ?x on the RHS produces constraint (?x :: alpha), and - we won't unify alpha:=Int. - * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool) - in the RHS - * For f4 we want to use the (Ord a) in the signature to solve the Eq a - constraint. - -Solution: in simplifyInfer, just before simplifying the constraints -gathered from the RHS, add Given constraints for the context of any -type signatures. - -************************************************************************ -* * - Quantification -* * -************************************************************************ - -Note [Deciding quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the monomorphism restriction does not apply, then we quantify as follows: - -* Step 1. Take the global tyvars, and "grow" them using the equality - constraints - E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can - happen because alpha is untouchable here) then do not quantify over - beta, because alpha fixes beta, and beta is effectively free in - the environment too - - We also account for the monomorphism restriction; if it applies, - add the free vars of all the constraints. - - Result is mono_tvs; we will not quantify over these. - -* Step 2. Default any non-mono tyvars (i.e ones that are definitely - not going to become further constrained), and re-simplify the - candidate constraints. - - Motivation for re-simplification (#7857): imagine we have a - constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are - not free in the envt, and instance forall (a::*) (b::*). (C a) => C - (a -> b) The instance doesn't match while l1,l2 are polymorphic, but - it will match when we default them to LiftedRep. - - This is all very tiresome. - -* Step 3: decide which variables to quantify over, as follows: - - - Take the free vars of the tau-type (zonked_tau_tvs) and "grow" - them using all the constraints. These are tau_tvs_plus - - - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being - careful to close over kinds, and to skolemise the quantified tyvars. - (This actually unifies each quantifies meta-tyvar with a fresh skolem.) - - Result is qtvs. - -* Step 4: Filter the constraints using pickQuantifiablePreds and the - qtvs. We have to zonk the constraints first, so they "see" the - freshly created skolems. - --} - -decideQuantification - :: InferMode - -> TcLevel - -> [(Name, TcTauType)] -- Variables to be generalised - -> [TcIdSigInst] -- Partial type signatures (if any) - -> [PredType] -- Candidate theta; already zonked - -> TcM ( [TcTyVar] -- Quantify over these (skolems) - , [PredType] -- and this context (fully zonked) - , VarSet) --- See Note [Deciding quantification] -decideQuantification infer_mode rhs_tclvl name_taus psigs candidates - = do { -- Step 1: find the mono_tvs - ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode - name_taus psigs candidates - - -- Step 2: default any non-mono tyvars, and re-simplify - -- This step may do some unification, but result candidates is zonked - ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - - -- Step 3: decide which kind/type variables to quantify over - ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates - - -- Step 4: choose which of the remaining candidate - -- predicates to actually quantify over - -- NB: decideQuantifiedTyVars turned some meta tyvars - -- into quantified skolems, so we have to zonk again - ; candidates <- TcM.zonkTcTypes candidates - ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) - ; let quantifiable_candidates - = pickQuantifiablePreds (mkVarSet qtvs) candidates - -- NB: do /not/ run pickQuantifiablePreds over psig_theta, - -- because we always want to quantify over psig_theta, and not - -- drop any of them; e.g. CallStack constraints. c.f #14658 - - theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - (psig_theta ++ quantifiable_candidates) - - ; traceTc "decideQuantification" - (vcat [ text "infer_mode:" <+> ppr infer_mode - , text "candidates:" <+> ppr candidates - , text "psig_theta:" <+> ppr psig_theta - , text "mono_tvs:" <+> ppr mono_tvs - , text "co_vars:" <+> ppr co_vars - , text "qtvs:" <+> ppr qtvs - , text "theta:" <+> ppr theta ]) - ; return (qtvs, theta, co_vars) } - ------------------- -decideMonoTyVars :: InferMode - -> [(Name,TcType)] - -> [TcIdSigInst] - -> [PredType] - -> TcM (TcTyCoVarSet, [PredType], CoVarSet) --- Decide which tyvars and covars cannot be generalised: --- (a) Free in the environment --- (b) Mentioned in a constraint we can't generalise --- (c) Connected by an equality to (a) or (b) --- Also return CoVars that appear free in the final quatified types --- we can't quantify over these, and we must make sure they are in scope -decideMonoTyVars infer_mode name_taus psigs candidates - = do { (no_quant, maybe_quant) <- pick infer_mode candidates - - -- If possible, we quantify over partial-sig qtvs, so they are - -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs - ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ - concatMap (map snd . sig_inst_skols) psigs - - ; psig_theta <- mapM TcM.zonkTcType $ - concatMap sig_inst_theta psigs - - ; taus <- mapM (TcM.zonkTcType . snd) name_taus - - ; tc_lvl <- TcM.getTcLevel - ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta - - co_vars = coVarsOfTypes (psig_tys ++ taus) - co_var_tvs = closeOverKinds co_vars - -- The co_var_tvs are tvs mentioned in the types of covars or - -- coercion holes. We can't quantify over these covars, so we - -- must include the variable in their types in the mono_tvs. - -- E.g. If we can't quantify over co :: k~Type, then we can't - -- quantify over k either! Hence closeOverKinds - - mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ - tyCoVarsOfTypes candidates - -- We need to grab all the non-quantifiable tyvars in the - -- candidates so that we can grow this set to find other - -- non-quantifiable tyvars. This can happen with something - -- like - -- f x y = ... - -- where z = x 3 - -- The body of z tries to unify the type of x (call it alpha[1]) - -- with (beta[2] -> gamma[2]). This unification fails because - -- alpha is untouchable. But we need to know not to quantify over - -- beta or gamma, because they are in the equality constraint with - -- alpha. Actual test case: typecheck/should_compile/tc213 - - mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs - - eq_constraints = filter isEqPrimPred candidates - mono_tvs2 = growThetaTyVars eq_constraints mono_tvs1 - - constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ - (growThetaTyVars eq_constraints - (tyCoVarsOfTypes no_quant) - `minusVarSet` mono_tvs2) - `delVarSetList` psig_qtvs - -- constrained_tvs: the tyvars that we are not going to - -- quantify solely because of the monomorphism restriction - -- - -- (`minusVarSet` mono_tvs2`): a type variable is only - -- "constrained" (so that the MR bites) if it is not - -- free in the environment (#13785) - -- - -- (`delVarSetList` psig_qtvs): if the user has explicitly - -- asked for quantification, then that request "wins" - -- over the MR. Note: do /not/ delete psig_qtvs from - -- mono_tvs1, because mono_tvs1 cannot under any circumstances - -- be quantified (#14479); see - -- Note [Quantification and partial signatures], Wrinkle 3, 4 - - mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs - - -- Warn about the monomorphism restriction - ; warn_mono <- woptM Opt_WarnMonomorphism - ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ - warnTc (Reason Opt_WarnMonomorphism) - (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) - mr_msg - - ; traceTc "decideMonoTyVars" $ vcat - [ text "mono_tvs0 =" <+> ppr mono_tvs0 - , text "no_quant =" <+> ppr no_quant - , text "maybe_quant =" <+> ppr maybe_quant - , text "eq_constraints =" <+> ppr eq_constraints - , text "mono_tvs =" <+> ppr mono_tvs - , text "co_vars =" <+> ppr co_vars ] - - ; return (mono_tvs, maybe_quant, co_vars) } - where - pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) - -- Split the candidates into ones we definitely - -- won't quantify, and ones that we might - pick NoRestrictions cand = return ([], cand) - pick ApplyMR cand = return (cand, []) - pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings - ; return (partition (is_int_ct os) cand) } - - -- For EagerDefaulting, do not quantify over - -- over any interactive class constraint - is_int_ct ovl_strings pred - | Just (cls, _) <- getClassPredTys_maybe pred - = isInteractiveClass ovl_strings cls - | otherwise - = False - - pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus - mr_msg = - hang (sep [ text "The Monomorphism Restriction applies to the binding" - <> plural name_taus - , text "for" <+> pp_bndrs ]) - 2 (hsep [ text "Consider giving" - , text (if isSingleton name_taus then "it" else "them") - , text "a type signature"]) - -------------------- -defaultTyVarsAndSimplify :: TcLevel - -> TyCoVarSet - -> [PredType] -- Assumed zonked - -> TcM [PredType] -- Guaranteed zonked --- Default any tyvar free in the constraints, --- and re-simplify in case the defaulting allows further simplification -defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - = do { -- Promote any tyvars that we cannot generalise - -- See Note [Promote momomorphic tyvars] - ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) - ; (prom, _) <- promoteTyVarSet mono_tvs - - -- Default any kind/levity vars - ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - <- candidateQTyVarsOfTypes candidates - -- any covars should already be handled by - -- the logic in decideMonoTyVars, which looks at - -- the constraints generated - - ; poly_kinds <- xoptM LangExt.PolyKinds - ; default_kvs <- mapM (default_one poly_kinds True) - (dVarSetElems cand_kvs) - ; default_tvs <- mapM (default_one poly_kinds False) - (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - ; let some_default = or default_kvs || or default_tvs - - ; case () of - _ | some_default -> simplify_cand candidates - | prom -> mapM TcM.zonkTcType candidates - | otherwise -> return candidates - } - where - default_one poly_kinds is_kind_var tv - | not (isMetaTyVar tv) - = return False - | tv `elemVarSet` mono_tvs - = return False - | otherwise - = defaultTyVar (not poly_kinds && is_kind_var) tv - - simplify_cand candidates - = do { clone_wanteds <- newWanteds DefaultOrigin candidates - ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ - simplifyWantedsTcM clone_wanteds - -- Discard evidence; simples is fully zonked - - ; let new_candidates = ctsPreds simples - ; traceTc "Simplified after defaulting" $ - vcat [ text "Before:" <+> ppr candidates - , text "After:" <+> ppr new_candidates ] - ; return new_candidates } - ------------------- -decideQuantifiedTyVars - :: [(Name,TcType)] -- Annotated theta and (name,tau) pairs - -> [TcIdSigInst] -- Partial signatures - -> [PredType] -- Candidates, zonked - -> TcM [TyVar] --- Fix what tyvars we are going to quantify over, and quantify them -decideQuantifiedTyVars name_taus psigs candidates - = do { -- Why psig_tys? We try to quantify over everything free in here - -- See Note [Quantification and partial signatures] - -- Wrinkles 2 and 3 - ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs - , (_,tv) <- sig_inst_skols sig ] - ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs - , pred <- sig_inst_theta sig ] - ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus - - ; let -- Try to quantify over variables free in these types - psig_tys = psig_tv_tys ++ psig_theta - seed_tys = psig_tys ++ tau_tys - - -- Now "grow" those seeds to find ones reachable via 'candidates' - grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) - - -- Now we have to classify them into kind variables and type variables - -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars - -- - -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces - -- them in that order, so that the final qtvs quantifies in the same - -- order as the partial signatures do (#13524) - ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $ - psig_tys ++ candidates ++ tau_tys - ; let pick = (`dVarSetIntersectVarSet` grown_tcvs) - dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } - - ; traceTc "decideQuantifiedTyVars" (vcat - [ text "candidates =" <+> ppr candidates - , text "tau_tys =" <+> ppr tau_tys - , text "seed_tys =" <+> ppr seed_tys - , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys) - , text "grown_tcvs =" <+> ppr grown_tcvs - , text "dvs =" <+> ppr dvs_plus]) - - ; quantifyTyVars dvs_plus } - ------------------- -growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet --- See Note [Growing the tau-tvs using constraints] -growThetaTyVars theta tcvs - | null theta = tcvs - | otherwise = transCloVarSet mk_next seed_tcvs - where - seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPPred theta - -- See Note [Inheriting implicit parameters] in TcType - - mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones - mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips - grow_one so_far pred tcvs - | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs - | otherwise = tcvs - where - pred_tcvs = tyCoVarsOfType pred - - -{- Note [Promote momomorphic tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promote any type variables that are free in the environment. Eg - f :: forall qtvs. bound_theta => zonked_tau -The free vars of f's type become free in the envt, and hence will show -up whenever 'f' is called. They may currently at rhs_tclvl, but they -had better be unifiable at the outer_tclvl! Example: envt mentions -alpha[1] - tau_ty = beta[2] -> beta[2] - constraints = alpha ~ [beta] -we don't quantify over beta (since it is fixed by envt) -so we must promote it! The inferred type is just - f :: beta -> beta - -NB: promoteTyVar ignores coercion variables - -Note [Quantification and partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When choosing type variables to quantify, the basic plan is to -quantify over all type variables that are - * free in the tau_tvs, and - * not forced to be monomorphic (mono_tvs), - for example by being free in the environment. - -However, in the case of a partial type signature, be doing inference -*in the presence of a type signature*. For example: - f :: _ -> a - f x = ... -or - g :: (Eq _a) => _b -> _b -In both cases we use plan InferGen, and hence call simplifyInfer. But -those 'a' variables are skolems (actually TyVarTvs), and we should be -sure to quantify over them. This leads to several wrinkles: - -* Wrinkle 1. In the case of a type error - f :: _ -> Maybe a - f x = True && x - The inferred type of 'f' is f :: Bool -> Bool, but there's a - left-over error of form (HoleCan (Maybe a ~ Bool)). The error-reporting - machine expects to find a binding site for the skolem 'a', so we - add it to the quantified tyvars. - -* Wrinkle 2. Consider the partial type signature - f :: (Eq _) => Int -> Int - f x = x - In normal cases that makes sense; e.g. - g :: Eq _a => _a -> _a - g x = x - where the signature makes the type less general than it could - be. But for 'f' we must therefore quantify over the user-annotated - constraints, to get - f :: forall a. Eq a => Int -> Int - (thereby correctly triggering an ambiguity error later). If we don't - we'll end up with a strange open type - f :: Eq alpha => Int -> Int - which isn't ambiguous but is still very wrong. - - Bottom line: Try to quantify over any variable free in psig_theta, - just like the tau-part of the type. - -* Wrinkle 3 (#13482). Also consider - f :: forall a. _ => Int -> Int - f x = if (undefined :: a) == undefined then x else 0 - Here we get an (Eq a) constraint, but it's not mentioned in the - psig_theta nor the type of 'f'. But we still want to quantify - over 'a' even if the monomorphism restriction is on. - -* Wrinkle 4 (#14479) - foo :: Num a => a -> a - foo xxx = g xxx - where - g :: forall b. Num b => _ -> b - g y = xxx + y - - In the signature for 'g', we cannot quantify over 'b' because it turns out to - get unified with 'a', which is free in g's environment. So we carefully - refrain from bogusly quantifying, in TcSimplify.decideMonoTyVars. We - report the error later, in TcBinds.chooseInferredQuantifiers. - -Note [Growing the tau-tvs using constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(growThetaTyVars insts tvs) is the result of extending the set - of tyvars, tvs, using all conceivable links from pred - -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} -Then growThetaTyVars preds tvs = {a,b,c} - -Notice that - growThetaTyVars is conservative if v might be fixed by vs - => v `elem` grow(vs,C) - -Note [Quantification with errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find that the RHS of the definition has some absolutely-insoluble -constraints (including especially "variable not in scope"), we - -* Abandon all attempts to find a context to quantify over, - and instead make the function fully-polymorphic in whatever - type we have found - -* Return a flag from simplifyInfer, indicating that we found an - insoluble constraint. This flag is used to suppress the ambiguity - check for the inferred type, which may well be bogus, and which - tends to obscure the real error. This fix feels a bit clunky, - but I failed to come up with anything better. - -Reasons: - - Avoid downstream errors - - Do not perform an ambiguity test on a bogus type, which might well - fail spuriously, thereby obfuscating the original insoluble error. - #14000 is an example - -I tried an alternative approach: simply failM, after emitting the -residual implication constraint; the exception will be caught in -TcBinds.tcPolyBinds, which gives all the binders in the group the type -(forall a. a). But that didn't work with -fdefer-type-errors, because -the recovery from failM emits no code at all, so there is no function -to run! But -fdefer-type-errors aspires to produce a runnable program. - -NB that we must include *derived* errors in the check for insolubles. -Example: - (a::*) ~ Int# -We get an insoluble derived error *~#, and we don't want to discard -it before doing the isInsolubleWC test! (#8262) - -Note [Default while Inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our current plan is that defaulting only happens at simplifyTop and -not simplifyInfer. This may lead to some insoluble deferred constraints. -Example: - -instance D g => C g Int b - -constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha -type inferred = gamma -> gamma - -Now, if we try to default (alpha := Int) we will be able to refine the implication to - (forall b. 0 => C gamma Int b) -which can then be simplified further to - (forall b. 0 => D gamma) -Finally, we /can/ approximate this implication with (D gamma) and infer the quantified -type: forall g. D g => g -> g - -Instead what will currently happen is that we will get a quantified type -(forall g. g -> g) and an implication: - forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha - -Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an -unsolvable implication: - forall g. 0 => (forall b. 0 => D g) - -The concrete example would be: - h :: C g a s => g -> a -> ST s a - f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) - -But it is quite tedious to do defaulting and resolve the implication constraints, and -we have not observed code breaking because of the lack of defaulting in inference, so -we don't do it for now. - - - -Note [Minimize by Superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we quantify over a constraint, in simplifyInfer we need to -quantify over a constraint that is minimal in some sense: For -instance, if the final wanted constraint is (Eq alpha, Ord alpha), -we'd like to quantify over Ord alpha, because we can just get Eq alpha -from superclass selection from Ord alpha. This minimization is what -mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint -to check the original wanted. - - -Note [Avoid unnecessary constraint simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -------- NB NB NB (Jun 12) ------------- - This note not longer applies; see the notes with #4361. - But I'm leaving it in here so we remember the issue.) - ---------------------------------------- -When inferring the type of a let-binding, with simplifyInfer, -try to avoid unnecessarily simplifying class constraints. -Doing so aids sharing, but it also helps with delicate -situations like - - instance C t => C [t] where .. - - f :: C [t] => .... - f x = let g y = ...(constraint C [t])... - in ... -When inferring a type for 'g', we don't want to apply the -instance decl, because then we can't satisfy (C t). So we -just notice that g isn't quantified over 't' and partition -the constraints before simplifying. - -This only half-works, but then let-generalisation only half-works. - -********************************************************************************* -* * -* Main Simplifier * -* * -*********************************************************************************** - --} - -simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints --- Solve the specified Wanted constraints --- Discard the evidence binds --- Discards all Derived stuff in result --- Postcondition: fully zonked and unflattened constraints -simplifyWantedsTcM wanted - = do { traceTc "simplifyWantedsTcM {" (ppr wanted) - ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) - ; result <- TcM.zonkWC result - ; traceTc "simplifyWantedsTcM }" (ppr result) - ; return result } - -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints --- Since solveWanteds returns the residual WantedConstraints, --- it should always be called within a runTcS or something similar, --- Result is not zonked -solveWantedsAndDrop wanted - = do { wc <- solveWanteds wanted - ; return (dropDerivedWC wc) } - -solveWanteds :: WantedConstraints -> TcS WantedConstraints --- so that the inert set doesn't mindlessly propagate. --- NB: wc_simples may be wanted /or/ derived now -solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { cur_lvl <- TcS.getTcLevel - ; traceTcS "solveWanteds {" $ - vcat [ text "Level =" <+> ppr cur_lvl - , ppr wc ] - - ; wc1 <- solveSimpleWanteds simples - -- Any insoluble constraints are in 'simples' and so get rewritten - -- See Note [Rewrite insolubles] in TcSMonad - - ; (floated_eqs, implics2) <- solveNestedImplications $ - implics `unionBags` wc_impl wc1 - - ; dflags <- getDynFlags - ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs - (wc1 { wc_impl = implics2 }) - - ; ev_binds_var <- getTcEvBindsVar - ; bb <- TcS.getTcEvBindsMap ev_binds_var - ; traceTcS "solveWanteds }" $ - vcat [ text "final wc =" <+> ppr final_wc - , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] - - ; return final_wc } - -simpl_loop :: Int -> IntWithInf -> Cts - -> WantedConstraints -> TcS WantedConstraints -simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples }) - | n `intGtLimit` limit - = do { -- Add an error (not a warning) if we blow the limit, - -- Typically if we blow the limit we are going to report some other error - -- (an unsolved constraint), and we don't want that error to suppress - -- the iteration limit warning! - addErrTcS (hang (text "solveWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Unsolved:" <+> ppr wc - , ppUnless (isEmptyBag floated_eqs) $ - text "Floated equalities:" <+> ppr floated_eqs - , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - ])) - ; return wc } - - | not (isEmptyBag floated_eqs) - = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples }) - -- Put floated_eqs first so they get solved first - -- NB: the floated_eqs may include /derived/ equalities - -- arising from fundeps inside an implication - - | superClassesMightHelp wc - = -- We still have unsolved goals, and apparently no way to solve them, - -- so try expanding superclasses at this level, both Given and Wanted - do { pending_given <- getPendingGivenScs - ; let (pending_wanted, simples1) = getPendingWantedScs simples - ; if null pending_given && null pending_wanted - then return wc -- After all, superclasses did not help - else - do { new_given <- makeSuperClasses pending_given - ; new_wanted <- makeSuperClasses pending_wanted - ; solveSimpleGivens new_given -- Add the new Givens to the inert set - ; simplify_again n limit (null pending_given) - wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } - - | otherwise - = return wc - -simplify_again :: Int -> IntWithInf -> Bool - -> WantedConstraints -> TcS WantedConstraints --- We have definitely decided to have another go at solving --- the wanted constraints (we have tried at least once already -simplify_again n limit no_new_given_scs - wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { csTraceTcS $ - text "simpl_loop iteration=" <> int n - <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma - , int (lengthBag simples) <+> text "simples to solve" ]) - ; traceTcS "simpl_loop: wc =" (ppr wc) - - ; (unifs1, wc1) <- reportUnifications $ - solveSimpleWanteds $ - simples - - -- See Note [Cutting off simpl_loop] - -- We have already tried to solve the nested implications once - -- Try again only if we have unified some meta-variables - -- (which is a bit like adding more givens), or we have some - -- new Given superclasses - ; let new_implics = wc_impl wc1 - ; if unifs1 == 0 && - no_new_given_scs && - isEmptyBag new_implics - - then -- Do not even try to solve the implications - simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics }) - - else -- Try to solve the implications - do { (floated_eqs2, implics2) <- solveNestedImplications $ - implics `unionBags` new_implics - ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 }) - } } - -solveNestedImplications :: Bag Implication - -> TcS (Cts, Bag Implication) --- Precondition: the TcS inerts may contain unsolved simples which have --- to be converted to givens before we go inside a nested implication. -solveNestedImplications implics - | isEmptyBag implics - = return (emptyBag, emptyBag) - | otherwise - = do { traceTcS "solveNestedImplications starting {" empty - ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics - ; let floated_eqs = concatBag floated_eqs_s - - -- ... and we are back in the original TcS inerts - -- Notice that the original includes the _insoluble_simples so it was safe to ignore - -- them in the beginning of this function. - ; traceTcS "solveNestedImplications end }" $ - vcat [ text "all floated_eqs =" <+> ppr floated_eqs - , text "unsolved_implics =" <+> ppr unsolved_implics ] - - ; return (floated_eqs, catBagMaybes unsolved_implics) } - -solveImplication :: Implication -- Wanted - -> TcS (Cts, -- All wanted or derived floated equalities: var = type - Maybe Implication) -- Simplified implication (empty or singleton) --- Precondition: The TcS monad contains an empty worklist and given-only inerts --- which after trying to solve this implication we must restore to their original value -solveImplication imp@(Implic { ic_tclvl = tclvl - , ic_binds = ev_binds_var - , ic_skols = skols - , ic_given = given_ids - , ic_wanted = wanteds - , ic_info = info - , ic_status = status }) - | isSolvedStatus status - = return (emptyCts, Just imp) -- Do nothing - - | otherwise -- Even for IC_Insoluble it is worth doing more work - -- The insoluble stuff might be in one sub-implication - -- and other unsolved goals in another; and we want to - -- solve the latter as much as possible - = do { inerts <- getTcSInerts - ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) - - -- commented out; see `where` clause below - -- ; when debugIsOn check_tc_level - - -- Solve the nested constraints - ; (no_given_eqs, given_insols, residual_wanted) - <- nestImplicTcS ev_binds_var tclvl $ - do { let loc = mkGivenLoc tclvl info (ic_env imp) - givens = mkGivens loc given_ids - ; solveSimpleGivens givens - - ; residual_wanted <- solveWanteds wanteds - -- solveWanteds, *not* solveWantedsAndDrop, because - -- we want to retain derived equalities so we can float - -- them out in floatEqualities - - ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols - -- Call getNoGivenEqs /after/ solveWanteds, because - -- solveWanteds can augment the givens, via expandSuperClasses, - -- to reveal given superclass equalities - - ; return (no_eqs, given_insols, residual_wanted) } - - ; (floated_eqs, residual_wanted) - <- floatEqualities skols given_ids ev_binds_var - no_given_eqs residual_wanted - - ; traceTcS "solveImplication 2" - (ppr given_insols $$ ppr residual_wanted) - ; let final_wanted = residual_wanted `addInsols` given_insols - -- Don't lose track of the insoluble givens, - -- which signal unreachable code; put them in ic_wanted - - ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs - , ic_wanted = final_wanted }) - - ; evbinds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - ; traceTcS "solveImplication end }" $ vcat - [ text "no_given_eqs =" <+> ppr no_given_eqs - , text "floated_eqs =" <+> ppr floated_eqs - , text "res_implic =" <+> ppr res_implic - , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) - , text "implication tvcs =" <+> ppr tcvs ] - - ; return (floated_eqs, res_implic) } - - where - -- TcLevels must be strictly increasing (see (ImplicInv) in - -- Note [TcLevel and untouchable type variables] in TcType), - -- and in fact I thinkthey should always increase one level at a time. - - -- Though sensible, this check causes lots of testsuite failures. It is - -- remaining commented out for now. - {- - check_tc_level = do { cur_lvl <- TcS.getTcLevel - ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) } - -} - ----------------------- -setImplicationStatus :: Implication -> TcS (Maybe Implication) --- Finalise the implication returned from solveImplication: --- * Set the ic_status field --- * Trim the ic_wanted field to remove Derived constraints --- Precondition: the ic_status field is not already IC_Solved --- Return Nothing if we can discard the implication altogether -setImplicationStatus implic@(Implic { ic_status = status - , ic_info = info - , ic_wanted = wc - , ic_given = givens }) - | ASSERT2( not (isSolvedStatus status ), ppr info ) - -- Precondition: we only set the status if it is not already solved - not (isSolvedWC pruned_wc) - = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) - - ; implic <- neededEvVars implic - - ; let new_status | insolubleWC pruned_wc = IC_Insoluble - | otherwise = IC_Unsolved - new_implic = implic { ic_status = new_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) - - ; return $ Just new_implic } - - | otherwise -- Everything is solved - -- Set status to IC_Solved, - -- and compute the dead givens and outer needs - -- See Note [Tracking redundant constraints] - = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic) - - ; implic@(Implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) <- neededEvVars implic - - ; bad_telescope <- checkBadTelescope implic - - ; let dead_givens | warnRedundantGivens info - = filterOut (`elemVarSet` need_inner) givens - | otherwise = [] -- None to report - - discard_entire_implication -- Can we discard the entire implication? - = null dead_givens -- No warning from this implication - && not bad_telescope - && isEmptyWC pruned_wc -- No live children - && isEmptyVarSet need_outer -- No needed vars to pass up to parent - - final_status - | bad_telescope = IC_BadTelescope - | otherwise = IC_Solved { ics_dead = dead_givens } - final_implic = implic { ic_status = final_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(all-solved) }" $ - vcat [ text "discard:" <+> ppr discard_entire_implication - , text "new_implic:" <+> ppr final_implic ] - - ; return $ if discard_entire_implication - then Nothing - else Just final_implic } - where - WC { wc_simple = simples, wc_impl = implics } = wc - - pruned_simples = dropDerivedSimples simples - pruned_implics = filterBag keep_me implics - pruned_wc = WC { wc_simple = pruned_simples - , wc_impl = pruned_implics } - - keep_me :: Implication -> Bool - keep_me ic - | IC_Solved { ics_dead = dead_givens } <- ic_status ic - -- Fully solved - , null dead_givens -- No redundant givens to report - , isEmptyBag (wc_impl (ic_wanted ic)) - -- And no children that might have things to report - = False -- Tnen we don't need to keep it - | otherwise - = True -- Otherwise, keep it - -checkBadTelescope :: Implication -> TcS Bool --- True <=> the skolems form a bad telescope --- See Note [Keeping scoped variables in order: Explicit] in TcHsType -checkBadTelescope (Implic { ic_telescope = m_telescope - , ic_skols = skols }) - | isJust m_telescope - = do{ skols <- mapM TcS.zonkTyCoVarKind skols - ; return (go emptyVarSet (reverse skols))} - - | otherwise - = return False - - where - go :: TyVarSet -- skolems that appear *later* than the current ones - -> [TcTyVar] -- ordered skolems, in reverse order - -> Bool -- True <=> there is an out-of-order skolem - go _ [] = False - go later_skols (one_skol : earlier_skols) - | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols - = True - | otherwise - = go (later_skols `extendVarSet` one_skol) earlier_skols - -warnRedundantGivens :: SkolemInfo -> Bool -warnRedundantGivens (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt _ warn_redundant -> warn_redundant - ExprSigCtxt -> True - _ -> False - - -- To think about: do we want to report redundant givens for - -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. -warnRedundantGivens (InstSkol {}) = True -warnRedundantGivens _ = False - -neededEvVars :: Implication -> TcS Implication --- Find all the evidence variables that are "needed", --- and delete dead evidence bindings --- See Note [Tracking redundant constraints] --- See Note [Delete dead Given evidence bindings] --- --- - Start from initial_seeds (from nested implications) --- --- - Add free vars of RHS of all Wanted evidence bindings --- and coercion variables accumulated in tcvs (all Wanted) --- --- - Generate 'needed', the needed set of EvVars, by doing transitive --- closure through Given bindings --- e.g. Needed {a,b} --- Given a = sc_sel a2 --- Then a2 is needed too --- --- - Prune out all Given bindings that are not needed --- --- - From the 'needed' set, delete ev_bndrs, the binders of the --- evidence bindings, to give the final needed variables --- -neededEvVars implic@(Implic { ic_given = givens - , ic_binds = ev_binds_var - , ic_wanted = WC { wc_impl = implics } - , ic_need_inner = old_needs }) - = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - - ; let seeds1 = foldr add_implic_seeds old_needs implics - seeds2 = foldEvBindMap add_wanted seeds1 ev_binds - seeds3 = seeds2 `unionVarSet` tcvs - need_inner = findNeededEvVars ev_binds seeds3 - live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds - need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds - `delVarSetList` givens - - ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds - -- See Note [Delete dead Given evidence bindings] - - ; traceTcS "neededEvVars" $ - vcat [ text "old_needs:" <+> ppr old_needs - , text "seeds3:" <+> ppr seeds3 - , text "tcvs:" <+> ppr tcvs - , text "ev_binds:" <+> ppr ev_binds - , text "live_ev_binds:" <+> ppr live_ev_binds ] - - ; return (implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) } - where - add_implic_seeds (Implic { ic_need_outer = needs }) acc - = needs `unionVarSet` acc - - needed_ev_bind needed (EvBind { eb_lhs = ev_var - , eb_is_given = is_given }) - | is_given = ev_var `elemVarSet` needed - | otherwise = True -- Keep all wanted bindings - - del_ev_bndr :: EvBind -> VarSet -> VarSet - del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v - - add_wanted :: EvBind -> VarSet -> VarSet - add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs - | is_given = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs - - -{- Note [Delete dead Given evidence bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a result of superclass expansion, we speculatively -generate evidence bindings for Givens. E.g. - f :: (a ~ b) => a -> b -> Bool - f x y = ... -We'll have - [G] d1 :: (a~b) -and we'll specuatively generate the evidence binding - [G] d2 :: (a ~# b) = sc_sel d - -Now d2 is available for solving. But it may not be needed! Usually -such dead superclass selections will eventually be dropped as dead -code, but: - - * It won't always be dropped (#13032). In the case of an - unlifted-equality superclass like d2 above, we generate - case heq_sc d1 of d2 -> ... - and we can't (in general) drop that case exrpession in case - d1 is bottom. So it's technically unsound to have added it - in the first place. - - * Simply generating all those extra superclasses can generate lots of - code that has to be zonked, only to be discarded later. Better not - to generate it in the first place. - - Moreover, if we simplify this implication more than once - (e.g. because we can't solve it completely on the first iteration - of simpl_looop), we'll generate all the same bindings AGAIN! - -Easy solution: take advantage of the work we are doing to track dead -(unused) Givens, and use it to prune the Given bindings too. This is -all done by neededEvVars. - -This led to a remarkable 25% overall compiler allocation decrease in -test T12227. - -But we don't get to discard all redundant equality superclasses, alas; -see #15205. - -Note [Tracking redundant constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Opt_WarnRedundantConstraints, GHC can report which -constraints of a type signature (or instance declaration) are -redundant, and can be omitted. Here is an overview of how it -works: - ------ What is a redundant constraint? - -* The things that can be redundant are precisely the Given - constraints of an implication. - -* A constraint can be redundant in two different ways: - a) It is implied by other givens. E.g. - f :: (Eq a, Ord a) => blah -- Eq a unnecessary - g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary - b) It is not needed by the Wanted constraints covered by the - implication E.g. - f :: Eq a => a -> Bool - f x = True -- Equality not used - -* To find (a), when we have two Given constraints, - we must be careful to drop the one that is a naked variable (if poss). - So if we have - f :: (Eq a, Ord a) => blah - then we may find [G] sc_sel (d1::Ord a) :: Eq a - [G] d2 :: Eq a - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. This is done by TcInteract.solveOneFromTheOther - See Note [Replacement vs keeping]. - -* To find (b) we need to know which evidence bindings are 'wanted'; - hence the eb_is_given field on an EvBind. - ------ How tracking works - -* The ic_need fields of an Implic records in-scope (given) evidence - variables bound by the context, that were needed to solve this - implication (so far). See the declaration of Implication. - -* When the constraint solver finishes solving all the wanteds in - an implication, it sets its status to IC_Solved - - - The ics_dead field, of IC_Solved, records the subset of this - implication's ic_given that are redundant (not needed). - -* We compute which evidence variables are needed by an implication - in setImplicationStatus. A variable is needed if - a) it is free in the RHS of a Wanted EvBind, - b) it is free in the RHS of an EvBind whose LHS is needed, - c) it is in the ics_need of a nested implication. - -* We need to be careful not to discard an implication - prematurely, even one that is fully solved, because we might - thereby forget which variables it needs, and hence wrongly - report a constraint as redundant. But we can discard it once - its free vars have been incorporated into its parent; or if it - simply has no free vars. This careful discarding is also - handled in setImplicationStatus. - ------ Reporting redundant constraints - -* TcErrors does the actual warning, in warnRedundantConstraints. - -* We don't report redundant givens for *every* implication; only - for those which reply True to TcSimplify.warnRedundantGivens: - - - For example, in a class declaration, the default method *can* - use the class constraint, but it certainly doesn't *have* to, - and we don't want to report an error there. - - - More subtly, in a function definition - f :: (Ord a, Ord a, Ix a) => a -> a - f x = rhs - we do an ambiguity check on the type (which would find that one - of the Ord a constraints was redundant), and then we check that - the definition has that type (which might find that both are - redundant). We don't want to report the same error twice, so we - disable it for the ambiguity check. Hence using two different - FunSigCtxts, one with the warn-redundant field set True, and the - other set False in - - TcBinds.tcSpecPrag - - TcBinds.tcTySig - - This decision is taken in setImplicationStatus, rather than TcErrors - so that we can discard implication constraints that we don't need. - So ics_dead consists only of the *reportable* redundant givens. - ------ Shortcomings - -Consider (see #9939) - f2 :: (Eq a, Ord a) => a -> a -> Bool - -- Ord a redundant, but Eq a is reported - f2 x y = (x == y) - -We report (Eq a) as redundant, whereas actually (Ord a) is. But it's -really not easy to detect that! - - -Note [Cutting off simpl_loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very important not to iterate in simpl_loop unless there is a chance -of progress. #8474 is a classic example: - - * There's a deeply-nested chain of implication constraints. - ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - - * From the innermost one we get a [D] alpha ~ Int, - but alpha is untouchable until we get out to the outermost one - - * We float [D] alpha~Int out (it is in floated_eqs), but since alpha - is untouchable, the solveInteract in simpl_loop makes no progress - - * So there is no point in attempting to re-solve - ?yn:betan => [W] ?x:Int - via solveNestedImplications, because we'll just get the - same [D] again - - * If we *do* re-solve, we'll get an ininite loop. It is cut off by - the fixed bound of 10, but solving the next takes 10*10*...*10 (ie - exponentially many) iterations! - -Conclusion: we should call solveNestedImplications only if we did -some unification in solveSimpleWanteds; because that's the only way -we'll get more Givens (a unification is like adding a Given) to -allow the implication to make progress. --} - -promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar) --- When we float a constraint out of an implication we must restore --- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType --- Return True <=> we did some promotion --- Also returns either the original tyvar (no promotion) or the new one --- See Note [Promoting unification variables] -promoteTyVar tv - = do { tclvl <- TcM.getTcLevel - ; if (isFloatedTouchableMetaTyVar tclvl tv) - then do { cloned_tv <- TcM.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv) - ; return (True, rhs_tv) } - else return (False, tv) } - --- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet) -promoteTyVarSet tvs - = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs) - -- non-determinism is OK because order of promotion doesn't matter - - ; return (or bools, mkVarSet tyvars) } - -promoteTyVarTcS :: TcTyVar -> TcS () --- When we float a constraint out of an implication we must restore --- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType --- See Note [Promoting unification variables] --- We don't just call promoteTyVar because we want to use unifyTyVar, --- not writeMetaTyVar -promoteTyVarTcS tv - = do { tclvl <- TcS.getTcLevel - ; when (isFloatedTouchableMetaTyVar tclvl tv) $ - do { cloned_tv <- TcS.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; unifyTyVar tv (mkTyVarTy rhs_tv) } } - --- | Like 'defaultTyVar', but in the TcS monad. -defaultTyVarTcS :: TcTyVar -> TcS Bool -defaultTyVarTcS the_tv - | isRuntimeRepVar the_tv - , not (isTyVarTyVar the_tv) - -- TyVarTvs should only be unified with a tyvar - -- never with a type; c.f. TcMType.defaultTyVar - -- and Note [Inferring kinds for type declarations] in TcTyClsDecls - = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv liftedRepTy - ; return True } - | otherwise - = return False -- the common case - -approximateWC :: Bool -> WantedConstraints -> Cts --- Postcondition: Wanted or Derived Cts --- See Note [ApproximateWC] -approximateWC float_past_equalities wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts - float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) - = filterBag (is_floatable trapping_tvs) simples `unionBags` - do_bag (float_implic trapping_tvs) implics - where - - float_implic :: TcTyCoVarSet -> Implication -> Cts - float_implic trapping_tvs imp - | float_past_equalities || ic_no_eqs imp - = float_wc new_trapping_tvs (ic_wanted imp) - | otherwise -- Take care with equalities - = emptyCts -- See (1) under Note [ApproximateWC] - where - new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp - - do_bag :: (a -> Bag c) -> Bag a -> Bag c - do_bag f = foldr (unionBags.f) emptyBag - - is_floatable skol_tvs ct - | isGivenCt ct = False - | isHoleCt ct = False - | insolubleEqCt ct = False - | otherwise = tyCoVarsOfCt ct `disjointVarSet` skol_tvs - -{- Note [ApproximateWC] -~~~~~~~~~~~~~~~~~~~~~~~ -approximateWC takes a constraint, typically arising from the RHS of a -let-binding whose type we are *inferring*, and extracts from it some -*simple* constraints that we might plausibly abstract over. Of course -the top-level simple constraints are plausible, but we also float constraints -out from inside, if they are not captured by skolems. - -The same function is used when doing type-class defaulting (see the call -to applyDefaultingRules) to extract constraints that that might be defaulted. - -There is one caveat: - -1. When infering most-general types (in simplifyInfer), we do *not* - float anything out if the implication binds equality constraints, - because that defeats the OutsideIn story. Consider - data T a where - TInt :: T Int - MkT :: T a - - f TInt = 3::Int - - We get the implication (a ~ Int => res ~ Int), where so far we've decided - f :: T a -> res - We don't want to float (res~Int) out because then we'll infer - f :: T a -> Int - which is only on of the possible types. (GHC 7.6 accidentally *did* - float out of such implications, which meant it would happily infer - non-principal types.) - - HOWEVER (#12797) in findDefaultableGroups we are not worried about - the most-general type; and we /do/ want to float out of equalities. - Hence the boolean flag to approximateWC. - ------- Historical note ----------- -There used to be a second caveat, driven by #8155 - - 2. We do not float out an inner constraint that shares a type variable - (transitively) with one that is trapped by a skolem. Eg - forall a. F a ~ beta, Integral beta - We don't want to float out (Integral beta). Doing so would be bad - when defaulting, because then we'll default beta:=Integer, and that - makes the error message much worse; we'd get - Can't solve F a ~ Integer - rather than - Can't solve Integral (F a) - - Moreover, floating out these "contaminated" constraints doesn't help - when generalising either. If we generalise over (Integral b), we still - can't solve the retained implication (forall a. F a ~ b). Indeed, - arguably that too would be a harder error to understand. - -But this transitive closure stuff gives rise to a complex rule for -when defaulting actually happens, and one that was never documented. -Moreover (#12923), the more complex rule is sometimes NOT what -you want. So I simply removed the extra code to implement the -contamination stuff. There was zero effect on the testsuite (not even -#8155). ------- End of historical note ----------- - - -Note [DefaultTyVar] -~~~~~~~~~~~~~~~~~~~ -defaultTyVar is used on any un-instantiated meta type variables to -default any RuntimeRep variables to LiftedRep. This is important -to ensure that instance declarations match. For example consider - - instance Show (a->b) - foo x = show (\_ -> True) - -Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), -and that won't match the tcTypeKind (*) in the instance decl. See tests -tc217 and tc175. - -We look only at touchable type variables. No further constraints -are going to affect these type variables, so it's time to do it by -hand. However we aren't ready to default them fully to () or -whatever, because the type-class defaulting rules have yet to run. - -An alternate implementation would be to emit a derived constraint setting -the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. - -Note [Promote _and_ default when inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are inferring a type, we simplify the constraint, and then use -approximateWC to produce a list of candidate constraints. Then we MUST - - a) Promote any meta-tyvars that have been floated out by - approximateWC, to restore invariant (WantedInv) described in - Note [TcLevel and untouchable type variables] in TcType. - - b) Default the kind of any meta-tyvars that are not mentioned in - in the environment. - -To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we -have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it -should! If we don't solve the constraint, we'll stupidly quantify over -(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over -(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. -#7641 is a simpler example. - -Note [Promoting unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we float an equality out of an implication we must "promote" free -unification variables of the equality, in order to maintain Invariant -(WantedInv) from Note [TcLevel and untouchable type variables] in -TcType. for the leftover implication. - -This is absolutely necessary. Consider the following example. We start -with two implications and a class with a functional dependency. - - class C x y | x -> y - instance C [a] [a] - - (I1) [untch=beta]forall b. 0 => F Int ~ [beta] - (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] - -We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. -They may react to yield that (beta := [alpha]) which can then be pushed inwards -the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that -(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable -beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: - - class C x y | x -> y where - op :: x -> y -> () - - instance C [a] [a] - - type family F a :: * - - h :: F Int -> () - h = undefined - - data TEx where - TEx :: a -> TEx - - f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) - - - -********************************************************************************* -* * -* Floating equalities * -* * -********************************************************************************* - -Note [Float Equalities out of Implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For ordinary pattern matches (including existentials) we float -equalities out of implications, for instance: - data T where - MkT :: Eq a => a -> T - f x y = case x of MkT _ -> (y::Int) -We get the implication constraint (x::T) (y::alpha): - forall a. [untouchable=alpha] Eq a => alpha ~ Int -We want to float out the equality into a scope where alpha is no -longer untouchable, to solve the implication! - -But we cannot float equalities out of implications whose givens may -yield or contain equalities: - - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a - - h :: T a -> a -> Int - - f x y = case x of - T1 -> y::Int - T2 -> y::Bool - T3 -> h x y - -We generate constraint, for (x::T alpha) and (y :: beta): - [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch - [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch - (alpha ~ beta) -- From 3rd branch - -If we float the equality (beta ~ Int) outside of the first implication and -the equality (beta ~ Bool) out of the second we get an insoluble constraint. -But if we just leave them inside the implications, we unify alpha := beta and -solve everything. - -Principle: - We do not want to float equalities out which may - need the given *evidence* to become soluble. - -Consequence: classes with functional dependencies don't matter (since there is -no evidence for a fundep equality), but equality superclasses do matter (since -they carry evidence). --} - -floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool - -> WantedConstraints - -> TcS (Cts, WantedConstraints) --- Main idea: see Note [Float Equalities out of Implications] --- --- Precondition: the wc_simple of the incoming WantedConstraints are --- fully zonked, so that we can see their free variables --- --- Postcondition: The returned floated constraints (Cts) are only --- Wanted or Derived --- --- Also performs some unifications (via promoteTyVar), adding to --- monadically-carried ty_binds. These will be used when processing --- floated_eqs later --- --- Subtleties: Note [Float equalities from under a skolem binding] --- Note [Skolem escape] --- Note [What prevents a constraint from floating] -floatEqualities skols given_ids ev_binds_var no_given_eqs - wanteds@(WC { wc_simple = simples }) - | not no_given_eqs -- There are some given equalities, so don't float - = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] - - | otherwise - = do { -- First zonk: the inert set (from whence they came) is fully - -- zonked, but unflattening may have filled in unification - -- variables, and we /must/ see them. Otherwise we may float - -- constraints that mention the skolems! - simples <- TcS.zonkSimples simples - ; binds <- TcS.getTcEvBindsMap ev_binds_var - - -- Now we can pick the ones to float - -- The constraints are un-flattened and de-canonicalised - ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples - - seed_skols = mkVarSet skols `unionVarSet` - mkVarSet given_ids `unionVarSet` - foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` - foldEvBindMap add_one_bind emptyVarSet binds - -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) - -- Include the EvIds of any non-floating constraints - - extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols - -- extended_skols contains the EvIds of all the trapped constraints - -- See Note [What prevents a constraint from floating] (3) - - (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols) - candidate_eqs - - remaining_simples = no_float_cts `andCts` no_flt_eqs - - -- Promote any unification variables mentioned in the floated equalities - -- See Note [Promoting unification variables] - ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs) - - ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols - , text "Extended skols =" <+> ppr extended_skols - , text "Simples =" <+> ppr simples - , text "Candidate eqs =" <+> ppr candidate_eqs - , text "Floated eqs =" <+> ppr flt_eqs]) - ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) } - - where - add_one_bind :: EvBind -> VarSet -> VarSet - add_one_bind bind acc = extendVarSet acc (evBindVar bind) - - add_non_flt_ct :: Ct -> VarSet -> VarSet - add_non_flt_ct ct acc | isDerivedCt ct = acc - | otherwise = extendVarSet acc (ctEvId ct) - - is_floatable :: VarSet -> Ct -> Bool - is_floatable skols ct - | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols) - | otherwise = not (ctEvId ct `elemVarSet` skols) - - add_captured_ev_ids :: Cts -> VarSet -> VarSet - add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts - where - extra_skol ct acc - | isDerivedCt ct = acc - | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct) - | otherwise = acc - - -- Identify which equalities are candidates for floating - -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside - -- See Note [Which equalities to float] - is_float_eq_candidate ct - | pred <- ctPred ct - , EqPred NomEq ty1 ty2 <- classifyPredType pred - , tcTypeKind ty1 `tcEqType` tcTypeKind ty2 - = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of - (Just tv1, _) -> float_tv_eq_candidate tv1 ty2 - (_, Just tv2) -> float_tv_eq_candidate tv2 ty1 - _ -> False - | otherwise = False - - float_tv_eq_candidate tv1 ty2 -- See Note [Which equalities to float] - = isMetaTyVar tv1 - && (not (isTyVarTyVar tv1) || isTyVarTy ty2) - - -{- Note [Float equalities from under a skolem binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which of the simple equalities can we float out? Obviously, only -ones that don't mention the skolem-bound variables. But that is -over-eager. Consider - [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int -The second constraint doesn't mention 'a'. But if we float it, -we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that -beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll -we left with the constraint - [2] forall a. a ~ gamma'[1] -which is insoluble because gamma became untouchable. - -Solution: float only constraints that stand a jolly good chance of -being soluble simply by being floated, namely ones of form - a ~ ty -where 'a' is a currently-untouchable unification variable, but may -become touchable by being floated (perhaps by more than one level). - -We had a very complicated rule previously, but this is nice and -simple. (To see the notes, look at this Note in a version of -TcSimplify prior to Oct 2014). - -Note [Which equalities to float] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which equalities should we float? We want to float ones where there -is a decent chance that floating outwards will allow unification to -happen. In particular, float out equalities that are: - -* Of form (alpha ~# ty) or (ty ~# alpha), where - * alpha is a meta-tyvar. - * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar. In that - case, floating out won't help either, and it may affect grouping - of error messages. - -* Homogeneous (both sides have the same kind). Why only homogeneous? - Because heterogeneous equalities have derived kind equalities. - See Note [Equalities with incompatible kinds] in TcCanonical. - If we float out a hetero equality, then it will spit out the same - derived kind equality again, which might create duplicate error - messages. - - Instead, we do float out the kind equality (if it's worth floating - out, as above). If/when we solve it, we'll be able to rewrite the - original hetero equality to be homogeneous, and then perhaps make - progress / float it out. The duplicate error message was spotted in - typecheck/should_fail/T7368. - -* Nominal. No point in floating (alpha ~R# ty), because we do not - unify representational equalities even if alpha is touchable. - See Note [Do not unify representational equalities] in TcInteract. - -Note [Skolem escape] -~~~~~~~~~~~~~~~~~~~~ -You might worry about skolem escape with all this floating. -For example, consider - [2] forall a. (a ~ F beta[2] delta, - Maybe beta[2] ~ gamma[1]) - -The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and -solve with gamma := beta. But what if later delta:=Int, and - F b Int = b. -Then we'd get a ~ beta[2], and solve to get beta:=a, and now the -skolem has escaped! - -But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] -to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. - -Note [What prevents a constraint from floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What /prevents/ a constraint from floating? If it mentions one of the -"bound variables of the implication". What are they? - -The "bound variables of the implication" are - - 1. The skolem type variables `ic_skols` - - 2. The "given" evidence variables `ic_given`. Example: - forall a. (co :: t1 ~# t2) => [W] co2 : (a ~# b |> co) - Here 'co' is bound - - 3. The binders of all evidence bindings in `ic_binds`. Example - forall a. (d :: t1 ~ t2) - EvBinds { (co :: t1 ~# t2) = superclass-sel d } - => [W] co2 : (a ~# b |> co) - Here `co` is gotten by superclass selection from `d`, and the - wanted constraint co2 must not float. - - 4. And the evidence variable of any equality constraint (incl - Wanted ones) whose type mentions a bound variable. Example: - forall k. [W] co1 :: t1 ~# t2 |> co2 - [W] co2 :: k ~# * - Here, since `k` is bound, so is `co2` and hence so is `co1`. - -Here (1,2,3) are handled by the "seed_skols" calculation, and -(4) is done by the transCloVarSet call. - -The possible dependence on givens, and evidence bindings, is more -subtle than we'd realised at first. See #14584. - - -********************************************************************************* -* * -* Defaulting and disambiguation * -* * -********************************************************************************* --} - -applyDefaultingRules :: WantedConstraints -> TcS Bool --- True <=> I did some defaulting, by unifying a meta-tyvar --- Input WantedConstraints are not necessarily zonked - -applyDefaultingRules wanteds - | isEmptyWC wanteds - = return False - | otherwise - = do { info@(default_tys, _) <- getDefaultInfo - ; wanteds <- TcS.zonkWC wanteds - - ; let groups = findDefaultableGroups info wanteds - - ; traceTcS "applyDefaultingRules {" $ - vcat [ text "wanteds =" <+> ppr wanteds - , text "groups =" <+> ppr groups - , text "info =" <+> ppr info ] - - ; something_happeneds <- mapM (disambigGroup default_tys) groups - - ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - - ; return (or something_happeneds) } - -findDefaultableGroups - :: ( [Type] - , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> WantedConstraints -- Unsolved (wanted or derived) - -> [(TyVar, [Ct])] -findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds - | null default_tys - = [] - | otherwise - = [ (tv, map fstOf3 group) - | group'@((_,_,tv) :| _) <- unary_groups - , let group = toList group' - , defaultable_tyvar tv - , defaultable_classes (map sndOf3 group) ] - where - simples = approximateWC True wanteds - (unaries, non_unaries) = partitionWith find_unary (bagToList simples) - unary_groups = equivClasses cmp_tv unaries - - unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints - unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints - non_unaries :: [Ct] -- and *other* constraints - - -- Finds unary type-class constraints - -- But take account of polykinded classes like Typeable, - -- which may look like (Typeable * (a:*)) (#8931) - find_unary :: Ct -> Either (Ct, Class, TyVar) Ct - find_unary cc - | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) - , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys - -- Ignore invisible arguments for this purpose - , Just tv <- tcGetTyVar_maybe ty - , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and - -- we definitely don't want to try to assign to those! - = Left (cc, cls, tv) - find_unary cc = Right cc -- Non unary or non dictionary - - bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries - bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries - - cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - - defaultable_tyvar :: TcTyVar -> Bool - defaultable_tyvar tv - = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] - b2 = not (tv `elemVarSet` bad_tvs) - in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] - - defaultable_classes :: [Class] -> Bool - defaultable_classes clss - | extended_defaults = any (isInteractiveClass ovl_strings) clss - | otherwise = all is_std_class clss && (any (isNumClass ovl_strings) clss) - - -- is_std_class adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled - is_std_class cls = isStandardClass cls || - (ovl_strings && (cls `hasKey` isStringClassKey)) - ------------------------------- -disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All classes of the form (C a) - -- sharing same type variable - -> TcS Bool -- True <=> something happened, reflected in ty_binds - -disambigGroup [] _ - = return False -disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) - = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) - ; fake_ev_binds_var <- TcS.newTcEvBinds - ; tclvl <- TcS.getTcLevel - ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group - - ; if success then - -- Success: record the type variable binding, and return - do { unifyTyVar the_tv default_ty - ; wrapWarnTcS $ warnDefaulting wanteds default_ty - ; traceTcS "disambigGroup succeeded }" (ppr default_ty) - ; return True } - else - -- Failure: try with the next type - do { traceTcS "disambigGroup failed, will try other default types }" - (ppr default_ty) - ; disambigGroup default_tys group } } - where - try_group - | Just subst <- mb_subst - = do { lcl_env <- TcS.getLclEnv - ; tc_lvl <- TcS.getTcLevel - ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env - ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) - wanteds - ; fmap isEmptyWC $ - solveSimpleWanteds $ listToBag $ - map mkNonCanonical wanted_evs } - - | otherwise - = return False - - the_ty = mkTyVarTy the_tv - mb_subst = tcMatchTyKi the_ty default_ty - -- Make sure the kinds match too; hence this call to tcMatchTyKi - -- E.g. suppose the only constraint was (Typeable k (a::k)) - -- With the addition of polykinded defaulting we also want to reject - -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. - --- In interactive mode, or with -XExtendedDefaultRules, --- we default Show a to Show () to avoid graututious errors on "show []" -isInteractiveClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isInteractiveClass ovl_strings cls - = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) - - -- isNumClass adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled -isNumClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isNumClass ovl_strings cls - = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - - -{- -Note [Avoiding spurious errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When doing the unification for defaulting, we check for skolem -type variables, and simply don't default them. For example: - f = (*) -- Monomorphic - g :: Num a => a -> a - g x = f x x -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num a) context arising from f's definition; -we try to unify a with Int (to default it), but find that it's -already been unified with the rigid variable from g's type sig. - -Note [Multi-parameter defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XExtendedDefaultRules, we default only based on single-variable -constraints, but do not exclude from defaulting any type variables which also -appear in multi-variable constraints. This means that the following will -default properly: - - default (Integer, Double) - - class A b (c :: Symbol) where - a :: b -> Proxy c - - instance A Integer c where a _ = Proxy - - main = print (a 5 :: Proxy "5") - -Note that if we change the above instance ("instance A Integer") to -"instance A Double", we get an error: - - No instance for (A Integer "5") - -This is because the first defaulted type (Integer) has successfully satisfied -its single-parameter constraints (in this case Num). --} diff --git a/typecheck/TcSplice.hs b/typecheck/TcSplice.hs deleted file mode 100644 --- a/typecheck/TcSplice.hs +++ /dev/null @@ -1,2254 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcSplice: Template Haskell splices --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module TcSplice( - tcSpliceExpr, tcTypedBracket, tcUntypedBracket, --- runQuasiQuoteExpr, runQuasiQuotePat, --- runQuasiQuoteDecl, runQuasiQuoteType, - runAnnotation, - - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, - tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta', runRemoteModFinalizers, - finishTH, runTopSplice - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import Annotations -import Finder -import Name -import TcRnMonad -import TcType - -import Outputable -import TcExpr -import SrcLoc -import THNames -import TcUnify -import TcEnv -import TcOrigin -import Coercion( etaExpandCoAxBranch ) -import FileCleanup ( newTempName, TempFileLifetime(..) ) - -import Control.Monad - -import GHCi.Message -import GHCi.RemoteTypes -import GHCi -import HscMain - -- These imports are the reason that TcSplice - -- is very high up the module hierarchy -import RnSplice( traceSplice, SpliceInfo(..)) -import RdrName -import HscTypes -import GHC.ThToHs -import RnExpr -import RnEnv -import RnUtils ( HsDocContext(..) ) -import RnFixity ( lookupFixityRn_help ) -import RnTypes -import TcHsSyn -import TcSimplify -import Type -import NameSet -import TcMType -import TcHsType -import TcIface -import TyCoRep -import FamInst -import FamInstEnv -import InstEnv -import Inst -import NameEnv -import PrelNames -import TysWiredIn -import OccName -import Hooks -import Var -import Module -import LoadIface -import Class -import TyCon -import CoAxiom -import PatSyn -import ConLike -import DataCon -import TcEvidence( TcEvBinds(..) ) -import Id -import IdInfo -import DsExpr -import DsMonad -import GHC.Serialized -import ErrUtils -import Util -import Unique -import VarSet -import Data.List ( find ) -import Data.Maybe -import FastString -import BasicTypes hiding( SuccessFlag(..) ) -import Maybes( MaybeErr(..) ) -import DynFlags -import Panic -import Lexeme -import qualified EnumSet -import Plugins -import Bag - -import qualified Language.Haskell.TH as TH --- THSyntax gives access to internal functions and data types -import qualified Language.Haskell.TH.Syntax as TH - --- Because GHC.Desugar might not be in the base library of the bootstrapping compiler -import GHC.Desugar ( AnnotationWrapper(..) ) - -import Control.Exception -import Data.Binary -import Data.Binary.Get -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import Data.Dynamic ( fromDynamic, toDyn ) -import qualified Data.Map as Map -import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) -import Data.Data (Data) -import Data.Proxy ( Proxy (..) ) -import GHC.Exts ( unsafeCoerce# ) - -{- -************************************************************************ -* * -\subsection{Main interface + stubs for the non-GHCI case -* * -************************************************************************ --} - -tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) - -- None of these functions add constraints to the LIE - --- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) --- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) --- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) --- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] - -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -{- -************************************************************************ -* * -\subsection{Quoting an expression} -* * -************************************************************************ --} - --- See Note [How brackets and nested splices are handled] --- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty - = addErrCtxt (quotationCtxtDoc brack) $ - do { cur_stage <- getStage - ; ps_ref <- newMutVar [] - ; lie_var <- getConstraintVar -- Any constraints arising from nested splices - -- should get thrown into the constraint set - -- from outside the bracket - - -- Typecheck expr to make sure it is valid, - -- Throw away the typechecked expression but return its type. - -- We'll typecheck it again when we splice it in somewhere - ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $ - tcInferRhoNC expr - -- NC for no context; tcBracket does that - ; let rep = getRuntimeRep expr_ty - - ; meta_ty <- tcTExpTy expr_ty - ; ps' <- readMutVar ps_ref - ; texpco <- tcLookupId unsafeTExpCoerceName - ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") - rn_expr - (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty]) - (noLoc (HsTcBracketOut noExtField brack ps')))) - meta_ty res_ty } -tcTypedBracket _ other_brack _ - = pprPanic "tcTypedBracket" (ppr other_brack) - --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) -tcUntypedBracket rn_expr brack ps res_ty - = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) - ; ps' <- mapM tcPendingSplice ps - ; meta_ty <- tcBrackTy brack - ; traceTc "tc_bracket done untyped" (ppr meta_ty) - ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket") - rn_expr (HsTcBracketOut noExtField brack ps') meta_ty res_ty } - ---------------- -tcBrackTy :: HsBracket GhcRn -> TcM TcType -tcBrackTy (VarBr {}) = tcMetaTy nameTyConName - -- Result type is Var (not Q-monadic) -tcBrackTy (ExpBr {}) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) -tcBrackTy (TypBr {}) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) -tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec] -tcBrackTy (PatBr {}) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) -tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL" -tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr" -tcBrackTy (XBracket nec) = noExtCon nec - ---------------- -tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice -tcPendingSplice (PendingRnSplice flavour splice_name expr) - = do { res_ty <- tcMetaTy meta_ty_name - ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty) - ; return (PendingTcSplice splice_name expr') } - where - meta_ty_name = case flavour of - UntypedExpSplice -> expQTyConName - UntypedPatSplice -> patQTyConName - UntypedTypeSplice -> typeQTyConName - UntypedDeclSplice -> decsQTyConName - ---------------- --- Takes a tau and returns the type Q (TExp tau) -tcTExpTy :: TcType -> TcM TcType -tcTExpTy exp_ty - = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) - ; q <- tcLookupTyCon qTyConName - ; texp <- tcLookupTyCon tExpTyConName - ; let rep = getRuntimeRep exp_ty - ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) } - where - err_msg ty - = vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] - -quotationCtxtDoc :: HsBracket GhcRn -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (ppr br_body) - - - -- The whole of the rest of the file is the else-branch (ie stage2 only) - -{- -Note [How top-level splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level splices (those not inside a [| .. |] quotation bracket) are handled -very straightforwardly: - - 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) - - 2. runMetaT: desugar, compile, run it, and convert result back to - GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, - HsExpr RdrName etc) - - 3. treat the result as if that's what you saw in the first place - e.g for HsType, rename and kind-check - for HsExpr, rename and type-check - - (The last step is different for decls, because they can *only* be - top-level: we return the result of step 2.) - -Note [How brackets and nested splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nested splices (those inside a [| .. |] quotation bracket), -are treated quite differently. - -Remember, there are two forms of bracket - typed [|| e ||] - and untyped [| e |] - -The life cycle of a typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s RnPendingTyped) - * Rename the body - * Result is still a HsBracket - - * When typechecking: - * Set the ThStage to (Brack s (TcPending ps_var lie_var)) - * Typecheck the body, and throw away the elaborated result - * Nested splices (which must be typed) are typechecked, and - the results accumulated in ps_var; their constraints - accumulate in lie_var - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - -The life cycle of a un-typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) - * Rename the body - * Nested splices (which must be untyped) are renamed, and the - results accumulated in ps_var - * Result is still (HsRnBracketOut rn_body pending_splices) - - * When typechecking a HsRnBracketOut - * Typecheck the pending_splices individually - * Ignore the body of the bracket; just check that the context - expects a bracket of that type (e.g. a [p| pat |] bracket should - be in a context needing a (Q Pat) - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - - -In both cases, desugaring happens like this: - * HsTcBracketOut is desugared by DsMeta.dsBracket. It - - a) Extends the ds_meta environment with the PendingSplices - attached to the bracket - - b) Converts the quoted (HsExpr Name) to a CoreExpr that, when - run, will produce a suitable TH expression/type/decl. This - is why we leave the *renamed* expression attached to the bracket: - the quoted expression should not be decorated with all the goop - added by the type checker - - * Each splice carries a unique Name, called a "splice point", thus - ${n}(e). The name is initialised to an (Unqual "splice") when the - splice is created; the renamer gives it a unique. - - * When DsMeta (used to desugar the body of the bracket) comes across - a splice, it looks up the splice's Name, n, in the ds_meta envt, - to find an (HsExpr Id) that should be substituted for the splice; - it just desugars it to get a CoreExpr (DsMeta.repSplice). - -Example: - Source: f = [| Just $(g 3) |] - The [| |] part is a HsBracket - - Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} - The [| |] part is a HsBracketOut, containing *renamed* - (not typechecked) expression - The "s7" is the "splice point"; the (g Int 3) part - is a typechecked expression - - Desugared: f = do { s7 <- g Int 3 - ; return (ConE "Data.Maybe.Just" s7) } - - -Note [Template Haskell state diagram] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here are the ThStages, s, their corresponding level numbers -(the result of (thLevel s)), and their state transitions. -The top level of the program is stage Comp: - - Start here - | - V - ----------- $ ------------ $ - | Comp | ---------> | Splice | -----| - | 1 | | 0 | <----| - ----------- ------------ - ^ | ^ | - $ | | [||] $ | | [||] - | v | v - -------------- ---------------- - | Brack Comp | | Brack Splice | - | 2 | | 1 | - -------------- ---------------- - -* Normal top-level declarations start in state Comp - (which has level 1). - Annotations start in state Splice, since they are - treated very like a splice (only without a '$') - -* Code compiled in state Splice (and only such code) - will be *run at compile time*, with the result replacing - the splice - -* The original paper used level -1 instead of 0, etc. - -* The original paper did not allow a splice within a - splice, but there is no reason not to. This is the - $ transition in the top right. - -Note [Template Haskell levels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Imported things are impLevel (= 0) - -* However things at level 0 are not *necessarily* imported. - eg $( \b -> ... ) here b is bound at level 0 - -* In GHCi, variables bound by a previous command are treated - as impLevel, because we have bytecode for them. - -* Variables are bound at the "current level" - -* The current level starts off at outerLevel (= 1) - -* The level is decremented by splicing $(..) - incremented by brackets [| |] - incremented by name-quoting 'f - -When a variable is used, we compare - bind: binding level, and - use: current level at usage site - - Generally - bind > use Always error (bound later than used) - [| \x -> $(f x) |] - - bind = use Always OK (bound same stage as used) - [| \x -> $(f [| x |]) |] - - bind < use Inside brackets, it depends - Inside splice, OK - Inside neither, OK - - For (bind < use) inside brackets, there are three cases: - - Imported things OK f = [| map |] - - Top-level things OK g = [| f |] - - Non-top-level Only if there is a liftable instance - h = \(x:Int) -> [| x |] - - To track top-level-ness we use the ThBindEnv in TcLclEnv - - For example: - f = ... - g1 = $(map ...) is OK - g2 = $(f ...) is not OK; because we havn't compiled f yet - --} - --- | We only want to produce warnings for TH-splices if the user requests so. --- See Note [Warnings for TH splices]. -getThSpliceOrigin :: TcM Origin -getThSpliceOrigin = do - warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return Generated - -{- Note [Warnings for TH splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only produce warnings for TH splices when the user requests so -(-fenable-th-splice-warnings). There are multiple reasons: - - * It's not clear that the user that compiles a splice is the author of the code - that produces the warning. Think of the situation where she just splices in - code from a third-party library that produces incomplete pattern matches. - In this scenario, the user isn't even able to fix that warning. - * Gathering information for producing the warnings (pattern-match check - warnings in particular) is costly. There's no point in doing so if the user - is not interested in those warnings. - -That's why we store Origin flags in the Haskell AST. The functions from ThToHs -take such a flag and depending on whether TH splice warnings were enabled or -not, we pass FromSource (if the user requests warnings) or Generated -(otherwise). This is implemented in getThSpliceOrigin. - -For correct pattern-match warnings it's crucial that we annotate the Origin -consistently (#17270). In the future we could offer the Origin as part of the -TH AST. That would enable us to give quotes from the current module get -FromSource origin, and/or third library authors to tag certain parts of -generated code as FromSource to enable warnings. That effort is tracked in -#14838. --} - -{- -************************************************************************ -* * -\subsection{Splicing an expression} -* * -************************************************************************ --} - -tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty - = addErrCtxt (spliceCtxtDoc splice) $ - setSrcSpan (getLoc expr) $ do - { stage <- getStage - ; case stage of - Splice {} -> tcTopSplice expr res_ty - Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty - RunSplice _ -> - -- See Note [RunSplice ThLevel] in "TcRnTypes". - pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ - "running another splice") (ppr splice) - Comp -> tcTopSplice expr res_ty - } -tcSpliceExpr splice _ - = pprPanic "tcSpliceExpr" (ppr splice) - -{- Note [Collecting modFinalizers in typed splices] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local -environment (see Note [Delaying modFinalizers in untyped splices] in -"RnSplice"). Thus after executing the splice, we move the finalizers to the -finalizer list in the global environment and set them to use the current local -environment (with 'addModFinalizersWithLclEnv'). - --} - -tcNestedSplice :: ThStage -> PendingStuff -> Name - -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets -tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty - = do { res_ty <- expTypeToType res_ty - ; let rep = getRuntimeRep res_ty - ; meta_exp_ty <- tcTExpTy res_ty - ; expr' <- setStage pop_stage $ - setConstraintVar lie_var $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - ; untypeq <- tcLookupId unTypeQName - ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr' - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) - - -- The returned expression is ignored; it's in the pending splices - ; return (panic "tcSpliceExpr") } - -tcNestedSplice _ _ splice_name _ _ - = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) - -tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcTopSplice expr res_ty - = do { -- Typecheck the expression, - -- making sure it has type Q (T res_ty) - res_ty <- expTypeToType res_ty - ; meta_exp_ty <- tcTExpTy res_ty - ; q_expr <- tcTopSpliceExpr Typed $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - ; lcl_env <- getLclEnv - ; let delayed_splice - = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsSpliceE noExtField (HsSplicedT delayed_splice)) - - } - - --- This is called in the zonker --- See Note [Running typed splices in the zonker] -runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) -runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) - = setLclEnv lcl_env $ do { - zonked_ty <- zonkTcType res_ty - ; zonked_q_expr <- zonkTopLExpr q_expr - -- See Note [Collecting modFinalizers in typed splices]. - ; modfinalizers_ref <- newTcRef [] - -- Run the expression - ; expr2 <- setStage (RunSplice modfinalizers_ref) $ - runMetaE zonked_q_expr - ; mod_finalizers <- readTcRef modfinalizers_ref - ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers - -- We use orig_expr here and not q_expr when tracing as a call to - -- unsafeTExpCoerce is added to the original expression by the - -- typechecker when typed quotes are type checked. - ; traceSplice (SpliceInfo { spliceDescription = "expression" - , spliceIsDecl = False - , spliceSource = Just orig_expr - , spliceGenerated = ppr expr2 }) - -- Rename and typecheck the spliced-in expression, - -- making sure it has type res_ty - -- These steps should never fail; this is a *typed* splice - ; (res, wcs) <- - captureConstraints $ - addErrCtxt (spliceResultDoc zonked_q_expr) $ do - { (exp3, _fvs) <- rnLExpr expr2 - ; tcMonoExpr exp3 (mkCheckExpType zonked_ty)} - ; ev <- simplifyTop wcs - ; return $ unLoc (mkHsDictLet (EvBinds ev) res) - } - - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -spliceCtxtDoc :: HsSplice GhcRn -> SDoc -spliceCtxtDoc splice - = hang (text "In the Template Haskell splice") - 2 (pprSplice splice) - -spliceResultDoc :: LHsExpr GhcTc -> SDoc -spliceResultDoc expr - = sep [ text "In the result of the splice:" - , nest 2 (char '$' <> ppr expr) - , text "To see what the splice expanded to, use -ddump-splices"] - -------------------- -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) --- Note [How top-level splices are handled] --- Type check an expression that is the body of a top-level splice --- (the caller will compile and run it) --- Note that set the level to Splice, regardless of the original level, --- before typechecking the expression. For example: --- f x = $( ...$(g 3) ... ) --- The recursive call to tcPolyExpr will simply expand the --- inner escape before dealing with the outer one - -tcTopSpliceExpr isTypedSplice tc_action - = checkNoErrs $ -- checkNoErrs: must not try to run the thing - -- if the type checker fails! - unsetGOptM Opt_DeferTypeErrors $ - -- Don't defer type errors. Not only are we - -- going to run this code, but we do an unsafe - -- coerce, so we get a seg-fault if, say we - -- splice a type into a place where an expression - -- is expected (#7276) - setStage (Splice isTypedSplice) $ - do { -- Typecheck the expression - (expr', wanted) <- captureConstraints tc_action - ; const_binds <- simplifyTop wanted - - -- Zonk it and tie the knot of dictionary bindings - ; return $ mkHsDictLet (EvBinds const_binds) expr' } - -{- -************************************************************************ -* * - Annotations -* * -************************************************************************ --} - -runAnnotation target expr = do - -- Find the classes we want instances for in order to call toAnnotationWrapper - loc <- getSrcSpanM - data_class <- tcLookupClass dataClassName - to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName - - -- Check the instances we require live in another module (we want to execute it..) - -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr - -- also resolves the LIE constraints to detect e.g. instance ambiguity - zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( - do { (expr', expr_ty) <- tcInferRhoNC expr - -- We manually wrap the typechecked expression in a call to toAnnotationWrapper - -- By instantiating the call >here< it gets registered in the - -- LIE consulted by tcTopSpliceExpr - -- and hence ensures the appropriate dictionary is bound by const_binds - ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] - ; let specialised_to_annotation_wrapper_expr - = L loc (mkHsWrap wrapper - (HsVar noExtField (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp noExtField - specialised_to_annotation_wrapper_expr expr')) - }) - - -- Run the appropriately wrapped expression to get the value of - -- the annotation and its dictionaries. The return value is of - -- type AnnotationWrapper by construction, so this conversion is - -- safe - serialized <- runMetaAW zonked_wrapped_expr' - return Annotation { - ann_target = target, - ann_value = serialized - } - -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) -convertAnnotationWrapper fhv = do - dflags <- getDynFlags - if gopt Opt_ExternalInterpreter dflags - then do - Right <$> runTH THAnnWrapper fhv - else do - annotation_wrapper <- liftIO $ wormhole dflags fhv - return $ Right $ - case unsafeCoerce# annotation_wrapper of - AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> - -- Got the value and dictionaries: build the serialized value and - -- call it a day. We ensure that we seq the entire serialized value - -- in order that any errors in the user-written code for the - -- annotation are exposed at this point. This is also why we are - -- doing all this stuff inside the context of runMeta: it has the - -- facilities to deal with user error in a meta-level expression - seqSerialized serialized `seq` serialized - --- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms -seqSerialized :: Serialized -> () -seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () - - -{- -************************************************************************ -* * -\subsection{Running an expression} -* * -************************************************************************ --} - -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act - -runRemoteModFinalizers :: ThModFinalizers -> TcM () -runRemoteModFinalizers (ThModFinalizers finRefs) = do - dflags <- getDynFlags - let withForeignRefs [] f = f [] - withForeignRefs (x : xs) f = withForeignRef x $ \r -> - withForeignRefs xs $ \rs -> f (r : rs) - if gopt Opt_ExternalInterpreter dflags then do - hsc_env <- env_top <$> getEnv - withIServ hsc_env $ \i -> do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Nothing -> return () -- TH was not started, nothing to do - Just fhv -> do - liftIO $ withForeignRef fhv $ \st -> - withForeignRefs finRefs $ \qrefs -> - writeIServ i (putMessage (RunModFinalizers st qrefs)) - () <- runRemoteTH i [] - readQResult i - else do - qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs - -runQResult - :: (a -> String) - -> (Origin -> SrcSpan -> a -> b) - -> (ForeignHValue -> TcM a) - -> SrcSpan - -> ForeignHValue {- TH.Q a -} - -> TcM b -runQResult show_th f runQ expr_span hval - = do { th_result <- runQ hval - ; th_origin <- getThSpliceOrigin - ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f th_origin expr_span th_result) } - - ------------------ -runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) - -> LHsExpr GhcTc - -> TcM hs_syn -runMeta unwrap e - = do { h <- getHooked runMetaHook defaultRunMeta - ; unwrap h e } - -defaultRunMeta :: MetaHook TcM -defaultRunMeta (MetaE r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) -defaultRunMeta (MetaP r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) -defaultRunMeta (MetaT r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) -defaultRunMeta (MetaD r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) -defaultRunMeta (MetaAW r) - = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) - -- We turn off showing the code in meta-level exceptions because doing so exposes - -- the toAnnotationWrapper function that we slap around the user's code - ----------------- -runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper - -> TcM Serialized -runMetaAW = runMeta metaRequestAW - -runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) - -> TcM (LHsExpr GhcPs) -runMetaE = runMeta metaRequestE - -runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) - -> TcM (LPat GhcPs) -runMetaP = runMeta metaRequestP - -runMetaT :: LHsExpr GhcTc -- Of type (Q Type) - -> TcM (LHsType GhcPs) -runMetaT = runMeta metaRequestT - -runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] - -> TcM [LHsDecl GhcPs] -runMetaD = runMeta metaRequestD - ---------------- -runMeta' :: Bool -- Whether code should be printed in the exception message - -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x - -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or - -- something like that - -> TcM hs_syn -- Of type t -runMeta' show_code ppr_hs run_and_convert expr - = do { traceTc "About to run" (ppr expr) - ; recordThSpliceUse -- seems to be the best place to do this, - -- we catch all kinds of splices and annotations. - - -- Check that we've had no errors of any sort so far. - -- For example, if we found an error in an earlier defn f, but - -- recovered giving it type f :: forall a.a, it'd be very dodgy - -- to carry ont. Mind you, the staging restrictions mean we won't - -- actually run f, but it still seems wrong. And, more concretely, - -- see #5358 for an example that fell over when trying to - -- reify a function with a "?" kind in it. (These don't occur - -- in type-correct programs. - ; failIfErrsM - - -- run plugins - ; hsc_env <- getTopEnv - ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr - - -- Desugar - ; ds_expr <- initDsTc (dsLExpr expr') - -- Compile and link it; might fail if linking fails - ; src_span <- getSrcSpanM - ; traceTc "About to run (desugared)" (ppr ds_expr) - ; either_hval <- tryM $ liftIO $ - HscMain.hscCompileCoreExpr hsc_env src_span ds_expr - ; case either_hval of { - Left exn -> fail_with_exn "compile and link" exn ; - Right hval -> do - - { -- Coerce it to Q t, and run it - - -- Running might fail if it throws an exception of any kind (hence tryAllM) - -- including, say, a pattern-match exception in the code we are running - -- - -- We also do the TH -> HS syntax conversion inside the same - -- exception-cacthing thing so that if there are any lurking - -- exceptions in the data structure returned by hval, we'll - -- encounter them inside the try - -- - -- See Note [Exceptions in TH] - let expr_span = getLoc expr - ; either_tval <- tryAllM $ - setSrcSpan expr_span $ -- Set the span so that qLocation can - -- see where this splice is - do { mb_result <- run_and_convert expr_span hval - ; case mb_result of - Left err -> failWithTc err - Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) - ; return $! result } } - - ; case either_tval of - Right v -> return v - Left se -> case fromException se of - Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> fail_with_exn "run" se -- Exception - }}} - where - -- see Note [Concealed TH exceptions] - fail_with_exn :: Exception e => String -> e -> TcM a - fail_with_exn phase exn = do - exn_msg <- liftIO $ Panic.safeShowException exn - let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", - nest 2 (text exn_msg), - if show_code then text "Code:" <+> ppr expr else empty] - failWithTc msg - -{- -Note [Running typed splices in the zonker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -See #15471 for the full discussion. - -For many years typed splices were run immediately after they were type checked -however, this is too early as it means to zonk some type variables before -they can be unified with type variables in the surrounding context. - -For example, - -``` -module A where - -test_foo :: forall a . Q (TExp (a -> a)) -test_foo = [|| id ||] - -module B where - -import A - -qux = $$(test_foo) -``` - -We would expect `qux` to have inferred type `forall a . a -> a` but if -we run the splices too early the unified variables are zonked to `Any`. The -inferred type is the unusable `Any -> Any`. - -To run the splice, we must compile `test_foo` all the way to byte code. -But at the moment when the type checker is looking at the splice, test_foo -has type `Q (TExp (alpha -> alpha))` and we -certainly can't compile code involving unification variables! - -We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` -which definitely is not what we want. Moreover, if we had - qux = [$$(test_foo), (\x -> x +1::Int)] -then `alpha` would have to be `Int`. - -Conclusion: we must defer taking decisions about `alpha` until the -typechecker is done; and *then* we can run the splice. It's fine to do it -later, because we know it'll produce type-correct code. - -Deferring running the splice until later, in the zonker, means that the -unification variables propagate upwards from the splice into the surrounding -context and are unified correctly. - -This is implemented by storing the arguments we need for running the splice -in a `DelayedSplice`. In the zonker, the arguments are passed to -`TcSplice.runTopSplice` and the expression inserted into the AST as normal. - - - -Note [Exceptions in TH] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like this - $( f 4 ) -where - f :: Int -> Q [Dec] - f n | n>3 = fail "Too many declarations" - | otherwise = ... - -The 'fail' is a user-generated failure, and should be displayed as a -perfectly ordinary compiler error message, not a panic or anything -like that. Here's how it's processed: - - * 'fail' is the monad fail. The monad instance for Q in TH.Syntax - effectively transforms (fail s) to - qReport True s >> fail - where 'qReport' comes from the Quasi class and fail from its monad - superclass. - - * The TcM monad is an instance of Quasi (see TcSplice), and it implements - (qReport True s) by using addErr to add an error message to the bag of errors. - The 'fail' in TcM raises an IOEnvFailure exception - - * 'qReport' forces the message to ensure any exception hidden in unevaluated - thunk doesn't get into the bag of errors. Otherwise the following splice - will triger panic (#8987): - $(fail undefined) - See also Note [Concealed TH exceptions] - - * So, when running a splice, we catch all exceptions; then for - - an IOEnvFailure exception, we assume the error is already - in the error-bag (above) - - other errors, we add an error to the bag - and then fail - -Note [Concealed TH exceptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When displaying the error message contained in an exception originated from TH -code, we need to make sure that the error message itself does not contain an -exception. For example, when executing the following splice: - - $( error ("foo " ++ error "bar") ) - -the message for the outer exception is a thunk which will throw the inner -exception when evaluated. - -For this reason, we display the message of a TH exception using the -'safeShowException' function, which recursively catches any exception thrown -when showing an error message. - - -To call runQ in the Tc monad, we need to make TcM an instance of Quasi: --} - -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } - - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addWarn NoReason (text msg) - - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - RealSrcSpan s -> return s - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitIdString (moduleUnitId m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddTempFile suffix = do - dflags <- getDynFlags - liftIO $ newTempName dflags TFL_GhcSession suffix - - qAddTopDecls thds = do - l <- getSrcSpanM - th_origin <- getThSpliceOrigin - let either_hval = convertToHsDecls th_origin l thds - ds <- case either_hval of - Left exn -> failWithTc $ - hang (text "Error in a declaration passed to addTopDecls:") - 2 exn - Right ds -> return ds - mapM_ (checkTopDecl . unLoc) ds - th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - updTcRef th_topdecls_var (\topds -> ds ++ topds) - where - checkTopDecl :: HsDecl GhcPs -> TcM () - checkTopDecl (ValD _ binds) - = mapM_ bindName (collectHsBindBinders binds) - checkTopDecl (SigD _ _) - = return () - checkTopDecl (AnnD _ _) - = return () - checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) - = bindName name - checkTopDecl _ - = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" - - bindName :: RdrName -> TcM () - bindName (Exact n) - = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } - - bindName name = - addErr $ - hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) - 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") - - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- env_top <$> getEnv - r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin) - let err = hang - (text "addCorePlugin: invalid plugin module " - <+> text (show plugin) - ) - 2 - (text "Plugins in the current package can't be specified.") - case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - --- | Adds a mod finalizer reference to the local environment. -addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () -addModFinalizerRef finRef = do - th_stage <- getStage - case th_stage of - RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) - -- This case happens only if a splice is executed and the caller does - -- not set the 'ThStage' to 'RunSplice' to collect finalizers. - -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. - _ -> - pprPanic "addModFinalizer was called when no finalizers were collected" - (ppr th_stage) - --- | Releases the external interpreter state. -finishTH :: TcM () -finishTH = do - dflags <- getDynFlags - when (gopt Opt_ExternalInterpreter dflags) $ do - tcg <- getGblEnv - writeTcRef (tcg_th_remote_state tcg) Nothing - -runTHExp :: ForeignHValue -> TcM TH.Exp -runTHExp = runTH THExp - -runTHPat :: ForeignHValue -> TcM TH.Pat -runTHPat = runTH THPat - -runTHType :: ForeignHValue -> TcM TH.Type -runTHType = runTH THType - -runTHDec :: ForeignHValue -> TcM [TH.Dec] -runTHDec = runTH THDec - -runTH :: Binary a => THResultType -> ForeignHValue -> TcM a -runTH ty fhv = do - hsc_env <- env_top <$> getEnv - dflags <- getDynFlags - if not (gopt Opt_ExternalInterpreter dflags) - then do - -- Run it in the local TcM - hv <- liftIO $ wormhole dflags fhv - r <- runQuasi (unsafeCoerce# hv :: TH.Q a) - return r - else - -- Run it on the server. For an overview of how TH works with - -- Remote GHCi, see Note [Remote Template Haskell] in - -- libraries/ghci/GHCi/TH.hs. - withIServ hsc_env $ \i -> do - rstate <- getTHState i - loc <- TH.qLocation - liftIO $ - withForeignRef rstate $ \state_hv -> - withForeignRef fhv $ \q_hv -> - writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) - runRemoteTH i [] - bs <- readQResult i - return $! runGet get (LB.fromStrict bs) - - --- | communicate with a remotely-running TH computation until it finishes. --- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. -runRemoteTH - :: IServ - -> [Messages] -- saved from nested calls to qRecover - -> TcM () -runRemoteTH iserv recovers = do - THMsg msg <- liftIO $ readIServ iserv getTHMessage - case msg of - RunTHDone -> return () - StartRecover -> do -- Note [TH recover with -fexternal-interpreter] - v <- getErrsVar - msgs <- readTcRef v - writeTcRef v emptyMessages - runRemoteTH iserv (msgs : recovers) - EndRecover caught_error -> do - let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of - [] -> panic "EndRecover" - a : b -> (a,b) - v <- getErrsVar - (warn_msgs,_) <- readTcRef v - -- keep the warnings only if there were no errors - writeTcRef v $ if caught_error - then prev_msgs - else (prev_warns `unionBags` warn_msgs, prev_errs) - runRemoteTH iserv rest - _other -> do - r <- handleTHMessage msg - liftIO $ writeIServ iserv (put r) - runRemoteTH iserv recovers - --- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServ -> TcM a -readQResult i = do - qr <- liftIO $ readIServ i get - case qr of - QDone a -> return a - QException str -> liftIO $ throwIO (ErrorCall str) - QFail str -> fail str - -{- Note [TH recover with -fexternal-interpreter] - -Recover is slightly tricky to implement. - -The meaning of "recover a b" is - - Do a - - If it finished with no errors, then keep the warnings it generated - - If it failed, discard any messages it generated, and do b - -Note that "failed" here can mean either - (1) threw an exception (failTc) - (2) generated an error message (addErrTcM) - -The messages are managed by GHC in the TcM monad, whereas the -exception-handling is done in the ghc-iserv process, so we have to -coordinate between the two. - -On the server: - - emit a StartRecover message - - run "a; FailIfErrs" inside a try - - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed - - if "a; FailIfErrs" failed, run "b" - -Back in GHC, when we receive: - - FailIfErrrs - failTc if there are any error messages (= failIfErrsM) - StartRecover - save the current messages and start with an empty set. - EndRecover caught_error - Restore the previous messages, - and merge in the new messages if caught_error is false. --} - --- | Retrieve (or create, if it hasn't been created already), the --- remote TH state. The TH state is a remote reference to an IORef --- QState living on the server, and we have to pass this to each RunTH --- call we make. --- --- The TH state is stored in tcg_th_remote_state in the TcGblEnv. --- -getTHState :: IServ -> TcM (ForeignRef (IORef QState)) -getTHState i = do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Just rhv -> return rhv - Nothing -> do - hsc_env <- env_top <$> getEnv - fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH - writeTcRef (tcg_th_remote_state tcg) (Just fhv) - return fhv - -wrapTHResult :: TcM a -> TcM (THResult a) -wrapTHResult tcm = do - e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic - case e of - Left e -> return (THException (show e)) - Right a -> return (THComplete a) - -handleTHMessage :: THMessage a -> TcM a -handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n - ReifyAnnotations lookup tyrep -> - wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s - AddModFinalizer r -> do - hsc_env <- env_top <$> getEnv - wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - FailIfErrs -> wrapTHResult failIfErrsM - _ -> panic ("handleTHMessage: unexpected message " ++ show msg) - -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] -getAnnotationsByTypeRep th_name tyrep - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep - ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - -{- -************************************************************************ -* * - Instance Testing -* * -************************************************************************ --} - -reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] -reifyInstances th_nm th_tys - = addErrCtxt (text "In the argument of reifyInstances:" - <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ - do { loc <- getSrcSpanM - ; th_origin <- getThSpliceOrigin - ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) - -- #9262 says to bring vars into scope, like in HsForAllTy case - -- of rnHsTyKi - ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty - -- Rename to HsType Name - ; ((tv_names, rn_ty), _fvs) - <- checkNoErrs $ -- If there are out-of-scope Names here, then we - -- must error before proceeding to typecheck the - -- renamed type, as that will result in GHC - -- internal errors (#13837). - bindLRdrNames tv_rdrs $ \ tv_names -> - do { (rn_ty, fvs) <- rnLHsType doc rdr_ty - ; return ((tv_names, rn_ty), fvs) } - ; (_tvs, ty) - <- pushTcLevelM_ $ - solveEqualities $ -- Avoid error cascade if there are unsolved - bindImplicitTKBndrs_Skol tv_names $ - fst <$> tcLHsType rn_ty - ; ty <- zonkTcTypeToType ty - -- Substitute out the meta type variables - -- In particular, the type might have kind - -- variables inside it (#7477) - - ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty)) - ; case splitTyConApp_maybe ty of -- This expands any type synonyms - Just (tc, tys) -- See #7910 - | Just cls <- tyConClass_maybe tc - -> do { inst_envs <- tcGetInstEnvs - ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys - ; traceTc "reifyInstances1" (ppr matches) - ; reifyClassInstances cls (map fst matches ++ unifies) } - | isOpenFamilyTyCon tc - -> do { inst_envs <- tcGetFamInstEnvs - ; let matches = lookupFamInstEnv inst_envs tc tys - ; traceTc "reifyInstances2" (ppr matches) - ; reifyFamilyInstances tc (map fim_instance matches) } - _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } - where - doc = ClassInstanceCtx - bale_out msg = failWithTc msg - - cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) - cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc msg - Right ty -> return ty - -{- -************************************************************************ -* * - Reification -* * -************************************************************************ --} - -lookupName :: Bool -- True <=> type namespace - -- False <=> value namespace - -> String -> TcM (Maybe TH.Name) -lookupName is_type_name s - = do { lcl_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv lcl_env rdr_name of - Just n -> return (Just (reifyName n)) - Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name - ; return (fmap reifyName mb_nm) } } - where - th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' - - occ_fs :: FastString - occ_fs = mkFastString (TH.nameBase th_name) - - occ :: OccName - occ | is_type_name - = if isLexVarSym occ_fs || isLexCon occ_fs - then mkTcOccFS occ_fs - else mkTyVarOccFS occ_fs - | otherwise - = if isLexCon occ_fs then mkDataOccFS occ_fs - else mkVarOccFS occ_fs - - rdr_name = case TH.nameModule th_name of - Nothing -> mkRdrUnqual occ - Just mod -> mkRdrQual (mkModuleName mod) occ - -getThing :: TH.Name -> TcM TcTyThing -getThing th_name - = do { name <- lookupThName th_name - ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) - ; tcLookupTh name } - -- ToDo: this tcLookup could fail, which would give a - -- rather unhelpful error message - where - ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" - ppr_ns _ = panic "reify/ppr_ns" - -reify :: TH.Name -> TcM TH.Info -reify th_name - = do { traceTc "reify 1" (text (TH.showName th_name)) - ; thing <- getThing th_name - ; traceTc "reify 2" (ppr thing) - ; reifyThing thing } - -lookupThName :: TH.Name -> TcM Name -lookupThName th_name = do - mb_name <- lookupThName_maybe th_name - case mb_name of - Nothing -> failWithTc (notInScope th_name) - Just name -> return name - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -lookupThName_maybe th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) - -- Pick the first that works - -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A - ; return (listToMaybe names) } - where - lookup rdr_name - = do { -- Repeat much of lookupOccRn, because we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return (Just name) - Nothing -> lookupGlobalOccRn_maybe rdr_name } - -tcLookupTh :: Name -> TcM TcTyThing --- This is a specialised version of TcEnv.tcLookup; specialised mainly in that --- it gives a reify-related error message on failure, whereas in the normal --- tcLookup, failure is a bug. -tcLookupTh name - = do { (gbl_env, lcl_env) <- getEnvs - ; case lookupNameEnv (tcl_env lcl_env) name of { - Just thing -> return thing; - Nothing -> - - case lookupNameEnv (tcg_type_env gbl_env) name of { - Just thing -> return (AGlobal thing); - Nothing -> - - -- EZY: I don't think this choice matters, no TH in signatures! - if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name - then -- It's defined in this module - failWithTc (notInEnv name) - - else - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc msg - }}}} - -notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" - -- Ugh! Rather an indirect way to display the name - -notInEnv :: Name -> SDoc -notInEnv name = quotes (ppr name) <+> - text "is not in the type environment at a reify" - ------------------------------- -reifyRoles :: TH.Name -> TcM [TH.Role] -reifyRoles th_name - = do { thing <- getThing th_name - ; case thing of - AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) - } - where - reify_role Nominal = TH.NominalR - reify_role Representational = TH.RepresentationalR - reify_role Phantom = TH.PhantomR - ------------------------------- -reifyThing :: TcTyThing -> TcM TH.Info --- The only reason this is monadic is for error reporting, --- which in turn is mainly for the case when TH can't express --- some random GHC extension - -reifyThing (AGlobal (AnId id)) - = do { ty <- reifyType (idType id) - ; let v = reifyName id - ; case idDetails id of - ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls)) - RecSelId{sel_tycon=RecSelData tc} - -> return (TH.VarI (reifySelector id tc) ty Nothing) - _ -> return (TH.VarI v ty Nothing) - } - -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AConLike (RealDataCon dc))) - = do { let name = dataConName dc - ; ty <- reifyType (idType (dataConWrapId dc)) - ; return (TH.DataConI (reifyName name) ty - (reifyName (dataConOrigTyCon dc))) - } - -reifyThing (AGlobal (AConLike (PatSynCon ps))) - = do { let name = reifyName ps - ; ty <- reifyPatSynType (patSynSig ps) - ; return (TH.PatSynI name ty) } - -reifyThing (ATcId {tct_id = id}) - = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even - -- though it may be incomplete - ; ty2 <- reifyType ty1 - ; return (TH.VarI (reifyName id) ty2 Nothing) } - -reifyThing (ATyVar tv tv1) - = do { ty1 <- zonkTcTyVar tv1 - ; ty2 <- reifyType ty1 - ; return (TH.TyVarI (reifyName tv) ty2) } - -reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) - -------------------------------------------- -reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn -reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs - , cab_lhs = lhs - , cab_rhs = rhs }) - -- remove kind patterns (#8884) - = do { tvs' <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; lhs' <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) - lhs_types_only lhs' - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs - ; rhs' <- reifyType rhs - ; return (TH.TySynEqn tvs' lhs_type rhs') } - -reifyTyCon :: TyCon -> TcM TH.Info -reifyTyCon tc - | Just cls <- tyConClass_maybe tc - = reifyClass cls - - | isFunTyCon tc - = return (TH.PrimTyConI (reifyName tc) 2 False) - - | isPrimTyCon tc - = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) - (isUnliftedTyCon tc)) - - | isTypeFamilyTyCon tc - = do { let tvs = tyConTyVars tc - res_kind = tyConResKind tc - resVar = famTcResVar tc - - ; kind' <- reifyKind res_kind - ; let (resultSig, injectivity) = - case resVar of - Nothing -> (TH.KindSig kind', Nothing) - Just name -> - let thName = reifyName name - injAnnot = tyConInjectivityInfo tc - sig = TH.TyVarSig (TH.KindedTV thName kind') - inj = case injAnnot of - NotInjective -> Nothing - Injective ms -> - Just (TH.InjectivityAnn thName injRHS) - where - injRHS = map (reifyName . tyVarName) - (filterByList ms tvs) - in (sig, inj) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; let tfHead = - TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity - ; if isOpenTypeFamilyTyCon tc - then do { fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc - (familyInstances fam_envs tc) - ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } - else do { eqns <- - case isClosedSynFamilyTyConWithAxiom_maybe tc of - Just ax -> mapM (reifyAxBranch tc) $ - fromBranches $ coAxiomBranches ax - Nothing -> return [] - ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) - []) } } - - | isDataFamilyTyCon tc - = do { let res_kind = tyConResKind tc - - ; kind' <- fmap Just (reifyKind res_kind) - - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) - ; return (TH.FamilyI - (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } - - | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym - = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; return (TH.TyConI - (TH.TySynD (reifyName tc) tvs' rhs')) - } - - | otherwise - = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; let tvs = tyConTyVars tc - dataCons = tyConDataCons tc - isGadt = isGadtSyntaxTyCon tc - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons - ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) - ; let name = reifyName tc - deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = - TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv - | otherwise = - TH.DataD cxt name r_tvs Nothing cons deriv - ; return (TH.TyConI decl) } - -reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con -reifyDataCon isGadtDataCon tys dc - = do { let -- used for H98 data constructors - (ex_tvs, theta, arg_tys) - = dataConInstSig dc tys - -- used for GADTs data constructors - g_user_tvs' = dataConUserTyVars dc - (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') - = dataConFullSig dc - (srcUnpks, srcStricts) - = mapAndUnzip reifySourceBang (dataConSrcBangs dc) - dcdBangs = zipWith TH.Bang srcUnpks srcStricts - fields = dataConFieldLabels dc - name = reifyName dc - -- Universal tvs present in eq_spec need to be filtered out, as - -- they will not appear anywhere in the type. - eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) - - ; (univ_subst, _) - -- See Note [Freshen reified GADT constructors' universal tyvars] - <- freshenTyVarBndrs $ - filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs - ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs' - g_theta = substTys tvb_subst g_theta' - g_arg_tys = substTys tvb_subst g_arg_tys' - g_res_ty = substTy tvb_subst g_res_ty' - - ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) - - ; main_con <- - if | not (null fields) && not isGadtDataCon -> - return $ TH.RecC name (zip3 (map reifyFieldLabel fields) - dcdBangs r_arg_tys) - | not (null fields) -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) - dcdBangs r_arg_tys) res_ty } - -- We need to check not isGadtDataCon here because GADT - -- constructors can be declared infix. - -- See Note [Infix GADT constructors] in TcTyClsDecls. - | dataConIsInfix dc && not isGadtDataCon -> - ASSERT( r_arg_tys `lengthIs` 2 ) do - { let [r_a1, r_a2] = r_arg_tys - [s1, s2] = dcdBangs - ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } - | isGadtDataCon -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty } - | otherwise -> - return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) - - ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) - | otherwise = ASSERT( all isTyVar ex_tvs ) - -- no covars for haskell syntax - (ex_tvs, theta) - ret_con | null ex_tvs' && null theta' = return main_con - | otherwise = do - { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' - ; return (TH.ForallC ex_tvs'' cxt main_con) } - ; ASSERT( r_arg_tys `equalLength` dcdBangs ) - ret_con } - -{- -Note [Freshen reified GADT constructors' universal tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose one were to reify this GADT: - - data a :~: b where - Refl :: forall a b. (a ~ b) => a :~: b - -We ought to be careful here about the uniques we give to the occurrences of `a` -and `b` in this definition. That is because in the original DataCon, all uses -of `a` and `b` have the same unique, since `a` and `b` are both universally -quantified type variables--that is, they are used in both the (:~:) tycon as -well as in the constructor type signature. But when we turn the DataCon -definition into the reified one, the `a` and `b` in the constructor type -signature becomes differently scoped than the `a` and `b` in `data a :~: b`. - -While it wouldn't technically be *wrong* per se to re-use the same uniques for -`a` and `b` across these two different scopes, it's somewhat annoying for end -users of Template Haskell, since they wouldn't be able to rely on the -assumption that all TH names have globally distinct uniques (#13885). For this -reason, we freshen the universally quantified tyvars that go into the reified -GADT constructor type signature to give them distinct uniques from their -counterparts in the tycon. --} - ------------------------------- -reifyClass :: Class -> TcM TH.Info -reifyClass cls - = do { cxt <- reifyCxt theta - ; inst_envs <- tcGetInstEnvs - ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) - ; assocTys <- concatMapM reifyAT ats - ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) - ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) - ; return (TH.ClassI dec insts) } - where - (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls - fds' = map reifyFunDep fds - reify_op (op, def_meth) - = do { let (_, _, ty) = tcSplitMethodTy (idType op) - -- Use tcSplitMethodTy to get rid of the extraneous class - -- variables and predicates at the beginning of op's type - -- (see #15551). - ; ty' <- reifyType ty - ; let nm' = reifyName op - ; case def_meth of - Just (_, GenericDM gdm_ty) -> - do { gdm_ty' <- reifyType gdm_ty - ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } - _ -> return [TH.SigD nm' ty'] } - - reifyAT :: ClassATItem -> TcM [TH.Dec] - reifyAT (ATI tycon def) = do - tycon' <- reifyTyCon tycon - case tycon' of - TH.FamilyI dec _ -> do - let (tyName, tyArgs) = tfNames dec - (dec :) <$> maybe (return []) - (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) - def - _ -> pprPanic "reifyAT" (text (show tycon')) - - reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec - reifyDefImpl n args ty = - TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) - <$> reifyType ty - - tfNames :: TH.Dec -> (TH.Name, [TH.Name]) - tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) - = (n, map bndrName args) - tfNames d = pprPanic "tfNames" (text (show d)) - - bndrName :: TH.TyVarBndr -> TH.Name - bndrName (TH.PlainTV n) = n - bndrName (TH.KindedTV n _) = n - ------------------------------- --- | Annotate (with TH.SigT) a type if the first parameter is True --- and if the type contains a free variable. --- This is used to annotate type patterns for poly-kinded tyvars in --- reifying class and type instances. --- See @Note [Reified instances and explicit kind signatures]@. -annotThType :: Bool -- True <=> annotate - -> TyCoRep.Type -> TH.Type -> TcM TH.Type - -- tiny optimization: if the type is annotated, don't annotate again. -annotThType _ _ th_ty@(TH.SigT {}) = return th_ty -annotThType True ty th_ty - | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty - = do { let ki = tcTypeKind ty - ; th_ki <- reifyKind ki - ; return (TH.SigT th_ty th_ki) } -annotThType _ _ th_ty = return th_ty - --- | For every argument type that a type constructor accepts, --- report whether or not the argument is poly-kinded. This is used to --- eventually feed into 'annotThType'. --- See @Note [Reified instances and explicit kind signatures]@. -tyConArgsPolyKinded :: TyCon -> [Bool] -tyConArgsPolyKinded tc = - map (is_poly_ty . tyVarKind) tc_vis_tvs - -- See "Wrinkle: Oversaturated data family instances" in - -- @Note [Reified instances and explicit kind signatures]@ - ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle - ++ repeat True -- (2) in Wrinkle - where - is_poly_ty :: Type -> Bool - is_poly_ty ty = not $ - isEmptyVarSet $ - filterVarSet isTyVar $ - tyCoVarsOfType ty - - tc_vis_tvs :: [TyVar] - tc_vis_tvs = tyConVisibleTyVars tc - - tc_res_kind_vis_bndrs :: [TyCoBinder] - tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc - -{- -Note [Reified instances and explicit kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Reified class instances and type family instances often include extra kind -information to disambiguate instances. Here is one such example that -illustrates this (#8953): - - type family Poly (a :: k) :: Type - type instance Poly (x :: Bool) = Int - type instance Poly (x :: Maybe k) = Double - -If you're not careful, reifying these instances might yield this: - - type instance Poly x = Int - type instance Poly x = Double - -To avoid this, we go through some care to annotate things with extra kind -information. Some functions which accomplish this feat include: - -* annotThType: This annotates a type with a kind signature if the type contains - a free variable. -* tyConArgsPolyKinded: This checks every argument that a type constructor can - accept and reports if the type of the argument is poly-kinded. This - information is ultimately fed into annotThType. - ------ --- Wrinkle: Oversaturated data family instances ------ - -What constitutes an argument to a type constructor in the definition of -tyConArgsPolyKinded? For most type constructors, it's simply the visible -type variable binders (i.e., tyConVisibleTyVars). There is one corner case -we must keep in mind, however: data family instances can appear oversaturated -(#17296). For instance: - - data family Foo :: Type -> Type - data instance Foo x - - data family Bar :: k - data family Bar x - -For these sorts of data family instances, tyConVisibleTyVars isn't enough, -as they won't give you the kinds of the oversaturated arguments. We must -also consult: - -1. The kinds of the arguments in the result kind (i.e., the tyConResKind). - This will tell us, e.g., the kind of `x` in `Foo x` above. -2. If we go beyond the number of arguments in the result kind (like the - `x` in `Bar x`), then we conservatively assume that the argument's - kind is poly-kinded. - ------ --- Wrinkle: data family instances with return kinds ------ - -Another squirrelly corner case is this: - - data family Foo (a :: k) - data instance Foo :: Bool -> Type - data instance Foo :: Char -> Type - -If you're not careful, reifying these instances might yield this: - - data instance Foo - data instance Foo - -We can fix this ambiguity by reifying the instances' explicit return kinds. We -should only do this if necessary (see -Note [When does a tycon application need an explicit kind signature?] in Type), -but more importantly, we *only* do this if either of the following are true: - -1. The data family instance has no constructors. -2. The data family instance is declared with GADT syntax. - -If neither of these are true, then reifying the return kind would yield -something like this: - - data instance (Bar a :: Type) = MkBar a - -Which is not valid syntax. --} - ------------------------------- -reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] -reifyClassInstances cls insts - = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts - -reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> ClsInst -> TcM TH.Dec -reifyClassInstance is_poly_tvs i - = do { cxt <- reifyCxt theta - ; let vis_types = filterOutInvisibleTypes cls_tc types - ; thtypes <- reifyTypes vis_types - ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes - ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes - ; return $ (TH.InstanceD over cxt head_ty []) } - where - (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) - cls_tc = classTyCon cls - dfun = instanceDFunId i - over = case overlapMode (is_flag i) of - NoOverlap _ -> Nothing - Overlappable _ -> Just TH.Overlappable - Overlapping _ -> Just TH.Overlapping - Overlaps _ -> Just TH.Overlaps - Incoherent _ -> Just TH.Incoherent - ------------------------------- -reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] -reifyFamilyInstances fam_tc fam_insts - = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts - -reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> FamInst -> TcM TH.Dec -reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor - , fi_axiom = ax - , fi_fam = fam }) - | let fam_tc = coAxiomTyCon ax - branch = coAxiomSingleBranch ax - , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch - = case flavor of - SynFamilyInst -> - -- remove kind patterns (#8884) - do { th_tvs <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; th_lhs <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only - th_lhs - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs - ; th_rhs <- reifyType rhs - ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } - - DataFamilyInst rep_tc -> - do { let -- eta-expand lhs types, because sometimes data/newtype - -- instances are eta-reduced; See #9692 - -- See Note [Eta reduction for data families] in FamInstEnv - (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch - fam' = reifyName fam - dataCons = tyConDataCons rep_tc - isGadt = isGadtSyntaxTyCon rep_tc - ; th_tvs <- reifyTyVarsToMaybe ee_tvs - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons - ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs - ; th_tys <- reifyTypes types_only - ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys - ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys - ; mb_sig <- - -- See "Wrinkle: data family instances with return kinds" in - -- Note [Reified instances and explicit kind signatures] - if (null cons || isGadtSyntaxTyCon rep_tc) - && tyConAppNeedsKindSig False fam_tc (length ee_lhs) - then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs) - ; th_full_kind <- reifyKind full_kind - ; pure $ Just th_full_kind } - else pure Nothing - ; return $ - if isNewTyCon rep_tc - then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] - else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] - } - ------------------------------- -reifyType :: TyCoRep.Type -> TcM TH.Type --- Monadic only because of failure -reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT - -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it - -- with Constraint (#14869). -reifyType ty@(ForAllTy (Bndr _ argf) _) - = reify_for_all argf ty -reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } -reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) -reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here -reifyType ty@(AppTy {}) = do - let (ty_head, ty_args) = splitAppTys ty - ty_head' <- reifyType ty_head - ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) - pure $ mkThAppTs ty_head' ty_args' - where - -- Make sure to filter out any invisible arguments. For instance, if you - -- reify the following: - -- - -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) - -- - -- Then you should receive back `f Bool`, not `f Type Bool`, since the - -- `Type` argument is invisible (#15792). - filter_out_invisible_args :: Type -> [Type] -> [Type] - filter_out_invisible_args ty_head ty_args = - filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) - ty_args -reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) - | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } -reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH -reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) - -reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type --- Arg of reify_for_all is always ForAllTy or a predicate FunTy -reify_for_all argf ty = do - tvs' <- reifyTyVars tvs - case argToForallVisFlag argf of - ForallVis -> do phi' <- reifyType phi - pure $ TH.ForallVisT tvs' phi' - ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi - cxt' <- reifyCxt cxt - tau' <- reifyType tau - pure $ TH.ForallT tvs' cxt' tau' - where - (tvs, phi) = tcSplitForAllTysSameVis argf ty - -reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit -reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) -reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) - -reifyTypes :: [Type] -> TcM [TH.Type] -reifyTypes = mapM reifyType - -reifyPatSynType - :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type --- reifies a pattern synonym's type and returns its *complete* type --- signature; see NOTE [Pattern synonym signatures and Template --- Haskell] -reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) - = do { univTyVars' <- reifyTyVars univTyVars - ; req' <- reifyCxt req - ; exTyVars' <- reifyTyVars exTyVars - ; prov' <- reifyCxt prov - ; tau' <- reifyType (mkVisFunTys argTys resTy) - ; return $ TH.ForallT univTyVars' req' - $ TH.ForallT exTyVars' prov' tau' } - -reifyKind :: Kind -> TcM TH.Kind -reifyKind = reifyType - -reifyCxt :: [PredType] -> TcM [TH.Pred] -reifyCxt = mapM reifyType - -reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep -reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) - -reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] -reifyTyVars tvs = mapM reify_tv tvs - where - -- even if the kind is *, we need to include a kind annotation, - -- in case a poly-kind would be inferred without the annotation. - -- See #8953 or test th/T8953 - reify_tv tv = TH.KindedTV name <$> reifyKind kind - where - kind = tyVarKind tv - name = reifyName tv - -reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr]) -reifyTyVarsToMaybe [] = pure Nothing -reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys - -reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type -reify_tc_app tc tys - = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) - ; maybe_sig_t (mkThAppTs r_tc tys') } - where - arity = tyConArity tc - - r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) - | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) - | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - | isTupleTyCon tc = if isPromotedDataCon tc - then TH.PromotedTupleT arity - else TH.TupleT arity - | tc `hasKey` constraintKindTyConKey - = TH.ConstraintT - | tc `hasKey` funTyConKey = TH.ArrowT - | tc `hasKey` listTyConKey = TH.ListT - | tc `hasKey` nilDataConKey = TH.PromotedNilT - | tc `hasKey` consDataConKey = TH.PromotedConsT - | tc `hasKey` heqTyConKey = TH.EqualityT - | tc `hasKey` eqPrimTyConKey = TH.EqualityT - | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) - | isPromotedDataCon tc = TH.PromotedT (reifyName tc) - | otherwise = TH.ConT (reifyName tc) - - -- See Note [When does a tycon application need an explicit kind - -- signature?] in TyCoRep - maybe_sig_t th_type - | tyConAppNeedsKindSig - False -- We don't reify types using visible kind applications, so - -- don't count specified binders as contributing towards - -- injective positions in the kind of the tycon. - tc (length tys) - = do { let full_kind = tcTypeKind (mkTyConApp tc tys) - ; th_full_kind <- reifyKind full_kind - ; return (TH.SigT th_type th_full_kind) } - | otherwise - = return th_type - ------------------------------- -reifyName :: NamedThing n => n -> TH.Name -reifyName thing - | isExternalName name - = mk_varg pkg_str mod_str occ_str - | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) - -- Many of the things we reify have local bindings, and - -- NameL's aren't supposed to appear in binding positions, so - -- we use NameU. When/if we start to reify nested things, that - -- have free variables, we may need to generate NameL's for them. - where - name = getName thing - mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = occNameString occ - occ = nameOccName name - mk_varg | OccName.isDataOcc occ = TH.mkNameG_d - | OccName.isVarOcc occ = TH.mkNameG_v - | OccName.isTcOcc occ = TH.mkNameG_tc - | otherwise = pprPanic "reifyName" (ppr name) - --- See Note [Reifying field labels] -reifyFieldLabel :: FieldLabel -> TH.Name -reifyFieldLabel fl - | flIsOverloaded fl - = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str)) - | otherwise = TH.mkNameG_v pkg_str mod_str occ_str - where - name = flSelector fl - mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = unpackFS (flLabel fl) - -reifySelector :: Id -> TyCon -> TH.Name -reifySelector id tc - = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of - Just fl -> reifyFieldLabel fl - Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc) - ------------------------------- -reifyFixity :: Name -> TcM (Maybe TH.Fixity) -reifyFixity name - = do { (found, fix) <- lookupFixityRn_help name - ; return (if found then Just (conv_fix fix) else Nothing) } - where - conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) - conv_dir BasicTypes.InfixR = TH.InfixR - conv_dir BasicTypes.InfixL = TH.InfixL - conv_dir BasicTypes.InfixN = TH.InfixN - -reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness -reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness -reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack -reifyUnpackedness SrcUnpack = TH.SourceUnpack - -reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness -reifyStrictness NoSrcStrict = TH.NoSourceStrictness -reifyStrictness SrcStrict = TH.SourceStrict -reifyStrictness SrcLazy = TH.SourceLazy - -reifySourceBang :: DataCon.HsSrcBang - -> (TH.SourceUnpackedness, TH.SourceStrictness) -reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) - -reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness -reifyDecidedStrictness HsLazy = TH.DecidedLazy -reifyDecidedStrictness HsStrict = TH.DecidedStrict -reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack - -reifyTypeOfThing :: TH.Name -> TcM TH.Type -reifyTypeOfThing th_name = do - thing <- getThing th_name - case thing of - AGlobal (AnId id) -> reifyType (idType id) - AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) - AGlobal (AConLike (RealDataCon dc)) -> - reifyType (idType (dataConWrapId dc)) - AGlobal (AConLike (PatSynCon ps)) -> - reifyPatSynType (patSynSig ps) - ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType - ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType - -- Impossible cases, supposedly: - AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" - ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" - APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" - ------------------------------- -lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget -lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) -lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) - = return $ ModuleTarget $ - mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn) - -reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] -reifyAnnotations th_name - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name - ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - ------------------------------- -modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m) - (TH.ModName $ moduleNameString $ moduleName m) - -reifyModule :: TH.Module -> TcM TH.ModuleInfo -reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do - this_mod <- getModule - let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString) - if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod - where - reifyThisModule = do - usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports - return $ TH.ModuleInfo usages - - reifyFromIface reifMod = do - iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod - let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (moduleUnitId reifMod) usage] ] - return $ TH.ModuleInfo usages - - usageToModule :: UnitId -> Usage -> Maybe Module - usageToModule _ (UsageFile {}) = Nothing - usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn - usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m - usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m - ------------------------------- -mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type -mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys - -noTH :: PtrString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> - text "in Template Haskell:", - nest 2 d]) - -ppr_th :: TH.Ppr a => a -> SDoc -ppr_th x = text (TH.pprint x) - -{- -Note [Reifying field labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reifying a datatype declared with DuplicateRecordFields enabled, we want -the reified names of the fields to be labels rather than selector functions. -That is, we want (reify ''T) and (reify 'foo) to produce - - data T = MkT { foo :: Int } - foo :: T -> Int - -rather than - - data T = MkT { $sel:foo:MkT :: Int } - $sel:foo:MkT :: T -> Int - -because otherwise TH code that uses the field names as strings will silently do -the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather -than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the -environment, NameG can't be used to represent such fields. Instead, -reifyFieldLabel uses NameQ. - -However, this means that extracting the field name from the output of reify, and -trying to reify it again, may fail with an ambiguity error if there are multiple -such fields defined in the module (see the test case -overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to -the TH AST to make it able to represent duplicate record fields. --} diff --git a/typecheck/TcSplice.hs-boot b/typecheck/TcSplice.hs-boot deleted file mode 100644 --- a/typecheck/TcSplice.hs-boot +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcSplice where - -import GhcPrelude -import Name -import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) -import TcRnTypes( TcM , SpliceType ) -import TcType ( ExpRhoType ) -import Annotations ( Annotation, CoreAnnTarget ) -import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) - -import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, - LHsDecl, ThModFinalizers ) -import qualified Language.Haskell.TH as TH - -tcSpliceExpr :: HsSplice GhcRn - -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -tcUntypedBracket :: HsExpr GhcRn - -> HsBracket GhcRn - -> [PendingRnSplice] - -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcTypedBracket :: HsExpr GhcRn - -> HsBracket GhcRn - -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) - -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation - -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId) - -runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs) -runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs) -runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs) -runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs] - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasi :: TH.Q a -> TcM a -runRemoteModFinalizers :: ThModFinalizers -> TcM () -finishTH :: TcM () diff --git a/typecheck/TcTyClsDecls.hs b/typecheck/TcTyClsDecls.hs deleted file mode 100644 --- a/typecheck/TcTyClsDecls.hs +++ /dev/null @@ -1,4718 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcTyClsDecls: Typecheck type and class declarations --} - -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcTyClsDecls ( - tcTyAndClassDecls, - - -- Functions used by TcInstDcls to check - -- data/type family instance declarations - kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon, - tcFamTyPats, tcTyFamInstEqn, - tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - unravelFamInstPats, addConsistencyConstraints, - wrongKindOfFamily - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import HscTypes -import BuildTyCl -import TcRnMonad -import TcEnv -import TcValidity -import TcHsSyn -import TcTyDecls -import TcClassDcl -import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) -import TcDeriv (DerivInfo(..)) -import TcUnify ( unifyKind, checkTvConstraints ) -import TcHsType -import ClsInst( AssocInstInfo(..) ) -import TcMType -import TysWiredIn ( unitTy, makeRecoveryTyCon ) -import TcType -import RnEnv( lookupConstructorFields ) -import FamInst -import FamInstEnv -import Coercion -import TcOrigin -import Type -import TyCoRep -- for checkValidRoles -import TyCoPpr( pprTyVars, pprWithExplicitKindsWhen ) -import Class -import CoAxiom -import TyCon -import DataCon -import Id -import Var -import VarEnv -import VarSet -import Module -import Name -import NameSet -import NameEnv -import Outputable -import Maybes -import Unify -import Util -import SrcLoc -import ListSetOps -import DynFlags -import Unique -import ConLike( ConLike(..) ) -import BasicTypes -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable -import Data.Function ( on ) -import Data.Functor.Identity -import Data.List -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.Set as Set -import Data.Tuple( swap ) - -{- -************************************************************************ -* * -\subsection{Type checking for type and class declarations} -* * -************************************************************************ - -Note [Grouping of type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly -connected component of mutually dependent types and classes. We kind check and -type check each group separately to enhance kind polymorphism. Take the -following example: - - type Id a = a - data X = X (Id Int) - -If we were to kind check the two declarations together, we would give Id the -kind * -> *, since we apply it to an Int in the definition of X. But we can do -better than that, since Id really is kind polymorphic, and should get kind -forall (k::*). k -> k. Since it does not depend on anything else, it can be -kind-checked by itself, hence getting the most general kind. We then kind check -X, which works fine because we then know the polymorphic kind of Id, and simply -instantiate k to *. - -Note [Check role annotations in a second pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Role inference potentially depends on the types of all of the datacons declared -in a mutually recursive group. The validity of a role annotation, in turn, -depends on the result of role inference. Because the types of datacons might -be ill-formed (see #7175 and Note [Checking GADT return types]) we must check -*all* the tycons in a group for validity before checking *any* of the roles. -Thus, we take two passes over the resulting tycons, first checking for general -validity and then checking for valid role annotations. --} - -tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in - -- dependency order - -> TcM ( TcGblEnv -- Input env extended by types and - -- classes - -- and their implicit Ids,DataCons - , [InstInfo GhcRn] -- Source-code instance decls info - , [DerivInfo] -- Deriving info - ) --- Fails if there are any errors -tcTyAndClassDecls tyclds_s - -- The code recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - -- Type check each group in dependency order folding the global env - = checkNoErrs $ fold_env [] [] tyclds_s - where - fold_env :: [InstInfo GhcRn] - -> [DerivInfo] - -> [TyClGroup GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) - fold_env inst_info deriv_info [] - = do { gbl_env <- getGblEnv - ; return (gbl_env, inst_info, deriv_info) } - fold_env inst_info deriv_info (tyclds:tyclds_s) - = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds - ; setGblEnv tcg_env $ - -- remaining groups are typechecked in the extended global env. - fold_env (inst_info' ++ inst_info) - (deriv_info' ++ deriv_info) - tyclds_s } - -tcTyClGroup :: TyClGroup GhcRn - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) --- Typecheck one strongly-connected component of type, class, and instance decls --- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls -tcTyClGroup (TyClGroup { group_tyclds = tyclds - , group_roles = roles - , group_kisigs = kisigs - , group_instds = instds }) - = do { let role_annots = mkRoleAnnotEnv roles - - -- Step 1: Typecheck the standalone kind signatures and type/class declarations - ; traceTc "---- tcTyClGroup ---- {" empty - ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) - ; (tyclss, data_deriv_info) <- - tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] - do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs - ; tcTyClDecls tyclds kisig_env role_annots } - - -- Step 1.5: Make sure we don't have any type synonym cycles - ; traceTc "Starting synonym cycle check" (ppr tyclss) - ; this_uid <- fmap thisPackage getDynFlags - ; checkSynCycles this_uid tyclss tyclds - ; traceTc "Done synonym cycle check" (ppr tyclss) - - -- Step 2: Perform the validity check on those types/classes - -- We can do this now because we are done with the recursive knot - -- Do it before Step 3 (adding implicit things) because the latter - -- expects well-formed TyCons - ; traceTc "Starting validity check" (ppr tyclss) - ; tyclss <- concatMapM checkValidTyCl tyclss - ; traceTc "Done validity check" (ppr tyclss) - ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss - -- See Note [Check role annotations in a second pass] - - ; traceTc "---- end tcTyClGroup ---- }" empty - - -- Step 3: Add the implicit things; - -- we want them in the environment because - -- they may be mentioned in interface files - ; gbl_env <- addTyConsToGblEnv tyclss - - -- Step 4: check instance declarations - ; (gbl_env', inst_info, datafam_deriv_info) <- - setGblEnv gbl_env $ - tcInstDecls1 instds - - ; let deriv_info = datafam_deriv_info ++ data_deriv_info - ; return (gbl_env', inst_info, deriv_info) } - - -tcTyClGroup (XTyClGroup nec) = noExtCon nec - --- Gives the kind for every TyCon that has a standalone kind signature -type KindSigEnv = NameEnv Kind - -tcTyClDecls - :: [LTyClDecl GhcRn] - -> KindSigEnv - -> RoleAnnotEnv - -> TcM ([TyCon], [DerivInfo]) -tcTyClDecls tyclds kisig_env role_annots - = do { -- Step 1: kind-check this group and returns the final - -- (possibly-polymorphic) kind of each TyCon and Class - -- See Note [Kind checking for type and class decls] - tc_tycons <- kcTyClGroup kisig_env tyclds - ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) - - -- Step 2: type-check all groups together, returning - -- the final TyCons and Classes - -- - -- NB: We have to be careful here to NOT eagerly unfold - -- type synonyms, as we have not tested for type synonym - -- loops yet and could fall into a black hole. - ; fixM $ \ ~(rec_tyclss, _) -> do - { tcg_env <- getGblEnv - ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss - - -- Populate environment with knot-tied ATyCon for TyCons - -- NB: if the decls mention any ill-staged data cons - -- (see Note [Recursion and promoting data constructors]) - -- we will have failed already in kcTyClGroup, so no worries here - ; (tycons, data_deriv_infos) <- - tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ - - -- Also extend the local type envt with bindings giving - -- a TcTyCon for each each knot-tied TyCon or Class - -- See Note [Type checking recursive type and class declarations] - -- and Note [Type environment evolution] - tcExtendKindEnvWithTyCons tc_tycons $ - - -- Kind and type check declarations for this group - mapAndUnzipM (tcTyClDecl roles) tyclds - ; return (tycons, concat data_deriv_infos) - } } - where - ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma - , ppr (tyConBinders tc) <> comma - , ppr (tyConResKind tc) - , ppr (isTcTyCon tc) ]) - -zipRecTyClss :: [TcTyCon] - -> [TyCon] -- Knot-tied - -> [(Name,TyThing)] --- Build a name-TyThing mapping for the TyCons bound by decls --- being careful not to look at the knot-tied [TyThing] --- The TyThings in the result list must have a visible ATyCon, --- because typechecking types (in, say, tcTyClDecl) looks at --- this outer constructor -zipRecTyClss tc_tycons rec_tycons - = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] - where - rec_tc_env :: NameEnv TyCon - rec_tc_env = foldr add_tc emptyNameEnv rec_tycons - - add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) - - add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_one_tc tc env = extendNameEnv env (tyConName tc) tc - - get name = case lookupNameEnv rec_tc_env name of - Just tc -> tc - other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) - -{- -************************************************************************ -* * - Kind checking -* * -************************************************************************ - -Note [Kind checking for type and class decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Kind checking is done thus: - - 1. Make up a kind variable for each parameter of the declarations, - and extend the kind environment (which is in the TcLclEnv) - - 2. Kind check the declarations - -We need to kind check all types in the mutually recursive group -before we know the kind of the type variables. For example: - - class C a where - op :: D b => a -> b -> b - - class D c where - bop :: (Monad c) => ... - -Here, the kind of the locally-polymorphic type variable "b" -depends on *all the uses of class D*. For example, the use of -Monad c in bop's type signature means that D must have kind Type->Type. - -Note: we don't treat type synonyms specially (we used to, in the past); -in particular, even if we have a type synonym cycle, we still kind check -it normally, and test for cycles later (checkSynCycles). The reason -we can get away with this is because we have more systematic TYPE r -inference, which means that we can do unification between kinds that -aren't lifted (this historically was not true.) - -The downside of not directly reading off the kinds of the RHS of -type synonyms in topological order is that we don't transparently -support making synonyms of types with higher-rank kinds. But -you can always specify a CUSK directly to make this work out. -See tc269 for an example. - -Note [CUSKs and PolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T (a :: *) = MkT (S a) -- Has CUSK - data S a = MkS (T Int) (S a) -- No CUSK - -Via inferInitialKinds we get - T :: * -> * - S :: kappa -> * - -Then we call kcTyClDecl on each decl in the group, to constrain the -kind unification variables. BUT we /skip/ the RHS of any decl with -a CUSK. Here we skip the RHS of T, so we eventually get - S :: forall k. k -> * - -This gets us more polymorphism than we would otherwise get, similar -(but implemented strangely differently from) the treatment of type -signatures in value declarations. - -However, we only want to do so when we have PolyKinds. -When we have NoPolyKinds, we don't skip those decls, because we have defaulting -(#16609). Skipping won't bring us more polymorphism when we have defaulting. -Consider - - data T1 a = MkT1 T2 -- No CUSK - data T2 = MkT2 (T1 Maybe) -- Has CUSK - -If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. -With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the -program type-checks. -But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens -in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking -(T1 Maybe) will throw a type error. - -Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. - -Open type families -~~~~~~~~~~~~~~~~~~ -This treatment of type synonyms only applies to Haskell 98-style synonyms. -General type functions can be recursive, and hence, appear in `alg_decls'. - -The kind of an open type family is solely determinded by its kind signature; -hence, only kind signatures participate in the construction of the initial -kind environment (as constructed by `inferInitialKind'). In fact, we ignore -instances of families altogether in the following. However, we need to include -the kinds of *associated* families into the construction of the initial kind -environment. (This is handled by `allDecls'). - -See also Note [Kind checking recursive type and class declarations] - -Note [How TcTyCons work] -~~~~~~~~~~~~~~~~~~~~~~~~ -TcTyCons are used for two distinct purposes - -1. When recovering from a type error in a type declaration, - we want to put the erroneous TyCon in the environment in a - way that won't lead to more errors. We use a TcTyCon for this; - see makeRecoveryTyCon. - -2. When checking a type/class declaration (in module TcTyClsDecls), we come - upon knowledge of the eventual tycon in bits and pieces. - - S1) First, we use inferInitialKinds to look over the user-provided - kind signature of a tycon (including, for example, the number - of parameters written to the tycon) to get an initial shape of - the tycon's kind. We record that shape in a TcTyCon. - - For CUSK tycons, the TcTyCon has the final, generalised kind. - For non-CUSK tycons, the TcTyCon has as its tyConBinders only - the explicit arguments given -- no kind variables, etc. - - S2) Then, using these initial kinds, we kind-check the body of the - tycon (class methods, data constructors, etc.), filling in the - metavariables in the tycon's initial kind. - - S3) We then generalize to get the (non-CUSK) tycon's final, fixed - kind. Finally, once this has happened for all tycons in a - mutually recursive group, we can desugar the lot. - - For convenience, we store partially-known tycons in TcTyCons, which - might store meta-variables. These TcTyCons are stored in the local - environment in TcTyClsDecls, until the real full TyCons can be created - during desugaring. A desugared program should never have a TcTyCon. - -3. In a TcTyCon, everything is zonked after the kind-checking pass (S2). - -4. tyConScopedTyVars. A challenging piece in all of this is that we - end up taking three separate passes over every declaration: - - one in inferInitialKind (this pass look only at the head, not the body) - - one in kcTyClDecls (to kind-check the body) - - a final one in tcTyClDecls (to desugar) - - In the latter two passes, we need to connect the user-written type - variables in an LHsQTyVars with the variables in the tycon's - inferred kind. Because the tycon might not have a CUSK, this - matching up is, in general, quite hard to do. (Look through the - git history between Dec 2015 and Apr 2016 for - TcHsType.splitTelescopeTvs!) - - Instead of trying, we just store the list of type variables to - bring into scope, in the tyConScopedTyVars field of the TcTyCon. - These tyvars are brought into scope in TcHsType.bindTyClTyVars. - - In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather - than just [TcTyVar]? Consider these mutually-recursive decls - data T (a :: k1) b = MkT (S a b) - data S (c :: k2) d = MkS (T c d) - We start with k1 bound to kappa1, and k2 to kappa2; so initially - in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But - then kappa1 and kappa2 get unified; so after the zonking in - 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. - -See also Note [Type checking recursive type and class declarations]. - -Note [Swizzling the tyvars before generaliseTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note only applies when /inferring/ the kind of a TyCon. -If there is a separate kind signature, or a CUSK, we take an entirely -different code path. - -For inference, consider - class C (f :: k) x where - type T f - op :: D f => blah - class D (g :: j) y where - op :: C g => y -> blah - -Here C and D are considered mutually recursive. Neither has a CUSK. -Just before generalisation we have the (un-quantified) kinds - C :: k1 -> k2 -> Constraint - T :: k1 -> Type - D :: k1 -> Type -> Constraint -Notice that f's kind and g's kind have been unified to 'k1'. We say -that k1 is the "representative" of k in C's decl, and of j in D's decl. - -Now when quantifying, we'd like to end up with - C :: forall {k2}. forall k. k -> k2 -> Constraint - T :: forall k. k -> Type - D :: forall j. j -> Type -> Constraint - -That is, we want to swizzle the representative to have the Name given -by the user. Partly this is to improve error messages and the output of -:info in GHCi. But it is /also/ important because the code for a -default method may mention the class variable(s), but at that point -(tcClassDecl2), we only have the final class tyvars available. -(Alternatively, we could record the scoped type variables in the -TyCon, but it's a nuisance to do so.) - -Notes: - -* On the input to generaliseTyClDecl, the mapping between the - user-specified Name and the representative TyVar is recorded in the - tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see - this representative TyVar. - -* The swizzling is actually performed by swizzleTcTyConBndrs - -* We must do the swizzling across the whole class decl. Consider - class C f where - type S (f :: k) - type T f - Here f's kind k is a parameter of C, and its identity is shared - with S and T. So if we swizzle the representative k at all, we - must do so consistently for the entire declaration. - - Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, - rather than in generaliseTcTyCon. - -There are errors to catch here. Suppose we had - class E (f :: j) (g :: k) where - op :: SameKind f g -> blah - -Then, just before generalisation we will have the (unquantified) - E :: k1 -> k1 -> Constraint - -That's bad! Two distinctly-named tyvars (j and k) have ended up with -the same representative k1. So when swizzling, we check (in -check_duplicate_tc_binders) that two distinct source names map -to the same representative. - -Here's an interesting case: - class C1 f where - type S (f :: k1) - type T (f :: k2) -Here k1 and k2 are different Names, but they end up mapped to the -same representative TyVar. To make the swizzling consistent (remember -we must have a single k across C1, S and T) we reject the program. - -Another interesting case - class C2 f where - type S (f :: k) (p::Type) - type T (f :: k) (p::Type->Type) - -Here the two k's (and the two p's) get distinct Uniques, because they -are seen by the renamer as locally bound in S and T resp. But again -the two (distinct) k's end up bound to the same representative TyVar. -You might argue that this should be accepted, but it's definitely -rejected (via an entirely different code path) if you add a kind sig: - type C2' :: j -> Constraint - class C2' f where - type S (f :: k) (p::Type) -We get - • Expected kind ‘j’, but ‘f’ has kind ‘k’ - • In the associated type family declaration for ‘S’ - -So we reject C2 too, even without the kind signature. We have -to do a bit of work to get a good error message, since both k's -look the same to the user. - -Another case - class C3 (f :: k1) where - type S (f :: k2) - -This will be rejected too. - - -Note [Type environment evolution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As we typecheck a group of declarations the type environment evolves. -Consider for example: - data B (a :: Type) = MkB (Proxy 'MkB) - -We do the following steps: - - 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the - type env with promotion errors - B :-> TyConPE - MkB :-> DataConPE - - 2. kcTyCLGroup - - Do inferInitialKinds, which will signal a promotion - error if B is used in any of the kinds needed to initialise - B's kind (e.g. (a :: Type)) here - - - Extend the type env with these initial kinds (monomorphic for - decls that lack a CUSK) - B :-> TcTyCon - (thereby overriding the B :-> TyConPE binding) - and do kcLTyClDecl on each decl to get equality constraints on - all those initial kinds - - - Generalise the initial kind, making a poly-kinded TcTyCon - - 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded - TcTyCons, again overriding the promotion-error bindings. - - But note that the data constructor promotion errors are still in place - so that (in our example) a use of MkB will still be signalled as - an error. - - 4. Typecheck the decls. - - 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons - - -Note [Missed opportunity to retain higher-rank kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In 'kcTyClGroup', there is a missed opportunity to make kind -inference work in a few more cases. The idea is analogous -to Note [Single function non-recursive binding special-case]: - - * If we have an SCC with a single decl, which is non-recursive, - instead of creating a unification variable representing the - kind of the decl and unifying it with the rhs, we can just - read the type directly of the rhs. - - * Furthermore, we can update our SCC analysis to ignore - dependencies on declarations which have CUSKs: we don't - have to kind-check these all at once, since we can use - the CUSK to initialize the kind environment. - -Unfortunately this requires reworking a bit of the code in -'kcLTyClDecl' so I've decided to punt unless someone shouts about it. - -Note [Don't process associated types in getInitialKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, we processed associated types in the thing_inside in getInitialKind, -but this was wrong -- we want to do ATs sepearately. -The consequence for not doing it this way is #15142: - - class ListTuple (tuple :: Type) (as :: [(k, Type)]) where - type ListToTuple as :: Type - -We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify -kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring -`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't -unified with Type. And then, when we generalize the kind of ListToTuple (which -indeed has a CUSK, according to the rules), we skolemize the free metavariable -kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, -because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] -will unify with Type. - -Bottom line: as associated types should have no effect on a CUSK enclosing class, -we move processing them to a separate action, run after the outer kind has -been generalized. - --} - -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon] - --- Kind check this group, kind generalize, and return the resulting local env --- This binds the TyCons and Classes of the group, but not the DataCons --- See Note [Kind checking for type and class decls] --- and Note [Inferring kinds for type declarations] -kcTyClGroup kisig_env decls - = do { mod <- getModule - ; traceTc "---- kcTyClGroup ---- {" - (text "module" <+> ppr mod $$ vcat (map ppr decls)) - - -- Kind checking; - -- 1. Bind kind variables for decls - -- 2. Kind-check decls - -- 3. Generalise the inferred kinds - -- See Note [Kind checking for type and class decls] - - ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds - -- See Note [CUSKs and PolyKinds] - ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls - - get_kind d - | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d)) - = Right (d, SAKS ki) - - | cusks_enabled && hsDeclHasCusk (unLoc d) - = Right (d, CUSK) - - | otherwise = Left d - - ; checked_tcs <- checkInitialKinds kinded_decls - ; inferred_tcs - <- tcExtendKindEnvWithTyCons checked_tcs $ - pushTcLevelM_ $ -- We are going to kind-generalise, so - -- unification variables in here must - -- be one level in - solveEqualities $ - do { -- Step 1: Bind kind variables for all decls - mono_tcs <- inferInitialKinds kindless_decls - - ; traceTc "kcTyClGroup: initial kinds" $ - ppr_tc_kinds mono_tcs - - -- Step 2: Set extended envt, kind-check the decls - -- NB: the environment extension overrides the tycon - -- promotion-errors bindings - -- See Note [Type environment evolution] - ; tcExtendKindEnvWithTyCons mono_tcs $ - mapM_ kcLTyClDecl kindless_decls - - ; return mono_tcs } - - -- Step 3: generalisation - -- Finally, go through each tycon and give it its final kind, - -- with all the required, specified, and inferred variables - -- in order. - ; let inferred_tc_env = mkNameEnv $ - map (\tc -> (tyConName tc, tc)) inferred_tcs - ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) - kindless_decls - - ; let poly_tcs = checked_tcs ++ generalized_tcs - ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) - ; return poly_tcs } - where - ppr_tc_kinds tcs = vcat (map pp_tc tcs) - pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) - -type ScopedPairs = [(Name, TcTyVar)] - -- The ScopedPairs for a TcTyCon are precisely - -- specified-tvs ++ required-tvs - -- You can distinguish them because there are tyConArity required-tvs - -generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon] --- See Note [Swizzling the tyvars before generaliseTcTyCon] -generaliseTyClDecl inferred_tc_env (L _ decl) - = do { let names_in_this_decl :: [Name] - names_in_this_decl = tycld_names decl - - -- Extract the specified/required binders and skolemise them - ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl - - -- Zonk, to manifest the side-effects of skolemisation to the swizzler - -- NB: it's important to skolemise them all before this step. E.g. - -- class C f where { type T (f :: k) } - -- We only skolemise k when looking at T's binders, - -- but k appears in f's kind in C's binders. - ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs - - -- Swizzle - ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) - - -- And finally generalise - ; mapAndReportM generaliseTcTyCon swizzled_infos } - where - tycld_names :: TyClDecl GhcRn -> [Name] - tycld_names decl = tcdName decl : at_names decl - - at_names :: TyClDecl GhcRn -> [Name] - at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats - at_names _ = [] -- Only class decls have associated types - - skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs) - -- Zonk and skolemise the Specified and Required binders - skolemise_tc_tycon tc_name - = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name - -- This lookup should not fail - ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc) - ; return (tc, scoped_prs) } - - zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind) - zonk_tc_tycon (tc, scoped_prs) - = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs - -- We really have to do this again, even though - -- we have just done zonkAndSkolemise - ; res_kind <- zonkTcType (tyConResKind tc) - ; return (tc, scoped_prs, res_kind) } - -swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)] - -> TcM [(TcTyCon, ScopedPairs, TcKind)] -swizzleTcTyConBndrs tc_infos - | all no_swizzle swizzle_prs - -- This fast path happens almost all the time - -- See Note [Non-cloning for tyvar binders] in TcHsType - = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos)) - ; return tc_infos } - - | otherwise - = do { check_duplicate_tc_binders - - ; traceTc "swizzleTcTyConBndrs" $ - vcat [ text "before" <+> ppr_infos tc_infos - , text "swizzle_prs" <+> ppr swizzle_prs - , text "after" <+> ppr_infos swizzled_infos ] - - ; return swizzled_infos } - - where - swizzled_infos = [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind) - | (tc, scoped_prs, kind) <- tc_infos ] - - swizzle_prs :: [(Name,TyVar)] - -- Pairs the user-specifed Name with its representative TyVar - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] - - no_swizzle :: (Name,TyVar) -> Bool - no_swizzle (nm, tv) = nm == tyVarName tv - - ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) - | (tc, prs, _) <- infos ] - - -- Check for duplicates - -- E.g. data SameKind (a::k) (b::k) - -- data T (a::k1) (b::k2) = MkT (SameKind a b) - -- Here k1 and k2 start as TyVarTvs, and get unified with each other - -- If this happens, things get very confused later, so fail fast - check_duplicate_tc_binders :: TcM () - check_duplicate_tc_binders = unless (null err_prs) $ - do { mapM_ report_dup err_prs; failM } - - -------------- Error reporting ------------ - err_prs :: [(Name,Name)] - err_prs = [ (n1,n2) - | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs - , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ] - -- This nubBy avoids bogus error reports when we have - -- [("f", f), ..., ("f",f)....] in swizzle_prs - -- which happens with class C f where { type T f } - - report_dup :: (Name,Name) -> TcM () - report_dup (n1,n2) - = setSrcSpan (getSrcSpan n2) $ addErrTc $ - hang (text "Different names for the same type variable:") 2 info - where - info | nameOccName n1 /= nameOccName n2 - = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) - | otherwise -- Same OccNames! See C2 in - -- Note [Swizzling the tyvars before generaliseTcTyCon] - = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) - , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] - - -------------- The swizzler ------------ - -- This does a deep traverse, simply doing a - -- Name-to-Name change, governed by swizzle_env - -- The 'swap' is what gets from the representative TyVar - -- back to the original user-specified Name - swizzle_env = mkVarEnv (map swap swizzle_prs) - - swizzleMapper :: TyCoMapper () Identity - swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv - , tcm_covar = swizzle_cv - , tcm_hole = swizzle_hole - , tcm_tycobinder = swizzle_bndr - , tcm_tycon = swizzle_tycon } - swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) - -- These types are pre-zonked - swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) - -- TcTyCons can't appear in kinds (yet) - swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) - swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) - - swizzle_bndr _ tcv _ - = return ((), swizzle_var tcv) - - swizzle_var :: Var -> Var - swizzle_var v - | Just nm <- lookupVarEnv swizzle_env v - = updateVarType swizzle_ty (v `setVarName` nm) - | otherwise - = updateVarType swizzle_ty v - - swizzle_ty ty = runIdentity (mapType swizzleMapper () ty) - - -generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon -generaliseTcTyCon (tc, scoped_prs, tc_res_kind) - -- See Note [Required, Specified, and Inferred for types] - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - do { -- Step 1: Separate Specified from Required variables - -- NB: spec_req_tvs = spec_tvs ++ req_tvs - -- And req_tvs is 1-1 with tyConTyVars - -- See Note [Scoped tyvars in a TcTyCon] in TyCon - ; let spec_req_tvs = map snd scoped_prs - n_spec = length spec_req_tvs - tyConArity tc - (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs - sorted_spec_tvs = scopedSort spec_tvs - -- NB: We can't do the sort until we've zonked - -- Maintain the L-R order of scoped_tvs - - -- Step 2a: find all the Inferred variables we want to quantify over - ; dvs1 <- candidateQTyVarsOfKinds $ - (tc_res_kind : map tyVarKind spec_req_tvs) - ; let dvs2 = dvs1 `delCandidates` spec_req_tvs - - -- Step 2b: quantify, mainly meaning skolemise the free variables - -- Returned 'inferred' are scope-sorted and skolemised - ; inferred <- quantifyTyVars dvs2 - - ; traceTc "generaliseTcTyCon: pre zonk" - (vcat [ text "tycon =" <+> ppr tc - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dvs1 =" <+> ppr dvs1 - , text "inferred =" <+> pprTyVars inferred ]) - - -- Step 3: Final zonk (following kind generalisation) - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - ; ze <- emptyZonkEnv - ; (ze, inferred) <- zonkTyBndrsX ze inferred - ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs - ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs - ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind - - ; traceTc "generaliseTcTyCon: post zonk" $ - vcat [ text "tycon =" <+> ppr tc - , text "inferred =" <+> pprTyVars inferred - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs - , text "req_tvs =" <+> ppr req_tvs - , text "zonk-env =" <+> ppr ze ] - - -- Step 4: Make the TyConBinders. - ; let dep_fv_set = candidateKindVars dvs1 - inferred_tcbs = mkNamedTyConBinders Inferred inferred - specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs - required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs - - -- Step 5: Assemble the final list. - final_tcbs = concat [ inferred_tcbs - , specified_tcbs - , required_tcbs ] - - -- Step 6: Make the result TcTyCon - tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind - (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) - True {- it's generalised now -} - (tyConFlavour tc) - - ; traceTc "generaliseTcTyCon done" $ - vcat [ text "tycon =" <+> ppr tc - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dep_fv_set =" <+> ppr dep_fv_set - , text "inferred_tcbs =" <+> ppr inferred_tcbs - , text "specified_tcbs =" <+> ppr specified_tcbs - , text "required_tcbs =" <+> ppr required_tcbs - , text "final_tcbs =" <+> ppr final_tcbs ] - - -- Step 7: Check for validity. - -- We do this here because we're about to put the tycon into the - -- the environment, and we don't want anything malformed there - ; checkTyConTelescope tycon - - ; return tycon } - -{- Note [Required, Specified, and Inferred for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each forall'd type variable in a type or kind is one of - - * Required: an argument must be provided at every call site - - * Specified: the argument can be inferred at call sites, but - may be instantiated with visible type/kind application - - * Inferred: the must be inferred at call sites; it - is unavailable for use with visible type/kind application. - -Why have Inferred at all? Because we just can't make user-facing -promises about the ordering of some variables. These might swizzle -around even between minor released. By forbidding visible type -application, we ensure users aren't caught unawares. - -Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. - -The question for this Note is this: - given a TyClDecl, how are its quantified type variables classified? -Much of the debate is memorialized in #15743. - -Here is our design choice. When inferring the ordering of variables -for a TyCl declaration (that is, for those variables that he user -has not specified the order with an explicit `forall`), we use the -following order: - - 1. Inferred variables - 2. Specified variables; in the left-to-right order in which - the user wrote them, modified by scopedSort (see below) - to put them in depdendency order. - 3. Required variables before a top-level :: - 4. All variables after a top-level :: - -If this ordering does not make a valid telescope, we reject the definition. - -Example: - data SameKind :: k -> k -> * - data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -For Bad: - - a, c, d, x are Required; they are explicitly listed by the user - as the positional arguments of Bad - - b is Specified; it appears explicitly in a kind signature - - k, the kind of a, is Inferred; it is not mentioned explicitly at all - -Putting variables in the order Inferred, Specified, Required -gives us this telescope: - Inferred: k - Specified: b : Proxy a - Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) - -But this order is ill-scoped, because b's kind mentions a, which occurs -after b in the telescope. So we reject Bad. - -Associated types -~~~~~~~~~~~~~~~~ -For associated types everything above is determined by the -associated-type declaration alone, ignoring the class header. -Here is an example (#15592) - class C (a :: k) b where - type F (x :: b a) - -In the kind of C, 'k' is Specified. But what about F? -In the kind of F, - - * Should k be Inferred or Specified? It's Specified for C, - but not mentioned in F's declaration. - - * In which order should the Specified variables a and b occur? - It's clearly 'a' then 'b' in C's declaration, but the L-R ordering - in F's declaration is 'b' then 'a'. - -In both cases we make the choice by looking at F's declaration alone, -so it gets the kind - F :: forall {k}. forall b a. b a -> Type - -How it works -~~~~~~~~~~~~ -These design choices are implemented by two completely different code -paths for - - * Declarations with a standalone kind signature or a complete user-specified - kind signature (CUSK). Handled by the kcCheckDeclHeader. - - * Declarations without a kind signature (standalone or CUSK) are handled by - kcInferDeclHeader; see Note [Inferring kinds for type declarations]. - -Note that neither code path worries about point (4) above, as this -is nicely handled by not mangling the res_kind. (Mangling res_kinds is done -*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.) - -We can tell Inferred apart from Specified by looking at the scoped -tyvars; Specified are always included there. - -Design alternatives -~~~~~~~~~~~~~~~~~~~ -* For associated types we considered putting the class variables - before the local variables, in a nod to the treatment for class - methods. But it got too compilicated; see #15592, comment:21ff. - -* We rigidly require the ordering above, even though we could be much more - permissive. Relevant musings are at - https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 - The bottom line conclusion is that, if the user wants a different ordering, - then can specify it themselves, and it is better to be predictable and dumb - than clever and capricious. - - I (Richard) conjecture we could be fully permissive, allowing all classes - of variables to intermix. We would have to augment ScopedSort to refuse to - reorder Required variables (or check that it wouldn't have). But this would - allow more programs. See #15743 for examples. Interestingly, Idris seems - to allow this intermixing. The intermixing would be fully specified, in that - we can be sure that inference wouldn't change between versions. However, - would users be able to predict it? That I cannot answer. - -Test cases (and tickets) relevant to these design decisions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - T15591* - T15592* - T15743* - -Note [Inferring kinds for type declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note deals with /inference/ for type declarations -that do not have a CUSK. Consider - data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) - data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) - -We do kind inference as follows: - -* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. - Make a unification variable for each of the Required and Specified - type variables in the header. - - Record the connection between the Names the user wrote and the - fresh unification variables in the tcTyConScopedTyVars field - of the TcTyCon we are making - [ (a, aa) - , (k1, kk1) - , (k2, kk2) - , (x, xx) ] - (I'm using the convention that double letter like 'aa' or 'kk' - mean a unification variable.) - - These unification variables - - Are TyVarTvs: that is, unification variables that can - unify only with other type variables. - See Note [Signature skolems] in TcType - - - Have complete fresh Names; see TcMType - Note [Unification variables need fresh Names] - - Assign initial monomorophic kinds to S, T - T :: kk1 -> * -> kk2 -> * - S :: kk3 -> * -> kk4 -> * - -* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and - T, with these monomorphic kinds. Now kind-check the declarations, - and solve the resulting equalities. The goal here is to discover - constraints on all these unification variables. - - Here we find that kk1 := kk3, and kk2 := kk4. - - This is why we can't use skolems for kk1 etc; they have to - unify with each other. - -* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. - We find the free variables of the kind, skolemise them, - sort them out into Inferred/Required/Specified (see the above - Note [Required, Specified, and Inferred for types]), - and perform some validity checks. - - This makes the utterly-final TyConBinders for the TyCon. - - All this is very similar at the level of terms: see TcBinds - Note [Quantified variables in partial type signatures] - - But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon] - -* Step 4. Extend the type environment with a TcTyCon for S and T, now - with their utterly-final polymorphic kinds (needed for recursive - occurrences of S, T). Now typecheck the declarations, and build the - final AlgTyCOn for S and T resp. - -The first three steps are in kcTyClGroup; the fourth is in -tcTyClDecls. - -There are some wrinkles - -* Do not default TyVarTvs. We always want to kind-generalise over - TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is - not allowed to unify with a type; it must stand for a type - variable. Hence the check in TcSimplify.defaultTyVarTcS, and - TcMType.defaultTyVar. Here's another example (#14555): - data Exp :: [TYPE rep] -> TYPE rep -> Type where - Lam :: Exp (a:xs) b -> Exp xs (a -> b) - We want to kind-generalise over the 'rep' variable. - #14563 is another example. - -* Duplicate type variables. Consider #11203 - data SameKind :: k -> k -> * - data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) - Here we will unify k1 with k2, but this time doing so is an error, - because k1 and k2 are bound in the same declaration. - - We spot this during validity checking (findDupTyVarTvs), - in generaliseTcTyCon. - -* Required arguments. Even the Required arguments should be made - into TyVarTvs, not skolems. Consider - data T k (a :: k) - Here, k is a Required, dependent variable. For uniformity, it is helpful - to have k be a TyVarTv, in parallel with other dependent variables. - -* Duplicate skolemisation is expected. When generalising in Step 3, - we may find that one of the variables we want to quantify has - already been skolemised. For example, suppose we have already - generalise S. When we come to T we'll find that kk1 (now the same as - kk3) has already been skolemised. - - That's fine -- but it means that - a) when collecting quantification candidates, in - candidateQTyVarsOfKind, we must collect skolems - b) quantifyTyVars should be a no-op on such a skolem - -Note [Tricky scoping in generaliseTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider #16342 - class C (a::ka) x where - cop :: D a x => x -> Proxy a -> Proxy a - cop _ x = x :: Proxy (a::ka) - - class D (b::kb) y where - dop :: C b y => y -> Proxy b -> Proxy b - dop _ x = x :: Proxy (b::kb) - -C and D are mutually recursive, by the time we get to -generaliseTcTyCon we'll have unified kka := kkb. - -But when typechecking the default declarations for 'cop' and 'dop' in -tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. -But at that point all we have is the utterly-final Class itself. - -Conclusion: the classTyVars of a class must have the same Name as -that originally assigned by the user. In our example, C must have -classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite -the fact that kka and kkb got unified! - -We achieve this sleight of hand in generaliseTcTyCon, using -the specialised function zonkRecTyVarBndrs. We make the call - zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] -where the [ka,a,x] are the Names originally assigned by the user, and -[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. -zonkRecTyVarBndrs builds a recursive ZonkEnv that binds - kkb :-> (ka :: ) - aa :-> (a :: ) - etc -That is, it maps each skolemised TcTyVars to the utterly-final -TyVar to put in the class, with its correct user-specified name. -When generalising D we'll do the same thing, but the ZonkEnv will map - kkb :-> (kb :: ) - bb :-> (b :: ) - etc -Note that 'kkb' again appears in the domain of the mapping, but this -time mapped to 'kb'. That's how C and D end up with differently-named -final TyVars despite the fact that we unified kka:=kkb - -zonkRecTyVarBndrs we need to do knot-tying because of the need to -apply this same substitution to the kind of each. - -Note [Inferring visible dependent quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T k :: k -> Type where - MkT1 :: T Type Int - MkT2 :: T (Type -> Type) Maybe - -This looks like it should work. However, it is polymorphically recursive, -as the uses of T in the constructor types specialize the k in the kind -of T. This trips up our dear users (#17131, #17541), and so we add -a "landmark" context (which cannot be suppressed) whenever we -spot inferred visible dependent quantification (VDQ). - -It's hard to know when we've actually been tripped up by polymorphic recursion -specifically, so we just include a note to users whenever we infer VDQ. The -testsuite did not show up a single spurious inclusion of this message. - -The context is added in addVDQNote, which looks for a visible TyConBinder -that also appears in the TyCon's kind. (I first looked at the kind for -a visible, dependent quantifier, but Note [No polymorphic recursion] in -TcHsType defeats that approach.) addVDQNote is used in kcTyClDecl, -which is used only when inferring the kind of a tycon (never with a CUSK or -SAK). - -Once upon a time, I (Richard E) thought that the tycon-kind could -not be a forall-type. But this is wrong: data T :: forall k. k -> Type -(with -XNoCUSKs) could end up here. And this is all OK. - - --} - --------------- -tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a -tcExtendKindEnvWithTyCons tcs - = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] - --------------- -mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv --- Maps each tycon/datacon to a suitable promotion error --- tc :-> APromotionErr TyConPE --- dc :-> APromotionErr RecDataConPE --- See Note [Recursion and promoting data constructors] - -mkPromotionErrorEnv decls - = foldr (plusNameEnv . mk_prom_err_env . unLoc) - emptyNameEnv decls - -mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv -mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) - = unitNameEnv nm (APromotionErr ClassPE) - `plusNameEnv` - mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) - | L _ at <- ats ] - -mk_prom_err_env (DataDecl { tcdLName = L _ name - , tcdDataDefn = HsDataDefn { dd_cons = cons } }) - = unitNameEnv name (APromotionErr TyConPE) - `plusNameEnv` - mkNameEnv [ (con, APromotionErr RecDataConPE) - | L _ con' <- cons - , L _ con <- getConNames con' ] - -mk_prom_err_env decl - = unitNameEnv (tcdName decl) (APromotionErr TyConPE) - -- Works for family declarations too - --------------- -inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] --- Returns a TcTyCon for each TyCon bound by the decls, --- each with its initial kind - -inferInitialKinds decls - = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) - ; tcs <- concatMapM infer_initial_kind decls - ; traceTc "inferInitialKinds done }" empty - ; return tcs } - where - infer_initial_kind = addLocM (getInitialKind InitialKindInfer) - --- Check type/class declarations against their standalone kind signatures or --- CUSKs, producing a generalized TcTyCon for each. -checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon] -checkInitialKinds decls - = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) - ; tcs <- concatMapM check_initial_kind decls - ; traceTc "checkInitialKinds done }" empty - ; return tcs } - where - check_initial_kind (ldecl, msig) = - addLocM (getInitialKind (InitialKindCheck msig)) ldecl - --- | Get the initial kind of a TyClDecl, either generalized or non-generalized, --- depending on the 'InitialKindStrategy'. -getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] - --- Allocate a fresh kind variable for each TyCon and Class --- For each tycon, return a TcTyCon with kind k --- where k is the kind of tc, derived from the LHS --- of the definition (and probably including --- kind unification variables) --- Example: data T a b = ... --- return (T, kv1 -> kv2 -> kv3) --- --- This pass deals with (ie incorporates into the kind it produces) --- * The kind signatures on type-variable binders --- * The result kinds signature on a TyClDecl --- --- No family instances are passed to checkInitialKinds/inferInitialKinds -getInitialKind strategy - (ClassDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdATs = ats }) - = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ - return (TheKind constraintKind) - ; let parent_tv_prs = tcTyConScopedTyVars cls - -- See Note [Don't process associated types in getInitialKind] - ; inner_tcs <- - tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocM (getAssocFamInitialKind cls)) ats - ; return (cls : inner_tcs) } - where - getAssocFamInitialKind cls = - case strategy of - InitialKindInfer -> get_fam_decl_initial_kind (Just cls) - InitialKindCheck _ -> check_initial_kind_assoc_fam cls - -getInitialKind strategy - (DataDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig - , dd_ND = new_or_data } }) - = do { let flav = newOrDataToFlavour new_or_data - ctxt = DataKindCtxt name - ; tc <- kcDeclHeader strategy name flav ktvs $ - case m_sig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> dataDeclDefaultResultKind new_or_data - ; return [tc] } - -getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) - = do { tc <- get_fam_decl_initial_kind Nothing decl - ; return [tc] } - -getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = - FamilyDecl { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } } ) - = do { let flav = getFamFlav Nothing info - ctxt = TyFamResKindCtxt name - ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> - case msig of - CUSK -> return (TheKind liftedTypeKind) - SAKS _ -> return AnyKind - ; return [tc] } - -getInitialKind strategy - (SynDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdRhs = rhs }) - = do { let ctxt = TySynKindCtxt name - ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ - case hsTyKindSig rhs of - Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig - Nothing -> return AnyKind - ; return [tc] } - -getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec -getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec -getInitialKind _ (XTyClDecl nec) = noExtCon nec - -get_fam_decl_initial_kind - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyDecl GhcRn - -> TcM TcTyCon -get_fam_decl_initial_kind mb_parent_tycon - FamilyDecl { fdLName = L _ name - , fdTyVars = ktvs - , fdResultSig = L _ resultSig - , fdInfo = info } - = kcDeclHeader InitialKindInfer name flav ktvs $ - case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki - _ -- open type families have * return kind by default - | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) - -- closed type families have their return kind inferred - -- by default - | otherwise -> return AnyKind - where - flav = getFamFlav mb_parent_tycon info - ctxt = TyFamResKindCtxt name -get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec - --- See Note [Standalone kind signatures for associated types] -check_initial_kind_assoc_fam - :: TcTyCon -- parent class - -> FamilyDecl GhcRn - -> TcM TcTyCon -check_initial_kind_assoc_fam cls - FamilyDecl - { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } - = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return (TheKind liftedTypeKind) - where - ctxt = TyFamResKindCtxt name - flav = getFamFlav (Just cls) info -check_initial_kind_assoc_fam _ (XFamilyDecl nec) = noExtCon nec - -{- Note [Standalone kind signatures for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If associated types had standalone kind signatures, would they wear them - ----------------------------+------------------------------ - like this? (OUT) | or like this? (IN) ----------------------------+------------------------------ - type T :: Type -> Type | class C a where - class C a where | type T :: Type -> Type - type T a | type T a - -The (IN) variant is syntactically ambiguous: - - class C a where - type T :: a -- standalone kind signature? - type T :: a -- declaration header? - -The (OUT) variant does not suffer from this issue, but it might not be the -direction in which we want to take Haskell: we seek to unify type families and -functions, and, by extension, associated types with class methods. And yet we -give class methods their signatures inside the class, not outside. Neither do -we have the counterpart of InstanceSigs for StandaloneKindSignatures. - -For now, we dodge the question by using CUSKs for associated types instead of -standalone kind signatures. This is a simple addition to the rule we used to -have before standalone kind signatures: - - old rule: associated type has a CUSK iff its parent class has a CUSK - new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature - --} - --- See Note [Data declaration default result kind] -dataDeclDefaultResultKind :: NewOrData -> TcM ContextKind -dataDeclDefaultResultKind new_or_data = do - -- See Note [Implementation of UnliftedNewtypes] - unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - return $ case new_or_data of - NewType | unlifted_newtypes -> OpenKind - _ -> TheKind liftedTypeKind - -{- Note [Data declaration default result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When the user has not written an inline result kind annotation on a data -declaration, we assume it to be 'Type'. That is, the following declarations -D1 and D2 are considered equivalent: - - data D1 where ... - data D2 :: Type where ... - -The consequence of this assumption is that we reject D3 even though we -accept D4: - - data D3 where - MkD3 :: ... -> D3 param - - data D4 :: Type -> Type where - MkD4 :: ... -> D4 param - -However, there's a twist: when -XUnliftedNewtypes are enabled, we must relax -the assumed result kind to (TYPE r) for newtypes: - - newtype D5 where - MkD5 :: Int# -> D5 - -dataDeclDefaultResultKind takes care to produce the appropriate result kind. --} - ---------------------------------- -getFamFlav - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyInfo pass - -> TyConFlavour -getFamFlav mb_parent_tycon info = - case info of - DataFamily -> DataFamilyFlavour mb_parent_tycon - OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon - ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon] - ClosedTypeFamilyFlavour - -{- Note [Closed type family mb_parent_tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's no way to write a closed type family inside a class declaration: - - class C a where - type family F a where -- error: parse error on input ‘where’ - -In fact, it is not clear what the meaning of such a declaration would be. -Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. --} - ------------------------------------------------------------------------- -kcLTyClDecl :: LTyClDecl GhcRn -> TcM () - -- See Note [Kind checking for type and class decls] - -- Called only for declarations without a signature (no CUSKs or SAKs here) -kcLTyClDecl (L loc decl) - = setSrcSpan loc $ - do { tycon <- kcLookupTcTyCon tc_name - ; traceTc "kcTyClDecl {" (ppr tc_name) - ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] - addErrCtxt (tcMkDeclCtxt decl) $ - kcTyClDecl decl tycon - ; traceTc "kcTyClDecl done }" (ppr tc_name) } - where - tc_name = tcdName decl - -kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () --- This function is used solely for its side effect on kind variables --- NB kind signatures on the type variables and --- result kind signature have already been dealt with --- by inferInitialKind, so we can ignore them here. - -kcTyClDecl (DataDecl { tcdLName = (L _ name) - , tcdDataDefn = defn }) tyCon - | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) - , dd_ctxt = (L _ []) - , dd_ND = new_or_data } <- defn - = -- See Note [Implementation of UnliftedNewtypes] STEP 2 - kcConDecls new_or_data (tyConResKind tyCon) cons - - -- hs_tvs and dd_kindSig already dealt with in inferInitialKind - -- This must be a GADT-style decl, - -- (see invariants of DataDefn declaration) - -- so (a) we don't need to bring the hs_tvs into scope, because the - -- ConDecls bind all their own variables - -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it - - | HsDataDefn { dd_ctxt = ctxt - , dd_cons = cons - , dd_ND = new_or_data } <- defn - = bindTyClTyVars name $ \ _ _ -> - do { _ <- tcHsContext ctxt - ; kcConDecls new_or_data (tyConResKind tyCon) cons - } - -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon - = bindTyClTyVars name $ \ _ res_kind -> - discardResult $ tcCheckLHsType rhs res_kind - -- NB: check against the result kind that we allocated - -- in inferInitialKinds. - -kcTyClDecl (ClassDecl { tcdLName = L _ name - , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon - = bindTyClTyVars name $ \ _ _ -> - do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM_ kc_sig) sigs } - where - kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty - kc_sig _ = return () - - skol_info = TyConSkol ClassFlavour name - -kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc --- closed type families look at their equations, but other families don't --- do anything here - = case fd_info of - ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns - _ -> return () -kcTyClDecl (FamDecl _ (XFamilyDecl nec)) _ = noExtCon nec -kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) _ = noExtCon nec -kcTyClDecl (XTyClDecl nec) _ = noExtCon nec - -------------------- - --- | Unify the kind of the first type provided with the newtype's kind, if --- -XUnliftedNewtypes is enabled and the NewOrData indicates Newtype. If there --- is more than one type provided, do nothing: the newtype is in error, and this --- will be caught in validity checking (which will give a better error than we can --- here.) -unifyNewtypeKind :: DynFlags - -> NewOrData - -> [LHsType GhcRn] -- user-written argument types, should be just 1 - -> [TcType] -- type-checked argument types, should be just 1 - -> TcKind -- expected kind of newtype - -> TcM [TcType] -- casted argument types (should be just 1) - -- result = orig_arg |> kind_co - -- where kind_co :: orig_arg_ki ~N expected_ki -unifyNewtypeKind dflags NewType [hs_ty] [tc_ty] ki - | xopt LangExt.UnliftedNewtypes dflags - = do { traceTc "unifyNewtypeKind" (ppr hs_ty $$ ppr tc_ty $$ ppr ki) - ; co <- unifyKind (Just (unLoc hs_ty)) (typeKind tc_ty) ki - ; return [tc_ty `mkCastTy` co] } - -- See comments above: just do nothing here -unifyNewtypeKind _ _ _ arg_tys _ = return arg_tys - --- Type check the types of the arguments to a data constructor. --- This includes doing kind unification if the type is a newtype. --- See Note [Implementation of UnliftedNewtypes] for why we need --- the first two arguments. -kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () -kcConArgTys new_or_data res_kind arg_tys = do - { arg_tc_tys <- mapM (tcHsOpenType . getBangType) arg_tys - -- See Note [Implementation of UnliftedNewtypes], STEP 2 - ; dflags <- getDynFlags - ; discardResult $ - unifyNewtypeKind dflags new_or_data arg_tys arg_tc_tys res_kind - } - -kcConDecls :: NewOrData - -> Kind -- The result kind signature - -> [LConDecl GhcRn] -- The data constructors - -> TcM () -kcConDecls new_or_data res_kind cons - = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons - where - (_, final_res_kind) = splitPiTys res_kind - -- See Note [kcConDecls result kind] - --- Kind check a data constructor. In additional to the data constructor, --- we also need to know about whether or not its corresponding type was --- declared with data or newtype, and we need to know the result kind of --- this type. See Note [Implementation of UnliftedNewtypes] for why --- we need the first two arguments. -kcConDecl :: NewOrData - -> Kind -- Result kind of the type constructor - -- Usually Type but can be TYPE UnliftedRep - -- or even TYPE r, in the case of unlifted newtype - -> ConDecl GhcRn - -> TcM () -kcConDecl new_or_data res_kind (ConDeclH98 - { con_name = name, con_ex_tvs = ex_tvs - , con_mb_cxt = ex_ctxt, con_args = args }) - = addErrCtxt (dataConCtxtName [name]) $ - discardResult $ - bindExplicitTKBndrs_Tv ex_tvs $ - do { _ <- tcHsMbContext ex_ctxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) - -- We don't need to check the telescope here, - -- because that's done in tcConDecl - } - -kcConDecl new_or_data res_kind (ConDeclGADT - { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt - , con_args = args, con_res_ty = res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs - = -- Even though the GADT-style data constructor's type is closed, - -- we must still kind-check the type, because that may influence - -- the inferred kind of the /type/ constructor. Example: - -- data T f a where - -- MkT :: f a -> T f a - -- If we don't look at MkT we won't get the correct kind - -- for the type constructor T - addErrCtxt (dataConCtxtName names) $ - discardResult $ - bindImplicitTKBndrs_Tv implicit_tkv_nms $ - bindExplicitTKBndrs_Tv explicit_tkv_nms $ - -- Why "_Tv"? See Note [Kind-checking for GADTs] - do { _ <- tcHsMbContext cxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) - ; _ <- tcHsOpenType res_ty - ; return () } -kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) = noExtCon nec -kcConDecl _ _ (XConDecl nec) = noExtCon nec - -{- Note [kcConDecls result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We might have e.g. - data T a :: Type -> Type where ... -or - newtype instance N a :: Type -> Type where .. -in which case, the 'res_kind' passed to kcConDecls will be - Type->Type - -We must look past those arrows, or even foralls, to the Type in the -corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here. - -I am a bit concerned about tycons with a declaration like - data T a :: Type -> forall k. k -> Type where ... - -It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon -with tyConResKind of Type -> forall k. k -> Type. Even that is fine: -the splitPiTys will look past the forall. But I'm bothered about -what if the type "in the corner" mentions k? This is incredibly -obscure but something like this could be bad: - data T a :: Type -> foral k. k -> TYPE (F k) where ... - -I bet we are not quite right here, but my brain suffered a buffer -overflow and I thought it best to nail the common cases right now. - -Note [Recursion and promoting data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to allow promotion in a strongly connected component -when kind checking. - -Consider: - data T f = K (f (K Any)) - -When kind checking the `data T' declaration the local env contains the -mappings: - T -> ATcTyCon - K -> APromotionErr - -APromotionErr is only used for DataCons, and only used during type checking -in tcTyClGroup. - -Note [Kind-checking for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Proxy a where - MkProxy1 :: forall k (b :: k). Proxy b - MkProxy2 :: forall j (c :: j). Proxy c - -It seems reasonable that this should be accepted. But something very strange -is going on here: when we're kind-checking this declaration, we need to unify -the kind of `a` with k and j -- even though k and j's scopes are local to the type of -MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during -the kind-checking pass. First off, note that it's OK if the kind-checking pass -is too permissive: we'll snag the problems in the type-checking pass later. -(This extra permissiveness might happen with something like - - data SameKind :: k -> k -> Type - data Bad a where - MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) - -which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected -in the second pass, though. Test case: polykinds/TyVarTvKinds3) -Recall that the kind-checking pass exists solely to collect constraints -on the kinds and to power unification. - -To achieve the use of TyVarTvs, we must be careful to use specialized functions -that produce TyVarTvs, not ordinary skolems. This is why we need -kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their -tc... variants. - -The drawback of this approach is sometimes it will accept a definition that -a (hypothetical) declarative specification would likely reject. As a general -rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, -the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs -approach allows a limited form of polymorphic recursion *without* a CUSK. - -To wit: - data T a = forall k (b :: k). MkT (T b) Int - (test case: dependent/should_compile/T14066a) - -Note that this is polymorphically recursive, with the recursive occurrence -of T used at a kind other than a's kind. The approach outlined here accepts -this definition, because this kind is still a kind variable (and so the -TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a -way to describe exactly what declarations will be accepted and which will -be rejected (without a CUSK). However, the accepted definitions are indeed -well-kinded and any rejected definitions would be accepted with a CUSK, -and so this wrinkle need not cause anyone to lose sleep. - -************************************************************************ -* * -\subsection{Type checking} -* * -************************************************************************ - -Note [Type checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this point we have completed *kind-checking* of a mutually -recursive group of type/class decls (done in kcTyClGroup). However, -we discarded the kind-checked types (eg RHSs of data type decls); -note that kcTyClDecl returns (). There are two reasons: - - * It's convenient, because we don't have to rebuild a - kinded HsDecl (a fairly elaborate type) - - * It's necessary, because after kind-generalisation, the - TyCons/Classes may now be kind-polymorphic, and hence need - to be given kind arguments. - -Example: - data T f a = MkT (f a) (T f a) -During kind-checking, we give T the kind T :: k1 -> k2 -> * -and figure out constraints on k1, k2 etc. Then we generalise -to get T :: forall k. (k->*) -> k -> * -So now the (T f a) in the RHS must be elaborated to (T k f a). - -However, during tcTyClDecl of T (above) we will be in a recursive -"knot". So we aren't allowed to look at the TyCon T itself; we are only -allowed to put it (lazily) in the returned structures. But when -kind-checking the RHS of T's decl, we *do* need to know T's kind (so -that we can correctly elaboarate (T k f a). How can we get T's kind -without looking at T? Delicate answer: during tcTyClDecl, we extend - - *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) - *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) - -Then: - - * During TcHsType.tcTyVar we look in the *local* env, to get the - fully-known, not knot-tied TcTyCon for T. - - * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular) - we look in the *global* env to get the TyCon. - -This fancy footwork (with two bindings for T) is only necessary for the -TyCons or Classes of this recursive group. Earlier, finished groups, -live in the global env only. - -See also Note [Kind checking recursive type and class declarations] - -Note [Kind checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before we can type-check the decls, we must kind check them. This -is done by establishing an "initial kind", which is a rather uninformed -guess at a tycon's kind (by counting arguments, mainly) and then -using this initial kind for recursive occurrences. - -The initial kind is stored in exactly the same way during -kind-checking as it is during type-checking (Note [Type checking -recursive type and class declarations]): in the *local* environment, -with ATcTyCon. But we still must store *something* in the *global* -environment. Even though we discard the result of kind-checking, we -sometimes need to produce error messages. These error messages will -want to refer to the tycons being checked, except that they don't -exist yet, and it would be Terribly Annoying to get the error messages -to refer back to HsSyn. So we create a TcTyCon and put it in the -global env. This tycon can print out its name and knows its kind, but -any other action taken on it will panic. Note that TcTyCons are *not* -knot-tied, unlike the rather valid but knot-tied ones that occur -during type-checking. - -Note [Declarations for wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For wired-in things we simply ignore the declaration -and take the wired-in information. That avoids complications. -e.g. the need to make the data constructor worker name for - a constraint tuple match the wired-in one - -Note [Implementation of UnliftedNewtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expected behavior of UnliftedNewtypes: - -* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst -* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 - -What follows is a high-level overview of the implementation of the -proposal. - -STEP 1: Getting the initial kind, as done by inferInitialKind. We have -two sub-cases (assuming we have a newtype and -XUnliftedNewtypes is enabled): - -* With a CUSK: no change in kind-checking; the tycon is given the kind - the user writes, whatever it may be. - -* Without a CUSK: If there is no kind signature, the tycon is given - a kind `TYPE r`, for a fresh unification variable `r`. - -STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. -The key function here is kcConDecl, which looks at an individual constructor -declaration. In the unlifted-newtypes case (i.e., -XUnliftedNewtypes and, -indeed, we are processing a newtype), we call unifyNewtypeKind, which is a -thin wrapper around unifyKind, unifying the kind of the one argument and the -result kind of the newtype tycon. - -Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is -enabled (we use r0 to denote a unification variable): - -newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -+ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) - is the kind that inferInitialKind invented for (Foo rep). - -data Color = Red | Blue -type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep -data family Foo (x :: Color) :: TYPE (Interpret x) -newtype instance Foo 'Red = FooRedC Int# -+ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep - -Note that, in the GADT case, we might have a kind signature with arrows -(newtype XYZ a b :: Type -> Type where ...). We want only the final -component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon -in kcTyClDecl. - -STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function -here is tcConDecl. Once again, we must call unifyNewtypeKind, for two reasons: - - A. It is possible that a GADT has a CUSK. (Note that this is *not* - possible for H98 types. Recall that CUSK types don't go through - kcTyClDecl, so we might not have done this kind check. - B. We need to produce the coercion to put on the argument type - if the kinds are different (for both H98 and GADT). - -Example of (B): - -type family F a where - F Int = LiftedRep - -newtype N :: TYPE (F Int) where - MkN :: Int -> N - -We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where -axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the -newtype kind, which is the principal correctness condition for newtypes. -This call to unifyNewtypeKind is what produces that coercion. - -Note that this is possible in the H98 case only for a data family, because -the H98 syntax doesn't permit a kind signature on the newtype itself. - - -1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if - UnliftedNewtypes is on. This allows us to write things like: - data family Foo :: TYPE 'IntRep - -2. In a newtype instance (with -XUnliftedNewtypes), if the user does - not write a kind signature, we want to allow the possibility that - the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. - This is done in tcDataFamInstHeader in TcInstDcls. Example: - - data family Bar (a :: RuntimeRep) :: TYPE a - newtype instance Bar 'IntRep = BarIntC Int# - newtype instance Bar 'WordRep :: TYPE 'WordRep where - BarWordC :: Word# -> Bar 'WordRep - - The data instance corresponding to IntRep does not specify a kind signature, - so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). - The data instance corresponding to WordRep does have a kind signature, so - we use that kind signature. - -3. A data family and its newtype instance may be declared with slightly - different kinds. See Note [Unifying data family kinds] in TcInstDcls. - -There's also a change in the renamer: - -* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means - for a newtype to have a CUSK. This is necessary since UnliftedNewtypes - means that, for newtypes without kind signatures, we must use the field - inside the data constructor to determine the result kind. - See Note [Unlifted Newtypes and CUSKs] for more detail. - -For completeness, it was also necessary to make coerce work on -unlifted types, resolving #13595. - --} - -tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl roles_info (L loc decl) - | Just thing <- wiredInNameTyThing_maybe (tcdName decl) - = case thing of -- See Note [Declarations for wired-in things] - ATyCon tc -> return (tc, wiredInDerivInfo tc decl) - _ -> pprPanic "tcTyClDecl" (ppr thing) - - | otherwise - = setSrcSpan loc $ tcAddDeclCtxt decl $ - do { traceTc "---- tcTyClDecl ---- {" (ppr decl) - ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl - ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) - ; return (tc, deriv_infos) } - -noDerivInfos :: a -> (a, [DerivInfo]) -noDerivInfos a = (a, []) - -wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] -wiredInDerivInfo tycon decl - | DataDecl { tcdDataDefn = dataDefn } <- decl - , HsDataDefn { dd_derivs = derivs } <- dataDefn - = [ DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = - if isFunTyCon tycon || isPrimTyCon tycon - then [] -- no tyConTyVars - else mkTyVarNamePairs (tyConTyVars tycon) - , di_clauses = unLoc derivs - , di_ctxt = tcMkDeclCtxt decl } ] -wiredInDerivInfo _ _ = [] - - -- "type family" declarations -tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) - = fmap noDerivInfos $ - tcFamDecl1 parent fd - - -- "type" synonym declaration -tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = L _ tc_name - , tcdRhs = rhs }) - = ASSERT( isNothing _parent ) - fmap noDerivInfos $ - tcTySynRhs roles_info tc_name rhs - - -- "data/newtype" declaration -tcTyClDecl1 _parent roles_info - decl@(DataDecl { tcdLName = L _ tc_name - , tcdDataDefn = defn }) - = ASSERT( isNothing _parent ) - tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn - -tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = L _ class_name - , tcdCtxt = hs_ctxt - , tcdMeths = meths - , tcdFDs = fundeps - , tcdSigs = sigs - , tcdATs = ats - , tcdATDefs = at_defs }) - = ASSERT( isNothing _parent ) - do { clas <- tcClassDecl1 roles_info class_name hs_ctxt - meths fundeps sigs ats at_defs - ; return (noDerivInfos (classTyCon clas)) } - -tcTyClDecl1 _ _ (XTyClDecl nec) = noExtCon nec - - -{- ********************************************************************* -* * - Class declarations -* * -********************************************************************* -} - -tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn - -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] - -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] - -> TcM Class -tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs - = fixM $ \ clas -> - -- We need the knot because 'clas' is passed into tcClassATs - bindTyClTyVars class_name $ \ binders res_kind -> - do { checkClassKindSig res_kind - ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) - ; let tycon_name = class_name -- We use the same name - roles = roles_info tycon_name -- for TyCon and Class - - ; (ctxt, fds, sig_stuff, at_stuff) - <- pushTcLevelM_ $ - solveEqualities $ - checkTvConstraints skol_info (binderVars binders) $ - -- The checkTvConstraints is needed bring into scope the - -- skolems bound by the class decl header (#17841) - do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths - ; at_stuff <- tcClassATs class_name clas ats at_defs - ; return (ctxt, fds, sig_stuff, at_stuff) } - - -- The solveEqualities will report errors for any - -- unsolved equalities, so these zonks should not encounter - -- any unfilled coercion variables unless there is such an error - -- The zonk also squeeze out the TcTyCons, and converts - -- Skolems to tyvars. - ; ze <- emptyZonkEnv - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff - -- ToDo: do we need to zonk at_stuff? - - -- TODO: Allow us to distinguish between abstract class, - -- and concrete class with no methods (maybe by - -- specifying a trailing where or not - - ; mindef <- tcClassMinimalDef class_name sigs sig_stuff - ; is_boot <- tcIsHsBootOrSig - ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff - = Nothing - | otherwise - = Just (ctxt, at_stuff, sig_stuff, mindef) - - ; clas <- buildClass class_name binders roles fds body - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ - ppr fds) - ; return clas } - where - skol_info = TyConSkol ClassFlavour class_name - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; - ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; - ; return (tvs1', tvs2') } - - -{- Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The following is an example of associated type defaults: - class C a where - data D a - - type F a b :: * - type F a b = [a] -- Default - -Note that we can get default definitions only for type families, not data -families. --} - -tcClassATs :: Name -- The class name (not knot-tied) - -> Class -- The class parent of this associated type - -> [LFamilyDecl GhcRn] -- Associated types. - -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. - -> TcM [ClassATItem] -tcClassATs class_name cls ats at_defs - = do { -- Complain about associated type defaults for non associated-types - sequence_ [ failWithTc (badATErr class_name n) - | n <- map at_def_tycon at_defs - , not (n `elemNameSet` at_names) ] - ; mapM tc_at ats } - where - at_def_tycon :: LTyFamDefltDecl GhcRn -> Name - at_def_tycon = tyFamInstDeclName . unLoc - - at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name = familyDeclName . unLoc - - at_names = mkNameSet (map at_fam_name ats) - - at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] - -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (at_def_tycon at_def) [at_def]) - emptyNameEnv at_defs - - tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at - ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) - `orElse` [] - ; atd <- tcDefaultAssocDecl fam_tc at_defs - ; return (ATI fam_tc atd) } - -------------------------- -tcDefaultAssocDecl :: - TyCon -- ^ Family TyCon (not knot-tied) - -> [LTyFamDefltDecl GhcRn] -- ^ Defaults - -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS -tcDefaultAssocDecl _ [] - = return Nothing -- No default declaration - -tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (text "More than one default declaration for" - <+> ppr (tyFamInstDeclName (unLoc d1))) - -tcDefaultAssocDecl fam_tc - [L loc (TyFamInstDecl { tfid_eqn = - HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }}})] - = -- See Note [Type-checking default assoc decls] - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") tc_name $ - do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) - ; let fam_tc_name = tyConName fam_tc - vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - - -- Kind of family check - ; ASSERT( fam_tc_name == tc_name ) - checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - - -- Arity check - ; checkTc (vis_pats == vis_arity) - (wrongNumberOfParmsErr vis_arity) - - -- Typecheck RHS - -- - -- You might think we should pass in some AssocInstInfo, as we're looking - -- at an associated type. But this would be wrong, because an associated - -- type default LHS can mention *different* type variables than the - -- enclosing class. So it's treated more as a freestanding beast. - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated - imp_vars (mb_expl_bndrs `orElse` []) - hs_pats hs_rhs_ty - - ; let fam_tvs = tyConTyVars fam_tc - ppr_eqn = ppr_default_eqn pats rhs_ty - pats_vis = tyConArgFlags fam_tc pats - ; traceTc "tcDefaultAssocDecl 2" (vcat - [ text "fam_tvs" <+> ppr fam_tvs - , text "qtvs" <+> ppr qtvs - , text "pats" <+> ppr pats - , text "rhs_ty" <+> ppr rhs_ty - ]) - ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis - ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis - ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs) - ; pure $ Just (substTyUnchecked subst rhs_ty, loc) - -- We also perform other checks for well-formedness and validity - -- later, in checkValidClass - } - where - -- Checks that a pattern on the LHS of a default is a type - -- variable. If so, return the underlying type variable, and if - -- not, throw an error. - -- See Note [Type-checking default assoc decls] - extract_tv :: SDoc -- The pretty-printed default equation - -- (only used for error message purposes) - -> Type -- The particular type pattern from which to extract - -- its underlying type variable - -> ArgFlag -- The visibility of the type pattern - -- (only used for error message purposes) - -> TcM TyVar - extract_tv ppr_eqn pat pat_vis = - case getTyVar_maybe pat of - Just tv -> pure tv - Nothing -> failWithTc $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ - hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion]) - - - -- Checks that no type variables in an associated default declaration are - -- duplicated. If that is the case, throw an error. - -- See Note [Type-checking default assoc decls] - check_all_distinct_tvs :: - SDoc -- The pretty-printed default equation (only used - -- for error message purposes) - -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated - -- default declaration, along with their respective - -- visibilities (the latter are only used for error - -- message purposes) - -> TcM () - check_all_distinct_tvs ppr_eqn pat_tvs_vis = - let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in - traverse_ - (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ - hang (text "Illegal duplicate variable" - <+> quotes (ppr pat_tv) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion])) - dups - - ppr_default_eqn :: [Type] -> Type -> SDoc - ppr_default_eqn pats rhs_ty = - quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) - <+> equals <+> ppr rhs_ty) - - suggestion :: SDoc - suggestion = text "The arguments to" <+> quotes (ppr fam_tc) - <+> text "must all be distinct type variables" - -tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x -tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x - - -{- Note [Type-checking default assoc decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this default declaration for an associated type - - class C a where - type F (a :: k) b :: Type - type F (x :: j) y = Proxy x -> y - -Note that the class variable 'a' doesn't scope over the default assoc -decl (rather oddly I think), and (less oddly) neither does the second -argument 'b' of the associated type 'F', or the kind variable 'k'. -Instead, the default decl is treated more like a top-level type -instance. - -However we store the default rhs (Proxy x -> y) in F's TyCon, using -F's own type variables, so we need to convert it to (Proxy a -> b). -We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and -applying this substitution to the RHS. - -In order to create this substitution, we must first ensure that all of -the arguments in the default instance consist of distinct type variables. -One might think that this is a simple task that could be implemented earlier -in the compiler, perhaps in the parser or the renamer. However, there are some -tricky corner cases that really do require the full power of typechecking to -weed out, as the examples below should illustrate. - -First, we must check that all arguments are type variables. As a motivating -example, consider this erroneous program (inspired by #11361): - - class C a where - type F (a :: k) b :: Type - type F x b = x - -If you squint, you'll notice that the kind of `x` is actually Type. However, -we cannot substitute from [Type |-> k], so we reject this default. - -Next, we must check that all arguments are distinct. Here is another offending -example, this time taken from #13971: - - class C2 (a :: j) where - type F2 (a :: j) (b :: k) - type F2 (x :: z) y = SameKind x y - data SameKind :: k -> k -> Type - -All of the arguments in the default equation for `F2` are type variables, so -that passes the first check. However, if we were to build this substitution, -then both `j` and `k` map to `z`! In terms of visible kind application, it's as -if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear -that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is -also rejected. - -Since the LHS of an associated type family default is always just variables, -it won't contain any tycons. Accordingly, the patterns used in the substitution -won't actually be knot-tied, even though we're in the knot. This is too -delicate for my taste, but it works. --} - -{- ********************************************************************* -* * - Type family declarations -* * -********************************************************************* -} - -tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon -tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info - , fdLName = tc_lname@(L _ tc_name) - , fdResultSig = L _ sig - , fdInjectivityAnn = inj }) - | DataFamily <- fam_info - = bindTyClTyVars tc_name $ \ binders res_kind -> do - { traceTc "data family:" (ppr tc_name) - ; checkFamFlag tc_name - - -- Check that the result kind is OK - -- We allow things like - -- data family T (a :: Type) :: forall k. k -> Type - -- We treat T as having arity 1, but result kind forall k. k -> Type - -- But we want to check that the result kind finishes in - -- Type or a kind-variable - -- For the latter, consider - -- data family D a :: forall k. Type -> k - -- When UnliftedNewtypes is enabled, we loosen this restriction - -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). - ; let (_, final_res_kind) = splitPiTys res_kind - ; checkDataKindSig DataFamilySort final_res_kind - ; tc_rep_name <- newTyConRepName tc_name - ; let inj = Injective $ replicate (length binders) True - tycon = mkFamilyTyCon tc_name binders - res_kind - (resultVariableName sig) - (DataFamilyTyCon tc_rep_name) - parent inj - ; return tycon } - - | OpenTypeFamily <- fam_info - = bindTyClTyVars tc_name $ \ binders res_kind -> do - { traceTc "open type family:" (ppr tc_name) - ; checkFamFlag tc_name - ; inj' <- tcInjectivity binders inj - ; checkResultSigFlag tc_name sig -- check after injectivity for better errors - ; let tycon = mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) OpenSynFamilyTyCon - parent inj' - ; return tycon } - - | ClosedTypeFamily mb_eqns <- fam_info - = -- Closed type families are a little tricky, because they contain the definition - -- of both the type family and the equations for a CoAxiom. - do { traceTc "Closed type family:" (ppr tc_name) - -- the variables in the header scope only over the injectivity - -- declaration but this is not involved here - ; (inj', binders, res_kind) - <- bindTyClTyVars tc_name $ \ binders res_kind -> - do { inj' <- tcInjectivity binders inj - ; return (inj', binders, res_kind) } - - ; checkFamFlag tc_name -- make sure we have -XTypeFamilies - ; checkResultSigFlag tc_name sig - - -- If Nothing, this is an abstract family in a hs-boot file; - -- but eqns might be empty in the Just case as well - ; case mb_eqns of - Nothing -> - return $ mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) - AbstractClosedSynFamilyTyCon parent - inj' - Just eqns -> do { - - -- Process the equations, creating CoAxBranches - ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind - noTcTyConScopedTyVars - False {- this doesn't matter here -} - ClosedTypeFamilyFlavour - - ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns - -- Do not attempt to drop equations dominated by earlier - -- ones here; in the case of mutual recursion with a data - -- type, we get a knot-tying failure. Instead we check - -- for this afterwards, in TcValidity.checkValidCoAxiom - -- Example: tc265 - - -- Create a CoAxiom, with the correct src location. - ; co_ax_name <- newFamInstAxiomName tc_lname [] - - ; let mb_co_ax - | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list - | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - - fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) - (ClosedSynFamilyTyCon mb_co_ax) parent inj' - - -- We check for instance validity later, when doing validity - -- checking for the tycon. Exception: checking equations - -- overlap done by dropDominatedAxioms - ; return fam_tc } } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker -#endif -tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec - --- | Maybe return a list of Bools that say whether a type family was declared --- injective in the corresponding type arguments. Length of the list is equal to --- the number of arguments (including implicit kind/coercion arguments). --- True on position --- N means that a function is injective in its Nth argument. False means it is --- not. -tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) - -> TcM Injectivity -tcInjectivity _ Nothing - = return NotInjective - - -- User provided an injectivity annotation, so for each tyvar argument we - -- check whether a type family was declared injective in that argument. We - -- return a list of Bools, where True means that corresponding type variable - -- was mentioned in lInjNames (type family is injective in that argument) and - -- False means that it was not mentioned in lInjNames (type family is not - -- injective in that type variable). We also extend injectivity information to - -- kind variables, so if a user declares: - -- - -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a - -- - -- then we mark both `a` and `k1` as injective. - -- NB: the return kind is considered to be *input* argument to a type family. - -- Since injectivity allows to infer input arguments from the result in theory - -- we should always mark the result kind variable (`k3` in this example) as - -- injective. The reason is that result type has always an assigned kind and - -- therefore we can always infer the result kind if we know the result type. - -- But this does not seem to be useful in any way so we don't do it. (Another - -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) - = setSrcSpan loc $ - do { let tvs = binderVars tcbs - ; dflags <- getDynFlags - ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (text "Illegal injectivity annotation" $$ - text "Use TypeFamilyDependencies to allow this") - ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds - ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars - closeOverKinds (mkVarSet inj_tvs) - ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs - ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs - , ppr inj_ktvs, ppr inj_bools ]) - ; return $ Injective inj_bools } - -tcTySynRhs :: RolesInfo -> Name - -> LHsType GhcRn -> TcM TyCon -tcTySynRhs roles_info tc_name hs_ty - = bindTyClTyVars tc_name $ \ binders res_kind -> - do { env <- getLclEnv - ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- pushTcLevelM_ $ - solveEqualities $ - tcCheckLHsType hs_ty res_kind - ; rhs_ty <- zonkTcTypeToType rhs_ty - ; let roles = roles_info tc_name - tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty - ; return tycon } - -tcDataDefn :: SDoc -> RolesInfo -> Name - -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) - -- NB: not used for newtype/data instances (whether associated or not) -tcDataDefn err_ctxt roles_info tc_name - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt - , dd_kindSig = mb_ksig -- Already in tc's kind - -- via inferInitialKinds - , dd_cons = cons - , dd_derivs = derivs }) - = bindTyClTyVars tc_name $ \ tycon_binders res_kind -> - -- The TyCon tyvars must scope over - -- - the stupid theta (dd_ctxt) - -- - for H98 constructors only, the ConDecl - -- But it does no harm to bring them into scope - -- over GADT ConDecls as well; and it's awkward not to - do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons - ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind - - ; tcg_env <- getGblEnv - ; let hsc_src = tcg_src tcg_env - ; unless (mk_permissive_kind hsc_src cons) $ - checkDataKindSig (DataDeclSort new_or_data) final_res_kind - - ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt - ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta - ; kind_signatures <- xoptM LangExt.KindSignatures - - -- Check that we don't use kind signatures without Glasgow extensions - ; when (isJust mb_ksig) $ - checkTc (kind_signatures) (badSigTyDecl tc_name) - - ; tycon <- fixM $ \ tycon -> do - { let final_bndrs = tycon_binders `chkAppend` extra_bndrs - res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) - roles = roles_info tc_name - ; data_cons <- tcConDecls - tycon - new_or_data - final_bndrs - final_res_kind - res_ty - cons - ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons - ; tc_rep_nm <- newTyConRepName tc_name - ; return (mkAlgTyCon tc_name - final_bndrs - final_res_kind - roles - (fmap unLoc cType) - stupid_theta tc_rhs - (VanillaAlgTyCon tc_rep_nm) - gadt_syntax) } - ; tctc <- tcLookupTcTyCon tc_name - -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need - -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon' - ; let deriv_info = DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = tcTyConScopedTyVars tctc - , di_clauses = unLoc derivs - , di_ctxt = err_ctxt } - ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) - ; return (tycon, [deriv_info]) } - where - -- Abstract data types in hsig files can have arbitrary kinds, - -- because they may be implemented by type synonyms - -- (which themselves can have arbitrary kinds, not just *). See #13955. - -- - -- Note that this is only a property that data type declarations possess, - -- so one could not have, say, a data family instance in an hsig file that - -- has kind `Bool`. Therefore, this check need only occur in the code that - -- typechecks data type declarations. - mk_permissive_kind HsigFile [] = True - mk_permissive_kind _ _ = False - - -- In hs-boot, a 'data' declaration with no constructors - -- indicates a nominally distinct abstract data type. - mk_tc_rhs HsBootFile _ [] - = return AbstractTyCon - - mk_tc_rhs HsigFile _ [] -- ditto - = return AbstractTyCon - - mk_tc_rhs _ tycon data_cons - = case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) -tcDataDefn _ _ _ (XHsDataDefn nec) = noExtCon nec - - -------------------------- -kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () --- Used for the equations of a closed type family only --- Not used for data/type instances -kcTyFamInstEqn tc_fam_tc - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) - = setSrcSpan loc $ - do { traceTc "kcTyFamInstEqn" (vcat - [ text "tc_name =" <+> ppr eqn_tc_name - , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) - , text "hsib_vars =" <+> ppr imp_vars - , text "feqn_bndrs =" <+> ppr mb_expl_bndrs - , text "feqn_pats =" <+> ppr hs_pats ]) - -- this check reports an arity error instead of a kind error; easier for user - ; let vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity - ; discardResult $ - bindImplicitTKBndrs_Q_Tv imp_vars $ - bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ - do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats - ; tcCheckLHsType hs_rhs_ty res_kind } - -- Why "_Tv" here? Consider (#14066 - -- type family Bar x y where - -- Bar (x :: a) (y :: b) = Int - -- Bar (x :: c) (y :: d) = Bool - -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately - } - where - vis_arity = length (tyConVisibleTyVars tc_fam_tc) - -kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec -kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec - - --------------------------- -tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn - -> TcM (KnotTied CoAxBranch) --- Needs to be here, not in TcInstDcls, because closed families --- (typechecked here) have TyFamInstEqns - -tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) - = ASSERT( getName fam_tc == eqn_tc_name ) - setSrcSpan loc $ - do { traceTc "tcTyFamInstEqn" $ - vcat [ ppr fam_tc <+> ppr hs_pats - , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) - , case mb_clsinfo of - NotAssociated -> empty - InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] - - -- First, check the arity of visible arguments - -- If we wait until validity checking, we'll get kind errors - -- below when an arity error will be much easier to understand. - ; let vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo - imp_vars (mb_expl_bndrs `orElse` []) - hs_pats hs_rhs_ty - -- Don't print results they may be knot-tied - -- (tcFamInstEqnGuts zonks to Type) - ; return (mkCoAxBranch qtvs [] [] pats rhs_ty - (map (const Nominal) qtvs) - loc) } - -tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn" - -{- -Kind check type patterns and kind annotate the embedded type variables. - type instance F [a] = rhs - - * Here we check that a type instance matches its kind signature, but we do - not check whether there is a pattern for each type index; the latter - check is only required for type synonym instances. - -Note [Instantiating a family tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible that kind-checking the result of a family tycon applied to -its patterns will instantiate the tycon further. For example, we might -have - - type family F :: k where - F = Int - F = Maybe - -After checking (F :: forall k. k) (with no visible patterns), we still need -to instantiate the k. With data family instances, this problem can be even -more intricate, due to Note [Arity of data families] in FamInstEnv. See -indexed-types/should_compile/T12369 for an example. - -So, the kind-checker must return the new skolems and args (that is, Type -or (Type -> Type) for the equations above) and the instantiated kind. - -Note [Generalising in tcTyFamInstEqnGuts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like - type instance forall (a::k) b. F t1 t2 = rhs - -Then imp_vars = [k], exp_bndrs = [a::k, b] - -We want to quantify over - * k, a, and b (all user-specified) - * and any inferred free kind vars from - - the kinds of k, a, b - - the types t1, t2 - -However, unlike a type signature like - f :: forall (a::k). blah - -we do /not/ care about the Inferred/Specified designation -or order for the final quantified tyvars. Type-family -instances are not invoked directly in Haskell source code, -so visible type application etc plays no role. - -So, the simple thing is - - gather candidates from [k, a, b] and pats - - quantify over them - -Hence the slightly mysterious call: - candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs) - -Simple, neat, but a little non-obvious! --} - --------------------------- -tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo - -> [Name] -> [LHsTyVarBndr GhcRn] -- Implicit and explicicit binder - -> HsTyPats GhcRn -- Patterns - -> LHsType GhcRn -- RHS - -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) --- Used only for type families, not data families -tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty - = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) - - -- By now, for type families (but not data families) we should - -- have checked that the number of patterns matches tyConArity - - -- This code is closely related to the code - -- in TcHsType.kcCheckDeclHeader_cusk - ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol imp_vars $ - bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ - do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats - -- Ensure that the instance is consistent with its - -- parent class (#16008) - ; addConsistencyConstraints mb_clsinfo lhs_ty - ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind - ; return (lhs_ty, rhs_ty) } - - -- See Note [Generalising in tcTyFamInstEqnGuts] - -- This code (and the stuff immediately above) is very similar - -- to that in tcDataFamInstHeader. Maybe we should abstract the - -- common code; but for the moment I concluded that it's - -- clearer to duplicate it. Still, if you fix a bug here, - -- check there too! - ; let scoped_tvs = imp_tvs ++ exp_tvs - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars dvs - - ; traceTc "tcTyFamInstEqnGuts 2" $ - vcat [ ppr fam_tc - , text "scoped_tvs" <+> pprTyVars scoped_tvs - , text "lhs_ty" <+> ppr lhs_ty - , text "dvs" <+> ppr dvs - , text "qtvs" <+> pprTyVars qtvs ] - - ; (ze, qtvs) <- zonkTyBndrs qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty - - ; let pats = unravelFamInstPats lhs_ty - -- Note that we do this after solveEqualities - -- so that any strange coercions inside lhs_ty - -- have been solved before we attempt to unravel it - ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) - ; return (qtvs, pats, rhs_ty) } - ------------------ -tcFamTyPats :: TyCon - -> HsTyPats GhcRn -- Patterns - -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) --- Used for both type and data families -tcFamTyPats fam_tc hs_pats - = do { traceTc "tcFamTyPats {" $ - vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] - - ; let fun_ty = mkTyConApp fam_tc [] - - ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- See Note [Wildcards in family instances] in - -- GHC.Rename.Source - tcInferApps typeLevelMode lhs_fun fun_ty hs_pats - - -- Hack alert: see Note [tcFamTyPats: zonking the result kind] - ; res_kind <- zonkTcType res_kind - - ; traceTc "End tcFamTyPats }" $ - vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] - - ; return (fam_app, res_kind) } - where - fam_name = tyConName fam_tc - fam_arity = tyConArity fam_tc - lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) - -{- Note [tcFamTyPats: zonking the result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#19250) - F :: forall k. k -> k - type instance F (x :: Constraint) = () - -The tricky point is this: - is that () an empty type tuple (() :: Type), or - an empty constraint tuple (() :: Constraint)? -We work this out in a hacky way, by looking at the expected kind: -see Note [Inferring tuple kinds]. - -In this case, we kind-check the RHS using the kind gotten from the LHS: -see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl. - -But we want the kind from the LHS to be /zonked/, so that when -kind-checking the RHS (tcCheckLHsType) we can "see" what we learned -from kind-checking the LHS (tcFamTyPats). In our example above, the -type of the LHS is just `kappa` (by instantiating the forall k), but -then we learn (from x::Constraint) that kappa ~ Constraint. We want -that info when kind-checking the RHS. - -Easy solution: just zonk that return kind. Of course this won't help -if there is lots of type-family reduction to do, but it works fine in -common cases. --} - -unravelFamInstPats :: TcType -> [TcType] --- Decompose fam_app to get the argument patterns --- --- We expect fam_app to look like (F t1 .. tn) --- tcInferApps is capable of returning ((F ty1 |> co) ty2), --- but that can't happen here because we already checked the --- arity of F matches the number of pattern -unravelFamInstPats fam_app - = case splitTyConApp_maybe fam_app of - Just (_, pats) -> pats - Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" - -- The Nothing case cannot happen for type families, because - -- we don't call unravelFamInstPats until we've solved the - -- equalities. For data families, it shouldn't happen either, - -- we need to fail hard and early if it does. See trac issue #15905 - -- for an example of this happening. - -addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () --- In the corresponding positions of the class and type-family, --- ensure the the family argument is the same as the class argument --- E.g class C a b c d where --- F c x y a :: Type --- Here the first arg of F should be the same as the third of C --- and the fourth arg of F should be the same as the first of C --- --- We emit /Derived/ constraints (a bit like fundeps) to encourage --- unification to happen, but without actually reporting errors. --- If, despite the efforts, corresponding positions do not match, --- checkConsistentFamInst will complain -addConsistencyConstraints mb_clsinfo fam_app - | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo - , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app - = do { let eqs = [ (cls_ty, pat) - | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats - , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] - ; traceTc "addConsistencyConstraints" (ppr eqs) - ; emitDerivedEqs AssocFamPatOrigin eqs } - -- Improve inference - -- Any mis-match is reports by checkConsistentFamInst - | otherwise - = return () - -{- Note [Constraints in patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This isn't the whole story. See comment in tcFamTyPats. - -At first glance, it seems there is a complicated story to tell in tcFamTyPats -around constraint solving. After all, type family patterns can now do -GADT pattern-matching, which is jolly complicated. But, there's a key fact -which makes this all simple: everything is at top level! There cannot -be untouchable type variables. There can't be weird interaction between -case branches. There can't be global skolems. - -This means that the semantics of type-level GADT matching is a little -different than term level. If we have - - data G a where - MkGBool :: G Bool - -And then - - type family F (a :: G k) :: k - type instance F MkGBool = True - -we get - - axF : F Bool (MkGBool ) ~ True - -Simple! No casting on the RHS, because we can affect the kind parameter -to F. - -If we ever introduce local type families, this all gets a lot more -complicated, and will end up looking awfully like term-level GADT -pattern-matching. - - -** The new story ** - -Here is really what we want: - -The matcher really can't deal with covars in arbitrary spots in coercions. -But it can deal with covars that are arguments to GADT data constructors. -So we somehow want to allow covars only in precisely those spots, then use -them as givens when checking the RHS. TODO (RAE): Implement plan. - -Note [Quantified kind variables of a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider type family KindFam (p :: k1) (q :: k1) - data T :: Maybe k1 -> k2 -> * - type instance KindFam (a :: Maybe k) b = T a b -> Int -The HsBSig for the family patterns will be ([k], [a]) - -Then in the family instance we want to - * Bring into scope [ "k" -> k:*, "a" -> a:k ] - * Kind-check the RHS - * Quantify the type instance over k and k', as well as a,b, thus - type instance [k, k', a:Maybe k, b:k'] - KindFam (Maybe k) k' a b = T k k' a b -> Int - -Notice that in the third step we quantify over all the visibly-mentioned -type variables (a,b), but also over the implicitly mentioned kind variables -(k, k'). In this case one is bound explicitly but often there will be -none. The role of the kind signature (a :: Maybe k) is to add a constraint -that 'a' must have that kind, and to bring 'k' into scope. - - - -************************************************************************ -* * - Data types -* * -************************************************************************ --} - -dataDeclChecks :: Name -> NewOrData - -> LHsContext GhcRn -> [LConDecl GhcRn] - -> TcM Bool -dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons - = do { -- Check that we don't use GADT syntax in H98 world - gadtSyntax_ok <- xoptM LangExt.GADTSyntax - ; let gadt_syntax = consUseGadtSyntax cons - ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) - - -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) - - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; empty_data_decls <- xoptM LangExt.EmptyDataDecls - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - ; return gadt_syntax } - - ------------------------------------ -consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True -consUseGadtSyntax _ = False - -- All constructors have same shape - ------------------------------------ -tcConDecls :: KnotTied TyCon -> NewOrData - -> [TyConBinder] -> TcKind -- binders and result kind of tycon - -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon] -tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl - = concatMapM $ addLocM $ - tcConDecl rep_tycon (mkTyConTagMap rep_tycon) - tmpl_bndrs res_kind res_tmpl new_or_data - -- It's important that we pay for tag allocation here, once per TyCon, - -- See Note [Constructor tag allocation], fixes #14657 - -tcConDecl :: KnotTied TyCon -- Representation tycon. Knot-tied! - -> NameEnv ConTag - -> [TyConBinder] -> TcKind -- tycon binders and result kind - -> KnotTied Type - -- Return type template (T tys), where T is the family TyCon - -> NewOrData - -> ConDecl GhcRn - -> TcM [DataCon] - -tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data - (ConDeclH98 { con_name = name - , con_ex_tvs = explicit_tkv_nms - , con_mb_cxt = hs_ctxt - , con_args = hs_args }) - = addErrCtxt (dataConCtxtName [name]) $ - do { -- NB: the tyvars from the declaration header are in scope - - -- Get hold of the existential type variables - -- e.g. data T a = forall k (b::k) f. MkT a (f b) - -- Here tmpl_bndrs = {a} - -- hs_qvars = HsQTvs { hsq_implicit = {k} - -- , hsq_explicit = {f,b} } - - ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - - ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts)) - <- pushTcLevelM_ $ - solveEqualities $ - bindExplicitTKBndrs_Skol explicit_tkv_nms $ - do { ctxt <- tcHsMbContext hs_ctxt - ; btys <- tcConArgs hs_args - ; field_lbls <- lookupConstructorFields (unLoc name) - ; let (arg_tys, stricts) = unzip btys - ; dflags <- getDynFlags - ; final_arg_tys <- - unifyNewtypeKind dflags new_or_data - (hsConDeclArgTys hs_args) - arg_tys res_kind - ; return (ctxt, final_arg_tys, field_lbls, stricts) - } - - -- exp_tvs have explicit, user-written binding sites - -- the kvs below are those kind variables entirely unmentioned by the user - -- and discovered only by generalization - - ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $ - mkSpecForAllTys exp_tvs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - unitTy) - -- That type is a lie, of course. (It shouldn't end in ()!) - -- And we could construct a proper result type from the info - -- at hand. But the result would mention only the tmpl_tvs, - -- and so it just creates more work to do it right. Really, - -- we're only doing this to find the right kind variables to - -- quantify over, and this type is fine for that purpose. - - -- Zonk to Types - ; (ze, qkvs) <- zonkTyBndrs kvs - ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) - ; let - univ_tvbs = tyConTyVarBinders tmpl_bndrs - univ_tvs = binderVars univ_tvbs - ex_tvbs = mkTyVarBinders Inferred qkvs ++ - mkTyVarBinders Specified user_qtvs - ex_tvs = qkvs ++ user_qtvs - -- For H98 datatypes, the user-written tyvar binders are precisely - -- the universals followed by the existentials. - -- See Note [DataCon user type variable binders] in DataCon. - user_tvbs = univ_tvbs ++ ex_tvbs - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixH98 name hs_args - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix rep_nm - stricts Nothing field_lbls - univ_tvs ex_tvs user_tvbs - [{- no eq_preds -}] ctxt arg_tys - res_tmpl rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr name) - ; mapM buildOneDataCon [name] - } - -tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data - -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get - -- the res_kind by typechecking the result type. - (ConDeclGADT { con_names = names - , con_qvars = qtvs - , con_mb_cxt = cxt, con_args = hs_args - , con_res_ty = hs_res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs - = addErrCtxt (dataConCtxtName names) $ - do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let (L _ name : _) = names - - ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) - <- pushTcLevelM_ $ -- We are going to generalise - solveEqualities $ -- We won't get another crack, and we don't - -- want an error cascade - bindImplicitTKBndrs_Skol implicit_tkv_nms $ - bindExplicitTKBndrs_Skol explicit_tkv_nms $ - do { ctxt <- tcHsMbContext cxt - ; btys <- tcConArgs hs_args - ; let (arg_tys, stricts) = unzip btys - ; res_ty <- tcHsOpenType hs_res_ty - -- See Note [Implementation of UnliftedNewtypes] - ; dflags <- getDynFlags - ; final_arg_tys <- - unifyNewtypeKind dflags new_or_data - (hsConDeclArgTys hs_args) - arg_tys (typeKind res_ty) - ; field_lbls <- lookupConstructorFields name - ; return (ctxt, final_arg_tys, res_ty, field_lbls, stricts) - } - ; imp_tvs <- zonkAndScopedSort imp_tvs - ; let user_tvs = imp_tvs ++ exp_tvs - - ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - res_ty) - - -- Zonk to Types - ; (ze, tkvs) <- zonkTyBndrs tkvs - ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty - - ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst) - = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty - -- NB: this is a /lazy/ binding, so we pass six thunks to - -- buildDataCon without yet forcing the guards in rejigConRes - -- See Note [Checking GADT return types] - - -- Compute the user-written tyvar binders. These have the same - -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order. - -- See Note [DataCon user type variable binders] in DataCon. - tkv_bndrs = mkTyVarBinders Inferred tkvs' - user_tv_bndrs = mkTyVarBinders Specified user_tvs' - all_user_bndrs = tkv_bndrs ++ user_tv_bndrs - - ctxt' = substTys arg_subst ctxt - arg_tys' = substTys arg_subst arg_tys - res_ty' = substTy arg_subst res_ty - - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) - ; let - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_args - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix - rep_nm - stricts Nothing field_lbls - univ_tvs ex_tvs all_user_bndrs eq_preds - ctxt' arg_tys' res_ty' rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr names) - ; mapM buildOneDataCon names - } -tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) - = noExtCon nec -tcConDecl _ _ _ _ _ _ (XConDecl nec) = noExtCon nec - -tcConIsInfixH98 :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -> TcM Bool -tcConIsInfixH98 _ details - = case details of - InfixCon {} -> return True - _ -> return False - -tcConIsInfixGADT :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -> TcM Bool -tcConIsInfixGADT con details - = case details of - InfixCon {} -> return True - RecCon {} -> return False - PrefixCon arg_tys -- See Note [Infix GADT constructors] - | isSymOcc (getOccName con) - , [_ty1,_ty2] <- arg_tys - -> do { fix_env <- getFixityEnv - ; return (con `elemNameEnv` fix_env) } - | otherwise -> return False - -tcConArgs :: HsConDeclDetails GhcRn - -> TcM [(TcType, HsSrcBang)] -tcConArgs (PrefixCon btys) - = mapM tcConArg btys -tcConArgs (InfixCon bty1 bty2) - = do { bty1' <- tcConArg bty1 - ; bty2' <- tcConArg bty2 - ; return [bty1', bty2'] } -tcConArgs (RecCon fields) - = mapM tcConArg btys - where - -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) - (unLoc fields) - explode (ns,ty) = zip ns (repeat ty) - exploded = concatMap explode combined - (_,btys) = unzip exploded - - -tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang) -tcConArg bty - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcHsOpenType (getBangType bty) - -- Newtypes can't have unboxed types, but we check - -- that in checkValidDataCon; this tcConArg stuff - -- doesn't happen for GADT-style declarations - ; traceTc "tcConArg 2" (ppr bty) - ; return (arg_ty, getBangStrictness bty) } - -{- -Note [Infix GADT constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not currently have syntax to declare an infix constructor in GADT syntax, -but it makes a (small) difference to the Show instance. So as a slightly -ad-hoc solution, we regard a GADT data constructor as infix if - a) it is an operator symbol - b) it has two arguments - c) there is a fixity declaration for it -For example: - infix 6 (:--:) - data T a where - (:--:) :: t1 -> t2 -> T Int - - -Note [Checking GADT return types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a delicacy around checking the return types of a datacon. The -central problem is dealing with a declaration like - - data T a where - MkT :: T a -> Q a - -Note that the return type of MkT is totally bogus. When creating the T -tycon, we also need to create the MkT datacon, which must have a "rejigged" -return type. That is, the MkT datacon's type must be transformed to have -a uniform return type with explicit coercions for GADT-like type parameters. -This rejigging is what rejigConRes does. The problem is, though, that checking -that the return type is appropriate is much easier when done over *Type*, -not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully -defined yet. - -So, we want to make rejigConRes lazy and then check the validity of -the return type in checkValidDataCon. To do this we /always/ return a -6-tuple from rejigConRes (so that we can compute the return type from it, which -checkValidDataCon needs), but the first three fields may be bogus if -the return type isn't valid (the last equation for rejigConRes). - -This is better than an earlier solution which reduced the number of -errors reported in one pass. See #7175, and #10836. --} - --- Example --- data instance T (b,c) where --- TI :: forall e. e -> T (e,e) --- --- The representation tycon looks like this: --- data :R7T b c where --- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 --- In this case orig_res_ty = T (e,e) - -rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. - -- data instance T [a] b c ... - -- gives template ([a,b,c], T [a] b c) - -> [TyVar] -- The constructor's inferred type variables - -> [TyVar] -- The constructor's user-written, specified - -- type variables - -> KnotTied Type -- res_ty - -> ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [TyVar], -- The constructor's rejigged, user-written, - -- inferred type variables - [TyVar], -- The constructor's rejigged, user-written, - -- specified type variables - [EqSpec], -- Equality predicates - TCvSubst) -- Substitution to apply to argument types - -- We don't check that the TyCon given in the ResTy is - -- the same as the parent tycon, because checkValidDataCon will do it --- NB: All arguments may potentially be knot-tied -rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty - -- E.g. data T [a] b c where - -- MkT :: forall x y z. T [(x,y)] z z - -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs - -- (NB: unlike the H98 case, the dc_tvs are not all existential) - -- Then we generate - -- Univ tyvars Eq-spec - -- a a~(x,y) - -- b b~z - -- z - -- Existentials are the leftover type vars: [x,y] - -- The user-written type variables are what is listed in the forall: - -- [x, y, z] (all specified). We must rejig these as well. - -- See Note [DataCon user type variable binders] in DataCon. - -- So we return ( [a,b,z], [x,y] - -- , [], [x,y,z] - -- , [a~(x,y),b~z], ) - | Just subst <- tcMatchTy res_tmpl res_ty - = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst - raw_ex_tvs = dc_tvs `minusList` univ_tvs - (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs - - -- After rejigging the existential tyvars, the resulting substitution - -- gives us exactly what we need to rejig the user-written tyvars, - -- since the dcUserTyVarBinders invariant guarantees that the - -- substitution has *all* the tyvars in its domain. - -- See Note [DataCon user type variable binders] in DataCon. - subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst) - substed_inferred_tvs = subst_user_tvs dc_inferred_tvs - substed_specified_tvs = subst_user_tvs dc_specified_tvs - - substed_eqs = map (substEqSpec arg_subst) raw_eqs - in - (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs, - substed_eqs, arg_subst) - - | otherwise - -- If the return type of the data constructor doesn't match the parent - -- type constructor, or the arity is wrong, the tcMatchTy will fail - -- e.g data T a b where - -- T1 :: Maybe a -- Wrong tycon - -- T2 :: T [a] -- Wrong arity - -- We are detect that later, in checkValidDataCon, but meanwhile - -- we must do *something*, not just crash. So we do something simple - -- albeit bogus, relying on checkValidDataCon to check the - -- bad-result-type error before seeing that the other fields look odd - -- See Note [Checking GADT return types] - = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs, - [], emptyTCvSubst) - where - dc_tvs = dc_inferred_tvs ++ dc_specified_tvs - tmpl_tvs = binderVars tmpl_bndrs - -{- Note [mkGADTVars] -~~~~~~~~~~~~~~~~~~~~ -Running example: - -data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where - MkT :: forall (x1 : *) (y :: x1) (z :: *). - T x1 * (Proxy (y :: x1), z) z - -We need the rejigged type to be - - MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). - forall (y :: x1) (z :: *). - (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) - => T x1 k2 a b - -You might naively expect that z should become a universal tyvar, -not an existential. (After all, x1 becomes a universal tyvar.) -But z has kind * while b has kind k2, so the return type - T x1 k2 a z -is ill-kinded. Another way to say it is this: the universal -tyvars must have exactly the same kinds as the tyConTyVars. - -So we need an existential tyvar and a heterogeneous equality -constraint. (The b ~ z is a bit redundant with the k2 ~ * that -comes before in that b ~ z implies k2 ~ *. I'm sure we could do -some analysis that could eliminate k2 ~ *. But we don't do this -yet.) - -The data con signature has already been fully kind-checked. -The return type - - T x1 * (Proxy (y :: x1), z) z -becomes - qtkvs = [x1 :: *, y :: x1, z :: *] - res_tmpl = T x1 * (Proxy x1 y, z) z - -We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We -know this match will succeed because of the validity check (actually done -later, but laziness saves us -- see Note [Checking GADT return types]). -Thus, we get - - subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } - -Now, we need to figure out what the GADT equalities should be. In this case, -we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a -renaming. The others should be GADT equalities. We also need to make -sure that the universally-quantified variables of the datacon match up -with the tyvars of the tycon, as required for Core context well-formedness. -(This last bit is why we have to rejig at all!) - -`choose` walks down the tycon tyvars, figuring out what to do with each one. -It carries two substitutions: - - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables - mentioned in the datacon signature. - - r_sub's domain is *result* tyvars, names written by the programmer in - the datacon signature. The final rejigged type will use these names, but - the subst is still needed because sometimes the printed name of these variables - is different. (See choose_tv_name, below.) - -Before explaining the details of `choose`, let's just look at its operation -on our example: - - choose [] [] {} {} [k1, k2, a, b] - --> -- first branch of `case` statement - choose - univs: [x1 :: *] - eq_spec: [] - t_sub: {k1 |-> x1} - r_sub: {x1 |-> x1} - t_tvs: [k2, a, b] - --> -- second branch of `case` statement - choose - univs: [k2 :: *, x1 :: *] - eq_spec: [k2 ~ *] - t_sub: {k1 |-> x1, k2 |-> k2} - r_sub: {x1 |-> x1} - t_tvs: [a, b] - --> -- second branch of `case` statement - choose - univs: [a :: k2, k2 :: *, x1 :: *] - eq_spec: [ a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} - r_sub: {x1 |-> x1} - t_tvs: [b] - --> -- second branch of `case` statement - choose - univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] - eq_spec: [ b ~ z - , a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} - r_sub: {x1 |-> x1} - t_tvs: [] - --> -- end of recursion - ( [x1 :: *, k2 :: *, a :: k2, b :: k2] - , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] - , {x1 |-> x1} ) - -`choose` looks up each tycon tyvar in the matching (it *must* be matched!). - -* If it finds a bare result tyvar (the first branch of the `case` - statement), it checks to make sure that the result tyvar isn't yet - in the list of univ_tvs. If it is in that list, then we have a - repeated variable in the return type, and we in fact need a GADT - equality. - -* It then checks to make sure that the kind of the result tyvar - matches the kind of the template tyvar. This check is what forces - `z` to be existential, as it should be, explained above. - -* Assuming no repeated variables or kind-changing, we wish to use the - variable name given in the datacon signature (that is, `x1` not - `k1`), not the tycon signature (which may have been made up by - GHC). So, we add a mapping from the tycon tyvar to the result tyvar - to t_sub. - -* If we discover that a mapping in `subst` gives us a non-tyvar (the - second branch of the `case` statement), then we have a GADT equality - to create. We create a fresh equality, but we don't extend any - substitutions. The template variable substitution is meant for use - in universal tyvar kinds, and these shouldn't be affected by any - GADT equalities. - -This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways -of simplifying it: - -1) The first branch of the `case` statement is really an optimization, used -in order to get fewer GADT equalities. It might be possible to make a GADT -equality for *every* univ. tyvar, even if the equality is trivial, and then -either deal with the bigger type or somehow reduce it later. - -2) This algorithm strives to use the names for type variables as specified -by the user in the datacon signature. If we always used the tycon tyvar -names, for example, this would be simplified. This change would almost -certainly degrade error messages a bit, though. --} - --- ^ From information about a source datacon definition, extract out --- what the universal variables and the GADT equalities should be. --- See Note [mkGADTVars]. -mkGADTVars :: [TyVar] -- ^ The tycon vars - -> [TyVar] -- ^ The datacon vars - -> TCvSubst -- ^ The matching between the template result type - -- and the actual result type - -> ( [TyVar] - , [EqSpec] - , TCvSubst ) -- ^ The univ. variables, the GADT equalities, - -- and a subst to apply to the GADT equalities - -- and existentials. -mkGADTVars tmpl_tvs dc_tvs subst - = choose [] [] empty_subst empty_subst tmpl_tvs - where - in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) - `unionInScope` getTCvInScope subst - empty_subst = mkEmptyTCvSubst in_scope - - choose :: [TyVar] -- accumulator of univ tvs, reversed - -> [EqSpec] -- accumulator of GADT equalities, reversed - -> TCvSubst -- template substitution - -> TCvSubst -- res. substitution - -> [TyVar] -- template tvs (the univ tvs passed in) - -> ( [TyVar] -- the univ_tvs - , [EqSpec] -- GADT equalities - , TCvSubst ) -- a substitution to fix kinds in ex_tvs - - choose univs eqs _t_sub r_sub [] - = (reverse univs, reverse eqs, r_sub) - choose univs eqs t_sub r_sub (t_tv:t_tvs) - | Just r_ty <- lookupTyVar subst t_tv - = case getTyVar_maybe r_ty of - Just r_tv - | not (r_tv `elem` univs) - , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) - -> -- simple, well-kinded variable substitution. - choose (r_tv:univs) eqs - (extendTvSubst t_sub t_tv r_ty') - (extendTvSubst r_sub r_tv r_ty') - t_tvs - where - r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) - r_ty' = mkTyVarTy r_tv1 - - -- Not a simple substitution: make an equality predicate - _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) - (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) - -- We've updated the kind of t_tv, - -- so add it to t_sub (#14162) - r_sub t_tvs - where - t_tv' = updateTyVarKind (substTy t_sub) t_tv - - | otherwise - = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) - - -- choose an appropriate name for a univ tyvar. - -- This *must* preserve the Unique of the result tv, so that we - -- can detect repeated variables. It prefers user-specified names - -- over system names. A result variable with a system name can - -- happen with GHC-generated implicit kind variables. - choose_tv_name :: TyVar -> TyVar -> Name - choose_tv_name r_tv t_tv - | isSystemName r_tv_name - = setNameUnique t_tv_name (getUnique r_tv_name) - - | otherwise - = r_tv_name - - where - r_tv_name = getName r_tv - t_tv_name = getName t_tv - -{- -Note [Substitution in template variables kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data G (a :: Maybe k) where - MkG :: G Nothing - -With explicit kind variables - -data G k (a :: Maybe k) where - MkG :: G k1 (Nothing k1) - -Note how k1 is distinct from k. So, when we match the template -`G k a` against `G k1 (Nothing k1)`, we get a subst -[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two -mappings, we surely don't want to add (k, k1) to the list of -GADT equalities -- that would be overly complex and would create -more untouchable variables than we need. So, when figuring out -which tyvars are GADT-like and which aren't (the fundamental -job of `choose`), we want to treat `k` as *not* GADT-like. -Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) -instead of (a :: Maybe k). This is the reason for dealing -with a substitution in here. - -However, we do not *always* want to substitute. Consider - -data H (a :: k) where - MkH :: H Int - -With explicit kind variables: - -data H k (a :: k) where - MkH :: H * Int - -Here, we have a kind-indexed GADT. The subst in question is -[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s -kind, because that would give a constructor with the type - -MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a - -The problem here is that a's kind is wrong -- it needs to be k, not *! -So, if the matching for a variable is anything but another bare variable, -we drop the mapping from the substitution before proceeding. This -was not an issue before kind-indexed GADTs because this case could -never happen. - -************************************************************************ -* * - Validity checking -* * -************************************************************************ - -Validity checking is done once the mutually-recursive knot has been -tied, so we can look at things freely. --} - -checkValidTyCl :: TyCon -> TcM [TyCon] --- The returned list is either a singleton (if valid) --- or a list of "fake tycons" (if not); the fake tycons --- include any implicits, like promoted data constructors --- See Note [Recover from validity error] -checkValidTyCl tc - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - recoverM recovery_code $ - do { traceTc "Starting validity for tycon" (ppr tc) - ; checkValidTyCon tc - ; traceTc "Done validity for tycon" (ppr tc) - ; return [tc] } - where - recovery_code -- See Note [Recover from validity error] - = do { traceTc "Aborted validity for tycon" (ppr tc) - ; return (concatMap mk_fake_tc $ - ATyCon tc : implicitTyConThings tc) } - - mk_fake_tc (ATyCon tc) - | isClassTyCon tc = [tc] -- Ugh! Note [Recover from validity error] - | otherwise = [makeRecoveryTyCon tc] - mk_fake_tc (AConLike (RealDataCon dc)) - = [makeRecoveryTyCon (promoteDataCon dc)] - mk_fake_tc _ = [] - -{- Note [Recover from validity error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We recover from a validity error in a type or class, which allows us -to report multiple validity errors. In the failure case we return a -TyCon of the right kind, but with no interesting behaviour -(makeRecoveryTyCon). Why? Suppose we have - type T a = Fun -where Fun is a type family of arity 1. The RHS is invalid, but we -want to go on checking validity of subsequent type declarations. -So we replace T with an abstract TyCon which will do no harm. -See indexed-types/should_fail/BadSock and #10896 - -Some notes: - -* We must make fakes for promoted DataCons too. Consider (#15215) - data T a = MkT ... - data S a = ...T...MkT.... - If there is an error in the definition of 'T' we add a "fake type - constructor" to the type environment, so that we can continue to - typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' - and so there was an internal error when we met 'MkT' in the body of - 'S'. - -* Painfully, we *don't* want to do this for classes. - Consider tcfail041: - class (?x::Int) => C a where ... - instance C Int - The class is invalid because of the superclass constraint. But - we still want it to look like a /class/, else the instance bleats - that the instance is mal-formed because it hasn't got a class in - the head. - - This is really bogus; now we have in scope a Class that is invalid - in some way, with unknown downstream consequences. A better - alternative might be to make a fake class TyCon. A job for another day. --} - -------------------------- --- For data types declared with record syntax, we require --- that each constructor that has a field 'f' --- (a) has the same result type --- (b) has the same type for 'f' --- module alpha conversion of the quantified type variables --- of the constructor. --- --- Note that we allow existentials to match because the --- fields can never meet. E.g --- data T where --- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T --- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T --- Here we do not complain about f1,f2 because they are existential - -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim - = return () - - | isWiredInName (getName tc) - -- validity-checking wired-in tycons is a waste of - -- time. More importantly, a wired-in tycon might - -- violate assumptions. Example: (~) has a superclass - -- mentioning (~#), which is ill-kinded in source Haskell - = traceTc "Skipping validity check for wired-in" (ppr tc) - - | otherwise - = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) - ; if | Just cl <- tyConClass_maybe tc - -> checkValidClass cl - - | Just syn_rhs <- synTyConRhs_maybe tc - -> do { checkValidType syn_ctxt syn_rhs - ; checkTySynRhs syn_ctxt syn_rhs } - - | Just fam_flav <- famTyConFlav_maybe tc - -> case fam_flav of - { ClosedSynFamilyTyCon (Just ax) - -> tcAddClosedTypeFamilyDeclCtxt tc $ - checkValidCoAxiom ax - ; ClosedSynFamilyTyCon Nothing -> return () - ; AbstractClosedSynFamilyTyCon -> - do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ - text "You may define an abstract closed type family" $$ - text "only in a .hs-boot file" } - ; DataFamilyTyCon {} -> return () - ; OpenSynFamilyTyCon -> return () - ; BuiltInSynFamTyCon _ -> return () } - - | otherwise -> do - { -- Check the context on the data decl - traceTc "cvtc1" (ppr tc) - ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) - - ; traceTc "cvtc2" (ppr tc) - - ; dflags <- getDynFlags - ; existential_ok <- xoptM LangExt.ExistentialQuantification - ; gadt_ok <- xoptM LangExt.GADTs - ; let ex_ok = existential_ok || gadt_ok - -- Data cons can have existential context - ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons - ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) - - -- Check that fields with the same name share a type - ; mapM_ check_fields groups }} - where - syn_ctxt = TySynCtxt name - name = tyConName tc - data_cons = tyConDataCons tc - - groups = equivClasses cmp_fld (concatMap get_fields data_cons) - cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2 - get_fields con = dataConFieldLabels con `zip` repeat con - -- dataConFieldLabels may return the empty list, which is fine - - -- See Note [GADT record selectors] in TcTyDecls - -- We must check (a) that the named field has the same - -- type in each constructor - -- (b) that those constructors have the same result type - -- - -- However, the constructors may have differently named type variable - -- and (worse) we don't know how the correspond to each other. E.g. - -- C1 :: forall a b. { f :: a, g :: b } -> T a b - -- C2 :: forall d c. { f :: c, g :: c } -> T c d - -- - -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's - -- result type against other candidates' types BOTH WAYS ROUND. - -- If they magically agrees, take the substitution and - -- apply them to the latter ones, and see if they match perfectly. - check_fields ((label, con1) :| other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = recoverM (return ()) $ mapM_ checkOne other_fields - -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - where - res1 = dataConOrigResTy con1 - fty1 = dataConFieldType con1 lbl - lbl = flLabel label - - checkOne (_, con2) -- Do it both ways to ensure they are structurally identical - = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 - ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } - where - res2 = dataConOrigResTy con2 - fty2 = dataConFieldType con2 lbl - -checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () --- Checks the partial record field selector, and warns. --- See Note [Checking partial record field] -checkPartialRecordField all_cons fld - = setSrcSpan loc $ - warnIfFlag Opt_WarnPartialFields - (not is_exhaustive && not (startsWithUnderscore occ_name)) - (sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr occ_name)]) - where - sel_name = flSelector fld - loc = getSrcSpan sel_name - occ_name = getOccName sel_name - - (cons_with_field, cons_without_field) = partition has_field all_cons - has_field con = fld `elem` (dataConFieldLabels con) - is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field - - con1 = ASSERT( not (null cons_with_field) ) head cons_with_field - (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1 - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs - -checkFieldCompat :: FieldLabelString -> DataCon -> DataCon - -> Type -> Type -> Type -> Type -> TcM () -checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 - = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) - ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } - where - mb_subst1 = tcMatchTy res1 res2 - mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 - -------------------------------- -checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () -checkValidDataCon dflags existential_ok tc con - = setSrcSpan (getSrcSpan con) $ - addErrCtxt (dataConCtxt con) $ - do { -- Check that the return type of the data constructor - -- matches the type constructor; eg reject this: - -- data T a where { MkT :: Bogus a } - -- It's important to do this first: - -- see Note [Checking GADT return types] - -- and c.f. Note [Check role annotations in a second pass] - let tc_tvs = tyConTyVars tc - res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) - orig_res_ty = dataConOrigResTy con - ; traceTc "checkValidDataCon" (vcat - [ ppr con, ppr tc, ppr tc_tvs - , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl) - , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) - - - ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty)) - (badDataConTyCon con res_ty_tmpl) - -- Note that checkTc aborts if it finds an error. This is - -- critical to avoid panicking when we call dataConUserType - -- on an un-rejiggable datacon! - - ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) - - -- Check that the result type is a *monotype* - -- e.g. reject this: MkT :: T (forall a. a->a) - -- Reason: it's really the argument of an equality constraint - ; checkValidMonoType orig_res_ty - - -- Check all argument types for validity - ; checkValidType ctxt (dataConUserType con) - - -- If we are dealing with a newtype, we allow levity polymorphism - -- regardless of whether or not UnliftedNewtypes is enabled. A - -- later check in checkNewDataCon handles this, producing a - -- better error message than checkForLevPoly would. - ; unless (isNewTyCon tc) - (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) - - -- Extra checks for newtype data constructors - ; when (isNewTyCon tc) (checkNewDataCon con) - - -- Check that existentials are allowed if they are used - ; checkTc (existential_ok || isVanillaDataCon con) - (badExistential con) - - -- Check that UNPACK pragmas and bangs work out - -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" - -- data T = MkT {-# UNPACK #-} !a -- Can't unpack - ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..] - - -- Check the dcUserTyVarBinders invariant - -- See Note [DataCon user type variable binders] in DataCon - -- checked here because we sometimes build invalid DataCons before - -- erroring above here - ; when debugIsOn $ - do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con - user_tvs = dataConUserTyVars con - user_tvbs_invariant - = Set.fromList (filterEqSpec eq_spec univs ++ exs) - == Set.fromList user_tvs - ; MASSERT2( user_tvbs_invariant - , vcat ([ ppr con - , ppr univs - , ppr exs - , ppr eq_spec - , ppr user_tvs ])) } - - ; traceTc "Done validity of data con" $ - vcat [ ppr con - , text "Datacon user type:" <+> ppr (dataConUserType con) - , text "Datacon rep type:" <+> ppr (dataConRepType con) - , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) - , case tyConFamInst_maybe (dataConTyCon con) of - Nothing -> text "not family" - Just (f, _) -> ppr (tyConBinders f) ] - } - where - ctxt = ConArgCtxt (dataConName con) - - check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM () - check_bang (HsSrcBang _ _ SrcLazy) _ n - | not (xopt LangExt.StrictData dflags) - = addErrTc - (bad_bang n (text "Lazy annotation (~) without StrictData")) - check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n - | isSrcUnpacked want_unpack, not is_strict - = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'")) - | isSrcUnpacked want_unpack - , case rep_bang of { HsUnpack {} -> False; _ -> True } - -- If not optimising, we don't unpack (rep_bang is never - -- HsUnpack), so don't complain! This happens, e.g., in Haddock. - -- See dataConSrcToImplBang. - , not (gopt Opt_OmitInterfacePragmas dflags) - -- When typechecking an indefinite package in Backpack, we - -- may attempt to UNPACK an abstract type. The test here will - -- conclude that this is unusable, but it might become usable - -- when we actually fill in the abstract type. As such, don't - -- warn in this case (it gives users the wrong idea about whether - -- or not UNPACK on abstract types is supported; it is!) - , unitIdIsDefinite (thisPackage dflags) - = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) - where - is_strict = case strict_mark of - NoSrcStrict -> xopt LangExt.StrictData dflags - bang -> isSrcStrict bang - - check_bang _ _ _ - = return () - - bad_bang n herald - = hang herald 2 (text "on the" <+> speakNth n - <+> text "argument of" <+> quotes (ppr con)) -------------------------------- -checkNewDataCon :: DataCon -> TcM () --- Further checks for the data constructor of a newtype -checkNewDataCon con - = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) - -- One argument - - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let allowedArgType = - unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True - ; checkTc allowedArgType $ vcat - [ text "A newtype cannot have an unlifted argument type" - , text "Perhaps you intended to use UnliftedNewtypes" - ] - - ; check_con (null eq_spec) $ - text "A newtype constructor must have a return type of form T a1 ... an" - -- Return type is (T a b c) - - ; check_con (null theta) $ - text "A newtype constructor cannot have a context in its type" - - ; check_con (null ex_tvs) $ - text "A newtype constructor cannot have existential type variables" - -- No existentials - - ; checkTc (all ok_bang (dataConSrcBangs con)) - (newtypeStrictError con) - -- No strictness annotations - } - where - (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig con - check_con what msg - = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) - - (arg_ty1 : _) = arg_tys - - ok_bang (HsSrcBang _ _ SrcStrict) = False - ok_bang (HsSrcBang _ _ SrcLazy) = False - ok_bang _ = True - -------------------------------- -checkValidClass :: Class -> TcM () -checkValidClass cls - = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods - ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses - ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses - ; fundep_classes <- xoptM LangExt.FunctionalDependencies - ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses - - -- Check that the class is unary, unless multiparameter type classes - -- are enabled; also recognize deprecated nullary type classes - -- extension (subsumed by multiparameter type classes, #8993) - ; checkTc (multi_param_type_classes || cls_arity == 1 || - (nullary_type_classes && cls_arity == 0)) - (classArityErr cls_arity cls) - ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) - - -- Check the super-classes - ; checkValidTheta (ClassSCCtxt (className cls)) theta - - -- Now check for cyclic superclasses - -- If there are superclass cycles, checkClassCycleErrs bails. - ; unless undecidable_super_classes $ - case checkClassCycles cls of - Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc err - Nothing -> return () - - -- Check the class operations. - -- But only if there have been no earlier errors - -- See Note [Abort when superclass cycle is detected] - ; whenNoErrs $ - mapM_ (check_op constrained_class_methods) op_stuff - - -- Check the associated type defaults are well-formed and instantiated - ; mapM_ check_at at_stuff } - where - (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - cls_arity = length (tyConVisibleTyVars (classTyCon cls)) - -- Ignore invisible variables - cls_tv_set = mkVarSet tyvars - - check_op constrained_class_methods (sel_id, dm) - = setSrcSpan (getSrcSpan sel_id) $ - addErrCtxt (classOpCtxt sel_id op_ty) $ do - { traceTc "class op type" (ppr op_ty) - ; checkValidType ctxt op_ty - -- This implements the ambiguity check, among other things - -- Example: tc223 - -- class Error e => Game b mv e | b -> mv e where - -- newBoard :: MonadState b m => m () - -- Here, MonadState has a fundep m->b, so newBoard is fine - - -- a method cannot be levity polymorphic, as we have to store the - -- method in a dictionary - -- example of what this prevents: - -- class BoundedX (a :: TYPE r) where minBound :: a - -- See Note [Levity polymorphism checking] in DsMonad - ; checkForLevPoly empty tau1 - - ; unless constrained_class_methods $ - mapM_ check_constraint (tail (cls_pred:op_theta)) - - ; check_dm ctxt sel_id cls_pred tau2 dm - } - where - ctxt = FunSigCtxt op_name True -- Report redundant class constraints - op_name = idName sel_id - op_ty = idType sel_id - (_,cls_pred,tau1) = tcSplitMethodTy op_ty - -- See Note [Splitting nested sigma types in class type signatures] - (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 - - check_constraint :: TcPredType -> TcM () - check_constraint pred -- See Note [Class method constraints] - = when (not (isEmptyVarSet pred_tvs) && - pred_tvs `subVarSet` cls_tv_set) - (addErrTc (badMethPred sel_id pred)) - where - pred_tvs = tyCoVarsOfType pred - - check_at (ATI fam_tc m_dflt_rhs) - = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) - (noClassTyVarErr cls fam_tc) - -- Check that the associated type mentions at least - -- one of the class type variables - -- The check is disabled for nullary type classes, - -- since there is no possible ambiguity (#10020) - - -- Check that any default declarations for associated types are valid - ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ - checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs } - where - fam_tvs = tyConTyVars fam_tc - - check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () - -- Check validity of the /top-level/ generic-default type - -- E.g for class C a where - -- default op :: forall b. (a~b) => blah - -- we do not want to do an ambiguity check on a type with - -- a free TyVar 'a' (#11608). See TcType - -- Note [TyVars and TcTyVars during type checking] in TcType - -- Hence the mkDefaultMethodType to close the type. - check_dm ctxt sel_id vanilla_cls_pred vanilla_tau - (Just (dm_name, dm_spec@(GenericDM dm_ty))) - = setSrcSpan (getSrcSpan dm_name) $ do - -- We have carefully set the SrcSpan on the generic - -- default-method Name to be that of the generic - -- default type signature - - -- First, we check that that the method's default type signature - -- aligns with the non-default type signature. - -- See Note [Default method type signatures must align] - let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls - -- Note that the second field of this tuple contains the context - -- of the default type signature, making it apparent that we - -- ignore method contexts completely when validity-checking - -- default type signatures. See the end of - -- Note [Default method type signatures must align] - -- to learn why this is OK. - -- - -- See also - -- Note [Splitting nested sigma types in class type signatures] - -- for an explanation of why we don't use tcSplitSigmaTy here. - (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty - - -- Given this class definition: - -- - -- class C a b where - -- op :: forall p q. (Ord a, D p q) - -- => a -> b -> p -> (a, b) - -- default op :: forall r s. E r - -- => a -> b -> s -> (a, b) - -- - -- We want to match up two types of the form: - -- - -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) - -- Default type sig: C a b => a -> b -> s -> (a, b) - -- - -- Notice that the two type signatures can be quantified over - -- different class type variables! Therefore, it's important that - -- we include the class predicate parts to match up a with aa and - -- b with bb. - vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau - dm_phi_ty = mkPhiTy [cls_pred] dm_tau - - traceTc "check_dm" $ vcat - [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty - , text "dm_phi_ty" <+> ppr dm_phi_ty ] - - -- Actually checking that the types align is done with a call to - -- tcMatchTys. We need to get a match in both directions to rule - -- out degenerate cases like these: - -- - -- class Foo a where - -- foo1 :: a -> b - -- default foo1 :: a -> Int - -- - -- foo2 :: a -> Int - -- default foo2 :: a -> b - unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] - [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - hang (text "The default type signature for" - <+> ppr sel_id <> colon) - 2 (ppr dm_ty) - $$ (text "does not match its corresponding" - <+> text "non-default type signature") - - -- Now do an ambiguity check on the default type signature. - checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) - check_dm _ _ _ _ _ = return () - -checkFamFlag :: Name -> TcM () --- Check that we don't use families without -XTypeFamilies --- The parser won't even parse them, but I suppose a GHC API --- client might have a go! -checkFamFlag tc_name - = do { idx_tys <- xoptM LangExt.TypeFamilies - ; checkTc idx_tys err_msg } - where - err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilies to allow indexed type families") - -checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () -checkResultSigFlag tc_name (TyVarSig _ tvb) - = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ - hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilyDependencies to allow result variable names") } -checkResultSigFlag _ _ = return () -- other cases OK - -{- Note [Class method constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Haskell 2010 is supposed to reject - class C a where - op :: Eq a => a -> a -where the method type constrains only the class variable(s). (The extension --XConstrainedClassMethods switches off this check.) But regardless -we should not reject - class C a where - op :: (?x::Int) => a -> a -as pointed out in #11793. So the test here rejects the program if - * -XConstrainedClassMethods is off - * the tyvars of the constraint are non-empty - * all the tyvars are class tyvars, none are locally quantified - -Note [Abort when superclass cycle is detected] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must avoid doing the ambiguity check for the methods (in -checkValidClass.check_op) when there are already errors accumulated. -This is because one of the errors may be a superclass cycle, and -superclass cycles cause canonicalization to loop. Here is a -representative example: - - class D a => C a where - meth :: D a => () - class C a => D a - -This fixes #9415, #9739 - -Note [Default method type signatures must align] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC enforces the invariant that a class method's default type signature -must "align" with that of the method's non-default type signature, as per -GHC #12918. For instance, if you have: - - class Foo a where - bar :: forall b. Context => a -> b - -Then a default type signature for bar must be alpha equivalent to -(forall b. a -> b). That is, the types must be the same modulo differences in -contexts. So the following would be acceptable default type signatures: - - default bar :: forall b. Context1 => a -> b - default bar :: forall x. Context2 => a -> x - -But the following are NOT acceptable default type signatures: - - default bar :: forall b. b -> a - default bar :: forall x. x - default bar :: a -> Int - -Note that a is bound by the class declaration for Foo itself, so it is -not allowed to differ in the default type signature. - -The default type signature (default bar :: a -> Int) deserves special mention, -since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To -write this, you need to declare the default type signature like so: - - default bar :: forall b. (b ~ Int). a -> b - -As noted in #12918, there are several reasons to do this: - -1. It would make no sense to have a type that was flat-out incompatible with - the non-default type signature. For instance, if you had: - - class Foo a where - bar :: a -> Int - default bar :: a -> Bool - - Then that would always fail in an instance declaration. So this check - nips such cases in the bud before they have the chance to produce - confusing error messages. - -2. Internally, GHC uses TypeApplications to instantiate the default method in - an instance. See Note [Default methods in instances] in TcInstDcls. - Thus, GHC needs to know exactly what the universally quantified type - variables are, and when instantiated that way, the default method's type - must match the expected type. - -3. Aesthetically, by only allowing the default type signature to differ in its - context, we are making it more explicit the ways in which the default type - signature is less polymorphic than the non-default type signature. - -You might be wondering: why are the contexts allowed to be different, but not -the rest of the type signature? That's because default implementations often -rely on assumptions that the more general, non-default type signatures do not. -For instance, in the Enum class declaration: - - class Enum a where - enum :: [a] - default enum :: (Generic a, GEnum (Rep a)) => [a] - enum = map to genum - - class GEnum f where - genum :: [f a] - -The default implementation for enum only works for types that are instances of -Generic, and for which their generic Rep type is an instance of GEnum. But -clearly enum doesn't _have_ to use this implementation, so naturally, the -context for enum is allowed to be different to accommodate this. As a result, -when we validity-check default type signatures, we ignore contexts completely. - -Note that when checking whether two type signatures match, we must take care to -split as many foralls as it takes to retrieve the tau types we which to check. -See Note [Splitting nested sigma types in class type signatures]. - -Note [Splitting nested sigma types in class type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this type synonym and class definition: - - type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t - - class Each s t a b where - each :: Traversal s t a b - default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b - -It might seem obvious that the tau types in both type signatures for `each` -are the same, but actually getting GHC to conclude this is surprisingly tricky. -That is because in general, the form of a class method's non-default type -signature is: - - forall a. C a => forall d. D d => E a b - -And the general form of a default type signature is: - - forall f. F f => E a f -- The variable `a` comes from the class - -So it you want to get the tau types in each type signature, you might find it -reasonable to call tcSplitSigmaTy twice on the non-default type signature, and -call it once on the default type signature. For most classes and methods, this -will work, but Each is a bit of an exceptional case. The way `each` is written, -it doesn't quantify any additional type variables besides those of the Each -class itself, so the non-default type signature for `each` is actually this: - - forall s t a b. Each s t a b => Traversal s t a b - -Notice that there _appears_ to only be one forall. But there's actually another -forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy -twice, you'll also go under the forall in Traversal! That is, you'll end up -with: - - (a -> f b) -> s -> f t - -A problem arises because you only call tcSplitSigmaTy once on the default type -signature for `each`, which gives you - - Traversal s t a b - -Or, equivalently: - - forall f. Applicative f => (a -> f b) -> s -> f t - -This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will -say that the tau types for `each` are not equal. - -A solution to this problem is to use tcSplitNestedSigmaTys instead of -tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it -sees until it can't go any further, so if you called it on the default type -signature for `each`, it would return (a -> f b) -> s -> f t like we desired. - -Note [Checking partial record field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This check checks the partial record field selector, and warns (#7169). - -For example: - - data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } - -The function 'm2' is partial record field, and will fail when it is applied to -'B'. The warning identifies such partial fields. The check is performed at the -declaration of T, not at the call-sites of m2. - -The warning can be suppressed by prefixing the field-name with an underscore. -For example: - - data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } - -************************************************************************ -* * - Checking role validity -* * -************************************************************************ --} - -checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () -checkValidRoleAnnots role_annots tc - | isTypeSynonymTyCon tc = check_no_roles - | isFamilyTyCon tc = check_no_roles - | isAlgTyCon tc = check_roles - | otherwise = return () - where - -- Role annotations are given only on *explicit* variables, - -- but a tycon stores roles for all variables. - -- So, we drop the implicit roles (which are all Nominal, anyway). - name = tyConName tc - roles = tyConRoles tc - (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ - zip roles (tyConBinders tc) - role_annot_decl_maybe = lookupRoleAnnot role_annots name - - pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) - pick_vis (role, tvb) - | isVisibleTyConBinder tvb = Just (role, binderVar tvb) - | otherwise = Nothing - - check_roles - = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> - addRoleAnnotCtxt name $ - setSrcSpan loc $ do - { role_annots_ok <- xoptM LangExt.RoleAnnotations - ; checkTc role_annots_ok $ needXRoleAnnotations tc - ; checkTc (vis_vars `equalLength` the_role_annots) - (wrongNumberOfRoles vis_vars decl) - ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles - -- Representational or phantom roles for class parameters - -- quickly lead to incoherence. So, we require - -- IncoherentInstances to have them. See #8773, #14292 - ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances - ; checkTc ( incoherent_roles_ok - || (not $ isClassTyCon tc) - || (all (== Nominal) vis_roles)) - incoherentRoles - - ; lint <- goptM Opt_DoCoreLinting - ; when lint $ checkValidRoles tc } - - check_no_roles - = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl - -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (L _ Nothing) _ = return () -checkRoleAnnot tv (L _ (Just r1)) r2 - = when (r1 /= r2) $ - addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 - --- This is a double-check on the role inference algorithm. It is only run when --- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls -checkValidRoles :: TyCon -> TcM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in CoreLint -checkValidRoles tc - | isAlgTyCon tc - -- tyConDataCons returns an empty list for data families - = mapM_ check_dc_roles (tyConDataCons tc) - | Just rhs <- synTyConRhs_maybe tc - = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs - | otherwise - = return () - where - check_dc_roles datacon - = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) - ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ arg_tys } - -- See Note [Role-checking data constructor arguments] in TcTyDecls - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - univ_roles = zipVarEnv univ_tvs (tyConRoles tc) - -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs - ex_roles = mkVarEnv (map (, Nominal) ex_tvs) - role_env = univ_roles `plusVarEnv` ex_roles - - check_ty_roles env role ty - | Just ty' <- coreView ty -- #14101 - = check_ty_roles env role ty' - - check_ty_roles env role (TyVarTy tv) - = case lookupVarEnv env tv of - Just role' -> unless (role' `ltRole` role || role' == role) $ - report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "cannot have role" <+> ppr role <+> - text "because it was assigned role" <+> ppr role' - Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "missing in environment" - - check_ty_roles env Representational (TyConApp tc tys) - = let roles' = tyConRoles tc in - zipWithM_ (maybe_check_ty_roles env) roles' tys - - check_ty_roles env Nominal (TyConApp _ tys) - = mapM_ (check_ty_roles env Nominal) tys - - check_ty_roles _ Phantom ty@(TyConApp {}) - = pprPanic "check_ty_roles" (ppr ty) - - check_ty_roles env role (AppTy ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env Nominal ty2 - - check_ty_roles env role (FunTy _ ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env role ty2 - - check_ty_roles env role (ForAllTy (Bndr tv _) ty) - = check_ty_roles env Nominal (tyVarKind tv) - >> check_ty_roles (extendVarEnv env tv Nominal) role ty - - check_ty_roles _ _ (LitTy {}) = return () - - check_ty_roles env role (CastTy t _) - = check_ty_roles env role t - - check_ty_roles _ role (CoercionTy co) - = unless (role == Phantom) $ - report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role - - maybe_check_ty_roles env role ty - = when (role == Nominal || role == Representational) $ - check_ty_roles env role ty - - report_error doc - = addErrTc $ vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] - -{- -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -addVDQNote :: TcTyCon -> TcM a -> TcM a --- See Note [Inferring visible dependent quantification] --- Only types without a signature (CUSK or SAK) here -addVDQNote tycon thing_inside - | ASSERT2( isTcTyCon tycon, ppr tycon ) - ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind ) - has_vdq - = addLandmarkErrCtxt vdq_warning thing_inside - | otherwise - = thing_inside - where - -- Check whether a tycon has visible dependent quantification. - -- This will *always* be a TcTyCon. Furthermore, it will *always* - -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. - -- Thus, all the TyConBinders will be anonymous. Thus, the - -- free variables of the tycon's kind will be the same as the free - -- variables from all the binders. - has_vdq = any is_vdq_tcb (tyConBinders tycon) - tc_kind = tyConKind tycon - kind_fvs = tyCoVarsOfType tc_kind - - is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && - isVisibleTyConBinder tcb - - vdq_warning = vcat - [ text "NB: Type" <+> quotes (ppr tycon) <+> - text "was inferred to use visible dependent quantification." - , text "Most types with visible dependent quantification are" - , text "polymorphically recursive and need a standalone kind" - , text "signature. Perhaps supply one, with StandaloneKindSignatures." - ] - -tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a -tcAddTyFamInstCtxt decl - = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) - -tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc -tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = - HsIB { hsib_body = eqn }}) - = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") - (unLoc (feqn_tycon eqn)) -tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec - -tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a -tcAddDataFamInstCtxt decl - = addErrCtxt (tcMkDataFamInstCtxt decl) - -tcMkFamInstCtxt :: SDoc -> Name -> SDoc -tcMkFamInstCtxt flavour tycon - = hsep [ text "In the" <+> flavour <+> text "declaration for" - , quotes (ppr tycon) ] - -tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a -tcAddFamInstCtxt flavour tycon thing_inside - = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside - -tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a -tcAddClosedTypeFamilyDeclCtxt tc - = addErrCtxt ctxt - where - ctxt = text "In the equations for closed type family" <+> - quotes (ppr tc) - -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc -resultTypeMisMatch field_name con1 con2 - = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "have a common field" <+> quotes (ppr field_name) <> comma], - nest 2 $ text "but have different result types"] - -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc -fieldTypeMisMatch field_name con1 con2 - = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "give different types for field", quotes (ppr field_name)] - -dataConCtxtName :: [Located Name] -> SDoc -dataConCtxtName [con] - = text "In the definition of data constructor" <+> quotes (ppr con) -dataConCtxtName con - = text "In the definition of data constructors" <+> interpp'SP con - -dataConCtxt :: Outputable a => a -> SDoc -dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) - -classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [text "When checking the class method:", - nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] - -classArityErr :: Int -> Class -> SDoc -classArityErr n cls - | n == 0 = mkErr "No" "no-parameter" - | otherwise = mkErr "Too many" "multi-parameter" - where - mkErr howMany allowWhat = - vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (text ("Enable MultiParamTypeClasses to allow " - ++ allowWhat ++ " classes"))] - -classFunDepsErr :: Class -> SDoc -classFunDepsErr cls - = vcat [text "Fundeps in class" <+> quotes (ppr cls), - parens (text "Enable FunctionalDependencies to allow fundeps")] - -badMethPred :: Id -> TcPredType -> SDoc -badMethPred sel_id pred - = vcat [ hang (text "Constraint" <+> quotes (ppr pred) - <+> text "in the type of" <+> quotes (ppr sel_id)) - 2 (text "constrains only the class type variables") - , text "Enable ConstrainedClassMethods to allow it" ] - -noClassTyVarErr :: Class -> TyCon -> SDoc -noClassTyVarErr clas fam_tc - = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) - , text "mentions none of the type or kind variables of the class" <+> - quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] - -badDataConTyCon :: DataCon -> Type -> SDoc -badDataConTyCon data_con res_ty_tmpl - | ASSERT( all isTyVar tvs ) - tcIsForAllTy actual_res_ty - = nested_foralls_contexts_suggestion - | isJust (tcSplitPredFunTy_maybe actual_res_ty) - = nested_foralls_contexts_suggestion - | otherwise - = hang (text "Data constructor" <+> quotes (ppr data_con) <+> - text "returns type" <+> quotes (ppr actual_res_ty)) - 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) - where - actual_res_ty = dataConOrigResTy data_con - - -- This suggestion is useful for suggesting how to correct code like what - -- was reported in #12087: - -- - -- data F a where - -- MkF :: Ord a => Eq a => a -> F a - -- - -- Although nested foralls or contexts are allowed in function type - -- signatures, it is much more difficult to engineer GADT constructor type - -- signatures to allow something similar, so we error in the latter case. - -- Nevertheless, we can at least suggest how a user might reshuffle their - -- exotic GADT constructor type signature so that GHC will accept. - nested_foralls_contexts_suggestion = - text "GADT constructor type signature cannot contain nested" - <+> quotes forAllLit <> text "s or contexts" - $+$ hang (text "Suggestion: instead use this type signature:") - 2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty) - - -- To construct a type that GHC would accept (suggested_ty), we: - -- - -- 1) Find the existentially quantified type variables and the class - -- predicates from the datacon. (NB: We don't need the universally - -- quantified type variables, since rejigConRes won't substitute them in - -- the result type if it fails, as in this scenario.) - -- 2) Split apart the return type (which is headed by a forall or a - -- context) using tcSplitNestedSigmaTys, collecting the type variables - -- and class predicates we find, as well as the rho type lurking - -- underneath the nested foralls and contexts. - -- 3) Smash together the type variables and class predicates from 1) and - -- 2), and prepend them to the rho type from 2). - (tvs, theta, rho) = tcSplitNestedSigmaTys (dataConUserType data_con) - suggested_ty = mkSpecSigmaTy tvs theta rho - -badGadtDecl :: Name -> SDoc -badGadtDecl tc_name - = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) - , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] - -badExistential :: DataCon -> SDoc -badExistential con - = hang (text "Data constructor" <+> quotes (ppr con) <+> - text "has existential type variables, a context, or a specialised result type") - 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) - , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]) - -badStupidTheta :: Name -> SDoc -badStupidTheta tc_name - = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) - -newtypeConError :: Name -> Int -> SDoc -newtypeConError tycon n - = sep [text "A newtype must have exactly one constructor,", - nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] - -newtypeStrictError :: DataCon -> SDoc -newtypeStrictError con - = sep [text "A newtype constructor cannot have a strictness annotation,", - nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] - -newtypeFieldErr :: DataCon -> Int -> SDoc -newtypeFieldErr con_name n_flds - = sep [text "The constructor of a newtype must have exactly one field", - nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] - -badSigTyDecl :: Name -> SDoc -badSigTyDecl tc_name - = vcat [ text "Illegal kind signature" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] - -emptyConDeclsErr :: Name -> SDoc -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> text "has no constructors", - nest 2 $ text "(EmptyDataDecls permits this)"] - -wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family - = text "Wrong category of family instance; declaration was for a" - <+> kindOfFamily - where - kindOfFamily | isTypeFamilyTyCon family = text "type family" - | isDataFamilyTyCon family = text "data family" - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - --- | Produce an error for oversaturated type family equations with too many --- required arguments. --- See Note [Oversaturated type family equations] in TcValidity. -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr max_args - = text "Number of parameters must match family declaration; expected" - <+> ppr max_args - -badRoleAnnot :: Name -> Role -> Role -> SDoc -badRoleAnnot var annot inferred - = hang (text "Role mismatch on variable" <+> ppr var <> colon) - 2 (sep [ text "Annotation says", ppr annot - , text "but role", ppr inferred - , text "is required" ]) - -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = hang (text "Wrong number of roles listed in role annotation;" $$ - text "Expected" <+> (ppr $ length tyvars) <> comma <+> - text "got" <+> (ppr $ length annots) <> colon) - 2 (ppr d) -wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec - - -illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) - = setErrCtxt [] $ - setSrcSpan loc $ - addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec - -needXRoleAnnotations :: TyCon -> SDoc -needXRoleAnnotations tc - = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ - text "did you intend to use RoleAnnotations?" - -incoherentRoles :: SDoc -incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") - -addTyConCtxt :: TyCon -> TcM a -> TcM a -addTyConCtxt tc = addTyConFlavCtxt name flav - where - name = getName tc - flav = tyConFlavour tc - -addRoleAnnotCtxt :: Name -> TcM a -> TcM a -addRoleAnnotCtxt name - = addErrCtxt $ - text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/typecheck/TcTyDecls.hs b/typecheck/TcTyDecls.hs deleted file mode 100644 --- a/typecheck/TcTyDecls.hs +++ /dev/null @@ -1,1031 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 - - -Analysis functions over data types. Specifically, detecting recursive types. - -This stuff is only used for source-code decls; it's recorded in interface -files for imported data types. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcTyDecls( - RolesInfo, - inferRoles, - checkSynCycles, - checkClassCycles, - - -- * Implicits - addTyConsToGblEnv, mkDefaultMethodType, - - -- * Record selectors - tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import TcEnv -import TcBinds( tcValBinds ) -import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) -import TcType -import Predicate -import TysWiredIn( unitTy ) -import MkCore( rEC_SEL_ERROR_ID ) -import GHC.Hs -import Class -import Type -import HscTypes -import TyCon -import ConLike -import DataCon -import Name -import NameEnv -import NameSet hiding (unitFV) -import RdrName ( mkVarUnqual ) -import Id -import IdInfo -import VarEnv -import VarSet -import Coercion ( ltRole ) -import BasicTypes -import SrcLoc -import Unique ( mkBuiltinUnique ) -import Outputable -import Util -import Maybes -import Bag -import FastString -import FV -import Module - -import Control.Monad - -{- -************************************************************************ -* * - Cycles in type synonym declarations -* * -************************************************************************ --} - -synonymTyConsOfType :: Type -> [TyCon] --- Does not look through type synonyms at all --- Return a list of synonym tycons --- Keep this synchronized with 'expandTypeSynonyms' -synonymTyConsOfType ty - = nameEnvElts (go ty) - where - go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim - go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys - go (LitTy _) = emptyNameEnv - go (TyVarTy _) = emptyNameEnv - go (AppTy a b) = go a `plusNameEnv` go b - go (FunTy _ a b) = go a `plusNameEnv` go b - go (ForAllTy _ ty) = go ty - go (CastTy ty co) = go ty `plusNameEnv` go_co co - go (CoercionTy co) = go_co co - - -- Note [TyCon cycles through coercions?!] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Although, in principle, it's possible for a type synonym loop - -- could go through a coercion (since a coercion can refer to - -- a TyCon or Type), it doesn't seem possible to actually construct - -- a Haskell program which tickles this case. Here is an example - -- program which causes a coercion: - -- - -- type family Star where - -- Star = Type - -- - -- data T :: Star -> Type - -- data S :: forall (a :: Type). T a -> Type - -- - -- Here, the application 'T a' must first coerce a :: Type to a :: Star, - -- witnessed by the type family. But if we now try to make Type refer - -- to a type synonym which in turn refers to Star, we'll run into - -- trouble: we're trying to define and use the type constructor - -- in the same recursive group. Possibly this restriction will be - -- lifted in the future but for now, this code is "just for completeness - -- sake". - go_mco MRefl = emptyNameEnv - go_mco (MCo co) = go_co co - - go_co (Refl ty) = go ty - go_co (GRefl _ ty mco) = go ty `plusNameEnv` go_mco mco - go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs - go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' - go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (FunCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (CoVarCo _) = emptyNameEnv - go_co (HoleCo {}) = emptyNameEnv - go_co (AxiomInstCo _ _ cs) = go_co_s cs - go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' - go_co (SymCo co) = go_co co - go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' - go_co (NthCo _ _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_co_s cs - - go_prov UnsafeCoerceProv = emptyNameEnv - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyNameEnv - - go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc - | otherwise = emptyNameEnv - go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys - go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos - --- | A monad for type synonym cycle checking, which keeps --- track of the TyCons which are known to be acyclic, or --- a failure message reporting that a cycle was found. -newtype SynCycleM a = SynCycleM { - runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } - deriving (Functor) - -type SynCycleState = NameSet - -instance Applicative SynCycleM where - pure x = SynCycleM $ \state -> Right (x, state) - (<*>) = ap - -instance Monad SynCycleM where - m >>= f = SynCycleM $ \state -> - case runSynCycleM m state of - Right (x, state') -> - runSynCycleM (f x) state' - Left err -> Left err - -failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () -failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) - --- | Test if a 'Name' is acyclic, short-circuiting if we've --- seen it already. -checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM () -checkNameIsAcyclic n m = SynCycleM $ \s -> - if n `elemNameSet` s - then Right ((), s) -- short circuit - else case runSynCycleM m s of - Right ((), s') -> Right ((), extendNameSet s' n) - Left err -> Left err - --- | Checks if any of the passed in 'TyCon's have cycles. --- Takes the 'UnitId' of the home package (as we can avoid --- checking those TyCons: cycles never go through foreign packages) and --- the corresponding @LTyClDecl Name@ for each 'TyCon', so we --- can give better error messages. -checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () -checkSynCycles this_uid tcs tyclds = do - case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc err - Right _ -> return () - where - -- Try our best to print the LTyClDecl for locally defined things - lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds) - - -- Short circuit if we've already seen this Name and concluded - -- it was acyclic. - go :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go so_far seen_tcs tc = - checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc - - -- Expand type synonyms, complaining if you find the same - -- type synonym a second time. - go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go' so_far seen_tcs tc - | n `elemNameSet` so_far - = failSynCycleM (getSrcSpan (head seen_tcs)) $ - sep [ text "Cycle in type synonym declarations:" - , nest 2 (vcat (map ppr_decl seen_tcs)) ] - -- Optimization: we don't allow cycles through external packages, - -- so once we find a non-local name we are guaranteed to not - -- have a cycle. - -- - -- This won't hold once we get recursive packages with Backpack, - -- but for now it's fine. - | not (isHoleModule mod || - moduleUnitId mod == this_uid || - isInteractiveModule mod) - = return () - | Just ty <- synTyConRhs_maybe tc = - go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty - | otherwise = return () - where - n = tyConName tc - mod = nameModule n - ppr_decl tc = - case lookupNameEnv lcl_decls n of - Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n - <+> text "from external module" - where - n = tyConName tc - - go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM () - go_ty so_far seen_tcs ty = - mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) - -{- Note [Superclass cycle check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The superclass cycle check for C decides if we can statically -guarantee that expanding C's superclass cycles transitively is -guaranteed to terminate. This is a Haskell98 requirement, -but one that we lift with -XUndecidableSuperClasses. - -The worry is that a superclass cycle could make the type checker loop. -More precisely, with a constraint (Given or Wanted) - C ty1 .. tyn -one approach is to instantiate all of C's superclasses, transitively. -We can only do so if that set is finite. - -This potential loop occurs only through superclasses. This, for -example, is fine - class C a where - op :: C b => a -> b -> b -even though C's full definition uses C. - -Making the check static also makes it conservative. Eg - type family F a - class F a => C a -Here an instance of (F a) might mention C: - type instance F [a] = C a -and now we'd have a loop. - -The static check works like this, starting with C - * Look at C's superclass predicates - * If any is a type-function application, - or is headed by a type variable, fail - * If any has C at the head, fail - * If any has a type class D at the head, - make the same test with D - -A tricky point is: what if there is a type variable at the head? -Consider this: - class f (C f) => C f - class c => Id c -and now expand superclasses for constraint (C Id): - C Id - --> Id (C Id) - --> C Id - --> .... -Each step expands superclasses one layer, and clearly does not terminate. --} - -checkClassCycles :: Class -> Maybe SDoc --- Nothing <=> ok --- Just err <=> possible cycle error -checkClassCycles cls - = do { (definite_cycle, err) <- go (unitNameSet (getName cls)) - cls (mkTyVarTys (classTyVars cls)) - ; let herald | definite_cycle = text "Superclass cycle for" - | otherwise = text "Potential superclass cycle for" - ; return (vcat [ herald <+> quotes (ppr cls) - , nest 2 err, hint]) } - where - hint = text "Use UndecidableSuperClasses to accept this" - - -- Expand superclasses starting with (C a b), complaining - -- if you find the same class a second time, or a type function - -- or predicate headed by a type variable - -- - -- NB: this code duplicates TcType.transSuperClasses, but - -- with more error message generation clobber - -- Make sure the two stay in sync. - go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go so_far cls tys = firstJusts $ - map (go_pred so_far) $ - immSuperClasses cls tys - - go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc) - -- Nothing <=> ok - -- Just (True, err) <=> definite cycle - -- Just (False, err) <=> possible cycle - go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms - | Just (tc, tys) <- tcSplitTyConApp_maybe pred - = go_tc so_far pred tc tys - | hasTyVarHead pred - = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") - 2 (quotes (ppr pred))) - | otherwise - = Nothing - - go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) - go_tc so_far pred tc tys - | isFamilyTyCon tc - = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") - 2 (quotes (ppr pred))) - | Just cls <- tyConClass_maybe tc - = go_cls so_far cls tys - | otherwise -- Equality predicate, for example - = Nothing - - go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go_cls so_far cls tys - | cls_nm `elemNameSet` so_far - = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) - | isCTupleClass cls - = go so_far cls tys - | otherwise - = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys - ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) - $$ err) } - where - cls_nm = getName cls - -{- -************************************************************************ -* * - Role inference -* * -************************************************************************ - -Note [Role inference] -~~~~~~~~~~~~~~~~~~~~~ -The role inference algorithm datatype definitions to infer the roles on the -parameters. Although these roles are stored in the tycons, we can perform this -algorithm on the built tycons, as long as we don't peek at an as-yet-unknown -roles field! Ah, the magic of laziness. - -First, we choose appropriate initial roles. For families and classes, roles -(including initial roles) are N. For datatypes, we start with the role in the -role annotation (if any), or otherwise use Phantom. This is done in -initialRoleEnv1. - -The function irGroup then propagates role information until it reaches a -fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a -monad RoleM, which is a combination reader and state monad. In its state are -the current RoleEnv, which gets updated by role propagation, and an update -bit, which we use to know whether or not we've reached the fixpoint. The -environment of RoleM contains the tycon whose parameters we are inferring, and -a VarEnv from parameters to their positions, so we can update the RoleEnv. -Between tycons, this reader information is missing; it is added by -addRoleInferenceInfo. - -There are two kinds of tycons to consider: algebraic ones (excluding classes) -and type synonyms. (Remember, families don't participate -- all their parameters -are N.) An algebraic tycon processes each of its datacons, in turn. Note that -a datacon's universally quantified parameters might be different from the parent -tycon's parameters, so we use the datacon's univ parameters in the mapping from -vars to positions. Note also that we don't want to infer roles for existentials -(they're all at N, too), so we put them in the set of local variables. As an -optimisation, we skip any tycons whose roles are already all Nominal, as there -nowhere else for them to go. For synonyms, we just analyse their right-hand sides. - -irType walks through a type, looking for uses of a variable of interest and -propagating role information. Because anything used under a phantom position -is at phantom and anything used under a nominal position is at nominal, the -irType function can assume that anything it sees is at representational. (The -other possibilities are pruned when they're encountered.) - -The rest of the code is just plumbing. - -How do we know that this algorithm is correct? It should meet the following -specification: - -Let Z be a role context -- a mapping from variables to roles. The following -rules define the property (Z |- t : r), where t is a type and r is a role: - -Z(a) = r' r' <= r -------------------------- RCVar -Z |- a : r - ----------- RCConst -Z |- T : r -- T is a type constructor - -Z |- t1 : r -Z |- t2 : N --------------- RCApp -Z |- t1 t2 : r - -forall i<=n. (r_i is R or N) implies Z |- t_i : r_i -roles(T) = r_1 .. r_n ----------------------------------------------------- RCDApp -Z |- T t_1 .. t_n : R - -Z, a:N |- t : r ----------------------- RCAll -Z |- forall a:k.t : r - - -We also have the following rules: - -For all datacon_i in type T, where a_1 .. a_n are universally quantified -and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, -then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, -then roles(T) = r_1 .. r_n - -roles(->) = R, R -roles(~#) = N, N - -With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, -called from checkValidTycon. - -Note [Role-checking data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - MkT :: Eq b => F a -> (a->a) -> T (G a) - -Then we want to check the roles at which 'a' is used -in MkT's type. We want to work on the user-written type, -so we need to take into account - * the arguments: (F a) and (a->a) - * the context: C a b - * the result type: (G a) -- this is in the eq_spec - - -Note [Coercions in role inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing -the kind of a type is totally irrelevant to the representation of that type. So, -we want to totally ignore coercions when doing role inference. This includes omitting -any type variables that appear in nominal positions but only within coercions. --} - -type RolesInfo = Name -> [Role] - -type RoleEnv = NameEnv [Role] -- from tycon names to roles - --- This, and any of the functions it calls, must *not* look at the roles --- field of a tycon we are inferring roles about! --- See Note [Role inference] -inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role] -inferRoles hsc_src annots tycons - = let role_env = initialRoleEnv hsc_src annots tycons - role_env' = irGroup role_env tycons in - \name -> case lookupNameEnv role_env' name of - Just roles -> roles - Nothing -> pprPanic "inferRoles" (ppr name) - -initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv -initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv . - map (initialRoleEnv1 hsc_src annots) - -initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role]) -initialRoleEnv1 hsc_src annots_env tc - | isFamilyTyCon tc = (name, map (const Nominal) bndrs) - | isAlgTyCon tc = (name, default_roles) - | isTypeSynonymTyCon tc = (name, default_roles) - | otherwise = pprPanic "initialRoleEnv1" (ppr tc) - where name = tyConName tc - bndrs = tyConBinders tc - argflags = map tyConBinderArgFlag bndrs - num_exps = count isVisibleArgFlag argflags - - -- if the number of annotations in the role annotation decl - -- is wrong, just ignore it. We check this in the validity check. - role_annots - = case lookupRoleAnnot annots_env name of - Just (dL->L _ (RoleAnnotDecl _ _ annots)) - | annots `lengthIs` num_exps -> map unLoc annots - _ -> replicate num_exps Nothing - default_roles = build_default_roles argflags role_annots - - build_default_roles (argf : argfs) (m_annot : ras) - | isVisibleArgFlag argf - = (m_annot `orElse` default_role) : build_default_roles argfs ras - build_default_roles (_argf : argfs) ras - = Nominal : build_default_roles argfs ras - build_default_roles [] [] = [] - build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" - (vcat [ppr tc, ppr role_annots]) - - default_role - | isClassTyCon tc = Nominal - -- Note [Default roles for abstract TyCons in hs-boot/hsig] - | HsBootFile <- hsc_src - , isAbstractTyCon tc = Representational - | HsigFile <- hsc_src - , isAbstractTyCon tc = Nominal - | otherwise = Phantom - --- Note [Default roles for abstract TyCons in hs-boot/hsig] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- What should the default role for an abstract TyCon be? --- --- Originally, we inferred phantom role for abstract TyCons --- in hs-boot files, because the type variables were never used. --- --- This was silly, because the role of the abstract TyCon --- was required to match the implementation, and the roles of --- data types are almost never phantom. Thus, in ticket #9204, --- the default was changed so be representational (the most common case). If --- the implementing data type was actually nominal, you'd get an easy --- to understand error, and add the role annotation yourself. --- --- Then Backpack was added, and with it we added role *subtyping* --- the matching judgment: if an abstract TyCon has a nominal --- parameter, it's OK to implement it with a representational --- parameter. But now, the representational default is not a good --- one, because you should *only* request representational if --- you're planning to do coercions. To be maximally flexible --- with what data types you will accept, you want the default --- for hsig files is nominal. We don't allow role subtyping --- with hs-boot files (it's good practice to give an exactly --- accurate role here, because any types that use the abstract --- type will propagate the role information.) - -irGroup :: RoleEnv -> [TyCon] -> RoleEnv -irGroup env tcs - = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in - if update - then irGroup env' tcs - else env' - -irTyCon :: TyCon -> RoleM () -irTyCon tc - | isAlgTyCon tc - = do { old_roles <- lookupRoles tc - ; unless (all (== Nominal) old_roles) $ -- also catches data families, - -- which don't want or need role inference - irTcTyVars tc $ - do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 - ; whenIsJust (tyConClass_maybe tc) irClass - ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} - - | Just ty <- synTyConRhs_maybe tc - = irTcTyVars tc $ - irType emptyVarSet ty - - | otherwise - = return () - --- any type variable used in an associated type must be Nominal -irClass :: Class -> RoleM () -irClass cls - = mapM_ ir_at (classATs cls) - where - cls_tvs = classTyVars cls - cls_tv_set = mkVarSet cls_tvs - - ir_at at_tc - = mapM_ (updateRole Nominal) nvars - where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc - --- See Note [Role inference] -irDataCon :: DataCon -> RoleM () -irDataCon datacon - = setRoleInferenceVars univ_tvs $ - irExTyVars ex_tvs $ \ ex_var_set -> - mapM_ (irType ex_var_set) - (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys) - -- See Note [Role-checking data constructor arguments] - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - -irType :: VarSet -> Type -> RoleM () -irType = go - where - go lcls ty | Just ty' <- coreView ty -- #14101 - = go lcls ty' - go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ - updateRole Representational tv - go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 - go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc - ; zipWithM_ (go_app lcls) roles tys } - go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb - lcls' = extendVarSet lcls tv - ; markNominal lcls (tyVarKind tv) - ; go lcls' ty } - go lcls (FunTy _ arg res) = go lcls arg >> go lcls res - go _ (LitTy {}) = return () - -- See Note [Coercions in role inference] - go lcls (CastTy ty _) = go lcls ty - go _ (CoercionTy _) = return () - - go_app _ Phantom _ = return () -- nothing to do here - go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N - go_app lcls Representational ty = go lcls ty - -irTcTyVars :: TyCon -> RoleM a -> RoleM a -irTcTyVars tc thing - = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) - where - go [] = thing - go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) - ; addRoleInferenceVar tv $ go tvs } - -irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a -irExTyVars orig_tvs thing = go emptyVarSet orig_tvs - where - go lcls [] = thing lcls - go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) - ; go (extendVarSet lcls tv) tvs } - -markNominal :: TyVarSet -- local variables - -> Type -> RoleM () -markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in - mapM_ (updateRole Nominal) nvars - where - -- get_ty_vars gets all the tyvars (no covars!) from a type *without* - -- recurring into coercions. Recall: coercions are totally ignored during - -- role inference. See [Coercions in role inference] - get_ty_vars :: Type -> FV - get_ty_vars (TyVarTy tv) = unitFV tv - get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (FunTy _ t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys - get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) - get_ty_vars (LitTy {}) = emptyFV - get_ty_vars (CastTy ty _) = get_ty_vars ty - get_ty_vars (CoercionTy _) = emptyFV - --- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps -lookupRolesX :: TyCon -> RoleM [Role] -lookupRolesX tc - = do { roles <- lookupRoles tc - ; return $ roles ++ repeat Nominal } - --- gets the roles either from the environment or the tycon -lookupRoles :: TyCon -> RoleM [Role] -lookupRoles tc - = do { env <- getRoleEnv - ; case lookupNameEnv env (tyConName tc) of - Just roles -> return roles - Nothing -> return $ tyConRoles tc } - --- tries to update a role; won't ever update a role "downwards" -updateRole :: Role -> TyVar -> RoleM () -updateRole role tv - = do { var_ns <- getVarNs - ; name <- getTyConName - ; case lookupVarEnv var_ns tv of - Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) - Just n -> updateRoleEnv name n role } - --- the state in the RoleM monad -data RoleInferenceState = RIS { role_env :: RoleEnv - , update :: Bool } - --- the environment in the RoleM monad -type VarPositions = VarEnv Int - --- See [Role inference] -newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon - -> VarPositions - -> Int -- size of VarPositions - -> RoleInferenceState - -> (a, RoleInferenceState) } - deriving (Functor) - -instance Applicative RoleM where - pure x = RM $ \_ _ _ state -> (x, state) - (<*>) = ap - -instance Monad RoleM where - a >>= f = RM $ \m_info vps nvps state -> - let (a', state') = unRM a m_info vps nvps state in - unRM (f a') m_info vps nvps state' - -runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) -runRoleM env thing = (env', update) - where RIS { role_env = env', update = update } - = snd $ unRM thing Nothing emptyVarEnv 0 state - state = RIS { role_env = env - , update = False } - -setRoleInferenceTc :: Name -> RoleM a -> RoleM a -setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> - ASSERT( isNothing m_name ) - ASSERT( isEmptyVarEnv vps ) - ASSERT( nvps == 0 ) - unRM thing (Just name) vps nvps state - -addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a -addRoleInferenceVar tv thing - = RM $ \m_name vps nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state - -setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a -setRoleInferenceVars tvs thing - = RM $ \m_name _vps _nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") - state - -getRoleEnv :: RoleM RoleEnv -getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) - -getVarNs :: RoleM VarPositions -getVarNs = RM $ \_ vps _ state -> (vps, state) - -getTyConName :: RoleM Name -getTyConName = RM $ \m_name _ _ state -> - case m_name of - Nothing -> panic "getTyConName" - Just name -> (name, state) - -updateRoleEnv :: Name -> Int -> Role -> RoleM () -updateRoleEnv name n role - = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), - case lookupNameEnv role_env name of - Nothing -> pprPanic "updateRoleEnv" (ppr name) - Just roles -> let (before, old_role : after) = splitAt n roles in - if role `ltRole` old_role - then let roles' = before ++ role : after - role_env' = extendNameEnv role_env name roles' in - RIS { role_env = role_env', update = True } - else state ) - - -{- ********************************************************************* -* * - Building implicits -* * -********************************************************************* -} - -addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv --- Given a [TyCon], add to the TcGblEnv --- * extend the TypeEnv with the tycons --- * extend the TypeEnv with their implicitTyThings --- * extend the TypeEnv with any default method Ids --- * add bindings for record selectors -addTyConsToGblEnv tyclss - = tcExtendTyConEnv tyclss $ - tcExtendGlobalEnvImplicit implicit_things $ - tcExtendGlobalValEnv def_meth_ids $ - do { traceTc "tcAddTyCons" $ vcat - [ text "tycons" <+> ppr tyclss - , text "implicits" <+> ppr implicit_things ] - ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) - ; return gbl_env } - where - implicit_things = concatMap implicitTyConThings tyclss - def_meth_ids = mkDefaultMethodIds tyclss - -mkDefaultMethodIds :: [TyCon] -> [Id] --- We want to put the default-method Ids (both vanilla and generic) --- into the type environment so that they are found when we typecheck --- the filled-in default methods of each instance declaration --- See Note [Default method Ids and Template Haskell] -mkDefaultMethodIds tycons - = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec) - | tc <- tycons - , Just cls <- [tyConClass_maybe tc] - , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] - -mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type --- Returns the top-level type of the default method -mkDefaultMethodType _ sel_id VanillaDM = idType sel_id -mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty - where - pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) - cls_bndrs = tyConBinders (classTyCon cls) - tv_bndrs = tyConTyVarBinders cls_bndrs - -- NB: the Class doesn't have TyConBinders; we reach into its - -- TyCon to get those. We /do/ need the TyConBinders because - -- we need the correct visibility: these default methods are - -- used in code generated by the fill-in for missing - -- methods in instances (TcInstDcls.mkDefMethBind), and - -- then typechecked. So we need the right visibilty info - -- (#13998) - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -{- -Note [Default method Ids and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#4169): - class Numeric a where - fromIntegerNum :: a - fromIntegerNum = ... - - ast :: Q [Dec] - ast = [d| instance Numeric Int |] - -When we typecheck 'ast' we have done the first pass over the class decl -(in tcTyClDecls), but we have not yet typechecked the default-method -declarations (because they can mention value declarations). So we -must bring the default method Ids into scope first (so they can be seen -when typechecking the [d| .. |] quote, and typecheck them later. --} - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv -tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $ - do { (rec_sel_binds, tcg_env) <- discardWarnings $ - tcValBinds TopLevel binds sigs getGblEnv - ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } - where - sigs = [ cL loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs - , let loc = getSrcSpan sel_id ] - binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] - -mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] --- NB We produce *un-typechecked* bindings, rather like 'deriving' --- This makes life easier, because the later type checking will add --- all necessary type abstractions and applications -mkRecSelBinds tycons - = map mkRecSelBind [ (tc,fld) | tc <- tycons - , fld <- tyConFieldLabels tc ] - -mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) -mkRecSelBind (tycon, fl) - = mkOneRecordSelector all_cons (RecSelData tycon) fl - where - all_cons = map RealDataCon (tyConDataCons tycon) - -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (Id, LHsBind GhcRn) -mkOneRecordSelector all_cons idDetails fl - = (sel_id, cL loc sel_bind) - where - loc = getSrcSpan sel_name - lbl = flLabel fl - sel_name = flSelector fl - - sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } - - -- Find a representative constructor, con1 - cons_w_field = conLikesWithFields all_cons [lbl] - con1 = ASSERT( not (null cons_w_field) ) head cons_w_field - - -- Selector type; Note [Polymorphic selectors] - field_ty = conLikeFieldType con1 lbl - data_tvs = tyCoVarsOfTypesWellScoped inst_tys - data_tv_set= mkVarSet data_tvs - is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) - (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty - sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkSpecForAllTys data_tvs $ - mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! - mkVisFunTy data_ty $ - mkSpecForAllTys field_tvs $ - mkPhiTy field_theta $ - -- req_theta is empty for normal DataCon - mkPhiTy req_theta $ - field_tau - - -- Make the binding: sel (C2 { fld = x }) = x - -- sel (C7 { fld = x }) = x - -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind Generated sel_lname alts - where - alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) - [] unit_rhs] - | otherwise = map mk_match cons_w_field ++ deflt - mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [cL loc (mk_sel_pat con)] - (cL loc (HsVar noExtField (cL loc field_var))) - mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields) - rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField - { hsRecFieldLbl - = cL loc (FieldOcc sel_name - (cL loc $ mkVarUnqual lbl)) - , hsRecFieldArg - = cL loc (VarPat noExtField (cL loc field_var)) - , hsRecPun = False }) - sel_lname = cL loc sel_name - field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc - - -- Add catch-all default case unless the case is exhaustive - -- We do this explicitly so that we get a nice error message that - -- mentions this particular record selector - deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch CaseAlt - [cL loc (WildPat noExtField)] - (mkHsApp (cL loc (HsVar noExtField - (cL loc (getName rEC_SEL_ERROR_ID)))) - (cL loc (HsLit noExtField msg_lit)))] - - -- Do not add a default case unless there are unmatched - -- constructors. We must take account of GADTs, else we - -- get overlap warning messages from the pattern-match checker - -- NB: we need to pass type args for the *representation* TyCon - -- to dataConCannotMatch, hence the calculation of inst_tys - -- This matters in data families - -- data instance T Int a where - -- A :: { fld :: Int } -> T Int Bool - -- B :: { fld :: Int } -> T Int Char - dealt_with :: ConLike -> Bool - dealt_with (PatSynCon _) = False -- We can't predict overlap - dealt_with con@(RealDataCon dc) = - con `elem` cons_w_field || dataConCannotMatch inst_tys dc - - (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 - - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs - - unit_rhs = mkLHsTupleExpr [] - msg_lit = HsStringPrim NoSourceText (bytesFS lbl) - -{- -Note [Polymorphic selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take care to build the type of a polymorphic selector in the right -order, so that visible type application works. - - data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) } - -We want - - field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b) - -Note [Naughty record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "naughty" field is one for which we can't define a record -selector, because an existential type variable would escape. For example: - data T = forall a. MkT { x,y::a } -We obviously can't define - x (MkT v _) = v -Nevertheless we *do* put a RecSelId into the type environment -so that if the user tries to use 'x' as a selector we can bleat -helpfully, rather than saying unhelpfully that 'x' is not in scope. -Hence the sel_naughty flag, to identify record selectors that don't really exist. - -In general, a field is "naughty" if its type mentions a type variable that -isn't in the result type of the constructor. Note that this *allows* -GADT record selectors (Note [GADT record selectors]) whose types may look -like sel :: T [a] -> a - -For naughty selectors we make a dummy binding - sel = () -so that the later type-check will add them to the environment, and they'll be -exported. The function is never called, because the typechecker spots the -sel_naughty field. - -Note [GADT record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For GADTs, we require that all constructors with a common field 'f' have the same -result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] -E.g. - data T where - T1 { f :: Maybe a } :: T [a] - T2 { f :: Maybe a, y :: b } :: T [a] - T3 :: T Int - -and now the selector takes that result type as its argument: - f :: forall a. T [a] -> Maybe a - -Details: the "real" types of T1,T2 are: - T1 :: forall r a. (r~[a]) => a -> T r - T2 :: forall r a b. (r~[a]) => a -> b -> T r - -So the selector loooks like this: - f :: forall a. T [a] -> Maybe a - f (a:*) (t:T [a]) - = case t of - T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) - T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) - T3 -> error "T3 does not have field f" - -Note the forall'd tyvars of the selector are just the free tyvars -of the result type; there may be other tyvars in the constructor's -type (e.g. 'b' in T2). - -Note the need for casts in the result! - -Note [Selector running example] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's OK to combine GADTs and type families. Here's a running example: - - data instance T [a] where - T1 { fld :: b } :: T [Maybe b] - -The representation type looks like this - data :R7T a where - T1 { fld :: b } :: :R7T (Maybe b) - -and there's coercion from the family type to the representation type - :CoR7T a :: T [a] ~ :R7T a - -The selector we want for fld looks like this: - - fld :: forall b. T [Maybe b] -> b - fld = /\b. \(d::T [Maybe b]). - case d `cast` :CoR7T (Maybe b) of - T1 (x::b) -> x - -The scrutinee of the case has type :R7T (Maybe b), which can be -gotten by appying the eq_spec to the univ_tvs of the data con. - --} diff --git a/typecheck/TcType.hs b/typecheck/TcType.hs deleted file mode 100644 --- a/typecheck/TcType.hs +++ /dev/null @@ -1,2447 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcType]{Types used in the typechecker} - -This module provides the Type interface for front-end parts of the -compiler. These parts - - * treat "source types" as opaque: - newtypes, and predicates are meaningful. - * look through usage types - -The "tc" prefix is for "TypeChecker", because the type checker -is the principal client. --} - -{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-} - -module TcType ( - -------------------------------- - -- Types - TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, - TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, - TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon, - KnotTied, - - ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, - - SyntaxOpType(..), synKnownType, mkSynFunTys, - - -- TcLevel - TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, - strictlyDeeperThan, sameDepthAs, - tcTypeLevel, tcTyVarLevel, maxTcLevel, - promoteSkolem, promoteSkolemX, promoteSkolemsX, - -------------------------------- - -- MetaDetails - TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, - MetaDetails(Flexi, Indirect), MetaInfo(..), - isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, - tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, - isFskTyVar, isFmvTyVar, isFlattenTyVar, - isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, - isFlexi, isIndirect, isRuntimeUnkSkol, - metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, - isTouchableMetaTyVar, - isFloatedTouchableMetaTyVar, - findDupTyVarTvs, mkTyVarNamePairs, - - -------------------------------- - -- Builders - mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, - mkTcAppTy, mkTcAppTys, mkTcCastTy, - - -------------------------------- - -- Splitters - -- These are important because they do not look through newtypes - getTyVar, - tcSplitForAllTy_maybe, - tcSplitForAllTys, tcSplitForAllTysSameVis, - tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs, - tcSplitPhiTy, tcSplitPredFunTy_maybe, - tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, - tcSplitFunTysN, - tcSplitTyConApp, tcSplitTyConApp_maybe, - tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, - tcRepGetNumAppTys, - tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole, - tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe, - - --------------------------------- - -- Predicates. - -- Again, newtypes are opaque - eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, - isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, - isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, - hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, - isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck, - checkValidClsArgs, hasTyVarHead, - isRigidTy, isAlmostFunctionFree, - - --------------------------------- - -- Misc type manipulators - - deNoteType, - orphNamesOfType, orphNamesOfCo, - orphNamesOfTypes, orphNamesOfCoCon, - getDFunTyKey, evVarPred, - - --------------------------------- - -- Predicate types - mkMinimalBySCs, transSuperClasses, - pickQuantifiablePreds, pickCapturedPreds, - immSuperClasses, boxEqPred, - isImprovementPred, - - -- * Finding type instances - tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree, - - -- * Finding "exact" (non-dead) type variables - exactTyCoVarsOfType, exactTyCoVarsOfTypes, - anyRewritableTyVar, - - --------------------------------- - -- Foreign import and export - isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool - isFFIImportResultTy, -- :: DynFlags -> Type -> Bool - isFFIExportResultTy, -- :: Type -> Bool - isFFIExternalTy, -- :: Type -> Bool - isFFIDynTy, -- :: Type -> Type -> Bool - isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool - isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool - isFFILabelTy, -- :: Type -> Bool - isFFITy, -- :: Type -> Bool - isFunPtrTy, -- :: Type -> Bool - tcSplitIOType_maybe, -- :: Type -> Maybe Type - - -------------------------------- - -- Rexported from Kind - Kind, tcTypeKind, - liftedTypeKind, - constraintKind, - isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, - - -------------------------------- - -- Rexported from Type - Type, PredType, ThetaType, TyCoBinder, - ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - - mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, - mkInvForAllTy, mkInvForAllTys, - mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys, - mkTyConApp, mkAppTy, mkAppTys, - mkTyConTy, mkTyVarTy, mkTyVarTys, - mkTyCoVarTy, mkTyCoVarTys, - - isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass, - mkClassPred, - tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, - isRuntimeRepVar, isKindLevPoly, - isVisibleBinder, isInvisibleBinder, - - -- Type substitutions - TCvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - zipTvSubst, - mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, - getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, - extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, - Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, - Type.extendTvSubst, - isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, - Type.substTy, substTys, substTyWith, substTyWithCoVars, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTheta, - - isUnliftedType, -- Source types are always lifted - isUnboxedTupleType, -- Ditto - isPrimitiveType, - - tcView, coreView, - - tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, - tyCoFVsOfType, tyCoFVsOfTypes, - tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, - tyCoVarsOfTypeList, tyCoVarsOfTypesList, - noFreeVarsOfType, - - -------------------------------- - pprKind, pprParendKind, pprSigmaType, - pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, - pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, - pprTCvBndr, pprTCvBndrs, - - TypeSize, sizeType, sizeTypes, scopedSort, - - --------------------------------- - -- argument visibility - tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible - - ) where - -#include "HsVersions.h" - --- friends: -import GhcPrelude - -import TyCoRep -import TyCoSubst ( mkTvSubst, substTyWithCoVars ) -import TyCoFVs -import TyCoPpr -import Class -import Var -import ForeignCall -import VarSet -import Coercion -import Type -import Predicate -import RepType -import TyCon - --- others: -import DynFlags -import CoreFVs -import Name -- hiding (varName) - -- We use this to make dictionaries for type literals. - -- Perhaps there's a better way to do this? -import NameSet -import VarEnv -import PrelNames -import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey - , listTyCon, constraintKind ) -import BasicTypes -import Util -import Maybes -import ListSetOps ( getNth, findDupsEq ) -import Outputable -import FastString -import ErrUtils( Validity(..), MsgDoc, isValid ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.List ( mapAccumL ) --- import Data.Functor.Identity( Identity(..) ) -import Data.IORef -import Data.List.NonEmpty( NonEmpty(..) ) - -{- -************************************************************************ -* * - Types -* * -************************************************************************ - -The type checker divides the generic Type world into the -following more structured beasts: - -sigma ::= forall tyvars. phi - -- A sigma type is a qualified type - -- - -- Note that even if 'tyvars' is empty, theta - -- may not be: e.g. (?x::Int) => Int - - -- Note that 'sigma' is in prenex form: - -- all the foralls are at the front. - -- A 'phi' type has no foralls to the right of - -- an arrow - -phi :: theta => rho - -rho ::= sigma -> rho - | tau - --- A 'tau' type has no quantification anywhere --- Note that the args of a type constructor must be taus -tau ::= tyvar - | tycon tau_1 .. tau_n - | tau_1 tau_2 - | tau_1 -> tau_2 - --- In all cases, a (saturated) type synonym application is legal, --- provided it expands to the required form. - -Note [TcTyVars and TyVars in the typechecker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker uses a lot of type variables with special properties, -notably being a unification variable with a mutable reference. These -use the 'TcTyVar' variant of Var.Var. - -Note, though, that a /bound/ type variable can (and probably should) -be a TyVar. E.g - forall a. a -> a -Here 'a' is really just a deBruijn-number; it certainly does not have -a signficant TcLevel (as every TcTyVar does). So a forall-bound type -variable should be TyVars; and hence a TyVar can appear free in a TcType. - -The type checker and constraint solver can also encounter /free/ type -variables that use the 'TyVar' variant of Var.Var, for a couple of -reasons: - - - When typechecking a class decl, say - class C (a :: k) where - foo :: T a -> Int - We have first kind-check the header; fix k and (a:k) to be - TyVars, bring 'k' and 'a' into scope, and kind check the - signature for 'foo'. In doing so we call solveEqualities to - solve any kind equalities in foo's signature. So the solver - may see free occurrences of 'k'. - - See calls to tcExtendTyVarEnv for other places that ordinary - TyVars are bought into scope, and hence may show up in the types - and kinds generated by TcHsType. - - - The pattern-match overlap checker calls the constraint solver, - long afer TcTyVars have been zonked away - -It's convenient to simply treat these TyVars as skolem constants, -which of course they are. We give them a level number of "outermost", -so they behave as global constants. Specifically: - -* Var.tcTyVarDetails succeeds on a TyVar, returning - vanillaSkolemTv, as well as on a TcTyVar. - -* tcIsTcTyVar returns True for both TyVar and TcTyVar variants - of Var.Var. The "tc" prefix means "a type variable that can be - encountered by the typechecker". - -This is a bit of a change from an earlier era when we remoselessly -insisted on real TcTyVars in the type checker. But that seems -unnecessary (for skolems, TyVars are fine) and it's now very hard -to guarantee, with the advent of kind equalities. - -Note [Coercion variables in free variable lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several places in the GHC codebase where functions like -tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type -variables of a type. The "Co" part of these functions' names shouldn't be -dismissed, as it is entirely possible that they will include coercion variables -in addition to type variables! As a result, there are some places in TcType -where we must take care to check that a variable is a _type_ variable (using -isTyVar) before calling tcTyVarDetails--a partial function that is not defined -for coercion variables--on the variable. Failing to do so led to -GHC #12785. --} - --- See Note [TcTyVars and TyVars in the typechecker] -type TcCoVar = CoVar -- Used only during type inference -type TcType = Type -- A TcType can have mutable type variables -type TcTyCoVar = Var -- Either a TcTyVar or a CoVar - -- Invariant on ForAllTy in TcTypes: - -- forall a. T - -- a cannot occur inside a MutTyVar in T; that is, - -- T is "flattened" before quantifying over a - -type TcTyVarBinder = TyVarBinder -type TcTyCon = TyCon -- these can be the TcTyCon constructor - --- These types do not have boxy type variables in them -type TcPredType = PredType -type TcThetaType = ThetaType -type TcSigmaType = TcType -type TcRhoType = TcType -- Note [TcRhoType] -type TcTauType = TcType -type TcKind = Kind -type TcTyVarSet = TyVarSet -type TcTyCoVarSet = TyCoVarSet -type TcDTyVarSet = DTyVarSet -type TcDTyCoVarSet = DTyCoVarSet - -{- ********************************************************************* -* * - ExpType: an "expected type" in the type checker -* * -********************************************************************* -} - --- | An expected type to check against during type-checking. --- See Note [ExpType] in TcMType, where you'll also find manipulators. -data ExpType = Check TcType - | Infer !InferResult - -data InferResult - = IR { ir_uniq :: Unique -- For debugging only - - , ir_lvl :: TcLevel -- See Note [TcLevel of ExpType] in TcMType - - , ir_inst :: Bool - -- True <=> deeply instantiate before returning - -- i.e. return a RhoType - -- False <=> do not instantiate before returning - -- i.e. return a SigmaType - -- See Note [Deep instantiation of InferResult] in TcUnify - - , ir_ref :: IORef (Maybe TcType) } - -- The type that fills in this hole should be a Type, - -- that is, its kind should be (TYPE rr) for some rr - -type ExpSigmaType = ExpType -type ExpRhoType = ExpType - -instance Outputable ExpType where - ppr (Check ty) = text "Check" <> braces (ppr ty) - ppr (Infer ir) = ppr ir - -instance Outputable InferResult where - ppr (IR { ir_uniq = u, ir_lvl = lvl - , ir_inst = inst }) - = text "Infer" <> braces (ppr u <> comma <> ppr lvl <+> ppr inst) - --- | Make an 'ExpType' suitable for checking. -mkCheckExpType :: TcType -> ExpType -mkCheckExpType = Check - - -{- ********************************************************************* -* * - SyntaxOpType -* * -********************************************************************* -} - --- | What to expect for an argument to a rebindable-syntax operator. --- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. --- The callback called from tcSyntaxOp gets a list of types; the meaning --- of these types is determined by a left-to-right depth-first traversal --- of the 'SyntaxOpType' tree. So if you pass in --- --- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny --- --- you'll get three types back: one for the first 'SynAny', the /element/ --- type of the list, and one for the last 'SynAny'. You don't get anything --- for the 'SynType', because you've said positively that it should be an --- Int, and so it shall be. --- --- This is defined here to avoid defining it in TcExpr.hs-boot. -data SyntaxOpType - = SynAny -- ^ Any type - | SynRho -- ^ A rho type, deeply skolemised or instantiated as appropriate - | SynList -- ^ A list type. You get back the element type of the list - | SynFun SyntaxOpType SyntaxOpType - -- ^ A function. - | SynType ExpType -- ^ A known type. -infixr 0 `SynFun` - --- | Like 'SynType' but accepts a regular TcType -synKnownType :: TcType -> SyntaxOpType -synKnownType = SynType . mkCheckExpType - --- | Like 'mkFunTys' but for 'SyntaxOpType' -mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType -mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys - - -{- -Note [TcRhoType] -~~~~~~~~~~~~~~~~ -A TcRhoType has no foralls or contexts at the top, or to the right of an arrow - YES (forall a. a->a) -> Int - NO forall a. a -> Int - NO Eq a => a -> a - NO Int -> forall a. a -> Int - - -************************************************************************ -* * - TyVarDetails, MetaDetails, MetaInfo -* * -************************************************************************ - -TyVarDetails gives extra info about type variables, used during type -checking. It's attached to mutable type variables only. -It's knot-tied back to Var.hs. There is no reason in principle -why Var.hs shouldn't actually have the definition, but it "belongs" here. - -Note [Signature skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -A TyVarTv is a specialised variant of TauTv, with the following invarints: - - * A TyVarTv can be unified only with a TyVar, - not with any other type - - * Its MetaDetails, if filled in, will always be another TyVarTv - or a SkolemTv - -TyVarTvs are only distinguished to improve error messages. -Consider this - - data T (a:k1) = MkT (S a) - data S (b:k2) = MkS (T b) - -When doing kind inference on {S,T} we don't want *skolems* for k1,k2, -because they end up unifying; we want those TyVarTvs again. - - -Note [TyVars and TcTyVars during type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Var type has constructors TyVar and TcTyVar. They are used -as follows: - -* TcTyVar: used /only/ during type checking. Should never appear - afterwards. May contain a mutable field, in the MetaTv case. - -* TyVar: is never seen by the constraint solver, except locally - inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar. - We instantiate these with TcTyVars before exposing the type - to the constraint solver. - -I have swithered about the latter invariant, excluding TyVars from the -constraint solver. It's not strictly essential, and indeed -(historically but still there) Var.tcTyVarDetails returns -vanillaSkolemTv for a TyVar. - -But ultimately I want to seeparate Type from TcType, and in that case -we would need to enforce the separation. --} - --- A TyVarDetails is inside a TyVar --- See Note [TyVars and TcTyVars] -data TcTyVarDetails - = SkolemTv -- A skolem - TcLevel -- Level of the implication that binds it - -- See TcUnify Note [Deeper level on the left] for - -- how this level number is used - Bool -- True <=> this skolem type variable can be overlapped - -- when looking up instances - -- See Note [Binding when looking up instances] in InstEnv - - | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi - -- interactive context - - | MetaTv { mtv_info :: MetaInfo - , mtv_ref :: IORef MetaDetails - , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] - -vanillaSkolemTv, superSkolemTv :: TcTyVarDetails --- See Note [Binding when looking up instances] in InstEnv -vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated -superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type - -- The choice of level number here is a bit dodgy, but - -- topTcLevel works in the places that vanillaSkolemTv is used - -instance Outputable TcTyVarDetails where - ppr = pprTcTyVarDetails - -pprTcTyVarDetails :: TcTyVarDetails -> SDoc --- For debugging -pprTcTyVarDetails (RuntimeUnk {}) = text "rt" -pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl -pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl -pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) - = ppr info <> colon <> ppr tclvl - ------------------------------ -data MetaDetails - = Flexi -- Flexi type variables unify to become Indirects - | Indirect TcType - -data MetaInfo - = TauTv -- This MetaTv is an ordinary unification variable - -- A TauTv is always filled in with a tau-type, which - -- never contains any ForAlls. - - | TyVarTv -- A variant of TauTv, except that it should not be - -- unified with a type, only with a type variable - -- See Note [Signature skolems] - - | FlatMetaTv -- A flatten meta-tyvar - -- It is a meta-tyvar, but it is always untouchable, with level 0 - -- See Note [The flattening story] in TcFlatten - - | FlatSkolTv -- A flatten skolem tyvar - -- Just like FlatMetaTv, but is comletely "owned" by - -- its Given CFunEqCan. - -- It is filled in /only/ by unflattenGivens - -- See Note [The flattening story] in TcFlatten - -instance Outputable MetaDetails where - ppr Flexi = text "Flexi" - ppr (Indirect ty) = text "Indirect" <+> ppr ty - -instance Outputable MetaInfo where - ppr TauTv = text "tau" - ppr TyVarTv = text "tyv" - ppr FlatMetaTv = text "fmv" - ppr FlatSkolTv = text "fsk" - -{- ********************************************************************* -* * - Untouchable type variables -* * -********************************************************************* -} - -newtype TcLevel = TcLevel Int deriving( Eq, Ord ) - -- See Note [TcLevel and untouchable type variables] for what this Int is - -- See also Note [TcLevel assignment] - -{- -Note [TcLevel and untouchable type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Each unification variable (MetaTv) - and each Implication - has a level number (of type TcLevel) - -* INVARIANTS. In a tree of Implications, - - (ImplicInv) The level number (ic_tclvl) of an Implication is - STRICTLY GREATER THAN that of its parent - - (SkolInv) The level number of the skolems (ic_skols) of an - Implication is equal to the level of the implication - itself (ic_tclvl) - - (GivenInv) The level number of a unification variable appearing - in the 'ic_given' of an implication I should be - STRICTLY LESS THAN the ic_tclvl of I - - (WantedInv) The level number of a unification variable appearing - in the 'ic_wanted' of an implication I should be - LESS THAN OR EQUAL TO the ic_tclvl of I - See Note [WantedInv] - -* A unification variable is *touchable* if its level number - is EQUAL TO that of its immediate parent implication, - and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv) - -Note [WantedInv] -~~~~~~~~~~~~~~~~ -Why is WantedInv important? Consider this implication, where -the constraint (C alpha[3]) disobeys WantedInv: - - forall[2] a. blah => (C alpha[3]) - (forall[3] b. alpha[3] ~ b) - -We can unify alpha:=b in the inner implication, because 'alpha' is -touchable; but then 'b' has excaped its scope into the outer implication. - -Note [Skolem escape prevention] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only unify touchable unification variables. Because of -(WantedInv), there can be no occurrences of the variable further out, -so the unification can't cause the skolems to escape. Example: - data T = forall a. MkT a (a->Int) - f x (MkT v f) = length [v,x] -We decide (x::alpha), and generate an implication like - [1]forall a. (a ~ alpha[0]) -But we must not unify alpha:=a, because the skolem would escape. - -For the cases where we DO want to unify, we rely on floating the -equality. Example (with same T) - g x (MkT v f) = x && True -We decide (x::alpha), and generate an implication like - [1]forall a. (Bool ~ alpha[0]) -We do NOT unify directly, bur rather float out (if the constraint -does not mention 'a') to get - (Bool ~ alpha[0]) /\ [1]forall a.() -and NOW we can unify alpha. - -The same idea of only unifying touchables solves another problem. -Suppose we had - (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) -In this example, beta is touchable inside the implication. The -first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside -the implication where a new constraint - uf ~ beta -emerges. If we (wrongly) spontaneously solved it to get uf := beta, -the whole implication disappears but when we pop out again we are left with -(F Int ~ uf) which will be unified by our final zonking stage and -uf will get unified *once more* to (F Int). - -Note [TcLevel assignment] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We arrange the TcLevels like this - - 0 Top level - 1 First-level implication constraints - 2 Second-level implication constraints - ...etc... --} - -maxTcLevel :: TcLevel -> TcLevel -> TcLevel -maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) - -topTcLevel :: TcLevel --- See Note [TcLevel assignment] -topTcLevel = TcLevel 0 -- 0 = outermost level - -isTopTcLevel :: TcLevel -> Bool -isTopTcLevel (TcLevel 0) = True -isTopTcLevel _ = False - -pushTcLevel :: TcLevel -> TcLevel --- See Note [TcLevel assignment] -pushTcLevel (TcLevel us) = TcLevel (us + 1) - -strictlyDeeperThan :: TcLevel -> TcLevel -> Bool -strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) - = tv_tclvl > ctxt_tclvl - -sameDepthAs :: TcLevel -> TcLevel -> Bool -sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl - -- So <= would be equivalent - -checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool --- Checks (WantedInv) from Note [TcLevel and untouchable type variables] -checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl >= tv_tclvl - --- Returns topTcLevel for non-TcTyVars -tcTyVarLevel :: TcTyVar -> TcLevel -tcTyVarLevel tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl - SkolemTv tv_lvl _ -> tv_lvl - RuntimeUnk -> topTcLevel - - -tcTypeLevel :: TcType -> TcLevel --- Max level of any free var of the type -tcTypeLevel ty - = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty) - where - add v lvl - | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v - | otherwise = lvl - -instance Outputable TcLevel where - ppr (TcLevel us) = ppr us - -promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar -promoteSkolem tclvl skol - | tclvl < tcTyVarLevel skol - = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) - setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol)) - - | otherwise - = skol - --- | Change the TcLevel in a skolem, extending a substitution -promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar) -promoteSkolemX tclvl subst skol - = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) - (new_subst, new_skol) - where - new_skol - | tclvl < tcTyVarLevel skol - = setTcTyVarDetails (updateTyVarKind (substTy subst) skol) - (SkolemTv tclvl (isOverlappableTyVar skol)) - | otherwise - = updateTyVarKind (substTy subst) skol - new_subst = extendTvSubstWithClone subst skol new_skol - -promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar]) -promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl) - -{- ********************************************************************* -* * - Finding type family instances -* * -************************************************************************ --} - --- | Finds outermost type-family applications occurring in a type, --- after expanding synonyms. In the list (F, tys) that is returned --- we guarantee that tys matches F's arity. For example, given --- type family F a :: * -> * (arity 1) --- calling tcTyFamInsts on (Maybe (F Int Bool) will return --- (F, [Int]), not (F, [Int,Bool]) --- --- This is important for its use in deciding termination of type --- instances (see #11581). E.g. --- type instance G [Int] = ...(F Int )... --- we don't need to take into account when asking if --- the calls on the RHS are smaller than the LHS -tcTyFamInsts :: Type -> [(TyCon, [Type])] -tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis - --- | Like 'tcTyFamInsts', except that the output records whether the --- type family and its arguments occur as an /invisible/ argument in --- some type application. This information is useful because it helps GHC know --- when to turn on @-fprint-explicit-kinds@ during error reporting so that --- users can actually see the type family being mentioned. --- --- As an example, consider: --- --- @ --- class C a --- data T (a :: k) --- type family F a :: k --- instance C (T @(F Int) (F Bool)) --- @ --- --- There are two occurrences of the type family `F` in that `C` instance, so --- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return: --- --- @ --- [ ('True', F, [Int]) --- , ('False', F, [Bool]) ] --- @ --- --- @F Int@ is paired with 'True' since it appears as an /invisible/ argument --- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a --- /visible/ argument to @C@. --- --- See also @Note [Kind arguments in error messages]@ in "TcErrors". -tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] -tcTyFamInstsAndVis = tcTyFamInstsAndVisX False - -tcTyFamInstsAndVisX - :: Bool -- ^ Is this an invisible argument to some type application? - -> Type -> [(Bool, TyCon, [Type])] -tcTyFamInstsAndVisX = go - where - go is_invis_arg ty - | Just exp_ty <- tcView ty = go is_invis_arg exp_ty - go _ (TyVarTy _) = [] - go is_invis_arg (TyConApp tc tys) - | isTypeFamilyTyCon tc - = [(is_invis_arg, tc, take (tyConArity tc) tys)] - | otherwise - = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys - go _ (LitTy {}) = [] - go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) - ++ go is_invis_arg ty - go is_invis_arg (FunTy _ ty1 ty2) = go is_invis_arg ty1 - ++ go is_invis_arg ty2 - go is_invis_arg ty@(AppTy _ _) = - let (ty_head, ty_args) = splitAppTys ty - ty_arg_flags = appTyArgFlags ty_head ty_args - in go is_invis_arg ty_head - ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag)) - ty_arg_flags ty_args) - go is_invis_arg (CastTy ty _) = go is_invis_arg ty - go _ (CoercionTy _) = [] -- don't count tyfams in coercions, - -- as they never get normalized, - -- anyway - --- | In an application of a 'TyCon' to some arguments, find the outermost --- occurrences of type family applications within the arguments. This function --- will not consider the 'TyCon' itself when checking for type family --- applications. --- --- See 'tcTyFamInstsAndVis' for more details on how this works (as this --- function is called inside of 'tcTyFamInstsAndVis'). -tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])] -tcTyConAppTyFamInstsAndVis = tcTyConAppTyFamInstsAndVisX False - -tcTyConAppTyFamInstsAndVisX - :: Bool -- ^ Is this an invisible argument to some type application? - -> TyCon -> [Type] -> [(Bool, TyCon, [Type])] -tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys = - let (invis_tys, vis_tys) = partitionInvisibleTypes tc tys - in concat $ map (tcTyFamInstsAndVisX True) invis_tys - ++ map (tcTyFamInstsAndVisX is_invis_arg) vis_tys - -isTyFamFree :: Type -> Bool --- ^ Check that a type does not contain any type family applications. -isTyFamFree = null . tcTyFamInsts - -anyRewritableTyVar :: Bool -- Ignore casts and coercions - -> EqRel -- Ambient role - -> (EqRel -> TcTyVar -> Bool) - -> TcType -> Bool --- (anyRewritableTyVar ignore_cos pred ty) returns True --- if the 'pred' returns True of any free TyVar in 'ty' --- Do not look inside casts and coercions if 'ignore_cos' is True --- See Note [anyRewritableTyVar must be role-aware] -anyRewritableTyVar ignore_cos role pred ty - = go role emptyVarSet ty - where - go_tv rl bvs tv | tv `elemVarSet` bvs = False - | otherwise = pred rl tv - - go rl bvs (TyVarTy tv) = go_tv rl bvs tv - go _ _ (LitTy {}) = False - go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys - go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg - go rl bvs (FunTy _ arg res) = go rl bvs arg || go rl bvs res - go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty - go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co - go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check - - go_tc NomEq bvs _ tys = any (go NomEq bvs) tys - go_tc ReprEq bvs tc tys = any (go_arg bvs) - (tyConRolesRepresentational tc `zip` tys) - - go_arg bvs (Nominal, ty) = go NomEq bvs ty - go_arg bvs (Representational, ty) = go ReprEq bvs ty - go_arg _ (Phantom, _) = False -- We never rewrite with phantoms - - go_co rl bvs co - | ignore_cos = False - | otherwise = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co) - -- We don't have an equivalent of anyRewritableTyVar for coercions - -- (at least not yet) so take the free vars and test them - -{- Note [anyRewritableTyVar must be role-aware] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -anyRewritableTyVar is used during kick-out from the inert set, -to decide if, given a new equality (a ~ ty), we should kick out -a constraint C. Rather than gather free variables and see if 'a' -is among them, we instead pass in a predicate; this is just efficiency. - -Moreover, consider - work item: [G] a ~R f b - inert item: [G] b ~R f a -We use anyRewritableTyVar to decide whether to kick out the inert item, -on the grounds that the work item might rewrite it. Well, 'a' is certainly -free in [G] b ~R f a. But because the role of a type variable ('f' in -this case) is nominal, the work item can't actually rewrite the inert item. -Moreover, if we were to kick out the inert item the exact same situation -would re-occur and we end up with an infinite loop in which each kicks -out the other (#14363). --} - -{- -************************************************************************ -* * - Predicates -* * -************************************************************************ --} - -tcIsTcTyVar :: TcTyVar -> Bool --- See Note [TcTyVars and TyVars in the typechecker] -tcIsTcTyVar tv = isTyVar tv - -isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool -isTouchableMetaTyVar ctxt_tclvl tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv - , not (isFlattenInfo info) - = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, - ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) - tv_tclvl `sameDepthAs` ctxt_tclvl - - | otherwise = False - -isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool -isFloatedTouchableMetaTyVar ctxt_tclvl tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv - , not (isFlattenInfo info) - = tv_tclvl `strictlyDeeperThan` ctxt_tclvl - - | otherwise = False - -isImmutableTyVar :: TyVar -> Bool -isImmutableTyVar tv = isSkolemTyVar tv - -isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar, isAmbiguousTyVar, - isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool - -isTyConableTyVar tv - -- True of a meta-type variable that can be filled in - -- with a type constructor application; in particular, - -- not a TyVarTv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - MetaTv { mtv_info = TyVarTv } -> False - _ -> True - | otherwise = True - -isFmvTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = FlatMetaTv } -> True - _ -> False - -isFskTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = FlatSkolTv } -> True - _ -> False - --- | True of both given and wanted flatten-skolems (fmv and fsk) -isFlattenTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = info } -> isFlattenInfo info - _ -> False - -isSkolemTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv {} -> False - _other -> True - -isOverlappableTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - SkolemTv _ overlappable -> overlappable - _ -> False - | otherwise = False - -isMetaTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - MetaTv {} -> True - _ -> False - | otherwise = False - --- isAmbiguousTyVar is used only when reporting type errors --- It picks out variables that are unbound, namely meta --- type variables and the RuntimUnk variables created by --- RtClosureInspect.zonkRTTIType. These are "ambiguous" in --- the sense that they stand for an as-yet-unknown type -isAmbiguousTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - MetaTv {} -> True - RuntimeUnk {} -> True - _ -> False - | otherwise = False - -isMetaTyVarTy :: TcType -> Bool -isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv -isMetaTyVarTy _ = False - -metaTyVarInfo :: TcTyVar -> MetaInfo -metaTyVarInfo tv - = case tcTyVarDetails tv of - MetaTv { mtv_info = info } -> info - _ -> pprPanic "metaTyVarInfo" (ppr tv) - -isFlattenInfo :: MetaInfo -> Bool -isFlattenInfo FlatMetaTv = True -isFlattenInfo FlatSkolTv = True -isFlattenInfo _ = False - -metaTyVarTcLevel :: TcTyVar -> TcLevel -metaTyVarTcLevel tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tclvl } -> tclvl - _ -> pprPanic "metaTyVarTcLevel" (ppr tv) - -metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel -metaTyVarTcLevel_maybe tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tclvl } -> Just tclvl - _ -> Nothing - -metaTyVarRef :: TyVar -> IORef MetaDetails -metaTyVarRef tv - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } -> ref - _ -> pprPanic "metaTyVarRef" (ppr tv) - -setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar -setMetaTyVarTcLevel tv tclvl - = case tcTyVarDetails tv of - details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) - _ -> pprPanic "metaTyVarTcLevel" (ppr tv) - -isTyVarTyVar :: Var -> Bool -isTyVarTyVar tv - = case tcTyVarDetails tv of - MetaTv { mtv_info = TyVarTv } -> True - _ -> False - -isFlexi, isIndirect :: MetaDetails -> Bool -isFlexi Flexi = True -isFlexi _ = False - -isIndirect (Indirect _) = True -isIndirect _ = False - -isRuntimeUnkSkol :: TyVar -> Bool --- Called only in TcErrors; see Note [Runtime skolems] there -isRuntimeUnkSkol x - | RuntimeUnk <- tcTyVarDetails x = True - | otherwise = False - -mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)] --- Just pair each TyVar with its own name -mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs] - -findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)] --- If we have [...(x1,tv)...(x2,tv)...] --- return (x1,x2) in the result list -findDupTyVarTvs prs - = concatMap mk_result_prs $ - findDupsEq eq_snd prs - where - eq_snd (_,tv1) (_,tv2) = tv1 == tv2 - mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs - -{- -************************************************************************ -* * -\subsection{Tau, sigma and rho} -* * -************************************************************************ --} - -mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type -mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) - --- | Make a sigma ty where all type variables are 'Inferred'. That is, --- they cannot be used with visible type application. -mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type -mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty - --- | Make a sigma ty where all type variables are "specified". That is, --- they can be used with visible type application -mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty - -mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy = mkInvisFunTys - ---------------- -getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to - -- construct a dictionary function name -getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' -getDFunTyKey (TyVarTy tv) = getOccName tv -getDFunTyKey (TyConApp tc _) = getOccName tc -getDFunTyKey (LitTy x) = getDFunTyLitKey x -getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy {}) = getOccName funTyCon -getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (CastTy ty _) = getDFunTyKey ty -getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) - -getDFunTyLitKey :: TyLit -> OccName -getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) -getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm - -{- ********************************************************************* -* * - Building types -* * -********************************************************************* -} - --- ToDo: I think we need Tc versions of these --- Reason: mkCastTy checks isReflexiveCastTy, which checks --- for equality; and that has a different answer --- depending on whether or not Type = Constraint - -mkTcAppTys :: Type -> [Type] -> Type -mkTcAppTys = mkAppTys - -mkTcAppTy :: Type -> Type -> Type -mkTcAppTy = mkAppTy - -mkTcCastTy :: Type -> Coercion -> Type -mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy? - -{- -************************************************************************ -* * -\subsection{Expanding and splitting} -* * -************************************************************************ - -These tcSplit functions are like their non-Tc analogues, but - *) they do not look through newtypes - -However, they are non-monadic and do not follow through mutable type -variables. It's up to you to make sure this doesn't matter. --} - --- | Splits a forall type into a list of 'TyBinder's and the inner type. --- Always succeeds, even if it returns an empty list. -tcSplitPiTys :: Type -> ([TyBinder], Type) -tcSplitPiTys ty - = ASSERT( all isTyBinder (fst sty) ) sty - where sty = splitPiTys ty - --- | Splits a type into a TyBinder and a body, if possible. Panics otherwise -tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) -tcSplitPiTy_maybe ty - = ASSERT( isMaybeTyBinder sty ) sty - where - sty = splitPiTy_maybe ty - isMaybeTyBinder (Just (t,_)) = isTyBinder t - isMaybeTyBinder _ = True - -tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) -tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty' -tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty) -tcSplitForAllTy_maybe _ = Nothing - --- | Like 'tcSplitPiTys', but splits off only named binders, --- returning just the tycovars. -tcSplitForAllTys :: Type -> ([TyVar], Type) -tcSplitForAllTys ty - = ASSERT( all isTyVar (fst sty) ) sty - where sty = splitForAllTys ty - --- | Like 'tcSplitForAllTys', but only splits a 'ForAllTy' if --- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility --- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided --- as an argument to this function. -tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVar], Type) -tcSplitForAllTysSameVis supplied_argf ty = ASSERT( all isTyVar (fst sty) ) sty - where sty = splitForAllTysSameVis supplied_argf ty - --- | Like 'tcSplitForAllTys', but splits off only named binders. -tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type) -tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty - where sty = splitForAllVarBndrs ty - --- | Is this a ForAllTy with a named binder? -tcIsForAllTy :: Type -> Bool -tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy {}) = True -tcIsForAllTy _ = False - -tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) --- Split off the first predicate argument from a type -tcSplitPredFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg - , ft_arg = arg, ft_res = res }) - = Just (arg, res) -tcSplitPredFunTy_maybe _ - = Nothing - -tcSplitPhiTy :: Type -> (ThetaType, Type) -tcSplitPhiTy ty - = split ty [] - where - split ty ts - = case tcSplitPredFunTy_maybe ty of - Just (pred, ty) -> split ty (pred:ts) - Nothing -> (reverse ts, ty) - --- | Split a sigma type into its parts. -tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) -tcSplitSigmaTy ty = case tcSplitForAllTys ty of - (tvs, rho) -> case tcSplitPhiTy rho of - (theta, tau) -> (tvs, theta, tau) - --- | Split a sigma type into its parts, going underneath as many @ForAllTy@s --- as possible. For example, given this type synonym: --- --- @ --- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t --- @ --- --- if you called @tcSplitSigmaTy@ on this type: --- --- @ --- forall s t a b. Each s t a b => Traversal s t a b --- @ --- --- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But --- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return --- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@. -tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) --- NB: This is basically a pure version of deeplyInstantiate (from Inst) that --- doesn't compute an HsWrapper. -tcSplitNestedSigmaTys ty - -- If there's a forall, split it apart and try splitting the rho type - -- underneath it. - | Just (arg_tys, tvs1, theta1, rho1) <- tcDeepSplitSigmaTy_maybe ty - = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 - in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) - -- If there's no forall, we're done. - | otherwise = ([], [], ty) - ------------------------ -tcDeepSplitSigmaTy_maybe - :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType) --- Looks for a *non-trivial* quantified type, under zero or more function arrows --- By "non-trivial" we mean either tyvars or constraints are non-empty - -tcDeepSplitSigmaTy_maybe ty - | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty - , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty - = Just (arg_ty:arg_tys, tvs, theta, rho) - - | (tvs, theta, rho) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = Just ([], tvs, theta, rho) - - | otherwise = Nothing - ------------------------ -tcTyConAppTyCon :: Type -> TyCon -tcTyConAppTyCon ty - = case tcTyConAppTyCon_maybe ty of - Just tc -> tc - Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) - --- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. -tcTyConAppTyCon_maybe :: Type -> Maybe TyCon -tcTyConAppTyCon_maybe ty - | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' -tcTyConAppTyCon_maybe (TyConApp tc _) - = Just tc -tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg }) - = Just funTyCon -- (=>) is /not/ a TyCon in its own right - -- C.f. tcRepSplitAppTy_maybe -tcTyConAppTyCon_maybe _ - = Nothing - -tcTyConAppArgs :: Type -> [Type] -tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of - Just (_, args) -> args - Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) - -tcSplitTyConApp :: Type -> (TyCon, [Type]) -tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) - ------------------------ -tcSplitFunTys :: Type -> ([Type], Type) -tcSplitFunTys ty = case tcSplitFunTy_maybe ty of - Nothing -> ([], ty) - Just (arg,res) -> (arg:args, res') - where - (args,res') = tcSplitFunTys res - -tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) -tcSplitFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - | VisArg <- af = Just (arg, res) -tcSplitFunTy_maybe _ = Nothing - -- Note the VisArg guard - -- Consider (?x::Int) => Bool - -- We don't want to treat this as a function type! - -- A concrete example is test tc230: - -- f :: () -> (?p :: ()) => () -> () - -- - -- g = f () () - -tcSplitFunTysN :: Arity -- n: Number of desired args - -> TcRhoType - -> Either Arity -- Number of missing arrows - ([TcSigmaType], -- Arg types (always N types) - TcSigmaType) -- The rest of the type --- ^ Split off exactly the specified number argument types --- Returns --- (Left m) if there are 'm' missing arrows in the type --- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res -tcSplitFunTysN n ty - | n == 0 - = Right ([], ty) - | Just (arg,res) <- tcSplitFunTy_maybe ty - = case tcSplitFunTysN (n-1) res of - Left m -> Left m - Right (args,body) -> Right (arg:args, body) - | otherwise - = Left n - -tcSplitFunTy :: Type -> (Type, Type) -tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) - -tcFunArgTy :: Type -> Type -tcFunArgTy ty = fst (tcSplitFunTy ty) - -tcFunResultTy :: Type -> Type -tcFunResultTy ty = snd (tcSplitFunTy ty) - --- | Strips off n *visible* arguments and returns the resulting type -tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type -tcFunResultTyN n ty - | Right (_, res_ty) <- tcSplitFunTysN n ty - = res_ty - | otherwise - = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) - ------------------------ -tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' -tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty - -tcSplitAppTy :: Type -> (Type, Type) -tcSplitAppTy ty = case tcSplitAppTy_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitAppTy" (pprType ty) - -tcSplitAppTys :: Type -> (Type, [Type]) -tcSplitAppTys ty - = go ty [] - where - go ty args = case tcSplitAppTy_maybe ty of - Just (ty', arg) -> go ty' (arg:args) - Nothing -> (ty,args) - --- | Returns the number of arguments in the given type, without --- looking through synonyms. This is used only for error reporting. --- We don't look through synonyms because of #11313. -tcRepGetNumAppTys :: Type -> Arity -tcRepGetNumAppTys = length . snd . repSplitAppTys - ------------------------ --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind type -tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty' -tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv)) -tcGetCastedTyVar_maybe _ = Nothing - -tcGetTyVar_maybe :: Type -> Maybe TyVar -tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' -tcGetTyVar_maybe (TyVarTy tv) = Just tv -tcGetTyVar_maybe _ = Nothing - -tcGetTyVar :: String -> Type -> TyVar -tcGetTyVar msg ty - = case tcGetTyVar_maybe ty of - Just tv -> tv - Nothing -> pprPanic msg (ppr ty) - -tcIsTyVarTy :: Type -> Bool -tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' -tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as - -- this is only used for - -- e.g., FlexibleContexts -tcIsTyVarTy (TyVarTy _) = True -tcIsTyVarTy _ = False - ------------------------ -tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) --- Split the type of a dictionary function --- We don't use tcSplitSigmaTy, because a DFun may (with NDP) --- have non-Pred arguments, such as --- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m --- --- Also NB splitFunTys, not tcSplitFunTys; --- the latter specifically stops at PredTy arguments, --- and we don't want to do that here -tcSplitDFunTy ty - = case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, theta, clas, tys) }}} - -tcSplitDFunHead :: Type -> (Class, [Type]) -tcSplitDFunHead = getClassPredTys - -tcSplitMethodTy :: Type -> ([TyVar], PredType, Type) --- A class method (selector) always has a type like --- forall as. C as => blah --- So if the class looks like --- class C a where --- op :: forall b. (Eq a, Ix b) => a -> b --- the class method type looks like --- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b --- --- tcSplitMethodTy just peels off the outer forall and --- that first predicate -tcSplitMethodTy ty - | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty - , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho - = (sel_tyvars, first_pred, local_meth_ty) - | otherwise - = pprPanic "tcSplitMethodTy" (ppr ty) - - -{- ********************************************************************* -* * - Type equalities -* * -********************************************************************* -} - -tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool -tcEqKind = tcEqType - -tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool --- tcEqType is a proper implements the same Note [Non-trivial definitional --- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* == --- Constraint), and that is NOT what we want in the type checker! -tcEqType ty1 ty2 - = tc_eq_type False False ki1 ki2 - && tc_eq_type False False ty1 ty2 - where - ki1 = tcTypeKind ty1 - ki2 = tcTypeKind ty2 - --- | Just like 'tcEqType', but will return True for types of different kinds --- as long as their non-coercion structure is identical. -tcEqTypeNoKindCheck :: TcType -> TcType -> Bool -tcEqTypeNoKindCheck ty1 ty2 - = tc_eq_type False False ty1 ty2 - --- | Like 'tcEqType', but returns True if the /visible/ part of the types --- are equal, even if they are really unequal (in the invisible bits) -tcEqTypeVis :: TcType -> TcType -> Bool -tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 - --- | Like 'pickyEqTypeVis', but returns a Bool for convenience -pickyEqType :: TcType -> TcType -> Bool --- Check when two types _look_ the same, _including_ synonyms. --- So (pickyEqType String [Char]) returns False --- This ignores kinds and coercions, because this is used only for printing. -pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 - - - --- | Real worker for 'tcEqType'. No kind check! -tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms - -> Bool -- ^ True <=> compare visible args only - -> Type -> Type - -> Bool --- Flags False, False is the usual setting for tc_eq_type -tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 - = go orig_env orig_ty1 orig_ty2 - where - go :: RnEnv2 -> Type -> Type -> Bool - go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2 - go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = rnOccL env tv1 == rnOccR env tv2 - - go _ (LitTy lit1) (LitTy lit2) - = lit1 == lit2 - - go env (ForAllTy (Bndr tv1 vis1) ty1) - (ForAllTy (Bndr tv2 vis2) ty2) - = vis1 == vis2 - && (vis_only || go env (varType tv1) (varType tv2)) - && go (rnBndr2 env tv1 tv2) ty1 ty2 - - -- Make sure we handle all FunTy cases since falling through to the - -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked - -- kind variable, which causes things to blow up. - go env (FunTy _ arg1 res1) (FunTy _ arg2 res2) - = go env arg1 arg2 && go env res1 res2 - go env ty (FunTy _ arg res) = eqFunTy env arg res ty - go env (FunTy _ arg res) ty = eqFunTy env arg res ty - - -- See Note [Equality on AppTys] in Type - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 - = go env s1 s2 && go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 - = go env s1 s2 && go env t1 t2 - - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 - - go env (CastTy t1 _) t2 = go env t1 t2 - go env t1 (CastTy t2 _) = go env t1 t2 - go _ (CoercionTy {}) (CoercionTy {}) = True - - go _ _ _ = False - - gos _ _ [] [] = True - gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) - && gos env igs ts1 ts2 - gos _ _ _ _ = False - - tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore - tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles - | otherwise = repeat False -- Ignore nothing - -- The repeat False is necessary because tycons - -- can legitimately be oversaturated - where - bndrs = tyConBinders tc - inviss = map isInvisibleTyConBinder bndrs - - orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - - -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is - -- sometimes hard to know directly because @ty@ might have some casts - -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't - -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or - -- res is unzonked/unflattened. Thus this function, which handles this - -- corner case. - eqFunTy :: RnEnv2 -> Type -> Type -> Type -> Bool - -- Last arg is /not/ FunTy - eqFunTy env arg res ty@(AppTy{}) = get_args ty [] - where - get_args :: Type -> [Type] -> Bool - get_args (AppTy f x) args = get_args f (x:args) - get_args (CastTy t _) args = get_args t args - get_args (TyConApp tc tys) args - | tc == funTyCon - , [_, _, arg', res'] <- tys ++ args - = go env arg arg' && go env res res' - get_args _ _ = False - eqFunTy _ _ _ _ = False - -{- ********************************************************************* -* * - Predicate types -* * -************************************************************************ - -Deconstructors and tests on predicate types - -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - class C f where... -- C :: forall k. k -> Constraint - g :: forall (f::*). C f => f -> f - -Here the (C f) in the signature is really (C * f), and we -don't want to complain that the * isn't a type variable! --} - -isTyVarClassPred :: PredType -> Bool -isTyVarClassPred ty = case getClassPredTys_maybe ty of - Just (_, tys) -> all isTyVarTy tys - _ -> False - -------------------------- -checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool --- If the Bool is True (flexible contexts), return True (i.e. ok) --- Otherwise, check that the type (not kind) args are all headed by a tyvar --- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected --- This function is here rather than in TcValidity because it is --- called from TcSimplify, which itself is imported by TcValidity -checkValidClsArgs flexible_contexts cls kts - | flexible_contexts = True - | otherwise = all hasTyVarHead tys - where - tys = filterOutInvisibleTypes (classTyCon cls) kts - -hasTyVarHead :: Type -> Bool --- Returns true of (a t1 .. tn), where 'a' is a type variable -hasTyVarHead ty -- Haskell 98 allows predicates of form - | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) - | otherwise -- where a is a type variable - = case tcSplitAppTy_maybe ty of - Just (ty, _) -> hasTyVarHead ty - Nothing -> False - -evVarPred :: EvVar -> PredType -evVarPred var = varType var - -- Historical note: I used to have an ASSERT here, - -- checking (isEvVarType (varType var)). But with something like - -- f :: c => _ -> _ - -- we end up with (c :: kappa), and (kappa ~ Constraint). Until - -- we solve and zonk (which there is no particular reason to do for - -- partial signatures, (isEvVarType kappa) will return False. But - -- nothing is wrong. So I just removed the ASSERT. - ------------------- --- | When inferring types, should we quantify over a given predicate? --- Generally true of classes; generally false of equality constraints. --- Equality constraints that mention quantified type variables and --- implicit variables complicate the story. See Notes --- [Inheriting implicit parameters] and [Quantifying over equality constraints] -pickQuantifiablePreds - :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcThetaType -- A subset that we can actually quantify --- This function decides whether a particular constraint should be --- quantified over, given the type variables that are being quantified -pickQuantifiablePreds qtvs theta - = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without - -- -XFlexibleContexts: see #10608, #10351 - -- flex_ctxt <- xoptM Opt_FlexibleContexts - mapMaybe (pick_me flex_ctxt) theta - where - pick_me flex_ctxt pred - = case classifyPredType pred of - - ClassPred cls tys - | Just {} <- isCallStackPred cls tys - -- NEVER infer a CallStack constraint. Otherwise we let - -- the constraints bubble up to be solved from the outer - -- context, or be defaulted when we reach the top-level. - -- See Note [Overview of implicit CallStacks] - -> Nothing - - | isIPClass cls - -> Just pred -- See note [Inheriting implicit parameters] - - | pick_cls_pred flex_ctxt cls tys - -> Just pred - - EqPred eq_rel ty1 ty2 - | quantify_equality eq_rel ty1 ty2 - , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constaints when quantifying] - , pick_cls_pred flex_ctxt cls tys - -> Just (mkClassPred cls tys) - - IrredPred ty - | tyCoVarsOfType ty `intersectsVarSet` qtvs - -> Just pred - - _ -> Nothing - - - pick_cls_pred flex_ctxt cls tys - = tyCoVarsOfTypes tys `intersectsVarSet` qtvs - && (checkValidClsArgs flex_ctxt cls tys) - -- Only quantify over predicates that checkValidType - -- will pass! See #10351. - - -- See Note [Quantifying over equality constraints] - quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 - quantify_equality ReprEq _ _ = True - - quant_fun ty - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) | isTypeFamilyTyCon tc - -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs - _ -> False - -boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) --- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version --- (t1 ~ t2) or (t1 `Coercible` t2) -boxEqPred eq_rel ty1 ty2 - = case eq_rel of - NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) - | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) - ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) - | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible - -- so we can't abstract over it - -- Nothing fundamental: we could add it - where - k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - homo_kind = k1 `tcEqType` k2 - -pickCapturedPreds - :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcThetaType -- A subset that we can actually quantify --- A simpler version of pickQuantifiablePreds, used to winnow down --- the inferred constraints of a group of bindings, into those for --- one particular identifier -pickCapturedPreds qtvs theta - = filter captured theta - where - captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) - - --- Superclasses - -type PredWithSCs a = (PredType, [PredType], a) - -mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a] --- Remove predicates that --- --- - are the same as another predicate --- --- - can be deduced from another by superclasses, --- --- - are a reflexive equality (e.g * ~ *) --- (see Note [Remove redundant provided dicts] in TcPatSyn) --- --- The result is a subset of the input. --- The 'a' is just paired up with the PredType; --- typically it might be a dictionary Id -mkMinimalBySCs get_pred xs = go preds_with_scs [] - where - preds_with_scs :: [PredWithSCs a] - preds_with_scs = [ (pred, pred : transSuperClasses pred, x) - | x <- xs - , let pred = get_pred x ] - - go :: [PredWithSCs a] -- Work list - -> [PredWithSCs a] -- Accumulating result - -> [a] - go [] min_preds - = reverse (map thdOf3 min_preds) - -- The 'reverse' isn't strictly necessary, but it - -- means that the results are returned in the same - -- order as the input, which is generally saner - go (work_item@(p,_,_) : work_list) min_preds - | EqPred _ t1 t2 <- classifyPredType p - , t1 `tcEqType` t2 -- See TcPatSyn - -- Note [Remove redundant provided dicts] - = go work_list min_preds - | p `in_cloud` work_list || p `in_cloud` min_preds - = go work_list min_preds - | otherwise - = go work_list (work_item : min_preds) - - in_cloud :: PredType -> [PredWithSCs a] -> Bool - in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ] - -transSuperClasses :: PredType -> [PredType] --- (transSuperClasses p) returns (p's superclasses) not including p --- Stop if you encounter the same class again --- See Note [Expanding superclasses] -transSuperClasses p - = go emptyNameSet p - where - go :: NameSet -> PredType -> [PredType] - go rec_clss p - | ClassPred cls tys <- classifyPredType p - , let cls_nm = className cls - , not (cls_nm `elemNameSet` rec_clss) - , let rec_clss' | isCTupleClass cls = rec_clss - | otherwise = rec_clss `extendNameSet` cls_nm - = [ p' | sc <- immSuperClasses cls tys - , p' <- sc : go rec_clss' sc ] - | otherwise - = [] - -immSuperClasses :: Class -> [Type] -> [PredType] -immSuperClasses cls tys - = substTheta (zipTvSubst tyvars tys) sc_theta - where - (tyvars,sc_theta,_,_) = classBigSig cls - -isImprovementPred :: PredType -> Bool --- Either it's an equality, or has some functional dependency -isImprovementPred ty - = case classifyPredType ty of - EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) - EqPred ReprEq _ _ -> False - ClassPred cls _ -> classHasFds cls - IrredPred {} -> True -- Might have equalities after reduction? - ForAllPred {} -> False - --- | Is the equality --- a ~r ...a.... --- definitely insoluble or not? --- a ~r Maybe a -- Definitely insoluble --- a ~N ...(F a)... -- Not definitely insoluble --- -- Perhaps (F a) reduces to Int --- a ~R ...(N a)... -- Not definitely insoluble --- -- Perhaps newtype N a = MkN Int --- See Note [Occurs check error] in --- TcCanonical for the motivation for this function. -isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool -isInsolubleOccursCheck eq_rel tv ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' - go (TyVarTy tv') = tv == tv' || go (tyVarKind tv') - go (LitTy {}) = False - go (AppTy t1 t2) = case eq_rel of -- See Note [AppTy and ReprEq] - NomEq -> go t1 || go t2 - ReprEq -> go t1 - go (FunTy _ t1 t2) = go t1 || go t2 - go (ForAllTy (Bndr tv' _) inner_ty) - | tv' == tv = False - | otherwise = go (varType tv') || go inner_ty - go (CastTy ty _) = go ty -- ToDo: what about the coercion - go (CoercionTy _) = False -- ToDo: what about the coercion - go (TyConApp tc tys) - | isGenerativeTyCon tc role = any go tys - | otherwise = any go (drop (tyConArity tc) tys) - -- (a ~ F b a), where F has arity 1, - -- has an insoluble occurs check - - role = eqRelRole eq_rel - -{- Note [Expanding superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we expand superclasses, we use the following algorithm: - -transSuperClasses( C tys ) returns the transitive superclasses - of (C tys), not including C itself - -For example - class C a b => D a b - class D b a => C a b - -Then - transSuperClasses( Ord ty ) = [Eq ty] - transSuperClasses( C ta tb ) = [D tb ta, C tb ta] - -Notice that in the recursive-superclass case we include C again at -the end of the chain. One could exclude C in this case, but -the code is more awkward and there seems no good reason to do so. -(However C.f. TcCanonical.mk_strict_superclasses, which /does/ -appear to do so.) - -The algorithm is expand( so_far, pred ): - - 1. If pred is not a class constraint, return empty set - Otherwise pred = C ts - 2. If C is in so_far, return empty set (breaks loops) - 3. Find the immediate superclasses constraints of (C ts) - 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss ) - -Notice that - - * With normal Haskell-98 classes, the loop-detector will never bite, - so we'll get all the superclasses. - - * We need the loop-breaker in case we have UndecidableSuperClasses on - - * Since there is only a finite number of distinct classes, expansion - must terminate. - - * The loop breaking is a bit conservative. Notably, a tuple class - could contain many times without threatening termination: - (Eq a, (Ord a, Ix a)) - And this is try of any class that we can statically guarantee - as non-recursive (in some sense). For now, we just make a special - case for tuples. Something better would be cool. - -See also TcTyDecls.checkClassCycles. - -Note [Lift equality constaints when quantifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't quantify over a constraint (t1 ~# t2) because that isn't a -predicate type; see Note [Types for coercions, predicates, and evidence] -in TyCoRep. - -So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted -to Coercible. - -This tiresome lifting is the reason that pick_me (in -pickQuantifiablePreds) returns a Maybe rather than a Bool. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t)? In general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, because then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you must quantify over implicit -parameters, *even if* they don't mention the bound type variables. -Reason: because implicit parameters, uniquely, have local instance -declarations. See pickQuantifiablePreds. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t)? In general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - -************************************************************************ -* * - Classifying types -* * -************************************************************************ --} - -isSigmaTy :: TcType -> Bool --- isSigmaTy returns true of any qualified type. It doesn't --- *necessarily* have any foralls. E.g --- f :: (?x::Int) => Int -> Int -isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' -isSigmaTy (ForAllTy {}) = True -isSigmaTy (FunTy { ft_af = InvisArg }) = True -isSigmaTy _ = False - -isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] -isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' -isRhoTy (ForAllTy {}) = False -isRhoTy (FunTy { ft_af = VisArg, ft_res = r }) = isRhoTy r -isRhoTy _ = True - --- | Like 'isRhoTy', but also says 'True' for 'Infer' types -isRhoExpTy :: ExpType -> Bool -isRhoExpTy (Check ty) = isRhoTy ty -isRhoExpTy (Infer {}) = True - -isOverloadedTy :: Type -> Bool --- Yes for a type of a function that might require evidence-passing --- Used only by bindLocalMethods -isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy { ft_af = InvisArg }) = True -isOverloadedTy _ = False - -isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy, isAnyTy :: Type -> Bool -isFloatTy = is_tc floatTyConKey -isDoubleTy = is_tc doubleTyConKey -isIntegerTy = is_tc integerTyConKey -isIntTy = is_tc intTyConKey -isWordTy = is_tc wordTyConKey -isBoolTy = is_tc boolTyConKey -isUnitTy = is_tc unitTyConKey -isCharTy = is_tc charTyConKey -isAnyTy = is_tc anyTyConKey - --- | Does a type represent a floating-point number? -isFloatingTy :: Type -> Bool -isFloatingTy ty = isFloatTy ty || isDoubleTy ty - --- | Is a type 'String'? -isStringTy :: Type -> Bool -isStringTy ty - = case tcSplitTyConApp_maybe ty of - Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty - _ -> False - --- | Is a type a 'CallStack'? -isCallStackTy :: Type -> Bool -isCallStackTy ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` callStackTyConKey - | otherwise - = False - --- | Is a 'PredType' a 'CallStack' implicit parameter? --- --- If so, return the name of the parameter. -isCallStackPred :: Class -> [Type] -> Maybe FastString -isCallStackPred cls tys - | [ty1, ty2] <- tys - , isIPClass cls - , isCallStackTy ty2 - = isStrLitTy ty1 - | otherwise - = Nothing - -is_tc :: Unique -> Type -> Bool --- Newtypes are opaque to this -is_tc uniq ty = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> uniq == getUnique tc - Nothing -> False - --- | Does the given tyvar appear at the head of a chain of applications --- (a t1 ... tn) -isTyVarHead :: TcTyVar -> TcType -> Bool -isTyVarHead tv (TyVarTy tv') = tv == tv' -isTyVarHead tv (AppTy fun _) = isTyVarHead tv fun -isTyVarHead tv (CastTy ty _) = isTyVarHead tv ty -isTyVarHead _ (TyConApp {}) = False -isTyVarHead _ (LitTy {}) = False -isTyVarHead _ (ForAllTy {}) = False -isTyVarHead _ (FunTy {}) = False -isTyVarHead _ (CoercionTy {}) = False - - -{- Note [AppTy and ReprEq] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a ~R# b a - a ~R# a b - -The former is /not/ a definite error; we might instantiate 'b' with Id - newtype Id a = MkId a -but the latter /is/ a definite error. - -On the other hand, with nominal equality, both are definite errors --} - -isRigidTy :: TcType -> Bool -isRigidTy ty - | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal - | Just {} <- tcSplitAppTy_maybe ty = True - | isForAllTy ty = True - | otherwise = False - - --- | Is this type *almost function-free*? See Note [Almost function-free] --- in TcRnTypes -isAlmostFunctionFree :: TcType -> Bool -isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty' -isAlmostFunctionFree (TyVarTy {}) = True -isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 && - isAlmostFunctionFree ty2 -isAlmostFunctionFree (TyConApp tc args) - | isTypeFamilyTyCon tc = False - | otherwise = all isAlmostFunctionFree args -isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr) -isAlmostFunctionFree (FunTy _ ty1 ty2) = isAlmostFunctionFree ty1 && - isAlmostFunctionFree ty2 -isAlmostFunctionFree (LitTy {}) = True -isAlmostFunctionFree (CastTy ty _) = isAlmostFunctionFree ty -isAlmostFunctionFree (CoercionTy {}) = True - -{- -************************************************************************ -* * -\subsection{Misc} -* * -************************************************************************ - -Note [Visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC implements a generalisation of the algorithm described in the -"Visible Type Application" paper (available from -http://www.cis.upenn.edu/~sweirich/publications.html). A key part -of that algorithm is to distinguish user-specified variables from inferred -variables. For example, the following should typecheck: - - f :: forall a b. a -> b -> b - f = const id - - g = const id - - x = f @Int @Bool 5 False - y = g 5 @Bool False - -The idea is that we wish to allow visible type application when we are -instantiating a specified, fixed variable. In practice, specified, fixed -variables are either written in a type signature (or -annotation), OR are imported from another module. (We could do better here, -for example by doing SCC analysis on parts of a module and considering any -type from outside one's SCC to be fully specified, but this is very confusing to -users. The simple rule above is much more straightforward and predictable.) - -So, both of f's quantified variables are specified and may be instantiated. -But g has no type signature, so only id's variable is specified (because id -is imported). We write the type of g as forall {a}. a -> forall b. b -> b. -Note that the a is in braces, meaning it cannot be instantiated with -visible type application. - -Tracking specified vs. inferred variables is done conveniently by a field -in TyBinder. - --} - -deNoteType :: Type -> Type --- Remove all *outermost* type synonyms and other notes -deNoteType ty | Just ty' <- coreView ty = deNoteType ty' -deNoteType ty = ty - -{- -Find the free tycons and classes of a type. This is used in the front -end of the compiler. --} - -{- -************************************************************************ -* * -\subsection[TysWiredIn-ext-type]{External types} -* * -************************************************************************ - -The compiler's foreign function interface supports the passing of a -restricted set of types as arguments and results (the restricting factor -being the ) --} - -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) --- (tcSplitIOType_maybe t) returns Just (IO,t',co) --- if co : t ~ IO t' --- returns Nothing otherwise -tcSplitIOType_maybe ty - = case tcSplitTyConApp_maybe ty of - Just (io_tycon, [io_res_ty]) - | io_tycon `hasKey` ioTyConKey -> - Just (io_tycon, io_res_ty) - _ -> - Nothing - -isFFITy :: Type -> Bool --- True for any TyCon that can possibly be an arg or result of an FFI call -isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty) - -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity --- Checks for valid argument type for a 'foreign import' -isFFIArgumentTy dflags safety ty - = checkRepTyCon (legalOutgoingTyCon dflags safety) ty - -isFFIExternalTy :: Type -> Validity --- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty - -isFFIImportResultTy :: DynFlags -> Type -> Validity -isFFIImportResultTy dflags ty - = checkRepTyCon (legalFIResultTyCon dflags) ty - -isFFIExportResultTy :: Type -> Validity -isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty - -isFFIDynTy :: Type -> Type -> Validity --- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of --- either, and the wrapped function type must be equal to the given type. --- We assume that all types have been run through normaliseFfiType, so we don't --- need to worry about expanding newtypes here. -isFFIDynTy expected ty - -- Note [Foreign import dynamic] - -- In the example below, expected would be 'CInt -> IO ()', while ty would - -- be 'FunPtr (CDouble -> IO ())'. - | Just (tc, [ty']) <- splitTyConApp_maybe ty - , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] - , eqType ty' expected - = IsValid - | otherwise - = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma - , text " Actual:" <+> ppr ty ]) - -isFFILabelTy :: Type -> Validity --- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. -isFFILabelTy ty = checkRepTyCon ok ty - where - ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey - = IsValid - | otherwise - = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") - -isFFIPrimArgumentTy :: DynFlags -> Type -> Validity --- Checks for valid argument type for a 'foreign import prim' --- Currently they must all be simple unlifted types, or the well-known type --- Any, which can be used to pass the address to a Haskell object on the heap to --- the foreign function. -isFFIPrimArgumentTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty - -isFFIPrimResultTy :: DynFlags -> Type -> Validity --- Checks for valid result type for a 'foreign import prim' Currently --- it must be an unlifted type, including unboxed tuples, unboxed --- sums, or the well-known type Any. -isFFIPrimResultTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty - -isFunPtrTy :: Type -> Bool -isFunPtrTy ty - | Just (tc, [_]) <- splitTyConApp_maybe ty - = tc `hasKey` funPtrTyConKey - | otherwise - = False - --- normaliseFfiType gets run before checkRepTyCon, so we don't --- need to worry about looking through newtypes or type functions --- here; that's already been taken care of. -checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity -checkRepTyCon check_tc ty - = case splitTyConApp_maybe ty of - Just (tc, tys) - | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) - | otherwise -> case check_tc tc of - IsValid -> IsValid - NotValid extra -> NotValid (msg $$ extra) - Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") - where - msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" - mk_nt_reason tc tys - | null tys = text "because its data constructor is not in scope" - | otherwise = text "because the data constructor for" - <+> quotes (ppr tc) <+> text "is not in scope" - nt_fix = text "Possible fix: import the data constructor to bring it into scope" - -{- -Note [Foreign import dynamic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign -type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. - -We use isFFIDynTy to check whether a signature is well-formed. For example, -given a (illegal) declaration like: - -foreign import ccall "dynamic" - foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () - -isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried -result type 'CInt -> IO ()', and return False, as they are not equal. - - ----------------------------------------------- -These chaps do the work; they are not exported ----------------------------------------------- --} - -legalFEArgTyCon :: TyCon -> Validity -legalFEArgTyCon tc - -- It's illegal to make foreign exports that take unboxed - -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 - = boxedMarshalableTyCon tc - -legalFIResultTyCon :: DynFlags -> TyCon -> Validity -legalFIResultTyCon dflags tc - | tc == unitTyCon = IsValid - | otherwise = marshalableTyCon dflags tc - -legalFEResultTyCon :: TyCon -> Validity -legalFEResultTyCon tc - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc - -legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity --- Checks validity of types going from Haskell -> external world -legalOutgoingTyCon dflags _ tc - = marshalableTyCon dflags tc - -legalFFITyCon :: TyCon -> Validity --- True for any TyCon that can possibly be an arg or result of an FFI call -legalFFITyCon tc - | isUnliftedTyCon tc = IsValid - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc - -marshalableTyCon :: DynFlags -> TyCon -> Validity -marshalableTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) - , not (null (tyConPrimRep tc)) -- Note [Marshalling void] - = validIfUnliftedFFITypes dflags - | otherwise - = boxedMarshalableTyCon tc - -boxedMarshalableTyCon :: TyCon -> Validity -boxedMarshalableTyCon tc - | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey - , int32TyConKey, int64TyConKey - , wordTyConKey, word8TyConKey, word16TyConKey - , word32TyConKey, word64TyConKey - , floatTyConKey, doubleTyConKey - , ptrTyConKey, funPtrTyConKey - , charTyConKey - , stablePtrTyConKey - , boolTyConKey - ] - = IsValid - - | otherwise = NotValid empty - -legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity --- Check args of 'foreign import prim', only allow simple unlifted types. --- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since --- currently they're of the wrong kind to use in function args anyway. -legalFIPrimArgTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) - = validIfUnliftedFFITypes dflags - | otherwise - = NotValid unlifted_only - -legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity --- Check result type of 'foreign import prim'. Allow simple unlifted --- types and also unboxed tuple and sum result types. -legalFIPrimResultTyCon dflags tc - | isUnliftedTyCon tc - , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc - || not (null (tyConPrimRep tc)) -- Note [Marshalling void] - = validIfUnliftedFFITypes dflags - - | otherwise - = NotValid unlifted_only - -unlifted_only :: MsgDoc -unlifted_only = text "foreign import prim only accepts simple unlifted types" - -validIfUnliftedFFITypes :: DynFlags -> Validity -validIfUnliftedFFITypes dflags - | xopt LangExt.UnliftedFFITypes dflags = IsValid - | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") - -{- -Note [Marshalling void] -~~~~~~~~~~~~~~~~~~~~~~~ -We don't treat State# (whose PrimRep is VoidRep) as marshalable. -In turn that means you can't write - foreign import foo :: Int -> State# RealWorld - -Reason: the back end falls over with panic "primRepHint:VoidRep"; - and there is no compelling reason to permit it --} - -{- -************************************************************************ -* * - The "Paterson size" of a type -* * -************************************************************************ --} - -{- -Note [Paterson conditions on PredTypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are considering whether *class* constraints terminate -(see Note [Paterson conditions]). Precisely, the Paterson conditions -would have us check that "the constraint has fewer constructors and variables -(taken together and counting repetitions) than the head.". - -However, we can be a bit more refined by looking at which kind of constraint -this actually is. There are two main tricks: - - 1. It seems like it should be OK not to count the tuple type constructor - for a PredType like (Show a, Eq a) :: Constraint, since we don't - count the "implicit" tuple in the ThetaType itself. - - In fact, the Paterson test just checks *each component* of the top level - ThetaType against the size bound, one at a time. By analogy, it should be - OK to return the size of the *largest* tuple component as the size of the - whole tuple. - - 2. Once we get into an implicit parameter or equality we - can't get back to a class constraint, so it's safe - to say "size 0". See #4200. - -NB: we don't want to detect PredTypes in sizeType (and then call -sizePred on them), or we might get an infinite loop if that PredType -is irreducible. See #5581. --} - -type TypeSize = IntWithInf - -sizeType :: Type -> TypeSize --- Size of a type: the number of variables and constructors --- Ignore kinds altogether -sizeType = go - where - go ty | Just exp_ty <- tcView ty = go exp_ty - go (TyVarTy {}) = 1 - go (TyConApp tc tys) - | isTypeFamilyTyCon tc = infinity -- Type-family applications can - -- expand to any arbitrary size - | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 - -- Why filter out invisible args? I suppose any - -- size ordering is sound, but why is this better? - -- I came across this when investigating #14010. - go (LitTy {}) = 1 - go (FunTy _ arg res) = go arg + go res + 1 - go (AppTy fun arg) = go fun + go arg - go (ForAllTy (Bndr tv vis) ty) - | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 - | otherwise = go ty + 1 - go (CastTy ty _) = go ty - go (CoercionTy {}) = 0 - -sizeTypes :: [Type] -> TypeSize -sizeTypes tys = sum (map sizeType tys) - ------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------ ------------------------ --- | For every arg a tycon can take, the returned list says True if the argument --- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to --- allow for oversaturation. -tcTyConVisibilities :: TyCon -> [Bool] -tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True - where - tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) - tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc)) - --- | If the tycon is applied to the types, is the next argument visible? -isNextTyConArgVisible :: TyCon -> [Type] -> Bool -isNextTyConArgVisible tc tys - = tcTyConVisibilities tc `getNth` length tys - --- | Should this type be applied to a visible argument? -isNextArgVisible :: TcType -> Bool -isNextArgVisible ty - | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr - | otherwise = True - -- this second case might happen if, say, we have an unzonked TauTv. - -- But TauTvs can't range over types that take invisible arguments diff --git a/typecheck/TcType.hs-boot b/typecheck/TcType.hs-boot deleted file mode 100644 --- a/typecheck/TcType.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module TcType where -import Outputable( SDoc ) -import {-# SOURCE #-} TyCoRep( Type ) -import {-# SOURCE #-} TyCon (TyCon) -import Data.Maybe (Maybe) - -data MetaDetails - -data TcTyVarDetails -pprTcTyVarDetails :: TcTyVarDetails -> SDoc -vanillaSkolemTv :: TcTyVarDetails -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) diff --git a/typecheck/TcTypeNats.hs b/typecheck/TcTypeNats.hs deleted file mode 100644 --- a/typecheck/TcTypeNats.hs +++ /dev/null @@ -1,992 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TcTypeNats - ( typeNatTyCons - , typeNatCoAxiomRules - , BuiltInSynFamily(..) - - -- If you define a new built-in type family, make sure to export its TyCon - -- from here as well. - -- See Note [Adding built-in type families] - , typeNatAddTyCon - , typeNatMulTyCon - , typeNatExpTyCon - , typeNatLeqTyCon - , typeNatSubTyCon - , typeNatDivTyCon - , typeNatModTyCon - , typeNatLogTyCon - , typeNatCmpTyCon - , typeSymbolCmpTyCon - , typeSymbolAppendTyCon - ) where - -import GhcPrelude - -import Type -import Pair -import TcType ( TcType, tcEqType ) -import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon - , Injectivity(..) ) -import Coercion ( Role(..) ) -import Constraint ( Xi ) -import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) -import Name ( Name, BuiltInSyntax(..) ) -import TysWiredIn -import TysPrim ( mkTemplateAnonTyConBinders ) -import PrelNames ( gHC_TYPELITS - , gHC_TYPENATS - , typeNatAddTyFamNameKey - , typeNatMulTyFamNameKey - , typeNatExpTyFamNameKey - , typeNatLeqTyFamNameKey - , typeNatSubTyFamNameKey - , typeNatDivTyFamNameKey - , typeNatModTyFamNameKey - , typeNatLogTyFamNameKey - , typeNatCmpTyFamNameKey - , typeSymbolCmpTyFamNameKey - , typeSymbolAppendFamNameKey - ) -import FastString ( FastString - , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS - ) -import qualified Data.Map as Map -import Data.Maybe ( isJust ) -import Control.Monad ( guard ) -import Data.List ( isPrefixOf, isSuffixOf ) - -{- -Note [Type-level literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are currently two forms of type-level literals: natural numbers, and -symbols (even though this module is named TcTypeNats, it covers both). - -Type-level literals are supported by CoAxiomRules (conditional axioms), which -power the built-in type families (see Note [Adding built-in type families]). -Currently, all built-in type families are for the express purpose of supporting -type-level literals. - -See also the Wiki page: - - https://gitlab.haskell.org/ghc/ghc/wikis/type-nats - -Note [Adding built-in type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a few steps to adding a built-in type family: - -* Adding a unique for the type family TyCon - - These go in PrelNames. It will likely be of the form - @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that - has not been chosen before in PrelNames. There are several examples already - in PrelNames—see, for instance, typeNatAddTyFamNameKey. - -* Adding the type family TyCon itself - - This goes in TcTypeNats. There are plenty of examples of how to define - these—see, for instance, typeNatAddTyCon. - - Once your TyCon has been defined, be sure to: - - - Export it from TcTypeNats. (Not doing so caused #14632.) - - Include it in the typeNatTyCons list, defined in TcTypeNats. - -* Exposing associated type family axioms - - When defining the type family TyCon, you will need to define an axiom for - the type family in general (see, for instance, axAddDef), and perhaps other - auxiliary axioms for special cases of the type family (see, for instance, - axAdd0L and axAdd0R). - - After you have defined all of these axioms, be sure to include them in the - typeNatCoAxiomRules list, defined in TcTypeNats. - (Not doing so caused #14934.) - -* Define the type family somewhere - - Finally, you will need to define the type family somewhere, likely in @base@. - Currently, all of the built-in type families are defined in GHC.TypeLits or - GHC.TypeNats, so those are likely candidates. - - Since the behavior of your built-in type family is specified in TcTypeNats, - you should give an open type family definition with no instances, like so: - - type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat - - Changing the argument and result kinds as appropriate. - -* Update the relevant test cases - - The GHC test suite will likely need to be updated after you add your built-in - type family. For instance: - - - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added - a test there, the expected output of T9181 will need to change. - - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit - tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have - runtime unit tests. Consider adding further unit tests to those if your - built-in type family deals with Nats or Symbols, respectively. --} - -{------------------------------------------------------------------------------- -Built-in type constructors for functions on type-level nats --} - --- The list of built-in type family TyCons that GHC uses. --- If you define a built-in type family, make sure to add it to this list. --- See Note [Adding built-in type families] -typeNatTyCons :: [TyCon] -typeNatTyCons = - [ typeNatAddTyCon - , typeNatMulTyCon - , typeNatExpTyCon - , typeNatLeqTyCon - , typeNatSubTyCon - , typeNatDivTyCon - , typeNatModTyCon - , typeNatLogTyCon - , typeNatCmpTyCon - , typeSymbolCmpTyCon - , typeSymbolAppendTyCon - ] - -typeNatAddTyCon :: TyCon -typeNatAddTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamAdd - , sfInteractTop = interactTopAdd - , sfInteractInert = interactInertAdd - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+") - typeNatAddTyFamNameKey typeNatAddTyCon - -typeNatSubTyCon :: TyCon -typeNatSubTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamSub - , sfInteractTop = interactTopSub - , sfInteractInert = interactInertSub - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-") - typeNatSubTyFamNameKey typeNatSubTyCon - -typeNatMulTyCon :: TyCon -typeNatMulTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamMul - , sfInteractTop = interactTopMul - , sfInteractInert = interactInertMul - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*") - typeNatMulTyFamNameKey typeNatMulTyCon - -typeNatDivTyCon :: TyCon -typeNatDivTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamDiv - , sfInteractTop = interactTopDiv - , sfInteractInert = interactInertDiv - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div") - typeNatDivTyFamNameKey typeNatDivTyCon - -typeNatModTyCon :: TyCon -typeNatModTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamMod - , sfInteractTop = interactTopMod - , sfInteractInert = interactInertMod - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod") - typeNatModTyFamNameKey typeNatModTyCon - - - - - -typeNatExpTyCon :: TyCon -typeNatExpTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamExp - , sfInteractTop = interactTopExp - , sfInteractInert = interactInertExp - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^") - typeNatExpTyFamNameKey typeNatExpTyCon - -typeNatLogTyCon :: TyCon -typeNatLogTyCon = mkTypeNatFunTyCon1 name - BuiltInSynFamily - { sfMatchFam = matchFamLog - , sfInteractTop = interactTopLog - , sfInteractInert = interactInertLog - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2") - typeNatLogTyFamNameKey typeNatLogTyCon - - - -typeNatLeqTyCon :: TyCon -typeNatLeqTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - boolTy - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?") - typeNatLeqTyFamNameKey typeNatLeqTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamLeq - , sfInteractTop = interactTopLeq - , sfInteractInert = interactInertLeq - } - -typeNatCmpTyCon :: TyCon -typeNatCmpTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - orderingKind - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat") - typeNatCmpTyFamNameKey typeNatCmpTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamCmpNat - , sfInteractTop = interactTopCmpNat - , sfInteractInert = \_ _ _ _ -> [] - } - -typeSymbolCmpTyCon :: TyCon -typeSymbolCmpTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) - orderingKind - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol") - typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon - ops = BuiltInSynFamily - { sfMatchFam = matchFamCmpSymbol - , sfInteractTop = interactTopCmpSymbol - , sfInteractInert = \_ _ _ _ -> [] - } - -typeSymbolAppendTyCon :: TyCon -typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamAppendSymbol - , sfInteractTop = interactTopAppendSymbol - , sfInteractInert = interactInertAppendSymbol - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol") - typeSymbolAppendFamNameKey typeSymbolAppendTyCon - - - --- Make a unary built-in constructor of kind: Nat -> Nat -mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon -mkTypeNatFunTyCon1 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeNatKind ]) - typeNatKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - - --- Make a binary built-in constructor of kind: Nat -> Nat -> Nat -mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon -mkTypeNatFunTyCon2 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) - typeNatKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - --- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol -mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon -mkTypeSymbolFunTyCon2 op tcb = - mkFamilyTyCon op - (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) - typeSymbolKind - Nothing - (BuiltInSynFamTyCon tcb) - Nothing - NotInjective - - -{------------------------------------------------------------------------------- -Built-in rules axioms --------------------------------------------------------------------------------} - --- If you add additional rules, please remember to add them to --- `typeNatCoAxiomRules` also. --- See Note [Adding built-in type families] -axAddDef - , axMulDef - , axExpDef - , axLeqDef - , axCmpNatDef - , axCmpSymbolDef - , axAppendSymbolDef - , axAdd0L - , axAdd0R - , axMul0L - , axMul0R - , axMul1L - , axMul1R - , axExp1L - , axExp0R - , axExp1R - , axLeqRefl - , axCmpNatRefl - , axCmpSymbolRefl - , axLeq0L - , axSubDef - , axSub0R - , axAppendSymbol0R - , axAppendSymbol0L - , axDivDef - , axDiv1 - , axModDef - , axMod1 - , axLogDef - :: CoAxiomRule - -axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $ - \x y -> Just $ num (x + y) - -axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $ - \x y -> Just $ num (x * y) - -axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $ - \x y -> Just $ num (x ^ y) - -axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $ - \x y -> Just $ bool (x <= y) - -axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon - $ \x y -> Just $ ordering (compare x y) - -axCmpSymbolDef = - CoAxiomRule - { coaxrName = fsLit "CmpSymbolDef" - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isStrLitTy s2 - t2' <- isStrLitTy t2 - return (mkTyConApp typeSymbolCmpTyCon [s1,t1] === - ordering (compare s2' t2')) } - -axAppendSymbolDef = CoAxiomRule - { coaxrName = fsLit "AppendSymbolDef" - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isStrLitTy s2 - t2' <- isStrLitTy t2 - let z = mkStrLitTy (appendFS s2' t2') - return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z) - } - -axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ - \x y -> fmap num (minus x y) - -axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $ - \x y -> do guard (y /= 0) - return (num (div x y)) - -axModDef = mkBinAxiom "ModDef" typeNatModTyCon $ - \x y -> do guard (y /= 0) - return (num (mod x y)) - -axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $ - \x -> do (a,_) <- genLog x 2 - return (num a) - -axAdd0L = mkAxiom1 "Add0L" $ \(Pair s t) -> (num 0 .+. s) === t -axAdd0R = mkAxiom1 "Add0R" $ \(Pair s t) -> (s .+. num 0) === t -axSub0R = mkAxiom1 "Sub0R" $ \(Pair s t) -> (s .-. num 0) === t -axMul0L = mkAxiom1 "Mul0L" $ \(Pair s _) -> (num 0 .*. s) === num 0 -axMul0R = mkAxiom1 "Mul0R" $ \(Pair s _) -> (s .*. num 0) === num 0 -axMul1L = mkAxiom1 "Mul1L" $ \(Pair s t) -> (num 1 .*. s) === t -axMul1R = mkAxiom1 "Mul1R" $ \(Pair s t) -> (s .*. num 1) === t -axDiv1 = mkAxiom1 "Div1" $ \(Pair s t) -> (tDiv s (num 1) === t) -axMod1 = mkAxiom1 "Mod1" $ \(Pair s _) -> (tMod s (num 1) === num 0) - -- XXX: Shouldn't we check that _ is 0? -axExp1L = mkAxiom1 "Exp1L" $ \(Pair s _) -> (num 1 .^. s) === num 1 -axExp0R = mkAxiom1 "Exp0R" $ \(Pair s _) -> (s .^. num 0) === num 1 -axExp1R = mkAxiom1 "Exp1R" $ \(Pair s t) -> (s .^. num 1) === t -axLeqRefl = mkAxiom1 "LeqRefl" $ \(Pair s _) -> (s <== s) === bool True -axCmpNatRefl = mkAxiom1 "CmpNatRefl" - $ \(Pair s _) -> (cmpNat s s) === ordering EQ -axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl" - $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ -axLeq0L = mkAxiom1 "Leq0L" $ \(Pair s _) -> (num 0 <== s) === bool True -axAppendSymbol0R = mkAxiom1 "Concat0R" - $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t -axAppendSymbol0L = mkAxiom1 "Concat0L" - $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t - --- The list of built-in type family axioms that GHC uses. --- If you define new axioms, make sure to include them in this list. --- See Note [Adding built-in type families] -typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule -typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) - [ axAddDef - , axMulDef - , axExpDef - , axLeqDef - , axCmpNatDef - , axCmpSymbolDef - , axAppendSymbolDef - , axAdd0L - , axAdd0R - , axMul0L - , axMul0R - , axMul1L - , axMul1R - , axExp1L - , axExp0R - , axExp1R - , axLeqRefl - , axCmpNatRefl - , axCmpSymbolRefl - , axLeq0L - , axSubDef - , axSub0R - , axAppendSymbol0R - , axAppendSymbol0L - , axDivDef - , axDiv1 - , axModDef - , axMod1 - , axLogDef - ] - - - -{------------------------------------------------------------------------------- -Various utilities for making axioms and types --------------------------------------------------------------------------------} - -(.+.) :: Type -> Type -> Type -s .+. t = mkTyConApp typeNatAddTyCon [s,t] - -(.-.) :: Type -> Type -> Type -s .-. t = mkTyConApp typeNatSubTyCon [s,t] - -(.*.) :: Type -> Type -> Type -s .*. t = mkTyConApp typeNatMulTyCon [s,t] - -tDiv :: Type -> Type -> Type -tDiv s t = mkTyConApp typeNatDivTyCon [s,t] - -tMod :: Type -> Type -> Type -tMod s t = mkTyConApp typeNatModTyCon [s,t] - -(.^.) :: Type -> Type -> Type -s .^. t = mkTyConApp typeNatExpTyCon [s,t] - -(<==) :: Type -> Type -> Type -s <== t = mkTyConApp typeNatLeqTyCon [s,t] - -cmpNat :: Type -> Type -> Type -cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] - -cmpSymbol :: Type -> Type -> Type -cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t] - -appendSymbol :: Type -> Type -> Type -appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t] - -(===) :: Type -> Type -> Pair Type -x === y = Pair x y - -num :: Integer -> Type -num = mkNumLitTy - -bool :: Bool -> Type -bool b = if b then mkTyConApp promotedTrueDataCon [] - else mkTyConApp promotedFalseDataCon [] - -isBoolLitTy :: Type -> Maybe Bool -isBoolLitTy tc = - do (tc,[]) <- splitTyConApp_maybe tc - case () of - _ | tc == promotedFalseDataCon -> return False - | tc == promotedTrueDataCon -> return True - | otherwise -> Nothing - -orderingKind :: Kind -orderingKind = mkTyConApp orderingTyCon [] - -ordering :: Ordering -> Type -ordering o = - case o of - LT -> mkTyConApp promotedLTDataCon [] - EQ -> mkTyConApp promotedEQDataCon [] - GT -> mkTyConApp promotedGTDataCon [] - -isOrderingLitTy :: Type -> Maybe Ordering -isOrderingLitTy tc = - do (tc1,[]) <- splitTyConApp_maybe tc - case () of - _ | tc1 == promotedLTDataCon -> return LT - | tc1 == promotedEQDataCon -> return EQ - | tc1 == promotedGTDataCon -> return GT - | otherwise -> Nothing - -known :: (Integer -> Bool) -> TcType -> Bool -known p x = case isNumLitTy x of - Just a -> p a - Nothing -> False - - -mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule -mkUnAxiom str tc f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2] <- return cs - s2' <- isNumLitTy s2 - z <- f s2' - return (mkTyConApp tc [s1] === z) - } - - - --- For the definitional axioms -mkBinAxiom :: String -> TyCon -> - (Integer -> Integer -> Maybe Type) -> CoAxiomRule -mkBinAxiom str tc f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal, Nominal] - , coaxrRole = Nominal - , coaxrProves = \cs -> - do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isNumLitTy s2 - t2' <- isNumLitTy t2 - z <- f s2' t2' - return (mkTyConApp tc [s1,t1] === z) - } - - - -mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule -mkAxiom1 str f = - CoAxiomRule - { coaxrName = fsLit str - , coaxrAsmpRoles = [Nominal] - , coaxrRole = Nominal - , coaxrProves = \case [eqn] -> Just (f eqn) - _ -> Nothing - } - - -{------------------------------------------------------------------------------- -Evaluation --------------------------------------------------------------------------------} - -matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamAdd [s,t] - | Just 0 <- mbX = Just (axAdd0L, [t], t) - | Just 0 <- mbY = Just (axAdd0R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axAddDef, [s,t], num (x + y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamAdd _ = Nothing - -matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamSub [s,t] - | Just 0 <- mbY = Just (axSub0R, [s], s) - | Just x <- mbX, Just y <- mbY, Just z <- minus x y = - Just (axSubDef, [s,t], num z) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamSub _ = Nothing - -matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamMul [s,t] - | Just 0 <- mbX = Just (axMul0L, [t], num 0) - | Just 0 <- mbY = Just (axMul0R, [s], num 0) - | Just 1 <- mbX = Just (axMul1L, [t], t) - | Just 1 <- mbY = Just (axMul1R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axMulDef, [s,t], num (x * y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamMul _ = Nothing - -matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamDiv [s,t] - | Just 1 <- mbY = Just (axDiv1, [s], s) - | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamDiv _ = Nothing - -matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamMod [s,t] - | Just 1 <- mbY = Just (axMod1, [s], num 0) - | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamMod _ = Nothing - - - -matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamExp [s,t] - | Just 0 <- mbY = Just (axExp0R, [s], num 1) - | Just 1 <- mbX = Just (axExp1L, [t], num 1) - | Just 1 <- mbY = Just (axExp1R, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axExpDef, [s,t], num (x ^ y)) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamExp _ = Nothing - -matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamLog [s] - | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n) - where mbX = isNumLitTy s -matchFamLog _ = Nothing - - -matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamLeq [s,t] - | Just 0 <- mbX = Just (axLeq0L, [t], bool True) - | Just x <- mbX, Just y <- mbY = - Just (axLeqDef, [s,t], bool (x <= y)) - | tcEqType s t = Just (axLeqRefl, [s], bool True) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamLeq _ = Nothing - -matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamCmpNat [s,t] - | Just x <- mbX, Just y <- mbY = - Just (axCmpNatDef, [s,t], ordering (compare x y)) - | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ) - where mbX = isNumLitTy s - mbY = isNumLitTy t -matchFamCmpNat _ = Nothing - -matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamCmpSymbol [s,t] - | Just x <- mbX, Just y <- mbY = - Just (axCmpSymbolDef, [s,t], ordering (compare x y)) - | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ) - where mbX = isStrLitTy s - mbY = isStrLitTy t -matchFamCmpSymbol _ = Nothing - -matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) -matchFamAppendSymbol [s,t] - | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t) - | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s) - | Just x <- mbX, Just y <- mbY = - Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y)) - where - mbX = isStrLitTy s - mbY = isStrLitTy t -matchFamAppendSymbol _ = Nothing - -{------------------------------------------------------------------------------- -Interact with axioms --------------------------------------------------------------------------------} - -interactTopAdd :: [Xi] -> Xi -> [Pair Type] -interactTopAdd [s,t] r - | Just 0 <- mbZ = [ s === num 0, t === num 0 ] -- (s + t ~ 0) => (s ~ 0, t ~ 0) - | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y] -- (5 + t ~ 8) => (t ~ 3) - | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x] -- (s + 5 ~ 8) => (s ~ 3) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopAdd _ _ = [] - -{- -Note [Weakened interaction rule for subtraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A simpler interaction here might be: - - `s - t ~ r` --> `t + r ~ s` - -This would enable us to reuse all the code for addition. -Unfortunately, this works a little too well at the moment. -Consider the following example: - - 0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0) - -This (correctly) spots that the constraint cannot be solved. - -However, this may be a problem if the constraint did not -need to be solved in the first place! Consider the following example: - -f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5 -f = id - -Currently, GHC is strict while evaluating functions, so this does not -work, because even though the `If` should evaluate to `5 - 0`, we -also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`, -which fails. - -So, for the time being, we only add an improvement when the RHS is a constant, -which happens to work OK for the moment, although clearly we need to do -something more general. --} -interactTopSub :: [Xi] -> Xi -> [Pair Type] -interactTopSub [s,t] r - | Just z <- mbZ = [ s === (num z .+. t) ] -- (s - t ~ 5) => (5 + t ~ s) - where - mbZ = isNumLitTy r -interactTopSub _ _ = [] - - - - - -interactTopMul :: [Xi] -> Xi -> [Pair Type] -interactTopMul [s,t] r - | Just 1 <- mbZ = [ s === num 1, t === num 1 ] -- (s * t ~ 1) => (s ~ 1, t ~ 1) - | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y] -- (3 * t ~ 15) => (t ~ 5) - | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x] -- (s * 3 ~ 15) => (s ~ 5) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopMul _ _ = [] - -interactTopDiv :: [Xi] -> Xi -> [Pair Type] -interactTopDiv _ _ = [] -- I can't think of anything... - -interactTopMod :: [Xi] -> Xi -> [Pair Type] -interactTopMod _ _ = [] -- I can't think of anything... - -interactTopExp :: [Xi] -> Xi -> [Pair Type] -interactTopExp [s,t] r - | Just 0 <- mbZ = [ s === num 0 ] -- (s ^ t ~ 0) => (s ~ 0) - | Just x <- mbX, Just z <- mbZ, Just y <- logExact z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3) - | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3) - where - mbX = isNumLitTy s - mbY = isNumLitTy t - mbZ = isNumLitTy r -interactTopExp _ _ = [] - -interactTopLog :: [Xi] -> Xi -> [Pair Type] -interactTopLog _ _ = [] -- I can't think of anything... - - - -interactTopLeq :: [Xi] -> Xi -> [Pair Type] -interactTopLeq [s,t] r - | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0) - where - mbY = isNumLitTy t - mbZ = isBoolLitTy r -interactTopLeq _ _ = [] - -interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] -interactTopCmpNat [s,t] r - | Just EQ <- isOrderingLitTy r = [ s === t ] -interactTopCmpNat _ _ = [] - -interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type] -interactTopCmpSymbol [s,t] r - | Just EQ <- isOrderingLitTy r = [ s === t ] -interactTopCmpSymbol _ _ = [] - -interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type] -interactTopAppendSymbol [s,t] r - -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "") - | Just z <- mbZ, nullFS z = - [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ] - - -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar") - | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z = - [ t === mkStrLitTy (mkFastString $ drop (length x) z) ] - - -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo") - | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z = - [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ] - - where - mbX = isStrLitTy s - mbY = isStrLitTy t - mbZ = isStrLitTy r - -interactTopAppendSymbol _ _ = [] - -{------------------------------------------------------------------------------- -Interaction with inerts --------------------------------------------------------------------------------} - -interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertAdd [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertAdd _ _ _ _ = [] - -interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertSub [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertSub _ _ _ _ = [] - -interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertMul [x1,y1] z1 [x2,y2] z2 - | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 - -interactInertMul _ _ _ _ = [] - -interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertDiv _ _ _ _ = [] - -interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertMod _ _ _ _ = [] - -interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertExp [x1,y1] z1 [x2,y2] z2 - | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 - -interactInertExp _ _ _ _ = [] - -interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertLog _ _ _ _ = [] - - -interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertLeq [x1,y1] z1 [x2,y2] z2 - | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ] - | bothTrue && tcEqType y1 x2 = [ (x1 <== y2) === bool True ] - | bothTrue && tcEqType y2 x1 = [ (x2 <== y1) === bool True ] - where bothTrue = isJust $ do True <- isBoolLitTy z1 - True <- isBoolLitTy z2 - return () - -interactInertLeq _ _ _ _ = [] - - -interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] -interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2 - | sameZ && tcEqType x1 x2 = [ y1 === y2 ] - | sameZ && tcEqType y1 y2 = [ x1 === x2 ] - where sameZ = tcEqType z1 z2 -interactInertAppendSymbol _ _ _ _ = [] - - - -{- ----------------------------------------------------------------------------- -These inverse functions are used for simplifying propositions using -concrete natural numbers. ------------------------------------------------------------------------------ -} - --- | Subtract two natural numbers. -minus :: Integer -> Integer -> Maybe Integer -minus x y = if x >= y then Just (x - y) else Nothing - --- | Compute the exact logarithm of a natural number. --- The logarithm base is the second argument. -logExact :: Integer -> Integer -> Maybe Integer -logExact x y = do (z,True) <- genLog x y - return z - - --- | Divide two natural numbers. -divide :: Integer -> Integer -> Maybe Integer -divide _ 0 = Nothing -divide x y = case divMod x y of - (a,0) -> Just a - _ -> Nothing - --- | Compute the exact root of a natural number. --- The second argument specifies which root we are computing. -rootExact :: Integer -> Integer -> Maybe Integer -rootExact x y = do (z,True) <- genRoot x y - return z - - - -{- | Compute the n-th root of a natural number, rounded down to -the closest natural number. The boolean indicates if the result -is exact (i.e., True means no rounding was done, False means rounded down). -The second argument specifies which root we are computing. -} -genRoot :: Integer -> Integer -> Maybe (Integer, Bool) -genRoot _ 0 = Nothing -genRoot x0 1 = Just (x0, True) -genRoot x0 root = Just (search 0 (x0+1)) - where - search from to = let x = from + div (to - from) 2 - a = x ^ root - in case compare a x0 of - EQ -> (x, True) - LT | x /= from -> search x to - | otherwise -> (from, False) - GT | x /= to -> search from x - | otherwise -> (from, False) - -{- | Compute the logarithm of a number in the given base, rounded down to the -closest integer. The boolean indicates if we the result is exact -(i.e., True means no rounding happened, False means we rounded down). -The logarithm base is the second argument. -} -genLog :: Integer -> Integer -> Maybe (Integer, Bool) -genLog x 0 = if x == 1 then Just (0, True) else Nothing -genLog _ 1 = Nothing -genLog 0 _ = Nothing -genLog x base = Just (exactLoop 0 x) - where - exactLoop s i - | i == 1 = (s,True) - | i < base = (s,False) - | otherwise = - let s1 = s + 1 - in s1 `seq` case divMod i base of - (j,r) - | r == 0 -> exactLoop s1 j - | otherwise -> (underLoop s1 j, False) - - underLoop s i - | i < base = s - | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) diff --git a/typecheck/TcTypeable.hs b/typecheck/TcTypeable.hs deleted file mode 100644 --- a/typecheck/TcTypeable.hs +++ /dev/null @@ -1,758 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module TcTypeable(mkTypeableBinds, tyConIsTypeable) where - -#include "HsVersions.h" - -import GhcPrelude - -import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) ) -import IfaceEnv( newGlobalBinder ) -import TyCoRep( Type(..), TyLit(..) ) -import TcEnv -import TcEvidence ( mkWpTyApps ) -import TcRnMonad -import TcType -import HscTypes ( lookupId ) -import PrelNames -import TysPrim ( primTyCons ) -import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon - , vecCountTyCon, vecElemTyCon - , nilDataCon, consDataCon ) -import Name -import Id -import Type -import TyCon -import DataCon -import Module -import GHC.Hs -import DynFlags -import Bag -import Var ( VarBndr(..) ) -import CoreMap -import Constants -import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) -import Outputable -import FastString ( FastString, mkFastString, fsLit ) - -import Control.Monad.Trans.State -import Control.Monad.Trans.Class (lift) -import Data.Maybe ( isJust ) -import Data.Word( Word64 ) - -{- Note [Grand plan for Typeable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The overall plan is this: - -1. Generate a binding for each module p:M - (done in TcTypeable by mkModIdBindings) - M.$trModule :: GHC.Types.Module - M.$trModule = Module "p" "M" - ("tr" is short for "type representation"; see GHC.Types) - - We might want to add the filename too. - This can be used for the lightweight stack-tracing stuff too - - Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv - -2. Generate a binding for every data type declaration T in module M, - M.$tcT :: GHC.Types.TyCon - M.$tcT = TyCon ...fingerprint info... - $trModule - "T" - 0# - kind_rep - - Here 0# is the number of arguments expected by the tycon to fully determine - its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a - recipe for computing the kind of an instantiation of the tycon (see - Note [Representing TyCon kinds: KindRep] later in this file for details). - - We define (in TyCon) - - type TyConRepName = Name - - to use for these M.$tcT "tycon rep names". Note that these must be - treated as "never exported" names by Backpack (see - Note [Handling never-exported TyThings under Backpack]). Consequently - they get slightly special treatment in RnModIface.rnIfaceDecl. - -3. Record the TyConRepName in T's TyCon, including for promoted - data and type constructors, and kinds like * and #. - - The TyConRepName is not an "implicit Id". It's more like a record - selector: the TyCon knows its name but you have to go to the - interface file to find its type, value, etc - -4. Solve Typeable constraints. This is done by a custom Typeable solver, - currently in TcInteract, that use M.$tcT so solve (Typeable T). - -There are many wrinkles: - -* The timing of when we produce this bindings is rather important: they must be - defined after the rest of the module has been typechecked since we need to be - able to lookup Module and TyCon in the type environment and we may be - currently compiling GHC.Types (where they are defined). - -* GHC.Prim doesn't have any associated object code, so we need to put the - representations for types defined in this module elsewhere. We chose this - place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for - injecting the bindings for the GHC.Prim representions when compiling - GHC.Types. - -* TyCon.tyConRepModOcc is responsible for determining where to find - the representation binding for a given type. This is where we handle - the special case for GHC.Prim. - -* To save space and reduce dependencies, we need use quite low-level - representations for TyCon and Module. See GHC.Types - Note [Runtime representation of modules and tycons] - -* The KindReps can unfortunately get quite large. Moreover, the simplifier will - float out various pieces of them, resulting in numerous top-level bindings. - Consequently we mark the KindRep bindings as noinline, ensuring that the - float-outs don't make it into the interface file. This is important since - there is generally little benefit to inlining KindReps and they would - otherwise strongly affect compiler performance. - -* In general there are lots of things of kind *, * -> *, and * -> * -> *. To - reduce the number of bindings we need to produce, we generate their KindReps - once in GHC.Types. These are referred to as "built-in" KindReps below. - -* Even though KindReps aren't inlined, this scheme still has more of an effect on - compilation time than I'd like. This is especially true in the case of - families of type constructors (e.g. tuples and unboxed sums). The problem is - particularly bad in the case of sums, since each arity-N tycon brings with it - N promoted datacons, each with a KindRep whose size also scales with N. - Consequently we currently simply don't allow sums to be Typeable. - - In general we might consider moving some or all of this generation logic back - to the solver since the performance hit we take in doing this at - type-definition time is non-trivial and Typeable isn't very widely used. This - is discussed in #13261. - --} - --- | Generate the Typeable bindings for a module. This is the only --- entry-point of this module and is invoked by the typechecker driver in --- 'tcRnSrcDecls'. --- --- See Note [Grand plan for Typeable] in TcTypeable. -mkTypeableBinds :: TcM TcGblEnv -mkTypeableBinds - = do { dflags <- getDynFlags - ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do - { -- Create a binding for $trModule. - -- Do this before processing any data type declarations, - -- which need tcg_tr_module to be initialised - ; tcg_env <- mkModIdBindings - -- Now we can generate the TyCon representations... - -- First we handle the primitive TyCons if we are compiling GHC.Types - ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos - - -- Then we produce bindings for the user-defined types in this module. - ; setGblEnv tcg_env $ - do { mod <- getModule - ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) - mod_id = case tcg_tr_module tcg_env of -- Should be set by now - Just mod_id -> mod_id - Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) - ; traceTc "mkTypeableBinds" (ppr tycons) - ; this_mod_todos <- todoForTyCons mod mod_id tycons - ; mkTypeRepTodoBinds (this_mod_todos : prim_todos) - } } } - where - needs_typeable_binds tc - | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] - = False - | otherwise = - isAlgTyCon tc - || isDataFamilyTyCon tc - || isClassTyCon tc - - -{- ********************************************************************* -* * - Building top-level binding for $trModule -* * -********************************************************************* -} - -mkModIdBindings :: TcM TcGblEnv -mkModIdBindings - = do { mod <- getModule - ; loc <- getSrcSpanM - ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc - ; trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) - ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod - - ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv - ; return (tcg_env { tcg_tr_module = Just mod_id } - `addTypecheckedBinds` [unitBag mod_bind]) } - -mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) -mkModIdRHS mod - = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName - ; trNameLit <- mkTrNameLit - ; return $ nlHsDataCon trModuleDataCon - `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod)) - `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) - } - -{- ********************************************************************* -* * - Building type-representation bindings -* * -********************************************************************* -} - --- | Information we need about a 'TyCon' to generate its representation. We --- carry the 'Id' in order to share it between the generation of the @TyCon@ and --- @KindRep@ bindings. -data TypeableTyCon - = TypeableTyCon - { tycon :: !TyCon - , tycon_rep_id :: !Id - } - --- | A group of 'TyCon's in need of type-rep bindings. -data TypeRepTodo - = TypeRepTodo - { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding - , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint - , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint - , todo_tycons :: [TypeableTyCon] - -- ^ The 'TyCon's in need of bindings kinds - } - | ExportedKindRepsTodo [(Kind, Id)] - -- ^ Build exported 'KindRep' bindings for the given set of kinds. - -todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo -todoForTyCons mod mod_id tycons = do - trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName - let mk_rep_id :: TyConRepName -> Id - mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy - - let typeable_tycons :: [TypeableTyCon] - typeable_tycons = - [ TypeableTyCon { tycon = tc'' - , tycon_rep_id = mk_rep_id rep_name - } - | tc <- tycons - , tc' <- tc : tyConATs tc - -- We need type representations for any associated types - , let promoted = map promoteDataCon (tyConDataCons tc') - , tc'' <- tc' : promoted - -- Don't make bindings for data-family instance tycons. - -- Do, however, make them for their promoted datacon (see #13915). - , not $ isFamInstTyCon tc'' - , Just rep_name <- pure $ tyConRepName_maybe tc'' - , tyConIsTypeable tc'' - ] - return TypeRepTodo { mod_rep_expr = nlHsVar mod_id - , pkg_fingerprint = pkg_fpr - , mod_fingerprint = mod_fpr - , todo_tycons = typeable_tycons - } - where - mod_fpr = fingerprintString $ moduleNameString $ moduleName mod - pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod - -todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo -todoForExportedKindReps kinds = do - trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName - let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) - return $ ExportedKindRepsTodo $ map mkId kinds - --- | Generate TyCon bindings for a set of type constructors -mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv -mkTypeRepTodoBinds [] = getGblEnv -mkTypeRepTodoBinds todos - = do { stuff <- collect_stuff - - -- First extend the type environment with all of the bindings - -- which we are going to produce since we may need to refer to them - -- while generating kind representations (namely, when we want to - -- represent a TyConApp in a kind, we must be able to look up the - -- TyCon associated with the applied type constructor). - ; let produced_bndrs :: [Id] - produced_bndrs = [ tycon_rep_id - | todo@(TypeRepTodo{}) <- todos - , TypeableTyCon {..} <- todo_tycons todo - ] ++ - [ rep_id - | ExportedKindRepsTodo kinds <- todos - , (_, rep_id) <- kinds - ] - ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv - - ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] - mk_binds todo@(TypeRepTodo {}) = - mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) - mk_binds (ExportedKindRepsTodo kinds) = - mkExportedKindReps stuff kinds >> return [] - - ; (gbl_env, binds) <- setGblEnv gbl_env - $ runKindRepM (mapM mk_binds todos) - ; return $ gbl_env `addTypecheckedBinds` concat binds } - --- | Generate bindings for the type representation of a wired-in 'TyCon's --- defined by the virtual "GHC.Prim" module. This is where we inject the --- representation bindings for these primitive types into "GHC.Types" --- --- See Note [Grand plan for Typeable] in this module. -mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) -mkPrimTypeableTodos - = do { mod <- getModule - ; if mod == gHC_TYPES - then do { -- Build Module binding for GHC.Prim - trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let ghc_prim_module_id = - mkExportedVanillaId trGhcPrimModuleName - (mkTyConTy trModuleTyCon) - - ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id - <$> mkModIdRHS gHC_PRIM - - -- Extend our environment with above - ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] - getGblEnv - ; let gbl_env' = gbl_env `addTypecheckedBinds` - [unitBag ghc_prim_module_bind] - - -- Build TypeRepTodos for built-in KindReps - ; todo1 <- todoForExportedKindReps builtInKindReps - -- Build TypeRepTodos for types in GHC.Prim - ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id - ghcPrimTypeableTyCons - ; return ( gbl_env' , [todo1, todo2]) - } - else do gbl_env <- getGblEnv - return (gbl_env, []) - } - --- | This is the list of primitive 'TyCon's for which we must generate bindings --- in "GHC.Types". This should include all types defined in "GHC.Prim". --- --- The majority of the types we need here are contained in 'primTyCons'. --- However, not all of them: in particular unboxed tuples are absent since we --- don't want to include them in the original name cache. See --- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more. -ghcPrimTypeableTyCons :: [TyCon] -ghcPrimTypeableTyCons = concat - [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ] - , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] - , map sumTyCon [2..mAX_SUM_SIZE] - , primTyCons - ] - -data TypeableStuff - = Stuff { dflags :: DynFlags - , trTyConDataCon :: DataCon -- ^ of @TyCon@ - , trNameLit :: FastString -> LHsExpr GhcTc - -- ^ To construct @TrName@s - -- The various TyCon and DataCons of KindRep - , kindRepTyCon :: TyCon - , kindRepTyConAppDataCon :: DataCon - , kindRepVarDataCon :: DataCon - , kindRepAppDataCon :: DataCon - , kindRepFunDataCon :: DataCon - , kindRepTYPEDataCon :: DataCon - , kindRepTypeLitSDataCon :: DataCon - , typeLitSymbolDataCon :: DataCon - , typeLitNatDataCon :: DataCon - } - --- | Collect various tidbits which we'll need to generate TyCon representations. -collect_stuff :: TcM TypeableStuff -collect_stuff = do - dflags <- getDynFlags - trTyConDataCon <- tcLookupDataCon trTyConDataConName - kindRepTyCon <- tcLookupTyCon kindRepTyConName - kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName - kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName - kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName - kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName - kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName - kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName - typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName - typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName - trNameLit <- mkTrNameLit - return Stuff {..} - --- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we --- can save the work of repeating lookups when constructing many TyCon --- representations. -mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) -mkTrNameLit = do - trNameSDataCon <- tcLookupDataCon trNameSDataConName - let trNameLit :: FastString -> LHsExpr GhcTc - trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit fs) - return trNameLit - --- | Make Typeable bindings for the given 'TyCon'. -mkTyConRepBinds :: TypeableStuff -> TypeRepTodo - -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) -mkTyConRepBinds stuff todo (TypeableTyCon {..}) - = do -- Make a KindRep - let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon) - liftTc $ traceTc "mkTyConKindRepBinds" - (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) - let ctx = mkDeBruijnContext (map binderVar bndrs) - kind_rep <- getKindRep stuff ctx kind - - -- Make the TyCon binding - let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep - tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs - return $ unitBag tycon_rep_bind - --- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type --- families and polytypes. -tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && kindIsTypeable (dropForAlls $ tyConKind tc) - --- | Is a particular 'Kind' representable by @Typeable@? Here we look for --- polytypes and types containing casts (which may be, for instance, a type --- family). -kindIsTypeable :: Kind -> Bool --- We handle types of the form (TYPE LiftedRep) specifically to avoid --- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) --- to be typeable without inspecting rr, but this exhibits bad behavior --- when rr is a type family. -kindIsTypeable ty - | Just ty' <- coreView ty = kindIsTypeable ty' -kindIsTypeable ty - | isLiftedTypeKind ty = True -kindIsTypeable (TyVarTy _) = True -kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b -kindIsTypeable (FunTy _ a b) = kindIsTypeable a && kindIsTypeable b -kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc - && all kindIsTypeable args -kindIsTypeable (ForAllTy{}) = False -kindIsTypeable (LitTy _) = True -kindIsTypeable (CastTy{}) = False - -- See Note [Typeable instances for casted types] -kindIsTypeable (CoercionTy{}) = False - --- | Maps kinds to 'KindRep' bindings. This binding may either be defined in --- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') --- or a binding which we generated in the current module (in which case it will --- be 'Just' the RHS of the binding). -type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc)) - --- | A monad within which we will generate 'KindRep's. Here we keep an --- environment containing 'KindRep's which we've already generated so we can --- re-use them opportunistically. -newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } - deriving (Functor, Applicative, Monad) - -liftTc :: TcRn a -> KindRepM a -liftTc = KindRepM . lift - --- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they --- can be reused across modules. -builtInKindReps :: [(Kind, Name)] -builtInKindReps = - [ (star, starKindRepName) - , (mkVisFunTy star star, starArrStarKindRepName) - , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName) - ] - where - star = liftedTypeKind - -initialKindRepEnv :: TcRn KindRepEnv -initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps - where - add_kind_rep acc (k,n) = do - id <- tcLookupId n - return $! extendTypeMap acc k (id, Nothing) - --- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. -mkExportedKindReps :: TypeableStuff - -> [(Kind, Id)] -- ^ the kinds to generate bindings for - -> KindRepM () -mkExportedKindReps stuff = mapM_ kindrep_binding - where - empty_scope = mkDeBruijnContext [] - - kindrep_binding :: (Kind, Id) -> KindRepM () - kindrep_binding (kind, rep_bndr) = do - -- We build the binding manually here instead of using mkKindRepRhs - -- since the latter would find the built-in 'KindRep's in the - -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). - rhs <- mkKindRepRhs stuff empty_scope kind - addKindRepBind empty_scope kind rep_bndr rhs - -addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () -addKindRepBind in_scope k bndr rhs = - KindRepM $ modify' $ - \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) - --- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking --- environment. -runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a) -runKindRepM (KindRepM action) = do - kindRepEnv <- initialKindRepEnv - (res, reps_env) <- runStateT action kindRepEnv - let rep_binds = foldTypeMap to_bind_pair [] reps_env - to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest - to_bind_pair (_, Nothing) rest = rest - tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv - let binds = map (uncurry mkVarBind) rep_binds - tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds] - return (tcg_env', res) - --- | Produce or find a 'KindRep' for the given kind. -getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr GhcTc) -getKindRep stuff@(Stuff {..}) in_scope = go - where - go :: Kind -> KindRepM (LHsExpr GhcTc) - go = KindRepM . StateT . go' - - go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) - go' k env - -- Look through type synonyms - | Just k' <- tcView k = go' k' env - - -- We've already generated the needed KindRep - | Just (id, _) <- lookupTypeMapWithScope env in_scope k - = return (nlHsVar id, env) - - -- We need to construct a new KindRep binding - | otherwise - = do -- Place a NOINLINE pragma on KindReps since they tend to be quite - -- large and bloat interface files. - rep_bndr <- (`setInlinePragma` neverInlinePragma) - <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon) - - -- do we need to tie a knot here? - flip runStateT env $ unKindRepM $ do - rhs <- mkKindRepRhs stuff in_scope k - addKindRepBind in_scope k rep_bndr rhs - return $ nlHsVar rep_bndr - --- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and --- in-scope kind variable set. -mkKindRepRhs :: TypeableStuff - -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression -mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep - where - new_kind_rep k - -- We handle (TYPE LiftedRep) etc separately to make it - -- clear to consumers (e.g. serializers) that there is - -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) - | not (tcIsConstraintKind k) - -- Typeable respects the Constraint/Type distinction - -- so do not follow the special case here - , Just arg <- kindRep_maybe k - , Just (tc, []) <- splitTyConApp_maybe arg - , Just dc <- isPromotedDataCon_maybe tc - = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc - - new_kind_rep (TyVarTy v) - | Just idx <- lookupCME in_scope v - = return $ nlHsDataCon kindRepVarDataCon - `nlHsApp` nlHsIntLit (fromIntegral idx) - | otherwise - = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v) - - new_kind_rep (AppTy t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepAppDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep k@(TyConApp tc tys) - | Just rep_name <- tyConRepName_maybe tc - = do rep_id <- liftTc $ lookupId rep_name - tys' <- mapM (getKindRep stuff in_scope) tys - return $ nlHsDataCon kindRepTyConAppDataCon - `nlHsApp` nlHsVar rep_id - `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' - | otherwise - = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) - - new_kind_rep (ForAllTy (Bndr var _) ty) - = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) - - new_kind_rep (FunTy _ t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepFunDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep (LitTy (NumTyLit n)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitNatDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) - - new_kind_rep (LitTy (StrTyLit s)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitSymbolDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) - - -- See Note [Typeable instances for casted types] - new_kind_rep (CastTy ty co) - = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) - - new_kind_rep (CoercionTy co) - = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) - --- | Produce the right-hand-side of a @TyCon@ representation. -mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo - -> TyCon -- ^ the 'TyCon' we are producing a binding for - -> LHsExpr GhcTc -- ^ its 'KindRep' - -> LHsExpr GhcTc -mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep - = nlHsDataCon trTyConDataCon - `nlHsApp` nlHsLit (word64 dflags high) - `nlHsApp` nlHsLit (word64 dflags low) - `nlHsApp` mod_rep_expr todo - `nlHsApp` trNameLit (mkFastString tycon_str) - `nlHsApp` nlHsLit (int n_kind_vars) - `nlHsApp` kind_rep - where - n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) - tycon_str = add_tick (occNameString (getOccName tycon)) - add_tick s | isPromotedDataCon tycon = '\'' : s - | otherwise = s - - -- This must match the computation done in - -- Data.Typeable.Internal.mkTyConFingerprint. - Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo - , mod_fingerprint todo - , fingerprintString tycon_str - ] - - int :: Int -> HsLit GhcTc - int n = HsIntPrim (SourceText $ show n) (toInteger n) - -word64 :: DynFlags -> Word64 -> HsLit GhcTc -word64 dflags n - | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n) - | otherwise = HsWordPrim NoSourceText (toInteger n) - -{- -Note [Representing TyCon kinds: KindRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One of the operations supported by Typeable is typeRepKind, - - typeRepKind :: TypeRep (a :: k) -> TypeRep k - -Implementing this is a bit tricky for poly-kinded types like - - data Proxy (a :: k) :: Type - -- Proxy :: forall k. k -> Type - -The TypeRep encoding of `Proxy Type Int` looks like this: - - $tcProxy :: GHC.Types.TyCon - $trInt :: TypeRep Int - TrType :: TypeRep Type - - $trProxyType :: TypeRep (Proxy Type :: Type -> Type) - $trProxyType = TrTyCon $tcProxy - [TrType] -- kind variable instantiation - (tyConKind $tcProxy [TrType]) -- The TypeRep of - -- Type -> Type - - $trProxy :: TypeRep (Proxy Type Int) - $trProxy = TrApp $trProxyType $trInt TrType - - $tkProxy :: GHC.Types.KindRep - $tkProxy = KindRepFun (KindRepVar 0) - (KindRepTyConApp (KindRepTYPE LiftedRep) []) - -Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent -polymorphic types. So instead - - * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations) - of all its kind arguments. We can't represent a tycon that is - applied to only some of its kind arguments. - - * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a - GHC.Types.KindRep, which represents the polymorphic kind of Proxy - Proxy :: forall k. k->Type - - * A KindRep is just a recipe that we can instantiate with the - argument kinds, using Data.Typeable.Internal.tyConKind and - store in the relevant 'TypeRep' constructor. - - Data.Typeable.Internal.typeRepKind looks up the stored kinds. - - * In a KindRep, the kind variables are represented by 0-indexed - de Bruijn numbers: - - type KindBndr = Int -- de Bruijn index - - data KindRep = KindRepTyConApp TyCon [KindRep] - | KindRepVar !KindBndr - | KindRepApp KindRep KindRep - | KindRepFun KindRep KindRep - ... - -Note [Typeable instances for casted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At present, GHC does not manufacture TypeReps for types containing casts -(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow. - -In today's GHC, we normalize all types before computing their TypeRep. -For example: - - type family F a - type instance F Int = Type - - data D = forall (a :: F Int). MkD a - - tr :: TypeRep (MkD Bool) - tr = typeRep - -When computing the TypeRep for `MkD Bool` (or rather, -`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the -TypeRep for `MkD Bool`. - -Why does this work? If we have a type definition with casts, then the -only coercions that those casts can mention are either Refl, type family -axioms, built-in axioms, and coercions built from those roots. Therefore, -type family (and built-in) axioms will apply precisely when type normalization -succeeds (i.e, the type family applications are reducible). Therefore, it -is safe to ignore the cast entirely when constructing the TypeRep. - -This approach would be fragile in a future where GHC permits other forms of -coercions to appear in casts (e.g., coercion quantification as described -in #15710). If GHC permits local assumptions to appear in casts that cannot be -reduced with conventional normalization, then discarding casts would become -unsafe. It would be unfortunate for the Typeable solver to become a roadblock -obstructing such a future, so we deliberately do not implement the ability -for TypeReps to represent types with casts at the moment. - -If we do wish to allow this in the future, it will likely require modeling -casts and coercions in TypeReps themselves. --} - -mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc -mkList ty = foldr consApp (nilExpr ty) - where - cons = consExpr ty - consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc - consApp x xs = cons `nlHsApp` x `nlHsApp` xs - - nilExpr :: Type -> LHsExpr GhcTc - nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) - - consExpr :: Type -> LHsExpr GhcTc - consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/typecheck/TcUnify.hs b/typecheck/TcUnify.hs deleted file mode 100644 --- a/typecheck/TcUnify.hs +++ /dev/null @@ -1,2300 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Type subsumption and unification --} - -{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections, - ScopedTypeVariables #-} - -module TcUnify ( - -- Full-blown subsumption - tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET, - tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS, - tcSubTypeDS_NC_O, tcSubTypeET, - checkConstraints, checkTvConstraints, - buildImplicationFor, emitResidualTvConstraint, - - -- Various unifications - unifyType, unifyKind, - uType, promoteTcType, - swapOverTyVars, canSolveByUnification, - - -------------------------------- - -- Holes - tcInferInst, tcInferNoInst, - matchExpectedListTy, - matchExpectedTyConApp, - matchExpectedAppTy, - matchExpectedFunTys, - matchActualFunTys, matchActualFunTysPart, - matchExpectedFunKind, - - metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..) - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TyCoRep -import TyCoPpr( debugPprType ) -import TcMType -import TcRnMonad -import TcType -import Type -import Coercion -import TcEvidence -import Constraint -import Predicate -import TcOrigin -import Name( isSystemName ) -import Inst -import TyCon -import TysWiredIn -import TysPrim( tYPE ) -import Var -import VarSet -import VarEnv -import ErrUtils -import DynFlags -import BasicTypes -import Bag -import Util -import qualified GHC.LanguageExtensions as LangExt -import Outputable - -import Data.Maybe( isNothing ) -import Control.Monad -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - matchExpected functions -* * -************************************************************************ - -Note [Herald for matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'herald' always looks like: - "The equation(s) for 'f' have" - "The abstraction (\x.e) takes" - "The section (+ x) expects" - "The function 'f' is applied to" - -This is used to construct a message of form - - The abstraction `\Just 1 -> ...' takes two arguments - but its type `Maybe a -> a' has only one - - The equation(s) for `f' have two arguments - but its type `Maybe a -> a' has only one - - The section `(f 3)' requires 'f' to take two arguments - but its type `Int -> Int' has only one - - The function 'f' is applied to two arguments - but its type `Int -> Int' has only one - -When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the -picture, we have a choice in deciding whether to count the type applications as -proper arguments: - - The function 'f' is applied to one visible type argument - and two value arguments - but its type `forall a. a -> a` has only one visible type argument - and one value argument - -Or whether to include the type applications as part of the herald itself: - - The expression 'f @Int' is applied to two arguments - but its type `Int -> Int` has only one - -The latter is easier to implement and is arguably easier to understand, so we -choose to implement that option. - -Note [matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -matchExpectedFunTys checks that a sigma has the form -of an n-ary function. It passes the decomposed type to the -thing_inside, and returns a wrapper to coerce between the two types - -It's used wherever a language construct must have a functional type, -namely: - A lambda expression - A function definition - An operator section - -This function must be written CPS'd because it needs to fill in the -ExpTypes produced for arguments before it can fill in the ExpType -passed in. - --} - --- Use this one when you have an "expected" type. -matchExpectedFunTys :: forall a. - SDoc -- See Note [Herald for matchExpectedFunTys] - -> Arity - -> ExpRhoType -- deeply skolemised - -> ([ExpSigmaType] -> ExpRhoType -> TcM a) - -- must fill in these ExpTypes here - -> TcM (a, HsWrapper) --- If matchExpectedFunTys n ty = (_, wrap) --- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, --- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty - where - go acc_arg_tys 0 ty - = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty) - ; return (result, idHsWrapper) } - - go acc_arg_tys n ty - | Just ty' <- tcView ty = go acc_arg_tys n ty' - - go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = ASSERT( af == VisArg ) - do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) - (n-1) res_ty - ; return ( result - , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - go acc_arg_tys n ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go acc_arg_tys n ty' - Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go acc_arg_tys n ty = addErrCtxtM mk_ctxt $ - defer acc_arg_tys n (mkCheckExpType ty) - - ------------ - defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper) - defer acc_arg_tys n fun_ty - = do { more_arg_tys <- replicateM n newInferExpTypeNoInst - ; res_ty <- newInferExpTypeInst - ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty - ; more_arg_tys <- mapM readExpType more_arg_tys - ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty - ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty - -- Not a good origin at all :-( - ; return (result, wrap) } - - ------------ - mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty - ; let (args, _) = tcSplitFunTys ty - n_actual = length args - (env'', orig_ty') = tidyOpenType env' orig_tc_ty - ; return ( env'' - , mk_fun_tys_msg orig_ty' ty n_actual arity herald) } - where - orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty - -- this is safe b/c we're called from "go" - --- Like 'matchExpectedFunTys', but used when you have an "actual" type, --- for example in function application -matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) --- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r) --- then wrap : ty ~> (t1 -> ... -> tn -> ty_r) -matchActualFunTys herald ct_orig mb_thing arity ty - = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity - --- | Variant of 'matchActualFunTys' that works when supplied only part --- (that is, to the right of some arrows) of the full function type -matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> [TcSigmaType] -- reversed args. See (*) below. - -> Arity -- overall arity of the function, for errs - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) -matchActualFunTysPart herald ct_orig mb_thing arity orig_ty - orig_old_args full_arity - = go arity orig_old_args orig_ty --- Does not allocate unnecessary meta variables: if the input already is --- a function, we just take it apart. Not only is this efficient, --- it's important for higher rank: the argument might be of form --- (forall a. ty) -> other --- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd --- hide the forall inside a meta-variable - --- (*) Sometimes it's necessary to call matchActualFunTys with only part --- (that is, to the right of some arrows) of the type of the function in --- question. (See TcExpr.tcArgs.) This argument is the reversed list of --- arguments already seen (that is, not part of the TcSigmaType passed --- in elsewhere). - - where - -- This function has a bizarre mechanic: it accumulates arguments on - -- the way down and also builds an argument list on the way up. Why: - -- 1. The returns args list and the accumulated args list might be different. - -- The accumulated args include all the arg types for the function, - -- including those from before this function was called. The returned - -- list should include only those arguments produced by this call of - -- matchActualFunTys - -- - -- 2. The HsWrapper can be built only on the way up. It seems (more) - -- bizarre to build the HsWrapper but not the arg_tys. - -- - -- Refactoring is welcome. - go :: Arity - -> [TcSigmaType] -- accumulator of arguments (reversed) - -> TcSigmaType -- the remainder of the type as we're processing - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) - go 0 _ ty = return (idHsWrapper, [], ty) - - go n acc_args ty - | not (null tvs && null theta) - = do { (wrap1, rho) <- topInstantiate ct_orig ty - ; (wrap2, arg_tys, res_ty) <- go n acc_args rho - ; return (wrap2 <.> wrap1, arg_tys, res_ty) } - where - (tvs, theta, _) = tcSplitSigmaTy ty - - go n acc_args ty - | Just ty' <- tcView ty = go n acc_args ty' - - go n acc_args (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = ASSERT( af == VisArg ) - do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty - ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc - , arg_ty : tys, ty_r ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - go n acc_args ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go n acc_args ty' - Flexi -> defer n ty } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $ - defer n ty - - ------------ - defer n fun_ty - = do { arg_tys <- replicateM n newOpenFlexiTyVarTy - ; res_ty <- newOpenFlexiTyVarTy - ; let unif_fun_ty = mkVisFunTys arg_tys res_ty - ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; return (mkWpCastN co, arg_tys, res_ty) } - - ------------ - mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt arg_tys res_ty env - = do { let ty = mkVisFunTys arg_tys res_ty - ; (env1, zonked) <- zonkTidyTcType env ty - -- zonking might change # of args - ; let (zonked_args, _) = tcSplitFunTys zonked - n_actual = length zonked_args - (env2, unzonked) = tidyOpenType env1 ty - ; return ( env2 - , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) } - -mk_fun_tys_msg :: TcType -- the full type passed in (unzonked) - -> TcType -- the full type passed in (zonked) - -> Arity -- the # of args found - -> Arity -- the # of args wanted - -> SDoc -- overall herald - -> SDoc -mk_fun_tys_msg full_ty ty n_args full_arity herald - = herald <+> speakNOf full_arity (text "argument") <> comma $$ - if n_args == full_arity - then text "its type is" <+> quotes (pprType full_ty) <> - comma $$ - text "it is specialized to" <+> quotes (pprType ty) - else sep [text "but its type" <+> quotes (pprType ty), - if n_args == 0 then text "has none" - else text "has only" <+> speakN n_args] - ----------------------- -matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) --- Special case for lists -matchExpectedListTy exp_ty - = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty - ; return (co, elt_ty) } - ---------------------- -matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * - -> TcRhoType -- orig_ty - -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty - [TcSigmaType]) -- Element types, k1 k2 k3 a b c - --- It's used for wired-in tycons, so we call checkWiredInTyCon --- Precondition: never called with FunTyCon --- Precondition: input type :: * --- Postcondition: (T k1 k2 k3 a b c) is well-kinded - -matchExpectedTyConApp tc orig_ty - = ASSERT(tc /= funTyCon) go orig_ty - where - go ty - | Just ty' <- tcView ty - = go ty' - - go ty@(TyConApp tycon args) - | tc == tycon -- Common case - = return (mkTcNomReflCo ty, args) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- If the common case does not occur, instantiate a template - -- T k1 .. kn t1 .. tm, and unify with the original type - -- Doing it this way ensures that the types we return are - -- kind-compatible with T. For example, suppose we have - -- matchExpectedTyConApp T (f Maybe) - -- where data T a = MkT a - -- Then we don't want to instantiate T's data constructors with - -- (a::*) ~ Maybe - -- because that'll make types that are utterly ill-kinded. - -- This happened in #7368 - defer - = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) - ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) - ; let args = mkTyVarTys arg_tvs - tc_template = mkTyConApp tc args - ; co <- unifyType Nothing tc_template orig_ty - ; return (co, args) } - ----------------------- -matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (TcCoercion, -- m a ~N orig_ty - (TcSigmaType, TcSigmaType)) -- Returns m, a --- If the incoming type is a mutable type variable of kind k, then --- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. - -matchExpectedAppTy orig_ty - = go orig_ty - where - go ty - | Just ty' <- tcView ty = go ty' - - | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty)) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- Defer splitting by generating an equality constraint - defer - = do { ty1 <- newFlexiTyVarTy kind1 - ; ty2 <- newFlexiTyVarTy kind2 - ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty - ; return (co, (ty1, ty2)) } - - orig_kind = tcTypeKind orig_ty - kind1 = mkVisFunTy liftedTypeKind orig_kind - kind2 = liftedTypeKind -- m :: * -> k - -- arg type :: * - -{- -************************************************************************ -* * - Subsumption checking -* * -************************************************************************ - -Note [Subsumption checking: tcSubType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All the tcSubType calls have the form - tcSubType actual_ty expected_ty -which checks - actual_ty <= expected_ty - -That is, that a value of type actual_ty is acceptable in -a place expecting a value of type expected_ty. I.e. that - - actual ty is more polymorphic than expected_ty - -It returns a coercion function - co_fn :: actual_ty ~ expected_ty -which takes an HsExpr of type actual_ty into one of type -expected_ty. - -These functions do not actually check for subsumption. They check if -expected_ty is an appropriate annotation to use for something of type -actual_ty. This difference matters when thinking about visible type -application. For example, - - forall a. a -> forall b. b -> b - DOES NOT SUBSUME - forall a b. a -> b -> b - -because the type arguments appear in a different order. (Neither does -it work the other way around.) BUT, these types are appropriate annotations -for one another. Because the user directs annotations, it's OK if some -arguments shuffle around -- after all, it's what the user wants. -Bottom line: none of this changes with visible type application. - -There are a number of wrinkles (below). - -Notice that Wrinkle 1 and 2 both require eta-expansion, which technically -may increase termination. We just put up with this, in exchange for getting -more predictable type inference. - -Wrinkle 1: Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want (forall a. Int -> a -> a) <= (Int -> forall a. a->a) -(see section 4.6 of "Practical type inference for higher rank types") -So we must deeply-skolemise the RHS before we instantiate the LHS. - -That is why tc_sub_type starts with a call to tcSkolemise (which does the -deep skolemisation), and then calls the DS variant (which assumes -that expected_ty is deeply skolemised) - -Wrinkle 2: Note [Co/contra-variance of subsumption checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider g :: (Int -> Int) -> Int - f1 :: (forall a. a -> a) -> Int - f1 = g - - f2 :: (forall a. a -> a) -> Int - f2 x = g x -f2 will typecheck, and it would be odd/fragile if f1 did not. -But f1 will only typecheck if we have that - (Int->Int) -> Int <= (forall a. a->a) -> Int -And that is only true if we do the full co/contravariant thing -in the subsumption check. That happens in the FunTy case of -tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of -HsWrapper. - -Another powerful reason for doing this co/contra stuff is visible -in #9569, involving instantiation of constraint variables, -and again involving eta-expansion. - -Wrinkle 3: Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider tc150: - f y = \ (x::forall a. a->a). blah -The following happens: -* We will infer the type of the RHS, ie with a res_ty = alpha. -* Then the lambda will split alpha := beta -> gamma. -* And then we'll check tcSubType IsSwapped beta (forall a. a->a) - -So it's important that we unify beta := forall a. a->a, rather than -skolemising the type. --} - - --- | Call this variant when you are in a higher-rank situation and --- you know the right-hand type is deeply skolemised. -tcSubTypeHR :: CtOrigin -- ^ of the actual type - -> Maybe (HsExpr GhcRn) -- ^ If present, it has type ty_actual - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper -tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt - ------------------------- -tcSubTypeET :: CtOrigin -> UserTypeCtxt - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type_et t1 t2 --- => wrap :: t1 ~> t2 -tcSubTypeET orig ctxt (Check ty_actual) ty_expected - = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected - where - eq_orig = TypeEqOrigin { uo_actual = ty_expected - , uo_expected = ty_actual - , uo_thing = Nothing - , uo_visible = True } - -tcSubTypeET _ _ (Infer inf_res) ty_expected - = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected ) - -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never - -- has the ir_inst field set. Reason: in patterns (which is what - -- tcSubTypeET is used for) do not aggressively instantiate - do { co <- fill_infer_result ty_expected inf_res - -- Since ir_inst is false, we can skip fillInferResult - -- and go straight to fill_infer_result - - ; return (mkWpCastN (mkTcSymCo co)) } - ------------------------- -tcSubTypeO :: CtOrigin -- ^ of the actual type - -> UserTypeCtxt -- ^ of the expected type - -> TcSigmaType - -> ExpRhoType - -> TcM HsWrapper -tcSubTypeO orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig - , pprUserTypeCtxt ctxt - , ppr ty_actual - , ppr ty_expected ]) - ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected } - -addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a -addSubTypeCtxt ty_actual ty_expected thing_inside - | isRhoTy ty_actual -- If there is no polymorphism involved, the - , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) - = thing_inside -- gives enough context by itself - | otherwise - = addErrCtxtM mk_msg thing_inside - where - mk_msg tidy_env - = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual - -- might not be filled if we're debugging. ugh. - ; mb_ty_expected <- readExpType_maybe ty_expected - ; (tidy_env, ty_expected) <- case mb_ty_expected of - Just ty -> second mkCheckExpType <$> - zonkTidyTcType tidy_env ty - Nothing -> return (tidy_env, ty_expected) - ; ty_expected <- readExpType ty_expected - ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; let msg = vcat [ hang (text "When checking that:") - 4 (ppr ty_actual) - , nest 2 (hang (text "is more polymorphic than:") - 2 (ppr ty_expected)) ] - ; return (tidy_env, msg) } - ---------------- --- The "_NC" variants do not add a typechecker-error context; --- the caller is assumed to do that - -tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- Checks that actual <= expected --- Returns HsWrapper :: actual ~ expected -tcSubType_NC ctxt ty_actual ty_expected - = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected } - where - origin = TypeEqOrigin { uo_actual = ty_actual - , uo_expected = ty_expected - , uo_thing = Nothing - , uo_visible = True } - -tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised (hence "DS") -tcSubTypeDS orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected } - -tcSubTypeDS_NC_O :: CtOrigin -- origin used for instantiation only - -> UserTypeCtxt - -> Maybe (HsExpr GhcRn) - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised -tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected - = case ty_expected of - Infer inf_res -> fillInferResult inst_orig ty_actual inf_res - Check ty -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty - where - eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty - , uo_thing = ppr <$> m_thing - , uo_visible = True } - ---------------- -tc_sub_tc_type :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type t1 t2 --- => wrap :: t1 ~> t2 -tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected - | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , not (possibly_poly ty_actual) - = do { traceTc "tc_sub_tc_type (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - uType TypeLevel eq_orig ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_tc_type (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $ - \ _ sk_rho -> - tc_sub_type_ds eq_orig inst_orig ctxt - ty_actual sk_rho - ; return (sk_wrap <.> inner_wrap) } - where - possibly_poly ty - | isForAllTy ty = True - | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res - | otherwise = False - -- NB *not* tcSplitFunTy, because here we want - -- to decompose type-class arguments too - - definitely_poly ty - | (tvs, theta, tau) <- tcSplitSigmaTy ty - , (tv:_) <- tvs - , null theta - , isInsolubleOccursCheck NomEq tv tau - = True - | otherwise - = False - -{- Note [Don't skolemise unnecessarily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are trying to solve - (Char->Char) <= (forall a. a->a) -We could skolemise the 'forall a', and then complain -that (Char ~ a) is insoluble; but that's a pretty obscure -error. It's better to say that - (Char->Char) ~ (forall a. a->a) -fails. - -So roughly: - * if the ty_expected has an outermost forall - (i.e. skolemisation is the next thing we'd do) - * and the ty_actual has no top-level polymorphism (but looking deeply) -then we can revert to simple equality. But we need to be careful. -These examples are all fine: - - * (Char -> forall a. a->a) <= (forall a. Char -> a -> a) - Polymorphism is buried in ty_actual - - * (Char->Char) <= (forall a. Char -> Char) - ty_expected isn't really polymorphic - - * (Char->Char) <= (forall a. (a~Char) => a -> a) - ty_expected isn't really polymorphic - - * (Char->Char) <= (forall a. F [a] Char -> Char) - where type instance F [x] t = t - ty_expected isn't really polymorphic - -If we prematurely go to equality we'll reject a program we should -accept (e.g. #13752). So the test (which is only to improve -error message) is very conservative: - * ty_actual is /definitely/ monomorphic - * ty_expected is /definitely/ polymorphic --} - ---------------- -tc_sub_type_ds :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper --- If wrap = tc_sub_type_ds t1 t2 --- => wrap :: t1 ~> t2 --- Here is where the work actually happens! --- Precondition: ty_expected is deeply skolemised -tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected - = do { traceTc "tc_sub_type_ds" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; go ty_actual ty_expected } - where - go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e - | Just ty_e' <- tcView ty_e = go ty_a ty_e' - - go (TyVarTy tv_a) ty_e - = do { lookup_res <- lookupTcTyVar tv_a - ; case lookup_res of - Filled ty_a' -> - do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:" - (ppr tv_a <+> text "-->" <+> ppr ty_a') - ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e } - Unfilled _ -> unify } - - -- Historical note (Sept 16): there was a case here for - -- go ty_a (TyVarTy alpha) - -- which, in the impredicative case unified alpha := ty_a - -- where th_a is a polytype. Not only is this probably bogus (we - -- simply do not have decent story for impredicative types), but it - -- caused #12616 because (also bizarrely) 'deriving' code had - -- -XImpredicativeTypes on. I deleted the entire case. - - go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res }) - (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res }) - = -- See Note [Co/contra-variance of subsumption checking] - do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res - ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg - -- GenSigCtxt: See Note [Setting the argument context] - ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) } - -- arg_wrap :: exp_arg ~> act_arg - -- res_wrap :: act-res ~> exp_res - where - given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) - doc = text "When checking that" <+> quotes (ppr ty_actual) <+> - text "is more polymorphic than" <+> quotes (ppr ty_expected) - - go ty_a ty_e - | let (tvs, theta, _) = tcSplitSigmaTy ty_a - , not (null tvs && null theta) - = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a - ; body_wrap <- tc_sub_type_ds - (eq_orig { uo_actual = in_rho - , uo_expected = ty_expected }) - inst_orig ctxt in_rho ty_e - ; return (body_wrap <.> in_wrap) } - - | otherwise -- Revert to unification - = inst_and_unify - -- It's still possible that ty_actual has nested foralls. Instantiate - -- these, as there's no way unification will succeed with them in. - -- See typecheck/should_compile/T11305 for an example of when this - -- is important. The problem is that we're checking something like - -- a -> forall b. b -> b <= alpha beta gamma - -- where we end up with alpha := (->) - - inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual - - -- If we haven't recurred through an arrow, then - -- the eq_orig will list ty_actual. In this case, - -- we want to update the origin to reflect the - -- instantiation. If we *have* recurred through - -- an arrow, it's better not to update. - ; let eq_orig' = case eq_orig of - TypeEqOrigin { uo_actual = orig_ty_actual } - | orig_ty_actual `tcEqType` ty_actual - , not (isIdHsWrapper wrap) - -> eq_orig { uo_actual = rho_a } - _ -> eq_orig - - ; cow <- uType TypeLevel eq_orig' rho_a ty_expected - ; return (mkWpCastN cow <.> wrap) } - - - -- use versions without synonyms expanded - unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected - -{- Note [Settting the argument context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider we are doing the ambiguity check for the (bogus) - f :: (forall a b. C b => a -> a) -> Int - -We'll call - tcSubType ((forall a b. C b => a->a) -> Int ) - ((forall a b. C b => a->a) -> Int ) - -with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing -on the argument type of the (->) -- and at that point we want to switch -to a UserTypeCtxt of GenSigCtxt. Why? - -* Error messages. If we stick with FunSigCtxt we get errors like - * Could not deduce: C b - from the context: C b0 - bound by the type signature for: - f :: forall a b. C b => a->a - But of course f does not have that type signature! - Example tests: T10508, T7220a, Simple14 - -* Implications. We may decide to build an implication for the whole - ambiguity check, but we don't need one for each level within it, - and TcUnify.alwaysBuildImplication checks the UserTypeCtxt. - See Note [When to build an implication] --} - ------------------ --- needs both un-type-checked (for origins) and type-checked (for wrapping) --- expressions -tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr - --- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more --- convenient. -tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcWrapResultO orig rn_expr expr actual_ty res_ty - = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty - , text "Expected:" <+> ppr res_ty ]) - ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt - (Just rn_expr) actual_ty res_ty - ; return (mkHsWrap cow expr) } - - -{- ********************************************************************** -%* * - ExpType functions: tcInfer, fillInferResult -%* * -%********************************************************************* -} - --- | Infer a type using a fresh ExpType --- See also Note [ExpType] in TcMType --- Does not attempt to instantiate the inferred type -tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInferNoInst = tcInfer False - -tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType) -tcInferInst = tcInfer True - -tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer instantiate tc_check - = do { res_ty <- newInferExpType instantiate - ; result <- tc_check res_ty - ; res_ty <- readExpType res_ty - ; return (result, res_ty) } - -fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper --- If wrap = fillInferResult t1 t2 --- => wrap :: t1 ~> t2 --- See Note [Deep instantiation of InferResult] -fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me }) - | instantiate_me - = do { (wrap, rho) <- deeplyInstantiate orig ty - ; co <- fill_infer_result rho inf_res - ; return (mkWpCastN co <.> wrap) } - - | otherwise - = do { co <- fill_infer_result ty inf_res - ; return (mkWpCastN co) } - -fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN --- If wrap = fill_infer_result t1 t2 --- => wrap :: t1 ~> t2 -fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl - , ir_ref = ref }) - = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty - - ; traceTc "Filling ExpType" $ - ppr u <+> text ":=" <+> ppr ty_to_fill_with - - ; when debugIsOn (check_hole ty_to_fill_with) - - ; writeTcRef ref (Just ty_to_fill_with) - - ; return ty_co } - where - check_hole ty -- Debug check only - = do { let ty_lvl = tcTypeLevel ty - ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl), - ppr u $$ ppr res_lvl $$ ppr ty_lvl $$ - ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty ) - ; cts <- readTcRef ref - ; case cts of - Just already_there -> pprPanic "writeExpType" - (vcat [ ppr u - , ppr ty - , ppr already_there ]) - Nothing -> return () } - -{- Note [Deep instantiation of InferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some cases we want to deeply instantiate before filling in -an InferResult, and in some cases not. That's why InferReult -has the ir_inst flag. - -ir_inst = True: deeply instantiate ----------------------------------- - -1. Consider - f x = (*) - We want to instantiate the type of (*) before returning, else we - will infer the type - f :: forall {a}. a -> forall b. Num b => b -> b -> b - This is surely confusing for users. - - And worse, the monomorphism restriction won't work properly. The MR is - dealt with in simplifyInfer, and simplifyInfer has no way of - instantiating. This could perhaps be worked around, but it may be - hard to know even when instantiation should happen. - -2. Another reason. Consider - f :: (?x :: Int) => a -> a - g y = let ?x = 3::Int in f - Here want to instantiate f's type so that the ?x::Int constraint - gets discharged by the enclosing implicit-parameter binding. - -ir_inst = False: do not instantiate ------------------------------------ - -1. Consider this (which uses visible type application): - - (let { f :: forall a. a -> a; f x = x } in f) @Int - - We'll call TcExpr.tcInferFun to infer the type of the (let .. in f) - And we don't want to instantite the type of 'f' when we reach it, - else the outer visible type application won't work - -2. :type +v. When we say - - :type +v const @Int - - we really want `forall b. Int -> b -> Int`. Note that this is *not* - instantiated. - -3. Pattern bindings. For example: - - foo x - | blah <- const @Int - = (blah x False, blah x 'z') - - Note that `blah` is polymorphic. (This isn't a terribly compelling - reason, but the choice of ir_inst does matter here.) - -Discussion ----------- -We thought that we should just remove the ir_inst flag, in favor of -always instantiating. Essentially: motivations (1) and (3) for ir_inst = False -are not terribly exciting. However, motivation (2) is quite important. -Furthermore, there really was not much of a simplification of the code -in removing ir_inst, and working around it to enable flows like what we -see in (2) is annoying. This was done in #17173. - --} - -{- ********************************************************************* -* * - Promoting types -* * -********************************************************************* -} - -promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType) --- See Note [Promoting a type] --- promoteTcType level ty = (co, ty') --- * Returns ty' whose max level is just 'level' --- and whose kind is ~# to the kind of 'ty' --- and whose kind has form TYPE rr --- * and co :: ty ~ ty' --- * and emits constraints to justify the coercion -promoteTcType dest_lvl ty - = do { cur_lvl <- getTcLevel - ; if (cur_lvl `sameDepthAs` dest_lvl) - then dont_promote_it - else promote_it } - where - promote_it :: TcM (TcCoercion, TcType) - promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty - -- where alpha and rr are fresh and from level dest_lvl - = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy - ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr) - ; let eq_orig = TypeEqOrigin { uo_actual = ty - , uo_expected = prom_ty - , uo_thing = Nothing - , uo_visible = False } - - ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty - ; return (co, prom_ty) } - - dont_promote_it :: TcM (TcCoercion, TcType) - dont_promote_it -- Check that ty :: TYPE rr, for some (fresh) rr - = do { res_kind <- newOpenTypeKind - ; let ty_kind = tcTypeKind ty - kind_orig = TypeEqOrigin { uo_actual = ty_kind - , uo_expected = res_kind - , uo_thing = Nothing - , uo_visible = False } - ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind - ; let co = mkTcGReflRightCo Nominal ty ki_co - ; return (co, ty `mkCastTy` ki_co) } - -{- Note [Promoting a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12427) - - data T where - MkT :: (Int -> Int) -> a -> T - - h y = case y of MkT v w -> v - -We'll infer the RHS type with an expected type ExpType of - (IR { ir_lvl = l, ir_ref = ref, ... ) -where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern -match will increase the level, so we'll end up in tcSubType, trying to -unify the type of v, - v :: Int -> Int -with the expected type. But this attempt takes place at level (l+1), -rightly so, since v's type could have mentioned existential variables, -(like w's does) and we want to catch that. - -So we - - create a new meta-var alpha[l+1] - - fill in the InferRes ref cell 'ref' with alpha - - emit an equality constraint, thus - [W] alpha[l+1] ~ (Int -> Int) - -That constraint will float outwards, as it should, unless v's -type mentions a skolem-captured variable. - -This approach fails if v has a higher rank type; see -Note [Promotion and higher rank types] - - -Note [Promotion and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If v had a higher-rank type, say v :: (forall a. a->a) -> Int, -then we'd emit an equality - [W] alpha[l+1] ~ ((forall a. a->a) -> Int) -which will sadly fail because we can't unify a unification variable -with a polytype. But there is nothing really wrong with the program -here. - -We could just about solve this by "promote the type" of v, to expose -its polymorphic "shape" while still leaving constraints that will -prevent existential escape. But we must be careful! Exposing -the "shape" of the type is precisely what we must NOT do under -a GADT pattern match! So in this case we might promote the type -to - (forall a. a->a) -> alpha[l+1] -and emit the constraint - [W] alpha[l+1] ~ Int -Now the promoted type can fill the ref cell, while the emitted -equality can float or not, according to the usual rules. - -But that's not quite right! We are exposing the arrow! We could -deal with that too: - (forall a. mu[l+1] a a) -> alpha[l+1] -with constraints - [W] alpha[l+1] ~ Int - [W] mu[l+1] ~ (->) -Here we abstract over the '->' inside the forall, in case that -is subject to an equality constraint from a GADT match. - -Note that we kept the outer (->) because that's part of -the polymorphic "shape". And because of impredicativity, -GADT matches can't give equalities that affect polymorphic -shape. - -This reasoning just seems too complicated, so I decided not -to do it. These higher-rank notes are just here to record -the thinking. --} - -{- ********************************************************************* -* * - Generalisation -* * -********************************************************************* -} - --- | Take an "expected type" and strip off quantifiers to expose the --- type underneath, binding the new skolems for the @thing_inside@. --- The returned 'HsWrapper' has type @specific_ty -> expected_ty@. -tcSkolemise :: UserTypeCtxt -> TcSigmaType - -> ([TcTyVar] -> TcType -> TcM result) - -- ^ These are only ever used for scoped type variables. - -> TcM (HsWrapper, result) - -- ^ The expression has type: spec_ty -> expected_ty - -tcSkolemise ctxt expected_ty thing_inside - -- We expect expected_ty to be a forall-type - -- If not, the call is a no-op - = do { traceTc "tcSkolemise" Outputable.empty - ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty - - ; lvl <- getTcLevel - ; when debugIsOn $ - traceTc "tcSkolemise" $ vcat [ - ppr lvl, - text "expected_ty" <+> ppr expected_ty, - text "inst tyvars" <+> ppr tv_prs, - text "given" <+> ppr given, - text "inst type" <+> ppr rho' ] - - -- Generally we must check that the "forall_tvs" havn't been constrained - -- The interesting bit here is that we must include the free variables - -- of the expected_ty. Here's an example: - -- runST (newVar True) - -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) - -- for (newVar True), with s fresh. Then we unify with the runST's arg type - -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. - -- So now s' isn't unconstrained because it's linked to a. - -- - -- However [Oct 10] now that the untouchables are a range of - -- TcTyVars, all this is handled automatically with no need for - -- extra faffing around - - ; let tvs' = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs - - ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ - thing_inside tvs' rho' - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op - --- | Variant of 'tcSkolemise' that takes an ExpType -tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) - -> TcM (HsWrapper, result) -tcSkolemiseET _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et -tcSkolemiseET ctxt (Check ty) thing_inside - = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType - -checkConstraints :: SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Given - -> TcM result - -> TcM (TcEvBinds, result) - -checkConstraints skol_info skol_tvs given thing_inside - = do { implication_needed <- implicationNeeded skol_info skol_tvs given - - ; if implication_needed - then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted - ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) - ; emitImplications implics - ; return (ev_binds, result) } - - else -- Fast path. We check every function argument with - -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints. - -- So this fast path is well-exercised - do { res <- thing_inside - ; return (emptyTcEvBinds, res) } } - -checkTvConstraints :: SkolemInfo - -> [TcTyVar] -- Skolem tyvars - -> TcM result - -> TcM result - -checkTvConstraints skol_info skol_tvs thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; emitResidualTvConstraint skol_info Nothing skol_tvs tclvl wanted - ; return result } - -emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar] - -> TcLevel -> WantedConstraints -> TcM () -emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted - | isEmptyWC wanted - , isNothing m_telescope || skol_tvs `lengthAtMost` 1 - -- If m_telescope is (Just d), we must do the bad-telescope check, - -- so we must /not/ discard the implication even if there are no - -- wanted constraints. See Note [Checking telescopes] in Constraint. - -- Lacking this check led to #16247 - = return () - - | otherwise - = do { ev_binds <- newNoTcEvBinds - ; implic <- newImplication - ; let status | insolubleWC wanted = IC_Insoluble - | otherwise = IC_Unsolved - -- If the inner constraints are insoluble, - -- we should mark the outer one similarly, - -- so that insolubleWC works on the outer one - - ; emitImplication $ - implic { ic_status = status - , ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_telescope = m_telescope - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info } } - -implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool --- See Note [When to build an implication] -implicationNeeded skol_info skol_tvs given - | null skol_tvs - , null given - , not (alwaysBuildImplication skol_info) - = -- Empty skolems and givens - do { tc_lvl <- getTcLevel - ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are - then return False -- already inside an implication - else - do { dflags <- getDynFlags -- If any deferral can happen, - -- we must build an implication - ; return (gopt Opt_DeferTypeErrors dflags || - gopt Opt_DeferTypedHoles dflags || - gopt Opt_DeferOutOfScopeVariables dflags) } } - - | otherwise -- Non-empty skolems or givens - = return True -- Definitely need an implication - -alwaysBuildImplication :: SkolemInfo -> Bool --- See Note [When to build an implication] -alwaysBuildImplication _ = False - -{- Commmented out for now while I figure out about error messages. - See #14185 - -alwaysBuildImplication (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt {} -> True -- RHS of a binding with a signature - _ -> False -alwaysBuildImplication (RuleSkol {}) = True -alwaysBuildImplication (InstSkol {}) = True -alwaysBuildImplication (FamInstSkol {}) = True -alwaysBuildImplication _ = False --} - -buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] - -> [EvVar] -> WantedConstraints - -> TcM (Bag Implication, TcEvBinds) -buildImplicationFor tclvl skol_info skol_tvs given wanted - | isEmptyWC wanted && null given - -- Optimisation : if there are no wanteds, and no givens - -- don't generate an implication at all. - -- Reason for the (null given): we don't want to lose - -- the "inaccessible alternative" error check - = return (emptyBag, emptyTcEvBinds) - - | otherwise - = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs ) - -- Why allow TyVarTvs? Because implicitly declared kind variables in - -- non-CUSK type declarations are TyVarTvs, and we need to bring them - -- into scope as a skolem in an implication. This is OK, though, - -- because TyVarTvs will always remain tyvars, even after unification. - do { ev_binds_var <- newTcEvBinds - ; implic <- newImplication - ; let implic' = implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given = given - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_info = skol_info } - - ; return (unitBag implic', TcEvBinds ev_binds_var) } - -{- Note [When to build an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have some 'skolems' and some 'givens', and we are -considering whether to wrap the constraints in their scope into an -implication. We must /always/ so if either 'skolems' or 'givens' are -non-empty. But what if both are empty? You might think we could -always drop the implication. Other things being equal, the fewer -implications the better. Less clutter and overhead. But we must -take care: - -* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, - we'll make a /term-level/ evidence binding for 'g = error "blah"'. - We must have an EvBindsVar those bindings!, otherwise they end up as - top-level unlifted bindings, which are verboten. This only matters - at top level, so we check for that - See also Note [Deferred errors for coercion holes] in TcErrors. - cf #14149 for an example of what goes wrong. - -* If you have - f :: Int; f = f_blah - g :: Bool; g = g_blah - If we don't build an implication for f or g (no tyvars, no givens), - the constraints for f_blah and g_blah are solved together. And that - can yield /very/ confusing error messages, because we can get - [W] C Int b1 -- from f_blah - [W] C Int b2 -- from g_blan - and fundpes can yield [D] b1 ~ b2, even though the two functions have - literally nothing to do with each other. #14185 is an example. - Building an implication keeps them separage. --} - -{- -************************************************************************ -* * - Boxy unification -* * -************************************************************************ - -The exported functions are all defined as versions of some -non-exported generic functions. --} - -unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1' - -> TcTauType -> TcTauType -> TcM TcCoercionN --- Actual and expected types --- Returns a coercion : ty1 ~ ty2 -unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> - uType TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = ppr <$> thing - , uo_visible = True } -- always called from a visible context - -unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN -unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> - uType KindLevel origin ty1 ty2 - where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = ppr <$> thing - , uo_visible = True } -- also always from a visible context - ---------------- - -{- -%************************************************************************ -%* * - uType and friends -%* * -%************************************************************************ - -uType is the heart of the unifier. --} - -uType, uType_defer - :: TypeOrKind - -> CtOrigin - -> TcType -- ty1 is the *actual* type - -> TcType -- ty2 is the *expected* type - -> TcM CoercionN - --------------- --- It is always safe to defer unification to the main constraint solver --- See Note [Deferred unification] -uType_defer t_or_k origin ty1 ty2 - = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2 - - -- Error trace only - -- NB. do *not* call mkErrInfo unless tracing is on, - -- because it is hugely expensive (#5631) - ; whenDOptM Opt_D_dump_tc_trace $ do - { ctxt <- getErrCtxt - ; doc <- mkErrInfo emptyTidyEnv ctxt - ; traceTc "utype_defer" (vcat [ debugPprType ty1 - , debugPprType ty2 - , pprCtOrigin origin - , doc]) - ; traceTc "utype_defer2" (ppr co) - } - ; return co } - --------------- -uType t_or_k origin orig_ty1 orig_ty2 - = do { tclvl <- getTcLevel - ; traceTc "u_tys" $ vcat - [ text "tclvl" <+> ppr tclvl - , sep [ ppr orig_ty1, text "~", ppr orig_ty2] - , pprCtOrigin origin] - ; co <- go orig_ty1 orig_ty2 - ; if isReflCo co - then traceTc "u_tys yields no coercion" Outputable.empty - else traceTc "u_tys yields coercion:" (ppr co) - ; return co } - where - go :: TcType -> TcType -> TcM CoercionN - -- The arguments to 'go' are always semantically identical - -- to orig_ty{1,2} except for looking through type synonyms - - -- Unwrap casts before looking for variables. This way, we can easily - -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we - -- didn't do it this way, and then the unification above was deferred. - go (CastTy t1 co1) t2 - = do { co_tys <- uType t_or_k origin t1 t2 - ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) } - - go t1 (CastTy t2 co2) - = do { co_tys <- uType t_or_k origin t1 t2 - ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) } - - -- Variables; go for uUnfilledVar - -- Note that we pass in *original* (before synonym expansion), - -- so that type variables tend to get filled in with - -- the most informative version of the type - go (TyVarTy tv1) ty2 - = do { lookup_res <- lookupTcTyVar tv1 - ; case lookup_res of - Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) - ; go ty1 ty2 } - Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 } - go ty1 (TyVarTy tv2) - = do { lookup_res <- lookupTcTyVar tv2 - ; case lookup_res of - Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) - ; go ty1 ty2 } - Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 } - - -- See Note [Expanding synonyms during unification] - go ty1@(TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = return $ mkNomReflCo ty1 - - -- See Note [Expanding synonyms during unification] - -- - -- Also NB that we recurse to 'go' so that we don't push a - -- new item on the origin stack. As a result if we have - -- type Foo = Int - -- and we try to unify Foo ~ Bool - -- we'll end up saying "can't match Foo with Bool" - -- rather than "can't match "Int with Bool". See #4535. - go ty1 ty2 - | Just ty1' <- tcView ty1 = go ty1' ty2 - | Just ty2' <- tcView ty2 = go ty1 ty2' - - -- Functions (or predicate functions) just check the two parts - go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2) - = do { co_l <- uType t_or_k origin fun1 fun2 - ; co_r <- uType t_or_k origin arg1 arg2 - ; return $ mkFunCo Nominal co_l co_r } - - -- Always defer if a type synonym family (type function) - -- is involved. (Data families behave rigidly.) - go ty1@(TyConApp tc1 _) ty2 - | isTypeFamilyTyCon tc1 = defer ty1 ty2 - go ty1 ty2@(TyConApp tc2 _) - | isTypeFamilyTyCon tc2 = defer ty1 ty2 - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - -- See Note [Mismatched type lists and application decomposition] - | tc1 == tc2, equalLength tys1 tys2 - = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 ) - do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2 - ; return $ mkTyConAppCo Nominal tc1 cos } - where - origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin) - (tcTyConVisibilities tc1) - - go (LitTy m) ty@(LitTy n) - | m == n - = return $ mkNomReflCo ty - - -- See Note [Care with type applications] - -- Do not decompose FunTy against App; - -- it's often a type error, so leave it for the constraint solver - go (AppTy s1 t1) (AppTy s2 t2) - = go_app (isNextArgVisible s1) s1 t1 s2 t2 - - go (AppTy s1 t1) (TyConApp tc2 ts2) - | Just (ts2', t2') <- snocView ts2 - = ASSERT( not (mustBeSaturated tc2) ) - go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2' - - go (TyConApp tc1 ts1) (AppTy s2 t2) - | Just (ts1', t1') <- snocView ts1 - = ASSERT( not (mustBeSaturated tc1) ) - go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2 - - go (CoercionTy co1) (CoercionTy co2) - = do { let ty1 = coercionType co1 - ty2 = coercionType co2 - ; kco <- uType KindLevel - (KindEqOrigin orig_ty1 (Just orig_ty2) origin - (Just t_or_k)) - ty1 ty2 - ; return $ mkProofIrrelCo Nominal kco co1 co2 } - - -- Anything else fails - -- E.g. unifying for-all types, which is relative unusual - go ty1 ty2 = defer ty1 ty2 - - ------------------ - defer ty1 ty2 -- See Note [Check for equality before deferring] - | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1) - | otherwise = uType_defer t_or_k origin ty1 ty2 - - ------------------ - go_app vis s1 t1 s2 t2 - = do { co_s <- uType t_or_k origin s1 s2 - ; let arg_origin - | vis = origin - | otherwise = toInvisibleOrigin origin - ; co_t <- uType t_or_k arg_origin t1 t2 - ; return $ mkAppCo co_s co_t } - -{- Note [Check for equality before deferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Particularly in ambiguity checks we can get equalities like (ty ~ ty). -If ty involves a type function we may defer, which isn't very sensible. -An egregious example of this was in test T9872a, which has a type signature - Proxy :: Proxy (Solutions Cubes) -Doing the ambiguity check on this signature generates the equality - Solutions Cubes ~ Solutions Cubes -and currently the constraint solver normalises both sides at vast cost. -This little short-cut in 'defer' helps quite a bit. - -Note [Care with type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note: type applications need a bit of care! -They can match FunTy and TyConApp, so use splitAppTy_maybe -NB: we've already dealt with type variables and Notes, -so if one type is an App the other one jolly well better be too - -Note [Mismatched type lists and application decomposition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we find two TyConApps, you might think that the argument lists -are guaranteed equal length. But they aren't. Consider matching - w (T x) ~ Foo (T x y) -We do match (w ~ Foo) first, but in some circumstances we simply create -a deferred constraint; and then go ahead and match (T x ~ T x y). -This came up in #3950. - -So either - (a) either we must check for identical argument kinds - when decomposing applications, - - (b) or we must be prepared for ill-kinded unification sub-problems - -Currently we adopt (b) since it seems more robust -- no need to maintain -a global invariant. - -Note [Expanding synonyms during unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We expand synonyms during unification, but: - * We expand *after* the variable case so that we tend to unify - variables with un-expanded type synonym. This just makes it - more likely that the inferred types will mention type synonyms - understandable to the user - - * Similarly, we expand *after* the CastTy case, just in case the - CastTy wraps a variable. - - * We expand *before* the TyConApp case. For example, if we have - type Phantom a = Int - and are unifying - Phantom Int ~ Phantom Char - it is *wrong* to unify Int and Char. - - * The problem case immediately above can happen only with arguments - to the tycon. So we check for nullary tycons *before* expanding. - This is particularly helpful when checking (* ~ *), because * is - now a type synonym. - -Note [Deferred Unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, -and yet its consistency is undetermined. Previously, there was no way to still -make it consistent. So a mismatch error was issued. - -Now these unifications are deferred until constraint simplification, where type -family instances and given equations may (or may not) establish the consistency. -Deferred unifications are of the form - F ... ~ ... -or x ~ ... -where F is a type function and x is a type variable. -E.g. - id :: x ~ y => x -> y - id e = e - -involves the unification x = y. It is deferred until we bring into account the -context x ~ y to establish that it holds. - -If available, we defer original types (rather than those where closed type -synonyms have already been expanded via tcCoreView). This is, as usual, to -improve error messages. - - -************************************************************************ -* * - uUnfilledVar and friends -* * -************************************************************************ - -@uunfilledVar@ is called when at least one of the types being unified is a -variable. It does {\em not} assume that the variable is a fixed point -of the substitution; rather, notice that @uVar@ (defined below) nips -back into @uTys@ if it turns out that the variable is already bound. --} - ----------- -uUnfilledVar :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2 - -> TcM Coercion --- "Unfilled" means that the variable is definitely not a filled-in meta tyvar --- It might be a skolem, or untouchable, or meta - -uUnfilledVar origin t_or_k swapped tv1 ty2 - = do { ty2 <- zonkTcType ty2 - -- Zonk to expose things to the - -- occurs check, and so that if ty2 - -- looks like a type variable then it - -- /is/ a type variable - ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 } - ----------- -uUnfilledVar1 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar1 origin t_or_k swapped tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 - = go tv2 - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - - where - -- 'go' handles the case where both are - -- tyvars so we might want to swap - -- E.g. maybe tv2 is a meta-tyvar and tv1 is not - go tv2 | tv1 == tv2 -- Same type variable => no-op - = return (mkNomReflCo (mkTyVarTy tv1)) - - | swapOverTyVars tv1 tv2 -- Distinct type variables - -- Swap meta tyvar to the left if poss - = do { tv1 <- zonkTyCoVarKind tv1 - -- We must zonk tv1's kind because that might - -- not have happened yet, and it's an invariant of - -- uUnfilledTyVar2 that ty2 is fully zonked - -- Omitting this caused #16902 - ; uUnfilledVar2 origin t_or_k (flipSwap swapped) - tv2 (mkTyVarTy tv1) } - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - ----------- -uUnfilledVar2 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar2 origin t_or_k swapped tv1 ty2 - = do { dflags <- getDynFlags - ; cur_lvl <- getTcLevel - ; go dflags cur_lvl } - where - go dflags cur_lvl - | canSolveByUnification cur_lvl tv1 ty2 - , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2 - = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1) - ; traceTc "uUnfilledVar2 ok" $ - vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2) - , ppr (isTcReflCo co_k), ppr co_k ] - - ; if isTcReflCo co_k - -- Only proceed if the kinds match - -- NB: tv1 should still be unfilled, despite the kind unification - -- because tv1 is not free in ty2 (or, hence, in its kind) - then do { writeMetaTyVar tv1 ty2' - ; return (mkTcNomReflCo ty2') } - - else defer } -- This cannot be solved now. See TcCanonical - -- Note [Equalities with incompatible kinds] - - | otherwise - = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) - -- Occurs check or an untouchable: just defer - -- NB: occurs check isn't necessarily fatal: - -- eg tv1 occured in type family parameter - ; defer } - - ty1 = mkTyVarTy tv1 - kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) - - defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 - -swapOverTyVars :: TcTyVar -> TcTyVar -> Bool -swapOverTyVars tv1 tv2 - -- Level comparison: see Note [TyVar/TyVar orientation] - | lvl1 `strictlyDeeperThan` lvl2 = False - | lvl2 `strictlyDeeperThan` lvl1 = True - - -- Priority: see Note [TyVar/TyVar orientation] - | pri1 > pri2 = False - | pri2 > pri1 = True - - -- Names: see Note [TyVar/TyVar orientation] - | isSystemName tv2_name, not (isSystemName tv1_name) = True - - | otherwise = False - - where - lvl1 = tcTyVarLevel tv1 - lvl2 = tcTyVarLevel tv2 - pri1 = lhsPriority tv1 - pri2 = lhsPriority tv2 - tv1_name = Var.varName tv1 - tv2_name = Var.varName tv2 - - -lhsPriority :: TcTyVar -> Int --- Higher => more important to be on the LHS --- See Note [TyVar/TyVar orientation] -lhsPriority tv - = ASSERT2( isTyVar tv, ppr tv) - case tcTyVarDetails tv of - RuntimeUnk -> 0 - SkolemTv {} -> 0 - MetaTv { mtv_info = info } -> case info of - FlatSkolTv -> 1 - TyVarTv -> 2 - TauTv -> 3 - FlatMetaTv -> 4 -{- Note [TyVar/TyVar orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)? -This is a surprisingly tricky question! - -First note: only swap if you have to! - See Note [Avoid unnecessary swaps] - -So we look for a positive reason to swap, using a three-step test: - -* Level comparison. If 'a' has deeper level than 'b', - put 'a' on the left. See Note [Deeper level on the left] - -* Priority. If the levels are the same, look at what kind of - type variable it is, using 'lhsPriority' - - - FlatMetaTv: Always put on the left. - See Note [Fmv Orientation Invariant] - NB: FlatMetaTvs always have the current level, never an - outer one. So nothing can be deeper than a FlatMetaTv - - - - TyVarTv/TauTv: if we have tyv_tv ~ tau_tv, put tau_tv - on the left because there are fewer - restrictions on updating TauTvs - - - TyVarTv/TauTv: put on the left either - a) Because it's touchable and can be unified, or - b) Even if it's not touchable, TcSimplify.floatEqualities - looks for meta tyvars on the left - - - FlatSkolTv: Put on the left in preference to a SkolemTv - See Note [Eliminate flat-skols] - -* Names. If the level and priority comparisons are all - equal, try to eliminate a TyVars with a System Name in - favour of ones with a Name derived from a user type signature - -* Age. At one point in the past we tried to break any remaining - ties by eliminating the younger type variable, based on their - Uniques. See Note [Eliminate younger unification variables] - (which also explains why we don't do this any more) - -Note [Deeper level on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The most important thing is that we want to put tyvars with -the deepest level on the left. The reason to do so differs for -Wanteds and Givens, but either way, deepest wins! Simple. - -* Wanteds. Putting the deepest variable on the left maximise the - chances that it's a touchable meta-tyvar which can be solved. - -* Givens. Suppose we have something like - forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] - - If we orient the Given a[2] on the left, we'll rewrite the Wanted to - (beta[1] ~ b[1]), and that can float out of the implication. - Otherwise it can't. By putting the deepest variable on the left - we maximise our changes of eliminating skolem capture. - - See also TcSMonad Note [Let-bound skolems] for another reason - to orient with the deepest skolem on the left. - - IMPORTANT NOTE: this test does a level-number comparison on - skolems, so it's important that skolems have (accurate) level - numbers. - -See #15009 for an further analysis of why "deepest on the left" -is a good plan. - -Note [Fmv Orientation Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * We always orient a constraint - fmv ~ alpha - with fmv on the left, even if alpha is - a touchable unification variable - -Reason: doing it the other way round would unify alpha:=fmv, but that -really doesn't add any info to alpha. But a later constraint alpha ~ -Int might unlock everything. Comment:9 of #12526 gives a detailed -example. - -WARNING: I've gone to and fro on this one several times. -I'm now pretty sure that unifying alpha:=fmv is a bad idea! -So orienting with fmvs on the left is a good thing. - -This example comes from IndTypesPerfMerge. (Others include -T10226, T10009.) - From the ambiguity check for - f :: (F a ~ a) => a - we get: - [G] F a ~ a - [WD] F alpha ~ alpha, alpha ~ a - - From Givens we get - [G] F a ~ fsk, fsk ~ a - - Now if we flatten we get - [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a - - Now, if we unified alpha := fmv, we'd get - [WD] F fmv ~ fmv, [WD] fmv ~ a - And now we are stuck. - -So instead the Fmv Orientation Invariant puts the fmv on the -left, giving - [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a - - Now we get alpha:=a, and everything works out - -Note [Eliminate flat-skols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have [G] Num (F [a]) -then we flatten to - [G] Num fsk - [G] F [a] ~ fsk -where fsk is a flatten-skolem (FlatSkolTv). Suppose we have - type instance F [a] = a -then we'll reduce the second constraint to - [G] a ~ fsk -and then replace all uses of 'a' with fsk. That's bad because -in error messages instead of saying 'a' we'll say (F [a]). In all -places, including those where the programmer wrote 'a' in the first -place. Very confusing! See #7862. - -Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate -the fsk. - -Note [Avoid unnecessary swaps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we swap without actually improving matters, we can get an infinite loop. -Consider - work item: a ~ b - inert item: b ~ c -We canonicalise the work-item to (a ~ c). If we then swap it before -adding to the inert set, we'll add (c ~ a), and therefore kick out the -inert guy, so we get - new work item: b ~ c - inert item: c ~ a -And now the cycle just repeats - -Note [Eliminate younger unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a choice of unifying - alpha := beta or beta := alpha -we try, if possible, to eliminate the "younger" one, as determined -by `ltUnique`. Reason: the younger one is less likely to appear free in -an existing inert constraint, and hence we are less likely to be forced -into kicking out and rewriting inert constraints. - -This is a performance optimisation only. It turns out to fix -#14723 all by itself, but clearly not reliably so! - -It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). -But, to my surprise, it didn't seem to make any significant difference -to the compiler's performance, so I didn't take it any further. Still -it seemed to too nice to discard altogether, so I'm leaving these -notes. SLPJ Jan 18. --} - --- @trySpontaneousSolve wi@ solves equalities where one side is a --- touchable unification variable. --- Returns True <=> spontaneous solve happened -canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool -canSolveByUnification tclvl tv xi - | isTouchableMetaTyVar tclvl tv - = case metaTyVarInfo tv of - TyVarTv -> is_tyvar xi - _ -> True - - | otherwise -- Untouchable - = False - where - is_tyvar xi - = case tcGetTyVar_maybe xi of - Nothing -> False - Just tv -> case tcTyVarDetails tv of - MetaTv { mtv_info = info } - -> case info of - TyVarTv -> True - _ -> False - SkolemTv {} -> True - RuntimeUnk -> True - -{- Note [Prevent unification with type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prevent unification with type families because of an uneasy compromise. -It's perfectly sound to unify with type families, and it even improves the -error messages in the testsuite. It also modestly improves performance, at -least in some cases. But it's disastrous for test case perf/compiler/T3064. -Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. -What do we do? Do we reduce F? Or do we use the given? Hard to know what's -best. GHC reduces. This is a disaster for T3064, where the type's size -spirals out of control during reduction. (We're not helped by the fact that -the flattener re-flattens all the arguments every time around.) If we prevent -unification with type families, then the solver happens to use the equality -before expanding the type family. - -It would be lovely in the future to revisit this problem and remove this -extra, unnecessary check. But we retain it for now as it seems to work -better in practice. - -Note [Refactoring hazard: checkTauTvUpdate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I (Richard E.) have a sad story about refactoring this code, retained here -to prevent others (or a future me!) from falling into the same traps. - -It all started with #11407, which was caused by the fact that the TyVarTy -case of defer_me didn't look in the kind. But it seemed reasonable to -simply remove the defer_me check instead. - -It referred to two Notes (since removed) that were out of date, and the -fast_check code in occurCheckExpand seemed to do just about the same thing as -defer_me. The one piece that defer_me did that wasn't repeated by -occurCheckExpand was the type-family check. (See Note [Prevent unification -with type families].) So I checked the result of occurCheckExpand for any -type family occurrences and deferred if there were any. This was done -in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 . - -This approach turned out not to be performant, because the expanded -type was bigger than the original type, and tyConsOfType (needed to -see if there are any type family occurrences) looks through type -synonyms. So it then struck me that we could dispense with the -defer_me check entirely. This simplified the code nicely, and it cut -the allocations in T5030 by half. But, as documented in Note [Prevent -unification with type families], this destroyed performance in -T3064. Regardless, I missed this regression and the change was -committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d . - -Bottom lines: - * defer_me is back, but now fixed w.r.t. #11407. - * Tread carefully before you start to refactor here. There can be - lots of hard-to-predict consequences. - -Note [Type synonyms and the occur check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking we try to update a variable with type synonyms not -expanded, which improves later error messages, unless looking -inside a type synonym may help resolve a spurious occurs check -error. Consider: - type A a = () - - f :: (A a -> a -> ()) -> () - f = \ _ -> () - - x :: () - x = f (\ x p -> p x) - -We will eventually get a constraint of the form t ~ A t. The ok function above will -properly expand the type (A t) to just (), which is ok to be unified with t. If we had -unified with the original type A t, we would lead the type checker into an infinite loop. - -Hence, if the occurs check fails for a type synonym application, then (and *only* then), -the ok function expands the synonym to detect opportunities for occurs check success using -the underlying definition of the type synonym. - -The same applies later on in the constraint interaction code; see TcInteract, -function @occ_check_ok@. - -Note [Non-TcTyVars in TcUnify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because the same code is now shared between unifying types and unifying -kinds, we sometimes will see proper TyVars floating around the unifier. -Example (from test case polykinds/PolyKinds12): - - type family Apply (f :: k1 -> k2) (x :: k1) :: k2 - type instance Apply g y = g y - -When checking the instance declaration, we first *kind-check* the LHS -and RHS, discovering that the instance really should be - - type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y - -During this kind-checking, all the tyvars will be TcTyVars. Then, however, -as a second pass, we desugar the RHS (which is done in functions prefixed -with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper -TyVars, not TcTyVars, get some kind unification must happen. - -Thus, we always check if a TyVar is a TcTyVar before asking if it's a -meta-tyvar. - -This used to not be necessary for type-checking (that is, before * :: *) -because expressions get desugared via an algorithm separate from -type-checking (with wrappers, etc.). Types get desugared very differently, -causing this wibble in behavior seen here. --} - -data LookupTyVarResult -- The result of a lookupTcTyVar call - = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv - | Filled TcType - -lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult -lookupTcTyVar tyvar - | MetaTv { mtv_ref = ref } <- details - = do { meta_details <- readMutVar ref - ; case meta_details of - Indirect ty -> return (Filled ty) - Flexi -> do { is_touchable <- isTouchableTcM tyvar - -- Note [Unifying untouchables] - ; if is_touchable then - return (Unfilled details) - else - return (Unfilled vanillaSkolemTv) } } - | otherwise - = return (Unfilled details) - where - details = tcTyVarDetails tyvar - -{- -Note [Unifying untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat an untouchable type variable as if it was a skolem. That -ensures it won't unify with anything. It's a slight hack, because -we return a made-up TcTyVarDetails, but I think it works smoothly. --} - --- | Breaks apart a function kind into its pieces. -matchExpectedFunKind - :: Outputable fun - => fun -- ^ type, only for errors - -> Arity -- ^ n: number of desired arrows - -> TcKind -- ^ fun_ kind - -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) - -matchExpectedFunKind hs_ty n k = go n k - where - go 0 k = return (mkNomReflCo k) - - go n k | Just k' <- tcView k = go n k' - - go n k@(TyVarTy kvar) - | isMetaTyVar kvar - = do { maybe_kind <- readMetaTyVar kvar - ; case maybe_kind of - Indirect fun_kind -> go n fun_kind - Flexi -> defer n k } - - go n (FunTy _ arg res) - = do { co <- go (n-1) res - ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) } - - go n other - = defer n other - - defer n k - = do { arg_kinds <- newMetaKindVars n - ; res_kind <- newMetaKindVar - ; let new_fun = mkVisFunTys arg_kinds res_kind - origin = TypeEqOrigin { uo_actual = k - , uo_expected = new_fun - , uo_thing = Just (ppr hs_ty) - , uo_visible = True - } - ; uType KindLevel origin k new_fun } - -{- ********************************************************************* -* * - Occurrence checking -* * -********************************************************************* -} - - -{- Note [Occurrence checking: look inside kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are considering unifying - (alpha :: *) ~ Int -> (beta :: alpha -> alpha) -This may be an error (what is that alpha doing inside beta's kind?), -but we must not make the mistake of actually unifying or we'll -build an infinite data structure. So when looking for occurrences -of alpha in the rhs, we must look in the kinds of type variables -that occur there. - -NB: we may be able to remove the problem via expansion; see - Note [Occurs check expansion]. So we have to try that. - -Note [Checking for foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unless we have -XImpredicativeTypes (which is a totally unsupported -feature), we do not want to unify - alpha ~ (forall a. a->a) -> Int -So we look for foralls hidden inside the type, and it's convenient -to do that at the same time as the occurs check (which looks for -occurrences of alpha). - -However, it's not just a question of looking for foralls /anywhere/! -Consider - (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) -This is legal; e.g. dependent/should_compile/T11635. - -We don't want to reject it because of the forall in beta's kind, -but (see Note [Occurrence checking: look inside kinds]) we do -need to look in beta's kind. So we carry a flag saying if a 'forall' -is OK, and sitch the flag on when stepping inside a kind. - -Why is it OK? Why does it not count as impredicative polymorphism? -The reason foralls are bad is because we reply on "seeing" foralls -when doing implicit instantiation. But the forall inside the kind is -fine. We'll generate a kind equality constraint - (forall k. k->*) ~ (forall k. k->*) -to check that the kinds of lhs and rhs are compatible. If alpha's -kind had instead been - (alpha :: kappa) -then this kind equality would rightly complain about unifying kappa -with (forall k. k->*) - --} - -data MetaTyVarUpdateResult a - = MTVU_OK a - | MTVU_Bad -- Forall, predicate, or type family - | MTVU_Occurs - deriving (Functor) - -instance Applicative MetaTyVarUpdateResult where - pure = MTVU_OK - (<*>) = ap - -instance Monad MetaTyVarUpdateResult where - MTVU_OK x >>= k = k x - MTVU_Bad >>= _ = MTVU_Bad - MTVU_Occurs >>= _ = MTVU_Occurs - -occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult () --- Just for error-message generation; so we return MetaTyVarUpdateResult --- so the caller can report the right kind of error --- Check whether --- a) the given variable occurs in the given type. --- b) there is a forall in the type (unless we have -XImpredicativeTypes) -occCheckForErrors dflags tv ty - = case preCheck dflags True tv ty of - MTVU_OK _ -> MTVU_OK () - MTVU_Bad -> MTVU_Bad - MTVU_Occurs -> case occCheckExpand [tv] ty of - Nothing -> MTVU_Occurs - Just _ -> MTVU_OK () - ----------------- -metaTyVarUpdateOK :: DynFlags - -> TcTyVar -- tv :: k1 - -> TcType -- ty :: k2 - -> Maybe TcType -- possibly-expanded ty --- (metaTyVarUpdateOK tv ty) --- We are about to update the meta-tyvar tv with ty --- Check (a) that tv doesn't occur in ty (occurs check) --- (b) that ty does not have any foralls --- (in the impredicative case), or type functions --- --- We have two possible outcomes: --- (1) Return the type to update the type variable with, --- [we know the update is ok] --- (2) Return Nothing, --- [the update might be dodgy] --- --- Note that "Nothing" does not mean "definite error". For example --- type family F a --- type instance F Int = Int --- consider --- a ~ F a --- This is perfectly reasonable, if we later get a ~ Int. For now, though, --- we return Nothing, leaving it to the later constraint simplifier to --- sort matters out. --- --- See Note [Refactoring hazard: checkTauTvUpdate] - -metaTyVarUpdateOK dflags tv ty - = case preCheck dflags False tv ty of - -- False <=> type families not ok - -- See Note [Prevent unification with type families] - MTVU_OK _ -> Just ty - MTVU_Bad -> Nothing -- forall, predicate, or type function - MTVU_Occurs -> occCheckExpand [tv] ty - -preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () --- A quick check for --- (a) a forall type (unless -XImpredicativeTypes) --- (b) a predicate type (unless -XImpredicativeTypes) --- (c) a type family --- (d) an occurrence of the type variable (occurs check) --- --- For (a), (b), and (c) we check only the top level of the type, NOT --- inside the kinds of variables it mentions. But for (c) we do --- look in the kinds of course. - -preCheck dflags ty_fam_ok tv ty - = fast_check ty - where - details = tcTyVarDetails tv - impredicative_ok = canUnifyWithPolyType dflags details - - ok :: MetaTyVarUpdateResult () - ok = MTVU_OK () - - fast_check :: TcType -> MetaTyVarUpdateResult () - fast_check (TyVarTy tv') - | tv == tv' = MTVU_Occurs - | otherwise = fast_check_occ (tyVarKind tv') - -- See Note [Occurrence checking: look inside kinds] - - fast_check (TyConApp tc tys) - | bad_tc tc = MTVU_Bad - | otherwise = mapM fast_check tys >> ok - fast_check (LitTy {}) = ok - fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r}) - | InvisArg <- af - , not impredicative_ok = MTVU_Bad - | otherwise = fast_check a >> fast_check r - fast_check (AppTy fun arg) = fast_check fun >> fast_check arg - fast_check (CastTy ty co) = fast_check ty >> fast_check_co co - fast_check (CoercionTy co) = fast_check_co co - fast_check (ForAllTy (Bndr tv' _) ty) - | not impredicative_ok = MTVU_Bad - | tv == tv' = ok - | otherwise = do { fast_check_occ (tyVarKind tv') - ; fast_check_occ ty } - -- Under a forall we look only for occurrences of - -- the type variable - - -- For kinds, we only do an occurs check; we do not worry - -- about type families or foralls - -- See Note [Checking for foralls] - fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs - | otherwise = ok - - -- For coercions, we are only doing an occurs check here; - -- no bother about impredicativity in coercions, as they're - -- inferred - fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs - | otherwise = ok - - bad_tc :: TyCon -> Bool - bad_tc tc - | not (impredicative_ok || isTauTyCon tc) = True - | not (ty_fam_ok || isFamFreeTyCon tc) = True - | otherwise = False - -canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool -canUnifyWithPolyType dflags details - = case details of - MetaTv { mtv_info = TyVarTv } -> False - MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags - _other -> True - -- We can have non-meta tyvars in given constraints diff --git a/typecheck/TcUnify.hs-boot b/typecheck/TcUnify.hs-boot deleted file mode 100644 --- a/typecheck/TcUnify.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -module TcUnify where - -import GhcPrelude -import TcType ( TcTauType ) -import TcRnTypes ( TcM ) -import TcEvidence ( TcCoercion ) -import GHC.Hs.Expr ( HsExpr ) -import GHC.Hs.Types ( HsType ) -import GHC.Hs.Extension ( GhcRn ) - --- This boot file exists only to tie the knot between --- TcUnify and Inst - -unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion diff --git a/typecheck/TcValidity.hs b/typecheck/TcValidity.hs deleted file mode 100644 --- a/typecheck/TcValidity.hs +++ /dev/null @@ -1,2901 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, TupleSections, ViewPatterns #-} - -module TcValidity ( - Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - checkValidTheta, - checkValidInstance, checkValidInstHead, validDerivPred, - checkTySynRhs, - checkValidCoAxiom, checkValidCoAxBranch, - checkValidTyFamEqn, checkConsistentFamInst, - badATErr, arityErr, - checkTyConTelescope, - allDistinctTyVars - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Maybes - --- friends: -import TcUnify ( tcSubType_NC ) -import TcSimplify ( simplifyAmbiguityCheck ) -import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) -import TyCoFVs -import TyCoRep -import TyCoPpr -import TcType hiding ( sizeType, sizeTypes ) -import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) -import PrelNames -import Type -import Unify ( tcMatchTyX_BM, BindFlag(..) ) -import Coercion -import CoAxiom -import Class -import TyCon -import Predicate -import TcOrigin - --- others: -import IfaceType( pprIfaceType, pprIfaceTypeApp ) -import ToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) -import GHC.Hs -- HsType -import TcRnMonad -- TcType, amongst others -import TcEnv ( tcInitTidyEnv, tcInitOpenTidyEnv ) -import FunDeps -import FamInstEnv ( isDominatedBy, injectiveBranches, - InjectivityCheckResult(..) ) -import FamInst -import Name -import VarEnv -import VarSet -import Var ( VarBndr(..), mkTyVar ) -import FV -import ErrUtils -import DynFlags -import Util -import ListSetOps -import SrcLoc -import Outputable -import Unique ( mkAlphaTyVarUnique ) -import Bag ( emptyBag ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable -import Data.List ( (\\), nub ) -import qualified Data.List.NonEmpty as NE - -{- -************************************************************************ -* * - Checking for ambiguity -* * -************************************************************************ - -Note [The ambiguity check for type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -checkAmbiguity is a check on *user-supplied type signatures*. It is -*purely* there to report functions that cannot possibly be called. So for -example we want to reject: - f :: C a => Int -The idea is there can be no legal calls to 'f' because every call will -give rise to an ambiguous constraint. We could soundly omit the -ambiguity check on type signatures entirely, at the expense of -delaying ambiguity errors to call sites. Indeed, the flag --XAllowAmbiguousTypes switches off the ambiguity check. - -What about things like this: - class D a b | a -> b where .. - h :: D Int b => Int -The Int may well fix 'b' at the call site, so that signature should -not be rejected. Moreover, using *visible* fundeps is too -conservative. Consider - class X a b where ... - class D a b | a -> b where ... - instance D a b => X [a] b where... - h :: X a b => a -> a -Here h's type looks ambiguous in 'b', but here's a legal call: - ...(h [True])... -That gives rise to a (X [Bool] beta) constraint, and using the -instance means we need (D Bool beta) and that fixes 'beta' via D's -fundep! - -Behind all these special cases there is a simple guiding principle. -Consider - - f :: - f = ...blah... - - g :: - g = f - -You would think that the definition of g would surely typecheck! -After all f has exactly the same type, and g=f. But in fact f's type -is instantiated and the instantiated constraints are solved against -the originals, so in the case an ambiguous type it won't work. -Consider our earlier example f :: C a => Int. Then in g's definition, -we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), -and fail. - -So in fact we use this as our *definition* of ambiguity. We use a -very similar test for *inferred* types, to ensure that they are -unambiguous. See Note [Impedance matching] in TcBinds. - -This test is very conveniently implemented by calling - tcSubType -This neatly takes account of the functional dependecy stuff above, -and implicit parameter (see Note [Implicit parameters and ambiguity]). -And this is what checkAmbiguity does. - -What about this, though? - g :: C [a] => Int -Is every call to 'g' ambiguous? After all, we might have - instance C [a] where ... -at the call site. So maybe that type is ok! Indeed even f's -quintessentially ambiguous type might, just possibly be callable: -with -XFlexibleInstances we could have - instance C a where ... -and now a call could be legal after all! Well, we'll reject this -unless the instance is available *here*. - -Note [When to call checkAmbiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We call checkAmbiguity - (a) on user-specified type signatures - (b) in checkValidType - -Conncerning (b), you might wonder about nested foralls. What about - f :: forall b. (forall a. Eq a => b) -> b -The nested forall is ambiguous. Originally we called checkAmbiguity -in the forall case of check_type, but that had two bad consequences: - * We got two error messages about (Eq b) in a nested forall like this: - g :: forall a. Eq a => forall b. Eq b => a -> a - * If we try to check for ambiguity of a nested forall like - (forall a. Eq a => b), the implication constraint doesn't bind - all the skolems, which results in "No skolem info" in error - messages (see #10432). - -To avoid this, we call checkAmbiguity once, at the top, in checkValidType. -(I'm still a bit worried about unbound skolems when the type mentions -in-scope type variables.) - -In fact, because of the co/contra-variance implemented in tcSubType, -this *does* catch function f above. too. - -Concerning (a) the ambiguity check is only used for *user* types, not -for types coming from inteface files. The latter can legitimately -have ambiguous types. Example - - class S a where s :: a -> (Int,Int) - instance S Char where s _ = (1,1) - f:: S a => [a] -> Int -> (Int,Int) - f (_::[a]) x = (a*x,b) - where (a,b) = s (undefined::a) - -Here the worker for f gets the type - fw :: forall a. S a => Int -> (# Int, Int #) - - -Note [Implicit parameters and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only a *class* predicate can give rise to ambiguity -An *implicit parameter* cannot. For example: - foo :: (?x :: [a]) => Int - foo = length ?x -is fine. The call site will supply a particular 'x' - -Furthermore, the type variables fixed by an implicit parameter -propagate to the others. E.g. - foo :: (Show a, ?x::[a]) => Int - foo = show (?x++?x) -The type of foo looks ambiguous. But it isn't, because at a call site -we might have - let ?x = 5::Int in foo -and all is well. In effect, implicit parameters are, well, parameters, -so we can take their type variables into account as part of the -"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. --} - -checkAmbiguity :: UserTypeCtxt -> Type -> TcM () -checkAmbiguity ctxt ty - | wantAmbiguityCheck ctxt - = do { traceTc "Ambiguity check for" (ppr ty) - -- Solve the constraints eagerly because an ambiguous type - -- can cause a cascade of further errors. Since the free - -- tyvars are skolemised, we can safely use tcSimplifyTop - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ - captureConstraints $ - tcSubType_NC ctxt ty ty - ; simplifyAmbiguityCheck ty wanted - - ; traceTc "Done ambiguity check for" (ppr ty) } - - | otherwise - = return () - where - mk_msg allow_ambiguous - = vcat [ text "In the ambiguity check for" <+> what - , ppUnless allow_ambiguous ambig_msg ] - ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" - what | Just n <- isSigMaybe ctxt = quotes (ppr n) - | otherwise = pprUserTypeCtxt ctxt - -wantAmbiguityCheck :: UserTypeCtxt -> Bool -wantAmbiguityCheck ctxt - = case ctxt of -- See Note [When we don't check for ambiguity] - GhciCtxt {} -> False - TySynCtxt {} -> False - TypeAppCtxt -> False - StandaloneKindSigCtxt{} -> False - _ -> True - -checkUserTypeError :: Type -> TcM () --- Check to see if the type signature mentions "TypeError blah" --- anywhere in it, and fail if so. --- --- Very unsatisfactorily (#11144) we need to tidy the type --- because it may have come from an /inferred/ signature, not a --- user-supplied one. This is really only a half-baked fix; --- the other errors in checkValidType don't do tidying, and so --- may give bad error messages when given an inferred type. -checkUserTypeError = check - where - check ty - | Just msg <- userTypeError_maybe ty = fail_with msg - | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts - | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2 - | Just (_,t1) <- splitForAllTy_maybe ty = check t1 - | otherwise = return () - - fail_with msg = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } - - -{- Note [When we don't check for ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a few places we do not want to check a user-specified type for ambiguity - -* GhciCtxt: Allow ambiguous types in GHCi's :kind command - E.g. type family T a :: * -- T :: forall k. k -> * - Then :k T should work in GHCi, not complain that - (T k) is ambiguous! - -* TySynCtxt: type T a b = C a b => blah - It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow - cure the ambiguity. So we defer the ambiguity check to the use site. - - There is also an implementation reason (#11608). In the RHS of - a type synonym we don't (currently) instantiate 'a' and 'b' with - TcTyVars before calling checkValidType, so we get asertion failures - from doing an ambiguity check on a type with TyVars in it. Fixing this - would not be hard, but let's wait till there's a reason. - -* TypeAppCtxt: visible type application - f @ty - No need to check ty for ambiguity - -* StandaloneKindSigCtxt: type T :: ksig - Kinds need a different ambiguity check than types, and the currently - implemented check is only good for types. See #14419, in particular - https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844 - -************************************************************************ -* * - Checking validity of a user-defined type -* * -************************************************************************ - -When dealing with a user-written type, we first translate it from an HsType -to a Type, performing kind checking, and then check various things that should -be true about it. We don't want to perform these checks at the same time -as the initial translation because (a) they are unnecessary for interface-file -types and (b) when checking a mutually recursive group of type and class decls, -we can't "look" at the tycons/classes yet. Also, the checks are rather -diverse, and used to really mess up the other code. - -One thing we check for is 'rank'. - - Rank 0: monotypes (no foralls) - Rank 1: foralls at the front only, Rank 0 inside - Rank 2: foralls at the front, Rank 1 on left of fn arrow, - - basic ::= tyvar | T basic ... basic - - r2 ::= forall tvs. cxt => r2a - r2a ::= r1 -> r2a | basic - r1 ::= forall tvs. cxt => r0 - r0 ::= r0 -> r0 | basic - -Another thing is to check that type synonyms are saturated. -This might not necessarily show up in kind checking. - type A i = i - data T k = MkT (k Int) - f :: T A -- BAD! --} - -checkValidType :: UserTypeCtxt -> Type -> TcM () --- Checks that a user-written type is valid for the given context --- Assumes argument is fully zonked --- Not used for instance decls; checkValidInstance instead -checkValidType ctxt ty - = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) - ; rankn_flag <- xoptM LangExt.RankNTypes - ; impred_flag <- xoptM LangExt.ImpredicativeTypes - ; let gen_rank :: Rank -> Rank - gen_rank r | rankn_flag = ArbitraryRank - | otherwise = r - - rank1 = gen_rank r1 - rank0 = gen_rank r0 - - r0 = rankZeroMonoType - r1 = LimitedRank True r0 - - rank - = case ctxt of - DefaultDeclCtxt-> MustBeMonoType - ResSigCtxt -> MustBeMonoType - PatSigCtxt -> rank0 - RuleSigCtxt _ -> rank1 - TySynCtxt _ -> rank0 - - ExprSigCtxt -> rank1 - KindSigCtxt -> rank1 - StandaloneKindSigCtxt{} -> rank1 - TypeAppCtxt | impred_flag -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Normally, ImpredicativeTypes is handled in check_arg_type, - -- but visible type applications don't go through there. - -- So we do this check here. - - FunSigCtxt {} -> rank1 - InfSigCtxt {} -> rank1 -- Inferred types should obey the - -- same rules as declared ones - - ConArgCtxt _ -> rank1 -- We are given the type of the entire - -- constructor, hence rank 1 - PatSynCtxt _ -> rank1 - - ForSigCtxt _ -> rank1 - SpecInstCtxt -> rank1 - ThBrackCtxt -> rank1 - GhciCtxt {} -> ArbitraryRank - - TyVarBndrKindCtxt _ -> rank0 - DataKindCtxt _ -> rank1 - TySynKindCtxt _ -> rank1 - TyFamResKindCtxt _ -> rank1 - - _ -> panic "checkValidType" - -- Can't happen; not used for *user* sigs - - ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - ; expand <- initialExpandMode - ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand } - - -- Check the internal validity of the type itself - -- Fail if bad things happen, else we misleading - -- (and more complicated) errors in checkAmbiguity - ; checkNoErrs $ - do { check_type ve ty - ; checkUserTypeError ty - ; traceTc "done ct" (ppr ty) } - - -- Check for ambiguous types. See Note [When to call checkAmbiguity] - -- NB: this will happen even for monotypes, but that should be cheap; - -- and there may be nested foralls for the subtype test to examine - ; checkAmbiguity ctxt ty - - ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) } - -checkValidMonoType :: Type -> TcM () --- Assumes argument is fully zonked -checkValidMonoType ty - = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - ; expand <- initialExpandMode - ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt - , ve_rank = MustBeMonoType, ve_expand = expand } - ; check_type ve ty } - -checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () -checkTySynRhs ctxt ty - | tcReturnsConstraintKind actual_kind - = do { ck <- xoptM LangExt.ConstraintKinds - ; if ck - then when (tcIsConstraintKind actual_kind) - (do { dflags <- getDynFlags - ; expand <- initialExpandMode - ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) - else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) } - - | otherwise - = return () - where - actual_kind = tcTypeKind ty - -{- -Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~ -Technically - Int -> forall a. a->a -is still a rank-1 type, but it's not Haskell 98 (#5957). So the -validity checker allow a forall after an arrow only if we allow it -before -- that is, with Rank2Types or RankNTypes --} - -data Rank = ArbitraryRank -- Any rank ok - - | LimitedRank -- Note [Higher rank types] - Bool -- Forall ok at top - Rank -- Use for function arguments - - | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype - - | MustBeMonoType -- Monotype regardless of flags - -instance Outputable Rank where - ppr ArbitraryRank = text "ArbitraryRank" - ppr (LimitedRank top_forall_ok r) - = text "LimitedRank" <+> ppr top_forall_ok - <+> parens (ppr r) - ppr (MonoType msg) = text "MonoType" <+> parens msg - ppr MustBeMonoType = text "MustBeMonoType" - -rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank -rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes") -tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") -synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") -constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype" - , text "Perhaps you intended to use QuantifiedConstraints" ]) - -funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result -funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) -funArgResRank other_rank = (other_rank, other_rank) - -forAllAllowed :: Rank -> Bool -forAllAllowed ArbitraryRank = True -forAllAllowed (LimitedRank forall_ok _) = forall_ok -forAllAllowed _ = False - -allConstraintsAllowed :: UserTypeCtxt -> Bool --- We don't allow arbitrary constraints in kinds -allConstraintsAllowed (TyVarBndrKindCtxt {}) = False -allConstraintsAllowed (DataKindCtxt {}) = False -allConstraintsAllowed (TySynKindCtxt {}) = False -allConstraintsAllowed (TyFamResKindCtxt {}) = False -allConstraintsAllowed (StandaloneKindSigCtxt {}) = False -allConstraintsAllowed _ = True - --- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the --- context for the type of a term, where visible, dependent quantification is --- currently disallowed. --- --- An example of something that is unambiguously the type of a term is the --- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the --- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the --- kind of a type, not the type of a term, so it is permitted. --- --- For more examples, see --- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places --- where VDQ is permitted) and --- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where --- VDQ is disallowed). -vdqAllowed :: UserTypeCtxt -> Bool --- Currently allowed in the kinds of types... -vdqAllowed (KindSigCtxt {}) = True -vdqAllowed (StandaloneKindSigCtxt {}) = True -vdqAllowed (TySynCtxt {}) = True -vdqAllowed (ThBrackCtxt {}) = True -vdqAllowed (GhciCtxt {}) = True -vdqAllowed (TyVarBndrKindCtxt {}) = True -vdqAllowed (DataKindCtxt {}) = True -vdqAllowed (TySynKindCtxt {}) = True -vdqAllowed (TyFamResKindCtxt {}) = True --- ...but not in the types of terms. -vdqAllowed (ConArgCtxt {}) = False - -- We could envision allowing VDQ in data constructor types so long as the - -- constructor is only ever used at the type level, but for now, GHC adopts - -- the stance that VDQ is never allowed in data constructor types. -vdqAllowed (FunSigCtxt {}) = False -vdqAllowed (InfSigCtxt {}) = False -vdqAllowed (ExprSigCtxt {}) = False -vdqAllowed (TypeAppCtxt {}) = False -vdqAllowed (PatSynCtxt {}) = False -vdqAllowed (PatSigCtxt {}) = False -vdqAllowed (RuleSigCtxt {}) = False -vdqAllowed (ResSigCtxt {}) = False -vdqAllowed (ForSigCtxt {}) = False -vdqAllowed (DefaultDeclCtxt {}) = False --- We count class constraints as "types of terms". All of the cases below deal --- with class constraints. -vdqAllowed (InstDeclCtxt {}) = False -vdqAllowed (SpecInstCtxt {}) = False -vdqAllowed (GenSigCtxt {}) = False -vdqAllowed (ClassSCCtxt {}) = False -vdqAllowed (SigmaCtxt {}) = False -vdqAllowed (DataTyCtxt {}) = False -vdqAllowed (DerivClauseCtxt {}) = False - -{- -Note [Correctness and performance of type synonym validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the type A arg1 arg2, where A is a type synonym. How should we check -this type for validity? We have three distinct choices, corresponding to the -three constructors of ExpandMode: - -1. Expand the application of A, and check the resulting type (`Expand`). -2. Don't expand the application of A. Only check the arguments (`NoExpand`). -3. Check the arguments *and* check the expanded type (`Both`). - -It's tempting to think that we could always just pick choice (3), but this -results in serious performance issues when checking a type like in the -signature for `f` below: - - type S = ... - f :: S (S (S (S (S (S ....(S Int)...)))) - -When checking the type of `f`, we'll check the outer `S` application with and -without expansion, and in *each* of those checks, we'll check the next `S` -application with and without expansion... the result is exponential blowup! So -clearly we don't want to use `Both` 100% of the time. - -On the other hand, neither is it correct to use exclusively `Expand` or -exclusively `NoExpand` 100% of the time: - -* If one always expands, then one can miss erroneous programs like the one in - the `tcfail129` test case: - - type Foo a = String -> Maybe a - type Bar m = m Int - blah = undefined :: Bar Foo - - If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type - synonyms is unsaturated. -* If one never expands and only checks the arguments, then one can miss - erroneous programs like the one in #16059: - - type Foo b = Eq b => b - f :: forall b (a :: Foo b). Int - - The kind of `a` contains a constraint, which is illegal, but this will only - be caught if `Foo b` is expanded. - -Therefore, it's impossible to have these validity checks be simultaneously -correct and performant if one sticks exclusively to a single `ExpandMode`. In -that case, the solution is to vary the `ExpandMode`s! In more detail: - -1. When we start validity checking, we start with `Expand` if - LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we - do this), and we start with `Both` otherwise. The `initialExpandMode` - function is responsible for this. -2. When expanding an application of a type synonym (in `check_syn_tc_app`), we - determine which things to check based on the current `ExpandMode` argument. - Importantly, if the current mode is `Both`, then we check the arguments in - `NoExpand` mode and check the expanded type in `Both` mode. - - Switching to `NoExpand` when checking the arguments is vital to avoid - exponential blowup. One consequence of this choice is that if you have - the following type synonym in one module (with RankNTypes enabled): - - {-# LANGUAGE RankNTypes #-} - module A where - type A = forall a. a - - And you define the following in a separate module *without* RankNTypes - enabled: - - module B where - - import A - - type Const a b = a - f :: Const Int A -> Int - - Then `f` will be accepted, even though `A` (which is technically a rank-n - type) appears in its type. We view this as an acceptable compromise, since - `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in - a type post-expansion, such as in the following variant: - - g :: Const A A -> Int - - Then that would be rejected unless RankNTypes were enabled. --} - --- | When validity-checking an application of a type synonym, should we --- check the arguments, check the expanded type, or both? --- See Note [Correctness and performance of type synonym validity checking] -data ExpandMode - = Expand -- ^ Only check the expanded type. - | NoExpand -- ^ Only check the arguments. - | Both -- ^ Check both the arguments and the expanded type. - -instance Outputable ExpandMode where - ppr e = text $ case e of - Expand -> "Expand" - NoExpand -> "NoExpand" - Both -> "Both" - --- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the --- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start --- in 'Both' mode. -initialExpandMode :: TcM ExpandMode -initialExpandMode = do - liberal_flag <- xoptM LangExt.LiberalTypeSynonyms - pure $ if liberal_flag then Expand else Both - --- | Information about a type being validity-checked. -data ValidityEnv = ValidityEnv - { ve_tidy_env :: TidyEnv - , ve_ctxt :: UserTypeCtxt - , ve_rank :: Rank - , ve_expand :: ExpandMode } - -instance Outputable ValidityEnv where - ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand }) = - hang (text "ValidityEnv") - 2 (vcat [ text "ve_tidy_env" <+> ppr env - , text "ve_ctxt" <+> pprUserTypeCtxt ctxt - , text "ve_rank" <+> ppr rank - , text "ve_expand" <+> ppr expand ]) - ----------------------------------------- -check_type :: ValidityEnv -> Type -> TcM () --- The args say what the *type context* requires, independent --- of *flag* settings. You test the flag settings at usage sites. --- --- Rank is allowed rank for function args --- Rank 0 means no for-alls anywhere - -check_type _ (TyVarTy _) = return () - -check_type ve (AppTy ty1 ty2) - = do { check_type ve ty1 - ; check_arg_type False ve ty2 } - -check_type ve ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = check_syn_tc_app ve ty tc tys - | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys - | otherwise = mapM_ (check_arg_type False ve) tys - -check_type _ (LitTy {}) = return () - -check_type ve (CastTy ty _) = check_type ve ty - --- Check for rank-n types, such as (forall x. x -> x) or (Show x => x). --- --- Critically, this case must come *after* the case for TyConApp. --- See Note [Liberal type synonyms]. -check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand }) ty - | not (null tvbs && null theta) - = do { traceTc "check_type" (ppr ty $$ ppr rank) - ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty) - -- Reject e.g. (Maybe (?x::Int => Int)), - -- with a decent error message - - ; checkConstraintsOK ve theta ty - -- Reject forall (a :: Eq b => b). blah - -- In a kind signature we don't allow constraints - - ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs - || vdqAllowed ctxt) - (illegalVDQTyErr env ty) - -- Reject visible, dependent quantification in the type of a - -- term (e.g., `f :: forall a -> a -> Maybe a`) - - ; check_valid_theta env' SigmaCtxt expand theta - -- Allow type T = ?x::Int => Int -> Int - -- but not type T = ?x::Int - - ; check_type (ve{ve_tidy_env = env'}) tau - -- Allow foralls to right of arrow - - ; checkEscapingKind env' tvbs' theta tau } - where - (tvbs, phi) = tcSplitForAllVarBndrs ty - (theta, tau) = tcSplitPhiTy phi - (env', tvbs') = tidyTyCoVarBinders env tvbs - -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty) - = do { check_type (ve{ve_rank = arg_rank}) arg_ty - ; check_type (ve{ve_rank = res_rank}) res_ty } - where - (arg_rank, res_rank) = funArgResRank rank - -check_type _ ty = pprPanic "check_type" (ppr ty) - ----------------------------------------- -check_syn_tc_app :: ValidityEnv - -> KindOrType -> TyCon -> [KindOrType] -> TcM () --- Used for type synonyms and type synonym families, --- which must be saturated, --- but not data families, which need not be saturated -check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand }) - ty tc tys - | tys `lengthAtLeast` tc_arity -- Saturated - -- Check that the synonym has enough args - -- This applies equally to open and closed synonyms - -- It's OK to have an *over-applied* type synonym - -- data Tree a b = ... - -- type Foo a = Tree [a] - -- f :: Foo a b -> ... - = case expand of - _ | isTypeFamilyTyCon tc - -> check_args_only expand - -- See Note [Correctness and performance of type synonym validity - -- checking] - Expand -> check_expansion_only expand - NoExpand -> check_args_only expand - Both -> check_args_only NoExpand *> check_expansion_only Both - - | GhciCtxt True <- ctxt -- Accept outermost under-saturated type synonym or - -- type family constructors in GHCi :kind commands. - -- See Note [Unsaturated type synonyms in GHCi] - = check_args_only expand - - | otherwise - = failWithTc (tyConArityErr tc tys) - where - tc_arity = tyConArity tc - - check_arg :: ExpandMode -> KindOrType -> TcM () - check_arg expand = - check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand}) - - check_args_only, check_expansion_only :: ExpandMode -> TcM () - check_args_only expand = mapM_ (check_arg expand) tys - - check_expansion_only expand - = ASSERT2( isTypeSynonymTyCon tc, ppr tc ) - case tcView ty of - Just ty' -> let err_ctxt = text "In the expansion of type synonym" - <+> quotes (ppr tc) - in addErrCtxt err_ctxt $ - check_type (ve{ve_expand = expand}) ty' - Nothing -> pprPanic "check_syn_tc_app" (ppr ty) - -{- -Note [Unsaturated type synonyms in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, GHC disallows unsaturated uses of type synonyms or type -families. For instance, if one defines `type Const a b = a`, then GHC will not -permit using `Const` unless it is applied to (at least) two arguments. There is -an exception to this rule, however: GHCi's :kind command. For instance, it -is quite common to look up the kind of a type constructor like so: - - λ> :kind Const - Const :: j -> k -> j - λ> :kind Const Int - Const Int :: k -> Type - -Strictly speaking, the two uses of `Const` above are unsaturated, but this -is an extremely benign (and useful) example of unsaturation, so we allow it -here as a special case. - -That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise, -this GHCi interaction would be possible: - - λ> newtype Fix f = MkFix (f (Fix f)) - λ> type Id a = a - λ> :kind Fix Id - Fix Id :: Type - -This is rather dodgy, so we move to disallow this. We only permit unsaturated -synonyms in GHCi if they are *top-level*—that is, if the synonym is the -outermost type being applied. This allows `Const` and `Const Int` in the -first example, but not `Fix Id` in the second example, as `Id` is not the -outermost type being applied (`Fix` is). - -We track this outermost property in the GhciCtxt constructor of UserTypeCtxt. -A field of True in GhciCtxt indicates that we're in an outermost position. Any -time we invoke `check_arg` to check the validity of an argument, we switch the -field to False. --} - ----------------------------------------- -check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM () -check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys - = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples - ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty) - - ; impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = if impred then ArbitraryRank else tyConArgMonoType - -- c.f. check_arg_type - -- However, args are allowed to be unlifted, or - -- more unboxed tuples, so can't use check_arg_ty - ; mapM_ (check_type (ve{ve_rank = rank'})) tys } - ----------------------------------------- -check_arg_type - :: Bool -- ^ Is this the argument to a type synonym? - -> ValidityEnv -> KindOrType -> TcM () --- The sort of type that can instantiate a type variable, --- or be the argument of a type constructor. --- Not an unboxed tuple, but now *can* be a forall (since impredicativity) --- Other unboxed types are very occasionally allowed as type --- arguments depending on the kind of the type constructor --- --- For example, we want to reject things like: --- --- instance Ord a => Ord (forall s. T s a) --- and --- g :: T s (forall b.b) --- --- NB: unboxed tuples can have polymorphic or unboxed args. --- This happens in the workers for functions returning --- product types with polymorphic components. --- But not in user code. --- Anyway, they are dealt with by a special case in check_tau_type - -check_arg_type _ _ (CoercionTy {}) = return () - -check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty - = do { impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = case rank of -- Predictive => must be monotype - -- Rank-n arguments to type synonyms are OK, provided - -- that LiberalTypeSynonyms is enabled. - _ | type_syn -> synArgMonoType - MustBeMonoType -> MustBeMonoType -- Monotype, regardless - _other | impred -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Make sure that MustBeMonoType is propagated, - -- so that we don't suggest -XImpredicativeTypes in - -- (Ord (forall a.a)) => a -> a - -- and so that if it Must be a monotype, we check that it is! - ctxt' :: UserTypeCtxt - ctxt' - | GhciCtxt _ <- ctxt = GhciCtxt False - -- When checking an argument, set the field of GhciCtxt to - -- False to indicate that we are no longer in an outermost - -- position (and thus unsaturated synonyms are no longer - -- allowed). - -- See Note [Unsaturated type synonyms in GHCi] - | otherwise = ctxt - - ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } - ----------------------------------------- -forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) -forAllTyErr env rank ty - = ( env - , vcat [ hang herald 2 (ppr_tidy env ty) - , suggestion ] ) - where - (tvs, _theta, _tau) = tcSplitSigmaTy ty - herald | null tvs = text "Illegal qualified type:" - | otherwise = text "Illegal polymorphic type:" - suggestion = case rank of - LimitedRank {} -> text "Perhaps you intended to use RankNTypes" - MonoType d -> d - _ -> Outputable.empty -- Polytype is always illegal - --- | Reject type variables that would escape their escape through a kind. --- See @Note [Type variables escaping through kinds]@. -checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM () -checkEscapingKind env tvbs theta tau = - case occCheckExpand (binderVars tvbs) phi_kind of - -- Ensure that none of the tvs occur in the kind of the forall - -- /after/ expanding type synonyms. - -- See Note [Phantom type variables in kinds] in Type - Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind - Just _ -> pure () - where - tau_kind = tcTypeKind tau - phi_kind | null theta = tau_kind - | otherwise = liftedTypeKind - -- If there are any constraints, the kind is *. (#11405) - -forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind - -> (TidyEnv, SDoc) -forAllEscapeErr env tvbs theta tau tau_kind - = ( env - , vcat [ hang (text "Quantified type's kind mentions quantified type variable") - 2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau))) - -- NB: Don't tidy this type since the tvbs were already tidied - -- previously, and re-tidying them will make the names of type - -- variables different from tau_kind. - , hang (text "where the body of the forall has this kind:") - 2 (quotes (ppr_tidy env tau_kind)) ] ) - -{- -Note [Type variables escaping through kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - - type family T (r :: RuntimeRep) :: TYPE r - foo :: forall r. T r - -Something smells funny about the type of `foo`. If you spell out the kind -explicitly, it becomes clearer from where the smell originates: - - foo :: ((forall r. T r) :: TYPE r) - -The type variable `r` appears in the result kind, which escapes the scope of -its binding site! This is not desirable, so we establish a validity check -(`checkEscapingKind`) to catch any type variables that might escape through -kinds in this way. --} - -ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -ubxArgTyErr env ty - = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:" - , ppr_tidy env ty ] - , text "Perhaps you intended to use UnboxedTuples" ] ) - -checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () -checkConstraintsOK ve theta ty - | null theta = return () - | allConstraintsAllowed (ve_ctxt ve) = return () - | otherwise - = -- We are in a kind, where we allow only equality predicates - -- See Note [Constraints in kinds] in TyCoRep, and #16263 - checkTcM (all isEqPred theta) $ - constraintTyErr (ve_tidy_env ve) ty - -constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -constraintTyErr env ty - = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) - --- | Reject a use of visible, dependent quantification in the type of a term. -illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -illegalVDQTyErr env ty = - (env, vcat - [ hang (text "Illegal visible, dependent quantification" <+> - text "in the type of a term:") - 2 (ppr_tidy env ty) - , text "(GHC does not yet support this)" ] ) - -{- -Note [Liberal type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* -doing validity checking. This allows us to instantiate a synonym defn -with a for-all type, or with a partially-applied type synonym. - e.g. type T a b = a - type S m = m () - f :: S (T Int) -Here, T is partially applied, so it's illegal in H98. But if you -expand S first, then T we get just - f :: Int -which is fine. - -IMPORTANT: suppose T is a type synonym. Then we must do validity -checking on an appliation (T ty1 ty2) - - *either* before expansion (i.e. check ty1, ty2) - *or* after expansion (i.e. expand T ty1 ty2, and then check) - BUT NOT BOTH - -If we do both, we get exponential behaviour!! - - data TIACons1 i r c = c i ::: r c - type TIACons2 t x = TIACons1 t (TIACons1 t x) - type TIACons3 t x = TIACons2 t (TIACons1 t x) - type TIACons4 t x = TIACons2 t (TIACons2 t x) - type TIACons7 t x = TIACons4 t (TIACons3 t x) - -The order in which you do validity checking is also somewhat delicate. Consider -the `check_type` function, which drives the validity checking for unsaturated -uses of type synonyms. There is a special case for rank-n types, such as -(forall x. x -> x) or (Show x => x), since those require at least one language -extension to use. It used to be the case that this case came before every other -case, but this can lead to bugs. Imagine you have this scenario (from #15954): - - type A a = Int - type B (a :: Type -> Type) = forall x. x -> x - type C = B A - -If the rank-n case came first, then in the process of checking for `forall`s -or contexts, we would expand away `B A` to `forall x. x -> x`. This is because -the functions that split apart `forall`s/contexts -(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded -away to `forall x. x -> x` before the actually validity checks occur, we will -have completely obfuscated the fact that we had an unsaturated application of -the `A` type synonym. - -We have since learned from our mistakes and now put this rank-n case /after/ -the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be -caught properly. But be careful! We can't make the rank-n case /last/ either, -as the FunTy case must came after the rank-n case. Otherwise, something like -(Eq a => Int) would be treated as a function type (FunTy), which just -wouldn't do. - -************************************************************************ -* * -\subsection{Checking a theta or source type} -* * -************************************************************************ - -Note [Implicit parameters in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Implicit parameters _only_ allowed in type signatures; not in instance -decls, superclasses etc. The reason for not allowing implicit params in -instances is a bit subtle. If we allowed - instance (?x::Int, Eq a) => Foo [a] where ... -then when we saw - (e :: (?x::Int) => t) -it would be unclear how to discharge all the potential uses of the ?x -in e. For example, a constraint Foo [Int] might come out of e, and -applying the instance decl would show up two uses of ?x. #8912. --} - -checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () --- Assumes argument is fully zonked -checkValidTheta ctxt theta - = addErrCtxtM (checkThetaCtxt ctxt theta) $ - do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) - ; expand <- initialExpandMode - ; check_valid_theta env ctxt expand theta } - -------------------------- -check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode - -> [PredType] -> TcM () -check_valid_theta _ _ _ [] - = return () -check_valid_theta env ctxt expand theta - = do { dflags <- getDynFlags - ; warnTcM (Reason Opt_WarnDuplicateConstraints) - (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) - (dupPredWarn env dups) - ; traceTc "check_valid_theta" (ppr theta) - ; mapM_ (check_pred_ty env dflags ctxt expand) theta } - where - (_,dups) = removeDups nonDetCmpType theta - -- It's OK to use nonDetCmpType because dups only appears in the - -- warning - -------------------------- -{- Note [Validity checking for constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We look through constraint synonyms so that we can see the underlying -constraint(s). For example - type Foo = ?x::Int - instance Foo => C T -We should reject the instance because it has an implicit parameter in -the context. - -But we record, in 'under_syn', whether we have looked under a synonym -to avoid requiring language extensions at the use site. Main example -(#9838): - - {-# LANGUAGE ConstraintKinds #-} - module A where - type EqShow a = (Eq a, Show a) - - module B where - import A - foo :: EqShow a => a -> String - -We don't want to require ConstraintKinds in module B. --} - -check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode - -> PredType -> TcM () --- Check the validity of a predicate in a signature --- See Note [Validity checking for constraints] -check_pred_ty env dflags ctxt expand pred - = do { check_type ve pred - ; check_pred_help False env dflags ctxt pred } - where - rank | xopt LangExt.QuantifiedConstraints dflags - = ArbitraryRank - | otherwise - = constraintMonoType - - ve :: ValidityEnv - ve = ValidityEnv{ ve_tidy_env = env - , ve_ctxt = SigmaCtxt - , ve_rank = rank - , ve_expand = expand } - -check_pred_help :: Bool -- True <=> under a type synonym - -> TidyEnv - -> DynFlags -> UserTypeCtxt - -> PredType -> TcM () -check_pred_help under_syn env dflags ctxt pred - | Just pred' <- tcView pred -- Switch on under_syn when going under a - -- synonym (#9838, yuk) - = check_pred_help True env dflags ctxt pred' - - | otherwise -- A bit like classifyPredType, but not the same - -- E.g. we treat (~) like (~#); and we look inside tuples - = case classifyPredType pred of - ClassPred cls tys - | isCTupleClass cls -> check_tuple_pred under_syn env dflags ctxt pred tys - | otherwise -> check_class_pred env dflags ctxt pred cls tys - - EqPred NomEq _ _ -> -- a ~# b - check_eq_pred env dflags pred - - EqPred ReprEq _ _ -> -- Ugh! When inferring types we may get - -- f :: (a ~R# b) => blha - -- And we want to treat that like (Coercible a b) - -- We should probably check argument shapes, but we - -- didn't do so before, so I'm leaving it for now - return () - - ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head - IrredPred {} -> check_irred_pred under_syn env dflags ctxt pred - -check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () -check_eq_pred env dflags pred - = -- Equational constraints are valid in all contexts if type - -- families are permitted - checkTcM (xopt LangExt.TypeFamilies dflags - || xopt LangExt.GADTs dflags) - (eqPredTyErr env pred) - -check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt - -> PredType -> ThetaType -> PredType -> TcM () -check_quant_pred env dflags _ctxt pred theta head_pred - = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $ - do { -- Check the instance head - case classifyPredType head_pred of - ClassPred cls tys -> checkValidInstHead SigmaCtxt cls tys - -- SigmaCtxt tells checkValidInstHead that - -- this is the head of a quantified constraint - IrredPred {} | hasTyVarHead head_pred - -> return () - _ -> failWithTcM (badQuantHeadErr env pred) - - -- Check for termination - ; unless (xopt LangExt.UndecidableInstances dflags) $ - checkInstTermination theta head_pred - } - -check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () -check_tuple_pred under_syn env dflags ctxt pred ts - = do { -- See Note [ConstraintKinds in predicates] - checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags) - (predTupleErr env pred) - ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } - -- This case will not normally be executed because without - -- -XConstraintKinds tuple types are only kind-checked as * - -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -check_irred_pred under_syn env dflags ctxt pred - -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint - -- where X is a type function - = do { -- If it looks like (x t1 t2), require ConstraintKinds - -- see Note [ConstraintKinds in predicates] - -- But (X t1 t2) is always ok because we just require ConstraintKinds - -- at the definition site (#9838) - failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) - && hasTyVarHead pred) - (predIrredErr env pred) - - -- Make sure it is OK to have an irred pred in this context - -- See Note [Irreducible predicates in superclasses] - ; failIfTcM (is_superclass ctxt - && not (xopt LangExt.UndecidableInstances dflags) - && has_tyfun_head pred) - (predSuperClassErr env pred) } - where - is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } - has_tyfun_head ty - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isTypeFamilyTyCon tc - Nothing -> False - -{- Note [ConstraintKinds in predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't check for -XConstraintKinds under a type synonym, because that -was done at the type synonym definition site; see #9838 -e.g. module A where - type C a = (Eq a, Ix a) -- Needs -XConstraintKinds - module B where - import A - f :: C a => a -> a -- Does *not* need -XConstraintKinds - -Note [Irreducible predicates in superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Allowing type-family calls in class superclasses is somewhat dangerous -because we can write: - - type family Fooish x :: * -> Constraint - type instance Fooish () = Foo - class Fooish () a => Foo a where - -This will cause the constraint simplifier to loop because every time we canonicalise a -(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately -solved to add+canonicalise another (Foo a) constraint. -} - -------------------------- -check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt - -> PredType -> Class -> [TcType] -> TcM () -check_class_pred env dflags ctxt pred cls tys - | isEqPredClass cls -- (~) and (~~) are classified as classes, - -- but here we want to treat them as equalities - = -- pprTrace "check_class" (ppr cls) $ - check_eq_pred env dflags pred - - | isIPClass cls - = do { check_arity - ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) } - - | otherwise -- Includes Coercible - = do { check_arity - ; checkSimplifiableClassConstraint env dflags ctxt cls tys - ; checkTcM arg_tys_ok (predTyVarErr env pred) } - where - check_arity = checkTc (tys `lengthIs` classArity cls) - (tyConArityErr (classTyCon cls) tys) - - -- Check the arguments of a class constraint - flexible_contexts = xopt LangExt.FlexibleContexts dflags - undecidable_ok = xopt LangExt.UndecidableInstances dflags - arg_tys_ok = case ctxt of - SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys - -- Further checks on head and theta - -- in checkInstTermination - _ -> checkValidClsArgs flexible_contexts cls tys - -checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt - -> Class -> [TcType] -> TcM () --- See Note [Simplifiable given constraints] -checkSimplifiableClassConstraint env dflags ctxt cls tys - | not (wopt Opt_WarnSimplifiableClassConstraints dflags) - = return () - | xopt LangExt.MonoLocalBinds dflags - = return () - - | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta" - = return () -- of a data type declaration - - | cls `hasKey` coercibleTyConKey - = return () -- Oddly, we treat (Coercible t1 t2) as unconditionally OK - -- matchGlobalInst will reply "yes" because we can reduce - -- (Coercible a b) to (a ~R# b) - - | otherwise - = do { result <- matchGlobalInst dflags False cls tys - ; case result of - OneInst { cir_what = what } - -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints) - (simplifiable_constraint_warn what) - _ -> return () } - where - pred = mkClassPred cls tys - - simplifiable_constraint_warn :: InstanceWhat -> SDoc - simplifiable_constraint_warn what - = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)) - <+> text "matches") - 2 (ppr what) - , hang (text "This makes type inference for inner bindings fragile;") - 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] - -{- Note [Simplifiable given constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature like - f :: Eq [(a,b)] => a -> b -is very fragile, for reasons described at length in TcInteract -Note [Instance and Given overlap]. As that Note discusses, for the -most part the clever stuff in TcInteract means that we don't use a -top-level instance if a local Given might fire, so there is no -fragility. But if we /infer/ the type of a local let-binding, things -can go wrong (#11948 is an example, discussed in the Note). - -So this warning is switched on only if we have NoMonoLocalBinds; in -that case the warning discourages users from writing simplifiable -class constraints. - -The warning only fires if the constraint in the signature -matches the top-level instances in only one way, and with no -unifiers -- that is, under the same circumstances that -TcInteract.matchInstEnv fires an interaction with the top -level instances. For example (#13526), consider - - instance {-# OVERLAPPABLE #-} Eq (T a) where ... - instance Eq (T Char) where .. - f :: Eq (T a) => ... - -We don't want to complain about this, even though the context -(Eq (T a)) matches an instance, because the user may be -deliberately deferring the choice so that the Eq (T Char) -has a chance to fire when 'f' is called. And the fragility -only matters when there's a risk that the instance might -fire instead of the local 'given'; and there is no such -risk in this case. Just use the same rules as for instance -firing! --} - -------------------------- -okIPCtxt :: UserTypeCtxt -> Bool - -- See Note [Implicit parameters in instance decls] -okIPCtxt (FunSigCtxt {}) = True -okIPCtxt (InfSigCtxt {}) = True -okIPCtxt ExprSigCtxt = True -okIPCtxt TypeAppCtxt = True -okIPCtxt PatSigCtxt = True -okIPCtxt ResSigCtxt = True -okIPCtxt GenSigCtxt = True -okIPCtxt (ConArgCtxt {}) = True -okIPCtxt (ForSigCtxt {}) = True -- ?? -okIPCtxt ThBrackCtxt = True -okIPCtxt (GhciCtxt {}) = True -okIPCtxt SigmaCtxt = True -okIPCtxt (DataTyCtxt {}) = True -okIPCtxt (PatSynCtxt {}) = True -okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int - -- #11466 - -okIPCtxt (KindSigCtxt {}) = False -okIPCtxt (StandaloneKindSigCtxt {}) = False -okIPCtxt (ClassSCCtxt {}) = False -okIPCtxt (InstDeclCtxt {}) = False -okIPCtxt (SpecInstCtxt {}) = False -okIPCtxt (RuleSigCtxt {}) = False -okIPCtxt DefaultDeclCtxt = False -okIPCtxt DerivClauseCtxt = False -okIPCtxt (TyVarBndrKindCtxt {}) = False -okIPCtxt (DataKindCtxt {}) = False -okIPCtxt (TySynKindCtxt {}) = False -okIPCtxt (TyFamResKindCtxt {}) = False - -{- -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -MultiParam check: - - class C f where... -- C :: forall k. k -> Constraint - instance C Maybe where... - - The dictionary gets type [C * Maybe] even if it's not a MultiParam - type class. - -Flexibility check: - - class C f where... -- C :: forall k. k -> Constraint - data D a = D a - instance C D where - - The dictionary gets type [C * (D *)]. IA0_TODO it should be - generalized actually. --} - -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) -checkThetaCtxt ctxt theta env - = return ( env - , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) - , text "While checking" <+> pprUserTypeCtxt ctxt ] ) - -eqPredTyErr, predTupleErr, predIrredErr, - predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -badQuantHeadErr env pred - = ( env - , hang (text "Quantified predicate must have a class or type variable head:") - 2 (ppr_tidy env pred) ) -eqPredTyErr env pred - = ( env - , text "Illegal equational constraint" <+> ppr_tidy env pred $$ - parens (text "Use GADTs or TypeFamilies to permit this") ) -predTupleErr env pred - = ( env - , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predIrredErr env pred - = ( env - , hang (text "Illegal constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predSuperClassErr env pred - = ( env - , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) - <+> text "in a superclass context") - 2 (parens undecidableMsg) ) - -predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -predTyVarErr env pred - = (env - , vcat [ hang (text "Non type-variable argument") - 2 (text "in the constraint:" <+> ppr_tidy env pred) - , parens (text "Use FlexibleContexts to permit this") ]) - -badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) -badIPPred env pred - = ( env - , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) - -constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -constraintSynErr env kind - = ( env - , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) - 2 (parens constraintKindsMsg) ) - -dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) -dupPredWarn env dups - = ( env - , text "Duplicate constraint" <> plural primaryDups <> text ":" - <+> pprWithCommas (ppr_tidy env) primaryDups ) - where - primaryDups = map NE.head dups - -tyConArityErr :: TyCon -> [TcType] -> SDoc --- For type-constructor arity errors, be careful to report --- the number of /visible/ arguments required and supplied, --- ignoring the /invisible/ arguments, which the user does not see. --- (e.g. #10516) -tyConArityErr tc tks - = arityErr (ppr (tyConFlavour tc)) (tyConName tc) - tc_type_arity tc_type_args - where - vis_tks = filterOutInvisibleTypes tc tks - - -- tc_type_arity = number of *type* args expected - -- tc_type_args = number of *type* args encountered - tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) - tc_type_args = length vis_tks - -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc -arityErr what name n m - = hsep [ text "The" <+> what, quotes (ppr name), text "should have", - n_arguments <> comma, text "but has been given", - if m==0 then text "none" else int m] - where - n_arguments | n == 0 = text "no arguments" - | n == 1 = text "1 argument" - | True = hsep [int n, text "arguments"] - -{- -************************************************************************ -* * -\subsection{Checking for a decent instance head type} -* * -************************************************************************ - -@checkValidInstHead@ checks the type {\em and} its syntactic constraints: -it must normally look like: @instance Foo (Tycon a b c ...) ...@ - -The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ -flag is on, or (2)~the instance is imported (they must have been -compiled elsewhere). In these cases, we let them go through anyway. - -We can also have instances for functions: @instance Foo (a -> b) ...@. --} - -checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () -checkValidInstHead ctxt clas cls_args - = do { dflags <- getDynFlags - ; is_boot <- tcIsHsBootOrSig - ; is_sig <- tcIsHsig - ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args - ; checkValidTypePats (classTyCon clas) cls_args - } - -{- - -Note [Instances of built-in classes in signature files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -User defined instances for KnownNat, KnownSymbol and Typeable are -disallowed -- they are generated when needed by GHC itself on-the-fly. - -However, if they occur in a Backpack signature file, they have an -entirely different meaning. Suppose in M.hsig we see - - signature M where - data T :: Nat - instance KnownNat T - -That says that any module satisfying M.hsig must provide a KnownNat -instance for T. We absolultely need that instance when compiling a -module that imports M.hsig: see #15379 and -Note [Fabricating Evidence for Literals in Backpack] in ClsInst. - -Hence, checkValidInstHead accepts a user-written instance declaration -in hsig files, where `is_sig` is True. - --} - -check_special_inst_head :: DynFlags -> Bool -> Bool - -> UserTypeCtxt -> Class -> [Type] -> TcM () --- Wow! There are a surprising number of ad-hoc special cases here. -check_special_inst_head dflags is_boot is_sig ctxt clas cls_args - - -- If not in an hs-boot file, abstract classes cannot have instances - | isAbstractClass clas - , not is_boot - = failWithTc abstract_class_msg - - -- For Typeable, don't complain about instances for - -- standalone deriving; they are no-ops, and we warn about - -- it in TcDeriv.deriveStandalone. - | clas_nm == typeableClassName - , not is_sig - -- Note [Instances of built-in classes in signature files] - , hand_written_bindings - = failWithTc rejected_class_msg - - -- Handwritten instances of KnownNat/KnownSymbol class - -- are always forbidden (#12837) - | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ] - , not is_sig - -- Note [Instances of built-in classes in signature files] - , hand_written_bindings - = failWithTc rejected_class_msg - - -- For the most part we don't allow - -- instances for (~), (~~), or Coercible; - -- but we DO want to allow them in quantified constraints: - -- f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m... - | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ] - , not quantified_constraint - = failWithTc rejected_class_msg - - -- Check for hand-written Generic instances (disallowed in Safe Haskell) - | clas_nm `elem` genericClassNames - , hand_written_bindings - = do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } - - | clas_nm == hasFieldClassName - = checkHasFieldInst clas cls_args - - | isCTupleClass clas - = failWithTc tuple_class_msg - - -- Check language restrictions on the args to the class - | check_h98_arg_shape - , Just msg <- mb_ty_args_msg - = failWithTc (instTypeErr clas cls_args msg) - - | otherwise - = pure () - where - clas_nm = getName clas - ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args - - hand_written_bindings - = case ctxt of - InstDeclCtxt stand_alone -> not stand_alone - SpecInstCtxt -> False - DerivClauseCtxt -> False - _ -> True - - check_h98_arg_shape = case ctxt of - SpecInstCtxt -> False - DerivClauseCtxt -> False - SigmaCtxt -> False - _ -> True - -- SigmaCtxt: once we are in quantified-constraint land, we - -- aren't so picky about enforcing H98-language restrictions - -- E.g. we want to allow a head like Coercible (m a) (m b) - - - -- When we are looking at the head of a quantified constraint, - -- check_quant_pred sets ctxt to SigmaCtxt - quantified_constraint = case ctxt of - SigmaCtxt -> True - _ -> False - - head_type_synonym_msg = parens ( - text "All instance types must be of the form (T t1 ... tn)" $$ - text "where T is not a synonym." $$ - text "Use TypeSynonymInstances if you want to disable this.") - - head_type_args_tyvars_msg = parens (vcat [ - text "All instance types must be of the form (T a1 ... an)", - text "where a1 ... an are *distinct type variables*,", - text "and each type variable appears at most once in the instance head.", - text "Use FlexibleInstances if you want to disable this."]) - - head_one_type_msg = parens $ - text "Only one type can be given in an instance head." $$ - text "Use MultiParamTypeClasses if you want to allow more, or zero." - - rejected_class_msg = text "Class" <+> quotes (ppr clas_nm) - <+> text "does not support user-specified instances" - tuple_class_msg = text "You can't specify an instance for a tuple constraint" - - gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)") - - abstract_class_msg = text "Cannot define instance for abstract class" - <+> quotes (ppr clas_nm) - - mb_ty_args_msg - | not (xopt LangExt.TypeSynonymInstances dflags) - , not (all tcInstHeadTyNotSynonym ty_args) - = Just head_type_synonym_msg - - | not (xopt LangExt.FlexibleInstances dflags) - , not (all tcInstHeadTyAppAllTyVars ty_args) - = Just head_type_args_tyvars_msg - - | length ty_args /= 1 - , not (xopt LangExt.MultiParamTypeClasses dflags) - , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) - = Just head_one_type_msg - - | otherwise - = Nothing - -tcInstHeadTyNotSynonym :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must not be type synonyms, but everywhere else type synonyms --- are transparent, so we need a special function here -tcInstHeadTyNotSynonym ty - = case ty of -- Do not use splitTyConApp, - -- because that expands synonyms! - TyConApp tc _ -> not (isTypeSynonymTyCon tc) - _ -> True - -tcInstHeadTyAppAllTyVars :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must be a constructor applied to type variable arguments --- or a type-level literal. --- But we allow kind instantiations. -tcInstHeadTyAppAllTyVars ty - | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) - = ok (filterOutInvisibleTypes tc tys) -- avoid kinds - | LitTy _ <- ty = True -- accept type literals (#13833) - | otherwise - = False - where - -- Check that all the types are type variables, - -- and that each is distinct - ok tys = equalLength tvs tys && hasNoDups tvs - where - tvs = mapMaybe tcGetTyVar_maybe tys - -dropCasts :: Type -> Type --- See Note [Casts during validity checking] --- This function can turn a well-kinded type into an ill-kinded --- one, so I've kept it local to this module --- To consider: drop only HoleCo casts -dropCasts (CastTy ty _) = dropCasts ty -dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) -dropCasts ty@(FunTy _ t1 t2) = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 } -dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) -dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) -dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy - -dropCastsB :: TyVarBinder -> TyVarBinder -dropCastsB b = b -- Don't bother in the kind of a forall - -instTypeErr :: Class -> [Type] -> SDoc -> SDoc -instTypeErr cls tys msg - = hang (hang (text "Illegal instance declaration for") - 2 (quotes (pprClassPred cls tys))) - 2 msg - --- | See Note [Validity checking of HasField instances] -checkHasFieldInst :: Class -> [Type] -> TcM () -checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] = - case splitTyConApp_maybe r_ty of - Nothing -> whoops (text "Record data type must be specified") - Just (tc, _) - | isFamilyTyCon tc - -> whoops (text "Record data type may not be a data family") - | otherwise -> case isStrLitTy x_ty of - Just lbl - | isJust (lookupTyConFieldLabel lbl tc) - -> whoops (ppr tc <+> text "already has a field" - <+> quotes (ppr lbl)) - | otherwise -> return () - Nothing - | null (tyConFieldLabels tc) -> return () - | otherwise -> whoops (ppr tc <+> text "has fields") - where - whoops = addErrTc . instTypeErr cls tys -checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) - -{- Note [Casts during validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the (bogus) - instance Eq Char# -We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an -insoluble equality constraint for * ~ #. We'll report the insoluble -constraint separately, but we don't want to *also* complain that Eq is -not applied to a type constructor. So we look gaily look through -CastTys here. - -Another example: Eq (Either a). Then we actually get a cast in -the middle: - Eq ((Either |> g) a) - - -Note [Validity checking of HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The HasField class has magic constraint solving behaviour (see Note -[HasField instances] in TcInteract). However, we permit users to -declare their own instances, provided they do not clash with the -built-in behaviour. In particular, we forbid: - - 1. `HasField _ r _` where r is a variable - - 2. `HasField _ (T ...) _` if T is a data family - (because it might have fields introduced later) - - 3. `HasField x (T ...) _` where x is a variable, - if T has any fields at all - - 4. `HasField "foo" (T ...) _` if T has a "foo" field - -The usual functional dependency checks also apply. - - -Note [Valid 'deriving' predicate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -validDerivPred checks for OK 'deriving' context. See Note [Exotic -derived instance contexts] in TcDeriv. However the predicate is -here because it uses sizeTypes, fvTypes. - -It checks for three things - - * No repeated variables (hasNoDups fvs) - - * No type constructors. This is done by comparing - sizeTypes tys == length (fvTypes tys) - sizeTypes counts variables and constructors; fvTypes returns variables. - So if they are the same, there must be no constructors. But there - might be applications thus (f (g x)). - - Note that tys only includes the visible arguments of the class type - constructor. Including the non-visible arguments can cause the following, - perfectly valid instance to be rejected: - class Category (cat :: k -> k -> *) where ... - newtype T (c :: * -> * -> *) a b = MkT (c a b) - instance Category c => Category (T c) where ... - since the first argument to Category is a non-visible *, which sizeTypes - would count as a constructor! See #11833. - - * Also check for a bizarre corner case, when the derived instance decl - would look like - instance C a b => D (T a) where ... - Note that 'b' isn't a parameter of T. This gives rise to all sorts of - problems; in particular, it's hard to compare solutions for equality - when finding the fixpoint, and that means the inferContext loop does - not converge. See #5287. - -Note [Equality class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't have users writing instances for the equality classes. But we -still need to be able to write instances for them ourselves. So we allow -instances only in the defining module. - --} - -validDerivPred :: TyVarSet -> PredType -> Bool --- See Note [Valid 'deriving' predicate] -validDerivPred tv_set pred - = case classifyPredType pred of - ClassPred cls tys -> cls `hasKey` typeableClassKey - -- Typeable constraints are bigger than they appear due - -- to kind polymorphism, but that's OK - || check_tys cls tys - EqPred {} -> False -- reject equality constraints - _ -> True -- Non-class predicates are ok - where - check_tys cls tys - = hasNoDups fvs - -- use sizePred to ignore implicit args - && lengthIs fvs (sizePred pred) - && all (`elemVarSet` tv_set) fvs - where tys' = filterOutInvisibleTypes (classTyCon cls) tys - fvs = fvTypes tys' - -{- -************************************************************************ -* * -\subsection{Checking instance for termination} -* * -************************************************************************ --} - -{- Note [Instances and constraint synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, we don't allow instances for constraint synonyms at all. -Consider these (#13267): - type C1 a = Show (a -> Bool) - instance C1 Int where -- I1 - show _ = "ur" - -This elicits "show is not a (visible) method of class C1", which isn't -a great message. But it comes from the renamer, so it's hard to improve. - -This needs a bit more care: - type C2 a = (Show a, Show Int) - instance C2 Int -- I2 - -If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose -the instance head, we'll expand the synonym on fly, and it'll look like - instance (%,%) (Show Int, Show Int) -and we /really/ don't want that. So we carefully do /not/ expand -synonyms, by matching on TyConApp directly. --} - -checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () -checkValidInstance ctxt hs_type ty - | not is_tc_app - = failWithTc (hang (text "Instance head is not headed by a class:") - 2 ( ppr tau)) - - | isNothing mb_cls - = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) - , text "A class instance must be for a class" ]) - - | not arity_ok - = failWithTc (text "Arity mis-match in instance head") - - | otherwise - = do { setSrcSpan head_loc $ - checkValidInstHead ctxt clas inst_tys - - ; traceTc "checkValidInstance {" (ppr ty) - - ; env0 <- tcInitTidyEnv - ; expand <- initialExpandMode - ; check_valid_theta env0 ctxt expand theta - - -- The Termination and Coverate Conditions - -- Check that instance inference will terminate (if we care) - -- For Haskell 98 this will already have been done by checkValidTheta, - -- but as we may be using other extensions we need to check. - -- - -- Note that the Termination Condition is *more conservative* than - -- the checkAmbiguity test we do on other type signatures - -- e.g. Bar a => Bar Int is ambiguous, but it also fails - -- the termination condition, because 'a' appears more often - -- in the constraint than in the head - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; if undecidable_ok - then checkAmbiguity ctxt ty - else checkInstTermination theta tau - - ; traceTc "cvi 2" (ppr ty) - - ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of - IsValid -> return () -- Check succeeded - NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) - - ; traceTc "End checkValidInstance }" empty - - ; return () } - where - (_tvs, theta, tau) = tcSplitSigmaTy ty - is_tc_app = case tau of { TyConApp {} -> True; _ -> False } - TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] - mb_cls = tyConClass_maybe tc - Just clas = mb_cls - arity_ok = inst_tys `lengthIs` classArity clas - - -- The location of the "head" of the instance - head_loc = getLoc (getLHsInstDeclHead hs_type) - -{- -Note [Paterson conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Termination test: the so-called "Paterson conditions" (see Section 5 of -"Understanding functional dependencies via Constraint Handling Rules, -JFP Jan 2007). - -We check that each assertion in the context satisfies: - (1) no variable has more occurrences in the assertion than in the head, and - (2) the assertion has fewer constructors and variables (taken together - and counting repetitions) than the head. -This is only needed with -fglasgow-exts, as Haskell 98 restrictions -(which have already been checked) guarantee termination. - -The underlying idea is that - - for any ground substitution, each assertion in the - context has fewer type constructors than the head. --} - -checkInstTermination :: ThetaType -> TcPredType -> TcM () --- See Note [Paterson conditions] -checkInstTermination theta head_pred - = check_preds emptyVarSet theta - where - head_fvs = fvType head_pred - head_size = sizeType head_pred - - check_preds :: VarSet -> [PredType] -> TcM () - check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds - - check :: VarSet -> PredType -> TcM () - check foralld_tvs pred - = case classifyPredType pred of - EqPred {} -> return () -- See #4200. - IrredPred {} -> check2 foralld_tvs pred (sizeType pred) - ClassPred cls tys - | isTerminatingClass cls - -> return () - - | isCTupleClass cls -- Look inside tuple predicates; #8359 - -> check_preds foralld_tvs tys - - | otherwise -- Other ClassPreds - -> check2 foralld_tvs pred bogus_size - where - bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys) - -- See Note [Invisible arguments and termination] - - ForAllPred tvs _ head_pred' - -> check (foralld_tvs `extendVarSetList` binderVars tvs) head_pred' - -- Termination of the quantified predicate itself is checked - -- when the predicates are individually checked for validity - - check2 foralld_tvs pred pred_size - | not (null bad_tvs) = failWithTc (noMoreMsg bad_tvs what (ppr head_pred)) - | not (isTyFamFree pred) = failWithTc (nestedMsg what) - | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred)) - | otherwise = return () - -- isTyFamFree: see Note [Type families in instance contexts] - where - what = text "constraint" <+> quotes (ppr pred) - bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred) - \\ head_fvs - -smallerMsg :: SDoc -> SDoc -> SDoc -smallerMsg what inst_head - = vcat [ hang (text "The" <+> what) - 2 (sep [ text "is no smaller than" - , text "the instance head" <+> quotes inst_head ]) - , parens undecidableMsg ] - -noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc -noMoreMsg tvs what inst_head - = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1) - <+> occurs <+> text "more often") - 2 (sep [ text "in the" <+> what - , text "than in the instance head" <+> quotes inst_head ]) - , parens undecidableMsg ] - where - tvs1 = nub tvs - occurs = if isSingleton tvs1 then text "occurs" - else text "occur" - -undecidableMsg, constraintKindsMsg :: SDoc -undecidableMsg = text "Use UndecidableInstances to permit this" -constraintKindsMsg = text "Use ConstraintKinds to permit this" - -{- Note [Type families in instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Are these OK? - type family F a - instance F a => C (Maybe [a]) where ... - intance C (F a) => C [[[a]]] where ... - -No: the type family in the instance head might blow up to an -arbitrarily large type, depending on how 'a' is instantiated. -So we require UndecidableInstances if we have a type family -in the instance head. #15172. - -Note [Invisible arguments and termination] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the ​Paterson conditions for termination an instance -declaration, we check for the number of "constructors and variables" -in the instance head and constraints. Question: Do we look at - - * All the arguments, visible or invisible? - * Just the visible arguments? - -I think both will ensure termination, provided we are consistent. -Currently we are /not/ consistent, which is really a bug. It's -described in #15177, which contains a number of examples. -The suspicious bits are the calls to filterOutInvisibleTypes. --} - - -{- -************************************************************************ -* * - Checking type instance well-formedness and termination -* * -************************************************************************ --} - -checkValidCoAxiom :: CoAxiom Branched -> TcM () -checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) - = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list - ; foldlM_ check_branch_compat [] branch_list } - where - branch_list = fromBranches branches - injectivity = tyConInjectivityInfo fam_tc - - check_branch_compat :: [CoAxBranch] -- previous branches in reverse order - -> CoAxBranch -- current branch - -> TcM [CoAxBranch]-- current branch : previous branches - -- Check for - -- (a) this branch is dominated by previous ones - -- (b) failure of injectivity - check_branch_compat prev_branches cur_branch - | cur_branch `isDominatedBy` prev_branches - = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch fam_tc cur_branch - ; return prev_branches } - | otherwise - = do { check_injectivity prev_branches cur_branch - ; return (cur_branch : prev_branches) } - - -- Injectivity check: check whether a new (CoAxBranch) can extend - -- already checked equations without violating injectivity - -- annotation supplied by the user. - -- See Note [Verifying injectivity annotation] in FamInstEnv - check_injectivity prev_branches cur_branch - | Injective inj <- injectivity - = do { dflags <- getDynFlags - ; let conflicts = - fst $ foldl' (gather_conflicts inj prev_branches cur_branch) - ([], 0) prev_branches - ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch - ; reportInjectivityErrors dflags ax cur_branch inj } - | otherwise - = return () - - gather_conflicts inj prev_branches cur_branch (acc, n) branch - -- n is 0-based index of branch in prev_branches - = case injectiveBranches inj cur_branch branch of - -- Case 1B2 in Note [Verifying injectivity annotation] in FamInstEnv - InjectivityUnified ax1 ax2 - | ax1 `isDominatedBy` (replace_br prev_branches n ax2) - -> (acc, n + 1) - | otherwise - -> (branch : acc, n + 1) - InjectivityAccepted -> (acc, n + 1) - - -- Replace n-th element in the list. Assumes 0-based indexing. - replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] - replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs - - --- Check that a "type instance" is well-formed (which includes decidability --- unless -XUndecidableInstances is given). --- -checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () -checkValidCoAxBranch fam_tc - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = typats - , cab_rhs = rhs, cab_loc = loc }) - = setSrcSpan loc $ - checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs - --- | Do validity checks on a type family equation, including consistency --- with any enclosing class instance head, termination, and lack of --- polytypes. -checkValidTyFamEqn :: TyCon -- ^ of the type family - -> [Var] -- ^ Bound variables in the equation - -> [Type] -- ^ Type patterns - -> Type -- ^ Rhs - -> TcM () -checkValidTyFamEqn fam_tc qvs typats rhs - = do { checkValidTypePats fam_tc typats - - -- Check for things used on the right but not bound on the left - ; checkFamPatBinders fam_tc qvs typats rhs - - -- Check for oversaturated visible kind arguments in a type family - -- equation. - -- See Note [Oversaturated type family equations] - ; when (isTypeFamilyTyCon fam_tc) $ - case drop (tyConArity fam_tc) typats of - [] -> pure () - spec_arg:_ -> - addErr $ text "Illegal oversaturated visible kind argument:" - <+> quotes (char '@' <> pprParendType spec_arg) - - -- The argument patterns, and RHS, are all boxed tau types - -- E.g Reject type family F (a :: k1) :: k2 - -- type instance F (forall a. a->a) = ... - -- type instance F Int# = ... - -- type instance F Int = forall a. a->a - -- type instance F Int = Int# - -- See #9357 - ; checkValidMonoType rhs - - -- We have a decidable instance unless otherwise permitted - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) - ; unless undecidable_ok $ - mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } - --- Make sure that each type family application is --- (1) strictly smaller than the lhs, --- (2) mentions no type variable more often than the lhs, and --- (3) does not contain any further type family instances. --- -checkFamInstRhs :: TyCon -> [Type] -- LHS - -> [(TyCon, [Type])] -- type family calls in RHS - -> [MsgDoc] -checkFamInstRhs lhs_tc lhs_tys famInsts - = mapMaybe check famInsts - where - lhs_size = sizeTyConAppArgs lhs_tc lhs_tys - inst_head = pprType (TyConApp lhs_tc lhs_tys) - lhs_fvs = fvTypes lhs_tys - check (tc, tys) - | not (all isTyFamFree tys) = Just (nestedMsg what) - | not (null bad_tvs) = Just (noMoreMsg bad_tvs what inst_head) - | lhs_size <= fam_app_size = Just (smallerMsg what inst_head) - | otherwise = Nothing - where - what = text "type family application" - <+> quotes (pprType (TyConApp tc tys)) - fam_app_size = sizeTyConAppArgs tc tys - bad_tvs = fvTypes tys \\ lhs_fvs - -- The (\\) is list difference; e.g. - -- [a,b,a,a] \\ [a,a] = [b,a] - -- So we are counting repetitions - ------------------ -checkFamPatBinders :: TyCon - -> [TcTyVar] -- Bound on LHS of family instance - -> [TcType] -- LHS patterns - -> Type -- RHS - -> TcM () --- We do these binder checks now, in tcFamTyPatsAndGen, rather --- than later, in checkValidFamEqn, for two reasons: --- - We have the implicitly and explicitly --- bound type variables conveniently to hand --- - If implicit variables are out of scope it may --- cause a crash; notably in tcConDecl in tcDataFamInstDecl -checkFamPatBinders fam_tc qtvs pats rhs - = do { traceTc "checkFamPatBinders" $ - vcat [ debugPprType (mkTyConApp fam_tc pats) - , ppr (mkTyConApp fam_tc pats) - , text "qtvs:" <+> ppr qtvs - , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) - , text "pat_tvs:" <+> ppr pat_tvs - , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ] - - -- Check for implicitly-bound tyvars, mentioned on the - -- RHS but not bound on the LHS - -- data T = MkT (forall (a::k). blah) - -- data family D Int = MkD (forall (a::k). blah) - -- In both cases, 'k' is not bound on the LHS, but is used on the RHS - -- We catch the former in kcDeclHeader, and the latter right here - -- See Note [Check type-family instance binders] - ; check_tvs bad_rhs_tvs (text "mentioned in the RHS") - (text "bound on the LHS of") - - -- Check for explicitly forall'd variable that is not bound on LHS - -- data instance forall a. T Int = MkT Int - -- See Note [Unused explicitly bound variables in a family pattern] - -- See Note [Check type-family instance binders] - ; check_tvs bad_qtvs (text "bound by a forall") - (text "used in") - } - where - pat_tvs = tyCoVarsOfTypes pats - inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes False pats - -- The type variables that are in injective positions. - -- See Note [Dodgy binding sites in type family instances] - -- NB: The False above is irrelevant, as we never have type families in - -- patterns. - -- - -- NB: It's OK to use the nondeterministic `fvVarSet` function here, - -- since the order of `inj_pat_tvs` is never revealed in an error - -- message. - rhs_fvs = tyCoFVsOfType rhs - used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs - bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs - -- Bound but not used at all - bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs) - -- Used on RHS but not bound on LHS - dodgy_tvs = pat_tvs `minusVarSet` inj_pat_tvs - - check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ - hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs - <+> isOrAre tvs <+> what <> comma) - 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" - , mk_extra tvs ]) - - -- mk_extra: #7536: give a decent error message for - -- type T a = Int - -- type instance F (T a) = a - mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $ - hang (text "The real LHS (expanding synonyms) is:") - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) - - --- | Checks that a list of type patterns is valid in a matching (LHS) --- position of a class instances or type/data family instance. --- --- Specifically: --- * All monotypes --- * No type-family applications -checkValidTypePats :: TyCon -> [Type] -> TcM () -checkValidTypePats tc pat_ty_args - = do { -- Check that each of pat_ty_args is a monotype. - -- One could imagine generalising to allow - -- instance C (forall a. a->a) - -- but we don't know what all the consequences might be. - traverse_ checkValidMonoType pat_ty_args - - -- Ensure that no type family applications occur a type pattern - ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of - [] -> pure () - ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ - ty_fam_inst_illegal_err tf_is_invis_arg - (mkTyConApp tf_tc tf_args) } - where - inst_ty = mkTyConApp tc pat_ty_args - - ty_fam_inst_illegal_err :: Bool -> Type -> SDoc - ty_fam_inst_illegal_err invis_arg ty - = pprWithExplicitKindsWhen invis_arg $ - hang (text "Illegal type synonym family application" - <+> quotes (ppr ty) <+> text "in instance" <> colon) - 2 (ppr inst_ty) - --- Error messages - -inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc -inaccessibleCoAxBranch fam_tc cur_branch - = text "Type family instance equation is overlapped:" $$ - nest 2 (pprCoAxBranchUser fam_tc cur_branch) - -nestedMsg :: SDoc -> SDoc -nestedMsg what - = sep [ text "Illegal nested" <+> what - , parens undecidableMsg ] - -badATErr :: Name -> Name -> SDoc -badATErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have an associated type", quotes (ppr op)] - - -------------------------- -checkConsistentFamInst :: AssocInstInfo - -> TyCon -- ^ Family tycon - -> CoAxBranch - -> TcM () --- See Note [Checking consistent instantiation] - -checkConsistentFamInst NotAssociated _ _ - = return () - -checkConsistentFamInst (InClsInst { ai_class = clas - , ai_tyvars = inst_tvs - , ai_inst_env = mini_env }) - fam_tc branch - = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs - , ppr arg_triples - , ppr mini_env - , ppr ax_tvs - , ppr ax_arg_tys - , ppr arg_triples ]) - -- Check that the associated type indeed comes from this class - -- See [Mismatched class methods and associated type families] - -- in TcInstDecls. - ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) - (badATErr (className clas) (tyConName fam_tc)) - - ; check_match arg_triples - } - where - (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch - - arg_triples :: [(Type,Type, ArgFlag)] - arg_triples = [ (cls_arg_ty, at_arg_ty, vis) - | (fam_tc_tv, vis, at_arg_ty) - <- zip3 (tyConTyVars fam_tc) - (tyConArgFlags fam_tc ax_arg_tys) - ax_arg_tys - , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] - - pp_wrong_at_arg vis - = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $ - vcat [ text "Type indexes must match class instance head" - , text "Expected:" <+> pp_expected_ty - , text " Actual:" <+> pp_actual_ty ] - - -- Fiddling around to arrange that wildcards unconditionally print as "_" - -- We only need to print the LHS, not the RHS at all - -- See Note [Printing conflicts with class header] - (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs - (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs) - - pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - [ case lookupVarEnv mini_env at_tv of - Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty - Nothing -> mk_wildcard at_tv - | at_tv <- tyConTyVars fam_tc ] - - pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - tidyTypes tidy_env2 ax_arg_tys - - mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) - tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan - - -- For check_match, bind_me, see - -- Note [Matching in the consistent-instantation check] - check_match :: [(Type,Type,ArgFlag)] -> TcM () - check_match triples = go emptyTCvSubst emptyTCvSubst triples - - go _ _ [] = return () - go lr_subst rl_subst ((ty1,ty2,vis):triples) - | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2 - , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 - = go lr_subst1 rl_subst1 triples - | otherwise - = addErrTc (pp_wrong_at_arg vis) - - -- The /scoped/ type variables from the class-instance header - -- should not be alpha-renamed. Inferred ones can be. - no_bind_set = mkVarSet inst_tvs - bind_me tv | tv `elemVarSet` no_bind_set = Skolem - | otherwise = BindMe - - -{- Note [Check type-family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type family instance, we require (of course), type variables -used on the RHS are matched on the LHS. This is checked by -checkFamPatBinders. Here is an interesting example: - - type family T :: k - type instance T = (Nothing :: Maybe a) - -Upon a cursory glance, it may appear that the kind variable `a` is unbound -since there are no (visible) LHS patterns in `T`. However, there is an -*invisible* pattern due to the return kind, so inside of GHC, the instance -looks closer to this: - - type family T @k :: k - type instance T @(Maybe a) = (Nothing :: Maybe a) - -Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in -fact not unbound. Contrast that with this example (#13985) - - type instance T = Proxy (Nothing :: Maybe a) - -This would looks like this inside of GHC: - - type instance T @(*) = Proxy (Nothing :: Maybe a) - -So this time, `a` is neither bound by a visible nor invisible type pattern on -the LHS, so `a` would be reported as not in scope. - -Finally, here's one more brain-teaser (from #9574). In the example below: - - class Funct f where - type Codomain f :: * - instance Funct ('KProxy :: KProxy o) where - type Codomain 'KProxy = NatTr (Proxy :: o -> *) - -As it turns out, `o` is in scope in this example. That is because `o` is -bound by the kind signature of the LHS type pattern 'KProxy. To make this more -obvious, one can also write the instance like so: - - instance Funct ('KProxy :: KProxy o) where - type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) - -Note [Dodgy binding sites in type family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example (from #7536): - - type T a = Int - type instance F (T a) = a - -This `F` instance is extremely fishy, since the RHS, `a`, purports to be -"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because -`T a` expands to `Int`, which doesn't mention at all, so it's as if one had -actually written: - - type instance F Int = a - -That is clearly bogus, so to reject this, we check that every type variable -that is mentioned on the RHS is /actually/ bound on the LHS. In other words, -we need to do something slightly more sophisticated that just compute the free -variables of the LHS patterns. - -It's tempting to just expand all type synonyms on the LHS and then compute -their free variables, but even that isn't sophisticated enough. After all, -an impish user could write the following (#17008): - - type family ConstType (a :: Type) :: Type where - ConstType _ = Type - - type family F (x :: ConstType a) :: Type where - F (x :: ConstType a) = a - -Just like in the previous example, the `a` on the RHS isn't actually bound -on the LHS, but this time a type family is responsible for the deception, not -a type synonym. - -We avoid both issues by requiring that all RHS type variables are mentioned -in injective positions on the left-hand side (by way of -`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective -position, as `T` is not an injective type constructor, so we do not count that. -Similarly for the `a` in `ConstType a`. - -Note [Matching in the consistent-instantation check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Matching the class-instance header to family-instance tyvars is -tricker than it sounds. Consider (#13972) - class C (a :: k) where - type T k :: Type - instance C Left where - type T (a -> Either a b) = Int - -Here there are no lexically-scoped variables from (C Left). -Yet the real class-instance header is C @(p -> Either @p @q)) (Left @p @q) -while the type-family instance is T (a -> Either @a @b) -So we allow alpha-renaming of variables that don't come -from the class-instance header. - -We track the lexically-scoped type variables from the -class-instance header in ai_tyvars. - -Here's another example (#14045a) - class C (a :: k) where - data S (a :: k) - instance C (z :: Bool) where - data S :: Bool -> Type where - -Again, there is no lexical connection, but we will get - class-instance header: C @Bool (z::Bool) - family instance S @Bool (a::Bool) - -When looking for mis-matches, we check left-to-right, -kinds first. If we look at types first, we'll fail to -suggest -fprint-explicit-kinds for a mis-match with - T @k vs T @Type -somewhere deep inside the type - -Note [Checking consistent instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #11450 for background discussion on this check. - - class C a b where - type T a x b - -With this class decl, if we have an instance decl - instance C ty1 ty2 where ... -then the type instance must look like - type T ty1 v ty2 = ... -with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. -For example: - - instance C [p] Int - type T [p] y Int = (p,y,y) - -Note that - -* We used to allow completely different bound variables in the - associated type instance; e.g. - instance C [p] Int - type T [q] y Int = ... - But from GHC 8.2 onwards, we don't. It's much simpler this way. - See #11450. - -* When the class variable isn't used on the RHS of the type instance, - it's tempting to allow wildcards, thus - instance C [p] Int - type T [_] y Int = (y,y) - But it's awkward to do the test, and it doesn't work if the - variable is repeated: - instance C (p,p) Int - type T (_,_) y Int = (y,y) - Even though 'p' is not used on the RHS, we still need to use 'p' - on the LHS to establish the repeated pattern. So to keep it simple - we just require equality. - -* For variables in associated type families that are not bound by the class - itself, we do _not_ check if they are over-specific. In other words, - it's perfectly acceptable to have an instance like this: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - - While the first and third arguments to T are required to be exactly [p] and - Int, respectively, since they are bound by C, the second argument is allowed - to be more specific than just a type variable. Furthermore, it is permissible - to define multiple equations for T that differ only in the non-class-bound - argument: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - type T [p] (Either x y) Int = x -> y - - We once considered requiring that non-class-bound variables in associated - type family instances be instantiated with distinct type variables. However, - that requirement proved too restrictive in practice, as there were examples - of extremely simple associated type family instances that this check would - reject, and fixing them required tiresome boilerplate in the form of - auxiliary type families. For instance, you would have to define the above - example as: - - instance C [p] Int where - type T [p] x Int = CAux x - - type family CAux x where - CAux (Maybe x) = x - CAux (Either x y) = x -> y - - We decided that this restriction wasn't buying us much, so we opted not - to pursue that design (see also GHC #13398). - -Implementation - * Form the mini-envt from the class type variables a,b - to the instance decl types [p],Int: [a->[p], b->Int] - - * Look at the tyvars a,x,b of the type family constructor T - (it shares tyvars with the class C) - - * Apply the mini-evnt to them, and check that the result is - consistent with the instance types [p] y Int. (where y can be any type, as - it is not scoped over the class type variables. - -We make all the instance type variables scope over the -type instances, of course, which picks up non-obvious kinds. Eg - class Foo (a :: k) where - type F a - instance Foo (b :: k -> k) where - type F b = Int -Here the instance is kind-indexed and really looks like - type F (k->k) (b::k->k) = Int -But if the 'b' didn't scope, we would make F's instance too -poly-kinded. - -Note [Printing conflicts with class header] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's remarkably painful to give a decent error message for conflicts -with the class header. Consider - clase C b where - type F a b c - instance C [b] where - type F x Int _ _ = ... - -Here we want to report a conflict between - Expected: F _ [b] _ - Actual: F x Int _ _ - -But if the type instance shadows the class variable like this -(rename/should_fail/T15828): - instance C [b] where - type forall b. F x (Tree b) _ _ = ... - -then we must use a fresh variable name - Expected: F _ [b] _ - Actual: F x [b1] _ _ - -Notice that: - - We want to print an underscore in the "Expected" type in - positions where the class header has no influence over the - parameter. Hence the fancy footwork in pp_expected_ty - - - Although the binders in the axiom are aready tidy, we must - re-tidy them to get a fresh variable name when we shadow - - - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the - class-instance variables a second time, from 'a' to 'a1' say. - Remember, the ax_tvs of the axiom share identity with the - class-instance variables, inst_tvs.. - - - We use tidyCoAxBndrsForUser to get underscores rather than - _1, _2, etc in the axiom tyvars; see the definition of - tidyCoAxBndrsForUser - -This all seems absurdly complicated. - -Note [Unused explicitly bound variables in a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Why is 'unusedExplicitForAllErr' not just a warning? - -Consider the following examples: - - type instance F a = Maybe b - type instance forall b. F a = Bool - type instance forall b. F a = Maybe b - -In every case, b is a type variable not determined by the LHS pattern. The -first is caught by the renamer, but we catch the last two here. Perhaps one -could argue that the second should be accepted, albeit with a warning, but -consider the fact that in a type family instance, there is no way to interact -with such a varable. At least with @x :: forall a. Int@ we can use visibile -type application, like @x \@Bool 1@. (Of course it does nothing, but it is -permissible.) In the type family case, the only sensible explanation is that -the user has made a mistake -- thus we throw an error. - -Note [Oversaturated type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type family tycons have very rigid arities. We want to reject something like -this: - - type family Foo :: Type -> Type where - Foo x = ... - -Because Foo has arity zero (i.e., it doesn't bind anything to the left of the -double colon), we want to disallow any equation for Foo that has more than zero -arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an -equation has more arguments than the arity of the type family, reject. - -Things get trickier when visible kind application enters the picture. Consider -the following example: - - type family Bar (x :: j) :: forall k. Either j k where - Bar 5 @Symbol = ... - -The arity of Bar is two, since it binds two variables, `j` and `x`. But even -though Bar's equation has two arguments, it's still invalid. Imagine the same -equation in Core: - - Bar Nat 5 Symbol = ... - -Here, it becomes apparent that Bar is actually taking /three/ arguments! So -we can't just rely on a simple counting argument to reject -`Bar 5 @Symbol = ...`, since it only has two user-written arguments. -Moreover, there's one explicit argument (5) and one visible kind argument -(@Symbol), which matches up perfectly with the fact that Bar has one required -binder (x) and one specified binder (j), so that's not a valid way to detect -oversaturation either. - -To solve this problem in a robust way, we do the following: - -1. When kind-checking, we count the number of user-written *required* - arguments and check if there is an equal number of required tycon binders. - If not, reject. (See `wrongNumberOfParmsErr` in TcTyClsDecls.) - - We perform this step during kind-checking, not during validity checking, - since we can give better error messages if we catch it early. -2. When validity checking, take all of the (Core) type patterns from on - equation, drop the first n of them (where n is the arity of the type family - tycon), and check if there are any types leftover. If so, reject. - - Why does this work? We know that after dropping the first n type patterns, - none of the leftover types can be required arguments, since step (1) would - have already caught that. Moreover, the only places where visible kind - applications should be allowed are in the first n types, since those are the - only arguments that can correspond to binding forms. Therefore, the - remaining arguments must correspond to oversaturated uses of visible kind - applications, which are precisely what we want to reject. - -Note that we only perform this check for type families, and not for data -families. This is because it is perfectly acceptable to oversaturate data -family instance equations: see Note [Arity of data families] in FamInstEnv. - -************************************************************************ -* * - Telescope checking -* * -************************************************************************ - -Note [Bad TyCon telescopes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Now that we can mix type and kind variables, there are an awful lot of -ways to shoot yourself in the foot. Here are some. - - data SameKind :: k -> k -> * -- just to force unification - -1. data T1 a k (b :: k) (x :: SameKind a b) - -The problem here is that we discover that a and b should have the same -kind. But this kind mentions k, which is bound *after* a. -(Testcase: dependent/should_fail/BadTelescope) - -2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -Note that b is not bound. Yet its kind mentions a. Because we have -a nice rule that all implicitly bound variables come before others, -this is bogus. - -To catch these errors, we call checkTyConTelescope during kind-checking -datatype declarations. This checks for - -* Ill-scoped binders. From (1) and (2) above we can get putative - kinds like - T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> * - where 'k' is mentioned a's kind before k is bound - - This is easy to check for: just look for - out-of-scope variables in the kind - -* We should arguably also check for ambiguous binders - but we don't. See Note [Ambiguous kind vars]. - -See also - * Note [Required, Specified, and Inferred for types] in TcTyClsDecls. - * Note [Keeping scoped variables in order: Explicit] discusses how - this check works for `forall x y z.` written in a type. - -Note [Ambiguous kind vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to be concerned about ambiguous binders. Suppose we have the kind - S1 :: forall k -> * -> * - S2 :: forall k. * -> * -Here S1 is OK, because k is Required, and at a use of S1 we will -see (S1 *) or (S1 (*->*)) or whatever. - -But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and -we have no way (ever) to figure out how 'k' should be instantiated. -For example if we see (S2 Int), that tells us nothing about k's -instantiation. (In this case we'll instantiate it to Any, but that -seems wrong.) This is really the same test as we make for ambiguous -type in term type signatures. - -Now, it's impossible for a Specified variable not to occur -at all in the kind -- after all, it is Specified so it must have -occurred. (It /used/ to be possible; see tests T13983 and T7873. But -with the advent of the forall-or-nothing rule for kind variables, -those strange cases went away.) - -But one might worry about - type v k = * - S3 :: forall k. V k -> * -which appears to mention 'k' but doesn't really. Or - S4 :: forall k. F k -> * -where F is a type function. But we simply don't check for -those cases of ambiguity, yet anyway. The worst that can happen -is ambiguity at the call sites. - -Historical note: this test used to be called reportFloatingKvs. --} - --- | Check a list of binders to see if they make a valid telescope. --- See Note [Bad TyCon telescopes] -type TelescopeAcc - = ( TyVarSet -- Bound earlier in the telescope - , Bool -- At least one binder occurred (in a kind) before - -- it was bound in the telescope. E.g. - ) -- T :: forall (a::k) k. blah - -checkTyConTelescope :: TyCon -> TcM () -checkTyConTelescope tc - | bad_scope - = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ - vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") - 2 pp_tc_kind - , extra - , hang (text "Perhaps try this order instead:") - 2 (pprTyVars sorted_tvs) ] - - | otherwise - = return () - where - tcbs = tyConBinders tc - tvs = binderVars tcbs - sorted_tvs = scopedSort tvs - - (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs - - add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc - add_one (bound, bad_scope) tcb - = ( bound `extendVarSet` tv - , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) ) - where - tv = binderVar tcb - fkvs = tyCoVarsOfType (tyVarKind tv) - - inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] - specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ] - - pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) - pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) - - pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc) - ppr_untidy ty = pprIfaceType (toIfaceType ty) - -- We need ppr_untidy here because pprType will tidy the type, which - -- will turn the bogus kind we are trying to report - -- T :: forall (a::k) k (b::k) -> blah - -- into a misleadingly sanitised version - -- T :: forall (a::k) k1 (b::k1) -> blah - - extra - | null inferred_tvs && null specified_tvs - = empty - | null inferred_tvs - = hang (text "NB: Specified variables") - 2 (sep [pp_spec, text "always come first"]) - | null specified_tvs - = hang (text "NB: Inferred variables") - 2 (sep [pp_inf, text "always come first"]) - | otherwise - = hang (text "NB: Inferred variables") - 2 (vcat [ sep [ pp_inf, text "always come first"] - , sep [text "then Specified variables", pp_spec]]) - -{- -************************************************************************ -* * -\subsection{Auxiliary functions} -* * -************************************************************************ --} - --- Free variables of a type, retaining repetitions, and expanding synonyms --- This ignores coercions, as coercions aren't user-written -fvType :: Type -> [TyCoVar] -fvType ty | Just exp_ty <- tcView ty = fvType exp_ty -fvType (TyVarTy tv) = [tv] -fvType (TyConApp _ tys) = fvTypes tys -fvType (LitTy {}) = [] -fvType (AppTy fun arg) = fvType fun ++ fvType arg -fvType (FunTy _ arg res) = fvType arg ++ fvType res -fvType (ForAllTy (Bndr tv _) ty) - = fvType (tyVarKind tv) ++ - filter (/= tv) (fvType ty) -fvType (CastTy ty _) = fvType ty -fvType (CoercionTy {}) = [] - -fvTypes :: [Type] -> [TyVar] -fvTypes tys = concat (map fvType tys) - -sizeType :: Type -> Int --- Size of a type: the number of variables and constructors -sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -sizeType (TyVarTy {}) = 1 -sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys -sizeType (LitTy {}) = 1 -sizeType (AppTy fun arg) = sizeType fun + sizeType arg -sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1 -sizeType (ForAllTy _ ty) = sizeType ty -sizeType (CastTy ty _) = sizeType ty -sizeType (CoercionTy _) = 0 - -sizeTypes :: [Type] -> Int -sizeTypes = foldr ((+) . sizeType) 0 - -sizeTyConAppArgs :: TyCon -> [Type] -> Int -sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys) - -- See Note [Invisible arguments and termination] - --- Size of a predicate --- --- We are considering whether class constraints terminate. --- Equality constraints and constraints for the implicit --- parameter class always terminate so it is safe to say "size 0". --- See #4200. -sizePred :: PredType -> Int -sizePred ty = goClass ty - where - goClass p = go (classifyPredType p) - - go (ClassPred cls tys') - | isTerminatingClass cls = 0 - | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys') - -- The filtering looks bogus - -- See Note [Invisible arguments and termination] - go (EqPred {}) = 0 - go (IrredPred ty) = sizeType ty - go (ForAllPred _ _ pred) = goClass pred - --- | When this says "True", ignore this class constraint during --- a termination check -isTerminatingClass :: Class -> Bool -isTerminatingClass cls - = isIPClass cls -- Implicit parameter constraints always terminate because - -- there are no instances for them --- they are only solved - -- by "local instances" in expressions - || isEqPredClass cls - || cls `hasKey` typeableClassKey - || cls `hasKey` coercibleTyConKey - --- | Tidy before printing a type -ppr_tidy :: TidyEnv -> Type -> SDoc -ppr_tidy env ty = pprType (tidyType env ty) - -allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool --- (allDistinctTyVars tvs tys) returns True if tys are --- a) all tyvars --- b) all distinct --- c) disjoint from tvs -allDistinctTyVars _ [] = True -allDistinctTyVars tkvs (ty : tys) - = case getTyVar_maybe ty of - Nothing -> False - Just tv | tv `elemVarSet` tkvs -> False - | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys diff --git a/types/Class.hs b/types/Class.hs deleted file mode 100644 --- a/types/Class.hs +++ /dev/null @@ -1,360 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- --- The @Class@ datatype - -{-# LANGUAGE CPP #-} - -module Class ( - Class, - ClassOpItem, - ClassATItem(..), - ClassMinimalDef, - DefMethInfo, pprDefMethInfo, - - FunDep, pprFundeps, pprFunDep, - - mkClass, mkAbstractClass, classTyVars, classArity, - classKey, className, classATs, classATItems, classTyCon, classMethods, - classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, - classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, - isAbstractClass, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TyCoRep ( Type, PredType ) -import {-# SOURCE #-} TyCoPpr ( pprType ) -import Var -import Name -import BasicTypes -import Unique -import Util -import SrcLoc -import Outputable -import BooleanFormula (BooleanFormula, mkTrue) - -import qualified Data.Data as Data - -{- -************************************************************************ -* * -\subsection[Class-basic]{@Class@: basic definition} -* * -************************************************************************ - -A @Class@ corresponds to a Greek kappa in the static semantics: --} - -data Class - = Class { - classTyCon :: TyCon, -- The data type constructor for - -- dictionaries of this class - -- See Note [ATyCon for classes] in TyCoRep - - className :: Name, -- Just the cached name of the TyCon - classKey :: Unique, -- Cached unique of TyCon - - classTyVars :: [TyVar], -- The class kind and type variables; - -- identical to those of the TyCon - -- If you want visibility info, look at the classTyCon - -- This field is redundant because it's duplicated in the - -- classTyCon, but classTyVars is used quite often, so maybe - -- it's a bit faster to cache it here - - classFunDeps :: [FunDep TyVar], -- The functional dependencies - - classBody :: ClassBody -- Superclasses, ATs, methods - - } - --- | e.g. --- --- > class C a b c | a b -> c, a c -> b where... --- --- Here fun-deps are [([a,b],[c]), ([a,c],[b])] --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', - --- For details on above see note [Api annotations] in ApiAnnotation -type FunDep a = ([a],[a]) - -type ClassOpItem = (Id, DefMethInfo) - -- Selector function; contains unfolding - -- Default-method info - -type DefMethInfo = Maybe (Name, DefMethSpec Type) - -- Nothing No default method - -- Just ($dm, VanillaDM) A polymorphic default method, name $dm - -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty - -- The generic dm type is *not* quantified - -- over the class variables; ie has the - -- class variables free - -data ClassATItem - = ATI TyCon -- See Note [Associated type tyvar names] - (Maybe (Type, SrcSpan)) - -- Default associated type (if any) from this template - -- Note [Associated type defaults] - -type ClassMinimalDef = BooleanFormula Name -- Required methods - -data ClassBody - = AbstractClass - | ConcreteClass { - -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) - -- We need value-level selectors for both the dictionary - -- superclasses and the equality superclasses - cls_sc_theta :: [PredType], -- Immediate superclasses, - cls_sc_sel_ids :: [Id], -- Selector functions to extract the - -- superclasses from a - -- dictionary of this class - -- Associated types - cls_ats :: [ClassATItem], -- Associated type families - - -- Class operations (methods, not superclasses) - cls_ops :: [ClassOpItem], -- Ordered by tag - - -- Minimal complete definition - cls_min_def :: ClassMinimalDef - } - -- TODO: maybe super classes should be allowed in abstract class definitions - -classMinimalDef :: Class -> ClassMinimalDef -classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d -classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction - -{- -Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following is an example of associated type defaults: - class C a where - data D a r - - type F x a b :: * - type F p q r = (p,q)->r -- Default - -Note that - - * The TyCons for the associated types *share type variables* with the - class, so that we can tell which argument positions should be - instantiated in an instance decl. (The first for 'D', the second - for 'F'.) - - * We can have default definitions only for *type* families, - not data families - - * In the default decl, the "patterns" should all be type variables, - but (in the source language) they don't need to be the same as in - the 'type' decl signature or the class. It's more like a - free-standing 'type instance' declaration. - - * HOWEVER, in the internal ClassATItem we rename the RHS to match the - tyConTyVars of the family TyCon. So in the example above we'd get - a ClassATItem of - ATI F ((x,a) -> b) - So the tyConTyVars of the family TyCon bind the free vars of - the default Type rhs - -The @mkClass@ function fills in the indirect superclasses. - -The SrcSpan is for the entire original declaration. --} - -mkClass :: Name -> [TyVar] - -> [FunDep TyVar] - -> [PredType] -> [Id] - -> [ClassATItem] - -> [ClassOpItem] - -> ClassMinimalDef - -> TyCon - -> Class - -mkClass cls_name tyvars fds super_classes superdict_sels at_stuff - op_stuff mindef tycon - = Class { classKey = nameUnique cls_name, - className = cls_name, - -- NB: tyConName tycon = cls_name, - -- But it takes a module loop to assert it here - classTyVars = tyvars, - classFunDeps = fds, - classBody = ConcreteClass { - cls_sc_theta = super_classes, - cls_sc_sel_ids = superdict_sels, - cls_ats = at_stuff, - cls_ops = op_stuff, - cls_min_def = mindef - }, - classTyCon = tycon } - -mkAbstractClass :: Name -> [TyVar] - -> [FunDep TyVar] - -> TyCon - -> Class - -mkAbstractClass cls_name tyvars fds tycon - = Class { classKey = nameUnique cls_name, - className = cls_name, - -- NB: tyConName tycon = cls_name, - -- But it takes a module loop to assert it here - classTyVars = tyvars, - classFunDeps = fds, - classBody = AbstractClass, - classTyCon = tycon } - -{- -Note [Associated type tyvar names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The TyCon of an associated type should use the same variable names as its -parent class. Thus - class C a b where - type F b x a :: * -We make F use the same Name for 'a' as C does, and similary 'b'. - -The reason for this is when checking instances it's easier to match -them up, to ensure they match. Eg - instance C Int [d] where - type F [d] x Int = .... -we should make sure that the first and third args match the instance -header. - -Having the same variables for class and tycon is also used in checkValidRoles -(in TcTyClsDecls) when checking a class's roles. - - -************************************************************************ -* * -\subsection[Class-selectors]{@Class@: simple selectors} -* * -************************************************************************ - -The rest of these functions are just simple selectors. --} - -classArity :: Class -> Arity -classArity clas = length (classTyVars clas) - -- Could memoise this - -classAllSelIds :: Class -> [Id] --- Both superclass-dictionary and method selectors -classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) - = sc_sels ++ classMethods c -classAllSelIds c = ASSERT( null (classMethods c) ) [] - -classSCSelIds :: Class -> [Id] --- Both superclass-dictionary and method selectors -classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) - = sc_sels -classSCSelIds c = ASSERT( null (classMethods c) ) [] - -classSCSelId :: Class -> Int -> Id --- Get the n'th superclass selector Id --- where n is 0-indexed, and counts --- *all* superclasses including equalities -classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n - = ASSERT( n >= 0 && lengthExceeds sc_sels n ) - sc_sels !! n -classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) - -classMethods :: Class -> [Id] -classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) - = [op_sel | (op_sel, _) <- op_stuff] -classMethods _ = [] - -classOpItems :: Class -> [ClassOpItem] -classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) - = op_stuff -classOpItems _ = [] - -classATs :: Class -> [TyCon] -classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) - = [tc | ATI tc _ <- at_stuff] -classATs _ = [] - -classATItems :: Class -> [ClassATItem] -classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) - = at_stuff -classATItems _ = [] - -classSCTheta :: Class -> [PredType] -classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) - = theta_stuff -classSCTheta _ = [] - -classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) -classTvsFds c = (classTyVars c, classFunDeps c) - -classHasFds :: Class -> Bool -classHasFds (Class { classFunDeps = fds }) = not (null fds) - -classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) -classBigSig (Class {classTyVars = tyvars, - classBody = AbstractClass}) - = (tyvars, [], [], []) -classBigSig (Class {classTyVars = tyvars, - classBody = ConcreteClass { - cls_sc_theta = sc_theta, - cls_sc_sel_ids = sc_sels, - cls_ops = op_stuff - }}) - = (tyvars, sc_theta, sc_sels, op_stuff) - -classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) -classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, - classBody = AbstractClass}) - = (tyvars, fundeps, [], [], [], []) -classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, - classBody = ConcreteClass { - cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, - cls_ats = ats, cls_ops = op_stuff - }}) - = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) - -isAbstractClass :: Class -> Bool -isAbstractClass Class{ classBody = AbstractClass } = True -isAbstractClass _ = False - -{- -************************************************************************ -* * -\subsection[Class-instances]{Instance declarations for @Class@} -* * -************************************************************************ - -We compare @Classes@ by their keys (which include @Uniques@). --} - -instance Eq Class where - c1 == c2 = classKey c1 == classKey c2 - c1 /= c2 = classKey c1 /= classKey c2 - -instance Uniquable Class where - getUnique c = classKey c - -instance NamedThing Class where - getName clas = className clas - -instance Outputable Class where - ppr c = ppr (getName c) - -pprDefMethInfo :: DefMethInfo -> SDoc -pprDefMethInfo Nothing = empty -- No default method -pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n -pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" - <+> ppr n <+> dcolon <+> pprType ty - -pprFundeps :: Outputable a => [FunDep a] -> SDoc -pprFundeps [] = empty -pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) - -pprFunDep :: Outputable a => FunDep a -> SDoc -pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] - -instance Data.Data Class where - -- don't traverse? - toConstr _ = abstractConstr "Class" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Class" diff --git a/types/CoAxiom.hs b/types/CoAxiom.hs deleted file mode 100644 --- a/types/CoAxiom.hs +++ /dev/null @@ -1,573 +0,0 @@ --- (c) The University of Glasgow 2012 - -{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, - ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} - --- | Module for coercion axioms, used to represent type family instances --- and newtypes - -module CoAxiom ( - BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), - manyBranches, unbranched, - fromBranches, numBranches, - mapAccumBranches, - - CoAxiom(..), CoAxBranch(..), - - toBranchedAxiom, toUnbranchedAxiom, - coAxiomName, coAxiomArity, coAxiomBranches, - coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, - coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, - coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, - coAxBranchRoles, - coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, - placeHolderIncomps, - - Role(..), fsFromRole, - - CoAxiomRule(..), TypeEqn, - BuiltInSynFamily(..), trivialBuiltInFamily - ) where - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep ( Type ) -import {-# SOURCE #-} TyCoPpr ( pprType ) -import {-# SOURCE #-} TyCon ( TyCon ) -import Outputable -import FastString -import Name -import Unique -import Var -import Util -import Binary -import Pair -import BasicTypes -import Data.Typeable ( Typeable ) -import SrcLoc -import qualified Data.Data as Data -import Data.Array -import Data.List ( mapAccumL ) - -#include "HsVersions.h" - -{- -Note [Coercion axiom branches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to allow closed type families, an axiom needs to contain an -ordered list of alternatives, called branches. The kind of the coercion built -from an axiom is determined by which index is used when building the coercion -from the axiom. - -For example, consider the axiom derived from the following declaration: - -type family F a where - F [Int] = Bool - F [a] = Double - F (a b) = Char - -This will give rise to this axiom: - -axF :: { F [Int] ~ Bool - ; forall (a :: *). F [a] ~ Double - ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char - } - -The axiom is used with the AxiomInstCo constructor of Coercion. If we wish -to have a coercion showing that F (Maybe Int) ~ Char, it will look like - -axF[2] <*> :: F (Maybe Int) ~ Char --- or, written using concrete-ish syntax -- -AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] - -Note that the index is 0-based. - -For type-checking, it is also necessary to check that no previous pattern -can unify with the supplied arguments. After all, it is possible that some -of the type arguments are lambda-bound type variables whose instantiation may -cause an earlier match among the branches. We wish to prohibit this behavior, -so the type checker rules out the choice of a branch where a previous branch -can unify. See also [Apartness] in FamInstEnv.hs. - -For example, the following is malformed, where 'a' is a lambda-bound type -variable: - -axF[2] <*> :: F (a Bool) ~ Char - -Why? Because a might be instantiated with [], meaning that branch 1 should -apply, not branch 2. This is a vital consistency check; without it, we could -derive Int ~ Bool, and that is a Bad Thing. - -Note [Branched axioms] -~~~~~~~~~~~~~~~~~~~~~~ -Although a CoAxiom has the capacity to store many branches, in certain cases, -we want only one. These cases are in data/newtype family instances, newtype -coercions, and type family instances. -Furthermore, these unbranched axioms are used in a -variety of places throughout GHC, and it would difficult to generalize all of -that code to deal with branched axioms, especially when the code can be sure -of the fact that an axiom is indeed a singleton. At the same time, it seems -dangerous to assume singlehood in various places through GHC. - -The solution to this is to label a CoAxiom with a phantom type variable -declaring whether it is known to be a singleton or not. The branches -are stored using a special datatype, declared below, that ensures that the -type variable is accurate. - -************************************************************************ -* * - Branches -* * -************************************************************************ --} - -type BranchIndex = Int -- The index of the branch in the list of branches - -- Counting from zero - --- promoted data type -data BranchFlag = Branched | Unbranched -type Branched = 'Branched -type Unbranched = 'Unbranched --- By using type synonyms for the promoted constructors, we avoid needing --- DataKinds and the promotion quote in client modules. This also means that --- we don't need to export the term-level constructors, which should never be used. - -newtype Branches (br :: BranchFlag) - = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } -type role Branches nominal - -manyBranches :: [CoAxBranch] -> Branches Branched -manyBranches brs = ASSERT( snd bnds >= fst bnds ) - MkBranches (listArray bnds brs) - where - bnds = (0, length brs - 1) - -unbranched :: CoAxBranch -> Branches Unbranched -unbranched br = MkBranches (listArray (0, 0) [br]) - -toBranched :: Branches br -> Branches Branched -toBranched = MkBranches . unMkBranches - -toUnbranched :: Branches br -> Branches Unbranched -toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) - MkBranches arr - -fromBranches :: Branches br -> [CoAxBranch] -fromBranches = elems . unMkBranches - -branchesNth :: Branches br -> BranchIndex -> CoAxBranch -branchesNth (MkBranches arr) n = arr ! n - -numBranches :: Branches br -> Int -numBranches (MkBranches arr) = snd (bounds arr) + 1 - --- | The @[CoAxBranch]@ passed into the mapping function is a list of --- all previous branches, reversed -mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) - -> Branches br -> Branches br -mapAccumBranches f (MkBranches arr) - = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) - where - go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) - go prev_branches cur_branch = ( cur_branch : prev_branches - , f prev_branches cur_branch ) - - -{- -************************************************************************ -* * - Coercion axioms -* * -************************************************************************ - -Note [Storing compatibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During axiom application, we need to be aware of which branches are compatible -with which others. The full explanation is in Note [Compatibility] in -FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on -the unification algorithm.) Although we could theoretically compute -compatibility on the fly, this is silly, so we store it in a CoAxiom. - -Specifically, each branch refers to all other branches with which it is -incompatible. This list might well be empty, and it will always be for the -first branch of any axiom. - -CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk -stored in cab_incomps. The incompatibilities are properly a property of the -axiom as a whole, and they are computed only when the final axiom is built. - -During serialization, the list is converted into a list of the indices -of the branches. --} - --- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data CoAxiom br - = CoAxiom -- Type equality axiom. - { co_ax_unique :: Unique -- Unique identifier - , co_ax_name :: Name -- Name for pretty-printing - , co_ax_role :: Role -- Role of the axiom's equality - , co_ax_tc :: TyCon -- The head of the LHS patterns - -- e.g. the newtype or family tycon - , co_ax_branches :: Branches br -- The branches that form this axiom - , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" - -- See Note [Implicit axioms] - -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. - } - -data CoAxBranch - = CoAxBranch - { cab_loc :: SrcSpan -- Location of the defining equation - -- See Note [CoAxiom locations] - , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh - , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars - -- See Note [CoAxBranch type variables] - -- cab_tvs and cab_lhs may be eta-reduded; see - -- Note [Eta reduction for data families] - , cab_cvs :: [CoVar] -- Bound coercion variables - -- Always empty, for now. - -- See Note [Constraints in patterns] - -- in TcTyClsDecls - , cab_roles :: [Role] -- See Note [CoAxBranch roles] - , cab_lhs :: [Type] -- Type patterns to match against - , cab_rhs :: Type -- Right-hand side of the equality - , cab_incomps :: [CoAxBranch] -- The previous incompatible branches - -- See Note [Storing compatibility] - } - deriving Data.Data - -toBranchedAxiom :: CoAxiom br -> CoAxiom Branched -toBranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toBranched branches) implicit - -toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched -toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toUnbranched branches) implicit - -coAxiomNumPats :: CoAxiom br -> Int -coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) - -coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch -coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index - = branchesNth bs index - -coAxiomArity :: CoAxiom br -> BranchIndex -> Arity -coAxiomArity ax index - = length tvs + length cvs - where - CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index - -coAxiomName :: CoAxiom br -> Name -coAxiomName = co_ax_name - -coAxiomRole :: CoAxiom br -> Role -coAxiomRole = co_ax_role - -coAxiomBranches :: CoAxiom br -> Branches br -coAxiomBranches = co_ax_branches - -coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch -coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) - | snd (bounds arr) == 0 - = Just $ arr ! 0 - | otherwise - = Nothing - -coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch -coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) - = arr ! 0 - -coAxiomTyCon :: CoAxiom br -> TyCon -coAxiomTyCon = co_ax_tc - -coAxBranchTyVars :: CoAxBranch -> [TyVar] -coAxBranchTyVars = cab_tvs - -coAxBranchCoVars :: CoAxBranch -> [CoVar] -coAxBranchCoVars = cab_cvs - -coAxBranchLHS :: CoAxBranch -> [Type] -coAxBranchLHS = cab_lhs - -coAxBranchRHS :: CoAxBranch -> Type -coAxBranchRHS = cab_rhs - -coAxBranchRoles :: CoAxBranch -> [Role] -coAxBranchRoles = cab_roles - -coAxBranchSpan :: CoAxBranch -> SrcSpan -coAxBranchSpan = cab_loc - -isImplicitCoAxiom :: CoAxiom br -> Bool -isImplicitCoAxiom = co_ax_implicit - -coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] -coAxBranchIncomps = cab_incomps - --- See Note [Compatibility checking] in FamInstEnv -placeHolderIncomps :: [CoAxBranch] -placeHolderIncomps = panic "placeHolderIncomps" - -{- -Note [CoAxBranch type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of a CoAxBranch of an associated type-family instance, -we use the *same* type variables (where possible) as the -enclosing class or instance. Consider - - instance C Int [z] where - type F Int [z] = ... -- Second param must be [z] - -In the CoAxBranch in the instance decl (F Int [z]) we use the -same 'z', so that it's easy to check that that type is the same -as that in the instance header. - -So, unlike FamInsts, there is no expectation that the cab_tvs -are fresh wrt each other, or any other CoAxBranch. - -Note [CoAxBranch roles] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code: - - newtype Age = MkAge Int - newtype Wrap a = MkWrap a - - convert :: Wrap Age -> Int - convert (MkWrap (MkAge i)) = i - -We want this to compile to: - - NTCo:Wrap :: forall a. Wrap a ~R a - NTCo:Age :: Age ~R Int - convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) - -But, note that NTCo:Age is at role R. Thus, we need to be able to pass -coercions at role R into axioms. However, we don't *always* want to be able to -do this, as it would be disastrous with type families. The solution is to -annotate the arguments to the axiom with roles, much like we annotate tycon -tyvars. Where do these roles get set? Newtype axioms inherit their roles from -the newtype tycon; family axioms are all at role N. - -Note [CoAxiom locations] -~~~~~~~~~~~~~~~~~~~~~~~~ -The source location of a CoAxiom is stored in two places in the -datatype tree. - * The first is in the location info buried in the Name of the - CoAxiom. This span includes all of the branches of a branched - CoAxiom. - * The second is in the cab_loc fields of the CoAxBranches. - -In the case of a single branch, we can extract the source location of -the branch from the name of the CoAxiom. In other cases, we need an -explicit SrcSpan to correctly store the location of the equation -giving rise to the FamInstBranch. - -Note [Implicit axioms] -~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Implicit TyThings] in HscTypes -* A CoAxiom arising from data/type family instances is not "implicit". - That is, it has its own IfaceAxiom declaration in an interface file - -* The CoAxiom arising from a newtype declaration *is* "implicit". - That is, it does not have its own IfaceAxiom declaration in an - interface file; instead the CoAxiom is generated by type-checking - the newtype declaration - -Note [Eta reduction for data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family T a b :: * - newtype instance T Int a = MkT (IO a) deriving( Monad ) -We'd like this to work. - -From the 'newtype instance' you might think we'd get: - newtype TInt a = MkT (IO a) - axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part - axiom ax2 a :: TInt a ~ IO a -- The newtype part - -But now what can we do? We have this problem - Given: d :: Monad IO - Wanted: d' :: Monad (T Int) = d |> ???? -What coercion can we use for the ??? - -Solution: eta-reduce both axioms, thus: - axiom ax1 :: T Int ~ TInt - axiom ax2 :: TInt ~ IO -Now - d' = d |> Monad (sym (ax2 ; ax1)) - ------ Bottom line ------ - -For a CoAxBranch for a data family instance with representation -TyCon rep_tc: - - - cab_tvs (of its CoAxiom) may be shorter - than tyConTyVars of rep_tc. - - - cab_lhs may be shorter than tyConArity of the family tycon - i.e. LHS is unsaturated - - - cab_rhs will be (rep_tc cab_tvs) - i.e. RHS is un-saturated - - - This eta reduction happens for data instances as well - as newtype instances. Here we want to eta-reduce the data family axiom. - - - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. - -But for a /type/ family - - cab_lhs has the exact arity of the family tycon - -There are certain situations (e.g., pretty-printing) where it is necessary to -deal with eta-expanded data family instances. For these situations, the -cab_eta_tvs field records the stuff that has been eta-reduced away. -So if we have - axiom forall a b. F [a->b] = D b a -and cab_eta_tvs is [p,q], then the original user-written definition -looked like - axiom forall a b p q. F [a->b] p q = D b a p q -(See #9692, #14179, and #15845 for examples of what can go wrong if -we don't eta-expand when showing things to the user.) - -(See also Note [Newtype eta] in TyCon. This is notionally separate -and deals with the axiom connecting a newtype with its representation -type; but it too is eta-reduced.) --} - -instance Eq (CoAxiom br) where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable (CoAxiom br) where - getUnique = co_ax_unique - -instance Outputable (CoAxiom br) where - ppr = ppr . getName - -instance NamedThing (CoAxiom br) where - getName = co_ax_name - -instance Typeable br => Data.Data (CoAxiom br) where - -- don't traverse? - toConstr _ = abstractConstr "CoAxiom" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoAxiom" - -instance Outputable CoAxBranch where - ppr (CoAxBranch { cab_loc = loc - , cab_lhs = lhs - , cab_rhs = rhs }) = - text "CoAxBranch" <+> parens (ppr loc) <> colon - <+> brackets (fsep (punctuate comma (map pprType lhs))) - <+> text "=>" <+> pprType rhs - -{- -************************************************************************ -* * - Roles -* * -************************************************************************ - -Roles are defined here to avoid circular dependencies. --} - --- See Note [Roles] in Coercion --- defined here to avoid cyclic dependency with Coercion --- --- Order of constructors matters: the Ord instance coincides with the *super*typing --- relation on roles. -data Role = Nominal | Representational | Phantom - deriving (Eq, Ord, Data.Data) - --- These names are slurped into the parser code. Changing these strings --- will change the **surface syntax** that GHC accepts! If you want to --- change only the pretty-printing, do some replumbing. See --- mkRoleAnnotDecl in RdrHsSyn -fsFromRole :: Role -> FastString -fsFromRole Nominal = fsLit "nominal" -fsFromRole Representational = fsLit "representational" -fsFromRole Phantom = fsLit "phantom" - -instance Outputable Role where - ppr = ftext . fsFromRole - -instance Binary Role where - put_ bh Nominal = putByte bh 1 - put_ bh Representational = putByte bh 2 - put_ bh Phantom = putByte bh 3 - - get bh = do tag <- getByte bh - case tag of 1 -> return Nominal - 2 -> return Representational - 3 -> return Phantom - _ -> panic ("get Role " ++ show tag) - -{- -************************************************************************ -* * - CoAxiomRule - Rules for building Evidence -* * -************************************************************************ - -Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: - - forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 - -My intention is to reuse these for both (~) and (~#). -The short-term plan is to use this datatype to represent the type-nat axioms. -In the longer run, it may be good to unify this and `CoAxiom`, -as `CoAxiom` is the special case when there are no assumptions. --} - --- | A more explicit representation for `t1 ~ t2`. -type TypeEqn = Pair Type - --- | For now, we work only with nominal equality. -data CoAxiomRule = CoAxiomRule - { coaxrName :: FastString - , coaxrAsmpRoles :: [Role] -- roles of parameter equations - , coaxrRole :: Role -- role of resulting equation - , coaxrProves :: [TypeEqn] -> Maybe TypeEqn - -- ^ coaxrProves returns @Nothing@ when it doesn't like - -- the supplied arguments. When this happens in a coercion - -- that means that the coercion is ill-formed, and Core Lint - -- checks for that. - } - -instance Data.Data CoAxiomRule where - -- don't traverse? - toConstr _ = abstractConstr "CoAxiomRule" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoAxiomRule" - -instance Uniquable CoAxiomRule where - getUnique = getUnique . coaxrName - -instance Eq CoAxiomRule where - x == y = coaxrName x == coaxrName y - -instance Ord CoAxiomRule where - compare x y = compare (coaxrName x) (coaxrName y) - -instance Outputable CoAxiomRule where - ppr = ppr . coaxrName - - --- Type checking of built-in families -data BuiltInSynFamily = BuiltInSynFamily - { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) - , sfInteractTop :: [Type] -> Type -> [TypeEqn] - , sfInteractInert :: [Type] -> Type -> - [Type] -> Type -> [TypeEqn] - } - --- Provides default implementations that do nothing. -trivialBuiltInFamily :: BuiltInSynFamily -trivialBuiltInFamily = BuiltInSynFamily - { sfMatchFam = \_ -> Nothing - , sfInteractTop = \_ _ -> [] - , sfInteractInert = \_ _ _ _ -> [] - } diff --git a/types/Coercion.hs b/types/Coercion.hs deleted file mode 100644 --- a/types/Coercion.hs +++ /dev/null @@ -1,2869 +0,0 @@ -{- -(c) The University of Glasgow 2006 --} - -{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns, - ScopedTypeVariables #-} - --- | Module for (a) type kinds and (b) type coercions, --- as used in System FC. See 'CoreSyn.Expr' for --- more on System FC and how coercions fit into it. --- -module Coercion ( - -- * Main data type - Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, - UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, - LeftOrRight(..), - Var, CoVar, TyCoVar, - Role(..), ltRole, - - -- ** Functions over coercions - coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, - coercionType, coercionKind, coercionKinds, - mkCoercionType, - coercionRole, coercionKindRole, - - -- ** Constructing coercions - mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, - mkCoVarCo, mkCoVarCos, - mkAxInstCo, mkUnbranchedAxInstCo, - mkAxInstRHS, mkUnbranchedAxInstRHS, - mkAxInstLHS, mkUnbranchedAxInstLHS, - mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkTransMCo, - mkNthCo, nthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, - mkForAllCo, mkForAllCos, mkHomoForAllCos, - mkPhantomCo, - mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, - mkAxiomInstCo, mkProofIrrelCo, - downgradeRole, mkAxiomRuleCo, - mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, - mkKindCo, castCoercionKind, castCoercionKindI, - - mkHeteroCoercionType, - mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, - mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, - - -- ** Decomposition - instNewTyCon_maybe, - - NormaliseStepper, NormaliseStepResult(..), composeSteppers, - mapStepResult, unwrapNewTypeStepper, - topNormaliseNewType_maybe, topNormaliseTypeX, - - decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, - splitTyConAppCo_maybe, - splitAppCo_maybe, - splitFunCo_maybe, - splitForAllCo_maybe, - splitForAllCo_ty_maybe, splitForAllCo_co_maybe, - - nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, - - pickLR, - - isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, - isReflCoVar_maybe, isGReflMCo, coToMCo, - - -- ** Coercion variables - mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, - isCoVar_maybe, - - -- ** Free variables - tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, - tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, - coercionSize, - - -- ** Substitution - CvSubstEnv, emptyCvSubstEnv, - lookupCoVar, - substCo, substCos, substCoVar, substCoVars, substCoWith, - substCoVarBndr, - extendTvSubstAndInScope, getCvSubstEnv, - - -- ** Lifting - liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, - emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, - liftCoSubstVarBndrUsing, isMappedByLC, - - mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, - - LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, - substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, - - -- ** Comparison - eqCoercion, eqCoercionX, - - -- ** Forcing evaluation of coercions - seqCo, - - -- * Pretty-printing - pprCo, pprParendCo, - pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, - pprCoAxBranchUser, tidyCoAxBndrsForUser, - etaExpandCoAxBranch, - - -- * Tidying - tidyCo, tidyCos, - - -- * Other - promoteCoercion, buildCoercion, - - simplifyArgsWorker - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} ToIface (toIfaceTyCon, tidyToIfaceTcArgs) - -import GhcPrelude - -import IfaceType -import TyCoRep -import TyCoFVs -import TyCoPpr -import TyCoSubst -import TyCoTidy -import Type -import TyCon -import CoAxiom -import Var -import VarEnv -import VarSet -import Name hiding ( varName ) -import Util -import BasicTypes -import Outputable -import Unique -import Pair -import SrcLoc -import PrelNames -import TysPrim -import ListSetOps -import Maybes -import UniqFM - -import Control.Monad (foldM, zipWithM) -import Data.Function ( on ) -import Data.Char( isDigit ) - -{- -%************************************************************************ -%* * - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. See - -- See [Coercion axioms applied to coercions] in TyCoRep - -\subsection{Coercion variables} -%* * -%************************************************************************ --} - -coVarName :: CoVar -> Name -coVarName = varName - -setCoVarUnique :: CoVar -> Unique -> CoVar -setCoVarUnique = setVarUnique - -setCoVarName :: CoVar -> Name -> CoVar -setCoVarName = setVarName - -{- -%************************************************************************ -%* * - Pretty-printing CoAxioms -%* * -%************************************************************************ - -Defined here to avoid module loops. CoAxiom is loaded very early on. - --} - -etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) --- Return the (tvs,lhs,rhs) after eta-expanding, --- to the way in which the axiom was originally written --- See Note [Eta reduction for data families] in CoAxiom -etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs - , cab_eta_tvs = eta_tvs - , cab_lhs = lhs - , cab_rhs = rhs }) - -- ToDo: what about eta_cvs? - = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) - where - eta_tys = mkTyVarTys eta_tvs - -pprCoAxiom :: CoAxiom br -> SDoc --- Used in debug-printing only -pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = hang (text "axiom" <+> ppr ax <+> dcolon) - 2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) - -pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc --- Used when printing injectivity errors (FamInst.reportInjectivityErrors) --- and inaccessible branches (TcValidity.inaccessibleCoAxBranch) --- This happens in error messages: don't print the RHS of a data --- family axiom, which is meaningless to a user -pprCoAxBranchUser tc br - | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br - | otherwise = pprCoAxBranch tc br - -pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc --- Print the family-instance equation when reporting --- a conflict between equations (FamInst.conflictInstErr) --- For type families the RHS is important; for data families not so. --- Indeed for data families the RHS is a mysterious internal --- type constructor, so we suppress it (#14179) --- See FamInstEnv Note [Family instance overlap conflicts] -pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs - where - pp_rhs _ _ = empty - -pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc -pprCoAxBranch = ppr_co_ax_branch ppr_rhs - where - ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs - -ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) - -> TyCon -> CoAxBranch -> SDoc -ppr_co_ax_branch ppr_rhs fam_tc branch - = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') - -- See Note [Printing foralls in type family instances] in IfaceType - , pp_lhs <+> ppr_rhs tidy_env ee_rhs - , text "-- Defined" <+> pp_loc ] - where - loc = coAxBranchSpan branch - pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) - | otherwise = text "in" <+> ppr loc - - -- Eta-expand LHS and RHS types, because sometimes data family - -- instances are eta-reduced. - -- See Note [Eta reduction for data families] in FamInstEnv. - (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch - - pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) - (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) - - (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs - -tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) --- Tidy wildcards "_1", "_2" to "_", and do not return them --- in the list of binders to be printed --- This is so that in error messages we see --- forall a. F _ [a] _ = ... --- rather than --- forall a _1 _2. F _1 [a] _2 = ... --- --- This is a rather disgusting function -tidyCoAxBndrsForUser init_env tcvs - = (tidy_env, reverse tidy_bndrs) - where - (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs - - tidy_one (env@(occ_env, subst), rev_bndrs') bndr - | is_wildcard bndr = (env_wild, rev_bndrs') - | otherwise = (env', bndr' : rev_bndrs') - where - (env', bndr') = tidyVarBndr env bndr - env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) - wild_bndr = setVarName bndr $ - tidyNameOcc (varName bndr) (mkTyVarOcc "_") - -- Tidy the binder to "_" - - is_wildcard :: Var -> Bool - is_wildcard tv = case occNameString (getOccName tv) of - ('_' : rest) -> all isDigit rest - _ -> False - -{- -%************************************************************************ -%* * - Destructing coercions -%* * -%************************************************************************ - -Note [Function coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Remember that - (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep - -Hence - FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) -is short for - TyConAppCo (->) co_rep1 co_rep2 co1 co2 -where co_rep1, co_rep2 are the coercions on the representations. --} - - --- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into --- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: --- --- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] -decomposeCo :: Arity -> Coercion - -> [Role] -- the roles of the output coercions - -- this must have at least as many - -- entries as the Arity provided - -> [Coercion] -decomposeCo arity co rs - = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] - -- Remember, Nth is zero-indexed - -decomposeFunCo :: HasDebugCallStack - => Role -- Role of the input coercion - -> Coercion -- Input coercion - -> (Coercion, Coercion) --- Expects co :: (s1 -> t1) ~ (s2 -> t2) --- Returns (co1 :: s1~s2, co2 :: t1~t2) --- See Note [Function coercions] for the "2" and "3" -decomposeFunCo r co = ASSERT2( all_ok, ppr co ) - (mkNthCo r 2 co, mkNthCo r 3 co) - where - Pair s1t1 s2t2 = coercionKind co - all_ok = isFunTy s1t1 && isFunTy s2t2 - -{- Note [Pushing a coercion into a pi-type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have this: - (f |> co) t1 .. tn -Then we want to push the coercion into the arguments, so as to make -progress. For example of why you might want to do so, see Note -[Respecting definitional equality] in TyCoRep. - -This is done by decomposePiCos. Specifically, if - decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) -then - (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn - -Notes: - -* k can be smaller than n! That is decomposePiCos can return *fewer* - coercions than there are arguments (ie k < n), if the kind provided - doesn't have enough binders. - -* If there is a type error, we might see - (f |> co) t1 - where co :: (forall a. ty) ~ (ty1 -> ty2) - Here 'co' is insoluble, but we don't want to crash in decoposePiCos. - So decomposePiCos carefully tests both sides of the coercion to check - they are both foralls or both arrows. Not doing this caused #15343. --} - -decomposePiCos :: HasDebugCallStack - => CoercionN -> Pair Type -- Coercion and its kind - -> [Type] - -> ([CoercionN], CoercionN) --- See Note [Pushing a coercion into a pi-type] -decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args - = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args - where - orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co - - go :: [CoercionN] -- accumulator for argument coercions, reversed - -> (TCvSubst,Kind) -- Lhs kind of coercion - -> CoercionN -- coercion originally applied to the function - -> (TCvSubst,Kind) -- Rhs kind of coercion - -> [Type] -- Arguments to that function - -> ([CoercionN], Coercion) - -- Invariant: co :: subst1(k2) ~ subst2(k2) - - go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) - | Just (a, t1) <- splitForAllTy_maybe k1 - , Just (b, t2) <- splitForAllTy_maybe k2 - -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) - -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) - -- a :: s1 - -- b :: s2 - -- ty :: s2 - -- need arg_co :: s2 ~ s1 - -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] - = let arg_co = mkNthCo Nominal 0 (mkSymCo co) - res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) - subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) - subst2' = extendTCvSubst subst2 b ty - in - go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys - - | Just (_s1, t1) <- splitFunTy_maybe k1 - , Just (_s2, t2) <- splitFunTy_maybe k2 - -- know co :: (s1 -> t1) ~ (s2 -> t2) - -- function :: s1 -> t1 - -- ty :: s2 - -- need arg_co :: s2 ~ s1 - -- res_co :: t1 ~ t2 - = let (sym_arg_co, res_co) = decomposeFunCo Nominal co - arg_co = mkSymCo sym_arg_co - in - go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys - - | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) - = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) - co - (zapTCvSubst subst2, substTy subst1 k2) - (ty:tys) - - -- tys might not be empty, if the left-hand type of the original coercion - -- didn't have enough binders - go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) - --- | Attempts to obtain the type variable underlying a 'Coercion' -getCoVar_maybe :: Coercion -> Maybe CoVar -getCoVar_maybe (CoVarCo cv) = Just cv -getCoVar_maybe _ = Nothing - --- | Attempts to tease a coercion apart into a type constructor and the application --- of a number of coercion arguments to that constructor -splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) -splitTyConAppCo_maybe co - | Just (ty, r) <- isReflCo_maybe co - = do { (tc, tys) <- splitTyConApp_maybe ty - ; let args = zipWith mkReflCo (tyConRolesX r tc) tys - ; return (tc, args) } -splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) -splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) - where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] -splitTyConAppCo_maybe _ = Nothing - --- first result has role equal to input; third result is Nominal -splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) --- ^ Attempt to take a coercion application apart. -splitAppCo_maybe (AppCo co arg) = Just (co, arg) -splitAppCo_maybe (TyConAppCo r tc args) - | args `lengthExceeds` tyConArity tc - , Just (args', arg') <- snocView args - = Just ( mkTyConAppCo r tc args', arg' ) - - | not (mustBeSaturated tc) - -- Never create unsaturated type family apps! - , Just (args', arg') <- snocView args - , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' - = Just ( mkTyConAppCo r tc args', arg'' ) - -- Use mkTyConAppCo to preserve the invariant - -- that identity coercions are always represented by Refl - -splitAppCo_maybe co - | Just (ty, r) <- isReflCo_maybe co - , Just (ty1, ty2) <- splitAppTy_maybe ty - = Just (mkReflCo r ty1, mkNomReflCo ty2) -splitAppCo_maybe _ = Nothing - -splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) -splitFunCo_maybe _ = Nothing - -splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) -splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) -splitForAllCo_maybe _ = Nothing - --- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder -splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) -splitForAllCo_ty_maybe (ForAllCo tv k_co co) - | isTyVar tv = Just (tv, k_co, co) -splitForAllCo_ty_maybe _ = Nothing - --- | Like 'splitForAllCo_maybe', but only returns Just for covar binder -splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) -splitForAllCo_co_maybe (ForAllCo cv k_co co) - | isCoVar cv = Just (cv, k_co, co) -splitForAllCo_co_maybe _ = Nothing - -------------------------------------------------------- --- and some coercion kind stuff - -coVarTypes :: HasDebugCallStack => CoVar -> Pair Type -coVarTypes cv - | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv - = Pair ty1 ty2 - -coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) -coVarKindsTypesRole cv - | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) - = let role - | tc `hasKey` eqPrimTyConKey = Nominal - | tc `hasKey` eqReprPrimTyConKey = Representational - | otherwise = panic "coVarKindsTypesRole" - in (k1,k2,ty1,ty2,role) - | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable" - (ppr cv $$ ppr (varType cv)) - -coVarKind :: CoVar -> Type -coVarKind cv - = ASSERT( isCoVar cv ) - varType cv - -coVarRole :: CoVar -> Role -coVarRole cv - | tc `hasKey` eqPrimTyConKey - = Nominal - | tc `hasKey` eqReprPrimTyConKey - = Representational - | otherwise - = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv)) - - where - tc = case tyConAppTyCon_maybe (varType cv) of - Just tc0 -> tc0 - Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv) - --- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, --- produce a coercion @rep_co :: r1 ~ r2@. -mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion -mkRuntimeRepCo co - = mkNthCo Nominal 0 kind_co - where - kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 - -- (up to silliness with Constraint) - -isReflCoVar_maybe :: Var -> Maybe Coercion --- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) --- Works on all kinds of Vars, not just CoVars -isReflCoVar_maybe cv - | isCoVar cv - , Pair ty1 ty2 <- coVarTypes cv - , ty1 `eqType` ty2 - = Just (mkReflCo (coVarRole cv) ty1) - | otherwise - = Nothing - --- | Tests if this coercion is obviously a generalized reflexive coercion. --- Guaranteed to work very quickly. -isGReflCo :: Coercion -> Bool -isGReflCo (GRefl{}) = True -isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl -isGReflCo _ = False - --- | Tests if this MCoercion is obviously generalized reflexive --- Guaranteed to work very quickly. -isGReflMCo :: MCoercion -> Bool -isGReflMCo MRefl = True -isGReflMCo (MCo co) | isGReflCo co = True -isGReflMCo _ = False - --- | Tests if this coercion is obviously reflexive. Guaranteed to work --- very quickly. Sometimes a coercion can be reflexive, but not obviously --- so. c.f. 'isReflexiveCo' -isReflCo :: Coercion -> Bool -isReflCo (Refl{}) = True -isReflCo (GRefl _ _ mco) | isGReflMCo mco = True -isReflCo _ = False - --- | Returns the type coerced if this coercion is a generalized reflexive --- coercion. Guaranteed to work very quickly. -isGReflCo_maybe :: Coercion -> Maybe (Type, Role) -isGReflCo_maybe (GRefl r ty _) = Just (ty, r) -isGReflCo_maybe (Refl ty) = Just (ty, Nominal) -isGReflCo_maybe _ = Nothing - --- | Returns the type coerced if this coercion is reflexive. Guaranteed --- to work very quickly. Sometimes a coercion can be reflexive, but not --- obviously so. c.f. 'isReflexiveCo_maybe' -isReflCo_maybe :: Coercion -> Maybe (Type, Role) -isReflCo_maybe (Refl ty) = Just (ty, Nominal) -isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) -isReflCo_maybe _ = Nothing - --- | Slowly checks if the coercion is reflexive. Don't call this in a loop, --- as it walks over the entire coercion. -isReflexiveCo :: Coercion -> Bool -isReflexiveCo = isJust . isReflexiveCo_maybe - --- | Extracts the coerced type from a reflexive coercion. This potentially --- walks over the entire coercion, so avoid doing this in a loop. -isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) -isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) -isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) -isReflexiveCo_maybe co - | ty1 `eqType` ty2 - = Just (ty1, r) - | otherwise - = Nothing - where (Pair ty1 ty2, r) = coercionKindRole co - -coToMCo :: Coercion -> MCoercion -coToMCo c = if isReflCo c - then MRefl - else MCo c - -{- -%************************************************************************ -%* * - Building coercions -%* * -%************************************************************************ - -These "smart constructors" maintain the invariants listed in the definition -of Coercion, and they perform very basic optimizations. - -Note [Role twiddling functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a plethora of functions for twiddling roles: - -mkSubCo: Requires a nominal input coercion and always produces a -representational output. This is used when you (the programmer) are sure you -know exactly that role you have and what you want. - -downgradeRole_maybe: This function takes both the input role and the output role -as parameters. (The *output* role comes first!) It can only *downgrade* a -role -- that is, change it from N to R or P, or from R to P. This one-way -behavior is why there is the "_maybe". If an upgrade is requested, this -function produces Nothing. This is used when you need to change the role of a -coercion, but you're not sure (as you're writing the code) of which roles are -involved. - -This function could have been written using coercionRole to ascertain the role -of the input. But, that function is recursive, and the caller of downgradeRole_maybe -often knows the input role. So, this is more efficient. - -downgradeRole: This is just like downgradeRole_maybe, but it panics if the -conversion isn't a downgrade. - -setNominalRole_maybe: This is the only function that can *upgrade* a coercion. -The result (if it exists) is always Nominal. The input can be at any role. It -works on a "best effort" basis, as it should never be strictly necessary to -upgrade a coercion during compilation. It is currently only used within GHC in -splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second -coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable -that splitAppCo_maybe is operating over a TyConAppCo that uses a -representational coercion. Hence the need for setNominalRole_maybe. -splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, -it is not absolutely critical that setNominalRole_maybe be complete. - -Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom -UnivCos are perfectly type-safe, whereas representational and nominal ones are -not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. -(Nominal ones are no worse than representational ones, so this function *will* -change a UnivCo Representational to a UnivCo Nominal.) - -Conal Elliott also came across a need for this function while working with the -GHC API, as he was decomposing Core casts. The Core casts use representational -coercions, as they must, but his use case required nominal coercions (he was -building a GADT). So, that's why this function is exported from this module. - -One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as -appropriate? I (Richard E.) have decided not to do this, because upgrading a -role is bizarre and a caller should have to ask for this behavior explicitly. - --} - --- | Make a generalized reflexive coercion -mkGReflCo :: Role -> Type -> MCoercionN -> Coercion -mkGReflCo r ty mco - | isGReflMCo mco = if r == Nominal then Refl ty - else GRefl r ty MRefl - | otherwise = GRefl r ty mco - --- | Make a reflexive coercion -mkReflCo :: Role -> Type -> Coercion -mkReflCo Nominal ty = Refl ty -mkReflCo r ty = GRefl r ty MRefl - --- | Make a representational reflexive coercion -mkRepReflCo :: Type -> Coercion -mkRepReflCo ty = GRefl Representational ty MRefl - --- | Make a nominal reflexive coercion -mkNomReflCo :: Type -> Coercion -mkNomReflCo = Refl - --- | Apply a type constructor to a list of coercions. It is the --- caller's responsibility to get the roles correct on argument coercions. -mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion -mkTyConAppCo r tc cos - | tc `hasKey` funTyConKey - , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] - = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) - -- rep1 :: ra ~ rc rep2 :: rb ~ rd - -- co1 :: a ~ c co2 :: b ~ d - mkFunCo r co1 co2 - - -- Expand type synonyms - | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos - = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - - | Just tys_roles <- traverse isReflCo_maybe cos - = mkReflCo r (mkTyConApp tc (map fst tys_roles)) - -- See Note [Refl invariant] - - | otherwise = TyConAppCo r tc cos - --- | Build a function 'Coercion' from two other 'Coercion's. That is, --- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. -mkFunCo :: Role -> Coercion -> Coercion -> Coercion -mkFunCo r co1 co2 - -- See Note [Refl invariant] - | Just (ty1, _) <- isReflCo_maybe co1 - , Just (ty2, _) <- isReflCo_maybe co2 - = mkReflCo r (mkVisFunTy ty1 ty2) - | otherwise = FunCo r co1 co2 - --- | Apply a 'Coercion' to another 'Coercion'. --- The second coercion must be Nominal, unless the first is Phantom. --- If the first is Phantom, then the second can be either Phantom or Nominal. -mkAppCo :: Coercion -- ^ :: t1 ~r t2 - -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 - -> Coercion -- ^ :: t1 s1 ~r t2 s2 -mkAppCo co arg - | Just (ty1, r) <- isReflCo_maybe co - , Just (ty2, _) <- isReflCo_maybe arg - = mkReflCo r (mkAppTy ty1 ty2) - - | Just (ty1, r) <- isReflCo_maybe co - , Just (tc, tys) <- splitTyConApp_maybe ty1 - -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) - = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) - where - zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] - zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... - -mkAppCo (TyConAppCo r tc args) arg - = case r of - Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) - Representational -> mkTyConAppCo Representational tc (args ++ [arg']) - where new_role = (tyConRolesRepresentational tc) !! (length args) - arg' = downgradeRole new_role Nominal arg - Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) -mkAppCo co arg = AppCo co arg --- Note, mkAppCo is careful to maintain invariants regarding --- where Refl constructors appear; see the comments in the definition --- of Coercion and the Note [Refl invariant] in TyCoRep. - --- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCo'. -mkAppCos :: Coercion - -> [Coercion] - -> Coercion -mkAppCos co1 cos = foldl' mkAppCo co1 cos - -{- Note [Unused coercion variable in ForAllCo] - -See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for -checking coercion variable in types. -To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: - -(1) In mkForAllCo, we check whether cv is a coercion variable - and whether it is not used in body_co. If so we construct a FunCo. -(2) We don't do this check in mkForAllCo. - In coercionKind, we use mkTyCoForAllTy to perform the check and construct - a FunTy when necessary. - -We chose (2) for two reasons: - -* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not - make a difference. -* even if cv occurs in body_co, it is possible that cv does not occur in the kind - of body_co. Therefore the check in coercionKind is inevitable. - -The last wrinkle is that there are restrictions around the use of the cv in the -coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that -we cannot prove that the type system is consistent with unrestricted use of this -cv; the consistency proof uses an untyped rewrite relation that works over types -with all coercions and casts removed. So, we can allow the cv to appear only in -positions that are erased. As an approximation of this (and keeping close to the -published theory), we currently allow the cv only within the type in a Refl node -and under a GRefl node (including in the Coercion stored in a GRefl). It's -possible other places are OK, too, but this is a safe approximation. - -Sadly, with heterogeneous equality, this restriction might be able to be violated; -Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst -function might create an invalid coercion. Because a violation of the -restriction might lead to a program that "goes wrong", it is checked all the time, -even in a production compiler and without -dcore-list. We *have* proved that the -problem does not occur with homogeneous equality, so this check can be dropped -once ~# is made to be homogeneous. --} - - --- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. --- The kind of the tycovar should be the left-hand kind of the kind coercion. --- See Note [Unused coercion variable in ForAllCo] -mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion -mkForAllCo v kind_co co - | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True - , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True - , Just (ty, r) <- isReflCo_maybe co - , isGReflCo kind_co - = mkReflCo r (mkTyCoInvForAllTy v ty) - | otherwise - = ForAllCo v kind_co co - --- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious --- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. --- The kind of the tycovar should be the left-hand kind of the kind coercion. -mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion -mkForAllCo_NoRefl v kind_co co - | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True - , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True - , ASSERT( not (isReflCo co)) True - , isCoVar v - , not (v `elemVarSet` tyCoVarsOfCo co) - = FunCo (coercionRole co) kind_co co - | otherwise - = ForAllCo v kind_co co - --- | Make nested ForAllCos -mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion -mkForAllCos bndrs co - | Just (ty, r ) <- isReflCo_maybe co - = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in - foldl' (flip $ uncurry mkForAllCo_NoRefl) - (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) - non_refls_rev'd - | otherwise - = foldr (uncurry mkForAllCo_NoRefl) co bndrs - --- | Make a Coercion quantified over a type/coercion variable; --- the variable has the same type in both sides of the coercion -mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion -mkHomoForAllCos vs co - | Just (ty, r) <- isReflCo_maybe co - = mkReflCo r (mkTyCoInvForAllTys vs ty) - | otherwise - = mkHomoForAllCos_NoRefl vs co - --- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious --- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. -mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion -mkHomoForAllCos_NoRefl vs orig_co - = ASSERT( not (isReflCo orig_co)) - foldr go orig_co vs - where - go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co - -mkCoVarCo :: CoVar -> Coercion --- cv :: s ~# t --- See Note [mkCoVarCo] -mkCoVarCo cv = CoVarCo cv - -mkCoVarCos :: [CoVar] -> [Coercion] -mkCoVarCos = map mkCoVarCo - -{- Note [mkCoVarCo] -~~~~~~~~~~~~~~~~~~~ -In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is -valid (although see Note [Unbound RULE binders] in Rules), but -it's a relatively expensive test and perhaps better done in -optCoercion. Not a big deal either way. --} - --- | Extract a covar, if possible. This check is dirty. Be ashamed --- of yourself. (It's dirty because it cares about the structure of --- a coercion, which is morally reprehensible.) -isCoVar_maybe :: Coercion -> Maybe CoVar -isCoVar_maybe (CoVarCo cv) = Just cv -isCoVar_maybe _ = Nothing - -mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] - -> Coercion --- mkAxInstCo can legitimately be called over-staturated; --- i.e. with more type arguments than the coercion requires -mkAxInstCo role ax index tys cos - | arity == n_tys = downgradeRole role ax_role $ - mkAxiomInstCo ax_br index (rtys `chkAppend` cos) - | otherwise = ASSERT( arity < n_tys ) - downgradeRole role ax_role $ - mkAppCos (mkAxiomInstCo ax_br index - (ax_args `chkAppend` cos)) - leftover_args - where - n_tys = length tys - ax_br = toBranchedAxiom ax - branch = coAxiomNthBranch ax_br index - tvs = coAxBranchTyVars branch - arity = length tvs - arg_roles = coAxBranchRoles branch - rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys - (ax_args, leftover_args) - = splitAt arity rtys - ax_role = coAxiomRole ax - --- worker function -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkAxiomInstCo ax index args - = ASSERT( args `lengthIs` coAxiomArity ax index ) - AxiomInstCo ax index args - --- to be used only with unbranched axioms -mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched - -> [Type] -> [Coercion] -> Coercion -mkUnbranchedAxInstCo role ax tys cos - = mkAxInstCo role ax 0 tys cos - -mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type --- Instantiate the axiom with specified types, --- returning the instantiated RHS --- A companion to mkAxInstCo: --- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) -mkAxInstRHS ax index tys cos - = ASSERT( tvs `equalLength` tys1 ) - mkAppTys rhs' tys2 - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - rhs' = substTyWith tvs tys1 $ - substTyWithCoVars cvs cos $ - coAxBranchRHS branch - -mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 - --- | Return the left-hand type of the axiom, when the axiom is instantiated --- at the types given. -mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type -mkAxInstLHS ax index tys cos - = ASSERT( tvs `equalLength` tys1 ) - mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - lhs_tys = substTysWith tvs tys1 $ - substTysWithCoVars cvs cos $ - coAxBranchLHS branch - fam_tc = coAxiomTyCon ax - --- | Instantiate the left-hand side of an unbranched axiom -mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 - --- | Manufacture an unsafe coercion from thin air. --- Currently (May 14) this is used only to implement the --- @unsafeCoerce#@ primitive. Optimise by pushing --- down through type constructors. -mkUnsafeCo :: Role -> Type -> Type -> Coercion -mkUnsafeCo role ty1 ty2 - = mkUnivCo UnsafeCoerceProv role ty1 ty2 - --- | Make a coercion from a coercion hole -mkHoleCo :: CoercionHole -> Coercion -mkHoleCo h = HoleCo h - --- | Make a universal coercion between two arbitrary types. -mkUnivCo :: UnivCoProvenance - -> Role -- ^ role of the built coercion, "r" - -> Type -- ^ t1 :: k1 - -> Type -- ^ t2 :: k2 - -> Coercion -- ^ :: t1 ~r t2 -mkUnivCo prov role ty1 ty2 - | ty1 `eqType` ty2 = mkReflCo role ty1 - | otherwise = UnivCo prov role ty1 ty2 - --- | Create a symmetric version of the given 'Coercion' that asserts --- equality between the same types but in the other "direction", so --- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. -mkSymCo :: Coercion -> Coercion - --- Do a few simple optimizations, but don't bother pushing occurrences --- of symmetry to the leaves; the optimizer will take care of that. -mkSymCo co | isReflCo co = co -mkSymCo (SymCo co) = co -mkSymCo (SubCo (SymCo co)) = SubCo co -mkSymCo co = SymCo co - --- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. --- (co1 ; co2) -mkTransCo :: Coercion -> Coercion -> Coercion -mkTransCo co1 co2 | isReflCo co1 = co2 - | isReflCo co2 = co1 -mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) - = GRefl r t1 (MCo $ mkTransCo co1 co2) -mkTransCo co1 co2 = TransCo co1 co2 - --- | Compose two MCoercions via transitivity -mkTransMCo :: MCoercion -> MCoercion -> MCoercion -mkTransMCo MRefl co2 = co2 -mkTransMCo co1 MRefl = co1 -mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) - -mkNthCo :: HasDebugCallStack - => Role -- The role of the coercion you're creating - -> Int -- Zero-indexed - -> Coercion - -> Coercion -mkNthCo r n co - = ASSERT2( good_call, bad_call_msg ) - go r n co - where - Pair ty1 ty2 = coercionKind co - - go r 0 co - | Just (ty, _) <- isReflCo_maybe co - , Just (tv, _) <- splitForAllTy_maybe ty - = -- works for both tyvar and covar - ASSERT( r == Nominal ) - mkNomReflCo (varType tv) - - go r n co - | Just (ty, r0) <- isReflCo_maybe co - , let tc = tyConAppTyCon ty - = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) - ASSERT( nthRole r0 tc n == r ) - mkReflCo r (tyConAppArgN n ty) - where ok_tc_app :: Type -> Int -> Bool - ok_tc_app ty n - | Just (_, tys) <- splitTyConApp_maybe ty - = tys `lengthExceeds` n - | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall - = n == 0 - | otherwise - = False - - go r 0 (ForAllCo _ kind_co _) - = ASSERT( r == Nominal ) - kind_co - -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) - -- then (nth 0 co :: k1 ~N k2) - -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) - -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) - - go r n co@(FunCo r0 arg res) - -- See Note [Function coercions] - -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) - -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) - -- Then we want to behave as if co was - -- TyConAppCo argk_co resk_co arg_co res_co - -- where - -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) - -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) - -- i.e. mkRuntimeRepCo - = case n of - 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg - 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res - 2 -> ASSERT( r == r0 ) arg - 3 -> ASSERT( r == r0 ) res - _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) - - go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n - , (vcat [ ppr tc - , ppr arg_cos - , ppr r0 - , ppr n - , ppr r ]) ) - arg_cos `getNth` n - - go r n co = - NthCo r n co - - -- Assertion checking - bad_call_msg = vcat [ text "Coercion =" <+> ppr co - , text "LHS ty =" <+> ppr ty1 - , text "RHS ty =" <+> ppr ty2 - , text "n =" <+> ppr n, text "r =" <+> ppr r - , text "coercion role =" <+> ppr (coercionRole co) ] - good_call - -- If the Coercion passed in is between forall-types, then the Int must - -- be 0 and the role must be Nominal. - | Just (_tv1, _) <- splitForAllTy_maybe ty1 - , Just (_tv2, _) <- splitForAllTy_maybe ty2 - = n == 0 && r == Nominal - - -- If the Coercion passed in is between T tys and T tys', then the Int - -- must be less than the length of tys/tys' (which must be the same - -- lengths). - -- - -- If the role of the Coercion is nominal, then the role passed in must - -- be nominal. If the role of the Coercion is representational, then the - -- role passed in must be tyConRolesRepresentational T !! n. If the role - -- of the Coercion is Phantom, then the role passed in must be Phantom. - -- - -- See also Note [NthCo Cached Roles] if you're wondering why it's - -- blaringly obvious that we should be *computing* this role instead of - -- passing it in. - | Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - = let len1 = length tys1 - len2 = length tys2 - good_role = case coercionRole co of - Nominal -> r == Nominal - Representational -> r == (tyConRolesRepresentational tc1 !! n) - Phantom -> r == Phantom - in len1 == len2 && n < len1 && good_role - - | otherwise - = True - - - --- | If you're about to call @mkNthCo r n co@, then @r@ should be --- whatever @nthCoRole n co@ returns. -nthCoRole :: Int -> Coercion -> Role -nthCoRole n co - | Just (tc, _) <- splitTyConApp_maybe lty - = nthRole r tc n - - | Just _ <- splitForAllTy_maybe lty - = Nominal - - | otherwise - = pprPanic "nthCoRole" (ppr co) - - where - (Pair lty _, r) = coercionKindRole co - -mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkLRCo lr co - | Just (ty, eq) <- isReflCo_maybe co - = mkReflCo eq (pickLR lr (splitAppTy ty)) - | otherwise - = LRCo lr co - --- | Instantiates a 'Coercion'. -mkInstCo :: Coercion -> Coercion -> Coercion -mkInstCo (ForAllCo tcv _kind_co body_co) co - | Just (arg, _) <- isReflCo_maybe co - -- works for both tyvar and covar - = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co -mkInstCo co arg = InstCo co arg - --- | Given @ty :: k1@, @co :: k1 ~ k2@, --- produces @co' :: ty ~r (ty |> co)@ -mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion -mkGReflRightCo r ty co - | isGReflCo co = mkReflCo r ty - -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ - -- instead of @isReflCo@ - | otherwise = GRefl r ty (MCo co) - --- | Given @ty :: k1@, @co :: k1 ~ k2@, --- produces @co' :: (ty |> co) ~r ty@ -mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion -mkGReflLeftCo r ty co - | isGReflCo co = mkReflCo r ty - -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ - -- instead of @isReflCo@ - | otherwise = mkSymCo $ GRefl r ty (MCo co) - --- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, --- produces @co' :: (ty |> co) ~r ty' --- It is not only a utility function, but it saves allocation when co --- is a GRefl coercion. -mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion -mkCoherenceLeftCo r ty co co2 - | isGReflCo co = co2 - | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 - --- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, --- produces @co' :: ty' ~r (ty |> co) --- It is not only a utility function, but it saves allocation when co --- is a GRefl coercion. -mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion -mkCoherenceRightCo r ty co co2 - | isGReflCo co = co2 - | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) - --- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. -mkKindCo :: Coercion -> Coercion -mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) -mkKindCo (GRefl _ _ (MCo co)) = co -mkKindCo (UnivCo (PhantomProv h) _ _ _) = h -mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h -mkKindCo co - | Pair ty1 ty2 <- coercionKind co - -- generally, calling coercionKind during coercion creation is a bad idea, - -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, - -- so it's OK here. - , let tk1 = typeKind ty1 - tk2 = typeKind ty2 - , tk1 `eqType` tk2 - = Refl tk1 - | otherwise - = KindCo co - -mkSubCo :: Coercion -> Coercion --- Input coercion is Nominal, result is Representational --- see also Note [Role twiddling functions] -mkSubCo (Refl ty) = GRefl Representational ty MRefl -mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co -mkSubCo (TyConAppCo Nominal tc cos) - = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (FunCo Nominal arg res) - = FunCo Representational - (downgradeRole Representational Nominal arg) - (downgradeRole Representational Nominal res) -mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) - SubCo co - --- | Changes a role, but only a downgrade. See Note [Role twiddling functions] -downgradeRole_maybe :: Role -- ^ desired role - -> Role -- ^ current role - -> Coercion -> Maybe Coercion --- In (downgradeRole_maybe dr cr co) it's a precondition that --- cr = coercionRole co - -downgradeRole_maybe Nominal Nominal co = Just co -downgradeRole_maybe Nominal _ _ = Nothing - -downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) -downgradeRole_maybe Representational Representational co = Just co -downgradeRole_maybe Representational Phantom _ = Nothing - -downgradeRole_maybe Phantom Phantom co = Just co -downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) - --- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. --- See Note [Role twiddling functions] -downgradeRole :: Role -- desired role - -> Role -- current role - -> Coercion -> Coercion -downgradeRole r1 r2 co - = case downgradeRole_maybe r1 r2 co of - Just co' -> co' - Nothing -> pprPanic "downgradeRole" (ppr co) - -mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion -mkAxiomRuleCo = AxiomRuleCo - --- | Make a "coercion between coercions". -mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" - -> Coercion -- ^ :: phi1 ~N phi2 - -> Coercion -- ^ g1 :: phi1 - -> Coercion -- ^ g2 :: phi2 - -> Coercion -- ^ :: g1 ~r g2 - --- if the two coercion prove the same fact, I just don't care what --- the individual coercions are. -mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) - -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ -mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r - (mkCoercionTy g1) (mkCoercionTy g2) - -{- -%************************************************************************ -%* * - Roles -%* * -%************************************************************************ --} - --- | Converts a coercion to be nominal, if possible. --- See Note [Role twiddling functions] -setNominalRole_maybe :: Role -- of input coercion - -> Coercion -> Maybe Coercion -setNominalRole_maybe r co - | r == Nominal = Just co - | otherwise = setNominalRole_maybe_helper co - where - setNominalRole_maybe_helper (SubCo co) = Just co - setNominalRole_maybe_helper co@(Refl _) = Just co - setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co - setNominalRole_maybe_helper (TyConAppCo Representational tc cos) - = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos - ; return $ TyConAppCo Nominal tc cos' } - setNominalRole_maybe_helper (FunCo Representational co1 co2) - = do { co1' <- setNominalRole_maybe Representational co1 - ; co2' <- setNominalRole_maybe Representational co2 - ; return $ FunCo Nominal co1' co2' - } - setNominalRole_maybe_helper (SymCo co) - = SymCo <$> setNominalRole_maybe_helper co - setNominalRole_maybe_helper (TransCo co1 co2) - = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 - setNominalRole_maybe_helper (AppCo co1 co2) - = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 - setNominalRole_maybe_helper (ForAllCo tv kind_co co) - = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co - setNominalRole_maybe_helper (NthCo _r n co) - -- NB, this case recurses via setNominalRole_maybe, not - -- setNominalRole_maybe_helper! - = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co - setNominalRole_maybe_helper (InstCo co arg) - = InstCo <$> setNominalRole_maybe_helper co <*> pure arg - setNominalRole_maybe_helper (UnivCo prov _ co1 co2) - | case prov of UnsafeCoerceProv -> True -- it's always unsafe - PhantomProv _ -> False -- should always be phantom - ProofIrrelProv _ -> True -- it's always safe - PluginProv _ -> False -- who knows? This choice is conservative. - = Just $ UnivCo prov Nominal co1 co2 - setNominalRole_maybe_helper _ = Nothing - --- | Make a phantom coercion between two types. The coercion passed --- in must be a nominal coercion between the kinds of the --- types. -mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkPhantomCo h t1 t2 - = mkUnivCo (PhantomProv h) Phantom t1 t2 - --- takes any coercion and turns it into a Phantom coercion -toPhantomCo :: Coercion -> Coercion -toPhantomCo co - = mkPhantomCo (mkKindCo co) ty1 ty2 - where Pair ty1 ty2 = coercionKind co - --- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational -applyRoles :: TyCon -> [Coercion] -> [Coercion] -applyRoles tc cos - = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos - --- the Role parameter is the Role of the TyConAppCo --- defined here because this is intimately concerned with the implementation --- of TyConAppCo --- Always returns an infinite list (with a infinite tail of Nominal) -tyConRolesX :: Role -> TyCon -> [Role] -tyConRolesX Representational tc = tyConRolesRepresentational tc -tyConRolesX role _ = repeat role - --- Returns the roles of the parameters of a tycon, with an infinite tail --- of Nominal -tyConRolesRepresentational :: TyCon -> [Role] -tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal - -nthRole :: Role -> TyCon -> Int -> Role -nthRole Nominal _ _ = Nominal -nthRole Phantom _ _ = Phantom -nthRole Representational tc n - = (tyConRolesRepresentational tc) `getNth` n - -ltRole :: Role -> Role -> Bool --- Is one role "less" than another? --- Nominal < Representational < Phantom -ltRole Phantom _ = False -ltRole Representational Phantom = True -ltRole Representational _ = False -ltRole Nominal Nominal = False -ltRole Nominal _ = True - -------------------------------- - --- | like mkKindCo, but aggressively & recursively optimizes to avoid using --- a KindCo constructor. The output role is nominal. -promoteCoercion :: Coercion -> CoercionN - --- First cases handles anything that should yield refl. -promoteCoercion co = case co of - - _ | ki1 `eqType` ki2 - -> mkNomReflCo (typeKind ty1) - -- no later branch should return refl - -- The ASSERT( False )s throughout - -- are these cases explicitly, but they should never fire. - - Refl _ -> ASSERT( False ) - mkNomReflCo ki1 - - GRefl _ _ MRefl -> ASSERT( False ) - mkNomReflCo ki1 - - GRefl _ _ (MCo co) -> co - - TyConAppCo _ tc args - | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args - -> co' - | otherwise - -> mkKindCo co - - AppCo co1 arg - | Just co' <- instCoercion (coercionKind (mkKindCo co1)) - (promoteCoercion co1) arg - -> co' - | otherwise - -> mkKindCo co - - ForAllCo tv _ g - | isTyVar tv - -> promoteCoercion g - - ForAllCo _ _ _ - -> ASSERT( False ) - mkNomReflCo liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in Type - - FunCo _ _ _ - -> ASSERT( False ) - mkNomReflCo liftedTypeKind - - CoVarCo {} -> mkKindCo co - HoleCo {} -> mkKindCo co - AxiomInstCo {} -> mkKindCo co - AxiomRuleCo {} -> mkKindCo co - - UnivCo UnsafeCoerceProv _ t1 t2 -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2) - UnivCo (PhantomProv kco) _ _ _ -> kco - UnivCo (ProofIrrelProv kco) _ _ _ -> kco - UnivCo (PluginProv _) _ _ _ -> mkKindCo co - - SymCo g - -> mkSymCo (promoteCoercion g) - - TransCo co1 co2 - -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) - - NthCo _ n co1 - | Just (_, args) <- splitTyConAppCo_maybe co1 - , args `lengthExceeds` n - -> promoteCoercion (args !! n) - - | Just _ <- splitForAllCo_maybe co - , n == 0 - -> ASSERT( False ) mkNomReflCo liftedTypeKind - - | otherwise - -> mkKindCo co - - LRCo lr co1 - | Just (lco, rco) <- splitAppCo_maybe co1 - -> case lr of - CLeft -> promoteCoercion lco - CRight -> promoteCoercion rco - - | otherwise - -> mkKindCo co - - InstCo g _ - | isForAllTy_ty ty1 - -> ASSERT( isForAllTy_ty ty2 ) - promoteCoercion g - | otherwise - -> ASSERT( False) - mkNomReflCo liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in Type - - KindCo _ - -> ASSERT( False ) - mkNomReflCo liftedTypeKind - - SubCo g - -> promoteCoercion g - - where - Pair ty1 ty2 = coercionKind co - ki1 = typeKind ty1 - ki2 = typeKind ty2 - --- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, --- where @g' = promoteCoercion (h w)@. --- fails if this is not possible, if @g@ coerces between a forall and an -> --- or if second parameter has a representational role and can't be used --- with an InstCo. -instCoercion :: Pair Type -- g :: lty ~ rty - -> CoercionN -- ^ must be nominal - -> Coercion - -> Maybe CoercionN -instCoercion (Pair lty rty) g w - | (isForAllTy_ty lty && isForAllTy_ty rty) - || (isForAllTy_co lty && isForAllTy_co rty) - , Just w' <- setNominalRole_maybe (coercionRole w) w - -- g :: (forall t1. t2) ~ (forall t1. t3) - -- w :: s1 ~ s2 - -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] - = Just $ mkInstCo g w' - | isFunTy lty && isFunTy rty - -- g :: (t1 -> t2) ~ (t3 -> t4) - -- returns t2 ~ t4 - = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->) - | otherwise -- one forall, one funty... - = Nothing - --- | Repeated use of 'instCoercion' -instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN -instCoercions g ws - = let arg_ty_pairs = map coercionKind ws in - snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) - where - go :: (Pair Type, Coercion) -> (Pair Type, Coercion) - -> Maybe (Pair Type, Coercion) - go (g_tys, g) (w_tys, w) - = do { g' <- instCoercion g_tys g w - ; return (piResultTy <$> g_tys <*> w_tys, g') } - --- | Creates a new coercion with both of its types casted by different casts --- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, --- has type @(t1 |> h1) ~r (t2 |> h2)@. --- @h1@ and @h2@ must be nominal. -castCoercionKind :: Coercion -> Role -> Type -> Type - -> CoercionN -> CoercionN -> Coercion -castCoercionKind g r t1 t2 h1 h2 - = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) - --- | Creates a new coercion with both of its types casted by different casts --- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, --- has type @(t1 |> h1) ~r (t2 |> h2)@. --- @h1@ and @h2@ must be nominal. --- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) --- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand. -castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion -castCoercionKindI g h1 h2 - = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) - where (Pair t1 t2, r) = coercionKindRole g - --- See note [Newtype coercions] in TyCon - -mkPiCos :: Role -> [Var] -> Coercion -> Coercion -mkPiCos r vs co = foldr (mkPiCo r) co vs - --- | Make a forall 'Coercion', where both types related by the coercion --- are quantified over the same variable. -mkPiCo :: Role -> Var -> Coercion -> Coercion -mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co - | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) - -- We didn't call mkForAllCo here because if v does not appear - -- in co, the argement coercion will be nominal. But here we - -- want it to be r. It is only called in 'mkPiCos', which is - -- only used in SimplUtils, where we are sure for - -- now (Aug 2018) v won't occur in co. - mkFunCo r (mkReflCo r (varType v)) co - | otherwise = mkFunCo r (mkReflCo r (varType v)) co - --- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 --- The first coercion might be lifted or unlifted; thus the ~? above --- Lifted and unlifted equalities take different numbers of arguments, --- so we have to make sure to supply the right parameter to decomposeCo. --- Also, note that the role of the first coercion is the same as the role of --- the equalities related by the second coercion. The second coercion is --- itself always representational. -mkCoCast :: Coercion -> CoercionR -> Coercion -mkCoCast c g - | (g2:g1:_) <- reverse co_list - = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 - - | otherwise - = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) - where - -- g :: (s1 ~# t1) ~# (s2 ~# t2) - -- g1 :: s1 ~# s2 - -- g2 :: t1 ~# t2 - (tc, _) = splitTyConApp (pFst $ coercionKind g) - co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) - -{- -%************************************************************************ -%* * - Newtypes -%* * -%************************************************************************ --} - --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated -instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) -instNewTyCon_maybe tc tys - | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype - , tvs `leLength` tys -- Check saturated enough - = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Type normalisation -* * -************************************************************************ --} - --- | A function to check if we can reduce a type by one step. Used --- with 'topNormaliseTypeX'. -type NormaliseStepper ev = RecTcChecker - -> TyCon -- tc - -> [Type] -- tys - -> NormaliseStepResult ev - --- | The result of stepping in a normalisation function. --- See 'topNormaliseTypeX'. -data NormaliseStepResult ev - = NS_Done -- ^ Nothing more to do - | NS_Abort -- ^ Utter failure. The outer function should fail too. - | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; - -- ^ ev is evidence; - -- Usually a co :: old type ~ new type - -mapStepResult :: (ev1 -> ev2) - -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 -mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) -mapStepResult _ NS_Done = NS_Done -mapStepResult _ NS_Abort = NS_Abort - --- | Try one stepper and then try the next, if the first doesn't make --- progress. --- So if it returns NS_Done, it means that both steppers are satisfied -composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev - -> NormaliseStepper ev -composeSteppers step1 step2 rec_nts tc tys - = case step1 rec_nts tc tys of - success@(NS_Step {}) -> success - NS_Done -> step2 rec_nts tc tys - NS_Abort -> NS_Abort - --- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into --- a loop. If it would fall into a loop, it produces 'NS_Abort'. -unwrapNewTypeStepper :: NormaliseStepper Coercion -unwrapNewTypeStepper rec_nts tc tys - | Just (ty', co) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of - Just rec_nts' -> NS_Step rec_nts' ty' co - Nothing -> NS_Abort - - | otherwise - = NS_Done - --- | A general function for normalising the top-level of a type. It continues --- to use the provided 'NormaliseStepper' until that function fails, and then --- this function returns. The roles of the coercions produced by the --- 'NormaliseStepper' must all be the same, which is the role returned from --- the call to 'topNormaliseTypeX'. --- --- Typically ev is Coercion. --- --- If topNormaliseTypeX step plus ty = Just (ev, ty') --- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' --- and ev = ev1 `plus` ev2 `plus` ... `plus` evn --- If it returns Nothing then no newtype unwrapping could happen -topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) - -> Type -> Maybe (ev, Type) -topNormaliseTypeX stepper plus ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys - = go rec_nts ev ty' - | otherwise - = Nothing - where - go rec_nts ev ty - | Just (tc, tys) <- splitTyConApp_maybe ty - = case stepper rec_nts tc tys of - NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' - NS_Done -> Just (ev, ty) - NS_Abort -> Nothing - - | otherwise - = Just (ev, ty) - -topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) --- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. --- This function strips off @newtype@ layers enough to reveal something that isn't --- a @newtype@. Specifically, here's the invariant: --- --- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') --- --- then (a) @co : ty0 ~ ty'@. --- (b) ty' is not a newtype. --- --- The function returns @Nothing@ for non-@newtypes@, --- or unsaturated applications --- --- This function does *not* look through type families, because it has no access to --- the type family environment. If you do have that at hand, consider to use --- topNormaliseType_maybe, which should be a drop-in replacement for --- topNormaliseNewType_maybe --- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' -topNormaliseNewType_maybe ty - = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty - -{- -%************************************************************************ -%* * - Comparison of coercions -%* * -%************************************************************************ --} - --- | Syntactic equality of coercions -eqCoercion :: Coercion -> Coercion -> Bool -eqCoercion = eqType `on` coercionType - --- | Compare two 'Coercion's, with respect to an RnEnv2 -eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool -eqCoercionX env = eqTypeX env `on` coercionType - -{- -%************************************************************************ -%* * - "Lifting" substitution - [(TyCoVar,Coercion)] -> Type -> Coercion -%* * -%************************************************************************ - -Note [Lifting coercions over types: liftCoSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The KPUSH rule deals with this situation - data T a = K (a -> Maybe a) - g :: T t1 ~ T t2 - x :: t1 -> Maybe t1 - - case (K @t1 x) |> g of - K (y:t2 -> Maybe t2) -> rhs - -We want to push the coercion inside the constructor application. -So we do this - - g' :: t1~t2 = Nth 0 g - - case K @t2 (x |> g' -> Maybe g') of - K (y:t2 -> Maybe t2) -> rhs - -The crucial operation is that we - * take the type of K's argument: a -> Maybe a - * and substitute g' for a -thus giving *coercion*. This is what liftCoSubst does. - -In the presence of kind coercions, this is a bit -of a hairy operation. So, we refer you to the paper introducing kind coercions, -available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf - -Note [extendLiftingContextEx] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider we have datatype - K :: \/k. \/a::k. P -> T k -- P be some type - g :: T k1 ~ T k2 - - case (K @k1 @t1 x) |> g of - K y -> rhs - -We want to push the coercion inside the constructor application. -We first get the coercion mapped by the universal type variable k: - lc = k |-> Nth 0 g :: k1~k2 - -Here, the important point is that the kind of a is coerced, and P might be -dependent on the existential type variable a. -Thus we first get the coercion of a's kind - g2 = liftCoSubst lc k :: k1 ~ k2 - -Then we store a new mapping into the lifting context - lc2 = a |-> (t1 ~ t1 |> g2), lc - -So later when we can correctly deal with the argument type P - liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] - -This is exactly what extendLiftingContextEx does. -* For each (tyvar:k, ty) pair, we product the mapping - tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) -* For each (covar:s1~s2, ty) pair, we produce the mapping - covar |-> (co ~ co') - co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' - -This follows the lifting context extension definition in the -"FC with Explicit Kind Equality" paper. --} - --- ---------------------------------------------------- --- See Note [Lifting coercions over types: liftCoSubst] --- ---------------------------------------------------- - -data LiftingContext = LC TCvSubst LiftCoEnv - -- in optCoercion, we need to lift when optimizing InstCo. - -- See Note [Optimising InstCo] in OptCoercion - -- We thus propagate the substitution from OptCoercion here. - -instance Outputable LiftingContext where - ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) - -type LiftCoEnv = VarEnv Coercion - -- Maps *type variables* to *coercions*. - -- That's the whole point of this function! - -- Also maps coercion variables to ProofIrrelCos. - --- like liftCoSubstWith, but allows for existentially-bound types as well -liftCoSubstWithEx :: Role -- desired role for output coercion - -> [TyVar] -- universally quantified tyvars - -> [Coercion] -- coercions to substitute for those - -> [TyCoVar] -- existentially quantified tycovars - -> [Type] -- types and coercions to be bound to ex vars - -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) -liftCoSubstWithEx role univs omegas exs rhos - = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) - psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) - in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) - -liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion -liftCoSubstWith r tvs cos ty - = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty - --- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) --- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where --- @lc_left@ is a substitution mapping type variables to the left-hand --- types of the mapped coercions in @lc@, and similar for @lc_right@. -liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion -liftCoSubst r lc@(LC subst env) ty - | isEmptyVarEnv env = mkReflCo r (substTy subst ty) - | otherwise = ty_co_subst lc r ty - -emptyLiftingContext :: InScopeSet -> LiftingContext -emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv - -mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext -mkLiftingContext pairs - = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) - (mkVarEnv pairs) - -mkSubstLiftingContext :: TCvSubst -> LiftingContext -mkSubstLiftingContext subst = LC subst emptyVarEnv - --- | Extend a lifting context with a new mapping. -extendLiftingContext :: LiftingContext -- ^ original LC - -> TyCoVar -- ^ new variable to map... - -> Coercion -- ^ ...to this lifted version - -> LiftingContext - -- mappings to reflexive coercions are just substitutions -extendLiftingContext (LC subst env) tv arg - | Just (ty, _) <- isReflCo_maybe arg - = LC (extendTCvSubst subst tv ty) env - | otherwise - = LC subst (extendVarEnv env tv arg) - --- | Extend a lifting context with a new mapping, and extend the in-scope set -extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC - -> TyCoVar -- ^ new variable to map... - -> Coercion -- ^ to this coercion - -> LiftingContext -extendLiftingContextAndInScope (LC subst env) tv co - = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co - --- | Extend a lifting context with existential-variable bindings. --- See Note [extendLiftingContextEx] -extendLiftingContextEx :: LiftingContext -- ^ original lifting context - -> [(TyCoVar,Type)] -- ^ ex. var / value pairs - -> LiftingContext --- Note that this is more involved than extendLiftingContext. That function --- takes a coercion to extend with, so it's assumed that the caller has taken --- into account any of the kind-changing stuff worried about here. -extendLiftingContextEx lc [] = lc -extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) --- This function adds bindings for *Nominal* coercions. Why? Because it --- works with existentially bound variables, which are considered to have --- nominal roles. - | isTyVar v - = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) - (extendVarEnv env v $ - mkGReflRightCo Nominal - ty - (ty_co_subst lc Nominal (tyVarKind v))) - in extendLiftingContextEx lc' rest - | CoercionTy co <- ty - = -- co :: s1 ~r s2 - -- lift_s1 :: s1 ~r s1' - -- lift_s2 :: s2 ~r s2' - -- kco :: (s1 ~r s2) ~N (s1' ~r s2') - ASSERT( isCoVar v ) - let (_, _, s1, s2, r) = coVarKindsTypesRole v - lift_s1 = ty_co_subst lc r s1 - lift_s2 = ty_co_subst lc r s2 - kco = mkTyConAppCo Nominal (equalityTyCon r) - [ mkKindCo lift_s1, mkKindCo lift_s2 - , lift_s1 , lift_s2 ] - lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) - (extendVarEnv env v - (mkProofIrrelCo Nominal kco co $ - (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) - in extendLiftingContextEx lc' rest - | otherwise - = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) - - --- | Erase the environments in a lifting context -zapLiftingContext :: LiftingContext -> LiftingContext -zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv - --- | Like 'substForAllCoBndr', but works on a lifting context -substForAllCoBndrUsingLC :: Bool - -> (Coercion -> Coercion) - -> LiftingContext -> TyCoVar -> Coercion - -> (LiftingContext, TyCoVar, Coercion) -substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co - = (LC subst' lc_env, tv', co') - where - (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co - --- | The \"lifting\" operation which substitutes coercions for type --- variables in a type to produce a coercion. --- --- For the inverse operation, see 'liftCoMatch' -ty_co_subst :: LiftingContext -> Role -> Type -> Coercion -ty_co_subst lc role ty - = go role ty - where - go :: Role -> Type -> Coercion - go r ty | Just ty' <- coreView ty - = go r ty' - go Phantom ty = lift_phantom ty - go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ - liftCoSubstTyVar lc r tv - go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) - go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) - go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) - go r t@(ForAllTy (Bndr v _) ty) - = let (lc', v', h) = liftCoSubstVarBndr lc v - body_co = ty_co_subst lc' r ty in - if isTyVar v' || almostDevoidCoVarOfCo v' body_co - -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo - -- imposes an extra restriction on where a covar can appear. See last - -- wrinkle in Note [Unused coercion variable in ForAllCo]. - -- We specifically check for this and panic because we know that - -- there's a hole in the type system here, and we'd rather panic than - -- fall into it. - then mkForAllCo v' h body_co - else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) - go r ty@(LitTy {}) = ASSERT( r == Nominal ) - mkNomReflCo ty - go r (CastTy ty co) = castCoercionKindI (go r ty) (substLeftCo lc co) - (substRightCo lc co) - go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) - (substRightCo lc co) - where kco = go Nominal (coercionType co) - - lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) - (substTy (lcSubstLeft lc) ty) - (substTy (lcSubstRight lc) ty) - -{- -Note [liftCoSubstTyVar] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This function can fail if a coercion in the environment is of too low a role. - -liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and -also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting -lemma guarantees that the roles work out. If we fail in this -case, we really should panic -- something is deeply wrong. But, in matchAxiom, -failing is fine. matchAxiom is trying to find a set of coercions -that match, but it may fail, and this is healthy behavior. --} - --- See Note [liftCoSubstTyVar] -liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion -liftCoSubstTyVar (LC subst env) r v - | Just co_arg <- lookupVarEnv env v - = downgradeRole_maybe r (coercionRole co_arg) co_arg - - | otherwise - = Just $ mkReflCo r (substTyVar subst v) - -{- Note [liftCoSubstVarBndr] - -callback: - We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in - FamInstEnv, therefore the input arg 'fun' returns a pair with polymophic type - in snd. - However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and - ignore the fourth component of the return value. - -liftCoSubstTyVarBndrUsing: - Given - forall tv:k. t - We want to get - forall (tv:k1) (kind_co :: k1 ~ k2) body_co - - We lift the kind k to get the kind_co - kind_co = ty_co_subst k :: k1 ~ k2 - - Now in the LiftingContext, we add the new mapping - tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) - -liftCoSubstCoVarBndrUsing: - Given - forall cv:(s1 ~ s2). t - We want to get - forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co - - We lift s1 and s2 respectively to get - eta1 :: s1' ~ t1 - eta2 :: s2' ~ t2 - And - kind_co = TyConAppCo Nominal (~#) eta1 eta2 - - Now in the liftingContext, we add the new mapping - cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) --} - --- See Note [liftCoSubstVarBndr] -liftCoSubstVarBndr :: LiftingContext -> TyCoVar - -> (LiftingContext, TyCoVar, Coercion) -liftCoSubstVarBndr lc tv - = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in - (lc', tv', h) - where - callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) - --- the callback must produce a nominal coercion -liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) - -> LiftingContext -> TyCoVar - -> (LiftingContext, TyCoVar, CoercionN, a) -liftCoSubstVarBndrUsing fun lc old_var - | isTyVar old_var - = liftCoSubstTyVarBndrUsing fun lc old_var - | otherwise - = liftCoSubstCoVarBndrUsing fun lc old_var - --- Works for tyvar binder -liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) - -> LiftingContext -> TyVar - -> (LiftingContext, TyVar, CoercionN, a) -liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var - = ASSERT( isTyVar old_var ) - ( LC (subst `extendTCvInScope` new_var) new_cenv - , new_var, eta, stuff ) - where - old_kind = tyVarKind old_var - (eta, stuff) = fun lc old_kind - Pair k1 _ = coercionKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - - lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta - -- :: new_var ~ new_var |> eta - new_cenv = extendVarEnv cenv old_var lifted - --- Works for covar binder -liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) - -> LiftingContext -> CoVar - -> (LiftingContext, CoVar, CoercionN, a) -liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var - = ASSERT( isCoVar old_var ) - ( LC (subst `extendTCvInScope` new_var) new_cenv - , new_var, kind_co, stuff ) - where - old_kind = coVarKind old_var - (eta, stuff) = fun lc old_kind - Pair k1 _ = coercionKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - - -- old_var :: s1 ~r s2 - -- eta :: (s1' ~r s2') ~N (t1 ~r t2) - -- eta1 :: s1' ~r t1 - -- eta2 :: s2' ~r t2 - -- co1 :: s1' ~r s2' - -- co2 :: t1 ~r t2 - -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) - -- lifted :: co1 ~N co2 - - role = coVarRole old_var - eta' = downgradeRole role Nominal eta - eta1 = mkNthCo role 2 eta' - eta2 = mkNthCo role 3 eta' - - co1 = mkCoVarCo new_var - co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 - kind_co = mkTyConAppCo Nominal (equalityTyCon role) - [ mkKindCo co1, mkKindCo co2 - , co1 , co2 ] - lifted = mkProofIrrelCo Nominal kind_co co1 co2 - - new_cenv = extendVarEnv cenv old_var lifted - --- | Is a var in the domain of a lifting context? -isMappedByLC :: TyCoVar -> LiftingContext -> Bool -isMappedByLC tv (LC _ env) = tv `elemVarEnv` env - --- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 --- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 -substLeftCo :: LiftingContext -> Coercion -> Coercion -substLeftCo lc co - = substCo (lcSubstLeft lc) co - --- Ditto, but for t2 and g2 -substRightCo :: LiftingContext -> Coercion -> Coercion -substRightCo lc co - = substCo (lcSubstRight lc) co - --- | Apply "sym" to all coercions in a 'LiftCoEnv' -swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv -swapLiftCoEnv = mapVarEnv mkSymCo - -lcSubstLeft :: LiftingContext -> TCvSubst -lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env - -lcSubstRight :: LiftingContext -> TCvSubst -lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env - -liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubstLeft = liftEnvSubst pFst - -liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubstRight = liftEnvSubst pSnd - -liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst -liftEnvSubst selector subst lc_env - = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst - where - pairs = nonDetUFMToList lc_env - -- It's OK to use nonDetUFMToList here because we - -- immediately forget the ordering by creating - -- a VarEnv - (tpairs, cpairs) = partitionWith ty_or_co pairs - tenv = mkVarEnv_Directly tpairs - cenv = mkVarEnv_Directly cpairs - - ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) - ty_or_co (u, co) - | Just equality_co <- isCoercionTy_maybe equality_ty - = Right (u, equality_co) - | otherwise - = Left (u, equality_ty) - where - equality_ty = selector (coercionKind co) - --- | Extract the underlying substitution from the LiftingContext -lcTCvSubst :: LiftingContext -> TCvSubst -lcTCvSubst (LC subst _) = subst - --- | Get the 'InScopeSet' from a 'LiftingContext' -lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getTCvInScope subst - -{- -%************************************************************************ -%* * - Sequencing on coercions -%* * -%************************************************************************ --} - -seqMCo :: MCoercion -> () -seqMCo MRefl = () -seqMCo (MCo co) = seqCo co - -seqCo :: Coercion -> () -seqCo (Refl ty) = seqType ty -seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco -seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos -seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k - `seq` seqCo co -seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 -seqCo (CoVarCo cv) = cv `seq` () -seqCo (HoleCo h) = coHoleCoVar h `seq` () -seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnivCo p r t1 t2) - = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 -seqCo (SymCo co) = seqCo co -seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (NthCo r n co) = r `seq` n `seq` seqCo co -seqCo (LRCo lr co) = lr `seq` seqCo co -seqCo (InstCo co arg) = seqCo co `seq` seqCo arg -seqCo (KindCo co) = seqCo co -seqCo (SubCo co) = seqCo co -seqCo (AxiomRuleCo _ cs) = seqCos cs - -seqProv :: UnivCoProvenance -> () -seqProv UnsafeCoerceProv = () -seqProv (PhantomProv co) = seqCo co -seqProv (ProofIrrelProv co) = seqCo co -seqProv (PluginProv _) = () - -seqCos :: [Coercion] -> () -seqCos [] = () -seqCos (co:cos) = seqCo co `seq` seqCos cos - -{- -%************************************************************************ -%* * - The kind of a type, and of a coercion -%* * -%************************************************************************ --} - -coercionType :: Coercion -> Type -coercionType co = case coercionKindRole co of - (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 - ------------------- --- | If it is the case that --- --- > c :: (t1 ~ t2) --- --- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. - -coercionKind :: Coercion -> Pair Type -coercionKind co = - go co - where - go (Refl ty) = Pair ty ty - go (GRefl _ ty MRefl) = Pair ty ty - go (GRefl _ ty (MCo co1)) = Pair ty (mkCastTy ty co1) - go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) - go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 - go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar - | isGReflCo k_co = mkTyCoInvForAllTy tv1 <$> go co1 - -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = go_forall empty_subst co - where - empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) - go (FunCo _ co1 co2) = mkVisFunTy <$> go co1 <*> go co2 - go (CoVarCo cv) = coVarTypes cv - go (HoleCo h) = coVarTypes (coHoleCoVar h) - go (AxiomInstCo ax ind cos) - | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind - , let Pair tycos1 tycos2 = sequenceA (map go cos) - (tys1, cotys1) = splitAtList tvs tycos1 - (tys2, cotys2) = splitAtList tvs tycos2 - cos1 = map stripCoercionTy cotys1 - cos2 = map stripCoercionTy cotys2 - = ASSERT( cos `equalLength` (tvs ++ cvs) ) - -- Invariant of AxiomInstCo: cos should - -- exactly saturate the axiom branch - Pair (substTyWith tvs tys1 $ - substTyWithCoVars cvs cos1 $ - mkTyConApp (coAxiomTyCon ax) lhs) - (substTyWith tvs tys2 $ - substTyWithCoVars cvs cos2 rhs) - go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 - go (SymCo co) = swap $ go co - go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) - go g@(NthCo _ d co) - | Just argss <- traverse tyConAppArgs_maybe tys - = ASSERT( and $ (`lengthExceeds` d) <$> argss ) - (`getNth` d) <$> argss - - | d == 0 - , Just splits <- traverse splitForAllTy_maybe tys - = (tyVarKind . fst) <$> splits - - | otherwise - = pprPanic "coercionKind" (ppr g) - where - tys = go co - go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co - go (InstCo aco arg) = go_app aco [arg] - go (KindCo co) = typeKind <$> go co - go (SubCo co) = go co - go (AxiomRuleCo ax cos) = expectJust "coercionKind" $ - coaxrProves ax (map go cos) - - go_app :: Coercion -> [Coercion] -> Pair Type - -- Collect up all the arguments and apply all at once - -- See Note [Nested InstCos] - go_app (InstCo co arg) args = go_app co (arg:args) - go_app co args = piResultTys <$> go co <*> (sequenceA $ map go args) - - go_forall subst (ForAllCo tv1 k_co co) - -- See Note [Nested ForAllCos] - | isTyVar tv1 - = mkInvForAllTy <$> Pair tv1 tv2 <*> go_forall subst' co - where - Pair _ k2 = go k_co - tv2 = setTyVarKind tv1 (substTy subst k2) - subst' | isGReflCo k_co = extendTCvInScope subst tv1 - -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ - TyVarTy tv2 `mkCastTy` mkSymCo k_co - go_forall subst (ForAllCo cv1 k_co co) - | isCoVar cv1 - = mkTyCoInvForAllTy <$> Pair cv1 cv2 <*> go_forall subst' co - where - Pair _ k2 = go k_co - r = coVarRole cv1 - eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) - eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) - - -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) - -- k1 = t1 ~r t2 - -- k2 = s1 ~r s2 - -- cv1 :: t1 ~r t2 - -- cv2 :: s1 ~r s2 - -- eta1 :: t1 ~r s1 - -- eta2 :: t2 ~r s2 - -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 - - cv2 = setVarType cv1 (substTy subst k2) - n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) - subst' | isReflCo k_co = extendTCvInScope subst cv1 - | otherwise = extendCvSubst (extendTCvInScope subst cv2) - cv1 n_subst - - go_forall subst other_co - -- when other_co is not a ForAllCo - = substTy subst `pLiftSnd` go other_co - -{- - -Note [Nested ForAllCos] -~~~~~~~~~~~~~~~~~~~~~~~ - -Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an -co)...) )`. We do not want to perform `n` single-type-variable -substitutions over the kind of `co`; rather we want to do one substitution -which substitutes for all of `a1`, `a2` ... simultaneously. If we do one -at a time we get the performance hole reported in #11735. - -Solution: gather up the type variables for nested `ForAllCos`, and -substitute for them all at once. Remarkably, for #11735 this single -change reduces /total/ compile time by a factor of more than ten. - --} - --- | Apply 'coercionKind' to multiple 'Coercion's -coercionKinds :: [Coercion] -> Pair [Type] -coercionKinds tys = sequenceA $ map coercionKind tys - --- | Get a coercion's kind and role. -coercionKindRole :: Coercion -> (Pair Type, Role) -coercionKindRole co = (coercionKind co, coercionRole co) - --- | Retrieve the role from a coercion. -coercionRole :: Coercion -> Role -coercionRole = go - where - go (Refl _) = Nominal - go (GRefl r _ _) = r - go (TyConAppCo r _ _) = r - go (AppCo co1 _) = go co1 - go (ForAllCo _ _ co) = go co - go (FunCo r _ _) = r - go (CoVarCo cv) = coVarRole cv - go (HoleCo h) = coVarRole (coHoleCoVar h) - go (AxiomInstCo ax _ _) = coAxiomRole ax - go (UnivCo _ r _ _) = r - go (SymCo co) = go co - go (TransCo co1 _co2) = go co1 - go (NthCo r _d _co) = r - go (LRCo {}) = Nominal - go (InstCo co _) = go co - go (KindCo {}) = Nominal - go (SubCo _) = Representational - go (AxiomRuleCo ax _) = coaxrRole ax - -{- -Note [Nested InstCos] -~~~~~~~~~~~~~~~~~~~~~ -In #5631 we found that 70% of the entire compilation time was -being spent in coercionKind! The reason was that we had - (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos -where - g :: forall a1 a2 .. a100. phi -If we deal with the InstCos one at a time, we'll do this: - 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' - 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst -But this is a *quadratic* algorithm, and the blew up #5631. -So it's very important to do the substitution simultaneously; -cf Type.piResultTys (which in fact we call here). - --} - --- | Makes a coercion type from two types: the types whose equality --- is proven by the relevant 'Coercion' -mkCoercionType :: Role -> Type -> Type -> Type -mkCoercionType Nominal = mkPrimEqPred -mkCoercionType Representational = mkReprPrimEqPred -mkCoercionType Phantom = \ty1 ty2 -> - let ki1 = typeKind ty1 - ki2 = typeKind ty2 - in - TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] - -mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type -mkHeteroCoercionType Nominal = mkHeteroPrimEqPred -mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred -mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" - --- | Creates a primitive type equality predicate. --- Invariant: the types are not Coercions -mkPrimEqPred :: Type -> Type -> Type -mkPrimEqPred ty1 ty2 - = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - --- | Makes a lifted equality predicate at the given role -mkPrimEqPredRole :: Role -> Type -> Type -> PredType -mkPrimEqPredRole Nominal = mkPrimEqPred -mkPrimEqPredRole Representational = mkReprPrimEqPred -mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" - --- | Creates a primite type equality predicate with explicit kinds -mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] - --- | Creates a primitive representational type equality predicate --- with explicit kinds -mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroReprPrimEqPred k1 k2 ty1 ty2 - = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - -mkReprPrimEqPred :: Type -> Type -> Type -mkReprPrimEqPred ty1 ty2 - = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - --- | Assuming that two types are the same, ignoring coercions, find --- a nominal coercion between the types. This is useful when optimizing --- transitivity over coercion applications, where splitting two --- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion. -buildCoercion :: Type -> Type -> CoercionN -buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 - | Just ty2' <- coreView ty2 = go ty1 ty2' - - go (CastTy ty1 co) ty2 - = let co' = go ty1 ty2 - r = coercionRole co' - in mkCoherenceLeftCo r ty1 co co' - - go ty1 (CastTy ty2 co) - = let co' = go ty1 ty2 - r = coercionRole co' - in mkCoherenceRightCo r ty2 co co' - - go ty1@(TyVarTy tv1) _tyvarty - = ASSERT( case _tyvarty of - { TyVarTy tv2 -> tv1 == tv2 - ; _ -> False } ) - mkNomReflCo ty1 - - go (FunTy { ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_arg = arg2, ft_res = res2 }) - = mkFunCo Nominal (go arg1 arg2) (go res1 res2) - - go (TyConApp tc1 args1) (TyConApp tc2 args2) - = ASSERT( tc1 == tc2 ) - mkTyConAppCo Nominal tc1 (zipWith go args1 args2) - - go (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 - = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - - go ty1 (AppTy ty2a ty2b) - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 - = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - - go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) - | isTyVar tv1 - = ASSERT( isTyVar tv2 ) - mkForAllCo tv1 kind_co (go ty1 ty2') - where kind_co = go (tyVarKind tv1) (tyVarKind tv2) - in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co - ty2' = substTyWithInScope in_scope [tv2] - [mkTyVarTy tv1 `mkCastTy` kind_co] - ty2 - - go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) - = ASSERT( isCoVar cv1 && isCoVar cv2 ) - mkForAllCo cv1 kind_co (go ty1 ty2') - where s1 = varType cv1 - s2 = varType cv2 - kind_co = go s1 s2 - - -- s1 = t1 ~r t2 - -- s2 = t3 ~r t4 - -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) - -- eta1 :: t1 ~r t3 - -- eta2 :: t2 ~r t4 - - r = coVarRole cv1 - kind_co' = downgradeRole r Nominal kind_co - eta1 = mkNthCo r 2 kind_co' - eta2 = mkNthCo r 3 kind_co' - - subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co - ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` - mkCoVarCo cv1 `mkTransCo` - eta2) - ty2 - - go ty1@(LitTy lit1) _lit2 - = ASSERT( case _lit2 of - { LitTy lit2 -> lit1 == lit2 - ; _ -> False } ) - mkNomReflCo ty1 - - go (CoercionTy co1) (CoercionTy co2) - = mkProofIrrelCo Nominal kind_co co1 co2 - where - kind_co = go (coercionType co1) (coercionType co2) - - go ty1 ty2 - = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 - , ppr ty1, ppr ty2 ]) - -{- -%************************************************************************ -%* * - Simplifying types -%* * -%************************************************************************ - -The function below morally belongs in TcFlatten, but it is used also in -FamInstEnv, and so lives here. - -Note [simplifyArgsWorker] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariant (F2) of Note [Flattening] says that flattening is homogeneous. -This causes some trouble when flattening a function applied to a telescope -of arguments, perhaps with dependency. For example, suppose - - type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] - -and we wish to flatten the args of (with kind applications explicit) - - F a b (Just a c) (Right a b d) False - -where all variables are skolems and - - a :: Type - b :: Type - c :: a - d :: k - - [G] aco :: a ~ fa - [G] bco :: b ~ fb - [G] cco :: c ~ fc - [G] dco :: d ~ fd - -The first step is to flatten all the arguments. This is done before calling -simplifyArgsWorker. We start from - - a - b - Just a c - Right a b d - False - -and get - - (fa, co1 :: fa ~ a) - (fb, co2 :: fb ~ b) - (Just fa (fc |> aco) |> co6, co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c)) - (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d)) - (False, co5 :: False ~ False) - -where - co6 :: Maybe fa ~ Maybe a - co7 :: Either fa fb ~ Either a b - -We now process the flattened args in left-to-right order. The first two args -need no further processing. But now consider the third argument. Let f3 = the flattened -result, Just fa (fc |> aco) |> co6. -This f3 flattened argument has kind (Maybe a), due to -(F2). And yet, when we build the application (F fa fb ...), we need this -argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. -The coercion to use is -determined by the kind of F: we see in F's kind that the third argument has -kind Maybe j. Critically, we also know that the argument corresponding to j -(in our example, a) flattened with a coercion co1. We can thus know the -coercion needed for the 3rd argument is (Maybe (sym co1)), thus building -(f3 |> Maybe (sym co1)) - -More generally, we must use the Lifting Lemma, as implemented in -Coercion.liftCoSubst. As we work left-to-right, any variable that is a -dependent parameter (j and k, in our example) gets mapped in a lifting context -to the coercion that is output from flattening the corresponding argument (co1 -and co2, in our example). Then, after flattening later arguments, we lift the -kind of these arguments in the lifting context that we've be building up. -This coercion is then used to keep the result of flattening well-kinded. - -Working through our example, this is what happens: - - 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, - because the binder associated with the first argument has a closed type (no - variables). - - 2. Extend the LC with [k |-> co2]. No casting to do. - - 3. Lifting the kind (Maybe j) with our LC - yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to - F. - - 4. Lifting the kind (Either j k) with our LC - yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th - argument to F, where f4 is the flattened form of argument 4, written above. - - 5. We lift Bool with our LC, getting ; - casting has no effect. - -We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False) -has the wrong kind. Its kind is [fb], instead of the original [b]. -So we must use our LC one last time to lift the result kind [k], -getting res_co :: [fb] ~ [b], and we cast our result. - -Accordingly, the final result is - - F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) - (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) - False - |> [sym bco] - -The res_co (in this case, [sym bco]) -is returned as the third return value from simplifyArgsWorker. - -Note [Last case in simplifyArgsWorker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, -because that case is first. We've run out of -binders. But perhaps inner_ki is a tyvar that has been instantiated with a -Π-type. - -Here is an example. - - a :: forall (k :: Type). k -> k - type family Star - Proxy :: forall j. j -> Type - axStar :: Star ~ Type - type family NoWay :: Bool - axNoWay :: NoWay ~ False - bo :: Type - [G] bc :: bo ~ Bool (in inert set) - - co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) - co = forall (j :: sym axStar). ( -> sym axStar) - - We are flattening: - a (forall (j :: Star). (j |> axStar) -> Star) -- 1 - (Proxy |> co) -- 2 - (bo |> sym axStar) -- 3 - (NoWay |> sym bc) -- 4 - :: Star - -First, we flatten all the arguments (before simplifyArgsWorker), like so: - - (forall j. j -> Type, co1 :: (forall j. j -> Type) ~ - (forall (j :: Star). (j |> axStar) -> Star)) -- 1 - (Proxy |> co, co2 :: (Proxy |> co) ~ (Proxy |> co)) -- 2 - (Bool |> sym axStar, co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar)) -- 3 - (False |> sym bc, co4 :: (False |> sym bc) ~ (NoWay |> sym bc)) -- 4 - -Then we do the process described in Note [simplifyArgsWorker]. - -1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we - don't use it. But we do build a lifting context [k -> co1] (where co1 is a - result of flattening an argument, written above). - -2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1). - This is not a dependent argument, so we don't extend the lifting context. - -Now we need to deal with argument (3). -The way we normally proceed is to lift the kind of the binder, to see whether -it's dependent. -But here, the remainder of the kind of `a` that we're left with -after processing two arguments is just `k`. - -The way forward is look up k in the lifting context, getting co1. If we're at -all well-typed, co1 will be a coercion between Π-types, with at least one binder. -So, let's -decompose co1 with decomposePiCos. This decomposition needs arguments to use -to instantiate any kind parameters. Look at the type of co1. If we just -decomposed it, we would end up with coercions whose types include j, which is -out of scope here. Accordingly, decomposePiCos takes a list of types whose -kinds are the *right-hand* types in the decomposed coercion. (See comments on -decomposePiCos.) Because the flattened types have unflattened kinds (because -flattening is homogeneous), passing the list of flattened types to decomposePiCos -just won't do: later arguments' kinds won't be as expected. So we need to get -the *unflattened* types to pass to decomposePiCos. We can do this easily enough -by taking the kind of the argument coercions, passed in originally. - -(Alternative 1: We could re-engineer decomposePiCos to deal with this situation. -But that function is already gnarly, and taking the right-hand types is correct -at its other call sites, which are much more common than this one.) - -(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its -behavior into simplifyArgsWorker. This would work, I think, but then all of the -complication of decomposePiCos would end up layered on top of all the complication -here. Please, no.) - -(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker -so that we don't have to recreate them. But that would complicate the interface -of this function to handle a very dark, dark corner case. Better to keep our -demons to ourselves here instead of exposing them to callers. This decision is -easily reversed if there is ever any performance trouble due to the call of -coercionKind.) - -So we now call - - decomposePiCos co1 - (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star)) - [bo |> sym axStar, NoWay |> sym bc] - -to get - - co5 :: Star ~ Type - co6 :: (j |> axStar) ~ (j |> co5), substituted to - (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) - == bo ~ bo - res_co :: Type ~ Star - -We then use these casts on (the flattened) (3) and (4) to get - - (Bool |> sym axStar |> co5 :: Type) -- (C3) - (False |> sym bc |> co6 :: bo) -- (C4) - -We can simplify to - - Bool -- (C3) - (False |> sym bc :: bo) -- (C4) - -Of course, we still must do the processing in Note [simplifyArgsWorker] to finish -the job. We thus want to recur. Our new function kind is the left-hand type of -co1 (gotten, recall, by lifting the variable k that was the return kind of the -original function). Why the left-hand type (as opposed to the right-hand type)? -Because we have casted all the arguments according to decomposePiCos, which gets -us from the right-hand type to the left-hand one. We thus recur with that new -function kind, zapping our lifting context, because we have essentially applied -it. - -This recursive call returns ([Bool, False], [...], Refl). The Bool and False -are the correct arguments we wish to return. But we must be careful about the -result coercion: our new, flattened application will have kind Type, but we -want to make sure that the result coercion casts this back to Star. (Why? -Because we started with an application of kind Star, and flattening is homogeneous.) - -So, we have to twiddle the result coercion appropriately. - -Let's check whether this is well-typed. We know - - a :: forall (k :: Type). k -> k - - a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type - - a (forall j. j -> Type) - Proxy - :: forall j. j -> Type - - a (forall j. j -> Type) - Proxy - Bool - :: Bool -> Type - - a (forall j. j -> Type) - Proxy - Bool - False - :: Type - - a (forall j. j -> Type) - Proxy - Bool - False - |> res_co - :: Star - -as desired. - -Whew. - -Historical note: I (Richard E) once thought that the final part of the kind -had to be a variable k (as in the example above). But it might not be: it could -be an application of a variable. Here is the example: - - let f :: forall (a :: Type) (b :: a -> Type). b (Any @a) - k :: Type - x :: k - - flatten (f @Type @((->) k) x) - -After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` -is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded. - --} - - --- This is shared between the flattener and the normaliser in FamInstEnv. --- See Note [simplifyArgsWorker] -{-# INLINE simplifyArgsWorker #-} -simplifyArgsWorker :: [TyCoBinder] -> Kind - -- the binders & result kind (not a Π-type) of the function applied to the args - -- list of binders can be shorter or longer than the list of args - -> TyCoVarSet -- free vars of the args - -> [Role] -- list of roles, r - -> [(Type, Coercion)] -- flattened type arguments, arg - -- each comes with the coercion used to flatten it, - -- with co :: flattened_type ~ original_type - -> ([Type], [Coercion], CoercionN) --- Returns (xis, cos, res_co), where each co :: xi ~ arg, --- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args --- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), --- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded. --- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this --- function is all about. That is, (f xis), where xis are the returned arguments, *is* --- well kinded. -simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs - orig_roles orig_simplified_args - = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args - where - orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs - - go :: [Type] -- Xis accumulator, in reverse order - -> [Coercion] -- Coercions accumulator, in reverse order - -- These are in 1-to-1 correspondence - -> LiftingContext -- mapping from tyvars to flattening coercions - -> [TyCoBinder] -- Unsubsted binders of function's kind - -> Kind -- Unsubsted result kind of function (not a Pi-type) - -> [Role] -- Roles at which to flatten these ... - -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions - -> ([Type], [Coercion], CoercionN) - go acc_xis acc_cos lc binders inner_ki _ [] - = (reverse acc_xis, reverse acc_cos, kind_co) - where - final_kind = mkPiTys binders inner_ki - kind_co = liftCoSubst Nominal lc final_kind - - go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) - = -- By Note [Flattening] in TcFlatten invariant (F2), - -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be - -- used as an argument to a function whose kind is different, if - -- earlier arguments have been flattened to new types. We thus - -- need a coercion (kind_co :: old_kind ~ new_kind). - -- - -- The bangs here have been observed to improve performance - -- significantly in optimized builds. - let kind_co = mkSymCo $ - liftCoSubst Nominal lc (tyCoBinderType binder) - !casted_xi = xi `mkCastTy` kind_co - casted_co = mkCoherenceLeftCo role xi kind_co co - - -- now, extend the lifting context with the new binding - !new_lc | Just tv <- tyCoBinderVar_maybe binder - = extendLiftingContextAndInScope lc tv casted_co - | otherwise - = lc - in - go (casted_xi : acc_xis) - (casted_co : acc_cos) - new_lc - binders - inner_ki - roles - args - - - -- See Note [Last case in simplifyArgsWorker] - go acc_xis acc_cos lc [] inner_ki roles args - = let co1 = liftCoSubst Nominal lc inner_ki - co1_kind = coercionKind co1 - unflattened_tys = map (pSnd . coercionKind . snd) args - (arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys - casted_args = ASSERT2( equalLength args arg_cos - , ppr args $$ ppr arg_cos ) - [ (casted_xi, casted_co) - | ((xi, co), arg_co, role) <- zip3 args arg_cos roles - , let casted_xi = xi `mkCastTy` arg_co - casted_co = mkCoherenceLeftCo role xi arg_co co ] - -- In general decomposePiCos can return fewer cos than tys, - -- but not here; because we're well typed, there will be enough - -- binders. Note that decomposePiCos does substitutions, so even - -- if the original substitution results in something ending with - -- ... -> k, that k will be substituted to perhaps reveal more - -- binders. - zapped_lc = zapLiftingContext lc - Pair flattened_kind _ = co1_kind - (bndrs, new_inner) = splitPiTys flattened_kind - - (xis_out, cos_out, res_co_out) - = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args - in - (xis_out, cos_out, res_co_out `mkTransCo` res_co) - - go _ _ _ _ _ _ _ = panic - "simplifyArgsWorker wandered into deeper water than usual" - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872d. - -- That's independent of the analagous case in flatten_args_fast - -- in TcFlatten: - -- each of these causes a 2% increase on its own, so commenting them - -- both out gives a 4% decrease in T9872d. - {- - - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} diff --git a/types/Coercion.hs-boot b/types/Coercion.hs-boot deleted file mode 100644 --- a/types/Coercion.hs-boot +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Coercion where - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep -import {-# SOURCE #-} TyCon - -import BasicTypes ( LeftOrRight ) -import CoAxiom -import Var -import Pair -import Util - -mkReflCo :: Role -> Type -> Coercion -mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion -mkAppCo :: Coercion -> Coercion -> Coercion -mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion -mkFunCo :: Role -> Coercion -> Coercion -> Coercion -mkCoVarCo :: CoVar -> Coercion -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkUnsafeCo :: Role -> Type -> Type -> Coercion -mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion -mkSymCo :: Coercion -> Coercion -mkTransCo :: Coercion -> Coercion -> Coercion -mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion -mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkInstCo :: Coercion -> Coercion -> Coercion -mkGReflCo :: Role -> Type -> MCoercionN -> Coercion -mkNomReflCo :: Type -> Coercion -mkKindCo :: Coercion -> Coercion -mkSubCo :: Coercion -> Coercion -mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion -mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion - -isGReflCo :: Coercion -> Bool -isReflCo :: Coercion -> Bool -isReflexiveCo :: Coercion -> Bool -decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) -coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) -coVarRole :: CoVar -> Role - -mkCoercionType :: Role -> Type -> Type -> Type - -data LiftingContext -liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion -seqCo :: Coercion -> () - -coercionKind :: Coercion -> Pair Type -coercionType :: Coercion -> Type diff --git a/types/FamInstEnv.hs b/types/FamInstEnv.hs deleted file mode 100644 --- a/types/FamInstEnv.hs +++ /dev/null @@ -1,1832 +0,0 @@ --- (c) The University of Glasgow 2006 --- --- FamInstEnv: Type checked family instance declarations - -{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections, - DeriveFunctor #-} - -module FamInstEnv ( - FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, - famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInsts, - mkImportedFamInst, - - FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, extendFamInstEnvList, - famInstEnvElts, famInstEnvSize, familyInstances, - - -- * CoAxioms - mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, - mkNewTypeCoAxiom, - - FamInstMatch(..), - lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, - - isDominatedBy, apartnessCheck, - - -- Injectivity - InjectivityCheckResult(..), - lookupFamInstEnvInjectivityConflicts, injectiveBranches, - - -- Normalisation - topNormaliseType, topNormaliseType_maybe, - normaliseType, normaliseTcApp, normaliseTcArgs, - reduceTyFamApp_maybe, - - -- Flattening - flattenTys - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Unify -import Type -import TyCoRep -import TyCon -import Coercion -import CoAxiom -import VarSet -import VarEnv -import Name -import PrelNames ( eqPrimTyConKey ) -import UniqDFM -import Outputable -import Maybes -import CoreMap -import Unique -import Util -import Var -import Pair -import SrcLoc -import FastString -import Control.Monad -import Data.List( mapAccumL ) -import Data.Array( Array, assocs ) - -{- -************************************************************************ -* * - Type checked family instance heads -* * -************************************************************************ - -Note [FamInsts and CoAxioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* CoAxioms and FamInsts are just like - DFunIds and ClsInsts - -* A CoAxiom is a System-FC thing: it can relate any two types - -* A FamInst is a Haskell source-language thing, corresponding - to a type/data family instance declaration. - - The FamInst contains a CoAxiom, which is the evidence - for the instance - - - The LHS of the CoAxiom is always of form F ty1 .. tyn - where F is a type family --} - -data FamInst -- See Note [FamInsts and CoAxioms] - = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom - -- introduced by this family - -- instance - -- INVARIANT: apart from freshening (see below) - -- fi_tvs = cab_tvs of the (single) axiom branch - -- fi_cvs = cab_cvs ...ditto... - -- fi_tys = cab_lhs ...ditto... - -- fi_rhs = cab_rhs ...ditto... - - , fi_flavor :: FamFlavor - - -- Everything below here is a redundant, - -- cached version of the two things above - -- except that the TyVars are freshened - , fi_fam :: Name -- Family name - - -- Used for "rough matching"; same idea as for class instances - -- See Note [Rough-match field] in InstEnv - , fi_tcs :: [Maybe Name] -- Top of type args - -- INVARIANT: fi_tcs = roughMatchTcs fi_tys - - -- Used for "proper matching"; ditto - , fi_tvs :: [TyVar] -- Template tyvars for full match - , fi_cvs :: [CoVar] -- Template covars for full match - -- Like ClsInsts, these variables are always fresh - -- See Note [Template tyvars are fresh] in InstEnv - - , fi_tys :: [Type] -- The LHS type patterns - -- May be eta-reduced; see Note [Eta reduction for data families] - - , fi_rhs :: Type -- the RHS, with its freshened vars - } - -data FamFlavor - = SynFamilyInst -- A synonym family - | DataFamilyInst TyCon -- A data family, with its representation TyCon - -{- -Note [Arity of data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Data family instances might legitimately be over- or under-saturated. - -Under-saturation has two potential causes: - U1) Eta reduction. See Note [Eta reduction for data families]. - U2) When the user has specified a return kind instead of written out patterns. - Example: - - data family Sing (a :: k) - data instance Sing :: Bool -> Type - - The data family tycon Sing has an arity of 2, the k and the a. But - the data instance has only one pattern, Bool (standing in for k). - This instance is equivalent to `data instance Sing (a :: Bool)`, but - without the last pattern, we have an under-saturated data family instance. - On its own, this example is not compelling enough to add support for - under-saturation, but U1 makes this feature more compelling. - -Over-saturation is also possible: - O1) If the data family's return kind is a type variable (see also #12369), - an instance might legitimately have more arguments than the family. - Example: - - data family Fix :: (Type -> k) -> k - data instance Fix f = MkFix1 (f (Fix f)) - data instance Fix f x = MkFix2 (f (Fix f x) x) - - In the first instance here, the k in the data family kind is chosen to - be Type. In the second, it's (Type -> Type). - - However, we require that any over-saturation is eta-reducible. That is, - we require that any extra patterns be bare unrepeated type variables; - see Note [Eta reduction for data families]. Accordingly, the FamInst - is never over-saturated. - -Why can we allow such flexibility for data families but not for type families? -Because data families can be decomposed -- that is, they are generative and -injective. A Type family is neither and so always must be applied to all its -arguments. --} - --- Obtain the axiom of a family instance -famInstAxiom :: FamInst -> CoAxiom Unbranched -famInstAxiom = fi_axiom - --- Split the left-hand side of the FamInst -famInstSplitLHS :: FamInst -> (TyCon, [Type]) -famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) - = (coAxiomTyCon axiom, lhs) - --- Get the RHS of the FamInst -famInstRHS :: FamInst -> Type -famInstRHS = fi_rhs - --- Get the family TyCon of the FamInst -famInstTyCon :: FamInst -> TyCon -famInstTyCon = coAxiomTyCon . famInstAxiom - --- Return the representation TyCons introduced by data family instances, if any -famInstsRepTyCons :: [FamInst] -> [TyCon] -famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] - --- Extracts the TyCon for this *data* (or newtype) instance -famInstRepTyCon_maybe :: FamInst -> Maybe TyCon -famInstRepTyCon_maybe fi - = case fi_flavor fi of - DataFamilyInst tycon -> Just tycon - SynFamilyInst -> Nothing - -dataFamInstRepTyCon :: FamInst -> TyCon -dataFamInstRepTyCon fi - = case fi_flavor fi of - DataFamilyInst tycon -> tycon - SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) - -{- -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -instance NamedThing FamInst where - getName = coAxiomName . fi_axiom - -instance Outputable FamInst where - ppr = pprFamInst - -pprFamInst :: FamInst -> SDoc --- Prints the FamInst as a family instance declaration --- NB: This function, FamInstEnv.pprFamInst, is used only for internal, --- debug printing. See PprTyThing.pprFamInst for printing for the user -pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax - , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) - = hang (ppr_tc_sort <+> text "instance" - <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) - 2 (whenPprDebug debug_stuff) - where - ppr_tc_sort = case flavor of - SynFamilyInst -> text "type" - DataFamilyInst tycon - | isDataTyCon tycon -> text "data" - | isNewTyCon tycon -> text "newtype" - | isAbstractTyCon tycon -> text "data" - | otherwise -> text "WEIRD" <+> ppr tycon - - debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax - , text "Tvs:" <+> ppr tvs - , text "LHS:" <+> ppr tys - , text "RHS:" <+> ppr rhs ] - -pprFamInsts :: [FamInst] -> SDoc -pprFamInsts finsts = vcat (map pprFamInst finsts) - -{- -Note [Lazy axiom match] -~~~~~~~~~~~~~~~~~~~~~~~ -It is Vitally Important that mkImportedFamInst is *lazy* in its axiom -parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime -later, mkImportedFamInst is called using that axiom. However, the axiom -may itself depend on entities which are not yet loaded as of the time -of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the -axiom, a dependency loop spontaneously appears and GHC hangs. The solution -is simply for mkImportedFamInst never, ever to look inside of the axiom -until everything else is good and ready to do so. We can assume that this -readiness has been achieved when some other code pulls on the axiom in the -FamInst. Thus, we pattern match on the axiom lazily (in the where clause, -not in the parameter list) and we assert the consistency of names there -also. --} - --- Make a family instance representation from the information found in an --- interface file. In particular, we get the rough match info from the iface --- (instead of computing it here). -mkImportedFamInst :: Name -- Name of the family - -> [Maybe Name] -- Rough match info - -> CoAxiom Unbranched -- Axiom introduced - -> FamInst -- Resulting family instance -mkImportedFamInst fam mb_tcs axiom - = FamInst { - fi_fam = fam, - fi_tcs = mb_tcs, - fi_tvs = tvs, - fi_cvs = cvs, - fi_tys = tys, - fi_rhs = rhs, - fi_axiom = axiom, - fi_flavor = flavor } - where - -- See Note [Lazy axiom match] - ~(CoAxBranch { cab_lhs = tys - , cab_tvs = tvs - , cab_cvs = cvs - , cab_rhs = rhs }) = coAxiomSingleBranch axiom - - -- Derive the flavor for an imported FamInst rather disgustingly - -- Maybe we should store it in the IfaceFamInst? - flavor = case splitTyConApp_maybe rhs of - Just (tc, _) - | Just ax' <- tyConFamilyCoercion_maybe tc - , ax' == axiom - -> DataFamilyInst tc - _ -> SynFamilyInst - -{- -************************************************************************ -* * - FamInstEnv -* * -************************************************************************ - -Note [FamInstEnv] -~~~~~~~~~~~~~~~~~ -A FamInstEnv maps a family name to the list of known instances for that family. - -The same FamInstEnv includes both 'data family' and 'type family' instances. -Type families are reduced during type inference, but not data families; -the user explains when to use a data family instance by using constructors -and pattern matching. - -Nevertheless it is still useful to have data families in the FamInstEnv: - - - For finding overlaps and conflicts - - - For finding the representation type...see FamInstEnv.topNormaliseType - and its call site in Simplify - - - In standalone deriving instance Eq (T [Int]) we need to find the - representation type for T [Int] - -Note [Varying number of patterns for data family axioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For data families, the number of patterns may vary between instances. -For example - data family T a b - data instance T Int a = T1 a | T2 - data instance T Bool [a] = T3 a - -Then we get a data type for each instance, and an axiom: - data TInt a = T1 a | T2 - data TBoolList a = T3 a - - axiom ax7 :: T Int ~ TInt -- Eta-reduced - axiom ax8 a :: T Bool [a] ~ TBoolList a - -These two axioms for T, one with one pattern, one with two; -see Note [Eta reduction for data families] - -Note [FamInstEnv determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We turn FamInstEnvs into a list in some places that don't directly affect -the ABI. That happens in family consistency checks and when producing output -for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard -to tell what it affects without following a chain of functions. It's also -easy to accidentally make that nondeterminism affect the ABI. Furthermore -the envs should be relatively small, so it should be free to use deterministic -maps here. Testing with nofib and validate detected no difference between -UniqFM and UniqDFM. -See Note [Deterministic UniqFM]. --} - -type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances - -- See Note [FamInstEnv] - -- See Note [FamInstEnv determinism] - -type FamInstEnvs = (FamInstEnv, FamInstEnv) - -- External package inst-env, Home-package inst-env - -newtype FamilyInstEnv - = FamIE [FamInst] -- The instances for a particular family, in any order - -instance Outputable FamilyInstEnv where - ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) - --- INVARIANTS: --- * The fs_tvs are distinct in each FamInst --- of a range value of the map (so we can safely unify them) - -emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) -emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) - -emptyFamInstEnv :: FamInstEnv -emptyFamInstEnv = emptyUDFM - -famInstEnvElts :: FamInstEnv -> [FamInst] -famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] - -- See Note [FamInstEnv determinism] - -famInstEnvSize :: FamInstEnv -> Int -famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 - -- It's OK to use nonDetFoldUDFM here since we're just computing the - -- size. - -familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] -familyInstances (pkg_fie, home_fie) fam - = get home_fie ++ get pkg_fie - where - get env = case lookupUDFM env fam of - Just (FamIE insts) -> insts - Nothing -> [] - -extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv -extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis - -extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -extendFamInstEnv inst_env - ins_item@(FamInst {fi_fam = cls_nm}) - = addToUDFM_C add inst_env cls_nm (FamIE [ins_item]) - where - add (FamIE items) _ = FamIE (ins_item:items) - -{- -************************************************************************ -* * - Compatibility -* * -************************************************************************ - -Note [Apartness] -~~~~~~~~~~~~~~~~ -In dealing with closed type families, we must be able to check that one type -will never reduce to another. This check is called /apartness/. The check -is always between a target (which may be an arbitrary type) and a pattern. -Here is how we do it: - -apart(target, pattern) = not (unify(flatten(target), pattern)) - -where flatten (implemented in flattenTys, below) converts all type-family -applications into fresh variables. (See Note [Flattening].) - -Note [Compatibility] -~~~~~~~~~~~~~~~~~~~~ -Two patterns are /compatible/ if either of the following conditions hold: -1) The patterns are apart. -2) The patterns unify with a substitution S, and their right hand sides -equal under that substitution. - -For open type families, only compatible instances are allowed. For closed -type families, the story is slightly more complicated. Consider the following: - -type family F a where - F Int = Bool - F a = Int - -g :: Show a => a -> F a -g x = length (show x) - -Should that type-check? No. We need to allow for the possibility that 'a' -might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int -only when we can be sure that 'a' is not Int. - -To achieve this, after finding a possible match within the equations, we have to -go back to all previous equations and check that, under the -substitution induced by the match, other branches are surely apart. (See -Note [Apartness].) This is similar to what happens with class -instance selection, when we need to guarantee that there is only a match and -no unifiers. The exact algorithm is different here because the -potentially-overlapping group is closed. - -As another example, consider this: - -type family G x where - G Int = Bool - G a = Double - -type family H y --- no instances - -Now, we want to simplify (G (H Char)). We can't, because (H Char) might later -simplify to be Int. So, (G (H Char)) is stuck, for now. - -While everything above is quite sound, it isn't as expressive as we'd like. -Consider this: - -type family J a where - J Int = Int - J a = a - -Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if -b is instantiated with Int, but the RHSs coincide there, so it's all OK. - -So, the rule is this: when looking up a branch in a closed type family, we -find a branch that matches the target, but then we make sure that the target -is apart from every previous *incompatible* branch. We don't check the -branches that are compatible with the matching branch, because they are either -irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). - -Note [Compatibility of eta-reduced axioms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In newtype instances of data families we eta-reduce the axioms, -See Note [Eta reduction for data families] in FamInstEnv. This means that -we sometimes need to test compatibility of two axioms that were eta-reduced to -different degrees, e.g.: - - -data family D a b c -newtype instance D a Int c = DInt (Maybe a) - -- D a Int ~ Maybe - -- lhs = [a, Int] -newtype instance D Bool Int Char = DIntChar Float - -- D Bool Int Char ~ Float - -- lhs = [Bool, Int, Char] - -These are obviously incompatible. We could detect this by saturating -(eta-expanding) the shorter LHS with fresh tyvars until the lists are of -equal length, but instead we can just remove the tail of the longer list, as -those types will simply unify with the freshly introduced tyvars. - -By doing this, in case the LHS are unifiable, the yielded substitution won't -mention the tyvars that appear in the tail we dropped off, and we might try -to test equality RHSes of different kinds, but that's fine since this case -occurs only for data families, where the RHS is a unique tycon and the equality -fails anyway. --} - --- See Note [Compatibility] -compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool -compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) - = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 - -- See Note [Compatibility of eta-reduced axioms] - in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of - SurelyApart -> True - Unifiable subst - | Type.substTyAddInScope subst rhs1 `eqType` - Type.substTyAddInScope subst rhs2 - -> True - _ -> False - --- | Result of testing two type family equations for injectiviy. -data InjectivityCheckResult - = InjectivityAccepted - -- ^ Either RHSs are distinct or unification of RHSs leads to unification of - -- LHSs - | InjectivityUnified CoAxBranch CoAxBranch - -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for - -- closed type families where equation after unification might be - -- overlpapped (in which case it is OK if they don't unify). Constructor - -- stores axioms after unification. - --- | Check whether two type family axioms don't violate injectivity annotation. -injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch - -> InjectivityCheckResult -injectiveBranches injectivity - ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) - -- See Note [Verifying injectivity annotation], case 1. - = let getInjArgs = filterByList injectivity - in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification - Nothing -> InjectivityAccepted - -- RHS are different, so equations are injective. - -- This is case 1A from Note [Verifying injectivity annotation] - Just subst -> -- RHS unify under a substitution - let lhs1Subst = Type.substTys subst (getInjArgs lhs1) - lhs2Subst = Type.substTys subst (getInjArgs lhs2) - -- If LHSs are equal under the substitution used for RHSs then this pair - -- of equations does not violate injectivity annotation. If LHSs are not - -- equal under that substitution then this pair of equations violates - -- injectivity annotation, but for closed type families it still might - -- be the case that one LHS after substitution is unreachable. - in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. - then InjectivityAccepted - else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 - , cab_rhs = Type.substTy subst rhs1 }) - ( ax2 { cab_lhs = Type.substTys subst lhs2 - , cab_rhs = Type.substTy subst rhs2 }) - -- payload of InjectivityUnified used only for check 1B2, only - -- for closed type families - --- takes a CoAxiom with unknown branch incompatibilities and computes --- the compatibilities --- See Note [Storing compatibility] in CoAxiom -computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] -computeAxiomIncomps branches - = snd (mapAccumL go [] branches) - where - go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) - go prev_brs cur_br - = (cur_br : prev_brs, new_br) - where - new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } - - mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] - mk_incomps prev_brs cur_br - = filter (not . compatibleBranches cur_br) prev_brs - -{- -************************************************************************ -* * - Constructing axioms - These functions are here because tidyType / tcUnifyTysFG - are not available in CoAxiom - - Also computeAxiomIncomps is too sophisticated for CoAxiom -* * -************************************************************************ - -Note [Tidy axioms when we build them] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Like types and classes, we build axioms fully quantified over all -their variables, and tidy them when we build them. For example, -we print out axioms and don't want to print stuff like - F k k a b = ... -Instead we must tidy those kind variables. See #7524. - -We could instead tidy when we print, but that makes it harder to get -things like injectivity errors to come out right. Danger of - Type family equation violates injectivity annotation. - Kind variable ‘k’ cannot be inferred from the right-hand side. - In the type family equation: - PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 - -Note [Always number wildcard types in CoAxBranch] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example (from the DataFamilyInstanceLHS test case): - - data family Sing (a :: k) - data instance Sing (_ :: MyKind) where - SingA :: Sing A - SingB :: Sing B - -If we're not careful during tidying, then when this program is compiled with --ddump-types, we'll get the following information: - - COERCION AXIOMS - axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: - Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ - -It's misleading to have a wildcard type appearing on the RHS like -that. To avoid this issue, when building a CoAxiom (which is what eventually -gets printed above), we tidy all the variables in an env that already contains -'_'. Thus, any variable named '_' will be renamed, giving us the nicer output -here: - - COERCION AXIOMS - axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: - Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 - -Which is at least legal syntax. - -See also Note [CoAxBranch type variables] in CoAxiom; note that we -are tidying (changing OccNames only), not freshening, in accordance with -that Note. --} - --- all axiom roles are Nominal, as this is only used with type families -mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars - -> [TyVar] -- Extra eta tyvars - -> [CoVar] -- possibly stale covars - -> [Type] -- LHS patterns - -> Type -- RHS - -> [Role] - -> SrcSpan - -> CoAxBranch -mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc - = CoAxBranch { cab_tvs = tvs' - , cab_eta_tvs = eta_tvs' - , cab_cvs = cvs' - , cab_lhs = tidyTypes env lhs - , cab_roles = roles - , cab_rhs = tidyType env rhs - , cab_loc = loc - , cab_incomps = placeHolderIncomps } - where - (env1, tvs') = tidyVarBndrs init_tidy_env tvs - (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs - (env, cvs') = tidyVarBndrs env2 cvs - -- See Note [Tidy axioms when we build them] - -- See also Note [CoAxBranch type variables] in CoAxiom - - init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] - init_tidy_env = mkEmptyTidyEnv init_occ_env - -- See Note [Always number wildcard types in CoAxBranch] - --- all of the following code is here to avoid mutual dependencies with --- Coercion -mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched -mkBranchedCoAxiom ax_name fam_tc branches - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = Nominal - , co_ax_implicit = False - , co_ax_branches = manyBranches (computeAxiomIncomps branches) } - -mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched -mkUnbranchedCoAxiom ax_name fam_tc branch - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = Nominal - , co_ax_implicit = False - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - -mkSingleCoAxiom :: Role -> Name - -> [TyVar] -> [TyVar] -> [CoVar] - -> TyCon -> [Type] -> Type - -> CoAxiom Unbranched --- Make a single-branch CoAxiom, incluidng making the branch itself --- Used for both type family (Nominal) and data family (Representational) --- axioms, hence passing in the Role -mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_role = role - , co_ax_implicit = False - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - where - branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty - (map (const Nominal) tvs) - (getSrcSpan ax_name) - --- | Create a coercion constructor (axiom) suitable for the given --- newtype 'TyCon'. The 'Name' should be that of a new coercion --- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and --- the type the appropriate right hand side of the @newtype@, with --- the free variables a subset of those 'TyVar's. -mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched -mkNewTypeCoAxiom name tycon tvs roles rhs_ty - = CoAxiom { co_ax_unique = nameUnique name - , co_ax_name = name - , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon - , co_ax_role = Representational - , co_ax_tc = tycon - , co_ax_branches = unbranched (branch { cab_incomps = [] }) } - where - branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty - roles (getSrcSpan name) - -{- -************************************************************************ -* * - Looking up a family instance -* * -************************************************************************ - -@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. -Multiple matches are only possible in case of type families (not data -families), and then, it doesn't matter which match we choose (as the -instances are guaranteed confluent). - -We return the matching family instances and the type instance at which it -matches. For example, if we lookup 'T [Int]' and have a family instance - - data instance T [a] = .. - -desugared to - - data :R42T a = .. - coe :Co:R42T a :: T [a] ~ :R42T a - -we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. --} - --- when matching a type family application, we get a FamInst, --- and the list of types the axiom should be applied to -data FamInstMatch = FamInstMatch { fim_instance :: FamInst - , fim_tys :: [Type] - , fim_cos :: [Coercion] - } - -- See Note [Over-saturated matches] - -instance Outputable FamInstMatch where - ppr (FamInstMatch { fim_instance = inst - , fim_tys = tys - , fim_cos = cos }) - = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos - -lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] -lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc - = get pkg_ie ++ get home_ie - where - get ie = case lookupUDFM ie fam_tc of - Nothing -> [] - Just (FamIE fis) -> fis - -lookupFamInstEnv - :: FamInstEnvs - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches --- Precondition: the tycon is saturated (or over-saturated) - -lookupFamInstEnv - = lookup_fam_inst_env match - where - match _ _ tpl_tys tys = tcMatchTys tpl_tys tys - -lookupFamInstEnvConflicts - :: FamInstEnvs - -> FamInst -- Putative new instance - -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) --- E.g. when we are about to add --- f : type instance F [a] = a->a --- we do (lookupFamInstConflicts f [b]) --- to find conflicting matches --- --- Precondition: the tycon is saturated (or over-saturated) - -lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) - = lookup_fam_inst_env my_unify envs fam tys - where - (fam, tys) = famInstSplitLHS fam_inst - -- In example above, fam tys' = F [b] - - my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ - = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, - (ppr fam <+> ppr tys) $$ - (ppr tpl_tvs <+> ppr tpl_tys) ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch - then Nothing - else Just noSubst - -- Note [Family instance overlap conflicts] - - noSubst = panic "lookupFamInstEnvConflicts noSubst" - new_branch = coAxiomSingleBranch new_axiom - --------------------------------------------------------------------------------- --- Type family injectivity checking bits -- --------------------------------------------------------------------------------- - -{- Note [Verifying injectivity annotation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Injectivity means that the RHS of a type family uniquely determines the LHS (see -Note [Type inference for type families with injectivity]). The user informs us about -injectivity using an injectivity annotation and it is GHC's task to verify that -this annotation is correct w.r.t. type family equations. Whenever we see a new -equation of a type family we need to make sure that adding this equation to the -already known equations of a type family does not violate the injectivity annotation -supplied by the user (see Note [Injectivity annotation]). Of course if the type -family has no injectivity annotation then no check is required. But if a type -family has injectivity annotation we need to make sure that the following -conditions hold: - -1. For each pair of *different* equations of a type family, one of the following - conditions holds: - - A: RHSs are different. (Check done in FamInstEnv.injectiveBranches) - - B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution - then it must be possible to unify the LHSs under the same substitution. - Example: - - type family FunnyId a = r | r -> a - type instance FunnyId Int = Int - type instance FunnyId a = a - - RHSs of these two equations unify under [ a |-> Int ] substitution. - Under this substitution LHSs are equal therefore these equations don't - violate injectivity annotation. (Check done in FamInstEnv.injectiveBranches) - - B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some - substitution then either the LHSs unify under the same substitution or - the LHS of the latter equation is overlapped by earlier equations. - Example 1: - - type family SwapIntChar a = r | r -> a where - SwapIntChar Int = Char - SwapIntChar Char = Int - SwapIntChar a = a - - Say we are checking the last two equations. RHSs unify under [ a |-> - Int ] substitution but LHSs don't. So we apply the substitution to LHS - of last equation and check whether it is overlapped by any of previous - equations. Since it is overlapped by the first equation we conclude - that pair of last two equations does not violate injectivity - annotation. (Check done in TcValidity.checkValidCoAxiom#gather_conflicts) - - A special case of B is when RHSs unify with an empty substitution ie. they - are identical. - - If any of the above two conditions holds we conclude that the pair of - equations does not violate injectivity annotation. But if we find a pair - of equations where neither of the above holds we report that this pair - violates injectivity annotation because for a given RHS we don't have a - unique LHS. (Note that (B) actually implies (A).) - - Note that we only take into account these LHS patterns that were declared - as injective. - -2. If an RHS of a type family equation is a bare type variable then - all LHS variables (including implicit kind variables) also have to be bare. - In other words, this has to be a sole equation of that type family and it has - to cover all possible patterns. So for example this definition will be - rejected: - - type family W1 a = r | r -> a - type instance W1 [a] = a - - If it were accepted we could call `W1 [W1 Int]`, which would reduce to - `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, - which is bogus. Checked FamInst.bareTvInRHSViolated. - -3. If the RHS of a type family equation is a type family application then the type - family is rejected as not injective. This is checked by FamInst.isTFHeaded. - -4. If a LHS type variable that is declared as injective is not mentioned in an - injective position in the RHS then the type family is rejected as not - injective. "Injective position" means either an argument to a type - constructor or argument to a type family on injective position. - There are subtleties here. See Note [Coverage condition for injective type families] - in FamInst. - -Check (1) must be done for all family instances (transitively) imported. Other -checks (2-4) should be done just for locally written equations, as they are checks -involving just a single equation, not about interactions. Doing the other checks for -imported equations led to #17405, as the behavior of check (4) depends on --XUndecidableInstances (see Note [Coverage condition for injective type families] in -FamInst), which may vary between modules. - -See also Note [Injective type families] in TyCon --} - - --- | Check whether an open type family equation can be added to already existing --- instance environment without causing conflicts with supplied injectivity --- annotations. Returns list of conflicting axioms (type instance --- declarations). -lookupFamInstEnvInjectivityConflicts - :: [Bool] -- injectivity annotation for this type family instance - -- INVARIANT: list contains at least one True value - -> FamInstEnvs -- all type instances seens so far - -> FamInst -- new type instance that we're checking - -> [CoAxBranch] -- conflicting instance declarations -lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) - fam_inst@(FamInst { fi_axiom = new_axiom }) - -- See Note [Verifying injectivity annotation]. This function implements - -- check (1.B1) for open type families described there. - = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie - where - fam = famInstTyCon fam_inst - new_branch = coAxiomSingleBranch new_axiom - - -- filtering function used by `lookup_inj_fam_conflicts` to check whether - -- a pair of equations conflicts with the injectivity annotation. - isInjConflict (FamInst { fi_axiom = old_axiom }) - | InjectivityAccepted <- - injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch - = False -- no conflict - | otherwise = True - - lookup_inj_fam_conflicts ie - | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam - = map (coAxiomSingleBranch . fi_axiom) $ - filter isInjConflict insts - | otherwise = [] - - --------------------------------------------------------------------------------- --- Type family overlap checking bits -- --------------------------------------------------------------------------------- - -{- -Note [Family instance overlap conflicts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In the case of data family instances, any overlap is fundamentally a - conflict (as these instances imply injective type mappings). - -- In the case of type family instances, overlap is admitted as long as - the right-hand sides of the overlapping rules coincide under the - overlap substitution. eg - type instance F a Int = a - type instance F Int b = b - These two overlap on (F Int Int) but then both RHSs are Int, - so all is well. We require that they are syntactically equal; - anything else would be difficult to test for at this stage. --} - ------------------------------------------------------------- --- Might be a one-way match or a unifier -type MatchFun = FamInst -- The FamInst template - -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst - -> [Type] -- Target to match against - -> Maybe TCvSubst - -lookup_fam_inst_env' -- The worker, local to this module - :: MatchFun - -> FamInstEnv - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -lookup_fam_inst_env' match_fun ie fam match_tys - | isOpenFamilyTyCon fam - , Just (FamIE insts) <- lookupUDFM ie fam - = find insts -- The common case - | otherwise = [] - where - - find [] = [] - find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs - , fi_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find rest - - -- Proper check - | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 - = (FamInstMatch { fim_instance = item - , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 - , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) - substCoVars subst tpl_cvs - }) - : find rest - - -- No match => try next - | otherwise - = find rest - where - (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys - - -- Precondition: the tycon is saturated (or over-saturated) - - -- Deal with over-saturation - -- See Note [Over-saturated matches] - split_tys tpl_tys - | isTypeFamilyTyCon fam - = pre_rough_split_tys - - | otherwise - = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys - rough_tcs = roughMatchTcs match_tys1 - in (rough_tcs, match_tys1, match_tys2) - - (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys - pre_rough_split_tys - = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) - -lookup_fam_inst_env -- The worker, local to this module - :: MatchFun - -> FamInstEnvs - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches - --- Precondition: the tycon is saturated (or over-saturated) - -lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys - = lookup_fam_inst_env' match_fun home_ie fam tys - ++ lookup_fam_inst_env' match_fun pkg_ie fam tys - -{- -Note [Over-saturated matches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's ok to look up an over-saturated type constructor. E.g. - type family F a :: * -> * - type instance F (a,b) = Either (a->b) - -The type instance gives rise to a newtype TyCon (at a higher kind -which you can't do in Haskell!): - newtype FPair a b = FP (Either (a->b)) - -Then looking up (F (Int,Bool) Char) will return a FamInstMatch - (FPair, [Int,Bool,Char]) -The "extra" type argument [Char] just stays on the end. - -We handle data families and type families separately here: - - * For type families, all instances of a type family must have the - same arity, so we can precompute the split between the match_tys - and the overflow tys. This is done in pre_rough_split_tys. - - * For data family instances, though, we need to re-split for each - instance, because the breakdown might be different for each - instance. Why? Because of eta reduction; see - Note [Eta reduction for data families]. --} - --- checks if one LHS is dominated by a list of other branches --- in other words, if an application would match the first LHS, it is guaranteed --- to match at least one of the others. The RHSs are ignored. --- This algorithm is conservative: --- True -> the LHS is definitely covered by the others --- False -> no information --- It is currently (Oct 2012) used only for generating errors for --- inaccessible branches. If these errors go unreported, no harm done. --- This is defined here to avoid a dependency from CoAxiom to Unify -isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool -isDominatedBy branch branches - = or $ map match branches - where - lhs = coAxBranchLHS branch - match (CoAxBranch { cab_lhs = tys }) - = isJust $ tcMatchTys tys lhs - -{- -************************************************************************ -* * - Choosing an axiom application -* * -************************************************************************ - -The lookupFamInstEnv function does a nice job for *open* type families, -but we also need to handle closed ones when normalising a type: --} - -reduceTyFamApp_maybe :: FamInstEnvs - -> Role -- Desired role of result coercion - -> TyCon -> [Type] - -> Maybe (Coercion, Type) --- Attempt to do a *one-step* reduction of a type-family application --- but *not* newtypes --- Works on type-synonym families always; data-families only if --- the role we seek is representational --- It does *not* normlise the type arguments first, so this may not --- go as far as you want. If you want normalised type arguments, --- use normaliseTcArgs first. --- --- The TyCon can be oversaturated. --- Works on both open and closed families --- --- Always returns a *homogeneous* coercion -- type family reductions are always --- homogeneous -reduceTyFamApp_maybe envs role tc tys - | Phantom <- role - = Nothing - - | case role of - Representational -> isOpenFamilyTyCon tc - _ -> isOpenTypeFamilyTyCon tc - -- If we seek a representational coercion - -- (e.g. the call in topNormaliseType_maybe) then we can - -- unwrap data families as well as type-synonym families; - -- otherwise only type-synonym families - , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } - , fim_tys = inst_tys - , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys - -- NB: Allow multiple matches because of compatible overlap - - = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos - ty = pSnd (coercionKind co) - in Just (co, ty) - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc - , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys - = let co = mkAxInstCo role ax ind inst_tys inst_cos - ty = pSnd (coercionKind co) - in Just (co, ty) - - | Just ax <- isBuiltInSynFamTyCon_maybe tc - , Just (coax,ts,ty) <- sfMatchFam ax tys - = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) - in Just (co, ty) - - | otherwise - = Nothing - --- The axiom can be oversaturated. (Closed families only.) -chooseBranch :: CoAxiom Branched -> [Type] - -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args -chooseBranch axiom tys - = do { let num_pats = coAxiomNumPats axiom - (target_tys, extra_tys) = splitAt num_pats tys - branches = coAxiomBranches axiom - ; (ind, inst_tys, inst_cos) - <- findBranch (unMkBranches branches) target_tys - ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } - --- The axiom must *not* be oversaturated -findBranch :: Array BranchIndex CoAxBranch - -> [Type] - -> Maybe (BranchIndex, [Type], [Coercion]) - -- coercions relate requested types to returned axiom LHS at role N -findBranch branches target_tys - = foldr go Nothing (assocs branches) - where - go :: (BranchIndex, CoAxBranch) - -> Maybe (BranchIndex, [Type], [Coercion]) - -> Maybe (BranchIndex, [Type], [Coercion]) - go (index, branch) other - = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs - , cab_lhs = tpl_lhs - , cab_incomps = incomps }) = branch - in_scope = mkInScopeSet (unionVarSets $ - map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - -- See Note [Flattening] below - flattened_target = flattenTys in_scope target_tys - in case tcMatchTys tpl_lhs target_tys of - Just subst -- matching worked. now, check for apartness. - | apartnessCheck flattened_target branch - -> -- matching worked & we're apart from all incompatible branches. - -- success - ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) - Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) - - -- failure. keep looking - _ -> other - --- | Do an apartness check, as described in the "Closed Type Families" paper --- (POPL '14). This should be used when determining if an equation --- ('CoAxBranch') of a closed type family can be used to reduce a certain target --- type family application. -apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure - -- they're flattened! See Note [Flattening]. - -- (NB: This "flat" is a different - -- "flat" than is used in TcFlatten.) - -> CoAxBranch -- ^ the candidate equation we wish to use - -- Precondition: this matches the target - -> Bool -- ^ True <=> equation can fire -apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) - = all (isSurelyApart - . tcUnifyTysFG (const BindMe) flattened_target - . coAxBranchLHS) incomps - where - isSurelyApart SurelyApart = True - isSurelyApart _ = False - -{- -************************************************************************ -* * - Looking up a family instance -* * -************************************************************************ - -Note [Normalising types] -~~~~~~~~~~~~~~~~~~~~~~~~ -The topNormaliseType function removes all occurrences of type families -and newtypes from the top-level structure of a type. normaliseTcApp does -the type family lookup and is fairly straightforward. normaliseType is -a little more involved. - -The complication comes from the fact that a type family might be used in the -kind of a variable bound in a forall. We wish to remove this type family -application, but that means coming up with a fresh variable (with the new -kind). Thus, we need a substitution to be built up as we recur through the -type. However, an ordinary TCvSubst just won't do: when we hit a type variable -whose kind has changed during normalisation, we need both the new type -variable *and* the coercion. We could conjure up a new VarEnv with just this -property, but a usable substitution environment already exists: -LiftingContexts from the liftCoSubst family of functions, defined in Coercion. -A LiftingContext maps a type variable to a coercion and a coercion variable to -a pair of coercions. Let's ignore coercion variables for now. Because the -coercion a type variable maps to contains the destination type (via -coercionKind), we don't need to store that destination type separately. Thus, -a LiftingContext has what we need: a map from type variables to (Coercion, -Type) pairs. - -We also benefit because we can piggyback on the liftCoSubstVarBndr function to -deal with binders. However, I had to modify that function to work with this -application. Thus, we now have liftCoSubstVarBndrUsing, which takes -a function used to process the kind of the binder. We don't wish -to lift the kind, but instead normalise it. So, we pass in a callback function -that processes the kind of the binder. - -After that brilliant explanation of all this, I'm sure you've forgotten the -dangling reference to coercion variables. What do we do with those? Nothing at -all. The point of normalising types is to remove type family applications, but -there's no sense in removing these from coercions. We would just get back a -new coercion witnessing the equality between the same types as the original -coercion. Because coercions are irrelevant anyway, there is no point in doing -this. So, whenever we encounter a coercion, we just say that it won't change. -That's what the CoercionTy case is doing within normalise_type. - -Note [Normalisation and type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to be a bit careful about normalising in the presence of type -synonyms (#13035). Suppose S is a type synonym, and we have - S t1 t2 -If S is family-free (on its RHS) we can just normalise t1 and t2 and -reconstruct (S t1' t2'). Expanding S could not reveal any new redexes -because type families are saturated. - -But if S has a type family on its RHS we expand /before/ normalising -the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them -after expansion, and that can lead to /exponential/ behavour; see #13035. - -Notice, though, that expanding first can in principle duplicate t1,t2, -which might contain redexes. I'm sure you could conjure up an exponential -case by that route too, but it hasn't happened in practice yet! --} - -topNormaliseType :: FamInstEnvs -> Type -> Type -topNormaliseType env ty = case topNormaliseType_maybe env ty of - Just (_co, ty') -> ty' - Nothing -> ty - -topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) - --- ^ Get rid of *outermost* (or toplevel) --- * type function redex --- * data family redex --- * newtypes --- returning an appropriate Representational coercion. Specifically, if --- topNormaliseType_maybe env ty = Just (co, ty') --- then --- (a) co :: ty ~R ty' --- (b) ty' is not a newtype, and is not a type-family or data-family redex --- --- However, ty' can be something like (Maybe (F ty)), where --- (F ty) is a redex. --- --- Always operates homogeneously: the returned type has the same kind as the --- original type, and the returned coercion is always homogeneous. -topNormaliseType_maybe env ty - = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty - ; return $ case mkind_co of - MRefl -> (co, nty) - MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co - final_co = mkCoherenceRightCo Representational nty - (mkSymCo kind_co) co - in (final_co, nty_casted) } - where - stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper - - combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) - - unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) - unwrapNewTypeStepper' rec_nts tc tys - = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys - - -- second coercion below is the kind coercion relating the original type's kind - -- to the normalised type's kind - tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) - tyFamStepper rec_nts tc tys -- Try to step a type/data family - = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in - case reduceTyFamApp_maybe env Representational tc ntys of - Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co) - _ -> NS_Done - ---------------- -normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) --- See comments on normaliseType for the arguments of this function -normaliseTcApp env role tc tys - = initNormM env role (tyCoVarsOfTypes tys) $ - normalise_tc_app tc tys - --- See Note [Normalising types] about the LiftingContext -normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) -normalise_tc_app tc tys - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , not (isFamFreeTyCon tc) -- Expand and try again - = -- A synonym with type families in the RHS - -- Expand and try again - -- See Note [Normalisation and type synonyms] - normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - - | isFamilyTyCon tc - = -- A type-family application - do { env <- getEnv - ; role <- getRole - ; (args_co, ntys, res_co) <- normalise_tc_args tc tys - ; case reduceTyFamApp_maybe env role tc ntys of - Just (first_co, ty') - -> do { (rest_co,nty) <- normalise_type ty' - ; return (assemble_result role nty - (args_co `mkTransCo` first_co `mkTransCo` rest_co) - res_co) } - _ -> -- No unique matching family instance exists; - -- we do not do anything - return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } - - | otherwise - = -- A synonym with no type families in the RHS; or data type etc - -- Just normalise the arguments and rebuild - do { (args_co, ntys, res_co) <- normalise_tc_args tc tys - ; role <- getRole - ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } - - where - assemble_result :: Role -- r, ambient role in NormM monad - -> Type -- nty, result type, possibly of changed kind - -> Coercion -- orig_ty ~r nty, possibly heterogeneous - -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) - -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) - -- where nty_casted has same kind as orig_ty - assemble_result r nty orig_to_nty kind_co - = ( final_co, nty_old_kind ) - where - nty_old_kind = nty `mkCastTy` mkSymCo kind_co - final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty - ---------------- --- | Normalise arguments to a tycon -normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances - -> Role -- ^ desired role of output coercion - -> TyCon -- ^ tc - -> [Type] -- ^ tys - -> (Coercion, [Type], CoercionN) - -- ^ co :: tc tys ~ tc new_tys - -- NB: co might not be homogeneous - -- last coercion :: kind(tc tys) ~ kind(tc new_tys) -normaliseTcArgs env role tc tys - = initNormM env role (tyCoVarsOfTypes tys) $ - normalise_tc_args tc tys - -normalise_tc_args :: TyCon -> [Type] -- tc tys - -> NormM (Coercion, [Type], CoercionN) - -- (co, new_tys), where - -- co :: tc tys ~ tc new_tys; might not be homogeneous - -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) -normalise_tc_args tc tys - = do { role <- getRole - ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys - ; return (mkTyConAppCo role tc args_cos, nargs, res_co) } - ---------------- -normaliseType :: FamInstEnvs - -> Role -- desired role of coercion - -> Type -> (Coercion, Type) -normaliseType env role ty - = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty - -normalise_type :: Type -- old type - -> NormM (Coercion, Type) -- (coercion, new type), where - -- co :: old-type ~ new_type --- Normalise the input type, by eliminating *all* type-function redexes --- but *not* newtypes (which are visible to the programmer) --- Returns with Refl if nothing happens --- Does nothing to newtypes --- The returned coercion *must* be *homogeneous* --- See Note [Normalising types] --- Try not to disturb type synonyms if possible - -normalise_type ty - = go ty - where - go (TyConApp tc tys) = normalise_tc_app tc tys - go ty@(LitTy {}) = do { r <- getRole - ; return (mkReflCo r ty, ty) } - - go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] - - go ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) - = do { (co1, nty1) <- go ty1 - ; (co2, nty2) <- go ty2 - ; r <- getRole - ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) } - go (ForAllTy (Bndr tcvar vis) ty) - = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar - ; (co, nty) <- withLC lc' $ normalise_type ty - ; let tv2 = setTyVarKind tv' ki' - ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } - go (TyVarTy tv) = normalise_tyvar tv - go (CastTy ty co) - = do { (nco, nty) <- go ty - ; lc <- getLC - ; let co' = substRightCo lc co - ; return (castCoercionKind nco Nominal ty nty co co' - , mkCastTy nty co') } - go (CoercionTy co) - = do { lc <- getLC - ; r <- getRole - ; let right_co = substRightCo lc co - ; return ( mkProofIrrelCo r - (liftCoSubst Nominal lc (coercionType co)) - co right_co - , mkCoercionTy right_co ) } - - go_app_tys :: Type -- function - -> [Type] -- args - -> NormM (Coercion, Type) - -- cf. TcFlatten.flatten_app_ty_args - go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) - go_app_tys fun_ty arg_tys - = do { (fun_co, nfun) <- go fun_ty - ; case tcSplitTyConApp_maybe nfun of - Just (tc, xis) -> - do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys)) - -- flatten_app_ty_args avoids redundantly processing the xis, - -- but that's a much more performance-sensitive function. - -- This type normalisation is not called in a loop. - ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) } - Nothing -> - do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun) - (repeat Nominal) - arg_tys - ; role <- getRole - ; let nty = mkAppTys nfun nargs - nco = mkAppCos fun_co args_cos - nty_casted = nty `mkCastTy` mkSymCo res_co - final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco - ; return (final_co, nty_casted) } } - -normalise_args :: Kind -- of the function - -> [Role] -- roles at which to normalise args - -> [Type] -- args - -> NormM ([Coercion], [Type], Coercion) --- returns (cos, xis, res_co), where each xi is the normalised --- version of the corresponding type, each co is orig_arg ~ xi, --- and the res_co :: kind(f orig_args) ~ kind(f xis) --- NB: The xis might *not* have the same kinds as the input types, --- but the resulting application *will* be well-kinded --- cf. TcFlatten.flatten_args_slow -normalise_args fun_ki roles args - = do { normed_args <- zipWithM normalise1 roles args - ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args - ; return (map mkSymCo cos, xis, mkSymCo res_co) } - where - (ki_binders, inner_ki) = splitPiTys fun_ki - fvs = tyCoVarsOfTypes args - - -- flattener conventions are different from ours - impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion) - impedance_match action = do { (co, ty) <- action - ; return (ty, mkSymCo co) } - - normalise1 role ty - = impedance_match $ withRole role $ normalise_type ty - -normalise_tyvar :: TyVar -> NormM (Coercion, Type) -normalise_tyvar tv - = ASSERT( isTyVar tv ) - do { lc <- getLC - ; r <- getRole - ; return $ case liftCoSubstTyVar lc r tv of - Just co -> (co, pSnd $ coercionKind co) - Nothing -> (mkReflCo r ty, ty) } - where ty = mkTyVarTy tv - -normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) -normalise_var_bndr tcvar - -- works for both tvar and covar - = do { lc1 <- getLC - ; env <- getEnv - ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal - ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } - --- | a monad for the normalisation functions, reading 'FamInstEnvs', --- a 'LiftingContext', and a 'Role'. -newtype NormM a = NormM { runNormM :: - FamInstEnvs -> LiftingContext -> Role -> a } - deriving (Functor) - -initNormM :: FamInstEnvs -> Role - -> TyCoVarSet -- the in-scope variables - -> NormM a -> a -initNormM env role vars (NormM thing_inside) - = thing_inside env lc role - where - in_scope = mkInScopeSet vars - lc = emptyLiftingContext in_scope - -getRole :: NormM Role -getRole = NormM (\ _ _ r -> r) - -getLC :: NormM LiftingContext -getLC = NormM (\ _ lc _ -> lc) - -getEnv :: NormM FamInstEnvs -getEnv = NormM (\ env _ _ -> env) - -withRole :: Role -> NormM a -> NormM a -withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r - -withLC :: LiftingContext -> NormM a -> NormM a -withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r - -instance Monad NormM where - ma >>= fmb = NormM $ \env lc r -> - let a = runNormM ma env lc r in - runNormM (fmb a) env lc r - -instance Applicative NormM where - pure x = NormM $ \ _ _ _ -> x - (<*>) = ap - -{- -************************************************************************ -* * - Flattening -* * -************************************************************************ - -Note [Flattening] -~~~~~~~~~~~~~~~~~ -As described in "Closed type families with overlapping equations" -http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf -we need to flatten core types before unifying them, when checking for "surely-apart" -against earlier equations of a closed type family. -Flattening means replacing all top-level uses of type functions with -fresh variables, *taking care to preserve sharing*. That is, the type -(Either (F a b) (F a b)) should flatten to (Either c c), never (Either -c d). - -Here is a nice example of why it's all necessary: - - type family F a b where - F Int Bool = Char - F a b = Double - type family G a -- open, no instances - -How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, -while the second equation does. But, before reducing, we must make sure that the -target can never become (F Int Bool). Well, no matter what G Float becomes, it -certainly won't become *both* Int and Bool, so indeed we're safe reducing -(F (G Float) (G Float)) to Double. - -This is necessary not only to get more reductions (which we might be -willing to give up on), but for substitutivity. If we have (F x x), we -can see that (F x x) can reduce to Double. So, it had better be the -case that (F blah blah) can reduce to Double, no matter what (blah) -is! Flattening as done below ensures this. - -The algorithm works by building up a TypeMap TyVar, mapping -type family applications to fresh variables. This mapping must -be threaded through all the function calls, as any entry in -the mapping must be propagated to all future nodes in the tree. - -The algorithm also must track the set of in-scope variables, in -order to make fresh variables as it flattens. (We are far from a -source of fresh Uniques.) See Wrinkle 2, below. - -There are wrinkles, of course: - -1. The flattening algorithm must account for the possibility - of inner `forall`s. (A `forall` seen here can happen only - because of impredicativity. However, the flattening operation - is an algorithm in Core, which is impredicative.) - Suppose we have (forall b. F b) -> (forall b. F b). Of course, - those two bs are entirely unrelated, and so we should certainly - not flatten the two calls F b to the same variable. Instead, they - must be treated separately. We thus carry a substitution that - freshens variables; we must apply this substitution (in - `coreFlattenTyFamApp`) before looking up an application in the environment. - Note that the range of the substitution contains only TyVars, never anything - else. - - For the sake of efficiency, we only apply this substitution when absolutely - necessary. Namely: - - * We do not perform the substitution at all if it is empty. - * We only need to worry about the arguments of a type family that are within - the arity of said type family, so we can get away with not applying the - substitution to any oversaturated type family arguments. - * Importantly, we do /not/ achieve this substitution by recursively - flattening the arguments, as this would be wrong. Consider `F (G a)`, - where F and G are type families. We might decide that `F (G a)` flattens - to `beta`. Later, the substitution is non-empty (but does not map `a`) and - so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course, - `F gamma` is unknown, and so we flatten it to `delta`, but it really - should have been `beta`! Argh! - - Moral of the story: instead of flattening the arguments, just substitute - them directly. - -2. There are two different reasons we might add a variable - to the in-scope set as we work: - - A. We have just invented a new flattening variable. - B. We have entered a `forall`. - - Annoying here is that in-scope variable source (A) must be - threaded through the calls. For example, consider (F b -> forall c. F c). - Suppose that, when flattening F b, we invent a fresh variable c. - Now, when we encounter (forall c. F c), we need to know c is already in - scope so that we locally rename c to c'. However, if we don't thread through - the in-scope set from one argument of (->) to the other, we won't know this - and might get very confused. - - In contrast, source (B) increases only as we go deeper, as in-scope sets - normally do. However, even here we must be careful. The TypeMap TyVar that - contains mappings from type family applications to freshened variables will - be threaded through both sides of (forall b. F b) -> (forall b. F b). We - thus must make sure that the two `b`s don't get renamed to the same b1. (If - they did, then looking up `F b1` would yield the same flatten var for - each.) So, even though `forall`-bound variables should really be in the - in-scope set only when they are in scope, we retain these variables even - outside of their scope. This ensures that, if we enounter a fresh - `forall`-bound b, we will rename it to b2, not b1. Note that keeping a - larger in-scope set than strictly necessary is always OK, as in-scope sets - are only ever used to avoid collisions. - - Sadly, the freshening substitution described in (1) really musn't bind - variables outside of their scope: note that its domain is the *unrenamed* - variables. This means that the substitution gets "pushed down" (like a - reader monad) while the in-scope set gets threaded (like a state monad). - Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; - instead, we just carry a TvSubstEnv down, tying it to the InScopeSet - traveling separately as necessary. - -3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k: - - type family F ty_1 ... ty_k :: res_k - - It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a - flattening skolem. But we must instead flatten it to - `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the - type family. - - Why is this better? Consider the following concrete example from #16995: - - type family Param :: Type -> Type - - type family LookupParam (a :: Type) :: Type where - LookupParam (f Char) = Bool - LookupParam x = Int - - foo :: LookupParam (Param ()) - foo = 42 - - In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to - `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if - `alpha` is apart from `f Char`, so it won't fall through to the second - equation. But since the `Param` type family has arity 0, we can instead - flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is - apart from `f Char`, permitting the second equation to be reached. - - Not only does this allow more programs to be accepted, it's also important - for correctness. Not doing this was the root cause of the Core Lint error - in #16995. - -flattenTys is defined here because of module dependencies. --} - -data FlattenEnv - = FlattenEnv { fe_type_map :: TypeMap TyVar - -- domain: exactly-saturated type family applications - -- range: fresh variables - , fe_in_scope :: InScopeSet } - -- See Note [Flattening] - -emptyFlattenEnv :: InScopeSet -> FlattenEnv -emptyFlattenEnv in_scope - = FlattenEnv { fe_type_map = emptyTypeMap - , fe_in_scope = in_scope } - -updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv -updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } - -flattenTys :: InScopeSet -> [Type] -> [Type] --- See Note [Flattening] --- NB: the returned types may mention fresh type variables, --- arising from the flattening. We don't return the --- mapping from those fresh vars to the ty-fam --- applications they stand for (we could, but no need) -flattenTys in_scope tys - = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys - -coreFlattenTys :: TvSubstEnv -> FlattenEnv - -> [Type] -> (FlattenEnv, [Type]) -coreFlattenTys subst = mapAccumL (coreFlattenTy subst) - -coreFlattenTy :: TvSubstEnv -> FlattenEnv - -> Type -> (FlattenEnv, Type) -coreFlattenTy subst = go - where - go env ty | Just ty' <- coreView ty = go env ty' - - go env (TyVarTy tv) - | Just ty <- lookupVarEnv subst tv = (env, ty) - | otherwise = let (env', ki) = go env (tyVarKind tv) in - (env', mkTyVarTy $ setTyVarKind tv ki) - go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, AppTy ty1' ty2') - go env (TyConApp tc tys) - -- NB: Don't just check if isFamilyTyCon: this catches *data* families, - -- which are generative and thus can be preserved during flattening - | not (isGenerativeTyCon tc Nominal) - = coreFlattenTyFamApp subst env tc tys - - | otherwise - = let (env', tys') = coreFlattenTys subst env tys in - (env', mkTyConApp tc tys') - - go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) - = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, ty { ft_arg = ty1', ft_res = ty2' }) - - go env (ForAllTy (Bndr tv vis) ty) - = let (env1, subst', tv') = coreFlattenVarBndr subst env tv - (env2, ty') = coreFlattenTy subst' env1 ty in - (env2, ForAllTy (Bndr tv' vis) ty') - - go env ty@(LitTy {}) = (env, ty) - - go env (CastTy ty co) - = let (env1, ty') = go env ty - (env2, co') = coreFlattenCo subst env1 co in - (env2, CastTy ty' co') - - go env (CoercionTy co) - = let (env', co') = coreFlattenCo subst env co in - (env', CoercionTy co') - --- when flattening, we don't care about the contents of coercions. --- so, just return a fresh variable of the right (flattened) type -coreFlattenCo :: TvSubstEnv -> FlattenEnv - -> Coercion -> (FlattenEnv, Coercion) -coreFlattenCo subst env co - = (env2, mkCoVarCo covar) - where - fresh_name = mkFlattenFreshCoName - (env1, kind') = coreFlattenTy subst env (coercionType co) - covar = uniqAway (fe_in_scope env1) (mkCoVar fresh_name kind') - -- Add the covar to the FlattenEnv's in-scope set. - -- See Note [Flattening], wrinkle 2A. - env2 = updateInScopeSet env1 (flip extendInScopeSet covar) - -coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv - -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar) -coreFlattenVarBndr subst env tv - = (env2, subst', tv') - where - -- See Note [Flattening], wrinkle 2B. - kind = varType tv - (env1, kind') = coreFlattenTy subst env kind - tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') - subst' = extendVarEnv subst tv (mkTyVarTy tv') - env2 = updateInScopeSet env1 (flip extendInScopeSet tv') - -coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv - -> TyCon -- type family tycon - -> [Type] -- args, already flattened - -> (FlattenEnv, Type) -coreFlattenTyFamApp tv_subst env fam_tc fam_args - = case lookupTypeMap type_map fam_ty of - Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args') - Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc - tv = uniqAway in_scope $ - mkTyVar tyvar_name (typeKind fam_ty) - - ty' = mkAppTys (mkTyVarTy tv) leftover_args' - env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv - , fe_in_scope = extendInScopeSet in_scope tv } - in (env'', ty') - where - arity = tyConArity fam_tc - tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv - (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args ) - splitAt arity fam_args - -- Apply the substitution before looking up an application in the - -- environment. See Note [Flattening], wrinkle 1. - -- NB: substTys short-cuts the common case when the substitution is empty. - sat_fam_args' = substTys tcv_subst sat_fam_args - (env', leftover_args') = coreFlattenTys tv_subst env leftover_args - -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening], - -- wrinkle 3), so we split it into the arguments needed to saturate it - -- (sat_fam_args') and the rest (leftover_args') - fam_ty = mkTyConApp fam_tc sat_fam_args' - FlattenEnv { fe_type_map = type_map - , fe_in_scope = in_scope } = env' - -mkFlattenFreshTyName :: Uniquable a => a -> Name -mkFlattenFreshTyName unq - = mkSysTvName (getUnique unq) (fsLit "flt") - -mkFlattenFreshCoName :: Name -mkFlattenFreshCoName - = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc") diff --git a/types/InstEnv.hs b/types/InstEnv.hs deleted file mode 100644 --- a/types/InstEnv.hs +++ /dev/null @@ -1,1030 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[InstEnv]{Utilities for typechecking instance declarations} - -The bits common to TcInstDcls and TcDeriv. --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module InstEnv ( - DFunId, InstMatch, ClsInstLookupResult, - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, - instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, - instanceDFunId, updateClsInstDFun, instanceRoughTcs, - fuzzyClsInstCmp, orphNamesOfClsInst, - - InstEnvs(..), VisibleOrphanModules, InstEnv, - emptyInstEnv, extendInstEnv, - deleteFromInstEnv, deleteDFunFromInstEnv, - identicalClsInstHead, - extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, - memberInstEnv, - instIsVisible, - classInstances, instanceBindFun, - instanceCantMatch, roughMatchTcs, - isOverlappable, isOverlapping, isIncoherent - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcType -- InstEnv is really part of the type checker, - -- and depends on TcType in many ways -import CoreSyn ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) -import Module -import Class -import Var -import VarSet -import Name -import NameSet -import Unify -import Outputable -import ErrUtils -import BasicTypes -import UniqDFM -import Util -import Id -import Data.Data ( Data ) -import Data.Maybe ( isJust, isNothing ) - -{- -************************************************************************ -* * - ClsInst: the data type for type-class instances -* * -************************************************************************ --} - --- | A type-class instance. Note that there is some tricky laziness at work --- here. See Note [ClsInst laziness and the rough-match fields] for more --- details. -data ClsInst - = ClsInst { -- Used for "rough matching"; see - -- Note [ClsInst laziness and the rough-match fields] - -- INVARIANT: is_tcs = roughMatchTcs is_tys - is_cls_nm :: Name -- ^ Class name - , is_tcs :: [Maybe Name] -- ^ Top of type args - - -- | @is_dfun_name = idName . is_dfun@. - -- - -- We use 'is_dfun_name' for the visibility check, - -- 'instIsVisible', which needs to know the 'Module' which the - -- dictionary is defined in. However, we cannot use the 'Module' - -- attached to 'is_dfun' since doing so would mean we would - -- potentially pull in an entire interface file unnecessarily. - -- This was the cause of #12367. - , is_dfun_name :: Name - - -- Used for "proper matching"; see Note [Proper-match fields] - , is_tvs :: [TyVar] -- Fresh template tyvars for full match - -- See Note [Template tyvars are fresh] - , is_cls :: Class -- The real class - , is_tys :: [Type] -- Full arg types (mentioning is_tvs) - -- INVARIANT: is_dfun Id has type - -- forall is_tvs. (...) => is_cls is_tys - -- (modulo alpha conversion) - - , is_dfun :: DFunId -- See Note [Haddock assumptions] - - , is_flag :: OverlapFlag -- See detailed comments with - -- the decl of BasicTypes.OverlapFlag - , is_orphan :: IsOrphan - } - deriving Data - --- | A fuzzy comparison function for class instances, intended for sorting --- instances before displaying them to the user. -fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering -fuzzyClsInstCmp x y = - stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` - mconcat (map cmp (zip (is_tcs x) (is_tcs y))) - where - cmp (Nothing, Nothing) = EQ - cmp (Nothing, Just _) = LT - cmp (Just _, Nothing) = GT - cmp (Just x, Just y) = stableNameCmp x y - -isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool -isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) -isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) -isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) - -{- -Note [ClsInst laziness and the rough-match fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is -otherwise unused in the program. Then it's stupid to load B.hi, the data type -declaration for B.T -- and perhaps further instance declarations! - -We avoid this as follows: - -* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's - content. - -* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys - contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we - poke any of these fields we'll typecheck the DFunId declaration, and hence - pull in interfaces that it refers to. See Note [Proper-match fields]. - -* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and - is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking - inside the DFunId. The rough-match fields allow us to say "definitely does not - match", based only on Names. - - This laziness is very important; see #12367. Try hard to avoid pulling on - the structured fields unless you really need the instance. - -* Another place to watch is InstEnv.instIsVisible, which needs the module to - which the ClsInst belongs. We can get this from is_dfun_name. - -* In is_tcs, - Nothing means that this type arg is a type variable - - (Just n) means that this type arg is a - TyConApp with a type constructor of n. - This is always a real tycon, never a synonym! - (Two different synonyms might match, but two - different real tycons can't.) - NB: newtypes are not transparent, though! --} - -{- -Note [Template tyvars are fresh] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_tvs field of a ClsInst has *completely fresh* tyvars. -That is, they are - * distinct from any other ClsInst - * distinct from any tyvars free in predicates that may - be looked up in the class instance environment -Reason for freshness: we use unification when checking for overlap -etc, and that requires the tyvars to be distinct. - -The invariant is checked by the ASSERT in lookupInstEnv'. - -Note [Proper-match fields] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_tvs, is_cls, is_tys fields are simply cached values, pulled -out (lazily) from the dfun id. They are cached here simply so -that we don't need to decompose the DFunId each time we want -to match it. The hope is that the rough-match fields mean -that we often never poke the proper-match fields. - -However, note that: - * is_tvs must be a superset of the free vars of is_tys - - * is_tvs, is_tys may be alpha-renamed compared to the ones in - the dfun Id - -Note [Haddock assumptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For normal user-written instances, Haddock relies on - - * the SrcSpan of - * the Name of - * the is_dfun of - * an Instance - -being equal to - - * the SrcSpan of - * the instance head type of - * the InstDecl used to construct the Instance. --} - -instanceDFunId :: ClsInst -> DFunId -instanceDFunId = is_dfun - -updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst -updateClsInstDFun tidy_dfun ispec - = ispec { is_dfun = tidy_dfun (is_dfun ispec) } - -instanceRoughTcs :: ClsInst -> [Maybe Name] -instanceRoughTcs = is_tcs - - -instance NamedThing ClsInst where - getName ispec = getName (is_dfun ispec) - -instance Outputable ClsInst where - ppr = pprInstance - -pprInstance :: ClsInst -> SDoc --- Prints the ClsInst as an instance declaration -pprInstance ispec - = hang (pprInstanceHdr ispec) - 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) - , whenPprDebug (ppr (is_dfun ispec)) ]) - --- * pprInstanceHdr is used in VStudio to populate the ClassView tree -pprInstanceHdr :: ClsInst -> SDoc --- Prints the ClsInst as an instance declaration -pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) - = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) - -pprInstances :: [ClsInst] -> SDoc -pprInstances ispecs = vcat (map pprInstance ispecs) - -instanceHead :: ClsInst -> ([TyVar], Class, [Type]) --- Returns the head, using the fresh tyavs from the ClsInst -instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) - = (tvs, cls, tys) - where - (_, _, cls, _) = tcSplitDFunTy (idType dfun) - --- | Collects the names of concrete types and type constructors that make --- up the head of a class instance. For instance, given `class Foo a b`: --- --- `instance Foo (Either (Maybe Int) a) Bool` would yield --- [Either, Maybe, Int, Bool] --- --- Used in the implementation of ":info" in GHCi. --- --- The 'tcSplitSigmaTy' is because of --- instance Foo a => Baz T where ... --- The decl is an orphan if Baz and T are both not locally defined, --- even if Foo *is* locally defined -orphNamesOfClsInst :: ClsInst -> NameSet -orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) - = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm - -instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) --- Decomposes the DFunId -instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) - -mkLocalInstance :: DFunId -> OverlapFlag - -> [TyVar] -> Class -> [Type] - -> ClsInst --- Used for local instances, where we can safely pull on the DFunId. --- Consider using newClsInst instead; this will also warn if --- the instance is an orphan. -mkLocalInstance dfun oflag tvs cls tys - = ClsInst { is_flag = oflag, is_dfun = dfun - , is_tvs = tvs - , is_dfun_name = dfun_name - , is_cls = cls, is_cls_nm = cls_name - , is_tys = tys, is_tcs = roughMatchTcs tys - , is_orphan = orph - } - where - cls_name = className cls - dfun_name = idName dfun - this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name - is_local name = nameIsLocalOrFrom this_mod name - - -- Compute orphanhood. See Note [Orphans] in InstEnv - (cls_tvs, fds) = classTvsFds cls - arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] - - -- See Note [When exactly is an instance decl an orphan?] - orph | is_local cls_name = NotOrphan (nameOccName cls_name) - | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns - | otherwise = IsOrphan - - notOrphan NotOrphan{} = True - notOrphan _ = False - - mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name - -- that is not in the "determined" arguments - mb_ns | null fds = [choose_one arg_names] - | otherwise = map do_one fds - do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names - , not (tv `elem` rtvs)] - - choose_one nss = chooseOrphanAnchor (unionNameSets nss) - -mkImportedInstance :: Name -- ^ the name of the class - -> [Maybe Name] -- ^ the types which the class was applied to - -> Name -- ^ the 'Name' of the dictionary binding - -> DFunId -- ^ the 'Id' of the dictionary. - -> OverlapFlag -- ^ may this instance overlap? - -> IsOrphan -- ^ is this instance an orphan? - -> ClsInst --- Used for imported instances, where we get the rough-match stuff --- from the interface file --- The bound tyvars of the dfun are guaranteed fresh, because --- the dfun has been typechecked out of the same interface file -mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan - = ClsInst { is_flag = oflag, is_dfun = dfun - , is_tvs = tvs, is_tys = tys - , is_dfun_name = dfun_name - , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs - , is_orphan = orphan } - where - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) - -{- -Note [When exactly is an instance decl an orphan?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - (see MkIface.instanceToIfaceInst, which implements this) -Roughly speaking, an instance is an orphan if its head (after the =>) -mentions nothing defined in this module. - -Functional dependencies complicate the situation though. Consider - - module M where { class C a b | a -> b } - -and suppose we are compiling module X: - - module X where - import M - data T = ... - instance C Int T where ... - -This instance is an orphan, because when compiling a third module Y we -might get a constraint (C Int v), and we'd want to improve v to T. So -we must make sure X's instances are loaded, even if we do not directly -use anything from X. - -More precisely, an instance is an orphan iff - - If there are no fundeps, then at least of the names in - the instance head is locally defined. - - If there are fundeps, then for every fundep, at least one of the - names free in a *non-determined* part of the instance head is - defined in this module. - -(Note that these conditions hold trivially if the class is locally -defined.) - - -************************************************************************ -* * - InstEnv, ClsInstEnv -* * -************************************************************************ - -A @ClsInstEnv@ all the instances of that class. The @Id@ inside a -ClsInstEnv mapping is the dfun for that instance. - -If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then - - forall a b, C t1 t2 t3 can be constructed by dfun - -or, to put it another way, we have - - instance (...) => C t1 t2 t3, witnessed by dfun --} - ---------------------------------------------------- -{- -Note [InstEnv determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We turn InstEnvs into a list in some places that don't directly affect -the ABI. That happens when we create output for `:info`. -Unfortunately that nondeterminism is nonlocal and it's hard to tell what it -affects without following a chain of functions. It's also easy to accidentally -make that nondeterminism affect the ABI. Furthermore the envs should be -relatively small, so it should be free to use deterministic maps here. -Testing with nofib and validate detected no difference between UniqFM and -UniqDFM. See also Note [Deterministic UniqFM] --} - -type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class - -- See Note [InstEnv determinism] - --- | 'InstEnvs' represents the combination of the global type class instance --- environment, the local type class instance environment, and the set of --- transitively reachable orphan modules (according to what modules have been --- directly imported) used to test orphan instance visibility. -data InstEnvs = InstEnvs { - ie_global :: InstEnv, -- External-package instances - ie_local :: InstEnv, -- Home-package instances - ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively - -- reachable from the module being compiled - -- See Note [Instance lookup and orphan instances] - } - --- | Set of visible orphan modules, according to what modules have been directly --- imported. This is based off of the dep_orphs field, which records --- transitively reachable orphan modules (modules that define orphan instances). -type VisibleOrphanModules = ModuleSet - -newtype ClsInstEnv - = ClsIE [ClsInst] -- The instances for a particular class, in any order - -instance Outputable ClsInstEnv where - ppr (ClsIE is) = pprInstances is - --- INVARIANTS: --- * The is_tvs are distinct in each ClsInst --- of a ClsInstEnv (so we can safely unify them) - --- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: --- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] --- The "a" in the pattern must be one of the forall'd variables in --- the dfun type. - -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUDFM - -instEnvElts :: InstEnv -> [ClsInst] -instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] - -- See Note [InstEnv determinism] - -instEnvClasses :: InstEnv -> [Class] -instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie] - --- | Test if an instance is visible, by checking that its origin module --- is in 'VisibleOrphanModules'. --- See Note [Instance lookup and orphan instances] -instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool -instIsVisible vis_mods ispec - -- NB: Instances from the interactive package always are visible. We can't - -- add interactive modules to the set since we keep creating new ones - -- as a GHCi session progresses. - = case nameModule_maybe (is_dfun_name ispec) of - Nothing -> True - Just mod | isInteractiveModule mod -> True - | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods - | otherwise -> True - -classInstances :: InstEnvs -> Class -> [ClsInst] -classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls - = get home_ie ++ get pkg_ie - where - get env = case lookupUDFM env cls of - Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts - Nothing -> [] - --- | Checks for an exact match of ClsInst in the instance environment. --- We use this when we do signature checking in TcRnDriver -memberInstEnv :: InstEnv -> ClsInst -> Bool -memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = - maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) - (lookupUDFM inst_env cls_nm) - where - identicalDFunType cls1 cls2 = - eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) - -extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv -extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs - -extendInstEnv :: InstEnv -> ClsInst -> InstEnv -extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item]) - where - add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) - -deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv -deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) - = adjustUDFM adjust inst_env cls_nm - where - adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) - -deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv --- Delete a specific instance fron an InstEnv -deleteDFunFromInstEnv inst_env dfun - = adjustUDFM adjust inst_env cls - where - (_, _, cls, _) = tcSplitDFunTy (idType dfun) - adjust (ClsIE items) = ClsIE (filterOut same_dfun items) - same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' - -identicalClsInstHead :: ClsInst -> ClsInst -> Bool --- ^ True when when the instance heads are the same --- e.g. both are Eq [(a,b)] --- Used for overriding in GHCi --- Obviously should be insenstive to alpha-renaming -identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) - (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) - = cls_nm1 == cls_nm2 - && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields - && isJust (tcMatchTys tys1 tys2) - && isJust (tcMatchTys tys2 tys1) - -{- -************************************************************************ -* * - Looking up an instance -* * -************************************************************************ - -@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since -the env is kept ordered, the first match must be the only one. The -thing we are looking up can have an arbitrary "flexi" part. - -Note [Instance lookup and orphan instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are compiling a module M, and we have a zillion packages -loaded, and we are looking up an instance for C (T W). If we find a -match in module 'X' from package 'p', should be "in scope"; that is, - - is p:X in the transitive closure of modules imported from M? - -The difficulty is that the "zillion packages" might include ones loaded -through earlier invocations of the GHC API, or earlier module loads in GHCi. -They might not be in the dependencies of M itself; and if not, the instances -in them should not be visible. #2182, #8427. - -There are two cases: - * If the instance is *not an orphan*, then module X defines C, T, or W. - And in order for those types to be involved in typechecking M, it - must be that X is in the transitive closure of M's imports. So we - can use the instance. - - * If the instance *is an orphan*, the above reasoning does not apply. - So we keep track of the set of orphan modules transitively below M; - this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. - - If module p:X is in this set, then we can use the instance, otherwise - we can't. - -Note [Rules for instance lookup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These functions implement the carefully-written rules in the user -manual section on "overlapping instances". At risk of duplication, -here are the rules. If the rules change, change this text and the -user manual simultaneously. The link may be this: -http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap - -The willingness to be overlapped or incoherent is a property of the -instance declaration itself, controlled as follows: - - * An instance is "incoherent" - if it has an INCOHERENT pragma, or - if it appears in a module compiled with -XIncoherentInstances. - - * An instance is "overlappable" - if it has an OVERLAPPABLE or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or - if the instance is incoherent. - - * An instance is "overlapping" - if it has an OVERLAPPING or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or - if the instance is incoherent. - compiled with -XOverlappingInstances. - -Now suppose that, in some client module, we are searching for an instance -of the target constraint (C ty1 .. tyn). The search works like this. - -* Find all instances `I` that *match* the target constraint; that is, the - target constraint is a substitution instance of `I`. These instance - declarations are the *candidates*. - -* Eliminate any candidate `IX` for which both of the following hold: - - - There is another candidate `IY` that is strictly more specific; that - is, `IY` is a substitution instance of `IX` but not vice versa. - - - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This - "either/or" design, rather than a "both/and" design, allow a - client to deliberately override an instance from a library, - without requiring a change to the library.) - -- If exactly one non-incoherent candidate remains, select it. If all - remaining candidates are incoherent, select an arbitrary one. - Otherwise the search fails (i.e. when more than one surviving - candidate is not incoherent). - -- If the selected candidate (from the previous step) is incoherent, the - search succeeds, returning that candidate. - -- If not, find all instances that *unify* with the target constraint, - but do not *match* it. Such non-candidate instances might match when - the target constraint is further instantiated. If all of them are - incoherent, the search succeeds, returning the selected candidate; if - not, the search fails. - -Notice that these rules are not influenced by flag settings in the -client module, where the instances are *used*. These rules make it -possible for a library author to design a library that relies on -overlapping instances without the client having to know. - -Note [Overlapping instances] (NB: these notes are quite old) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Overlap is permitted, but only in such a way that one can make -a unique choice when looking up. That is, overlap is only permitted if -one template matches the other, or vice versa. So this is ok: - - [a] [Int] - -but this is not - - (Int,a) (b,Int) - -If overlap is permitted, the list is kept most specific first, so that -the first lookup is the right choice. - - -For now we just use association lists. - -\subsection{Avoiding a problem with overlapping} - -Consider this little program: - -\begin{pseudocode} - class C a where c :: a - class C a => D a where d :: a - - instance C Int where c = 17 - instance D Int where d = 13 - - instance C a => C [a] where c = [c] - instance ({- C [a], -} D a) => D [a] where d = c - - instance C [Int] where c = [37] - - main = print (d :: [Int]) -\end{pseudocode} - -What do you think `main' prints (assuming we have overlapping instances, and -all that turned on)? Well, the instance for `D' at type `[a]' is defined to -be `c' at the same type, and we've got an instance of `C' at `[Int]', so the -answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because -the `C [Int]' instance is more specific). - -Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That -was easy ;-) Let's just consult hugs for good measure. Wait - if I use old -hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it -doesn't even compile! What's going on!? - -What hugs complains about is the `D [a]' instance decl. - -\begin{pseudocode} - ERROR "mj.hs" (line 10): Cannot build superclass instance - *** Instance : D [a] - *** Context supplied : D a - *** Required superclass : C [a] -\end{pseudocode} - -You might wonder what hugs is complaining about. It's saying that you -need to add `C [a]' to the context of the `D [a]' instance (as appears -in comments). But there's that `C [a]' instance decl one line above -that says that I can reduce the need for a `C [a]' instance to the -need for a `C a' instance, and in this case, I already have the -necessary `C a' instance (since we have `D a' explicitly in the -context, and `C' is a superclass of `D'). - -Unfortunately, the above reasoning indicates a premature commitment to the -generic `C [a]' instance. I.e., it prematurely rules out the more specific -instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to -add the context that hugs suggests (uncomment the `C [a]'), effectively -deferring the decision about which instance to use. - -Now, interestingly enough, 4.04 has this same bug, but it's covered up -in this case by a little known `optimization' that was disabled in -4.06. Ghc-4.04 silently inserts any missing superclass context into -an instance declaration. In this case, it silently inserts the `C -[a]', and everything happens to work out. - -(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for -`Mark Jones', although Mark claims no credit for the `optimization' in -question, and would rather it stopped being called the `Mark Jones -optimization' ;-) - -So, what's the fix? I think hugs has it right. Here's why. Let's try -something else out with ghc-4.04. Let's add the following line: - - d' :: D a => [a] - d' = c - -Everyone raise their hand who thinks that `d :: [Int]' should give a -different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The -`optimization' only applies to instance decls, not to regular -bindings, giving inconsistent behavior. - -Old hugs had this same bug. Here's how we fixed it: like GHC, the -list of instances for a given class is ordered, so that more specific -instances come before more generic ones. For example, the instance -list for C might contain: - ..., C Int, ..., C a, ... -When we go to look for a `C Int' instance we'll get that one first. -But what if we go looking for a `C b' (`b' is unconstrained)? We'll -pass the `C Int' instance, and keep going. But if `b' is -unconstrained, then we don't know yet if the more specific instance -will eventually apply. GHC keeps going, and matches on the generic `C -a'. The fix is to, at each step, check to see if there's a reverse -match, and if so, abort the search. This prevents hugs from -prematurely chosing a generic instance when a more specific one -exists. - ---Jeff - -BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in -this test. Suppose the instance envt had - ..., forall a b. C a a b, ..., forall a b c. C a b c, ... -(still most specific first) -Now suppose we are looking for (C x y Int), where x and y are unconstrained. - C x y Int doesn't match the template {a,b} C a a b -but neither does - C a a b match the template {x,y} C x y Int -But still x and y might subsequently be unified so they *do* match. - -Simple story: unify, don't match. --} - -type DFunInstType = Maybe Type - -- Just ty => Instantiate with this type - -- Nothing => Instantiate with any type of this tyvar's kind - -- See Note [DFunInstType: instantiating types] - -type InstMatch = (ClsInst, [DFunInstType]) - -type ClsInstLookupResult - = ( [InstMatch] -- Successful matches - , [ClsInst] -- These don't match but do unify - , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell - -- (see Note [Safe Haskell Overlapping Instances] in - -- TcSimplify). - -{- -Note [DFunInstType: instantiating types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A successful match is a ClsInst, together with the types at which - the dfun_id in the ClsInst should be instantiated -The instantiating types are (Either TyVar Type)s because the dfun -might have some tyvars that *only* appear in arguments - dfun :: forall a b. C a b, Ord b => D [a] -When we match this against D [ty], we return the instantiating types - [Just ty, Nothing] -where the 'Nothing' indicates that 'b' can be freely instantiated. -(The caller instantiates it to a flexi type variable, which will - presumably later become fixed via functional dependencies.) --} - --- |Look up an instance in the given instance environment. The given class application must match exactly --- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, --- yield 'Left errorMessage'. -lookupUniqueInstEnv :: InstEnvs - -> Class -> [Type] - -> Either MsgDoc (ClsInst, [Type]) -lookupUniqueInstEnv instEnv cls tys - = case lookupInstEnv False instEnv cls tys of - ([(inst, inst_tys)], _, _) - | noFlexiVar -> Right (inst, inst_tys') - | otherwise -> Left $ text "flexible type variable:" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) - where - inst_tys' = [ty | Just ty <- inst_tys] - noFlexiVar = all isJust inst_tys - _other -> Left $ text "instance not found" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) - -lookupInstEnv' :: InstEnv -- InstEnv to look in - -> VisibleOrphanModules -- But filter against this - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - [ClsInst]) -- These don't match but do unify - -- (no incoherent ones in here) --- The second component of the result pair happens when we look up --- Foo [a] --- in an InstEnv that has entries for --- Foo [Int] --- Foo [b] --- Then which we choose would depend on the way in which 'a' --- is instantiated. So we report that Foo [b] is a match (mapping b->a) --- but Foo [Int] is a unifier. This gives the caller a better chance of --- giving a suitable error message - -lookupInstEnv' ie vis_mods cls tys - = lookup ie - where - rough_tcs = roughMatchTcs tys - all_tvs = all isNothing rough_tcs - - -------------- - lookup env = case lookupUDFM env cls of - Nothing -> ([],[]) -- No instances for this class - Just (ClsIE insts) -> find [] [] insts - - -------------- - find ms us [] = (ms, us) - find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs - , is_tys = tpl_tys }) : rest) - | not (instIsVisible vis_mods item) - = find ms us rest -- See Note [Instance lookup and orphan instances] - - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = find ms us rest - - | Just subst <- tcMatchTys tpl_tys tys - = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest - - -- Does not match, so next check whether the things unify - -- See Note [Overlapping instances] - -- Ignore ones that are incoherent: Note [Incoherent instances] - | isIncoherent item - = find ms us rest - - | otherwise - = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, - (ppr cls <+> ppr tys <+> ppr all_tvs) $$ - (ppr tpl_tvs <+> ppr tpl_tys) - ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - -- See Note [Template tyvars are fresh] - case tcUnifyTys instanceBindFun tpl_tys tys of - Just _ -> find ms (item:us) rest - Nothing -> find ms us rest - where - tpl_tv_set = mkVarSet tpl_tvs - ---------------- --- This is the common way to call this function. -lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions - -> InstEnvs -- External and home package inst-env - -> Class -> [Type] -- What we are looking for - -> ClsInstLookupResult --- ^ See Note [Rules for instance lookup] --- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify --- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -lookupInstEnv check_overlap_safe - (InstEnvs { ie_global = pkg_ie - , ie_local = home_ie - , ie_visible = vis_mods }) - cls - tys - = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ - (final_matches, final_unifs, unsafe_overlapped) - where - (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys - (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys - all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs ++ pkg_unifs - final_matches = foldr insert_overlapping [] all_matches - -- Even if the unifs is non-empty (an error situation) - -- we still prune the matches, so that the error message isn't - -- misleading (complaining of multiple matches when some should be - -- overlapped away) - - unsafe_overlapped - = case final_matches of - [match] -> check_safe match - _ -> [] - - -- If the selected match is incoherent, discard all unifiers - final_unifs = case final_matches of - (m:_) | isIncoherent (fst m) -> [] - _ -> all_unifs - - -- NOTE [Safe Haskell isSafeOverlap] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- We restrict code compiled in 'Safe' mode from overriding code - -- compiled in any other mode. The rationale is that code compiled - -- in 'Safe' mode is code that is untrusted by the ghc user. So - -- we shouldn't let that code change the behaviour of code the - -- user didn't compile in 'Safe' mode since that's the code they - -- trust. So 'Safe' instances can only overlap instances from the - -- same module. A same instance origin policy for safe compiled - -- instances. - check_safe (inst,_) - = case check_overlap_safe && unsafeTopInstance inst of - -- make sure it only overlaps instances from the same module - True -> go [] all_matches - -- most specific is from a trusted location. - False -> [] - where - go bad [] = bad - go bad (i@(x,_):unchecked) = - if inSameMod x || isOverlappable x - then go bad unchecked - else go (i:bad) unchecked - - inSameMod b = - let na = getName $ getName inst - la = isInternalName na - nb = getName $ getName b - lb = isInternalName nb - in (la && lb) || (nameModule na == nameModule nb) - - -- We consider the most specific instance unsafe when it both: - -- (1) Comes from a module compiled as `Safe` - -- (2) Is an orphan instance, OR, an instance for a MPTC - unsafeTopInstance inst = isSafeOverlap (is_flag inst) && - (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) - ---------------- -insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] --- ^ Add a new solution, knocking out strictly less specific ones --- See Note [Rules for instance lookup] -insert_overlapping new_item [] = [new_item] -insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) - | new_beats_old -- New strictly overrides old - , not old_beats_new - , new_inst `can_override` old_inst - = insert_overlapping new_item old_items - - | old_beats_new -- Old strictly overrides new - , not new_beats_old - , old_inst `can_override` new_inst - = old_item : old_items - - -- Discard incoherent instances; see Note [Incoherent instances] - | isIncoherent old_inst -- Old is incoherent; discard it - = insert_overlapping new_item old_items - | isIncoherent new_inst -- New is incoherent; discard it - = old_item : old_items - - -- Equal or incomparable, and neither is incoherent; keep both - | otherwise - = old_item : insert_overlapping new_item old_items - where - - new_beats_old = new_inst `more_specific_than` old_inst - old_beats_new = old_inst `more_specific_than` new_inst - - -- `instB` can be instantiated to match `instA` - -- or the two are equal - instA `more_specific_than` instB - = isJust (tcMatchTys (is_tys instB) (is_tys instA)) - - instA `can_override` instB - = isOverlapping instA || isOverlappable instB - -- Overlap permitted if either the more specific instance - -- is marked as overlapping, or the more general one is - -- marked as overlappable. - -- Latest change described in: #9242. - -- Previous change: #3877, Dec 10. - -{- -Note [Incoherent instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For some classes, the choice of a particular instance does not matter, any one -is good. E.g. consider - - class D a b where { opD :: a -> b -> String } - instance D Int b where ... - instance D a Int where ... - - g (x::Int) = opD x x -- Wanted: D Int Int - -For such classes this should work (without having to add an "instance D Int -Int", and using -XOverlappingInstances, which would then work). This is what --XIncoherentInstances is for: Telling GHC "I don't care which instance you use; -if you can use one, use it." - -Should this logic only work when *all* candidates have the incoherent flag, or -even when all but one have it? The right choice is the latter, which can be -justified by comparing the behaviour with how -XIncoherentInstances worked when -it was only about the unify-check (note [Overlapping instances]): - -Example: - class C a b c where foo :: (a,b,c) - instance C [a] b Int - instance [incoherent] [Int] b c - instance [incoherent] C a Int c -Thanks to the incoherent flags, - [Wanted] C [a] b Int -works: Only instance one matches, the others just unify, but are marked -incoherent. - -So I can write - (foo :: ([a],b,Int)) :: ([Int], Int, Int). -but if that works then I really want to be able to write - foo :: ([Int], Int, Int) -as well. Now all three instances from above match. None is more specific than -another, so none is ruled out by the normal overlapping rules. One of them is -not incoherent, but we still want this to compile. Hence the -"all-but-one-logic". - -The implementation is in insert_overlapping, where we remove matching -incoherent instances as long as there are others. - - - -************************************************************************ -* * - Binding decisions -* * -************************************************************************ --} - -instanceBindFun :: TyCoVar -> BindFlag -instanceBindFun tv | isOverlappableTyVar tv = Skolem - | otherwise = BindMe - -- Note [Binding when looking up instances] - -{- -Note [Binding when looking up instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When looking up in the instance environment, or family-instance environment, -we are careful about multiple matches, as described above in -Note [Overlapping instances] - -The key_tys can contain skolem constants, and we can guarantee that those -are never going to be instantiated to anything, so we should not involve -them in the unification test. Example: - class Foo a where { op :: a -> Int } - instance Foo a => Foo [a] -- NB overlap - instance Foo [Int] -- NB overlap - data T = forall a. Foo a => MkT a - f :: T -> Int - f (MkT x) = op [x,x] -The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd -complain, saying that the choice of instance depended on the instantiation -of 'a'; but of course it isn't *going* to be instantiated. - -We do this only for isOverlappableTyVar skolems. For example we reject - g :: forall a => [a] -> Int - g x = op x -on the grounds that the correct instance depends on the instantiation of 'a' --} diff --git a/types/OptCoercion.hs b/types/OptCoercion.hs deleted file mode 100644 --- a/types/OptCoercion.hs +++ /dev/null @@ -1,1205 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP #-} - -module OptCoercion ( optCoercion, checkAxInstCo ) where - -#include "HsVersions.h" - -import GhcPrelude - -import DynFlags -import TyCoRep -import TyCoSubst -import Coercion -import Type hiding( substTyVarBndr, substTy ) -import TcType ( exactTyCoVarsOfType ) -import TyCon -import CoAxiom -import VarSet -import VarEnv -import Outputable -import FamInstEnv ( flattenTys ) -import Pair -import ListSetOps ( getNth ) -import Util -import Unify -import InstEnv -import Control.Monad ( zipWithM ) - -{- -%************************************************************************ -%* * - Optimising coercions -%* * -%************************************************************************ - -Note [Optimising coercion optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Looking up a coercion's role or kind is linear in the size of the -coercion. Thus, doing this repeatedly during the recursive descent -of coercion optimisation is disastrous. We must be careful to avoid -doing this if at all possible. - -Because it is generally easy to know a coercion's components' roles -from the role of the outer coercion, we pass down the known role of -the input in the algorithm below. We also keep functions opt_co2 -and opt_co3 separate from opt_co4, so that the former two do Phantom -checks that opt_co4 can avoid. This is a big win because Phantom coercions -rarely appear within non-phantom coercions -- only in some TyConAppCos -and some AxiomInstCos. We handle these cases specially by calling -opt_co2. - -Note [Optimising InstCo] -~~~~~~~~~~~~~~~~~~~~~~~~ -(1) tv is a type variable -When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. - -Let's look at the typing rules. - -h : k1 ~ k2 -tv:k1 |- g : t1 ~ t2 ------------------------------ -ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) - -g1 : (all tv:k1.t1') ~ (all tv:k2.t2') -g2 : s1 ~ s2 --------------------- -InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] - -We thus want some coercion proving this: - - (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) - -If we substitute the *type* tv for the *coercion* -(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. -This is bizarre, -though, because we're substituting a type variable with a coercion. However, -this operation already exists: it's called *lifting*, and defined in Coercion. -We just need to enhance the lifting operation to be able to deal with -an ambient substitution, which is why a LiftingContext stores a TCvSubst. - -(2) cv is a coercion variable -Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. - -h : (t1 ~r t2) ~N (t3 ~r t4) -cv : t1 ~r t2 |- g : t1' ~r2 t2' -n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 -n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 ------------------------------------------------- -ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 - (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) - -g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') -g2 : h1 ~N h2 -h1 : t1 ~r t2 -h2 : t3 ~r t4 ------------------------------------------------- -InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] - -We thus want some coercion proving this: - - t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] - -So we substitute the coercion variable c for the coercion -(h1 ~N (n1; h2; sym n2)) in g. --} - -optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo --- ^ optCoercion applies a substitution to a coercion, --- *and* optimises it to reduce its size -optCoercion dflags env co - | hasNoOptCoercion dflags = substCo env co - | otherwise = optCoercion' env co - -optCoercion' :: TCvSubst -> Coercion -> NormalCo -optCoercion' env co - | debugIsOn - = let out_co = opt_co1 lc False co - (Pair in_ty1 in_ty2, in_role) = coercionKindRole co - (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co - in - ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 && - substTyUnchecked env in_ty2 `eqType` out_ty2 && - in_role == out_role - , text "optCoercion changed types!" - $$ hang (text "in_co:") 2 (ppr co) - $$ hang (text "in_ty1:") 2 (ppr in_ty1) - $$ hang (text "in_ty2:") 2 (ppr in_ty2) - $$ hang (text "out_co:") 2 (ppr out_co) - $$ hang (text "out_ty1:") 2 (ppr out_ty1) - $$ hang (text "out_ty2:") 2 (ppr out_ty2) - $$ hang (text "subst:") 2 (ppr env) ) - out_co - - | otherwise = opt_co1 lc False co - where - lc = mkSubstLiftingContext env - -type NormalCo = Coercion - -- Invariants: - -- * The substitution has been fully applied - -- * For trans coercions (co1 `trans` co2) - -- co1 is not a trans, and neither co1 nor co2 is identity - -type NormalNonIdCo = NormalCo -- Extra invariant: not the identity - --- | Do we apply a @sym@ to the result? -type SymFlag = Bool - --- | Do we force the result to be representational? -type ReprFlag = Bool - --- | Optimize a coercion, making no assumptions. All coercions in --- the lifting context are already optimized (and sym'd if nec'y) -opt_co1 :: LiftingContext - -> SymFlag - -> Coercion -> NormalCo -opt_co1 env sym co = opt_co2 env sym (coercionRole co) co - --- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's role. No other assumptions. -opt_co2 :: LiftingContext - -> SymFlag - -> Role -- ^ The role of the input coercion - -> Coercion -> NormalCo -opt_co2 env sym Phantom co = opt_phantom env sym co -opt_co2 env sym r co = opt_co3 env sym Nothing r co - --- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's non-Phantom role. -opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo -opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co -opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co - -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore -opt_co3 env sym _ r co = opt_co4_wrap env sym False r co - --- See Note [Optimising coercion optimisation] --- | Optimize a non-phantom coercion. -opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo - -opt_co4_wrap = opt_co4 -{- -opt_co4_wrap env sym rep r co - = pprTrace "opt_co4_wrap {" - ( vcat [ text "Sym:" <+> ppr sym - , text "Rep:" <+> ppr rep - , text "Role:" <+> ppr r - , text "Co:" <+> ppr co ]) $ - ASSERT( r == coercionRole co ) - let result = opt_co4 env sym rep r co in - pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ - result --} - -opt_co4 env _ rep r (Refl ty) - = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ - text "Found role:" <+> ppr Nominal $$ - text "Type:" <+> ppr ty ) - liftCoSubst (chooseRole rep r) env ty - -opt_co4 env _ rep r (GRefl _r ty MRefl) - = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ - text "Found role:" <+> ppr _r $$ - text "Type:" <+> ppr ty ) - liftCoSubst (chooseRole rep r) env ty - -opt_co4 env sym rep r (GRefl _r ty (MCo co)) - = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ - text "Found role:" <+> ppr _r $$ - text "Type:" <+> ppr ty ) - if isGReflCo co || isGReflCo co' - then liftCoSubst r' env ty - else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) - where - r' = chooseRole rep r - ty' = substTy (lcSubstLeft env) ty - co' = opt_co4 env False False Nominal co - -opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co - -- surprisingly, we don't have to do anything to the env here. This is - -- because any "lifting" substitutions in the env are tied to ForAllCos, - -- which treat their left and right sides differently. We don't want to - -- exchange them. - -opt_co4 env sym rep r g@(TyConAppCo _r tc cos) - = ASSERT( r == _r ) - case (rep, r) of - (True, Nominal) -> - mkTyConAppCo Representational tc - (zipWith3 (opt_co3 env sym) - (map Just (tyConRolesRepresentational tc)) - (repeat Nominal) - cos) - (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) - (_, Representational) -> - -- must use opt_co2 here, because some roles may be P - -- See Note [Optimising coercion optimisation] - mkTyConAppCo r tc (zipWith (opt_co2 env sym) - (tyConRolesRepresentational tc) -- the current roles - cos) - (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) - -opt_co4 env sym rep r (AppCo co1 co2) - = mkAppCo (opt_co4_wrap env sym rep r co1) - (opt_co4_wrap env sym False Nominal co2) - -opt_co4 env sym rep r (ForAllCo tv k_co co) - = case optForAllCoBndr env sym tv k_co of - (env', tv', k_co') -> mkForAllCo tv' k_co' $ - opt_co4_wrap env' sym rep r co - -- Use the "mk" functions to check for nested Refls - -opt_co4 env sym rep r (FunCo _r co1 co2) - = ASSERT( r == _r ) - if rep - then mkFunCo Representational co1' co2' - else mkFunCo r co1' co2' - where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 - -opt_co4 env sym rep r (CoVarCo cv) - | Just co <- lookupCoVar (lcTCvSubst env) cv - = opt_co4_wrap (zapLiftingContext env) sym rep r co - - | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] - = mkReflCo (chooseRole rep r) ty1 - - | otherwise - = ASSERT( isCoVar cv1 ) - wrapRole rep r $ wrapSym sym $ - CoVarCo cv1 - - where - Pair ty1 ty2 = coVarTypes cv1 - - cv1 = case lookupInScope (lcInScopeSet env) cv of - Just cv1 -> cv1 - Nothing -> WARN( True, text "opt_co: not in scope:" - <+> ppr cv $$ ppr env) - cv - -- cv1 might have a substituted kind! - -opt_co4 _ _ _ _ (HoleCo h) - = pprPanic "opt_univ fell into a hole" (ppr h) - -opt_co4 env sym rep r (AxiomInstCo con ind cos) - -- Do *not* push sym inside top-level axioms - -- e.g. if g is a top-level axiom - -- g a : f a ~ a - -- then (sym (g ty)) /= g (sym ty) !! - = ASSERT( r == coAxiomRole con ) - wrapRole rep (coAxiomRole con) $ - wrapSym sym $ - -- some sub-cos might be P: use opt_co2 - -- See Note [Optimising coercion optimisation] - AxiomInstCo con ind (zipWith (opt_co2 env False) - (coAxBranchRoles (coAxiomNthBranch con ind)) - cos) - -- Note that the_co does *not* have sym pushed into it - -opt_co4 env sym rep r (UnivCo prov _r t1 t2) - = ASSERT( r == _r ) - opt_univ env sym prov (chooseRole rep r) t1 t2 - -opt_co4 env sym rep r (TransCo co1 co2) - -- sym (g `o` h) = sym h `o` sym g - | sym = opt_trans in_scope co2' co1' - | otherwise = opt_trans in_scope co1' co2' - where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 - in_scope = lcInScopeSet env - -opt_co4 env _sym rep r (NthCo _r n co) - | Just (ty, _) <- isReflCo_maybe co - , Just (_tc, args) <- ASSERT( r == _r ) - splitTyConApp_maybe ty - = liftCoSubst (chooseRole rep r) env (args `getNth` n) - | Just (ty, _) <- isReflCo_maybe co - , n == 0 - , Just (tv, _) <- splitForAllTy_maybe ty - -- works for both tyvar and covar - = liftCoSubst (chooseRole rep r) env (varType tv) - -opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) - = ASSERT( r == r1 ) - opt_co4_wrap env sym rep r (cos `getNth` n) - -opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) - -- works for both tyvar and covar - = ASSERT( r == _r ) - ASSERT( n == 0 ) - opt_co4_wrap env sym rep Nominal eta - -opt_co4 env sym rep r (NthCo _r n co) - | TyConAppCo _ _ cos <- co' - , let nth_co = cos `getNth` n - = if rep && (r == Nominal) - -- keep propagating the SubCo - then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co - else nth_co - - | ForAllCo _ eta _ <- co' - = if rep - then opt_co4_wrap (zapLiftingContext env) False True Nominal eta - else eta - - | otherwise - = wrapRole rep r $ NthCo r n co' - where - co' = opt_co1 env sym co - -opt_co4 env sym rep r (LRCo lr co) - | Just pr_co <- splitAppCo_maybe co - = ASSERT( r == Nominal ) - opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) - | Just pr_co <- splitAppCo_maybe co' - = ASSERT( r == Nominal ) - if rep - then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) - else pick_lr lr pr_co - | otherwise - = wrapRole rep Nominal $ LRCo lr co' - where - co' = opt_co4_wrap env sym False Nominal co - - pick_lr CLeft (l, _) = l - pick_lr CRight (_, r) = r - --- See Note [Optimising InstCo] -opt_co4 env sym rep r (InstCo co1 arg) - -- forall over type... - | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 - = opt_co4_wrap (extendLiftingContext env tv - (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) - -- mkSymCo kind_co :: k1 ~ k2 - -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) - -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) - sym rep r co_body - - -- forall over coercion... - | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 - , CoercionTy h1 <- t1 - , CoercionTy h2 <- t2 - = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 - in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body - - -- See if it is a forall after optimization - -- If so, do an inefficient one-variable substitution, then re-optimize - - -- forall over type... - | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' - = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' - (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) - False False r' co_body' - - -- forall over coercion... - | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' - , CoercionTy h1' <- t1' - , CoercionTy h2' <- t2' - = let new_co = mk_new_co cv' kind_co' h1' h2' - in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) - False False r' co_body' - - | otherwise = InstCo co1' arg' - where - co1' = opt_co4_wrap env sym rep r co1 - r' = chooseRole rep r - arg' = opt_co4_wrap env sym False Nominal arg - sym_arg = wrapSym sym arg' - - -- Performance note: don't be alarmed by the two calls to coercionKind - -- here, as only one call to coercionKind is actually demanded per guard. - -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used - -- when checking if co1' (i.e., co1 post-optimization) is a forall. - -- - -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' - -- might have an extra Sym at the front (after being optimized) that co1 - -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) - Pair t1 t2 = coercionKind sym_arg - Pair t1' t2' = coercionKind arg' - - mk_new_co cv kind_co h1 h2 - = let -- h1 :: (t1 ~ t2) - -- h2 :: (t3 ~ t4) - -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) - -- n1 :: t1 ~ t3 - -- n2 :: t2 ~ t4 - -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) - r2 = coVarRole cv - kind_co' = downgradeRole r2 Nominal kind_co - n1 = mkNthCo r2 2 kind_co' - n2 = mkNthCo r2 3 kind_co' - in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 - (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) - -opt_co4 env sym _rep r (KindCo co) - = ASSERT( r == Nominal ) - let kco' = promoteCoercion co in - case kco' of - KindCo co' -> promoteCoercion (opt_co1 env sym co') - _ -> opt_co4_wrap env sym False Nominal kco' - -- This might be able to be optimized more to do the promotion - -- and substitution/optimization at the same time - -opt_co4 env sym _ r (SubCo co) - = ASSERT( r == Representational ) - opt_co4_wrap env sym True Nominal co - --- This could perhaps be optimized more. -opt_co4 env sym rep r (AxiomRuleCo co cs) - = ASSERT( r == coaxrRole co ) - wrapRole rep r $ - wrapSym sym $ - AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) - -{- Note [Optimise CoVarCo to Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have (c :: t~t) we can optimise it to Refl. That increases the -chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) - -We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] -in Coercion. --} - -------------- --- | Optimize a phantom coercion. The input coercion may not necessarily --- be a phantom, but the output sure will be. -opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo -opt_phantom env sym co - = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 - where - Pair ty1 ty2 = coercionKind co - -{- Note [Differing kinds] - ~~~~~~~~~~~~~~~~~~~~~~ -The two types may not have the same kind (although that would be very unusual). -But even if they have the same kind, and the same type constructor, the number -of arguments in a `CoTyConApp` can differ. Consider - - Any :: forall k. k - - Any * Int :: * - Any (*->*) Maybe Int :: * - -Hence the need to compare argument lengths; see #13658 - -} - -opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role - -> Type -> Type -> Coercion -opt_univ env sym (PhantomProv h) _r ty1 ty2 - | sym = mkPhantomCo h' ty2' ty1' - | otherwise = mkPhantomCo h' ty1' ty2' - where - h' = opt_co4 env sym False Nominal h - ty1' = substTy (lcSubstLeft env) ty1 - ty2' = substTy (lcSubstRight env) ty2 - -opt_univ env sym prov role oty1 oty2 - | Just (tc1, tys1) <- splitTyConApp_maybe oty1 - , Just (tc2, tys2) <- splitTyConApp_maybe oty2 - , tc1 == tc2 - , equalLength tys1 tys2 -- see Note [Differing kinds] - -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); - -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps - = let roles = tyConRolesX role tc1 - arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 - arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos - in - mkTyConAppCo role tc1 arg_cos' - - -- can't optimize the AppTy case because we can't build the kind coercions. - - | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 - , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 - -- NB: prov isn't interesting here either - = let k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - eta = mkUnivCo prov' Nominal k1 k2 - -- eta gets opt'ed soon, but not yet. - ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 - - (env', tv1', eta') = optForAllCoBndr env sym tv1 eta - in - mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') - - | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 - , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 - -- NB: prov isn't interesting here either - = let k1 = varType cv1 - k2 = varType cv2 - r' = coVarRole cv1 - eta = mkUnivCo prov' Nominal k1 k2 - eta_d = downgradeRole r' Nominal eta - -- eta gets opt'ed soon, but not yet. - n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` - (mkCoVarCo cv1) `mkTransCo` - (mkNthCo r' 3 eta_d) - ty2' = substTyWithCoVars [cv2] [n_co] ty2 - - (env', cv1', eta') = optForAllCoBndr env sym cv1 eta - in - mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') - - | otherwise - = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 - ty2 = substTyUnchecked (lcSubstRight env) oty2 - (a, b) | sym = (ty2, ty1) - | otherwise = (ty1, ty2) - in - mkUnivCo prov' role a b - - where - prov' = case prov of - UnsafeCoerceProv -> prov - PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco - ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco - PluginProv _ -> prov - -------------- -opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList is = zipWith (opt_trans is) - -opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo -opt_trans is co1 co2 - | isReflCo co1 = co2 - -- optimize when co1 is a Refl Co - | otherwise = opt_trans1 is co1 co2 - -opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo --- First arg is not the identity -opt_trans1 is co1 co2 - | isReflCo co2 = co1 - -- optimize when co2 is a Refl Co - | otherwise = opt_trans2 is co1 co2 - -opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo --- Neither arg is the identity -opt_trans2 is (TransCo co1a co1b) co2 - -- Don't know whether the sub-coercions are the identity - = opt_trans is co1a (opt_trans is co1b co2) - -opt_trans2 is co1 co2 - | Just co <- opt_trans_rule is co1 co2 - = co - -opt_trans2 is co1 (TransCo co2a co2b) - | Just co1_2a <- opt_trans_rule is co1 co2a - = if isReflCo co1_2a - then co2b - else opt_trans1 is co1_2a co2b - -opt_trans2 _ co1 co2 - = mkTransCo co1 co2 - ------- --- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo - -opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) - = ASSERT( r1 == r2 ) - fireTransRule "GRefl" in_co1 in_co2 $ - mkGReflRightCo r1 t1 (opt_trans is co1 co2) - --- Push transitivity through matching destructors -opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) - | d1 == d2 - , coercionRole co1 == coercionRole co2 - , co1 `compatible_co` co2 - = ASSERT( r1 == r2 ) - fireTransRule "PushNth" in_co1 in_co2 $ - mkNthCo r1 d1 (opt_trans is co1 co2) - -opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) - | d1 == d2 - , co1 `compatible_co` co2 - = fireTransRule "PushLR" in_co1 in_co2 $ - mkLRCo d1 (opt_trans is co1 co2) - --- Push transitivity inside instantiation -opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) - | ty1 `eqCoercion` ty2 - , co1 `compatible_co` co2 - = fireTransRule "TrPushInst" in_co1 in_co2 $ - mkInstCo (opt_trans is co1 co2) ty1 - -opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) - in_co2@(UnivCo p2 r2 _tyl2 tyr2) - | Just prov' <- opt_trans_prov p1 p2 - = ASSERT( r1 == r2 ) - fireTransRule "UnivCo" in_co1 in_co2 $ - mkUnivCo prov' r1 tyl1 tyr2 - where - -- if the provenances are different, opt'ing will be very confusing - opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv - opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) - = Just $ PhantomProv $ opt_trans is kco1 kco2 - opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) - = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 - opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 - opt_trans_prov _ _ = Nothing - --- Push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) - | tc1 == tc2 - = ASSERT( r1 == r2 ) - fireTransRule "PushTyConApp" in_co1 in_co2 $ - mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) - -opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b) - = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case - fireTransRule "PushFun" in_co1 in_co2 $ - mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b) - -opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) - -- Must call opt_trans_rule_app; see Note [EtaAppCo] - = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] - --- Eta rules -opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 - | Just cos2 <- etaTyConAppCo_maybe tc co2 - = ASSERT( cos1 `equalLength` cos2 ) - fireTransRule "EtaCompL" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) - | Just cos1 <- etaTyConAppCo_maybe tc co1 - = ASSERT( cos1 `equalLength` cos2 ) - fireTransRule "EtaCompR" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1@(AppCo co1a co1b) co2 - | Just (co2a,co2b) <- etaAppCo_maybe co2 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] - -opt_trans_rule is co1 co2@(AppCo co2a co2b) - | Just (co1a,co1b) <- etaAppCo_maybe co1 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] - --- Push transitivity inside forall --- forall over types. -opt_trans_rule is co1 co2 - | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 - , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 - = push_trans tv1 eta1 r1 tv2 eta2 r2 - - | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 - , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 - = push_trans tv1 eta1 r1 tv2 eta2 r2 - - where - push_trans tv1 eta1 r1 tv2 eta2 r2 - -- Given: - -- co1 = /\ tv1 : eta1. r1 - -- co2 = /\ tv2 : eta2. r2 - -- Wanted: - -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) - = fireTransRule "EtaAllTy_ty" co1 co2 $ - mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') - where - is' = is `extendInScopeSet` tv1 - r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 - --- Push transitivity inside forall --- forall over coercions. -opt_trans_rule is co1 co2 - | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 - , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 - = push_trans cv1 eta1 r1 cv2 eta2 r2 - - | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 - , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 - = push_trans cv1 eta1 r1 cv2 eta2 r2 - - where - push_trans cv1 eta1 r1 cv2 eta2 r2 - -- Given: - -- co1 = /\ cv1 : eta1. r1 - -- co2 = /\ cv2 : eta2. r2 - -- Wanted: - -- n1 = nth 2 eta1 - -- n2 = nth 3 eta1 - -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) - = fireTransRule "EtaAllTy_co" co1 co2 $ - mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') - where - is' = is `extendInScopeSet` cv1 - role = coVarRole cv1 - eta1' = downgradeRole role Nominal eta1 - n1 = mkNthCo role 2 eta1' - n2 = mkNthCo role 3 eta1' - r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` - (mkCoVarCo cv1) `mkTransCo` n2]) - r2 - --- Push transitivity inside axioms -opt_trans_rule is co1 co2 - - -- See Note [Why call checkAxInstCo during optimisation] - -- TrPushSymAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , True <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst - - -- TrPushAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , False <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushAxR" co1 co2 newAxInst - - -- TrPushSymAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , True <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst - - -- TrPushAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , False <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushAxL" co1 co2 newAxInst - - -- TrPushAxSym/TrPushSymAx - | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe - , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe - , con1 == con2 - , ind1 == ind2 - , sym1 == not sym2 - , let branch = coAxiomNthBranch con1 ind1 - qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch - lhs = coAxNthLHS con1 ind1 - rhs = coAxBranchRHS branch - pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) - , all (`elemVarSet` pivot_tvs) qtvs - = fireTransRule "TrPushAxSym" co1 co2 $ - if sym2 - -- TrPushAxSym - then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs - -- TrPushSymAx - else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs - where - co1_is_axiom_maybe = isAxiom_maybe co1 - co2_is_axiom_maybe = isAxiom_maybe co2 - role = coercionRole co1 -- should be the same as coercionRole co2! - -opt_trans_rule _ co1 co2 -- Identity rule - | (Pair ty1 _, r) <- coercionKindRole co1 - , Pair _ ty2 <- coercionKind co2 - , ty1 `eqType` ty2 - = fireTransRule "RedTypeDirRefl" co1 co2 $ - mkReflCo r ty2 - -opt_trans_rule _ _ _ = Nothing - --- See Note [EtaAppCo] -opt_trans_rule_app :: InScopeSet - -> Coercion -- original left-hand coercion (printing only) - -> Coercion -- original right-hand coercion (printing only) - -> Coercion -- left-hand coercion "function" - -> [Coercion] -- left-hand coercion "args" - -> Coercion -- right-hand coercion "function" - -> [Coercion] -- right-hand coercion "args" - -> Maybe Coercion -opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs - | AppCo co1aa co1ab <- co1a - , Just (co2aa, co2ab) <- etaAppCo_maybe co2a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) - - | AppCo co2aa co2ab <- co2a - , Just (co1aa, co1ab) <- etaAppCo_maybe co1a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) - - | otherwise - = ASSERT( co1bs `equalLength` co2bs ) - fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ - let Pair _ rt1a = coercionKind co1a - (Pair lt2a _, rt2a) = coercionKindRole co2a - - Pair _ rt1bs = traverse coercionKind co1bs - Pair lt2bs _ = traverse coercionKind co2bs - rt2bs = map coercionRole co2bs - - kcoa = mkKindCo $ buildCoercion lt2a rt1a - kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs - - co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a - co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs - co2bs'' = zipWith mkTransCo co2bs' co2bs - in - mkAppCos (opt_trans is co1a co2a') - (zipWith (opt_trans is) co1bs co2bs'') - -fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion -fireTransRule _rule _co1 _co2 res - = Just res - -{- -Note [Conflict checking with AxiomInstCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following type family and axiom: - -type family Equal (a :: k) (b :: k) :: Bool -type instance where - Equal a a = True - Equal a b = False --- -Equal :: forall k::*. k -> k -> Bool -axEqual :: { forall k::*. forall a::k. Equal k a a ~ True - ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } - -We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ -False) and that all is OK. But, all is not OK: we want to use the first branch -of the axiom in this case, not the second. The problem is that the parameters -of the first branch can unify with the supplied coercions, thus meaning that -the first branch should be taken. See also Note [Apartness] in -types/FamInstEnv.hs. - -Note [Why call checkAxInstCo during optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible that otherwise-good-looking optimisations meet with disaster -in the presence of axioms with multiple equations. Consider - -type family Equal (a :: *) (b :: *) :: Bool where - Equal a a = True - Equal a b = False -type family Id (a :: *) :: * where - Id a = a - -axEq :: { [a::*]. Equal a a ~ True - ; [a::*, b::*]. Equal a b ~ False } -axId :: [a::*]. Id a ~ a - -co1 = Equal (axId[0] Int) (axId[0] Bool) - :: Equal (Id Int) (Id Bool) ~ Equal Int Bool -co2 = axEq[1] - :: Equal Int Bool ~ False - -We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that -co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what -happens when we push the coercions inside? We get - -co3 = axEq[1] (axId[0] Int) (axId[0] Bool) - :: Equal (Id Int) (Id Bool) ~ False - -which is bogus! This is because the type system isn't smart enough to know -that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type -families. At the time of writing, I (Richard Eisenberg) couldn't think of -a way of detecting this any more efficient than just building the optimised -coercion and checking. - -Note [EtaAppCo] -~~~~~~~~~~~~~~~ -Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd -like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that -the resultant coercions might not be well kinded. Here is an example (things -labeled with x don't matter in this example): - - k1 :: Type - k2 :: Type - - a :: k1 -> Type - b :: k1 - - h :: k1 ~ k2 - - co1a :: x1 ~ (a |> (h -> ) - co1b :: x2 ~ (b |> h) - - co2a :: a ~ x3 - co2b :: b ~ x4 - -First, convince yourself of the following: - - co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) - co2a co2b :: a b ~ x3 x4 - - (a |> (h -> )) (b |> h) `eqType` a b - -That last fact is due to Note [Non-trivial definitional equality] in TyCoRep, -where we ignore coercions in types as long as two types' kinds are the same. -In our case, we meet this last condition, because - - (a |> (h -> )) (b |> h) :: Type - and - a b :: Type - -So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the -suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the -kinds don't match up. - -The solution here is to twiddle the kinds in the output coercions. First, we -need to find coercions - - ak :: kind(a |> (h -> )) ~ kind(a) - bk :: kind(b |> h) ~ kind(b) - -This can be done with mkKindCo and buildCoercion. The latter assumes two -types are identical modulo casts and builds a coercion between them. - -Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the -output coercions. These are well-kinded. - -Also, note that all of this is done after accumulated any nested AppCo -parameters. This step is to avoid quadratic behavior in calling coercionKind. - -The problem described here was first found in dependent/should_compile/dynamic-paper. - --} - --- | Check to make sure that an AxInstCo is internally consistent. --- Returns the conflicting branch, if it exists --- See Note [Conflict checking with AxiomInstCo] -checkAxInstCo :: Coercion -> Maybe CoAxBranch --- defined here to avoid dependencies in Coercion --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in CoreLint -checkAxInstCo (AxiomInstCo ax ind cos) - = let branch = coAxiomNthBranch ax ind - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - incomps = coAxBranchIncomps branch - (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos) - co_args = map stripCoercionTy cotys - subst = zipTvSubst tvs tys `composeTCvSubst` - zipCvSubst cvs co_args - target = Type.substTys subst (coAxBranchLHS branch) - in_scope = mkInScopeSet $ - unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - flattened_target = flattenTys in_scope target in - check_no_conflict flattened_target incomps - where - check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch - check_no_conflict _ [] = Nothing - check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) - -- See Note [Apartness] in FamInstEnv - | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp - = check_no_conflict flat rest - | otherwise - = Just b -checkAxInstCo _ = Nothing - - ------------ -wrapSym :: SymFlag -> Coercion -> Coercion -wrapSym sym co | sym = mkSymCo co - | otherwise = co - --- | Conditionally set a role to be representational -wrapRole :: ReprFlag - -> Role -- ^ current role - -> Coercion -> Coercion -wrapRole False _ = id -wrapRole True current = downgradeRole Representational current - --- | If we require a representational role, return that. Otherwise, --- return the "default" role provided. -chooseRole :: ReprFlag - -> Role -- ^ "default" role - -> Role -chooseRole True _ = Representational -chooseRole _ r = r - ------------ -isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) -isAxiom_maybe (SymCo co) - | Just (sym, con, ind, cos) <- isAxiom_maybe co - = Just (not sym, con, ind, cos) -isAxiom_maybe (AxiomInstCo con ind cos) - = Just (False, con, ind, cos) -isAxiom_maybe _ = Nothing - -matchAxiom :: Bool -- True = match LHS, False = match RHS - -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] -matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co - | CoAxBranch { cab_tvs = qtvs - , cab_cvs = [] -- can't infer these, so fail if there are any - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } <- coAxiomNthBranch ax ind - , Just subst <- liftCoMatch (mkVarSet qtvs) - (if sym then (mkTyConApp tc lhs) else rhs) - co - , all (`isMappedByLC` subst) qtvs - = zipWithM (liftCoSubstTyVar subst) roles qtvs - - | otherwise - = Nothing - -------------- -compatible_co :: Coercion -> Coercion -> Bool --- Check whether (co1 . co2) will be well-kinded -compatible_co co1 co2 - = x1 `eqType` x2 - where - Pair _ x1 = coercionKind co1 - Pair x2 _ = coercionKind co2 - -------------- -{- -etaForAllCo -~~~~~~~~~~~~~~~~~ -(1) etaForAllCo_ty_maybe -Suppose we have - - g : all a1:k1.t1 ~ all a2:k2.t2 - -but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: - - g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) - -Call the kind coercion h1 and the body coercion h2. We can see that - - h2 : t1 ~ t2[a2 |-> (a1 |> h1)] - -According to the typing rule for ForAllCo, we get that - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) - -or - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) - -as desired. - -(2) etaForAllCo_co_maybe -Suppose we have - - g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 - -Similarly, we do this - - g' = all c1:h1. h2 - : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] - [c1 |-> eta1;c1;sym eta2] - -Here, - - h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) - eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) - eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) - h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) --} -etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) --- Try to make the coercion be of form (forall tv:kind_co. co) -etaForAllCo_ty_maybe co - | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co - = Just (tv, kind_co, r) - - | Pair ty1 ty2 <- coercionKind co - , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 - , isForAllTy_ty ty2 - , let kind_co = mkNthCo Nominal 0 co - = Just ( tv1, kind_co - , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) - - | otherwise - = Nothing - -etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) --- Try to make the coercion be of form (forall cv:kind_co. co) -etaForAllCo_co_maybe co - | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co - = Just (cv, kind_co, r) - - | Pair ty1 ty2 <- coercionKind co - , Just (cv1, _) <- splitForAllTy_co_maybe ty1 - , isForAllTy_co ty2 - = let kind_co = mkNthCo Nominal 0 co - r = coVarRole cv1 - l_co = mkCoVarCo cv1 - kind_co' = downgradeRole r Nominal kind_co - r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` - l_co `mkTransCo` - (mkNthCo r 3 kind_co') - in Just ( cv1, kind_co - , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) - - | otherwise - = Nothing - -etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) --- If possible, split a coercion --- g :: t1a t1b ~ t2a t2b --- into a pair of coercions (left g, right g) -etaAppCo_maybe co - | Just (co1,co2) <- splitAppCo_maybe co - = Just (co1,co2) - | (Pair ty1 ty2, Nominal) <- coercionKindRole co - , Just (_,t1) <- splitAppTy_maybe ty1 - , Just (_,t2) <- splitAppTy_maybe ty2 - , let isco1 = isCoercionTy t1 - , let isco2 = isCoercionTy t2 - , isco1 == isco2 - = Just (LRCo CLeft co, LRCo CRight co) - | otherwise - = Nothing - -etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] --- If possible, split a coercion --- g :: T s1 .. sn ~ T t1 .. tn --- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] -etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) - = ASSERT( tc == tc2 ) Just cos2 - -etaTyConAppCo_maybe tc co - | not (mustBeSaturated tc) - , (Pair ty1 ty2, r) <- coercionKindRole co - , Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in TyCoRep - , let n = length tys1 - , tys2 `lengthIs` n -- This can fail in an erroneous progam - -- E.g. T a ~# T a b - -- #14607 - = ASSERT( tc == tc1 ) - Just (decomposeCo n co (tyConRolesX r tc1)) - -- NB: n might be <> tyConArity tc - -- e.g. data family T a :: * -> * - -- g :: T a b ~ T c d - - | otherwise - = Nothing - -{- -Note [Eta for AppCo] -~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: s1 t1 ~ s2 t2 - -Then we can't necessarily make - left g :: s1 ~ s2 - right g :: t1 ~ t2 -because it's possible that - s1 :: * -> * t1 :: * - s2 :: (*->*) -> * t2 :: * -> * -and in that case (left g) does not have the same -kind on either side. - -It's enough to check that - kind t1 = kind t2 -because if g is well-kinded then - kind (s1 t2) = kind (s2 t2) -and these two imply - kind s1 = kind s2 - --} - -optForAllCoBndr :: LiftingContext -> Bool - -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) -optForAllCoBndr env sym - = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/types/TyCoFVs.hs b/types/TyCoFVs.hs deleted file mode 100644 --- a/types/TyCoFVs.hs +++ /dev/null @@ -1,861 +0,0 @@ -module TyCoFVs - ( - tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, - exactTyCoVarsOfType, exactTyCoVarsOfTypes, - tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, - tyCoFVsOfType, tyCoVarsOfTypeList, - tyCoFVsOfTypes, tyCoVarsOfTypesList, - tyCoVarsOfTypesSet, tyCoVarsOfCosSet, - coVarsOfType, coVarsOfTypes, - coVarsOfCo, coVarsOfCos, - tyCoVarsOfCo, tyCoVarsOfCos, - tyCoVarsOfCoDSet, - tyCoFVsOfCo, tyCoFVsOfCos, - tyCoVarsOfCoList, tyCoVarsOfProv, - almostDevoidCoVarOfCo, - injectiveVarsOfType, injectiveVarsOfTypes, - invisibleVarsOfType, invisibleVarsOfTypes, - - noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, - - mkTyCoInScopeSet, - - -- * Welll-scoped free variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - ) where - -import GhcPrelude - -import {-# SOURCE #-} Type (coreView, tcView, partitionInvisibleTypes) - -import TyCoRep -import TyCon -import Var -import FV - -import UniqFM -import VarSet -import VarEnv -import Util -import Panic - -{- -%************************************************************************ -%* * - Free variables of types and coercions -%* * -%************************************************************************ --} - -{- Note [Free variables of types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns -a VarSet that is closed over the types of its variables. More precisely, - if S = tyCoVarsOfType( t ) - and (a:k) is in S - then tyCoVarsOftype( k ) is a subset of S - -Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. - -We could /not/ close over the kinds of the variable occurrences, and -instead do so at call sites, but it seems that we always want to do -so, so it's easiest to do it here. - -It turns out that getting the free variables of types is performance critical, -so we profiled several versions, exploring different implementation strategies. - -1. Baseline version: uses FV naively. Essentially: - - tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty - - This is not nice, because FV introduces some overhead to implement - determinism, and throught its "interesting var" function, neither of which - we need here, so they are a complete waste. - -2. UnionVarSet version: instead of reusing the FV-based code, we simply used - VarSets directly, trying to avoid the overhead of FV. E.g.: - - -- FV version: - tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c - - -- UnionVarSet version: - tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) - - This looks deceptively similar, but while FV internally builds a list- and - set-generating function, the VarSet functions manipulate sets directly, and - the latter peforms a lot worse than the naive FV version. - -3. Accumulator-style VarSet version: this is what we use now. We do use VarSet - as our data structure, but delegate the actual work to a new - ty_co_vars_of_... family of functions, which use accumulator style and the - "in-scope set" filter found in the internals of FV, but without the - determinism overhead. - -See #14880. - -Note [Closing over free variable kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over -free variable kinds. In previous GHC versions, this happened naively: whenever -we would encounter an occurrence of a free type variable, we would close over -its kind. This, however is wrong for two reasons (see #14880): - -1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then - we don't want to have to traverse k more than once. - -2. Correctness. Imagine we have forall k. b -> k, where b has - kind k, for some k bound in an outer scope. If we look at b's kind inside - the forall, we'll collect that k is free and then remove k from the set of - free variables. This is plain wrong. We must instead compute that b is free - and then conclude that b's kind is free. - -An obvious first approach is to move the closing-over-kinds from the -occurrences of a type variable to after finding the free vars - however, this -turns out to introduce performance regressions, and isn't even entirely -correct. - -In fact, it isn't even important *when* we close over kinds; what matters is -that we handle each type var exactly once, and that we do it in the right -context. - -So the next approach we tried was to use the "in-scope set" part of FV or the -equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to -say "don't bother with variables we have already closed over". This should work -fine in theory, but the code is complicated and doesn't perform well. - -But there is a simpler way, which is implemented here. Consider the two points -above: - -1. Efficiency: we now have an accumulator, so the second time we encounter 'a', - we'll ignore it, certainly not looking at its kind - this is why - pre-checking set membership before inserting ends up not only being faster, - but also being correct. - -2. Correctness: we have an "in-scope set" (I think we should call it it a - "bound-var set"), specifying variables that are bound by a forall in the type - we are traversing; we simply ignore these variables, certainly not looking at - their kind. - -So now consider: - - forall k. b -> k - -where b :: k->Type is free; but of course, it's a different k! When looking at -b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose -this is our first encounter with b; we want the free vars of its kind. But we -want to behave as if we took the free vars of its kind at the end; that is, -with no bound vars in scope. - -So the solution is easy. The old code was this: - - ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) - -Now all we need to do is take the free vars of tyVarKind v *with an empty -bound-var set*, thus: - -ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) - ^^^^^^^^^^^ - -And that's it. This works because a variable is either bound or free. If it is bound, -then we won't look at it at all. If it is free, then all the variables free in its -kind are free -- regardless of whether some local variable has the same Unique. -So if we're looking at a variable occurrence at all, then all variables in its -kind are free. --} - -tyCoVarsOfType :: Type -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfType ty = ty_co_vars_of_type ty emptyVarSet emptyVarSet - -tyCoVarsOfTypes :: [Type] -> TyCoVarSet -tyCoVarsOfTypes tys = ty_co_vars_of_types tys emptyVarSet emptyVarSet - -ty_co_vars_of_type :: Type -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) - emptyVarSet -- See Note [Closing over free variable kinds] - (extendVarSet acc v) - -ty_co_vars_of_type (TyConApp _ tys) is acc = ty_co_vars_of_types tys is acc -ty_co_vars_of_type (LitTy {}) _ acc = acc -ty_co_vars_of_type (AppTy fun arg) is acc = ty_co_vars_of_type fun is (ty_co_vars_of_type arg is acc) -ty_co_vars_of_type (FunTy _ arg res) is acc = ty_co_vars_of_type arg is (ty_co_vars_of_type res is acc) -ty_co_vars_of_type (ForAllTy (Bndr tv _) ty) is acc = ty_co_vars_of_type (varType tv) is $ - ty_co_vars_of_type ty (extendVarSet is tv) acc -ty_co_vars_of_type (CastTy ty co) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_co co is acc) -ty_co_vars_of_type (CoercionTy co) is acc = ty_co_vars_of_co co is acc - -ty_co_vars_of_types :: [Type] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_types [] _ acc = acc -ty_co_vars_of_types (ty:tys) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_types tys is acc) - -tyCoVarsOfCo :: Coercion -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCo co = ty_co_vars_of_co co emptyVarSet emptyVarSet - -tyCoVarsOfCos :: [Coercion] -> TyCoVarSet -tyCoVarsOfCos cos = ty_co_vars_of_cos cos emptyVarSet emptyVarSet - - -ty_co_vars_of_co :: Coercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_co (Refl ty) is acc = ty_co_vars_of_type ty is acc -ty_co_vars_of_co (GRefl _ ty mco) is acc = ty_co_vars_of_type ty is $ - ty_co_vars_of_mco mco is acc -ty_co_vars_of_co (TyConAppCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc -ty_co_vars_of_co (AppCo co arg) is acc = ty_co_vars_of_co co is $ - ty_co_vars_of_co arg is acc -ty_co_vars_of_co (ForAllCo tv kind_co co) is acc = ty_co_vars_of_co kind_co is $ - ty_co_vars_of_co co (extendVarSet is tv) acc -ty_co_vars_of_co (FunCo _ co1 co2) is acc = ty_co_vars_of_co co1 is $ - ty_co_vars_of_co co2 is acc -ty_co_vars_of_co (CoVarCo v) is acc = ty_co_vars_of_co_var v is acc -ty_co_vars_of_co (HoleCo h) is acc = ty_co_vars_of_co_var (coHoleCoVar h) is acc - -- See Note [CoercionHoles and coercion free variables] -ty_co_vars_of_co (AxiomInstCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc -ty_co_vars_of_co (UnivCo p _ t1 t2) is acc = ty_co_vars_of_prov p is $ - ty_co_vars_of_type t1 is $ - ty_co_vars_of_type t2 is acc -ty_co_vars_of_co (SymCo co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (TransCo co1 co2) is acc = ty_co_vars_of_co co1 is $ - ty_co_vars_of_co co2 is acc -ty_co_vars_of_co (NthCo _ _ co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (LRCo _ co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (InstCo co arg) is acc = ty_co_vars_of_co co is $ - ty_co_vars_of_co arg is acc -ty_co_vars_of_co (KindCo co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (SubCo co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (AxiomRuleCo _ cs) is acc = ty_co_vars_of_cos cs is acc - -ty_co_vars_of_mco :: MCoercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_mco MRefl _is acc = acc -ty_co_vars_of_mco (MCo co) is acc = ty_co_vars_of_co co is acc - -ty_co_vars_of_co_var :: CoVar -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_co_var v is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (varType v) - emptyVarSet -- See Note [Closing over free variable kinds] - (extendVarSet acc v) - -ty_co_vars_of_cos :: [Coercion] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_cos [] _ acc = acc -ty_co_vars_of_cos (co:cos) is acc = ty_co_vars_of_co co is (ty_co_vars_of_cos cos is acc) - -tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet -tyCoVarsOfProv prov = ty_co_vars_of_prov prov emptyVarSet emptyVarSet - -ty_co_vars_of_prov :: UnivCoProvenance -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_prov (PhantomProv co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_prov (ProofIrrelProv co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_prov UnsafeCoerceProv _ acc = acc -ty_co_vars_of_prov (PluginProv _) _ acc = acc - --- | Generates an in-scope set from the free variables in a list of types --- and a list of coercions -mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet -mkTyCoInScopeSet tys cos - = mkInScopeSet (ty_co_vars_of_types tys emptyVarSet $ - ty_co_vars_of_cos cos emptyVarSet emptyVarSet) - --- | `tyCoFVsOfType` that returns free variables of a type in a deterministic --- set. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty - --- | `tyCoFVsOfType` that returns free variables of a type in deterministic --- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeList :: Type -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty - --- | Returns free variables of types, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesSet :: TyVarEnv Type -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesSet tys = tyCoVarsOfTypes $ nonDetEltsUFM tys - -- It's OK to use nonDetEltsUFM here because we immediately forget the - -- ordering by returning a set - --- | Returns free variables of types, including kind variables as --- a deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys - --- | Returns free variables of types, including kind variables as --- a deterministically ordered list. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesList :: [Type] -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys - -{- -************************************************************************ -* * - The "exact" free variables of a type -* * -************************************************************************ - -Note [Silly type synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type T a = Int -What are the free tyvars of (T x)? Empty, of course! - -exactTyCoVarsOfType is used by the type checker to figure out exactly -which type variables are mentioned in a type. It only matters -occasionally -- see the calls to exactTyCoVarsOfType. --} - -exactTyCoVarsOfType :: Type -> TyCoVarSet --- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] above. -exactTyCoVarsOfType ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' -- This is the key line - go (TyVarTy tv) = goVar tv - go (TyConApp _ tys) = exactTyCoVarsOfTypes tys - go (LitTy {}) = emptyVarSet - go (AppTy fun arg) = go fun `unionVarSet` go arg - go (FunTy _ arg res) = go arg `unionVarSet` go res - go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) - go (CastTy ty co) = go ty `unionVarSet` goCo co - go (CoercionTy co) = goCo co - - goMCo MRefl = emptyVarSet - goMCo (MCo co) = goCo co - - goCo (Refl ty) = go ty - goCo (GRefl _ ty mco) = go ty `unionVarSet` goMCo mco - goCo (TyConAppCo _ _ args)= goCos args - goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg - goCo (ForAllCo tv k_co co) - = goCo co `delVarSet` tv `unionVarSet` goCo k_co - goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (CoVarCo v) = goVar v - goCo (HoleCo h) = goVar (coHoleCoVar h) - goCo (AxiomInstCo _ _ args) = goCos args - goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2 - goCo (SymCo co) = goCo co - goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (NthCo _ _ co) = goCo co - goCo (LRCo _ co) = goCo co - goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg - goCo (KindCo co) = goCo co - goCo (SubCo co) = goCo co - goCo (AxiomRuleCo _ c) = goCos c - - goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos - - goProv UnsafeCoerceProv = emptyVarSet - goProv (PhantomProv kco) = goCo kco - goProv (ProofIrrelProv kco) = goCo kco - goProv (PluginProv _) = emptyVarSet - - goVar v = unitVarSet v `unionVarSet` go (varType v) - -exactTyCoVarsOfTypes :: [Type] -> TyVarSet -exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys - --- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. --- The previous implementation used `unionVarSet` which is O(n+m) and can --- make the function quadratic. --- It's exported, so that it can be composed with --- other functions that compute free variables. --- See Note [FV naming conventions] in FV. --- --- Eta-expanded because that makes it run faster (apparently) --- See Note [FV eta expansion] in FV for explanation. -tyCoFVsOfType :: Type -> FV --- See Note [Free variables of types] -tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) - | not (f v) = (acc_list, acc_set) - | v `elemVarSet` bound_vars = (acc_list, acc_set) - | v `elemVarSet` acc_set = (acc_list, acc_set) - | otherwise = tyCoFVsOfType (tyVarKind v) f - emptyVarSet -- See Note [Closing over free variable kinds] - (v:acc_list, extendVarSet acc_set v) -tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc -tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc -tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc -tyCoFVsOfType (FunTy _ arg res) f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc -tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc -tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc -tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc - -tyCoFVsBndr :: TyCoVarBinder -> FV -> FV --- Free vars of (forall b. ) -tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs - -tyCoFVsVarBndrs :: [Var] -> FV -> FV -tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars - -tyCoFVsVarBndr :: Var -> FV -> FV -tyCoFVsVarBndr var fvs - = tyCoFVsOfType (varType var) -- Free vars of its type/kind - `unionFV` delFV var fvs -- Delete it from the thing-inside - -tyCoFVsOfTypes :: [Type] -> FV --- See Note [Free variables of types] -tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc -tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc - --- | Get a deterministic set of the vars free in a coercion -tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co - -tyCoVarsOfCoList :: Coercion -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co - -tyCoFVsOfMCo :: MCoercion -> FV -tyCoFVsOfMCo MRefl = emptyFV -tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co - -tyCoVarsOfCosSet :: CoVarEnv Coercion -> TyCoVarSet -tyCoVarsOfCosSet cos = tyCoVarsOfCos $ nonDetEltsUFM cos - -- It's OK to use nonDetEltsUFM here because we immediately forget the - -- ordering by returning a set - -tyCoFVsOfCo :: Coercion -> FV --- Extracts type and coercion variables from a coercion --- See Note [Free variables of types] -tyCoFVsOfCo (Refl ty) fv_cand in_scope acc - = tyCoFVsOfType ty fv_cand in_scope acc -tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc - = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc -tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc - = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc - = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc -tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc - = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc - = tyCoFVsOfCoVar v fv_cand in_scope acc -tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc - = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc - -- See Note [CoercionHoles and coercion free variables] -tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc - = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 - `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc -tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc - -tyCoFVsOfCoVar :: CoVar -> FV -tyCoFVsOfCoVar v fv_cand in_scope acc - = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc - -tyCoFVsOfProv :: UnivCoProvenance -> FV -tyCoFVsOfProv UnsafeCoerceProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc - -tyCoFVsOfCos :: [Coercion] -> FV -tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc - - -------------- Extracting the CoVars of a type or coercion ----------- - -{- - -Note [CoVarsOfX and the InterestingVarFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The coVarsOfType, coVarsOfTypes, coVarsOfCo, and coVarsOfCos functions are -implemented in terms of the respective FV equivalents (tyCoFVsOf...), rather -than the VarSet-based flavors (tyCoVarsOf...), despite the performance -considerations outlined in Note [Free variables of types]. - -This is because FV includes the InterestingVarFun, which is useful here, -because we can cleverly use it to restrict our calculations to CoVars - this -is what getCoVarSet achieves. - -See #14880. - --} - -getCoVarSet :: FV -> CoVarSet -getCoVarSet fv = snd (fv isCoVar emptyVarSet ([], emptyVarSet)) - -coVarsOfType :: Type -> CoVarSet -coVarsOfType ty = getCoVarSet (tyCoFVsOfType ty) - -coVarsOfTypes :: [Type] -> TyCoVarSet -coVarsOfTypes tys = getCoVarSet (tyCoFVsOfTypes tys) - -coVarsOfCo :: Coercion -> CoVarSet -coVarsOfCo co = getCoVarSet (tyCoFVsOfCo co) - -coVarsOfCos :: [Coercion] -> CoVarSet -coVarsOfCos cos = getCoVarSet (tyCoFVsOfCos cos) - ------ Whether a covar is /Almost Devoid/ in a type or coercion ---- - --- | Given a covar and a coercion, returns True if covar is almost devoid in --- the coercion. That is, covar can only appear in Refl and GRefl. --- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion -almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool -almostDevoidCoVarOfCo cv co = - almost_devoid_co_var_of_co co cv - -almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool -almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and -almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into - -- the coercions -almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv - = almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_co (AppCo co arg) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_co arg cv -almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv - = almost_devoid_co_var_of_co kind_co cv - && (v == cv || almost_devoid_co_var_of_co co cv) -almost_devoid_co_var_of_co (FunCo _ co1 co2) cv - = almost_devoid_co_var_of_co co1 cv - && almost_devoid_co_var_of_co co2 cv -almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv -almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv -almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv - = almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv - = almost_devoid_co_var_of_prov p cv - && almost_devoid_co_var_of_type t1 cv - && almost_devoid_co_var_of_type t2 cv -almost_devoid_co_var_of_co (SymCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (TransCo co1 co2) cv - = almost_devoid_co_var_of_co co1 cv - && almost_devoid_co_var_of_co co2 cv -almost_devoid_co_var_of_co (NthCo _ _ co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (LRCo _ co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (InstCo co arg) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_co arg cv -almost_devoid_co_var_of_co (KindCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (SubCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv - = almost_devoid_co_var_of_cos cs cv - -almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool -almost_devoid_co_var_of_cos [] _ = True -almost_devoid_co_var_of_cos (co:cos) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_cos cos cv - -almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool -almost_devoid_co_var_of_prov (PhantomProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (ProofIrrelProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov UnsafeCoerceProv _ = True -almost_devoid_co_var_of_prov (PluginProv _) _ = True - -almost_devoid_co_var_of_type :: Type -> CoVar -> Bool -almost_devoid_co_var_of_type (TyVarTy _) _ = True -almost_devoid_co_var_of_type (TyConApp _ tys) cv - = almost_devoid_co_var_of_types tys cv -almost_devoid_co_var_of_type (LitTy {}) _ = True -almost_devoid_co_var_of_type (AppTy fun arg) cv - = almost_devoid_co_var_of_type fun cv - && almost_devoid_co_var_of_type arg cv -almost_devoid_co_var_of_type (FunTy _ arg res) cv - = almost_devoid_co_var_of_type arg cv - && almost_devoid_co_var_of_type res cv -almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv - = almost_devoid_co_var_of_type (varType v) cv - && (v == cv || almost_devoid_co_var_of_type ty cv) -almost_devoid_co_var_of_type (CastTy ty co) cv - = almost_devoid_co_var_of_type ty cv - && almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_type (CoercionTy co) cv - = almost_devoid_co_var_of_co co cv - -almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool -almost_devoid_co_var_of_types [] _ = True -almost_devoid_co_var_of_types (ty:tys) cv - = almost_devoid_co_var_of_type ty cv - && almost_devoid_co_var_of_types tys cv - -------------- Injective free vars ----------------- - --- | Returns the free variables of a 'Type' that are in injective positions. --- Specifically, it finds the free variables while: --- --- * Expanding type synonyms --- --- * Ignoring the coercion in @(ty |> co)@ --- --- * Ignoring the non-injective fields of a 'TyConApp' --- --- --- For example, if @F@ is a non-injective type family, then: --- --- @ --- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} --- @ --- --- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. --- More formally, if --- @a@ is in @'injectiveVarsOfType' ty@ --- and @S1(ty) ~ S2(ty)@, --- then @S1(a) ~ S2(a)@, --- where @S1@ and @S2@ are arbitrary substitutions. --- --- See @Note [When does a tycon application need an explicit kind signature?]@. -injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? - -- See Note [Coverage condition for injective type families] - -- in FamInst. - -> Type -> FV -injectiveVarsOfType look_under_tfs = go - where - go ty | Just ty' <- coreView ty - = go ty' - go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) - go (AppTy f a) = go f `unionFV` go a - go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 - go (TyConApp tc tys) = - case tyConInjectivityInfo tc of - Injective inj - | look_under_tfs || not (isTypeFamilyTyCon tc) - -> mapUnionFV go $ - filterByList (inj ++ repeat True) tys - -- Oversaturated arguments to a tycon are - -- always injective, hence the repeat True - _ -> emptyFV - go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) - go LitTy{} = emptyFV - go (CastTy ty _) = go ty - go CoercionTy{} = emptyFV - --- | Returns the free variables of a 'Type' that are in injective positions. --- Specifically, it finds the free variables while: --- --- * Expanding type synonyms --- --- * Ignoring the coercion in @(ty |> co)@ --- --- * Ignoring the non-injective fields of a 'TyConApp' --- --- See @Note [When does a tycon application need an explicit kind signature?]@. -injectiveVarsOfTypes :: Bool -- ^ look under injective type families? - -- See Note [Coverage condition for injective type families] - -- in FamInst. - -> [Type] -> FV -injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs) - - -------------- Invisible vars ----------------- --- | Returns the set of variables that are used invisibly anywhere within --- the given type. A variable will be included even if it is used both visibly --- and invisibly. An invisible use site includes: --- * In the kind of a variable --- * In the kind of a bound variable in a forall --- * In a coercion --- * In a Specified or Inferred argument to a function --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep -invisibleVarsOfType :: Type -> FV -invisibleVarsOfType = go - where - go ty | Just ty' <- coreView ty - = go ty' - go (TyVarTy v) = go (tyVarKind v) - go (AppTy f a) = go f `unionFV` go a - go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 - go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` - invisibleVarsOfTypes visibles - where (invisibles, visibles) = partitionInvisibleTypes tc tys - go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty - go LitTy{} = emptyFV - go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty - go (CoercionTy co) = tyCoFVsOfCo co - --- | Like 'invisibleVarsOfType', but for many types. -invisibleVarsOfTypes :: [Type] -> FV -invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType - - -------------- No free vars ----------------- - --- | Returns True if this type has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case. -noFreeVarsOfType :: Type -> Bool -noFreeVarsOfType (TyVarTy _) = False -noFreeVarsOfType (AppTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 -noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys -noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty) -noFreeVarsOfType (FunTy _ t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 -noFreeVarsOfType (LitTy _) = True -noFreeVarsOfType (CastTy ty co) = noFreeVarsOfType ty && noFreeVarsOfCo co -noFreeVarsOfType (CoercionTy co) = noFreeVarsOfCo co - -noFreeVarsOfMCo :: MCoercion -> Bool -noFreeVarsOfMCo MRefl = True -noFreeVarsOfMCo (MCo co) = noFreeVarsOfCo co - -noFreeVarsOfTypes :: [Type] -> Bool -noFreeVarsOfTypes = all noFreeVarsOfType - --- | Returns True if this coercion has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. -noFreeVarsOfCo :: Coercion -> Bool -noFreeVarsOfCo (Refl ty) = noFreeVarsOfType ty -noFreeVarsOfCo (GRefl _ ty co) = noFreeVarsOfType ty && noFreeVarsOfMCo co -noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args -noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 -noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co) -noFreeVarsOfCo (FunCo _ c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 -noFreeVarsOfCo (CoVarCo _) = False -noFreeVarsOfCo (HoleCo {}) = True -- I'm unsure; probably never happens -noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args -noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p && - noFreeVarsOfType t1 && - noFreeVarsOfType t2 -noFreeVarsOfCo (SymCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (TransCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 -noFreeVarsOfCo (NthCo _ _ co) = noFreeVarsOfCo co -noFreeVarsOfCo (LRCo _ co) = noFreeVarsOfCo co -noFreeVarsOfCo (InstCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 -noFreeVarsOfCo (KindCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (SubCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (AxiomRuleCo _ cs) = all noFreeVarsOfCo cs - --- | Returns True if this UnivCoProv has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case. -noFreeVarsOfProv :: UnivCoProvenance -> Bool -noFreeVarsOfProv UnsafeCoerceProv = True -noFreeVarsOfProv (PhantomProv co) = noFreeVarsOfCo co -noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co -noFreeVarsOfProv (PluginProv {}) = True - -{- -%************************************************************************ -%* * - Well-scoped tyvars -* * -************************************************************************ - -Note [ScopedSort] -~~~~~~~~~~~~~~~~~ -Consider - - foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () - -This function type is implicitly generalised over [a, b, k, k2]. These -variables will be Specified; that is, they will be available for visible -type application. This is because they are written in the type signature -by the user. - -However, we must ask: what order will they appear in? In cases without -dependency, this is easy: we just use the lexical left-to-right ordering -of first occurrence. With dependency, we cannot get off the hook so -easily. - -We thus state: - - * These variables appear in the order as given by ScopedSort, where - the input to ScopedSort is the left-to-right order of first occurrence. - -Note that this applies only to *implicit* quantification, without a -`forall`. If the user writes a `forall`, then we just use the order given. - -ScopedSort is defined thusly (as proposed in #15743): - * Work left-to-right through the input list, with a cursor. - * If variable v at the cursor is depended on by any earlier variable w, - move v immediately before the leftmost such w. - -INVARIANT: The prefix of variables before the cursor form a valid telescope. - -Note that ScopedSort makes sense only after type inference is done and all -types/kinds are fully settled and zonked. - --} - --- | Do a topological sort on a list of tyvars, --- so that binders occur before occurrences --- E.g. given [ a::k, k::*, b::k ] --- it'll return a well-scoped list [ k::*, a::k, b::k ] --- --- This is a deterministic sorting operation --- (that is, doesn't depend on Uniques). --- --- It is also meant to be stable: that is, variables should not --- be reordered unnecessarily. This is specified in Note [ScopedSort] --- See also Note [Ordering of implicit variables] in RnTypes - -scopedSort :: [TyCoVar] -> [TyCoVar] -scopedSort = go [] [] - where - go :: [TyCoVar] -- already sorted, in reverse order - -> [TyCoVarSet] -- each set contains all the variables which must be placed - -- before the tv corresponding to the set; they are accumulations - -- of the fvs in the sorted tvs' kinds - - -- This list is in 1-to-1 correspondence with the sorted tyvars - -- INVARIANT: - -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) - -- That is, each set in the list is a superset of all later sets. - - -> [TyCoVar] -- yet to be sorted - -> [TyCoVar] - go acc _fv_list [] = reverse acc - go acc fv_list (tv:tvs) - = go acc' fv_list' tvs - where - (acc', fv_list') = insert tv acc fv_list - - insert :: TyCoVar -- var to insert - -> [TyCoVar] -- sorted list, in reverse order - -> [TyCoVarSet] -- list of fvs, as above - -> ([TyCoVar], [TyCoVarSet]) -- augmented lists - insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) - insert tv (a:as) (fvs:fvss) - | tv `elemVarSet` fvs - , (as', fvss') <- insert tv as fvss - = (a:as', fvs `unionVarSet` fv_tv : fvss') - - | otherwise - = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) - where - fv_tv = tyCoVarsOfType (tyVarKind tv) - - -- lists not in correspondence - insert _ _ _ = panic "scopedSort" - --- | Get the free vars of a type in scoped order -tyCoVarsOfTypeWellScoped :: Type -> [TyVar] -tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList - --- | Get the free vars of types in scoped order -tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] -tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList diff --git a/types/TyCoPpr.hs b/types/TyCoPpr.hs deleted file mode 100644 --- a/types/TyCoPpr.hs +++ /dev/null @@ -1,337 +0,0 @@ --- | Pretty-printing types and coercions. -module TyCoPpr - ( - -- * Precedence - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, - - -- * Pretty-printing types - pprType, pprParendType, pprPrecType, pprPrecTypeX, - pprTypeApp, pprTCvBndr, pprTCvBndrs, - pprSigmaType, - pprTheta, pprParendTheta, pprForAll, pprUserForAll, - pprTyVar, pprTyVars, - pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprTyLit, - pprDataCons, pprWithExplicitKindsWhen, - pprWithTYPE, pprSourceTyCon, - - - -- * Pretty-printing coercions - pprCo, pprParendCo, - - debugPprType, - - -- * Pretty-printing 'TyThing's - pprTyThingCategory, pprShortTyThing, - ) where - -import GhcPrelude - -import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr - , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) -import {-# SOURCE #-} DataCon( dataConFullSig - , dataConUserTyVarBinders - , DataCon ) - -import {-# SOURCE #-} Type( isLiftedTypeKind ) - -import TyCon -import TyCoRep -import TyCoTidy -import TyCoFVs -import Class -import Var - -import IfaceType - -import VarSet -import VarEnv - -import DynFlags ( gopt_set, - GeneralFlag(Opt_PrintExplicitKinds, Opt_PrintExplicitRuntimeReps) ) -import Outputable -import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec - , funPrec, appPrec, maybeParen ) - -{- -%************************************************************************ -%* * - Pretty-printing types - - Defined very early because of debug printing in assertions -%* * -%************************************************************************ - -@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is -defined to use this. @pprParendType@ is the same, except it puts -parens around the type, except for the atomic cases. @pprParendType@ -works just by setting the initial context precedence very high. - -Note that any function which pretty-prints a @Type@ first converts the @Type@ -to an @IfaceType@. See Note [IfaceType and pretty-printing] in IfaceType. - -See Note [Precedence in types] in BasicTypes. --} - --------------------------------------------------------- --- When pretty-printing types, we convert to IfaceType, --- and pretty-print that. --- See Note [Pretty printing via IfaceSyn] in PprTyThing --------------------------------------------------------- - -pprType, pprParendType :: Type -> SDoc -pprType = pprPrecType topPrec -pprParendType = pprPrecType appPrec - -pprPrecType :: PprPrec -> Type -> SDoc -pprPrecType = pprPrecTypeX emptyTidyEnv - -pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc -pprPrecTypeX env prec ty - = getPprStyle $ \sty -> - if debugStyle sty -- Use debugPprType when in - then debug_ppr_ty prec ty -- when in debug-style - else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) - -- NB: debug-style is used for -dppr-debug - -- dump-style is used for -ddump-tc-trace etc - -pprTyLit :: TyLit -> SDoc -pprTyLit = pprIfaceTyLit . toIfaceTyLit - -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - -tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType -tidyToIfaceTypeStyX env ty sty - | userStyle sty = tidyToIfaceTypeX env ty - | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty - -- in latter case, don't tidy, as we'll be printing uniques. - -tidyToIfaceType :: Type -> IfaceType -tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv - -tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType --- It's vital to tidy before converting to an IfaceType --- or nested binders will become indistinguishable! --- --- Also for the free type variables, tell toIfaceTypeX to --- leave them as IfaceFreeTyVar. This is super-important --- for debug printing. -tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) - where - env' = tidyFreeTyCoVars env free_tcvs - free_tcvs = tyCoVarsOfTypeWellScoped ty - ------------- -pprCo, pprParendCo :: Coercion -> SDoc -pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) -pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) - -tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion -tidyToIfaceCoSty co sty - | userStyle sty = tidyToIfaceCo co - | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co - -- in latter case, don't tidy, as we'll be printing uniques. - -tidyToIfaceCo :: Coercion -> IfaceCoercion --- It's vital to tidy before converting to an IfaceType --- or nested binders will become indistinguishable! --- --- Also for the free type variables, tell toIfaceCoercionX to --- leave them as IfaceFreeCoVar. This is super-important --- for debug printing. -tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) - where - env = tidyFreeTyCoVars emptyTidyEnv free_tcvs - free_tcvs = scopedSort $ tyCoVarsOfCoList co ------------- -pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = pprTypeApp (classTyCon clas) tys - ------------- -pprTheta :: ThetaType -> SDoc -pprTheta = pprIfaceContext topPrec . map tidyToIfaceType - -pprParendTheta :: ThetaType -> SDoc -pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType - -pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType - ------------------- -pprSigmaType :: Type -> SDoc -pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType - -pprForAll :: [TyCoVarBinder] -> SDoc -pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) - --- | Print a user-level forall; see Note [When to print foralls] in this module. -pprUserForAll :: [TyCoVarBinder] -> SDoc -pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr - -pprTCvBndrs :: [TyCoVarBinder] -> SDoc -pprTCvBndrs tvs = sep (map pprTCvBndr tvs) - -pprTCvBndr :: TyCoVarBinder -> SDoc -pprTCvBndr = pprTyVar . binderVar - -pprTyVars :: [TyVar] -> SDoc -pprTyVars tvs = sep (map pprTyVar tvs) - -pprTyVar :: TyVar -> SDoc --- Print a type variable binder with its kind (but not if *) --- Here we do not go via IfaceType, because the duplication with --- pprIfaceTvBndr is minimal, and the loss of uniques etc in --- debug printing is disastrous -pprTyVar tv - | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) - where - kind = tyVarKind tv - ------------------ -debugPprType :: Type -> SDoc --- ^ debugPprType is a simple pretty printer that prints a type --- without going through IfaceType. It does not format as prettily --- as the normal route, but it's much more direct, and that can --- be useful for debugging. E.g. with -dppr-debug it prints the --- kind on type-variable /occurrences/ which the normal route --- fundamentally cannot do. -debugPprType ty = debug_ppr_ty topPrec ty - -debug_ppr_ty :: PprPrec -> Type -> SDoc -debug_ppr_ty _ (LitTy l) - = ppr l - -debug_ppr_ty _ (TyVarTy tv) - = ppr tv -- With -dppr-debug we get (tv :: kind) - -debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - = maybeParen prec funPrec $ - sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] - where - arrow = case af of - VisArg -> text "->" - InvisArg -> text "=>" - -debug_ppr_ty prec (TyConApp tc tys) - | null tys = ppr tc - | otherwise = maybeParen prec appPrec $ - hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) - -debug_ppr_ty _ (AppTy t1 t2) - = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) - 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish - -- TyConApp from AppTy - -debug_ppr_ty prec (CastTy ty co) - = maybeParen prec topPrec $ - hang (debug_ppr_ty topPrec ty) - 2 (text "|>" <+> ppr co) - -debug_ppr_ty _ (CoercionTy co) - = parens (text "CO" <+> ppr co) - -debug_ppr_ty prec ty@(ForAllTy {}) - | (tvs, body) <- split ty - = maybeParen prec funPrec $ - hang (text "forall" <+> fsep (map ppr tvs) <> dot) - -- The (map ppr tvs) will print kind-annotated - -- tvs, because we are (usually) in debug-style - 2 (ppr body) - where - split ty | ForAllTy tv ty' <- ty - , (tvs, body) <- split ty' - = (tv:tvs, body) - | otherwise - = ([], ty) - -{- -Note [When to print foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we want to print top-level foralls when (and only when) the user specifies --fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses -too much information; see #9018. - -So I'm trying out this rule: print explicit foralls if - a) User specifies -fprint-explicit-foralls, or - b) Any of the quantified type variables has a kind - that mentions a kind variable - -This catches common situations, such as a type siguature - f :: m a -which means - f :: forall k. forall (m :: k->*) (a :: k). m a -We really want to see both the "forall k" and the kind signatures -on m and a. The latter comes from pprTCvBndr. - -Note [Infix type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With TypeOperators you can say - - f :: (a ~> b) -> b - -and the (~>) is considered a type variable. However, the type -pretty-printer in this module will just see (a ~> b) as - - App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") - -So it'll print the type in prefix form. To avoid confusion we must -remember to parenthesise the operator, thus - - (~>) a b -> b - -See #2766. --} - -pprDataCons :: TyCon -> SDoc -pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons - where - sepWithVBars [] = empty - sepWithVBars docs = sep (punctuate (space <> vbar) docs) - -pprDataConWithArgs :: DataCon -> SDoc -pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] - where - (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc - user_bndrs = dataConUserTyVarBinders dc - forAllDoc = pprUserForAll user_bndrs - thetaDoc = pprThetaArrowTy theta - argsDoc = hsep (fmap pprParendType arg_tys) - - -pprTypeApp :: TyCon -> [Type] -> SDoc -pprTypeApp tc tys - = pprIfaceTypeApp topPrec (toIfaceTyCon tc) - (toIfaceTcArgs tc tys) - -- TODO: toIfaceTcArgs seems rather wasteful here - ------------------- --- | Display all kind information (with @-fprint-explicit-kinds@) when the --- provided 'Bool' argument is 'True'. --- See @Note [Kind arguments in error messages]@ in TcErrors. -pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc -pprWithExplicitKindsWhen b - = updSDocDynFlags $ \dflags -> - if b then gopt_set dflags Opt_PrintExplicitKinds - else dflags - --- | This variant preserves any use of TYPE in a type, effectively --- locally setting -fprint-explicit-runtime-reps. -pprWithTYPE :: Type -> SDoc -pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $ - ppr ty - --- | Pretty prints a 'TyCon', using the family instance in case of a --- representation tycon. For example: --- --- > data T [a] = ... --- --- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' -pprSourceTyCon :: TyCon -> SDoc -pprSourceTyCon tycon - | Just (fam_tc, tys) <- tyConFamInst_maybe tycon - = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon - | otherwise - = ppr tycon diff --git a/types/TyCoPpr.hs-boot b/types/TyCoPpr.hs-boot deleted file mode 100644 --- a/types/TyCoPpr.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module TyCoPpr where - -import {-# SOURCE #-} TyCoRep (Type, Kind, Coercion, TyLit) -import Outputable - -pprType :: Type -> SDoc -pprKind :: Kind -> SDoc -pprCo :: Coercion -> SDoc -pprTyLit :: TyLit -> SDoc - diff --git a/types/TyCoRep.hs b/types/TyCoRep.hs deleted file mode 100644 --- a/types/TyCoRep.hs +++ /dev/null @@ -1,1690 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 -\section[TyCoRep]{Type and Coercion - friends' interface} - -Note [The Type-related module hierarchy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Class - CoAxiom - TyCon imports Class, CoAxiom - TyCoRep imports Class, CoAxiom, TyCon - TyCoPpr imports TyCoRep - TyCoFVs imports TyCoRep - TyCoSubst imports TyCoRep, TyCoFVs, TyCoPpr - TyCoTidy imports TyCoRep, TyCoFVs - TysPrim imports TyCoRep ( including mkTyConTy ) - Coercion imports Type --} - --- We expose the relevant stuff from this module via the Type module -{-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} - -module TyCoRep ( - TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, - - -- * Types - Type( TyVarTy, AppTy, TyConApp, ForAllTy - , LitTy, CastTy, CoercionTy - , FunTy, ft_arg, ft_res, ft_af - ), -- Export the type synonym FunTy too - - TyLit(..), - KindOrType, Kind, - KnotTied, - PredType, ThetaType, -- Synonyms - ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - - -- * Coercions - Coercion(..), - UnivCoProvenance(..), - CoercionHole(..), coHoleCoVar, setCoHoleCoVar, - CoercionN, CoercionR, CoercionP, KindCoercion, - MCoercion(..), MCoercionR, MCoercionN, - - -- * Functions over types - mkTyConTy, mkTyVarTy, mkTyVarTys, - mkTyCoVarTy, mkTyCoVarTys, - mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, - mkForAllTy, mkForAllTys, - mkPiTy, mkPiTys, - - -- * Functions over binders - TyCoBinder(..), TyCoVarBinder, TyBinder, - binderVar, binderVars, binderType, binderArgFlag, - delBinderVar, - isInvisibleArgFlag, isVisibleArgFlag, - isInvisibleBinder, isVisibleBinder, - isTyBinder, isNamedBinder, - - -- * Functions over coercions - pickLR, - - -- * Sizes - typeSize, coercionSize, provSize - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCoPpr ( pprType, pprCo, pprTyLit ) - - -- Transitively pulls in a LOT of stuff, better to break the loop - -import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) - --- friends: -import IfaceType -import Var -import VarSet -import Name hiding ( varName ) -import TyCon -import CoAxiom - --- others -import BasicTypes ( LeftOrRight(..), pickLR ) -import Outputable -import FastString -import Util - --- libraries -import qualified Data.Data as Data hiding ( TyCon ) -import Data.IORef ( IORef ) -- for CoercionHole - -{- -%************************************************************************ -%* * - TyThing -%* * -%************************************************************************ - -Despite the fact that DataCon has to be imported via a hi-boot route, -this module seems the right place for TyThing, because it's needed for -funTyCon and all the types in TysPrim. - -It is also SOURCE-imported into Name.hs - - -Note [ATyCon for classes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Both classes and type constructors are represented in the type environment -as ATyCon. You can tell the difference, and get to the class, with - isClassTyCon :: TyCon -> Bool - tyConClass_maybe :: TyCon -> Maybe Class -The Class and its associated TyCon have the same Name. --} - --- | A global typecheckable-thing, essentially anything that has a name. --- Not to be confused with a 'TcTyThing', which is also a typecheckable --- thing but in the *local* context. See 'TcEnv' for how to retrieve --- a 'TyThing' given a 'Name'. -data TyThing - = AnId Id - | AConLike ConLike - | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] - | ACoAxiom (CoAxiom Branched) - -instance Outputable TyThing where - ppr = pprShortTyThing - -instance NamedThing TyThing where -- Can't put this with the type - getName (AnId id) = getName id -- decl, because the DataCon instance - getName (ATyCon tc) = getName tc -- isn't visible there - getName (ACoAxiom cc) = getName cc - getName (AConLike cl) = conLikeName cl - -pprShortTyThing :: TyThing -> SDoc --- c.f. PprTyThing.pprTyThing, which prints all the details -pprShortTyThing thing - = pprTyThingCategory thing <+> quotes (ppr (getName thing)) - -pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory = text . capitalise . tyThingCategory - -tyThingCategory :: TyThing -> String -tyThingCategory (ATyCon tc) - | isClassTyCon tc = "class" - | otherwise = "type constructor" -tyThingCategory (ACoAxiom _) = "coercion axiom" -tyThingCategory (AnId _) = "identifier" -tyThingCategory (AConLike (RealDataCon _)) = "data constructor" -tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" - - -{- ********************************************************************** -* * - Type -* * -********************************************************************** -} - --- | The key representation of types within the compiler - -type KindOrType = Type -- See Note [Arguments to type constructors] - --- | The key type representing kinds in the compiler. -type Kind = Type - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Type - -- See Note [Non-trivial definitional equality] - = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) - - | AppTy - Type - Type -- ^ Type application to something other than a 'TyCon'. Parameters: - -- - -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', - -- must be another 'AppTy', or 'TyVarTy' - -- See Note [Respecting definitional equality] (EQ1) about the - -- no 'CastTy' requirement - -- - -- 2) Argument type - - | TyConApp - TyCon - [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. - -- Invariant: saturated applications of 'FunTyCon' must - -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's - -- do appear as 'TyConApp's. - -- Parameters: - -- - -- 1) Type constructor being applied to. - -- - -- 2) Type arguments. Might not have enough type arguments - -- here to saturate the constructor. - -- Even type synonyms are not necessarily saturated; - -- for example unsaturated type synonyms - -- can appear as the right hand side of a type synonym. - - | ForAllTy - {-# UNPACK #-} !TyCoVarBinder - Type -- ^ A Π type. - - | FunTy -- ^ t1 -> t2 Very common, so an important special case - -- See Note [Function types] - { ft_af :: AnonArgFlag -- Is this (->) or (=>)? - , ft_arg :: Type -- Argument type - , ft_res :: Type } -- Result type - - | LitTy TyLit -- ^ Type literals are similar to type constructors. - - | CastTy - Type - KindCoercion -- ^ A kind cast. The coercion is always nominal. - -- INVARIANT: The cast is never refl. - -- INVARIANT: The Type is not a CastTy (use TransCo instead) - -- See Note [Respecting definitional equality] (EQ2) and (EQ3) - - | CoercionTy - Coercion -- ^ Injection of a Coercion into a type - -- This should only ever be used in the RHS of an AppTy, - -- in the list of a TyConApp, when applying a promoted - -- GADT data constructor - - deriving Data.Data - -instance Outputable Type where - ppr = pprType - --- NOTE: Other parts of the code assume that type literals do not contain --- types or type variables. -data TyLit - = NumTyLit Integer - | StrTyLit FastString - deriving (Eq, Ord, Data.Data) - -instance Outputable TyLit where - ppr = pprTyLit - -{- Note [Function types] -~~~~~~~~~~~~~~~~~~~~~~~~ -FFunTy is the constructor for a function type. Lots of things to say -about it! - -* FFunTy is the data constructor, meaning "full function type". - -* The function type constructor (->) has kind - (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep - mkTyConApp ensure that we convert a saturated application - TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 - dropping the 'r1' and 'r2' arguments; they are easily recovered - from 't1' and 't2'. - -* The ft_af field says whether or not this is an invisible argument - VisArg: t1 -> t2 Ordinary function type - InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, - i.e. t1 :: Constraint - See Note [Types for coercions, predicates, and evidence] - - This visibility info makes no difference in Core; it matters - only when we regard the type as a Haskell source type. - -* FunTy is a (unidirectional) pattern synonym that allows - positional pattern matching (FunTy arg res), ignoring the - ArgFlag. --} - -{- ----------------------- - Commented out until the pattern match - checker can handle it; see #16185 - - For now we use the CPP macro #define FunTy FFunTy _ - (see HsVersions.h) to allow pattern matching on a - (positional) FunTy constructor. - -{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp - , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} - --- | 'FunTy' is a (uni-directional) pattern synonym for the common --- case where we want to match on the argument/result type, but --- ignoring the AnonArgFlag -pattern FunTy :: Type -> Type -> Type -pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } - - End of commented out block ----------------------------------- -} - -{- Note [Types for coercions, predicates, and evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat differently: - - (a) Predicate types - Test: isPredTy - Binders: DictIds - Kind: Constraint - Examples: (Eq a), and (a ~ b) - - (b) Coercion types are primitive, unboxed equalities - Test: isCoVarTy - Binders: CoVars (can appear in coercions) - Kind: TYPE (TupleRep []) - Examples: (t1 ~# t2) or (t1 ~R# t2) - - (c) Evidence types is the type of evidence manipulated by - the type constraint solver. - Test: isEvVarType - Binders: EvVars - Kind: Constraint or TYPE (TupleRep []) - Examples: all coercion types and predicate types - -Coercion types and predicate types are mutually exclusive, -but evidence types are a superset of both. - -When treated as a user type, - - - Predicates (of kind Constraint) are invisible and are - implicitly instantiated - - - Coercion types, and non-pred evidence types (i.e. not - of kind Constrain), are just regular old types, are - visible, and are not implicitly instantiated. - -In a FunTy { ft_af = InvisArg }, the argument type is always -a Predicate type. - -Note [Constraints in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do we allow a type constructor to have a kind like - S :: Eq a => a -> Type - -No, we do not. Doing so would mean would need a TyConApp like - S @k @(d :: Eq k) (ty :: k) - and we have no way to build, or decompose, evidence like - (d :: Eq k) at the type level. - -But we admit one exception: equality. We /do/ allow, say, - MkT :: (a ~ b) => a -> b -> Type a b - -Why? Because we can, without much difficulty. Moreover -we can promote a GADT data constructor (see TyCon -Note [Promoted data constructors]), like - data GT a b where - MkGT : a -> a -> GT a a -so programmers might reasonably expect to be able to -promote MkT as well. - -How does this work? - -* In TcValidity.checkConstraintsOK we reject kinds that - have constraints other than (a~b) and (a~~b). - -* In Inst.tcInstInvisibleTyBinder we instantiate a call - of MkT by emitting - [W] co :: alpha ~# beta - and producing the elaborated term - MkT @alpha @beta (Eq# alpha beta co) - We don't generate a boxed "Wanted"; we generate only a - regular old /unboxed/ primitive-equality Wanted, and build - the box on the spot. - -* How can we get such a MkT? By promoting a GADT-style data - constructor - data T a b where - MkT :: (a~b) => a -> b -> T a b - See DataCon.mkPromotedDataCon - and Note [Promoted data constructors] in TyCon - -* We support both homogeneous (~) and heterogeneous (~~) - equality. (See Note [The equality types story] - in TysPrim for a primer on these equality types.) - -* How do we prevent a MkT having an illegal constraint like - Eq a? We check for this at use-sites; see TcHsType.tcTyVar, - specifically dc_theta_illegal_constraint. - -* Notice that nothing special happens if - K :: (a ~# b) => blah - because (a ~# b) is not a predicate type, and is never - implicitly instantiated. (Mind you, it's not clear how you - could creates a type constructor with such a kind.) See - Note [Types for coercions, predicates, and evidence] - -* The existence of promoted MkT with an equality-constraint - argument is the (only) reason that the AnonTCB constructor - of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). - For example, when we promote the data constructor - MkT :: forall a b. (a~b) => a -> b -> T a b - we get a PromotedDataCon with tyConBinders - Bndr (a :: Type) (NamedTCB Inferred) - Bndr (b :: Type) (NamedTCB Inferred) - Bndr (_ :: a ~ b) (AnonTCB InvisArg) - Bndr (_ :: a) (AnonTCB VisArg)) - Bndr (_ :: b) (AnonTCB VisArg)) - -* One might reasonably wonder who *unpacks* these boxes once they are - made. After all, there is no type-level `case` construct. The - surprising answer is that no one ever does. Instead, if a GADT - constructor is used on the left-hand side of a type family equation, - that occurrence forces GHC to unify the types in question. For - example: - - data G a where - MkG :: G Bool - - type family F (x :: G a) :: a where - F MkG = False - - When checking the LHS `F MkG`, GHC sees the MkG constructor and then must - unify F's implicit parameter `a` with Bool. This succeeds, making the equation - - F Bool (MkG @Bool ) = False - - Note that we never need unpack the coercion. This is because type - family equations are *not* parametric in their kind variables. That - is, we could have just said - - type family H (x :: G a) :: a where - H _ = False - - The presence of False on the RHS also forces `a` to become Bool, - giving us - - H Bool _ = False - - The fact that any of this works stems from the lack of phase - separation between types and kinds (unlike the very present phase - separation between terms and types). - - Once we have the ability to pattern-match on types below top-level, - this will no longer cut it, but it seems fine for now. - - -Note [Arguments to type constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of kind polymorphism, in addition to type application we now -have kind instantiation. We reuse the same notations to do so. - -For example: - - Just (* -> *) Maybe - Right * Nat Zero - -are represented by: - - TyConApp (PromotedDataCon Just) [* -> *, Maybe] - TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] - -Important note: Nat is used as a *kind* and not as a type. This can be -confusing, since type-level Nat and kind-level Nat are identical. We -use the kind of (PromotedDataCon Right) to know if its arguments are -kinds or types. - -This kind instantiation only happens in TyConApp currently. - -Note [Non-trivial definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is Int |> <*> the same as Int? YES! In order to reduce headaches, -we decide that any reflexive casts in types are just ignored. -(Indeed they must be. See Note [Respecting definitional equality].) -More generally, the `eqType` function, which defines Core's type equality -relation, ignores casts and coercion arguments, as long as the -two types have the same kind. This allows us to be a little sloppier -in keeping track of coercions, which is a good thing. It also means -that eqType does not depend on eqCoercion, which is also a good thing. - -Why is this sensible? That is, why is something different than α-equivalence -appropriate for the implementation of eqType? - -Anything smaller than ~ and homogeneous is an appropriate definition for -equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any -expression of type τ can be transmuted to one of type σ at any point by -casting. The same is true of expressions of type σ. So in some sense, τ and σ -are interchangeable. - -But let's be more precise. If we examine the typing rules of FC (say, those in -https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) -there are several places where the same metavariable is used in two different -premises to a rule. (For example, see Ty_App.) There is an implicit equality -check here. What definition of equality should we use? By convention, we use -α-equivalence. Take any rule with one (or more) of these implicit equality -checks. Then there is an admissible rule that uses ~ instead of the implicit -check, adding in casts as appropriate. - -The only problem here is that ~ is heterogeneous. To make the kinds work out -in the admissible rule that uses ~, it is necessary to homogenize the -coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; -we use η |> kind η, which is homogeneous. - -The effect of this all is that eqType, the implementation of the implicit -equality check, can use any homogeneous relation that is smaller than ~, as -those rules must also be admissible. - -A more drawn out argument around all of this is presented in Section 7.2 of -Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). - -What would go wrong if we insisted on the casts matching? See the beginning of -Section 8 in the unpublished paper above. Theoretically, nothing at all goes -wrong. But in practical terms, getting the coercions right proved to be -nightmarish. And types would explode: during kind-checking, we often produce -reflexive kind coercions. When we try to cast by these, mkCastTy just discards -them. But if we used an eqType that distinguished between Int and Int |> <*>, -then we couldn't discard -- the output of kind-checking would be enormous, -and we would need enormous casts with lots of CoherenceCo's to straighten -them out. - -Would anything go wrong if eqType respected type families? No, not at all. But -that makes eqType rather hard to implement. - -Thus, the guideline for eqType is that it should be the largest -easy-to-implement relation that is still smaller than ~ and homogeneous. The -precise choice of relation is somewhat incidental, as long as the smart -constructors and destructors in Type respect whatever relation is chosen. - -Another helpful principle with eqType is this: - - (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. - -This principle also tells us that eqType must relate only types with the -same kinds. - -Note [Respecting definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [Non-trivial definitional equality] introduces the property (EQ). -How is this upheld? - -Any function that pattern matches on all the constructors will have to -consider the possibility of CastTy. Presumably, those functions will handle -CastTy appropriately and we'll be OK. - -More dangerous are the splitXXX functions. Let's focus on splitTyConApp. -We don't want it to fail on (T a b c |> co). Happily, if we have - (T a b c |> co) `eqType` (T d e f) -then co must be reflexive. Why? eqType checks that the kinds are equal, as -well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). -By the kind check, we know that (T a b c |> co) and (T d e f) have the same -kind. So the only way that co could be non-reflexive is for (T a b c) to have -a different kind than (T d e f). But because T's kind is closed (all tycon kinds -are closed), the only way for this to happen is that one of the arguments has -to differ, leading to a contradiction. Thus, co is reflexive. - -Accordingly, by eliminating reflexive casts, splitTyConApp need not worry -about outermost casts to uphold (EQ). Eliminating reflexive casts is done -in mkCastTy. - -Unforunately, that's not the end of the story. Consider comparing - (T a b c) =? (T a b |> (co -> )) (c |> co) -These two types have the same kind (Type), but the left type is a TyConApp -while the right type is not. To handle this case, we say that the right-hand -type is ill-formed, requiring an AppTy never to have a casted TyConApp -on its left. It is easy enough to pull around the coercions to maintain -this invariant, as done in Type.mkAppTy. In the example above, trying to -form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). -Both the casts there are reflexive and will be dropped. Huzzah. - -This idea of pulling coercions to the right works for splitAppTy as well. - -However, there is one hiccup: it's possible that a coercion doesn't relate two -Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, -then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't -be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not -`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate -our (EQ) property. - -Lastly, in order to detect reflexive casts reliably, we must make sure not -to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). - -In sum, in order to uphold (EQ), we need the following three invariants: - - (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable - cast is one that relates either a FunTy to a FunTy or a - ForAllTy to a ForAllTy. - (EQ2) No reflexive casts in CastTy. - (EQ3) No nested CastTys. - (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). - See Note [Weird typing rule for ForAllTy] in Type. - -These invariants are all documented above, in the declaration for Type. - -Note [Unused coercion variable in ForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - \(co:t1 ~ t2). e - -What type should we give to this expression? - (1) forall (co:t1 ~ t2) -> t - (2) (t1 ~ t2) -> t - -If co is used in t, (1) should be the right choice. -if co is not used in t, we would like to have (1) and (2) equivalent. - -However, we want to keep eqType simple and don't want eqType (1) (2) to return -True in any case. - -We decide to always construct (2) if co is not used in t. - -Thus in mkLamType, we check whether the variable is a coercion -variable (of type (t1 ~# t2), and whether it is un-used in the -body. If so, it returns a FunTy instead of a ForAllTy. - -There are cases we want to skip the check. For example, the check is -unnecessary when it is known from the context that the input variable -is a type variable. In those cases, we use mkForAllTy. - --} - --- | A type labeled 'KnotTied' might have knot-tied tycons in it. See --- Note [Type checking recursive type and class declarations] in --- TcTyClsDecls -type KnotTied ty = ty - -{- ********************************************************************** -* * - TyCoBinder and ArgFlag -* * -********************************************************************** -} - --- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be --- dependent ('Named') or nondependent ('Anon'). They may also be visible or --- not. See Note [TyCoBinders] -data TyCoBinder - = Named TyCoVarBinder -- A type-lambda binder - | Anon AnonArgFlag Type -- A term-lambda binder. Type here can be CoercionTy. - -- Visibility is determined by the AnonArgFlag - deriving Data.Data - -instance Outputable TyCoBinder where - ppr (Anon af ty) = ppr af <+> ppr ty - ppr (Named (Bndr v Required)) = ppr v - ppr (Named (Bndr v Specified)) = char '@' <> ppr v - ppr (Named (Bndr v Inferred)) = braces (ppr v) - - --- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' --- in the 'Named' field. -type TyBinder = TyCoBinder - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVar :: VarSet -> TyCoVarBinder -> VarSet -delBinderVar vars (Bndr tv _) = vars `delVarSet` tv - --- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyCoBinder -> Bool -isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis -isInvisibleBinder (Anon InvisArg _) = True -isInvisibleBinder (Anon VisArg _) = False - --- | Does this binder bind a visible argument? -isVisibleBinder :: TyCoBinder -> Bool -isVisibleBinder = not . isInvisibleBinder - -isNamedBinder :: TyCoBinder -> Bool -isNamedBinder (Named {}) = True -isNamedBinder (Anon {}) = False - --- | If its a named binder, is the binder a tyvar? --- Returns True for nondependent binder. --- This check that we're really returning a *Ty*Binder (as opposed to a --- coercion binder). That way, if/when we allow coercion quantification --- in more places, we'll know we missed updating some function. -isTyBinder :: TyCoBinder -> Bool -isTyBinder (Named bnd) = isTyVarBinder bnd -isTyBinder _ = True - -{- Note [TyCoBinders] -~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyCoVarBinder. But a type can be decomposed -to a telescope consisting of a [TyCoBinder] - -A TyCoBinder represents the type of binders -- that is, the type of an -argument to a Pi-type. GHC Core currently supports two different -Pi-types: - - * A non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. - - * A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty - -Both Pi-types classify terms/types that take an argument. In other -words, if `x` is either a function or a polytype, `x arg` makes sense -(for an appropriate `arg`). - - -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. - Each TyCoVarBinder - Bndr a tvis - is equipped with tvis::ArgFlag, which says whether or not arguments - for this binder should be visible (explicit) in source Haskell. - -* A TyCon contains a list of TyConBinders. Each TyConBinder - Bndr a cvis - is equipped with cvis::TyConBndrVis, which says whether or not type - and kind arguments for this TyCon should be visible (explicit) in - source Haskell. - -This table summarises the visibility rules: ---------------------------------------------------------------------------------------- -| Occurrences look like this -| GHC displays type as in Haskell source code -|-------------------------------------------------------------------------------------- -| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term -| tvis :: ArgFlag -| tvis = Inferred: f :: forall {a}. type Arg not allowed: f - f :: forall {co}. type Arg not allowed: f -| tvis = Specified: f :: forall a. type Arg optional: f or f @Int -| tvis = Required: T :: forall k -> type Arg required: T * -| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] -| -| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon -| cvis :: TyConBndrVis -| cvis = AnonTCB: T :: kind -> kind Required: T * -| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T -| T :: forall {co}. kind Arg not allowed: T -| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T -| cvis = NamedTCB Required: T :: forall k -> kind Required: T * ---------------------------------------------------------------------------------------- - -[1] In types, in the Specified case, it would make sense to allow - optional kind applications, thus (T @*), but we have not - yet implemented that - ----- In term declarations ---- - -* Inferred. Function defn, with no signature: f1 x = x - We infer f1 :: forall {a}. a -> a, with 'a' Inferred - It's Inferred because it doesn't appear in any - user-written signature for f1 - -* Specified. Function defn, with signature (implicit forall): - f2 :: a -> a; f2 x = x - So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified - even though 'a' is not bound in the source code by an explicit forall - -* Specified. Function defn, with signature (explicit forall): - f3 :: forall a. a -> a; f3 x = x - So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified - -* Inferred/Specified. Function signature with inferred kind polymorphism. - f4 :: a b -> Int - So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int - Here 'k' is Inferred (it's not mentioned in the type), - but 'a' and 'b' are Specified. - -* Specified. Function signature with explicit kind polymorphism - f5 :: a (b :: k) -> Int - This time 'k' is Specified, because it is mentioned explicitly, - so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int - -* Similarly pattern synonyms: - Inferred - from inferred types (e.g. no pattern type signature) - - or from inferred kind polymorphism - ----- In type declarations ---- - -* Inferred (k) - data T1 a b = MkT1 (a b) - Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * - The kind variable 'k' is Inferred, since it is not mentioned - - Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, - and Anon binders don't have a visibility flag. (Or you could think - of Anon having an implicit Required flag.) - -* Specified (k) - data T2 (a::k->*) b = MkT (a b) - Here T's kind is T :: forall (k:*). (k->*) -> k -> * - The kind variable 'k' is Specified, since it is mentioned in - the signature. - -* Required (k) - data T k (a::k->*) b = MkT (a b) - Here T's kind is T :: forall k:* -> (k->*) -> k -> * - The kind is Required, since it bound in a positional way in T's declaration - Every use of T must be explicitly applied to a kind - -* Inferred (k1), Specified (k) - data T a b (c :: k) = MkT (a b) (Proxy c) - Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * - So 'k' is Specified, because it appears explicitly, - but 'k1' is Inferred, because it does not - -Generally, in the list of TyConBinders for a TyCon, - -* Inferred arguments always come first -* Specified, Anon and Required can be mixed - -e.g. - data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... - -Here Foo's TyConBinders are - [Required 'a', Specified 'b', Anon] -and its kind prints as - Foo :: forall a -> forall b. (a -> b -> Type) -> Type - -See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls - ----- Printing ----- - - We print forall types with enough syntax to tell you their visibility - flag. But this is not source Haskell, and these types may not all - be parsable. - - Specified: a list of Specified binders is written between `forall` and `.`: - const :: forall a b. a -> b -> a - - Inferred: with -fprint-explicit-foralls, Inferred binders are written - in braces: - f :: forall {k} (a:k). S k a -> Int - Otherwise, they are printed like Specified binders. - - Required: binders are put between `forall` and `->`: - T :: forall k -> * - ----- Other points ----- - -* In classic Haskell, all named binders (that is, the type variables in - a polymorphic function type f :: forall a. a -> a) have been Inferred. - -* Inferred variables correspond to "generalized" variables from the - Visible Type Applications paper (ESOP'16). - -Note [No Required TyCoBinder in terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Required foralls for term variables, including pattern -synonyms and data constructors. Why? Because then an application -would need a /compulsory/ type argument (possibly without an "@"?), -thus (f Int); and we don't have concrete syntax for that. - -We could change this decision, but Required, Named TyCoBinders are rare -anyway. (Most are Anons.) - -However the type of a term can (just about) have a required quantifier; -see Note [Required quantifiers in the type of a term] in TcExpr. --} - - -{- ********************************************************************** -* * - PredType -* * -********************************************************************** -} - - --- | A type of the form @p@ of constraint kind represents a value whose type is --- the Haskell predicate @p@, where a predicate is what occurs before --- the @=>@ in a Haskell type. --- --- We use 'PredType' as documentation to mark those types that we guarantee to --- have this kind. --- --- It can be expanded into its representation, but: --- --- * The type checker must treat it as opaque --- --- * The rest of the compiler treats it as transparent --- --- Consider these examples: --- --- > f :: (Eq a) => a -> Int --- > g :: (?x :: Int -> Int) => a -> Int --- > h :: (r\l) => {r} => {l::Int | r} --- --- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -type PredType = Type - --- | A collection of 'PredType's -type ThetaType = [PredType] - -{- -(We don't support TREX records yet, but the setup is designed -to expand to allow them.) - -A Haskell qualified type, such as that for f,g,h above, is -represented using - * a FunTy for the double arrow - * with a type of kind Constraint as the function argument - -The predicate really does turn into a real extra argument to the -function. If the argument has type (p :: Constraint) then the predicate p is -represented by evidence of type p. - - -%************************************************************************ -%* * - Simple constructors -%* * -%************************************************************************ - -These functions are here so that they can be used by TysPrim, -which in turn is imported by Type --} - -mkTyVarTy :: TyVar -> Type -mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) - TyVarTy v - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - -mkTyCoVarTy :: TyCoVar -> Type -mkTyCoVarTy v - | isTyVar v - = TyVarTy v - | otherwise - = CoercionTy (CoVarCo v) - -mkTyCoVarTys :: [TyCoVar] -> [Type] -mkTyCoVarTys = map mkTyCoVarTy - -infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right - -mkFunTy :: AnonArgFlag -> Type -> Type -> Type -mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } - -mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type -mkVisFunTy = mkFunTy VisArg -mkInvisFunTy = mkFunTy InvisArg - --- | Make nested arrow types -mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type -mkVisFunTys tys ty = foldr mkVisFunTy ty tys -mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys - --- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder --- See Note [Unused coercion variable in ForAllTy] -mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type -mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty - --- | Wraps foralls over the type using the provided 'TyCoVar's from left to right -mkForAllTys :: [TyCoVarBinder] -> Type -> Type -mkForAllTys tyvars ty = foldr ForAllTy ty tyvars - -mkPiTy:: TyCoBinder -> Type -> Type -mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } -mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty - -mkPiTys :: [TyCoBinder] -> Type -> Type -mkPiTys tbs ty = foldr mkPiTy ty tbs - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = TyConApp tycon [] - -{- -%************************************************************************ -%* * - Coercions -%* * -%************************************************************************ --} - --- | A 'Coercion' is concrete evidence of the equality/convertibility --- of two types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Coercion - -- Each constructor has a "role signature", indicating the way roles are - -- propagated through coercions. - -- - P, N, and R stand for coercions of the given role - -- - e stands for a coercion of a specific unknown role - -- (think "role polymorphism") - -- - "e" stands for an explicit role parameter indicating role e. - -- - _ stands for a parameter that is not a Role or Coercion. - - -- These ones mirror the shape of types - = -- Refl :: _ -> N - Refl Type -- See Note [Refl invariant] - -- Invariant: applications of (Refl T) to a bunch of identity coercions - -- always show up as Refl. - -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). - - -- Applications of (Refl T) to some coercions, at least one of - -- which is NOT the identity, show up as TyConAppCo. - -- (They may not be fully saturated however.) - -- ConAppCo coercions (like all coercions other than Refl) - -- are NEVER the identity. - - -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) - - -- GRefl :: "e" -> _ -> Maybe N -> e - -- See Note [Generalized reflexive coercion] - | GRefl Role Type MCoercionN -- See Note [Refl invariant] - -- Use (Refl ty), not (GRefl Nominal ty MRefl) - -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) - - -- These ones simply lift the correspondingly-named - -- Type constructors into Coercions - - -- TyConAppCo :: "e" -> _ -> ?? -> e - -- See Note [TyConAppCo roles] - | TyConAppCo Role TyCon [Coercion] -- lift TyConApp - -- The TyCon is never a synonym; - -- we expand synonyms eagerly - -- But it can be a type function - - | AppCo Coercion CoercionN -- lift AppTy - -- AppCo :: e -> N -> e - - -- See Note [Forall coercions] - | ForAllCo TyCoVar KindCoercion Coercion - -- ForAllCo :: _ -> N -> e -> e - - | FunCo Role Coercion Coercion -- lift FunTy - -- FunCo :: "e" -> e -> e -> e - -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? - -- Because the AnonArgFlag has no impact on Core; it is only - -- there to guide implicit instantiation of Haskell source - -- types, and that is irrelevant for coercions, which are - -- Core-only. - - -- These are special - | CoVarCo CoVar -- :: _ -> (N or R) - -- result role depends on the tycon of the variable's type - - -- AxiomInstCo :: e -> _ -> ?? -> e - | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] - -- See also [CoAxiom index] - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. - -- See [Coercion axioms applied to coercions] - -- The roles of the argument coercions are determined - -- by the cab_roles field of the relevant branch of the CoAxiom - - | AxiomRuleCo CoAxiomRule [Coercion] - -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule - -- The number coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - - | UnivCo UnivCoProvenance Role Type Type - -- :: _ -> "e" -> _ -> _ -> e - - | SymCo Coercion -- :: e -> e - | TransCo Coercion Coercion -- :: e -> e -> e - - | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- Using NthCo on a ForAllCo gives an N coercion always - -- See Note [NthCo and newtypes] - -- - -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) - -- That is: the role of the entire coercion is redundantly cached here. - -- See Note [NthCo Cached Roles] - - | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) - -- :: _ -> N -> N - | InstCo Coercion CoercionN - -- :: e -> N -> e - -- See Note [InstCo roles] - - -- Extract a kind coercion from a (heterogeneous) type coercion - -- NB: all kind coercions are Nominal - | KindCo Coercion - -- :: e -> N - - | SubCo CoercionN -- Turns a ~N into a ~R - -- :: N -> R - - | HoleCo CoercionHole -- ^ See Note [Coercion holes] - -- Only present during typechecking - deriving Data.Data - -type CoercionN = Coercion -- always nominal -type CoercionR = Coercion -- always representational -type CoercionP = Coercion -- always phantom -type KindCoercion = CoercionN -- always nominal - -instance Outputable Coercion where - ppr = pprCo - --- | A semantically more meaningful type to represent what may or may not be a --- useful 'Coercion'. -data MCoercion - = MRefl - -- A trivial Reflexivity coercion - | MCo Coercion - -- Other coercions - deriving Data.Data -type MCoercionR = MCoercion -type MCoercionN = MCoercion - -instance Outputable MCoercion where - ppr MRefl = text "MRefl" - ppr (MCo co) = text "MCo" <+> ppr co - -{- -Note [Refl invariant] -~~~~~~~~~~~~~~~~~~~~~ -Invariant 1: - -Coercions have the following invariant - Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. - -You might think that a consequencs is: - Every identity coercions has Refl at the root - -But that's not quite true because of coercion variables. Consider - g where g :: Int~Int - Left h where h :: Maybe Int ~ Maybe Int -etc. So the consequence is only true of coercions that -have no coercion variables. - -Note [Generalized reflexive coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GRefl is a generalized reflexive coercion (see #15192). It wraps a kind -coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing -rules for GRefl: - - ty : k1 - ------------------------------------ - GRefl r ty MRefl: ty ~r ty - - ty : k1 co :: k1 ~ k2 - ------------------------------------ - GRefl r ty (MCo co) : ty ~r ty |> co - -Consider we have - - g1 :: s ~r t - s :: k1 - g2 :: k1 ~ k2 - -and we want to construct a coercions co which has type - - (s |> g2) ~r t - -We can define - - co = Sym (GRefl r s g2) ; g1 - -It is easy to see that - - Refl == GRefl Nominal ty MRefl :: ty ~n ty - -A nominal reflexive coercion is quite common, so we keep the special form Refl to -save allocation. - -Note [Coercion axioms applied to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The reason coercion axioms can be applied to coercions and not just -types is to allow for better optimization. There are some cases where -we need to be able to "push transitivity inside" an axiom in order to -expose further opportunities for optimization. - -For example, suppose we have - - C a : t[a] ~ F a - g : b ~ c - -and we want to optimize - - sym (C b) ; t[g] ; C c - -which has the kind - - F b ~ F c - -(stopping through t[b] and t[c] along the way). - -We'd like to optimize this to just F g -- but how? The key is -that we need to allow axioms to be instantiated by *coercions*, -not just by types. Then we can (in certain cases) push -transitivity inside the axiom instantiations, and then react -opposite-polarity instantiations of the same axiom. In this -case, e.g., we match t[g] against the LHS of (C c)'s kind, to -obtain the substitution a |-> g (note this operation is sort -of the dual of lifting!) and hence end up with - - C g : t[b] ~ F c - -which indeed has the same kind as t[g] ; C c. - -Now we have - - sym (C b) ; C g - -which can be optimized to F g. - -Note [CoAxiom index] -~~~~~~~~~~~~~~~~~~~~ -A CoAxiom has 1 or more branches. Each branch has contains a list -of the free type variables in that branch, the LHS type patterns, -and the RHS type for that branch. When we apply an axiom to a list -of coercions, we must choose which branch of the axiom we wish to -use, as the different branches may have different numbers of free -type variables. (The number of type patterns is always the same -among branches, but that doesn't quite concern us here.) - -The Int in the AxiomInstCo constructor is the 0-indexed number -of the chosen branch. - -Note [Forall coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -Constructing coercions between forall-types can be a bit tricky, -because the kinds of the bound tyvars can be different. - -The typing rule is: - - - kind_co : k1 ~ k2 - tv1:k1 |- co : t1 ~ t2 - ------------------------------------------------------------------- - ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ - all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) - -First, the TyCoVar stored in a ForAllCo is really an optimisation: this field -should be a Name, as its kind is redundant. Thinking of the field as a Name -is helpful in understanding what a ForAllCo means. -The kind of TyCoVar always matches the left-hand kind of the coercion. - -The idea is that kind_co gives the two kinds of the tyvar. See how, in the -conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. - -Of course, a type variable can't have different kinds at the same time. So, -we arbitrarily prefer the first kind when using tv1 in the inner coercion -co, which shows that t1 equals t2. - -The last wrinkle is that we need to fix the kinds in the conclusion. In -t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of -the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with -(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it -mentions the same name with different kinds, but it *is* well-kinded, noting -that `(tv1:k2) |> sym kind_co` has kind k1. - -This all really would work storing just a Name in the ForAllCo. But we can't -add Names to, e.g., VarSets, and there generally is just an impedance mismatch -in a bunch of places. So we use tv1. When we need tv2, we can use -setTyVarKind. - -Note [Predicate coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: a~b -How can we coerce between types - ([c]~a) => [a] -> c -and - ([c]~b) => [b] -> c -where the equality predicate *itself* differs? - -Answer: we simply treat (~) as an ordinary type constructor, so these -types really look like - - ((~) [c] a) -> [a] -> c - ((~) [c] b) -> [b] -> c - -So the coercion between the two is obviously - - ((~) [c] g) -> [g] -> c - -Another way to see this to say that we simply collapse predicates to -their representation type (see Type.coreView and Type.predTypeRep). - -This collapse is done by mkPredCo; there is no PredCo constructor -in Coercion. This is important because we need Nth to work on -predicates too: - Nth 1 ((~) [c] g) = g -See Simplify.simplCoercionF, which generates such selections. - -Note [Roles] -~~~~~~~~~~~~ -Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated -in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see -https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation - -Here is one way to phrase the problem: - -Given: -newtype Age = MkAge Int -type family F x -type instance F Age = Bool -type instance F Int = Char - -This compiles down to: -axAge :: Age ~ Int -axF1 :: F Age ~ Bool -axF2 :: F Int ~ Char - -Then, we can make: -(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char - -Yikes! - -The solution is _roles_, as articulated in "Generative Type Abstraction and -Type-level Computation" (POPL 2010), available at -http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf - -The specification for roles has evolved somewhat since that paper. For the -current full details, see the documentation in docs/core-spec. Here are some -highlights. - -We label every equality with a notion of type equivalence, of which there are -three options: Nominal, Representational, and Phantom. A ground type is -nominally equivalent only with itself. A newtype (which is considered a ground -type in Haskell) is representationally equivalent to its representation. -Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" -to denote the equivalences. - -The axioms above would be: -axAge :: Age ~R Int -axF1 :: F Age ~N Bool -axF2 :: F Age ~N Char - -Then, because transitivity applies only to coercions proving the same notion -of equivalence, the above construction is impossible. - -However, there is still an escape hatch: we know that any two types that are -nominally equivalent are representationally equivalent as well. This is what -the form SubCo proves -- it "demotes" a nominal equivalence into a -representational equivalence. So, it would seem the following is possible: - -sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG - -What saves us here is that the arguments to a type function F, lifted into a -coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and -we are safe. - -Roles are attached to parameters to TyCons. When lifting a TyCon into a -coercion (through TyConAppCo), we need to ensure that the arguments to the -TyCon respect their roles. For example: - -data T a b = MkT a (F b) - -If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know -that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because -the type function F branches on b's *name*, not representation. So, we say -that 'a' has role Representational and 'b' has role Nominal. The third role, -Phantom, is for parameters not used in the type's definition. Given the -following definition - -data Q a = MkQ Int - -the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we -can construct the coercion Bool ~P Char (using UnivCo). - -See the paper cited above for more examples and information. - -Note [TyConAppCo roles] -~~~~~~~~~~~~~~~~~~~~~~~ -The TyConAppCo constructor has a role parameter, indicating the role at -which the coercion proves equality. The choice of this parameter affects -the required roles of the arguments of the TyConAppCo. To help explain -it, assume the following definition: - - type instance F Int = Bool -- Axiom axF : F Int ~N Bool - newtype Age = MkAge Int -- Axiom axAge : Age ~R Int - data Foo a = MkFoo a -- Role on Foo's parameter is Representational - -TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool - For (TyConAppCo Nominal) all arguments must have role Nominal. Why? - So that Foo Age ~N Foo Int does *not* hold. - -TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool -TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int - For (TyConAppCo Representational), all arguments must have the roles - corresponding to the result of tyConRoles on the TyCon. This is the - whole point of having roles on the TyCon to begin with. So, we can - have Foo Age ~R Foo Int, if Foo's parameter has role R. - - If a Representational TyConAppCo is over-saturated (which is otherwise fine), - the spill-over arguments must all be at Nominal. This corresponds to the - behavior for AppCo. - -TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool - All arguments must have role Phantom. This one isn't strictly - necessary for soundness, but this choice removes ambiguity. - -The rules here dictate the roles of the parameters to mkTyConAppCo -(should be checked by Lint). - -Note [NthCo and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype N a = MkN Int - type role N representational - -This yields axiom - - NTCo:N :: forall a. N a ~R Int - -We can then build - - co :: forall a b. N a ~R N b - co = NTCo:N a ; sym (NTCo:N b) - -for any `a` and `b`. Because of the role annotation on N, if we use -NthCo, we'll get out a representational coercion. That is: - - NthCo r 0 co :: forall a b. a ~R b - -Yikes! Clearly, this is terrible. The solution is simple: forbid -NthCo to be used on newtypes if the internal coercion is representational. - -This is not just some corner case discovered by a segfault somewhere; -it was discovered in the proof of soundness of roles and described -in the "Safe Coercions" paper (ICFP '14). - -Note [NthCo Cached Roles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we cache the role of NthCo in the NthCo constructor? -Because computing role(Nth i co) involves figuring out that - - co :: T tys1 ~ T tys2 - -using coercionKind, and finding (coercionRole co), and then looking -at the tyConRoles of T. Avoiding bad asymptotic behaviour here means -we have to compute the kind and role of a coercion simultaneously, -which makes the code complicated and inefficient. - -This only happens for NthCo. Caching the role solves the problem, and -allows coercionKind and coercionRole to be simple. - -See #11735 - -Note [InstCo roles] -~~~~~~~~~~~~~~~~~~~ -Here is (essentially) the typing rule for InstCo: - -g :: (forall a. t1) ~r (forall a. t2) -w :: s1 ~N s2 -------------------------------- InstCo -InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) - -Note that the Coercion w *must* be nominal. This is necessary -because the variable a might be used in a "nominal position" -(that is, a place where role inference would require a nominal -role) in t1 or t2. If we allowed w to be representational, we -could get bogus equalities. - -A more nuanced treatment might be able to relax this condition -somewhat, by checking if t1 and/or t2 use their bound variables -in nominal ways. If not, having w be representational is OK. - - -%************************************************************************ -%* * - UnivCoProvenance -%* * -%************************************************************************ - -A UnivCo is a coercion whose proof does not directly express its role -and kind (indeed for some UnivCos, like UnsafeCoerceProv, there /is/ -no proof). - -The different kinds of UnivCo are described by UnivCoProvenance. Really -each is entirely separate, but they all share the need to represent their -role and kind, which is done in the UnivCo constructor. - --} - --- | For simplicity, we have just one UnivCo that represents a coercion from --- some type to some other type, with (in general) no restrictions on the --- type. The UnivCoProvenance specifies more exactly what the coercion really --- is and why a program should (or shouldn't!) trust the coercion. --- It is reasonable to consider each constructor of 'UnivCoProvenance' --- as a totally independent coercion form; their only commonality is --- that they don't tell you what types they coercion between. (That info --- is in the 'UnivCo' constructor of 'Coercion'. -data UnivCoProvenance - = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. - - | PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom - -- roled coercions - - | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are - -- considered equivalent. See Note [ProofIrrelProv]. - -- Can be used in Nominal or Representational coercions - - | PluginProv String -- ^ From a plugin, which asserts that this coercion - -- is sound. The string is for the use of the plugin. - - deriving Data.Data - -instance Outputable UnivCoProvenance where - ppr UnsafeCoerceProv = text "(unsafeCoerce#)" - ppr (PhantomProv _) = text "(phantom)" - ppr (ProofIrrelProv _) = text "(proof irrel.)" - ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) - --- | A coercion to be filled in by the type-checker. See Note [Coercion holes] -data CoercionHole - = CoercionHole { ch_co_var :: CoVar - -- See Note [CoercionHoles and coercion free variables] - - , ch_ref :: IORef (Maybe Coercion) - } - -coHoleCoVar :: CoercionHole -> CoVar -coHoleCoVar = ch_co_var - -setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole -setCoHoleCoVar h cv = h { ch_co_var = cv } - -instance Data.Data CoercionHole where - -- don't traverse? - toConstr _ = abstractConstr "CoercionHole" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoercionHole" - -instance Outputable CoercionHole where - ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) - - -{- Note [Phantom coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = T1 | T2 -Then we have - T s ~R T t -for any old s,t. The witness for this is (TyConAppCo T Rep co), -where (co :: s ~P t) is a phantom coercion built with PhantomProv. -The role of the UnivCo is always Phantom. The Coercion stored is the -(nominal) kind coercion between the types - kind(s) ~N kind (t) - -Note [Coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~ -During typechecking, constraint solving for type classes works by - - Generate an evidence Id, d7 :: Num a - - Wrap it in a Wanted constraint, [W] d7 :: Num a - - Use the evidence Id where the evidence is needed - - Solve the constraint later - - When solved, add an enclosing let-binding let d7 = .... in .... - which actually binds d7 to the (Num a) evidence - -For equality constraints we use a different strategy. See Note [The -equality types story] in TysPrim for background on equality constraints. - - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just - like type classes above. (Indeed, boxed equality constraints *are* classes.) - - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) - we use a different plan - -For unboxed equalities: - - Generate a CoercionHole, a mutable variable just like a unification - variable - - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest - - Use the CoercionHole in a Coercion, via HoleCo - - Solve the constraint later - - When solved, fill in the CoercionHole by side effect, instead of - doing the let-binding thing - -The main reason for all this is that there may be no good place to let-bind -the evidence for unboxed equalities: - - - We emit constraints for kind coercions, to be used to cast a - type's kind. These coercions then must be used in types. Because - they might appear in a top-level type, there is no place to bind - these (unlifted) coercions in the usual way. - - - A coercion for (forall a. t1) ~ (forall a. t2) will look like - forall a. (coercion for t1~t2) - But the coercion for (t1~t2) may mention 'a', and we don't have - let-bindings within coercions. We could add them, but coercion - holes are easier. - - - Moreover, nothing is lost from the lack of let-bindings. For - dicionaries want to achieve sharing to avoid recomoputing the - dictionary. But coercions are entirely erased, so there's little - benefit to sharing. Indeed, even if we had a let-binding, we - always inline types and coercions at every use site and drop the - binding. - -Other notes about HoleCo: - - * INVARIANT: CoercionHole and HoleCo are used only during type checking, - and should never appear in Core. Just like unification variables; a Type - can contain a TcTyVar, but only during type checking. If, one day, we - use type-level information to separate out forms that can appear during - type-checking vs forms that can appear in core proper, holes in Core will - be ruled out. - - * See Note [CoercionHoles and coercion free variables] - - * Coercion holes can be compared for equality like other coercions: - by looking at the types coerced. - - -Note [CoercionHoles and coercion free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why does a CoercionHole contain a CoVar, as well as reference to -fill in? Because we want to treat that CoVar as a free variable of -the coercion. See #14584, and Note [What prevents a -constraint from floating] in TcSimplify, item (4): - - forall k. [W] co1 :: t1 ~# t2 |> co2 - [W] co2 :: k ~# * - -Here co2 is a CoercionHole. But we /must/ know that it is free in -co1, because that's all that stops it floating outside the -implication. - - -Note [ProofIrrelProv] -~~~~~~~~~~~~~~~~~~~~~ -A ProofIrrelProv is a coercion between coercions. For example: - - data G a where - MkG :: G Bool - -In core, we get - - G :: * -> * - MkG :: forall (a :: *). (a ~ Bool) -> G a - -Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want -a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be - - TyConAppCo Nominal MkG [co3, co4] - where - co3 :: co1 ~ co2 - co4 :: a1 ~ a2 - -Note that - co1 :: a1 ~ Bool - co2 :: a2 ~ Bool - -Here, - co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) - where - co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) - co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] --} - - -{- ********************************************************************* -* * - typeSize, coercionSize -* * -********************************************************************* -} - --- NB: We put typeSize/coercionSize here because they are mutually --- recursive, and have the CPR property. If we have mutual --- recursion across a hi-boot file, we don't get the CPR property --- and these functions allocate a tremendous amount of rubbish. --- It's not critical (because typeSize is really only used in --- debug mode, but I tripped over an example (T5642) in which --- typeSize was one of the biggest single allocators in all of GHC. --- And it's easy to fix, so I did. - --- NB: typeSize does not respect `eqType`, in that two types that --- are `eqType` may return different sizes. This is OK, because this --- function is used only in reporting, not decision-making. - -typeSize :: Type -> Int -typeSize (LitTy {}) = 1 -typeSize (TyVarTy {}) = 1 -typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (FunTy _ t1 t2) = typeSize t1 + typeSize t2 -typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t -typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) -typeSize (CastTy ty co) = typeSize ty + coercionSize co -typeSize (CoercionTy co) = coercionSize co - -coercionSize :: Coercion -> Int -coercionSize (Refl ty) = typeSize ty -coercionSize (GRefl _ ty MRefl) = typeSize ty -coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co -coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (AppCo co arg) = coercionSize co + coercionSize arg -coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h -coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (CoVarCo _) = 1 -coercionSize (HoleCo _) = 1 -coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 -coercionSize (SymCo co) = 1 + coercionSize co -coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (NthCo _ _ co) = 1 + coercionSize co -coercionSize (LRCo _ co) = 1 + coercionSize co -coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg -coercionSize (KindCo co) = 1 + coercionSize co -coercionSize (SubCo co) = 1 + coercionSize co -coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) - -provSize :: UnivCoProvenance -> Int -provSize UnsafeCoerceProv = 1 -provSize (PhantomProv co) = 1 + coercionSize co -provSize (ProofIrrelProv co) = 1 + coercionSize co -provSize (PluginProv _) = 1 diff --git a/types/TyCoRep.hs-boot b/types/TyCoRep.hs-boot deleted file mode 100644 --- a/types/TyCoRep.hs-boot +++ /dev/null @@ -1,23 +0,0 @@ -module TyCoRep where - -import Data.Data ( Data ) -import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) - -data Type -data TyThing -data Coercion -data UnivCoProvenance -data TyLit -data TyCoBinder -data MCoercion - -type PredType = Type -type Kind = Type -type ThetaType = [PredType] -type CoercionN = Coercion -type MCoercionN = MCoercion - -mkFunTy :: AnonArgFlag -> Type -> Type -> Type -mkForAllTy :: Var -> ArgFlag -> Type -> Type - -instance Data Type -- To support Data instances in CoAxiom diff --git a/types/TyCoSubst.hs b/types/TyCoSubst.hs deleted file mode 100644 --- a/types/TyCoSubst.hs +++ /dev/null @@ -1,1029 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 -Type and Coercion - friends' interface --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - --- | Substitution into types and coercions. -module TyCoSubst - ( - -- * Substitutions - TCvSubst(..), TvSubstEnv, CvSubstEnv, - emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, - emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, mkCvSubst, - getTvSubstEnv, - getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, - isInScope, notElemTCvSubst, - setTvSubstEnv, setCvSubstEnv, zapTCvSubst, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendTCvSubstWithClone, - extendCvSubst, extendCvSubstWithClone, - extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, - extendTvSubstList, extendTvSubstAndInScope, - extendTCvSubstList, - unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, - zipTvSubst, zipCvSubst, - zipTCvSubst, - mkTvSubstPrs, - - substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, - substCoWith, - substTy, substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyWithInScope, - substTys, substTheta, - lookupTyVar, - substCo, substCos, substCoVar, substCoVars, lookupCoVar, - cloneTyVarBndr, cloneTyVarBndrs, - substVarBndr, substVarBndrs, - substTyVarBndr, substTyVarBndrs, - substCoVarBndr, - substTyVar, substTyVars, substTyCoVars, - substForAllCoBndr, - substVarBndrUsing, substForAllCoBndrUsing, - checkValidSubst, isValidTCvSubst, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Type ( mkCastTy, mkAppTy, isCoercionTy ) -import {-# SOURCE #-} Coercion ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo - , mkNomReflCo, mkSubCo, mkSymCo - , mkFunCo, mkForAllCo, mkUnivCo - , mkAxiomInstCo, mkAppCo, mkGReflCo - , mkInstCo, mkLRCo, mkTyConAppCo - , mkCoercionType - , coercionKind, coVarKindsTypesRole ) - -import TyCoRep -import TyCoFVs -import TyCoPpr - -import Var -import VarSet -import VarEnv - -import Pair -import Util -import UniqSupply -import Unique -import UniqFM -import UniqSet -import Outputable - -import Data.List (mapAccumL) - -{- -%************************************************************************ -%* * - Substitutions - Data type defined here to avoid unnecessary mutual recursion -%* * -%************************************************************************ --} - --- | Type & coercion substitution --- --- #tcvsubst_invariant# --- The following invariants must hold of a 'TCvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TCvSubst - = TCvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - CvSubstEnv -- Substitutes coercion variables - -- See Note [Substitutions apply only once] - -- and Note [Extending the TvSubstEnv] - -- and Note [Substituting types and coercions] - -- and Note [The substitution invariant] - --- | A substitution of 'Type's for 'TyVar's --- and 'Kind's for 'KindVar's -type TvSubstEnv = TyVarEnv Type - -- NB: A TvSubstEnv is used - -- both inside a TCvSubst (with the apply-once invariant - -- discussed in Note [Substitutions apply only once], - -- and also independently in the middle of matching, - -- and unification (see Types.Unify). - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever - --- | A substitution of 'Coercion's for 'CoVar's -type CvSubstEnv = CoVarEnv Coercion - -{- Note [The substitution invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When calling (substTy subst ty) it should be the case that -the in-scope set in the substitution is a superset of both: - - (SIa) The free vars of the range of the substitution - (SIb) The free vars of ty minus the domain of the substitution - -The same rules apply to other substitutions (notably CoreSubst.Subst) - -* Reason for (SIa). Consider - substTy [a :-> Maybe b] (forall b. b->a) - we must rename the forall b, to get - forall b2. b2 -> Maybe b - Making 'b' part of the in-scope set forces this renaming to - take place. - -* Reason for (SIb). Consider - substTy [a :-> Maybe b] (forall b. (a,b,x)) - Then if we use the in-scope set {b}, satisfying (SIa), there is - a danger we will rename the forall'd variable to 'x' by mistake, - getting this: - forall x. (Maybe b, x, x) - Breaking (SIb) caused the bug from #11371. - -Note: if the free vars of the range of the substitution are freshly created, -then the problems of (SIa) can't happen, and so it would be sound to -ignore (SIa). - -Note [Substitutions apply only once] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use TCvSubsts to instantiate things, and we might instantiate - forall a b. ty -with the types - [a, b], or [b, a]. -So the substitution might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substitution that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - ******************************************************** - *** So a substitution must be applied precisely once *** - ******************************************************** - -A TCvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubstEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tcvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the subst envs are empty: -if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) -holds --- then (substTy subst ty) does nothing. - -For example, consider: - (/\a. /\b:(a~Int). ...b..) Int -We substitute Int for 'a'. The Unique of 'b' does not change, but -nevertheless we add 'b' to the TvSubstEnv, because b's kind does change - -This invariant has several crucial consequences: - -* In substVarBndr, we need extend the TvSubstEnv - - if the unique has changed - - or if the kind has changed - -* In substTyVar, we do not need to consult the in-scope set; - the TvSubstEnv is enough - -* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty - -Note [Substituting types and coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Types and coercions are mutually recursive, and either may have variables -"belonging" to the other. Thus, every time we wish to substitute in a -type, we may also need to substitute in a coercion, and vice versa. -However, the constructor used to create type variables is distinct from -that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note -that it would be possible to use the CoercionTy constructor to combine -these environments, but that seems like a false economy. - -Note that the TvSubstEnv should *never* map a CoVar (built with the Id -constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, -the range of the TvSubstEnv should *never* include a type headed with -CoercionTy. --} - -emptyTvSubstEnv :: TvSubstEnv -emptyTvSubstEnv = emptyVarEnv - -emptyCvSubstEnv :: CvSubstEnv -emptyCvSubstEnv = emptyVarEnv - -composeTCvSubstEnv :: InScopeSet - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) - = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 - , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TCvSubst in_scope tenv1 cenv1 - --- | Composes two substitutions, applying the second one provided first, --- like in function composition. -composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) - = TCvSubst is3 tenv3 cenv3 - where - is3 = is1 `unionInScope` is2 - (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) - -emptyTCvSubst :: TCvSubst -emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv - -mkEmptyTCvSubst :: InScopeSet -> TCvSubst -mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv - -isEmptyTCvSubst :: TCvSubst -> Bool - -- See Note [Extending the TvSubstEnv] -isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv - -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst -mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv - -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst --- ^ Make a TCvSubst with specified tyvar subst and empty covar subst -mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv - -mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst --- ^ Make a TCvSubst with specified covar subst and empty tyvar subst -mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv - -getTvSubstEnv :: TCvSubst -> TvSubstEnv -getTvSubstEnv (TCvSubst _ env _) = env - -getCvSubstEnv :: TCvSubst -> CvSubstEnv -getCvSubstEnv (TCvSubst _ _ env) = env - -getTCvInScope :: TCvSubst -> InScopeSet -getTCvInScope (TCvSubst in_scope _ _) = in_scope - --- | Returns the free variables of the types in the range of a substitution as --- a non-deterministic set. -getTCvSubstRangeFVs :: TCvSubst -> VarSet -getTCvSubstRangeFVs (TCvSubst _ tenv cenv) - = unionVarSet tenvFVs cenvFVs - where - tenvFVs = tyCoVarsOfTypesSet tenv - cenvFVs = tyCoVarsOfCosSet cenv - -isInScope :: Var -> TCvSubst -> Bool -isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope - -notElemTCvSubst :: Var -> TCvSubst -> Bool -notElemTCvSubst v (TCvSubst _ tenv cenv) - | isTyVar v - = not (v `elemVarEnv` tenv) - | otherwise - = not (v `elemVarEnv` cenv) - -setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst -setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv - -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst -setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv - -zapTCvSubst :: TCvSubst -> TCvSubst -zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv - -extendTCvInScope :: TCvSubst -> Var -> TCvSubst -extendTCvInScope (TCvSubst in_scope tenv cenv) var - = TCvSubst (extendInScopeSet in_scope var) tenv cenv - -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst -extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv - -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst -extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv - -extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst -extendTCvSubst subst v ty - | isTyVar v - = extendTvSubst subst v ty - | CoercionTy co <- ty - = extendCvSubst subst v co - | otherwise - = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) - -extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst -extendTCvSubstWithClone subst tcv - | isTyVar tcv = extendTvSubstWithClone subst tcv - | otherwise = extendCvSubstWithClone subst tcv - -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst -extendTvSubst (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv - -extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst -extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty - = ASSERT( isTyVar v ) - extendTvSubstAndInScope subst v ty -extendTvSubstBinderAndInScope subst (Anon {}) _ - = subst - -extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst --- Adds a new tv -> tv mapping, /and/ extends the in-scope set -extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - (extendVarEnv tenv tv (mkTyVarTy tv')) - cenv - where - new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' - -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst -extendCvSubst (TCvSubst in_scope tenv cenv) v co - = TCvSubst in_scope tenv (extendVarEnv cenv v co) - -extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst -extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - tenv - (extendVarEnv cenv cv (mkCoVarCo cv')) - where - new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' - -extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst --- Also extends the in-scope set -extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) - (extendVarEnv tenv tv ty) - cenv - -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTvSubstList subst tvs tys - = foldl2 extendTvSubst subst tvs tys - -extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTCvSubstList subst tvs tys - = foldl2 extendTCvSubst subst tvs tys - -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst --- Works when the ranges are disjoint -unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) - = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) - && not (cenv1 `intersectsVarEnv` cenv2) ) - TCvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - (cenv1 `plusVarEnv` cenv2) - --- mkTvSubstPrs and zipTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No CoVars, please! -zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst -zipTvSubst tvs tys - = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv - where - tenv = zipTyEnv tvs tys - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No TyVars, please! -zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst -zipCvSubst cvs cos - = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv - where - cenv = zipCoEnv cvs cos - -zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst -zipTCvSubst tcvs tys - = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) - where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst - zip_tcvsubst (tv:tvs) (ty:tys) subst - = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) - zip_tcvsubst [] [] subst = subst -- empty case - zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" - (ppr tcvs <+> ppr tys) - --- | Generates the in-scope set for the 'TCvSubst' from the types in the --- incoming environment. No CoVars, please! -mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst -mkTvSubstPrs prs = - ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) - mkTvSubst in_scope tenv - where tenv = mkVarEnv prs - in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs - onlyTyVarsAndNoCoercionTy = - and [ isTyVar tv && not (isCoercionTy ty) - | (tv, ty) <- prs ] - -zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv -zipTyEnv tyvars tys - | debugIsOn - , not (all isTyVar tyvars) - = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) - | otherwise - = ASSERT( all (not . isCoercionTy) tys ) - mkVarEnv (zipEqual "zipTyEnv" tyvars tys) - -- There used to be a special case for when - -- ty == TyVarTy tv - -- (a not-uncommon case) in which case the substitution was dropped. - -- But the type-tidier changes the print-name of a type variable without - -- changing the unique, and that led to a bug. Why? Pre-tidying, we had - -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. - -- And it happened that t was the type variable of the class. Post-tiding, - -- it got turned into {Foo t2}. The ext-core printer expanded this using - -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, - -- and so generated a rep type mentioning t not t2. - -- - -- Simplest fix is to nuke the "optimisation" - -zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv -zipCoEnv cvs cos - | debugIsOn - , not (all isCoVar cvs) - = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) - | otherwise - = mkVarEnv (zipEqual "zipCoEnv" cvs cos) - -instance Outputable TCvSubst where - ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ text "TCvSubst", - nest 2 (text "In scope:" <+> ppr ins), - nest 2 (text "Type env:" <+> ppr tenv), - nest 2 (text "Co env:" <+> ppr cenv) ] - -{- -%************************************************************************ -%* * - Performing type or kind substitutions -%* * -%************************************************************************ - -Note [Sym and ForAllCo] -~~~~~~~~~~~~~~~~~~~~~~~ -In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, -how do we push sym into a ForAllCo? It's a little ugly. - -Here is the typing rule: - -h : k1 ~# k2 -(tv : k1) |- g : ty1 ~# ty2 ----------------------------- -ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# - (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) - -Here is what we want: - -ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# - (ForAllTy (tv : k1) ty1) - - -Because the kinds of the type variables to the right of the colon are the kinds -coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). - -Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want - -ForAllCo tv h' g' : - (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# - (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) - -We thus see that we want - -g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] - -and thus g' = sym (g[tv |-> tv |> h']). - -Putting it all together, we get this: - -sym (ForAllCo tv h g) -==> -ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) - -Note [Substituting in a coercion hole] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It seems highly suspicious to be substituting in a coercion that still -has coercion holes. Yet, this can happen in a situation like this: - - f :: forall k. k :~: Type -> () - f Refl = let x :: forall (a :: k). [a] -> ... - x = ... - -When we check x's type signature, we require that k ~ Type. We indeed -know this due to the Refl pattern match, but the eager unifier can't -make use of givens. So, when we're done looking at x's type, a coercion -hole will remain. Then, when we're checking x's definition, we skolemise -x's type (in order to, e.g., bring the scoped type variable `a` into scope). -This requires performing a substitution for the fresh skolem variables. - -This subsitution needs to affect the kind of the coercion hole, too -- -otherwise, the kind will have an out-of-scope variable in it. More problematically -in practice (we won't actually notice the out-of-scope variable ever), skolems -in the kind might have too high a level, triggering a failure to uphold the -invariant that no free variables in a type have a higher level than the -ambient level in the type checker. In the event of having free variables in the -hole's kind, I'm pretty sure we'll always have an erroneous program, so we -don't need to worry what will happen when the hole gets filled in. After all, -a hole relating a locally-bound type variable will be unable to be solved. This -is why it's OK not to look through the IORef of a coercion hole during -substitution. - --} - --- | Type substitution, see 'zipTvSubst' -substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type --- Works only if the domain of the substitution is a --- superset of the type being substituted into -substTyWith tvs tys = {-#SCC "substTyWith" #-} - ASSERT( tvs `equalLength` tys ) - substTy (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type -substTyWithUnchecked tvs tys - = ASSERT( tvs `equalLength` tys ) - substTyUnchecked (zipTvSubst tvs tys) - --- | Substitute tyvars within a type using a known 'InScopeSet'. --- Pre-condition: the 'in_scope' set should satisfy Note [The substitution --- invariant]; specifically it should include the free vars of 'tys', --- and of 'ty' minus the domain of the subst. -substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type -substTyWithInScope in_scope tvs tys ty = - ASSERT( tvs `equalLength` tys ) - substTy (mkTvSubst in_scope tenv) ty - where tenv = zipTyEnv tvs tys - --- | Coercion substitution, see 'zipTvSubst' -substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion -substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) - substCo (zipTvSubst tvs tys) - --- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithUnchecked tvs tys - = ASSERT( tvs `equalLength` tys ) - substCoUnchecked (zipTvSubst tvs tys) - - - --- | Substitute covars within a type -substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type -substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) - --- | Type substitution, see 'zipTvSubst' -substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] -substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) - substTys (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst' -substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] -substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) - substTys (zipCvSubst cvs cos) - --- | Substitute within a 'Type' after adding the free variables of the type --- to the in-scope set. This is useful for the case when the free variables --- aren't already in the in-scope set or easily available. --- See also Note [The substitution invariant]. -substTyAddInScope :: TCvSubst -> Type -> Type -substTyAddInScope subst ty = - substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty - --- | When calling `substTy` it should be the case that the in-scope set in --- the substitution is a superset of the free vars of the range of the --- substitution. --- See also Note [The substitution invariant]. -isValidTCvSubst :: TCvSubst -> Bool -isValidTCvSubst (TCvSubst in_scope tenv cenv) = - (tenvFVs `varSetInScope` in_scope) && - (cenvFVs `varSetInScope` in_scope) - where - tenvFVs = tyCoVarsOfTypesSet tenv - cenvFVs = tyCoVarsOfCosSet cenv - --- | This checks if the substitution satisfies the invariant from --- Note [The substitution invariant]. -checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a - = ASSERT2( isValidTCvSubst subst, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "tenvFVs" <+> ppr (tyCoVarsOfTypesSet tenv) $$ - text "cenv" <+> ppr cenv $$ - text "cenvFVs" <+> ppr (tyCoVarsOfCosSet cenv) $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos ) - ASSERT2( tysCosFVsInScope, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "cenv" <+> ppr cenv $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos $$ - text "needInScope" <+> ppr needInScope ) - a - where - substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv - -- It's OK to use nonDetKeysUFM here, because we only use this list to - -- remove some elements from a set - needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) - `delListFromUniqSet_Directly` substDomain - tysCosFVsInScope = needInScope `varSetInScope` in_scope - - --- | Substitute within a 'Type' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTy :: HasCallStack => TCvSubst -> Type -> Type -substTy subst ty - | isEmptyTCvSubst subst = ty - | otherwise = checkValidSubst subst [ty] [] $ - subst_ty subst ty - --- | Substitute within a 'Type' disabling the sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyUnchecked :: TCvSubst -> Type -> Type -substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty - | otherwise = subst_ty subst ty - --- | Substitute within several 'Type's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] -substTys subst tys - | isEmptyTCvSubst subst = tys - | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys - --- | Substitute within several 'Type's disabling the sanity checks. --- The problems that the sanity checks in substTys catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTysUnchecked to --- substTys and remove this function. Please don't use in new code. -substTysUnchecked :: TCvSubst -> [Type] -> [Type] -substTysUnchecked subst tys - | isEmptyTCvSubst subst = tys - | otherwise = map (subst_ty subst) tys - --- | Substitute within a 'ThetaType' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType -substTheta = substTys - --- | Substitute within a 'ThetaType' disabling the sanity checks. --- The problems that the sanity checks in substTys catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substThetaUnchecked to --- substTheta and remove this function. Please don't use in new code. -substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType -substThetaUnchecked = substTysUnchecked - - -subst_ty :: TCvSubst -> Type -> Type --- subst_ty is the main workhorse for type substitution --- --- Note that the in_scope set is poked only if we hit a forall --- so it may often never be fully computed -subst_ty subst ty - = go ty - where - go (TyVarTy tv) = substTyVar subst tv - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- by [Int], represented with TyConApp - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - go ty@(FunTy { ft_arg = arg, ft_res = res }) - = let !arg' = go arg - !res' = go res - in ty { ft_arg = arg', ft_res = res' } - go (ForAllTy (Bndr tv vis) ty) - = case substVarBndrUnchecked subst tv of - (subst', tv') -> - (ForAllTy $! ((Bndr $! tv') vis)) $! - (subst_ty subst' ty) - go (LitTy n) = LitTy $! n - go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) - go (CoercionTy co) = CoercionTy $! (subst_co subst co) - -substTyVar :: TCvSubst -> TyVar -> Type -substTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - case lookupVarEnv tenv tv of - Just ty -> ty - Nothing -> TyVarTy tv - -substTyVars :: TCvSubst -> [TyVar] -> [Type] -substTyVars subst = map $ substTyVar subst - -substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] -substTyCoVars subst = map $ substTyCoVar subst - -substTyCoVar :: TCvSubst -> TyCoVar -> Type -substTyCoVar subst tv - | isTyVar tv = substTyVar subst tv - | otherwise = CoercionTy $ substCoVar subst tv - -lookupTyVar :: TCvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TCvSubst] -lookupTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - lookupVarEnv tenv tv - --- | Substitute within a 'Coercion' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion -substCo subst co - | isEmptyTCvSubst subst = co - | otherwise = checkValidSubst subst [] [co] $ subst_co subst co - --- | Substitute within a 'Coercion' disabling sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoUnchecked :: TCvSubst -> Coercion -> Coercion -substCoUnchecked subst co - | isEmptyTCvSubst subst = co - | otherwise = subst_co subst co - --- | Substitute within several 'Coercion's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] -substCos subst cos - | isEmptyTCvSubst subst = cos - | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos - -subst_co :: TCvSubst -> Coercion -> Coercion -subst_co subst co - = go co - where - go_ty :: Type -> Type - go_ty = subst_ty subst - - go_mco :: MCoercion -> MCoercion - go_mco MRefl = MRefl - go_mco (MCo co) = MCo (go co) - - go :: Coercion -> Coercion - go (Refl ty) = mkNomReflCo $! (go_ty ty) - go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) - go (TyConAppCo r tc args)= let args' = map go args - in args' `seqList` mkTyConAppCo r tc args' - go (AppCo co arg) = (mkAppCo $! go co) $! go arg - go (ForAllCo tv kind_co co) - = case substForAllCoBndrUnchecked subst tv kind_co of - (subst', tv', kind_co') -> - ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co - go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 - go (CoVarCo cv) = substCoVar subst cv - go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos - go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! - (go_ty t1)) $! (go_ty t2) - go (SymCo co) = mkSymCo $! (go co) - go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) - go (NthCo r d co) = mkNthCo r d $! (go co) - go (LRCo lr co) = mkLRCo lr $! (go co) - go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg - go (KindCo co) = mkKindCo $! (go co) - go (SubCo co) = mkSubCo $! (go co) - go (AxiomRuleCo c cs) = let cs1 = map go cs - in cs1 `seqList` AxiomRuleCo c cs1 - go (HoleCo h) = HoleCo $! go_hole h - - go_prov UnsafeCoerceProv = UnsafeCoerceProv - go_prov (PhantomProv kco) = PhantomProv (go kco) - go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) - go_prov p@(PluginProv _) = p - - -- See Note [Substituting in a coercion hole] - go_hole h@(CoercionHole { ch_co_var = cv }) - = h { ch_co_var = updateVarType go_ty cv } - -substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) -substForAllCoBndr subst - = substForAllCoBndrUsing False (substCo subst) subst - --- | Like 'substForAllCoBndr', but disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) -substForAllCoBndrUnchecked subst - = substForAllCoBndrUsing False (substCoUnchecked subst) subst - --- See Note [Sym and ForAllCo] -substForAllCoBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, KindCoercion) -substForAllCoBndrUsing sym sco subst old_var - | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var - | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var - -substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyVar -> KindCoercion - -> (TCvSubst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co - = ASSERT( isTyVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv - , new_var, new_kind_co ) - where - new_env | no_change && not sym = delVarEnv tenv old_var - | sym = extendVarEnv tenv old_var $ - TyVarTy new_var `CastTy` new_kind_co - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - no_kind_change = noFreeVarsOfCo old_kind_co - no_change = no_kind_change && (new_var == old_var) - - new_kind_co | no_kind_change = old_kind_co - | otherwise = sco old_kind_co - - Pair new_ki1 _ = coercionKind new_kind_co - -- We could do substitution to (tyVarKind old_var). We don't do so because - -- we already substituted new_kind_co, which contains the kind information - -- we want. We don't want to do substitution once more. Also, in most cases, - -- new_kind_co is a Refl, in which case coercionKind is really fast. - - new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) - -substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> CoVar -> KindCoercion - -> (TCvSubst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) - old_var old_kind_co - = ASSERT( isCoVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv - , new_var, new_kind_co ) - where - new_cenv | no_change && not sym = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) - - no_kind_change = noFreeVarsOfCo old_kind_co - no_change = no_kind_change && (new_var == old_var) - - new_kind_co | no_kind_change = old_kind_co - | otherwise = sco old_kind_co - - Pair h1 h2 = coercionKind new_kind_co - - new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type - new_var_type | sym = h2 - | otherwise = h1 - -substCoVar :: TCvSubst -> CoVar -> Coercion -substCoVar (TCvSubst _ _ cenv) cv - = case lookupVarEnv cenv cv of - Just co -> co - Nothing -> CoVarCo cv - -substCoVars :: TCvSubst -> [CoVar] -> [Coercion] -substCoVars subst cvs = map (substCoVar subst) cvs - -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion -lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v - -substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndr = substTyVarBndrUsing substTy - -substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) -substTyVarBndrs = mapAccumL substTyVarBndr - -substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndr = substVarBndrUsing substTy - -substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) -substVarBndrs = mapAccumL substVarBndr - -substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndr = substCoVarBndrUsing substTy - --- | Like 'substVarBndr', but disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndrUnchecked = substVarBndrUsing substTyUnchecked - -substVarBndrUsing :: (TCvSubst -> Type -> Type) - -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndrUsing subst_fn subst v - | isTyVar v = substTyVarBndrUsing subst_fn subst v - | otherwise = substCoVarBndrUsing subst_fn subst v - --- | Substitute a tyvar in a binding position, returning an --- extended subst and a new tyvar. --- Use the supplied function to substitute in the kind -substTyVarBndrUsing - :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind - -> TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) - ASSERT( isTyVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) - where - new_env | no_change = delVarEnv tenv old_var - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypesSet tenv) - -- Assertion check that we are not capturing something in the substitution - - old_ki = tyVarKind old_var - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - no_change = no_kind_change && (new_var == old_var) - -- no_change means that the new_var is identical in - -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TCvSubst] - -- - -- In that case we don't need to extend the substitution - -- to map old to new. But instead we must zap any - -- current substitution for the variable. For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - - new_var | no_kind_change = uniqAway in_scope old_var - | otherwise = uniqAway in_scope $ - setTyVarKind old_var (subst_fn subst old_ki) - -- The uniqAway part makes sure the new variable is not already in scope - --- | Substitute a covar in a binding position, returning an --- extended subst and a new covar. --- Use the supplied function to substitute in the kind -substCoVarBndrUsing - :: (TCvSubst -> Type -> Type) - -> TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT( isCoVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) - where - new_co = mkCoVarCo new_var - no_kind_change = noFreeVarsOfTypes [t1, t2] - no_change = new_var == old_var && no_kind_change - - new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var new_co - - new_var = uniqAway in_scope subst_old_var - subst_old_var = mkCoVar (varName old_var) new_var_type - - (_, _, t1, t2, role) = coVarKindsTypesRole old_var - t1' = subst_fn subst t1 - t2' = subst_fn subst t2 - new_var_type = mkCoercionType role t1' t2' - -- It's important to do the substitution for coercions, - -- because they can have free type variables - -cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) -cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq - = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars - (TCvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') - where - old_ki = tyVarKind tv - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - - tv1 | no_kind_change = tv - | otherwise = setTyVarKind tv (substTy subst old_ki) - - tv' = setVarUnique tv1 uniq - -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) -cloneTyVarBndrs subst [] _usupply = (subst, []) -cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) - where - (uniq, usupply') = takeUniqFromSupply usupply - (subst' , tv ) = cloneTyVarBndr subst t uniq - (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' - diff --git a/types/TyCoTidy.hs b/types/TyCoTidy.hs deleted file mode 100644 --- a/types/TyCoTidy.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | Tidying types and coercions for printing in error messages. -module TyCoTidy - ( - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyKind, - tidyCo, tidyCos, - tidyTyCoVarBinder, tidyTyCoVarBinders - ) where - -import GhcPrelude - -import TyCoRep -import TyCoFVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) - -import Name hiding (varName) -import Var -import VarEnv -import Util (seqList) - -import Data.List (mapAccumL) - -{- -%************************************************************************ -%* * -\subsection{TidyType} -%* * -%************************************************************************ --} - --- | This tidies up a type for printing in an error message, or in --- an interface file. --- --- It doesn't change the uniques at all, just the print names. -tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyVarBndrs tidy_env tvs - = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs - -tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -tidyVarBndr tidy_env@(occ_env, subst) var - = case tidyOccName occ_env (getHelpfulOccName var) of - (occ_env', occ') -> ((occ_env', subst'), var') - where - subst' = extendVarEnv subst var var' - var' = setVarType (setVarName var name') type' - type' = tidyType tidy_env (varType var) - name' = tidyNameOcc name occ' - name = varName var - -avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv --- Seed the occ_env with clashes among the names, see --- Note [Tidying multiple names at once] in OccName -avoidNameClashes tvs (occ_env, subst) - = (avoidClashesOccEnv occ_env occs, subst) - where - occs = map getHelpfulOccName tvs - -getHelpfulOccName :: TyCoVar -> OccName --- A TcTyVar with a System Name is probably a --- unification variable; when we tidy them we give them a trailing --- "0" (or 1 etc) so that they don't take precedence for the --- un-modified name. Plus, indicating a unification variable in --- this way is a helpful clue for users -getHelpfulOccName tv - | isSystemName name, isTcTyVar tv - = mkTyVarOcc (occNameString occ ++ "0") - | otherwise - = occ - where - name = varName tv - occ = getOccName name - -tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis - -> (TidyEnv, VarBndr TyCoVar vis) -tidyTyCoVarBinder tidy_env (Bndr tv vis) - = (tidy_env', Bndr tv' vis) - where - (tidy_env', tv') = tidyVarBndr tidy_env tv - -tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] - -> (TidyEnv, [VarBndr TyCoVar vis]) -tidyTyCoVarBinders tidy_env tvbs - = mapAccumL tidyTyCoVarBinder - (avoidNameClashes (binderVars tvbs) tidy_env) tvbs - ---------------- -tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv --- ^ Add the free 'TyVar's to the env in tidy form, --- so that we can tidy the type they are free in -tidyFreeTyCoVars (full_occ_env, var_env) tyvars - = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars) - ---------------- -tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars - ---------------- -tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) --- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name --- using the environment if one has not already been allocated. See --- also 'tidyVarBndr' -tidyOpenTyCoVar env@(_, subst) tyvar - = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> - let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) - in tidyVarBndr env' tyvar -- Treat it as a binder - ---------------- -tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar -tidyTyCoVarOcc env@(_, subst) tv - = case lookupVarEnv subst tv of - Nothing -> updateVarType (tidyType env) tv - Just tv' -> tv' - ---------------- -tidyTypes :: TidyEnv -> [Type] -> [Type] -tidyTypes env tys = map (tidyType env) tys - ---------------- -tidyType :: TidyEnv -> Type -> Type -tidyType _ (LitTy n) = LitTy n -tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) -tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys - in args `seqList` TyConApp tycon args -tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env ty@(FunTy _ arg res) = let { !arg' = tidyType env arg - ; !res' = tidyType env res } - in ty { ft_arg = arg', ft_res = res' } -tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty - where - (tvs, vis, body_ty) = splitForAllTys' ty - (env', tvs') = tidyVarBndrs env tvs -tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) -tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) - - --- The following two functions differ from mkForAllTys and splitForAllTys in that --- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but --- how should they be named? -mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type -mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs - where - strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty - -splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) -splitForAllTys' ty = go ty [] [] - where - go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) - go ty tvs viss = (reverse tvs, reverse viss, ty) - - ---------------- --- | Grabs the free type variables, tidies them --- and then uses 'tidyType' to work over the type itself -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys - = (env', tidyTypes (trimmed_occ_env, var_env) tys) - where - (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ - tyCoVarsOfTypesWellScoped tys - trimmed_occ_env = initTidyOccEnv (map getOccName tvs') - -- The idea here was that we restrict the new TidyEnv to the - -- _free_ vars of the types, so that we don't gratuitously rename - -- the _bound_ variables of the types. - ---------------- -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in - (env', ty') - ---------------- --- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) -tidyTopType :: Type -> Type -tidyTopType ty = tidyType emptyTidyEnv ty - ---------------- -tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyOpenKind = tidyOpenType - -tidyKind :: TidyEnv -> Kind -> Kind -tidyKind = tidyType - ----------------- -tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co - = go co - where - go_mco MRefl = MRefl - go_mco (MCo co) = MCo (go co) - - go (Refl ty) = Refl (tidyType env ty) - go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco - go (TyConAppCo r tc cos) = let args = map go cos - in args `seqList` TyConAppCo r tc args - go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 - go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) - where (envp, tvp) = tidyVarBndr env tv - -- the case above duplicates a bit of work in tidying h and the kind - -- of tv. But the alternative is to use coercionKind, which seems worse. - go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 - go (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' - go (HoleCo h) = HoleCo h - go (AxiomInstCo con ind cos) = let args = map go cos - in args `seqList` AxiomInstCo con ind args - go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! - tidyType env t1) $! tidyType env t2 - go (SymCo co) = SymCo $! go co - go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo r d co) = NthCo r d $! go co - go (LRCo lr co) = LRCo lr $! go co - go (InstCo co ty) = (InstCo $! go co) $! go ty - go (KindCo co) = KindCo $! go co - go (SubCo co) = SubCo $! go co - go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos - in cos1 `seqList` AxiomRuleCo ax cos1 - - go_prov UnsafeCoerceProv = UnsafeCoerceProv - go_prov (PhantomProv co) = PhantomProv (go co) - go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) - go_prov p@(PluginProv _) = p - -tidyCos :: TidyEnv -> [Coercion] -> [Coercion] -tidyCos env = map (tidyCo env) - - diff --git a/types/TyCon.hs b/types/TyCon.hs deleted file mode 100644 --- a/types/TyCon.hs +++ /dev/null @@ -1,2868 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @TyCon@ datatype --} - -{-# LANGUAGE CPP, FlexibleInstances, LambdaCase #-} - -module TyCon( - -- * Main TyCon data types - TyCon, - AlgTyConRhs(..), visibleDataCons, - AlgTyConFlav(..), isNoParent, - FamTyConFlav(..), Role(..), Injectivity(..), - RuntimeRepInfo(..), TyConFlavour(..), - - -- * TyConBinder - TyConBinder, TyConBndrVis(..), TyConTyCoBinder, - mkNamedTyConBinder, mkNamedTyConBinders, - mkRequiredTyConBinder, - mkAnonTyConBinder, mkAnonTyConBinders, - tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, - - -- ** Field labels - tyConFieldLabels, lookupTyConFieldLabel, - - -- ** Constructing TyCons - mkAlgTyCon, - mkClassTyCon, - mkFunTyCon, - mkPrimTyCon, - mkKindTyCon, - mkLiftedPrimTyCon, - mkTupleTyCon, - mkSumTyCon, - mkDataTyConRhs, - mkSynonymTyCon, - mkFamilyTyCon, - mkPromotedDataCon, - mkTcTyCon, - noTcTyConScopedTyVars, - - -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, - isClassTyCon, isFamInstTyCon, - isFunTyCon, - isPrimTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isUnboxedSumTyCon, isPromotedTupleTyCon, - isTypeSynonymTyCon, - mustBeSaturated, - isPromotedDataCon, isPromotedDataCon_maybe, - isKindTyCon, isLiftedTypeKindTyConName, - isTauTyCon, isFamFreeTyCon, - - isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, - isDataSumTyCon_maybe, - isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, - isFamilyTyCon, isOpenFamilyTyCon, - isTypeFamilyTyCon, isDataFamilyTyCon, - isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, - tyConInjectivityInfo, - isBuiltInSynFamTyCon_maybe, - isUnliftedTyCon, - isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, - isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, - isImplicitTyCon, - isTyConWithSrcDataCons, - isTcTyCon, setTcTyConKind, - isTcLevPoly, - - -- ** Extracting information out of TyCons - tyConName, - tyConSkolem, - tyConKind, - tyConUnique, - tyConTyVars, tyConVisibleTyVars, - tyConCType, tyConCType_maybe, - tyConDataCons, tyConDataCons_maybe, - tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConSingleAlgDataCon_maybe, - tyConFamilySize, - tyConStupidTheta, - tyConArity, - tyConRoles, - tyConFlavour, - tyConTuple_maybe, tyConClass_maybe, tyConATs, - tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - tyConFamilyResVar_maybe, - synTyConDefn_maybe, synTyConRhs_maybe, - famTyConFlav_maybe, famTcResVar, - algTyConRhs, - newTyConRhs, newTyConEtadArity, newTyConEtadRhs, - unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, - newTyConDataCon_maybe, - algTcFields, - tyConRuntimeRepInfo, - tyConBinders, tyConResKind, tyConTyVarBinders, - tcTyConScopedTyVars, tcTyConIsPoly, - mkTyConTagMap, - - -- ** Manipulating TyCons - expandSynTyCon_maybe, - newTyConCo, newTyConCo_maybe, - pprPromotionQuote, mkTyConKind, - - -- ** Predicated on TyConFlavours - tcFlavourIsOpen, - - -- * Runtime type representation - TyConRepName, tyConRepName_maybe, - mkPrelTyConRepName, - tyConRepModOcc, - - -- * Primitive representations of Types - PrimRep(..), PrimElemRep(..), - isVoidRep, isGcPtrRep, - primRepSizeB, - primElemRepSizeB, - primRepIsFloat, - primRepsCompatible, - primRepCompatible, - - -- * Recursion breaking - RecTcChecker, initRecTc, defaultRecTcMaxBound, - setRecTcMaxBound, checkRecTc - -) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, mkForAllTy, mkFunTy ) -import {-# SOURCE #-} TyCoPpr ( pprType ) -import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind - , vecCountTyCon, vecElemTyCon, liftedTypeKind ) -import {-# SOURCE #-} DataCon ( DataCon, dataConExTyCoVars, dataConFieldLabels - , dataConTyCon, dataConFullSig - , isUnboxedSumCon ) - -import Binary -import Var -import VarSet -import Class -import BasicTypes -import DynFlags -import ForeignCall -import Name -import NameEnv -import CoAxiom -import PrelNames -import Maybes -import Outputable -import FastStringEnv -import FieldLabel -import Constants -import Util -import Unique( tyConRepNameUnique, dataConTyRepNameUnique ) -import UniqSet -import Module - -import qualified Data.Data as Data - -{- ------------------------------------------------ - Notes about type families ------------------------------------------------ - -Note [Type synonym families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Type synonym families, also known as "type functions", map directly - onto the type functions in FC: - - type family F a :: * - type instance F Int = Bool - ..etc... - -* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon - -* From the user's point of view (F Int) and Bool are simply - equivalent types. - -* A Haskell 98 type synonym is a degenerate form of a type synonym - family. - -* Type functions can't appear in the LHS of a type function: - type instance F (F Int) = ... -- BAD! - -* Translation of type family decl: - type family F a :: * - translates to - a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon - - type family G a :: * where - G Int = Bool - G Bool = Char - G a = () - translates to - a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the - appropriate CoAxiom representing the equations - -We also support injective type families -- see Note [Injective type families] - -Note [Data type families] -~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Wrappers for data instance tycons] in MkId.hs - -* Data type families are declared thus - data family T a :: * - data instance T Int = T1 | T2 Bool - - Here T is the "family TyCon". - -* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon - -* The user does not see any "equivalent types" as he did with type - synonym families. He just sees constructors with types - T1 :: T Int - T2 :: Bool -> T Int - -* Here's the FC version of the above declarations: - - data T a - data R:TInt = T1 | T2 Bool - axiom ax_ti : T Int ~R R:TInt - - Note that this is a *representational* coercion - The R:TInt is the "representation TyCons". - It has an AlgTyConFlav of - DataFamInstTyCon T [Int] ax_ti - -* The axiom ax_ti may be eta-reduced; see - Note [Eta reduction for data families] in FamInstEnv - -* Data family instances may have a different arity than the data family. - See Note [Arity of data families] in FamInstEnv - -* The data constructor T2 has a wrapper (which is what the - source-level "T2" invokes): - - $WT2 :: Bool -> T Int - $WT2 b = T2 b `cast` sym ax_ti - -* A data instance can declare a fully-fledged GADT: - - data instance T (a,b) where - X1 :: T (Int,Bool) - X2 :: a -> b -> T (a,b) - - Here's the FC version of the above declaration: - - data R:TPair a b where - X1 :: R:TPair Int Bool - X2 :: a -> b -> R:TPair a b - axiom ax_pr :: T (a,b) ~R R:TPair a b - - $WX1 :: forall a b. a -> b -> T (a,b) - $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) - - The R:TPair are the "representation TyCons". - We have a bit of work to do, to unpick the result types of the - data instance declaration for T (a,b), to get the result type in the - representation; e.g. T (a,b) --> R:TPair a b - - The representation TyCon R:TList, has an AlgTyConFlav of - - DataFamInstTyCon T [(a,b)] ax_pr - -* Notice that T is NOT translated to a FC type function; it just - becomes a "data type" with no constructors, which can be coerced - into R:TInt, R:TPair by the axioms. These axioms - axioms come into play when (and *only* when) you - - use a data constructor - - do pattern matching - Rather like newtype, in fact - - As a result - - - T behaves just like a data type so far as decomposition is concerned - - - (T Int) is not implicitly converted to R:TInt during type inference. - Indeed the latter type is unknown to the programmer. - - - There *is* an instance for (T Int) in the type-family instance - environment, but it is only used for overlap checking - - - It's fine to have T in the LHS of a type function: - type instance F (T a) = [a] - - It was this last point that confused me! The big thing is that you - should not think of a data family T as a *type function* at all, not - even an injective one! We can't allow even injective type functions - on the LHS of a type function: - type family injective G a :: * - type instance F (G Int) = Bool - is no good, even if G is injective, because consider - type instance G Int = Bool - type instance F Bool = Char - - So a data type family is not an injective type function. It's just a - data type with some axioms that connect it to other data types. - -* The tyConTyVars of the representation tycon are the tyvars that the - user wrote in the patterns. This is important in TcDeriv, where we - bring these tyvars into scope before type-checking the deriving - clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. - -Note [Associated families and their parent class] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Associated* families are just like *non-associated* families, except -that they have a famTcParent field of (Just cls_tc), which identifies the -parent class. - -However there is an important sharing relationship between - * the tyConTyVars of the parent Class - * the tyConTyVars of the associated TyCon - - class C a b where - data T p a - type F a q b - -Here the 'a' and 'b' are shared with the 'Class'; that is, they have -the same Unique. - -This is important. In an instance declaration we expect - * all the shared variables to be instantiated the same way - * the non-shared variables of the associated type should not - be instantiated at all - - instance C [x] (Tree y) where - data T p [x] = T1 x | T2 p - type F [x] q (Tree y) = (x,y,q) - -Note [TyCon Role signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every tycon has a role signature, assigning a role to each of the tyConTyVars -(or of equal length to the tyConArity, if there are no tyConTyVars). An -example demonstrates these best: say we have a tycon T, with parameters a at -nominal, b at representational, and c at phantom. Then, to prove -representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have -nominal equality between a1 and a2, representational equality between b1 and -b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This -might happen, say, with the following declaration: - - data T a b c where - MkT :: b -> T Int b c - -Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), -as do vanilla synonym tycons. Family tycons have all parameters at role N, -though it is conceivable that we could relax this restriction. (->)'s and -tuples' parameters are at role R. Each primitive tycon declares its roles; -it's worth noting that (~#)'s parameters are at role N. Promoted data -constructors' type arguments are at role R. All kind arguments are at role -N. - -Note [Unboxed tuple RuntimeRep vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The contents of an unboxed tuple may have any representation. Accordingly, -the kind of the unboxed tuple constructor is runtime-representation -polymorphic. - -Type constructor (2 kind arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). - TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) -Data constructor (4 type arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) - (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) - -These extra tyvars (q and r) cause some delicate processing around tuples, -where we need to manually insert RuntimeRep arguments. -The same situation happens with unboxed sums: each alternative -has its own RuntimeRep. -For boxed tuples, there is no levity polymorphism, and therefore -we add RuntimeReps only for the unboxed version. - -Type constructor (no kind arguments) - (,) :: Type -> Type -> Type -Data constructor (2 type arguments) - (,) :: forall a b. a -> b -> (a, b) - - -Note [Injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow injectivity annotations for type families (both open and closed): - - type family F (a :: k) (b :: k) = r | r -> a - type family G a b = res | res -> a b where ... - -Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. -`famTcInj` maybe stores a list of Bools, where each entry corresponds to a -single element of `tyConTyVars` (both lists should have identical length). If no -injectivity annotation was provided `famTcInj` is Nothing. From this follows an -invariant that if `famTcInj` is a Just then at least one element in the list -must be True. - -See also: - * [Injectivity annotation] in GHC.Hs.Decls - * [Renaming injectivity annotation] in RnSource - * [Verifying injectivity annotation] in FamInstEnv - * [Type inference for type families with injectivity] in TcInteract - -************************************************************************ -* * - TyConBinder, TyConTyCoBinder -* * -************************************************************************ --} - -type TyConBinder = VarBndr TyVar TyConBndrVis - --- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really --- contain CoVar. -type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis - -data TyConBndrVis - = NamedTCB ArgFlag - | AnonTCB AnonArgFlag - -instance Outputable TyConBndrVis where - ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag - ppr (AnonTCB af) = text "AnonTCB" <> ppr af - -mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder -mkAnonTyConBinder af tv = ASSERT( isTyVar tv) - Bndr tv (AnonTCB af) - -mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] -mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs - -mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder --- The odd argument order supports currying -mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) - Bndr tv (NamedTCB vis) - -mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] --- The odd argument order supports currying -mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs - --- | Make a Required TyConBinder. It chooses between NamedTCB and --- AnonTCB based on whether the tv is mentioned in the dependent set -mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently - -> TyVar - -> TyConBinder -mkRequiredTyConBinder dep_set tv - | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv - | otherwise = mkAnonTyConBinder VisArg tv - -tyConBinderArgFlag :: TyConBinder -> ArgFlag -tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis - -tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag -tyConBndrVisArgFlag (NamedTCB vis) = vis -tyConBndrVisArgFlag (AnonTCB VisArg) = Required -tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] - -isNamedTyConBinder :: TyConBinder -> Bool --- Identifies kind variables --- E.g. data T k (a:k) = blah --- Here 'k' is a NamedTCB, a variable used in the kind of other binders -isNamedTyConBinder (Bndr _ (NamedTCB {})) = True -isNamedTyConBinder _ = False - -isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis - -isVisibleTcbVis :: TyConBndrVis -> Bool -isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis -isVisibleTcbVis (AnonTCB VisArg) = True -isVisibleTcbVis (AnonTCB InvisArg) = False - -isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) - --- Build the 'tyConKind' from the binders and the result kind. --- Keep in sync with 'mkTyConKind' in iface/IfaceType. -mkTyConKind :: [TyConBinder] -> Kind -> Kind -mkTyConKind bndrs res_kind = foldr mk res_kind bndrs - where - mk :: TyConBinder -> Kind -> Kind - mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k - mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k - -tyConTyVarBinders :: [TyConBinder] -- From the TyCon - -> [TyVarBinder] -- Suitable for the foralls of a term function --- See Note [Building TyVarBinders from TyConBinders] -tyConTyVarBinders tc_bndrs - = map mk_binder tc_bndrs - where - mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv - where - vis = case tc_vis of - AnonTCB VisArg -> Specified - AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg] - NamedTCB Required -> Specified - NamedTCB vis -> vis - --- Returns only tyvars, as covars are always inferred -tyConVisibleTyVars :: TyCon -> [TyVar] -tyConVisibleTyVars tc - = [ tv | Bndr tv vis <- tyConBinders tc - , isVisibleTcbVis vis ] - -{- Note [AnonTCB InvisArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's pretty rare to have an (AnonTCB InvisArg) binder. The -only way it can occur is through equality constraints in kinds. These -can arise in one of two ways: - -* In a PromotedDataCon whose kind has an equality constraint: - - 'MkT :: forall a b. (a~b) => blah - - See Note [Constraints in kinds] in TyCoRep, and - Note [Promoted data constructors] in this module. -* In a data type whose kind has an equality constraint, as in the - following example from #12102: - - data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type - -When mapping an (AnonTCB InvisArg) to an ArgFlag, in -tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot -specify this arguments, even with visible type/kind application; -instead the type checker must fill it in. - -We map (AnonTCB VisArg) to Required, of course: the user must -provide it. It would be utterly wrong to do this for constraint -arguments, which is why AnonTCB must have the AnonArgFlag in -the first place. - -Note [Building TyVarBinders from TyConBinders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We sometimes need to build the quantified type of a value from -the TyConBinders of a type or class. For that we need not -TyConBinders but TyVarBinders (used in forall-type) E.g: - - * From data T a = MkT (Maybe a) - we are going to make a data constructor with type - MkT :: forall a. Maybe a -> T a - See the TyCoVarBinders passed to buildDataCon - - * From class C a where { op :: a -> Maybe a } - we are going to make a default method - $dmop :: forall a. C a => a -> Maybe a - See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType - -Both of these are user-callable. (NB: default methods are not callable -directly by the user but rather via the code generated by 'deriving', -which uses visible type application; see mkDefMethBind.) - -Since they are user-callable we must get their type-argument visibility -information right; and that info is in the TyConBinders. -Here is an example: - - data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * - -The TyCon has - - tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] - -The TyConBinders for App line up with App's kind, given above. - -But the DataCon MkApp has the type - MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b - -That is, its TyCoVarBinders should be - - dataConUnivTyVarBinders = [ Bndr (k:*) Inferred - , Bndr (a:k->*) Specified - , Bndr (b:k) Specified ] - -So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: - - variable names from the TyConBinders - - but changing Anon/Required to Specified - -The last part about Required->Specified comes from this: - data T k (a:k) b = MkT (a b) -Here k is Required in T's kind, but we don't have Required binders in -the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] -in TyCoRep), so we change it to Specified when making MkT's TyCoBinders --} - - -{- Note [The binders/kind/arity fields of a TyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All TyCons have this group of fields - tyConBinders :: [TyConBinder/TyConTyCoBinder] - tyConResKind :: Kind - tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders - -- NB: Currently (Aug 2018), TyCons that own this - -- field really only contain TyVars. So it is - -- [TyVar] instead of [TyCoVar]. - tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind - tyConArity :: Arity -- Cached = length tyConBinders - -They fit together like so: - -* tyConBinders gives the telescope of type/coercion variables on the LHS of the - type declaration. For example: - - type App a (b :: k) = a b - - tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) - , Bndr (a:k->*) AnonTCB - , Bndr (b:k) AnonTCB ] - - Note that that are three binders here, including the - kind variable k. - -* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep - for what the visibility flag means. - -* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and - that TyVar may scope over some other part of the TyCon's definition. Eg - type T a = a -> a - we have - tyConBinders = [ Bndr (a:*) AnonTCB ] - synTcRhs = a -> a - So the 'a' scopes over the synTcRhs - -* From the tyConBinders and tyConResKind we can get the tyConKind - E.g for our App example: - App :: forall k. (k->*) -> k -> * - - We get a 'forall' in the kind for each NamedTCB, and an arrow - for each AnonTCB - - tyConKind is the full kind of the TyCon, not just the result kind - -* For type families, tyConArity is the arguments this TyCon must be - applied to, to be considered saturated. Here we mean "applied to in - the actual Type", not surface syntax; i.e. including implicit kind - variables. So it's just (length tyConBinders) - -* For an algebraic data type, or data instance, the tyConResKind is - always (TYPE r); that is, the tyConBinders are enough to saturate - the type constructor. I'm not quite sure why we have this invariant, - but it's enforced by etaExpandAlgTyCon --} - -instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where - ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) - where - ppr_bi (AnonTCB VisArg) = text "anon-vis" - ppr_bi (AnonTCB InvisArg) = text "anon-invis" - ppr_bi (NamedTCB Required) = text "req" - ppr_bi (NamedTCB Specified) = text "spec" - ppr_bi (NamedTCB Inferred) = text "inf" - -instance Binary TyConBndrVis where - put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } - put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } - - get bh = do { h <- getByte bh - ; case h of - 0 -> do { af <- get bh; return (AnonTCB af) } - _ -> do { vis <- get bh; return (NamedTCB vis) } } - - -{- ********************************************************************* -* * - The TyCon type -* * -************************************************************************ --} - - --- | TyCons represent type constructors. Type constructors are introduced by --- things such as: --- --- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of --- kind @*@ --- --- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor --- --- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor --- of kind @* -> *@ --- --- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor --- of kind @*@ --- --- This data type also encodes a number of primitive, built in type constructors --- such as those for function and tuple types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data TyCon - = -- | The function type constructor, @(->)@ - FunTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRepName :: TyConRepName - } - - -- | Algebraic data types, from - -- - @data@ declarations - -- - @newtype@ declarations - -- - data instance declarations - -- - type instance declarations - -- - the TyCon generated by a class declaration - -- - boxed tuples - -- - unboxed tuples - -- - constraint tuples - -- All these constructors are lifted and boxed except unboxed tuples - -- which should have an 'UnboxedAlgTyCon' parent. - -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. - -- See 'AlgTyConRhs' for more information. - | AlgTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- The tyConTyVars scope over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in algTyConRhs.NewTyCon - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data - -- constructors. - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - tyConCType :: Maybe CType,-- ^ The C type that should be used - -- for this type when using the FFI - -- and CAPI - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT - -- syntax? If so, that doesn't mean it's a - -- true GADT; only that the "where" form - -- was used. This field is used only to - -- guide pretty-printing - - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data - -- type (always empty for GADTs). A - -- \"stupid theta\" is the context to - -- the left of an algebraic type - -- declaration, e.g. @Eq a@ in the - -- declaration @data Eq a => T a ...@. - - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the - -- data constructors of the algebraic type - - algTcFields :: FieldLabelEnv, -- ^ Maps a label to information - -- about the field - - algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration - -- 'TyCon' for derived 'TyCon's representing - -- class or family instances, respectively. - - } - - -- | Represents type synonyms - | SynonymTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - -- tyConTyVars scope over: synTcRhs - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - synTcRhs :: Type, -- ^ Contains information about the expansion - -- of the synonym - - synIsTau :: Bool, -- True <=> the RHS of this synonym does not - -- have any foralls, after expanding any - -- nested synonyms - synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention - -- any type synonym families (data families - -- are fine), again after expanding any - -- nested synonyms - } - - -- | Represents families (both type and data) - -- Argument roles are all Nominal - | FamilyTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - -- tyConTyVars connect an associated family TyCon - -- with its parent class; see TcValidity.checkConsistentFamInst - - famTcResVar :: Maybe Name, -- ^ Name of result type variable, used - -- for pretty-printing with --show-iface - -- and for reifying TyCon in Template - -- Haskell - - famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, - -- abstract, built-in. See comments for - -- FamTyConFlav - - famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families - -- The class tycon in which the family is declared - -- See Note [Associated families and their parent class] - - famTcInj :: Injectivity -- ^ is this a type family injective in - -- its type variables? Nothing if no - -- injectivity annotation was given - } - - -- | Primitive types; cannot be defined in Haskell. This includes - -- the usual suspects (such as @Int#@) as well as foreign-imported - -- types and kinds (@*@, @#@, and @?@) - | PrimTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may - -- not contain bottom) but other are lifted, - -- e.g. @RealWorld@ - -- Only relevant if tyConKind = * - - primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons - -- i.e, *, #, ? - } - - -- | Represents promoted data constructor. - | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConTyCoBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars - dataCon :: DataCon, -- ^ Corresponding data constructor - tcRepName :: TyConRepName, - promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' - } - - -- | These exist only during type-checking. See Note [How TcTyCons work] - -- in TcTyClsDecls - | TcTyCon { - tyConUnique :: Unique, - tyConName :: Name, - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- NB: the TyConArity of a TcTyCon must match - -- the number of Required (positional, user-specified) - -- arguments to the type constructor; see the use - -- of tyConArity in generaliseTcTyCon - - tcTyConScopedTyVars :: [(Name,TyVar)], - -- ^ Scoped tyvars over the tycon's body - -- See Note [Scoped tyvars in a TcTyCon] - - tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? - - tcTyConFlavour :: TyConFlavour - -- ^ What sort of 'TyCon' this represents. - } -{- Note [Scoped tyvars in a TcTyCon] - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The tcTyConScopedTyVars field records the lexicial-binding connection -between the original, user-specified Name (i.e. thing in scope) and -the TcTyVar that the Name is bound to. - -Order *does* matter; the tcTyConScopedTyvars list consists of - specified_tvs ++ required_tvs - -where - * specified ones first - * required_tvs the same as tyConTyVars - * tyConArity = length required_tvs - -See also Note [How TcTyCons work] in TcTyClsDecls --} - --- | Represents right-hand-sides of 'TyCon's for algebraic types -data AlgTyConRhs - - -- | Says that we know nothing about this data type, except that - -- it's represented by a pointer. Used when we export a data type - -- abstractly into an .hi file. - = AbstractTyCon - - -- | Information about those 'TyCon's derived from a @data@ - -- declaration. This includes data types with no constructors at - -- all. - | DataTyCon { - data_cons :: [DataCon], - -- ^ The data type constructors; can be empty if the - -- user declares the type to have no constructors - -- - -- INVARIANT: Kept in order of increasing 'DataCon' - -- tag (see the tag assignment in mkTyConTagMap) - data_cons_size :: Int, - -- ^ Cached value: length data_cons - is_enum :: Bool -- ^ Cached value: is this an enumeration type? - -- See Note [Enumeration types] - } - - | TupleTyCon { -- A boxed, unboxed, or constraint tuple - data_con :: DataCon, -- NB: it can be an *unboxed* tuple - tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint - -- tuple? - } - - -- | An unboxed sum type. - | SumTyCon { - data_cons :: [DataCon], - data_cons_size :: Int -- ^ Cached value: length data_cons - } - - -- | Information about those 'TyCon's derived from a @newtype@ declaration - | NewTyCon { - data_con :: DataCon, -- ^ The unique constructor for the @newtype@. - -- It has no existentials - - nt_rhs :: Type, -- ^ Cached value: the argument type of the - -- constructor, which is just the representation - -- type of the 'TyCon' (remember that @newtype@s - -- do not exist at runtime so need a different - -- representation type). - -- - -- The free 'TyVar's of this type are the - -- 'tyConTyVars' from the corresponding 'TyCon' - - nt_etad_rhs :: ([TyVar], Type), - -- ^ Same as the 'nt_rhs', but this time eta-reduced. - -- Hence the list of 'TyVar's in this field may be - -- shorter than the declared arity of the 'TyCon'. - - -- See Note [Newtype eta] - nt_co :: CoAxiom Unbranched, - -- The axiom coercion that creates the @newtype@ - -- from the representation 'Type'. - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check #1072. - nt_lev_poly :: Bool - -- 'True' if the newtype can be levity polymorphic when - -- fully applied to its arguments, 'False' otherwise. - -- This can only ever be 'True' with UnliftedNewtypes. - -- - -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt) - -- - -- This is cached to make it cheaper to check if a - -- variable binding is levity polymorphic, as used by - -- isTcLevPoly. - } - -mkSumTyConRhs :: [DataCon] -> AlgTyConRhs -mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) - -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs cons - = DataTyCon { - data_cons = cons, - data_cons_size = length cons, - is_enum = not (null cons) && all is_enum_con cons - -- See Note [Enumeration types] in TyCon - } - where - is_enum_con con - | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) - <- dataConFullSig con - = null ex_tvs && null eq_spec && null theta && null arg_tys - --- | Some promoted datacons signify extra info relevant to GHC. For example, --- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' --- constructor of 'PrimRep'. This data structure allows us to store this --- information right in the 'TyCon'. The other approach would be to look --- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. --- See also Note [Getting from RuntimeRep to PrimRep] in RepType -data RuntimeRepInfo - = NoRRI -- ^ an ordinary promoted data con - | RuntimeRep ([Type] -> [PrimRep]) - -- ^ A constructor of @RuntimeRep@. The argument to the function should - -- be the list of arguments to the promoted datacon. - | VecCount Int -- ^ A constructor of @VecCount@ - | VecElem PrimElemRep -- ^ A constructor of @VecElem@ - --- | Extract those 'DataCon's that we are able to learn about. Note --- that visibility in this sense does not correspond to visibility in --- the context of any particular user program! -visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons (DataTyCon{ data_cons = cs }) = cs -visibleDataCons (NewTyCon{ data_con = c }) = [c] -visibleDataCons (TupleTyCon{ data_con = c }) = [c] -visibleDataCons (SumTyCon{ data_cons = cs }) = cs - --- ^ Both type classes as well as family instances imply implicit --- type constructors. These implicit type constructors refer to their parent --- structure (ie, the class or family from which they derive) using a type of --- the following form. -data AlgTyConFlav - = -- | An ordinary type constructor has no parent. - VanillaAlgTyCon - TyConRepName - - -- | An unboxed type constructor. The TyConRepName is a Maybe since we - -- currently don't allow unboxed sums to be Typeable since there are too - -- many of them. See #13276. - | UnboxedAlgTyCon - (Maybe TyConRepName) - - -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in TyCoRep - | ClassTyCon - Class -- INVARIANT: the classTyCon of this Class is the - -- current tycon - TyConRepName - - -- | Type constructors representing an *instance* of a *data* family. - -- Parameters: - -- - -- 1) The type family in question - -- - -- 2) Instance types; free variables are the 'tyConTyVars' - -- of the current 'TyCon' (not the family one). INVARIANT: - -- the number of types matches the arity of the family 'TyCon' - -- - -- 3) A 'CoTyCon' identifying the representation - -- type with the type instance family - | DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) -- The coercion axiom. - -- A *Representational* coercion, - -- of kind T ty1 ty2 ~R R:T a b c - -- where T is the family TyCon, - -- and R:T is the representation TyCon (ie this one) - -- and a,b,c are the tyConTyVars of this TyCon - -- - -- BUT may be eta-reduced; see FamInstEnv - -- Note [Eta reduction for data families] - - -- Cached fields of the CoAxiom, but adjusted to - -- use the tyConTyVars of this TyCon - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- No shorter in length than the tyConTyVars of the family TyCon - -- How could it be longer? See [Arity of data families] in FamInstEnv - - -- E.g. data instance T [a] = ... - -- gives a representation tycon: - -- data R:TList a = ... - -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcParent = DataFamInstTyCon T [a] co - -instance Outputable AlgTyConFlav where - ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" - ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" - ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls - ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" - <+> ppr tc <+> sep (map pprType tys) - --- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class --- name, if any -okParent :: Name -> AlgTyConFlav -> Bool -okParent _ (VanillaAlgTyCon {}) = True -okParent _ (UnboxedAlgTyCon {}) = True -okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) -okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc - -isNoParent :: AlgTyConFlav -> Bool -isNoParent (VanillaAlgTyCon {}) = True -isNoParent _ = False - --------------------- - -data Injectivity - = NotInjective - | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) - deriving( Eq ) - --- | Information pertaining to the expansion of a type synonym (@type@) -data FamTyConFlav - = -- | Represents an open type family without a fixed right hand - -- side. Additional instances can appear at any time. - -- - -- These are introduced by either a top level declaration: - -- - -- > data family T a :: * - -- - -- Or an associated data type declaration, within a class declaration: - -- - -- > class C a b where - -- > data T b :: * - DataFamilyTyCon - TyConRepName - - -- | An open type synonym family e.g. @type family F x y :: * -> *@ - | OpenSynFamilyTyCon - - -- | A closed type synonym family e.g. - -- @type family F x where { F Int = Bool }@ - | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) - -- See Note [Closed type families] - - -- | A closed type synonym family declared in an hs-boot file with - -- type family F a where .. - | AbstractClosedSynFamilyTyCon - - -- | Built-in type family used by the TypeNats solver - | BuiltInSynFamTyCon BuiltInSynFamily - -instance Outputable FamTyConFlav where - ppr (DataFamilyTyCon n) = text "data family" <+> ppr n - ppr OpenSynFamilyTyCon = text "open type family" - ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" - ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax - ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" - ppr (BuiltInSynFamTyCon _) = text "built-in type family" - -{- Note [Closed type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* In an open type family you can add new instances later. This is the - usual case. - -* In a closed type family you can only put equations where the family - is defined. - -A non-empty closed type family has a single axiom with multiple -branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed -type family with no equations does not have an axiom, because there is -nothing for the axiom to prove! - - -Note [Promoted data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All data constructors can be promoted to become a type constructor, -via the PromotedDataCon alternative in TyCon. - -* The TyCon promoted from a DataCon has the *same* Name and Unique as - the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, - say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) - -* We promote the *user* type of the DataCon. Eg - data T = MkT {-# UNPACK #-} !(Bool, Bool) - The promoted kind is - 'MkT :: (Bool,Bool) -> T - *not* - 'MkT :: Bool -> Bool -> T - -* Similarly for GADTs: - data G a where - MkG :: forall b. b -> G [b] - The promoted data constructor has kind - 'MkG :: forall b. b -> G [b] - *not* - 'MkG :: forall a b. (a ~# [b]) => b -> G a - -Note [Enumeration types] -~~~~~~~~~~~~~~~~~~~~~~~~ -We define datatypes with no constructors to *not* be -enumerations; this fixes trac #2578, Otherwise we -end up generating an empty table for - __closure_tbl -which is used by tagToEnum# to map Int# to constructors -in an enumeration. The empty table apparently upset -the linker. - -Moreover, all the data constructor must be enumerations, meaning -they have type (forall abc. T a b c). GADTs are not enumerations. -For example consider - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a -What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. -See #4528. - -Note [Newtype coercions] -~~~~~~~~~~~~~~~~~~~~~~~~ -The NewTyCon field nt_co is a CoAxiom which is used for coercing from -the representation type of the newtype, to the newtype itself. For -example, - - newtype T a = MkT (a -> a) - -the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. - -In the case that the right hand side is a type application -ending with the same type variables as the left hand side, we -"eta-contract" the coercion. So if we had - - newtype S a = MkT [a] - -then we would generate the arity 0 axiom CoS : S ~ []. The -primary reason we do this is to make newtype deriving cleaner. - -In the paper we'd write - axiom CoT : (forall t. T t) ~ (forall t. [t]) -and then when we used CoT at a particular type, s, we'd say - CoT @ s -which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) - -Note [Newtype eta] -~~~~~~~~~~~~~~~~~~ -Consider - newtype Parser a = MkParser (IO a) deriving Monad -Are these two types equal (to Core)? - Monad Parser - Monad IO -which we need to make the derived instance for Monad Parser. - -Well, yes. But to see that easily we eta-reduce the RHS type of -Parser, in this case to ([], Froogle), so that even unsaturated applications -of Parser will work right. This eta reduction is done when the type -constructor is built, and cached in NewTyCon. - -Here's an example that I think showed up in practice -Source code: - newtype T a = MkT [a] - newtype Foo m = MkFoo (forall a. m a -> Int) - - w1 :: Foo [] - w1 = ... - - w2 :: Foo T - w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) - -After desugaring, and discarding the data constructors for the newtypes, -we get: - w2 = w1 `cast` Foo CoT -so the coercion tycon CoT must have - kind: T ~ [] - and arity: 0 - -This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs. - - -************************************************************************ -* * - TyConRepName -* * -********************************************************************* -} - -type TyConRepName = Name -- The Name of the top-level declaration - -- $tcMaybe :: Data.Typeable.Internal.TyCon - -- $tcMaybe = TyCon { tyConName = "Maybe", ... } - -tyConRepName_maybe :: TyCon -> Maybe TyConRepName -tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) - = Just rep_nm -tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) - = mb_rep_nm -tyConRepName_maybe (AlgTyCon { algTcParent = parent }) - | VanillaAlgTyCon rep_nm <- parent = Just rep_nm - | ClassTyCon _ rep_nm <- parent = Just rep_nm - | UnboxedAlgTyCon rep_nm <- parent = rep_nm -tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) - = Just rep_nm -tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) - | isUnboxedSumCon dc -- see #13276 - = Nothing - | otherwise - = Just rep_nm -tyConRepName_maybe _ = Nothing - --- | Make a 'Name' for the 'Typeable' representation of the given wired-in type -mkPrelTyConRepName :: Name -> TyConRepName --- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. -mkPrelTyConRepName tc_name -- Prelude tc_name is always External, - -- so nameModule will work - = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) - where - name_occ = nameOccName tc_name - name_mod = nameModule tc_name - name_uniq = nameUnique tc_name - rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq - | otherwise = dataConTyRepNameUnique name_uniq - (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ - --- | The name (and defining module) for the Typeable representation (TyCon) of a --- type constructor. --- --- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. -tyConRepModOcc :: Module -> OccName -> (Module, OccName) -tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) - where - rep_module - | tc_module == gHC_PRIM = gHC_TYPES - | otherwise = tc_module - - -{- ********************************************************************* -* * - PrimRep -* * -************************************************************************ - -Note [rep swamp] - -GHC has a rich selection of types that represent "primitive types" of -one kind or another. Each of them makes a different set of -distinctions, and mostly the differences are for good reasons, -although it's probably true that we could merge some of these. - -Roughly in order of "includes more information": - - - A Width (cmm/CmmType) is simply a binary value with the specified - number of bits. It may represent a signed or unsigned integer, a - floating-point value, or an address. - - data Width = W8 | W16 | W32 | W64 | W128 - - - Size, which is used in the native code generator, is Width + - floating point information. - - data Size = II8 | II16 | II32 | II64 | FF32 | FF64 - - it is necessary because e.g. the instruction to move a 64-bit float - on x86 (movsd) is different from the instruction to move a 64-bit - integer (movq), so the mov instruction is parameterised by Size. - - - CmmType wraps Width with more information: GC ptr, float, or - other value. - - data CmmType = CmmType CmmCat Width - - data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - - It is important to have GcPtr information in Cmm, since we generate - info tables containing pointerhood for the GC from this. As for - why we have float (and not signed/unsigned) here, see Note [Signed - vs unsigned]. - - - ArgRep makes only the distinctions necessary for the call and - return conventions of the STG machine. It is essentially CmmType - + void. - - - PrimRep makes a few more distinctions than ArgRep: it divides - non-GC-pointers into signed/unsigned and addresses, information - that is necessary for passing these values to foreign functions. - -There's another tension here: whether the type encodes its size in -bytes, or whether its size depends on the machine word size. Width -and CmmType have the size built-in, whereas ArgRep and PrimRep do not. - -This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. - -On the other hand, CmmType includes some "nonsense" values, such as -CmmType GcPtrCat W32 on a 64-bit machine. - -The PrimRep type is closely related to the user-visible RuntimeRep type. -See Note [RuntimeRep and PrimRep] in RepType. - --} - --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, --- and store values of this type. See also Note [RuntimeRep and PrimRep] in RepType --- and Note [VoidRep] in RepType. -data PrimRep - = VoidRep - | LiftedRep - | UnliftedRep -- ^ Unlifted pointer - | Int8Rep -- ^ Signed, 8-bit value - | Int16Rep -- ^ Signed, 16-bit value - | Int32Rep -- ^ Signed, 32-bit value - | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) - | IntRep -- ^ Signed, word-sized value - | Word8Rep -- ^ Unsigned, 8 bit value - | Word16Rep -- ^ Unsigned, 16 bit value - | Word32Rep -- ^ Unsigned, 32 bit value - | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) - | WordRep -- ^ Unsigned, word-sized value - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') - | FloatRep - | DoubleRep - | VecRep Int PrimElemRep -- ^ A vector - deriving( Eq, Show ) - -instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 - put_ bh LiftedRep = putByte bh 1 - put_ bh UnliftedRep = putByte bh 2 - put_ bh Int8Rep = putByte bh 3 - put_ bh Int16Rep = putByte bh 4 - put_ bh Int32Rep = putByte bh 5 - put_ bh Int64Rep = putByte bh 6 - put_ bh IntRep = putByte bh 7 - put_ bh Word8Rep = putByte bh 8 - put_ bh Word16Rep = putByte bh 9 - put_ bh Word32Rep = putByte bh 10 - put_ bh Word64Rep = putByte bh 11 - put_ bh WordRep = putByte bh 12 - put_ bh AddrRep = putByte bh 13 - put_ bh FloatRep = putByte bh 14 - put_ bh DoubleRep = putByte bh 15 - put_ bh (VecRep n el) = putByte bh 16 >> put_ bh n >> put_ bh el - get bh = getByte bh >>= \case - 0 -> pure VoidRep - 1 -> pure LiftedRep - 2 -> pure UnliftedRep - 3 -> pure Int8Rep - 4 -> pure Int16Rep - 5 -> pure Int32Rep - 6 -> pure Int64Rep - 7 -> pure IntRep - 8 -> pure Word8Rep - 9 -> pure Word16Rep - 10 -> pure Word32Rep - 11 -> pure Word64Rep - 12 -> pure WordRep - 13 -> pure AddrRep - 14 -> pure FloatRep - 15 -> pure DoubleRep - 16 -> VecRep <$> get bh <*> get bh - _ -> panic "Decoding PrimRep, invalid byte." - -data PrimElemRep - = Int8ElemRep - | Int16ElemRep - | Int32ElemRep - | Int64ElemRep - | Word8ElemRep - | Word16ElemRep - | Word32ElemRep - | Word64ElemRep - | FloatElemRep - | DoubleElemRep - deriving( Eq, Show ) - -instance Binary PrimElemRep where - put_ bh Int8ElemRep = putByte bh 0 - put_ bh Int16ElemRep = putByte bh 1 - put_ bh Int32ElemRep = putByte bh 2 - put_ bh Int64ElemRep = putByte bh 3 - put_ bh Word8ElemRep = putByte bh 4 - put_ bh Word16ElemRep = putByte bh 5 - put_ bh Word32ElemRep = putByte bh 6 - put_ bh Word64ElemRep = putByte bh 7 - put_ bh FloatElemRep = putByte bh 8 - put_ bh DoubleElemRep = putByte bh 9 - get bh = getByte bh >>= \case - 0 -> pure Int8ElemRep - 1 -> pure Int16ElemRep - 2 -> pure Int32ElemRep - 3 -> pure Int64ElemRep - 4 -> pure Word8ElemRep - 5 -> pure Word16ElemRep - 6 -> pure Word32ElemRep - 7 -> pure Word64ElemRep - 8 -> pure FloatElemRep - 9 -> pure DoubleElemRep - _ -> panic "Decoding PrimElemRep, invalid byte." - -instance Outputable PrimRep where - ppr r = text (show r) - -instance Outputable PrimElemRep where - ppr r = text (show r) - -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - -isGcPtrRep :: PrimRep -> Bool -isGcPtrRep LiftedRep = True -isGcPtrRep UnliftedRep = True -isGcPtrRep _ = False - --- A PrimRep is compatible with another iff one can be coerced to the other. --- See Note [bad unsafe coercion] in CoreLint for when are two types coercible. -primRepCompatible :: DynFlags -> PrimRep -> PrimRep -> Bool -primRepCompatible dflags rep1 rep2 = - (isUnboxed rep1 == isUnboxed rep2) && - (primRepSizeB dflags rep1 == primRepSizeB dflags rep2) && - (primRepIsFloat rep1 == primRepIsFloat rep2) - where - isUnboxed = not . isGcPtrRep - --- More general version of `primRepCompatible` for types represented by zero or --- more than one PrimReps. -primRepsCompatible :: DynFlags -> [PrimRep] -> [PrimRep] -> Bool -primRepsCompatible dflags reps1 reps2 = - length reps1 == length reps2 && - and (zipWith (primRepCompatible dflags) reps1 reps2) - --- | The size of a 'PrimRep' in bytes. --- --- This applies also when used in a constructor, where we allow packing the --- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will --- take only 8 bytes, which for 64-bit arch will be equal to 1 word. --- See also mkVirtHeapOffsetsWithPadding for details of how data fields are --- layed out. -primRepSizeB :: DynFlags -> PrimRep -> Int -primRepSizeB dflags IntRep = wORD_SIZE dflags -primRepSizeB dflags WordRep = wORD_SIZE dflags -primRepSizeB _ Int8Rep = 1 -primRepSizeB _ Int16Rep = 2 -primRepSizeB _ Int32Rep = 4 -primRepSizeB _ Int64Rep = wORD64_SIZE -primRepSizeB _ Word8Rep = 1 -primRepSizeB _ Word16Rep = 2 -primRepSizeB _ Word32Rep = 4 -primRepSizeB _ Word64Rep = wORD64_SIZE -primRepSizeB _ FloatRep = fLOAT_SIZE -primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags -primRepSizeB dflags AddrRep = wORD_SIZE dflags -primRepSizeB dflags LiftedRep = wORD_SIZE dflags -primRepSizeB dflags UnliftedRep = wORD_SIZE dflags -primRepSizeB _ VoidRep = 0 -primRepSizeB _ (VecRep len rep) = len * primElemRepSizeB rep - -primElemRepSizeB :: PrimElemRep -> Int -primElemRepSizeB Int8ElemRep = 1 -primElemRepSizeB Int16ElemRep = 2 -primElemRepSizeB Int32ElemRep = 4 -primElemRepSizeB Int64ElemRep = 8 -primElemRepSizeB Word8ElemRep = 1 -primElemRepSizeB Word16ElemRep = 2 -primElemRepSizeB Word32ElemRep = 4 -primElemRepSizeB Word64ElemRep = 8 -primElemRepSizeB FloatElemRep = 4 -primElemRepSizeB DoubleElemRep = 8 - --- | Return if Rep stands for floating type, --- returns Nothing for vector types. -primRepIsFloat :: PrimRep -> Maybe Bool -primRepIsFloat FloatRep = Just True -primRepIsFloat DoubleRep = Just True -primRepIsFloat (VecRep _ _) = Nothing -primRepIsFloat _ = Just False - - -{- -************************************************************************ -* * - Field labels -* * -************************************************************************ --} - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabels :: TyCon -> [FieldLabel] -tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabelEnv :: TyCon -> FieldLabelEnv -tyConFieldLabelEnv tc - | isAlgTyCon tc = algTcFields tc - | otherwise = emptyDFsEnv - --- | Look up a field label belonging to this 'TyCon' -lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel -lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl - --- | Make a map from strings to FieldLabels from all the data --- constructors of this algebraic tycon -fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv -fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) - | fl <- dataConsFields (visibleDataCons rhs) ] - where - -- Duplicates in this list will be removed by 'mkFsEnv' - dataConsFields dcs = concatMap dataConFieldLabels dcs - - -{- -************************************************************************ -* * -\subsection{TyCon Construction} -* * -************************************************************************ - -Note: the TyCon constructors all take a Kind as one argument, even though -they could, in principle, work out their Kind from their other arguments. -But to do so they need functions from Types, and that makes a nasty -module mutual-recursion. And they aren't called from many places. -So we compromise, and move their Kind calculation to the call site. --} - --- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is recommended to use 'TyCoRep.funTyCon' if you want --- this functionality -mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon -mkFunTyCon name binders rep_nm - = FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConResKind = liftedTypeKind, - tyConKind = mkTyConKind binders liftedTypeKind, - tyConArity = length binders, - tcRepName = rep_nm - } - --- | This is the making of an algebraic 'TyCon'. Notably, you have to --- pass in the generic (in the -XGenerics sense) information about the --- type constructor - you can get hold of it easily (see Generics --- module) -mkAlgTyCon :: Name - -> [TyConBinder] -- ^ Binders of the 'TyCon' - -> Kind -- ^ Result kind - -> [Role] -- ^ The roles for each TyVar - -> Maybe CType -- ^ The C type this type corresponds to - -- when using the CAPI FFI - -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' - -> AlgTyConRhs -- ^ Information about data constructors - -> AlgTyConFlav -- ^ What flavour is it? - -- (e.g. vanilla, type family) - -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> TyCon -mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - tyConCType = cType, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcFields = fieldsOfAlgTcRhs rhs, - algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, - algTcGadtSyntax = gadt_syn - } - --- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> [TyConBinder] - -> [Role] -> AlgTyConRhs -> Class - -> Name -> TyCon -mkClassTyCon name binders roles rhs clas tc_rep_name - = mkAlgTyCon name binders constraintKind roles Nothing [] rhs - (ClassTyCon clas tc_rep_name) - False - -mkTupleTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Result kind of the 'TyCon' - -> Arity -- ^ Arity of the tuple 'TyCon' - -> DataCon - -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> AlgTyConFlav - -> TyCon -mkTupleTyCon name binders res_kind arity con sort parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = binderVars binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = TupleTyCon { data_con = con, - tup_sort = sort }, - algTcFields = emptyDFsEnv, - algTcParent = parent - } - -mkSumTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Kind of the resulting 'TyCon' - -> Arity -- ^ Arity of the sum - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' - -> [DataCon] - -> AlgTyConFlav - -> TyCon -mkSumTyCon name binders res_kind arity tyvars cons parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = tyvars, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = mkSumTyConRhs cons, - algTcFields = emptyDFsEnv, - algTcParent = parent - } - --- | Makes a tycon suitable for use during type-checking. It stores --- a variety of details about the definition of the TyCon, but no --- right-hand side. It lives only during the type-checking of a --- mutually-recursive group of tycons; it is then zonked to a proper --- TyCon in zonkTcTyCon. --- See also Note [Kind checking recursive type and class declarations] --- in TcTyClsDecls. -mkTcTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ /result/ kind only - -> [(Name,TcTyVar)] -- ^ Scoped type variables; - -- see Note [How TcTyCons work] in TcTyClsDecls - -> Bool -- ^ Is this TcTyCon generalised already? - -> TyConFlavour -- ^ What sort of 'TyCon' this represents - -> TyCon -mkTcTyCon name binders res_kind scoped_tvs poly flav - = TcTyCon { tyConUnique = getUnique name - , tyConName = name - , tyConTyVars = binderVars binders - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tcTyConScopedTyVars = scoped_tvs - , tcTyConIsPoly = poly - , tcTyConFlavour = flav } - --- | No scoped type variables (to be used with mkTcTyCon). -noTcTyConScopedTyVars :: [(Name, TcTyVar)] -noTcTyConScopedTyVars = [] - --- | Create an unlifted primitive 'TyCon', such as @Int#@. -mkPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind, never levity-polymorphic - -> [Role] -> TyCon -mkPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) - --- | Kind constructors -mkKindTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> Name -> TyCon -mkKindTyCon name binders res_kind roles rep_nm - = tc - where - tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) - --- | Create a lifted primitive 'TyCon' such as @RealWorld@ -mkLiftedPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> TyCon -mkLiftedPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) - where rep_nm = mkPrelTyConRepName name - -mkPrimTyCon' :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind, never levity-polymorphic - -- (If you need a levity-polymorphic PrimTyCon, change - -- isTcLevPoly.) - -> [Role] - -> Bool -> Maybe TyConRepName -> TyCon -mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm - = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length roles, - tcRoles = roles, - isUnlifted = is_unlifted, - primRepName = rep_nm - } - --- | Create a type synonym 'TyCon' -mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> Bool -> Bool -> TyCon -mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free - = SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - synTcRhs = rhs, - synIsTau = is_tau, - synIsFamFree = is_fam_free - } - --- | Create a type family 'TyCon' -mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> Maybe Name -> FamTyConFlav - -> Maybe Class -> Injectivity -> TyCon -mkFamilyTyCon name binders res_kind resVar flav parent inj - = FamilyTyCon - { tyConUnique = nameUnique name - , tyConName = name - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConTyVars = binderVars binders - , famTcResVar = resVar - , famTcFlav = flav - , famTcParent = classTyCon <$> parent - , famTcInj = inj - } - - --- | Create a promoted data constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- as the data constructor itself; when we pretty-print --- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> TyConRepName - -> [TyConTyCoBinder] -> Kind -> [Role] - -> RuntimeRepInfo -> TyCon -mkPromotedDataCon con name rep_name binders res_kind roles rep_info - = PromotedDataCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = length roles, - tcRoles = roles, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - dataCon = con, - tcRepName = rep_name, - promDcRepInfo = rep_info - } - -isFunTyCon :: TyCon -> Bool -isFunTyCon (FunTyCon {}) = True -isFunTyCon _ = False - --- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) -isAbstractTyCon :: TyCon -> Bool -isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True -isAbstractTyCon _ = False - --- | Does this 'TyCon' represent something that cannot be defined in Haskell? -isPrimTyCon :: TyCon -> Bool -isPrimTyCon (PrimTyCon {}) = True -isPrimTyCon _ = False - --- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can --- only be true for primitive and unboxed-tuple 'TyCon's -isUnliftedTyCon :: TyCon -> Bool -isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) - = is_unlifted -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | SumTyCon {} <- rhs - = True -isUnliftedTyCon _ = False - --- | Returns @True@ if the supplied 'TyCon' resulted from either a --- @data@ or @newtype@ declaration -isAlgTyCon :: TyCon -> Bool -isAlgTyCon (AlgTyCon {}) = True -isAlgTyCon _ = False - --- | Returns @True@ for vanilla AlgTyCons -- that is, those created --- with a @data@ or @newtype@ declaration. -isVanillaAlgTyCon :: TyCon -> Bool -isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True -isVanillaAlgTyCon _ = False - -isDataTyCon :: TyCon -> Bool --- ^ Returns @True@ for data types that are /definitely/ represented by --- heap-allocated constructors. These are scrutinised by Core-level --- @case@ expressions, and they get info tables allocated for them. --- --- Generally, the function will be true for all @data@ types and false --- for @newtype@s, unboxed tuples, unboxed sums and type family --- 'TyCon's. But it is not guaranteed to return @True@ in all cases --- that it could. --- --- NB: for a data type family, only the /instance/ 'TyCon's --- get an info table. The family declaration 'TyCon' does not -isDataTyCon (AlgTyCon {algTcRhs = rhs}) - = case rhs of - TupleTyCon { tup_sort = sort } - -> isBoxed (tupleSortBoxity sort) - SumTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False -isDataTyCon _ = False - --- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) --- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) --- See also Note [Decomposing equality] in TcCanonical -isInjectiveTyCon :: TyCon -> Role -> Bool -isInjectiveTyCon _ Phantom = False -isInjectiveTyCon (FunTyCon {}) _ = True -isInjectiveTyCon (AlgTyCon {}) Nominal = True -isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational - = isGenInjAlgRhs rhs -isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) - Nominal = True -isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj -isInjectiveTyCon (FamilyTyCon {}) _ = False -isInjectiveTyCon (PrimTyCon {}) _ = True -isInjectiveTyCon (PromotedDataCon {}) _ = True -isInjectiveTyCon (TcTyCon {}) _ = True - -- Reply True for TcTyCon to minimise knock on type errors - -- See Note [How TcTyCons work] item (1) in TcTyClsDecls - --- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T tys ~X t), then (t's head ~X T). --- See also Note [Decomposing equality] in TcCanonical -isGenerativeTyCon :: TyCon -> Role -> Bool -isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True -isGenerativeTyCon (FamilyTyCon {}) _ = False - -- in all other cases, injectivity implies generativity -isGenerativeTyCon tc r = isInjectiveTyCon tc r - --- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective --- with respect to representational equality? -isGenInjAlgRhs :: AlgTyConRhs -> Bool -isGenInjAlgRhs (TupleTyCon {}) = True -isGenInjAlgRhs (SumTyCon {}) = True -isGenInjAlgRhs (DataTyCon {}) = True -isGenInjAlgRhs (AbstractTyCon {}) = False -isGenInjAlgRhs (NewTyCon {}) = False - --- | Is this 'TyCon' that for a @newtype@ -isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon _ = False - --- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it --- expands into, and (possibly) a coercion from the representation type to the --- @newtype@. --- Returns @Nothing@ if this is not possible. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = co, - nt_rhs = rhs }}) - = Just (tvs, rhs, co) -unwrapNewTyCon_maybe _ = Nothing - -unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, - nt_etad_rhs = (tvs,rhs) }}) - = Just (tvs, rhs, co) -unwrapNewTyConEtad_maybe _ = Nothing - -isProductTyCon :: TyCon -> Bool --- True of datatypes or newtypes that have --- one, non-existential, data constructor --- See Note [Product types] -isProductTyCon tc@(AlgTyCon {}) - = case algTcRhs tc of - TupleTyCon {} -> True - DataTyCon{ data_cons = [data_con] } - -> null (dataConExTyCoVars data_con) - NewTyCon {} -> True - _ -> False -isProductTyCon _ = False - -isDataProductTyCon_maybe :: TyCon -> Maybe DataCon --- True of datatypes (not newtypes) with --- one, vanilla, data constructor --- See Note [Product types] -isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [con] } - | null (dataConExTyCoVars con) -- non-existential - -> Just con - TupleTyCon { data_con = con } - -> Just con - _ -> Nothing -isDataProductTyCon_maybe _ = Nothing - -isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] -isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = cons } - | cons `lengthExceeds` 1 - , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - SumTyCon { data_cons = cons } - | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - _ -> Nothing -isDataSumTyCon_maybe _ = Nothing - -{- Note [Product types] -~~~~~~~~~~~~~~~~~~~~~~~ -A product type is - * A data type (not a newtype) - * With one, boxed data constructor - * That binds no existential type variables - -The main point is that product types are amenable to unboxing for - * Strict function calls; we can transform - f (D a b) = e - to - fw a b = e - via the worker/wrapper transformation. (Question: couldn't this - work for existentials too?) - - * CPR for function results; we can transform - f x y = let ... in D a b - to - fw x y = let ... in (# a, b #) - -Note that the data constructor /can/ have evidence arguments: equality -constraints, type classes etc. So it can be GADT. These evidence -arguments are simply value arguments, and should not get in the way. --} - - --- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? -isTypeSynonymTyCon :: TyCon -> Bool -isTypeSynonymTyCon (SynonymTyCon {}) = True -isTypeSynonymTyCon _ = False - -isTauTyCon :: TyCon -> Bool -isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau -isTauTyCon _ = True - -isFamFreeTyCon :: TyCon -> Bool -isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free -isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isFamFreeTyCon _ = True - --- As for newtypes, it is in some contexts important to distinguish between --- closed synonyms and synonym families, as synonym families have no unique --- right hand side to which a synonym family application can expand. --- - --- | True iff we can decompose (T a b c) into ((T a b) c) --- I.e. is it injective and generative w.r.t nominal equality? --- That is, if (T a b) ~N d e f, is it always the case that --- (T ~N d), (a ~N e) and (b ~N f)? --- Specifically NOT true of synonyms (open and otherwise) --- --- It'd be unusual to call mustBeSaturated on a regular H98 --- type synonym, because you should probably have expanded it first --- But regardless, it's not decomposable -mustBeSaturated :: TyCon -> Bool -mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour - --- | Is this an algebraic 'TyCon' declared with the GADT syntax? -isGadtSyntaxTyCon :: TyCon -> Bool -isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res -isGadtSyntaxTyCon _ = False - --- | Is this an algebraic 'TyCon' which is just an enumeration of values? -isEnumerationTyCon :: TyCon -> Bool --- See Note [Enumeration types] in TyCon -isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) - = case rhs of - DataTyCon { is_enum = res } -> res - TupleTyCon {} -> arity == 0 - _ -> False -isEnumerationTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family? -isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (FamilyTyCon {}) = True -isFamilyTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family with --- instances? -isOpenFamilyTyCon :: TyCon -> Bool -isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) - | OpenSynFamilyTyCon <- flav = True - | DataFamilyTyCon {} <- flav = True -isOpenFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isTypeFamilyTyCon :: TyCon -> Bool -isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) -isTypeFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isDataFamilyTyCon :: TyCon -> Bool -isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isDataFamilyTyCon _ = False - --- | Is this an open type family TyCon? -isOpenTypeFamilyTyCon :: TyCon -> Bool -isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True -isOpenTypeFamilyTyCon _ = False - --- | Is this a non-empty closed type family? Returns 'Nothing' for --- abstract or empty closed families. -isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) -isClosedSynFamilyTyConWithAxiom_maybe - (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb -isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing - --- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an --- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is --- injective), or 'NotInjective' otherwise. -tyConInjectivityInfo :: TyCon -> Injectivity -tyConInjectivityInfo tc - | FamilyTyCon { famTcInj = inj } <- tc - = inj - | isInjectiveTyCon tc Nominal - = Injective (replicate (tyConArity tc) True) - | otherwise - = NotInjective - -isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily -isBuiltInSynFamTyCon_maybe - (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops -isBuiltInSynFamTyCon_maybe _ = Nothing - -isDataFamFlav :: FamTyConFlav -> Bool -isDataFamFlav (DataFamilyTyCon {}) = True -- Data family -isDataFamFlav _ = False -- Type synonym family - --- | Is this TyCon for an associated type? -isTyConAssoc :: TyCon -> Bool -isTyConAssoc = isJust . tyConAssoc_maybe - --- | Get the enclosing class TyCon (if there is one) for the given TyCon. -tyConAssoc_maybe :: TyCon -> Maybe TyCon -tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour - --- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour -tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon -tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe _ = Nothing - --- The unit tycon didn't used to be classed as a tuple tycon --- but I thought that was silly so I've undone it --- If it can't be for some reason, it should be a AlgTyCon -isTupleTyCon :: TyCon -> Bool --- ^ Does this 'TyCon' represent a tuple? --- --- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to --- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they --- get spat into the interface file as tuple tycons, so I don't think --- it matters. -isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True -isTupleTyCon _ = False - -tyConTuple_maybe :: TyCon -> Maybe TupleSort -tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort} <- rhs = Just sort -tyConTuple_maybe _ = Nothing - --- | Is this the 'TyCon' for an unboxed tuple? -isUnboxedTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnboxedTupleTyCon _ = False - --- | Is this the 'TyCon' for a boxed tuple? -isBoxedTupleTyCon :: TyCon -> Bool -isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = isBoxed (tupleSortBoxity sort) -isBoxedTupleTyCon _ = False - --- | Is this the 'TyCon' for an unboxed sum? -isUnboxedSumTyCon :: TyCon -> Bool -isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) - | SumTyCon {} <- rhs - = True -isUnboxedSumTyCon _ = False - --- | Is this the 'TyCon' for a /promoted/ tuple? -isPromotedTupleTyCon :: TyCon -> Bool -isPromotedTupleTyCon tyCon - | Just dataCon <- isPromotedDataCon_maybe tyCon - , isTupleTyCon (dataConTyCon dataCon) = True - | otherwise = False - --- | Is this a PromotedDataCon? -isPromotedDataCon :: TyCon -> Bool -isPromotedDataCon (PromotedDataCon {}) = True -isPromotedDataCon _ = False - --- | Retrieves the promoted DataCon if this is a PromotedDataCon; -isPromotedDataCon_maybe :: TyCon -> Maybe DataCon -isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc -isPromotedDataCon_maybe _ = Nothing - --- | Is this tycon really meant for use at the kind level? That is, --- should it be permitted without -XDataKinds? -isKindTyCon :: TyCon -> Bool -isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys - --- | These TyCons should be allowed at the kind level, even without --- -XDataKinds. -kindTyConKeys :: UniqSet Unique -kindTyConKeys = unionManyUniqSets - ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] - : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon - , vecCountTyCon, vecElemTyCon ] ) - where - tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) - -isLiftedTypeKindTyConName :: Name -> Bool -isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) - --- | Identifies implicit tycons that, in particular, do not go into interface --- files (because they are implicitly reconstructed when the interface is --- read). --- --- Note that: --- --- * Associated families are implicit, as they are re-constructed from --- the class declaration in which they reside, and --- --- * Family instances are /not/ implicit as they represent the instance body --- (similar to a @dfun@ does that for a class instance). --- --- * Tuples are implicit iff they have a wired-in name --- (namely: boxed and unboxed tuples are wired-in and implicit, --- but constraint tuples are not) -isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon (FunTyCon {}) = True -isImplicitTyCon (PrimTyCon {}) = True -isImplicitTyCon (PromotedDataCon {}) = True -isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) - | TupleTyCon {} <- rhs = isWiredInName name - | SumTyCon {} <- rhs = True - | otherwise = False -isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent -isImplicitTyCon (SynonymTyCon {}) = False -isImplicitTyCon (TcTyCon {}) = False - -tyConCType_maybe :: TyCon -> Maybe CType -tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc -tyConCType_maybe _ = Nothing - --- | Is this a TcTyCon? (That is, one only used during type-checking?) -isTcTyCon :: TyCon -> Bool -isTcTyCon (TcTyCon {}) = True -isTcTyCon _ = False - -setTcTyConKind :: TyCon -> Kind -> TyCon --- Update the Kind of a TcTyCon --- The new kind is always a zonked version of its previous --- kind, so we don't need to update any other fields. --- See Note [The Purely Kinded Invariant] in TcHsType -setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } -setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) - --- | Could this TyCon ever be levity-polymorphic when fully applied? --- True is safe. False means we're sure. Does only a quick check --- based on the TyCon's category. --- Precondition: The fully-applied TyCon has kind (TYPE blah) -isTcLevPoly :: TyCon -> Bool -isTcLevPoly FunTyCon{} = False -isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) - | UnboxedAlgTyCon _ <- parent - = True - | NewTyCon { nt_lev_poly = lev_poly } <- rhs - = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360) - | otherwise - = False -isTcLevPoly SynonymTyCon{} = True -isTcLevPoly FamilyTyCon{} = True -isTcLevPoly PrimTyCon{} = False -isTcLevPoly TcTyCon{} = False -isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) - -{- ------------------------------------------------ --- Expand type-constructor applications ------------------------------------------------ --} - -expandSynTyCon_maybe - :: TyCon - -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body - -- type of the synonym (not yet substituted) - -- and any arguments remaining from the - -- application - --- ^ Expand a type synonym application, if any -expandSynTyCon_maybe tc tys - | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc - = case tys `listLengthCmp` arity of - GT -> Just (tvs `zip` tys, rhs, drop arity tys) - EQ -> Just (tvs `zip` tys, rhs, []) - LT -> Nothing - | otherwise - = Nothing - ----------------- - --- | Check if the tycon actually refers to a proper `data` or `newtype` --- with user defined constructors rather than one from a class or other --- construction. - --- NB: This is only used in TcRnExports.checkPatSynParent to determine if an --- exported tycon can have a pattern synonym bundled with it, e.g., --- module Foo (TyCon(.., PatSyn)) where -isTyConWithSrcDataCons :: TyCon -> Bool -isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = - case rhs of - DataTyCon {} -> isSrcParent - NewTyCon {} -> isSrcParent - TupleTyCon {} -> isSrcParent - _ -> False - where - isSrcParent = isNoParent parent -isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) - = True -- #14058 -isTyConWithSrcDataCons _ = False - - --- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no --- constructors could be found -tyConDataCons :: TyCon -> [DataCon] --- It's convenient for tyConDataCons to return the --- empty list for type synonyms etc -tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] - --- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' --- is the sort that can have any constructors (note: this does not include --- abstract algebraic types) -tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) - = case rhs of - DataTyCon { data_cons = cons } -> Just cons - NewTyCon { data_con = con } -> Just [con] - TupleTyCon { data_con = con } -> Just [con] - SumTyCon { data_cons = cons } -> Just cons - _ -> Nothing -tyConDataCons_maybe _ = Nothing - --- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ --- type with one alternative, a tuple type or a @newtype@ then that constructor --- is returned. If the 'TyCon' has more than one constructor, or represents a --- primitive or function type constructor then @Nothing@ is returned. In any --- other case, the function panics -tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - NewTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleDataCon_maybe _ = Nothing - -tyConSingleDataCon :: TyCon -> DataCon -tyConSingleDataCon tc - = case tyConSingleDataCon_maybe tc of - Just c -> c - Nothing -> pprPanic "tyConDataCon" (ppr tc) - -tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon --- Returns (Just con) for single-constructor --- *algebraic* data types *not* newtypes -tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleAlgDataCon_maybe _ = Nothing - --- | Determine the number of value constructors a 'TyCon' has. Panics if the --- 'TyCon' is not algebraic or a tuple -tyConFamilySize :: TyCon -> Int -tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons_size = size } -> size - NewTyCon {} -> 1 - TupleTyCon {} -> 1 - SumTyCon { data_cons_size = size } -> size - _ -> pprPanic "tyConFamilySize 1" (ppr tc) -tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) - --- | Extract an 'AlgTyConRhs' with information about data constructors from an --- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' -algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs other = pprPanic "algTyConRhs" (ppr other) - --- | Extract type variable naming the result of injective type family -tyConFamilyResVar_maybe :: TyCon -> Maybe Name -tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res -tyConFamilyResVar_maybe _ = Nothing - --- | Get the list of roles for the type parameters of a TyCon -tyConRoles :: TyCon -> [Role] --- See also Note [TyCon Role signatures] -tyConRoles tc - = case tc of - { FunTyCon {} -> [Nominal, Nominal, Representational, Representational] - ; AlgTyCon { tcRoles = roles } -> roles - ; SynonymTyCon { tcRoles = roles } -> roles - ; FamilyTyCon {} -> const_role Nominal - ; PrimTyCon { tcRoles = roles } -> roles - ; PromotedDataCon { tcRoles = roles } -> roles - ; TcTyCon {} -> const_role Nominal - } - where - const_role r = replicate (tyConArity tc) r - --- | Extract the bound type variables and type expansion of a type synonym --- 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) - = (tvs, rhs) -newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) - --- | The number of type parameters that need to be passed to a newtype to --- resolve it. May be less than in the definition if it can be eta-contracted. -newTyConEtadArity :: TyCon -> Int -newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) - = length (fst tvs_rhs) -newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) - --- | Extract the bound type variables and type expansion of an eta-contracted --- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConEtadRhs :: TyCon -> ([TyVar], Type) -newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs -newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) - --- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to --- construct something with the @newtype@s type from its representation type --- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns --- @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co -newTyConCo_maybe _ = Nothing - -newTyConCo :: TyCon -> CoAxiom Unbranched -newTyConCo tc = case newTyConCo_maybe tc of - Just co -> co - Nothing -> pprPanic "newTyConCo" (ppr tc) - -newTyConDataCon_maybe :: TyCon -> Maybe DataCon -newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con -newTyConDataCon_maybe _ = Nothing - --- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context --- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration --- @data Eq a => T a ...@ -tyConStupidTheta :: TyCon -> [PredType] -tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid -tyConStupidTheta (FunTyCon {}) = [] -tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) - --- | Extract the 'TyVar's bound by a vanilla type synonym --- and the corresponding (unsubstituted) right hand side. -synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) -synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) - = Just (tyvars, ty) -synTyConDefn_maybe _ = Nothing - --- | Extract the information pertaining to the right hand side of a type synonym --- (@type@) declaration. -synTyConRhs_maybe :: TyCon -> Maybe Type -synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs -synTyConRhs_maybe _ = Nothing - --- | Extract the flavour of a type family (with all the extra information that --- it carries) -famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav -famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav -famTyConFlav_maybe _ = Nothing - --- | Is this 'TyCon' that for a class instance? -isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True -isClassTyCon _ = False - --- | If this 'TyCon' is that for a class instance, return the class it is for. --- Otherwise returns @Nothing@ -tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas -tyConClass_maybe _ = Nothing - --- | Return the associated types of the 'TyCon', if any -tyConATs :: TyCon -> [TyCon] -tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas -tyConATs _ = [] - ----------------------------------------------------------------------------- --- | Is this 'TyCon' that for a data family instance? -isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) - = True -isFamInstTyCon _ = False - -tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) -tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) - = Just (f, ts, ax) -tyConFamInstSig_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return the family in question --- and the instance types. Otherwise, return @Nothing@ -tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) - = Just (f, ts) -tyConFamInst_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which --- represents a coercion identifying the representation type with the type --- instance family. Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) - = Just ax -tyConFamilyCoercion_maybe _ = Nothing - --- | Extract any 'RuntimeRepInfo' from this TyCon -tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo -tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri -tyConRuntimeRepInfo _ = NoRRI - -- could panic in that second case. But Douglas Adams told me not to. - -{- -Note [Constructor tag allocation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking we need to allocate constructor tags to constructors. -They are allocated based on the position in the data_cons field of TyCon, -with the first constructor getting fIRST_TAG. - -We used to pay linear cost per constructor, with each constructor looking up -its relative index in the constructor list. That was quadratic and prohibitive -for large data types with more than 10k constructors. - -The current strategy is to build a NameEnv with a mapping from costructor's -Name to ConTag and pass it down to buildDataCon for efficient lookup. - -Relevant ticket: #14657 --} - -mkTyConTagMap :: TyCon -> NameEnv ConTag -mkTyConTagMap tycon = - mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] - -- See Note [Constructor tag allocation] - -{- -************************************************************************ -* * -\subsection[TyCon-instances]{Instance declarations for @TyCon@} -* * -************************************************************************ - -@TyCon@s are compared by comparing their @Unique@s. --} - -instance Eq TyCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable TyCon where - getUnique tc = tyConUnique tc - -instance Outputable TyCon where - -- At the moment a promoted TyCon has the same Name as its - -- corresponding TyCon, so we add the quote to distinguish it here - ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc - where - pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc) - then text "[tc]" - else empty - --- | Paints a picture of what a 'TyCon' represents, in broad strokes. --- This is used towards more informative error messages. -data TyConFlavour - = ClassFlavour - | TupleFlavour Boxity - | SumFlavour - | DataTypeFlavour - | NewtypeFlavour - | AbstractTypeFlavour - | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | ClosedTypeFamilyFlavour - | TypeSynonymFlavour - | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. - | PromotedDataConFlavour - deriving Eq - -instance Outputable TyConFlavour where - ppr = text . go - where - go ClassFlavour = "class" - go (TupleFlavour boxed) | isBoxed boxed = "tuple" - | otherwise = "unboxed tuple" - go SumFlavour = "unboxed sum" - go DataTypeFlavour = "data type" - go NewtypeFlavour = "newtype" - go AbstractTypeFlavour = "abstract type" - go (DataFamilyFlavour (Just _)) = "associated data family" - go (DataFamilyFlavour Nothing) = "data family" - go (OpenTypeFamilyFlavour (Just _)) = "associated type family" - go (OpenTypeFamilyFlavour Nothing) = "type family" - go ClosedTypeFamilyFlavour = "type family" - go TypeSynonymFlavour = "type synonym" - go BuiltInTypeFlavour = "built-in type" - go PromotedDataConFlavour = "promoted data constructor" - -tyConFlavour :: TyCon -> TyConFlavour -tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) - | ClassTyCon _ _ <- parent = ClassFlavour - | otherwise = case rhs of - TupleTyCon { tup_sort = sort } - -> TupleFlavour (tupleSortBoxity sort) - SumTyCon {} -> SumFlavour - DataTyCon {} -> DataTypeFlavour - NewTyCon {} -> NewtypeFlavour - AbstractTyCon {} -> AbstractTypeFlavour -tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) - = case flav of - DataFamilyTyCon{} -> DataFamilyFlavour parent - OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent - ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour - AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour - BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour -tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour -tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour -tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav - --- | Can this flavour of 'TyCon' appear unsaturated? -tcFlavourMustBeSaturated :: TyConFlavour -> Bool -tcFlavourMustBeSaturated ClassFlavour = False -tcFlavourMustBeSaturated DataTypeFlavour = False -tcFlavourMustBeSaturated NewtypeFlavour = False -tcFlavourMustBeSaturated DataFamilyFlavour{} = False -tcFlavourMustBeSaturated TupleFlavour{} = False -tcFlavourMustBeSaturated SumFlavour = False -tcFlavourMustBeSaturated AbstractTypeFlavour = False -tcFlavourMustBeSaturated BuiltInTypeFlavour = False -tcFlavourMustBeSaturated PromotedDataConFlavour = False -tcFlavourMustBeSaturated TypeSynonymFlavour = True -tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True -tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True - --- | Is this flavour of 'TyCon' an open type family or a data family? -tcFlavourIsOpen :: TyConFlavour -> Bool -tcFlavourIsOpen DataFamilyFlavour{} = True -tcFlavourIsOpen OpenTypeFamilyFlavour{} = True -tcFlavourIsOpen ClosedTypeFamilyFlavour = False -tcFlavourIsOpen ClassFlavour = False -tcFlavourIsOpen DataTypeFlavour = False -tcFlavourIsOpen NewtypeFlavour = False -tcFlavourIsOpen TupleFlavour{} = False -tcFlavourIsOpen SumFlavour = False -tcFlavourIsOpen AbstractTypeFlavour = False -tcFlavourIsOpen BuiltInTypeFlavour = False -tcFlavourIsOpen PromotedDataConFlavour = False -tcFlavourIsOpen TypeSynonymFlavour = False - -pprPromotionQuote :: TyCon -> SDoc --- Promoted data constructors already have a tick in their OccName -pprPromotionQuote tc - = case tc of - PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types - _ -> empty - -instance NamedThing TyCon where - getName = tyConName - -instance Data.Data TyCon where - -- don't traverse? - toConstr _ = abstractConstr "TyCon" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "TyCon" - -instance Binary Injectivity where - put_ bh NotInjective = putByte bh 0 - put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs - - get bh = do { h <- getByte bh - ; case h of - 0 -> return NotInjective - _ -> do { xs <- get bh - ; return (Injective xs) } } - -{- -************************************************************************ -* * - Walking over recursive TyCons -* * -************************************************************************ - -Note [Expanding newtypes and products] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When expanding a type to expose a data-type constructor, we need to be -careful about newtypes, lest we fall into an infinite loop. Here are -the key examples: - - newtype Id x = MkId x - newtype Fix f = MkFix (f (Fix f)) - newtype T = MkT (T -> T) - - Type Expansion - -------------------------- - T T -> T - Fix Maybe Maybe (Fix Maybe) - Id (Id Int) Int - Fix Id NO NO NO - -Notice that - * We can expand T, even though it's recursive. - * We can expand Id (Id Int), even though the Id shows up - twice at the outer level, because Id is non-recursive - -So, when expanding, we keep track of when we've seen a recursive -newtype at outermost level; and bail out if we see it again. - -We sometimes want to do the same for product types, so that the -strictness analyser doesn't unbox infinitely deeply. - -More precisely, we keep a *count* of how many times we've seen it. -This is to account for - data instance T (a,b) = MkT (T a) (T b) -Then (#10482) if we have a type like - T (Int,(Int,(Int,(Int,Int)))) -we can still unbox deeply enough during strictness analysis. -We have to treat T as potentially recursive, but it's still -good to be able to unwrap multiple layers. - -The function that manages all this is checkRecTc. --} - -data RecTcChecker = RC !Int (NameEnv Int) - -- The upper bound, and the number of times - -- we have encountered each TyCon - --- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. -initRecTc :: RecTcChecker -initRecTc = RC defaultRecTcMaxBound emptyNameEnv - --- | The default upper bound (100) for the number of times a 'RecTcChecker' is --- allowed to encounter each 'TyCon'. -defaultRecTcMaxBound :: Int -defaultRecTcMaxBound = 100 --- Should we have a flag for this? - --- | Change the upper bound for the number of times a 'RecTcChecker' is allowed --- to encounter each 'TyCon'. -setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker -setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts - -checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker --- Nothing => Recursion detected --- Just rec_tcs => Keep going -checkRecTc (RC bound rec_nts) tc - = case lookupNameEnv rec_nts tc_name of - Just n | n >= bound -> Nothing - | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) - Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) - where - tc_name = tyConName tc - --- | Returns whether or not this 'TyCon' is definite, or a hole --- that may be filled in at some later point. See Note [Skolem abstract data] -tyConSkolem :: TyCon -> Bool -tyConSkolem = isHoleName . tyConName - --- Note [Skolem abstract data] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Skolem abstract data arises from data declarations in an hsig file. --- --- The best analogy is to interpret the types declared in signature files as --- elaborating to universally quantified type variables; e.g., --- --- unit p where --- signature H where --- data T --- data S --- module M where --- import H --- f :: (T ~ S) => a -> b --- f x = x --- --- elaborates as (with some fake structural types): --- --- p :: forall t s. { f :: forall a b. t ~ s => a -> b } --- p = { f = \x -> x } -- ill-typed --- --- It is clear that inside p, t ~ s is not provable (and --- if we tried to write a function to cast t to s, that --- would not work), but if we call p @Int @Int, clearly Int ~ Int --- is provable. The skolem variables are all distinct from --- one another, but we can't make assumptions like "f is --- inaccessible", because the skolem variables will get --- instantiated eventually! --- --- Skolem abstractness can apply to "non-abstract" data as well): --- --- unit p where --- signature H1 where --- data T = MkT --- signature H2 where --- data T = MkT --- module M where --- import qualified H1 --- import qualified H2 --- f :: (H1.T ~ H2.T) => a -> b --- f x = x --- --- This is why the test is on the original name of the TyCon, --- not whether it is abstract or not. diff --git a/types/TyCon.hs-boot b/types/TyCon.hs-boot deleted file mode 100644 --- a/types/TyCon.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module TyCon where - -import GhcPrelude -import Binary - -data TyCon -data PrimRep - -instance Eq PrimRep -instance Binary PrimRep - -isTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool diff --git a/types/Type.hs b/types/Type.hs deleted file mode 100644 --- a/types/Type.hs +++ /dev/null @@ -1,3209 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1998 --- --- Type - public interface - -{-# LANGUAGE CPP, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Main functions for manipulating types and type-related things -module Type ( - -- Note some of this is just re-exports from TyCon.. - - -- * Main data types representing Types - -- $type_classification - - -- $representation_types - TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - KindOrType, PredType, ThetaType, - Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, - KnotTied, - - -- ** Constructing and deconstructing types - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, - getCastedTyVar_maybe, tyVarKind, varType, - - mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, - splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, - - mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, - splitFunTy, splitFunTy_maybe, - splitFunTys, funResultTy, funArgTy, - - mkTyConApp, mkTyConTy, - tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, - tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, - splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, - tcSplitTyConApp_maybe, - splitListTyConApp_maybe, - repSplitTyConApp_maybe, - - mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, - mkSpecForAllTy, mkSpecForAllTys, - mkVisForAllTys, mkTyCoInvForAllTy, - mkInvForAllTy, mkInvForAllTys, - splitForAllTys, splitForAllTysSameVis, - splitForAllVarBndrs, - splitForAllTy_maybe, splitForAllTy, - splitForAllTy_ty_maybe, splitForAllTy_co_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, - mkTyConBindersPreferAnon, - mkPiTy, mkPiTys, - mkLamType, mkLamTypes, - piResultTy, piResultTys, - applyTysX, dropForAlls, - mkFamilyTyConApp, - - mkNumLitTy, isNumLitTy, - mkStrLitTy, isStrLitTy, - isLitTy, - - isPredTy, - - getRuntimeRep_maybe, kindRep_maybe, kindRep, - - mkCastTy, mkCoercionTy, splitCastTy_maybe, - discardCast, - - userTypeError_maybe, pprUserTypeErrorTy, - - coAxNthLHS, - stripCoercionTy, - - splitPiTysInvisible, splitPiTysInvisibleN, - invisibleTyBndrCount, - filterOutInvisibleTypes, filterOutInferredTypes, - partitionInvisibleTypes, partitionInvisibles, - tyConArgFlags, appTyArgFlags, - synTyConResKind, - - modifyJoinResTy, setJoinResTy, - - -- ** Analyzing types - TyCoMapper(..), mapType, mapCoercion, - - -- (Newtypes) - newTyConInstRhs, - - -- ** Binders - sameVis, - mkTyCoVarBinder, mkTyCoVarBinders, - mkTyVarBinders, - mkAnonBinder, - isAnonTyCoBinder, - binderVar, binderVars, binderType, binderArgFlag, - tyCoBinderType, tyCoBinderVar_maybe, - tyBinderType, - binderRelevantType_maybe, - isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, - isInvisibleBinder, isNamedBinder, - tyConBindersTyCoBinders, - - -- ** Common type constructors - funTyCon, - - -- ** Predicates on types - isTyVarTy, isFunTy, isCoercionTy, - isCoercionTy_maybe, isForAllTy, - isForAllTy_ty, isForAllTy_co, - isPiTy, isTauTy, isFamFreeTy, - isCoVarType, - - isValidJoinPointType, - tyConAppNeedsKindSig, - - -- *** Levity and boxity - isLiftedType_maybe, - isLiftedTypeKind, isUnliftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, - isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, - isAlgType, isDataFamilyAppType, - isPrimitiveType, isStrictType, - isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, - dropRuntimeRepArgs, - getRuntimeRep, - - -- * Main data types representing Kinds - Kind, - - -- ** Finding the kind of a type - typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly, - tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, - tcIsRuntimeTypeKind, - - -- ** Common Kind - liftedTypeKind, - - -- * Type free variables - tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, - tyCoVarsOfType, tyCoVarsOfTypes, - tyCoVarsOfTypeDSet, - coVarsOfType, - coVarsOfTypes, - closeOverKindsDSet, closeOverKindsFV, closeOverKindsList, - closeOverKinds, - - noFreeVarsOfType, - splitVisVarsOfType, splitVisVarsOfTypes, - expandTypeSynonyms, - typeSize, occCheckExpand, - - -- * Well-scoped lists of variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - - -- * Type comparison - eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, - nonDetCmpTypesX, nonDetCmpTc, - eqVarBndrs, - - -- * Forcing evaluation of types - seqType, seqTypes, - - -- * Other views onto Types - coreView, tcView, - - tyConsOfType, - - -- * Main type substitution data types - TvSubstEnv, -- Representation widely visible - TCvSubst(..), -- Representation visible to a few friends - - -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - - mkTCvSubst, zipTvSubst, mkTvSubstPrs, - zipTCvSubst, - notElemTCvSubst, - getTvSubstEnv, setTvSubstEnv, - zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendCvSubst, - extendTvSubst, extendTvSubstBinderAndInScope, - extendTvSubstList, extendTvSubstAndInScope, - extendTCvSubstList, - extendTvSubstWithClone, - extendTCvSubstWithClone, - isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, - isEmptyTCvSubst, unionTCvSubst, - - -- ** Performing substitution on types and kinds - substTy, substTys, substTyWith, substTysWith, substTheta, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, - substVarBndr, substVarBndrs, - cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyKind, - tidyTyCoVarBinder, tidyTyCoVarBinders, - - -- * Kinds - isConstraintKindCon, - classifiesTypeWithValues, - isKindLevPoly - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import BasicTypes - --- We import the representation and primitive functions from TyCoRep. --- Many things are reexported, but not the representation! - -import TyCoRep -import TyCoSubst -import TyCoTidy -import TyCoFVs - --- friends: -import Var -import VarEnv -import VarSet -import UniqSet - -import TyCon -import TysPrim -import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind - , typeSymbolKind, liftedTypeKind - , constraintKind ) -import PrelNames -import CoAxiom -import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo - , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo - , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo - , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo - , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo - , decomposePiCos, coercionKind, coercionType - , isReflexiveCo, seqCo ) - --- others -import Util -import FV -import Outputable -import FastString -import Pair -import ListSetOps -import Unique ( nonDetCmpUnique ) - -import Maybes ( orElse ) -import Data.Maybe ( isJust ) -import Control.Monad ( guard ) - --- $type_classification --- #type_classification# --- --- Types are one of: --- --- [Unboxed] Iff its representation is other than a pointer --- Unboxed types are also unlifted. --- --- [Lifted] Iff it has bottom as an element. --- Closures always have lifted types: i.e. any --- let-bound identifier in Core must have a lifted --- type. Operationally, a lifted object is one that --- can be entered. --- Only lifted types may be unified with a type variable. --- --- [Algebraic] Iff it is a type with one or more constructors, whether --- declared with @data@ or @newtype@. --- An algebraic type is one that can be deconstructed --- with a case expression. This is /not/ the same as --- lifted types, because we also include unboxed --- tuples in this classification. --- --- [Data] Iff it is a type declared with @data@, or a boxed tuple. --- --- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. --- --- Currently, all primitive types are unlifted, but that's not necessarily --- the case: for example, @Int@ could be primitive. --- --- Some primitive types are unboxed, such as @Int#@, whereas some are boxed --- but unlifted (such as @ByteArray#@). The only primitive types that we --- classify as algebraic are the unboxed tuples. --- --- Some examples of type classifications that may make this a bit clearer are: --- --- @ --- Type primitive boxed lifted algebraic --- ----------------------------------------------------------------------------- --- Int# Yes No No No --- ByteArray# Yes Yes No No --- (\# a, b \#) Yes No No Yes --- (\# a | b \#) Yes No No Yes --- ( a, b ) No Yes Yes Yes --- [a] No Yes Yes Yes --- @ - --- $representation_types --- A /source type/ is a type that is a separate type as far as the type checker is --- concerned, but which has a more low-level representation as far as Core-to-Core --- passes and the rest of the back end is concerned. --- --- You don't normally have to worry about this, as the utility functions in --- this module will automatically convert a source into a representation type --- if they are spotted, to the best of its abilities. If you don't want this --- to happen, use the equivalent functions from the "TcType" module. - -{- -************************************************************************ -* * - Type representation -* * -************************************************************************ - -Note [coreView vs tcView] -~~~~~~~~~~~~~~~~~~~~~~~~~ -So far as the typechecker is concerned, 'Constraint' and 'TYPE -LiftedRep' are distinct kinds. - -But in Core these two are treated as identical. - -We implement this by making 'coreView' convert 'Constraint' to 'TYPE -LiftedRep' on the fly. The function tcView (used in the type checker) -does not do this. - -See also #11715, which tracks removing this inconsistency. - --} - --- | Gives the typechecker view of a type. This unwraps synonyms but --- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into --- TYPE LiftedRep. Returns Nothing if no unwrapping happens. --- See also Note [coreView vs tcView] -{-# INLINE tcView #-} -tcView :: Type -> Maybe Type -tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - -- The free vars of 'rhs' should all be bound by 'tenv', so it's - -- ok to use 'substTy' here. - -- See also Note [The substitution invariant] in TyCoSubst. - -- Its important to use mkAppTys, rather than (foldl AppTy), - -- because the function part might well return a - -- partially-applied type constructor; indeed, usually will! -tcView _ = Nothing - -{-# INLINE coreView #-} -coreView :: Type -> Maybe Type --- ^ This function Strips off the /top layer only/ of a type synonym --- application (if any) its underlying representation type. --- Returns Nothing if there is nothing to look through. --- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. --- --- By being non-recursive and inlined, this case analysis gets efficiently --- joined onto the case analysis that the caller is already doing -coreView ty@(TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') - -- This equation is exactly like tcView - - -- At the Core level, Constraint = Type - -- See Note [coreView vs tcView] - | isConstraintKindCon tc - = ASSERT2( null tys, ppr ty ) - Just liftedTypeKind - -coreView _ = Nothing - ------------------------------------------------ -expandTypeSynonyms :: Type -> Type --- ^ Expand out all type synonyms. Actually, it'd suffice to expand out --- just the ones that discard type variables (e.g. type Funny a = Int) --- But we don't know which those are currently, so we just expand all. --- --- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, --- not in the kinds of any TyCon or TyVar mentioned in the type. --- --- Keep this synchronized with 'synonymTyConsOfType' -expandTypeSynonyms ty - = go (mkEmptyTCvSubst in_scope) ty - where - in_scope = mkInScopeSet (tyCoVarsOfType ty) - - go subst (TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys - = let subst' = mkTvSubst in_scope (mkVarEnv tenv) - -- Make a fresh substitution; rhs has nothing to - -- do with anything that has happened so far - -- NB: if you make changes here, be sure to build an - -- /idempotent/ substitution, even in the nested case - -- type T a b = a -> b - -- type S x y = T y x - -- (#11665) - in mkAppTys (go subst' rhs) tys' - | otherwise - = TyConApp tc expanded_tys - where - expanded_tys = (map (go subst) tys) - - go _ (LitTy l) = LitTy l - go subst (TyVarTy tv) = substTyVar subst tv - go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) - go subst ty@(FunTy _ arg res) - = ty { ft_arg = go subst arg, ft_res = go subst res } - go subst (ForAllTy (Bndr tv vis) t) - = let (subst', tv') = substVarBndrUsing go subst tv in - ForAllTy (Bndr tv' vis) (go subst' t) - go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) - go subst (CoercionTy co) = mkCoercionTy (go_co subst co) - - go_mco _ MRefl = MRefl - go_mco subst (MCo co) = MCo (go_co subst co) - - go_co subst (Refl ty) - = mkNomReflCo (go subst ty) - go_co subst (GRefl r ty mco) - = mkGReflCo r (go subst ty) (go_mco subst mco) - -- NB: coercions are always expanded upon creation - go_co subst (TyConAppCo r tc args) - = mkTyConAppCo r tc (map (go_co subst) args) - go_co subst (AppCo co arg) - = mkAppCo (go_co subst co) (go_co subst arg) - go_co subst (ForAllCo tv kind_co co) - = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in - mkForAllCo tv' kind_co' (go_co subst' co) - go_co subst (FunCo r co1 co2) - = mkFunCo r (go_co subst co1) (go_co subst co2) - go_co subst (CoVarCo cv) - = substCoVar subst cv - go_co subst (AxiomInstCo ax ind args) - = mkAxiomInstCo ax ind (map (go_co subst) args) - go_co subst (UnivCo p r t1 t2) - = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) - go_co subst (SymCo co) - = mkSymCo (go_co subst co) - go_co subst (TransCo co1 co2) - = mkTransCo (go_co subst co1) (go_co subst co2) - go_co subst (NthCo r n co) - = mkNthCo r n (go_co subst co) - go_co subst (LRCo lr co) - = mkLRCo lr (go_co subst co) - go_co subst (InstCo co arg) - = mkInstCo (go_co subst co) (go_co subst arg) - go_co subst (KindCo co) - = mkKindCo (go_co subst co) - go_co subst (SubCo co) - = mkSubCo (go_co subst co) - go_co subst (AxiomRuleCo ax cs) - = AxiomRuleCo ax (map (go_co subst) cs) - go_co _ (HoleCo h) - = pprPanic "expandTypeSynonyms hit a hole" (ppr h) - - go_prov _ UnsafeCoerceProv = UnsafeCoerceProv - go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) - go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) - go_prov _ p@(PluginProv _) = p - - -- the "False" and "const" are to accommodate the type of - -- substForAllCoBndrUsing, which is general enough to - -- handle coercion optimization (which sometimes swaps the - -- order of a coercion) - go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst - - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @kindRep * = LiftedRep@; Panics if this is not possible. --- Treats * and Constraint as the same -kindRep :: HasDebugCallStack => Kind -> Type -kindRep k = case kindRep_maybe k of - Just r -> r - Nothing -> pprPanic "kindRep" (ppr k) - --- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. --- For example, @kindRep_maybe * = Just LiftedRep@ --- Returns 'Nothing' if the kind is not of form (TYPE rr) --- Treats * and Constraint as the same -kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type -kindRep_maybe kind - | Just kind' <- coreView kind = kindRep_maybe kind' - | TyConApp tc [arg] <- kind - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing - --- | This version considers Constraint to be the same as *. Returns True --- if the argument is equivalent to Type/Constraint and False otherwise. --- See Note [Kind Constraint and kind Type] -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False - -isLiftedRuntimeRep :: Type -> Bool --- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep --- False of type variables (a :: RuntimeRep) --- and of other reps e.g. (IntRep :: RuntimeRep) -isLiftedRuntimeRep rep - | Just rep' <- coreView rep = isLiftedRuntimeRep rep' - | TyConApp rr_tc args <- rep - , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True - | otherwise = False - --- | Returns True if the kind classifies unlifted types and False otherwise. --- Note that this returns False for levity-polymorphic kinds, which may --- be specialized to a kind that classifies unlifted types. -isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isUnliftedRuntimeRep rep - Nothing -> False - -isUnliftedRuntimeRep :: Type -> Bool --- True of definitely-unlifted RuntimeReps --- False of (LiftedRep :: RuntimeRep) --- and of variables (a :: RuntimeRep) -isUnliftedRuntimeRep rep - | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' - | TyConApp rr_tc _ <- rep -- NB: args might be non-empty - -- e.g. TupleRep [r1, .., rn] - = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) - -- Avoid searching all the unlifted RuntimeRep type cons - -- In the RuntimeRep data type, only LiftedRep is lifted - -- But be careful of type families (F tys) :: RuntimeRep - | otherwise {- Variables, applications -} - = False - --- | Is this the type 'RuntimeRep'? -isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' -isRuntimeRepTy (TyConApp tc args) - | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True -isRuntimeRepTy _ = False - --- | Is a tyvar of type 'RuntimeRep'? -isRuntimeRepVar :: TyVar -> Bool -isRuntimeRepVar = isRuntimeRepTy . tyVarKind - - -{- -************************************************************************ -* * - Analyzing types -* * -************************************************************************ - -These functions do a map-like operation over types, performing some operation -on all variables and binding sites. Primarily used for zonking. - -Note [Efficiency for mapCoercion ForAllCo case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant. -It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches -the left-hand kind of the coercion. This is convenient lots of the time, but -not when mapping a function over a coercion. - -The problem is that tcm_tybinder will affect the TyCoVar's kind and -mapCoercion will affect the Coercion, and we hope that the results will be -the same. Even if they are the same (which should generally happen with -correct algorithms), then there is an efficiency issue. In particular, -this problem seems to make what should be a linear algorithm into a potentially -exponential one. But it's only going to be bad in the case where there's -lots of foralls in the kinds of other foralls. Like this: - - forall a : (forall b : (forall c : ...). ...). ... - -This construction seems unlikely. So we'll do the inefficient, easy way -for now. - -Note [Specialising mappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These INLINABLE pragmas are indispensable. mapType/mapCoercion are used -to implement zonking, and it's vital that they get specialised to the TcM -monad. This specialisation happens automatically (that is, without a -SPECIALISE pragma) as long as the definitions are INLINABLE. For example, -this one change made a 20% allocation difference in perf/compiler/T5030. - --} - --- | This describes how a "map" operation over a type/coercion should behave -data TyCoMapper env m - = TyCoMapper - { tcm_tyvar :: env -> TyVar -> m Type - , tcm_covar :: env -> CoVar -> m Coercion - , tcm_hole :: env -> CoercionHole -> m Coercion - -- ^ What to do with coercion holes. - -- See Note [Coercion holes] in TyCoRep. - - , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) - -- ^ The returned env is used in the extended scope - - , tcm_tycon :: TyCon -> m TyCon - -- ^ This is used only for TcTyCons - -- a) To zonk TcTyCons - -- b) To turn TcTyCons into TyCons. - -- See Note [Type checking recursive type and class declarations] - -- in TcTyClsDecls - } - -{-# INLINABLE mapType #-} -- See Note [Specialising mappers] -mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type -mapType mapper@(TyCoMapper { tcm_tyvar = tyvar - , tcm_tycobinder = tycobinder - , tcm_tycon = tycon }) - env ty - = go ty - where - go (TyVarTy tv) = tyvar env tv - go (AppTy t1 t2) = mkAppTy <$> go t1 <*> go t2 - go ty@(LitTy {}) = return ty - go (CastTy ty co) = mkCastTy <$> go ty <*> mapCoercion mapper env co - go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co - - go ty@(FunTy _ arg res) - = do { arg' <- go arg; res' <- go res - ; return (ty { ft_arg = arg', ft_res = res' }) } - - go ty@(TyConApp tc tys) - | isTcTyCon tc - = do { tc' <- tycon tc - ; mkTyConApp tc' <$> mapM go tys } - - -- Not a TcTyCon - | null tys -- Avoid allocation in this very - = return ty -- common case (E.g. Int, LiftedRep etc) - - | otherwise - = mkTyConApp tc <$> mapM go tys - - go (ForAllTy (Bndr tv vis) inner) - = do { (env', tv') <- tycobinder env tv vis - ; inner' <- mapType mapper env' inner - ; return $ ForAllTy (Bndr tv' vis) inner' } - -{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] -mapCoercion :: Monad m - => TyCoMapper env m -> env -> Coercion -> m Coercion -mapCoercion mapper@(TyCoMapper { tcm_covar = covar - , tcm_hole = cohole - , tcm_tycobinder = tycobinder - , tcm_tycon = tycon }) - env co - = go co - where - go_mco MRefl = return MRefl - go_mco (MCo co) = MCo <$> (go co) - - go (Refl ty) = Refl <$> mapType mapper env ty - go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco) - go (TyConAppCo r tc args) - = do { tc' <- if isTcTyCon tc - then tycon tc - else return tc - ; mkTyConAppCo r tc' <$> mapM go args } - go (AppCo c1 c2) = mkAppCo <$> go c1 <*> go c2 - go (ForAllCo tv kind_co co) - = do { kind_co' <- go kind_co - ; (env', tv') <- tycobinder env tv Inferred - ; co' <- mapCoercion mapper env' co - ; return $ mkForAllCo tv' kind_co' co' } - -- See Note [Efficiency for mapCoercion ForAllCo case] - go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 - go (CoVarCo cv) = covar env cv - go (AxiomInstCo ax i args) - = mkAxiomInstCo ax i <$> mapM go args - go (HoleCo hole) = cohole env hole - go (UnivCo p r t1 t2) - = mkUnivCo <$> go_prov p <*> pure r - <*> mapType mapper env t1 <*> mapType mapper env t2 - go (SymCo co) = mkSymCo <$> go co - go (TransCo c1 c2) = mkTransCo <$> go c1 <*> go c2 - go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos - go (NthCo r i co) = mkNthCo r i <$> go co - go (LRCo lr co) = mkLRCo lr <$> go co - go (InstCo co arg) = mkInstCo <$> go co <*> go arg - go (KindCo co) = mkKindCo <$> go co - go (SubCo co) = mkSubCo <$> go co - - go_prov UnsafeCoerceProv = return UnsafeCoerceProv - go_prov (PhantomProv co) = PhantomProv <$> go co - go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co - go_prov p@(PluginProv _) = return p - -{- -************************************************************************ -* * -\subsection{Constructor-specific functions} -* * -************************************************************************ - - ---------------------------------------------------------------------- - TyVarTy - ~~~~~~~ --} - --- | Attempts to obtain the type variable underlying a 'Type', and panics with the --- given message if this is not a type variable type. See also 'getTyVar_maybe' -getTyVar :: String -> Type -> TyVar -getTyVar msg ty = case getTyVar_maybe ty of - Just tv -> tv - Nothing -> panic ("getTyVar: " ++ msg) - -isTyVarTy :: Type -> Bool -isTyVarTy ty = isJust (getTyVar_maybe ty) - --- | Attempts to obtain the type variable underlying a 'Type' -getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' - | otherwise = repGetTyVar_maybe ty - --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind ty -getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' -getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -getCastedTyVar_maybe (TyVarTy tv) - = Just (tv, mkReflCo Nominal (tyVarKind tv)) -getCastedTyVar_maybe _ = Nothing - --- | Attempts to obtain the type variable underlying a 'Type', without --- any expansion -repGetTyVar_maybe :: Type -> Maybe TyVar -repGetTyVar_maybe (TyVarTy tv) = Just tv -repGetTyVar_maybe _ = Nothing - -{- ---------------------------------------------------------------------- - AppTy - ~~~~~ -We need to be pretty careful with AppTy to make sure we obey the -invariant that a TyConApp is always visibly so. mkAppTy maintains the -invariant: use it. - -Note [Decomposing fat arrow c=>t] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can we unify (a b) with (Eq a => ty)? If we do so, we end up with -a partial application like ((=>) Eq a) which doesn't make sense in -source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). -Here's an example (#9858) of how you might do it: - i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep - i p = typeRep p - - j = i (Proxy :: Proxy (Eq Int => Int)) -The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, -but suppose we want that. But then in the call to 'i', we end -up decomposing (Eq Int => Int), and we definitely don't want that. - -This really only applies to the type checker; in Core, '=>' and '->' -are the same, as are 'Constraint' and '*'. But for now I've put -the test in repSplitAppTy_maybe, which applies throughout, because -the other calls to splitAppTy are in Unify, which is also used by -the type checker (e.g. when matching type-function equations). - --} - --- | Applies a type to another, as in e.g. @k a@ -mkAppTy :: Type -> Type -> Type - -- See Note [Respecting definitional equality], invariant (EQ1). -mkAppTy (CastTy fun_ty co) arg_ty - | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] - = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co - -mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) -mkAppTy ty1 ty2 = AppTy ty1 ty2 - -- Note that the TyConApp could be an - -- under-saturated type synonym. GHC allows that; e.g. - -- type Foo k = k a -> k a - -- type Id x = x - -- foo :: Foo Id -> Foo Id - -- - -- Here Id is partially applied in the type sig for Foo, - -- but once the type synonyms are expanded all is well - -- - -- Moreover in TcHsTypes.tcInferApps we build up a type - -- (T t1 t2 t3) one argument at a type, thus forming - -- (T t1), (T t1 t2), etc - -mkAppTys :: Type -> [Type] -> Type -mkAppTys ty1 [] = ty1 -mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy - -- Why do this? See (EQ1) of - -- Note [Respecting definitional equality] - -- in TyCoRep - = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers - where - (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys - (args_to_cast, leftovers) = splitAtList arg_cos arg_tys - casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos -mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) -mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 - -------------- -splitAppTy_maybe :: Type -> Maybe (Type, Type) --- ^ Attempt to take a type application apart, whether it is a --- function, type constructor, or plain type application. Note --- that type family applications are NEVER unsaturated by this! -splitAppTy_maybe ty | Just ty' <- coreView ty - = splitAppTy_maybe ty' -splitAppTy_maybe ty = repSplitAppTy_maybe ty - -------------- -repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that --- any Core view stuff is already done -repSplitAppTy_maybe (FunTy _ ty1 ty2) - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -repSplitAppTy_maybe (AppTy ty1 ty2) - = Just (ty1, ty2) - -repSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! - -repSplitAppTy_maybe _other = Nothing - --- This one doesn't break apart (c => t). --- See Note [Decomposing fat arrow c=>t] --- Defined here to avoid module loops between Unify and TcType. -tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that --- any coreView stuff is already done. Refuses to look through (c => t) -tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }) - | InvisArg <- af - = Nothing -- See Note [Decomposing fat arrow c=>t] - - | otherwise - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcRepSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! -tcRepSplitAppTy_maybe _other = Nothing - -------------- -splitAppTy :: Type -> (Type, Type) --- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', --- and panics if this is not possible -splitAppTy ty = case splitAppTy_maybe ty of - Just pr -> pr - Nothing -> panic "splitAppTy" - -------------- -splitAppTys :: Type -> (Type, [Type]) --- ^ Recursively splits a type as far as is possible, leaving a residual --- type being applied to and the type arguments applied to it. Never fails, --- even if that means returning an empty list of type applications. -splitAppTys ty = split ty ty [] - where - split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args - split _ (AppTy ty arg) args = split ty ty (arg:args) - split _ (TyConApp tc tc_args) args - = let -- keep type families saturated - n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy _ ty1 ty2) args - = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split orig_ty _ args = (orig_ty, args) - --- | Like 'splitAppTys', but doesn't look through type synonyms -repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) -repSplitAppTys ty = split ty [] - where - split (AppTy ty arg) args = split ty (arg:args) - split (TyConApp tc tc_args) args - = let n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split (FunTy _ ty1 ty2) args - = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split ty args = (ty, args) - -{- - LitTy - ~~~~~ --} - -mkNumLitTy :: Integer -> Type -mkNumLitTy n = LitTy (NumTyLit n) - --- | Is this a numeric literal. We also look through type synonyms. -isNumLitTy :: Type -> Maybe Integer -isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 -isNumLitTy (LitTy (NumTyLit n)) = Just n -isNumLitTy _ = Nothing - -mkStrLitTy :: FastString -> Type -mkStrLitTy s = LitTy (StrTyLit s) - --- | Is this a symbol literal. We also look through type synonyms. -isStrLitTy :: Type -> Maybe FastString -isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 -isStrLitTy (LitTy (StrTyLit s)) = Just s -isStrLitTy _ = Nothing - --- | Is this a type literal (symbol or numeric). -isLitTy :: Type -> Maybe TyLit -isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1 -isLitTy (LitTy l) = Just l -isLitTy _ = Nothing - --- | Is this type a custom user error? --- If so, give us the kind and the error message. -userTypeError_maybe :: Type -> Maybe Type -userTypeError_maybe t - = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - - ; guard (tyConName tc == errorMessageTypeErrorFamName) - ; return msg } - --- | Render a type corresponding to a user type error into a SDoc. -pprUserTypeErrorTy :: Type -> SDoc -pprUserTypeErrorTy ty = - case splitTyConApp_maybe ty of - - -- Text "Something" - Just (tc,[txt]) - | tyConName tc == typeErrorTextDataConName - , Just str <- isStrLitTy txt -> ftext str - - -- ShowType t - Just (tc,[_k,t]) - | tyConName tc == typeErrorShowTypeDataConName -> ppr t - - -- t1 :<>: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorAppendDataConName -> - pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 - - -- t1 :$$: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorVAppendDataConName -> - pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 - - -- An unevaluated type function - _ -> ppr ty - - - - -{- ---------------------------------------------------------------------- - FunTy - ~~~~~ - -Note [Representation of function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Functions (e.g. Int -> Char) can be thought of as being applications -of funTyCon (known in Haskell surface syntax as (->)), - - (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) - (a :: TYPE r1) (b :: TYPE r2). - a -> b -> Type - -However, for efficiency's sake we represent saturated applications of (->) -with FunTy. For instance, the type, - - (->) r1 r2 a b - -is equivalent to, - - FunTy (Anon a) b - -Note how the RuntimeReps are implied in the FunTy representation. For this -reason we must be careful when recontructing the TyConApp representation (see, -for instance, splitTyConApp_maybe). - -In the compiler we maintain the invariant that all saturated applications of -(->) are represented with FunTy. - -See #11714. --} - -splitFunTy :: Type -> (Type, Type) --- ^ Attempts to extract the argument and result types from a type, and --- panics if that is not possible. See also 'splitFunTy_maybe' -splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' -splitFunTy (FunTy _ arg res) = (arg, res) -splitFunTy other = pprPanic "splitFunTy" (ppr other) - -splitFunTy_maybe :: Type -> Maybe (Type, Type) --- ^ Attempts to extract the argument and result types from a type -splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' -splitFunTy_maybe (FunTy _ arg res) = Just (arg, res) -splitFunTy_maybe _ = Nothing - -splitFunTys :: Type -> ([Type], Type) -splitFunTys ty = split [] ty ty - where - split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args _ (FunTy _ arg res) = split (arg:args) res res - split args orig_ty _ = (reverse args, orig_ty) - -funResultTy :: Type -> Type --- ^ Extract the function result type and panic if that is not possible -funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (FunTy { ft_res = res }) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) - -funArgTy :: Type -> Type --- ^ Extract the function argument type and panic if that is not possible -funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (FunTy { ft_arg = arg }) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) - --- ^ Just like 'piResultTys' but for a single argument --- Try not to iterate 'piResultTy', because it's inefficient to substitute --- one variable at a time; instead use 'piResultTys" -piResultTy :: HasDebugCallStack => Type -> Type -> Type -piResultTy ty arg = case piResultTy_maybe ty arg of - Just res -> res - Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) - -piResultTy_maybe :: Type -> Type -> Maybe Type --- We don't need a 'tc' version, because --- this function behaves the same for Type and Constraint -piResultTy_maybe ty arg - | Just ty' <- coreView ty = piResultTy_maybe ty' arg - - | FunTy { ft_res = res } <- ty - = Just res - - | ForAllTy (Bndr tv _) res <- ty - = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes [arg,res] - in Just (substTy (extendTCvSubst empty_subst tv arg) res) - - | otherwise - = Nothing - --- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) --- where f :: f_ty --- 'piResultTys' is interesting because: --- 1. 'f_ty' may have more for-alls than there are args --- 2. Less obviously, it may have fewer for-alls --- For case 2. think of: --- piResultTys (forall a.a) [forall b.b, Int] --- This really can happen, but only (I think) in situations involving --- undefined. For example: --- undefined :: forall a. a --- Term: undefined @(forall b. b->b) @Int --- This term should have type (Int -> Int), but notice that --- there are more type args than foralls in 'undefined's type. - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs - --- This is a heavily used function (e.g. from typeKind), --- so we pay attention to efficiency, especially in the special case --- where there are no for-alls so we are just dropping arrows from --- a function type/kind. -piResultTys :: HasDebugCallStack => Type -> [Type] -> Type -piResultTys ty [] = ty -piResultTys ty orig_args@(arg:args) - | Just ty' <- coreView ty - = piResultTys ty' orig_args - - | FunTy { ft_res = res } <- ty - = piResultTys res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst init_subst tv arg) res args - - | otherwise - = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) - where - init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) - - go :: TCvSubst -> Type -> [Type] -> Type - go subst ty [] = substTyUnchecked subst ty - - go subst ty all_args@(arg:args) - | Just ty' <- coreView ty - = go subst ty' all_args - - | FunTy { ft_res = res } <- ty - = go subst res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst subst tv arg) res args - - | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] - = go init_subst - (substTy subst ty) - all_args - - | otherwise - = -- We have not run out of arguments, but the function doesn't - -- have the right kind to apply to them; so panic. - -- Without the explicit isEmptyVarEnv test, an ill-kinded type - -- would give an infniite loop, which is very unhelpful - -- c.f. #15473 - pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) - -applyTysX :: [TyVar] -> Type -> [Type] -> Type --- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys --- Assumes that (/\tvs. body_ty) is closed -applyTysX tvs body_ty arg_tys - = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff ) - ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) - mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) - (drop n_tvs arg_tys) - where - pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] - n_tvs = length tvs - - - -{- Note [Care with kind instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - T :: forall k. k -and we are finding the kind of - T (forall b. b -> b) * Int -Then - T (forall b. b->b) :: k[ k :-> forall b. b->b] - :: forall b. b -> b -So - T (forall b. b->b) * :: (b -> b)[ b :-> *] - :: * -> * - -In other words we must intantiate the forall! - -Similarly (#15428) - S :: forall k f. k -> f k -and we are finding the kind of - S * (* ->) Int Bool -We have - S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] - :: * -> * -> * -So again we must instantiate. - -The same thing happens in ToIface.toIfaceAppArgsX. - - ---------------------------------------------------------------------- - TyConApp - ~~~~~~~~ --} - --- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to --- its arguments. Applies its arguments to the constructor from left to right. -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon - , [_rep1,_rep2,ty1,ty2] <- tys - = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 } - -- The FunTyCon (->) is always a visible one - - | otherwise - = TyConApp tycon tys - --- splitTyConApp "looks through" synonyms, because they don't --- mean a distinct type, but all other type-constructor applications --- including functions are returned as Just .. - --- | Retrieve the tycon heading this type, if there is one. Does /not/ --- look through synonyms. -tyConAppTyConPicky_maybe :: Type -> Maybe TyCon -tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc -tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon -tyConAppTyConPicky_maybe _ = Nothing - - --- | The same as @fst . splitTyConApp@ -tyConAppTyCon_maybe :: Type -> Maybe TyCon -tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' -tyConAppTyCon_maybe (TyConApp tc _) = Just tc -tyConAppTyCon_maybe (FunTy {}) = Just funTyCon -tyConAppTyCon_maybe _ = Nothing - -tyConAppTyCon :: Type -> TyCon -tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) - --- | The same as @snd . splitTyConApp@ -tyConAppArgs_maybe :: Type -> Maybe [Type] -tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' -tyConAppArgs_maybe (TyConApp _ tys) = Just tys -tyConAppArgs_maybe (FunTy _ arg res) - | Just rep1 <- getRuntimeRep_maybe arg - , Just rep2 <- getRuntimeRep_maybe res - = Just [rep1, rep2, arg, res] -tyConAppArgs_maybe _ = Nothing - -tyConAppArgs :: Type -> [Type] -tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) - -tyConAppArgN :: Int -> Type -> Type --- Executing Nth -tyConAppArgN n ty - = case tyConAppArgs_maybe ty of - Just tys -> ASSERT2( tys `lengthExceeds` n, ppr n <+> ppr tys ) tys `getNth` n - Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor. Panics if that is not possible. --- See also 'splitTyConApp_maybe' -splitTyConApp :: Type -> (TyCon, [Type]) -splitTyConApp ty = case splitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' -splitTyConApp_maybe ty = repSplitTyConApp_maybe ty - --- | Split a type constructor application into its type constructor and --- applied types. Note that this may fail in the case of a 'FunTy' with an --- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind --- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your --- type before using this function. --- --- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. -tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) --- Defined here to avoid module loops between Unify and TcType. -tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' -tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty - -------------------- -repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) --- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This --- assumes the synonyms have already been dealt with. --- --- Moreover, for a FunTy, it only succeeds if the argument types --- have enough info to extract the runtime-rep arguments that --- the funTyCon requires. This will usually be true; --- but may be temporarily false during canonicalization: --- see Note [FunTy and decomposing tycon applications] in TcCanonical --- -repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (FunTy _ arg res) - | Just arg_rep <- getRuntimeRep_maybe arg - , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [arg_rep, res_rep, arg, res]) -repSplitTyConApp_maybe _ = Nothing - -------------------- --- | Attempts to tease a list type apart and gives the type of the elements if --- successful (looks through type synonyms) -splitListTyConApp_maybe :: Type -> Maybe Type -splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of - Just (tc,[e]) | tc == listTyCon -> Just e - _other -> Nothing - -nextRole :: Type -> Role -nextRole ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , let num_tys = length tys - , num_tys < tyConArity tc - = tyConRoles tc `getNth` num_tys - - | otherwise - = Nominal - -newTyConInstRhs :: TyCon -> [Type] -> Type --- ^ Unwrap one 'layer' of newtype on a type constructor and its --- arguments, using an eta-reduced version of the @newtype@ if possible. --- This requires tys to have at least @newTyConInstArity tycon@ elements. -newTyConInstRhs tycon tys - = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) - applyTysX tvs rhs tys - where - (tvs, rhs) = newTyConEtadRhs tycon - -{- ---------------------------------------------------------------------- - CastTy - ~~~~~~ -A casted type has its *kind* casted into something new. --} - -splitCastTy_maybe :: Type -> Maybe (Type, Coercion) -splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' -splitCastTy_maybe (CastTy ty co) = Just (ty, co) -splitCastTy_maybe _ = Nothing - --- | Make a 'CastTy'. The Coercion must be nominal. Checks the --- Coercion for reflexivity, dropping it if it's reflexive. --- See Note [Respecting definitional equality] in TyCoRep -mkCastTy :: Type -> Coercion -> Type -mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note --- NB: Do the slow check here. This is important to keep the splitXXX --- functions working properly. Otherwise, we may end up with something --- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) --- fails under splitFunTy_maybe. This happened with the cheaper check --- in test dependent/should_compile/dynamic-paper. - -mkCastTy (CastTy ty co1) co2 - -- (EQ3) from the Note - = mkCastTy ty (co1 `mkTransCo` co2) - -- call mkCastTy again for the reflexivity check - -mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co - -- (EQ4) from the Note - | isTyVar tv - , let fvs = tyCoVarsOfCo co - = -- have to make sure that pushing the co in doesn't capture the bound var! - if tv `elemVarSet` fvs - then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) - (subst, tv') = substVarBndr empty_subst tv - in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) - else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) - -mkCastTy ty co = CastTy ty co - -tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] --- Return the tyConBinders in TyCoBinder form -tyConBindersTyCoBinders = map to_tyb - where - to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) - to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv) - --- | Drop the cast on a type, if any. If there is no --- cast, just return the original type. This is rarely what --- you want. The CastTy data constructor (in TyCoRep) has the --- invariant that another CastTy is not inside. See the --- data constructor for a full description of this invariant. --- Since CastTy cannot be nested, the result of discardCast --- cannot be a CastTy. -discardCast :: Type -> Type -discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty - where - isCastTy CastTy{} = True - isCastTy _ = False -discardCast ty = ty - - -{- --------------------------------------------------------------------- - CoercionTy - ~~~~~~~~~~ -CoercionTy allows us to inject coercions into types. A CoercionTy -should appear only in the right-hand side of an application. --} - -mkCoercionTy :: Coercion -> Type -mkCoercionTy = CoercionTy - -isCoercionTy :: Type -> Bool -isCoercionTy (CoercionTy _) = True -isCoercionTy _ = False - -isCoercionTy_maybe :: Type -> Maybe Coercion -isCoercionTy_maybe (CoercionTy co) = Just co -isCoercionTy_maybe _ = Nothing - -stripCoercionTy :: Type -> Coercion -stripCoercionTy (CoercionTy co) = co -stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) - -{- ---------------------------------------------------------------------- - SynTy - ~~~~~ - -Notes on type synonyms -~~~~~~~~~~~~~~~~~~~~~~ -The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try -to return type synonyms wherever possible. Thus - - type Foo a = a -> a - -we want - splitFunTys (a -> Foo a) = ([a], Foo a) -not ([a], a -> a) - -The reason is that we then get better (shorter) type signatures in -interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. - - ---------------------------------------------------------------------- - ForAllTy - ~~~~~~~~ --} - --- | Make a dependent forall over an 'Inferred' variable -mkTyCoInvForAllTy :: TyCoVar -> Type -> Type -mkTyCoInvForAllTy tv ty - | isCoVar tv - , not (tv `elemVarSet` tyCoVarsOfType ty) - = mkVisFunTy (varType tv) ty - | otherwise - = ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar -mkInvForAllTy :: TyVar -> Type -> Type -mkInvForAllTy tv ty = ASSERT( isTyVar tv ) - ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Inferred', a common case -mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type -mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs - --- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar -mkInvForAllTys :: [TyVar] -> Type -> Type -mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs - --- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', --- a common case -mkSpecForAllTy :: TyVar -> Type -> Type -mkSpecForAllTy tv ty = ASSERT( isTyVar tv ) - -- covar is always Inferred, so input should be tyvar - ForAllTy (Bndr tv Specified) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Specified', a common case -mkSpecForAllTys :: [TyVar] -> Type -> Type -mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs - --- | Like mkForAllTys, but assumes all variables are dependent and visible -mkVisForAllTys :: [TyVar] -> Type -> Type -mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) - -- covar is always Inferred, so all inputs should be tyvar - mkForAllTys [ Bndr tv Required | tv <- tvs ] - -mkLamType :: Var -> Type -> Type --- ^ Makes a @(->)@ type or an implicit forall type, depending --- on whether it is given a type variable or a term variable. --- This is used, for example, when producing the type of a lambda. --- Always uses Inferred binders. -mkLamTypes :: [Var] -> Type -> Type --- ^ 'mkLamType' for multiple type or value arguments - -mkLamType v body_ty - | isTyVar v - = ForAllTy (Bndr v Inferred) body_ty - - | isCoVar v - , v `elemVarSet` tyCoVarsOfType body_ty - = ForAllTy (Bndr v Required) body_ty - - | isPredTy arg_ty -- See Note [mkLamType: dictionary arguments] - = mkInvisFunTy arg_ty body_ty - - | otherwise - = mkVisFunTy arg_ty body_ty - where - arg_ty = varType v - -mkLamTypes vs ty = foldr mkLamType ty vs - -{- Note [mkLamType: dictionary arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have (\ (d :: Ord a). blah), we want to give it type - (Ord a => blah_ty) -with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. - -Why? After all, we are in Core, where (=>) and (->) behave the same. -Yes, but the /specialiser/ does treat dictionary arguments specially. -Suppose we do w/w on 'foo' in module A, thus (#11272, #6056) - foo :: Ord a => Int -> blah - foo a d x = case x of I# x' -> $wfoo @a d x' - - $wfoo :: Ord a => Int# -> blah - -Now in module B we see (foo @Int dOrdInt). The specialiser will -specialise this to $sfoo, where - $sfoo :: Int -> blah - $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' - -Now we /must/ also specialise $wfoo! But it wasn't user-written, -and has a type built with mkLamTypes. - -Conclusion: the easiest thing is to make mkLamType build - (c => ty) -when the argument is a predicate type. See TyCoRep -Note [Types for coercions, predicates, and evidence] --} - --- | Given a list of type-level vars and the free vars of a result kind, --- makes TyCoBinders, preferring anonymous binders --- if the variable is, in fact, not dependent. --- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) --- We want (k:*) Named, (b:k) Anon, (c:k) Anon --- --- All non-coercion binders are /visible/. -mkTyConBindersPreferAnon :: [TyVar] -- ^ binders - -> TyCoVarSet -- ^ free variables of result - -> [TyConBinder] -mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) - fst (go vars) - where - go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars - go [] = ([], inner_tkvs) - go (v:vs) | v `elemVarSet` fvs - = ( Bndr v (NamedTCB Required) : binders - , fvs `delVarSet` v `unionVarSet` kind_vars ) - | otherwise - = ( Bndr v (AnonTCB VisArg) : binders - , fvs `unionVarSet` kind_vars ) - where - (binders, fvs) = go vs - kind_vars = tyCoVarsOfType $ tyVarKind v - --- | Take a ForAllTy apart, returning the list of tycovars and the result type. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitForAllTys :: Type -> ([TyCoVar], Type) -splitForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Like 'splitForAllTys', but only splits a 'ForAllTy' if --- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility --- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided --- as an argument to this function. -splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type) -splitForAllTysSameVis supplied_argf ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (Bndr tv argf) ty) tvs - | argf `sameVis` supplied_argf = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Like splitForAllTys, but split only for tyvars. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitTyVarForAllTys :: Type -> ([TyVar], Type) -splitTyVarForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Checks whether this is a proper forall (with a named binder) -isForAllTy :: Type -> Bool -isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' -isForAllTy (ForAllTy {}) = True -isForAllTy _ = False - --- | Like `isForAllTy`, but returns True only if it is a tyvar binder -isForAllTy_ty :: Type -> Bool -isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' -isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True -isForAllTy_ty _ = False - --- | Like `isForAllTy`, but returns True only if it is a covar binder -isForAllTy_co :: Type -> Bool -isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' -isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True -isForAllTy_co _ = False - --- | Is this a function or forall? -isPiTy :: Type -> Bool -isPiTy ty | Just ty' <- coreView ty = isPiTy ty' -isPiTy (ForAllTy {}) = True -isPiTy (FunTy {}) = True -isPiTy _ = False - --- | Is this a function? -isFunTy :: Type -> Bool -isFunTy ty | Just ty' <- coreView ty = isFunTy ty' -isFunTy (FunTy {}) = True -isFunTy _ = False - --- | Take a forall type apart, or panics if that is not possible. -splitForAllTy :: Type -> (TyCoVar, Type) -splitForAllTy ty - | Just answer <- splitForAllTy_maybe ty = answer - | otherwise = pprPanic "splitForAllTy" (ppr ty) - --- | Drops all ForAllTys -dropForAlls :: Type -> Type -dropForAlls ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy _ res) = go res - go res = res - --- | Attempts to take a forall type apart, but only if it's a proper forall, --- with a named binder -splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) - go _ = Nothing - --- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. -splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_ty_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) - go _ = Nothing - --- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. -splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_co_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) - go _ = Nothing - --- | Attempts to take a forall type apart; works with proper foralls and --- functions -splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) -splitPiTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy bndr ty) = Just (Named bndr, ty) - go (FunTy { ft_af = af, ft_arg = arg, ft_res = res}) - = Just (Anon af arg, res) - go _ = Nothing - --- | Takes a forall type apart, or panics -splitPiTy :: Type -> (TyCoBinder, Type) -splitPiTy ty - | Just answer <- splitPiTy_maybe ty = answer - | otherwise = pprPanic "splitPiTy" (ppr ty) - --- | Split off all TyCoBinders to a type, splitting both proper foralls --- and functions -splitPiTys :: Type -> ([TyCoBinder], Type) -splitPiTys ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (Named b : bs) - split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs - = split res res (Anon af arg : bs) - split orig_ty _ bs = (reverse bs, orig_ty) - --- | Like 'splitPiTys' but split off only /named/ binders --- and returns TyCoVarBinders rather than TyCoBinders -splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) -splitForAllVarBndrs ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (b:bs) - split orig_ty _ bs = (reverse bs, orig_ty) -{-# INLINE splitForAllVarBndrs #-} - -invisibleTyBndrCount :: Type -> Int --- Returns the number of leading invisible forall'd binders in the type --- Includes invisible predicate arguments; e.g. for --- e.g. forall {k}. (k ~ *) => k -> k --- returns 2 not 1 -invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) - --- Like splitPiTys, but returns only *invisible* binders, including constraints --- Stops at the first visible binder -splitPiTysInvisible :: Type -> ([TyCoBinder], Type) -splitPiTysInvisible ty = split ty ty [] - where - split orig_ty ty bs - | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs - | Bndr _ vis <- b - , isInvisibleArgFlag vis = split res res (Named b : bs) - split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res }) bs - = split res res (Anon InvisArg arg : bs) - split orig_ty _ bs = (reverse bs, orig_ty) - -splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) --- Same as splitPiTysInvisible, but stop when --- - you have found 'n' TyCoBinders, --- - or you run out of invisible binders -splitPiTysInvisibleN n ty = split n ty ty [] - where - split n orig_ty ty bs - | n == 0 = (reverse bs, orig_ty) - | Just ty' <- coreView ty = split n orig_ty ty' bs - | ForAllTy b res <- ty - , Bndr _ vis <- b - , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) - | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty - = split (n-1) res res (Anon InvisArg arg : bs) - | otherwise = (reverse bs, orig_ty) - --- | Given a 'TyCon' and a list of argument types, filter out any invisible --- (i.e., 'Inferred' or 'Specified') arguments. -filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] -filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys - --- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' --- arguments. -filterOutInferredTypes :: TyCon -> [Type] -> [Type] -filterOutInferredTypes tc tys = - filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys - --- | Given a 'TyCon' and a list of argument types, partition the arguments --- into: --- --- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and --- --- 2. 'Required' (i.e., visible) arguments -partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) -partitionInvisibleTypes tc tys = - partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys - --- | Given a list of things paired with their visibilities, partition the --- things into (invisible things, visible things). -partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) -partitionInvisibles = partitionWith pick_invis - where - pick_invis :: (a, ArgFlag) -> Either a a - pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing - | otherwise = Right thing - --- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- Wrinkle: consider the following scenario: --- --- > T :: forall k. k -> k --- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] --- --- After substituting, we get --- --- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n --- --- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, --- and @Q@ is visible. -tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] -tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) - --- | Given a 'Type' and a list of argument types to which the 'Type' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- Most of the time, the arguments will be 'Required', but not always. Consider --- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is --- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely --- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, --- since @f Type Bool@ would be represented in Core using 'AppTy's. --- (See also #15792). -appTyArgFlags :: Type -> [Type] -> [ArgFlag] -appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) - --- | Given a function kind and a list of argument types (where each argument's --- kind aligns with the corresponding position in the argument kind), determine --- each argument's visibility ('Inferred', 'Specified', or 'Required'). -fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] -fun_kind_arg_flags = go emptyTCvSubst - where - go subst ki arg_tys - | Just ki' <- coreView ki = go subst ki' arg_tys - go _ _ [] = [] - go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) - = argf : go subst' res_ki arg_tys - where - subst' = extendTvSubst subst tv arg_ty - go subst (TyVarTy tv) arg_tys - | Just ki <- lookupTyVar subst tv = go subst ki arg_tys - -- This FunTy case is important to handle kinds with nested foralls, such - -- as this kind (inspired by #16518): - -- - -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type - -- - -- Here, we want to get the following ArgFlags: - -- - -- [Inferred, Specified, Required, Required, Specified, Required] - -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type - go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) - = argf : go subst res_ki arg_tys - where - argf = case af of - VisArg -> Required - InvisArg -> Inferred - go _ _ arg_tys = map (const Required) arg_tys - -- something is ill-kinded. But this can happen - -- when printing errors. Assume everything is Required. - --- @isTauTy@ tests if a type has no foralls -isTauTy :: Type -> Bool -isTauTy ty | Just ty' <- coreView ty = isTauTy ty' -isTauTy (TyVarTy _) = True -isTauTy (LitTy {}) = True -isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy _ a b) = isTauTy a && isTauTy b -isTauTy (ForAllTy {}) = False -isTauTy (CastTy ty _) = isTauTy ty -isTauTy (CoercionTy _) = False -- Not sure about this - -{- -%************************************************************************ -%* * - TyCoBinders -%* * -%************************************************************************ --} - --- | Make an anonymous binder -mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder -mkAnonBinder = Anon - --- | Does this binder bind a variable that is /not/ erased? Returns --- 'True' for anonymous binders. -isAnonTyCoBinder :: TyCoBinder -> Bool -isAnonTyCoBinder (Named {}) = False -isAnonTyCoBinder (Anon {}) = True - -tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar -tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv -tyCoBinderVar_maybe _ = Nothing - -tyCoBinderType :: TyCoBinder -> Type -tyCoBinderType (Named tvb) = binderType tvb -tyCoBinderType (Anon _ ty) = ty - -tyBinderType :: TyBinder -> Type -tyBinderType (Named (Bndr tv _)) - = ASSERT( isTyVar tv ) - tyVarKind tv -tyBinderType (Anon _ ty) = ty - --- | Extract a relevant type, if there is one. -binderRelevantType_maybe :: TyCoBinder -> Maybe Type -binderRelevantType_maybe (Named {}) = Nothing -binderRelevantType_maybe (Anon _ ty) = Just ty - -------------- Closing over kinds ----------------- - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a non-deterministic set. -closeOverKinds :: TyVarSet -> TyVarSet -closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet - -- It's OK to use nonDetEltsUniqSet here because we immediately forget - -- about the ordering by returning a set. - --- | Given a list of tyvars returns a deterministic FV computation that --- returns the given tyvars with the kind variables free in the kinds of the --- given tyvars. -closeOverKindsFV :: [TyVar] -> FV -closeOverKindsFV tvs = - mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministically ordered list. -closeOverKindsList :: [TyVar] -> [TyVar] -closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministic set. -closeOverKindsDSet :: DTyVarSet -> DTyVarSet -closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems - -{- -************************************************************************ -* * -\subsection{Type families} -* * -************************************************************************ --} - -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- ^ Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance tycon is :RTL, so: --- --- > mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys ) - zipTvSubst tvs tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys - --- | Get the type on the LHS of a coercion induced by a type/data --- family instance. -coAxNthLHS :: CoAxiom br -> Int -> Type -coAxNthLHS ax ind = - mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) - -isFamFreeTy :: Type -> Bool -isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' -isFamFreeTy (TyVarTy _) = True -isFamFreeTy (LitTy {}) = True -isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc -isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (FunTy _ a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty -isFamFreeTy (CastTy ty _) = isFamFreeTy ty -isFamFreeTy (CoercionTy _) = False -- Not sure about this - --- | Does this type classify a core (unlifted) Coercion? --- At either role nominal or representational --- (t1 ~# t2) or (t1 ~R# t2) --- See Note [Types for coercions, predicates, and evidence] in TyCoRep -isCoVarType :: Type -> Bool - -- ToDo: should we check saturation? -isCoVarType ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey - | otherwise - = False - - -{- -************************************************************************ -* * -\subsection{Liftedness} -* * -************************************************************************ --} - --- | Returns Just True if this type is surely lifted, Just False --- if it is surely unlifted, Nothing if we can't be sure (i.e., it is --- levity polymorphic), and panics if the kind does not have the shape --- TYPE r. -isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool -isLiftedType_maybe ty = go (getRuntimeRep ty) - where - go rr | Just rr' <- coreView rr = go rr' - | isLiftedRuntimeRep rr = Just True - | TyConApp {} <- rr = Just False -- Everything else is unlifted - | otherwise = Nothing -- levity polymorphic - --- | See "Type#type_classification" for what an unlifted type is. --- Panics on levity polymorphic types; See 'mightBeUnliftedType' for --- a more approximate predicate that behaves better in the presence of --- levity polymorphism. -isUnliftedType :: HasDebugCallStack => Type -> Bool - -- isUnliftedType returns True for forall'd unlifted types: - -- x :: forall a. Int# - -- I found bindings like these were getting floated to the top level. - -- They are pretty bogus types, mind you. It would be better never to - -- construct them -isUnliftedType ty - = not (isLiftedType_maybe ty `orElse` - pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) - --- | Returns: --- --- * 'False' if the type is /guaranteed/ lifted or --- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case) -mightBeUnliftedType :: Type -> Bool -mightBeUnliftedType ty - = case isLiftedType_maybe ty of - Just is_lifted -> not is_lifted - Nothing -> True - --- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) -isRuntimeRepKindedTy :: Type -> Bool -isRuntimeRepKindedTy = isRuntimeRepTy . typeKind - --- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. --- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: --- --- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep --- , String, Int# ] == [String, Int#] --- -dropRuntimeRepArgs :: [Type] -> [Type] -dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not --- possible. -getRuntimeRep_maybe :: HasDebugCallStack - => Type -> Maybe Type -getRuntimeRep_maybe = kindRep_maybe . typeKind - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. -getRuntimeRep :: HasDebugCallStack => Type -> Type -getRuntimeRep ty - = case getRuntimeRep_maybe ty of - Just r -> r - Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - -isUnboxedTupleType :: Type -> Bool -isUnboxedTupleType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey - -- NB: Do not use typePrimRep, as that can't tell the difference between - -- unboxed tuples and unboxed sums - - -isUnboxedSumType :: Type -> Bool -isUnboxedSumType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey - --- | See "Type#type_classification" for what an algebraic type is. --- Should only be applied to /types/, as opposed to e.g. partially --- saturated type constructors -isAlgType :: Type -> Bool -isAlgType ty - = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isAlgTyCon tc - _other -> False - --- | Check whether a type is a data family type -isDataFamilyAppType :: Type -> Bool -isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of - Just tc -> isDataFamilyTyCon tc - _ -> False - --- | Computes whether an argument (or let right hand side) should --- be computed strictly or lazily, based only on its type. --- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. -isStrictType :: HasDebugCallStack => Type -> Bool -isStrictType = isUnliftedType - -isPrimitiveType :: Type -> Bool --- ^ Returns true of types that are opaque to Haskell. -isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isPrimTyCon tc - _ -> False - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Determine whether a type could be the type of a join point of given total --- arity, according to the polymorphism rule. A join point cannot be polymorphic --- in its return type, since given --- join j @a @b x y z = e1 in e2, --- the types of e1 and e2 must be the same, and a and b are not in scope for e2. --- (See Note [The polymorphism rule of join points] in CoreSyn.) Returns False --- also if the type simply doesn't have enough arguments. --- --- Note that we need to know how many arguments (type *and* value) the putative --- join point takes; for instance, if --- j :: forall a. a -> Int --- then j could be a binary join point returning an Int, but it could *not* be a --- unary join point returning a -> Int. --- --- TODO: See Note [Excess polymorphism and join points] -isValidJoinPointType :: JoinArity -> Type -> Bool -isValidJoinPointType arity ty - = valid_under emptyVarSet arity ty - where - valid_under tvs arity ty - | arity == 0 - = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty) - | Just (t, ty') <- splitForAllTy_maybe ty - = valid_under (tvs `extendVarSet` t) (arity-1) ty' - | Just (_, res_ty) <- splitFunTy_maybe ty - = valid_under tvs (arity-1) res_ty - | otherwise - = False - -{- Note [Excess polymorphism and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In principle, if a function would be a join point except that it fails -the polymorphism rule (see Note [The polymorphism rule of join points] in -CoreSyn), it can still be made a join point with some effort. This is because -all tail calls must return the same type (they return to the same context!), and -thus if the return type depends on an argument, that argument must always be the -same. - -For instance, consider: - - let f :: forall a. a -> Char -> [a] - f @a x c = ... f @a y 'a' ... - in ... f @Int 1 'b' ... f @Int 2 'c' ... - -(where the calls are tail calls). `f` fails the polymorphism rule because its -return type is [a], where [a] is bound. But since the type argument is always -'Int', we can rewrite it as: - - let f' :: Int -> Char -> [Int] - f' x c = ... f' y 'a' ... - in ... f' 1 'b' ... f 2 'c' ... - -and now we can make f' a join point: - - join f' :: Int -> Char -> [Int] - f' x c = ... jump f' y 'a' ... - in ... jump f' 1 'b' ... jump f' 2 'c' ... - -It's not clear that this comes up often, however. TODO: Measure how often and -add this analysis if necessary. See #14620. - - -************************************************************************ -* * -\subsection{Sequencing on types} -* * -************************************************************************ --} - -seqType :: Type -> () -seqType (LitTy n) = n `seq` () -seqType (TyVarTy tv) = tv `seq` () -seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (FunTy _ t1 t2) = seqType t1 `seq` seqType t2 -seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty -seqType (CastTy ty co) = seqType ty `seq` seqCo co -seqType (CoercionTy co) = seqCo co - -seqTypes :: [Type] -> () -seqTypes [] = () -seqTypes (ty:tys) = seqType ty `seq` seqTypes tys - -{- -************************************************************************ -* * - Comparison for types - (We don't use instances so that we know where it happens) -* * -************************************************************************ - -Note [Equality on AppTys] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In our cast-ignoring equality, we want to say that the following two -are equal: - - (Maybe |> co) (Int |> co') ~? Maybe Int - -But the left is an AppTy while the right is a TyConApp. The solution is -to use repSplitAppTy_maybe to break up the TyConApp into its pieces and -then continue. Easy to do, but also easy to forget to do. - --} - -eqType :: Type -> Type -> Bool --- ^ Type equality on source types. Does not look through @newtypes@ or --- 'PredType's, but it does look through type synonyms. --- This first checks that the kinds of the types are equal and then --- checks whether the types are equal, ignoring casts and coercions. --- (The kind check is a recursive call, but since all kinds have type --- @Type@, there is no need to check the types of kinds.) --- See also Note [Non-trivial definitional equality] in TyCoRep. -eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 - -- It's OK to use nonDetCmpType here and eqType is deterministic, - -- nonDetCmpType does equality deterministically - --- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. -eqTypeX :: RnEnv2 -> Type -> Type -> Bool -eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 - -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, - -- nonDetCmpTypeX does equality deterministically - --- | Type equality on lists of types, looking through type synonyms --- but not newtypes. -eqTypes :: [Type] -> [Type] -> Bool -eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 - -- It's OK to use nonDetCmpType here and eqTypes is deterministic, - -- nonDetCmpTypes does equality deterministically - -eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 --- Check that the var lists are the same length --- and have matching kinds; if so, extend the RnEnv2 --- Returns Nothing if they don't match -eqVarBndrs env [] [] - = Just env -eqVarBndrs env (tv1:tvs1) (tv2:tvs2) - | eqTypeX env (varType tv1) (varType tv2) - = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 -eqVarBndrs _ _ _= Nothing - --- Now here comes the real worker - -{- -Note [nonDetCmpType nondeterminism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX -uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for -ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, -comparing type variables is nondeterministic, note the call to nonDetCmpVar in -nonDetCmpTypeX. -See Note [Unique Determinism] for more details. --} - -nonDetCmpType :: Type -> Type -> Ordering -nonDetCmpType t1 t2 - -- we know k1 and k2 have the same kind, because they both have kind *. - = nonDetCmpTypeX rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) - -nonDetCmpTypes :: [Type] -> [Type] -> Ordering -nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) - --- | An ordering relation between two 'Type's (known below as @t1 :: k1@ --- and @t2 :: k2@) -data TypeOrdering = TLT -- ^ @t1 < t2@ - | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, - -- therefore we can conclude @k1 ~ k2@ - | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so - -- they may differ in kind. - | TGT -- ^ @t1 > t2@ - deriving (Eq, Ord, Enum, Bounded) - -nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse - -- See Note [Non-trivial definitional equality] in TyCoRep -nonDetCmpTypeX env orig_t1 orig_t2 = - case go env orig_t1 orig_t2 of - -- If there are casts then we also need to do a comparison of the kinds of - -- the types being compared - TEQX -> toOrdering $ go env k1 k2 - ty_ordering -> toOrdering ty_ordering - where - k1 = typeKind orig_t1 - k2 = typeKind orig_t2 - - toOrdering :: TypeOrdering -> Ordering - toOrdering TLT = LT - toOrdering TEQ = EQ - toOrdering TEQX = EQ - toOrdering TGT = GT - - liftOrdering :: Ordering -> TypeOrdering - liftOrdering LT = TLT - liftOrdering EQ = TEQ - liftOrdering GT = TGT - - thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering - thenCmpTy TEQ rel = rel - thenCmpTy TEQX rel = hasCast rel - thenCmpTy rel _ = rel - - hasCast :: TypeOrdering -> TypeOrdering - hasCast TEQ = TEQX - hasCast rel = rel - - -- Returns both the resulting ordering relation between the two types - -- and whether either contains a cast. - go :: RnEnv2 -> Type -> Type -> TypeOrdering - go env t1 t2 - | Just t1' <- coreView t1 = go env t1' t2 - | Just t2' <- coreView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 - go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) - = go env (varType tv1) (varType tv2) - `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 - -- See Note [Equality on AppTys] - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- repSplitAppTy_maybe ty2 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- repSplitAppTy_maybe ty1 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (FunTy _ s1 t1) (FunTy _ s2 t2) - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 - go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) - go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 - go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 - - go _ (CoercionTy {}) (CoercionTy {}) = TEQ - - -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy - go _ ty1 ty2 - = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) - where get_rank :: Type -> Int - get_rank (CastTy {}) - = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) - get_rank (TyVarTy {}) = 0 - get_rank (CoercionTy {}) = 1 - get_rank (AppTy {}) = 3 - get_rank (LitTy {}) = 4 - get_rank (TyConApp {}) = 5 - get_rank (FunTy {}) = 6 - get_rank (ForAllTy {}) = 7 - - gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering - gos _ [] [] = TEQ - gos _ [] _ = TLT - gos _ _ [] = TGT - gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 - -------------- -nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering -nonDetCmpTypesX _ [] [] = EQ -nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 - `thenCmp` - nonDetCmpTypesX env tys1 tys2 -nonDetCmpTypesX _ [] _ = LT -nonDetCmpTypesX _ _ [] = GT - -------------- --- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as --- recognized by Kind.isConstraintKindCon) which is considered a synonym for --- 'Type' in Core. --- See Note [Kind Constraint and kind Type] in Kind. --- See Note [nonDetCmpType nondeterminism] -nonDetCmpTc :: TyCon -> TyCon -> Ordering -nonDetCmpTc tc1 tc2 - = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) - u1 `nonDetCmpUnique` u2 - where - u1 = tyConUnique tc1 - u2 = tyConUnique tc2 - -{- -************************************************************************ -* * - The kind of a type -* * -************************************************************************ - -Note [typeKind vs tcTypeKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have two functions to get the kind of a type - - * typeKind ignores the distinction between Constraint and * - * tcTypeKind respects the distinction between Constraint and * - -tcTypeKind is used by the type inference engine, for which Constraint -and * are different; after that we use typeKind. - -See also Note [coreView vs tcView] - -Note [Kinding rules for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. -We then have - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - ty : TYPE rep - `a` is not free in rep -(FORALL) ----------------------- - forall a. ty : TYPE rep - -In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - t1 : Constraint - t2 : TYPE rep - (PRED1) ---------------- - t1 => t2 : Type - - t1 : Constraint - t2 : Constraint - (PRED2) --------------------- - t1 => t2 : Constraint - - ty : TYPE rep - `a` is not free in rep -(FORALL1) ----------------------- - forall a. ty : TYPE rep - - ty : Constraint -(FORALL2) ------------------------- - forall a. ty : Constraint - -Note that: -* The only way we distinguish '->' from '=>' is by the fact - that the argument is a PredTy. Both are FunTys - -Note [Phantom type variables in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - type K (r :: RuntimeRep) = Type -- Note 'r' is unused - data T r :: K r -- T :: forall r -> K r - foo :: forall r. T r - -The body of the forall in foo's type has kind (K r), and -normally it would make no sense to have - forall r. (ty :: K r) -because the kind of the forall would escape the binding -of 'r'. But in this case it's fine because (K r) exapands -to Type, so we expliclity /permit/ the type - forall r. T r - -To accommodate such a type, in typeKind (forall a.ty) we use -occCheckExpand to expand any type synonyms in the kind of 'ty' -to eliminate 'a'. See kinding rule (FORALL) in -Note [Kinding rules for types] - -And in TcValidity.checkEscapingKind, we use also use -occCheckExpand, for the same reason. --} - ------------------------------ -typeKind :: HasDebugCallStack => Type -> Kind --- No need to expand synonyms -typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -typeKind (LitTy l) = typeLiteralKind l -typeKind (FunTy {}) = liftedTypeKind -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (CastTy _ty co) = pSnd $ coercionKind co -typeKind (CoercionTy co) = coercionType co - -typeKind (AppTy fun arg) - = go fun [arg] - where - -- Accumulate the type arugments, so we can call piResultTys, - -- rather than a succession of calls to piResultTy (which is - -- asymptotically costly as the number of arguments increases) - go (AppTy fun arg) args = go fun (arg:args) - go fun args = piResultTys (typeKind fun) args - -typeKind ty@(ForAllTy {}) - = case occCheckExpand tvs body_kind of - -- We must make sure tv does not occur in kind - -- As it is already out of scope! - -- See Note [Phantom type variables in kinds] - Just k' -> k' - Nothing -> pprPanic "typeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) - where - (tvs, body) = splitTyVarForAllTys ty - body_kind = typeKind body - ---------------------------------------------- --- Utilities to be used in Unify, which uses "tc" functions ---------------------------------------------- - -tcTypeKind :: HasDebugCallStack => Type -> Kind --- No need to expand synonyms -tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -tcTypeKind (LitTy l) = typeLiteralKind l -tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar -tcTypeKind (CastTy _ty co) = pSnd $ coercionKind co -tcTypeKind (CoercionTy co) = coercionType co - -tcTypeKind (FunTy { ft_af = af, ft_res = res }) - | InvisArg <- af - , tcIsConstraintKind (tcTypeKind res) - = constraintKind -- Eq a => Ord a :: Constraint - | otherwise -- Eq a => a -> a :: TYPE LiftedRep - = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) - -tcTypeKind (AppTy fun arg) - = go fun [arg] - where - -- Accumulate the type arugments, so we can call piResultTys, - -- rather than a succession of calls to piResultTy (which is - -- asymptotically costly as the number of arguments increases) - go (AppTy fun arg) args = go fun (arg:args) - go fun args = piResultTys (tcTypeKind fun) args - -tcTypeKind ty@(ForAllTy {}) - | tcIsConstraintKind body_kind - = constraintKind - - | otherwise - = case occCheckExpand tvs body_kind of - -- We must make sure tv does not occur in kind - -- As it is already out of scope! - -- See Note [Phantom type variables in kinds] - Just k' -> k' - Nothing -> pprPanic "tcTypeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) - where - (tvs, body) = splitTyVarForAllTys ty - body_kind = tcTypeKind body - - -isPredTy :: HasDebugCallStack => Type -> Bool --- See Note [Types for coercions, predicates, and evidence] in TyCoRep -isPredTy ty = tcIsConstraintKind (tcTypeKind ty) - --- tcIsConstraintKind stuff only makes sense in the typechecker --- After that Constraint = Type --- See Note [coreView vs tcView] --- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) -tcIsConstraintKind :: Kind -> Bool -tcIsConstraintKind ty - | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , isConstraintKindCon tc - = ASSERT2( null args, ppr ty ) True - - | otherwise - = False - --- | Is this kind equivalent to @*@? --- --- This considers 'Constraint' to be distinct from @*@. For a version that --- treats them as the same type, see 'isLiftedTypeKind'. -tcIsLiftedTypeKind :: Kind -> Bool -tcIsLiftedTypeKind ty - | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , tc `hasKey` tYPETyConKey - = isLiftedRuntimeRep arg - | otherwise - = False - --- | Is this kind equivalent to @TYPE r@ (for some unknown r)? --- --- This considers 'Constraint' to be distinct from @*@. -tcIsRuntimeTypeKind :: Kind -> Bool -tcIsRuntimeTypeKind ty - | Just (tc, _) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , tc `hasKey` tYPETyConKey - = True - | otherwise - = False - -tcReturnsConstraintKind :: Kind -> Bool --- True <=> the Kind ultimately returns a Constraint --- E.g. * -> Constraint --- forall k. k -> Constraint -tcReturnsConstraintKind kind - | Just kind' <- tcView kind = tcReturnsConstraintKind kind' -tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc -tcReturnsConstraintKind _ = False - --------------------------- -typeLiteralKind :: TyLit -> Kind -typeLiteralKind (NumTyLit {}) = typeNatKind -typeLiteralKind (StrTyLit {}) = typeSymbolKind - --- | Returns True if a type is levity polymorphic. Should be the same --- as (isKindLevPoly . typeKind) but much faster. --- Precondition: The type has kind (TYPE blah) -isTypeLevPoly :: Type -> Bool -isTypeLevPoly = go - where - go ty@(TyVarTy {}) = check_kind ty - go ty@(AppTy {}) = check_kind ty - go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False - | otherwise = check_kind ty - go (ForAllTy _ ty) = go ty - go (FunTy {}) = False - go (LitTy {}) = False - go ty@(CastTy {}) = check_kind ty - go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) - - check_kind = isKindLevPoly . typeKind - --- | Looking past all pi-types, is the end result potentially levity polymorphic? --- Example: True for (forall r (a :: TYPE r). String -> a) --- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) -resultIsLevPoly :: Type -> Bool -resultIsLevPoly = isTypeLevPoly . snd . splitPiTys - - -{- ********************************************************************** -* * - Occurs check expansion -%* * -%********************************************************************* -} - -{- Note [Occurs check expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid -of occurrences of tv outside type function arguments, if that is -possible; otherwise, it returns Nothing. - -For example, suppose we have - type F a b = [a] -Then - occCheckExpand b (F Int b) = Just [Int] -but - occCheckExpand a (F a Int) = Nothing - -We don't promise to do the absolute minimum amount of expanding -necessary, but we try not to do expansions we don't need to. We -prefer doing inner expansions first. For example, - type F a b = (a, Int, a, [a]) - type G b = Char -We have - occCheckExpand b (F (G b)) = Just (F Char) -even though we could also expand F to get rid of b. --} - -occCheckExpand :: [Var] -> Type -> Maybe Type --- See Note [Occurs check expansion] --- We may have needed to do some type synonym unfolding in order to --- get rid of the variable (or forall), so we also return the unfolded --- version of the type, which is guaranteed to be syntactically free --- of the given type variable. If the type is already syntactically --- free of the variable, then the same type is returned. -occCheckExpand vs_to_avoid ty - | null vs_to_avoid -- Efficient shortcut - = Just ty -- Can happen, eg. CoreUtils.mkSingleAltCase - - | otherwise - = go (mkVarSet vs_to_avoid, emptyVarEnv) ty - where - go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type - -- The VarSet is the set of variables we are trying to avoid - -- The VarEnv carries mappings necessary - -- because of kind expansion - go cxt@(as, env) (TyVarTy tv') - | tv' `elemVarSet` as = Nothing - | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') - | otherwise = do { tv'' <- go_var cxt tv' - ; return (mkTyVarTy tv'') } - - go _ ty@(LitTy {}) = return ty - go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (mkAppTy ty1' ty2') } - go cxt ty@(FunTy _ ty1 ty2) - = do { ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (ty { ft_arg = ty1', ft_res = ty2' }) } - go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) - = do { ki' <- go cxt (varType tv) - ; let tv' = setVarType tv ki' - env' = extendVarEnv env tv tv' - as' = as `delVarSet` tv - ; body' <- go (as', env') body_ty - ; return (ForAllTy (Bndr tv' vis) body') } - - -- For a type constructor application, first try expanding away the - -- offending variable from the arguments. If that doesn't work, next - -- see if the type constructor is a type synonym, and if so, expand - -- it and try again. - go cxt ty@(TyConApp tc tys) - = case mapM (go cxt) tys of - Just tys' -> return (mkTyConApp tc tys') - Nothing | Just ty' <- tcView ty -> go cxt ty' - | otherwise -> Nothing - -- Failing that, try to expand a synonym - - go cxt (CastTy ty co) = do { ty' <- go cxt ty - ; co' <- go_co cxt co - ; return (mkCastTy ty' co') } - go cxt (CoercionTy co) = do { co' <- go_co cxt co - ; return (mkCoercionTy co') } - - ------------------ - go_var cxt v = do { k' <- go cxt (varType v) - ; return (setVarType v k') } - -- Works for TyVar and CoVar - -- See Note [Occurrence checking: look inside kinds] - - ------------------ - go_mco _ MRefl = return MRefl - go_mco ctx (MCo co) = MCo <$> go_co ctx co - - ------------------ - go_co cxt (Refl ty) = do { ty' <- go cxt ty - ; return (mkNomReflCo ty') } - go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco - ; ty' <- go cxt ty - ; return (mkGReflCo r ty' mco') } - -- Note: Coercions do not contain type synonyms - go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args - ; return (mkTyConAppCo r tc args') } - go_co cxt (AppCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkAppCo co' arg') } - go_co cxt@(as, env) (ForAllCo tv kind_co body_co) - = do { kind_co' <- go_co cxt kind_co - ; let tv' = setVarType tv $ - pFst (coercionKind kind_co') - env' = extendVarEnv env tv tv' - as' = as `delVarSet` tv - ; body' <- go_co (as', env') body_co - ; return (ForAllCo tv' kind_co' body') } - go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; return (mkFunCo r co1' co2') } - go_co cxt@(as,env) (CoVarCo c) - | c `elemVarSet` as = Nothing - | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') - | otherwise = do { c' <- go_var cxt c - ; return (mkCoVarCo c') } - go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) - ; return (HoleCo (h { ch_co_var = c' })) } - go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args - ; return (mkAxiomInstCo ax ind args') } - go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p - ; ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (mkUnivCo p' r ty1' ty2') } - go_co cxt (SymCo co) = do { co' <- go_co cxt co - ; return (mkSymCo co') } - go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; return (mkTransCo co1' co2') } - go_co cxt (NthCo r n co) = do { co' <- go_co cxt co - ; return (mkNthCo r n co') } - go_co cxt (LRCo lr co) = do { co' <- go_co cxt co - ; return (mkLRCo lr co') } - go_co cxt (InstCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkInstCo co' arg') } - go_co cxt (KindCo co) = do { co' <- go_co cxt co - ; return (mkKindCo co') } - go_co cxt (SubCo co) = do { co' <- go_co cxt co - ; return (mkSubCo co') } - go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs - ; return (mkAxiomRuleCo ax cs') } - - ------------------ - go_prov _ UnsafeCoerceProv = return UnsafeCoerceProv - go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co - go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co - go_prov _ p@(PluginProv _) = return p - - -{- -%************************************************************************ -%* * - Miscellaneous functions -%* * -%************************************************************************ - --} --- | All type constructors occurring in the type; looking through type --- synonyms, but not newtypes. --- When it finds a Class, it returns the class TyCon. -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - = go ty - where - go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyUniqSet - go (LitTy {}) = emptyUniqSet - go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys - go (AppTy a b) = go a `unionUniqSets` go b - go (FunTy _ a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon - go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) - go (CastTy ty co) = go ty `unionUniqSets` go_co co - go (CoercionTy co) = go_co co - - go_co (Refl ty) = go ty - go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco - go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args - go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co - go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args - go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 - go_co (CoVarCo {}) = emptyUniqSet - go_co (HoleCo {}) = emptyUniqSet - go_co (SymCo co) = go_co co - go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (NthCo _ _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_cos cs - - go_mco MRefl = emptyUniqSet - go_mco (MCo co) = go_co co - - go_prov UnsafeCoerceProv = emptyUniqSet - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyUniqSet - -- this last case can happen from the tyConsOfType used from - -- checkTauTvUpdate - - go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys - go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos - - go_tc tc = unitUniqSet tc - go_ax ax = go_tc $ coAxiomTyCon ax - --- | Find the result 'Kind' of a type synonym, --- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, --- but they'd always return '*', so we never need to ask -synTyConResKind :: TyCon -> Kind -synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) - --- | Retrieve the free variables in this type, splitting them based --- on whether they are used visibly or invisibly. Invisible ones come --- first. -splitVisVarsOfType :: Type -> Pair TyCoVarSet -splitVisVarsOfType orig_ty = Pair invis_vars vis_vars - where - Pair invis_vars1 vis_vars = go orig_ty - invis_vars = invis_vars1 `minusVarSet` vis_vars - - go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) - go (AppTy t1 t2) = go t1 `mappend` go t2 - go (TyConApp tc tys) = go_tc tc tys - go (FunTy _ t1 t2) = go t1 `mappend` go t2 - go (ForAllTy (Bndr tv _) ty) - = ((`delVarSet` tv) <$> go ty) `mappend` - (invisible (tyCoVarsOfType $ varType tv)) - go (LitTy {}) = mempty - go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) - go (CoercionTy co) = invisible $ tyCoVarsOfCo co - - invisible vs = Pair vs emptyVarSet - - go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in - invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis - -splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet -splitVisVarsOfTypes = foldMap splitVisVarsOfType - -modifyJoinResTy :: Int -- Number of binders to skip - -> (Type -> Type) -- Function to apply to result type - -> Type -- Type of join point - -> Type -- New type --- INVARIANT: If any of the first n binders are foralls, those tyvars cannot --- appear in the original result type. See isValidJoinPointType. -modifyJoinResTy orig_ar f orig_ty - = go orig_ar orig_ty - where - go 0 ty = f ty - go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty - = mkPiTy arg_bndr (go (n-1) res_ty) - | otherwise - = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) - -setJoinResTy :: Int -- Number of binders to skip - -> Type -- New result type - -> Type -- Type of join point - -> Type -- New type --- INVARIANT: Same as for modifyJoinResTy -setJoinResTy ar new_res_ty ty - = modifyJoinResTy ar (const new_res_ty) ty - -{- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ - -Note [Kind Constraint and kind Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that - * They are displayed with double arrow: - f :: Ord a => a -> a - * They are implicitly instantiated at call sites; so the type inference - engine inserts an extra argument of type (Ord a) at every call site - to f. - -However, once type inference is over, there is *no* distinction between -Constraint and Type. Indeed we can have coercions between the two. Consider - class C a where - op :: a -> a -For this single-method class we may generate a newtype, which in turn -generates an axiom witnessing - C a ~ (a -> a) -so on the left we have Constraint, and on the right we have Type. -See #7451. - -Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except -during type inference. --} - -isConstraintKindCon :: TyCon -> Bool -isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey - --- | Tests whether the given kind (which should look like @TYPE x@) --- is something other than a constructor tree (that is, constructors at every node). --- E.g. True of TYPE k, TYPE (F Int) --- False of TYPE 'LiftedRep -isKindLevPoly :: Kind -> Bool -isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) - -- the isLiftedTypeKind check is necessary b/c of Constraint - go k - where - go ty | Just ty' <- coreView ty = go ty' - go TyVarTy{} = True - go AppTy{} = True -- it can't be a TyConApp - go (TyConApp tc tys) = isFamilyTyCon tc || any go tys - go ForAllTy{} = True - go (FunTy _ t1 t2) = go t1 || go t2 - go LitTy{} = False - go CastTy{} = True - go CoercionTy{} = True - - _is_type = classifiesTypeWithValues k - ------------------------------------------ --- Subkinding --- The tc variants are used during type-checking, where ConstraintKind --- is distinct from all other kinds --- After type-checking (in core), Constraint and liftedTypeKind are --- indistinguishable - --- | Does this classify a type allowed to have values? Responds True to things --- like *, #, TYPE Lifted, TYPE v, Constraint. -classifiesTypeWithValues :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind -classifiesTypeWithValues k = isJust (kindRep_maybe k) - -{- -%************************************************************************ -%* * - Pretty-printing -%* * -%************************************************************************ - -Most pretty-printing is either in TyCoRep or IfaceType. - --} - --- | Does a 'TyCon' (that is applied to some number of arguments) need to be --- ascribed with an explicit kind signature to resolve ambiguity if rendered as --- a source-syntax type? --- (See @Note [When does a tycon application need an explicit kind signature?]@ --- for a full explanation of what this function checks for.) -tyConAppNeedsKindSig - :: Bool -- ^ Should specified binders count towards injective positions in - -- the kind of the TyCon? (If you're using visible kind - -- applications, then you want True here. - -> TyCon - -> Int -- ^ The number of args the 'TyCon' is applied to. - -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the - -- number of arguments) -tyConAppNeedsKindSig spec_inj_pos tc n_args - | LT <- listLengthCmp tc_binders n_args - = False - | otherwise - = let (dropped_binders, remaining_binders) - = splitAt n_args tc_binders - result_kind = mkTyConKind remaining_binders tc_res_kind - result_vars = tyCoVarsOfType result_kind - dropped_vars = fvVarSet $ - mapUnionFV injective_vars_of_binder dropped_binders - - in not (subVarSet result_vars dropped_vars) - where - tc_binders = tyConBinders tc - tc_res_kind = tyConResKind tc - - -- Returns the variables that would be fixed by knowing a TyConBinder. See - -- Note [When does a tycon application need an explicit kind signature?] - -- for a more detailed explanation of what this function does. - injective_vars_of_binder :: TyConBinder -> FV - injective_vars_of_binder (Bndr tv vis) = - case vis of - AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice - (varType tv) - NamedTCB argf | source_of_injectivity argf - -> unitFV tv `unionFV` - injectiveVarsOfType False (varType tv) - _ -> emptyFV - - source_of_injectivity Required = True - source_of_injectivity Specified = spec_inj_pos - source_of_injectivity Inferred = False - -{- -Note [When does a tycon application need an explicit kind signature?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a couple of places in GHC where we convert Core Types into forms that -more closely resemble user-written syntax. These include: - -1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) -2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock) - -This conversion presents a challenge: how do we ensure that the resulting type -has enough kind information so as not to be ambiguous? To better motivate this -question, consider the following Core type: - - -- Foo :: Type -> Type - type Foo = Proxy Type - -There is nothing ambiguous about the RHS of Foo in Core. But if we were to, -say, reify it into a TH Type, then it's tempting to just drop the invisible -Type argument and simply return `Proxy`. But now we've lost crucial kind -information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` -or `Proxy Int` or something else! We've inadvertently introduced ambiguity. - -Unlike in other situations in GHC, we can't just turn on --fprint-explicit-kinds, as we need to produce something which has the same -structure as a source-syntax type. Moreover, we can't rely on visible kind -application, since the first kind argument to Proxy is inferred, not specified. -Our solution is to annotate certain tycons with their kinds whenever they -appear in applied form in order to resolve the ambiguity. For instance, we -would reify the RHS of Foo like so: - - type Foo = (Proxy :: Type -> Type) - -We need to devise an algorithm that determines precisely which tycons need -these explicit kind signatures. We certainly don't want to annotate _every_ -tycon with a kind signature, or else we might end up with horribly bloated -types like the following: - - (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) - -We only want to annotate tycons that absolutely require kind signatures in -order to resolve some sort of ambiguity, and nothing more. - -Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type -require a kind signature? It might require it when we need to fill in any of -T's omitted arguments. By "omitted argument", we mean one that is dropped when -reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and -specified arguments (e.g., TH reification in TcSplice), and sometimes the -omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType, -which reifies specified arguments through visible kind application). -Regardless, the key idea is that _some_ arguments are going to be omitted after -reification, and the only mechanism we have at our disposal for filling them in -is through explicit kind signatures. - -What do we mean by "fill in"? Let's consider this small example: - - T :: forall {k}. Type -> (k -> Type) -> k - -Moreover, we have this application of T: - - T @{j} Int aty - -When we reify this type, we omit the inferred argument @{j}. Is it fixed by the -other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then -we'll generate an equality constraint (kappa -> Type) and, assuming we can -solve it, that will fix `kappa`. (Here, `kappa` is the unification variable -that we instantiate `k` with.) - -Therefore, for any application of a tycon T to some arguments, the Question We -Must Answer is: - -* Given the first n arguments of T, do the kinds of the non-omitted arguments - fill in the omitted arguments? - -(This is still a bit hand-wavey, but we'll refine this question incrementally -as we explain more of the machinery underlying this process.) - -Answering this question is precisely the role that the `injectiveVarsOfType` -and `injective_vars_of_binder` functions exist to serve. If an omitted argument -`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing -`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a -bit.) - -More formally, if -`a` is in `injectiveVarsOfType ty` -and S1(ty) ~ S2(ty), -then S1(a) ~ S2(a), -where S1 and S2 are arbitrary substitutions. - -For example, is `F` is a non-injective type family, then - - injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} - -Now that we know what this function does, here is a second attempt at the -Question We Must Answer: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. Do the injective - variables of these binders fill in the remainder of T's kind? - -Alright, we're getting closer. Next, we need to clarify what the injective -variables of a tycon binder are. This the role that the -`injective_vars_of_binder` function serves. Here is what this function does for -each form of tycon binder: - -* Anonymous binders are injective positions. For example, in the promoted data - constructor '(:): - - '(:) :: forall a. a -> [a] -> [a] - - The second and third tyvar binders (of kinds `a` and `[a]`) are both - anonymous, so if we had '(:) 'True '[], then the kinds of 'True and - '[] would contribute to the kind of '(:) 'True '[]. Therefore, - injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. - (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) -* Named binders: - - Inferred binders are never injective positions. For example, in this data - type: - - data Proxy a - Proxy :: forall {k}. k -> Type - - If we had Proxy 'True, then the kind of 'True would not contribute to the - kind of Proxy 'True. Therefore, - injective_vars_of_binder(forall {k}. ...) = {}. - - Required binders are injective positions. For example, in this data type: - - data Wurble k (a :: k) :: k - Wurble :: forall k -> k -> k - - The first tyvar binder (of kind `forall k`) has required visibility, so if - we had Wurble (Maybe a) Nothing, then the kind of Maybe a would - contribute to the kind of Wurble (Maybe a) Nothing. Hence, - injective_vars_of_binder(forall a -> ...) = {a}. - - Specified binders /might/ be injective positions, depending on how you - approach things. Continuing the '(:) example: - - '(:) :: forall a. a -> [a] -> [a] - - Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind - of '(:) 'True '[], since it's not explicitly instantiated by the user. But - if visible kind application is enabled, then this is possible, since the - user can write '(:) @Bool 'True '[]. (In that case, - injective_vars_of_binder(forall a. ...) = {a}.) - - There are some situations where using visible kind application is appropriate - (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH - reification), so the `injective_vars_of_binder` function is parametrized by - a Bool which decides if specified binders should be counted towards - injective positions or not. - -Now that we've defined injective_vars_of_binder, we can refine the Question We -Must Answer once more: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the remainder of T's kind? - -If the answer to this question is "no", then (T ty_1 ... ty_n) needs an -explicit kind signature, since T's kind has kind variables leftover that -aren't fixed by the non-omitted arguments. - -One last sticking point: what does "the remainder of T's kind" mean? You might -be tempted to think that it corresponds to all of the arguments in the kind of -T that would normally be instantiated by omitted arguments. But this isn't -quite right, strictly speaking. Consider the following (silly) example: - - S :: forall {k}. Type -> Type - -And suppose we have this application of S: - - S Int Bool - -The Int argument would be omitted, and -injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which -might suggest that (S Bool) needs an explicit kind signature. But -(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature -only affects the /result/ of the application, not all of the individual -arguments. So adding a kind signature here won't make a difference. Therefore, -the fourth (and final) iteration of the Question We Must Answer is: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the kind of (T ty_1 ... ty_n)? - -Phew, that was a lot of work! - -How can be sure that this is correct? That is, how can we be sure that in the -event that we leave off a kind annotation, that one could infer the kind of the -tycon application from its arguments? It's essentially a proof by induction: if -we can infer the kinds of every subtree of a type, then the whole tycon -application will have an inferrable kind--unless, of course, the remainder of -the tycon application's kind has uninstantiated kind variables. - -What happens if T is oversaturated? That is, if T's kind has fewer than n -arguments, in the case that the concrete application instantiates a result -kind variable with an arrow kind? If we run out of arguments, we do not attach -a kind annotation. This should be a rare case, indeed. Here is an example: - - data T1 :: k1 -> k2 -> * - data T2 :: k1 -> k2 -> * - - type family G (a :: k) :: k - type instance G T1 = T2 - - type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above - -Here G's kind is (forall k. k -> k), and the desugared RHS of that last -instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to -the algorithm above, there are 3 arguments to G so we should peel off 3 -arguments in G's kind. But G's kind has only two arguments. This is the -rare special case, and we choose not to annotate the application of G with -a kind signature. After all, we needn't do this, since that instance would -be reified as: - - type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool - -So the kind of G isn't ambiguous anymore due to the explicit kind annotation -on its argument. See #8953 and test th/T8953. --} diff --git a/types/Type.hs-boot b/types/Type.hs-boot deleted file mode 100644 --- a/types/Type.hs-boot +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Type where - -import GhcPrelude -import {-# SOURCE #-} TyCon -import {-# SOURCE #-} TyCoRep( Type, Coercion ) -import Util - -isPredTy :: HasDebugCallStack => Type -> Bool -isCoercionTy :: Type -> Bool - -mkAppTy :: Type -> Type -> Type -mkCastTy :: Type -> Coercion -> Type -piResultTy :: HasDebugCallStack => Type -> Type -> Type - -eqType :: Type -> Type -> Bool - -coreView :: Type -> Maybe Type -tcView :: Type -> Maybe Type -isRuntimeRepTy :: Type -> Bool -isLiftedTypeKind :: Type -> Bool - -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) - -partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/types/Unify.hs b/types/Unify.hs deleted file mode 100644 --- a/types/Unify.hs +++ /dev/null @@ -1,1592 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module Unify ( - tcMatchTy, tcMatchTyKi, - tcMatchTys, tcMatchTyKis, - tcMatchTyX, tcMatchTysX, tcMatchTyKisX, - tcMatchTyX_BM, ruleMatchTyKiX, - - -- * Rough matching - roughMatchTcs, instanceCantMatch, - typesCantMatch, - - -- Side-effect free unification - tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, - tcUnifyTysFG, tcUnifyTyWithTFs, - BindFlag(..), - UnifyResult, UnifyResultM(..), - - -- Matching a type against a lifted type (coercion) - liftCoMatch - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Var -import VarEnv -import VarSet -import Name( Name ) -import Type hiding ( getTvSubstEnv ) -import Coercion hiding ( getCvSubstEnv ) -import TyCon -import TyCoRep -import TyCoFVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) -import TyCoSubst ( mkTvSubst ) -import FV( FV, fvVarSet, fvVarList ) -import Util -import Pair -import Outputable -import UniqFM -import UniqSet - -import Control.Monad -import qualified Control.Monad.Fail as MonadFail -import Control.Applicative hiding ( empty ) -import qualified Control.Applicative - -{- - -Unification is much tricker than you might think. - -1. The substitution we generate binds the *template type variables* - which are given to us explicitly. - -2. We want to match in the presence of foralls; - e.g (forall a. t1) ~ (forall b. t2) - - That is what the RnEnv2 is for; it does the alpha-renaming - that makes it as if a and b were the same variable. - Initialising the RnEnv2, so that it can generate a fresh - binder when necessary, entails knowing the free variables of - both types. - -3. We must be careful not to bind a template type variable to a - locally bound variable. E.g. - (forall a. x) ~ (forall b. b) - where x is the template type variable. Then we do not want to - bind x to a/b! This is a kind of occurs check. - The necessary locals accumulate in the RnEnv2. - -Note [tcMatchTy vs tcMatchTyKi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This module offers two variants of matching: with kinds and without. -The TyKi variant takes two types, of potentially different kinds, -and matches them. Along the way, it necessarily also matches their -kinds. The Ty variant instead assumes that the kinds are already -eqType and so skips matching up the kinds. - -How do you choose between them? - -1. If you know that the kinds of the two types are eqType, use - the Ty variant. It is more efficient, as it does less work. - -2. If the kinds of variables in the template type might mention type families, - use the Ty variant (and do other work to make sure the kinds - work out). These pure unification functions do a straightforward - syntactic unification and do no complex reasoning about type - families. Note that the types of the variables in instances can indeed - mention type families, so instance lookup must use the Ty variant. - - (Nothing goes terribly wrong -- no panics -- if there might be type - families in kinds in the TyKi variant. You just might get match - failure even though a reducing a type family would lead to success.) - -3. Otherwise, if you're sure that the variable kinds do not mention - type families and you're not already sure that the kind of the template - equals the kind of the target, then use the TyKi version. --} - --- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) --- @s@ such that @s(t1)@ equals @t2@. --- The returned substitution might bind coercion variables, --- if the variable is an argument to a GADT constructor. --- --- Precondition: typeKind ty1 `eqType` typeKind ty2 --- --- We don't pass in a set of "template variables" to be bound --- by the match, because tcMatchTy (and similar functions) are --- always used on top-level types, so we can bind any of the --- free variables of the LHS. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTy :: Type -> Type -> Maybe TCvSubst -tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] - -tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst - -> Type -> Type -> Maybe TCvSubst -tcMatchTyX_BM bind_me subst ty1 ty2 - = tc_match_tys_x bind_me False subst [ty1] [ty2] - --- | Like 'tcMatchTy', but allows the kinds of the types to differ, --- and thus matches them as well. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKi :: Type -> Type -> Maybe TCvSubst -tcMatchTyKi ty1 ty2 - = tc_match_tys (const BindMe) True [ty1] [ty2] - --- | This is similar to 'tcMatchTy', but extends a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyX :: TCvSubst -- ^ Substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe TCvSubst -tcMatchTyX subst ty1 ty2 - = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] - --- | Like 'tcMatchTy' but over a list of types. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTys :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot; in principle the template - -- variables could be free in the target -tcMatchTys tys1 tys2 - = tc_match_tys (const BindMe) False tys1 tys2 - --- | Like 'tcMatchTyKi' but over a list of types. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKis :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTyKis tys1 tys2 - = tc_match_tys (const BindMe) True tys1 tys2 - --- | Like 'tcMatchTys', but extending a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTysX :: TCvSubst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTysX subst tys1 tys2 - = tc_match_tys_x (const BindMe) False subst tys1 tys2 - --- | Like 'tcMatchTyKis', but extending a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution -tcMatchTyKisX subst tys1 tys2 - = tc_match_tys_x (const BindMe) True subst tys1 tys2 - --- | Same as tc_match_tys_x, but starts with an empty substitution -tc_match_tys :: (TyVar -> BindFlag) - -> Bool -- ^ match kinds? - -> [Type] - -> [Type] - -> Maybe TCvSubst -tc_match_tys bind_me match_kis tys1 tys2 - = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 - where - in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) - --- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' -tc_match_tys_x :: (TyVar -> BindFlag) - -> Bool -- ^ match kinds? - -> TCvSubst - -> [Type] - -> [Type] - -> Maybe TCvSubst -tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 - = case tc_unify_tys bind_me - False -- Matching, not unifying - False -- Not an injectivity check - match_kis - (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of - Unifiable (tv_env', cv_env') - -> Just $ TCvSubst in_scope tv_env' cv_env' - _ -> Nothing - --- | This one is called from the expression matcher, --- which already has a MatchEnv in hand -ruleMatchTyKiX - :: TyCoVarSet -- ^ template variables - -> RnEnv2 - -> TvSubstEnv -- ^ type substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe TvSubstEnv -ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target --- See Note [Kind coercions in Unify] - = case tc_unify_tys (matchBindFun tmpl_tvs) False False - True -- <-- this means to match the kinds - rn_env tenv emptyCvSubstEnv [tmpl] [target] of - Unifiable (tenv', _) -> Just tenv' - _ -> Nothing - -matchBindFun :: TyCoVarSet -> TyVar -> BindFlag -matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem - - -{- ********************************************************************* -* * - Rough matching -* * -********************************************************************* -} - --- See Note [Rough match] field in InstEnv - -roughMatchTcs :: [Type] -> [Maybe Name] -roughMatchTcs tys = map rough tys - where - rough ty - | Just (ty', _) <- splitCastTy_maybe ty = rough ty' - | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) - | otherwise = Nothing - -instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool --- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot --- possibly be instantiated to actual, nor vice versa; --- False is non-committal -instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as -instanceCantMatch _ _ = False -- Safe - -itemCantMatch :: Maybe Name -> Maybe Name -> Bool -itemCantMatch (Just t) (Just a) = t /= a -itemCantMatch _ _ = False - - -{- -************************************************************************ -* * - GADTs -* * -************************************************************************ - -Note [Pruning dead case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider data T a where - T1 :: T Int - T2 :: T a - - newtype X = MkX Int - newtype Y = MkY Char - - type family F a - type instance F Bool = Int - -Now consider case x of { T1 -> e1; T2 -> e2 } - -The question before the house is this: if I know something about the type -of x, can I prune away the T1 alternative? - -Suppose x::T Char. It's impossible to construct a (T Char) using T1, - Answer = YES we can prune the T1 branch (clearly) - -Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated -to 'Bool', in which case x::T Int, so - ANSWER = NO (clearly) - -We see here that we want precisely the apartness check implemented within -tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely -apart. Note that since we are simply dropping dead code, a conservative test -suffices. --} - --- | Given a list of pairs of types, are any two members of a pair surely --- apart, even after arbitrary type function evaluation and substitution? -typesCantMatch :: [(Type,Type)] -> Bool --- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (uncurry cant_match) prs - where - cant_match :: Type -> Type -> Bool - cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of - SurelyApart -> True - _ -> False - -{- -************************************************************************ -* * - Unification -* * -************************************************************************ - -Note [Fine-grained unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- -no substitution to finite types makes these match. But, a substitution to -*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. -Why do we care? Consider these two type family instances: - -type instance F x x = Int -type instance F [y] y = Bool - -If we also have - -type instance Looper = [Looper] - -then the instances potentially overlap. The solution is to use unification -over infinite terms. This is possible (see [1] for lots of gory details), but -a full algorithm is a little more power than we need. Instead, we make a -conservative approximation and just omit the occurs check. - -[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf - -tcUnifyTys considers an occurs-check problem as the same as general unification -failure. - -tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check -failure ("MaybeApart"), or general failure ("SurelyApart"). - -See also #8162. - -It's worth noting that unification in the presence of infinite types is not -complete. This means that, sometimes, a closed type family does not reduce -when it should. See test case indexed-types/should_fail/Overlap15 for an -example. - -Note [The substitution in MaybeApart] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? -Because consider unifying these: - -(a, a, Int) ~ (b, [b], Bool) - -If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we -apply the subst we have so far and discover that we need [b |-> [b]]. Because -this fails the occurs check, we say that the types are MaybeApart (see above -Note [Fine-grained unification]). But, we can't stop there! Because if we -continue, we discover that Int is SurelyApart from Bool, and therefore the -types are apart. This has practical consequences for the ability for closed -type family applications to reduce. See test case -indexed-types/should_compile/Overlap14. - -Note [Unifying with skolems] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we discover that two types unify if and only if a skolem variable is -substituted, we can't properly unify the types. But, that skolem variable -may later be instantiated with a unifyable type. So, we return maybeApart -in these cases. --} - --- | Simple unification of two types; all type variables are bindable --- Precondition: the kinds are already equal -tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TCvSubst - -- A regular one-shot (idempotent) substitution -tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] - --- | Like 'tcUnifyTy', but also unifies the kinds -tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst -tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] - --- | Unify two types, treating type family applications as possibly unifying --- with anything and looking through injective type family applications. --- Precondition: kinds are the same -tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; - -- False <=> do one-way matching. - -- See end of sec 5.2 from the paper - -> Type -> Type -> Maybe TCvSubst --- This algorithm is an implementation of the "Algorithm U" presented in --- the paper "Injective type families for Haskell", Figures 2 and 3. --- The code is incorporated with the standard unifier for convenience, but --- its operation should match the specification in the paper. -tcUnifyTyWithTFs twoWay t1 t2 - = case tc_unify_tys (const BindMe) twoWay True False - rn_env emptyTvSubstEnv emptyCvSubstEnv - [t1] [t2] of - Unifiable (subst, _) -> Just $ maybe_fix subst - MaybeApart (subst, _) -> Just $ maybe_fix subst - -- we want to *succeed* in questionable cases. This is a - -- pre-unification algorithm. - SurelyApart -> Nothing - where - in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] - rn_env = mkRnEnv2 in_scope - - maybe_fix | twoWay = niFixTCvSubst - | otherwise = mkTvSubst in_scope -- when matching, don't confuse - -- domain with range - ------------------ -tcUnifyTys :: (TyCoVar -> BindFlag) - -> [Type] -> [Type] - -> Maybe TCvSubst - -- ^ A regular one-shot (idempotent) substitution - -- that unifies the erased types. See comments - -- for 'tcUnifyTysFG' - --- The two types may have common type variables, and indeed do so in the --- second call to tcUnifyTys in FunDeps.checkClsFD -tcUnifyTys bind_fn tys1 tys2 - = case tcUnifyTysFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- | Like 'tcUnifyTys' but also unifies the kinds -tcUnifyTyKis :: (TyCoVar -> BindFlag) - -> [Type] -> [Type] - -> Maybe TCvSubst -tcUnifyTyKis bind_fn tys1 tys2 - = case tcUnifyTyKisFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- This type does double-duty. It is used in the UM (unifier monad) and to --- return the final result. See Note [Fine-grained unification] -type UnifyResult = UnifyResultM TCvSubst -data UnifyResultM a = Unifiable a -- the subst that unifies the types - | MaybeApart a -- the subst has as much as we know - -- it must be part of a most general unifier - -- See Note [The substitution in MaybeApart] - | SurelyApart - deriving Functor - -instance Applicative UnifyResultM where - pure = Unifiable - (<*>) = ap - -instance Monad UnifyResultM where - - SurelyApart >>= _ = SurelyApart - MaybeApart x >>= f = case f x of - Unifiable y -> MaybeApart y - other -> other - Unifiable x >>= f = f x - -instance Alternative UnifyResultM where - empty = SurelyApart - - a@(Unifiable {}) <|> _ = a - _ <|> b@(Unifiable {}) = b - a@(MaybeApart {}) <|> _ = a - _ <|> b@(MaybeApart {}) = b - SurelyApart <|> SurelyApart = SurelyApart - -instance MonadPlus UnifyResultM - --- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose --- domain elements all respond 'BindMe' to @bind_tv@) such that --- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned --- Coercions. This version requires that the kinds of the types are the same, --- if you unify left-to-right. -tcUnifyTysFG :: (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTysFG bind_fn tys1 tys2 - = tc_unify_tys_fg False bind_fn tys1 tys2 - -tcUnifyTyKisFG :: (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTyKisFG bind_fn tys1 tys2 - = tc_unify_tys_fg True bind_fn tys1 tys2 - -tc_unify_tys_fg :: Bool - -> (TyVar -> BindFlag) - -> [Type] -> [Type] - -> UnifyResult -tc_unify_tys_fg match_kis bind_fn tys1 tys2 - = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env - emptyTvSubstEnv emptyCvSubstEnv - tys1 tys2 - ; return $ niFixTCvSubst env } - where - vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 - env = mkRnEnv2 $ mkInScopeSet vars - --- | This function is actually the one to call the unifier -- a little --- too general for outside clients, though. -tc_unify_tys :: (TyVar -> BindFlag) - -> AmIUnifying -- ^ True <=> unify; False <=> match - -> Bool -- ^ True <=> doing an injectivity check - -> Bool -- ^ True <=> treat the kinds as well - -> RnEnv2 - -> TvSubstEnv -- ^ substitution to extend - -> CvSubstEnv - -> [Type] -> [Type] - -> UnifyResultM (TvSubstEnv, CvSubstEnv) --- NB: It's tempting to ASSERT here that, if we're not matching kinds, then --- the kinds of the types should be the same. However, this doesn't work, --- as the types may be a dependent telescope, where later types have kinds --- that mention variables occurring earlier in the list of types. Here's an --- example (from typecheck/should_fail/T12709): --- template: [rep :: RuntimeRep, a :: TYPE rep] --- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] --- We can see that matching the first pair will make the kinds of the second --- pair equal. Yet, we still don't need a separate pass to unify the kinds --- of these types, so it's appropriate to use the Ty variant of unification. --- See also Note [tcMatchTy vs tcMatchTyKi]. -tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 - = initUM tv_env cv_env $ - do { when match_kis $ - unify_tys env kis1 kis2 - ; unify_tys env tys1 tys2 - ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } - where - env = UMEnv { um_bind_fun = bind_fn - , um_skols = emptyVarSet - , um_unif = unif - , um_inj_tf = inj_check - , um_rn_env = rn_env } - - kis1 = map typeKind tys1 - kis2 = map typeKind tys2 - -instance Outputable a => Outputable (UnifyResultM a) where - ppr SurelyApart = text "SurelyApart" - ppr (Unifiable x) = text "Unifiable" <+> ppr x - ppr (MaybeApart x) = text "MaybeApart" <+> ppr x - -{- -************************************************************************ -* * - Non-idempotent substitution -* * -************************************************************************ - -Note [Non-idempotent substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During unification we use a TvSubstEnv/CvSubstEnv pair that is - (a) non-idempotent - (b) loop-free; ie repeatedly applying it yields a fixed point - -Note [Finding the substitution fixpoint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Finding the fixpoint of a non-idempotent substitution arising from a -unification is much trickier than it looks, because of kinds. Consider - T k (H k (f:k)) ~ T * (g:*) -If we unify, we get the substitution - [ k -> * - , g -> H k (f:k) ] -To make it idempotent we don't want to get just - [ k -> * - , g -> H * (f:k) ] -We also want to substitute inside f's kind, to get - [ k -> * - , g -> H k (f:*) ] -If we don't do this, we may apply the substitution to something, -and get an ill-formed type, i.e. one where typeKind will fail. -This happened, for example, in #9106. - -It gets worse. In #14164 we wanted to take the fixpoint of -this substitution - [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) - (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) - , a_aY6 :-> a_aXQ ] - -We have to apply the substitution for a_aY6 two levels deep inside -the invocation of F! We don't have a function that recursively -applies substitutions inside the kinds of variable occurrences (and -probably rightly so). - -So, we work as follows: - - 1. Start with the current substitution (which we are - trying to fixpoint - [ xs :-> F a (z :: a) (rest :: G a (z :: a)) - , a :-> b ] - - 2. Take all the free vars of the range of the substitution: - {a, z, rest, b} - NB: the free variable finder closes over - the kinds of variable occurrences - - 3. If none are in the domain of the substitution, stop. - We have found a fixpoint. - - 4. Remove the variables that are bound by the substitution, leaving - {z, rest, b} - - 5. Do a topo-sort to put them in dependency order: - [ b :: *, z :: a, rest :: G a z ] - - 6. Apply the substitution left-to-right to the kinds of these - tyvars, extending it each time with a new binding, so we - finish up with - [ xs :-> ..as before.. - , a :-> b - , b :-> b :: * - , z :-> z :: b - , rest :-> rest :: G b (z :: b) ] - Note that rest now has the right kind - - 7. Apply this extended substitution (once) to the range of - the /original/ substitution. (Note that we do the - extended substitution would go on forever if you tried - to find its fixpoint, because it maps z to z.) - - 8. And go back to step 1 - -In Step 6 we use the free vars from Step 2 as the initial -in-scope set, because all of those variables appear in the -range of the substitution, so they must all be in the in-scope -set. But NB that the type substitution engine does not look up -variables in the in-scope set; it is used only to ensure no -shadowing. --} - -niFixTCvSubst :: TvSubstEnv -> TCvSubst --- Find the idempotent fixed point of the non-idempotent substitution --- This is surprisingly tricky: --- see Note [Finding the substitution fixpoint] --- ToDo: use laziness instead of iteration? -niFixTCvSubst tenv - | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) - | otherwise = subst - where - range_fvs :: FV - range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) - -- It's OK to use nonDetEltsUFM here because the - -- order of range_fvs, range_tvs is immaterial - - range_tvs :: [TyVar] - range_tvs = fvVarList range_fvs - - not_fixpoint = any in_domain range_tvs - in_domain tv = tv `elemVarEnv` tenv - - free_tvs = scopedSort (filterOut in_domain range_tvs) - - -- See Note [Finding the substitution fixpoint], Step 6 - init_in_scope = mkInScopeSet (fvVarSet range_fvs) - subst = foldl' add_free_tv - (mkTvSubst init_in_scope tenv) - free_tvs - - add_free_tv :: TCvSubst -> TyVar -> TCvSubst - add_free_tv subst tv - = extendTvSubst subst tv (mkTyVarTy tv') - where - tv' = updateTyVarKind (substTy subst) tv - -niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet --- Apply the non-idempotent substitution to a set of type variables, --- remembering that the substitution isn't necessarily idempotent --- This is used in the occurs check, before extending the substitution -niSubstTvSet tsubst tvs - = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs - -- It's OK to nonDetFoldUFM here because we immediately forget the - -- ordering by creating a set. - where - get tv - | Just ty <- lookupVarEnv tsubst tv - = niSubstTvSet tsubst (tyCoVarsOfType ty) - - | otherwise - = unitVarSet tv - -{- -************************************************************************ -* * - unify_ty: the main workhorse -* * -************************************************************************ - -Note [Specification of unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The pure unifier, unify_ty, defined in this module, tries to work out -a substitution to make two types say True to eqType. NB: eqType is -itself not purely syntactic; it accounts for CastTys; -see Note [Non-trivial definitional equality] in TyCoRep - -Unlike the "impure unifiers" in the typechecker (the eager unifier in -TcUnify, and the constraint solver itself in TcCanonical), the pure -unifier It does /not/ work up to ~. - -The algorithm implemented here is rather delicate, and we depend on it -to uphold certain properties. This is a summary of these required -properties. Any reference to "flattening" refers to the flattening -algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not -the flattening algorithm in the solver. - -Notation: - θ,φ substitutions - ξ type-function-free types - τ,σ other types - τ♭ type τ, flattened - - ≡ eqType - -(U1) Soundness. - If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). - θ is a most general unifier for τ₁ and τ₂. - -(U2) Completeness. - If (unify ξ₁ ξ₂) = SurelyApart, - then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). - -These two properties are stated as Property 11 in the "Closed Type Families" -paper (POPL'14). Below, this paper is called [CTF]. - -(U3) Apartness under substitution. - If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, - for any θ. (Property 12 from [CTF]) - -(U4) Apart types do not unify. - If (unify ξ τ♭) = SurelyApart, then there exists no θ - such that θ(ξ) = θ(τ). (Property 13 from [CTF]) - -THEOREM. Completeness w.r.t ~ - If (unify τ₁♭ τ₂♭) = SurelyApart, - then there exists no proof that (τ₁ ~ τ₂). - -PROOF. See appendix of [CTF]. - - -The unification algorithm is used for type family injectivity, as described -in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run -in this mode, it has the following properties. - -(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even - after arbitrary type family reductions. Note that σ and τ are - not flattened here. - -(I2) If (unify σ τ) = MaybeApart θ, and if some - φ exists such that φ(σ) ~ φ(τ), then φ extends θ. - - -Furthermore, the RULES matching algorithm requires this property, -but only when using this algorithm for matching: - -(M1) If (match σ τ) succeeds with θ, then all matchable tyvars - in σ are bound in θ. - - Property M1 means that we must extend the substitution with, - say (a ↦ a) when appropriate during matching. - See also Note [Self-substitution when matching]. - -(M2) Completeness of matching. - If θ(σ) = τ, then (match σ τ) = Unifiable φ, - where θ is an extension of φ. - -Sadly, property M2 and I2 conflict. Consider - -type family F1 a b where - F1 Int Bool = Char - F1 Double String = Char - -Consider now two matching problems: - -P1. match (F1 a Bool) (F1 Int Bool) -P2. match (F1 a Bool) (F1 Double String) - -In case P1, we must find (a ↦ Int) to satisfy M2. -In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note -that the correct mapping for I2 is (a ↦ Int). There is no way to discover -this, but we musn't map a to anything else!) - -We thus must parameterize the algorithm over whether it's being used -for an injectivity check (refrain from looking at non-injective arguments -to type families) or not (do indeed look at those arguments). This is -implemented by the uf_inj_tf field of UmEnv. - -(It's all a question of whether or not to include equation (7) from Fig. 2 -of [ITF].) - -This extra parameter is a bit fiddly, perhaps, but seemingly less so than -having two separate, almost-identical algorithms. - -Note [Self-substitution when matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should happen when we're *matching* (not unifying) a1 with a1? We -should get a substitution [a1 |-> a1]. A successful match should map all -the template variables (except ones that disappear when expanding synonyms). -But when unifying, we don't want to do this, because we'll then fall into -a loop. - -This arrangement affects the code in three places: - - If we're matching a refined template variable, don't recur. Instead, just - check for equality. That is, if we know [a |-> Maybe a] and are matching - (a ~? Maybe Int), we want to just fail. - - - Skip the occurs check when matching. This comes up in two places, because - matching against variables is handled separately from matching against - full-on types. - -Note that this arrangement was provoked by a real failure, where the same -unique ended up in the template as in the target. (It was a rule firing when -compiling Data.List.NonEmpty.) - -Note [Matching coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - type family F a - - data G a where - MkG :: F a ~ Bool => G a - - type family Foo (x :: G a) :: F a - type instance Foo MkG = False - -We would like that to be accepted. For that to work, we need to introduce -a coercion variable on the left and then use it on the right. Accordingly, -at use sites of Foo, we need to be able to use matching to figure out the -value for the coercion. (See the desugared version: - - axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) - -) We never want this action to happen during *unification* though, when -all bets are off. - -Note [Kind coercions in Unify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to match/unify while ignoring casts. But, we can't just ignore -them completely, or we'll end up with ill-kinded substitutions. For example, -say we're matching `a` with `ty |> co`. If we just drop the cast, we'll -return [a |-> ty], but `a` and `ty` might have different kinds. We can't -just match/unify their kinds, either, because this might gratuitously -fail. After all, `co` is the witness that the kinds are the same -- they -may look nothing alike. - -So, we pass a kind coercion to the match/unify worker. This coercion witnesses -the equality between the substed kind of the left-hand type and the substed -kind of the right-hand type. Note that we do not unify kinds at the leaves -(as we did previously). We thus have - -INVARIANT: In the call - unify_ty ty1 ty2 kco -it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where -`subst` is the ambient substitution in the UM monad. - -To get this coercion, we first have to match/unify -the kinds before looking at the types. Happily, we need look only one level -up, as all kinds are guaranteed to have kind *. - -When we're working with type applications (either TyConApp or AppTy) we -need to worry about establishing INVARIANT, as the kinds of the function -& arguments aren't (necessarily) included in the kind of the result. -When unifying two TyConApps, this is easy, because the two TyCons are -the same. Their kinds are thus the same. As long as we unify left-to-right, -we'll be sure to unify types' kinds before the types themselves. (For example, -think about Proxy :: forall k. k -> *. Unifying the first args matches up -the kinds of the second args.) - -For AppTy, we must unify the kinds of the functions, but once these are -unified, we can continue unifying arguments without worrying further about -kinds. - -The interface to this module includes both "...Ty" functions and -"...TyKi" functions. The former assume that INVARIANT is already -established, either because the kinds are the same or because the -list of types being passed in are the well-typed arguments to some -type constructor (see two paragraphs above). The latter take a separate -pre-pass over the kinds to establish INVARIANT. Sometimes, it's important -not to take the second pass, as it caused #12442. - -We thought, at one point, that this was all unnecessary: why should -casts be in types in the first place? But they are sometimes. In -dependent/should_compile/KindEqualities2, we see, for example the -constraint Num (Int |> (blah ; sym blah)). We naturally want to find -a dictionary for that constraint, which requires dealing with -coercions in this manner. - -Note [Matching in the presence of casts (1)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When matching, it is crucial that no variables from the template -end up in the range of the matching substitution (obviously!). -When unifying, that's not a constraint; instead we take the fixpoint -of the substitution at the end. - -So what should we do with this, when matching? - unify_ty (tmpl |> co) tgt kco - -Previously, wrongly, we pushed 'co' in the (horrid) accumulating -'kco' argument like this: - unify_ty (tmpl |> co) tgt kco - = unify_ty tmpl tgt (kco ; co) - -But that is obviously wrong because 'co' (from the template) ends -up in 'kco', which in turn ends up in the range of the substitution. - -This all came up in #13910. Because we match tycon arguments -left-to-right, the ambient substitution will already have a matching -substitution for any kinds; so there is an easy fix: just apply -the substitution-so-far to the coercion from the LHS. - -Note that - -* When matching, the first arg of unify_ty is always the template; - we never swap round. - -* The above argument is distressingly indirect. We seek a - better way. - -* One better way is to ensure that type patterns (the template - in the matching process) have no casts. See #14119. - -Note [Matching in the presence of casts (2)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) -and we are matching - tcMatchTy (T k (a::k)) (T j (b::j)) - -Then we'll match k :-> j, as expected. But then in unify_tys -we invoke - unify_tys env (a::k) (b::j) (Refl j) - -Although we have unified k and j, it's very important that we put -(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. -If we put (Refl k) we'd end up with teh substitution - a :-> b |> Refl k -which is bogus because one of the template variables, k, -appears in the range of the substitution. Eek. - -Similar care is needed in unify_ty_app. - - -Note [Polykinded tycon applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose T :: forall k. Type -> K -and we are unifying - ty1: T @Type Int :: Type - ty2: T @(Type->Type) Int Int :: Type - -These two TyConApps have the same TyCon at the front but they -(legitimately) have different numbers of arguments. They -are surelyApart, so we can report that without looking any -further (see #15704). --} - --------------- unify_ty: the main workhorse ----------- - -type AmIUnifying = Bool -- True <=> Unifying - -- False <=> Matching - -unify_ty :: UMEnv - -> Type -> Type -- Types to be unified and a co - -> CoercionN -- A coercion between their kinds - -- See Note [Kind coercions in Unify] - -> UM () --- See Note [Specification of unification] --- Respects newtypes, PredTypes - -unify_ty env ty1 ty2 kco - -- TODO: More commentary needed here - | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco - | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco - | CastTy ty1' co <- ty1 = if um_unif env - then unify_ty env ty1' ty2 (co `mkTransCo` kco) - else -- See Note [Matching in the presence of casts (1)] - do { subst <- getSubst env - ; let co' = substCo subst co - ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } - | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) - -unify_ty env (TyVarTy tv1) ty2 kco - = uVar env tv1 ty2 kco -unify_ty env ty1 (TyVarTy tv2) kco - | um_unif env -- If unifying, can swap args - = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) - -unify_ty env ty1 ty2 _kco - | Just (tc1, tys1) <- mb_tc_app1 - , Just (tc2, tys2) <- mb_tc_app2 - , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) - = if isInjectiveTyCon tc1 Nominal - then unify_tys env tys1 tys2 - else do { let inj | isTypeFamilyTyCon tc1 - = case tyConInjectivityInfo tc1 of - NotInjective -> repeat False - Injective bs -> bs - | otherwise - = repeat False - - (inj_tys1, noninj_tys1) = partitionByList inj tys1 - (inj_tys2, noninj_tys2) = partitionByList inj tys2 - - ; unify_tys env inj_tys1 inj_tys2 - ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] - don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } - - | Just (tc1, _) <- mb_tc_app1 - , not (isGenerativeTyCon tc1 Nominal) - -- E.g. unify_ty (F ty1) b = MaybeApart - -- because the (F ty1) behaves like a variable - -- NB: if unifying, we have already dealt - -- with the 'ty2 = variable' case - = maybeApart - - | Just (tc2, _) <- mb_tc_app2 - , not (isGenerativeTyCon tc2 Nominal) - , um_unif env - -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) - -- because the (F ty2) behaves like a variable - -- NB: we have already dealt with the 'ty1 = variable' case - = maybeApart - - where - mb_tc_app1 = tcSplitTyConApp_maybe ty1 - mb_tc_app2 = tcSplitTyConApp_maybe ty2 - - -- Applications need a bit of care! - -- They can match FunTy and TyConApp, so use splitAppTy_maybe - -- NB: we've already dealt with type variables, - -- so if one type is an App the other one jolly well better be too -unify_ty env (AppTy ty1a ty1b) ty2 _kco - | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty env ty1 (AppTy ty2a ty2b) _kco - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () - -unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco - = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) - ; let env' = umRnBndr2 env tv1 tv2 - ; unify_ty env' ty1 ty2 kco } - --- See Note [Matching coercion variables] -unify_ty env (CoercionTy co1) (CoercionTy co2) kco - = do { c_subst <- getCvSubstEnv - ; case co1 of - CoVarCo cv - | not (um_unif env) - , not (cv `elemVarEnv` c_subst) - , BindMe <- tvBindFlag env cv - -> do { checkRnEnv env (tyCoVarsOfCo co2) - ; let (co_l, co_r) = decomposeFunCo Nominal kco - -- cv :: t1 ~ t2 - -- co2 :: s1 ~ s2 - -- co_l :: t1 ~ s1 - -- co_r :: t2 ~ s2 - ; extendCvEnv cv (co_l `mkTransCo` - co2 `mkTransCo` - mkSymCo co_r) } - _ -> return () } - -unify_ty _ _ _ _ = surelyApart - -unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () -unify_ty_app env ty1 ty1args ty2 ty2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 - = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) - - | otherwise - = do { let ki1 = typeKind ty1 - ki2 = typeKind ty2 - -- See Note [Kind coercions in Unify] - ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) - ; unify_ty env ty1 ty2 (mkNomReflCo ki2) - -- Very important: 'ki2' not 'ki1' - -- See Note [Matching in the presence of casts (2)] - ; unify_tys env ty1args ty2args } - -unify_tys :: UMEnv -> [Type] -> [Type] -> UM () -unify_tys env orig_xs orig_ys - = go orig_xs orig_ys - where - go [] [] = return () - go (x:xs) (y:ys) - -- See Note [Kind coercions in Unify] - = do { unify_ty env x y (mkNomReflCo $ typeKind y) - -- Very important: 'y' not 'x' - -- See Note [Matching in the presence of casts (2)] - ; go xs ys } - go _ _ = surelyApart - -- Possibly different saturations of a polykinded tycon - -- See Note [Polykinded tycon applications] - ---------------------------------- -uVar :: UMEnv - -> InTyVar -- Variable to be unified - -> Type -- with this Type - -> Coercion -- :: kind tv ~N kind ty - -> UM () - -uVar env tv1 ty kco - = do { -- Apply the ambient renaming - let tv1' = umRnOccL env tv1 - - -- Check to see whether tv1 is refined by the substitution - ; subst <- getTvSubstEnv - ; case (lookupVarEnv subst tv1') of - Just ty' | um_unif env -- Unifying, so call - -> unify_ty env ty' ty kco -- back into unify - | otherwise - -> -- Matching, we don't want to just recur here. - -- this is because the range of the subst is the target - -- type, not the template type. So, just check for - -- normal type equality. - guard ((ty' `mkCastTy` kco) `eqType` ty) - Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue - -uUnrefined :: UMEnv - -> OutTyVar -- variable to be unified - -> Type -- with this Type - -> Type -- (version w/ expanded synonyms) - -> Coercion -- :: kind tv ~N kind ty - -> UM () - --- We know that tv1 isn't refined - -uUnrefined env tv1' ty2 ty2' kco - | Just ty2'' <- coreView ty2' - = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms - -- This is essential, in case we have - -- type Foo a = a - -- and then unify a ~ Foo a - - | TyVarTy tv2 <- ty2' - = do { let tv2' = umRnOccR env tv2 - ; unless (tv1' == tv2' && um_unif env) $ do - -- If we are unifying a ~ a, just return immediately - -- Do not extend the substitution - -- See Note [Self-substitution when matching] - - -- Check to see whether tv2 is refined - { subst <- getTvSubstEnv - ; case lookupVarEnv subst tv2 of - { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco - ; _ -> - - do { -- So both are unrefined - -- Bind one or the other, depending on which is bindable - ; let b1 = tvBindFlag env tv1' - b2 = tvBindFlag env tv2' - ty1 = mkTyVarTy tv1' - ; case (b1, b2) of - (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) - (_, BindMe) | um_unif env - -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco) - - _ | tv1' == tv2' -> return () - -- How could this happen? If we're only matching and if - -- we're comparing forall-bound variables. - - _ -> maybeApart -- See Note [Unification with skolems] - }}}} - -uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable - = case tvBindFlag env tv1' of - Skolem -> maybeApart -- See Note [Unification with skolems] - BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) - -bindTv :: UMEnv -> OutTyVar -> Type -> UM () --- OK, so we want to extend the substitution with tv := ty --- But first, we must do a couple of checks -bindTv env tv1 ty2 - = do { let free_tvs2 = tyCoVarsOfType ty2 - - -- Make sure tys mentions no local variables - -- E.g. (forall a. b) ~ (forall a. [a]) - -- We should not unify b := [a]! - ; checkRnEnv env free_tvs2 - - -- Occurs check, see Note [Fine-grained unification] - -- Make sure you include 'kco' (which ty2 does) #14846 - ; occurs <- occursCheck env tv1 free_tvs2 - - ; if occurs then maybeApart - else extendTvEnv tv1 ty2 } - -occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool -occursCheck env tv free_tvs - | um_unif env - = do { tsubst <- getTvSubstEnv - ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } - - | otherwise -- Matching; no occurs check - = return False -- See Note [Self-substitution when matching] - -{- -%************************************************************************ -%* * - Binding decisions -* * -************************************************************************ --} - -data BindFlag - = BindMe -- A regular type variable - - | Skolem -- This type variable is a skolem constant - -- Don't bind it; it only matches itself - deriving Eq - -{- -************************************************************************ -* * - Unification monad -* * -************************************************************************ --} - -data UMEnv - = UMEnv { um_unif :: AmIUnifying - - , um_inj_tf :: Bool - -- Checking for injectivity? - -- See (end of) Note [Specification of unification] - - , um_rn_env :: RnEnv2 - -- Renaming InTyVars to OutTyVars; this eliminates - -- shadowing, and lines up matching foralls on the left - -- and right - - , um_skols :: TyVarSet - -- OutTyVars bound by a forall in this unification; - -- Do not bind these in the substitution! - -- See the function tvBindFlag - - , um_bind_fun :: TyVar -> BindFlag - -- User-supplied BindFlag function, - -- for variables not in um_skols - } - -data UMState = UMState - { um_tv_env :: TvSubstEnv - , um_cv_env :: CvSubstEnv } - -newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) } - deriving (Functor) - -instance Applicative UM where - pure a = UM (\s -> pure (s, a)) - (<*>) = ap - -instance Monad UM where -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - m >>= k = UM (\state -> - do { (state', v) <- unUM m state - ; unUM (k v) state' }) - --- need this instance because of a use of 'guard' above -instance Alternative UM where - empty = UM (\_ -> Control.Applicative.empty) - m1 <|> m2 = UM (\state -> - unUM m1 state <|> - unUM m2 state) - -instance MonadPlus UM - -instance MonadFail.MonadFail UM where - fail _ = UM (\_ -> SurelyApart) -- failed pattern match - -initUM :: TvSubstEnv -- subst to extend - -> CvSubstEnv - -> UM a -> UnifyResultM a -initUM subst_env cv_subst_env um - = case unUM um state of - Unifiable (_, subst) -> Unifiable subst - MaybeApart (_, subst) -> MaybeApart subst - SurelyApart -> SurelyApart - where - state = UMState { um_tv_env = subst_env - , um_cv_env = cv_subst_env } - -tvBindFlag :: UMEnv -> OutTyVar -> BindFlag -tvBindFlag env tv - | tv `elemVarSet` um_skols env = Skolem - | otherwise = um_bind_fun env tv - -getTvSubstEnv :: UM TvSubstEnv -getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) - -getCvSubstEnv :: UM CvSubstEnv -getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) - -getSubst :: UMEnv -> UM TCvSubst -getSubst env = do { tv_env <- getTvSubstEnv - ; cv_env <- getCvSubstEnv - ; let in_scope = rnInScopeSet (um_rn_env env) - ; return (mkTCvSubst in_scope (tv_env, cv_env)) } - -extendTvEnv :: TyVar -> Type -> UM () -extendTvEnv tv ty = UM $ \state -> - Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) - -extendCvEnv :: CoVar -> Coercion -> UM () -extendCvEnv cv co = UM $ \state -> - Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) - -umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv -umRnBndr2 env v1 v2 - = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } - where - (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 - -checkRnEnv :: UMEnv -> VarSet -> UM () -checkRnEnv env varset - | isEmptyVarSet skol_vars = return () - | varset `disjointVarSet` skol_vars = return () - | otherwise = maybeApart - -- ToDo: why MaybeApart? - -- I think SurelyApart would be right - where - skol_vars = um_skols env - -- NB: That isEmptyVarSet guard is a critical optimization; - -- it means we don't have to calculate the free vars of - -- the type, often saving quite a bit of allocation. - --- | Converts any SurelyApart to a MaybeApart -don'tBeSoSure :: UM () -> UM () -don'tBeSoSure um = UM $ \ state -> - case unUM um state of - SurelyApart -> MaybeApart (state, ()) - other -> other - -umRnOccL :: UMEnv -> TyVar -> TyVar -umRnOccL env v = rnOccL (um_rn_env env) v - -umRnOccR :: UMEnv -> TyVar -> TyVar -umRnOccR env v = rnOccR (um_rn_env env) v - -umSwapRn :: UMEnv -> UMEnv -umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } - -maybeApart :: UM () -maybeApart = UM (\state -> MaybeApart (state, ())) - -surelyApart :: UM a -surelyApart = UM (\_ -> SurelyApart) - -{- -%************************************************************************ -%* * - Matching a (lifted) type against a coercion -%* * -%************************************************************************ - -This section defines essentially an inverse to liftCoSubst. It is defined -here to avoid a dependency from Coercion on this module. - --} - -data MatchEnv = ME { me_tmpls :: TyVarSet - , me_env :: RnEnv2 } - --- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if --- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, --- where @==@ there means that the result of 'liftCoSubst' has the same --- type as the original co; but may be different under the hood. --- That is, it matches a type against a coercion of the same --- "shape", and returns a lifting substitution which could have been --- used to produce the given coercion from the given type. --- Note that this function is incomplete -- it might return Nothing --- when there does indeed exist a possible lifting context. --- --- This function is incomplete in that it doesn't respect the equality --- in `eqType`. That is, it's possible that this will succeed for t1 and --- fail for t2, even when t1 `eqType` t2. That's because it depends on --- there being a very similar structure between the type and the coercion. --- This incompleteness shouldn't be all that surprising, especially because --- it depends on the structure of the coercion, which is a silly thing to do. --- --- The lifting context produced doesn't have to be exacting in the roles --- of the mappings. This is because any use of the lifting context will --- also require a desired role. Thus, this algorithm prefers mapping to --- nominal coercions where it can do so. -liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext -liftCoMatch tmpls ty co - = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co - ; cenv2 <- ty_co_match menv cenv1 ty co - (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) - ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } - where - menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } - in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) - -- Like tcMatchTy, assume all the interesting variables - -- in ty are in tmpls - - ki = typeKind ty - ki_co = promoteCoercion co - ki_ki_co = mkNomReflCo liftedTypeKind - - Pair co_lkind co_rkind = coercionKind ki_co - --- | 'ty_co_match' does all the actual work for 'liftCoMatch'. -ty_co_match :: MatchEnv -- ^ ambient helpful info - -> LiftCoEnv -- ^ incoming subst - -> Type -- ^ ty, type to match - -> Coercion -- ^ co, coercion to match against - -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co - -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co - -> Maybe LiftCoEnv -ty_co_match menv subst ty co lkco rkco - | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco - - -- handle Refl case: - | tyCoVarsOfType ty `isNotInDomainOf` subst - , Just (ty', _) <- isReflCo_maybe co - , ty `eqType` ty' - = Just subst - - where - isNotInDomainOf :: VarSet -> VarEnv a -> Bool - isNotInDomainOf set env - = noneSet (\v -> elemVarEnv v env) set - - noneSet :: (Var -> Bool) -> VarSet -> Bool - noneSet f = allVarSet (not . f) - -ty_co_match menv subst ty co lkco rkco - | CastTy ty' co' <- ty - -- See Note [Matching in the presence of casts (1)] - = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) - substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' - substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' - in - ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) - (substed_co_r `mkTransCo` rkco) - - | SymCo co' <- co - = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco - - -- Match a type variable against a non-refl coercion -ty_co_match menv subst (TyVarTy tv1) co lkco rkco - | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 - = if eqCoercionX (nukeRnEnvL rn_env) co1' co - then Just subst - else Nothing -- no match since tv1 matches two different coercions - - | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var - = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) - then Nothing -- occurs check failed - else Just $ extendVarEnv subst tv1' $ - castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco) - - | otherwise - = Nothing - - where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - - -- just look through SubCo's. We don't really care about roles here. -ty_co_match menv subst ty (SubCo co) lkco rkco - = ty_co_match menv subst ty co lkco rkco - -ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco - | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] -ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 - -- yes, the one from Type, not TcType; this is for coercion optimization - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] - -ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco - = ty_co_match_tc menv subst tc1 tys tc2 cos -ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco - -- Despite the fact that (->) is polymorphic in four type variables (two - -- runtime rep and two types), we shouldn't need to explicitly unify the - -- runtime reps here; unifying the types themselves should be sufficient. - -- See Note [Representation of function types]. - | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co - , tc == funTyCon - = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] - in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos - -ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) - (ForAllCo tv2 kind_co2 co2) - lkco rkco - | isTyVar tv1 && isTyVar tv2 - = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 - ki_ki_co ki_ki_co - ; let rn_env0 = me_env menv - rn_env1 = rnBndr2 rn_env0 tv1 tv2 - menv' = menv { me_env = rn_env1 } - ; ty_co_match menv' subst1 ty1 co2 lkco rkco } - where - ki_ki_co = mkNomReflCo liftedTypeKind - --- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) --- (ForAllCo cv2 kind_co2 co2) --- lkco rkco --- | isCoVar cv1 && isCoVar cv2 --- We seems not to have enough information for this case --- 1. Given: --- cv1 :: (s1 :: k1) ~r (s2 :: k2) --- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) --- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) --- :: s1' ~ t1 --- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) --- :: s2' ~ t2 --- Wanted: --- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 --- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 --- Question: How do we get kcoi? --- 2. Given: --- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in Type --- rkco :: <*> --- Wanted: --- ty_co_match menv' subst2 ty1 co2 lkco' rkco' --- Question: How do we get lkco' and rkco'? - -ty_co_match _ subst (CoercionTy {}) _ _ _ - = Just subst -- don't inspect coercions - -ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco - = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) - -ty_co_match menv subst ty co1 lkco rkco - | Just (CastTy t co, r) <- isReflCo_maybe co1 - -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us - -- t |> co ~ t ; ; t ~ t |> co - -- But transitive coercions are not helpful. Therefore we deal - -- with it here: we do recursion on the smaller reflexive coercion, - -- while propagating the correct kind coercions. - = let kco' = mkSymCo co - in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') - (rkco `mkTransCo` kco') - - -ty_co_match menv subst ty co lkco rkco - | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco - | otherwise = Nothing - -ty_co_match_tc :: MatchEnv -> LiftCoEnv - -> TyCon -> [Type] - -> TyCon -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_tc menv subst tc1 tys1 tc2 cos2 - = do { guard (tc1 == tc2) - ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } - where - Pair lkcos rkcos - = traverse (fmap mkNomReflCo . coercionKind) cos2 - -ty_co_match_app :: MatchEnv -> LiftCoEnv - -> Type -> [Type] -> Coercion -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_app menv subst ty1 ty1args co2 co2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (co2', co2a) <- splitAppCo_maybe co2 - = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) - - | otherwise - = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co - ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 - ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco - ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args - ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } - where - ki1 = typeKind ty1 - ki2 = promoteCoercion co2 - ki_ki_co = mkNomReflCo liftedTypeKind - -ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] - -> [Coercion] -> [Coercion] -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_args _ subst [] [] _ _ = Just subst -ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) - = do { subst' <- ty_co_match menv subst ty arg lkco rkco - ; ty_co_match_args menv subst' tys args lkcos rkcos } -ty_co_match_args _ _ _ _ _ _ = Nothing - -pushRefl :: Coercion -> Maybe Coercion -pushRefl co = - case (isReflCo_maybe co) of - Just (AppTy ty1 ty2, Nominal) - -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) - Just (FunTy _ ty1 ty2, r) - | Just rep1 <- getRuntimeRep_maybe ty1 - , Just rep2 <- getRuntimeRep_maybe ty2 - -> Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 - , mkReflCo r ty1, mkReflCo r ty2 ]) - Just (TyConApp tc tys, r) - -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) - Just (ForAllTy (Bndr tv _) ty, r) - -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) - -- NB: NoRefl variant. Otherwise, we get a loop! - _ -> Nothing diff --git a/utils/AsmUtils.hs b/utils/AsmUtils.hs deleted file mode 100644 --- a/utils/AsmUtils.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Various utilities used in generating assembler. --- --- These are used not only by the native code generator, but also by the --- "DriverPipeline". -module AsmUtils - ( sectionType - ) where - -import GhcPrelude - -import GHC.Platform -import Outputable - --- | Generate a section type (e.g. @\@progbits@). See #13937. -sectionType :: String -- ^ section type - -> SDoc -- ^ pretty assembler fragment -sectionType ty = sdocWithPlatform $ \platform -> - case platformArch platform of - ArchARM{} -> char '%' <> text ty - _ -> char '@' <> text ty diff --git a/utils/Bag.hs b/utils/Bag.hs deleted file mode 100644 --- a/utils/Bag.hs +++ /dev/null @@ -1,335 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Bag: an unordered collection with duplicates --} - -{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor #-} - -module Bag ( - Bag, -- abstract type - - emptyBag, unitBag, unionBags, unionManyBags, - mapBag, - elemBag, lengthBag, - filterBag, partitionBag, partitionBagWith, - concatBag, catBagMaybes, foldBag, - isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, - listToBag, bagToList, mapAccumBagL, - concatMapBag, concatMapBagPair, mapMaybeBag, - mapBagM, mapBagM_, - flatMapBagM, flatMapBagPairM, - mapAndUnzipBagM, mapAccumBagLM, - anyBagM, filterBagM - ) where - -import GhcPrelude - -import Outputable -import Util - -import MonadUtils -import Control.Monad -import Data.Data -import Data.Maybe( mapMaybe ) -import Data.List ( partition, mapAccumL ) -import qualified Data.Foldable as Foldable - -infixr 3 `consBag` -infixl 3 `snocBag` - -data Bag a - = EmptyBag - | UnitBag a - | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty - | ListBag [a] -- INVARIANT: the list is non-empty - deriving (Functor) - -emptyBag :: Bag a -emptyBag = EmptyBag - -unitBag :: a -> Bag a -unitBag = UnitBag - -lengthBag :: Bag a -> Int -lengthBag EmptyBag = 0 -lengthBag (UnitBag {}) = 1 -lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 -lengthBag (ListBag xs) = length xs - -elemBag :: Eq a => a -> Bag a -> Bool -elemBag _ EmptyBag = False -elemBag x (UnitBag y) = x == y -elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 -elemBag x (ListBag ys) = any (x ==) ys - -unionManyBags :: [Bag a] -> Bag a -unionManyBags xs = foldr unionBags EmptyBag xs - --- This one is a bit stricter! The bag will get completely evaluated. - -unionBags :: Bag a -> Bag a -> Bag a -unionBags EmptyBag b = b -unionBags b EmptyBag = b -unionBags b1 b2 = TwoBags b1 b2 - -consBag :: a -> Bag a -> Bag a -snocBag :: Bag a -> a -> Bag a - -consBag elt bag = (unitBag elt) `unionBags` bag -snocBag bag elt = bag `unionBags` (unitBag elt) - -isEmptyBag :: Bag a -> Bool -isEmptyBag EmptyBag = True -isEmptyBag _ = False -- NB invariants - -isSingletonBag :: Bag a -> Bool -isSingletonBag EmptyBag = False -isSingletonBag (UnitBag _) = True -isSingletonBag (TwoBags _ _) = False -- Neither is empty -isSingletonBag (ListBag xs) = isSingleton xs - -filterBag :: (a -> Bool) -> Bag a -> Bag a -filterBag _ EmptyBag = EmptyBag -filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag -filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 - where sat1 = filterBag pred b1 - sat2 = filterBag pred b2 -filterBag pred (ListBag vs) = listToBag (filter pred vs) - -filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) -filterBagM _ EmptyBag = return EmptyBag -filterBagM pred b@(UnitBag val) = do - flag <- pred val - if flag then return b - else return EmptyBag -filterBagM pred (TwoBags b1 b2) = do - sat1 <- filterBagM pred b1 - sat2 <- filterBagM pred b2 - return (sat1 `unionBags` sat2) -filterBagM pred (ListBag vs) = do - sat <- filterM pred vs - return (listToBag sat) - -allBag :: (a -> Bool) -> Bag a -> Bool -allBag _ EmptyBag = True -allBag p (UnitBag v) = p v -allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 -allBag p (ListBag xs) = all p xs - -anyBag :: (a -> Bool) -> Bag a -> Bool -anyBag _ EmptyBag = False -anyBag p (UnitBag v) = p v -anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 -anyBag p (ListBag xs) = any p xs - -anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool -anyBagM _ EmptyBag = return False -anyBagM p (UnitBag v) = p v -anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 - if flag then return True - else anyBagM p b2 -anyBagM p (ListBag xs) = anyM p xs - -concatBag :: Bag (Bag a) -> Bag a -concatBag bss = foldr add emptyBag bss - where - add bs rs = bs `unionBags` rs - -catBagMaybes :: Bag (Maybe a) -> Bag a -catBagMaybes bs = foldr add emptyBag bs - where - add Nothing rs = rs - add (Just x) rs = x `consBag` rs - -partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, - Bag a {- Don't -}) -partitionBag _ EmptyBag = (EmptyBag, EmptyBag) -partitionBag pred b@(UnitBag val) - = if pred val then (b, EmptyBag) else (EmptyBag, b) -partitionBag pred (TwoBags b1 b2) - = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) - where (sat1, fail1) = partitionBag pred b1 - (sat2, fail2) = partitionBag pred b2 -partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partition pred vs - - -partitionBagWith :: (a -> Either b c) -> Bag a - -> (Bag b {- Left -}, - Bag c {- Right -}) -partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) -partitionBagWith pred (UnitBag val) - = case pred val of - Left a -> (UnitBag a, EmptyBag) - Right b -> (EmptyBag, UnitBag b) -partitionBagWith pred (TwoBags b1 b2) - = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) - where (sat1, fail1) = partitionBagWith pred b1 - (sat2, fail2) = partitionBagWith pred b2 -partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partitionWith pred vs - -foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative - -> (a -> r) -- Replace UnitBag with this - -> r -- Replace EmptyBag with this - -> Bag a - -> r - -{- Standard definition -foldBag t u e EmptyBag = e -foldBag t u e (UnitBag x) = u x -foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) -foldBag t u e (ListBag xs) = foldr (t.u) e xs --} - --- More tail-recursive definition, exploiting associativity of "t" -foldBag _ _ e EmptyBag = e -foldBag t u e (UnitBag x) = u x `t` e -foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 -foldBag t u e (ListBag xs) = foldr (t.u) e xs - -mapBag :: (a -> b) -> Bag a -> Bag b -mapBag = fmap - -concatMapBag :: (a -> Bag b) -> Bag a -> Bag b -concatMapBag _ EmptyBag = EmptyBag -concatMapBag f (UnitBag x) = f x -concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) -concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs - -concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) -concatMapBagPair _ EmptyBag = (EmptyBag, EmptyBag) -concatMapBagPair f (UnitBag x) = f x -concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2) - where - (r1, s1) = concatMapBagPair f b1 - (r2, s2) = concatMapBagPair f b2 -concatMapBagPair f (ListBag xs) = foldr go (emptyBag, emptyBag) xs - where - go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2) - where - (r1, r2) = f a - -mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b -mapMaybeBag _ EmptyBag = EmptyBag -mapMaybeBag f (UnitBag x) = case f x of - Nothing -> EmptyBag - Just y -> UnitBag y -mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) -mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) - -mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) -mapBagM _ EmptyBag = return EmptyBag -mapBagM f (UnitBag x) = do r <- f x - return (UnitBag r) -mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 - r2 <- mapBagM f b2 - return (TwoBags r1 r2) -mapBagM f (ListBag xs) = do rs <- mapM f xs - return (ListBag rs) - -mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () -mapBagM_ _ EmptyBag = return () -mapBagM_ f (UnitBag x) = f x >> return () -mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 -mapBagM_ f (ListBag xs) = mapM_ f xs - -flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) -flatMapBagM _ EmptyBag = return EmptyBag -flatMapBagM f (UnitBag x) = f x -flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 - r2 <- flatMapBagM f b2 - return (r1 `unionBags` r2) -flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs - where - k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } - -flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) -flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) -flatMapBagPairM f (UnitBag x) = f x -flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 - (r2,s2) <- flatMapBagPairM f b2 - return (r1 `unionBags` r2, s1 `unionBags` s2) -flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs - where - k x (r2,s2) = do { (r1,s1) <- f x - ; return (r1 `unionBags` r2, s1 `unionBags` s2) } - -mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) -mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) -mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x - return (UnitBag r, UnitBag s) -mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 - (r2,s2) <- mapAndUnzipBagM f b2 - return (TwoBags r1 r2, TwoBags s1 s2) -mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs - let (rs,ss) = unzip ts - return (ListBag rs, ListBag ss) - -mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function - -> acc -- ^ initial state - -> Bag x -- ^ inputs - -> (acc, Bag y) -- ^ final state, outputs -mapAccumBagL _ s EmptyBag = (s, EmptyBag) -mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) -mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 - (s2, b2') = mapAccumBagL f s1 b2 - in (s2, TwoBags b1' b2') -mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs - in (s', ListBag xs') - -mapAccumBagLM :: Monad m - => (acc -> x -> m (acc, y)) -- ^ combining function - -> acc -- ^ initial state - -> Bag x -- ^ inputs - -> m (acc, Bag y) -- ^ final state, outputs -mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) -mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } -mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 - ; (s2, b2') <- mapAccumBagLM f s1 b2 - ; return (s2, TwoBags b1' b2') } -mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs - ; return (s', ListBag xs') } - -listToBag :: [a] -> Bag a -listToBag [] = EmptyBag -listToBag [x] = UnitBag x -listToBag vs = ListBag vs - -bagToList :: Bag a -> [a] -bagToList b = foldr (:) [] b - -instance (Outputable a) => Outputable (Bag a) where - ppr bag = braces (pprWithCommas ppr (bagToList bag)) - -instance Data a => Data (Bag a) where - gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly - toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Bag" - dataCast1 x = gcast1 x - -instance Foldable.Foldable Bag where - foldr _ z EmptyBag = z - foldr k z (UnitBag x) = k x z - foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 - foldr k z (ListBag xs) = foldr k z xs - - foldl _ z EmptyBag = z - foldl k z (UnitBag x) = k z x - foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 - foldl k z (ListBag xs) = foldl k z xs - - foldl' _ z EmptyBag = z - foldl' k z (UnitBag x) = k z x - foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 - foldl' k z (ListBag xs) = foldl' k z xs - -instance Traversable Bag where - traverse _ EmptyBag = pure EmptyBag - traverse f (UnitBag x) = UnitBag <$> f x - traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 - traverse f (ListBag xs) = ListBag <$> traverse f xs diff --git a/utils/Binary.hs b/utils/Binary.hs deleted file mode 100644 --- a/utils/Binary.hs +++ /dev/null @@ -1,1422 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BangPatterns #-} - -{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- --- (c) The University of Glasgow 2002-2006 --- --- Binary I/O library, with special tweaks for GHC --- --- Based on the nhc98 Binary library, which is copyright --- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. --- Under the terms of the license for that software, we must tell you --- where you can obtain the original version of the Binary library, namely --- http://www.cs.york.ac.uk/fp/nhc98/ - -module Binary - ( {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - SymbolTable, Dictionary, - - openBinMem, --- closeBin, - - seekBin, - seekBy, - tellBin, - castBin, - isEOFBin, - withBinBuffer, - - writeBinMem, - readBinMem, - - putAt, getAt, - - -- * For writing instances - putByte, - getByte, - - -- * Variable length encodings - putULEB128, - getULEB128, - putSLEB128, - getSLEB128, - - -- * Lazy Binary I/O - lazyGet, - lazyPut, - - -- * User data - UserData(..), getUserData, setUserData, - newReadState, newWriteState, - putDictionary, getDictionary, putFS, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Name (Name) -import FastString -import PlainPanic -import UniqFM -import FastMutInt -import Fingerprint -import BasicTypes -import SrcLoc - -import Foreign -import Data.Array -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Data.IORef -import Data.Char ( ord, chr ) -import Data.Time -import Data.List (unfoldr) -import Type.Reflection -import Type.Reflection.Unsafe -import Data.Kind (Type) -import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) -import Control.Monad ( when, (<$!>), unless ) -import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import GHC.Serialized - -type BinArray = ForeignPtr Word8 - ---------------------------------------------------------------- --- BinHandle ---------------------------------------------------------------- - -data BinHandle - = BinMem { -- binary data stored in an unboxed array - bh_usr :: UserData, -- sigh, need parameterized modules :-) - _off_r :: !FastMutInt, -- the current offset - _sz_r :: !FastMutInt, -- size of the array (cached) - _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -- XXX: should really store a "high water mark" for dumping out - -- the binary data to a file. - -getUserData :: BinHandle -> UserData -getUserData bh = bh_usr bh - -setUserData :: BinHandle -> UserData -> BinHandle -setUserData bh us = bh { bh_usr = us } - --- | Get access to the underlying buffer. --- --- It is quite important that no references to the 'ByteString' leak out of the --- continuation lest terrible things happen. -withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a -withBinBuffer (BinMem _ ix_r _ arr_r) action = do - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \ptr -> - BS.unsafePackCStringLen (castPtr ptr, ix) >>= action - - ---------------------------------------------------------------- --- Bin ---------------------------------------------------------------- - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i - ---------------------------------------------------------------- --- class Binary ---------------------------------------------------------------- - --- | Do not rely on instance sizes for general types, --- we use variable length encoding for many of them. -class Binary a where - put_ :: BinHandle -> a -> IO () - put :: BinHandle -> a -> IO (Bin a) - get :: BinHandle -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do _ <- put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - -putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put_ bh x; return () - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- mallocForeignPtrBytes size - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r size - return (BinMem noUserData ix_r sz_r arr_r) - -tellBin :: BinHandle -> IO (Bin a) -tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -seekBin :: BinHandle -> Bin a -> IO () -seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do - sz <- readFastMutInt sz_r - if (p >= sz) - then do expandBin h p; writeFastMutInt ix_r p - else writeFastMutInt ix_r p - -seekBy :: BinHandle -> Int -> IO () -seekBy h@(BinMem _ ix_r sz_r _) !off = do - sz <- readFastMutInt sz_r - ix <- readFastMutInt ix_r - let ix' = ix + off - if (ix' >= sz) - then do expandBin h ix'; writeFastMutInt ix_r ix' - else writeFastMutInt ix_r ix' - -isEOFBin :: BinHandle -> IO Bool -isEOFBin (BinMem _ ix_r sz_r _) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - return (ix >= sz) - -writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinMem _ ix_r _ arr_r) fn = do - h <- openBinaryFile fn WriteMode - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \p -> hPutBuf h p ix - hClose h - -readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State -readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - arr <- mallocForeignPtrBytes filesize - count <- withForeignPtr arr $ \p -> hGetBuf h p filesize - when (count /= filesize) $ - error ("Binary.readBinMem: only read " ++ show count ++ " bytes") - hClose h - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r filesize - return (BinMem noUserData ix_r sz_r arr_r) - --- expand the size of the array to include a specified offset -expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem _ _ sz_r arr_r) !off = do - !sz <- readFastMutInt sz_r - let !sz' = getSize sz - arr <- readIORef arr_r - arr' <- mallocForeignPtrBytes sz' - withForeignPtr arr $ \old -> - withForeignPtr arr' $ \new -> - copyBytes new old sz - writeFastMutInt sz_r sz' - writeIORef arr_r arr' - where - getSize :: Int -> Int - getSize !sz - | sz > off - = sz - | otherwise - = getSize (sz * 2) - --- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - --- | Takes a size and action writing up to @size@ bytes. --- After the action has run advance the index to the buffer --- by size bytes. -putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () -putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - expandBin h (ix + size) - arr <- readIORef arr_r - withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - --- -- | Similar to putPrim but advances the index by the actual number of --- -- bytes written. --- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () --- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do --- ix <- readFastMutInt ix_r --- sz <- readFastMutInt sz_r --- when (ix + size > sz) $ --- expandBin h (ix + size) --- arr <- readIORef arr_r --- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) --- writeFastMutInt ix_r (ix + written) - -getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a -getPrim (BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) - arr <- readIORef arr_r - w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - return w - -putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h !w = putPrim h 1 (\op -> poke op w) - -getWord8 :: BinHandle -> IO Word8 -getWord8 h = getPrim h 1 peek - --- putWord16 :: BinHandle -> Word16 -> IO () --- putWord16 h w = putPrim h 2 (\op -> do --- pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) --- pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) --- ) - --- getWord16 :: BinHandle -> IO Word16 --- getWord16 h = getPrim h 2 (\op -> do --- w0 <- fromIntegral <$> peekElemOff op 0 --- w1 <- fromIntegral <$> peekElemOff op 1 --- return $! w0 `shiftL` 8 .|. w1 --- ) - -putWord32 :: BinHandle -> Word32 -> IO () -putWord32 h w = putPrim h 4 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) - ) - -getWord32 :: BinHandle -> IO Word32 -getWord32 h = getPrim h 4 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - - return $! (w0 `shiftL` 24) .|. - (w1 `shiftL` 16) .|. - (w2 `shiftL` 8) .|. - w3 - ) - --- putWord64 :: BinHandle -> Word64 -> IO () --- putWord64 h w = putPrim h 8 (\op -> do --- pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) --- pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) --- pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) --- pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) --- pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) --- pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) --- pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) --- pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) --- ) - --- getWord64 :: BinHandle -> IO Word64 --- getWord64 h = getPrim h 8 (\op -> do --- w0 <- fromIntegral <$> peekElemOff op 0 --- w1 <- fromIntegral <$> peekElemOff op 1 --- w2 <- fromIntegral <$> peekElemOff op 2 --- w3 <- fromIntegral <$> peekElemOff op 3 --- w4 <- fromIntegral <$> peekElemOff op 4 --- w5 <- fromIntegral <$> peekElemOff op 5 --- w6 <- fromIntegral <$> peekElemOff op 6 --- w7 <- fromIntegral <$> peekElemOff op 7 - --- return $! (w0 `shiftL` 56) .|. --- (w1 `shiftL` 48) .|. --- (w2 `shiftL` 40) .|. --- (w3 `shiftL` 32) .|. --- (w4 `shiftL` 24) .|. --- (w5 `shiftL` 16) .|. --- (w6 `shiftL` 8) .|. --- w7 --- ) - -putByte :: BinHandle -> Word8 -> IO () -putByte bh !w = putWord8 bh w - -getByte :: BinHandle -> IO Word8 -getByte h = getWord8 h - --- ----------------------------------------------------------------------------- --- Encode numbers in LEB128 encoding. --- Requires one byte of space per 7 bits of data. --- --- There are signed and unsigned variants. --- Do NOT use the unsigned one for signed values, at worst it will --- result in wrong results, at best it will lead to bad performance --- when coercing negative values to an unsigned type. --- --- We mark them as SPECIALIZE as it's extremely critical that they get specialized --- to their specific types. --- --- TODO: Each use of putByte performs a bounds check, --- we should use putPrimMax here. However it's quite hard to return --- the number of bytes written into putPrimMax without allocating an --- Int for it, while the code below does not allocate at all. --- So we eat the cost of the bounds check instead of increasing allocations --- for now. - --- Unsigned numbers -{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} -putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () -putULEB128 bh w = -#if defined(DEBUG) - (if w < 0 then panic "putULEB128: Signed number" else id) $ -#endif - go w - where - go :: a -> IO () - go w - | w <= (127 :: a) - = putByte bh (fromIntegral w :: Word8) - | otherwise = do - -- bit 7 (8th bit) indicates more to come. - let !byte = setBit (fromIntegral w) 7 :: Word8 - putByte bh byte - go (w `unsafeShiftR` 7) - -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} -getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a -getULEB128 bh = - go 0 0 - where - go :: Int -> a -> IO a - go shift w = do - b <- getByte bh - let !hasMore = testBit b 7 - let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a - if hasMore - then do - go (shift+7) val - else - return $! val - --- Signed numbers -{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} -putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () -putSLEB128 bh initial = go initial - where - go :: a -> IO () - go val = do - let !byte = fromIntegral (clearBit val 7) :: Word8 - let !val' = val `unsafeShiftR` 7 - let !signBit = testBit byte 6 - let !done = - -- Unsigned value, val' == 0 and and last value can - -- be discriminated from a negative number. - ((val' == 0 && not signBit) || - -- Signed value, - (val' == -1 && signBit)) - - let !byte' = if done then byte else setBit byte 7 - putByte bh byte' - - unless done $ go val' - -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} -getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a -getSLEB128 bh = do - (val,shift,signed) <- go 0 0 - if signed && (shift < finiteBitSize val ) - then return $! ((complement 0 `unsafeShiftL` shift) .|. val) - else return val - where - go :: Int -> a -> IO (a,Int,Bool) - go shift val = do - byte <- getByte bh - let !byteVal = fromIntegral (clearBit byte 7) :: a - let !val' = val .|. (byteVal `unsafeShiftL` shift) - let !more = testBit byte 7 - let !shift' = shift+7 - if more - then go (shift') val' - else do - let !signed = testBit byte 6 - return (val',shift',signed) - --- ----------------------------------------------------------------------------- --- Primitive Word writes - -instance Binary Word8 where - put_ bh !w = putWord8 bh w - get = getWord8 - -instance Binary Word16 where - put_ = putULEB128 - get = getULEB128 - -instance Binary Word32 where - put_ = putULEB128 - get = getULEB128 - -instance Binary Word64 where - put_ = putULEB128 - get = getULEB128 - --- ----------------------------------------------------------------------------- --- Primitive Int writes - -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - put_ = putSLEB128 - get = getSLEB128 - -instance Binary Int32 where - put_ = putSLEB128 - get = getSLEB128 - -instance Binary Int64 where - put_ h w = putSLEB128 h w - get h = getSLEB128 h - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - put_ _ () = return () - get _ = return () - -instance Binary Bool where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) - -instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) - -instance Binary Int where - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) - -instance Binary a => Binary [a] where - put_ bh l = do - let len = length l - put_ bh len - mapM_ (put_ bh) l - get bh = do - len <- get bh :: IO Int -- Int is variable length encoded so only - -- one byte for small lists. - let loop 0 = return [] - loop n = do a <- get bh; as <- loop (n-1); return (a:as) - loop len - -instance (Ix a, Binary a, Binary b) => Binary (Array a b) where - put_ bh arr = do - put_ bh $ bounds arr - put_ bh $ elems arr - get bh = do - bounds <- get bh - xs <- get bh - return $ listArray bounds xs - -instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where - put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - return (a,b,c,d,e) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where - put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where - put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - g <- get bh - return (a,b,c,d,e,f,g) - -instance Binary a => Binary (Maybe a) where - put_ bh Nothing = putByte bh 0 - put_ bh (Just a) = do putByte bh 1; put_ bh a - get bh = do h <- getWord8 bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) - -instance (Binary a, Binary b) => Binary (Either a b) where - put_ bh (Left a) = do putByte bh 0; put_ bh a - put_ bh (Right b) = do putByte bh 1; put_ bh b - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -instance Binary UTCTime where - put_ bh u = do put_ bh (utctDay u) - put_ bh (utctDayTime u) - get bh = do day <- get bh - dayTime <- get bh - return $ UTCTime { utctDay = day, utctDayTime = dayTime } - -instance Binary Day where - put_ bh d = put_ bh (toModifiedJulianDay d) - get bh = do i <- get bh - return $ ModifiedJulianDay { toModifiedJulianDay = i } - -instance Binary DiffTime where - put_ bh dt = put_ bh (toRational dt) - get bh = do r <- get bh - return $ fromRational r - -{- -Finally - a reasonable portable Integer instance. - -We used to encode values in the Int32 range as such, -falling back to a string of all things. In either case -we stored a tag byte to discriminate between the two cases. - -This made some sense as it's highly portable but also not very -efficient. - -However GHC stores a surprisingly large number off large Integer -values. In the examples looked at between 25% and 50% of Integers -serialized were outside of the Int32 range. - -Consider a valie like `2724268014499746065`, some sort of hash -actually generated by GHC. -In the old scheme this was encoded as a list of 19 chars. This -gave a size of 77 Bytes, one for the length of the list and 76 -since we encod chars as Word32 as well. - -We can easily do better. The new plan is: - -* Start with a tag byte - * 0 => Int64 (LEB128 encoded) - * 1 => Negative large interger - * 2 => Positive large integer -* Followed by the value: - * Int64 is encoded as usual - * Large integers are encoded as a list of bytes (Word8). - We use Data.Bits which defines a bit order independent of the representation. - Values are stored LSB first. - -This means our example value `2724268014499746065` is now only 10 bytes large. -* One byte tag -* One byte for the length of the [Word8] list. -* 8 bytes for the actual date. - -The new scheme also does not depend in any way on -architecture specific details. - -We still use this scheme even with LEB128 available, -as it has less overhead for truely large numbers. (> maxBound :: Int64) - -The instance is used for in Binary Integer and Binary Rational in basicTypes/Literal.hs --} - -instance Binary Integer where - put_ bh i - | i >= lo64 && i <= hi64 = do - putWord8 bh 0 - put_ bh (fromIntegral i :: Int64) - | otherwise = do - if i < 0 - then putWord8 bh 1 - else putWord8 bh 2 - put_ bh (unroll $ abs i) - where - lo64 = fromIntegral (minBound :: Int64) - hi64 = fromIntegral (maxBound :: Int64) - get bh = do - int_kind <- getWord8 bh - case int_kind of - 0 -> fromIntegral <$!> (get bh :: IO Int64) - -- Large integer - 1 -> negate <$!> getInt - 2 -> getInt - _ -> panic "Binary Integer - Invalid byte" - where - getInt :: IO Integer - getInt = roll <$!> (get bh :: IO [Word8]) - -unroll :: Integer -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldl' unstep 0 . reverse - where - unstep a b = a `shiftL` 8 .|. fromIntegral b - - - {- - -- This code is currently commented out. - -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for - -- discussion. - - put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) - put_ bh (J# s# a#) = do - putByte bh 1 - put_ bh (I# s#) - let sz# = sizeofByteArray# a# -- in *bytes* - put_ bh (I# sz#) -- in *bytes* - putByteArray bh a# sz# - - get bh = do - b <- getByte bh - case b of - 0 -> do (I# i#) <- get bh - return (S# i#) - _ -> do (I# s#) <- get bh - sz <- get bh - (BA a#) <- getByteArray bh sz - return (J# s# a#) - -putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () -putByteArray bh a s# = loop 0# - where loop n# - | n# ==# s# = return () - | otherwise = do - putByte bh (indexByteArray a n#) - loop (n# +# 1#) - -getByteArray :: BinHandle -> Int -> IO ByteArray -getByteArray bh (I# sz) = do - (MBA arr) <- newByteArray sz - let loop n - | n ==# sz = return () - | otherwise = do - w <- getByte bh - writeByteArray arr n w - loop (n +# 1#) - loop 0# - freezeByteArray arr - -} - -{- -data ByteArray = BA ByteArray# -data MBA = MBA (MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newByteArray# sz s of { (# s, arr #) -> - (# s, MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s, arr #) -> - (# s, BA arr #) } - -writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () -writeByteArray arr i (W8# w) = IO $ \s -> - case writeWord8Array# arr i w s of { s -> - (# s, () #) } - -indexByteArray :: ByteArray# -> Int# -> Word8 -indexByteArray a# n# = W8# (indexWord8Array# a# n#) - --} -instance (Binary a) => Binary (Ratio a) where - put_ bh (a :% b) = do put_ bh a; put_ bh b - get bh = do a <- get bh; b <- get bh; return (a :% b) - --- Instance uses fixed-width encoding to allow inserting --- Bin placeholders in the stream. -instance Binary (Bin a) where - put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) - get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) - --- ----------------------------------------------------------------------------- --- Instances for Data.Typeable stuff - -instance Binary TyCon where - put_ bh tc = do - put_ bh (tyConPackage tc) - put_ bh (tyConModule tc) - put_ bh (tyConName tc) - put_ bh (tyConKindArgs tc) - put_ bh (tyConKindRep tc) - get bh = - mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh - -instance Binary VecCount where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh - -instance Binary VecElem where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh - -instance Binary RuntimeRep where - put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b - put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps - put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps - put_ bh LiftedRep = putByte bh 3 - put_ bh UnliftedRep = putByte bh 4 - put_ bh IntRep = putByte bh 5 - put_ bh WordRep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh Word64Rep = putByte bh 8 - put_ bh AddrRep = putByte bh 9 - put_ bh FloatRep = putByte bh 10 - put_ bh DoubleRep = putByte bh 11 -#if __GLASGOW_HASKELL__ >= 807 - put_ bh Int8Rep = putByte bh 12 - put_ bh Word8Rep = putByte bh 13 - put_ bh Int16Rep = putByte bh 14 - put_ bh Word16Rep = putByte bh 15 -#endif -#if __GLASGOW_HASKELL__ >= 809 - put_ bh Int32Rep = putByte bh 16 - put_ bh Word32Rep = putByte bh 17 -#endif - - get bh = do - tag <- getByte bh - case tag of - 0 -> VecRep <$> get bh <*> get bh - 1 -> TupleRep <$> get bh - 2 -> SumRep <$> get bh - 3 -> pure LiftedRep - 4 -> pure UnliftedRep - 5 -> pure IntRep - 6 -> pure WordRep - 7 -> pure Int64Rep - 8 -> pure Word64Rep - 9 -> pure AddrRep - 10 -> pure FloatRep - 11 -> pure DoubleRep -#if __GLASGOW_HASKELL__ >= 807 - 12 -> pure Int8Rep - 13 -> pure Word8Rep - 14 -> pure Int16Rep - 15 -> pure Word16Rep -#endif -#if __GLASGOW_HASKELL__ >= 809 - 16 -> pure Int32Rep - 17 -> pure Word32Rep -#endif - _ -> fail "Binary.putRuntimeRep: invalid tag" - -instance Binary KindRep where - put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k - put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr - put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b - put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b - put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r - put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r - - get bh = do - tag <- getByte bh - case tag of - 0 -> KindRepTyConApp <$> get bh <*> get bh - 1 -> KindRepVar <$> get bh - 2 -> KindRepApp <$> get bh <*> get bh - 3 -> KindRepFun <$> get bh <*> get bh - 4 -> KindRepTYPE <$> get bh - 5 -> KindRepTypeLit <$> get bh <*> get bh - _ -> fail "Binary.putKindRep: invalid tag" - -instance Binary TypeLitSort where - put_ bh TypeLitSymbol = putByte bh 0 - put_ bh TypeLitNat = putByte bh 1 - get bh = do - tag <- getByte bh - case tag of - 0 -> pure TypeLitSymbol - 1 -> pure TypeLitNat - _ -> fail "Binary.putTypeLitSort: invalid tag" - -putTypeRep :: BinHandle -> TypeRep a -> IO () --- Special handling for TYPE, (->), and RuntimeRep due to recursive kind --- relations. --- See Note [Mutually recursive representations of primitive types] -putTypeRep bh rep - | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) - = put_ bh (0 :: Word8) -putTypeRep bh (Con' con ks) = do - put_ bh (1 :: Word8) - put_ bh con - put_ bh ks -putTypeRep bh (App f x) = do - put_ bh (2 :: Word8) - putTypeRep bh f - putTypeRep bh x -putTypeRep bh (Fun arg res) = do - put_ bh (3 :: Word8) - putTypeRep bh arg - putTypeRep bh res - -getSomeTypeRep :: BinHandle -> IO SomeTypeRep -getSomeTypeRep bh = do - tag <- get bh :: IO Word8 - case tag of - 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) - 1 -> do con <- get bh :: IO TyCon - ks <- get bh :: IO [SomeTypeRep] - return $ SomeTypeRep $ mkTrCon con ks - - 2 -> do SomeTypeRep f <- getSomeTypeRep bh - SomeTypeRep x <- getSomeTypeRep bh - case typeRepKind f of - Fun arg res -> - case arg `eqTypeRep` typeRepKind x of - Just HRefl -> - case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of - Just HRefl -> return $ SomeTypeRep $ mkTrApp f x - _ -> failure "Kind mismatch in type application" [] - _ -> failure "Kind mismatch in type application" - [ " Found argument of kind: " ++ show (typeRepKind x) - , " Where the constructor: " ++ show f - , " Expects kind: " ++ show arg - ] - _ -> failure "Applied non-arrow" - [ " Applied type: " ++ show f - , " To argument: " ++ show x - ] - 3 -> do SomeTypeRep arg <- getSomeTypeRep bh - SomeTypeRep res <- getSomeTypeRep bh - if - | App argkcon _ <- typeRepKind arg - , App reskcon _ <- typeRepKind res - , Just HRefl <- argkcon `eqTypeRep` tYPErep - , Just HRefl <- reskcon `eqTypeRep` tYPErep - -> return $ SomeTypeRep $ Fun arg res - | otherwise -> failure "Kind mismatch" [] - _ -> failure "Invalid SomeTypeRep" [] - where - tYPErep :: TypeRep TYPE - tYPErep = typeRep - - failure description info = - fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] - ++ map (" "++) info - -instance Typeable a => Binary (TypeRep (a :: k)) where - put_ = putTypeRep - get bh = do - SomeTypeRep rep <- getSomeTypeRep bh - case rep `eqTypeRep` expected of - Just HRefl -> pure rep - Nothing -> fail $ unlines - [ "Binary: Type mismatch" - , " Deserialized type: " ++ show rep - , " Expected type: " ++ show expected - ] - where expected = typeRep :: TypeRep a - -instance Binary SomeTypeRep where - put_ bh (SomeTypeRep rep) = putTypeRep bh rep - get = getSomeTypeRep - --- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyPut :: Binary a => BinHandle -> a -> IO () -lazyPut bh a = do - -- output the obj with a ptr to skip over it: - pre_a <- tellBin bh - put_ bh pre_a -- save a slot for the ptr - put_ bh a -- dump the object - q <- tellBin bh -- q = ptr to after object - putAt bh pre_a q -- fill in slot before a with ptr to q - seekBin bh q -- finally carry on writing at q - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO $ do - -- NB: Use a fresh off_r variable in the child thread, for thread - -- safety. - off_r <- newFastMutInt - getAt bh { _off_r = off_r } p_a - seekBin bh p -- skip over the object for now - return a - --- ----------------------------------------------------------------------------- --- UserData --- ----------------------------------------------------------------------------- - --- | Information we keep around during interface file --- serialization/deserialization. Namely we keep the functions for serializing --- and deserializing 'Name's and 'FastString's. We do this because we actually --- use serialization in two distinct settings, --- --- * When serializing interface files themselves --- --- * When computing the fingerprint of an IfaceDecl (which we computing by --- hashing its Binary serialization) --- --- These two settings have different needs while serializing Names: --- --- * Names in interface files are serialized via a symbol table (see Note --- [Symbol table representation of names] in BinIface). --- --- * During fingerprinting a binding Name is serialized as the OccName and a --- non-binding Name is serialized as the fingerprint of the thing they --- represent. See Note [Fingerprinting IfaceDecls] for further discussion. --- -data UserData = - UserData { - -- for *deserialising* only: - ud_get_name :: BinHandle -> IO Name, - ud_get_fs :: BinHandle -> IO FastString, - - -- for *serialising* only: - ud_put_nonbinding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a non-binding 'Name' (e.g. a reference to another - -- binding). - ud_put_binding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) - ud_put_fs :: BinHandle -> FastString -> IO () - } - -newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's - -> (BinHandle -> IO FastString) - -> UserData -newReadState get_name get_fs - = UserData { ud_get_name = get_name, - ud_get_fs = get_fs, - ud_put_nonbinding_name = undef "put_nonbinding_name", - ud_put_binding_name = undef "put_binding_name", - ud_put_fs = undef "put_fs" - } - -newWriteState :: (BinHandle -> Name -> IO ()) - -- ^ how to serialize non-binding 'Name's - -> (BinHandle -> Name -> IO ()) - -- ^ how to serialize binding 'Name's - -> (BinHandle -> FastString -> IO ()) - -> UserData -newWriteState put_nonbinding_name put_binding_name put_fs - = UserData { ud_get_name = undef "get_name", - ud_get_fs = undef "get_fs", - ud_put_nonbinding_name = put_nonbinding_name, - ud_put_binding_name = put_binding_name, - ud_put_fs = put_fs - } - -noUserData :: a -noUserData = undef "UserData" - -undef :: String -> a -undef s = panic ("Binary.UserData: no " ++ s) - ---------------------------------------------------------- --- The Dictionary ---------------------------------------------------------- - -type Dictionary = Array Int FastString -- The dictionary - -- Should be 0-indexed - -putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () -putDictionary bh sz dict = do - put_ bh sz - mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) - -- It's OK to use nonDetEltsUFM here because the elements have indices - -- that array uses to create order - -getDictionary :: BinHandle -> IO Dictionary -getDictionary bh = do - sz <- get bh - elems <- sequence (take sz (repeat (getFS bh))) - return (listArray (0,sz-1) elems) - ---------------------------------------------------------- --- The Symbol Table ---------------------------------------------------------- - --- On disk, the symbol table is an array of IfExtName, when --- reading it in we turn it into a SymbolTable. - -type SymbolTable = Array Int Name - ---------------------------------------------------------- --- Reading and writing FastStrings ---------------------------------------------------------- - -putFS :: BinHandle -> FastString -> IO () -putFS bh fs = putBS bh $ bytesFS fs - -getFS :: BinHandle -> IO FastString -getFS bh = do - l <- get bh :: IO Int - getPrim bh l (\src -> pure $! mkFastStringBytes src l ) - -putBS :: BinHandle -> ByteString -> IO () -putBS bh bs = - BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do - put_ bh l - putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) - -getBS :: BinHandle -> IO ByteString -getBS bh = do - l <- get bh :: IO Int - BS.create l $ \dest -> do - getPrim bh l (\src -> BS.memcpy dest src l) - -instance Binary ByteString where - put_ bh f = putBS bh f - get bh = getBS bh - -instance Binary FastString where - put_ bh f = - case getUserData bh of - UserData { ud_put_fs = put_fs } -> put_fs bh f - - get bh = - case getUserData bh of - UserData { ud_get_fs = get_fs } -> get_fs bh - --- Here to avoid loop -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -instance Binary PromotionFlag where - put_ bh NotPromoted = putByte bh 0 - put_ bh IsPromoted = putByte bh 1 - - get bh = do - n <- getByte bh - case n of - 0 -> return NotPromoted - 1 -> return IsPromoted - _ -> fail "Binary(IsPromoted): fail)" - -instance Binary Fingerprint where - put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 - get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) - -instance Binary FunctionOrData where - put_ bh IsFunction = putByte bh 0 - put_ bh IsData = putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> return IsFunction - 1 -> return IsData - _ -> panic "Binary FunctionOrData" - -instance Binary TupleSort where - put_ bh BoxedTuple = putByte bh 0 - put_ bh UnboxedTuple = putByte bh 1 - put_ bh ConstraintTuple = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return BoxedTuple - 1 -> do return UnboxedTuple - _ -> do return ConstraintTuple - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore src aa) = do - putByte bh 2 - put_ bh src - put_ bh aa - put_ bh (ActiveAfter src ab) = do - putByte bh 3 - put_ bh src - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do src <- get bh - aa <- get bh - return (ActiveBefore src aa) - _ -> do src <- get bh - ab <- get bh - return (ActiveAfter src ab) - -instance Binary InlinePragma where - put_ bh (InlinePragma s a b c d) = do - put_ bh s - put_ bh a - put_ bh b - put_ bh c - put_ bh d - - get bh = do - s <- get bh - a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (InlinePragma s a b c d) - -instance Binary RuleMatchInfo where - put_ bh FunLike = putByte bh 0 - put_ bh ConLike = putByte bh 1 - get bh = do - h <- getByte bh - if h == 1 then return ConLike - else return FunLike - -instance Binary InlineSpec where - put_ bh NoUserInline = putByte bh 0 - put_ bh Inline = putByte bh 1 - put_ bh Inlinable = putByte bh 2 - put_ bh NoInline = putByte bh 3 - - get bh = do h <- getByte bh - case h of - 0 -> return NoUserInline - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline - -instance Binary RecFlag where - put_ bh Recursive = do - putByte bh 0 - put_ bh NonRecursive = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Recursive - _ -> do return NonRecursive - -instance Binary OverlapMode where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - _ -> panic ("get OverlapMode" ++ show h) - - -instance Binary OverlapFlag where - put_ bh flag = do put_ bh (overlapMode flag) - put_ bh (isSafeOverlap flag) - get bh = do - h <- get bh - b <- get bh - return OverlapFlag { overlapMode = h, isSafeOverlap = b } - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity src aa ab) = do - put_ bh src - put_ bh aa - put_ bh ab - get bh = do - src <- get bh - aa <- get bh - ab <- get bh - return (Fixity src aa ab) - -instance Binary WarningTxt where - put_ bh (WarningTxt s w) = do - putByte bh 0 - put_ bh s - put_ bh w - put_ bh (DeprecatedTxt s d) = do - putByte bh 1 - put_ bh s - put_ bh d - - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - w <- get bh - return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh - return (DeprecatedTxt s d) - -instance Binary StringLiteral where - put_ bh (StringLiteral st fs) = do - put_ bh st - put_ bh fs - get bh = do - st <- get bh - fs <- get bh - return (StringLiteral st fs) - -instance Binary a => Binary (Located a) where - put_ bh (L l x) = do - put_ bh l - put_ bh x - - get bh = do - l <- get bh - x <- get bh - return (L l x) - -instance Binary RealSrcSpan where - put_ bh ss = do - put_ bh (srcSpanFile ss) - put_ bh (srcSpanStartLine ss) - put_ bh (srcSpanStartCol ss) - put_ bh (srcSpanEndLine ss) - put_ bh (srcSpanEndCol ss) - - get bh = do - f <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh - return (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) - -instance Binary SrcSpan where - put_ bh (RealSrcSpan ss) = do - putByte bh 0 - put_ bh ss - - put_ bh (UnhelpfulSpan s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> do ss <- get bh - return (RealSrcSpan ss) - _ -> do s <- get bh - return (UnhelpfulSpan s) - -instance Binary Serialized where - put_ bh (Serialized the_type bytes) = do - put_ bh the_type - put_ bh bytes - get bh = do - the_type <- get bh - bytes <- get bh - return (Serialized the_type bytes) - -instance Binary SourceText where - put_ bh NoSourceText = putByte bh 0 - put_ bh (SourceText s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return NoSourceText - 1 -> do - s <- get bh - return (SourceText s) - _ -> panic $ "Binary SourceText:" ++ show h diff --git a/utils/BooleanFormula.hs b/utils/BooleanFormula.hs deleted file mode 100644 --- a/utils/BooleanFormula.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, - DeriveTraversable #-} - --------------------------------------------------------------------------------- --- | Boolean formulas without quantifiers and without negation. --- Such a formula consists of variables, conjunctions (and), and disjunctions (or). --- --- This module is used to represent minimal complete definitions for classes. --- -module BooleanFormula ( - BooleanFormula(..), LBooleanFormula, - mkFalse, mkTrue, mkAnd, mkOr, mkVar, - isFalse, isTrue, - eval, simplify, isUnsatisfied, - implies, impliesAtom, - pprBooleanFormula, pprBooleanFormulaNice - ) where - -import GhcPrelude - -import Data.List ( nub, intersperse ) -import Data.Data - -import MonadUtils -import Outputable -import Binary -import SrcLoc -import Unique -import UniqSet - ----------------------------------------------------------------------- --- Boolean formula type and smart constructors ----------------------------------------------------------------------- - -type LBooleanFormula a = Located (BooleanFormula a) - -data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] - | Parens (LBooleanFormula a) - deriving (Eq, Data, Functor, Foldable, Traversable) - -mkVar :: a -> BooleanFormula a -mkVar = Var - -mkFalse, mkTrue :: BooleanFormula a -mkFalse = Or [] -mkTrue = And [] - --- Convert a Bool to a BooleanFormula -mkBool :: Bool -> BooleanFormula a -mkBool False = mkFalse -mkBool True = mkTrue - --- Make a conjunction, and try to simplify -mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd - where - -- See Note [Simplification of BooleanFormulas] - fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] - fromAnd (L _ (And xs)) = Just xs - -- assume that xs are already simplified - -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs - fromAnd (L _ (Or [])) = Nothing - -- in case of False we bail out, And [..,mkFalse,..] == mkFalse - fromAnd x = Just [x] - mkAnd' [x] = unLoc x - mkAnd' xs = And xs - -mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr - where - -- See Note [Simplification of BooleanFormulas] - fromOr (L _ (Or xs)) = Just xs - fromOr (L _ (And [])) = Nothing - fromOr x = Just [x] - mkOr' [x] = unLoc x - mkOr' xs = Or xs - - -{- -Note [Simplification of BooleanFormulas] -~~~~~~~~~~~~~~~~~~~~~~ -The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, - 1. Collapsing nested ands and ors, so - `(mkAnd [x, And [y,z]]` - is represented as - `And [x,y,z]` - Implemented by `fromAnd`/`fromOr` - 2. Collapsing trivial ands and ors, so - `mkAnd [x]` becomes just `x`. - Implemented by mkAnd' / mkOr' - 3. Conjunction with false, disjunction with true is simplified, i.e. - `mkAnd [mkFalse,x]` becomes `mkFalse`. - 4. Common subexpression elimination: - `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. - -This simplification is not exhaustive, in the sense that it will not produce -the smallest possible equivalent expression. For example, -`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently -is not. A general simplifier would need to use something like BDDs. - -The reason behind the (crude) simplifier is to make for more user friendly -error messages. E.g. for the code - > class Foo a where - > {-# MINIMAL bar, (foo, baq | foo, quux) #-} - > instance Foo Int where - > bar = ... - > baz = ... - > quux = ... -We don't show a ridiculous error message like - Implement () and (either (`foo' and ()) or (`foo' and ())) --} - ----------------------------------------------------------------------- --- Evaluation and simplification ----------------------------------------------------------------------- - -isFalse :: BooleanFormula a -> Bool -isFalse (Or []) = True -isFalse _ = False - -isTrue :: BooleanFormula a -> Bool -isTrue (And []) = True -isTrue _ = False - -eval :: (a -> Bool) -> BooleanFormula a -> Bool -eval f (Var x) = f x -eval f (And xs) = all (eval f . unLoc) xs -eval f (Or xs) = any (eval f . unLoc) xs -eval f (Parens x) = eval f (unLoc x) - --- Simplify a boolean formula. --- The argument function should give the truth of the atoms, or Nothing if undecided. -simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a -simplify f (Var a) = case f a of - Nothing -> Var a - Just b -> mkBool b -simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) -simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) -simplify f (Parens x) = simplify f (unLoc x) - --- Test if a boolean formula is satisfied when the given values are assigned to the atoms --- if it is, returns Nothing --- if it is not, return (Just remainder) -isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) -isUnsatisfied f bf - | isTrue bf' = Nothing - | otherwise = Just bf' - where - f' x = if f x then Just True else Nothing - bf' = simplify f' bf - --- prop_simplify: --- eval f x == True <==> isTrue (simplify (Just . f) x) --- eval f x == False <==> isFalse (simplify (Just . f) x) - --- If the boolean formula holds, does that mean that the given atom is always true? -impliesAtom :: Eq a => BooleanFormula a -> a -> Bool -Var x `impliesAtom` y = x == y -And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs - -- we have all of xs, so one of them implying y is enough -Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs -Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y - -implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool -implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) - where - go :: Uniquable a => Clause a -> Clause a -> Bool - go l@Clause{ clauseExprs = hyp:hyps } r = - case hyp of - Var x | memberClauseAtoms x r -> True - | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r - Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r - And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r - Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' - go l r@Clause{ clauseExprs = con:cons } = - case con of - Var x | memberClauseAtoms x l -> True - | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } - Parens con' -> go l r { clauseExprs = unLoc con':cons } - And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' - Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } - go _ _ = False - --- A small sequent calculus proof engine. -data Clause a = Clause { - clauseAtoms :: UniqSet a, - clauseExprs :: [BooleanFormula a] - } -extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a -extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } - -memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool -memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c - ----------------------------------------------------------------------- --- Pretty printing ----------------------------------------------------------------------- - --- Pretty print a BooleanFormula, --- using the arguments as pretty printers for Var, And and Or respectively -pprBooleanFormula' :: (Rational -> a -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> Rational -> BooleanFormula a -> SDoc -pprBooleanFormula' pprVar pprAnd pprOr = go - where - go p (Var x) = pprVar p x - go p (And []) = cparen (p > 0) $ empty - go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) - go _ (Or []) = keyword $ text "FALSE" - go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) - go p (Parens x) = go p (unLoc x) - --- Pretty print in source syntax, "a | b | c,d,e" -pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc -pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr - where - pprAnd p = cparen (p > 3) . fsep . punctuate comma - pprOr p = cparen (p > 2) . fsep . intersperse vbar - --- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? -pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc -pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 - where - pprVar _ = quotes . ppr - pprAnd p = cparen (p > 1) . pprAnd' - pprAnd' [] = empty - pprAnd' [x,y] = x <+> text "and" <+> y - pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs - pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) - -instance (OutputableBndr a) => Outputable (BooleanFormula a) where - ppr = pprBooleanFormulaNormal - -pprBooleanFormulaNormal :: (OutputableBndr a) - => BooleanFormula a -> SDoc -pprBooleanFormulaNormal = go - where - go (Var x) = pprPrefixOcc x - go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) - go (Or []) = keyword $ text "FALSE" - go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) - go (Parens x) = parens (go $ unLoc x) - - ----------------------------------------------------------------------- --- Binary ----------------------------------------------------------------------- - -instance Binary a => Binary (BooleanFormula a) where - put_ bh (Var x) = putByte bh 0 >> put_ bh x - put_ bh (And xs) = putByte bh 1 >> put_ bh xs - put_ bh (Or xs) = putByte bh 2 >> put_ bh xs - put_ bh (Parens x) = putByte bh 3 >> put_ bh x - - get bh = do - h <- getByte bh - case h of - 0 -> Var <$> get bh - 1 -> And <$> get bh - 2 -> Or <$> get bh - _ -> Parens <$> get bh diff --git a/utils/BufWrite.hs b/utils/BufWrite.hs deleted file mode 100644 --- a/utils/BufWrite.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- --- Fast write-buffered Handles --- --- (c) The University of Glasgow 2005-2006 --- --- This is a simple abstraction over Handles that offers very fast write --- buffering, but without the thread safety that Handles provide. It's used --- to save time in Pretty.printDoc. --- ------------------------------------------------------------------------------ - -module BufWrite ( - BufHandle(..), - newBufHandle, - bPutChar, - bPutStr, - bPutFS, - bPutFZS, - bPutPtrString, - bPutReplicate, - bFlush, - ) where - -import GhcPrelude - -import FastString -import FastMutInt - -import Control.Monad ( when ) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Unsafe as BS -import Data.Char ( ord ) -import Foreign -import Foreign.C.String -import System.IO - --- ----------------------------------------------------------------------------- - -data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) - {-#UNPACK#-}!FastMutInt - Handle - -newBufHandle :: Handle -> IO BufHandle -newBufHandle hdl = do - ptr <- mallocBytes buf_size - r <- newFastMutInt - writeFastMutInt r 0 - return (BufHandle ptr r hdl) - -buf_size :: Int -buf_size = 8192 - -bPutChar :: BufHandle -> Char -> IO () -bPutChar b@(BufHandle buf r hdl) !c = do - i <- readFastMutInt r - if (i >= buf_size) - then do hPutBuf hdl buf buf_size - writeFastMutInt r 0 - bPutChar b c - else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) - writeFastMutInt r (i+1) - -bPutStr :: BufHandle -> String -> IO () -bPutStr (BufHandle buf r hdl) !str = do - i <- readFastMutInt r - loop str i - where loop "" !i = do writeFastMutInt r i; return () - loop (c:cs) !i - | i >= buf_size = do - hPutBuf hdl buf buf_size - loop (c:cs) 0 - | otherwise = do - pokeElemOff buf i (fromIntegral (ord c)) - loop cs (i+1) - -bPutFS :: BufHandle -> FastString -> IO () -bPutFS b fs = bPutBS b $ bytesFS fs - -bPutFZS :: BufHandle -> FastZString -> IO () -bPutFZS b fs = bPutBS b $ fastZStringToByteString fs - -bPutBS :: BufHandle -> ByteString -> IO () -bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b - -bPutCStringLen :: BufHandle -> CStringLen -> IO () -bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do - i <- readFastMutInt r - if (i + len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl ptr len - else bPutCStringLen b cstr - else do - copyBytes (buf `plusPtr` i) ptr len - writeFastMutInt r (i + len) - -bPutPtrString :: BufHandle -> PtrString -> IO () -bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do - i <- readFastMutInt r - if (i+len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl a len - else bPutPtrString b l - else do - copyBytes (buf `plusPtr` i) a len - writeFastMutInt r (i+len) - --- | Replicate an 8-bit character -bPutReplicate :: BufHandle -> Int -> Char -> IO () -bPutReplicate (BufHandle buf r hdl) len c = do - i <- readFastMutInt r - let oc = fromIntegral (ord c) - if (i+len) < buf_size - then do - fillBytes (buf `plusPtr` i) oc len - writeFastMutInt r (i+len) - else do - -- flush the current buffer - when (i /= 0) $ hPutBuf hdl buf i - if (len < buf_size) - then do - fillBytes buf oc len - writeFastMutInt r len - else do - -- fill a full buffer - fillBytes buf oc buf_size - -- flush it as many times as necessary - let go n | n >= buf_size = do - hPutBuf hdl buf buf_size - go (n-buf_size) - | otherwise = writeFastMutInt r n - go len - -bFlush :: BufHandle -> IO () -bFlush (BufHandle buf r hdl) = do - i <- readFastMutInt r - when (i > 0) $ hPutBuf hdl buf i - free buf - return () diff --git a/utils/Digraph.hs b/utils/Digraph.hs deleted file mode 100644 --- a/utils/Digraph.hs +++ /dev/null @@ -1,524 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Digraph( - Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, - - SCC(..), Node(..), flattenSCC, flattenSCCs, - stronglyConnCompG, - topologicalSortG, - verticesG, edgesG, hasVertexG, - reachableG, reachablesG, transposeG, - emptyG, - - findCycle, - - -- For backwards compatibility with the simpler version of Digraph - stronglyConnCompFromEdgedVerticesOrd, - stronglyConnCompFromEdgedVerticesOrdR, - stronglyConnCompFromEdgedVerticesUniq, - stronglyConnCompFromEdgedVerticesUniqR, - - -- Simple way to classify edges - EdgeType(..), classifyEdges - ) where - -#include "HsVersions.h" - ------------------------------------------------------------------------------- --- A version of the graph algorithms described in: --- --- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' --- by David King and John Launchbury --- --- Also included is some additional code for printing tree structures ... --- --- If you ever find yourself in need of algorithms for classifying edges, --- or finding connected/biconnected components, consult the history; Sigbjorn --- Finne contributed some implementations in 1997, although we've since --- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------- - - -import GhcPrelude - -import Util ( minWith, count ) -import Outputable -import Maybes ( expectJust ) - --- std interfaces -import Data.Maybe -import Data.Array -import Data.List hiding (transpose) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified Data.Graph as G -import Data.Graph hiding (Graph, Edge, transposeG, reachable) -import Data.Tree -import Unique -import UniqFM - -{- -************************************************************************ -* * -* Graphs and Graph Construction -* * -************************************************************************ - -Note [Nodes, keys, vertices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * A 'node' is a big blob of client-stuff - - * Each 'node' has a unique (client) 'key', but the latter - is in Ord and has fast comparison - - * Digraph then maps each 'key' to a Vertex (Int) which is - arranged densely in 0.n --} - -data Graph node = Graph { - gr_int_graph :: IntGraph, - gr_vertex_to_node :: Vertex -> node, - gr_node_to_vertex :: node -> Maybe Vertex - } - -data Edge node = Edge node node - -{-| Representation for nodes of the Graph. - - * The @payload@ is user data, just carried around in this module - - * The @key@ is the node identifier. - Key has an Ord instance for performance reasons. - - * The @[key]@ are the dependencies of the node; - it's ok to have extra keys in the dependencies that - are not the key of any Node in the graph --} -data Node key payload = DigraphNode { - node_payload :: payload, -- ^ User data - node_key :: key, -- ^ User defined node id - node_dependencies :: [key] -- ^ Dependencies/successors of the node - } - - -instance (Outputable a, Outputable b) => Outputable (Node a b) where - ppr (DigraphNode a b c) = ppr (a, b, c) - -emptyGraph :: Graph a -emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) - --- See Note [Deterministic SCC] -graphFromEdgedVertices - :: ReduceFn key payload - -> [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVertices _reduceFn [] = emptyGraph -graphFromEdgedVertices reduceFn edged_vertices = - Graph graph vertex_fn (key_vertex . key_extractor) - where key_extractor = node_key - (bounds, vertex_fn, key_vertex, numbered_nodes) = - reduceFn edged_vertices key_extractor - graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) - | (v, (node_dependencies -> ks)) <- numbered_nodes] - -- We normalize outgoing edges by sorting on node order, so - -- that the result doesn't depend on the order of the edges - --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -graphFromEdgedVerticesOrd - :: Ord key - => [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd - --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -graphFromEdgedVerticesUniq - :: Uniquable key - => [Node key payload] -- The graph; its ok for the - -- out-list to contain keys which aren't - -- a vertex key, they are ignored - -> Graph (Node key payload) -graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq - -type ReduceFn key payload = - [Node key payload] -> (Node key payload -> key) -> - (Bounds, Vertex -> Node key payload - , key -> Maybe Vertex, [(Vertex, Node key payload)]) - -{- -Note [reduceNodesIntoVertices implementations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -reduceNodesIntoVertices is parameterized by the container type. -This is to accomodate key types that don't have an Ord instance -and hence preclude the use of Data.Map. An example of such type -would be Unique, there's no way to implement Ord Unique -deterministically. - -For such types, there's a version with a Uniquable constraint. -This leaves us with two versions of every function that depends on -reduceNodesIntoVertices, one with Ord constraint and the other with -Uniquable constraint. -For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. - -The Uniq version should be a tiny bit more efficient since it uses -Data.IntMap internally. --} -reduceNodesIntoVertices - :: ([(key, Vertex)] -> m) - -> (key -> m -> Maybe Vertex) - -> ReduceFn key payload -reduceNodesIntoVertices fromList lookup nodes key_extractor = - (bounds, (!) vertex_map, key_vertex, numbered_nodes) - where - max_v = length nodes - 1 - bounds = (0, max_v) :: (Vertex, Vertex) - - -- Keep the order intact to make the result depend on input order - -- instead of key order - numbered_nodes = zip [0..] nodes - vertex_map = array bounds numbered_nodes - - key_map = fromList - [ (key_extractor node, v) | (v, node) <- numbered_nodes ] - key_vertex k = lookup k key_map - --- See Note [reduceNodesIntoVertices implementations] -reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload -reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup - --- See Note [reduceNodesIntoVertices implementations] -reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload -reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) - -{- -************************************************************************ -* * -* SCC -* * -************************************************************************ --} - -type WorkItem key payload - = (Node key payload, -- Tip of the path - [payload]) -- Rest of the path; - -- [a,b,c] means c depends on b, b depends on a - --- | Find a reasonably short cycle a->b->c->a, in a strongly --- connected component. The input nodes are presumed to be --- a SCC, so you can start anywhere. -findCycle :: forall payload key. Ord key - => [Node key payload] -- The nodes. The dependencies can - -- contain extra keys, which are ignored - -> Maybe [payload] -- A cycle, starting with node - -- so each depends on the next -findCycle graph - = go Set.empty (new_work root_deps []) [] - where - env :: Map.Map key (Node key payload) - env = Map.fromList [ (node_key node, node) | node <- graph ] - - -- Find the node with fewest dependencies among the SCC modules - -- This is just a heuristic to find some plausible root module - root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) - (node_dependencies node)) - | node <- graph ]) - DigraphNode root_payload root_key root_deps = root - - - -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle - -- Invariant: in a call (go visited ps qs), - -- visited = union (map tail (ps ++ qs)) - - go _ [] [] = Nothing -- No cycles - go visited [] qs = go visited qs [] - go visited (((DigraphNode payload key deps), path) : ps) qs - | key == root_key = Just (root_payload : reverse path) - | key `Set.member` visited = go visited ps qs - | key `Map.notMember` env = go visited ps qs - | otherwise = go (Set.insert key visited) - ps (new_qs ++ qs) - where - new_qs = new_work deps (payload : path) - - new_work :: [key] -> [payload] -> [WorkItem key payload] - new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] - -{- -************************************************************************ -* * -* Strongly Connected Component wrappers for Graph -* * -************************************************************************ - -Note: the components are returned topologically sorted: later components -depend on earlier ones, but not vice versa i.e. later components only have -edges going from them to earlier ones. --} - -{- -Note [Deterministic SCC] -~~~~~~~~~~~~~~~~~~~~~~~~ -stronglyConnCompFromEdgedVerticesUniq, -stronglyConnCompFromEdgedVerticesUniqR, -stronglyConnCompFromEdgedVerticesOrd and -stronglyConnCompFromEdgedVerticesOrdR -provide a following guarantee: -Given a deterministically ordered list of nodes it returns a deterministically -ordered list of strongly connected components, where the list of vertices -in an SCC is also deterministically ordered. -Note that the order of edges doesn't need to be deterministic for this to work. -We use the order of nodes to normalize the order of edges. --} - -stronglyConnCompG :: Graph node -> [SCC node] -stronglyConnCompG graph = decodeSccs graph forest - where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) - -decodeSccs :: Graph node -> Forest Vertex -> [SCC node] -decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest - = map decode forest - where - decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] - | otherwise = AcyclicSCC (vertex_fn v) - decode other = CyclicSCC (dec other []) - where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts - mentions_itself v = v `elem` (graph ! v) - - --- The following two versions are provided for backwards compatibility: --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesOrd - :: Ord key - => [Node key payload] - -> [SCC payload] -stronglyConnCompFromEdgedVerticesOrd - = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR - --- The following two versions are provided for backwards compatibility: --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesUniq - :: Uniquable key - => [Node key payload] - -> [SCC payload] -stronglyConnCompFromEdgedVerticesUniq - = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR - --- The "R" interface is used when you expect to apply SCC to --- (some of) the result of SCC, so you don't want to lose the dependency info --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesOrdR - :: Ord key - => [Node key payload] - -> [SCC (Node key payload)] -stronglyConnCompFromEdgedVerticesOrdR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd - --- The "R" interface is used when you expect to apply SCC to --- (some of) the result of SCC, so you don't want to lose the dependency info --- See Note [Deterministic SCC] --- See Note [reduceNodesIntoVertices implementations] -stronglyConnCompFromEdgedVerticesUniqR - :: Uniquable key - => [Node key payload] - -> [SCC (Node key payload)] -stronglyConnCompFromEdgedVerticesUniqR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq - -{- -************************************************************************ -* * -* Misc wrappers for Graph -* * -************************************************************************ --} - -topologicalSortG :: Graph node -> [node] -topologicalSortG graph = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) - -reachableG :: Graph node -> node -> [node] -reachableG graph from = map (gr_vertex_to_node graph) result - where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) - result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] - --- | Given a list of roots return all reachable nodes. -reachablesG :: Graph node -> [node] -> [node] -reachablesG graph froms = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.reachable" #-} - reachable (gr_int_graph graph) vs - vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] - -hasVertexG :: Graph node -> node -> Bool -hasVertexG graph node = isJust $ gr_node_to_vertex graph node - -verticesG :: Graph node -> [node] -verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) - -edgesG :: Graph node -> [Edge node] -edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) - where v2n = gr_vertex_to_node graph - -transposeG :: Graph node -> Graph node -transposeG graph = Graph (G.transposeG (gr_int_graph graph)) - (gr_vertex_to_node graph) - (gr_node_to_vertex graph) - -emptyG :: Graph node -> Bool -emptyG g = graphEmpty (gr_int_graph g) - -{- -************************************************************************ -* * -* Showing Graphs -* * -************************************************************************ --} - -instance Outputable node => Outputable (Graph node) where - ppr graph = vcat [ - hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), - hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) - ] - -instance Outputable node => Outputable (Edge node) where - ppr (Edge from to) = ppr from <+> text "->" <+> ppr to - -graphEmpty :: G.Graph -> Bool -graphEmpty g = lo > hi - where (lo, hi) = bounds g - -{- -************************************************************************ -* * -* IntGraphs -* * -************************************************************************ --} - -type IntGraph = G.Graph - -{- ------------------------------------------------------------- --- Depth first search numbering ------------------------------------------------------------- --} - --- Data.Tree has flatten for Tree, but nothing for Forest -preorderF :: Forest a -> [a] -preorderF ts = concat (map flatten ts) - -{- ------------------------------------------------------------- --- Finding reachable vertices ------------------------------------------------------------- --} - --- This generalizes reachable which was found in Data.Graph -reachable :: IntGraph -> [Vertex] -> [Vertex] -reachable g vs = preorderF (dfs g vs) - -{- -************************************************************************ -* * -* Classify Edge Types -* * -************************************************************************ --} - --- Remark: While we could generalize this algorithm this comes at a runtime --- cost and with no advantages. If you find yourself using this with graphs --- not easily represented using Int nodes please consider rewriting this --- using the more general Graph type. - --- | Edge direction based on DFS Classification -data EdgeType - = Forward - | Cross - | Backward -- ^ Loop back towards the root node. - -- Eg backjumps in loops - | SelfLoop -- ^ v -> v - deriving (Eq,Ord) - -instance Outputable EdgeType where - ppr Forward = text "Forward" - ppr Cross = text "Cross" - ppr Backward = text "Backward" - ppr SelfLoop = text "SelfLoop" - -newtype Time = Time Int deriving (Eq,Ord,Num,Outputable) - ---Allow for specialzation -{-# INLINEABLE classifyEdges #-} - --- | Given a start vertex, a way to get successors from a node --- and a list of (directed) edges classify the types of edges. -classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) - -> [(key,key)] -> [((key, key), EdgeType)] -classifyEdges root getSucc edges = - --let uqe (from,to) = (getUnique from, getUnique to) - --in pprTrace "Edges:" (ppr $ map uqe edges) $ - zip edges $ map classify edges - where - (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root - classify :: (key,key) -> EdgeType - classify (from,to) - | startFrom < startTo - , endFrom > endTo - = Forward - | startFrom > startTo - , endFrom < endTo - = Backward - | startFrom > startTo - , endFrom > endTo - = Cross - | getUnique from == getUnique to - = SelfLoop - | otherwise - = pprPanic "Failed to classify edge of Graph" - (ppr (getUnique from, getUnique to)) - - where - getTime event node - | Just time <- lookupUFM event node - = time - | otherwise - = pprPanic "Failed to classify edge of CFG - not not timed" - (text "edges" <> ppr (getUnique from, getUnique to) - <+> ppr starts <+> ppr ends ) - startFrom = getTime starts from - startTo = getTime starts to - endFrom = getTime ends from - endTo = getTime ends to - - addTimes :: (Time, UniqFM Time, UniqFM Time) -> key - -> (Time, UniqFM Time, UniqFM Time) - addTimes (time,starts,ends) n - --Dont reenter nodes - | elemUFM n starts - = (time,starts,ends) - | otherwise = - let - starts' = addToUFM starts n time - time' = time + 1 - succs = getSucc n :: [key] - (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs - ends'' = addToUFM ends' n time'' - in - (time'' + 1, starts'', ends'') diff --git a/utils/Dominators.hs b/utils/Dominators.hs deleted file mode 100644 --- a/utils/Dominators.hs +++ /dev/null @@ -1,597 +0,0 @@ -{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-} - -{- | - Module : Dominators - Copyright : (c) Matt Morrow 2009 - License : BSD3 - Maintainer : - Stability : experimental - Portability : portable - - Taken from the dom-lt package. - - The Lengauer-Tarjan graph dominators algorithm. - - \[1\] Lengauer, Tarjan, - /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979. - - \[2\] Muchnick, - /Advanced Compiler Design and Implementation/, 1997. - - \[3\] Brisk, Sarrafzadeh, - /Interference Graphs for Procedures in Static Single/ - /Information Form are Interval Graphs/, 2007. - - Originally taken from the dom-lt package. --} - -module Dominators ( - Node,Path,Edge - ,Graph,Rooted - ,idom,ipdom - ,domTree,pdomTree - ,dom,pdom - ,pddfs,rpddfs - ,fromAdj,fromEdges - ,toAdj,toEdges - ,asTree,asGraph - ,parents,ancestors -) where - -import GhcPrelude - -import Data.Bifunctor -import Data.Tuple (swap) - -import Data.Tree -import Data.IntMap(IntMap) -import Data.IntSet(IntSet) -import qualified Data.IntMap.Strict as IM -import qualified Data.IntSet as IS - -import Control.Monad -import Control.Monad.ST.Strict - -import Data.Array.ST -import Data.Array.Base hiding ((!)) - -- (unsafeNewArray_ - -- ,unsafeWrite,unsafeRead - -- ,readArray,writeArray) - -import Util (debugIsOn) - ------------------------------------------------------------------------------ - -type Node = Int -type Path = [Node] -type Edge = (Node,Node) -type Graph = IntMap IntSet -type Rooted = (Node, Graph) - ------------------------------------------------------------------------------ - --- | /Dominators/. --- Complexity as for @idom@ -dom :: Rooted -> [(Node, Path)] -dom = ancestors . domTree - --- | /Post-dominators/. --- Complexity as for @idom@. -pdom :: Rooted -> [(Node, Path)] -pdom = ancestors . pdomTree - --- | /Dominator tree/. --- Complexity as for @idom@. -domTree :: Rooted -> Tree Node -domTree a@(r,_) = - let is = filter ((/=r).fst) (idom a) - tg = fromEdges (fmap swap is) - in asTree (r,tg) - --- | /Post-dominator tree/. --- Complexity as for @idom@. -pdomTree :: Rooted -> Tree Node -pdomTree a@(r,_) = - let is = filter ((/=r).fst) (ipdom a) - tg = fromEdges (fmap swap is) - in asTree (r,tg) - --- | /Immediate dominators/. --- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is --- \"a functional inverse of Ackermann's function\". --- --- This Complexity bound assumes /O(1)/ indexing. Since we're --- using @IntMap@, it has an additional /lg |V|/ factor --- somewhere in there. I'm not sure where. -idom :: Rooted -> [(Node,Node)] -idom rg = runST (evalS idomM =<< initEnv (pruneReach rg)) - --- | /Immediate post-dominators/. --- Complexity as for @idom@. -ipdom :: Rooted -> [(Node,Node)] -ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg))) - ------------------------------------------------------------------------------ - --- | /Post-dominated depth-first search/. -pddfs :: Rooted -> [Node] -pddfs = reverse . rpddfs - --- | /Reverse post-dominated depth-first search/. -rpddfs :: Rooted -> [Node] -rpddfs = concat . levels . pdomTree - ------------------------------------------------------------------------------ - -type Dom s a = S s (Env s) a -type NodeSet = IntSet -type NodeMap a = IntMap a -data Env s = Env - {succE :: !Graph - ,predE :: !Graph - ,bucketE :: !Graph - ,dfsE :: {-# UNPACK #-}!Int - ,zeroE :: {-# UNPACK #-}!Node - ,rootE :: {-# UNPACK #-}!Node - ,labelE :: {-# UNPACK #-}!(Arr s Node) - ,parentE :: {-# UNPACK #-}!(Arr s Node) - ,ancestorE :: {-# UNPACK #-}!(Arr s Node) - ,childE :: {-# UNPACK #-}!(Arr s Node) - ,ndfsE :: {-# UNPACK #-}!(Arr s Node) - ,dfnE :: {-# UNPACK #-}!(Arr s Int) - ,sdnoE :: {-# UNPACK #-}!(Arr s Int) - ,sizeE :: {-# UNPACK #-}!(Arr s Int) - ,domE :: {-# UNPACK #-}!(Arr s Node) - ,rnE :: {-# UNPACK #-}!(Arr s Node)} - ------------------------------------------------------------------------------ - -idomM :: Dom s [(Node,Node)] -idomM = do - dfsDom =<< rootM - n <- gets dfsE - forM_ [n,n-1..1] (\i-> do - w <- ndfsM i - sw <- sdnoM w - ps <- predsM w - forM_ ps (\v-> do - u <- eval v - su <- sdnoM u - when (su < sw) - (store sdnoE w su)) - z <- ndfsM =<< sdnoM w - modify(\e->e{bucketE=IM.adjust - (w`IS.insert`) - z (bucketE e)}) - pw <- parentM w - link pw w - bps <- bucketM pw - forM_ bps (\v-> do - u <- eval v - su <- sdnoM u - sv <- sdnoM v - let dv = case su < sv of - True-> u - False-> pw - store domE v dv)) - forM_ [1..n] (\i-> do - w <- ndfsM i - j <- sdnoM w - z <- ndfsM j - dw <- domM w - when (dw /= z) - (do ddw <- domM dw - store domE w ddw)) - fromEnv - ------------------------------------------------------------------------------ - -eval :: Node -> Dom s Node -eval v = do - n0 <- zeroM - a <- ancestorM v - case a==n0 of - True-> labelM v - False-> do - compress v - a <- ancestorM v - l <- labelM v - la <- labelM a - sl <- sdnoM l - sla <- sdnoM la - case sl <= sla of - True-> return l - False-> return la - -compress :: Node -> Dom s () -compress v = do - n0 <- zeroM - a <- ancestorM v - aa <- ancestorM a - when (aa /= n0) (do - compress a - a <- ancestorM v - aa <- ancestorM a - l <- labelM v - la <- labelM a - sl <- sdnoM l - sla <- sdnoM la - when (sla < sl) - (store labelE v la) - store ancestorE v aa) - ------------------------------------------------------------------------------ - -link :: Node -> Node -> Dom s () -link v w = do - n0 <- zeroM - lw <- labelM w - slw <- sdnoM lw - let balance s = do - c <- childM s - lc <- labelM c - slc <- sdnoM lc - case slw < slc of - False-> return s - True-> do - zs <- sizeM s - zc <- sizeM c - cc <- childM c - zcc <- sizeM cc - case 2*zc <= zs+zcc of - True-> do - store ancestorE c s - store childE s cc - balance s - False-> do - store sizeE c zs - store ancestorE s c - balance c - s <- balance w - lw <- labelM w - zw <- sizeM w - store labelE s lw - store sizeE v . (+zw) =<< sizeM v - let follow s = do - when (s /= n0) (do - store ancestorE s v - follow =<< childM s) - zv <- sizeM v - follow =<< case zv < 2*zw of - False-> return s - True-> do - cv <- childM v - store childE v s - return cv - ------------------------------------------------------------------------------ - -dfsDom :: Node -> Dom s () -dfsDom i = do - _ <- go i - n0 <- zeroM - r <- rootM - store parentE r n0 - where go i = do - n <- nextM - store dfnE i n - store sdnoE i n - store ndfsE n i - store labelE i i - ss <- succsM i - forM_ ss (\j-> do - s <- sdnoM j - case s==0 of - False-> return() - True-> do - store parentE j i - go j) - ------------------------------------------------------------------------------ - -initEnv :: Rooted -> ST s (Env s) -initEnv (r0,g0) = do - let (g,rnmap) = renum 1 g0 - pred = predG g - r = rnmap IM.! r0 - n = IM.size g - ns = [0..n] - m = n+1 - - let bucket = IM.fromList - (zip ns (repeat mempty)) - - rna <- newI m - writes rna (fmap swap - (IM.toList rnmap)) - - doms <- newI m - sdno <- newI m - size <- newI m - parent <- newI m - ancestor <- newI m - child <- newI m - label <- newI m - ndfs <- newI m - dfn <- newI m - - forM_ [0..n] (doms.=0) - forM_ [0..n] (sdno.=0) - forM_ [1..n] (size.=1) - forM_ [0..n] (ancestor.=0) - forM_ [0..n] (child.=0) - - (doms.=r) r - (size.=0) 0 - (label.=0) 0 - - return (Env - {rnE = rna - ,dfsE = 0 - ,zeroE = 0 - ,rootE = r - ,labelE = label - ,parentE = parent - ,ancestorE = ancestor - ,childE = child - ,ndfsE = ndfs - ,dfnE = dfn - ,sdnoE = sdno - ,sizeE = size - ,succE = g - ,predE = pred - ,bucketE = bucket - ,domE = doms}) - -fromEnv :: Dom s [(Node,Node)] -fromEnv = do - dom <- gets domE - rn <- gets rnE - -- r <- gets rootE - (_,n) <- st (getBounds dom) - forM [1..n] (\i-> do - j <- st(rn!:i) - d <- st(dom!:i) - k <- st(rn!:d) - return (j,k)) - ------------------------------------------------------------------------------ - -zeroM :: Dom s Node -zeroM = gets zeroE -domM :: Node -> Dom s Node -domM = fetch domE -rootM :: Dom s Node -rootM = gets rootE -succsM :: Node -> Dom s [Node] -succsM i = gets (IS.toList . (! i) . succE) -predsM :: Node -> Dom s [Node] -predsM i = gets (IS.toList . (! i) . predE) -bucketM :: Node -> Dom s [Node] -bucketM i = gets (IS.toList . (! i) . bucketE) -sizeM :: Node -> Dom s Int -sizeM = fetch sizeE -sdnoM :: Node -> Dom s Int -sdnoM = fetch sdnoE --- dfnM :: Node -> Dom s Int --- dfnM = fetch dfnE -ndfsM :: Int -> Dom s Node -ndfsM = fetch ndfsE -childM :: Node -> Dom s Node -childM = fetch childE -ancestorM :: Node -> Dom s Node -ancestorM = fetch ancestorE -parentM :: Node -> Dom s Node -parentM = fetch parentE -labelM :: Node -> Dom s Node -labelM = fetch labelE -nextM :: Dom s Int -nextM = do - n <- gets dfsE - let n' = n+1 - modify(\e->e{dfsE=n'}) - return n' - ------------------------------------------------------------------------------ - -type A = STUArray -type Arr s a = A s Int a - -infixl 9 !: -infixr 2 .= - -(.=) :: (MArray (A s) a (ST s)) - => Arr s a -> a -> Int -> ST s () -(v .= x) i - | debugIsOn = writeArray v i x - | otherwise = unsafeWrite v i x - -(!:) :: (MArray (A s) a (ST s)) - => A s Int a -> Int -> ST s a -a !: i - | debugIsOn = do - o <- readArray a i - return $! o - | otherwise = do - o <- unsafeRead a i - return $! o - -new :: (MArray (A s) a (ST s)) - => Int -> ST s (Arr s a) -new n = unsafeNewArray_ (0,n-1) - -newI :: Int -> ST s (Arr s Int) -newI = new - --- newD :: Int -> ST s (Arr s Double) --- newD = new - --- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a] --- dump a = do --- (m,n) <- getBounds a --- forM [m..n] (\i -> a!:i) - -writes :: (MArray (A s) a (ST s)) - => Arr s a -> [(Int,a)] -> ST s () -writes a xs = forM_ xs (\(i,x) -> (a.=x) i) - --- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a) --- arr xs = do --- let n = length xs --- a <- new n --- go a n 0 xs --- return a --- where go _ _ _ [] = return () --- go a n i (x:xs) --- | i <= n = (a.=x) i >> go a n (i+1) xs --- | otherwise = return () - ------------------------------------------------------------------------------ - -(!) :: Monoid a => IntMap a -> Int -> a -(!) g n = maybe mempty id (IM.lookup n g) - -fromAdj :: [(Node, [Node])] -> Graph -fromAdj = IM.fromList . fmap (second IS.fromList) - -fromEdges :: [Edge] -> Graph -fromEdges = collectI IS.union fst (IS.singleton . snd) - -toAdj :: Graph -> [(Node, [Node])] -toAdj = fmap (second IS.toList) . IM.toList - -toEdges :: Graph -> [Edge] -toEdges = concatMap (uncurry (fmap . (,))) . toAdj - -predG :: Graph -> Graph -predG g = IM.unionWith IS.union (go g) g0 - where g0 = fmap (const mempty) g - f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet - f m i a = foldl' (\m p -> IM.insertWith mappend p - (IS.singleton i) m) - m - (IS.toList a) - go :: IntMap IntSet -> IntMap IntSet - go = flip IM.foldlWithKey' mempty f - -pruneReach :: Rooted -> Rooted -pruneReach (r,g) = (r,g2) - where is = reachable - (maybe mempty id - . flip IM.lookup g) $ r - g2 = IM.fromList - . fmap (second (IS.filter (`IS.member`is))) - . filter ((`IS.member`is) . fst) - . IM.toList $ g - -tip :: Tree a -> (a, [Tree a]) -tip (Node a ts) = (a, ts) - -parents :: Tree a -> [(a, a)] -parents (Node i xs) = p i xs - ++ concatMap parents xs - where p i = fmap (flip (,) i . rootLabel) - -ancestors :: Tree a -> [(a, [a])] -ancestors = go [] - where go acc (Node i xs) - = let acc' = i:acc - in p acc' xs ++ concatMap (go acc') xs - p is = fmap (flip (,) is . rootLabel) - -asGraph :: Tree Node -> Rooted -asGraph t@(Node a _) = let g = go t in (a, fromAdj g) - where go (Node a ts) = let as = (fst . unzip . fmap tip) ts - in (a, as) : concatMap go ts - -asTree :: Rooted -> Tree Node -asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a)) - f = (g !) - in go r - -reachable :: (Node -> NodeSet) -> (Node -> NodeSet) -reachable f a = go (IS.singleton a) a - where go seen a = let s = f a - as = IS.toList (s `IS.difference` seen) - in foldl' go (s `IS.union` seen) as - -collectI :: (c -> c -> c) - -> (a -> Int) -> (a -> c) -> [a] -> IntMap c -collectI (<>) f g - = foldl' (\m a -> IM.insertWith (<>) - (f a) - (g a) m) mempty - --- collect :: (Ord b) => (c -> c -> c) --- -> (a -> b) -> (a -> c) -> [a] -> Map b c --- collect (<>) f g --- = foldl' (\m a -> SM.insertWith (<>) --- (f a) --- (g a) m) mempty - --- (renamed, old -> new) -renum :: Int -> Graph -> (Graph, NodeMap Node) -renum from = (\(_,m,g)->(g,m)) - . IM.foldlWithKey' - f (from,mempty,mempty) - where - f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet - -> (Int, NodeMap Node, IntMap IntSet) - f (!n,!env,!new) i ss = - let (j,n2,env2) = go n env i - (n3,env3,ss2) = IS.fold - (\k (!n,!env,!new)-> - case go n env k of - (l,n2,env2)-> (n2,env2,l `IS.insert` new)) - (n2,env2,mempty) ss - new2 = IM.insertWith IS.union j ss2 new - in (n3,env3,new2) - go :: Int - -> NodeMap Node - -> Node - -> (Node,Int,NodeMap Node) - go !n !env i = - case IM.lookup i env of - Just j -> (j,n,env) - Nothing -> (n,n+1,IM.insert i n env) - ------------------------------------------------------------------------------ - -newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o} -instance Functor (S z s) where - fmap f (S g) = S (\k -> g (k . f)) -instance Monad (S z s) where - return = pure - S g >>= f = S (\k -> g (\a -> unS (f a) k)) -instance Applicative (S z s) where - pure a = S (\k -> k a) - (<*>) = ap --- get :: S z s s --- get = S (\k s -> k s s) -gets :: (s -> a) -> S z s a -gets f = S (\k s -> k (f s) s) --- set :: s -> S z s () --- set s = S (\k _ -> k () s) -modify :: (s -> s) -> S z s () -modify f = S (\k -> k () . f) --- runS :: S z s a -> s -> ST z (a, s) --- runS (S g) = g (\a s -> return (a,s)) -evalS :: S z s a -> s -> ST z a -evalS (S g) = g ((return .) . const) --- execS :: S z s a -> s -> ST z s --- execS (S g) = g ((return .) . flip const) -st :: ST z a -> S z s a -st m = S (\k s-> do - a <- m - k a s) -store :: (MArray (A z) a (ST z)) - => (s -> Arr z a) -> Int -> a -> S z s () -store f i x = do - a <- gets f - st ((a.=x) i) -fetch :: (MArray (A z) a (ST z)) - => (s -> Arr z a) -> Int -> S z s a -fetch f i = do - a <- gets f - st (a!:i) - diff --git a/utils/Encoding.hs b/utils/Encoding.hs deleted file mode 100644 --- a/utils/Encoding.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O2 #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 1997-2006 --- --- Character encodings --- --- ----------------------------------------------------------------------------- - -module Encoding ( - -- * UTF-8 - utf8DecodeChar#, - utf8PrevChar, - utf8CharStart, - utf8DecodeChar, - utf8DecodeByteString, - utf8DecodeStringLazy, - utf8EncodeChar, - utf8EncodeString, - utf8EncodedLength, - countUTF8Chars, - - -- * Z-encoding - zEncodeString, - zDecodeString, - - -- * Base62-encoding - toBase62, - toBase62Padded - ) where - -import GhcPrelude - -import Foreign -import Foreign.ForeignPtr.Unsafe -import Data.Char -import qualified Data.Char as Char -import Numeric -import GHC.IO - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS - -import GHC.Exts - --- ----------------------------------------------------------------------------- --- UTF-8 - --- We can't write the decoder as efficiently as we'd like without --- resorting to unboxed extensions, unfortunately. I tried to write --- an IO version of this function, but GHC can't eliminate boxed --- results from an IO-returning function. --- --- We assume we can ignore overflow when parsing a multibyte character here. --- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences --- before decoding them (see StringBuffer.hs). - -{-# INLINE utf8DecodeChar# #-} -utf8DecodeChar# :: Addr# -> (# Char#, Int# #) -utf8DecodeChar# a# = - let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in - case () of - _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) - - | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# - (ch1 -# 0x80#)), - 2# #) - - | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch2 -# 0x80#)), - 3# #) - - | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> - let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in - if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else - let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in - if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else - let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in - if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else - (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# - ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# - ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ch3 -# 0x80#)), - 4# #) - - | otherwise -> fail 1# - where - -- all invalid sequences end up here: - fail :: Int# -> (# Char#, Int# #) - fail nBytes# = (# '\0'#, nBytes# #) - -- '\xFFFD' would be the usual replacement character, but - -- that's a valid symbol in Haskell, so will result in a - -- confusing parse error later on. Instead we use '\0' which - -- will signal a lexer error immediately. - -utf8DecodeChar :: Ptr Word8 -> (Char, Int) -utf8DecodeChar (Ptr a#) = - case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) - --- UTF-8 is cleverly designed so that we can always figure out where --- the start of the current character is, given any position in a --- stream. This function finds the start of the previous character, --- assuming there *is* a previous character. -utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) -utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) - -utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) -utf8CharStart p = go p - where go p = do w <- peek p - if w >= 0x80 && w < 0xC0 - then go (p `plusPtr` (-1)) - else return p - -utf8DecodeByteString :: ByteString -> [Char] -utf8DecodeByteString (BS.PS ptr offset len) - = utf8DecodeStringLazy ptr offset len - -utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] -utf8DecodeStringLazy fptr offset len - = unsafeDupablePerformIO $ unpack start - where - !start = unsafeForeignPtrToPtr fptr `plusPtr` offset - !end = start `plusPtr` len - - unpack p - | p >= end = touchForeignPtr fptr >> return [] - | otherwise = - case utf8DecodeChar# (unPtr p) of - (# c#, nBytes# #) -> do - rest <- unsafeDupableInterleaveIO $ unpack (p `plusPtr#` nBytes#) - return (C# c# : rest) - -countUTF8Chars :: Ptr Word8 -> Int -> IO Int -countUTF8Chars ptr len = go ptr 0 - where - !end = ptr `plusPtr` len - - go p !n - | p >= end = return n - | otherwise = do - case utf8DecodeChar# (unPtr p) of - (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1) - -unPtr :: Ptr a -> Addr# -unPtr (Ptr a) = a - -plusPtr# :: Ptr a -> Int# -> Ptr a -plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#) - -utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8) -utf8EncodeChar c ptr = - let x = ord c in - case () of - _ | x > 0 && x <= 0x007f -> do - poke ptr (fromIntegral x) - return (ptr `plusPtr` 1) - -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we - -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). - | x <= 0x07ff -> do - poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 2) - | x <= 0xffff -> do - poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F)) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F)) - pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 3) - | otherwise -> do - poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18))) - pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F))) - pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F))) - pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F))) - return (ptr `plusPtr` 4) - -utf8EncodeString :: Ptr Word8 -> String -> IO () -utf8EncodeString ptr str = go ptr str - where go !_ [] = return () - go ptr (c:cs) = do - ptr' <- utf8EncodeChar c ptr - go ptr' cs - -utf8EncodedLength :: String -> Int -utf8EncodedLength str = go 0 str - where go !n [] = n - go n (c:cs) - | ord c > 0 && ord c <= 0x007f = go (n+1) cs - | ord c <= 0x07ff = go (n+2) cs - | ord c <= 0xffff = go (n+3) cs - | otherwise = go (n+4) cs - --- ----------------------------------------------------------------------------- --- The Z-encoding - -{- -This is the main name-encoding and decoding function. It encodes any -string into a string that is acceptable as a C name. This is done -right before we emit a symbol name into the compiled C or asm code. -Z-encoding of strings is cached in the FastString interface, so we -never encode the same string more than once. - -The basic encoding scheme is this. - -* Tuples (,,,) are coded as Z3T - -* Alphabetic characters (upper and lower) and digits - all translate to themselves; - except 'Z', which translates to 'ZZ' - and 'z', which translates to 'zz' - We need both so that we can preserve the variable/tycon distinction - -* Most other printable characters translate to 'zx' or 'Zx' for some - alphabetic character x - -* The others translate as 'znnnU' where 'nnn' is the decimal number - of the character - - Before After - -------------------------- - Trak Trak - foo_wib foozuwib - > zg - >1 zg1 - foo# foozh - foo## foozhzh - foo##1 foozhzh1 - fooZ fooZZ - :+ ZCzp - () Z0T 0-tuple - (,,,,) Z5T 5-tuple - (# #) Z1H unboxed 1-tuple (note the space) - (#,,,,#) Z5H unboxed 5-tuple - (NB: There is no Z1T nor Z0H.) --} - -type UserString = String -- As the user typed it -type EncodedString = String -- Encoded form - - -zEncodeString :: UserString -> EncodedString -zEncodeString cs = case maybe_tuple cs of - Just n -> n -- Tuples go to Z2T etc - Nothing -> go cs - where - go [] = [] - go (c:cs) = encode_digit_ch c ++ go' cs - go' [] = [] - go' (c:cs) = encode_ch c ++ go' cs - -unencodedChar :: Char -> Bool -- True for chars that don't need encoding -unencodedChar 'Z' = False -unencodedChar 'z' = False -unencodedChar c = c >= 'a' && c <= 'z' - || c >= 'A' && c <= 'Z' - || c >= '0' && c <= '9' - --- If a digit is at the start of a symbol then we need to encode it. --- Otherwise package names like 9pH-0.1 give linker errors. -encode_digit_ch :: Char -> EncodedString -encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c -encode_digit_ch c | otherwise = encode_ch c - -encode_ch :: Char -> EncodedString -encode_ch c | unencodedChar c = [c] -- Common case first - --- Constructors -encode_ch '(' = "ZL" -- Needed for things like (,), and (->) -encode_ch ')' = "ZR" -- For symmetry with ( -encode_ch '[' = "ZM" -encode_ch ']' = "ZN" -encode_ch ':' = "ZC" -encode_ch 'Z' = "ZZ" - --- Variables -encode_ch 'z' = "zz" -encode_ch '&' = "za" -encode_ch '|' = "zb" -encode_ch '^' = "zc" -encode_ch '$' = "zd" -encode_ch '=' = "ze" -encode_ch '>' = "zg" -encode_ch '#' = "zh" -encode_ch '.' = "zi" -encode_ch '<' = "zl" -encode_ch '-' = "zm" -encode_ch '!' = "zn" -encode_ch '+' = "zp" -encode_ch '\'' = "zq" -encode_ch '\\' = "zr" -encode_ch '/' = "zs" -encode_ch '*' = "zt" -encode_ch '_' = "zu" -encode_ch '%' = "zv" -encode_ch c = encode_as_unicode_char c - -encode_as_unicode_char :: Char -> EncodedString -encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str - else '0':hex_str - where hex_str = showHex (ord c) "U" - -- ToDo: we could improve the encoding here in various ways. - -- eg. strings of unicode characters come out as 'z1234Uz5678U', we - -- could remove the 'U' in the middle (the 'z' works as a separator). - -zDecodeString :: EncodedString -> UserString -zDecodeString [] = [] -zDecodeString ('Z' : d : rest) - | isDigit d = decode_tuple d rest - | otherwise = decode_upper d : zDecodeString rest -zDecodeString ('z' : d : rest) - | isDigit d = decode_num_esc d rest - | otherwise = decode_lower d : zDecodeString rest -zDecodeString (c : rest) = c : zDecodeString rest - -decode_upper, decode_lower :: Char -> Char - -decode_upper 'L' = '(' -decode_upper 'R' = ')' -decode_upper 'M' = '[' -decode_upper 'N' = ']' -decode_upper 'C' = ':' -decode_upper 'Z' = 'Z' -decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch - -decode_lower 'z' = 'z' -decode_lower 'a' = '&' -decode_lower 'b' = '|' -decode_lower 'c' = '^' -decode_lower 'd' = '$' -decode_lower 'e' = '=' -decode_lower 'g' = '>' -decode_lower 'h' = '#' -decode_lower 'i' = '.' -decode_lower 'l' = '<' -decode_lower 'm' = '-' -decode_lower 'n' = '!' -decode_lower 'p' = '+' -decode_lower 'q' = '\'' -decode_lower 'r' = '\\' -decode_lower 's' = '/' -decode_lower 't' = '*' -decode_lower 'u' = '_' -decode_lower 'v' = '%' -decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch - --- Characters not having a specific code are coded as z224U (in hex) -decode_num_esc :: Char -> EncodedString -> UserString -decode_num_esc d rest - = go (digitToInt d) rest - where - go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest - go n ('U' : rest) = chr n : zDecodeString rest - go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) - -decode_tuple :: Char -> EncodedString -> UserString -decode_tuple d rest - = go (digitToInt d) rest - where - -- NB. recurse back to zDecodeString after decoding the tuple, because - -- the tuple might be embedded in a longer name. - go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go 0 ('T':rest) = "()" ++ zDecodeString rest - go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest - go 1 ('H':rest) = "(# #)" ++ zDecodeString rest - go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest - go n other = error ("decode_tuple: " ++ show n ++ ' ':other) - -{- -Tuples are encoded as - Z3T or Z3H -for 3-tuples or unboxed 3-tuples respectively. No other encoding starts - Z - -* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) - There are no unboxed 0-tuples. - -* "()" is the tycon for a boxed 0-tuple. - There are no boxed 1-tuples. --} - -maybe_tuple :: UserString -> Maybe EncodedString - -maybe_tuple "(# #)" = Just("Z1H") -maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") - _ -> Nothing -maybe_tuple "()" = Just("Z0T") -maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : _) -> Just ('Z' : shows (n+1) "T") - _ -> Nothing -maybe_tuple _ = Nothing - -count_commas :: Int -> String -> (Int, String) -count_commas n (',' : cs) = count_commas (n+1) cs -count_commas n cs = (n,cs) - - -{- -************************************************************************ -* * - Base 62 -* * -************************************************************************ - -Note [Base 62 encoding 128-bit integers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instead of base-62 encoding a single 128-bit integer -(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers -(2 * ceil(10.75) characters). Luckily for us, it's the same number of -characters! --} - --------------------------------------------------------------------------- --- Base 62 - --- The base-62 code is based off of 'locators' --- ((c) Operational Dynamics Consulting, BSD3 licensed) - --- | Size of a 64-bit word when written as a base-62 string -word64Base62Len :: Int -word64Base62Len = 11 - --- | Converts a 64-bit word into a base-62 string -toBase62Padded :: Word64 -> String -toBase62Padded w = pad ++ str - where - pad = replicate len '0' - len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) - str = toBase62 w - -toBase62 :: Word64 -> String -toBase62 w = showIntAtBase 62 represent w "" - where - represent :: Int -> Char - represent x - | x < 10 = Char.chr (48 + x) - | x < 36 = Char.chr (65 + x - 10) - | x < 62 = Char.chr (97 + x - 36) - | otherwise = error "represent (base 62): impossible!" diff --git a/utils/EnumSet.hs b/utils/EnumSet.hs deleted file mode 100644 --- a/utils/EnumSet.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' --- things. -module EnumSet - ( EnumSet - , member - , insert - , delete - , toList - , fromList - , empty - ) where - -import GhcPrelude - -import qualified Data.IntSet as IntSet - -newtype EnumSet a = EnumSet IntSet.IntSet - -member :: Enum a => a -> EnumSet a -> Bool -member x (EnumSet s) = IntSet.member (fromEnum x) s - -insert :: Enum a => a -> EnumSet a -> EnumSet a -insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s - -delete :: Enum a => a -> EnumSet a -> EnumSet a -delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s - -toList :: Enum a => EnumSet a -> [a] -toList (EnumSet s) = map toEnum $ IntSet.toList s - -fromList :: Enum a => [a] -> EnumSet a -fromList = EnumSet . IntSet.fromList . map fromEnum - -empty :: EnumSet a -empty = EnumSet IntSet.empty diff --git a/utils/Exception.hs b/utils/Exception.hs deleted file mode 100644 --- a/utils/Exception.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} -module Exception - ( - module Control.Exception, - module Exception - ) - where - -import GhcPrelude - -import Control.Exception -import Control.Monad.IO.Class - -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = Control.Exception.catch - -handleIO :: (IOException -> IO a) -> IO a -> IO a -handleIO = flip catchIO - -tryIO :: IO a -> IO (Either IOException a) -tryIO = try - --- | A monad that can catch exceptions. A minimal definition --- requires a definition of 'gcatch'. --- --- Implementations on top of 'IO' should implement 'gmask' to --- eventually call the primitive 'Control.Exception.mask'. --- These are used for --- implementations that support asynchronous exceptions. The default --- implementations of 'gbracket' and 'gfinally' use 'gmask' --- thus rarely require overriding. --- -class MonadIO m => ExceptionMonad m where - - -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gcatch :: Exception e => m a -> (e -> m a) -> m a - - -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gmask :: ((m a -> m a) -> m b) -> m b - - -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c - - -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary - -- exception handling monad instead of just 'IO'. - gfinally :: m a -> m b -> m a - - gbracket before after thing = - gmask $ \restore -> do - a <- before - r <- restore (thing a) `gonException` after a - _ <- after a - return r - - a `gfinally` sequel = - gmask $ \restore -> do - r <- restore a `gonException` sequel - _ <- sequel - return r - -instance ExceptionMonad IO where - gcatch = Control.Exception.catch - gmask f = mask (\x -> f x) - -gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) -gtry act = gcatch (act >>= \a -> return (Right a)) - (\e -> return (Left e)) - --- | Generalised version of 'Control.Exception.handle', allowing an arbitrary --- exception handling monad instead of just 'IO'. -ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a -ghandle = flip gcatch - --- | Always executes the first argument. If this throws an exception the --- second argument is executed and the exception is raised again. -gonException :: (ExceptionMonad m) => m a -> m b -> m a -gonException ioA cleanup = ioA `gcatch` \e -> - do _ <- cleanup - liftIO $ throwIO (e :: SomeException) - diff --git a/utils/FV.hs b/utils/FV.hs deleted file mode 100644 --- a/utils/FV.hs +++ /dev/null @@ -1,201 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook 2015 - -Utilities for efficiently and deterministically computing free variables. - --} - -{-# LANGUAGE BangPatterns #-} - -module FV ( - -- * Deterministic free vars computations - FV, InterestingVarFun, - - -- * Running the computations - fvVarListVarSet, fvVarList, fvVarSet, fvDVarSet, - - -- ** Manipulating those computations - unitFV, - emptyFV, - mkFVs, - unionFV, - unionsFV, - delFV, - delFVs, - filterFV, - mapUnionFV, - ) where - -import GhcPrelude - -import Var -import VarSet - --- | Predicate on possible free variables: returns @True@ iff the variable is --- interesting -type InterestingVarFun = Var -> Bool - --- Note [Deterministic FV] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- When computing free variables, the order in which you get them affects --- the results of floating and specialization. If you use UniqFM to collect --- them and then turn that into a list, you get them in nondeterministic --- order as described in Note [Deterministic UniqFM] in UniqDFM. - --- A naive algorithm for free variables relies on merging sets of variables. --- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log --- factor. It's cheaper to incrementally add to a list and use a set to check --- for duplicates. -type FV = InterestingVarFun - -- Used for filtering sets as we build them - -> VarSet - -- Locally bound variables - -> ([Var], VarSet) - -- List to preserve ordering and set to check for membership, - -- so that the list doesn't have duplicates - -- For explanation of why using `VarSet` is not deterministic see - -- Note [Deterministic UniqFM] in UniqDFM. - -> ([Var], VarSet) - --- Note [FV naming conventions] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- To get the performance and determinism that FV provides, FV computations --- need to built up from smaller FV computations and then evaluated with --- one of `fvVarList`, `fvDVarSet`, `fvVarListVarSet`. That means the functions --- returning FV need to be exported. --- --- The conventions are: --- --- a) non-deterministic functions: --- * a function that returns VarSet --- e.g. `tyVarsOfType` --- b) deterministic functions: --- * a worker that returns FV --- e.g. `tyFVsOfType` --- * a function that returns [Var] --- e.g. `tyVarsOfTypeList` --- * a function that returns DVarSet --- e.g. `tyVarsOfTypeDSet` --- --- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented --- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet --- respectively. - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order and a non-deterministic set containing --- those variables. -fvVarListVarSet :: FV -> ([Var], VarSet) -fvVarListVarSet fv = fv (const True) emptyVarSet ([], emptyVarSet) - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order. -fvVarList :: FV -> [Var] -fvVarList = fst . fvVarListVarSet - --- | Run a free variable computation, returning a deterministic set of free --- variables. Note that this is just a wrapper around the version that --- returns a deterministic list. If you need a list you should use --- `fvVarList`. -fvDVarSet :: FV -> DVarSet -fvDVarSet = mkDVarSet . fst . fvVarListVarSet - --- | Run a free variable computation, returning a non-deterministic set of --- free variables. Don't use if the set will be later converted to a list --- and the order of that list will impact the generated code. -fvVarSet :: FV -> VarSet -fvVarSet = snd . fvVarListVarSet - --- Note [FV eta expansion] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- Let's consider an eta-reduced implementation of freeVarsOf using FV: --- --- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b --- --- If GHC doesn't eta-expand it, after inlining unionFV we end up with --- --- freeVarsOf = \x -> --- case x of --- App a b -> \fv_cand in_scope acc -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which has to create a thunk, resulting in more allocations. --- --- On the other hand if it is eta-expanded: --- --- freeVarsOf (App a b) fv_cand in_scope acc = --- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc --- --- after inlining unionFV we have: --- --- freeVarsOf = \x fv_cand in_scope acc -> --- case x of --- App a b -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which saves allocations. --- --- GHC when presented with knowledge about all the call sites, correctly --- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets --- exported to be composed with other functions, GHC doesn't have that --- information and has to be more conservative here. --- --- Hence functions that get exported and return FV need to be manually --- eta-expanded. See also #11146. - --- | Add a variable - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -unitFV :: Id -> FV -unitFV var fv_cand in_scope acc@(have, haveSet) - | var `elemVarSet` in_scope = acc - | var `elemVarSet` haveSet = acc - | fv_cand var = (var:have, extendVarSet haveSet var) - | otherwise = acc -{-# INLINE unitFV #-} - --- | Return no free variables. -emptyFV :: FV -emptyFV _ _ acc = acc -{-# INLINE emptyFV #-} - --- | Union two free variable computations. -unionFV :: FV -> FV -> FV -unionFV fv1 fv2 fv_cand in_scope acc = - fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc -{-# INLINE unionFV #-} - --- | Mark the variable as not free by putting it in scope. -delFV :: Var -> FV -> FV -delFV var fv fv_cand !in_scope acc = - fv fv_cand (extendVarSet in_scope var) acc -{-# INLINE delFV #-} - --- | Mark many free variables as not free. -delFVs :: VarSet -> FV -> FV -delFVs vars fv fv_cand !in_scope acc = - fv fv_cand (in_scope `unionVarSet` vars) acc -{-# INLINE delFVs #-} - --- | Filter a free variable computation. -filterFV :: InterestingVarFun -> FV -> FV -filterFV fv_cand2 fv fv_cand1 in_scope acc = - fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc -{-# INLINE filterFV #-} - --- | Map a free variable computation over a list and union the results. -mapUnionFV :: (a -> FV) -> [a] -> FV -mapUnionFV _f [] _fv_cand _in_scope acc = acc -mapUnionFV f (a:as) fv_cand in_scope acc = - mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc -{-# INLINABLE mapUnionFV #-} - --- | Union many free variable computations. -unionsFV :: [FV] -> FV -unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc -{-# INLINE unionsFV #-} - --- | Add multiple variables - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -mkFVs :: [Var] -> FV -mkFVs vars fv_cand in_scope acc = - mapUnionFV unitFV vars fv_cand in_scope acc -{-# INLINE mkFVs #-} diff --git a/utils/FastFunctions.hs b/utils/FastFunctions.hs deleted file mode 100644 --- a/utils/FastFunctions.hs +++ /dev/null @@ -1,21 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 --} - -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} - -module FastFunctions ( - inlinePerformIO, - ) where - -#include "HsVersions.h" - -import GhcPrelude () - -import GHC.Exts -import GHC.IO (IO(..)) - --- Just like unsafeDupablePerformIO, but we inline it. -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/utils/FastMutInt.hs b/utils/FastMutInt.hs deleted file mode 100644 --- a/utils/FastMutInt.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O2 #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected --- --- (c) The University of Glasgow 2002-2006 --- --- Unboxed mutable Ints - -module FastMutInt( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt, - - FastMutPtr, newFastMutPtr, - readFastMutPtr, writeFastMutPtr - ) where - -import GhcPrelude - -import Data.Bits -import GHC.Base -import GHC.Ptr - -newFastMutInt :: IO FastMutInt -readFastMutInt :: FastMutInt -> IO Int -writeFastMutInt :: FastMutInt -> Int -> IO () - -newFastMutPtr :: IO FastMutPtr -readFastMutPtr :: FastMutPtr -> IO (Ptr a) -writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () - -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where !(I# size) = finiteBitSize (0 :: Int) - -readFastMutInt (FastMutInt arr) = IO $ \s -> - case readIntArray# arr 0# s of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> - case writeIntArray# arr 0# i s of { s -> - (# s, () #) } - -data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) - -newFastMutPtr = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutPtr arr #) } - -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' - where !(I# size) = finiteBitSize (0 :: Int) - -readFastMutPtr (FastMutPtr arr) = IO $ \s -> - case readAddrArray# arr 0# s of { (# s, i #) -> - (# s, Ptr i #) } - -writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> - case writeAddrArray# arr 0# i s of { s -> - (# s, () #) } diff --git a/utils/FastString.hs b/utils/FastString.hs deleted file mode 100644 --- a/utils/FastString.hs +++ /dev/null @@ -1,693 +0,0 @@ --- (c) The University of Glasgow, 1997-2006 - -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, - GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- | --- There are two principal string types used internally by GHC: --- --- ['FastString'] --- --- * A compact, hash-consed, representation of character strings. --- * Comparison is O(1), and you can get a 'Unique.Unique' from them. --- * Generated by 'fsLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. --- --- ['PtrString'] --- --- * Pointer and size of a Latin-1 encoded string. --- * Practically no operations. --- * Outputing them is fast. --- * Generated by 'sLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' --- * Requires manual memory management. --- Improper use may lead to memory leaks or dangling pointers. --- * It assumes Latin-1 as the encoding, therefore it cannot represent --- arbitrary Unicode strings. --- --- Use 'PtrString' unless you want the facilities of 'FastString'. -module FastString - ( - -- * ByteString - bytesFS, -- :: FastString -> ByteString - fastStringToByteString, -- = bytesFS (kept for haddock) - mkFastStringByteString, - fastZStringToByteString, - unsafeMkByteString, - - -- * FastZString - FastZString, - hPutFZS, - zString, - lengthFZS, - - -- * FastStrings - FastString(..), -- not abstract, for now. - - -- ** Construction - fsLit, - mkFastString, - mkFastStringBytes, - mkFastStringByteList, - mkFastStringForeignPtr, - mkFastString#, - - -- ** Deconstruction - unpackFS, -- :: FastString -> String - - -- ** Encoding - zEncodeFS, - - -- ** Operations - uniqueOfFS, - lengthFS, - nullFS, - appendFS, - headFS, - tailFS, - concatFS, - consFS, - nilFS, - isUnderscoreFS, - - -- ** Outputing - hPutFS, - - -- ** Internal - getFastStringTable, - getFastStringZEncCounter, - - -- * PtrStrings - PtrString (..), - - -- ** Construction - sLit, - mkPtrString#, - mkPtrString, - - -- ** Deconstruction - unpackPtrString, - - -- ** Operations - lengthPS - ) where - -#include "HsVersions.h" - -import GhcPrelude as Prelude - -import Encoding -import FastFunctions -import PlainPanic -import Util - -import Control.Concurrent.MVar -import Control.DeepSeq -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Foreign.C -import GHC.Exts -import System.IO -import Data.Data -import Data.IORef -import Data.Char -import Data.Semigroup as Semi - -import GHC.IO - -import Foreign - -#if GHC_STAGE >= 2 -import GHC.Conc.Sync (sharedCAF) -#endif - -import GHC.Base ( unpackCString#, unpackNBytes# ) - - --- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' -bytesFS :: FastString -> ByteString -bytesFS f = fs_bs f - -{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-} -fastStringToByteString :: FastString -> ByteString -fastStringToByteString = bytesFS - -fastZStringToByteString :: FastZString -> ByteString -fastZStringToByteString (FastZString bs) = bs - --- This will drop information if any character > '\xFF' -unsafeMkByteString :: String -> ByteString -unsafeMkByteString = BSC.pack - -hashFastString :: FastString -> Int -hashFastString (FastString _ _ bs _) - = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - return $ hashStr (castPtr ptr) len - --- ----------------------------------------------------------------------------- - -newtype FastZString = FastZString ByteString - deriving NFData - -hPutFZS :: Handle -> FastZString -> IO () -hPutFZS handle (FastZString bs) = BS.hPut handle bs - -zString :: FastZString -> String -zString (FastZString bs) = - inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen - -lengthFZS :: FastZString -> Int -lengthFZS (FastZString bs) = BS.length bs - -mkFastZStringString :: String -> FastZString -mkFastZStringString str = FastZString (BSC.pack str) - --- ----------------------------------------------------------------------------- - -{-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All -'FastString's are stored in a global hashtable to support fast O(1) -comparison. - -It is also associated with a lazy reference to the Z-encoding -of this string which is used by the compiler internally. --} -data FastString = FastString { - uniq :: {-# UNPACK #-} !Int, -- unique id - n_chars :: {-# UNPACK #-} !Int, -- number of chars - fs_bs :: {-# UNPACK #-} !ByteString, - fs_zenc :: FastZString - -- ^ Lazily computed z-encoding of this string. - -- - -- Since 'FastString's are globally memoized this is computed at most - -- once for any given string. - } - -instance Eq FastString where - f1 == f2 = uniq f1 == uniq f2 - -instance Ord FastString where - -- Compares lexicographically, not by unique - a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } - a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } - a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } - a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } - max x y | x >= y = x - | otherwise = y - min x y | x <= y = x - | otherwise = y - compare a b = cmpFS a b - -instance IsString FastString where - fromString = fsLit - -instance Semi.Semigroup FastString where - (<>) = appendFS - -instance Monoid FastString where - mempty = nilFS - mappend = (Semi.<>) - mconcat = concatFS - -instance Show FastString where - show fs = show (unpackFS fs) - -instance Data FastString where - -- don't traverse? - toConstr _ = abstractConstr "FastString" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "FastString" - -instance NFData FastString where - rnf fs = seq fs () - -cmpFS :: FastString -> FastString -> Ordering -cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = - if u1 == u2 then EQ else - compare (bytesFS f1) (bytesFS f2) - -foreign import ccall unsafe "memcmp" - memcmp :: Ptr a -> Ptr b -> CSize -> IO CInt - --- ----------------------------------------------------------------------------- --- Construction - -{- -Internally, the compiler will maintain a fast string symbol table, providing -sharing and fast comparison. Creation of new @FastString@s then covertly does a -lookup, re-using the @FastString@ if there was a hit. - -The design of the FastString hash table allows for lockless concurrent reads -and updates to multiple buckets with low synchronization overhead. - -See Note [Updating the FastString table] on how it's updated. --} -data FastStringTable = FastStringTable - {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets - {-# UNPACK #-} !(IORef Int) -- number of computed z-encodings for all buckets - (Array# (IORef FastStringTableSegment)) -- concurrent segments - -data FastStringTableSegment = FastStringTableSegment - {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment - {-# UNPACK #-} !(IORef Int) -- the number of elements - (MutableArray# RealWorld [FastString]) -- buckets in this segment - -{- -Following parameters are determined based on: - -* Benchmark based on testsuite/tests/utils/should_run/T14854.hs -* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@: - on 2018-10-24, we have 13920 entries. --} -segmentBits, numSegments, segmentMask, initialNumBuckets :: Int -segmentBits = 8 -numSegments = 256 -- bit segmentBits -segmentMask = 0xff -- bit segmentBits - 1 -initialNumBuckets = 64 - -hashToSegment# :: Int# -> Int# -hashToSegment# hash# = hash# `andI#` segmentMask# - where - !(I# segmentMask#) = segmentMask - -hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int# -hashToIndex# buckets# hash# = - (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size# - where - !(I# segmentBits#) = segmentBits - size# = sizeofMutableArray# buckets# - -maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment -maybeResizeSegment segmentRef = do - segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef - let oldSize# = sizeofMutableArray# old# - newSize# = oldSize# *# 2# - (I# n#) <- readIORef counter - if isTrue# (n# <# newSize#) -- maximum load of 1 - then return segment - else do - resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# -> - case newArray# newSize# [] s1# of - (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #) - forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do - fsList <- IO $ readArray# old# i# - forM_ fsList $ \fs -> do - let -- Shall we store in hash value in FastString instead? - !(I# hash#) = hashFastString fs - idx# = hashToIndex# new# hash# - IO $ \s1# -> - case readArray# new# idx# s1# of - (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of - s3# -> (# s3#, () #) - writeIORef segmentRef resizedSegment - return resizedSegment - -{-# NOINLINE stringTable #-} -stringTable :: FastStringTable -stringTable = unsafePerformIO $ do - let !(I# numSegments#) = numSegments - !(I# initialNumBuckets#) = initialNumBuckets - loop a# i# s1# - | isTrue# (i# ==# numSegments#) = s1# - | otherwise = case newMVar () `unIO` s1# of - (# s2#, lock #) -> case newIORef 0 `unIO` s2# of - (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of - (# s4#, buckets# #) -> case newIORef - (FastStringTableSegment lock counter buckets#) `unIO` s4# of - (# s5#, segment #) -> case writeArray# a# i# segment s5# of - s6# -> loop a# (i# +# 1#) s6# - uid <- newIORef 603979776 -- ord '$' * 0x01000000 - n_zencs <- newIORef 0 - tab <- IO $ \s1# -> - case newArray# numSegments# (panic "string_table") s1# of - (# s2#, arr# #) -> case loop arr# 0# s2# of - s3# -> case unsafeFreezeArray# arr# s3# of - (# s4#, segments# #) -> - (# s4#, FastStringTable uid n_zencs segments# #) - - -- use the support wired into the RTS to share this CAF among all images of - -- libHSghc -#if GHC_STAGE < 2 - return tab -#else - sharedCAF tab getOrSetLibHSghcFastStringTable - --- from the RTS; thus we cannot use this mechanism when GHC_STAGE<2; the previous --- RTS might not have this symbol -foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" - getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) -#endif - -{- - -We include the FastString table in the `sharedCAF` mechanism because we'd like -FastStrings created by a Core plugin to have the same uniques as corresponding -strings created by the host compiler itself. For example, this allows plugins -to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or -even re-invoke the parser. - -In particular, the following little sanity test was failing in a plugin -prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not -be looked up /by the plugin/. - - let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" - putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts - -`mkTcOcc` involves the lookup (or creation) of a FastString. Since the -plugin's FastString.string_table is empty, constructing the RdrName also -allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These -uniques are almost certainly unequal to the ones that the host compiler -originally assigned to those FastStrings. Thus the lookup fails since the -domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's -unique. - -Maintaining synchronization of the two instances of this global is rather -difficult because of the uses of `unsafePerformIO` in this module. Not -synchronizing them risks breaking the rather major invariant that two -FastStrings with the same unique have the same string. Thus we use the -lower-level `sharedCAF` mechanism that relies on Globals.c. - --} - -mkFastString# :: Addr# -> FastString -mkFastString# a# = mkFastStringBytes ptr (fromIntegral (ptrStrLength ptr)) - where ptr = Ptr a# - -{- Note [Updating the FastString table] - -We use a concurrent hashtable which contains multiple segments, each hash value -always maps to the same segment. Read is lock-free, write to the a segment -should acquire a lock for that segment to avoid race condition, writes to -different segments are independent. - -The procedure goes like this: - -1. Find out which segment to operate on based on the hash value -2. Read the relevant bucket and perform a look up of the string. -3. If it exists, return it. -4. Otherwise grab a unique ID, create a new FastString and atomically attempt - to update the relevant segment with this FastString: - - * Resize the segment by doubling the number of buckets when the number of - FastStrings in this segment grows beyond the threshold. - * Double check that the string is not in the bucket. Another thread may have - inserted it while we were creating our string. - * Return the existing FastString if it exists. The one we preemptively - created will get GCed. - * Otherwise, insert and return the string we created. --} - -mkFastStringWith - :: (Int -> IORef Int-> IO FastString) -> Ptr Word8 -> Int -> IO FastString -mkFastStringWith mk_fs !ptr !len = do - FastStringTableSegment lock _ buckets# <- readIORef segmentRef - let idx# = hashToIndex# buckets# hash# - bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket len ptr - case res of - Just found -> return found - Nothing -> do - -- The withMVar below is not dupable. It can lead to deadlock if it is - -- only run partially and putMVar is not called after takeMVar. - noDuplicate - n <- get_uid - new_fs <- mk_fs n n_zencs - withMVar lock $ \_ -> insert new_fs - where - !(FastStringTable uid n_zencs segments#) = stringTable - get_uid = atomicModifyIORef' uid $ \n -> (n+1,n) - - !(I# hash#) = hashStr ptr len - (# segmentRef #) = indexArray# segments# (hashToSegment# hash#) - insert fs = do - FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef - let idx# = hashToIndex# buckets# hash# - bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket len ptr - case res of - -- The FastString was added by another thread after previous read and - -- before we acquired the write lock. - Just found -> return found - Nothing -> do - IO $ \s1# -> - case writeArray# buckets# idx# (fs: bucket) s1# of - s2# -> (# s2#, () #) - modifyIORef' counter succ - return fs - -bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) -bucket_match [] _ _ = return Nothing -bucket_match (v@(FastString _ _ bs _):ls) len ptr - | len == BS.length bs = do - b <- BS.unsafeUseAsCString bs $ \buf -> - cmpStringPrefix ptr (castPtr buf) len - if b then return (Just v) - else bucket_match ls len ptr - | otherwise = - bucket_match ls len ptr - -mkFastStringBytes :: Ptr Word8 -> Int -> FastString -mkFastStringBytes !ptr !len = - -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is - -- idempotent. - unsafeDupablePerformIO $ - mkFastStringWith (copyNewFastString ptr len) ptr len - --- | Create a 'FastString' from an existing 'ForeignPtr'; the difference --- between this and 'mkFastStringBytes' is that we don't have to copy --- the bytes if the string is new to the table. -mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString -mkFastStringForeignPtr ptr !fp len - = mkFastStringWith (mkNewFastString fp ptr len) ptr len - --- | Create a 'FastString' from an existing 'ForeignPtr'; the difference --- between this and 'mkFastStringBytes' is that we don't have to copy --- the bytes if the string is new to the table. -mkFastStringByteString :: ByteString -> FastString -mkFastStringByteString bs = - inlinePerformIO $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do - let ptr' = castPtr ptr - mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len - --- | Creates a UTF-8 encoded 'FastString' from a 'String' -mkFastString :: String -> FastString -mkFastString str = - inlinePerformIO $ do - let l = utf8EncodedLength str - buf <- mallocForeignPtrBytes l - withForeignPtr buf $ \ptr -> do - utf8EncodeString ptr str - mkFastStringForeignPtr ptr buf l - --- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ -mkFastStringByteList :: [Word8] -> FastString -mkFastStringByteList str = mkFastStringByteString (BS.pack str) - --- | Creates a (lazy) Z-encoded 'FastString' from a 'String' and account --- the number of forced z-strings into the passed 'IORef'. -mkZFastString :: IORef Int -> ByteString -> FastZString -mkZFastString n_zencs bs = unsafePerformIO $ do - atomicModifyIORef' n_zencs $ \n -> (n+1, ()) - return $ mkFastZStringString (zEncodeString (utf8DecodeByteString bs)) - -mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int - -> IORef Int -> IO FastString -mkNewFastString fp ptr len uid n_zencs = do - let bs = BS.fromForeignPtr fp 0 len - zstr = mkZFastString n_zencs bs - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars bs zstr) - -mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int - -> IORef Int -> IO FastString -mkNewFastStringByteString bs ptr len uid n_zencs = do - let zstr = mkZFastString n_zencs bs - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars bs zstr) - -copyNewFastString :: Ptr Word8 -> Int -> Int -> IORef Int -> IO FastString -copyNewFastString ptr len uid n_zencs = do - fp <- copyBytesToForeignPtr ptr len - let bs = BS.fromForeignPtr fp 0 len - zstr = mkZFastString n_zencs bs - n_chars <- countUTF8Chars ptr len - return (FastString uid n_chars bs zstr) - -copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) -copyBytesToForeignPtr ptr len = do - fp <- mallocForeignPtrBytes len - withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len - return fp - -cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool -cmpStringPrefix ptr1 ptr2 len = - do r <- memcmp ptr1 ptr2 (fromIntegral len) - return (r == 0) - -hashStr :: Ptr Word8 -> Int -> Int - -- use the Addr to produce a hash value between 0 & m (inclusive) -hashStr (Ptr a#) (I# len#) = loop 0# 0# - where - loop h n = - if isTrue# (n ==# len#) then - I# h - else - let - -- DO NOT move this let binding! indexCharOffAddr# reads from the - -- pointer so we need to evaluate this based on the length check - -- above. Not doing this right caused #17909. - !c = ord# (indexCharOffAddr# a# n) - !h2 = (h *# 16777619#) `xorI#` c - in - loop h2 (n +# 1#) - --- ----------------------------------------------------------------------------- --- Operations - --- | Returns the length of the 'FastString' in characters -lengthFS :: FastString -> Int -lengthFS f = n_chars f - --- | Returns @True@ if the 'FastString' is empty -nullFS :: FastString -> Bool -nullFS f = BS.null (fs_bs f) - --- | Unpacks and decodes the FastString -unpackFS :: FastString -> String -unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs - --- | Returns a Z-encoded version of a 'FastString'. This might be the --- original, if it was already Z-encoded. The first time this --- function is applied to a particular 'FastString', the results are --- memoized. --- -zEncodeFS :: FastString -> FastZString -zEncodeFS (FastString _ _ _ ref) = ref - -appendFS :: FastString -> FastString -> FastString -appendFS fs1 fs2 = mkFastStringByteString - $ BS.append (bytesFS fs1) (bytesFS fs2) - -concatFS :: [FastString] -> FastString -concatFS = mkFastStringByteString . BS.concat . map fs_bs - -headFS :: FastString -> Char -headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString" -headFS (FastString _ _ bs _) = - inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> - return (fst (utf8DecodeChar (castPtr ptr))) - -tailFS :: FastString -> FastString -tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString" -tailFS (FastString _ _ bs _) = - inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> - do let (_, n) = utf8DecodeChar (castPtr ptr) - return $! mkFastStringByteString (BS.drop n bs) - -consFS :: Char -> FastString -> FastString -consFS c fs = mkFastString (c : unpackFS fs) - -uniqueOfFS :: FastString -> Int -uniqueOfFS (FastString u _ _ _) = u - -nilFS :: FastString -nilFS = mkFastString "" - -isUnderscoreFS :: FastString -> Bool -isUnderscoreFS fs = fs == fsLit "_" - --- ----------------------------------------------------------------------------- --- Stats - -getFastStringTable :: IO [[[FastString]]] -getFastStringTable = - forM [0 .. numSegments - 1] $ \(I# i#) -> do - let (# segmentRef #) = indexArray# segments# i# - FastStringTableSegment _ _ buckets# <- readIORef segmentRef - let bucketSize = I# (sizeofMutableArray# buckets#) - forM [0 .. bucketSize - 1] $ \(I# j#) -> - IO $ readArray# buckets# j# - where - !(FastStringTable _ _ segments#) = stringTable - -getFastStringZEncCounter :: IO Int -getFastStringZEncCounter = readIORef n_zencs - where - !(FastStringTable _ n_zencs _) = stringTable - --- ----------------------------------------------------------------------------- --- Outputting 'FastString's - --- |Outputs a 'FastString' with /no decoding at all/, that is, you --- get the actual bytes in the 'FastString' written to the 'Handle'. -hPutFS :: Handle -> FastString -> IO () -hPutFS handle fs = BS.hPut handle $ bytesFS fs - --- ToDo: we'll probably want an hPutFSLocal, or something, to output --- in the current locale's encoding (for error messages and suchlike). - --- ----------------------------------------------------------------------------- --- PtrStrings, here for convenience only. - --- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. -data PtrString = PtrString !(Ptr Word8) !Int - --- | Wrap an unboxed address into a 'PtrString'. -mkPtrString# :: Addr# -> PtrString -mkPtrString# a# = PtrString (Ptr a#) (fromIntegral (ptrStrLength (Ptr a#))) - --- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 --- encoding. The original string must not contain non-Latin-1 characters --- (above codepoint @0xff@). -{-# INLINE mkPtrString #-} -mkPtrString :: String -> PtrString -mkPtrString s = - -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks - -- and because someone might be using `eqAddr#` to check for string equality. - unsafePerformIO (do - let len = length s - p <- mallocBytes len - let - loop :: Int -> String -> IO () - loop !_ [] = return () - loop n (c:cs) = do - pokeByteOff p n (fromIntegral (ord c) :: Word8) - loop (1+n) cs - loop 0 s - return (PtrString p len) - ) - --- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. --- This does not free the memory associated with 'PtrString'. -unpackPtrString :: PtrString -> String -unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# - --- | Return the length of a 'PtrString' -lengthPS :: PtrString -> Int -lengthPS (PtrString _ n) = n - --- ----------------------------------------------------------------------------- --- under the carpet - -foreign import ccall unsafe "strlen" - ptrStrLength :: Ptr Word8 -> CSize - -{-# NOINLINE sLit #-} -sLit :: String -> PtrString -sLit x = mkPtrString x - -{-# NOINLINE fsLit #-} -fsLit :: String -> FastString -fsLit x = mkFastString x - -{-# RULES "slit" - forall x . sLit (unpackCString# x) = mkPtrString# x #-} -{-# RULES "fslit" - forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/utils/FastStringEnv.hs b/utils/FastStringEnv.hs deleted file mode 100644 --- a/utils/FastStringEnv.hs +++ /dev/null @@ -1,100 +0,0 @@ -{- -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[FastStringEnv]{@FastStringEnv@: FastString environments} --} - -module FastStringEnv ( - -- * FastString environments (maps) - FastStringEnv, - - -- ** Manipulating these environments - mkFsEnv, - emptyFsEnv, unitFsEnv, - extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, - extendFsEnvList, extendFsEnvList_C, - filterFsEnv, - plusFsEnv, plusFsEnv_C, alterFsEnv, - lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, - elemFsEnv, mapFsEnv, - - -- * Deterministic FastString environments (maps) - DFastStringEnv, - - -- ** Manipulating these environments - mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv - ) where - -import GhcPrelude - -import UniqFM -import UniqDFM -import Maybes -import FastString - - --- | A non-deterministic set of FastStrings. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not --- deterministic and why it matters. Use DFastStringEnv if the set eventually --- gets converted into a list or folded over in a way where the order --- changes the generated code. -type FastStringEnv a = UniqFM a -- Domain is FastString - -emptyFsEnv :: FastStringEnv a -mkFsEnv :: [(FastString,a)] -> FastStringEnv a -alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a -extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a -extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b -extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a -plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a -plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a -extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a -extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a -delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a -delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a -elemFsEnv :: FastString -> FastStringEnv a -> Bool -unitFsEnv :: FastString -> a -> FastStringEnv a -lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a -lookupFsEnv_NF :: FastStringEnv a -> FastString -> a -filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt -mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 - -emptyFsEnv = emptyUFM -unitFsEnv x y = unitUFM x y -extendFsEnv x y z = addToUFM x y z -extendFsEnvList x l = addListToUFM x l -lookupFsEnv x y = lookupUFM x y -alterFsEnv = alterUFM -mkFsEnv l = listToUFM l -elemFsEnv x y = elemUFM x y -plusFsEnv x y = plusUFM x y -plusFsEnv_C f x y = plusUFM_C f x y -extendFsEnv_C f x y z = addToUFM_C f x y z -mapFsEnv f x = mapUFM f x -extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b -extendFsEnvList_C x y z = addListToUFM_C x y z -delFromFsEnv x y = delFromUFM x y -delListFromFsEnv x y = delListFromUFM x y -filterFsEnv x y = filterUFM x y - -lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) - --- Deterministic FastStringEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DFastStringEnv. - -type DFastStringEnv a = UniqDFM a -- Domain is FastString - -emptyDFsEnv :: DFastStringEnv a -emptyDFsEnv = emptyUDFM - -dFsEnvElts :: DFastStringEnv a -> [a] -dFsEnvElts = eltsUDFM - -mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a -mkDFsEnv l = listToUDFM l - -lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a -lookupDFsEnv = lookupUDFM diff --git a/utils/Fingerprint.hs b/utils/Fingerprint.hs deleted file mode 100644 --- a/utils/Fingerprint.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ---------------------------------------------------------------------------- --- --- (c) The University of Glasgow 2006 --- --- Fingerprints for recompilation checking and ABI versioning. --- --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance --- --- ---------------------------------------------------------------------------- - -module Fingerprint ( - readHexFingerprint, - fingerprintByteString, - -- * Re-exported from GHC.Fingerprint - Fingerprint(..), fingerprint0, - fingerprintFingerprints, - fingerprintData, - fingerprintString, - getFileHash - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Foreign -import GHC.IO -import Numeric ( readHex ) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS - -import GHC.Fingerprint - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - -fingerprintByteString :: BS.ByteString -> Fingerprint -fingerprintByteString bs = unsafeDupablePerformIO $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/utils/FiniteMap.hs b/utils/FiniteMap.hs deleted file mode 100644 --- a/utils/FiniteMap.hs +++ /dev/null @@ -1,31 +0,0 @@ --- Some extra functions to extend Data.Map - -module FiniteMap ( - insertList, - insertListWith, - deleteList, - foldRight, foldRightWithKey - ) where - -import GhcPrelude - -import Data.Map (Map) -import qualified Data.Map as Map - -insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt -insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs - -insertListWith :: Ord key - => (elt -> elt -> elt) - -> [(key,elt)] - -> Map key elt - -> Map key elt -insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs - -deleteList :: Ord key => [key] -> Map key elt -> Map key elt -deleteList ks m = foldl' (flip Map.delete) m ks - -foldRight :: (elt -> a -> a) -> a -> Map key elt -> a -foldRight = Map.foldr -foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a -foldRightWithKey = Map.foldrWithKey diff --git a/utils/GhcPrelude.hs b/utils/GhcPrelude.hs deleted file mode 100644 --- a/utils/GhcPrelude.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Custom GHC "Prelude" --- --- This module serves as a replacement for the "Prelude" module --- and abstracts over differences between the bootstrapping --- GHC version, and may also provide a common default vocabulary. - --- Every module in GHC --- * Is compiled with -XNoImplicitPrelude --- * Explicitly imports GhcPrelude - -module GhcPrelude (module X) where - --- We export the 'Semigroup' class but w/o the (<>) operator to avoid --- clashing with the (Outputable.<>) operator which is heavily used --- through GHC's code-base. - -import Prelude as X hiding ((<>)) -import Data.Foldable as X (foldl') - -{- -Note [Why do we import Prelude here?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and -ghc-heap.cabal contain the directive default-extensions: -NoImplicitPrelude. There are two motivations for this: - - Consistency with the compiler directory, which enables - NoImplicitPrelude; - - Allows loading the above dependent packages with ghc-in-ghci, - giving a smoother development experience when adding new - extensions. --} diff --git a/utils/GraphBase.hs b/utils/GraphBase.hs deleted file mode 100644 --- a/utils/GraphBase.hs +++ /dev/null @@ -1,107 +0,0 @@ - --- | Types for the general graph colorer. -module GraphBase ( - Triv, - Graph (..), - initGraph, - graphMapModify, - - Node (..), newNode, -) - - -where - -import GhcPrelude - -import UniqSet -import UniqFM - - --- | A fn to check if a node is trivially colorable --- For graphs who's color classes are disjoint then a node is 'trivially colorable' --- when it has less neighbors and exclusions than available colors for that node. --- --- For graph's who's color classes overlap, ie some colors alias other colors, then --- this can be a bit more tricky. There is a general way to calculate this, but --- it's likely be too slow for use in the code. The coloring algorithm takes --- a canned function which can be optimised by the user to be specific to the --- specific graph being colored. --- --- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" --- Smith, Ramsey, Holloway - PLDI 2004. --- -type Triv k cls color - = cls -- the class of the node we're trying to color. - -> UniqSet k -- the node's neighbors. - -> UniqSet color -- the node's exclusions. - -> Bool - - --- | The Interference graph. --- There used to be more fields, but they were turfed out in a previous revision. --- maybe we'll want more later.. --- -data Graph k cls color - = Graph { - -- | All active nodes in the graph. - graphMap :: UniqFM (Node k cls color) } - - --- | An empty graph. -initGraph :: Graph k cls color -initGraph - = Graph - { graphMap = emptyUFM } - - --- | Modify the finite map holding the nodes in the graph. -graphMapModify - :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color)) - -> Graph k cls color -> Graph k cls color - -graphMapModify f graph - = graph { graphMap = f (graphMap graph) } - - - --- | Graph nodes. --- Represents a thing that can conflict with another thing. --- For the register allocater the nodes represent registers. --- -data Node k cls color - = Node { - -- | A unique identifier for this node. - nodeId :: k - - -- | The class of this node, - -- determines the set of colors that can be used. - , nodeClass :: cls - - -- | The color of this node, if any. - , nodeColor :: Maybe color - - -- | Neighbors which must be colored differently to this node. - , nodeConflicts :: UniqSet k - - -- | Colors that cannot be used by this node. - , nodeExclusions :: UniqSet color - - -- | Colors that this node would prefer to be, in decending order. - , nodePreference :: [color] - - -- | Neighbors that this node would like to be colored the same as. - , nodeCoalesce :: UniqSet k } - - --- | An empty node. -newNode :: k -> cls -> Node k cls color -newNode k cls - = Node - { nodeId = k - , nodeClass = cls - , nodeColor = Nothing - , nodeConflicts = emptyUniqSet - , nodeExclusions = emptyUniqSet - , nodePreference = [] - , nodeCoalesce = emptyUniqSet } diff --git a/utils/GraphColor.hs b/utils/GraphColor.hs deleted file mode 100644 --- a/utils/GraphColor.hs +++ /dev/null @@ -1,373 +0,0 @@ --- | Graph Coloring. --- This is a generic graph coloring library, abstracted over the type of --- the node keys, nodes and colors. --- - -module GraphColor ( - module GraphBase, - module GraphOps, - module GraphPpr, - colorGraph -) - -where - -import GhcPrelude - -import GraphBase -import GraphOps -import GraphPpr - -import Unique -import UniqFM -import UniqSet -import Outputable - -import Data.Maybe -import Data.List - - --- | Try to color a graph with this set of colors. --- Uses Chaitin's algorithm to color the graph. --- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes --- are pushed onto a stack and removed from the graph. --- Once this process is complete the graph can be colored by removing nodes from --- the stack (ie in reverse order) and assigning them colors different to their neighbors. --- -colorGraph - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq cls, Ord k - , Outputable k, Outputable cls, Outputable color) - => Bool -- ^ whether to do iterative coalescing - -> Int -- ^ how many times we've tried to color this graph so far. - -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to color. - - -> ( Graph k cls color -- the colored graph. - , UniqSet k -- the set of nodes that we couldn't find a color for. - , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced - -- r1 should be replaced by r2 in the source - -colorGraph iterative spinCount colors triv spill graph0 - = let - -- If we're not doing iterative coalescing then do an aggressive coalescing first time - -- around and then conservative coalescing for subsequent passes. - -- - -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if - -- there is a lot of register pressure and we do it on every round then it can make the - -- graph less colorable and prevent the algorithm from converging in a sensible number - -- of cycles. - -- - (graph_coalesced, kksCoalesce1) - = if iterative - then (graph0, []) - else if spinCount == 0 - then coalesceGraph True triv graph0 - else coalesceGraph False triv graph0 - - -- run the scanner to slurp out all the trivially colorable nodes - -- (and do coalescing if iterative coalescing is enabled) - (ksTriv, ksProblems, kksCoalesce2) - = colorScan iterative triv spill graph_coalesced - - -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. - -- We need to apply all the coalescences found by the scanner to the original - -- graph before doing assignColors. - -- - -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing - -- to force all the (conservative) coalescences found during scanning. - -- - (graph_scan_coalesced, _) - = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 - - -- color the trivially colorable nodes - -- during scanning, keys of triv nodes were added to the front of the list as they were found - -- this colors them in the reverse order, as required by the algorithm. - (graph_triv, ksNoTriv) - = assignColors colors graph_scan_coalesced ksTriv - - -- try and color the problem nodes - -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. - (graph_prob, ksNoColor) - = assignColors colors graph_triv ksProblems - - -- if the trivially colorable nodes didn't color then something is probably wrong - -- with the provided triv function. - -- - in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty - ( empty - $$ text "ksTriv = " <> ppr ksTriv - $$ text "ksNoTriv = " <> ppr ksNoTriv - $$ text "colors = " <> ppr colors - $$ empty - $$ dotGraph (\_ -> text "white") triv graph_triv) - - else ( graph_prob - , mkUniqSet ksNoColor -- the nodes that didn't color (spills) - , if iterative - then (listToUFM kksCoalesce2) - else (listToUFM kksCoalesce1)) - - --- | Scan through the conflict graph separating out trivially colorable and --- potentially uncolorable (problem) nodes. --- --- Checking whether a node is trivially colorable or not is a reasonably expensive operation, --- so after a triv node is found and removed from the graph it's no good to return to the 'start' --- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. --- --- To ward against this, during each pass through the graph we collect up a list of triv nodes --- that were found, and only remove them once we've finished the pass. The more nodes we can delete --- at once the more likely it is that nodes we've already checked will become trivially colorable --- for the next pass. --- --- TODO: add work lists to finding triv nodes is easier. --- If we've just scanned the graph, and removed triv nodes, then the only --- nodes that we need to rescan are the ones we've removed edges from. - -colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool -- ^ whether to do iterative coalescing - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to scan - - -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce - -colorScan iterative triv spill graph - = colorScan_spin iterative triv spill graph [] [] [] - -colorScan_spin - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spin iterative triv spill graph - ksTriv ksSpill kksCoalesce - - -- if the graph is empty then we're done - | isNullUFM $ graphMap graph - = (ksTriv, ksSpill, reverse kksCoalesce) - - -- Simplify: - -- Look for trivially colorable nodes. - -- If we can find some then remove them from the graph and go back for more. - -- - | nsTrivFound@(_:_) - <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - -- for iterative coalescing we only want non-move related - -- nodes here - && (not iterative || isEmptyUniqSet (nodeCoalesce node))) - $ graph - - , ksTrivFound <- map nodeId nsTrivFound - , graph2 <- foldr (\k g -> let Just g' = delNode k g - in g') - graph ksTrivFound - - = colorScan_spin iterative triv spill graph2 - (ksTrivFound ++ ksTriv) - ksSpill - kksCoalesce - - -- Coalesce: - -- If we're doing iterative coalescing and no triv nodes are available - -- then it's time for a coalescing pass. - | iterative - = case coalesceGraph False triv graph of - - -- we were able to coalesce something - -- go back to Simplify and see if this frees up more nodes to be trivially colorable. - (graph2, kksCoalesceFound@(_:_)) - -> colorScan_spin iterative triv spill graph2 - ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) - - -- Freeze: - -- nothing could be coalesced (or was triv), - -- time to choose a node to freeze and give up on ever coalescing it. - (graph2, []) - -> case freezeOneInGraph graph2 of - - -- we were able to freeze something - -- hopefully this will free up something for Simplify - (graph3, True) - -> colorScan_spin iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- we couldn't find something to freeze either - -- time for a spill - (graph3, False) - -> colorScan_spill iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- spill time - | otherwise - = colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - --- Select: --- we couldn't find any triv nodes or things to freeze or coalesce, --- and the graph isn't empty yet.. We'll have to choose a spill --- candidate and leave it uncolored. --- -colorScan_spill - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool - -> Triv k cls color - -> (Graph k cls color -> k) - -> Graph k cls color - -> [k] - -> [k] - -> [(k, k)] - -> ([k], [k], [(k, k)]) - -colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce - - = let kSpill = spill graph - Just graph' = delNode kSpill graph - in colorScan_spin iterative triv spill graph' - ksTriv (kSpill : ksSpill) kksCoalesce - - --- | Try to assign a color to all these nodes. - -assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> [k] -- ^ nodes to assign a color to. - -> ( Graph k cls color -- the colored graph - , [k]) -- the nodes that didn't color. - -assignColors colors graph ks - = assignColors' colors graph [] ks - - where assignColors' _ graph prob [] - = (graph, prob) - - assignColors' colors graph prob (k:ks) - = case assignColor colors k graph of - - -- couldn't color this node - Nothing -> assignColors' colors graph (k : prob) ks - - -- this node colored ok, so do the rest - Just graph' -> assignColors' colors graph' prob ks - - - assignColor colors u graph - | Just c <- selectColor colors graph u - = Just (setColor u c graph) - - | otherwise - = Nothing - - - --- | Select a color for a certain node --- taking into account preferences, neighbors and exclusions. --- returns Nothing if no color can be assigned to this node. --- -selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color - , Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> k -- ^ key of the node to select a color for. - -> Maybe color - -selectColor colors graph u - = let -- lookup the node - Just node = lookupNode graph u - - -- lookup the available colors for the class of this node. - colors_avail - = case lookupUFM colors (nodeClass node) of - Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) - Just cs -> cs - - -- find colors we can't use because they're already being used - -- by a node that conflicts with this one. - Just nsConflicts - = sequence - $ map (lookupNode graph) - $ nonDetEltsUniqSet - $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts - - -- the prefs of our neighbors - colors_neighbor_prefs - = mkUniqSet - $ concat $ map nodePreference nsConflicts - - -- colors that are still valid for us - colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) - colors_ok = minusUniqSet colors_ok_ex colors_conflict - - -- the colors that we prefer, and are still ok - colors_ok_pref = intersectUniqSets - (mkUniqSet $ nodePreference node) colors_ok - - -- the colors that we could choose while being nice to our neighbors - colors_ok_nice = minusUniqSet - colors_ok colors_neighbor_prefs - - -- the best of all possible worlds.. - colors_ok_pref_nice - = intersectUniqSets - colors_ok_nice colors_ok_pref - - -- make the decision - chooseColor - - -- everyone is happy, yay! - | not $ isEmptyUniqSet colors_ok_pref_nice - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) - (nodePreference node) - = Just c - - -- we've got one of our preferences - | not $ isEmptyUniqSet colors_ok_pref - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) - (nodePreference node) - = Just c - - -- it wasn't a preference, but it was still ok - | not $ isEmptyUniqSet colors_ok - , c : _ <- nonDetEltsUniqSet colors_ok - -- See Note [Unique Determinism and code generation] - = Just c - - -- no colors were available for us this time. - -- looks like we're going around the loop again.. - | otherwise - = Nothing - - in chooseColor - - - diff --git a/utils/GraphOps.hs b/utils/GraphOps.hs deleted file mode 100644 --- a/utils/GraphOps.hs +++ /dev/null @@ -1,680 +0,0 @@ --- | Basic operations on graphs. --- - -module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount -) -where - -import GhcPrelude - -import GraphBase - -import Outputable -import Unique -import UniqSet -import UniqFM - -import Data.List hiding (union) -import Data.Maybe - --- | Lookup a node from the graph. -lookupNode - :: Uniquable k - => Graph k cls color - -> k -> Maybe (Node k cls color) - -lookupNode graph k - = lookupUFM (graphMap graph) k - - --- | Get a node from the graph, throwing an error if it's not there -getNode - :: Uniquable k - => Graph k cls color - -> k -> Node k cls color - -getNode graph k - = case lookupUFM (graphMap graph) k of - Just node -> node - Nothing -> panic "ColorOps.getNode: not found" - - --- | Add a node to the graph, linking up its edges -addNode :: Uniquable k - => k -> Node k cls color - -> Graph k cls color -> Graph k cls color - -addNode k node graph - = let - -- add back conflict edges from other nodes to this one - map_conflict = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeConflicts = - addOneToUniqSet (nodeConflicts n) k})) - (graphMap graph) - (nodeConflicts node) - - -- add back coalesce edges from other nodes to this one - map_coalesce = - nonDetFoldUniqSet - -- It's OK to use nonDetFoldUFM here because the - -- operation is commutative - (adjustUFM_C (\n -> n { nodeCoalesce = - addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - - --- | Delete a node and all its edges from the graph. -delNode :: (Uniquable k) - => k -> Graph k cls color -> Maybe (Graph k cls color) - -delNode k graph - | Just node <- lookupNode graph k - = let -- delete conflict edges from other nodes to this one. - graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph - $ nonDetEltsUniqSet (nodeConflicts node) - - -- delete coalesce edge from other nodes to this one. - graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 - $ nonDetEltsUniqSet (nodeCoalesce node) - -- See Note [Unique Determinism and code generation] - - -- delete the node - graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 - - in Just graph3 - - | otherwise - = Nothing - - --- | Modify a node in the graph. --- returns Nothing if the node isn't present. --- -modNode :: Uniquable k - => (Node k cls color -> Node k cls color) - -> k -> Graph k cls color -> Maybe (Graph k cls color) - -modNode f k graph - = case lookupNode graph k of - Just Node{} - -> Just - $ graphMapModify - (\fm -> let Just node = lookupUFM fm k - node' = f node - in addToUFM fm k node') - graph - - Nothing -> Nothing - - --- | Get the size of the graph, O(n) -size :: Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - - --- | Union two graphs together. -union :: Graph k cls color -> Graph k cls color -> Graph k cls color - -union graph1 graph2 - = Graph - { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } - - --- | Add a conflict between nodes to the graph, creating the nodes required. --- Conflicts are virtual regs which need to be colored differently. -addConflict - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addConflict (u1, c1) (u2, c2) - = let addNeighbor u c u' - = adjustWithDefaultUFM - (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) - (newNode u c) { nodeConflicts = unitUniqSet u' } - u - - in graphMapModify - ( addNeighbor u1 c1 u2 - . addNeighbor u2 c2 u1) - - --- | Delete a conflict edge. k1 -> k2 --- returns Nothing if the node isn't in the graph -delConflict - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delConflict k1 k2 - = modNode - (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) - k1 - - --- | Add some conflicts to the graph, creating nodes if required. --- All the nodes in the set are taken to conflict with each other. -addConflicts - :: Uniquable k - => UniqSet k -> (k -> cls) - -> Graph k cls color -> Graph k cls color - -addConflicts conflicts getClass - - -- just a single node, but no conflicts, create the node anyway. - | (u : []) <- nonDetEltsUniqSet conflicts - = graphMapModify - $ adjustWithDefaultUFM - id - (newNode u (getClass u)) - u - - | otherwise - = graphMapModify - $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm - $ nonDetEltsUniqSet conflicts - -- See Note [Unique Determinism and code generation] - - -addConflictSet1 :: Uniquable k - => k -> (k -> cls) -> UniqSet k - -> UniqFM (Node k cls color) - -> UniqFM (Node k cls color) -addConflictSet1 u getClass set - = case delOneFromUniqSet set u of - set' -> adjustWithDefaultUFM - (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) - (newNode u (getClass u)) { nodeConflicts = set' } - u - - --- | Add an exclusion to the graph, creating nodes if required. --- These are extra colors that the node cannot use. -addExclusion - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> color - -> Graph k cls color -> Graph k cls color - -addExclusion u getClass color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) - (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } - u - -addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color - -addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors - - --- | Add a coalescence edge to the graph, creating nodes if requried. --- It is considered adventageous to assign the same color to nodes in a coalesence. -addCoalesce - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addCoalesce (u1, c1) (u2, c2) - = let addCoalesce u c u' - = adjustWithDefaultUFM - (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) - (newNode u c) { nodeCoalesce = unitUniqSet u' } - u - - in graphMapModify - ( addCoalesce u1 c1 u2 - . addCoalesce u2 c2 u1) - - --- | Delete a coalescence edge (k1 -> k2) from the graph. -delCoalesce - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - -delCoalesce k1 k2 - = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) - k1 - - --- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most prefered. --- The algorithm tries to assign a node it's prefered color if possible. --- -addPreference - :: Uniquable k - => (k, cls) -> color - -> Graph k cls color -> Graph k cls color - -addPreference (u, c) color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodePreference = color : (nodePreference node) }) - (newNode u c) { nodePreference = [color] } - u - - --- | Do aggressive coalescing on this graph. --- returns the new graph and the list of pairs of nodes that got coalesced together. --- for each pair, the resulting node will have the least key and be second in the pair. --- -coalesceGraph - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> ( Graph k cls color - , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. - -coalesceGraph aggressive triv graph - = coalesceGraph' aggressive triv graph [] - -coalesceGraph' - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool - -> Triv k cls color - -> Graph k cls color - -> [(k, k)] - -> ( Graph k cls color - , [(k, k)]) -coalesceGraph' aggressive triv graph kkPairsAcc - = let - -- find all the nodes that have coalescence edges - cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - -- build a list of pairs of keys for node's we'll try and coalesce - -- every pair of nodes will appear twice in this list - -- ie [(k1, k2), (k2, k1) ... ] - -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for - -- build a list of what nodes get coalesced together for later on. - -- - cList = [ (nodeId node1, k2) - | node1 <- cNodes - , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] - -- See Note [Unique Determinism and code generation] - - -- do the coalescing, returning the new graph and a list of pairs of keys - -- that got coalesced together. - (graph', mPairs) - = mapAccumL (coalesceNodes aggressive triv) graph cList - - -- keep running until there are no more coalesces can be found - in case catMaybes mPairs of - [] -> (graph', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) - - --- | Coalesce this pair of nodes unconditionally \/ aggressively. --- The resulting node is the one with the least key. --- --- returns: Just the pair of keys if the nodes were coalesced --- the second element of the pair being the least one --- --- Nothing if either of the nodes weren't in the graph - -coalesceNodes - :: (Uniquable k, Ord k, Eq cls) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> (k, k) -- ^ keys of the nodes to be coalesced - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes aggressive triv graph (k1, k2) - | (kMin, kMax) <- if k1 < k2 - then (k1, k2) - else (k2, k1) - - -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax - - -- can't coalesce conflicting modes - , not $ elementOfUniqSet kMin (nodeConflicts nMax) - , not $ elementOfUniqSet kMax (nodeConflicts nMin) - - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax - - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) - -coalesceNodes_merge - :: (Uniquable k, Eq cls) - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- sanity checks - | nodeClass nMin /= nodeClass nMax - = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." - - | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) - = error "GraphOps.coalesceNodes: can't coalesce colored nodes." - - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing - - -- nodes don't conflict with themselves.. - , nodeConflicts - = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - - , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) - , nodePreference = nodePreference nMin ++ nodePreference nMax - - -- nodes don't coalesce with themselves.. - , nodeCoalesce - = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - } - - in coalesceNodes_check aggressive triv graph kMin kMax node - -coalesceNodes_check - :: Uniquable k - => Bool - -> Triv k cls color - -> Graph k cls color - -> k -> k - -> Node k cls color - -> (Graph k cls color, Maybe (k, k)) - -coalesceNodes_check aggressive triv graph kMin kMax node - - -- Unless we're coalescing aggressively, if the result node is not trivially - -- colorable then don't do the coalescing. - | not aggressive - , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = (graph, Nothing) - - | otherwise - = let -- delete the old nodes from the graph and add the new one - Just graph1 = delNode kMax graph - Just graph2 = delNode kMin graph1 - graph3 = addNode kMin node graph2 - - in (graph3, Just (kMax, kMin)) - - --- | Freeze a node --- This is for the iterative coalescer. --- By freezing a node we give up on ever coalescing it. --- Move all its coalesce edges into the frozen set - and update --- back edges from other nodes. --- -freezeNode - :: Uniquable k - => k -- ^ key of the node to freeze - -> Graph k cls color -- ^ the graph - -> Graph k cls color -- ^ graph with that node frozen - -freezeNode k - = graphMapModify - $ \fm -> - let -- freeze all the edges in the node to be frozen - Just node = lookupUFM fm k - node' = node - { nodeCoalesce = emptyUniqSet } - - fm1 = addToUFM fm k node' - - -- update back edges pointing to this node - freezeEdge k node - = if elementOfUniqSet k (nodeCoalesce node) - then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } - else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. - - fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - -- It's OK to use nonDetFoldUFM here because the operation - -- is commutative - $ nodeCoalesce node - - in fm2 - - --- | Freeze one node in the graph --- This if for the iterative coalescer. --- Look for a move related node of low degree and freeze it. --- --- We probably don't need to scan the whole graph looking for the node of absolute --- lowest degree. Just sample the first few and choose the one with the lowest --- degree out of those. Also, we don't make any distinction between conflicts of different --- classes.. this is just a heuristic, after all. --- --- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv --- right here, and add it to a worklist if known triv\/non-move nodes. --- -freezeOneInGraph - :: (Uniquable k) - => Graph k cls color - -> ( Graph k cls color -- the new graph - , Bool ) -- whether we found a node to freeze - -freezeOneInGraph graph - = let compareNodeDegree n1 n2 - = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) - - candidates - = sortBy compareNodeDegree - $ take 5 -- 5 isn't special, it's just a small number. - $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph - - in case candidates of - - -- there wasn't anything available to freeze - [] -> (graph, False) - - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) - - --- | Freeze all the nodes in the graph --- for debugging the iterative allocator. --- -freezeAllInGraph - :: (Uniquable k) - => Graph k cls color - -> Graph k cls color - -freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | Find all the nodes in the graph that meet some criteria --- -scanGraph - :: (Node k cls color -> Bool) - -> Graph k cls color - -> [Node k cls color] - -scanGraph match graph - = filter match $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - --- | validate the internal structure of a graph --- all its edges should point to valid nodes --- If they don't then throw an error --- -validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph - -validateGraph doc isColored graph - - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existent nodes" - $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ nonDetEltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph - - --- | If this node is colored, check that all the nodes which --- conflict with it have different colors. -checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - -checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ nonDetEltsUniqSet $ nodeConflicts node - -- See Note [Unique Determinism and code generation] - - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True - - - --- | Slurp out a map of how many nodes had a certain number of conflict neighbours - -slurpNodeConflictCount - :: Graph k cls color - -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) - -slurpNodeConflictCount graph - = addListToUFM_C - (\(c1, n1) (_, n2) -> (c1, n1 + n2)) - emptyUFM - $ map (\node - -> let count = sizeUniqSet $ nodeConflicts node - in (count, (count, 1))) - $ nonDetEltsUFM - -- See Note [Unique Determinism and code generation] - $ graphMap graph - - --- | Set the color of a certain node -setColor - :: Uniquable k - => k -> color - -> Graph k cls color -> Graph k cls color - -setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a - -adjustWithDefaultUFM f def k map - = addToUFM_C - (\old _ -> f old) - map - k def - --- Argument order different from UniqFM's adjustUFM -{-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a - -adjustUFM_C f k map - = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) - diff --git a/utils/GraphPpr.hs b/utils/GraphPpr.hs deleted file mode 100644 --- a/utils/GraphPpr.hs +++ /dev/null @@ -1,173 +0,0 @@ - --- | Pretty printing of graphs. - -module GraphPpr ( - dumpGraph, - dotGraph -) -where - -import GhcPrelude - -import GraphBase - -import Outputable -import Unique -import UniqSet -import UniqFM - -import Data.List (mapAccumL) -import Data.Maybe - - --- | Pretty print a graph in a somewhat human readable format. -dumpGraph - :: (Outputable k, Outputable color) - => Graph k cls color -> SDoc - -dumpGraph graph - = text "Graph" - $$ pprUFM (graphMap graph) (vcat . map dumpNode) - -dumpNode - :: (Outputable k, Outputable color) - => Node k cls color -> SDoc - -dumpNode node - = text "Node " <> ppr (nodeId node) - $$ text "conflicts " - <> parens (int (sizeUniqSet $ nodeConflicts node)) - <> text " = " - <> ppr (nodeConflicts node) - - $$ text "exclusions " - <> parens (int (sizeUniqSet $ nodeExclusions node)) - <> text " = " - <> ppr (nodeExclusions node) - - $$ text "coalesce " - <> parens (int (sizeUniqSet $ nodeCoalesce node)) - <> text " = " - <> ppr (nodeCoalesce node) - - $$ space - - - --- | Pretty print a graph in graphviz .dot format. --- Conflicts get solid edges. --- Coalescences get dashed edges. -dotGraph - :: ( Uniquable k - , Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) -- ^ What graphviz color to use for each node color - -- It's usually safe to return X11 style colors here, - -- ie "red", "green" etc or a hex triplet #aaff55 etc - -> Triv k cls color - -> Graph k cls color -> SDoc - -dotGraph colorMap triv graph - = let nodes = nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - in vcat - ( [ text "graph G {" ] - ++ map (dotNode colorMap triv) nodes - ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) - ++ [ text "}" - , space ]) - - -dotNode :: ( Outputable k, Outputable cls, Outputable color) - => (color -> SDoc) - -> Triv k cls color - -> Node k cls color -> SDoc - -dotNode colorMap triv node - = let name = ppr $ nodeId node - cls = ppr $ nodeClass node - - excludes - = hcat $ punctuate space - $ map (\n -> text "-" <> ppr n) - $ nonDetEltsUniqSet $ nodeExclusions node - -- See Note [Unique Determinism and code generation] - - preferences - = hcat $ punctuate space - $ map (\n -> text "+" <> ppr n) - $ nodePreference node - - expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] - then empty - else text "\\n" <> (excludes <+> preferences) - - -- if the node has been colored then show that, - -- otherwise indicate whether it looks trivially colorable. - color - | Just c <- nodeColor node - = text "\\n(" <> ppr c <> text ")" - - | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = text "\\n(" <> text "triv" <> text ")" - - | otherwise - = text "\\n(" <> text "spill?" <> text ")" - - label = name <> text " :: " <> cls - <> expref - <> color - - pcolorC = case nodeColor node of - Nothing -> text "style=filled fillcolor=white" - Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) - - - pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" - <> space <> doubleQuotes name - <> text ";" - - in pout - - --- | Nodes in the graph are doubly linked, but we only want one edge for each --- conflict if the graphviz graph. Traverse over the graph, but make sure --- to only print the edges for each node once. - -dotNodeEdges - :: ( Uniquable k - , Outputable k) - => UniqSet k - -> Node k cls color - -> (UniqSet k, Maybe SDoc) - -dotNodeEdges visited node - | elementOfUniqSet (nodeId node) visited - = ( visited - , Nothing) - - | otherwise - = let dconflicts - = map (dotEdgeConflict (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeConflicts node) visited - - dcoalesces - = map (dotEdgeCoalesce (nodeId node)) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ minusUniqSet (nodeCoalesce node) visited - - out = vcat dconflicts - $$ vcat dcoalesces - - in ( addOneToUniqSet visited (nodeId node) - , Just out) - - where dotEdgeConflict u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> text ";" - - dotEdgeCoalesce u1 u2 - = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) - <> space <> text "[ style = dashed ];" diff --git a/utils/IOEnv.hs b/utils/IOEnv.hs deleted file mode 100644 --- a/utils/IOEnv.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} --- --- (c) The University of Glasgow 2002-2006 --- --- The IO Monad with an environment --- --- The environment is passed around as a Reader monad but --- as its in the IO monad, mutable references can be used --- for updating state. --- - -module IOEnv ( - IOEnv, -- Instance of Monad - - -- Monad utilities - module MonadUtils, - - -- Errors - failM, failWithM, - IOEnvFailure(..), - - -- Getting at the environment - getEnv, setEnv, updEnv, - - runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, - tryM, tryAllM, tryMostM, fixM, - - -- I/O operations - IORef, newMutVar, readMutVar, writeMutVar, updMutVar, - atomicUpdMutVar, atomicUpdMutVar' - ) where - -import GhcPrelude - -import DynFlags -import Exception -import Module -import Panic - -import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, - atomicModifyIORef, atomicModifyIORef' ) -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO ( fixIO ) -import Control.Monad -import qualified Control.Monad.Fail as MonadFail -import MonadUtils -import Control.Applicative (Alternative(..)) -import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) -import Control.Concurrent (forkIO, killThread) - ----------------------------------------------------------------------- --- Defining the monad type ----------------------------------------------------------------------- - - -newtype IOEnv env a = IOEnv (env -> IO a) deriving (Functor) - -unIOEnv :: IOEnv env a -> (env -> IO a) -unIOEnv (IOEnv m) = m - -instance Monad (IOEnv m) where - (>>=) = thenM - (>>) = (*>) -#if !MIN_VERSION_base(4,13,0) - fail = MonadFail.fail -#endif - -instance MonadFail.MonadFail (IOEnv m) where - fail _ = failM -- Ignore the string - -instance Applicative (IOEnv m) where - pure = returnM - IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) - (*>) = thenM_ - -returnM :: a -> IOEnv env a -returnM a = IOEnv (\ _ -> return a) - -thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b -thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; - unIOEnv (f r) env }) - -thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b -thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) - -failM :: IOEnv env a -failM = IOEnv (\ _ -> throwIO IOEnvFailure) - -failWithM :: String -> IOEnv env a -failWithM s = IOEnv (\ _ -> ioError (userError s)) - -data IOEnvFailure = IOEnvFailure - -instance Show IOEnvFailure where - show IOEnvFailure = "IOEnv failure" - -instance Exception IOEnvFailure - -instance ExceptionMonad (IOEnv a) where - gcatch act handle = - IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s - gmask f = - IOEnv $ \s -> gmask $ \io_restore -> - let - g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s) - in - unIOEnv (f g_restore) s - -instance ContainsDynFlags env => HasDynFlags (IOEnv env) where - getDynFlags = do env <- getEnv - return $! extractDynFlags env - -instance ContainsModule env => HasModule (IOEnv env) where - getModule = do env <- getEnv - return $ extractModule env - ----------------------------------------------------------------------- --- Fundamental combinators specific to the monad ----------------------------------------------------------------------- - - ---------------------------- -runIOEnv :: env -> IOEnv env a -> IO a -runIOEnv env (IOEnv m) = m env - - ---------------------------- -{-# NOINLINE fixM #-} - -- Aargh! Not inlining fixM alleviates a space leak problem. - -- Normally fixM is used with a lazy tuple match: if the optimiser is - -- shown the definition of fixM, it occasionally transforms the code - -- in such a way that the code generator doesn't spot the selector - -- thunks. Sigh. - -fixM :: (a -> IOEnv env a) -> IOEnv env a -fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) - - ---------------------------- -tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) --- Reflect UserError exceptions (only) into IOEnv monad --- Other exceptions are not caught; they are simply propagated as exns --- --- The idea is that errors in the program being compiled will give rise --- to UserErrors. But, say, pattern-match failures in GHC itself should --- not be caught here, else they'll be reported as errors in the program --- begin compiled! -tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) - -tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) -tryIOEnvFailure = try - -tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) --- Catch *all* synchronous exceptions --- This is used when running a Template-Haskell splice, when --- even a pattern-match failure is a programmer error -tryAllM (IOEnv thing) = IOEnv (\ env -> safeTry (thing env)) - --- | Like 'try', but doesn't catch asynchronous exceptions -safeTry :: IO a -> IO (Either SomeException a) -safeTry act = do - var <- newEmptyMVar - -- uninterruptible because we want to mask around 'killThread', which is interruptible. - uninterruptibleMask $ \restore -> do - -- Fork, so that 'act' is safe from all asynchronous exceptions other than the ones we send it - t <- forkIO $ try (restore act) >>= putMVar var - restore (readMVar var) - `catch` \(e :: SomeException) -> do - -- Control reaches this point only if the parent thread was sent an async exception - -- In that case, kill the 'act' thread and re-raise the exception - killThread t - throwIO e - -tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) -tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) - ---------------------------- -unsafeInterleaveM :: IOEnv env a -> IOEnv env a -unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) - -uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a -uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) - ----------------------------------------------------------------------- --- Alternative/MonadPlus ----------------------------------------------------------------------- - -instance Alternative (IOEnv env) where - empty = IOEnv (const empty) - m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) - -instance MonadPlus (IOEnv env) - ----------------------------------------------------------------------- --- Accessing input/output ----------------------------------------------------------------------- - -instance MonadIO (IOEnv env) where - liftIO io = IOEnv (\ _ -> io) - -newMutVar :: a -> IOEnv env (IORef a) -newMutVar val = liftIO (newIORef val) - -writeMutVar :: IORef a -> a -> IOEnv env () -writeMutVar var val = liftIO (writeIORef var val) - -readMutVar :: IORef a -> IOEnv env a -readMutVar var = liftIO (readIORef var) - -updMutVar :: IORef a -> (a -> a) -> IOEnv env () -updMutVar var upd = liftIO (modifyIORef var upd) - --- | Atomically update the reference. Does not force the evaluation of the --- new variable contents. For strict update, use 'atomicUpdMutVar''. -atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b -atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) - --- | Strict variant of 'atomicUpdMutVar'. -atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b -atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) - ----------------------------------------------------------------------- --- Accessing the environment ----------------------------------------------------------------------- - -getEnv :: IOEnv env env -{-# INLINE getEnv #-} -getEnv = IOEnv (\ env -> return env) - --- | Perform a computation with a different environment -setEnv :: env' -> IOEnv env' a -> IOEnv env a -{-# INLINE setEnv #-} -setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) - --- | Perform a computation with an altered environment -updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a -{-# INLINE updEnv #-} -updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) diff --git a/utils/Json.hs b/utils/Json.hs deleted file mode 100644 --- a/utils/Json.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Json where - -import GhcPrelude - -import Outputable -import Data.Char -import Numeric - --- | Simple data type to represent JSON documents. -data JsonDoc where - JSNull :: JsonDoc - JSBool :: Bool -> JsonDoc - JSInt :: Int -> JsonDoc - JSString :: String -> JsonDoc - JSArray :: [JsonDoc] -> JsonDoc - JSObject :: [(String, JsonDoc)] -> JsonDoc - - --- This is simple and slow as it is only used for error reporting -renderJSON :: JsonDoc -> SDoc -renderJSON d = - case d of - JSNull -> text "null" - JSBool b -> text $ if b then "true" else "false" - JSInt n -> ppr n - JSString s -> doubleQuotes $ text $ escapeJsonString s - JSArray as -> brackets $ pprList renderJSON as - JSObject fs -> braces $ pprList renderField fs - where - renderField :: (String, JsonDoc) -> SDoc - renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j - - pprList pp xs = hcat (punctuate comma (map pp xs)) - -escapeJsonString :: String -> String -escapeJsonString = concatMap escapeChar - where - escapeChar '\b' = "\\b" - escapeChar '\f' = "\\f" - escapeChar '\n' = "\\n" - escapeChar '\r' = "\\r" - escapeChar '\t' = "\\t" - escapeChar '"' = "\\\"" - escapeChar '\\' = "\\\\" - escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c - escapeChar c = [c] - - uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) - - pad n cs | len < n = replicate (n-len) '0' ++ cs - | otherwise = cs - where len = length cs - -class ToJson a where - json :: a -> JsonDoc diff --git a/utils/ListSetOps.hs b/utils/ListSetOps.hs deleted file mode 100644 --- a/utils/ListSetOps.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[ListSetOps]{Set-like operations on lists} --} - -{-# LANGUAGE CPP #-} - -module ListSetOps ( - unionLists, minusList, deleteBys, - - -- Association lists - Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, - - -- Duplicate handling - hasNoDups, removeDups, findDupsEq, - equivClasses, - - -- Indexing - getNth - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Outputable -import Util - -import qualified Data.List as L -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Set as S - -getNth :: Outputable a => [a] -> Int -> a -getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) - xs !! n - -deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a] --- (deleteBys eq xs ys) returns xs-ys, using the given equality function --- Just like 'Data.List.delete' but with an equality function -deleteBys eq xs ys = foldl' (flip (L.deleteBy eq)) xs ys - -{- -************************************************************************ -* * - Treating lists as sets - Assumes the lists contain no duplicates, but are unordered -* * -************************************************************************ --} - - --- | Assumes that the arguments contain no duplicates -unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] --- We special case some reasonable common patterns. -unionLists xs [] = xs -unionLists [] ys = ys -unionLists [x] ys - | isIn "unionLists" x ys = ys - | otherwise = x:ys -unionLists xs [y] - | isIn "unionLists" y xs = xs - | otherwise = y:xs -unionLists xs ys - = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys) - [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys - --- | Calculate the set difference of two lists. This is --- /O((m + n) log n)/, where we subtract a list of /n/ elements --- from a list of /m/ elements. --- --- Extremely short cases are handled specially: --- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1, --- it takes /O(n)/ time. -minusList :: Ord a => [a] -> [a] -> [a] --- There's no point building a set to perform just one lookup, so we handle --- extremely short lists specially. It might actually be better to use --- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5). --- The tipping point will be somewhere in the area of where /m/ and /log n/ --- become comparable, but we probably don't want to work too hard on this. -minusList [] _ = [] -minusList xs@[x] ys - | x `elem` ys = [] - | otherwise = xs --- Using an empty set or a singleton would also be silly, so let's not. -minusList xs [] = xs -minusList xs [y] = filter (/= y) xs --- When each list has at least two elements, we build a set from the --- second argument, allowing us to filter the first argument fairly --- efficiently. -minusList xs ys = filter (`S.notMember` yss) xs - where - yss = S.fromList ys - -{- -************************************************************************ -* * -\subsection[Utils-assoc]{Association lists} -* * -************************************************************************ - -Inefficient finite maps based on association lists and equality. --} - --- A finite mapping based on equality and association lists -type Assoc a b = [(a,b)] - -assoc :: (Eq a) => String -> Assoc a b -> a -> b -assocDefault :: (Eq a) => b -> Assoc a b -> a -> b -assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b -assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b -assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b - -assocDefaultUsing _ deflt [] _ = deflt -assocDefaultUsing eq deflt ((k,v) : rest) key - | k `eq` key = v - | otherwise = assocDefaultUsing eq deflt rest key - -assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key -assocDefault deflt list key = assocDefaultUsing (==) deflt list key -assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key - -assocMaybe alist key - = lookup alist - where - lookup [] = Nothing - lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest - -{- -************************************************************************ -* * -\subsection[Utils-dups]{Duplicate-handling} -* * -************************************************************************ --} - -hasNoDups :: (Eq a) => [a] -> Bool - -hasNoDups xs = f [] xs - where - f _ [] = True - f seen_so_far (x:xs) = if x `is_elem` seen_so_far - then False - else f (x:seen_so_far) xs - - is_elem = isIn "hasNoDups" - -equivClasses :: (a -> a -> Ordering) -- Comparison - -> [a] - -> [NonEmpty a] - -equivClasses _ [] = [] -equivClasses _ [stuff] = [stuff :| []] -equivClasses cmp items = NE.groupBy eq (L.sortBy cmp items) - where - eq a b = case cmp a b of { EQ -> True; _ -> False } - -removeDups :: (a -> a -> Ordering) -- Comparison function - -> [a] - -> ([a], -- List with no duplicates - [NonEmpty a]) -- List of duplicate groups. One representative - -- from each group appears in the first result - -removeDups _ [] = ([], []) -removeDups _ [x] = ([x],[]) -removeDups cmp xs - = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') -> - (xs', dups) } - where - collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) - collect_dups dups_so_far (x :| []) = (dups_so_far, x) - collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) - -findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] -findDupsEq _ [] = [] -findDupsEq eq (x:xs) | L.null eq_xs = findDupsEq eq xs - | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs - where (eq_xs, neq_xs) = L.partition (eq x) xs diff --git a/utils/Maybes.hs b/utils/Maybes.hs deleted file mode 100644 --- a/utils/Maybes.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module Maybes ( - module Data.Maybe, - - MaybeErr(..), -- Instance of Monad - failME, isSuccess, - - orElse, - firstJust, firstJusts, - whenIsJust, - expectJust, - rightToMaybe, - - -- * MaybeT - MaybeT(..), liftMaybeT, tryMaybeT - ) where - -import GhcPrelude - -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Exception (catch, SomeException(..)) -import Data.Maybe -import Util (HasCallStack) - -infixr 4 `orElse` - -{- -************************************************************************ -* * -\subsection[Maybe type]{The @Maybe@ type} -* * -************************************************************************ --} - -firstJust :: Maybe a -> Maybe a -> Maybe a -firstJust a b = firstJusts [a, b] - --- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or --- @Nothing@ otherwise. -firstJusts :: [Maybe a] -> Maybe a -firstJusts = msum - -expectJust :: HasCallStack => String -> Maybe a -> a -{-# INLINE expectJust #-} -expectJust _ (Just x) = x -expectJust err Nothing = error ("expectJust " ++ err) - -whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () - --- | Flipped version of @fromMaybe@, useful for chaining. -orElse :: Maybe a -> a -> a -orElse = flip fromMaybe - -rightToMaybe :: Either a b -> Maybe b -rightToMaybe (Left _) = Nothing -rightToMaybe (Right x) = Just x - -{- -************************************************************************ -* * -\subsection[MaybeT type]{The @MaybeT@ monad transformer} -* * -************************************************************************ --} - --- We had our own MaybeT in the past. Now we reuse transformer's MaybeT - -liftMaybeT :: Monad m => m a -> MaybeT m a -liftMaybeT act = MaybeT $ Just `liftM` act - --- | Try performing an 'IO' action, failing on error. -tryMaybeT :: IO a -> MaybeT IO a -tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler - where - handler (SomeException _) = return Nothing - -{- -************************************************************************ -* * -\subsection[MaybeErr type]{The @MaybeErr@ type} -* * -************************************************************************ --} - -data MaybeErr err val = Succeeded val | Failed err - deriving (Functor) - -instance Applicative (MaybeErr err) where - pure = Succeeded - (<*>) = ap - -instance Monad (MaybeErr err) where - Succeeded v >>= k = k v - Failed e >>= _ = Failed e - -isSuccess :: MaybeErr err val -> Bool -isSuccess (Succeeded {}) = True -isSuccess (Failed {}) = False - -failME :: err -> MaybeErr err val -failME e = Failed e diff --git a/utils/MonadUtils.hs b/utils/MonadUtils.hs deleted file mode 100644 --- a/utils/MonadUtils.hs +++ /dev/null @@ -1,215 +0,0 @@ --- | Utilities related to Monad and Applicative classes --- Mostly for backwards compatibility. - -module MonadUtils - ( Applicative(..) - , (<$>) - - , MonadFix(..) - , MonadIO(..) - - , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM - , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M - , mapAccumLM - , mapSndM - , concatMapM - , mapMaybeM - , fmapMaybeM, fmapEitherM - , anyM, allM, orM - , foldlM, foldlM_, foldrM - , maybeMapM - , whenM, unlessM - , filterOutM - ) where - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - -import GhcPrelude - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -import Data.Foldable (sequenceA_, foldlM, foldrM) -import Data.List (unzip4, unzip5, zipWith4) - -------------------------------------------------------------------------------- --- Common functions --- These are used throughout the compiler -------------------------------------------------------------------------------- - -{- - -Note [Inline @zipWithNM@ functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same -as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see -Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. - -The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and -`sequenceA` functions with which they are defined have an opportunity to fuse. - -Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly -rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for -more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) -for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning -'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and -'zipWithM_', respectively, with regards to fusion. - -As such, since there are not any differences between 2-ary 'zipWithM'/ -'zipWithM_' and their n-ary counterparts below aside from the number of -arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ -functions below as well. - --} - -zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] -{-# INLINE zipWith3M #-} --- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. --- See Note [Inline @zipWithNM@ functions] above. -zipWith3M f xs ys zs = sequenceA (zipWith3 f xs ys zs) - -zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () -{-# INLINE zipWith3M_ #-} --- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. --- See Note [Inline @zipWithNM@ functions] above. -zipWith3M_ f xs ys zs = sequenceA_ (zipWith3 f xs ys zs) - -zipWith4M :: Monad m => (a -> b -> c -> d -> m e) - -> [a] -> [b] -> [c] -> [d] -> m [e] -{-# INLINE zipWith4M #-} --- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. --- See Note [Inline @zipWithNM@ functions] above. -zipWith4M f xs ys ws zs = sequenceA (zipWith4 f xs ys ws zs) - -zipWithAndUnzipM :: Monad m - => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) -{-# INLINABLE zipWithAndUnzipM #-} --- See Note [flatten_many performance] in TcFlatten for why this --- pragma is essential. -zipWithAndUnzipM f (x:xs) (y:ys) - = do { (c, d) <- f x y - ; (cs, ds) <- zipWithAndUnzipM f xs ys - ; return (c:cs, d:ds) } -zipWithAndUnzipM _ _ _ = return ([], []) - -{- - -Note [Inline @mapAndUnzipNM@ functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". -The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` -functions with which it is defined have an opportunity to fuse, see -Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. - -Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a -non-recursive way similarly to 'mapAndUnzipM', and for more than just -uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac -ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', -'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards -to fusion. - -As such, since there are not any differences between 2-ary 'mapAndUnzipM' and -its n-ary counterparts below aside from the number of arguments, the `INLINE` -pragma should be replicated in the @mapAndUnzipNM@ functions below as well. - --} - --- | mapAndUnzipM for triples -mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) -{-# INLINE mapAndUnzip3M #-} --- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. --- See Note [Inline @mapAndUnzipNM@ functions] above. -mapAndUnzip3M f xs = unzip3 <$> traverse f xs - -mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) -{-# INLINE mapAndUnzip4M #-} --- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. --- See Note [Inline @mapAndUnzipNM@ functions] above. -mapAndUnzip4M f xs = unzip4 <$> traverse f xs - -mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) -{-# INLINE mapAndUnzip5M #-} --- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. --- See Note [Inline @mapAndUnzipNM@ functions] above. -mapAndUnzip5M f xs = unzip5 <$> traverse f xs - --- | Monadic version of mapAccumL -mapAccumLM :: Monad m - => (acc -> x -> m (acc, y)) -- ^ combining function - -> acc -- ^ initial state - -> [x] -- ^ inputs - -> m (acc, [y]) -- ^ final state, outputs -mapAccumLM _ s [] = return (s, []) -mapAccumLM f s (x:xs) = do - (s1, x') <- f s x - (s2, xs') <- mapAccumLM f s1 xs - return (s2, x' : xs') - --- | Monadic version of mapSnd -mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapSndM _ [] = return [] -mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - --- | Applicative version of mapMaybe -mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = foldr g (pure []) - where g a = liftA2 (maybe id (:)) (f a) - --- | Monadic version of fmap -fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) -fmapMaybeM _ Nothing = return Nothing -fmapMaybeM f (Just x) = f x >>= (return . Just) - --- | Monadic version of fmap -fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) -fmapEitherM fl _ (Left a) = fl a >>= (return . Left) -fmapEitherM _ fr (Right b) = fr b >>= (return . Right) - --- | Monadic version of 'any', aborts the computation at the first @True@ value -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM _ [] = return False -anyM f (x:xs) = do b <- f x - if b then return True - else anyM f xs - --- | Monad version of 'all', aborts the computation at the first @False@ value -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM _ [] = return True -allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) - --- | Monadic version of or -orM :: Monad m => m Bool -> m Bool -> m Bool -orM m1 m2 = m1 >>= \x -> if x then return True else m2 - --- | Monadic version of foldl that discards its result -foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () -foldlM_ = foldM_ - --- | Monadic version of fmap specialised for Maybe -maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) -maybeMapM _ Nothing = return Nothing -maybeMapM m (Just x) = liftM Just $ m x - --- | Monadic version of @when@, taking the condition in the monad -whenM :: Monad m => m Bool -> m () -> m () -whenM mb thing = do { b <- mb - ; when b thing } - --- | Monadic version of @unless@, taking the condition in the monad -unlessM :: Monad m => m Bool -> m () -> m () -unlessM condM acc = do { cond <- condM - ; unless cond acc } - --- | Like 'filterM', only it reverses the sense of the test. -filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] -filterOutM p = - foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) diff --git a/utils/OrdList.hs b/utils/OrdList.hs deleted file mode 100644 --- a/utils/OrdList.hs +++ /dev/null @@ -1,194 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - - -This is useful, general stuff for the Native Code Generator. - -Provide trees (of instructions), so that lists of instructions -can be appended in linear time. --} -{-# LANGUAGE DeriveFunctor #-} - -{-# LANGUAGE BangPatterns #-} - -module OrdList ( - OrdList, - nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, - headOL, - mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse, - strictlyEqOL, strictlyOrdOL -) where - -import GhcPrelude -import Data.Foldable - -import Outputable - -import qualified Data.Semigroup as Semigroup - -infixl 5 `appOL` -infixl 5 `snocOL` -infixr 5 `consOL` - -data OrdList a - = None - | One a - | Many [a] -- Invariant: non-empty - | Cons a (OrdList a) - | Snoc (OrdList a) a - | Two (OrdList a) -- Invariant: non-empty - (OrdList a) -- Invariant: non-empty - deriving (Functor) - -instance Outputable a => Outputable (OrdList a) where - ppr ol = ppr (fromOL ol) -- Convert to list and print that - -instance Semigroup (OrdList a) where - (<>) = appOL - -instance Monoid (OrdList a) where - mempty = nilOL - mappend = (Semigroup.<>) - mconcat = concatOL - -instance Foldable OrdList where - foldr = foldrOL - foldl' = foldlOL - toList = fromOL - null = isNilOL - length = lengthOL - -instance Traversable OrdList where - traverse f xs = toOL <$> traverse f (fromOL xs) - -nilOL :: OrdList a -isNilOL :: OrdList a -> Bool - -unitOL :: a -> OrdList a -snocOL :: OrdList a -> a -> OrdList a -consOL :: a -> OrdList a -> OrdList a -appOL :: OrdList a -> OrdList a -> OrdList a -concatOL :: [OrdList a] -> OrdList a -headOL :: OrdList a -> a -lastOL :: OrdList a -> a -lengthOL :: OrdList a -> Int - -nilOL = None -unitOL as = One as -snocOL as b = Snoc as b -consOL a bs = Cons a bs -concatOL aas = foldr appOL None aas - -headOL None = panic "headOL" -headOL (One a) = a -headOL (Many as) = head as -headOL (Cons a _) = a -headOL (Snoc as _) = headOL as -headOL (Two as _) = headOL as - -lastOL None = panic "lastOL" -lastOL (One a) = a -lastOL (Many as) = last as -lastOL (Cons _ as) = lastOL as -lastOL (Snoc _ a) = a -lastOL (Two _ as) = lastOL as - -lengthOL None = 0 -lengthOL (One _) = 1 -lengthOL (Many as) = length as -lengthOL (Cons _ as) = 1 + length as -lengthOL (Snoc as _) = 1 + length as -lengthOL (Two as bs) = length as + length bs - -isNilOL None = True -isNilOL _ = False - -None `appOL` b = b -a `appOL` None = a -One a `appOL` b = Cons a b -a `appOL` One b = Snoc a b -a `appOL` b = Two a b - -fromOL :: OrdList a -> [a] -fromOL a = go a [] - where go None acc = acc - go (One a) acc = a : acc - go (Cons a b) acc = a : go b acc - go (Snoc a b) acc = go a (b:acc) - go (Two a b) acc = go a (go b acc) - go (Many xs) acc = xs ++ acc - -fromOLReverse :: OrdList a -> [a] -fromOLReverse a = go a [] - -- acc is already in reverse order - where go :: OrdList a -> [a] -> [a] - go None acc = acc - go (One a) acc = a : acc - go (Cons a b) acc = go b (a : acc) - go (Snoc a b) acc = b : go a acc - go (Two a b) acc = go b (go a acc) - go (Many xs) acc = reverse xs ++ acc - -mapOL :: (a -> b) -> OrdList a -> OrdList b -mapOL = fmap - -foldrOL :: (a->b->b) -> b -> OrdList a -> b -foldrOL _ z None = z -foldrOL k z (One x) = k x z -foldrOL k z (Cons x xs) = k x (foldrOL k z xs) -foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs -foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 -foldrOL k z (Many xs) = foldr k z xs - --- | Strict left fold. -foldlOL :: (b->a->b) -> b -> OrdList a -> b -foldlOL _ z None = z -foldlOL k z (One x) = k z x -foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs -foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x -foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 -foldlOL k z (Many xs) = foldl' k z xs - -toOL :: [a] -> OrdList a -toOL [] = None -toOL [x] = One x -toOL xs = Many xs - -reverseOL :: OrdList a -> OrdList a -reverseOL None = None -reverseOL (One x) = One x -reverseOL (Cons a b) = Snoc (reverseOL b) a -reverseOL (Snoc a b) = Cons b (reverseOL a) -reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) -reverseOL (Many xs) = Many (reverse xs) - --- | Compare not only the values but also the structure of two lists -strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool -strictlyEqOL None None = True -strictlyEqOL (One x) (One y) = x == y -strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs -strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs -strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2 -strictlyEqOL (Many as) (Many bs) = as == bs -strictlyEqOL _ _ = False - --- | Compare not only the values but also the structure of two lists -strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering -strictlyOrdOL None None = EQ -strictlyOrdOL None _ = LT -strictlyOrdOL (One x) (One y) = compare x y -strictlyOrdOL (One _) _ = LT -strictlyOrdOL (Cons a as) (Cons b bs) = - compare a b `mappend` strictlyOrdOL as bs -strictlyOrdOL (Cons _ _) _ = LT -strictlyOrdOL (Snoc as a) (Snoc bs b) = - compare a b `mappend` strictlyOrdOL as bs -strictlyOrdOL (Snoc _ _) _ = LT -strictlyOrdOL (Two a1 a2) (Two b1 b2) = - (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2) -strictlyOrdOL (Two _ _) _ = LT -strictlyOrdOL (Many as) (Many bs) = compare as bs -strictlyOrdOL (Many _ ) _ = GT - - diff --git a/utils/Outputable.hs b/utils/Outputable.hs deleted file mode 100644 --- a/utils/Outputable.hs +++ /dev/null @@ -1,1252 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-1998 --} - --- | This module defines classes and functions for pretty-printing. It also --- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. --- --- The interface to this module is very similar to the standard Hughes-PJ pretty printing --- module, except that it exports a number of additional functions that are rarely used, --- and works over the 'SDoc' type. -module Outputable ( - -- * Type classes - Outputable(..), OutputableBndr(..), - - -- * Pretty printing combinators - SDoc, runSDoc, initSDocContext, - docToSDoc, - interppSP, interpp'SP, - pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, - pprWithBars, - empty, isEmpty, nest, - char, - text, ftext, ptext, ztext, - int, intWithCommas, integer, word, float, double, rational, doublePrec, - parens, cparen, brackets, braces, quotes, quote, - doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, vbar, - arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, - blankLine, forAllLit, kindType, bullet, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - hang, hangNotEmpty, punctuate, ppWhen, ppUnless, - speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, - unicodeSyntax, - - coloured, keyword, - - -- * Converting 'SDoc' into strings and outputing it - printSDoc, printSDocLn, printForUser, printForUserPartWay, - printForC, bufLeftRenderSDoc, - pprCode, mkCodeStyle, - showSDoc, showSDocUnsafe, showSDocOneLine, - showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, - showSDocUnqual, showPpr, - renderWithStyle, - - pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsBytes, - - primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, - primInt64Suffix, primWord64Suffix, primIntSuffix, - - pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, - - pprFastFilePath, pprFilePathString, - - -- * Controlling the style in which output is printed - BindingSite(..), - - PprStyle, CodeStyle(..), PrintUnqualified(..), - QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, - reallyAlwaysQualify, reallyAlwaysQualifyNames, - alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, - neverQualify, neverQualifyNames, neverQualifyModules, - alwaysQualifyPackages, neverQualifyPackages, - QualifyName(..), queryQual, - sdocWithDynFlags, sdocWithPlatform, - updSDocDynFlags, - getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured, - pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - qualName, qualModule, qualPackage, - mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, - mkUserStyle, cmdlineParserStyle, Depth(..), - - ifPprDebug, whenPprDebug, getPprDebug, - - -- * Error handling and debugging utilities - pprPanic, pprSorry, assertPprPanic, pprPgmError, - pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace, - pprSTrace, pprTraceException, pprTraceM, - trace, pgmError, panic, sorry, assertPanic, - pprDebugAndThen, callStackDoc, - ) where - -import GhcPrelude - -import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, - targetPlatform, pprUserLength, pprCols, - useUnicode, useUnicodeSyntax, useStarIsType, - shouldUseColor, unsafeGlobalDynFlags, - shouldUseHexWordLiterals ) -import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) -import {-# SOURCE #-} OccName( OccName ) - -import BufWrite (BufHandle) -import FastString -import qualified Pretty -import Util -import GHC.Platform -import qualified PprColour as Col -import Pretty ( Doc, Mode(..) ) -import Panic -import GHC.Serialized -import GHC.LanguageExtensions (Extension) - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Char -import qualified Data.Map as M -import Data.Int -import qualified Data.IntMap as IM -import Data.Set (Set) -import qualified Data.Set as Set -import Data.String -import Data.Word -import System.IO ( Handle ) -import System.FilePath -import Text.Printf -import Numeric (showFFloat) -import Data.Graph (SCC(..)) -import Data.List (intersperse) - -import GHC.Fingerprint -import GHC.Show ( showMultiLineString ) -import GHC.Stack ( callStack, prettyCallStack ) -import Control.Monad.IO.Class -import Exception - -{- -************************************************************************ -* * -\subsection{The @PprStyle@ data type} -* * -************************************************************************ --} - -data PprStyle - = PprUser PrintUnqualified Depth Coloured - -- Pretty-print in a way that will make sense to the - -- ordinary user; must be very close to Haskell - -- syntax, etc. - -- Assumes printing tidied code: non-system names are - -- printed without uniques. - - | PprDump PrintUnqualified - -- For -ddump-foo; less verbose than PprDebug, but more than PprUser - -- Does not assume tidied code: non-external names - -- are printed with uniques. - - | PprDebug -- Full debugging output - - | PprCode CodeStyle - -- Print code; either C or assembler - -data CodeStyle = CStyle -- The format of labels differs for C and assembler - | AsmStyle - -data Depth = AllTheWay - | PartWay Int -- 0 => stop - -data Coloured - = Uncoloured - | Coloured - --- ----------------------------------------------------------------------------- --- Printing original names - --- | When printing code that contains original names, we need to map the --- original names back to something the user understands. This is the --- purpose of the triple of functions that gets passed around --- when rendering 'SDoc'. -data PrintUnqualified = QueryQualify { - queryQualifyName :: QueryQualifyName, - queryQualifyModule :: QueryQualifyModule, - queryQualifyPackage :: QueryQualifyPackage -} - --- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify --- it. -type QueryQualifyName = Module -> OccName -> QualifyName - --- | For a given module, we need to know whether to print it with --- a package name to disambiguate it. -type QueryQualifyModule = Module -> Bool - --- | For a given package, we need to know whether to print it with --- the component id to disambiguate it. -type QueryQualifyPackage = UnitId -> Bool - --- See Note [Printing original names] in HscTypes -data QualifyName -- Given P:M.T - = NameUnqual -- It's in scope unqualified as "T" - -- OR nothing called "T" is in scope - - | NameQual ModuleName -- It's in scope qualified as "X.T" - - | NameNotInScope1 -- It's not in scope at all, but M.T is not bound - -- in the current scope, so we can refer to it as "M.T" - - | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in - -- the current scope, so we must refer to it as "P:M.T" - -instance Outputable QualifyName where - ppr NameUnqual = text "NameUnqual" - ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( - ppr NameNotInScope1 = text "NameNotInScope1" - ppr NameNotInScope2 = text "NameNotInScope2" - -reallyAlwaysQualifyNames :: QueryQualifyName -reallyAlwaysQualifyNames _ _ = NameNotInScope2 - --- | NB: This won't ever show package IDs -alwaysQualifyNames :: QueryQualifyName -alwaysQualifyNames m _ = NameQual (moduleName m) - -neverQualifyNames :: QueryQualifyName -neverQualifyNames _ _ = NameUnqual - -alwaysQualifyModules :: QueryQualifyModule -alwaysQualifyModules _ = True - -neverQualifyModules :: QueryQualifyModule -neverQualifyModules _ = False - -alwaysQualifyPackages :: QueryQualifyPackage -alwaysQualifyPackages _ = True - -neverQualifyPackages :: QueryQualifyPackage -neverQualifyPackages _ = False - -reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified -reallyAlwaysQualify - = QueryQualify reallyAlwaysQualifyNames - alwaysQualifyModules - alwaysQualifyPackages -alwaysQualify = QueryQualify alwaysQualifyNames - alwaysQualifyModules - alwaysQualifyPackages -neverQualify = QueryQualify neverQualifyNames - neverQualifyModules - neverQualifyPackages - -defaultUserStyle :: DynFlags -> PprStyle -defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay - -defaultDumpStyle :: DynFlags -> PprStyle - -- Print without qualifiers to reduce verbosity, unless -dppr-debug -defaultDumpStyle dflags - | hasPprDebug dflags = PprDebug - | otherwise = PprDump neverQualify - -mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle -mkDumpStyle dflags print_unqual - | hasPprDebug dflags = PprDebug - | otherwise = PprDump print_unqual - -defaultErrStyle :: DynFlags -> PprStyle --- Default style for error messages, when we don't know PrintUnqualified --- It's a bit of a hack because it doesn't take into account what's in scope --- Only used for desugarer warnings, and typechecker errors in interface sigs --- NB that -dppr-debug will still get into PprDebug style -defaultErrStyle dflags = mkErrStyle dflags neverQualify - --- | Style for printing error messages -mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle -mkErrStyle dflags qual = - mkUserStyle dflags qual (PartWay (pprUserLength dflags)) - -cmdlineParserStyle :: DynFlags -> PprStyle -cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay - -mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle -mkUserStyle dflags unqual depth - | hasPprDebug dflags = PprDebug - | otherwise = PprUser unqual depth Uncoloured - -setStyleColoured :: Bool -> PprStyle -> PprStyle -setStyleColoured col style = - case style of - PprUser q d _ -> PprUser q d c - _ -> style - where - c | col = Coloured - | otherwise = Uncoloured - -instance Outputable PprStyle where - ppr (PprUser {}) = text "user-style" - ppr (PprCode {}) = text "code-style" - ppr (PprDump {}) = text "dump-style" - ppr (PprDebug {}) = text "debug-style" - -{- -Orthogonal to the above printing styles are (possibly) some -command-line flags that affect printing (often carried with the -style). The most likely ones are variations on how much type info is -shown. - -The following test decides whether or not we are actually generating -code (either C or assembly), or generating interface files. - -************************************************************************ -* * -\subsection{The @SDoc@ data type} -* * -************************************************************************ --} - --- | Represents a pretty-printable document. --- --- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', --- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the --- abstraction layer. -newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } - -data SDocContext = SDC - { sdocStyle :: !PprStyle - , sdocLastColour :: !Col.PprColour - -- ^ The most recently used colour. This allows nesting colours. - , sdocDynFlags :: !DynFlags - } - -instance IsString SDoc where - fromString = text - --- The lazy programmer's friend. -instance Outputable SDoc where - ppr = id - -initSDocContext :: DynFlags -> PprStyle -> SDocContext -initSDocContext dflags sty = SDC - { sdocStyle = sty - , sdocLastColour = Col.colReset - , sdocDynFlags = dflags - } - -withPprStyle :: PprStyle -> SDoc -> SDoc -withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} - --- | This is not a recommended way to render 'SDoc', since it breaks the --- abstraction layer of 'SDoc'. Prefer to use 'printSDoc', 'printSDocLn', --- 'bufLeftRenderSDoc', or 'renderWithStyle' instead. -withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc -withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) - -pprDeeper :: SDoc -> SDoc -pprDeeper d = SDoc $ \ctx -> case ctx of - SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." - SDC{sdocStyle=PprUser q (PartWay n) c} -> - runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} - _ -> runSDoc d ctx - --- | Truncate a list that is longer than the current depth. -pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -pprDeeperList f ds - | null ds = f [] - | otherwise = SDoc work - where - work ctx@SDC{sdocStyle=PprUser q (PartWay n) c} - | n==0 = Pretty.text "..." - | otherwise = - runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} - where - go _ [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - work other_ctx = runSDoc (f ds) other_ctx - -pprSetDepth :: Depth -> SDoc -> SDoc -pprSetDepth depth doc = SDoc $ \ctx -> - case ctx of - SDC{sdocStyle=PprUser q _ c} -> - runSDoc doc ctx{sdocStyle = PprUser q depth c} - _ -> - runSDoc doc ctx - -getPprStyle :: (PprStyle -> SDoc) -> SDoc -getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx - -sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc -sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx - -sdocWithPlatform :: (Platform -> SDoc) -> SDoc -sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) - -updSDocDynFlags :: (DynFlags -> DynFlags) -> SDoc -> SDoc -updSDocDynFlags upd doc - = SDoc $ \ctx -> runSDoc doc (ctx { sdocDynFlags = upd (sdocDynFlags ctx) }) - -qualName :: PprStyle -> QueryQualifyName -qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ -qualName (PprDump q) mod occ = queryQualifyName q mod occ -qualName _other mod _ = NameQual (moduleName mod) - -qualModule :: PprStyle -> QueryQualifyModule -qualModule (PprUser q _ _) m = queryQualifyModule q m -qualModule (PprDump q) m = queryQualifyModule q m -qualModule _other _m = True - -qualPackage :: PprStyle -> QueryQualifyPackage -qualPackage (PprUser q _ _) m = queryQualifyPackage q m -qualPackage (PprDump q) m = queryQualifyPackage q m -qualPackage _other _m = True - -queryQual :: PprStyle -> PrintUnqualified -queryQual s = QueryQualify (qualName s) - (qualModule s) - (qualPackage s) - -codeStyle :: PprStyle -> Bool -codeStyle (PprCode _) = True -codeStyle _ = False - -asmStyle :: PprStyle -> Bool -asmStyle (PprCode AsmStyle) = True -asmStyle _other = False - -dumpStyle :: PprStyle -> Bool -dumpStyle (PprDump {}) = True -dumpStyle _other = False - -debugStyle :: PprStyle -> Bool -debugStyle PprDebug = True -debugStyle _other = False - -userStyle :: PprStyle -> Bool -userStyle (PprUser {}) = True -userStyle _other = False - -getPprDebug :: (Bool -> SDoc) -> SDoc -getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) - -ifPprDebug :: SDoc -> SDoc -> SDoc --- ^ Says what to do with and without -dppr-debug -ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no - -whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style --- ^ Says what to do with -dppr-debug; without, return empty -whenPprDebug d = ifPprDebug d empty - --- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the --- terminal doesn't get screwed up by the ANSI color codes if an exception --- is thrown during pretty-printing. -printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () -printSDoc mode dflags handle sty doc = - Pretty.printDoc_ mode cols handle (runSDoc doc ctx) - `finally` - Pretty.printDoc_ mode cols handle - (runSDoc (coloured Col.colReset empty) ctx) - where - cols = pprCols dflags - ctx = initSDocContext dflags sty - --- | Like 'printSDoc' but appends an extra newline. -printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () -printSDocLn mode dflags handle sty doc = - printSDoc mode dflags handle sty (doc $$ text "") - -printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () -printForUser dflags handle unqual doc - = printSDocLn PageMode dflags handle - (mkUserStyle dflags unqual AllTheWay) doc - -printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc - -> IO () -printForUserPartWay dflags handle d unqual doc - = printSDocLn PageMode dflags handle - (mkUserStyle dflags unqual (PartWay d)) doc - --- | Like 'printSDocLn' but specialized with 'LeftMode' and --- @'PprCode' 'CStyle'@. This is typically used to output C-- code. -printForC :: DynFlags -> Handle -> SDoc -> IO () -printForC dflags handle doc = - printSDocLn LeftMode dflags handle (PprCode CStyle) doc - --- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that --- outputs to a 'BufHandle'. -bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO () -bufLeftRenderSDoc dflags bufHandle sty doc = - Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty)) - -pprCode :: CodeStyle -> SDoc -> SDoc -pprCode cs d = withPprStyle (PprCode cs) d - -mkCodeStyle :: CodeStyle -> PprStyle -mkCodeStyle = PprCode - --- Can't make SDoc an instance of Show because SDoc is just a function type --- However, Doc *is* an instance of Show --- showSDoc just blasts it out as a string -showSDoc :: DynFlags -> SDoc -> String -showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags) - --- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be --- initialised yet. -showSDocUnsafe :: SDoc -> String -showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc - -showPpr :: Outputable a => DynFlags -> a -> String -showPpr dflags thing = showSDoc dflags (ppr thing) - -showSDocUnqual :: DynFlags -> SDoc -> String --- Only used by Haddock -showSDocUnqual dflags sdoc = showSDoc dflags sdoc - -showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String --- Allows caller to specify the PrintUnqualified to use -showSDocForUser dflags unqual doc - = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay) - -showSDocDump :: DynFlags -> SDoc -> String -showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags) - -showSDocDebug :: DynFlags -> SDoc -> String -showSDocDebug dflags d = renderWithStyle dflags d PprDebug - -renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String -renderWithStyle dflags sdoc sty - = let s = Pretty.style{ Pretty.mode = PageMode, - Pretty.lineLength = pprCols dflags } - in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty) - --- This shows an SDoc, but on one line only. It's cheaper than a full --- showSDoc, designed for when we're getting results like "Foo.bar" --- and "foo{uniq strictness}" so we don't want fancy layout anyway. -showSDocOneLine :: DynFlags -> SDoc -> String -showSDocOneLine dflags d - = let s = Pretty.style{ Pretty.mode = OneLineMode, - Pretty.lineLength = pprCols dflags } in - Pretty.renderStyle s $ - runSDoc d (initSDocContext dflags (defaultUserStyle dflags)) - -showSDocDumpOneLine :: DynFlags -> SDoc -> String -showSDocDumpOneLine dflags d - = let s = Pretty.style{ Pretty.mode = OneLineMode, - Pretty.lineLength = irrelevantNCols } in - Pretty.renderStyle s $ - runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) - -irrelevantNCols :: Int --- Used for OneLineMode and LeftMode when number of cols isn't used -irrelevantNCols = 1 - -isEmpty :: DynFlags -> SDoc -> Bool -isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext - where dummySDocContext = initSDocContext dflags PprDebug - -docToSDoc :: Doc -> SDoc -docToSDoc d = SDoc (\_ -> d) - -empty :: SDoc -char :: Char -> SDoc -text :: String -> SDoc -ftext :: FastString -> SDoc -ptext :: PtrString -> SDoc -ztext :: FastZString -> SDoc -int :: Int -> SDoc -integer :: Integer -> SDoc -word :: Integer -> SDoc -float :: Float -> SDoc -double :: Double -> SDoc -rational :: Rational -> SDoc - -empty = docToSDoc $ Pretty.empty -char c = docToSDoc $ Pretty.char c - -text s = docToSDoc $ Pretty.text s -{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire - -ftext s = docToSDoc $ Pretty.ftext s -ptext s = docToSDoc $ Pretty.ptext s -ztext s = docToSDoc $ Pretty.ztext s -int n = docToSDoc $ Pretty.int n -integer n = docToSDoc $ Pretty.integer n -float n = docToSDoc $ Pretty.float n -double n = docToSDoc $ Pretty.double n -rational n = docToSDoc $ Pretty.rational n -word n = sdocWithDynFlags $ \dflags -> - -- See Note [Print Hexadecimal Literals] in Pretty.hs - if shouldUseHexWordLiterals dflags - then docToSDoc $ Pretty.hex n - else docToSDoc $ Pretty.integer n - --- | @doublePrec p n@ shows a floating point number @n@ with @p@ --- digits of precision after the decimal point. -doublePrec :: Int -> Double -> SDoc -doublePrec p n = text (showFFloat (Just p) n "") - -parens, braces, brackets, quotes, quote, - doubleQuotes, angleBrackets :: SDoc -> SDoc - -parens d = SDoc $ Pretty.parens . runSDoc d -braces d = SDoc $ Pretty.braces . runSDoc d -brackets d = SDoc $ Pretty.brackets . runSDoc d -quote d = SDoc $ Pretty.quote . runSDoc d -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d -angleBrackets d = char '<' <> d <> char '>' - -cparen :: Bool -> SDoc -> SDoc -cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d - --- 'quotes' encloses something in single quotes... --- but it omits them if the thing begins or ends in a single quote --- so that we don't get `foo''. Instead we just have foo'. -quotes d = - sdocWithDynFlags $ \dflags -> - if useUnicode dflags - then char '‘' <> d <> char '’' - else SDoc $ \sty -> - let pp_d = runSDoc d sty - str = show pp_d - in case (str, lastMaybe str) of - (_, Just '\'') -> pp_d - ('\'' : _, _) -> pp_d - _other -> Pretty.quotes pp_d - -semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc - -blankLine = docToSDoc $ Pretty.text "" -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") -semi = docToSDoc $ Pretty.semi -comma = docToSDoc $ Pretty.comma -colon = docToSDoc $ Pretty.colon -equals = docToSDoc $ Pretty.equals -space = docToSDoc $ Pretty.space -underscore = char '_' -dot = char '.' -vbar = char '|' -lparen = docToSDoc $ Pretty.lparen -rparen = docToSDoc $ Pretty.rparen -lbrack = docToSDoc $ Pretty.lbrack -rbrack = docToSDoc $ Pretty.rbrack -lbrace = docToSDoc $ Pretty.lbrace -rbrace = docToSDoc $ Pretty.rbrace - -forAllLit :: SDoc -forAllLit = unicodeSyntax (char '∀') (text "forall") - -kindType :: SDoc -kindType = sdocWithDynFlags $ \dflags -> - if useStarIsType dflags - then unicodeSyntax (char '★') (char '*') - else text "Type" - -bullet :: SDoc -bullet = unicode (char '•') (char '*') - -unicodeSyntax :: SDoc -> SDoc -> SDoc -unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> - if useUnicode dflags && useUnicodeSyntax dflags - then unicode - else plain - -unicode :: SDoc -> SDoc -> SDoc -unicode unicode plain = sdocWithDynFlags $ \dflags -> - if useUnicode dflags - then unicode - else plain - -nest :: Int -> SDoc -> SDoc --- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap -(<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them -($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is --- no vertical overlap it "dovetails" the two onto one line -($+$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically - -nest n d = SDoc $ Pretty.nest n . runSDoc d -(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) -(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) -($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) -($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) - -hcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally -hsep :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally with a space between each one -vcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' vertically with dovetailing -sep :: [SDoc] -> SDoc --- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits -cat :: [SDoc] -> SDoc --- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits -fsep :: [SDoc] -> SDoc --- ^ A paragraph-fill combinator. It's much like sep, only it --- keeps fitting things on one line until it can't fit any more. -fcat :: [SDoc] -> SDoc --- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' - - -hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] -hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] -vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] -sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] -cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] -fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] -fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] - -hang :: SDoc -- ^ The header - -> Int -- ^ Amount to indent the hung body - -> SDoc -- ^ The hung body, indented and placed below the header - -> SDoc -hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) - --- | This behaves like 'hang', but does not indent the second document --- when the header is empty. -hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc -hangNotEmpty d1 n d2 = - SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) - -punctuate :: SDoc -- ^ The punctuation - -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements - -> [SDoc] -- ^ Punctuated list -punctuate _ [] = [] -punctuate p (d:ds) = go d ds - where - go d [] = [d] - go d (e:es) = (d <> p) : go e es - -ppWhen, ppUnless :: Bool -> SDoc -> SDoc -ppWhen True doc = doc -ppWhen False _ = empty - -ppUnless True _ = empty -ppUnless False doc = doc - --- | Apply the given colour\/style for the argument. --- --- Only takes effect if colours are enabled. -coloured :: Col.PprColour -> SDoc -> SDoc -coloured col sdoc = - sdocWithDynFlags $ \dflags -> - if shouldUseColor dflags - then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } -> - case ctx of - SDC{ sdocStyle = PprUser _ _ Coloured } -> - let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in - Pretty.zeroWidthText (Col.renderColour col) - Pretty.<> runSDoc sdoc ctx' - Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) - _ -> runSDoc sdoc ctx - else sdoc - -keyword :: SDoc -> SDoc -keyword = coloured Col.colBold - -{- -************************************************************************ -* * -\subsection[Outputable-class]{The @Outputable@ class} -* * -************************************************************************ --} - --- | Class designating that some type has an 'SDoc' representation -class Outputable a where - ppr :: a -> SDoc - pprPrec :: Rational -> a -> SDoc - -- 0 binds least tightly - -- We use Rational because there is always a - -- Rational between any other two Rationals - - ppr = pprPrec 0 - pprPrec _ = ppr - -instance Outputable Char where - ppr c = text [c] - -instance Outputable Bool where - ppr True = text "True" - ppr False = text "False" - -instance Outputable Ordering where - ppr LT = text "LT" - ppr EQ = text "EQ" - ppr GT = text "GT" - -instance Outputable Int32 where - ppr n = integer $ fromIntegral n - -instance Outputable Int64 where - ppr n = integer $ fromIntegral n - -instance Outputable Int where - ppr n = int n - -instance Outputable Integer where - ppr n = integer n - -instance Outputable Word16 where - ppr n = integer $ fromIntegral n - -instance Outputable Word32 where - ppr n = integer $ fromIntegral n - -instance Outputable Word where - ppr n = integer $ fromIntegral n - -instance Outputable Float where - ppr f = float f - -instance Outputable Double where - ppr f = double f - -instance Outputable () where - ppr _ = text "()" - -instance (Outputable a) => Outputable [a] where - ppr xs = brackets (fsep (punctuate comma (map ppr xs))) - -instance (Outputable a) => Outputable (Set a) where - ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) - -instance (Outputable a, Outputable b) => Outputable (a, b) where - ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) - -instance Outputable a => Outputable (Maybe a) where - ppr Nothing = text "Nothing" - ppr (Just x) = text "Just" <+> ppr x - -instance (Outputable a, Outputable b) => Outputable (Either a b) where - ppr (Left x) = text "Left" <+> ppr x - ppr (Right y) = text "Right" <+> ppr y - --- ToDo: may not be used -instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where - ppr (x,y,z) = - parens (sep [ppr x <> comma, - ppr y <> comma, - ppr z ]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d) => - Outputable (a, b, c, d) where - ppr (a,b,c,d) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => - Outputable (a, b, c, d, e) where - ppr (a,b,c,d,e) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => - Outputable (a, b, c, d, e, f) where - ppr (a,b,c,d,e,f) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f]) - -instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => - Outputable (a, b, c, d, e, f, g) where - ppr (a,b,c,d,e,f,g) = - parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f <> comma, - ppr g]) - -instance Outputable FastString where - ppr fs = ftext fs -- Prints an unadorned string, - -- no double quotes or anything - -instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where - ppr m = ppr (M.toList m) -instance (Outputable elt) => Outputable (IM.IntMap elt) where - ppr m = ppr (IM.toList m) - -instance Outputable Fingerprint where - ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) - -instance Outputable a => Outputable (SCC a) where - ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) - ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) - -instance Outputable Serialized where - ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) - -instance Outputable Extension where - ppr = text . show - -{- -************************************************************************ -* * -\subsection{The @OutputableBndr@ class} -* * -************************************************************************ --} - --- | 'BindingSite' is used to tell the thing that prints binder what --- language construct is binding the identifier. This can be used --- to decide how much info to print. --- Also see Note [Binding-site specific printing] in PprCore -data BindingSite - = LambdaBind -- ^ The x in (\x. e) - | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } - | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } - | LetBind -- ^ The x in (let x = rhs in e) - --- | When we print a binder, we often want to print its type too. --- The @OutputableBndr@ class encapsulates this idea. -class Outputable a => OutputableBndr a where - pprBndr :: BindingSite -> a -> SDoc - pprBndr _b x = ppr x - - pprPrefixOcc, pprInfixOcc :: a -> SDoc - -- Print an occurrence of the name, suitable either in the - -- prefix position of an application, thus (f a b) or ((+) x) - -- or infix position, thus (a `f` b) or (x + y) - - bndrIsJoin_maybe :: a -> Maybe Int - bndrIsJoin_maybe _ = Nothing - -- When pretty-printing we sometimes want to find - -- whether the binder is a join point. You might think - -- we could have a function of type (a->Var), but Var - -- isn't available yet, alas - -{- -************************************************************************ -* * -\subsection{Random printing helpers} -* * -************************************************************************ --} - --- We have 31-bit Chars and will simply use Show instances of Char and String. - --- | Special combinator for showing character literals. -pprHsChar :: Char -> SDoc -pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) - | otherwise = text (show c) - --- | Special combinator for showing string literals. -pprHsString :: FastString -> SDoc -pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) - --- | Special combinator for showing bytestring literals. -pprHsBytes :: ByteString -> SDoc -pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs - in vcat (map text (showMultiLineString escaped)) <> char '#' - where escape :: Word8 -> String - escape w = let c = chr (fromIntegral w) - in if isAscii c - then [c] - else '\\' : show w - --- Postfix modifiers for unboxed literals. --- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`. -primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc -primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc -primCharSuffix = char '#' -primFloatSuffix = char '#' -primIntSuffix = char '#' -primDoubleSuffix = text "##" -primWordSuffix = text "##" -primInt64Suffix = text "L#" -primWord64Suffix = text "L##" - --- | Special combinator for showing unboxed literals. -pprPrimChar :: Char -> SDoc -pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc -pprPrimChar c = pprHsChar c <> primCharSuffix -pprPrimInt i = integer i <> primIntSuffix -pprPrimWord w = word w <> primWordSuffix -pprPrimInt64 i = integer i <> primInt64Suffix -pprPrimWord64 w = word w <> primWord64Suffix - ---------------------- --- Put a name in parens if it's an operator -pprPrefixVar :: Bool -> SDoc -> SDoc -pprPrefixVar is_operator pp_v - | is_operator = parens pp_v - | otherwise = pp_v - --- Put a name in backquotes if it's not an operator -pprInfixVar :: Bool -> SDoc -> SDoc -pprInfixVar is_operator pp_v - | is_operator = pp_v - | otherwise = char '`' <> pp_v <> char '`' - ---------------------- -pprFastFilePath :: FastString -> SDoc -pprFastFilePath path = text $ normalise $ unpackFS path - --- | Normalise, escape and render a string representing a path --- --- e.g. "c:\\whatever" -pprFilePathString :: FilePath -> SDoc -pprFilePathString path = doubleQuotes $ text (escape (normalise path)) - where - escape [] = [] - escape ('\\':xs) = '\\':'\\':escape xs - escape (x:xs) = x:escape xs - -{- -************************************************************************ -* * -\subsection{Other helper functions} -* * -************************************************************************ --} - -pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use - -> [a] -- ^ The things to be pretty printed - -> SDoc -- ^ 'SDoc' where the things have been pretty printed, - -- comma-separated and finally packed into a paragraph. -pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) - -pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use - -> [a] -- ^ The things to be pretty printed - -> SDoc -- ^ 'SDoc' where the things have been pretty printed, - -- bar-separated and finally packed into a paragraph. -pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) - --- | Returns the separated concatenation of the pretty printed things. -interppSP :: Outputable a => [a] -> SDoc -interppSP xs = sep (map ppr xs) - --- | Returns the comma-separated concatenation of the pretty printed things. -interpp'SP :: Outputable a => [a] -> SDoc -interpp'SP xs = sep (punctuate comma (map ppr xs)) - --- | Returns the comma-separated concatenation of the quoted pretty printed things. --- --- > [x,y,z] ==> `x', `y', `z' -pprQuotedList :: Outputable a => [a] -> SDoc -pprQuotedList = quotedList . map ppr - -quotedList :: [SDoc] -> SDoc -quotedList xs = fsep (punctuate comma (map quotes xs)) - -quotedListWithOr :: [SDoc] -> SDoc --- [x,y,z] ==> `x', `y' or `z' -quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) -quotedListWithOr xs = quotedList xs - -quotedListWithNor :: [SDoc] -> SDoc --- [x,y,z] ==> `x', `y' nor `z' -quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) -quotedListWithNor xs = quotedList xs - -{- -************************************************************************ -* * -\subsection{Printing numbers verbally} -* * -************************************************************************ --} - -intWithCommas :: Integral a => a -> SDoc --- Prints a big integer with commas, eg 345,821 -intWithCommas n - | n < 0 = char '-' <> intWithCommas (-n) - | q == 0 = int (fromIntegral r) - | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) - where - (q,r) = n `quotRem` 1000 - zeroes | r >= 100 = empty - | r >= 10 = char '0' - | otherwise = text "00" - --- | Converts an integer to a verbal index: --- --- > speakNth 1 = text "first" --- > speakNth 5 = text "fifth" --- > speakNth 21 = text "21st" -speakNth :: Int -> SDoc -speakNth 1 = text "first" -speakNth 2 = text "second" -speakNth 3 = text "third" -speakNth 4 = text "fourth" -speakNth 5 = text "fifth" -speakNth 6 = text "sixth" -speakNth n = hcat [ int n, text suffix ] - where - suffix | n <= 20 = "th" -- 11,12,13 are non-std - | last_dig == 1 = "st" - | last_dig == 2 = "nd" - | last_dig == 3 = "rd" - | otherwise = "th" - - last_dig = n `rem` 10 - --- | Converts an integer to a verbal multiplicity: --- --- > speakN 0 = text "none" --- > speakN 5 = text "five" --- > speakN 10 = text "10" -speakN :: Int -> SDoc -speakN 0 = text "none" -- E.g. "he has none" -speakN 1 = text "one" -- E.g. "he has one" -speakN 2 = text "two" -speakN 3 = text "three" -speakN 4 = text "four" -speakN 5 = text "five" -speakN 6 = text "six" -speakN n = int n - --- | Converts an integer and object description to a statement about the --- multiplicity of those objects: --- --- > speakNOf 0 (text "melon") = text "no melons" --- > speakNOf 1 (text "melon") = text "one melon" --- > speakNOf 3 (text "melon") = text "three melons" -speakNOf :: Int -> SDoc -> SDoc -speakNOf 0 d = text "no" <+> d <> char 's' -speakNOf 1 d = text "one" <+> d -- E.g. "one argument" -speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" - --- | Determines the pluralisation suffix appropriate for the length of a list: --- --- > plural [] = char 's' --- > plural ["Hello"] = empty --- > plural ["Hello", "World"] = char 's' -plural :: [a] -> SDoc -plural [_] = empty -- a bit frightening, but there you are -plural _ = char 's' - --- | Determines the form of to be appropriate for the length of a list: --- --- > isOrAre [] = text "are" --- > isOrAre ["Hello"] = text "is" --- > isOrAre ["Hello", "World"] = text "are" -isOrAre :: [a] -> SDoc -isOrAre [_] = text "is" -isOrAre _ = text "are" - --- | Determines the form of to do appropriate for the length of a list: --- --- > doOrDoes [] = text "do" --- > doOrDoes ["Hello"] = text "does" --- > doOrDoes ["Hello", "World"] = text "do" -doOrDoes :: [a] -> SDoc -doOrDoes [_] = text "does" -doOrDoes _ = text "do" - -{- -************************************************************************ -* * -\subsection{Error handling} -* * -************************************************************************ --} - -callStackDoc :: HasCallStack => SDoc -callStackDoc = - hang (text "Call stack:") - 4 (vcat $ map text $ lines (prettyCallStack callStack)) - -pprPanic :: HasCallStack => String -> SDoc -> a --- ^ Throw an exception saying "bug in GHC" -pprPanic s doc = panicDoc s (doc $$ callStackDoc) - -pprSorry :: String -> SDoc -> a --- ^ Throw an exception saying "this isn't finished yet" -pprSorry = sorryDoc - - -pprPgmError :: String -> SDoc -> a --- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprPgmError = pgmErrorDoc - -pprTraceDebug :: String -> SDoc -> a -> a -pprTraceDebug str doc x - | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x - | otherwise = x - -pprTrace :: String -> SDoc -> a -> a --- ^ If debug output is on, show some 'SDoc' on the screen -pprTrace str doc x - | hasNoDebugOutput unsafeGlobalDynFlags = x - | otherwise = - pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x - -pprTraceM :: Applicative f => String -> SDoc -> f () -pprTraceM str doc = pprTrace str doc (pure ()) - --- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@. --- This allows you to print details from the returned value as well as from --- ambient variables. -pprTraceWith :: String -> (a -> SDoc) -> a -> a -pprTraceWith desc f x = pprTrace desc (f x) x - --- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ -pprTraceIt :: Outputable a => String -> a -> a -pprTraceIt desc x = pprTraceWith desc ppr x - --- | @pprTraceException desc x action@ runs action, printing a message --- if it throws an exception. -pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a -pprTraceException heading doc = - handleGhcException $ \exc -> liftIO $ do - putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc]) - throwGhcExceptionIO exc - --- | If debug output is on, show some 'SDoc' on the screen along --- with a call stack when available. -pprSTrace :: HasCallStack => SDoc -> a -> a -pprSTrace doc = pprTrace "" (doc $$ callStackDoc) - -warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a --- ^ Just warn about an assertion failure, recording the given file and line number. --- Should typically be accessed with the WARN macros -warnPprTrace _ _ _ _ x | not debugIsOn = x -warnPprTrace _ _file _line _msg x - | hasNoDebugOutput unsafeGlobalDynFlags = x -warnPprTrace False _file _line _msg x = x -warnPprTrace True file line msg x - = pprDebugAndThen unsafeGlobalDynFlags trace heading - (msg $$ callStackDoc ) - x - where - heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] - --- | Panic with an assertation failure, recording the given file and --- line number. Should typically be accessed with the ASSERT family of macros -assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a -assertPprPanic _file _line msg - = pprPanic "ASSERT failed!" msg - -pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a -pprDebugAndThen dflags cont heading pretty_msg - = cont (showSDocDump dflags doc) - where - doc = sep [heading, nest 2 pretty_msg] diff --git a/utils/Outputable.hs-boot b/utils/Outputable.hs-boot deleted file mode 100644 --- a/utils/Outputable.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module Outputable where - -import GhcPrelude -import GHC.Stack( HasCallStack ) - -data SDoc - -showSDocUnsafe :: SDoc -> String - -warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a - -text :: String -> SDoc diff --git a/utils/Pair.hs b/utils/Pair.hs deleted file mode 100644 --- a/utils/Pair.hs +++ /dev/null @@ -1,60 +0,0 @@ -{- -A simple homogeneous pair type with useful Functor, Applicative, and -Traversable instances. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Outputable -import qualified Data.Semigroup as Semi - -data Pair a = Pair { pFst :: a, pSnd :: a } - deriving (Functor) --- Note that Pair is a *unary* type constructor --- whereas (,) is binary - --- The important thing about Pair is that it has a *homogeneous* --- Functor instance, so you can easily apply the same function --- to both components - -instance Applicative Pair where - pure x = Pair x x - (Pair f g) <*> (Pair x y) = Pair (f x) (g y) - -instance Foldable Pair where - foldMap f (Pair x y) = f x `mappend` f y - -instance Traversable Pair where - traverse f (Pair x y) = Pair <$> f x <*> f y - -instance Semi.Semigroup a => Semi.Semigroup (Pair a) where - Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) - -instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where - mempty = Pair mempty mempty - mappend = (Semi.<>) - -instance Outputable a => Outputable (Pair a) where - ppr (Pair a b) = ppr a <+> char '~' <+> ppr b - -unPair :: Pair a -> (a,a) -unPair (Pair x y) = (x,y) - -toPair :: (a,a) -> Pair a -toPair (x,y) = Pair x y - -swap :: Pair a -> Pair a -swap (Pair x y) = Pair y x - -pLiftFst :: (a -> a) -> Pair a -> Pair a -pLiftFst f (Pair a b) = Pair (f a) b - -pLiftSnd :: (a -> a) -> Pair a -> Pair a -pLiftSnd f (Pair a b) = Pair a (f b) diff --git a/utils/Panic.hs b/utils/Panic.hs deleted file mode 100644 --- a/utils/Panic.hs +++ /dev/null @@ -1,259 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP Project, Glasgow University, 1992-2000 - -Defines basic functions for printing error messages. - -It's hard to put these functions anywhere else without causing -some unnecessary loops in the module dependency graph. --} - -{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} - -module Panic ( - GhcException(..), showGhcException, - throwGhcException, throwGhcExceptionIO, - handleGhcException, - PlainPanic.progName, - pgmError, - - panic, sorry, assertPanic, trace, - panicDoc, sorryDoc, pgmErrorDoc, - - cmdLineError, cmdLineErrorIO, - - Exception.Exception(..), showException, safeShowException, - try, tryMost, throwTo, - - withSignalHandlers, -) where - -import GhcPrelude - -import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe) -import PlainPanic - -import Exception - -import Control.Monad.IO.Class -import Control.Concurrent -import Data.Typeable ( cast ) -import Debug.Trace ( trace ) -import System.IO.Unsafe - -#if !defined(mingw32_HOST_OS) -import System.Posix.Signals as S -#endif - -#if defined(mingw32_HOST_OS) -import GHC.ConsoleHandler as S -#endif - -import System.Mem.Weak ( deRefWeak ) - --- | GHC's own exception type --- error messages all take the form: --- --- @ --- : --- @ --- --- If the location is on the command line, or in GHC itself, then --- ="ghc". All of the error types below correspond to --- a of "ghc", except for ProgramError (where the string is --- assumed to contain a location already, so we don't print one). - -data GhcException - -- | Some other fatal signal (SIGHUP,SIGTERM) - = Signal Int - - -- | Prints the short usage msg after the error - | UsageError String - - -- | A problem with the command line arguments, but don't print usage. - | CmdLineError String - - -- | The 'impossible' happened. - | Panic String - | PprPanic String SDoc - - -- | The user tickled something that's known not to work yet, - -- but we're not counting it as a bug. - | Sorry String - | PprSorry String SDoc - - -- | An installation problem. - | InstallationError String - - -- | An error in the user's code, probably. - | ProgramError String - | PprProgramError String SDoc - -instance Exception GhcException where - fromException (SomeException e) - | Just ge <- cast e = Just ge - | Just pge <- cast e = Just $ - case pge of - PlainSignal n -> Signal n - PlainUsageError str -> UsageError str - PlainCmdLineError str -> CmdLineError str - PlainPanic str -> Panic str - PlainSorry str -> Sorry str - PlainInstallationError str -> InstallationError str - PlainProgramError str -> ProgramError str - | otherwise = Nothing - -instance Show GhcException where - showsPrec _ e@(ProgramError _) = showGhcException e - showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e - showsPrec _ e = showString progName . showString ": " . showGhcException e - --- | Show an exception as a string. -showException :: Exception e => e -> String -showException = show - --- | Show an exception which can possibly throw other exceptions. --- Used when displaying exception thrown within TH code. -safeShowException :: Exception e => e -> IO String -safeShowException e = do - -- ensure the whole error message is evaluated inside try - r <- try (return $! forceList (showException e)) - case r of - Right msg -> return msg - Left e' -> safeShowException (e' :: SomeException) - where - forceList [] = [] - forceList xs@(x : xt) = x `seq` forceList xt `seq` xs - --- | Append a description of the given exception to this string. --- --- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some --- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. --- If the error message to be printed includes a pretty-printer document --- which forces one of these fields this call may bottom. -showGhcException :: GhcException -> ShowS -showGhcException = showPlainGhcException . \case - Signal n -> PlainSignal n - UsageError str -> PlainUsageError str - CmdLineError str -> PlainCmdLineError str - Panic str -> PlainPanic str - Sorry str -> PlainSorry str - InstallationError str -> PlainInstallationError str - ProgramError str -> PlainProgramError str - - PprPanic str sdoc -> PlainPanic $ - concat [str, "\n\n", showSDocUnsafe sdoc] - PprSorry str sdoc -> PlainProgramError $ - concat [str, "\n\n", showSDocUnsafe sdoc] - PprProgramError str sdoc -> PlainProgramError $ - concat [str, "\n\n", showSDocUnsafe sdoc] - -throwGhcException :: GhcException -> a -throwGhcException = Exception.throw - -throwGhcExceptionIO :: GhcException -> IO a -throwGhcExceptionIO = Exception.throwIO - -handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a -handleGhcException = ghandle - -panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a -panicDoc x doc = throwGhcException (PprPanic x doc) -sorryDoc x doc = throwGhcException (PprSorry x doc) -pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) - --- | Like try, but pass through UserInterrupt and Panic exceptions. --- Used when we want soft failures when reading interface files, for example. --- TODO: I'm not entirely sure if this is catching what we really want to catch -tryMost :: IO a -> IO (Either SomeException a) -tryMost action = do r <- try action - case r of - Left se -> - case fromException se of - -- Some GhcException's we rethrow, - Just (Signal _) -> throwIO se - Just (Panic _) -> throwIO se - -- others we return - Just _ -> return (Left se) - Nothing -> - case fromException se of - -- All IOExceptions are returned - Just (_ :: IOException) -> - return (Left se) - -- Anything else is rethrown - Nothing -> throwIO se - Right v -> return (Right v) - --- | We use reference counting for signal handlers -{-# NOINLINE signalHandlersRefCount #-} -#if !defined(mingw32_HOST_OS) -signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler - ,S.Handler,S.Handler)) -#else -signalHandlersRefCount :: MVar (Word, Maybe S.Handler) -#endif -signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) - - --- | Temporarily install standard signal handlers for catching ^C, which just --- throw an exception in the current thread. -withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a -withSignalHandlers act = do - main_thread <- liftIO myThreadId - wtid <- liftIO (mkWeakThreadId main_thread) - - let - interrupt = do - r <- deRefWeak wtid - case r of - Nothing -> return () - Just t -> throwTo t UserInterrupt - -#if !defined(mingw32_HOST_OS) - let installHandlers = do - let installHandler' a b = installHandler a b Nothing - hdlQUIT <- installHandler' sigQUIT (Catch interrupt) - hdlINT <- installHandler' sigINT (Catch interrupt) - -- see #3656; in the future we should install these automatically for - -- all Haskell programs in the same way that we install a ^C handler. - let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) - hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) - hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) - return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) - - let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do - _ <- installHandler sigQUIT hdlQUIT Nothing - _ <- installHandler sigINT hdlINT Nothing - _ <- installHandler sigHUP hdlHUP Nothing - _ <- installHandler sigTERM hdlTERM Nothing - return () -#else - -- GHC 6.3+ has support for console events on Windows - -- NOTE: running GHCi under a bash shell for some reason requires - -- you to press Ctrl-Break rather than Ctrl-C to provoke - -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know - -- why --SDM 17/12/2004 - let sig_handler ControlC = interrupt - sig_handler Break = interrupt - sig_handler _ = return () - - let installHandlers = installHandler (Catch sig_handler) - let uninstallHandlers = installHandler -- directly install the old handler -#endif - - -- install signal handlers if necessary - let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case - (0,Nothing) -> do - hdls <- installHandlers - return (1,Just hdls) - (c,oldHandlers) -> return (c+1,oldHandlers) - - -- uninstall handlers if necessary - let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case - (1,Just hdls) -> do - _ <- uninstallHandlers hdls - return (0,Nothing) - (c,oldHandlers) -> return (c-1,oldHandlers) - - mayInstallHandlers - act `gfinally` mayUninstallHandlers diff --git a/utils/PlainPanic.hs b/utils/PlainPanic.hs deleted file mode 100644 --- a/utils/PlainPanic.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} - --- | Defines a simple exception type and utilities to throw it. The --- 'PlainGhcException' type is a subset of the 'Panic.GhcException' --- type. It omits the exception constructors that involve --- pretty-printing via 'Outputable.SDoc'. --- --- There are two reasons for this: --- --- 1. To avoid import cycles / use of boot files. "Outputable" has --- many transitive dependencies. To throw exceptions from these --- modules, the functions here can be used without introducing import --- cycles. --- --- 2. To reduce the number of modules that need to be compiled to --- object code when loading GHC into GHCi. See #13101 -module PlainPanic - ( PlainGhcException(..) - , showPlainGhcException - - , panic, sorry, pgmError - , cmdLineError, cmdLineErrorIO - , assertPanic - - , progName - ) where - -#include "HsVersions.h" - -import Config -import Exception -import GHC.Stack -import GhcPrelude -import System.Environment -import System.IO.Unsafe - --- | This type is very similar to 'Panic.GhcException', but it omits --- the constructors that involve pretty-printing via --- 'Outputable.SDoc'. Due to the implementation of 'fromException' --- for 'Panic.GhcException', this type can be caught as a --- 'Panic.GhcException'. --- --- Note that this should only be used for throwing exceptions, not for --- catching, as 'Panic.GhcException' will not be converted to this --- type when catching. -data PlainGhcException - -- | Some other fatal signal (SIGHUP,SIGTERM) - = PlainSignal Int - - -- | Prints the short usage msg after the error - | PlainUsageError String - - -- | A problem with the command line arguments, but don't print usage. - | PlainCmdLineError String - - -- | The 'impossible' happened. - | PlainPanic String - - -- | The user tickled something that's known not to work yet, - -- but we're not counting it as a bug. - | PlainSorry String - - -- | An installation problem. - | PlainInstallationError String - - -- | An error in the user's code, probably. - | PlainProgramError String - -instance Exception PlainGhcException - -instance Show PlainGhcException where - showsPrec _ e@(PlainProgramError _) = showPlainGhcException e - showsPrec _ e@(PlainCmdLineError _) = showString ": " . showPlainGhcException e - showsPrec _ e = showString progName . showString ": " . showPlainGhcException e - --- | The name of this GHC. -progName :: String -progName = unsafePerformIO (getProgName) -{-# NOINLINE progName #-} - --- | Short usage information to display when we are given the wrong cmd line arguments. -short_usage :: String -short_usage = "Usage: For basic information, try the `--help' option." - --- | Append a description of the given exception to this string. -showPlainGhcException :: PlainGhcException -> ShowS -showPlainGhcException = - \case - PlainSignal n -> showString "signal: " . shows n - PlainUsageError str -> showString str . showChar '\n' . showString short_usage - PlainCmdLineError str -> showString str - PlainPanic s -> panicMsg (showString s) - PlainSorry s -> sorryMsg (showString s) - PlainInstallationError str -> showString str - PlainProgramError str -> showString str - where - sorryMsg :: ShowS -> ShowS - sorryMsg s = - showString "sorry! (unimplemented feature or known bug)\n" - . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") - . s . showString "\n" - - panicMsg :: ShowS -> ShowS - panicMsg s = - showString "panic! (the 'impossible' happened)\n" - . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") - . s . showString "\n\n" - . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" - -throwPlainGhcException :: PlainGhcException -> a -throwPlainGhcException = Exception.throw - --- | Panics and asserts. -panic, sorry, pgmError :: String -> a -panic x = unsafeDupablePerformIO $ do - stack <- ccsToStrings =<< getCurrentCCS x - if null stack - then throwPlainGhcException (PlainPanic x) - else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) - -sorry x = throwPlainGhcException (PlainSorry x) -pgmError x = throwPlainGhcException (PlainProgramError x) - -cmdLineError :: String -> a -cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO - -cmdLineErrorIO :: String -> IO a -cmdLineErrorIO x = do - stack <- ccsToStrings =<< getCurrentCCS x - if null stack - then throwPlainGhcException (PlainCmdLineError x) - else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) - --- | Throw a failed assertion exception for a given filename and line number. -assertPanic :: String -> Int -> a -assertPanic file line = - Exception.throw (Exception.AssertionFailed - ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) diff --git a/utils/PprColour.hs b/utils/PprColour.hs deleted file mode 100644 --- a/utils/PprColour.hs +++ /dev/null @@ -1,101 +0,0 @@ -module PprColour where -import GhcPrelude - -import Data.Maybe (fromMaybe) -import Util (OverridingBool(..), split) -import Data.Semigroup as Semi - --- | A colour\/style for use with 'coloured'. -newtype PprColour = PprColour { renderColour :: String } - -instance Semi.Semigroup PprColour where - PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) - --- | Allow colours to be combined (e.g. bold + red); --- In case of conflict, right side takes precedence. -instance Monoid PprColour where - mempty = PprColour mempty - mappend = (<>) - -renderColourAfresh :: PprColour -> String -renderColourAfresh c = renderColour (colReset `mappend` c) - -colCustom :: String -> PprColour -colCustom "" = mempty -colCustom s = PprColour ("\27[" ++ s ++ "m") - -colReset :: PprColour -colReset = colCustom "0" - -colBold :: PprColour -colBold = colCustom ";1" - -colBlackFg :: PprColour -colBlackFg = colCustom "30" - -colRedFg :: PprColour -colRedFg = colCustom "31" - -colGreenFg :: PprColour -colGreenFg = colCustom "32" - -colYellowFg :: PprColour -colYellowFg = colCustom "33" - -colBlueFg :: PprColour -colBlueFg = colCustom "34" - -colMagentaFg :: PprColour -colMagentaFg = colCustom "35" - -colCyanFg :: PprColour -colCyanFg = colCustom "36" - -colWhiteFg :: PprColour -colWhiteFg = colCustom "37" - -data Scheme = - Scheme - { sHeader :: PprColour - , sMessage :: PprColour - , sWarning :: PprColour - , sError :: PprColour - , sFatal :: PprColour - , sMargin :: PprColour - } - -defaultScheme :: Scheme -defaultScheme = - Scheme - { sHeader = mempty - , sMessage = colBold - , sWarning = colBold `mappend` colMagentaFg - , sError = colBold `mappend` colRedFg - , sFatal = colBold `mappend` colRedFg - , sMargin = colBold `mappend` colBlueFg - } - --- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ --- environment variable). -parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) -parseScheme "always" (_, cs) = (Always, cs) -parseScheme "auto" (_, cs) = (Auto, cs) -parseScheme "never" (_, cs) = (Never, cs) -parseScheme input (b, cs) = - ( b - , Scheme - { sHeader = fromMaybe (sHeader cs) (lookup "header" table) - , sMessage = fromMaybe (sMessage cs) (lookup "message" table) - , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) - , sError = fromMaybe (sError cs) (lookup "error" table) - , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) - , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) - } - ) - where - table = do - w <- split ':' input - let (k, v') = break (== '=') w - case v' of - '=' : v -> return (k, colCustom v) - _ -> [] diff --git a/utils/Pretty.hs b/utils/Pretty.hs deleted file mode 100644 --- a/utils/Pretty.hs +++ /dev/null @@ -1,1105 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : Pretty --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : David Terei --- Stability : stable --- Portability : portable --- --- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators --- --- Based on /The Design of a Pretty-printing Library/ --- in Advanced Functional Programming, --- Johan Jeuring and Erik Meijer (eds), LNCS 925 --- --- ------------------------------------------------------------------------------ - -{- -Note [Differences between libraries/pretty and compiler/utils/Pretty.hs] - -For historical reasons, there are two different copies of `Pretty` in the GHC -source tree: - * `libraries/pretty` is a submodule containing - https://github.com/haskell/pretty. This is the `pretty` library as released - on hackage. It is used by several other libraries in the GHC source tree - (e.g. template-haskell and Cabal). - * `compiler/utils/Pretty.hs` (this module). It is used by GHC only. - -There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and -https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy -of Pretty. - -Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following -major differences: - * GHC's copy uses `Faststring` for performance reasons. - * GHC's copy has received a backported bugfix for #12227, which was - released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", - https://github.com/haskell/pretty/pull/35). - -Other differences are minor. Both copies define some extra functions and -instances not defined in the other copy. To see all differences, do this in a -ghc git tree: - - $ cd libraries/pretty - $ git checkout v1.1.2.0 - $ cd - - $ vimdiff compiler/utils/Pretty.hs \ - libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs - -For parity with `pretty-1.1.2.1`, the following two `pretty` commits would -have to be backported: - * "Resolve foldr-strictness stack overflow bug" - (307b8173f41cd776eae8f547267df6d72bff2d68) - * "Special-case reduce for horiz/vert" - (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) -This has not been done sofar, because these commits seem to cause more -allocation in the compiler (see thomie's comments in -https://github.com/haskell/pretty/pull/9). --} - -module Pretty ( - - -- * The document type - Doc, TextDetails(..), - - -- * Constructing documents - - -- ** Converting values into documents - char, text, ftext, ptext, ztext, sizedText, zeroWidthText, - int, integer, float, double, rational, hex, - - -- ** Simple derived documents - semi, comma, colon, space, equals, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, - - -- ** Wrapping documents in delimiters - parens, brackets, braces, quotes, quote, doubleQuotes, - maybeParens, - - -- ** Combining documents - empty, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - nest, - hang, hangNotEmpty, punctuate, - - -- * Predicates on documents - isEmpty, - - -- * Rendering documents - - -- ** Rendering with a particular style - Style(..), - style, - renderStyle, - Mode(..), - - -- ** General rendering - fullRender, txtPrinter, - - -- ** GHC-specific rendering - printDoc, printDoc_, - bufLeftRender -- performance hack - - ) where - -import GhcPrelude hiding (error) - -import BufWrite -import FastString -import PlainPanic -import System.IO -import Numeric (showHex) - ---for a RULES -import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) -import GHC.Ptr ( Ptr(..) ) - --- --------------------------------------------------------------------------- --- The Doc calculus - -{- -Laws for $$ -~~~~~~~~~~~ - (x $$ y) $$ z = x $$ (y $$ z) - empty $$ x = x - x $$ empty = x - - ...ditto $+$... - -Laws for <> -~~~~~~~~~~~ - (x <> y) <> z = x <> (y <> z) - empty <> x = empty - x <> empty = x - - ...ditto <+>... - -Laws for text -~~~~~~~~~~~~~ - text s <> text t = text (s++t) - text "" <> x = x, if x non-empty - -** because of law n6, t2 only holds if x doesn't -** start with `nest'. - - -Laws for nest -~~~~~~~~~~~~~ - nest 0 x = x - nest k (nest k' x) = nest (k+k') x - nest k (x <> y) = nest k x <> nest k y - nest k (x $$ y) = nest k x $$ nest k y - nest k empty = empty - x <> nest k y = x <> y, if x non-empty - -** Note the side condition on ! It is this that -** makes it OK for empty to be a left unit for <>. - -Miscellaneous -~~~~~~~~~~~~~ - (text s <> x) $$ y = text s <> ((text "" <> x) $$ - nest (-length s) y) - - (x $$ y) <> z = x $$ (y <> z) - if y non-empty - - -Laws for list versions -~~~~~~~~~~~~~~~~~~~~~~ - sep (ps++[empty]++qs) = sep (ps ++ qs) - ...ditto hsep, hcat, vcat, fill... - - nest k (sep ps) = sep (map (nest k) ps) - ...ditto hsep, hcat, vcat, fill... - -Laws for oneLiner -~~~~~~~~~~~~~~~~~ - oneLiner (nest k p) = nest k (oneLiner p) - oneLiner (x <> y) = oneLiner x <> oneLiner y - -You might think that the following version of would -be neater: - -<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ - nest (-length s) y) - -But it doesn't work, for if x=empty, we would have - - text s $$ y = text s <> (empty $$ nest (-length s) y) - = text s <> nest (-length s) y --} - --- --------------------------------------------------------------------------- --- Operator fixity - -infixl 6 <> -infixl 6 <+> -infixl 5 $$, $+$ - - --- --------------------------------------------------------------------------- --- The Doc data type - --- | The abstract type of documents. --- A Doc represents a *set* of layouts. A Doc with --- no occurrences of Union or NoDoc represents just one layout. -data Doc - = Empty -- empty - | NilAbove Doc -- text "" $$ x - | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x - | Nest {-# UNPACK #-} !Int Doc -- nest k x - | Union Doc Doc -- ul `union` ur - | NoDoc -- The empty set of documents - | Beside Doc Bool Doc -- True <=> space between - | Above Doc Bool Doc -- True <=> never overlap - -{- -Here are the invariants: - -1) The argument of NilAbove is never Empty. Therefore - a NilAbove occupies at least two lines. - -2) The argument of @TextBeside@ is never @Nest@. - -3) The layouts of the two arguments of @Union@ both flatten to the same - string. - -4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. - -5) A @NoDoc@ may only appear on the first line of the left argument of an - union. Therefore, the right argument of an union can never be equivalent - to the empty set (@NoDoc@). - -6) An empty document is always represented by @Empty@. It can't be - hidden inside a @Nest@, or a @Union@ of two @Empty@s. - -7) The first line of every layout in the left argument of @Union@ is - longer than the first line of any layout in the right argument. - (1) ensures that the left argument has a first line. In view of - (3), this invariant means that the right argument must have at - least two lines. - -Notice the difference between - * NoDoc (no documents) - * Empty (one empty document; no height and no width) - * text "" (a document containing the empty string; - one line high, but has no width) --} - - --- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. -type RDoc = Doc - --- | The TextDetails data type --- --- A TextDetails represents a fragment of text that will be --- output at some point. -data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment - | Str String -- ^ A whole String fragment - | PStr FastString -- a hashed string - | ZStr FastZString -- a z-encoded string - | LStr {-# UNPACK #-} !PtrString - -- a '\0'-terminated array of bytes - | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char - -- a repeated character (e.g., ' ') - -instance Show Doc where - showsPrec _ doc cont = fullRender (mode style) (lineLength style) - (ribbonsPerLine style) - txtPrinter cont doc - - --- --------------------------------------------------------------------------- --- Values and Predicates on GDocs and TextDetails - --- | A document of height and width 1, containing a literal character. -char :: Char -> Doc -char c = textBeside_ (Chr c) 1 Empty - --- | A document of height 1 containing a literal string. --- 'text' satisfies the following laws: --- --- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ --- --- * @'text' \"\" '<>' x = x@, if @x@ non-empty --- --- The side condition on the last law is necessary because @'text' \"\"@ --- has height 1, while 'empty' has no height. -text :: String -> Doc -text s = textBeside_ (Str s) (length s) Empty -{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire - -- It must wait till after phase 1 when - -- the unpackCString first is manifested - --- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the --- intermediate packing/unpacking of the string. -{-# RULES "text/str" - forall a. text (unpackCString# a) = ptext (mkPtrString# a) - #-} -{-# RULES "text/unpackNBytes#" - forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) - #-} - -ftext :: FastString -> Doc -ftext s = textBeside_ (PStr s) (lengthFS s) Empty - -ptext :: PtrString -> Doc -ptext s = textBeside_ (LStr s) (lengthPS s) Empty - -ztext :: FastZString -> Doc -ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty - --- | Some text with any width. (@text s = sizedText (length s) s@) -sizedText :: Int -> String -> Doc -sizedText l s = textBeside_ (Str s) l Empty - --- | Some text, but without any width. Use for non-printing text --- such as a HTML or Latex tags -zeroWidthText :: String -> Doc -zeroWidthText = sizedText 0 - --- | The empty document, with no height and no width. --- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere --- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. -empty :: Doc -empty = Empty - --- | Returns 'True' if the document is empty -isEmpty :: Doc -> Bool -isEmpty Empty = True -isEmpty _ = False - -{- -Q: What is the reason for negative indentation (i.e. argument to indent - is < 0) ? - -A: -This indicates an error in the library client's code. -If we compose a <> b, and the first line of b is more indented than some -other lines of b, the law (<> eats nests) may cause the pretty -printer to produce an invalid layout: - -doc |0123345 ------------------- -d1 |a...| -d2 |...b| - |c...| - -d1<>d2 |ab..| - c|....| - -Consider a <> b, let `s' be the length of the last line of `a', `k' the -indentation of the first line of b, and `k0' the indentation of the -left-most line b_i of b. - -The produced layout will have negative indentation if `k - k0 > s', as -the first line of b will be put on the (s+1)th column, effectively -translating b horizontally by (k-s). Now if the i^th line of b has an -indentation k0 < (k-s), it is translated out-of-page, causing -`negative indentation'. --} - - -semi :: Doc -- ^ A ';' character -comma :: Doc -- ^ A ',' character -colon :: Doc -- ^ A ':' character -space :: Doc -- ^ A space character -equals :: Doc -- ^ A '=' character -lparen :: Doc -- ^ A '(' character -rparen :: Doc -- ^ A ')' character -lbrack :: Doc -- ^ A '[' character -rbrack :: Doc -- ^ A ']' character -lbrace :: Doc -- ^ A '{' character -rbrace :: Doc -- ^ A '}' character -semi = char ';' -comma = char ',' -colon = char ':' -space = char ' ' -equals = char '=' -lparen = char '(' -rparen = char ')' -lbrack = char '[' -rbrack = char ']' -lbrace = char '{' -rbrace = char '}' - -spaceText, nlText :: TextDetails -spaceText = Chr ' ' -nlText = Chr '\n' - -int :: Int -> Doc -- ^ @int n = text (show n)@ -integer :: Integer -> Doc -- ^ @integer n = text (show n)@ -float :: Float -> Doc -- ^ @float n = text (show n)@ -double :: Double -> Doc -- ^ @double n = text (show n)@ -rational :: Rational -> Doc -- ^ @rational n = text (show n)@ -hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] -int n = text (show n) -integer n = text (show n) -float n = text (show n) -double n = text (show n) -rational n = text (show n) -hex n = text ('0' : 'x' : padded) - where - str = showHex n "" - strLen = max 1 (length str) - len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) - padded = replicate (len - strLen) '0' ++ str - -parens :: Doc -> Doc -- ^ Wrap document in @(...)@ -brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ -braces :: Doc -> Doc -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ -quote :: Doc -> Doc -doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ -quotes p = char '`' <> p <> char '\'' -quote p = char '\'' <> p -doubleQuotes p = char '"' <> p <> char '"' -parens p = char '(' <> p <> char ')' -brackets p = char '[' <> p <> char ']' -braces p = char '{' <> p <> char '}' - -{- -Note [Print Hexadecimal Literals] - -Relevant discussions: - * Phabricator: https://phabricator.haskell.org/D4465 - * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 - -There is a flag `-dword-hex-literals` that causes literals of -type `Word#` or `Word64#` to be displayed in hexadecimal instead -of decimal when dumping GHC core. It also affects the presentation -of these in GHC's error messages. Additionally, the hexadecimal -encoding of these numbers is zero-padded so that its length is -a power of two. As an example of what this does, -consider the following haskell file `Literals.hs`: - - module Literals where - - alpha :: Int - alpha = 100 + 200 - - beta :: Word -> Word - beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 - -We get the following dumped core when we compile on a 64-bit -machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all --dhex-word-literals literals.hs: - - ==================== Tidy Core ==================== - - ... omitted for brevity ... - - -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} - alpha - alpha = I# 300# - - -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} - beta - beta - = \ x_aYE -> - case x_aYE of { W# x#_a1v0 -> - W# - (plusWord# - (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) - 0x0202##) - } - -Notice that the word literals are in hexadecimals and that they have -been padded with zeroes so that their lengths are 16, 8, and 4, respectively. - --} - --- | Apply 'parens' to 'Doc' if boolean is true. -maybeParens :: Bool -> Doc -> Doc -maybeParens False = id -maybeParens True = parens - --- --------------------------------------------------------------------------- --- Structural operations on GDocs - --- | Perform some simplification of a built up @GDoc@. -reduceDoc :: Doc -> RDoc -reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) -reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) -reduceDoc p = p - --- | List version of '<>'. -hcat :: [Doc] -> Doc -hcat = reduceAB . foldr (beside_' False) empty - --- | List version of '<+>'. -hsep :: [Doc] -> Doc -hsep = reduceAB . foldr (beside_' True) empty - --- | List version of '$$'. -vcat :: [Doc] -> Doc -vcat = reduceAB . foldr (above_' False) empty - --- | Nest (or indent) a document by a given number of positions --- (which may also be negative). 'nest' satisfies the laws: --- --- * @'nest' 0 x = x@ --- --- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ --- --- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ --- --- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ --- --- * @'nest' k 'empty' = 'empty'@ --- --- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty --- --- The side condition on the last law is needed because --- 'empty' is a left identity for '<>'. -nest :: Int -> Doc -> Doc -nest k p = mkNest k (reduceDoc p) - --- | @hang d1 n d2 = sep [d1, nest n d2]@ -hang :: Doc -> Int -> Doc -> Doc -hang d1 n d2 = sep [d1, nest n d2] - --- | Apply 'hang' to the arguments if the first 'Doc' is not empty. -hangNotEmpty :: Doc -> Int -> Doc -> Doc -hangNotEmpty d1 n d2 = if isEmpty d1 - then d2 - else hang d1 n d2 - --- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ -punctuate :: Doc -> [Doc] -> [Doc] -punctuate _ [] = [] -punctuate p (x:xs) = go x xs - where go y [] = [y] - go y (z:zs) = (y <> p) : go z zs - --- mkNest checks for Nest's invariant that it doesn't have an Empty inside it -mkNest :: Int -> Doc -> Doc -mkNest k _ | k `seq` False = undefined -mkNest k (Nest k1 p) = mkNest (k + k1) p -mkNest _ NoDoc = NoDoc -mkNest _ Empty = Empty -mkNest 0 p = p -mkNest k p = nest_ k p - --- mkUnion checks for an empty document -mkUnion :: Doc -> Doc -> Doc -mkUnion Empty _ = Empty -mkUnion p q = p `union_` q - -beside_' :: Bool -> Doc -> Doc -> Doc -beside_' _ p Empty = p -beside_' g p q = Beside p g q - -above_' :: Bool -> Doc -> Doc -> Doc -above_' _ p Empty = p -above_' g p q = Above p g q - -reduceAB :: Doc -> Doc -reduceAB (Above Empty _ q) = q -reduceAB (Beside Empty _ q) = q -reduceAB doc = doc - -nilAbove_ :: RDoc -> RDoc -nilAbove_ = NilAbove - --- Arg of a TextBeside is always an RDoc -textBeside_ :: TextDetails -> Int -> RDoc -> RDoc -textBeside_ = TextBeside - -nest_ :: Int -> RDoc -> RDoc -nest_ = Nest - -union_ :: RDoc -> RDoc -> RDoc -union_ = Union - - --- --------------------------------------------------------------------------- --- Vertical composition @$$@ - --- | Above, except that if the last line of the first argument stops --- at least one position before the first line of the second begins, --- these two lines are overlapped. For example: --- --- > text "hi" $$ nest 5 (text "there") --- --- lays out as --- --- > hi there --- --- rather than --- --- > hi --- > there --- --- '$$' is associative, with identity 'empty', and also satisfies --- --- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. --- -($$) :: Doc -> Doc -> Doc -p $$ q = above_ p False q - --- | Above, with no overlapping. --- '$+$' is associative, with identity 'empty'. -($+$) :: Doc -> Doc -> Doc -p $+$ q = above_ p True q - -above_ :: Doc -> Bool -> Doc -> Doc -above_ p _ Empty = p -above_ Empty _ q = q -above_ p g q = Above p g q - -above :: Doc -> Bool -> RDoc -> RDoc -above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) -above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) -above p g q = aboveNest p g 0 (reduceDoc q) - --- Specification: aboveNest p g k q = p $g$ (nest k q) -aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc -aboveNest _ _ k _ | k `seq` False = undefined -aboveNest NoDoc _ _ _ = NoDoc -aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` - aboveNest p2 g k q - -aboveNest Empty _ k q = mkNest k q -aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) - -- p can't be Empty, so no need for mkNest - -aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) -aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest - where - !k1 = k - sl - rest = case p of - Empty -> nilAboveNest g k1 q - _ -> aboveNest p g k1 q -aboveNest (Above {}) _ _ _ = error "aboveNest Above" -aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" - --- Specification: text s <> nilaboveNest g k q --- = text s <> (text "" $g$ nest k q) -nilAboveNest :: Bool -> Int -> RDoc -> RDoc -nilAboveNest _ k _ | k `seq` False = undefined -nilAboveNest _ _ Empty = Empty - -- Here's why the "text s <>" is in the spec! -nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q -nilAboveNest g k q | not g && k > 0 -- No newline if no overlap - = textBeside_ (RStr k ' ') k q - | otherwise -- Put them really above - = nilAbove_ (mkNest k q) - - --- --------------------------------------------------------------------------- --- Horizontal composition @<>@ - --- We intentionally avoid Data.Monoid.(<>) here due to interactions of --- Data.Monoid.(<>) and (<+>). See --- http://www.haskell.org/pipermail/libraries/2011-November/017066.html - --- | Beside. --- '<>' is associative, with identity 'empty'. -(<>) :: Doc -> Doc -> Doc -p <> q = beside_ p False q - --- | Beside, separated by space, unless one of the arguments is 'empty'. --- '<+>' is associative, with identity 'empty'. -(<+>) :: Doc -> Doc -> Doc -p <+> q = beside_ p True q - -beside_ :: Doc -> Bool -> Doc -> Doc -beside_ p _ Empty = p -beside_ Empty _ q = q -beside_ p g q = Beside p g q - --- Specification: beside g p q = p q -beside :: Doc -> Bool -> RDoc -> RDoc -beside NoDoc _ _ = NoDoc -beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q -beside Empty _ q = q -beside (Nest k p) g q = nest_ k $! beside p g q -beside p@(Beside p1 g1 q1) g2 q2 - | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 - | otherwise = beside (reduceDoc p) g2 q2 -beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q -beside (NilAbove p) g q = nilAbove_ $! beside p g q -beside (TextBeside s sl p) g q = textBeside_ s sl rest - where - rest = case p of - Empty -> nilBeside g q - _ -> beside p g q - --- Specification: text "" <> nilBeside g p --- = text "" p -nilBeside :: Bool -> RDoc -> RDoc -nilBeside _ Empty = Empty -- Hence the text "" in the spec -nilBeside g (Nest _ p) = nilBeside g p -nilBeside g p | g = textBeside_ spaceText 1 p - | otherwise = p - - --- --------------------------------------------------------------------------- --- Separate, @sep@ - --- Specification: sep ps = oneLiner (hsep ps) --- `union` --- vcat ps - --- | Either 'hsep' or 'vcat'. -sep :: [Doc] -> Doc -sep = sepX True -- Separate with spaces - --- | Either 'hcat' or 'vcat'. -cat :: [Doc] -> Doc -cat = sepX False -- Don't - -sepX :: Bool -> [Doc] -> Doc -sepX _ [] = empty -sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps - - --- Specification: sep1 g k ys = sep (x : map (nest k) ys) --- = oneLiner (x nest k (hsep ys)) --- `union` x $$ nest k (vcat ys) -sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc -sep1 _ _ k _ | k `seq` False = undefined -sep1 _ NoDoc _ _ = NoDoc -sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` - aboveNest q False k (reduceDoc (vcat ys)) - -sep1 g Empty k ys = mkNest k (sepX g ys) -sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) - -sep1 _ (NilAbove p) k ys = nilAbove_ - (aboveNest p False k (reduceDoc (vcat ys))) -sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) -sep1 _ (Above {}) _ _ = error "sep1 Above" -sep1 _ (Beside {}) _ _ = error "sep1 Beside" - --- Specification: sepNB p k ys = sep1 (text "" <> p) k ys --- Called when we have already found some text in the first item --- We have to eat up nests -sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc -sepNB g (Nest _ p) k ys - = sepNB g p k ys -- Never triggered, because of invariant (2) -sepNB g Empty k ys - = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` - -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) - nilAboveNest False k (reduceDoc (vcat ys)) - where - rest | g = hsep ys - | otherwise = hcat ys -sepNB g p k ys - = sep1 g p k ys - - --- --------------------------------------------------------------------------- --- @fill@ - --- | \"Paragraph fill\" version of 'cat'. -fcat :: [Doc] -> Doc -fcat = fill False - --- | \"Paragraph fill\" version of 'sep'. -fsep :: [Doc] -> Doc -fsep = fill True - --- Specification: --- --- fill g docs = fillIndent 0 docs --- --- fillIndent k [] = [] --- fillIndent k [p] = p --- fillIndent k (p1:p2:ps) = --- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) --- (remove_nests (oneLiner p2) : ps) --- `Union` --- (p1 $*$ nest (-k) (fillIndent 0 ps)) --- --- $*$ is defined for layouts (not Docs) as --- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 --- | otherwise = layout1 $+$ layout2 - -fill :: Bool -> [Doc] -> RDoc -fill _ [] = empty -fill g (p:ps) = fill1 g (reduceDoc p) 0 ps - -fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc -fill1 _ _ k _ | k `seq` False = undefined -fill1 _ NoDoc _ _ = NoDoc -fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` - aboveNest q False k (fill g ys) -fill1 g Empty k ys = mkNest k (fill g ys) -fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) -fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) -fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) -fill1 _ (Above {}) _ _ = error "fill1 Above" -fill1 _ (Beside {}) _ _ = error "fill1 Beside" - -fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc -fillNB _ _ k _ | k `seq` False = undefined -fillNB g (Nest _ p) k ys = fillNB g p k ys - -- Never triggered, because of invariant (2) -fillNB _ Empty _ [] = Empty -fillNB g Empty k (Empty:ys) = fillNB g Empty k ys -fillNB g Empty k (y:ys) = fillNBE g k y ys -fillNB g p k ys = fill1 g p k ys - - -fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc -fillNBE g k y ys - = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) - -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) - `mkUnion` nilAboveNest False k (fill g (y:ys)) - where k' = if g then k - 1 else k - -elideNest :: Doc -> Doc -elideNest (Nest _ d) = d -elideNest d = d - --- --------------------------------------------------------------------------- --- Selecting the best layout - -best :: Int -- Line length - -> Int -- Ribbon length - -> RDoc - -> RDoc -- No unions in here! -best w0 r = get w0 - where - get :: Int -- (Remaining) width of line - -> Doc -> Doc - get w _ | w == 0 && False = undefined - get _ Empty = Empty - get _ NoDoc = NoDoc - get w (NilAbove p) = nilAbove_ (get w p) - get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) - get w (Nest k p) = nest_ k (get (w - k) p) - get w (p `Union` q) = nicest w r (get w p) (get w q) - get _ (Above {}) = error "best get Above" - get _ (Beside {}) = error "best get Beside" - - get1 :: Int -- (Remaining) width of line - -> Int -- Amount of first line already eaten up - -> Doc -- This is an argument to TextBeside => eat Nests - -> Doc -- No unions in here! - - get1 w _ _ | w == 0 && False = undefined - get1 _ _ Empty = Empty - get1 _ _ NoDoc = NoDoc - get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) - get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) - get1 w sl (Nest _ p) = get1 w sl p - get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) - (get1 w sl q) - get1 _ _ (Above {}) = error "best get1 Above" - get1 _ _ (Beside {}) = error "best get1 Beside" - -nicest :: Int -> Int -> Doc -> Doc -> Doc -nicest !w !r = nicest1 w r 0 - -nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc -nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p - | otherwise = q - -fits :: Int -- Space available - -> Doc - -> Bool -- True if *first line* of Doc fits in space available -fits n _ | n < 0 = False -fits _ NoDoc = False -fits _ Empty = True -fits _ (NilAbove _) = True -fits n (TextBeside _ sl p) = fits (n - sl) p -fits _ (Above {}) = error "fits Above" -fits _ (Beside {}) = error "fits Beside" -fits _ (Union {}) = error "fits Union" -fits _ (Nest {}) = error "fits Nest" - --- | @first@ returns its first argument if it is non-empty, otherwise its second. -first :: Doc -> Doc -> Doc -first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused - | otherwise = q - -nonEmptySet :: Doc -> Bool -nonEmptySet NoDoc = False -nonEmptySet (_ `Union` _) = True -nonEmptySet Empty = True -nonEmptySet (NilAbove _) = True -nonEmptySet (TextBeside _ _ p) = nonEmptySet p -nonEmptySet (Nest _ p) = nonEmptySet p -nonEmptySet (Above {}) = error "nonEmptySet Above" -nonEmptySet (Beside {}) = error "nonEmptySet Beside" - --- @oneLiner@ returns the one-line members of the given set of @GDoc@s. -oneLiner :: Doc -> Doc -oneLiner NoDoc = NoDoc -oneLiner Empty = Empty -oneLiner (NilAbove _) = NoDoc -oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) -oneLiner (Nest k p) = nest_ k (oneLiner p) -oneLiner (p `Union` _) = oneLiner p -oneLiner (Above {}) = error "oneLiner Above" -oneLiner (Beside {}) = error "oneLiner Beside" - - --- --------------------------------------------------------------------------- --- Rendering - --- | A rendering style. -data Style - = Style { mode :: Mode -- ^ The rendering mode - , lineLength :: Int -- ^ Length of line, in chars - , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length - } - --- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). -style :: Style -style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } - --- | Rendering mode. -data Mode = PageMode -- ^ Normal - | ZigZagMode -- ^ With zig-zag cuts - | LeftMode -- ^ No indentation, infinitely long lines - | OneLineMode -- ^ All on one line - --- | Render the @Doc@ to a String using the given @Style@. -renderStyle :: Style -> Doc -> String -renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) - txtPrinter "" - --- | Default TextDetails printer -txtPrinter :: TextDetails -> String -> String -txtPrinter (Chr c) s = c:s -txtPrinter (Str s1) s2 = s1 ++ s2 -txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 -txtPrinter (ZStr s1) s2 = zString s1 ++ s2 -txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 -txtPrinter (RStr n c) s2 = replicate n c ++ s2 - --- | The general rendering interface. -fullRender :: Mode -- ^ Rendering mode - -> Int -- ^ Line length - -> Float -- ^ Ribbons per line - -> (TextDetails -> a -> a) -- ^ What to do with text - -> a -- ^ What to do at the end - -> Doc -- ^ The document - -> a -- ^ Result -fullRender OneLineMode _ _ txt end doc - = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) -fullRender LeftMode _ _ txt end doc - = easyDisplay nlText first txt end (reduceDoc doc) - -fullRender m lineLen ribbons txt rest doc - = display m lineLen ribbonLen txt rest doc' - where - doc' = best bestLineLen ribbonLen (reduceDoc doc) - - bestLineLen, ribbonLen :: Int - ribbonLen = round (fromIntegral lineLen / ribbons) - bestLineLen = case m of - ZigZagMode -> maxBound - _ -> lineLen - -easyDisplay :: TextDetails - -> (Doc -> Doc -> Doc) - -> (TextDetails -> a -> a) - -> a - -> Doc - -> a -easyDisplay nlSpaceText choose txt end - = lay - where - lay NoDoc = error "easyDisplay: NoDoc" - lay (Union p q) = lay (choose p q) - lay (Nest _ p) = lay p - lay Empty = end - lay (NilAbove p) = nlSpaceText `txt` lay p - lay (TextBeside s _ p) = s `txt` lay p - lay (Above {}) = error "easyDisplay Above" - lay (Beside {}) = error "easyDisplay Beside" - -display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a -display m !page_width !ribbon_width txt end doc - = case page_width - ribbon_width of { gap_width -> - case gap_width `quot` 2 of { shift -> - let - lay k _ | k `seq` False = undefined - lay k (Nest k1 p) = lay (k + k1) p - lay _ Empty = end - lay k (NilAbove p) = nlText `txt` lay k p - lay k (TextBeside s sl p) - = case m of - ZigZagMode | k >= gap_width - -> nlText `txt` ( - Str (replicate shift '/') `txt` ( - nlText `txt` - lay1 (k - shift) s sl p )) - - | k < 0 - -> nlText `txt` ( - Str (replicate shift '\\') `txt` ( - nlText `txt` - lay1 (k + shift) s sl p )) - - _ -> lay1 k s sl p - lay _ (Above {}) = error "display lay Above" - lay _ (Beside {}) = error "display lay Beside" - lay _ NoDoc = error "display lay NoDoc" - lay _ (Union {}) = error "display lay Union" - - lay1 !k s !sl p = let !r = k + sl - in indent k (s `txt` lay2 r p) - - lay2 k _ | k `seq` False = undefined - lay2 k (NilAbove p) = nlText `txt` lay k p - lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p - lay2 k (Nest _ p) = lay2 k p - lay2 _ Empty = end - lay2 _ (Above {}) = error "display lay2 Above" - lay2 _ (Beside {}) = error "display lay2 Beside" - lay2 _ NoDoc = error "display lay2 NoDoc" - lay2 _ (Union {}) = error "display lay2 Union" - - indent !n r = RStr n ' ' `txt` r - in - lay 0 doc - }} - -printDoc :: Mode -> Int -> Handle -> Doc -> IO () --- printDoc adds a newline to the end -printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") - -printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () --- printDoc_ does not add a newline at the end, so that --- successive calls can output stuff on the same line --- Rather like putStr vs putStrLn -printDoc_ LeftMode _ hdl doc - = do { printLeftRender hdl doc; hFlush hdl } -printDoc_ mode pprCols hdl doc - = do { fullRender mode pprCols 1.5 put done doc ; - hFlush hdl } - where - put (Chr c) next = hPutChar hdl c >> next - put (Str s) next = hPutStr hdl s >> next - put (PStr s) next = hPutStr hdl (unpackFS s) >> next - -- NB. not hPutFS, we want this to go through - -- the I/O library's encoding layer. (#3398) - put (ZStr s) next = hPutFZS hdl s >> next - put (LStr s) next = hPutPtrString hdl s >> next - put (RStr n c) next = hPutStr hdl (replicate n c) >> next - - done = return () -- hPutChar hdl '\n' - - -- some versions of hPutBuf will barf if the length is zero -hPutPtrString :: Handle -> PtrString -> IO () -hPutPtrString _handle (PtrString _ 0) = return () -hPutPtrString handle (PtrString a l) = hPutBuf handle a l - --- Printing output in LeftMode is performance critical: it's used when --- dumping C and assembly output, so we allow ourselves a few dirty --- hacks: --- --- (1) we specialise fullRender for LeftMode with IO output. --- --- (2) we add a layer of buffering on top of Handles. Handles --- don't perform well with lots of hPutChars, which is mostly --- what we're doing here, because Handles have to be thread-safe --- and async exception-safe. We only have a single thread and don't --- care about exceptions, so we add a layer of fast buffering --- over the Handle interface. - -printLeftRender :: Handle -> Doc -> IO () -printLeftRender hdl doc = do - b <- newBufHandle hdl - bufLeftRender b doc - bFlush b - -bufLeftRender :: BufHandle -> Doc -> IO () -bufLeftRender b doc = layLeft b (reduceDoc doc) - -layLeft :: BufHandle -> Doc -> IO () -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft _ NoDoc = error "layLeft: NoDoc" -layLeft b (Union p q) = layLeft b $! first p q -layLeft b (Nest _ p) = layLeft b $! p -layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) -layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) - where - put b _ | b `seq` False = undefined - put b (Chr c) = bPutChar b c - put b (Str s) = bPutStr b s - put b (PStr s) = bPutFS b s - put b (ZStr s) = bPutFZS b s - put b (LStr s) = bPutPtrString b s - put b (RStr n c) = bPutReplicate b n c -layLeft _ _ = panic "layLeft: Unhandled case" - --- Define error=panic, for easier comparison with libraries/pretty. -error :: String -> a -error = panic diff --git a/utils/State.hs b/utils/State.hs deleted file mode 100644 --- a/utils/State.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UnboxedTuples #-} - -module State where - -import GhcPrelude - -newtype State s a = State { runState' :: s -> (# a, s #) } - deriving (Functor) - -instance Applicative (State s) where - pure x = State $ \s -> (# x, s #) - m <*> n = State $ \s -> case runState' m s of - (# f, s' #) -> case runState' n s' of - (# x, s'' #) -> (# f x, s'' #) - -instance Monad (State s) where - m >>= n = State $ \s -> case runState' m s of - (# r, s' #) -> runState' (n r) s' - -get :: State s s -get = State $ \s -> (# s, s #) - -gets :: (s -> a) -> State s a -gets f = State $ \s -> (# f s, s #) - -put :: s -> State s () -put s' = State $ \_ -> (# (), s' #) - -modify :: (s -> s) -> State s () -modify f = State $ \s -> (# (), f s #) - - -evalState :: State s a -> s -> a -evalState s i = case runState' s i of - (# a, _ #) -> a - - -execState :: State s a -> s -> s -execState s i = case runState' s i of - (# _, s' #) -> s' - - -runState :: State s a -> s -> (a, s) -runState s i = case runState' s i of - (# a, s' #) -> (a, s') diff --git a/utils/Stream.hs b/utils/Stream.hs deleted file mode 100644 --- a/utils/Stream.hs +++ /dev/null @@ -1,135 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 2012 --- --- Monadic streams --- --- ----------------------------------------------------------------------------- -module Stream ( - Stream(..), yield, liftIO, - collect, collect_, consume, fromList, - Stream.map, Stream.mapM, Stream.mapAccumL, Stream.mapAccumL_ - ) where - -import GhcPrelude - -import Control.Monad - --- | --- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence --- of elements of type @a@ followed by a result of type @b@. --- --- More concretely, a value of type @Stream m a b@ can be run using @runStream@ --- in the Monad @m@, and it delivers either --- --- * the final result: @Left b@, or --- * @Right (a,str)@, where @a@ is the next element in the stream, and @str@ --- is a computation to get the rest of the stream. --- --- Stream is itself a Monad, and provides an operation 'yield' that --- produces a new element of the stream. This makes it convenient to turn --- existing monadic computations into streams. --- --- The idea is that Stream is useful for making a monadic computation --- that produces values from time to time. This can be used for --- knitting together two complex monadic operations, so that the --- producer does not have to produce all its values before the --- consumer starts consuming them. We make the producer into a --- Stream, and the consumer pulls on the stream each time it wants a --- new value. --- -newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) } - -instance Monad f => Functor (Stream f a) where - fmap = liftM - -instance Monad m => Applicative (Stream m a) where - pure a = Stream (return (Left a)) - (<*>) = ap - -instance Monad m => Monad (Stream m a) where - - Stream m >>= k = Stream $ do - r <- m - case r of - Left b -> runStream (k b) - Right (a,str) -> return (Right (a, str >>= k)) - -yield :: Monad m => a -> Stream m a () -yield a = Stream (return (Right (a, return ()))) - -liftIO :: IO a -> Stream IO b a -liftIO io = Stream $ io >>= return . Left - --- | Turn a Stream into an ordinary list, by demanding all the elements. -collect :: Monad m => Stream m a () -> m [a] -collect str = go str [] - where - go str acc = do - r <- runStream str - case r of - Left () -> return (reverse acc) - Right (a, str') -> go str' (a:acc) - --- | Turn a Stream into an ordinary list, by demanding all the elements. -collect_ :: Monad m => Stream m a r -> m ([a], r) -collect_ str = go str [] - where - go str acc = do - r <- runStream str - case r of - Left r -> return (reverse acc, r) - Right (a, str') -> go str' (a:acc) - -consume :: Monad m => Stream m a b -> (a -> m ()) -> m b -consume str f = do - r <- runStream str - case r of - Left ret -> return ret - Right (a, str') -> do - f a - consume str' f - --- | Turn a list into a 'Stream', by yielding each element in turn. -fromList :: Monad m => [a] -> Stream m a () -fromList = mapM_ yield - --- | Apply a function to each element of a 'Stream', lazily -map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x -map f str = Stream $ do - r <- runStream str - case r of - Left x -> return (Left x) - Right (a, str') -> return (Right (f a, Stream.map f str')) - --- | Apply a monadic operation to each element of a 'Stream', lazily -mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x -mapM f str = Stream $ do - r <- runStream str - case r of - Left x -> return (Left x) - Right (a, str') -> do - b <- f a - return (Right (b, Stream.mapM f str')) - --- | analog of the list-based 'mapAccumL' on Streams. This is a simple --- way to map over a Stream while carrying some state around. -mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a () - -> Stream m b c -mapAccumL f c str = Stream $ do - r <- runStream str - case r of - Left () -> return (Left c) - Right (a, str') -> do - (c',b) <- f c a - return (Right (b, mapAccumL f c' str')) - -mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r - -> Stream m b (c, r) -mapAccumL_ f c str = Stream $ do - r <- runStream str - case r of - Left r -> return (Left (c, r)) - Right (a, str') -> do - (c',b) <- f c a - return (Right (b, mapAccumL_ f c' str')) diff --git a/utils/StringBuffer.hs b/utils/StringBuffer.hs deleted file mode 100644 --- a/utils/StringBuffer.hs +++ /dev/null @@ -1,334 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The University of Glasgow, 1997-2006 - - -Buffers for scanning string input stored in external arrays. --} - -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O2 #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - -module StringBuffer - ( - StringBuffer(..), - -- non-abstract for vs\/HaskellService - - -- * Creation\/destruction - hGetStringBuffer, - hGetStringBufferBlock, - hPutStringBuffer, - appendStringBuffers, - stringToStringBuffer, - - -- * Inspection - nextChar, - currentChar, - prevChar, - atEnd, - - -- * Moving and comparison - stepOn, - offsetBytes, - byteDiff, - atLine, - - -- * Conversion - lexemeToString, - lexemeToFastString, - decodePrevNChars, - - -- * Parsing integers - parseUnsignedInteger, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Encoding -import FastString -import FastFunctions -import PlainPanic -import Util - -import Data.Maybe -import Control.Exception -import System.IO -import System.IO.Unsafe ( unsafePerformIO ) -import GHC.IO.Encoding.UTF8 ( mkUTF8 ) -import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) - -import GHC.Exts - -import Foreign - --- ----------------------------------------------------------------------------- --- The StringBuffer type - --- |A StringBuffer is an internal pointer to a sized chunk of bytes. --- The bytes are intended to be *immutable*. There are pure --- operations to read the contents of a StringBuffer. --- --- A StringBuffer may have a finalizer, depending on how it was --- obtained. --- -data StringBuffer - = StringBuffer { - buf :: {-# UNPACK #-} !(ForeignPtr Word8), - len :: {-# UNPACK #-} !Int, -- length - cur :: {-# UNPACK #-} !Int -- current pos - } - -- The buffer is assumed to be UTF-8 encoded, and furthermore - -- we add three @\'\\0\'@ bytes to the end as sentinels so that the - -- decoder doesn't have to check for overflow at every single byte - -- of a multibyte sequence. - -instance Show StringBuffer where - showsPrec _ s = showString "" - --- ----------------------------------------------------------------------------- --- Creation / Destruction - --- | Read a file into a 'StringBuffer'. The resulting buffer is automatically --- managed by the garbage collector. -hGetStringBuffer :: FilePath -> IO StringBuffer -hGetStringBuffer fname = do - h <- openBinaryFile fname ReadMode - size_i <- hFileSize h - offset_i <- skipBOM h size_i 0 -- offset is 0 initially - let size = fromIntegral $ size_i - offset_i - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do - r <- if size == 0 then return 0 else hGetBuf h ptr size - hClose h - if (r /= size) - then ioError (userError "short read of file") - else newUTF8StringBuffer buf ptr size - -hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer -hGetStringBufferBlock handle wanted - = do size_i <- hFileSize handle - offset_i <- hTell handle >>= skipBOM handle size_i - let size = min wanted (fromIntegral $ size_i-offset_i) - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> - do r <- if size == 0 then return 0 else hGetBuf handle ptr size - if r /= size - then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) - else newUTF8StringBuffer buf ptr size - -hPutStringBuffer :: Handle -> StringBuffer -> IO () -hPutStringBuffer hdl (StringBuffer buf len cur) - = do withForeignPtr (plusForeignPtr buf cur) $ \ptr -> - hPutBuf hdl ptr len - --- | Skip the byte-order mark if there is one (see #1744 and #6016), --- and return the new position of the handle in bytes. --- --- This is better than treating #FEFF as whitespace, --- because that would mess up layout. We don't have a concept --- of zero-width whitespace in Haskell: all whitespace codepoints --- have a width of one column. -skipBOM :: Handle -> Integer -> Integer -> IO Integer -skipBOM h size offset = - -- Only skip BOM at the beginning of a file. - if size > 0 && offset == 0 - then do - -- Validate assumption that handle is in binary mode. - ASSERTM( hGetEncoding h >>= return . isNothing ) - -- Temporarily select utf8 encoding with error ignoring, - -- to make `hLookAhead` and `hGetChar` return full Unicode characters. - bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do - c <- hLookAhead h - if c == '\xfeff' - then hGetChar h >> hTell h - else return offset - else return offset - where - safeEncoding = mkUTF8 IgnoreCodingFailure - -newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer -newUTF8StringBuffer buf ptr size = do - pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] - -- sentinels for UTF-8 decoding - return $ StringBuffer buf size 0 - -appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer -appendStringBuffers sb1 sb2 - = do newBuf <- mallocForeignPtrArray (size+3) - withForeignPtr newBuf $ \ptr -> - withForeignPtr (buf sb1) $ \sb1Ptr -> - withForeignPtr (buf sb2) $ \sb2Ptr -> - do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len - copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len - pokeArray (ptr `advancePtr` size) [0,0,0] - return (StringBuffer newBuf size 0) - where sb1_len = calcLen sb1 - sb2_len = calcLen sb2 - calcLen sb = len sb - cur sb - size = sb1_len + sb2_len - --- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer --- is automatically managed by the garbage collector. -stringToStringBuffer :: String -> StringBuffer -stringToStringBuffer str = - unsafePerformIO $ do - let size = utf8EncodedLength str - buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do - utf8EncodeString ptr str - pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] - -- sentinels for UTF-8 decoding - return (StringBuffer buf size 0) - --- ----------------------------------------------------------------------------- --- Grab a character - --- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well --- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The --- behavior is undefined if the 'StringBuffer' is empty. The result shares --- the same buffer as the original. Similar to 'utf8DecodeChar', if the --- character cannot be decoded as UTF-8, @\'\\0\'@ is returned. -{-# INLINE nextChar #-} -nextChar :: StringBuffer -> (Char,StringBuffer) -nextChar (StringBuffer buf len (I# cur#)) = - -- Getting our fingers dirty a little here, but this is performance-critical - inlinePerformIO $ do - withForeignPtr buf $ \(Ptr a#) -> do - case utf8DecodeChar# (a# `plusAddr#` cur#) of - (# c#, nBytes# #) -> - let cur' = I# (cur# +# nBytes#) in - return (C# c#, StringBuffer buf len cur') - --- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous --- to 'Data.List.head'). __Warning:__ The behavior is undefined if the --- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character --- cannot be decoded as UTF-8, @\'\\0\'@ is returned. -currentChar :: StringBuffer -> Char -currentChar = fst . nextChar - -prevChar :: StringBuffer -> Char -> Char -prevChar (StringBuffer _ _ 0) deflt = deflt -prevChar (StringBuffer buf _ cur) _ = - inlinePerformIO $ do - withForeignPtr buf $ \p -> do - p' <- utf8PrevChar (p `plusPtr` cur) - return (fst (utf8DecodeChar p')) - --- ----------------------------------------------------------------------------- --- Moving - --- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous --- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the --- 'StringBuffer' is empty. The result shares the same buffer as the --- original. -stepOn :: StringBuffer -> StringBuffer -stepOn s = snd (nextChar s) - --- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ --- If there aren't enough characters, the returned 'StringBuffer' will be --- invalid and any use of it may lead to undefined behavior. The result --- shares the same buffer as the original. -offsetBytes :: Int -- ^ @n@, the number of bytes - -> StringBuffer - -> StringBuffer -offsetBytes i s = s { cur = cur s + i } - --- | Compute the difference in offset between two 'StringBuffer's that share --- the same buffer. __Warning:__ The behavior is undefined if the --- 'StringBuffer's use separate buffers. -byteDiff :: StringBuffer -> StringBuffer -> Int -byteDiff s1 s2 = cur s2 - cur s1 - --- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). -atEnd :: StringBuffer -> Bool -atEnd (StringBuffer _ l c) = l == c - --- | Computes a 'StringBuffer' which points to the first character of the --- wanted line. Lines begin at 1. -atLine :: Int -> StringBuffer -> Maybe StringBuffer -atLine line sb@(StringBuffer buf len _) = - inlinePerformIO $ - withForeignPtr buf $ \p -> do - p' <- skipToLine line len p - if p' == nullPtr - then return Nothing - else - let - delta = p' `minusPtr` p - in return $ Just (sb { cur = delta - , len = len - delta - }) - -skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) -skipToLine !line !len !op0 = go 1 op0 - where - !opend = op0 `plusPtr` len - - go !i_line !op - | op >= opend = pure nullPtr - | i_line == line = pure op - | otherwise = do - w <- peek op :: IO Word8 - case w of - 10 -> go (i_line + 1) (plusPtr op 1) - 13 -> do - -- this is safe because a 'StringBuffer' is - -- guaranteed to have 3 bytes sentinel values. - w' <- peek (plusPtr op 1) :: IO Word8 - case w' of - 10 -> go (i_line + 1) (plusPtr op 2) - _ -> go (i_line + 1) (plusPtr op 1) - _ -> go i_line (plusPtr op 1) - --- ----------------------------------------------------------------------------- --- Conversion - --- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. --- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, --- they will be replaced with @\'\\0\'@. -lexemeToString :: StringBuffer - -> Int -- ^ @n@, the number of bytes - -> String -lexemeToString _ 0 = "" -lexemeToString (StringBuffer buf _ cur) bytes = - utf8DecodeStringLazy buf cur bytes - -lexemeToFastString :: StringBuffer - -> Int -- ^ @n@, the number of bytes - -> FastString -lexemeToFastString _ 0 = nilFS -lexemeToFastString (StringBuffer buf _ cur) len = - inlinePerformIO $ - withForeignPtr buf $ \ptr -> - return $! mkFastStringBytes (ptr `plusPtr` cur) len - --- | Return the previous @n@ characters (or fewer if we are less than @n@ --- characters into the buffer. -decodePrevNChars :: Int -> StringBuffer -> String -decodePrevNChars n (StringBuffer buf _ cur) = - inlinePerformIO $ withForeignPtr buf $ \p0 -> - go p0 n "" (p0 `plusPtr` (cur - 1)) - where - go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String - go buf0 n acc p | n == 0 || buf0 >= p = return acc - go buf0 n acc p = do - p' <- utf8PrevChar p - let (c,_) = utf8DecodeChar p' - go buf0 (n - 1) (c:acc) p' - --- ----------------------------------------------------------------------------- --- Parsing integer strings in various bases -parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer -parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int - = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let - go i x | i == len = x - | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of - '_' -> go (i + 1) x -- skip "_" (#14473) - char -> go (i + 1) (x * radix + toInteger (char_to_int char)) - in go 0 0 diff --git a/utils/TrieMap.hs b/utils/TrieMap.hs deleted file mode 100644 --- a/utils/TrieMap.hs +++ /dev/null @@ -1,405 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -module TrieMap( - -- * Maps over 'Maybe' values - MaybeMap, - -- * Maps over 'List' values - ListMap, - -- * Maps over 'Literal's - LiteralMap, - -- * 'TrieMap' class - TrieMap(..), insertTM, deleteTM, - - -- * Things helpful for adding additional Instances. - (>.>), (|>), (|>>), XT, - foldMaybe, - -- * Map for leaf compression - GenMap, - lkG, xtG, mapG, fdG, - xtList, lkList - - ) where - -import GhcPrelude - -import Literal -import UniqDFM -import Unique( Unique ) - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import Outputable -import Control.Monad( (>=>) ) - -{- -This module implements TrieMaps, which are finite mappings -whose key is a structured value like a CoreExpr or Type. - -This file implements tries over general data structures. -Implementation for tries over Core Expressions/Types are -available in coreSyn/TrieMap. - -The regular pattern for handling TrieMaps on data structures was first -described (to my knowledge) in Connelly and Morris's 1995 paper "A -generalization of the Trie Data Structure"; there is also an accessible -description of the idea in Okasaki's book "Purely Functional Data -Structures", Section 10.3.2 - -************************************************************************ -* * - The TrieMap class -* * -************************************************************************ --} - -type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) - -- or an existing elt (Just) - -class TrieMap m where - type Key m :: * - emptyTM :: m a - lookupTM :: forall b. Key m -> m b -> Maybe b - alterTM :: forall b. Key m -> XT b -> m b -> m b - mapTM :: (a->b) -> m a -> m b - - foldTM :: (a -> b -> b) -> m a -> b -> b - -- The unusual argument order here makes - -- it easy to compose calls to foldTM; - -- see for example fdE below - -insertTM :: TrieMap m => Key m -> a -> m a -> m a -insertTM k v m = alterTM k (\_ -> Just v) m - -deleteTM :: TrieMap m => Key m -> m a -> m a -deleteTM k m = alterTM k (\_ -> Nothing) m - ----------------------- --- Recall that --- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c - -(>.>) :: (a -> b) -> (b -> c) -> a -> c --- Reverse function composition (do f first, then g) -infixr 1 >.> -(f >.> g) x = g (f x) -infixr 1 |>, |>> - -(|>) :: a -> (a->b) -> b -- Reverse application -x |> f = f x - ----------------------- -(|>>) :: TrieMap m2 - => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) - -> (m2 a -> m2 a) - -> m1 (m2 a) -> m1 (m2 a) -(|>>) f g = f (Just . g . deMaybe) - -deMaybe :: TrieMap m => Maybe (m a) -> m a -deMaybe Nothing = emptyTM -deMaybe (Just m) = m - -{- -************************************************************************ -* * - IntMaps -* * -************************************************************************ --} - -instance TrieMap IntMap.IntMap where - type Key IntMap.IntMap = Int - emptyTM = IntMap.empty - lookupTM k m = IntMap.lookup k m - alterTM = xtInt - foldTM k m z = IntMap.foldr k z m - mapTM f m = IntMap.map f m - -xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a -xtInt k f m = IntMap.alter f k m - -instance Ord k => TrieMap (Map.Map k) where - type Key (Map.Map k) = k - emptyTM = Map.empty - lookupTM = Map.lookup - alterTM k f m = Map.alter f k m - foldTM k m z = Map.foldr k z m - mapTM f m = Map.map f m - - -{- -Note [foldTM determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We want foldTM to be deterministic, which is why we have an instance of -TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that -go wrong if foldTM is nondeterministic. Consider: - - f a b = return (a <> b) - -Depending on the order that the typechecker generates constraints you -get either: - - f :: (Monad m, Monoid a) => a -> a -> m a - -or: - - f :: (Monoid a, Monad m) => a -> a -> m a - -The generated code will be different after desugaring as the dictionaries -will be bound in different orders, leading to potential ABI incompatibility. - -One way to solve this would be to notice that the typeclasses could be -sorted alphabetically. - -Unfortunately that doesn't quite work with this example: - - f a b = let x = a <> a; y = b <> b in x - -where you infer: - - f :: (Monoid m, Monoid m1) => m1 -> m -> m1 - -or: - - f :: (Monoid m1, Monoid m) => m1 -> m -> m1 - -Here you could decide to take the order of the type variables in the type -according to depth first traversal and use it to order the constraints. - -The real trouble starts when the user enables incoherent instances and -the compiler has to make an arbitrary choice. Consider: - - class T a b where - go :: a -> b -> String - - instance (Show b) => T Int b where - go a b = show a ++ show b - - instance (Show a) => T a Bool where - go a b = show a ++ show b - - f = go 10 True - -GHC is free to choose either dictionary to implement f, but for the sake of -determinism we'd like it to be consistent when compiling the same sources -with the same flags. - -inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it -gets converted to a bag of (Wanted) Cts using a fold. Then in -solve_simple_wanteds it's merged with other WantedConstraints. We want the -conversion to a bag to be deterministic. For that purpose we use UniqDFM -instead of UniqFM to implement the TrieMap. - -See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made -deterministic. --} - -instance TrieMap UniqDFM where - type Key UniqDFM = Unique - emptyTM = emptyUDFM - lookupTM k m = lookupUDFM m k - alterTM k f m = alterUDFM f m k - foldTM k m z = foldUDFM k z m - mapTM f m = mapUDFM f m - -{- -************************************************************************ -* * - Maybes -* * -************************************************************************ - -If m is a map from k -> val -then (MaybeMap m) is a map from (Maybe k) -> val --} - -data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } - -instance TrieMap m => TrieMap (MaybeMap m) where - type Key (MaybeMap m) = Maybe (Key m) - emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } - lookupTM = lkMaybe lookupTM - alterTM = xtMaybe alterTM - foldTM = fdMaybe - mapTM = mapMb - -mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b -mapMb f (MM { mm_nothing = mn, mm_just = mj }) - = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } - -lkMaybe :: (forall b. k -> m b -> Maybe b) - -> Maybe k -> MaybeMap m a -> Maybe a -lkMaybe _ Nothing = mm_nothing -lkMaybe lk (Just x) = mm_just >.> lk x - -xtMaybe :: (forall b. k -> XT b -> m b -> m b) - -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a -xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } -xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } - -fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b -fdMaybe k m = foldMaybe k (mm_nothing m) - . foldTM k (mm_just m) - -{- -************************************************************************ -* * - Lists -* * -************************************************************************ --} - -data ListMap m a - = LM { lm_nil :: Maybe a - , lm_cons :: m (ListMap m a) } - -instance TrieMap m => TrieMap (ListMap m) where - type Key (ListMap m) = [Key m] - emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } - lookupTM = lkList lookupTM - alterTM = xtList alterTM - foldTM = fdList - mapTM = mapList - -instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where - ppr m = text "List elts" <+> ppr (foldTM (:) m []) - -mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b -mapList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } - -lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) - -> [k] -> ListMap m a -> Maybe a -lkList _ [] = lm_nil -lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs - -xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) - -> [k] -> XT a -> ListMap m a -> ListMap m a -xtList _ [] f m = m { lm_nil = f (lm_nil m) } -xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } - -fdList :: forall m a b. TrieMap m - => (a -> b -> b) -> ListMap m a -> b -> b -fdList k m = foldMaybe k (lm_nil m) - . foldTM (fdList k) (lm_cons m) - -foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b -foldMaybe _ Nothing b = b -foldMaybe k (Just a) b = k a b - -{- -************************************************************************ -* * - Basic maps -* * -************************************************************************ --} - -type LiteralMap a = Map.Map Literal a - -{- -************************************************************************ -* * - GenMap -* * -************************************************************************ - -Note [Compressed TrieMap] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -The GenMap constructor augments TrieMaps with leaf compression. This helps -solve the performance problem detailed in #9960: suppose we have a handful -H of entries in a TrieMap, each with a very large key, size K. If you fold over -such a TrieMap you'd expect time O(H). That would certainly be true of an -association list! But with TrieMap we actually have to navigate down a long -singleton structure to get to the elements, so it takes time O(K*H). This -can really hurt on many type-level computation benchmarks: -see for example T9872d. - -The point of a TrieMap is that you need to navigate to the point where only one -key remains, and then things should be fast. So the point of a SingletonMap -is that, once we are down to a single (key,value) pair, we stop and -just use SingletonMap. - -'EmptyMap' provides an even more basic (but essential) optimization: if there is -nothing in the map, don't bother building out the (possibly infinite) recursive -TrieMap structure! - -Compressed triemaps are heavily used by CoreMap. So we have to mark some things -as INLINEABLE to permit specialization. --} - -data GenMap m a - = EmptyMap - | SingletonMap (Key m) a - | MultiMap (m a) - -instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where - ppr EmptyMap = text "Empty map" - ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v - ppr (MultiMap m) = ppr m - --- TODO undecidable instance -instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where - type Key (GenMap m) = Key m - emptyTM = EmptyMap - lookupTM = lkG - alterTM = xtG - foldTM = fdG - mapTM = mapG - ---We want to be able to specialize these functions when defining eg ---tries over (GenMap CoreExpr) which requires INLINEABLE - -{-# INLINEABLE lkG #-} -lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a -lkG _ EmptyMap = Nothing -lkG k (SingletonMap k' v') | k == k' = Just v' - | otherwise = Nothing -lkG k (MultiMap m) = lookupTM k m - -{-# INLINEABLE xtG #-} -xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a -xtG k f EmptyMap - = case f Nothing of - Just v -> SingletonMap k v - Nothing -> EmptyMap -xtG k f m@(SingletonMap k' v') - | k' == k - -- The new key matches the (single) key already in the tree. Hence, - -- apply @f@ to @Just v'@ and build a singleton or empty map depending - -- on the 'Just'/'Nothing' response respectively. - = case f (Just v') of - Just v'' -> SingletonMap k' v'' - Nothing -> EmptyMap - | otherwise - -- We've hit a singleton tree for a different key than the one we are - -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then - -- we can just return the old map. If not, we need a map with *two* - -- entries. The easiest way to do that is to insert two items into an empty - -- map of type @m a@. - = case f Nothing of - Nothing -> m - Just v -> emptyTM |> alterTM k' (const (Just v')) - >.> alterTM k (const (Just v)) - >.> MultiMap -xtG k f (MultiMap m) = MultiMap (alterTM k f m) - -{-# INLINEABLE mapG #-} -mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b -mapG _ EmptyMap = EmptyMap -mapG f (SingletonMap k v) = SingletonMap k (f v) -mapG f (MultiMap m) = MultiMap (mapTM f m) - -{-# INLINEABLE fdG #-} -fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b -fdG _ EmptyMap = \z -> z -fdG k (SingletonMap _ v) = \z -> k v z -fdG k (MultiMap m) = foldTM k m diff --git a/utils/UnVarGraph.hs b/utils/UnVarGraph.hs deleted file mode 100644 --- a/utils/UnVarGraph.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- - -Copyright (c) 2014 Joachim Breitner - -A data structure for undirected graphs of variables -(or in plain terms: Sets of unordered pairs of numbers) - - -This is very specifically tailored for the use in CallArity. In particular it -stores the graph as a union of complete and complete bipartite graph, which -would be very expensive to store as sets of edges or as adjanceny lists. - -It does not normalize the graphs. This means that g `unionUnVarGraph` g is -equal to g, but twice as expensive and large. - --} -module UnVarGraph - ( UnVarSet - , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets - , delUnVarSet - , elemUnVarSet, isEmptyUnVarSet - , UnVarGraph - , emptyUnVarGraph - , unionUnVarGraph, unionUnVarGraphs - , completeGraph, completeBipartiteGraph - , neighbors - , hasLoopAt - , delNode - ) where - -import GhcPrelude - -import Id -import VarEnv -import UniqFM -import Outputable -import Bag -import Unique - -import qualified Data.IntSet as S - --- We need a type for sets of variables (UnVarSet). --- We do not use VarSet, because for that we need to have the actual variable --- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. --- Therefore, use a IntSet directly (which is likely also a bit more efficient). - --- Set of uniques, i.e. for adjancet nodes -newtype UnVarSet = UnVarSet (S.IntSet) - deriving Eq - -k :: Var -> Int -k v = getKey (getUnique v) - -emptyUnVarSet :: UnVarSet -emptyUnVarSet = UnVarSet S.empty - -elemUnVarSet :: Var -> UnVarSet -> Bool -elemUnVarSet v (UnVarSet s) = k v `S.member` s - - -isEmptyUnVarSet :: UnVarSet -> Bool -isEmptyUnVarSet (UnVarSet s) = S.null s - -delUnVarSet :: UnVarSet -> Var -> UnVarSet -delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s - -mkUnVarSet :: [Var] -> UnVarSet -mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs - -varEnvDom :: VarEnv a -> UnVarSet -varEnvDom ae = UnVarSet $ ufmToSet_Directly ae - -unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet -unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) - -unionUnVarSets :: [UnVarSet] -> UnVarSet -unionUnVarSets = foldr unionUnVarSet emptyUnVarSet - -instance Outputable UnVarSet where - ppr (UnVarSet s) = braces $ - hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] - - --- The graph type. A list of complete bipartite graphs -data Gen = CBPG UnVarSet UnVarSet -- complete bipartite - | CG UnVarSet -- complete -newtype UnVarGraph = UnVarGraph (Bag Gen) - -emptyUnVarGraph :: UnVarGraph -emptyUnVarGraph = UnVarGraph emptyBag - -unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph -{- -Premature optimisation, it seems. -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s1 == s3 && s2 == s4 - = pprTrace "unionUnVarGraph fired" empty $ - completeGraph (s1 `unionUnVarSet` s2) -unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) - | s2 == s3 && s1 == s4 - = pprTrace "unionUnVarGraph fired2" empty $ - completeGraph (s1 `unionUnVarSet` s2) --} -unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) - = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ - UnVarGraph (g1 `unionBags` g2) - -unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph -unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph - --- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } -completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph -completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 - -completeGraph :: UnVarSet -> UnVarGraph -completeGraph s = prune $ UnVarGraph $ unitBag $ CG s - -neighbors :: UnVarGraph -> Var -> UnVarSet -neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g - where go (CG s) = (if v `elemUnVarSet` s then [s] else []) - go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ - (if v `elemUnVarSet` s2 then [s1] else []) - --- hasLoopAt G v <=> v--v ∈ G -hasLoopAt :: UnVarGraph -> Var -> Bool -hasLoopAt (UnVarGraph g) v = any go $ bagToList g - where go (CG s) = v `elemUnVarSet` s - go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 - - -delNode :: UnVarGraph -> Var -> UnVarGraph -delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g - where go (CG s) = CG (s `delUnVarSet` v) - go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) - -prune :: UnVarGraph -> UnVarGraph -prune (UnVarGraph g) = UnVarGraph $ filterBag go g - where go (CG s) = not (isEmptyUnVarSet s) - go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) - -instance Outputable Gen where - ppr (CG s) = ppr s <> char '²' - ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 -instance Outputable UnVarGraph where - ppr (UnVarGraph g) = ppr g diff --git a/utils/UniqDFM.hs b/utils/UniqDFM.hs deleted file mode 100644 --- a/utils/UniqDFM.hs +++ /dev/null @@ -1,420 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook, 2015 - -UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -This is very similar to @UniqFM@, the major difference being that the order of -folding is not dependent on @Unique@ ordering, giving determinism. -Currently the ordering is determined by insertion order. - -See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering -is not deterministic. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqDFM ( - -- * Unique-keyed deterministic mappings - UniqDFM, -- abstract type - - -- ** Manipulating those mappings - emptyUDFM, - unitUDFM, - addToUDFM, - addToUDFM_C, - addListToUDFM, - delFromUDFM, - delListFromUDFM, - adjustUDFM, - alterUDFM, - mapUDFM, - plusUDFM, - plusUDFM_C, - lookupUDFM, lookupUDFM_Directly, - elemUDFM, - foldUDFM, - eltsUDFM, - filterUDFM, filterUDFM_Directly, - isNullUDFM, - sizeUDFM, - intersectUDFM, udfmIntersectUFM, - intersectsUDFM, - disjointUDFM, disjointUdfmUfm, - equalKeysUDFM, - minusUDFM, - listToUDFM, - udfmMinusUFM, - partitionUDFM, - anyUDFM, allUDFM, - pprUniqDFM, pprUDFM, - - udfmToList, - udfmToUfm, - nonDetFoldUDFM, - alwaysUnsafeUfmToUdfm, - ) where - -import GhcPrelude - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import qualified Data.IntMap as M -import Data.Data -import Data.Functor.Classes (Eq1 (..)) -import Data.List (sortBy) -import Data.Function (on) -import qualified Data.Semigroup as Semi -import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) - --- Note [Deterministic UniqFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- A @UniqDFM@ is just like @UniqFM@ with the following additional --- property: the function `udfmToList` returns the elements in some --- deterministic order not depending on the Unique key for those elements. --- --- If the client of the map performs operations on the map in deterministic --- order then `udfmToList` returns them in deterministic order. --- --- There is an implementation cost: each element is given a serial number --- as it is added, and `udfmToList` sorts it's result by this serial --- number. So you should only use `UniqDFM` if you need the deterministic --- property. --- --- `foldUDFM` also preserves determinism. --- --- Normal @UniqFM@ when you turn it into a list will use --- Data.IntMap.toList function that returns the elements in the order of --- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with --- with a list ordered by @Uniques@. --- The order of @Uniques@ is known to be not stable across rebuilds. --- See Note [Unique Determinism] in Unique. --- --- --- There's more than one way to implement this. The implementation here tags --- every value with the insertion time that can later be used to sort the --- values when asked to convert to a list. --- --- An alternative would be to have --- --- data UniqDFM ele = UDFM (M.IntMap ele) [ele] --- --- where the list determines the order. This makes deletion tricky as we'd --- only accumulate elements in that list, but makes merging easier as you --- can just merge both structures independently. --- Deletion can probably be done in amortized fashion when the size of the --- list is twice the size of the set. - --- | A type of values tagged with insertion time -data TaggedVal val = - TaggedVal - val - {-# UNPACK #-} !Int -- ^ insertion time - deriving (Data, Functor) - -taggedFst :: TaggedVal val -> val -taggedFst (TaggedVal v _) = v - -taggedSnd :: TaggedVal val -> Int -taggedSnd (TaggedVal _ i) = i - -instance Eq val => Eq (TaggedVal val) where - (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 - --- | Type of unique deterministic finite maps -data UniqDFM ele = - UDFM - !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and - -- values are tagged with insertion time. - -- The invariant is that all the tags will - -- be distinct within a single map - {-# UNPACK #-} !Int -- Upper bound on the values' insertion - -- time. See Note [Overflow on plusUDFM] - deriving (Data, Functor) - --- | Deterministic, in O(n log n). -instance Foldable UniqDFM where - foldr = foldUDFM - --- | Deterministic, in O(n log n). -instance Traversable UniqDFM where - traverse f = fmap listToUDFM_Directly - . traverse (\(u,a) -> (u,) <$> f a) - . udfmToList - -emptyUDFM :: UniqDFM elt -emptyUDFM = UDFM M.empty 0 - -unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt -unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 - --- The new binding always goes to the right of existing ones -addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt -addToUDFM m k v = addToUDFM_Directly m (getUnique k) v - --- The new binding always goes to the right of existing ones -addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt -addToUDFM_Directly (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i - -- Keep the old tag, but insert the new value - -- This means that udfmToList typically returns elements - -- in the order of insertion, rather than the reverse - -addToUDFM_Directly_C - :: (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt - -> Unique -> elt - -> UniqDFM elt -addToUDFM_Directly_C f (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal old_v old_i) - = TaggedVal (f old_v new_v) old_i - -- Flip the arguments, because M.insertWith uses (new->old->result) - -- but f needs (old->new->result) - -- Like addToUDFM_Directly, keep the old tag - -addToUDFM_C - :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt -- old - -> key -> elt -- new - -> UniqDFM elt -- result -addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v - -addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt -addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) - -addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) - -addListToUDFM_Directly_C - :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v) - -delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt -delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i - -plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft_C f udfml udfmr - | otherwise = insertUDFMIntoLeft_C f udfmr udfml - --- Note [Overflow on plusUDFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- There are multiple ways of implementing plusUDFM. --- The main problem that needs to be solved is overlap on times of --- insertion between different keys in two maps. --- Consider: --- --- A = fromList [(a, (x, 1))] --- B = fromList [(b, (y, 1))] --- --- If you merge them naively you end up with: --- --- C = fromList [(a, (x, 1)), (b, (y, 1))] --- --- Which loses information about ordering and brings us back into --- non-deterministic world. --- --- The solution I considered before would increment the tags on one of the --- sets by the upper bound of the other set. The problem with this approach --- is that you'll run out of tags for some merge patterns. --- Say you start with A with upper bound 1, you merge A with A to get A' and --- the upper bound becomes 2. You merge A' with A' and the upper bound --- doubles again. After 64 merges you overflow. --- This solution would have the same time complexity as plusUFM, namely O(n+m). --- --- The solution I ended up with has time complexity of --- O(m log m + m * min (n+m, W)) where m is the smaller set. --- It simply inserts the elements of the smaller set into the larger --- set in the order that they were inserted into the smaller set. That's --- O(m log m) for extracting the elements from the smaller set in the --- insertion order and O(m * min(n+m, W)) to insert them into the bigger --- set. - -plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft udfml udfmr - | otherwise = insertUDFMIntoLeft udfmr udfml - -insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr - -insertUDFMIntoLeft_C - :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft_C f udfml udfmr = - addListToUDFM_Directly_C f udfml $ udfmToList udfmr - -lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt -lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m - -lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt -lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m - -elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool -elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m - --- | Performs a deterministic fold over the UniqDFM. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -foldUDFM k z m = foldr k z (eltsUDFM m) - --- | Performs a nondeterministic fold over the UniqDFM. --- It's O(n), same as the corresponding function on `UniqFM`. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m - -eltsUDFM :: UniqDFM elt -> [elt] -eltsUDFM (UDFM m _i) = - map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m - -filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i - -filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i - where - p' k (TaggedVal v _) = p (getUnique k) v - --- | Converts `UniqDFM` to a list, with elements in deterministic order. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -udfmToList :: UniqDFM elt -> [(Unique, elt)] -udfmToList (UDFM m _i) = - [ (getUnique k, taggedFst v) - | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] - --- Determines whether two 'UniqDFM's contain the same keys. -equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool -equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 - -isNullUDFM :: UniqDFM elt -> Bool -isNullUDFM (UDFM m _) = M.null m - -sizeUDFM :: UniqDFM elt -> Int -sizeUDFM (UDFM m _i) = M.size m - -intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 -udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) - -disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) - -disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool -disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) - -minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 -minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - -udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 -udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - --- | Partition UniqDFM into two UniqDFMs according to the predicate -partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) -partitionUDFM p (UDFM m i) = - case M.partition (p . taggedFst) m of - (left, right) -> (UDFM left i, UDFM right i) - --- | Delete a list of elements from a UniqDFM -delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt -delListFromUDFM = foldl' delFromUDFM - --- | This allows for lossy conversion from UniqDFM to UniqFM -udfmToUfm :: UniqDFM elt -> UniqFM elt -udfmToUfm (UDFM m _i) = - listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] - -listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt -listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM - -listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt -listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM - --- | Apply a function to a particular element -adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt -adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i - --- | The expression (alterUDFM f k map) alters value x at k, or absence --- thereof. alterUDFM can be used to insert, delete, or update a value in --- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are --- more efficient. -alterUDFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqDFM elt -- old - -> key -- new - -> UniqDFM elt -- result -alterUDFM f (UDFM m i) k = - UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) - where - alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) - inject Nothing = Nothing - inject (Just v) = Just $ TaggedVal v i - --- | Map a function over every value in a UniqDFM -mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 -mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i - -anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m - -allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m - -instance Semi.Semigroup (UniqDFM a) where - (<>) = plusUDFM - -instance Monoid (UniqDFM a) where - mempty = emptyUDFM - mappend = (Semi.<>) - --- This should not be used in commited code, provided for convenience to --- make ad-hoc conversions when developing -alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt -alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList - --- Output-ery - -instance Outputable a => Outputable (UniqDFM a) where - ppr ufm = pprUniqDFM ppr ufm - -pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc -pprUniqDFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- udfmToList ufm ] - -pprUDFM :: UniqDFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/utils/UniqDSet.hs b/utils/UniqDSet.hs deleted file mode 100644 --- a/utils/UniqDSet.hs +++ /dev/null @@ -1,141 +0,0 @@ --- (c) Bartosz Nitka, Facebook, 2015 - --- | --- Specialised deterministic sets, for things with @Uniques@ --- --- Based on 'UniqDFM's (as you would expect). --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it. --- --- Basically, the things need to be in class 'Uniquable'. - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module UniqDSet ( - -- * Unique set type - UniqDSet, -- type synonym for UniqFM a - getUniqDSet, - pprUniqDSet, - - -- ** Manipulating these sets - delOneFromUniqDSet, delListFromUniqDSet, - emptyUniqDSet, - unitUniqDSet, - mkUniqDSet, - addOneToUniqDSet, addListToUniqDSet, - unionUniqDSets, unionManyUniqDSets, - minusUniqDSet, uniqDSetMinusUniqSet, - intersectUniqDSets, uniqDSetIntersectUniqSet, - foldUniqDSet, - elementOfUniqDSet, - filterUniqDSet, - sizeUniqDSet, - isEmptyUniqDSet, - lookupUniqDSet, - uniqDSetToList, - partitionUniqDSet, - mapUniqDSet - ) where - -import GhcPrelude - -import Outputable -import UniqDFM -import UniqSet -import Unique - -import Data.Coerce -import Data.Data -import qualified Data.Semigroup as Semi - --- See Note [UniqSet invariant] in UniqSet.hs for why we want a newtype here. --- Beyond preserving invariants, we may also want to 'override' typeclass --- instances. - -newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a} - deriving (Data, Semi.Semigroup, Monoid) - -emptyUniqDSet :: UniqDSet a -emptyUniqDSet = UniqDSet emptyUDFM - -unitUniqDSet :: Uniquable a => a -> UniqDSet a -unitUniqDSet x = UniqDSet (unitUDFM x x) - -mkUniqDSet :: Uniquable a => [a] -> UniqDSet a -mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet - --- The new element always goes to the right of existing ones. -addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) - -addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -addListToUniqDSet = foldl' addOneToUniqDSet - -delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s - -delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s - -unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) - -unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a -unionManyUniqDSets [] = emptyUniqDSet -unionManyUniqDSets sets = foldr1 unionUniqDSets sets - -minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a -minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) - -uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a -uniqDSetMinusUniqSet xs ys - = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) - -intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) - -uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a -uniqDSetIntersectUniqSet xs ys - = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) - -foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b -foldUniqDSet c n (UniqDSet s) = foldUDFM c n s - -elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool -elementOfUniqDSet k = elemUDFM k . getUniqDSet - -filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a -filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) - -sizeUniqDSet :: UniqDSet a -> Int -sizeUniqDSet = sizeUDFM . getUniqDSet - -isEmptyUniqDSet :: UniqDSet a -> Bool -isEmptyUniqDSet = isNullUDFM . getUniqDSet - -lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a -lookupUniqDSet = lookupUDFM . getUniqDSet - -uniqDSetToList :: UniqDSet a -> [a] -uniqDSetToList = eltsUDFM . getUniqDSet - -partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) -partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet - --- See Note [UniqSet invariant] in UniqSet.hs -mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b -mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList - --- Two 'UniqDSet's are considered equal if they contain the same --- uniques. -instance Eq (UniqDSet a) where - UniqDSet a == UniqDSet b = equalKeysUDFM a b - -getUniqDSet :: UniqDSet a -> UniqDFM a -getUniqDSet = getUniqDSet' - -instance Outputable a => Outputable (UniqDSet a) where - ppr = pprUniqDSet ppr - -pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc -pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/utils/UniqFM.hs b/utils/UniqFM.hs deleted file mode 100644 --- a/utils/UniqFM.hs +++ /dev/null @@ -1,416 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -UniqFM: Specialised finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -(A similar thing to @UniqSet@, as opposed to @Set@.) - -The interface is based on @FiniteMap@s, but the implementation uses -@Data.IntMap@, which is both maintained and faster than the past -implementation (see commit log). - -The @UniqFM@ interface maps directly to Data.IntMap, only -``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased -and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order -of arguments of combining function. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqFM ( - -- * Unique-keyed mappings - UniqFM, -- abstract type - NonDetUniqFM(..), -- wrapper for opting into nondeterminism - - -- ** Manipulating those mappings - emptyUFM, - unitUFM, - unitDirectlyUFM, - listToUFM, - listToUFM_Directly, - listToUFM_C, - addToUFM,addToUFM_C,addToUFM_Acc, - addListToUFM,addListToUFM_C, - addToUFM_Directly, - addListToUFM_Directly, - adjustUFM, alterUFM, - adjustUFM_Directly, - delFromUFM, - delFromUFM_Directly, - delListFromUFM, - delListFromUFM_Directly, - plusUFM, - plusUFM_C, - plusUFM_CD, - plusMaybeUFM_C, - plusUFMList, - minusUFM, - intersectUFM, - intersectUFM_C, - disjointUFM, - equalKeysUFM, - nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, - anyUFM, allUFM, seqEltsUFM, - mapUFM, mapUFM_Directly, - elemUFM, elemUFM_Directly, - filterUFM, filterUFM_Directly, partitionUFM, - sizeUFM, - isNullUFM, - lookupUFM, lookupUFM_Directly, - lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - nonDetEltsUFM, eltsUFM, nonDetKeysUFM, - ufmToSet_Directly, - nonDetUFMToList, ufmToIntMap, - pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM - ) where - -import GhcPrelude - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import qualified Data.IntMap as M -import qualified Data.IntSet as S -import Data.Data -import qualified Data.Semigroup as Semi -import Data.Functor.Classes (Eq1 (..)) - - -newtype UniqFM ele = UFM (M.IntMap ele) - deriving (Data, Eq, Functor) - -- Nondeterministic Foldable and Traversable instances are accessible through - -- use of the 'NonDetUniqFM' wrapper. - -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. - -emptyUFM :: UniqFM elt -emptyUFM = UFM M.empty - -isNullUFM :: UniqFM elt -> Bool -isNullUFM (UFM m) = M.null m - -unitUFM :: Uniquable key => key -> elt -> UniqFM elt -unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) - --- when you've got the Unique already -unitDirectlyUFM :: Unique -> elt -> UniqFM elt -unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) - -listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt -listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM - -listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt -listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM - -listToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> [(key, elt)] - -> UniqFM elt -listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM - -addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt -addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) - -addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt -addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) - -addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt -addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) - -addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt -addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) - -addToUFM_C - :: Uniquable key - => (elt -> elt -> elt) -- old -> new -> result - -> UniqFM elt -- old - -> key -> elt -- new - -> UniqFM elt -- result --- Arguments of combining function of M.insertWith and addToUFM_C are flipped. -addToUFM_C f (UFM m) k v = - UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) - -addToUFM_Acc - :: Uniquable key - => (elt -> elts -> elts) -- Add to existing - -> (elt -> elts) -- New element - -> UniqFM elts -- old - -> key -> elt -- new - -> UniqFM elts -- result -addToUFM_Acc exi new (UFM m) k v = - UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) - -alterUFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqFM elt -- old - -> key -- new - -> UniqFM elt -- result -alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) - -addListToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> UniqFM elt -> [(key,elt)] - -> UniqFM elt -addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) - -adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt -adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) - -adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt -adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) - -delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt -delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) - -delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt -delListFromUFM = foldl' delFromUFM - -delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt -delListFromUFM_Directly = foldl' delFromUFM_Directly - -delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt -delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) - --- Bindings in right argument shadow those in the left -plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt --- M.union is left-biased, plusUFM should be right-biased. -plusUFM (UFM x) (UFM y) = UFM (M.union y x) - -- Note (M.union y x), with arguments flipped - -- M.union is left-biased, plusUFM should be right-biased. - -plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) - --- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the --- combinding function and `d1` resp. `d2` as the default value if --- there is no entry in `m1` reps. `m2`. The domain is the union of --- the domains of `m1` and `m2`. --- --- Representative example: --- --- @ --- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 --- == {A: f 1 42, B: f 2 3, C: f 23 4 } --- @ -plusUFM_CD - :: (elt -> elt -> elt) - -> UniqFM elt -- map X - -> elt -- default for X - -> UniqFM elt -- map Y - -> elt -- default for Y - -> UniqFM elt -plusUFM_CD f (UFM xm) dx (UFM ym) dy - = UFM $ M.mergeWithKey - (\_ x y -> Just (x `f` y)) - (M.map (\x -> x `f` dy)) - (M.map (\y -> dx `f` y)) - xm ym - -plusMaybeUFM_C :: (elt -> elt -> Maybe elt) - -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusMaybeUFM_C f (UFM xm) (UFM ym) - = UFM $ M.mergeWithKey - (\_ x y -> x `f` y) - id - id - xm ym - -plusUFMList :: [UniqFM elt] -> UniqFM elt -plusUFMList = foldl' plusUFM emptyUFM - -minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -minusUFM (UFM x) (UFM y) = UFM (M.difference x y) - -intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) - -intersectUFM_C - :: (elt1 -> elt2 -> elt3) - -> UniqFM elt1 - -> UniqFM elt2 - -> UniqFM elt3 -intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) - -disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool -disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) - -foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -foldUFM k z (UFM m) = M.foldr k z m - -mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM f (UFM m) = UFM (M.map f m) - -mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) - -filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM p (UFM m) = UFM (M.filter p m) - -filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) - -partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) -partitionUFM p (UFM m) = - case M.partition p m of - (left, right) -> (UFM left, UFM right) - -sizeUFM :: UniqFM elt -> Int -sizeUFM (UFM m) = M.size m - -elemUFM :: Uniquable key => key -> UniqFM elt -> Bool -elemUFM k (UFM m) = M.member (getKey $ getUnique k) m - -elemUFM_Directly :: Unique -> UniqFM elt -> Bool -elemUFM_Directly u (UFM m) = M.member (getKey u) m - -lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt -lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m - --- when you've got the Unique already -lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt -lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m - -lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt -lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m - -lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt -lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m - -eltsUFM :: UniqFM elt -> [elt] -eltsUFM (UFM m) = M.elems m - -ufmToSet_Directly :: UniqFM elt -> S.IntSet -ufmToSet_Directly (UFM m) = M.keysSet m - -anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool -anyUFM p (UFM m) = M.foldr ((||) . p) False m - -allUFM :: (elt -> Bool) -> UniqFM elt -> Bool -allUFM p (UFM m) = M.foldr ((&&) . p) True m - -seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () -seqEltsUFM seqList = seqList . nonDetEltsUFM - -- It's OK to use nonDetEltsUFM here because the type guarantees that - -- the only interesting thing this function can do is to force the - -- elements. - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetEltsUFM :: UniqFM elt -> [elt] -nonDetEltsUFM (UFM m) = M.elems m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetKeysUFM :: UniqFM elt -> [Unique] -nonDetKeysUFM (UFM m) = map getUnique $ M.keys m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM k z (UFM m) = M.foldr k z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] -nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m - --- | A wrapper around 'UniqFM' with the sole purpose of informing call sites --- that the provided 'Foldable' and 'Traversable' instances are --- nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele } - deriving (Functor) - --- | Inherently nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -instance Foldable NonDetUniqFM where - foldr f z (NonDetUniqFM (UFM m)) = foldr f z m - --- | Inherently nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -instance Traversable NonDetUniqFM where - traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m - -ufmToIntMap :: UniqFM elt -> M.IntMap elt -ufmToIntMap (UFM m) = m - --- Determines whether two 'UniqFM's contain the same keys. -equalKeysUFM :: UniqFM a -> UniqFM b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 - --- Instances - -instance Semi.Semigroup (UniqFM a) where - (<>) = plusUFM - -instance Monoid (UniqFM a) where - mempty = emptyUFM - mappend = (Semi.<>) - --- Output-ery - -instance Outputable a => Outputable (UniqFM a) where - ppr ufm = pprUniqFM ppr ufm - -pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc -pprUniqFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- nonDetUFMToList ufm ] - -- It's OK to use nonDetUFMToList here because we only use it for - -- pretty-printing. - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. -pprUFM :: UniqFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFM ufm pp = pp (nonDetEltsUFM ufm) - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetUFMToList. -pprUFMWithKeys - :: UniqFM a -- ^ The things to be pretty printed - -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralUFM :: UniqFM a -> SDoc -pluralUFM ufm - | sizeUFM ufm == 1 = empty - | otherwise = char 's' diff --git a/utils/UniqMap.hs b/utils/UniqMap.hs deleted file mode 100644 --- a/utils/UniqMap.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wall #-} - --- Like 'UniqFM', these are maps for keys which are Uniquable. --- Unlike 'UniqFM', these maps also remember their keys, which --- makes them a much better drop in replacement for 'Data.Map.Map'. --- --- Key preservation is right-biased. -module UniqMap ( - UniqMap, - emptyUniqMap, - isNullUniqMap, - unitUniqMap, - listToUniqMap, - listToUniqMap_C, - addToUniqMap, - addListToUniqMap, - addToUniqMap_C, - addToUniqMap_Acc, - alterUniqMap, - addListToUniqMap_C, - adjustUniqMap, - delFromUniqMap, - delListFromUniqMap, - plusUniqMap, - plusUniqMap_C, - plusMaybeUniqMap_C, - plusUniqMapList, - minusUniqMap, - intersectUniqMap, - disjointUniqMap, - mapUniqMap, - filterUniqMap, - partitionUniqMap, - sizeUniqMap, - elemUniqMap, - lookupUniqMap, - lookupWithDefaultUniqMap, - anyUniqMap, - allUniqMap, - -- Non-deterministic functions omitted -) where - -import GhcPrelude - -import UniqFM - -import Unique -import Outputable - -import Data.Semigroup as Semi ( Semigroup(..) ) -import Data.Coerce -import Data.Maybe -import Data.Data - --- | Maps indexed by 'Uniquable' keys -newtype UniqMap k a = UniqMap (UniqFM (k, a)) - deriving (Data, Eq, Functor) -type role UniqMap nominal representational - -instance Semigroup (UniqMap k a) where - (<>) = plusUniqMap - -instance Monoid (UniqMap k a) where - mempty = emptyUniqMap - mappend = (Semi.<>) - -instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where - ppr (UniqMap m) = - brackets $ fsep $ punctuate comma $ - [ ppr k <+> text "->" <+> ppr v - | (k, v) <- eltsUFM m ] - -liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) -liftC f (_, v) (k', v') = (k', f v v') - -emptyUniqMap :: UniqMap k a -emptyUniqMap = UniqMap emptyUFM - -isNullUniqMap :: UniqMap k a -> Bool -isNullUniqMap (UniqMap m) = isNullUFM m - -unitUniqMap :: Uniquable k => k -> a -> UniqMap k a -unitUniqMap k v = UniqMap (unitUFM k (k, v)) - -listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a -listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs]) - -listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a -listToUniqMap_C f kvs = UniqMap $ - listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs] - -addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a -addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v) - -addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a -addListToUniqMap (UniqMap m) kvs = UniqMap $ - addListToUFM m [(k,(k,v)) | (k,v) <- kvs] - -addToUniqMap_C :: Uniquable k - => (a -> a -> a) - -> UniqMap k a - -> k - -> a - -> UniqMap k a -addToUniqMap_C f (UniqMap m) k v = UniqMap $ - addToUFM_C (liftC f) m k (k, v) - -addToUniqMap_Acc :: Uniquable k - => (b -> a -> a) - -> (b -> a) - -> UniqMap k a - -> k - -> b - -> UniqMap k a -addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $ - addToUFM_Acc (\b (k, v) -> (k, exi b v)) - (\b -> (k0, new b)) - m k0 v0 - -alterUniqMap :: Uniquable k - => (Maybe a -> Maybe a) - -> UniqMap k a - -> k - -> UniqMap k a -alterUniqMap f (UniqMap m) k = UniqMap $ - alterUFM (fmap (k,) . f . fmap snd) m k - -addListToUniqMap_C - :: Uniquable k - => (a -> a -> a) - -> UniqMap k a - -> [(k, a)] - -> UniqMap k a -addListToUniqMap_C f (UniqMap m) kvs = UniqMap $ - addListToUFM_C (liftC f) m - [(k,(k,v)) | (k,v) <- kvs] - -adjustUniqMap - :: Uniquable k - => (a -> a) - -> UniqMap k a - -> k - -> UniqMap k a -adjustUniqMap f (UniqMap m) k = UniqMap $ - adjustUFM (\(_,v) -> (k,f v)) m k - -delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a -delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k - -delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a -delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks - -plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a -plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2 - -plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a -plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ - plusUFM_C (liftC f) m1 m2 - -plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a -plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ - plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2 - -plusUniqMapList :: [UniqMap k a] -> UniqMap k a -plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs) - -minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a -minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2 - -intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a -intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2 - -disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool -disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2 - -mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b -mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance - -filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a -filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m - -partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a) -partitionUniqMap f (UniqMap m) = - coerce $ partitionUFM (f . snd) m - -sizeUniqMap :: UniqMap k a -> Int -sizeUniqMap (UniqMap m) = sizeUFM m - -elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool -elemUniqMap k (UniqMap m) = elemUFM k m - -lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a -lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k) - -lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a -lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k)) - -anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool -anyUniqMap f (UniqMap m) = anyUFM (f . snd) m - -allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool -allUniqMap f (UniqMap m) = allUFM (f . snd) m diff --git a/utils/UniqSet.hs b/utils/UniqSet.hs deleted file mode 100644 --- a/utils/UniqSet.hs +++ /dev/null @@ -1,195 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[UniqSet]{Specialised sets, for things with @Uniques@} - -Based on @UniqFMs@ (as you would expect). - -Basically, the things need to be in class @Uniquable@. --} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module UniqSet ( - -- * Unique set type - UniqSet, -- type synonym for UniqFM a - getUniqSet, - pprUniqSet, - - -- ** Manipulating these sets - emptyUniqSet, - unitUniqSet, - mkUniqSet, - addOneToUniqSet, addListToUniqSet, - delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, - delListFromUniqSet_Directly, - unionUniqSets, unionManyUniqSets, - minusUniqSet, uniqSetMinusUFM, - intersectUniqSets, - restrictUniqSetToUFM, - uniqSetAny, uniqSetAll, - elementOfUniqSet, - elemUniqSet_Directly, - filterUniqSet, - filterUniqSet_Directly, - sizeUniqSet, - isEmptyUniqSet, - lookupUniqSet, - lookupUniqSet_Directly, - partitionUniqSet, - mapUniqSet, - unsafeUFMToUniqSet, - nonDetEltsUniqSet, - nonDetKeysUniqSet, - nonDetFoldUniqSet, - nonDetFoldUniqSet_Directly - ) where - -import GhcPrelude - -import UniqFM -import Unique -import Data.Coerce -import Outputable -import Data.Data -import qualified Data.Semigroup as Semi - --- Note [UniqSet invariant] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- UniqSet has the following invariant: --- The keys in the map are the uniques of the values --- It means that to implement mapUniqSet you have to update --- both the keys and the values. - -newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} - deriving (Data, Semi.Semigroup, Monoid) - -emptyUniqSet :: UniqSet a -emptyUniqSet = UniqSet emptyUFM - -unitUniqSet :: Uniquable a => a -> UniqSet a -unitUniqSet x = UniqSet $ unitUFM x x - -mkUniqSet :: Uniquable a => [a] -> UniqSet a -mkUniqSet = foldl' addOneToUniqSet emptyUniqSet - -addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) - -addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a -addListToUniqSet = foldl' addOneToUniqSet - -delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) - -delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a -delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) - -delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a -delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) - -delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a -delListFromUniqSet_Directly (UniqSet s) l = - UniqSet (delListFromUFM_Directly s l) - -unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) - -unionManyUniqSets :: [UniqSet a] -> UniqSet a -unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet - -minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a -minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) - -intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) - -restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a -restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) - -uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a -uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) - -elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool -elementOfUniqSet a (UniqSet s) = elemUFM a s - -elemUniqSet_Directly :: Unique -> UniqSet a -> Bool -elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s - -filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a -filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) - -filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt -filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) - -partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) -partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) - -uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAny p (UniqSet s) = anyUFM p s - -uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAll p (UniqSet s) = allUFM p s - -sizeUniqSet :: UniqSet a -> Int -sizeUniqSet (UniqSet s) = sizeUFM s - -isEmptyUniqSet :: UniqSet a -> Bool -isEmptyUniqSet (UniqSet s) = isNullUFM s - -lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b -lookupUniqSet (UniqSet s) k = lookupUFM s k - -lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a -lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetEltsUniqSet :: UniqSet elt -> [elt] -nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetKeysUniqSet :: UniqSet elt -> [Unique] -nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a -nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a -nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s - --- See Note [UniqSet invariant] -mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b -mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet - --- Two 'UniqSet's are considered equal if they contain the same --- uniques. -instance Eq (UniqSet a) where - UniqSet a == UniqSet b = equalKeysUFM a b - -getUniqSet :: UniqSet a -> UniqFM a -getUniqSet = getUniqSet' - --- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ --- assuming, without checking, that it maps each 'Unique' to a value --- that has that 'Unique'. See Note [UniqSet invariant]. -unsafeUFMToUniqSet :: UniqFM a -> UniqSet a -unsafeUFMToUniqSet = UniqSet - -instance Outputable a => Outputable (UniqSet a) where - ppr = pprUniqSet ppr - -pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc --- It's OK to use nonDetUFMToList here because we only use it for --- pretty-printing. -pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet diff --git a/utils/Util.hs b/utils/Util.hs deleted file mode 100644 --- a/utils/Util.hs +++ /dev/null @@ -1,1475 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} - --- | Highly random utility functions --- -module Util ( - -- * Flags dependent on the compiler build - ghciSupported, debugIsOn, - ghciTablesNextToCode, - isWindowsHost, isDarwinHost, - - -- * Miscellaneous higher-order functions - applyWhen, nTimes, - - -- * General list processing - zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, - - zipWithLazy, zipWith3Lazy, - - filterByList, filterByLists, partitionByList, - - unzipWith, - - mapFst, mapSnd, chkAppend, - mapAndUnzip, mapAndUnzip3, mapAccumL2, - filterOut, partitionWith, - - dropWhileEndLE, spanEnd, last2, lastMaybe, - - foldl1', foldl2, count, countWhile, all2, - - lengthExceeds, lengthIs, lengthIsNot, - lengthAtLeast, lengthAtMost, lengthLessThan, - listLengthCmp, atLength, - equalLength, compareLength, leLength, ltLength, - - isSingleton, only, singleton, - notNull, snocView, - - isIn, isn'tIn, - - chunkList, - - changeLast, - - whenNonEmpty, - - -- * Tuples - fstOf3, sndOf3, thdOf3, - firstM, first3M, secondM, - fst3, snd3, third3, - uncurry3, - liftFst, liftSnd, - - -- * List operations controlled by another list - takeList, dropList, splitAtList, split, - dropTail, capitalise, - - -- * Sorting - sortWith, minWith, nubSort, ordNub, - - -- * Comparisons - isEqual, eqListBy, eqMaybeBy, - thenCmp, cmpList, - removeSpaces, - (<&&>), (<||>), - - -- * Edit distance - fuzzyMatch, fuzzyLookup, - - -- * Transitive closures - transitiveClosure, - - -- * Strictness - seqList, - - -- * Module names - looksLikeModuleName, - looksLikePackageName, - - -- * Argument processing - getCmd, toCmdArgs, toArgs, - - -- * Integers - exactLog2, - - -- * Floating point - readRational, - readHexRational, - - -- * IO-ish utilities - doesDirNameExist, - getModificationUTCTime, - modificationTimeIfExists, - withAtomicRename, - - global, consIORef, globalM, - sharedGlobal, sharedGlobalM, - - -- * Filenames and paths - Suffix, - splitLongestPrefix, - escapeSpaces, - Direction(..), reslash, - makeRelativeTo, - - -- * Utils for defining Data instances - abstractConstr, abstractDataType, mkNoRepType, - - -- * Utils for printing C code - charToC, - - -- * Hashing - hashString, - - -- * Call stacks - HasCallStack, - HasDebugCallStack, - - -- * Utils for flags - OverridingBool(..), - overrideWith, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Exception -import PlainPanic - -import Data.Data -import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.List hiding (group) -import Data.List.NonEmpty ( NonEmpty(..) ) - -import GHC.Exts -import GHC.Stack (HasCallStack) - -import Control.Applicative ( liftA2 ) -import Control.Monad ( liftM, guard ) -import Control.Monad.IO.Class ( MonadIO, liftIO ) -import GHC.Conc.Sync ( sharedCAF ) -import System.IO.Error as IO ( isDoesNotExistError ) -import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) -import System.FilePath - -import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper - , isHexDigit, digitToInt ) -import Data.Int -import Data.Ratio ( (%) ) -import Data.Ord ( comparing ) -import Data.Bits -import Data.Word -import qualified Data.IntMap as IM -import qualified Data.Set as Set - -import Data.Time - -#if defined(DEBUG) -import {-# SOURCE #-} Outputable ( warnPprTrace, text ) -#endif - -infixr 9 `thenCmp` - -{- -************************************************************************ -* * -\subsection{Is DEBUG on, are we on Windows, etc?} -* * -************************************************************************ - -These booleans are global constants, set by CPP flags. They allow us to -recompile a single module (this one) to change whether or not debug output -appears. They sometimes let us avoid even running CPP elsewhere. - -It's important that the flags are literal constants (True/False). Then, -with -0, tests of the flags in other modules will simplify to the correct -branch of the conditional, thereby dropping debug code altogether when -the flags are off. --} - -ghciSupported :: Bool -#if defined(HAVE_INTERNAL_INTERPRETER) -ghciSupported = True -#else -ghciSupported = False -#endif - -debugIsOn :: Bool -#if defined(DEBUG) -debugIsOn = True -#else -debugIsOn = False -#endif - -ghciTablesNextToCode :: Bool -#if defined(GHCI_TABLES_NEXT_TO_CODE) -ghciTablesNextToCode = True -#else -ghciTablesNextToCode = False -#endif - -isWindowsHost :: Bool -#if defined(mingw32_HOST_OS) -isWindowsHost = True -#else -isWindowsHost = False -#endif - -isDarwinHost :: Bool -#if defined(darwin_HOST_OS) -isDarwinHost = True -#else -isDarwinHost = False -#endif - -{- -************************************************************************ -* * -\subsection{Miscellaneous higher-order functions} -* * -************************************************************************ --} - --- | Apply a function iff some condition is met. -applyWhen :: Bool -> (a -> a) -> a -> a -applyWhen True f x = f x -applyWhen _ _ x = x - --- | A for loop: Compose a function with itself n times. (nth rather than twice) -nTimes :: Int -> (a -> a) -> (a -> a) -nTimes 0 _ = id -nTimes 1 f = f -nTimes n f = f . nTimes (n-1) f - -fstOf3 :: (a,b,c) -> a -sndOf3 :: (a,b,c) -> b -thdOf3 :: (a,b,c) -> c -fstOf3 (a,_,_) = a -sndOf3 (_,b,_) = b -thdOf3 (_,_,c) = c - -fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) -fst3 f (a, b, c) = (f a, b, c) - -snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) -snd3 f (a, b, c) = (a, f b, c) - -third3 :: (c -> d) -> (a, b, c) -> (a, b, d) -third3 f (a, b, c) = (a, b, f c) - -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f (a, b, c) = f a b c - -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a,c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c,a) = (c, f a) - -firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) -firstM f (x, y) = liftM (\x' -> (x', y)) (f x) - -first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) -first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) - -secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) -secondM f (x, y) = (x,) <$> f y - -{- -************************************************************************ -* * -\subsection[Utils-lists]{General list processing} -* * -************************************************************************ --} - -filterOut :: (a->Bool) -> [a] -> [a] --- ^ Like filter, only it reverses the sense of the test -filterOut _ [] = [] -filterOut p (x:xs) | p x = filterOut p xs - | otherwise = x : filterOut p xs - -partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) --- ^ Uses a function to determine which of two output lists an input element should join -partitionWith _ [] = ([],[]) -partitionWith f (x:xs) = case f x of - Left b -> (b:bs, cs) - Right c -> (bs, c:cs) - where (bs,cs) = partitionWith f xs - -chkAppend :: [a] -> [a] -> [a] --- Checks for the second argument being empty --- Used in situations where that situation is common -chkAppend xs ys - | null ys = xs - | otherwise = xs ++ ys - -{- -A paranoid @zip@ (and some @zipWith@ friends) that checks the lists -are of equal length. Alastair Reid thinks this should only happen if -DEBUGging on; hey, why not? --} - -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] - -#if !defined(DEBUG) -zipEqual _ = zip -zipWithEqual _ = zipWith -zipWith3Equal _ = zipWith3 -zipWith4Equal _ = zipWith4 -#else -zipEqual _ [] [] = [] -zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs -zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) - -zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs -zipWithEqual _ _ [] [] = [] -zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) - -zipWith3Equal msg z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3Equal msg z as bs cs -zipWith3Equal _ _ [] [] [] = [] -zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) - -zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4Equal msg z as bs cs ds -zipWith4Equal _ _ [] [] [] [] = [] -zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) -#endif - --- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) -zipLazy :: [a] -> [b] -> [(a,b)] -zipLazy [] _ = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys - --- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. --- The length of the output is always the same as the length of the first --- list. -zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWithLazy _ [] _ = [] -zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs - --- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. --- The length of the output is always the same as the length of the first --- list. -zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] -zipWith3Lazy _ [] _ _ = [] -zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs - --- | 'filterByList' takes a list of Bools and a list of some elements and --- filters out these elements for which the corresponding value in the list of --- Bools is False. This function does not check whether the lists have equal --- length. -filterByList :: [Bool] -> [a] -> [a] -filterByList (True:bs) (x:xs) = x : filterByList bs xs -filterByList (False:bs) (_:xs) = filterByList bs xs -filterByList _ _ = [] - --- | 'filterByLists' takes a list of Bools and two lists as input, and --- outputs a new list consisting of elements from the last two input lists. For --- each Bool in the list, if it is 'True', then it takes an element from the --- former list. If it is 'False', it takes an element from the latter list. --- The elements taken correspond to the index of the Bool in its list. --- For example: --- --- @ --- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" --- @ --- --- This function does not check whether the lists have equal length. -filterByLists :: [Bool] -> [a] -> [a] -> [a] -filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys -filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys -filterByLists _ _ _ = [] - --- | 'partitionByList' takes a list of Bools and a list of some elements and --- partitions the list according to the list of Bools. Elements corresponding --- to 'True' go to the left; elements corresponding to 'False' go to the right. --- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ --- This function does not check whether the lists have equal --- length; when one list runs out, the function stops. -partitionByList :: [Bool] -> [a] -> ([a], [a]) -partitionByList = go [] [] - where - go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs - go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs - go trues falses _ _ = (reverse trues, reverse falses) - -stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] --- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in --- the places where @p@ returns @True@ - -stretchZipWith _ _ _ [] _ = [] -stretchZipWith p z f (x:xs) ys - | p x = f x z : stretchZipWith p z f xs ys - | otherwise = case ys of - [] -> [] - (y:ys) -> f x y : stretchZipWith p z f xs ys - -mapFst :: (a->c) -> [(a,b)] -> [(c,b)] -mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] - -mapFst f xys = [(f x, y) | (x,y) <- xys] -mapSnd f xys = [(x, f y) | (x,y) <- xys] - -mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) - -mapAndUnzip _ [] = ([], []) -mapAndUnzip f (x:xs) - = let (r1, r2) = f x - (rs1, rs2) = mapAndUnzip f xs - in - (r1:rs1, r2:rs2) - -mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) - -mapAndUnzip3 _ [] = ([], [], []) -mapAndUnzip3 f (x:xs) - = let (r1, r2, r3) = f x - (rs1, rs2, rs3) = mapAndUnzip3 f xs - in - (r1:rs1, r2:rs2, r3:rs3) - -zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) -zipWithAndUnzip f (a:as) (b:bs) - = let (r1, r2) = f a b - (rs1, rs2) = zipWithAndUnzip f as bs - in - (r1:rs1, r2:rs2) -zipWithAndUnzip _ _ _ = ([],[]) - --- | This has the effect of making the two lists have equal length by dropping --- the tail of the longer one. -zipAndUnzip :: [a] -> [b] -> ([a],[b]) -zipAndUnzip (a:as) (b:bs) - = let (rs1, rs2) = zipAndUnzip as bs - in - (a:rs1, b:rs2) -zipAndUnzip _ _ = ([],[]) - -mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) -mapAccumL2 f s1 s2 xs = (s1', s2', ys) - where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of - (s1', s2', y) -> ((s1', s2'), y)) - (s1, s2) xs - --- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: --- --- @ --- atLength atLenPred atEndPred ls n --- | n < 0 = atLenPred ls --- | length ls < n = atEndPred (n - length ls) --- | otherwise = atLenPred (drop n ls) --- @ -atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) - -- NB: arg passed to this function may be [] - -> b -- Called when length ls < n - -> [a] - -> Int - -> b -atLength atLenPred atEnd ls0 n0 - | n0 < 0 = atLenPred ls0 - | otherwise = go n0 ls0 - where - -- go's first arg n >= 0 - go 0 ls = atLenPred ls - go _ [] = atEnd -- n > 0 here - go n (_:xs) = go (n-1) xs - --- Some special cases of atLength: - --- | @(lengthExceeds xs n) = (length xs > n)@ -lengthExceeds :: [a] -> Int -> Bool -lengthExceeds lst n - | n < 0 - = True - | otherwise - = atLength notNull False lst n - --- | @(lengthAtLeast xs n) = (length xs >= n)@ -lengthAtLeast :: [a] -> Int -> Bool -lengthAtLeast = atLength (const True) False - --- | @(lengthIs xs n) = (length xs == n)@ -lengthIs :: [a] -> Int -> Bool -lengthIs lst n - | n < 0 - = False - | otherwise - = atLength null False lst n - --- | @(lengthIsNot xs n) = (length xs /= n)@ -lengthIsNot :: [a] -> Int -> Bool -lengthIsNot lst n - | n < 0 = True - | otherwise = atLength notNull True lst n - --- | @(lengthAtMost xs n) = (length xs <= n)@ -lengthAtMost :: [a] -> Int -> Bool -lengthAtMost lst n - | n < 0 - = False - | otherwise - = atLength null True lst n - --- | @(lengthLessThan xs n) == (length xs < n)@ -lengthLessThan :: [a] -> Int -> Bool -lengthLessThan = atLength (const False) True - -listLengthCmp :: [a] -> Int -> Ordering -listLengthCmp = atLength atLen atEnd - where - atEnd = LT -- Not yet seen 'n' elts, so list length is < n. - - atLen [] = EQ - atLen _ = GT - -equalLength :: [a] -> [b] -> Bool --- ^ True if length xs == length ys -equalLength [] [] = True -equalLength (_:xs) (_:ys) = equalLength xs ys -equalLength _ _ = False - -compareLength :: [a] -> [b] -> Ordering -compareLength [] [] = EQ -compareLength (_:xs) (_:ys) = compareLength xs ys -compareLength [] _ = LT -compareLength _ [] = GT - -leLength :: [a] -> [b] -> Bool --- ^ True if length xs <= length ys -leLength xs ys = case compareLength xs ys of - LT -> True - EQ -> True - GT -> False - -ltLength :: [a] -> [b] -> Bool --- ^ True if length xs < length ys -ltLength xs ys = case compareLength xs ys of - LT -> True - EQ -> False - GT -> False - ----------------------------- -singleton :: a -> [a] -singleton x = [x] - -isSingleton :: [a] -> Bool -isSingleton [_] = True -isSingleton _ = False - -notNull :: [a] -> Bool -notNull [] = False -notNull _ = True - -only :: [a] -> a -#if defined(DEBUG) -only [a] = a -#else -only (a:_) = a -#endif -only _ = panic "Util: only" - --- Debugging/specialising versions of \tr{elem} and \tr{notElem} - -isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool - -# if !defined(DEBUG) -isIn _msg x ys = x `elem` ys -isn'tIn _msg x ys = x `notElem` ys - -# else /* DEBUG */ -isIn msg x ys - = elem100 0 x ys - where - elem100 :: Eq a => Int -> a -> [a] -> Bool - elem100 _ _ [] = False - elem100 i x (y:ys) - | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) - | otherwise = x == y || elem100 (i + 1) x ys - -isn'tIn msg x ys - = notElem100 0 x ys - where - notElem100 :: Eq a => Int -> a -> [a] -> Bool - notElem100 _ _ [] = True - notElem100 i x (y:ys) - | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) - | otherwise = x /= y && notElem100 (i + 1) x ys -# endif /* DEBUG */ - - --- | Split a list into chunks of /n/ elements -chunkList :: Int -> [a] -> [[a]] -chunkList _ [] = [] -chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs - --- | Replace the last element of a list with another element. -changeLast :: [a] -> a -> [a] -changeLast [] _ = panic "changeLast" -changeLast [_] x = [x] -changeLast (x:xs) x' = x : changeLast xs x' - -whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () -whenNonEmpty [] _ = pure () -whenNonEmpty (x:xs) f = f (x :| xs) - -{- -************************************************************************ -* * -\subsubsection{Sort utils} -* * -************************************************************************ --} - -minWith :: Ord b => (a -> b) -> [a] -> a -minWith get_key xs = ASSERT( not (null xs) ) - head (sortWith get_key xs) - -nubSort :: Ord a => [a] -> [a] -nubSort = Set.toAscList . Set.fromList - --- | Remove duplicates but keep elements in order. --- O(n * log n) -ordNub :: Ord a => [a] -> [a] -ordNub xs - = go Set.empty xs - where - go _ [] = [] - go s (x:xs) - | Set.member x s = go s xs - | otherwise = x : go (Set.insert x s) xs - - -{- -************************************************************************ -* * -\subsection[Utils-transitive-closure]{Transitive closure} -* * -************************************************************************ - -This algorithm for transitive closure is straightforward, albeit quadratic. --} - -transitiveClosure :: (a -> [a]) -- Successor function - -> (a -> a -> Bool) -- Equality predicate - -> [a] - -> [a] -- The transitive closure - -transitiveClosure succ eq xs - = go [] xs - where - go done [] = done - go done (x:xs) | x `is_in` done = go done xs - | otherwise = go (x:done) (succ x ++ xs) - - _ `is_in` [] = False - x `is_in` (y:ys) | eq x y = True - | otherwise = x `is_in` ys - -{- -************************************************************************ -* * -\subsection[Utils-accum]{Accumulating} -* * -************************************************************************ - -A combination of foldl with zip. It works with equal length lists. --} - -foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc -foldl2 _ z [] [] = z -foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs -foldl2 _ _ _ _ = panic "Util: foldl2" - -all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool --- True if the lists are the same length, and --- all corresponding elements satisfy the predicate -all2 _ [] [] = True -all2 p (x:xs) (y:ys) = p x y && all2 p xs ys -all2 _ _ _ = False - --- Count the number of times a predicate is true - -count :: (a -> Bool) -> [a] -> Int -count p = go 0 - where go !n [] = n - go !n (x:xs) | p x = go (n+1) xs - | otherwise = go n xs - -countWhile :: (a -> Bool) -> [a] -> Int --- Length of an /initial prefix/ of the list satsifying p -countWhile p = go 0 - where go !n (x:xs) | p x = go (n+1) xs - go !n _ = n - -{- -@splitAt@, @take@, and @drop@ but with length of another -list giving the break-off point: --} - -takeList :: [b] -> [a] -> [a] --- (takeList as bs) trims bs to the be same length --- as as, unless as is longer in which case it's a no-op -takeList [] _ = [] -takeList (_:xs) ls = - case ls of - [] -> [] - (y:ys) -> y : takeList xs ys - -dropList :: [b] -> [a] -> [a] -dropList [] xs = xs -dropList _ xs@[] = xs -dropList (_:xs) (_:ys) = dropList xs ys - - -splitAtList :: [b] -> [a] -> ([a], [a]) -splitAtList [] xs = ([], xs) -splitAtList _ xs@[] = (xs, xs) -splitAtList (_:xs) (y:ys) = (y:ys', ys'') - where - (ys', ys'') = splitAtList xs ys - --- drop from the end of a list -dropTail :: Int -> [a] -> [a] --- Specification: dropTail n = reverse . drop n . reverse --- Better implemention due to Joachim Breitner --- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html -dropTail n xs - = go (drop n xs) xs - where - go (_:ys) (x:xs) = x : go ys xs - go _ _ = [] -- Stop when ys runs out - -- It'll always run out before xs does - --- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, --- but is lazy in the elements and strict in the spine. For reasonably short lists, --- such as path names and typical lines of text, dropWhileEndLE is generally --- faster than dropWhileEnd. Its advantage is magnified when the predicate is --- expensive--using dropWhileEndLE isSpace to strip the space off a line of text --- is generally much faster than using dropWhileEnd isSpace for that purpose. --- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse --- Pay attention to the short-circuit (&&)! The order of its arguments is the only --- difference between dropWhileEnd and dropWhileEndLE. -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- | @spanEnd p l == reverse (span p (reverse l))@. The first list --- returns actually comes after the second list (when you look at the --- input list). -spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) -spanEnd p l = go l [] [] l - where go yes _rev_yes rev_no [] = (yes, reverse rev_no) - go yes rev_yes rev_no (x:xs) - | p x = go yes (x : rev_yes) rev_no xs - | otherwise = go xs [] (x : rev_yes ++ rev_no) xs - --- | Get the last two elements in a list. Partial! -{-# INLINE last2 #-} -last2 :: [a] -> (a,a) -last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) - where - partialError = panic "last2 - list length less than two" - -lastMaybe :: [a] -> Maybe a -lastMaybe [] = Nothing -lastMaybe xs = Just $ last xs - --- | Split a list into its last element and the initial part of the list. --- @snocView xs = Just (init xs, last xs)@ for non-empty lists. --- @snocView xs = Nothing@ otherwise. --- Unless both parts of the result are guaranteed to be used --- prefer separate calls to @last@ + @init@. --- If you are guaranteed to use both, this will --- be more efficient. -snocView :: [a] -> Maybe ([a],a) -snocView [] = Nothing -snocView xs - | (xs,x) <- go xs - = Just (xs,x) - where - go :: [a] -> ([a],a) - go [x] = ([],x) - go (x:xs) - | !(xs',x') <- go xs - = (x:xs', x') - go [] = error "impossible" - -split :: Char -> String -> [String] -split c s = case rest of - [] -> [chunk] - _:rest -> chunk : split c rest - where (chunk, rest) = break (==c) s - --- | Convert a word to title case by capitalising the first letter -capitalise :: String -> String -capitalise [] = [] -capitalise (c:cs) = toUpper c : cs - - -{- -************************************************************************ -* * -\subsection[Utils-comparison]{Comparisons} -* * -************************************************************************ --} - -isEqual :: Ordering -> Bool --- Often used in (isEqual (a `compare` b)) -isEqual GT = False -isEqual EQ = True -isEqual LT = False - -thenCmp :: Ordering -> Ordering -> Ordering -{-# INLINE thenCmp #-} -thenCmp EQ ordering = ordering -thenCmp ordering _ = ordering - -eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy _ [] [] = True -eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy _ _ _ = False - -eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool -eqMaybeBy _ Nothing Nothing = True -eqMaybeBy eq (Just x) (Just y) = eq x y -eqMaybeBy _ _ _ = False - -cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering - -- `cmpList' uses a user-specified comparer - -cmpList _ [] [] = EQ -cmpList _ [] _ = LT -cmpList _ _ [] = GT -cmpList cmp (a:as) (b:bs) - = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } - -removeSpaces :: String -> String -removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace - --- Boolean operators lifted to Applicative -(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool -(<&&>) = liftA2 (&&) -infixr 3 <&&> -- same as (&&) - -(<||>) :: Applicative f => f Bool -> f Bool -> f Bool -(<||>) = liftA2 (||) -infixr 2 <||> -- same as (||) - -{- -************************************************************************ -* * -\subsection{Edit distance} -* * -************************************************************************ --} - --- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. --- See: . --- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing --- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). --- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and --- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation -restrictedDamerauLevenshteinDistance :: String -> String -> Int -restrictedDamerauLevenshteinDistance str1 str2 - = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 - where - m = length str1 - n = length str2 - -restrictedDamerauLevenshteinDistanceWithLengths - :: Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 - | m <= n - = if n <= 32 -- n must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 - - | otherwise - = if m <= 32 -- m must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 - -restrictedDamerauLevenshteinDistance' - :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 - | [] <- str1 = n - | otherwise = extractAnswer $ - foldl' (restrictedDamerauLevenshteinDistanceWorker - (matchVectors str1) top_bit_mask vector_mask) - (0, 0, m_ones, 0, m) str2 - where - m_ones@vector_mask = (2 ^ m) - 1 - top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy - extractAnswer (_, _, _, _, distance) = distance - -restrictedDamerauLevenshteinDistanceWorker - :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv - -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) -restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask - (pm, d0, vp, vn, distance) char2 - = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ - seq pm' $ seq d0' $ seq vp' $ seq vn' $ - seq distance'' $ seq char2 $ - (pm', d0', vp', vn', distance'') - where - pm' = IM.findWithDefault 0 (ord char2) str1_mvs - - d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) - .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn - -- No need to mask the shiftL because of the restricted range of pm - - hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) - hn' = d0' .&. vp - - hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask - hn'_shift = (hn' `shiftL` 1) .&. vector_mask - vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) - vn' = d0' .&. hp'_shift - - distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance - distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' - -sizedComplement :: Bits bv => bv -> bv -> bv -sizedComplement vector_mask vect = vector_mask `xor` vect - -matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv -matchVectors = snd . foldl' go (0 :: Int, IM.empty) - where - go (ix, im) char = let ix' = ix + 1 - im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im - in seq ix' $ seq im' $ (ix', im') - -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' - :: Word32 -> Int -> Int -> String -> String -> Int #-} -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' - :: Integer -> Int -> Int -> String -> String -> Int #-} - -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker - :: IM.IntMap Word32 -> Word32 -> Word32 - -> (Word32, Word32, Word32, Word32, Int) - -> Char -> (Word32, Word32, Word32, Word32, Int) #-} -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker - :: IM.IntMap Integer -> Integer -> Integer - -> (Integer, Integer, Integer, Integer, Int) - -> Char -> (Integer, Integer, Integer, Integer, Int) #-} - -{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} -{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} - -{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} -{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} - -fuzzyMatch :: String -> [String] -> [String] -fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] - --- | Search for possible matches to the users input in the given list, --- returning a small number of ranked results -fuzzyLookup :: String -> [(String,a)] -> [a] -fuzzyLookup user_entered possibilites - = map fst $ take mAX_RESULTS $ sortBy (comparing snd) - [ (poss_val, distance) | (poss_str, poss_val) <- possibilites - , let distance = restrictedDamerauLevenshteinDistance - poss_str user_entered - , distance <= fuzzy_threshold ] - where - -- Work out an approriate match threshold: - -- We report a candidate if its edit distance is <= the threshold, - -- The threshold is set to about a quarter of the # of characters the user entered - -- Length Threshold - -- 1 0 -- Don't suggest *any* candidates - -- 2 1 -- for single-char identifiers - -- 3 1 - -- 4 1 - -- 5 1 - -- 6 2 - -- - fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) - mAX_RESULTS = 3 - -{- -************************************************************************ -* * -\subsection[Utils-pairs]{Pairs} -* * -************************************************************************ --} - -unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] -unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs - -seqList :: [a] -> b -> b -seqList [] b = b -seqList (x:xs) b = x `seq` seqList xs b - - -{- -************************************************************************ -* * - Globals and the RTS -* * -************************************************************************ - -When a plugin is loaded, it currently gets linked against a *newly -loaded* copy of the GHC package. This would not be a problem, except -that the new copy has its own mutable state that is not shared with -that state that has already been initialized by the original GHC -package. - -(Note that if the GHC executable was dynamically linked this -wouldn't be a problem, because we could share the GHC library it -links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) - -The solution is to make use of @sharedCAF@ through @sharedGlobal@ -for globals that are shared between multiple copies of ghc packages. --} - --- Global variables: - -global :: a -> IORef a -global a = unsafePerformIO (newIORef a) - -consIORef :: IORef [a] -> a -> IO () -consIORef var x = do - atomicModifyIORef' var (\xs -> (x:xs,())) - -globalM :: IO a -> IORef a -globalM ma = unsafePerformIO (ma >>= newIORef) - --- Shared global variables: - -sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobal a get_or_set = unsafePerformIO $ - newIORef a >>= flip sharedCAF get_or_set - -sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobalM ma get_or_set = unsafePerformIO $ - ma >>= newIORef >>= flip sharedCAF get_or_set - --- Module names: - -looksLikeModuleName :: String -> Bool -looksLikeModuleName [] = False -looksLikeModuleName (c:cs) = isUpper c && go cs - where go [] = True - go ('.':cs) = looksLikeModuleName cs - go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs - --- Similar to 'parse' for Distribution.Package.PackageName, --- but we don't want to depend on Cabal. -looksLikePackageName :: String -> Bool -looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' - -{- -Akin to @Prelude.words@, but acts like the Bourne shell, treating -quoted strings as Haskell Strings, and also parses Haskell [String] -syntax. --} - -getCmd :: String -> Either String -- Error - (String, String) -- (Cmd, Rest) -getCmd s = case break isSpace $ dropWhile isSpace s of - ([], _) -> Left ("Couldn't find command in " ++ show s) - res -> Right res - -toCmdArgs :: String -> Either String -- Error - (String, [String]) -- (Cmd, Args) -toCmdArgs s = case getCmd s of - Left err -> Left err - Right (cmd, s') -> case toArgs s' of - Left err -> Left err - Right args -> Right (cmd, args) - -toArgs :: String -> Either String -- Error - [String] -- Args -toArgs str - = case dropWhile isSpace str of - s@('[':_) -> case reads s of - [(args, spaces)] - | all isSpace spaces -> - Right args - _ -> - Left ("Couldn't read " ++ show str ++ " as [String]") - s -> toArgs' s - where - toArgs' :: String -> Either String [String] - -- Remove outer quotes: - -- > toArgs' "\"foo\" \"bar baz\"" - -- Right ["foo", "bar baz"] - -- - -- Keep inner quotes: - -- > toArgs' "-DFOO=\"bar baz\"" - -- Right ["-DFOO=\"bar baz\""] - toArgs' s = case dropWhile isSpace s of - [] -> Right [] - ('"' : _) -> do - -- readAsString removes outer quotes - (arg, rest) <- readAsString s - (arg:) `fmap` toArgs' rest - s' -> case break (isSpace <||> (== '"')) s' of - (argPart1, s''@('"':_)) -> do - (argPart2, rest) <- readAsString s'' - -- show argPart2 to keep inner quotes - ((argPart1 ++ show argPart2):) `fmap` toArgs' rest - (arg, s'') -> (arg:) `fmap` toArgs' s'' - - readAsString :: String -> Either String (String, String) - readAsString s = case reads s of - [(arg, rest)] - -- rest must either be [] or start with a space - | all isSpace (take 1 rest) -> - Right (arg, rest) - _ -> - Left ("Couldn't read " ++ show s ++ " as String") ------------------------------------------------------------------------------ --- Integers - --- | Determine the $\log_2$ of exact powers of 2 -exactLog2 :: Integer -> Maybe Integer -exactLog2 x - | x <= 0 = Nothing - | x > fromIntegral (maxBound :: Int32) = Nothing - | x' .&. (-x') /= x' = Nothing - | otherwise = Just (fromIntegral c) - where - x' = fromIntegral x :: Int32 - c = countTrailingZeros x' - -{- --- ----------------------------------------------------------------------------- --- Floats --} - -readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" -readRational__ r = do - (n,d,s) <- readFix r - (k,t) <- readExp s - return ((n%1)*10^^(k-d), t) - where - readFix r = do - (ds,s) <- lexDecDigits r - (ds',t) <- lexDotDigits s - return (read (ds++ds'), length ds', t) - - readExp (e:s) | e `elem` "eE" = readExp' s - readExp s = return (0,s) - - readExp' ('+':s) = readDec s - readExp' ('-':s) = do (k,t) <- readDec s - return (-k,t) - readExp' s = readDec s - - readDec s = do - (ds,r) <- nonnull isDigit s - return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], - r) - - lexDecDigits = nonnull isDigit - - lexDotDigits ('.':s) = return (span' isDigit s) - lexDotDigits s = return ("",s) - - nonnull p s = do (cs@(_:_),t) <- return (span' p s) - return (cs,t) - - span' _ xs@[] = (xs, xs) - span' p xs@(x:xs') - | x == '_' = span' p xs' -- skip "_" (#14473) - | p x = let (ys,zs) = span' p xs' in (x:ys,zs) - | otherwise = ([],xs) - -readRational :: String -> Rational -- NB: *does* handle a leading "-" -readRational top_s - = case top_s of - '-' : xs -> - (read_me xs) - xs -> read_me xs - where - read_me s - = case (do { (x,"") <- readRational__ s ; return x }) of - [x] -> x - [] -> error ("readRational: no parse:" ++ top_s) - _ -> error ("readRational: ambiguous parse:" ++ top_s) - - -readHexRational :: String -> Rational -readHexRational str = - case str of - '-' : xs -> - (readMe xs) - xs -> readMe xs - where - readMe as = - case readHexRational__ as of - Just n -> n - _ -> error ("readHexRational: no parse:" ++ str) - - -readHexRational__ :: String -> Maybe Rational -readHexRational__ ('0' : x : rest) - | x == 'X' || x == 'x' = - do let (front,rest2) = span' isHexDigit rest - guard (not (null front)) - let frontNum = steps 16 0 front - case rest2 of - '.' : rest3 -> - do let (back,rest4) = span' isHexDigit rest3 - guard (not (null back)) - let backNum = steps 16 frontNum back - exp1 = -4 * length back - case rest4 of - p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) - _ -> return (mk backNum exp1) - p : ps | isExp p -> fmap (mk frontNum) (getExp ps) - _ -> Nothing - - where - isExp p = p == 'p' || p == 'P' - - getExp ('+' : ds) = dec ds - getExp ('-' : ds) = fmap negate (dec ds) - getExp ds = dec ds - - mk :: Integer -> Int -> Rational - mk n e = fromInteger n * 2^^e - - dec cs = case span' isDigit cs of - (ds,"") | not (null ds) -> Just (steps 10 0 ds) - _ -> Nothing - - steps base n ds = foldl' (step base) n ds - step base n d = base * n + fromIntegral (digitToInt d) - - span' _ xs@[] = (xs, xs) - span' p xs@(x:xs') - | x == '_' = span' p xs' -- skip "_" (#14473) - | p x = let (ys,zs) = span' p xs' in (x:ys,zs) - | otherwise = ([],xs) - -readHexRational__ _ = Nothing - ------------------------------------------------------------------------------ --- Verify that the 'dirname' portion of a FilePath exists. --- -doesDirNameExist :: FilePath -> IO Bool -doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) - ------------------------------------------------------------------------------ --- Backwards compatibility definition of getModificationTime - -getModificationUTCTime :: FilePath -> IO UTCTime -getModificationUTCTime = getModificationTime - --- -------------------------------------------------------------- --- check existence & modification time at the same time - -modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) -modificationTimeIfExists f = do - (do t <- getModificationUTCTime f; return (Just t)) - `catchIO` \e -> if isDoesNotExistError e - then return Nothing - else ioError e - --- -------------------------------------------------------------- --- atomic file writing by writing to a temporary file first (see #14533) --- --- This should be used in all cases where GHC writes files to disk --- and uses their modification time to skip work later, --- as otherwise a partially written file (e.g. due to crash or Ctrl+C) --- also results in a skip. - -withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a -withAtomicRename targetFile f - | enableAtomicRename = do - -- The temp file must be on the same file system (mount) as the target file - -- to result in an atomic move on most platforms. - -- The standard way to ensure that is to place it into the same directory. - -- This can still be fooled when somebody mounts a different file system - -- at just the right time, but that is not a case we aim to cover here. - let temp = targetFile <.> "tmp" - res <- f temp - liftIO $ renameFile temp targetFile - return res - - | otherwise = f targetFile - where - -- As described in #16450, enabling this causes spurious build failures due - -- to apparently missing files. - enableAtomicRename :: Bool -#if defined(mingw32_BUILD_OS) - enableAtomicRename = False -#else - enableAtomicRename = True -#endif - --- -------------------------------------------------------------- --- split a string at the last character where 'pred' is True, --- returning a pair of strings. The first component holds the string --- up (but not including) the last character for which 'pred' returned --- True, the second whatever comes after (but also not including the --- last character). --- --- If 'pred' returns False for all characters in the string, the original --- string is returned in the first component (and the second one is just --- empty). -splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) -splitLongestPrefix str pred - | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred (reverse str) - -escapeSpaces :: String -> String -escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" - -type Suffix = String - --------------------------------------------------------------- --- * Search path --------------------------------------------------------------- - -data Direction = Forwards | Backwards - -reslash :: Direction -> FilePath -> FilePath -reslash d = f - where f ('/' : xs) = slash : f xs - f ('\\' : xs) = slash : f xs - f (x : xs) = x : f xs - f "" = "" - slash = case d of - Forwards -> '/' - Backwards -> '\\' - -makeRelativeTo :: FilePath -> FilePath -> FilePath -this `makeRelativeTo` that = directory thisFilename - where (thisDirectory, thisFilename) = splitFileName this - thatDirectory = dropFileName that - directory = joinPath $ f (splitPath thisDirectory) - (splitPath thatDirectory) - - f (x : xs) (y : ys) - | x == y = f xs ys - f xs ys = replicate (length ys) ".." ++ xs - -{- -************************************************************************ -* * -\subsection[Utils-Data]{Utils for defining Data instances} -* * -************************************************************************ - -These functions helps us to define Data instances for abstract types. --} - -abstractConstr :: String -> Constr -abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix - -abstractDataType :: String -> DataType -abstractDataType n = mkDataType n [abstractConstr n] - -{- -************************************************************************ -* * -\subsection[Utils-C]{Utils for printing C code} -* * -************************************************************************ --} - -charToC :: Word8 -> String -charToC w = - case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] - | otherwise -> ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] - -{- -************************************************************************ -* * -\subsection[Utils-Hashing]{Utils for hashing} -* * -************************************************************************ --} - --- | A sample hash function for Strings. We keep multiplying by the --- golden ratio and adding. The implementation is: --- --- > hashString = foldl' f golden --- > where f m c = fromIntegral (ord c) * magic + hashInt32 m --- > magic = 0xdeadbeef --- --- Where hashInt32 works just as hashInt shown above. --- --- Knuth argues that repeated multiplication by the golden ratio --- will minimize gaps in the hash space, and thus it's a good choice --- for combining together multiple keys to form one. --- --- Here we know that individual characters c are often small, and this --- produces frequent collisions if we use ord c alone. A --- particular problem are the shorter low ASCII and ISO-8859-1 --- character strings. We pre-multiply by a magic twiddle factor to --- obtain a good distribution. In fact, given the following test: --- --- > testp :: Int32 -> Int --- > testp k = (n - ) . length . group . sort . map hs . take n $ ls --- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] --- > hs = foldl' f golden --- > f m c = fromIntegral (ord c) * k + hashInt32 m --- > n = 100000 --- --- We discover that testp magic = 0. -hashString :: String -> Int32 -hashString = foldl' f golden - where f m c = fromIntegral (ord c) * magic + hashInt32 m - magic = fromIntegral (0xdeadbeef :: Word32) - -golden :: Int32 -golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 --- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 --- but that has bad mulHi properties (even adding 2^32 to get its inverse) --- Whereas the above works well and contains no hash duplications for --- [-32767..65536] - --- | A sample (and useful) hash function for Int32, --- implemented by extracting the uppermost 32 bits of the 64-bit --- result of multiplying by a 33-bit constant. The constant is from --- Knuth, derived from the golden ratio: --- --- > golden = round ((sqrt 5 - 1) * 2^32) --- --- We get good key uniqueness on small inputs --- (a problem with previous versions): --- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 --- -hashInt32 :: Int32 -> Int32 -hashInt32 x = mulHi x golden + x - --- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply -mulHi :: Int32 -> Int32 -> Int32 -mulHi a b = fromIntegral (r `shiftR` 32) - where r :: Int64 - r = fromIntegral a * fromIntegral b - --- | A call stack constraint, but only when 'isDebugOn'. -#if defined(DEBUG) -type HasDebugCallStack = HasCallStack -#else -type HasDebugCallStack = (() :: Constraint) -#endif - -data OverridingBool - = Auto - | Always - | Never - deriving Show - -overrideWith :: Bool -> OverridingBool -> Bool -overrideWith b Auto = b -overrideWith _ Always = True -overrideWith _ Never = False